mathpiper-0.81f+svn4469+dfsg3/0000755000175000017500000000000011722677373016161 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/docs/0000755000175000017500000000000011722677346017111 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/docs/functions_that_need_documentation.txt0000644000175000017500000001345711523151705026621 0ustar giovannigiovanniThe following functions and .mpw files need to be documented (functions that start with * and are indented have already had documentation added to them): AddTerm.mpw AddTerms.mpw DivTermList.mpw MultiDivTerm.mpw MultiplySingleTerm.mpw MultiplyTerms.mpw SubtractTerms.mpw AntiDeriv.mpw //Tensor functions. ApplyDelta.mpw MoveDeltas.mpw Delta.mpw TD.mpw TExplicitSum.mpw TList.mpw TRun.mpw TSimplify.mpw TSum.mpw TSumRest.mpw TSumSimplify.mpw X.mpw ApproxInfSum.mpw ArcCosh.mpw ArcCot.mpw ArcCoth.mpw ArcCsc.mpw ArcCsch.mpw ArcSec.mpw ArcSech.mpw ArcSinNum.mpw ArcSinh.mpw ArcTanN'Taylor.mpw ArcTanNum.mpw ArcTanh.mpw Average.mpw BSearch.mpw BellNumber.mpw BenchCall.mpw BenchShow.mpw Bernoulli1.mpw BernoulliFracPart.mpw BesselI.mpw BesselJ.mpw BesselJN.mpw BesselJN0.mpw BesselNsmall.mpw BesselY.mpw Beta.mpw BinaryFactors.mpw BisectSqrt.mpw BitCount.java BitsToDigits.java BitsToDigits.mpw BoundRealRoots.mpw BrentLn.mpw BuiltinAssoc.java CNF.mpw CanBeUni.mpw CanonicalAdd.mpw CatalanConstNum.mpw ChartUtility.java CheckIntPower.mpw ChineseRemainderInteger.mpw ChineseRemainderPoly.mpw CommonLispTokenizer.java CompilePatterns.mpw Contradict.mpw ControlChart.mpw CosN'Doubling.mpw CosN'Taylor.mpw CosNum.mpw Cosh.mpw Cot.mpw Coth.mpw Csc.mpw Csch.mpw CustomEval.java CustomEvalExpression.java CustomEvalLocals.java CustomEvalResult.java CustomEvalStop.java DawsonIntegral.mpw DebugFile.java DebugLine.java DefLoadFunction.java DefaultPrint.mpw Deriv.mpw DestructiveAppendList.mpw Digamma.mpw DigitalRoot.mpw DigitsToBits.java DigitsToBits.mpw DirichletBeta.mpw DirichletEta.mpw DirichletLambda.mpw DivPoly.mpw DoUnitSubsumptionAndResolution.mpw DropEndZeroes.mpw EqualAsSets.mpw Erf.mpw Erfc.mpw Erfi.mpw EulerArray.mpw Example.mpw Exit.java ExitRequested.java ExpN'Doubling.mpw ExpN'Taylor.mpw ExpNum.mpw ExpandFrac.mpw ExpandSparseUniVar.mpw ExpandUniVariate.mpw ExpressionDepth.mpw ExtendedEuclidean.mpw ExtendedEuclideanMonic.mpw FW.mpw FWatom.mpw FactorGaussianInteger.mpw FactorQS.mpw FactorUniVar.mpw Factorial.java FactorizeInt.mpw FactorsBinomials.mpw FastArcCos.java FastArcSin.java FastArcTan.java FastCos.java FastIsPrime.java FastLog.java FastPower.java FastSin.java FastTan.java FileSize.java FindIsq.mpw FindPredicate.mpw FindPrimeFactor.mpw FindPrimeFactorSimple.mpw FloatIsInt.mpw ForEachExperimental.mpw ForEachInArray.mpw FresnelCos.mpw FresnelSin.mpw GammaConstNum.mpw GarbageCollect.java GaussianFactorPrime.mpw GaussianMod.mpw GcdN.mpw GcdReduce.mpw GeoGebra.mpw GeoGebraHistogram.mpw GeoGebraPlot.mpw GeoGebraPoint.mpw GetNumerDenom.mpw GetPrimePower.mpw Groebner.mpw HighschoolForm.mpw II.mpw ImII.mpw Import.java InDebugMode.java IncompleteGamma.mpw Internal'BernoulliArray.mpw Internal'BernoulliArray1.mpw Internal'GammaNum.mpw Internal'LnGammaNum.mpw Internal'LnNum.mpw IsBoolType.mpw IsComplex.mpw IsComplexII.mpw IsNonNegativeInteger.mpw IsNonNegativeNumber.mpw IsNotComplex.mpw IsOne.mpw IsPerfect.mpw IsRationalOrNumber.mpw IsSubset.mpw IsUniVar.mpw IsVariable.mpw JFreeChartHistogram.mpw JavaAccess.mpw LexCompare2.java LexGreaterThan.java LexLessThan.java ListHasFuncSome.mpw LnGamma.mpw LogicCombine.mpw LogicFindWith.mpw LogicRemoveTautologies.mpw LogicSimplify.mpw MM.mpw MacroMapArgs.mpw MacroMapSingle.mpw MacroSubstitute.mpw Magnitude.mpw MakeMultiNomial.mpw MakeSparseUniVar.mpw MakeUni.mpw ManipEquations.mpw Manipulate.mpw MathBitCount.mpw MathExpDoubling.mpw MathExpTaylor.mpw MathFloatPower.mpw MathIntPower.mpw MathIsSmall.java MathLn'Doubling.mpw MathLn'Taylor.mpw MathMul2Exp.mpw MathNegate.java MathPi.mpw MathSign.java MathSqrtFloat.mpw MatrixRowAndColumnOps.mpw Maxima.java MultiDivide.mpw MultiGcd.mpw MultiNomial.mpw MultiSimp.mpw NN.mpw NewtonLn.mpw NextPseudoPrime.mpw NextTest.mpw NormalForm.mpw Nth.java NumericEqual.mpw OldCyclotomic.mpw OptionsListToHash.mpw PAdicExpandInternal.mpw PSolve.mpw PanAxiom.java PartFracExpand.mpw PartitionsP.mpw PatternCreate.java PatternMatches.java PollardCombineLists.mpw PollardMerge.mpw PollardRhoFactorize.mpw PolyLog.mpw PositiveIntPower.mpw Print.mpw ProductPrimesTo257.mpw RabinMiller.mpw RationalForm.mpw RationalizeNumber.mpw ReII.mpw Regress.mpw Rem.mpw RemoveRepeated.mpw RepeatedSquaresMultiply.mpw Repunit.mpw Return.java Ring.java Roots.mpw RootsWithMultiples.mpw Sec.mpw Sech.mpw Series.mpw Set.java SetOrder.mpw SetPlotColor.java SetPlotWidth.java ShowLine.mpw ShuffledDeckNoSuits.mpw SimpAdd.mpw SimpDiv.mpw SimpExpand.mpw SimpFlatten.mpw SimpImplode.mpw SimpMul.mpw SimulatorPlot.java SinN'Taylor.mpw SinN'Tripling.mpw SinNum.mpw Sinc.mpw Sinh.mpw SmallSort.mpw SolveSetEqns.mpw SolveSystem.mpw SortFactorList.mpw SparseUniVar.mpw StackSize.java StemAndLeaf.mpw SturmSequence.mpw SturmVariations.mpw Substitute.mpw Subsumes.mpw SumFunc.mpw TanNum.mpw Tanh.mpw Taylor2.mpw Taylor3.mpw TestEquivalent.mpw Testing.mpw Totient.mpw TraceToStdio.java TrialFactorize.mpw Trigonometry.mpw UniDivide.mpw UniGCD.mpw UniTaylor.mpw UniVarList.mpw UniVariate.mpw UniVariateCyclotomic.mpw VarListAll.mpw ViewGeoGebra.java ViewSimulator.java WilkinsonMatrix.mpw WriteDataItem.mpw WriteN.mpw backends.mpw equals_greaterthan_operator.mpw expthreshold.mpw ggbLine.mpw html.mpw jFactorsPoly.mpw jasFactorsInt.mpw jas_test.mpw lessthan_minus_operator.mpw mathpiperinit.mpw om.mpw period_operator.mpw pound_operator.mpw randomtest.mpw scopestack.mpw sign'change.mpw sparsenomial.mpw sparsetree.mpw stdopers.mpw xFactor.mpw xFactors.mpw xFactorsBinomial.mpw xFactorsResiduals.mpw xSolvePoly.mpw xSolveRational.mpw xSolveReduce.mpw xSolveSqrts.mpw xSolveSystem.mpw xTerms.mpw zeta.mpw The following functions have been categorized and have had documentation added to them. *IntLog.mpw *IntNthRoot.mpw *IntPowerNum.mpw *IsSumOfTerms.mpw *MultiplyNum.mpw *NetwonNum.mpw *nthroot.mpw NthRoot *numeric.mpw InNumericMode, NonN *Remove.mpw *SumTaylorNum.mpw *ArithmeticGeometricMean.mpw *ApplyFast.java mathpiper-0.81f+svn4469+dfsg3/build.xml0000644000175000017500000002571211563440436020000 0ustar giovannigiovanni Build file for MathPiper. mathpiper-0.81f+svn4469+dfsg3/nbproject/0000755000175000017500000000000011722677316020144 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/nbproject/genfiles.properties0000644000175000017500000000073111503731314024041 0ustar giovannigiovanninbbuild.xml.data.CRC32=3ff7be42 nbbuild.xml.script.CRC32=b1b8aa36 nbbuild.xml.stylesheet.CRC32=958a1d3e@1.26.2.45 # This file is used by a NetBeans-based IDE to track changes in generated files such as build-impl.xml. # Do not edit this file. You may delete it but then the IDE will never regenerate such files for you. nbproject/build-impl.xml.data.CRC32=3ff7be42 nbproject/build-impl.xml.script.CRC32=bf50b382 nbproject/build-impl.xml.stylesheet.CRC32=229523de@1.38.3.45 mathpiper-0.81f+svn4469+dfsg3/nbproject/build-impl.xml0000644000175000017500000013601711503731314022716 0ustar giovannigiovanni Must set src.src.dir Must set src.tests.dir Must set build.dir Must set dist.dir Must set build.classes.dir Must set dist.javadoc.dir Must set build.test.classes.dir Must set build.test.results.dir Must set build.classes.excludes Must set dist.jar Must set javac.includes Must select some files in the IDE or set javac.includes To run this application from the command line without Ant, try: java -cp "${run.classpath.with.dist.jar}" ${main.class} To run this application from the command line without Ant, try: java -jar "${dist.jar.resolved}" To run this application from the command line without Ant, try: java -jar "${dist.jar.resolved}" Must select one file in the IDE or set run.class Must select one file in the IDE or set run.class Must select one file in the IDE or set debug.class Must select one file in the IDE or set debug.class Must set fix.includes Must select some files in the IDE or set javac.includes Some tests failed; see details above. Must select some files in the IDE or set test.includes Some tests failed; see details above. Must select one file in the IDE or set test.class Must select one file in the IDE or set applet.url Must select one file in the IDE or set applet.url mathpiper-0.81f+svn4469+dfsg3/nbproject/project.properties0000644000175000017500000000732711523146134023725 0ustar giovannigiovanniannotation.processing.enabled=true annotation.processing.enabled.in.editor=false annotation.processing.run.all.processors=true application.title=mathpiper application.vendor=tkosan build.classes.dir=${build.dir}/classes build.classes.excludes=**/*.java,**/*.form # This directory is removed when the project is cleaned: build.dir=build build.generated.dir=${build.dir}/generated build.generated.sources.dir=${build.dir}/generated-sources # Only compile against the classpath explicitly listed here: build.sysclasspath=ignore build.test.classes.dir=${build.dir}/test/classes build.test.results.dir=${build.dir}/test/results buildfile=nbbuild.xml # Uncomment to specify the preferred debugger connection transport: #debug.transport=dt_socket debug.classpath=\ ${run.classpath} debug.test.classpath=\ ${run.test.classpath} # This directory is removed when the project is cleaned: dist.dir=dist dist.jar=${dist.dir}/mathpiper.jar dist.javadoc.dir=${dist.dir}/javadoc endorsed.classpath= excludes= file.reference.geogebra.jar=/home/tkosan/NetBeansProjects/lib/geogebra.jar file.reference.geogebra_cas.jar=/home/tkosan/NetBeansProjects/lib/geogebra_cas.jar file.reference.geogebra_export.jar=/home/tkosan/NetBeansProjects/lib/geogebra_export.jar file.reference.geogebra_gui.jar=/home/tkosan/NetBeansProjects/lib/geogebra_gui.jar file.reference.geogebra_javascript.jar=/home/tkosan/NetBeansProjects/lib/geogebra_javascript.jar file.reference.geogebra_main.jar=/home/tkosan/NetBeansProjects/lib/geogebra_main.jar file.reference.geogebra_properties.jar=/home/tkosan/NetBeansProjects/lib/geogebra_properties.jar file.reference.jas.jar=/home/tkosan/NetBeansProjects/lib/jas.jar file.reference.jcommon-1.0.16.jar=/home/tkosan/NetBeansProjects/lib/jcommon-1.0.16.jar file.reference.jdom.jar=/home/tkosan/NetBeansProjects/lib/jdom.jar file.reference.jfreechart-1.0.13.jar=/home/tkosan/NetBeansProjects/lib/jfreechart-1.0.13.jar file.reference.NetBeansProjects-mathpiper=. includes=** jar.compress=false javac.classpath=\ ${file.reference.jcommon-1.0.16.jar}:\ ${file.reference.jdom.jar}:\ ${file.reference.jfreechart-1.0.13.jar}:\ ${file.reference.geogebra.jar}:\ ${file.reference.geogebra_cas.jar}:\ ${file.reference.geogebra_export.jar}:\ ${file.reference.geogebra_gui.jar}:\ ${file.reference.geogebra_javascript.jar}:\ ${file.reference.geogebra_main.jar}:\ ${file.reference.geogebra_properties.jar}:\ ${file.reference.jas.jar} # Space-separated list of extra javac options javac.compilerargs=-g javac.deprecation=false javac.processorpath=\ ${javac.classpath} javac.source=1.5 javac.target=1.5 javac.test.classpath=\ ${javac.classpath}:\ ${build.classes.dir}:\ ${libs.junit.classpath}:\ ${libs.junit_4.classpath} javadoc.additionalparam= javadoc.author=false javadoc.encoding=${source.encoding} javadoc.noindex=false javadoc.nonavbar=false javadoc.notree=false javadoc.private=false javadoc.splitindex=true javadoc.use=true javadoc.version=false javadoc.windowtitle= main.class=org.mathpiper.ui.text.consoles.Console manifest.file=manifest.mf meta.inf.dir=${src.dir}/META-INF platform.active=default_platform run.classpath=\ ${javac.classpath}:\ ${build.classes.dir}:\ ${file.reference.jcommon-1.0.16.jar}:\ ${file.reference.jdom.jar}:\ ${file.reference.jfreechart-1.0.13.jar}:\ ${file.reference.NetBeansProjects-mathpiper} # Space-separated list of JVM arguments used when running the project # (you may also define separate properties like run-sys-prop.name=value instead of -Dname=value # or test-sys-prop.name=value to set system properties for unit tests): run.jvmargs= run.test.classpath=\ ${javac.test.classpath}:\ ${build.test.classes.dir} source.encoding=UTF-8 src.src.dir=src src.tests.dir=tests mathpiper-0.81f+svn4469+dfsg3/nbproject/project.xml0000644000175000017500000000074211351304227022321 0ustar giovannigiovanni org.netbeans.modules.java.j2seproject mathpiper mathpiper-0.81f+svn4469+dfsg3/tests/0000755000175000017500000000000011722677316017320 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/win_test.bat0000644000175000017500000000005211123262534021624 0ustar giovannigiovannijava -cp . org.mathpiper.test.RunTestSuitemathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/0000755000175000017500000000000011722677314022015 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/xTestSolve.mpw0000644000175000017500000001230311316262063024647 0ustar giovannigiovanni%mathpiper,title="xTestSolve" Use("proposed.rep/xSolve.mpi"); //######################################################################## // T E S T I N G T E S T I N G T E S T I N G //######################################################################## iDebug := False; //iDebug := True; // a bunch of expressions for testing expressions := {}; Push( expressions, {a,{}} ); Push( expressions, {0,{{x==x}}} ); Push( expressions, {x-5,{{x==5}}} ); Push( expressions, {x-a,{{x==a}}} ); Push( expressions, {12*x+5==29,{{x==2}}} ); Push( expressions, {5*x-15==5*(x-3),{x==x}} ); Push( expressions, {5*x-15==5*(x-4),{}} ); Push( expressions, {x^2-4,{x==2,x==(-2)}} ); Push( expressions, {x^2-a^2,{x==a,x==(-a)}} ); Push( expressions, {2*x^2+9*x==18,{x==3/2,x==(-6)}} ); Push( expressions, {5*x^2==25*x, {x==0,x==5}} ); Push( expressions, {2*x/5-x/3==2,{x==30}}); Push( expressions, {2/x-3/2==7/(2*x),{x==(-1)}}); Push( expressions, {2/(x-3)-3/(x+3)==12/(x^2-9),{}}); Push( expressions, {3/(x^2+x-2)-1/(x^2-1)==7/(2*(x^2+3*x+2)),{x==3}}); Push( expressions, {1+1/x==6/x^2,{x==2,x==(-3)}}); Push( expressions, {Sqrt(x)-3,{x==9}}); Push( expressions, {Sqrt(x-3),{x==3}}); Push( expressions, {Sqrt(x-3)==2, {x==7}}); Push( expressions, {Sqrt(2*x)==Sqrt(x+1), {x==1}}); Push( expressions, {Sqrt(x)==x, {x==1,x==0}}); Push( expressions, {Sqrt(x+2)-2*x==1,{x==1/4} } ); Push( expressions, {Sqrt(x+2)+2*x==1,{x==(5 - Sqrt(41))/8} } ); Push( expressions, {Sqrt(9*x^2+4)-3*x==1,{x==1/2} } ); Push( expressions, {Sqrt(x+1)-Sqrt(x)==-2,{} } ); Push( expressions, {Sqrt(3*x-5)-Sqrt(2*x+3)==-1,{x==3} } ); Push( expressions, {Exp(x)==4, {x==Ln(4)}}); Push( expressions, {Exp(x)==Abs(a), {x==Ln(Abs(a))}}); Push( expressions, {Ln(x)==4, {x==Exp(4)}}); Push( expressions, {Ln(x)==a, {x==Exp(a)}}); Push( expressions, {(x+6)/2-(3*x+36)/4==4, {x==-40} } ); Push( expressions, {(x-3)*(x-4)==x^2-2, {x==2} } ); Push( expressions, {a*x-2*b*c==d,{x==(2*b*c+d)/a} } ); Push( expressions, {(36-4*x)/(x^2-9)-(2+3*x)/(3-x)==(3*x-2)/(x+3),{x==-2} } ); Push( expressions, {(x^2-1)^(1/3)==2,{x==3,x==(-3)} } ); Push( expressions, {x^4-53*x^2+196==0, {x==(-7),x==(-2),x==2,x==7} } ); Push( expressions, {x^3-8==0, {x==2,x==-1+I*Sqrt(3),x==-1-I*Sqrt(3)} } ); Push( expressions, {x^(2/3)+x^(1/3)-2==0, {x==1,x==(-8)} } ); Push( expressions, {Sqrt(x)-(1/4)*x==1, {x==4} } ); Push( expressions, {(1/4)*x-Sqrt(x)==-1, {x==4} } ); Push( expressions, {{x-y==1,3*x+2*y==13}, {x==3,y==2} } ); Push( expressions, {{x-y-1==0,2*y+3*x-13==0}, {x==3,y==2} } ); //Push( expressions, {, {} } ); //Push( expressions, {,{{},{},{},{}}} ); NewLine(2); Tell("TEST xSolve()"); t1 := SystemTimer(); expressions := Reverse(expressions); Local(i); i := 0; Local(iCorrect); iCorrect := 0; ForEach(q,expressions) [ i := i + 1; Check(i<100, ">>>>> FORCED STOP <<<<<"); f := q[1]; If( f = blank, [ i := i - 1; NewLine(); ], [ //If(i=23 Or i=26 Or i=40,iDebug:=True,iDebug:=False); Local(vars); g := q[2]; NewLine(); Tell(i,"-------------------------------"); Tell(">>> Test xSolve() on the expression: ",f); stk := {}; vars := VarList(f); If(IsList(f), [ If(iDebug=True,Tell(" system")); r := xSolve(f,vars); SysOut(" xSolve(f,vars) ==> ",r); ], [ If(iDebug=True,Tell(" single")); r := xSolve(f,x); SysOut(" xSolve(f,x) ==> ",r); ] ); //If(IsList(f),Break()); rmg := Simplify(Expand(UnFlatten(r-g,"+",0))); If(iDebug=True,Tell("rmg",rmg)); If(iDebug And IsList(rmg),Tell(Listify(rmg))); If( IsZero(rmg) Or IsZeroVector(rmg), [SysOut(" Answer is CORRECT"); iCorrect:=iCorrect+1;], [ If(iDebug=True,Tell("check rmg a little more")); Local(Lrmg,Lrmg2,Lrmg3); Lrmg := Listify(rmg); If(iDebug=True,Tell("Listify rmg",Lrmg)); If(Lrmg[1] != UnFlatten, [ Lrmg2 := Listify(Lrmg[2]); Lrmg3 := Listify(Lrmg[3]); If(iDebug=True,Tell("LL",{Lrmg2,Lrmg3})); If(CloseEnough(Lrmg2[3],Lrmg3[3],10), [SysOut(" Answer is CORRECT"); iCorrect:=iCorrect+1;], [SysOut(" Answer is WRONG: should be ",g );] ); ], SysOut(" Answer is WRONG: should be ",g ) ); ] ); //SysOut(" Answer is WRONG: it should be ",g); ] ); ]; NewLine(2); Tell("DONE",{iCorrect,i}); t2 := SystemTimer(); Echo("Time taken: ",N((t2-t1)/10^9)," sec"); %/mathpiper mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/myMatch_new.mpi0000644000175000017500000000251511166030403024762 0ustar giovannigiovanni //Tell(a); ///////////////////////////////////////////////////////////////// // my MatchLinear ///////////////////////////////////////////////////////////////// 10 # myMatchLinear(var_(Not IsAtom),expr) <-- List(); 12 # myMatchLinear(_var,expr_CanBeUni) <-- [ Local(d,c); d := myDegree(expr,var); Tell(1,{expr,d}); If(d = 1, [c:=Coef(expr,var,{1,0}); Tell(ooo,{c}); c;], List() ); ]; 14 # myMatchLinear(_var,_expr) <-- List(); ///////////////////////////////////////////////////////////////// // my Degree ///////////////////////////////////////////////////////////////// 10 # myDegree(expr_CanBeUni,_var) <-- [Tell(D2,{expr,var}); Degree(expr,var);]; 20 # myDegree(_expr,_var) <-- False; Retract("tellMe",2); Retract("trythis",2); Clear(p1); Clear(p2); Clear(ss); Clear(cc); p1 := A*x+B; p1 := x+B; //p2 := A*x^2+B*x+C; //ss := Sin(x); //cc := 23; 10 # trythis(_var,_expr)_(mm:=myMatchLinear(var,expr)) <-- Tell("Here is the output: ",mm); 20 # trythis(_var,_expr) <-- Tell("NADA"); tellMe(_var,_expr) <-- [ Local(m,ccs); Tell(CASE,expr); m := myMatchLinear(var,expr); Tell(1,m); ccs := trythis(var,expr); Tell(2,ccs); ]; //TraceOn(); tellMe(x,p1); NewLine(); //TraceOff(); /*tellMe(x,p2); NewLine(); tellMe(x,ss); NewLine(); tellMe(x,cc); NewLine(); */ mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/factors_rational_number_bug.mpw0000644000175000017500000000030511316262063030265 0ustar giovannigiovanni%mathpiper 10 # Factors(p_IsRational)_(Denominator(p) != 1) <-- {{Factor(Numerator(p)) / Factor(Denominator(p)) , 1}}; %/mathpiper %output,preserve="false" Result: True . %/output mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/resampling_statistics.mpw0000644000175000017500000003366111316262063027154 0ustar giovannigiovanni %mathpiper Use("org/mathpiper/assembledscripts/proposed.rep/statistics.mpi"); Use("org/mathpiper/assembledscripts/proposed.rep/geogebra.mpi"); %/mathpiper %output,preserve="false" Result: True . %/output %mathpiper,title="two boys." boysAndGirls := {}; ForEach(trial, 1 .. 100) [ child1 := Round(Random()); child2 := Round(Random()); boysAndGirls := Append( boysAndGirls, {child1, child2} ); ]; boysOnly := Remove(boysAndGirls,{0,0}); Echo("Trials :", boysOnly); oneBoy := Count(boysOnly, {1,0}) + Count(boysOnly, {0,1}); twoBoys := Count(boysOnly, {1,1}); Echo("One boy: ", oneBoy); Echo("Two boys: ", twoBoys); Echo("At least one boy: ", Length(boysOnly),N( (oneBoy + twoBoys)/Length(boysAndGirls))); N(twoBoys/ Length(boysOnly)); %/mathpiper %output,preserve="false" Result: 0.2564102564 Side Effects: Trials :{{1,1},{0,1},{1,1},{0,1},{0,1},{0,1},{0,1},{1,1},{1,1},{1,1},{0,1},{1,1},{0,1},{0,1},{1,0},{1,1},{1,1},{1,0},{0,1},{0,1},{1,0},{1,0},{1,0},{1,0},{0,1},{0,1},{1,1},{1,1},{1,0},{1,0},{1,1},{1,0},{1,1},{1,0},{0,1},{0,1},{1,0},{0,1},{1,0},{0,1},{0,1},{1,0},{1,1},{0,1},{0,1},{1,0},{0,1},{0,1},{1,1},{0,1},{1,0},{0,1},{0,1},{1,0},{1,0},{0,1},{0,1},{1,0},{0,1},{0,1},{0,1},{1,0},{1,1},{1,0},{1,0},{1,0},{0,1},{1,0},{1,1},{1,0},{1,1},{0,1},{1,0},{0,1},{1,1},{1,1},{1,1},{1,0}} One boy: 58 Two boys: 20 At least one boy: 78 0.78 . %/output %mathpiper,title="Gold example on pp.82 chapter 6." ships := {{gold, gold}, {gold, silver}, {silver, silver}}; score := {}; Repeat(1000) [ ship := RandomPick(ships); ship := Shuffle(ship); If(Count(ship,gold) = 2, score := Append(score,success) ); If(Count(ship,silver) = 1, If(ship[1] = gold, score := Append(score,failure)) ); ]; initialGoldCount := Length(score); goldGoldCount := Count(score,success); result := N(goldGoldCount/initialGoldCount); Echo(initialGoldCount,,,goldGoldCount,,,result); %/mathpiper %mathpiper,title="Three door problem pp.83 chapter 6." firstPickScore := {}; secondPickScore := {}; Repeat(1000) [ doors := Shuffle( {empty, prize, empty} ); firstPick := doors[1]; If(doors[2] = empty, secondPick := doors[3], secondPick := doors[2]); firstPickScore := Append(firstPickScore, firstPick); secondPickScore := Append(secondPickScore, secondPick); ]; Echo("First Pick: ", Count(firstPickScore,prize)); Echo("Second Pick: ", Count(secondPickScore,prize)); %/mathpiper %output,preserve="false" Result: True Side Effects: First Pick: 263 Second Pick: 737 . %/output %mathpiper,title="Two of a kind problem pp.85 chapter 6." pairsCount := 0; deck := Concat(1 .. 13, 1 .. 13, 1 .. 13, 1 .. 13); trials := 100; Repeat(trials) [ deck := Shuffle(deck); hand := Take(deck,5); //Echo(hand); handPairCount := 0; ForEach(card,1 .. 13) [ If(Count(hand,card) = 2, handPairCount := handPairCount + 1); ]; If(handPairCount = 1, pairsCount := pairsCount + 1); ]; Echo("Probability of a single pair: ", N(pairsCount/trials) ); %/mathpiper %output,preserve="false" Result: True Side Effects: Probability of a single pair: 0.52 . %/output %mathpiper,title="Two pairs vs. three of a kind problem pp.90 chapter 6." pairsCount := 0; threeOfAKindCount := 0; deck := Concat(1 .. 13, 1 .. 13, 1 .. 13, 1 .. 13); trials := 1000; Repeat(trials) [ deck := Shuffle(deck); hand := Take(deck,5); //Echo(hand); handPairCount := 0; handThreeOfAKindCount := 0; ForEach(card,1 .. 13) [ If(Count(hand,card) = 2, handPairCount := handPairCount + 1); If(Count(hand,card) = 3, handThreeOfAKindCount := handThreeOfAKindCount + 1); ]; If(handPairCount = 2, pairsCount := pairsCount + 1); If(handThreeOfAKindCount = 1, threeOfAKindCount := threeOfAKindCount + 1); ]; Echo("Probability of two pairs: ", N(pairsCount/trials) ); Echo("Probability of three of a kind: ", N(threeOfAKindCount/trials) ); %/mathpiper %output,preserve="false" Result: True Side Effects: Probability of two pairs: 0.052 Probability of three of a kind: 0.028 . %/output %mathpiper,title="Birthday match from page 97 chapter 7." birthdayMatchCounter := 0; trials := 50; Repeat(trials) [ birthdays := RandomIntegerVector(25,1,365); dayCounter := 1; While(dayCounter <= 365) [ If(Count(birthdays,dayCounter) >= 2, [birthdayMatchCounter := birthdayMatchCounter + 1; dayCounter := 366;]); dayCounter := dayCounter + 1; ]; ]; Echo(birthdayMatchCounter,,,trials); %/mathpiper %output,preserve="false" Result: True Side Effects: 31 , 50 . %/output %mathpiper,title="Birthday the same as August 1st" birthdayMatchCounter := 0; trials := 1000; Repeat(trials) [ targetPersonBirthday := 213; birthdays := RandomIntegerVector(25,1,365); If( Contains(birthdays, targetPersonBirthday), birthdayMatchCounter++); ]; Echo(birthdayMatchCounter,,,trials,,,N(birthdayMatchCounter/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 81 , 1000 , 0.081 . %/output %mathpiper,title="Three daughters example pp.97 chapter 7." trials := 100; successes := 0; Repeat(trials) [ sample := RandomSymbolVector( {{boy,1/2}, {girl,1/2} },4); //Echo(sample); If(Count(sample,girl) = 3, successes := successes + 1); ]; Echo(successes,,,trials); %/mathpiper %output,preserve="false" Result: True Side Effects: 27 , 100 . %/output %mathpiper,title="5 shot basketball example pp.102 chapter 7." trials := 100; successes := 0; Repeat(trials) [ sample := RandomSymbolVector({{hit,1/4}, {miss,3/4}},5); If(Count(sample,hit) >= 3, successes := successes + 1); ]; Echo(successes,,,trials); %/mathpiper %mathpiper,title="Archery example pp.104 chapter 7." trials := 100; successes := 0; Repeat(trials) [ sample := RandomSymbolVector({{black,10/100}, {white,60/100}, {miss,30/100}},3); If(Count(sample,black)= 1 And Count(sample,white) = 2, successes := successes + 1); ]; Echo(successes,,,trials); %/mathpiper %mathpiper,title="Sum of hammers and handle lengths pp. 108" sample := {}; trials := 100; Repeat(trials) [ handleLength := RandomSymbol({{10.0,20/100},{10.1,30/100},{10.2,30/100},{10.3,20/100}}); headLength := RandomSymbol({{2.0,20/100},{2.1,20/100},{2.2,30/100},{2.3,20/100},{2.4,10/100}}); totalLength := handleLength + headLength; sample := Append(sample, totalLength); ]; givenLength := 12.4; overOrEqual := 0; ForEach(element, sample) [ If(element >= givenLength, overOrEqual := overOrEqual + 1); ]; mean := Mean(sample); Echo(overOrEqual,,,trials,,,mean); %/mathpiper %mathpiper,title="Flipping pennies pp.110 chapter 7." trials := 2; emptyCount := 0; Repeat(trials) [ stack1 := 10; stack2 := 10; iterations := Repeat(200) [ flip := RandomSymbol({{head,1/2},{tail,1/2}}); If(flip = head, [stack1++; stack2--;], [stack1--; stack2++;] ); If(stack1 = 0 Or stack2 = 0, Break() ); ]; Echo({stack1,,,stack2,,,iterations}); If(stack1 = 0 Or stack2 = 0, emptyCount++); ]; {emptyCount,trials}; %/mathpiper %mathpiper,title="capacirators example pp. 112 chapter 7." daysToEmptyList := {}; trials := 50; Repeat(trials) [ warehouseCount := 12; dayCounter := 0; daysToEmpty := Repeat() [ morning := RandomSymbol({{used,6/10},{not_used,4/10}}); If(morning = used, warehouseCount--); If(warehouseCount = 0, Break()); afternoon := RandomSymbol({{used,6/10},{not_used,4/10}}); If(afternoon = used, warehouseCount--); If(warehouseCount = 0, Break()); If(Mod(dayCounter,3) = 0, warehouseCount := warehouseCount + 2); //Echo(warehouseCount, dayCounter, Mod(dayCounter,3)); dayCounter++; ]; daysToEmptyList := Append(daysToEmptyList, daysToEmpty); ]; Echo("Average days to empty: ", Mean(daysToEmptyList)); %/mathpiper %mathpiper,title="Random walk example at the end of chapter 7." targetPositions := {{3,2}, {-1,-4}}; successCount := 0; trials := 500; Repeat(trials) [ currentPosition := {0,0}; walkPath := {}; Repeat(12) [ step:= RandomSymbol({{{1,0},1/4},{{-1,0},1/4},{{0,1},1/4},{{0,-1},1/4}}); currentPosition := currentPosition + step; //walkPath := Append(walkPath,currentPosition); If(Contains(targetPositions, currentPosition), [successCount++; Break();]); ]; //Write(walkPath); ]; {successCount, trials, N(successCount/trials)}; %/mathpiper %output,preserve="false" Result: {35,500,0.07} . %/output %mathpiper,title="case 1 example pp. 119 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 1000; Repeat(trials) [ sample := Sample(balls,3); If(sample = {1,2,3}, successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 36 , 5000 , 0.0072 . %/output %mathpiper,title="case 2 example pp. 120 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 1000; Repeat(trials) [ sample := Sample(balls,3); If(IsSubset({1,2,3},sample), successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 49 , 1000 , 0.049 . %/output %mathpiper,title="case 3 example pp. 121 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 1000; Repeat(trials) [ sample := Sample(balls,3); If( (IsOdd(sample[1]) And IsEven(sample[2])) Or (IsOdd(sample[2]) And IsEven(sample[3])), successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 588 , 1000 , 0.588 . %/output %mathpiper,title="case 4 example pp. 120 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 1000; Repeat(trials) [ sample := Sample(balls,3); If(Length(Select("IsOdd",sample)) = 2, successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 423 , 1000 , 0.423 . %/output %mathpiper,title="case 5a example pp. 121 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 1000; Repeat(trials) [ sample := Sample(balls,3); If(sample[1] = 1 Or sample[2] = 2 Or sample[3] = 3, successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 421 , 1000 , 0.421 . %/output %mathpiper,title="case 5b example pp. 121 chapter 8." balls := {1,2,3,4,5,6}; successCount := 0; trials := 10000; Repeat(trials) [ sample := Sample(balls,6); If(sample = {1,2,3,4,5,6}, successCount++); ]; Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 19 , 10000 , 0.0019 . %/output %mathpiper,title="example 8-1 50 girls and boys pp. 122." class := Concat(FillList(boy,25), FillList(girl,25)); samples := {}; trials := 100; Repeat(trials) [ class := Shuffle(class); sample := Take(class,5); samples := Count(sample,girl) : samples; ]; successCount := Count(samples,4); Echo(successCount,,,trials,,,N(successCount/trials)); %/mathpiper %output,preserve="false" Result: True Side Effects: 14 , 100 , 0.14 . %/output %mathpiper,title="Extra code for example 8-1" GeoGebraHistogram(samples); %/mathpiper %output,preserve="false" Result: true . %/output %mathpiper,title="Example 8-2 9 spades pp. 125" samples := {}; trials := 100; deck := Concat(FillList(spades,13), FillList(diamonds,13), FillList(hearts,13), FillList(clubs,13)); //test := {}; //counter := 0; Repeat(trials) [ (deck := Shuffle(deck)); (hand := Take(deck,13)); //test := Count(hand, spades) : test; (If(Count(hand, spades) = 9, Count(hand, clubs) : samples)); //If(Mod(counter,100) = 0, SysOut("Trial # ",,, counter)); //counter++; ]; samples; %/mathpiper %output,preserve="false" Result: {} . %/output %mathpiper,title="Extra code for example 8-2" //The probability of obtaining 9 spades seems to be very low. N( (Combinations(13,9) * Combinations(39,4)) / Combinations(52,13) ); %/mathpiper %output,preserve="false" Result: 0.00009261135311 . %/output %mathpiper,title="Extra code for example 8-2" GeoGebraHistogram(test); %/mathpiper %output,preserve="false" Result: true . %/output mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/0000755000175000017500000000000011722677314026504 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/ostrowsky/0000755000175000017500000000000011722677314030570 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/kosan/0000755000175000017500000000000011722677314027617 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/kosan/Kind.mpw0000644000175000017500000000167711316262063031232 0ustar giovannigiovanni%mathpiper /* This is the beginnings of a Kind function which will return: 1) If u is an atomic expression, return the type of the expression. 2) If u is a compund expression, return the operator at the root of the expression tree. pp.104 "Computer Algebra And Symbolic Computation: Elementary Algorithms" Cohen. */ Retract("Kind",*); RuleBase("Kind",{u}); //HoldArg("Kind",u); 10 # Kind(_u) <-- [ Write(u,,); Local(result); if(IsInteger(u)) [ result := integer; Echo(1); ] else if(IsString(u)) [ result := string; Echo(2); ] else if(IsList(u)) [ result := list; Echo(3); ] else if(Not IsBound(Eval(u))) [ result := symbol; Echo(10); ] else [ ]; result; ]; Kind({3}); %/mathpiper %output,preserve="false" Result: list Side Effects: {3},3 . %/output ././@LongLink0000000000000000000000000000017700000000000011572 Lustar rootrootmathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/kosan/computer_algebra_elementary_algorithms_cohen.mpwmathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/computer_algebra_cohen/kosan/computer_algebra_eleme0000644000175000017500000000626011316262063034216 0ustar giovannigiovanni %mathpiper CASCompare(expressions) := [ Local(count,e,me, answer); count := 1; ForEach(e,expressions) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Exercise: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); Echo("MathPiper: ",Eval(FromString(e:";") Read())); //me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; me := ToString()[WriteString("(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; ]; %/mathpiper %output,preserve="false" Result: True . %/output %mathpiper,title="page 55 exercises 1a. Echo("pp.55 exercises. 1a "); NewLine(); expressions :={ {"x^2*x^3","x^5"}, {"x^(1/2)*x^(1/3)","x^(5/6)"}, {"x^a*x^b","x^(a+b)"}, {"(x^2)^3","x^6"}, {"(x^a)^2","x^(2*a)"}, {"(x^2)^(1/2)","|x|"}, {"(x^(1/2))^2","x"}, {"(x^2)^a","x^(2*a)"}, {"(x*y)^2","x^2*y^2"}, {"(x*y)^(1/3)","x^(1/3)*y^(1/3)"}, {"(x*y)^a","x^a*y^a"}, }; CASCompare(expressions); %/mathpiper %output,preserve="false" Result: True Side Effects: pp.55 exercises. 1a #1 Exercise: x^2*x^3 Answer: "x^5" MathPiper: x^5 Maxima:(%o700) x^5 #2 Exercise: x^(1/2)*x^(1/3) Answer: "x^(5/6)" MathPiper: Sqrt(x)*x^(1/3) Maxima:(%o701) x^(5/6) #3 Exercise: x^a*x^b Answer: "x^(a+b)" MathPiper: x^(b+a) Maxima:(%o702) x^(b+a) #4 Exercise: (x^2)^3 Answer: "x^6" MathPiper: x^6 Maxima:(%o703) x^6 #5 Exercise: (x^a)^2 Answer: "x^(2*a)" MathPiper: x^a^2 Maxima:(%o704) x^(2*a) #6 Exercise: (x^2)^(1/2) Answer: "|x|" MathPiper: Sqrt(x^2) Maxima:(%o705) abs(x) #7 Exercise: (x^(1/2))^2 Answer: "x" MathPiper: x Maxima:(%o706) x #8 Exercise: (x^2)^a Answer: "x^(2*a)" MathPiper: x^2^a Maxima:(%o707) abs(x)^(2*a) #9 Exercise: (x*y)^2 Answer: "x^2*y^2" MathPiper: (x*y)^2 Maxima:(%o708) x^2*y^2 #10 Exercise: (x*y)^(1/3) Answer: "x^(1/3)*y^(1/3)" MathPiper: (x*y)^(1/3) Maxima:(%o709) x^(1/3)*y^(1/3) #11 Exercise: (x*y)^a Answer: "x^a*y^a" MathPiper: (x*y)^a Maxima:(%o710) (x*y)^a . %/output %mathpiper,title="page 55 exercises 2a. Echo("pp.55 exercises. 1a "); NewLine(); expressions :={ {"2*x+3*x","5*x"}, {"(1+x)+2*(1+x)","3*(1+x)"}, {"2*x+Sqrt(2)*x","(2+Sqrt(2))*x"}, {"a*x + b*x","(a+b)*x"}, {"(a+b)*x","a*x+b*x)"}, {"2*(x+y)","2*x+2*y"}, {"-(x+y)","-x-y"}, {"a*(x+y)","a*x+a*y"}, }; //CASCompare(expressions); %/mathpiper %output,preserve="false" Result: {{"2*x+3*x","5*x"},{"(1+x)+2*(1+x)","3*(1+x)"},{"2*x+Sqrt(2)*x","(2+Sqrt(2))*x"},{"a*x + b*x","(a+b)*x"},{"(a+b)*x","a*x+b*x)"},{"2*(x+y)","2*x+2*y"},{"-(x+y)","-x-y"},{"a*(x+y)","a*x+a*y"}} Side Effects: pp.55 exercises. 1a . %/output mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/myMatch_new.mpt0000644000175000017500000004036511417150721025007 0ustar giovannigiovanniinit: deps-jar: compile-single: run-single: Maxima is initialized Debug> Loading file"org/mathpiper/scripts/predicates.rep/code.mpi" for function IsMatrix Debug> Finished loading file "org/mathpiper/scripts/predicates.rep/code.mpi" Leave}(TraceOn(),True); Enter{(tellMe,tellMe(x,p1)); Arg(x,x); Arg(p1,x+B); Enter{(Prog,[ Local(m,ccs); Tell(CASE,expr); m:=myMatchLinear(var,expr); Tell(1,m); ccs:=trythis(var,expr); Tell(2,ccs); ] ); Arg(Local(m,ccs),{Local(m,ccs),Tell(CASE,expr),m:=myMatchLinear(var,expr),Tell(1,m),ccs:=trythis(var,expr),Tell(2,ccs)}); Enter{(Local,Local(m,ccs)); Arg(m,{m,ccs}); Leave}(Local(m,ccs),True); Debug> Loading file"org/mathpiper/scripts/testers.rep/code.mpi" for function Tell Enter{(Function,Function(BenchCall,{expr})[ Echo({In> ,expr}); WriteString(); Eval(expr); WriteString(); True; ] ); Arg(BenchCall,BenchCall); Arg({expr},{expr}); Arg([ Echo({In> ,expr}); WriteString(); Eval(expr); WriteString(); True; ] ,[ Echo({In> ,expr}); WriteString(); Eval(expr); WriteString(); True; ] ); Enter{(And,GreaterThan(Length(args),1)And Equals(MathNth(args,Length(args)),Atom(...))); Arg(GreaterThan(Length(args),1),{GreaterThan(Length(args),1),Equals(MathNth(args,Length(args)),Atom(...))}); Enter{(GreaterThan,GreaterThan(Length(args),1)); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(GreaterThan(Length(args),1),False); Leave}(GreaterThan(Length(args),1)And Equals(MathNth(args,Length(args)),Atom(...)),False); Enter{(Prog,[ Retract(oper,Length(args)); MacroRuleBase(oper,args); MacroRule(oper,Length(args),1025,True)body; ] ); Arg(Retract(oper,Length(args)),{Retract(oper,Length(args)),MacroRuleBase(oper,args),MacroRule(oper,Length(args),1025,True)body}); Enter{(Retract,Retract(oper,Length(args))); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(Retract(oper,Length(args)),True); Enter{(MacroRuleBase,MacroRuleBase(oper,args)); Leave}(MacroRuleBase(oper,args),True); Enter{(MacroRule,MacroRule(oper,Length(args),1025,True)body); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(MacroRule(oper,Length(args),1025,True)body,True); Leave}([ Retract(oper,Length(args)); MacroRuleBase(oper,args); MacroRule(oper,Length(args),1025,True)body; ] ,True); Leave}(Function(BenchCall,{expr})[ Echo({In> ,expr}); WriteString(); Eval(expr); WriteString(); True; ] ,True); Enter{(HoldArg,HoldArg(BenchCall,expr)); Leave}(HoldArg(BenchCall,expr),True); Enter{(Function,Function(BenchShow,{expr})[ Echo({In> ,expr}); WriteString( ); Echo({Out> ,Eval(expr),}); True; ] ); Arg(BenchShow,BenchShow); Arg({expr},{expr}); Arg([ Echo({In> ,expr}); WriteString( ); Echo({Out> ,Eval(expr),}); True; ] ,[ Echo({In> ,expr}); WriteString( ); Echo({Out> ,Eval(expr),}); True; ] ); Enter{(And,GreaterThan(Length(args),1)And Equals(MathNth(args,Length(args)),Atom(...))); Arg(GreaterThan(Length(args),1),{GreaterThan(Length(args),1),Equals(MathNth(args,Length(args)),Atom(...))}); Enter{(GreaterThan,GreaterThan(Length(args),1)); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(GreaterThan(Length(args),1),False); Leave}(GreaterThan(Length(args),1)And Equals(MathNth(args,Length(args)),Atom(...)),False); Enter{(Prog,[ Retract(oper,Length(args)); MacroRuleBase(oper,args); MacroRule(oper,Length(args),1025,True)body; ] ); Arg(Retract(oper,Length(args)),{Retract(oper,Length(args)),MacroRuleBase(oper,args),MacroRule(oper,Length(args),1025,True)body}); Enter{(Retract,Retract(oper,Length(args))); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(Retract(oper,Length(args)),True); Enter{(MacroRuleBase,MacroRuleBase(oper,args)); Leave}(MacroRuleBase(oper,args),True); Enter{(MacroRule,MacroRule(oper,Length(args),1025,True)body); Enter{(Length,Length(args)); Leave}(Length(args),1); Leave}(MacroRule(oper,Length(args),1025,True)body,True); Leave}([ Retract(oper,Length(args)); MacroRuleBase(oper,args); MacroRule(oper,Length(args),1025,True)body; ] ,True); Leave}(Function(BenchShow,{expr})[ Echo({In> ,expr}); WriteString( ); Echo({Out> ,Eval(expr),}); True; ] ,True); Enter{(HoldArg,HoldArg(BenchShow,expr)); Leave}(HoldArg(BenchShow,expr),True); Enter{(<--,10#EchoInternal(string _IsString)<--[ WriteString(string); ] ); Arg(10#EchoInternal(string _IsString),10#EchoInternal(string _IsString)); Arg([ WriteString(string); ] ,[ WriteString(string); ] ); Enter{(Equals,Equals(Type(patternleft),#)); Enter{(Type,Type(patternleft)); Leave}(Type(patternleft),#); Leave}(Equals(Type(patternleft),#),True); Enter{(Prog,[ DefinePattern(patternleft[2],patternright,patternleft[1],True); ] ); Arg(DefinePattern(patternleft[2],patternright,patternleft[1],True),{DefinePattern(patternleft[2],patternright,patternleft[1],True)}); Enter{(DefinePattern,DefinePattern(patternleft[2],patternright,patternleft[1],True)); Enter{(Nth,patternleft[2]); Arg(patternleft,10#EchoInternal(string _IsString)); Arg(2,2); Enter{(And,And(Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth))); Arg(Equals(IsFunction(alist),True),{Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth)}); Enter{(Equals,Equals(IsFunction(alist),True)); Enter{(IsFunction,IsFunction(alist)); Leave}(IsFunction(alist),True); Leave}(Equals(IsFunction(alist),True),True); Enter{(Equals,Equals(IsInteger(aindex),True)); Enter{(IsInteger,IsInteger(aindex)); Leave}(IsInteger(aindex),True); Leave}(Equals(IsInteger(aindex),True),True); Enter{(Not,Not Equals(Head(Listify(alist)),Nth)); Enter{(Equals,Equals(Head(Listify(alist)),Nth)); Enter{(Head,Head(Listify(alist))); Enter{(Listify,Listify(alist)); Leave}(Listify(alist),{#,10,EchoInternal(string _IsString)}); Leave}(Head(Listify(alist)),#); Leave}(Equals(Head(Listify(alist)),Nth),False); Leave}(Not Equals(Head(Listify(alist)),Nth),True); Leave}(And(Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth)),True); Enter{(MathNth,MathNth(alist,aindex)); Leave}(MathNth(alist,aindex),EchoInternal(string _IsString)); Leave}(patternleft[2],EchoInternal(string _IsString)); Enter{(Nth,patternleft[1]); Arg(patternleft,10#EchoInternal(string _IsString)); Arg(1,1); Enter{(And,And(Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth))); Arg(Equals(IsFunction(alist),True),{Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth)}); Enter{(Equals,Equals(IsFunction(alist),True)); Enter{(IsFunction,IsFunction(alist)); Leave}(IsFunction(alist),True); Leave}(Equals(IsFunction(alist),True),True); Enter{(Equals,Equals(IsInteger(aindex),True)); Enter{(IsInteger,IsInteger(aindex)); Leave}(IsInteger(aindex),True); Leave}(Equals(IsInteger(aindex),True),True); Enter{(Not,Not Equals(Head(Listify(alist)),Nth)); Enter{(Equals,Equals(Head(Listify(alist)),Nth)); Enter{(Head,Head(Listify(alist))); Enter{(Listify,Listify(alist)); Leave}(Listify(alist),{#,10,EchoInternal(string _IsString)}); Leave}(Head(Listify(alist)),#); Leave}(Equals(Head(Listify(alist)),Nth),False); Leave}(Not Equals(Head(Listify(alist)),Nth),True); Leave}(And(Equals(IsFunction(alist),True),Equals(IsInteger(aindex),True),Not Equals(Head(Listify(alist)),Nth)),True); Enter{(MathNth,MathNth(alist,aindex)); Leave}(MathNth(alist,aindex),10); Leave}(patternleft[1],10); Arg(patternleft[2],EchoInternal(string _IsString)); Arg(patternright,[ WriteString(string); ] ); Arg(patternleft[1],10); Arg(True,True); Enter{(Equals,Equals(Type(patternleft),_)); Enter{(Type,Type(patternleft)); Leave}(Type(patternleft),EchoInternal); Leave}(Equals(Type(patternleft),_),False); Enter{(Prog,[ Local(patternflat,patternvars,patt,patternoper,arity); Set(patternflat,Listify(patternleft)); Set(patternvars,Tail(patternflat)); Set(patternoper,String(Head(patternflat))); Set(arity,Length(patternvars)); DefLoadFunction(patternoper); If(Not RuleBaseDefined(patternoper,arity),[ MacroRuleBase(patternoper,MakeVector(arg,arity)); ] ); Set(patt,PatternCreate(patternvars,postpredicate)); MacroRulePattern(patternoper,arity,patternprecedence,patt)patternright; True; ] ); Arg(Local(patternflat,patternvars,patt,patternoper,arity),{Local(patternflat,patternvars,patt,patternoper,arity),Set(patternflat,Listify(patternleft)),Set(patternvars,Tail(patternflat)),Set(patternoper,String(Head(patternflat))),Set(arity,Length(patternvars)),DefLoadFunction(patternoper),If(Not RuleBaseDefined(patternoper,arity),[ MacroRuleBase(patternoper,MakeVector(arg,arity)); ] ),Set(patt,PatternCreate(patternvars,postpredicate)),MacroRulePattern(patternoper,arity,patternprecedence,patt)patternright,True}); Enter{(Local,Local(patternflat,patternvars,patt,patternoper,arity)); Arg(patternflat,{patternflat,patternvars,patt,patternoper,arity}); Leave}(Local(patternflat,patternvars,patt,patternoper,arity),True); Enter{(Set,Set(patternflat,Listify(patternleft))); Enter{(Listify,Listify(patternleft)); Leave}(Listify(patternleft),{EchoInternal,string _IsString}); Leave}(Set(patternflat,Listify(patternleft)),True); Enter{(Set,Set(patternvars,Tail(patternflat))); Enter{(Tail,Tail(patternflat)); Leave}(Tail(patternflat),{string _IsString}); Leave}(Set(patternvars,Tail(patternflat)),True); Enter{(Set,Set(patternoper,String(Head(patternflat)))); Enter{(String,String(Head(patternflat))); Enter{(Head,Head(patternflat)); Leave}(Head(patternflat),EchoInternal); Leave}(String(Head(patternflat)),EchoInternal); Leave}(Set(patternoper,String(Head(patternflat))),True); Enter{(Set,Set(arity,Length(patternvars))); Enter{(Length,Length(patternvars)); Leave}(Length(patternvars),1); Leave}(Set(arity,Length(patternvars)),True); Enter{(DefLoadFunction,DefLoadFunction(patternoper)); Leave}(DefLoadFunction(patternoper),True); Enter{(If,If(Not RuleBaseDefined(patternoper,arity),[ MacroRuleBase(patternoper,MakeVector(arg,arity)); ] )); Arg(Not RuleBaseDefined(patternoper,arity),Not RuleBaseDefined(patternoper,arity)); Enter{(Not,Not RuleBaseDefined(patternoper,arity)); Enter{(RuleBaseDefined,RuleBaseDefined(patternoper,arity)); Leave}(RuleBaseDefined(patternoper,arity),False); Leave}(Not RuleBaseDefined(patternoper,arity),True); Enter{(Prog,[ MacroRuleBase(patternoper,MakeVector(arg,arity)); ] ); Arg(MacroRuleBase(patternoper,MakeVector(arg,arity)),{MacroRuleBase(patternoper,MakeVector(arg,arity))}); Enter{(MacroRuleBase,MacroRuleBase(patternoper,MakeVector(arg,arity))); Enter{(MakeVector,MakeVector(arg,arity)); Arg(arg,arg); Arg(arity,1); Enter{(Prog,[ Local(res,i); res:={}; i:=1; Set(dimension,AddN(dimension,1)); While(LessThan(i,dimension))[ DestructiveInsert(res,1,Atom(ConcatStrings(String(vec),String(i)))); Set(i,AddN(i,1)); ] ; DestructiveReverse(res); ] ); Arg(Local(res,i),{Local(res,i),res:={},i:=1,Set(dimension,AddN(dimension,1)),While(LessThan(i,dimension))[ DestructiveInsert(res,1,Atom(ConcatStrings(String(vec),String(i)))); Set(i,AddN(i,1)); ] ,DestructiveReverse(res)}); Enter{(Local,Local(res,i)); Arg(res,{res,i}); Leave}(Local(res,i),True); Enter{(:=,res:={}); Arg(res,res); Arg({},{}); Enter{(IsList,IsList(aLeftAssign)); Leave}(IsList(aLeftAssign),False); Enter{(IsAtom,IsAtom(aLeftAssign)); Leave}(IsAtom(aLeftAssign),True); Enter{(Prog,[ MacroSet(aLeftAssign,Eval(aRightAssign)); Eval(aLeftAssign); ] ); Arg(MacroSet(aLeftAssign,Eval(aRightAssign)),{MacroSet(aLeftAssign,Eval(aRightAssign)),Eval(aLeftAssign)}); Enter{(MacroSet,MacroSet(aLeftAssign,Eval(aRightAssign))); Enter{(Eval,Eval(aRightAssign)); Enter{(List,{}); Arg(Load test: Result: True Side Effects: Tracing is on. Errors: Assertion failed. BUILD SUCCESSFUL (total time: 1 second) mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/geogebra_interaction.mpw0000644000175000017500000000357011316262063026707 0ustar giovannigiovanni %* Create 3 points A, B and C in GeoGebra. */ %mathpiper,title="" /* The GeoGebra() function is used to tell the system which GeoGebra objects should be inserted into the MathPiper environment. The names of the objects are sent to the GeoGebra() function in a comma separated list. */ GeoGebra()["updateObjects"] := "A,B,C,f,g"; /* GeoGebraPoint() is an experimental function which directly places points into GeoGebra. The first parameter is the name of the point, the second parameter is its x coordinate, and the third parameter is the name of its y coordinate. */ GeoGebraPoint("A",1,2); GeoGebraPoint("B",2,2); GeoGebraPoint("C",1,1); %/mathpiper %output,preserve="false" Result: java.lang.Boolean . %/output %mathpiper, output="latex" ax := A["coords"]["x"]; ay := A["coords"]["y"]; bx := B["coords"]["x"]; by := B["coords"]["y"]; cx := C["coords"]["x"]; cy := C["coords"]["y"]; %/mathpiper %hoteqn,preserve="false" Result: 1.0 . %/hoteqn %mathpiper, output="geogebra" bez1(a,b,r) := a*(1-r)+b*r; bez2(a,b,c,r) := bez1(a,b,r)*(1-r) + bez1(b,c,r)*r; f(x) := Expand(bez2(ax,bx,cx,x)); f(x); %/mathpiper %geogebra,preserve="false" Result: 2.0*x-2.0*x^2+1 . %/geogebra %output,preserve="false" GeoGebra updated. . %/output %mathpiper, output="geogebra" g(x) := Expand(bez2(ay,by,cy,x)); g(x); %/mathpiper %geogebra,preserve="false" Result: 2.0-x^2 . %/geogebra %output,preserve="false" GeoGebra updated. . %/output %geogebra, clear="false" curve : curve[f(t),g(t),t,0,1] %/geogebra %output,preserve="false" GeoGebra updated. . %/output %mathpiper, output="latex" {f(x), g(x)}; %/mathpiper %hoteqn,preserve="false" Result: \left(2x-2x^{2}+1,2-x^{2}\right) . %/hoteqn %output,preserve="false" HotEqn updated. . %/output mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/extra_parentheses.mpt0000644000175000017500000004770411166031233026261 0ustar giovannigiovanniIn> ee:=a*b*c/(d*e) Result> (a*b*c)/(d*e) In> TraceOn() Result> True Side Effects> Tracing is on. Leave}(TraceOn(),True); In> ee:=a*b*c/(d*e) Result> (a*b*c)/(d*e) Side Effects> Enter{(:=,ee:=a*b*c/(d*e)); Arg(ee,ee); Arg(a*b*c/(d*e),a*b*c/(d*e)); Enter{(IsList,IsList(aLeftAssign)); Leave}(IsList(aLeftAssign),False); Enter{(IsAtom,IsAtom(aLeftAssign)); Leave}(IsAtom(aLeftAssign),True); Enter{(Prog,[ MacroSet(aLeftAssign,Eval(aRightAssign)); Eval(aLeftAssign); ] ); Arg(MacroSet(aLeftAssign,Eval(aRightAssign)),{MacroSet(aLeftAssign,Eval(aRightAssign)),Eval(aLeftAssign)}); Enter{(MacroSet,MacroSet(aLeftAssign,Eval(aRightAssign))); Enter{(Eval,Eval(aRightAssign)); Enter{(*,a*b*c/(d*e)); Enter{(*,a*b); Arg(a,a); Arg(b,b); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Enter{(IsNonObject,IsNonObject(x)); Arg(x,a); Leave}(IsNonObject(x),True); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(IsNumber,IsNumber(y)); Leave}(IsNumber(y),False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(IsList,IsList(aLeft)); Leave}(IsList(aLeft),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,a); Leave}(IsInfinity(x),False); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Leave}(a*b,a*b); Enter{(/,c/(d*e)); Enter{(*,d*e); Arg(d,d); Arg(e,e); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,d); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,d); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Enter{(IsNonObject,IsNonObject(x)); Arg(x,d); Leave}(IsNonObject(x),True); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(IsNumber,IsNumber(y)); Leave}(IsNumber(y),False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(IsList,IsList(aLeft)); Leave}(IsList(aLeft),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,d); Leave}(IsInfinity(x),False); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Leave}(d*e,d*e); Arg(c,c); Arg(d*e,d*e); Enter{(IsNumber,IsNumber(y)); Leave}(IsNumber(y),False); Enter{(IsNonZeroInteger,IsNonZeroInteger(x)); Arg(x,c); Enter{(And,IsInteger(x)And x!=0); Arg(IsInteger(x),{IsInteger(x),x!=0}); Enter{(IsInteger,IsInteger(x)); Leave}(IsInteger(x),False); Leave}(IsInteger(x)And x!=0,False); Leave}(IsNonZeroInteger(x),False); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,c); Leave}(IsInfinity(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,c); Leave}(IsInfinity(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,c); Leave}(IsInfinity(x),False); Enter{(IsNegativeNumber,IsNegativeNumber(y)); Arg(y,d*e); Enter{(And,IsNumber(x)And x<0); Arg(IsNumber(x),{IsNumber(x),x<0}); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Leave}(IsNumber(x)And x<0,False); Leave}(IsNegativeNumber(y),False); Enter{(IsList,IsList(xlist)); Leave}(IsList(xlist),False); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Leave}(c/(d*e),c/(d*e)); Arg(a*b,a*b); Arg(c/(d*e),c/(d*e)); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a*b); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a*b); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Enter{(IsNonObject,IsNonObject(x)); Arg(x,a*b); Leave}(IsNonObject(x),True); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(/,(x*y)/z); Enter{(*,x*y); Arg(x,a*b); Arg(y,c); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a*b); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsMatrix,IsMatrix(x)); Arg(x,a*b); Enter{(If,If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False)); Arg(IsList($x10)And Length($x10)>0,IsList($x10)And Length($x10)>0); Enter{(And,IsList($x10)And Length($x10)>0); Arg(IsList($x10),{IsList($x10),Length($x10)>0}); Enter{(IsList,IsList($x10)); Leave}(IsList($x10),False); Leave}(IsList($x10)And Length($x10)>0,False); Leave}(If(IsList($x10)And Length($x10)>0,[ Local(n); n:=Length($x10); If(Length(Select(IsVector,$x10))=n,MapSingle(Length,$x10)=Length($x10[1])+ZeroVector(n),False); ] ,False),False); Leave}(IsMatrix(x),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Enter{(IsNonObject,IsNonObject(x)); Arg(x,a*b); Leave}(IsNonObject(x),True); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(IsNumber,IsNumber(y)); Leave}(IsNumber(y),False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(=,f= -1); Enter{(-,-1); Arg(1,1); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),True); Enter{(SubtractN,SubtractN(0,x)); Leave}(SubtractN(0,x),-1); Leave}(-1,-1); Leave}(f= -1,False); Enter{(IsList,IsList(aLeft)); Leave}(IsList(aLeft),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,a*b); Leave}(IsInfinity(x),False); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Leave}(x*y,a*b*c); Arg(x*y,a*b*c); Arg(z,d*e); Enter{(IsNumber,IsNumber(y)); Leave}(IsNumber(y),False); Enter{(IsNonZeroInteger,IsNonZeroInteger(x)); Arg(x,a*b*c); Enter{(And,IsInteger(x)And x!=0); Arg(IsInteger(x),{IsInteger(x),x!=0}); Enter{(IsInteger,IsInteger(x)); Leave}(IsInteger(x),False); Leave}(IsInteger(x)And x!=0,False); Leave}(IsNonZeroInteger(x),False); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,a*b*c); Leave}(IsInfinity(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,a*b*c); Leave}(IsInfinity(x),False); Enter{(IsInfinity,IsInfinity(x)); Arg(x,a*b*c); Leave}(IsInfinity(x),False); Enter{(IsNegativeNumber,IsNegativeNumber(y)); Arg(y,d*e); Enter{(And,IsNumber(x)And x<0); Arg(IsNumber(x),{IsNumber(x),x<0}); Enter{(IsNumber,IsNumber(x)); Leave}(IsNumber(x),False); Leave}(IsNumber(x)And x<0,False); Leave}(IsNegativeNumber(y),False); Enter{(IsList,IsList(xlist)); Leave}(IsList(xlist),False); Enter{(IsList,IsList(y)); Leave}(IsList(y),False); Enter{(IsList,IsList(x)); Leave}(IsList(x),False); Leave}((x*y)/z,(a*b*c)/(d*e)); Leave}(a*b*c/(d*e),(a*b*c)/(d*e)); Leave}(Eval(aRightAssign),(a*b*c)/(d*e)); Leave}(MacroSet(aLeftAssign,Eval(aRightAssign)),True); Enter{(Eval,Eval(aLeftAssign)); Leave}(Eval(aLeftAssign),(a*b*c)/(d*e)); Leave}([ MacroSet(aLeftAssign,Eval(aRightAssign)); Eval(aLeftAssign); ] ,(a*b*c)/(d*e)); Leave}(ee:=a*b*c/(d*e),(a*b*c)/(d*e)); mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/high_school_tests.mpw0000644000175000017500000006447111316262063026254 0ustar giovannigiovanni %mathpiper Echo("pp.100. Express the following in lowest terms. The letter symbols that appear represent positive integers."); NewLine(); equations1 := { {"18/48","3/8"}, "85/100", {"56/-12","-14/3"}, "-91/49", {"(32*a^2)/(16*a)","2*a"}, "(45*x^3*y)/(-15*y^2)", {"(a*b*c)/(c*d)","a*b/d"}, "(2*x + 2)/(x + 1)", {"(2*a - 1)/(b - 2*a*b)","-1/b"}, "(a*b)/(b*a)", {"(6*a + 4)/(12*a)","(3*a+2)/(6*a)"}, "(a + 1)/(a*b + b)", {"(14 - 7*x)/(21)","(2-x)/3"}, "(3*x - x^2)/(x^2 - x)",//x is not equal to 1. {"(a^2 + 7*a)/(a^2)","(a+7)/a"}, "(x^2 - 3*x)/(6*x - 2*x^2)",//x is not equal to 3. {"(5*a^2 - a)/(5*a - 1)","a"}, "(10*a^2 - 2*a)/(10*a^2 + 2*a)", }; count := 1; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 18 Side Effects: pp.100. Express the following in lowest terms. The letter symbols that appear represent positive integers. #1 Problem: 18/48 Answer: "3/8" MathPiper: 3/8 Maxima:(%o543) 3/8 #2 Problem: 85/100 MathPiper: 17/20 Maxima:(%o544) 17/20 #3 Problem: 56/-12 Answer: "-14/3" MathPiper: (-14)/3 Maxima:(%o545) -14/3 #4 Problem: -91/49 MathPiper: (-13)/7 Maxima:(%o546) -13/7 #5 Problem: (32*a^2)/(16*a) Answer: "2*a" MathPiper: 2*a Maxima:(%o547) 2*a #6 Problem: (45*x^3*y)/(-15*y^2) MathPiper: (-3*x^3)/y Maxima:(%o548) -3*x^3/y #7 Problem: (a*b*c)/(c*d) Answer: "a*b/d" MathPiper: (a*b)/d Maxima:(%o549) a*b/d #8 Problem: (2*x + 2)/(x + 1) MathPiper: 2 Maxima:(%o550) 2 #9 Problem: (2*a - 1)/(b - 2*a*b) Answer: "-1/b" MathPiper: (2*a-1)/(b*(1-2*a)) Maxima:(%o551) -1/b #10 Problem: (a*b)/(b*a) MathPiper: 1 Maxima:(%o552) 1 #11 Problem: (6*a + 4)/(12*a) Answer: "(3*a+2)/(6*a)" MathPiper: (3*a+2)/(6*a) Maxima:(%o553) (3*a+2)/(6*a) #12 Problem: (a + 1)/(a*b + b) MathPiper: 1/b Maxima:(%o554) 1/b #13 Problem: (14 - 7*x)/(21) Answer: "(2-x)/3" MathPiper: (2-x)/3 Maxima:(%o555) -(x-2)/3 #14 Problem: (3*x - x^2)/(x^2 - x) MathPiper: (3-x)/(x-1) Maxima:(%o556) -(x-3)/(x-1) #15 Problem: (a^2 + 7*a)/(a^2) Answer: "(a+7)/a" MathPiper: (a+7)/a Maxima:(%o557) (a+7)/a #16 Problem: (x^2 - 3*x)/(6*x - 2*x^2) MathPiper: (x-3)/(2*(3-x)) Maxima:(%o558) -1/2 #17 Problem: (5*a^2 - a)/(5*a - 1) Answer: "a" MathPiper: a Maxima:(%o559) a #18 Problem: (10*a^2 - 2*a)/(10*a^2 + 2*a) MathPiper: (5*a-1)/(5*a+1) Maxima:(%o560) (5*a-1)/(5*a+1) . %/output %mathpiper Echo("pp.105. Perform the following additions. Express each result in lowest terms. The letter symbols that appear represent positive integers."); NewLine(); equations1 := { {"2/3 + 5/3","7/3"}, "1/9 + 4/9 + 5/9", {"2/7 + 3/7 + 5/7","10/7"}, "a/y + b/y + c/y", {"a/x + 3*a/x + 4*a/x","8*a/x"}, "x/(x+y) + x/(x + y)", {"a/(a + 1) + 1/(a + 1)","1"}, "2/3 + 4/5", {"3 + 7/6 + 2/3","29/6"}, "y/3 + 2*y/9", {"3*y + y/5","16*y/5"}, "x/2 + x/3 + x/4", {"4/a + 3/(2*a)","11/(2*a)"}, "1/a + 1/b + 1/c", {"b*c + 1/c","(b*c^2+1)/c"}, "x/(x+y) + 7", {"1/(2*m) + (a + 3)/(4*m)","(a+5)/(4*m)"}, "9/x^2 + 4/x", {"a/(x + y) + b/(x + y)","(a+b)/(x+y)"}, "1/a + 3/(a*b) + 2/b", {"2*x/a + 3*y/b","(2*b*x+3*a*y)/(a*b)"}, "2/a + 7/(a*b*c) + 6/c", }; count := 1; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 22 Side Effects: pp.105. Perform the following additions. Express each result in lowest terms. The letter symbols that appear represent positive integers. #1 Problem: 2/3 + 5/3 Answer: "7/3" MathPiper: 7/3 Maxima:(%o385) 7/3 #2 Problem: 1/9 + 4/9 + 5/9 MathPiper: 10/9 Maxima:(%o386) 10/9 #3 Problem: 2/7 + 3/7 + 5/7 Answer: "10/7" MathPiper: 10/7 Maxima:(%o387) 10/7 #4 Problem: a/y + b/y + c/y MathPiper: (a+b+c)/y Maxima:(%o388) (c+b+a)/y #5 Problem: a/x + 3*a/x + 4*a/x Answer: "8*a/x" MathPiper: (8*a)/x Maxima:(%o389) 8*a/x #6 Problem: x/(x+y) + x/(x + y) MathPiper: (2*x)/(x+y) Maxima:(%o390) 2*x/(y+x) #7 Problem: a/(a + 1) + 1/(a + 1) Answer: "1" MathPiper: 1 Maxima:(%o391) 1 #8 Problem: 2/3 + 4/5 MathPiper: 22/15 Maxima:(%o392) 22/15 #9 Problem: 3 + 7/6 + 2/3 Answer: "29/6" MathPiper: 29/6 Maxima:(%o393) 29/6 #10 Problem: y/3 + 2*y/9 MathPiper: (5*y)/9 Maxima:(%o394) 5*y/9 #11 Problem: 3*y + y/5 Answer: "16*y/5" MathPiper: (16*y)/5 Maxima:(%o395) 16*y/5 #12 Problem: x/2 + x/3 + x/4 MathPiper: (13*x)/12 Maxima:(%o396) 13*x/12 #13 Problem: 4/a + 3/(2*a) Answer: "11/(2*a)" MathPiper: (11*a)/(2*a^2) Maxima:(%o397) 11/(2*a) #14 Problem: 1/a + 1/b + 1/c MathPiper: (a*b+a*c+b*c)/(a*b*c) Maxima:(%o398) ((b+a)*c+a*b)/(a*b*c) #15 Problem: b*c + 1/c Answer: "(b*c^2+1)/c" MathPiper: (b*c^2+1)/c Maxima:(%o399) (b*c^2+1)/c #16 Problem: x/(x+y) + 7 MathPiper: (8*x+7*y)/(x+y) Maxima:(%o400) (7*y+8*x)/(y+x) #17 Problem: 1/(2*m) + (a + 3)/(4*m) Answer: "(a+5)/(4*m)" MathPiper: (m*a+5*m)/(4*m^2) Maxima:(%o401) (a+5)/(4*m) #18 Problem: 9/x^2 + 4/x MathPiper: (4*x^2+9*x)/x^3 Maxima:(%o402) (4*x+9)/x^2 #19 Problem: a/(x + y) + b/(x + y) Answer: "(a+b)/(x+y)" MathPiper: (a+b)/(x+y) Maxima:(%o403) (b+a)/(y+x) #20 Problem: 1/a + 3/(a*b) + 2/b MathPiper: (2*a^2*b+a*b^2+3*a*b)/(a^2*b^2) Maxima:(%o404) (b+2*a+3)/(a*b) #21 Problem: 2*x/a + 3*y/b Answer: "(2*b*x+3*a*y)/(a*b)" MathPiper: (2*x*b+3*a*y)/(a*b) Maxima:(%o405) (3*a*y+2*b*x)/(a*b) #22 Problem: 2/a + 7/(a*b*c) + 6/c MathPiper: (6*a^2*b*c+2*a*b*c^2+7*a*c)/(a^2*b*c^2) Maxima:(%o406) (2*b*c+6*a*b+7)/(a*b*c) . %/output %mathpiper Echo("pp.112. Find the following products. Express each result in lowest terms. The letter symbols represent positive integers."); NewLine(); equations1 := { {"3*(4/9)","4/3"}, {"5*(7/11)",""}, {"2/3*6","4"}, {"5/8*4/15",""}, {"91/119*34/39","2/3"}, {"a/b*1/a",""}, {"(3*a)/(2*b)*(5*a^2)/(9*b)","(5*a^3)/(6*b^2)"}, {"(a/b)*(a/b)",""}, {"(1/x^2)*(2/3)*(x/4)","1/(6*x)"}, {"(m^2/n)*(n/m^2)",""}, {"((a^2+a*x)/3)*(6/(a+x))","2*a"}, {"((2*x+12)/(x+5))*((3*x+15)/(x+6))",""}, {"((x + 1)/x)*(x^2/(x^2+x))","1"}, {"((4*x*y)/(x+3))*((3*x^2+9*x)/(16*y^2))",""}, {"(2/6)*(1/2)*(3/4)","1/8"}, {"(a/2)*(4/a^2)*(3/5)",""}, {"((3*x+12)/x)*(2*x^2/(x+4))","6*x"}, {"(y^3/(15*x+6))*((5*x+2)/y)",""}, {"((2*a+b)/(7*a*b))*3*b^2/(4*a+2*b)","(3*b)/(14*a)"}, {"(5/(a^3+a^2*y))*((a^2+a*y)/25)",""}, {"((2*a^2+3*a^2)/b)*(b^3/a^2)","5*b^2"}, {"((4*y+4)/7)*(14/(2*y^2+2*y))",""}, {"skip",""}, {"skip",""}, {"(4*a+4)/4","a+1"}, {"(2*x+6)/2",""}, {"(a^2+a)/a","a+1"}, {"(a*x+a*y)/a",""}, }; count := 1; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 28 Side Effects: pp.112. Find the following products. Express each result in lowest terms. The letter symbols represent positive integers. #1 Problem: 3*(4/9) Answer: "4/3" MathPiper: 4/3 Maxima:(%o429) 4/3 #2 Problem: 5*(7/11) Answer: "" MathPiper: 35/11 Maxima:(%o430) 35/11 #3 Problem: 2/3*6 Answer: "4" MathPiper: 4 Maxima:(%o431) 4 #4 Problem: 5/8*4/15 Answer: "" MathPiper: 1/6 Maxima:(%o432) 1/6 #5 Problem: 91/119*34/39 Answer: "2/3" MathPiper: 2/3 Maxima:(%o433) 2/3 #6 Problem: a/b*1/a Answer: "" MathPiper: 1/b Maxima:(%o434) 1/b #7 Problem: (3*a)/(2*b)*(5*a^2)/(9*b) Answer: "(5*a^3)/(6*b^2)" MathPiper: (5*a^3)/(6*b^2) Maxima:(%o435) 5*a^3/(6*b^2) #8 Problem: (a/b)*(a/b) Answer: "" MathPiper: a^2/b^2 Maxima:(%o436) a^2/b^2 #9 Problem: (1/x^2)*(2/3)*(x/4) Answer: "1/(6*x)" MathPiper: 1/(6*x) Maxima:(%o437) 1/(6*x) #10 Problem: (m^2/n)*(n/m^2) Answer: "" MathPiper: 1 Maxima:(%o438) 1 #11 Problem: ((a^2+a*x)/3)*(6/(a+x)) Answer: "2*a" MathPiper: 2*a Maxima:(%o439) 2*a #12 Problem: ((2*x+12)/(x+5))*((3*x+15)/(x+6)) Answer: "" MathPiper: 6 Maxima:(%o440) 6 #13 Problem: ((x + 1)/x)*(x^2/(x^2+x)) Answer: "1" MathPiper: 1 Maxima:(%o441) 1 #14 Problem: ((4*x*y)/(x+3))*((3*x^2+9*x)/(16*y^2)) Answer: "" MathPiper: (3*x^2)/(4*y) Maxima:(%o442) 3*x^2/(4*y) #15 Problem: (2/6)*(1/2)*(3/4) Answer: "1/8" MathPiper: 1/8 Maxima:(%o443) 1/8 #16 Problem: (a/2)*(4/a^2)*(3/5) Answer: "" MathPiper: 6/(5*a) Maxima:(%o444) 6/(5*a) #17 Problem: ((3*x+12)/x)*(2*x^2/(x+4)) Answer: "6*x" MathPiper: 6*x Maxima:(%o445) 6*x #18 Problem: (y^3/(15*x+6))*((5*x+2)/y) Answer: "" MathPiper: y^2/3 Maxima:(%o446) y^2/3 #19 Problem: ((2*a+b)/(7*a*b))*3*b^2/(4*a+2*b) Answer: "(3*b)/(14*a)" MathPiper: (3*b)/(14*a) Maxima:(%o447) 3*b/(14*a) #20 Problem: (5/(a^3+a^2*y))*((a^2+a*y)/25) Answer: "" MathPiper: 1/(5*a) Maxima:(%o448) 1/(5*a) #21 Problem: ((2*a^2+3*a^2)/b)*(b^3/a^2) Answer: "5*b^2" MathPiper: 5*b^2 Maxima:(%o449) 5*b^2 #22 Problem: ((4*y+4)/7)*(14/(2*y^2+2*y)) Answer: "" MathPiper: 4/y Maxima:(%o450) 4/y #23 Problem: skip Answer: "" MathPiper: skip Maxima:(%o451) skip #24 Problem: skip Answer: "" MathPiper: skip Maxima:(%o452) skip #25 Problem: (4*a+4)/4 Answer: "a+1" MathPiper: a+1 Maxima:(%o453) a+1 #26 Problem: (2*x+6)/2 Answer: "" MathPiper: x+3 Maxima:(%o454) x+3 #27 Problem: (a^2+a)/a Answer: "a+1" MathPiper: a+1 Maxima:(%o455) a+1 #28 Problem: (a*x+a*y)/a Answer: "" MathPiper: x+y Maxima:(%o456) y+x . %/output %mathpiper Echo("pp.130. Problems 1-24: Perform the following divisions. Express results in lowest terms. The letter symbols represent positive integers."); NewLine(); equations1 := { {"(7/8)/(2/3)","21/16"}, {"4/(3/5)",""}, {"(3/5)/4","3/20"}, {"(a/b)/a",""}, {"a/(a/b)","b"}, {"((x+y)/x)/x",""}, {"x/((x+y)/x)","x^2/(x+y)"}, {"(x/y)/(y/x)",""}, {"(x/(x+y))/(x/y)","y/(x+y)"}, {"a/(a*b)",""}, {"(a*b)/a","b"}, {"(x/2)/((5*x^2)/8)",""}, {"((a+b)/a)/(b/a)","(a+b)/b"}, {"((a+b)/a)/(a/b)",""}, {"((2*a)/(3*b))/((4*a)/27)","9/(2*b)"}, {"(a/(a+b))/((3*a)/(a*c+b*c))",""}, {"((5*x+10)/x^2)/(5/x)","(x+2)/x"}, {"((x*y+x)/(y))/((a*y+a)/(y^2))",""}, {"(y^2/(15*x+6))/(y/(5*x+2))","y/3"}, {"((3*x+12)/x)/((x+4)/(2*x^2))",""}, {"(5/(a^3+a^2*y))/(25/(a^2+a*y))","1/(5*a)"}, {"((2*a+b)/(7*a*b))/((4*a+2*b)/(3*b^2))",""}, {"((4*y+4)/7)/((2*y^2+2*y)/14)","4/y"}, {"((2*a^2+3*a^2)/b)/(a^2/b^3)",""}, {"skip",""}, {"skip",""},//26. {"(1/2+1/3)/(1/4+1/5)",""}, {"(1/x+1/y)/(2/x+2/y)",""}, {"(8+3/4)*(2/3)",""}, {"(4+1/3)*(6+1/2)",""}, {"(2+1/2)/(5+1/3)",""},//31. {"(6+1/2)+(14+1/3)",""}, {"(4+2/7)/(3+1/3)",""}, {"(4+2/7)*(3+1/3)",""}, {"(1/x+3)/(4+2/x)",""}, {"((x+y)/4)/((2*x+2*y)/8)",""},//36. {"((1+x)/3)/((3+3*x)/7)",""}, {"(3-1/x^2)/(2+1/x)",""}, {"(a/2+b/3)/((3*a+2*b)/5)",""}, {"(2/a+3/b)/(5/a+4/b)",""},//40 }; count := 1; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 40 Side Effects: pp.130. Problems 1-24: Perform the following divisions. Express results in lowest terms. The letter symbols represent positive integers. #1 Problem: (7/8)/(2/3) Answer: "21/16" MathPiper: 21/16 Maxima:(%o471) 21/16 #2 Problem: 4/(3/5) Answer: "" MathPiper: 20/3 Maxima:(%o472) 20/3 #3 Problem: (3/5)/4 Answer: "3/20" MathPiper: 3/20 Maxima:(%o473) 3/20 #4 Problem: (a/b)/a Answer: "" MathPiper: 1/b Maxima:(%o474) 1/b #5 Problem: a/(a/b) Answer: "b" MathPiper: b Maxima:(%o475) b #6 Problem: ((x+y)/x)/x Answer: "" MathPiper: (x+y)/x^2 Maxima:(%o476) (y+x)/x^2 #7 Problem: x/((x+y)/x) Answer: "x^2/(x+y)" MathPiper: x^2/(x+y) Maxima:(%o477) x^2/(y+x) #8 Problem: (x/y)/(y/x) Answer: "" MathPiper: x^2/y^2 Maxima:(%o478) x^2/y^2 #9 Problem: (x/(x+y))/(x/y) Answer: "y/(x+y)" MathPiper: y/(x+y) Maxima:(%o479) y/(y+x) #10 Problem: a/(a*b) Answer: "" MathPiper: 1/b Maxima:(%o480) 1/b #11 Problem: (a*b)/a Answer: "b" MathPiper: b Maxima:(%o481) b #12 Problem: (x/2)/((5*x^2)/8) Answer: "" MathPiper: 4/(5*x) Maxima:(%o482) 4/(5*x) #13 Problem: ((a+b)/a)/(b/a) Answer: "(a+b)/b" MathPiper: (a+b)/b Maxima:(%o483) (b+a)/b #14 Problem: ((a+b)/a)/(a/b) Answer: "" MathPiper: ((a+b)*b)/a^2 Maxima:(%o484) (b^2+a*b)/a^2 #15 Problem: ((2*a)/(3*b))/((4*a)/27) Answer: "9/(2*b)" MathPiper: 9/(2*b) Maxima:(%o485) 9/(2*b) #16 Problem: (a/(a+b))/((3*a)/(a*c+b*c)) Answer: "" MathPiper: c/3 Maxima:(%o486) c/3 #17 Problem: ((5*x+10)/x^2)/(5/x) Answer: "(x+2)/x" MathPiper: (x+2)/x Maxima:(%o487) (x+2)/x #18 Problem: ((x*y+x)/(y))/((a*y+a)/(y^2)) Answer: "" MathPiper: (x*y)/a Maxima:(%o488) x*y/a #19 Problem: (y^2/(15*x+6))/(y/(5*x+2)) Answer: "y/3" MathPiper: y/3 Maxima:(%o489) y/3 #20 Problem: ((3*x+12)/x)/((x+4)/(2*x^2)) Answer: "" MathPiper: 6*x Maxima:(%o490) 6*x #21 Problem: (5/(a^3+a^2*y))/(25/(a^2+a*y)) Answer: "1/(5*a)" MathPiper: 1/(5*a) Maxima:(%o491) 1/(5*a) #22 Problem: ((2*a+b)/(7*a*b))/((4*a+2*b)/(3*b^2)) Answer: "" MathPiper: (3*b)/(14*a) Maxima:(%o492) 3*b/(14*a) #23 Problem: ((4*y+4)/7)/((2*y^2+2*y)/14) Answer: "4/y" MathPiper: 4/y Maxima:(%o493) 4/y #24 Problem: ((2*a^2+3*a^2)/b)/(a^2/b^3) Answer: "" MathPiper: 5*b^2 Maxima:(%o494) 5*b^2 #25 Problem: skip Answer: "" MathPiper: skip Maxima:(%o495) skip #26 Problem: skip Answer: "" MathPiper: skip Maxima:(%o496) skip #27 Problem: (1/2+1/3)/(1/4+1/5) Answer: "" MathPiper: 50/27 Maxima:(%o497) 50/27 #28 Problem: (1/x+1/y)/(2/x+2/y) Answer: "" MathPiper: 1/2 Maxima:(%o498) 1/2 #29 Problem: (8+3/4)*(2/3) Answer: "" MathPiper: 35/6 Maxima:(%o499) 35/6 #30 Problem: (4+1/3)*(6+1/2) Answer: "" MathPiper: 169/6 Maxima:(%o500) 169/6 #31 Problem: (2+1/2)/(5+1/3) Answer: "" MathPiper: 15/32 Maxima:(%o501) 15/32 #32 Problem: (6+1/2)+(14+1/3) Answer: "" MathPiper: 125/6 Maxima:(%o502) 125/6 #33 Problem: (4+2/7)/(3+1/3) Answer: "" MathPiper: 9/7 Maxima:(%o503) 9/7 #34 Problem: (4+2/7)*(3+1/3) Answer: "" MathPiper: 100/7 Maxima:(%o504) 100/7 #35 Problem: (1/x+3)/(4+2/x) Answer: "" MathPiper: (3*x+1)/(2*(2*x+1)) Maxima:(%o505) (3*x+1)/(4*x+2) #36 Problem: ((x+y)/4)/((2*x+2*y)/8) Answer: "" MathPiper: 1 Maxima:(%o506) 1 #37 Problem: ((1+x)/3)/((3+3*x)/7) Answer: "" MathPiper: 7/9 Maxima:(%o507) 7/9 #38 Problem: (3-1/x^2)/(2+1/x) Answer: "" MathPiper: (3*x^2-1)/(x*(2*x+1)) Maxima:(%o508) (3*x^2-1)/(2*x^2+x) #39 Problem: (a/2+b/3)/((3*a+2*b)/5) Answer: "" MathPiper: 5/6 Maxima:(%o509) 5/6 #40 Problem: (2/a+3/b)/(5/a+4/b) Answer: "" MathPiper: (3*a+2*b)/(4*a+5*b) Maxima:(%o510) (2*b+3*a)/(5*b+4*a) . %/output %mathpiper Echo("pp.130. Problems 27-40: Perform the following calculations. Express results in lowest terms. In exercises in which letter symbols appear, tell what values of the letter symbols must be excluded. Problems 41-63: Combine the following expressions into a single fraction in lowest terms. Indicate the values of the letter symbols which must be excluded."); NewLine(); equations1 := { {"((1/2)+(1/3))/((1/4)+(1/5))",""}, {"((1/x)+(1/y))/((2/x)+(2/y))",""}, {"(8+(2/3))*(2/3)",""}, {"(4+(1/3))+(6+(1/2))",""}, {"(2+(1/2))/(5+(1/3))",""}, {"(6+(1/2))+(14+(1/3))",""},//32. {"(4+(2/7))/(3+(1/3))",""}, {"(4+(2/7))*(3+(1/3))",""}, {"((1/x)+3)/(4+(2/x))",""}, {"((x+y)/4)/((2*x+2*y)/8)",""},//36. {"((1+x)/3)/((3+3*x)/7)",""}, {"(3-(1/x^2))/(2+(1/x))",""}, {"((a/2)+(b/3))/((3*a+2*b)/5)",""}, {"((2/a)+(3/b))/((5/a)+(4/b))",""}, }; count := 27; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 40 Side Effects: pp.130. Problems 27-40: Perform the following calculations. Express results in lowest terms. In exercises in which letter symbols appear, tell what values of the letter symbols must be excluded. Problems 41-63: Combine the following expressions into a single fraction in lowest terms. Indicate the values of the letter symbols which must be excluded. #27 Problem: ((1/2)+(1/3))/((1/4)+(1/5)) Answer: "" MathPiper: 50/27 Maxima:(%o511) 50/27 #28 Problem: ((1/x)+(1/y))/((2/x)+(2/y)) Answer: "" MathPiper: 1/2 Maxima:(%o512) 1/2 #29 Problem: (8+(2/3))*(2/3) Answer: "" MathPiper: 52/9 Maxima:(%o513) 52/9 #30 Problem: (4+(1/3))+(6+(1/2)) Answer: "" MathPiper: 65/6 Maxima:(%o514) 65/6 #31 Problem: (2+(1/2))/(5+(1/3)) Answer: "" MathPiper: 15/32 Maxima:(%o515) 15/32 #32 Problem: (6+(1/2))+(14+(1/3)) Answer: "" MathPiper: 125/6 Maxima:(%o516) 125/6 #33 Problem: (4+(2/7))/(3+(1/3)) Answer: "" MathPiper: 9/7 Maxima:(%o517) 9/7 #34 Problem: (4+(2/7))*(3+(1/3)) Answer: "" MathPiper: 100/7 Maxima:(%o518) 100/7 #35 Problem: ((1/x)+3)/(4+(2/x)) Answer: "" MathPiper: (3*x+1)/(2*(2*x+1)) Maxima:(%o519) (3*x+1)/(4*x+2) #36 Problem: ((x+y)/4)/((2*x+2*y)/8) Answer: "" MathPiper: 1 Maxima:(%o520) 1 #37 Problem: ((1+x)/3)/((3+3*x)/7) Answer: "" MathPiper: 7/9 Maxima:(%o521) 7/9 #38 Problem: (3-(1/x^2))/(2+(1/x)) Answer: "" MathPiper: (3*x^2-1)/(x*(2*x+1)) Maxima:(%o522) (3*x^2-1)/(2*x^2+x) #39 Problem: ((a/2)+(b/3))/((3*a+2*b)/5) Answer: "" MathPiper: 5/6 Maxima:(%o523) 5/6 #40 Problem: ((2/a)+(3/b))/((5/a)+(4/b)) Answer: "" MathPiper: (3*a+2*b)/(4*a+5*b) Maxima:(%o524) (2*b+3*a)/(5*b+4*a) . %/output %mathpiper Echo("pp.130. Problems 41-63: Combine the following expressions into a single fraction in lowest terms. Indicate the values of the letter symbols which must be excluded."); NewLine(); equations1 := { {"(4/(2*x))-((3*x)/5)+(6/x)",""}, {"(8/(x+3))+5+(3/7)",""}, {"(2/(y+2))-(3/(y+2))",""}, {"(3/(2*x-1))+4-(x/(1-2*x))",""}, {"((6*a)/(2*a-3))-(9/(2*a-3))",""}, {"((a*x)/(x+a))*((x+a)/(x*a))",""}, {"((m-4)/12)*(18/(m^2-4*m))",""},//47 {"((x*y-x)/y)/((a*y-a)/(y^2))",""}, {"((2*a-b)/(a+b))-((2*a-2*b)/(a+b))",""}, {"((2*a)/(a-b))+(a/(b-a))",""}, {"(b/(3*a))-((a-1)/(5*b))",""}, {"((a*b+a*c)/(b*m+b*n))/((b+c)/(m+n))",""},//52. {"((2*x+8)/(3*x-9))*(3/(x+4))",""}, {"((x^2+y^2)/(m+n))-((x^2-y^2)/(m+n))",""}, {"(1/2)-((a-1)/a)+((a-2)/a^2)",""}, {"((3/(x-4)))-(4/(x-4))",""}, {"(7/(a-b))-(5/(b-a))",""}, {"((2*x))",""}, }; count := 41; ForEach(e,equations1) [ If(IsList(e), [answer := e[2]; e := e[1];]); Echo("#",count ,"Problem: ",e, If(IsBound(answer),ToString()[WriteString(" Answer: " );Write(answer);Clear(answer);],"") ); //Echo(PrettyForm(e)); Echo("MathPiper: ",Simplify(Eval(FromString(e:";") Read()))); me := ToString()[WriteString("ratsimp(");Write(Atom(e));WriteString(")");]; Echo("Maxima:",Maxima(me)); count := count + 1; ]; count - 1; %/mathpiper %output,preserve="false" Result: 58 Side Effects: pp.130. Problems 41-63: Combine the following expressions into a single fraction in lowest terms. Indicate the values of the letter symbols which must be excluded. #41 Problem: (4/(2*x))-((3*x)/5)+(6/x) Answer: "" MathPiper: (40*x-3*x^3)/(5*x^2) Maxima:(%o525) -(3*x^2-40)/(5*x) #42 Problem: (8/(x+3))+5+(3/7) Answer: "" MathPiper: (2*(19*x+85))/(7*(x+3)) Maxima:(%o526) (38*x+170)/(7*x+21) #43 Problem: (2/(y+2))-(3/(y+2)) Answer: "" MathPiper: (-(y+2))/(y^2+4*y+4) Maxima:(%o527) -1/(y+2) #44 Problem: (3/(2*x-1))+4-(x/(1-2*x)) Answer: "" MathPiper: (11*x-18*x^2-1)/(4*x-4*x^2-1) Maxima:(%o528) (9*x-1)/(2*x-1) #45 Problem: ((6*a)/(2*a-3))-(9/(2*a-3)) Answer: "" MathPiper: 3 Maxima:(%o529) 3 #46 Problem: ((a*x)/(x+a))*((x+a)/(x*a)) Answer: "" MathPiper: 1 Maxima:(%o530) 1 #47 Problem: ((m-4)/12)*(18/(m^2-4*m)) Answer: "" MathPiper: 3/(2*m) Maxima:(%o531) 3/(2*m) #48 Problem: ((x*y-x)/y)/((a*y-a)/(y^2)) Answer: "" MathPiper: (x*y)/a Maxima:(%o532) x*y/a #49 Problem: ((2*a-b)/(a+b))-((2*a-2*b)/(a+b)) Answer: "" MathPiper: (a*b+b^2)/(a^2+2*a*b+b^2) Maxima:(%o533) b/(b+a) #50 Problem: ((2*a)/(a-b))+(a/(b-a)) Answer: "" MathPiper: (a*b-a^2)/(2*a*b-a^2-b^2) Maxima:(%o534) -a/(b-a) #51 Problem: (b/(3*a))-((a-1)/(5*b)) Answer: "" MathPiper: (5*b^2+3*a-3*a^2)/(15*b*a) Maxima:(%o535) (5*b^2-3*a^2+3*a)/(15*a*b) #52 Problem: ((a*b+a*c)/(b*m+b*n))/((b+c)/(m+n)) Answer: "" MathPiper: a/b Maxima:(%o536) a/b #53 Problem: ((2*x+8)/(3*x-9))*(3/(x+4)) Answer: "" MathPiper: (2*(x+4))/(x^2+x-12) Maxima:(%o537) 2/(x-3) #54 Problem: ((x^2+y^2)/(m+n))-((x^2-y^2)/(m+n)) Answer: "" MathPiper: (2*y^2*m+2*y^2*n)/(m^2+2*m*n+n^2) Maxima:(%o538) 2*y^2/(n+m) #55 Problem: (1/2)-((a-1)/a)+((a-2)/a^2) Answer: "" MathPiper: (4*a^2-a^3-4*a)/(2*a^3) Maxima:(%o539) -(a^2-4*a+4)/(2*a^2) #56 Problem: ((3/(x-4)))-(4/(x-4)) Answer: "" MathPiper: (4-x)/(x^2-8*x+16) Maxima:(%o540) -1/(x-4) #57 Problem: (7/(a-b))-(5/(b-a)) Answer: "" MathPiper: (12*(b-a))/(2*a*b-a^2-b^2) Maxima:(%o541) -12/(b-a) #58 Problem: ((2*x)) Answer: "" MathPiper: 2*x Maxima:(%o542) 2*x . %/output %mathpiper //Manipulating symbolic equations. z := a*b==c; z+5; z-5; z*2; z/6; z^2; Sqrt(z); //Implement symbolic arithmetic so that m := 144 == 20 * a + b; n := 136 == 10 * a + b;c := m-n; works. %/mathpiper mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/options_test.mpw0000644000175000017500000000264211343407116025266 0ustar giovannigiovanni%mathpiper Retract("tstSolve",*); RulebaseListed("tstSolve",{expression, variable, optionsList}); //Handle no option call. 5 # tstSolve(_expression, _variable) <-- tstSolve(expression, variable, {}); //Main routine. It will automatically accept 2 or more option calls because the //options come in a list. 10 # tstSolve(_expression, _variable, optionsList_IsList) <-- [ Local(options); Echo(expression, variable, optionsList); options := OptionsToAssociativeList(optionsList); Echo("All submitted options: ", options); Echo("The roots option is set to ", options["roots"]); ]; //Handle a single option call because the option does not come in a list for some reason. 20 # tstSolve(_expression, _variable, _singleOption) <-- tstSolve(expression, variable, {singleOption}); %/mathpiper %output,preserve="false" Result: True . %/output //No option call. In> tstSolve(x^2+x,x) Result: {} Side Effects: x^2+x x {} All submitted options: {} The roots option is set to Empty //One option call. In> TestSolve(x^2+x,x,roots->R) Result: TestSolve(x^2+x,x,roots->R) //Multiple option call. In> tstSolve(x^2+x,x,roots->R, option2 -> 15, option3 -> test) Result: {{"option3","test"},{"option2","15"},{"roots","R"}} Side Effects: x^2+x x {roots->R,option2->15,option3->test} All submitted options: {{"option3","test"},{"option2","15"},{"roots","R"}} The roots option is set to R mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/local_pattern_matching.mpw0000644000175000017500000025256211417150721027244 0ustar giovannigiovanni%mathpiper E := A(x,y) + B(x,y,z); F := Deriv(z) E; Echo("F: ",F); G := ( F /: { (Deriv(_var)(_w))_(IsFreeOf(var,w)) <- 0 } ); //G := ( (Deriv(z)A(x,y)) /: {(Deriv(_var)(_w))_(IsFreeOf(var,w)) <- Echo("KALI ",,,var,,,w)} ); //G := ( (Deriv(z)A(x,y)) /: {(Deriv(_var)(_w)) <- Echo("KALI ",,,var,,,w)} ); // (Deriv(_var)(_x / _y))_(IsFreeOf(var,y)) <-- (Deriv(var) x) / y; //WriteString("E = "); Echo(E); //WriteString("F = "); Echo(F); WriteString("G = "); Echo(G); /*1 # (Deriv(_var)(_w))_(IsFreeOf(var,w)) <-- 0; G := Eval(F) ; WriteString("G = "); Echo(G);NewLine(); */ %/mathpiper %output,preserve="false" Result: True Side Effects: F: (Deriv(z)A(x,y))+(Deriv(z)B(x,y,z)) G = 0+(Deriv(z)B(x,y,z)) . %/output F: (Deriv(z)A(x,y))+(Deriv(z)B(x,y,z)) G = (Deriv(z)A(x,y))+(Deriv(z)B(x,y,z)) F: (Deriv(z)A(x,y))+(Deriv(z)B(x,y,z)) G = 0+(Deriv(z)B(x,y,z)) G = Deriv(z)B(x,y,z) %mathpiper (b + c) * (d + e) /: {(x_IsAtom + _y) <- Echo(x,,,y)}; %/mathpiper %mathpiper,output="trace" //(b + c) * (d + e) /: {(x_IsAtom + _y) <- Echo(x,,,y)}; Retract("LocProcessSingle",*); 40 # LocProcessSingle(pat_IsFunction <- _exp) <-- [ Local(justPattern, postPredicate); If(Type(pat) = "_", [ justPattern := pat[1]; postPredicate := pat[2]; ], [ justPattern := pat; postPredicate := True; ] ); { {justPattern[0],PatternCreate(justPattern,postPredicate)},exp }; ]; //TraceExcept("MacroLocal,ApplyPure,Apply,MapSingle,+,ForEach,*,++,>=,<=,:=,IsUniVar,IsNumber,IsNegativeNumber,For,IsInfinity,IsMatrix,IsNonObject,SubtractN,-,MathSign,IsGeneric,Or,IsString,AbsN,UnFence,LocalSymbols,GreaterThan,Retract,=,UnList,Hold,Equals,IsFunction,Listify,Head,Nth,MathNth,Type,Prog,And,NotEquals,Local,Tail,DefLoadFunction,Not,IsInteger,Set,String,Length,If,List,MakeVector,IsList,LessThan,While,DestructiveReverse,MacroSet,Eval,DestructiveInsert,AddN,IsAtom,Atom,ConcatStrings", (b + c) * (d + e) /: {(x_IsAtom + _y)_(IsZero(0)) <- Echo(x,,,y)} ); %/mathpiper %mathpiper_trace,preserve="false" Result: True . %/mathpiper_trace %mathpiper,output="trace" //(b + c) * (d + e) /: {(x_IsAtom + _y) <- Echo(x,,,y)}; Retract("LocProcessSingle",*); 40 # LocProcessSingle(pat_IsFunction <- _exp) <-- [ { {pat[0],PatternCreate(pat,True)},exp }; ]; //10 # LocProcessSingle({_pat,_post,_exp}) <-- { {pat[0],PatternCreate(pat,post)},exp }; //20 # LocProcessSingle({pat_IsFunction,_exp}) <-- { {pat[0],PatternCreate(pat,True)},exp }; //30 # LocProcessSingle({pat_IsAtom,_exp}) <-- { pat,exp }; //50 # LocProcessSingle(pat_IsAtom <- _exp) <-- { pat,exp }; TraceExcept("MacroLocal,ApplyPure,Apply,MapSingle,+,ForEach,*,++,>=,<=,:=,IsUniVar,IsNumber,IsNegativeNumber,For,IsInfinity,IsMatrix,IsNonObject,SubtractN,-,MathSign,IsGeneric,Or,IsString,AbsN,UnFence,LocalSymbols,GreaterThan,Retract,=,UnList,Hold,Equals,IsFunction,Listify,Head,Nth,MathNth,Type,Prog,And,NotEquals,Local,Tail,DefLoadFunction,Not,IsInteger,Set,String,Length,If,List,MakeVector,IsList,LessThan,While,DestructiveReverse,MacroSet,Eval,DestructiveInsert,AddN,IsAtom,Atom,ConcatStrings", (b + c) * (d + e) /: {(x_IsAtom + _y) <- Echo(x,,,y)} ); %/mathpiper %mathpiper E := A(x,y) + B(x,y,z); F := Deriv(z) E; G := ( Eval(F) /: { (Deriv(_var)(_w))_(IsFreeOf(var,w)) <- 0 } ); WriteString("E = "); Echo(E); WriteString("F = "); Echo(F); WriteString("G = "); Echo(G); WriteString("G simplified = "); Echo(Simplify(G)); 1 # (Deriv(_var)(_w))_(IsFreeOf(var,w)) <-- 0; G := Eval(F) ; WriteString("G = "); Echo(G);NewLine(); %/mathpiper %output,preserve="false" Result: True Side Effects: E = A(x,y)+B(x,y,z) F = Deriv(z)B(x,y,z) G = Deriv(z)B(x,y,z) G simplified = Deriv(z)B(x,y,z) G = Deriv(z)B(x,y,z) . %/output (x_IsBound + y_IsOdd) <- m1, (x_IsBound + y_IsEven) <- m3, %mathpiper Hold((a + b) * (1 + 2) * (2 + 1) * (1/2 + c) * (3/4 + d) ) /: { (x_IsOdd + y_IsEven) <- m1, (x_IsEven + y_IsOdd) <- m2, (x_IsRational + y_IsAtom)_(Denominator(x) = 2) <- m3, }; %/mathpiper %output,preserve="false" Result: (a+b)*m1*m2*m3*(3/4+d) . %/output %mathpiper Hold( (b + c) * (d + 1) * (4 + d) ) /: { (x_IsBound + y_IsBound) <- m2, }; %/mathpiper %output,preserve="false" Result: m2*m2*m2 . %/output %mathpiper,output="trace" //(b + c) * (d + e) /: {(x_IsAtom + y_IsAtom) <- m1}; functions := "MacroLocal,ApplyPure,Apply,MapSingle,+,ForEach,*,++,>=,<=,<,:=,IsUniVar,IsNumber,IsNegativeNumber,For,IsInfinity,IsMatrix,IsNonObject,SubtractN,-,MathSign,IsGeneric,Or,IsString,AbsN,UnFence,LocalSymbols,GreaterThan,Retract,=,UnList,Hold,Equals,IsFunction,Listify,Head,Nth,MathNth,Type,Prog,And,NotEquals,Local,Tail,DefLoadFunction,Not,IsInteger,Set,String,Length,If,List,MakeVector,IsList,LessThan,While,DestructiveReverse,MacroSet,Eval,DestructiveInsert,AddN,IsAtom,Atom,ConcatStrings"; TraceExcept(functions,(b + c) * (d + 1) * (4 + d) /: { (x_IsBound + y_IsBound) <- m2, } ); %/mathpiper %mathpiper_trace,preserve="false" Result: m2*m2*m2 Side Effects: Enter<**** user rulebase>{(/:, (b+c)*(d+1)*(4+d)/:{x_IsBound+y_IsBound<-m2}); Enter<**** user rulebase>{(<-, x_IsBound+y_IsBound<-m2); Arg(left -> x_IsBound+y_IsBound); Arg(right -> m2); Leave<**** user rulebase>}(x_IsBound+y_IsBound<-m2 -> x_IsBound+y_IsBound<-m2, Local variables: right -> m2, left -> (+ (_ x IsBound )(_ y IsBound ))m2, ); Arg(arg1 -> (b+c)*(d+1)*(d+4)); Arg(arg2 -> {x_IsBound+y_IsBound<-m2}); **** Rule in function (/:) matched: Precedence: 10, Parameters: arg1, arg2, Predicates: (Pattern) True, Variables: expression, patterns, Types: Variable, Variable, Body: [ Set(patterns, LocProcess(patterns)); MacroSubstitute(expression, "LocPredicate", "LocChange");] Enter<**** user rulebase>{(LocProcess, LocProcess(patterns)); Arg(patterns -> {x_IsBound+y_IsBound<-m2}); **** Rule in function (LocProcess) matched: Precedence: 1025, Parameters: patterns, Predicates: None., Body: [ MapSingle("LocProcessSingle", patterns);] Enter<**** user rulebase>{(LocProcessSingle, LocProcessSingle(x_IsBound+y_IsBound<-m2)); Enter<**** user rulebase>{(<-, x_IsBound+y_IsBound<-m2); Arg(left -> x_IsBound+y_IsBound); Arg(right -> m2); Leave<**** user rulebase>}(x_IsBound+y_IsBound<-m2 -> x_IsBound+y_IsBound<-m2, Local variables: right -> m2, left -> (+ (_ x IsBound )(_ y IsBound ))m2, ); Arg(arg1 -> x_IsBound+y_IsBound<-m2); **** Rule in function (LocProcessSingle) matched: Precedence: 40, Parameters: arg1, Predicates: (Pattern) IsFunction(pat), True, Variables: pat, exp, Types: Sublist, Body: [ Local(justPattern, postPredicate); If(Type(pat)="_", [ justPattern:=pat[1]; postPredicate:=pat[2];], [ justPattern:=pat; postPredicate:=True;]); {{justPattern[0], PatternCreate(justPattern, postPredicate)}, exp};] Enter{(PatternCreate, PatternCreate(justPattern,postPredicate)); Arg(parameter1 -> x_IsBound+y_IsBound); Arg(parameter2 -> True); Leave}(PatternCreate(justPattern,postPredicate) -> Pattern, Local variables: postPredicate -> True, justPattern -> (+ (_ x IsBound )(_ y IsBound )), exp -> m2, pat -> (+ (_ x IsBound )(_ y IsBound ))m2, arg1 -> (<- (+ (_ x IsBound )(_ y IsBound ))m2 ), ); Leave<**** user rulebase>}(LocProcessSingle(x_IsBound+y_IsBound<-m2) -> {{+,Pattern},m2}, Local variables: exp -> m2, pat -> (+ (_ x IsBound )(_ y IsBound ))m2, arg1 -> (<- (+ (_ x IsBound )(_ y IsBound ))m2 ), ); Leave<**** user rulebase>}(LocProcess(patterns) -> {{{+,Pattern},m2}}, Local variables: patterns -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), ); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(expression,LocPredicate,LocChange)); Arg(body -> (b+c)*(d+1)*(d+4)); Arg(predicate -> LocPredicate); Arg(change -> LocChange); **** Rule in function (MacroSubstitute) matched: Precedence: 1025, Parameters: body, predicate, change, Predicates: None., Body: [ `MacroSubstitute(Hold(@body));] Enter{(`, `MacroSubstitute(Hold(@body))); Arg(parameter1 -> MacroSubstitute(Hold(@body))); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(Hold((b+c)*(d+1)*(d+4)))); Arg(body -> (b+c)*(d+1)*(d+4)); Enter{(`, `ApplyPure(predicate,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(predicate,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocPredicate, LocPredicate(Hold((b+c)*(d+1)*(d+4)))); Arg(arg1 -> (b+c)*(d+1)*(d+4)); **** Rule in function (LocPredicate) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsFunction(exp), True, Variables: exp, Types: Variable, Body: [ Local(tr, result, head); tr:=patterns; result:=False; While(tr!={})[ Set(head, Head(Head(tr))); If(NotIsAtom(head)Andexp[0]=head[1]AndPatternMatches(head[2], exp), [ Set($LocResult12, Eval(Head(Tail(Head(tr))))); Set(result, True); Set(tr, {});], [ Set(tr, Tail(tr));]);]; result;] Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {{{+,Pattern},m2}}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> True, Local variables: aRight -> (List ), aLeft -> (List (List (List + [BuiltinObject])m2 )), ); Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> False, Local variables: aRight -> (List ), aLeft -> (List ), ); Leave<**** user rulebase>}(LocPredicate(Hold((b+c)*(d+1)*(d+4))) -> False, Local variables: exp -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(predicate,{Hold(Hold(@body))}) -> False, Local variables: body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(`, `IsFunction(Hold(@body))); Arg(parameter1 -> IsFunction(Hold(@body))); Leave}(`IsFunction(Hold(@body)) -> True, Local variables: body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); **** Rule in function (MacroSubstitute) matched: Precedence: 2, Parameters: body, Predicates: `IsFunction(Hold(@body)), Body: [ `ApplyPure("MacroMapArgs", {Hold(Hold(@body)), "MacroSubstitute"});] Enter{(`, `ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute})); Arg(parameter1 -> ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute})); Enter{(MacroMapArgs, MacroMapArgs(Hold((b+c)*(d+1)*(d+4)),MacroSubstitute)); Arg(expr -> Hold((b+c)*(d+1)*(d+4))); Arg(oper -> MacroSubstitute); **** Rule in function (MacroMapArgs) matched: Precedence: 1025, Parameters: expr, oper, Predicates: None., Body: [ Local(ex, tl, op); Set(op, @oper); Set(ex, Listify(@expr)); Set(tl, Tail(ex)); UnList(Concat({ex[1]}, `MacroMapSingle(@op, Hold(@tl))));], Substituted Macro Body: [ Local(ex,tl,op); Set(op,"MacroSubstitute"); Set(ex,Listify(Hold((b+c)*(d+1)*(d+4)))); Set(tl,Tail(ex)); UnList(Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl))));] Enter{(Concat, Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl)))); Enter{(`, `MacroMapSingle(@op,Hold(@tl))); Arg(parameter1 -> MacroMapSingle(@op,Hold(@tl))); Enter<**** user rulebase>{(MacroMapSingle, MacroMapSingle(MacroSubstitute,Hold({(b+c)*(d+1),d+4}))); Arg($func15 -> MacroSubstitute); Arg($list15 -> {(b+c)*(d+1),d+4}); **** Rule in function (MacroMapSingle) matched: Precedence: 1025, Parameters: $func15, $list15, Predicates: None., Body: [ Local(mapsingleresult); mapsingleresult:={}; ForEach(mapsingleitem, $list15)[ DestructiveInsert(mapsingleresult, 1, `ApplyPure($func15, {Hold(Hold(@mapsingleitem))}));]; DestructiveReverse(mapsingleresult);] Enter{(`, `ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Arg(parameter1 -> ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(Hold((b+c)*(d+1)))); Arg(body -> (b+c)*(d+1)); Enter{(`, `ApplyPure(predicate,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(predicate,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocPredicate, LocPredicate(Hold((b+c)*(d+1)))); Arg(arg1 -> (b+c)*(d+1)); **** Rule in function (LocPredicate) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsFunction(exp), True, Variables: exp, Types: Variable, Body: [ Local(tr, result, head); tr:=patterns; result:=False; While(tr!={})[ Set(head, Head(Head(tr))); If(NotIsAtom(head)Andexp[0]=head[1]AndPatternMatches(head[2], exp), [ Set($LocResult12, Eval(Head(Tail(Head(tr))))); Set(result, True); Set(tr, {});], [ Set(tr, Tail(tr));]);]; result;] Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {{{+,Pattern},m2}}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> True, Local variables: aRight -> (List ), aLeft -> (List (List (List + [BuiltinObject])m2 )), ); Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> False, Local variables: aRight -> (List ), aLeft -> (List ), ); Leave<**** user rulebase>}(LocPredicate(Hold((b+c)*(d+1))) -> False, Local variables: exp -> (* (+ b c )(+ d 1 )), arg1 -> (* (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(predicate,{Hold(Hold(@body))}) -> False, Local variables: body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(`, `IsFunction(Hold(@body))); Arg(parameter1 -> IsFunction(Hold(@body))); Leave}(`IsFunction(Hold(@body)) -> True, Local variables: body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); **** Rule in function (MacroSubstitute) matched: Precedence: 2, Parameters: body, Predicates: `IsFunction(Hold(@body)), Body: [ `ApplyPure("MacroMapArgs", {Hold(Hold(@body)), "MacroSubstitute"});] Enter{(`, `ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute})); Arg(parameter1 -> ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute})); Enter{(MacroMapArgs, MacroMapArgs(Hold((b+c)*(d+1)),MacroSubstitute)); Arg(expr -> Hold((b+c)*(d+1))); Arg(oper -> MacroSubstitute); **** Rule in function (MacroMapArgs) matched: Precedence: 1025, Parameters: expr, oper, Predicates: None., Body: [ Local(ex, tl, op); Set(op, @oper); Set(ex, Listify(@expr)); Set(tl, Tail(ex)); UnList(Concat({ex[1]}, `MacroMapSingle(@op, Hold(@tl))));], Substituted Macro Body: [ Local(ex,tl,op); Set(op,"MacroSubstitute"); Set(ex,Listify(Hold((b+c)*(d+1)))); Set(tl,Tail(ex)); UnList(Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl))));] Enter{(Concat, Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl)))); Enter{(`, `MacroMapSingle(@op,Hold(@tl))); Arg(parameter1 -> MacroMapSingle(@op,Hold(@tl))); Enter<**** user rulebase>{(MacroMapSingle, MacroMapSingle(MacroSubstitute,Hold({b+c,d+1}))); Arg($func15 -> MacroSubstitute); Arg($list15 -> {b+c,d+1}); **** Rule in function (MacroMapSingle) matched: Precedence: 1025, Parameters: $func15, $list15, Predicates: None., Body: [ Local(mapsingleresult); mapsingleresult:={}; ForEach(mapsingleitem, $list15)[ DestructiveInsert(mapsingleresult, 1, `ApplyPure($func15, {Hold(Hold(@mapsingleitem))}));]; DestructiveReverse(mapsingleresult);] Enter{(`, `ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Arg(parameter1 -> ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(Hold(b+c))); Arg(body -> b+c); Enter{(`, `ApplyPure(predicate,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(predicate,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocPredicate, LocPredicate(Hold(b+c))); Arg(arg1 -> b+c); **** Rule in function (LocPredicate) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsFunction(exp), True, Variables: exp, Types: Variable, Body: [ Local(tr, result, head); tr:=patterns; result:=False; While(tr!={})[ Set(head, Head(Head(tr))); If(NotIsAtom(head)Andexp[0]=head[1]AndPatternMatches(head[2], exp), [ Set($LocResult12, Eval(Head(Tail(Head(tr))))); Set(result, True); Set(tr, {});], [ Set(tr, Tail(tr));]);]; result;] Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {{{+,Pattern},m2}}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> True, Local variables: aRight -> (List ), aLeft -> (List (List (List + [BuiltinObject])m2 )), ); Enter{(PatternMatches, PatternMatches(head[2],exp)); Arg(parameter1 -> Pattern); Arg(parameter2 -> b+c); Enter{(IsBound, IsBound(x)); Arg(parameter1 -> x); Leave}(IsBound(x) -> True, Local variables: y -> c, x -> b c, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ b c ), arg1 -> (+ b c ), body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(IsBound, IsBound(y)); Arg(parameter1 -> y); Leave}(IsBound(y) -> True, Local variables: y -> c, x -> b c, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ b c ), arg1 -> (+ b c ), body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(PatternMatches(head[2],exp) -> True, Local variables: y -> c, x -> b c, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ b c ), arg1 -> (+ b c ), body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> False, Local variables: aRight -> (List ), aLeft -> (List ), ); Leave<**** user rulebase>}(LocPredicate(Hold(b+c)) -> True, Local variables: exp -> (+ b c ), arg1 -> (+ b c ), body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(predicate,{Hold(Hold(@body))}) -> True, Local variables: body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); **** Rule in function (MacroSubstitute) matched: Precedence: 1, Parameters: body, Predicates: `ApplyPure(predicate,{Hold(Hold(@body))})=True, Body: [ `ApplyPure(change, {Hold(Hold(@body))});] Enter{(`, `ApplyPure(change,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(change,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocChange, LocChange(Hold(b+c))); Arg(arg1 -> b+c); **** Rule in function (LocChange) matched: Precedence: 0, Parameters: arg1, Predicates: (Pattern) True, Variables: exp, Types: Variable, Body: $LocResult12 Leave<**** user rulebase>}(LocChange(Hold(b+c)) -> m2, Local variables: exp -> (+ b c ), arg1 -> (+ b c ), body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(change,{Hold(Hold(@body))}) -> m2, Local variables: body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(Hold(b+c)) -> m2, Local variables: body -> (+ b c ), mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure($func15,{Hold(Hold(@mapsingleitem))}) -> m2, Local variables: mapsingleitem -> (+ b c ), foreachtail -> (List (+ b c )(+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(`, `ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Arg(parameter1 -> ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(Hold(d+1))); Arg(body -> d+1); Enter{(`, `ApplyPure(predicate,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(predicate,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocPredicate, LocPredicate(Hold(d+1))); Arg(arg1 -> d+1); **** Rule in function (LocPredicate) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsFunction(exp), True, Variables: exp, Types: Variable, Body: [ Local(tr, result, head); tr:=patterns; result:=False; While(tr!={})[ Set(head, Head(Head(tr))); If(NotIsAtom(head)Andexp[0]=head[1]AndPatternMatches(head[2], exp), [ Set($LocResult12, Eval(Head(Tail(Head(tr))))); Set(result, True); Set(tr, {});], [ Set(tr, Tail(tr));]);]; result;] Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {{{+,Pattern},m2}}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> True, Local variables: aRight -> (List ), aLeft -> (List (List (List + [BuiltinObject])m2 )), ); Enter{(PatternMatches, PatternMatches(head[2],exp)); Arg(parameter1 -> Pattern); Arg(parameter2 -> d+1); Enter{(IsBound, IsBound(x)); Arg(parameter1 -> x); Leave}(IsBound(x) -> True, Local variables: y -> 1, x -> d 1, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 1 ), arg1 -> (+ d 1 ), body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(IsBound, IsBound(y)); Arg(parameter1 -> y); Leave}(IsBound(y) -> True, Local variables: y -> 1, x -> d 1, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 1 ), arg1 -> (+ d 1 ), body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(PatternMatches(head[2],exp) -> True, Local variables: y -> 1, x -> d 1, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 1 ), arg1 -> (+ d 1 ), body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> False, Local variables: aRight -> (List ), aLeft -> (List ), ); Leave<**** user rulebase>}(LocPredicate(Hold(d+1)) -> True, Local variables: exp -> (+ d 1 ), arg1 -> (+ d 1 ), body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(predicate,{Hold(Hold(@body))}) -> True, Local variables: body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); **** Rule in function (MacroSubstitute) matched: Precedence: 1, Parameters: body, Predicates: `ApplyPure(predicate,{Hold(Hold(@body))})=True, Body: [ `ApplyPure(change, {Hold(Hold(@body))});] Enter{(`, `ApplyPure(change,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(change,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocChange, LocChange(Hold(d+1))); Arg(arg1 -> d+1); **** Rule in function (LocChange) matched: Precedence: 0, Parameters: arg1, Predicates: (Pattern) True, Variables: exp, Types: Variable, Body: $LocResult12 Leave<**** user rulebase>}(LocChange(Hold(d+1)) -> m2, Local variables: exp -> (+ d 1 ), arg1 -> (+ d 1 ), body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(change,{Hold(Hold(@body))}) -> m2, Local variables: body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(Hold(d+1)) -> m2, Local variables: body -> (+ d 1 ), mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure($func15,{Hold(Hold(@mapsingleitem))}) -> m2, Local variables: mapsingleitem -> (+ d 1 ), foreachtail -> (List (+ d 1 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (+ b c )(+ d 1 )), $item22 -> mapsingleitem, mapsingleresult -> (List m2 ), $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroMapSingle(MacroSubstitute,Hold({b+c,d+1})) -> {m2,m2}, Local variables: $list15 -> (List (+ b c )(+ d 1 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`MacroMapSingle(@op,Hold(@tl)) -> {m2,m2}, Local variables: op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Arg(parameter1 -> {ex[1]}); Arg(parameter2 -> `MacroMapSingle(@op,Hold(@tl))); Leave}(Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl))) -> {*,m2,m2}, Local variables: op -> "MacroSubstitute", tl -> (List (+ b c )(+ d 1 )), ex -> (List * (+ b c )(+ d 1 )), body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(MacroMapArgs(Hold((b+c)*(d+1)),MacroSubstitute) -> m2*m2, Local variables: body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute}) -> m2*m2, Local variables: body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(Hold((b+c)*(d+1))) -> m2*m2, Local variables: body -> (* (+ b c )(+ d 1 )), mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure($func15,{Hold(Hold(@mapsingleitem))}) -> m2*m2, Local variables: mapsingleitem -> (* (+ b c )(+ d 1 )), foreachtail -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List ), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(`, `ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Arg(parameter1 -> ApplyPure($func15,{Hold(Hold(@mapsingleitem))})); Enter<**** user rulebase>{(MacroSubstitute, MacroSubstitute(Hold(d+4))); Arg(body -> d+4); Enter{(`, `ApplyPure(predicate,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(predicate,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocPredicate, LocPredicate(Hold(d+4))); Arg(arg1 -> d+4); **** Rule in function (LocPredicate) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsFunction(exp), True, Variables: exp, Types: Variable, Body: [ Local(tr, result, head); tr:=patterns; result:=False; While(tr!={})[ Set(head, Head(Head(tr))); If(NotIsAtom(head)Andexp[0]=head[1]AndPatternMatches(head[2], exp), [ Set($LocResult12, Eval(Head(Tail(Head(tr))))); Set(result, True); Set(tr, {});], [ Set(tr, Tail(tr));]);]; result;] Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {{{+,Pattern},m2}}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> True, Local variables: aRight -> (List ), aLeft -> (List (List (List + [BuiltinObject])m2 )), ); Enter{(PatternMatches, PatternMatches(head[2],exp)); Arg(parameter1 -> Pattern); Arg(parameter2 -> d+4); Enter{(IsBound, IsBound(x)); Arg(parameter1 -> x); Leave}(IsBound(x) -> True, Local variables: y -> 4, x -> d 4, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 4 ), arg1 -> (+ d 4 ), body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter{(IsBound, IsBound(y)); Arg(parameter1 -> y); Leave}(IsBound(y) -> True, Local variables: y -> 4, x -> d 4, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 4 ), arg1 -> (+ d 4 ), body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(PatternMatches(head[2],exp) -> True, Local variables: y -> 4, x -> d 4, head -> (List + [BuiltinObject]), result -> False, tr -> (List (List (List + [BuiltinObject])m2 )), exp -> (+ d 4 ), arg1 -> (+ d 4 ), body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Enter<**** user rulebase>{(!=, tr!={}); Arg(aLeft -> {}); Arg(aRight -> {}); **** Rule in function (!=) matched: Precedence: 1025, Parameters: aLeft, aRight, Predicates: None., Body: NotaLeft=aRight Leave<**** user rulebase>}(tr!={} -> False, Local variables: aRight -> (List ), aLeft -> (List ), ); Leave<**** user rulebase>}(LocPredicate(Hold(d+4)) -> True, Local variables: exp -> (+ d 4 ), arg1 -> (+ d 4 ), body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(predicate,{Hold(Hold(@body))}) -> True, Local variables: body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); **** Rule in function (MacroSubstitute) matched: Precedence: 1, Parameters: body, Predicates: `ApplyPure(predicate,{Hold(Hold(@body))})=True, Body: [ `ApplyPure(change, {Hold(Hold(@body))});] Enter{(`, `ApplyPure(change,{Hold(Hold(@body))})); Arg(parameter1 -> ApplyPure(change,{Hold(Hold(@body))})); Enter<**** user rulebase>{(LocChange, LocChange(Hold(d+4))); Arg(arg1 -> d+4); **** Rule in function (LocChange) matched: Precedence: 0, Parameters: arg1, Predicates: (Pattern) True, Variables: exp, Types: Variable, Body: $LocResult12 Leave<**** user rulebase>}(LocChange(Hold(d+4)) -> m2, Local variables: exp -> (+ d 4 ), arg1 -> (+ d 4 ), body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(change,{Hold(Hold(@body))}) -> m2, Local variables: body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(Hold(d+4)) -> m2, Local variables: body -> (+ d 4 ), mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure($func15,{Hold(Hold(@mapsingleitem))}) -> m2, Local variables: mapsingleitem -> (+ d 4 ), foreachtail -> (List (+ d 4 )), $body22 -> (Prog (DestructiveInsert mapsingleresult 1 (` (ApplyPure $func15 (List (Hold (Hold (@ mapsingleitem )))))))), $list22 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $item22 -> mapsingleitem, mapsingleresult -> (List (* m2 m2 )), $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroMapSingle(MacroSubstitute,Hold({(b+c)*(d+1),d+4})) -> {m2*m2,m2}, Local variables: $list15 -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), $func15 -> "MacroSubstitute", op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`MacroMapSingle(@op,Hold(@tl)) -> {m2*m2,m2}, Local variables: op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Arg(parameter1 -> {ex[1]}); Arg(parameter2 -> `MacroMapSingle(@op,Hold(@tl))); Leave}(Concat({ex[1]},`MacroMapSingle(@op,Hold(@tl))) -> {*,m2*m2,m2}, Local variables: op -> "MacroSubstitute", tl -> (List (* (+ b c )(+ d 1 ))(+ d 4 )), ex -> (List * (* (+ b c )(+ d 1 ))(+ d 4 )), body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(MacroMapArgs(Hold((b+c)*(d+1)*(d+4)),MacroSubstitute) -> m2*m2*m2, Local variables: body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`ApplyPure(MacroMapArgs,{Hold(Hold(@body)),MacroSubstitute}) -> m2*m2*m2, Local variables: body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(Hold((b+c)*(d+1)*(d+4))) -> m2*m2*m2, Local variables: body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave}(`MacroSubstitute(Hold(@body)) -> m2*m2*m2, Local variables: change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}(MacroSubstitute(expression,LocPredicate,LocChange) -> m2*m2*m2, Local variables: change -> "LocChange", predicate -> "LocPredicate", body -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); Leave<**** user rulebase>}((b+c)*(d+1)*(4+d)/:{x_IsBound+y_IsBound<-m2} -> m2*m2*m2, Local variables: patterns -> (List (List (List + [BuiltinObject])m2 )), expression -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), arg2 -> (List (<- (+ (_ x IsBound )(_ y IsBound ))m2 )), arg1 -> (* (* (+ b c )(+ d 1 ))(+ d 4 )), ); . %/mathpiper_trace mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/xTermsTest.mpw0000644000175000017500000000237211316262063024656 0ustar giovannigiovanni%mathpiper Use("proposed.rep/xSolve.mpi"); %/mathpiper %output,preserve="false" Result: True . %/output %mathpiper,scope="private" // a bunch of expressions for testing expressions := {}; Push( expressions, 4 ); Push( expressions, -4 ); Push( expressions, 3*y^2 - Sin(Pi*y) ); Push( expressions, a*x+b*x^2 ); Push( expressions, -a*x+b*x^2 ); Push( expressions, -a*x-b*x^2 ); Push( expressions, +a*x+b*x^2 ); Push( expressions, a*x + b*x^2-c/x+d/x^2 ); Push( expressions, a1/(b1+c1*x^2) ); Push( expressions, x+Sin(x) ); Push( expressions, x-Sin(x) ); Push( expressions, a*x+Sin(x) ); Push( expressions, Sin(x)-x ); Push( expressions, Sqrt(x) ); Push( expressions, Sqrt(1/x) ); Push( expressions, Sqrt(1/(x^2+1)) ); Push( expressions, Sqrt((1-x)/(1+x)) ); Push( expressions, 1/x+1/x^2 ); Push( expressions, a/(x+1)+b/(x-1) ); Push( expressions, (1-x)^(3/2) ); Push( expressions, a*(x-3*x^2) ); Push( expressions, (x+2*x^3)/c ); nn := Length( expressions ); For( i:=1, i<=nn, i++ ) [ f := PopBack( expressions ); Echo("-------------------------------------------------------------------"); Echo(">>> new expression: ",f); //r:=V(xTerms(f)); r:=xTerms2(f); Echo({r}); ]; %/mathpiper mathpiper-0.81f+svn4469+dfsg3/tests/manual_tests/jas.mpw0000644000175000017500000000146711370214425023314 0ustar giovannigiovanni%mathpiper,title="" /* I renamed your program JasAccess so that it can be used as the primary class which MathPiper will use to access JAS (for now, at least.). */ jas := JavaNew("org.mathpiper.builtin.library.jas.JasAccess"); //Note: debug output is sent to the Activity Log. JavaCall(jas,"setDebug",True); resultSet := JavaCall(jas,"factorPolyInt","x**2-9", "x"); iterator := JavaCall(resultSet,"iterator"); While(JavaValue(JavaCall(iterator,"hasNext")) = True) [ entrySet := JavaCall(iterator,"next"); factor := JavaValue(JavaCall(entrySet,"getKey")); multiplicity := JavaValue(JavaCall(entrySet,"getValue")); Echo(factor, multiplicity); ]; %/mathpiper %output,preserve="false" Result: True Side Effects: x - 3 1 x + 3 1 . %/output mathpiper-0.81f+svn4469+dfsg3/tests/mathpiper_tests.log0000644000175000017500000002342211515231223023220 0ustar giovannigiovanniTurning stack tracing on: Result: True Side Effects: Stack tracing is on. ***** Mon Jan 10 09:55:07 PST 2011 ***** ***** MathPiper version: .81c ***** =========================== arithmetic.mpt: Result: True Side Effects: Test suite for Test arithmetic : Test suite for Basic calculations : Test suite for Testing math stuff : --IntegerOperations --PowerN --Rounding --Bases --Factorization =========================== binaryfactors.mpt: Result: True =========================== calculus.mpt: Result: True Side Effects: --UnaryFunctionInverses --Derivatives --Limits Known failure: Limit(k,Infinity)((k-phi)/k)^(k+1/2)=Exp(-phi) --Pslq =========================== canprove.mpt: Result: True Side Effects: Test suite for Propositional logic theorem prover : =========================== comments.mpt: Result: True Side Effects: Test suite for Checking comment syntax supported : =========================== complex.mpt: Result: True Side Effects: Known failure: (Limit(n,Infinity)(n^2*I^n)/(n^3+1))=0 =========================== c_tex_form.mpt: Result: True Side Effects: Test suite for TeXForm()... : --IsCFormable =========================== cyclotomic.mpt: Result: True Side Effects: Test suite for Cyclotomic Polynomials : =========================== deriv.mpt: Result: True =========================== dimensions.mpt: Result: True Side Effects: ---- Dimensions (Tensor Rank) =========================== dot.mpt: Result: True Side Effects: ---- Dot =========================== GaussianIntegers.mpt: Result: True Side Effects: Test suite for Gaussian Integers : =========================== includetestfiles: is not a MathPiper test file. =========================== integrate.mpt: Result: True =========================== issues.mpt: Result: True Side Effects: Test suite for Problems reported as Issues : =========================== io.mpt: Result: True Side Effects: --Error reporting =========================== journal.mpt: Result: True =========================== linalg.mpt: Result: True Side Effects: --LeviCivita --VectorProducts Test suite for Inproduct : Test suite for Identity matrices : Test suite for Check linear algebra : --Normalize --DiagonalMatrix --ZeroMatrix --Transpose --Determinant --CoFactor --Minor --Inverse --SolveMatrix --Trace =========================== lists.mpt: Result: True Side Effects: Test suite for VarList : --BubbleSort --HeapSort --ListOperations --Length --Nth --Concat --Binary searching --AssocDelete ---- Arithmetic Operations =========================== logic_simplify_test.mpt: Result: True Side Effects: Test suite for CNF : =========================== macro.mpt: Result: True =========================== mathpiper_tests.log: is not a MathPiper test file. =========================== matrixpower.mpt: Result: True Side Effects: ---- MatrixPower =========================== multivar.mpt: Result: True Side Effects: Test suite for Test arithmetic : =========================== nthroot.mpt: Result: True Side Effects: ---- NthRoot =========================== numbers.mpt: Result: True Side Effects: --Integer logarithms and roots --Factorial --Random numbers =========================== numerics.mpt: Result: True Side Effects: ****************** tests/scripts4/numerics.mpt: 193 newrepL[1]-newrepR[1] evaluates to -53768446116670492691 which differs from 0 ****************** ****************** tests/scripts4/numerics.mpt: 195 newrepL[1]-newrepR[1] evaluates to -6282627216144394152 which differs from 0 ****************** ****************** tests/scripts4/numerics.mpt: 282 newrepL[1]-newrepR[1] evaluates to -3357578071772547517286808 which differs from 0 ****************** ****************** tests/scripts4/numerics.mpt: 287 newrepL[1]-newrepR[1] evaluates to 406993831 which differs from 0 ****************** --Gamma constant ****************** tests/scripts4/numerics.mpt: 318 newrepL[1]-newrepR[1] evaluates to 2 which differs from 0 ****************** =========================== nummethods.mpt: Result: True =========================== ode.mpt: Result: True Side Effects: **** THE ODE TEST HAS BEEN TEMPORARILY REMOVED BECAUSE IT CAUSED AN INFINITE RECURSION **** =========================== openmath.mpt: Result: True Side Effects: Test suite for Converting to and from OpenMath expressions : =========================== orthopoly.mpt: Result: True Side Effects: Test suite for Testing orthogonal polynomials : =========================== outer.mpt: Result: True Side Effects: ---- Outer =========================== piper_test.bat: is not a MathPiper test file. =========================== plots.mpt: Result: True Side Effects: ****************** tests/scripts4/plots.mpt: 6 PipeToString()Write(Plot2D(a,-1:1,output->data,points->4,depth->0)) evaluates to "{{{-1,-1},{-0.5,-0.5},{0.0,0.0},{0.5,0.5},{1,1}}}" which differs from "{{{-1,-1},{-0.5,-0.5},{0,0},{0.5,0.5},{1.,1.}}}" ****************** ****************** tests/scripts4/plots.mpt: 7 PipeToString()Write(Plot2D(b,b->-1:1,output->data,points->4)) evaluates to "{{{-1,-1},{-0.5,-0.5},{0.0,0.0},{0.5,0.5},{1,1}}}" which differs from "{{{-1,-1},{-0.5,-0.5},{0,0},{0.5,0.5},{1.,1.}}}" ****************** ****************** tests/scripts4/plots.mpt: 14 PipeToString()Write(Plot3DS(a,-1:1,-1:1,output->data,points->2)) evaluates to "{{{-1,-1,-1},{-1,0,-1},{-1,1,-1},{0,-1,0},{0,0,0},{0,1,0},{1,-1,1},{1,0,1},{1,1,1}}}" which differs from "{{{-1,-1,-1},{-1,0,-1},{-1,1.,-1},{0,-1,0},{0,0,0},{0,1.,0},{1.,-1,1.},{1.,0,1.},{1.,1.,1.}}}" ****************** ****************** tests/scripts4/plots.mpt: 14 PipeToString()Write(Plot3DS(x1,x1->-1:1,x2->-1:1,output->data,points->2)) evaluates to "{{{-1,-1,0.1011417762},{-1,0,0.1011417762},{-1,1,0.1011417762},{0,-1,0.1011417762},{0,0,0.1011417762},{0,1,0.1011417762},{1,-1,0.1011417762},{1,0,0.1011417762},{1,1,0.1011417762}}}" which differs from "{{{-1,-1,-1},{-1,0,-1},{-1,1.,-1},{0,-1,0},{0,0,0},{0,1.,0},{1.,-1,1.},{1.,0,1.},{1.,1.,1.}}}" ****************** =========================== poly.mpt: Result: True Side Effects: Test suite for Polynomials : =========================== predicates.mpt: Result: True Side Effects: --Predicates --Boolean Operations --NumberCompares --comparisons in exponential notation --Matrix predicates ****************** tests/scripts4/predicates.mpt: 123 HasFuncArith(a*b+f({b,c}),List) evaluates to True which differs from False ****************** --IsConstant ---- IsScalar ---- IsVector ---- IsVector(IsNumber) ---- Matrix Predicates ------ IsMatrix ------ IsMatrix(IsInteger) ------ IsSquareMatrix =========================== programming.mpt: Result: True Side Effects: --Apply --ThreadingListables --MapSingle --Function definitions --LocalVariables =========================== radsimp.mpt: Result: True Side Effects: Test suite for Testing simplifying nested radicals : =========================== regress.mpt: Result: True Side Effects: Test suite for Regression on bug reports : ****************** tests/scripts4/regress.mpt: 328 (Integrate(x,a,b)Cos(x)^2)-((b-Sin((-2)*b)/2)/2-(a-Sin((-2)*a)/2)/2) evaluates to (Sin(2*b)/2+b)/2-(Sin(2*a)/2+a)/2-((b-(-Sin(2*b))/2)/2-(a-(-Sin(2*a))/2)/2) which differs from 0 ****************** Known failure: (Limit(x,Infinity)x^n/Ln(x))=Infinity Known failure: (Limit(x,0,Right)x^(Ln(a)/(1+Ln(x))))=a Known failure: Gcd(10,3.3)!=3.3 And Gcd(10,3.3)!=1 Known failure: (Differentiate(z)Conjugate(z))=Undefined Known failure: ArcCos(Cos(beta))!=beta Known failure: (Limit(n,Infinity)n^5/2^n)=0 Known failure: RoundTo(RoundTo(N(Cot(2),9),9),N(Cot(2),9),9)=0 =========================== scopestack.mpt: Result: True =========================== simplify.mpt: Result: True Side Effects: Test suite for Simplify : =========================== solve.mpt: Result: True Side Effects: --Solve --PSolve -- Linear -- Quadratic -- Cubic -- Quartic =========================== sturm.mpt: Result: True =========================== sums.mpt: Result: True Side Effects: --Taylor ****************** tests/scripts4/sums.mpt: 339 $pp2187 evaluates to Taylor'LPS(1,{-2,0,1/3,0},t,Taylor'LPS'ScalarMult(-1,Taylor'LPS(1,{2,0,(-1)/3,0},t,Taylor'LPS'ScalarMult(2,Taylor'LPS(1,{1,0,(-1)/6,0},t,Sin(t)))))) which differs from Taylor'LPS(1,{-2,0,1/3,0},t,Taylor'LPS'ScalarMult(-2,Taylor'LPS(1,{1,0,(-1)/6,0},t,Sin(t)))) ****************** =========================== tensors.mpt: Result: True Side Effects: Test suite for Tensors : =========================== test-yacas-c-version: is not a MathPiper test file. =========================== trace.mpt: Result: True Side Effects: ---- Trace =========================== transforms.mpt: Result: True =========================== : is not a MathPiper test file. ***** Tests complete ***** Exception Count: 0 GlobalVariables: Result: True Side Effects: {$a73,$a994,$assumptions78,$b73,$b994,$bernoulli1Threshold56,$CacheOfConstantsN1,$CFormAllFunctions63,$cformMathFunctions61,$cformRegularOps60,$cindent62,$ClearScreenString40,$complexReduce54,$Debug'FileLines40,$Debug'FileLoaded40,$Debug'NrLines40,$ErrorTableau59,$formulaMaxWidth68,$GlobalStack19,$intpred72,$knownOrthoPoly71,$knownRNGDists50,$knownRNGEngines50,$lastcoef48,$LocResult74,$mathExpThreshold52,$mNum33,$n'max58,$nNum33,$NthRoot'Table162,$numericMode2,$omindent65,$omsymbol67,$omsymbolreverse67,$omtoken66,$options989,$p02187,$p12187,$p22187,$p32187,$p42,$p42187,$p993,$pc242187,$pc352187,$pc462187,$pc572187,$pc682187,$pj2187,$pj402187,$pj502187,$pj512187,$pj522187,$pj532187,$pj542187,$pju02187,$pp2187,$RandSeed51,$res36,$res79,$rFormMathFunctions45,$rFormRegularOps44,$RIndent46,$simple994,$st1011,$TeXFormGreekLetters69,$TeXFormMathFunctions270,$TeXFormMathFunctions70,$TeXFormRegularOps69,$TeXFormRegularPrefixOps69,$TeXFormSpecialNames69,$Verbose41,%,I,LoadResult} mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/0000755000175000017500000000000011722677316021073 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/tests/scripts4/linalg.mpt0000644000175000017500000001040711602432433023047 0ustar giovannigiovanni Testing("LeviCivita"); Verify(LeviCivita({1,2,3}),1); Verify(LeviCivita({2,1,3}),-1); Verify(LeviCivita({1,1,3}),0); Testing("VectorProducts"); [ Local(l,m,n); l:={1,0,0}; m:={0,1,0}; n:={0,0,1}; Verify(l X m, {0,0,1}); Verify(m X n, {1,0,0}); Verify(n X l, {0,1,0}); Verify(l X n, {0,-1,0}); Verify(Dot(l, m), 0); Verify(Dot(m, n), 0); Verify(Dot(n, l), 0); Verify(Dot(l, l), 1); ]; [ Local(a,b); /* Strangeness: change variable below into a, and the crossproducts * later on fail! */ a:={1,2,3}; b:={3,1,5}; Verify( Dot(a, b) , 20); Verify(CrossProduct({1,2,3} , {4,2,5}) , {4,7,-6}); ]; Verify(aa,Hold(aa)); [ Local(a,b); NextTest("Inproduct"); a:={1,2,3}; b:={3,1,5}; Verify( Dot(a, b) , 20); ]; Verify(CrossProduct({1,2,3} , {4,2,5}) , {4,7,-6}); Verify({1,2,3} X {4,2,5},{4,7,-6}); Unbind(a,b); NextTest("Identity matrices"); Verify(Identity(4), { {1, 0, 0, 0} , {0, 1, 0, 0} , {0, 0, 1, 0} , {0, 0, 0, 1} }); NextTest("Check linear algebra"); /* Normalize */ Testing("Normalize"); Verify(Normalize({3,4}),{3/5,4/5}); /* DiagonalMatrix */ Testing("DiagonalMatrix"); Verify(DiagonalMatrix({2,3,4}),{{2,0,0},{0,3,0},{0,0,4}}); /* ZeroMatrix */ Testing("ZeroMatrix"); Verify(ZeroMatrix(2,3),{{0,0,0},{0,0,0}}); /* Transpose */ Testing("Transpose"); Verify(Transpose({{a,b},{c,d}}),{{a,c},{b,d}}); /* Determinant */ Testing("Determinant"); Verify(Determinant({{2,3},{3,1}}),-7); Verify( Determinant(ToeplitzMatrix(1 .. 10)), -2816 ); // check that Determinant gives correct symbolic result TestMathPiper(Determinant({{a,b},{c,d}}),a*d-b*c); [ Local(ll); ll:={ {1,2,3}, {2,-1,4}, {3,4,3} }; /* CoFactor */ Testing("CoFactor"); Verify(N(CoFactor(ll,1,2)),6); /* Minor */ Testing("Minor"); Verify(N(Minor(ll,1,2)),-6); /* Inverse */ Testing("Inverse"); Verify(Inverse(ll)*ll,Identity(3)); /* SolveMatrix */ Testing("SolveMatrix"); Verify(ll*SolveMatrix(ll,{1,2,3}),{1,2,3}); /* Trace */ Testing("Trace"); Verify(Trace(ll),1-1+3); /* IsVector */ Verify(IsList(ll),True); Verify(IsList({1,2,3}),True); /* IsMatrix */ Verify(IsMatrix(ll),True); Unbind(ll); ]; [ Local(A); Verify( IsSymmetric(Identity(10)), True ); Verify( IsOrthogonal(2*Identity(10)), False ); A := {{1,2,2},{2,1,-2},{-2,2,-1}}; Verify( IsOrthogonal(A/3), True ); Verify( IsSymmetric(Identity(10)), True ); Verify( IsSymmetric({{1}}),True ); A := {{1,0,0,0,1},{0,2,0,0,0},{0,0,3,0,0},{0,0,0,4,0},{1,0,0,0,5}}; Verify( IsSymmetric(A),True ); A := {{0,2,0,0,1},{0,0,3,0,0},{0,0,0,4,0},{1,0,0,0,5}}; Verify( IsSymmetric(A),False); A := {{0,-1},{1,0}}; Verify( IsSkewSymmetric(A), True ); Verify( IsSkewSymmetric(Identity(10)), False ); Verify( IsSkewSymmetric(ZeroMatrix(10,10)), True ); Verify( IsIdempotent(Identity(20)), True ); Verify( IsIdempotent(ZeroMatrix(10,10)), True ); ]; Verify( VandermondeMatrix({1,2,3,4}),{{1,1,1,1},{1,2,3,4},{1,4,9,16},{1,8,27,64}}); Verify( JacobianMatrix( {x^4*y,Cos(y)}, { x, y}), {{4*x^3*y,x^4},{0,-Sin(y)}} ); Verify( WronskianMatrix( {Sin(x),Cos(x)}, x) , {{Sin(x),Cos(x)},{Cos(x),-Sin(x)}} ); Verify( Determinant(HilbertMatrix(5)), 1/266716800000 ); Verify( HilbertMatrix(6)*HilbertInverseMatrix(6), Identity(6) ); Verify( FrobeniusNorm({{1,2},{3,4}}), Sqrt(30) ); Verify( Norm({1,2,3}), Sqrt(14) ); Verify( OrthogonalBasis({{1,1,0},{2,0,1},{2,2,1}}) , {{1,1,0},{1,-1,1},{-1/3,1/3,2/3}} ); Verify( OrthogonalBasis({{1,0,1,0},{1,1,1,0},{0,1,0,1}}), {{1,0,1,0},{0,1,0,0},{0,0,0,1}} ); Verify( OrthonormalBasis({{1,0,1,0},{1,1,1,0},{0,1,0,1}}), {{Sqrt(1/2),0,Sqrt(1/2),0},{0,1,0,0},{0,0,0,1}} ); Verify( OrthonormalBasis({{1,1,1},{0,1,1},{0,0,1}}), {{Sqrt(1/3),Sqrt(1/3),Sqrt(1/3)}, {-Sqrt(2/3),Sqrt(1/6),Sqrt(1/6)}, {0,-Sqrt(1/2),Sqrt(1/2)}} ); [ Local(A,b); A:={{1,2,4},{1,3,9},{1,4,16}}; b:={2,4,7}; Verify( MatrixSolve(A,b) , {1,(-1)/2,1/2} ); A:={{2,4,-2,-2},{1,2,4,-3},{-3,-3,8,-2},{-1,1,6,-3}}; b:={-4,5,7,7}; Verify( MatrixSolve(A,b), {1,2,3,4} ); ]; [ Local(A,R); A:={{4,-2,4,2},{-2,10,-2,-7},{4,-2,8,4},{2,-7,4,7}}; R:=Cholesky(A); Verify( R, {{2,-1,2,1},{0,3,0,-2},{0,0,2,1},{0,0,0,1}} ); Verify( A, Transpose(R)*R ); ]; [ Local(A,L,U); A:={{2,1,1},{2,2,-1},{4,-1,6}}; {L,U} := LU(A); Verify( L*U, A ); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/test_index.txt0000644000175000017500000000111111555270472023770 0ustar giovannigiovanniarithmetic.mpt binaryfactors.mpt calculus.mpt calendar.mpt canprove.mpt comments.mpt complex.mpt c_tex_form.mpt cyclotomic.mpt deriv.mpt dimensions.mpt dot.mpt factor.mpt GaussianIntegers.mpt integrate.mpt issues.mpt io.mpt journal.mpt linalg.mpt lists.mpt logic_simplify_test.mpt macro.mpt matrixpower.mpt multivar.mpt nthroot.mpt numbers.mpt numerics.mpt nummethods.mpt ode.mpt openmath.mpt orthopoly.mpt outer.mpt plots.mpt poly.mpt predicates.mpt programming.mpt radsimp.mpt regress.mpt scopestack.mpt simplify.mpt solve.mpt sturm.mpt sums.mpt tensors.mpt trace.mpt transforms.mpt mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/factor.mpt0000644000175000017500000000261411555270472023072 0ustar giovannigiovanniTesting("UnivariatePolynomialFactorization"); Verify(Factors(x^2-4),{{x-2,1},{x+2,1}}); Verify(Factors(x^2+2*x+1),{{x+1,2}}); Verify(Factors(-9*x^2+45*x-36),{{-9,1},{x-4,1},{x-1,1}}); Verify(Factors(9*x^2-1),{{3*x-1,1},{3*x+1,1}}); Verify(Factors(4*x^3+12*x^2-40*x),{{4,1},{x,1},{x-2,1},{x+5,1}}); Verify(Factors(32*x^3+32*x^2-70*x-75),{{2*x-3,1},{4*x+5,2}}); Verify(Factors(3*x^3-12*x^2-2*x+8),{{x-4,1},{3*x^2-2,1}}); Verify(Factors(x^3+3*x^2-25*x-75),{{x-5,1},{x+3,1},{x+5,1}}); Verify(Factors(2*x^3-30*x^2+12*x^4),{{2,1},{x,2},{2*x-3,1},{3*x+5,1}}); Verify(Factors(5*x^7-20*x^6+25*x^5-20*x^4+25*x^3-20*x^2+20*x),{{5,1},{x,1},{x-2,2},{x^2-x+1,1},{x^2+x+1,1}}); Verify(Factors((2/5)*x^2-2*x-(12/5)), {{2/5,1},{x-6,1},{x+1,1}}); Verify(Factors(.4*x^2-2*x-2.4), {{2/5,1},{x-6,1},{x+1,1}}); Verify(Factors(x^3+1), {{x+1,1},{x^2-x+1,1}}); Verify(Factors(x^4-1), {{x-1,1},{x+1,1},{x^2+1,1}}); Verify(Factors(x^5-1), {{x-1,1},{x^4+x^3+x^2+x+1,1}}); Verify(Factors(x^5+1), {{x+1,1},{x^4-x^3+x^2-x+1,1}}); Testing("BivariatePolynomialFactorization"); Verify(Factors(-7*x-14*y),{{-7,1},{2*y+x,1}}); Verify(Factors(x^2-a^2),{{x-a,1},{a+x,1}}); Verify(Factors(a^2+2*a*b+b^2),{{a+b,2}}); Verify(Factors(x^3-y^3),{{x-y,1},{y^2+y*x+x^2,1}}); Verify(Factors(x^3+a^3),{{a+x,1},{a^2-a*x+x^2,1}}); Verify(Factors(x^6-a^6),{{x-a,1},{a+x,1},{a^2-a*x+x^2,1},{a^2+a*x+x^2,1}}); Verify(Factors(3*x^2-x*y-10*y^2),{{3*x+5*y,1},{x-2*y,1}}); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/simplify.mpt0000644000175000017500000000413311552343672023446 0ustar giovannigiovanni /* Test Simplify() */ NextTest("Simplify"); TestMathPiper( Simplify((x+y)*(x-y)-(x+y)^2), -2*y^2-2*x*y ); TestMathPiper( Simplify(1+x+x+3*y-4*(x+y+2)), -2*x-y-7 ); TestMathPiper( Simplify((1+I)^4), -4 ); TestMathPiper( Simplify((x-y)/(x*y)), 1/y-1/x ); //See below, now handled with II KnownFailure(TestMathPiper( Simplify((x+I)^4), x^4+4*x^3*I-6*x^2-4*x*I+1 )); TestMathPiper( Simplify((xx+II)^4), xx^4+4*xx^3*II-6*xx^2-4*xx*II+1 ); TestMathPiper( Simplify(Differentiate(x,4)Exp(-x^2/2)), Exp(-x^2/2)*(x^4-6*x^2+3)); TestMathPiper( Simplify(1),1); TestMathPiper( Simplify(1/x ), 1/x ); TestMathPiper( Simplify( 1/(1/x+1) ),x/(x+1) ); TestMathPiper( Simplify(1/(1/(1/x+1)+1) ),(x+1)/(2*x+1) ); TestMathPiper( Simplify(1/(1/(1/(1/x+1)+1)+1) ),(2*x+1)/(3*x+2) ); TestMathPiper( Simplify(1/(1/(1/(1/(1/x+1)+1)+1)+1) ),(3*x+2)/(5*x+3) ); TestMathPiper( Simplify(1/(1/(1/(1/(1/(1/x+1)+1)+1)+1)+1) ),(5*x+3)/(8*x+5) ); /*Serge: these are not handled yet ;-) TestMathPiper( Simplify((x^2-y^2)/(x+y)), x-y ); */ TestMathPiper(ExpandFrac(x+y/x+1/3),(x^2+y+x/3)/x); // this did not work until the latest fix to ExpandBrackets using MM() Verify( ExpandBrackets(x*(a+b)*y*z) , x*a*y*z+x*b*y*z ); Verify( ExpandBrackets(ExpandFrac((x+1)/(x-1)+1/x)) , Hold(x^2/(x^2-x)+(2*x)/(x^2-x)-1/(x^2-x)) ); // these used to fail. Added by Serge, resolved by Ayal Verify([Local(a);a:=0.1;Simplify(a*b);], 0.1*b); Verify([Local(a);a:=0.1;Simplify(a/b);], 0.1/b); // Testing FactorialSimplify TestMathPiper(FactorialSimplify((n+1)! / n!),n+1); TestMathPiper(FactorialSimplify((n-k+2)! / (n-k)!),(n-k+2)*(n-k+1)); TestMathPiper(FactorialSimplify(2^(n+2)/2^n),4); TestMathPiper(FactorialSimplify((-1)^(n+1)/(-1)^n),-1); TestMathPiper(FactorialSimplify((n+1)! / n! + (n-k+2)! / (n-k)!),n+1 + (n-k+2)*(n-k+1)); TestMathPiper(FactorialSimplify((n+1)! / n! + (-1)^(n+1)/(-1)^n),n); /* And now for the piece de resistance: an example from the book "A=B" */ TestMathPiper(FactorialSimplify( ( (n+1)! / (2*k! *(n+1-k)!) - n! / (k! * (n-k)!) + n! / (2*k! * (n-k)!) - n! / (2*(k-1)! * (n-k+1)!) )*(k! *(n+1-k)!)/(n!) ),0); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/solve.mpt0000644000175000017500000001623111572657612022750 0ustar giovannigiovanni Testing("Solve"); VerifySolve(Solve(a+x*y==z,x),{x==(z-a)/y}); // check that solving systems of equations works, at least at the // level of simple back-substitutions VerifySolve(Solve({a+x*y==z},{x}),{{x==(z-a)/y}}); // check linear systems VerifySolve(Solve({2*x-2*y+z==(-7),3*x+y+2*z==(-2),5*x+3*y-3*z==(-7)}, {x,y,z}), {x==(-2),y==2,z==1}); VerifySolve(Solve({3*x-2*y+z==1,x-y-z==2,6*x-4*y+2*z==3}, {x,y,z}), {}); VerifySolve(Solve({2*x+3*y==6,4*x+6*y==12}, {x,y}), {x==3-(3*y)/2,y==y}); [ Local(eq,res); eq:={a-b==c,b==c}; res:=Solve(eq,{a,b}); Verify(eq Where res,{c==c,c==c}); ]; VerifySolve(Solve(a+x*y == z, x), { x == (z-a)/y }); VerifySolve(Solve(x^2-3*x+2, x), { x == 1, x == 2 }); VerifySolve(Solve(2^n == 32, n), { n == Ln(32)/Ln(2) }); /* Of course, Ln(32)/Ln(2) = 5 */ VerifySolve(Solve(ArcTan(x^4) == Pi/4, x), { x == 1, x == -1, x == I, x == -I }); VerifySolve(Solve(Exp(x)/(1-Exp(x)) == a, x), {x == Ln(a/(a+1))}); VerifySolve(Solve(Exp(x)/(1-Exp(x)) == a, a), {a == Exp(x)/(1-Exp(x))}); //VerifySolve(Solve(x^5 == 1, x), // { x == 1, x == Exp(2/5*I*Pi), x == Exp(4/5*I*Pi), // x == Exp(-2/5*I*Pi), x == Exp(-4/5*I*Pi)}); VerifySolve(Solve(Sqrt(x) == 1, x), { x == 1 }); VerifySolve(Solve(Sqrt(x) == -1, x), { }); VerifySolve(Solve(Sqrt(x) == I, x), { x == -1 }); VerifySolve(Solve(Sqrt(x) == -I, x), { }); VerifySolve(Solve(Sqrt(x) == 0, x), { x == 0 }); /* The following equations have in fact infinitely many solutions */ VerifySolve(Solve(Sin(x), x), { x == 0, x == Pi }); VerifySolve(Solve(Sin(x), x), { x == 0, x == Pi }); VerifySolve(Solve(Cos(a)^2 == 1/2, a), { a == Pi/4, a == 3/4*Pi, a == -3/4*Pi, a == -Pi/4 }); /* The solution could have nicer form, but it is correct, apart from periodicity */ VerifySolve(Solve(Sin(a*Pi)^2-Sin(a*Pi)/2 == 1/2, a), {a==Pi/(2*Pi),a==-Pi/(6*Pi),a==(Pi+Pi/6)/Pi}); Verify(IsError(), False); /* This equation can be solved (the solution is x>0), but the current * code does not do this. The least we can expect is that no spurious * solutions are returned. */ VerifySolve(Solve(0^x == 0, x), {}); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /* This equation could be solved using the Lambert W function */ VerifySolve(Solve(x^x == 1, x), {}); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /* Another equation which cannot be solved at the moment */ VerifySolve(Solve(BesselJ(1,x), x), {}); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /* And another one */ VerifySolve(Solve(Exp(x)+Cos(x) == 3, x), {}); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /* This equation could be solved if we knew that x >= 0 */ VerifySolve(Solve(Sqrt(x) == a, x), { }); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /* Test the type-checking mechanism */ VerifySolve(Solve(2*x == 1, 1), {}); Verify(ClearError("Solve'TypeError"), True); Verify(IsError(), False); /* This command is clearly nonsense, but it used to send Yacas in an * infinite recursion, which should never happen. Note that 'Differentiate(y)x == 0' * is parsed as 'Differentiate(y)(x==0)'. */ VerifySolve(Solve(Differentiate(y)(x == 0), x), { }); Verify(ClearError("Solve'Fails"), True); Verify(IsError(), False); /**********************************************************************/ Testing("PSolve"); /* Linear equations */ Testing(" Linear"); VerifySolve(PSolve(x,x), 0); VerifySolve(PSolve(x+3*Sin(b)-1,x), 1-3*Sin(b)); VerifySolve(PSolve(2*x-a,x), a/2); VerifySolve(PSolve(2*x-a,a), 2*x); /* Quadratic equations */ Testing(" Quadratic"); VerifySolve(PSolve(x^2,x), 0); VerifySolve(PSolve(4*x^2-1,x), {1/2,-1/2}); VerifySolve(PSolve(x^2+1,x), {I,-I}); VerifySolve(PSolve(x^2-3*x+2,x), {1,2}); /* Cubic equations */ Testing(" Cubic"); VerifySolve(PSolve(x^3,x), 0); VerifySolve(PSolve(x^3-1,x), {1, Exp(2/3*Pi*I), Exp(-2/3*Pi*I)}); VerifySolve(PSolve(x^3+1,x), {-1, Exp(1/3*Pi*I), Exp(-1/3*Pi*I)}); VerifySolve(PSolve(x^3-3*x^2+2*x,x), {0,2,1}); /* Quartic equations */ Testing(" Quartic"); VerifySolve(PSolve(x^4,x), 0); VerifySolve(PSolve(16*x^4-1,x), {1/2, -1/2, 1/2*I, -1/2*I}); VerifySolve(PSolve(x^4-x,x), {0, 1, Exp(2/3*Pi*I), Exp(-2/3*Pi*I)}); VerifySolve(PSolve(x^4+x,x), {0, -1, Exp(1/3*Pi*I), Exp(-1/3*Pi*I)}); /* Yacas has difficulties with more complicated equations, like the * biquadratic x^4 - 3*x^2 + 2. */ /* Added the ability to Solve and Where to handle expressions more complex than just variables. One can now Solve for say x[1], or Sin(x) (it only uses a simple comparison for now though). The following test just assures that that will never break. */ Verify(Simplify(x[1]-4*x[2]+x[3] Where (Solve({x[1]-4*x[2]+x[3]==0},{x[2]}))),{0}); /*TODO MatrixSolve */ // moved from xSingle_test_solve.mpw VerifySolve(Solve(3/(x^2+x-2)-1/(x^2-1)-7/(2*(x^2+3*x+2))==0, x), {x==3}); VerifySolve(Solve(3/(x^2+x-2)-1/(x^2-1)==7/(2*(x^2+3*x+2)), x), {x==3}); // moved from xTestSolve.mpw // Tricky one; the solution should depend on a being 0 // FIXME: the equation leaves the error set to Solve'Fails //VerifySolve(Solve(a == 0,x),{}); VerifySolve(Solve(0,x),{x==x}); VerifySolve(Solve(x-5,x),{x==5}); VerifySolve(Solve(x-a,x),{x==a}); VerifySolve(Solve(12*x+5==29,x),{x==2}); VerifySolve(Solve(5*x-15==5*(x-3),x),{x==x}); VerifySolve(Solve(5*x-15==5*(x-4),x),{}); VerifySolve(Solve(x^2-4,x),{x==2,x==(-2)}); //VerifySolve(Solve(x^2-a^2,x),{x==a,x==(-a)}); VerifySolve(Solve(2*x^2+9*x==18,x),{x==(-6),x==3/2}); VerifySolve(Solve(5*x^2==25*x,x),{x==0,x==5}); VerifySolve(Solve(2*x/5-x/3==2,x),{x==30}); VerifySolve(Solve(2/x-3/2==7/(2*x),x),{x==(-1)}); VerifySolve(Solve(2/(x-3)-3/(x+3)==12/(x^2-9),x),{}); VerifySolve(Solve(3/(x^2+x-2)-1/(x^2-1)==7/(2*(x^2+3*x+2)),x),{x==3}); VerifySolve(Solve(1+1/x==6/x^2,x),{x==2,x==(-3)}); VerifySolve(Solve(Sqrt(x)-3,x),{x==9}); VerifySolve(Solve(Sqrt(x-3),x),{x==3}); VerifySolve(Solve(Sqrt(x-3)==2,x),{x==7}); //VerifySolve(Solve(Sqrt(2*x)==Sqrt(x+1),x), {x==1}); //VerifySolve(Solve(Sqrt(x)==x,x),{x==1,x==0}); //VerifySolve(Solve(Sqrt(x+2)-2*x==1,x),{x==1/4}); //VerifySolve(Solve(Sqrt(x+2)+2*x==1,x),{x==(5 - Sqrt(41))/8}); //VerifySolve(Solve(Sqrt(9*x^2+4)-3*x==1,x),{x==1/2}); VerifySolve(Solve(Sqrt(x+1)-Sqrt(x)==-2,x),{}); //VerifySolve(Solve(Sqrt(3*x-5)-Sqrt(2*x+3)==-1,x),{x==3}); VerifySolve(Solve(Exp(x)==4,x),{x==Ln(4)}); VerifySolve(Solve(Exp(x)==Abs(a),x),{x==Ln(Abs(a))}); VerifySolve(Solve(Ln(x)==4,x),{x==Exp(4)}); VerifySolve(Solve(Ln(x)==a,x),{x==Exp(a)}); VerifySolve(Solve((x+6)/2-(3*x+36)/4==4,x),{x==-40}); VerifySolve(Solve((x-3)*(x-4)==x^2-2,x),{x==2}); VerifySolve(Solve(a*x-2*b*c==d,x),{x==(2*b*c+d)/a}); VerifySolve(Solve((36-4*x)/(x^2-9)-(2+3*x)/(3-x)==(3*x-2)/(x+3),x),{x==-2}); //VerifySolve(Solve((x^2-1)^(1/3)==2,x),{x==3,x==(-3)}); VerifySolve(Solve(x^4-53*x^2+196==0,x),{x==(-7),x==(-2),x==2,x==7}); VerifySolve(Solve(x^3-8==0,x),{x==2,x==-1+I*Sqrt(3),x==-1-I*Sqrt(3)}); //VerifySolve(Solve(x^(2/3)+x^(1/3)-2==0,x),{x==1,x==(-8)}); //VerifySolve(Solve(Sqrt(x)-(1/4)*x==1,x),{x==4}); //VerifySolve(Solve((1/4)*x-Sqrt(x)==-1,x),{x==4}); VerifySolve(Solve({x-y==1,3*x+2*y==13},{x,y}),{x==3,y==2}); VerifySolve(Solve({x-y-1==0,2*y+3*x-13==0},{x,y}),{x==3,y==2}); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/issues.mpt0000644000175000017500000001240011602741206023110 0ustar giovannigiovanniNextTest("Problems reported as Issues"); //Issue02 Verify(Rationalize( 1.5 / 0.5 ),3); // OK //Issue03 Verify(N(Sqrt(17.032 * 3.22), 5), 7.4056); // OK Verify(N(Sqrt(17.032 * 3.22), 4), 7.406); // OK Verify(N(Sqrt(17.032 * 3.22), 3), 7.41); // OK //Issue04 Verify(Factor( Sqrt(61/10-Sqrt(36/5)) ), Sqrt(61/10-Sqrt(36/5))); // OK //Issue05 Verify(Factor( a^2 + 2*a*b + b^2 ), (a+b)^2); // OK //Issue06 //Verify(Simplify( Sqrt(6.1 - Sqrt(7.2)) ), Sqrt(610-120*Sqrt(5))/10); // NOT OK //Issue08 Verify(Factor(x^2 + x^3), x^2*(x+1) ); // OK //Issue09 Verify(Solve(x^2==21,x), {x==Sqrt(21),x==-Sqrt(21)} ); // OK //Issue10 Verify(Solve({x + y == 2, y == x}, {x, y}), {x==1,y==1} ); // OK //Issue11 Verify(Solve(x^3==x,x), {x==0,x==1,x==(-1)}); Verify(Solve(x^3==x^2,x), {x==0,x==1} ); Verify(Solve(x^4==x^2,x), {x==0,x==1,x==(-1)}); // OK //Issue12 Verify(Factor( t^2-9 ), (t-3)*(t+3)); // OK //Issue 23 TestMathPiper(Factor(x^8+2*x^6+3*x^4+2*x^2+1),(x^2+x+1)*(x^2+x+1)*(x^2-x+1)*(x^2-x+1)); //Issue 24 TestMathPiper(Factor(x^5+4*x^4-22*x^2+59*x-30),x^5+4*x^4-22*x^2+59*x-30); //Issue 25 Verify(Limit(x,Infinity)((1)/(x)) * (Sin(x)), 0); //Issue 28 Verify(Limit(x,Infinity)(Sin(x))/(x), 0); // Issue 30 KnownFailure(Limit(x,-Infinity)(Sin(1/x)*x^2-x*Cos(1/x))/x^2 = 0); Verify(Limit(x,Infinity)(Sqrt((4 * (x)^(2)) - (2 * x))) - (2 * x), 0); //Issue 37 Verify(Solve((x) * (Ln(x)) == 0, x), {x==1}); // Issue 39 Verify(AntiDeriv(x,(x + 4)/(x + 3)^2), Ln(x+3)-(x+3)^(-1)); //Issue 40 Verify(Factor(x^2-2),x^2-2); //Issue 41 Verify(FactorCancel((1-x)/(x-1)),-1); //Issue 43 Verify(FactorCancel((x^2)/(x)), x); Verify(FactorCancel((x^2+1)/(x+1)),(x^2+1)/(x+1)); Verify(FactorCancel((x+3)/(x^2+2)),(x+3)/(x^2+2)); //Issue 44 //Verify(Solve(pmt == loan * (rate * (1+rate)^n) / ((1+rate)^n -1), rate), ); Verify(Solve(E == R * r * (r^n - 1)/(r - 1), n), {n==Ln(((E-(-R*r)/(r-1))*(r-1))/(R*r))/Ln(r)}); //Issue 50 TestEquivalent(Factor(5*a*x+5*b*x-2*b*y-2*a*y),(5*x-2*y)*(a+b)); //Issue 54 Verify(ExpandBrackets((x-y)*(a+b)),x*a+x*b-y*a-y*b); //Issue 55 TestEquivalent(Factor(s^2 - r^2),(s-r)*(r+s)); //Issue 56 TestEquivalent(Factor(5 * a - 10 * b^2),5*(a-2*b^2)); //Issue 57a Verify(Solve(3*(3*x-4)+2*(3*x-7)==3*(5*x-6)-8, x),{x==x}); //Issue 57b Verify(Solve((2*x - 1)*(4*x + 3) == (8*x - 3)*(x + 4) - 3*(9*x + 1), x),{}); //Issue 58 Verify(Simplify(Ln(3)),Ln(3)); //Issue 59 Verify(Solve((x - 1)*(x - 2)*(x - 3)==0, x),{x==3,x==2,x==1}); //Issue 60 Verify(Solve(-3*x^3+10*x^2-11*x+4==0, x),{x==1,x==4/3}); //Issue 61 Verify(TrigSimpCombine(ExpandBrackets((2*x^2-x+3)-(2*x^2-x+3))),0); //Issue 65 Verify(Limit(x, Infinity) ((x)^(2) * ((3) + (x)))^(1/3)/x, 1); Verify(Limit(x, Infinity) (((x)^(2)) + (1))/(Sqrt(3) * x)/x, Sqrt(1/3)); Verify(Limit(x, Infinity) ((Sqrt(2) * (x)^(2)) + (1))/(3 * x)/x, Sqrt(2/9)); //Issue 67(a) Verify(Factor(Rationalize(x^2+0.5*x+0.5)), Hold(1/2*(2*x^2+x+1))); //Issue 67(b) Verify(Factor(Rationalize(x^2+0.5*x-0.5)), Hold(1/2*(x+1)*(2*x-1))); //Issue 67(c) Verify(Factor(Rationalize(x^2-0.5*x-0.5)), Hold(1/2*(x-1)*(2*x+1))); //Issue 67(d) Verify(Factor(Rationalize(x^2-0.5*x+0.5), Hold(1/2*(2*x^2-x+1)))); //Issue 68 Verify(Factor(Rationalize(x^2-0.7*x-2.6)), Hold(1/10*(x-2)*(10*x+13))); //Issue 80 Verify(Solve((-((10 * c) + (3)))/(2 * ((4 * (c)^(2)) - (9))) == (-1)/(2 * ((2 * c) - (3))), c), {c==0}); //Issue 82 Verify(Solve((x^3-6*x^2+32)/8==x^2-4, x),{x==(-2),x==8+2^(5/2),x==8-2^(5/2)}); // Issue 83 Verify(Solve({a*x + b*y == c, d*x + e*y == f}, {x, y}),{x==f/d-((c-(a*f)/d)*e)/(d*(b-(a*e)/d)),y==(c-(a*f)/d)/(b-(a*e)/d)}); //Issue 84 TestEquivalent(Factor((9 * (a)^(2)) - (3 * a * b)),3*a*(3*a-b)); //Issue 90 Verify(Sum(i, 0, n-1, r^i), (1-r^(n-1+1))/(1-r)); // Issue 93 Verify(Solve({x + y == 2, 2*y+2*x==4}, {x, y}), {x==2-y,y==y}); // Issue 98 Verify(Simplify(3.15 * 3), 9.45); // Issue 99 Verify(0*Infinity, Undefined); Verify(0*(-Infinity), Undefined); Verify(Infinity*0, Undefined); Verify((-Infinity)*0, Undefined); // Issue 106 Verify(ExpandBrackets(-(2*x+2*y)), Hold(-2*x-2*y)); // Issue 107 Verify(ExpandBrackets(1/4 * (x+1)), Hold(x/4+1/4)); // Issue 108 Verify(CForm(2.), "2."); // Issue 109 Verify(Rationalize({2.25,-33.333,8}),{9/4,(-33333)/1000,8}); Verify(Rationalize(Sqrt(6.1 - Sqrt(7.2))),Sqrt(61/10-Sqrt(36/5))); // Issue 113 Verify(Simplify(TrigSimpCombine(FactorCancel((x) + (0.2 * x)))), (6*x)/5); // Issue 115 Verify(Solve(a * b^x == c, x), {x==Ln(c/a)/Ln(b)}); // Issue 116 Verify(a/3+2*a/3,a); Verify(a/3+(2*a)/3,a); Verify(a/2+3*a/2,2*a); Verify(a/2+(3*a)/2,2*a); Verify(1/(2*a)+3/(2*a),2/a); Verify(a/(2*b)+3*a/(2*b),(2*a)/b); // Issue 117 Verify(Differentiate(x, 1) ArcSin(Sin(x)), Cos(x)/Sqrt(1-Sin(x)^2)); // Issue 118 Verify(Factor(a^2 - a*f + f^2), a^2-a*f+f^2); // Issue 119 Verify(Integrate(x) 1/(4 * x^2 + 1), ArcTan(2*x)/2); // Issue 120 Verify(Simplify(x^2*(1/x)^2+1), 2); // Issue 121 Verify(Limit(x, Infinity) ((x)^(2)) + (Sin(x)), Infinity); // Issue 122 Verify(PAdicExpand(x^3, x-1), 3*(x-1)+3*(x-1)^2+(x-1)^3+1); // Issue 123 Verify(Apart((x+4)/(x+3)^2), 1/(x+3)+1/(x+3)^2); // Issue 124 Verify(N(Zeta(-11.5)), 0.02039697872); // Issue 125 [ Local(x,y); x := -0.15; y := x; Verify(N(y,1), -0.2); Verify(x,-0.15); Verify(y,-0.15); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/GaussianIntegers.mpt0000644000175000017500000000304711074042175025061 0ustar giovannigiovanni NextTest("Gaussian Integers"); /* TestGaussianFactors: test if Gaussian Factors Really works! Computes in r the product of the factors, and checks if each one is a Gaussian prime and if r is associated to z (i.e. if r/z is a Gaussian Unit */ TestGaussianFactors(z_IsGaussianInteger) <-- [ Local(r,gfactors,Ok); // Echo("TestGaussianFactors: factoring ",z); gfactors := GaussianFactors(z); // Echo(gfactors); Ok := True; r :=1; ForEach(p,gfactors) [ r := r*p[1]^p[2]; Ok := Ok And IsGaussianPrime(p[1]); ]; // Echo(r); Ok := Ok And IsGaussianUnit(r/z); If(Ok,True,Echo("FAILED: GaussianFactors(", z, ")=", gfactors, " which is wrong.")); ]; TestGaussianFactors((9!)+1); TestGaussianFactors(2+3*I); TestGaussianFactors(-1+2*I); TestGaussianFactors(17); TestGaussianFactors(41); Verify(GaussianFactors(157+28*I), {{Complex(5,2),1},{Complex(-29,6),1}}); Verify(GaussianFactors(1), {}); // is this the correct behavior? why not {{}} or {{1,1}}? Verify(GaussianFactors(-1), {}); // is this the correct behavior? Verify(GaussianFactors(I), {}); // is this the correct behavior? Verify(GaussianFactors(0), {}); // is this the correct behavior? Verify(GaussianFactors(2), {{Complex(1,1),1},{Complex(1,-1),1}}); Verify(GaussianFactors(-2), {{Complex(1,1),1},{Complex(1,-1),1}}); Verify(GaussianFactors(3), {{3,1}}); Verify(GaussianFactors(3*I), {{3,1}}); Verify(GaussianFactors(4), {{Complex(1,1),2},{Complex(1,-1),2}}); Verify(GaussianFactors(-5*I), {{Complex(2,1),1},{Complex(2,-1),1}}); Verify(GaussianFactors(Complex(1,1)^11*163^4),{{Complex(1,1),11},{163,4}}); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/numerics.mpt0000644000175000017500000002462611606405405023441 0ustar giovannigiovanni/* Numerical testers - all confirmed with Matlab 6r12.0 */ f():=[]; //[//Echo(CurrentLine()+1);]; BuiltinPrecisionSet(10); //Echo("BIP set to ",10); NumericEqual(N(Sqrt(2),6), 1.41421,6);f(); NumericEqual(N(N(1+Pi,20)-Pi,20),1,20);f(); // "N" should have "HoldArgument" in some way, so inner "N" is evaluated with outer precision 20 /* Got the first digits of Pi from the following page: http://www.cecm.sfu.ca/projects/ISC/dataB/isc/C/pi10000.txt Just checking that Yacas agrees. First, however, we need to set BuiltinPrecision way higher than 10 !! */ BuiltinPrecisionSet(90);//Echo("BIP set to ",90); NumericEqual(N(Pi,70),3.141592653589793238462643383279502884197169399375105820974944592307816,70);f(); BuiltinPrecisionSet(10);//Echo("BIP set to ",10); NumericEqual( N(Sec(2),10), -2.402997962, 9);f(); NumericEqual( N(Csc(2),9), 1.09975017,9);f(); NumericEqual( N(Cot(2),9), -0.457657554, 9);f(); NumericEqual( N(Sinh(2),10), 3.626860408,10); f();// matter of discussion whether rounding should be to nearest NumericEqual( N(ArcSin(2), 9), Complex(1.570796327,1.316957897),9);f(); NumericEqual( N(ArcCos(2),9), Complex(0,-1.316957897),9);f(); NumericEqual( N(ArcTan(2*I), 12), N(Complex(1.5707963267950,0.54930614433405),12),11); f();// calculating to precision+1 because RoundToPrecision rounds... cluttering the last digit with round-off NumericEqual( N(ArcSinh(2), 10), 1.443635475,9);f(); NumericEqual( N(ArcCosh(2), 10), 1.316957897,9);f(); NumericEqual( N(ArcCosh(-2), 8), Complex(-1.3169579,3.14159265),8);f(); NumericEqual( N(ArcTanh(2), 9), Complex(0.549306144,1.570796327),9);f(); /* Numerical tests - all confirmed with Maple */ BuiltinPrecisionSet(55);//Echo("BIP set to ",55); // NOTE (hso,100311) BuiltinPrecisionSet MUST specify a value higher // than any of the precisions to be used in tests below. // Otherwise, false errors are reported. I have changed // the value from 50 to 55, to satisfy this requirement. NumericEqual( RoundToPrecision(N(Pi), 50) , 3.14159265358979323846264338327950288419716939937511 , 50);f(); NumericEqual( RoundToPrecision(N(Sin(2.0)), 49) , 0.9092974268256816953960198659117448427022549714479 ,48);f(); NumericEqual( RoundToPrecision(N(Sin(2.0)), 50) , 0.90929742682568169539601986591174484270225497144789 ,49);f(); NumericEqual( RoundToPrecision(N(Sin(2.0)), 51) , 0.90929742682568169539601986591174484270225497144789 ,50);f(); NumericEqual( RoundToPrecision(N(Cos(20.0)), 49) , 0.4080820618133919860622678609276449570992995103163 , 48); f(); NumericEqual( RoundToPrecision(N(Tan(20.0)), 49) , 2.2371609442247422652871732477303491783724839749188 , 48); f(); // to here. hso NumericEqual( RoundToPrecision(N(Exp(10.32),54), 54) , 30333.2575962246035600343483350109621778376486335450125 ,48); f(); // This one rounds off the wrong direction (125 rounded to 12 iso 13). But alas, change was needed because new interpretation means the required precision was actually higher (not number of decimals after point, but total number of digits were meant). NumericEqual( RoundToPrecision(N(Ln(10.32/4.07)), 50) , 0.93044076059891305468974486564632598071134270468002 , 50); f(); // fixed 20101229 NumericEqual( RoundToPrecision(N(1.3^10.32), 48) , 14.99323664825717956473936947123246987802978985306 , 48); f(); NumericEqual( RoundToPrecision(N(Sqrt(5.3),51), 51) , 2.302172886644267644194841586420201850185830282633675 ,51); f(); // increased to 51 digits so round-off is obviously downwards (previous rounding was defendably wrong) // this failed in gmp due to broken SqrtN() NumericEqual( RoundToPrecision(N(Sqrt(25.3)), 50) , 5.0299105359837166789719353820984438468186649281130 ,50);f(); // this failed due to broken RoundToPrecision() NumericEqual( RoundToPrecision(PowerN(13, -23), 50) , 0.23949855470974885180294666343025235387321690490245e-25 , 50);f(); NumericEqual( RoundToPrecision([Local(x);x:=Newton(x*Exp(x)-4,x,1,10^(-49)); N(x*Exp(x));], 49) , 4 ,49); f(); Verify(Newton(x^2+1,x,1,0.1,-3,3), Fail); f(); NumericEqual(Newton(x^2-1,x,1,0.1,-3,3), 1,BuiltinPrecisionGet()); f(); NumericEqual( RoundToPrecision(N(ArcSin(0.32)), 49) , 0.3257294872946301593103199105324500784354180998122808003 ,49); f(); NumericEqual( RoundToPrecision(N(Sin(N(ArcSin(0.1234567)))), 49) , 0.1234567 ,49); f(); /* ArcSin(x) for x close to 1 */ NumericEqual( RoundToPrecision(N( (1-Sin(N(ArcSin(1-10^(-25)))))*10^25), 25) , 1 , 25); f(); NumericEqual( N(ArcSin(N(Sin(1.234567),50)),50) , N(1.234567,50) , 49); f(); // calculating to precision+1 because RoundToPrecision rounds... cluttering the last digit with round-off NumericEqual( RoundToPrecision(N(ArcCos(0.32)), 49) , 1.2450668395002664599210017811073013636631665998753 , 49); f(); NumericEqual( RoundToPrecision(N(ArcTan(0.32)), 49) , 0.3097029445424561999173808103924156700884366304804 , 49); f(); NumericEqual( RoundToPrecision(N(Cos(N(ArcCos(0.1234567)))), 49) , 0.1234567 , 49);f(); NumericEqual( RoundToPrecision(N(ArcCos(N(Cos(1.234567)))), 49) , 1.234567 , 49);f(); NumericEqual( RoundToPrecision(N(Tan(N(ArcTan(20)))), 46) // large roundoff error on Tan() calculation due to subtraction from Pi/2 -- unavoidable loss of precision , 20 , 46);f(); //KnownFailure( NumericEqual( RoundToPrecision(N(Tan(N(ArcTan(500000)))), 38) , 500000 //) , 38);f(); BuiltinPrecisionSet(60); //Echo("BIP set to ",60); // obviously, 50 is not enough for the following //KnownFailure( NumericEqual( RoundToPrecision(N((Pi/2-ArcTan(N(Tan(N(Pi/2)-10^(-24)))))*10^24 ), 25) , 1 //) , 25);f(); /// special functions BuiltinPrecisionSet(50); //Echo("BIP set to ",50); // needs a pretty high value for Gamma TestMathPiper( Gamma(10.5) , (654729075*Sqrt(Pi))/1024 );f(); TestMathPiper( Gamma(9/2) , (105*Sqrt(Pi))/16 );f(); TestMathPiper( Gamma(-10.5) , (-2048*Sqrt(Pi))/13749310575 );f(); TestMathPiper( Gamma(-7/2) , (16*Sqrt(Pi))/105 );f(); NumericEqual(RoundToPlace(N( Internal'GammaNum(10.5) ), 13), 1133278.3889487855673, 13);f(); NumericEqual(RoundToPlace(N( Internal'GammaNum(-11.5) ), 20), 0.00000002295758104824, 20);f(); NumericEqual(RoundToPlace(N( Internal'GammaNum(-12.5) ), 20), -0.00000000183660648386, 20);f(); // Check for one example that N(Gamma(x)) returns the same as Internal'GammaNum NumericEqual(RoundToPlace(N( Gamma(10.5) ), 13), 1133278.3889487855673, 13);f(); NumericEqual( // lost 2 digits b/c of imprecise arithmetic RoundToPlace(N( Zeta(-11.5) ), 18) , 0.020396978715942792 ,18);f(); TestMathPiper( Zeta(40) , (261082718496449122051*Pi^40)/20080431172289638826798401128390556640625 );f(); TestMathPiper( Zeta(-11) , 691/32760 );f(); TestMathPiper( Zeta(-12) , 0 );f(); NumericEqual( RoundToPrecision(N(Zeta(40)), 19) , 1.0000000000009094948 ,19);f(); NumericEqual( RoundToPrecision(N(Zeta(1.5)), 19) , 2.6123753486854883433 ,19);f(); // test correctness of Zeta(3) NumericEqual( RoundToPrecision(Internal'ZetaNum(3)-N(Zeta(3)), 20) , 0 ,20);f(); TestMathPiper( Bernoulli(40) , -261082718496449122051/13530 );f(); Verify( ContFracList(355/113) , {3,7,16} );f(); Verify( ContFracList(-24, 4) , {-24} );f(); Verify( ContFracList(-355/113) , {-4,1,6,16} );f(); //BuiltinPrecisionSet(7);//Echo("BIP set to ",7); Verify( NearRational(N(Pi),3) , 201/64 );f(); /* For the NearRational test, perhaps better would be a real test that checks that the result is correct up to the required number of digits accuracy. */ BuiltinPrecisionSet(10);//Echo("BIP set to ",10); Verify( NearRational(N(Pi)) , 355/113, );f(); // Lambert's W function BuiltinPrecisionSet(10); NumericEqual( N(LambertW(-0.24),BuiltinPrecisionGet()) , -0.3357611648 , BuiltinPrecisionGet());f(); NumericEqual( N(LambertW(10),BuiltinPrecisionGet()) , 1.7455280027 , BuiltinPrecisionGet());f(); // Bessel Functions // These results are from GNU bc, matlab seems to suck. BuiltinPrecisionSet(50);//Echo("BIP set to ",50); NumericEqual( N(BesselJ(0,.5)), RoundToPrecision(.93846980724081290422840467359971262556892679709682,50),50 );f(); NumericEqual( N(BesselJ(0,.9)), RoundToPrecision(.80752379812254477730240904228745534863542363027564,50),50 );f(); NumericEqual( N(BesselJ(0,.99999)), RoundToPrecision(.76520208704756659155313775543958045290339472808482,50),50 );f(); NumericEqual( N(BesselJ(10,.75)), RoundToPrecision(.000000000014962171311759681469871248362168283485781647202136,50),50 );f(); NumericEqual( N(BesselJ(5,1)), RoundToPrecision(.00024975773021123443137506554098804519815836777698007,50),50 );f(); NumericEqual( N(BesselJ(4,2)), RoundToPrecision(.033995719807568434145759211288531044714832968346313,50),50 );f(); NumericEqual( N(BesselJ(10,3)), RoundToPrecision( .000012928351645715883777534530802580170743420832844164,50),50 );f(); NumericEqual( N(BesselJ(11,11)), RoundToPrecision( .20101400990926940339478738551009382430831534125484,50),50 );f(); NumericEqual( N(BesselJ(-11,11)), RoundToPrecision( -.20101400990926940339478738551009382430831534125484,50),50 );f(); NumericEqual( RoundToPrecision(N(BesselJ(1,10)),50), RoundToPrecision( .043472746168861436669748768025859288306272867118594, 50),50 );f(); NumericEqual( N(BesselJ(10,10)), RoundToPrecision( .20748610663335885769727872351875342803274461128682, 50 ),50 );f(); NumericEqual( RoundToPrecision(N(BesselJ(1,3.6)),50), RoundToPrecision( .095465547177876403845706744226060986019432754908851, 50 ),50) ;f(); BuiltinPrecisionSet(20);//Echo("BIP set to ",20); Verify( RoundToPrecision(N(Erf(Sqrt(0.8)),20),19), RoundToPrecision(.79409678926793169113034892342, 19) );f(); Verify( RoundToPrecision(N(Erf(50*I+20)/10^910,22),19), RoundToPrecision(1.09317119002909585408+I*0.00475463306931818955275, 19) );f(); // testing GammaConstNum against Maple Testing("Gamma constant"); BuiltinPrecisionSet(40);//Echo("BIP set to ",40); NumericEqual(Internal'gamma()+0, 0.5772156649015328606065120900824024310422,BuiltinPrecisionGet());f(); BuiltinPrecisionSet(20);//Echo("BIP set to ",20); Verify(gamma,ToAtom("gamma"));f(); NumericEqual(RoundToPrecision(Internal'gamma()+0,19), 0.5772156649015328606,19);f(); NumericEqual(RoundToPrecision(N(1/2+gamma+Pi), 19), 4.2188083184913260991,19);f(); // From GSL 1.0 //NumericEqual( N(PolyLog(2,-0.001),20), -0.00099975011104865108, 20 ); // PolyLog I didn't write PolyLog, but it seems to not always calculate correctly up to the last digit. Verify( RoundToPrecision(N(PolyLog(2,-0.001)+0.00099975011104865108,20),20),0);f(); // Round-off errors N([ Local(a,b); a:= 77617; b:= 33096; // this expression gives a wrong answer on any hardware floating-point platform NumericEqual( 333.75*b^6 + a^2*(11*a^2*b^2-b^6-121*b^4-2)+5.5*b^8 +a/(2*b), -0.827396,6); ],40);f(); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/transforms.mpt0000644000175000017500000000051011074042175023774 0ustar giovannigiovanniVerify( LaplaceTransform(t,s,1), 1/s ); Verify( LaplaceTransform(t,s,t^3), 6/s^4); Verify( LaplaceTransform(t,s,t), 1/s^2 ); Verify( LaplaceTransform(t,s,t*Exp(4*t)), 1/(4*(s/4-1))^2 ); Verify( LaplaceTransform(t,s,Exp(4*t)*Cos(4*t)), (s-4)/(16*(((s-4)/4)^2+1)) ); Verify( LaplaceTransform(t,s,t^3*Cosh(t)) Where s==2, 82/27 ); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/regress.mpt0000644000175000017500000004653711543450620023272 0ustar giovannigiovanni NextTest("Regression on bug reports"); Verify(N(Sin(a)),Sin(a)); LogicVerify(CanProve(P Or (Not P And Not Q)),P Or Not Q); Verify(Cos(0),1); Verify(Infinity/Infinity,Undefined); Verify(Sqrt(Infinity),Infinity); Verify(1^Infinity,Undefined); Verify((-2)*Infinity,-Infinity); Verify(Infinity*0,Undefined); Verify(Limit(x,Infinity) (-x^2+1)/(x+2),-Infinity); Verify(Limit(x,-Infinity)Exp(2*x),0); Verify(Limit(x,Infinity)(1+1/x)^x,Exp(1)); Verify(Limit(x,Infinity)(1+2/x)^x,Exp(2)); Verify(Limit(x,Infinity)(1+1/x)^(2*x),Exp(2)); Verify(Limit(x,Infinity)-2*x,-Infinity); Verify(Limit(x,Infinity)(x^2+1)/(-x^3+1),0); Verify(Limit(x,0)1/x,Undefined); Verify(Limit(x,0,Right)1/x,Infinity); Verify(Limit(x,0,Left)1/x,-Infinity); Verify([Local(a);a:=0.1;Simplify((a*b*c)/(a*c*b));],1); LogicVerify(CanProve(P Or (Not P And Not Q)),P Or Not Q); LogicVerify(CanProve(A>0 And A<=0),False); LogicVerify(CanProve(A>0 Or A<=0),True); Verify(A<0,A<0); Verify(A>0,A>0); TestMathPiper(Arg(Exp(2*I*Pi/3)),2*Pi/3); TestMathPiper(Content(1/2*x+1/2),1/2); TestMathPiper(PrimitivePart(1/2*x+1/2),x+1); TestMathPiper(Content(1/2*x+1/3),1/6); TestMathPiper(PrimitivePart(1/2*x+1/3),3*x+2); // Mod generated a stack overflow on floats. Verify(Modulo(1.2,3.4),6/5); //TODO I need to understand why we need to put Eval here. Modulo(-1.2,3.4)-2.2 returns 0/5 where the 0 is not an integer according to the system. Round-off error? NumericEqual(N(Eval(Modulo(-1.2,3.4))),2.2,BuiltinPrecisionGet()); Verify(Modulo(-12/10,34/10),11/5); // just a test to see if Verify still gives correct error Verify(N(Modulo(-12/10,34/10)),11/5); // some reports: LocalSymbols(f,p,a,b,x,n) [ f(_n) <-- Apply("Differentiate",{x,n, x^n}); Verify(f(10)-(10!)); p := a+2-(a+1); Verify(Simplify(x^p),x); ]; LocalSymbols(f,p,a,b,x,n,simple,u,v) [ simple := { Exp(_a)*Exp(_b) <- Exp(a+b), Exp(_a)*_u*Exp(_b) <- u*Exp(a+b), _u*Exp(_a)*Exp(_b) <- u*Exp(a+b), Exp(_a)*Exp(_b)*_u <- u*Exp(a+b), _u*Exp(_a)*_v*Exp(_b) <- u*v*Exp(a+b), Exp(_a)*_u*Exp(_b)*_v <- u*v*Exp(a+b), _u*Exp(_a)*Exp(_b)*_v <- u*v*Exp(a+b), _u*Exp(_a)*_v*Exp(_b)*_w <- u*v*w*Exp(a+b) }; a := Simplify(Exp(x)*(Differentiate(x) x*Exp(-x))); b := Exp(x)*Exp(-x)-Exp(x)*x*Exp(-x); a:= (a /: simple); b:= (b /: simple); Verify(Simplify(a-(1-x)),0); Verify(Simplify(b-(1-x)),0); ]; // Verify that postfix operators can be applied one after the other // without brackets Verify((3!) !, 720); Verify(3! !, 720); TestMathPiper(TrigSimpCombine(Exp(A*X)),Exp(A*X)); TestMathPiper(TrigSimpCombine(x^Sin(a*x+b)),x^Sin(a*x+b)); Verify(CanBeUni(x^(-1)),False); f(x):=Eval(Factor(x))=x; Verify(f(703), True); Verify(f(485), True); Verify(f(170410240), True); /* bug reported by Jonathan: All functions that do not have Taylor Expansions about the given point go into infinite loops. */ Verify(Taylor(x,0,5) Ln(x),Undefined); Verify(Taylor(x,0,5) 1/x,Undefined); Verify(Taylor(x,0,5) 1/Sin(x),Undefined); // Yacas used to not simplify the following, due to Pi being // considered constant. The expression was thus not expanded // as a univariate polynomial in Pi TestMathPiper(2*Pi/3,(Pi-Pi/3)); TestMathPiper(( a*(Sqrt(Pi))^2/2), (a*Pi)/2); TestMathPiper(( 3*(Sqrt(Pi))^2/2), (3*Pi)/2); TestMathPiper(( a*(Sqrt(b ))^2/2), (a*b)/2); // Bug was found: gcd sometimes returned 0! Very bad, since the // value returned by gcd is usually used to divide out greatest // common divisors, and dividing by zero is not a good idea. Verify(Gcd(0,0),1); Verify(Gcd({0}),1); // Product didn't check for correct input Verify(Product(10), Product(10)); Verify(Product(-1), Product(-1)); Verify(Product(Infinity), Product(Infinity)); Verify(Product(1 .. 10),3628800); // TestMathPiper(Sin(Pi-22),-Sin(22-Pi)); TestMathPiper(Cos(Pi-22), Cos(22-Pi)); // Verify that some matrix functions accept only positive // integer arguments. Regression test for the fact that the functions // in org/mathpiper/scripts/linalg.rep/ didn't check their arguments. // Note: Jonathan, perhaps some functions could return something // useful if the argument passed in is just a number? I'd imagine // Inverse(-2) <-- -1/2 would not be inconsistent? Verify(ZeroMatrix(-2,-2),ZeroMatrix(-2,-2)); Verify(Identity(-2),Identity(-2)); //Verify(LeviCivita(2),LeviCivita(2)); //Verify(Permutations(2),Permutations(2)); //Verify(InProduct(-2,-2),InProduct(-2,-2)); //Verify(CrossProduct(-2,-2),CrossProduct(-2,-2)); //Verify(BaseVector(-2,-2),BaseVector(-2,-2)); //Verify(DiagonalMatrix(-2),DiagonalMatrix(-2)); //Verify(Normalize(-2),Normalize(-2)); //Verify(Transpose(-2),Transpose(-2)); //Verify(Determinant(-2),Determinant(-2)); //Verify(CoFactor(-2,-2,-2),CoFactor(-2,-2,-2)); //Verify(Inverse(-2),Inverse(-2)); //Verify(Trace(-2),Trace(-2)); //Verify(SylvesterMatrix(-2,-2,-2),SylvesterMatrix(-2,-2,-2)); Verify(ZeroVector(-2),ZeroVector(-2)); Verify(Sech(x),1/Cosh(x)); Verify(Cot(x),1/Tan(x)); // Matrix operations failed: a^2 performed the squaring on each element Verify({{1,2},{3,4}}^2,{{7,10},{15,22}}); // And check that raising powers still works on lists/vectors (dotproduct?) correctly Verify({2,3}^2,{4,9}); Verify( Differentiate(x,0) Sin(x), Sin(x) ); Verify( 2/3 >= 1/3, True); Verify( Infinity + I, Complex(Infinity,1) ); Verify( Infinity - I, Complex(Infinity,-1) ); Verify( I - Infinity,Complex(-Infinity,1) ); Verify( I + Infinity, Complex(Infinity,1) ); Verify( I*Infinity,Complex(0,Infinity)); //Changed Ayal: I didn't like the old definition Verify(-I*Infinity,Complex(0,-Infinity)); //Changed Ayal: I didn't like the old definition Verify( Infinity*I,Complex(0,Infinity)); //Changed Ayal: I didn't like the old definition Verify( Infinity^I,Undefined);//Changed Ayal: I didn't like the old definition (it is undefined, right?) Verify( (2*I)^Infinity, Infinity ); Verify( Infinity/I,Infinity ); Verify( Sign(Infinity), 1 ); Verify( Sign(-Infinity), -1 ); Verify( Limit(n, Infinity) (n+1)/(2*n+3)*I, Complex(0,1/2) ); Verify( Limit(x, Infinity) x*I, Complex(0,Infinity) ); //Changed Ayal: I didn't like the old definition Verify(Integrate(x) z^100, z^100*x ); Verify(Integrate(x) x^(-1),Ln(x) ); BuiltinPrecisionSet(50); NumericEqual( RoundToN(N(ArcSin(0.0000000321232123),50),50) , 0.000000032123212300000005524661243020493367846793163005802 ,50); Verify(Internal'LnNum(1), 0); Verify(BinomialCoefficient(0,0),1 ); Verify(0|1, 1); Verify(0&1, 0); Verify(0%1, 0); Verify(0.0/Sqrt(2),0); Verify(0.0000000000/Sqrt(2),0); Verify(0.0000^(24),0); Verify(Bernoulli(24), -236364091/2730); Verify(Gamma(1/2), Sqrt(Pi)); // Coef accepted non-integer arguments as second argument, and // crashed on it. Verify(Coef(3*Pi,Pi),Coef(3*Pi,Pi)); Verify(Coef(3*Pi,x), Coef(3*Pi,x)); // Univariates in Pi did not get handled well, due to Pi being // considered a constant, non-variable. Verify(Degree(Pi,Pi),1); Verify(Degree(2*Pi,Pi),1); Verify(Sin(2*Pi), 0); Verify(Cos(2*Pi), 1); Verify(Cos(4*Pi), 1); Verify(Sin(3*Pi/2)+1, 0); Verify(Sin(Pi/2), 1); // - and ! operators didn't get handled correctly in the // parser/pretty printer (did you fix this, Serge?) Verify(PipeToString()Write((-x)!),"(-x)!"); // some interesting interaction between the rules... Verify(x*x*x,x^3,); Verify(x+x+x,3*x); Verify(x+x-x+x,2*x); // bugs with complex numbers Verify((1+I)^0, 1); Verify((-I)^0, 1); Verify((2*I)^(-10), -1/1024); Verify((-I)^(-10), -1); Verify((1-I)^(-10), Complex(0,1/32)); Verify((1-I)^(+10), Complex(0,-32)); Verify((1+2*I)^(-10), Complex(237/9765625,3116/9765625)); Verify((1+2*I)^(+10), Complex(237,-3116)); // expansion of negative powers of fractions Verify( (-1/2)^(-10), 1024); Verify( I^(Infinity), Undefined ); Verify( I^(-Infinity), Undefined ); Verify( Limit(n,Infinity) n*I^n, Undefined ); Verify(1 <= 1.0, True); Verify(-1 <= -1.0, True); Verify(0 <= 0.0, True); Verify(0.0 <= 0, True); Verify(1 >= 1.0, True); Verify(-1 >= -1.0, True); Verify(0 >= 0.0, True); Verify(0.0 >= 0, True); Verify((1==1) != True, True); Verify((a==a) != True, True); Verify((1==2) != False, True); Verify((a==2) != False, True); Verify( Integrate(x) x^5000, x^5001/5001 ); Verify( Integrate(x) Sin(x)/2, (-Cos(x))/2 ); Verify( 2^(-10), 1/1024 ); // The following line catches a bug reported where Simplify // would go into an infinite loop. It doesn't check the correctness // of the returned value as such, but merely the fact that this // simplification terminates in the first place. // // The problem was caused by a gcd calculation (from the multivariate // code) not terminating. Verify( Simplify((a^2+b^2)/(2*a)), (a^2+b^2)/(2*a) ); // The following is a classical error: 0*x=0 is only true if // x is a number! In this case, it is checked for that the // multiplication of 0 with a vector returns a zero vector. // This would automatically be caught with type checking. // More tests of this ilk are possible: 0*matrix, etcetera. Verify(0*{a,b,c},{0,0,0}); // the following broke evaluation (dr) Verify(Conjugate({a}),{a}); // not yet fixed (dr) Verify(Abs(Undefined),Undefined); // broke Plot2Differentiate() on singular functions with Abs() Verify(Undefined<1, False); Verify(Undefined>Undefined, False); Verify(Undefined>1, False); Verify(Undefined >= -4, False); Verify(Undefined <= -4, False); // Jonathan's bug report BuiltinPrecisionSet(10); NumericEqual(N(Cos(Pi*.5),BuiltinPrecisionGet()), 0,BuiltinPrecisionGet()); /* Jitse's bug report, extended with the changes that do not coerce integers to floats automatically any more (just enter a dot and the number becomes float if that is what is intended). */ Verify(CForm(4), "4"); Verify(CForm(4.), "4."); Verify(CForm(0), "0"); Verify(CForm(0.), "0."); // Discovered that Floor didn't handle new exponent notation Verify(Floor(1001.1e-1),100); Verify(Floor(10.01e1),100); Verify(Floor(100.1),100); // Bugs discovered by Jonathan: Verify(Undefined*0,Undefined); // Actually, the following Groebner test is just to check that the program doesn't crash on this, // more than on the exact result (which is hopefully correct also ;-) ) Verify(Groebner({x*(y-1),y*(x-1)}),{x*y-x,x*y-y,y-x,y^2-y}); // Reported by Yannick Versley Verify((Integrate(x,a,b)Cos(x)^2) - ((b-Sin((-2)*b)/2)/2-(a-Sin((-2)*a)/2)/2),0); Verify(Differentiate(t) Integrate(x,a,b) f(x,t),Integrate(x,a,b)Deriv(t)f(x,t)); // This was returning FWatom(Sin(x)) Verify( Factor(Sin(x)), Factor(Sin(x)) ); // should return unevaled Verify( BesselJ(0,x), BesselJ(0,x) ); // FunctionToList and ListToFunction coredumped when their arguments were invalid Verify(FunctionToList(Cos(x)),{Cos,x}); Verify(ListToFunction({Cos,x}),Cos(x)); [ Local(exception); exception := False; ExceptionCatch(FunctionToList(1.2), exception := ExceptionGet()); Verify(exception = False, False); exception := false; ExceptionCatch(ListToFunction(1.2), exception := ExceptionGet()); Verify(exception = False, False); ]; // Reported by Serge: xml tokenizer not general enough Verify(XmlExplodeTag("

"), XmlTag("P",{},"OpenClose")); Verify(XmlExplodeTag("

"), XmlTag("P",{},"OpenClose")); Verify(ToBase(16,30),"1e"); Verify(FromBase(16,"1e"),30); // numbers are too small because of wrong precision handling BuiltinPrecisionSet(30); Verify(0.00000000000000000005421010862 = 0, False); // 2^(-64) Verify(0.00000000000000000005421010862 / 1 = 0, False); Verify(0.00000000000000000005421010862 / 2 = 0, False); Verify(0.00000000000000000001 = 0, False); Verify(0.00000000000000000001 / 2 = 0, False); Verify(0.00000000000000000000000000001 = 0, False); Verify(0.000000000000000000000000000001 = 0, False); Verify((0.0000000000000000000000000000000000000001 = 0), False); // I added another one, the code will currently say that 0.0000...00001=0 is True // for a sufficient amount of zeroes, regardless of precision. Either that is good // or that is bad, but the above tests didn't go far enough. This one makes it // more explicit, unless we move over to a 128-bits system ;-) Verify((0.0000000000000000000000000000000000000000000000001 = 0), False); // Problem with FloatIsInt and gmp Verify(FloatIsInt(3.1415926535e9), False); Verify(FloatIsInt(3.1415926535e10), True); Verify(FloatIsInt(3.1415926535e20), True); Verify(FloatIsInt(0.3e20), True); /* Regression on bug reports from docs/bugs.txt */ /* Bug #1 */ /* Can't test: 'Limit(x,0)Differentiate(x,2)Sin(x)/x' never terminates */ /* Bug #2 */ KnownFailure((Limit(x,Infinity) x^n/Ln(x)) = Infinity); KnownFailure((Limit(x,0,Right) x^(Ln(a)/(1+Ln(x)))) = a); Verify((Limit(x,0) (x+1)^(Ln(a)/x)), a); /* Note paren's around bodied operators like Limit, D, Integrate; otherwise it's parsed as Limit (... = ...) */ /* Bug #3 */ KnownFailure(Gcd(10,3.3) != 3.3 And Gcd(10,3.3) != 1); /* I don't know what the answer should be, but buth 1 and 3.3 seem */ /* certainly wrong. */ Verify(Gcd(-10, 0), 10); Verify(Gcd(0, -10), 10); /* Bug #4 */ /* How can we test for this? */ /* Bug says: at startup, 2^Infinity does not simplify to Infinity */ /* Bug #5 */ /* How can we test for this? */ /* Bug says: Limit(n,Infinity) Sqrt(n+1)-Sqrt(n) floods stack */ /* but 'MaxEvalDepth reached' exits Yacas, even inside ExceptionCatch */ /* Bug #6 */ KnownFailure((Differentiate(z) Conjugate(z)) = Undefined); /* Bug #7 */ Verify(Im(3+I*Infinity), Infinity); /* resolved */ Verify(Im(3+I*Undefined), Undefined); /* Bug #9 */ Verify((Integrate(x,-1,1) 1/x), 0); /* or maybe Undefined? */ Verify((Integrate(x,-1,1) 1/x^2), Infinity); /* Bug #10 */ Verify(Simplify(x^(-2)/(1-x)^3) != 0); /* I don't know what we want to return, but '0' is definitely wrong! */ /* Bug #11 */ Verify(ArcCos(Cos(beta)) != beta); /* Bug #12 */ KnownFailure((Limit(n, Infinity) n^5/2^n) = 0); /* Bug #13 */ /* Cannot test; TrigSimpCombine(x^500) floods stack */ /* Bug #14 */ Verify((Limit(x,Infinity) Zeta(x)), 1); // Actually, I changed the Factorial(x) to (x!) Verify((Limit(x,Infinity) (x!)), Infinity); /* Bug #15 */ Verify(PowerN(0,0.55), 0); // LogN(-1) locks up in gmpnumbers.cpp, will be fixed in scripts //FIXME this test should be uncommented eventually // Verify(ExceptionCatch(PowerN(-1,-0.5), error), error); /* Bug #16 */ /* Can't test, bug in build system */ /* Bug #17 */ Verify(Assoc(x-1, Factors(x^6-1))[2], 1); /* Bug #18 */ //Changed, see next line TestMathPiper(Integrate(x) x^(1/2), 2/3*x^(3/2)); TestMathPiper(Integrate(x) x^(1/2), (2/3)*Sqrt(x)^(3)); Verify(a[2]*Sin(x)/:{Sin(_x) <- sin(x)},a[2]*sin(x)); // There was a bug, reported by Sebastian Ferraro, which caused the determinant // to return "Undefined" when one of the elements of the diagonal of a matrix // was zero. This was due to the numeric determinant algorithm applying // Gaussian elimination, but taking the elements on the diagonal as pivot points. Verify(IsZero(Determinant( {{1,-1,0,0},{0,0,-1,1},{1,0,0,1},{0,1,1,0}} )),True); // The following failed when numerics changed so that 0e-1 was not matched to 0 any more in // a transformation rule defining the less than operator. Verify(ExpNum(0),1); NumericEqual(ExpNum(0e-1),1,BuiltinPrecisionGet()); Verify(500 < 0e-1,False); // version 1.0.56: Due to MathBitCount returning negative values sometimes, functions depending on // proper functioning failed. MathSqrtFloat failed for instance on N(1/2). It did give the right // result for 0.5. NumericEqual(N(Sqrt(500000e-6),20),N(Sqrt(0.0000005e6),20),20); NumericEqual(N(Sqrt(0.5),20),N(Sqrt(N(1/2)),20),20); // With the changes in numerics, RoundTo seems to have been broken. This line demonstrates the problem. // The last digit is suddenly rounded down (it used to be 4, correctly, and then gets rounded down to 3). KnownFailure(RoundTo(RoundTo(N(Cot(2),9),9),N(Cot(2),9),9)=0); // LogN used to hang on *all* input Verify(LogN(2)!=0,True); // Bug that was introduced when going to the new numeric setup where // numbers were not converted to strings any more. In the situation // -n*10^-m where n and m positive integers, the number got truncated // prematurely, resulting in a wrong rounding. [ Local(n,m,nkeep,lcl); n:=7300 + 12*I; m:=2700 + 100*I; nkeep:=n; n:=m; m:=nkeep - m*Round(nkeep/m); lcl:=Re(N(n/m))+0.5; Verify(FloorN(lcl),-3); ]; /* Here follow some tests for MathBitCount. These were written while creating the Java version, fixing BitCount in the process. */ Verify(MathBitCount(3),2); Verify(MathBitCount(3.0),2); Verify(MathBitCount(4),3); Verify(MathBitCount(4.0),3); Verify(MathBitCount(0),0); Verify(MathBitCount(0.0),0); Verify(MathBitCount(0.5),0); Verify(MathBitCount(0.25),-1); Verify(MathBitCount(0.125),-2); Verify(MathBitCount(0.0125),-6); Verify(MathBitCount(-3),2); Verify(MathBitCount(-3.0),2); Verify(MathBitCount(-4),3); Verify(MathBitCount(-4.0),3); Verify(MathBitCount(-0),0); Verify(MathBitCount(-0.0),0); Verify(MathBitCount(-0.5),0); Verify(MathBitCount(-0.25),-1); Verify(MathBitCount(-0.125),-2); Verify(MathBitCount(-0.0125),-6); // This one ended in an infinite loop because 1 is an even function, and the indefinite integrator // then kept on calling itself because the left and right boundaries were equal to zero. Verify(Integrate(x,0,0)1,0); // This code verifies that if integrating over a zero domain, the result // is zero. Verify(Integrate(x,1,1)Sin(Exp(x^2)),0); /* Reverse and FlatCopy (and some friends) would segfault in the past if passed a string as argument. * I am not opposed to overloading these functions to also work on strings per se, but for now just * check that they return an error in stead of segfaulting. */ Verify(ExceptionCatch(Reverse("abc"),"Exception"), "Exception"); Verify(ExceptionCatch(FlatCopy("abc"),"Exception"), "Exception"); // Make sure Mod works threaded Verify(Modulo(2,Infinity),2); Verify(Modulo({2,1},{2,2}),{0,1}); Verify(Modulo({5,1},4),{1,1}); /* In MatchLinear and MatchPureSquare, the matched coefficients were * assigned to global variables that were not protected with LocalSymbols. */ [ Local(a,b,A); a:=mystr; A:=mystr; /* The real test here is that no error is generated due to the * fact that variables a or A are set. */ Verify(Simplify((Integrate(x,a,b)Sin(x))-Cos(a)+Cos(b)),0); ]; // Factoring 2*x^2 used to generate an error Verify(Factor(2*x^2),2*x^2); /* Bug report from Magnus Petursson regarding determinants of matrices that have symbolic entries */ Verify(CanBeUni(Determinant({{a,b},{c,d}})),True); /* Bug report from Michael Borcherds. The brackets were missing. */ Verify(TeXForm(Hold(2*x*(-2))), "$2 \\cdot x \\cdot ( - 2) $"); /* Bug reported by Adrian Vontobel. */ [ Local(A1,A2); A1:=Pi*20^2; // 400*Pi A2:=Pi*18^2; // 324*Pi Verify(Minimum(A1,A2), 324*Pi); Verify(Maximum(A1,A2), 400*Pi); ]; /* One place where we forgot to change Sum to Add */ TestMathPiper(Diverge({x*y,x*y,x*y},{x,y,z}),x+y); /* Bug reported by Adrian Vontobel: comparison operators should coerce * to a real value as much as possible before trying the comparison. */ [ Local(F); F:=0.2*Pi; Verify(F>0.5, True); Verify(F>0.7, False); Verify(F<0.7, True); Verify(F<0.6, False); ]; /* Bug reported by Michael Borcherds: Simplify(((4*x)-2.25)/2) returned some expression with three calls to Gcd, which was technically correct, but not the intended simplification. */ Verify(IsZero(Simplify(Simplify(((4*x)-2.25)/2)-(2*x-2.25/2))),True); /* Bug reported by Adrian Vontobel: when assigning an expression to a variable, * it did not get re-evaluated in the calling environment when passing it in to Newton. * The resulting value was "Undefined", instead of the expected 1.5 . */ NumericEqual([ Local(expr); expr := 1800*x/1.5 - 1800; Newton(expr, x,2,0.001); ],1.5,3); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/dot.mpt0000644000175000017500000000305311074042175022371 0ustar giovannigiovanni////// // $Id: dot.yts,v 1.2 2006/03/26 12:49:15 ayalpinkus Exp $ // Tests for Dot ////// Testing("-- Dot"); // vector . vector Verify(Dot({},{}),0); Verify(Dot({},a),Hold(Dot({},a))); Verify(Dot(a,{}),Hold(Dot(a,{}))); Verify(Dot({a},{}),Hold(Dot({a},{}))); Verify(Dot({},{a}),Hold(Dot({},{a}))); Verify(Dot({a},{b}),a*b); Verify(Dot({a},{b,c}),Hold(Dot({a},{b,c}))); Verify(Dot({a,b},{c}),Hold(Dot({a,b},{c}))); Verify(Dot({a,b},{c,d}),a*c+b*d); Verify(Dot({a,b},{c,{d}}),Hold(Dot({a,b},{c,{d}}))); Verify(Dot({a,{b}},{c,d}),Hold(Dot({a,{b}},{c,d}))); Verify(Dot({a,b},{c,d,e}),Hold(Dot({a,b},{c,d,e}))); Verify(Dot({a,b,c},{d,e}),Hold(Dot({a,b,c},{d,e}))); Verify(Dot({1,2,3},{4,5,6}),32); // matrix . vector Verify(Dot({{}},{}),{0}); Verify(Dot({{}},{1}),Hold(Dot({{}},{1}))); Verify(Dot({{},{}},{}),{0,0}); Verify(Dot({{a}},{b}),{a*b}); Verify(Dot({{a},{b}},{c}),{a*c,b*c}); Verify(Dot({{1},{2}},{2}),{2,4}); Verify(Dot({{1,2,3},{4,5,6}},{7,8,9}),{50,122}); // vector . matrix Verify(Dot({},{{}}),Hold(Dot({},{{}}))); Verify(Dot({},{{},{}}),Hold(Dot({},{{},{}}))); Verify(Dot({1},{{}}),Hold(Dot({1},{{}}))); Verify(Dot({1},{{},{}}),Hold(Dot({1},{{},{}}))); Verify(Dot({a,b},{{c},{d}}),{a*c+b*d}); Verify(Dot({1,2,3},{{4,5},{6,7},{8,9}}),{40,46}); // matrix . matrix Verify(Dot({{}},{{}}),Hold(Dot({{}},{{}}))); Verify(Dot({{a}},{{}}),Hold(Dot({{a}},{{}}))); Verify(Dot({{}},{{b}}),Hold(Dot({{}},{{b}}))); Verify(Dot({{1,2},{3,4},{5,6}},{{1,2,3},{4,5,6}}),{{9,12,15},{19,26,33},{29,40,51}}); Verify(Dot({{1,2,3},{4,5,6}},{{1,2},{3,4},{5,6}}),{{22,28},{49,64}}); ////// mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/multivar.mpt0000644000175000017500000000016611133333737023453 0ustar giovannigiovanni NextTest("Test arithmetic"); TestMathPiper(NormalForm(MM((x+y)^5)),y^5+5*x*y^4+10*x^2*y^3+10*x^3*y^2+5*x^4*y+x^5); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/lists.mpt0000644000175000017500000001005711602432433022740 0ustar giovannigiovanni Verify(Intersection({aa,b,c},{b,c,d}),{b,c}); Verify(Union({aa,b,c},{b,c,d}),{aa,b,c,d}); Verify(Difference({aa,b,c},{b,c,d}),{aa}); NextTest("VarList"); Verify(VarList(x^2+y^3) , {x , y}); Verify(List(1,2,3),{1 , 2 , 3}); Testing("BubbleSort"); Verify(BubbleSort({2,3,1},"<"),{1,2,3}); Verify(BubbleSort({2,3,1},">"),{3,2,1}); Testing("HeapSort"); Verify(HeapSort({2,3,1},"<"),{1,2,3}); Verify(HeapSort({2,1,3},">"),{3,2,1}); Verify(HeapSort({7,3,1,2,6},"<"),{1,2,3,6,7}); Verify(HeapSort({6,7,1,3,2},">"),{7,6,3,2,1}); Verify(Type(Cos(x)),"Cos"); Verify(ArgumentsCount(Cos(x)),1); Verify(Contains({a,b,c},b),True); Verify(Contains({a,b,c},d),False); Verify(Append({a,b,c},d),{a,b,c,d}); Verify(RemoveDuplicates({a,b,b,c}),{a,b,c}); Verify(Count({a,b,b,c},b),2); Verify(VarList(x*Cos(x)),{x}); [ Local(l); l:={1,2,3}; DestructiveDelete(l,1); Verify(l,{2,3}); DestructiveInsert(l,1,1); Verify(l,{1,2,3}); l[1] := 2; Verify(l,{2,2,3}); l[1] := 1; DestructiveDelete(l,3); Verify(l,{1,2}); DestructiveInsert(l,3,3); Verify(l,{1,2,3}); DestructiveDelete(FlatCopy(l),1); Verify(l,{1,2,3}); ]; Verify(Table(i!,i,1,4,1),{1,2,6,24}); Verify(PermutationsList({a,b,c}),{{a,b,c},{a,c,b},{c,a,b},{b,a,c},{b,c,a},{c,b,a}}); Testing("ListOperations"); Verify(First({a,b,c}),a); Verify(Rest({a,b,c}),{b,c}); Verify(DestructiveReverse({a,b,c}),{c,b,a}); Verify(ListToFunction({a,b,c}),a(b,c)); Verify(FunctionToList(a(b,c)),{a,b,c}); Verify(Delete({a,b,c},2),{a,c}); Verify(Insert({a,c},2,b),{a,b,c}); Testing("Length"); Verify(Length({a,b}),2); Verify(Length({}),0); Testing("Nth"); Verify(Nth({a,b},1),a); Verify({a,b,c}[2],b); Testing("Concat"); Verify(Concat({a,b},{c,d}),{a,b,c,d}); //This is simply not true!!! Verify(Hold(Concat({a,b},{c,d})),Concat({a,b},{c,d})); Testing("Binary searching"); Verify(BSearch(100,{{n},n^2-15}), -1); Verify(BSearch(100,{{n},n^2-16}), 4); Verify(BSearch(100,{{n},n^2-100002}), -1); Verify(BSearch(100,{{n},n^2-0}), -1); Verify(FindIsq(100,{{n},n^2-15}), 3); Verify(FindIsq(100,{{n},n^2-16}), 4); Verify(FindIsq(100,{{n},n^2-100002}), 100); Verify(FindIsq(100,{{n},n^2-0}), 1); Verify(Difference(FuncList(a*b/c*d), {*,/}), {}); Verify(Difference(FuncListArith(0*x*Sin(a/b)*Ln(Cos(y-z)+Sin(a))), {*,Ln,Sin}), {}); Verify(Difference(VarListArith(x+a*y^2-1), {x,a,y^2}), {}); Verify(Difference(FuncList(IsCFormable([i:=0;While(i<10)[i++; a--; a:=a+i; {};];])), {IsCFormable,Prog,:=,While,<,++,--,ToAtom("+"),List}), {}); Verify(FuncList({1,2,3}),{List}); Verify(FuncList({{},{}}),{List}); Verify(FuncList({}),{List}); Testing("AssocDelete"); [ Local(hash); hash:={{"A",1},{"A",2},{"B",3},{"B",4}}; AssocDelete(hash,{"B",3}); Verify(hash, {{"A",1},{"A",2},{"B",4}}); Verify(AssocDelete(hash,"A"),True); Verify(hash, {{"A",2},{"B",4}}); Verify(AssocDelete(hash,"C"),False); Verify(hash, {{"A",2},{"B",4}}); AssocDelete(hash,"A"); Verify(hash, {{"B",4}}); AssocDelete(hash, {"A",2}); AssocDelete(hash,"A"); Verify(hash, {{"B",4}}); Verify(AssocDelete(hash,"B"),True); Verify(hash, {}); Verify(AssocDelete(hash,"A"),False); Verify(hash, {}); ]; Testing("-- Arithmetic Operations"); Verify(1+{3,4},{4,5}); Verify({3,4}+1,{4,5}); Verify({1}+{3,4},Hold({1}+{3,4})); Verify({3,4}+{1},Hold({3,4}+{1})); Verify({1,2}+{3,4},{4,6}); Verify(1-{3,4},{-2,-3}); Verify({3,4}-1,{2,3}); Verify({1}-{3,4},Hold({1}-{3,4})); Verify({3,4}-{1},Hold({3,4}-{1})); Verify({1,2}-{3,4},{-2,-2}); Verify(2*{3,4},{6,8}); Verify({3,4}*2,{6,8}); Verify({2}*{3,4},Hold({2}*{3,4})); Verify({3,4}*{2},Hold({3,4}*{2})); Verify({1,2}*{3,4},{3,8}); Verify(2/{3,4},{2/3,1/2}); Verify({3,4}/2,{3/2,2}); Verify({2}/{3,4},Hold({2}/{3,4})); Verify({3,4}/{2},Hold({3,4}/{2})); Verify({1,2}/{3,4},{1/3,1/2}); Verify(2^{3,4},{8,16}); Verify({3,4}^2,{9,16}); Verify({2}^{3,4},Hold({2}^{3,4})); Verify({3,4}^{2},Hold({3,4}^{2})); Verify({1,2}^{3,4},{1,16}); // non-destructive Reverse operation [ Local(lst,revlst); lst:={a,b,c,13,19}; revlst:=Reverse(lst); Verify(revlst,{19,13,c,b,a}); Verify(lst,{a,b,c,13,19}); ]; Verify(IsBound(lst),False); Verify(IsBound(revlst),False); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/canprove.mpt0000644000175000017500000000317411074042175023424 0ustar giovannigiovanni NextTest("Propositional logic theorem prover"); Verify(CanProve(( (a=>b) And (b=>c) => (a=>c) )),True); Verify(CanProve((((a=>b) And (b=>c))=> (a=>c) )),True); Verify(CanProve(( (a=>b) And((b=>c) => (a=>c)))),((Not a Or b)And(Not a Or (b Or c))) ); //KnownFailure(BadOutput + WhenPreviousLine + IsUncommented); //And *my* previous line (the KnownFailure) aborts. (witnessed by no report from next line). Verify(CanProve( True ),True); Verify(CanProve(a Or Not a) ,True); Verify(CanProve(True Or a) ,True); Verify(CanProve(False Or a) ,a ); Verify(CanProve(a And Not a) ,False); Verify(CanProve(a Or b Or (a And b)) ,a Or b ); /* Two theorems from the Pure Implicational Calculus (PIC), in which the * only operator is [material] implication. From the first, all other * theorems in PIC can be proved using only the two transformation rules: * 1. Rule of substitution. Uniform replacement in theorems yields theorems. * 2. Rule of detachment, or modus ponens. If 'a' and 'a=>b' are theorems, then 'b' is a theorem. * * 1. Lukasiewicz, Jan, "The Shortest Axiom of the Implicational Calculus * of Propositions," Proceedings of the Royal Irish Academy, vol. 52, * Sec. A, No. 3 (1948). [ Can you say "Polish Notation"? ] * 2. Meredith, David, "On a Property of Certain Propositional Formulae," * Notre Dame Journal of Formal Logic, vol. XIV, No. 1, January 1973. */ Verify(CanProve( /* 1. CCCpqrCCrpCsp */ ((p=>q) => r) => ((r=>p) => (s=>p)) ), True); Verify(CanProve( /* 2. CCpCqrCqCpr */ (p => (q=>r)) => (q => (p=>r)) ), True); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/c_tex_form.mpt0000644000175000017500000000710411447311113023724 0ustar giovannigiovanni/*LoadScriptOnce("texform");*/ NextTest("TeXForm()..."); /* it worketh no more... Testing("Realistic example"); f:=Exp(I*lambda*eta)*w(T*(k+k1+lambda)); g:=Simplify(Subst(lambda,0) f+(k+k1)*(Differentiate(lambda)f)+k*k1*Differentiate(lambda)Differentiate(lambda)f ); Verify(TeXForm(g), ...); */ Verify( TeXForm(Hold(Cos(A-B)*Sqrt(C+D)-(a+b)*c^d+2*I+Complex(a+b,a-b)/Complex(0,1))) ,"$\\cos ( A - B) \\cdot \\sqrt{C + D} - ( a + b) \\cdot c ^{d} + 2 \\cdot \\imath + \\frac{a + b + \\imath \\cdot ( a - b) }{\\imath } $" ); Verify( TeXForm(Hold(Exp(A*B)/C/D/(E+F)*G-(-(a+b)-(c-d))-b^(c^d) -(a^b)^c)) ,"$\\frac{\\frac{\\frac{\\exp ( A \\cdot B) }{C} }{D} }{E + F} \\cdot G - ( - ( a + b) - ( c - d) ) - b ^{c ^{d}} - ( a ^{b}) ^{c}$" ); Verify( TeXForm(Hold(Cos(A-B)*Sin(a)*f(b,c,d*(e+1))*Sqrt(C+D)-(g(a+b)^(c+d))^(c+d))) ,"$\\cos ( A - B) \\cdot \\sin a \\cdot f( b, c, d \\cdot ( e + 1) ) \\cdot \\sqrt{C + D} - ( g( a + b) ^{c + d}) ^{c + d}$" ); // testing latest features: \\cdot, %, (a/b)^n, BinomialCoefficient(), BesselI, OrthoH Verify( TeXForm(3*2^n+Hold(x*10!) + (x/y)^2 + BinomialCoefficient(x,y) + BesselI(n,x) + Maximum(a,b) + OrthoH(n,x)) , "$3\\cdot 2 ^{n} + x\\cdot 10! + ( \\frac{x}{y} ) ^{2} + {x \\choose y} + I _{n}( x) + \\max ( a, b) + H _{n}( x) $" ); /* this fails because of a bug that Differentiate(x) f(y) does not go to 0 */ /* Verify( TeXForm(3*Differentiate(x)f(x,y,z)*Cos(Omega)*Modulo(Sin(a)*4,5/a^b)) ,"$3 ( \\frac{\\partial}{\\partial x}f( x, y, z) ) ( \\cos \\Omega ) ( 4 ( \\sin a) ) \\bmod \\frac{5}{a ^{b}} $" ); */ Verify( TeXForm(Hold(Differentiate(x)f(x))) ,"$\\frac{d}{d x}f( x) $"); Verify( TeXForm(Hold(Not (c<0) And (a+b)*c>= -d^e And (c<=0 Or b+1>0) Or a!=0 And Not (p=q))) ,"$ \\neg c < 0\\wedge ( a + b) \\cdot c\\geq - d ^{e}\\wedge ( c\\leq 0\\vee b + 1 > 0) \\vee a\\neq 0\\wedge \\neg p = q$" ); Verify( TeXForm((Differentiate(x)f(x,y,z))*Cos(Omega)*Modulo(Sin(a)*4,5/a^b)) ,"$( \\frac{\\partial}{\\partial x}f( x, y, z) ) \\cdot \\cos \\Omega \\cdot ( 4 \\cdot \\sin a) \\bmod \\frac{5}{a ^{b}} $" ); Verify( TeXForm(Pi+Exp(1)-Theta-Integrate(x,x1,3/g(Pi))2*theta(x)*Exp(1/x)) ,"$\\pi + \\exp ( 1) - \\Theta - \\int _{x_{1}} ^{\\frac{3}{g( \\pi ) } } 2 \\cdot \\theta ( x) \\cdot \\exp ( \\frac{1}{x} ) dx$" ); Verify( TeXForm({a[3]*b[5]-c[1][2],{a,b,c,d}}) ,"$( a _{3} \\cdot b _{5} - c _{( 1, 2) }, ( a, b, c, d) ) $" ); Bodied("aa", 200); Infix("bar", 100); Verify( TeXForm(aa(x,y) z + 1 bar y!) ,"$aa( x, y) z + 1\\mathrm{ bar }y!$" ); Verify( TeXForm(x^(1/3)+x^(1/2)) , "$\\sqrt[3]{x} + \\sqrt{x}$" ); /* Verify( TeXForm() ,"" ); */ Verify( CForm(Hold(Cos(A-B)*Sin(a)*func(b,c,d*(e+Pi))*Sqrt(Abs(C)+D)-(g(a+b)^(c+d))^(c+d))) ,"cos(A - B) * sin(a) * func(b, c, d * ( e + Pi) ) * sqrt(fabs(C) + D) - pow(pow(g(a + b), c + d), c + d)" ); Verify( CForm(Hold([i:=0;While(i<10)[i++; a:=a+Floor(i);];])) , "{ i = 0; while(i < 10) { ++(i); a = a + floor(i); } ; ; } " ); /* Check that we can still force numbers to be floats in stead of integers if we want to */ Verify( CForm(Hold([i:=0.;While(i<10.)[i++; a:=a+Floor(i);];])) , "{ i = 0.; while(i < 10.) { ++(i); a = a + floor(i); } ; ; } " ); Testing("IsCFormable"); Verify( IsCFormable(e+Pi*Cos(A-B)/3-Floor(3.14)*2) , True ); Verify( IsCFormable(e+Pi*Cos(A-B)/3-Floor(3.14)*2+bad'func(x+y)) , False ); Verify( IsCFormable(e+Pi*Cos(A-B)/3-Floor(3.14)*2+bad'func(x+y), {bad'func}) , True ); Verify( IsCFormable([i:=0;While(i<10)[i++; a:=a+i;];]) , True ); Verify( IsCFormable([i:=0;While(i<10)[i++; a:=a+i; {};];]) , False ); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/nummethods.mpt0000644000175000017500000000114311351575043023767 0ustar giovannigiovanni// test some numerical methods // these examples are taken from the refman Verify(IntPowerNum(3*10^100, 0, MultiplyN,1), 1); Verify(IntPowerNum(3, 3, MultiplyN,1), 27); Verify(IntPowerNum(HilbertMatrix(2), 4, *, Identity(2)), {{289/144,29/27},{29/27,745/1296}}); Verify(IntPowerNum(3,100,{{x,y},Modulo(x*y,7)},1), 4); BuiltinPrecisionSet(22); NumericEqual(RoundTo(SumTaylorNum(1, {{k},1/k!}, {{k},1/k}, 21),21), 2.718281828459045235359,21); NumericEqual(RoundTo(SumTaylorNum(1, {{k},1/k!}, 21),21), 2.718281828459045235359,21); NumericEqual(NewtonNum({{x}, x+Sin(x)}, 3, 5, 3), 3.14159265358979323846,20); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/integrate.mpt0000644000175000017500000000502511554750350023572 0ustar giovannigiovanni // verify that unknown integrals don't simplify Verify(Integrate(x,a,b)Exp(Sin(x)),Integrate(x,a,b)Exp(Sin(x))); Verify(Integrate(x )Exp(Sin(x)),Integrate(x )Exp(Sin(x))); // Verify that Yacas cannot integrate these expressions. // Yacas needs to return the integration unevaluated, or // return a correct answer (if it happens to be able to do // these integrals in the future). TestNonIntegrable(_expr) <-- Verify(Type(expr) = "Integrate",True); // The following two used to get the interpreter into an infinite // loop. Fixed in version 1.0.51 // FIXED!!! TestNonIntegrable(Integrate(x)(x*Ln(x))); TestNonIntegrable(Integrate(x)Sin(Exp(x))); Verify(Integrate(x) x^(-1),Ln(x)); // Well done Jonathan! ;-) Verify(Integrate(x) 1/x,Ln(x) ); Verify(Integrate(x) 1/x^2, -x^ -1 ); Verify(Integrate(x) 6/x^2, (-6)*x^-1); Verify(Integrate(x) 3/Sin(x),3*Ln(1/Sin(x)-Cos(x)/Sin(x)) ); Verify(Integrate(x) Ln(x), x*Ln(x)-x ); Verify(Integrate(x) x^5000, x^5001/5001 ); Verify(Integrate(x) 1/Tan(x), Ln(Sin(x)) ); Verify(Integrate(x) 1/Cosh(x)^2, Tanh(x) ); Verify(Integrate(x) 1/Sqrt(3-x^2), ArcSin(x/Sqrt(3)) ); Verify(Integrate(x) Erf(x), x*Erf(x)+1/(Exp(x^2)*Sqrt(Pi)) ); Verify(Integrate(x) Sin(x)/(2*y+4),(-Cos(x))/(2*y+4)); Verify(Integrate(x, {logAbs -> True})1/x, Ln(Abs(x))); Verify(Integrate(x,a,b, {logAbs -> True})1/x, Ln(Abs(b))-Ln(Abs(a))); TestNonIntegrable(Integrate(x) x^(1/x)); TestNonIntegrable(Integrate(x) x^(Sin(x))); TestNonIntegrable(Integrate(x) Exp(x^2)); TestNonIntegrable(Integrate(x) Sin(x^2)); TestMathPiper(Integrate(x,0,A)Sin(x),1 - Cos(A)); TestMathPiper(Integrate(x,0,A)x^2,(A^3)/3); TestMathPiper(Integrate(x,0,A)Sin(B*x),1/B-Cos(A*B)/B); TestMathPiper(Integrate(x,0,A)(x^2+2*x+1)/(x+1),(A^2)/2+A); TestMathPiper(Integrate(x,0,A)(x+1)/(x^2+2*x+1),Ln(A+1)); // Check that threaded integration works Verify((Integrate(x,0,1) {1,x*x,1+x})-{1,1/3,3/2},{0,0,0}); // Test MatchLinear: code heavily used with integration LocalSymbols(TestMatchLinearTrue,TestMatchLinearFalse) [ TestMatchLinearTrue(_var,_expr,_expected) <-- [ Local(a,b); Verify(MatchLinear(var,expr),True); a:=Simplify(Matched'a()-expected[1]); b:=Simplify(Matched'b()-expected[2]); `TestMathPiper(@a,0); `TestMathPiper(@b,0); ]; TestMatchLinearFalse(_var,_expr) <-- [ Local(a,b); Verify(MatchLinear(var,expr),False); ]; TestMatchLinearTrue(x,(R+1)*x+(T-1),{(R+1),(T-1)}); TestMatchLinearTrue(x,x+T,{1,T}); TestMatchLinearTrue(x,a*x+b,{a,b}); TestMatchLinearFalse(x,Sin(x)*x+(T-1)); TestMatchLinearFalse(x,x+Sin(x)); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/comments.mpt0000644000175000017500000000074711502266107023436 0ustar giovannigiovanni NextTest("Checking comment syntax supported"); [ Local(a); /* something here */ a:= 3; // test 1 // /* test2 */ /* // test3 */ //Echo({a, Nl()}); // Check parsing a==-b; // This would generate a parse error in Yacas versions 1.0.54 and earlier ]; [ //Test ExceptionCatch and ExceptionGet. Local(exception); exception := False; ExceptionCatch(Check(False, "Unspecified", "some error"), exception := ExceptionGet()); Verify(exception = False, False); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/poly.mpt0000644000175000017500000000014711133333737022572 0ustar giovannigiovanni NextTest("Polynomials"); TestMathPiper(Expand((1+x)^2),1+2*x+x^2); // We need more polynomial tests mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/ode.mpt0000644000175000017500000000043711316325143022353 0ustar giovannigiovanni Echo("**** THE ODE TEST HAS BEEN TEMPORARILY REMOVED BECAUSE IT CAUSED AN INFINITE RECURSION ****"); //Verify( OdeTest(y''+y, OdeSolve(y''+y==0) ), 0 ); //Verify( OdeTest(y'/5-Sin(x), OdeSolve(y'/5==Sin(x)) ), 0 ); //Verify( OdeTest(x*y' - 1, OdeSolve(x*y'==1) ), 0 ); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/dimensions.mpt0000644000175000017500000000230711074042175023754 0ustar giovannigiovanni////// // $Id: dimensions.yts,v 1.2 2006/03/26 12:49:15 ayalpinkus Exp $ // Tests for Dimensions ////// Testing("-- Dimensions (Tensor Rank)"); Verify(Dimensions(a),{}); Verify(Dimensions({}),{0}); Verify(Dimensions({a,b}),{2}); Verify(Dimensions({{}}),{1,0}); Verify(Dimensions({{a}}),{1,1}); Verify(Dimensions({{},a}),{2}); Verify(Dimensions({{a},b}),{2}); Verify(Dimensions({{},{}}),{2,0}); Verify(Dimensions({{},{{}}}),{2}); Verify(Dimensions({{a,b},{c}}),{2}); Verify(Dimensions({{a,b},{c,d}}),{2,2}); Verify(Dimensions({{a,b},{c,d},{e,f}}),{3,2}); Verify(Dimensions({{a,b,c},{d,e,f},{g,h,i}}),{3,3}); Verify(Dimensions({{a,b,c},{d,e,f}}),{2,3}); Verify(Dimensions({{{a,b}},{{c,d}}}), {2,1,2}); Verify(Dimensions({{{{a},{b}}},{{{c},d}}}),{2,1,2}); Verify(Dimensions({{{{{a,b}}}},{{{c,d}}}}),{2,1,1}); Verify(Dimensions({{{{{a,b}}}},{{{c},{d}}}}),{2,1}); Verify(Dimensions({{{}}}),{1,1,0}); Verify(Dimensions({{{a}}}),{1,1,1}); Verify(Dimensions({{{{a}}},{{{b}}}}),{2,1,1,1}); Verify(Dimensions({{{{a},{b}}},{{{c},{d}}}}),{2,1,2,1}); Verify(Dimensions({{{{a,b}}},{{{c,d}}}}),{2,1,1,2}); Verify(Dimensions({{{{a,b}},{{c,d}}}}),{1,2,1,2}); Verify(Dimensions({{{{{{a,b},{c}}}}},{{{d},{e,f,g}}}}), {2,1}); ////// ////// mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/numbers.mpt0000644000175000017500000001163111234730336023260 0ustar giovannigiovanni f():=[]; //Echo(CurrentLine()); Verify( CatalanNumber(6), 132 ); f(); Verify( CatalanNumber(10), 16796 ); f(); Testing("Integer logarithms and roots"); Verify(IntLog(23^45, 67), 33); f(); Verify(IntLog(1, 67), 0); f(); Verify(IntLog(2, 67), 0); f(); Verify(IntLog(0, 67), 0); f(); Verify(IntLog(1, 1), Undefined); f(); Verify(IntLog(2, 1), Undefined); f(); Verify(IntLog(256^8, 4), 32); f(); Verify(IntLog(256^8-1, 4), 31); f(); Verify(IntNthRoot(65537^33, 11), 281487861809153); f(); Testing("Factorial"); Verify(261! - 261*260!, 0); f(); Verify(300! / 250!, 251***300); f(); Verify(Repunit(3), 111 ); f(); Verify(HarmonicNumber(5), 137/60 ); f(); Verify( Subfactorial(0), 1 ); f(); Verify( Subfactorial(21), 18795307255050944540 ); f(); Verify( Divisors(180), 18 ); f(); Verify( IsAmicablePair(200958394875 ,209194708485 ), True ); f(); Verify( IsAmicablePair(220,284),True ); f(); Verify( IsComposite(100), True ); f(); Verify( IsComposite(1), False ); f(); Verify( IsComposite(37), False ); f(); Verify( IsTwinPrime(71), True ); f(); Verify( IsTwinPrime(1), False ); f(); Verify( IsTwinPrime(22), False ); f(); Verify( DigitalRoot(18), 9 ); f(); Verify( DigitalRoot(15), 6 ); f(); Verify( IsIrregularPrime(37), True ); f(); Verify( IsIrregularPrime(59), True ); f(); Verify( IsIrregularPrime(1), False ); f(); Verify( IsIrregularPrime(11), False ); f(); Verify( Gcd( 324 + 1608*I, -11800 + 7900*I ),Complex(-52,16) ); f(); // I changed from Complex(-4,4) to Complex(4,4) as the GaussianGcd algorithm suddenly returned this instead. // However, as it turned out it was a bug in FloorN, introduced when // we moved to the new number classes (so the numbers did not get converted // to string and back any more). The number got prematurely truncated with // this test case (regression test added to regress.yts also). Verify( Gcd( 7300 + 12*I, 2700 + 100*I), Complex(-4,4) ); f(); VerifyGaussianGcd(x,y):= [ Local(gcd); gcd:=Gcd(x,y); // Echo(x/gcd); // Echo(y/gcd); Verify(IsGaussianInteger(x/gcd) And IsGaussianInteger(y/gcd),True); ]; VerifyGaussianGcd(324 + 1608*I, -11800 + 7900*I); VerifyGaussianGcd(7300 + 12*I, 2700 + 100*I); VerifyGaussianGcd(120-I*200,-336+50*I); //TODO we can expand this with randomized tests Verify( Lcm({7,11,13,17}), 7*11*13*17 ); f(); Verify( IsCoprime(11,13), True ); f(); Verify( IsCoprime(1 .. 10), False ); f(); Verify( IsCoprime({9,40}), True ); f(); Verify( IsCarmichaelNumber( {561,1105,1729,2465,2821,6601,8911} ),{True,True,True,True,True,True,True} ); f(); Verify( IsCarmichaelNumber( {0,1,2,1727,2463,2823,6603} ),{False,False,False,False,False,False,False} ); f(); Verify(IsSmallPrime(137),True); f(); Verify(IsSmallPrime(138),False); f(); Verify(IsSmallPrime(65537),True); f(); Verify(IsSmallPrime(65539),False); f(); Verify(IsPrime(65539),True); f(); Verify(RabinMiller(1037),False); f(); Verify(RabinMiller(1038),False); f(); Verify(RabinMiller(1039),True); f(); Verify(NextPrime(65537), 65539); f(); Verify(NextPrime(97192831),97192841); f(); Verify(NextPrime(14987234876128361),14987234876128369); f(); Verify(IsPrime(0),False); f(); Verify(IsPrime(-1),False); f(); Verify(IsPrime(1),False); f(); Verify(IsPrime(2),True); f(); Verify(IsPrime(3),True); f(); Verify(IsPrime(4),False); f(); Verify(IsPrime(5),True); f(); Verify(IsPrime(6),False); f(); Verify(IsPrime(7),True); f(); Verify(IsPrime(-60000000000),False); f(); Verify(IsPrime(6.1),False); f(); Testing("Random numbers"); Local(r1, r2, r3, x1, x2, x3); r1:=RngCreate(); // create a default RNG object, return structure f(); r2:=RngCreate(12345); // create RNG object with given seed f(); RandomSeed(12345); // initialize the global RNG with the same seed f(); r3:=RngCreate(seed->12345, engine->advanced, dist->gauss); // test advanced options f(); Rng(r1); f(); Rng(r1); f(); x1:=Rng(r2); f(); Verify(x1, Random()); f(); x2:=Rng(r2); f(); x3:=Rng(r3); f(); Verify(Rng(r3)=x3, False); f(); Verify(x1=x2, False); f(); RngSeed(r2, 12345); f(); Verify(Rng(r2), x1); // reproducible number Verify(Rng(r2), x2); // reproducible number RngSeed(r3, 12345); Verify(Rng(r3), x3); // reproducible number f(); Verify(PartitionsP(1),1); f(); Verify(PartitionsP(2),2); f(); Verify(PartitionsP(3),3); f(); Verify(PartitionsP(4),5); f(); Verify(PartitionsP(13),101); f(); // This takes about 18 seconds, useful for benchmarking //Verify( PartitionsP(4096), 6927233917602120527467409170319882882996950147283323368445315320451 ); Verify(Euler(16),19391512145); f(); Verify(EulerArray(8), {1,0,-1,0,5,0,-61,0,1385}); f(); Verify(JacobiSymbol(165,1), 1); f(); Verify(JacobiSymbol(1,3), 1); f(); Verify(JacobiSymbol(1,13), 1); f(); Verify(JacobiSymbol(2,15), 1); f(); Verify(JacobiSymbol(3,15), 0); f(); Verify(JacobiSymbol(7,15), -1); f(); Verify(JacobiSymbol(3,7), -1); f(); Verify(JacobiSymbol(0,3), 0); f(); Verify(JacobiSymbol(0,1), 1); f(); Verify(JacobiSymbol(1323132412,31312317), -1); f(); Verify(JacobiSymbol(57173571,1976575123), 1); f(); Verify(JacobiSymbol(-3,5), -1); f(); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/calculus.mpt0000644000175000017500000001206511641706064023425 0ustar giovannigiovannif():=[];//Echo(CurrentFile()," line ",CurrentLine()); Testing("UnaryFunctionInverses"); Verify(Sin(ArcSin(a)),a); f(); Verify(Cos(ArcCos(a)),a); f(); //TODO ??? Verify(Tan(ArcTan(a)),a); //TODO ??? this is not always the correct answer! Verify(ArcTan(Tan(a)),a); Verify(Tan(Pi/2),Infinity); f(); Verify(Tan(Pi),0); f(); Verify( Limit(x,Infinity) Sin(x), Undefined ); f(); Verify( Limit(x,Infinity) Cos(x), Undefined ); f(); Verify( Limit(x,Infinity) Tan(x), Undefined ); f(); Verify( Limit(x,Infinity) Gamma(x), Infinity ); f(); Verify( Limit(x,Infinity) Abs(x), Infinity ); f(); Verify( Limit(x,Infinity) x!, Infinity); f(); Verify( Sin(x)/Cos(x), Tan(x) ); f(); Verify( TrigSimpCombine(Sin(x)^2 + Cos(x)^2), 1 ); f(); Verify( Sinh(x)-Cosh(x), Exp(-x)); f(); Verify( Sinh(x)+Cosh(x), Exp(x) ); f(); Verify( Sinh(x)/Cosh(x), Tanh(x) ); f(); Verify( Sinh(Infinity), Infinity); f(); Verify( Sinh(x)*Csch(x), 1); f(); Verify( 1/Coth(x), Tanh(x) ); f(); Verify(2+I*3,Complex(2,3)); f(); Verify(Magnitude(I+1),Sqrt(2)); f(); Verify(Re(2+I*3),2); f(); Verify(Im(2+I*3),3); f(); // Shouldn't these be in linalg.yts? Verify(ZeroVector(3),{0,0,0}); f(); Verify(BaseVector(2,3),{0,1,0}); f(); Verify(Identity(3),{{1,0,0},{0,1,0},{0,0,1}}); f(); Testing("Derivatives"); Verify(Differentiate(x) a,0); f(); Verify(Differentiate(x) x,1); f(); Verify(Differentiate(x) (x+x),2); f(); Verify(Differentiate(x) (x*x),2*x); f(); Verify(Differentiate(x) Differentiate(x) Sin(x),-Sin(x)); f(); Testing("Limits"); Verify( Limit(x,0,Right) Ln(x)*Sin(x), 0 ); f(); KnownFailure( Limit(k,Infinity) ((k-phi)/k)^(k+1/2) = Exp(-phi) ); f(); // tests adapted from mpreduce Verify(Limit(x,0)Sin(x)/x, 1); Verify(Limit(x,0)Sin(x)^2/x, 0); Verify(Limit(x,1)Sin(x)/x, Sin(1)); /* This is actually a tricky one - for complex it should bring infinity but for real it's undefined. BTW, reduce seems to get it wrong */ Verify(Limit(x,0)1/x, Undefined); Verify(Limit(x,0)(Sin(x)-x)/x^3, -1/6); Verify(Limit(x,Infinity)x*Sin(1/x), 1); /* reduce seems to get it wrong */ Verify(Limit(x,0)Sin(x)/x^2, Undefined); Verify(Limit(x,Infinity)x^2*Sin(1/x), Infinity); // tests adapted from mpreduce Verify(Limit(x,2)x^2-6*x+4,-4); Verify(Limit(x,-1)(x+3)*(2*x-1)/(x^2+3*x-2), 3/2); Verify(Limit(h,0)(Sqrt(4+h)-2)/h, 1/4); Verify(Limit(x,4)(Sqrt(x)-2)/(4-x), -1/4); Verify(Limit(x,2)(x^2-4)/(x-2), 4); Verify(Limit(x,-1)1/(2*x-5), -1/7); Verify(Limit(x,1)Sqrt(x)/(x+1), 1/2); Verify(Limit(x,Infinity)(2*x+5)/(3*x-2), 2/3); Verify(Limit(x,1)(1/(x+3)-2/(3*x+5))/(x-1), 1/32); Verify(Limit(x,0)Sin(3*x)/x, 3); Verify(Limit(x,0)(1-Cos(x))/x^2, 1/2); Verify(Limit(x,0)(6*x-Sin(2*x))/(2*x+3*Sin(4*x)), 2/7); Verify(Limit(x,0)(1-2*Cos(x)+Cos(2*x))/x^2, -1); Verify(Simplify(Limit(x,0)(3*Sin(Pi*x) - Sin(3*Pi*x))/x^3), 4*Pi^3); Verify(Limit(x,0)(Cos(a*x)-Cos(b*x))/x^2, (-a^2 + b^2)/2); Verify(Limit(x,0)(Exp(x)-1)/x, 1); Verify(Limit(x,0)(a^x-b^x)/x, Ln(a) - Ln(b)); // tests adapted from mpreduce Verify(Limit(x,0)Sinh(2*x)^2/Ln(1+x^2), 4); // The limit seems to hang mathpiper //Verify(Limit(x,Infinity)x^2*(Exp(1/x)-1)*(Ln(x+2)-Ln(x)),2); // another tricky problem with the result depending on the sign of // alpha; I'm not sure how we should deal with it //Limit(x,Infinity)x^alpha*Ln(x+1)^2/Ln(x); Verify(Limit(x,0)(2*Cosh(x)-2-x^2)/Ln(1+x^2)^2, 1/12); Verify(Limit(x,0)(x*Sinh(x)-2+2*Cosh(x))/(x^4+2*x^2), 1); Verify(Limit(x,0)(2*Sinh(x)-Tanh(x))/(Exp(x)-1), 1); Verify(Limit(x,0)x*Tanh(x)/(Sqrt(1-x^2)-1), -2); Verify(Limit(x,0)(2*Ln(1+x)+x^2-2*x)/x^3, 2/3); Verify(Limit(x,0)(Exp(5*x)-2*x)^(1/x), Exp(3)); Verify(Limit(x,Infinity)Ln(Ln(x))/Ln(x)^2, 0); // tests adapted from mpreduce Verify(Limit(x,0)(Exp(x)-1)/x, 1); Verify(Limit(x,1)((1-x)/Ln(x))^2, 1); Verify(Limit(x,0)x/(Exp(x)-1), 1); Verify(Limit(x,0)x/Ln(x), 0); Verify(Limit(x,Infinity)Ln(1+x)/Ln(x), 1); Verify(Limit(x,Infinity)Ln(x)/Sqrt(x), 0); Verify(Limit(x,0,Right)Sqrt(x)/Sin(x), Infinity); Verify(Limit(x,0)x*Ln(x), 0); Verify(Limit(x,0)Ln(x)/Ln(2*x), 1); Verify(Limit(x,0)x*Ln(x)*(1+x), 0); Verify(Limit(x,Infinity)Ln(x)/x,0); Verify(Limit(x,Infinity)Ln(x)/Sqrt(x),0); Verify(Limit(x,Infinity)Ln(x), Infinity); Verify(Limit(x,0)Ln(x+1)/Sin(x), 1); // Seems to hang mathpiper //Verify(Limit(x,0)Ln(x+1/x)*Sin(x), 0); Verify(Limit(x,0)-Ln(1+x)*(x+2)/Sin(x), -2); Verify(Limit(x,Infinity)Ln(x+1)^2/Sqrt(x), 0); Verify(Limit(x,Infinity)(Ln(x+1)-Ln(x)), 0); Verify(Limit(x,Infinity)-Ln(x+1)^2/Ln(Ln(x)), -Infinity); // Verify argument checking [ Verify(Limit(n, Infinity) 2 + 11/n, 2); Local(n, exception); n := 5; exception := False; ExceptionCatch(Limit(n, Infinity) 2 + 11/n, exception := True); Verify(exception, True); ]; [ Local(z); // This function satisfies Laplaces eqn: Differentiate(x,2)z + Differentiate(y,2)z = 0 z:= ArcTan((2*x*y)/(x^2 - y^2)); f(); Verify(Simplify((Differentiate(x,2) z) + Differentiate(y,2) z), 0 ); ]; Testing("Pslq"); VerifyPslq(left,right):= [ If(left=right, Verify(True,True), `Verify(@left,-(@right))); ]; VerifyPslq(Pslq({ Pi+2*Exp(1) , Pi , Exp(1) },20),{1,-1,-2}); f(); VerifyPslq(Pslq({ 2*Pi+3*Exp(1) , Pi , Exp(1) },20),{1,-2,-3}); f(); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/scopestack.mpt0000644000175000017500000000131511074042175023741 0ustar giovannigiovanni LocalSymbols(st) [ st:=NewStack(); Verify(IsOnStack(st,"c"),False); PushStackFrame(st,fenced); AddToStack(st,"a"); AddToStack(st,"b"); Verify(IsOnStack(st,"a"),True); Verify(IsOnStack(st,"c"),False); Verify(FindOnStack(st,"a"),{}); FindOnStack(st,"b")["set"]:=True; Verify(FindOnStack(st,"b"),{{"set",True}}); PushStackFrame(st,unfenced); AddToStack(st,"c"); Verify(IsOnStack(st,"c"),True); Verify(IsOnStack(st,"a"),True); PopStackFrame(st); PushStackFrame(st,fenced); AddToStack(st,"c"); Verify(IsOnStack(st,"c"),True); Verify(IsOnStack(st,"a"),False); PopStackFrame(st); PopStackFrame(st); Verify(StackDepth(st),0); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/io.mpt0000644000175000017500000000353311320713454022214 0ustar giovannigiovanniTesting("Error reporting"); // generate no errors Verify(IsError(), False); Verify(IsError("testing"), False); Verify(Assert("testing") 1=1, True); Verify(IsError(), False); Verify(IsError("testing"), False); Verify(Assert("testing1234", {1,2,3,4}) 1=1, True); Verify(IsError(), False); Verify(IsError("testing"), False); Verify(IsError("testing1234"), False); Verify(PipeToString()DumpErrors(), ""); // generate some errors Verify(Assert("testing") 1=0, False); Verify(IsError(), True); Verify(IsError("testing"), True); Verify(IsError("testing1234"), False); Verify(Assert("testing1234", {1,2,3,4}) 1=0, False); Verify(IsError(), True); Verify(IsError("testing"), True); Verify(IsError("testing1234"), True); // report errors Verify(PipeToString()DumpErrors(), "Error: testing Error: testing1234: {1, 2, 3, 4} "); // no more errors now Verify(IsError(), False); Verify(IsError("testing"), False); Verify(IsError("testing1234"), False); // generate some more errors Verify(Assert("testing") 1=0, False); Verify(Assert("testing1234", {1,2,3,4}) 1=0, False); Verify(GetError("testing1234567"), False); // handle errors Verify(GetError("testing"), True); Verify(IsError(), True); Verify(IsError("testing"), True); Verify(IsError("testing1234"), True); Verify(ClearError("testing"), True); Verify(IsError(), True); Verify(IsError("testing"), False); Verify(IsError("testing1234"), True); // no more "testing" error Verify(ClearError("testing"), False); Verify(IsError(), True); Verify(IsError("testing"), False); Verify(IsError("testing1234"), True); Verify(GetError("testing1234"), {1,2,3,4}); Verify(IsError(), True); Verify(IsError("testing"), False); Verify(IsError("testing1234"), True); Verify(ClearError("testing1234"), True); Verify(IsError(), False); Verify(IsError("testing"), False); Verify(IsError("testing1234"), False); Verify(ClearError("testing1234"), False); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/orthopoly.mpt0000644000175000017500000000225611133333737023651 0ustar giovannigiovanniNextTest("Testing orthogonal polynomials"); /* Symbolic calculations */ TestMathPiper(OrthoG(3, 1/5, x), 88/125*x^3-12/25*x); TestMathPiper(OrthoG(9, 1/2, x), 12155/128*x^9-6435/32*x^7+9009/64*x^5-1155/32*x^3+315/128*x); TestMathPiper(OrthoH(4, x), 16*x^4-48*x^2+12); TestMathPiper(OrthoH(10, x), 1024*x^10-23040*x^8+161280*x^6-403200*x^4+302400*x^2-30240); TestMathPiper(OrthoL(4, 1/3, x), x^4/24-13/18*x^3+65/18*x^2-455/81*x+455/243); TestMathPiper(OrthoP(3,1/2,5/2,x), 21/2*x^3-7*x^2-35/16*x+7/8); TestMathPiper(OrthoP(7,x), (429*x^7-693*x^5+315*x^3-35*x)/16); TestMathPiper(OrthoT(15, x), 16384*x^15-61440*x^13+92160*x^11-70400*x^9+28800*x^7-6048*x^5+560*x^3-15*x); TestMathPiper(OrthoU(16, x), 65536*x^16-245760*x^14+372736*x^12-292864*x^10+126720*x^8-29568*x^6+3360*x^4-144*x^2+1); /* Numerical calculations */ TestMathPiper(OrthoP(100, 1), 1); TestMathPiper(OrthoL(50,5/3,5/2), 956329424993407752478497541911420551314045339353541114044036291602395886513403153686689293955/143232645897909553890691033589829981069003266848814603996731044282564768594296559565258358784); TestMathPiper(OrthoP(15,1/7,1/9,2/3), 3891107589471727673898835091294644097395/16032477875245178148605931130545427636128); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/matrixpower.mpt0000644000175000017500000000267511074042175024175 0ustar giovannigiovanni////// // test for MatrixPower (dr) ////// Testing("-- MatrixPower"); //Verify(MatrixPower(,),); Verify(MatrixPower(a,0),Hold(MatrixPower(a,0))); Verify(MatrixPower(a,n),Hold(MatrixPower(a,n))); Verify(MatrixPower({a},0),Hold(MatrixPower({a},0))); Verify(MatrixPower({a},n),Hold(MatrixPower({a},n))); Verify(MatrixPower({{a}},0),{{1}}); Verify(MatrixPower({{a}},1),{{a}}); Verify(MatrixPower({{a}},-1),{{1/a}}); Verify(MatrixPower({{a}},3/5),Hold(MatrixPower({{a}},3/5))); Verify(MatrixPower({{a}},10),{{a^10}}); Verify(MatrixPower({{a}},-10),{{1/a^10}}); Verify(MatrixPower({{a}},n),Hold(MatrixPower({{a}},n))); Verify(MatrixPower({{1,2},{3,4}},0),{{1,0},{0,1}}); Verify(MatrixPower({{1,2},{3,4}},1),{{1,2},{3,4}}); Verify(MatrixPower({{1,2},{3,4}},2),{{7,10},{15,22}}); Verify(MatrixPower({{1,2},{3,4}},3),{{37,54},{81,118}}); Verify(MatrixPower({{1,2},{3,4}},4),{{199,290},{435,634}}); Verify(MatrixPower({{1,2},{3,4}},5),{{1069,1558},{2337,3406}}); Verify(MatrixPower({{1,2},{3,4}},7),{{30853,44966},{67449,98302}}); Verify(MatrixPower({{1,2},{3,4}},13),{{741736909,1081027478},{1621541217,2363278126}}); Verify(MatrixPower({{1,2},{3,4}},-1),{{-2,1},{3/2,-1/2}}); Verify(MatrixPower({{1,2},{3,4}},-2),{{11/2,-5/2},{-15/4,7/4}}); Verify(MatrixPower({{1,2},{3,4}},-3),{{-59/4,27/4},{81/8,-37/8}}); Verify(MatrixPower({{1,2},{3,4}},-4),{{317/8,-145/8},{-435/16,199/16}}); Verify(MatrixPower({{1,2},{3,4}},-5),{{-1703/16,779/16},{2337/32,-1069/32}}); ////// ////// mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/trace.mpt0000644000175000017500000000216611074042175022705 0ustar giovannigiovanni////// // $Id: trace.yts,v 1.2 2006/03/26 12:49:15 ayalpinkus Exp $ // Tests for Trace ////// Testing("-- Trace"); Verify(Trace(a),Hold(Trace(a))); Verify(Trace({}),0); Verify(Trace({a,b}),a+b); Verify(Trace({{}}),0); Verify(Trace({{a}}),a); Verify(Trace({{},a}),{}); Verify(Simplify(Trace({{a},b})-{a+b}),{0}); Verify(Trace({{},{}}),0); Verify(Trace({{},{{}}}),Hold({}+{{}})); // bug in list addition? Verify(Trace({{a,b},{c}}),Hold({a,b}+{c})); // bug in list addition? Verify(Trace({{a,b},{c,d}}),a+d); Verify(Trace({{a,b},{c,d},{e,f}}),a+d); Verify(Trace({{a,b,c},{d,e,f},{g,h,i}}),a+e+i); Verify(Trace({{a,b,c},{d,e,f}}),a+e); Verify(Trace({{{a,b}},{{c,d}}}),a); Verify(Trace({{{{a},{b}}},{{{c},d}}}),{a}); Verify(Trace({{{{{a,b}}}},{{{c,d}}}}),{{a,b}}); Verify(Trace({{{{{a,b}}}},{{{c},{d}}}}),{{{a,b}}}); Verify(Trace({{{}}}),0); Verify(Trace({{{a}}}),a); Verify(Trace({{{{a}}},{{{b}}}}),a); Verify(Trace({{{{a},{b}}},{{{c},{d}}}}),a); Verify(Trace({{{{a,b}}},{{{c,d}}}}),a); Verify(Trace({{{{a,b}},{{c,d}}}}),a); Verify(Trace({{{{{{a,b},{c}}}}},{{{d},{e,f,g}}}}),{{{{a, b}, {c}}}}); ////// ////// mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/complex.mpt0000644000175000017500000000112011133333737023246 0ustar giovannigiovanniVerify( Limit(z,2*I) (I*z^4+3*z^2-10*I), Complex(-12,6) ); KnownFailure( (Limit(n,Infinity) (n^2*I^n)/(n^3+1)) = 0 ); Verify( Limit(n,Infinity) n*I^n, Undefined ); Verify(1/I, -I); Verify(I^2, -1); Verify(2/(1+I), 1-I); Verify(I^3, -I); Verify(I^4, 1); Verify(I^5, I); Verify(1^I, 1); Verify(0^I, Undefined); Verify(I^(-I), Exp(Pi/2)); Verify((1+I)^33, 65536+I*65536); Verify((1+I)^(-33), (1-I)/131072); Verify(Exp(I*Pi), -1); TestMathPiper((a+b*I)*(c+d*I), (a*c-b*d)+I*(a*d+b*c)); Verify(Ln(-1), I*Pi); Verify(Ln(3+4*I), Ln(5)+I*ArcTan(4/3)); Verify(Re(2*I-4), -4); Verify(Im(2*I-4), 2); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/binaryfactors.mpt0000644000175000017500000000360111317314530024445 0ustar giovannigiovanni TestPoly(poly,requiredResult):= [ //Echo(poly); Local(realResult); realResult:=BinaryFactors(poly); Verify(Length(realResult),Length(requiredResult)); //Echo(requiredResult,realResult); Local(intersection); intersection:={}; ForEach(item1,requiredResult) ForEach(item2,realResult) [ If(Simplify(item1-item2) = {0,0}, intersection := (item1:intersection)); ]; Verify(Length(realResult),Length(intersection/*Intersection(requiredResult,realResult)*/)); Verify(Simplify(poly-FW(realResult)),0); ]; // Simple factorizations TestPoly((x+1)*(x-1),{{x+1,1},{x-1,1}}); // Simple with multiple factors TestPoly((x+1)^2,{{x+1,2}}); // Test: term with lowest power not zero power TestPoly(x^2*(x+1)*(x-1),{{x,2},{x+1,1},{x-1,1}}); TestPoly(x^3*(x+1)*(x-1),{{x,3},{x+1,1},{x-1,1}}); // Variable different from x TestPoly((y+1)*(y-1),{{y+1,1},{y-1,1}}); // Test from Wester 1994 test TestPoly(Differentiate(x)(x+1)^20,{{20,1},{x+1,19}}); // From regression test, and verify that polys with unfactorizable parts works TestPoly((x^6-1),{{x^4+x^2+1,1},{x+1,1},{x-1,1}}); // Non-monic polynomials TestPoly((x+13)^2*(3*x-5)^3,{{27,1},{x+13,2},{x-5/3,3}}); TestPoly((x+13)^2*(4*x-5)^3,{{64,1},{x+13,2},{x-5/4,3}}); // Heavy: binary coefficients TestPoly((x+1024)*(x+2048),{{x+1024,1},{x+2048,1}}); TestPoly((x+1024)^2*(x+2048)^3,{{x+1024,2},{x+2048,3}}); TestPoly((16*x+1024)*(x+2048),{{16,1},{x+64,1},{x+2048,1}}); TestPoly((x+1024)*(x+2047),{{x+1024,1},{x+2047,1}}); TestPoly((x+1024)*(x+2049),{{x+1024,1},{x+2049,1}}); TestPoly((x+1024)*(x-2047),{{x+1024,1},{x-2047,1}}); TestPoly((x-1024)*(x+2047),{{x-1024,1},{x+2047,1}}); TestPoly((x-1024)*(x-2047),{{x-1024,1},{x-2047,1}}); // Rational coefficients TestPoly((x+4/7)*(x-5/9),{{x+4/7,1},{x-5/9,1}}); // More than two factors ;-) TestPoly((x+1)*(x-2)*(x+3)*(x-4)*(x+5)*(x-6),{{x+1,1},{x-2,1},{x+3,1},{x-4,1},{x+5,1},{x-6,1}}); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/sums.mpt0000644000175000017500000003366211552552161022605 0ustar giovannigiovanni Verify(Product(i,1,3,i),6); Verify( Sum(k,1,n,k), n*(n+1)/2 ); Verify( Simplify(Sum(k,1,n,k^3)), Simplify( (n*(n+1))^2 / 4 ) ); Verify( Sum(k,1,Infinity,1/k^2), Zeta(2) ); Verify( Sum(k,1,Infinity,1/k), Infinity ); Verify( Sum(i,1,Infinity,1/i), Infinity ); Verify( Sum(k,1,Infinity,Sqrt(k)), Infinity ); Verify( Sum(k,2,Infinity,x^k/k!), Exp(x)-(x+1) ); Verify( Sum(k,1,n,Sin(a)+Sin(b)+p),(Sin(a)+Sin(b)+p)*n ); Verify(Add({1,2,3,4}), 10); Verify(Add({1}), 1); Verify(Add({}), 0); Verify(Add(1,2,3,4), 10); Verify(Add(1), 1); Verify(Add(), Add()); [ Local(list); list:={1,2,3,4,5}; Verify(Add(list)/Length(list), 3); list:={0}; Verify(Add(list)/Length(list), 0); list:={}; Verify(Add(list)/Length(list), Undefined); ]; Verify(Minimum(0,1),0); Verify(Minimum({}), Undefined); Verify(Minimum({x}), x); Verify(Minimum(x), x); Verify(Minimum(Exp(x)), Exp(x)); Verify(Minimum({1,2,3}), 1); // since Minimum(multiple args) is disabled, comment this out Verify(Minimum(1,2,3), 1); Verify(Minimum(1,2,0), 0); Verify(Minimum(5,2,3,4), 2); Verify(Minimum(5,2,0,4), 0); // ------------------------------------------------------------ Testing("Taylor"); // Black-box testing Verify(Taylor2(x,0,9) Sin(x), x - x^3/6 + x^5/120 - x^7/5040 + x^9/362880); Verify(Taylor2(x,0,6) Cos(x), 1 - x^2/2 + x^4/24 - x^6/720); Verify(Taylor2(x,0,6) Exp(x), 1 + x + x^2/2 + x^3/6 + x^4/24 + x^5/120 + x^6/720); Verify(Taylor2(x,1,6) 1/x, 1 - (x-1) + (x-1)^2 - (x-1)^3 + (x-1)^4 - (x-1)^5 + (x-1)^6); Verify(Taylor2(x,1,6) Ln(x), (x-1) - (x-1)^2/2 + (x-1)^3/3 - (x-1)^4/4 + (x-1)^5/5 - (x-1)^6/6); Verify(Taylor2(x,0,6) x/(Exp(x)-1), 1 - x/2 + x^2/12 - x^4/720 + x^6/30240); Verify(Taylor2(x,0,6) Sin(x)^2+Cos(x)^2, 1); TestMathPiper(Taylor2(x,0,14) Sin(Tan(x)) - Tan(Sin(x)), -1/30*x^7 - 29/756*x^9 - 1913/75600*x^11 - 95/7392*x^13); TestMathPiper((Taylor2(t,a+1,2) Exp(c*t)), Exp(c*(a+1)) + c*Exp(c*(a+1))*(t-a-1) + c^2*Exp(c*(a+1))*(t-a-1)^2/2); // Consistency checks TestMathPiper(Taylor2(x,0,7) (Sin(x)+Cos(x)), (Taylor2(x,0,7) Sin(x)) + (Taylor2(x,0,7) Cos(x))); TestMathPiper(Taylor2(x,0,7) (a*Sin(x)), a * (Taylor2(x,0,7) Sin(x))); TestMathPiper(Taylor2(x,0,7) (Sin(x)-Cos(x)), (Taylor2(x,0,7) Sin(x)) - (Taylor2(x,0,7) Cos(x))); TestMathPiper(Taylor2(x,0,7) (Sin(x)*Cos(x)), Taylor2(x,0,7) ((Taylor2(x,0,7) Sin(x)) * (Taylor2(x,0,7) Cos(x)))); TestMathPiper(Taylor2(x,0,7) (Sin(x)/Ln(1+x)), Taylor2(x,0,7) ((Taylor2(x,0,8) Sin(x)) / Taylor2(x,0,8) Ln(1+x))); TestMathPiper(Taylor2(t,0,7) (Sin(t)^2), Taylor2(t,0,7) ((Taylor2(t,0,7) Sin(t))^2)); TestMathPiper(Taylor2(x,0,7) Cos(Ln(x+1)), Taylor2(x,0,7) (Subst(y,Taylor2(x,0,7)Ln(x+1)) Cos(y))); 100 # Taylor'LPS'CompOrder(_x, jn(_x)) <-- 5; 100 # Taylor'LPS'CompCoeff(_x, jn(_x), _k) <-- ToAtom("jn":ToString(k)); Verify(Taylor2(t,0,8) jn(t), jn5*t^5 + jn6*t^6 + jn7*t^7 + jn8*t^8); Verify((Taylor2(x,0,10) Exp(jn(x))), 1 + jn5*x^5 + jn6*x^6 + jn7*x^7 + jn8*x^8 + jn9*x^9 + (jn10+jn5^2/2)*x^10); // Some examples of power series LocalSymbols(p1,p2,p3,p4,p0,pj,pp,pju0,pj40,pj50,pj51,pj52,pj53,pj54,pc24,pc35,pc46,pc57,pc68) [ p1 := Taylor'LPS(0, {1,1,1/2,1/6}, x, Exp(x)); p2 := Taylor'LPS(1, {1,0,-1/6,0,1/120,0}, t, Sin(t)); p3 := Taylor'LPS(0, {a0,a1,a2,a3}, x, foo(x)); p4 := Taylor'LPS(-2, {1,0,-1/2,0,1/24}, x, Cos(x)/x^2); p0 := Taylor'LPS(Infinity, {}, x, 0); // special case: zero // Taylor'LPS should not evaluate Verify(p1, Hold(Taylor'LPS(0, {1,1,1/2,1/6}, x, Exp(x)))); // Taylor'LPS'Coeffs can get pre-computed coefficients Verify(Taylor'LPS'Coeffs(p1, 0, 3), {1,1,1/2,1/6}); Verify(Taylor'LPS'Coeffs(p1, -3, -1), {0,0,0}); Verify(Taylor'LPS'Coeffs(p2, -1, 3), {0,0,1,0,-1/6}); Verify(Taylor'LPS'Coeffs(p3, 0, 3), {a0,a1,a2,a3}); Verify(Taylor'LPS'Coeffs(p4, -1, 1), {0,-1/2,0}); Verify(Taylor'LPS'Coeffs(p0, 1, 5), {0,0,0,0,0}); // Conversion to power series Verify(Taylor'LPS'PowerSeries(p1, 3, x), 1+x+x^2/2+x^3/6); Verify(Taylor'LPS'PowerSeries(p2, 4, t), t-t^3/6); Verify(Taylor'LPS'PowerSeries(p3, 3, s), a0+a1*s+a2*s^2+a3*s^3); Verify({Taylor'LPS'PowerSeries(p4, 2, x), ClearError("singularity")}, {Undefined, True}); Verify(Taylor'LPS'PowerSeries(p0, 3, x), 0); // Construction of new LPS Verify(Taylor'LPS'Construct(x, 1), Taylor'LPS(Undefined, {}, x, 1)); // Taylor'LPS'Coeffs can compute new coefficients in-place Verify(Taylor'LPS'Coeffs(p1, 0, 4), {1,1,1/2,1/6,1/24}); Verify(p1, Taylor'LPS(0, {1,1,1/2,1/6,1/24}, x, Exp(x))); p1 := Taylor'LPS(0, {1,1,1/2,1/6}, x, Exp(x)); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, 1), 0, 7), {1, 0, 0, 0, 0, 0, 0, 0}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, 0), 0, 7), {0, 0, 0, 0, 0, 0, 0, 0}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, 1/x), 0, 7), {0, 0, 0, 0, 0, 0, 0, 0}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, x^2), 0, 7), {0, 0, 1, 0, 0, 0, 0, 0}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, Exp(x)), 0, 7), {1, 1, 1/2, 1/6, 1/24, 1/120, 1/720, 1/5040}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, Ln(1+x)), 0, 7), {0, 1, -1/2, 1/3, -1/4, 1/5, -1/6, 1/7}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, Sin(x)), 0, 7), {0, 1, 0, -1/6, 0, 1/120, 0, -1/5040}); Verify(Taylor'LPS'Coeffs(Taylor'LPS'Construct(x, Cos(x)), 0, 7), {1, 0, -1/2, 0, 1/24, 0, -1/720, 0}); // Check order of power series Verify(Taylor'LPS'GetOrder(p1), {0,True}); Verify(Taylor'LPS'GetOrder(Taylor'LPS'Construct(x, Cos(x))), {0,True}); Verify(Taylor'LPS'GetOrder(Taylor'LPS'Construct(x, Sin(x))), {1,True}); Verify(Taylor'LPS'GetOrder(Taylor'LPS'Construct(x, x-Sin(x))), {1,False}); Verify(Taylor'LPS'GetOrder(Taylor'LPS'Construct(x, 1/x)), {-1,True}); // User-defined power series pju0 := Taylor'LPS(Undefined, {}, x, jn(x)); pj40 := Taylor'LPS(5, {}, x, jn(x)); pj50 := Taylor'LPS(5, {}, x, jn(x)); pj51 := Taylor'LPS(5, {jn5}, x, jn(x)); pj52 := Taylor'LPS(5, {jn5,jn6}, x, jn(x)); pj53 := Taylor'LPS(5, {jn5,jn6,jn7}, x, jn(x)); pj54 := Taylor'LPS(5, {jn5,jn6,jn7,jn8}, x, jn(x)); pc24 := {0,0,0}; pc35 := {0,0,jn5}; pc46 := {0,jn5,jn6}; pc57 := {jn5,jn6,jn7}; pc68 := {jn6,jn7,jn8}; tlc(_a,_b,_c) <-- Taylor'LPS'Coeffs(a,b,c); // abbreviation pj := FlatCopy(pju0); Verify(tlc(pj,2,4), pc24); Verify(pj, pj50); pj := FlatCopy(pju0); Verify(tlc(pj,3,5), pc35); Verify(pj, pj51); pj := FlatCopy(pju0); Verify(tlc(pj,4,6), pc46); Verify(pj, pj52); pj := FlatCopy(pju0); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pju0); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj40); Verify(tlc(pj,2,4), pc24); Verify(pj, pj50); pj := FlatCopy(pj40); Verify(tlc(pj,3,5), pc35); Verify(pj, pj51); pj := FlatCopy(pj40); Verify(tlc(pj,4,6), pc46); Verify(pj, pj52); pj := FlatCopy(pj40); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pj40); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj50); Verify(tlc(pj,2,4), pc24); Verify(pj, pj50); pj := FlatCopy(pj50); Verify(tlc(pj,3,5), pc35); Verify(pj, pj51); pj := FlatCopy(pj50); Verify(tlc(pj,4,6), pc46); Verify(pj, pj52); pj := FlatCopy(pj50); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pj50); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj51); Verify(tlc(pj,2,4), pc24); Verify(pj, pj51); pj := FlatCopy(pj51); Verify(tlc(pj,3,5), pc35); Verify(pj, pj51); pj := FlatCopy(pj51); Verify(tlc(pj,4,6), pc46); Verify(pj, pj52); pj := FlatCopy(pj51); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pj51); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj52); Verify(tlc(pj,2,4), pc24); Verify(pj, pj52); pj := FlatCopy(pj52); Verify(tlc(pj,3,5), pc35); Verify(pj, pj52); pj := FlatCopy(pj52); Verify(tlc(pj,4,6), pc46); Verify(pj, pj52); pj := FlatCopy(pj52); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pj52); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj53); Verify(tlc(pj,2,4), pc24); Verify(pj, pj53); pj := FlatCopy(pj53); Verify(tlc(pj,3,5), pc35); Verify(pj, pj53); pj := FlatCopy(pj53); Verify(tlc(pj,4,6), pc46); Verify(pj, pj53); pj := FlatCopy(pj53); Verify(tlc(pj,5,7), pc57); Verify(pj, pj53); pj := FlatCopy(pj53); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); pj := FlatCopy(pj54); Verify(tlc(pj,2,4), pc24); Verify(pj, pj54); pj := FlatCopy(pj54); Verify(tlc(pj,3,5), pc35); Verify(pj, pj54); pj := FlatCopy(pj54); Verify(tlc(pj,4,6), pc46); Verify(pj, pj54); pj := FlatCopy(pj54); Verify(tlc(pj,5,7), pc57); Verify(pj, pj54); pj := FlatCopy(pj54); Verify(tlc(pj,6,8), pc68); Verify(pj, pj54); // Addition pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'Add(FlatCopy(p1), FlatCopy(p3))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {1+a0,1+a1,1/2+a2,1/6+a3}); Verify(pp, Taylor'LPS(0, {1+a0,1+a1,1/2+a2,1/6+a3}, x, Taylor'LPS'Add(p1,p3))); pp := Taylor'LPS(0, {1+a0}, x, Taylor'LPS'Add(FlatCopy(p1), FlatCopy(p3))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {1+a0,1+a1,1/2+a2,1/6+a3}); Verify(pp, Taylor'LPS(0, {1+a0,1+a1,1/2+a2,1/6+a3}, x, Taylor'LPS'Add(p1,p3))); pp := Taylor'LPS'Construct(x, 1+Ln(x+1)); Verify(Taylor'LPS'Coeffs(pp, 0, 4), {1, 1, -1/2, 1/3, -1/4}); Verify(pp, Taylor'LPS(0, {1,1,-1/2,1/3,-1/4}, x, Taylor'LPS'Add(pp2,pp1)) Where {pp1 == Taylor'LPS(0, {1,0,0,0,0}, x, 1), pp2 == Taylor'LPS(1, {1,-1/2,1/3,-1/4}, x, Ln(x+1))}); pp := Taylor'LPS'Construct(a, Exp(a)+jn(a)); Verify(Taylor'LPS'Coeffs(pp, -1, 5), {0, 1, 1, 1/2, 1/6, 1/24, 1/120+jn5}); Verify(pp, Taylor'LPS(0, {1, 1, 1/2, 1/6, 1/24, 1/120+jn5}, a, Taylor'LPS'Add(pp1,pp2)) Where {pp1 == Taylor'LPS(0, {1,1,1/2,1/6,1/24,1/120}, a, Exp(a)), pp2 == Taylor'LPS(5, {jn5}, a, jn(a))}); // Scalar multiplication pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'ScalarMult(5, FlatCopy(p1))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {5,5,5/2,5/6}); Verify(pp, Taylor'LPS(0, {5,5,5/2,5/6}, x, Taylor'LPS'ScalarMult(5,p1))); pp := Taylor'LPS(0, {5,5}, x, Taylor'LPS'ScalarMult(5, FlatCopy(p1))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {5,5,5/2,5/6}); Verify(pp, Taylor'LPS(0, {5,5,5/2,5/6}, x, Taylor'LPS'ScalarMult(5,p1))); pp := Taylor'LPS'Construct(t, (-2)*Sin(t)); Verify(Taylor'LPS'Coeffs(pp, -1, 4), {0, 0, -2, 0, 1/3, 0}); Verify(pp, Taylor'LPS(1, {-2,0,1/3,0}, t, Taylor'LPS'ScalarMult(-2, pp1)) Where pp1 == Taylor'LPS(1, {1,0,-1/6,0}, t, Sin(t))); // Subtraction pp := Taylor'LPS'Construct(x, Exp(x)-Cos(x)); // zero order term cancels! Verify(Taylor'LPS'Coeffs(pp, 0, 4), {0, 1, 1, 1/6, 0}); Verify(pp, Taylor'LPS(1, {1,1,1/6,0}, x, Taylor'LPS'Add(pp1, pp2)) Where pp1 == Taylor'LPS(0, {1,1,1/2,1/6,1/24}, x, Exp(x)) Where pp2 == Taylor'LPS(0, {-1,0,1/2,0,-1/24}, x, Taylor'LPS'ScalarMult(-1, pp3)) Where pp3 == Taylor'LPS(0, {1,0,-1/2,0,1/24}, x, Cos(x))); // Multiplication pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'Multiply(FlatCopy(p1), FlatCopy(p3))); Verify(Taylor'LPS'Coeffs(pp, 0, 2), {a0, a1+a0, a2+a1+1/2*a0}); Verify(pp, Taylor'LPS(0, {a0, a1+a0, a2+a1+1/2*a0}, x, Taylor'LPS'Multiply(p1,p3))); pp := Taylor'LPS(0, {a0}, x, Taylor'LPS'Multiply(FlatCopy(p1), FlatCopy(p3))); Verify(Taylor'LPS'Coeffs(pp, 0, 2), {a0, a1+a0, a2+a1+1/2*a0}); Verify(pp, Taylor'LPS(0, {a0, a1+a0, a2+a1+1/2*a0}, x, Taylor'LPS'Multiply(p1,p3))); pp := Taylor'LPS'Construct(x, x^2*Ln(x+1)); Verify(Taylor'LPS'Coeffs(pp, 0, 4), {0, 0, 0, 1, -1/2}); Verify(pp, Taylor'LPS(3, {1,-1/2}, x, Taylor'LPS'Multiply(pp1,pp2)) Where {pp1 == Taylor'LPS(2, {1,0}, x, x^2), pp2 == Taylor'LPS(1, {1,-1/2}, x, Ln(x+1))}); // Inversion pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'Inverse(FlatCopy(p1))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {1,-1,1/2,-1/6}); Verify(pp, Taylor'LPS(0, {1,-1,1/2,-1/6}, x, Taylor'LPS'Inverse(p1))); pp := Taylor'LPS(Undefined, {}, t, Taylor'LPS'Inverse(FlatCopy(p2))); Verify(Taylor'LPS'Coeffs(pp, 0, 2), {0,1/6,-0}); Verify(pp, Taylor'LPS(-1, {1,0,1/6,0}, t, Taylor'LPS'Inverse(p2))); pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'Inverse(FlatCopy(p0))); Verify([Taylor'LPS'Coeffs(pp, 0, 0); ClearError("div-by-zero");], True); pp := Taylor'LPS'Construct(x, 1/jn(x)); Verify(Taylor'LPS'Coeffs(pp, -7, -4), {0,0,1/jn5,-jn6/jn5^2}); Verify(pp, Taylor'LPS(-5, {1/jn5,-jn6/jn5^2}, x, Taylor'LPS'Inverse(pp1)) Where pp1 == Taylor'LPS(5, {jn5,jn6}, x, jn(x))); pp := Taylor'LPS'Construct(x, 1/(Cos(x)^2+Sin(x)^2-1)); Verify([Taylor'LPS'Coeffs(pp, 0, 5); ClearError("maybe-div-by-zero");], True); // Division pp := Taylor'LPS'Construct(x, Exp(x)/Cos(x)); Verify(Taylor'LPS'Coeffs(pp, 0, 4), {1, 1, 1, 2/3, 1/2}); Verify(pp, Taylor'LPS(0, {1,1,1,2/3,1/2}, x, Taylor'LPS'Multiply(pp1, pp2)) Where pp1 == Taylor'LPS(0, {1,1,1/2,1/6,1/24}, x, Exp(x)) Where pp2 == Taylor'LPS(0, {1,0,1/2,0,5/24}, x, Taylor'LPS'Inverse(pp3)) Where pp3 == Taylor'LPS(0, {1,0,-1/2,0,1/24}, x, Cos(x))); // Raising to a natural power // No tests (Taylor'LPS'Power is not implemented yet) // Composition Verify(Taylor'LPS'Construct(x, Ln(Sin(x))), Taylor'LPS(Undefined, {}, x, Taylor'LPS'Compose(pp1,pp2)) Where {pp1 == Taylor'LPS(Undefined, {}, x, Ln(x)), pp2 == Taylor'LPS(1, {}, x, Sin(x))}); Verify(Taylor'LPS'Construct(x, Ln(Cos(x))), Taylor'LPS(Undefined, {}, x, Taylor'LPS'Compose(pp1,pp2)) Where {pp1 == Taylor'LPS(Undefined, {}, x, Ln(1+x)), pp2 == Taylor'LPS(Undefined, {}, x, Taylor'LPS'Add(pp3,pp4)), pp3 == Taylor'LPS(0, {1}, x, Cos(x)), pp4 == Taylor'LPS(Undefined, {}, x, -1)}); pp := Taylor'LPS(Undefined, {}, x, Taylor'LPS'Compose(FlatCopy(p1), FlatCopy(p2))); Verify(Taylor'LPS'Coeffs(pp, 0, 3), {1, 1, 1/2, 0}); Verify(pp, Taylor'LPS(0, {1,1,1/2,0}, x, Taylor'LPS'Compose(p1,p2))); ]; // LocalSymbols(p*) mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/arithmetic.mpt0000644000175000017500000000744111507302740023737 0ustar giovannigiovanni NextTest("Test arithmetic"); NextTest("Basic calculations"); Verify(3 + 2 , 5); Verify(3-7, -4); Verify(1 = 2 , 0 = -1); Verify(5 ^ 2 , 25); Verify(IsZero(0.000),True); Verify(2/5,Hold(2/5)); Verify(IsZero(N(2/5)-0.4)); Verify(IsRational(2),True); Verify(IsRational(2/5),True); Verify(IsRational(-2/5),True); Verify(IsRational(2.0/5),False); Verify(IsRational(Pi/2),False); Verify(Numerator(2/5),2); Verify(Denominator(2/5),5); VerifyArithmetic(10,5,8); VerifyArithmetic(10000000000,5,8); VerifyArithmetic(10,50,80); VerifyArithmetic(10000,50,88); Verify(4!,24); Verify(BinomialCoefficient(2,1),2); NextTest("Testing math stuff"); Verify(1*a,a); Verify(a*1,a); Verify(0*a,0); Verify(a*0,0); Verify(aa-aa,0); Verify(2+3,5); Verify(2*3,6); Verify(2+3*4,14); Verify(3*4+2,14); Verify(3*(4+2),18); Verify((4+2)*3,18); Verify(15/5,3); Verify(-2+3,1); Verify(-2.01+3.01,1.); Verify(0+a,a); Verify(a+0,a); Verify(aa-aa,0); Testing("IntegerOperations"); Verify(1<<10,1024); Verify(1024>>10,1); Verify(Modulo(10,3),1); Verify(Quotient(10,3),3); Verify(GcdN(55,10),5); Verify(Modulo(2,Infinity),2); Verify(Modulo({0,1,2,3,4,5,6},2),{0,1,0,1,0,1,0}); Verify(Modulo({0,1,2,3,4,5,6},{2,2,2,2,2,2,2}),{0,1,0,1,0,1,0}); Testing("PowerN"); // was broken in the gmp version Verify(PowerN(19, 0), 1); Verify(PowerN(1, -1), 1); Verify(PowerN(1, -2), 1); Verify(IsZero(PowerN(10, -2)- 0.01)); Verify(PowerN(2, 3), 8); NumericEqual(PowerN(2, -3), 0.125,BuiltinPrecisionGet()); Testing("Rounding"); Verify(Floor(1.2),1); Verify(Floor(-1.2),-2); Verify(Ceil(1.2),2); Verify(Ceil(-1.2),-1); Verify(Round(1.49),1); Verify(Round(1.51),2); Verify(Round(-1.49),-1); Verify(Round(-1.51),-2); Testing("Bases"); Verify(ToBase(16,255),"ff"); Verify(FromBase(2,"100"),4); // conversion between decimal and binary digits Verify(BitsToDigits(2000, 10), 602); Verify(DigitsToBits(602, 10), 2000); LocalSymbols(f,ft) [ f(x,y):=(Quotient(x,y)*y+Rem(x,y)-x); ft(x,y):= [ Verify(f(x,y),0); Verify(f(-x,y),0); Verify(f(x,-y),0); Verify(f(-x,-y),0); ]; ft(10,4); ft(2.5,1.2); ]; Testing("Factorization"); Verify( Eval(Factors(447738843)) , {{3,1},{17,1},{2729,1},{3217,1}} ); //Exponential notation is now supported in the native arithmetic library too... Verify(2e3+1,2001.); Verify(2.0e3+1,2001.); Verify(2.00e3+1,2001.); Verify(2.000e3+1,2001.); Verify(2.0000e3+1,2001.); Verify(1+2e3,2001.); Verify(1+2.0e3,2001.); Verify(1+2.00e3,2001.); Verify(1+2.000e3,2001.); Verify(1+2.0000e3,2001.); NumericEqual(N(Sqrt(1e4))-100,0,BuiltinPrecisionGet()); NumericEqual(N(Sqrt(1.0e4))-100,0,BuiltinPrecisionGet()); Verify(2.0000e3-1,1999.); [ Local(p); p:=BuiltinPrecisionGet(); BuiltinPrecisionSet(12);//TODO this will fail if you drop precision to below 12, for some reason. NumericEqual(RoundToPrecision(10e3*1.2e-3,BuiltinPrecisionGet()),12.,BuiltinPrecisionGet()); BuiltinPrecisionSet(p); ]; Verify((10e3*1.2e-4)-1.2,0); Verify(IsZero(N(Sin(0.1e1)-Sin(1),30)),True); [ /* In Dutch they have a saying "dit verdient geen schoonheidsprijs" ;-) We need to sort this out. * But a passable result, for now. */ Local(diff); diff := N(Sin(10e-1)-Sin(1),30); //BuiltinPrecisionSet(20); //Echo("diff = ",diff); //Echo("diff > -0.00001 = ",diff > -0.00001); //Echo("diff < 0.00001 = ",diff < 0.00001); Verify(diff > -0.00001 And diff < 0.00001,True); ]; /* Jonathan reported a problem with Simplify(-Sqrt(8)/2), which returned some * complex expression containing greatest common divisors of square roots. * This was fixed by adding some rules dealing with taking the gcd of two objects * where at least one is a square root. */ Verify(-Sqrt(8)/2,-Sqrt(2)); Verify(Sqrt(8)/2,Sqrt(2)); Verify(Gcd(Sqrt(2),Sqrt(2)),Sqrt(2)); Verify(Gcd(-Sqrt(2),-Sqrt(2)),Sqrt(2)); Verify(Gcd(Sqrt(2),-Sqrt(2)),Sqrt(2)); Verify(Gcd(-Sqrt(2),Sqrt(2)),Sqrt(2)); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/cyclotomic.mpt0000644000175000017500000000034711074042175023753 0ustar giovannigiovanniNextTest("Cyclotomic Polynomials"); Verify(Cyclotomic(1,x),x-1); Verify(Cyclotomic(5,x),x^4+x^3+x^2+x+1); Verify(Cyclotomic(8,z),z^4+1); Verify(Cyclotomic(10,y),y^4-y^3+y^2-y+1); Verify(Cyclotomic(15,x),x^8-x^7+x^5-x^4+x^3-x+1); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/tensors.mpt0000644000175000017500000000222111321250634023270 0ustar giovannigiovanni NextTest("Tensors"); TestMathPiper(TSimplify( TSum({j}) Delta(i,j)*v(j) ),v(i)); TestMathPiper(TSimplify( TSum({j,i}) Delta(i,j)*Delta(i,j) ), Ndim); TestMathPiper(TSimplify( TSum({j,i}) Delta(i,j)*Delta(j,i) ), Ndim); TestMathPiper(TSimplify( TSum({j}) Delta(i,j)*Delta(j,k) ), Delta(i,k)); TestMathPiper(TSimplify( TSum({i}) v(i)*v(i) ), TSum({i})(v(i)^2)); Retract("v",1); Rulebase("v",{ii}); f(i,j):=v(i)*v(j); TestMathPiper(f(i,i),v(i)^2); TestMathPiper(TSimplify( TSum({i}) f(i,i) ),TSum({i})(v(i)^2)); TestMathPiper(TSimplify( TSum({j}) Delta(i,j)*f(j,k) ),v(i)*v(k)); TestMathPiper(TSimplify(TSum({i,j}) Delta(i,j)*f(i,j) ), TSum({j})v(j)^2); TestMathPiper(TSimplify(TSum({i})X(j)*TD(i)X(i)), Ndim*X(j)); TestMathPiper(TSimplify(TSum({i}) TD(i)(X(i)*X(j)) ), Ndim*X(j)+X(j)); TestMathPiper(TSimplify(TSum({i}) X(i)*TD(i)X(j) ), X(j)); TestMathPiper(TSimplify(TSum({i})TD(i)v(i)), TSum({i})TD(i)v(i)); TestMathPiper(TSimplify(TSum({i,j})TD(i)TD(j)(X(i)*X(j))), Ndim+Ndim^2); TestMathPiper(TSimplify(TSum({i})TD(i)(X(i)*X(j)*X(j))), Ndim*X(j)^2+2*X(j)^2); TestMathPiper(TSimplify(TSum({i,j,k})TD(i)TD(j)TD(k)(X(i)*X(j)*X(k))), 3*Ndim^2+2*Ndim+Ndim^3); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/outer.mpt0000644000175000017500000000105611074042175022742 0ustar giovannigiovanni////// // $Id: outer.yts,v 1.2 2006/03/26 12:49:15 ayalpinkus Exp $ // Tests for Outer ////// Testing("-- Outer"); Verify(Outer({},{}),{}); Verify(Outer({{}},{}),Hold(Outer({{}},{}))); Verify(Outer({},{{}}),Hold(Outer({},{{}}))); Verify(Outer({{}},{{}}),Hold(Outer({{}},{{}}))); Verify(Outer(a,b),Hold(Outer(a,b))); Verify(Outer({a},{b}),{{a*b}}); Verify(Outer({a,b},{c}),{{a*c},{b*c}}); Verify(Outer({a},{b,c}),{{a*b,a*c}}); Verify(Outer({a,b},{c,d,e}),{{a*c,a*d,a*e},{b*c,b*d,b*e}}); Verify(Outer({a,b,c},{d,e}),{{a*d,a*e},{b*d,b*e},{c*d,c*e}}); ////// mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/macro.mpt0000644000175000017500000000233311321250634022700 0ustar giovannigiovanni [ Local(a,b,c,d); DefMacroRulebase(foo,{a,b}); // Simple check foo(_c,_d) <-- {@c,@d}; Verify(foo(2,3),Hold({2,3})); Macro("foo",{a}) {@a,a}; a:=A; Verify(foo(B),{B,A}); Retract(foo,1); Retract(foo,2); Verify(foo(2,3),foo(2,3)); Verify(foo(B),foo(B)); ]; [ Local(a,i,tot); a:=100; Retract(forloop,4); Macro(forloop,{init,pred,inc,body}) [ @init; While(@pred) [ @body; @inc; ]; True; ]; tot:=0; forloop(i:=1,i<=10,i++,tot:=tot+a*i); Verify(i,11); Verify(tot,5500); ]; [ Macro("bar",{list,...}) Length(@list); Verify(bar(a,b,list,bar,list),5); ]; [ Local(x,y,z); y:=x; Verify(`{@x,@y},{x,x}); z:=u; y:={@z,@z}; Verify(`{@x,@y},{x,{@z,@z}}); Verify(`{@x,`(@y)},{x,{@u,@u}}); y:=Hold(`{@z,@z}); Verify(`{@x,@y},{x,{u,u}}); Verify(`{@x,`(@y)},{x,{u,u}}); ]; // check that a macro can reach a local from the calling environment. [ Macro(foo,{x}) a*(@x); Function(bar,{x}) [ Local(a); a:=2; foo(x); ]; Verify(bar(3),6); ]; //check that with nested backquotes expansion only expands the top-level expression [ Local(a,b); a:=2; b:=3; Verify( `[ Local(c); c:=@a+@b; `((@c)*(@c)); ],25); ]; mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/radsimp.mpt0000644000175000017500000000115311133333737023244 0ustar giovannigiovannif():=Echo(CurrentFile()," line ",CurrentLine()); NextTest("Testing simplifying nested radicals"); TestMathPiper(RadSimp(Sqrt(9+4*Sqrt(2))), 1+Sqrt(8)); TestMathPiper(RadSimp(Sqrt(5+2*Sqrt(6))+Sqrt(5-2*Sqrt(6))),Sqrt(12)); TestMathPiper(RadSimp(Sqrt(14+3*Sqrt(3+2*Sqrt(5-12*Sqrt(3-2*Sqrt(2)))))), 3+Sqrt(2)); TestMathPiper(RadSimp(Sqrt(3+2*Sqrt(2))),1+Sqrt(2)); TestMathPiper(RadSimp(Sqrt(5+2*Sqrt(6))),Sqrt(2)+Sqrt(3)); //FAILS??? TestMathPiper(RadSimp(Sqrt(5*Sqrt(3)+6*Sqrt(2))),Sqrt(Sqrt(27))+Sqrt(Sqrt(12))); //??? TestMathPiper(RadSimp(Sqrt(12+2*Sqrt(6)+2*Sqrt(14)+2*Sqrt(21))),Sqrt(2)+Sqrt(3)+Sqrt(7)); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/sturm.mpt0000644000175000017500000000622311357461233022763 0ustar giovannigiovanni/* TESTS: - random-test code for roots, be generating random roots and multiplicities. - find an example where bisection is needed, or better, a group of examples where bisection is needed, for tests - GarbageCollect in TryRandomPoly causes some corruption, as is visible when turning show file/line on. */ BuiltinPrecisionSet(5); VerifyZero(x) := (Abs(x)<10^ -BuiltinPrecisionGet()); sl() := []; //Echo(CurrentFile(),CurrentLine()); TryRandomPoly(deg,coefmin,coefmax):= [ //GarbageCollect(); Local(coefs,p,roots,px); coefs:=Table(FloorN(coefmin+Random()*(coefmax-coefmin)),i,1,deg+1,1); p:=Add(coefs*x^(0 .. deg)); p:=Rationalize(p); //Echo("Test polynom ",p); Verify(Maximum(Abs(coefs))<=MaximumBound(p)); Verify(Minimum(Abs(coefs))>MinimumBound(p)); //Echo("bounds ",BoundRealRoots(p)); roots:=FindRealRoots(p); //Echo("roots ",roots); px := (p Where x==x); Verify(Dot(px, px) < 0.01); ]; TryRandomRoots(deg,coefmin,coefmax):= [ //GarbageCollect(); Local(coefs,p,roots,px,mult); coefs:=RemoveDuplicates(Table(FloorN(coefmin+Random()*(coefmax-coefmin)),i,1,deg+1,1)); deg:=Length(coefs)-1; mult:=1+Abs(Table(FloorN(coefmin+Random()*(coefmax-coefmin)),i,1,deg+1,1)); p:=Product((x-coefs)^mult); p:=Rationalize(p); Echo("Test polynom ",p); Echo("minimum ",MinimumBound(p)); Echo("maximum ",MaximumBound(p)); Echo("bounds ",BoundRealRoots(p)); roots:=FindRealRoots(p); Echo("roots ",roots); Verify(Length(roots) = Length(coefs)); Verify(Length(RemoveDuplicates(roots)) = Length(coefs)); px := (p Where x==x); Verify(Dot(px, px) < 0.01); ]; sl(); [ Local(p); p := FindRealRoots((x+2)^9*(x-4)^5*(x-1)^4)-{-2.,1.,4.}; Verify(VerifyZero(Dot(p,p)),True); ]; sl(); /*TODO TryRandomRoots(3,-10,10); sl(); TryRandomRoots(3,-10,10); sl(); TryRandomRoots(5,5,1000); sl(); TryRandomRoots(5,5,1000); sl(); */ // Bounds on coefficients Verify(MinimumBound(4),-Infinity); sl(); Verify(MaximumBound(4),Infinity); sl(); // RealRootsCount Verify(RealRootsCount(x^2-1),2); sl(); Verify(RealRootsCount(x^2+1),0); sl(); [ Local(p); p:=Difference(FindRealRoots(Expand((x*(x-10)^3*(x+2)^2))),{0,-2.,10.}); Verify(VerifyZero(Dot(p, p)),True); ]; Verify(FindRealRoots((x^2+20)*(x^2+10)),{}); Verify(RealRootsCount((x^2+20)*(x^2+10)),0); sl(); // Simple test on Squarefree TestMathPiper(Monic(SquareFree((x-1)^2*(x-3)^3)),Monic((x-1)*(x-3))); sl(); // Check the rare case where the bounds finder lands on // exactly a root [ Local(p); p:=FindRealRoots((x+4)*(x-6),1,7)-{-4.,6.}; Verify(VerifyZero(Dot(p, p)),True); ]; sl(); [ Local(p); p:=Expand((x-3.1)*(x+6.23)); p:=FindRealRoots(p)-{-6.23,3.1}; Verify(VerifyZero(Dot(p, p)),True); ]; sl(); Verify(BuiltinPrecisionGet(),5); [ Local(res); res:=FindRealRoots(Expand((x-3.1)*(x+6.23)))-{-6.23,3.1}; Verify(VerifyZero(Dot(res, res)) , True); ]; sl(); TryRandomPoly(5,5,1000); sl(); sl(); TryRandomPoly(5,5,1000); sl(); sl(); TryRandomPoly(5,5,1000); sl(); sl(); TryRandomPoly(5,5,1000); sl(); sl(); TryRandomPoly(5,5,1000); sl(); sl(); TryRandomPoly(5,5,1000); sl(); sl(); //RandomPoly(_var,_degree,_coefmin,_coefmax) //RandomIntegerList(_count,_coefmin,_coefmax) mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/openmath.mpt0000644000175000017500000000047511320713454023422 0ustar giovannigiovanni NextTest("Converting to and from OpenMath expressions"); Macro(OMTest1,{expr}) [ Local(string,result); string:=PipeToString() OMForm(@expr); result:=PipeFromString(string)OMRead(); // Echo(Hold(@expr),`Hold(@result)); Verify(Hold(@expr),`Hold(@result)); ]; OMTest1(2+3); OMTest1(2*a+3*Sin(Cos(a*x+b))); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/programming.mpt0000644000175000017500000000234511331203122024113 0ustar giovannigiovanni Testing("Apply"); Verify(Apply("+",{2,3}),5); [ Local(x,y); Verify(Apply({{x,y},x+y},{2,3}),5); Verify(Apply(Lambda({x,y},x+y),{2,3}),5); Verify(Lambda({x,y},x+y) @ {2,3},5); /* Basically the next line is to check that {{x},Length(x)} * behaves in an undesirable way (Length being evaluated * prematurely), so that the next test can then check that * Lambda solves the problem. */ Verify(Apply({{x},Length(x)},{"aaa"}),Length); Verify(Apply(Lambda({x},Length(x)),{"aaa"}),3); Verify(x,x); Verify(y,y); Testing("ThreadingListables"); x:={bb,cc,dd}; Verify(Sin(aa*x),{Sin(aa*bb),Sin(aa*cc),Sin(aa*dd)}); ]; Testing("MapSingle"); Verify(MapSingle("!",{1,2,3,4}),{1,2,6,24}); /* Example: using the for function. */ Function("count",{from,to}) [ Local(i); Local(sum); Bind(sum,0); For(i:=from,i B) And A), (Not A Or B)And A); Verify(CNF((A And B) And A), (A And B) And A); Verify(CNF(Not (A And B) And A), (Not A Or Not B) And A); Verify(CanProve((A Or B) And Not A), B And Not A); Verify(CanProve((A Or B) And (Not A Or C)), (A Or B) And (C Or Not A)); Verify(CanProve((B Or A) And (Not A Or C)), (A Or B) And (C Or Not A)); Verify(CanProve( A And (A Or B Or C)), A); Verify(CanProve( A And (Not A Or B Or C)), A And (B Or C)); // this is a test of contradication, A==3 should kick A==2 out as they're contradictory Verify(CanProve( A==3 And (A==2 Or B Or C)), A-3==0 And (B Or C)); //TODO Verify(CanProve( A==3 And (A<2 Or B Or C)), A-3==0 And (B Or C)); //TODO Verify(CanProve( A==3 And (A>2 Or B Or C)), (A-3==0) And (((A-2) > 0) Or B Or C)); Verify(CanProve(Not(Not (p_2-NULL==0))Or Not(p_2-NULL==0)), True); LogicTest({A},A And A, A); LogicTest({A},A And True, A); LogicTest({A},A And False, False); LogicTest({A},A Or True, True); LogicTest({A},A Or False, A); LogicTest({A},A Or Not A, True); LogicTest({A},A And Not A, False); LogicTest({A,B},(A And B) Or (A And B), A And B); LogicTest({A,B},A Or (A And B), A And(A Or B)); LogicTest({A,B},(A And B) And A, (A And B) And A); LogicTest({A,B},Not (A And B) And A, (Not A Or Not B) And A); LogicTest({A,B},(A Or B) And Not A, B And Not A); LogicTest({A,B,C},(A Or B) And (Not A Or C), (A Or B) And (C Or Not A)); LogicTest({A,B,C},(B Or A) And (Not A Or C), (A Or B) And (C Or Not A)); LogicTest({A,B,C}, A And (A Or B Or C), A); LogicTest({A,B,C}, A And (Not A Or B Or C), A And (B Or C)); LogicTest({A},CNF(A And A), A); LogicTest({A},CNF(A And True), A); LogicTest({A},CNF(A And False), False); LogicTest({A},CNF(A Or True), True); LogicTest({A},CNF(A Or False), A); LogicTest({A},CNF(A Or Not A), True); LogicTest({A},CNF(A And Not A), False); LogicTest({A,B},CNF((A And B) Or (A And B)), A And B); LogicTest({A,B},CNF(A Or (A And B)), A And(A Or B)); LogicTest({A,B},CNF((A => B) And A), (Not A Or B)And A); LogicTest({A,B},CNF((A And B) And A), (A And B) And A); LogicTest({A,B},CNF(Not (A And B) And A), (Not A Or Not B) And A); LogicTest({A,B},CanProve((A Or B) And Not A), B And Not A); LogicTest({A,B,C},CanProve((A Or B) And (Not A Or C)), (A Or B) And (C Or Not A)); LogicTest({A,B,C},CanProve((B Or A) And (Not A Or C)), (A Or B) And (C Or Not A)); LogicTest({A,B,C},CanProve( A And (A Or B Or C)), A); LogicTest({A,B,C},CanProve( A And (Not A Or B Or C)), A And (B Or C)); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/deriv.mpt0000644000175000017500000000073711133333737022725 0ustar giovannigiovanniTestMathPiper(Deriv(x)Ln(x),1/x); TestMathPiper(Deriv(x)Exp(x),Exp(x)); TestMathPiper(Deriv(x)(x^4+x^3+x^2+x+1),4*x^3+3*x^2+2*x+1); TestMathPiper(Deriv(x)Sin(x),Cos(x)); TestMathPiper(Deriv(x)Cos(x),-Sin(x)); TestMathPiper(Deriv(x)Sinh(x),Cosh(x)); TestMathPiper(Deriv(x)Cosh(x),Sinh(x)); TestMathPiper(Deriv(x)ArcCos(x),-1/Sqrt(1-x^2)); TestMathPiper(Deriv(x)ArcSin(x),1/Sqrt(1-x^2)); TestMathPiper(Deriv(x)ArcTan(x),1/(x^2+1)); TestMathPiper(Deriv(x)Sech(x),-Sech(x)*Tanh(x)); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/plots.mpt0000644000175000017500000000217411352014462022744 0ustar giovannigiovanni // some tests to verify that plotting works /* I stringified the results for now, as that is what the tests used to mean. The correct way to deal with this * would be to compare the resulting numbers to accepted precision. */ Verify(PipeToString()Write(Plot2D(a,-1:1,output->data,points->4,depth->0)), "{{{-1,-1},{-0.5,-0.5},{0,0},{0.5,0.5},{1.,1.}}}"); Verify(PipeToString()Write(Plot2D(b,b-> -1:1,output->data,points->4)), "{{{-1,-1},{-0.5,-0.5},{0,0},{0.5,0.5},{1.,1.}}}"); [ Local(result); result:="{{{-1,-1,-1},{-1,0,-1},{-1,1.,-1},{0,-1,0},{0,0,0},{0,1.,0},{1.,-1,1.},{1.,0,1.},{1.,1.,1.}}}"; Verify(PipeToString()Write(Plot3DS(a,-1:1,-1:1,output->data,points->2)), result); Verify(PipeToString()Write(Plot3DS(x1,x1 -> -1:1,x2 -> -1:1,output->data,points->2)), result); ]; // test NFunction BuiltinPrecisionSet(10); Retract("f",1); Retract("f1",1); f(x) := N(Abs(1/x-1)); Verify(f(0), Infinity); NumericEqual(RoundToN(f(3),BuiltinPrecisionGet()), 0.6666666667,BuiltinPrecisionGet()); NFunction("f1", "f", {x}); Verify(f1(0), Undefined); NumericEqual(RoundToN(f1(3),BuiltinPrecisionGet()), 0.6666666667,BuiltinPrecisionGet()); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/journal.mpt0000644000175000017500000000117711320767174023271 0ustar giovannigiovanni /* * This file contains tests to check constructs used in the * tutorials and journal entries. */ Verify(1+1,2); Verify("This text","This text"); Verify(2+3,5); Verify(3*4,12); Verify(-(3*4),-12); Verify(2+3*4,14); Verify(6/3,2); Verify(1/3,1/3); Verify(IsNumber(N(1/3)),True); Verify(Sin(Pi),0); Verify(Minimum(5,1,3,-5,10),-5); Verify(Sqrt(2),Sqrt(2)); Verify({1,2,3},{1,2,3}); Verify({a,b,c}[2],b); Verify("abc"[2],"b"); // Etcetera.... PLEASECHECK TODO fill out this file /* From derivatives example, I am using ^0.5 there because of the * fact that Yacas replaces x^(1/2) with Sqrt(x). */ Verify(x^(1/2),Sqrt(x)); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/predicates.mpt0000644000175000017500000001374511352014462023734 0ustar giovannigiovanni Testing("Predicates"); Verify(IsFunction(a(b)),True); Verify(IsFunction(a),False); Verify(IsList({a,b,c}),True); Verify(IsList(a),False); Verify(IsAtom({a,b,c}),False); Verify(IsAtom(a),True); Verify(IsAtom(123),True); Verify(IsNumber(123),True); Verify(IsNumber(123.123),True); Verify(IsNumber(a),False); Verify(IsNumber({a}),False); Verify(IsInteger(123),True); Verify(IsInteger(123.123),False); Verify(IsInteger(a),False); Verify(IsInteger({a}),False); Testing("Boolean Operations"); Verify(False And False,False); Verify(True And False,False); Verify(False And True,False); Verify(True And True,True); Verify(False Or False,False); Verify(True Or False,True); Verify(False Or True,True); Verify(True Or True,True); Verify(Not(True),False); Verify(Not(False),True); Verify(IsEqual(a,b),False); Verify(IsEqual(a,a),True); Verify(IsEqual({a,b},{a}),False); Verify(IsEqual({a,b},{a,b}),True); Testing("NumberCompares"); Verify(IsLessThan(2,3),True); Verify(IsLessThan(3,2),False); Verify(IsGreaterThan(2,3),False); Verify(IsGreaterThan(3,2),True); Verify(.1<2,True); Verify(0.1<2,True); Verify(.3<2,True); Verify(.1>2,False); Verify(0.1>2,False); Verify(.3>2,False); Verify(2<.1,False); Verify(2<0.1,False); Verify(2<.3,False); Verify(2>.1,True); Verify(2>0.1,True); Verify(2>.3,True); Testing("comparisons in exponential notation"); // some of these failed Verify(1e-5 < 1, True); Verify(1e-5 < 2e-5, True); Verify(1e-1 < 2e-1, True); Verify(1e-15 < 2e-15, True); Verify(1e-5 < 1e-10, False); Verify(1e-5 < 1e-2, True); Verify(-1e-5 < 1e-5, True); Verify(-1e-5 < 1e-6, True); Verify(1e-5 = 2e-5, False); Verify(1e-5 = 1e-6, False); Verify(1e-15 > 0, True); Verify(1e-5 > 0, True); Verify(1e-4 > 0, True); Verify(1e-3 > 0, True); Verify(1e-2 > 0, True); Verify(1e-1 > 0, True); Verify(1e5 > 0, True); BuiltinPrecisionSet(32); Verify(1.0000000000000000000000000000111 > 1, True); Verify(0.999999999999999999999999999992 < 1, True); BuiltinPrecisionSet(10); Verify(IsLessThan(-1e-115, 0), True); Verify(IsLessThan(-1e-15, 0), True); Verify(IsLessThan(-1e-10, 0), True); Verify(IsLessThan(-1e-5, 0), True); Verify(IsLessThan(-1e-1, 0), True); Testing("Matrix predicates"); Verify(IsHermitian({{0,I},{-I,0}}),True); Verify(IsHermitian({{0,I},{-I,1}}),True); Verify(IsHermitian({{0,I},{-2*I,0}}),False); Verify(IsUnitary({{0,I},{-I,0}}),True); Verify(IsUnitary({{0,I},{-I,1}}),False); Verify(IsUnitary({{0,I},{-2*I,0}}),False); Verify(IsVariable(a),True); Verify(IsVariable(Sin(a)),False); Verify(IsVariable(2),False); Verify(IsVariable(-2),False); Verify(IsVariable(2.1),False); Verify(HasExpr(a*b+1,1),True); Verify(HasExpr(a+Sin(b*c),c),True); Verify(HasExpr(a*b+1,2),False); Verify(HasExpr(a*b+f({b,c}),f),False); Verify(HasExprArith(a*b+1,ToAtom("+")),False); Verify(HasExprArith(a*b+1,1),True); Verify(HasExprArith(a+Sin(b*c),c),False); Verify(HasExprArith(a+Sin(b*c),Sin(b*c)),True); Verify(HasExprArith(a*b+f({b,c}),c),False); Verify(HasFunc(a*b+1,*),True); Verify(HasFunc(a+Sin(b*c),*),True); Verify(HasFunc(a*b+1,List),False); Verify(HasFunc(a*b+f({b,c}),List),True); Verify(HasFuncArith(a*b+1,ToAtom("+")),True); Verify(HasFuncArith(a+Sin(b*c),*),False); Verify(HasFuncArith(a+Sin(b*c),Sin),True); Verify(HasFuncArith(a*b+f({b,c}),List),False); Verify(IsGaussianInteger(3+4*I),True ); Verify(IsGaussianInteger(5),True); Verify(IsGaussianInteger(1.1), False ); Verify(IsGaussianPrime(5+2*I),True ); Verify(IsGaussianPrime(13), False ); Verify(IsGaussianPrime(0), False ); Verify(IsGaussianPrime(3.5), False ); Verify(IsGaussianPrime(2+3.1*I), False ); Verify(IsPerfect(2305843008139952128), True ); Verify(IsPerfect(137438691328),True ); Verify(IsPerfect(234325),False ); Testing("IsConstant"); Verify(IsConstant(Pi), True); Verify(IsConstant(Exp(1)+Sqrt(3)), True); Verify(IsConstant(x), False); Verify(IsConstant(Infinity), True); Verify(IsConstant(-Infinity), True); Verify(IsConstant(Undefined), True); Testing("-- IsScalar"); Verify(IsScalar(a),True); Verify(IsScalar({a}),False); Testing("-- IsVector"); Verify(IsVector(1),False); Verify(IsVector(a),False); Verify(IsVector(Sin(a)+2),False); Verify(IsVector({}),True); Verify(IsVector({{}}),False); Verify(IsVector({1,2,a,4}),True); Verify(IsVector({1,{2,a},4}),False); Verify(IsVector({{a,b,c}}),False); Testing("-- IsVector(IsNumber)"); Verify(IsVector(IsNumber,1),False); Verify(IsVector(IsNumber,{}),True); Verify(IsVector(IsNumber,{a,b,c}),False); Verify(IsVector(IsNumber,{a,2,c}),False); Verify(IsVector(IsNumber,{2,2.5,4}),True); Verify(IsVector(IsNumber,{Pi,2,3}),False); Verify(IsVector(IsNumber,{{1},{2}}),False); Testing("-- Matrix Predicates"); Testing("---- IsMatrix"); Verify(IsMatrix(1),False); Verify(IsMatrix({}),False); Verify(IsMatrix({a,b}),False); Verify(IsMatrix({{}}),True); Verify(IsMatrix({{a}}),True); Verify(IsMatrix({{{a}}}),False); Verify(IsMatrix({{},a}),False); Verify(IsMatrix({{a},b}),False); Verify(IsMatrix({{},{}}),True); Verify(IsMatrix({{{}},{}}),False); Verify(IsMatrix({{},{{}}}),False); Verify(IsMatrix({{a,b},{c}}),False); Verify(IsMatrix({{a,b},{c,d}}),True); Verify(IsMatrix({{a,b},{c,{d}}}),False); Verify(IsMatrix({{{}}}), False); Verify(IsMatrix({{{a}}}), False); Verify(IsMatrix({{{{a}}},{{{b}}}}),False); Testing("---- IsMatrix(IsInteger)"); Verify(IsMatrix(IsInteger,{{a,1}}),False); Verify(IsMatrix(IsInteger,{{1,2}}),True); Verify(IsMatrix(IsInteger,{{1,2/3}}),False); Verify(IsMatrix(IsInteger,{{1,2,3},{4,5,6}}),True); Verify(IsMatrix(IsInteger,{{1,{2},3},{4,5,6}}),False); Verify(IsMatrix(IsInteger,{{1,2,3},{4,5}}),False); Verify(IsMatrix(IsInteger,{{Sin(1),2,3},{4,5,6}}),False); Verify(IsMatrix(IsInteger,{{Sin(0),2,3},{4,5,6}}),True); Testing("---- IsSquareMatrix"); Verify(IsSquareMatrix({{}}),False); Verify(IsSquareMatrix({{a}}),True); Verify(IsSquareMatrix({{},{}}),False); Verify(IsSquareMatrix({{a,b}}),False); Verify(IsSquareMatrix({{a,b},{c,d}}),True); Verify(IsSquareMatrix({{a,b},{c,d},{e,f}}),False); Verify(IsSquareMatrix({{a,b,c},{d,e,f},{g,h,i}}),True); Verify(IsSquareMatrix({{a,b,c},{d,e,f}}),False); Verify(IsSquareMatrix({{{a,b}},{{c,d}}}), False); mathpiper-0.81f+svn4469+dfsg3/tests/scripts4/calendar.mpt0000644000175000017500000000022211554100732023344 0ustar giovannigiovanniTesting("-- Easter"); Verify(Easter(1777), {3, 30}); Verify(Easter(1961), {4, 2}); Verify(Easter(2009), {4, 12}); Verify(Easter(2011), {4, 24}); mathpiper-0.81f+svn4469+dfsg3/tests/unix_test.sh0000644000175000017500000000005211123262534021656 0ustar giovannigiovannijava -cp . org.mathpiper.test.RunTestSuitemathpiper-0.81f+svn4469+dfsg3/manifest.mf0000644000175000017500000000012211351304227020265 0ustar giovannigiovanniManifest-Version: 1.0 X-COMMENT: Main-Class will be added automatically by build mathpiper-0.81f+svn4469+dfsg3/lib/0000755000175000017500000000000011722677372016726 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/0000755000175000017500000000000011722677373021575 5ustar giovannigiovannimathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/make-c-code.red0000644000175000017500000004533711550002751024327 0ustar giovannigiovanni% make-c-code.red %************************************************************************** %* Copyright (C) 2010, Codemist Ltd. A C Norman * %* * %* Redistribution and use in source and binary forms, with or without * %* modification, are permitted provided that the following conditions are * %* met: * %* * %* * Redistributions of source code must retain the relevant * %* copyright notice, this list of conditions and the following * %* disclaimer. * %* * Redistributions in binary form must reproduce the above * %* copyright notice, this list of conditions and the following * %* disclaimer in the documentation and/or other materials provided * %* with the distribution. * %* * %* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * %* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * %* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * %* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * %* COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * %* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * %* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * %* OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * %* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * %* TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * %* THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * %* DAMAGE. * %*************************************************************************/ on echo; % This file can be run to turn bits of the REDUCE source code % into C so that this C can be compiled and linked in to make a % customised CSL executable that will red REDUCE faster. % % Run this using bootstrapreduce.img to select code to compile into C. % The functions to be compiled are extracted from a file "profile.dat" % that was created by "profile.red". % % I will also allow for a file "unprofile.dat" that can be used to provide % extra help with modules where the module maintainer is unable to provide % test cases that generate reliable profile date. % % If full_c_code is defined then rather than paying much attention % to profile.dat it attempts to compile everything into C! Note that % this capability causes BUGS to surface at present (I will remove this % comment when I believe I have got past that state!) so it is just % for hackers and experimenters. symbolic; % Three major parameters are available: % % fnames a list of files to create. Making the list longer (or % shorter) changes the amount of C that can be created. % The CSL source code has to know how many there are, and % its current default is for 12 files. % % size_per_file % this guides the compiler about how much to put in each % generated file, where the value 7000 results in each % file of generated C being in the range 120 to 150 Kbytes. % % force_count indicates how many functions from alg.tst statistics should % be included before anything else. The idea for this is % rooted in old days when alg.tst was *THE* Reduce test and % overall performance was often judged solely on how well % it ran. I will now make the value of force_count rather % small so as not to perturb more globally rational profile- % based judgements! But in fact most of the things that are % heavily used in alg.tst are used elswehere. I suspect that % these days the only exceptions will be the high energy % physics stuff. % % % Also if "how_many" is set then this will limit the total number of % functions that are compiled into C. Since I expect to pass that via a % command line "-dhow_many=362" etc I allow for it being a string % not a number to start with. In ordinary circumstances this will not be % used, however it has proved INVALUABLE when tracking down cases where % compilation into C causes changes in behaviour... how_many can be used % with a binary-chop selection process to discover exactly which function % causes upset when compiled into C. Of course in release quality code I % hope there are no such cases! global '(fnames size_per_file force_count how_many everything); if boundp 'full_c_code then everything := t else everything := nil; fnames := '( "u01" "u02" "u03" "u04" "u05" "u06" "u07" "u08" "u09" "u10" "u11" "u12" "u13" "u14" "u15" "u16" "u17" "u18" "u19" "u20" "u21" "u22" "u23" "u24" "u25" "u26" "u27" "u28" "u29" "u30" "u31" "u32" "u33" "u34" "u35" "u36" "u37" "u38" "u39" "u40" "u41" "u42" "u43" "u44" "u45" "u46" "u47" "u48" "u49" "u50" "u51" "u52" "u53" "u54" "u55" "u56" "u57" "u58" "u59" "u60" ); if boundp 'size_per_file and numberp (cx := compress explodec size_per_file) and cx > 100 and cx < 200000 then size_per_file := cx else if everything then size_per_file := 60000 else size_per_file := 7000; << terpri(); princ "size_per_file = "; print size_per_file; nil >>; % At the time of writing these are the top 5 functions used by alg.tst % % (noncomp 363494365036146324 11 285540) % (simpcar 1247942846384282646 7 167232) % (reval 607148151428708743 8 186615) % (terminalp 570814658694331872 12 229779) % (delcp 2216652391477548477 8 131682) force_count := 5; % You may well ask "what is it with the number 3500 here". Well that sets % a default number of functions to be compiled into C that matches the % number I used historically, and hence it provides a safe level of % continuity. You may experiment with % make c-code how_many=nnnn % and do so either to see how the speed/space tradeoff goes or because you % are ocncerned about a possible bug in the Lisp to C compilation step. My % current measurements suggest that 3500 gives reasonable trade off for % build of the executable vs. performance. However for use with an embedded % system with limited memort I might suggest say 500. if not boundp 'how_many then how_many := 3500 else << how_many := compress explodec how_many; if not numberp how_many then how_many := 3500 >>; << terpri(); princ "how_many = "; print how_many; nil >>; global '(omitted at_start at_end); % At any stage there may be some things that I must not even try to compile % into C because of bugs or limitations. I can list them here. omitted := '( s!:prinl0 % uses unwind-protect prinl % Ha ha - this being turned into C makes it seem % available before it really is! compile!-file!* % &optional s!:compile!-file!* % &optional fetch!-url % &optional begin % bootstrapping issue module2!-to!-file % ditto olderfaslp % ditto (some time I will investigate and % maybe fix these "bootstrapping" issues... package!-remake2 % ditto update!-fasl2 % ditto upd!-fasl1 % ditto update_prompt % ditto linelength % horrid use of copyd etc in tmprint.red setpchar % horrid use of copyd.. also in tmprint.red ordp % redefined in helphy/noncom2 and spde/spde unit % name conflict. pasf_bapprox % Unknown issue! divdm % gck2 % !:recip % cr!:minus % typerr % typerr and symerr are defined in makereduce.lsp symerr % but there are slightly versions elsewhere. fluid % the env cells of these get out of step during.. global % a bootstrap build if they are compiled here. ); % There is a bit of a mess-up if something that has been given an autoload % stub gets compiled into C so I will try to identify any such and mark % them as unsuitable for compilation. for each x in oblist() do if eqcar(d := getd(x), 'expr) and consp cdr d and consp cddr d and consp cdddr d then << d := cadddr d; if eqcar(d, 'progn) and cdr d and eqcar(cadr d, 'load!-package) then << princ "+++ "; prin x; printc " looks like an autoload stub. Omit here"; omitted := x . omitted >> >>; at_start := '( ); at_end := '( ); on comp; load!-module 'remake; % Here I need to consider the issue of patches. First consider patches that % had been in force when "profile.red" was run. In such cases a patched % function f1 has an associated replacement f1_123456789 (the numeric suffix % is a checksum on the new definition) and when the profile job was run % this replacement will have had its definition copied to f1. The way in % which CSL's mapstore function extracts counts will mean that the % thing in profile.dat relate to f1_123456789. % Usually things in profile.dat are in the form % (function_name . checksum_of_definition) % but for these patched things I will instead record % (original_function_name package_involved) % This can be distinguished because it has a symbol not a number as % the second component. To make this possible each patch function % f1_123456789 would have to have this information attached to it % when the profiling job was run. % % But I suppose have now obtained a newer version of the patches file. So % now the correct patch for f1 will be f1_abcdef. If f1 was in one of the % REDUCE core packages (eg "alg") then both the functions f1_123456789 and % f1_abcdef will be in memory now, but it will be the latter that will % have been copied to plain old f1. In other cases f1_123456789 will now % have been totally lost and the definition of f1_abcdef will be in the % patches module. Furthermore the new patches file may patch another % function f2 that had not previously been subject to patching, but % that had been selected for compilation into C. And in a truly bad % case the complete REDUCE sources will contain several functions named % f2 and of course the patches file identifies which one it is interested % in by the name of the package it is in. % % The response to all this I will use here is intended to make life % reasonably SIMPLE for me in a complicated situation. So I first % collect the set of names that I think need compiling into C. Then I % grab a list of the names of things defined in the current patches file. % If a function in the paches file has a name similar enough (!) to one that % I have already decided to compile into C then I will schedule it for % compilation into C too. Because of the hash suffix added to names in the % patches file defining a C version having those things present in the Lisp % kernel should never be a problem - after all the patches file itself is % intended to be loaded all the time. So the main down-side of this is % that I will sometimes find that I have compiled into C either patch % versions of a function when it was another version of that code that was % time-critical or that I have compiled into C two generations of % patch function. These waste opportunity and space by having some % things compiled into C that might not really justify that, but this % seems a modest cost. % Note that parts of the above may apply if the sources of REDUCE are % changed in ANY manner (not just a special patches file) but the C code % is not re-created. fluid '(w_reduce requests); w_reduce := requests := nil; % I make a list of all the functions that profile data suggests that % I should compile into C. The master copy of the profile data is % usually expected to be in "$destdir". symbolic procedure read_profile_data file; begin scalar w0, w1; if not errorp(w0 := errorset(list('open, file, ''input), nil, nil)) then << w0 := rds car w0; while not errorp (w1 := errorset('(read), nil, nil)) and not eqcar(w1, !$eof!$) do << requests := car w1 . requests; princ "Use data for "; print caar w1 >>; % The data structure read in here will be of the form % ((module-name f-name1 f_name2 ...) (module-name ...) ...) % where within each module the requested functions have been listed in % order of priority. close rds w0 >> end; off echo; read_profile_data "$destdir/profile.dat"; read_profile_data "$destdir/unprofile.dat"; on echo; if not everything then << % As a fairly shameless hack I am going to insist on compiling ALL the % things that the "alg" test uses. That is because this one test % file has been used for many years to give a single performance % figure for REDUCE. In fact it is not too bad to pay lots of % attention to it since it exercises the basic core algebra and so what is % good for it is good for quite a lot of everybody else. However by % tuning this selection process you can adjust the way REDUCE balances % its speed in different application areas. w_reduce := assoc('alg, requests)$ requests := for each x in delete(w_reduce, requests) collect cdr x$ w_reduce := reverse cdr w_reduce$ d := length w_reduce - force_count; if d > 0 then for i := 1:d do w_reduce := cdr w_reduce; length w_reduce; % Now I will merge in suggestions from all other modules in % breadth-first order of priority % Ie if I have modules A, B, C and D (with A=alg) and each has in it % functions a1, a2, a3 ... (in priority odder) then I will make up a list % here that goes % % a1 a2 a3 ... an b1 c1 d2 b2 c2 d2 b3 c3 d3 b4 c4 d4 ... % % so that the first n items from A get priority and after that B, C and D % will get about balanced treatment if I have to truncate the list at % some stage. symbolic procedure membercar(a, l); if null l then nil else if a = caar l then t else membercar(a, cdr l); fg := t; while fg do << fg := nil; for each x on requests do if car x then << if k := assoc(caaar x, w_reduce) then << if not (cadr k = cadaar x) then << prin caaar x; printc " has multiple definition"; princ " keep version with checksum: "; print cadr k; princ " ignore: "; print cadaar x; terpri() >> >> % ORDP is a special case because I have put a version of it into the % CSL kernel by hand, and any redefinition here would be unfriendly and % might clash with that. else if caaar x = 'ordp then printc "Ignoring ORDP (!)" else w_reduce := caar x . w_reduce; fg := t; rplaca(x, cdar x) >> >>; % Now I scan all pre-compiled modules to recover source versions of the % selected REDUCE functions. The values put as load!-source properties % are checksums of the recovered definitions that I would be prepared % to accept. for each n in w_reduce do put(car n, 'load!-source, cdr n); w_reduce := for each n in w_reduce collect car n$ % Discard things that give trouble... for each x in omitted do w_reduce := delete(x, w_reduce); % Compile some specific things first and others last. The ability to % override the normal priority order may be useful when I want to % force-compile some functions for testing purposes. for each x in append(at_start, at_end) do << prin x; princ " "; print get(x, '!*savedef) >>; w_reduce := append(at_start, append(nreverse w_reduce, at_end))$ for each m in library!-members() do load!-source m; % Up through Reduce 3.8 there was a mechanism for distributing patches % that could be installed to correct or upgrade a base version. In the % Open Source model it seems way easiest for people to fetch or build % a full new image, and so I am not going to deal with patches any more. >>; if everything then << % load!-source being true causes a !*savedef to be loaded for every function % in the module. Without it a definition only gets picked up if a load!-source % property has been set on the name. load!-source := t; for each m in library!-members() do load!-source m; % Hah but I really want the core versions of anything that might get redefined % to be the one left - so I will re-load all the core modules! for each m in loaded!-modules!* do load!-source m; w_reduce := nil; for each x in oblist() do if get(x, '!*savedef) and not memq(x, omitted) then w_reduce := x . w_reduce; w_reduce := nreverse w_reduce$ % Now in alphabetic order, which seems neat. for each x in at_start do w_reduce := delete(x, w_reduce); for each x in at_end do w_reduce := delete(x, w_reduce); w_reduce := append(at_start, append(w_reduce, at_end)); >>; << printc "Top 20 things to compile are..."; p := w_reduce; for i := 1:20 do if p then << print car p; p := cdr p >> >>; verbos nil; global '(rprifn!*); on fastfor, fastvector, unsafecar; symbolic procedure listsize(x, n); if null x then n else if atom x then n+1 else listsize(cdr x, listsize(car x, n+1)); << count := 0; while fnames do begin scalar name, bulk; name := car fnames; princ "About to create "; printc name; c!:ccompilestart(name, name, "$destdir", nil); bulk := 0; while bulk < size_per_file and w_reduce and how_many > 0 do begin scalar name, defn; name := car w_reduce; if null (defn := get(name, '!*savedef)) then << princ "+++ "; prin name; printc ": no saved definition found"; w_reduce := cdr w_reduce >> else << bulk := listsize(defn, bulk); if bulk < size_per_file then << count := count+1; princ count; princ ": "; c!:ccmpout1 ('de . name . cdr defn); how_many := how_many - 1; w_reduce := cdr w_reduce >> >> end; eval '(c!-end); fnames := cdr fnames end; terpri(); printc "*** End of compilation from REDUCE into C ***"; terpri(); total := count; bulk := 0; % I list the next 50 functions that WOULD get selected - just for interest. if null w_reduce then printc "No more functions need compiling into C" else while bulk < 50 and w_reduce do begin name := car w_reduce; if null (defn := get(name, '!*savedef)) then << princ "+++ "; prin name; printc ": no saved definition found"; w_reduce := cdr w_reduce >> else << bulk := bulk+1; princ (count := count+1); princ ": "; print name; w_reduce := cdr w_reduce >> end; terpri(); prin total; printc " functions compiled into C"; nil >>; quit; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/buildreduce.lsp0000644000175000017500000016171211570371306024600 0ustar giovannigiovanni% "buildreduce.lsp" % % Build a CSL REDUCE. % % Depending on how this file is used it will EITHER create a bootstrap % version of REDUCE or a full and optimised one. % % The behaviour is determined by whether the version of CSL used to % run it has a full complement of functions in the modules u01.c to u60.c. % % % bootstrapreduce -z buildreduce.lsp -D@srcdir=

% % Builds a system "bootstrapreduce.img" that does not depend on any % custom C code. The main use of this slow system is for profiling % REDUCE and then compiling the hot-spots into C. Once that has been % done this image is logically unnecessary. % % % reduce -z buildreduce.lsp -D@srcdir= % % Here the files u01.c to u60.c and u01.lsp to u60.lsp must already % have been created, and that the reduce executable has them compiled in. % The REDUCE source files that are compiled *MUST* be the same as those used % to create this C code. % Author: Anthony C. Hearn, Stanley L. Kameny and Arthur Norman (verbos 3) (window!-heading "basic CSL") (setq !*savedef (and (not (memq 'embedded lispsystem!*)) (zerop (cdr (assoc 'c!-code lispsystem!*))))) (make!-special '!*native_code) (setq !*native_code nil) (cond ((and (null !*savedef) (null (memq 'embedded lispsystem!*))) (progn (de c!:install (name env c!-version !&optional c1) (cond (c1 (check!-c!-code name env c!-version c1)) (t (progn (put name 'c!-version c!-version) (cond (env (prog (v n) (setq v (mkvect (sub1 (length env)))) (setq n 0) top (cond ((null env) (progn (put name 'funarg v) (return (symbol!-set!-env name v))))) (putv v n (car env)) (setq n (add1 n)) (setq env (cdr env)) (go top)))) name)))) (rdf "$srcdir/../../src/../cslbuild/generated-c/u01.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u02.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u03.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u04.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u05.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u06.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u07.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u08.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u09.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u10.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u11.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u12.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u13.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u14.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u15.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u16.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u17.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u18.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u19.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u20.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u21.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u22.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u23.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u24.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u25.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u26.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u27.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u28.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u29.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u30.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u31.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u32.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u33.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u34.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u35.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u36.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u37.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u38.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u39.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u40.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u41.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u42.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u43.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u44.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u45.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u46.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u47.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u48.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u49.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u50.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u51.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u52.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u53.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u54.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u55.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u56.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u57.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u58.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u59.lsp") (rdf "$srcdir/../../src/../cslbuild/generated-c/u60.lsp") ))) (rdf "$srcdir/fastgets.lsp") (rdf "$srcdir/compat.lsp") (rdf "$srcdir/extras.lsp") (rdf "$srcdir/compiler.lsp") (compile!-all) (setq !*comp t) % It's faster if we compile the boot file. % Tidy up be deleting any modules that are left over in this image (dolist (a (library!-members)) (delete!-module a)) % Build fasl files for the compatibility code and the two % versions of the compiler. (faslout 'cslcompat) (rdf "$srcdir/fastgets.lsp") (rdf "$srcdir/compat.lsp") (rdf "$srcdir/extras.lsp") (faslend) (faslout 'compiler) (rdf "$srcdir/compiler.lsp") (faslend) (setq !*comp t) (de concat (u v) (compress (cons '!" (append (explode2 u) (nconc (explode2 v) (list '!")))))) (global '(oldchan!*)) (setq prolog_file 'cslprolo) (setq rend_file 'cslrend) (setq !*argnochk t) (setq !*int nil) % Prevents input buffer being saved. (setq !*msg nil) (window!-heading "bootstrap RLISP") % This is dervived fron the Standard LISP BOOT File. % Author: Anthony C. Hearn. % Copyright (c) 1991 RAND. All Rights Reserved. (fluid '(fname!* !*blockp !*lower !*mode)) (global '(oldchan!*)) (global '(!*raise crchar!* cursym!* nxtsym!* ttype!* !$eol!$)) (put '!; 'switch!* '(nil !*semicol!*)) (put '!( 'switch!* '(nil !*lpar!*)) (put '!) 'switch!* '(nil !*rpar!*)) (put '!, 'switch!* '(nil !*comma!*)) (put '!. 'switch!* '(nil cons)) (put '!: 'switch!* '(((!= nil setq)) !*colon!*)) (put '!*comma!* 'infix 1) (put 'setq 'infix 2) (put 'cons 'infix 3) (flag '(!*comma!*) 'nary) (flag '(!*colon!* !*semicol!* end then else) 'delim) (put 'begin 'stat 'blockstat) (put 'if 'stat 'ifstat) (put 'symbolic 'stat 'procstat) (de begin2 nil (prog nil (setq cursym!* '!*semicol!*) a (cond ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil))) (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) (go a))) (de form (u) u) (de xread (u) (progn (scan) (xread1 u))) (de xread1 (u) (prog (v w x y z z2) a (setq z cursym!*) a1 (cond ((or (null (atom z)) (numberp z)) (setq y nil)) ((flagp z 'delim) (go end1)) ((eq z '!*lpar!*) (go lparen)) ((eq z '!*rpar!*) (go end1)) ((setq y (get z 'infix)) (go infx)) ((setq y (get z 'stat)) (go stat))) a3 (setq w (cons z w)) next (setq z (scan)) (go a1) lparen(setq y nil) (cond ((eq (scan) '!*rpar!*) (and w (setq w (cons (list (car w)) (cdr w)))) ) ((eqcar (setq z (xread1 'paren)) '!*comma!*) (setq w (cons (cons (car w) (cdr z)) (cdr w)))) (t (go a3))) (go next) infx (setq z2 (mkvar (car w) z)) un1 (setq w (cdr w)) (cond ((null w) (go un2)) (t (setq z2 (cons (car w) (list z2)))) ) (go un1) un2 (setq v (cons z2 v)) preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) pr1 (setq x (cons (cons y z) x)) (go next) pr2 (setq v (cons (cond ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) (cons (cdar x) (cons (cadr v) (cdar v)))) (t (cons (cdar x) (list (cadr v) (car v)))) ) (cdr (cdr v)))) (setq x (cdr x)) (go preced) stat (setq w (cons (eval (list y)) w)) (setq y nil) (go a) end1 (cond ((and (and (null v) (null w)) (null x)) (return nil)) (t (setq y 0))) (go infx) pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) (de eqcar (u v) (and (null (atom u)) (eq (car u) v))) (de mksetq (u v) (list 'setq u v)) (de mkvar (u v) u) (de rread nil (prog (x) (setq x (token)) (return (cond ((and (equal ttype!* 3) (eq x '!()) (rrdls)) (t x)))) ) (de rrdls nil (prog (x r) a (setq x (rread)) (cond ((null (equal ttype!* 3)) (go b)) ((eq x '!)) (return (reverse r))) % REVERSIP not yet defined. ((null (eq x '!.)) (go b))) (setq x (rread)) (token) (return (nconc (reverse r) x)) b (setq r (cons x r)) (go a))) (de token nil (prog (x y) (setq x crchar!*) a (cond ((seprp x) (go sepr)) ((digit x) (go number)) ((liter x) (go letter)) ((eq x '!%) (go coment)) ((eq x '!!) (go escape)) ((eq x '!') (go quote)) ((eq x '!") (go string))) (setq ttype!* 3) (cond ((delcp x) (go d))) (setq nxtsym!* x) a1 (setq crchar!* (readch)) (go c) escape(setq y (cons x y)) (setq x (readch)) letter(setq ttype!* 0) let1 (setq y (cons x y)) (cond ((or (digit (setq x (readch))) (liter x)) (go let1)) ((eq x '!!) (go escape))) (setq nxtsym!* (intern (compress (reverse y)))) b (setq crchar!* x) c (return nxtsym!*) number(setq ttype!* 2) num1 (setq y (cons x y)) (cond ((digit (setq x (readch))) (go num1))) (setq nxtsym!* (compress (reverse y))) (go b) quote (setq crchar!* (readch)) (setq nxtsym!* (list 'quote (rread))) (setq ttype!* 4) (go c) string(prog (raise !*lower) (setq raise !*raise) (setq !*raise nil) strinx(setq y (cons x y)) (cond ((null (eq (setq x (readch)) '!")) (go strinx))) (setq y (cons x y)) (setq nxtsym!* (mkstrng (compress (reverse y)))) (setq !*raise raise)) (setq ttype!* 1) (go a1) coment(cond ((null (eq (readch) !$eol!$)) (go coment))) sepr (setq x (readch)) (go a) d (setq nxtsym!* x) (setq crchar!* '! ) (go c))) (setq crchar!* '! ) (de delcp (u) (or (eq u '!;) (eq u '!$))) (de mkstrng (u) u) (de seprp (u) (or (eq u blank) (eq u tab) (eq u !$eol!$))) (de scan nil (prog (x y) (cond ((null (eq cursym!* '!*semicol!*)) (go b))) a (setq nxtsym!* (token)) b (cond ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l)) ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x)) (go b)) ((eq nxtsym!* 'comment) (go comm)) ((and (eq nxtsym!* '!') (setq cursym!* (list 'quote (rread)))) (go l1)) ((null (setq x (get nxtsym!* 'switch!*))) (go l)) ((eq (cadr x) '!*semicol!*) (return (setq cursym!* (cadr x)))) ) sw1 (setq nxtsym!* (token)) (cond ((or (null (car x)) (null (setq y (assoc nxtsym!* (car x)))) ) (return (setq cursym!* (cadr x)))) ) (setq x (cdr y)) (go sw1) comm (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm))) (go a) l (setq cursym!* (cond ((null (eqcar nxtsym!* 'string)) nxtsym!*) (t (cons 'quote (cdr nxtsym!*)))) ) l1 (setq nxtsym!* (token)) (return cursym!*))) (de ifstat nil (prog (condx condit) a (setq condx (xread t)) (setq condit (nconc condit (list (list condx (xread t)))) ) (cond ((null (eq cursym!* 'else)) (go b)) ((eq (scan) 'if) (go a)) (t (setq condit (nconc condit (list (list t (xread1 t)))) ))) b (return (cons 'cond condit)))) (de procstat nil (prog (x y) (cond ((eq cursym!* 'symbolic) (scan))) (cond ((eq cursym!* '!*semicol!*) (return (null (setq !*mode 'symbolic)))) ) (setq fname!* (scan)) (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) (setq y (xread nil)) (cond ((flagp (car x) 'lose) (return nil))) (putd (car x) 'expr (list 'lambda (cdr x) y)) (setq fname!* nil) (return (list 'quote (car x)))) ) (de blockstat nil (prog (x hold varlis !*blockp) a0 (setq !*blockp t) (scan) (cond ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar))) (go a))) (setq x (xread nil)) (setq varlis (nconc (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x))) varlis)) (go a0) a (setq hold (nconc hold (list (xread1 nil)))) (setq x cursym!*) (scan) (cond ((not (eq x 'end)) (go a))) (return (mkprog varlis hold)))) (de mkprog (u v) (cons 'prog (cons u v))) (de gostat nil (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) (put 'go 'stat 'gostat) (de rlis nil (prog (x) (setq x cursym!*) (return (list x (list 'quote (list (xread t))))))) (de endstat nil (prog (x) (setq x cursym!*) (scan) (return (list x)))) % Now we have just enough to be able to start to express ourselves in % (a subset of) rlisp. (begin2) !@reduce := concat(!@srcdir, "/../../src"); rds(xxx := open("$reduce/packages/support/build.red",'input)); (close xxx) (load!-package!-sources prolog_file 'support) (load!-package!-sources 'rlisp 'rlisp) (load!-package!-sources 'smacros 'support) (load!-package!-sources rend_file 'support) (load!-package!-sources 'poly 'poly) (load!-package!-sources 'alg 'alg) (load!-package!-sources 'arith 'arith) % Needed by roots, specfn*, (psl). (load!-package!-sources 'entry 'support) (load!-package!-sources 'remake 'support) (setq !*comp nil) (begin) symbolic; !#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) faslout 'user; % % The "user" module is only useful when building a full system, since % in the bootstrap the files u01.lsp to u60.lsp will probably not exist % and it is CERTAIN that they are not useful. % if modulep 'cslcompat then load!-module 'cslcompat; symbolic procedure c!:install(name, env, c!-version, !&optional, c1); begin scalar v, n; if c1 then return check!-c!-code(name, env, c!-version, c1); put(name, 'c!-version, c!-version); if null env then return name; v := mkvect sub1 length env; n := 0; while env do << putv(v, n, car env); n := n + 1; env := cdr env >>; % I only instate the environment if there is nothing useful there at % present. Actually this is even stronger. When a built-in function is % set up it gets NIL in its environment cell by default. Things that are % not defined at all have themselves there. if symbol!-env name = nil then symbol!-set!-env(name, v); put(name, 'funarg, v); return name; end; rdf "$srcdir/../../cslbuild/generated-c/u01.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u02.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u03.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u04.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u05.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u06.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u07.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u08.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u09.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u10.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u11.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u12.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u13.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u14.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u15.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u16.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u17.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u18.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u19.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u20.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u21.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u22.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u23.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u24.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u25.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u26.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u27.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u28.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u29.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u30.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u31.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u32.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u33.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u34.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u35.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u36.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u37.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u38.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u39.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u40.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u41.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u42.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u43.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u44.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u45.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u46.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u47.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u48.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u49.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u50.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u51.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u52.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u53.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u54.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u55.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u56.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u57.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u58.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u59.lsp"$ rdf "$srcdir/../../cslbuild/generated-c/u60.lsp"$ if modulep 'smacros then load!-module 'smacros; faslend; !#endif faslout 'remake; !#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) load!-module "user"; !#endif !@reduce := concat(!@srcdir, "/../../src"); in "$reduce/packages/support/remake.red"$ global '(reduce_base_modules reduce_extra_modules reduce_test_cases); symbolic procedure get_configuration_data(); % Read data from a configuration file that lists the modules that must % be processed. NOTE that this and the next few funtions will ONLY % work properly if REDUCE had been started up with the correct % working directory. This is (just about) acceptable because these are % system maintainance functions rather than generally flexible things % for arbitrary use. begin scalar i, w, e; % Configuration information is held in a file called something like % "package.map". if boundp 'microreduce and symbol!-value 'microreduce then i := "$srcdir/../../src/packages/micropackage.map" else if boundp 'minireduce and symbol!-value 'minireduce then i := "$srcdir/../../src/packages/minipackage.map" else i := "$srcdir/../../src/packages/package.map"; i := open(i, 'input); i := rds i; e := !*echo; !*echo := nil; w := read(); !*echo := e; i := rds i; close i; reduce_base_modules := for each x in w conc if member('core, cddr x) and member('csl, cddr x) then list car x else nil; reduce_extra_modules := for each x in w conc if not member('core, cddr x) and member('csl, cddr x) then list car x else nil; reduce_test_cases := for each x in w conc if member('test, cddr x) and member('csl, cddr x) then list car x else nil; for each x in w do if member('csl, cddr x) then put(car x, 'folder, cadr x); % princ "reduce_base_modules: "; print reduce_base_modules; % princ "reduce_extra_modules: "; print reduce_extra_modules; % princ "reduce_test_cases: "; print reduce_test_cases; return; end; symbolic procedure build_reduce_modules names; begin scalar w; !#if !*savedef !*savedef := t; !#else !*savedef := nil; !#endif make!-special '!*native_code; !*native_code := nil; get_configuration_data(); window!-heading list!-to!-string explodec car names; !#if !*savedef % When building the bootstrap version I want to record what switches % get declared... if not getd 'original!-switch then << w := getd 'switch; putd('original!-switch, car w, cdr w); putd('switch, 'expr, '(lambda (x) (dolist (y x) (princ "+++ Declaring a switch: ") (print y)) (original!-switch x))) >>; !#endif package!-remake car names; if null (names := cdr names) then << printc "Recompilation complete"; window!-heading "Recompilation complete" >>; !#if (or !*savedef (memq 'embedded lispsystem!*)) if null names then restart!-csl 'begin else restart!-csl('(remake build_reduce_modules), names) !#else if null names then restart!-csl '(user begin) else restart!-csl('(remake build_reduce_modules), names) !#endif end; symbolic procedure test_a_package names; begin scalar packge, logname, logtmp, logfile, start_time, start_gctime, gt; scalar redef, quitfn, oll, rr; princ "TESTING: "; print car names; window!-heading list!-to!-string explodec car names; !*backtrace := nil; !*errcont := t; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. packge := car names; verbos nil; % load!-latest!-patches(); % Normally logs from testing go in testlogs/name.rlg, however you may % may sometimes want to put them somewhere else. If you do then launch reduce % along the lines % reduce -D@log="mylogs" ... % and ensure that /mylogs exists. if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "testlogs"; logname := concat(logname, "/"); logtmp := concat(logname, concat(car names, ".tmp")); logname := concat(logname, concat(car names,".rlg")); logfile := open(logtmp, 'output); get_configuration_data(); begin scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, outputhandler!*; !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; oll := linelength 80; princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); load!-package packge; if get(packge,'folder) then packge := get(packge,'folder); packge := concat("$srcdir/../../src/packages/", concat(packge, concat("/", concat(car names,".tst")))); redef := !*redefmsg; !*redefmsg := nil; quitfn := getd 'quit; % At least at one stage at least one test file ends in "quit;" rather than % "end;" and the normal effect would be that this leads it to cancel % all execution instantly. To avoid that I will undefine the function % "quit", but restore it after the test. I reset !*redefmsg to avoid getting % messages about this. I redefined quit to something (specifically "posn") % that does not need an argument and that is "harmless". remd 'quit; putd('quit, 'expr, 'posn); start_time := time(); start_gctime := gctime(); !*mode := 'algebraic; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. !*errcont := t; % resource!-limit is a special feature in CSL so that potentially wild % code can be run with it being stopped harshly if it gets stuck. % The first argument is an expression to evaluate. The next 4 are % a time limit, in seconds % a "cons" limit, in megaconses % a limit on the number of thousands of I/O bytes that can be % performed, with both reading and printing counted % a limit on the number of Lisp-level errors that can be raised. % note that that can be large if errorset is used to trap them. % % If a limit is specified as a negative value (typically -1) then that % resource is not applied. % The first 3 limits are applied in an APPROXIMATE way, and the first % is seriously sensitive the the speed of the computer you are running % on, so should be used with real care. At the end the return value % is atomic if a limit expired, otherwise ncons of the regular value. % A global variable *resources* should end up a list of 4 values % showing the usage in each category. % The settings here are intended to be fairly conservative... % Time: On an Intel Q6600 CPU the longest test runs in under 20 seconds, % so allowing 3 minutes gives almost a factor of 10 slack. If % many people are running slow(ish) machines still I can increase % the limit. % Space: The amount of space used ought to be pretty independent of % the computer used. Measuring on 32 and 64-bit systems will % give minor differences. But the limit given here seems to allow % all the current tests to run with a factor of 2 headroom % in case the test-scripts are updated. % IO: The "crack" package has code in it that checkpoints its state % to disc periodically, and tests that activate that use amazingly % more IO than the others. The limit at 10 Mbytes suits the % relevant current tests. If a broken package leads to a test % script looping this then means that the resulting log file is no % larger than (about) 10 Mbytes, which is ugly but managable. % Errors: Some REDUCE packages make extensive use of errorset and % predictable use of "error" (for lack of use of catch and throw, % usually). So I do not constrain errors here. But if things were % ever such that no errors were expected I could enforce that % condition here. rr := resource!-limit(list('in_list1, mkquote packge, t), 300, % allow 5 minutes per test 200, % allow 200 megaconses 10000,% allow ten megabytes of I/O -1); % Do not limit Lisp-level errors at all erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); !*redefmsg := redef; terpri(); prin2 "Time for test: "; gt := time() - start_time; % I ensure that the reported time is at least 1 millisecond. if gt = 0 then gt := 1; prin2 gt; prin2 " ms"; if (gt := gctime() - start_gctime) > 0 then << prin2 ", plus GC time: "; prin2 gt; prin2 " ms" >>; terpri(); % Temp while I watch things if atom rr then printc "+++++ Error: Resource limit exceeded"; princ "@@@@@ Resources used: "; print !*resources!*; linelength oll end; close logfile; delete!-file logname; rename!-file(logtmp, logname); names := cdr names; if null names then << printc "Testing complete"; window!-heading "Testing complete"; restart!-csl t >> else restart!-csl('(remake test_a_package), names) end; symbolic procedure report_incomplete_tests names; begin % Displays information about what "complete_tests" would do scalar packge, tfile, logname; scalar date1, date2, date3; get_configuration_data(); for each packge in names do << tfile := packge; if get(packge,'folder) then tfile := get(packge,'folder); tfile := concat("$srcdir/../../src/packages/", concat(tfile, concat("/", concat(packge,".tst")))); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "testlogs"; logname := concat(logname, concat("/", concat(packge,".rlg"))); date1 := filedate "reduce.img"; date2 := filedate tfile; date3 := filedate logname; if null date1 then date1 := date(); if null date2 then date2 := date(); if null date3 or datelessp(date3, date1) or datelessp(date3, date2) then << princ "NEED TO TEST: "; print packge >> >> end; symbolic procedure complete_tests names; begin % Just like the previous testing code except that logs that are already up % to date are not re-generated. scalar packge, tfile, logname, logfile, logtmp, start_time, start_gctime, gt, rr; scalar date1, date2, date3, oll; !*backtrace := nil; !*errcont := t; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. verbos nil; get_configuraion_data(); top: tfile := packge := car names; if get(tfile,'folder) then tfile := get(tfile,'folder); tfile := concat("$srcdir/../../src/packages/", concat(tfile, concat("/", concat(packge,".tst")))); if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "testlogs"; logname := concat(logname, "/"); logtmp := concat(logname, concat(packge, ".tmp")); logname := concat(logname, concat(packge, ".rlg")); date1 := filedate "reduce.img"; date2 := filedate tfile; date3 := filedate logname; if null date1 then date1 := date(); if null date2 then date2 := date(); if null date3 or datelessp(date3, date1) or datelessp(date3, date2) then << princ "TESTING: "; print packge; window!-heading list!-to!-string explodec packge; logfile := open(logtmp, 'output); start_time := time(); start_gctime := gctime(); begin scalar !*terminal!-io!*, !*standard!-output!*, !*error!-output!*, !*trace!-output!*, !*debug!-io!*, !*query!-io!*, !*errcont, outputhandler!*, redef, quitfn; !*terminal!-io!* := !*standard!-output!* := !*error!-output!* := logfile; !*trace!-output!* := !*debug!-io!* := !*query!-io!* := logfile; oll := linelength 80; princ date(); princ " run on "; printc cdr assoc('name, lispsystem!*); load!-package packge; !*mode := 'algebraic; !*extraecho := t; % Ensure standard environment for the test... !*int := nil; % ... so that results are predictable. redef := !*redefmsg; !*redefmsg := nil; quitfn := getd 'quit; remd 'quit; putd('quit, 'expr, 'posn); !*errcont := t; rr := resource!-limit(list('in_list1, mkquote tfile, t), 300, % allow 5 minutes per test 200, % allow 200 megaconses 10000,% allow ten megabytes of I/O -1); % Do not limit Lisp-level errors at all erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); !*redefmsg := redef; terpri(); prin2 "Time for test: "; gt := time() - start_time; if gt = 0 then gt := 1; prin2 gt; prin2 " ms"; if (gt := gctime() - start_gctime) > 0 then << prin2 ", plus GC time: "; prin2 gt; prin2 " ms" >>; if atom rr then printc "+++++ Error: Resource limit exceeded"; princ "@@@@@ Resources used: "; print !*resources!*; terpri(); linelength oll end; close logfile; delete!-file logname; rename!-file(logtmp, logname) >> else if cdr names then << names := cdr names; go to top >>; names := cdr names; if null names then restart!-csl t else restart!-csl('(remake complete_tests), names) end; symbolic procedure profile_compare_fn(p, q); (float caddr p/float cadr p) < (float caddr q/float cadr q); % % This function runs a test file and sorts out what the top 350 % functions in it. It appends their names to "profile.dat". % % I need to talk a little about the interaction between profiling and % patching. Well firstly I arrange that whenever I run a profiling job % I rebuild REDUCE with the latest paches. This may involve re-compiling % the patches.red source. Thus when a test is run the current patches % will be in place. Patched functions are first defined with funny names % (including a hash based on their definition) and then copied into place % when a package is loaded. However MAPSTORE and the CSL instrumentation % attributes their cost to the hash-extended name even though the % functions may have been called via the simple one. Thus in the face % of patches one can expect the profile data to refer to some names that % are long and curious looking. Throughout all this I assume that there will % never be embarassing collisions in my hash functions. symbolic procedure profile_a_package names; begin scalar packge, oll, w, w1, w2, quitfn, !*errcont, rr; princ "PROFILING: "; print car names; !*backtrace := nil; !*errcont := t; !*int := nil; packge := car names; verbos nil; load!-package packge; get_configuration_data(); if get(packge,'folder) then packge := get(packge,'folder); packge := concat("$srcdir/../../src/packages/", concat(packge, concat("/", concat(car names,".tst")))); oll := linelength 80; !*mode := 'algebraic; window!-heading list!-to!-string explodec car names; quitfn := getd 'quit; remd 'quit; putd('quit, 'expr, 'posn); mapstore 4; % reset counts; !*errcont := t; % I try hard to arrange that even if the test fails I can continue and that % input & output file selection is not messed up for me. w := wrs nil; w1 := rds nil; wrs w; rds w1; rr := resource!-limit(list('errorset, mkquote list('in_list1, mkquote packge, t), nil, nil), 300, % allow 5 minutes per test 200, % allow 200 megaconses 10000,% allow ten megabytes of I/O -1); % Do not limit Lisp-level errors at all wrs w; rds w1; erfg!* := nil; terpri(); putd('quit, car quitfn, cdr quitfn); w := sort(mapstore 2, function profile_compare_fn); w1 := nil; while w do << w2 := get(caar w, '!*savedef); % if eqcar(w2, 'lambda) then << % princ "md60: "; print (caar w . cdr w2); % princ "= "; print md60 (caar w . cdr w2) >>; if eqcar(w2, 'lambda) then w1 := (caar w . md60 (caar w . cdr w2) . cadar w . caddar w) . w1; w := cdr w >>; w := w1; % I collect the top 350 functions as used by each test, not because all % that many will be wanted but because I might as well record plenty % of information here and discard unwanted parts later on. for i := 1:349 do if w1 then w1 := cdr w1; if w1 then rplacd(w1, nil); % princ "MODULE "; prin car names; princ " suggests "; % print for each z in w collect car z; w1 := open("profile.dat", 'append); w1 := wrs w1; linelength 80; if atom rr then printc "% +++++ Error: Resource limit exceeded"; princ "% @@@@@ Resources used: "; print !*resources!*; princ "("; prin car names; terpri(); for each n in w do << princ " ("; prin car n; princ " "; if posn() > 30 then << terpri(); ttab 30 >>; prin cadr n; % I also display the counts just to help me debug & for interest. princ " "; prin caddr n; princ " "; princ cdddr n; printc ")" >>; printc " )"; terpri(); close wrs w1; linelength oll; names := cdr names; if null names then << printc "Profiling complete"; window!-heading "Profiling complete"; restart!-csl t >> else restart!-csl('(remake profile_a_package), names) end; symbolic procedure trim_prefix(a, b); begin while a and b and car a = car b do << a := cdr a; b := cdr b >>; if null a then return b else return nil end; fluid '(time_info); symbolic procedure read_file f1; begin % I take the view that I can afford to read the whole of a file into % memory at the start of processing. This makes life easier for me % and the REDUCE log files are small compared with current main memory sizes. scalar r, w, w1, n, x; scalar p1, p2, p3, p4, p5, p6, p7; % To make comparisons between my CSL logs and some of the Hearn "reference % logs", which are created using a different script, I will discard % lines that match certain patterns! Note that if the reference logs change % the particular tests I perform here could become out of date! Also if any % legitimate test output happened to match one of the following strings % I would lose out slightly. p1 := explodec "REDUCE 3.8,"; p2 := explodec "1: 1:"; p3 := explodec "2: 2: 2:"; p4 := explodec "3: 3: "; % a prefix to first real line of output. p5 := explodec "4: 4: 4:"; p6 := explodec "5: 5:"; p7 := explodec "Quittin"; % nb left so that the "g" remains! % this is so that the match is detected. r := nil; n := 0; while not ((w := readline f1) = !$eof!$) do << w1 := explodec w; if x := trim_prefix(p4, w1) then r := ((n := n + 1) . list!-to!-string x) . r else if trim_prefix(p1, w1) or trim_prefix(p2, w1) or trim_prefix(p3, w1) or trim_prefix(p5, w1) or trim_prefix(p6, w1) or trim_prefix(p7, w1) then nil else r := ((n := n + 1) . w) . r >>; w := r; % The text scanned for here is expected to match that generated by the % test script. I locate the last match in a file, extract the numbers % and eventually write them to testlogs/times.log n := explodec "Time for test:"; while w and null (x := trim_prefix(n, explodec cdar w)) do w := cdr w; if null w then << time_info := nil; return reversip r >>; while eqcar(x, '! ) do x := cdr x; w := n := nil; while digit car x do << w := car x . w; x := cdr x >>; while eqcar(x, '! ) do x := cdr x; if x := trim_prefix(explodec "ms, plus GC time:", x) then << while eqcar(x, '! ) do x := cdr x; while digit car x do << n := car x . n; x := cdr x >> >>; if null w then w := '(!0); if null n then n := '(!0); time_info := compress reverse w . compress reverse n; return reversip r; end; symbolic procedure roughly_equal(a, b); begin % a and b are strings repesenting lines of text. I want to test if they % match subject to some floating point slop. scalar wa, wb, adot, bdot; if a = b then return t; a := explodec a; b := explodec b; top: % First deal with end of line matters. if null a and null b then return t else if null a or null b then return nil; % next split off any bits of a and b up to a digit wa := wb := nil; while a and not digit car a do << wa := car a . wa; a := cdr a >>; while b and not digit car b do << wb := car b . wb; b := cdr b >>; if not (wa = wb) then return nil; % now both a and b start with digits. I will seek a chunk of the % form nnn.mmmE+xxx where Exxx is optional... % Note that any leading sign on the float has been checked already! wa := wb := nil; adot := bdot := nil; while a and digit car a do << wa := car a . wa; a := cdr a >>; if eqcar(a, '!.) then << adot := t; wa := car a . wa; a := cdr a >>; while a and digit car a do << wa := car a . wa; a := cdr a >>; if eqcar(a, '!e) or eqcar(a, '!E) then << adot := t; wa := car a . wa; a := cdr a; if eqcar(a, '!+) or eqcar(a, '!-) then << wa := car a . wa; a := cdr a >>; while a and digit car a do << wa := car a . wa; a := cdr a >> >>; % Now all the same to grab a float from b while b and digit car b do << wb := car b . wb; b := cdr b >>; if eqcar(b, '!.) then << bdot := t; wb := car b . wb; b := cdr b >>; while b and digit car b do << wb := car b . wb; b := cdr b >>; if eqcar(b, '!e) or eqcar(b, '!E) then << bdot := t; wb := car b . wb; b := cdr b; if eqcar(b, '!+) or eqcar(b, '!-) then << wb := car b . wb; b := cdr b >>; while b and digit car b do << wb := car b . wb; b := cdr b >> >>; % Now one possibility is that I had an integer not a float, % and in that case I want an exact match if not adot or not bdot then << if wa = wb then goto top else return nil >>; if wa = wb then goto top; % textual match on floating point values wa := compress reversip wa; wb := compress reversip wb; if fixp wa then wa := float wa; if fixp wb then wb := float wb; if not (floatp wa and floatp wb) then return nil; % messed up somehow! if wa = wb then goto top; % now the crucial approximate floating point test - note that both numbers % are positive, but that they may be extreme in range. % As a cop-out I am going to insist that if values are either very very big % or very very small that they match as text. if wa > 1.0e100 or wb > 1.0e100 then return nil; if wa < 1.0e-100 or wb < 1.0e-100 then return nil; wa := (wa - wb)/(wa + wb); if wa < 0 then wa := -wa; if wa > 0.0001 then return nil; % pretty crude! goto top end; symbolic procedure in_sync(d1, n1, d2, n2); begin for i := 1:n1 do if d1 then << % skip n1 lines from d1 d1 := cdr d1 >>; for i := 1:n2 do if d2 then << % skip n2 lines from d2 d2 := cdr d2 >>; % If one is ended but the other is not then we do not have a match. If % both are ended we do have one. if null d1 then return null d2 else if null d2 then return nil; % Here I insist on 3 lines that agree before I count a match as % having been re-established. if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil; if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil; if not roughly_equal(cdar d1, cdar d2) then return nil; d1 := cdr d1; d2 := cdr d2; if null d1 then return null d2 else if null d2 then return nil else return t end; fluid '(time_data time_ratio gc_time_ratio log_count); symbolic procedure prinright(x, w); begin scalar xx, xl; xx := explodec x; xl := length xx; while w > xl do << princ " "; xl := xl + 1 >>; princ x; end; symbolic procedure file_compare(f1, f2, name); begin scalar i, j, d1, d2, t1, gt1, t2, gt2, time_info; d1 := read_file f1; if null time_info then t1 := gt1 := 0 else << t1 := car time_info; gt1 := cdr time_info >>; d2 := read_file f2; if null time_info then t2 := gt2 := 0 else << t2 := car time_info; gt2 := cdr time_info >>; i := wrs time_data; j := set!-print!-precision 3; prin name; ttab 17; if zerop t1 then princ " ---" else << prinright(t1, 8); % Tag the time with an asterisk if it will not participate in the % eventual overall timing report. if t1<=200 then princ "*"; ttab 30; prinright(gt1, 8) >>; ttab 40; if zerop t2 then princ " ---" else << prinright(t2, 9); if t2<=200 then princ "*"; ttab 50; prinright(gt2, 8) >>; ttab 60; if zerop t1 or zerop t2 then princ " *** ***" else begin scalar r1, gr1, w; r1 := float t1 / float t2; gr1 := float (t1+gt1)/float (t2+gt2); % I will only use tests where the time taken was over 200ms in my eventual % composite summary of timings, since measurement accuracy can leave the % really short tests pretty meaningless. if t1 > 200 and t2 > 200 then << % But I will go further than that and give less weight to any test whose time % is under 1 second, so that the cut-off is gradual rather than abrupt. w := min(t1, t2); % This means that if w (the smaller time) = 200 then then % the test does not contribute to the average, while if w>=1000 % it contributes fully. if w < 1000.0 then w := (w - 200.0)/800.0 else w := 1.0; time_ratio := time_ratio * expt(r1, w); gc_time_ratio := gc_time_ratio * expt(gr1, w); log_count := log_count + w >>; princ r1; ttab 70; princ gr1; end; terpri(); set!-print!-precision j; wrs i; % The next segment of code is a version of "diff" to report ways in which % reference and recent log files match or diverge. % I can not see a neat way to get a "structured" control structure % here easily. Ah well, drop back to GOTO statements! top: if null d1 then << % end of one file if d2 then terpri(); i := 0; while d2 and i < 20 do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; i := i + 1 >>; if d2 then printc "..."; return >>; if null d2 then << % end of other file i := 0; while d1 and i < 20 do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; i := i + 1 >>; if d1 then printc "..."; return >>; % The test "roughly_equal" compares allowing some tolerance on floating % point values. This is because REDUCE uses platform libraries for % floating point elementary functions and printing, so small differences % are expected. This is perhaps uncomfortable, but is part of reality, and % the test here makes comparison output much more useful in that the % differences shown up are better limited towards "real" ones. if roughly_equal(cdar d1, cdar d2) then << d1 := cdr d1; d2 := cdr d2; go to top >>; % I will first see if there are just a few blank lines inserted into % one or other file. This special case is addressed here because it % appears more common a possibility than I had expected. if cdar d1 = "" and cdr d1 and roughly_equal(cdadr d1, cdar d2) then << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; go to top >> else if cdar d1 = "" and cdr d1 and cdadr d1 = "" and cddr d1 and roughly_equal(cdaddr d1, cdar d2) then << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; go to top >> else if cdar d2 = "" and cdr d2 and roughly_equal(cdadr d2, cdar d1) then << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; go to top >> else if cdar d2 = "" and cdr d2 and cdadr d2 = "" and cddr d2 and roughly_equal(cdaddr d2, cdar d1) then << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; go to top >>; i := 1; seek_rematch: j := 0; inner: if in_sync(d1, i, d2, j) then << terpri(); for k := 1:i do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1 >>; for k := 1:j do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2 >>; % Should be in step again here. if null d1 then return else go to top >>; j := j + 1; i := i - 1; if i >= 0 then go to inner; i := j; % I am prepared to seek 80 lines ahead on each side before I give up. % The number 80 is pretty much arbitrary. if i < 80 then goto seek_rematch; terpri(); i := 0; while d2 and i < 20 do << princ "REF "; princ caar d2; princ ":"; ttab 10; printc cdar d2; d2 := cdr d2; i := i+1 >>; if d2 then printc "..."; i := 0; while d1 and i < 20 do << princ "NEW "; princ caar d1; princ ":"; ttab 10; printc cdar d1; d1 := cdr d1; i := i+1 >>; if d1 then printc "..."; printc "Comparison failed." end; fluid '(which_module); symbolic procedure check_a_package; begin scalar oll, names, p1, logname, mylogname, mylog, reflogname, reflog, time_data, time_ratio, gc_time_ratio, log_count; get_configuration_data(); if boundp 'which_module and symbol!-value 'which_module and not (symbol!-value 'which_module = "") then << names := compress explodec symbol!-value 'which_module; if member(names, reduce_test_cases) then names := list names else error(0, list("unknown module to check", which_module)) >> else names := reduce_test_cases; % I write a summary of timing information into csllogs/times.log time_data := open("testlogs/times.log", 'output); p1 := wrs time_data; princ "MODULE"; ttab 21; princ "Local"; ttab 32; princ "(GC)"; ttab 40; princ "Reference"; ttab 52; princ "(GC)"; ttab 55; princ "Ratio"; ttab 65; printc "inc GC"; wrs p1; terpri(); oll := linelength 100; printc "=== Comparison results ==="; time_ratio := gc_time_ratio := 1.0; log_count := 0.0; for each packge in names do << terpri(); princ "CHECKING: "; print packge; if boundp '!@log and stringp symbol!-value '!@log then logname := symbol!-value '!@log else logname := "testlogs"; mylogname := concat(logname, concat("/", concat(packge, ".rlg"))); if get(packge,'folder) then p1 := get(packge,'folder) else p1 := packge; reflogname := concat("$srcdir/../../src/packages/", concat(p1, concat("/", concat(packge,".rlg")))); mylog := errorset(list('open, mkquote mylogname, ''input), nil, nil); reflog := errorset(list('open, mkquote reflogname, ''input), nil, nil); if errorp mylog then << if not errorp reflog then close car reflog; princ "No current log in "; print mylogname >> else if errorp reflog then << close car mylog; princ "No reference log in "; print reflogname >> else << princ "LOGS: "; princ mylogname; princ " "; printc reflogname; mylog := car mylog; reflog := car reflog; file_compare(mylog, reflog, packge); close mylog; close reflog >> >>; time_data := wrs time_data; if not zerop log_count then << time_ratio := expt(time_ratio, 1.0/log_count); gc_time_ratio := expt(gc_time_ratio, 1.0/log_count); terpri(); p1 := set!-print!-precision 3; princ "Over "; prin log_count; princ " tests the speed ratio was "; print time_ratio; princ " (or "; prin gc_time_ratio; printc " is garbage collection costs are included)"; set!-print!-precision p1 >>; close wrs time_data; linelength oll; end; faslend; % faslout 'cslhelp; % % module cslhelp; % % global '(!*force); % % flag('(force),'switch); % flag('(on),'eval); % % on force; % % symbolic procedure formhelp(u,vars,mode); % list('help, 'list . for each x in cdr u collect mkquote x); % % if member('help, lispsystem!*) then << % put('help, 'stat, 'rlis); % flag('(help), 'go); % put('help, 'formfn, 'formhelp) >>; % % off force; % remflag('(on),'eval); % % endmodule; % % faslend; load!-module 'remake; << initreduce(); date!* := "Bootstrap version"; !@reduce := symbol!-value gensym(); checkpoint('begin, "REDUCE") >>; !#if (and (not (memq 'embedded lispsystem!*)) (not !*savedef)) load!-module 'user; !#endif !@reduce := concat(!@srcdir, "/../../src"); get_configuration_data(); package!-remake2(prolog_file,'support); package!-remake2(rend_file,'support); package!-remake2('entry,'support); package!-remake2('smacros,'support); package!-remake2('remake,'support); % The next lines have LOTS of hidden depth! They restart CSL repeatedly % so that each of the modules that has to be processed gets dealt with in % a fresh uncluttered environment. The list of modules is fetched from % a configuration file which must have 3 s-expressions in it. The first % is a list of basic modules that must be built to get a core version of % REDUCE. The second list identifies modules that can be built one the core % is ready for use, while the last list indicates which modules have % associated test scripts. % % when the modules have been rebuild the system does a restart that % kicks it back into REDUCE by calling begin(). This then continues % reading from the stream that had been the standard input when this % job started. Thus this script MUST be invoked as % ./csl -obootstrapreduce.img -z buildreduce.lsp % with the file buildreduce.lsp specified on the command line in the call. It % will not work if you start csl manually and then do a (rdf ..) [say] % on buildreduce.lsp. I told you that it was a little delicate. !#if !*savedef % Some switches may be in the utter core and not introduced via the % "switch" declaration... for each y in oblist() do if flagp(y, 'switch) then << princ "+++ Declaring a switch: "; print y >>; !#endif get_configuration_data(); build_reduce_modules reduce_base_modules; % Now I want to do a cold-start so that I can create a sensible % image for use in the subsequent build steps. This image should not % contain ANYTHING extraneous. symbolic restart!-csl nil; (setq !*savedef (and (null (memq 'embedded lispsystem!*)) (zerop (cdr (assoc 'c!-code lispsystem!*))))) (make!-special '!*native_code) (setq !*native_code nil) (setq !*backtrace t) (cond ((and (null !*savedef) (null (memq 'embedded lispsystem!*))) (load!-module 'user))) (load!-module 'cslcompat) (setq !*comp nil) (load!-module 'module) % Definition of load_package, etc. (load!-module 'cslprolo) % CSL specific code. (setq loaded!-packages!* '(cslcompat user cslprolo)) % NB I will re-load the "patches" module when REDUCE is started % if there is a version newer than the one I load up here. Note that % if there had not been a "patches.red" file I will not have a module to load % here. % % (cond % ((modulep 'patches) (load!-module 'patches))) (load!-package 'rlisp) (load!-package 'cslrend) (load!-package 'smacros) (load!-package 'poly) (load!-package 'arith) (load!-package 'alg) (load!-package 'mathpr) (cond ((modulep 'tmprint) (load!-package 'tmprint))) (load!-package 'entry) % (write!-help!-module "$srcdir/../../src/util/reduce.inf" nil) % % (load!-module 'cslhelp) (setq version!* "Reduce (Free CSL version)") (setq date!* (date t)) (setq !*backtrace nil) (initreduce) (setq no_init_file nil) (setq !@csl (setq !@reduce (symbol!-value (gensym)))) % If the user compiles a new FASL module then I will let it % generate native code by default. I build the bulk of REDUCE % without that since I have statically-selected hot-spot compilation % that gives me what I believe to be a better speed/space tradeoff. % Oh well, let's change that and disable it by dafault since at least on % windows there are problems with windows vs cygwin file-names. (fluid '(!*native_code)) (setq !*native_code nil) % Try T if you are VERY keen... %(checkpoint 'begin (bldmsg "%w, %w ..." version!* date!*)) (checkpoint 'begin (bldmsg "")) (setq no_init_file t) (begin) % % See the fairly length comments given a bit earlier about the % delicacy of the next few lines! % symbolic; load!-module 'remake; get_configuration_data(); build_reduce_modules reduce_extra_modules; symbolic; "**** **** REDUCE FULLY REBUILD **** ****"; % At this stage I have a complete workable REDUCE. If built using a % basic CSL (I call it "bootstrapreduce" here) nothing has been compiled into C % (everything is bytecoded), and it is big because it has retained all % Lisp source code in the image file. If however I built using a version % of CSL ("reduce") that did have things compiled into C then these will % be exploited and the original Lisp source will be omitted from the % image, leaving a production version. bye; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/package.red0000644000175000017500000000033611550002751023643 0ustar giovannigiovanni% This gets a single REDUCE package compiled and up to date symbolic; load!-module 'remake; if not boundp 'target or null target then target := 'alg; get_configuration_data t; build_reduce_modules list target; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/extras.red0000644000175000017500000007613411550002751023567 0ustar giovannigiovanni% extras.red Copyright Codemist Ltd 2004-2009 % % Additional useful functions to have in a Lisp environment. % % % %/************************************************************************** % * Copyright (C) 2009, Codemist Ltd. A C Norman * % * * % * Redistribution and use in source and binary forms, with or without * % * modification, are permitted provided that the following conditions are * % * met: * % * * % * * Redistributions of source code must retain the relevant * % * copyright notice, this list of conditions and the following * % * disclaimer. * % * * Redistributions in binary form must reproduce the above * % * copyright notice, this list of conditions and the following * % * disclaimer in the documentation and/or other materials provided * % * with the distribution. * % * * % * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * % * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * % * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * % * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * % * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * % * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * % * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * % * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * % * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * % * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * % * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * % * DAMAGE. * % *************************************************************************/ % % % CSL does not support user-defined special forms! So % (df name (u) body) % will get mapped to a macro as roughly % (dm name (g) % `(let* ((u '@(cdr g))) % (progn @,body))) % % For example (df quote (u) (car u)) % map map onto something such that macroexpanding (quote XX) gives % (let* ((g '(XX))) % (car g)) [g is a fresh gensym] symbolic macro procedure df(u, !&optional, env); begin scalar g, w; g := gensym(); w := list('list, ''let!*, list('list, list('list, mkquote caaddr u, list('mkquote, list('cdr, g)))), list('cons, ''progn, mkquote cdddr u)); return list('dm, cadr u, list(g, '!&optional, gensym()), w); end; % The following small function is just used for testing the CSL OEM % interface code... symbolic procedure oem!-supervisor(); print eval read(); % % If you go (setq !*break!-loop!* 'break!-loop) then errors will get this % function called - and it is rather desirable that it does not itself fail. % The argument is what was passed to (ERROR ...) if the Lisp-level error % function was called. When this function exits the system will unwind back % to the next enclosing ERRORSET. (enable!-backtrace ) can be used to % switch backtrace display on or off. % symbolic procedure break!-loop a; begin scalar prompt, ifile, ofile, u, v; % I use wrs/rds so I am compatible between Standard and Common Lisp here ifile := rds !*debug!-io!*; ofile := wrs !*debug!-io!*; prompt := setpchar "Break loop (:X exits)> "; top:u := read(); if u = '!:x then go to exit else if u = '!:q then << enable!-backtrace nil; princ "Backtrace now disabled"; terpri() >> else if u = '!:v then << enable!-backtrace t; princ "Backtrace now enabled"; terpri() >> else << if null u then v := nil else v := errorset(u, nil, nil); if atom v then << princ ":Q quietens backtrace"; terpri(); princ ":V enables backtrace"; terpri(); princ ":X exits from break loop"; terpri(); princ "else form for evaluation"; terpri(); >> else << prin "=> "; prinl car v; terpri() >> >>; go to top; exit: rds ifile; wrs ofile; setpchar prompt; return nil end; % dated!-name manufactures a symbol that is expected to be unique - but % there will in fact be no strict guarantee of that. The name is made up out % of a base part provided by the caller, then a chunk that encodes the % date and time of day that the function was called (accurate to around % a second, typically). Finally a serial number that starts off as 1 when % the "extras" module is loaded into a copy of Lisp. Two copies of Lisp % running at the same time could lead to clashes here. But names of this % sort seem to be needed for inclusion in files and other places where % re-readability is vital. global '(s!:gensym!-serial); s!:gensym!-serial := 0; symbolic procedure s!:stamp n; % Converts an integer (which will in fact be a timestamp, an about % 2^29 or 2^30 in value) into a sequence of letters and digits by % converting to base 36 (with the digits ending up in the "wrong" % order). Used only when generating probably-unique-identifiers to % use as names for internally generated functions. if n < 0 then append(s!:stamp(-n), '(!-)) else if n = 0 then nil else schar("0123456789abcdefghijklmnopqrstuvwxyz", remainder(n, 36)) . s!:stamp truncate(n ,36); symbolic procedure dated!-name base; intern list!-to!-string append(explodec base, '!_ . append(reverse s!:stamp datestamp(), '!_ . explodec(s!:gensym!-serial := s!:gensym!-serial + 1))); % hashtagged!-name(base, value) manufactures a name based on the % base together with a hash-value computed from the "value". This % is expected to be a reliable signature (but clashes are of course % possible). Eg base may be the name of a function and value its % definition, then this will invent a name suitable for a parallel % version of the function where the new name ought not to conflict with % ones used later if this function gets defined with a different % definition. symbolic procedure hashtagged!-name(base, value); intern list!-to!-string append(explodec base, '!_ . s!:stamp md60 value); % % Sorting % remflag('(sort sortip), 'lose); symbolic procedure sort(l, pred); % Sort the list l according to the given predicate. If l is a list % of numbers then the predicate "lessp" will sort the list into % ascending order. The predicate should be a strict inequality, i.e. % it should return NIL if the two items compared are equal. % As implemented here SORT just calls STABLE-SORT, but as a matter of % style any use where the ordering of incomparable items in the output % matters ought to use STABLE!-SORT directly, thereby allowing the % replacement of this code with a faster non-stable method. % (Note: the previous REDUCE sort function also happened to be stable, so % this code should give exactly the same results for all calls where % the predicate is self-consistent and never has both pred(a,b) and % pred(b,a) true. A previous CSL sort was not stable, but was perhaps % very slightly faster than this) stable!-sortip(append(l, nil), pred); symbolic procedure stable!-sort(l, pred); % Sorts a list, as SORT, but if two items x and y in the input list % satisfy neither pred(x,y) nor pred(y,x) [i.e. they are equal so far % as the given ordering predicate is concerned] this function guarantees % that they will appear in the output list in the same order that they % were in the input. stable!-sortip(append(l, nil), pred); symbolic procedure sortip(l, pred); stable!-sortip(l, pred); symbolic procedure stable!-sortip(l, pred); % As stable!-sort, but over-writes the input list to make the output. % It is not intended that people should call this function directly: it % is present just as the implementation of the main sort procedures defined % above. begin scalar l1, l2, w; if null l then return l; % Input list of length 0 l1 := l; l2 := cdr l; if null l2 then return l; % Input list of length 1 % Now I have dealt with the essential special cases of lists of length 0 % and 1 (which do not need sorting at all). Since it possibly speeds things % up just a little I will now have some fairly ugly code that makes special % cases of lists of length 2. I could easily have special code for length % 3 lists here (and include it, but commented out), but at present my % measurements suggest that the speed improvement that it gives is minimal % and the increase in code bulk is large enough to give some pain. l := cdr l2; if null l then << % Input list of length 2 if apply2(pred, car l2, car l1) then << l := car l1; rplaca(l1, car l2); rplaca(l2, l) >>; return l1 >>; % Now I will check to see if the list is in fact in order already % Doing so will have a cost - but sometimes that cost will be repaid % when I am able to exit especially early. The result of all this % is that I will have a best case behaviour with linear cost growth for % inputs that are initially in the correct order, while my average and % worst-case costs will increase by a constant factor. l := l1; while l2 and not apply2(pred, car l2, car l) do << % In the input list is NOT already in order then I expect that this % loop will exit fairly early, and so will not contribute much to the % total cost. If it exits very late then probably in the next recursion % down the first half of the list will be found to be already sorted, and % again I have a chance to win. l := l2; l2 := cdr l2 >>; if null l2 then return l1; l2 := l1; l := cddr l2; while l and cdr l do << l2 := cdr l2; l := cddr l >>; l := l2; l2 := cdr l2; rplacd(l, nil); % The two sub-lists are then sorted. l1 := stable!-sortip(l1, pred); l2 := stable!-sortip(l2, pred); % Now I merge the sorted fragments, giving priority to item from the % earlier part of the original list. l := w := list nil; while l1 and l2 do << if apply2(pred, car l2, car l1) then << rplacd(w, l2); w := l2; l2 := cdr l2 >> else << rplacd(w, l1); w := l1; l1 := cdr l1 >> >>; if l1 then l2 := l1; rplacd(w, l2); return cdr l end; % % Code to print potentially re-entrant lists % fluid '(!*prinl!-visited!-nodes!* !*prinl!-index!* !*prinl!-fn!* !*loop!-print!* !*print!-array!* !*print!-length!* !*print!-level!*); !*print!-length!* := !*print!-level!* := nil; !*prinl!-visited!-nodes!* := mkhash(10, 0, 1.5)$ symbolic procedure s!:prinl0(x,!*prinl!-fn!*); % print x even if it has loops in it begin scalar !*prinl!-index!*; !*prinl!-index!*:=0; % Clear the hash table AFTER use, so that the junk that goes into it does % not gobble memory between calls to prinl. This relies on unwind!-protect % to make sure that it is indeed always cleared. Errors (eg ^C) during the % clean-up operation could lead to curious displays in the next use of % prinl. Also of course bugs in the implementation of unwind!-protect... % clrhash !*prinl!-visited!-nodes!*; unwind!-protect(<< s!:prinl1(x, 0); s!:prinl2(x, 0) >>, clrhash !*prinl!-visited!-nodes!*); return x end; symbolic procedure s!:prinl1(x, depth); % Find all the nodes in x and record them in the hash table. % The first time a node is met it is inserted with associated value 0. % If a node is met a second time then it is assigned an unique positive % integer code that will later be used in its label. begin scalar w, length; if fixp !*print!-level!* and depth > !*print!-level!* then return nil; length := 0; top: if atom x and not simple!-vector!-p x and not gensymp x then return nil else if w := gethash(x,!*prinl!-visited!-nodes!*) then << if w = 0 then << !*prinl!-index!* := !*prinl!-index!* + 1; puthash(x,!*prinl!-visited!-nodes!*, !*prinl!-index!*) >>; return nil >> else << puthash(x, !*prinl!-visited!-nodes!*, 0); if simple!-vector!-p x then << if !*print!-array!* then << length := upbv x; if fixp !*print!-length!* and !*print!-length!* < length then length := !*print!-length!*; for i:=0:length do s!:prinl1(getv(x,i), depth+1) >> >> else if not atom x then << s!:prinl1(car x, depth+1); if fixp !*print!-length!* and (length := length+1) > !*print!-length!* then return nil; x := cdr x; go to top >> >> end; symbolic procedure s!:prinl2(x, depth); % Scan a structure that was previously processed by s!:prinl1. Thus all % nodes in x are already in the hash table. Those with value zero % are only present once in x, while those with strictly positive values % occur at least twice. After printing a label for such value this resets the % value negative so that the printing can tell when the visit is for % a second rather than first time. The output format is intended to % bear some resemblance to the expectations of Common Lisp. if fixp !*print!-level!* and depth > !*print!-level!* then princ "#" else if atom x and not simple!-vector!-p x and not gensymp x then << !#if common!-lisp!-mode if complex!-arrayp x and not !*print!-array!* then princ "[Array]" else if structp x and not !*print!-array!* then princ "[Struct]" else !#endif funcall(!*prinl!-fn!*, x) >> else begin scalar w, length; w := gethash(x,!*prinl!-visited!-nodes!*); % w has better be a number here, following s!:prinl1 if not zerop w then << if w < 0 then << princ "#"; princ (-w); princ "#"; return nil >> else << puthash(x,!*prinl!-visited!-nodes!*, -w); princ "#"; princ w; princ "=" >> >>; if simple!-vector!-p x then << princ "%("; if !*print!-array!* then << length := upbv x; if fixp !*print!-length!* and !*print!-length!* < length then length := !*print!-length!*; for i:=0:length do << s!:prinl2(getv(x,i), depth+1); if not i=upbv x then princ " " >> >> else princ "..."; princ ")"; return nil >> else if atom x then return funcall(!*prinl!-fn!*, x); princ "("; length := 0; loop: s!:prinl2(car x, depth+1); x:=cdr x; if atom x then << if simple!-vector!-p x then << princ " . %("; if !*print!-array!* then << length := upbv x; if fixp !*print!-length!* and !*print!-length!* < length then length := !*print!-length!*; for i:=0:length do <> >> else princ "..."; princ ")" >> else if x then << princ " . "; funcall(!*prinl!-fn!*, x) >>; return princ ")" >>; if fixp !*print!-length!* and (length := length + 1) > !*print!-length!* then return princ " ...)"; w := gethash(x, !*prinl!-visited!-nodes!*); if not (w = 0) then if w < 0 then << princ " . #"; princ (-w); return princ "#)" >> else << princ " . "; s!:prinl2(x, depth+1); % This will set the label return princ ")" >> else princ " "; go to loop end; symbolic procedure printl x; << prinl x; terpri(); x >>; symbolic procedure printcl x; << princl x; terpri(); x >>; symbolic procedure princl x; s!:prinl0(x,function princ); symbolic procedure prinl x; s!:prinl0(x,function prin); % % A small subset of the facilities of the unreasonably baroque Common % Lisp FORMAT function may be useful. % !#if (not common!-lisp!-mode) % If I am in COMMON Lisp mode then a more complete version of this % will be installed from elsewhere. symbolic procedure s!:format(dest, fmt, args); begin scalar len, c, a, res, o; if not null dest then << if dest = 't then o := wrs nil else o := wrs dest >>; len := upbv fmt; for i := 0:len do << c := schar(fmt, i); if c = '!~ then << i := i + 1; c := char!-downcase schar(fmt, i); if c = '!% then if null dest then res := !$eol!$ . res else terpri() else if c = '!~ then if null dest then res := '!~ . res else princ '!~ else << if null args then a := nil else << a := car args; args := cdr args >>; if c = '!a then if null dest then for each k in explode2 a do res := k . res else princ a else if c = '!s then if null dest then for each k in explode a do res := k . res else prin a else if null dest then for each k in explode a do res := k . res else prin list('!?!?!?, c, a) >> >> else << if null dest then res := c . res else princ c >> >>; if null dest then return list!-to!-string reversip res else << wrs o; return nil >> end; symbolic macro procedure format(u, !&optional, env); list('s!:format, cadr u, caddr u, 'list . cdddr u); !#endif fluid '(bn bufferi buffero indblanks indentlevel initialblanks lmar pendingrpars rmar rparcount stack); global '(!*quotes !*pretty!-symmetric thin!*); !*pretty!-symmetric := t; !*quotes := t; thin!* := 5; % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % Functions: % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = <>; % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; symbolic procedure prettyprint x; << superprinm(x,posn()); % What REDUCE seems to want. Looks a bit odd to me! terpri(); nil>>; symbolic procedure superprintm(x,lmar); << superprinm(x,lmar); terpri(); x >>; % From here down the functions are not intended for direct use. symbolic procedure superprinm(x,lmar); begin scalar stack,bufferi,buffero,bn,initialblanks,rmar, pendingrpars,indentlevel,indblanks,rparcount,w; bufferi:=buffero:=list nil; %fifo buffer. initialblanks:=0; rparcount:=0; indblanks:=0; rmar:=linelength(nil); % right margin. linelength 500; % To try to be extra cautious if rmar<25 then error(0,list(rmar, "Linelength too short for superprinting")); bn:=0; %characters in buffer. indentlevel:=0; %no indentation needed, yet. if lmar+20>=rmar then lmar:=rmar - 21; %no room for specified margin w:=posn(); if w>lmar then << terpri(); w:=0 >>; if w> else begin scalar cx; if 4*n>3*rmar then << %list is too deep for sanity. s!:overflow 'all; n:=truncate(n, 8); if initialblanks>n then << lmar:=lmar - initialblanks+n; initialblanks:=n >> >>; stack := (s!:newframe n) . stack; s!:putch ('lpar . s!:top()); cx:=car x; s!:prindent(cx,n+1); if idp cx and not atom cdr x then cx:=get(cx,'s!:ppformat) else cx:=nil; if cx=2 and atom cddr x then cx:=nil; if cx='prog then << s!:putch '! ; s!:prindent(car (x:=cdr x),n+3) >>; % CX now controls the formatting of what follows: % nil default action % first few blanks are non-indenting % prog display atoms as labels. x:=cdr x; scan: if atom x then go to outt; s!:finishpending(); %about to print a blank. if cx='prog then << s!:putblank(); s!:overflow bufferi; %force format for prog. if atom car x then << % a label. lmar:=initialblanks:=max(lmar - 6,0); s!:prindent(car x,n - 3); % print the label. x:=cdr x; if not atom x and atom car x then go to scan; if lmar+bn>n then s!:putblank() else for i:=lmar+bn:n - 1 do s!:putch '! ; if atom x then go to outt>> >> else if numberp cx then << cx:=cx - 1; if cx=0 then cx:=nil; s!:putch '! >> else s!:putblank(); s!:prindent(car x,n+3); x:=cdr x; go to scan; outt: if not null x then << s!:finishpending(); s!:putblank(); s!:putch '!.; s!:putch '! ; s!:prindent(x,n+5) >>; s!:putch ('rpar . (n - 3)); if s!:indenting s!:top()='indent and not null s!:blanklist s!:top() then s!:overflow car s!:blanklist s!:top() else s!:endlist s!:top(); stack:=cdr stack end; symbolic procedure s!:explodes x; %dummy function just in case another format is needed. explode x; symbolic procedure s!:prvector(x,n); begin scalar bound; bound:=upbv x; % length of the vector. stack:=(s!:newframe n) . stack; s!:putch ('lsquare . s!:top()); s!:prindent(getv(x,0),n+3); for i:=1:bound do << s!:putch '!,; s!:putblank(); s!:prindent(getv(x,i),n+3) >>; s!:putch('rsquare . (n - 3)); s!:endlist s!:top(); stack:=cdr stack end; symbolic procedure s!:putblank(); begin s!:putch s!:top(); %represents a blank character. s!:setblankcount(s!:top(),s!:blankcount s!:top()+1); s!:setblanklist(s!:top(),bufferi . s!:blanklist s!:top()); %remember where I was. indblanks:=indblanks+1 end; symbolic procedure s!:endlist l; %Fix up the blanks in a complete list so that they %will not be turned into indentations. pendingrpars:=l . pendingrpars; % When I have printed a ')' I want to mark all of the blanks % within the parentheses as being unindented, ordinary blank % characters. It is however possible that I may get a buffer % overflow while printing a string of )))))))))), and so this % marking should be delayed until I get round to printing % a further blank (which will be a candidate for a place to % split lines). This delay is dealt with by the list % pendingrpars which holds a list of levels that, when % convenient, can be tidied up and closed out. symbolic procedure s!:finishpending(); << for each stackframe in pendingrpars do << if s!:indenting stackframe neq 'indent then for each b in s!:blanklist stackframe do << rplaca(b,'! ); indblanks:=indblanks - 1>>; % s!:blanklist of stackframe must be non-nil so that overflow % will not treat the '(' specially. s!:setblanklist(stackframe,t) >>; pendingrpars:=nil >>; symbolic procedure s!:quotep x; !*quotes and not atom x and car x='quote and not atom cdr x and null cddr x; % property s!:ppformat drives the prettyprinter - % prog : special for prog only % 1 : (fn a1 % a2 % ... ) % 2 : (fn a1 a2 % a3 % ... ) ; put('prog,'s!:ppformat,'prog); put('lambda,'s!:ppformat,1); put('lambdaq,'s!:ppformat,1); put('setq,'s!:ppformat,1); put('set,'s!:ppformat,1); put('while,'s!:ppformat,1); put('t,'s!:ppformat,1); put('de,'s!:ppformat,2); put('df,'s!:ppformat,2); put('dm,'s!:ppformat,2); put('defun,'s!:ppformat,2); put('defmacro,'s!:ppformat,2); put('foreach,'s!:ppformat,4); % (foreach x in y do ...) etc. % Now for the routines that buffer things on a character by character % basis, and deal with buffer overflow. symbolic procedure s!:putch c; begin if atom c then rparcount:=0 else if s!:blankp c then << rparcount:=0; go to nocheck >> else if car c='rpar then << rparcount:=rparcount+1; % format for a long string of rpars is: % )))) ))) ))) ))) ))) ; if rparcount>4 then << s!:putch '! ; rparcount:=2 >> >> else rparcount:=0; while lmar+bn>=rmar do s!:overflow 'more; nocheck: bufferi:=cdr rplacd(bufferi,list c); bn:=bn+1 end; symbolic procedure s!:overflow flg; begin scalar c,blankstoskip; % The current buffer holds so much information that it will % not all fit on a line. try to do something about it. % flg is one of: % 'none do not force more indentation % 'more force one level more indentation % % prints up to and including that character, which % should be a blank. if indblanks=0 and initialblanks>3 and flg='more then << initialblanks:=initialblanks - 3; lmar:=lmar - 3; return 'moved!-left >>; fblank: if bn=0 then << % No blank found - can do no more for now. % If flg='more I am in trouble and so have to print % a continuation mark. in the other cases I can just exit. if not(flg = 'more) then return 'empty; if atom car buffero then % continuation mark not needed if last char printed was % special (e.g. lpar or rpar). prin2 "%+"; %continuation marker. terpri(); lmar:=0; return 'continued >> else << spaces initialblanks; initialblanks:=0 >>; buffero:=cdr buffero; bn:=bn - 1; lmar:=lmar+1; c:=car buffero; if atom c then << prin2 c; go to fblank >> else if s!:blankp c then if not atom blankstoskip then << prin2 '! ; indblanks:=indblanks - 1; % blankstoskip = (stack-frame . skip-count). if c eq car blankstoskip then << rplacd(blankstoskip,cdr blankstoskip - 1); if cdr blankstoskip=0 then blankstoskip:=t >>; go to fblank >> else go to blankfound else if car c='lpar or car c='lsquare then << prin2 get(car c,'s!:ppchar); if flg='none then go to fblank; % now I want to flag this level for indentation. c:=cdr c; %the stack frame. if not null s!:blanklist c then go to fblank; if s!:depth c>indentlevel then << %new indentation. % this level has not emitted any blanks yet. indentlevel:=s!:depth c; s!:setindenting(c,'indent) >>; go to fblank >> else if car c='rpar or car c='rsquare then << if cdr c> else error(0,list(c,"UNKNOWN TAG IN OVERFLOW")); blankfound: if eqcar(s!:blanklist c,buffero) then s!:setblanklist(c,nil); % at least one entry on blanklist ought to be valid, so if I % print the last blank I must kill blanklist totally. indblanks:=indblanks - 1; % check if next level represents new indentation. if s!:depth c>indentlevel then << if flg='none then << %just print an ordinary blank. prin2 '! ; go to fblank >>; % here I increase the indentation level by one. if blankstoskip then blankstoskip:=nil else << indentlevel:=s!:depth c; s!:setindenting(c,'indent) >> >>; %otherwise I was indenting at that level anyway. if s!:blankcount c>(thin!* - 1) then << %long thin list fix-up here. blankstoskip:=c . ((s!:blankcount c) - 2); s!:setindenting(c,'thin); s!:setblankcount(c,1); indentlevel:=(s!:depth c) - 1; prin2 '! ; go to fblank >>; s!:setblankcount(c,(s!:blankcount c) - 1); terpri(); lmar:=initialblanks:=s!:depth c; if buffero eq flg then return 'to!-flg; if blankstoskip or not (flg='more) then go to fblank; % keep going unless call was of type 'more'. return 'more; %try some more. end; put('lpar,'s!:ppchar,'!(); put('lsquare,'s!:ppchar,'![); put('rpar,'s!:ppchar,'!)); put('rsquare,'s!:ppchar,'!]); % Now some (experimental) support for network access symbolic procedure fetch!-url(url, !&optional, dest); begin scalar a, b, c, d, e, w; a := open!-url url; if null a then return nil; if dest then << d := open(dest, 'output); if null d then << close a; return error(0, "unable to open destination file") >>; d := wrs d >>; b := rds a; w := linelength 500; while not ((c := readch()) = !$eof!$) do princ c; linelength e; rds b; close a; if dest then close wrs d end; end; % end of extras.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/struct.red0000644000175000017500000002727511550002751023607 0ustar giovannigiovanni % Author: Anthony C. Hearn. % This code is designed to structure Lisp and REDUCE code. The result % should have the same execution behavior as the input. % The next few bits are to make this code free-standing... symbolic procedure lprim x; print x; symbolic procedure no!-side!-effectp u; if atom u then numberp u or idp u and not(fluidp u or globalp u) else if car u eq 'quote then t else if flagp!*!*(car u,'nosideeffects) then no!-side!-effect!-listp u else nil; symbolic procedure no!-side!-effect!-listp u; null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u; flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons),'nosideeffects); % Currently code does not check for duplicate labels. symbolic procedure structchk u; % Top level structuring function. begin scalar v; repeat <> until u = v; return u end; symbolic procedure structchk1 u; begin scalar x; if atom u or car u eq 'quote then return u else if atom car u and (x := get(car u,'structfn)) then return apply(x,list u) else if car u eq 'lambda then return list('lambda,cadr u,structchk1 caddr u) else if car u eq 'procedure then return list('procedure,cadr u,caddr u,cadddr u, car cddddr u,structchk1 cadr cddddr u) else return for each x in u collect structchk1 x end; put('cond,'structfn,'strcond); put('rblock,'structfn,'blockchk); put('prog,'structfn,'progchk); put('progn,'structfn,'prognchk); symbolic procedure strcond u; begin u := for each x in cdr u collect list(car x,structchk1 cadr x); if length u = 2 and eqcar(cadar u,'cond) and caadr u = 't then u := {mknot caar u,cadadr u} . cdadar u; return 'cond . u end; symbolic procedure mknot u; if not atom u and car u memq '(not null) then cadr u else {'not,u}; fluid '(flg lablist); symbolic procedure addlbl lbl; if atsoc(lbl,lablist) then nil else lablist := list(lbl,nil) . lablist; symbolic procedure addblock lst; rplacd(cdr atsoc(getlbl caar lst,lablist),cdar lst . cdr lst); symbolic procedure gochk u; if atom u or car u memq '(quote prog) then nil else if car u eq 'go then updlbl(cadr u,u) else <>; symbolic procedure updlbl(lbl,exp); begin scalar x; x := atsoc(lbl,lablist); if x then rplaca(cdr x,exp . cadr x) else lablist := list(lbl,list exp) . lablist end; symbolic procedure transferp u; if atom u or not idp car u then nil else if flagp(car u,'transfer) then car u else if car u eq 'cond then condtranp cdr u else if car u memq '(prog2 progn) then transferp car reverse cdr u else nil; flag('(go return rederr error errach),'transfer); symbolic procedure condtranp u; % Determines if every branch of a COND is a transfer. if null u then nil else if null cdr u and caar u eq t then transferp cadar u else transferp cadar u and condtranp cdr u; symbolic procedure progchk u; blockchk1(u,'prog); symbolic procedure blockchk u; blockchk1(u,'rblock); symbolic procedure blockchk1(u,v); begin scalar flg,lablist,laststat,vars,top,x,z; % Format of element of LABLIST is (label,list of references,body). vars := cadr u; % Define independent blocks. u := cddr u; if null u then lprie "empty block"; % First make sure that block does not 'fall through'. x := u; while cdr x do x := cdr x; % if not transferp car x then rplacd(x,list '(return nil)); % Now look for first label. while u and not labelp car u do <>; % Should that be structchk1 car u? if null u then <> else if null top or not transferp car top then <>; top := reversip top; top := list nil . nil . top . car reverse top; % lablist format. while u do if labelp car u then <>; addblock(reversip x . laststat); x := nil>>>> else rederr list("unreachable statement",car u); % Merging of blocks. lablist := reversip lablist; % To make final order correct. a: flg := nil; % Removal of (cond ... (pi (go lab)) ...) ... (go lab)). for each x in (top . lablist) do if cdr x and cddr x and eqcar(cdddr x,'go) then condgochk(caddr x,cdddr x); % Replacement of singly referenced labels by PROGN. x := nil; while lablist do <> else x := car lablist . x; lablist := cdr lablist>>; lablist := reversip x; % WHILE/REPEAT insertion. for each z in lablist do if cdddr z = caadr z and eqcar(caaddr z,'cond) and null cddr caaddr z and transferp cadadr caaddr z and notranp cdaddr z then <>; % Superfluous PROGN expansion. if flg then for each y in top . lablist do <>; if flg then go to a; top := caddr top; % Retrieve true expression. x := top; % Pick up remaining labels. while x do <>); lablist := delete(z,lablist)>> else if lablist then <> else x := cdr x>>; ret: top := miscchk structchk1 top; if null vars and eqcar(car top,'return) then return cadar top else return v . vars . top; end; symbolic procedure miscchk u; % Check for miscellaneous constructs. begin scalar v,w; % x v := u; % x := copy u; while v do if eqcar(car v,'setq) and ((w := setqchk(car v,cdr v)) neq v) then rplacw(v,w) else if cdr v and eqcar(car v,'cond) and null cddar v and eqcar(cadr cadar v,'return) % Next line should be generalized to (...) ... (return ...). and eqcar(cadr v,'return) then rplacw(v,{'return, {'cond,{caadar v,cadr cadr cadar v}, {'t,cadr cadr v}}} . cddr v) else v := cdr v; % return if u = x then u else miscchk u return u end; symbolic procedure setqchk(u,v); % Determine if setq in u is necessary. begin scalar x,y,z; x := cadr u; y := caddr u; if not no!-side!-effectp y then return u . v; a: if null v then return u . reversip z % else if eqcar(car v,'return) and not smemq(x,cdar v) % then return nconc(reversip z,v) else if eqcar(car v,'return) and used!-oncep(x,cadar v) then <> else if not smemq(x,car v) then <> else return u . nconc(reversip z,v) end; symbolic procedure used!-oncep(u,v); % Determines if u is used at most once in v. if atom v then t else if car v eq 'quote then t else if u eq car v then not smemq(u,cdr v) else used!-oncep(u,cdr v); symbolic procedure substq(u,v,w); % Substitute first occurrence of atom u in w by v. if atom w then if u eq w then v else w else if car w eq 'quote then w else if u eq car w then v . cdr w else if not atom car w then substq(u,v,car w) . substq(u,v,cdr w) else car w . substq(u,v,cdr w); symbolic procedure labelp u; atom u or car u eq '!*label; symbolic procedure getlbl u; if atom u then u else cadr u; symbolic procedure mklbl u; list('!*label,u); symbolic procedure notranp u; null smemqlp('(go return),cdr reverse u); symbolic procedure !&deleq(u,v); if null v then nil else if u eq car v then cdr v else car v . !&deleq(u,cdr v); symbolic procedure prognchk u; prognchk1 cdr u; symbolic procedure prognchk1 u; if null cdr u or null cdr(u:= miscchk u) then car u else 'progn . u; symbolic procedure mknull u; if not atom u and car u memq '(null not) then cadr u else list('null,u); symbolic procedure condgochk(u,v); if null u then nil else <>; symbolic procedure cgchk1(u,v,w); if null u then nil else if not transferp cadar u then nil % We could look for following (T transfer) here. else begin scalar x,y,z; cgchk1(cdr u,v,w); x := cadar u; if x=w or eqcar(x,'progn) and (x := car reverse x)=w and (y := reverse cdr reverse cdadar u) then <>; if y then rplacd(u,list list(t,prognchk1 y)); rplaca(cdar u,prognchk1 z); rplacd(v,list w)>> else nil end; % The following routines transform MAPs into FOR EACH statements % were possible; symbolic procedure mapox u; mapsox(u,'on,'do); symbolic procedure mapcox u; mapsox(u,'in,'do); symbolic procedure maplistox u; mapsox(u,'on,'collect); symbolic procedure mapcarox u; mapsox(u,'in,'collect); symbolic procedure mapconox u; mapsox(u,'on,'conc); symbolic procedure mapcanox u; mapsox(u,'in,'conc); symbolic procedure mapsox(u,v,w); begin scalar x,y,z; x := cadr u; y := caddr u; if not eqcar(y,'function) then rederr list("syntax error in map expression",u); y := cadr y; if atom y then <>; return list('foreach,z,v,x,w,y) end; put('map,'structfn,'mapox); put('mapc,'structfn,'mapcox); put('maplist,'structfn,'maplistox); put('mapcar,'structfn,'mapcarox); put('mapcan,'structfn,'mapcanox); put('mapcon,'structfn,'mapconox); symbolic procedure whilechk(u,v); begin scalar w; % Note that V is in reversed order. return if idp(u) and car v = list('setq,u,list('cdr,u)) and not((w := caronly(u,cdr v,'j)) eq '!*failed!*) then list('progn,list('foreach,'j,'in,u,'do,prognchk1 reversip w), list('setq,u,nil)) else list('while,u,prognchk1 reversip v) end; symbolic procedure caronly(u,v,w); begin scalar x; return if not smemq(u,v) then v else if atom v then if u eq v then '!*failed!* else v else if not idp car v or not(eqcar(cdr v,u) and cdr v and null cddr v and (x := get(car v,'carfn))) then cmerge(caronly(u,car v,w),caronly(u,cdr v,w)) else if car v eq 'car then w else list(x,w) end; deflist('((car t) (caar car) (cdar cdr) (caaar caar) (cadar cadr) (cdaar cdar) (cddar cddr) (caaaar caaar) (caadar caadr) (cadaar cadar) (caddar caddr) (cdaaar cdaar) (cdadar cdadr) (cddaar cddar) (cdddar cdddr)), 'carfn); symbolic procedure cmerge(u,v); if u eq '!*failed!* or v eq '!*failed!* then '!*failed!* else u . v; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/testrest.red0000644000175000017500000000116111550002751024122 0ustar giovannigiovanni% % This script is normally run as % ./r38 ../util/testall.red -D@srcdir=DIR -Dwhich_module=XXX % where XXX is the name of a module that is to be tested. If XXX is left % empty then the script will test all known modules. % symbolic; load!-module 'remake; get_configuration_data t; report_incomplete_tests r38_test_cases; if boundp 'which_module and which_module and not (which_module = "") then << mods := compress explodec which_module; if member(mods, r38_test_cases) then complete_tests list mods else error(0, list("unknown module to test", which_module)) >> else complete_tests r38_test_cases; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/i86.red0000644000175000017500000000061311550002751022654 0ustar giovannigiovanni lisp; on comp; in "i86comp.red"$ on backtrace; !*genlisting := t; symbolic procedure foo x; if x then 'one else 'two; i86!-compile '(de foo (x) (if x 'one 'two)); symbolic procedure fact n; if n = 0 then 1 else n * fact sub1 n; i86!-compile '(de fact (n) (if (equal n 0) 1 (times n (fact (sub1 n))))); symbol!-env 'fact; fact 0; fact 1; fact 2; fact 5; fact 10; preserve(); end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/get-definitions.red0000755000175000017500000000406011550002751025341 0ustar giovannigiovanni% Get definitions for Reduce functions lisp; on echo, comp, backtrace; load!-module 'compiler; % The following line will be left over from the system build if you build % bootstrapreduce.img on the system you are now using! If not you need % to adjust and activate this. % @srcdir := "/cygdrive/c/projects/reduce-algebra/trunk/csl/cslbase"; << m := open("$srcdir/../../src/packages/package.map", 'input); oldi := rds m; off echo; packages := read(); on echo; rds oldi; close m >>; symbolic procedure record!-a!-def(name, modname, type, d); put(name, 'definition, union(get(name, 'definition), list list(modname, type, d))); symbolic procedure record!-defs!-for!-name(name, modname); begin scalar d, c; if (d := get(name, 'smacro)) and (c := md5 d) neq get(name, 'smacro!-checksum) then << record!-a!-def(name, modname, 'smacro, d); put(name, 'smacro!-checksum, c) >>; if (d := get(name, '!*savedef)) and (c := md5 d) neq get(name, 'expr!-checksum) then << record!-a!-def(name, modname, 'expr, d); put(name, 'expr!-checksum, c) >>; end; symbolic procedure record!-defs modname; for each name in oblist() do record!-defs!-for!-name(name, modname); record!-defs 'core; load!-source := t; % So that savedefs get loaded without any checksum checking. for each modname in packages do if modulep car modname then << % princ "+++ About to load "; print car modname; load!-source car modname; record!-defs car modname >>; defined := nil; for each name in oblist() do if get(name, 'definition) then defined := name . defined; defined := sort(defined, 'orderp)$ % Here I illustrate what I have collected by displaying cases where % there seem to be two (or more) potentially conflicting definitions. << terpri(); for each name in defined do if length get(name, 'definition) > 1 then << print name; for each d in get(name, 'definition) do << princ "Defined as "; prin cadr d; princ " in package "; print car d >>; terpri() >> >>; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/lispfile.lsp0000644000175000017500000034226711550002751024117 0ustar giovannigiovanni% % Create Standard Lisp versions of the source files for CSL where I keep % the master versions coded in RLISP. % % Since this is (probably) not done very often I build a version of % RLISP specially for the occasion. % % Run this as % csl -z lispfile.lsp % % or csl -z lispfile.lsp -D@cslbase="" % (eg csl -z lispfile.lsp -D@cslbase="d:\acn\cslbase") (spool "lispfile.log") (load!-module 'compat) % Note that if too much of the system has changed or been damaged it may % be necessary to disable the compiler here (by commenting out the next % couple of lines). This code should then run correctly but painfully % slowly. (load!-module 'compiler) (setq !*comp t) % % If the files compat.fsl and compiler.fsl had been corrupted you % could go % (rdf "compat.lsp") % here... then later on see (*) % (de symerr (u v) (progn (terpri) (print (list 'symerr u v)) (error 'failure))) % Standard LISP equivalent of BOOT.RED. (fluid '(!*blockp !*mode)) (global '(oldchan!*)) (global '(crchar!* cursym!* fname!* nxtsym!* ttype!* !$eol!$)) (put '!; 'switch!* '(nil !*semicol!*)) (put '!( 'switch!* '(nil !*lpar!*)) (put '!) 'switch!* '(nil !*rpar!*)) (put '!, 'switch!* '(nil !*comma!*)) (put '!. 'switch!* '(nil cons)) (put '!: 'switch!* '(((!= nil setq)) !*colon!*)) (put '!*comma!* 'infix 1) (put 'setq 'infix 2) (put 'cons 'infix 3) (flag '(!*comma!*) 'nary) (flag '(!*colon!* !*semicol!* end then else) 'delim) (put 'begin 'stat 'blockstat) (put 'if 'stat 'ifstat) (put 'symbolic 'stat 'procstat) (de begin2 nil (prog nil (setq cursym!* '!*semicol!*) a (cond ((eq cursym!* 'end) (progn (rds oldchan!*) (return nil))) (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) (go a))) (de form (u) u) (de xread (u) (progn (scan) (xread1 u))) (de xread1 (u) (prog (v w x y z z2) a (setq z cursym!*) a1 (cond ((or (null (atom z)) (numberp z)) (setq y nil)) ((flagp z 'delim) (go end1)) ((eq z '!*lpar!*) (go lparen)) ((eq z '!*rpar!*) (go end1)) ((setq y (get z 'infix)) (go infx)) ((setq y (get z 'stat)) (go stat))) a3 (setq w (cons z w)) next (setq z (scan)) (go a1) lparen(setq y nil) (cond ((eq (scan) '!*rpar!*) (and w (setq w (cons (list (car w)) (cdr w)))) ) ((eqcar (setq z (xread1 'paren)) '!*comma!*) (setq w (cons (cons (car w) (cdr z)) (cdr w)))) (t (go a3))) (go next) infx (setq z2 (mkvar (car w) z)) un1 (setq w (cdr w)) (cond ((null w) (go un2)) (t (setq z2 (cons (car w) (list z2)))) ) (go un1) un2 (setq v (cons z2 v)) preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) pr1 (setq x (cons (cons y z) x)) (go next) pr2 (setq v (cons (cond ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) (cons (cdar x) (cons (cadr v) (cdar v)))) (t (cons (cdar x) (list (cadr v) (car v)))) ) (cdr (cdr v)))) (setq x (cdr x)) (go preced) stat (setq w (cons (eval (list y)) w)) (setq y nil) (go a) end1 (cond ((and (and (null v) (null w)) (null x)) (return nil)) (t (setq y 0))) (go infx) pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) % (de eqcar (u v) (and (null (atom u)) (eq (car u) v))) (de mksetq (u v) (list 'setq u v)) (de mkvar (u v) u) (de rread nil (prog (x) (setq x (token)) (return (cond ((and (equal ttype!* 3) (eq x '!()) (rrdls)) (t x)))) ) (de reverse2 (a b) (prog nil a (cond ((null a) (return b))) (setq b (cons (car a) b)) (setq a (cdr a)))) (de rrdls nil (prog (x r) a (setq x (rread)) (cond ((null (equal ttype!* 3)) (go b)) ((eq x '!)) (return (reversip r))) ((null (eq x '!.)) (go b))) (setq x (rread)) (token) (return (reverse2 r x)) b (setq r (cons x r)) (go a))) (de token nil (prog (x y) (setq x crchar!*) a (cond ((seprp x) (go sepr)) ((digit x) (go number)) ((liter x) (go letter)) ((eq x '!%) (go coment)) ((eq x '!!) (go escape)) ((eq x '!') (go quote)) ((eq x '!") (go string))) (setq ttype!* 3) (cond ((delcp x) (go d))) (setq nxtsym!* x) a1 (setq crchar!* (readch)) (go c) escape(setq y (cons x y)) (setq x (readch)) letter(setq ttype!* 0) let1 (setq y (cons x y)) (cond ((or (digit (setq x (readch))) (liter x)) (go let1)) ((eq x '!!) (go escape))) (setq nxtsym!* (intern (compress (reverse y)))) b (setq crchar!* x) c (return nxtsym!*) number(setq ttype!* 2) num1 (setq y (cons x y)) (cond ((digit (setq x (readch))) (go num1))) (setq nxtsym!* (compress (reverse y))) (go b) quote (setq crchar!* (readch)) (setq nxtsym!* (list 'quote (rread))) (setq ttype!* 4) (go c) string(prog (raise) (setq raise !*raise) (setq !*raise nil) strinx(setq y (cons x y)) (cond ((null (eq (setq x (readch)) '!")) (go strinx))) (setq y (cons x y)) (setq nxtsym!* (mkstrng (compress (reverse y)))) (setq !*raise raise)) (setq ttype!* 1) (go a1) coment(cond ((null (eq (readch) !$eol!$)) (go coment))) sepr (setq x (readch)) (go a) d (setq nxtsym!* x) (setq crchar!* '! ) (go c))) (setq crchar!* '! ) (de delcp (u) (or (eq u '!;) (eq u '!$))) (de mkstrng (u) u) (de scan nil (prog (x y) (cond ((null (eq cursym!* '!*semicol!*)) (go b))) a (setq nxtsym!* (token)) b (cond ((or (null (atom nxtsym!*)) (numberp nxtsym!*)) (go l)) ((and (setq x (get nxtsym!* 'newnam)) (setq nxtsym!* x)) (go b)) ((eq nxtsym!* 'comment) (go comm)) ((and (eq nxtsym!* '!') (setq cursym!* (list 'quote (rread)))) (go l1)) ((null (setq x (get nxtsym!* 'switch!*))) (go l)) ((eq (cadr x) '!*semicol!*) (return (setq cursym!* (cadr x)))) ) sw1 (setq nxtsym!* (token)) (cond ((or (null (car x)) (null (setq y (assoc nxtsym!* (car x)))) ) (return (setq cursym!* (cadr x)))) ) (setq x (cdr y)) (go sw1) comm (cond ((eq (readch) '!;) (setq crchar!* '! )) (t (go comm))) (go a) l (setq cursym!* (cond ((null (eqcar nxtsym!* 'string)) nxtsym!*) (t (cons 'quote (cdr nxtsym!*)))) ) l1 (setq nxtsym!* (token)) (return cursym!*))) (de ifstat nil (prog (condx condit) a (setq condx (xread t)) (setq condit (nconc condit (list (list condx (xread t)))) ) (cond ((null (eq cursym!* 'else)) (go b)) ((eq (scan) 'if) (go a)) (t (setq condit (nconc condit (list (list t (xread1 t)))) ))) b (return (cons 'cond condit)))) (de procstat nil (prog (x y) (cond ((eq cursym!* 'symbolic) (scan))) (cond ((eq cursym!* '!*semicol!*) (return (null (setq !*mode 'symbolic)))) ) (setq fname!* (scan)) (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) (setq y (xread nil)) (cond ((flagp (car x) 'lose) (return nil))) (putd (car x) 'expr (list 'lambda (cdr x) y)) (setq fname!* nil) (return (list 'quote (car x)))) ) (de blockstat nil (prog (x hold varlis !*blockp) a0 (setq !*blockp t) (scan) (cond ((null (or (eq cursym!* 'integer) (eq cursym!* 'scalar))) (go a))) (setq x (xread nil)) (setq varlis (nconc (cond ((eqcar x '!*comma!*) (cdr x)) (t (list x))) varlis)) (go a0) a (setq hold (nconc hold (list (xread1 nil)))) (setq x cursym!*) (scan) (cond ((not (eq x 'end)) (go a))) (return (mkprog varlis hold)))) (de mkprog (u v) (cons 'prog (cons u v))) (de gostat nil (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) (put 'go 'stat 'gostat) (de rlis nil (prog (x) (setq x cursym!*) (return (cond ((not (flagp (scan) 'delim)) (list x (list 'quote (list (xread1 t))))) (t (list x)))))) (begin2) % % This file is "rlisp.red" taken from the REDUCE 3.3 sources, and can be % used to reconstruct the CSL files compiler.lsp and ccomp.lsp from % the associated RLISP source files. Note that REDUCE 3.3 is now a % VERY old and out-of-date system, and the code here is only from the % parser from it - no algebra is included. % % module module; % Support for module use. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(exportslist!* importslist!* module!-name!* old!-mode!*); !*mode := 'symbolic; % initial value. symbolic procedure exports u; begin exportslist!* := union(u,exportslist!*); end; symbolic procedure imports u; begin importslist!* := union(u,importslist!*); end; symbolic procedure module u; %Sets up a module definition; begin if null module!-name!* then old!-mode!* := !*mode; module!-name!* := car u . module!-name!*; !*mode := 'symbolic end; symbolic procedure endmodule; begin if null module!-name!* then rederr "ENDMODULE called outside module"; exportslist!* := nil; importslist!* := nil; module!-name!* := cdr module!-name!*; if module!-name!* then return nil; !*mode := old!-mode!*; old!-mode!* := nil end; deflist('((exports rlis) (imports rlis) (module rlis)),'stat); if null get('endmodule, 'stat) then put('endmodule,'stat,'rlis); % For bootstrap only flag('(endmodule),'go); % endmodule; module newtok; % Functions for introducing infix tokens to the system. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*redeflg!*); global '(!*msg preclis!*); %Several operators in REDUCE are used in an infix form (e.g., %+,- ). The internal alphanumeric names associated with these %operators are introduced by the function NEWTOK defined below. %This association, and the precedence of each infix operator, is %initialized in this section. We also associate printing characters %with each internal alphanumeric name as well; preclis!*:= '(or and not member memq equal neq eq geq greaterp leq lessp freeof plus difference times quotient expt cons); deflist ('( (not not) (plus plus) (difference minus) (minus minus) (times times) (quotient recip) (recip recip) ), 'unary); flag ('(and or !*comma!* plus times),'nary); flag ('(cons setq plus times),'right); deflist ('((minus plus) (recip times)),'alt); symbolic procedure mkprec; begin scalar x,y,z; x := 'where . ('!*comma!* . ('setq . preclis!*)); y := 1; a: if null x then return nil; put(car x,'infix,y); put(car x,'op,list list(y,y)); %for RPRINT; if z := get(car x,'unary) then put(z,'infix,y); if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y)); x := cdr x; y := add1 y; go to a end; mkprec(); symbolic procedure newtok u; begin scalar !*redeflg!*,x,y; if atom u or atom car u or null idp caar u then typerr(u,"NEWTOK argument"); % set up SWITCH* property. put(caar u,'switch!*, cdr newtok1(car u,cadr u,get(caar u,'switch!*))); % set up PRTCH property. y := intern compress consescc car u; if !*redeflg!* then lprim list(y,"redefined"); put(cadr u,'prtch,y); if x := get(cadr u,'unary) then put(x,'prtch,y) end; symbolic procedure newtok1(charlist,name,propy); if null propy then lstchr(charlist,name) else if null cdr charlist then begin if cdr propy and !*msg then !*redeflg!* := t; return list(car charlist,car propy,name) end else car charlist . newtok2(cdr charlist,name,car propy) . cdr propy; symbolic procedure newtok2(charlist,name,assoclist); if null assoclist then list lstchr(charlist,name) else if car charlist eq caar assoclist then newtok1(charlist,name,cdar assoclist) . cdr assoclist else car assoclist . newtok2(charlist,name,cdr assoclist); symbolic procedure consescc u; if null u then nil else '!! . car u . consescc cdr u; symbolic procedure lstchr(u,v); if null cdr u then list(car u,nil,v) else list(car u,list lstchr(cdr u,v)); newtok '((!$) !*semicol!*); newtok '((!;) !*semicol!*); newtok '((!+) plus); newtok '((!-) difference); newtok '((!*) times); newtok '((!^) expt); newtok '((!* !*) expt); newtok '((!/) quotient); newtok '((!=) equal); newtok '((!,) !*comma!*); newtok '((!() !*lpar!*); newtok '((!)) !*rpar!*); newtok '((!:) !*colon!*); newtok '((!: !=) setq); newtok '((!.) cons); newtok '((!<) lessp); newtok '((!< !=) leq); newtok '((!< !<) !*lsqb!*); newtok '((!>) greaterp); newtok '((!> !=) geq); newtok '((!> !>) !*rsqb!*); put('expt,'prtch,'!*!*); % To ensure that FORTRAN output is correct. flag('(difference minus plus setq),'spaced); flag('(newtok),'eval); endmodule; module support; % Basic functions needed to support RLISP and REDUCE. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure aconc(u,v); %adds element v to the tail of u. u is destroyed in process; nconc(u,list v); symbolic procedure arrayp u; get(u,'rtype) eq 'array; symbolic procedure atsoc(u,v); if null v then nil else if u eq caar v then car v else atsoc(u,cdr v); symbolic procedure eqcar(u,v); null atom u and car u eq v; symbolic procedure flagpcar(u,v); null atom u and idp car u and flagp(car u,v); symbolic procedure idlistp u; % True if u is a list of id's. null u or null atom u and idp car u and idlistp cdr u; symbolic procedure mkprog(u,v); 'prog . (u . v); symbolic procedure mkquote u; list('quote,u); symbolic procedure mksetq(u,v); list('setq,u,v); symbolic procedure pairvars(u,vars,mode); % Sets up pairings of parameters and modes. begin scalar x; a: if null u then return append(reversip!* x,vars) else if null idp car u then symerr("Invalid parameter",nil); x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure prin2t u; progn(prin2 u, terpri(), u); symbolic procedure reversip u; begin scalar x,y; a: if null u then return y; x := cdr u; y := rplacd(u,y); u := x; go to a end; symbolic procedure smemq(u,v); %true if id U is a member of V at any level (excluding %quoted expressions); if atom v then u eq v else if car v eq 'quote then nil else smemq(u,car v) or smemq(u,cdr v); symbolic procedure union(x,y); if null x then y else union(cdr x,if car x member y then y else car x . y); symbolic procedure xn(u,v); if null u then nil else if car u member v then car u . xn(cdr u,delete(car u,v)) else xn(cdr u,v); symbolic procedure u>=v; null(uv); symbolic procedure u neq v; null(u=v); symbolic procedure setdiff(u,v); if null v then u else setdiff(delete(car v,u),cdr v); % symbolic smacro procedure u>=v; null(uv); % symbolic smacro procedure u neq v; null(u=v); % List changing alternates (may also be defined as copying functions) symbolic procedure aconc!*(u,v); nconc(u,list v); % append(u,list v); symbolic procedure nconc!*(u,v); nconc(u,v); % append(u,v); symbolic procedure reversip!* u; reversip u; % reverse u; symbolic procedure rplaca!*(u,v); rplaca(u,v); % v . cdr u; symbolic procedure rplacd!*(u,v); rplacd(u,v); % car u . v; % The following functions should be provided in the compiler for % efficient coding. symbolic procedure apply1(u,v); apply(u,list v); symbolic procedure apply2(u,v,w); apply(u,list(v,w)); symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x)); % The following function is needed by several modules. It is more % REDUCE-specific than other functions in this module, but since it % needs to be defined early on, it might as well go here. symbolic procedure gettype u; % Returns a REDUCE-related type for the expression U. % It needs to be more table driven than the current definition. if numberp u then 'number else if null atom u or null u or null idp u then 'form else if get(u,'simpfn) then 'operator else if get(u,'avalue) then 'variable else if getd u then 'procedure else if globalp u then 'global else if fluidp u then 'fluid else if flagp(u,'parm) then 'parameter else get(u,'rtype); endmodule; module slfns; % Complete list of Standard LISP functions. % Author: Anthony C. Hearn. global '(!*argnochk slfns!*); slfns!* := '( (abs 1) (add1 1) (append 2) (apply 2) (assoc 2) (atom 1) (car 1) (cdr 1) (caar 1) (cadr 1) (cdar 1) (cddr 1) (caaar 1) (caadr 1) (cadar 1) (caddr 1) (cdaar 1) (cdadr 1) (cddar 1) (cdddr 1) (caaaar 1) (caaadr 1) (caadar 1) (caaddr 1) (cadaar 1) (cadadr 1) (caddar 1) (cadddr 1) (cdaaar 1) (cdaadr 1) (cdadar 1) (cdaddr 1) (cddaar 1) (cddadr 1) (cdddar 1) (cddddr 1) (close 1) (codep 1) (compress 1) (cons 2) (constantp 1) (de 3) (deflist 2) (delete 2) % (DF 3) conflicts with algebraic operator DF (difference 2) (digit 1) (divide 2) (dm 3) (dn 3) (ds 3) (eject 0) (eq 2) (eqn 2) (equal 2) (error 2) (errorset 3) (eval 1) (evlis 1) (expand 2) (explode 1) (expt 2) (fix 1) (fixp 1) (flag 2) (flagp 2) (float 1) (floatp 1) (fluid 1) (fluidp 1) (function 1) (gensym 0) (get 2) (getd 1) (getv 2) (global 1) (globalp 1) (go 1) (greaterp 2) (idp 1) (intern 1) (length 1) (lessp 2) (linelength 1) (liter 1) (lposn 0) (map 2) (mapc 2) (mapcan 2) (mapcar 2) (mapcon 2) (maplist 2) (max2 2) (member 2) (memq 2) (minus 1) (minusp 1) (min2 2) (mkvect 1) (nconc 2) (not 1) (null 1) (numberp 1) (onep 1) (open 2) (pagelength 1) (pair 2) (pairp 1) (plus2 2) (posn 0) (print 1) (prin1 1) (prin2 1) (prog2 2) (put 3) (putd 3) (putv 3) (quote 1) (quotient 2) (rds 1) (read 0) (readch 0) (remainder 2) (remd 1) (remflag 2) (remob 1) (remprop 2) (return 1) (reverse 1) (rplaca 2) (rplacd 2) (sassoc 3) (set 2) (setq 2) (stringp 1) (sublis 2) (subst 3) (sub1 1) (terpri 0) (times2 2) (unfluid 1) (upbv 1) (vectorp 1) (wrs 1) (zerop 1) ); if !*argnochk then deflist(slfns!*,'number!-of!-args); endmodule; module superv; % REDUCE supervisory functions. % Author: Anthony C. Hearn. % Modified by: Jed B. Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*defn !*errcont !*int !*mode !*slin !*time dfprint!* lreadfn!* semic!* tslin!*); global '(!$eof!$ !*byeflag!* !*demo !*echo !*extraecho !*lessspace !*micro!-version !*nosave!* !*output !*pret !*rlisp2 !*strind !*struct cloc!* cmsg!* crbuf!* crbuflis!* crbuf1!* cursym!* eof!* erfg!* ifl!* ipl!* initl!* inputbuflis!* key!* ofl!* opl!* ogctime!* otime!* program!* programl!* promptexp!* resultbuflis!* st!* statcounter symchar!* tok!* ttype!* ws); !*output := t; eof!* := 0; initl!* := '(fname!* outl!*); statcounter := 0; % The true REDUCE supervisory function is BEGIN, again defined in the % system dependent part of this program. However, most of the work is % done by BEGIN1, which is called by BEGIN for every file encountered % on input; symbolic procedure errorp u; %returns true if U is an ERRORSET error format; atom u or cdr u; symbolic procedure flagp!*!*(u,v); idp u and flagp(u,v); symbolic procedure printprompt u; %Prints the prompt expression for input; progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*); symbolic procedure setcloc!*; % Used to set for file input a global variable CLOC!* to dotted pair % of file name and dotted pair of line and page being read. % Currently a place holder for system specific function, since not % supported in Standard LISP. CLOC!* is used in the INTER and RCREF % modules. cloc!* := if null ifl!* then nil else car ifl!* . nil; symbolic procedure command; begin scalar x; if !*demo and (x := ifl!*) then progn(terpri(),rds nil,readch(),rds cadr x); if null !*slin then if !*rlisp2 then progn(s!&(), key!* := tok!*, m!-metarlisp(), (if st!* then x := car st!* else x := nil), st!* := nil) else progn(scan(), setcloc!*(), key!* := cursym!*, x := xread1 nil) else progn(key!* := (semic!* := '!;), setcloc!*(), x := (if lreadfn!* then apply(lreadfn!*,nil) else read()), if key!* eq '!; then key!* := if atom x then x else car x); if !*struct then x := structchk x; if !*pret then progn(terpri(),rprint x); if null !*slin then x := form x; return x end; symbolic procedure begin1; begin scalar mode,parserr,result,x; if !*rlisp2 then prolog 'm!-metarlisp; otime!* := time(); % the next line is that way for bootstrapping purposes. if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0; a0: cursym!* := '!*semicol!*; a: if null terminalp() or !*nosave!* then go to b else if statcounter>0 then add2buflis(); statcounter := statcounter + 1; crbuf1!* := nil; % For input string editor. !*strind := 0; % Used by some versions of input editor. promptexp!* := compress('!! . append(explode statcounter, explode if null symchar!* or !*mode eq 'algebraic then '!:! else '!*! )); setpchar promptexp!*; b: parserr := nil; !*nosave!* := nil; if !*time then eval '(showtime); %Since a STAT; if !*output and null ofl!* and terminalp() and null !*defn and null !*lessspace then terpri(); if tslin!* then progn(!*slin := car tslin!*, lreadfn!* := cdr tslin!*, tslin!* := nil); mapcar(initl!*,function sinitl); if !*int then erfg!* := nil; %to make editing work properly; if null !*rlisp2 and cursym!* eq 'end then progn(comm1 'end, return nil) else if terminalp() and (!*rlisp2 or null(key!* eq 'ed)) then printprompt promptexp!*; program!* := errorset('(command),t,!*backtrace); if !*rlisp2 then if tok!* eq '!*semic!* then semic!* := '!; else semic!* := '!$; condterpri(); if errorp program!* then go to err1; program!* := car program!*; if eofcheck() then go to c else eof!* := 0; if !*rlisp2 then if program!* = '(end) then return nil else nil else if cursym!* eq 'end then if !*micro!-version and terminalp() then go to a0 else progn(comm1 'end, return nil) else if eqcar(program!*,'retry) then program!* := programl!*; %The following section decides what the target mode should be. %That mode is also assumed to be the printing mode; if flagp!*!*(key!*,'modefn) then mode := key!* else if null atom program!* % and null !*micro!-version and null(car program!* eq 'quote) and (null(idp car program!* and (flagp(car program!*,'nochange) or flagp(car program!*,'intfn) or car program!* eq 'list)) or car program!* memq '(setq setel setf) and eqcar(caddr program!*,'quote)) then mode := 'symbolic else if key!* eq 'input and (x := rassoc!*(program!*,inputbuflis!*)) then mode := cddr x else mode := !*mode; program!* := convertmode1(program!*,nil,'symbolic,mode); add2inputbuf(program!*,!*mode); % This used to be MODE, but then ED n wouldn't work. if null !*rlisp2 and null atom program!* and car program!* memq '(bye quit) then if getd 'bye then progn(eval program!*, go to b) else progn(!*byeflag!* := t, return nil) else if null !*rlisp2 and eqcar(program!*,'ed) then progn((if getd 'cedit and terminalp() then cedit cdr program!* else lprim "ED not supported"), go to b) else if !*defn then if erfg!* then go to a else if null flagp!*!*(key!*,'ignore) and null eqcar(program!*,'quote) then go to d; b1: if !*output and ifl!* and !*echo and null !*lessspace then terpri(); result := errorset((if mode eq 'symbolic then program!* else list('assgneval,mkquote program!*)), t,!*backtrace); if errorp result or erfg!* then progn(programl!* := program!*,go to err2) else if !*defn then go to a; if null(mode eq 'symbolic) then progn(program!* := cdar result, result := list caar result); add2resultbuf(car result,mode); if null !*output then go to a else if (null !*rlisp2 and semic!* eq '!;) or (!*rlisp2 and tok!* eq '!*semic!*) then if mode eq 'symbolic then if null car result and null(!*mode eq 'symbolic) then nil else begin terpri(); result := errorset(list('print,mkquote car result), t,!*backtrace) end else if car result then result := errorset(list('varpri,mkquote car result, mkquote program!*, mkquote 'only), t,!*backtrace); if errorp result then go to err3 else go to a; c: if crbuf1!* then progn(lprim "Closing object improperly removed. Redo edit.", crbuf1!* := nil, go to a) else if eof!*>4 then progn(lprim "End-of-file read", return eval '(bye)) else if terminalp() then progn(crbuf!* := nil, go to b) else return nil; d: if program!* then dfprint program!*; if null flagp!*!*(key!*,'eval) then go to a else go to b1; err1: if eofcheck() or eof!*>0 then go to c else if program!*="BEGIN invalid" then go to a; parserr := t; err2: resetparser(); %in case parser needs to be modified; err3: erfg!* := t; if null !*int and null !*errcont then progn(!*defn := t, !*echo := t, (if null cmsg!* then lprie "Continuing with parsing only ..."), cmsg!* := t) else if null !*errcont then progn(result := pause1 parserr, (if result then return null eval result), erfg!* := nil) else erfg!* := nil; go to a end; flag ('(deflist flag fluid global remflag remprop unfluid),'eval); symbolic procedure assgneval u; % Evaluate (possible) assignment statements and return results in a % form that allows required printing of such assignments. begin scalar x,y; a: if atom u then go to b else if car u eq 'setq then x := ('setq . cadr u) . x else if car u eq 'setel then x := ('setel . mkquote eval cadr u) . x else if car u eq 'setk then x := ('setk . mkquote if atom (y := eval cadr u) then y else car y . revlis cdr y) . x else go to b; u := caddr u; go to a; b: u := mkquote eval u; c: if null x then return(eval u . u); u := list(caar x,cdar x,u); x := cdr x; go to c end; symbolic procedure rassoc!*(u,v); % Finds term in which U is the first term in the right part of a term % in the association list V, or NIL if term is not found; if null v then nil else if u = cadar v then car v else rassoc!*(u,cdr v); symbolic procedure close!-input!-files; % Close all input files currently open; begin if ifl!* then progn(rds nil,ifl!* := nil); aa: if null ipl!* then return nil; close cdar ipl!*; ipl!* := cdr ipl!*; go to aa end; symbolic procedure close!-output!-files; % Close all output files currently open; begin if ofl!* then progn(wrs nil,ofl!* := nil); aa: if null opl!* then return nil; close cdar opl!*; opl!* := cdr opl!*; go to aa end; symbolic procedure add2buflis; begin if null crbuf!* then return nil; crbuf!* := reversip crbuf!*; %put in right order; a: if crbuf!* and seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a); crbuflis!* := (statcounter . crbuf!*) . crbuflis!*; crbuf!* := nil end; symbolic procedure add2inputbuf(u,mode); begin if null terminalp() or !*nosave!* then return nil; inputbuflis!* := (statcounter . u . mode) . inputbuflis!* end; symbolic procedure add2resultbuf(u,mode); begin if mode eq 'symbolic or null u or !*nosave!* then return nil; ws := u; if terminalp() then resultbuflis!* := (statcounter . u) . resultbuflis!* end; symbolic procedure condterpri; !*output and !*echo and !*extraecho and (null !*int or ifl!*) and null !*defn and terpri(); symbolic procedure eofcheck; % true if an end-of-file has been read in current input sequence; program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1); symbolic procedure resetparser; %resets the parser after an error; if null !*slin then comm1 t; symbolic procedure terminalp; %true if input is coming from an interactive terminal; !*int and null ifl!*; symbolic procedure dfprint u; %Looks for special action on a form, otherwise prettyprints it; if dfprint!* then apply(dfprint!*,list u) else if cmsg!* then nil else if null eqcar(u,'progn) then prettyprint u else begin a: u := cdr u; if null u then return nil; dfprint car u; go to a end; symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!*-x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; x := x - y; terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; symbolic procedure sinitl u; set(u,get(u,'initl)); endmodule; module tok; % Identifier and reserved character reading. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(semic!*); global '(!$eof!$ !$eol!$ !*quotenewnam !*raise !*lower crbuf!* crbuf1!* crchar!* curline!* cursym!* eof!* ifl!* nxtsym!* outl!* ttype!*); !*quotenewnam := t; crchar!* := '! ; curline!* := 1; % The function TOKEN defined below is used for reading identifiers % and reserved characters (such as parentheses and infix operators). % It is called by the function SCAN, which translates reserved % characters into their internal name, and sets up the output of the % input line. The following definitions of TOKEN and SCAN are quite % general, but also inefficient. The reading process can often be % speeded up considerably if these functions (especially token) are % written in terms of the explicit LISP used. symbolic procedure prin2x u; outl!* := u . outl!*; symbolic procedure mkstrng u; %converts the uninterned id U into a string; %if strings are not constants, this should be replaced by %list('string,u); u; symbolic procedure readch1; begin scalar x; if null terminalp() then progn(x := readch(), x eq !$eol!$ and (curline!* := curline!*+1), return x) else if crbuf1!* then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end else x := readch(); crbuf!* := x . crbuf!*; return x end; symbolic procedure token1; begin scalar x,y,z; x := crchar!*; a: if seprp x then progn(x := readch1(), go to a) else if digit x then go to number else if liter x or x eq '!_ then go to letter else if x eq '!% then go to coment else if x eq '!! then go to escape else if x eq '!' then progn(crchar!* := readch1(), nxtsym!* := mkquote rread(), ttype!* := 4, return nxtsym!*) else if x eq '!" then go to string; ttype!* := 3; if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr()); nxtsym!* := x; a1: if delcp x then crchar!*:= '! else crchar!*:= readch1(); go to c; escape: begin scalar raise, !*lower; raise := !*raise; !*raise := !*lower := nil; y := x . y; x := readch1(); !*raise := raise end; letter: ttype!* := 0; let1: y := x . y; if digit (x := readch1()) or liter x or x eq '!_ then go to let1 else if x eq '!! then go to escape; nxtsym!* := intern compress reversip!* y; b: crchar!* := x; c: return nxtsym!*; number: ttype!* := 2; num1: y := x . y; z := x; if digit (x := readch1()) or x eq '!. or x eq 'e or z eq 'e then go to num1; nxtsym!* := compress reversip!* y; go to b; string: begin scalar raise, !*lower; raise := !*raise; !*raise := !*lower := nil; strinx: y := x . y; if null((x := readch1()) eq '!") then go to strinx; y := x . y; nxtsym!* := mkstrng compress reversip!* y; !*raise := raise end; ttype!* := 1; go to a1; coment: if null(readch1() eq !$eol!$) then go to coment; x := readch1(); go to a end; symbolic procedure token; %This provides a hook for a faster TOKEN; token1(); symbolic procedure filenderr; begin eof!* := eof!*+1; if terminalp() then error1() else error(99,if ifl!* then list("End-of-file read in file",car ifl!*) else "End-of-file read") end; symbolic procedure ptoken; begin scalar x; x := token(); if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*; %an explicit reference to OUTL!* used here; prin2x x; if null ((x eq '!() or (x eq '!))) then prin2x '! ; return x end; symbolic procedure rread1; % Modified to use QUOTENEWNAM's for ids. begin scalar x,y; x := ptoken(); if null (ttype!*=3) then return if null idp x or null !*quotenewnam or null(y := get(x,'quotenewnam)) then x else y else if x eq '!( then return rrdls() else if null (x eq '!+ or x eq '!-) then return x; y := ptoken(); if null numberp y then progn(nxtsym!* := " ", symerr("Syntax error: improper number",nil)) else if x eq '!- then y := apply('minus,list y); %we need this construct for bootstrapping purposes; return y end; symbolic procedure rrdls; begin scalar x,y,z; a: x := rread1(); if null (ttype!*=3) then go to b else if x eq '!) then return z else if null (x eq '!.) then go to b; x := rread1(); y := ptoken(); if null (ttype!*=3) or null (y eq '!)) then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil)) else return nconc(z,x); b: z := nconc(z,list x); go to a end; symbolic procedure rread; progn(prin2x " '",rread1()); %--- symbolic procedure scan; %--- begin scalar x,y; %--- if null (cursym!* eq '!*semicol!*) then go to b; %--- a: nxtsym!* := token(); %--- b: if null atom nxtsym!* then go to q1 %--- else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* %--- then outl!* := nil; %--- prin2x nxtsym!*; %--- c: if null idp nxtsym!* then go to l %--- else if (x:=get(nxtsym!*,'newnam)) and %--- (null (x=nxtsym!*)) then go to new %--- else if nxtsym!* eq 'comment OR NXTSYM!* EQ '!% AND TTYPE!*=3 %--- THEN GO TO COMM %--- ELSE IF NULL(TTYPE!* = 3) THEN GO TO L %--- ELSE IF NXTSYM!* EQ !$eof!$ then return filenderr() %--- else if nxtsym!* eq '!' then go to quote %--- else if null (x:= get(nxtsym!*,'switch!*)) then go to l %--- else if eqcar(cdr x,'!*semicol!*) then go to delim; %--- sw1: nxtsym!* := token(); %--- if null(ttype!* = 3) then go to sw2 %--- else if nxtsym!* eq !$eof!$ then return filenderr() %--- else if car x then go to sw3; %--- sw2: cursym!*:=cadr x; %--- if cursym!* eq '!*rpar!* then go to l2 %--- else return cursym!*; %--- sw3: if null (y:= atsoc(nxtsym!*,car x)) then go to sw2; %--- prin2x nxtsym!*; %--- x := cdr y; %--- go to sw1; %--- comm: if delcp crchar!* then go to com1; %--- crchar!* := readch(); %--- go to comm; %--- com1: crchar!* := '! ; %--- condterpri(); %--- go to a; %--- delim: %--- semic!*:=nxtsym!*; %--- return (cursym!*:='!*semicol!*); %--- new: nxtsym!* := x; %--- if stringp x then go to l %--- else if atom x then go to c %--- else go to l; %--- quote: %--- nxtsym!* := mkquote rread1(); %--- go to l; %--- q1: if null (car nxtsym!* eq 'string) then go to l; %--- prin2x " "; %--- prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); %--- l: cursym!*:=nxtsym!*; %--- l1: nxtsym!* := token(); %--- if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); %--- l2: if numberp nxtsym!* %--- or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) %--- then prin2x " "; %--- return cursym!* %--- end; global '(!*eoldelimp comment!*); symbolic procedure scan; begin scalar bool,x,y; if null (cursym!* eq '!*semicol!*) then go to b; a: nxtsym!* := token(); b: if null atom nxtsym!* then go to q1 else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* then outl!* := nil; prin2x nxtsym!*; c: if null idp nxtsym!* then go to l else if (x:=get(nxtsym!*,'newnam)) and (null (x=nxtsym!*)) then go to new else if nxtsym!* eq 'Comment then go to comm else if nxtsym!* eq '!#if then go to conditional else if nxtsym!* eq '!#else then progn(nxtsym!* := x := nil, go to skipping) else if nxtsym!* eq '!#endif then go to a else if nxtsym!* eq '!% and ttype!*=3 % then progn(prin2t "****** Tell Hearn you got to SCAN comment", % go to comm) then go to comm else if null(ttype!* = 3) then go to l else if nxtsym!* eq !$eof!$ then return filenderr() else if nxtsym!* eq '!' then rederr "Invalid QUOTE" else if !*eoldelimp and nxtsym!* eq !$eol!$ then go to delim else if null (x:= get(nxtsym!*,'switch!*)) then go to l else if eqcar(cdr x,'!*semicol!*) then go to delim; bool := seprp crchar!*; sw1: nxtsym!* := token(); if null(ttype!* = 3) then go to sw2 else if nxtsym!* eq !$eof!$ then return filenderr() else if car x then go to sw3; sw2: cursym!*:=cadr x; bool := nil; if cursym!* eq '!*rpar!* then go to l2 else return cursym!*; sw3: if bool or null (y:= atsoc(nxtsym!*,car x)) then go to sw2; prin2x nxtsym!*; x := cdr y; if null car x and cadr x eq '!*Comment!* then progn(comment!* := read!-comment(),go to a); go to sw1; conditional: % The conditional expression used here must be written in Lisp form x := errorset(rread(), !*backtrace, nil); % errors in evaluation count as NIL if null errorp x and car x then go to a; x := nil; skipping: % I support nesting of conditional inclusion. if nxtsym!* eq '!#endif then if null x then go to a else x := cdr x else if nxtsym!* eq '!#if then x := nil . x else if (nxtsym!* eq '!#else) and null x then go to a; nxtsym!* := token(); go to skipping; comm: if delcp crchar!* and null(crchar!* eq !$eol!$) then progn(crchar!* := '! , condterpri(), go to a); crchar!* := readch(); go to comm; delim: semic!*:=nxtsym!*; return (cursym!*:='!*semicol!*); new: nxtsym!* := x; if stringp x then go to l else if atom x then go to c else go to l; q1: if null (car nxtsym!* eq 'string) then go to l; prin2x " "; prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); l: cursym!*:=nxtsym!*; nxtsym!* := token(); if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); l2: if numberp nxtsym!* or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) then prin2x " "; return cursym!* end; endmodule; module xread; % Routines for parsing REDUCE input. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* nxtsym!*); % The conversion of a REDUCE expression to LISP prefix form is carried % out by the function XREAD. This function initiates the scanning % process, and then calls the auxiliary function XREAD1 to perform the % actual parsing. Both XREAD and XREAD1 are used by many functions % whenever an expression must be read; flag ('(end !*colon!* !*semicol!*),'delim); symbolic procedure chknewnam u; % Check to see if U has a newnam, and return it else return U. begin scalar x; return if null(x := get(u,'newnam)) or x eq u then u else if idp x then chknewnam x else x end; symbolic procedure mkvar(u,v); u; symbolic procedure remcomma u; if eqcar(u,'!*comma!*) then cdr u else list u; symbolic procedure xread1 u; begin scalar v,w,x,y,z,z1,z2; % v: expression being built % w: prefix operator stack % x: infix operator stack % y: infix value or stat property % z: current symbol % z1: next symbol % z2: temporary storage; a: z := cursym!*; a1: if null idp z then nil else if z eq '!*lpar!* then go to lparen else if z eq '!*rpar!* then go to rparen else if y := get(z,'infix) then go to infx % The next line now commented out was intended to allow a STAT % to be used as a label. However, it prevents the definition of % a diphthong whose first character is a colon. % else if nxtsym!* eq '!: then nil else if flagp(z,'delim) then go to delimit else if y := get(z,'stat) then go to stat; a2: y := nil; a3: w := z . w; if numberp z and idp (z1 := chknewnam nxtsym!*) and null flagp(z1,'delim) and null(get(z1,'switch!*) and null(z1 eq '!()) and null get(z1,'infix) then progn(cursym!* := 'times, go to a); % allow for implicit * after a number. next: z := scan(); go to a1; lparen: y := nil; if scan() eq '!*rpar!* then go to lp1 % no args else if flagpcar(w,'struct) then z := xread1 car w else z := xread1 'paren; if flagp(u,'struct) then progn(z := remcomma z, go to a3) else if null eqcar(z,'!*comma!*) then go to a3 else if null w then (if u eq 'lambda then go to a3 else symerr("Improper delimiter",nil)) else w := (car w . cdr z) . cdr w; go to next; lp1: if w then w := list car w . cdr w; %function of no args; go to next; rparen: if null u or u eq 'group or u eq 'proc then symerr("Too many right parentheses",nil) else go to end1; infx: if z eq '!*comma!* or null atom (z1 := scan()) or numberp z1 then go to in1 else if z1 eq '!*rpar!*%infix operator used as variable; or z1 eq '!*comma!* or flagp(z1,'delim) then go to in2 else if z1 eq '!*lpar!*%infix operator in prefix position; and null atom(z1 := xread 'paren) and car z1 eq '!*comma!* and (z := z . cdr z1) then go to a1; in1: if w then go to unwind else if null(z := get(z,'unary)) then symerr("Redundant operator",nil); v := '!*!*un!*!* . v; go to pr1; in2: y := nil; w := z . w; in3: z := z1; go to a1; unwind: z2 := mkvar(car w,z); un1: w:= cdr w; if null w then go to un2 else if numberp car w then symerr("Missing operator",nil); z2 := list(car w,z2); go to un1; un2: v:= z2 . v; preced: if null x then if y=0 then go to end2 else nil else if y>; begin scalar lst; a: lst := aconc!*(lst,xread 'group); if null(cursym!* eq '!*rsqb!*) then go to a; scan(); return ('progn . lst) end; put('!*lsqb!*,'stat,'mkprogn); flag('(!*rsqb!*),'delim); flag('(!*rsqb!*),'nodel); % ***** END STATEMENT ***** symbolic procedure endstat; %This procedure can also be used for any key-words which take no %arguments; begin scalar x; x := cursym!*; comm1 'end; return list x end; put('end,'stat,'endstat); put('endmodule,'stat,'endstat); put('bye,'stat,'endstat); put('quit,'stat,'endstat); flag('(bye quit),'eval); put('showtime,'stat,'endstat); endmodule; module block; % Block statement and related operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(!*vars!* cursym!* nxtsym!*); % ***** GO statement ***** symbolic procedure gostat; begin scalar var; var := if eq(scan(),'to) then scan() else cursym!*; scan(); return list('go,var) end; put('go,'stat,'gostat); put('goto,'newnam,'go); % ***** Declaration Statement ***** symbolic procedure decl u; begin scalar varlis,w; a: if cursym!* eq '!*semicol!* then go to c else if not flagp!*!*(cursym!*,'type) then return varlis else if cursym!* eq 'dcl then go to dclr; w := cursym!*; if scan() eq 'procedure then return procstat1 w; varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w)); b: if not cursym!* eq '!*semicol!* then symerr(nil,t) else if null u then return list('dcl,mkquote varlis); %top level declaration; c: scan(); go to a; dclr: varlis := append(varlis,dclstat1()); go to b end; flag ('(dcl real integer scalar),'type); symbolic procedure dclstat; list('dcl,mkquote dclstat1()); symbolic procedure dclstat1; begin scalar x,y; a: x := xread nil; if not cursym!* eq '!*colon!* then symerr('dcl,t); y := append(y,pairvars(remcomma x,nil,scan())); if scan() eq '!*semicol!* then return y else if not cursym!* eq '!*comma!* then symerr('dcl,t) else go to a end; symbolic procedure dcl u; %U is a list of (id, mode) pairs, which are declared as global vars; begin scalar x; !*vars!* := append(u,!*vars!*); x := mapcar(u,function car); global x; flag(x,'share); a: if null u then return nil; set(caar u,get(cdar u,'initvalue)); u := cdr u; go to a end; put('integer,'initvalue,0); put('dcl,'stat,'dclstat); symbolic procedure decstat; %only called if a declaration occurs at the top level or not first %in a block; begin scalar x,y,z; if !*blockp then symerr('block,t); x := cursym!*; y := nxtsym!*; z := decl nil; if y neq 'procedure then rederr list(x,"invalid outside block"); return z end; put('integer,'stat,'decstat); put('real,'stat,'decstat); put('scalar,'stat,'decstat); % ***** Block Statement ***** symbolic procedure blockstat; begin scalar hold,varlis,x,!*blockp; !*blockp := t; scan(); if cursym!* memq '(nil !*rpar!*) then rederr "BEGIN invalid"; varlis := decl t; a: if cursym!* eq 'end and not nxtsym!* eq '!: then go to b; x := xread1 nil; if eqcar(x,'end) then go to c; not cursym!* eq 'end and scan(); if x then hold := aconc!*(hold,x); go to a; b: comm1 'end; c: return mkblock(varlis,hold) end; symbolic procedure mkblock(u,v); 'block . (u . v); putd('block,'macro, '(lambda (u) (cons 'prog (cons (mapcar (cadr u) (function car)) (cddr u))))); symbolic procedure formblock(u,vars,mode); 'prog . append(initprogvars cadr u, formprog1(cddr u,append(cadr u,vars),mode)); symbolic procedure initprogvars u; begin scalar x,y,z; a: if null u then return(reversip!* x . reversip!* y) else if z := get(cdar u,'initvalue) then y := mksetq(caar u,z) . y; x := caar u . x; u := cdr u; go to a end; symbolic procedure formprog(u,vars,mode); 'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode); symbolic procedure formprog1(u,vars,mode); if null u then nil else if atom car u then car u . formprog1(cdr u,vars,mode) else if idp caar u and flagp(caar u,'modefn) then formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode) else formc(car u,vars,mode) . formprog1(cdr u,vars,mode); put('block,'formfn,'formblock); put('prog,'formfn,'formprog); put('begin,'stat,'blockstat); % ***** Return Statement ***** symbolic procedure retstat; if not !*blockp then symerr(nil,t) else list('return, if flagp!*!*(scan(),'delim) then nil else xread1 t); put('return,'stat,'retstat); endmodule; module form; % Performs a mode analysis of parsed forms. % Author: Anthony C. Hearn. % Modifications by: Jed Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*!*a2sfn !*cref !*defn !*mode current!-modulus); global '(!*argnochk !*composites !*force !*micro!-version !*vars!*); !*!*a2sfn := 'aeval; flag('(algebraic symbolic),'modefn); symbolic procedure formcond(u,vars,mode); 'cond . formcond1(cdr u,vars,mode); symbolic procedure formcond1(u,vars,mode); if null u then nil else list(formbool(caar u,vars,mode),form1(cadar u,vars,mode)) % FORMC here would add REVAL . formcond1(cdr u,vars,mode); put('cond,'formfn,'formcond); symbolic procedure formlamb(u,vars,mode); list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode)); put('lambda,'formfn,'formlamb); symbolic procedure formprogn(u,vars,mode); 'progn . formclis(cdr u,vars,mode); put('progn,'formfn,'formprogn); symbolic procedure expdrmacro u; %returns the macro form for U if expansion is permitted; begin scalar x; if null(x := getrmacro u) or flagp(u,'noexpand) then return nil else if null !*cref and (null !*defn or car x eq 'smacro) or flagp(u,'expand) or !*force then return x else return nil end; symbolic procedure getrmacro u; %returns a Reduce macro definition for U, if one exists, %in GETD format; begin scalar x; return if not idp u then nil else if (x := getd u) and car x eq 'macro then x else if (x := get(u,'smacro)) then 'smacro . x % else if (x := get(u,'nmacro)) then 'nmacro . x; else nil end; symbolic procedure applmacro(u,v,w); apply1(u,w . v); %symbolic procedure applnmacro(u,v,w); % apply(u,if flagp(w,'nospread) then list v else v); % symbolic procedure applsmacro(u,v,w); % %We could use an atom sublis here, eg SUBLA; % sublis(pair(cadr u,v),caddr u); put('macro,'macrofn,'applmacro); %put('nmacro,'macrofn,'applnmacro); put('smacro,'macrofn,'applsmacro); flag('(ed go quote),'noform); symbolic procedure set!-global!-mode u; begin !*mode := u end; symbolic procedure form1(u,vars,mode); begin scalar x,y; if atom u then return if not idp u then u else if u eq 'ed then list u else if flagp(u,'modefn) then set!-global!-mode u else if x:= get(mode,'idfn) then apply2(x,u,vars) else u else if not atom car u then if caar u eq 'lambda then return formlis(u,vars,mode) else typerr(car u,"operator") else if not idp car u then typerr(car u,"operator") else if get(car u, 'localfnname) then return form1(get(car u,'localfnname) . cdr u,vars,mode) else if flagp(car u,'noform) then return u else if arrayp car u and (mode eq 'symbolic or intexprlisp(cdr u,vars)) then return list('getel,intargfn(u,vars,mode)) else if flagp(car u,'modefn) then return convertmode(cadr u,vars,mode,car u) else if (x := get(car u,'formfn)) then return macrochk(apply(x,list(u,vars,mode)),mode) else if get(car u,'stat) eq 'rlis then return macrochk(formrlis(u,vars,mode),mode) % else if (x := getd car u) and eqcar(x, 'macro) and % not(mode eq 'algebraic) then % return << x := apply(cdr x, list(u, vars, mode)); % formc(x, vars, mode) >> ; argnochk u; x := formlis(cdr u,vars,mode); y := if x=cdr u then u else car u . x; return if mode eq 'symbolic or get(car u,'stat) or cdr u and eqcar(cadr u,'quote) and null !*micro!-version or intexprnp(y,vars) and null !*composites and null current!-modulus then macrochk(y,mode) else if not(mode eq 'algebraic) then convertmode(y,vars,mode,'algebraic) else ('list . algid(car u,vars) . x) end; symbolic procedure argnochk u; begin scalar x; if null !*argnochk then nil else if (x := argsofopr car u) and x neq length cdr u then rederr list(car u,"called with", length cdr u, if length cdr u=1 then "argument" else "arguments", "instead of",x) end; symbolic procedure argsofopr u; % This function may be optimizable in various implementations. get(u,'number!-of!-args); symbolic procedure intexprnp(u,vars); %determines if U is an integer expression; if atom u then if numberp u then fixp u else if (u := atsoc(u,vars)) then cdr u eq 'integer else nil else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars); symbolic procedure intexprlisp(u,vars); null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars); flag('(difference minus plus times),'intfn); % EXPT is not included in this list, because a negative exponent can % cause problems (i.e., result can be rational); symbolic procedure formlis(u,vars,mode); mapcar(u,function (lambda x; form1(x,vars,mode))); symbolic procedure formclis(u,vars,mode); mapcar(u,function (lambda x; formc(x,vars,mode))); symbolic procedure form u; form1(u,!*vars!*,!*mode); symbolic procedure macrochk(u,mode); begin scalar y; %expands U if CAR U is a macro and expansion allowed; if atom u then return u else if (y := expdrmacro car u) and (mode eq 'symbolic or idp car u and flagp(car u,'opfn)) then return apply(get(car y,'macrofn),list(cdr y,cdr u,car u)) else return u end; put('symbolic,'idfn,'symbid); symbolic procedure symbid(u,vars); u; % if atsoc(u,vars) or fluidp u or globalp u or u memq '(nil t) % or flagp(u,'share) then u % else <>; put('algebraic,'idfn,'algid); symbolic procedure algid(u,vars); if atsoc(u,vars) or flagp(u,'share) then u else mkquote u; put('integer,'idfn,'intid); symbolic procedure intid(u,vars); begin scalar x,y; return if (x := atsoc(u,vars)) then if cdr x eq 'integer then u else if y := get(cdr x,'integer) then apply2(y,u,vars) else if cdr x eq 'scalar then !*!*a2i(u,vars) else rederr list(cdr x,"not convertable to INTEGER") else !*!*a2i(mkquote u,vars) end; symbolic procedure convertmode(exprn,vars,target,source); convertmode1(form1(exprn,vars,source),vars,target,source); symbolic procedure convertmode1(exprn,vars,target,source); begin scalar x; if source eq 'real then source := 'algebraic; if target eq 'real then target := 'algebraic; if target eq source then return exprn else if idp exprn and (x := atsoc(exprn,vars)) and not(cdr x memq '(integer scalar real)) and not(cdr x eq source) then return convertmode(exprn,vars,target,cdr x) else if not (x := get(source,target)) then typerr(source,target) else return apply2(x,exprn,vars) end; put('algebraic,'symbolic,'!*!*a2s); put('symbolic,'algebraic,'!*!*s2a); symbolic procedure !*!*a2s(u,vars); % It would be nice if we could include the ATSOC(U,VARS) line, % since in many cases that would save recomputation. However, % in any sequential process, assignments or subsititution rules % can change the value of a variable, so we have to check its % value again. More comprehensive analysis could certainly % optimize this. if u = '(quote nil) then nil else if null u or constantp u and null fixp u or intexprnp(u,vars) and null !*composites and null current!-modulus or not atom u and idp car u and flagp(car u,'nochange) and not(car u eq 'getel) % or atsoc(u,vars) % means it was already evaluated then u else list(!*!*a2sfn,u); symbolic procedure !*!*s2a(u,vars); u; symbolic procedure formc(u,vars,mode); %this needs to be generalized; if mode eq 'algebraic and intexprnp(u,vars) then u else convertmode(u,vars,'symbolic,mode); symbolic procedure intargfn(u,vars,mode); % transforms array element U into expression with integer arguments. % Array name is treated as an algebraic variable; 'list . form1(car u,vars,'algebraic) . mapcar(cdr u, function (lambda x; convertmode(x,vars,'integer,mode))); put('algebraic,'integer,'!*!*a2i); symbolic procedure !*!*a2i(u,vars); if intexprnp(u,vars) then u else list('ieval,u); symbolic procedure ieval u; !*s2i reval u; flag('(ieval),'opfn); % To make it a symbolic operator. flag('(ieval),'nochange); put('symbolic,'integer,'!*!*s2i); symbolic procedure !*!*s2i(u,vars); if fixp u then u else list('!*s2i,u); symbolic procedure !*s2i u; if fixp u then u else typerr(u,"integer"); put('integer,'symbolic,'identity); symbolic procedure identity(u,vars); u; symbolic procedure formbool(u,vars,mode); if mode eq 'symbolic then form1(u,vars,mode) else if atom u then if not idp u or atsoc(u,vars) or u eq 't then u else formc!*(u,vars,mode) else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u else if idp car u and get(car u,'boolfn) then get(car u,'boolfn) . formclis(cdr u,vars,mode) else if idp car u and flagp(car u,'boolean) then car u . mapcar(cdr u,function (lambda x; if flagp(car u,'boolargs) then formbool(x,vars,mode) else formc!*(x,vars,mode))) else formc!*(u,vars,mode); symbolic procedure formc!*(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'reval; return formc(u,vars,mode) end; % Functions with side effects must be handled carefully in this model, % otherwise they are not always evaluated within blocks. symbolic procedure formrederr(u,vars,mode); begin scalar x; x := formc!*(cadr u,vars,mode); return list('rederr,x) end; put('rederr,'formfn,'formrederr); symbolic procedure formreturn(u,vars,mode); begin scalar x; x := form1(cadr u,vars,mode); % FORMC here would add REVAL if not(mode memq '(symbolic integer real)) and eqcar(x,'setq) % Should this be more general? then x := list(!*!*a2sfn,x); return list('return,x) end; put('return,'formfn,'formreturn); symbolic procedure formsetq(u,vars,mode); begin scalar target,x,y; u := cdr u; if eqcar(cadr u,'quote) then mode := 'symbolic; if idp car u and (y := atsoc(car u,vars)) and not(cdr y eq 'scalar) then target := 'symbolic % used to be CDR Y else target := 'symbolic; % Make target always SYMBOLIC so that algebraic expressions % are evaluated before being stored. x := convertmode(cadr u,vars,target,mode); return if not atom car u then if not idp caar u then typerr(car u,"assignment") else if arrayp caar u then list('setel,intargfn(car u,vars,mode),x) else if y := get(caar u,'setqfn) then form1((y . append(cdar u,cdr u)),vars,mode) % else if y := get(caar u, 'access) % then list('m!-setf, % list(caar u, form1(cadar u, vars, mode)), % x) else list('setk,form1(car u,vars,'algebraic),x) % algebraic needed above, since SETK expects it. else if not idp car u then typerr(car u,"assignment") else if mode eq 'symbolic or y or flagp(car u,'share) or eqcar(x,'quote) then mksetq(car u,x) else list('setk,mkquote car u,x) end; put('car,'setqfn,'rplaca); put('cdr,'setqfn,'rplacd); put('setq,'formfn,'formsetq); symbolic procedure formfunc(u,vars,mode); if idp cadr u then if getrmacro cadr u then rederr list("Macro",cadr u,"Used as Function") else list('function,cadr u) else list('function,form1(cadr u,vars,mode)); put('function,'formfn,'formfunc); % RLIS is a parser function that reads a list of arguments and returns % this list as one argument. It needs to be defined in this module for % bootstrapping purposes since this definition only works with its form % function. symbolic procedure rlis; begin scalar x; x := cursym!*; return if flagp!*!*(scan(),'delim) then list(x,nil) else x . remcomma xread1 'lambda end; symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end; symbolic procedure rlistat u; begin a: if null u then return nil; put(car u,'stat,'rlis); u := cdr u; go to a end; rlistat '(flagop); symbolic procedure formrlis(u,vars,mode); if not flagp(car u,'flagop) then list(car u,'list . formlis(cdr u,vars,'algebraic)) else if not idlistp cdr u then typerr('!*comma!* . cdr u,"identifier list") else mkprog(nil,list('flag,mkquote cdr u,mkquote car u) . get(car u,'simpfg)); symbolic procedure mkarg(u,vars); % Returns the "unevaled" form of U. if null u or constantp u then u else if atom u then if atsoc(u,vars) then u else mkquote u else if car u eq 'quote then mkquote u else 'list . mapcar(u,function (lambda x; mkarg(x,vars))); endmodule; module proc; % Procedure statement. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace); global '(!*argnochk !*comp !*lose cursym!* erfg!* fname!* ftypes!*); fluid '(!*defn); !*lose := t; ftypes!* := '(expr fexpr macro); symbolic procedure putc(name,type,body); %defines a non-standard function, such as an smacro. Returns NAME; begin if !*comp and flagp(type,'compile) then compd(name,type,body) else put(name,type,body); return name end; % flag('(putc),'eval); symbolic procedure formproc(u,vars,mode); begin scalar body,name,type,varlis,x,y; u := cdr u; name := car u; if cadr u then mode := cadr u; % overwrite previous mode u := cddr u; type := car u; if flagp(name,'lose) and (!*lose or null !*defn) then return progn(lprim list(name, "not defined (LOSE flag)"), nil); varlis := cadr u; u := caddr u; x := if eqcar(u,'block) then cadr u else nil; y := pairxvars(varlis,x,vars,mode); if x then u := car u . rplaca!*(cdr u,cdr y); body:= form1(u,car y,mode); % FORMC here would add REVAL if type eq 'expr then body := list('de,name,varlis,body) else if type eq 'fexpr then body := list('df,name,varlis,body) else if type eq 'macro then body := list('dm,name,varlis,body) else if type eq 'emb then return embfn(name,varlis,body) else body := list('putc, mkquote name, mkquote type, mkquote list('lambda,varlis,body)); if not(mode eq 'symbolic) then body := list('progn, list('flag,mkquote list name,mkquote 'opfn), body); if !*argnochk and type memq '(expr smacro) then body := list('progn, list('put,mkquote name, mkquote 'number!-of!-args, length varlis), body); if !*defn and type memq '(fexpr macro smacro) then eval body; return body end; put('procedure,'formfn,'formproc); symbolic procedure pairxvars(u,v,vars,mode); %Pairs procedure variables and their modes, taking into account %the convention which allows a top level prog to change the mode %of such a variable; begin scalar x,y; a: if null u then return append(reversip!* x,vars) . v else if (y := atsoc(car u,v)) then <> else x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure procstat1 mode; begin scalar bool,u,type,x,y,z; bool := erfg!*; if fname!* then go to b else if cursym!* eq 'procedure then type := 'expr else progn(type := cursym!*,scan()); if not cursym!* eq 'procedure then go to c; x := errorset('(xread (quote proc)),nil,!*backtrace); if errorp x then go to a else if atom (x := car x) then x := list x; %no arguments; fname!* := car x; %function name; if idp fname!* %AND NOT(TYPE MEMQ FTYPES!*); then if null fname!* or (z := gettype fname!*) and not z memq '(procedure operator) then go to d else if not getd fname!* then flag(list fname!*,'fnc); %to prevent invalid use of function name in body; u := cdr x; y := u; x := car x . y; a: z := errorset('(xread t),nil,!*backtrace); if not errorp z then z := car z; if null erfg!* then z:=list('procedure,car x,mode,type,y,z); remflag(list fname!*,'fnc); fname!*:=nil; if erfg!* then progn(z := nil,if not bool then error1()); return z; b: bool := t; c: errorset('(symerr (quote procedure) t),nil,!*backtrace); go to a; d: typerr(list(z,fname!*),"procedure"); go to a end; symbolic procedure procstat; procstat1 nil; deflist ('((procedure procstat) (expr procstat) (fexpr procstat) (emb procstat) (macro procstat) (smacro procstat)), 'stat); % Next line refers to bootstrapping process. if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat); deflist('((lisp symbolic)),'newnam); endmodule; module forstat; % Definition of REDUCE FOR loops. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* foractions!*); comment the syntax of the FOR statement is as follows: {step i3 until} {i := i1 { } i2 } { { : } } for { } { { in } } { each i { } } { on } In all cases, the is evaluated algebraically within the scope of the current value of i. If is DO, then nothing else happens. In other cases, is a binary operator that causes a result to be built up and returned by FOR. In each case, the loop is initialized to a default value. The test for the end condition is made before any action is taken. The effect of the definition here is to replace all for loops by semantically equivalent blocks. As a result, none of the mapping functions are needed in REDUCE. To declare a set of actions, one says; foractions!* := '(do collect conc product sum); remflag(foractions!*,'delim); % For bootstrapping purposes. % To associate a binary function with an action, one says: deflist('((product times) (sum plus)),'bin); % And to give these an initial value in a loop: deflist('((product 1) (sum 0)),'initval); % NB: We need to reset for and let delims if an error occurs. It's % probably best to do this in the begin1 loop. flag('(for),'nochange); symbolic procedure forstat; begin scalar !*blockp; return if scan() eq 'all then forallstat() else if cursym!* eq 'each then foreachstat() else forloop() end; put('for,'stat,'forstat); symbolic procedure forloop; begin scalar action,bool,incr,var,x; flag('(step),'delim); x := errorset('(xread1 'for),t,t); remflag('(step),'delim); if errorp x then error1() else x := car x; if not eqcar(x,'setq) or not idp(var := cadr x) then symerr('for,t); x := caddr x; if cursym!* eq 'step then <> else if cursym!* eq '!*colon!* then incr := 1 else symerr('for,t); if flagp(car foractions!*,'delim) then bool := t % nested loop else flag(foractions!*,'delim); incr := list(x,incr,xread t); if null bool then remflag(foractions!*,'delim); if not((action := cursym!*) memq foractions!*) then symerr('for,t); return list('for,var,incr,action,xread t) end; symbolic procedure formfor(u,vars,mode); begin scalar action,algp,body,endval,incr,initval,var,x; %ALGP is used to determine if the loop calculation must be %done algebraically or not; var := cadr u; incr := caddr u; incr := list(formc(car incr,vars,mode), formc(cadr incr,vars,mode), formc(caddr incr,vars,mode)); if intexprnp(car incr,vars) and intexprnp(cadr incr,vars) and not atsoc(var,vars) then vars := (var . 'integer) . vars; action := cadddr u; body := formc(car cddddr u, (var . if intexprlisp(caddr u,vars) then 'integer else mode) . vars,mode); algp := algmodep car incr or algmodep cadr incr or algmodep caddr incr; initval := car incr; endval := caddr incr; incr := cadr incr; x := if algp then list('list,''difference,endval,var) else list('difference,endval,var); if incr neq 1 then x := if algp then list('list,''times,incr,x) else list('times,incr,x); % We could consider simplifying X here (via reval). x := if algp then list('aminusp!:,x) else list('minusp,x); return forformat(action,body,initval,x, list('plus2,incr),var,vars,mode) end; put('for,'formfn,'formfor); symbolic procedure algmodep u; eqcar(u,'aeval); symbolic procedure aminusp!: u; begin scalar x; u := aeval u; x := u; if fixp x then return minusp x else if not eqcar(x,'!*sq) then msgpri(nil,reval u,"invalid in FOR statement",nil,t); x := cadr x; if fixp car x and fixp cdr x then return minusp car x else if not cdr x = 1 or not (atom(x := car x) or atom car x) % Should be DOMAINP, but SMACROs not yet defined. then msgpri(nil,reval u,"invalid in FOR statement",nil,t) else return apply('!:minusp,list x) end; symbolic procedure foreachstat; begin scalar w,x,y,z; if not idp(x := scan()) or not (y := scan()) memq '(in on) then symerr("FOR EACH",t) else if flagp(car foractions!*,'delim) then w := t else flag(foractions!*,'delim); z := xread t; if null w then remflag(foractions!*,'delim); w := cursym!*; if not w memq foractions!* then symerr("FOR EACH",t); return list('foreach,x,y,z,w,xread t) end; put('foreach,'stat,'foreachstat); symbolic procedure formforeach(u,vars,mode); begin scalar action,body,lst,mod,var; var := cadr u; u := cddr u; mod := car u; u := cdr u; lst := formc(car u,vars,mode); u := cdr u; if not(mode eq 'symbolic) then lst := list('getrlist,lst); action := car u; u := cdr u; body := formc(car u,(var . mode) . vars,mode); if mod eq 'in then body := list(list('lambda,list var,body),list('car,var)) else if not(mode eq 'symbolic) then typerr(mod,'action); return forformat(action,body,lst, list('null,var),list 'cdr,var,vars,mode) end; put('foreach,'formfn,'formforeach); symbolic procedure forformat(action,body,initval, testexp,updform,var,vars,mode); begin scalar result; result := gensym(); return sublis(list('body2 . if mode eq 'symbolic or intexprnp(body,vars) then list(get(action,'bin),body,result) else list('aeval,list('list,mkquote get(action,'bin), body,result)), 'body3 . if mode eq 'symbolic then body else list('getrlist,body), 'body . body, 'initval . initval, 'nillist . if mode eq 'symbolic then nil else ''(list), 'result . result, 'initresult . get(action,'initval), 'resultlist . if mode eq 'symbolic then result else list('cons,''list,result), 'testexp . testexp, 'updfn . car updform, 'updval . cdr updform, 'var . var), if action eq 'do then '(prog (var) (setq var initval) lab (cond (testexp (return nil))) body (setq var (updfn var . updval)) (go lab)) else if action eq 'collect then '(prog (var result endptr) (setq var initval) (cond (testexp (return nillist))) (setq result (setq endptr (cons body nil))) looplabel (setq var (updfn var . updval)) (cond (testexp (return resultlist))) (rplacd endptr (cons body nil)) (setq endptr (cdr endptr)) (go looplabel)) else if action eq 'conc then '(prog (var result endptr) (setq var initval) startover (cond (testexp (return nillist))) (setq result body) (setq endptr (lastpair resultlist)) (setq var (updfn var . updval)) (cond ((atom endptr) (go startover))) looplabel (cond (testexp (return result))) (rplacd endptr body3) (setq endptr (lastpair endptr)) (setq var (updfn var . updval)) (go looplabel)) else '(prog (var result) (setq var initval) (setq result initresult) lab1 (cond (testexp (return result))) (setq result body2) (setq var (updfn var . updval)) (go lab1))) end; symbolic procedure lastpair u; % Return the last pair of the list u. if atom u or atom cdr u then u else lastpair cdr u; put('join,'newnam,'conc); % alternative for CONC endmodule; module loops; % Looping forms other than the FOR statement. % Author: Anthony C. Hearn % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!*); % ***** REPEAT STATEMENT ***** symbolic procedure repeatstat; begin scalar body,!*blockp; flag('(until),'delim); body:= xread t; remflag('(until),'delim); if not cursym!* eq 'until then symerr('repeat,t); return list('repeat,body,xread t); end; symbolic macro procedure repeat u; begin scalar body,bool,lab; body := cadr u; bool := caddr u; lab := gensym(); return mkprog(nil,list(lab,body, list('cond,list(list('not,bool),list('go,lab))))) end; put('repeat,'stat,'repeatstat); flag('(repeat),'nochange); symbolic procedure formrepeat(u,vars,mode); list('repeat,formc(cadr u,vars,mode),formbool(caddr u,vars,mode)); put('repeat,'formfn,'formrepeat); % ***** WHILE STATEMENT ***** symbolic procedure whilstat; begin scalar bool,!*blockp; flag('(do),'delim); bool := xread t; remflag('(do),'delim); if not cursym!* eq 'do then symerr('while,t); return list('while,bool,xread t) end; symbolic macro procedure while u; begin scalar body,bool,lab; bool := cadr u; body := caddr u; lab := gensym(); return mkprog(nil,list(lab,list('cond,list(list('not,bool), list('return,nil))),body,list('go,lab))) end; put('while,'stat,'whilstat); flag('(while),'nochange); symbolic procedure formwhile(u,vars,mode); list('while,formbool(cadr u,vars,mode),formc(caddr u,vars,mode)); put('while,'formfn,'formwhile); endmodule; module write; % Miscellaneous statement definitions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % ***** DEFINE STATEMENT ***** remprop('define,'stat); symbolic procedure define u; for each x in u do if not eqcar(x,'equal) or not idp cadr x then typerr(x,"DEFINE declaration") else put(cadr x,'newnam,caddr x); put('define,'stat,'rlis); flag('(define),'eval); % ***** WRITE STATEMENT ***** symbolic procedure formwrite(u,vars,mode); begin scalar bool1,bool2,x,z; u := cdr u; bool1 := mode eq 'symbolic; while u do <>; return mkprog(nil,reversip!* z) end; symbolic procedure writepri(u,v); begin scalar x; x := assgneval u; return varpri(car x,cdr x,v) end; symbolic procedure mkarg1(u,vars); % Returns the "unevaled" form of U for the WRITE command. if null u or constantp u then u else if atom u then if atsoc(u,vars) then list('mkquote,u) else mkquote u else if car u eq 'quote then mkquote u else if car u eq 'setq then list('list,''setq,mkquote cadr u,mkarg1(caddr u,vars)) else 'list . mapcar(u,function (lambda x; mkarg1(x,vars))); put('write,'stat,'rlis); put('write,'formfn,'formwrite); endmodule; module smacro; % Support for SMACRO expansion. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure applsmacro(u,vals,name); % U is smacro body of form (lambda ), VALS is % argument list, NAME is name of smacro. begin scalar body,remvars,varlist,w; varlist := cadr u; body := caddr u; if length varlist neq length vals then rederr list("Argument mismatch for SMACRO",name); if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body) then return subla!-q(pair(varlist,vals),body) else if length varlist>1 then <>; for each x in vals do <>; if null remvars then return body else <>; return w>> end; symbolic procedure no!-side!-effectp u; if atom u then numberp u or idp u and not(fluidp u or globalp u) else if car u eq 'quote then t else if flagp!*!*(car u,'nosideeffects) then no!-side!-effect!-listp u else nil; symbolic procedure no!-side!-effect!-listp u; null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u; flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons),'nosideeffects); symbolic procedure one!-entryp(u,v); % determines if id U occurs less than twice in V. if atom v then t else if smemq(u,car v) then if smemq(u,cdr v) then nil else one!-entryp(u,car v) else one!-entryp(u,cdr v); symbolic procedure one!-entry!-listp(u,v); null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v); symbolic procedure subla!-q(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= atsoc(v,u) then cdr x else v else if car v eq 'quote then return v else return(subla!-q(u,car v) . subla!-q(u,cdr v)) end; endmodule; module infix; % Functions for introducing new infix operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(preclis!*); symbolic procedure infix x; begin scalar y; a: if null x then go to b; y := car x; if !*mode eq 'algebraic then mkop y; if not(y member preclis!*) then preclis!* := y . preclis!*; x := cdr x; go to a; b: mkprec() end; symbolic procedure precedence u; begin scalar x,y,z; preclis!* := delete(car u,preclis!*); y := cadr u; x := preclis!*; a: if null x then rederr list (y,"not found") else if y eq car x then <>; z := car x . z; x := cdr x; go to a end; deflist('((infix rlis) (precedence rlis)),'stat); flag('(infix precedence),'eval); endmodule; module where; % Support for a where construct. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure formwhere(u,vars,mode); begin scalar expn,equivs,y,z; expn := cadr u; equivs := caddr u; if eqcar(equivs,'!*comma!*) then equivs := cdr equivs else equivs := list equivs; for each x in equivs do if not atom x and car x memq '(equal setq) then <> else rederr list(x,"invalid in WHERE statement"); return formc(list('lambda,reversip z,expn) . reversip y, vars,mode) end; put('where,'formfn,'formwhere); % infix where; % We do this explicitly to avoid changing preclis*. deflist('((where 1)),'infix); put('where,'op,'((1 1))); endmodule; module list; % Define a list as a list of expressions in curly brackets. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(orig!* posn!*); global '(cursym!*); % Add to system table. put('list,'tag,'list); put('list,'rtypefn,'(lambda (x) 'list)); % Parsing interface. symbolic procedure xreadlist; % expects a list of expressions enclosed by {, }. % also allows expressions separated by ; --- treats these as progn. begin scalar cursym,delim,lst; if scan() eq '!*rcbkt!* then <>; a: lst := aconc(lst,xread1 'group); cursym := cursym!*; scan(); if cursym eq '!*rcbkt!* then return if delim eq '!*semicol!* then 'progn . lst else 'list . lst else if null delim then delim := cursym else if not(delim eq cursym) then symerr("syntax error: mixed , and ; in list",nil); go to a end; put('!*lcbkt!*,'stat,'xreadlist); newtok '((!{) !*lcbkt!*); newtok '((!}) !*rcbkt!*); flag('(!*rcbkt!*),'delim); flag('(!*rcbkt!*),'nodel); % Evaluation interface. put('list,'evfn,'listeval); symbolic procedure getrlist u; if eqcar(u,'list) then cdr u else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list"); symbolic procedure listeval(u,v); if atom u then listeval(get(u,'rvalue),v) else car u . for each j in cdr u collect reval1(j,v); % Length interface. put('list,'lengthfn,'(lambda (x) (length (cdr x)))); % Printing interface. put('list,'prifn,'listpri); symbolic procedure listpri l; % This definition is basically that of INPRINT, except that it % decides when to split at the comma by looking at the size of % the argument. begin scalar orig,split,u; u := l; l := cdr l; prin2!* get('!*lcbkt!*,'prtch); % Do it this way so table can change. orig := orig!*; orig!* := if posn!*<18 then posn!* else orig!*+3; if null l then go to b; split := treesizep(l,40); % 40 is arbitrary choice. a: maprint(negnumberchk car l,0); l := cdr l; if null l then go to b; oprin '!*comma!*; if split then terpri!* t; go to a; b: prin2!* get('!*rcbkt!*,'prtch); % terpri!* nil; orig!* := orig; return u end; symbolic procedure treesizep(u,n); % true if u has recursively more pairs than n. treesizep1(u,n)=0; symbolic procedure treesizep1(u,n); if atom u then n-1 else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n) else 0; % Definitions of operations on lists symbolic procedure rfirst u; <>; put('first,'psopfn,'rfirst); symbolic procedure parterr(u,v); msgpri("Expression",u,"does not have part",v,t); symbolic procedure rsecond u; <>; put('second,'psopfn,'rsecond); symbolic procedure rthird u; <>; put('third,'psopfn,'rthird); symbolic procedure rrest u; <>; put('rest,'psopfn,'rrest); symbolic procedure rappend u; begin scalar x,y; argnochk ('append . u); if null(getrtype(x := reval car u) eq 'list) then typerr(x,"list") else if null(getrtype(y := reval cadr u) eq 'list) then typerr(y,"list") else return 'list .append(cdr x,cdr y) end; put('append,'psopfn,'rappend); symbolic procedure rcons u; begin scalar x,y; argnochk ('cons . u); if (y := getrtype(x := reval cadr u)) eq 'vector then return prepsq simpdot u else if not(y eq 'list) then typerr(x,"list") else return 'list . reval car u . cdr x end; put('cons,'psopfn,'rcons); symbolic procedure rreverse u; <>; put('reverse,'psopfn,'rreverse); endmodule; module array; % Array statement. % Author: Anthony C. Hearn. % Modifications by: Nancy Kirkwood. % These definitions are very careful about bounds checking. Appropriate % optimizations in a given system might really speed things up. global '(erfg!*); symbolic procedure getel u; % Returns the value of the array element U. getel1(get(car u,'rvalue),cdr u,get(car u,'dimension)); symbolic procedure getel1(u,v,dims); if length v neq length dims then rederr "Incorrect array reference" else if null v then u else if car v geq car dims then rederr "Array out of bounds" else getel1(getv(u,car v),cdr v,cdr dims); symbolic procedure setel(u,v); % Sets array element U to V and returns V. setel1(get(car u,'rvalue),cdr u,v,get(car u,'dimension)); symbolic procedure setel1(u,v,w,dims); if length v neq length dims then rederr "Incorrect array reference" else if car v geq car dims then rederr "Array out of bounds" else if null cdr v then putv(u,car v,w) else setel1(getv(u,car v),cdr v,w,cdr dims); symbolic procedure dimension u; get(u,'dimension); comment further support for REDUCE arrays; symbolic procedure typechk(u,v); begin scalar x; if (x := gettype u) eq v or x eq 'parameter then lprim list(v,u,"redefined") else if x then typerr(list(x,u),v) end; symbolic procedure arrayfn(u,v); % U is the defining mode, V a list of lists, assumed syntactically % correct. ARRAYFN declares each element as an array unless a % semantic mismatch occurs. begin scalar y; for each x in v do <>>> end; symbolic procedure add1lis u; if null u then nil else (car u+1) . add1lis cdr u; symbolic procedure mkarray(u,v); %U is a list of positive integers representing array bounds, V %the defining mode. Value is an array structure; if null u then if v eq 'symbolic then nil else 0 else begin integer n; scalar x; n := car u-1; x := mkvect n; for i:=0:n do putv(x,i,mkarray(cdr u,v)); return x end; rlistat '(array); flag ('(array arrayfn),'eval); symbolic procedure formarray(u,vars,mode); begin scalar x; x := cdr u; while x do <>; u := for each z in cdr u collect intargfn(z,vars,mode); %ARRAY arguments must be returned as quoted structures; return list('arrayfn,mkquote mode,'list . u) end; symbolic procedure listp u; % Returns T if U is a top level list. null u or not atom u and listp cdr u; put('array,'formfn,'formarray); put('array,'rtypefn,'arraychk); symbolic procedure arraychk u; % If arraychk receives NIL, it means that array name is being used % as an identifier. We no longer permit this. if null u then 'array else nil; % nil; put('array,'evfn,'arrayeval); symbolic procedure arrayeval(u,v); % Eventually we'll support this. rederr "Array arithmetic not defined"; put('array,'lengthfn,'arraylength); symbolic procedure arraylength u; 'list . get(u,'dimension); endmodule; module switch; % Support for switches and ON and OFF statements. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*switchcheck switchlist!*); % No references to RPLAC-based functions in this module. symbolic procedure on u; onoff(u,t); symbolic procedure off u; onoff(u,nil); symbolic procedure onoff(u,bool); for each j in u do begin scalar x,y; if not idp j then typerr(j,"switch") else if not flagp(j,'switch) then if !*switchcheck then rederr list(j,"not defined as switch") else lpriw("*****",list(j,"not defined as switch")); x := intern compress append(explode '!*,explode j); if !*switchcheck and eval x eq bool then return nil else if y := atsoc(bool,get(j,'simpfg)) then eval mkprog(nil,cdr y); set(x,bool) end; symbolic procedure switch u; % Declare list u as switches. for each x in u do begin scalar y; if not idp x then typerr(x,"switch"); if not u memq switchlist!* then switchlist!* := x . switchlist!*; flag(list x,'switch); y := intern compress append(explode '!*,explode x); if not fluidp y and not globalp y then fluid list y end; deflist('((switch rlis)),'stat); % we use deflist since it's flagged % eval rlistat '(off on); flag ('(off on),'ignore); % Symbolic mode switches: switch backtrace,comp,defn,demo,echo,errcont,int,msg,output,pret, quotenewnam,raise,time; % switchcheck. % The following are compiler switches that may not be supported in all % versions: switch pgwd,plap,pwrds; % flag('(switch),'eval); endmodule; module io; % Reduce functions for handling input and output of files. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*int semic!*); global '(!*echo contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!* techo!*); symbolic procedure file!-transform(u,v); % Performs a transformation on the file u. V is name of function % used for the transformation; begin scalar echo,ichan,oldichan,val; echo := !*echo; !*echo := nil; ichan := open(u,'input); oldichan := rds ichan; val := errorset(list v,t,!*backtrace); !*echo := echo; close ichan; rds oldichan; if not errorp val then return car val end; symbolic procedure infile u; % loads the single file u into REDUCE without echoing; begin scalar !*int; return file!-transform(u,function begin1) end; symbolic procedure in u; begin scalar chan,echo,echop,type; echop := semic!* eq '!;; %record echo character from input; echo := !*echo; %save current echo status; if null ifl!* then techo!* := !*echo; %terminal echo status; for each fl in u do <> else <>; ipl!* := ifl!* . ipl!*; %add to input file stack; !*echo := echop; type := filetype fl; if type and (type := get(type,'action)) then eval list type else begin1(); if chan then close chan; if fl eq caar ipl!* then ipl!* := cdr ipl!* else errach list("FILE STACK CONFUSION",fl,ipl!*)>>; !*echo := echo; %restore echo status; if ipl!* and null contl!* then ifl!* := car ipl!* else ifl!* := nil; if ifl!* then <> else rds nil end; symbolic procedure out u; %U is a list of one file; begin integer n; scalar chan,fl,x; n := linelength nil; if null u then return nil else if car u eq 't then return <>; fl := mkfil car u; if not (x := assoc(fl,opl!*)) then <>>> else ofl!* := x; wrs cdr ofl!*; linelength n end; symbolic procedure shut u; %U is a list of names of files to be shut; begin scalar fl1; for each fl in u do <>; close cdr fl1>> else if not (fl1 := assoc(fl,ipl!*)) then rederr list(fl,"not open") else if fl1 neq ifl!* then <> else rederr list("Cannot shut current input file",car fl1)>> end; deflist ('((in rlis) (out rlis) (shut rlis)),'stat); flag ('(in out shut),'eval); flag ('(in out shut),'ignore); endmodule; module inter; % Functions for interactive support. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*int); global '(!$eof!$ !*echo !*lessspace cloc!* contl!* curline!* edit!* eof!* erfg!* flg!* ifl!* ipl!* key!* ofl!* opl!* techo!*); symbolic procedure pause; %Must appear at the top-most level; if null !*int then nil else if key!* eq 'pause then pause1 nil else %typerr('pause,"lower level command"); pause1 nil; %Allow at lower level for now; symbolic procedure pause1 bool; begin if bool then if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?" then return <>; edit1(cloc!*,nil)>> else if flg!* then return (edit!* := nil); if null ifl!* or yesp "Cont?" then return nil; ifl!* := list(car ifl!*,cadr ifl!*,curline!*); contl!* := ifl!* . !*echo . contl!*; rds (ifl!* := nil); !*echo := techo!* end; symbolic procedure yesp u; begin scalar bool,ifl,ofl,x,y,z; if ifl!* then <>; if ofl!* then <>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (Y or N)"; if null !*lessspace then terpri(); z := setpchar '!?; a: x := read(); % Assume an end-of-file is the same as "yes". if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b; if null bool then prin2t "TYPE Y OR N"; bool := t; go to a; b: setpchar z; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return y end; symbolic procedure cont; begin scalar fl,techo; if ifl!* then return nil %CONT only active from terminal; else if null contl!* then rederr "No file open"; fl := car contl!*; techo := cadr contl!*; contl!* := cddr contl!*; if car fl=caar ipl!* and cadr fl=cadar ipl!* then <> else rds nil; !*echo := techo>> else <> end; deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat); flag ('(cont),'ignore); endmodule; comment Codemist Standard Lisp based REDUCE "back-end"; % this file defines the system dependent code necessary to run REDUCE % under Codemist Standard Lisp comment the following functions, which are referenced in the basic REDUCE source (rlisp, alg1, alg2, matr and phys) should be defined to complete the definition of REDUCE: bye delcp error1 filetype mkfil orderp quit random seprp setpchar. prototypical descriptions of these functions are as follows; remprop('bye,'stat); symbolic procedure bye; % returns control to the computer's operating system command level. % the current REDUCE job cannot be restarted; stop 0; deflist('((bye endstat)),'stat); remprop('quit,'stat); symbolic procedure quit; % returns control to the computer's operating system command level. % the current REDUCE job cannot be restarted; stop 0; deflist('((quit endstat)),'stat); symbolic procedure delcp u; if u = '!; or u = '!$ then t else nil; symbolic procedure filetype u; nil; symbolic procedure mkfil u; % converts file descriptor u into valid system filename; if idp u then u else if stringp u then string2file u else if eqcar(u,'quote) then mkfil cadr u else if atom u then nil else for each z in u collect mkfil z; symbolic procedure string2file s; % converts a string into a valid file name. s; fluid '(promptstring!*); procedure setpchar c; % set prompt, return old one begin scalar oldprompt; oldprompt := promptstring!*; promptstring!* := c; return oldprompt end; comment the following functions are only referenced if various flags are set, or the functions are actually defined. they are defined in another module, which is not needed to build the basic system. the name of the flag follows the function name, enclosed in parentheses: bfquotient!: (bigfloat) cedit (?) compd (comp) edit1 this function provides a link to an editor. however, a definition is not necessary, since REDUCE checks to see if it has a function value. embfn (?) ezgcdf (ezgcd) factorf (factor) load!-module (?) prettyprint (defn --- also called by dfprint) this function is used in particular for output of RLISP expressions in Lisp syntax. if that feature is needed, and the prettyprint module is not available, then it should be defined as print rprint (pret) texpt!: (bigfloat) texpt!:any (bigfloat) time (time) returns elapsed time from some arbitrary initial point in milliseconds; comment we also need to define a function begin, which acts as the top- level call to REDUCE, and sets the appropriate variables. the following is a minimum definition; fluid '(!*int !*mode); global '(crchar!* date!* ifl!* ipl!* ofl!* !*extraecho !*echo); remflag('(begin),'go); symbolic procedure begin; begin !*int := not batchp(); !*echo := not !*int; !*extraecho := t; ifl!* := ipl!* := ofl!* := nil; if null date!* then go to a; % verbos nil; % leave verbos flag as it had been linelength 79; prin2 date!*; prin2t " ..."; !*mode := if getd 'addsq then 'algebraic else 'symbolic; initreduce(); % resets date!*; erfg!* := !*defn := cmsg!* := nil; % reset error status; a: crchar!* := '! ; if errorp errorset('(begin1),t,!*backtrace) then go to a; if not yesp "are you sure you want to leave REDUCE & enter Lisp?" then go to a; prin2t "entering Lisp ... "; prin2t "type (begin) to re-enter REDUCE, (stop) to exit from Lisp"; end; flag('(begin),'go); comment initial setups for REDUCE; global '(spare!* statcounter); spare!* := 10; symbolic procedure initreduce; %. initial declarations for REDUCE <>; flag('(reclaim rdf),'opfn); flag('(explode2 printc princ ttab unglobal random next!-random!-number), 'lose); % redo showtime for Codemist Lisp interpretation of gctime vs. time remflag('(showtime), 'lose); symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!*-x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; % x := x - y; % not for Codemist Lisp terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; flag('(lengthc), 'lose); symbolic procedure typerr(u, v); % redefined when I get to alg1.red, but smashes before then % need some support, I guess << terpri(); princ "+++++ typerr: "; prin u; princ " "; prin v; terpri(); error "typerr called" >>; symbolic procedure flush(); begin scalar c; while (c:=readch()) neq !$eol!$ and c neq !$eof!$ do nil; return nil end; flag('(cedit1), 'lose); % redefinition of yesp to improve prompt generation remflag('(yesp), 'lose); symbolic procedure yesp u; begin scalar bool,ifl,ofl,x,y,z; if ifl!* then <>; if ofl!* then <>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (y or n)"; if null !*lessspace then terpri(); z := setpchar '!?; a: prin2 '!?; x := read(); % assume an end-of-file is the same as "yes". if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b; if null bool then prin2t "type y or n"; bool := t; go to a; b: setpchar z; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return y end; % support for some more floating point stuff global '(ft!-tolerance!* e!-value!* pi!-value!*); ft!-tolerance!* := float 1 / float 1000000000000; e!-value!* := exp 1.0; pi!-value!* := 4.0 * atan 1.0; comment now set the system name; global '(systemname!*); systemname!* := 'csl; initreduce(); eval '(begin); % (*) % in "extras.red"$ % in "compiler.red"$ % compile!-all(); off comp,echo; verbos nil; linelength 78; !*force := t; symbolic procedure pptt u; << prettyprint u; terpri(); terpri(); u >>; dfprint!* := 'pptt; out "$cslbase/extras.lsp"$ on defn$ in "$cslbase/extras.red"$ off defn$ out t$ "extras.lsp created from extras.red"; out "$cslbase/compiler.lsp"$ on defn$ in "$cslbase/compiler.red"$ off defn$ out t$ "compiler.lsp created from compiler.red"; out "$cslbase/ccomp.lsp"$ on defn$ in "$cslbase/ccomp.red"$ off defn$ out t$ "ccomp.lsp created from ccomp.red"; bye; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compiler.lsp0000644000175000017500000104617311550002751024120 0ustar giovannigiovanni % RLISP to LISP converter. A C Norman 2004 %% %% Copyright (C) 2010, following the master REDUCE source files. * %% * %% Redistribution and use in source and binary forms, with or without * %% modification, are permitted provided that the following conditions are * %% met: * %% * %% * Redistributions of source code must retain the relevant * %% copyright notice, this list of conditions and the following * %% disclaimer. * %% * Redistributions in binary form must reproduce the above * %% copyright notice, this list of conditions and the following * %% disclaimer in the documentation and/or other materials provided * %% with the distribution. * %% * %% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * %% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * %% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * %% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * %% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * %% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * %% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * %% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * %% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * %% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * %% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * %% DAMAGE. * %% (global (quote (s!:opcodelist))) (setq s!:opcodelist (quote (LOADLOC LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 LOC0LOC1 LOC1LOC2 LOC2LOC3 LOC1LOC0 LOC2LOC1 LOC3LOC2 VNIL LOADLIT LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 LOADFREE LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4 STORELOC STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 STOREFREE STOREFREE1 STOREFREE2 STOREFREE3 LOADLEX STORELEX CLOSURE CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11 CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5 CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3 CALL0 CALL1 CALL2 CALL2R CALL3 CALLN CALL0_0 CALL0_1 CALL0_2 CALL0_3 CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4 BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 APPLY1 APPLY2 APPLY3 APPLY4 JCALL JCALLN JUMP JUMP_B JUMP_L JUMP_BL JUMPNIL JUMPNIL_B JUMPNIL_L JUMPNIL_BL JUMPT JUMPT_B JUMPT_L JUMPT_BL JUMPATOM JUMPATOM_B JUMPATOM_L JUMPATOM_BL JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T JUMPL2NIL JUMPL2T JUMPL3NIL JUMPL3T JUMPL4NIL JUMPL4T JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T JUMPST2NIL JUMPST2T JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM JUMPL2ATOM JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL JUMPFREE2T JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T JUMPFREENIL JUMPFREET JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE JUMPLIT3EQ JUMPLIT3NE JUMPLIT4EQ JUMPLIT4NE JUMPLITEQ JUMPLITNE JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T JUMPFLAGP JUMPNFLAGP JUMPEQCAR JUMPNEQCAR CATCH CATCH_B CATCH_L CATCH_BL UNCATCH THROW PROTECT UNPROTECT PVBIND PVRESTORE FREEBIND FREERSTR EXIT NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS POP LOSE LOSE2 LOSE3 LOSES SWOP EQ EQCAR EQUAL NUMBERP CAR CDR CAAR CADR CDAR CDDR CONS NCONS XCONS ACONS LENGTH LIST2 LIST2STAR LIST3 PLUS2 ADD1 DIFFERENCE SUB1 TIMES2 GREATERP LESSP FLAGP GET LITGET GETV QGETV QGETVN BIGSTACK BIGCALL ICASE FASTGET SPARE1 SPARE2))) (prog (n) (setq n 0) (prog (var1001) (setq var1001 s!:opcodelist) lab1000 ( cond ((null var1001) (return nil))) (prog (v) (setq v (car var1001)) (progn ( put v (quote s!:opcode) n) (setq n (plus n 1)))) (setq var1001 (cdr var1001)) (go lab1000)) (return (list n (quote opcodes) (quote allocated)))) (setq s!:opcodelist nil) (fluid (quote (s!:env_alist))) (de s!:vecof (l) (prog (w) (setq w (assoc l s!:env_alist)) (cond (w (return ( cdr w)))) (setq w (s!:vecof1 l)) (setq s!:env_alist (cons (cons l w) s!:env_alist)) (return w))) (de s!:vecof1 (l) (prog (v n) (setq v (mkvect (sub1 (length l)))) (setq n 0) (prog (var1003) (setq var1003 l) lab1002 (cond ((null var1003) (return nil))) (prog (x) (setq x (car var1003)) (progn (putv v n x) (setq n (plus n 1)))) ( setq var1003 (cdr var1003)) (go lab1002)) (return v))) (progn (put (quote batchp) (quote s!:builtin0) 0) (put (quote date) (quote s!:builtin0) 1) (put (quote eject) (quote s!:builtin0) 2) (put (quote error1) (quote s!:builtin0) 3) (put (quote gctime) (quote s!:builtin0) 4) (put ( quote lposn) (quote s!:builtin0) 6) (put (quote posn) (quote s!:builtin0) 8) (put (quote read) (quote s!:builtin0) 9) (put (quote readch) (quote s!:builtin0) 10) (put (quote terpri) (quote s!:builtin0) 11) (put (quote time ) (quote s!:builtin0) 12) (put (quote tyi) (quote s!:builtin0) 13) (put ( quote load!-spid) (quote s!:builtin0) 14) (put (quote abs) (quote s!:builtin1 ) 0) (put (quote add1) (quote s!:builtin1) 1) (put (quote atan) (quote s!:builtin1) 2) (put (quote apply0) (quote s!:builtin1) 3) (put (quote atom) (quote s!:builtin1) 4) (put (quote boundp) (quote s!:builtin1) 5) (put (quote char!-code) (quote s!:builtin1) 6) (put (quote close) (quote s!:builtin1) 7) (put (quote codep) (quote s!:builtin1) 8) (put (quote compress) (quote s!:builtin1) 9) (put (quote constantp) (quote s!:builtin1) 10) (put (quote digit) (quote s!:builtin1) 11) (put (quote endp) (quote s!:builtin1) 12) (put (quote eval) (quote s!:builtin1) 13) (put (quote evenp) (quote s!:builtin1) 14) (put (quote evlis) (quote s!:builtin1) 15) (put (quote explode) (quote s!:builtin1) 16) (put (quote explode2lc) (quote s!:builtin1) 17) (put (quote explode2) (quote s!:builtin1) 18) (put (quote explodec) (quote s!:builtin1) 18) (put (quote fixp) (quote s!:builtin1) 19) (put (quote float) (quote s!:builtin1) 20) (put (quote floatp) (quote s!:builtin1) 21) (put (quote symbol!-specialp) (quote s!:builtin1) 22) (put (quote gc) (quote s!:builtin1) 23) (put (quote gensym1) (quote s!:builtin1) 24) (put (quote getenv) (quote s!:builtin1) 25) (put (quote symbol!-globalp) (quote s!:builtin1) 26) (put ( quote iadd1) (quote s!:builtin1) 27) (put (quote symbolp) (quote s!:builtin1) 28) (put (quote iminus) (quote s!:builtin1) 29) (put (quote iminusp) (quote s!:builtin1) 30) (put (quote indirect) (quote s!:builtin1) 31) (put (quote integerp) (quote s!:builtin1) 32) (put (quote intern) (quote s!:builtin1) 33) (put (quote isub1) (quote s!:builtin1) 34) (put (quote length) (quote s!:builtin1) 35) (put (quote lengthc) (quote s!:builtin1) 36) (put (quote linelength) (quote s!:builtin1) 37) (put (quote liter) (quote s!:builtin1) 38 ) (put (quote load!-module) (quote s!:builtin1) 39) (put (quote lognot) ( quote s!:builtin1) 40) (put (quote macroexpand) (quote s!:builtin1) 41) (put (quote macroexpand!-1) (quote s!:builtin1) 42) (put (quote macro!-function) ( quote s!:builtin1) 43) (put (quote make!-bps) (quote s!:builtin1) 44) (put ( quote make!-global) (quote s!:builtin1) 45) (put (quote make!-simple!-string) (quote s!:builtin1) 46) (put (quote make!-special) (quote s!:builtin1) 47) ( put (quote minus) (quote s!:builtin1) 48) (put (quote minusp) (quote s!:builtin1) 49) (put (quote mkvect) (quote s!:builtin1) 50) (put (quote modular!-minus) (quote s!:builtin1) 51) (put (quote modular!-number) (quote s!:builtin1) 52) (put (quote modular!-reciprocal) (quote s!:builtin1) 53) ( put (quote null) (quote s!:builtin1) 54) (put (quote oddp) (quote s!:builtin1 ) 55) (put (quote onep) (quote s!:builtin1) 56) (put (quote pagelength) ( quote s!:builtin1) 57) (put (quote pairp) (quote s!:builtin1) 58) (put (quote plist) (quote s!:builtin1) 59) (put (quote plusp) (quote s!:builtin1) 60) ( put (quote prin) (quote s!:builtin1) 61) (put (quote princ) (quote s!:builtin1) 62) (put (quote print) (quote s!:builtin1) 63) (put (quote printc) (quote s!:builtin1) 64) (put (quote rds) (quote s!:builtin1) 68) (put (quote remd) (quote s!:builtin1) 69) (put (quote reverse) (quote s!:builtin1 ) 70) (put (quote reversip) (quote s!:builtin1) 71) (put (quote seprp) (quote s!:builtin1) 72) (put (quote set!-small!-modulus) (quote s!:builtin1) 73) ( put (quote spaces) (quote s!:builtin1) 74) (put (quote xtab) (quote s!:builtin1) 74) (put (quote special!-char) (quote s!:builtin1) 75) (put ( quote special!-form!-p) (quote s!:builtin1) 76) (put (quote spool) (quote s!:builtin1) 77) (put (quote stop) (quote s!:builtin1) 78) (put (quote stringp) (quote s!:builtin1) 79) (put (quote sub1) (quote s!:builtin1) 80) ( put (quote symbol!-env) (quote s!:builtin1) 81) (put (quote symbol!-function) (quote s!:builtin1) 82) (put (quote symbol!-name) (quote s!:builtin1) 83) ( put (quote symbol!-value) (quote s!:builtin1) 84) (put (quote system) (quote s!:builtin1) 85) (put (quote fix) (quote s!:builtin1) 86) (put (quote ttab) ( quote s!:builtin1) 87) (put (quote tyo) (quote s!:builtin1) 88) (put (quote remob) (quote s!:builtin1) 89) (put (quote unmake!-global) (quote s!:builtin1 ) 90) (put (quote unmake!-special) (quote s!:builtin1) 91) (put (quote upbv) (quote s!:builtin1) 92) (put (quote vectorp) (quote s!:builtin1) 93) (put ( quote verbos) (quote s!:builtin1) 94) (put (quote wrs) (quote s!:builtin1) 95 ) (put (quote zerop) (quote s!:builtin1) 96) (put (quote car) (quote s!:builtin1) 97) (put (quote cdr) (quote s!:builtin1) 98) (put (quote caar) ( quote s!:builtin1) 99) (put (quote cadr) (quote s!:builtin1) 100) (put (quote cdar) (quote s!:builtin1) 101) (put (quote cddr) (quote s!:builtin1) 102) ( put (quote qcar) (quote s!:builtin1) 103) (put (quote qcdr) (quote s!:builtin1) 104) (put (quote qcaar) (quote s!:builtin1) 105) (put (quote qcadr) (quote s!:builtin1) 106) (put (quote qcdar) (quote s!:builtin1) 107) ( put (quote qcddr) (quote s!:builtin1) 108) (put (quote ncons) (quote s!:builtin1) 109) (put (quote numberp) (quote s!:builtin1) 110) (put (quote is!-spid) (quote s!:builtin1) 111) (put (quote spid!-to!-nil) (quote s!:builtin1) 112) (put (quote append) (quote s!:builtin2) 0) (put (quote ash) (quote s!:builtin2) 1) (put (quote assoc) (quote s!:builtin2) 2) (put (quote assoc!*!*) (quote s!:builtin2) 2) (put (quote atsoc) (quote s!:builtin2) 3) (put (quote deleq) (quote s!:builtin2) 4) (put (quote delete) (quote s!:builtin2) 5) (put (quote divide) (quote s!:builtin2) 6) (put (quote eqcar) (quote s!:builtin2) 7) (put (quote eql) (quote s!:builtin2) 8) (put (quote eqn) (quote s!:builtin2) 9) (put (quote expt) (quote s!:builtin2) 10) (put ( quote flag) (quote s!:builtin2) 11) (put (quote flagpcar) (quote s!:builtin2) 12) (put (quote gcdn) (quote s!:builtin2) 13) (put (quote geq) (quote s!:builtin2) 14) (put (quote getv) (quote s!:builtin2) 15) (put (quote greaterp) (quote s!:builtin2) 16) (put (quote idifference) (quote s!:builtin2 ) 17) (put (quote igreaterp) (quote s!:builtin2) 18) (put (quote ilessp) ( quote s!:builtin2) 19) (put (quote imax) (quote s!:builtin2) 20) (put (quote imin) (quote s!:builtin2) 21) (put (quote iplus2) (quote s!:builtin2) 22) ( put (quote iquotient) (quote s!:builtin2) 23) (put (quote iremainder) (quote s!:builtin2) 24) (put (quote irightshift) (quote s!:builtin2) 25) (put (quote itimes2) (quote s!:builtin2) 26) (put (quote leq) (quote s!:builtin2) 28) ( put (quote lessp) (quote s!:builtin2) 29) (put (quote max2) (quote s!:builtin2) 31) (put (quote member) (quote s!:builtin2) 32) (put (quote member!*!*) (quote s!:builtin2) 32) (put (quote memq) (quote s!:builtin2) 33) (put (quote min2) (quote s!:builtin2) 34) (put (quote mod) (quote s!:builtin2) 35) (put (quote modular!-difference) (quote s!:builtin2) 36) ( put (quote modular!-expt) (quote s!:builtin2) 37) (put (quote modular!-plus) (quote s!:builtin2) 38) (put (quote modular!-quotient) (quote s!:builtin2) 39 ) (put (quote modular!-times) (quote s!:builtin2) 40) (put (quote nconc) ( quote s!:builtin2) 41) (put (quote neq) (quote s!:builtin2) 42) (put (quote orderp) (quote s!:builtin2) 43) (put (quote quotient) (quote s!:builtin2) 44) (put (quote remainder) (quote s!:builtin2) 45) (put (quote remflag) (quote s!:builtin2) 46) (put (quote remprop) (quote s!:builtin2) 47) (put (quote rplaca) (quote s!:builtin2) 48) (put (quote rplacd) (quote s!:builtin2) 49) ( put (quote schar) (quote s!:builtin2) 50) (put (quote set) (quote s!:builtin2 ) 51) (put (quote smemq) (quote s!:builtin2) 52) (put (quote subla) (quote s!:builtin2) 53) (put (quote sublis) (quote s!:builtin2) 54) (put (quote symbol!-set!-definition) (quote s!:builtin2) 55) (put (quote symbol!-set!-env ) (quote s!:builtin2) 56) (put (quote times2) (quote s!:builtin2) 57) (put ( quote xcons) (quote s!:builtin2) 58) (put (quote equal) (quote s!:builtin2) 59) (put (quote eq) (quote s!:builtin2) 60) (put (quote cons) (quote s!:builtin2) 61) (put (quote list2) (quote s!:builtin2) 62) (put (quote get) (quote s!:builtin2) 63) (put (quote qgetv) (quote s!:builtin2) 64) (put ( quote flagp) (quote s!:builtin2) 65) (put (quote apply1) (quote s!:builtin2) 66) (put (quote difference) (quote s!:builtin2) 67) (put (quote plus2) (quote s!:builtin2) 68) (put (quote times2) (quote s!:builtin2) 69) (put (quote equalcar) (quote s!:builtin2) 70) (put (quote iequal) (quote s!:builtin2) 71) (put (quote nreverse) (quote s!:builtin2) 72) (put (quote bps!-putv) (quote s!:builtin3) 0) (put (quote errorset) (quote s!:builtin3) 1) (put (quote list2!*) (quote s!:builtin3) 2) (put (quote list3) (quote s!:builtin3) 3) ( put (quote putprop) (quote s!:builtin3) 4) (put (quote putv) (quote s!:builtin3) 5) (put (quote putv!-char) (quote s!:builtin3) 6) (put (quote subst) (quote s!:builtin3) 7) (put (quote apply2) (quote s!:builtin3) 8) (put (quote acons) (quote s!:builtin3) 9) nil) (de s!:prinhex1 (n) (princ (schar "0123456789abcdef" (logand n 15)))) (de s!:prinhex2 (n) (progn (s!:prinhex1 (truncate n 16)) (s!:prinhex1 n))) (de s!:prinhex4 (n) (progn (s!:prinhex2 (truncate n 256)) (s!:prinhex2 n))) (flag (quote (comp plap pgwd pwrds notailcall ord nocompile carcheckflag savedef carefuleq r2i native_code save_native strip_native)) (quote switch)) (cond ((not (boundp (quote !*comp))) (progn (fluid (quote (!*comp))) (setq !*comp t)))) (cond ((not (boundp (quote !*nocompile))) (progn (fluid (quote (!*nocompile)) ) (setq !*nocompile nil)))) (cond ((not (boundp (quote !*plap))) (progn (fluid (quote (!*plap))) (setq !*plap nil)))) (cond ((not (boundp (quote !*pgwd))) (progn (fluid (quote (!*pgwd))) (setq !*pgwd nil)))) (cond ((not (boundp (quote !*pwrds))) (progn (fluid (quote (!*pwrds))) (setq !*pwrds t)))) (cond ((not (boundp (quote !*notailcall))) (progn (fluid (quote (!*notailcall ))) (setq !*notailcall nil)))) (cond ((not (boundp (quote !*ord))) (progn (fluid (quote (!*ord))) (setq !*ord nil)))) (cond ((not (boundp (quote !*savedef))) (progn (fluid (quote (!*savedef))) ( setq !*savedef nil)))) (cond ((not (boundp (quote !*carcheckflag))) (progn (fluid (quote ( !*carcheckflag))) (setq !*carcheckflag t)))) (cond ((not (boundp (quote !*carefuleq))) (progn (fluid (quote (!*carefuleq)) ) (setq !*carefuleq (or (and (boundp (quote lispsystem!*)) (not (null (member (quote jlisp) lispsystem!*)))) (and (boundp (quote !*features!*)) (not (null (member (quote !:jlisp) !*features!*))))))))) (cond ((not (boundp (quote !*r2i))) (progn (fluid (quote (!*r2i))) (setq !*r2i t)))) (cond ((not (boundp (quote !*native_code))) (progn (fluid (quote ( !*native_code))) (setq !*native_code nil)))) (cond ((not (boundp (quote !*save_native))) (progn (fluid (quote ( !*save_native))) (setq !*save_native nil)))) (cond ((not (boundp (quote !*strip_native))) (progn (fluid (quote ( !*strip_native))) (setq !*strip_native t)))) (global (quote (s!:native_file))) (fluid (quote (s!:current_function s!:current_label s!:current_block s!:current_size s!:current_procedure s!:other_defs s!:lexical_env s!:has_closure s!:recent_literals s!:used_lexicals s!:a_reg_values s!:current_count))) (de s!:start_procedure (nargs nopts restarg) (progn (setq s!:current_procedure nil) (setq s!:current_label (gensym)) (setq s!:a_reg_values nil) (cond ((or (not (zerop nopts)) restarg) (progn (setq s!:current_block (list (list (quote OPTARGS) nopts) nopts (list (quote ARGCOUNT) nargs) nargs)) (setq s!:current_size 2))) (t (cond ((greaterp nargs 3) (progn (setq s!:current_block (list (list (quote ARGCOUNT) nargs) nargs)) (setq s!:current_size 1))) (t (progn (setq s!:current_block nil) (setq s!:current_size 0)))))))) (de s!:set_label (x) (progn (cond (s!:current_label (prog (w) (setq w (cons s!:current_size s!:current_block)) (prog (var1005) (setq var1005 s!:recent_literals) lab1004 (cond ((null var1005) (return nil))) (prog (x) ( setq x (car var1005)) (rplaca x w)) (setq var1005 (cdr var1005)) (go lab1004) ) (setq s!:recent_literals nil) (setq s!:current_procedure (cons (cons s!:current_label (cons (list (quote JUMP) x) w)) s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0)))) (setq s!:current_label x) (setq s!:a_reg_values nil))) (de s!:outjump (op lab) (prog (g w) (cond ((not (flagp op (quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (cond ((equal op (quote JUMP)) (setq op (list op lab))) (t ( cond ((equal op (quote ICASE)) (setq op (cons op lab))) (t (setq op (list op lab (setq g (gensym)))))))) (setq w (cons s!:current_size s!:current_block)) (prog (var1007) (setq var1007 s!:recent_literals) lab1006 (cond ((null var1007) (return nil))) (prog (x) (setq x (car var1007)) (rplaca x w)) (setq var1007 (cdr var1007)) (go lab1006)) (setq s!:recent_literals nil) (setq s!:current_procedure (cons (cons s!:current_label (cons op w)) s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( setq s!:current_label g) (return op))) (de s!:outexit nil (prog (w op) (setq op (quote (EXIT))) (cond ((null s!:current_label) (return nil))) (setq w (cons s!:current_size s!:current_block)) (prog (var1009) (setq var1009 s!:recent_literals) lab1008 (cond ((null var1009) (return nil))) (prog (x) (setq x (car var1009)) (rplaca x w)) (setq var1009 (cdr var1009)) (go lab1008)) (setq s!:recent_literals nil) (setq s!:current_procedure (cons (cons s!:current_label (cons op w)) s!:current_procedure)) (setq s!:current_block nil) (setq s!:current_size 0) ( setq s!:current_label nil))) (flag (quote (PUSH PUSHNIL PUSHNIL2 PUSHNIL3 LOSE LOSE2 LOSE3 LOSES STORELOC STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 JUMP JUMPT JUMPNIL JUMPEQ JUMPEQUAL JUMPNE JUMPNEQUAL JUMPATOM JUMPNATOM)) (quote s!:preserves_a)) (de s!:outopcode0 (op doc) (prog nil (cond ((not (flagp op (quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (setq s!:current_block (cons op s!:current_block)) (setq s!:current_size (plus s!:current_size 1)) (cond ((or !*plap !*pgwd) (setq s!:current_block (cons doc s!:current_block)))))) (de s!:outopcode1 (op arg doc) (prog nil (cond ((not (flagp op (quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) (setq s!:current_size (plus s!:current_size 2)) (cond ((or !*plap !*pgwd) ( setq s!:current_block (cons (list op doc) s!:current_block)))))) (deflist (quote ((LOADLIT 1) (LOADFREE 2) (CALL0 2) (CALL1 2) (LITGET 2) ( JUMPLITEQ 2) (JUMPLITNE 2) (JUMPLITEQ!* 2) (JUMPLITNE!* 2) (JUMPFREET 2) ( JUMPFREENIL 2))) (quote s!:short_form_bonus)) (de s!:record_literal (env) (prog (w extra) (setq w (gethash (car s!:current_block) (car env))) (cond ((null w) (setq w (cons 0 nil)))) (setq extra (get (cadr s!:current_block) (quote s!:short_form_bonus))) (cond ((null extra) (setq extra 10)) (t (setq extra (plus extra 10)))) (setq s!:recent_literals (cons (cons nil s!:current_block) s!:recent_literals)) ( puthash (car s!:current_block) (car env) (cons (plus (car w) extra) (cons ( car s!:recent_literals) (cdr w)))))) (de s!:record_literal_for_jump (x env lab) (prog (w extra) (cond ((null s!:current_label) (return nil))) (setq w (gethash (cadr x) (car env))) (cond ((null w) (setq w (cons 0 nil)))) (setq extra (get (car x) (quote s!:short_form_bonus))) (cond ((null extra) (setq extra 10)) (t (setq extra ( plus extra 10)))) (setq x (s!:outjump x lab)) (puthash (cadar x) (car env) ( cons (plus (car w) extra) (cons (cons nil x) (cdr w)))))) (de s!:outopcode1lit (op arg env) (prog nil (cond ((not (flagp op (quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (setq s!:current_block (cons arg (cons op s!:current_block))) (s!:record_literal env) (setq s!:current_size (plus s!:current_size 2)) ( cond ((or !*plap !*pgwd) (setq s!:current_block (cons (list op arg) s!:current_block)))))) (de s!:outopcode2 (op arg1 arg2 doc) (prog nil (cond ((not (flagp op (quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (setq s!:current_block (cons arg2 (cons arg1 (cons op s!:current_block)))) (setq s!:current_size (plus s!:current_size 3)) (cond (( or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block )))))) (de s!:outopcode2lit (op arg1 arg2 doc env) (prog nil (cond ((not (flagp op ( quote s!:preserves_a))) (setq s!:a_reg_values nil))) (cond ((null s!:current_label) (return nil))) (setq s!:current_block (cons arg1 (cons op s!:current_block))) (s!:record_literal env) (setq s!:current_block (cons arg2 s!:current_block)) (setq s!:current_size (plus s!:current_size 3)) (cond (( or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block )))))) (de s!:outlexref (op arg1 arg2 arg3 doc) (prog (arg4) (cond ((null s!:current_label) (return nil))) (cond ((or (greaterp arg1 255) (greaterp arg2 255) (greaterp arg3 255)) (progn (cond ((or (greaterp arg1 2047) ( greaterp arg2 31) (greaterp arg3 2047)) (error 0 "stack frame > 2047 or > 31 deep nesting"))) (setq doc (list op doc)) (setq arg4 (logand arg3 255)) (setq arg3 (plus (truncate arg3 256) (times 16 ( logand arg1 15)))) (cond ((equal op (quote LOADLEX)) (setq op (plus 192 arg2) )) (t (setq op (plus 224 arg2)))) (setq arg2 (truncate arg1 16)) (setq arg1 op) (setq op (quote BIGSTACK)))) (t (setq doc (list doc)))) (setq s!:current_block (cons arg3 (cons arg2 (cons arg1 (cons op s!:current_block)) ))) (setq s!:current_size (plus s!:current_size 4)) (cond (arg4 (progn (setq s!:current_block (cons arg4 s!:current_block)) (setq s!:current_size (plus s!:current_size 1))))) (cond ((or !*plap !*pgwd) (setq s!:current_block (cons (cons op doc) s!:current_block)))))) (put (quote LOADLIT) (quote s!:shortform) (cons (quote (1 . 7)) (s!:vecof ( quote (!- LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7))))) (put (quote LOADFREE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( quote (!- LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4))))) (put (quote STOREFREE) (quote s!:shortform) (cons (quote (1 . 3)) (s!:vecof ( quote (!- STOREFREE1 STOREFREE2 STOREFREE3))))) (put (quote CALL0) (quote s!:shortform) (cons (quote (0 . 3)) (s!:vecof ( quote (CALL0_0 CALL0_1 CALL0_2 CALL0_3))))) (put (quote CALL1) (quote s!:shortform) (cons (quote (0 . 5)) (s!:vecof ( quote (CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5))))) (put (quote CALL2) (quote s!:shortform) (cons (quote (0 . 4)) (s!:vecof ( quote (CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4))))) (put (quote JUMPFREET) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( quote (!- JUMPFREE1T JUMPFREE2T JUMPFREE3T JUMPFREE4T))))) (put (quote JUMPFREENIL) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof (quote (!- JUMPFREE1NIL JUMPFREE2NIL JUMPFREE3NIL JUMPFREE4NIL))))) (put (quote JUMPLITEQ) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( quote (!- JUMPLIT1EQ JUMPLIT2EQ JUMPLIT3EQ JUMPLIT4EQ))))) (put (quote JUMPLITNE) (quote s!:shortform) (cons (quote (1 . 4)) (s!:vecof ( quote (!- JUMPLIT1NE JUMPLIT2NE JUMPLIT3NE JUMPLIT4NE))))) (put (quote JUMPLITEQ!*) (quote s!:shortform) (get (quote JUMPLITEQ) (quote s!:shortform))) (put (quote JUMPLITNE!*) (quote s!:shortform) (get (quote JUMPLITNE) (quote s!:shortform))) (put (quote CALL0) (quote s!:longform) 0) (put (quote CALL1) (quote s!:longform) 16) (put (quote CALL2) (quote s!:longform) 32) (put (quote CALL3) (quote s!:longform) 48) (put (quote CALLN) (quote s!:longform) 64) (put (quote CALL2R) (quote s!:longform) 80) (put (quote LOADFREE) (quote s!:longform) 96) (put (quote STOREFREE) (quote s!:longform) 112) (put (quote JCALL0) (quote s!:longform) 128) (put (quote JCALL1) (quote s!:longform) 144) (put (quote JCALL2) (quote s!:longform) 160) (put (quote JCALL3) (quote s!:longform) 176) (put (quote JCALLN) (quote s!:longform) 192) (put (quote FREEBIND) (quote s!:longform) 208) (put (quote LITGET) (quote s!:longform) 224) (put (quote LOADLIT) (quote s!:longform) 240) (de s!:literal_order (a b) (cond ((equal (cadr a) (cadr b)) (orderp (car a) ( car b))) (t (greaterp (cadr a) (cadr b))))) (de s!:resolve_literals (env checksum) (prog (w op opspec n litbytes) (setq w (hashcontents (car env))) (setq w (sort w (function s!:literal_order))) ( setq w (append w (list (list checksum 0)))) (setq n (length w)) (setq litbytes (times 4 n)) (cond ((greaterp n 4096) (setq w (s!:too_many_literals w n)))) (setq n 0) (prog (var1011) (setq var1011 w) lab1010 (cond ((null var1011) (return nil))) (prog (x) (setq x (car var1011)) (progn (rplaca (cdr x) n) (setq n (plus n 1)))) (setq var1011 (cdr var1011)) (go lab1010)) (prog (var1015) (setq var1015 w) lab1014 (cond ((null var1015) (return nil))) (prog (x) (setq x (car var1015)) (progn (setq n (cadr x)) (prog (var1013) (setq var1013 (cddr x)) lab1012 (cond ((null var1013) (return nil))) (prog (y) ( setq y (car var1013)) (progn (cond ((null (car y)) (progn (setq op (caadr y)) (setq opspec (get op (quote s!:shortform))) (cond ((and opspec (leq (caar opspec) n) (leq n (cdar opspec))) (rplaca (cdr y) (getv (cdr opspec) n))) (t (rplaca (cdadr y) n))))) (t (progn (setq op (caddr y)) (cond ((greaterp n 255 ) (progn (rplaca (car y) (plus (caar y) 1)) (setq op (plus (get op (quote s!:longform)) (truncate n 256))) (rplaca (cdr y) (ilogand n 255)) (rplaca ( cddr y) (quote BIGCALL)) (rplacd (cdr y) (cons op (cddr y))))) (t (cond ((and (setq opspec (get op (quote s!:shortform))) (leq (caar opspec) n) (leq n ( cdar opspec))) (progn (rplaca (car y) (difference (caar y) 1)) (rplaca (cdr y ) (getv (cdr opspec) n)) (rplacd (cdr y) (cdddr y)))) (t (rplaca (cdr y) n))) ))))))) (setq var1013 (cdr var1013)) (go lab1012)))) (setq var1015 (cdr var1015)) (go lab1014)) (prog (var1017) (setq var1017 w) lab1016 (cond ((null var1017) (return nil))) (prog (x) (setq x (car var1017)) (rplacd x (cadr x)) ) (setq var1017 (cdr var1017)) (go lab1016)) (rplaca env (cons (reversip w) litbytes)))) (de s!:only_loadlit (l) (cond ((null l) t) (t (cond ((null (caar l)) nil) (t (cond ((not (eqcar (cddar l) (quote LOADLIT))) nil) (t (s!:only_loadlit (cdr l))))))))) (de s!:too_many_literals (w n) (prog (k xvecs l r newrefs uses z1) (setq k 0) (setq n (plus n 1)) (prog nil lab1018 (cond ((null (and (greaterp n 4096) ( not (null w)))) (return nil))) (progn (cond ((and (not (equal (cadar w) 10000000)) (s!:only_loadlit (cddar w))) (progn (setq l (cons (car w) l)) ( setq n (difference n 1)) (setq k (plus k 1)) (cond ((equal k 256) (progn ( setq xvecs (cons l xvecs)) (setq l nil) (setq k 0) (setq n (plus n 1))))))) ( t (setq r (cons (car w) r)))) (setq w (cdr w))) (go lab1018)) (cond (( greaterp n 4096) (error 0 "function uses too many literals (4096 is limit)")) ) (setq xvecs (cons l xvecs)) (prog nil lab1019 (cond ((null r) (return nil)) ) (progn (setq w (cons (car r) w)) (setq r (cdr r))) (go lab1019)) (prog ( var1025) (setq var1025 xvecs) lab1024 (cond ((null var1025) (return nil))) ( prog (v) (setq v (car var1025)) (progn (setq newrefs nil) (setq uses 0) (setq r nil) (setq k 0) (prog (var1023) (setq var1023 v) lab1022 (cond ((null var1023) (return nil))) (prog (q) (setq q (car var1023)) (progn (prog ( var1021) (setq var1021 (cddr q)) lab1020 (cond ((null var1021) (return nil))) (prog (z) (setq z (car var1021)) (progn (cond ((car z) (rplaca (car z) (plus (caar z) 2)))) (setq z1 (cons (quote QGETVN) (cons nil (cddr z)))) (rplaca ( cdr z) k) (rplacd (cdr z) z1) (rplacd z (cdr z1)) (setq newrefs (cons z newrefs)) (setq uses (plus uses 11)))) (setq var1021 (cdr var1021)) (go lab1020)) (setq r (cons (car q) r)) (setq k (plus k 1)))) (setq var1023 (cdr var1023)) (go lab1022)) (setq newrefs (cons uses newrefs)) (setq newrefs ( cons (s!:vecof (reversip r)) newrefs)) (setq w (cons newrefs w)))) (setq var1025 (cdr var1025)) (go lab1024)) (return (sort w (function s!:literal_order))))) (fluid (quote (s!:into_c))) (de s!:endprocedure (name env checksum) (prog (pc labelvals w vec) ( s!:outexit) (cond (s!:into_c (return (cons s!:current_procedure env)))) ( s!:resolve_literals env checksum) (setq s!:current_procedure ( s!:tidy_flowgraph s!:current_procedure)) (cond ((and (not !*notailcall) (not s!:has_closure)) (setq s!:current_procedure (s!:try_tailcall s!:current_procedure)))) (setq s!:current_procedure (s!:tidy_exits s!:current_procedure)) (setq labelvals (s!:resolve_labels)) (setq pc (car labelvals)) (setq labelvals (cdr labelvals)) (setq vec (make!-bps pc)) (setq pc 0) (cond ((or !*plap !*pgwd) (progn (terpri) (ttab 23) (princ "+++ ") ( prin name) (princ " +++") (terpri)))) (prog (var1027) (setq var1027 s!:current_procedure) lab1026 (cond ((null var1027) (return nil))) (prog (b) (setq b (car var1027)) (progn (cond ((and (car b) (flagp (car b) (quote used_label)) (or !*plap !*pgwd)) (progn (ttab 20) (prin (car b)) (princ ":") (terpri)))) (setq pc (s!:plant_basic_block vec pc (reverse (cdddr b)))) (setq b (cadr b)) (cond ((and b (neq (car b) (quote ICASE)) (cdr b) (cddr b)) ( setq b (list (car b) (cadr b))))) (setq pc (s!:plant_exit_code vec pc b labelvals)))) (setq var1027 (cdr var1027)) (go lab1026)) (cond (!*pwrds ( progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin name) (princ " compiled, ") (princ pc) (princ " + ") (princ (cdar env)) (princ " bytes") ( terpri)))) (setq env (caar env)) (cond ((null env) (setq w nil)) (t (progn ( setq w (mkvect (cdar env))) (prog nil lab1028 (cond ((null env) (return nil)) ) (progn (putv w (cdar env) (caar env)) (setq env (cdr env))) (go lab1028)))) ) (return (cons vec w)))) (de s!:add_pending (lab pend blocks) (prog (w) (cond ((not (atom lab)) ( return (cons (list (gensym) lab 0) pend)))) (setq w (atsoc lab pend)) (cond ( w (return (cons w (deleq w pend)))) (t (return (cons (atsoc lab blocks) pend) ))))) (de s!:invent_exit (x blocks) (prog (w) (setq w blocks) scan (cond ((null w) (go not_found)) (t (cond ((and (eqcar (cadar w) x) (equal (caddar w) 0)) ( return (cons (caar w) blocks))) (t (setq w (cdr w)))))) (go scan) not_found ( setq w (gensym)) (return (cons w (cons (list w (list x) 0) blocks))))) (de s!:destination_label (lab blocks) (prog (n w x) (setq w (atsoc lab blocks )) (cond ((s!:is_lose_and_exit w blocks) (return (quote (EXIT))))) (setq x ( cadr w)) (setq n (caddr w)) (setq w (cdddr w)) (cond ((neq n 0) (return lab)) ) (cond ((or (null x) (null (cdr x))) (return x)) (t (cond ((equal (cadr x) lab) (return lab)) (t (cond ((null (cddr x)) (return (s!:destination_label ( cadr x) blocks))) (t (return lab))))))))) (de s!:remlose (b) (prog (w) (setq w b) (prog nil lab1029 (cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1029)) (cond ( (null w) (return (cons 0 b)))) (cond ((and (numberp (car w)) (eqcar (cdr w) ( quote LOSES))) (setq w (cons 2 (cddr w)))) (t (cond ((or (equal (car w) ( quote LOSE)) (equal (car w) (quote LOSE2)) (equal (car w) (quote LOSE3))) ( setq w (cons 1 (cdr w)))) (t (return (cons 0 b)))))) (setq b (s!:remlose (cdr w))) (return (cons (plus (car w) (car b)) (cdr b))))) (put (quote CALL0_0) (quote s!:shortcall) (quote (0 . 0))) (put (quote CALL0_1) (quote s!:shortcall) (quote (0 . 1))) (put (quote CALL0_2) (quote s!:shortcall) (quote (0 . 2))) (put (quote CALL0_3) (quote s!:shortcall) (quote (0 . 3))) (put (quote CALL1_0) (quote s!:shortcall) (quote (1 . 0))) (put (quote CALL1_1) (quote s!:shortcall) (quote (1 . 1))) (put (quote CALL1_2) (quote s!:shortcall) (quote (1 . 2))) (put (quote CALL1_3) (quote s!:shortcall) (quote (1 . 3))) (put (quote CALL1_4) (quote s!:shortcall) (quote (1 . 4))) (put (quote CALL1_5) (quote s!:shortcall) (quote (1 . 5))) (put (quote CALL2_0) (quote s!:shortcall) (quote (2 . 0))) (put (quote CALL2_1) (quote s!:shortcall) (quote (2 . 1))) (put (quote CALL2_2) (quote s!:shortcall) (quote (2 . 2))) (put (quote CALL2_3) (quote s!:shortcall) (quote (2 . 3))) (put (quote CALL2_4) (quote s!:shortcall) (quote (2 . 4))) (de s!:remcall (b) (prog (w p q r s) (prog nil lab1030 (cond ((null (and b ( not (atom (car b))))) (return nil))) (progn (setq p (car b)) (setq b (cdr b)) ) (go lab1030)) (cond ((null b) (return nil)) (t (cond ((numberp (car b)) ( progn (setq r (car b)) (setq s 2) (setq b (cdr b)) (cond ((null b) (return nil)) (t (cond ((numberp (car b)) (progn (setq q r) (setq r (car b)) (setq s 3) (setq b (cdr b)) (cond ((and b (numberp (setq w (car b))) (eqcar (cdr b) ( quote BIGCALL)) (equal (truncate w 16) 4)) (progn (setq r (plus (times 256 ( logand w 15)) r)) (setq s 4) (setq b (cdr b)))) (t (cond ((eqcar b (quote BIGCALL)) (progn (setq w (truncate r 16)) (setq r (plus (times 256 (logand r 15)) q)) (setq q w) (cond ((equal q 5) (progn (setq q 2) (setq s (difference s 1)) (setq b (cons (quote BIGCALL) (cons (quote SWOP) (cdr b))))))) (cond (( greaterp q 4) (return nil))))) (t (cond ((not (eqcar b (quote CALLN))) ( return nil))))))))) (t (cond ((equal (car b) (quote CALL0)) (setq q 0)) (t ( cond ((equal (car b) (quote CALL1)) (setq q 1)) (t (cond ((equal (car b) ( quote CALL2)) (setq q 2)) (t (cond ((equal (car b) (quote CALL2R)) (progn ( setq q 2) (setq s (difference s 1)) (setq b (cons (quote CALL2) (cons (quote SWOP) (cdr b)))))) (t (cond ((equal (car b) (quote CALL3)) (setq q 3)) (t ( return nil))))))))))))))) (setq b (cdr b)))) (t (cond ((setq q (get (car b) ( quote s!:shortcall))) (progn (setq r (cdr q)) (setq q (car q)) (setq s 1) ( setq b (cdr b)))) (t (return nil))))))) (return (cons p (cons q (cons r (cons s b))))))) (de s!:is_lose_and_exit (b blocks) (prog (lab exit) (setq lab (car b)) (setq exit (cadr b)) (setq b (cdddr b)) (cond ((null exit) (return nil))) (setq b ( s!:remlose b)) (setq b (cdr b)) (prog nil lab1031 (cond ((null (and b (not ( atom (car b))))) (return nil))) (setq b (cdr b)) (go lab1031)) (cond (b ( return nil)) (t (cond ((equal (car exit) (quote EXIT)) (return t)) (t (cond ( (equal (car exit) (quote JUMP)) (progn (cond ((equal (cadr exit) lab) nil) (t (return (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)))))) (t ( return nil))))))))) (de s!:try_tail_1 (b blocks) (prog (exit size body w w0 w1 w2 op) (setq exit (cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car exit) ( quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn (cond (( not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b))))) ( t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq body ( s!:remlose body)) (setq size (difference size (car body))) (setq body (cdr body)) (setq w (s!:remcall body)) (cond ((null w) (return b))) (setq w0 (cadr w)) (setq w1 (caddr w)) (setq body (cddddr w)) (cond ((and (leq w0 7) (leq w1 31)) (progn (setq body (cons (quote JCALL) body)) (setq body (cons (plus ( times 32 w0) w1) body)) (setq size (difference size 1)))) (t (cond ((lessp w1 256) (setq body (cons w0 (cons w1 (cons (quote JCALLN) body))))) (t (progn ( setq body (cons (quote BIGCALL) body)) (setq w2 (logand w1 255)) (setq w1 ( truncate w1 256)) (cond ((lessp w0 4) (setq body (cons w2 (cons (plus w1 ( times 16 w0) 128) body)))) (t (progn (setq body (cons w0 (cons w2 (cons (plus w1 (plus (times 16 4) 128)) body)))) (setq size (plus size 1)))))))))) (cond ((car w) (setq body (cons (append (car w) (list (quote TAIL))) body)))) ( rplaca (cdr b) nil) (rplaca (cddr b) (plus (difference size (cadddr w)) 3)) ( rplacd (cddr b) body) (return b))) (de s!:try_tailcall (b) (prog (var1033 var1034) (setq var1033 b) lab1032 ( cond ((null var1033) (return (reversip var1034)))) (prog (v) (setq v (car var1033)) (setq var1034 (cons (s!:try_tail_1 v b) var1034))) (setq var1033 ( cdr var1033)) (go lab1032))) (de s!:tidy_exits_1 (b blocks) (prog (exit size body comm w w0 w1 w2 op) ( setq exit (cadr b)) (cond ((null exit) (return b)) (t (cond ((not (equal (car exit) (quote EXIT))) (progn (cond ((equal (car exit) (quote JUMP)) (progn ( cond ((not (s!:is_lose_and_exit (atsoc (cadr exit) blocks) blocks)) (return b ))))) (t (return b)))))))) (setq size (caddr b)) (setq body (cdddr b)) (setq body (s!:remlose body)) (setq size (difference size (car body))) (setq body ( cdr body)) (prog nil lab1035 (cond ((null (and body (not (atom (car body))))) (return nil))) (progn (setq comm (car body)) (setq body (cdr body))) (go lab1035)) (cond ((eqcar body (quote VNIL)) (setq w (quote NILEXIT))) (t (cond ((eqcar body (quote LOADLOC0)) (setq w (quote LOC0EXIT))) (t (cond ((eqcar body (quote LOADLOC1)) (setq w (quote LOC1EXIT))) (t (cond ((eqcar body ( quote LOADLOC2)) (setq w (quote LOC2EXIT))) (t (setq w nil))))))))) (cond (w (progn (rplaca (cdr b) (list w)) (setq body (cdr body)) (setq size ( difference size 1)))) (t (cond (comm (setq body (cons comm body)))))) (rplaca (cddr b) size) (rplacd (cddr b) body) (return b))) (de s!:tidy_exits (b) (prog (var1037 var1038) (setq var1037 b) lab1036 (cond ((null var1037) (return (reversip var1038)))) (prog (v) (setq v (car var1037) ) (setq var1038 (cons (s!:tidy_exits_1 v b) var1038))) (setq var1037 (cdr var1037)) (go lab1036))) (de s!:tidy_flowgraph (b) (prog (r pending) (setq b (reverse b)) (setq pending (list (car b))) (prog nil lab1040 (cond ((null pending) (return nil)) ) (prog (c x l1 l2 done1 done2) (setq c (car pending)) (setq pending (cdr pending)) (flag (list (car c)) (quote coded)) (setq x (cadr c)) (cond ((or ( null x) (null (cdr x))) (setq r (cons c r))) (t (cond ((equal (car x) (quote ICASE)) (progn (rplacd x (reversip (cdr x))) (prog (ll) (setq ll (cdr x)) lab1039 (cond ((null ll) (return nil))) (progn (setq l1 (s!:destination_label (car ll) b)) (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) b)) (setq b (cdr l1)) (setq l1 (cadr l1))))) (rplaca ll l1) (setq done1 ( flagp l1 (quote coded))) (flag (list l1) (quote used_label)) (cond ((not done1) (setq pending (s!:add_pending l1 pending b))))) (setq ll (cdr ll)) (go lab1039)) (rplacd x (reversip (cdr x))) (setq r (cons c r)))) (t (cond (( null (cddr x)) (progn (setq l1 (s!:destination_label (cadr x) b)) (cond ((not (atom l1)) (setq c (cons (car c) (cons l1 (cddr c))))) (t (cond ((flagp l1 ( quote coded)) (progn (flag (list l1) (quote used_label)) (setq c (cons (car c ) (cons (list (car x) l1) (cddr c)))))) (t (progn (setq c (cons (car c) (cons nil (cddr c)))) (setq pending (s!:add_pending l1 pending b))))))) (setq r ( cons c r)))) (t (progn (setq l1 (s!:destination_label (cadr x) b)) (setq l2 ( s!:destination_label (caddr x) b)) (setq done1 (and (atom l1) (flagp l1 ( quote coded)))) (setq done2 (and (atom l2) (flagp l2 (quote coded)))) (cond ( done1 (progn (cond (done2 (progn (flag (list l1) (quote used_label)) (rplaca (cdadr c) l1) (setq pending (cons (list (gensym) (list (quote JUMP) l2) 0) pending)))) (t (progn (flag (list l1) (quote used_label)) (rplaca (cdadr c) l1) (setq pending (s!:add_pending l2 pending b))))))) (t (progn (cond (done2 (progn (flag (list l2) (quote used_label)) (rplaca (cadr c) (s!:negate_jump ( car x))) (rplaca (cdadr c) l2) (setq pending (s!:add_pending l1 pending b)))) (t (progn (cond ((not (atom l1)) (progn (setq l1 (s!:invent_exit (car l1) b) ) (setq b (cdr l1)) (setq l1 (car l1))))) (flag (list l1) (quote used_label)) (rplaca (cdadr c) l1) (cond ((not (flagp l1 (quote coded))) (setq pending ( s!:add_pending l1 pending b)))) (setq pending (s!:add_pending l2 pending b))) ))))) (setq r (cons c r)))))))))) (go lab1040)) (return (reverse r)))) (deflist (quote ((JUMPNIL JUMPT) (JUMPT JUMPNIL) (JUMPATOM JUMPNATOM) ( JUMPNATOM JUMPATOM) (JUMPEQ JUMPNE) (JUMPNE JUMPEQ) (JUMPEQUAL JUMPNEQUAL) ( JUMPNEQUAL JUMPEQUAL) (JUMPL0NIL JUMPL0T) (JUMPL0T JUMPL0NIL) (JUMPL1NIL JUMPL1T) (JUMPL1T JUMPL1NIL) (JUMPL2NIL JUMPL2T) (JUMPL2T JUMPL2NIL) ( JUMPL3NIL JUMPL3T) (JUMPL3T JUMPL3NIL) (JUMPL4NIL JUMPL4T) (JUMPL4T JUMPL4NIL ) (JUMPL0ATOM JUMPL0NATOM) (JUMPL0NATOM JUMPL0ATOM) (JUMPL1ATOM JUMPL1NATOM) (JUMPL1NATOM JUMPL1ATOM) (JUMPL2ATOM JUMPL2NATOM) (JUMPL2NATOM JUMPL2ATOM) ( JUMPL3ATOM JUMPL3NATOM) (JUMPL3NATOM JUMPL3ATOM) (JUMPST0NIL JUMPST0T) ( JUMPST0T JUMPST0NIL) (JUMPST1NIL JUMPST1T) (JUMPST1T JUMPST1NIL) (JUMPST2NIL JUMPST2T) (JUMPST2T JUMPST2NIL) (JUMPFREE1NIL JUMPFREE1T) (JUMPFREE1T JUMPFREE1NIL) (JUMPFREE2NIL JUMPFREE2T) (JUMPFREE2T JUMPFREE2NIL) ( JUMPFREE3NIL JUMPFREE3T) (JUMPFREE3T JUMPFREE3NIL) (JUMPFREE4NIL JUMPFREE4T) (JUMPFREE4T JUMPFREE4NIL) (JUMPFREENIL JUMPFREET) (JUMPFREET JUMPFREENIL) ( JUMPLIT1EQ JUMPLIT1NE) (JUMPLIT1NE JUMPLIT1EQ) (JUMPLIT2EQ JUMPLIT2NE) ( JUMPLIT2NE JUMPLIT2EQ) (JUMPLIT3EQ JUMPLIT3NE) (JUMPLIT3NE JUMPLIT3EQ) ( JUMPLIT4EQ JUMPLIT4NE) (JUMPLIT4NE JUMPLIT4EQ) (JUMPLITEQ JUMPLITNE) ( JUMPLITNE JUMPLITEQ) (JUMPLITEQ!* JUMPLITNE!*) (JUMPLITNE!* JUMPLITEQ!*) ( JUMPB1NIL JUMPB1T) (JUMPB1T JUMPB1NIL) (JUMPB2NIL JUMPB2T) (JUMPB2T JUMPB2NIL ) (JUMPFLAGP JUMPNFLAGP) (JUMPNFLAGP JUMPFLAGP) (JUMPEQCAR JUMPNEQCAR) ( JUMPNEQCAR JUMPEQCAR))) (quote negjump)) (de s!:negate_jump (x) (cond ((atom x) (get x (quote negjump))) (t (rplaca x (get (car x) (quote negjump)))))) (de s!:resolve_labels nil (prog (w labelvals converged pc x) (prog nil lab1043 (progn (setq converged t) (setq pc 0) (prog (var1042) (setq var1042 s!:current_procedure) lab1041 (cond ((null var1042) (return nil))) (prog (b) (setq b (car var1042)) (progn (setq w (assoc!*!* (car b) labelvals)) (cond (( null w) (progn (setq converged nil) (setq w (cons (car b) pc)) (setq labelvals (cons w labelvals)))) (t (cond ((neq (cdr w) pc) (progn (rplacd w pc) (setq converged nil)))))) (setq pc (plus pc (caddr b))) (setq x (cadr b)) (cond ((null x) nil) (t (cond ((null (cdr x)) (setq pc (plus pc 1))) (t ( cond ((equal (car x) (quote ICASE)) (setq pc (plus pc (times 2 (length x))))) (t (progn (setq w (assoc!*!* (cadr x) labelvals)) (cond ((null w) (progn ( setq w 128) (setq converged nil))) (t (setq w (difference (cdr w) pc)))) ( setq w (s!:expand_jump (car x) w)) (setq pc (plus pc (length w)))))))))))) ( setq var1042 (cdr var1042)) (go lab1041))) (cond ((null converged) (go lab1043)))) (return (cons pc labelvals)))) (de s!:plant_basic_block (vec pc b) (prog (tagged) (prog (var1047) (setq var1047 b) lab1046 (cond ((null var1047) (return nil))) (prog (i) (setq i ( car var1047)) (progn (cond ((atom i) (progn (cond ((symbolp i) (setq i (get i (quote s!:opcode))))) (cond ((and (not tagged) (or !*plap !*pgwd)) (progn ( s!:prinhex4 pc) (princ ":") (ttab 8) (setq tagged t)))) (cond ((or (not (fixp i)) (lessp i 0) (greaterp i 255)) (error "bad byte to put" i))) (bps!-putv vec pc i) (cond ((or !*plap !*pgwd) (progn (s!:prinhex2 i) (princ " ")))) ( setq pc (plus pc 1)))) (t (cond ((or !*plap !*pgwd) (progn (ttab 23) (princ ( car i)) (prog (var1045) (setq var1045 (cdr i)) lab1044 (cond ((null var1045) (return nil))) (prog (w) (setq w (car var1045)) (progn (princ " ") (prin w))) (setq var1045 (cdr var1045)) (go lab1044)) (terpri) (setq tagged nil)))))))) (setq var1047 (cdr var1047)) (go lab1046)) (return pc))) (de s!:plant_bytes (vec pc bytelist doc) (prog nil (cond ((or !*plap !*pgwd) (progn (s!:prinhex4 pc) (princ ":") (ttab 8)))) (prog (var1049) (setq var1049 bytelist) lab1048 (cond ((null var1049) (return nil))) (prog (v) (setq v ( car var1049)) (progn (cond ((symbolp v) (setq v (get v (quote s!:opcode))))) (cond ((or (not (fixp v)) (lessp v 0) (greaterp v 255)) (error "bad byte to put" v))) (bps!-putv vec pc v) (cond ((or !*plap !*pgwd) (progn (cond ((greaterp (posn) 50) (progn (terpri) (ttab 8)))) (s!:prinhex2 v) ( princ " ")))) (setq pc (plus pc 1)))) (setq var1049 (cdr var1049)) (go lab1048)) (cond ((or !*plap !*pgwd) (progn (cond ((greaterp (posn) 23) ( terpri))) (ttab 23) (princ (car doc)) (prog (var1051) (setq var1051 (cdr doc) ) lab1050 (cond ((null var1051) (return nil))) (prog (w) (setq w (car var1051 )) (progn (cond ((greaterp (posn) 65) (progn (terpri) (ttab 23)))) (princ " " ) (prin w))) (setq var1051 (cdr var1051)) (go lab1050)) (terpri)))) (return pc))) (de s!:plant_exit_code (vec pc b labelvals) (prog (w loc low high r) (cond (( null b) (return pc)) (t (cond ((null (cdr b)) (return (s!:plant_bytes vec pc (list (get (car b) (quote s!:opcode))) b))) (t (cond ((equal (car b) (quote ICASE)) (progn (setq loc (plus pc 3)) (prog (var1053) (setq var1053 (cdr b)) lab1052 (cond ((null var1053) (return nil))) (prog (ll) (setq ll (car var1053 )) (progn (setq w (difference (cdr (assoc!*!* ll labelvals)) loc)) (setq loc (plus loc 2)) (cond ((lessp w 0) (progn (setq w (minus w)) (setq low (ilogand w 255)) (setq high (plus 128 (truncate (difference w low) 256))))) (t (progn (setq low (ilogand w 255)) (setq high (truncate (difference w low) 256))))) (setq r (cons low (cons high r))))) (setq var1053 (cdr var1053)) (go lab1052) ) (setq r (cons (get (quote ICASE) (quote s!:opcode)) (cons (length (cddr b)) (reversip r)))) (return (s!:plant_bytes vec pc r b))))))))) (setq w ( difference (cdr (assoc!*!* (cadr b) labelvals)) pc)) (setq w (s!:expand_jump (car b) w)) (return (s!:plant_bytes vec pc w b)))) (deflist (quote ((JUMPL0NIL ((LOADLOC0) JUMPNIL)) (JUMPL0T ((LOADLOC0) JUMPT) ) (JUMPL1NIL ((LOADLOC1) JUMPNIL)) (JUMPL1T ((LOADLOC1) JUMPT)) (JUMPL2NIL (( LOADLOC2) JUMPNIL)) (JUMPL2T ((LOADLOC2) JUMPT)) (JUMPL3NIL ((LOADLOC3) JUMPNIL)) (JUMPL3T ((LOADLOC3) JUMPT)) (JUMPL4NIL ((LOADLOC4) JUMPNIL)) ( JUMPL4T ((LOADLOC4) JUMPT)) (JUMPL0ATOM ((LOADLOC0) JUMPATOM)) (JUMPL0NATOM ( (LOADLOC0) JUMPNATOM)) (JUMPL1ATOM ((LOADLOC1) JUMPATOM)) (JUMPL1NATOM (( LOADLOC1) JUMPNATOM)) (JUMPL2ATOM ((LOADLOC2) JUMPATOM)) (JUMPL2NATOM (( LOADLOC2) JUMPNATOM)) (JUMPL3ATOM ((LOADLOC3) JUMPATOM)) (JUMPL3NATOM (( LOADLOC3) JUMPNATOM)) (JUMPST0NIL ((STORELOC0) JUMPNIL)) (JUMPST0T (( STORELOC0) JUMPT)) (JUMPST1NIL ((STORELOC1) JUMPNIL)) (JUMPST1T ((STORELOC1) JUMPT)) (JUMPST2NIL ((STORELOC2) JUMPNIL)) (JUMPST2T ((STORELOC2) JUMPT)) ( JUMPFREE1NIL ((LOADFREE1) JUMPNIL)) (JUMPFREE1T ((LOADFREE1) JUMPT)) ( JUMPFREE2NIL ((LOADFREE2) JUMPNIL)) (JUMPFREE2T ((LOADFREE2) JUMPT)) ( JUMPFREE3NIL ((LOADFREE3) JUMPNIL)) (JUMPFREE3T ((LOADFREE3) JUMPT)) ( JUMPFREE4NIL ((LOADFREE4) JUMPNIL)) (JUMPFREE4T ((LOADFREE4) JUMPT)) ( JUMPFREENIL ((LOADFREE !*) JUMPNIL)) (JUMPFREET ((LOADFREE !*) JUMPT)) ( JUMPLIT1EQ ((LOADLIT1) JUMPEQ)) (JUMPLIT1NE ((LOADLIT1) JUMPNE)) (JUMPLIT2EQ ((LOADLIT2) JUMPEQ)) (JUMPLIT2NE ((LOADLIT2) JUMPNE)) (JUMPLIT3EQ ((LOADLIT3) JUMPEQ)) (JUMPLIT3NE ((LOADLIT3) JUMPNE)) (JUMPLIT4EQ ((LOADLIT4) JUMPEQ)) ( JUMPLIT4NE ((LOADLIT4) JUMPNE)) (JUMPLITEQ ((LOADLIT !*) JUMPEQ)) (JUMPLITNE ((LOADLIT !*) JUMPNE)) (JUMPLITEQ!* ((LOADLIT !* SWOP) JUMPEQ)) (JUMPLITNE!* ((LOADLIT !* SWOP) JUMPNE)) (JUMPB1NIL ((BUILTIN1 !*) JUMPNIL)) (JUMPB1T (( BUILTIN1 !*) JUMPT)) (JUMPB2NIL ((BUILTIN2 !*) JUMPNIL)) (JUMPB2T ((BUILTIN2 !*) JUMPT)) (JUMPFLAGP ((LOADLIT !* FLAGP) JUMPT)) (JUMPNFLAGP ((LOADLIT !* FLAGP) JUMPNIL)) (JUMPEQCAR ((LOADLIT !* EQCAR) JUMPT)) (JUMPNEQCAR ((LOADLIT !* EQCAR) JUMPNIL)))) (quote s!:expand_jump)) (fluid (quote (s!:backwards_jump s!:longer_jump))) (progn (setq s!:backwards_jump (make!-simple!-string 256)) (setq s!:longer_jump (make!-simple!-string 256)) nil) (prog (var1055) (setq var1055 (quote ((JUMP JUMP_B JUMP_L JUMP_BL) (JUMPNIL JUMPNIL_B JUMPNIL_L JUMPNIL_BL) (JUMPT JUMPT_B JUMPT_L JUMPT_BL) (JUMPATOM JUMPATOM_B JUMPATOM_L JUMPATOM_BL) (JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL) (JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL) (JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL) (JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL) (JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL) (CATCH CATCH_B CATCH_L CATCH_BL)))) lab1054 (cond ((null var1055) (return nil))) (prog (op) (setq op (car var1055 )) (progn (putv!-char s!:backwards_jump (get (car op) (quote s!:opcode)) (get (cadr op) (quote s!:opcode))) (putv!-char s!:backwards_jump (get (caddr op) (quote s!:opcode)) (get (cadddr op) (quote s!:opcode))) (putv!-char s!:longer_jump (get (car op) (quote s!:opcode)) (get (caddr op) (quote s!:opcode))) (putv!-char s!:longer_jump (get (cadr op) (quote s!:opcode)) ( get (cadddr op) (quote s!:opcode))))) (setq var1055 (cdr var1055)) (go lab1054)) (de s!:expand_jump (op offset) (prog (arg low high opcode expanded) (cond (( not (atom op)) (progn (setq arg (cadr op)) (setq op (car op)) (setq offset ( difference offset 1))))) (setq expanded (get op (quote s!:expand_jump))) ( cond ((and expanded (not (and (leq 2 offset) (lessp offset (plus 256 2)) (or (null arg) (lessp arg 256))))) (progn (setq op (cadr expanded)) (setq expanded (car expanded)) (cond (arg (progn (cond ((greaterp arg 2047) (error 0 "function uses too many literals (2048 limit)")) (t (cond ((greaterp arg 255) (prog (high low) (setq low (ilogand arg 255)) (setq high (truncate ( difference arg low) 256)) (setq expanded (cons (quote BIGCALL) (cons (plus ( get (car expanded) (quote s!:longform)) high) (cons low (cddr expanded))))))) (t (setq expanded (subst arg (quote !*) expanded)))))) (setq offset (plus offset 1))))) (setq offset (difference offset (length expanded))) (setq arg nil))) (t (setq expanded nil))) (setq opcode (get op (quote s!:opcode))) ( cond ((null opcode) (error 0 (list op offset "invalid block exit")))) (cond ( (and (lessp (plus (minus 256) 2) offset) (lessp offset (plus 256 2))) (setq offset (difference offset 2))) (t (progn (setq high t) (setq offset ( difference offset 3))))) (cond ((lessp offset 0) (progn (setq opcode ( byte!-getv s!:backwards_jump opcode)) (setq offset (minus offset))))) (cond ( high (progn (setq low (logand offset 255)) (setq high (truncate (difference offset low) 256)))) (t (cond ((greaterp (setq low offset) 255) (error 0 "Bad offset in expand_jump"))))) (cond (arg (return (list opcode arg low))) ( t (cond ((not high) (return (append expanded (list opcode low)))) (t (return (append expanded (list (byte!-getv s!:longer_jump opcode) high low))))))))) (de s!:comval (x env context) (prog (helper) (setq x (s!:improve x)) (cond (( atom x) (return (s!:comatom x env context))) (t (cond ((eqcar (car x) (quote lambda)) (return (s!:comlambda (cadar x) (cddar x) (cdr x) env context))) (t (cond ((eq (car x) s!:current_function) (s!:comcall x env context)) (t (cond ((and (setq helper (get (car x) (quote s!:compilermacro))) (setq helper ( funcall helper x env context))) (return (s!:comval helper env context))) (t ( cond ((setq helper (get (car x) (quote s!:newname))) (return (s!:comval (cons helper (cdr x)) env context))) (t (cond ((setq helper (get (car x) (quote s!:compfn))) (return (funcall helper x env context))) (t (cond ((setq helper (macro!-function (car x))) (return (s!:comval (funcall helper x) env context) )) (t (return (s!:comcall x env context)))))))))))))))))) (de s!:comspecform (x env context) (error 0 (list "special form" x))) (cond ((null (get (quote and) (quote s!:compfn))) (progn (put (quote compiler!-let) (quote s!:compfn) (function s!:comspecform)) (put (quote de) ( quote s!:compfn) (function s!:comspecform)) (put (quote defun) (quote s!:compfn) (function s!:comspecform)) (put (quote eval!-when) (quote s!:compfn) (function s!:comspecform)) (put (quote flet) (quote s!:compfn) ( function s!:comspecform)) (put (quote labels) (quote s!:compfn) (function s!:comspecform)) (put (quote macrolet) (quote s!:compfn) (function s!:comspecform)) (put (quote multiple!-value!-call) (quote s!:compfn) ( function s!:comspecform)) (put (quote multiple!-value!-prog1) (quote s!:compfn) (function s!:comspecform)) (put (quote prog!*) (quote s!:compfn) ( function s!:comspecform)) (put (quote progv) (quote s!:compfn) (function s!:comspecform)) nil))) (de s!:improve (u) (prog (w) (cond ((atom u) (return u)) (t (cond ((setq w ( get (car u) (quote s!:tidy_fn))) (return (funcall w u))) (t (cond ((setq w ( get (car u) (quote s!:newname))) (return (s!:improve (cons w (cdr u))))) (t ( return u))))))))) (de s!:imp_minus (u) (prog (a) (setq a (s!:improve (cadr u))) (return (cond ( (numberp a) (minus a)) (t (cond ((or (eqcar a (quote minus)) (eqcar a (quote iminus))) (cadr a)) (t (cond ((eqcar a (quote difference)) (s!:improve (list (quote difference) (caddr a) (cadr a)))) (t (cond ((eqcar a (quote idifference)) (s!:improve (list (quote idifference) (caddr a) (cadr a)))) (t (list (car u) a)))))))))))) (put (quote minus) (quote s!:tidy_fn) (quote s!:imp_minus)) (put (quote iminus) (quote s!:tidy_fn) (quote s!:imp_minus)) (de s!:imp_times (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( cons (car u) (prog (var1057 var1058) (setq var1057 (cdr u)) lab1056 (cond (( null var1057) (return (reversip var1058)))) (prog (v) (setq v (car var1057)) (setq var1058 (cons (s!:improve v) var1058))) (setq var1057 (cdr var1057)) ( go lab1056)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) )) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a (minus 1)) (s!:imp_minus (list (quote minus) b))) (t (cond ((equal b (minus 1 )) (s!:imp_minus (list (quote minus) a))) (t (list (car u) a b)))))))))))) (put (quote times) (quote s!:tidy_fn) (quote s!:imp_times)) (de s!:imp_itimes (u) (prog (a b) (cond ((not (equal (length u) 3)) (return ( cons (car u) (prog (var1060 var1061) (setq var1060 (cdr u)) lab1059 (cond (( null var1060) (return (reversip var1061)))) (prog (v) (setq v (car var1060)) (setq var1061 (cons (s!:improve v) var1061))) (setq var1060 (cdr var1060)) ( go lab1059)))))) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u) )) (return (cond ((equal a 1) b) (t (cond ((equal b 1) a) (t (cond ((equal a (minus 1)) (s!:imp_minus (list (quote iminus) b))) (t (cond ((equal b (minus 1)) (s!:imp_minus (list (quote iminus) a))) (t (list (car u) a b)))))))))))) (put (quote itimes) (quote s!:tidy_fn) (quote s!:imp_itimes)) (de s!:imp_difference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list (quote minus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) (put (quote difference) (quote s!:tidy_fn) (quote s!:imp_difference)) (de s!:imp_idifference (u) (prog (a b) (setq a (s!:improve (cadr u))) (setq b (s!:improve (caddr u))) (return (cond ((equal a 0) (s!:imp_minus (list ( quote iminus) b))) (t (cond ((equal b 0) a) (t (list (car u) a b)))))))) (put (quote idifference) (quote s!:tidy_fn) (quote s!:imp_idifference)) (de s!:alwayseasy (x) t) (put (quote quote) (quote s!:helpeasy) (function s!:alwayseasy)) (put (quote function) (quote s!:helpeasy) (function s!:alwayseasy)) (de s!:easyifarg (x) (or (null (cdr x)) (and (null (cddr x)) (s!:iseasy (cadr x))))) (put (quote ncons) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote car) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cadar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cddar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caaaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caaadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caadar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caaddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cadaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cadadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote caddar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cadddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdaaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdaadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdadar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdaddr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cddaar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cddadr) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cdddar) (quote s!:helpeasy) (function s!:easyifarg)) (put (quote cddddr) (quote s!:helpeasy) (function s!:easyifarg)) (de s!:easygetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (null !*carcheckflag) (fixp a2) (geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr x)))) (t (return nil))))) (put (quote getv) (quote s!:helpeasy) (function s!:easygetv)) (de s!:easyqgetv (x) (prog (a2) (setq a2 (caddr x)) (cond ((and (fixp a2) ( geq a2 0) (lessp a2 256)) (return (s!:iseasy (cadr x)))) (t (return nil))))) (put (quote qgetv) (quote s!:helpeasy) (function s!:easyqgetv)) (de s!:iseasy (x) (prog (h) (cond ((atom x) (return t))) (cond ((not (atom ( car x))) (return nil))) (cond ((setq h (get (car x) (quote s!:helpeasy))) ( return (funcall h x))) (t (return nil))))) (de s!:instate_local_decs (v d w) (prog (fg) (cond ((fluidp v) (return w))) ( prog (var1063) (setq var1063 d) lab1062 (cond ((null var1063) (return nil))) (prog (z) (setq z (car var1063)) (cond ((and (eqcar z (quote special)) (memq v (cdr z))) (setq fg t)))) (setq var1063 (cdr var1063)) (go lab1062)) (cond ( fg (progn (make!-special v) (setq w (cons v w))))) (return w))) (de s!:residual_local_decs (d w) (prog nil (prog (var1067) (setq var1067 d) lab1066 (cond ((null var1067) (return nil))) (prog (z) (setq z (car var1067)) (cond ((eqcar z (quote special)) (prog (var1065) (setq var1065 (cdr z)) lab1064 (cond ((null var1065) (return nil))) (prog (v) (setq v (car var1065)) (cond ((and (not (fluidp v)) (not (globalp v))) (progn (make!-special v) ( setq w (cons v w)))))) (setq var1065 (cdr var1065)) (go lab1064))))) (setq var1067 (cdr var1067)) (go lab1066)) (return w))) (de s!:cancel_local_decs (w) (unfluid w)) (de s!:find_local_decs (body isprog) (prog (w local_decs) (cond ((and (not isprog) body (null (cdr body)) (eqcar (car body) (quote progn))) (setq body ( cdar body)))) (prog nil lab1068 (cond ((null (and body (or (eqcar (car body) (quote declare)) (stringp (car body))))) (return nil))) (progn (cond (( stringp (car body)) (setq w (cons (car body) w))) (t (setq local_decs (append local_decs (cdar body))))) (setq body (cdr body))) (go lab1068)) (prog nil lab1069 (cond ((null w) (return nil))) (progn (setq body (cons (car w) body)) (setq w (cdr w))) (go lab1069)) (return (cons local_decs body)))) (de s!:comlambda (bvl body args env context) (prog (s nbvl fluids fl1 w local_decs) (setq nbvl (setq s (cdr env))) (setq body (s!:find_local_decs body nil)) (setq local_decs (car body)) (setq body (cdr body)) (cond ((atom body) (setq body nil)) (t (cond ((atom (cdr body)) (setq body (car body))) (t (setq body (cons (quote progn) body)))))) (setq w nil) (prog (var1071) (setq var1071 bvl) lab1070 (cond ((null var1071) (return nil))) (prog (v) (setq v (car var1071)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1071 (cdr var1071)) (go lab1070)) (prog (var1073) (setq var1073 bvl) lab1072 ( cond ((null var1073) (return nil))) (prog (v) (setq v (car var1073)) (progn ( cond ((or (fluidp v) (globalp v)) (prog (g) (setq g (gensym)) (setq nbvl ( cons g nbvl)) (setq fl1 (cons v fl1)) (setq fluids (cons (cons v g) fluids))) ) (t (setq nbvl (cons v nbvl)))) (cond ((equal (car args) nil) (s!:outstack 1 )) (t (progn (s!:comval (car args) env 1) (s!:outopcode0 (quote PUSH) (quote (PUSH)))))) (rplacd env (cons 0 (cdr env))) (setq args (cdr args)))) (setq var1073 (cdr var1073)) (go lab1072)) (rplacd env nbvl) (cond (fluids (progn ( setq fl1 (s!:vecof fl1)) (s!:outopcode1lit (quote FREEBIND) fl1 env) (prog ( var1075) (setq var1075 (cons nil fluids)) lab1074 (cond ((null var1075) ( return nil))) (prog (v) (setq v (car var1075)) (rplacd env (cons 0 (cdr env)) )) (setq var1075 (cdr var1075)) (go lab1074)) (rplacd env (cons (plus 2 ( length fluids)) (cdr env))) (prog (var1077) (setq var1077 fluids) lab1076 ( cond ((null var1077) (return nil))) (prog (v) (setq v (car var1077)) ( s!:comval (list (quote setq) (car v) (cdr v)) env 2)) (setq var1077 (cdr var1077)) (go lab1076))))) (setq w (s!:residual_local_decs local_decs w)) ( s!:comval body env 1) (s!:cancel_local_decs w) (cond (fluids (s!:outopcode0 ( quote FREERSTR) (quote (FREERSTR))))) (s!:outlose (length bvl)) (rplacd env s ))) (de s!:loadliteral (x env) (cond ((member!*!* (list (quote quote) x) s!:a_reg_values) nil) (t (progn (cond ((equal x nil) (s!:outopcode0 (quote VNIL) (quote (loadlit nil)))) (t (s!:outopcode1lit (quote LOADLIT) x env))) ( setq s!:a_reg_values (list (list (quote quote) x))))))) (de s!:comquote (x env context) (cond ((leq context 1) (s!:loadliteral (cadr x) env)))) (put (quote quote) (quote s!:compfn) (function s!:comquote)) (fluid (quote (s!:current_exitlab s!:current_proglabels s!:local_macros))) (de s!:comfunction (x env context) (cond ((leq context 1) (progn (setq x ( cadr x)) (cond ((eqcar x (quote lambda)) (prog (g w s!:used_lexicals) (setq s!:has_closure t) (setq g (hashtagged!-name (quote lambda) (cdr x))) (setq w (s!:compile1 g (cadr x) (cddr x) (cons (list (cdr env) s!:current_exitlab s!:current_proglabels s!:local_macros) s!:lexical_env))) (cond ( s!:used_lexicals (setq w (s!:compile1 g (cons (gensym) (cadr x)) (cddr x) ( cons (list (cdr env) s!:current_exitlab s!:current_proglabels s!:local_macros ) s!:lexical_env))))) (setq s!:other_defs (append w s!:other_defs)) ( s!:loadliteral g env) (setq w (length (cdr env))) (cond (s!:used_lexicals ( progn (setq s!:has_closure t) (cond ((greaterp w 4095) (error 0 "stack frame > 4095")) (t (cond ((greaterp w 255) (s!:outopcode2 (quote BIGSTACK) (plus 128 (truncate w 256)) (logand w 255) (list (quote CLOSURE) w) )) (t (s!:outopcode1 (quote CLOSURE) w x)))))))))) (t (s!:loadliteral x env)) ))))) (put (quote function) (quote s!:compfn) (function s!:comfunction)) (de s!:should_be_fluid (x) (cond ((not (or (fluidp x) (globalp x))) (progn ( cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin x) (princ " declared fluid") (terpri)))) (fluid (list x)) nil)))) (de s!:find_lexical (x lex n) (prog (p) (cond ((null lex) (return nil))) ( setq p (memq x (caar lex))) (cond (p (progn (cond ((not (memq x s!:used_lexicals)) (setq s!:used_lexicals (cons x s!:used_lexicals)))) ( return (list n (length p))))) (t (return (s!:find_lexical x (cdr lex) (plus n 1))))))) (global (quote (s!:loadlocs))) (setq s!:loadlocs (s!:vecof (quote (LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11)))) (de s!:comatom (x env context) (prog (n w) (cond ((greaterp context 1) ( return nil)) (t (cond ((or (null x) (not (symbolp x))) (return ( s!:loadliteral x env)))))) (setq n 0) (setq w (cdr env)) (prog nil lab1078 ( cond ((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n (add1 n) ) (setq w (cdr w))) (go lab1078)) (cond (w (progn (setq w (cons (quote loc) w )) (cond ((member!*!* w s!:a_reg_values) (return nil)) (t (progn (cond (( lessp n 12) (s!:outopcode0 (getv s!:loadlocs n) (list (quote LOADLOC) x))) (t (cond ((greaterp n 4095) (error 0 "stack frame > 4095")) (t (cond ((greaterp n 255) (s!:outopcode2 (quote BIGSTACK) (truncate n 256) (logand n 255) (list (quote LOADLOC) x))) (t (s!:outopcode1 (quote LOADLOC) n x))))))) (setq s!:a_reg_values (list w)) (return nil))))))) (cond ((setq w (s!:find_lexical x s!:lexical_env 0)) (progn (cond ((member!*!* (cons (quote lex) w) s!:a_reg_values) (return nil))) (s!:outlexref (quote LOADLEX) (length (cdr env)) (car w) (cadr w) x) (setq s!:a_reg_values (list (cons (quote lex) w))) (return nil)))) (s!:should_be_fluid x) (cond ((flagp x (quote constant!?)) ( return (s!:loadliteral (eval x) env)))) (setq w (cons (quote free) x)) (cond ((member!*!* w s!:a_reg_values) (return nil))) (s!:outopcode1lit (quote LOADFREE) x env) (setq s!:a_reg_values (list w)))) (flag (quote (t !$EOL!$ !$EOF!$)) (quote constant!?)) (de s!:islocal (x env) (prog (n w) (cond ((or (null x) (not (symbolp x)) (eq x t)) (return 99999))) (setq n 0) (setq w (cdr env)) (prog nil lab1079 (cond ((null (and w (not (eqcar w x)))) (return nil))) (progn (setq n (add1 n)) ( setq w (cdr w))) (go lab1079)) (cond (w (return n)) (t (return 99999))))) (de s!:load2 (a b env) (progn (cond ((s!:iseasy b) (prog (wa wb w) (setq wa ( s!:islocal a env)) (setq wb (s!:islocal b env)) (cond ((and (lessp wa 4) ( lessp wb 4)) (progn (cond ((and (equal wa 0) (equal wb 1)) (setq w (quote LOC0LOC1))) (t (cond ((and (equal wa 1) (equal wb 2)) (setq w (quote LOC1LOC2 ))) (t (cond ((and (equal wa 2) (equal wb 3)) (setq w (quote LOC2LOC3))) (t ( cond ((and (equal wa 1) (equal wb 0)) (setq w (quote LOC1LOC0))) (t (cond (( and (equal wa 2) (equal wb 1)) (setq w (quote LOC2LOC1))) (t (cond ((and ( equal wa 3) (equal wb 2)) (setq w (quote LOC3LOC2)))))))))))))) (cond (w ( progn (s!:outopcode0 w (list (quote LOCLOC) a b)) (return nil))))))) ( s!:comval a env 1) (setq s!:a_reg_values nil) (s!:comval b env 1) (return nil ))) (t (cond (!*ord (progn (s!:comval a env 1) (s!:outopcode0 (quote PUSH) ( quote (PUSH))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values nil) ( s!:comval b env 1) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd env ( cddr env)) t)) (t (cond ((s!:iseasy a) (progn (s!:comval b env 1) (setq s!:a_reg_values nil) (s!:comval a env 1) t)) (t (progn (s!:comval b env 1) ( s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) ( setq s!:a_reg_values nil) (s!:comval a env 1) (s!:outopcode0 (quote POP) ( quote (POP))) (rplacd env (cddr env)) nil))))))))) (global (quote (s!:carlocs s!:cdrlocs s!:caarlocs))) (setq s!:carlocs (s!:vecof (quote (CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11)))) (setq s!:cdrlocs (s!:vecof (quote (CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5)))) (setq s!:caarlocs (s!:vecof (quote (CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3)))) (flag (quote (plus2 times2 eq equal)) (quote s!:symmetric)) (flag (quote (car cdr caar cadr cdar cddr ncons add1 sub1 numberp length)) ( quote s!:onearg)) (flag (quote (cons xcons list2 get flagp plus2 difference times2 greaterp lessp apply1 eq equal getv qgetv eqcar)) (quote s!:twoarg)) (flag (quote (apply2 list2!* list3 acons)) (quote s!:threearg)) (de s!:comcall (x env context) (prog (fn args nargs op s w1 w2 w3 sw) (setq fn (car x)) (cond ((not (symbolp fn)) (error 0 "non-symbol used in function position"))) (setq args (prog (var1081 var1082) (setq var1081 (cdr x)) lab1080 (cond ((null var1081) (return (reversip var1082)))) (prog (v) (setq v (car var1081)) (setq var1082 (cons (s!:improve v) var1082))) (setq var1081 (cdr var1081)) (go lab1080))) (setq nargs (length args)) (cond ((and (greaterp nargs 15) !*pwrds) (progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin fn) (princ " called with ") (prin nargs) ( princ " from function ") (prin s!:current_function) (terpri)))) (setq s (cdr env)) (cond ((equal nargs 0) (cond ((setq w2 (get fn (quote s!:builtin0))) ( s!:outopcode1 (quote BUILTIN0) w2 fn)) (t (s!:outopcode1lit (quote CALL0) fn env)))) (t (cond ((equal nargs 1) (progn (cond ((and (equal fn (quote car)) ( lessp (setq w2 (s!:islocal (car args) env)) 12)) (s!:outopcode0 (getv s!:carlocs w2) (list (quote carloc) (car args)))) (t (cond ((and (equal fn ( quote cdr)) (lessp (setq w2 (s!:islocal (car args) env)) 6)) (s!:outopcode0 ( getv s!:cdrlocs w2) (list (quote cdrloc) (car args)))) (t (cond ((and (equal fn (quote caar)) (lessp (setq w2 (s!:islocal (car args) env)) 4)) ( s!:outopcode0 (getv s!:caarlocs w2) (list (quote caarloc) (car args)))) (t ( progn (s!:comval (car args) env 1) (cond ((flagp fn (quote s!:onearg)) ( s!:outopcode0 fn (list fn))) (t (cond ((setq w2 (get fn (quote s!:builtin1))) (s!:outopcode1 (quote BUILTIN1) w2 fn)) (t (s!:outopcode1lit (quote CALL1) fn env)))))))))))))) (t (cond ((equal nargs 2) (progn (setq sw (s!:load2 (car args) (cadr args) env)) (cond ((flagp fn (quote s!:symmetric)) (setq sw nil) )) (cond ((flagp fn (quote s!:twoarg)) (progn (cond (sw (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (s!:outopcode0 fn (list fn)))) (t (progn (setq w3 ( get fn (quote s!:builtin2))) (cond (sw (progn (cond (w3 (s!:outopcode1 (quote BUILTIN2R) w3 fn)) (t (s!:outopcode1lit (quote CALL2R) fn env))))) (t (cond (w3 (s!:outopcode1 (quote BUILTIN2) w3 fn)) (t (s!:outopcode1lit (quote CALL2 ) fn env)))))))))) (t (cond ((equal nargs 3) (progn (cond ((equal (car args) nil) (s!:outstack 1)) (t (progn (s!:comval (car args) env 1) (s!:outopcode0 ( quote PUSH) (quote (PUSHA3)))))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values nil) (cond ((s!:load2 (cadr args) (caddr args) env) ( s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond ((flagp fn (quote s!:threearg)) (s!:outopcode0 (cond ((equal fn (quote list2!*)) (quote list2star)) (t fn)) (list fn))) (t (cond ((setq w2 (get fn (quote s!:builtin3 ))) (s!:outopcode1 (quote BUILTIN3) w2 fn)) (t (s!:outopcode1lit (quote CALL3 ) fn env))))) (rplacd env (cddr env)))) (t (prog (largs) (setq largs (reverse args)) (prog (var1084) (setq var1084 (reverse (cddr largs))) lab1083 (cond ( (null var1084) (return nil))) (prog (a) (setq a (car var1084)) (progn (cond ( (null a) (s!:outstack 1)) (t (progn (s!:comval a env 1) (cond ((equal nargs 4 ) (s!:outopcode0 (quote PUSH) (quote (PUSHA4)))) (t (s!:outopcode0 (quote PUSH) (quote (PUSHARG)))))))) (rplacd env (cons 0 (cdr env))) (setq s!:a_reg_values nil))) (setq var1084 (cdr var1084)) (go lab1083)) (cond (( s!:load2 (cadr largs) (car largs) env) (s!:outopcode0 (quote SWOP) (quote ( SWOP))))) (cond ((and (equal fn (quote apply3)) (equal nargs 4)) ( s!:outopcode0 (quote APPLY3) (quote (APPLY3)))) (t (cond ((greaterp nargs 255 ) (error 0 "Over 255 args in a function call")) (t (s!:outopcode2lit (quote CALLN) fn nargs (list nargs fn) env))))) (rplacd env s)))))))))))) (de s!:ad_name (l) (cond ((equal (car l) (quote a)) (cond ((equal (cadr l) ( quote a)) (quote caar)) (t (quote cadr)))) (t (cond ((equal (cadr l) (quote a )) (quote cdar)) (t (quote cddr)))))) (de s!:comcarcdr3 (x env context) (prog (name outer c1 c2) (setq name (cdr ( explode2 (car x)))) (setq x (list (s!:ad_name name) (list (cond ((equal ( caddr name) (quote a)) (quote car)) (t (quote cdr))) (cadr x)))) (return ( s!:comval x env context)))) (put (quote caaar) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote caadr) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote cadar) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote caddr) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote cdaar) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote cdadr) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote cddar) (quote s!:compfn) (function s!:comcarcdr3)) (put (quote cdddr) (quote s!:compfn) (function s!:comcarcdr3)) (de s!:comcarcdr4 (x env context) (prog (name outer c1 c2) (setq name (cdr ( explode2 (car x)))) (setq x (list (s!:ad_name name) (list (s!:ad_name (cddr name)) (cadr x)))) (return (s!:comval x env context)))) (put (quote caaaar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote caaadr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote caadar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote caaddr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cadaar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cadadr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote caddar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cadddr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cdaaar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cdaadr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cdadar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cdaddr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cddaar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cddadr) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cdddar) (quote s!:compfn) (function s!:comcarcdr4)) (put (quote cddddr) (quote s!:compfn) (function s!:comcarcdr4)) (de s!:comgetv (x env context) (cond (!*carcheckflag (s!:comcall x env context)) (t (s!:comval (cons (quote qgetv) (cdr x)) env context)))) (put (quote getv) (quote s!:compfn) (function s!:comgetv)) (de s!:comqgetv (x env context) (cond ((and (fixp (caddr x)) (geq (caddr x) 0 ) (lessp (caddr x) 256)) (progn (s!:comval (cadr x) env 1) (s!:outopcode1 ( quote QGETVN) (caddr x) (caddr x)))) (t (s!:comcall x env context)))) (put (quote qgetv) (quote s!:compfn) (function s!:comqgetv)) (de s!:comget (x env context) (prog (a b c w) (setq a (cadr x)) (setq b ( caddr x)) (setq c (cdddr x)) (cond ((eqcar b (quote quote)) (progn (setq b ( cadr b)) (setq w (symbol!-make!-fastget b nil)) (cond (c (progn (cond (w ( progn (cond ((s!:load2 a b env) (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (s!:outopcode1 (quote FASTGET) (logor w 64) b))) (t (s!:comcall x env context))))) (t (progn (s!:comval a env 1) (cond (w (s!:outopcode1 (quote FASTGET) w b)) (t (s!:outopcode1lit (quote LITGET) b env)))))))) (t ( s!:comcall x env context))))) (put (quote get) (quote s!:compfn) (function s!:comget)) (de s!:comflagp (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr x)) (cond ((eqcar b (quote quote)) (progn (setq b (cadr b)) (s!:comval a env 1) (setq a (symbol!-make!-fastget b nil)) (cond (a (s!:outopcode1 (quote FASTGET) (logor a 128) b)) (t (s!:comcall x env context))))) (t (s!:comcall x env context))))) (put (quote flagp) (quote s!:compfn) (function s!:comflagp)) (de s!:complus (x env context) (s!:comval (expand (cdr x) (quote plus2)) env context)) (put (quote plus) (quote s!:compfn) (function s!:complus)) (de s!:comtimes (x env context) (s!:comval (expand (cdr x) (quote times2)) env context)) (put (quote times) (quote s!:compfn) (function s!:comtimes)) (de s!:comiplus (x env context) (s!:comval (expand (cdr x) (quote iplus2)) env context)) (put (quote iplus) (quote s!:compfn) (function s!:comiplus)) (de s!:comitimes (x env context) (s!:comval (expand (cdr x) (quote itimes2)) env context)) (put (quote itimes) (quote s!:compfn) (function s!:comitimes)) (de s!:complus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( s!:comval (plus a b) env context)) (t (cond ((equal a 0) (s!:comval b env context)) (t (cond ((equal a 1) (s!:comval (list (quote add1) b) env context) ) (t (cond ((equal b 0) (s!:comval a env context)) (t (cond ((equal b 1) ( s!:comval (list (quote add1) a) env context)) (t (cond ((equal b (minus 1)) ( s!:comval (list (quote sub1) a) env context)) (t (s!:comcall x env context))) ))))))))))))) (put (quote plus2) (quote s!:compfn) (function s!:complus2)) (de s!:comdifference (x env context) (prog (a b) (setq a (s!:improve (cadr x) )) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b )) (s!:comval (difference a b) env context)) (t (cond ((equal a 0) (s!:comval (list (quote minus) b) env context)) (t (cond ((equal b 0) (s!:comval a env context)) (t (cond ((equal b 1) (s!:comval (list (quote sub1) a) env context) ) (t (cond ((equal b (minus 1)) (s!:comval (list (quote add1) a) env context) ) (t (s!:comcall x env context)))))))))))))) (put (quote difference) (quote s!:compfn) (function s!:comdifference)) (de s!:comiplus2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( s!:comval (plus a b) env context)) (t (cond ((equal a 1) (s!:comval (list ( quote iadd1) b) env context)) (t (cond ((equal b 1) (s!:comval (list (quote iadd1) a) env context)) (t (cond ((equal b (minus 1)) (s!:comval (list (quote isub1) a) env context)) (t (s!:comcall x env context)))))))))))) (put (quote iplus2) (quote s!:compfn) (function s!:comiplus2)) (de s!:comidifference (x env context) (prog (a b) (setq a (s!:improve (cadr x ))) (setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) (s!:comval (difference a b) env context)) (t (cond ((equal b 1) ( s!:comval (list (quote isub1) a) env context)) (t (cond ((equal b (minus 1)) (s!:comval (list (quote iadd1) a) env context)) (t (s!:comcall x env context) ))))))))) (put (quote idifference) (quote s!:compfn) (function s!:comidifference)) (de s!:comtimes2 (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (return (cond ((and (numberp a) (numberp b)) ( s!:comval (times a b) env context)) (t (cond ((equal a 1) (s!:comval b env context)) (t (cond ((equal a (minus 1)) (s!:comval (list (quote minus) b) env context)) (t (cond ((equal b 1) (s!:comval a env context)) (t (cond ((equal b (minus 1)) (s!:comval (list (quote minus) a) env context)) (t (s!:comcall x env context)))))))))))))) (put (quote times2) (quote s!:compfn) (function s!:comtimes2)) (put (quote itimes2) (quote s!:compfn) (function s!:comtimes2)) (de s!:comminus (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( return (cond ((numberp a) (s!:comval (minus a) env context)) (t (cond ((eqcar a (quote minus)) (s!:comval (cadr a) env context)) (t (s!:comcall x env context)))))))) (put (quote minus) (quote s!:compfn) (function s!:comminus)) (de s!:comminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote lessp) ( cdr a)) env context))) (t (return (s!:comcall x env context)))))) (put (quote minusp) (quote s!:compfn) (function s!:comminusp)) (de s!:comlessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( quote minusp) a) env context))) (t (return (s!:comcall x env context)))))) (put (quote lessp) (quote s!:compfn) (function s!:comlessp)) (de s!:comiminusp (x env context) (prog (a) (setq a (s!:improve (cadr x))) ( cond ((eqcar a (quote difference)) (return (s!:comval (cons (quote ilessp) ( cdr a)) env context))) (t (return (s!:comcall x env context)))))) (put (quote iminusp) (quote s!:compfn) (function s!:comiminusp)) (de s!:comilessp (x env context) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (cond ((equal b 0) (return (s!:comval (list ( quote iminusp) a) env context))) (t (return (s!:comcall x env context)))))) (put (quote ilessp) (quote s!:compfn) (function s!:comilessp)) (de s!:comprogn (x env context) (progn (setq x (cdr x)) (cond ((null x) ( s!:comval nil env context)) (t (prog (a) (setq a (car x)) (prog nil lab1085 ( cond ((null (setq x (cdr x))) (return nil))) (progn (s!:comval a env (cond (( geq context 4) context) (t 2))) (setq a (car x))) (go lab1085)) (s!:comval a env context)))))) (put (quote progn) (quote s!:compfn) (function s!:comprogn)) (de s!:comprog1 (x env context) (prog nil (setq x (cdr x)) (cond ((null x) ( return (s!:comval nil env context)))) (s!:comval (car x) env context) (cond ( (null (setq x (cdr x))) (return nil))) (s!:outopcode0 (quote PUSH) (quote ( PUSH))) (rplacd env (cons 0 (cdr env))) (prog (var1087) (setq var1087 x) lab1086 (cond ((null var1087) (return nil))) (prog (a) (setq a (car var1087)) (s!:comval a env (cond ((geq context 4) context) (t 2)))) (setq var1087 (cdr var1087)) (go lab1086)) (s!:outopcode0 (quote POP) (quote (POP))) (rplacd env (cddr env)))) (put (quote prog1) (quote s!:compfn) (function s!:comprog1)) (de s!:comprog2 (x env context) (prog (a) (setq x (cdr x)) (cond ((null x) ( return (s!:comval nil env context)))) (setq a (car x)) (s!:comval a env (cond ((geq context 4) context) (t 2))) (s!:comprog1 x env context))) (put (quote prog2) (quote s!:compfn) (function s!:comprog2)) (de s!:outstack (n) (prog (w a) (setq w s!:current_block) (prog nil lab1088 ( cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1088)) (cond ((eqcar w (quote PUSHNIL)) (setq a 1)) (t (cond ((eqcar w ( quote PUSHNIL2)) (setq a 2)) (t (cond ((eqcar w (quote PUSHNIL3)) (setq a 3)) (t (cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr w) (quote PUSHNILS))) (progn (setq w (cdr w)) (setq s!:current_size ( difference s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn ( setq s!:current_block (cdr w)) (setq s!:current_size (difference s!:current_size 1)) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 (quote PUSHNIL) (quote (PUSHNIL)))) (t (cond ((equal n 2) (s!:outopcode0 ( quote PUSHNIL2) (quote (PUSHNIL2)))) (t (cond ((equal n 3) (s!:outopcode0 ( quote PUSHNIL3) (quote (PUSHNIL3)))) (t (cond ((greaterp n 255) (progn ( s!:outopcode1 (quote PUSHNILS) 255 255) (s!:outstack (difference n 255)))) (t (cond ((greaterp n 3) (s!:outopcode1 (quote PUSHNILS) n n))))))))))))) (de s!:outlose (n) (prog (w a) (setq w s!:current_block) (prog nil lab1089 ( cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1089)) (cond ((eqcar w (quote LOSE)) (setq a 1)) (t (cond ((eqcar w ( quote LOSE2)) (setq a 2)) (t (cond ((eqcar w (quote LOSE3)) (setq a 3)) (t ( cond ((and w (numberp (setq a (car w))) (not (equal a 255)) (eqcar (cdr w) ( quote LOSES))) (progn (setq w (cdr w)) (setq s!:current_size (difference s!:current_size 1)))) (t (setq a nil))))))))) (cond (a (progn (setq s!:current_block (cdr w)) (setq s!:current_size (difference s!:current_size 1 )) (setq n (plus n a))))) (cond ((equal n 1) (s!:outopcode0 (quote LOSE) ( quote (LOSE)))) (t (cond ((equal n 2) (s!:outopcode0 (quote LOSE2) (quote ( LOSE2)))) (t (cond ((equal n 3) (s!:outopcode0 (quote LOSE3) (quote (LOSE3))) ) (t (cond ((greaterp n 255) (progn (s!:outopcode1 (quote LOSES) 255 255) ( s!:outlose (difference n 255)))) (t (cond ((greaterp n 3) (s!:outopcode1 ( quote LOSES) n n))))))))))))) (de s!:comprog (x env context) (prog (labs s bvl fluids n body local_decs w) (setq body (s!:find_local_decs (cddr x) t)) (setq local_decs (car body)) ( setq body (cdr body)) (setq n 0) (prog (var1091) (setq var1091 (cadr x)) lab1090 (cond ((null var1091) (return nil))) (prog (v) (setq v (car var1091)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1091 (cdr var1091) ) (go lab1090)) (prog (var1093) (setq var1093 (cadr x)) lab1092 (cond ((null var1093) (return nil))) (prog (v) (setq v (car var1093)) (progn (cond (( globalp v) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++++ global ") (prin v) (princ " converted to fluid") (terpri)))) ( unglobal (list v)) (fluid (list v))))) (cond ((fluidp v) (setq fluids (cons v fluids))) (t (progn (setq n (plus n 1)) (setq bvl (cons v bvl))))))) (setq var1093 (cdr var1093)) (go lab1092)) (setq s (cdr env)) (setq s!:current_exitlab (cons (cons nil (cons (gensym) s)) s!:current_exitlab)) ( s!:outstack n) (rplacd env (append bvl (cdr env))) (cond (fluids (prog (fl1) (setq fl1 (s!:vecof fluids)) (s!:outopcode1lit (quote FREEBIND) fl1 env) ( prog (var1095) (setq var1095 (cons nil fluids)) lab1094 (cond ((null var1095) (return nil))) (prog (v) (setq v (car var1095)) (rplacd env (cons 0 (cdr env )))) (setq var1095 (cdr var1095)) (go lab1094)) (rplacd env (cons (plus 2 ( length fluids)) (cdr env))) (cond ((equal context 0) (setq context 1)))))) ( prog (var1097) (setq var1097 body) lab1096 (cond ((null var1097) (return nil) )) (prog (a) (setq a (car var1097)) (cond ((atom a) (progn (cond ((atsoc a labs) (progn (cond ((not (null a)) (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++++ label ") (prin a) (princ " multiply defined") (terpri)))))) (t ( setq labs (cons (cons a (cons (cons (gensym) (cdr env)) nil)) labs)))))))) ( setq var1097 (cdr var1097)) (go lab1096)) (setq s!:current_proglabels (cons labs s!:current_proglabels)) (setq w (s!:residual_local_decs local_decs w)) ( prog (var1099) (setq var1099 body) lab1098 (cond ((null var1099) (return nil) )) (prog (a) (setq a (car var1099)) (cond ((not (atom a)) (s!:comval a env ( plus context 4))) (t (prog (d) (setq d (atsoc a labs)) (cond ((null (cddr d)) (progn (rplacd (cdr d) t) (s!:set_label (caadr d))))))))) (setq var1099 (cdr var1099)) (go lab1098)) (s!:cancel_local_decs w) (s!:comval nil env context) (cond (fluids (s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))))) ( s!:outlose n) (rplacd env s) (s!:set_label (cadar s!:current_exitlab)) (setq s!:current_exitlab (cdr s!:current_exitlab)) (setq s!:current_proglabels (cdr s!:current_proglabels)))) (put (quote prog) (quote s!:compfn) (function s!:comprog)) (de s!:comtagbody (x env context) (prog (labs) (prog (var1101) (setq var1101 (cdr x)) lab1100 (cond ((null var1101) (return nil))) (prog (a) (setq a (car var1101)) (cond ((atom a) (progn (cond ((atsoc a labs) (progn (cond ((not ( null a)) (progn (cond ((neq (posn) 0) (terpri))) (princ "+++++ label ") (prin a) (princ " multiply defined") (terpri)))))) (t (setq labs (cons (cons a ( cons (cons (gensym) (cdr env)) nil)) labs)))))))) (setq var1101 (cdr var1101) ) (go lab1100)) (setq s!:current_proglabels (cons labs s!:current_proglabels) ) (prog (var1103) (setq var1103 (cdr x)) lab1102 (cond ((null var1103) ( return nil))) (prog (a) (setq a (car var1103)) (cond ((not (atom a)) ( s!:comval a env (plus context 4))) (t (prog (d) (setq d (atsoc a labs)) (cond ((null (cddr d)) (progn (rplacd (cdr d) t) (s!:set_label (caadr d))))))))) ( setq var1103 (cdr var1103)) (go lab1102)) (s!:comval nil env context) (setq s!:current_proglabels (cdr s!:current_proglabels)))) (put (quote tagbody) (quote s!:compfn) (function s!:comtagbody)) (de s!:comblock (x env context) (prog nil (setq s!:current_exitlab (cons ( cons (cadr x) (cons (gensym) (cdr env))) s!:current_exitlab)) (s!:comval ( cons (quote progn) (cddr x)) env context) (s!:set_label (cadar s!:current_exitlab)) (setq s!:current_exitlab (cdr s!:current_exitlab)))) (put (quote !~block) (quote s!:compfn) (function s!:comblock)) (de s!:comcatch (x env context) (prog (g) (setq g (gensym)) (s!:comval (cadr x) env 1) (s!:outjump (quote CATCH) g) (rplacd env (cons (quote (catch)) ( cons 0 (cons 0 (cdr env))))) (s!:comval (cons (quote progn) (cddr x)) env context) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (rplacd env ( cddddr env)) (s!:set_label g))) (put (quote catch) (quote s!:compfn) (quote s!:comcatch)) (de s!:comthrow (x env context) (prog nil (s!:comval (cadr x) env 1) ( s!:outopcode0 (quote PUSH) (quote (PUSH))) (rplacd env (cons 0 (cdr env))) ( s!:comval (caddr x) env 1) (s!:outopcode0 (quote THROW) (quote (THROW))) ( rplacd env (cddr env)))) (put (quote throw) (quote s!:compfn) (quote s!:comthrow)) (de s!:comunwind!-protect (x env context) (prog (g) (setq g (gensym)) ( s!:comval (quote (load!-spid)) env 1) (s!:outjump (quote CATCH) g) (rplacd env (cons (list (quote unwind!-protect) (cddr x)) (cons 0 (cons 0 (cdr env))) )) (s!:comval (cadr x) env context) (s!:outopcode0 (quote PROTECT) (quote ( PROTECT))) (s!:set_label g) (rplaca (cdr env) 0) (s!:comval (cons (quote progn) (cddr x)) env context) (s!:outopcode0 (quote UNPROTECT) (quote ( UNPROTECT))) (rplacd env (cddddr env)))) (put (quote unwind!-protect) (quote s!:compfn) (quote s!:comunwind!-protect)) (de s!:comdeclare (x env context) (prog nil (cond (!*pwrds (progn (princ "+++ ") (prin x) (princ " ignored") (terpri)))))) (put (quote declare) (quote s!:compfn) (function s!:comdeclare)) (de s!:expand_let (vl b) (prog (vars vals) (prog (var1105) (setq var1105 vl) lab1104 (cond ((null var1105) (return nil))) (prog (v) (setq v (car var1105)) (cond ((atom v) (progn (setq vars (cons v vars)) (setq vals (cons nil vals)) )) (t (cond ((atom (cdr v)) (progn (setq vars (cons (car v) vars)) (setq vals (cons nil vals)))) (t (progn (setq vars (cons (car v) vars)) (setq vals ( cons (cadr v) vals)))))))) (setq var1105 (cdr var1105)) (go lab1104)) (return (list (cons (cons (quote lambda) (cons vars b)) vals))))) (de s!:comlet (x env context) (s!:comval (cons (quote progn) (s!:expand_let ( cadr x) (cddr x))) env context)) (put (quote !~let) (quote s!:compfn) (function s!:comlet)) (de s!:expand_let!* (vl local_decs b) (prog (r var val) (setq r (cons (cons ( quote declare) local_decs) b)) (prog (var1109) (setq var1109 (reverse vl)) lab1108 (cond ((null var1109) (return nil))) (prog (x) (setq x (car var1109)) (progn (setq val nil) (cond ((atom x) (setq var x)) (t (cond ((atom (cdr x)) (setq var (car x))) (t (progn (setq var (car x)) (setq val (cadr x))))))) ( prog (var1107) (setq var1107 local_decs) lab1106 (cond ((null var1107) ( return nil))) (prog (z) (setq z (car var1107)) (cond ((eqcar z (quote special )) (cond ((memq var (cdr z)) (setq r (cons (list (quote declare) (list (quote special) var)) r))))))) (setq var1107 (cdr var1107)) (go lab1106)) (setq r ( list (list (cons (quote lambda) (cons (list var) r)) val))))) (setq var1109 ( cdr var1109)) (go lab1108)) (cond ((eqcar (car r) (quote declare)) (setq r ( list (cons (quote lambda) (cons nil r))))) (t (setq r (cons (quote progn) r)) )) (return r))) (de s!:comlet!* (x env context) (prog (b) (setq b (s!:find_local_decs (cddr x ) nil)) (return (s!:comval (s!:expand_let!* (cadr x) (car b) (cdr b)) env context)))) (put (quote let!*) (quote s!:compfn) (function s!:comlet!*)) (de s!:restore_stack (e1 e2) (prog (n) (setq n 0) (prog nil lab1111 (cond (( null (not (equal e1 e2))) (return nil))) (progn (cond ((null e1) (error 0 "bad block nesting with GO or RETURN-FROM"))) (cond ((and (numberp (car e1)) (greaterp (car e1) 2)) (progn (cond ((not (zerop n)) (s!:outlose n))) (setq n (car e1)) (s!:outopcode0 (quote FREERSTR) (quote (FREERSTR))) (prog (i) ( setq i 1) lab1110 (cond ((minusp (times 1 (difference n i))) (return nil))) ( setq e1 (cdr e1)) (setq i (plus i 1)) (go lab1110)) (setq n 0))) (t (cond (( equal (car e1) (quote (catch))) (progn (cond ((not (zerop n)) (s!:outlose n)) ) (s!:outopcode0 (quote UNCATCH) (quote (UNCATCH))) (setq e1 (cdddr e1)) ( setq n 0))) (t (cond ((eqcar (car e1) (quote unwind!-protect)) (progn (cond ( (not (zerop n)) (s!:outlose n))) (s!:outopcode0 (quote PROTECT) (quote ( PROTECT))) (s!:comval (cons (quote progn) (cadar e1)) e1 2) (s!:outopcode0 ( quote UNPROTECT) (quote (UNPROTECT))) (setq e1 (cdddr e1)) (setq n 0))) (t ( progn (setq e1 (cdr e1)) (setq n (plus n 1)))))))))) (go lab1111)) (cond (( not (zerop n)) (s!:outlose n))))) (de s!:comgo (x env context) (prog (pl d) (cond ((lessp context 4) (progn ( princ "go not in program context") (terpri)))) (setq pl s!:current_proglabels ) (prog nil lab1112 (cond ((null (and pl (null d))) (return nil))) (progn ( setq d (atsoc (cadr x) (car pl))) (cond ((null d) (setq pl (cdr pl))))) (go lab1112)) (cond ((null d) (progn (cond ((neq (posn) 0) (terpri))) (princ "+++++ label ") (prin (cadr x)) (princ " not set") (terpri) (return nil)))) ( setq d (cadr d)) (s!:restore_stack (cdr env) (cdr d)) (s!:outjump (quote JUMP ) (car d)))) (put (quote go) (quote s!:compfn) (function s!:comgo)) (de s!:comreturn!-from (x env context) (prog (tag) (cond ((lessp context 4) ( progn (princ "+++++ return or return-from not in prog context") (terpri)))) ( setq x (cdr x)) (setq tag (car x)) (cond ((cdr x) (setq x (cadr x))) (t (setq x nil))) (s!:comval x env (difference context 4)) (setq x (atsoc tag s!:current_exitlab)) (cond ((null x) (error 0 (list "invalid return-from" tag )))) (setq x (cdr x)) (s!:restore_stack (cdr env) (cdr x)) (s!:outjump (quote JUMP) (car x)))) (put (quote return!-from) (quote s!:compfn) (function s!:comreturn!-from)) (de s!:comreturn (x env context) (s!:comreturn!-from (cons (quote return!-from) (cons nil (cdr x))) env context)) (put (quote return) (quote s!:compfn) (function s!:comreturn)) (global (quote (s!:jumplts s!:jumplnils s!:jumpatoms s!:jumpnatoms))) (setq s!:jumplts (s!:vecof (quote (JUMPL0T JUMPL1T JUMPL2T JUMPL3T JUMPL4T))) ) (setq s!:jumplnils (s!:vecof (quote (JUMPL0NIL JUMPL1NIL JUMPL2NIL JUMPL3NIL JUMPL4NIL)))) (setq s!:jumpatoms (s!:vecof (quote (JUMPL0ATOM JUMPL1ATOM JUMPL2ATOM JUMPL3ATOM)))) (setq s!:jumpnatoms (s!:vecof (quote (JUMPL0NATOM JUMPL1NATOM JUMPL2NATOM JUMPL3NATOM)))) (de s!:jumpif (neg x env lab) (prog (w w1 j) top (cond ((null x) (progn (cond ((not neg) (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond ((or (eq x t) (and (eqcar x (quote quote)) (cadr x)) (and (atom x) (not (symbolp x)))) (progn (cond (neg (s!:outjump (quote JUMP) lab))) (return nil))) (t (cond (( lessp (setq w (s!:islocal x env)) 5) (return (s!:outjump (getv (cond (neg s!:jumplts) (t s!:jumplnils)) w) lab))) (t (cond ((and (equal w 99999) ( symbolp x)) (progn (s!:should_be_fluid x) (setq w (list (cond (neg (quote JUMPFREET)) (t (quote JUMPFREENIL))) x x)) (return ( s!:record_literal_for_jump w env lab))))))))))) (cond ((and (not (atom x)) ( atom (car x)) (setq w (get (car x) (quote s!:testfn)))) (return (funcall w neg x env lab)))) (cond ((not (atom x)) (progn (setq w (s!:improve x)) (cond ((or (atom w) (not (eqcar x (car w)))) (progn (setq x w) (go top)))) (cond (( and (setq w1 (get (car w) (quote s!:compilermacro))) (setq w1 (funcall w1 w env 1))) (progn (setq x w1) (go top))))))) remacro (cond ((and (not (atom w)) (setq w1 (macro!-function (car w)))) (progn (setq w (funcall w1 w)) (cond (( or (atom w) (eqcar w (quote quote)) (get (car w) (quote s!:testfn)) (get (car w) (quote s!:compilermacro))) (progn (setq x w) (go top)))) (go remacro)))) (s!:comval x env 1) (setq w s!:current_block) (prog nil lab1113 (cond ((null (and w (not (atom (car w))))) (return nil))) (setq w (cdr w)) (go lab1113)) ( setq j (quote (JUMPNIL . JUMPT))) (cond (w (progn (setq w1 (car w)) (setq w ( cdr w)) (cond ((equal w1 (quote STORELOC0)) (progn (setq s!:current_block w) (setq s!:current_size (difference s!:current_size 1)) (setq j (quote ( JUMPST0NIL . JUMPST0T))))) (t (cond ((equal w1 (quote STORELOC1)) (progn ( setq s!:current_block w) (setq s!:current_size (difference s!:current_size 1) ) (setq j (quote (JUMPST1NIL . JUMPST1T))))) (t (cond ((equal w1 (quote STORELOC2)) (progn (setq s!:current_block w) (setq s!:current_size ( difference s!:current_size 1)) (setq j (quote (JUMPST2NIL . JUMPST2T))))) (t (cond ((eqcar w (quote BUILTIN1)) (progn (setq s!:current_block (cdr w)) ( setq s!:current_size (difference s!:current_size 2)) (setq j (cons (list ( quote JUMPB1NIL) w1) (list (quote JUMPB1T) w1))))) (t (cond ((eqcar w (quote BUILTIN2)) (progn (setq s!:current_block (cdr w)) (setq s!:current_size ( difference s!:current_size 2)) (setq j (cons (list (quote JUMPB2NIL) w1) ( list (quote JUMPB2T) w1))))))))))))))))) (return (s!:outjump (cond (neg (cdr j)) (t (car j))) lab)))) (de s!:testnot (neg x env lab) (s!:jumpif (not neg) (cadr x) env lab)) (put (quote null) (quote s!:testfn) (function s!:testnot)) (put (quote not) (quote s!:testfn) (function s!:testnot)) (de s!:testatom (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal ( cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpatoms) (t s!:jumpnatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump (quote JUMPATOM) lab)) (t (s!:outjump (quote JUMPNATOM) lab))))) (put (quote atom) (quote s!:testfn) (function s!:testatom)) (de s!:testconsp (neg x env lab) (prog (w) (cond ((lessp (setq w (s!:islocal (cadr x) env)) 4) (return (s!:outjump (getv (cond (neg s!:jumpnatoms) (t s!:jumpatoms)) w) lab)))) (s!:comval (cadr x) env 1) (cond (neg (s!:outjump ( quote JUMPNATOM) lab)) (t (s!:outjump (quote JUMPATOM) lab))))) (put (quote consp) (quote s!:testfn) (function s!:testconsp)) (de s!:comcond (x env context) (prog (l1 l2 w) (setq l1 (gensym)) (prog nil lab1114 (cond ((null (setq x (cdr x))) (return nil))) (progn (setq w (car x)) (cond ((atom (cdr w)) (progn (s!:comval (car w) env 1) (s!:outjump (quote JUMPT) l1) (setq l2 nil))) (t (progn (cond ((equal (car w) t) (setq l2 nil)) (t (progn (setq l2 (gensym)) (s!:jumpif nil (car w) env l2)))) (setq w (cdr w )) (cond ((null (cdr w)) (setq w (car w))) (t (setq w (cons (quote progn) w)) )) (s!:comval w env context) (cond (l2 (progn (s!:outjump (quote JUMP) l1) ( s!:set_label l2))) (t (setq x (quote (nil))))))))) (go lab1114)) (cond (l2 ( s!:comval nil env context))) (s!:set_label l1))) (put (quote cond) (quote s!:compfn) (function s!:comcond)) (de s!:comif (x env context) (prog (l1 l2) (setq l2 (gensym)) (s!:jumpif nil (cadr x) env l2) (setq x (cddr x)) (s!:comval (car x) env context) (setq x ( cdr x)) (cond ((or x (and (lessp context 2) (setq x (quote (nil))))) (progn ( setq l1 (gensym)) (s!:outjump (quote JUMP) l1) (s!:set_label l2) (s!:comval ( car x) env context) (s!:set_label l1))) (t (s!:set_label l2))))) (put (quote if) (quote s!:compfn) (function s!:comif)) (de s!:comwhen (x env context) (prog (l2) (setq l2 (gensym)) (cond ((lessp context 2) (progn (s!:comval (cadr x) env 1) (s!:outjump (quote JUMPNIL) l2)) ) (t (s!:jumpif nil (cadr x) env l2))) (s!:comval (cons (quote progn) (cddr x )) env context) (s!:set_label l2))) (put (quote when) (quote s!:compfn) (function s!:comwhen)) (de s!:comunless (x env context) (s!:comwhen (list!* (quote when) (list ( quote not) (cadr x)) (cddr x)) env context)) (put (quote unless) (quote s!:compfn) (function s!:comunless)) (de s!:comicase (x env context) (prog (l1 labs labassoc w) (setq x (cdr x)) ( prog (var1116) (setq var1116 (cdr x)) lab1115 (cond ((null var1116) (return nil))) (prog (v) (setq v (car var1116)) (progn (setq w (assoc!*!* v labassoc) ) (cond (w (setq l1 (cons (cdr w) l1))) (t (progn (setq l1 (gensym)) (setq labs (cons l1 labs)) (setq labassoc (cons (cons v l1) labassoc))))))) (setq var1116 (cdr var1116)) (go lab1115)) (s!:comval (car x) env 1) (s!:outjump ( quote ICASE) (reversip labs)) (setq l1 (gensym)) (prog (var1118) (setq var1118 labassoc) lab1117 (cond ((null var1118) (return nil))) (prog (v) ( setq v (car var1118)) (progn (s!:set_label (cdr v)) (s!:comval (car v) env context) (s!:outjump (quote JUMP) l1))) (setq var1118 (cdr var1118)) (go lab1117)) (s!:set_label l1))) (put (quote s!:icase) (quote s!:compfn) (function s!:comicase)) (put (quote JUMPLITEQ!*) (quote s!:opcode) (get (quote JUMPLITEQ) (quote s!:opcode))) (put (quote JUMPLITNE!*) (quote s!:opcode) (get (quote JUMPLITNE) (quote s!:opcode))) (de s!:jumpliteql (val lab env) (prog (w) (cond ((or (idp val) (eq!-safe val) ) (progn (setq w (list (quote JUMPLITEQ!*) val val)) ( s!:record_literal_for_jump w env lab))) (t (progn (s!:outopcode0 (quote PUSH) (quote (PUSH))) (s!:loadliteral val env) (s!:outopcode1 (quote BUILTIN2) ( get (quote eql) (quote s!:builtin2)) (quote eql)) (s!:outjump (quote JUMPT) lab) (flag (list lab) (quote s!:jumpliteql)) (s!:outopcode0 (quote POP) ( quote (POP)))))))) (de s!:casebranch (sw env dflt) (prog (size w w1 r g) (setq size (plus 4 ( truncate (length sw) 2))) (prog nil lab1119 (cond ((null (or (equal ( remainder size 2) 0) (equal (remainder size 3) 0) (equal (remainder size 5) 0 ) (equal (remainder size 13) 0))) (return nil))) (setq size (plus size 1)) ( go lab1119)) (prog (var1121) (setq var1121 sw) lab1120 (cond ((null var1121) (return nil))) (prog (p) (setq p (car var1121)) (progn (setq w (remainder ( eqlhash (car p)) size)) (setq w1 (assoc!*!* w r)) (cond (w1 (rplacd (cdr w1) (cons p (cddr w1)))) (t (setq r (cons (list w (gensym) p) r)))))) (setq var1121 (cdr var1121)) (go lab1120)) (s!:outopcode0 (quote PUSH) (quote (PUSH ))) (rplacd env (cons 0 (cdr env))) (s!:outopcode1lit (quote CALL1) (quote eqlhash) env) (s!:loadliteral size env) (setq g (gensym)) (s!:outopcode1 ( quote BUILTIN2) (get (quote iremainder) (quote s!:builtin2)) (quote iremainder)) (s!:outjump (quote ICASE) (cons g (prog (i var1123) (setq i 0) lab1122 (cond ((minusp (times 1 (difference (difference size 1) i))) (return (reversip var1123)))) (setq var1123 (cons (progn (setq w (assoc!*!* i r)) ( cond (w (cadr w)) (t g))) var1123)) (setq i (plus i 1)) (go lab1122)))) (prog (var1127) (setq var1127 r) lab1126 (cond ((null var1127) (return nil))) ( prog (p) (setq p (car var1127)) (progn (s!:set_label (cadr p)) (s!:outopcode0 (quote POP) (quote (POP))) (prog (var1125) (setq var1125 (cddr p)) lab1124 ( cond ((null var1125) (return nil))) (prog (q) (setq q (car var1125)) ( s!:jumpliteql (car q) (cdr q) env)) (setq var1125 (cdr var1125)) (go lab1124) ) (s!:outjump (quote JUMP) dflt))) (setq var1127 (cdr var1127)) (go lab1126)) (s!:set_label g) (s!:outopcode0 (quote POP) (quote (POP))) (s!:outjump ( quote JUMP) dflt) (rplacd env (cddr env)))) (de s!:comcase (x env context) (prog (keyform blocks v w g dflt sw keys nonnum) (setq x (cdr x)) (setq keyform (car x)) (prog (y) (setq y (cdr x)) lab1130 (cond ((null y) (return nil))) (progn (setq w (assoc!*!* (cdar y) blocks)) (cond (w (setq g (cdr w))) (t (progn (setq g (gensym)) (setq blocks (cons (cons (cdar y) g) blocks))))) (setq w (caar y)) (cond ((and (null (cdr y)) (or (equal w t) (equal w (quote otherwise)))) (setq dflt g)) (t (progn ( cond ((atom w) (setq w (list w)))) (prog (var1129) (setq var1129 w) lab1128 ( cond ((null var1129) (return nil))) (prog (n) (setq n (car var1129)) (progn ( cond ((or (idp n) (numberp n)) (progn (cond ((not (fixp n)) (setq nonnum t))) (setq keys (cons n keys)) (setq sw (cons (cons n g) sw)))) (t (error 0 (list "illegal case label" n)))))) (setq var1129 (cdr var1129)) (go lab1128)))))) (setq y (cdr y)) (go lab1130)) (cond ((null dflt) (progn (cond ((setq w ( assoc!*!* nil blocks)) (setq dflt (cdr w))) (t (setq blocks (cons (cons nil ( setq dflt (gensym))) blocks))))))) (cond ((not nonnum) (progn (setq keys ( sort keys (function lessp))) (setq nonnum (car keys)) (setq g (lastcar keys)) (cond ((lessp (difference g nonnum) (times 2 (length keys))) (progn (cond (( not (equal nonnum 0)) (progn (setq keyform (list (quote xdifference) keyform nonnum)) (setq sw (prog (var1132 var1133) (setq var1132 sw) lab1131 (cond (( null var1132) (return (reversip var1133)))) (prog (y) (setq y (car var1132)) (setq var1133 (cons (cons (difference (car y) nonnum) (cdr y)) var1133))) ( setq var1132 (cdr var1132)) (go lab1131)))))) (s!:comval keyform env 1) (setq w nil) (prog (i) (setq i 0) lab1134 (cond ((minusp (times 1 (difference g i) )) (return nil))) (cond ((setq v (assoc!*!* i sw)) (setq w (cons (cdr v) w))) (t (setq w (cons dflt w)))) (setq i (plus i 1)) (go lab1134)) (setq w (cons dflt (reversip w))) (s!:outjump (quote ICASE) w) (setq nonnum nil))) (t (setq nonnum t)))))) (cond (nonnum (progn (s!:comval keyform env 1) (cond ((lessp (length sw) 7) (progn (prog (var1136) (setq var1136 sw) lab1135 (cond ((null var1136) (return nil))) (prog (y) (setq y (car var1136)) (s!:jumpliteql (car y) (cdr y) env)) (setq var1136 (cdr var1136)) (go lab1135)) (s!:outjump ( quote JUMP) dflt))) (t (s!:casebranch sw env dflt)))))) (setq g (gensym)) ( prog (var1138) (setq var1138 blocks) lab1137 (cond ((null var1138) (return nil))) (prog (v) (setq v (car var1138)) (progn (s!:set_label (cdr v)) (cond ( (flagp (cdr v) (quote s!:jumpliteql)) (s!:outlose 1))) (s!:comval (cons ( quote progn) (car v)) env context) (s!:outjump (quote JUMP) g))) (setq var1138 (cdr var1138)) (go lab1137)) (s!:set_label g))) (put (quote case) (quote s!:compfn) (function s!:comcase)) (fluid (quote (!*defn dfprint!* s!:dfprintsave s!:faslmod_name))) (de s!:comeval!-when (x env context) (prog (y) (setq x (cdr x)) (setq y (car x)) (princ "COMPILING eval-when: ") (print y) (print x) (setq x (cons (quote progn) (cdr x))) (cond ((memq (quote compile) y) (eval x))) (cond ((memq ( quote load) y) (progn (cond (dfprint!* (apply1 dfprint!* x)))))) (cond ((memq (quote eval) y) (s!:comval x env context)) (t (s!:comval nil env context)))) ) (put (quote eval!-when) (quote s!:compfn) (function s!:comeval!-when)) (de s!:comthe (x env context) (s!:comval (caddr x) env context)) (put (quote the) (quote s!:compfn) (function s!:comthe)) (de s!:comand (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( s!:comval (car x) env 1) (prog nil lab1139 (cond ((null (setq x (cdr x))) ( return nil))) (progn (s!:outjump (quote JUMPNIL) l) (s!:comval (car x) env 1) ) (go lab1139)) (s!:set_label l))) (put (quote and) (quote s!:compfn) (function s!:comand)) (de s!:comor (x env context) (prog (l) (setq l (gensym)) (setq x (cdr x)) ( s!:comval (car x) env 1) (prog nil lab1140 (cond ((null (setq x (cdr x))) ( return nil))) (progn (s!:outjump (quote JUMPT) l) (s!:comval (car x) env 1)) (go lab1140)) (s!:set_label l))) (put (quote or) (quote s!:compfn) (function s!:comor)) (de s!:combool (neg x env lab) (prog (fn) (setq fn (eqcar x (quote or))) ( cond ((eq fn neg) (prog nil lab1141 (cond ((null (setq x (cdr x))) (return nil))) (s!:jumpif fn (car x) env lab) (go lab1141))) (t (progn (setq neg ( gensym)) (prog nil lab1142 (cond ((null (setq x (cdr x))) (return nil))) ( s!:jumpif fn (car x) env neg) (go lab1142)) (s!:outjump (quote JUMP) lab) ( s!:set_label neg)))))) (put (quote and) (quote s!:testfn) (function s!:combool)) (put (quote or) (quote s!:testfn) (function s!:combool)) (de s!:testeq (neg x env lab) (prog (a b) (setq a (s!:improve (cadr x))) ( setq b (s!:improve (caddr x))) (cond ((or (s!:eval_to_eq_unsafe a) ( s!:eval_to_eq_unsafe b)) (progn (cond ((neq (posn) 0) (terpri))) (princ "++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) (princ " : ") (prin a) (princ " ") (print b) (return (s!:testequal neg (cons (quote equal) (cdr x)) env lab))))) (cond (!*carefuleq (progn (s!:comval x env 1) ( s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab) (return nil))) ) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b) ( s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a (quote quote)) (and ( atom a) (not (symbolp a)))) (progn (s!:comval b env 1) (cond ((eqcar a (quote quote)) (setq a (cadr a)))) (setq b (list (cond (neg (quote JUMPLITEQ)) (t ( quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b env lab))) (t (cond (( or (eqcar b (quote quote)) (and (atom b) (not (symbolp b)))) (progn ( s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr b)))) (setq a (list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b)) ( s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) (cond ( neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab))))))) ))))))) (de s!:testeq1 (neg x env lab) (prog (a b) (cond (!*carefuleq (progn ( s!:comval x env 1) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab) (return nil)))) (setq a (s!:improve (cadr x))) (setq b (s!:improve ( caddr x))) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b ) (s!:jumpif (not neg) a env lab)) (t (cond ((or (eqcar a (quote quote)) (and (atom a) (not (symbolp a)))) (progn (s!:comval b env 1) (cond ((eqcar a ( quote quote)) (setq a (cadr a)))) (setq b (list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) a a)) (s!:record_literal_for_jump b env lab))) (t ( cond ((or (eqcar b (quote quote)) (and (atom b) (not (symbolp b)))) (progn ( s!:comval a env 1) (cond ((eqcar b (quote quote)) (setq b (cadr b)))) (setq a (list (cond (neg (quote JUMPLITEQ)) (t (quote JUMPLITNE))) b b)) ( s!:record_literal_for_jump a env lab))) (t (progn (s!:load2 a b env) (cond ( neg (s!:outjump (quote JUMPEQ) lab)) (t (s!:outjump (quote JUMPNE) lab))))))) ))))))) (put (quote eq) (quote s!:testfn) (function s!:testeq)) (cond ((eq!-safe 0) (put (quote iequal) (quote s!:testfn) (function s!:testeq1))) (t (put (quote iequal) (quote s!:testfn) (function s!:testequal )))) (de s!:testequal (neg x env lab) (prog (a b) (setq a (cadr x)) (setq b (caddr x)) (cond ((null a) (s!:jumpif (not neg) b env lab)) (t (cond ((null b) ( s!:jumpif (not neg) a env lab)) (t (cond ((or (and (eqcar a (quote quote)) ( or (symbolp (cadr a)) (eq!-safe (cadr a)))) (and (eqcar b (quote quote)) (or (symbolp (cadr b)) (eq!-safe (cadr b)))) (and (not (idp a)) (eq!-safe a)) ( and (not (idp b)) (eq!-safe b))) (s!:testeq1 neg (cons (quote eq) (cdr x)) env lab)) (t (progn (s!:load2 a b env) (cond (neg (s!:outjump (quote JUMPEQUAL) lab)) (t (s!:outjump (quote JUMPNEQUAL) lab)))))))))))) (put (quote equal) (quote s!:testfn) (function s!:testequal)) (de s!:testneq (neg x env lab) (s!:testequal (not neg) (cons (quote equal) ( cdr x)) env lab)) (put (quote neq) (quote s!:testfn) (function s!:testneq)) (de s!:testeqcar (neg x env lab) (prog (a b sw promote) (setq a (cadr x)) ( setq b (s!:improve (caddr x))) (cond ((s!:eval_to_eq_unsafe b) (progn (cond ( (neq (posn) 0) (terpri))) (princ "++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( princ " : ") (print b) (setq promote t))) (t (cond (!*carefuleq (progn ( s!:comval x env 1) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab) (return nil)))))) (cond ((and (not promote) (eqcar b (quote quote))) ( progn (s!:comval a env 1) (setq b (cadr b)) (setq a (list (cond (neg (quote JUMPEQCAR)) (t (quote JUMPNEQCAR))) b b)) (s!:record_literal_for_jump a env lab))) (t (progn (setq sw (s!:load2 a b env)) (cond (sw (s!:outopcode0 (quote SWOP) (quote (SWOP))))) (cond (promote (s!:outopcode1 (quote BUILTIN2) (get (quote equalcar) (quote s!:builtin2)) (quote equalcar))) (t (s!:outopcode0 ( quote EQCAR) (quote (EQCAR))))) (s!:outjump (cond (neg (quote JUMPT)) (t ( quote JUMPNIL))) lab)))))) (put (quote eqcar) (quote s!:testfn) (function s!:testeqcar)) (de s!:testflagp (neg x env lab) (prog (a b sw) (setq a (cadr x)) (setq b ( caddr x)) (cond ((eqcar b (quote quote)) (progn (s!:comval a env 1) (setq b ( cadr b)) (setq sw (symbol!-make!-fastget b nil)) (cond (sw (progn ( s!:outopcode1 (quote FASTGET) (logor sw 128) b) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab))) (t (progn (setq a (list (cond (neg ( quote JUMPFLAGP)) (t (quote JUMPNFLAGP))) b b)) (s!:record_literal_for_jump a env lab)))))) (t (progn (setq sw (s!:load2 a b env)) (cond (sw ( s!:outopcode0 (quote SWOP) (quote (SWOP))))) (s!:outopcode0 (quote FLAGP) ( quote (FLAGP))) (s!:outjump (cond (neg (quote JUMPT)) (t (quote JUMPNIL))) lab)))))) (put (quote flagp) (quote s!:testfn) (function s!:testflagp)) (global (quote (s!:storelocs))) (setq s!:storelocs (s!:vecof (quote (STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7)))) (de s!:comsetq (x env context) (prog (n w var) (setq x (cdr x)) (cond ((null x) (return nil))) (cond ((or (not (symbolp (car x))) (null (cdr x))) (return (error 0 (list "bad args for setq" x))))) (s!:comval (cadr x) env 1) (setq var (car x)) (setq n 0) (setq w (cdr env)) (prog nil lab1143 (cond ((null ( and w (not (eqcar w var)))) (return nil))) (progn (setq n (add1 n)) (setq w ( cdr w))) (go lab1143)) (cond (w (progn (cond ((not (member!*!* (cons (quote loc) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote loc) w) s!:a_reg_values)))) (cond ((lessp n 8) (s!:outopcode0 (getv s!:storelocs n) ( list (quote storeloc) var))) (t (cond ((greaterp n 4095) (error 0 "stack frame > 4095")) (t (cond ((greaterp n 255) (s!:outopcode2 (quote BIGSTACK) (plus 64 (truncate n 256)) (logand n 255) (list (quote STORELOC) var))) (t (s!:outopcode1 (quote STORELOC) n var))))))))) (t (cond ((setq w ( s!:find_lexical var s!:lexical_env 0)) (progn (cond ((not (member!*!* (cons ( quote lex) w) s!:a_reg_values)) (setq s!:a_reg_values (cons (cons (quote lex) w) s!:a_reg_values)))) (s!:outlexref (quote STORELEX) (length (cdr env)) ( car w) (cadr w) var))) (t (progn (cond ((or (null var) (eq var t)) (error 0 ( list "bad variable in setq" var))) (t (s!:should_be_fluid var))) (setq w ( cons (quote free) var)) (cond ((not (member!*!* w s!:a_reg_values)) (setq s!:a_reg_values (cons w s!:a_reg_values)))) (s!:outopcode1lit (quote STOREFREE) var env)))))) (cond ((cddr x) (return (s!:comsetq (cdr x) env context)))))) (put (quote setq) (quote s!:compfn) (function s!:comsetq)) (put (quote noisy!-setq) (quote s!:compfn) (function s!:comsetq)) (de s!:comlist (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null (setq w (cdr x))) (s!:comval (list (quote ncons) (car x)) env context)) (t ( cond ((null (setq w (cdr w))) (s!:comval (list (quote list2) (car x) (cadr x) ) env context)) (t (cond ((null (cdr w)) (s!:comval (list (quote list3) (car x) (cadr x) (car w)) env context)) (t (s!:comval (list (quote list2!*) (car x ) (cadr x) (cons (quote list) w)) env context))))))))) (put (quote list) (quote s!:compfn) (function s!:comlist)) (de s!:comlist!* (x env context) (prog (w) (cond ((null (setq x (cdr x))) ( return (s!:comval nil env context)))) (setq s!:a_reg_values nil) (cond ((null (setq w (cdr x))) (s!:comval (car x) env context)) (t (cond ((null (setq w ( cdr w))) (s!:comval (list (quote cons) (car x) (cadr x)) env context)) (t ( cond ((null (cdr w)) (s!:comval (list (quote list2!*) (car x) (cadr x) (car w )) env context)) (t (s!:comval (list (quote list2!*) (car x) (cadr x) (cons ( quote list!*) w)) env context))))))))) (put (quote list!*) (quote s!:compfn) (function s!:comlist!*)) (de s!:comcons (x env context) (prog (a b) (setq a (cadr x)) (setq b (caddr x )) (cond ((or (equal b nil) (equal b (quote (quote nil)))) (s!:comval (list ( quote ncons) a) env context)) (t (cond ((eqcar a (quote cons)) (s!:comval ( list (quote acons) (cadr a) (caddr a) b) env context)) (t (cond ((eqcar b ( quote cons)) (cond ((null (caddr b)) (s!:comval (list (quote list2) a (cadr b )) env context)) (t (s!:comval (list (quote list2!*) a (cadr b) (caddr b)) env context)))) (t (cond ((and (not !*ord) (s!:iseasy a) (not (s!:iseasy b))) (s!:comval (list (quote xcons) b a) env context)) (t (s!:comcall x env context))))))))))) (put (quote cons) (quote s!:compfn) (function s!:comcons)) (de s!:comapply (x env context) (prog (a b n) (setq a (cadr x)) (setq b ( caddr x)) (cond ((and (null (cdddr x)) (eqcar b (quote list))) (progn (cond ( (eqcar a (quote quote)) (return (progn (setq n s!:current_function) (prog ( s!:current_function) (setq s!:current_function (compress (append (explode n) (cons (quote !!) (cons (quote !.) (explodec (setq s!:current_count (plus s!:current_count 1)))))))) (return (s!:comval (cons (cadr a) (cdr b)) env context))))))) (setq n (length (setq b (cdr b)))) (return (s!:comval (cons ( quote funcall) (cons a b)) env context)))) (t (cond ((and (null b) (null ( cdddr x))) (return (s!:comval (list (quote funcall) a) env context))) (t ( return (s!:comcall x env context)))))))) (put (quote apply) (quote s!:compfn) (function s!:comapply)) (de s!:imp_funcall (u) (prog (n) (setq u (cdr u)) (cond ((eqcar (car u) ( quote function)) (return (s!:improve (cons (cadar u) (cdr u)))))) (setq n ( length (cdr u))) (setq u (cond ((equal n 0) (cons (quote apply0) u)) (t (cond ((equal n 1) (cons (quote apply1) u)) (t (cond ((equal n 2) (cons (quote apply2) u)) (t (cond ((equal n 3) (cons (quote apply3) u)) (t (cons (quote funcall!*) u)))))))))) (return u))) (put (quote funcall) (quote s!:tidy_fn) (quote s!:imp_funcall)) (de s!:eval_to_eq_safe (x) (or (null x) (equal x t) (and (not (symbolp x)) ( eq!-safe x)) (and (not (atom x)) (flagp (car x) (quote eq!-safe))) (and ( eqcar x (quote quote)) (or (symbolp (cadr x)) (eq!-safe (cadr x)))))) (de s!:eval_to_eq_unsafe (x) (or (and (atom x) (not (symbolp x)) (not ( eq!-safe x))) (and (not (atom x)) (flagp (car x) (quote eq!-unsafe))) (and ( eqcar x (quote quote)) (or (not (atom (cadr x))) (and (not (symbolp (cadr x)) ) (not (eq!-safe (cadr x)))))))) (de s!:list_all_eq_safe (u) (or (atom u) (and (or (symbolp (car u)) (eq!-safe (car u))) (s!:list_all_eq_safe (cdr u))))) (de s!:eval_to_list_all_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) (s!:list_all_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x )) (and (s!:eval_to_eq_safe (cadr x)) (s!:eval_to_list_all_eq_safe (cons ( quote list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_eq_safe ( cadr x)) (s!:eval_to_list_all_eq_safe (caddr x))))) (de s!:list_some_eq_unsafe (u) (and (not (atom u)) (or (s!:eval_to_eq_unsafe (car u)) (s!:list_some_eq_unsafe (cdr u))))) (de s!:eval_to_list_some_eq_unsafe (x) (cond ((atom x) nil) (t (cond ((eqcar x (quote quote)) (s!:list_some_eq_unsafe (cadr x))) (t (cond ((and (eqcar x ( quote list)) (cdr x)) (or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_list_some_eq_unsafe (cons (quote list) (cddr x))))) (t (cond (( eqcar x (quote cons)) (or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_list_some_eq_unsafe (caddr x)))) (t nil))))))))) (de s!:eval_to_car_eq_safe (x) (and (or (eqcar x (quote cons)) (eqcar x ( quote list))) (not (null (cdr x))) (s!:eval_to_eq_safe (cadr x)))) (de s!:eval_to_car_eq_unsafe (x) (and (or (eqcar x (quote cons)) (eqcar x ( quote list))) (not (null (cdr x))) (s!:eval_to_eq_unsafe (cadr x)))) (de s!:alist_eq_safe (u) (or (atom u) (and (not (atom (car u))) (or (symbolp (caar u)) (eq!-safe (caar u))) (s!:alist_eq_safe (cdr u))))) (de s!:eval_to_alist_eq_safe (x) (or (null x) (and (eqcar x (quote quote)) ( s!:alist_eq_safe (cadr x))) (and (eqcar x (quote list)) (or (null (cdr x)) ( and (s!:eval_to_car_eq_safe (cadr x)) (s!:eval_to_alist_eq_safe (cons (quote list) (cddr x)))))) (and (eqcar x (quote cons)) (s!:eval_to_car_eq_safe (cadr x)) (s!:eval_to_alist_eq_safe (caddr x))))) (de s!:alist_eq_unsafe (u) (and (not (atom u)) (not (atom (car u))) (or (not (atom (caar u))) (and (not (symbolp (caar u))) (not (eq!-safe (caar u)))) ( s!:alist_eq_unsafe (cdr u))))) (de s!:eval_to_alist_eq_unsafe (x) (cond ((null x) nil) (t (cond ((eqcar x ( quote quote)) (s!:alist_eq_unsafe (cadr x))) (t (cond ((eqcar x (quote list)) (and (cdr x) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( s!:eval_to_alist_eq_unsafe (cons (quote list) (cddr x)))))) (t (cond ((eqcar x (quote cons)) (or (s!:eval_to_car_eq_unsafe (cadr x)) ( s!:eval_to_alist_eq_safe (caddr x)))) (t nil))))))))) (flag (quote (eq eqcar null not greaterp lessp geq leq minusp atom numberp consp)) (quote eq!-safe)) (cond ((not (eq!-safe 1)) (flag (quote (length plus minus difference times quotient plus2 times2 expt fix float)) (quote eq!-unsafe)))) (de s!:comequal (x env context) (cond ((or (s!:eval_to_eq_safe (cadr x)) ( s!:eval_to_eq_safe (caddr x))) (s!:comcall (cons (quote eq) (cdr x)) env context)) (t (s!:comcall x env context)))) (put (quote equal) (quote s!:compfn) (function s!:comequal)) (de s!:comeq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri))) ( princ "++++ EQ on number upgraded to EQUAL in ") (prin s!:current_function) ( princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comcall (cons (quote equal) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote eq) (quote s!:compfn) (function s!:comeq)) (de s!:comeqcar (x env context) (cond ((s!:eval_to_eq_unsafe (caddr x)) ( progn (cond ((neq (posn) 0) (terpri))) (princ "++++ EQCAR on number upgraded to EQUALCAR in ") (prin s!:current_function) ( princ " : ") (prin (caddr x)) (s!:comcall (cons (quote equalcar) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote eqcar) (quote s!:compfn) (function s!:comeqcar)) (de s!:comsublis (x env context) (cond ((s!:eval_to_alist_eq_safe (cadr x)) ( s!:comval (cons (quote subla) (cdr x)) env context)) (t (s!:comcall x env context)))) (put (quote sublis) (quote s!:compfn) (function s!:comsublis)) (de s!:comsubla (x env context) (cond ((s!:eval_to_alist_eq_unsafe (cadr x)) (progn (cond ((neq (posn) 0) (terpri))) (princ "++++ SUBLA on number upgraded to SUBLIS in ") (prin s!:current_function) ( princ " : ") (print (cadr x)) (s!:comval (cons (quote sublis) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote subla) (quote s!:compfn) (function s!:comsubla)) (de s!:comassoc (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x)) (s!:eval_to_alist_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval (cons (quote atsoc) (cdr x)) env context)) (t (cond ((equal (length x) 3) ( s!:comcall (cons (quote assoc!*!*) (cdr x)) env context)) (t (s!:comcall x env context)))))) (put (quote assoc) (quote s!:compfn) (function s!:comassoc)) (put (quote assoc!*!*) (quote s!:compfn) (function s!:comassoc)) (de s!:comatsoc (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_alist_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) (terpri)) ) (princ "++++ ATSOC on number upgraded to ASSOC in ") (prin s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comval (cons (quote assoc) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote atsoc) (quote s!:compfn) (function s!:comatsoc)) (de s!:commember (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) ) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( cons (quote memq) (cdr x)) env context)) (t (s!:comcall x env context)))) (put (quote member) (quote s!:compfn) (function s!:commember)) (put (quote member!*!*) (quote s!:compfn) (function s!:commember)) (de s!:commemq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( terpri))) (princ "++++ MEMQ on number upgraded to MEMBER in ") (prin s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comval (cons (quote member) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote memq) (quote s!:compfn) (function s!:commemq)) (de s!:comdelete (x env context) (cond ((and (or (s!:eval_to_eq_safe (cadr x) ) (s!:eval_to_list_all_eq_safe (caddr x))) (equal (length x) 3)) (s!:comval ( cons (quote deleq) (cdr x)) env context)) (t (s!:comcall x env context)))) (put (quote delete) (quote s!:compfn) (function s!:comdelete)) (de s!:comdeleq (x env context) (cond ((or (s!:eval_to_eq_unsafe (cadr x)) ( s!:eval_to_list_some_eq_unsafe (caddr x))) (progn (cond ((neq (posn) 0) ( terpri))) (princ "++++ DELEQ on number upgraded to DELETE in ") (prin s!:current_function) (princ " : ") (prin (cadr x)) (princ " ") (print (caddr x)) (s!:comval (cons (quote delete) (cdr x)) env context))) (t (s!:comcall x env context)))) (put (quote deleq) (quote s!:compfn) (function s!:comdeleq)) (de s!:commap (fnargs env context) (prog (carp fn fn1 args var avar moveon l1 r s closed) (setq fn (car fnargs)) (cond ((greaterp context 1) (progn (cond ((equal fn (quote mapcar)) (setq fn (quote mapc))) (t (cond ((equal fn (quote maplist)) (setq fn (quote map))))))))) (cond ((or (equal fn (quote mapc)) ( equal fn (quote mapcar)) (equal fn (quote mapcan))) (setq carp t))) (setq fnargs (cdr fnargs)) (cond ((atom fnargs) (error 0 "bad arguments to map function"))) (setq fn1 (cadr fnargs)) (prog nil lab1144 (cond ((null (or (eqcar fn1 (quote function)) (and (eqcar fn1 (quote quote)) (eqcar (cadr fn1) (quote lambda))))) (return nil))) (progn (setq fn1 (cadr fn1)) (setq closed t)) (go lab1144)) (setq args (car fnargs)) (setq l1 ( gensym)) (setq r (gensym)) (setq s (gensym)) (setq var (gensym)) (setq avar var) (cond (carp (setq avar (list (quote car) avar)))) (cond (closed (setq fn1 (list fn1 avar))) (t (setq fn1 (list (quote funcall) fn1 avar)))) (setq moveon (list (quote setq) var (list (quote cdr) var))) (cond ((or (equal fn ( quote map)) (equal fn (quote mapc))) (setq fn (sublis (list (cons (quote l1) l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( cons (quote moveon) moveon)) (quote (prog (var) (setq var args) l1 (cond (( not var) (return nil))) fn moveon (go l1)))))) (t (cond ((or (equal fn (quote maplist)) (equal fn (quote mapcar))) (setq fn (sublis (list (cons (quote l1) l1) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) ( cons (quote moveon) moveon) (cons (quote r) r)) (quote (prog (var r) (setq var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) moveon (go l1)))))) (t (setq fn (sublis (list (cons (quote l1) l1) (cons ( quote l2) (gensym)) (cons (quote var) var) (cons (quote fn) fn1) (cons (quote args) args) (cons (quote moveon) moveon) (cons (quote r) (gensym)) (cons ( quote s) (gensym))) (quote (prog (var r s) (setq var args) (setq r (setq s ( list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond (( not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))))))))) ( s!:comval fn env context))) (put (quote map) (quote s!:compfn) (function s!:commap)) (put (quote maplist) (quote s!:compfn) (function s!:commap)) (put (quote mapc) (quote s!:compfn) (function s!:commap)) (put (quote mapcar) (quote s!:compfn) (function s!:commap)) (put (quote mapcon) (quote s!:compfn) (function s!:commap)) (put (quote mapcan) (quote s!:compfn) (function s!:commap)) (de s!:nilargs (use) (cond ((null use) t) (t (cond ((or (equal (car use) ( quote nil)) (equal (car use) (quote (quote nil)))) (s!:nilargs (cdr use))) (t nil))))) (de s!:subargs (args use) (cond ((null use) t) (t (cond ((null args) ( s!:nilargs use)) (t (cond ((not (equal (car args) (car use))) nil) (t ( s!:subargs (cdr args) (cdr use))))))))) (fluid (quote (!*where_defined!*))) (de clear_source_database nil (progn (setq !*where_defined!* (mkhash 10 2 1.5 )) nil)) (de load_source_database (filename) (prog (a b) (clear_source_database) (setq a (open filename (quote input))) (cond ((null a) (return nil))) (setq a (rds a)) (prog nil lab1145 (cond ((null (setq b (read))) (return nil))) (puthash (car b) !*where_defined!* (cdr b)) (go lab1145)) (close (rds a)) (return nil) )) (de save_source_database (filename) (prog (a) (setq a (open filename (quote output))) (cond ((null a) (return nil))) (setq a (wrs a)) (prog (var1147) ( setq var1147 (sort (hashcontents !*where_defined!*) (function orderp))) lab1146 (cond ((null var1147) (return nil))) (prog (z) (setq z (car var1147)) (progn (prin z) (terpri))) (setq var1147 (cdr var1147)) (go lab1146)) (princ nil) (terpri) (wrs a) (setq !*where_defined!* nil) (return nil))) (de display_source_database nil (prog (w) (cond ((null !*where_defined!*) ( return nil))) (setq w (hashcontents !*where_defined!*)) (setq w (sort w ( function orderp))) (terpri) (prog (var1149) (setq var1149 w) lab1148 (cond (( null var1149) (return nil))) (prog (x) (setq x (car var1149)) (progn (princ ( car x)) (ttab 40) (prin (cdr x)) (terpri))) (setq var1149 (cdr var1149)) (go lab1148)))) (fluid (quote (s!:r2i_simple_recurse s!:r2i_cons_recurse))) (de s!:r2i (name args body) (prog (lab v b1 s!:r2i_simple_recurse s!:r2i_cons_recurse) (setq lab (gensym)) (setq v (list (gensym))) (setq b1 ( s!:r2i1 name args body lab v)) (cond (s!:r2i_cons_recurse (progn (setq b1 ( list (quote prog) v lab b1)) (return b1))) (t (cond (s!:r2i_simple_recurse ( progn (setq v (list (gensym))) (setq b1 (s!:r2i2 name args body lab v)) (setq b1 (list (quote prog) (cdr v) lab b1)) (return b1))) (t (return (s!:r2i3 name args body lab v)))))))) (de s!:r2i1 (name args body lab v) (cond ((or (null body) (equal body (quote (progn)))) (list (quote return) (list (quote nreverse) (car v)))) (t (cond (( and (eqcar body name) (equal (length (cdr body)) (length args))) (progn (setq s!:r2i_simple_recurse t) (cons (quote progn) (append (s!:r2isteps args (cdr body) v) (list (list (quote go) lab)))))) (t (cond ((eqcar body (quote cond)) (cons (quote cond) (s!:r2icond name args (cdr body) lab v))) (t (cond (( eqcar body (quote if)) (cons (quote if) (s!:r2iif name args (cdr body) lab v) )) (t (cond ((eqcar body (quote when)) (cons (quote when) (s!:r2iwhen name args (cdr body) lab v))) (t (cond ((eqcar body (quote cons)) (s!:r2icons name args (cadr body) (caddr body) lab v)) (t (cond ((or (eqcar body (quote progn )) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2iprogn name args ( cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i1 name args ( s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) (s!:r2i1 name args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) (list (quote nreverse) (car v) body))))))))))))))))))))) (de s!:r2iand (l) (cond ((null l) t) (t (cond ((null (cdr l)) (car l)) (t ( list (quote cond) (list (car l) (s!:r2iand (cdr l))))))))) (de s!:r2ior (l) (cond ((null l) nil) (t (cons (quote cond) (prog (var1151 var1152) (setq var1151 l) lab1150 (cond ((null var1151) (return (reversip var1152)))) (prog (x) (setq x (car var1151)) (setq var1152 (cons (list x) var1152))) (setq var1151 (cdr var1151)) (go lab1150)))))) (de s!:r2icond (name args b lab v) (cond ((null b) (list (list t (list (quote return) (list (quote nreverse) (car v)))))) (t (cond ((null (cdar b)) (progn (cond ((null (cdr v)) (rplacd v (list (gensym))))) (cons (list (list (quote setq) (cadr v) (caar b)) (list (quote return) (list (quote nreverse) (car v) (cadr v)))) (s!:r2icond name args (cdr b) lab v)))) (t (cond ((eqcar (car b) t) (list (cons t (s!:r2iprogn name args (cdar b) lab v)))) (t (cons (cons ( caar b) (s!:r2iprogn name args (cdar b) lab v)) (s!:r2icond name args (cdr b) lab v))))))))) (de s!:r2iif (name args b lab v) (cond ((null (cddr b)) (list (car b) ( s!:r2i1 name args (cadr b) lab v))) (t (list (car b) (s!:r2i1 name args (cadr b) lab v) (s!:r2i1 name args (caddr b) lab v))))) (de s!:r2iwhen (name args b lab v) (cons (car b) (s!:r2iprogn name args (cdr b) lab v))) (de s!:r2iprogn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i1 name args (car b) lab v))) (t (cons (car b) (s!:r2iprogn name args (cdr b) lab v) )))) (de s!:r2icons (name args a d lab v) (cond ((eqcar d (quote cons)) ( s!:r2icons2 name args a (cadr d) (caddr d) lab v)) (t (cond ((and (eqcar d name) (equal (length (cdr d)) (length args))) (progn (setq s!:r2i_cons_recurse t) (cons (quote progn) (cons (list (quote setq) (car v) ( list (quote cons) a (car v))) (append (s!:r2isteps args (cdr d) v) (list ( list (quote go) lab))))))) (t (list (quote return) (list (quote nreverse) ( car v) (list (quote cons) a d)))))))) (de s!:r2icons2 (name args a ad dd lab v) (cond ((and (eqcar dd name) (equal (length (cdr dd)) (length args))) (progn (setq s!:r2i_cons_recurse t) (cons ( quote progn) (cons (list (quote setq) (car v) (list (quote cons) a (car v))) (cons (list (quote setq) (car v) (list (quote cons) ad (car v))) (append ( s!:r2isteps args (cdr dd) v) (list (list (quote go) lab)))))))) (t (list ( quote return) (list (quote nreverse) (car v) (list (quote cons) a (list ( quote cons) ad dd))))))) (de s!:r2isteps (vars vals v) (cond ((null vars) (cond ((null vals) nil) (t ( error 0 "too many args in recursive call to self")))) (t (cond ((null vals) ( error 0 "not enough args in recursive call to self")) (t (cond ((equal (car vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v)) (t (cond (( s!:r2i_safestep (car vars) (cdr vars) (cdr vals)) (cons (list (quote setq) ( car vars) (car vals)) (s!:r2isteps (cdr vars) (cdr vals) v))) (t (prog (w) ( cond ((null (cdr v)) (rplacd v (list (gensym))))) (setq v (cdr v)) (setq w ( s!:r2isteps (cdr vars) (cdr vals) v)) (return (cons (list (quote setq) (car v ) (car vals)) (append w (list (list (quote setq) (car vars) (car v))))))))))) ))))) (de s!:r2i_safestep (x vars vals) (cond ((and (null vars) (null vals)) t) (t (cond ((s!:r2i_dependson (car vals) x) nil) (t (s!:r2i_safestep x (cdr vars) (cdr vals))))))) (de s!:r2i_dependson (e x) (cond ((equal e x) t) (t (cond ((or (atom e) ( eqcar e (quote quote))) nil) (t (cond ((not (atom (car e))) t) (t (cond (( flagp (car e) (quote s!:r2i_safe)) (s!:r2i_list_dependson (cdr e) x)) (t ( cond ((or (fluidp x) (globalp x)) t) (t (cond ((or (flagp (car e) (quote s!:r2i_unsafe)) (macro!-function (car e))) t) (t (s!:r2i_list_dependson (cdr e) x)))))))))))))) (flag (quote (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons ncons rcons acons list list2 list3 list!* add1 sub1 plus plus2 times times2 difference minus quotient append reverse nreverse null not assoc atsoc member memq subst sublis subla pair prog1 prog2 progn)) (quote s!:r2i_safe)) (flag (quote (cond if when case de defun dm defmacro prog let let!* flet and or)) (quote s!:r2i_unsafe)) (de s!:r2i_list_dependson (l x) (cond ((null l) nil) (t (cond (( s!:r2i_dependson (car l) x) t) (t (s!:r2i_list_dependson (cdr l) x)))))) (de s!:r2i2 (name args body lab v) (cond ((or (null body) (equal body (quote (progn)))) (list (quote return) nil)) (t (cond ((and (eqcar body name) (equal (length (cdr body)) (length args))) (progn (cons (quote progn) (append ( s!:r2isteps args (cdr body) v) (list (list (quote go) lab)))))) (t (cond (( eqcar body (quote cond)) (cons (quote cond) (s!:r2i2cond name args (cdr body) lab v))) (t (cond ((eqcar body (quote if)) (cons (quote if) (s!:r2i2if name args (cdr body) lab v))) (t (cond ((eqcar body (quote when)) (cons (quote when) (s!:r2i2when name args (cdr body) lab v))) (t (cond ((or (eqcar body ( quote progn)) (eqcar body (quote prog2))) (cons (quote progn) (s!:r2i2progn name args (cdr body) lab v))) (t (cond ((eqcar body (quote and)) (s!:r2i2 name args (s!:r2iand (cdr body)) lab v)) (t (cond ((eqcar body (quote or)) ( s!:r2i2 name args (s!:r2ior (cdr body)) lab v)) (t (list (quote return) body) ))))))))))))))))) (de s!:r2i2cond (name args b lab v) (cond ((null b) (list (list t (list ( quote return) nil)))) (t (cond ((null (cdar b)) (progn (cond ((null (cdr v)) (rplacd v (list (gensym))))) (cons (list (list (quote setq) (cadr v) (caar b) ) (list (quote return) (cadr v))) (s!:r2i2cond name args (cdr b) lab v)))) (t (cond ((eqcar (car b) t) (list (cons t (s!:r2i2progn name args (cdar b) lab v)))) (t (cons (cons (caar b) (s!:r2i2progn name args (cdar b) lab v)) ( s!:r2i2cond name args (cdr b) lab v))))))))) (de s!:r2i2if (name args b lab v) (cond ((null (cddr b)) (list (car b) ( s!:r2i2 name args (cadr b) lab v))) (t (list (car b) (s!:r2i2 name args (cadr b) lab v) (s!:r2i2 name args (caddr b) lab v))))) (de s!:r2i2when (name args b lab v) (cons (car b) (s!:r2i2progn name args ( cdr b) lab v))) (de s!:r2i2progn (name args b lab v) (cond ((null (cdr b)) (list (s!:r2i2 name args (car b) lab v))) (t (cons (car b) (s!:r2i2progn name args (cdr b) lab v))))) (de s!:r2i3 (name args body lab v) (prog (v v1 v2 lab1 lab2 lab3 w P Q g R) ( cond ((s!:any_fluid args) (return body))) (cond ((eqcar body (quote cond)) ( progn (cond ((not (setq w (cdr body))) (return body))) (setq P (car w)) (setq w (cdr w)) (cond ((null P) (return body))) (setq Q (cdr P)) (setq P (car P)) (cond ((or (null Q) (cdr Q)) (return body))) (setq Q (car Q)) (cond ((or ( null w) (cdr w)) (return body))) (setq w (car w)) (cond ((not (eqcar w t)) ( return body))) (setq w (cdr w)) (cond ((or (not w) (cdr w)) (return body))) ( setq w (car w)))) (t (cond ((eqcar body (quote if)) (progn (setq w (cdr body) ) (setq P (car w)) (setq w (cdr w)) (setq Q (car w)) (setq w (cdr w)) (cond ( (null w) (return body))) (setq w (car w)))) (t (return body))))) (cond ((or ( atom w) (atom (cdr w)) (atom (cddr w)) (cdddr w)) (return body))) (setq g ( car w)) (setq R (cadr w)) (setq w (caddr w)) (cond ((not (atom g)) (return body))) (cond ((member g (quote (and or progn prog1 prog2 cond if when))) ( return body))) (cond ((not (eqcar w name)) (return body))) (setq w (cdr w)) ( cond ((not (equal (length w) (length args))) (return body))) (setq v1 (gensym )) (setq v2 (gensym)) (setq v (list v2)) (setq lab1 (gensym)) (setq lab2 ( gensym)) (setq lab3 (gensym)) (setq w (s!:r2isteps args w v)) (setq w (list ( quote prog) (cons v1 v) lab1 (list (quote cond) (list P (list (quote go) lab2 ))) (list (quote setq) v1 (list (quote cons) R v1)) (cons (quote progn) w) ( list (quote go) lab1) lab2 (list (quote setq) v2 Q) lab3 (list (quote cond) ( list (list (quote null) v1) (list (quote return) v2))) (list (quote setq) v2 (list g (list (quote car) v1) v2)) (list (quote setq) v1 (list (quote cdr) v1 )) (list (quote go) lab3))) (return w))) (de s!:any_fluid (l) (cond ((null l) nil) (t (cond ((fluidp (car l)) t) (t ( s!:any_fluid (cdr l))))))) (de s!:compile1 (name args body s!:lexical_env) (prog (w aargs oargs oinit restarg svars nargs nopts env fluids s!:current_function s!:current_label s!:current_block s!:current_size s!:current_procedure s!:current_exitlab s!:current_proglabels s!:other_defs local_decs s!:has_closure s!:local_macros s!:recent_literals s!:a_reg_values w1 w2 s!:current_count s!:env_alist checksum) (cond (s!:lexical_env (setq checksum 0)) (t (setq checksum (md60 ( cons name (cons args body)))))) (setq s!:current_function name) (setq s!:current_count 0) (cond (!*where_defined!* (progn (setq w name) (puthash w !*where_defined!* (where!-was!-that))))) (setq body (s!:find_local_decs body nil)) (setq local_decs (car body)) (setq body (cdr body)) (cond ((atom body) (setq body nil)) (t (cond ((null (cdr body)) (setq body (car body))) (t (setq body (cons (quote progn) body)))))) (setq nargs (setq nopts 0)) (prog nil lab1153 (cond ((null (and args (not (eqcar args (quote !&optional))) (not ( eqcar args (quote !&rest))))) (return nil))) (progn (cond ((or (equal (car args) (quote !&key)) (equal (car args) (quote !&aux))) (error 0 "&key/&aux")) ) (setq aargs (cons (car args) aargs)) (setq nargs (plus nargs 1)) (setq args (cdr args))) (go lab1153)) (cond ((eqcar args (quote !&optional)) (progn ( setq args (cdr args)) (prog nil lab1155 (cond ((null (and args (not (eqcar args (quote !&rest))))) (return nil))) (progn (cond ((or (equal (car args) ( quote !&key)) (equal (car args) (quote !&aux))) (error 0 "&key/&aux"))) (setq w (car args)) (prog nil lab1154 (cond ((null (and (not (atom w)) (or (atom ( cdr w)) (equal (cdr w) (quote (nil)))))) (return nil))) (setq w (car w)) (go lab1154)) (setq args (cdr args)) (setq oargs (cons w oargs)) (setq nopts ( plus nopts 1)) (cond ((atom w) (setq aargs (cons w aargs))) (t (progn (setq oinit t) (setq aargs (cons (car w) aargs)) (cond ((not (atom (cddr w))) (setq svars (cons (caddr w) svars)))))))) (go lab1155))))) (cond ((eqcar args ( quote !&rest)) (progn (setq w (cadr args)) (setq aargs (cons w aargs)) (setq restarg w) (setq args (cddr args)) (cond (args (error 0 "&rest arg not at end")))))) (setq args (reverse aargs)) (setq oargs (reverse oargs)) (prog (var1157) (setq var1157 (append svars args)) lab1156 (cond (( null var1157) (return nil))) (prog (v) (setq v (car var1157)) (progn (cond (( globalp v) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++++ global ") (prin v) (princ " converted to fluid") (terpri)))) ( unglobal (list v)) (fluid (list v))))))) (setq var1157 (cdr var1157)) (go lab1156)) (cond (oinit (return (s!:compile2 name nargs nopts args oargs restarg body local_decs checksum)))) (setq w nil) (prog (var1159) (setq var1159 args) lab1158 (cond ((null var1159) (return nil))) (prog (v) (setq v (car var1159)) (setq w (s!:instate_local_decs v local_decs w))) (setq var1159 (cdr var1159)) (go lab1158)) (cond ((and !*r2i (null oargs) (null restarg)) (setq body (s!:r2i name args body)))) (prog (v) (setq v args) lab1160 (cond ( (null v) (return nil))) (progn (cond ((fluidp (car v)) (prog (g) (setq g ( gensym)) (setq fluids (cons (cons (car v) g) fluids)) (rplaca v g))))) (setq v (cdr v)) (go lab1160)) (cond (fluids (progn (setq body (list (list (quote return) body))) (prog (var1162) (setq var1162 fluids) lab1161 (cond ((null var1162) (return nil))) (prog (v) (setq v (car var1162)) (setq body (cons ( list (quote setq) (car v) (cdr v)) body))) (setq var1162 (cdr var1162)) (go lab1161)) (setq body (cons (quote prog) (cons (prog (var1164 var1165) (setq var1164 fluids) lab1163 (cond ((null var1164) (return (reversip var1165)))) ( prog (v) (setq v (car var1164)) (setq var1165 (cons (car v) var1165))) (setq var1164 (cdr var1164)) (go lab1163)) body)))))) (setq env (cons (mkhash 10 2 1.5) (reverse args))) (puthash name (car env) (cons 10000000 nil)) (setq w ( s!:residual_local_decs local_decs w)) (s!:start_procedure nargs nopts restarg ) (setq w1 body) more (cond ((atom w1) nil) (t (cond ((and (equal (car w1) ( quote block)) (equal (length w1) 3)) (progn (setq w1 (caddr w1)) (go more))) (t (cond ((and (equal (car w1) (quote progn)) (equal (length w1) 2)) (progn ( setq w1 (cadr w1)) (go more))) (t (cond ((and (atom (setq w2 (car w1))) (setq w2 (get w2 (quote s!:newname)))) (progn (setq w1 (cons w2 (cdr w1))) (go more))) (t (cond ((and (atom (setq w2 (car w1))) (setq w2 (macro!-function w2 ))) (progn (setq w1 (funcall w2 w1)) (go more)))))))))))) (cond ((not (equal (setq w2 (s!:improve w1)) w1)) (progn (setq w1 w2) (go more)))) (cond ((and ( not (atom w1)) (atom (car w1)) (not (special!-form!-p (car w1))) (s!:subargs args (cdr w1)) (leq nargs 3) (equal nopts 0) (not restarg) (leq (length (cdr w1)) nargs)) (progn (s!:cancel_local_decs w) (cond (restarg (setq nopts (plus nopts 512)))) (setq nopts (plus nopts (times 1024 (length w1)))) (setq nargs (plus nargs (times 256 nopts))) (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) (princ "+++ ") (prin name) (princ " compiled as link to ") (princ (car w1)) (terpri)))) (return (cons (cons name (cons nargs (cons nil (car w1) ))) s!:other_defs))))) (s!:comval body env 0) (s!:cancel_local_decs w) (cond (restarg (setq nopts (plus nopts 512)))) (setq nargs (plus nargs (times 256 nopts))) (return (cons (cons name (cons nargs (s!:endprocedure name env checksum))) s!:other_defs)))) (de s!:compile2 (name nargs nopts args oargs restarg body local_decs checksum ) (prog (fluids env penv g v init atend w) (prog (var1167) (setq var1167 args ) lab1166 (cond ((null var1167) (return nil))) (prog (v) (setq v (car var1167 )) (progn (setq env (cons 0 env)) (setq penv (cons env penv)))) (setq var1167 (cdr var1167)) (go lab1166)) (setq env (cons (mkhash 10 2 1.5) env)) ( puthash name (car env) (cons 10000000 nil)) (setq penv (reversip penv)) (cond (restarg (setq oargs (append oargs (quote (0)))))) (prog (i) (setq i 1) lab1168 (cond ((minusp (times 1 (difference nargs i))) (return nil))) (setq oargs (cons 0 oargs)) (setq i (plus i 1)) (go lab1168)) (s!:start_procedure nargs nopts restarg) (prog nil lab1169 (cond ((null args) (return nil))) ( progn (setq v (car args)) (setq init (car oargs)) (cond ((equal init 0) ( progn (setq w (s!:instate_local_decs v local_decs w)) (cond ((fluidp v) ( progn (setq g (gensym)) (rplaca (car penv) g) (s!:outopcode1lit (quote FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr env))))) (setq atend (cons (quote FREERSTR) atend)) (s!:comval (list (quote setq) v g) env 2))) (t (rplaca (car penv) v))))) (t (prog (ival sp l1 l2) ( cond ((not (atom init)) (progn (setq init (cdr init)) (setq ival (car init)) (cond ((not (atom (cdr init))) (setq sp (cadr init))))))) (setq l1 (gensym)) (setq g (gensym)) (rplaca (car penv) g) (cond ((and (null ival) (null sp)) ( s!:comval (list (quote setq) g (list (quote spid!-to!-nil) g)) env 1)) (t ( progn (s!:jumpif nil (list (quote is!-spid) g) env l1) (s!:comval (list ( quote setq) g ival) env 1) (cond (sp (progn (cond ((fluidp sp) (progn ( s!:outopcode1lit (quote FREEBIND) (s!:vecof (list sp)) env) (s!:outjump ( quote JUMP) (setq l2 (gensym))) (s!:set_label l1) (s!:outopcode1lit (quote FREEBIND) (s!:vecof (list sp)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr env))))) (s!:comval (list (quote setq) sp t) env 1) (s!:set_label l2) (setq atend (cons (quote FREERSTR) atend)))) (t (progn (s!:outopcode0 (quote PUSHNIL) (quote (PUSHNIL))) (s!:outjump (quote JUMP) (setq l2 (gensym))) ( s!:set_label l1) (s!:loadliteral t env) (s!:outopcode0 (quote PUSH) (quote ( PUSH))) (s!:set_label l2) (rplacd env (cons sp (cdr env))) (setq atend (cons (quote LOSE) atend))))))) (t (s!:set_label l1)))))) (setq w ( s!:instate_local_decs v local_decs w)) (cond ((fluidp v) (progn ( s!:outopcode1lit (quote FREEBIND) (s!:vecof (list v)) env) (rplacd env (cons 3 (cons 0 (cons 0 (cdr env))))) (s!:comval (list (quote setq) v g) env 1) ( setq atend (cons (quote FREERSTR) atend)))) (t (rplaca (car penv) v)))))) ( setq args (cdr args)) (setq oargs (cdr oargs)) (setq penv (cdr penv))) (go lab1169)) (setq w (s!:residual_local_decs local_decs w)) (s!:comval body env 0) (prog nil lab1170 (cond ((null atend) (return nil))) (progn (s!:outopcode0 (car atend) (list (car atend))) (setq atend (cdr atend))) (go lab1170)) ( s!:cancel_local_decs w) (setq nopts (plus nopts 256)) (cond (restarg (setq nopts (plus nopts 512)))) (setq nargs (plus nargs (times 256 nopts))) (return (cons (cons name (cons nargs (s!:endprocedure name env checksum))) s!:other_defs)))) (de compile!-all nil (prog (var1172) (setq var1172 (oblist)) lab1171 (cond (( null var1172) (return nil))) (prog (x) (setq x (car var1172)) (prog (w) (setq w (getd x)) (cond ((and (or (eqcar w (quote expr)) (eqcar w (quote macro))) (eqcar (cdr w) (quote lambda))) (progn (princ "Compile: ") (prin x) (terpri) (errorset (list (quote compile) (mkquote (list x))) t t)))))) (setq var1172 ( cdr var1172)) (go lab1171))) (flag (quote (rds deflist flag fluid global remprop remflag unfluid unglobal dm defmacro carcheck faslend c_end)) (quote eval)) (flag (quote (rds)) (quote ignore)) (fluid (quote (!*backtrace))) (de s!:fasl_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote ( read)) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond ((equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand u)))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote faslend)) (return ( apply (quote faslend) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:fasl_supervisor) ( princ "End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (s!:fslout0 u))))))) (go top))) (de s!:fslout0 (u) (s!:fslout1 u nil)) (de s!:fslout1 (u loadonly) (prog (w) (cond ((not (atom u)) (setq u ( macroexpand u)))) (cond ((atom u) (return nil)) (t (cond ((eqcar u (quote progn)) (progn (prog (var1174) (setq var1174 (cdr u)) lab1173 (cond ((null var1174) (return nil))) (prog (v) (setq v (car var1174)) (s!:fslout1 v loadonly)) (setq var1174 (cdr var1174)) (go lab1173)) (return nil))) (t (cond ((eqcar u (quote eval!-when)) (return (prog nil (setq w (cadr u)) (setq u ( cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) (not loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:fslout1 u t))) (return nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) ( quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond ( (not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( s!:fasl_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w))) ) (t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ( !*nocompile (progn (cond ((and (not (eqcar u (quote faslend))) (not (eqcar u (quote carcheck)))) (write!-module u))))) (t (cond ((or (eqcar u (quote de)) (eqcar u (quote defun))) (progn (cond ((and !*native_code (not (memq (quote win64) lispsystem!*))) (progn (cond ((c!:valid_fndef (caddr u) (cdddr u)) ( prog (pending_functions u1) (c!:ccmpout1a u) (prog nil lab1175 (cond ((null pending_functions) (return nil))) (progn (setq u1 (car pending_functions)) ( setq pending_functions (cdr pending_functions)) (s!:fslout0 u1)) (go lab1175) ))) (t (progn (princ "+++ ") (prin (cadr u)) (printc " can not be compiled into native code"))))))) (setq u (cdr u)) (cond ((and ( setq w (get (car u) (quote c!-version))) (equal w (md60 (cons (car u) (cons ( cadr u) (s!:fully_macroexpand_list (cddr u))))))) (progn (princ "+++ ") (prin (car u)) (printc " not compiled (C version available)") (write!-module (list (quote restore!-c!-code) (mkquote (car u)))))) (t (cond ((flagp (car u) ( quote lose)) (progn (princ "+++ ") (prin (car u)) (printc " not compiled (LOSE flag)"))) (t (progn (cond ((setq w (get (car u) (quote c!-version))) (progn (princ "+++ ") (prin (car u)) (princ " reports C version with checksum ") (print w) (print "+++ differing from this version:") (setq w (cons (car u) (cons (cadr u) ( s!:fully_macroexpand_list (cddr u))))) (princ "::: ") (prettyprint w) (princ "+++ which has checksum ") (print (md60 w))))) (prog (var1177) (setq var1177 (s!:compile1 (car u) (cadr u) (cddr u) nil)) lab1176 (cond ((null var1177) ( return nil))) (prog (p) (setq p (car var1177)) (s!:fslout2 p u)) (setq var1177 (cdr var1177)) (go lab1176))))))))) (t (cond ((or (eqcar u (quote dm) ) (eqcar u (quote defmacro))) (prog (g) (setq g (hashtagged!-name (cadr u) ( cddr u))) (setq u (cdr u)) (cond ((flagp (car u) (quote lose)) (progn (princ "+++ ") (prin (car u)) (printc " not compiled (LOSE flag)") (return nil)))) ( setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons (car w) (cons ( quote !&optional) (cons (gensym) nil)))))) (prog (var1179) (setq var1179 ( s!:compile1 g w (cddr u) nil)) lab1178 (cond ((null var1179) (return nil))) ( prog (p) (setq p (car var1179)) (s!:fslout2 p u)) (setq var1179 (cdr var1179) ) (go lab1178)) (write!-module (list (quote dm) (car u) (quote (u !&optional e)) (list g (quote u) (quote e)))))) (t (cond ((eqcar u (quote putd)) (prog ( a1 a2 a3) (setq a1 (cadr u)) (setq a2 (caddr u)) (setq a3 (cadddr u)) (cond ( (and (eqcar a1 (quote quote)) (or (equal a2 (quote (quote expr))) (equal a2 ( quote (quote macro)))) (or (eqcar a3 (quote quote)) (eqcar a3 (quote function ))) (eqcar (cadr a3) (quote lambda))) (progn (setq a1 (cadr a1)) (setq a2 ( cadr a2)) (setq a3 (cadr a3)) (setq u (cons (cond ((equal a2 (quote expr)) ( quote de)) (t (quote dm))) (cons a1 (cdr a3)))) (s!:fslout1 u loadonly))) (t (write!-module u))))) (t (cond ((and (not (eqcar u (quote faslend))) (not ( eqcar u (quote carcheck)))) (write!-module u))))))))))))))) (de s!:fslout2 (p u) (prog (name nargs code env w) (setq name (car p)) (setq nargs (cadr p)) (setq code (caddr p)) (setq env (cdddr p)) (cond ((and !*savedef (equal name (car u))) (progn (define!-in!-module (minus 1)) ( write!-module (cons (quote lambda) (cons (cadr u) (s!:fully_macroexpand_list (cddr u)))))))) (setq w (irightshift nargs 18)) (setq nargs (logand nargs 262143)) (cond ((not (equal w 0)) (setq code (difference w 1)))) ( define!-in!-module nargs) (write!-module name) (write!-module code) ( write!-module env))) (remprop (quote faslend) (quote stat)) (de faslend nil (prog (copysrc copydest) (cond ((null s!:faslmod_name) ( return nil))) (princ "Completed FASL files for ") (print (car s!:faslmod_name )) (cond ((and !*native_code (not (memq (quote win64) lispsystem!*))) (prog ( cmnd w w1 obj deff) (setq w (C!-end1 nil)) (close C_file) (setq cmnd (append (explodec s!:native_file) (quote (!")))) (cond ((memq (quote win32) lispsystem!*) (setq obj "dll")) (t (setq obj "so"))) (setq obj (tmpnam obj)) (cond ((memq (quote win32) lispsystem!*) (prog (nn) (setq nn (car s!:faslmod_name)) (setq nn (list!-to!-string (prog (var1181 var1182) (setq var1181 (explodec nn)) lab1180 (cond ((null var1181) (return (reversip var1182)))) (prog (c) (setq c (car var1181)) (setq var1182 (cons (cond (( equal c (quote !-)) (quote !_)) (t c)) var1182))) (setq var1181 (cdr var1181) ) (go lab1180)))) (setq deff (tmpnam "def")) (setq w1 (open deff (quote output))) (setq w1 (wrs w1)) (princ "LIBRARY ") (princ (car s!:faslmod_name)) (printc ".dll") (printc "EXPORTS") (printc " init") (princ " ") (princ nn) ( printc "_setup") (printc "IMPORTS") (print!-imports) (close (wrs w1)) (setq cmnd (append (explodec deff) (cons (quote ! ) cmnd)))))) (setq cmnd (append ( explodec obj) (cons (quote ! ) cmnd))) (setq cmnd (append (explodec " -o ") cmnd)) (prog (var1184) (setq var1184 (reverse (cdr (assoc (quote compiler!-command) lispsystem!*)))) lab1183 (cond ((null var1184) (return nil ))) (prog (x) (setq x (car var1184)) (setq cmnd (append (explodec x) (cons ( quote ! ) cmnd)))) (setq var1184 (cdr var1184)) (go lab1183)) (setq cmnd ( compress (cons (quote !") cmnd))) (print cmnd) (cond ((not (zerop ( silent!-system cmnd))) (progn (princ "+++ C compilation for ") (prin (car s!:faslmod_name)) (printc " failed"))) (t (progn (cond (!*strip_native (progn (setq cmnd (compress (cons (quote !") (append (explodec "strip ") (append ( explodec obj) (quote (!"))))))) (print cmnd) (silent!-system cmnd)))) (setq copysrc obj) (setq copydest (list!-to!-string (append (explodec (car s!:faslmod_name)) (cons (quote !.) (explodec (cdr (assoc (quote linker) lispsystem!*))))))) (cond ((not !*save_native) (progn (delete!-file s!:native_file) (cond ((memq (quote win32) lispsystem!*) (delete!-file deff)) )))) (write!-module (list (quote instate!-c!-code) (mkquote (car s!:faslmod_name)) (mkquote w))))))))) (start!-module nil) (cond (copysrc ( progn (copy!-native copysrc copydest) (cond ((not !*save_native) ( delete!-file copysrc)))))) (setq dfprint!* s!:dfprintsave) (setq !*defn nil) (setq !*comp (cdr s!:faslmod_name)) (setq s!:faslmod_name nil) (return nil))) (put (quote faslend) (quote stat) (quote endstat)) (de s!:file (s) (prog (r) (setq s (reverse (explodec s))) (prog nil lab1185 ( cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( return nil))) (progn (setq r (cons (car s) r)) (setq s (cdr s))) (go lab1185) ) (return (list!-to!-string r)))) (de s!:trim!.c (s) (prog (r) (setq s (reverse (explodec s))) (cond ((eqcar s (quote c)) (progn (setq s (cdr s)) (cond ((eqcar s (quote !.)) (setq s (cdr s ))))))) (return (list!-to!-string (reverse s))))) (de s!:dir (s) (prog nil (setq s (reverse (explodec s))) (prog nil lab1186 ( cond ((null (and s (not (or (eqcar s (quote !/)) (eqcar s (quote !\)))))) ( return nil))) (setq s (cdr s)) (go lab1186)) (cond (s (setq s (cdr s)))) ( cond ((null s) (return ".")) (t (return (list!-to!-string (reverse s))))))) (de faslout (u) (prog nil (terpri) (princ "FASLOUT ") (prin u) (princ ": IN files; or type in expressions") (terpri) (princ "When all done, execute FASLEND;") (terpri) (cond ((not (atom u)) (setq u ( car u)))) (cond ((not (start!-module u)) (progn (cond ((neq (posn) 0) (terpri ))) (princ "+++ Failed to open FASL output file") (terpri) (return nil)))) ( cond ((and !*native_code (not (memq (quote win64) lispsystem!*))) (progn ( setq s!:native_file (tmpnam "c")) (c!:ccompilestart (s!:trim!.c (s!:file s!:native_file)) u (s!:dir s!:native_file) t)))) (setq s!:faslmod_name (cons u !*comp)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* (quote s!:fslout0) ) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote begin)) (return nil)) ) (s!:fasl_supervisor))) (put (quote faslout) (quote stat) (quote rlis)) (de s!:c_supervisor nil (prog (u w !*echo) top (setq u (errorset (quote (read )) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( equal u !$eof!$) (return nil))) (cond ((not (atom u)) (setq u (macroexpand u) ))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote c_end)) (return ( apply (quote c_end) nil))) (t (cond ((eqcar u (quote rdf)) (progn (setq w ( open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (terpri) (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) (s!:c_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w)))) (t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (s!:cout0 u))))))) (go top) )) (de s!:cout0 (u) (s!:cout1 u nil)) (de s!:cout1 (u loadonly) (prog (s!:into_c) (setq s!:into_c t) (cond ((not ( atom u)) (setq u (macroexpand u)))) (cond ((atom u) (return nil)) (t (cond (( eqcar u (quote progn)) (progn (prog (var1188) (setq var1188 (cdr u)) lab1187 (cond ((null var1188) (return nil))) (prog (v) (setq v (car var1188)) ( s!:cout1 v loadonly)) (setq var1188 (cdr var1188)) (go lab1187)) (return nil) )) (t (cond ((eqcar u (quote eval!-when)) (return (prog (w) (setq w (cadr u)) (setq u (cons (quote progn) (cddr u))) (cond ((and (memq (quote compile) w) (not loadonly)) (eval u))) (cond ((memq (quote load) w) (s!:cout1 u t))) ( return nil)))) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) (quote setq)) (not (atom (caddr u))) (flagp (caaddr u) (quote eval)))) (cond ((not loadonly) (errorset u t !*backtrace))))))))))) (cond ((eqcar u (quote rdf)) (prog (w) (setq w (open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (princ "Reading file ") (prin u) (terpri) (setq w (rds w)) ( s!:c_supervisor) (princ "End of file ") (prin u) (terpri) (close (rds w)))) ( t (progn (princ "Failed to open file ") (prin u) (terpri)))))) (t (cond ((or (eqcar u (quote de)) (eqcar u (quote defun))) (prog (w) (setq u (cdr u)) ( setq w (s!:compile1 (car u) (cadr u) (cddr u) nil)) (prog (var1190) (setq var1190 w) lab1189 (cond ((null var1190) (return nil))) (prog (p) (setq p ( car var1190)) (s!:cgen (car p) (cadr p) (caddr p) (cdddr p))) (setq var1190 ( cdr var1190)) (go lab1189)))) (t (cond ((or (eqcar u (quote dm)) (eqcar u ( quote defmacro))) (prog (w g) (setq g (hashtagged!-name (cadr u) (cddr u))) ( setq u (cdr u)) (setq w (cadr u)) (cond ((and w (null (cdr w))) (setq w (cons (car w) (cons (quote !&optional) (cons (gensym) nil)))))) (setq w ( s!:compile1 g w (cddr u) nil)) (prog (var1192) (setq var1192 w) lab1191 (cond ((null var1192) (return nil))) (prog (p) (setq p (car var1192)) (s!:cgen ( car p) (cadr p) (caddr p) (cdddr p))) (setq var1192 (cdr var1192)) (go lab1191)) (s!:cinit (list (quote dm) (car u) (quote (u !&optional e)) (list g (quote u) (quote e)))))) (t (cond ((eqcar u (quote putd)) (prog (a1 a2 a3) ( setq a1 (cadr u)) (setq a2 (caddr u)) (setq a3 (cadddr u)) (cond ((and (eqcar a1 (quote quote)) (or (equal a2 (quote (quote expr))) (equal a2 (quote ( quote macro)))) (or (eqcar a3 (quote quote)) (eqcar a3 (quote function))) ( eqcar (cadr a3) (quote lambda))) (progn (setq a1 (cadr a1)) (setq a2 (cadr a2 )) (setq a3 (cadr a3)) (setq u (cons (cond ((equal a2 (quote expr)) (quote de )) (t (quote dm))) (cons a1 (cdr a3)))) (s!:cout1 u loadonly))) (t (s!:cinit u))))) (t (cond ((and (not (eqcar u (quote c_end))) (not (eqcar u (quote carcheck)))) (s!:cinit u))))))))))))) (fluid (quote (s!:cmod_name))) (de c_end nil (prog nil (cond ((null s!:cmod_name) (return nil))) (s!:cend) ( setq dfprint!* s!:dfprintsave) (setq !*defn nil) (setq !*comp (cdr s!:cmod_name)) (setq s!:cmod_name nil) (return nil))) (put (quote c_end) (quote stat) (quote endstat)) (de c_out (u) (prog nil (terpri) (princ "C_OUT ") (prin u) (princ ": IN files; or type in expressions") (terpri) (princ "When all done, execute C_END;") (terpri) (cond ((not (atom u)) (setq u (car u)))) (cond ((null (s!:cstart u)) (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++ Failed to open C output file") (terpri) (return nil)))) (setq s!:cmod_name (cons u !*comp)) (setq s!:dfprintsave dfprint!*) (setq dfprint!* (quote s!:cout0)) (setq !*defn t) (setq !*comp nil) (cond ((getd (quote begin)) (return nil))) (s!:c_supervisor))) (put (quote c_out) (quote stat) (quote rlis)) (de s!:compile!-file!* (fromfile !&optional tofile verbose !*pwrds) (prog ( !*comp w save) (cond ((null tofile) (setq tofile fromfile))) (cond (verbose ( progn (cond ((neq (posn) 0) (terpri))) (princ "+++ Compiling file ") (prin fromfile) (terpri) (setq save (verbos nil)) (verbos (ilogand save 4))))) ( cond ((not (start!-module tofile)) (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++ Failed to open FASL output file") (terpri) (cond (save (verbos save))) (return nil)))) (setq w (open fromfile (quote input))) (cond (w ( progn (setq w (rds w)) (s!:fasl_supervisor) (close (rds w)))) (t (progn ( princ "Failed to open file ") (prin fromfile) (terpri)))) (cond (save (verbos save))) (start!-module nil) (cond (verbose (progn (cond ((neq (posn) 0) ( terpri))) (princ "+++ Compilation complete") (terpri)))) (return t))) (de compile!-file!* (fromfile !&optional tofile) (s!:compile!-file!* fromfile tofile t t)) (de compd (name type defn) (prog (g !*comp) (setq !*comp t) (cond ((eqcar defn (quote lambda)) (progn (setq g (dated!-name type)) ( symbol!-set!-definition g defn) (compile (list g)) (setq defn g)))) (put name type defn) (return name))) (de s!:compile0 (name) (prog (w args defn) (setq defn (getd name)) (cond (( and (eqcar defn (quote macro)) (eqcar (cdr defn) (quote lambda))) (prog ( !*comp lx vx bx) (setq lx (cdr defn)) (cond ((not (or (and (equal (length lx) 3) (not (atom (setq bx (caddr lx)))) (equal (cadr lx) (cdr bx))) (and (equal (length lx) 3) (not (atom (setq bx (caddr lx)))) (not (atom (cadr lx))) ( eqcar (cdadr lx) (quote !&optional)) (not (atom (setq bx (cdr bx)))) (equal ( caadr lx) (car bx)) (equal (cddadr lx) (cdr bx))))) (progn (setq w ( hashtagged!-name name defn)) (symbol!-set!-definition w (cdr defn)) ( s!:compile0 w) (cond ((equal 1 (length (cadr lx))) (symbol!-set!-env name ( list (quote (u !&optional env)) (list w (quote u))))) (t (symbol!-set!-env name (list (quote (u !&optional env)) (list w (quote u) (quote env))))))))))) (t (cond ((or (not (eqcar defn (quote expr))) (not (eqcar (cdr defn) (quote lambda)))) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++ ") (prin name) (princ " not compilable") (terpri)))))) (t (progn ( setq args (cddr defn)) (setq defn (cdr args)) (setq args (car args)) (cond (( stringp args) (progn (cond (!*pwrds (progn (cond ((neq (posn) 0) (terpri))) ( princ "+++ ") (prin name) (princ " was already compiled") (terpri)))))) (t ( progn (cond (!*savedef (put name (quote !*savedef) (cons (quote lambda) (cons args (s!:fully_macroexpand_list defn)))))) (setq w (s!:compile1 name args defn nil)) (prog (var1194) (setq var1194 w) lab1193 (cond ((null var1194) ( return nil))) (prog (p) (setq p (car var1194)) (symbol!-set!-definition (car p) (cdr p))) (setq var1194 (cdr var1194)) (go lab1193)))))))))))) (de s!:fully_macroexpand_list (l) (cond ((atom l) l) (t (prog (var1196 var1197) (setq var1196 l) lab1195 (cond ((null var1196) (return (reversip var1197)))) (prog (u) (setq u (car var1196)) (setq var1197 (cons ( s!:fully_macroexpand u) var1197))) (setq var1196 (cdr var1196)) (go lab1195)) ))) (de s!:fully_macroexpand (x) (prog (helper) (cond ((or (atom x) (eqcar x ( quote quote))) (return x)) (t (cond ((eqcar (car x) (quote lambda)) (return ( cons (cons (quote lambda) (cons (cadar x) (s!:fully_macroexpand_list (cddar x )))) (s!:fully_macroexpand_list (cdr x))))) (t (cond ((setq helper (get (car x) (quote s!:newname))) (return (s!:fully_macroexpand (cons helper (cdr x)))) ) (t (cond ((setq helper (get (car x) (quote s!:expandfn))) (return (funcall helper x))) (t (cond ((setq helper (macro!-function (car x))) (return ( s!:fully_macroexpand (funcall helper x)))) (t (return (cons (car x) ( s!:fully_macroexpand_list (cdr x)))))))))))))))) (de s!:expandfunction (u) u) (de s!:expandflet (u) (cons (car u) (cons (prog (var1199 var1200) (setq var1199 (cadr u)) lab1198 (cond ((null var1199) (return (reversip var1200)))) (prog (b) (setq b (car var1199)) (setq var1200 (cons (s!:expandfletvars b) var1200))) (setq var1199 (cdr var1199)) (go lab1198)) ( s!:fully_macroexpand_list (cddr u))))) (de s!:expandfletvars (b) (cons (car b) (cons (cadr b) ( s!:fully_macroexpand_list (cddr b))))) (de s!:expandlabels (u) (s!:expandflet u)) (de s!:expandmacrolet (u) (s!:expandflet u)) (de s!:expandprog (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list (cddr u))))) (de s!:expandtagbody (u) (s!:fully_macroexpand_list u)) (de s!:expandprogv (u) (cons (car u) (cons (cadr u) (cons (caddr u) ( s!:fully_macroexpand_list (cadddr u)))))) (de s!:expandblock (u) (cons (car u) (cons (cadr u) ( s!:fully_macroexpand_list (cddr u))))) (de s!:expanddeclare (u) u) (de s!:expandlet (u) (cons (car u) (cons (prog (var1202 var1203) (setq var1202 (cadr u)) lab1201 (cond ((null var1202) (return (reversip var1203)))) (prog (x) (setq x (car var1202)) (setq var1203 (cons ( s!:fully_macroexpand_list x) var1203))) (setq var1202 (cdr var1202)) (go lab1201)) (s!:fully_macroexpand_list (cddr u))))) (de s!:expandlet!* (u) (s!:expandlet u)) (de s!:expandgo (u) u) (de s!:expandreturn!-from (u) (cons (car u) (cons (cadr u) ( s!:fully_macroexpand_list (cddr u))))) (de s!:expandcond (u) (cons (car u) (prog (var1205 var1206) (setq var1205 ( cdr u)) lab1204 (cond ((null var1205) (return (reversip var1206)))) (prog (x) (setq x (car var1205)) (setq var1206 (cons (s!:fully_macroexpand_list x) var1206))) (setq var1205 (cdr var1205)) (go lab1204)))) (de s!:expandcase (u) (cons (car u) (cons (s!:fully_macroexpand (cadr u)) ( prog (var1208 var1209) (setq var1208 (cddr u)) lab1207 (cond ((null var1208) (return (reversip var1209)))) (prog (x) (setq x (car var1208)) (setq var1209 (cons (cons (car x) (s!:fully_macroexpand_list (cdr x))) var1209))) (setq var1208 (cdr var1208)) (go lab1207))))) (de s!:expandeval!-when (u) (cons (car u) (cons (cadr u) ( s!:fully_macroexpand_list (cddr u))))) (de s!:expandthe (u) (cons (car u) (cons (cadr u) (s!:fully_macroexpand_list (cddr u))))) (de s!:expandmv!-call (u) (cons (car u) (cons (cadr u) ( s!:fully_macroexpand_list (cddr u))))) (put (quote function) (quote s!:expandfn) (function s!:expandfunction)) (put (quote flet) (quote s!:expandfn) (function s!:expandflet)) (put (quote labels) (quote s!:expandfn) (function s!:expandlabels)) (put (quote macrolet) (quote s!:expandfn) (function s!:expandmacrolet)) (put (quote prog) (quote s!:expandfn) (function s!:expandprog)) (put (quote tagbody) (quote s!:expandfn) (function s!:expandtagbody)) (put (quote progv) (quote s!:expandfn) (function s!:expandprogv)) (put (quote !~block) (quote s!:expandfn) (function s!:expandblock)) (put (quote declare) (quote s!:expandfn) (function s!:expanddeclare)) (put (quote !~let) (quote s!:expandfn) (function s!:expandlet)) (put (quote let!*) (quote s!:expandfn) (function s!:expandlet!*)) (put (quote go) (quote s!:expandfn) (function s!:expandgo)) (put (quote return!-from) (quote s!:expandfn) (function s!:expandreturn!-from )) (put (quote cond) (quote s!:expandfn) (function s!:expandcond)) (put (quote case) (quote s!:expandfn) (function s!:expandcase)) (put (quote eval!-when) (quote s!:expandfn) (function s!:expandeval!-when)) (put (quote the) (quote s!:expandfn) (function s!:expandthe)) (put (quote multiple!-value!-call) (quote s!:expandfn) (function s!:expandmv!-call)) (de compile (l) (prog nil (cond ((and (atom l) (not (null l))) (setq l (list l)))) (prog (var1211) (setq var1211 l) lab1210 (cond ((null var1211) (return nil))) (prog (name) (setq name (car var1211)) (errorset (list (quote s!:compile0) (mkquote name)) t t)) (setq var1211 (cdr var1211)) (go lab1210)) (return l))) (global (quote (!*fastvector !*unsafecar))) (flag (quote (fastvector unsafecar)) (quote switch)) (fluid (quote (C_file L_file O_file L_contents Setup_name File_name))) (dm c!:printf (u !&optional env) (list (quote c!:printf1) (cadr u) (cons ( quote list) (cddr u)))) (de c!:printf1 (fmt args) (prog (a c) (setq fmt (explode2 fmt)) (prog nil lab1212 (cond ((null fmt) (return nil))) (progn (setq c (car fmt)) (setq fmt (cdr fmt)) (cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !n)) (equal (car fmt) (quote !N)))) (progn (terpri) (setq fmt (cdr fmt)))) (t ( cond ((and (equal c (quote !\)) (or (equal (car fmt) (quote !q)) (equal (car fmt) (quote !Q)))) (progn (princ (quote !")) (setq fmt (cdr fmt)))) (t (cond ((equal c (quote !%)) (progn (setq c (car fmt)) (cond ((null args) (setq a ( quote missing_arg))) (t (setq a (car args)))) (cond ((or (equal c (quote !v)) (equal c (quote !V))) (cond ((flagp a (quote c!:live_across_call)) (progn ( princ "stack[") (princ (minus (get a (quote c!:location)))) (princ "]"))) (t (princ a)))) (t (cond ((or (equal c (quote !c)) (equal c (quote !C))) ( c!:safeprin a)) (t (cond ((or (equal c (quote !a)) (equal c (quote !A))) ( prin a)) (t (cond ((or (equal c (quote !t)) (equal c (quote !T))) (ttab a)) ( t (cond ((equal c (quote !<)) (progn (setq args (cons nil args)) (cond (( greaterp (posn) 70) (terpri))))) (t (princ a))))))))))) (cond (args (setq args (cdr args)))) (setq fmt (cdr fmt)))) (t (princ c)))))))) (go lab1212)))) (de c!:safeprin (x) (prog (a b) (setq a (explode x)) (prog nil lab1213 (cond ((null a) (return nil))) (progn (cond ((and (eqcar a (quote !/)) b) (princ " "))) (princ (car a)) (setq b (eqcar a (quote !*))) (setq a (cdr a))) (go lab1213)))) (de c!:valid_fndef (args body) (cond ((or (memq (quote !&optional) args) ( memq (quote !&rest) args)) nil) (t (c!:valid_list body)))) (de c!:valid_list (x) (cond ((null x) t) (t (cond ((atom x) nil) (t (cond (( not (c!:valid_expr (car x))) nil) (t (c!:valid_list (cdr x))))))))) (de c!:valid_expr (x) (cond ((atom x) t) (t (cond ((not (atom (car x))) ( progn (cond ((not (c!:valid_list (cdr x))) nil) (t (cond ((not (eqcar (car x) (quote lambda))) nil) (t (cond ((atom (cdar x)) nil) (t (c!:valid_fndef ( cadar x) (cddar x)))))))))) (t (cond ((not (idp (car x))) nil) (t (cond (( eqcar x (quote quote)) t) (t (prog (h) (setq h (get (car x) (quote c!:valid)) ) (cond ((null h) (return (c!:valid_list (cdr x))))) (return (funcall h (cdr x))))))))))))) (de c!:cspecform (x env) (error 0 (list "special form" x))) (de c!:valid_specform (x) nil) (progn (put (quote and) (quote c!:code) (function c!:cspecform)) (put (quote catch) (quote c!:code) (function c!:cspecform)) (put (quote compiler!-let) ( quote c!:code) (function c!:cspecform)) (put (quote cond) (quote c!:code) ( function c!:cspecform)) (put (quote declare) (quote c!:code) (function c!:cspecform)) (put (quote de) (quote c!:code) (function c!:cspecform)) (put (quote eval!-when) (quote c!:code) (function c!:cspecform)) (put (quote flet) (quote c!:code) (function c!:cspecform)) (put (quote function) (quote c!:code) (function c!:cspecform)) (put (quote go) (quote c!:code) (function c!:cspecform)) (put (quote if) (quote c!:code) (function c!:cspecform)) (put (quote labels) (quote c!:code) (function c!:cspecform)) (put (quote !~let) ( quote c!:code) (function c!:cspecform)) (put (quote let!*) (quote c!:code) ( function c!:cspecform)) (put (quote list) (quote c!:code) (function c!:cspecform)) (put (quote list!*) (quote c!:code) (function c!:cspecform)) ( put (quote macrolet) (quote c!:code) (function c!:cspecform)) (put (quote multiple!-value!-call) (quote c!:code) (function c!:cspecform)) (put (quote multiple!-value!-prog1) (quote c!:code) (function c!:cspecform)) (put (quote or) (quote c!:code) (function c!:cspecform)) (put (quote prog) (quote c!:code ) (function c!:cspecform)) (put (quote prog!*) (quote c!:code) (function c!:cspecform)) (put (quote prog1) (quote c!:code) (function c!:cspecform)) ( put (quote prog2) (quote c!:code) (function c!:cspecform)) (put (quote progn) (quote c!:code) (function c!:cspecform)) (put (quote progv) (quote c!:code) (function c!:cspecform)) (put (quote quote) (quote c!:code) (function c!:cspecform)) (put (quote return) (quote c!:code) (function c!:cspecform)) ( put (quote return!-from) (quote c!:code) (function c!:cspecform)) (put (quote setq) (quote c!:code) (function c!:cspecform)) (put (quote tagbody) (quote c!:code) (function c!:cspecform)) (put (quote the) (quote c!:code) (function c!:cspecform)) (put (quote throw) (quote c!:code) (function c!:cspecform)) ( put (quote unless) (quote c!:code) (function c!:cspecform)) (put (quote unwind!-protect) (quote c!:code) (function c!:cspecform)) (put (quote when) ( quote c!:code) (function c!:cspecform)) (put (quote catch) (quote c!:valid) ( function c!:valid_specform)) (put (quote compiler!-let) (quote c!:valid) ( function c!:valid_specform)) (put (quote cond) (quote c!:valid) (function c!:valid_specform)) (put (quote declare) (quote c!:valid) (function c!:valid_specform)) (put (quote de) (quote c!:valid) (function c!:valid_specform)) (put (quote eval!-when) (quote c!:valid) (function c!:valid_specform)) (put (quote flet) (quote c!:valid) (function c!:valid_specform)) (put (quote function) (quote c!:valid) (function c!:valid_specform)) (put (quote labels) (quote c!:valid) (function c!:valid_specform)) (put (quote !~let) (quote c!:valid) (function c!:valid_specform)) (put (quote let!*) (quote c!:valid) (function c!:valid_specform)) (put (quote macrolet) (quote c!:valid) (function c!:valid_specform)) (put (quote multiple!-value!-call) (quote c!:valid) ( function c!:valid_specform)) (put (quote multiple!-value!-prog1) (quote c!:valid) (function c!:valid_specform)) (put (quote prog) (quote c!:valid) ( function c!:valid_specform)) (put (quote prog!*) (quote c!:valid) (function c!:valid_specform)) (put (quote progv) (quote c!:valid) (function c!:valid_specform)) (put (quote quote) (quote c!:valid) (function c!:valid_specform)) (put (quote the) (quote c!:valid) (function c!:valid_specform)) (put (quote throw) (quote c!:valid) (function c!:valid_specform)) (put (quote unwind!-protect) (quote c!:valid) (function c!:valid_specform))) (fluid (quote (c!:current_procedure c!:current_args c!:current_block c!:current_contents c!:all_blocks c!:registers c!:stacklocs))) (fluid (quote (c!:available c!:used))) (setq c!:available (setq c!:used nil)) (de c!:reset_gensyms nil (progn (remflag c!:used (quote c!:live_across_call)) (remflag c!:used (quote c!:visited)) (prog nil lab1214 (cond ((null c!:used) (return nil))) (progn (remprop (car c!:used) (quote c!:contents)) (remprop ( car c!:used) (quote c!:why)) (remprop (car c!:used) (quote c!:where_to)) ( remprop (car c!:used) (quote c!:count)) (remprop (car c!:used) (quote c!:live )) (remprop (car c!:used) (quote c!:clash)) (remprop (car c!:used) (quote c!:chosen)) (remprop (car c!:used) (quote c!:location)) (cond ((plist (car c!:used)) (prog (o) (setq o (wrs nil)) (princ "+++++ ") (prin (car c!:used)) (princ " ") (prin (plist (car c!:used))) (terpri) (wrs o)))) (setq c!:available (cons (car c!:used) c!:available)) (setq c!:used (cdr c!:used))) (go lab1214)))) (de c!:my_gensym nil (prog (w) (cond (c!:available (progn (setq w (car c!:available)) (setq c!:available (cdr c!:available)))) (t (setq w (gensym1 "v")))) (setq c!:used (cons w c!:used)) (cond ((plist w) (progn (princ "????? ") (prin w) (princ " => ") (prin (plist w)) (terpri)))) (return w))) (de c!:newreg nil (prog (r) (setq r (c!:my_gensym)) (setq c!:registers (cons r c!:registers)) (return r))) (de c!:startblock (s) (progn (setq c!:current_block s) (setq c!:current_contents nil))) (de c!:outop (a b c d) (cond (c!:current_block (setq c!:current_contents ( cons (list a b c d) c!:current_contents))))) (de c!:endblock (why where_to) (cond (c!:current_block (progn (put c!:current_block (quote c!:contents) c!:current_contents) (put c!:current_block (quote c!:why) why) (put c!:current_block (quote c!:where_to ) where_to) (setq c!:all_blocks (cons c!:current_block c!:all_blocks)) (setq c!:current_contents nil) (setq c!:current_block nil))))) (de c!:cval_inner (x env) (prog (helper) (setq x (s!:improve x)) (cond ((atom x) (return (c!:catom x env))) (t (cond ((eqcar (car x) (quote lambda)) ( return (c!:clambda (cadar x) (cddar x) (cdr x) env))) (t (cond ((setq helper (get (car x) (quote c!:code))) (return (funcall helper x env))) (t (cond (( and (setq helper (get (car x) (quote c!:compile_macro))) (setq helper ( funcall helper x))) (return (c!:cval helper env))) (t (cond ((and (idp (car x )) (setq helper (macro!-function (car x)))) (return (c!:cval (funcall helper x) env))) (t (return (c!:ccall (car x) (cdr x) env)))))))))))))) (de c!:cval (x env) (prog (r) (setq r (c!:cval_inner x env)) (cond ((and r ( not (member!*!* r c!:registers))) (error 0 (list r "not a register" x)))) ( return r))) (de c!:clambda (bvl body args env) (prog (w w1 fluids env1 decs) (setq env1 ( car env)) (setq w (prog (var1216 var1217) (setq var1216 args) lab1215 (cond ( (null var1216) (return (reversip var1217)))) (prog (a) (setq a (car var1216)) (setq var1217 (cons (c!:cval a env) var1217))) (setq var1216 (cdr var1216)) (go lab1215))) (setq w1 (s!:find_local_decs body nil)) (setq localdecs (cons (car w1) localdecs)) (setq w1 (cdr w1)) (cond ((null w1) (setq body nil)) (t (cond ((null (cdr w1)) (setq body (car w1))) (t (setq body (cons (quote progn ) w1)))))) (prog (var1219) (setq var1219 bvl) lab1218 (cond ((null var1219) ( return nil))) (prog (x) (setq x (car var1219)) (cond ((and (not (fluidp x)) ( not (globalp x)) (c!:local_fluidp x localdecs)) (progn (make!-special x) ( setq decs (cons x decs)))))) (setq var1219 (cdr var1219)) (go lab1218)) (prog (var1221) (setq var1221 bvl) lab1220 (cond ((null var1221) (return nil))) ( prog (v) (setq v (car var1221)) (progn (cond ((globalp v) (prog (oo) (setq oo (wrs nil)) (princ "+++++ ") (prin v) (princ " converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v)) ( fluid (list v))))) (cond ((fluidp v) (progn (setq fluids (cons (cons v ( c!:newreg)) fluids)) (flag (list (cdar fluids)) (quote c!:live_across_call)) (setq env1 (cons (cons (quote c!:dummy!:name) (cdar fluids)) env1)) (c!:outop (quote ldrglob) (cdar fluids) v (c!:find_literal v)) (c!:outop (quote strglob) (car w) v (c!:find_literal v)))) (t (progn (setq env1 (cons (cons v (c!:newreg)) env1)) (c!:outop (quote movr) (cdar env1) nil (car w))))) (setq w (cdr w)))) (setq var1221 (cdr var1221)) (go lab1220)) (cond (fluids ( c!:outop (quote fluidbind) nil nil fluids))) (setq env (cons env1 (append fluids (cdr env)))) (setq w (c!:cval body env)) (prog (var1223) (setq var1223 fluids) lab1222 (cond ((null var1223) (return nil))) (prog (v) (setq v (car var1223)) (c!:outop (quote strglob) (cdr v) (car v) (c!:find_literal (car v)) )) (setq var1223 (cdr var1223)) (go lab1222)) (unfluid decs) (setq localdecs (cdr localdecs)) (return w))) (de c!:locally_bound (x env) (atsoc x (car env))) (flag (quote (nil t)) (quote c!:constant)) (fluid (quote (literal_vector))) (de c!:find_literal (x) (prog (n w) (setq w literal_vector) (setq n 0) (prog nil lab1224 (cond ((null (and w (not (equal (car w) x)))) (return nil))) ( progn (setq n (plus n 1)) (setq w (cdr w))) (go lab1224)) (cond ((null w) ( setq literal_vector (append literal_vector (list x))))) (return n))) (de c!:catom (x env) (prog (v w) (setq v (c!:newreg)) (cond ((and (idp x) (or (fluidp x) (globalp x))) (c!:outop (quote ldrglob) v x (c!:find_literal x))) (t (cond ((and (idp x) (setq w (c!:locally_bound x env))) (c!:outop (quote movr) v nil (cdr w))) (t (cond ((or (null x) (equal x (quote t)) ( c!:small_number x)) (c!:outop (quote movk1) v nil x)) (t (cond ((or (not (idp x)) (flagp x (quote c!:constant))) (c!:outop (quote movk) v x ( c!:find_literal x))) (t (c!:outop (quote ldrglob) v x (c!:find_literal x))))) ))))) (return v))) (de c!:cjumpif (x env d1 d2) (prog (helper r) (setq x (s!:improve x)) (cond ( (and (atom x) (or (not (idp x)) (and (flagp x (quote c!:constant)) (not ( c!:locally_bound x env))))) (c!:endblock (quote goto) (list (cond (x d1) (t d2))))) (t (cond ((and (not (atom x)) (setq helper (get (car x) (quote c!:ctest)))) (return (funcall helper x env d1 d2))) (t (progn (setq r ( c!:cval x env)) (c!:endblock (list (quote ifnull) r) (list d2 d1))))))))) (fluid (quote (c!:current))) (de c!:ccall (fn args env) (c!:ccall1 fn args env)) (fluid (quote (c!:visited))) (de c!:has_calls (a b) (prog (c!:visited) (return (c!:has_calls_1 a b)))) (de c!:has_calls_1 (a b) (cond ((or (equal a b) (not (atom a)) (memq a c!:visited)) nil) (t (prog (has_call) (setq c!:visited (cons a c!:visited)) ( prog (var1226) (setq var1226 (get a (quote c!:contents))) lab1225 (cond (( null var1226) (return nil))) (prog (z) (setq z (car var1226)) (cond ((eqcar z (quote call)) (setq has_call t)))) (setq var1226 (cdr var1226)) (go lab1225) ) (cond (has_call (return (prog (c!:visited) (return (c!:can_reach a b)))))) (prog (var1228) (setq var1228 (get a (quote c!:where_to))) lab1227 (cond (( null var1228) (return nil))) (prog (d) (setq d (car var1228)) (cond (( c!:has_calls_1 d b) (setq has_call t)))) (setq var1228 (cdr var1228)) (go lab1227)) (return has_call))))) (de c!:can_reach (a b) (cond ((equal a b) t) (t (cond ((or (not (atom a)) ( memq a c!:visited)) nil) (t (progn (setq c!:visited (cons a c!:visited)) ( c!:any_can_reach (get a (quote c!:where_to)) b))))))) (de c!:any_can_reach (l b) (cond ((null l) nil) (t (cond ((c!:can_reach (car l) b) t) (t (c!:any_can_reach (cdr l) b)))))) (de c!:pareval (args env) (prog (tasks tasks1 merge split r) (setq tasks ( prog (var1230 var1231) (setq var1230 args) lab1229 (cond ((null var1230) ( return (reversip var1231)))) (prog (a) (setq a (car var1230)) (setq var1231 ( cons (cons (c!:my_gensym) (c!:my_gensym)) var1231))) (setq var1230 (cdr var1230)) (go lab1229))) (setq split (c!:my_gensym)) (c!:endblock (quote goto ) (list split)) (prog (var1233) (setq var1233 args) lab1232 (cond ((null var1233) (return nil))) (prog (a) (setq a (car var1233)) (prog (s) (setq s ( car tasks)) (setq tasks (cdr tasks)) (c!:startblock (car s)) (setq r (cons ( c!:cval a env) r)) (c!:endblock (quote goto) (list (cdr s))) (cond ((or t ( c!:has_calls (car s) (cdr s))) (setq tasks1 (cons s tasks1))) (t (setq merge (cons s merge)))))) (setq var1233 (cdr var1233)) (go lab1232)) (prog (var1235 ) (setq var1235 tasks1) lab1234 (cond ((null var1235) (return nil))) (prog (z ) (setq z (car var1235)) (setq merge (cons z merge))) (setq var1235 (cdr var1235)) (go lab1234)) (prog (var1237) (setq var1237 merge) lab1236 (cond (( null var1237) (return nil))) (prog (v) (setq v (car var1237)) (progn ( c!:startblock split) (c!:endblock (quote goto) (list (car v))) (setq split ( cdr v)))) (setq var1237 (cdr var1237)) (go lab1236)) (c!:startblock split) ( return (reversip r)))) (de c!:ccall1 (fn args env) (prog (tasks merge r val) (setq fn (list fn (cdr env))) (setq val (c!:newreg)) (cond ((null args) (c!:outop (quote call) val nil fn)) (t (cond ((null (cdr args)) (c!:outop (quote call) val (list ( c!:cval (car args) env)) fn)) (t (progn (setq r (c!:pareval args env)) ( c!:outop (quote call) val r fn)))))) (c!:outop (quote reloadenv) (quote env) nil nil) (return val))) (fluid (quote (restart_label reloadenv does_call c!:current_c_name))) (de c!:local_fluidp1 (v decs) (and decs (or (and (eqcar (car decs) (quote special)) (memq v (cdar decs))) (c!:local_fluidp1 v (cdr decs))))) (de c!:local_fluidp (v decs) (and decs (or (c!:local_fluidp1 v (car decs)) ( c!:local_fluidp v (cdr decs))))) (fluid (quote (proglabs blockstack localdecs))) (de c!:cfndef (c!:current_procedure c!:current_c_name argsbody checksum) ( prog (env n w c!:current_args c!:current_block restart_label c!:current_contents c!:all_blocks entrypoint exitpoint args1 c!:registers c!:stacklocs literal_vector reloadenv does_call blockstack proglabs args body localdecs) (setq args (car argsbody)) (setq body (cdr argsbody)) (setq w ( s!:find_local_decs body nil)) (setq body (cdr w)) (cond ((atom body) (setq body nil)) (t (cond ((atom (cdr body)) (setq body (car body))) (t (setq body (cons (quote progn) body)))))) (setq localdecs (list (car w))) ( c!:reset_gensyms) (wrs C_file) (linelength 200) (c!:printf "\n\n/* Code for %a %<*/\n\n" c!:current_procedure) (c!:find_literal c!:current_procedure) (setq c!:current_args args) (prog (var1239) (setq var1239 args) lab1238 (cond ((null var1239) (return nil))) (prog (v) (setq v (car var1239)) (cond ((or (equal v (quote !&optional)) (equal v (quote !&rest ))) (error 0 "&optional and &rest not supported by this compiler (yet)")) (t (cond ((globalp v) (prog (oo) (setq oo (wrs nil)) (princ "+++++ ") (prin v) ( princ " converted from GLOBAL to FLUID") (terpri) (wrs oo) (unglobal (list v) ) (fluid (list v)) (setq n (cons (cons v (c!:my_gensym)) n)))) (t (cond ((or (fluidp v) (c!:local_fluidp v localdecs)) (setq n (cons (cons v (c!:my_gensym )) n))))))))) (setq var1239 (cdr var1239)) (go lab1238)) (cond (!*r2i (setq body (s!:r2i c!:current_procedure args body)))) (setq restart_label ( c!:my_gensym)) (setq body (list (quote c!:private_tagbody) restart_label body )) (cond (n (progn (setq body (list (list (quote return) body))) (setq args ( subla n args)) (prog (var1241) (setq var1241 n) lab1240 (cond ((null var1241) (return nil))) (prog (v) (setq v (car var1241)) (setq body (cons (list ( quote setq) (car v) (cdr v)) body))) (setq var1241 (cdr var1241)) (go lab1240 )) (setq body (cons (quote prog) (cons (prog (var1243 var1244) (setq var1243 (reverse n)) lab1242 (cond ((null var1243) (return (reversip var1244)))) ( prog (v) (setq v (car var1243)) (setq var1244 (cons (car v) var1244))) (setq var1243 (cdr var1243)) (go lab1242)) body)))))) (c!:printf "static Lisp_Object ") (cond ((or (null args) (geq (length args) 3)) ( c!:printf "MS_CDECL "))) (c!:printf "%s(Lisp_Object env" c!:current_c_name) ( cond ((or (null args) (geq (length args) 3)) (c!:printf ", int nargs"))) ( setq n t) (setq env nil) (prog (var1246) (setq var1246 args) lab1245 (cond (( null var1246) (return nil))) (prog (x) (setq x (car var1246)) (prog (aa) ( c!:printf ",") (cond (n (progn (c!:printf "\n ") (setq n nil))) (t (setq n t))) (setq aa (c!:my_gensym)) (setq env (cons (cons x aa ) env)) (setq c!:registers (cons aa c!:registers)) (setq args1 (cons aa args1 )) (c!:printf " Lisp_Object %s" aa))) (setq var1246 (cdr var1246)) (go lab1245)) (cond ((or (null args) (geq (length args) 3)) (c!:printf ", ..."))) (c!:printf ")\n{\n") (c!:startblock (setq entrypoint (c!:my_gensym))) (setq exitpoint c!:current_block) (c!:endblock (quote goto) (list (list (c!:cval body (cons env nil))))) (c!:optimise_flowgraph entrypoint c!:all_blocks env ( cons (length args) c!:current_procedure) args1) (c!:printf "}\n\n") (wrs O_file) (setq L_contents (cons (cons c!:current_procedure (cons literal_vector checksum)) L_contents)) (return nil))) (flag (quote (rds deflist flag fluid global remprop remflag unfluid unglobal dm carcheck C!-end)) (quote eval)) (flag (quote (rds)) (quote ignore)) (fluid (quote (!*backtrace))) (de c!:ccompilesupervisor nil (prog (u w) top (setq u (errorset (quote (read) ) t !*backtrace)) (cond ((atom u) (return nil))) (setq u (car u)) (cond (( equal u !$eof!$) (return nil))) (cond ((atom u) (go top)) (t (cond ((eqcar u (quote C!-end)) (return (apply (quote C!-end) nil))) (t (cond ((eqcar u ( quote rdf)) (progn (setq w (open (setq u (eval (cadr u))) (quote input))) ( cond (w (progn (terpri) (princ "Reading file ") (print u) (setq w (rds w)) ( c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t (progn (princ "Failed to open file ") (print u)))))) (t (c!:ccmpout1 u))))))) (go top))) (global (quote (c!:char_mappings))) (setq c!:char_mappings (quote ((! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . !E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)))) (fluid (quote (c!:names_so_far))) (de c!:inv_name (n) (prog (r w) (cond ((setq w (assoc n c!:names_so_far)) ( setq w (plus (cdr w) 1))) (t (setq w 0))) (setq c!:names_so_far (cons (cons n w) c!:names_so_far)) (setq r (quote (!C !C !"))) (cond ((not (zerop w)) ( setq r (append (reverse (explodec w)) r)))) (setq r (cons (quote !_) r)) ( prog (var1248) (setq var1248 (explode2 n)) lab1247 (cond ((null var1248) ( return nil))) (prog (c) (setq c (car var1248)) (progn (cond ((equal c (quote _)) (setq r (cons (quote _) r))) (t (cond ((or (liter c) (digit c)) (setq r ( cons c r))) (t (cond ((setq w (atsoc c c!:char_mappings)) (setq r (cons (cdr w) r))) (t (setq r (cons (quote !Z) r)))))))))) (setq var1248 (cdr var1248)) (go lab1247)) (setq r (cons (quote !") r)) (return (compress (reverse r))))) (fluid (quote (c!:defnames pending_functions))) (de c!:ccmpout1 (u) (prog (pending_functions) (setq pending_functions (list u )) (prog nil lab1249 (cond ((null pending_functions) (return nil))) (progn ( setq u (car pending_functions)) (setq pending_functions (cdr pending_functions)) (c!:ccmpout1a u)) (go lab1249)))) (de c!:ccmpout1a (u) (prog (w checksum) (cond ((atom u) (return nil)) (t ( cond ((eqcar u (quote progn)) (progn (prog (var1251) (setq var1251 (cdr u)) lab1250 (cond ((null var1251) (return nil))) (prog (v) (setq v (car var1251)) (c!:ccmpout1a v)) (setq var1251 (cdr var1251)) (go lab1250)) (return nil))) (t (cond ((eqcar u (quote C!-end)) nil) (t (cond ((or (flagp (car u) (quote eval)) (and (equal (car u) (quote setq)) (not (atom (caddr u))) (flagp ( caaddr u) (quote eval)))) (errorset u t !*backtrace))))))))) (cond ((eqcar u (quote rdf)) (prog nil (setq w (open (setq u (eval (cadr u))) (quote input))) (cond (w (progn (princ "Reading file ") (print u) (setq w (rds w)) ( c!:ccompilesupervisor) (princ "End of file ") (print u) (close (rds w)))) (t (progn (princ "Failed to open file ") (print u)))))) (t (cond ((eqcar u ( quote de)) (progn (setq u (cdr u)) (setq checksum (md60 u)) (setq c!:defnames (cons (list (car u) (c!:inv_name (car u)) (length (cadr u)) checksum) c!:defnames)) (princ "Compiling ") (prin (caar c!:defnames)) (princ " ... ") (c!:cfndef (caar c!:defnames) (cadar c!:defnames) (cdr u) checksum) (terpri)) )))))) (fluid (quote (!*defn dfprint!* dfprintsave))) (de c!:concat (a b) (compress (cons (quote !") (append (explode2 a) (append ( explode2 b) (quote (!"))))))) (de c!:ccompilestart (name setupname dir hdrnow) (prog (o d w) (reset!-gensym 0) (setq c!:registers (setq c!:available (setq c!:used nil))) (setq File_name (list!-to!-string (explodec name))) (setq Setup_name (explodec setupname)) (setq Setup_name (subst (quote !_) (quote !-) Setup_name)) (setq Setup_name (list!-to!-string Setup_name)) (cond (dir (progn (cond ((memq ( quote win32) lispsystem!*) (setq name (c!:concat dir (c!:concat "\" name)))) (t (setq name (c!:concat dir (c!:concat "/" name)))))))) (princ "C file = ") (print name) (setq C_file (open (c!:concat name ".c") (quote output))) (setq L_file (c!:concat name ".lsp")) (setq L_contents nil) (setq c!:names_so_far nil) (setq o (reverse (explode (date)))) (prog (i) (setq i 1) lab1252 (cond ( (minusp (times 1 (difference 5 i))) (return nil))) (progn (setq d (cons (car o) d)) (setq o (cdr o))) (setq i (plus i 1)) (go lab1252)) (setq d (cons ( quote !-) d)) (setq o (cdddr (cdddr (cddddr o)))) (setq w o) (setq o (cdddr o )) (setq d (cons (caddr o) (cons (cadr o) (cons (car o) d)))) (setq d ( compress (cons (quote !") (cons (cadr w) (cons (car w) (cons (quote !-) d)))) )) (setq O_file (wrs C_file)) (setq c!:defnames nil) (cond (hdrnow (c!:printf "\n/* Module: %s %tMachine generated C code %<*/\n\n" setupname 25)) (t ( c!:printf "\n/* %s.c %tMachine generated C code %<*/\n\n" name 25))) ( c!:printf "/* Signature: 00000000 %s %<*/\n\n" d) (c!:printf "#include \n") (c!:printf "#include \n") (c!:printf "#include \n") (c!:printf "#include \n") (c!:printf "#include \n") (c!:printf "#include \n") (c!:printf "#ifndef _cplusplus\n") (c!:printf "#include \n") (c!:printf "#endif\n\n") (cond (hdrnow (print!-config!-header)) (t (c!:printf "#include \qconfig.h\q\n\n"))) (print!-csl!-headers) (cond (hdrnow ( c!:print!-init))) (wrs O_file) (return nil))) (de c!:print!-init nil (progn (c!:printf "\n") (c!:printf "Lisp_Object *C_nilp;\n") (c!:printf "Lisp_Object **C_stackp;\n") (c!:printf "Lisp_Object * volatile * stacklimitp;\n") (c!:printf "\n") (c!:printf "void init(Lisp_Object *a, Lisp_Object **b, Lisp_Object * volatile *c)\n") ( c!:printf "{\n") (c!:printf " C_nilp = a;\n") (c!:printf " C_stackp = b;\n") (c!:printf " stacklimitp = c;\n") (c!:printf "}\n") (c!:printf "\n") (c!:printf "#define C_nil (*C_nilp)\n") (c!:printf "#define C_stack (*C_stackp)\n") (c!:printf "#define stacklimit (*stacklimitp)\n") (c!:printf "\n"))) (de C!-end nil (C!-end1 t)) (de C!-end1 (create_lfile) (prog (checksum c1 c2 c3) (wrs C_file) (cond ( create_lfile (c!:printf "\n\nsetup_type const %s_setup[] =\n{\n" Setup_name)) (t (c!:printf "\n\nsetup_type_1 const %s_setup[] =\n{\n" Setup_name))) (setq c!:defnames (reverse c!:defnames)) (prog nil lab1253 (cond ((null c!:defnames) (return nil))) (prog (name nargs f1 f2 cast fn) (setq name (caar c!:defnames)) (setq checksum (cadddr (car c!:defnames))) (setq f1 (cadar c!:defnames)) (setq nargs (caddar c!:defnames)) (setq cast "(n_args *)") ( cond ((equal nargs 1) (progn (setq f2 (quote !t!o!o_!m!a!n!y_1)) (setq cast "") (setq fn (quote !w!r!o!n!g_!n!o_1)))) (t (cond ((equal nargs 2) (progn ( setq f2 f1) (setq f1 (quote !t!o!o_!f!e!w_2)) (setq cast "") (setq fn (quote !w!r!o!n!g_!n!o_2)))) (t (progn (setq fn f1) (setq f1 (quote !w!r!o!n!g_!n!o_!n!a)) (setq f2 (quote !w!r!o!n!g_!n!o_!n!b))))))) (cond ( create_lfile (c!:printf " {\q%s\q,%t%s,%t%s,%t%s%s},\n" name 32 f1 48 f2 63 cast fn)) (t (prog (c1 c2) (setq c1 (divide checksum (expt 2 31))) (setq c2 (cdr c1)) (setq c1 (car c1)) (c!:printf " {\q%s\q, %t%s, %t%s, %t%s%s, %t%s, %t%s},\n" name 24 f1 40 f2 52 cast fn 64 c1 76 c2)))) (setq c!:defnames (cdr c!:defnames))) (go lab1253)) (setq c3 (setq checksum (md60 L_contents))) (setq c1 (remainder c3 10000000)) (setq c3 (quotient c3 10000000)) (setq c2 (remainder c3 10000000)) (setq c3 ( quotient c3 10000000)) (setq checksum (list!-to!-string (append (explodec c3) (cons (quote ! ) (append (explodec c2) (cons (quote ! ) (explodec c1))))))) (c!:printf " {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n" Setup_name checksum) (c!:printf "% (intptr_t)%v) ? lisp_true : nil;\n" r1 r2 r3)) (put (quote igreaterp) (quote c!:opcode_printer) (function c!:pigreaterp)) (flag (quote (igreaterp)) (quote c!:uses_nil)) (de c!:piminus (op r1 r2 r3 depth) (c!:printf " %v = (Lisp_Object)(2-((int32_t)(%v)));\n" r1 r3)) (put (quote iminus) (quote c!:opcode_printer) (function c!:piminus)) (de c!:piadd1 (op r1 r2 r3 depth) (c!:printf " %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n" r1 r3)) (put (quote iadd1) (quote c!:opcode_printer) (function c!:piadd1)) (de c!:pisub1 (op r1 r2 r3 depth) (c!:printf " %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n" r1 r3)) (put (quote isub1) (quote c!:opcode_printer) (function c!:pisub1)) (de c!:piplus2 (op r1 r2 r3 depth) (c!:printf " %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_FIXNUM);\n" r1 r2 r3)) (put (quote iplus2) (quote c!:opcode_printer) (function c!:piplus2)) (de c!:pidifference (op r1 r2 r3 depth) (c!:printf " %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_FIXNUM);\n" r1 r2 r3)) (put (quote idifference) (quote c!:opcode_printer) (function c!:pidifference) ) (de c!:pitimes2 (op r1 r2 r3 depth) (c!:printf " %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnum(%v)));\n" r1 r2 r3)) (put (quote itimes2) (quote c!:opcode_printer) (function c!:pitimes2)) (de c!:pmodular_plus (op r1 r2 r3 depth) (progn (c!:printf " { int32_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n" r2 r3) ( c!:printf " if (w >= current_modulus) w -= current_modulus;\n") ( c!:printf " %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) (put (quote modular!-plus) (quote c!:opcode_printer) (function c!:pmodular_plus)) (de c!:pmodular_difference (op r1 r2 r3 depth) (progn (c!:printf " { int32_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n" r2 r3) ( c!:printf " if (w < 0) w += current_modulus;\n") (c!:printf " %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) (put (quote modular!-difference) (quote c!:opcode_printer) (function c!:pmodular_difference)) (de c!:pmodular_minus (op r1 r2 r3 depth) (progn (c!:printf " { int32_t w = int_of_fixnum(%v);\n" r3) (c!:printf " if (w != 0) w = current_modulus - w;\n") (c!:printf " %v = fixnum_of_int(w);\n" r1) (c!:printf " }\n"))) (put (quote modular!-minus) (quote c!:opcode_printer) (function c!:pmodular_minus)) (de c!:passoc (op r1 r2 r3 depth) (c!:printf " %v = Lassoc(nil, %v, %v);\n" r1 r2 r3)) (put (quote assoc) (quote c!:opcode_printer) (function c!:passoc)) (flag (quote (assoc)) (quote c!:uses_nil)) (de c!:patsoc (op r1 r2 r3 depth) (c!:printf " %v = Latsoc(nil, %v, %v);\n" r1 r2 r3)) (put (quote atsoc) (quote c!:opcode_printer) (function c!:patsoc)) (flag (quote (atsoc)) (quote c!:uses_nil)) (de c!:pmember (op r1 r2 r3 depth) (c!:printf " %v = Lmember(nil, %v, %v);\n" r1 r2 r3)) (put (quote member) (quote c!:opcode_printer) (function c!:pmember)) (flag (quote (member)) (quote c!:uses_nil)) (de c!:pmemq (op r1 r2 r3 depth) (c!:printf " %v = Lmemq(nil, %v, %v);\n" r1 r2 r3)) (put (quote memq) (quote c!:opcode_printer) (function c!:pmemq)) (flag (quote (memq)) (quote c!:uses_nil)) (de c!:pget (op r1 r2 r3 depth) (c!:printf " %v = get(%v, %v);\n" r1 r2 r3 )) (put (quote get) (quote c!:opcode_printer) (function c!:pget)) (de c!:pqgetv (op r1 r2 r3 depth) (progn (c!:printf " %v = *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +" r1 r2) ( c!:printf " ((int32_t)%v/(16/CELL)));\n" r3))) (put (quote qgetv) (quote c!:opcode_printer) (function c!:pqgetv)) (de c!:pqputv (op r1 r2 r3 depth) (progn (c!:printf " *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +" r2) (c!:printf " ((int32_t)%v/(16/CELL))) = %v;\n" r3 r1))) (put (quote qputv) (quote c!:opcode_printer) (function c!:pqputv)) (de c!:peq (op r1 r2 r3 depth) (c!:printf " %v = (%v == %v ? lisp_true : nil);\n" r1 r2 r3)) (put (quote eq) (quote c!:opcode_printer) (function c!:peq)) (flag (quote (eq)) (quote c!:uses_nil)) (de c!:pequal (op r1 r2 r3 depth) (c!:printf " %v = (equal(%v, %v) ? lisp_true : nil);\n" r1 r2 r3 r2 r3)) (put (quote equal) (quote c!:opcode_printer) (function c!:pequal)) (flag (quote (equal)) (quote c!:uses_nil)) (de c!:pfluidbind (op r1 r2 r3 depth) nil) (put (quote fluidbind) (quote c!:opcode_printer) (function c!:pfluidbind)) (de c!:pcall (op r1 r2 r3 depth) (prog (w boolfn) (cond ((setq w (get (car r3 ) (quote c!:direct_entrypoint))) (progn (c!:printf " %v = %s(" r1 (cdr w)) (cond (r2 (progn (c!:printf "%v" (car r2)) (prog (var1269) (setq var1269 ( cdr r2)) lab1268 (cond ((null var1269) (return nil))) (prog (a) (setq a (car var1269)) (c!:printf ", %v" a)) (setq var1269 (cdr var1269)) (go lab1268))))) (c!:printf ");\n"))) (t (cond ((setq w (get (car r3) (quote c!:direct_predicate))) (progn (setq boolfn t) (c!:printf " %v = (Lisp_Object)%s(" r1 (cdr w)) (cond (r2 (progn (c!:printf "%v" (car r2)) (prog (var1271) (setq var1271 (cdr r2)) lab1270 (cond ((null var1271) ( return nil))) (prog (a) (setq a (car var1271)) (c!:printf ", %v" a)) (setq var1271 (cdr var1271)) (go lab1270))))) (c!:printf ");\n"))) (t (cond ((equal (car r3) c!:current_procedure) (progn (setq r2 (c!:fix_nargs r2 c!:current_args)) (c!:printf " %v = %s(env" r1 c!:current_c_name) (cond (( or (null r2) (geq (length r2) 3)) (c!:printf ", %s" (length r2)))) (prog ( var1273) (setq var1273 r2) lab1272 (cond ((null var1273) (return nil))) (prog (a) (setq a (car var1273)) (c!:printf ", %v" a)) (setq var1273 (cdr var1273) ) (go lab1272)) (c!:printf ");\n"))) (t (cond ((setq w (get (car r3) (quote c!:c_entrypoint))) (progn (c!:printf " %v = %s(nil" r1 w) (cond ((or (null r2) (geq (length r2) 3)) (c!:printf ", %s" (length r2)))) (prog (var1275) ( setq var1275 r2) lab1274 (cond ((null var1275) (return nil))) (prog (a) (setq a (car var1275)) (c!:printf ", %v" a)) (setq var1275 (cdr var1275)) (go lab1274)) (c!:printf ");\n"))) (t (prog (nargs) (setq nargs (length r2)) ( c!:printf " fn = elt(env, %s); % ((int32_t)(%v))" (car s) (cadr s))) (put (quote ifigreaterp) (quote c!:exit_helper) (function c!:pifigreaterp)) (de c!:display_flowgraph (s depth dropping_through) (cond ((not (atom s)) ( progn (c!:printf " ") (c!:pgoto s depth))) (t (cond ((not (flagp s (quote c!:visited))) (prog (why where_to) (flag (list s) (quote c!:visited)) (cond ( (or (not dropping_through) (not (equal (get s (quote c!:count)) 1))) ( c!:printf "\n%s:\n" s))) (prog (var1279) (setq var1279 (reverse (get s (quote c!:contents)))) lab1278 (cond ((null var1279) (return nil))) (prog (k) (setq k (car var1279)) (c!:print_opcode k depth)) (setq var1279 (cdr var1279)) (go lab1278)) (setq why (get s (quote c!:why))) (setq where_to (get s (quote c!:where_to))) (cond ((and (equal why (quote goto)) (or (not (atom (car where_to))) (and (not (flagp (car where_to) (quote c!:visited))) (equal (get (car where_to) (quote c!:count)) 1)))) (c!:display_flowgraph (car where_to) depth t)) (t (c!:print_exit_condition why where_to depth))))))))) (fluid (quote (c!:startpoint))) (de c!:branch_chain (s count) (prog (contents why where_to n) (cond ((not ( atom s)) (return s)) (t (cond ((flagp s (quote c!:visited)) (progn (setq n ( get s (quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) (put s (quote c!:count) n) (return s)))))) (flag (list s) (quote c!:visited) ) (setq contents (get s (quote c!:contents))) (setq why (get s (quote c!:why) )) (setq where_to (prog (var1281 var1282) (setq var1281 (get s (quote c!:where_to))) lab1280 (cond ((null var1281) (return (reversip var1282)))) ( prog (z) (setq z (car var1281)) (setq var1282 (cons (c!:branch_chain z count) var1282))) (setq var1281 (cdr var1281)) (go lab1280))) (prog nil lab1283 ( cond ((null (and contents (eqcar (car contents) (quote movr)) (equal why ( quote goto)) (not (atom (car where_to))) (equal (caar where_to) (cadr (car contents))))) (return nil))) (progn (setq where_to (list (list (cadddr (car contents))))) (setq contents (cdr contents))) (go lab1283)) (put s (quote c!:contents) contents) (put s (quote c!:where_to) where_to) (cond ((and (null contents) (equal why (quote goto))) (progn (remflag (list s) (quote c!:visited)) (return (car where_to))))) (cond (count (progn (setq n (get s ( quote c!:count))) (cond ((null n) (setq n 1)) (t (setq n (plus n 1)))) (put s (quote c!:count) n)))) (return s))) (de c!:one_operand (op) (progn (flag (list op) (quote c!:set_r1)) (flag (list op) (quote c!:read_r3)) (put op (quote c!:code) (function c!:builtin_one)))) (de c!:two_operands (op) (progn (flag (list op) (quote c!:set_r1)) (flag ( list op) (quote c!:read_r2)) (flag (list op) (quote c!:read_r3)) (put op ( quote c!:code) (function c!:builtin_two)))) (prog (var1285) (setq var1285 (quote (car cdr qcar qcdr null not atom numberp fixp iminusp iminus iadd1 isub1 modular!-minus))) lab1284 (cond ((null var1285) (return nil))) (prog (n) (setq n (car var1285)) (c!:one_operand n)) (setq var1285 (cdr var1285)) (go lab1284)) (prog (var1287) (setq var1287 (quote (eq equal atsoc memq iplus2 idifference assoc member itimes2 ilessp igreaterp qgetv get modular!-plus modular!-difference))) lab1286 (cond ((null var1287) (return nil))) (prog (n) (setq n (car var1287)) (c!:two_operands n)) (setq var1287 (cdr var1287)) (go lab1286)) (flag (quote (movr movk movk1 ldrglob call reloadenv fastget fastflag)) ( quote c!:set_r1)) (flag (quote (strglob qputv)) (quote c!:read_r1)) (flag (quote (qputv fastget fastflag)) (quote c!:read_r2)) (flag (quote (movr qputv)) (quote c!:read_r3)) (flag (quote (ldrglob strglob nilglob movk call)) (quote c!:read_env)) (fluid (quote (fn_used nil_used nilbase_used))) (de c!:live_variable_analysis (c!:all_blocks) (prog (changed z) (prog nil lab1294 (progn (setq changed nil) (prog (var1293) (setq var1293 c!:all_blocks ) lab1292 (cond ((null var1293) (return nil))) (prog (b) (setq b (car var1293 )) (prog (w live) (prog (var1289) (setq var1289 (get b (quote c!:where_to))) lab1288 (cond ((null var1289) (return nil))) (prog (x) (setq x (car var1289)) (cond ((atom x) (setq live (union live (get x (quote c!:live))))) (t (setq live (union live x))))) (setq var1289 (cdr var1289)) (go lab1288)) (setq w ( get b (quote c!:why))) (cond ((not (atom w)) (progn (cond ((or (eqcar w ( quote ifnull)) (eqcar w (quote ifequal))) (setq nil_used t))) (setq live ( union live (cdr w))) (cond ((and (eqcar (car w) (quote call)) (or (flagp ( cadar w) (quote c!:direct_predicate)) (and (flagp (cadar w) (quote c!:c_entrypoint)) (not (flagp (cadar w) (quote c!:direct_entrypoint)))))) ( setq nil_used t))) (cond ((and (eqcar (car w) (quote call)) (not (equal ( cadar w) c!:current_procedure)) (not (get (cadar w) (quote c!:direct_entrypoint))) (not (get (cadar w) (quote c!:c_entrypoint)))) (progn (setq fn_used t) (setq live (union (quote (env)) live)))))))) (prog (var1291 ) (setq var1291 (get b (quote c!:contents))) lab1290 (cond ((null var1291) ( return nil))) (prog (s) (setq s (car var1291)) (prog (op r1 r2 r3) (setq op ( car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond (( equal op (quote movk1)) (progn (cond ((equal r3 nil) (setq nil_used t)) (t ( cond ((equal r3 (quote t)) (setq nilbase_used t))))))) (t (cond ((and (atom op) (flagp op (quote c!:uses_nil))) (setq nil_used t))))) (cond ((flagp op ( quote c!:set_r1)) (cond ((memq r1 live) (setq live (delete r1 live))) (t ( cond ((equal op (quote call)) nil) (t (setq op (quote nop)))))))) (cond (( flagp op (quote c!:read_r1)) (setq live (union live (list r1))))) (cond (( flagp op (quote c!:read_r2)) (setq live (union live (list r2))))) (cond (( flagp op (quote c!:read_r3)) (setq live (union live (list r3))))) (cond (( equal op (quote call)) (progn (cond ((or (not (flagp (car r3) (quote c!:no_errors))) (flagp (car r3) (quote c!:c_entrypoint)) (get (car r3) (quote c!:direct_predicate))) (setq nil_used t))) (setq does_call t) (cond ((and ( not (eqcar r3 c!:current_procedure)) (not (get (car r3) (quote c!:direct_entrypoint))) (not (get (car r3) (quote c!:c_entrypoint)))) (setq fn_used t))) (cond ((not (flagp (car r3) (quote c!:no_errors))) (flag live ( quote c!:live_across_call)))) (setq live (union live r2))))) (cond ((flagp op (quote c!:read_env)) (setq live (union live (quote (env)))))))) (setq var1291 (cdr var1291)) (go lab1290)) (setq live (sort live (function orderp)) ) (cond ((not (equal live (get b (quote c!:live)))) (progn (put b (quote c!:live) live) (setq changed t)))))) (setq var1293 (cdr var1293)) (go lab1292 ))) (cond ((null (not changed)) (go lab1294)))) (setq z c!:registers) (setq c!:registers (setq c!:stacklocs nil)) (prog (var1296) (setq var1296 z) lab1295 (cond ((null var1296) (return nil))) (prog (r) (setq r (car var1296)) (cond ((flagp r (quote c!:live_across_call)) (setq c!:stacklocs (cons r c!:stacklocs))) (t (setq c!:registers (cons r c!:registers))))) (setq var1296 (cdr var1296)) (go lab1295)))) (de c!:insert1 (a b) (cond ((memq a b) b) (t (cons a b)))) (de c!:clash (a b) (cond ((equal (flagp a (quote c!:live_across_call)) (flagp b (quote c!:live_across_call))) (progn (put a (quote c!:clash) (c!:insert1 b (get a (quote c!:clash)))) (put b (quote c!:clash) (c!:insert1 a (get b ( quote c!:clash)))))))) (de c!:build_clash_matrix (c!:all_blocks) (prog nil (prog (var1304) (setq var1304 c!:all_blocks) lab1303 (cond ((null var1304) (return nil))) (prog (b) (setq b (car var1304)) (prog (live w) (prog (var1298) (setq var1298 (get b ( quote c!:where_to))) lab1297 (cond ((null var1298) (return nil))) (prog (x) ( setq x (car var1298)) (cond ((atom x) (setq live (union live (get x (quote c!:live))))) (t (setq live (union live x))))) (setq var1298 (cdr var1298)) ( go lab1297)) (setq w (get b (quote c!:why))) (cond ((not (atom w)) (progn ( setq live (union live (cdr w))) (cond ((and (eqcar (car w) (quote call)) (not (get (cadar w) (quote c!:direct_entrypoint))) (not (get (cadar w) (quote c!:c_entrypoint)))) (setq live (union (quote (env)) live))))))) (prog ( var1302) (setq var1302 (get b (quote c!:contents))) lab1301 (cond ((null var1302) (return nil))) (prog (s) (setq s (car var1302)) (prog (op r1 r2 r3) (setq op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond ((flagp op (quote c!:set_r1)) (cond ((memq r1 live) (progn (setq live (delete r1 live)) (cond ((equal op (quote reloadenv)) (setq reloadenv t))) ( prog (var1300) (setq var1300 live) lab1299 (cond ((null var1300) (return nil) )) (prog (v) (setq v (car var1300)) (c!:clash r1 v)) (setq var1300 (cdr var1300)) (go lab1299)))) (t (cond ((equal op (quote call)) nil) (t (progn ( setq op (quote nop)) (rplacd s (cons (car s) (cdr s))) (rplaca s op)))))))) ( cond ((flagp op (quote c!:read_r1)) (setq live (union live (list r1))))) ( cond ((flagp op (quote c!:read_r2)) (setq live (union live (list r2))))) ( cond ((flagp op (quote c!:read_r3)) (setq live (union live (list r3))))) ( cond ((equal op (quote call)) (setq live (union live r2)))) (cond ((flagp op (quote c!:read_env)) (setq live (union live (quote (env)))))))) (setq var1302 (cdr var1302)) (go lab1301)))) (setq var1304 (cdr var1304)) (go lab1303)) ( return nil))) (de c!:allocate_registers (rl) (prog (schedule neighbours allocation) (setq neighbours 0) (prog nil lab1308 (cond ((null rl) (return nil))) (prog (w x) ( setq w rl) (prog nil lab1305 (cond ((null (and w (greaterp (length (setq x ( get (car w) (quote c!:clash)))) neighbours))) (return nil))) (setq w (cdr w)) (go lab1305)) (cond (w (progn (setq schedule (cons (car w) schedule)) (setq rl (deleq (car w) rl)) (prog (var1307) (setq var1307 x) lab1306 (cond ((null var1307) (return nil))) (prog (r) (setq r (car var1307)) (put r (quote c!:clash) (deleq (car w) (get r (quote c!:clash))))) (setq var1307 (cdr var1307)) (go lab1306)))) (t (setq neighbours (plus neighbours 1))))) (go lab1308)) (prog (var1312) (setq var1312 schedule) lab1311 (cond ((null var1312) (return nil))) (prog (r) (setq r (car var1312)) (prog (poss) (setq poss allocation) (prog (var1310) (setq var1310 (get r (quote c!:clash))) lab1309 (cond ((null var1310) (return nil))) (prog (x) (setq x (car var1310)) (setq poss (deleq (get x (quote c!:chosen)) poss))) (setq var1310 (cdr var1310)) (go lab1309)) (cond ((null poss) (progn (setq poss (c!:my_gensym)) (setq allocation (append allocation (list poss))))) (t (setq poss (car poss)) )) (put r (quote c!:chosen) poss))) (setq var1312 (cdr var1312)) (go lab1311) ) (return allocation))) (de c!:remove_nops (c!:all_blocks) (prog (var1322) (setq var1322 c!:all_blocks) lab1321 (cond ((null var1322) (return nil))) (prog (b) (setq b (car var1322)) (prog (r) (prog (var1317) (setq var1317 (get b (quote c!:contents))) lab1316 (cond ((null var1317) (return nil))) (prog (s) (setq s (car var1317)) (cond ((not (eqcar s (quote nop))) (prog (op r1 r2 r3) (setq op (car s)) (setq r1 (cadr s)) (setq r2 (caddr s)) (setq r3 (cadddr s)) (cond ((or (flagp op (quote c!:set_r1)) (flagp op (quote c!:read_r1))) (setq r1 ( get r1 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r2)) (setq r2 ( get r2 (quote c!:chosen))))) (cond ((flagp op (quote c!:read_r3)) (setq r3 ( get r3 (quote c!:chosen))))) (cond ((equal op (quote call)) (setq r2 (prog ( var1314 var1315) (setq var1314 r2) lab1313 (cond ((null var1314) (return ( reversip var1315)))) (prog (v) (setq v (car var1314)) (setq var1315 (cons ( get v (quote c!:chosen)) var1315))) (setq var1314 (cdr var1314)) (go lab1313) )))) (cond ((not (and (equal op (quote movr)) (equal r1 r3))) (setq r (cons ( list op r1 r2 r3) r)))))))) (setq var1317 (cdr var1317)) (go lab1316)) (put b (quote c!:contents) (reversip r)) (setq r (get b (quote c!:why))) (cond (( not (atom r)) (put b (quote c!:why) (cons (car r) (prog (var1319 var1320) ( setq var1319 (cdr r)) lab1318 (cond ((null var1319) (return (reversip var1320 )))) (prog (v) (setq v (car var1319)) (setq var1320 (cons (get v (quote c!:chosen)) var1320))) (setq var1319 (cdr var1319)) (go lab1318)))))))) (setq var1322 (cdr var1322)) (go lab1321))) (fluid (quote (c!:error_labels))) (de c!:find_error_label (why env depth) (prog (w z) (setq z (list why env depth)) (setq w (assoc!*!* z c!:error_labels)) (cond ((null w) (progn (setq w (cons z (c!:my_gensym))) (setq c!:error_labels (cons w c!:error_labels))))) (return (cdr w)))) (de c!:assign (u v c) (cond ((flagp u (quote fluid)) (cons (list (quote strglob) v u (c!:find_literal u)) c)) (t (cons (list (quote movr) u nil v) c) ))) (de c!:insert_tailcall (b) (prog (why dest contents fcall res w) (setq why ( get b (quote c!:why))) (setq dest (get b (quote c!:where_to))) (setq contents (get b (quote c!:contents))) (prog nil lab1323 (cond ((null (and contents ( not (eqcar (car contents) (quote call))))) (return nil))) (progn (setq w ( cons (car contents) w)) (setq contents (cdr contents))) (go lab1323)) (cond ( (null contents) (return nil))) (setq fcall (car contents)) (setq contents ( cdr contents)) (setq res (cadr fcall)) (prog nil lab1324 (cond ((null w) ( return nil))) (progn (cond ((eqcar (car w) (quote reloadenv)) (setq w (cdr w) )) (t (cond ((and (eqcar (car w) (quote movr)) (equal (cadddr (car w)) res)) (progn (setq res (cadr (car w))) (setq w (cdr w)))) (t (setq res (setq w nil) )))))) (go lab1324)) (cond ((null res) (return nil))) (cond ((c!:does_return res why dest) (cond ((equal (car (cadddr fcall)) c!:current_procedure) (progn (prog (var1326) (setq var1326 (pair c!:current_args (caddr fcall))) lab1325 (cond ((null var1326) (return nil))) (prog (p) (setq p (car var1326)) (setq contents (c!:assign (car p) (cdr p) contents))) (setq var1326 (cdr var1326)) (go lab1325)) (put b (quote c!:contents) contents) (put b (quote c!:why) ( quote goto)) (put b (quote c!:where_to) (list restart_label)))) (t (progn ( setq nil_used t) (put b (quote c!:contents) contents) (put b (quote c!:why) ( cons (list (quote call) (car (cadddr fcall))) (caddr fcall))) (put b (quote c!:where_to) nil)))))))) (de c!:does_return (res why where_to) (cond ((not (equal why (quote goto))) nil) (t (cond ((not (atom (car where_to))) (equal res (caar where_to))) (t ( prog (contents) (setq where_to (car where_to)) (setq contents (reverse (get where_to (quote c!:contents)))) (setq why (get where_to (quote c!:why))) ( setq where_to (get where_to (quote c!:where_to))) (prog nil lab1327 (cond (( null contents) (return nil))) (cond ((eqcar (car contents) (quote reloadenv)) (setq contents (cdr contents))) (t (cond ((and (eqcar (car contents) (quote movr)) (equal (cadddr (car contents)) res)) (progn (setq res (cadr (car contents))) (setq contents (cdr contents)))) (t (setq res (setq contents nil) ))))) (go lab1327)) (cond ((null res) (return nil)) (t (return ( c!:does_return res why where_to)))))))))) (de c!:pushpop (op v) (prog (n w) (cond ((null v) (return nil))) (setq n ( length v)) (prog nil lab1329 (cond ((null (greaterp n 0)) (return nil))) ( progn (setq w n) (cond ((greaterp w 6) (setq w 6))) (setq n (difference n w)) (cond ((equal w 1) (c!:printf " %s(%s);\n" op (car v))) (t (progn ( c!:printf " %s%d(%s" op w (car v)) (setq v (cdr v)) (prog (i) (setq i 2) lab1328 (cond ((minusp (times 1 (difference w i))) (return nil))) (progn ( c!:printf ",%s" (car v)) (setq v (cdr v))) (setq i (plus i 1)) (go lab1328)) (c!:printf ");\n"))))) (go lab1329)))) (de c!:optimise_flowgraph (c!:startpoint c!:all_blocks env argch args) (prog (w n locs stacks c!:error_labels fn_used nil_used nilbase_used) (prog ( var1331) (setq var1331 c!:all_blocks) lab1330 (cond ((null var1331) (return nil))) (prog (b) (setq b (car var1331)) (c!:insert_tailcall b)) (setq var1331 (cdr var1331)) (go lab1330)) (setq c!:startpoint (c!:branch_chain c!:startpoint nil)) (remflag c!:all_blocks (quote c!:visited)) ( c!:live_variable_analysis c!:all_blocks) (c!:build_clash_matrix c!:all_blocks ) (cond ((and c!:error_labels env) (setq reloadenv t))) (prog (var1335) (setq var1335 env) lab1334 (cond ((null var1335) (return nil))) (prog (u) (setq u (car var1335)) (prog (var1333) (setq var1333 env) lab1332 (cond ((null var1333) (return nil))) (prog (v) (setq v (car var1333)) (c!:clash (cdr u) ( cdr v))) (setq var1333 (cdr var1333)) (go lab1332))) (setq var1335 (cdr var1335)) (go lab1334)) (setq locs (c!:allocate_registers c!:registers)) ( setq stacks (c!:allocate_registers c!:stacklocs)) (flag stacks (quote c!:live_across_call)) (c!:remove_nops c!:all_blocks) (setq c!:startpoint ( c!:branch_chain c!:startpoint nil)) (remflag c!:all_blocks (quote c!:visited) ) (setq c!:startpoint (c!:branch_chain c!:startpoint t)) (remflag c!:all_blocks (quote c!:visited)) (cond (does_call (setq nil_used t))) (cond (nil_used (c!:printf " Lisp_Object nil = C_nil;\n")) (t (cond ( nilbase_used (c!:printf " nil_as_base\n"))))) (cond (locs (progn ( c!:printf " Lisp_Object %s" (car locs)) (prog (var1337) (setq var1337 (cdr locs)) lab1336 (cond ((null var1337) (return nil))) (prog (v) (setq v (car var1337)) (c!:printf ", %s" v)) (setq var1337 (cdr var1337)) (go lab1336)) ( c!:printf ";\n")))) (cond (fn_used (c!:printf " Lisp_Object fn;\n"))) ( cond (nil_used (c!:printf " CSL_IGNORE(nil);\n")) (t (cond (nilbase_used ( progn (c!:printf "#ifndef NILSEG_EXTERNS\n") (c!:printf " CSL_IGNORE(nil);\n") (c!:printf "#endif\n")))))) (cond ((or (equal (car argch) 0) (geq (car argch) 3)) (c!:printf " argcheck(nargs, %s, \q%s\q);\n" (car argch) (cdr argch)))) (c!:printf "#ifdef DEBUG\n") (c!:printf " if (check_env(env)) return aerror(\qenv for %s\q);\n" (cdr argch)) ( c!:printf "#endif\n") (cond (does_call (progn (c!:printf " if (stack >= stacklimit)\n") (c!:printf " {\n") (c!:pushpop (quote push) args) (c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n") (c!:pushpop (quote pop) (reverse args)) (c!:printf " nil = C_nil;\n") (c!:printf " if (exception_pending()) return nil;\n") (c!:printf " }\n")))) ( cond (reloadenv (c!:printf " push(env);\n")) (t (c!:printf " CSL_IGNORE(env);\n"))) (setq n 0) (cond (stacks (progn (c!:printf "% ") (remflag '(geq leq neq logand logor logxor leftshift princ printc evenp reversip seprp atsoc eqcar flagp!*!* flagpcar get!* prin1 prin2 apply0 apply1 apply2 apply3 smemq spaces subla gcdn lcmn printprompt pair putc) 'lose) (symbol!-make!-fastget 32) (symbol!-make!-fastget 'noncom 0) % built into the kernel (symbol!-make!-fastget 'lose 1) (flag '(raise lower echo comp plap pgwd pwrds savedef) 'switch) (make!-special '!*echo) (setq !*echo nil) (make!-special '!*raise) (setq !*raise nil) (make!-special '!*lower) (setq !*lower t) (make!-special '!*savedef) % I only nil out !*savedef if it is not already present because of % some bootstrapping delicacies when this file is re-loaded. (if (not (boundp '!*savedef)) (setq !*savedef nil)) (make!-special '!*comp) (setq !*comp nil) (make!-special '!*plap) (setq !*plap nil) (make!-special '!*pgwd) (setq !*pgwd nil) (make!-special '!*pwrds) (setq !*pwrds t) % Until the following lines have been executed the % bitwise operations listed here will not work. (progn (symbol!-set!-env 'logand 1) (symbol!-set!-env 'logxor 6) (symbol!-set!-env 'logor 7) (symbol!-set!-env 'logeqv 9)) (make!-special '!!fleps1) (setq !!fleps1 1.0e-12) (symbol!-set!-env 'safe!-fp!-plus '!!fleps1) (de rplacw (a b) (progn (rplaca a (car b)) (rplacd a (cdr b)))) (de expand (l fn) (cond ((null (cdr l)) (car l)) (t (list fn (car l) (expand (cdr l) fn))))) (dm plus (a) (cond ((null (cdr a)) 0) (t (expand (cdr a) 'plus2)))) (dm times (a) (cond ((null (cdr a)) 1) (t (expand (cdr a) 'times2)))) (de mapcar (l fn) (prog (r) top (cond ((null l) (return (reversip r)))) (setq r (cons (funcall fn (car l)) r)) (setq l (cdr l)) (go top))) (de maplist (l fn) (prog (r) top (cond ((null l) (return (reversip r)))) (setq r (cons (funcall fn l) r)) (setq l (cdr l)) (go top))) (de mapcan (l fn) (cond ((null l) nil) (t (nconc (funcall fn (car l)) (mapcan (cdr l) fn))))) (de mapcon (l fn) (cond ((null l) nil) (t (nconc (funcall fn l) (mapcon (cdr l) fn))))) (de mapc (l fn) (prog () top (cond ((null l) (return nil))) (funcall fn (car l)) (setq l (cdr l)) (go top))) (de map (l fn) (prog () top (cond ((null l) (return nil))) (funcall fn l) (setq l (cdr l)) (go top))) (de copy (a) (cond ((atom a) a) (t (cons (copy (car a)) (copy (cdr a)))))) (de sassoc (a l fn) (cond ((atom l) (funcall fn)) ((equal a (caar l)) (car l)) (t (sassoc a (cdr l) fn)))) (de rassoc (x l) % Not in Standard Lisp (prog () loop (cond ((atom l) (return nil)) ((equal x (cdar l)) (return (car l))) (t (setq l (cdr l)) (go loop))) )) (de lastcar (x) % Not in Standard Lisp (cond ((null x) nil) ((null (cdr x)) (car x)) (t (lastcar (cdr x))))) % The system-coded primitive function INTERNAL-OPEN opens a file, and takes % a second argument that shows what options are wanted. See "print.c" for an % explanation of the bits. (de open (a b) (cond ((eq b 'input) (internal!-open a (plus 1 64))) % if-does-not-exist error ((eq b 'output) (internal!-open a (plus 2 20 32))) % if-does-not-exist create, % if-exists new-version ((eq b 'append) (internal!-open a (plus 2 8 32))) % if-exists append (t (error "bad direction ~A in open" b)))) (de binopen (a b) (cond ((eq b 'input) (internal!-open a (plus 1 64 128))) ((eq b 'output) (internal!-open a (plus 2 20 32 128))) ((eq b 'append) (internal!-open a (plus 2 8 32 128))) (t (error "bad direction ~A in binopen" b)))) (de pipe!-open (c d) (cond ((eq d 'input) (internal!-open c (plus 1 256))) ((eq d 'output) (internal!-open c (plus 2 256))) (t (error "bad direction ~A in pipe-open" d)))) (de putd (a type b) (progn (cond ((eqcar b 'funarg) (setq b (cons 'lambda (cddr b))))) (cond ((flagp a 'lose) (progn (terpri) (princ "+++ ") (prin a) (printc " not defined (LOSE flag)") nil)) (t (progn (cond ((and !*redefmsg (getd a)) (progn (terpri) (princ "+++ ") (prin a) (printc " redefined")))) (cond ((eq type 'expr) (symbol!-set!-definition a b)) ((eq type 'subr) (symbol!-set!-definition a b)) ((and (eq type 'macro) (eqcar b 'lambda)) (eval (list!* 'dm a (cdr b)))) % CSL does not really support user-defined special forms and so at some % stage I will make "df" a macro that makes some attempt to simulate the % desired behaviour using a macro. ((and (eq type 'fexpr) (eqcar b 'lambda)) (eval (list!* 'df a (cdr b)))) (t (error "Bad type ~S in putd" type))) a)))))) % A version of this in rlisp/rsupport.red tries to compile the % odd sort of definition involved, but I will not! (de putc (a b c) (put a b c)) (de traceset1 (name) (prog (w !*comp) (setq w (getd name)) (cond ((not (and (eqcar w 'expr) (eqcar (cdr w) 'lambda))) (princ "+++++ ") (prin name) (printc " should be interpreted for traceset to work") (return nil))) (putd name 'expr (subst 'noisy!-setq 'setq (cdr w))) (trace (list name)))) (de untraceset1 (name) (prog (w !*comp) (setq w (getd name)) (cond ((not (and (eqcar w 'expr) (eqcar (cdr w) 'lambda))) (princ "+++++ ") (prin name) (printc " should be interpreted for untraceset to work") (return nil))) (putd name 'expr (subst 'setq 'noisy!-setq (cdr w))) (untrace (list name)))) (de traceset (l) (mapc l (function traceset1))) (de untraceset (l) (mapc l (function untraceset1))) (de deflist (a b) (prog (r) top (cond ((null a) (return (reversip r)))) (put (caar a) b (cadar a)) (setq r (cons (caar a) r)) (setq a (cdr a)) (go top))) (de global (l) (prog nil top (cond ((null l) (return nil))) (make!-global (car l)) (cond ((not (boundp (car l))) (set (car l) nil))) (setq l (cdr l)) (go top))) (de fluid (l) (prog nil top (cond ((null l) (return nil))) (make!-special (car l)) (cond ((not (boundp (car l))) (set (car l) nil))) (setq l (cdr l)) (go top))) (de unglobal (l) (prog () top (cond ((null l) (return nil))) (unmake!-global (car l)) (setq l (cdr l)) (go top))) (de unfluid (l) (prog () top (cond ((null l) (return nil))) (unmake!-special (car l)) (setq l (cdr l)) (go top))) (global '(ofl!*)) (de printprompt (u) nil) (global '(program!* ttype!* eof!*)) (global '(crbuf!*)) (global '(blank !$eol!$ tab !$eof!$ esc!*)) (fluid '(!*notailcall !*carcheckflag)) (fluid '(!*terminal!-io!* !*standard!-input!* !*standard!-output!* !*error!-output!* !*trace!-output!* !*debug!-io!* !*query!-io!*)) (setq !*notailcall nil) (setq !*carcheckflag t) (de carcheck (n) (prog (old) (cond ((zerop n) (setq n nil))) (setq old !*carcheckflag) (setq !*carcheckflag n) (return old))) (progn % The "special-char" numeric codes here are all very odd and are of no % relevance beyond the initial build stages of this Lisp. In particular they % have little or no resemblance to any widely used character code schemes. (setq blank (compress (list '!! (special!-char 0)))) (setq !$eol!$ (compress (list '!! (special!-char 1)))) (setq tab (compress (list '!! (special!-char 3)))) (setq esc!* (compress (list '!! (special!-char 9)))) (setq !$eof!$ (special!-char 8)) nil) (setq crbuf!* (list !$eol!$)) % may not be necessary % Since this should never get called I will just not define it here! %(de symerr (u v) % (progn (terpri) % (print (list 'symerr u v)) % (error 'failure))) (global '(!*full!-oblist)) (setq !*full!-oblist nil) (de s!:oblist (v r) (prog (n a) (setq n (upbv v)) top (cond ((minusp n) (return r))) (setq a (getv v n)) (cond ((and (idp a) % I list things that have a function value of some sort or that have % a non-empty property-list. Symbols that have been mentioned but which do % not have properties or values are missed out since they are dull and % seeing them listed is probably not very helpful. People may disagree % about that... if so it would be very easy to remove the tests here and % end up listing everything. Eg some symbols exist and are used as property- % names (via PUT and GET) but are not used for anything else... % % Well, the flag !*full!-oblist can be set to force inclusion of % everything! (or !*full!-oblist (symbol!-function a) (macro!-function a) (special!-form!-p a) (fluidp a) (globalp a) (not (null (plist a))))) (setq r (cons a r)))) (setq n (sub1 n)) (go top))) (de s!:oblist1 (v r) (cond ((null v) r) ((vectorp v) (s!:oblist v r)) % This allows for segmented object-vectors (t (s!:oblist (car v) (s!:oblist1 (cdr v) r))))) (de oblist () (sort (s!:oblist1 (getv !*package!* 1) nil) (function orderp))) % Now a few things not needed by Standard Lisp but maybe helpful % when using Lisp directly. (de s!:make!-psetq!-vars (u) (if (null u) nil (if (null (cdr u)) (error "odd number of items in psetq") (cons (gensym) (s!:make!-psetq!-vars (cddr u)))))) (de s!:make!-psetq!-bindings (vars u) (if (null u) nil (cons (list (car vars) (cadr u)) (s!:make!-psetq!-bindings (cdr vars) (cddr u))))) (de s!:make!-psetq!-assignments (vars u) (if (null u) nil (cons (list 'setq (car u) (car vars)) (s!:make!-psetq!-assignments (cdr vars) (cddr u))))) (dm psetq (x) (!~let ((vars (s!:make!-psetq!-vars (cdr x)))) `(let!* ,(s!:make!-psetq!-bindings vars (cdr x)) ,@(s!:make!-psetq!-assignments vars (cdr x))))) % (do ((v i s) ..) % (end result ...) % body) (de s!:do!-bindings (u) (if (null u) nil (if (atom (car u)) (cons (car u) (s!:do!-bindings (cdr u))) (if (null (cdar u)) (cons (list (caar u) nil) (s!:do!-bindings (cdr u))) (cons (list (caar u) (cadar u)) (s!:do!-bindings (cdr u))))))) (de s!:do!-endtest (u) (if (null u) nil (car u))) (de s!:do!-result (u) (if (null u) nil (cdr u))) (de s!:do!-updates (u) (if (null u) nil (!~let ((v (car u)) (x (s!:do!-updates (cdr u)))) (if (or (atom v) (null (cdr v)) (null (cddr v))) x (cons (car v) (cons (caddr v) x)))))) (de s!:expand!-do (u letter setter) (let!* ((bindings (s!:do!-bindings (car u))) (result (s!:do!-result (cadr u))) (updates (s!:do!-updates (car u))) (body (cddr u)) (endtest (s!:do!-endtest (cadr u))) (upd (if updates (list (cons setter updates)) nil)) (res (if (null result) nil (if (null (cdr result)) (car result) (cons 'progn result)))) (x (if (null endtest) nil `((if ,endtest (return ,res))))) (g (gensym))) (if bindings `(,letter ,bindings (prog nil ,g ,@x ,@body ,@upd (go ,g))) `(prog nil ,g ,@x ,@body ,@upd (go ,g))))) (dm do (u) (s!:expand!-do (cdr u) '!~let 'psetq)) (dm do!* (u) (s!:expand!-do (cdr u) 'let!* 'setq)) (de s!:expand!-dolist (vir b) (prog (l v var init res) (setq var (car vir)) (setq init (car (setq vir (cdr vir)))) (setq res (cdr vir)) (setq v (gensym)) (setq l (gensym)) (return `(prog (,v ,var) (setq ,v ,init) ,l (cond ((null ,v) (return (progn ,@res)))) (setq ,var (car ,v)) ,@b (setq ,v (cdr ,v)) (go ,l))))) (dm dolist (u) (s!:expand!-dolist (cadr u) (cddr u))) (de s!:expand!-dotimes (vnr b) (prog (l v var count res) (setq var (car vnr)) (setq count (car (setq vnr (cdr vnr)))) (setq res (cdr vnr)) (setq v (gensym)) (setq l (gensym)) (return `(prog (,v ,var) (setq ,v ,count) (setq ,var 0) ,l (cond ((not (lessp ,var ,v)) (return (progn ,@res)))) ,@b (setq ,var (add1 ,var)) (go ,l))))) (dm dotimes (u) (s!:expand!-dotimes (cadr u) (cddr u))) (flag '(geq leq neq logand logor logxor leftshift princ printc evenp reversip seprp atsoc eqcar flagp!*!* flagpcar get!* prin1 prin2 apply0 apply1 apply2 apply3 smemq spaces subla gcdn lcmn printprompt pair putc) 'lose) % end of compat.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/ccomp.red0000644000175000017500000040776011550002751023365 0ustar giovannigiovanni% "ccomp.red" Copyright 1991-2010, Codemist Ltd % % Compiler that turns Lisp code into C in a way that fits in % with the conventions used with CSL/CCL % % A C Norman % %% %% Copyright (C) 2010, following the master REDUCE source files. * %% * %% Redistribution and use in source and binary forms, with or without * %% modification, are permitted provided that the following conditions are * %% met: * %% * %% * Redistributions of source code must retain the relevant * %% copyright notice, this list of conditions and the following * %% disclaimer. * %% * Redistributions in binary form must reproduce the above * %% copyright notice, this list of conditions and the following * %% disclaimer in the documentation and/or other materials provided * %% with the distribution. * %% * %% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * %% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * %% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * %% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * %% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * %% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * %% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * %% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * %% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * %% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * %% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * %% DAMAGE. * %% symbolic; global '(!*fastvector !*unsafecar); flag('(fastvector unsafecar), 'switch); % % I start with some utility functions that provide something % related to a FORMAT or PRINTF facility % fluid '(C_file L_file O_file L_contents Setup_name File_name); symbolic macro procedure c!:printf(u,!&optional,env); % inspired by the C printf function, but much less general. % This macro is to provide the illusion that printf can take an % arbitrary number of arguments. list('c!:printf1, cadr u, 'list . cddr u); symbolic procedure c!:printf1(fmt, args); % this is the inner works of print formatting. % the special sequences that can occur in format strings are % %s use princ (to print a name?) % %d use princ (to print a number?) % %a use prin % %c as prin, but do not generate the sequence % "*/" as part of the output (!) % %t do a ttab() % %< ensure at least 2 free chars on line % %v print a variable.... magic for this compiler % \n do a terpri() % \q princ '!" to display quote marks begin scalar a, c; fmt := explode2 fmt; while fmt do << c := car fmt; fmt := cdr fmt; if c = '!\ and (car fmt = '!n or car fmt = '!N) then << terpri(); fmt := cdr fmt >> else if c = '!\ and (car fmt = '!q or car fmt = '!Q) then << princ '!"; fmt := cdr fmt >> else if c = '!% then << c := car fmt; if null args then a := 'missing_arg else a := car args; if c = '!v or c = '!V then if flagp(a, 'c!:live_across_call) then << princ "stack["; princ(-get(a, 'c!:location)); princ "]" >> else princ a else if c = '!c or c = '!C then c!:safeprin a else if c = '!a or c = '!A then prin a else if c = '!t or c = '!T then ttab a else if c = '!< then << args := nil . args; % dummy so in effect no arg is used. if posn() > 70 then terpri() >> else princ a; if args then args := cdr args; fmt := cdr fmt >> else princ c >> end; % The following yukky code is for use in displaying C comments. I want to be % able to annotate my code as in % ... /* load the literal "something" */ % where the literal is displayed. But if the literal were to be a string % with the character sequence "*/" within it I would get into trouble... symbolic procedure c!:safeprin x; begin scalar a, b; a := explode x; while a do << if eqcar(a, '!/) and b then princ " "; princ car a; b := eqcar(a, '!*); a := cdr a >>; end; symbolic procedure c!:valid_fndef(args, body); if ('!&optional memq args) or ('!&rest memq args) then nil else c!:valid_list body; symbolic procedure c!:valid_list x; if null x then t else if atom x then nil else if not c!:valid_expr car x then nil else c!:valid_list cdr x; symbolic procedure c!:valid_expr x; if atom x then t else if not atom car x then << if not c!:valid_list cdr x then nil else if not eqcar(car x, 'lambda) then nil else if atom cdar x then nil else c!:valid_fndef(cadar x, cddar x) >> else if not idp car x then nil else if eqcar(x, 'quote) then t else begin scalar h; h := get(car x, 'c!:valid); if null h then return c!:valid_list cdr x; return funcall(h, cdr x) end; % This establishes a default handler for each special form so that % any that I forget to treat more directly will cause a tidy error % if found in compiled code. symbolic procedure c!:cspecform(x, env); error(0, list("special form", x)); symbolic procedure c!:valid_specform x; nil; << put('and, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('block, 'c!:code, function c!:cspecform); !#endif put('catch, 'c!:code, function c!:cspecform); put('compiler!-let, 'c!:code, function c!:cspecform); put('cond, 'c!:code, function c!:cspecform); put('declare, 'c!:code, function c!:cspecform); put('de, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('defun, 'c!:code, function c!:cspecform); !#endif put('eval!-when, 'c!:code, function c!:cspecform); put('flet, 'c!:code, function c!:cspecform); put('function, 'c!:code, function c!:cspecform); put('go, 'c!:code, function c!:cspecform); put('if, 'c!:code, function c!:cspecform); put('labels, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('let, 'c!:code, function c!:cspecform); !#else put('!~let, 'c!:code, function c!:cspecform); !#endif put('let!*, 'c!:code, function c!:cspecform); put('list, 'c!:code, function c!:cspecform); put('list!*, 'c!:code, function c!:cspecform); put('macrolet, 'c!:code, function c!:cspecform); put('multiple!-value!-call, 'c!:code, function c!:cspecform); put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); put('or, 'c!:code, function c!:cspecform); put('prog, 'c!:code, function c!:cspecform); put('prog!*, 'c!:code, function c!:cspecform); put('prog1, 'c!:code, function c!:cspecform); put('prog2, 'c!:code, function c!:cspecform); put('progn, 'c!:code, function c!:cspecform); put('progv, 'c!:code, function c!:cspecform); put('quote, 'c!:code, function c!:cspecform); put('return, 'c!:code, function c!:cspecform); put('return!-from, 'c!:code, function c!:cspecform); put('setq, 'c!:code, function c!:cspecform); put('tagbody, 'c!:code, function c!:cspecform); put('the, 'c!:code, function c!:cspecform); put('throw, 'c!:code, function c!:cspecform); put('unless, 'c!:code, function c!:cspecform); put('unwind!-protect, 'c!:code, function c!:cspecform); put('when, 'c!:code, function c!:cspecform) ; % I comment out lines here when (a) the special form involved is % supported by my compilation into C and (b) its syntax is such that % I can analyse it as if it was an ordinary function. Eg (AND a b c) % % Cases like PROG are left in because the syntax (PROG (v1 v2) ...) needs % special treatment. % % Cases like UNWIND-PROTECT are left in because at the time of writing this % comment they are not supported. % put('and, 'c!:valid, function c!:valid_specform); !#if common!-lisp!-mode % put('block, 'c!:valid, function c!:valid_specform); !#endif put('catch, 'c!:valid, function c!:valid_specform); put('compiler!-let, 'c!:valid, function c!:valid_specform); put('cond, 'c!:valid, function c!:valid_specform); put('declare, 'c!:valid, function c!:valid_specform); put('de, 'c!:valid, function c!:valid_specform); !#if common!-lisp!-mode put('defun, 'c!:valid, function c!:valid_specform); !#endif put('eval!-when, 'c!:valid, function c!:valid_specform); put('flet, 'c!:valid, function c!:valid_specform); put('function, 'c!:valid, function c!:valid_specform); % put('go, 'c!:valid, function c!:valid_specform); % put('if, 'c!:valid, function c!:valid_specform); put('labels, 'c!:valid, function c!:valid_specform); !#if common!-lisp!-mode put('let, 'c!:valid, function c!:valid_specform); !#else put('!~let, 'c!:valid, function c!:valid_specform); !#endif put('let!*, 'c!:valid, function c!:valid_specform); % put('list, 'c!:valid, function c!:valid_specform); % put('list!*, 'c!:valid, function c!:valid_specform); put('macrolet, 'c!:valid, function c!:valid_specform); put('multiple!-value!-call, 'c!:valid, function c!:valid_specform); put('multiple!-value!-prog1, 'c!:valid, function c!:valid_specform); % put('or, 'c!:valid, function c!:valid_specform); put('prog, 'c!:valid, function c!:valid_specform); put('prog!*, 'c!:valid, function c!:valid_specform); % put('prog1, 'c!:valid, function c!:valid_specform); % put('prog2, 'c!:valid, function c!:valid_specform); % put('progn, 'c!:valid, function c!:valid_specform); put('progv, 'c!:valid, function c!:valid_specform); put('quote, 'c!:valid, function c!:valid_specform); % put('return, 'c!:valid, function c!:valid_specform); % put('return!-from, 'c!:valid, function c!:valid_specform); % put('setq, 'c!:valid, function c!:valid_specform); % put('tagbody, 'c!:valid, function c!:valid_specform); put('the, 'c!:valid, function c!:valid_specform); put('throw, 'c!:valid, function c!:valid_specform); % put('unless, 'c!:valid, function c!:valid_specform); put('unwind!-protect, 'c!:valid, function c!:valid_specform); % put('when, 'c!:valid, function c!:valid_specform) >>; fluid '(c!:current_procedure c!:current_args c!:current_block c!:current_contents c!:all_blocks c!:registers c!:stacklocs); fluid '(c!:available c!:used); c!:available := c!:used := nil; symbolic procedure c!:reset_gensyms(); << remflag(c!:used, 'c!:live_across_call); remflag(c!:used, 'c!:visited); while c!:used do << remprop(car c!:used, 'c!:contents); remprop(car c!:used, 'c!:why); remprop(car c!:used, 'c!:where_to); remprop(car c!:used, 'c!:count); remprop(car c!:used, 'c!:live); remprop(car c!:used, 'c!:clash); remprop(car c!:used, 'c!:chosen); remprop(car c!:used, 'c!:location); if plist car c!:used then begin scalar o; o := wrs nil; princ "+++++ "; prin car c!:used; princ " "; prin plist car c!:used; terpri(); wrs o end; c!:available := car c!:used . c!:available; c!:used := cdr c!:used >> >>; !#if common!-lisp!-mode fluid '(my_gensym_counter); my_gensym_counter := 0; !#endif symbolic procedure c!:my_gensym(); begin scalar w; if c!:available then << w := car c!:available; c!:available := cdr c!:available >> !#if common!-lisp!-mode else w := compress1 ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); !#else else w := gensym1 "v"; !#endif c!:used := w . c!:used; if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; return w end; symbolic procedure c!:newreg(); begin scalar r; r := c!:my_gensym(); c!:registers := r . c!:registers; return r end; symbolic procedure c!:startblock s; << c!:current_block := s; c!:current_contents := nil >>; symbolic procedure c!:outop(a,b,c,d); if c!:current_block then c!:current_contents := list(a,b,c,d) . c!:current_contents; symbolic procedure c!:endblock(why, where_to); if c!:current_block then << % Note that the operations within a block are in reversed order. put(c!:current_block, 'c!:contents, c!:current_contents); put(c!:current_block, 'c!:why, why); put(c!:current_block, 'c!:where_to, where_to); c!:all_blocks := c!:current_block . c!:all_blocks; c!:current_contents := nil; c!:current_block := nil >>; % % Now for a general driver for compilation % symbolic procedure c!:cval_inner(x, env); begin scalar helper; % NB use the "improve" function from the regular compiler here... x := s!:improve x; % atoms and embedded lambda expressions need their own treatment. if atom x then return c!:catom(x, env) else if eqcar(car x, 'lambda) then return c!:clambda(cadar x, cddar x, cdr x, env) % a c!:code property gives direct control over compilation else if helper := get(car x, 'c!:code) then return funcall(helper, x, env) % compiler-macros take precedence over regular macros, so that I can % make special expansions in the context of compilation. Only used if the % expansion is non-nil else if (helper := get(car x, 'c!:compile_macro)) and (helper := funcall(helper, x)) then return c!:cval(helper, env) % regular Lisp macros get expanded else if idp car x and (helper := macro!-function car x) then return c!:cval(funcall(helper, x), env) % anything not recognised as special will be turned into a % function call, but there will still be special cases, such as % calls to the current function, calls into the C-coded kernel, etc. else return c!:ccall(car x, cdr x, env) end; symbolic procedure c!:cval(x, env); begin scalar r; r := c!:cval_inner(x, env); if r and not member!*!*(r, c!:registers) then error(0, list(r, "not a register", x)); return r end; symbolic procedure c!:clambda(bvl, body, args, env); % This is for ((lambda bvl body) args) and it will need to deal with % local declarations at the head of body. On this call body is a list of % forms. begin scalar w, w1, fluids, env1, decs; env1 := car env; w := for each a in args collect c!:cval(a, env); w1 := s!:find_local_decs(body, nil); localdecs := car w1 . localdecs; w1 := cdr w1; % Tidy up so that body is a single expression. if null w1 then body := nil else if null cdr w1 then body := car w1 else body := 'progn . w1; for each x in bvl do if not fluidp x and not globalp x and c!:local_fluidp(x, localdecs) then << make!-special x; decs := x . decs >>; for each v in bvl do << if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v end; if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('strglob, car w, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movr, cdar env1, nil, car w) >>; w := cdr w >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); w := c!:cval(body, env); for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); unfluid decs; localdecs := cdr localdecs; return w end; symbolic procedure c!:locally_bound(x, env); atsoc(x, car env); flag('(nil t), 'c!:constant); fluid '(literal_vector); symbolic procedure c!:find_literal x; begin scalar n, w; w := literal_vector; n := 0; while w and not (car w = x) do << n := n + 1; w := cdr w >>; if null w then literal_vector := append(literal_vector, list x); return n end; symbolic procedure c!:catom(x, env); begin scalar v, w; v := c!:newreg(); % I may need to think harder here about things that are both locally % bound AND fluid. But when I bind a fluid I put a dummy name onto env % and use that as a place to save the old value of the fluid, so I believe % I may be safe. Well not quite I guess. How about % (prog (a) % a local variable % (prog (a) (declare (special a)) % hah this one os fluid! % reference "a" here... % and related messes. So note that the outer binding means that a is % locally bound but the inner binding means that a fluid binding must % be used. if idp x and (fluidp x or globalp x) then c!:outop('ldrglob, v, x, c!:find_literal x) else if idp x and (w := c!:locally_bound(x, env)) then c!:outop('movr, v, nil, cdr w) else if null x or x = 't or c!:small_number x then c!:outop('movk1, v, nil, x) else if not idp x or flagp(x, 'c!:constant) then c!:outop('movk, v, x, c!:find_literal x) % If a variable that is referenced is not locally bound then it is treated % as being fluid/global without comment. else c!:outop('ldrglob, v, x, c!:find_literal x); return v end; symbolic procedure c!:cjumpif(x, env, d1, d2); begin scalar helper, r; x := s!:improve x; if atom x and (not idp x or (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then c!:endblock('goto, list (if x then d1 else d2)) else if not atom x and (helper := get(car x, 'c!:ctest)) then return funcall(helper, x, env, d1, d2) else << r := c!:cval(x, env); c!:endblock(list('ifnull, r), list(d2, d1)) >> end; fluid '(c!:current); symbolic procedure c!:ccall(fn, args, env); c!:ccall1(fn, args, env); fluid '(c!:visited); symbolic procedure c!:has_calls(a, b); begin scalar c!:visited; return c!:has_calls_1(a, b) end; symbolic procedure c!:has_calls_1(a, b); % true if there is a path from node a to node b that has a call instruction % on the way. if a = b or not atom a or memq(a, c!:visited) then nil else begin scalar has_call; c!:visited := a . c!:visited; for each z in get(a, 'c!:contents) do if eqcar(z, 'call) then has_call := t; if has_call then return begin scalar c!:visited; return c!:can_reach(a, b) end; for each d in get(a, 'c!:where_to) do if c!:has_calls_1(d, b) then has_call := t; return has_call end; symbolic procedure c!:can_reach(a, b); if a = b then t else if not atom a or memq(a, c!:visited) then nil else << c!:visited := a . c!:visited; c!:any_can_reach(get(a, 'c!:where_to), b) >>; symbolic procedure c!:any_can_reach(l, b); if null l then nil else if c!:can_reach(car l, b) then t else c!:any_can_reach(cdr l, b); symbolic procedure c!:pareval(args, env); begin scalar tasks, tasks1, merge, split, r; tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); split := c!:my_gensym(); c!:endblock('goto, list split); for each a in args do begin scalar s; % I evaluate each arg as what is (at this stage) a separate task s := car tasks; tasks := cdr tasks; c!:startblock car s; r := c!:cval(a, env) . r; c!:endblock('goto, list cdr s); % If the task did no procedure calls (or only tail calls) then it can be % executed sequentially with the other args without need for stacking % anything. Otherwise it more care will be needed. Put the hard % cases onto tasks1. !#if common!-lisp!-mode tasks1 := s . tasks1 !#else % The "t or" here is to try to FORCE left to right evaluation, even though % doing so may hurt performance. It at present looks as if some parts % of REDUCE have been coded making assumptions about this. if t or c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 else merge := s . merge !#endif end; %-- % if there are zero or one items in tasks1 then again it is easy - %-- % otherwise I flag the problem with a notionally parallel construction. %-- if tasks1 then << %-- if null cdr tasks1 then merge := car tasks1 . merge %-- else << %-- c!:startblock split; %-- printc "***** ParEval needed parallel block here..."; %-- c!:endblock('par, for each v in tasks1 collect car v); %-- split := c!:my_gensym(); %-- for each v in tasks1 do << %-- c!:startblock cdr v; %-- c!:endblock('goto, list split) >> >> >>; for each z in tasks1 do merge := z . merge; % do sequentially %-- %-- % Finally string end-to-end all the bits of sequential code I have left over. for each v in merge do << c!:startblock split; c!:endblock('goto, list car v); split := cdr v >>; c!:startblock split; return reversip r end; symbolic procedure c!:ccall1(fn, args, env); begin scalar tasks, merge, r, val; fn := list(fn, cdr env); val := c!:newreg(); if null args then c!:outop('call, val, nil, fn) else if null cdr args then c!:outop('call, val, list c!:cval(car args, env), fn) else << r := c!:pareval(args, env); c!:outop('call, val, r, fn) >>; c!:outop('reloadenv, 'env, nil, nil); return val end; fluid '(restart_label reloadenv does_call c!:current_c_name); % Reminder: s!:find_local_decs(body, isprog) returns (L . B') where % L is a list of local declarations and B' is the body with any % initial DECLARE and string-comments removed. The body passed in and % the result returned are both lists of forms. symbolic procedure c!:local_fluidp1(v, decs); decs and ((eqcar(car decs, 'special) and memq(v, cdar decs)) or c!:local_fluidp1(v, cdr decs)); symbolic procedure c!:local_fluidp(v, decs); decs and (c!:local_fluidp1(v, car decs) or c!:local_fluidp(v, cdr decs)); % % The "proper" recipe here arranges that functions that expect over 2 args use % the "va_arg" mechanism to pick up ALL their args. This would be pretty % heavy-handed, and at least on a lot of machines it does not seem to % be necessary. I will duck it for a while more at least. BUT NOTE THAT THE % CODE I GENERATE HERE IS AT LEAST OFFICIALLY INCORRECT. If at some stage I % find a computer where the implementation of va_args is truly incompatible % with that for known numbers of arguments I will need to adjust things % here. Yuk. % % Just so I know, the code at presently generated tends to go % % Lisp_Object f(Lisp_Object env, int nargs, Lisp_Object a1, Lisp_Object a2, % Lisp_Object a3, ...) % { // use a1, a2 and a3 as arguments % and note that it does put the "..." there! % % What it maybe ought to be is % % Lisp_Object f(Lisp_Object env, int nargs, ...) % { Lisp_Object a1, a2, a3; % va_list aa; % va_start(aa, nargs); % argcheck(nargs, 3, "f"); % a1 = va_arg(aa, Lisp_Object); % a2 = va_arg(aa, Lisp_Object); % a3 = va_arg(aa, Lisp_Object); % va_end(aa); % % Hmm that is not actually that hard to arrange! Remind me to do it some time! fluid '(proglabs blockstack localdecs); symbolic procedure c!:cfndef(c!:current_procedure, c!:current_c_name, argsbody, checksum); begin scalar env, n, w, c!:current_args, c!:current_block, restart_label, c!:current_contents, c!:all_blocks, entrypoint, exitpoint, args1, c!:registers, c!:stacklocs, literal_vector, reloadenv, does_call, blockstack, proglabs, args, body, localdecs; args := car argsbody; body := cdr argsbody; % If there is a (DECLARE (SPECIAL ...)) extract it here, aned leave a body % that is without it. w := s!:find_local_decs(body, nil); body := cdr w; if atom body then body := nil else if atom cdr body then body := car body else body := 'progn . body; localdecs := list car w; % I expect localdecs to be a list a bit like % ( ((special a b) (special c d) ...) ...) % and hypothetically it could have entries that were not tagged as % SPECIAL in it. % % The next line prints it to check. % if localdecs then << princ "localdecs = "; print localdecs >>; % @@@ % % Normally comment out the next line... It just shows what I am having to % compile and may be useful when debugging. % print list(c!:current_procedure, c!:current_c_name, args, body); c!:reset_gensyms(); wrs C_file; linelength 200; c!:printf("\n\n/* Code for %a %<*/\n\n", c!:current_procedure); c!:find_literal c!:current_procedure; % For benefit of backtraces % % cope with fluid vars in an argument list by expanding the definition % (de f (a B C d) body) B and C fluid % into % (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) % so that the fluids get bound by PROG. % c!:current_args := args; for each v in args do if v = '!&optional or v = '!&rest then error(0, "&optional and &rest not supported by this compiler (yet)") else if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v; n := (v . c!:my_gensym()) . n end else if fluidp v or c!:local_fluidp(v, localdecs) then n := (v . c!:my_gensym()) . n; if !*r2i then body := s!:r2i(c!:current_procedure, args, body); restart_label := c!:my_gensym(); body := list('c!:private_tagbody, restart_label, body); % This bit sets up the PROG block for binding fluid arguments. if n then << body := list list('return, body); args := subla(n, args); for each v in n do body := list('setq, car v, cdr v) . body; body := 'prog . (for each v in reverse n collect car v) . body >>; c!:printf "static Lisp_Object "; if null args or length args >= 3 then c!:printf("MS_CDECL "); c!:printf("%s(Lisp_Object env", c!:current_c_name); if null args or length args >= 3 then c!:printf(", int nargs"); n := t; env := nil; % Hah - here is where I will change things to use va_args for >= 3 args. for each x in args do begin scalar aa; c!:printf ","; if n then << c!:printf "\n "; n := nil >> else n := t; aa := c!:my_gensym(); env := (x . aa) . env; c!:registers := aa . c!:registers; args1 := aa . args1; c!:printf(" Lisp_Object %s", aa) end; if null args or length args >= 3 then c!:printf(", ..."); c!:printf(")\n{\n"); % Now I would need to do va_arg calls to declare the args and init them... % Except that I must do that within optimise_flowgraph after all possible % declarations have been generated. c!:startblock (entrypoint := c!:my_gensym()); exitpoint := c!:current_block; c!:endblock('goto, list list c!:cval(body, env . nil)); c!:optimise_flowgraph(entrypoint, c!:all_blocks, env, length args . c!:current_procedure, args1); c!:printf("}\n\n"); wrs O_file; L_contents := (c!:current_procedure . literal_vector . checksum) . L_contents; return nil end; % c!:ccompile1 directs the compilation of a single function, and bind all the % major fluids used by the compilation process flag('(rds deflist flag fluid global remprop remflag unfluid unglobal dm carcheck C!-end), 'eval); flag('(rds), 'ignore); fluid '(!*backtrace); symbolic procedure c!:ccompilesupervisor; begin scalar u, w; top:u := errorset('(read), t, !*backtrace); if atom u then return; % failed, or maybe EOF u := car u; if u = !$eof!$ then return; % end of file if atom u then go to top % the apply('C!-end, nil) is here because C!-end has a "stat" % property and so it will mis-parse if I just write "C!-end()". Yuk. else if eqcar(u, 'C!-end) then return apply('C!-end, nil) else if eqcar(u, 'rdf) then << !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!-not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << terpri(); princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> >> else c!:ccmpout1 u; go to top end; global '(c!:char_mappings); c!:char_mappings := '( (! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . !E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)); fluid '(c!:names_so_far); symbolic procedure c!:inv_name n; begin scalar r, w; % The next bit ararnges that if there are several definitions of the % same function in the same module that they get different C names. % Specifically they will be called CC_f, CC1_f, CC2_c, CC3_f, ... if (w := assoc(n, c!:names_so_far)) then w := cdr w + 1 else w := 0; c!:names_so_far := (n . w) . c!:names_so_far; r := '(!C !C !"); if not zerop w then r := append(reverse explodec w, r); r := '!_ . r; !#if common!-lisp!-mode for each c in explode2 package!-name symbol!-package n do << if c = '_ then r := '_ . r else if alpha!-char!-p c or digit c then r := c . r else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!_ . '!_ . r; !#endif for each c in explode2 n do << if c = '_ then r := '_ . r !#if common!-lisp!-mode else if alpha!-char!-p c or digit c then r := c . r !#else else if liter c or digit c then r := c . r !#endif else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!" . r; !#if common!-lisp!-mode return compress1 reverse r !#else return compress reverse r !#endif end; fluid '(c!:defnames pending_functions); symbolic procedure c!:ccmpout1 u; begin scalar pending_functions; pending_functions := list u; while pending_functions do << u := car pending_functions; pending_functions := cdr pending_functions; c!:ccmpout1a u >> end; symbolic procedure c!:ccmpout1a u; begin scalar w, checksum; if atom u then return nil else if eqcar(u, 'progn) then << for each v in cdr u do c!:ccmpout1a v; return nil >> else if eqcar(u, 'C!-end) then nil else if flagp(car u, 'eval) or (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then errorset(u, t, !*backtrace); if eqcar(u, 'rdf) then begin !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!_not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> end !#if common!-lisp!-mode else if eqcar(u, 'defun) then return c!:ccmpout1a macroexpand u !#endif else if eqcar(u, 'de) then << u := cdr u; checksum := md60 u; !#if common!-lisp!-mode w := compress1 ('!" . append(explodec package!-name symbol!-package car u, '!@ . '!@ . append(explodec symbol!-name car u, append(explodec "@@Builtin", '(!"))))); w := intern w; c!:defnames := list(car u, c!:inv_name car u, length cadr u, w, checksum) . c!:defnames; !#else c!:defnames := list(car u, c!:inv_name car u, length cadr u, checksum) . c!:defnames; !#endif % if posn() neq 0 then terpri(); princ "Compiling "; prin caar c!:defnames; princ " ... "; c!:cfndef(caar c!:defnames, cadar c!:defnames, cdr u, checksum); !#if common!-lisp!-mode L_contents := (w . car L_contents) . cdr L_contents; !#endif terpri() >> end; fluid '(!*defn dfprint!* dfprintsave); !#if common!-lisp!-mode symbolic procedure c!:concat(a, b); compress1('!" . append(explode2 a, append(explode2 b, '(!")))); !#else symbolic procedure c!:concat(a, b); compress('!" . append(explode2 a, append(explode2 b, '(!")))); !#endif symbolic procedure c!:ccompilestart(name, setupname, dir, hdrnow); begin scalar o, d, w; reset!-gensym 0; % Makes output more consistent !#if common!-lisp!-mode my_gensym_counter := 0; !#endif c!:registers := c!:available := c!:used := nil; % File_name will be the undecorated name as a string when hdrnow is false, File_name := list!-to!-string explodec name; Setup_name := explodec setupname; % I REALLY want the user to give me a module name that is a valid C % identifier, but in REDUCE I find just one case where a name has an embedded % "-", so I will just map that onto "_". When loading modules I will need to % take care to be aware of this! Also if any idiot tried to have two modules % called a-b and a_b they would now clash with one another. Setup_name := subst('!_, '!-, Setup_name); Setup_name := list!-to!-string Setup_name; if dir then << if 'win32 memq lispsystem!* then name := c!:concat(dir, c!:concat("\", name)) else name := c!:concat(dir, c!:concat("/", name)) >>; princ "C file = "; print name; !#if common!-lisp!-mode C_file := open(c!:concat(name, ".c"), !:direction, !:output); !#else C_file := open(c!:concat(name, ".c"), 'output); !#endif L_file := c!:concat(name, ".lsp"); L_contents := nil; c!:names_so_far := nil; % Here I turn a date into a form like "12-Oct-1993" as expected by the % file signature mechanism that I use. This seems a pretty ugly process. o := reverse explode date(); for i := 1:5 do << d := car o . d; o := cdr o >>; d := '!- . d; o := cdddr cdddr cddddr o; w := o; o := cdddr o; d := caddr o . cadr o . car o . d; !#if common!-lisp!-mode d := compress1('!" . cadr w . car w . '!- . d); !#else d := compress('!" . cadr w . car w . '!- . d); !#endif O_file := wrs C_file; c!:defnames := nil; if hdrnow then c!:printf("\n/* Module: %s %tMachine generated C code %<*/\n\n", setupname, 25) else c!:printf("\n/* %s.c %tMachine generated C code %<*/\n\n", name, 25); c!:printf("/* Signature: 00000000 %s %<*/\n\n", d); c!:printf "#include \n"; c!:printf "#include \n"; c!:printf "#include \n"; c!:printf "#include \n"; c!:printf "#include \n"; c!:printf "#include \n"; c!:printf "#ifndef _cplusplus\n"; c!:printf "#include \n"; c!:printf "#endif\n\n"; % The stuff I put in the file here includes written-in copies of header % files. The main "csl_headers" should be the same for all systems built % based on the current sources, but the "config_header" is specific to a % particular build. So if I am genarating C code that is JUST for use on the % current platform I can write-in the config header here and now, but if % there is any chance that I might save the generated C and compile it % elsewhere I should leave "#include "config.h"" in there. if hdrnow then print!-config!-header() else c!:printf "#include \qconfig.h\q\n\n"; print!-csl!-headers(); % Now a useful prefix for when compiling as a DLL if hdrnow then c!:print!-init(); wrs O_file; return nil end; symbolic procedure c!:print!-init(); << c!:printf "\n"; c!:printf "Lisp_Object *C_nilp;\n"; c!:printf "Lisp_Object **C_stackp;\n"; c!:printf "Lisp_Object * volatile * stacklimitp;\n"; c!:printf "\n"; c!:printf "void init(Lisp_Object *a, Lisp_Object **b, Lisp_Object * volatile *c)\n"; c!:printf "{\n"; c!:printf " C_nilp = a;\n"; c!:printf " C_stackp = b;\n"; c!:printf " stacklimitp = c;\n"; c!:printf "}\n"; c!:printf "\n"; c!:printf "#define C_nil (*C_nilp)\n"; c!:printf "#define C_stack (*C_stackp)\n"; c!:printf "#define stacklimit (*stacklimitp)\n"; c!:printf "\n" >>; symbolic procedure C!-end; C!-end1 t; procedure C!-end1 create_lfile; begin scalar checksum, c1, c2, c3; wrs C_file; if create_lfile then c!:printf("\n\nsetup_type const %s_setup[] =\n{\n", Setup_name) else c!:printf("\n\nsetup_type_1 const %s_setup[] =\n{\n", Setup_name); c!:defnames := reverse c!:defnames; while c!:defnames do begin scalar name, nargs, f1, f2, cast, fn; !#if common!-lisp!-mode name := cadddr car c!:defnames; checksum := cadddr cdar c!:defnames; !#else name := caar c!:defnames; checksum := cadddr car c!:defnames; !#endif f1 := cadar c!:defnames; nargs := caddar c!:defnames; cast := "(n_args *)"; if nargs = 1 then << f2 := '!t!o!o_!m!a!n!y_1; cast := ""; fn := '!w!r!o!n!g_!n!o_1 >> else if nargs = 2 then << f2 := f1; f1 := '!t!o!o_!f!e!w_2; cast := ""; fn := '!w!r!o!n!g_!n!o_2 >> else << fn := f1; f1 := '!w!r!o!n!g_!n!o_!n!a; f2 := '!w!r!o!n!g_!n!o_!n!b >>; if create_lfile then c!:printf(" {\q%s\q,%t%s,%t%s,%t%s%s},\n", name, 32, f1, 48, f2, 63, cast, fn) else begin scalar c1, c2; c1 := divide(checksum, expt(2, 31)); c2 := cdr c1; c1 := car c1; c!:printf(" {\q%s\q, %t%s, %t%s, %t%s%s, %t%s, %t%s},\n", name, 24, f1, 40, f2, 52, cast, fn, 64, c1, 76, c2) end; c!:defnames := cdr c!:defnames end; c3 := checksum := md60 L_contents; c1 := remainder(c3, 10000000); c3 := c3 / 10000000; c2 := remainder(c3, 10000000); c3 := c3 / 10000000; checksum := list!-to!-string append(explodec c3, '! . append(explodec c2, '! . explodec c1)); c!:printf(" {NULL, (one_args *)%a, (two_args *)%a, 0}\n};\n\n", Setup_name, checksum); c!:printf "%>; terpri(); !#if common!-lisp!-mode princ ";;; End of generated Lisp code"; !#else princ "% End of generated Lisp code"; !#endif terpri(); terpri(); L_contents := nil; wrs O_file; close L_file; !*defn := nil; dfprint!* := dfprintsave >> else << checksum := checksum . reverse L_contents; L_contents := nil; return checksum >> end; put('C!-end, 'stat, 'endstat); symbolic procedure C!-compile u; begin terpri(); princ "C!-COMPILE "; prin u; princ ": IN files; or type in expressions"; terpri(); princ "When all done, execute C!-END;"; terpri(); verbos nil; c!:ccompilestart(car u, car u, nil, nil); dfprintsave := dfprint!*; dfprint!* := 'c!:ccmpout1; !*defn := t; if getd 'begin then return nil; c!:ccompilesupervisor(); end; put('C!-compile, 'stat, 'rlis); % % Global treatment of a flow-graph... % symbolic procedure c!:print_opcode(s, depth); begin scalar op, r1, r2, r3, helper; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; helper := get(op, 'c!:opcode_printer); if helper then funcall(helper, op, r1, r2, r3, depth) else << prin s; terpri() >> end; symbolic procedure c!:print_exit_condition(why, where_to, depth); begin scalar helper, lab1, drop1, lab2, drop2, negate; % An exit condition is one of % goto (lab) % goto ((return-register)) % (ifnull v) (lab1 lab2) ) etc, where v is a register and % (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false % (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported % ((call fn) a1 a2) () tail-call to given function % if why = 'goto then << where_to := car where_to; if atom where_to then << c!:printf(" goto %s;\n", where_to); c!:display_flowgraph(where_to, depth, t) >> else << c!:printf " "; c!:pgoto(where_to, depth) >>; return nil >> else if eqcar(car why, 'call) then return begin scalar args, locs, g, w; if w := get(cadar why, 'c!:direct_entrypoint) then << for each a in cdr why do if flagp(a, 'c!:live_across_call) then << if null g then c!:printf " {\n"; g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then << if g then c!:printf " "; c!:printf(" popv(%s);\n", depth) >>; if g then c!:printf " "; !#if common!-lisp!-mode c!:printf(" { Lisp_Object retVal = %s(", cdr w); !#else c!:printf(" return %s(", cdr w); !#endif args := reversip args; if args then << c!:printf("%v", car args); for each a in cdr args do c!:printf(", %v", a) >>; c!:printf(");\n"); !#if common!-lisp!-mode if g then c!:printf " "; c!:printf(" errexit();\n"); if g then c!:printf " "; c!:printf(" return onevalue(retVal); }\n"); !#endif if g then c!:printf " }\n" >> else if w := get(cadar why, 'c!:c_entrypoint) then << % I think there may be an issue here with functions that can accept variable % numbers of args. I seem to support just ONE C entrypoint which I will % call in all circumstances... Yes there ARE such issues, and the one % I recently fall across was "error" which in my implementation can take % any number of arguments. So I have removed it from the list of things % that can be called as direct C code... for each a in cdr why do if flagp(a, 'c!:live_across_call) then << if null g then c!:printf " {\n"; g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return %s(nil", w); if null args or length args >= 3 then c!:printf(", %s", length args); for each a in reversip args do c!:printf(", %v", a); c!:printf(");\n"); if g then c!:printf " }\n" >> else begin scalar nargs; nargs := length cdr why; c!:printf " {\n"; for each a in cdr why do if flagp(a, 'c!:live_across_call) then << g := c!:my_gensym(); c!:printf(" Lisp_Object %s = %v;\n", g, a); args := g . args >> else args := a . args; if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" fn = elt(env, %s); %> else if drop1 then negate := t; helper := get(car why, 'c!:exit_helper); if null helper then error(0, list("Bad exit condition", why)); c!:printf(" if ("); if negate then << c!:printf("!("); funcall(helper, cdr why, depth); c!:printf(")") >> else funcall(helper, cdr why, depth); c!:printf(") "); if not drop1 then << c!:pgoto(car where_to, depth); c!:printf(" else ") >>; c!:pgoto(cadr where_to, depth); if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) end; symbolic procedure c!:pmovr(op, r1, r2, r3, depth); c!:printf(" %v = %v;\n", r1, r3); put('movr, 'c!:opcode_printer, function c!:pmovr); symbolic procedure c!:pmovk(op, r1, r2, r3, depth); c!:printf(" %v = elt(env, %s); %>; put('fastget, 'c!:opcode_printer, function c!:pfastget); flag('(fastget), 'c!:uses_nil); symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); << c!:printf(" if (!symbolp(%v)) %v = nil;\n", r2, r1); c!:printf(" else { %v = qfastgets(%v);\n", r1, r2); c!:printf(" if (%v != nil) { %v = elt(%v, %s); %>; put('fastflag, 'c!:opcode_printer, function c!:pfastflag); flag('(fastflag), 'c!:uses_nil); symbolic procedure c!:pcar(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:printf(" if (!car_legal(%v)) ", r3); c!:pgoto(c!:find_error_label(list('car, r3), r2, depth), depth) >>; c!:printf(" %v = qcar(%v);\n", r1, r3) end; put('car, 'c!:opcode_printer, function c!:pcar); symbolic procedure c!:pcdr(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:printf(" if (!car_legal(%v)) ", r3); c!:pgoto(c!:find_error_label(list('cdr, r3), r2, depth), depth) >>; c!:printf(" %v = qcdr(%v);\n", r1, r3) end; put('cdr, 'c!:opcode_printer, function c!:pcdr); symbolic procedure c!:pqcar(op, r1, r2, r3, depth); c!:printf(" %v = qcar(%v);\n", r1, r3); put('qcar, 'c!:opcode_printer, function c!:pqcar); symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); c!:printf(" %v = qcdr(%v);\n", r1, r3); put('qcdr, 'c!:opcode_printer, function c!:pqcdr); symbolic procedure c!:patom(op, r1, r2, r3, depth); c!:printf(" %v = (consp(%v) ? nil : lisp_true);\n", r1, r3); put('atom, 'c!:opcode_printer, function c!:patom); flag('(atom), 'c!:uses_nil); symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); c!:printf(" %v = (is_number(%v) ? lisp_true : nil);\n", r1, r3); put('numberp, 'c!:opcode_printer, function c!:pnumberp); flag('(numberp), 'c!:uses_nil); symbolic procedure c!:pfixp(op, r1, r2, r3, depth); c!:printf(" %v = integerp(%v);\n", r1, r3); put('fixp, 'c!:opcode_printer, function c!:pfixp); flag('(fixp), 'c!:uses_nil); symbolic procedure c!:piminusp(op, r1, r2, r3, depth); c!:printf(" %v = ((intptr_t)(%v) < 0 ? lisp_true : nil);\n", r1, r3); put('iminusp, 'c!:opcode_printer, function c!:piminusp); flag('(iminusp), 'c!:uses_nil); symbolic procedure c!:pilessp(op, r1, r2, r3, depth); c!:printf(" %v = ((intptr_t)%v < (intptr_t)%v) ? lisp_true : nil;\n", r1, r2, r3); put('ilessp, 'c!:opcode_printer, function c!:pilessp); flag('(ilessp), 'c!:uses_nil); symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); c!:printf(" %v = ((intptr_t)%v > (intptr_t)%v) ? lisp_true : nil;\n", r1, r2, r3); put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); flag('(igreaterp), 'c!:uses_nil); % The "int32_t" here is deliberate, and ensures that if the intereg-mode % arithmetic strays outside 32-bits that truncation is done at that % level even on 64-bit architectures. symbolic procedure c!:piminus(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)(2-((int32_t)(%v)));\n", r1, r3); put('iminus, 'c!:opcode_printer, function c!:piminus); symbolic procedure c!:piadd1(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n", r1, r3); put('iadd1, 'c!:opcode_printer, function c!:piadd1); symbolic procedure c!:pisub1(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n", r1, r3); put('isub1, 'c!:opcode_printer, function c!:pisub1); symbolic procedure c!:piplus2(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_FIXNUM);\n", r1, r2, r3); put('iplus2, 'c!:opcode_printer, function c!:piplus2); symbolic procedure c!:pidifference(op, r1, r2, r3, depth); c!:printf(" %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_FIXNUM);\n", r1, r2, r3); put('idifference, 'c!:opcode_printer, function c!:pidifference); symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); c!:printf(" %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnum(%v)));\n", r1, r2, r3); put('itimes2, 'c!:opcode_printer, function c!:pitimes2); symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); << c!:printf(" { int32_t w = int_of_fixnum(%v) + int_of_fixnum(%v);\n", r2, r3); c!:printf(" if (w >= current_modulus) w -= current_modulus;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); << c!:printf(" { int32_t w = int_of_fixnum(%v) - int_of_fixnum(%v);\n", r2, r3); c!:printf(" if (w < 0) w += current_modulus;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); << c!:printf(" { int32_t w = int_of_fixnum(%v);\n", r3); c!:printf(" if (w != 0) w = current_modulus - w;\n"); c!:printf(" %v = fixnum_of_int(w);\n", r1); c!:printf(" }\n") >>; put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); !#if (not common!-lisp!-mode) symbolic procedure c!:passoc(op, r1, r2, r3, depth); c!:printf(" %v = Lassoc(nil, %v, %v);\n", r1, r2, r3); put('assoc, 'c!:opcode_printer, function c!:passoc); flag('(assoc), 'c!:uses_nil); !#endif symbolic procedure c!:patsoc(op, r1, r2, r3, depth); c!:printf(" %v = Latsoc(nil, %v, %v);\n", r1, r2, r3); put('atsoc, 'c!:opcode_printer, function c!:patsoc); flag('(atsoc), 'c!:uses_nil); !#if (not common!-lisp!-mode) symbolic procedure c!:pmember(op, r1, r2, r3, depth); c!:printf(" %v = Lmember(nil, %v, %v);\n", r1, r2, r3); put('member, 'c!:opcode_printer, function c!:pmember); flag('(member), 'c!:uses_nil); !#endif symbolic procedure c!:pmemq(op, r1, r2, r3, depth); c!:printf(" %v = Lmemq(nil, %v, %v);\n", r1, r2, r3); put('memq, 'c!:opcode_printer, function c!:pmemq); flag('(memq), 'c!:uses_nil); !#if common!-lisp!-mode symbolic procedure c!:pget(op, r1, r2, r3, depth); c!:printf(" %v = get(%v, %v, nil);\n", r1, r2, r3); flag('(get), 'c!:uses_nil); !#else symbolic procedure c!:pget(op, r1, r2, r3, depth); c!:printf(" %v = get(%v, %v);\n", r1, r2, r3); !#endif put('get, 'c!:opcode_printer, function c!:pget); symbolic procedure c!:pqgetv(op, r1, r2, r3, depth); << c!:printf(" %v = *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", r1, r2); c!:printf(" ((int32_t)%v/(16/CELL)));\n", r3) >>; put('qgetv, 'c!:opcode_printer, function c!:pqgetv); symbolic procedure c!:pqputv(op, r1, r2, r3, depth); << c!:printf(" *(Lisp_Object *)((char *)%v + (CELL-TAG_VECTOR) +", r2); c!:printf(" ((int32_t)%v/(16/CELL))) = %v;\n", r3, r1) >>; put('qputv, 'c!:opcode_printer, function c!:pqputv); symbolic procedure c!:peq(op, r1, r2, r3, depth); c!:printf(" %v = (%v == %v ? lisp_true : nil);\n", r1, r2, r3); put('eq, 'c!:opcode_printer, function c!:peq); flag('(eq), 'c!:uses_nil); !#if common!-lisp!-mode symbolic procedure c!:pequal(op, r1, r2, r3, depth); c!:printf(" %v = (cl_equal(%v, %v) ? lisp_true : nil);\n", r1, r2, r3, r2, r3); !#else symbolic procedure c!:pequal(op, r1, r2, r3, depth); c!:printf(" %v = (equal(%v, %v) ? lisp_true : nil);\n", r1, r2, r3, r2, r3); !#endif put('equal, 'c!:opcode_printer, function c!:pequal); flag('(equal), 'c!:uses_nil); symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); nil; put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); symbolic procedure c!:pcall(op, r1, r2, r3, depth); begin % r3 is (name ) scalar w, boolfn; if w := get(car r3, 'c!:direct_entrypoint) then << c!:printf(" %v = %s(", r1, cdr w); if r2 then << c!:printf("%v", car r2); for each a in cdr r2 do c!:printf(", %v", a) >>; c!:printf(");\n") >> else if w := get(car r3, 'c!:direct_predicate) then << boolfn := t; c!:printf(" %v = (Lisp_Object)%s(", r1, cdr w); if r2 then << c!:printf("%v", car r2); for each a in cdr r2 do c!:printf(", %v", a) >>; c!:printf(");\n") >> else if car r3 = c!:current_procedure then << % Things could go sour here if a function tried to call itself but with the % wrong number of args. And this happens at one place in the REDUCE source % code (I hope it will be fixed soon!). I will patch things up here by % discarding any excess args or padding with NIL if not enough had been % written. r2 := c!:fix_nargs(r2, c!:current_args); c!:printf(" %v = %s(env", r1, c!:current_c_name); if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); for each a in r2 do c!:printf(", %v", a); c!:printf(");\n") >> else if w := get(car r3, 'c!:c_entrypoint) then << c!:printf(" %v = %s(nil", r1, w); if null r2 or length r2 >= 3 then c!:printf(", %s", length r2); for each a in r2 do c!:printf(", %v", a); c!:printf(");\n") >> else begin scalar nargs; nargs := length r2; c!:printf(" fn = elt(env, %s); %> >>; if boolfn then c!:printf(" %v = %v ? lisp_true : nil;\n", r1, r1); end; symbolic procedure c!:fix_nargs(r2, act); if null act then nil else if null r2 then nil . c!:fix_nargs(nil, cdr act) else car r2 . c!:fix_nargs(cdr r2, cdr act); put('call, 'c!:opcode_printer, function c!:pcall); symbolic procedure c!:pgoto(lab, depth); begin if atom lab then return c!:printf("goto %s;\n", lab); lab := get(car lab, 'c!:chosen); if zerop depth then c!:printf("return onevalue(%v);\n", lab) else if flagp(lab, 'c!:live_across_call) then c!:printf("{ Lisp_Object res = %v; popv(%s); return onevalue(res); }\n", lab, depth) else c!:printf("{ popv(%s); return onevalue(%v); }\n", depth, lab) end; symbolic procedure c!:pifnull(s, depth); c!:printf("%v == nil", car s); put('ifnull, 'c!:exit_helper, function c!:pifnull); symbolic procedure c!:pifatom(s, depth); c!:printf("!consp(%v)", car s); put('ifatom, 'c!:exit_helper, function c!:pifatom); symbolic procedure c!:pifsymbol(s, depth); c!:printf("symbolp(%v)", car s); put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); symbolic procedure c!:pifnumber(s, depth); c!:printf("is_number(%v)", car s); put('ifnumber, 'c!:exit_helper, function c!:pifnumber); symbolic procedure c!:pifizerop(s, depth); c!:printf("(%v) == 1", car s); put('ifizerop, 'c!:exit_helper, function c!:pifizerop); symbolic procedure c!:pifeq(s, depth); c!:printf("%v == %v", car s, cadr s); put('ifeq, 'c!:exit_helper, function c!:pifeq); !#if common!-lisp!-mode symbolic procedure c!:pifequal(s, depth); c!:printf("cl_equal(%v, %v)", car s, cadr s, car s, cadr s); !#else symbolic procedure c!:pifequal(s, depth); c!:printf("equal(%v, %v)", car s, cadr s, car s, cadr s); !#endif put('ifequal, 'c!:exit_helper, function c!:pifequal); symbolic procedure c!:pifilessp(s, depth); c!:printf("((int32_t)(%v)) < ((int32_t)(%v))", car s, cadr s); put('ifilessp, 'c!:exit_helper, function c!:pifilessp); symbolic procedure c!:pifigreaterp(s, depth); c!:printf("((int32_t)(%v)) > ((int32_t)(%v))", car s, cadr s); put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); symbolic procedure c!:display_flowgraph(s, depth, dropping_through); if not atom s then << c!:printf " "; c!:pgoto(s, depth) >> else if not flagp(s, 'c!:visited) then begin scalar why, where_to; flag(list s, 'c!:visited); if not dropping_through or not (get(s, 'c!:count) = 1) then c!:printf("\n%s:\n", s); for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); why := get(s, 'c!:why); where_to := get(s, 'c!:where_to); if why = 'goto and (not atom car where_to or (not flagp(car where_to, 'c!:visited) and get(car where_to, 'c!:count) = 1)) then c!:display_flowgraph(car where_to, depth, t) else c!:print_exit_condition(why, where_to, depth); end; fluid '(c!:startpoint); symbolic procedure c!:branch_chain(s, count); begin scalar contents, why, where_to, n; % do nothing to blocks already visted or return blocks. if not atom s then return s else if flagp(s, 'c!:visited) then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n); return s >>; flag(list s, 'c!:visited); contents := get(s, 'c!:contents); why := get(s, 'c!:why); where_to := for each z in get(s, 'c!:where_to) collect c!:branch_chain(z, count); % Turn movr a,b; return a; into return b; while contents and eqcar(car contents, 'movr) and why = 'goto and not atom car where_to and caar where_to = cadr car contents do << where_to := list list cadddr car contents; contents := cdr contents >>; put(s, 'c!:contents, contents); put(s, 'c!:where_to, where_to); % discard empty blocks if null contents and why = 'goto then << remflag(list s, 'c!:visited); return car where_to >>; if count then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n) >>; return s end; symbolic procedure c!:one_operand op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_one) >>; symbolic procedure c!:two_operands op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r2); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_two) >>; for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp iminus iadd1 isub1 modular!-minus) do c!:one_operand n; !#if common!-lisp!-mode for each n in '(eq equal atsoc memq iplus2 idifference itimes2 ilessp igreaterp qgetv get modular!-plus modular!-difference ) do c!:two_operands n; !#else for each n in '(eq equal atsoc memq iplus2 idifference assoc member itimes2 ilessp igreaterp qgetv get modular!-plus modular!-difference ) do c!:two_operands n; !#endif flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); flag('(strglob qputv), 'c!:read_r1); flag('(qputv fastget fastflag), 'c!:read_r2); flag('(movr qputv), 'c!:read_r3); flag('(ldrglob strglob nilglob movk call), 'c!:read_env); % special opcodes: % call fluidbind fluid '(fn_used nil_used nilbase_used); symbolic procedure c!:live_variable_analysis c!:all_blocks; begin scalar changed, z; repeat << changed := nil; for each b in c!:all_blocks do begin scalar w, live; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; live := union(live, cdr w); if eqcar(car w, 'call) and (flagp(cadar w, 'c!:direct_predicate) or (flagp(cadar w, 'c!:c_entrypoint) and not flagp(cadar w, 'c!:direct_entrypoint))) then nil_used := t; if eqcar(car w, 'call) and not (cadar w = c!:current_procedure) and not get(cadar w, 'c!:direct_entrypoint) and not get(cadar w, 'c!:c_entrypoint) then << fn_used := t; live := union('(env), live) >> >>; for each s in get(b, 'c!:contents) do begin % backwards over contents scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if op = 'movk1 then << if r3 = nil then nil_used := t else if r3 = 't then nilbase_used := t >> else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; if flagp(op, 'c!:set_r1) then !#if common!-lisp!-mode if memq(r1, live) then live := remove(r1, live) !#else if memq(r1, live) then live := delete(r1, live) !#endif else if op = 'call then nil % Always needed else op := 'nop; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); if op = 'call then << if not flagp(car r3, 'c!:no_errors) or flagp(car r3, 'c!:c_entrypoint) or get(car r3, 'c!:direct_predicate) then nil_used := t; does_call := t; if not eqcar(r3, c!:current_procedure) and not get(car r3, 'c!:direct_entrypoint) and not get(car r3, 'c!:c_entrypoint) then fn_used := t; if not flagp(car r3, 'c!:no_errors) then flag(live, 'c!:live_across_call); live := union(live, r2) >>; if flagp(op, 'c!:read_env) then live := union(live, '(env)) end; !#if common!-lisp!-mode live := append(live, nil); % because CL sort is destructive! !#endif live := sort(live, function orderp); if not (live = get(b, 'c!:live)) then << put(b, 'c!:live, live); changed := t >> end >> until not changed; z := c!:registers; c!:registers := c!:stacklocs := nil; for each r in z do if flagp(r, 'c!:live_across_call) then c!:stacklocs := r . c!:stacklocs else c!:registers := r . c!:registers end; symbolic procedure c!:insert1(a, b); if memq(a, b) then b else a . b; symbolic procedure c!:clash(a, b); if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; symbolic procedure c!:build_clash_matrix c!:all_blocks; begin for each b in c!:all_blocks do begin scalar live, w; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << live := union(live, cdr w); if eqcar(car w, 'call) and not get(cadar w, 'c!:direct_entrypoint) and not get(cadar w, 'c!:c_entrypoint) then live := union('(env), live) >>; for each s in get(b, 'c!:contents) do begin scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if flagp(op, 'c!:set_r1) then if memq(r1, live) then << !#if common!-lisp!-mode live := remove(r1, live); !#else live := delete(r1, live); !#endif if op = 'reloadenv then reloadenv := t; for each v in live do c!:clash(r1, v) >> else if op = 'call then nil else << op := 'nop; rplacd(s, car s . cdr s); % Leaves original instrn visible rplaca(s, op) >>; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); % Maybe CALL should be a little more selective about need for "env"? if op = 'call then live := union(live, r2); if flagp(op, 'c!:read_env) then live := union(live, '(env)) end end; % The next few lines are for debugging... %%- c!:printf "Scratch registers:\n"; %%- for each r in c!:registers do %%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); %%- c!:printf "Stack items:\n"; %%- for each r in c!:stacklocs do %%- c!:printf("%s clashes: %s\n", r, get(r, 'c!:clash)); return nil end; symbolic procedure c!:allocate_registers rl; begin scalar schedule, neighbours, allocation; neighbours := 0; while rl do begin scalar w, x; w := rl; while w and length (x := get(car w, 'c!:clash)) > neighbours do w := cdr w; if w then << schedule := car w . schedule; rl := deleq(car w, rl); for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> else neighbours := neighbours + 1 end; for each r in schedule do begin scalar poss; poss := allocation; for each x in get(r, 'c!:clash) do poss := deleq(get(x, 'c!:chosen), poss); if null poss then << poss := c!:my_gensym(); allocation := append(allocation, list poss) >> else poss := car poss; % c!:printf("%>; return cdr w end; symbolic procedure c!:assign(u, v, c); if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c else list('movr, u, nil, v) . c; symbolic procedure c!:insert_tailcall b; begin scalar why, dest, contents, fcall, res, w; why := get(b, 'c!:why); dest := get(b, 'c!:where_to); contents := get(b, 'c!:contents); while contents and not eqcar(car contents, 'call) do << w := car contents . w; contents := cdr contents >>; if null contents then return nil; fcall := car contents; contents := cdr contents; res := cadr fcall; while w do << if eqcar(car w, 'reloadenv) then w := cdr w else if eqcar(car w, 'movr) and cadddr car w = res then << res := cadr car w; w := cdr w >> else res := w := nil >>; if null res then return nil; if c!:does_return(res, why, dest) then if car cadddr fcall = c!:current_procedure then << for each p in pair(c!:current_args, caddr fcall) do contents := c!:assign(car p, cdr p, contents); put(b, 'c!:contents, contents); put(b, 'c!:why, 'goto); put(b, 'c!:where_to, list restart_label) >> else << nil_used := t; put(b, 'c!:contents, contents); put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); put(b, 'c!:where_to, nil) >> end; symbolic procedure c!:does_return(res, why, where_to); if not (why = 'goto) then nil else if not atom car where_to then res = caar where_to else begin scalar contents; where_to := car where_to; contents := reverse get(where_to, 'c!:contents); why := get(where_to, 'c!:why); where_to := get(where_to, 'c!:where_to); while contents do if eqcar(car contents, 'reloadenv) then contents := cdr contents else if eqcar(car contents, 'movr) and cadddr car contents = res then << res := cadr car contents; contents := cdr contents >> else res := contents := nil; if null res then return nil else return c!:does_return(res, why, where_to) end; symbolic procedure c!:pushpop(op, v); % for each x in v do c!:printf(" %s(%s);\n", op, x); begin scalar n, w; if null v then return nil; n := length v; while n > 0 do << w := n; if w > 6 then w := 6; n := n-w; if w = 1 then c!:printf(" %s(%s);\n", op, car v) else << c!:printf(" %s%d(%s", op, w, car v); v := cdr v; for i := 2:w do << c!:printf(",%s", car v); v := cdr v >>; c!:printf(");\n") >> >> end; symbolic procedure c!:optimise_flowgraph(c!:startpoint, c!:all_blocks, env, argch, args); begin scalar w, n, locs, stacks, c!:error_labels, fn_used, nil_used, nilbase_used; !#if common!-lisp!-mode nilbase_used := t; % For onevalue(xxx) at least !#endif for each b in c!:all_blocks do c!:insert_tailcall b; c!:startpoint := c!:branch_chain(c!:startpoint, nil); remflag(c!:all_blocks, 'c!:visited); c!:live_variable_analysis c!:all_blocks; c!:build_clash_matrix c!:all_blocks; if c!:error_labels and env then reloadenv := t; for each u in env do for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct locs := c!:allocate_registers c!:registers; stacks := c!:allocate_registers c!:stacklocs; flag(stacks, 'c!:live_across_call); c!:remove_nops c!:all_blocks; c!:startpoint := c!:branch_chain(c!:startpoint, nil); % after tailcall insertion remflag(c!:all_blocks, 'c!:visited); c!:startpoint := c!:branch_chain(c!:startpoint, t); % ... AGAIN to tidy up remflag(c!:all_blocks, 'c!:visited); if does_call then nil_used := t; if nil_used then c!:printf " Lisp_Object nil = C_nil;\n" else if nilbase_used then c!:printf " nil_as_base\n"; if locs then << c!:printf(" Lisp_Object %s", car locs); for each v in cdr locs do c!:printf(", %s", v); c!:printf ";\n" >>; if fn_used then c!:printf " Lisp_Object fn;\n"; if nil_used then c!:printf(" CSL_IGNORE(nil);\n") else if nilbase_used then << c!:printf("#ifndef NILSEG_EXTERNS\n"); c!:printf(" CSL_IGNORE(nil);\n"); c!:printf("#endif\n") >>; if car argch = 0 or car argch >= 3 then c!:printf(" argcheck(nargs, %s, \q%s\q);\n", car argch, cdr argch); c!:printf("#ifdef DEBUG\n"); c!:printf(" if (check_env(env)) return aerror(\qenv for %s\q);\n", cdr argch); c!:printf("#endif\n"); % I will not do a stack check if I have a leaf procedure, and I hope % that this policy will speed up code a bit. if does_call then << c!:printf " if (stack >= stacklimit)\n"; c!:printf " {\n"; % This is slightly clumsy code to save all args on the stack across the % call to reclaim(), but it is not executed often... c!:pushpop('push, args); c!:printf " env = reclaim(env, \qstack\q, GC_STACK, 0);\n"; c!:pushpop('pop, reverse args); c!:printf " nil = C_nil;\n"; c!:printf " if (exception_pending()) return nil;\n"; c!:printf " }\n" >>; if reloadenv then c!:printf(" push(env);\n") else c!:printf(" CSL_IGNORE(env);\n"); n := 0; if stacks then << c!:printf "%>; w := n; while w >= 5 do << c!:printf " push5(nil, nil, nil, nil, nil);\n"; w := w - 5 >>; if w neq 0 then << if w = 1 then c!:printf " push(nil);\n" else << c!:printf(" push%s(nil", w); for i := 2:w do c!:printf ", nil"; c!:printf ");\n" >> >> >>; if reloadenv then << reloadenv := n; n := n + 1 >>; if env then c!:printf "%> >>; remflag(c!:all_blocks, 'c!:visited); end; symbolic procedure c!:print_error_return(why, env, depth); begin if reloadenv and env then c!:printf(" env = stack[%s];\n", -reloadenv); if null why then << % One could imagine generating backtrace entries here... for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v; %> else if flagp(cadr why, 'c!:live_across_call) then << c!:printf(" { Lisp_Object res = %v;\n", cadr why); for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v;\n", c!:find_literal car v, get(cdr v, 'c!:chosen)); if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return error(1, %s, res); }\n", if eqcar(why, 'car) then "err_bad_car" else if eqcar(why, 'cdr) then "err_bad_cdr" else error(0, list(why, "unknown_error"))) >> else << for each v in env do c!:printf(" qvalue(elt(env, %s)) = %v;\n", c!:find_literal car v, get(cdr v, 'c!:chosen)); if depth neq 0 then c!:printf(" popv(%s);\n", depth); c!:printf(" return error(1, %s, %v);\n", (if eqcar(why, 'car) then "err_bad_car" else if eqcar(why, 'cdr) then "err_bad_cdr" else error(0, list(why, "unknown_error"))), cadr why) >> end; % % Now I have a series of separable sections each of which gives a special % recipe that implements or optimises compilation of some specific Lisp % form. % symbolic procedure c!:cand(u, env); begin scalar w, r; w := reverse cdr u; if null w then return c!:cval(nil, env); r := list(list('t, car w)); w := cdr w; for each z in w do r := list(list('null, z), nil) . r; r := 'cond . r; return c!:cval(r, env) end; %-- scalar next, done, v, r; %-- v := c!:newreg(); %-- done := c!:my_gensym(); %-- u := cdr u; %-- while cdr u do << %-- next := c!:my_gensym(); %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- u := cdr u; %-- c!:endblock(list('ifnull, v), list(done, next)); %-- c!:startblock next >>; %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- c!:endblock('goto, list done); %-- c!:startblock done; %-- return v %-- end; put('and, 'c!:code, function c!:cand); !#if common!-lisp!-mode symbolic procedure c!:cblock(u, env); begin scalar progret, progexit, r; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (cadr u . progret . progexit) . blockstack; u := cddr u; for each a in u do r := c!:cval(a, env); c!:outop('movr, progret, nil, r); c!:endblock('goto, list progexit); c!:startblock progexit; blockstack := cdr blockstack; return progret end; put('block, 'c!:code, function c!:cblock); !#endif symbolic procedure c!:ccatch(u, env); error(0, "catch"); put('catch, 'c!:code, function c!:ccatch); symbolic procedure c!:ccompile_let(u, env); error(0, "compiler-let"); put('compiler!-let, 'c!:code, function c!:ccompiler_let); symbolic procedure c!:ccond(u, env); begin scalar v, join; v := c!:newreg(); join := c!:my_gensym(); for each c in cdr u do begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); if atom cdr c then << c!:outop('movr, v, nil, c!:cval(car c, env)); c!:endblock(list('ifnull, v), list(l2, join)) >> else << c!:cjumpif(car c, env, l1, l2); c!:startblock l1; % if the condition is true c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); c!:endblock('goto, list join) >>; c!:startblock l2 end; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('cond, 'c!:code, function c!:ccond); symbolic procedure c!:valid_cond x; if null x then t else if not c!:valid_list car x then nil else c!:valid_cond cdr x; put('cond, 'c!:valid, function c!:valid_cond); symbolic procedure c!:cdeclare(u, env); error(0, "declare"); put('declare, 'c!:code, function c!:cdeclare); symbolic procedure c!:cde(u, env); error(0, "de"); put('de, 'c!:code, function c!:cde); symbolic procedure c!:cdefun(u, env); error(0, "defun"); put('!~defun, 'c!:code, function c!:cdefun); symbolic procedure c!:ceval_when(u, env); error(0, "eval-when"); put('eval!-when, 'c!:code, function c!:ceval_when); symbolic procedure c!:cflet(u, env); error(0, "flet"); put('flet, 'c!:code, function c!:cflet); symbolic procedure c!:cfunction(u, env); begin scalar v; u := cadr u; if not atom u then << if not eqcar(u, 'lambda) then error(0, list("lambda expression needed", u)); v := dated!-name 'lambda; pending_functions := ('de . v . cdr u) . pending_functions; u := v >>; v := c!:newreg(); c!:outop('movk, v, u, c!:find_literal u); return v; end; symbolic procedure c!:valid_function x; if atom x then nil else if not null cdr x then nil else if idp car x then t else if atom car x then nil else if not eqcar(car x, 'lambda) then nil else if atom cdar x then nil else c!:valid_fndef(cadar x, cddar x); put('function, 'c!:code, function c!:cfunction); put('function, 'c!:valid, function c!:valid_function); symbolic procedure c!:cgo(u, env); begin scalar w, w1; w1 := proglabs; while null w and w1 do << w := assoc!*!*(cadr u, car w1); w1 := cdr w1 >>; if null w then error(0, list(u, "label not set")); c!:endblock('goto, list cadr w); return nil % value should not be used end; put('go, 'c!:code, function c!:cgo); put('go, 'c!:valid, function c!:valid_quote); symbolic procedure c!:cif(u, env); begin scalar v, join, l1, l2, w; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(car (u := cdr u), env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval(car (u := cdr u), env)); c!:endblock('goto, list join); c!:startblock l2; u := cdr u; if u then u := car u; % permit 2-arg version... c!:outop('movr, v, nil, c!:cval(u, env)); c!:endblock('goto, list join); c!:startblock join; return v end; put('if, 'c!:code, function c!:cif); symbolic procedure c!:clabels(u, env); error(0, "labels"); put('labels, 'c!:code, function c!:clabels); symbolic procedure c!:expand!-let(vl, b); if null vl then 'progn . b else if null cdr vl then c!:expand!-let!*(vl, b) else begin scalar vars, vals; for each v in vl do if atom v then << vars := v . vars; vals := nil . vals >> else if atom cdr v then << vars := car v . vars; vals := nil . vals >> else << vars := car v . vars; vals := cadr v . vals >>; % if there is any DECLARE it will be at the start of b and the code that % deals with LAMBDA will cope with it. return ('lambda . vars . b) . vals end; symbolic procedure c!:clet(x, env); c!:cval(c!:expand!-let(cadr x, cddr x), env); symbolic procedure c!:valid_let x; if null x then t else if not c!:valid_cond car x then nil else c!:valid_list cdr x; !#if common!-lisp!-mode put('let, 'c!:code, function c!:clet); put('let, 'c!:valid, function c!:valid_let); !#else put('!~let, 'c!:code, function c!:clet); put('!~let, 'c!:valid, function c!:valid_let); !#endif symbolic procedure c!:expand!-let!*(vl, b); if null vl then 'progn . b else begin scalar var, val; var := car vl; if not atom var then << val := cdr var; var := car var; if not atom val then val := car val >>; b := list list('return, c!:expand!-let!*(cdr vl, b)); if val then b := list('setq, var, val) . b; return 'prog . list var . b end; symbolic procedure c!:clet!*(x, env); c!:cval(c!:expand!-let!*(cadr x, cddr x), env); put('let!*, 'c!:code, function c!:clet!*); put('let!*, 'c!:valid, function c!:valid_let); symbolic procedure c!:clist(u, env); if null cdr u then c!:cval(nil, env) else if null cddr u then c!:cval('ncons . cdr u, env) else if eqcar(cadr u, 'cons) then c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) else if null cdddr u then c!:cval('list2 . cdr u, env) else if null cddddr u then c!:cval('list3 . cdr u, env) else if null cdr cddddr u then c!:cval('list4 . cdr u, env) else c!:cval(list('list3!*, cadr u, caddr u, cadddr u, 'list . cddddr u), env); put('list, 'c!:code, function c!:clist); symbolic procedure c!:clist!*(u, env); begin scalar v; u := reverse cdr u; v := car u; for each a in cdr u do v := list('cons, a, v); return c!:cval(v, env) end; put('list!*, 'c!:code, function c!:clist!*); symbolic procedure c!:ccons(u, env); begin scalar a1, a2; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if a2 = nil or a2 = '(quote nil) or a2 = '(list) then return c!:cval(list('ncons, a1), env); if eqcar(a1, 'cons) then return c!:cval(list('acons, cadr a1, caddr a1, a2), env); if eqcar(a2, 'cons) then return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); if eqcar(a2, 'list) then return c!:cval(list('cons, a1, list('cons, cadr a2, 'list . cddr a2)), env); return c!:ccall(car u, cdr u, env) end; put('cons, 'c!:code, function c!:ccons); symbolic procedure c!:cget(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('get, 'c!:code, function c!:cget); symbolic procedure c!:cflag(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('flagp, 'c!:code, function c!:cflag); symbolic procedure c!:cgetv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qgetv . cdr u, env); put('getv, 'c!:code, function c!:cgetv); !#if common!-lisp!-mode put('svref, 'c!:code, function c!:cgetv); !#endif symbolic procedure c!:cputv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qputv . cdr u, env); put('putv, 'c!:code, function c!:cputv); symbolic procedure c!:cqputv(x, env); begin scalar rr; rr := c!:pareval(cdr x, env); c!:outop('qputv, caddr rr, car rr, cadr rr); return caddr rr end; put('qputv, 'c!:code, function c!:cqputv); symbolic procedure c!:cmacrolet(u, env); error(0, "macrolet"); put('macrolet, 'c!:code, function c!:cmacrolet); symbolic procedure c!:cmultiple_value_call(u, env); error(0, "multiple_value_call"); put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); symbolic procedure c!:cmultiple_value_prog1(u, env); error(0, "multiple_value_prog1"); put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); symbolic procedure c!:cor(u, env); begin scalar next, done, v, r; v := c!:newreg(); done := c!:my_gensym(); u := cdr u; while cdr u do << next := c!:my_gensym(); c!:outop('movr, v, nil, c!:cval(car u, env)); u := cdr u; c!:endblock(list('ifnull, v), list(next, done)); c!:startblock next >>; c!:outop('movr, v, nil, c!:cval(car u, env)); c!:endblock('goto, list done); c!:startblock done; return v end; put('or, 'c!:code, function c!:cor); symbolic procedure c!:cprog(u, env); begin scalar w, w1, bvl, local_proglabs, progret, progexit, fluids, env1, body, decs; env1 := car env; bvl := cadr u; w := s!:find_local_decs(cddr u, t); body := cdr w; localdecs := car w . localdecs; % Anything DECLAREd special that is not already fluid or global % gets uprated now. decs ends up a list of things that had their status % changed. for each v in bvl do << if not globalp v and not fluidp v and c!:local_fluidp(v, localdecs) then << make!-special v; decs := v . decs >> >>; for each v in bvl do << if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v end; % Note I need to update local_decs if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('nilglob, nil, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movk1, cdar env1, nil, nil) >> >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); u := body; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (nil . progret . progexit) . blockstack; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else c!:cval(a, env); c!:outop('movk1, progret, nil, nil); c!:endblock('goto, list progexit); c!:startblock progexit; for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); blockstack := cdr blockstack; proglabs := cdr proglabs; unfluid decs; % reset effect of DECLARE localdecs := cdr localdecs; return progret end; put('prog, 'c!:code, function c!:cprog); symbolic procedure c!:valid_prog x; c!:valid_list cdr x; put('prog, 'c!:valid, function c!:valid_prog); symbolic procedure c!:cprog!*(u, env); error(0, "prog*"); put('prog!*, 'c!:code, function c!:cprog!*); symbolic procedure c!:cprog1(u, env); begin scalar g; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); return c!:cval(g, env) end; put('prog1, 'c!:code, function c!:cprog1); symbolic procedure c!:cprog2(u, env); begin scalar g; u := cdr u; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); g := list('progn, car u, g); return c!:cval(g, env) end; put('prog2, 'c!:code, function c!:cprog2); symbolic procedure c!:cprogn(u, env); begin scalar r; u := cdr u; if u = nil then u := '(nil); for each s in u do r := c!:cval(s, env); return r end; put('progn, 'c!:code, function c!:cprogn); symbolic procedure c!:cprogv(u, env); error(0, "progv"); put('progv, 'c!:code, function c!:cprogv); symbolic procedure c!:cquote(u, env); begin scalar v; u := cadr u; v := c!:newreg(); if null u or u = 't or c!:small_number u then c!:outop('movk1, v, nil, u) else c!:outop('movk, v, u, c!:find_literal u); return v; end; symbolic procedure c!:valid_quote x; t; put('quote, 'c!:code, function c!:cquote); put('quote, 'c!:valid, function c!:valid_quote); symbolic procedure c!:creturn(u, env); begin scalar w; w := assoc!*!*(nil, blockstack); if null w then error(0, "RETURN out of context"); c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; put('return, 'c!:code, function c!:creturn); !#if common!-lisp!-mode symbolic procedure c!:creturn_from(u, env); begin scalar w; w := assoc!*!*(cadr u, blockstack); if null w then error(0, "RETURN-FROM out of context"); c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; !#endif put('return!-from, 'c!:code, function c!:creturn_from); symbolic procedure c!:csetq(u, env); begin scalar v, w; v := c!:cval(caddr u, env); u := cadr u; if not idp u then error(0, list(u, "bad variable in setq")) else if (w := c!:locally_bound(u, env)) then c!:outop('movr, cdr w, nil, v) else if flagp(u, 'c!:constant) then error(0, list(u, "attempt to use setq on a constant")) else c!:outop('strglob, v, u, c!:find_literal u); return v end; put('setq, 'c!:code, function c!:csetq); put('noisy!-setq, 'c!:code, function c!:csetq); !#if common!-lisp!-mode symbolic procedure c!:ctagbody(u, env); begin scalar w, bvl, local_proglabs, res; u := cdr u; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else res := c!:cval(a, env); if null res then res := c!:cval(nil, env); proglabs := cdr proglabs; return res end; put('tagbody, 'c!:code, function c!:ctagbody); !#endif symbolic procedure c!:cprivate_tagbody(u, env); % This sets a label for use for tail-call to self. begin u := cdr u; c!:endblock('goto, list car u); c!:startblock car u; % This seems to be the proper place to capture the internal names associated % with argument-vars that must be reset if a tail-call is mapped into a loop. c!:current_args := for each v in c!:current_args collect begin scalar z; z := assoc!*!*(v, car env); return if z then cdr z else v end; return c!:cval(cadr u, env) end; put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); symbolic procedure c!:cthe(u, env); c!:cval(caddr u, env); put('the, 'c!:code, function c!:cthe); symbolic procedure c!:cthrow(u, env); error(0, "throw"); put('throw, 'c!:code, function c!:cthrow); symbolic procedure c!:cunless(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l2, l1); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('unless, 'c!:code, function c!:cunless); symbolic procedure c!:cunwind_protect(u, env); error(0, "unwind_protect"); put('unwind!-protect, 'c!:code, function c!:cunwind_protect); symbolic procedure c!:cwhen(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('when, 'c!:code, function c!:cwhen); % % End of code to handle special forms - what comes from here on is % more concerned with performance than with speed. % !#if (not common!-lisp!-mode) % mapcar etc are compiled specially as a fudge to achieve an effect as % if proper environment-capture was implemented for the functional % argument (which I do not support at present). symbolic procedure c!:expand_map(fnargs); begin scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; fn := car fnargs; % if the value of a mapping function is not needed I demote from mapcar to % mapc or from maplist to map. % if context > 1 then << % if fn = 'mapcar then fn := 'mapc % else if fn = 'maplist then fn := 'map >>; if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; fnargs := cdr fnargs; if atom fnargs then error(0,"bad arguments to map function"); fn1 := cadr fnargs; while eqcar(fn1, 'function) or (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << fn1 := cadr fn1; closed := t >>; % if closed is false I will insert FUNCALL since I am invoking a function % stored in a variable - NB this means that the word FUNCTION becomes % essential when using mapping operators - this is because I have built % a 2-Lisp rather than a 1-Lisp. args := car fnargs; l1 := c!:my_gensym(); r := c!:my_gensym(); s := c!:my_gensym(); var := c!:my_gensym(); avar := var; if carp then avar := list('car, avar); if closed then fn1 := list(fn1, avar) else fn1 := list('apply1, fn1, avar); moveon := list('setq, var, list('cdr, var)); if fn = 'map or fn = 'mapc then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon), '(prog (var) (setq var args) l1 (cond ((not var) (return nil))) fn moveon (go l1))) else if fn = 'maplist or fn = 'mapcar then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), '(prog (var r) (setq var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) moveon (go l1))) else fn := sublis( list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . c!:my_gensym(), 's . c!:my_gensym()), '(prog (var r s) (setq var args) (setq r (setq s (list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))); return fn end; put('map, 'c!:compile_macro, function c!:expand_map); put('maplist, 'c!:compile_macro, function c!:expand_map); put('mapc, 'c!:compile_macro, function c!:expand_map); put('mapcar, 'c!:compile_macro, function c!:expand_map); put('mapcon, 'c!:compile_macro, function c!:expand_map); put('mapcan, 'c!:compile_macro, function c!:expand_map); !#endif % caaar to cddddr get expanded into compositions of % car, cdr which are compiled in-line symbolic procedure c!:expand_carcdr(x); begin scalar name; name := cdr reverse cdr explode2 car x; x := cadr x; for each v in name do x := list(if v = 'a then 'car else 'cdr, x); return x end; << put('caar, 'c!:compile_macro, function c!:expand_carcdr); put('cadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdar, 'c!:compile_macro, function c!:expand_carcdr); put('cddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaar, 'c!:compile_macro, function c!:expand_carcdr); put('caadr, 'c!:compile_macro, function c!:expand_carcdr); put('cadar, 'c!:compile_macro, function c!:expand_carcdr); put('caddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); put('cddar, 'c!:compile_macro, function c!:expand_carcdr); put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); put('caadar, 'c!:compile_macro, function c!:expand_carcdr); put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); put('caddar, 'c!:compile_macro, function c!:expand_carcdr); put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; symbolic procedure c!:builtin_one(x, env); begin scalar r1, r2; r1 := c!:cval(cadr x, env); c!:outop(car x, r2:=c!:newreg(), cdr env, r1); return r2 end; symbolic procedure c!:builtin_two(x, env); begin scalar a1, a2, r, rr; a1 := cadr x; a2 := caddr x; rr := c!:pareval(list(a1, a2), env); c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); return r end; symbolic procedure c!:narg(x, env); c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); for each n in '((plus plus2) (times times2) (iplus iplus2) (itimes itimes2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#if common!-lisp!-mode for each n in '((!+ plus2) (!* times2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#endif symbolic procedure c!:cplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('add1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('add1, a), env) else if b = -1 then c!:cval(list('sub1, a), env) else c!:ccall(car u, cdr u, env) end; put('plus2, 'c!:code, function c!:cplus2); symbolic procedure c!:ciplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('iadd1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('iadd1, a), env) else if b = -1 then c!:cval(list('isub1, a), env) else c!:builtin_two(u, env) end; put('iplus2, 'c!:code, function c!:ciplus2); symbolic procedure c!:cdifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('minus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('sub1, a), env) else if b = -1 then c!:cval(list('add1, a), env) else c!:ccall(car u, cdr u, env) end; put('difference, 'c!:code, function c!:cdifference); symbolic procedure c!:cidifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('iminus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('isub1, a), env) else if b = -1 then c!:cval(list('iadd1, a), env) else c!:builtin_two(u, env) end; put('idifference, 'c!:code, function c!:cidifference); symbolic procedure c!:ctimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('minus, b), env) else if b = -1 then c!:cval(list('minus, a), env) else c!:ccall(car u, cdr u, env) end; put('times2, 'c!:code, function c!:ctimes2); symbolic procedure c!:citimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('iminus, b), env) else if b = -1 then c!:cval(list('iminus, a), env) else c!:builtin_two(u, env) end; put('itimes2, 'c!:code, function c!:citimes2); symbolic procedure c!:cminus(u, env); begin scalar a, b; a := s!:improve cadr u; return if numberp a then c!:cval(-a, env) else if eqcar(a, 'minus) then c!:cval(cadr a, env) else c!:ccall(car u, cdr u, env) end; put('minus, 'c!:code, function c!:cminus); symbolic procedure c!:ceq(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); return r end; put('eq, 'c!:code, function c!:ceq); symbolic procedure c!:cequal(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), r:=c!:newreg(), car rr, cadr rr); return r end; put('equal, 'c!:code, function c!:cequal); % % The next few cases are concerned with demoting functions that use % equal tests into ones that use eq instead symbolic procedure c!:is_fixnum x; fixp x and x >= -134217728 and x <= 134217727; symbolic procedure c!:certainlyatom x; null x or x=t or c!:is_fixnum x or (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); symbolic procedure c!:atomlist1 u; atom u or ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); symbolic procedure c!:atomlist x; null x or (eqcar(x, 'quote) and c!:atomlist1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:certainlyatom cadr x and c!:atomlist ('list . cddr x)))) or (eqcar(x, 'cons) and c!:certainlyatom cadr x and c!:atomlist caddr x); symbolic procedure c!:atomcar x; (eqcar(x, 'cons) or eqcar(x, 'list)) and not null cdr x and c!:certainlyatom cadr x; symbolic procedure c!:atomkeys1 u; atom u or (not atom car u and (symbolp caar u or c!:is_fixnum caar u) and c!:atomlist1 cdr u); symbolic procedure c!:atomkeys x; null x or (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:atomcar cadr x and c!:atomkeys ('list . cddr x)))) or (eqcar(x, 'cons) and c!:atomcar cadr x and c!:atomkeys caddr x); !#if (not common!-lisp!-mode) symbolic procedure c!:comsublis x; if c!:atomkeys cadr x then 'subla . cdr x else nil; put('sublis, 'c!:compile_macro, function c!:comsublis); symbolic procedure c!:comassoc x; if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x else nil; put('assoc, 'c!:compile_macro, function c!:comassoc); put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); symbolic procedure c!:commember x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x else nil; put('member, 'c!:compile_macro, function c!:commember); symbolic procedure c!:comdelete x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x else nil; put('delete, 'c!:compile_macro, function c!:comdelete); !#endif symbolic procedure c!:ctestif(x, env, d1, d2); begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:jumpif(cadr x, l1, l2); x := cddr x; c!:startblock l1; c!:jumpif(car x, d1, d2); c!:startblock l2; c!:jumpif(cadr x, d1, d2) end; put('if, 'c!:ctest, function c!:ctestif); symbolic procedure c!:ctestnull(x, env, d1, d2); c!:cjumpif(cadr x, env, d2, d1); put('null, 'c!:ctest, function c!:ctestnull); put('not, 'c!:ctest, function c!:ctestnull); symbolic procedure c!:ctestatom(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d1, d2)) end; put('atom, 'c!:ctest, function c!:ctestatom); symbolic procedure c!:ctestconsp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d2, d1)) end; put('consp, 'c!:ctest, function c!:ctestconsp); symbolic procedure c!:ctestsymbol(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifsymbol, x), list(d1, d2)) end; put('idp, 'c!:ctest, function c!:ctestsymbol); symbolic procedure c!:ctestnumberp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifnumber, x), list(d1, d2)) end; put('numberp, 'c!:ctest, function c!:ctestnumberp); symbolic procedure c!:ctestizerop(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifizerop, x), list(d1, d2)) end; put('izerop, 'c!:ctest, function c!:ctestizerop); symbolic procedure c!:ctesteq(x, env, d1, d2); begin scalar a1, a2, r; a1 := cadr x; a2 := caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock('ifeq . r, list(d1, d2)) end; put('eq, 'c!:ctest, function c!:ctesteq); symbolic procedure c!:ctesteqcar(x, env, d1, d2); begin scalar a1, a2, r, d3; a1 := cadr x; a2 := caddr x; d3 := c!:my_gensym(); r := c!:pareval(list(a1, a2), env); c!:endblock(list('ifatom, car r), list(d2, d3)); c!:startblock d3; c!:outop('qcar, car r, nil, car r); c!:endblock('ifeq . r, list(d1, d2)) end; put('eqcar, 'c!:ctest, function c!:ctesteqcar); global '(least_fixnum greatest_fixnum); least_fixnum := -expt(2, 27); greatest_fixnum := expt(2, 27) - 1; symbolic procedure c!:small_number x; fixp x and x >= least_fixnum and x <= greatest_fixnum; symbolic procedure c!:eqvalid x; if atom x then c!:small_number x else if flagp(car x, 'c!:fixnum_fn) then t else car x = 'quote and (idp cadr x or c!:small_number cadr x); flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); symbolic procedure c!:ctestequal(x, env, d1, d2); begin scalar a1, a2, r; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . r, list(d1, d2)) end; put('equal, 'c!:ctest, function c!:ctestequal); symbolic procedure c!:ctestneq(x, env, d1, d2); begin scalar a1, a2, r; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cjumpif(a2, env, d1, d2) else if a2 = nil then return c!:cjumpif(a1, env, d1, d2); r := c!:pareval(list(a1, a2), env); c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . r, list(d2, d1)) end; put('neq, 'c!:ctest, function c!:ctestneq); symbolic procedure c!:ctestilessp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifilessp . r, list(d1, d2)) end; put('ilessp, 'c!:ctest, function c!:ctestilessp); symbolic procedure c!:ctestigreaterp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifigreaterp . r, list(d1, d2)) end; put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); symbolic procedure c!:ctestand(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, next, d2); c!:startblock next >>; c!:endblock('goto, list d1) end; put('and, 'c!:ctest, function c!:ctestand); symbolic procedure c!:ctestor(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, d1, next); c!:startblock next >>; c!:endblock('goto, list d2) end; put('or, 'c!:ctest, function c!:ctestor); % Here are some of the things that are built into the Lisp kernel % and that I am happy to allow the compiler to generate direct calls to. % But NOTE that if any of these were callable with eg either 1 or 2 args % I would need DIFFERENT C entrypoints for each such case. To that effect % I need to change this to have % c!:c_entrypoint1, c!:c_entrypoint2 and c!:c_entrypointn % rather than a single property name. fluid '(c!:c_entrypoint_list); null (c!:c_entrypoint_list := '( (abs c!:c_entrypoint "Labsval") % (acons c!:c_entrypoint "Lacons") % (add1 c!:c_entrypoint "Ladd1") % (apply c!:c_entrypoint "Lapply") (apply0 c!:c_entrypoint "Lapply0") (apply1 c!:c_entrypoint "Lapply1") (apply2 c!:c_entrypoint "Lapply2") (apply3 c!:c_entrypoint "Lapply3") % (ash c!:c_entrypoint "Lash") (ash1 c!:c_entrypoint "Lash1") (atan c!:c_entrypoint "Latan") (atom c!:c_entrypoint "Latom") (atsoc c!:c_entrypoint "Latsoc") (batchp c!:c_entrypoint "Lbatchp") (boundp c!:c_entrypoint "Lboundp") (bps!-putv c!:c_entrypoint "Lbpsputv") (caaaar c!:c_entrypoint "Lcaaaar") (caaadr c!:c_entrypoint "Lcaaadr") (caaar c!:c_entrypoint "Lcaaar") (caadar c!:c_entrypoint "Lcaadar") (caaddr c!:c_entrypoint "Lcaaddr") (caadr c!:c_entrypoint "Lcaadr") (caar c!:c_entrypoint "Lcaar") (cadaar c!:c_entrypoint "Lcadaar") (cadadr c!:c_entrypoint "Lcadadr") (cadar c!:c_entrypoint "Lcadar") (caddar c!:c_entrypoint "Lcaddar") (cadddr c!:c_entrypoint "Lcadddr") (caddr c!:c_entrypoint "Lcaddr") (cadr c!:c_entrypoint "Lcadr") (car c!:c_entrypoint "Lcar") (cdaaar c!:c_entrypoint "Lcdaaar") (cdaadr c!:c_entrypoint "Lcdaadr") (cdaar c!:c_entrypoint "Lcdaar") (cdadar c!:c_entrypoint "Lcdadar") (cdaddr c!:c_entrypoint "Lcdaddr") (cdadr c!:c_entrypoint "Lcdadr") (cdar c!:c_entrypoint "Lcdar") (cddaar c!:c_entrypoint "Lcddaar") (cddadr c!:c_entrypoint "Lcddadr") (cddar c!:c_entrypoint "Lcddar") (cdddar c!:c_entrypoint "Lcdddar") (cddddr c!:c_entrypoint "Lcddddr") (cdddr c!:c_entrypoint "Lcdddr") (cddr c!:c_entrypoint "Lcddr") (cdr c!:c_entrypoint "Lcdr") (char!-code c!:c_entrypoint "Lchar_code") (close c!:c_entrypoint "Lclose") (codep c!:c_entrypoint "Lcodep") (constantp c!:c_entrypoint "Lconstantp") % (cons c!:c_entrypoint "Lcons") (date c!:c_entrypoint "Ldate") (deleq c!:c_entrypoint "Ldeleq") % (difference c!:c_entrypoint "Ldifference2") (digit c!:c_entrypoint "Ldigitp") (eject c!:c_entrypoint "Leject") (endp c!:c_entrypoint "Lendp") (eq c!:c_entrypoint "Leq") (eqcar c!:c_entrypoint "Leqcar") (eql c!:c_entrypoint "Leql") (eqn c!:c_entrypoint "Leqn") % (error c!:c_entrypoint "Lerror") (error1 c!:c_entrypoint "Lerror0") % !!! % (errorset c!:c_entrypoint "Lerrorset") (evenp c!:c_entrypoint "Levenp") (evlis c!:c_entrypoint "Levlis") (explode c!:c_entrypoint "Lexplode") (explode2 c!:c_entrypoint "Lexplodec") (explodec c!:c_entrypoint "Lexplodec") (expt c!:c_entrypoint "Lexpt") (fix c!:c_entrypoint "Ltruncate") (fixp c!:c_entrypoint "Lfixp") (flag c!:c_entrypoint "Lflag") (flagp!*!* c!:c_entrypoint "Lflagp") (flagp c!:c_entrypoint "Lflagp") (flagpcar c!:c_entrypoint "Lflagpcar") (float c!:c_entrypoint "Lfloat") (floatp c!:c_entrypoint "Lfloatp") (fluidp c!:c_entrypoint "Lsymbol_specialp") (gcdn c!:c_entrypoint "Lgcd") (gctime c!:c_entrypoint "Lgctime") (gensym c!:c_entrypoint "Lgensym") (gensym1 c!:c_entrypoint "Lgensym1") (geq c!:c_entrypoint "Lgeq") (get!* c!:c_entrypoint "Lget") % (get c!:c_entrypoint "Lget") (getenv c!:c_entrypoint "Lgetenv") (getv c!:c_entrypoint "Lgetv") (svref c!:c_entrypoint "Lgetv") (globalp c!:c_entrypoint "Lsymbol_globalp") (greaterp c!:c_entrypoint "Lgreaterp") (iadd1 c!:c_entrypoint "Liadd1") (idifference c!:c_entrypoint "Lidifference") (idp c!:c_entrypoint "Lsymbolp") (igreaterp c!:c_entrypoint "Ligreaterp") (ilessp c!:c_entrypoint "Lilessp") (iminus c!:c_entrypoint "Liminus") (iminusp c!:c_entrypoint "Liminusp") (indirect c!:c_entrypoint "Lindirect") (integerp c!:c_entrypoint "Lintegerp") (iplus2 c!:c_entrypoint "Liplus2") (iquotient c!:c_entrypoint "Liquotient") (iremainder c!:c_entrypoint "Liremainder") (irightshift c!:c_entrypoint "Lirightshift") (isub1 c!:c_entrypoint "Lisub1") (itimes2 c!:c_entrypoint "Litimes2") % (lcm c!:c_entrypoint "Llcm") (length c!:c_entrypoint "Llength") (lengthc c!:c_entrypoint "Llengthc") (leq c!:c_entrypoint "Lleq") (lessp c!:c_entrypoint "Llessp") (linelength c!:c_entrypoint "Llinelength") % (list2!* c!:c_entrypoint "Llist2star") % (list2 c!:c_entrypoint "Llist2") % (list3 c!:c_entrypoint "Llist3") (load!-module c!:c_entrypoint "Lload_module") % (lognot c!:c_entrypoint "Llognot") (lposn c!:c_entrypoint "Llposn") (macro!-function c!:c_entrypoint "Lmacro_function") (macroexpand!-1 c!:c_entrypoint "Lmacroexpand_1") (macroexpand c!:c_entrypoint "Lmacroexpand") (make!-bps c!:c_entrypoint "Lget_bps") (make!-global c!:c_entrypoint "Lmake_global") (make!-simple!-string c!:c_entrypoint "Lsmkvect") (make!-special c!:c_entrypoint "Lmake_special") (mapstore c!:c_entrypoint "Lmapstore") (max2 c!:c_entrypoint "Lmax2") (memq c!:c_entrypoint "Lmemq") (min2 c!:c_entrypoint "Lmin2") (minus c!:c_entrypoint "Lminus") (minusp c!:c_entrypoint "Lminusp") (mkquote c!:c_entrypoint "Lmkquote") (mkvect c!:c_entrypoint "Lmkvect") (mod c!:c_entrypoint "Lmod") (modular!-difference c!:c_entrypoint "Lmodular_difference") (modular!-expt c!:c_entrypoint "Lmodular_expt") (modular!-minus c!:c_entrypoint "Lmodular_minus") (modular!-number c!:c_entrypoint "Lmodular_number") (modular!-plus c!:c_entrypoint "Lmodular_plus") (modular!-quotient c!:c_entrypoint "Lmodular_quotient") (modular!-reciprocal c!:c_entrypoint "Lmodular_reciprocal") (modular!-times c!:c_entrypoint "Lmodular_times") (nconc c!:c_entrypoint "Lnconc") % (ncons c!:c_entrypoint "Lncons") (neq c!:c_entrypoint "Lneq") % (next!-random!-number c!:c_entrypoint "Lnext_random") (not c!:c_entrypoint "Lnull") (null c!:c_entrypoint "Lnull") (numberp c!:c_entrypoint "Lnumberp") (oddp c!:c_entrypoint "Loddp") (onep c!:c_entrypoint "Lonep") (orderp c!:c_entrypoint "Lorderp") % (ordp c!:c_entrypoint "Lorderp") (pagelength c!:c_entrypoint "Lpagelength") (pairp c!:c_entrypoint "Lconsp") (plist c!:c_entrypoint "Lplist") % (plus2 c!:c_entrypoint "Lplus2") (plusp c!:c_entrypoint "Lplusp") (posn c!:c_entrypoint "Lposn") (put c!:c_entrypoint "Lputprop") (putv!-char c!:c_entrypoint "Lsputv") (putv c!:c_entrypoint "Lputv") (qcaar c!:c_entrypoint "Lcaar") (qcadr c!:c_entrypoint "Lcadr") (qcar c!:c_entrypoint "Lcar") (qcdar c!:c_entrypoint "Lcdar") (qcddr c!:c_entrypoint "Lcddr") (qcdr c!:c_entrypoint "Lcdr") (qgetv c!:c_entrypoint "Lgetv") % (quotient c!:c_entrypoint "Lquotient") % (random c!:c_entrypoint "Lrandom") % (rational c!:c_entrypoint "Lrational") (rds c!:c_entrypoint "Lrds") (reclaim c!:c_entrypoint "Lgc") % (remainder c!:c_entrypoint "Lrem") (remd c!:c_entrypoint "Lremd") (remflag c!:c_entrypoint "Lremflag") (remob c!:c_entrypoint "Lunintern") (remprop c!:c_entrypoint "Lremprop") (reverse c!:c_entrypoint "Lreverse") (reversip c!:c_entrypoint "Lnreverse") (rplaca c!:c_entrypoint "Lrplaca") (rplacd c!:c_entrypoint "Lrplacd") (schar c!:c_entrypoint "Lsgetv") (seprp c!:c_entrypoint "Lwhitespace_char_p") (set!-small!-modulus c!:c_entrypoint "Lset_small_modulus") (set c!:c_entrypoint "Lset") (smemq c!:c_entrypoint "Lsmemq") (spaces c!:c_entrypoint "Lxtab") (special!-char c!:c_entrypoint "Lspecial_char") (special!-form!-p c!:c_entrypoint "Lspecial_form_p") (spool c!:c_entrypoint "Lspool") (stop c!:c_entrypoint "Lstop") (stringp c!:c_entrypoint "Lstringp") % (sub1 c!:c_entrypoint "Lsub1") (subla c!:c_entrypoint "Lsubla") (subst c!:c_entrypoint "Lsubst") (symbol!-env c!:c_entrypoint "Lsymbol_env") (symbol!-function c!:c_entrypoint "Lsymbol_function") (symbol!-name c!:c_entrypoint "Lsymbol_name") (symbol!-set!-definition c!:c_entrypoint "Lsymbol_set_definition") (symbol!-set!-env c!:c_entrypoint "Lsymbol_set_env") (symbol!-value c!:c_entrypoint "Lsymbol_value") (system c!:c_entrypoint "Lsystem") (terpri c!:c_entrypoint "Lterpri") (threevectorp c!:c_entrypoint "Lthreevectorp") (time c!:c_entrypoint "Ltime") % (times2 c!:c_entrypoint "Ltimes2") (ttab c!:c_entrypoint "Lttab") (tyo c!:c_entrypoint "Ltyo") (unmake!-global c!:c_entrypoint "Lunmake_global") (unmake!-special c!:c_entrypoint "Lunmake_special") (upbv c!:c_entrypoint "Lupbv") (verbos c!:c_entrypoint "Lverbos") (wrs c!:c_entrypoint "Lwrs") (xcons c!:c_entrypoint "Lxcons") (xtab c!:c_entrypoint "Lxtab") % (orderp c!:c_entrypoint "Lorderp") being retired. (zerop c!:c_entrypoint "Lzerop") % The following can be called without having to provide an environment % or arg-count. The compiler should check the number of args being % passed matches the expected number. (cons c!:direct_entrypoint (2 . "cons")) (ncons c!:direct_entrypoint (1 . "ncons")) (list2 c!:direct_entrypoint (2 . "list2")) (list2!* c!:direct_entrypoint (3 . "list2star")) (acons c!:direct_entrypoint (3 . "acons")) (list3 c!:direct_entrypoint (3 . "list3")) (list3!* c!:direct_entrypoint (4 . "list3star")) (list4 c!:direct_entrypoint (4 . "list4")) (plus2 c!:direct_entrypoint (2 . "plus2")) (difference c!:direct_entrypoint (2 . "difference2")) (add1 c!:direct_entrypoint (1 . "add1")) (sub1 c!:direct_entrypoint (1 . "sub1")) (lognot c!:direct_entrypoint (1 . "lognot")) (ash c!:direct_entrypoint (2 . "ash")) (quotient c!:direct_entrypoint (2 . "quot2")) (remainder c!:direct_entrypoint (2 . "Cremainder")) (times2 c!:direct_entrypoint (2 . "times2")) (minus c!:direct_entrypoint (1 . "negate")) % (rational c!:direct_entrypoint (1 . "rational")) (lessp c!:direct_predicate (2 . "lessp2")) (leq c!:direct_predicate (2 . "lesseq2")) (greaterp c!:direct_predicate (2 . "greaterp2")) (geq c!:direct_predicate (2 . "geq2")) (zerop c!:direct_predicate (1 . "zerop")) ))$ !#if common!-lisp!-mode null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( (!1!+ c!:c_entrypoint "Ladd1") (equal c!:c_entrypoint "Lcl_equal") (!1!- c!:c_entrypoint "Lsub1") (vectorp c!:c_entrypoint "Lvectorp"))))$ !#endif !#if (not common!-lisp!-mode) null (c!:c_entrypoint_list := append(c!:c_entrypoint_list, '( (append c!:c_entrypoint "Lappend") (assoc c!:c_entrypoint "Lassoc") (compress c!:c_entrypoint "Lcompress") (delete c!:c_entrypoint "Ldelete") (divide c!:c_entrypoint "Ldivide") (equal c!:c_entrypoint "Lequal") (intern c!:c_entrypoint "Lintern") (liter c!:c_entrypoint "Lalpha_char_p") (member c!:c_entrypoint "Lmember") (prin c!:c_entrypoint "Lprin") (prin1 c!:c_entrypoint "Lprin") (prin2 c!:c_entrypoint "Lprinc") (princ c!:c_entrypoint "Lprinc") (print c!:c_entrypoint "Lprint") (printc c!:c_entrypoint "Lprintc") (read c!:c_entrypoint "Lread") (readch c!:c_entrypoint "Lreadch") (sublis c!:c_entrypoint "Lsublis") (vectorp c!:c_entrypoint "Lsimple_vectorp") (get c!:direct_entrypoint (2 . "get")))))$ !#endif for each x in c!:c_entrypoint_list do put(car x, cadr x, caddr x)$ flag( '(atom atsoc codep constantp deleq digit endp eq eqcar evenp eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift isub1 itimes2 liter memq minusp modular!-difference modular!-expt modular!-minus modular!-number modular!-plus modular!-times not null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr qcdr remflag remprop reversip seprp special!-form!-p stringp symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), 'c!:no_errors); end; % End of ccomp.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/unbyte.red0000644000175000017500000015524511550002751023570 0ustar giovannigiovanni linelength 72; in "struct.red"$ fluid '(all_jumps); % % "unbyte" is the main body of the decoder % fluid '(!@a !@b !@w !@stack !@catch); global '(opnames); symbolic procedure unbyte name; begin scalar pc, code, len, env, byte, r, entry_stack, w, w1, w2, args, nargs, stack, deepest, locals, all_jumps, !@a, !@b, !@w, !@stack, !@catch; !@a := gensym(); !@b := gensym(); !@w := gensym(); !@stack := gensym(); code := symbol!-env name; nargs := symbol!-argcount name; if atom code or not bpsp car code then return nil; env := cdr code; code := car code; len := bps!-upbv code; % If the function has 4 or more arge then the first byte of the bytestream % says just how many. If it has &optional and/or &rest support the first % two bytes give information on the largest and smallest valid number of % args. if fixp nargs then << entry_stack := nargs; if nargs < 4 then pc := 0 else pc := 1 >> else << entry_stack := cadr nargs; if logand(caddr nargs, 2) neq 0 then entry_stack := entry_stack+1; pc := 2 >>; % The first stage will be to unpick the byte-stream into at least some sort % of more spread-out data structure, recognising the lengths of various % instructions. The output I will collect will be a list where each item is % of the form % (address nil s-expression-1 s-expression-1 ...) % with stack operands shown as (stack nn) and label operands as numeric % offsets. Subsequent passes will use the field that is initially set as % nil to help me decide where labels should be set and I will need to % convert data references from being relative to the top of the stack into % being relative to a known stack-base. r := nil; all_jumps := list(nil, pc); % Force label on entrypoint while pc <= len do << byte := bps!-getv(code, pc); w := funcall(getv(opnames, byte), pc+1, code, env); % If the previous instruction had been a branch (marked here as an IF % statement) then I would have indicated a jump to an explicit label as % the ELSE part and I want to set the label concerned on whatever follows. % The stacked-up IF is stored as % (address label (IF cond dest (GO ggg))) % where ggg is what I want. if r then w1 := caddr car r else w1 := nil; if eqcar(w1, 'if) then r := (pc . cadr cadddr w1 . cdr w) . r else r := (pc . nil . cdr w) . r; pc := pc + car w >>; % All jumps in the code will have been represented as % (if xxx (go xx) (go yy)) % but in the first pass I can not have these resolved as symbolic labels. % To begin with xx will be a numeric address, and the items (go xx) will be % cahined through their CAR fields (so the 'go is not present yet). The % (go yy) will have a symbolic label for yy and this must be set on the % instruction immediately after then goto. while all_jumps do << w := assoc(cadr all_jumps, r); % The branch destination if null w then error(1, "Branch destination not found"); if null cadr w then rplaca(cdr w, gensym()); rplaca(cdr all_jumps, cadr w); w := car all_jumps; rplaca(all_jumps, 'go); all_jumps := w >>; % Now jumps are under control I will consolidate the entire decoded mess into % a collection of basic blocks, keyed by labels. At this stage it is % possible for a block not to have any explicit branch at its end. I want to % change that so that every block does end in an explicit jump or exit. The % cases I will recognise are: % (if ...) % (go ..) % (return ..) % (throw) and maybe some others that I am not worrying about yet w := nil; while r do << w1 := cddar r; w2 := w1; while cdr w2 do w2 := cdr w2; w2 := car w2; % Final instruction in this block % Append GO to drop through, if necessary if w and not ( eqcar(w2, 'if) or eqcar(w2, 'go) or eqcar(w2, 'return) or eqcar(w2, 'throw)) then << w1 := append(w1, list list('go, caar w)) >>; while null cadar r do << r := cdr r; w1 := append(cddar r, w1) >>; w := (cadar r . nil . w1) . w; r := cdr r >>; % The next thing I have to do is to link FREERSTR opcodes up with the % FREEBIND opcodes that they belong to. I NEED to do this early on % because a FREEBIND and its FREERSTR move the stack up or down by % an amount dependent on the number of variables being bound. For FREEBIND % this is instantly visible, but for FREERSTR the information is only % available by determining which FREEBIND it matches. But finding this % out should be OK since every FREERSTR should correspond to exactly one % FREEBIND. Because there should be no ambiguity at all about matching % binds with restores I can have a fairly simple version of data flow % analysis to make the link-up. rplaca(cdar w, list nil); % No free bindings at entry-point r := list caar w; % pending blocks while r do begin scalar n; w1 := assoc(car r, w); r := cdr r; n := caadr w1; for each z in cddr w1 do << if eqcar(z, 'freebind) then n := cadr z . n else if eqcar(z, 'freerstr) then << rplaca(cdr z, car n); n := cdr n >> else if eqcar(z, 'if) then << r := set_bind(assoc(cadr caddr z, w), r, n); r := set_bind(assoc(cadr cadddr z, w), r, n) >> else if eqcar(z, 'go) then r := set_bind(assoc(cadr z, w), r, n) >> end; % Blocks are now in order with the starting basic block at the top of % the list (w). Each block is (label flag contents..) where the flag is nil % at present. I will traverse the collection of blocks replacing the nils % with the stack depth in force at the start of each block. This gives % me a chance to detect inconsistencies in this area, but is also % a vital prelude to replacing stack references with names. for each z in w do rplaca(cdr z, nil); rplaca(cdar w, entry_stack); % stack depth for entry block deepest := entry_stack; r := list caar w; % list of "pending" blocks while r do begin scalar n; w1 := assoc(car r, w); if null w1 then << prin car r; princ " not found in "; print w; error(1, r) >>; r := cdr r; n := cadr w1; if n > deepest then deepest := n; for each z in cddr w1 do << if z = 'push then n := n + 1 else if z = 'lose then n := n - 1 else if eqcar(z, 'freebind) then n := n + 2 + length cadr z else if z = 'pvbind then n := n + 2 else if eqcar(z, 'freerstr) then n := n - 2 - length cadr z else if z = 'pvrestore then n := n - 2 else if z = 'uncatch or z = 'unprotect then n := n - 3 else if eqcar(z, 'if) then << if eqcar(cadr z, !@catch) then << n := n+3; rplaca(z, 'ifcatch) >>; r := set_stack(assoc(cadr caddr z, w), r, n); r := set_stack(assoc(cadr cadddr z, w), r, n) >> else if eqcar(z, 'go) then r := set_stack(assoc(cadr z, w), r, n); if n < entry_stack then error(1, "Too many POPs in the codestream") else if n > deepest then deepest := n >> end; % Now I want three separate things. One is the list of formal arguments % to be put in a procedure header. This must contain annotations such as % &optional and &rest where relevant. The other is a map of the stack. % this will include all arguments, but without &optional etc. The final thing % will be a list of local variables required for this procedure. This % will include all the stack items not present as arguments together with % the workspace items !@a, !@b and !@w. args := stack := locals := nil; if fixp nargs then << for i := 1:nargs do stack := gensym() . stack; args := reverse stack >> else << for i := 1:car nargs do stack := gensym() . stack; args := stack; if not (cadr nargs = car nargs) then << args := '!&optional . args; for i := car nargs+1:cadr nargs do << w1 := gensym(); stack := w1 . stack; if logand(caddr nargs, 1) = 0 then args := w1 . args else args := list(w1, ''!*spid!*) . args >>; if logand(caddr nargs, 2) neq 0 then << w1 := gensym(); stack := w1 . stack; args := w1 . '!&rest . args >> >>; args := reverse args >>; locals := list(!@a, !@b, !@w); for i := 1+length stack:deepest do locals := gensym() . locals; % Now if I find a reference to a location (!@stack n) at a stage when % the logical stack depth is m I can map it onto a reference to a simple % variable - either a local or one of the arguments. The code in % stackref knows how to do this. for each b in w do begin scalar m, z1; m := cadr b; if not fixp m then error(1, "Unreferenced code block"); for each z in cddr b do << if z = 'push then m := m + 1 else if z = 'lose then m := m - 1 else if eqcar(z, 'freebind) then m := m + 2 + length cadr z else if z = 'pvbind then m := m + 2 else if eqcar(z, 'freerstr) then m := m - 2 - length cadr z else if z = 'pvrestore then m := m - 2 else if z = 'uncatch or z = 'unprotect then m := m - 3 else << z1 := stackref(z, m, stack, locals, entry_stack); rplaca(z, car z1); rplacd(z, cdr z1) >> >>; end; % Now is the time to deal with constructs that include matching % pairs of byte-opcodes that must be brought together in the reconstructed % Lisp code. The cases that arise are % FREEBIND(data); ... FREERSTR % which must map onto % (prog (vars) ...) % and note that there could be several places where the FREERSTR % is present - these can correspond to places where the original % code contained a RETURN or a GO that exited from the scope % of the fluid binding. Since at the level I am working here % values are passed in the !@a variable I do not need to distinguish % these cases too specially and reconstruct clever arguments for % a RETURN. If there is just one exit point from the reconstructed % block I may as well use RETURN but it is not vital. % % CATCH(label); ....UNCATCH; label: ... % the label mentioned in the CATCH ought always to be the one % just after an UNCATCH. There can be other UNCATCH statements % on branches through the code that represent lexical exits from the % protected region (eg GO or RETURN). Distinguishing between % exits of this sort that represent GO and those that are RETURN % seems un-obvious but is a similar issue to the case with FREEBIND % and so perhaps does not matter too much. % (catch !@a ... (go label)) label: % % PVBIND; ... PVRESTORE % this is for % (progv !@a !@b ...) % teh compiler arranges for PVRESTOREs to be placed on every exit % from the funny region, and so arguments similar to those for % FREEBIND and CATCH apply about multiple exits. % % (setq @a (load-spid)) CATCH(label); ... PROTECT; label: ... UNPROTECT % the CATCH used here is passed the result from the builtin function % (load-spid), which obtains a value that would not be valid as a % proper catch tag. The purpose of the PROTECT and UNPROTECT is % to delimit the cleanup forms and so indicate that a proper % value from the main protected form should survive across % that region. % Any lexical (eg GO or RETURN) exit from the protected region % will have the sequence PROTECT cleanup-forms UNPROTECT inserted % along the path. Lexical exits from the region between PROTECT % and UNPROTECT are possible and will just LOSE three items from % the stack on the way, thereby discarding the way in which % the execution of UNPROTECT would have re-instated the exit % values and condition from the protected region. % w := fix_free_bindings w; % Ignore catch, unwind-protect, progv for now. w := optimise_blocks(w, stack, locals); r := 'prog . locals . flowgraph_to_lisp w; terpri(); princ "=> "; prettyprint r; w := errorset(list('structchk, mkquote r), t, t); if not atom w then r := car w; r := list('de, name, args, r); terpri(); princ "Finally: "; prettyprint r; return nil end; symbolic procedure flowgraph_to_lisp w; begin scalar r; for each i in w do << r := car i . r; for each j in cddr i do << if eqcar(j, 'prog) then r := ('prog . cadr j . flowgraph_to_lisp cddr j) . r % I convert from IF into COND because that will interact better with the % re-structuring code that is used later on. else if eqcar(j, 'if) then r := list('cond, list(cadr j, caddr j), list('t, cadddr j)) . r else if eqcar(j, 'freerstr) or eqcar(j, 'progexits) then nil else if not member(j, '(push lose)) then r := j . r >> >>; return reversip r end; symbolic procedure set_stack(block, r, n); if null cadr block then << rplaca(cdr block, n); car block . r >> else if not (cadr block = n) then << printc "++++ Stack confusion"; prin n; princ " vs. "; print block; r >> else r; symbolic procedure set_bind(block, r, n); if null cadr block then << rplaca(cdr block, list n); car block . r >> else if not (caadr block = n) then << printc "++++ Binding confusion"; prin n; princ " vs. "; print block; r >> else r; symbolic procedure stackref(u, m, stack, locals, entry_stack); if atom u or eqcar(u, 'quote) then u else if eqcar(u, !@stack) then begin scalar n, x; n := cadr u; x := n - m + entry_stack; if x >= 0 then << if x >= entry_stack then error(1, "Reference outside stack-frame"); for i := 1:x do stack := cdr stack; return car stack >> else << for i := 1:-(x+1) do locals := cdr locals; return car locals >> end else for each x in u collect stackref(x, m, stack, locals, entry_stack); opnames := mkvect 255$ % The table that follows lists the various opcodes that are used here. % Each of these must be decoded, and the irregularity of the "machine" % involved will leave this process rather untidy. For instance opcodes % with similar actions are grouped together here but addressing modes are % not at all consistently supported. This irregularity is not an accident: % it is a consequence of attempting to keep code sequences as short as % convenient. %-- LOADLOC general opcode to load from the stack %-- LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 specific offsets %-- LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 %-- LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 %-- combinations to load two values (especially common cases) %-- LOC0LOC1 LOC1LOC2 LOC2LOC3 %-- LOC1LOC0 LOC2LOC1 LOC3LOC2 %-- %-- VNIL load the value NIL %-- %-- LOADLIT load a literal from the literal vector %-- LOADLIT1 LOADLIT2 LOADLIT3 specific offsets %-- LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 %-- %-- LOADFREE load value of a free (FLUID/SPECIAL) variable %-- LOADFREE1 LOADFREE2 LOADFREE3 specific offsets %-- LOADFREE4 %-- %-- STORELOC Store onto stack %-- STORELOC0 STORELOC1 STORELOC2 STORELOC3 specific offsets %-- STORELOC4 STORELOC5 STORELOC6 STORELOC7 %-- %-- STOREFREE Set value of FLUID/SPECIAL variable %-- STOREFREE1 STOREFREE2 STOREFREE3 %-- %-- LOADLEX access to non-local lexical variables (for Common Lisp) %-- STORELEX %-- CLOSURE %-- %-- Code to access local variables and also take CAR or CDR %-- CARLOC0 CARLOC1 CARLOC2 CARLOC3 %-- CARLOC4 CARLOC5 CARLOC6 CARLOC7 %-- CARLOC8 CARLOC9 CARLOC10 CARLOC11 %-- CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 %-- CDRLOC4 CDRLOC5 %-- CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3 %-- %-- Function call support %-- CALL0 CALL1 CALL2 CALL2R CALL3 CALLN %-- CALL0_0 CALL0_1 CALL0_2 CALL0_3 %-- CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 %-- CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4 %-- BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 %-- APPLY1 APPLY2 APPLY3 APPLY4 %-- JCALL JCALLN %-- %-- Branches. The main collection come in variants with long or short %-- offsets and with the branch to go fowards or backwards. %-- JUMP JUMP_B JUMP_L JUMP_BL %-- JUMPNIL JUMPNIL_B JUMPNIL_L JUMPNIL_BL %-- JUMPT JUMPT_B JUMPT_L JUMPT_BL %-- JUMPATOM JUMPATOM_B JUMPATOM_L JUMPATOM_BL %-- JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL %-- JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL %-- JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL %-- JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL %-- JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL %-- %-- The following jumps go forwards only, and by only short offsets. They %-- are provided to support a collection of common special cases %-- (a) test local variables for NIl or TRUE %-- JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T %-- JUMPL2NIL JUMPL2T JUMPL3NIL JUMPL3T %-- JUMPL4NIL JUMPL4T %-- (b) store in a local variable and test for NIL or TRUE %-- JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T %-- JUMPST2NIL JUMPST2T %-- (c) test if local variable is atomic or not %-- JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM %-- JUMPL2ATOM JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM %-- (d) test free variable for NIL or TRUE %-- JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL JUMPFREE2T %-- JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T %-- JUMPFREENIL JUMPFREET %-- (e) test for equality (EQ) against literal value %-- JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE %-- JUMPLIT3EQ JUMPLIT3NE JUMPLIT4EQ JUMPLIT4NE %-- JUMPLITEQ JUMPLITNE %-- (f) call built-in one-arg function and use that as a predicate %-- JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T %-- (g) flagp with a literal tag %-- JUMPFLAGP JUMPNFLAGP %-- (h) EQCAR test against literal %-- JUMPEQCAR JUMPNEQCAR %-- %-- CATCH needs something that behaves a bit like a (general) jump. %-- CATCH CATCH_B CATCH_L CATCH_BL %-- After a CATCH the stack (etc) needs restoring %-- UNCATCH THROW PROTECT UNPROTECT %-- %-- PVBIND PVRESTORE PROGV support %-- FREEBIND FREERSTR Bind/restore FLUID/SPECIAL variables %-- %-- Exiting from a procedure, optionally popping the stack a bit %-- EXIT NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT %-- %-- General stack management %-- PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS %-- POP LOSE LOSE2 LOSE3 LOSES %-- %-- Exchange A and B registers %-- SWOP %-- %-- Various especially havily used Lisp functions %-- EQ EQCAR EQUAL NUMBERP %-- CAR CDR CAAR CADR CDAR CDDR %-- CONS NCONS XCONS ACONS LENGTH %-- LIST2 LIST2STAR LIST3 %-- PLUS2 ADD1 DIFFERENCE SUB1 TIMES2 %-- GREATERP LESSP %-- FLAGP GET LITGET %-- GETV QGETV QGETVN %-- %-- Support for over-large stack-frames (LOADLOC/STORELOC + lexical access) %-- BIGSTACK %-- Support for CALLs where the literal vector has become huge %-- BIGCALL %-- %-- An integer-based SWITCH or CASE statement has special support %-- ICASE %-- %-- Speed-up support for compiled GET and FLAGP when tag is important %-- FASTGET %-- %-- Opcodes that have not yet been allocated. %-- SPARE1 %-- SPARE2 %-- in "../cslbase/opcodes.red"; begin scalar w; w := s!:opcodelist; for i := 0:255 do << putv(opnames, i, compress('h . '!! . '!: . explode car w)); w := cdr w >> end; global '(builtin0 builtin1 builtin2 builtin3); builtin0 := mkvect 255$ builtin1 := mkvect 255$ builtin2 := mkvect 255$ builtin3 := mkvect 255$ for each x in oblist() do begin scalar w; if (w := get(x, 's!:builtin0)) then putv(builtin0, w, x) else if (w := get(x, 's!:builtin1)) then putv(builtin1, w, x) else if (w := get(x, 's!:builtin2)) then putv(builtin2, w, x) else if (w := get(x, 's!:builtin3)) then putv(builtin3, w, x) end; % Now I have one procedure per opcode, so I can call the helper code to % do the decoding. The result that must be handed back will be % (n-bytes lisp1 lisp2 ...) where n-bytes is the number of % bytes that composes this instruction. One could readily argue that the % large number of somewhat repetitive procedures here represents bad % software design and that some table-driven approach would be much better. % My defence is that the bytecode model is inherently irregular and so the % flexibility of using code is useful. off echo; symbolic procedure byte1; bps!-getv(code, pc); symbolic procedure byte2; bps!-getv(code, pc+1); symbolic procedure twobytes; 256*byte1() + byte2(); symbolic procedure makeif(why, loc); list('if, why, loc, list('go, gensym())); symbolic procedure jumpto x; all_jumps := list(all_jumps, x); symbolic procedure jumpop why; list(2, makeif(why, jumpto(pc + byte1() + 1))); symbolic procedure jumpopb why; list(2, makeif(why, jumpto(pc - byte1() + 1))); symbolic procedure jumpopl why; list(3, makeif(why, jumpto(pc + twobytes() + 1))); symbolic procedure jumpopbl why; list(3, makeif(why, jumpto(pc - twobytes() + 1))); << symbolic procedure h!:LOADLOC(pc, code, env); list(2, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, byte1()))); symbolic procedure h!:LOADLOC0(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 0))); symbolic procedure h!:LOADLOC1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 1))); symbolic procedure h!:LOADLOC2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 2))); symbolic procedure h!:LOADLOC3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 3))); symbolic procedure h!:LOADLOC4(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 4))); symbolic procedure h!:LOADLOC5(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 5))); symbolic procedure h!:LOADLOC6(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 6))); symbolic procedure h!:LOADLOC7(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 7))); symbolic procedure h!:LOADLOC8(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 8))); symbolic procedure h!:LOADLOC9(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 9))); symbolic procedure h!:LOADLOC10(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 10))); symbolic procedure h!:LOADLOC11(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(!@stack, 11))); symbolic procedure h!:LOC0LOC1(pc, code, env); list(1, list('setq, !@b, list(!@stack, 0)), list('setq, !@a, list(!@stack, 1))); symbolic procedure h!:LOC1LOC2(pc, code, env); list(1, list('setq, !@b, list(!@stack, 1)), list('setq, !@a, list(!@stack, 2))); symbolic procedure h!:LOC2LOC3(pc, code, env); list(1, list('setq, !@b, list(!@stack, 2)), list('setq, !@a, list(!@stack, 3))); symbolic procedure h!:LOC1LOC0(pc, code, env); list(1, list('setq, !@b, list(!@stack, 1)), list('setq, !@a, list(!@stack, 1))); symbolic procedure h!:LOC2LOC1(pc, code, env); list(1, list('setq, !@b, list(!@stack, 2)), list('setq, !@a, list(!@stack, 1))); symbolic procedure h!:LOC3LOC2(pc, code, env); list(1, list('setq, !@b, list(!@stack, 3)), list('setq, !@a, list(!@stack, 2))); symbolic procedure h!:VNIL(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, nil)); symbolic procedure freeref(env, n); if n < 0 or n > upbv env then error(1, "free variable (etc) reference failure") else getv(env, n); symbolic procedure litref(env, n); if n < 0 or n > upbv env then error(1, "literal reference failure") else mkquote getv(env, n); symbolic procedure h!:LOADLIT(pc, code, env); list(2, list('setq, !@b, !@a), list('setq, !@a, litref(env, byte1()))); symbolic procedure h!:LOADLIT1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 1))); symbolic procedure h!:LOADLIT2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 2))); symbolic procedure h!:LOADLIT3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 3))); symbolic procedure h!:LOADLIT4(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 4))); symbolic procedure h!:LOADLIT5(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 5))); symbolic procedure h!:LOADLIT6(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 6))); symbolic procedure h!:LOADLIT7(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, litref(env, 7))); symbolic procedure h!:LOADFREE(pc, code, env); list(2, list('setq, !@b, !@a), list('setq, !@a, freeref(env, byte1()))); symbolic procedure h!:LOADFREE1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, freeref(env, 1))); symbolic procedure h!:LOADFREE2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, freeref(env, 2))); symbolic procedure h!:LOADFREE3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, freeref(env, 3))); symbolic procedure h!:LOADFREE4(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, freeref(env, 4))); symbolic procedure h!:STORELOC(pc, code, env); list(2, list('setq, list(!@stack, byte1()), !@a)); symbolic procedure h!:STORELOC0(pc, code, env); list(1, list('setq, list(!@stack, 0), !@a)); symbolic procedure h!:STORELOC1(pc, code, env); list(1, list('setq, list(!@stack, 1), !@a)); symbolic procedure h!:STORELOC2(pc, code, env); list(1, list('setq, list(!@stack, 2), !@a)); symbolic procedure h!:STORELOC3(pc, code, env); list(1, list('setq, list(!@stack, 3), !@a)); symbolic procedure h!:STORELOC4(pc, code, env); list(1, list('setq, list(!@stack, 4), !@a)); symbolic procedure h!:STORELOC5(pc, code, env); list(1, list('setq, list(!@stack, 5), !@a)); symbolic procedure h!:STORELOC6(pc, code, env); list(1, list('setq, list(!@stack, 6), !@a)); symbolic procedure h!:STORELOC7(pc, code, env); list(1, list('setq, list(!@stack, 7), !@a)); symbolic procedure h!:STOREFREE(pc, code, env); list(2, list('setq, freeref(env, byte1()), !@a)); symbolic procedure h!:STOREFREE1(pc, code, env); list(1, list('setq, freeref(env, 1), !@a)); symbolic procedure h!:STOREFREE2(pc, code, env); list(1, list('setq, freeref(env, 2), !@a)); symbolic procedure h!:STOREFREE3(pc, code, env); list(1, list('setq, freeref(env, 3), !@a)); symbolic procedure h!:LOADLEX(pc, code, env); begin error(1, "loadlex"); % Not yet implemented here return list(3, 'loadlex) end; symbolic procedure h!:STORELEX(pc, code, env); begin error(1, "storelex"); % Not yet implemented here return list(3, 'storelex) end; symbolic procedure h!:CLOSURE(pc, code, env); begin error(1, "closure"); % Not yet implemented here return list(2, 'closure) end; symbolic procedure h!:CARLOC0(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 0)))); symbolic procedure h!:CARLOC1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 1)))); symbolic procedure h!:CARLOC2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 2)))); symbolic procedure h!:CARLOC3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 3)))); symbolic procedure h!:CARLOC4(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 4)))); symbolic procedure h!:CARLOC5(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 5)))); symbolic procedure h!:CARLOC6(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 6)))); symbolic procedure h!:CARLOC7(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 7)))); symbolic procedure h!:CARLOC8(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 8)))); symbolic procedure h!:CARLOC9(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 9)))); symbolic procedure h!:CARLOC10(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 10)))); symbolic procedure h!:CARLOC11(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 11)))); symbolic procedure h!:CDRLOC0(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 0)))); symbolic procedure h!:CDRLOC1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 1)))); symbolic procedure h!:CDRLOC2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 2)))); symbolic procedure h!:CDRLOC3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 3)))); symbolic procedure h!:CDRLOC4(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 4)))); symbolic procedure h!:CDRLOC5(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('cdr, list(!@stack, 5)))); symbolic procedure h!:CAARLOC0(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('caar, list(!@stack, 0)))); symbolic procedure h!:CAARLOC1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('caar, list(!@stack, 1)))); symbolic procedure h!:CAARLOC2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('caar, list(!@stack, 2)))); symbolic procedure h!:CAARLOC3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list('car, list(!@stack, 3)))); symbolic procedure h!:CALL0(pc, code, env); list(2, list('setq, !@b, !@a), list('setq, !@a, list(freeref(env, byte1())))); symbolic procedure h!:CALL1(pc, code, env); list(2, list('setq, !@a, list(freeref(env, byte1()), !@a))); symbolic procedure h!:CALL2(pc, code, env); list(2, list('setq, !@a, list(freeref(env, byte1()), !@b, !@a))); symbolic procedure h!:CALL2R(pc, code, env); list(2, list('setq, !@a, list(freeref(env, byte1()), !@a, !@b))); symbolic procedure h!:CALL3(pc, code, env); list(2, list('setq, !@a, expand_call(3, freeref(env, byte1()))), 'lose); symbolic procedure h!:CALLN(pc, code, env); begin scalar n, w; n := byte1(); for i := 1:n-2 do w := 'lose . w; return list!*(3, list('setq, !@a, expand_call(n, freeref(env, byte2()))), w) end; symbolic procedure h!:CALL0_0(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(freeref(env, 0)))); symbolic procedure h!:CALL0_1(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(freeref(env, 1)))); symbolic procedure h!:CALL0_2(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(freeref(env, 2)))); symbolic procedure h!:CALL0_3(pc, code, env); list(1, list('setq, !@b, !@a), list('setq, !@a, list(freeref(env, 3)))); symbolic procedure h!:CALL1_0(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 0), !@a))); symbolic procedure h!:CALL1_1(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 1), !@a))); symbolic procedure h!:CALL1_2(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 2), !@a))); symbolic procedure h!:CALL1_3(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 3), !@a))); symbolic procedure h!:CALL1_4(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 4), !@a))); symbolic procedure h!:CALL1_5(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 5), !@a))); symbolic procedure h!:CALL2_0(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 0), !@b, !@a))); symbolic procedure h!:CALL2_1(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 1), !@b, !@a))); symbolic procedure h!:CALL2_2(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 2), !@b, !@a))); symbolic procedure h!:CALL2_3(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 3), !@b, !@a))); symbolic procedure h!:CALL2_4(pc, code, env); list(1, list('setq, !@a, list(freeref(env, 4), !@b, !@a))); symbolic procedure h!:BUILTIN0(pc, code, env); begin scalar w; w := getv(builtin0, byte1()); if null w then error(1, "Invalid builtin-function specifier"); return list(2, list('setq, !@a, list w)) end; symbolic procedure h!:BUILTIN1(pc, code, env); begin scalar w; w := getv(builtin1, byte1()); if null w then error(1, "Invalid builtin-function specifier"); return list(2, list('setq, !@a, list(w, !@a))) end; symbolic procedure h!:BUILTIN2(pc, code, env); begin scalar w; w := getv(builtin2, byte1()); if null w then error(1, "Invalid builtin-function specifier"); return list(2, list('setq, !@a, list(w, !@b, !@a))) end; symbolic procedure h!:BUILTIN2R(pc, code, env); begin scalar w; w := getv(builtin2, byte1()); if null w then error(1, "Invalid builtin-function specifier"); return list(2, list('setq, !@a, list(w, !@a, !@b))) end; symbolic procedure h!:BUILTIN3(pc, code, env); begin scalar w; w := getv(builtin3, byte1()); if null w then error(1, "Invalid builtin-function specifier"); return list(2, list('setq, !@a, expand_call(3, w)), 'lose) end; symbolic procedure h!:APPLY1(pc, code, env); list(1, list('setq, !@a, list('apply, !@b, !@a))); symbolic procedure h!:APPLY2(pc, code, env); list(1, list('setq, !@a, list('apply, list(!@stack, 0), !@b, !@a)), 'lose); symbolic procedure h!:APPLY3(pc, code, env); list(1, list('setq, !@a, list('apply, list(!@stack, 0), list(!@stack, 1), !@b, !@a)), 'lose, 'lose); symbolic procedure h!:APPLY4(pc, code, env); list(1, list('setq, !@a, list('apply, list(!@stack, 0), list(!@stack, 1), list(!@stack, 2), !@b, !@a)), 'lose, 'lose, 'lose); symbolic procedure h!:JCALL(pc, code, env); begin scalar nargs, dest; nargs := byte1(); dest := freeref(env, logand(nargs, 31)); nargs := irightshift(nargs, 5); return list(2, expand_jcall(nargs, dest)) end; symbolic procedure h!:JCALLN(pc, code, env); list(3, expand_jcall(byte2(), freeref(env, byte1()))); symbolic procedure expand_jcall(nargs, dest); list('return, expand_call(nargs, dest)); symbolic procedure expand_call(nargs, dest); if nargs = 0 then list dest else if nargs = 1 then list(dest, !@a) else if nargs = 2 then list(dest, !@b, !@a) else begin scalar w; w := list(!@b, !@a); for i := 1:nargs-2 do w := list(!@stack, i) . w; return dest . w end; symbolic procedure h!:JUMP(pc, code, env); list(2, jumpto(pc + byte1() + 1)); symbolic procedure h!:JUMP_B(pc, code, env); list(2, jumpto(pc - byte1() + 1)); symbolic procedure h!:JUMP_L(pc, code, env); list(3, jumpto(pc + twobytes() + 1)); symbolic procedure h!:JUMP_BL(pc, code, env); list(3, jumpto(pc - twobytes() + 1)); symbolic procedure h!:JUMPNIL(pc, code, env); jumpop list('null, !@a); symbolic procedure h!:JUMPNIL_B(pc, code, env); jumpopb list('null, !@a); symbolic procedure h!:JUMPNIL_L(pc, code, env); jumpopl list('null, !@a); symbolic procedure h!:JUMPNIL_BL(pc, code, env); jumpopbl list('null, !@a); symbolic procedure h!:JUMPT(pc, code, env); jumpop !@a; symbolic procedure h!:JUMPT_B(pc, code, env); jumpopb !@a; symbolic procedure h!:JUMPT_L(pc, code, env); jumpopl !@a; symbolic procedure h!:JUMPT_BL(pc, code, env); jumpopbl !@a; symbolic procedure h!:JUMPATOM(pc, code, env); jumpop list('atom, !@a); symbolic procedure h!:JUMPATOM_B(pc, code, env); jumpopb list('atom, !@a); symbolic procedure h!:JUMPATOM_L(pc, code, env); jumpopl list('atom, !@a); symbolic procedure h!:JUMPATOM_BL(pc, code, env); jumpopbl list('atom, !@a); symbolic procedure h!:JUMPNATOM(pc, code, env); jumpop list('not, list('atom, !@a)); symbolic procedure h!:JUMPNATOM_B(pc, code, env); jumpopb list('not, list('atom, !@a)); symbolic procedure h!:JUMPNATOM_L(pc, code, env); jumpopl list('not, list('atom, !@a)); symbolic procedure h!:JUMPNATOM_BL(pc, code, env); jumpopbl list('not, list('atom, !@a)); symbolic procedure h!:JUMPEQ(pc, code, env); jumpop list('eq, !@b, !@a); symbolic procedure h!:JUMPEQ_B(pc, code, env); jumpopb list('eq, !@b, !@a); symbolic procedure h!:JUMPEQ_L(pc, code, env); jumpopl list('eq, !@b, !@a); symbolic procedure h!:JUMPEQ_BL(pc, code, env); jumpopbl list('eq, !@b, !@a); symbolic procedure h!:JUMPNE(pc, code, env); jumpop list('not, list('eq, !@b, !@a)); symbolic procedure h!:JUMPNE_B(pc, code, env); jumpopb list('not, list('eq, !@b, !@a)); symbolic procedure h!:JUMPNE_L(pc, code, env); jumpopl list('not, list('eq, !@b, !@a)); symbolic procedure h!:JUMPNE_BL(pc, code, env); jumpopbl list('not, list('eq, !@b, !@a)); symbolic procedure h!:JUMPEQUAL(pc, code, env); jumpop list('equal, !@b, !@a); symbolic procedure h!:JUMPEQUAL_B(pc, code, env); jumpopb list('equal, !@b, !@a); symbolic procedure h!:JUMPEQUAL_L(pc, code, env); jumpopl list('equal, !@b, !@a); symbolic procedure h!:JUMPEQUAL_BL(pc, code, env); jumpopbl list('equal, !@b, !@a); symbolic procedure h!:JUMPNEQUAL(pc, code, env); jumpop list('not, list('equal, !@b, !@a)); symbolic procedure h!:JUMPNEQUAL_B(pc, code, env); jumpopb list('not, list('equal, !@b, !@a)); symbolic procedure h!:JUMPNEQUAL_L(pc, code, env); jumpopl list('not, list('equal, !@b, !@a)); symbolic procedure h!:JUMPNEQUAL_BL(pc, code, env); jumpopbl list('not, list('equal, !@b, !@a)); symbolic procedure h!:JUMPL0NIL(pc, code, env); jumpop list('null, list(!@stack, 0)); symbolic procedure h!:JUMPL0T(pc, code, env); jumpop list(!@stack, 0); symbolic procedure h!:JUMPL1NIL(pc, code, env); jumpop list('null, list(!@stack, 1)); symbolic procedure h!:JUMPL1T(pc, code, env); jumpop list(!@stack, 1); symbolic procedure h!:JUMPL2NIL(pc, code, env); jumpop list('null, list(!@stack, 2)); symbolic procedure h!:JUMPL2T(pc, code, env); jumpop list(!@stack, 2); symbolic procedure h!:JUMPL3NIL(pc, code, env); jumpop list('null, list(!@stack, 3)); symbolic procedure h!:JUMPL3T(pc, code, env); jumpop list(!@stack, 3); symbolic procedure h!:JUMPL4NIL(pc, code, env); jumpop list('null, list(!@stack, 4)); symbolic procedure h!:JUMPL4T(pc, code, env); jumpop list(!@stack, 4); symbolic procedure h!:JUMPST0NIL(pc, code, env); jumpop list('null, list('setq, list(!@stack, 0), !@a)); symbolic procedure h!:JUMPST0T(pc, code, env); jumpop list('setq, list(!@stack, 0), !@a); symbolic procedure h!:JUMPST1NIL(pc, code, env); jumpop list('null, list('setq, list(!@stack, 1), !@a)); symbolic procedure h!:JUMPST1T(pc, code, env); jumpop list('setq, list(!@stack, 1), !@a); symbolic procedure h!:JUMPST2NIL(pc, code, env); jumpop list('null, list('setq, list(!@stack, 2), !@a)); symbolic procedure h!:JUMPST2T(pc, code, env); jumpop list('setq, list(!@stack, 2), !@a); symbolic procedure h!:JUMPL0ATOM(pc, code, env); jumpop list('atom, list(!@stack, 0)); symbolic procedure h!:JUMPL0NATOM(pc, code, env); jumpop list('not, list('atom, list(!@stack, 0))); symbolic procedure h!:JUMPL1ATOM(pc, code, env); jumpop list('atom, list(!@stack, 1)); symbolic procedure h!:JUMPL1NATOM(pc, code, env); jumpop list('not, list('atom, list(!@stack, 1))); symbolic procedure h!:JUMPL2ATOM(pc, code, env); jumpop list('atom, list(!@stack, 2)); symbolic procedure h!:JUMPL2NATOM(pc, code, env); jumpop list('not, list('atom, list(!@stack, 2))); symbolic procedure h!:JUMPL3ATOM(pc, code, env); jumpop list('atom, list(!@stack, 3)); symbolic procedure h!:JUMPL3NATOM(pc, code, env); jumpop list('not, list('atom, list(!@stack, 3))); symbolic procedure h!:JUMPFREE1NIL(pc, code, env); jumpop list('null, freeref(env, 1)); symbolic procedure h!:JUMPFREE1T(pc, code, env); jumpop freeref(env, 1); symbolic procedure h!:JUMPFREE2NIL(pc, code, env); jumpop list('null, freeref(env, 2)); symbolic procedure h!:JUMPFREE2T(pc, code, env); jumpop freeref(env, 2); symbolic procedure h!:JUMPFREE3NIL(pc, code, env); jumpop list('null, freeref(env, 3)); symbolic procedure h!:JUMPFREE3T(pc, code, env); jumpop freeref(env, 3); symbolic procedure h!:JUMPFREE4NIL(pc, code, env); jumpop list('null, freeref(env, 4)); symbolic procedure h!:JUMPFREE4T(pc, code, env); jumpop freeref(env, 4); symbolic procedure h!:JUMPFREENIL(pc, code, env); list(3, makeif(list('null, freeref(env, byte1())), jumpto(pc + byte2() + 2))); symbolic procedure h!:JUMPFREET(pc, code, env); list(3, makeif(freeref(env, byte1()), jumpto(pc + byte2() + 2))); symbolic procedure h!:JUMPLIT1EQ(pc, code, env); jumpop list('eq, !@a, litref(env, 1)); symbolic procedure h!:JUMPLIT1NE(pc, code, env); jumpop list('not, list('eq, !@a, litref(env, 1))); symbolic procedure h!:JUMPLIT2EQ(pc, code, env); jumpop list('eq, !@a, litref(env, 2)); symbolic procedure h!:JUMPLIT2NE(pc, code, env); jumpop list('not, list('eq, !@a, litref(env, 1))); symbolic procedure h!:JUMPLIT3EQ(pc, code, env); jumpop list('eq, !@a, litref(env, 3)); symbolic procedure h!:JUMPLIT3NE(pc, code, env); jumpop list('not, list('eq, !@a, litref(env, 1))); symbolic procedure h!:JUMPLIT4EQ(pc, code, env); jumpop list('eq, !@a, litref(env, 4)); symbolic procedure h!:JUMPLIT4NE(pc, code, env); jumpop list('not, list('eq, !@a, litref(env, 1))); symbolic procedure h!:JUMPLITEQ(pc, code, env); list(3, makeif(list('eq, !@a, litref(env, byte1())), jumpto(pc + byte2() + 2))); symbolic procedure h!:JUMPLITNE(pc, code, env); list(3, makeif(list('not, list('eq, !@a, litref(env, byte1()))), jumpto(pc + byte2() + 2))); symbolic procedure h!:JUMPB1NIL(pc, code, env); begin scalar w; w := elt(builtin1, byte1()); if null w then error(1, "Bad in JUMPB1NIL"); return list(3, makeif(list('null, list(w, !@a)), jumpto(pc + byte2() + 2))); end; symbolic procedure h!:JUMPB1T(pc, code, env); begin scalar w; w := elt(builtin1, byte1()); if null w then error(1, "Bad in JUMPB1T"); return list(3, makeif(list(w, !@a), jumpto(pc + byte2() + 2))); end; symbolic procedure h!:JUMPB2NIL(pc, code, env); begin scalar w; w := elt(builtin2, byte1()); if null w then error(1, "Bad in JUMPB2NIL"); return list(3, makeif(list('null, list(w, !@b, !@a)), jumpto(pc + byte2() + 2))); end; symbolic procedure h!:JUMPB2T(pc, code, env); begin scalar w; w := elt(builtin2, byte1()); if null w then error(1, "Bad in JUMPB2T"); return list(3, makeif(list(w, !@b, !@a), jumpto(pc + byte2() + 2))); end; symbolic procedure h!:JUMPFLAGP(pc, code, env); jumpop list('flagp, !@b, !@a); symbolic procedure h!:JUMPNFLAGP(pc, code, env); jumpop list('not, list('flagp, !@b, !@a)); symbolic procedure h!:JUMPEQCAR(pc, code, env); list(3, makeif(list('eqcar, !@a, litref(env, byte1())), jumpto(pc + byte2() + 2))); symbolic procedure h!:JUMPNEQCAR(pc, code, env); list(3, makeif(list('not, list('eqcar, !@a, litref(env, byte1()))), jumpto(pc + byte2() + 2))); symbolic procedure h!:CATCH(pc, code, env); jumpop list(!@catch, !@a); symbolic procedure h!:CATCH_B(pc, code, env); jumpopb list(!@catch, !@a); symbolic procedure h!:CATCH_L(pc, code, env); jumpopl list(!@catch, !@a); symbolic procedure h!:CATCH_BL(pc, code, env); jumpopbl list(!@catch, !@a); symbolic procedure h!:UNCATCH(pc, code, env); list(1, 'uncatch, jumpto(pc)); symbolic procedure h!:THROW(pc, code, env); '(1 throw); % There is a jolly feature here. I force in a JUMP just after any % FREEBIND/FREERSTR since that will make later processing easier for me. % Ditto CATCH etc. symbolic procedure h!:PROTECT(pc, code, env); list(1 ,'protect, jumpto(pc)); symbolic procedure h!:UNPROTECT(pc, code, env); list(1, 'unprotect, jumpto(pc)); symbolic procedure h!:PVBIND(pc, code, env); list(1, 'pvbind, jumpto(pc)); symbolic procedure h!:PVRESTORE(pc, code, env); list(1, 'pvrestore, jumpto(pc)); symbolic procedure vector_to_list v; if not vectorp v then error(1, "Error in binding fluid variables") else begin scalar r; for i := 0:upbv v do r := getv(v, i) . r; return reversip r end; symbolic procedure h!:FREEBIND(pc, code, env); list(2, list('freebind, vector_to_list freeref(env, byte1())), jumpto(pc+1)); symbolic procedure h!:FREERSTR(pc, code, env); list(1, '(freerstr !*), jumpto(pc)); symbolic procedure h!:EXIT(pc, code, env); list(1, list('return, !@a)); symbolic procedure h!:NILEXIT(pc, code, env); list(1, list('return, nil)); symbolic procedure h!:LOC0EXIT(pc, code, env); list(1, list('return, list(!@stack, 0))); symbolic procedure h!:LOC1EXIT(pc, code, env); list(1, list('return, list(!@stack, 1))); symbolic procedure h!:LOC2EXIT(pc, code, env); list(1, list('return, list(!@stack, 2))); symbolic procedure h!:PUSH(pc, code, env); list(1, 'push, list('setq, list(!@stack, 0), !@a)); symbolic procedure h!:PUSHNIL(pc, code, env); list(1, 'push, list('setq, list(!@stack, 0), nil)); symbolic procedure h!:PUSHNIL2(pc, code, env); list(1, 'push, list('setq, list(!@stack, 0), nil), 'push, list('setq, list(!@stack, 0), nil)); symbolic procedure h!:PUSHNIL3(pc, code, env); list(1, 'push, list('setq, list(!@stack, 0), nil), 'push, list('setq, list(!@stack, 0), nil), 'push, list('setq, list(!@stack, 0), nil)); symbolic procedure h!:PUSHNILS(pc, code, env); begin scalar n, w; n := byte1(); for i := 1:n do w := 'push . list('setq, list(!@stack, 0), nil) . w; return 2 . w end; symbolic procedure h!:POP(pc, code, env); list(1, list('setq, list('!@stack, 0)), 'lose); symbolic procedure h!:LOSE(pc, code, env); '(1 lose); symbolic procedure h!:LOSE2(pc, code, env); '(1 lose lose); symbolic procedure h!:LOSE3(pc, code, env); '(1 lose lose lose); symbolic procedure h!:LOSES(pc, code, env); begin scalar n, w; n := byte1(); for i := 1:n do w := 'lose . w; return 2 . w end; symbolic procedure h!:SWOP(pc, code, env); list(1, list('setq, !@w, !@a), list('setq, !@a, !@b), list('setq, !@b, !@w)); symbolic procedure h!:EQ(pc, code, env); list(1, list('setq, !@a, list('eq, !@b, !@a))); symbolic procedure h!:EQCAR(pc, code, env); list(1, list('setq, !@a, list('eqcar, !@b, !@a))); symbolic procedure h!:EQUAL(pc, code, env); list(1, list('setq, !@a, list('equal, !@b, !@a))); symbolic procedure h!:NUMBERP(pc, code, env); list(1, list('setq, !@a, list('numberp, !@a))); symbolic procedure h!:CAR(pc, code, env); list(1, list('setq, !@a, list('car, !@a))); symbolic procedure h!:CDR(pc, code, env); list(1, list('setq, !@a, list('cdr, !@a))); symbolic procedure h!:CAAR(pc, code, env); list(1, list('setq, !@a, list('caar, !@a))); symbolic procedure h!:CADR(pc, code, env); list(1, list('setq, !@a, list('cadr, !@a))); symbolic procedure h!:CDAR(pc, code, env); list(1, list('setq, !@a, list('cdar, !@a))); symbolic procedure h!:CDDR(pc, code, env); list(1, list('setq, !@a, list('cddr, !@a))); symbolic procedure h!:CONS(pc, code, env); list(1, list('setq, !@a, list('cons, !@b, !@a))); symbolic procedure h!:NCONS(pc, code, env); list(1, list('setq, !@a, list('ncons, !@a))); symbolic procedure h!:XCONS(pc, code, env); list(1, list('setq, !@a, list('cons, !@a, !@b))); symbolic procedure h!:ACONS(pc, code, env); list(1, list('setq, !@a, list('acons, !@b, !@a, list(!@stack, 0))), 'lose); symbolic procedure h!:LENGTH(pc, code, env); list(1, list('setq, !@a, list('length, !@a))); symbolic procedure h!:LIST2(pc, code, env); list(1, list('setq, !@a, list('list, !@b, !@a))); symbolic procedure h!:LIST2STAR(pc, code, env); list(1, list('setq, !@a, list('list!*, !@b, !@a, list(!@stack, 0))), 'lose); symbolic procedure h!:LIST3(pc, code, env); list(1, list('setq, !@a, list('list, !@b, !@a, list(!@stack, 0))), 'lose); symbolic procedure h!:PLUS2(pc, code, env); list(1, list('setq, !@a, list('plus, !@b, !@a))); symbolic procedure h!:ADD1(pc, code, env); list(1, list('setq, !@a, list('add1, !@a))); symbolic procedure h!:DIFFERENCE(pc, code, env); list(1, list('setq, !@a, list('difference, !@b, !@a))); symbolic procedure h!:SUB1(pc, code, env); list(1, list('setq, !@a, list('sub1, !@a))); symbolic procedure h!:TIMES2(pc, code, env); list(1, list('setq, !@a, list('times, !@b, !@a))); symbolic procedure h!:GREATERP(pc, code, env); list(1, list('setq, !@a, list('greaterp, !@b, !@a))); symbolic procedure h!:LESSP(pc, code, env); list(1, list('setq, !@a, list('lessp, !@b, !@a))); symbolic procedure h!:FLAGP(pc, code, env); list(1, list('setq, !@a, list('flagp, !@b, !@a))); symbolic procedure h!:GET(pc, code, env); list(1, list('setq, !@a, list('get, !@b, !@a))); symbolic procedure h!:LITGET(pc, code, env); list(2, list('setq, !@a, list('get, !@a, litref(env, byte1())))); symbolic procedure h!:GETV(pc, code, env); list(1, list('setq, !@a, list('getv, !@b, !@a))); symbolic procedure h!:QGETV(pc, code, env); list(1, list('setq, !@a, list('qgetv, !@b, !@a))); symbolic procedure h!:QGETVN(pc, code, env); list(2, list('setq, !@a, list('qgetv, !@a, byte1()))); symbolic procedure h!:BIGSTACK(pc, code, env); begin error(1, "bigstack"); % Not yet implemented here return list(3, 'bigstack) end; symbolic procedure h!:BIGCALL(pc, code, env); begin error(1, "bigcall"); % Not yet implemented here return list(3, 'bigcall) end; symbolic procedure h!:ICASE(pc, code, env); begin error(1, "ICASE opcode found"); % Not yet implemented here % This is followed by a whole bunch of addresses for destinations return list(4 + 2*byte1(), 'icase) end; symbolic procedure h!:FASTGET(pc, code, env); begin error(1, "fastget"); % Not yet implemented here return list(2, 'fastget) end; symbolic procedure h!:SPARE1(pc, code, env); error(1, "Invalid (spare) opcode found in byte-stream"); symbolic procedure h!:SPARE2(pc, code, env); error(1, "Invalid (spare) opcode found in byte-stream"); "All helper functions present" >>; % % fix_free_bindings searches for a (FREEBIND) and clips out everything % up as far as all matching FREERSTRs % symbolic procedure find_freebind x; if null x then nil else if eqcar(car x, 'freebind) then x else find_freebind cdr x; symbolic procedure find_freerstr x; if null x then nil else if eqcar(car x, 'freerstr) then x else find_freerstr cdr x; symbolic procedure mark_restores(w, lab); begin scalar b; b := assoc(lab, w); if null b then error(1, "block not found"); if cadr b then return nil; % processed earlier... rplaca(cdr b, t); % Mark this one as already noticed if find_freerstr cddr b then return nil else if find_freebind cddr b then return t; while not atom cdr b do b := cdr b; b := car b; if eqcar(b, 'go) then return mark_restores(w, cadr b) else if eqcar(b, 'if) then << if mark_restores(w, cadr caddr b) then return t else return mark_restores(w, cadr cadddr b) >> else if eqcar(b, 'progexits) then return mark_several_restores(w, cdr b) else return nil end; symbolic procedure mark_several_restores(w, l); if null l then nil else if mark_restores(w, car l) then t else mark_several_restores(w, cdr l); symbolic procedure lift_free_binding(w, fb); % Now all the marked basic blocks form part of a nested chunk, so I % pull that out and re-insert it headed by the word "prog". begin scalar r1, r2, w1; while w do << w1 := cdr w; if cadar w then << rplaca(cdar w, nil); rplacd(w, r1); r1 := w >> else << rplacd(w, r2); r2 := w >>; w := w1 >>; r1 := reversip r1; rplaca(fb, 'prog . cadar fb . r1); rplacd(fb, list ('progexits . free_exits r1)); return reversip r2 end; symbolic procedure free_exits b; begin scalar r, r1; for each i in b do << while not atom cdr i do i := cdr i; i := car i; if eqcar(i, 'go) then r := union(cdr i, r) else if eqcar(i, 'if) then r := union(cdr caddr i, union(cdr cadddr i, r)) else if eqcar(i, 'progexits) then r := union(cdr i, r) >>; for each i in r do if null assoc(i, b) then r1 := i . r1; return r1 end; symbolic procedure fix_free_bindings w; begin scalar changed, aborted, p, fb; changed := t; while changed do << changed := nil; for each z in w do rplaca(cdr z, nil); if aborted then p := cdr p else p := w; aborted := nil; while p and not (fb := find_freebind cddar p) do p := cdr p; if p then << changed := t; % fb = ((freebind (x y z)) (go lab)) if mark_restores(w, cadr cadr fb) then aborted := t else w := lift_free_binding(w, fb) >> >>; return w end; % % The code above here is concerned with generating VALID Lisp code out of % a byte-stream. It can be used as nothing more than a byte-code verifier % if that is what you want. There is one call-out left in it, to a % function called "optimise-blocks", and this is expected to turn the initial % bunch of machine-code-like basic blocks into ones whose contents % look a lot more like reasonable Lisp. % symbolic procedure optimise_blocks(w, args, locals); begin scalar vars, changed, avail; vars := append(args, locals); for each z in w do rplaca(cdr z, 'unknown); rplaca(cdar w, nil); changed := t; while changed do << changed := nil; for each z in w do << avail := cadr z; % prin car z; printc ":"; for each q in cddr z do << % princ "OPT: "; print q; nil >> >> >>; return w end; !*echo := !*plap := t; symbolic procedure simple x; if atom x then x else if null cdr x then car x else simple cdr x; fluid '(x y); symbolic procedure mylast x; if atom x then x else if null cdr x then car x else mylast cdr x; symbolic procedure test a; begin scalar x; x := a+a+a; x := begin scalar y; y := x*x; print list(x, y); return y end; return x/a end; unfluid '(x y); !*plap := nil; unbyte 'simple; unbyte 'mylast; unbyte 'test; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/i86comp.red0000644000175000017500000046556311550002751023556 0ustar giovannigiovanni% "i86comp.red" Copyright 1991-2007, Codemist Ltd % % Compiler that turns Lisp code into Intel 80x86 32-bit assembler in a way % that fits in with the conventions used with CSL/CCL % % It is hoped that parts of this compoiler will form a framework upon % which native compilers for other architectures can be built. Even with % just the Intel one there are three different sets of register and calling % conventions I would like to support (!), viz % Watcom C 11.0 register based calling % Microsoft Visual C++ 5.0 fast calling % Linux/GCC for Intel architectures % This incoherence is amazing and horrid! % % The rules for these configurations appear to be as follows, but % astonishing though it may seem I have found it amazingly difficult to % find these rules documented. Certainly Microsoft explicitly indicate % that the register-usage for their __fastcall linkage may vary between % releases of their C compiler. Explanations of where to place arguments % are tolerably well explained, but the statement of what registers may be % corrupted and which must be preserved is buried somewhere... % % % register (a) (b) (c) % % EAX result arg1/result result % EBX preserved arg3 or preserved preserved % ECX scratch arg4 or preserved arg1 or scratch % EDX scratch arg2 or preserved arg2 or scratch % EBP preserved preserved preserved % ESI preserved preserved preserved % EDI preserved preserved preserved % ESP stack stack stack % % (a) Linux/GCC all functions, Watcom and MSVC __cdecl and va_args cases % (b) Watcom "/r5" register-based calling % (c) MSVC __fastcall % % % M A Dmitriev % A C Norman global '(i_machine); i_machine := cdr assoc('native, lispsystem!*); % i_machine = 2 Watcom 11.0 % = 3 MS VC++ 5.0 % = 4 Linux % otherwise something not supported here. if not (i_machine=2 or i_machine=3 or i_machine=4) then error(0, "Unsupported architecture for this compiler"); % % Assembler for use when generating native code within CSL/CCL. The % overall structure of this code is intende to be fairly independent of % the actual machine architecture supported, and there will be call-backs % into particular code-generators when system sensitive operations have % to be performed. % % % This low-level assembler is activated using a procedural interface. % To create some native code the correct sequence to use is: % i_startproc(); set things going % for each basic block do % i_putlabel lab; % for each instruction in the block do % i_putcomment '(disassembly of the instrn); % mixture of % i_putbyte 8-bits % i_put32 32-bits Intel byte-order % i_extern 32-bit ref to external symbol % i_putjump(data, lab) variable length jump instruction % i_resolve(); resolve labels % % There is a put32r to insert bytes in Sun rather than Intel byte order, % and put16, put16r calls for 16-bit values. % % To go with this assembler there must be machine-specific procedures % to decode the jump stuff: % i_jumpsize(pc, target, data) % i_jumpbytes(pc, target, data) % where i_jumpsize MUST return a list whose length is the same as % the value of i_jumpsize. The data handed down is whatever was passed to % i_putjump, and it can be as complicated a structure as the architecture % needs. % % put_extern takes an argument that one of the following, the meaning of % which are explained later: % (absolute xxx) % (relative xxx) % (rel_plus_4 xxx) % (rel_minus_2 xxx) % (rel_minus_4 xxx) % (rel_offset xxx n) % % where xxx can be one of the following possibilities: % a negative integer -(n+1) n is used to look up in a useful_functions % table (in file fns3.c of the CSL sources) % a positive integer n address_of_variable (from fns3.c) will be % called with n as an argument % (n 0) entry n from zero_arg_functions (eval4.c) % (n 1) entry n from one_arg_functions % (n 2) entry n from two_arg_functions % (n 3) entry n from three_arg_functions % and the code in restart.c will need to agree with the layout created % here for relocation modes that link to these entities. % % All the addressing modes (at present) generate a 32 bit reference. The % simplest one is ABSOLUTE which just puts the address of the target % in the 32 bit location. The other modes all insert an adddress of the % target relative to the current location. The complication is that some % computers want this to be relative to the start of the 32-bit address, % some relative to the start of the instruction containing that address and % some use the start of the NEXT instruction as the base. I use plain % RELATIVE for relocation from the start address of the value being % stored. REL_PLUS_4 is relative to the word after this (ie +4). REL_MINUS_2 % and REL_MINUS_4 are expected to be useful if you need to be relative to the % start of an instruction which has 2 or 4 bytes before the 32-bit offset. % Finally REL_OFFSET is a catch-all that puts an extra signed byte in the % relocation table to show the offset from the effect of just RELATIVE. % In general I expect any particular computer to use just one of these, % for instance Intel use REL_PLUS_4, but the others are there to make it % easy to implement many different compiler back-ends. I have room in the % encoding to add several more modes if and when necessary! % % % Of course for any particular computer architecture I will have a % higher level assembler that accepts input in a fairly symbolic form % and converts it into the bit-patterns required here. % % A procedure is accumulated as a sequence of blocks. Each of these % has an associated label, which will be a gensym if no user label was % provided. Jump instructions only occur at the end of one of these % blocks. When a block is complete it sits in the list of blocks in % the form % (label location size b b ... b<0>) % where size is the size in bytes represented by the sequence of bytes % b, except that the size of any final JUMP is not included. The % items in the list may be % an integer just that byte % (JUMP shortform longform label) short/long are lists of bytes % (EXTERN something) 4 bytes external reference % (COMMENT c1 c2 ...) to display in listing % fluid '(i_procedure i_block i_blocksize i_label i_pc i_externs); global '(!*genlisting); !*genlisting := nil; switch genlisting; % For the benefit of RLISP/Reduce users symbolic procedure i_startproc(); << i_label := list nil; i_procedure := nil; i_externs := nil; i_block := nil; i_blocksize := 0; i_pc := 0; nil >>; symbolic procedure i_putlabel l; begin % car i_label can be nil at the start of a procedure or just after a jump % has been issued. If a label is set in such a case and any instructions % have been set in the dummy block then I invent a gensym-label for it, % but if a real label gets set soon enough I can avoid introducing any % sort of dummy mess. if car i_label = nil then << if i_block = nil then << rplaca(i_label, l); return >> else rplaca(i_label, gensym()) >>; % rplacd(i_label, i_pc . i_blocksize . i_block); i_procedure := i_label . i_procedure; put(car i_label, 'i_label, i_label); % When I first create a procedure I suppose (optimistically) that all % jumps can be rendered in short form. i_pc := i_pc + i_blocksize; if i_block and eqcar(car i_block, 'jump) then i_pc := i_pc + length cadar i_block + 1; i_label := list l; i_block := nil; i_blocksize := 0; nil end; % The user MUST put a comment just before each instruction if % disassembly is to behave properly. However if the assembly code % is not going to be displayed I can avoid storing the extra rubbish. symbolic procedure i_putcomment n; << if !*genlisting then i_block := ('comment . n) . i_block; nil >>; symbolic procedure i_putbyte n; << i_block := n . i_block; i_blocksize := i_blocksize + 1; nil >>; symbolic procedure i_put32 n; << i_putbyte logand(n, 0xff); n := logand(n, 0xffffffff) / 0x100; i_putbyte logand(n, 0xff); n := irightshift(n, 8); i_putbyte logand(n, 0xff); n := irightshift(n, 8); i_putbyte logand(n, 0xff); nil >>; % Codegenerators will need to use whether i_put32 or i_put32r % depending on the byte ordering used by the architecture that they support. symbolic procedure i_put32r n; << n := logand(n, 0xffffffff); i_putbyte logand(n / 0x01000000, 0xff); i_putbyte logand(n / 0x00010000, 0xff); i_putbyte logand(n / 0x00000100, 0xff); i_putbyte logand(n, 0xff); nil >>; % % i_put16 and i_put16r dump 16 bit values. % symbolic procedure i_put16 n; << i_putbyte logand(n, 0xff); n := irightshift(ilogand(n, 0xffff), 8); i_putbyte logand(n, 0xff); nil >>; symbolic procedure i_put16r n; << n := logand(n, 0xffff); i_putbyte irightshift(n, 8); i_putbyte logand(n, 0xff); nil >>; % In order to be able to optimise short jumps I will arrange to start a % fresh basic block after every jump instruction. I also store two % possible byte sequences for use in the final code, one for when the % target address is close by and the other for when it is further away. % symbolic procedure i_putjump(data, lab); << i_block := list('jump, data, lab) . i_block; if car i_label = nil then rplaca(i_label, gensym()); rplacd(i_label, i_pc . i_blocksize . i_block); i_procedure := i_label . i_procedure; put(car i_label, 'i_label, i_label); % When a jump is first issued I will assemble it as a jump-to-self % which I expect to use the shortest form of jump available. Later on % and only if necessary I will expand it to a longer variant of the % instruction. i_pc := i_pc + i_blocksize + i_jumpsize(i_pc, i_pc, data); i_label := list nil; % leave in pending state i_block := nil; i_blocksize := 0; flag(list lab, 'i_used); % To get it displayed in listing nil >>; % References to "external" symbols will be used to call functions in the % Lisp kernel and to reference key variables there. At present I assume that % all such references will require a 32-bit field. This will get filled in by % load-time relocation code. symbolic procedure i_putextern a; << i_block := list('extern, a) . i_block; i_externs := list(i_label, i_blocksize, a) . i_externs; i_blocksize := i_blocksize + 4; nil >>; % prinhexb displays a hex number and then a blank, but only % if !*genlisting is true. symbolic procedure prinhexb(n, w); if !*genlisting then << prinhex(n, w); princ " " >>; % i_resolve() iterates over the code re-calculating the length of % each basic block and hence deducing how long each jump instruction % has to be. When it has done that it scans the code to make a map % showing what external symbols will need relocating, and it builds % the relevant tables. Finally it allocates space for the assembled % code and puts the bytes where they need to be, optionally printing % a nice neat version for the user to admire. symbolic procedure i_resolve(); begin scalar changed, pc, hardcode_handle, c, c1, c2, c3, gap, oll; oll := linelength 80; i_putlabel nil; % Flushes last block into data structures % The blocks had been collected in reverse order since that is how Lisp % finds it easiest to build up lists. i_procedure := reversip i_procedure; % Iterate until position of all blocks stabilises. In the very worst case % this could take a number of passes proportional to the length of the % code being assembled, but I do not expect that to happen often enough % to worry about it. repeat << changed := nil; pc := 0; for each b in i_procedure do begin scalar loc, len, j; loc := cadr b; % estimated location len := caddr b; % length of block (excluding jump) j := cdddr b; if j then j := car j; if eqcar(j, 'jump) then j := cdr j else j := nil; if loc neq pc then << changed := t; % will need to go around again. rplaca(cdr b, pc) >>; pc := pc + len; % The next bit evaluates the size of a jump instruction. if j then begin scalar target, offset; target := cadr get(cadr j, 'i_label); pc := pc + i_jumpsize(pc, target, car j) end end >> until not changed; % When I get to here pc shows the total size of the compiled code, and % all labels have been resolved with jumps able to be in their shortest % valid forms. The next thing to do is to sort out external references. i_pc := pc; i_externs := reversip i_externs; for each r in i_externs do rplaca(r, cadar r); c := i_externs; pc := 0; i_externs := nil; while c do begin scalar data, address, offset, addressmode, target, op; c1 := car c; data := caddr c1; % The "data" passed to i_putextern address := car c1 + cadr c1; % word to relocate offset := address - pc; % distance from previous relocation pc := address; % store loc to calculate next offset addressmode := car data; % data = {addressmode,target} target := cadr data; % The variable op will accumulate the first byte of the relocation information % which packs an address mode and a target catagory into 169 possibilities % as 13*13. op := 13*get(addressmode, 'i_addressmode); % The target is coded in a slighly (!) ugly way here. I decode it and % merge part of the information into the opcode byte, leaving the variable % "target" holding an 8-bit specification of just what to address. if numberp target then << if target < 0 then << op := op + 4; % RELOC_DIRECT_ENTRY target := -(target+1) >> else op := op + 5 >> % RELOC_VAR else << op := op + cadr target; % RELOC_0_ARGS to RELOC_3_ARGS target := car target >>; % Now things are a bit messy. If the next relocation is close to the % current one (which it almost always will be) I use a single byte offset % to indicate where it is. if offset < 256 then % can use one-byte offset i_externs := offset . (op+1) . i_externs % If the next relocation is 256 or more bytes away I have to use an extended % form of relocation record. This spreads the opcode across two bytes and % that give space for 15 bits of genuine offset. If the gap was over % 0x7fff then even this is not enough, and in that case I use multiple % instances of the biggest offset I do support and do null relocations % at the intermediate places. else << while offset > 0x7fff do << % The sequence 0xff 0xff 0xff will be treated as NOP with offset 0x7fff % and thus provides for arbitrary expansion of the range of offsets. i_externs := 0xff . 0xff . 0xff . i_externs; offset := offset - 0x7fff >>; % NB (obviously?) the coding use here must agree with the corresponding % stuff in source file "restart.c" that unpicks stuff. i_externs := logand(offset, 0xff) . (171 + op/2) . i_externs; i_externs := (128*remainder(op, 2) + (offset/256)) . i_externs >>; i_externs := target . i_externs; % Here when I support RELOC_SELF_2 I will need to insert a target extension % byte into the code-stream here. % % Add an extra byte if the relocation needed patching with a further offset, % if we had address mode REL_OFFSET. if eqcar(gap, 'rel_offset) then i_externs := logand(caddr data, 0xff) . i_externs; % I put a "comment" into the list so that I can display a nice % or at least fairly symbolic indication of the relocation information % when the user has !*genlisting switched on. i_externs := list(pc, data) . i_externs; c := cdr c end; i_externs := '(termination) . 0 . i_externs; % Terminate the list % The first 4 bytes of some BPS give its length, and then the % next 4 bytes give the offset of the start of the actual code in it. % thuse there are 8 bytes of stuff to allow for. gap := 8; for each r in i_externs do if numberp r then gap := gap+1; % I will ensure that the compiled code itself starts at a word boundary. I % could make it start at a doubleword boundary easily enough if that made % a real difference to performance. c := logand(gap, 3); if c neq 0 then << while c neq 4 do << i_externs := 0 . i_externs; c := c + 1; gap := gap + 1 >>; % Word align i_externs := '(alignment) . i_externs >>; i_externs := reversip i_externs; % Back in the tidy order; % Insert the data that gives the offset to the start of real compiled code i_externs := list('start, compress ('!! . '!0 . '!x . explodehex gap)) . i_externs; i_externs := logand(gap / 0x01000000, 0xff) . i_externs; i_externs := logand(gap / 0x00010000, 0xff) . i_externs; i_externs := logand(gap / 0x00000100, 0xff) . i_externs; i_externs := logand(gap, 0xff) . i_externs; % Create space for the assembled code. i_pc := i_pc + gap; hardcode_handle := make!-native(i_pc); pc := 4; while i_externs do << prinhexb(pc, 4); if !*genlisting then princ ": "; while i_externs and numberp car i_externs do << prinhexb(car i_externs, 2); native!-putv(hardcode_handle, pc, car i_externs); pc := pc + 1; i_externs := cdr i_externs >>; if not atom i_externs then << if !*genlisting then << ttab 35; if numberp caar i_externs then << princ "@"; prinhex(gap+caar i_externs, 4); princ ": " >> else << princ caar i_externs; princ " " >>; if cdar i_externs then printc cadar i_externs else terpri() >>; i_externs := cdr i_externs >> >>; if !*genlisting then terpri(); % between relocation table & code pc := gap; for each b in i_procedure do << % I display labels unless they are never referenced. if !*genlisting and flagp(car b, 'i_used) then << ttab 30; prin car b; printc ":" >>; % The instructions within a basic block had been accumulated in a list % that is reversed, so put it right here. c := reverse cdddr b; % Code list % I expect the first item in the list to be a comment, but if it is not % I will annotate things with a "?" rather than crashing. if c and eqcar(car c, 'comment) then << c1 := cdar c; c := cdr c >> else c1 := '(!?); while c do << prinhexb(pc, 4); princ ": "; % Address to put things at. % Since I really wanted comments before each instruction I will scan % forwrad until I either find the next comment or I hit the end of the list. while c and not eqcar(c2 := car c, 'comment) do << if numberp c2 then << prinhexb(c2, 2); native!-putv(hardcode_handle, pc, c2); pc := pc + 1 >> else if eqcar(c2, 'extern) then << if !*genlisting then princ "xx xx xx xx "; native!-putv(hardcode_handle, pc, 0); pc := pc + 1; native!-putv(hardcode_handle, pc, 0); pc := pc + 1; native!-putv(hardcode_handle, pc, 0); pc := pc + 1; native!-putv(hardcode_handle, pc, 0); pc := pc + 1 >> else if eqcar(c2, 'jump) then << for each j in i_jumpbytes(pc-gap, cadr get(caddr c2, 'i_label), cadr c2) do << prinhexb(j, 2); native!-putv(hardcode_handle, pc, j); pc := pc + 1 >> >>; c := cdr c >>; if !*genlisting then << % Now display the comment ttab 34; for each w in c1 do << if w = '!; then ttab 55 else princ " "; princ w >>; terpri() >>; if c and eqcar(c2, 'comment) then << c1 := cdr c2; c := cdr c >> >> >>; % At the end of dealing with a procedure I will clean up the property lists % of all the symbols that were used as labels in it. for each b in i_procedure do << remflag(list car b, 'i_used); remprop(car b, 'i_label) >>; linelength oll; return (hardcode_handle . gap) end; put('absolute, 'i_addressmode, 0); % Absolute address of target put('relative, 'i_addressmode, 1); % relative to start of reference put('rel_plus_4, 'i_addressmode, 2); % relative to end of reference put('rel_minus_2, 'i_addressmode, 3);% relative to 2 before item put('rel_minus_4, 'i_addressmode, 4);% relative to 4 before item put('rel_offset, 'i_addressmode, 5); % generic offset relative address %============================================================================ % Now some Intel versions of jump support. This supposes that the "jump data" % passed down to i_putjump was just the one-byte opcode for the short % form of a relative jump. symbolic procedure i_jumpsize(pc, target, data); begin scalar offset; offset := target - (pc + 2); % Suppose short here if offset >= -128 and offset <= 127 then return 2 % short jump else if data = 0xeb then return 5 % unconditional else return 6 % conditional end; symbolic procedure i_jumpbytes(pc, target, data); begin scalar r, offset; offset := target - (pc + 2); % Suppose short for the moment if offset >= -128 and offset <= 127 then return list(data, logand(offset, 0xff)); % An unconditional jump grows by 3 bytes while a conditional one % needs an extra 4. And on this architecture the offset is taken from the % end of the jump instruction, and so I need to adjust it a bit here. if data = 0xeb then << % 0xeb = short unconditional jump offset := offset - 3; r := list 0xe9 >> % 0xe9 = long unconditional jump else << offset := offset - 4; r := list(data+0x10, 0x0f) >>; % +0x10 turns short to long jump offset := logand(offset, 0xffffffff); r := logand(offset, 0xff) . r; offset := offset / 0x100; r := ilogand(offset, 0xff) . r; offset := irightshift(offset, 8); r := ilogand(offset, 0xff) . r; offset := irightshift(offset, 8); r := ilogand(offset, 0xff) . r; return reversip r end; % % Next the code that transforms symbolically represented i80x86 instructions % into native machine code. % % The main macro of the code generator. Generates opcodes for a sequence of % i80x86 instructions represented in symbolic form. A macro is used just to % make the calling form perhaps more natural. The sequence supplied to this % macro looks as a list of parameters of arbitary length, not as a Lisp list % (into which the macro transforms this sequence). Things that are names % of Intel opcodes or registers do not need to be quoted... I detect them % and insert a quote during macro expansion. symbolic macro procedure i!:gopcode u; list('i!:genopcode, 'list . for each v in cdr u collect if atom v then (if get(v, 'i!:regcode) or get(v, 'i!:nargs) then mkquote v else v) else if eqcar(v, 'list) then for each v1 in v collect (if atom v1 and get(v1, 'i!:regcode) then mkquote v1 else v1) else v); % Now the procedure which actually gets called. It looks for items that % are flagged as being opcodes, and for each such it knows how many % operands to expect. It can then call lower level routines to collect and % process those operands. Some amount of peephole optimisation is done on % the way, which is probably not where I want it to be done, but it can % remain here until I have re-worked the higher level compiler. symbolic procedure i!:genopcode u; begin scalar c, nargs; while u do << c := car u; nargs := get(c, 'i!:nargs); if nargs then << % It is an opcode... u := cdr u; if nargs = 2 then << i!:2arginstr(c, car u, cadr u); u := cddr u >> else if nargs = 1 then << i!:1arginstr(c, car u); u := cdr u >> else i!:noarginstr c >> else if c = '!: then << % label i!:proc_label cadr u; u := cddr u >> else u := cdr u >> % Ignore anything that is not understood! end; << % Codes of the processor registers put('eax, 'i!:regcode, 0); put('ecx, 'i!:regcode, 1); put('edx, 'i!:regcode, 2); put('ebx, 'i!:regcode, 3); put('esp, 'i!:regcode, 4); put('ebp, 'i!:regcode, 5); put('esi, 'i!:regcode, 6); put('edi, 'i!:regcode, 7); % ds and ebp have the same code, but instructions which contain memory % references of the form {ds,...} have a special prefix. However, this % code generator will produce wrong output for "mov ds,const" instruction. % But I can't imagine what it can be needed for and I am not sure it is % legal in the user mode. put('ds, 'i!:regcode, 5); % Irregular table of instructions opcodes. Values associated with the % properties are either main or secondary opcodes for different formats % of the instructions. put('add, 'i!:nargs, 2); put('add, 'i!:rm!-reg, 0x01); put('add, 'i!:immed!-rm, 0x81); put('add, 'i!:immed!-rm!-secopcode, 0); put('add, 'i!:immed!-eax, 0x05); put('and, 'i!:nargs, 2); put('and, 'i!:rm!-reg, 0x21); put('and, 'i!:immed!-rm, 0x81); put('and, 'i!:immed!-rm!-secopcode, 4); put('and, 'i!:immed!-eax, 0x25); put('call, 'i!:nargs, 1); put('call, 'i!:reg, 0xff); put('call, 'i!:reg!-secopcode, 0xd0); put('call, 'i!:jump, 0xe8); put('cmp, 'i!:nargs, 2); put('cmp, 'i!:rm!-reg, 0x39); put('cmp, 'i!:immed!-rm, 0x81); put('cmp, 'i!:immed!-rm!-secopcode, 7); put('cmp, 'i!:immed!-eax, 0x3d); put('dec, 'i!:nargs, 1); put('dec, 'i!:reg, 0x48); put('mul, 'i!:nargs, 2); put('mul, 'i!:rm!-reg!-prefix, 0x0f); put('mul, 'i!:rm!-reg, 0xaf); put('mul, 'i!:rm!-reg!-dbit_preset, 1); put('mul, 'i!:immed!-rm, 0x69); put('inc, 'i!:nargs, 1); put('inc, 'i!:reg, 0x40); put('je, 'i!:nargs, 1); put('je, 'i!:jump, 0x74); put('jne, 'i!:nargs, 1); put('jne, 'i!:jump, 0x75); put('jg, 'i!:nargs, 1); put('jg, 'i!:jump, 0x7f); put('jge, 'i!:nargs, 1); put('jge, 'i!:jump, 0x7d); put('jl, 'i!:nargs, 1); put('jl, 'i!:jump, 0x7c); put('jle, 'i!:nargs, 1); put('jle, 'i!:jump, 0x7e); put('ja, 'i!:nargs, 1); put('ja, 'i!:jump, 0x77); put('jae, 'i!:nargs, 1); put('jae, 'i!:jump, 0x73); put('jb, 'i!:nargs, 1); put('jb, 'i!:jump, 0x72); put('jbe, 'i!:nargs, 1); put('jbe, 'i!:jump, 0x76); put('jmp, 'i!:nargs, 1); put('jmp, 'i!:jump, 0xeb); put('mov, 'i!:nargs, 2); put('mov, 'i!:rm!-reg, 0x89); put('mov, 'i!:immed!-rm, 0xc7); put('mov, 'i!:immed!-rm!-secopcode, 0); flag('(mov), 'i!:immed!-rm!-noshortform); put('mov, 'i!:immed!-reg, 0xb8); put('neg, 'i!:nargs, 1); put('neg, 'i!:rm, 0xf5); put('neg, 'i!:rm!-secopcode, 3); put('or, 'i!:nargs, 2); put('or, 'i!:rm!-reg, 0x09); put('or, 'i!:immed!-rm, 0x81); put('or, 'i!:immed!-rm!-secopcode, 1); put('or, 'i!:immed!-eax, 0x0d); put('pop, 'i!:nargs, 1); put('pop, 'i!:reg, 0x58); put('pop, 'i!:mem, 0x8f); put('pop, 'i!:mem!-secopcode, 0x00); put('push, 'i!:nargs, 1); put('push, 'i!:reg, 0x50); put('push, 'i!:mem, 0xff); put('push, 'i!:mem!-secopcode, 0x06); put('push, 'i!:immed8, 0x6a); put('push, 'i!:immed32, 0x68); put('ret, 'i!:nargs, 0); put('ret, 'i!:code, 0xc3); put('shl, 'i!:nargs, 2); put('shl, 'i!:immed!-rm, 0xc1); put('shl, 'i!:immed!-rm!-secopcode, 4); flag('(shl), 'i!:immed!-rm!-shortformonly); put('shr, 'i!:nargs, 2); put('shr, 'i!:immed!-rm, 0xc1); put('shr, 'i!:immed!-rm!-secopcode, 5); flag('(shr), 'i!:immed!-rm!-shortformonly); put('sub, 'i!:nargs, 2); put('sub, 'i!:rm!-reg, 0x29); put('sub, 'i!:immed!-rm, 0x81); put('sub, 'i!:immed!-rm!-secopcode, 5); put('sub, 'i!:immed!-eax, 0x2d); put('test, 'i!:nargs, 2); put('test, 'i!:rm!-reg, 0x85); put('test, 'i!:rm!-reg!-dbit_preset, 0); put('test, 'i!:immed!-rm, 0xf7); put('test, 'i!:immed!-rm!-secopcode, 0); flag('(test), 'i!:immed!-rm!-noshortform); put('test, 'i!:immed!-eax, 0xa9); put('xor, 'i!:nargs, 2); put('xor, 'i!:rm!-reg, 0x31); put('xor, 'i!:immed!-rm, 0x81); put('xor, 'i!:immed!-rm!-secopcode, 6); put('xor, 'i!:immed!-eax, 0x35); % These instructions necessarily change registers when they are executed. % Hence we should keep track of them to get peephole optimisation right. flag('(add and dec mul inc neg or shl shr sub xor), 'i!:changes_reg) >>; fluid '(i!:reg_vec); % Addresses of some internal CSL variables and functions. % This table is needed by code compiled from Lisp which necessarily uses % Lisp run-time library and internal variables % Of course a worry here is that these addresses potentially change each % time Lisp is re-loaded into memory, and so I need to be a little % careful about their treatment. global '(OFS_NIL OFS_STACK OFS_LISP_TRUE OFS_CURRENT_MODULUS OFS_STACKLIMIT); << OFS_NIL := 0; % Arg to give to native!-address OFS_STACK := 1; OFS_LISP_TRUE := 98; OFS_CURRENT_MODULUS := 29; !#if common!-lisp!-mode OFS_STACKLIMIT := 16; !#else OFS_STACKLIMIT := 15; !#endif % What follows will allow me to patch up direct calls to Lisp kernel % functions. The (negative) integers are codes to pass to native!-address % at the Lisp level and are then slightly adjusted to go in the relocation % tables that are generated here. put('cons, 'c!:direct_call_func, -1); put('ncons, 'c!:direct_call_func, -2); put('list2, 'c!:direct_call_func, -3); put('list2!*, 'c!:direct_call_func, -4); put('acons, 'c!:direct_call_func, -5); put('list3, 'c!:direct_call_func, -6); put('plus2, 'c!:direct_call_func, -7); put('difference, 'c!:direct_call_func, -8); put('add1, 'c!:direct_call_func, -9); put('sub1, 'c!:direct_call_func, -10); put('get, 'c!:direct_call_func, -11); put('lognot, 'c!:direct_call_func, -12); put('ash, 'c!:direct_call_func, -13); put('quotient, 'c!:direct_call_func, -14); put('remainder, 'c!:direct_call_func, -15); put('times2, 'c!:direct_call_func, -16); put('minus, 'c!:direct_call_func, -17); put('rational, 'c!:direct_call_func, -18); put('lessp, 'c!:direct_call_func, -19); put('leq, 'c!:direct_call_func, -20); put('greaterp, 'c!:direct_call_func, -21); put('geq, 'c!:direct_call_func, -22); put('zerop, 'c!:direct_call_func, -23); put('reclaim, 'c!:direct_call_func, -24); put('error, 'c!:direct_call_func, -25); put('equal_fn, 'c!:direct_call_func, -26); put('cl_equal_fn, 'c!:direct_call_func, -27); put('aerror, 'c!:direct_call_func, -28); put('integerp, 'c!:direct_call_func, -29); put('apply, 'c!:direct_call_func, -30); >>; fluid '(off_env off_nargs); off_nargs := 12; % off_env is set dynamically in cg_fndef symbolic procedure i!:translate_memref(a); % Check if an atomic symbol is a variable of the program being compiled, and % if so, return its assembler representation (memory address in a suitable % form). The first line implements the general mechanism of translating % references for local variables kept in stack. For such a symbolic variable % the 'i!:locoffs property should contain its offset in stack. The rest deals % with the translation of symbolic representations of CSL internal variables. % % ACN dislikes the use of the STRING "nil" here. Also resolution of the % addresses of C_nil, stack etc should be deferred to load time. But leave % it as it is for now since it works! % if (get(a, 'i!:locoffs)) then {'ebp, get(a, 'i!:locoffs)} else if a = "nil" then {'ebp,-4} else if a = 'env or a = '!.env then {'ebp,off_env} else if a = 'C_nil then {'ds,OFS_NIL} else if a = 'stack then {'ds,OFS_STACK} else if a = 'lisp_true then {'ds,OFS_LISP_TRUE} else if a = 'current_modulus then {'ds,OFS_CURRENT_MODULUS} else if a = 'stacklimit then {'ds,OFS_STACKLIMIT} else if flagp(a, 'c!:live_across_call) then {'ebx,-get(a, 'c!:location)*4} else a; % Otherwise we hope that this is a symbolic label - a call % or jump operand. symbolic procedure i!:outmemfield(reg, mem); % Generate the second and further bytes of the instruction whose operand is % memory. For 2-arg instructions reg means code of the register operand, % for 1-arg instructions it is a secondary opcode % Examples of the forms of memory references accepted are given below: % {ds,1234}, {ebx,-16}, {eax,2,ebx}, {ecx,4,edx,32} begin scalar secbyte, thirdbyte, constofs, constofslong, reg1name, reg1, reg2, mul; reg1name := car mem; reg1 := get(reg1name, 'i!:regcode); if length mem = 1 or ((length mem = 2) and numberp cadr mem) then << % [reg1] or [reg1 + ofs] secbyte := reg*8 + reg1; mem := cdr mem; % Curious peculiarities of constant offset length field behaviour % when ebp (or ds) is an operand force me to do this weird thing. if (not mem) and (reg1name = 'ebp) then mem := cons(0, nil); if mem then << constofs := car mem; if (constofs > 127) or (constofs < -128) or (reg1name = 'ds) then << if reg1name neq 'ds then secbyte := secbyte + 0x80; constofslong := t >> else << secbyte := secbyte + 0x40; constofslong := nil >> >>; i_putbyte secbyte >> else << % [reg + reg] or [reg + const*reg] or [reg + const*reg + ofs] secbyte := 0x04 + reg*8; % 0x04 is a magic number, imho thirdbyte := reg1; mem := cdr mem; if numberp car mem then << mul := car mem; if mul = 8 then thirdbyte := thirdbyte + 0xc0 else if mul = 4 then thirdbyte := thirdbyte + 0x80 else if mul = 2 then thirdbyte := thirdbyte + 0x40; mem := cdr mem >>; reg2 := get(car mem, 'i!:regcode); thirdbyte := thirdbyte + reg2*8; mem := cdr mem; if (not mem) and (reg1name = 'ebp) then mem := 0 . nil; if mem then << constofs := car mem; if (constofs > 127) or (constofs < -128) then << % Weird thing with ebp again - only for it in this case we should % put 00 in two bits representing the offset length if reg1name neq 'ebp then secbyte := secbyte + 0x80; constofslong := t >> else << secbyte := secbyte + 0x40; constofslong := nil >> >> else constofs := nil; i_putbyte secbyte; i_putbyte thirdbyte >>; if constofs then if constofslong then << if reg1name='ds then i_putextern list('absolute, constofs) else i_put32 constofs >> else i_putbyte ilogand(constofs, 0xff) end; symbolic procedure i!:remove_reg_memrefs(reg); % A part of peephole optimisation. We maintain the table which has an entry % per register. An entry for register reg contains registers and memory % references whose contents are equal to reg. When reg is changed, we % must flush its entry. This is already done when this procedure called. % But what we should also do (here) is to check if the buffer for any % register other than reg contains reg or a memory reference which includes % reg, such as {reg,1000}, and remove all such references. begin scalar regi, regi1, memref; for i := 0:2 do << regi := getv(i!:reg_vec, i); regi1 := nil; while regi neq nil do << memref := car regi; regi := cdr regi; if (atom memref) and (memref neq reg) then regi1 := memref . regi1 else if not member(reg, memref) then regi1 := memref . regi1; >>; putv(i!:reg_vec, i, regi1) >> end; symbolic procedure i!:eq_to_reg(mem); % Check if a memory variable is equal to some register at the current moment begin scalar i,res; res := nil; for i := 0:2 do if member(mem, getv(i!:reg_vec, i)) then res := i; return res; end; symbolic procedure i!:regname(code); % Return register symbolic name for its code if code = 0 then 'eax else if code = 1 then 'ecx else if code = 2 then 'edx else error1 "bad regname"; symbolic procedure encomment(reg1, a1); if reg1 then list a1 else begin scalar x; x := i!:translate_memref a1; if a1 = x then return list a1 else return list(x, '!;, list a1) end; symbolic procedure i!:2arginstr(instr, a1, a2); % Process an instruction with two arguments begin scalar reg1, reg2, isnuma2, longnuma2, code, secopcode, tmp, dbit, pref, c1, c2; reg1 := get(a1, 'i!:regcode); reg2 := get(a2, 'i!:regcode); isnuma2 := numberp a2; if isnuma2 then longnuma2 := not zerop irightshift(a2,8); % Peephole optimisation - replace "instr d,mem" with % "instr d,reg" if reg = mem if (not reg2) and (not isnuma2) then << reg2 := i!:eq_to_reg(a2); if reg2 and not ((instr = 'mov) and (reg1 = reg2)) then a2 := i!:regname(reg2) else reg2 := nil; >>; % Peephole optimisation - redundant memory-register transfers suppression if (reg1) and (reg1 <= 2) then << if flagp(instr, 'i!:changes_reg) then << putv(i!:reg_vec, reg1, nil); i!:remove_reg_memrefs(a1); >> else if (instr = 'mov) then << % mov reg1, a2(which is mem or reg) if member(a2, getv(i!:reg_vec, reg1)) then % Suppress MOV return nil else << i!:remove_reg_memrefs(a1); if not reg2 then << % a2 is a memory location if (not atom a2) and (member(a1,a2)) then putv(i!:reg_vec, reg1, nil) else putv(i!:reg_vec, reg1, a2 . nil) >> else << % a2 is a register putv(i!:reg_vec, reg1, a2 . getv(i!:reg_vec, reg2)); putv(i!:reg_vec, reg2, a1 . getv(i!:reg_vec, reg2)); >> >> >> >> else if (instr = 'mov) and reg2 and (reg2 <= 2) then << if member(a1, getv(i!:reg_vec, reg2)) then % Suppress MOV return nil else << for i := 0:2 do putv(i!:reg_vec, i, delete(a1, getv(i!:reg_vec,i))); putv(i!:reg_vec, reg2, a1 . getv(i!:reg_vec, reg2)) >> >>; c1 := encomment(reg1, a1); c2 := encomment(reg2, a2); if null cdr c1 then c1 := append(c1, c2) else c1 := car c1 . append(c2, cdr c1); i_putcomment (instr . c1); if reg1 then % Immediate/register/memory to register variant if isnuma2 then << % Immediate to register variants if longnuma2 and (a1 = 'eax) then code := get(instr, 'i!:immed!-eax) else code := nil; if code then << % "Immediate to eax" version of instruction i_putbyte code; i_put32 a2; >> else << % "Immediate to register" version of % instruction (MOV,?..) code := get(instr, 'i!:immed!-reg); if code then << i_putbyte(code + reg1); i_put32 a2; >> else << % General "immediate to register/memory" version code := get(instr, 'i!:immed!-rm); if code then << secopcode := get(instr, 'i!:immed!-rm!-secopcode); if not secopcode then secopcode := reg1; if longnuma2 then << % Long immediate constant if flagp(instr, 'i!:immed!-rm!-shortformonly) then << error1 "Long constant is invalid here" >>; i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); i_put32 a2 >> else << % Short immediate constant if flagp(instr, 'i!:immed!-rm!-noshortform) then << i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); i_put32 a2 >> else if flagp(instr, 'i!:immed!-rm!-shortformonly) then << i_putbyte code; i_putbyte(0xc0 + secopcode*8 + reg1); i_putbyte a2 >> else << i_putbyte(code+2); i_putbyte(0xc0 + secopcode*8 + reg1); i_putbyte a2 >> >> >> else error1 "Invalid combination of opcode and operands 1" >> >> >> else << % Register/memory to register code := get(instr, 'i!:rm!-reg); if not code then error1 "Invalid combination of opcode and operands 2"; if reg2 then << % Register to register if (pref := get(instr, 'i!:rm!-reg!-prefix)) then i_putbyte pref; if (dbit := get(instr, 'i!:rm!-reg!-dbit_preset)) then << % Special case when changing d bit changes the whole instruction i_putbyte code; if dbit = 0 then << tmp := reg1; reg1 := reg2; reg2 := tmp >> >> else i_putbyte(code + 2); i_putbyte(0xc0 + reg1*8 + reg2) >> else << % Memory to register if atom a2 then a2 := i!:translate_memref(a2); if car a2 = 'ds then << i_putbyte 0x3E; if (instr = 'mov) and (reg1 = 0) then << % mov eax,ds:[...] i_putbyte 0xa1; i_putextern list('absolute, cadr a2); % More complicated ds addressing is not implemented yet! return nil >> >>; i_putbyte(code + 2); i!:outmemfield(reg1, a2) >> >> else if reg2 then << % Register to memory code := get(instr, 'i!:rm!-reg); if not code then error1 "Invalid combination of opcode and operands 3"; if atom a1 then a1 := i!:translate_memref(a1); if car a1 = 'ds then << i_putbyte 0x3E; if (instr = 'mov) and (reg2 = 0) then << % mov ds:[...],eax i_putbyte 0xa3; i_putextern list('absolute, cadr a1); % More complicated ds addressing is not implemented yet! return nil >> >>; i_putbyte code; i!:outmemfield(reg2, a1) >> else error1 "Invalid combination of opcode and operands 4" end; symbolic procedure i!:1arginstr(instr, a1); % Process an instruction with one argument begin scalar reg1, code, secopcode, labrec, curpos, dist; reg1 := get(a1, 'i!:regcode); % Peephole optimisation - replace push mem with push reg if mem = reg if (not reg1) and (instr = 'push) then << reg1 := i!:eq_to_reg(a1); if reg1 then a1 := i!:regname(reg1) >>; if not reg1 and atom a1 then a1 := i!:translate_memref(a1); % Part of peephole optimisation - control of changing register contents if flagp(instr, 'i!:changes_reg) and reg1 and (reg1 <= 2) then << putv(i!:reg_vec, reg1, nil); i!:remove_reg_memrefs(a1) >>; i_putcomment (instr . encomment(reg1, a1)); if atom a1 then << % Register or label operand if reg1 then << % Register operand code := get(instr, 'i!:reg); if code then << % "Register" version of instruction secopcode := get(instr, 'i!:reg!-secopcode); if not secopcode then i_putbyte(code + reg1) else << i_putbyte code; i_putbyte(secopcode + reg1) >> >> else << % "Register/memory" version of instruction code := get(instr, 'i!:rm); secopcode := get(instr, 'i!:rm!-secopcode); i_putbyte(code+2); i_putbyte(0xc0 + secopcode*8 + reg1) >> >> else if numberp a1 then << % Immediate operand if (a1 > 127) or (a1 < -128) then << code := get(instr, 'i!:immed32); i_putbyte code; i_put32 a1 >> else << code := get(instr, 'i!:immed8); i_putbyte code; i_putbyte a1 >> >> else << % Jumps and call remain, thus label operand code := get(instr, 'i!:jump); if not code then error1 "Invalid combination of opcode and operands 1"; if instr = 'call then << printc("##### CALL ", a1); i_putbyte code; i_putextern list('rel_plus_4, 99); % What am I calling???? % Part of peephole optimisation for i := 0:2 do putv(i!:reg_vec, i, nil) >> else i_putjump(code, a1); >> >> else << % Memory operand code := get(instr, 'i!:mem); secopcode := get(instr, 'i!:mem!-secopcode); if not secopcode then secopcode := 0; if car a1 = 'ds then i_putbyte 0x3E; i_putbyte code; i!:outmemfield(secopcode, a1); >> end; symbolic procedure i!:noarginstr instr; % Process an instruction with no arguments << i_putcomment list instr; i_putbyte get(instr,'i!:code) >>; symbolic procedure i!:proc_label lab; % Process a label begin i_putlabel lab; % Part of peephole optimisation for i := 0:2 do putv(i!:reg_vec, i, nil) end; % % Now the higher level parts of the compiler. % global '(!*fastvector !*unsafecar); flag('(fastvector unsafecar), 'switch); % Some internal CSL constants global '(TAG_BITS TAG_CONS TAG_FIXNUM TAG_ODDS TAG_SYMBOL TAG_NUMBERS TAG_VECTOR GC_STACK SPID_NOPROP); TAG_BITS := 7; TAG_CONS := 0; TAG_FIXNUM := 1; TAG_ODDS := 2; TAG_SYMBOL := 4; TAG_NUMBERS := 5; TAG_VECTOR := 6; GC_STACK := 2; SPID_NOPROP := 0xc2 + 0x0b00; % % I start with some utility functions that provide something % related to a FORMAT or PRINTF facility % % This establishes a default handler for each special form so that % any that I forget to treat more directly will cause a tidy error % if found in compiled code. symbolic procedure c!:cspecform(x, env); error(0, list("special form", x)); << put('and, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('block, 'c!:code, function c!:cspecform); !#endif put('catch, 'c!:code, function c!:cspecform); put('compiler!-let, 'c!:code, function c!:cspecform); put('cond, 'c!:code, function c!:cspecform); put('declare, 'c!:code, function c!:cspecform); put('de, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('defun, 'c!:code, function c!:cspecform); !#endif put('eval!-when, 'c!:code, function c!:cspecform); put('flet, 'c!:code, function c!:cspecform); put('function, 'c!:code, function c!:cspecform); put('go, 'c!:code, function c!:cspecform); put('if, 'c!:code, function c!:cspecform); put('labels, 'c!:code, function c!:cspecform); !#if common!-lisp!-mode put('let, 'c!:code, function c!:cspecform); !#else put('!~let, 'c!:code, function c!:cspecform); !#endif put('let!*, 'c!:code, function c!:cspecform); put('list, 'c!:code, function c!:cspecform); put('list!*, 'c!:code, function c!:cspecform); put('macrolet, 'c!:code, function c!:cspecform); put('multiple!-value!-call, 'c!:code, function c!:cspecform); put('multiple!-value!-prog1, 'c!:code, function c!:cspecform); put('or, 'c!:code, function c!:cspecform); put('prog, 'c!:code, function c!:cspecform); put('prog!*, 'c!:code, function c!:cspecform); put('prog1, 'c!:code, function c!:cspecform); put('prog2, 'c!:code, function c!:cspecform); put('progn, 'c!:code, function c!:cspecform); put('progv, 'c!:code, function c!:cspecform); put('quote, 'c!:code, function c!:cspecform); put('return, 'c!:code, function c!:cspecform); put('return!-from, 'c!:code, function c!:cspecform); put('setq, 'c!:code, function c!:cspecform); put('tagbody, 'c!:code, function c!:cspecform); put('the, 'c!:code, function c!:cspecform); put('throw, 'c!:code, function c!:cspecform); put('unless, 'c!:code, function c!:cspecform); put('unwind!-protect, 'c!:code, function c!:cspecform); put('when, 'c!:code, function c!:cspecform) >>; fluid '(current_procedure current_args current_block current_contents all_blocks registers stacklocs); fluid '(available used); available := used := nil; fluid '(lab_end_proc); symbolic procedure c!:reset_gensyms(); << remflag(used, 'c!:live_across_call); remflag(used, 'c!:visited); while used do << remprop(car used, 'c!:contents); remprop(car used, 'c!:why); remprop(car used, 'c!:where_to); remprop(car used, 'c!:count); remprop(car used, 'c!:live); remprop(car used, 'c!:clash); remprop(car used, 'c!:chosen); remprop(car used, 'c!:location); remprop(car used, 'i!:locoffs); if plist car used then begin scalar o; o := wrs nil; princ "+++++ "; prin car used; princ " "; prin plist car used; terpri(); wrs o end; available := car used . available; used := cdr used >> >>; !#if common!-lisp!-mode fluid '(my_gensym_counter); my_gensym_counter := 0; !#endif symbolic procedure c!:my_gensym(); begin scalar w; if available then << w := car available; available := cdr available >> !#if common!-lisp!-mode else w := compress1 ('!v . explodec (my_gensym_counter := my_gensym_counter + 1)); !#else else w := gensym1 "v"; !#endif used := w . used; if plist w then << princ "????? "; prin w; princ " => "; prin plist w; terpri() >>; return w end; symbolic procedure c!:newreg(); begin scalar r; r := c!:my_gensym(); registers := r . registers; return r end; symbolic procedure c!:startblock s; << current_block := s; current_contents := nil >>; symbolic procedure c!:outop(a,b,c,d); if current_block then current_contents := list(a,b,c,d) . current_contents; symbolic procedure c!:endblock(why, where_to); if current_block then << % Note that the operations within a block are in reversed order. put(current_block, 'c!:contents, current_contents); put(current_block, 'c!:why, why); put(current_block, 'c!:where_to, where_to); all_blocks := current_block . all_blocks; current_contents := nil; current_block := nil >>; % % Now for a general driver for compilation % symbolic procedure c!:cval_inner(x, env); begin scalar helper; % NB use the "improve" function from the regular compiler here... x := s!:improve x; % atoms and embedded lambda expressions need their own treatment. if atom x then return c!:catom(x, env) else if eqcar(car x, 'lambda) then return c!:clambda(cadar x, 'progn . cddar x, cdr x, env) % a c!:code property gives direct control over compilation else if helper := get(car x, 'c!:code) then return funcall(helper, x, env) % compiler-macros take precedence over regular macros, so that I can % make special expansions in the context of compilation. Only used if the % expansion is non-nil else if (helper := get(car x, 'c!:compile_macro)) and (helper := funcall(helper, x)) then return c!:cval(helper, env) % regular Lisp macros get expanded else if idp car x and (helper := macro!-function car x) then return c!:cval(funcall(helper, x), env) % anything not recognised as special will be turned into a % function call, but there will still be special cases, such as % calls to the current function, calls into the C-coded kernel, etc. else return c!:ccall(car x, cdr x, env) end; symbolic procedure c!:cval(x, env); begin scalar r; r := c!:cval_inner(x, env); if r and not member!*!*(r, registers) then error(0, list(r, "not a register", x)); return r end; symbolic procedure c!:clambda(bvl, body, args, env); begin scalar w, fluids, env1; env1 := car env; w := for each a in args collect c!:cval(a, env); for each v in bvl do << if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v end; if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('strglob, car w, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movr, cdar env1, nil, car w) >>; w := cdr w >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); w := c!:cval(body, env); for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); return w end; symbolic procedure c!:locally_bound(x, env); atsoc(x, car env); flag('(nil t), 'c!:constant); fluid '(literal_vector); symbolic procedure c!:find_literal x; begin scalar n, w; w := literal_vector; n := 0; while w and not (car w = x) do << n := n + 1; w := cdr w >>; if null w then literal_vector := append(literal_vector, list x); return n end; symbolic procedure c!:catom(x, env); begin scalar v, w; v := c!:newreg(); if idp x and (w := c!:locally_bound(x, env)) then c!:outop('movr, v, nil, cdr w) else if null x or x = 't or c!:small_number x then c!:outop('movk1, v, nil, x) else if not idp x or flagp(x, 'c!:constant) then c!:outop('movk, v, x, c!:find_literal x) else c!:outop('ldrglob, v, x, c!:find_literal x); return v end; symbolic procedure c!:cjumpif(x, env, d1, d2); begin scalar helper, r; x := s!:improve x; if atom x and (not idp x or (flagp(x, 'c!:constant) and not c!:locally_bound(x, env))) then c!:endblock('goto, list (if x then d1 else d2)) else if not atom x and (helper := get(car x, 'c!:ctest)) then return funcall(helper, x, env, d1, d2) else << r := c!:cval(x, env); c!:endblock(list('ifnull, r), list(d2, d1)) >> end; fluid '(current); symbolic procedure c!:ccall(fn, args, env); c!:ccall1(fn, args, env); fluid '(visited); symbolic procedure c!:has_calls(a, b); begin scalar visited; return c!:has_calls_1(a, b) end; symbolic procedure c!:has_calls_1(a, b); % true if there is a path from node a to node b that has a call instruction % on the way. if a = b or not atom a or memq(a, visited) then nil else begin scalar has_call; visited := a . visited; for each z in get(a, 'c!:contents) do if eqcar(z, 'call) then has_call := t; if has_call then return begin scalar visited; return c!:can_reach(a, b) end; for each d in get(a, 'c!:where_to) do if c!:has_calls_1(d, b) then has_call := t; return has_call end; symbolic procedure c!:can_reach(a, b); if a = b then t else if not atom a or memq(a, visited) then nil else << visited := a . visited; c!:any_can_reach(get(a, 'c!:where_to), b) >>; symbolic procedure c!:any_can_reach(l, b); if null l then nil else if c!:can_reach(car l, b) then t else c!:any_can_reach(cdr l, b); symbolic procedure c!:pareval(args, env); begin scalar tasks, tasks1, merge, split, r; tasks := for each a in args collect (c!:my_gensym() . c!:my_gensym()); split := c!:my_gensym(); c!:endblock('goto, list split); for each a in args do begin scalar s; % I evaluate each arg as what is (at this stage) a separate task s := car tasks; tasks := cdr tasks; c!:startblock car s; r := c!:cval(a, env) . r; c!:endblock('goto, list cdr s); % If the task did no procedure calls (or only tail calls) then it can be % executed sequentially with the other args without need for stacking % anything. Otherwise it more care will be needed. Put the hard % cases onto tasks1. !#if common!-lisp!-mode tasks1 := s . tasks1 !#else if c!:has_calls(car s, cdr s) then tasks1 := s . tasks1 else merge := s . merge !#endif end; %-- % if there are zero or one items in tasks1 then again it is easy - %-- % otherwise I flag the problem with a notionally parallel construction. %-- if tasks1 then << %-- if null cdr tasks1 then merge := car tasks1 . merge %-- else << %-- c!:startblock split; %-- printc "***** ParEval needed parallel block here..."; %-- c!:endblock('par, for each v in tasks1 collect car v); %-- split := c!:my_gensym(); %-- for each v in tasks1 do << %-- c!:startblock cdr v; %-- c!:endblock('goto, list split) >> >> >>; for each z in tasks1 do merge := z . merge; % do sequentially %-- %-- % Finally string end-to-end all the bits of sequential code I have left over. for each v in merge do << c!:startblock split; c!:endblock('goto, list car v); split := cdr v >>; c!:startblock split; return reversip r end; symbolic procedure c!:ccall1(fn, args, env); begin scalar tasks, merge, r, val; fn := list(fn, cdr env); val := c!:newreg(); if null args then c!:outop('call, val, nil, fn) else if null cdr args then c!:outop('call, val, list c!:cval(car args, env), fn) else << r := c!:pareval(args, env); c!:outop('call, val, r, fn) >>; c!:outop('reloadenv, 'env, nil, nil); return val end; fluid '(restart_label reloadenv does_call current_c_name); % % The "proper" recipe here arranges that functions that expect over 2 args use % the "va_arg" mechanism to pick up ALL their args. This would be pretty % heavy-handed, and at least on a lot of machines it does not seem to % be necessary. I will duck it for a while more at least. % fluid '(proglabs blockstack retloc); symbolic procedure c!:cfndef(current_procedure, current_c_name, args, body); begin scalar env, n, w, current_args, current_block, restart_label, current_contents, all_blocks, entrypoint, exitpoint, args1, registers, stacklocs, literal_vector, reloadenv, does_call, blockstack, proglabs, stackoffs, env_vec, i, retloc; c!:reset_gensyms(); i_startproc(); i!:reg_vec := mkvect 2; c!:find_literal current_procedure; % For benefit of backtraces % % cope with fluid vars in an argument list by mapping the definition % (de f (a B C d) body) B and C fluid % onto % (de f (a x y c) (prog (B C) (setq B x) (setq C y) (return body))) % so that the fluids get bound by PROG. % current_args := args; for each v in args do if v = '!&optional or v = '!&rest then error(0, "&optional and &rest not supported by this compiler (yet)") else if globalp v then begin scalar oo; oo := wrs nil; princ "+++++ "; prin v; princ " converted from GLOBAL to FLUID"; terpri(); wrs oo; unglobal list v; fluid list v; n := (v . c!:my_gensym()) . n end else if fluidp v then n := (v . c!:my_gensym()) . n; restart_label := c!:my_gensym(); body := list('c!:private_tagbody, restart_label, body); if n then << body := list list('return, body); args := subla(n, args); for each v in n do body := list('setq, car v, cdr v) . body; body := 'prog . (for each v in reverse n collect car v) . body >>; n := length args; if n = 0 or n >= 3 then w := t else w := nil; if w or i_machine = 4 then off_env := 8 else off_env := 4; % Here I FUDDGE the issue of args passed in registers by flushing them % back to the stack. I guess I will need to repair the stack to % compensate somewhere too... retloc := 0; if i_machine = 2 then << if n = 1 then << i!:gopcode(push,edx, push,eax); retloc := 2 >> else if n = 2 then << i!:gopcode(push,ebx, push,edx, push,eax); retloc := 3 >> >> else if i_machine = 3 then << if n = 1 or n = 2 then i!:gopcode(push, edx, push, ecx); retloc := 2 >>; if i_machine = 4 then << if w then stackoffs := 16 else stackoffs := 12 >> else if i_machine = 3 then << if w then stackoffs := 16 else stackoffs := 8 >> else if i_machine = 2 then << if w then stackoffs := 12 else stackoffs := 8 >> else error(0, "unknown machine"); n := 0; env := nil; for each x in args do begin scalar aa; n := n+1; if n = retloc then stackoffs := stackoffs+4; aa := c!:my_gensym(); env := (x . aa) . env; registers := aa . registers; args1 := aa . args1; put(aa, 'i!:locoffs, stackoffs); stackoffs := stackoffs + 4 end; c!:startblock (entrypoint := c!:my_gensym()); exitpoint := current_block; c!:endblock('goto, list list c!:cval(body, env . nil)); c!:optimise_flowgraph(entrypoint, all_blocks, env, length args . current_procedure, args1); env_vec := mkvect(length literal_vector - 1); i := 0; for each v in literal_vector do << putv(env_vec, i, v); i := i + 1 >>; if !*genlisting then << terpri(); ttab 28; princ "+++ Native code for "; prin current_procedure; printc " +++" >>; i := i_resolve(); symbol!-set!-native(current_procedure, length args, car i, cdr i, env_vec); return nil end; % c!:ccompile1 directs the compilation of a single function, and bind all the % major fluids used by the compilation process flag('(rds deflist flag fluid global remprop remflag unfluid unglobal dm carcheck i86!-end), 'eval); flag('(rds), 'ignore); fluid '(!*backtrace); symbolic procedure c!:ccompilesupervisor; begin scalar u, w; top:u := errorset('(read), t, !*backtrace); if atom u then return; % failed, or maybe EOF u := car u; if u = !$eof!$ then return; % end of file if atom u then go to top % the apply('i86!-end, nil) is here because i86!-end has a "stat" % property and so it will mis-parse if I just write "i86!-end()". Yuk. else if eqcar(u, 'i86!-end) then return apply('i86!-end, nil) else if eqcar(u, 'rdf) then << !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!-not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << terpri(); princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> >> else c!:ccmpout1 u; go to top end; global '(c!:char_mappings); c!:char_mappings := '( (! . !A) (!! . !B) (!# . !C) (!$ . !D) (!% . !E) (!^ . !F) (!& . !G) (!* . !H) (!( . !I) (!) . !J) (!- . !K) (!+ . !L) (!= . !M) (!\ . !N) (!| . !O) (!, . !P) (!. . !Q) (!< . !R) (!> . !S) (!: . !T) (!; . !U) (!/ . !V) (!? . !W) (!~ . !X) (!` . !Y)); symbolic procedure c!:inv_name n; begin scalar r, w; r := '(_ !C !C !"); !#if common!-lisp!-mode for each c in explode2 package!-name symbol!-package n do << if c = '_ then r := '_ . r else if alpha!-char!-p c or digit c then r := c . r else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!_ . '!_ . r; !#endif for each c in explode2 n do << if c = '_ then r := '_ . r !#if common!-lisp!-mode else if alpha!-char!-p c or digit c then r := c . r !#else else if liter c or digit c then r := c . r !#endif else if w := atsoc(c, c!:char_mappings) then r := cdr w . r else r := '!Z . r >>; r := '!" . r; !#if common!-lisp!-mode return compress1 reverse r !#else return compress reverse r !#endif end; fluid '(defnames); symbolic procedure c!:ccmpout1 u; begin scalar w; if atom u then return nil else if eqcar(u, 'progn) then << for each v in cdr u do codesize := codesize + c!:ccmpout1 v; return nil >> else if eqcar(u, 'i86!-end) then nil else if flagp(car u, 'eval) or (car u = 'setq and not atom caddr u and flagp(caaddr u, 'eval)) then errorset(u, t, !*backtrace); if eqcar(u, 'rdf) then begin !#if common!-lisp!-mode w := open(u := eval cadr u, !:direction, !:input, !:if!-does!_not!-exist, nil); !#else w := open(u := eval cadr u, 'input); !#endif if w then << princ "Reading file "; print u; w := rds w; c!:ccompilesupervisor(); princ "End of file "; print u; close rds w >> else << princ "Failed to open file "; print u >> end !#if common!-lisp!-mode else if eqcar(u, 'defun) then return c!:ccmpout1 macroexpand u !#endif else if eqcar(u, 'de) then << u := cdr u; !#if common!-lisp!-mode w := compress1 ('!" . append(explodec package!-name symbol!-package car u, '!@ . '!@ . append(explodec symbol!-name car u, append(explodec "@@Builtin", '(!"))))); w := intern w; defnames := list(car u, c!:inv_name car u, length cadr u, w) . defnames; !#else defnames := list(car u, c!:inv_name car u, length cadr u) . defnames; !#endif if posn() neq 0 then terpri(); princ "Compiling "; prin caar defnames; princ " ... "; c!:cfndef(caar defnames, cadar defnames, cadr u, 'progn . cddr u); terpri() >>; return nil; end; fluid '(!*defn dfprint!* dfprintsave); !#if common!-lisp!-mode symbolic procedure c!:concat(a, b); compress1('!" . append(explode2 a, append(explode2 b, '(!")))); !#else symbolic procedure c!:concat(a, b); compress('!" . append(explode2 a, append(explode2 b, '(!")))); !#endif symbolic procedure c!:ccompilestart name; defnames := nil; symbolic procedure i86!-end; << !*defn := nil; dfprint!* := dfprintsave >>; put('i86!-end, 'stat, 'endstat); symbolic procedure i86!-begin u; begin terpri(); princ "IN files; or type in expressions"; terpri(); princ "When all done, execute i86!-END;"; terpri(); verbos nil; defnames := nil; dfprintsave := dfprint!*; dfprint!* := 'c!:ccmpout1; !*defn := t; if getd 'begin then return nil; return c!:ccompilesupervisor() % There is a problem with compilesupervisor at the moment, so this way the % function does not return code size. end; put('i86!-begin, 'stat, 'rlis); symbolic procedure i86!-compile u; begin defnames := nil; % but subsequently ignored! c!:ccmpout1 u; end; % % Global treatment of a flow-graph... % symbolic procedure c!:print_opcode(s, depth); begin scalar op, r1, r2, r3, helper; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; helper := get(op, 'c!:opcode_printer); if helper then funcall(helper, op, r1, r2, r3, depth) else << prin s; terpri() >> end; symbolic procedure c!:print_exit_condition(why, where_to, depth); begin scalar helper, lab1, drop1, lab2, drop2, negate, jmptype, args, nargs, iflab1, iflab2, lab_end, pops; % An exit condition is one of % goto (lab) % goto ((return-register)) % (ifnull v) (lab1 lab2) ) etc, where v is a register and % (ifatom v) (lab1 lab2) ) lab1, lab2 are labels for true & false % (ifeq v1 v2) (lab1 lab2) ) and various predicates are supported % ((call fn) a1 a2) () tail-call to given function % if why = 'goto then << where_to := car where_to; if atom where_to then << i!:gopcode(jmp, where_to); c!:display_flowgraph(where_to, depth, t) >> else << c!:pgoto(nil, where_to, depth) >>; return nil >> else if eqcar(car why, 'call) then return begin scalar locs, g, w; nargs := length cdr why; << for each a in cdr why do if flagp(a, 'c!:live_across_call) then << g := c!:my_gensym(); args := g . args >> else args := a . args; i!:gopcode(push, esi); % The next line is a HORRID fudge to keep ebx safe when it was going to be % used by the calling standard. Ugh if i_machine = 2 and length cdr why = 2 then i!:gopcode(push,ebx); for each a in reverse(cdr why) do if flagp(a, 'c!:live_across_call) then i!:gopcode(push,{ebx,-get(a, 'c!:location)*4}) else i!:gopcode(push, a); c!:pld_eltenv(c!:find_literal cadar why); % Compute qenv(fn) and put into edx i!:gopcode(mov,edx,{eax,4}); % See further comments for the similar construction in c!:pcall if nargs = 1 then i!:gopcode(mov,esi,{eax,8}) else if nargs = 2 then i!:gopcode(mov,esi,{eax,12}) else << i!:gopcode(mov,esi,{eax,16}); i!:gopcode(push, nargs); nargs := nargs + 1 >>; i!:gopcode(push,edx); % Here I adapt (CRUDELY) for possibly different calling machanisms pops := 4*(nargs+1); print list(i_machine, nargs, pops, 'tailcall); if i_machine = 2 and (pops = 8 or pops = 12) then << i!:gopcode(pop,eax, pop,edx); pops := pops-8; if pops = 4 then << i!:gopcode(pop,ebx); pops := pops-4 >> >> else if i_machine = 3 and (pops = 8 or pops = 12) then << i!:gopcode(pop,ecx, pop,edx); pops := pops-8 >>; i!:gopcode(call,esi); if pops neq 0 then i!:gopcode(add,esp,pops); % The next line is a HORRID fudge to keep ebx safe when it was going to be % used by the calling standard. Ugh if i_machine = 2 and length cdr why = 2 then i!:gopcode(pop,ebx); i!:gopcode(pop, esi); if depth neq 0 then c!:ppopv(depth); i!:gopcode(jmp,lab_end_proc) >>; return nil end; lab1 := car where_to; drop1 := atom lab1 and not flagp(lab1, 'c!:visited); lab2 := cadr where_to; drop2 := atom lab2 and not flagp(drop2, 'c!:visited); if drop2 and get(lab2, 'c!:count) = 1 then << where_to := list(lab2, lab1); drop1 := t >> else if drop1 then negate := t; helper := get(car why, 'c!:exit_helper); if null helper then error(0, list("Bad exit condition", why)); %! Left for testing purposes and should be removed later ------ if not atom(car where_to) then % In this case it is implied that we should generate not just a jump, but % a piece of code which is executed if the condition is satisfied. iflab1 := c!:my_gensym(); if not atom(cadr where_to) then iflab2 := c!:my_gensym(); jmptype := funcall(helper, cdr why, negate); if not drop1 then << if not iflab1 then c!:pgoto(jmptype, car where_to, depth) else i!:gopcode(jmptype, iflab1); if not iflab2 then c!:pgoto('jmp, cadr where_to, depth) else i!:gopcode(jmp, iflab2) >> else if not iflab2 then c!:pgoto(jmptype, cadr where_to, depth) else << i!:gopcode(jmptype,iflab2); lab_end := c!:my_gensym(); i!:gopcode(jmp,lab_end) >>; if iflab1 then << i!:gopcode('!:,iflab1); c!:pgoto(jmptype, car where_to, depth) >>; if iflab2 then << i!:gopcode('!:,iflab2); c!:pgoto(jmptype, cadr where_to, depth) >>; if lab_end then i!:gopcode('!:,lab_end); if atom car where_to then c!:display_flowgraph(car where_to, depth, drop1); if atom cadr where_to then c!:display_flowgraph(cadr where_to, depth, nil) end; %----------------------------------------------------------------------------- % There are certain conventions about locations of some variables: % 1. I assume the address of current stack top is residing in ebx permanently; % *OOGGGUMPHHH*. On Linux ebx is perserved across procedure calls and so % this use of it as a "register variable" is OK, but on Watcom it gets % used in some procedure calls and potentially clobbered on any. Oh dear! % 2. nil is always the first local variable of any function, thus it is referred % everywhere as [ebp-4] % 3. env is always the first formal parameter of any function, thus it is % referred everywhere as [ebp+off_env] % 4. nargs (if exists at all) is always the second formal parameter of any % function, thus it is referred everywhere as [ebp+off_nargs] symbolic procedure c!:pmovr(op, r1, r2, r3, depth); << if flagp(r3, 'c!:live_across_call) then i!:gopcode(mov, eax, {ebx,-4*get(r3, 'c!:location)}) else i!:gopcode(mov, eax, r3); if flagp(r1, 'c!:live_across_call) then i!:gopcode(mov, {ebx,-4*get(r1, 'c!:location)},eax) else i!:gopcode(mov, r1, eax) >>; put('movr, ' c!:opcode_printer, function c!:pmovr); symbolic procedure c!:pld_eltenv(elno); << % #define elt(v, n) (*(Lisp_Object *)((char *)(v)-2+(((int32_t)(n))<<2))) i!:gopcode(mov, edx,{ebp,off_env}); i!:gopcode(mov, eax,{edx,4*elno-2}) >>; symbolic procedure c!:pst_eltenv(elno); << i!:gopcode(mov, edx,{ebp,off_env}); i!:gopcode(mov, {edx,4*elno-2},eax) >>; symbolic procedure c!:pld_qvaleltenv(elno); << % #define qvalue(p) (*(Lisp_Object *)(p)) c!:pld_eltenv(elno); i!:gopcode(mov, eax, {eax}); >>; symbolic procedure c!:pst_qvaleltenv(elno); << i!:gopcode(mov, edx,{ebp,off_env}); i!:gopcode(mov, ecx,{edx,4*elno-2}); i!:gopcode(mov, {ecx},eax); >>; symbolic procedure c!:pmovk(op, r1, r2, r3, depth); << c!:pld_eltenv(r3); i!:gopcode(mov, r1,eax) >>; put('movk, 'c!:opcode_printer, function c!:pmovk); symbolic procedure c!:pmovk1(op, r1, r2, r3, depth); if null r3 then << i!:gopcode(mov, eax, {ebp,-4}); i!:gopcode(mov, r1, eax) >> else if r3 = 't then << i!:gopcode(mov, eax, 'lisp_true); i!:gopcode(mov, r1, eax) >> else << i!:gopcode(mov, eax, 16*r3+1); i!:gopcode(mov, r1, eax) >>; put('movk1, 'c!:opcode_printer, function c!:pmovk1); procedure c!:preloadenv(op, r1, r2, r3, depth); % will not be encountered unless reloadenv variable has been set up. << i!:gopcode(mov, ecx,{ebx,-reloadenv*4}); i!:gopcode(mov, {ebp,off_env},ecx) >>; put('reloadenv, 'c!:opcode_printer, function c!:preloadenv); symbolic procedure c!:pldrglob(op, r1, r2, r3, depth); << c!:pld_qvaleltenv(r3); i!:gopcode(mov, r1,eax) >>; put('ldrglob, 'c!:opcode_printer, function c!:pldrglob); symbolic procedure c!:pstrglob(op, r1, r2, r3, depth); << i!:gopcode(mov, eax,r1); c!:pst_qvaleltenv(r3) >>; put('strglob, 'c!:opcode_printer, function c!:pstrglob); symbolic procedure c!:pnilglob(op, r1, r2, r3, depth); << i!:gopcode(mov, eax, {ebp,-4}); c!:pst_qvaleltenv(r3) >>; put('nilglob, 'c!:opcode_printer, function c!:pnilglob); symbolic procedure c!:pgentornil(condtype, dest); begin scalar condjmp, lab1, lab2; if condtype = 'eq then condjmp := 'jne else if condtype = 'neq then condjmp := 'je else if condtype = '< then condjmp := 'jge else if condtype = '> then condjmp := 'jle; lab1 := c!:my_gensym(); lab2 := c!:my_gensym(); i!:gopcode(condjmp, lab1); i!:gopcode(mov,eax,'lisp_true, jmp,lab2); i!:gopcode('!:,lab1, mov,eax,{ebp,-4}); i!:gopcode('!:,lab2, mov,dest,eax) end; symbolic procedure c!:pnull(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3); i!:gopcode(cmp,eax,{ebp,-4}); c!:pgentornil('eq, r1) >>; put('null, 'c!:opcode_printer, function c!:pnull); put('not, 'c!:opcode_printer, function c!:pnull); symbolic procedure c!:pfastget(op, r1, r2, r3, depth); begin scalar lab1,lab_end; lab1 := c!:my_gensym(); lab_end := c!:my_gensym(); i!:gopcode(mov,eax,r2); i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL, je,lab1); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end); i!:gopcode('!:,lab1); i!:gopcode(mov,eax,r2, mov,eax,{eax,28}, cmp,eax,{ebp,-4}, je,lab_end); i!:gopcode(mov,eax,{eax,4*(car r3)-2}); i!:gopcode(cmp,eax,SPID_NOPROP, jne,lab_end, mov,eax,{ebp,-4}); i!:gopcode('!:,lab_end, mov,r1,eax) end; put('fastget, 'c!:opcode_printer, function c!:pfastget); flag('(fastget), 'c!:uses_nil); symbolic procedure c!:pfastflag(op, r1, r2, r3, depth); begin scalar lab1, lab2, lab_end; lab1 := c!:my_gensym(); lab2 := c!:my_gensym(); lab_end := c!:my_gensym(); i!:gopcode(mov,eax,r2); i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL, je,lab1); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end); i!:gopcode('!:,lab1); i!:gopcode(mov,eax,r2, mov,eax,{eax,28}, cmp,eax,{ebp,-4}, je,lab_end); i!:gopcode(mov,eax,{eax,4*(car r3)-2}); i!:gopcode(cmp,eax,SPID_NOPROP, je,lab2, mov,eax,'lisp_true, jmp,lab_end); i!:gopcode('!:,lab2, mov,eax,{ebp,-4}); i!:gopcode('!:,lab_end, mov,r1,eax) end; put('fastflag, 'c!:opcode_printer, function c!:pfastflag); flag('(fastflag), 'c!:uses_nil); symbolic procedure c!:pcar(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:pgoto(nil, c!:find_error_label(list('car, r3), r2, depth), depth); % #define car_legal(p) is_cons(p) % #define is_cons(p) ((((int)(p)) & TAG_BITS) == TAG_CONS) % TAG_CONS = 0 i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); c!:pgoto('jne, c!:find_error_label(list('car, r3), r2, depth), depth) >>; c!:pqcar(op, r1, r2, r3, depth) end; put('car, 'c!:opcode_printer, function c!:pcar); symbolic procedure c!:pcdr(op, r1, r2, r3, depth); begin if not !*unsafecar then << c!:pgoto(nil, c!:find_error_label(list('cdr, r3), r2, depth), depth); i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); c!:pgoto('jne, c!:find_error_label(list('cdr, r3), r2, depth), depth) >>; c!:pqcdr(op, r1, r2, r3, depth) end; put('cdr, 'c!:opcode_printer, function c!:pcdr); symbolic procedure c!:pqcar(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3); i!:gopcode(mov,eax,{eax}, mov,r1,eax) >>; put('qcar, 'c!:opcode_printer, function c!:pqcar); symbolic procedure c!:pqcdr(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3); i!:gopcode(mov,eax,{eax,4}, mov,r1,eax) >>; put('qcdr, 'c!:opcode_printer, function c!:pqcdr); symbolic procedure c!:patom(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3, test,eax,TAG_BITS); c!:pgentornil('neq, r1); >>; put('atom, 'c!:opcode_printer, function c!:patom); symbolic procedure c!:pnumberp(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3, test,eax,1); c!:pgentornil('neq, r1) >>; put('numberp, 'c!:opcode_printer, function c!:pnumberp); symbolic procedure c!:pfixp(op, r1, r2, r3, depth); << c!:pgencall('integerp, {"nil",r3}, r1) >>; put('fixp, 'c!:opcode_printer, function c!:pfixp); symbolic procedure c!:piminusp(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r3, test,eax,eax); c!:pgentornil('<, r1) >>; put('iminusp, 'c!:opcode_printer, function c!:piminusp); symbolic procedure c!:pilessp(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, cmp,eax,r3); c!:pgentornil('<, r1) >>; put('ilessp, 'c!:opcode_printer, function c!:pilessp); symbolic procedure c!:pigreaterp(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, cmp,eax,r3); c!:pgentornil('>, r1) >>; put('igreaterp, 'c!:opcode_printer, function c!:pigreaterp); symbolic procedure c!:piminus(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,2, sub,eax,r3); i!:gopcode(mov, r1, eax) >>; put('iminus, 'c!:opcode_printer, function c!:piminus); symbolic procedure c!:piadd1(op, r1, r2, r3, depth); << i!:gopcode(mov, eax, r3); i!:gopcode(add,eax,0x10, mov,r1,eax) >>; put('iadd1, 'c!:opcode_printer, function c!:piadd1); symbolic procedure c!:pisub1(op, r1, r2, r3, depth); << i!:gopcode(mov, eax, r3); i!:gopcode(sub,eax,0x10, mov,r1,eax) >>; put('isub1, 'c!:opcode_printer, function c!:pisub1); symbolic procedure c!:piplus2(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, add,eax,r3); i!:gopcode(sub,eax,TAG_FIXNUM, mov,r1,eax) >>; put('iplus2, 'c!:opcode_printer, function c!:piplus2); symbolic procedure c!:pidifference(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, sub,eax,r3); i!:gopcode(add,eax,TAG_FIXNUM, mov,r1,eax) >>; put('idifference, 'c!:opcode_printer, function c!:pidifference); symbolic procedure c!:pitimes2(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, shr,eax,4); i!:gopcode(mov,edx,r3, shr,edx,4); i!:gopcode(mul,eax,edx, shl,eax,4, add,eax,TAG_FIXNUM); i!:gopcode(mov, r1, eax); >>; put('itimes2, 'c!:opcode_printer, function c!:pitimes2); symbolic procedure c!:pmodular_plus(op, r1, r2, r3, depth); begin scalar lab1; lab1 := c!:my_gensym(); i!:gopcode(mov,eax,r2, shr,eax,4); i!:gopcode(mov,edx,r3, shr,edx,4); i!:gopcode(add,eax,edx, cmp,eax,'current_modulus, jl,lab1); i!:gopcode(sub, eax, 'current_modulus); i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) end; put('modular!-plus, 'c!:opcode_printer, function c!:pmodular_plus); symbolic procedure c!:pmodular_difference(op, r1, r2, r3, depth); begin scalar lab1; lab1 := c!:my_gensym(); i!:gopcode(mov,eax,r2, shr,eax,4); i!:gopcode(mov,edx,r3, shr,edx,4); i!:gopcode(sub,eax,edx, test,eax,eax, jge,lab1); i!:gopcode(add,eax,'current_modulus); i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) end; put('modular!-difference, 'c!:opcode_printer, function c!:pmodular_difference); symbolic procedure c!:pmodular_minus(op, r1, r2, r3, depth); begin scalar lab1; lab1 := c!:my_gensym(); i!:gopcode(mov,eax,r3, shr,eax,4); i!:gopcode(test,eax,eax, je,lab1); i!:gopcode(sub,eax,'current_modulus, neg,eax); i!:gopcode('!:,lab1, shl,eax,4, add,eax,TAG_FIXNUM, mov,r1,eax) end; put('modular!-minus, 'c!:opcode_printer, function c!:pmodular_minus); !#if (not common!-lisp!-mode) symbolic procedure c!:passoc(op, r1, r2, r3, depth); << c!:pgencall('assoc, list("nil", r2, r3), r1) >>; put('assoc, 'c!:opcode_printer, function c!:passoc); flag('(assoc), 'c!:uses_nil); !#endif symbolic procedure c!:patsoc(op, r1, r2, r3, depth); << c!:pgencall('atsoc, list("nil", r2, r3), r1) >>; put('atsoc, 'c!:opcode_printer, function c!:patsoc); flag('(atsoc), 'c!:uses_nil); !#if (not common!-lisp!-mode) symbolic procedure c!:pmember(op, r1, r2, r3, depth); << c!:pgencall('member, {"nil", r2, r3}, r1) >>; put('member, 'c!:opcode_printer, function c!:pmember); flag('(member), 'c!:uses_nil); !#endif symbolic procedure c!:pmemq(op, r1, r2, r3, depth); << c!:pgencall('memq, {"nil", r2, r3}, r1) >>; put('memq, 'c!:opcode_printer, function c!:pmemq); flag('(memq), 'c!:uses_nil); !#if common!-lisp!-mode symbolic procedure c!:pget(op, r1, r2, r3, depth); << c!:pgencall('get, {r2, r3, "nil"}, r1); >>; flag('(get), 'c!:uses_nil); !#else symbolic procedure c!:pget(op, r1, r2, r3, depth); << c!:pgencall('get, list(r2, r3), r1); >>; !#endif put('get, 'c!:opcode_printer, function c!:pget); symbolic procedure c!:pgetv(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, sub,eax,2); i!:gopcode(mov,edx,r3, shr,edx,2, add,eax,edx); i!:gopcode(mov,eax,{eax}, mov,r1,eax) >>; put('getv, 'c!:opcode_printer, function c!:pgetv); symbolic procedure c!:pqputv(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, sub,eax,2); i!:gopcode(mov,edx,r3, shr,edx,2, add,edx,eax); i!:gopcode(mov,eax,r1, mov,{edx},eax) >>; put('qputv, 'c!:opcode_printer, function c!:pqputv); symbolic procedure c!:peq(op, r1, r2, r3, depth); << i!:gopcode(mov,eax,r2, cmp,eax,r3); c!:pgentornil('eq, r1) >>; put('eq, 'c!:opcode_printer, function c!:peq); flag('(eq), 'c!:uses_nil); symbolic procedure c!:pgenpequal(fname, args, res); begin scalar jmpinstr, lab1, lab2; jmpinstr := c!:pgenequal(fname, args, nil); % Jump instruction is issued for the case the condition is true lab1 := c!:my_gensym(); lab2 := c!:my_gensym(); i!:gopcode(jmpinstr, lab1); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab2); i!:gopcode('!:,lab1, mov,eax,'lisp_true); i!:gopcode('!:,lab2, mov,res,eax) end; !#if common!-lisp!-mode symbolic procedure c!:pequal(op, r1, r2, r3, depth); << c!:pgenpequal('cl_equal_fn, list(r2, r3), r1); >>; !#else symbolic procedure c!:pequal(op, r1, r2, r3, depth); begin c!:pgenpequal('equal_fn, list(r2, r3), r1) end; !#endif put('equal, 'c!:opcode_printer, function c!:pequal); flag('(equal), 'c!:uses_nil); symbolic procedure c!:pfluidbind(op, r1, r2, r3, depth); nil; put('fluidbind, 'c!:opcode_printer, function c!:pfluidbind); symbolic procedure c!:pgencall(addr, arglist, dest); % Generate a call sequence. begin scalar reg, nargs, c_dir, pops; if not (reg := get(addr,'i!:regcode)) then << nargs := length arglist; if not atom car arglist then << % We encode (nil, actual no of args) or (env, actual no of args) this way nargs := cadar arglist; car arglist := caar arglist; >> else if (car arglist = 'env) or (car arglist = "nil") then nargs := nargs - 1 else << % This is a direct C entrypoint or direct C predicate or one of special % functions: reclaim, error, equal_fn, aerror which behave the same % and for which we don't need to pass the number of args. if (c_dir := get(addr, 'c!:direct_call_func)) then nargs := nil >> >>; % The next line is a HORRID fudge to keep ebx safe when it was going to be % used by the calling standard. Ugh if i_machine = 2 and length arglist = 3 then i!:gopcode(push,ebx); % I have to reverse the order of parameters, since we use C call model for each a in reverse arglist do i!:gopcode(push, a); pops := 4*length arglist; % Here I adapt (CRUDELY) for possibly different calling mechanisms print list(i_machine, pops, 'call); if i_machine = 2 and (pops = 8 or nargs = 12) then << i!:gopcode(pop,eax, pop,edx); pops := pops-8; if pops = 4 then << i!:gopcode(pop,ebx); pops := pops-4 >> >> else if i_machine = 3 and (pops = 8 or pops = 12) then << i!:gopcode(pop,ecx, pop,edx); pops := pops-8 >>; if reg then i!:gopcode(call, addr) else << i_putcomment list('call, addr, list nargs, c_dir); i_putbyte 0xe8; if c_dir then i_putextern list('rel_plus_4, c_dir) else i_putextern list('rel_plus_4, list(addr, nargs)) >>; if pops neq 0 then i!:gopcode(add, esp, pops); % The next line is a HORRID fudge to keep ebx safe when it was going to be % used by the calling standard. Ugh if i_machine = 2 and length arglist = 3 then i!:gopcode(pop,ebx); if dest neq nil then i!:gopcode(mov,dest,eax); end; symbolic procedure c!:pcall(op, r1, r2, r3, depth); begin % r3 is (name ) scalar w, boolfn, nargs, lab1; %-- if car r3 = current_procedure then << %-- nargs := length r2; %-- if null r2 or nargs >= 3 then << %-- r2 := cons(nargs, r2); %-- r2 := cons({'env, nargs}, r2) >> %-- else r2 := cons('env, r2); %-- c!:pgencall(car r3, r2, r1) %-- >> begin nargs := length r2; c!:pld_eltenv(c!:find_literal car r3); % Compute qenv(fn) and put into edx i!:gopcode(mov,edx,{eax,4}); r2 := cons('edx, r2); if nargs = 1 then i!:gopcode(mov,ecx,{eax,8}) else if nargs = 2 then i!:gopcode(mov,ecx,{eax,12}) else << i!:gopcode(mov,ecx,{eax,16}); r2 := car r2 . nargs . cdr r2 >>; c!:pgencall('ecx, r2, r1) end; if not flagp(car r3, 'c!:no_errors) then << if null cadr r3 and depth = 0 then << lab1 := c!:my_gensym(); i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); i!:gopcode(and,eax,1, je,lab1); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc); i!:gopcode('!:,lab1) >> else << i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); c!:pgoto(nil, c!:find_error_label(nil, cadr r3, depth), depth); i!:gopcode(and,eax,1); c!:pgoto('jne, c!:find_error_label(nil, cadr r3, depth), depth) >> >>; if boolfn then << i!:gopcode(mov,eax,r1, test,eax,eax); c!:pgentornil('neq, r1) >> end; put('call, 'c!:opcode_printer, function c!:pcall); symbolic procedure c!:ppopv(depth); << i!:gopcode(sub,ebx,depth*4, mov,'stack,ebx) >>; symbolic procedure c!:pgoto(jmptype, lab, depth); begin if atom lab then << if jmptype neq nil then %! when test sup removed nil test not required return i!:gopcode(jmptype, lab) else return nil >>; lab := get(car lab, 'c!:chosen); if zerop depth then << i!:gopcode(mov,eax,lab, jmp,lab_end_proc) >> else if flagp(lab, 'c!:live_across_call) then << i!:gopcode(mov, eax, {ebx, -get(lab, 'c!:location)*4}); c!:ppopv(depth); i!:gopcode(jmp,lab_end_proc) >> else << c!:ppopv(depth); i!:gopcode(mov,eax,lab, jmp,lab_end_proc) >> end; symbolic procedure c!:pifnull(s, negate); << i!:gopcode(mov, eax, car s); i!:gopcode(cmp, eax, {ebp,-4}); if negate then 'jne else 'je >>; put('ifnull, 'c!:exit_helper, function c!:pifnull); symbolic procedure c!:pifatom(s, negate); << i!:gopcode(mov,eax,car s, test,eax,TAG_BITS); if negate then 'je else 'jne >>; put('ifatom, 'c!:exit_helper, function c!:pifatom); symbolic procedure c!:pifsymbol(s, negate); << i!:gopcode(mov, eax, car s); i!:gopcode(and,eax,TAG_BITS, cmp,eax,TAG_SYMBOL); if negate then 'jne else 'je >>; put('ifsymbol, 'c!:exit_helper, function c!:pifsymbol); symbolic procedure c!:pifnumber(s, negate); << i!:gopcode(mov,eax,car s, test,eax,1); if negate then 'je else 'jne >>; put('ifnumber, 'c!:exit_helper, function c!:pifnumber); symbolic procedure c!:pifizerop(s, negate); << i!:gopcode(mov,eax,car s, cmp,eax,1); if negate then 'jne else 'je >>; put('ifizerop, 'c!:exit_helper, function c!:pifizerop); symbolic procedure c!:pifeq(s, negate); << i!:gopcode(mov,eax,car s, cmp,eax,cadr s); if negate then 'jne else 'je >>; put('ifeq, 'c!:exit_helper, function c!:pifeq); symbolic procedure c!:pgenequal(fname, args, negate); % Perform the evaluation of the macro below, and issue a cond jump command so % that jump is performed if the condition is satisfied. fname should be % either equal_fn or cl_equal_fn, and this parameter is required only % because of my desire to support both SL and CL at least here begin scalar lab_ok, lab_fail, lab_end; % #define equal(a, b) \ % ((a) == (b) || \ % (((((a) ^ (b)) & TAG_BITS) == 0) && \ % ((unsigned)(((a) & TAG_BITS) - 1) > 3) && \ % equal_fn(a, b))) lab_ok := c!:my_gensym(); lab_fail := c!:my_gensym(); lab_end := c!:my_gensym(); i!:gopcode(mov, ecx,car args); i!:gopcode(mov, edx,cadr args); i!:gopcode(cmp,ecx,edx, je,lab_ok); i!:gopcode(mov,eax,ecx, xor,eax,edx, test,eax,7, jne,lab_fail); i!:gopcode(mov,eax,ecx, and,eax,7, dec,eax); i!:gopcode(cmp,eax,3, jbe,lab_fail); c!:pgencall(fname,{'ecx,'edx},nil); i!:gopcode(test,eax,eax, jne,lab_ok); i!:gopcode('!:,lab_fail, xor,eax,eax, jmp,lab_end); i!:gopcode('!:,lab_ok, mov,eax,1); i!:gopcode('!:,lab_end, test,eax,eax); if negate then return 'je else return 'jne end; !#if common!-lisp!-mode symbolic procedure c!:pifequal(s, negate); c!:pgenequal('cl_equal_fn, s, negate); !#else symbolic procedure c!:pifequal(s, negate); c!:pgenequal('equal_fn, s, negate); !#endif put('ifequal, 'c!:exit_helper, function c!:pifequal); symbolic procedure c!:pifilessp(s, negate); << i!:gopcode(mov,eax,car s, cmp,eax,cadr s); if negate then 'jge else 'jl >>; put('ifilessp, 'c!:exit_helper, function c!:pifilessp); symbolic procedure c!:pifigreaterp(s, negate); << i!:gopcode(mov,eax,car s, cmp,eax,cadr s); if negate then 'jle else 'jg >>; put('ifigreaterp, 'c!:exit_helper, function c!:pifigreaterp); %------------------------------------------------------------------------------ symbolic procedure c!:display_flowgraph(s, depth, dropping_through); if not atom s then << c!:pgoto(nil, s, depth) >> else if not flagp(s, 'c!:visited) then begin scalar why, where_to; flag(list s, 'c!:visited); if not dropping_through or not (get(s, 'c!:count) = 1) then i!:gopcode('!:, s); for each k in reverse get(s, 'c!:contents) do c!:print_opcode(k, depth); why := get(s, 'c!:why); where_to := get(s, 'c!:where_to); if why = 'goto and (not atom car where_to or (not flagp(car where_to, 'c!:visited) and get(car where_to, 'c!:count) = 1)) then c!:display_flowgraph(car where_to, depth, t) else c!:print_exit_condition(why, where_to, depth) end; fluid '(startpoint); symbolic procedure c!:branch_chain(s, count); begin scalar contents, why, where_to, n; % do nothing to blocks already visted or return blocks. if not atom s then return s else if flagp(s, 'c!:visited) then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n); return s >>; flag(list s, 'c!:visited); contents := get(s, 'c!:contents); why := get(s, 'c!:why); where_to := for each z in get(s, 'c!:where_to) collect c!:branch_chain(z, count); % Turn movr a,b; return a; into return b; while contents and eqcar(car contents, 'movr) and why = 'goto and not atom car where_to and caar where_to = cadr car contents do << where_to := list list cadddr car contents; contents := cdr contents >>; put(s, 'c!:contents, contents); put(s, 'c!:where_to, where_to); % discard empty blocks if null contents and why = 'goto then << remflag(list s, 'c!:visited); return car where_to >>; if count then << n := get(s, 'c!:count); if null n then n := 1 else n := n + 1; put(s, 'c!:count, n) >>; return s end; symbolic procedure c!:one_operand op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_one) >>; symbolic procedure c!:two_operands op; << flag(list op, 'c!:set_r1); flag(list op, 'c!:read_r2); flag(list op, 'c!:read_r3); put(op, 'c!:code, function c!:builtin_two) >>; for each n in '(car cdr qcar qcdr null not atom numberp fixp iminusp iminus iadd1 isub1 modular!-minus) do c!:one_operand n; !#if common!-lisp!-mode for each n in '(eq equal atsoc memq iplus2 idifference itimes2 ilessp igreaterp getv get modular!-plus modular!-difference ) do c!:two_operands n; !#else for each n in '(eq equal atsoc memq iplus2 idifference assoc member itimes2 ilessp igreaterp getv get modular!-plus modular!-difference ) do c!:two_operands n; !#endif flag('(movr movk movk1 ldrglob call reloadenv fastget fastflag), 'c!:set_r1); flag('(strglob qputv), 'c!:read_r1); flag('(qputv fastget fastflag), 'c!:read_r2); flag('(movr qputv), 'c!:read_r3); flag('(ldrglob strglob nilglob movk call), 'c!:read_env); % special opcodes: % call fluidbind fluid '(fn_used nil_used nilbase_used); symbolic procedure c!:live_variable_analysis all_blocks; begin scalar changed, z; repeat << changed := nil; for each b in all_blocks do begin scalar w, live; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << if eqcar(w, 'ifnull) or eqcar(w, 'ifequal) then nil_used := t; live := union(live, cdr w); if eqcar(car w, 'call) and not (cadar w = current_procedure) then << fn_used := t; live := union('(env), live) >> >>; for each s in get(b, 'c!:contents) do begin % backwards over contents scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if op = 'movk1 then << if r3 = nil then nil_used := t else if r3 = 't then nilbase_used := t >> else if atom op and flagp(op, 'c!:uses_nil) then nil_used := t; if flagp(op, 'c!:set_r1) then !#if common!-lisp!-mode if memq(r1, live) then live := remove(r1, live) !#else if memq(r1, live) then live := delete(r1, live) !#endif else if op = 'call then nil % Always needed else op := 'nop; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); if op = 'call then << if not flagp(car r3, 'c!:no_errors) then nil_used := t; does_call := t; fn_used := t; if not flagp(car r3, 'c!:no_errors) then flag(live, 'c!:live_across_call); live := union(live, r2) >>; if flagp(op, 'c!:read_env) then live := union(live, '(env)) end; !#if common!-lisp!-mode live := append(live, nil); % because CL sort is destructive! !#endif live := sort(live, function orderp); if not (live = get(b, 'c!:live)) then << put(b, 'c!:live, live); changed := t >> end >> until not changed; z := registers; registers := stacklocs := nil; for each r in z do if flagp(r, 'c!:live_across_call) then stacklocs := r . stacklocs else registers := r . registers; end; symbolic procedure c!:insert1(a, b); if memq(a, b) then b else a . b; symbolic procedure c!:clash(a, b); if flagp(a, 'c!:live_across_call) = flagp(b, 'c!:live_across_call) then << put(a, 'c!:clash, c!:insert1(b, get(a, 'c!:clash))); put(b, 'c!:clash, c!:insert1(a, get(b, 'c!:clash))) >>; symbolic procedure c!:build_clash_matrix all_blocks; begin for each b in all_blocks do begin scalar live, w; for each x in get(b, 'c!:where_to) do if atom x then live := union(live, get(x, 'c!:live)) else live := union(live, x); w := get(b, 'c!:why); if not atom w then << live := union(live, cdr w); if eqcar(car w, 'call) then live := union('(env), live) >>; for each s in get(b, 'c!:contents) do begin scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if flagp(op, 'c!:set_r1) then if memq(r1, live) then << !#if common!-lisp!-mode live := remove(r1, live); !#else live := delete(r1, live); !#endif if op = 'reloadenv then reloadenv := t; for each v in live do c!:clash(r1, v) >> else if op = 'call then nil else << op := 'nop; rplacd(s, car s . cdr s); % Leaves original instrn visible rplaca(s, op) >>; if flagp(op, 'c!:read_r1) then live := union(live, list r1); if flagp(op, 'c!:read_r2) then live := union(live, list r2); if flagp(op, 'c!:read_r3) then live := union(live, list r3); % Maybe CALL should be a little more selective about need for "env"? if op = 'call then live := union(live, r2); if flagp(op, 'c!:read_env) then live := union(live, '(env)) end end; return nil end; symbolic procedure c!:allocate_registers rl; begin scalar schedule, neighbours, allocation; neighbours := 0; while rl do begin scalar w, x; w := rl; while w and length (x := get(car w, 'c!:clash)) > neighbours do w := cdr w; if w then << schedule := car w . schedule; rl := deleq(car w, rl); for each r in x do put(r, 'c!:clash, deleq(car w, get(r, 'c!:clash))) >> else neighbours := neighbours + 1 end; for each r in schedule do begin scalar poss; poss := allocation; for each x in get(r, 'c!:clash) do poss := deleq(get(x, 'c!:chosen), poss); if null poss then << poss := c!:my_gensym(); allocation := append(allocation, list poss) >> else poss := car poss; put(r, 'c!:chosen, poss) end; return allocation end; symbolic procedure c!:remove_nops all_blocks; % Remove no-operation instructions, and map registers to reflect allocation for each b in all_blocks do begin scalar r; for each s in get(b, 'c!:contents) do if not eqcar(s, 'nop) then begin scalar op, r1, r2, r3; op := car s; r1 := cadr s; r2 := caddr s; r3 := cadddr s; if flagp(op, 'c!:set_r1) or flagp(op, 'c!:read_r1) then r1 := get(r1, 'c!:chosen); if flagp(op, 'c!:read_r2) then r2 := get(r2, 'c!:chosen); if flagp(op, 'c!:read_r3) then r3 := get(r3, 'c!:chosen); if op = 'call then r2 := for each v in r2 collect get(v, 'c!:chosen); if not (op = 'movr and r1 = r3) then r := list(op, r1, r2, r3) . r end; put(b, 'c!:contents, reversip r); r := get(b, 'c!:why); if not atom r then put(b, 'c!:why, car r . for each v in cdr r collect get(v, 'c!:chosen)) end; fluid '(error_labels); symbolic procedure c!:find_error_label(why, env, depth); begin scalar w, z; z := list(why, env, depth); w := assoc!*!*(z, error_labels); if null w then << w := z . c!:my_gensym(); error_labels := w . error_labels >>; return cdr w end; symbolic procedure c!:assign(u, v, c); if flagp(u, 'fluid) then list('strglob, v, u, c!:find_literal u) . c else list('movr, u, nil, v) . c; symbolic procedure c!:insert_tailcall b; begin scalar why, dest, contents, fcall, res, w; why := get(b, 'c!:why); dest := get(b, 'c!:where_to); contents := get(b, 'c!:contents); while contents and not eqcar(car contents, 'call) do << w := car contents . w; contents := cdr contents >>; if null contents then return nil; fcall := car contents; contents := cdr contents; res := cadr fcall; while w do << if eqcar(car w, 'reloadenv) then w := cdr w else if eqcar(car w, 'movr) and cadddr car w = res then << res := cadr car w; w := cdr w >> else res := w := nil >>; if null res then return nil; if c!:does_return(res, why, dest) then if car cadddr fcall = current_procedure then << for each p in pair(current_args, caddr fcall) do contents := c!:assign(car p, cdr p, contents); put(b, 'c!:contents, contents); put(b, 'c!:why, 'goto); put(b, 'c!:where_to, list restart_label) >> else << nil_used := t; put(b, 'c!:contents, contents); put(b, 'c!:why, list('call, car cadddr fcall) . caddr fcall); put(b, 'c!:where_to, nil) >> end; symbolic procedure c!:does_return(res, why, where_to); if not (why = 'goto) then nil else if not atom car where_to then res = caar where_to else begin scalar contents; where_to := car where_to; contents := reverse get(where_to, 'c!:contents); why := get(where_to, 'c!:why); where_to := get(where_to, 'c!:where_to); while contents do if eqcar(car contents, 'reloadenv) then contents := cdr contents else if eqcar(car contents, 'movr) and cadddr car contents = res then << res := cadr car contents; contents := cdr contents >> else res := contents := nil; if null res then return nil else return c!:does_return(res, why, where_to) end; symbolic procedure c!:pushpop(op, v); begin scalar n, w, instr, src, dest, addr, v1,n1; if null v then return nil; n := length v; if op = 'push then << instr := 'add; src := 'eax >> else << instr := 'sub; dest := 'eax >>; addr := 0; for each x in v do << if op = 'push then << addr := addr + 4; dest := {'ebx, addr}; i!:gopcode(mov, eax, x) >> else src := {'ebx, addr}; i!:gopcode(mov, dest, src); if op = 'pop then << i!:gopcode(mov, x,eax); addr := addr - 4 >> >>; i!:gopcode(add,ebx,addr, mov,'stack,ebx) end; symbolic procedure c!:optimise_flowgraph(startpoint, all_blocks, env, argch, args); begin scalar w, n, locs, stacks, error_labels, fn_used, nil_used, nilbase_used, locsno, lab1, addr, lab_ok, stackoffs; !#if common!-lisp!-mode nilbase_used := t; % For onevalue(xxx) at least !#endif for each b in all_blocks do c!:insert_tailcall b; startpoint := c!:branch_chain(startpoint, nil); remflag(all_blocks, 'c!:visited); c!:live_variable_analysis all_blocks; c!:build_clash_matrix all_blocks; if error_labels and env then reloadenv := t; for each u in env do for each v in env do c!:clash(cdr u, cdr v); % keep all args distinct locs := c!:allocate_registers registers; stacks := c!:allocate_registers stacklocs; flag(stacks, 'c!:live_across_call); c!:remove_nops all_blocks; startpoint := c!:branch_chain(startpoint, nil); % after tailcall insertion remflag(all_blocks, 'c!:visited); startpoint := c!:branch_chain(startpoint, t); % ... AGAIN to tidy up remflag(all_blocks, 'c!:visited); if does_call then nil_used := t; lab_end_proc := c!:my_gensym(); locsno := 0; if nil_used then << locsno := locsno + 1 >>; if locs then << locsno := locsno + length(locs) >>; % In ASM code I don't use fn since it is well replaced by hardware register i!:gopcode(push,ebp, mov,ebp,esp); if locsno > 0 then << i!:gopcode(sub,esp,locsno*4); stackoffs := 0; if nil_used then stackoffs := stackoffs - 4; for each v in locs do << stackoffs := stackoffs - 4; put(v, 'i!:locoffs, stackoffs) >> >>; if nil_used then i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); i!:gopcode(push,ebx, mov,ebx,'stack); %!! Has not been perfectly processed yet due to the string parameter % # define argcheck(var, n, msg) if ((var)!=(n)) return aerror(msg); if car argch = 0 or car argch >= 3 then << lab_ok := c!:my_gensym(); i!:gopcode(mov,eax,{ebp,off_nargs}, cmp,eax,car argch, je,lab_ok); c!:pgencall('aerror, {999}, nil); i!:gopcode(jmp,lab_end_proc); i!:gopcode('!:,lab_ok) >>; % I will not do a stack check if I have a leaf procedure, and I hope % that this policy will speed up code a bit. if does_call then << lab1 := c!:my_gensym(); i!:gopcode(cmp,ebx,'stacklimit, jl,lab1); % This is slightly clumsy code to save all args on the stack across the % call to reclaim(), but it is not executed often... c!:pushpop('push, args); %!! Has not been perfectly processed yet due to the string parameter c!:pgencall('reclaim, {'!.env,0,GC_STACK,0}, {'ebp,off_env}); c!:pushpop('pop, reverse args); i!:gopcode(mov,eax,'C_nil, mov,{ebp,-4},eax); i!:gopcode(and,eax,1, je,lab1); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc); i!:gopcode('!:,lab1) >>; if reloadenv then << i!:gopcode(mov,eax,{ebp,off_env}, add,ebx,4, mov,{ebx},eax, mov,'stack,ebx) >>; n := 0; if stacks then << for each v in stacks do << put(v, 'c!:location, n); n := n+1 >>; stackoffs := 0; i!:gopcode(mov, eax,{ebp,-4}); for each v in stacks do << stackoffs := stackoffs + 4; i!:gopcode(mov, {ebx,stackoffs},eax) >>; i!:gopcode(add,ebx,stackoffs, mov,'stack,ebx) >>; if reloadenv then << reloadenv := n; n := n + 1 >>; for each v in env do if flagp(cdr v, 'c!:live_across_call) then << i!:gopcode(mov, eax,cdr v); i!:gopcode(mov, {ebx,-get(get(cdr v, 'c!:chosen), 'c!:location)*4},eax) >> else << i!:gopcode(mov, eax,cdr v); i!:gopcode(mov, get(cdr v, 'c!:chosen),eax) >>; c!:display_flowgraph(startpoint, n, t); if error_labels then << for each x in error_labels do << i!:gopcode('!:, cdr x); c!:print_error_return(caar x, cadar x, caddar x) >> >>; remflag(all_blocks, 'c!:visited); i!:gopcode('!:,lab_end_proc); i!:gopcode(pop,ebx, mov,esp,ebp, pop,ebp); if retloc neq 0 then i!:gopcode(add,esp,4*retloc); i!:gopcode(ret); end; symbolic procedure c!:print_error_return(why, env, depth); begin scalar args; if reloadenv and env then << i!:gopcode(mov,eax,{ebx,-reloadenv*4}, mov,{ebp,off_env},eax) >>; if null why then << % One could imagine generating backtrace entries here... for each v in env do << i!:gopcode(mov, eax,get(cdr v, 'c!:chosen)); c!:pst_qvaleltenv(c!:find_literal car v) >>; if depth neq 0 then c!:ppopv(depth); i!:gopcode(mov,eax,{ebp,-4}, jmp,lab_end_proc) >> else if flagp(cadr why, 'c!:live_across_call) then << i!:gopcode(push, {ebx,-get(cadr why, 'c!:location)*4}); for each v in env do << i!:gopcode(mov, eax,get(cdr v, 'c!:chosen)); c!:pst_qvaleltenv(c!:find_literal car v) >>; if depth neq 0 then c!:ppopv(depth); if eqcar(why, 'car) then "err_bad_car" else if eqcar(why, 'cdr) then "err_bad_cdr" else error(0, list(why, "unknown_error")); %!! Has not been properly processed yet because of the string parameter args := list(1, if eqcar(why, 'car) then 0 % "err_bad_car" else if eqcar(why, 'cdr) then 0 % "err_bad_cdr" else 0, % error(0, list(why, "unknown_error")); cadr why); c!:pgencall('error, args, nil); i!:gopcode(jmp,lab_end_proc) >> else << for each v in env do << i!:gopcode(mov, eax, get(cdr v, 'c!:chosen)); c!:pst_qvaleltenv(c!:find_literal car v) >>; if depth neq 0 then c!:ppopv(depth); %!! Has not been properly processed yet due to the string parameter args := list(1, if eqcar(why, 'car) then 0 % "err_bad_car" else if eqcar(why, 'cdr) then 0 % "err_bad_cdr" else 0, % error(0, list(why, "unknown_error")); cadr why); c!:pgencall('error, args, nil); i!:gopcode(jmp,lab_end_proc) >> end; % % Now I have a series of separable sections each of which gives a special % recipe that implements or optimises compilation of some specific Lisp % form. % symbolic procedure c!:cand(u, env); begin scalar w, r; w := reverse cdr u; if null w then return c!:cval(nil, env); r := list(list('t, car w)); w := cdr w; for each z in w do r := list(list('null, z), nil) . r; r := 'cond . r; return c!:cval(r, env) end; %-- scalar next, done, v, r; %-- v := c!:newreg(); %-- done := c!:my_gensym(); %-- u := cdr u; %-- while cdr u do << %-- next := c!:my_gensym(); %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- u := cdr u; %-- c!:endblock(list('ifnull, v), list(done, next)); %-- c!:startblock next >>; %-- c!:outop('movr, v, nil, c!:cval(car u, env)); %-- c!:endblock('goto, list done); %-- c!:startblock done; %-- return v %-- end; put('and, 'c!:code, function c!:cand); !#if common!-lisp!-mode symbolic procedure c!:cblock(u, env); begin scalar progret, progexit, r; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (cadr u . progret . progexit) . blockstack; u := cddr u; for each a in u do r := c!:cval(a, env); c!:outop('movr, progret, nil, r); c!:endblock('goto, list progexit); c!:startblock progexit; blockstack := cdr blockstack; return progret end; put('block, 'c!:code, function c!:cblock); !#endif symbolic procedure c!:ccatch(u, env); error(0, "catch"); put('catch, 'c!:code, function c!:ccatch); symbolic procedure c!:ccompile_let(u, env); error(0, "compiler-let"); put('compiler!-let, 'c!:code, function c!:ccompiler_let); symbolic procedure c!:ccond(u, env); begin scalar v, join; v := c!:newreg(); join := c!:my_gensym(); for each c in cdr u do begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); if atom cdr c then << c!:outop('movr, v, nil, c!:cval(car c, env)); c!:endblock(list('ifnull, v), list(l2, join)) >> else << c!:cjumpif(car c, env, l1, l2); c!:startblock l1; % if the condition is true c!:outop('movr, v, nil, c!:cval('progn . cdr c, env)); c!:endblock('goto, list join) >>; c!:startblock l2 end; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('cond, 'c!:code, function c!:ccond); symbolic procedure c!:cdeclare(u, env); error(0, "declare"); put('declare, 'c!:code, function c!:cdeclare); symbolic procedure c!:cde(u, env); error(0, "de"); put('de, 'c!:code, function c!:cde); symbolic procedure c!:cdefun(u, env); error(0, "defun"); put('!~defun, 'c!:code, function c!:cdefun); symbolic procedure c!:ceval_when(u, env); error(0, "eval-when"); put('eval!-when, 'c!:code, function c!:ceval_when); symbolic procedure c!:cflet(u, env); error(0, "flet"); put('flet, 'c!:code, function c!:cflet); symbolic procedure c!:cfunction(u, env); begin scalar v; u := cadr u; if not atom u then error(0, "function/funarg needed"); v := c!:newreg(); c!:outop('movk, v, u, c!:find_literal u); return v end; put('function, 'c!:code, function c!:cfunction); symbolic procedure c!:cgo(u, env); begin scalar w, w1; w1 := proglabs; while null w and w1 do << w := assoc!*!*(cadr u, car w1); w1 := cdr w1 >>; if null w then error(0, list(u, "label not set")); c!:endblock('goto, list cadr w); return nil % value should not be used end; put('go, 'c!:code, function c!:cgo); symbolic procedure c!:cif(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval(car (u := cddr u), env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movr, v, nil, c!:cval(cadr u, env)); c!:endblock('goto, list join); c!:startblock join; return v end; put('if, 'c!:code, function c!:cif); symbolic procedure c!:clabels(u, env); error(0, "labels"); put('labels, 'c!:code, function c!:clabels); symbolic procedure c!:expand!-let(vl, b); if null vl then 'progn . b else if null cdr vl then c!:expand!-let!*(vl, b) else begin scalar vars, vals; for each v in vl do if atom v then << vars := v . vars; vals := nil . vals >> else if atom cdr v then << vars := car v . vars; vals := nil . vals >> else << vars := car v . vars; vals := cadr v . vals >>; return ('lambda . vars . b) . vals end; symbolic procedure c!:clet(x, env); c!:cval(c!:expand!-let(cadr x, cddr x), env); !#if common!-lisp!-mode put('let, 'c!:code, function c!:clet); !#else put('!~let, 'c!:code, function c!:clet); !#endif symbolic procedure c!:expand!-let!*(vl, b); if null vl then 'progn . b else begin scalar var, val; var := car vl; if not atom var then << val := cdr var; var := car var; if not atom val then val := car val >>; b := list list('return, c!:expand!-let!*(cdr vl, b)); if val then b := list('setq, var, val) . b; return 'prog . list var . b end; symbolic procedure c!:clet!*(x, env); c!:cval(c!:expand!-let!*(cadr x, cddr x), env); put('let!*, 'c!:code, function c!:clet!*); symbolic procedure c!:clist(u, env); if null cdr u then c!:cval(nil, env) else if null cddr u then c!:cval('ncons . cdr u, env) else if eqcar(cadr u, 'cons) then c!:cval(list('acons, cadr cadr u, caddr cadr u, 'list . cddr u), env) else if null cdddr u then c!:cval('list2 . cdr u, env) else c!:cval(list('list2!*, cadr u, caddr u, 'list . cdddr u), env); put('list, 'c!:code, function c!:clist); symbolic procedure c!:clist!*(u, env); begin scalar v; u := reverse cdr u; v := car u; for each a in cdr u do v := list('cons, a, v); return c!:cval(v, env) end; put('list!*, 'c!:code, function c!:clist!*); symbolic procedure c!:ccons(u, env); begin scalar a1, a2; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if a2 = nil or a2 = '(quote nil) or a2 = '(list) then return c!:cval(list('ncons, a1), env); if eqcar(a1, 'cons) then return c!:cval(list('acons, cadr a1, caddr a1, a2), env); if eqcar(a2, 'cons) then return c!:cval(list('list2!*, a1, cadr a2, caddr a2), env); if eqcar(a2, 'list) then return c!:cval(list('cons, a1, list('cons, cadr a2, 'list . cddr a2)), env); return c!:ccall(car u, cdr u, env) end; put('cons, 'c!:code, function c!:ccons); symbolic procedure c!:cget(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastget, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('get, 'c!:code, function c!:cget); symbolic procedure c!:cflag(u, env); begin scalar a1, a2, w, r, r1; a1 := s!:improve cadr u; a2 := s!:improve caddr u; if eqcar(a2, 'quote) and idp(w := cadr a2) and (w := symbol!-make!-fastget(w, nil)) then << r := c!:newreg(); c!:outop('fastflag, r, c!:cval(a1, env), w . cadr a2); return r >> else return c!:ccall(car u, cdr u, env) end; put('flagp, 'c!:code, function c!:cflag); symbolic procedure c!:cgetv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qgetv . cdr u, env); put('getv, 'c!:code, function c!:cgetv); !#if common!-lisp!-mode put('svref, 'c!:code, function c!:cgetv); !#endif symbolic procedure c!:cputv(u, env); if not !*fastvector then c!:ccall(car u, cdr u, env) else c!:cval('qputv . cdr u, env); put('putv, 'c!:code, function c!:cputv); symbolic procedure c!:cqputv(x, env); begin scalar rr; rr := c!:pareval(cdr x, env); c!:outop('qputv, caddr rr, car rr, cadr rr); return caddr rr end; put('qputv, 'c!:code, function c!:cqputv); symbolic procedure c!:cmacrolet(u, env); error(0, "macrolet"); put('macrolet, 'c!:code, function c!:cmacrolet); symbolic procedure c!:cmultiple_value_call(u, env); error(0, "multiple_value_call"); put('multiple!-value!-call, 'c!:code, function c!:cmultiple_value_call); symbolic procedure c!:cmultiple_value_prog1(u, env); error(0, "multiple_value_prog1"); put('multiple!-value!-prog1, 'c!:code, function c!:cmultiple_value_prog1); symbolic procedure c!:cor(u, env); begin scalar next, done, v, r; v := c!:newreg(); done := c!:my_gensym(); u := cdr u; while cdr u do << next := c!:my_gensym(); c!:outop('movr, v, nil, c!:cval(car u, env)); u := cdr u; c!:endblock(list('ifnull, v), list(next, done)); c!:startblock next >>; c!:outop('movr, v, nil, c!:cval(car u, env)); c!:endblock('goto, list done); c!:startblock done; return v end; put('or, 'c!:code, function c!:cor); symbolic procedure c!:cprog(u, env); begin scalar w, w1, bvl, local_proglabs, progret, progexit, fluids, env1; env1 := car env; bvl := cadr u; for each v in bvl do if globalp v then error(0, list(v, "attempt to bind a global")) else if fluidp v then << fluids := (v . c!:newreg()) . fluids; flag(list cdar fluids, 'c!:live_across_call); % silly if not env1 := ('c!:dummy!:name . cdar fluids) . env1; c!:outop('ldrglob, cdar fluids, v, c!:find_literal v); c!:outop('nilglob, nil, v, c!:find_literal v) >> else << env1 := (v . c!:newreg()) . env1; c!:outop('movk1, cdar env1, nil, nil) >>; if fluids then c!:outop('fluidbind, nil, nil, fluids); env := env1 . append(fluids, cdr env); u := cddr u; progret := c!:newreg(); progexit := c!:my_gensym(); blockstack := (nil . progret . progexit) . blockstack; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else c!:cval(a, env); c!:outop('movk1, progret, nil, nil); c!:endblock('goto, list progexit); c!:startblock progexit; for each v in fluids do c!:outop('strglob, cdr v, car v, c!:find_literal car v); blockstack := cdr blockstack; proglabs := cdr proglabs; return progret end; put('prog, 'c!:code, function c!:cprog); symbolic procedure c!:cprog!*(u, env); error(0, "prog*"); put('prog!*, 'c!:code, function c!:cprog!*); symbolic procedure c!:cprog1(u, env); begin scalar g; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); return c!:cval(g, env) end; put('prog1, 'c!:code, function c!:cprog1); symbolic procedure c!:cprog2(u, env); begin scalar g; u := cdr u; g := c!:my_gensym(); g := list('prog, list g, list('setq, g, cadr u), 'progn . cddr u, list('return, g)); g := list('progn, car u, g); return c!:cval(g, env) end; put('prog2, 'c!:code, function c!:cprog2); symbolic procedure c!:cprogn(u, env); begin scalar r; u := cdr u; if u = nil then u := '(nil); for each s in u do r := c!:cval(s, env); return r end; put('progn, 'c!:code, function c!:cprogn); symbolic procedure c!:cprogv(u, env); error(0, "progv"); put('progv, 'c!:code, function c!:cprogv); symbolic procedure c!:cquote(u, env); begin scalar v; u := cadr u; v := c!:newreg(); if null u or u = 't or c!:small_number u then c!:outop('movk1, v, nil, u) else c!:outop('movk, v, u, c!:find_literal u); return v; end; put('quote, 'c!:code, function c!:cquote); symbolic procedure c!:creturn(u, env); begin scalar w; w := assoc!*!*(nil, blockstack); if null w then error(0, "RETURN out of context"); c!:outop('movr, cadr w, nil, c!:cval(cadr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; put('return, 'c!:code, function c!:creturn); !#if common!-lisp!-mode symbolic procedure c!:creturn_from(u, env); begin scalar w; w := assoc!*!*(cadr u, blockstack); if null w then error(0, "RETURN-FROM out of context"); c!:outop('movr, cadr w, nil, c!:cval(caddr u, env)); c!:endblock('goto, list cddr w); return nil % value should not be used end; !#endif put('return!-from, 'c!:code, function c!:creturn_from); symbolic procedure c!:csetq(u, env); begin scalar v, w; v := c!:cval(caddr u, env); u := cadr u; if not idp u then error(0, list(u, "bad variable in setq")) else if (w := c!:locally_bound(u, env)) then c!:outop('movr, cdr w, nil, v) else if flagp(u, 'c!:constant) then error(0, list(u, "attempt to use setq on a constant")) else c!:outop('strglob, v, u, c!:find_literal u); return v end; put('setq, 'c!:code, function c!:csetq); put('noisy!-setq, 'c!:code, function c!:csetq); !#if common!-lisp!-mode symbolic procedure c!:ctagbody(u, env); begin scalar w, bvl, local_proglabs, res; u := cdr u; for each a in u do if atom a then if atsoc(a, local_proglabs) then << if not null a then << w := wrs nil; princ "+++++ multiply defined label: "; prin a; terpri(); wrs w >> >> else local_proglabs := list(a, c!:my_gensym()) . local_proglabs; proglabs := local_proglabs . proglabs; for each a in u do if atom a then << w := cdr(assoc!*!*(a, local_proglabs)); if null cdr w then << rplacd(w, t); c!:endblock('goto, list car w); c!:startblock car w >> >> else res := c!:cval(a, env); if null res then res := c!:cval(nil, env); proglabs := cdr proglabs; return res end; put('tagbody, 'c!:code, function c!:ctagbody); !#endif symbolic procedure c!:cprivate_tagbody(u, env); % This sets a label for use for tail-call to self. begin u := cdr u; c!:endblock('goto, list car u); c!:startblock car u; % This seems to be the proper place to capture the internal names associated % with argument-vars that must be reset if a tail-call is mapped into a loop. current_args := for each v in current_args collect begin scalar z; z := assoc!*!*(v, car env); return if z then cdr z else v end; return c!:cval(cadr u, env) end; put('c!:private_tagbody, 'c!:code, function c!:cprivate_tagbody); symbolic procedure c!:cthe(u, env); c!:cval(caddr u, env); put('the, 'c!:code, function c!:cthe); symbolic procedure c!:cthrow(u, env); error(0, "throw"); put('throw, 'c!:code, function c!:cthrow); symbolic procedure c!:cunless(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l2, l1); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('unless, 'c!:code, function c!:cunless); symbolic procedure c!:cunwind_protect(u, env); error(0, "unwind_protect"); put('unwind!-protect, 'c!:code, function c!:cunwind_protect); symbolic procedure c!:cwhen(u, env); begin scalar v, join, l1, l2; v := c!:newreg(); join := c!:my_gensym(); l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:cjumpif(cadr u, env, l1, l2); c!:startblock l1; c!:outop('movr, v, nil, c!:cval('progn . cddr u, env)); c!:endblock('goto, list join); c!:startblock l2; c!:outop('movk1, v, nil, nil); c!:endblock('goto, list join); c!:startblock join; return v end; put('when, 'c!:code, function c!:cwhen); % % End of code to handle special forms - what comes from here on is % more concerned with performance than with speed. % !#if (not common!-lisp!-mode) % mapcar etc are compiled specially as a fudge to achieve an effect as % if proper environment-capture was implemented for the functional % argument (which I do not support at present). symbolic procedure c!:expand_map(fnargs); begin scalar carp, fn, fn1, args, var, avar, moveon, l1, r, s, closed; fn := car fnargs; % if the value of a mapping function is not needed I demote from mapcar to % mapc or from maplist to map. % if context > 1 then << % if fn = 'mapcar then fn := 'mapc % else if fn = 'maplist then fn := 'map >>; if fn = 'mapc or fn = 'mapcar or fn = 'mapcan then carp := t; fnargs := cdr fnargs; if atom fnargs then error(0,"bad arguments to map function"); fn1 := cadr fnargs; while eqcar(fn1, 'function) or (eqcar(fn1, 'quote) and eqcar(cadr fn1, 'lambda)) do << fn1 := cadr fn1; closed := t >>; % if closed is false I will insert FUNCALL since I am invoking a function % stored in a variable - NB this means that the word FUNCTION becomes % essential when using mapping operators - this is because I have built % a 2-Lisp rather than a 1-Lisp. args := car fnargs; l1 := c!:my_gensym(); r := c!:my_gensym(); s := c!:my_gensym(); var := c!:my_gensym(); avar := var; if carp then avar := list('car, avar); if closed then fn1 := list(fn1, avar) else fn1 := list('apply1, fn1, avar); moveon := list('setq, var, list('cdr, var)); if fn = 'map or fn = 'mapc then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon), '(prog (var) (setq var args) l1 (cond ((not var) (return nil))) fn moveon (go l1))) else if fn = 'maplist or fn = 'mapcar then fn := sublis( list('l1 . l1, 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . r), '(prog (var r) (setq var args) l1 (cond ((not var) (return (reversip r)))) (setq r (cons fn r)) moveon (go l1))) else fn := sublis( list('l1 . l1, 'l2 . c!:my_gensym(), 'var . var, 'fn . fn1, 'args . args, 'moveon . moveon, 'r . c!:my_gensym(), 's . c!:my_gensym()), '(prog (var r s) (setq var args) (setq r (setq s (list nil))) l1 (cond ((not var) (return (cdr r)))) (rplacd s fn) l2 (cond ((not (atom (cdr s))) (setq s (cdr s)) (go l2))) moveon (go l1))); return fn end; put('map, 'c!:compile_macro, function c!:expand_map); put('maplist, 'c!:compile_macro, function c!:expand_map); put('mapc, 'c!:compile_macro, function c!:expand_map); put('mapcar, 'c!:compile_macro, function c!:expand_map); put('mapcon, 'c!:compile_macro, function c!:expand_map); put('mapcan, 'c!:compile_macro, function c!:expand_map); !#endif % caaar to cddddr get expanded into compositions of % car, cdr which are compiled in-line symbolic procedure c!:expand_carcdr(x); begin scalar name; name := cdr reverse cdr explode2 car x; x := cadr x; for each v in name do x := list(if v = 'a then 'car else 'cdr, x); return x end; << put('caar, 'c!:compile_macro, function c!:expand_carcdr); put('cadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdar, 'c!:compile_macro, function c!:expand_carcdr); put('cddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaar, 'c!:compile_macro, function c!:expand_carcdr); put('caadr, 'c!:compile_macro, function c!:expand_carcdr); put('cadar, 'c!:compile_macro, function c!:expand_carcdr); put('caddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdadr, 'c!:compile_macro, function c!:expand_carcdr); put('cddar, 'c!:compile_macro, function c!:expand_carcdr); put('cdddr, 'c!:compile_macro, function c!:expand_carcdr); put('caaaar, 'c!:compile_macro, function c!:expand_carcdr); put('caaadr, 'c!:compile_macro, function c!:expand_carcdr); put('caadar, 'c!:compile_macro, function c!:expand_carcdr); put('caaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cadaar, 'c!:compile_macro, function c!:expand_carcdr); put('cadadr, 'c!:compile_macro, function c!:expand_carcdr); put('caddar, 'c!:compile_macro, function c!:expand_carcdr); put('cadddr, 'c!:compile_macro, function c!:expand_carcdr); put('cdaaar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdadar, 'c!:compile_macro, function c!:expand_carcdr); put('cdaddr, 'c!:compile_macro, function c!:expand_carcdr); put('cddaar, 'c!:compile_macro, function c!:expand_carcdr); put('cddadr, 'c!:compile_macro, function c!:expand_carcdr); put('cdddar, 'c!:compile_macro, function c!:expand_carcdr); put('cddddr, 'c!:compile_macro, function c!:expand_carcdr) >>; symbolic procedure c!:builtin_one(x, env); begin scalar r1, r2; r1 := c!:cval(cadr x, env); c!:outop(car x, r2:=c!:newreg(), cdr env, r1); return r2 end; symbolic procedure c!:builtin_two(x, env); begin scalar a1, a2, r, rr; a1 := cadr x; a2 := caddr x; rr := c!:pareval(list(a1, a2), env); c!:outop(car x, r:=c!:newreg(), car rr, cadr rr); return r end; symbolic procedure c!:narg(x, env); c!:cval(expand(cdr x, get(car x, 'c!:binary_version)), env); for each n in '((plus plus2) (times times2) (iplus iplus2) (itimes itimes2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#if common!-lisp!-mode for each n in '((!+ plus2) (!* times2)) do << put(car n, 'c!:binary_version, cadr n); put(car n, 'c!:code, function c!:narg) >>; !#endif symbolic procedure c!:cplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('add1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('add1, a), env) else if b = -1 then c!:cval(list('sub1, a), env) else c!:ccall(car u, cdr u, env) end; put('plus2, 'c!:code, function c!:cplus2); symbolic procedure c!:ciplus2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a+b, env) else if a = 0 then c!:cval(b, env) else if a = 1 then c!:cval(list('iadd1, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('iadd1, a), env) else if b = -1 then c!:cval(list('isub1, a), env) else c!:builtin_two(u, env) end; put('iplus2, 'c!:code, function c!:ciplus2); symbolic procedure c!:cdifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('minus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('sub1, a), env) else if b = -1 then c!:cval(list('add1, a), env) else c!:ccall(car u, cdr u, env) end; put('difference, 'c!:code, function c!:cdifference); symbolic procedure c!:cidifference(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a-b, env) else if a = 0 then c!:cval(list('iminus, b), env) else if b = 0 then c!:cval(a, env) else if b = 1 then c!:cval(list('isub1, a), env) else if b = -1 then c!:cval(list('iadd1, a), env) else c!:builtin_two(u, env) end; put('idifference, 'c!:code, function c!:cidifference); symbolic procedure c!:ctimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('minus, b), env) else if b = -1 then c!:cval(list('minus, a), env) else c!:ccall(car u, cdr u, env) end; put('times2, 'c!:code, function c!:ctimes2); symbolic procedure c!:citimes2(u, env); begin scalar a, b; a := s!:improve cadr u; b := s!:improve caddr u; return if numberp a and numberp b then c!:cval(a*b, env) else if a = 0 or b = 0 then c!:cval(0, env) else if a = 1 then c!:cval(b, env) else if b = 1 then c!:cval(a, env) else if a = -1 then c!:cval(list('iminus, b), env) else if b = -1 then c!:cval(list('iminus, a), env) else c!:builtin_two(u, env) end; put('itimes2, 'c!:code, function c!:citimes2); symbolic procedure c!:cminus(u, env); begin scalar a, b; a := s!:improve cadr u; return if numberp a then c!:cval(-a, env) else if eqcar(a, 'minus) then c!:cval(cadr a, env) else c!:ccall(car u, cdr u, env) end; put('minus, 'c!:code, function c!:cminus); symbolic procedure c!:ceq(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop('eq, r:=c!:newreg(), car rr, cadr rr); return r end; put('eq, 'c!:code, function c!:ceq); symbolic procedure c!:cequal(x, env); begin scalar a1, a2, r, rr; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cval(list('null, a2), env) else if a2 = nil then return c!:cval(list('null, a1), env); rr := c!:pareval(list(a1, a2), env); c!:outop((if c!:eqvalid a1 or c!:eqvalid a2 then 'eq else 'equal), r:=c!:newreg(), car rr, cadr rr); return r end; put('equal, 'c!:code, function c!:cequal); % % The next few cases are concerned with demoting functions that use % equal tests into ones that use eq instead symbolic procedure c!:is_fixnum x; fixp x and x >= -134217728 and x <= 134217727; symbolic procedure c!:certainlyatom x; null x or x=t or c!:is_fixnum x or (eqcar(x, 'quote) and (symbolp cadr x or c!:is_fixnum cadr x)); symbolic procedure c!:atomlist1 u; atom u or ((symbolp car u or c!:is_fixnum car u) and c!:atomlist1 cdr u); symbolic procedure c!:atomlist x; null x or (eqcar(x, 'quote) and c!:atomlist1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:certainlyatom cadr x and c!:atomlist ('list . cddr x)))) or (eqcar(x, 'cons) and c!:certainlyatom cadr x and c!:atomlist caddr x); symbolic procedure c!:atomcar x; (eqcar(x, 'cons) or eqcar(x, 'list)) and not null cdr x and c!:certainlyatom cadr x; symbolic procedure c!:atomkeys1 u; atom u or (not atom car u and (symbolp caar u or c!:is_fixnum caar u) and c!:atomlist1 cdr u); symbolic procedure c!:atomkeys x; null x or (eqcar(x, 'quote) and c!:atomkeys1 cadr x) or (eqcar(x, 'list) and (null cdr x or (c!:atomcar cadr x and c!:atomkeys ('list . cddr x)))) or (eqcar(x, 'cons) and c!:atomcar cadr x and c!:atomkeys caddr x); !#if (not common!-lisp!-mode) symbolic procedure c!:comsublis x; if c!:atomkeys cadr x then 'subla . cdr x else nil; put('sublis, 'c!:compile_macro, function c!:comsublis); symbolic procedure c!:comassoc x; if c!:certainlyatom cadr x or c!:atomkeys caddr x then 'atsoc . cdr x else nil; put('assoc, 'c!:compile_macro, function c!:comassoc); put('assoc!*!*, 'c!:compile_macro, function c!:comassoc); symbolic procedure c!:commember x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'memq . cdr x else nil; put('member, 'c!:compile_macro, function c!:commember); symbolic procedure c!:comdelete x; if c!:certainlyatom cadr x or c!:atomlist caddr x then 'deleq . cdr x else nil; put('delete, 'c!:compile_macro, function c!:comdelete); !#endif symbolic procedure c!:ctestif(x, env, d1, d2); begin scalar l1, l2; l1 := c!:my_gensym(); l2 := c!:my_gensym(); c!:jumpif(cadr x, l1, l2); x := cddr x; c!:startblock l1; c!:jumpif(car x, d1, d2); c!:startblock l2; c!:jumpif(cadr x, d1, d2) end; put('if, 'c!:ctest, function c!:ctestif); symbolic procedure c!:ctestnull(x, env, d1, d2); c!:cjumpif(cadr x, env, d2, d1); put('null, 'c!:ctest, function c!:ctestnull); put('not, 'c!:ctest, function c!:ctestnull); symbolic procedure c!:ctestatom(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d1, d2)) end; put('atom, 'c!:ctest, function c!:ctestatom); symbolic procedure c!:ctestconsp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifatom, x), list(d2, d1)) end; put('consp, 'c!:ctest, function c!:ctestconsp); symbolic procedure c!:ctestsymbol(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifsymbol, x), list(d1, d2)) end; put('idp, 'c!:ctest, function c!:ctestsymbol); symbolic procedure c!:ctestnumberp(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifnumber, x), list(d1, d2)) end; put('numberp, 'c!:ctest, function c!:ctestnumberp); symbolic procedure c!:ctestizerop(x, env, d1, d2); begin x := c!:cval(cadr x, env); c!:endblock(list('ifizerop, x), list(d1, d2)) end; put('izerop, 'c!:ctest, function c!:ctestizerop); symbolic procedure c!:ctesteq(x, env, d1, d2); begin scalar a1, a2, r; a1 := cadr x; a2 := caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock('ifeq . r, list(d1, d2)) end; put('eq, 'c!:ctest, function c!:ctesteq); symbolic procedure c!:ctesteqcar(x, env, d1, d2); begin scalar a1, a2, r, d3; a1 := cadr x; a2 := caddr x; d3 := c!:my_gensym(); r := c!:pareval(list(a1, a2), env); c!:endblock(list('ifatom, car r), list(d2, d3)); c!:startblock d3; c!:outop('qcar, car r, nil, car r); c!:endblock('ifeq . r, list(d1, d2)) end; put('eqcar, 'c!:ctest, function c!:ctesteqcar); global '(least_fixnum greatest_fixnum); least_fixnum := -expt(2, 27); greatest_fixnum := expt(2, 27) - 1; symbolic procedure c!:small_number x; fixp x and x >= least_fixnum and x <= greatest_fixnum; symbolic procedure c!:eqvalid x; if atom x then c!:small_number x else if flagp(car x, 'c!:fixnum_fn) then t else car x = 'quote and (idp cadr x or c!:small_number cadr x); flag('(iplus iplus2 idifference iminus itimes itimes2), 'c!:fixnum_fn); symbolic procedure c!:ctestequal(x, env, d1, d2); begin scalar a1, a2, r; a1 := s!:improve cadr x; a2 := s!:improve caddr x; if a1 = nil then return c!:cjumpif(a2, env, d2, d1) else if a2 = nil then return c!:cjumpif(a1, env, d2, d1); r := c!:pareval(list(a1, a2), env); c!:endblock((if c!:eqvalid a1 or c!:eqvalid a2 then 'ifeq else 'ifequal) . r, list(d1, d2)) end; put('equal, 'c!:ctest, function c!:ctestequal); symbolic procedure c!:ctestilessp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifilessp . r, list(d1, d2)) end; put('ilessp, 'c!:ctest, function c!:ctestilessp); symbolic procedure c!:ctestigreaterp(x, env, d1, d2); begin scalar r; r := c!:pareval(list(cadr x, caddr x), env); c!:endblock('ifigreaterp . r, list(d1, d2)) end; put('igreaterp, 'c!:ctest, function c!:ctestigreaterp); symbolic procedure c!:ctestand(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, next, d2); c!:startblock next >>; c!:endblock('goto, list d1) end; put('and, 'c!:ctest, function c!:ctestand); symbolic procedure c!:ctestor(x, env, d1, d2); begin scalar next; for each a in cdr x do << next := c!:my_gensym(); c!:cjumpif(a, env, d1, next); c!:startblock next >>; c!:endblock('goto, list d2) end; put('or, 'c!:ctest, function c!:ctestor); % Here are some of the things that are built into the Lisp kernel % and that I am happy to allow the compiler to generate direct calls to. << % % In these tables there are some functions that would need adjusting % for a Common Lisp compiler, since they take different numbers of % args in Common and Standard Lisp. % This means, to be specific: % % Lgensym Lread Latan Ltruncate Lfloat % Lintern Lmacroexpand Lmacroexpand_1 % Lrandom Lunintern Lappend Leqn Lgcd % Lgeq Lgreaterp Llcm Lleq Llessp % Lquotient % % In these cases (at least!) the Common Lisp version of the compiler will % need to avoid generating the call that uses this table. % % Some functions are missing from the list here because they seemed % critical enough to be awarded single-byte opcodes or because the % compiler always expands them away - car through cddddr are the main % cases, together with eq and equal. % put('batchp, 'zero_arg_fn, 0); put('date, 'zero_arg_fn, 1); put('eject, 'zero_arg_fn, 2); put('error0, 'zero_arg_fn, 3); put('gctime, 'zero_arg_fn, 4); put('gensym, 'zero_arg_fn, 5); put('lposn, 'zero_arg_fn, 6); put('next!-random, 'zero_arg_fn, 7); put('posn, 'zero_arg_fn, 8); put('read, 'zero_arg_fn, 9); put('readch, 'zero_arg_fn, 10); put('terpri, 'zero_arg_fn, 11); put('time, 'zero_arg_fn, 12); put('tyi, 'zero_arg_fn, 13); put('load!-spid, 'zero_arg_fn, 14); % ONLY used in compiled code put('absval, 'one_arg_fn, 0); put('add1, 'one_arg_fn, 1); put('atan, 'one_arg_fn, 2); put('apply0, 'one_arg_fn, 3); put('atom, 'one_arg_fn, 4); put('boundp, 'one_arg_fn, 5); put('char!-code, 'one_arg_fn, 6); put('close, 'one_arg_fn, 7); put('codep, 'one_arg_fn, 8); put('compress, 'one_arg_fn, 9); put('constantp, 'one_arg_fn, 10); put('digitp, 'one_arg_fn, 11); put('endp, 'one_arg_fn, 12); put('eval, 'one_arg_fn, 13); put('evenp, 'one_arg_fn, 14); put('evlis, 'one_arg_fn, 15); put('explode, 'one_arg_fn, 16); put('explode2lc, 'one_arg_fn, 17); put('explodec, 'one_arg_fn, 18); put('fixp, 'one_arg_fn, 19); put('float, 'one_arg_fn, 20); put('floatp, 'one_arg_fn, 21); put('symbol!-specialp, 'one_arg_fn, 22); put('gc, 'one_arg_fn, 23); put('gensym1, 'one_arg_fn, 24); put('getenv, 'one_arg_fn, 25); put('symbol!-globalp, 'one_arg_fn, 26); put('iadd1, 'one_arg_fn, 27); put('symbolp, 'one_arg_fn, 28); put('iminus, 'one_arg_fn, 29); put('iminusp, 'one_arg_fn, 30); put('indirect, 'one_arg_fn, 31); put('integerp, 'one_arg_fn, 32); put('intern, 'one_arg_fn, 33); put('isub1, 'one_arg_fn, 34); put('length, 'one_arg_fn, 35); put('lengthc, 'one_arg_fn, 36); put('linelength, 'one_arg_fn, 37); put('alpha!-char!-p, 'one_arg_fn, 38); put('load!-module, 'one_arg_fn, 39); put('lognot, 'one_arg_fn, 40); put('macroexpand, 'one_arg_fn, 41); put('macroexpand!-1, 'one_arg_fn, 42); put('macro!-function, 'one_arg_fn, 43); put('get!-bps, 'one_arg_fn, 44); put('make!-global, 'one_arg_fn, 45); put('smkvect, 'one_arg_fn, 46); put('make!-special, 'one_arg_fn, 47); put('minus, 'one_arg_fn, 48); put('minusp, 'one_arg_fn, 49); put('mkvect, 'one_arg_fn, 50); put('modular!-minus, 'one_arg_fn, 51); put('modular!-number, 'one_arg_fn, 52); put('modular!-reciprocal, 'one_arg_fn, 53); put('null, 'one_arg_fn, 54); put('oddp, 'one_arg_fn, 55); put('onep, 'one_arg_fn, 56); put('pagelength, 'one_arg_fn, 57); put('consp, 'one_arg_fn, 58); put('plist, 'one_arg_fn, 59); put('plusp, 'one_arg_fn, 60); put('prin, 'one_arg_fn, 61); put('princ, 'one_arg_fn, 62); put('print, 'one_arg_fn, 63); put('printc, 'one_arg_fn, 64); put('random, 'one_arg_fn, 65); put('rational, 'one_arg_fn, 66); put('rdf1, 'one_arg_fn, 67); put('rds, 'one_arg_fn, 68); put('remd, 'one_arg_fn, 69); put('reverse, 'one_arg_fn, 70); put('nreverse, 'one_arg_fn, 71); put('whitespace!-char!-p, 'one_arg_fn, 72); put('set!-small!-modulus, 'one_arg_fn, 73); put('xtab, 'one_arg_fn, 74); put('special!-char, 'one_arg_fn, 75); put('special!-form!-p, 'one_arg_fn, 76); put('spool, 'one_arg_fn, 77); put('stop, 'one_arg_fn, 78); put('stringp, 'one_arg_fn, 79); put('sub1, 'one_arg_fn, 80); put('symbol!-env, 'one_arg_fn, 81); put('symbol!-function, 'one_arg_fn, 82); put('symbol!-name, 'one_arg_fn, 83); put('symbol!-value, 'one_arg_fn, 84); put('system, 'one_arg_fn, 85); put('truncate, 'one_arg_fn, 86); put('ttab, 'one_arg_fn, 87); put('tyo, 'one_arg_fn, 88); put('unintern, 'one_arg_fn, 89); put('unmake!-global, 'one_arg_fn, 90); put('unmake!-special, 'one_arg_fn, 91); put('upbv, 'one_arg_fn, 92); put('simple!-vectorp, 'one_arg_fn, 93); put('verbos, 'one_arg_fn, 94); put('wrs, 'one_arg_fn, 95); put('zerop, 'one_arg_fn, 96); put('car, 'one_arg_fn, 97); put('cdr, 'one_arg_fn, 98); put('caar, 'one_arg_fn, 99); put('cadr, 'one_arg_fn, 100); put('cdar, 'one_arg_fn, 101); put('cddr, 'one_arg_fn, 102); put('car, 'one_arg_fn, 103); % Really QCAR (unchecked) put('cdr, 'one_arg_fn, 104); put('caar, 'one_arg_fn, 105); put('cadr, 'one_arg_fn, 106); put('cdar, 'one_arg_fn, 107); put('cddr, 'one_arg_fn, 108); put('ncons, 'one_arg_fn, 109); put('numberp, 'one_arg_fn, 110); put('is!-spid, 'one_arg_fn, 111); % ONLY used in compiled code put('spid!-to!-nil, 'one_arg_fn, 112); % ONLY used in compiled code put('mv!-list, 'one_arg_fn, 113); % ONLY used in compiled code put('append, 'two_arg_fn, 0); put('ash, 'two_arg_fn, 1); put('assoc, 'two_arg_fn, 2); put('atsoc, 'two_arg_fn, 3); put('deleq, 'two_arg_fn, 4); put('delete, 'two_arg_fn, 5); put('divide, 'two_arg_fn, 6); put('eqcar, 'two_arg_fn, 7); put('eql, 'two_arg_fn, 8); put('eqn, 'two_arg_fn, 9); put('expt, 'two_arg_fn, 10); put('flag, 'two_arg_fn, 11); put('flagpcar, 'two_arg_fn, 12); put('gcd, 'two_arg_fn, 13); put('geq, 'two_arg_fn, 14); put('getv, 'two_arg_fn, 15); put('greaterp, 'two_arg_fn, 16); put('idifference, 'two_arg_fn, 17); put('igreaterp, 'two_arg_fn, 18); put('ilessp, 'two_arg_fn, 19); put('imax, 'two_arg_fn, 20); put('imin, 'two_arg_fn, 21); put('iplus2, 'two_arg_fn, 22); put('iquotient, 'two_arg_fn, 23); put('iremainder, 'two_arg_fn, 24); put('irightshift, 'two_arg_fn, 25); put('itimes2, 'two_arg_fn, 26); put('lcm, 'two_arg_fn, 27); put('leq, 'two_arg_fn, 28); put('lessp, 'two_arg_fn, 29); put('make!-random!-state, 'two_arg_fn, 30); put('max2, 'two_arg_fn, 31); put('member, 'two_arg_fn, 32); put('memq, 'two_arg_fn, 33); put('min2, 'two_arg_fn, 34); put('mod, 'two_arg_fn, 35); put('modular!-difference, 'two_arg_fn, 36); put('modular!-expt, 'two_arg_fn, 37); put('modular!-plus, 'two_arg_fn, 38); put('modular!-quotient, 'two_arg_fn, 39); put('modular!-times, 'two_arg_fn, 40); put('nconc, 'two_arg_fn, 41); put('neq, 'two_arg_fn, 42); put('orderp, 'two_arg_fn, 43); put('quotient, 'two_arg_fn, 44); put('rem, 'two_arg_fn, 45); put('remflag, 'two_arg_fn, 46); put('remprop, 'two_arg_fn, 47); put('rplaca, 'two_arg_fn, 48); put('rplacd, 'two_arg_fn, 49); put('sgetv, 'two_arg_fn, 50); put('set, 'two_arg_fn, 51); put('smemq, 'two_arg_fn, 52); put('subla, 'two_arg_fn, 53); put('sublis, 'two_arg_fn, 54); put('symbol!-set!-definition, 'two_arg_fn, 55); put('symbol!-set!-env, 'two_arg_fn, 56); put('times2, 'two_arg_fn, 57); put('xcons, 'two_arg_fn, 58); put('equal, 'two_arg_fn, 59); put('eq, 'two_arg_fn, 60); put('cons, 'two_arg_fn, 61); put('list2, 'two_arg_fn, 62); put('get, 'two_arg_fn, 63); put('getv, 'two_arg_fn, 64); % QGETV put('flagp, 'two_arg_fn, 65); put('apply1, 'two_arg_fn, 66); put('difference2, 'two_arg_fn, 67); put('plus2, 'two_arg_fn, 68); put('times2, 'two_arg_fn, 69); put('bpsputv, 'three_arg_fn, 0); put('errorsetn, 'three_arg_fn, 1); put('list2star, 'three_arg_fn, 2); put('list3, 'three_arg_fn, 3); put('putprop, 'three_arg_fn, 4); put('putv, 'three_arg_fn, 5); put('sputv, 'three_arg_fn, 6); put('subst, 'three_arg_fn, 7); put('apply2, 'three_arg_fn, 8); put('acons, 'three_arg_fn, 9); "native entrypoints established" >>; flag( '(atom atsoc codep constantp deleq digit endp eq eqcar evenp eql fixp flagp flagpcar floatp get globalp iadd1 idifference idp igreaterp ilessp iminus iminusp indirect integerp iplus2 irightshift isub1 itimes2 liter memq minusp modular!-difference modular!-expt modular!-minus modular!-number modular!-plus modular!-times not null numberp onep pairp plusp qcaar qcadr qcar qcdar qcddr qcdr remflag remprop reversip seprp special!-form!-p stringp symbol!-env symbol!-name symbol!-value threevectorp vectorp zerop), 'c!:no_errors); end; % End of i86comp.red mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checkall.red0000644000175000017500000000043411550002751024015 0ustar giovannigiovanni% % This script is normally run as % r38 ../util/checkall.red -D@srcdir=DIR -Dwhich_module=XXX % where XXX is the name of a module that is to be checked. If XXX is left % empty then the script will check all known modules. % load!-module 'remake; lisp check_a_package(); end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/recompile.red0000755000175000017500000000131011550002751024223 0ustar giovannigiovanni% % This script is normally run via % make recompile which=modulename % or make bootstraprecompile which=modulename % symbolic; load!-module 'remake; get_configuration_data(); fluid '(!*forcecompile); !*forcecompile := t; % Ignore date-stamps and force compilation to happen if boundp 'which and which and not (which = "") then << mods := compress explodec which; if member(mods, reduce_base_modules) or member(mods, reduce_extra_modules) then build_reduce_modules list mods else error(0, list("unknown module to recompile", mods)) >> else << terpri(); printc "Must specify which module should be recompiled, eg"; printc " make recompile which=modulename"; stop 8 >>; end; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/profile.red0000644000175000017500000000064011550002751023706 0ustar giovannigiovanni% Collect profile information about all REDUCE modules that have % associated test scripts. The information is put in "profile.dat" % in the current directory but you then probably want to move it up % to the place it really lives. This step is not automated here at % present. symbolic; load!-module 'remake; get_configuration_data(); delete!-file "profile.dat"; profile_a_package reduce_test_cases; bye; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/rlisp.lsp0000644000175000017500000033531411550002751023434 0ustar giovannigiovanni; ; Create RLISP. Use this via mkrlisp0.lsp or mkrlisp1.lsp ; ; Standard LISP equivalent of BOOT.RED. (proclaim '(special *blockp *mode)) (proclaim '(special oldchan*)) (proclaim '(special crchar* cursym* fname* nxtsym* ttype* $eol$ !$eof!$)) (setq *blockp nil) (setq *mode nil) (setq oldchan* nil) (setq crchar* nil) (setq cursym* nil) (setq fname* nil) (setq nxtsym* nil) (setq ttype* nil) (defun compress (l) (prog (r c) (setq c (car l)) (if (or (eq c '|"|) (digit c)) (return (compress1 l))) (while l (setq c (car l)) (setq l (cdr l)) (when (eq c '|!|) (setq c (car l)) (setq l (cdr l))) (setq r (cons c (cons '|\\| r)))) (return (compress1 (nreverse r))))) (setq $eol$ (compress1 (list '|\\| (special-char 1)))) (setq $eof$ (special-char 8)) (put '|;| 'switch* '(nil *semicol*)) (put '|(| 'switch* '(nil *lpar*)) (put '|)| 'switch* '(nil *rpar*)) (put '|,| 'switch* '(nil *comma*)) (put '|.| 'switch* '(nil cons)) (put '|:| 'switch* '(((= nil setq)) *colon*)) (put '*comma* 'infix 1) (put 'setq 'infix 2) (put 'cons 'infix 3) (flag '(*comma*) 'nary) (flag '(*colon* *semicol* end then else) 'delim) (put 'begin 'stat 'blockstat) (put 'if 'stat 'ifstat) (put 'symbolic 'stat 'procstat) (de begin2 nil (prog nil (setq cursym* '*semicol*) a (cond ((eq cursym* 'end) (progn (rds oldchan*) (return nil))) (t (prin2 (errorset '(eval (form (xread nil))) t t)) )) (go a))) (de form (u) u) (de xread (u) (progn (scan) (xread1 u))) (de xread1 (u) (prog (v w x y z z2) a (setq z cursym*) a1 (cond ((or (null (atom z)) (numberp z)) (setq y nil)) ((flagp z 'delim) (go end1)) ((eq z '*lpar*) (go lparen)) ((eq z '*rpar*) (go end1)) ((setq y (get z 'infix)) (go infx)) ((setq y (get z 'stat)) (go stat))) a3 (setq w (cons z w)) next (setq z (scan)) (go a1) lparen(setq y nil) (cond ((eq (scan) '*rpar*) (and w (setq w (cons (list (car w)) (cdr w)))) ) ((eqcar (setq z (xread1 'paren)) '*comma*) (setq w (cons (cons (car w) (cdr z)) (cdr w)))) (t (go a3))) (go next) infx (setq z2 (mkvar (car w) z)) un1 (setq w (cdr w)) (cond ((null w) (go un2)) (t (setq z2 (cons (car w) (list z2)))) ) (go un1) un2 (setq v (cons z2 v)) preced(cond ((null x) (go pr4)) ((lessp y (car (car x))) (go pr2))) pr1 (setq x (cons (cons y z) x)) (go next) pr2 (setq v (cons (cond ((and (eqcar (car v) (cdar x)) (flagp (cdar x) 'nary)) (cons (cdar x) (cons (cadr v) (cdar v)))) (t (cons (cdar x) (list (cadr v) (car v)))) ) (cdr (cdr v)))) (setq x (cdr x)) (go preced) stat (setq w (cons (eval (list y)) w)) (setq y nil) (go a) end1 (cond ((and (and (null v) (null w)) (null x)) (return nil)) (t (setq y 0))) (go infx) pr4 (cond ((null (equal y 0)) (go pr1)) (t (return (car v)))) )) (de eqcar (u v) (and (null (atom u)) (eq (car u) v))) (de mksetq (u v) (list 'setq u v)) (de mkvar (u v) u) (de rread nil (prog (x) (setq x (token)) (return (cond ((and (equal ttype* 3) (eq x '|(|)) (rrdls)) (t x)))) ) (de reverse2 (a b) (prog nil a (cond ((null a) (return b))) (setq b (cons (car a) b)) (setq a (cdr a)))) (de rrdls nil (prog (x r) a (setq x (rread)) (cond ((null (equal ttype* 3)) (go b)) ((eq x '|)|) (return (reversip r))) ((null (eq x '|.|)) (go b))) (setq x (rread)) (token) (return (reverse2 r x)) b (setq r (cons x r)) (go a))) (de token nil (prog (x y) (setq x crchar*) a (cond ((seprp x) (go sepr)) ((digit x) (go number)) ((liter x) (go letter)) ((eq x '|%|) (go coment)) ((eq x '|!|) (go escape)) ((eq x '|'|) (go quote)) ((eq x '|"|) (go string))) (setq ttype* 3) (cond ((delcp x) (go d))) (setq nxtsym* x) a1 (setq crchar* (readch)) (go c) escape(setq y (cons x y)) (setq x (readch)) letter(setq ttype* 0) let1 (setq y (cons x y)) (cond ((or (digit (setq x (readch))) (liter x)) (go let1)) ((eq x '|!|) (go escape))) (setq nxtsym* (intern (compress (reverse y)))) b (setq crchar* x) c (return nxtsym*) number(setq ttype* 2) num1 (setq y (cons x y)) (cond ((digit (setq x (readch))) (go num1))) (setq nxtsym* (compress (reverse y))) (go b) quote (setq crchar* (readch)) (setq nxtsym* (list 'quote (rread))) (setq ttype* 4) (go c) string(prog (raise) (setq raise *raise) (setq *raise nil) strinx(setq y (cons x y)) (cond ((null (eq (setq x (readch)) '|"|)) (go strinx))) (setq y (cons x y)) (setq nxtsym* (mkstrng (compress (reverse y)))) (setq *raise raise)) (setq ttype* 1) (go a1) coment(cond ((null (eq (readch) $eol$)) (go coment))) sepr (setq x (readch)) (go a) d (setq nxtsym* x) (setq crchar* '| |) (go c))) (setq crchar* '| |) (de delcp (u) (or (eq u '|;|) (eq u '|$|))) (de mkstrng (u) u) (de scan nil (prog (x y) (cond ((null (eq cursym* '*semicol*)) (go b))) a (setq nxtsym* (token)) b (cond ((or (null (atom nxtsym*)) (numberp nxtsym*)) (go l)) ((and (setq x (get nxtsym* 'newnam)) (setq nxtsym* x)) (go b)) ((eq nxtsym* 'comment) (go comm)) ((and (eq nxtsym* '|'|) (setq cursym* (list 'quote (rread)))) (go l1)) ((null (setq x (get nxtsym* 'switch*))) (go l)) ((eq (cadr x) '*semicol*) (return (setq cursym* (cadr x)))) ) sw1 (setq nxtsym* (token)) (cond ((or (null (car x)) (null (setq y (assoc nxtsym* (car x)))) ) (return (setq cursym* (cadr x)))) ) (setq x (cdr y)) (go sw1) comm (cond ((eq (readch) '|;|) (setq crchar* '| |)) (t (go comm))) (go a) l (setq cursym* (cond ((null (eqcar nxtsym* 'string)) nxtsym*) (t (cons 'quote (cdr nxtsym*)))) ) l1 (setq nxtsym* (token)) (return cursym*))) (de ifstat nil (prog (condx condit) a (setq condx (xread t)) (setq condit (nconc condit (list (list condx (xread t)))) ) (cond ((null (eq cursym* 'else)) (go b)) ((eq (scan) 'if) (go a)) (t (setq condit (nconc condit (list (list t (xread1 t)))) ))) b (return (cons 'cond condit)))) (de procstat nil (prog (x y) (cond ((eq cursym* 'symbolic) (scan))) (cond ((eq cursym* '*semicol*) (return (null (setq *mode 'symbolic)))) ) (setq fname* (scan)) (cond ((atom (setq x (xread1 nil))) (setq x (list x)))) (setq y (xread nil)) (cond ((flagp (car x) 'lose) (return nil))) (putd (car x) 'expr (list 'lambda (cdr x) y)) (setq fname* nil) (return (list 'quote (car x)))) ) (de blockstat nil (prog (x hold varlis *blockp) a0 (setq *blockp t) (scan) (cond ((null (or (eq cursym* 'integer) (eq cursym* 'scalar))) (go a))) (setq x (xread nil)) (setq varlis (nconc (cond ((eqcar x '*comma*) (cdr x)) (t (list x))) varlis)) (go a0) a (setq hold (nconc hold (list (xread1 nil)))) (setq x cursym*) (scan) (cond ((not (eq x 'end)) (go a))) (return (mkprog varlis hold)))) (de mkprog (u v) (cons 'prog (cons u v))) (de gostat nil (prog (x) (scan) (setq x (scan)) (scan) (return (list 'go x)))) (put 'go 'stat 'gostat) (de rlis nil (prog (x) (setq x cursym*) (return (cond ((not (flagp (scan) 'delim)) (list x (list 'quote (list (xread1 t))))) (t (list x)))))) (begin2) % % This file is "rlisp.red" taken from the REDUCE 3.3 sources, and can be % used to reconstruct the CSL files compiler.lsp and ccomp.lsp from % the associated RLISP source files. % % module module; % Support for module use. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(exportslist!* importslist!* module!-name!* old!-mode!*); !*mode := 'symbolic; % initial value. symbolic procedure exports u; begin exportslist!* := union(u,exportslist!*); end; symbolic procedure imports u; begin importslist!* := union(u,importslist!*); end; symbolic procedure module u; %Sets up a module definition; begin if null module!-name!* then old!-mode!* := !*mode; module!-name!* := car u . module!-name!*; !*mode := 'symbolic end; symbolic procedure endmodule; begin if null module!-name!* then rederr "ENDMODULE called outside module"; exportslist!* := nil; importslist!* := nil; module!-name!* := cdr module!-name!*; if module!-name!* then return nil; !*mode := old!-mode!*; old!-mode!* := nil end; deflist('((exports rlis) (imports rlis) (module rlis)),'stat); if null get('endmodule, 'stat) then put('endmodule,'stat,'rlis); % For bootstrap only flag('(endmodule),'go); % endmodule; module newtok; % Functions for introducing infix tokens to the system. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*redeflg!*); global '(!*msg preclis!*); %Several operators in REDUCE are used in an infix form (e.g., %+,- ). The internal alphanumeric names associated with these %operators are introduced by the function NEWTOK defined below. %This association, and the precedence of each infix operator, is %initialized in this section. We also associate printing characters %with each internal alphanumeric name as well; preclis!*:= '(or and not member memq equal neq eq geq greaterp leq lessp freeof plus difference times quotient expt cons); deflist ('( (not not) (plus plus) (difference minus) (minus minus) (times times) (quotient recip) (recip recip) ), 'unary); flag ('(and or !*comma!* plus times),'nary); flag ('(cons setq plus times),'right); deflist ('((minus plus) (recip times)),'alt); symbolic procedure mkprec; begin scalar x,y,z; x := 'where . ('!*comma!* . ('setq . preclis!*)); y := 1; a: if null x then return nil; put(car x,'infix,y); put(car x,'op,list list(y,y)); %for RPRINT; if z := get(car x,'unary) then put(z,'infix,y); if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y)); x := cdr x; y := add1 y; go to a end; mkprec(); symbolic procedure newtok u; begin scalar !*redeflg!*,x,y; if atom u or atom car u or null idp caar u then typerr(u,"NEWTOK argument"); % set up SWITCH* property. put(caar u,'switch!*, cdr newtok1(car u,cadr u,get(caar u,'switch!*))); % set up PRTCH property. y := intern compress consescc car u; if !*redeflg!* then lprim list(y,"redefined"); put(cadr u,'prtch,y); if x := get(cadr u,'unary) then put(x,'prtch,y) end; symbolic procedure newtok1(charlist,name,propy); if null propy then lstchr(charlist,name) else if null cdr charlist then begin if cdr propy and !*msg then !*redeflg!* := t; return list(car charlist,car propy,name) end else car charlist . newtok2(cdr charlist,name,car propy) . cdr propy; symbolic procedure newtok2(charlist,name,assoclist); if null assoclist then list lstchr(charlist,name) else if car charlist eq caar assoclist then newtok1(charlist,name,cdar assoclist) . cdr assoclist else car assoclist . newtok2(charlist,name,cdr assoclist); symbolic procedure consescc u; if null u then nil else '!! . car u . consescc cdr u; symbolic procedure lstchr(u,v); if null cdr u then list(car u,nil,v) else list(car u,list lstchr(cdr u,v)); newtok '((!$) !*semicol!*); newtok '((!;) !*semicol!*); newtok '((!+) plus); newtok '((!-) difference); newtok '((!*) times); newtok '((!^) expt); newtok '((!* !*) expt); newtok '((!/) quotient); newtok '((!=) equal); newtok '((!,) !*comma!*); newtok '((!() !*lpar!*); newtok '((!)) !*rpar!*); newtok '((!:) !*colon!*); newtok '((!: !=) setq); newtok '((!.) cons); newtok '((!<) lessp); newtok '((!< !=) leq); newtok '((!< !<) !*lsqb!*); newtok '((!>) greaterp); newtok '((!> !=) geq); newtok '((!> !>) !*rsqb!*); put('expt,'prtch,'!*!*); % To ensure that FORTRAN output is correct. flag('(difference minus plus setq),'spaced); flag('(newtok),'eval); endmodule; module support; % Basic functions needed to support RLISP and REDUCE. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure aconc(u,v); %adds element v to the tail of u. u is destroyed in process; nconc(u,list v); symbolic procedure r!-arrayp u; get(u,'rtype) eq 'array; symbolic procedure idlistp u; % True if u is a list of id's. null u or null atom u and idp car u and idlistp cdr u; symbolic procedure mkprog(u,v); 'prog . (u . v); symbolic procedure mksetq(u,v); list('setq,u,v); symbolic procedure pairvars(u,vars,mode); % Sets up pairings of parameters and modes. begin scalar x; a: if null u then return append(reversip!* x,vars) else if null idp car u then symerr("Invalid parameter",nil); x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure prin2t u; progn(prin2 u, terpri(), u); symbolic procedure smemq(u,v); %true if id U is a member of V at any level (excluding %quoted expressions); if atom v then u eq v else if car v eq 'quote then nil else smemq(u,car v) or smemq(u,cdr v); symbolic procedure u neq v; null(u=v); symbolic procedure setdiff(u,v); if null v then u else setdiff(delete(car v,u),cdr v); % List changing alternates (may also be defined as copying functions) symbolic procedure aconc!*(u,v); nconc(u,list v); % append(u,list v); symbolic procedure nconc!*(u,v); nconc(u,v); % append(u,v); symbolic procedure reversip!* u; reversip u; % reverse u; symbolic procedure rplaca!*(u,v); rplaca(u,v); % v . cdr u; symbolic procedure rplacd!*(u,v); rplacd(u,v); % car u . v; % The following functions should be provided in the compiler for % efficient coding. %symbolic procedure apply1(u,v); apply(u,list v); %symbolic procedure apply2(u,v,w); apply(u,list(v,w)); %symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x)); % The following function is needed by several modules. It is more % REDUCE-specific than other functions in this module, but since it % needs to be defined early on, it might as well go here. symbolic procedure gettype u; % Returns a REDUCE-related type for the expression U. % It needs to be more table driven than the current definition. if numberp u then 'number else if null atom u or null u or null idp u then 'form else if get(u,'simpfn) then 'operator else if get(u,'avalue) then 'variable else if getd u then 'procedure else if globalp u then 'global else if fluidp u then 'fluid else if flagp(u,'parm) then 'parameter else get(u,'rtype); endmodule; module slfns; % Complete list of Standard LISP functions. % Author: Anthony C. Hearn. global '(!*argnochk slfns!*); slfns!* := '( (abs 1) (add1 1) (append 2) (apply 2) (assoc 2) (atom 1) (car 1) (cdr 1) (caar 1) (cadr 1) (cdar 1) (cddr 1) (caaar 1) (caadr 1) (cadar 1) (caddr 1) (cdaar 1) (cdadr 1) (cddar 1) (cdddr 1) (caaaar 1) (caaadr 1) (caadar 1) (caaddr 1) (cadaar 1) (cadadr 1) (caddar 1) (cadddr 1) (cdaaar 1) (cdaadr 1) (cdadar 1) (cdaddr 1) (cddaar 1) (cddadr 1) (cdddar 1) (cddddr 1) (close 1) (codep 1) (compress 1) (cons 2) (constantp 1) (de 3) (deflist 2) (delete 2) % (DF 3) conflicts with algebraic operator DF (difference 2) (digit 1) (divide 2) (dm 3) (dn 3) (ds 3) (eject 0) (eq 2) (eqn 2) (equal 2) (error 2) (errorset 3) (eval 1) (evlis 1) (expand 2) (explode 1) (expt 2) (fix 1) (fixp 1) (flag 2) (flagp 2) (float 1) (floatp 1) (fluid 1) (fluidp 1) (function 1) (gensym 0) (get 2) (getd 1) (getv 2) (global 1) (globalp 1) (go 1) (greaterp 2) (idp 1) (intern 1) (length 1) (lessp 2) (linelength 1) (liter 1) (lposn 0) (map 2) (mapc 2) (mapcan 2) (mapcar 2) (mapcon 2) (maplist 2) (max2 2) (member 2) (memq 2) (minus 1) (minusp 1) (min2 2) (mkvect 1) (nconc 2) (not 1) (null 1) (numberp 1) (onep 1) (open 2) (pagelength 1) (pair 2) (pairp 1) (plus2 2) (posn 0) (print 1) (prin1 1) (prin2 1) (prog2 2) (put 3) (putd 3) (putv 3) (quote 1) (quotient 2) (rds 1) (read 0) (readch 0) (remainder 2) (remd 1) (remflag 2) (remob 1) (remprop 2) (return 1) (reverse 1) (rplaca 2) (rplacd 2) (sassoc 3) (set 2) (setq 2) (stringp 1) (sublis 2) (subst 3) (sub1 1) (terpri 0) (times2 2) (unfluid 1) (upbv 1) (vectorp 1) (wrs 1) (zerop 1) ); if !*argnochk then deflist(slfns!*,'number!-of!-args); endmodule; module superv; % REDUCE supervisory functions. % Author: Anthony C. Hearn. % Modified by: Jed B. Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*defn !*errcont !*int !*mode !*slin !*time dfprint!* lreadfn!* semic!* tslin!*); global '(!$eof!$ !*byeflag!* !*demo !*echo !*extraecho !*lessspace !*micro!-version !*nosave!* !*output !*pret !*rlisp2 !*strind !*struct cloc!* cmsg!* crbuf!* crbuflis!* crbuf1!* cursym!* eof!* erfg!* ifl!* ipl!* initl!* inputbuflis!* key!* ofl!* opl!* ogctime!* otime!* program!* programl!* resultbuflis!* st!* statcounter symchar!* tok!* ttype!* ws); !*output := t; eof!* := 0; initl!* := '(fname!* outl!*); statcounter := 0; % The true REDUCE supervisory function is BEGIN, again defined in the % system dependent part of this program. However, most of the work is % done by BEGIN1, which is called by BEGIN for every file encountered % on input; symbolic procedure errorp u; %returns true if U is an ERRORSET error format; atom u or cdr u; symbolic procedure flagp!*!*(u,v); idp u and flagp(u,v); symbolic procedure setcloc!*; % Used to set for file input a global variable CLOC!* to dotted pair % of file name and dotted pair of line and page being read. % Currently a place holder for system specific function, since not % supported in Standard LISP. CLOC!* is used in the INTER and RCREF % modules. cloc!* := if null ifl!* then nil else car ifl!* . nil; symbolic procedure command; begin scalar x; if !*demo and (x := ifl!*) then progn(terpri(),rds nil,readch(),rds cadr x); if null !*slin then if !*rlisp2 then progn(s!&(), key!* := tok!*, m!-metarlisp(), (if st!* then x := car st!* else x := nil), st!* := nil) else progn(scan(), setcloc!*(), key!* := cursym!*, x := xread1 nil) else progn(key!* := (semic!* := '!;), setcloc!*(), x := (if lreadfn!* then apply(lreadfn!*,nil) else read()), if key!* eq '!; then key!* := if atom x then x else car x); if !*struct then x := structchk x; if !*pret then progn(terpri(),rprint x); if null !*slin then x := form x; return x end; symbolic procedure begin1; begin scalar mode,parserr,result,x; if !*rlisp2 then prolog 'm!-metarlisp; otime!* := time(); % the next line is that way for bootstrapping purposes. if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0; a0: cursym!* := '!*semicol!*; a: if null terminalp() or !*nosave!* then go to b else if statcounter>0 then add2buflis(); statcounter := statcounter + 1; crbuf1!* := nil; % For input string editor. !*strind := 0; % Used by some versions of input editor. setpchar compress1('!| . append(explodec statcounter, if null symchar!* or !*mode eq 'algebraic then '(!: ! !|) else '(!* ! !|))); b: parserr := nil; !*nosave!* := nil; if !*time then eval '(showtime); %Since a STAT; if !*output and null ofl!* and terminalp() and null !*defn and null !*lessspace then terpri(); if tslin!* then progn(!*slin := car tslin!*, lreadfn!* := cdr tslin!*, tslin!* := nil); mapcar(function sinitl, initl!*); if !*int then erfg!* := nil; %to make editing work properly; if null !*rlisp2 and cursym!* eq 'end then progn(comm1 'end, return nil); program!* := errorset('(command),t,!*backtrace); if !*rlisp2 then if tok!* eq '!*semic!* then semic!* := '!; else semic!* := '!$; condterpri(); if errorp program!* then go to err1; program!* := car program!*; if eofcheck() then go to c else eof!* := 0; if !*rlisp2 then if program!* = '(end) then return nil else nil else if cursym!* eq 'end then if !*micro!-version and terminalp() then go to a0 else progn(comm1 'end, return nil) else if eqcar(program!*,'retry) then program!* := programl!*; %The following section decides what the target mode should be. %That mode is also assumed to be the printing mode; if flagp!*!*(key!*,'modefn) then mode := key!* else if null atom program!* % and null !*micro!-version and null(car program!* eq 'quote) and (null(idp car program!* and (flagp(car program!*,'nochange) or flagp(car program!*,'intfn) or car program!* eq 'list)) or car program!* memq '(setq setel setf) and eqcar(caddr program!*,'quote)) then mode := 'symbolic else if key!* eq 'input and (x := rassoc!*(program!*,inputbuflis!*)) then mode := cddr x else mode := !*mode; program!* := convertmode1(program!*,nil,'symbolic,mode); add2inputbuf(program!*,!*mode); % This used to be MODE, but then ED n wouldn't work. if null !*rlisp2 and null atom program!* and car program!* memq '(bye quit) then if getd 'bye then progn(eval program!*, go to b) else progn(!*byeflag!* := t, return nil) else if null !*rlisp2 and eqcar(program!*,'ed) then progn((if getd 'cedit and terminalp() then cedit cdr program!* else lprim "ED not supported"), go to b) else if !*defn then if erfg!* then go to a else if null flagp!*!*(key!*,'ignore) and null eqcar(program!*,'quote) then go to d; b1: if !*output and ifl!* and !*echo and null !*lessspace then terpri(); result := errorset((if mode eq 'symbolic then program!* else list('assgneval,mkquote program!*)), t,!*backtrace); if errorp result or erfg!* then progn(programl!* := program!*,go to err2) else if !*defn then go to a; if null(mode eq 'symbolic) then progn(program!* := cdar result, result := list caar result); add2resultbuf(car result,mode); if null !*output then go to a else if (null !*rlisp2 and semic!* eq '!;) or (!*rlisp2 and tok!* eq '!*semic!*) then if mode eq 'symbolic then if null car result and null(!*mode eq 'symbolic) then nil else begin terpri(); result := errorset(list('print,mkquote car result), t,!*backtrace) end else if car result then result := errorset(list('varpri,mkquote car result, mkquote program!*, mkquote 'only), t,!*backtrace); if errorp result then go to err3 else go to a; c: if crbuf1!* then progn(lprim "Closing object improperly removed. Redo edit.", crbuf1!* := nil, go to a) else if eof!*>4 then progn(lprim "End-of-file read", return eval '(bye)) else if terminalp() then progn(crbuf!* := nil, go to b) else return nil; d: if program!* then dfprint program!*; if null flagp!*!*(key!*,'eval) then go to a else go to b1; err1: if eofcheck() or eof!*>0 then go to c else if program!*="BEGIN invalid" then go to a; parserr := t; err2: resetparser(); %in case parser needs to be modified; err3: erfg!* := t; if null !*int and null !*errcont then progn(!*defn := t, !*echo := t, (if null cmsg!* then lprie "Continuing with parsing only ..."), cmsg!* := t) else if null !*errcont then progn(result := pause1 parserr, (if result then return null eval result), erfg!* := nil) else erfg!* := nil; go to a end; flag ('(deflist flag fluid global remflag remprop unfluid),'eval); symbolic procedure assgneval u; % Evaluate (possible) assignment statements and return results in a % form that allows required printing of such assignments. begin scalar x,y; a: if atom u then go to b else if car u eq 'setq then x := ('setq . cadr u) . x else if car u eq 'setel then x := ('setel . mkquote eval cadr u) . x else if car u eq 'setk then x := ('setk . mkquote if atom (y := eval cadr u) then y else car y . revlis cdr y) . x else go to b; u := caddr u; go to a; b: u := mkquote eval u; c: if null x then return(eval u . u); u := list(caar x,cdar x,u); x := cdr x; go to c end; symbolic procedure rassoc!*(u,v); % Finds term in which U is the first term in the right part of a term % in the association list V, or NIL if term is not found; if null v then nil else if u = cadar v then car v else rassoc!*(u,cdr v); symbolic procedure close!-input!-files; % Close all input files currently open; begin if ifl!* then progn(rds nil,ifl!* := nil); aa: if null ipl!* then return nil; close cdar ipl!*; ipl!* := cdr ipl!*; go to aa end; symbolic procedure close!-output!-files; % Close all output files currently open; begin if ofl!* then progn(wrs nil,ofl!* := nil); aa: if null opl!* then return nil; close cdar opl!*; opl!* := cdr opl!*; go to aa end; symbolic procedure add2buflis; begin if null crbuf!* then return nil; crbuf!* := reversip crbuf!*; %put in right order; a: if crbuf!* and seprp car crbuf!* then progn(crbuf!* := cdr crbuf!*, go to a); crbuflis!* := (statcounter . crbuf!*) . crbuflis!*; crbuf!* := nil end; symbolic procedure add2inputbuf(u,mode); begin if null terminalp() or !*nosave!* then return nil; inputbuflis!* := (statcounter . u . mode) . inputbuflis!* end; symbolic procedure add2resultbuf(u,mode); begin if mode eq 'symbolic or null u or !*nosave!* then return nil; ws := u; if terminalp() then resultbuflis!* := (statcounter . u) . resultbuflis!* end; symbolic procedure condterpri; !*output and !*echo and !*extraecho and (null !*int or ifl!*) and null !*defn and terpri(); symbolic procedure eofcheck; % true if an end-of-file has been read in current input sequence; program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1); symbolic procedure resetparser; %resets the parser after an error; if null !*slin then comm1 t; symbolic procedure terminalp; %true if input is coming from an interactive terminal; !*int and null ifl!*; symbolic procedure dfprint u; %Looks for special action on a form, otherwise prettyprints it; if dfprint!* then apply(dfprint!*,list u) else if cmsg!* then nil else if null eqcar(u,'progn) then prettyprint u else begin a: u := cdr u; if null u then return nil; dfprint car u; go to a end; symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!*-x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; x := x - y; terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; symbolic procedure sinitl u; set(u,get(u,'initl)); endmodule; module tok; % Identifier and reserved character reading. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(semic!*); global '(!$eof!$ !$eol!$ !*quotenewnam !*raise !*lower crbuf!* crbuf1!* crchar!* curline!* cursym!* eof!* ifl!* nxtsym!* outl!* ttype!*); !*quotenewnam := t; crchar!* := '! ; curline!* := 1; % The function TOKEN defined below is used for reading identifiers % and reserved characters (such as parentheses and infix operators). % It is called by the function SCAN, which translates reserved % characters into their internal name, and sets up the output of the % input line. The following definitions of TOKEN and SCAN are quite % general, but also inefficient. The reading process can often be % speeded up considerably if these functions (especially token) are % written in terms of the explicit LISP used. symbolic procedure prin2x u; outl!* := u . outl!*; symbolic procedure mkstrng u; %converts the uninterned id U into a string; %if strings are not constants, this should be replaced by %list('string,u); u; symbolic procedure readch1; begin scalar x; if null terminalp() then progn(x := readch(), x eq !$eol!$ and (curline!* := curline!*+1), return x) else if crbuf1!* then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end else x := readch(); crbuf!* := x . crbuf!*; return x end; symbolic procedure token1; begin scalar x,y,z; x := crchar!*; a: if seprp x then progn(x := readch1(), go to a) else if digit x then go to number else if liter x or x eq '!_ then go to letter else if x eq '!% then go to coment else if x eq '!! then go to escape else if x eq '!' then progn(crchar!* := readch1(), nxtsym!* := mkquote rread(), ttype!* := 4, return nxtsym!*) else if x eq '!" then go to string; ttype!* := 3; if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr()); nxtsym!* := x; a1: if delcp x then crchar!*:= '! else crchar!*:= readch1(); go to c; escape: begin scalar raise, !*lower; raise := !*raise; !*raise := !*lower := nil; y := x . y; x := readch1(); !*raise := raise end; letter: ttype!* := 0; let1: y := x . y; if digit (x := readch1()) or liter x or x eq '!_ then go to let1 else if x eq '!! then go to escape; nxtsym!* := intern compress reversip!* y; b: crchar!* := x; c: return nxtsym!*; number: ttype!* := 2; num1: y := x . y; z := x; if digit (x := readch1()) or x eq '!. or x eq 'e or z eq 'e then go to num1; nxtsym!* := compress reversip!* y; go to b; string: begin scalar raise, !*lower; raise := !*raise; !*raise := !*lower := nil; strinx: y := x . y; if null((x := readch1()) eq '!") then go to strinx; y := x . y; nxtsym!* := mkstrng compress reversip!* y; !*raise := raise end; ttype!* := 1; go to a1; coment: if null(readch1() eq !$eol!$) then go to coment; x := readch1(); go to a end; symbolic procedure token; %This provides a hook for a faster TOKEN; token1(); symbolic procedure filenderr; begin eof!* := eof!*+1; if terminalp() then error1() else error(99,if ifl!* then list("End-of-file read in file",car ifl!*) else "End-of-file read") end; symbolic procedure ptoken; begin scalar x; x := token(); if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*; %an explicit reference to OUTL!* used here; prin2x x; if null ((x eq '!() or (x eq '!))) then prin2x '! ; return x end; symbolic procedure rread1; % Modified to use QUOTENEWNAM's for ids. begin scalar x,y; x := ptoken(); if null (ttype!*=3) then return if null idp x or null !*quotenewnam or null(y := get(x,'quotenewnam)) then x else y else if x eq '!( then return rrdls() else if null (x eq '!+ or x eq '!-) then return x; y := ptoken(); if null numberp y then progn(nxtsym!* := " ", symerr("Syntax error: improper number",nil)) else if x eq '!- then y := apply('minus,list y); %we need this construct for bootstrapping purposes; return y end; symbolic procedure rrdls; begin scalar x,y,z; a: x := rread1(); if null (ttype!*=3) then go to b else if x eq '!) then return z else if null (x eq '!.) then go to b; x := rread1(); y := ptoken(); if null (ttype!*=3) or null (y eq '!)) then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil)) else return nconc(z,x); b: z := nconc(z,list x); go to a end; symbolic procedure rread; progn(prin2x " '",rread1()); %-- symbolic procedure scan; %-- begin scalar x,y; %-- if null (cursym!* eq '!*semicol!*) then go to b; %-- a: nxtsym!* := token(); %-- b: if null atom nxtsym!* then go to q1 %-- else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* %-- then outl!* := nil; %-- prin2x nxtsym!*; %-- c: if null idp nxtsym!* then go to l %-- else if (x:=get(nxtsym!*,'newnam)) and %-- (null (x=nxtsym!*)) then go to new %-- else if nxtsym!* eq 'comment OR NXTSYM!* EQ '!% AND TTYPE!*=3 %-- THEN GO TO COMM %-- ELSE IF NULL(TTYPE!* = 3) THEN GO TO L %-- ELSE IF NXTSYM!* EQ !$eof!$ then return filenderr() %-- else if nxtsym!* eq '!' then go to quote %-- else if null (x:= get(nxtsym!*,'switch!*)) then go to l %-- else if eqcar(cdr x,'!*semicol!*) then go to delim; %-- sw1: nxtsym!* := token(); %-- if null(ttype!* = 3) then go to sw2 %-- else if nxtsym!* eq !$eof!$ then return filenderr() %-- else if car x then go to sw3; %-- sw2: cursym!*:=cadr x; %-- if cursym!* eq '!*rpar!* then go to l2 %-- else return cursym!*; %-- sw3: if null (y:= atsoc(nxtsym!*,car x)) then go to sw2; %-- prin2x nxtsym!*; %-- x := cdr y; %-- go to sw1; %-- comm: if delcp crchar!* then go to com1; %-- crchar!* := readch(); %-- go to comm; %-- com1: crchar!* := '! ; %-- condterpri(); %-- go to a; %-- delim: %-- semic!*:=nxtsym!*; %-- return (cursym!*:='!*semicol!*); %-- new: nxtsym!* := x; %-- if stringp x then go to l %-- else if atom x then go to c %-- else go to l; %-- quote: %-- nxtsym!* := mkquote rread1(); %-- go to l; %-- q1: if null (car nxtsym!* eq 'string) then go to l; %-- prin2x " "; %-- prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); %-- l: cursym!*:=nxtsym!*; %-- l1: nxtsym!* := token(); %-- if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); %-- l2: if numberp nxtsym!* %-- or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) %-- then prin2x " "; %-- return cursym!* %-- end; global '(!*eoldelimp comment!*); symbolic procedure scan; begin scalar bool,x,y; if null (cursym!* eq '!*semicol!*) then go to b; a: nxtsym!* := token(); b: if null atom nxtsym!* then go to q1 else if nxtsym!* eq 'else or cursym!* eq '!*semicol!* then outl!* := nil; prin2x nxtsym!*; c: if null idp nxtsym!* then go to l else if (x:=get(nxtsym!*,'newnam)) and (null (x=nxtsym!*)) then go to new else if nxtsym!* eq 'Comment then go to comm else if nxtsym!* eq '!#if then go to conditional else if nxtsym!* eq '!#else then progn(nxtsym!* := x := nil, go to skipping) else if nxtsym!* eq '!#endif then go to a else if nxtsym!* eq '!% and ttype!*=3 % then progn(prin2t "****** Tell Hearn you got to SCAN comment", % go to comm) then go to comm else if null(ttype!* = 3) then go to l else if nxtsym!* eq !$eof!$ then return filenderr() else if nxtsym!* eq '!' then rederr "Invalid QUOTE" else if !*eoldelimp and nxtsym!* eq !$eol!$ then go to delim else if null (x:= get(nxtsym!*,'switch!*)) then go to l else if eqcar(cdr x,'!*semicol!*) then go to delim; bool := seprp crchar!*; sw1: nxtsym!* := token(); if null(ttype!* = 3) then go to sw2 else if nxtsym!* eq !$eof!$ then return filenderr() else if car x then go to sw3; sw2: cursym!*:=cadr x; bool := nil; if cursym!* eq '!*rpar!* then go to l2 else return cursym!*; sw3: if bool or null (y:= atsoc(nxtsym!*,car x)) then go to sw2; prin2x nxtsym!*; x := cdr y; if null car x and cadr x eq '!*Comment!* then progn(comment!* := read!-comment(),go to a); go to sw1; conditional: % The conditional expression used here must be written in Lisp form x := errorset(rread(), !*backtrace, nil); % errors in evaluation count as NIL if null errorp x and car x then go to a; x := nil; skipping: % I support nesting of conditional inclusion. if nxtsym!* eq '!#endif then if null x then go to a else x := cdr x else if nxtsym!* eq '!#if then x := nil . x else if (nxtsym!* eq '!#else) and null x then go to a; nxtsym!* := token(); go to skipping; comm: if delcp crchar!* and null(crchar!* eq !$eol!$) then progn(crchar!* := '! , condterpri(), go to a); crchar!* := readch(); go to comm; delim: semic!*:=nxtsym!*; return (cursym!*:='!*semicol!*); new: nxtsym!* := x; if stringp x then go to l else if atom x then go to c else go to l; q1: if null (car nxtsym!* eq 'string) then go to l; prin2x " "; prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*); l: cursym!*:=nxtsym!*; nxtsym!* := token(); if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr(); l2: if numberp nxtsym!* or (atom nxtsym!* and null get(nxtsym!*,'switch!*)) then prin2x " "; return cursym!* end; endmodule; module xread; % Routines for parsing REDUCE input. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* nxtsym!*); % The conversion of a REDUCE expression to LISP prefix form is carried % out by the function XREAD. This function initiates the scanning % process, and then calls the auxiliary function XREAD1 to perform the % actual parsing. Both XREAD and XREAD1 are used by many functions % whenever an expression must be read; flag ('(end !*colon!* !*semicol!*),'delim); symbolic procedure chknewnam u; % Check to see if U has a newnam, and return it else return U. begin scalar x; return if null(x := get(u,'newnam)) or x eq u then u else if idp x then chknewnam x else x end; symbolic procedure mkvar(u,v); u; symbolic procedure remcomma u; if eqcar(u,'!*comma!*) then cdr u else list u; symbolic procedure xread1 u; begin scalar v,w,x,y,z,z1,z2; % v: expression being built % w: prefix operator stack % x: infix operator stack % y: infix value or stat property % z: current symbol % z1: next symbol % z2: temporary storage; a: z := cursym!*; a1: if null idp z then nil else if z eq '!*lpar!* then go to lparen else if z eq '!*rpar!* then go to rparen else if y := get(z,'infix) then go to infx % The next line now commented out was intended to allow a STAT % to be used as a label. However, it prevents the definition of % a diphthong whose first character is a colon. % else if nxtsym!* eq '!: then nil else if flagp(z,'delim) then go to delimit else if y := get(z,'stat) then go to stat; a2: y := nil; a3: w := z . w; if numberp z and idp (z1 := chknewnam nxtsym!*) and null flagp(z1,'delim) and null(get(z1,'switch!*) and null(z1 eq '!()) and null get(z1,'infix) then progn(cursym!* := 'times, go to a); % allow for implicit * after a number. next: z := scan(); go to a1; lparen: y := nil; if scan() eq '!*rpar!* then go to lp1 % no args else if flagpcar(w,'struct) then z := xread1 car w else z := xread1 'paren; if flagp(u,'struct) then progn(z := remcomma z, go to a3) else if null eqcar(z,'!*comma!*) then go to a3 else if null w then (if u eq 'lambda then go to a3 else symerr("Improper delimiter",nil)) else w := (car w . cdr z) . cdr w; go to next; lp1: if w then w := list car w . cdr w; %function of no args; go to next; rparen: if null u or u eq 'group or u eq 'proc then symerr("Too many right parentheses",nil) else go to end1; infx: if z eq '!*comma!* or null atom (z1 := scan()) or numberp z1 then go to in1 else if z1 eq '!*rpar!*%infix operator used as variable; or z1 eq '!*comma!* or flagp(z1,'delim) then go to in2 else if z1 eq '!*lpar!*%infix operator in prefix position; and null atom(z1 := xread 'paren) and car z1 eq '!*comma!* and (z := z . cdr z1) then go to a1; in1: if w then go to unwind else if null(z := get(z,'unary)) then symerr("Redundant operator",nil); v := '!*!*un!*!* . v; go to pr1; in2: y := nil; w := z . w; in3: z := z1; go to a1; unwind: z2 := mkvar(car w,z); un1: w:= cdr w; if null w then go to un2 else if numberp car w then symerr("Missing operator",nil); z2 := list(car w,z2); go to un1; un2: v:= z2 . v; preced: if null x then if y=0 then go to end2 else nil else if y>; begin scalar lst; a: lst := aconc!*(lst,xread 'group); if null(cursym!* eq '!*rsqb!*) then go to a; scan(); return ('progn . lst) end; put('!*lsqb!*,'stat,'mkprogn); flag('(!*rsqb!*),'delim); flag('(!*rsqb!*),'nodel); % ***** END STATEMENT ***** symbolic procedure endstat; %This procedure can also be used for any key-words which take no %arguments; begin scalar x; x := cursym!*; comm1 'end; return list x end; put('end,'stat,'endstat); put('endmodule,'stat,'endstat); put('bye,'stat,'endstat); put('quit,'stat,'endstat); flag('(bye quit),'eval); put('showtime,'stat,'endstat); endmodule; module block; % Block statement and related operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(!*vars!* cursym!* nxtsym!*); % ***** GO statement ***** symbolic procedure gostat; begin scalar var; var := if eq(scan(),'to) then scan() else cursym!*; scan(); return list('go,var) end; put('go,'stat,'gostat); put('goto,'newnam,'go); % ***** Declaration Statement ***** symbolic procedure decl u; begin scalar varlis,w; a: if cursym!* eq '!*semicol!* then go to c else if not flagp!*!*(cursym!*,'type) then return varlis else if cursym!* eq 'dcl then go to dclr; w := cursym!*; if scan() eq 'procedure then return procstat1 w; varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w)); b: if not cursym!* eq '!*semicol!* then symerr(nil,t) else if null u then return list('dcl,mkquote varlis); %top level declaration; c: scan(); go to a; dclr: varlis := append(varlis,dclstat1()); go to b end; flag ('(dcl real integer scalar),'type); symbolic procedure dclstat; list('dcl,mkquote dclstat1()); symbolic procedure dclstat1; begin scalar x,y; a: x := xread nil; if not cursym!* eq '!*colon!* then symerr('dcl,t); y := append(y,pairvars(remcomma x,nil,scan())); if scan() eq '!*semicol!* then return y else if not cursym!* eq '!*comma!* then symerr('dcl,t) else go to a end; symbolic procedure dcl u; %U is a list of (id, mode) pairs, which are declared as global vars; begin scalar x; !*vars!* := append(u,!*vars!*); x := mapcar(function car, u); global x; flag(x,'share); a: if null u then return nil; set(caar u,get(cdar u,'initvalue)); u := cdr u; go to a end; put('integer,'initvalue,0); put('dcl,'stat,'dclstat); symbolic procedure decstat; %only called if a declaration occurs at the top level or not first %in a block; begin scalar x,y,z; if !*blockp then symerr('block,t); x := cursym!*; y := nxtsym!*; z := decl nil; if y neq 'procedure then rederr list(x,"invalid outside block"); return z end; put('integer,'stat,'decstat); put('real,'stat,'decstat); put('scalar,'stat,'decstat); % ***** Block Statement ***** symbolic procedure blockstat; begin scalar hold,varlis,x,!*blockp; !*blockp := t; scan(); if cursym!* memq '(nil !*rpar!*) then rederr "BEGIN invalid"; varlis := decl t; a: if cursym!* eq 'end and not nxtsym!* eq '!: then go to b; x := xread1 nil; if eqcar(x,'end) then go to c; not cursym!* eq 'end and scan(); if x then hold := aconc!*(hold,x); go to a; b: comm1 'end; c: return mkblock(varlis,hold) end; symbolic procedure mkblock(u,v); 'reduce!-block . (u . v); putd('reduce!-block,'macro, '(lambda (u) (cons 'prog (cons (mapcar (function car) (cadr u)) (cddr u))))); symbolic procedure formblock(u,vars,mode); 'prog . append(initprogvars cadr u, formprog1(cddr u,append(cadr u,vars),mode)); symbolic procedure initprogvars u; begin scalar x,y,z; a: if null u then return(reversip!* x . reversip!* y) else if z := get(cdar u,'initvalue) then y := mksetq(caar u,z) . y; x := caar u . x; u := cdr u; go to a end; symbolic procedure formprog(u,vars,mode); 'prog . cadr u . formprog1(cddr u,pairvars(cadr u,vars,mode),mode); symbolic procedure formprog1(u,vars,mode); if null u then nil else if atom car u then car u . formprog1(cdr u,vars,mode) else if idp caar u and flagp(caar u,'modefn) then formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode) else formc(car u,vars,mode) . formprog1(cdr u,vars,mode); put('reduce!-block,'formfn,'formblock); put('prog,'formfn,'formprog); put('begin,'stat,'blockstat); % ***** Return Statement ***** symbolic procedure retstat; if not !*blockp then symerr(nil,t) else list('return, if flagp!*!*(scan(),'delim) then nil else xread1 t); put('return,'stat,'retstat); endmodule; module form; % Performs a mode analysis of parsed forms. % Author: Anthony C. Hearn. % Modifications by: Jed Marti. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*!*a2sfn !*cref !*defn !*mode current!-modulus); global '(!*argnochk !*composites !*force !*micro!-version !*vars!*); !*!*a2sfn := 'aeval; flag('(algebraic symbolic),'modefn); symbolic procedure formcond(u,vars,mode); 'cond . formcond1(cdr u,vars,mode); symbolic procedure formcond1(u,vars,mode); if null u then nil else list(formbool(caar u,vars,mode),form1(cadar u,vars,mode)) % FORMC here would add REVAL . formcond1(cdr u,vars,mode); put('cond,'formfn,'formcond); symbolic procedure formlamb(u,vars,mode); list('lambda,cadr u,form1(caddr u,pairvars(cadr u,vars,mode),mode)); put('lambda,'formfn,'formlamb); symbolic procedure formprogn(u,vars,mode); 'progn . formclis(cdr u,vars,mode); put('progn,'formfn,'formprogn); symbolic procedure expdrmacro u; %returns the macro form for U if expansion is permitted; begin scalar x; if null(x := getrmacro u) or flagp(u,'noexpand) then return nil else if null !*cref and (null !*defn or car x eq 'smacro) or flagp(u,'expand) or !*force then return x else return nil end; symbolic procedure getrmacro u; %returns a Reduce macro definition for U, if one exists, %in GETD format; begin scalar x; return if not idp u then nil else if (x := getd u) and car x eq 'macro then x else if (x := get(u,'smacro)) then 'smacro . x % else if (x := get(u,'nmacro)) then 'nmacro . x; else nil end; symbolic procedure applmacro(u,v,w); apply1(u,w . v); %symbolic procedure applnmacro(u,v,w); % apply(u,if flagp(w,'nospread) then list v else v); % symbolic procedure applsmacro(u,v,w); % %We could use an atom sublis here, eg SUBLA; % sublis(pair(cadr u,v),caddr u); put('macro,'macrofn,'applmacro); %put('nmacro,'macrofn,'applnmacro); put('smacro,'macrofn,'applsmacro); flag('(ed go quote),'noform); symbolic procedure set!-global!-mode u; begin !*mode := u end; symbolic procedure form1(u,vars,mode); begin scalar x,y; if atom u then return if not idp u then u else if u eq 'ed then list u else if flagp(u,'modefn) then set!-global!-mode u else if x:= get(mode,'idfn) then apply2(x,u,vars) else u else if not atom car u then if caar u eq 'lambda then return formlis(u,vars,mode) else typerr(car u,"operator") else if not idp car u then typerr(car u,"operator") else if get(car u, 'localfnname) then return form1(get(car u,'localfnname) . cdr u,vars,mode) else if flagp(car u,'noform) then return u else if r!-arrayp car u and (mode eq 'symbolic or intexprlisp(cdr u,vars)) then return list('getel,intargfn(u,vars,mode)) else if flagp(car u,'modefn) then return convertmode(cadr u,vars,mode,car u) else if (x := get(car u,'formfn)) then return macrochk(apply(x,list(u,vars,mode)),mode) else if get(car u,'stat) eq 'rlis then return macrochk(formrlis(u,vars,mode),mode) % else if (x := getd car u) and eqcar(x, 'macro) and % not(mode eq 'algebraic) then % return << x := apply(cdr x, list(u, vars, mode)); % formc(x, vars, mode) >> ; argnochk u; x := formlis(cdr u,vars,mode); y := if x=cdr u then u else car u . x; return if mode eq 'symbolic or get(car u,'stat) or cdr u and eqcar(cadr u,'quote) and null !*micro!-version or intexprnp(y,vars) and null !*composites and null current!-modulus then macrochk(y,mode) else if not(mode eq 'algebraic) then convertmode(y,vars,mode,'algebraic) else ('list . algid(car u,vars) . x) end; symbolic procedure argnochk u; begin scalar x; if null !*argnochk then nil else if (x := argsofopr car u) and x neq length cdr u then rederr list(car u,"called with", length cdr u, if length cdr u=1 then "argument" else "arguments", "instead of",x) end; symbolic procedure argsofopr u; % This function may be optimizable in various implementations. get(u,'number!-of!-args); symbolic procedure intexprnp(u,vars); %determines if U is an integer expression; if atom u then if numberp u then fixp u else if (u := atsoc(u,vars)) then cdr u eq 'integer else nil else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars); symbolic procedure intexprlisp(u,vars); null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars); flag('(difference minus plus times),'intfn); % EXPT is not included in this list, because a negative exponent can % cause problems (i.e., result can be rational); symbolic procedure formlis(u,vars,mode); mapcar(function (lambda x; form1(x,vars,mode)), u); symbolic procedure formclis(u,vars,mode); mapcar(function (lambda x; formc(x,vars,mode)), u); symbolic procedure form u; form1(u,!*vars!*,!*mode); symbolic procedure macrochk(u,mode); begin scalar y; %expands U if CAR U is a macro and expansion allowed; if atom u then return u else if (y := expdrmacro car u) and (mode eq 'symbolic or idp car u and flagp(car u,'opfn)) then return apply(get(car y,'macrofn),list(cdr y,cdr u,car u)) else return u end; put('symbolic,'idfn,'symbid); symbolic procedure symbid(u,vars); u; % if atsoc(u,vars) or fluidp u or globalp u or u memq '(nil t) % or flagp(u,'share) then u % else <>; put('algebraic,'idfn,'algid); symbolic procedure algid(u,vars); if atsoc(u,vars) or flagp(u,'share) then u else mkquote u; put('integer,'idfn,'intid); symbolic procedure intid(u,vars); begin scalar x,y; return if (x := atsoc(u,vars)) then if cdr x eq 'integer then u else if y := get(cdr x,'integer) then apply2(y,u,vars) else if cdr x eq 'scalar then !*!*a2i(u,vars) else rederr list(cdr x,"not convertable to INTEGER") else !*!*a2i(mkquote u,vars) end; symbolic procedure convertmode(exprn,vars,target,source); convertmode1(form1(exprn,vars,source),vars,target,source); symbolic procedure convertmode1(exprn,vars,target,source); begin scalar x; if source eq 'real then source := 'algebraic; if target eq 'real then target := 'algebraic; if target eq source then return exprn else if idp exprn and (x := atsoc(exprn,vars)) and not(cdr x memq '(integer scalar real)) and not(cdr x eq source) then return convertmode(exprn,vars,target,cdr x) else if not (x := get(source,target)) then typerr(source,target) else return apply2(x,exprn,vars) end; put('algebraic,'symbolic,'!*!*a2s); put('symbolic,'algebraic,'!*!*s2a); symbolic procedure !*!*a2s(u,vars); % It would be nice if we could include the ATSOC(U,VARS) line, % since in many cases that would save recomputation. However, % in any sequential process, assignments or subsititution rules % can change the value of a variable, so we have to check its % value again. More comprehensive analysis could certainly % optimize this. if u = '(quote nil) then nil else if null u or constantp u and null fixp u or intexprnp(u,vars) and null !*composites and null current!-modulus or not atom u and idp car u and flagp(car u,'nochange) and not(car u eq 'getel) % or atsoc(u,vars) % means it was already evaluated then u else list(!*!*a2sfn,u); symbolic procedure !*!*s2a(u,vars); u; symbolic procedure formc(u,vars,mode); %this needs to be generalized; if mode eq 'algebraic and intexprnp(u,vars) then u else convertmode(u,vars,'symbolic,mode); symbolic procedure intargfn(u,vars,mode); % transforms array element U into expression with integer arguments. % Array name is treated as an algebraic variable; 'list . form1(car u,vars,'algebraic) . mapcar(function (lambda x; convertmode(x,vars,'integer,mode)), cdr u); put('algebraic,'integer,'!*!*a2i); symbolic procedure !*!*a2i(u,vars); if intexprnp(u,vars) then u else list('ieval,u); symbolic procedure ieval u; !*s2i reval u; flag('(ieval),'opfn); % To make it a symbolic operator. flag('(ieval),'nochange); put('symbolic,'integer,'!*!*s2i); symbolic procedure !*!*s2i(u,vars); if fixp u then u else list('!*s2i,u); symbolic procedure !*s2i u; if fixp u then u else typerr(u,"integer"); put('integer,'symbolic,'ridentity); symbolic procedure ridentity(u,vars); u; symbolic procedure formbool(u,vars,mode); if mode eq 'symbolic then form1(u,vars,mode) else if atom u then if not idp u or atsoc(u,vars) or u eq 't then u else formc!*(u,vars,mode) else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u else if idp car u and get(car u,'boolfn) then get(car u,'boolfn) . formclis(cdr u,vars,mode) else if idp car u and flagp(car u,'boolean) then car u . mapcar(function (lambda x; if flagp(car u,'boolargs) then formbool(x,vars,mode) else formc!*(x,vars,mode)), cdr u) else formc!*(u,vars,mode); symbolic procedure formc!*(u,vars,mode); begin scalar !*!*a2sfn; !*!*a2sfn := 'reval; return formc(u,vars,mode) end; % Functions with side effects must be handled carefully in this model, % otherwise they are not always evaluated within blocks. symbolic procedure formrederr(u,vars,mode); begin scalar x; x := formc!*(cadr u,vars,mode); return list('rederr,x) end; put('rederr,'formfn,'formrederr); symbolic procedure formreturn(u,vars,mode); begin scalar x; x := form1(cadr u,vars,mode); % FORMC here would add REVAL if not(mode memq '(symbolic integer real)) and eqcar(x,'setq) % Should this be more general? then x := list(!*!*a2sfn,x); return list('return,x) end; put('return,'formfn,'formreturn); symbolic procedure formsetq(u,vars,mode); begin scalar target,x,y; u := cdr u; if eqcar(cadr u,'quote) then mode := 'symbolic; if idp car u and (y := atsoc(car u,vars)) and not(cdr y eq 'scalar) then target := 'symbolic % used to be CDR Y else target := 'symbolic; % Make target always SYMBOLIC so that algebraic expressions % are evaluated before being stored. x := convertmode(cadr u,vars,target,mode); return if not atom car u then if not idp caar u then typerr(car u,"assignment") else if r!-arrayp caar u then list('setel,intargfn(car u,vars,mode),x) else if y := get(caar u,'setqfn) then form1((y . append(cdar u,cdr u)),vars,mode) % else if y := get(caar u, 'access) % then list('m!-setf, % list(caar u, form1(cadar u, vars, mode)), % x) else list('setk,form1(car u,vars,'algebraic),x) % algebraic needed above, since SETK expects it. else if not idp car u then typerr(car u,"assignment") else if mode eq 'symbolic or y or flagp(car u,'share) or eqcar(x,'quote) then mksetq(car u,x) else list('setk,mkquote car u,x) end; put('car,'setqfn,'rplaca); put('cdr,'setqfn,'rplacd); put('setq,'formfn,'formsetq); symbolic procedure formfunc(u,vars,mode); if idp cadr u then if getrmacro cadr u then rederr list("Macro",cadr u,"Used as Function") else list('function,cadr u) else list('function,form1(cadr u,vars,mode)); put('function,'formfn,'formfunc); % RLIS is a parser function that reads a list of arguments and returns % this list as one argument. It needs to be defined in this module for % bootstrapping purposes since this definition only works with its form % function. symbolic procedure rlis; begin scalar x; x := cursym!*; return if flagp!*!*(scan(),'delim) then list(x,nil) else x . remcomma xread1 'lambda end; symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end; symbolic procedure rlistat u; begin a: if null u then return nil; put(car u,'stat,'rlis); u := cdr u; go to a end; rlistat '(flagop); symbolic procedure formrlis(u,vars,mode); if not flagp(car u,'flagop) then list(car u,'list . formlis(cdr u,vars,'algebraic)) else if not idlistp cdr u then typerr('!*comma!* . cdr u,"identifier list") else mkprog(nil,list('flag,mkquote cdr u,mkquote car u) . get(car u,'simpfg)); symbolic procedure mkarg(u,vars); % Returns the "unevaled" form of U. if null u or constantp u then u else if atom u then if atsoc(u,vars) then u else mkquote u else if car u eq 'quote then mkquote u else 'list . mapcar(function (lambda x; mkarg(x,vars)), u); endmodule; module proc; % Procedure statement. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace); global '(!*argnochk !*comp !*lose cursym!* erfg!* fname!* ftypes!*); fluid '(!*defn); !*lose := t; ftypes!* := '(expr fexpr macro); symbolic procedure putc(name,type,body); %defines a non-standard function, such as an smacro. Returns NAME; begin if !*comp and flagp(type,'compile) then compd(name,type,body) else put(name,type,body); return name end; % flag('(putc),'eval); symbolic procedure formproc(u,vars,mode); begin scalar body,name,type,varlis,x,y; u := cdr u; name := car u; if cadr u then mode := cadr u; % overwrite previous mode u := cddr u; type := car u; if flagp(name,'lose) and (!*lose or null !*defn) then return progn(lprim list(name, "not defined (LOSE flag)"), nil); varlis := cadr u; u := caddr u; x := if eqcar(u,'reduce!-block) then cadr u else nil; y := pairxvars(varlis,x,vars,mode); if x then u := car u . rplaca!*(cdr u,cdr y); body:= form1(u,car y,mode); % FORMC here would add REVAL if type eq 'expr then body := list('de,name,varlis,body) else if type eq 'fexpr then error(0, "FEXPR definition") else if type eq 'macro then body := list('defmacro,name,'!&whole . varlis,body) else if type eq 'emb then return embfn(name,varlis,body) else body := list('put, mkquote name, mkquote type, mkquote list('lambda,varlis,body)); if not(mode eq 'symbolic) then body := list('progn, list('flag,mkquote list name,mkquote 'opfn), body); if !*argnochk and type memq '(expr smacro) then body := list('progn, list('put,mkquote name, mkquote 'number!-of!-args, length varlis), body); if !*defn and type memq '(fexpr macro smacro) then eval body; return body end; put('procedure,'formfn,'formproc); symbolic procedure pairxvars(u,v,vars,mode); %Pairs procedure variables and their modes, taking into account %the convention which allows a top level prog to change the mode %of such a variable; begin scalar x,y; a: if null u then return append(reversip!* x,vars) . v else if (y := atsoc(car u,v)) then <> else x := (car u . mode) . x; u := cdr u; go to a end; symbolic procedure procstat1 mode; begin scalar bool,u,type,x,y,z; bool := erfg!*; if fname!* then go to b else if cursym!* eq 'procedure then type := 'expr else progn(type := cursym!*,scan()); if not cursym!* eq 'procedure then go to c; x := errorset('(xread (quote proc)),nil,!*backtrace); if errorp x then go to a else if atom (x := car x) then x := list x; %no arguments; fname!* := car x; %function name; if idp fname!* %AND NOT(TYPE MEMQ FTYPES!*); then if null fname!* or (z := gettype fname!*) and not z memq '(procedure operator) then go to d else if not getd fname!* then flag(list fname!*,'fnc); %to prevent invalid use of function name in body; u := cdr x; y := u; x := car x . y; a: z := errorset('(xread t),nil,!*backtrace); if not errorp z then z := car z; if null erfg!* then z:=list('procedure,car x,mode,type,y,z); remflag(list fname!*,'fnc); fname!*:=nil; if erfg!* then progn(z := nil,if not bool then error1()); return z; b: bool := t; c: errorset('(symerr (quote procedure) t),nil,!*backtrace); go to a; d: typerr(list(z,fname!*),"procedure"); go to a end; symbolic procedure procstat; procstat1 nil; deflist ('((procedure procstat) (expr procstat) (fexpr procstat) (emb procstat) (macro procstat) (smacro procstat)), 'stat); % Next line refers to bootstrapping process. if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat); deflist('((lisp symbolic)),'newnam); endmodule; module forstat; % Definition of REDUCE FOR loops. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!* foractions!*); comment the syntax of the FOR statement is as follows: {step i3 until} {i := i1 { } i2 } { { : } } for { } { { in } } { each i { } } { on } In all cases, the is evaluated algebraically within the scope of the current value of i. If is DO, then nothing else happens. In other cases, is a binary operator that causes a result to be built up and returned by FOR. In each case, the loop is initialized to a default value. The test for the end condition is made before any action is taken. The effect of the definition here is to replace all for loops by semantically equivalent blocks. As a result, none of the mapping functions are needed in REDUCE. To declare a set of actions, one says; foractions!* := '(do collect conc product sum); remflag(foractions!*,'delim); % For bootstrapping purposes. % To associate a binary function with an action, one says: deflist('((product times) (sum plus)),'bin); % And to give these an initial value in a loop: deflist('((product 1) (sum 0)),'initval); % NB: We need to reset for and let delims if an error occurs. It's % probably best to do this in the begin1 loop. flag('(for),'nochange); symbolic procedure forstat; begin scalar !*blockp; return if scan() eq 'all then forallstat() else if cursym!* eq 'each then foreachstat() else forloop() end; put('for,'stat,'forstat); symbolic procedure forloop; begin scalar action,bool,incr,var,x; flag('(step),'delim); x := errorset('(xread1 'for),t,t); remflag('(step),'delim); if errorp x then error1() else x := car x; if not eqcar(x,'setq) or not idp(var := cadr x) then symerr('for,t); x := caddr x; if cursym!* eq 'step then <> else if cursym!* eq '!*colon!* then incr := 1 else symerr('for,t); if flagp(car foractions!*,'delim) then bool := t % nested loop else flag(foractions!*,'delim); incr := list(x,incr,xread t); if null bool then remflag(foractions!*,'delim); if not((action := cursym!*) memq foractions!*) then symerr('for,t); return list('for,var,incr,action,xread t) end; symbolic procedure formfor(u,vars,mode); begin scalar action,algp,body,endval,incr,initval,var,x; %ALGP is used to determine if the loop calculation must be %done algebraically or not; var := cadr u; incr := caddr u; incr := list(formc(car incr,vars,mode), formc(cadr incr,vars,mode), formc(caddr incr,vars,mode)); if intexprnp(car incr,vars) and intexprnp(cadr incr,vars) and not atsoc(var,vars) then vars := (var . 'integer) . vars; action := cadddr u; body := formc(car cddddr u, (var . if intexprlisp(caddr u,vars) then 'integer else mode) . vars,mode); algp := algmodep car incr or algmodep cadr incr or algmodep caddr incr; initval := car incr; endval := caddr incr; incr := cadr incr; x := if algp then list('list,''difference,endval,var) else list('difference,endval,var); if incr neq 1 then x := if algp then list('list,''times,incr,x) else list('times,incr,x); % We could consider simplifying X here (via reval). x := if algp then list('aminusp!:,x) else list('minusp,x); return forformat(action,body,initval,x, list('plus2,incr),var,vars,mode) end; put('for,'formfn,'formfor); symbolic procedure algmodep u; eqcar(u,'aeval); symbolic procedure aminusp!: u; begin scalar x; u := aeval u; x := u; if fixp x then return minusp x else if not eqcar(x,'!*sq) then msgpri(nil,reval u,"invalid in FOR statement",nil,t); x := cadr x; if fixp car x and fixp cdr x then return minusp car x else if not cdr x = 1 or not (atom(x := car x) or atom car x) % Should be DOMAINP, but SMACROs not yet defined. then msgpri(nil,reval u,"invalid in FOR statement",nil,t) else return apply('!:minusp,list x) end; symbolic procedure foreachstat; begin scalar w,x,y,z; if not idp(x := scan()) or not (y := scan()) memq '(in on) then symerr("FOR EACH",t) else if flagp(car foractions!*,'delim) then w := t else flag(foractions!*,'delim); z := xread t; if null w then remflag(foractions!*,'delim); w := cursym!*; if not w memq foractions!* then symerr("FOR EACH",t); return list('foreach,x,y,z,w,xread t) end; put('foreach,'stat,'foreachstat); symbolic procedure formforeach(u,vars,mode); begin scalar action,body,lst,mod,var; var := cadr u; u := cddr u; mod := car u; u := cdr u; lst := formc(car u,vars,mode); u := cdr u; if not(mode eq 'symbolic) then lst := list('getrlist,lst); action := car u; u := cdr u; body := formc(car u,(var . mode) . vars,mode); if mod eq 'in then body := list(list('lambda,list var,body),list('car,var)) else if not(mode eq 'symbolic) then typerr(mod,'action); return forformat(action,body,lst, list('null,var),list 'cdr,var,vars,mode) end; put('foreach,'formfn,'formforeach); symbolic procedure forformat(action,body,initval, testexp,updform,var,vars,mode); begin scalar result; result := gensym(); return sublis(list('body2 . if mode eq 'symbolic or intexprnp(body,vars) then list(get(action,'bin),body,result) else list('aeval,list('list,mkquote get(action,'bin), body,result)), 'body3 . if mode eq 'symbolic then body else list('getrlist,body), 'body . body, 'initval . initval, 'nillist . if mode eq 'symbolic then nil else ''(list), 'result . result, 'initresult . get(action,'initval), 'resultlist . if mode eq 'symbolic then result else list('cons,''list,result), 'testexp . testexp, 'updfn . car updform, 'updval . cdr updform, 'var . var), if action eq 'do then '(prog (var) (setq var initval) lab (cond (testexp (return nil))) body (setq var (updfn var . updval)) (go lab)) else if action eq 'collect then '(prog (var result endptr) (setq var initval) (cond (testexp (return nillist))) (setq result (setq endptr (cons body nil))) looplabel (setq var (updfn var . updval)) (cond (testexp (return resultlist))) (rplacd endptr (cons body nil)) (setq endptr (cdr endptr)) (go looplabel)) else if action eq 'conc then '(prog (var result endptr) (setq var initval) startover (cond (testexp (return nillist))) (setq result body) (setq endptr (lastpair resultlist)) (setq var (updfn var . updval)) (cond ((atom endptr) (go startover))) looplabel (cond (testexp (return result))) (rplacd endptr body3) (setq endptr (lastpair endptr)) (setq var (updfn var . updval)) (go looplabel)) else '(prog (var result) (setq var initval) (setq result initresult) lab1 (cond (testexp (return result))) (setq result body2) (setq var (updfn var . updval)) (go lab1))) end; symbolic procedure lastpair u; % Return the last pair of the list u. if atom u or atom cdr u then u else lastpair cdr u; put('join,'newnam,'conc); % alternative for CONC endmodule; module loops; % Looping forms other than the FOR statement. % Author: Anthony C. Hearn % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*blockp); global '(cursym!*); % ***** REPEAT STATEMENT ***** symbolic procedure repeatstat; begin scalar body,!*blockp; flag('(until),'delim); body:= xread t; remflag('(until),'delim); if not cursym!* eq 'until then symerr('repeat,t); return list('repeat,body,xread t); end; symbolic macro procedure repeat u; begin scalar body,bool,lab; body := cadr u; bool := caddr u; lab := gensym(); return mkprog(nil,list(lab,body, list('cond,list(list('not,bool),list('go,lab))))) end; put('repeat,'stat,'repeatstat); flag('(repeat),'nochange); symbolic procedure formrepeat(u,vars,mode); list('repeat,formc(cadr u,vars,mode),formbool(caddr u,vars,mode)); put('repeat,'formfn,'formrepeat); % ***** WHILE STATEMENT ***** symbolic procedure whilstat; begin scalar bool,!*blockp; flag('(do),'delim); bool := xread t; remflag('(do),'delim); if not cursym!* eq 'do then symerr('while,t); return list('while,bool,xread t) end; symbolic macro procedure while u; begin scalar body,bool,lab; bool := cadr u; body := caddr u; lab := gensym(); return mkprog(nil,list(lab,list('cond,list(list('not,bool), list('return,nil))),body,list('go,lab))) end; put('while,'stat,'whilstat); flag('(while),'nochange); symbolic procedure formwhile(u,vars,mode); list('while,formbool(cadr u,vars,mode),formc(caddr u,vars,mode)); put('while,'formfn,'formwhile); endmodule; module write; % Miscellaneous statement definitions. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. % ***** DEFINE STATEMENT ***** remprop('define,'stat); symbolic procedure define u; for each x in u do if not eqcar(x,'equal) or not idp cadr x then typerr(x,"DEFINE declaration") else put(cadr x,'newnam,caddr x); put('define,'stat,'rlis); flag('(define),'eval); % ***** WRITE STATEMENT ***** symbolic procedure formwrite(u,vars,mode); begin scalar bool1,bool2,x,z; u := cdr u; bool1 := mode eq 'symbolic; while u do <>; return mkprog(nil,reversip!* z) end; symbolic procedure writepri(u,v); begin scalar x; x := assgneval u; return varpri(car x,cdr x,v) end; symbolic procedure mkarg1(u,vars); % Returns the "unevaled" form of U for the WRITE command. if null u or constantp u then u else if atom u then if atsoc(u,vars) then list('mkquote,u) else mkquote u else if car u eq 'quote then mkquote u else if car u eq 'setq then list('list,''setq,mkquote cadr u,mkarg1(caddr u,vars)) else 'list . for each x in u collect mkarg1(x,vars); put('write,'stat,'rlis); put('write,'formfn,'formwrite); endmodule; module smacro; % Support for SMACRO expansion. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure applsmacro(u,vals,name); % U is smacro body of form (lambda ), VALS is % argument list, NAME is name of smacro. begin scalar body,remvars,varlist,w; varlist := cadr u; body := caddr u; if length varlist neq length vals then rederr list("Argument mismatch for SMACRO",name); if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body) then return subla!-q(pair(varlist,vals),body) else if length varlist>1 then <>; for each x in vals do <>; if null remvars then return body else <>; return w>> end; symbolic procedure no!-side!-effectp u; if atom u then numberp u or idp u and not(fluidp u or globalp u) else if car u eq 'quote then t else if flagp!*!*(car u,'nosideeffects) then no!-side!-effect!-listp u else nil; symbolic procedure no!-side!-effect!-listp u; null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u; flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons),'nosideeffects); symbolic procedure one!-entryp(u,v); % determines if id U occurs less than twice in V. if atom v then t else if smemq(u,car v) then if smemq(u,cdr v) then nil else one!-entryp(u,car v) else one!-entryp(u,cdr v); symbolic procedure one!-entry!-listp(u,v); null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v); symbolic procedure subla!-q(u,v); begin scalar x; if null u or null v then return v else if atom v then return if x:= atsoc(v,u) then cdr x else v else if car v eq 'quote then return v else return(subla!-q(u,car v) . subla!-q(u,cdr v)) end; endmodule; module infix; % Functions for introducing new infix operators. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*mode); global '(preclis!*); symbolic procedure infix x; begin scalar y; a: if null x then go to b; y := car x; if !*mode eq 'algebraic then mkop y; if not(y member preclis!*) then preclis!* := y . preclis!*; x := cdr x; go to a; b: mkprec() end; symbolic procedure precedence u; begin scalar x,y,z; preclis!* := delete(car u,preclis!*); y := cadr u; x := preclis!*; a: if null x then rederr list (y,"not found") else if y eq car x then <>; z := car x . z; x := cdr x; go to a end; deflist('((infix rlis) (precedence rlis)),'stat); flag('(infix precedence),'eval); endmodule; module where; % Support for a where construct. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. symbolic procedure formwhere(u,vars,mode); begin scalar expn,equivs,y,z; expn := cadr u; equivs := caddr u; if eqcar(equivs,'!*comma!*) then equivs := cdr equivs else equivs := list equivs; for each x in equivs do if not atom x and car x memq '(equal setq) then <> else rederr list(x,"invalid in WHERE statement"); return formc(list('lambda,reversip z,expn) . reversip y, vars,mode) end; put('where,'formfn,'formwhere); % infix where; % We do this explicitly to avoid changing preclis*. deflist('((where 1)),'infix); put('where,'op,'((1 1))); endmodule; module list; % Define a list as a list of expressions in curly brackets. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(orig!* posn!*); global '(cursym!*); % Add to system table. put('list,'tag,'list); put('list,'rtypefn,'(lambda (x) 'list)); % Parsing interface. symbolic procedure xreadlist; % expects a list of expressions enclosed by {, }. % also allows expressions separated by ; --- treats these as progn. begin scalar cursym,delim,lst; if scan() eq '!*rcbkt!* then <>; a: lst := aconc(lst,xread1 'group); cursym := cursym!*; scan(); if cursym eq '!*rcbkt!* then return if delim eq '!*semicol!* then 'progn . lst else 'list . lst else if null delim then delim := cursym else if not(delim eq cursym) then symerr("syntax error: mixed , and ; in list",nil); go to a end; put('!*lcbkt!*,'stat,'xreadlist); newtok '((!{) !*lcbkt!*); newtok '((!}) !*rcbkt!*); flag('(!*rcbkt!*),'delim); flag('(!*rcbkt!*),'nodel); % Evaluation interface. put('list,'evfn,'listeval); symbolic procedure getrlist u; if eqcar(u,'list) then cdr u else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list"); symbolic procedure listeval(u,v); if atom u then listeval(get(u,'rvalue),v) else car u . for each j in cdr u collect reval1(j,v); % Length interface. put('list,'lengthfn,'(lambda (x) (length (cdr x)))); % Printing interface. put('list,'prifn,'listpri); symbolic procedure listpri l; % This definition is basically that of INPRINT, except that it % decides when to split at the comma by looking at the size of % the argument. begin scalar orig,split,u; u := l; l := cdr l; prin2!* get('!*lcbkt!*,'prtch); % Do it this way so table can change. orig := orig!*; orig!* := if posn!*<18 then posn!* else orig!*+3; if null l then go to b; split := treesizep(l,40); % 40 is arbitrary choice. a: maprint(negnumberchk car l,0); l := cdr l; if null l then go to b; oprin '!*comma!*; if split then terpri!* t; go to a; b: prin2!* get('!*rcbkt!*,'prtch); % terpri!* nil; orig!* := orig; return u end; symbolic procedure treesizep(u,n); % true if u has recursively more pairs than n. treesizep1(u,n)=0; symbolic procedure treesizep1(u,n); if atom u then n-1 else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n) else 0; % Definitions of operations on lists symbolic procedure rfirst u; <>; put('first,'psopfn,'rfirst); symbolic procedure parterr(u,v); msgpri("Expression",u,"does not have part",v,t); symbolic procedure rsecond u; <>; put('second,'psopfn,'rsecond); symbolic procedure rthird u; <>; put('third,'psopfn,'rthird); symbolic procedure rrest u; <>; put('rest,'psopfn,'rrest); symbolic procedure rappend u; begin scalar x,y; argnochk ('append . u); if null(getrtype(x := reval car u) eq 'list) then typerr(x,"list") else if null(getrtype(y := reval cadr u) eq 'list) then typerr(y,"list") else return 'list .append(cdr x,cdr y) end; put('append,'psopfn,'rappend); symbolic procedure rcons u; begin scalar x,y; argnochk ('cons . u); if (y := getrtype(x := reval cadr u)) eq 'vector then return prepsq simpdot u else if not(y eq 'list) then typerr(x,"list") else return 'list . reval car u . cdr x end; put('cons,'psopfn,'rcons); symbolic procedure rreverse u; <>; put('reverse,'psopfn,'rreverse); endmodule; module array; % Array statement. % Author: Anthony C. Hearn. % Modifications by: Nancy Kirkwood. % These definitions are very careful about bounds checking. Appropriate % optimizations in a given system might really speed things up. global '(erfg!*); symbolic procedure getel u; % Returns the value of the array element U. getel1(get(car u,'rvalue),cdr u,get(car u,'dimension)); symbolic procedure getel1(u,v,dims); if length v neq length dims then rederr "Incorrect array reference" else if null v then u else if car v geq car dims then rederr "Array out of bounds" else getel1(getv(u,car v),cdr v,cdr dims); symbolic procedure setel(u,v); % Sets array element U to V and returns V. setel1(get(car u,'rvalue),cdr u,v,get(car u,'dimension)); symbolic procedure setel1(u,v,w,dims); if length v neq length dims then rederr "Incorrect array reference" else if car v geq car dims then rederr "Array out of bounds" else if null cdr v then putv(u,car v,w) else setel1(getv(u,car v),cdr v,w,cdr dims); symbolic procedure dimension u; get(u,'dimension); comment further support for REDUCE arrays; symbolic procedure typechk(u,v); begin scalar x; if (x := gettype u) eq v or x eq 'parameter then lprim list(v,u,"redefined") else if x then typerr(list(x,u),v) end; symbolic procedure arrayfn(u,v); % U is the defining mode, V a list of lists, assumed syntactically % correct. ARRAYFN declares each element as an array unless a % semantic mismatch occurs. begin scalar y; for each x in v do <>>> end; symbolic procedure add1lis u; if null u then nil else (car u+1) . add1lis cdr u; symbolic procedure mkarray(u,v); %U is a list of positive integers representing array bounds, V %the defining mode. Value is an array structure; if null u then if v eq 'symbolic then nil else 0 else begin integer n; scalar x; n := car u-1; x := mkvect n; for i:=0:n do putv(x,i,mkarray(cdr u,v)); return x end; rlistat '(array); flag ('(array arrayfn),'eval); symbolic procedure formarray(u,vars,mode); begin scalar x; x := cdr u; while x do <>; u := for each z in cdr u collect intargfn(z,vars,mode); %ARRAY arguments must be returned as quoted structures; return list('arrayfn,mkquote mode,'list . u) end; symbolic procedure listp u; % Returns T if U is a top level list. null u or not atom u and listp cdr u; put('array,'formfn,'formarray); put('array,'rtypefn,'arraychk); symbolic procedure arraychk u; % If arraychk receives NIL, it means that array name is being used % as an identifier. We no longer permit this. if null u then 'array else nil; % nil; put('array,'evfn,'arrayeval); symbolic procedure arrayeval(u,v); % Eventually we'll support this. rederr "Array arithmetic not defined"; put('array,'lengthfn,'arraylength); symbolic procedure arraylength u; 'list . get(u,'dimension); endmodule; module switch; % Support for switches and ON and OFF statements. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. global '(!*switchcheck switchlist!*); % No references to RPLAC-based functions in this module. symbolic procedure on u; onoff(u,t); symbolic procedure off u; onoff(u,nil); symbolic procedure onoff(u,bool); for each j in u do begin scalar x,y; if not idp j then typerr(j,"switch") else if not flagp(j,'switch) then if !*switchcheck then rederr list(j,"not defined as switch") else lpriw("*****",list(j,"not defined as switch")); x := intern compress append(explode '!*,explode j); if !*switchcheck and eval x eq bool then return nil else if y := atsoc(bool,get(j,'simpfg)) then eval mkprog(nil,cdr y); set(x,bool) end; symbolic procedure switch u; % Declare list u as switches. for each x in u do begin scalar y; if not idp x then typerr(x,"switch"); if not u memq switchlist!* then switchlist!* := x . switchlist!*; flag(list x,'switch); y := intern compress append(explode '!*,explode x); if not fluidp y and not globalp y then fluid list y end; deflist('((switch rlis)),'stat); % we use deflist since it's flagged % eval rlistat '(off on); flag ('(off on),'ignore); % Symbolic mode switches: switch backtrace,comp,defn,demo,echo,errcont,int,msg,output,pret, quotenewnam,raise,time; % switchcheck. % The following are compiler switches that may not be supported in all % versions: switch pgwd,plap,pwrds; % flag('(switch),'eval); endmodule; module io; % Reduce functions for handling input and output of files. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*backtrace !*int semic!*); global '(!*echo contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!* techo!*); symbolic procedure file!-transform(u,v); % Performs a transformation on the file u. V is name of function % used for the transformation; begin scalar echo,ichan,oldichan,val; echo := !*echo; !*echo := nil; ichan := open(u,'input); oldichan := rds ichan; val := errorset(list v,t,!*backtrace); !*echo := echo; close ichan; rds oldichan; if not errorp val then return car val end; symbolic procedure infile u; % loads the single file u into REDUCE without echoing; begin scalar !*int; return file!-transform(u,function begin1) end; symbolic procedure in u; begin scalar chan,echo,echop,type; echop := semic!* eq '!;; %record echo character from input; echo := !*echo; %save current echo status; if null ifl!* then techo!* := !*echo; %terminal echo status; for each fl in u do <> else <>; ipl!* := ifl!* . ipl!*; %add to input file stack; !*echo := echop; type := filetype fl; if type and (type := get(type,'action)) then eval list type else begin1(); if chan then close chan; if fl eq caar ipl!* then ipl!* := cdr ipl!* else errach list("FILE STACK CONFUSION",fl,ipl!*)>>; !*echo := echo; %restore echo status; if ipl!* and null contl!* then ifl!* := car ipl!* else ifl!* := nil; if ifl!* then <> else rds nil end; symbolic procedure out u; %U is a list of one file; begin integer n; scalar chan,fl,x; n := linelength nil; if null u then return nil else if car u eq 't then return <>; fl := mkfil car u; if not (x := assoc(fl,opl!*)) then <>>> else ofl!* := x; wrs cdr ofl!*; linelength n end; symbolic procedure shut u; %U is a list of names of files to be shut; begin scalar fl1; for each fl in u do <>; close cdr fl1>> else if not (fl1 := assoc(fl,ipl!*)) then rederr list(fl,"not open") else if fl1 neq ifl!* then <> else rederr list("Cannot shut current input file",car fl1)>> end; deflist ('((in rlis) (out rlis) (shut rlis)),'stat); flag ('(in out shut),'eval); flag ('(in out shut),'ignore); endmodule; module inter; % Functions for interactive support. % Author: Anthony C. Hearn. % Copyright (c) 1987 The RAND Corporation. All rights reserved. fluid '(!*int); global '(!$eof!$ !*echo !*lessspace cloc!* contl!* curline!* edit!* eof!* erfg!* flg!* ifl!* ipl!* key!* ofl!* opl!* techo!*); symbolic procedure pause; %Must appear at the top-most level; if null !*int then nil else if key!* eq 'pause then pause1 nil else %typerr('pause,"lower level command"); pause1 nil; %Allow at lower level for now; symbolic procedure pause1 bool; begin if bool then if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?" then return <>; edit1(cloc!*,nil)>> else if flg!* then return (edit!* := nil); if null ifl!* or yesp "Cont?" then return nil; ifl!* := list(car ifl!*,cadr ifl!*,curline!*); contl!* := ifl!* . !*echo . contl!*; rds (ifl!* := nil); !*echo := techo!* end; symbolic procedure yesp u; begin scalar bool,ifl,ofl,x,y,z; if ifl!* then <>; if ofl!* then <>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (Y or N)"; if null !*lessspace then terpri(); z := setpchar '!?; a: x := read(); % Assume an end-of-file is the same as "yes". if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b; if null bool then prin2t "TYPE Y OR N"; bool := t; go to a; b: setpchar z; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return y end; symbolic procedure cont; begin scalar fl,techo; if ifl!* then return nil %CONT only active from terminal; else if null contl!* then rederr "No file open"; fl := car contl!*; techo := cadr contl!*; contl!* := cddr contl!*; if car fl=caar ipl!* and cadr fl=cadar ipl!* then <> else rds nil; !*echo := techo>> else <> end; deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat); flag ('(cont),'ignore); endmodule; comment Codemist Standard Lisp based REDUCE "back-end"; % this file defines the system dependent code necessary to run REDUCE % under Codemist Standard Lisp comment the following functions, which are referenced in the basic REDUCE source (rlisp, alg1, alg2, matr and phys) should be defined to complete the definition of REDUCE: bye delcp error1 filetype mkfil orderp quit random seprp setpchar. prototypical descriptions of these functions are as follows; remprop('bye,'stat); symbolic procedure bye; % returns control to the computer's operating system command level. % the current REDUCE job cannot be restarted; stop 0; deflist('((bye endstat)),'stat); remprop('quit,'stat); symbolic procedure quit; % returns control to the computer's operating system command level. % the current REDUCE job cannot be restarted; stop 0; deflist('((quit endstat)),'stat); symbolic procedure delcp u; if u = '!; or u = '!$ then t else nil; symbolic procedure filetype u; nil; symbolic procedure mkfil u; % converts file descriptor u into valid system filename; if idp u then u else if stringp u then string2file u else if eqcar(u,'quote) then mkfil cadr u else if atom u then nil else for each z in u collect mkfil z; symbolic procedure string2file s; % converts a string into a valid file name. s; comment the following functions are only referenced if various flags are set, or the functions are actually defined. they are defined in another module, which is not needed to build the basic system. the name of the flag follows the function name, enclosed in parentheses: bfquotient!: (bigfloat) cedit (?) compd (comp) edit1 this function provides a link to an editor. however, a definition is not necessary, since REDUCE checks to see if it has a function value. embfn (?) ezgcdf (ezgcd) factorf (factor) load!-module (?) prettyprint (defn --- also called by dfprint) this function is used in particular for output of RLISP expressions in Lisp syntax. if that feature is needed, and the prettyprint module is not available, then it should be defined as print rprint (pret) texpt!: (bigfloat) texpt!:any (bigfloat) time (time) returns elapsed time from some arbitrary initial point in milliseconds; comment we also need to define a function begin, which acts as the top- level call to REDUCE, and sets the appropriate variables. the following is a minimum definition; fluid '(!*int !*mode); global '(crchar!* date!* ifl!* ipl!* ofl!* !*extraecho !*echo); remflag('(begin),'go); symbolic procedure begin; begin !*int := not batchp(); !*echo := not !*int; !*extraecho := t; ifl!* := ipl!* := ofl!* := nil; if null date!* then go to a; % verbos nil; % leave verbos flag as it had been linelength 79; prin2 date!*; prin2t " ..."; !*mode := if getd 'addsq then 'algebraic else 'symbolic; initreduce(); % resets date!*; erfg!* := !*defn := cmsg!* := nil; % reset error status; a: crchar!* := '! ; if errorp errorset('(begin1),t,!*backtrace) then go to a; if not yesp "are you sure you want to leave REDUCE & enter Lisp?" then go to a; prin2t "entering Lisp ... "; prin2t "type (begin) to re-enter REDUCE, (stop) to exit from Lisp"; end; flag('(begin),'go); comment initial setups for REDUCE; global '(spare!* statcounter); spare!* := 10; symbolic procedure initreduce; %. initial declarations for REDUCE <>; flag('(reclaim rdf),'opfn); % flag('(explode2 printc princ ttab unglobal random next!-random!-number), 'lose); % redo showtime for Codemist Lisp interpretation of gctime vs. time % remflag('(showtime), 'lose); symbolic procedure showtime; begin scalar x,y; x := otime!*; otime!* := time(); x := otime!*-x; y := ogctime!*; ogctime!* := gctime(); y := ogctime!* - y; % x := x - y; % not for Codemist Lisp terpri(); prin2 "Time: "; prin2 x; prin2 " ms"; if y = 0 then return terpri(); prin2 " plus GC time: "; prin2 y; prin2 " ms" end; % flag('(lengthc), 'lose); symbolic procedure typerr(u, v); % redefined when I get to alg1.red, but smashes before then % need some support, I guess << terpri(); princ "+++++ typerr: "; prin u; princ " "; prin v; terpri(); error "typerr called" >>; symbolic procedure flush(); begin scalar c; while (c:=readch()) neq !$eol!$ and c neq !$eof!$ do nil; return nil end; % flag('(cedit1), 'lose); % redefinition of yesp to improve prompt generation % remflag('(yesp), 'lose); symbolic procedure yesp u; begin scalar bool,ifl,ofl,x,y,z; if ifl!* then <>; if ofl!* then <>; if null !*lessspace then terpri(); if atom u then prin2 u else lpri u; prin2t " (y or n)"; if null !*lessspace then terpri(); z := setpchar '!?; a: prin2 '!?; x := read(); % assume an end-of-file is the same as "yes". if (y := x eq 'y or x eq !$eof!$) or x eq 'n then go to b; if null bool then prin2t "type y or n"; bool := t; go to a; b: setpchar z; if ofl then wrs cdr ofl; if ifl then rds cadr ifl; cursym!* := '!*semicol!*; return y end; % support for some more floating point stuff global '(ft!-tolerance!* e!-value!* pi!-value!*); ft!-tolerance!* := float 1 / float 1000000000000; e!-value!* := exp 1.0; pi!-value!* := 4.0 * atan 1.0; comment now set the system name; global '(systemname!*); systemname!* := 'ccl; initreduce(); preserve 'begin; mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/fastgets.lsp0000644000175000017500000000506311550002751024116 0ustar giovannigiovanni% % fastgets.lsp Copyright (C) 1995-2004 Codemist Ltd % (prog (how!-many w n) (setq how!-many 32) (symbol!-make!-fastget how!-many) % It is important that NONCOM is given the fastget tag zero, since that % number is hard coded into the Lisp kernel in "cslread.c" (symbol!-make!-fastget 'noncom 0) (symbol!-make!-fastget 'lose 1) % The following list gives property-list indicators in roughly the % order of priority across the whole range of REDUCE test files provided % with REDUCE 3.6. For each test the number of successful and unsuccessful % property-list accesses was counted. (S and F). The score S+2*F was used % to allow for failing accesses needing to scan all the list, while % successful ones only go on average half way. For each test scores for each % particular indicator were expressed as percentages. Tables of all these % percentages were put together and sorted - the list that follows is what % emerged when only the highest-placed mention of a tag was kept. The effect % should be that the most heavily used tags in each test come in this list. % This list can be longer than the number of fast-get tags I support and only % the relevant number of items on it will be used. % % At present I am assuming that the priority order will be roughly the % same for REDUCE 3.8! % (setq w '( convert rules field opmtch optional noncom rtype dname indexvar phystype oldnam opfn psopfn avalue share zerop prepfn2 newnam onep intequivfn trace polyfn symmetric binding nary ifdegree alt switch!* remember minusp modefn rtypefn infix tokprop full delchar class delim times pprifn spaced simpfn number!-of!-args stat plus i2d prifn idvalfn tag package!-name fkernfn !*decs!* difference rvalue tracing struct prtch kvalue mksqsubfn dfform noform subscripted switch mgen )) (setq n 2) top (cons ((equal n how!-many) (return nil))) (symbol!-make!-fastget (car w) n) (setq w (cdr w)) (setq n (add1 n)) (go top)) % end of fastgets.lsp mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/unbyte.lsp0000644000175000017500000015736311550002751023617 0ustar giovannigiovanni % RLISP to LISP converter. A C Norman 2004-2007 (linelength 72) (de lprim (x) (print x)) (de no!-side!-effectp (u) (cond ((atom u) (or (numberp u) (and (idp u) (not ( or (fluidp u) (globalp u)))))) (t (cond ((eq (car u) (quote quote)) t) (t ( cond ((flagp!*!* (car u) (quote nosideeffects)) (no!-side!-effect!-listp u)) (t nil))))))) (de no!-side!-effect!-listp (u) (or (null u) (and (no!-side!-effectp (car u)) (no!-side!-effect!-listp (cdr u))))) (flag (quote (car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cons)) (quote nosideeffects)) (de structchk (u) (prog (v) (prog nil lab1000 (progn (setq v (copy u)) (setq u (structchk1 u))) (cond ((null (equal u v)) (go lab1000)))) (return u))) (de structchk1 (u) (prog (x) (cond ((or (atom u) (eq (car u) (quote quote))) (return u)) (t (cond ((and (atom (car u)) (setq x (get (car u) (quote structfn)))) (return (apply x (list u)))) (t (cond ((eq (car u) (quote lambda )) (return (list (quote lambda) (cadr u) (structchk1 (caddr u))))) (t (cond ( (eq (car u) (quote procedure)) (return (list (quote procedure) (cadr u) ( caddr u) (cadddr u) (car (cddddr u)) (structchk1 (cadr (cddddr u)))))) (t ( return (prog (var1002 var1003) (setq var1002 u) lab1001 (cond ((null var1002) (return (reversip var1003)))) (prog (x) (setq x (car var1002)) (setq var1003 (cons (structchk1 x) var1003))) (setq var1002 (cdr var1002)) (go lab1001)))) ))))))))) (put (quote cond) (quote structfn) (quote strcond)) (put (quote rblock) (quote structfn) (quote blockchk)) (put (quote prog) (quote structfn) (quote progchk)) (put (quote progn) (quote structfn) (quote prognchk)) (de strcond (u) (prog nil (setq u (prog (var1005 var1006) (setq var1005 (cdr u)) lab1004 (cond ((null var1005) (return (reversip var1006)))) (prog (x) ( setq x (car var1005)) (setq var1006 (cons (list (car x) (structchk1 (cadr x)) ) var1006))) (setq var1005 (cdr var1005)) (go lab1004))) (cond ((and (equal ( length u) 2) (eqcar (cadar u) (quote cond)) (equal (caadr u) (quote t))) ( setq u (cons (list (mknot (caar u)) (cadadr u)) (cdadar u))))) (return (cons (quote cond) u)))) (de mknot (u) (cond ((and (not (atom u)) (memq (car u) (quote (not null)))) ( cadr u)) (t (list (quote not) u)))) (fluid (quote (flg lablist))) (de addlbl (lbl) (cond ((atsoc lbl lablist) nil) (t (setq lablist (cons (list lbl nil) lablist))))) (de addblock (lst) (rplacd (cdr (atsoc (getlbl (caar lst)) lablist)) (cons ( cdar lst) (cdr lst)))) (de gochk (u) (cond ((or (atom u) (memq (car u) (quote (quote prog)))) nil) ( t (cond ((eq (car u) (quote go)) (updlbl (cadr u) u)) (t (progn (gochk (car u )) (gochk (cdr u)))))))) (de updlbl (lbl exp) (prog (x) (setq x (atsoc lbl lablist)) (cond (x (rplaca (cdr x) (cons exp (cadr x)))) (t (setq lablist (cons (list lbl (list exp)) lablist)))))) (de transferp (u) (cond ((or (atom u) (not (idp (car u)))) nil) (t (cond (( flagp (car u) (quote transfer)) (car u)) (t (cond ((eq (car u) (quote cond)) (condtranp (cdr u))) (t (cond ((memq (car u) (quote (prog2 progn))) ( transferp (car (reverse (cdr u))))) (t nil))))))))) (flag (quote (go return rederr error errach)) (quote transfer)) (de condtranp (u) (cond ((null u) nil) (t (cond ((and (null (cdr u)) (eq ( caar u) t)) (transferp (cadar u))) (t (and (transferp (cadar u)) (condtranp ( cdr u)))))))) (de progchk (u) (blockchk1 u (quote prog))) (de blockchk (u) (blockchk1 u (quote rblock))) (de blockchk1 (u v) (prog (flg lablist laststat vars top x z) (setq vars ( cadr u)) (setq u (cddr u)) (cond ((null u) (lprie "empty block"))) (setq x u) (prog nil lab1007 (cond ((null (cdr x)) (return nil))) (setq x (cdr x)) (go lab1007)) (prog nil lab1008 (cond ((null (and u (not (labelp (car u))))) ( return nil))) (progn (setq top (cons (car u) top)) (gochk (car u)) (setq u ( cdr u))) (go lab1008)) (cond ((null u) (progn (setq top (reversip top)) (go ret))) (t (cond ((or (null top) (not (transferp (car top)))) (progn (setq top (cons (list (quote go) (getlbl (car u))) top)) (gochk (car top))))))) (setq top (reversip top)) (setq top (cons (list nil) (cons nil (cons top (car ( reverse top)))))) (prog nil lab1010 (cond ((null u) (return nil))) (cond (( labelp (car u)) (progn (addlbl (getlbl (car u))) (cond ((or (null laststat) ( transferp laststat)) (progn (setq laststat nil) (setq x (list (car u))) (setq u (cdr u)) (prog nil lab1009 (cond ((null (and u (not (transferp laststat))) ) (return nil))) (progn (cond ((labelp (car u)) (setq u (cons (list (quote go ) (getlbl (car u))) u)))) (gochk (car u)) (setq laststat (car u)) (setq x ( cons (car u) x)) (setq u (cdr u))) (go lab1009)) (addblock (cons (reversip x) laststat)) (setq x nil)))))) (t (rederr (list "unreachable statement" (car u ))))) (go lab1010)) (setq lablist (reversip lablist)) a (setq flg nil) (prog (var1012) (setq var1012 (cons top lablist)) lab1011 (cond ((null var1012) ( return nil))) (prog (x) (setq x (car var1012)) (cond ((and (cdr x) (cddr x) ( eqcar (cdddr x) (quote go))) (condgochk (caddr x) (cdddr x))))) (setq var1012 (cdr var1012)) (go lab1011)) (setq x nil) (prog nil lab1013 (cond ((null lablist) (return nil))) (progn (setq z (length (cadar lablist))) (cond ((or ( equal z 0) (and (equal z 1) (equal (cdddar lablist) (caadar lablist)))) ( lprim (list "unreferenced block at label" (caar lablist)))) (t (cond ((equal z 1) (progn (setq flg t) (lprim (list "label" (caar lablist) "removed")) ( rplacw (caadar lablist) (prognchk1 (caddar lablist))))) (t (setq x (cons (car lablist) x)))))) (setq lablist (cdr lablist))) (go lab1013)) (setq lablist ( reversip x)) (prog (var1015) (setq var1015 lablist) lab1014 (cond ((null var1015) (return nil))) (prog (z) (setq z (car var1015)) (cond ((and (equal ( cdddr z) (caadr z)) (eqcar (caaddr z) (quote cond)) (null (cddr (caaddr z))) (transferp (cadadr (caaddr z))) (notranp (cdaddr z))) (progn (setq flg t) ( rplaca (cdr z) (!&deleq (cdddr z) (cadr z))) (rplaca (cddr z) (list (whilechk (mknull (caadr (caaddr z))) (cdr (reverse (cdaddr z)))) (cadadr (caaddr z))) ) (rplacd (cddr z) nil))))) (setq var1015 (cdr var1015)) (go lab1014)) (cond (flg (prog (var1018) (setq var1018 (cons top lablist)) lab1017 (cond ((null var1018) (return nil))) (prog (y) (setq y (car var1018)) (progn (setq z ( caddr y)) (prog nil lab1016 (cond ((null z) (return nil))) (cond ((eqcar (car z) (quote progn)) (rplacw z (nconc (cdar z) (cdr z)))) (t (setq z (cdr z)))) (go lab1016)) (cond ((and (cdr y) (cddr y) (eqcar (cdddr y) (quote progn))) (rplacd (cddr y) (car (reverse (cdddr y)))))))) (setq var1018 (cdr var1018)) (go lab1017)))) (cond (flg (go a))) (setq top (caddr top)) (setq x top) (prog nil lab1020 (cond ((null x) (return nil))) (progn (prog nil lab1019 (cond (( null (cdr x)) (return nil))) (setq x (cdr x)) (go lab1019)) (cond ((and ( eqcar (car x) (quote go)) (setq z (atsoc (cadar x) lablist))) (progn (rplacw x (cond ((cdadr z) (cons (mklbl (car z)) (caddr z))) (t (progn (lprim (list "label" (caar lablist) "removed")) (caddr z))))) (setq lablist (delete z lablist)))) (t (cond (lablist (progn (rplacd x (cons (mklbl (caar lablist)) ( caddar lablist))) (setq lablist (cdr lablist)))) (t (setq x (cdr x))))))) (go lab1020)) ret (setq top (miscchk (structchk1 top))) (cond ((and (null vars) (eqcar (car top) (quote return))) (return (cadar top))) (t (return (cons v ( cons vars top))))))) (de miscchk (u) (prog (v w) (setq v u) (prog nil lab1021 (cond ((null v) ( return nil))) (cond ((and (eqcar (car v) (quote setq)) (neq (setq w (setqchk (car v) (cdr v))) v)) (rplacw v w)) (t (cond ((and (cdr v) (eqcar (car v) ( quote cond)) (null (cddar v)) (eqcar (cadr (cadar v)) (quote return)) (eqcar (cadr v) (quote return))) (rplacw v (cons (list (quote return) (list (quote cond) (list (caadar v) (cadr (cadr (cadar v)))) (list (quote t) (cadr (cadr v ))))) (cddr v)))) (t (setq v (cdr v)))))) (go lab1021)) (return u))) (de setqchk (u v) (prog (x y z) (setq x (cadr u)) (setq y (caddr u)) (cond (( not (no!-side!-effectp y)) (return (cons u v)))) a (cond ((null v) (return ( cons u (reversip z)))) (t (cond ((and (eqcar (car v) (quote return)) ( used!-oncep x (cadar v))) (progn (lprim (list "assignment for" x "removed")) (return (nconc (reversip z) (cons (substq x y (car v)) (cdr v)))))) (t (cond ((not (smemq x (car v))) (progn (setq z (cons (car v) z)) (setq v (cdr v)) ( go a))) (t (return (cons u (nconc (reversip z) v))))))))))) (de used!-oncep (u v) (cond ((atom v) t) (t (cond ((eq (car v) (quote quote)) t) (t (cond ((eq u (car v)) (not (smemq u (cdr v)))) (t (used!-oncep u (cdr v))))))))) (de substq (u v w) (cond ((atom w) (cond ((eq u w) v) (t w))) (t (cond ((eq ( car w) (quote quote)) w) (t (cond ((eq u (car w)) (cons v (cdr w))) (t (cond ((not (atom (car w))) (cons (substq u v (car w)) (substq u v (cdr w)))) (t ( cons (car w) (substq u v (cdr w)))))))))))) (de labelp (u) (or (atom u) (eq (car u) (quote !*label)))) (de getlbl (u) (cond ((atom u) u) (t (cadr u)))) (de mklbl (u) (list (quote !*label) u)) (de notranp (u) (null (smemqlp (quote (go return)) (cdr (reverse u))))) (de !&deleq (u v) (cond ((null v) nil) (t (cond ((eq u (car v)) (cdr v)) (t ( cons (car v) (!&deleq u (cdr v)))))))) (de prognchk (u) (prognchk1 (cdr u))) (de prognchk1 (u) (cond ((or (null (cdr u)) (null (cdr (setq u (miscchk u)))) ) (car u)) (t (cons (quote progn) u)))) (de mknull (u) (cond ((and (not (atom u)) (memq (car u) (quote (null not)))) (cadr u)) (t (list (quote null) u)))) (de condgochk (u v) (cond ((null u) nil) (t (progn (condgochk (cdr u) v) ( cond ((eqcar (car u) (quote cond)) (cgchk1 (cdar u) u v))))))) (de cgchk1 (u v w) (cond ((null u) nil) (t (cond ((not (transferp (cadar u))) nil) (t (prog (x y z) (cgchk1 (cdr u) v w) (setq x (cadar u)) (cond ((or ( equal x w) (and (eqcar x (quote progn)) (equal (setq x (car (reverse x))) w) (setq y (reverse (cdr (reverse (cdadar u))))))) (progn (setq flg t) (setq z ( atsoc (cadr w) lablist)) (rplaca (cdr z) (!&deleq x (cadr z))) (rplaca (car u ) (mknull (caar u))) (setq z (reverse (cdr (reverse (cdr v))))) (cond ((cdr u ) (progn (setq z (cons (cons (quote cond) (cdr u)) z)) (rplacd u nil)))) ( cond (y (rplacd u (list (list t (prognchk1 y)))))) (rplaca (cdar u) ( prognchk1 z)) (rplacd v (list w)))) (t nil)))))))) (de mapox (u) (mapsox u (quote on) (quote do))) (de mapcox (u) (mapsox u (quote in) (quote do))) (de maplistox (u) (mapsox u (quote on) (quote collect))) (de mapcarox (u) (mapsox u (quote in) (quote collect))) (de mapconox (u) (mapsox u (quote on) (quote conc))) (de mapcanox (u) (mapsox u (quote in) (quote conc))) (de mapsox (u v w) (prog (x y z) (setq x (cadr u)) (setq y (caddr u)) (cond ( (not (eqcar y (quote function))) (rederr (list "syntax error in map expression" u)))) (setq y (cadr y)) (cond ((atom y) ( progn (setq z (quote x)) (setq y (list y z)))) (t (cond ((or (not (eq (car y) (quote lambda))) (null (cadr y)) (cdadr y)) (rederr (list "syntax error in map expression" u))) (t (progn (setq z (caadr y)) (setq y ( caddr y))))))) (return (list (quote foreach) z v x w y)))) (put (quote map) (quote structfn) (quote mapox)) (put (quote mapc) (quote structfn) (quote mapcox)) (put (quote maplist) (quote structfn) (quote maplistox)) (put (quote mapcar) (quote structfn) (quote mapcarox)) (put (quote mapcan) (quote structfn) (quote mapcanox)) (put (quote mapcon) (quote structfn) (quote mapconox)) (de whilechk (u v) (prog (w) (return (cond ((and (idp u) (equal (car v) (list (quote setq) u (list (quote cdr) u))) (not (eq (setq w (caronly u (cdr v) ( quote j))) (quote !*failed!*)))) (list (quote progn) (list (quote foreach) ( quote j) (quote in) u (quote do) (prognchk1 (reversip w))) (list (quote setq) u nil))) (t (list (quote while) u (prognchk1 (reversip v)))))))) (de caronly (u v w) (prog (x) (return (cond ((not (smemq u v)) v) (t (cond (( atom v) (cond ((eq u v) (quote !*failed!*)) (t v))) (t (cond ((or (not (idp ( car v))) (not (and (eqcar (cdr v) u) (cdr v) (null (cddr v)) (setq x (get ( car v) (quote carfn)))))) (cmerge (caronly u (car v) w) (caronly u (cdr v) w) )) (t (cond ((eq (car v) (quote car)) w) (t (list x w)))))))))))) (deflist (quote ((car t) (caar car) (cdar cdr) (caaar caar) (cadar cadr) ( cdaar cdar) (cddar cddr) (caaaar caaar) (caadar caadr) (cadaar cadar) (caddar caddr) (cdaaar cdaar) (cdadar cdadr) (cddaar cddar) (cdddar cdddr))) (quote carfn)) (de cmerge (u v) (cond ((or (eq u (quote !*failed!*)) (eq v (quote !*failed!* ))) (quote !*failed!*)) (t (cons u v)))) (fluid (quote (all_jumps))) (fluid (quote (!@a !@b !@w !@stack !@catch))) (global (quote (opnames))) (de unbyte (name) (prog (pc code len env byte r entry_stack w w1 w2 args nargs stack deepest locals all_jumps !@a !@b !@w !@stack !@catch) (setq !@a ( gensym)) (setq !@b (gensym)) (setq !@w (gensym)) (setq !@stack (gensym)) ( setq code (symbol!-env name)) (setq nargs (symbol!-argcount name)) (cond ((or (atom code) (not (bpsp (car code)))) (return nil))) (setq env (cdr code)) ( setq code (car code)) (setq len (bps!-upbv code)) (cond ((fixp nargs) (progn (setq entry_stack nargs) (cond ((lessp nargs 4) (setq pc 0)) (t (setq pc 1))) )) (t (progn (setq entry_stack (cadr nargs)) (cond ((neq (logand (caddr nargs ) 2) 0) (setq entry_stack (plus entry_stack 1)))) (setq pc 2)))) (setq r nil) (setq all_jumps (list nil pc)) (prog nil lab1022 (cond ((null (leq pc len)) (return nil))) (progn (setq byte (bps!-getv code pc)) (setq w (funcall (getv opnames byte) (plus pc 1) code env)) (cond (r (setq w1 (caddr (car r)))) (t ( setq w1 nil))) (cond ((eqcar w1 (quote if)) (setq r (cons (cons pc (cons ( cadr (cadddr w1)) (cdr w))) r))) (t (setq r (cons (cons pc (cons nil (cdr w)) ) r)))) (setq pc (plus pc (car w)))) (go lab1022)) (prog nil lab1023 (cond (( null all_jumps) (return nil))) (progn (setq w (assoc (cadr all_jumps) r)) ( cond ((null w) (error 1 "Branch destination not found"))) (cond ((null (cadr w)) (rplaca (cdr w) (gensym)))) (rplaca (cdr all_jumps) (cadr w)) (setq w ( car all_jumps)) (rplaca all_jumps (quote go)) (setq all_jumps w)) (go lab1023 )) (setq w nil) (prog nil lab1026 (cond ((null r) (return nil))) (progn (setq w1 (cddar r)) (setq w2 w1) (prog nil lab1024 (cond ((null (cdr w2)) (return nil))) (setq w2 (cdr w2)) (go lab1024)) (setq w2 (car w2)) (cond ((and w (not (or (eqcar w2 (quote if)) (eqcar w2 (quote go)) (eqcar w2 (quote return)) ( eqcar w2 (quote throw))))) (progn (setq w1 (append w1 (list (list (quote go) (caar w)))))))) (prog nil lab1025 (cond ((null (null (cadar r))) (return nil) )) (progn (setq r (cdr r)) (setq w1 (append (cddar r) w1))) (go lab1025)) ( setq w (cons (cons (cadar r) (cons nil w1)) w)) (setq r (cdr r))) (go lab1026 )) (rplaca (cdar w) (list nil)) (setq r (list (caar w))) (prog nil lab1029 ( cond ((null r) (return nil))) (prog (n) (setq w1 (assoc (car r) w)) (setq r ( cdr r)) (setq n (caadr w1)) (prog (var1028) (setq var1028 (cddr w1)) lab1027 (cond ((null var1028) (return nil))) (prog (z) (setq z (car var1028)) (progn (cond ((eqcar z (quote freebind)) (setq n (cons (cadr z) n))) (t (cond (( eqcar z (quote freerstr)) (progn (rplaca (cdr z) (car n)) (setq n (cdr n)))) (t (cond ((eqcar z (quote if)) (progn (setq r (set_bind (assoc (cadr (caddr z )) w) r n)) (setq r (set_bind (assoc (cadr (cadddr z)) w) r n)))) (t (cond (( eqcar z (quote go)) (setq r (set_bind (assoc (cadr z) w) r n)))))))))))) ( setq var1028 (cdr var1028)) (go lab1027))) (go lab1029)) (prog (var1031) ( setq var1031 w) lab1030 (cond ((null var1031) (return nil))) (prog (z) (setq z (car var1031)) (rplaca (cdr z) nil)) (setq var1031 (cdr var1031)) (go lab1030)) (rplaca (cdar w) entry_stack) (setq deepest entry_stack) (setq r ( list (caar w))) (prog nil lab1034 (cond ((null r) (return nil))) (prog (n) ( setq w1 (assoc (car r) w)) (cond ((null w1) (progn (prin (car r)) (princ " not found in ") (print w) (error 1 r)))) (setq r (cdr r)) (setq n (cadr w1) ) (cond ((greaterp n deepest) (setq deepest n))) (prog (var1033) (setq var1033 (cddr w1)) lab1032 (cond ((null var1033) (return nil))) (prog (z) ( setq z (car var1033)) (progn (cond ((equal z (quote push)) (setq n (plus n 1) )) (t (cond ((equal z (quote lose)) (setq n (difference n 1))) (t (cond (( eqcar z (quote freebind)) (setq n (plus n 2 (length (cadr z))))) (t (cond (( equal z (quote pvbind)) (setq n (plus n 2))) (t (cond ((eqcar z (quote freerstr)) (setq n (difference (difference n 2) (length (cadr z))))) (t (cond ((equal z (quote pvrestore)) (setq n (difference n 2))) (t (cond ((or (equal z (quote uncatch)) (equal z (quote unprotect))) (setq n (difference n 3))) ( t (cond ((eqcar z (quote if)) (progn (cond ((eqcar (cadr z) !@catch) (progn ( setq n (plus n 3)) (rplaca z (quote ifcatch))))) (setq r (set_stack (assoc ( cadr (caddr z)) w) r n)) (setq r (set_stack (assoc (cadr (cadddr z)) w) r n)) )) (t (cond ((eqcar z (quote go)) (setq r (set_stack (assoc (cadr z) w) r n)) )))))))))))))))))) (cond ((lessp n entry_stack) (error 1 "Too many POPs in the codestream")) (t (cond ((greaterp n deepest) (setq deepest n))))))) (setq var1033 (cdr var1033)) (go lab1032))) (go lab1034)) ( setq args (setq stack (setq locals nil))) (cond ((fixp nargs) (progn (prog (i ) (setq i 1) lab1035 (cond ((minusp (times 1 (difference nargs i))) (return nil))) (setq stack (cons (gensym) stack)) (setq i (plus i 1)) (go lab1035)) ( setq args (reverse stack)))) (t (progn (prog (i) (setq i 1) lab1036 (cond (( minusp (times 1 (difference (car nargs) i))) (return nil))) (setq stack (cons (gensym) stack)) (setq i (plus i 1)) (go lab1036)) (setq args stack) (cond ( (not (equal (cadr nargs) (car nargs))) (progn (setq args (cons (quote !&optional) args)) (prog (i) (setq i (plus (car nargs) 1)) lab1037 (cond (( minusp (times 1 (difference (cadr nargs) i))) (return nil))) (progn (setq w1 (gensym)) (setq stack (cons w1 stack)) (cond ((equal (logand (caddr nargs) 1) 0) (setq args (cons w1 args))) (t (setq args (cons (list w1 (quote (quote !*spid!*))) args))))) (setq i (plus i 1)) (go lab1037)) (cond ((neq (logand ( caddr nargs) 2) 0) (progn (setq w1 (gensym)) (setq stack (cons w1 stack)) ( setq args (cons w1 (cons (quote !&rest) args))))))))) (setq args (reverse args))))) (setq locals (list !@a !@b !@w)) (prog (i) (setq i (plus 1 (length stack))) lab1038 (cond ((minusp (times 1 (difference deepest i))) (return nil ))) (setq locals (cons (gensym) locals)) (setq i (plus i 1)) (go lab1038)) ( prog (var1042) (setq var1042 w) lab1041 (cond ((null var1042) (return nil))) (prog (b) (setq b (car var1042)) (prog (m z1) (setq m (cadr b)) (cond ((not ( fixp m)) (error 1 "Unreferenced code block"))) (prog (var1040) (setq var1040 (cddr b)) lab1039 (cond ((null var1040) (return nil))) (prog (z) (setq z (car var1040)) (progn (cond ((equal z (quote push)) (setq m (plus m 1))) (t (cond ((equal z (quote lose)) (setq m (difference m 1))) (t (cond ((eqcar z (quote freebind)) (setq m (plus m 2 (length (cadr z))))) (t (cond ((equal z (quote pvbind)) (setq m (plus m 2))) (t (cond ((eqcar z (quote freerstr)) (setq m ( difference (difference m 2) (length (cadr z))))) (t (cond ((equal z (quote pvrestore)) (setq m (difference m 2))) (t (cond ((or (equal z (quote uncatch) ) (equal z (quote unprotect))) (setq m (difference m 3))) (t (progn (setq z1 (stackref z m stack locals entry_stack)) (rplaca z (car z1)) (rplacd z (cdr z1))))))))))))))))))) (setq var1040 (cdr var1040)) (go lab1039)))) (setq var1042 (cdr var1042)) (go lab1041)) (setq w (fix_free_bindings w)) (setq w ( optimise_blocks w stack locals)) (setq r (cons (quote prog) (cons locals ( flowgraph_to_lisp w)))) (terpri) (princ "=> ") (prettyprint r) (setq w ( errorset (list (quote structchk) (mkquote r)) t t)) (cond ((not (atom w)) ( setq r (car w)))) (setq r (list (quote de) name args r)) (terpri) (princ "Finally: ") (prettyprint r) (return nil))) (de flowgraph_to_lisp (w) (prog (r) (prog (var1046) (setq var1046 w) lab1045 (cond ((null var1046) (return nil))) (prog (i) (setq i (car var1046)) (progn (setq r (cons (car i) r)) (prog (var1044) (setq var1044 (cddr i)) lab1043 ( cond ((null var1044) (return nil))) (prog (j) (setq j (car var1044)) (progn ( cond ((eqcar j (quote prog)) (setq r (cons (cons (quote prog) (cons (cadr j) (flowgraph_to_lisp (cddr j)))) r))) (t (cond ((eqcar j (quote if)) (setq r ( cons (list (quote cond) (list (cadr j) (caddr j)) (list (quote t) (cadddr j)) ) r))) (t (cond ((or (eqcar j (quote freerstr)) (eqcar j (quote progexits))) nil) (t (cond ((not (member j (quote (push lose)))) (setq r (cons j r)))))))) )))) (setq var1044 (cdr var1044)) (go lab1043)))) (setq var1046 (cdr var1046) ) (go lab1045)) (return (reversip r)))) (de set_stack (block r n) (cond ((null (cadr block)) (progn (rplaca (cdr block) n) (cons (car block) r))) (t (cond ((not (equal (cadr block) n)) ( progn (printc "++++ Stack confusion") (prin n) (princ " vs. ") (print block) r)) (t r))))) (de set_bind (block r n) (cond ((null (cadr block)) (progn (rplaca (cdr block ) (list n)) (cons (car block) r))) (t (cond ((not (equal (caadr block) n)) ( progn (printc "++++ Binding confusion") (prin n) (princ " vs. ") (print block ) r)) (t r))))) (de stackref (u m stack locals entry_stack) (cond ((or (atom u) (eqcar u ( quote quote))) u) (t (cond ((eqcar u !@stack) (prog (n x) (setq n (cadr u)) ( setq x (plus (difference n m) entry_stack)) (cond ((geq x 0) (progn (cond (( geq x entry_stack) (error 1 "Reference outside stack-frame"))) (prog (i) ( setq i 1) lab1047 (cond ((minusp (times 1 (difference x i))) (return nil))) ( setq stack (cdr stack)) (setq i (plus i 1)) (go lab1047)) (return (car stack) ))) (t (progn (prog (i) (setq i 1) lab1048 (cond ((minusp (times 1 ( difference (minus (plus x 1)) i))) (return nil))) (setq locals (cdr locals)) (setq i (plus i 1)) (go lab1048)) (return (car locals))))))) (t (prog ( var1050 var1051) (setq var1050 u) lab1049 (cond ((null var1050) (return ( reversip var1051)))) (prog (x) (setq x (car var1050)) (setq var1051 (cons ( stackref x m stack locals entry_stack) var1051))) (setq var1050 (cdr var1050) ) (go lab1049))))))) (setq opnames (mkvect 255)) (setq s!:opcodelist (quote (LOADLOC LOADLOC0 LOADLOC1 LOADLOC2 LOADLOC3 LOADLOC4 LOADLOC5 LOADLOC6 LOADLOC7 LOADLOC8 LOADLOC9 LOADLOC10 LOADLOC11 LOC0LOC1 LOC1LOC2 LOC2LOC3 LOC1LOC0 LOC2LOC1 LOC3LOC2 VNIL LOADLIT LOADLIT1 LOADLIT2 LOADLIT3 LOADLIT4 LOADLIT5 LOADLIT6 LOADLIT7 LOADFREE LOADFREE1 LOADFREE2 LOADFREE3 LOADFREE4 STORELOC STORELOC0 STORELOC1 STORELOC2 STORELOC3 STORELOC4 STORELOC5 STORELOC6 STORELOC7 STOREFREE STOREFREE1 STOREFREE2 STOREFREE3 LOADLEX STORELEX CLOSURE CARLOC0 CARLOC1 CARLOC2 CARLOC3 CARLOC4 CARLOC5 CARLOC6 CARLOC7 CARLOC8 CARLOC9 CARLOC10 CARLOC11 CDRLOC0 CDRLOC1 CDRLOC2 CDRLOC3 CDRLOC4 CDRLOC5 CAARLOC0 CAARLOC1 CAARLOC2 CAARLOC3 CALL0 CALL1 CALL2 CALL2R CALL3 CALLN CALL0_0 CALL0_1 CALL0_2 CALL0_3 CALL1_0 CALL1_1 CALL1_2 CALL1_3 CALL1_4 CALL1_5 CALL2_0 CALL2_1 CALL2_2 CALL2_3 CALL2_4 BUILTIN0 BUILTIN1 BUILTIN2 BUILTIN2R BUILTIN3 APPLY1 APPLY2 APPLY3 APPLY4 JCALL JCALLN JUMP JUMP_B JUMP_L JUMP_BL JUMPNIL JUMPNIL_B JUMPNIL_L JUMPNIL_BL JUMPT JUMPT_B JUMPT_L JUMPT_BL JUMPATOM JUMPATOM_B JUMPATOM_L JUMPATOM_BL JUMPNATOM JUMPNATOM_B JUMPNATOM_L JUMPNATOM_BL JUMPEQ JUMPEQ_B JUMPEQ_L JUMPEQ_BL JUMPNE JUMPNE_B JUMPNE_L JUMPNE_BL JUMPEQUAL JUMPEQUAL_B JUMPEQUAL_L JUMPEQUAL_BL JUMPNEQUAL JUMPNEQUAL_B JUMPNEQUAL_L JUMPNEQUAL_BL JUMPL0NIL JUMPL0T JUMPL1NIL JUMPL1T JUMPL2NIL JUMPL2T JUMPL3NIL JUMPL3T JUMPL4NIL JUMPL4T JUMPST0NIL JUMPST0T JUMPST1NIL JUMPST1T JUMPST2NIL JUMPST2T JUMPL0ATOM JUMPL0NATOM JUMPL1ATOM JUMPL1NATOM JUMPL2ATOM JUMPL2NATOM JUMPL3ATOM JUMPL3NATOM JUMPFREE1NIL JUMPFREE1T JUMPFREE2NIL JUMPFREE2T JUMPFREE3NIL JUMPFREE3T JUMPFREE4NIL JUMPFREE4T JUMPFREENIL JUMPFREET JUMPLIT1EQ JUMPLIT1NE JUMPLIT2EQ JUMPLIT2NE JUMPLIT3EQ JUMPLIT3NE JUMPLIT4EQ JUMPLIT4NE JUMPLITEQ JUMPLITNE JUMPB1NIL JUMPB1T JUMPB2NIL JUMPB2T JUMPFLAGP JUMPNFLAGP JUMPEQCAR JUMPNEQCAR CATCH CATCH_B CATCH_L CATCH_BL UNCATCH THROW PROTECT UNPROTECT PVBIND PVRESTORE FREEBIND FREERSTR EXIT NILEXIT LOC0EXIT LOC1EXIT LOC2EXIT PUSH PUSHNIL PUSHNIL2 PUSHNIL3 PUSHNILS POP LOSE LOSE2 LOSE3 LOSES SWOP EQ EQCAR EQUAL NUMBERP CAR CDR CAAR CADR CDAR CDDR CONS NCONS XCONS ACONS LENGTH LIST2 LIST2STAR LIST3 PLUS2 ADD1 DIFFERENCE SUB1 TIMES2 GREATERP LESSP FLAGP GET LITGET GETV QGETV QGETVN BIGSTACK BIGCALL ICASE FASTGET SPARE1 SPARE2))) (prog (w) (setq w s!:opcodelist) (prog (i) (setq i 0) lab1054 (cond ((minusp (times 1 (difference 255 i))) (return nil))) (progn (putv opnames i (compress (cons (quote h) (cons (quote !!) (cons (quote !:) (explode (car w))))))) ( setq w (cdr w))) (setq i (plus i 1)) (go lab1054))) (global (quote (builtin0 builtin1 builtin2 builtin3))) (setq builtin0 (mkvect 255)) (setq builtin1 (mkvect 255)) (setq builtin2 (mkvect 255)) (setq builtin3 (mkvect 255)) (prog (var1056) (setq var1056 (oblist)) lab1055 (cond ((null var1056) (return nil))) (prog (x) (setq x (car var1056)) (prog (w) (cond ((setq w (get x ( quote s!:builtin0))) (putv builtin0 w x)) (t (cond ((setq w (get x (quote s!:builtin1))) (putv builtin1 w x)) (t (cond ((setq w (get x (quote s!:builtin2))) (putv builtin2 w x)) (t (cond ((setq w (get x (quote s!:builtin3))) (putv builtin3 w x))))))))))) (setq var1056 (cdr var1056)) (go lab1055)) (off echo) (de byte1 nil (bps!-getv code pc)) (de byte2 nil (bps!-getv code (plus pc 1))) (de twobytes nil (plus (times 256 (byte1)) (byte2))) (de makeif (why loc) (list (quote if) why loc (list (quote go) (gensym)))) (de jumpto (x) (setq all_jumps (list all_jumps x))) (de jumpop (why) (list 2 (makeif why (jumpto (plus pc (byte1) 1))))) (de jumpopb (why) (list 2 (makeif why (jumpto (plus (difference pc (byte1)) 1 ))))) (de jumpopl (why) (list 3 (makeif why (jumpto (plus pc (twobytes) 1))))) (de jumpopbl (why) (list 3 (makeif why (jumpto (plus (difference pc (twobytes )) 1))))) (progn (de h!:LOADLOC (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack (byte1))))) (de h!:LOADLOC0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 0)))) (de h!:LOADLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (list !@stack 1)))) (de h!:LOADLOC2 (pc code env) (list 1 ( list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 2)))) (de h!:LOADLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 3)))) (de h!:LOADLOC4 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 4)))) (de h!:LOADLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 5)))) (de h!:LOADLOC6 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 6)))) (de h!:LOADLOC7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 7)))) (de h!:LOADLOC8 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 8)))) (de h!:LOADLOC9 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 9)))) (de h!:LOADLOC10 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 10)))) (de h!:LOADLOC11 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list !@stack 11)))) (de h!:LOC0LOC1 (pc code env) (list 1 (list ( quote setq) !@b (list !@stack 0)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC1LOC2 (pc code env) (list 1 (list (quote setq) !@b (list !@stack 1) ) (list (quote setq) !@a (list !@stack 2)))) (de h!:LOC2LOC3 (pc code env) ( list 1 (list (quote setq) !@b (list !@stack 2)) (list (quote setq) !@a (list !@stack 3)))) (de h!:LOC1LOC0 (pc code env) (list 1 (list (quote setq) !@b ( list !@stack 1)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC2LOC1 ( pc code env) (list 1 (list (quote setq) !@b (list !@stack 2)) (list (quote setq) !@a (list !@stack 1)))) (de h!:LOC3LOC2 (pc code env) (list 1 (list ( quote setq) !@b (list !@stack 3)) (list (quote setq) !@a (list !@stack 2)))) (de h!:VNIL (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a nil))) (de freeref (env n) (cond ((or (lessp n 0) (greaterp n (upbv env))) (error 1 "free variable (etc) reference failure")) (t (getv env n)))) (de litref (env n) (cond ((or (lessp n 0) (greaterp n (upbv env))) (error 1 "literal reference failure")) (t (mkquote (getv env n))))) (de h!:LOADLIT (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env (byte1))))) (de h!:LOADLIT1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 1)))) (de h!:LOADLIT2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 2)))) (de h!:LOADLIT3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (litref env 3)))) (de h!:LOADLIT4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 4)))) (de h!:LOADLIT5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (litref env 5)))) (de h!:LOADLIT6 (pc code env) (list 1 (list ( quote setq) !@b !@a) (list (quote setq) !@a (litref env 6)))) (de h!:LOADLIT7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a ( litref env 7)))) (de h!:LOADFREE (pc code env) (list 2 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env (byte1))))) (de h!:LOADFREE1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 1)))) (de h!:LOADFREE2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 2)))) (de h!:LOADFREE3 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (freeref env 3)))) (de h!:LOADFREE4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (freeref env 4)))) (de h!:STORELOC (pc code env) (list 2 ( list (quote setq) (list !@stack (byte1)) !@a))) (de h!:STORELOC0 (pc code env ) (list 1 (list (quote setq) (list !@stack 0) !@a))) (de h!:STORELOC1 (pc code env) (list 1 (list (quote setq) (list !@stack 1) !@a))) (de h!:STORELOC2 (pc code env) (list 1 (list (quote setq) (list !@stack 2) !@a))) (de h!:STORELOC3 (pc code env) (list 1 (list (quote setq) (list !@stack 3) !@a))) (de h!:STORELOC4 (pc code env) (list 1 (list (quote setq) (list !@stack 4) !@a))) (de h!:STORELOC5 (pc code env) (list 1 (list (quote setq) (list !@stack 5) !@a))) (de h!:STORELOC6 (pc code env) (list 1 (list (quote setq) ( list !@stack 6) !@a))) (de h!:STORELOC7 (pc code env) (list 1 (list (quote setq) (list !@stack 7) !@a))) (de h!:STOREFREE (pc code env) (list 2 (list ( quote setq) (freeref env (byte1)) !@a))) (de h!:STOREFREE1 (pc code env) ( list 1 (list (quote setq) (freeref env 1) !@a))) (de h!:STOREFREE2 (pc code env) (list 1 (list (quote setq) (freeref env 2) !@a))) (de h!:STOREFREE3 (pc code env) (list 1 (list (quote setq) (freeref env 3) !@a))) (de h!:LOADLEX ( pc code env) (prog nil (error 1 "loadlex") (return (list 3 (quote loadlex)))) ) (de h!:STORELEX (pc code env) (prog nil (error 1 "storelex") (return (list 3 (quote storelex))))) (de h!:CLOSURE (pc code env) (prog nil (error 1 "closure") (return (list 2 (quote closure))))) (de h!:CARLOC0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) ( list !@stack 0))))) (de h!:CARLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 1))))) (de h!:CARLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 2))))) (de h!:CARLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 3))))) (de h!:CARLOC4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 4))))) (de h!:CARLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 5))))) (de h!:CARLOC6 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 6))))) (de h!:CARLOC7 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 7))))) (de h!:CARLOC8 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 8))))) (de h!:CARLOC9 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 9))))) (de h!:CARLOC10 (pc code env) (list 1 (list (quote setq ) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 10))))) (de h!:CARLOC11 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote car) (list !@stack 11))))) (de h!:CDRLOC0 (pc code env ) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr ) (list !@stack 0))))) (de h!:CDRLOC1 (pc code env) (list 1 (list (quote setq ) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 1))))) (de h!:CDRLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 2))))) (de h!:CDRLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 3))))) (de h!:CDRLOC4 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 4))))) (de h!:CDRLOC5 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote cdr) (list !@stack 5))))) (de h!:CAARLOC0 (pc code env ) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote caar) (list !@stack 0))))) (de h!:CAARLOC1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (quote caar) (list !@stack 1)))) ) (de h!:CAARLOC2 (pc code env) (list 1 (list (quote setq) !@b !@a) (list ( quote setq) !@a (list (quote caar) (list !@stack 2))))) (de h!:CAARLOC3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list ( quote car) (list !@stack 3))))) (de h!:CALL0 (pc code env) (list 2 (list ( quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env (byte1)))))) ( de h!:CALL1 (pc code env) (list 2 (list (quote setq) !@a (list (freeref env ( byte1)) !@a)))) (de h!:CALL2 (pc code env) (list 2 (list (quote setq) !@a ( list (freeref env (byte1)) !@b !@a)))) (de h!:CALL2R (pc code env) (list 2 ( list (quote setq) !@a (list (freeref env (byte1)) !@a !@b)))) (de h!:CALL3 ( pc code env) (list 2 (list (quote setq) !@a (expand_call 3 (freeref env ( byte1)))) (quote lose))) (de h!:CALLN (pc code env) (prog (n w) (setq n ( byte1)) (prog (i) (setq i 1) lab1057 (cond ((minusp (times 1 (difference ( difference n 2) i))) (return nil))) (setq w (cons (quote lose) w)) (setq i ( plus i 1)) (go lab1057)) (return (list!* 3 (list (quote setq) !@a ( expand_call n (freeref env (byte2)))) w)))) (de h!:CALL0_0 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 0))))) (de h!:CALL0_1 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 1))))) (de h!:CALL0_2 (pc code env) ( list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 2))))) (de h!:CALL0_3 (pc code env) (list 1 (list (quote setq) !@b !@a) (list (quote setq) !@a (list (freeref env 3))))) (de h!:CALL1_0 (pc code env) ( list 1 (list (quote setq) !@a (list (freeref env 0) !@a)))) (de h!:CALL1_1 ( pc code env) (list 1 (list (quote setq) !@a (list (freeref env 1) !@a)))) (de h!:CALL1_2 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 2 ) !@a)))) (de h!:CALL1_3 (pc code env) (list 1 (list (quote setq) !@a (list ( freeref env 3) !@a)))) (de h!:CALL1_4 (pc code env) (list 1 (list (quote setq ) !@a (list (freeref env 4) !@a)))) (de h!:CALL1_5 (pc code env) (list 1 ( list (quote setq) !@a (list (freeref env 5) !@a)))) (de h!:CALL2_0 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 0) !@b !@a)))) (de h!:CALL2_1 (pc code env) (list 1 (list (quote setq) !@a (list (freeref env 1) !@b !@a)))) (de h!:CALL2_2 (pc code env) (list 1 (list (quote setq) !@a ( list (freeref env 2) !@b !@a)))) (de h!:CALL2_3 (pc code env) (list 1 (list ( quote setq) !@a (list (freeref env 3) !@b !@a)))) (de h!:CALL2_4 (pc code env ) (list 1 (list (quote setq) !@a (list (freeref env 4) !@b !@a)))) (de h!:BUILTIN0 (pc code env) (prog (w) (setq w (getv builtin0 (byte1))) (cond (( null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 ( list (quote setq) !@a (list w)))))) (de h!:BUILTIN1 (pc code env) (prog (w) ( setq w (getv builtin1 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@a)))))) (de h!:BUILTIN2 (pc code env) (prog (w) (setq w (getv builtin2 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@b !@a)))))) (de h!:BUILTIN2R (pc code env) (prog (w) (setq w ( getv builtin2 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (list w !@a !@b)))))) (de h!:BUILTIN3 (pc code env) (prog (w) (setq w ( getv builtin3 (byte1))) (cond ((null w) (error 1 "Invalid builtin-function specifier"))) (return (list 2 (list (quote setq) !@a (expand_call 3 w)) (quote lose))))) (de h!:APPLY1 (pc code env) (list 1 ( list (quote setq) !@a (list (quote apply) !@b !@a)))) (de h!:APPLY2 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) !@b !@a)) (quote lose))) (de h!:APPLY3 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) (list !@stack 1) !@b !@a)) (quote lose) (quote lose))) (de h!:APPLY4 (pc code env) (list 1 (list (quote setq) !@a (list (quote apply) (list !@stack 0) (list !@stack 1) (list !@stack 2) !@b !@a)) (quote lose) (quote lose) (quote lose))) (de h!:JCALL (pc code env) (prog (nargs dest) (setq nargs (byte1)) (setq dest (freeref env (logand nargs 31))) (setq nargs (irightshift nargs 5)) (return (list 2 (expand_jcall nargs dest))))) (de h!:JCALLN (pc code env) (list 3 (expand_jcall (byte2) ( freeref env (byte1))))) (de expand_jcall (nargs dest) (list (quote return) ( expand_call nargs dest))) (de expand_call (nargs dest) (cond ((equal nargs 0) (list dest)) (t (cond ((equal nargs 1) (list dest !@a)) (t (cond ((equal nargs 2) (list dest !@b !@a)) (t (prog (w) (setq w (list !@b !@a)) (prog (i) (setq i 1) lab1058 (cond ((minusp (times 1 (difference (difference nargs 2) i ))) (return nil))) (setq w (cons (list !@stack i) w)) (setq i (plus i 1)) (go lab1058)) (return (cons dest w)))))))))) (de h!:JUMP (pc code env) (list 2 ( jumpto (plus pc (byte1) 1)))) (de h!:JUMP_B (pc code env) (list 2 (jumpto ( plus (difference pc (byte1)) 1)))) (de h!:JUMP_L (pc code env) (list 3 ( jumpto (plus pc (twobytes) 1)))) (de h!:JUMP_BL (pc code env) (list 3 (jumpto (plus (difference pc (twobytes)) 1)))) (de h!:JUMPNIL (pc code env) (jumpop (list (quote null) !@a))) (de h!:JUMPNIL_B (pc code env) (jumpopb (list ( quote null) !@a))) (de h!:JUMPNIL_L (pc code env) (jumpopl (list (quote null) !@a))) (de h!:JUMPNIL_BL (pc code env) (jumpopbl (list (quote null) !@a))) ( de h!:JUMPT (pc code env) (jumpop !@a)) (de h!:JUMPT_B (pc code env) (jumpopb !@a)) (de h!:JUMPT_L (pc code env) (jumpopl !@a)) (de h!:JUMPT_BL (pc code env) (jumpopbl !@a)) (de h!:JUMPATOM (pc code env) (jumpop (list (quote atom) !@a))) (de h!:JUMPATOM_B (pc code env) (jumpopb (list (quote atom) !@a))) ( de h!:JUMPATOM_L (pc code env) (jumpopl (list (quote atom) !@a))) (de h!:JUMPATOM_BL (pc code env) (jumpopbl (list (quote atom) !@a))) (de h!:JUMPNATOM (pc code env) (jumpop (list (quote not) (list (quote atom) !@a)) )) (de h!:JUMPNATOM_B (pc code env) (jumpopb (list (quote not) (list (quote atom) !@a)))) (de h!:JUMPNATOM_L (pc code env) (jumpopl (list (quote not) ( list (quote atom) !@a)))) (de h!:JUMPNATOM_BL (pc code env) (jumpopbl (list ( quote not) (list (quote atom) !@a)))) (de h!:JUMPEQ (pc code env) (jumpop ( list (quote eq) !@b !@a))) (de h!:JUMPEQ_B (pc code env) (jumpopb (list ( quote eq) !@b !@a))) (de h!:JUMPEQ_L (pc code env) (jumpopl (list (quote eq) !@b !@a))) (de h!:JUMPEQ_BL (pc code env) (jumpopbl (list (quote eq) !@b !@a) )) (de h!:JUMPNE (pc code env) (jumpop (list (quote not) (list (quote eq) !@b !@a)))) (de h!:JUMPNE_B (pc code env) (jumpopb (list (quote not) (list ( quote eq) !@b !@a)))) (de h!:JUMPNE_L (pc code env) (jumpopl (list (quote not ) (list (quote eq) !@b !@a)))) (de h!:JUMPNE_BL (pc code env) (jumpopbl (list (quote not) (list (quote eq) !@b !@a)))) (de h!:JUMPEQUAL (pc code env) ( jumpop (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_B (pc code env) ( jumpopb (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_L (pc code env) ( jumpopl (list (quote equal) !@b !@a))) (de h!:JUMPEQUAL_BL (pc code env) ( jumpopbl (list (quote equal) !@b !@a))) (de h!:JUMPNEQUAL (pc code env) ( jumpop (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_B (pc code env) (jumpopb (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_L (pc code env) (jumpopl (list (quote not) (list (quote equal) !@b !@a)))) (de h!:JUMPNEQUAL_BL (pc code env) (jumpopbl (list (quote not) ( list (quote equal) !@b !@a)))) (de h!:JUMPL0NIL (pc code env) (jumpop (list ( quote null) (list !@stack 0)))) (de h!:JUMPL0T (pc code env) (jumpop (list !@stack 0))) (de h!:JUMPL1NIL (pc code env) (jumpop (list (quote null) (list !@stack 1)))) (de h!:JUMPL1T (pc code env) (jumpop (list !@stack 1))) (de h!:JUMPL2NIL (pc code env) (jumpop (list (quote null) (list !@stack 2)))) (de h!:JUMPL2T (pc code env) (jumpop (list !@stack 2))) (de h!:JUMPL3NIL (pc code env) (jumpop (list (quote null) (list !@stack 3)))) (de h!:JUMPL3T (pc code env) (jumpop (list !@stack 3))) (de h!:JUMPL4NIL (pc code env) (jumpop ( list (quote null) (list !@stack 4)))) (de h!:JUMPL4T (pc code env) (jumpop ( list !@stack 4))) (de h!:JUMPST0NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 0) !@a)))) (de h!:JUMPST0T (pc code env) ( jumpop (list (quote setq) (list !@stack 0) !@a))) (de h!:JUMPST1NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 1) !@a)))) ( de h!:JUMPST1T (pc code env) (jumpop (list (quote setq) (list !@stack 1) !@a) )) (de h!:JUMPST2NIL (pc code env) (jumpop (list (quote null) (list (quote setq) (list !@stack 2) !@a)))) (de h!:JUMPST2T (pc code env) (jumpop (list ( quote setq) (list !@stack 2) !@a))) (de h!:JUMPL0ATOM (pc code env) (jumpop ( list (quote atom) (list !@stack 0)))) (de h!:JUMPL0NATOM (pc code env) ( jumpop (list (quote not) (list (quote atom) (list !@stack 0))))) (de h!:JUMPL1ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 1)))) ( de h!:JUMPL1NATOM (pc code env) (jumpop (list (quote not) (list (quote atom) (list !@stack 1))))) (de h!:JUMPL2ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 2)))) (de h!:JUMPL2NATOM (pc code env) (jumpop (list ( quote not) (list (quote atom) (list !@stack 2))))) (de h!:JUMPL3ATOM (pc code env) (jumpop (list (quote atom) (list !@stack 3)))) (de h!:JUMPL3NATOM (pc code env) (jumpop (list (quote not) (list (quote atom) (list !@stack 3))))) ( de h!:JUMPFREE1NIL (pc code env) (jumpop (list (quote null) (freeref env 1))) ) (de h!:JUMPFREE1T (pc code env) (jumpop (freeref env 1))) (de h!:JUMPFREE2NIL (pc code env) (jumpop (list (quote null) (freeref env 2)))) ( de h!:JUMPFREE2T (pc code env) (jumpop (freeref env 2))) (de h!:JUMPFREE3NIL (pc code env) (jumpop (list (quote null) (freeref env 3)))) (de h!:JUMPFREE3T (pc code env) (jumpop (freeref env 3))) (de h!:JUMPFREE4NIL (pc code env) ( jumpop (list (quote null) (freeref env 4)))) (de h!:JUMPFREE4T (pc code env) (jumpop (freeref env 4))) (de h!:JUMPFREENIL (pc code env) (list 3 (makeif ( list (quote null) (freeref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPFREET (pc code env) (list 3 (makeif (freeref env (byte1)) (jumpto ( plus pc (byte2) 2))))) (de h!:JUMPLIT1EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 1)))) (de h!:JUMPLIT1NE (pc code env) (jumpop (list ( quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLIT2EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 2)))) (de h!:JUMPLIT2NE (pc code env) (jumpop (list (quote not) (list (quote eq) !@a (litref env 1))))) ( de h!:JUMPLIT3EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 3)))) (de h!:JUMPLIT3NE (pc code env) (jumpop (list (quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLIT4EQ (pc code env) (jumpop (list (quote eq) !@a (litref env 4)))) (de h!:JUMPLIT4NE (pc code env) (jumpop (list ( quote not) (list (quote eq) !@a (litref env 1))))) (de h!:JUMPLITEQ (pc code env) (list 3 (makeif (list (quote eq) !@a (litref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPLITNE (pc code env) (list 3 (makeif (list ( quote not) (list (quote eq) !@a (litref env (byte1)))) (jumpto (plus pc ( byte2) 2))))) (de h!:JUMPB1NIL (pc code env) (prog (w) (setq w (elt builtin1 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB1NIL"))) (return (list 3 ( makeif (list (quote null) (list w !@a)) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB1T (pc code env) (prog (w) (setq w (elt builtin1 (byte1))) (cond (( null w) (error 1 "Bad in JUMPB1T"))) (return (list 3 (makeif (list w !@a) ( jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB2NIL (pc code env) (prog (w) ( setq w (elt builtin2 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB2NIL"))) (return (list 3 (makeif (list (quote null) (list w !@b !@a)) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPB2T (pc code env) (prog (w) (setq w (elt builtin2 (byte1))) (cond ((null w) (error 1 "Bad in JUMPB2T"))) (return (list 3 (makeif (list w !@b !@a) (jumpto (plus pc (byte2) 2))))))) (de h!:JUMPFLAGP (pc code env) (jumpop (list (quote flagp) !@b !@a))) (de h!:JUMPNFLAGP (pc code env) (jumpop (list (quote not) (list (quote flagp) !@b !@a)))) (de h!:JUMPEQCAR (pc code env) (list 3 (makeif (list (quote eqcar) !@a (litref env (byte1))) (jumpto (plus pc (byte2) 2))))) (de h!:JUMPNEQCAR ( pc code env) (list 3 (makeif (list (quote not) (list (quote eqcar) !@a ( litref env (byte1)))) (jumpto (plus pc (byte2) 2))))) (de h!:CATCH (pc code env) (jumpop (list !@catch !@a))) (de h!:CATCH_B (pc code env) (jumpopb (list !@catch !@a))) (de h!:CATCH_L (pc code env) (jumpopl (list !@catch !@a))) ( de h!:CATCH_BL (pc code env) (jumpopbl (list !@catch !@a))) (de h!:UNCATCH ( pc code env) (list 1 (quote uncatch) (jumpto pc))) (de h!:THROW (pc code env) (quote (1 throw))) (de h!:PROTECT (pc code env) (list 1 (quote protect) ( jumpto pc))) (de h!:UNPROTECT (pc code env) (list 1 (quote unprotect) (jumpto pc))) (de h!:PVBIND (pc code env) (list 1 (quote pvbind) (jumpto pc))) (de h!:PVRESTORE (pc code env) (list 1 (quote pvrestore) (jumpto pc))) (de vector_to_list (v) (cond ((not (vectorp v)) (error 1 "Error in binding fluid variables")) (t (prog (r) (prog (i) (setq i 0) lab1059 (cond ((minusp (times 1 (difference (upbv v) i))) (return nil))) ( setq r (cons (getv v i) r)) (setq i (plus i 1)) (go lab1059)) (return ( reversip r)))))) (de h!:FREEBIND (pc code env) (list 2 (list (quote freebind) (vector_to_list (freeref env (byte1)))) (jumpto (plus pc 1)))) (de h!:FREERSTR (pc code env) (list 1 (quote (freerstr !*)) (jumpto pc))) (de h!:EXIT (pc code env) (list 1 (list (quote return) !@a))) (de h!:NILEXIT (pc code env) (list 1 (list (quote return) nil))) (de h!:LOC0EXIT (pc code env) ( list 1 (list (quote return) (list !@stack 0)))) (de h!:LOC1EXIT (pc code env) (list 1 (list (quote return) (list !@stack 1)))) (de h!:LOC2EXIT (pc code env) (list 1 (list (quote return) (list !@stack 2)))) (de h!:PUSH (pc code env) (list 1 (quote push) (list (quote setq) (list !@stack 0) !@a))) (de h!:PUSHNIL (pc code env) (list 1 (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNIL2 (pc code env) (list 1 (quote push) (list ( quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNIL3 (pc code env) (list 1 (quote push) (list ( quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil) (quote push) (list (quote setq) (list !@stack 0) nil))) (de h!:PUSHNILS (pc code env) (prog (n w) (setq n (byte1)) (prog (i) (setq i 1) lab1060 (cond ((minusp (times 1 (difference n i))) (return nil))) (setq w ( cons (quote push) (cons (list (quote setq) (list !@stack 0) nil) w))) (setq i (plus i 1)) (go lab1060)) (return (cons 2 w)))) (de h!:POP (pc code env) ( list 1 (list (quote setq) (list (quote !@stack) 0)) (quote lose))) (de h!:LOSE (pc code env) (quote (1 lose))) (de h!:LOSE2 (pc code env) (quote (1 lose lose))) (de h!:LOSE3 (pc code env) (quote (1 lose lose lose))) (de h!:LOSES (pc code env) (prog (n w) (setq n (byte1)) (prog (i) (setq i 1) lab1061 (cond ((minusp (times 1 (difference n i))) (return nil))) (setq w ( cons (quote lose) w)) (setq i (plus i 1)) (go lab1061)) (return (cons 2 w)))) (de h!:SWOP (pc code env) (list 1 (list (quote setq) !@w !@a) (list (quote setq) !@a !@b) (list (quote setq) !@b !@w))) (de h!:EQ (pc code env) (list 1 (list (quote setq) !@a (list (quote eq) !@b !@a)))) (de h!:EQCAR (pc code env ) (list 1 (list (quote setq) !@a (list (quote eqcar) !@b !@a)))) (de h!:EQUAL (pc code env) (list 1 (list (quote setq) !@a (list (quote equal) !@b !@a)))) (de h!:NUMBERP (pc code env) (list 1 (list (quote setq) !@a (list (quote numberp) !@a)))) (de h!:CAR (pc code env) (list 1 (list (quote setq) !@a ( list (quote car) !@a)))) (de h!:CDR (pc code env) (list 1 (list (quote setq) !@a (list (quote cdr) !@a)))) (de h!:CAAR (pc code env) (list 1 (list (quote setq) !@a (list (quote caar) !@a)))) (de h!:CADR (pc code env) (list 1 (list (quote setq) !@a (list (quote cadr) !@a)))) (de h!:CDAR (pc code env) (list 1 (list (quote setq) !@a (list (quote cdar) !@a)))) (de h!:CDDR (pc code env) (list 1 (list (quote setq) !@a (list (quote cddr) !@a)))) (de h!:CONS (pc code env) (list 1 (list (quote setq) !@a (list (quote cons) !@b !@a)))) (de h!:NCONS (pc code env) (list 1 (list (quote setq) !@a (list (quote ncons) !@a )))) (de h!:XCONS (pc code env) (list 1 (list (quote setq) !@a (list (quote cons) !@a !@b)))) (de h!:ACONS (pc code env) (list 1 (list (quote setq) !@a ( list (quote acons) !@b !@a (list !@stack 0))) (quote lose))) (de h!:LENGTH ( pc code env) (list 1 (list (quote setq) !@a (list (quote length) !@a)))) (de h!:LIST2 (pc code env) (list 1 (list (quote setq) !@a (list (quote list) !@b !@a)))) (de h!:LIST2STAR (pc code env) (list 1 (list (quote setq) !@a (list ( quote list!*) !@b !@a (list !@stack 0))) (quote lose))) (de h!:LIST3 (pc code env) (list 1 (list (quote setq) !@a (list (quote list) !@b !@a (list !@stack 0))) (quote lose))) (de h!:PLUS2 (pc code env) (list 1 (list (quote setq) !@a (list (quote plus) !@b !@a)))) (de h!:ADD1 (pc code env) (list 1 (list ( quote setq) !@a (list (quote add1) !@a)))) (de h!:DIFFERENCE (pc code env) ( list 1 (list (quote setq) !@a (list (quote difference) !@b !@a)))) (de h!:SUB1 (pc code env) (list 1 (list (quote setq) !@a (list (quote sub1) !@a)) )) (de h!:TIMES2 (pc code env) (list 1 (list (quote setq) !@a (list (quote times) !@b !@a)))) (de h!:GREATERP (pc code env) (list 1 (list (quote setq) !@a (list (quote greaterp) !@b !@a)))) (de h!:LESSP (pc code env) (list 1 ( list (quote setq) !@a (list (quote lessp) !@b !@a)))) (de h!:FLAGP (pc code env) (list 1 (list (quote setq) !@a (list (quote flagp) !@b !@a)))) (de h!:GET (pc code env) (list 1 (list (quote setq) !@a (list (quote get) !@b !@a )))) (de h!:LITGET (pc code env) (list 2 (list (quote setq) !@a (list (quote get) !@a (litref env (byte1)))))) (de h!:GETV (pc code env) (list 1 (list ( quote setq) !@a (list (quote getv) !@b !@a)))) (de h!:QGETV (pc code env) ( list 1 (list (quote setq) !@a (list (quote qgetv) !@b !@a)))) (de h!:QGETVN ( pc code env) (list 2 (list (quote setq) !@a (list (quote qgetv) !@a (byte1))) )) (de h!:BIGSTACK (pc code env) (prog nil (error 1 "bigstack") (return (list 3 (quote bigstack))))) (de h!:BIGCALL (pc code env) (prog nil (error 1 "bigcall") (return (list 3 (quote bigcall))))) (de h!:ICASE (pc code env) ( prog nil (error 1 "ICASE opcode found") (return (list (plus 4 (times 2 (byte1 ))) (quote icase))))) (de h!:FASTGET (pc code env) (prog nil (error 1 "fastget") (return (list 2 (quote fastget))))) (de h!:SPARE1 (pc code env) ( error 1 "Invalid (spare) opcode found in byte-stream")) (de h!:SPARE2 (pc code env) (error 1 "Invalid (spare) opcode found in byte-stream")) "All helper functions present") (de find_freebind (x) (cond ((null x) nil) (t (cond ((eqcar (car x) (quote freebind)) x) (t (find_freebind (cdr x))))))) (de find_freerstr (x) (cond ((null x) nil) (t (cond ((eqcar (car x) (quote freerstr)) x) (t (find_freerstr (cdr x))))))) (de mark_restores (w lab) (prog (b) (setq b (assoc lab w)) (cond ((null b) ( error 1 "block not found"))) (cond ((cadr b) (return nil))) (rplaca (cdr b) t ) (cond ((find_freerstr (cddr b)) (return nil)) (t (cond ((find_freebind ( cddr b)) (return t))))) (prog nil lab1062 (cond ((null (not (atom (cdr b)))) (return nil))) (setq b (cdr b)) (go lab1062)) (setq b (car b)) (cond ((eqcar b (quote go)) (return (mark_restores w (cadr b)))) (t (cond ((eqcar b (quote if)) (progn (cond ((mark_restores w (cadr (caddr b))) (return t)) (t (return (mark_restores w (cadr (cadddr b)))))))) (t (cond ((eqcar b (quote progexits) ) (return (mark_several_restores w (cdr b)))) (t (return nil))))))))) (de mark_several_restores (w l) (cond ((null l) nil) (t (cond ((mark_restores w (car l)) t) (t (mark_several_restores w (cdr l))))))) (de lift_free_binding (w fb) (prog (r1 r2 w1) (prog nil lab1063 (cond ((null w) (return nil))) (progn (setq w1 (cdr w)) (cond ((cadar w) (progn (rplaca ( cdar w) nil) (rplacd w r1) (setq r1 w))) (t (progn (rplacd w r2) (setq r2 w)) )) (setq w w1)) (go lab1063)) (setq r1 (reversip r1)) (rplaca fb (cons (quote prog) (cons (cadar fb) r1))) (rplacd fb (list (cons (quote progexits) ( free_exits r1)))) (return (reversip r2)))) (de free_exits (b) (prog (r r1) (prog (var1066) (setq var1066 b) lab1065 ( cond ((null var1066) (return nil))) (prog (i) (setq i (car var1066)) (progn ( prog nil lab1064 (cond ((null (not (atom (cdr i)))) (return nil))) (setq i ( cdr i)) (go lab1064)) (setq i (car i)) (cond ((eqcar i (quote go)) (setq r ( union (cdr i) r))) (t (cond ((eqcar i (quote if)) (setq r (union (cdr (caddr i)) (union (cdr (cadddr i)) r)))) (t (cond ((eqcar i (quote progexits)) (setq r (union (cdr i) r)))))))))) (setq var1066 (cdr var1066)) (go lab1065)) ( prog (var1068) (setq var1068 r) lab1067 (cond ((null var1068) (return nil))) (prog (i) (setq i (car var1068)) (cond ((null (assoc i b)) (setq r1 (cons i r1))))) (setq var1068 (cdr var1068)) (go lab1067)) (return r1))) (de fix_free_bindings (w) (prog (changed aborted p fb) (setq changed t) (prog nil lab1072 (cond ((null changed) (return nil))) (progn (setq changed nil) ( prog (var1070) (setq var1070 w) lab1069 (cond ((null var1070) (return nil))) (prog (z) (setq z (car var1070)) (rplaca (cdr z) nil)) (setq var1070 (cdr var1070)) (go lab1069)) (cond (aborted (setq p (cdr p))) (t (setq p w))) ( setq aborted nil) (prog nil lab1071 (cond ((null (and p (not (setq fb ( find_freebind (cddar p)))))) (return nil))) (setq p (cdr p)) (go lab1071)) ( cond (p (progn (setq changed t) (cond ((mark_restores w (cadr (cadr fb))) ( setq aborted t)) (t (setq w (lift_free_binding w fb)))))))) (go lab1072)) ( return w))) (de optimise_blocks (w args locals) (prog (vars changed avail) (setq vars ( append args locals)) (prog (var1074) (setq var1074 w) lab1073 (cond ((null var1074) (return nil))) (prog (z) (setq z (car var1074)) (rplaca (cdr z) ( quote unknown))) (setq var1074 (cdr var1074)) (go lab1073)) (rplaca (cdar w) nil) (setq changed t) (prog nil lab1079 (cond ((null changed) (return nil))) (progn (setq changed nil) (prog (var1078) (setq var1078 w) lab1077 (cond (( null var1078) (return nil))) (prog (z) (setq z (car var1078)) (progn (setq avail (cadr z)) (prog (var1076) (setq var1076 (cddr z)) lab1075 (cond ((null var1076) (return nil))) (prog (q) (setq q (car var1076)) (progn nil)) (setq var1076 (cdr var1076)) (go lab1075)))) (setq var1078 (cdr var1078)) (go lab1077))) (go lab1079)) (return w))) (setq !*echo (setq !*plap t)) (de simple (x) (cond ((atom x) x) (t (cond ((null (cdr x)) (car x)) (t ( simple (cdr x))))))) (fluid (quote (x y))) (de mylast (x) (cond ((atom x) x) (t (cond ((null (cdr x)) (car x)) (t ( mylast (cdr x))))))) (de test (a) (prog (x) (setq x (plus a a a)) (setq x (prog (y) (setq y (times x x)) (print (list x y)) (return y))) (return (quotient x a)))) (unfluid (quote (x y))) (setq !*plap nil) (unbyte (quote simple)) (unbyte (quote mylast)) (unbyte (quote test)) % end of file mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/checks.lsp0000644000175000017500000003376211550002751023545 0ustar giovannigiovanni% Checks on basic arithmetic..." % This rather crude set of tests was used for initial and basic % functionality-testing of arithmetic when CSL was adapted for use % on 64-bit architectures. It may still be useful as a minimal part of % a set of regression tests... (de tests (a b r) (prog (w) (setq w (list (plus a b) (plus b a))) (setq w (list!* (difference a b) (difference b a) w)) (setq w (list!* (times a b) (times b a) w)) (setq w (list!* (quotient a b) (quotient b a) w)) (setq w (list!* (remainder a b) (remainder b a) w)) (setq w (list!* (greaterp a b) (greaterp b a) w)) (setq w (list!* (lessp a b) (lessp b a) w)) (setq w (list!* (equal a b) (equal b a) w)) % (terpri) (print (list 'tests a b (list 'quote w))) (cond ((not (equal r w)) (terpri) (printc "*** ERROR ***") (princ "a = ") (print a) (princ "b = ") (print b) (showall r w) (error 0 "messed up"))) (return nil))) (de showall (r w) (prog (z) (princ "op") (ttab 5) (princ "correct") (ttab 40) (printc "computed") (setq z '(!= != !< !< !> !> !% !% !/ !/ !* !* !- !- !+ !+)) top (cond ((or (null r) (null w) (null z)) (return nil))) (cond ((equal (car r) (car w)) (princ " ")) (t (princ "? "))) (princ (car z)) (ttab 5) (prin (car r)) (ttab 40) (print (car w)) (setq r (cdr r)) (setq w (cdr w)) (setq z (cdr z)) (go top))) (tests 1 1 (quote (t t nil nil nil nil 0 0 1 1 1 1 0 0 2 2))) (tests 1 2 (quote (nil nil t nil nil t 1 0 0 2 2 2 -1 1 3 3))) (tests 1 10000 (quote (nil nil t nil nil t 1 0 0 10000 10000 10000 -9999 9999 10001 10001))) (tests 1 1000000000 (quote (nil nil t nil nil t 1 0 0 1000000000 1000000000 1000000000 -999999999 999999999 1000000001 1000000001)) ) (tests 1 100000000000000000000 (quote (nil nil t nil nil t 1 0 0 100000000000000000000 100000000000000000000 100000000000000000000 -99999999999999999999 99999999999999999999 100000000000000000001 100000000000000000001))) (tests 1 100000000000000000000000000000000 (quote (nil nil t nil nil t 1 0 0 100000000000000000000000000000000 100000000000000000000000000000000 100000000000000000000000000000000 -99999999999999999999999999999999 99999999999999999999999999999999 100000000000000000000000000000001 100000000000000000000000000000001))) (tests 3 1 (quote (nil nil nil t t nil 0 1 3 0 3 3 2 -2 4 4))) (tests 3 2 (quote (nil nil nil t t nil 1 2 1 0 6 6 1 -1 5 5))) (tests 3 10000 (quote (nil nil t nil nil t 3 1 0 3333 30000 30000 -9997 9997 10003 10003))) (tests 3 1000000000 (quote (nil nil t nil nil t 3 1 0 333333333 3000000000 3000000000 -999999997 999999997 1000000003 1000000003)) ) (tests 3 100000000000000000000 (quote (nil nil t nil nil t 3 1 0 33333333333333333333 300000000000000000000 300000000000000000000 -99999999999999999997 99999999999999999997 100000000000000000003 100000000000000000003))) (tests 3 100000000000000000000000000000000 (quote (nil nil t nil nil t 3 1 0 33333333333333333333333333333333 300000000000000000000000000000000 300000000000000000000000000000000 -99999999999999999999999999999997 99999999999999999999999999999997 100000000000000000000000000000003 100000000000000000000000000000003))) (tests 7777 1 (quote (nil nil nil t t nil 0 1 7777 0 7777 7777 7776 -7776 7778 7778))) (tests 7777 2 (quote (nil nil nil t t nil 1 2 3888 0 15554 15554 7775 -7775 7779 7779))) (tests 7777 10000 (quote (nil nil t nil nil t 7777 2223 0 1 77770000 77770000 -2223 2223 17777 17777))) (tests 7777 1000000000 (quote (nil nil t nil nil t 7777 2232 0 128584 7777000000000 7777000000000 -999992223 999992223 1000007777 1000007777))) (tests 7777 100000000000000000000 (quote (nil nil t nil nil t 7777 3334 0 12858428700012858 777700000000000000000000 777700000000000000000000 -99999999999999992223 99999999999999992223 100000000000000007777 100000000000000007777)) ) (tests 7777 100000000000000000000000000000000 (quote (nil nil t nil nil t 7777 3334 0 12858428700012858428700012858 777700000000000000000000000000000000 777700000000000000000000000000000000 -99999999999999999999999999992223 99999999999999999999999999992223 100000000000000000000000000007777 100000000000000000000000000007777))) (tests 3141592653882 1 (quote (nil nil nil t t nil 0 1 3141592653882 0 3141592653882 3141592653882 3141592653881 -3141592653881 3141592653883 3141592653883))) (tests 3141592653882 2 (quote (nil nil nil t t nil 0 2 1570796326941 0 6283185307764 6283185307764 3141592653880 -3141592653880 3141592653884 3141592653884))) (tests 3141592653882 10000 (quote (nil nil nil t t nil 3882 10000 314159265 0 31415926538820000 31415926538820000 3141592643882 -3141592643882 3141592663882 3141592663882))) (tests 3141592653882 1000000000 (quote (nil nil nil t t nil 592653882 1000000000 3141 0 3141592653882000000000 3141592653882000000000 3140592653882 -3140592653882 3142592653882 3142592653882))) (tests 3141592653882 100000000000000000000 (quote (nil nil t nil nil t 3141592653882 1933393904584 0 31830988 314159265388200000000000000000000 314159265388200000000000000000000 -99999996858407346118 99999996858407346118 100000003141592653882 100000003141592653882)) ) (tests 3141592653882 100000000000000000000000000000000 (quote (nil nil t nil nil t 3141592653882 1024789465762 0 31830988615418393659 314159265388200000000000000000000000000000000 314159265388200000000000000000000000000000000 -99999999999999999996858407346118 99999999999999999996858407346118 100000000000000000003141592653882 100000000000000000003141592653882))) (tests 7788882333333333300000000000000331 1 (quote (nil nil nil t t nil 0 1 7788882333333333300000000000000331 0 7788882333333333300000000000000331 7788882333333333300000000000000331 7788882333333333300000000000000330 -7788882333333333300000000000000330 7788882333333333300000000000000332 7788882333333333300000000000000332))) (tests 7788882333333333300000000000000331 2 (quote (nil nil nil t t nil 1 2 3894441166666666650000000000000165 0 15577764666666666600000000000000662 15577764666666666600000000000000662 7788882333333333300000000000000329 -7788882333333333300000000000000329 7788882333333333300000000000000333 7788882333333333300000000000000333))) (tests 7788882333333333300000000000000331 10000 (quote (nil nil nil t t nil 331 10000 778888233333333330000000000000 0 77888823333333333000000000000003310000 77888823333333333000000000000003310000 7788882333333333299999999999990331 -7788882333333333299999999999990331 7788882333333333300000000000010331 7788882333333333300000000000010331))) (tests 7788882333333333300000000000000331 1000000000 (quote (nil nil nil t t nil 331 1000000000 7788882333333333300000000 0 7788882333333333300000000000000331000000000 7788882333333333300000000000000331000000000 7788882333333333299999999000000331 -7788882333333333299999999000000331 7788882333333333300000001000000331 7788882333333333300000001000000331))) (tests 7788882333333333300000000000000331 100000000000000000000 ( quote (nil nil nil t t nil 33300000000000000331 100000000000000000000 77888823333333 0 778888233333333330000000000000033100000000000000000000 778888233333333330000000000000033100000000000000000000 7788882333333233300000000000000331 -7788882333333233300000000000000331 7788882333333433300000000000000331 7788882333333433300000000000000331))) (tests 7788882333333333300000000000000331 100000000000000000000000000000000 (quote (nil nil nil t t nil 88882333333333300000000000000331 100000000000000000000000000000000 77 0 778888233333333330000000000000033100000000000000000000000000000000 778888233333333330000000000000033100000000000000000000000000000000 7688882333333333300000000000000331 -7688882333333333300000000000000331 7888882333333333300000000000000331 7888882333333333300000000000000331))) (tests -1 1 (quote (nil nil t nil nil t 0 0 -1 -1 -1 -1 -2 2 0 0)) ) (tests -1 2 (quote (nil nil t nil nil t -1 0 0 -2 -2 -2 -3 3 1 1)) ) (tests -1 10000 (quote (nil nil t nil nil t -1 0 0 -10000 -10000 -10000 -10001 10001 9999 9999))) (tests -1 1000000000 (quote (nil nil t nil nil t -1 0 0 -1000000000 -1000000000 -1000000000 -1000000001 1000000001 999999999 999999999))) (tests -1 100000000000000000000 (quote (nil nil t nil nil t -1 0 0 -100000000000000000000 -100000000000000000000 -100000000000000000000 -100000000000000000001 100000000000000000001 99999999999999999999 99999999999999999999))) (tests -1 100000000000000000000000000000000 (quote (nil nil t nil nil t -1 0 0 -100000000000000000000000000000000 -100000000000000000000000000000000 -100000000000000000000000000000000 -100000000000000000000000000000001 100000000000000000000000000000001 99999999999999999999999999999999 99999999999999999999999999999999))) (tests -3 1 (quote (nil nil t nil nil t 0 1 -3 0 -3 -3 -4 4 -2 -2) )) (tests -3 2 (quote (nil nil t nil nil t -1 2 -1 0 -6 -6 -5 5 -1 -1 ))) (tests -3 10000 (quote (nil nil t nil nil t -3 1 0 -3333 -30000 -30000 -10003 10003 9997 9997))) (tests -3 1000000000 (quote (nil nil t nil nil t -3 1 0 -333333333 -3000000000 -3000000000 -1000000003 1000000003 999999997 999999997 ))) (tests -3 100000000000000000000 (quote (nil nil t nil nil t -3 1 0 -33333333333333333333 -300000000000000000000 -300000000000000000000 -100000000000000000003 100000000000000000003 99999999999999999997 99999999999999999997))) (tests -3 100000000000000000000000000000000 (quote (nil nil t nil nil t -3 1 0 -33333333333333333333333333333333 -300000000000000000000000000000000 -300000000000000000000000000000000 -100000000000000000000000000000003 100000000000000000000000000000003 99999999999999999999999999999997 99999999999999999999999999999997))) (tests -7777 1 (quote (nil nil t nil nil t 0 1 -7777 0 -7777 -7777 -7778 7778 -7776 -7776))) (tests -7777 2 (quote (nil nil t nil nil t -1 2 -3888 0 -15554 -15554 -7779 7779 -7775 -7775))) (tests -7777 10000 (quote (nil nil t nil nil t -7777 2223 0 -1 -77770000 -77770000 -17777 17777 2223 2223))) (tests -7777 1000000000 (quote (nil nil t nil nil t -7777 2232 0 -128584 -7777000000000 -7777000000000 -1000007777 1000007777 999992223 999992223))) (tests -7777 100000000000000000000 (quote (nil nil t nil nil t -7777 3334 0 -12858428700012858 -777700000000000000000000 -777700000000000000000000 -100000000000000007777 100000000000000007777 99999999999999992223 99999999999999992223))) (tests -7777 100000000000000000000000000000000 (quote (nil nil t nil nil t -7777 3334 0 -12858428700012858428700012858 -777700000000000000000000000000000000 -777700000000000000000000000000000000 -100000000000000000000000000007777 100000000000000000000000000007777 99999999999999999999999999992223 99999999999999999999999999992223))) (tests -3141592653882 1 (quote (nil nil t nil nil t 0 1 -3141592653882 0 -3141592653882 -3141592653882 -3141592653883 3141592653883 -3141592653881 -3141592653881))) (tests -3141592653882 2 (quote (nil nil t nil nil t 0 2 -1570796326941 0 -6283185307764 -6283185307764 -3141592653884 3141592653884 -3141592653880 -3141592653880))) (tests -3141592653882 10000 (quote (nil nil t nil nil t -3882 10000 -314159265 0 -31415926538820000 -31415926538820000 -3141592663882 3141592663882 -3141592643882 -3141592643882))) (tests -3141592653882 1000000000 (quote (nil nil t nil nil t -592653882 1000000000 -3141 0 -3141592653882000000000 -3141592653882000000000 -3142592653882 3142592653882 -3140592653882 -3140592653882))) (tests -3141592653882 100000000000000000000 (quote (nil nil t nil nil t -3141592653882 1933393904584 0 -31830988 -314159265388200000000000000000000 -314159265388200000000000000000000 -100000003141592653882 100000003141592653882 99999996858407346118 99999996858407346118))) (tests -3141592653882 100000000000000000000000000000000 (quote ( nil nil t nil nil t -3141592653882 1024789465762 0 -31830988615418393659 -314159265388200000000000000000000000000000000 -314159265388200000000000000000000000000000000 -100000000000000000003141592653882 100000000000000000003141592653882 99999999999999999996858407346118 99999999999999999996858407346118))) (tests -7788882333333333300000000000000331 1 (quote (nil nil t nil nil t 0 1 -7788882333333333300000000000000331 0 -7788882333333333300000000000000331 -7788882333333333300000000000000331 -7788882333333333300000000000000332 7788882333333333300000000000000332 -7788882333333333300000000000000330 -7788882333333333300000000000000330))) (tests -7788882333333333300000000000000331 2 (quote (nil nil t nil nil t -1 2 -3894441166666666650000000000000165 0 -15577764666666666600000000000000662 -15577764666666666600000000000000662 -7788882333333333300000000000000333 7788882333333333300000000000000333 -7788882333333333300000000000000329 -7788882333333333300000000000000329))) (tests -7788882333333333300000000000000331 10000 (quote (nil nil t nil nil t -331 10000 -778888233333333330000000000000 0 -77888823333333333000000000000003310000 -77888823333333333000000000000003310000 -7788882333333333300000000000010331 7788882333333333300000000000010331 -7788882333333333299999999999990331 -7788882333333333299999999999990331))) (tests -7788882333333333300000000000000331 1000000000 (quote (nil nil t nil nil t -331 1000000000 -7788882333333333300000000 0 -7788882333333333300000000000000331000000000 -7788882333333333300000000000000331000000000 -7788882333333333300000001000000331 7788882333333333300000001000000331 -7788882333333333299999999000000331 -7788882333333333299999999000000331))) (tests -7788882333333333300000000000000331 100000000000000000000 ( quote (nil nil t nil nil t -33300000000000000331 100000000000000000000 -77888823333333 0 -778888233333333330000000000000033100000000000000000000 -778888233333333330000000000000033100000000000000000000 -7788882333333433300000000000000331 7788882333333433300000000000000331 -7788882333333233300000000000000331 -7788882333333233300000000000000331))) (tests -7788882333333333300000000000000331 100000000000000000000000000000000 (quote (nil nil t nil nil t -88882333333333300000000000000331 100000000000000000000000000000000 -77 0 -778888233333333330000000000000033100000000000000000000000000000000 -778888233333333330000000000000033100000000000000000000000000000000 -7888882333333333300000000000000331 7888882333333333300000000000000331 -7688882333333333300000000000000331 -7688882333333333300000000000000331))) (stop 0) mathpiper-0.81f+svn4469+dfsg3/lib/build_scripts/compiler.red0000644000175000017500000066515211550002751024077 0ustar giovannigiovanni% % Compiler from Lisp into byte-codes for use with CSL/CCL. % Copyright (C) Codemist Ltd, 1990-2010 % %% %% Copyright (C) 2010, following the master REDUCE source files. * %% * %% Redistribution and use in source and binary forms, with or without * %% modification, are permitted provided that the following conditions are * %% met: * %% * %% * Redistributions of source code must retain the relevant * %% copyright notice, this list of conditions and the following * %% disclaimer. * %% * Redistributions in binary form must reproduce the above * %% copyright notice, this list of conditions and the following * %% disclaimer in the documentation and/or other materials provided * %% with the distribution. * %% * %% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * %% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * %% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS * %% FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE * %% COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, * %% INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, * %% BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS * %% OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND * %% ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR * %% TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * %% THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * %% DAMAGE. * %% % Pretty-well all internal functions defined here and all fluid and % global variables have been written with names of the form s!:xxx. This % might keep them away from most users. In Common Lisp I may want to put % them all in a package called "s". global '(s!:opcodelist); % The following list of opcodes must be kept in step with the corresponding % C header file "bytes.h" in the CSL kernel code, and the source file % "opnames.c". in "$cslbase/opcodes.red"$ begin scalar n; n := 0; for each v in s!:opcodelist do << put(v, 's!:opcode, n); n := n + 1 >>; return list(n, 'opcodes, 'allocated) end; s!:opcodelist := nil; fluid '(s!:env_alist); symbolic procedure s!:vecof l; begin scalar w; w := assoc(l, s!:env_alist); if w then return cdr w; w := s!:vecof1 l; s!:env_alist := (l . w) . s!:env_alist; return w end; symbolic procedure s!:vecof1 l; begin scalar v, n; v := mkvect sub1 length l; n := 0; for each x in l do << putv(v, n, x); n := n+1 >>; return v end; << put('batchp, 's!:builtin0, 0); put('date, 's!:builtin0, 1); put('eject, 's!:builtin0, 2); put('error1, 's!:builtin0, 3); put('gctime, 's!:builtin0, 4); % put('gensym, 's!:builtin0, 5); put('lposn, 's!:builtin0, 6); % put('next!-random, 's!:builtin0, 7); put('posn, 's!:builtin0, 8); put('read, 's!:builtin0, 9); put('readch, 's!:builtin0, 10); put('terpri, 's!:builtin0, 11); !#if (not common!-lisp!-mode) put('time, 's!:builtin0, 12); !#endif put('tyi, 's!:builtin0, 13); % load!-spid is not for use by an ordinary programmer - it is used in the % compilation of unwind!-protect. put('load!-spid, 's!:builtin0, 14); put('abs, 's!:builtin1, 0); put('add1, 's!:builtin1, 1); !#if common!-lisp!-mode put('!1!+, 's!:builtin1, 1); !#endif !#if (not common!-lisp!-mode) put('atan, 's!:builtin1, 2); !#endif put('apply0, 's!:builtin1, 3); put('atom, 's!:builtin1, 4); put('boundp, 's!:builtin1, 5); put('char!-code, 's!:builtin1, 6); put('close, 's!:builtin1, 7); put('codep, 's!:builtin1, 8); !#if (not common!-lisp!-mode) put('compress, 's!:builtin1, 9); !#endif put('constantp, 's!:builtin1, 10); put('digit, 's!:builtin1, 11); put('endp, 's!:builtin1, 12); put('eval, 's!:builtin1, 13); put('evenp, 's!:builtin1, 14); put('evlis, 's!:builtin1, 15); put('explode, 's!:builtin1, 16); put('explode2lc, 's!:builtin1, 17); put('explode2, 's!:builtin1, 18); put('explodec, 's!:builtin1, 18); put('fixp, 's!:builtin1, 19); !#if (not common!-lisp!-mode) put('float, 's!:builtin1, 20); !#endif put('floatp, 's!:builtin1, 21); put('symbol!-specialp, 's!:builtin1, 22); put('gc, 's!:builtin1, 23); put('gensym1, 's!:builtin1, 24); put('getenv, 's!:builtin1, 25); put('symbol!-globalp, 's!:builtin1, 26); put('iadd1, 's!:builtin1, 27); put('symbolp, 's!:builtin1, 28); put('iminus, 's!:builtin1, 29); put('iminusp, 's!:builtin1, 30); put('indirect, 's!:builtin1, 31); put('integerp, 's!:builtin1, 32); !#if (not common!-lisp!-mode) put('intern, 's!:builtin1, 33); !#endif put('isub1, 's!:builtin1, 34); put('length, 's!:builtin1, 35); put('lengthc, 's!:builtin1, 36); put('linelength, 's!:builtin1, 37); put('liter, 's!:builtin1, 38); put('load!-module, 's!:builtin1, 39); put('lognot, 's!:builtin1, 40); !#if (not common!-lisp!-mode) put('macroexpand, 's!:builtin1, 41); put('macroexpand!-1, 's!:builtin1, 42); !#endif put('macro!-function, 's!:builtin1, 43); put('make!-bps, 's!:builtin1, 44); put('make!-global, 's!:builtin1, 45); put('make!-simple!-string, 's!:builtin1, 46); put('make!-special, 's!:builtin1, 47); put('minus, 's!:builtin1, 48); put('minusp, 's!:builtin1, 49); put('mkvect, 's!:builtin1, 50); put('modular!-minus, 's!:builtin1, 51); put('modular!-number, 's!:builtin1, 52); put('modular!-reciprocal, 's!:builtin1, 53); put('null, 's!:builtin1, 54); put('oddp, 's!:builtin1, 55); put('onep, 's!:builtin1, 56); put('pagelength, 's!:builtin1, 57); put('pairp, 's!:builtin1, 58); put('plist, 's!:builtin1, 59); put('plusp, 's!:builtin1, 60); !#if (not common!-lisp!-mode) put('prin, 's!:builtin1, 61); put('princ, 's!:builtin1, 62); put('print, 's!:builtin1, 63); put('printc, 's!:builtin1, 64); !#endif % put('random, 's!:builtin1, 65); % put('rational, 's!:builtin1, 66); % put('load, 's!:builtin1, 67); put('rds, 's!:builtin1, 68); put('remd, 's!:builtin1, 69); !#if (not common!-lisp!-mode) put('reverse, 's!:builtin1, 70); !#endif put('reversip, 's!:builtin1, 71); put('seprp, 's!:builtin1, 72); put('set!-small!-modulus, 's!:builtin1, 73); put('spaces, 's!:builtin1, 74); put('xtab, 's!:builtin1, 74); % = spaces? put('special!-char, 's!:builtin1, 75); put('special!-form!-p, 's!:builtin1, 76); put('spool, 's!:builtin1, 77); put('stop, 's!:builtin1, 78); !#if (not common!-lisp!-mode) put('stringp, 's!:builtin1, 79); !#endif put('sub1, 's!:builtin1, 80); !#if common!-lisp!-mode put('!1!-, 's!:builtin1, 80); !#endif put('symbol!-env, 's!:builtin1, 81); put('symbol!-function, 's!:builtin1, 82); put('symbol!-name, 's!:builtin1, 83); put('symbol!-value, 's!:builtin1, 84); put('system, 's!:builtin1, 85); !#if (not common!-lisp!-mode) put('fix, 's!:builtin1, 86); !#endif put('ttab, 's!:builtin1, 87); put('tyo, 's!:builtin1, 88); !#if (not common!-lisp!-mode) put('remob, 's!:builtin1, 89); !#endif put('unmake!-global, 's!:builtin1, 90); put('unmake!-special, 's!:builtin1, 91); put('upbv, 's!:builtin1, 92); !#if (not common!-lisp!-mode) put('vectorp, 's!:builtin1, 93); !#else put('simple!-vectorp, 's!:builtin1, 93); !#endif put('verbos, 's!:builtin1, 94); put('wrs, 's!:builtin1, 95); put('zerop, 's!:builtin1, 96); % car, cdr etc will pretty-well always turn into single byte operations % rather than the builtin calls listed here. So the next few lines are % probably redundant. put('car, 's!:builtin1, 97); put('cdr, 's!:builtin1, 98); put('caar, 's!:builtin1, 99); put('cadr, 's!:builtin1, 100); put('cdar, 's!:builtin1, 101); put('cddr, 's!:builtin1, 102); put('qcar, 's!:builtin1, 103); put('qcdr, 's!:builtin1, 104); put('qcaar, 's!:builtin1, 105); put('qcadr, 's!:builtin1, 106); put('qcdar, 's!:builtin1, 107); put('qcddr, 's!:builtin1, 108); put('ncons, 's!:builtin1, 109); put('numberp, 's!:builtin1, 110); % is!-spid and spid!-to!-nil are NOT for direct use by ordinary programmers. % They are part of the support for &optional arguments. put('is!-spid, 's!:builtin1, 111); put('spid!-to!-nil, 's!:builtin1, 112); !#if common!-lisp!-mode put('mv!-list!*, 's!:builtin1, 113); !#endif put('append, 's!:builtin2, 0); put('ash, 's!:builtin2, 1); !#if (not common!-lisp!-mode) put('assoc, 's!:builtin2, 2); !#endif put('assoc!*!*, 's!:builtin2, 2); put('atsoc, 's!:builtin2, 3); put('deleq, 's!:builtin2, 4); !#if (not common!-lisp!-mode) put('delete, 's!:builtin2, 5); put('divide, 's!:builtin2, 6); !#endif put('eqcar, 's!:builtin2, 7); put('eql, 's!:builtin2, 8); !#if (not common!-lisp!-mode) put('eqn, 's!:builtin2, 9); !#endif put('expt, 's!:builtin2, 10); put('flag, 's!:builtin2, 11); put('flagpcar, 's!:builtin2, 12); !#if (not common!-lisp!-mode) put('gcdn, 's!:builtin2, 13); !#endif put('geq, 's!:builtin2, 14); put('getv, 's!:builtin2, 15); put('greaterp, 's!:builtin2, 16); put('idifference, 's!:builtin2, 17); put('igreaterp, 's!:builtin2, 18); put('ilessp, 's!:builtin2, 19); put('imax, 's!:builtin2, 20); put('imin, 's!:builtin2, 21); put('iplus2, 's!:builtin2, 22); put('iquotient, 's!:builtin2, 23); put('iremainder, 's!:builtin2, 24); put('irightshift, 's!:builtin2, 25); put('itimes2, 's!:builtin2, 26); !#if (not common!-lisp!-mode) % put('lcm, 's!:builtin2, 27); !#endif put('leq, 's!:builtin2, 28); put('lessp, 's!:builtin2, 29); % put('make!-random!-state, 's!:builtin2, 30); put('max2, 's!:builtin2, 31); !#if (not common!-lisp!-mode) put('member, 's!:builtin2, 32); !#endif put('member!*!*, 's!:builtin2, 32); put('memq, 's!:builtin2, 33); put('min2, 's!:builtin2, 34); put('mod, 's!:builtin2, 35); put('modular!-difference, 's!:builtin2, 36); put('modular!-expt, 's!:builtin2, 37); put('modular!-plus, 's!:builtin2, 38); put('modular!-quotient, 's!:builtin2, 39); put('modular!-times, 's!:builtin2, 40); put('nconc, 's!:builtin2, 41); put('neq, 's!:builtin2, 42); put('orderp, 's!:builtin2, 43); % put('ordp, 's!:builtin2, 43); % alternative name !#if (not common!-lisp!-mode) put('quotient, 's!:builtin2, 44); !#endif put('remainder, 's!:builtin2, 45); put('remflag, 's!:builtin2, 46); put('remprop, 's!:builtin2, 47); put('rplaca, 's!:builtin2, 48); put('rplacd, 's!:builtin2, 49); put('schar, 's!:builtin2, 50); put('set, 's!:builtin2, 51); put('smemq, 's!:builtin2, 52); put('subla, 's!:builtin2, 53); put('sublis, 's!:builtin2, 54); put('symbol!-set!-definition, 's!:builtin2, 55); put('symbol!-set!-env, 's!:builtin2, 56); put('times2, 's!:builtin2, 57); put('xcons, 's!:builtin2, 58); put('equal, 's!:builtin2, 59); put('eq, 's!:builtin2, 60); put('cons, 's!:builtin2, 61); put('list2, 's!:builtin2, 62); !#if (not common!-lisp!-mode) put('get, 's!:builtin2, 63); !#endif put('qgetv, 's!:builtin2, 64); put('flagp, 's!:builtin2, 65); put('apply1, 's!:builtin2, 66); put('difference, 's!:builtin2, 67); put('plus2, 's!:builtin2, 68); put('times2, 's!:builtin2, 69); put('equalcar, 's!:builtin2, 70); put('iequal, 's!:builtin2, 71); put('nreverse, 's!:builtin2, 72); put('bps!-putv, 's!:builtin3, 0); put('errorset, 's!:builtin3, 1); put('list2!*, 's!:builtin3, 2); put('list3, 's!:builtin3, 3); put('putprop, 's!:builtin3, 4); put('putv, 's!:builtin3, 5); put('putv!-char, 's!:builtin3, 6); put('subst, 's!:builtin3, 7); put('apply2, 's!:builtin3, 8); put('acons, 's!:builtin3, 9); nil >>; % Hex printing, for use when displaying assembly code symbolic procedure s!:prinhex1 n; princ schar("0123456789abcdef", logand(n, 15)); symbolic procedure s!:prinhex2 n; << s!:prinhex1 truncate(n, 16); s!:prinhex1 n >>; symbolic procedure s!:prinhex4 n; << s!:prinhex2 truncate(n, 256); s!:prinhex2 n >>; % % The rather elaborate scheme here is to allow for the possibility that the % horrid user may have defined one of these variables before loading in % the compiler - I do not want to clobber the user's settings. % flag('(comp plap pgwd pwrds notailcall ord nocompile carcheckflag savedef carefuleq r2i native_code save_native strip_native), 'switch); % for RLISP if not boundp '!*comp then << % compile automatically on "de" fluid '(!*comp); !*comp := t >>; if not boundp '!*nocompile then << % do not compile when fasling fluid '(!*nocompile); !*nocompile := nil >>; if not boundp '!*plap then << % print generated bytecodes fluid '(!*plap); !*plap := nil >>; if not boundp '!*pgwd then << % equivalent to *plap here fluid '(!*pgwd); !*pgwd := nil >>; if not boundp '!*pwrds then << % display size of generated code fluid '(!*pwrds); !*pwrds := t >>; if not boundp '!*notailcall then << % disable an optimisation fluid '(!*notailcall); !*notailcall := nil >>; if not boundp '!*ord then << % disable an optimisation wrt evaluation order fluid '(!*ord); !*ord := nil >>; if not boundp '!*savedef then << % keep interpretable definition on p-list fluid '(!*savedef); !*savedef := nil >>; if not boundp '!*carcheckflag then << % safety/speed control fluid '(!*carcheckflag); !*carcheckflag := t >>; if not boundp '!*carefuleq then << % force EQ to be function call fluid '(!*carefuleq); % to permit checking of (EQ number number) !*carefuleq := (boundp 'lispsystem!* and not null (member('jlisp, lispsystem!*))) or (boundp '!*features!* and not null (member('!:jlisp, !*features!*))) >>; if not boundp '!*r2i then << % apply Recursion to Iteration conversions fluid '(!*r2i); !*r2i := t >>; % If this flag is set then I will generate C code for the functions that % I compile as well as the usual bytecoded stuff for the FASL file. % Making it all link up is a slight delicacy! if not boundp '!*native_code then << % Compile via C fluid '(!*native_code); % By default I will leave compilation into native code switched off % at this level. When I build an image I will adjust the switch % to set a more carefully selected application-specific default. !*native_code := nil >>; if not boundp '!*save_native then << % Do not delete the C code (for debugging) fluid '(!*save_native); !*save_native := nil >>; if not boundp '!*strip_native then << % strip symbols from C code fluid '(!*strip_native); !*strip_native := t >>; % At least on Windows not stripping uses a LOT of space global '(s!:native_file); fluid '(s!:current_function s!:current_label s!:current_block s!:current_size s!:current_procedure s!:other_defs s!:lexical_env s!:has_closure s!:recent_literals s!:used_lexicals s!:a_reg_values s!:current_count); % % s!:current_procedure is a list of basic blocks, with the entry-point % implicit at the first block (that is to say at the END of the list % while I am building it).. Each block is represented as a list % (label exit-condn size . byte-list) % where the exit-condn can (at various stages during compilation) be % nil drop through % (exit) one-byte exit opcodes % (jump

>$ h:=cons(f, if h1=2 then cons(p,cdar fcc) else if h1=3 then if cddar fcc then cons(cadar fcc,cons(p,cddar fcc)) else cons(p,cdar fcc) else append(cdar fcc,list p) ); rplaca(fcc,h); >> else fcl:=cons({f,p},fcl); >> >> >> >>$ if flin_ then << % If there is a set flin_ of linear functions whose linearity is to be % preserved as long as possible then do not choose a factor of flin_ % if there is any such factor. h:=fcl; while h and not freeoflist(caar h,flin_) do h:=cdr h; if h then << % There are factors without flin_ functions --> drop all % factors with flin_ functions h:=fcl; fcl:=nil; for each p in h do if freeoflist(car p,flin_) then fcl:=cons(p,fcl) >> >>; % Selection of the best pair (function . equation) % List of priorities: % - the factor is of lowest possible degree h:=nil; h2:=nil; while fcl do << h1:=pde_degree(caar fcl,ftem_)$ if (null h) or (h1=h2) then <> else if h1

>$ fcl:=cdr fcl >>$ fcl:=h$ % - the equation has the lowest number of factors, i.e. dropping all % factors that are not also factors to a pde in fewest_factor_pdes % if there is such a PDE left if flin_ then << for each p in fewest_factor_pdes do if (homogen_ and zerop car get(p,'hom_deg)) or freeoflist(get(p,'fcts),flin_) then flin_free:=cons(p,flin_free); if flin_free then fewest_factor_pdes:=flin_free >>$ h:=nil; for each h1 in fcl do << if not freeoflist(h1,fewest_factor_pdes) then h:=cons(h1,h)$ >>$ if h then fcl:=h$ % keep only factors which occur in the most equations % keep for each factor only one equation which has the % lowest max degree of its factors and has the fewest % number of terms in all its factors me:=0; % the maximum number of equations a factor turns up while fcl do << h:=length car fcl$ if h > me then << me:=h$ best_fac:=cons(caar fcl,best_fac_pde(cdar fcl)) >> else if h = me then << % which pde is better: cadr best_fac or best_fac_pde(cdar fcl)? bp:=best_fac_pde(cdar fcl)$ if ( cadr bp < caddr best_fac ) or ((cadr bp = caddr best_fac) and (caddr bp < cadddr best_fac) ) then best_fac:=cons(caar fcl,bp) >>; fcl:=cdr fcl >>$ %best_fac is now a list of dotted pairs (factor_f . best_eqn_with_f_as_factor) return if (null best_fac) or (me=0) then nil else << h1:=nil; h2:=nil; h:=cdr get(cadr best_fac,'val)$ if flin_ then << for each p in h do if freeoflist(p,flin_) then h1:=cons(p,h1) else h2:=cons(p,h2); h:=append(h1,h2) >>$ put(cadr best_fac,'val,cons('TIMES,cons(car best_fac, delete(car best_fac,h))))$ cadr best_fac >> end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/applysym.html0000644000175000017500000000671211526203062024341 0ustar giovannigiovanniapplysym.html
Author Thomas Wolf
Title APPLYSYM
Short description The package APPLYSYM takes as input a differential equation (DE) or a system of DEs and its point symmetries, for example computed by the program LIEPDE. It computes symmetry and similarity variables through solving single first order partial DEs (PDEs) with the procedure QUASILINPDE. This procedure formulates an equivalent characteristic non-linear system of ordinary DEs (ODEs) which is investigated by the program CRACK. Although the program CRACK is primarily made for dealing with overdetermined DE-systems, it nevertheless has good chances of solving the not overdetermined characteristic ODE-systems because CRACK has a number of different integration techniques built in and because Lie-symmetries often have a simple form which results in relatively simple characteristic ODE-systems. The program QUASILINPDE can be used independently without connection to symmetries for solving quasi-linear first order PDEs as demonstrated in applysym.tst.
Platform REDUCE, version 3.6 or 3.7
System requirements The memory requirements depend crucially on the application. The non-trivial computations in the test file applysym.tst have been run in a 4MB session under LINUX.
Installation In a running REDUCE session either do
  in "applysym.red"$
or, in order to speed up computation, either compile it with
  on comp$
before the above command, or, generate a fast-loading compiled file once with
  faslout "applysym"$
  in "applysym.red"$
  faslend$
and load that file whenever you want to run APPLYSYM with
  load applysym$
In a similar way proceed with the files crack.red, liepde.red. The above commands assume all files to be in the current directory.
More information/updates There are available a manual, a test file and a log file.
A web demo for APPLYSYM may be available later. The latest version is available from ftp://ftp.maths.qmw.ac.uk/pub/tw/applysym/.
Contact e-mail: Thomas Wolf
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crshort.red0000644000175000017500000010736411526203062023762 0ustar giovannigiovanni%******************************************************************** module shortening$ %******************************************************************** % Routines for algebraically combining de's to reduce their length % Author: Thomas Wolf % Jan 1998 % % $Id: crshort.red,v 1.4 1998/04/28 21:36:27 arrigo Exp $ % % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic procedure alg_length_reduction(arglist)$ % Do one length-reducing combination of two equations begin scalar pdes,l,l1$ %,cpu,gc$ % cpu:=time()$ gc:=gctime()$ pdes:=car arglist$ if expert_mode then l:=selectpdes(pdes,2) else l:=pdes$ !*rational_bak := cons(!*rational,!*rational_bak)$ if !*rational then algebraic(off rational)$ if struc_eqn then << while l do << if is_algebraic(car l) then l1:=cons(car l,l1); l:=cdr l >>$ l:=reverse l1 >>$ if l and cdr l and (l1:=err_catch_short(l,caddr arglist,pdes)) then <> else l:=nil$ %if print_ and !*time then << % write " time : ", time() - cpu, % " ms GC time : ", gctime() - gc," ms " %>>$ if !*rational neq car !*rational_bak then if !*rational then algebraic(off rational) else algebraic(on rational)$ !*rational_bak:= cdr !*rational_bak$ return l$ end$ %------------------- symbolic procedure err_catch_short(a1,vl,pdes)$ begin scalar h,bak,kernlist!*bak,kord!*bak,mi,newp,p1,bakup_bak; bak:=max_gc_counter$ max_gc_counter:=my_gc_counter+max_gc_short; kernlist!*bak:=kernlist!*$ kord!*bak:=kord!*$ bakup_bak:=backup_; backup_:='max_gc_short$ h:=errorset({'shorten_pdes,mkquote a1},nil,nil) where !*protfg=t; kernlist!*:=kernlist!*bak$ kord!*:=kord!*bak; erfg!*:=nil; max_gc_counter:=bak; backup_:=bakup_bak; return if (errorp h) or (caar h=nil) then nil else << mi:=caar h; newp:=cdar h; h:=nil; p1:=0; for each pc in cdr newp do p1:=p1+get(pc,'terms); mi:=(<> else mkeq(pc,fctsort union(get(caddr mi,'fcts), get(cadddr mi,'fcts)), vl,allflags_,t,list(0),nil,pdes); for each pc in h do if pc then p1:=p1-get(pc,'terms); h >> . cdr newp); if print_ then << if tr_short then << for each h in cdr newp do <>$ for each h in car mi do if null h then <> else <>$ >>$ write "shortening by ",p1," term"$ if p1 neq 1 then write"s"$ terpri()$ >>; for each pc in cdr newp do drop_pde(pc,nil,nil); mi >> end$ %------------------- symbolic procedure is_algebraic(p)$ % checks whether the leading derivative is algebraic % if true and if lex_fc:=nil then all allvar functions turn up % only algebraically begin scalar h; h:=get(p,'derivs)$ return if null h then t else <> end$ %------------------- symbolic procedure shorten_pdes(des)$ begin scalar mi,p1,p1rl,p1le,pc,pcc,newp, l0,l1,l2,l3,l4,version,p1_is_alg$ %,valcp$ if pairp des and pairp cdr des then << version:=1; repeat << % find the pair of pdes not yet reduced with each other % with the lowest product of their number of terms % printlength's mi:=nil; pc:=des; while cdr pc do << p1:=car pc;pc:=cdr pc; if flagp(p1,'to_eval) %and % ((get(p1,'terms)>1) or << % valcp:=get(p1,'val); % if car valcp='!*sq then valcp:=reval valcp; % freeof(valcp,'PLUS) % >>) then << p1rl:=get(p1,'rl_with); p1le:=get(p1,'terms); l1:=get(p1,'derivs); l0:=length l1; if struc_eqn then p1_is_alg:=is_algebraic(p1)$ pcc:=pc; while pcc do if flagp(car pcc,'to_eval ) and % ((get(car pcc,'terms)>1) or << % valcp:=get(car pcc,'val); % if car valcp='!*sq then valcp:=reval valcp; % freeof(valcp,'PLUS) % >>) and ((not member(car pcc, p1rl )) or (not member(p1 ,get(car pcc,'rl_with))) ) and ((null struc_eqn) or p1_is_alg or (is_algebraic(car pcc) and (p1le=get(car pcc,'terms)) ) ) and <l3 ) and % necessary requirement (( null mi ) or (( car mi) > l3) ) then t else nil >> else << l3:=length(setdiff(l1,setdiff(l1,l2)))$ l4:=length(union(l1,l2))$ if (l3>0) and ((null mi) or ((((car mi)*l4) > ((cadr mi)*l3)))) then t else nil >> >> then <> else pcc:=cdr pcc >> else pcc:=cdr pcc; >> >>$ if mi then << newp:=shorten(caddr mi,cadddr mi); if null newp then add_rl_with(caddr mi,cadddr mi) >> >> until (null mi) or newp; % if not possible then already returned with nil >>; return (mi . newp) end$ %------------------- symbolic procedure partition_1(l,la)$ % l is an equation, % returning (l1 . l2) where % l1=partitioning of equation l into ((lpow1.lc1),(lpow2.lc2),...) % l2=(lpow1,lpow2,...) % This works currently only for l that are linear in elem. of la begin scalar l1,l3; l:=reorder !*a2f l; while pairp l and member(l3:=car lpow l,la) do << l1:=cons((l3 . !*f2a lc l), l1)$ l:= red l; >>; return if l then (append(l1,list(1 . !*f2a l)) . append(la,list(1))) % inhomogeneous case else (l1 . la) % homogeneous case end$ %------------------- symbolic procedure partition_2(de,l)$ % dropping from de all parts that can not be matched by the other % equation, a list of ftem-functions and their derivatives from % the other equation is l begin scalar newde,dropped,n; % dropped is the number of terms that can not be matched and % which are therefore dropped dropped:=0$ while de do << n:=no_of_terms cdar de$ if member(caar de,l) then newde:=cons(cons(n,car de),newde) else dropped:=dropped+n; de:=cdr de >>; return (dropped . newde) end$ %------------------- symbolic procedure strip(d)$ begin scalar h; d:= if not pairp d then list d else if car d='QUOTIENT then cadr d else if car d = 'PLUS then cdr d else list(d)$ return for each h in d collect !*a2f h end$ %------------------- symbolic procedure shorten(de1,de2)$ % shorten the two pdes with each other % returns a dotted pair, where car is a list of the values of new pdes % and cdr is a list of names of pdes to be dropped begin scalar a,b,h,r,s,cp,l1,l2,l1ul2,l1ml2,l2ml1,l1il2,oldorder, de1p,de2p,termsof1,termsof2,flip,n1,n2,ql,maxcancel, take_first,non_linear,homo,de2pnew,tr_short_local; non_linear:=t; % take_first:=t; % "=t is not so radical, --> eqn.s are longer and in total it is slower % tr_short_local:=t; if tr_short_local then deprint list(get(de1,'val),get(de2,'val))$ if homogen_ and (1=car get(de1,'hom_deg) ) and (1=car get(de2,'hom_deg) ) and ((cadr get(de1,'hom_deg)) neq (cadr get(de2,'hom_deg)) ) then homo:=t; if non_linear and null homo then << a:=sort_partition(de1,nil,get(de1,'fcts),nil)$ b:=sort_partition(de2,nil,get(de2,'fcts),nil)$ if tr_short_local then << write"a=",a$ terpri()$ write"b=",b$ terpri()$ >>; de1p:=nil; de2p:=nil; for each h in a do << s:=car h; cp:=b; % Does s occur in b? while cp and (s neq caar cp) do cp:=cdr cp; if cp then << r:=if (pairp s) or (numberp s) then gensym() else s; %--- dropping the ftem-depending factors once at the beginning de1p:=cons(cons(cadr h, cons(r, reval list('QUOTIENT, if cadr h>1 then cons('PLUS,caddr h) else caaddr h, s) )), de1p); de2p:=cons(cons(cadar cp, cons(r, reval list('QUOTIENT, if cadar cp>1 then cons('PLUS,caddar cp) else car caddar cp, s) )), de2p); % %--- not dropping the ftem-depending factors % de1p:=cons(cons(cadr h,cons(r,if cadr h>1 then cons('PLUS,caddr h) % else caaddr h )),de1p); % de2p:=cons(cons(cadar cp,cons(r,if cadar cp>1 then cons('PLUS,caddar cp) % else car caddar cp )),de2p); if tr_short_local then << write"de1p=",de1p$terpri()$ write"de2p=",de2p$terpri()$ >> >> >> >> else << de1p:=get(de1,'val)$ de2p:=get(de2,'val)$ if homo then << % multiplication with flin_ functions is forbidden a:=get(de1,'derivs)$ h:=nil$ while a do << if not freeoflist(car a,flin_) then h:=cons(car a,h); a:=cdr a >> >> else h:=get(de1,'derivs)$ l1:=for each a in h collect if length car a = 1 then caar a else cons('DF,car a)$ % all derivs of de1 if homo then << % multiplication with flin_ functions is forbidden a:=get(de2,'derivs)$ h:=nil$ while a do << if not freeoflist(car a,flin_) then h:=cons(car a,h); a:=cdr a >> >> else h:=get(de2,'derivs)$ l2:=for each a in h collect if length car a = 1 then caar a else cons('DF,car a)$ % all derivs of de2 l1ml2:=setdiff(l1,l2); % l1 - l2 l2ml1:=setdiff(l2,l1); % l2 - l1 l1il2:=setdiff(l1,l1ml2); % intersection l1ul2:=union(l1,l2); % union if tr_short_local then << write"before substitution:"$terpri()$ write"l1=",l1$ terpri()$ write"l2=",l2$ terpri()$ write"de1p=",de1p$terpri()$ write"de2p=",de2p$terpri()$ write"l1ml2=",l1ml2$terpri()$ write"l2ml1=",l2ml1$terpri()$ write"l1il2=",l1il2$terpri()$ write"l1ul2=",l1ul2$terpri()$ >>; % substituting derivatives by a new variable to become kernels for each a in l1ml2 do if pairp a then << b:=gensym()$ l1:=subst(b,a,l1)$ l1ul2:=subst(b,a,l1ul2)$ de1p:=subst(b,a,de1p) >>$ for each a in l2ml1 do if pairp a then << b:=gensym()$ l2:=subst(b,a,l2)$ l1ul2:=subst(b,a,l1ul2)$ de2p:=subst(b,a,de2p) >>$ for each a in l1il2 do if pairp a then << b:=gensym()$ l1:=subst(b,a,l1)$ l2:=subst(b,a,l2)$ l1ul2:=subst(b,a,l1ul2)$ de1p:=subst(b,a,de1p)$ de2p:=subst(b,a,de2p) >>$ if tr_short_local then << write"after substitution:"$terpri()$ write"l1=",l1$ terpri()$ write"l2=",l2$ terpri()$ write"de1p=",de1p$terpri()$ write"de2p=",de2p$terpri()$ write"l1ml2=",l1ml2$terpri()$ write"l2ml1=",l2ml1$terpri()$ write"l1il2=",l1il2$terpri()$ write"l1ul2=",l1ul2$terpri()$ >>; %--- writing both equations as polynomials in elements of l1ul2 oldorder:=setkorder l1ul2; de1p:=partition_1(de1p,l1); l1:=cdr de1p; de1p:=car de1p; de2p:=partition_1(de2p,l2); l2:=cdr de2p; de2p:=car de2p; setkorder oldorder; %--- l1,l2 can now have the element 1 in case of inhomogeneous de's l1ul2:=nil; l1il2:=nil; %--- Partitioning each equation into 2 parts, one part that can %--- be matched by the other equation and one that can not. % de1p:=partition_2(de1p,l2)$ dropped1:=car de1p; de1p:=cdr de1p; % de2p:=partition_2(de2p,l1)$ dropped2:=car de2p; de2p:=cdr de2p; de1p:=cdr partition_2(de1p,l2)$ de2p:=cdr partition_2(de2p,l1)$ >>$ if (null de1p) or (null de2p) then return nil; termsof1:=no_of_terms get(de1,'val)$ termsof2:=no_of_terms get(de2,'val)$ if tr_short_local then << write"---------"$terpri()$ write"de1:",de1," with ",termsof1," terms"$terpri()$ a:=de1p; while a do << write "caar =",caar a;terpri()$ write "cadar=",cadar a;terpri()$ write "cddar=", algebraic write lisp cddar a;terpri()$ a:=cdr a; >>;terpri()$ write"de2:",de2," with ",termsof2," terms"$terpri()$ a:=de2p; while a do << write "caar =",caar a;terpri()$ write "cadar=",cadar a;terpri()$ write "cddar=",algebraic write lisp cddar a;terpri()$ a:=cdr a; >>;terpri()$ >>; % One can do a stronger restriction: The maximum that can be % canceled is sum of min of terms of the de1p,de2p sublists % corresponding to the coefficients of different ftem functions/deriv. a:=de1p; b:=de2p; n2:=nil; while a do << n1:=if (caar a)<(caar b) then caar a else caar b; % n1 is min of terms of the coefficients of the same ftem function/der. n2:=cons(2*n1,n2); a:=cdr a; b:=cdr b; >>$ % maxcancel is the maximal number of cancellations in all the % remaining runs of short depending on the current run. maxcancel:=list(0); n1:=0; while n2 do << n1:=n1+car n2; n2:=cdr n2; maxcancel:=cons(n1,maxcancel); >>; if ((car maxcancel)cadr get(de2,'hom_deg)) then flip:= t else if (termsof1> else << n1:=termsof1; n2:=termsof2 >>; if (n1=1) and (length de1p = 1) and ((atom cddar de1p) or (caddar de1p neq 'PLUS)) then << % one equation has only a single term which is not a product of sums a:=cadar de1p; % e.g. g0030 b:=de2p; while b and (cadar b neq a) do b:=cdr b; if tr_short_local then << write"one is a 1-term equation"$terpri()$ write"a=",a$terpri()$ write"b=",b$terpri()$ write"de1p.1=",de1p$terpri()$ write"de2p.1=",de2p$terpri()$ >>$ a:=if null b then nil % that term does not turn up in other equation else << % it does turn up --> success de1p:=cddar de1p; de2p:=cddar b; if tr_short_local then << write"de1p.2=",de1p$terpri()$ write"de2p.2=",de2p$terpri()$ >>$ if homo then << if pairp de2p and car de2p='PLUS then de2p:= cdr de2p else de2p:=list de2p; for each a in de2p do << r:=algebraic(a/de1p); % otherwise already successful if freeoflist(algebraic den r,ftem_) then de2pnew:=cons(r,de2pnew) >>; de2p:=if null de2pnew then <> else if cdr de2pnew then cons('PLUS,de2pnew) else car de2pnew; de1p:=1 >>; de2p % does only matter whether nil or not >> >> else << repeat << % one shortening if tr_short_local then <>$ a:=reval list('PLUS, list('MINUS, if de1p=1 then b else list('TIMES,de1p,b)), if de2p=1 then a else list('TIMES,de2p,a) )$ if in_cycle(cons(11,if flip then { get(de2,'printlength),length get(de2,'fcts),de2p, get(de1,'printlength),length get(de1,'fcts),de1p} else { get(de1,'printlength),length get(de1,'fcts),de1p, get(de2,'printlength),length get(de2,'fcts),de2p})) then nil else (list a . list(ql)) >> end$ %------------------- symbolic procedure clean_num(qc,j)$ begin scalar qc1,nall$ return if 2*(cdaar qc)<=j then t else << qc1:=car qc; % the representative and list to proportional factors nall:=cdar qc1; while cdr qc1 do if (cdadr qc1)+nall<=j then rplacd(qc1,cddr qc1) else qc1:=cdr qc1; if qc1=car qc then t else nil % whether empty or not after cleaning >> end$ %-------------------- symbolic procedure clean_den(qc,j)$ begin scalar qcc$ qcc:=qc$ while cdr qc do if clean_num(cdr qc,j) then rplacd(qc,cddr qc) else qc:=cdr qc$ return null cdr qcc % Are there any numerators left? end$ %-------------------- symbolic procedure short(ql,d1,d2,n1,n1_now,max_save_now, max_save_later,take_first,homo)$ begin % d1,d2 are two subexpressions of two expressions with n1,n2 terms % ql is the list of quotients % drp is the number of terms dropped as they can not cancel anything % dne is the number terms of d1 already done, including those dropped % mi is the minimum of n1,n2 % homo=t then non-linear equations --> must check that d2 is not % multiplied with ftem_ dependent factor scalar nall,d1cop,d2cop,m,j,e1,q,qq,qc,dcl,nu,preqc,ldcl,lnu,mi,tr_short_local; %tr_short_local:=t; mi:=n1; m:=0; nall:=0; d1cop:=d1; % n1_now is the maximum number of terms cancelling each other % in this run of short based on 2*(number of remaining terms of d1 % still to check). % max_save_now is the maximum number of cancellations based % on 2*min(terms of d1, min terms of d2) j:=if n1_now> else << ldcl:=dcl; repeat ldcl:=lc ldcl until numberp ldcl$% or car ldcl = '!:RN!:$ dcl:=car cancel(dcl ./ ldcl) >>; nu:=car q; % nu is the numerator of the current quotient if numberp nu then <> else if homo and not freeoflist(nu,ftem_) then nu:=nil else << lnu:=nu; repeat lnu:=lc lnu until numberp lnu$% or car ldcl = '!:RN!:$ nu:=car cancel(nu ./ lnu) >>; if (lnu>1000000000) or (ldcl>1000000000) then if tr_short then << write" Num. factors grew too large in shortening."$ terpri() >> else else if nu then << % - ql is a list of denominator classes: (dcl1 dcl2 dcl3 ...) % - each denominator class dcli is a dotted pair (di . nclist) where % - di is the denominator and % - nclist is a list of numerator classes. % Each numerator class is a list with % - first element: (ncl . n) where ncl is the numerator % up to a rational numerical factor and n is the number of % occurences of ncl (up to a rational numerical factor) % - further elements: (nfi . ni) where nfi is the numerical % proportionality factor and ni the number of occurences % of this factor %---- search for the denominator class qc:=ql; while qc and (dcl neq caar qc) do qc:=cdr qc; if null qc then % denominator class not found if j <= 0 then % add denominator class, here nall,m are not % assigned as it would only play a role if % one equation had only one term but that % is covered as special case ql:=cons((dcl . list(list((nu . 1),((lnu . ldcl) . 1)))), ql) else % too late to add this denominator else << % denominator class has been found %---- now search of the numerator class qc:=cdar qc; % qc is the list of numerator classes nclist while qc and (nu neq caaar qc) do <>; if null qc then % numerator class not found if j leq 0 then % add numerator class rplacd(preqc,list(list((nu . 1),((lnu . ldcl) . 1))) ) else % too late to add this numerator else <<% numerator class found nall:=cdaar qc + 1; % increasing the total number of occur. rplacd(caar qc,nall); %---- now search for the numerical factor qq:=(lnu . ldcl); qc:=cdar qc; while qc and (qq neq caar qc) do <>; if null qc then << % numerical factor not found m:=1; rplacd(preqc,list((qq . 1))) >> else << m:=add1 cdar qc$ rplacd(car qc,m) >> >> % numerator class found >> % denominator class found >> % not (homo and ftem_ - dep. factor for d2) >>$ % all terms of d2 j:=if n1_now0 then << while ql and clean_den(car ql,j) do ql:=cdr ql; if ql then << qc:=ql; while cdr qc do if clean_den(cadr qc,j) then rplacd(qc,cddr qc) else qc:=cdr qc >> >>; if tr_short_local then << terpri();write length ql," denominators"; >>; % If there is only one quotient left and no new one can be added % (because of j>0) then take_first:=t % The following lines need only be un-commented but a test % showed no speed up, only slight slowing down % % if (null take_first) and % (j > 0) and % no new quotients will be added % ql and (null cdr ql) and % only one denominator class % (null cddar ql) and % only one numerator class in cdar ql % % the numerator class is cadar ql % (1=cdar cadar ql) then take_first:=t >> % all terms of d1 until (null d1cop) or % everything divided (take_first and (nall+m>n1)) or % successful: saving > cost ((j > 0) and (null ql))$ % all quotients are too rare --> end return % cons(take_first, if ((j > 0) and (null ql)) then nil else if m+nall<=mi then (ql . nil) else (ql . q) % ) end$ % of short symbolic procedure drop_lin_dep(arglist)$ % drops linear dependent equations begin scalar pdes,tr_drop,p,cp,incre,newpdes,m,h,s,r,a,v, vli,indp,indli,conli,mli,success$ % the pdes are assumed to be sorted by the number of terms, % shortest come first % vli is the list of all `independent variables' v in this lin. algebra % computation, i.e. a list of all different products of powers of % derivatives of ftem functions and constants % format: ((product1, v1, sum1),(product2, v2, sum2),...) % where sumi is the sum of all terms of all equations multiplied % with the multiplier of that equation % indli is a list marking whether equations are necessarily lin % indep. because they involve a `variable' v not encountered yet % mli is the list of multipliers of the equations pdes:=car arglist$ % tr_drop:=t$ if pdes and cdr pdes then << while pdes do << p:=car pdes; pdes:=cdr pdes; newpdes:=cons(p,newpdes); m:=gensym()$ a:=sort_partition(p,nil,get(p,'fcts),nil); if tr_drop then <>; if car indli then pdes:=cons(car newpdes,pdes) else << s:=cdr solveeval {cons('LIST,subst(1,car mli,conli)),cons('LIST,cdr mli)}; if s then <> >> else <> >>; >>; newpdes:=cdr newpdes; indli:=cdr indli; conli:=subst(0,car mli,conli); mli:=cdr mli >>; pdes:=cons(car newpdes,pdes) >>; return if success then list(pdes,cadr arglist) else nil end$ symbolic procedure find_1_term_eqn(arglist)$ % checks whether a linear combination of the equations can produce % an equation with only one term if not lin_problem then nil else begin scalar pdes,tr_drop,p,cp,incre,m,h,s,r,a,v, vli,indp,indli,conli,mli,mpli,success, sli,slilen,maxlen,newconli,newpdes,newp,fl,vl$ %tr_drop:=t$ if tr_drop then terpri()$ pdes:=car arglist$ newpdes:=pdes$ %--------------------------------- % if struc_eqn then << % cp:=pdes; % while cp do << % if is_algebraic(car cp) then r:=cons(car cp,r) % else s:=cons(car cp,s); % cp:=cdr cp % >>; % r:=nil; % s:=nil; % >>$ % Drop all PDEs which have at least two derivs which no other have %--------------------------------- if pdes and cdr pdes then << while pdes do << p:=car pdes; pdes:=cdr pdes; m:=gensym()$ if tr_drop then <>$ if s then << % found 1-term equation if null success then for each p in newpdes do << fl:=union(get(p,'fcts),fl); vl:=union(get(p,'vars),vl) >>$ success:=t$ maxlen:=0$ s:=cdar s; % first solution (lin. system), dropping 'LIST % now find the equation to be replaced by the 1-term-equation % find the non-vanishing m in s, such that the corresponding p in % mpli has a maximum number of terms while s do << if caddar s neq 0 then << r:=cadar s; cp:=mpli; while caar cp neq r do cp:=cdr cp; if get(cdar cp,'terms)>maxlen then << p:=cdar cp; % p will be the equation to be replaced m:=r; maxlen:=get(p,'terms); >> >>$ s:=cdr s >>$ % Now replacing the old equation p by the new 1-term equation in conli: r:=0; newconli:=nil$ while conli do << v:=subst(0,m,car conli)$ conli:=cdr conli$ if r=h then << v:=reval {'PLUS,{'TIMES,m,newp},v}$ >>$ newconli:=cons(v,newconli); r:=add1(r) >>$ conli:=reverse newconli$ % the new equation: newp:=mkeq(newp,fl,vl,allflags_,t,list(0),nil,nil); % last argument is nil as no new inequalities can result % if new equation has only one term newpdes:=cons(newp,newpdes); if print_ then << terpri()$ write"The new equation ",newp$ typeeq newp$ write" replaces ",p$ typeeq p$ >>; drop_pde(p,nil,nil)$ newpdes:=delete(p,newpdes); % update of mpli: mpli:=subst(newp,p,mpli)$ if tr_drop then << write"mpli=",mpli$terpri()$ >>; >>; % end of successful find cp:=conli; for s:=1:h do cp:=cdr cp; rplaca(cp,reval {'PLUS,-1,car cp}); >> % if the 1-term PDE is not already known >>$ % for each possible single term >>; return if success then list(newpdes,cadr arglist) else nil end$ endmodule$ end$ % moegliche Verbesserungen: % - auch subtrahieren, wenn 0 Gewinn (Zyklus!) % - kann Zyklus mit decoupling geben % - evtl erst alle Quotienten bestimmen, dann die Heuristik: % . erst wo nur die kleinere Gleichung mit ftem-Funktionen multipliziert % wird % . wo nur die kleinere Gleichung multipliziert wird % . alle Quotienten werden auf Hauptnenner gebracht und der mit der % groessten Potenz mit der die kuerzere Gleichung multipliziert wird, % ist der erste % - Erweiterung auf mehrere Gleichungen % - counter example: % 0 = +a+b+c % 0 = -b +d+e % 0 = -c-d +f % 0 = -a -e-f % combining any 2 gives a longer one % the sum of all 4 is even zero. % - In order not to run into a cycle with decouple one could use % dec_hist_list but that costs memory. mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crgensep.red0000644000175000017500000013574011526203062024103 0ustar giovannigiovanni%********************************************************************* module gensep_lin$ %********************************************************************* % Routines for generalized separation of de's % Author: Andreas Brand, Thomas Wolf 1990 1994 1997 % Thomas Wolf since 1997 symbolic procedure quick_gen_separation(arglist)$ % Indirect separation of a pde if vl_ then % otherwise not possible --> save time begin scalar p,l,l1,pdes,stp$ % pdes:=clean_up(car arglist)$ % if pdes then l:=list(pdes,cadr arglist)$ % because the bookeeping of to_drop is not complete instead: pdes:=car arglist$ % to return the new list of pdes in case gensep is not successful if expert_mode then << l1:=selectpdes(pdes,1); if get(car l1,'starde) then flag(l1,'to_gensep) >> else l1:=cadddr arglist$ if (p:=get_gen_separ_pde(l1,t,t)) then % high priority <>$ l:=list(pdes,cadr arglist)>>$ return l$ end$ symbolic procedure gen_separation(arglist)$ % Indirect separation of a pde if vl_ then % otherwise not possible --> save time begin scalar p,l,l1,pdes,stp$ % pdes:=clean_up(car arglist)$ % if pdes then l:=list(pdes,cadr arglist)$ % because the bookeeping of to_drop is not complete instead: pdes:=car arglist$ % to return the new list of pdes in case gensep is not successful if expert_mode then << l1:=selectpdes(pdes,1); if get(car l1,'starde) then flag(l1,'to_gensep) >> else l1:=cadddr arglist$ if (p:=get_gen_separ_pde(l1,nil,t)) then % low priority <>$ l:=list(pdes,cadr arglist)>>$ return l$ end$ symbolic procedure maxnoargs(fl,v)$ % determines the maximal number of arguments of any of the % functions of fl begin scalar f,n,m; n:=0; for each f in fl do <>; return n end$ symbolic procedure get_gen_separ_pde(pdes,high_priority,lin)$ % looking for a pde in pdes which can be indirectly separated % if lin then only a liner PDE % p ...the next equation that will be chosen % dw...whether p was already delt with % na...number of variables in the equation % nv...maximal number of arguments of any of the functions of p % nf...min number of functions to be dropped before direct sep. % leng...length of p begin scalar p,nv,nf,dw,len,h1,h2,h3,h4,nvmax$ %na,h5 % ncmax:=nvmax$ if high_priority then << nvmax:=0; for each p in pdes do if (h1:=get(p,'nvars))>nvmax then nvmax:=h1; p:=nil >>$ while pdes do << if flagp(car pdes,'to_gensep) and (null lin or get(car pdes,'linear_)) and % not too many terms or enough terms <h1) or (high_gensep> and % no single function depending on all variables: (h3:=get(car pdes,'starde) ) and % not directly separable: (cdr h3 neq 0 ) and % Each time the equation is investigated and differentiated % wrt the first element of car h3, this element is dropped. % --> The equation should not already have been differentiated % wrt all variables: (not null car h3 ) and % If equations have been investigated by generalized % separation or if equations resulted from generalized % separation then they get the flag used_ to be solved % first, not to have too many unevaluated new functions % at a time ((h4:=flagp(car pdes,'used_) ) or (null dw) ) and % The variables in h3 are the ones wrt which direct separation % shall be achieved after differentiation, therefore functions % of these variables have to be thrown out. The remaining % functions shall be of as many as possible arguments to % make quick progress: ((null p ) or (len > h1 ) or % neu ((len = h1) and ( % neu (nv < (h2:=maxnoargs( get(car pdes,'fcts), car h3 )) ) or ((nv = h2) and ( % (na < (h5:=get(car pdes,'nvars)) ) or % ((na = h5) and ( ((null dw) and flagp(car pdes,'used_)) or (( nf > cdr h3 ) or ((nf = cdr h3 ) and (len > h1 ) ) ) ) )))) then <>$ pdes:=cdr pdes$ >>; return p end$ %----------------- symbolic procedure gensep(p,pdes)$ % generalized separation of pde p if zerop cdr get(p,'starde) then separate(p,pdes) % be dropped? else % e.g. a=((x y z).2) % POSSIBLE REASONS FOR FAILURE: % - After the sequence of divisions and differentiations in the direct % separation, if there explicit v-dependent coefficients are taken % out which also contain later integration variables, then the integrands % are not total derivatives anymore --> no backintegration is possible. % - This corresponds to the case when all variables occur explicitly but % in a non-product expression, like sin(x*y*z) begin scalar a,pl$ if print_ then <>$ if tr_gensep then <>$ %--- so far only one DE p in the pool starlist of equations pl:=partitn(get(p,'val), % expression nil, % history of divisions/diff so far get(p,'fcts), % functions get(p,'vars), % variables car get(p,'starde) % separation charac. ); if pl then << pl:=append(for each a in car pl collect cdr a,cadr pl); pl:=mkeqlist(pl,fctsort union(ftem_,get(p,'fcts)),get(p,'vars), cons('to_drop,allflags_),t,get(p,'orderings),pdes)$ drop_pde(p,nil,nil); flag(pl,'used_); if print_ then < 1 then write"s"$ write" : "$ if tr_gensep then typeeqlist pl else listprint pl$ terpri() >> >> else << remflag1(p,'to_gensep)$ pl:=list p >>$ return pl$ end$ %----------------- symbolic procedure partitn(q,old_histy,ftem,vl,a)$ % This procedure calls itself recursively! % q: a **-expression to be separated % old_histy: a list of elements {denom,v,{(divisor . expr_before),..}} % where a sequence of divisions through factors from the % list of divisors and differentiations wrt. v and % afterwards multiplication with denom resulted in q % ftem: functions in the expression % vl: variables in the expression % a: the variables for direct separation=car starp() % % RETURNS {{(c1.q1),(c2.q2),(c3.q3),..},{s1,s2,s3,..},{r1,r2,..},{f1,f2,..}} % where qi=0 are necessary consequences, % qi are not *-expressions, % sum_i ci*qi = q % si=0 are consistency conditions determining constants/functions % of integration % ri=0 are other cases to be checked --> case distinctions begin scalar histy,l1,l4,nv,vl1,nv1,h,x,f,ft,aa,bb,cc,y, ruli,extra_cond,par,cases,newf$ %--- ft: the list of functions to drop from q by differentiation %--- to do a direct separation wrt x: % x = any one variable in a on which a function with as % many as possible variables does not depend on % Find such a function and variable x ft:=ftem; nv:=0; while ft do << vl1:=fctargs car ft; nv1:=if vl1 then length vl1 else 0; if nv1 > nv then << h:=setdiff(a,vl1); if h then << x:=car h; % if possible find an x occuring explicitly in q while h and freeof(q,car h) do h:=cdr h; if h then x:=car h; f:=car ft; nv:=nv1 >> >>; ft:=cdr ft >>; if nv=0 then x:=car a; % no x was found if tr_gensep then <>$ % Find all functions ft in q depending on x ft:=nil$ for each f in ftem do if member(x,fctargs f) and not freeof(q,f) then ft:=cons(f,ft)$ ft:=fctsort reverse ft$ % sorting w.r.t. number of args ruli:=start_let_rules()$ %--- throwing out functions ft until ft=nil %--- or until the expression lost the *-property while ft do % for each function to get rid of % (possibly each time a different diff variable) if null (l1:=felim(q,car ft,ftem,vl)) then ft:=nil % to stop else << %prettyprint l1; for each h in cdadr l1 do % special extra cases if not freeoflist(car h,ftem) then cases:=cons(car h,cases); %write"cadr l1=",cadr l1$terpri()$ if zerop car l1 then << q:=reval {'QUOTIENT,cdr cadadr l1,car cadadr l1}; % new expression cc:=cons(car cadr l1,cddadr l1); >> else << q:=car l1$ % new expression cc:=cadr l1; >>$ if (pairp q) and (car q='QUOTIENT) then << bb:=caddr q; % we take off the denimonator q:=cadr q >> else bb:=1$ histy:=cons(cons(bb,cc),histy)$ % extended history %terpri()$write"q=",q$terpri()$ %write"histy=",histy$terpri()$ ftem:=smemberl(ftem,q)$ % functions still in q aa:=stardep(ftem,argset(ftem))$ % still *-expression? if not aa or zerop cdr aa then ft:=nil % to stop else ft:=smemberl(cdr ft,ftem) % remain. fcts of x >>$ stop_let_rules(ruli)$ if null l1 then if tr_gensep then <>; %--- prepare list of variables vl1 for direct separation vl1:=nil$ for each y in vl do if my_freeof(ftem,y) then vl1:=cons(y,vl1); %--- direct separation if useful (i.e. if aa(=stardep) neq nil) if vl1 and not (q=0) then <>$ l1:=separ(q,ftem,vl1,nil)$ % direct separation of the numerator if tr_gensep then <>$ >> else l1:=list cons(1,q)$ if tr_gensep then << terpri()$ write"Separation gave ",length l1," condition(s)" >>; % Although the vaiable x does not occur anymore % (each felim call removed one function of x % and direct separation removed explicit occurences of x) % the remaining expression may still be indirectly separable % --> recursive call of partitn % l4 becomes a list of pairs (sep_coefficient . sep_remainding_factor) for each h in l1 do << ft:=smemberl(ftem,cdr h); vl1:=argset(ft)$ if null (aa:=stardep(ft,vl1)) then l4:=cons(h,l4) else << par:=partitn(cdr h, % expression append(histy, % history so far, old_histy), % needed to add new functions % of integration properly differentiated to be % able to integrate below ft, % functions vl1, % variables car aa % separation charac. ); % RETURNS {{(c1.q1),(c2.q2),(c3.q3),..},{s1,s2,s3,..}, % {r1,r2,..},{f1,f2,..} } % where qi=0 are necessary consequences, % qi are not *-expressions, % sum_i ci*qi = q % si=0 are consistency conditions determining constants/functions % of integration % ri=0 are other cases to be checked --> case distinctions l4:=append(l4,for each f in car par collect ({'TIMES,car h,car f} . cdr f)); extra_cond:=append(extra_cond,cadr par); % collecting any % appearing conditions cases:=append(cases,caddr par); newf:=cadddr par; ftem:=append(ftem,newf); >> >>$ %--- backintegration par:=backint(l4,old_histy,histy,ftem,vl)$ extra_cond:=append(extra_cond,cadr par); % collecting any conditions {car par,extra_cond,cases,append(newf,caddr par)} >> end$ %----------- symbolic procedure felim(q,f,ftem,vl)$ % returns: nil if not successful (quotient) otherwise % {the expression after all the divisions and differentiations, % {diff variable, sequence of (factor . expression before)} } begin scalar a,b,l,l1,ft1,v,prflag$ %--- getting rid of f through diff. wrt. v v:=car setdiff(vl,fctargs f)$ %--- ft1 are all v-independent functions %--- In the call to separ one has to disregard v-dep. functions ft1:=nil$ for each f in ftem do if my_freeof(f,v) then ft1:=cons(f,ft1)$ %--- To run separ, functions ft1 should not be in the denominator %--- ?????? What if nonl. Problems? if not (pairp q and (car q='QUOTIENT) and smemberl(ft1,caddr q)) then % This exceptional case should not occure anymore <>$ print_:=prflag$ %--- l is a list of dotted pairs a each representing a term in q % where car(a) is the product of v-dep. factors and cdr(a) the % product of v-independent factors %--- A list l1 of car(a) is generated for which cdr(a) depends % on f. l1 is the list of divisions to be done before differen. l1:=nil$ while l do <>$ if tr_gensep then <>$ %--- Now the divisions and differentiations are done while l1 do <> >> >>$ %if l then part_histy:=cons(v,l)$ %--- output if tr_gensep then <>$ if tr_gensep and l then <>$ l1:=list(q,cons(v,l)) >>$ return l1 end$ symbolic procedure backint(l4,old_histy,histy,ftem,vl)$ % l4 is a list of pairs (sep_coefficient . % sep_remainding_factor_to_be_integrated) % old_histy, histy are lists of elements % {denom,v,{(divisor . expr_before),..}} % where a sequence of divisions through factors from the % list of divisors and differentiations wrt. v and % afterwards multiplication with denom resulted in q % Integrations should only be done inverting histy, but % in choosing functions of integration, both should be used % % returns {- integrated equivalent of l4 where the cdr of each element % is the integrated expression, % - a list of check_sum conditions, % - a list of new functions} begin scalar succ,ft,q,l,v,v1,vf,s1,s2,p,f1,f2,fctr,check_sum, allfnew,new_cond,denomi$ % start of the backintegration succ:=t$ while histy and succ do <>$ % Now the sequence of integrations wrt v % l is the list of (factor . expression before division & diff) while l do << % while l and q do fctr:=caar l; check_sum:=cdar l; l:=cdr l; if tr_gensep then <>$ %write"l4="$ %prettyprint l4; % l4 is a list of pairs (sep_coefficient . sep_remainding_factor) l4:=for each h in l4 collect if null car h then h % one integration % was not succ.ful else << ft:=smemberl(ftem,cdr h)$ fnew_:=nil$ if tr_gensep then <>$ q:=integratepde(cdr h,ft,v,nil,nil)$ % genflag:=nil, potflag=nil if null q then << succ:=nil$ if print_ then << terpri()$ write "#### Back integration of "$ eqprint cdr h$ write " wrt ",v," during generalized ", "separation was not successful ####."$ terpri()$ write "The coeff. dropped in direct separation was "$ mathprint car h >> >> else << q:=reval list('TIMES,fctr,car q)$ % fctr is the next integrating factor % Neccessary: Substituting the new functions of integration by % derivatives of them such that back-integration can be made % hat fnew_ nur ein element, d.h. wird nur eine Integration gemacht % oder mehrere? for each f1 in fnew_ do <>$ if not smemberl(vf,car s1) then f2:=list('TIMES,f2,car s1)$ >>$ % the remaining integrations in the current element of histy if histy then << s2:=reverse l$ while s2 do <>; >>; if f1 neq f2 then <>$ q:=subst(f2,f1,q)$ >> >>$ allfnew:=append(fnew_,allfnew)$ ftem:=union(fnew_,ftem); if succ then check_sum:={'DIFFERENCE,check_sum,{'TIMES,q,car h}}; % car h is the coefficient dropped through direct separation >>$ (car h . q) % the value to be collected to give the new l4 >>; check_sum:=reval check_sum$ if succ then new_cond:=cons(check_sum,new_cond)$ if succ and tr_gensep then <>$ >> >>$ for each f in allfnew do ftem_:=fctinsert(f,ftem_)$ if tr_gensep then if succ then <> else <>$ fnew_:=nil$ return {l4,new_cond,allfnew} end$ endmodule$ %********************************************************************* module gensep_non_lin$ %********************************************************************* % Routines for generalized separation of de's % Author: Thomas Wolf since 1997 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic procedure my_smemberl(p,vl)$ begin scalar l,v; for each v in vl do if not my_freeof(p,v) then l:=cons(v,l); return reverse l end$ %----------- symbolic procedure stripcond(conds)$ begin scalar newconds,condi; newconds:=nil; while conds do << condi:=cdar conds; conds:=cdr conds; if length condi=1 then condi:=car condi else condi:=cons('PLUS,condi); newconds:=cons(condi,newconds) >>; return newconds end$ %----------- symbolic procedure checkli(exlist,condi)$ begin scalar ok,isincondi,isinexli,excopy,n; ok:=t; while condi and ok do << % all i in the condition car condi isincondi:=car condi; %smemberl(ilist,car condi); n:=length isincondi; % are all isincondi contained in one of the elements of exlist? excopy:=exlist; while excopy and ok do << isinexli:=smemberl(isincondi,car excopy); if isinexli then if length(isinexli) = n then ok:=nil; excopy:=cdr excopy >>; condi:=cdr condi >>; return ok end$ %----------- symbolic procedure longst(exlist)$ % returns the element of exlist which (is a list and) % has the most elements begin scalar lo; while exlist do << if not lo then lo:=car exlist else if length(lo)>; return lo end$ %----------- symbolic procedure starequ(n,alindep,blindep)$ % alindep is a list of lists of factors ai which are all non-zero and % are all linear independent from each other within such a list % blindep like alindep % generates all cases each with all conditions with _i representing % ai or bi, equations and new functions are not generated begin comment The equation to separate has the form 0 = sum_i ai*bi where the bi do not depend on some variable x. The procedure starequ generates cases: cases ... ( all cases ) each case ... ( list of all a-conditions, list of all b-conditions) each condition ... ( the ai,bi contained in the condition with _i representing ai and bi ) ; scalar i,j,cases,oldcases,case,ai,bi,ci,oldaconds,oldbconds, newaconds,newbcond,newbconds,newacond, ilist,cona,conb,unin,el,pri; % ,oldpri % Determine the longest union of two list, one, ai, being element of % alindep and one, bi, being from blindep %pri:=t; i:=0; if alindep then for each cona in alindep do if blindep then for each conb in blindep do if (j:=length union(cona,conb)) > i then <> else else % no blindep given if (j:=length cona) > i then <> else else % no alindep given if blindep then for each conb in blindep do if (j:=length conb) > i then <>; % ai, bi will now be determined % preparation of the sequence ilist of extensions ilist:=for i:=1:n collect i; if pri then <>$ if i neq 0 then << if ai then i:=length ai else i:=0; if bi then j:=length bi else j:=0; unin:=union(ai,bi); % extensions through bch should be done when elements from % bi are treated. This is coded in ilist through negative numbers ilist:=setdiff(ilist,unin); if i>j then << for each el in setdiff(unin,ai) do ilist:=cons(-el,ilist); for each el in ai do ilist:=cons( el,ilist) >> else << for each el in setdiff(unin,bi) do ilist:=cons( el,ilist); for each el in bi do ilist:=cons(-el,ilist) >>; ilist:=reverse ilist >>; % ilist is prepared now if pri then <>$ while ilist do << i:=car ilist;ilist:=cdr ilist; if pri then <>$ if i>0 then ci:=mkid('_, i) else ci:=mkid('_,-i); if pri then << write"666 car ilist=",i; terpri() >>$ % if i>0 then the list of cases is extended with ai else with bi oldcases:=cases; cases:=nil; while oldcases do << % for each old case do: case:=car oldcases; if pri then <>$ oldcases:=cdr oldcases; if i>0 then << oldaconds:=car case; if pri then <>; % newcases will be the new list of all cases newcases:=nil; while cases do << % car cases is one case with alltogether n conditions which % The conditions for the a-factors are called below acons % and for the b-factors bcons. acons:= caar cases; bcons:=cadar cases; cases:= cdr cases; if pri then <>$ ali:= if not zerop car ali then for each i in cdr ali collect reval list('DF,list('QUOTIENT,i,car ali),x) else cdr ali; if pri then <>$ % Drop that element from bcons which includes % car ali (as first element) if bco:=find_cond(bcons,car aco) then bcons:=setdiff(bcons,list bco); aco:=cdr aco >>; acond:=car ali; if (pairp acond) and (car acond = 'QUOTIENT) then acond:=cadr acond; >>; newca:=cons(acond,newca) >>; if pri then <>; >>; % all a-conditions have been dealt with if pri then <>; % completing all b-conditions for each bi in ili do bcons:=subst(cdr pickfac(ex,bi),bi,bcons); % adding all b-conditions to the new case newca while bcons do << if length car bcons = 1 then newca:=cons(caar bcons,newca) else newca:=cons(cons('PLUS,car bcons), newca); bcons:=cdr bcons >>; % if ex is an *-expression with grade>1 then possibly b-conditions % had to be dropped, so ex must be added if addex then newca:=cons(exx,newca); if pri then <>; % adding the list of constants of integeration newca:=cons(cilist,newca); if pri then <>; newcases:=cons(newca,newcases) >>; return newcases end$ % of starsep %----------- symbolic procedure separizable(p,ftem,vl)$ begin scalar x,ft,f,ex,v,a,b,vlcp,allvarcaara,print_bak$ vlcp:=vl; repeat << x:=car vl; vl:=cdr vl; % Determining all x-dependent functions ft ft:=nil; for each f in ftem do if member(x,fctargs f) and not my_freeof(p,f) then ft:=cons(f,ft)$ f:=car reverse fctsort ft$ % sorting w.r.t. number of args v:=car setdiff(vlcp,fctargs f)$ % getting rid of f by v-differen. % preparation of the separ-call, ft are now v-indep. functions ft:=nil$ for each f in ftem do if my_freeof(f,v) then ft:=cons(f,ft)$ % ex:=separ(p,ft,list v,nil)$ % det. all lin. ind. factors print_bak:=print_; print_:=nil; ex:=separ2(p,ft,list v)$ % det. all lin. ind. factors print_:=print_bak; a:=ex; while a and << b:=vlcp; while b and not my_freeof(caar a,car b) do b:=cdr b; b >> do a:=cdr a; if a then allvarcaara:=cons(caar a,allvarcaara); >> until (null a) or (null vl); % if a then null vl then whatever x was, there is allways one % element (car a) of ex such that car of this element (caar a) % does depend on all variables --> no separability possible, % new functions would depend on all variables % if a then test whether separation would be possible by getting % rid of functions through differentiation % (this would not be the case if e.g. sin(all variables) would occur) % --> use of smemberl vl:=vlcp; while allvarcaara and not not_included(vlcp,smemberl(vlcp,car allvarcaara)) do <>$ return if a and null allvarcaara then nil % no chance else if a then {nil,car allvarcaara,car vl} % deleting functions first else << % separation now possible if tr_gensep then <>$ {ex,v} >> end$ %----------- symbolic procedure newgensep(p,starpro,ftem,vl)$ % ftem, vl should be correct: % ftem:=smemberl(ftem_,p)$ % vl:=varslist(p,ftem,vl)$ % starpro:=stardep(ftem,vl)$ % returns what starsep returns begin scalar pl,v,ex,a,b$ % ,gense,el1,el2,conds,newcali,l,clist$ % if pairp p and (car p = 'QUOTIENT) then <>$ % ftem:=smemberl(ftem,p)$ % vl:=varslist(p,ftem,vl)$ % if not (starpro:=stardep(ftem,vl)) then % then no *-equation % pl:=list list(nil,p) % one case, no new functions % else % e.g. starpro=((x y z).2) % if zerop cdr starpro then pl:=nil% ############################## % %list cons(nil,separate(p,ftem,vl)) % direct sep % else % if delength(p) leq gensep_ then % generalized separation % << if print_ then <>$ if tr_gensep then <>$ for each v in car starpro do vl:=delete(v,vl); vl:=append(car starpro,vl); a:=separizable(p,ftem,vl)$ if null a then return nil else if null car a then return << % functions to be deleted before separation are those in cadr a % ft:=smemberl(ftem,cadr a); if print_ then <>; nil >> else <>$ for each a in reverse idx_sort for each b in ex collect cons(delength car b,b) collect cdr a$ if tr_gensep then <>$ % with v and v-dep. functions as first factors in the terms in ex pl:=starsep(p,ex,ftem,vl,v); if tr_gensep then <>$ % print_:=oldpri$ %%############################################################ % % l is a list of cases each (list of new fncts, cond1, cond2, ...) % % for each condition (neq p) in all cases calling gensep again % % if needed % pl:=nil; % the final list of cases of only non-*-equ. % while l do % checking all cases % <>; % conds:=cdr conds % >>; % pl:=append(newcali,pl) % >> % >>; return pl end$ % of newgensep %----------- symbolic procedure gen_separation2(arglist)$ % Indirect separation of a pde, 2nd version for non-linear PDEs begin scalar p,h,fl,l,l1,pdes,forg,n,result,d,contrad,newpdes$%,newfdep,bak,sol pdes:=car arglist$ forg:=cadr arglist$ if expert_mode then << l1:=selectpdes(pdes,1); if get(car l1,'starde) then flag(l1,'to_gensep) >> else l1:=pdes$ if (p:=get_gen_separ_pde(l1,nil,nil)) then if l:=newgensep(get(p,'val), get(p,'starde), get(p,'fcts), get(p,'vars)) then if cdr l then << if print_ then << terpri()$ write"The indirect separation leads to ",length l," cases."$ %terpri()$ >>$ contrad:=t$ n:=0; remflag1(p,'to_gensep)$ % bak:=backup_pdes(pdes,forg)$ % must come before drop_pde(... backup_to_file(pdes,forg,nil)$ % newfdep:=nil$ while l do << d:=car l; l:=cdr l; if not memberl(cdr d,ineq_) then << % non of the equations is an inequality if n neq 0 then << h:=restore_and_merge(l1,pdes,forg)$ pdes:= car h; forg:=cadr h; % was not assigned above as it has not changed probably % h:=restore_pdes(bak); % pdes:=car h; forg:=cadr h >>; n:=n+1$ level_:=cons(n,level_)$ if print_ then << print_level(t)$ terpri()$ write "CRACK is now called with the assumption : "$ deprint(cdr d) >>$ % formulation of new equations for each h in car d do ftem_:=fctinsert(h,ftem_); fl:=append(get(p,'fcts),car d); newpdes:=pdes$ for each h in cdr d do newpdes:=eqinsert(mkeq(h,fl,vl_,allflags_,t,list(0),nil,newpdes),newpdes); % further necessary step to call crackmain(): recycle_fcts:=nil$ % such that functions generated in the sub-call % will not clash with existing functions l1:=crackmain(newpdes,forg)$ % for each sol in l1 do % if sol then << % for each f in caddr sol do % if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep); % >>; if not contradiction_ then contrad:=nil$ if l1 and not contradiction_ then result:=union(l1,result); contradiction_:=nil$ >> >>; delete_backup()$ % % newfdep are additional dependencies of the new functions in l1 % depl!*:=append(depl!*,newfdep); contradiction_:=contrad$ if contradiction_ then result:=nil$ if print_ then << terpri()$ write"This completes the investigation of all cases of an ", "indirect separation."$ terpri()$ >>$ result:=list result % to tell crackmain that computation is completed >> else << % only one case l:=car l; for each h in car l do ftem_:=fctinsert(h,ftem_); fl:=append(get(p,'fcts),car l); pdes:=drop_pde(p,pdes,nil)$ for each h in cdr l do pdes:=eqinsert(mkeq(h,fl,vl_,allflags_,t,list(0),nil,pdes),pdes); result:=list(pdes,forg) >>$ return result$ end$ endmodule$ end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crack.rlg0000644000175000017500000004154511527635055023405 0ustar giovannigiovanniFri Feb 18 21:27:26 2011 run on win32 %*******************************************************************% % % % C R A C K . T S T % % ----------------- % % crack.tst contains test examples for the program crack.red. % % % % Author of this file: Thomas Wolf % % Date: 11. Sep 1998, 6. May 2003 % % % % Details about the syntax of crack.red are given in crack.tex. % % % % To run this demo you need to load crack through: % % load crack$ % % and to read in this file as % % in "crack.tst"; % % If you got the source code of a newer version of crack then % % either read it in through % % in "crack.red"$ % % (with the appropriate directory name in front of crack.red) % % or, to speed up the calculation, you compile before with % % faslout "crack"$ % % in "crack.red"$ % % faslend$ % % and then load it with % % load crack$ % % % %*******************************************************************% lisp(depl!*:=nil)$ % clearing of all dependencies %setcrackflags()$ % use standart flag-setting %lisp(print_:=50)$ % if one would want to print expressions % with up to 50 factors lisp(print_:=nil)$ % to suppress printing the computation lisp(initial_proc_list_ := % initial_proc_list_ is saved for an proc_list_)$ % application at the end on dfprint$ % to print partial deriv. as indices %off batch_mode$ comment ------------------------------------------------------- Modules in CRACK The following examples illustrate the operation of various modules of CRACK. These examples are not typical applications but are chosen to demonstrate individual CRACK modules. To see typical applications of CRACK run LIEPDE.TST, CONLAW.TST or APPLYSYM.TST instead. The extra assignments in this run that involve proc_list_ are to disable all other modules and to demonstrate better the action of the individual module. ------------------------------------------------------- Format of the return of CRACK CRACK returns a list {sol_1,...} of one or more solutions where each solution is a list: { list_of_remaining_unsolved_equations, list_of_computed_values_of_functions_or_constants, list_of_free_functions_or_constants, list_of_inequalities_valid_for_this_solution } Empty lists are {}. =======================================================; write" Integration: Integrating exact PDEs "$ Integration: Integrating exact PDEs comment An important part of CRACK are integration routines which employ a number of different techniques which are demonstrated next. At first an example for the integration of exact PDE; depend f,x,y$ depend g,x$ de:=2*df(f,y)*df(g,x) + 2*df(f,x,y)*g + g*df(g,x)**3 + x*df(g,x)**4 + 3*x*g*df(g,x)**2*df(g,x,2)$ lisp(proc_list_ := '(integration))$ crack({de},{},{f,g},{}); 3 {{{g *g*x*y + c_1 + c_2 + 2*f*g}, x {}, {g,f,c_2,c_1}, {}}} write"-------------------------------------------------------"$ ------------------------------------------------------- write" Integration: Integration of an exact PDE + terms "$ Integration: Integration of an exact PDE + terms write" which are not exact (are not a total "$ which are not exact (are not a total write" derivative) but which only involve "$ derivative) but which only involve write" unknown functions of fewer variables"$ unknown functions of fewer variables comment The price of integrating non-exact expressions will be the introduction of extra conditions but in fewer variables than the integrated PDE has. A special algorithm minimizes the number of new functions of fewer variables to be introduced. The bracket below is a polynomial in the integration variable x, as a consequence the algorithm is applicable such that only one extra function has to be introduced. $ de:=de + g^2*(y^2 + x*sin y + x^2*exp y)$ crack({de},{},{f,g},{}); 2 {{{c_3 - g , 3x y 2 3 y 3*cos(y)*c_3 *x - 3*cos(y)*c_3 - 3*e *c_3 *x - c_3 *y + 6*e *c_3 *x 2x x 2x 2x x 3 y - 3*g *g*x*y - 6*e *c_3 - 3*c_4 - 3*c_5 - 6*f*g}, x {}, {g, f, c_5, c_4, c_3}, {}}} nodepnd {f,g}$ write"-------------------------------------------------------"$ ------------------------------------------------------- write" Integration: Integrating Factors"$ Integration: Integrating Factors comment Heuristics for the determination of integrating factors in CRACK are not rigorous but often useful. $ depend f,x,y$ g:=df(f,x)/e**x+df(f,y)/x**2$ crack({num(df(g,x))},{},{f},{}); 2 x x 2 {{{f *x + e *f + e *c_6*x }, x y {}, {f,c_6}, {}}} clear g$ nodepnd {f}$ write"-------------------------------------------------------"$ ------------------------------------------------------- write" Integration: Recognizing a 2-dim divergence"$ Integration: Recognizing a 2-dim divergence comment Being able to recognize a structure 0=df(a,x)+df(b,y) where a,b are differential expressions is of benefit if a,b can both be solved for a unknown function as in the following example. $ lisp(proc_list_ := '(subst_level_4 integration))$ depend f,x,y$ depend g,x,y$ depend h,x,y$ a:=x*f+y*df(g,y)$ b:=df(g,x,y)*sin(x)+h/y$ crack({df(a,x)+df(b,y)},{},{f,g,h},{}); {{{}, {h=cos(x)*g *y + c_7 *y, y x - c_7 - g *sin(x) - g *y y 2y y f=-----------------------------}, x {g,c_7}, {}}} nodepnd {f,g,h}$ write"-------------------------------------------------------"$ ------------------------------------------------------- write" Integration: Solving ODEs for partial derivatives"$ Integration: Solving ODEs for partial derivatives comment In CRACK ODEs and PDEs which are ODEs for a single partial derivative are investigated by the program ODESOLVE by MacCallum/Wright. In the following example this technique together with a previous one are successful. $ depend f,x,y$ lisp(proc_list_ := '(subst_level_4 integration))$ crack({x**2*df(f,x,2,y)-2*x*df(f,x,y)-df(f,y)+x**3/y**2}, {},{f},{}); {{{}, sqrt(13)*log(x) sqrt(13)/2 sqrt(13)/2 3 {f=(sqrt(x)*e *c_10*x*y - x *c_12*y - x *x sqrt(13)/2 + sqrt(x)*c_11*x*y)/(x *y)}, {c_12,c_11,c_10}, {}}} nodepnd {f}$ write"======================================================="$ ======================================================= write" Separation: Direct separation of PDEs"$ Separation: Direct separation of PDEs comment Another important group of modules concerns separations. In this example z is an extra independent variable on which f and g do not depend (therefore z is in the 4th argument to crack). There is furthermore a function h=h(z) which is assumed to be given and is not to be calculated as it is not element of the third argument to CRACK, i.e. the question is to find expressions for f,g for arbitrary h. In the computation below, h is treated as being linear independent from z because h is declared as arbitrary. If h would be added to the list {f,g} then h would have to be computed and direct separation would not be possible but only indirect separation (see next example). $ depend f,x$ depend g,y$ depend h,z$ de:=z*f + h*y*g$ lisp(proc_list_ := '(subst_level_4 separation))$ crack({de},{},{f,g},{z}); {{{},{g=0,f=0},{},{}}} nodepnd {f,g,h}$ write"-------------------------------------------------------"$ ------------------------------------------------------- write" Separation: Indirect separation of PDEs"$ Separation: Indirect separation of PDEs write" (combined with integration)"$ (combined with integration) comment This example is the same as before, only now h is not assumed to be given but to be calculated. In this example there is no variable turning up only explicitly to allow a direct separation. But there is also no function which depends on all variables and this allows the use of an indirect separation method. This example also demonstrates factorization and the splitting into subcases to do substitutions in non-linear problems. Three solutions result, 1. f=h=0, g arbitrary, 2. f,g,h given in terms of two constants, both non-vanishing 3. f=g=0, h arbitrary, h non-vanishing. $ depend f,y$ depend g,x$ depend h,z$ de:=z*f + h*y*g$ lisp(proc_list_ := '(subst_level_3 separation gen_separation alg_solve_single))$ crack({de},{},{f,g,h},{}); {{{},{g=0,f=0},{h},{}}, {{}, - c_13 {h= - c_14*z,g=---------,f= - c_13*y}, c_14 {c_13,c_14}, {c_14,c_13}}, {{},{h=0,f=0},{g},{g}}} nodepnd {f,g,h}$ write"======================================================="$ ======================================================= write" Combination: Pseudo Differential Groebner Basis"$ Combination: Pseudo Differential Groebner Basis comment Another group of modules tries to take advantage of combining equations or their derivatives. The main tool in this respect computes a Pseudo Differential Groebner Basis. In interactive mode (off batch_mode) it is possible to choose between different orderings of derivatives which is not demonstrated here. (The origin of the following example is described at the end of this file.) ; depend xi ,x,y$ depend eta,x,y$ lisp(proc_list_ := '(separation decoupling))$ crack({2*df(eta,x,y)*x**5*y1 + df(eta,x,2)*x**5 - df(eta,x)*x**4 - 2*df(eta,x)*x**2*y + df(eta,y,2)*x**5*y1**2 - 4*df(eta,y)*x*y**2 - 2*df(xi,x,y)*x**5*y1**2 - df(xi,x,2)*x**5*y1 - df(xi,x)*x**4*y1 - 2*df(xi,x)*x**2*y*y1 + 8*df(xi,x)*x*y**2 - df(xi,y,2)*x**5*y1**3 - 2*df(xi,y)*x**4*y1**2 - 4*df(xi,y)*x**2*y*y1**2 + 12*df(xi,y)*x*y**2*y1 - 2*eta*x**2*y1 + 8*eta*x*y + x**3*xi*y1 + 6*x*xi*y*y1 - 16*xi*y**2}, {},{eta,xi},{x,y,y1}); {{{xi , y 2 xi *x - xi *x + xi, 2x x 3 2 xi *x - xi *x*y - eta*x - x *xi + 3*xi*y}, x x {}, {xi,eta}, {}}} nodepnd {xi,eta}$ write"-------------------------------------------------------"$ ------------------------------------------------------- write" Combination: Shortening linear PDE systems"$ Combination: Shortening linear PDE systems comment To reduce memory requirements now and for further computations with a system of equations it is advisable to find length reducing linear combinations. The shorther equations become, the more useful they are to shorten other equations and the more likely they are integrable.; depend f,x,y$ a:=sin(x)*y+7*x+3*df(f,x)$ b:=df(f,y)*y+f*x+x*y**2$ c:=3*x*y**2+sin(x)*y-4$ lisp(proc_list_ := '(alg_length_reduction))$ crack({a,a*c+b},{},{f},{}); {{{3*f + sin(x)*y + 7*x, x 2 f *y + f*x + x*y }, y {}, {f}, {}}} clear a,b,c$ nodepnd {f}$ write"======================================================="$ ======================================================= write" Parametric solution of linear underdetermined ODEs"$ Parametric solution of linear underdetermined ODEs comment The following example demonstrates an algorithm for the parametric solution of underdetermined linear ODEs with arbitrary non-constant cefficients. $ depend f,x$ depend g,x$ lisp(proc_list_ := '(subst_level_4 undetlinode))$ crack({cos(x)*df(f,x,2) - df(g,x,2)},{},{f,g},{}); {{{}, 5 4 4 {g=(6*cos(x) *c_17 - cos(x) *c_17 *sin(x) + 9*cos(x) *sin(x)*c_17 x 2x 3 2 2 + 2*cos(x) *c_17 - 2*cos(x) *c_17 *sin(x) + 2*cos(x) *sin(x)*c_17 x 2x 6 4 - 8*cos(x)*c_17 - 8*sin(x)*c_17)/(cos(x) *sin(x) + 4*cos(x) *sin(x) x 2 + 4*cos(x) *sin(x)), 4 4 3 f=( - cos(x) *c_17 + 4*cos(x) *c_17 - 4*cos(x) *c_17 *sin(x) 2x x 2 2 - 2*cos(x) *c_17 - 6*cos(x) *c_17 - 4*cos(x)*c_17 *sin(x) - 4*c_17)/( 2x x 7 5 3 cos(x) + 4*cos(x) + 4*cos(x) )}, {c_17}, {}}} nodepnd {f,g}$ write"======================================================="$ ======================================================= write"Application: Investigating point symmetries of an ODE"$ Application: Investigating point symmetries of an ODE comment Finally a small real life example that demonstrates the interplay of different modules to solve completely an overdetermined system which is generated when investigating the point symmetries of the ODE 6.97 in Kamke's book using the following CRACK input: $ % depend y,x$ % load_package crack,liepde$ % liepde({{df(y,x,2)*x**4-df(y,x)*(2*x*y+x**3)+4*y**2},{y},{x}}, % {"point"},{})$ comment (and renaming xi_x --> xi, eta_y --> eta, y!`1 --> y1 which is only done to ease reading). Instead of just doing this liepde-call which would take care of everything, we call crack below explicitly for demonstration. Two arbitrary constants in the solution stand for two symmetries. $ depend xi ,x,y$ depend eta,x,y$ lisp(proc_list_ := initial_proc_list_)$ % this was saved at the start crack({2*df(eta,x,y)*x**5*y1 + df(eta,x,2)*x**5 - df(eta,x)*x**4 - 2*df(eta,x)*x**2*y + df(eta,y,2)*x**5*y1**2 - 4*df(eta,y)*x*y**2 - 2*df(xi,x,y)*x**5*y1**2 - df(xi,x,2)*x**5*y1 - df(xi,x)*x**4*y1 - 2*df(xi,x)*x**2*y*y1 + 8*df(xi,x)*x*y**2 - df(xi,y,2)*x**5*y1**3 - 2*df(xi,y)*x**4*y1**2 - 4*df(xi,y)*x**2*y*y1**2 + 12*df(xi,y)*x*y**2*y1 - 2*eta*x**2*y1 + 8*eta*x*y + x**3*xi*y1 + 6*x*xi*y*y1 - 16*xi*y**2}, {},{xi,eta},{x,y,y1}); {{{}, 2 {eta= - 2*log(x)*c_22*y - c_22*x + c_22*y - 2*c_23*y, xi= - log(x)*c_22*x - c_23*x}, {c_23,c_22}, {}}} nodepnd {xi,eta}$ write"======================================================="$ ======================================================= write" Integration: Solving a linear 1st order PDE"$ Integration: Solving a linear 1st order PDE comment If the computation of a differential Groebner Basis is getting bigger and bigger and normal integration is not successful and also no functions of fewer variables are present then trying the solution of a 1st order linear PDE is recommended. $ lisp(proc_list_ := '(subst_level_4 full_integration gen_separation find_trafo))$ depend f,x,y; crack({df(f,x)-x**2*y*df(f,y)+x},{},{f},{}); 2 - 2*c_24 - x% {{{},{f=-----------------},{c_24},{}}} 2 write "The list of transformations done (here only one): ", lisp done_trafo; 3 x /3 The list of transformations done (here only one): {{x%=x,y%=e *y}} nodepnd {f}$ write"======================================================="$ ======================================================= lisp(depl!*:=nil)$ % to delete all dependencies of functions on variables end$ Time for test: 858 ms, plus GC time: 31 ms @@@@@ Resources used: (1 8 128 0) mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crinit.red0000644000175000017500000006475011526203062023567 0ustar giovannigiovanni%********************************************************************** module crackinit$ %********************************************************************** % Initialisation % Author: Andreas Brand 1993 - 97 % Thomas Wolf since 1994 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % % variables that are backed up in recursive calls glob_var:='( !*batch_mode !*iconic adjust_fnc allflags_ batchcount_ collect_sol confirm_subst cont_ contradiction_ cost_limit5 % dec_hist dec_hist_list depl!* done_trafo eqname_ expert_mode explog_ facint_ flin_ % force_sep fname_ fnew_ freeabs_ freeint_ ftem_ genint_ high_gensep homogen_ idnties_ independence_ ineq_ inter_divint keep_parti last_steps length_inc lex_df lex_fc lin_problem logoprint_ low_gensep max_gc_elimin max_gc_fac max_gc_red_len % mem_eff max_gc_short max_gc_ss max_red_len maxalgsys_ nequ_ new_gensep odesolve_ orderings_ target_limit_0 target_limit_1 target_limit_2 target_limit_3 target_limit_4 poly_only potint_ print_ print_all print_more proc_list_ pvm_able quick_decoup record_hist recycle_eqns recycle_fcts repeat_mode safeint_ session_ simple_orderings size_watch solvealg_ stop_ struc_dim struc_eqn subst_0 subst_1 subst_2 subst_3 subst_4 time_ to_do_list tr_decouple tr_genint tr_gensep tr_main tr_orderings tr_short tr_redlength userrules_ vl_)$ Comment : Variables not to be changed interactively are not updated: allflags_ current_dir default_proc_list_ full_proc_list_ lin_test_constmy_gc_counter max_gc_counter prop_list one_argument_functions_ reducefunctions_ trig1_ trig2_ trig3_ trig4_ trig5_ trig6_ trig7_ trig8_ The following are ment to be used continuously: size_hist sol_list stepcounter_ level_ nfct_ time_limit limit_time history_ These variables are separately backed up in crutil.red in backup_to_file() and updated in restore_backup_from_file(), see also restore_and_merge(). history_ is not backed up to accumulate all input also during subcases. Because function names and function dependencies generated in subcalls of crack are passed back in the solution that is passed back and on the other hand the backup depl!* is restored, i.e. the dependencies of the new functions is dropped, this has to be carried over by adding their dependencies to the backup depl!*. $ global_list_integer := '(odesolve_ subst_0 subst_1 subst_2 subst_3 subst_4 cost_limit5 max_gc_fac max_gc_red_len max_gc_short max_gc_ss % dec_hist maxalgsys_ nfct_ nequ_ low_gensep high_gensep)$ global_list_ninteger := '(genint_ facint_ new_gensep target_limit_0 target_limit_1 target_limit_2 target_limit_3 target_limit_4 print_ )$ global_list_number := '(length_inc)$ switch batch_mode$ compiletime global '(groebresmax)$ symbolic operator setcrackflags$ symbolic procedure setcrackflags$ << ONE_ARGUMENT_FUNCTIONS_:='(ABS ACOS ACOSD ACOSH ACOT ACOTD ACOTH ACSC ACSCD ACSCH ASEC ASECD ASECH ASIN ASIND ASINH ATAN ATAND ATANH CBRT COS COSD COSH COT COTD COTH CSC CSCD CSCH EXP HYPOT LN LOG LOGB LOG10 SEC SECD SECH SIN SIND SINH SQRT TAN TAND TANH MINUS)$ REDUCEFUNCTIONS_:=append(ONE_ARGUMENT_FUNCTIONS_, '(ATAN2 ATAN2D FACTORIAL PLUS DIFFERENCE DF TIMES QUOTIENT EXPT INT))$ allflags_:='(to_eval to_fullint to_int to_sep to_gensep to_decoup to_diff to_under to_symbol)$ prop_list:='(val fcts vars nvars level derivs no_derivs fcteval_lin fcteval_nca fcteval_nli fct_nli_lin fct_nli_nca fct_nli_nli fct_nli_nus printlength length rational nonrational allvarfcts starde dec_with dec_with_rl rl_with % dec_info histry_ terms orderings partitioned hom_deg split_test linear_)$ % Some of the modules in the following list are still experimental. % The order in which they appear in full_proc_list_ is a proposal for % the order to appear in proc_list_. full_proc_list_:='(to_do % 1 separation % 2 subst_level_0 % 3 subst_level_03 % 4 subst_level_05 % 5 subst_level_45 % 6 quick_integration % 7 factorize_to_substitute % 8 subst_derivative % 9 quick_gen_separation % 10 alg_length_reduction % 11 drop_lin_dep % 12 find_1_term_eqn % 13 trian_lin_alg % 14 subst_level_1 % 15 subst_level_3 % 16 subst_level_5 % 17 subst_level_2 % 18 subst_level_33 % 19 subst_level_35 % 20 subst_level_4 % 21 undetlinode % 22 undetlinpde % 23 full_integration % 24 integration % 25 gen_separation % 26 diff_length_reduction % 27 del_redundant_de % 28 idty_integration % 29 decoupling % 30 add_differentiated_pdes % 31 add_diff_ise % 32 multintfac % 33 alg_solve_single % 34 alg_solve_system % 35 undo_subst_derivative % 36 change_proc_list % 37 stop_batch % 38 general_trafo % 39 del_redundant_fc % 40 sub_problem % 41 drop_dep_bi_lin % 42 find_factor_bi_lin % 43 split_into_cases % 44 subst_level_04 % 45 first_int_for_ode % 46 factorize_any % 47 gen_separation2 % 48 find_and_use_sub_systems12 % 49 find_and_use_sub_systems13 % 50 find_and_use_sub_systems14 % 51 find_and_use_sub_systems15 % 52 find_and_use_sub_systems22 % 53 find_and_use_sub_systems23 % 54 find_and_use_sub_systems24 % 55 find_and_use_sub_systems25 % 56 high_prio_decoupling % 57 user_defined % 58 alg_groebner % 59 solution_check % 60 find_trafo % 61 )$ default_proc_list_:='(to_do separation subst_level_0 subst_level_03 quick_integration factorize_to_substitute factorize_any subst_derivative subst_level_1 subst_level_3 subst_level_2 subst_level_33 subst_level_35 subst_level_4 full_integration gen_separation diff_length_reduction decoupling integration undetlinode add_diff_ise alg_solve_single undo_subst_derivative )$ proc_list_:=default_proc_list_$ % in case crident.red is not distributed: if not getd 'show_id then << full_proc_list_:=setdiff(full_proc_list_, '(del_redundant_de idty_integration)); proc_list_ :=setdiff( proc_list_, '(del_redundant_de idty_integration)) >>$ !*batch_mode:=t$ % running crack in batchmode expert_mode:=nil$ % "half automatic" when running crack in non batch mode repeat_mode:=nil$ % "repeat mode" when running crack in non batch mode if not fixp nfct_ then nfct_:=1$ % index of new functions and constants initialized nequ_:=1$ % index of new equations initialized nid_:=1$ % index of new identities initialized fname_:='c_$ % name of new functions and constants (integration) eqname_:='e_$ % name of new equations idname_:='id_$ % name of new identities level_:=nil$ % actual level of crack recursion cont_:=nil$ % interactive user control for integration or % substitution of large expressions is disabled independence_:=nil$% interactive control of linear independence disabled genint_:=15$ % if =nil then generalized integration disabled % else the maximal number of new functions and extra % equations due to generalized integration facint_:=1000$ % =nil then no search for integrating factors % otherwise max product terms*kernels for investigation potint_:=t$ % allowing `potential integration' safeint_:=t$ % uses only solutions of ODEs with non-vanishing denom. freeint_:=t$ % Do only integrations if expl. part is integrable freeabs_:=t$ % Allow only solutions of ODEs without ABS() odesolve_:=100$ % maximal length of a de (number of terms) to be % integrated as ode low_gensep:=6$ % max. size of expressions to separate in a % generalized way with higher priority high_gensep:=300$ % min. size of expressions to separate in a % generalized way with higher priority new_gensep:=nil$ % whether or not a new form of gensep should be used subst_0:=2$ % maximal length of an expression to be substituted subst_1:=8$ % subst_2:=10^3$ % subst_3:=20$ % subst_4:=10^3$ % cost_limit5:=100$ % maximal number of extra terms generated by a subst. my_gc_counter:=0$ % initialization of my_gc_counter max_gc_short:=40$ % maximal number of garbage collections during shortening max_gc_ss:=10$ % maximal number of garbage collections during % search of sub_systems max_gc_counter:=100000000$% max. number of garbage collections max_gc_red_len:=30$% maximal number of garbage collections during % length reduction max_gc_fac:=15$ % maximal number of garbage collections during factorization max_gc_elimin:=15$ % maximal number of garbage collections during % elimination in decoupling max_red_len:=1000000$ % max product of lengths of equations to be length % reduced with the decouling procedure target_limit_0:=nil$ % maximal product length(pde)*length(subst_expr) target_limit_1:=10^3$ % nil=no length limit target_limit_2:=10^4$ % target_limit_3:=10^3$ % target_limit_4:=nil$ % length_inc:=1.0$ % factor by which the length of an expression may % grow during decoupling tr_main:=nil$ % Trace main procedure tr_gensep:=nil$ % Trace generalized separation tr_genint:=nil$ % Trace generalized integration tr_decouple:=nil$ % Trace decoupling process tr_redlength:=nil$ % Trace length reduction tr_orderings:=nil$ % Trace orderings stuff tr_short:=nil$ % Trace the algebraic shortening homogen_:=nil$ % =t if all equations are homogeneous -> hom_deg is assigned solvealg_:=nil$ % Use SOLVE for algebraic equations print_more:=t$ % Print more informations about the pdes print_all:=nil$ % Print all informations about the pdes logoprint_:=t$ % print logo for crack call poly_only:=nil$ % all equations are polynomials only time_:=nil$ % print the time needed for running crack print_:=12$ % maximal length of an expression to be printed %dec_hist:=0$ % length of pde history list during decoupling maxalgsys_:=20$ % max. number of equations to be solved in specialsol adjust_fnc:=nil$ % if t then free constants/functions are scaled and % redundant ones are droped to simplify the result orderings_:=nil$ % Stores the orderings list, nil initially simple_orderings:=t$ % Turn off orderings support except for trivial case lex_df:=nil$ % if t then use lex. instead of tot. degree ordering % of derivatives lex_fc:=t$ % if t then lex. ordering of functions has higher % priority than any ordering of derivatives collect_sol:=t$ % whether solutions found shall be collected and % returned together at the end or not (to save memory) struc_eqn:=nil$ % whether the equations has the form of structural eqn. quick_decoup:=nil$ % whether decoupling should be done faster with less % care for saving memory idnties_:=nil$ % list of identities resulting from reductions and % integrability conditions if getd 'show_id then record_hist:=t else record_hist:=nil; % whether the history of equations is to be recorded keep_parti:=nil$ % whether for each equation a copy in partitioned form % is to be stored to speed up several simplifications size_watch:=nil$ % whether before each computational step the size % of the system shall be recorded in size_hist inter_divint:=nil$ % whether the integration of divergence identities % with more than 2 differentiation variables shall % be confirmed interactively do_recycle_eqn:=t$ % whether equation names shall be recycled or not % (saves memory but is less clear when determining % histry_ in terms of original equations) do_recycle_fnc:=nil$ % whether function names shall be recycled or not % (saves memory but is less clear to follow) old_history:=nil$ % old_history is interactive input to be read from % this list confirm_subst:=nil$% whether substitutions and the order of subcase % investigations has to be confirmed mem_eff:=t$ % whether to be memory efficient even if slower force_sep:=nil$ % whether direct separation should be forced even % if functions occur in the supposed to be linear % independent explicit expressions (for non-lin. prob.) flin_:=nil$ % a list of functions occuring only linearly in an % otherwise non-linear problem. This matters in a % factorization when factors with functions of flin_ % are considered last. last_steps:=nil$ % a list of the last steps to avoid cycles if null lin_test_const then lin_test_const:=gensym()$ % a global fixed constant to check linearity lin_problem:=nil$ % whether the full problem is linear or not time_limit:=nil$ % whether a time limit limit_time is set after % which batch-mode is interrupted to interactive mode limit_time:=0$ % = time()+how-much-more-time-allowed-in-batch-mode if memq ('psl, lispsystem!*) then random_init() % only if under PSL else random_new_seed(time() + 10)$ session_:=explode date()$ session_:= for each c in session_ collect (if c memq '(!: ! ) then '!- else c); session_ := compress session!_; % proposed by ACN %%session_:=reverse cons(car session_,cdr cddddr reverse session_)$ %%if cadr session_ = '! then session_:=cons(car session_,cddr session_)$ %%session_:=compress session_$ setq(session_,bldmsg("%w%d-%w","bu",random 1000,session_))$ % name of the session, used to generate filename % for backup when case splitting if print_all then <>$ random_new_seed(1)$ setq(groebresmax,2000); pvm_activate()$ % initialize pvm_able and current_dir % if getd('pvm_mytid) then <> % else <>$ !*iconic:=nil$ % whether new processes in parallelization % should appear as icons done_trafo:={'LIST}$ % a list of backtransformations of done transformations put('to_do,'description, list("Hot list of urgent steps"))$ put('subst_level_0,'description, list("Substitution", if subst_0 then " of <=",subst_0,if subst_0 then " terms", if target_limit_0 then " in <=",target_limit_0,if target_limit_0 then " terms", ", only fcts. of less vars., no cases"))$ put('subst_level_03,'description, list("Substitution", if subst_0 then " of <=",subst_0,if subst_0 then " terms", if target_limit_0 then " in <=",target_limit_0,if target_limit_0 then " terms", ", alg. expressions, no cases"))$ put('subst_level_04,'description, list("Substitution", if subst_1 then " of <=",subst_1,if subst_1 then " terms", if target_limit_1 then " in <=",target_limit_1,if target_limit_1 then " terms", ", alg. expressions, no cases"))$ put('subst_level_05,'description, list("Substitution", if subst_4 then " of <=",subst_4,if subst_4 then " terms", if target_limit_0 then " in <=",target_limit_0,if target_limit_0 then " terms", ", alg. expressions, no cases"))$ put('subst_level_1,'description, list("Substitution", if subst_1 then " of <=",subst_1,if subst_1 then " terms", if target_limit_1 then " in <=",target_limit_1,if target_limit_1 then " terms", ", fcts. of less vars."))$ put('subst_level_2,'description, list("Substitution", if subst_2 then " of <=",subst_2,if subst_2 then " terms", if target_limit_0 then " in <=",target_limit_0,if target_limit_0 then " terms", ", fcts. of less vars., no cases"))$ put('subst_level_3,'description, list("Substitution", if subst_3 then " of <=",subst_3,if subst_3 then " terms", if target_limit_3 then " in <=",target_limit_3,if target_limit_3 then " terms"))$ put('subst_level_33,'description, list("Substitution", if subst_4 then " of <=",subst_4,if subst_4 then " terms", if target_limit_4 then " in <=",target_limit_4,if target_limit_4 then " terms", " only linear expressions, f-indep. coeff."))$ put('subst_level_35,'description, list("Substitution", if subst_4 then " of <=",subst_4,if subst_4 then " terms", if target_limit_4 then " in <=",target_limit_4,if target_limit_4 then " terms", ", no cases"))$ put('subst_level_4,'description, list("Substitution", if subst_4 then " of <=",subst_4,if subst_4 then " terms", if target_limit_4 then " in <=",target_limit_4,if target_limit_4 then " terms"))$ put('subst_level_45,'description, list("Substitution", ", minimal growth", if cost_limit5 then ", with max ",cost_limit5, if cost_limit5 then " add. terms", ", no cases"))$ put('subst_level_5,'description, list("Substitution", if subst_4 then " of <=",subst_4,if subst_4 then " terms", if target_limit_4 then " in <=",target_limit_4,if target_limit_4 then " terms", ", minimal growth"))$ put('subst_derivative,'description, list("Substitution of derivatives by new functions"))$ put('undo_subst_derivative,'description, list("Undo Substitutions of derivatives by new functions"))$ put('factorize_to_substitute,'description, list("Factorization to subcases leading to substitutions"))$ put('factorize_any,'description, list("Any factorization"))$ put('separation,'description, list("Direct separation"))$ put('quick_integration,'description, list("Integration of a first order de with at", " most two terms."))$ put('full_integration,'description, list("Integration of a pde such that", " a function can be subst."))$ put('integration,'description, list("Any integration"))$ put('multintfac,'description, list("Find an integrating factor for a set of pde's"))$ put('diff_length_reduction,'description, list("Length reducing decoupling steps"))$ put('decoupling,'description, list("Do one decoupling step"))$ put('quick_gen_separation,'description, list("Indirect separation of <",low_gensep," or >", high_gensep," terms"))$ put('gen_separation,'description, list("Indirect separation of equations of any size"))$ put('gen_separation2,'description, list("Alternative indirect separation of non-lin equations"))$ put('add_differentiated_pdes,'description, list("Differentiate pdes with nonlinear leading derivs"))$ put('alg_length_reduction,'description, list("Algebraic length reduction of equations"))$ put('alg_solve_single,'description, list("Solving an algebraic equation."))$ put('alg_solve_system,'description, list("Solving equations for fnct.s or deriv.s algebraically"))$ put('stop_batch,'description, list("Stop batch mode"))$ put('undetlinode,'description, list("The parametric solution of underdetermined ODE"))$ put('undetlinpde,'description, list("The parametric solution of underdetermined PDE"))$ put('change_proc_list,'description, list("Changing the list of priorities"))$ put('drop_lin_dep,'description, list("Find and drop linear dependent general equations"))$ put('drop_dep_bi_lin,'description, list("Find and drop linear dependent bi-linear equations"))$ put('find_factor_bi_lin,'description, list("Find factorizable bi-linear equations"))$ put('find_1_term_eqn,'description, list("Find a linear dependent equation with only 1 term"))$ put('trian_lin_alg,'description, list("Triangularize a linear algebraic system"))$ put('general_trafo,'description, list("An interactive general transformation"))$ put('del_redundant_fc,'description, list("Drop redundant functions and constants"))$ put('sub_problem,'description, list("Solve a subset of equations first"))$ put('del_redundant_de,'description, list("Delete redundant equations"))$ put('idty_integration,'description, list("Integrate an identity"))$ put('add_diff_ise,'description, list("Differentiate indirectly separable equations"))$ put('split_into_cases,'description, list("Consider a given expression to be zero and non-zero"))$ put('first_int_for_ode,'description, list("Find symmetries and then first integrals for an ODE"))$ put('find_and_use_sub_systems12,'description, list("Find sub-systems with 2 non-flin_ functions"))$ put('find_and_use_sub_systems13,'description, list("Find sub-systems with 3 non-flin_ functions"))$ put('find_and_use_sub_systems14,'description, list("Find sub-systems with 4 non-flin_ functions"))$ put('find_and_use_sub_systems15,'description, list("Find sub-systems with 5 non-flin_ functions"))$ put('find_and_use_sub_systems22,'description, list("Find sub-systems with 2 flin_ functions"))$ put('find_and_use_sub_systems23,'description, list("Find sub-systems with 3 flin_ functions"))$ put('find_and_use_sub_systems24,'description, list("Find sub-systems with 4 flin_ functions"))$ put('find_and_use_sub_systems25,'description, list("Find sub-systems with 5 flin_ functions"))$ put('high_prio_decoupling,'description, list("Do one high priority decoupling step"))$ put('user_define,'description, list("Perform a user defined operation"))$ put('alg_groebner,'description, list("Computation of the algebraic Groebner basis"))$ put('solution_check,'description, list("Check whether a given solution is contained"))$ put('find_trafo,'description, list("Find a transformation to integrate a 1st order PDE"))$ ini_let_rules() >>$ algebraic procedure ini_let_rules$ begin explog_:= { cot(~x) => 1/tan(x), % e**(~x+~y) => e**x*e**y, % sqrt(e)**(~x+~y) => sqrt(e)**x*sqrt(e)**y, % e**((~x+~y)/~z) => e**(x/z)*e**(y/z), % sqrt(e)**((~x+~y)/~z) => sqrt(e)**(x/z)*sqrt(e)**(y/z), e**~x*e**~y => e**(x+y), sqrt(e)**~x*sqrt(e)**~y => sqrt(e)**(x+y), e**(~x/~z)*e**(~y/~z) => e**((x+y)/z), sqrt(e)**(~x/~z)*sqrt(e)**(~y/~z) => sqrt(e)**((x+y)/z), sqrt(e)**(log(~y)/~x) => y**(1/x/2), sqrt(e)**(-log(~y)/~x) => y**(-1/x/2), sqrt(e)**(~x*log(~y)/~z) => y**(x/z/2), sqrt(e)**(-~x*log(~y)/~z) => y**(-x/z/2), sqrt(e)**((~x*log(~y))/~z) => y**(x/z/2), e**(log(~y)/~x) => y**(1/x), e**(~x*log(~y)/~z) => y**(x/z), e**((~x*log(~y))/~z) => y**(x/z), int(df(~y,~x)/~y,~x) => log(y) } $ lisp(userrules_:={'LIST})$ % LET rules defined by the user abs_ :={abs(~x) => x}$ trig1_:={sin(~x)**2 => 1-cos(x)**2}$ % trig1_:={cos(~x)**2 => 1-sin(x)**2}$ trig2_:={cosh(~x)**2 => (sinh(x)**2 + 1)}$ trig3_:={tan(~x/2) => (1-cos(x))/sin(x)}$ trig4_:={cot(~x/2) => (1+cos(x))/sin(x)}$ trig5_:={cos(2*~x) => 1-2*sin(x)**2}$ trig6_:={sin(2*~x) => 2*cos(x)*sin(x)}$ trig7_:={sinh(2*~x) => 2*sinh(x)*cosh(x)}$ trig8_:={cosh(2*~x) => 2*cosh(x)**2-1}$ sqrt1_:={sqrt(~x*~y) => sqrt(x)*sqrt(y)}$ sqrt2_:={sqrt(~x/~y) => sqrt(x)/sqrt(y)}$ end$ % The following procedure is PSL specific and has to be COMPILED! fluid '(datebuffer); symbolic procedure random_init()$ <>$ %symbolic procedure randomhack()$ % wand(external_time datebuffer,255)$ %random_new_seed ( 100 * lisp randomhack() + 27)$ endmodule$ end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/conlaw3.red0000644000175000017500000004004611526203062023635 0ustar giovannigiovanni % CONLAW version 3, to calculate conservation laws of systems of PDEs % by calculating characteristic functions and conserved currents % by Thomas Wolf, June 1999 %---------------------------------------------------------------------- % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic fluid '(print_ logoprint_ potint_ facint_ adjust_fnc quasilin_rhs)$ %------------- algebraic procedure conlaw3(problem,runmode)$ begin scalar contrace,eqlist,ulist,xlist,dequ,cllist,pllist, sb,densord,flist,eqord,maxord,dulist,revdulist,vl,expl, deplist,e1,e2,e3,n,h1,h2,h3,h4,h5,h6,condi,soln, adjust_old,potold,adjustold,udens,gensepold,inequ0, inequ,logoold,treqlist,fl,facold,u,nodep,cpu,gc, cpustart,gcstart,found,cf0,rtnlist,solns,nontriv, extraline,cf,cfcopy,nx,nde,mindensord,mindensord0, maxdensord,absmaxord,nonconstc; backup_reduce_flags()$ lisp <>; cpustart:=lisp time()$ gcstart:=lisp gctime()$ % contrace:=t; %--- extracting input data eqlist:= reverse maklist first problem; ulist := maklist second problem; xlist:= maklist third problem; nx:=length xlist; nde:=length eqlist; if contrace then write"eqlist=",eqlist, " ulist=",ulist," xlist=",xlist; mindensord:=part(runmode,1)$ maxdensord:=part(runmode,2)$ expl :=part(runmode,3)$ flist :=part(runmode,4)$ inequ0 :=part(runmode,5)$ problem:=runmode:=0; %--- initial printout lisp(if logoprint_ then <> else terpri()); if nde = 1 then write "The DE under investigation is :" else write "The DEs under investigation are :"; for each e1 in reverse eqlist do write e1; lisp<>$ write"======================================================"$ %--- nodep is a list of derivatives the Q do not depend on nodep:=first lhsli(eqlist)$ %--- Here comes a test that lhs's are properly chosen chksub(eqlist,ulist)$ %--- Checking whether an ansatz for characteristic functions %--- has been made, then denominator of equations is not dropped for n:=1:nde do if not lisp(null get(mkid('q_,n),'avalue)) then cf0:=t; eqlist:=reverse for each e1 in eqlist collect if part(e1,0)=EQUAL then if cf0 then lhs e1 - rhs e1 else num(lhs e1 - rhs e1) else if cf0 then e1 else num e1; if contrace then write"ulist=",ulist," eqlist=",eqlist; %--- initializations to be done only once rtnlist:={}; %------ the list of parameters of the equation to be determined paralist:={}; for each e1 in flist do if not freeof(eqlist,e1) then paralist:=cons(e1,paralist); %------ determination of the order of the input equations eqord:=0; for each e1 in eqlist do for each e2 in ulist do << % h1:=totordpot(e1,e2); % if car h1>eqord then <> else % if car h1=eqord then % if cdr h1>eqlddeg then eqlddeg:=cdr h1 h1:=totdeg(e1,e2); if h1>eqord then eqord:=h1 >>; h3:=eqord; mindensord0:=mindensord$ for n:=1:nde do << h1:=mkid(q_,n); if not lisp(null get(mkid('q_,n),'avalue)) then << for each e2 in ulist do << h2:=totdeg(h1,e2); if h2>eqord then eqord:=h2; if h2>mindensord then mindensord:=h2 >>; cf0:=t; >> >>; for n:=1:nx do << % if the index of p_ should be a number then use n instead of h4 h4:=lisp(reval algebraic(part(xlist,n))); h1:=mkid(p_,h4); if not lisp(null get(mkid('p_,h4),'avalue)) then << for each e2 in ulist do << h2:=totdeg(h1,e2); if h2>eqord then eqord:=h2; if (h2>=h3) and (mindensord<=h2) then mindensord:=h2+1 >>; cf0:=t; >> >>; if maxdensord> else lisp<< write"Currently conservation laws with characteristic"; terpri(); write"function(s) of order ",densord," are determined"; terpri(); write"======================================================"$ >>; %--- repeated initializations %--- maxord is maximal order of a derivative on the right hand side %--- absmaxord is maximal order of a derivative occuring at least % temprorily in the condition (in the null divergence) % If q*delta is linear in highest derivatives then P is of one % order lower otherwise P is of same order but one degree less maxord:=if eqord>densord then eqord else densord; absmaxord:=if lisp(null quasilin_rhs) then maxord+1 else maxord; if contrace then << write"maxord=",maxord; write"absmaxord=",absmaxord; >>; if {}=fargs first ulist then for each e1 in ulist do depnd(e1,{xlist}); sb:=subdif1(xlist,ulist,absmaxord)$ nodepnd ulist; if contrace then write"sb=",sb; dulist:=ulist . reverse for each e1 in sb collect for each e2 in e1 collect rhs e2; sb:=0; revdulist:=reverse dulist; % dulist with decreasing order udens:=part(dulist,densord+1); % derivatives of order densord vl:=for each e1 in dulist join e1; if contrace then write"vl=",vl," udens=",udens; if not flist then fl:={} else fl:=flist; %--- initializing characteristic functions cf, the list of functions fl, %--- the conserved current pl and the condition condi condi:=0; deplist:=lisp(cons('LIST,setdiff(cdr ulist,cdr nodep))) . for n:=1:densord collect listdifdif2(nodep,part(dulist,n+1)); if expl then deplist:=xlist . deplist; deplist:=reverse deplist; cf:={}; for n:=1:nde do << h1:=mkid(q_,n); if lisp(null get(mkid('q_,n),'avalue)) then << nodepnd({h1}); depnd(h1, deplist); fl:=cons(h1,fl); >>; cf:=cons(h1,cf); condi:=condi+h1*part(treqlist,n); >>; cf:=reverse cf$ deplist:=for h3:=0:(absmaxord-1) collect part(dulist,h3+1); if expl then deplist:=xlist . deplist; deplist:=reverse deplist; pl:={}; for n:=1:nx do << % if the index of p_ should be a number then use n instead of h4 h4:=lisp(reval algebraic(part(xlist,n))); h1:=mkid(p_,h4); if lisp(null get(mkid('p_,h4),'avalue)) then << nodepnd({h1}); depnd(h1, deplist); fl:=h1 . fl; >>; pl:=cons(h1,pl); condi:=condi-totdif(h1,h4,n,dulist) >>; sb:=0; if contrace then write"fl=",fl," cf=",cf," pl=",pl; if contrace then lisp (write" depl*=",depl!*); if contrace then write"condi=",condi; vl:=reverse append(xlist,vl); % now the full list inequ:=inequ0; %--- inequ is to stop crack if order of cf is too low if (densord neq 0) and ((cf0=nil) or (mindensord0 neq 0)) then << % for the investigation to stop if % cf is independent of highest order derivatives dequ:=0; for each e1 in cf do << h1:=udens; while h1 neq {} do << dequ:=dequ+df(e1,first h1)*(lisp intern gensym()); h1:=rest h1 >>; >>; inequ:=cons(dequ,inequ) >>; if contrace then write"inequ=",inequ; condi:={condi}; if (not lisp(null get('cl_condi,'avalue))) and (part(cl_condi,0)=LIST) then condi:=append(condi,cl_condi)$ %--- freeing some space sb:=dulist:=revdulist:=deplist:=e1:=e2:=e3:= n:=h1:=h2:=h3:=soln:=u:=dequ:=0; %--- the real calculation if lisp(!*time) then write "time to formulate condition: ", lisp time() - cpu, " ms GC time : ", lisp gctime() - gc," ms"$ solns:=crack(condi,inequ,fl,vl); %--- postprocessing lisp terpri()$ pllist:={}; cllist:={}; found:=nil; while solns neq {} do << % for each solution (if param. are determ.) soln:=first solns; solns:=rest solns; condi:=first soln; % filtering out conservation laws found in the previous run cfcopy:=sub(second soln,cf); % any non-trivial conservation law? h1:=0; for each h2 in cfcopy do if h2 neq 0 then h1:=1; if h1 neq 0 then << pl:=sub(second soln,pl); if contrace then write"cfcopy=",cfcopy," pl=",pl; h1:=third soln; if contrace then write"third soln=",h1; fl:={}; h2:={}; for each e1 in h1 do << if not freeof(condi,e1) then fl:=cons(e1,fl); % fl to output remaining conditions later if freeof(paralist,e1) then h2:=cons(e1,h2) >>; h1:=parti_fn(h2,condi)$ if contrace then write"h1(partitioned)=",h1; extraline:=nil; nonconstc:={}; while h1 neq {} do << % for each potential conservation law % h1 is the list of lists of constants/functions % depending on each other h2:=first h1;h1:=rest h1; if contrace then write"h2=",h2; if contrace then write"cfcopy=",cfcopy; nontriv:=nil; %--- is the constant/function in the characteristic functions? h3:=for each e2 in cfcopy collect << e3:=for each e1 in h2 sum fdepterms(e2,e1); if e3 neq 0 then nontriv:=t; e3 >>; if nontriv then << for each e1 in h2 do if fargs e1 neq {} then lisp << nonconstc:=cons('LIST,cons(reval e1,cdr nonconstc)); write"The function "$ fctprint list reval e1$ write" is not constant!"; extraline:=t; terpri() >>; %--- the current h4:=reverse for each e2 in pl collect for each e1 in h2 sum fdepterms(e2,e1); if contrace then write"h3-1=",h3," h4-1=",h4; sb:=absorbconst(h3,h2)$ if (sb neq nil) and (sb neq 0) then << h3:=sub(sb,h3); h4:=sub(sb,h4) >>; if contrace then write"h3-2=",h3," h4-2=",h4; if (length(h2)=1) and (fargs first h2 = {}) then << e1:=first h2; h4:=sub(e1=1,h4); h3:=sub(e1=1,h3) >>; h5:=udens; if (densord > 0) and ((cf0=nil) or (mindensord0 neq 0)) then while (h5 neq {}) and freeof(h3,first h5) do h5:=rest h5; if h5 neq {} then << % h3 is of order densord cllist:=cons(h3,cllist); pllist:=cons(h4,pllist) >> >> >>; if condi neq {} then << write"There are remaining conditions: ", condi; lisp << write"for the functions: "; fctprint cdr reval algebraic fl;terpri(); write"Corresponding CLs might not be shown below as they"; terpri()$write"could be of too low order.";terpri()>>; extraline:=t; >>; if extraline then lisp << write"======================================================"$ terpri() >>; for each e1 in ulist do depnd(e1,{xlist}); if contrace then write"cllist2=",cllist," pllist2=",pllist$ on evallhseqp; sb:=subdif1(xlist,ulist,maxord)$ sb:=for each e1 in sb join for each e2 in e1 collect(rhs e2 = lhs e2); if contrace then write"sb=",sb$ off evallhseqp; cllist:=sub(sb,cllist); if contrace then write"cllist3=",cllist$ pllist:=sub(sb,pllist); if contrace then write"pllist3=",pllist$ % if nx=2 then % pllist:=simppl(pllist,ulist,first xlist,second xlist)$ if contrace then << write"cllist3=",cllist; write"pllist3=",pllist; write"eqlist=",eqlist; write"xlist=",xlist >>; while pllist neq {} do << found:=t; write"Conservation law:"; h2:=first pllist; h3:=first cllist; rtnlist:=cons({h3,h2},rtnlist); %--- conditions on parameters if paralist neq {} then for each e2 in second soln do if not freeof(paralist,lhs e2) then <>$ %--- the conservation laws h4:=eqlist; if paralist then h4:=sub(second soln,h4); print_claw(h4,h3,h2,xlist)$ %--- factoring out diff operators? h6:={}; for each h5 in nonconstc do if not freeof(h3,h5) then h6:=cons(h5,h6); if (h6 neq {}) and (h2 neq nondiv) then partintdf(h4,h3,h2,xlist,h6,vl,sb); write"======================================================"$ pllist:=rest pllist; cllist:=rest cllist; >>$ >>; >>; if found=nil then << write"There is no conservation law of this order."; write"======================================================"$ >> >>; % for densord:=mindensord:maxdensord if fargs(first ulist)={} then for each e1 in ulist do depnd(e1,{xlist}); if lisp(!*time) then write "time to run conlaw3: ", lisp time() - cpustart, " ms GC time : ", lisp gctime() - gcstart," ms"$ lisp <>; recover_reduce_flags()$ return rtnlist end$ % of conlaw3 end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/conlaw2.red0000644000175000017500000005704411526203062023642 0ustar giovannigiovanni % CONLAW version 2, to calculate conservation laws of systems % of PDEs by calculating characteristic functions % by Thomas Wolf, June 1999 %---------------------------------------------------------------------- % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic fluid '(print_ logoprint_ potint_ facint_ adjust_fnc)$ %------------- symbolic procedure newil(il,mo,nx)$ if (null il) or (length il>$ %------------- symbolic procedure sortli(l)$ % sort a list of numbers begin scalar l1,l2,l3,m,n$ return if null l then nil else << n:=car l$ l2:=list car l$ l:=cdr l$ while l do << m:=car l$ if m>n then l1:=cons(car l,l1) else if m>$ append(sortli(l1),append(l2,sortli(l3))) >> end$ %------------- %symbolic operator combi$ symbolic procedure combi(ilist)$ % ilist is a list of indexes (of variables of a partial derivative) % and returns length!/k1!/k2!../ki! where kj! is the multiplicity of j. begin integer n0,n1,n2,n3; n1:=1; % ilist:=cdr ilist; while ilist do <> else <>; ilist:=cdr ilist>>; return n1 end$ %------------- symbolic procedure derili(il)$ % make a derivative index list from a list of numbers if null il then nil else begin scalar h1,h2,h3$ h1:=sortli(il); while h1 do << h2:=reval algebraic mkid(!`,lisp car h1); h3:=if h3 then mkid(h2,h3) else h2; h1:=cdr h1 >>; return h3 end$ %------------- algebraic procedure conlaw2(problem,runmode)$ begin scalar contrace,eqlist,ulist,xlist,dequ,cllist,divlist, sb,densord,flist,eqord,maxord,dulist,revdulist,vl,expl, deplist,e1,e2,e3,n,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11, condi,soln,potold,adjustold,udens,gensepold, inequ0,inequ,logoold,treqlist,fl,facold,u,nodep,subl,cpu, gc,cpustart,gcstart,nontriv,cf0,rtnlist,paralist,solns, found,clcopy,extraline,nondiv,nx,nde,nonconstc, mindensord,mindensord0,maxdensord,rules$ backup_reduce_flags()$ lisp <>; cpustart:=lisp time()$ gcstart:=lisp gctime()$ %contrace:=t; %--- extracting input data eqlist:= reverse maklist first problem; ulist := maklist second problem; xlist := maklist third problem; nx:=length xlist; nde:=length eqlist; if contrace then write"eqlist=",eqlist, " ulist=",ulist," xlist=",xlist; mindensord:=part(runmode,1)$ maxdensord:=part(runmode,2)$ expl :=part(runmode,3)$ flist :=part(runmode,4)$ inequ0 :=part(runmode,5)$ problem:=runmode:=0; %--- initial printout lisp(if logoprint_ then <> else terpri()); if nde = 1 then write "The DE under investigation is :" else write "The DEs under investigation are :"; for each e1 in reverse eqlist do write e1; lisp<>$ write"======================================================"$ %--- nodep is a list of derivatives the P do not depend on %--- subl is the list of lhs-derivatives to be substituted h1:=lhsli(eqlist)$ nodep:=first h1$ subl:=second h1$ %--- Here comes a test that lhs's are properly chosen chksub(eqlist,ulist)$ %--- Checking whether an ansatz for characteristic functions %--- has been made, then denominator of equations is not dropped for n:=1:nde do if not lisp(null get(mkid('q_,n),'avalue)) then cf0:=t; eqlist:=reverse for each e1 in eqlist collect if part(e1,0)=EQUAL then if cf0 then lhs e1 - rhs e1 else num(lhs e1 - rhs e1) else if cf0 then e1 else num e1; if contrace then write"ulist=",ulist," eqlist=",eqlist; %--- initializations to be done only once rtnlist:={}; nondiv:=lisp intern gensym(); % as a marker if p-computation was not succ. %------ the list of parameters of the equation to be determined paralist:={}; for each e1 in flist do if not freeof(eqlist,e1) then paralist:=cons(e1,paralist); %------ determination of the order of the input equations eqord:=0; mindensord0:=mindensord; for each e1 in eqlist do for each e2 in ulist do << h1:=totdeg(e1,e2); if h1>eqord then eqord:=h1 >>; for n:=1:nde do << h1:=mkid(q_,n); if not lisp(null get(mkid('q_,n),'avalue)) then << for each e2 in ulist do << h2:=totdeg(h1,e2); if h2>eqord then eqord:=h2; if h2>mindensord then mindensord:=h2 >>; cf0:=t; >> >>; if contrace then write"eqord=",eqord; if maxdensord> else lisp<< write"Currently conservation laws with characteristic"; terpri(); write"function(s) of order ",densord," are determined"; terpri(); write"======================================================"$ >>; %--- repeated initializations %--- maxord is maximal derivative in condition maxord:=eqord % from the total derivatives + 1 % for safety + if eqord>densord then eqord else densord$ %######## possibly to be increased due to substitutions if contrace then write"maxord=",maxord; if {}=fargs first ulist then for each e1 in ulist do depnd(e1,{xlist}); sb:=subdif1(xlist,ulist,maxord)$ nodepnd ulist; if contrace then write"sb=",sb; dulist:=ulist . reverse for each e1 in sb collect for each e2 in e1 collect rhs e2; sb:=0; revdulist:=reverse dulist; % dulist with decreasing order udens:=part(dulist,densord+1); % derivatives of order densord vl:=for each e1 in dulist join e1; if contrace then write"vl=",vl," udens=",udens; if not flist then fl:={} else fl:=flist; %--- initializing characteristic functions cf, the list of functions fl deplist:=lisp(cons('LIST,setdiff(cdr ulist,cdr nodep))) . for n:=1:densord collect listdifdif2(nodep,part(dulist,n+1)); if expl then deplist:=xlist . deplist; deplist:=reverse deplist; cf:={}; for n:=1:nde do << h1:=mkid(q_,n); if lisp(null get(mkid('q_,n),'avalue)) then << nodepnd({h1}); depnd(h1, deplist); fl:=cons(h1,fl); >>; cf:=cons(h1,cf); >>; cf:=reverse cf; if contrace then write"fl=",fl; if contrace then lisp (write" depl*=",depl!*); %--- generation of the conditions condi:={}; for each u in ulist do << if contrace then write"function=",u; h1:=treqlist; h2:=cf; h3:=0; while h1 neq {} do << % sum over all equations if contrace then write"equation :",first h1; for each e1 in vl do % sum over u and all its derivatives if lisp(reval algebraic(u) = car combidif algebraic(e1)) then << % for u and all its derivatives e2:=df(first h1, e1); if e2 neq 0 then << if contrace then write"e1=",e1; dequ:=first h2 * e2; e2:=1; for each e3 in lisp cons('LIST,cdr combidif(algebraic e1)) do <> >>; dequ:=0; % to compute rhs h2:=treqlist; % " if paralist then h2:=sub(second soln,h2); % " if contrace then write"h2=",h2; % " nontriv:=nil; h3:=for each e2 in cfcopy collect << e3:=for each h4 in e1 sum fdepterms(e2,h4); dequ:=dequ+e3*first h2; h2:=rest h2; % computes rhs if e3 neq 0 then nontriv:=t; e3 >>; if nontriv then << found:=t; cllist:=cons(<>$ if condi neq {} then << write"There are remaining conditions: ", condi; lisp << write"for the functions: "; fctprint cdr reval algebraic fl;terpri(); write"Corresponding CLs might not be shown below as they"; terpri()$write"could be of too low order.";terpri()>>; extraline:=t; >>; if extraline then lisp << write"======================================================"$ terpri() >>; %--- Dropping conservation laws of too low order if (densord > 0) and ((cf0=nil) or (mindensord0 neq 0)) then << h1:={}; h2:={}; for each e1 in cllist do << h5:=udens; while (h5 neq {}) and freeof(e1,first h5) do h5:=rest h5; if h5 neq {} then << h1:=cons(e1,h1); h2:=cons(first divlist,h2) >>; divlist:=rest divlist; >>; cllist:=h1; divlist:=h2 >>; if contrace then write"cllist=",cllist; if cllist neq {} then << %--- Below h1 is the list of W^i in the Anco/Bluman formula h1:=for e1:=1:(length cllist) collect intcurrent1(part(divlist,e1),ulist,xlist,dulist,nx, eqord,densord); %--- Backsubstitution of e.g. u`1`1 --> df(u,x,2) for each e1 in ulist do depnd(e1,{xlist}); on evallhseqp; sb:=subdif1(xlist,ulist,maxord)$ sb:=for each e1 in sb join for each e2 in e1 collect(rhs e2 = lhs e2); off evallhseqp; cllist:=sub(sb,cllist); h1:=sub(sb,h1); if not lisp(freeof(h1,'SUB)) then h1:={} else << %--- lambda integration of h1 to compute P_i h2:=lisp intern gensym()$ h10:=ulist; while h10 neq {} do if not lisp(freeof(h1,'SUB)) then h10:={} else << e1:=first h10; h10:=rest h10; h1:=sub(e1=h2*e1,h1) >>; if not lisp(freeof(h1,'SUB)) then h1:={} else h1:=for each e1 in h1 collect << % i.e. for each cl h10:=sub(sb,first divlist); divlist:=rest divlist; % at first try direct integration to compute p h9:=intcurrent2(h10,append(nonconstc,ulist),xlist); if second h9 = 0 then h9:=first h9 else << % no success --> use lambda-integration h9:=nondiv; h8:=t; % whether intcurrent1 is still ok %--- at first the term h10 = T^i/x^i in conca.tex for each e2 in ulist do << if h8 then h10:=err_catch_sub(e2,0,h10); if h10 eq nil then h8:=nil >>$ if contrace then write"h10-1=",h10$ if h8 and (h10 neq 0) then << for each e2 in xlist do << if h8 then h10:=err_catch_sub(e2,h2*e2,h10); if h10 eq nil then h8:=nil >>$ if h8 then << if contrace then write"h10-2=",h10$ %--- the following is to catch errors in: %--- int(h10*h2**(nx-1),h2) h10:=if not lisp freeof(h10,'SUB) then nil else err_catch_int(h10*h2**(nx-1),h2)$ if contrace then write"h10-3=",h10$ %--- the following is to catch errors in: %--- sub(h2=1,h10)-sub(h2=0,h10) h6:=err_catch_sub(h2,1,h10); if contrace then write"h6=",h6$ if h6 eq nil then h7:=nil else h7:=err_catch_sub(h2,0,h10); if contrace then write"h7=",h7$ if h7 eq nil then h8:=nil else h10:=h6-h7 >> >>$ if contrace then write"h10-4=",h10$ h4:={}; % h4 becomes the inverse list of P^i h11:=0; while h8 and (e1 neq {}) do << h11:=h11+1; e2:=first e1; e1:=rest e1; if contrace then write"e2=",e2$ h3:=err_catch_int(e2/h2,h2)$ if contrace then write"h3-1=",h3$ %--- the following is to catch errors in: %--- sub(h2=1,h3)-sub(h2=0,h3) h6:=err_catch_sub(h2,1,h3); if h6 eq nil then h7:=nil else h7:=err_catch_sub(h2,0,h3); if h7 eq nil then h8:=nil else h4:=cons(h6-h7+h10*part(xlist,h11),h4) >>; if h8 then h9:=reverse h4 >>; h9 >> >>; if contrace then write"h1-1=",h1$ if h1={} then << lisp << write"The conserved quantities could not be found."$ terpri() >>$ if condi neq {} then lisp << write"For that the remaining conditions should be solved."; terpri() >>; lisp << write"The adjoined symmetries are:"$terpri() >>$ for each e1 in cllist do write e1$ >>$ if contrace then << write"h1=",h1;write"cllist=",cllist;write"eqlist=",eqlist >>; while h1 neq {} do << h2:=first h1; h3:=first cllist; rtnlist:=cons({h3,h2},rtnlist); %--- conditions on parameters if paralist neq {} then for each e2 in second soln do if not freeof(paralist,lhs e2) then <>$ %--- the conservation laws %--- Test whether actually only an adjoint symmetry has been %--- computed and not a conservation law h4:=eqlist; if paralist neq {} then h4:=sub(second soln,h4); h8:=0; if h2 neq nondiv then << h5:=h4; for each e1 in h3 do << h8:=h8 + e1*(first h5)$ h5:=rest h5 >>$ for e1:=1:nx do << h8:=h8-df(part(h2,e1),part(xlist,e1))$ % for test purposes >>; if h8 neq 0 then h2:=nondiv >>; if h2 neq nondiv then << if nx=2 then h2:=first simppl({h2},ulist,first xlist,second xlist)$ write"Conservation law:"; print_claw(h4,h3,h2,xlist); %--- factoring out diff operators? h6:={}; for each h5 in nonconstc do if not freeof(h3,h5) then h6:=cons(h5,h6); if h6 neq {} then partintdf(h4,h3,h2,xlist,h6,vl,sb) >> else << write"Adjoint symmetry:"; while h3 neq {} do << if length h3 < length first cllist then write "+"$ write"(",first h3,") * (",first h4,")"$ h3:=rest h3; h4:=rest h4 >>$ lisp << write"could not be written as a divergence but solves the"$ terpri()$ write"adjoint symmetry condition and therefore represents"$ terpri()$ write"an adjoint symmetry."$ terpri()$ >>$ if (h8 neq 0) and (condi neq {}) then << write"Please check: if the remaining conditions guarantee "$ write" 0 = ",h8$ write"then the found characteristic function represents ", "a conservation law"$ >>$ >>; h1:=rest h1; cllist:=rest cllist; write"======================================================"$ >>$ >>; % if cllist neq {} then << nodepnd(ulist); >>; % while solns neq {} do << if found=nil then << write"There is no conservation law of this order."; write"======================================================"$ >> >>; % for densord:=mindensord:maxdensord if fargs first ulist = {} then for each e1 in ulist do depnd(e1,{xlist}); if lisp(!*time) then write "time to run conlaw2: ", lisp time() - cpustart, " ms GC time : ", lisp gctime() - gcstart," ms"$ lisp <>; recover_reduce_flags()$ return rtnlist end$ % of conlaw2 end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crstart.red0000644000175000017500000000265111526203062023751 0ustar giovannigiovanni% startup code for CRACK. % Has to be executed as last module in the CRACK modules list. % Winfried Neun, Jan 27, 2006 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % lisp setcrackflags()$ end; mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crident.red0000644000175000017500000004750711526203062023730 0ustar giovannigiovanni%******************************************************************** module identities$ %******************************************************************** % Routines for dealing with differential identities % Author: Thomas Wolf % May 1999 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic procedure drop_idty(id)$ % recycles a name of an identity <>$ symbolic procedure new_id_name$ % provides a name for a new identity begin scalar id$ if null recycle_ids then << id:=mkid(idname_,nid_)$ nid_:=add1 nid_$ >> else << id:=car recycle_ids$ recycle_ids:=cdr recycle_ids >>$ setprop(id,nil)$ return id end$ symbolic procedure replace_idty$ begin scalar p,ps,ex$ ps:=promptstring!*$ promptstring!*:=""$ terpri()$ write "If you want to replace an identity then ", "type its name, e.g. id_2 ."$ terpri()$ write "If you want to add an identity then type `new_idty' . "$ p:=termread()$ if (p='NEW_IDTY) or member(p,idnties_) then <> >> end$ symbolic procedure show_id$ begin scalar l,n$ terpri()$ l:=length idnties_$ write if l=0 then "No" else l, if l=1 then " identity." else " identities"$ if l=0 then terpri() else << n:=1; for each l in reverse idnties_ do << terpri()$ algebraic write n,") ",l," : 0 = ",lisp(get(l,'val)); n:=add1 n; if print_all then << terpri()$write " to_int : ",flagp(l,'to_int)$ terpri()$write " to_subst : ",flap(l,'to_subst)$ >> >> >> end$ symbolic procedure del_red_id(pdes)$ begin scalar oldli,pl,s,idty,news,succ,p,l$ % ,r,newr$ if idnties_ then << oldli:=idnties_$ while oldli do if not flagp(car oldli,'to_subst) then oldli:=cdr oldli else << idty:=get(car oldli,'val)$ pl:=smemberl(pdes,idty)$ for each p in pl do l:=union(get(p,'vars),l)$ if l then l:=length l else l:=0$ pl:=setdiff(pl,search_li(idty,'DF)); % now all pdes in pl are redundand, drop the longest if null pl then remflag1(car oldli,'to_subst) else << drop_idty(car oldli); % find the longest equation s of those with the most variables s:=nil; while pl do << if (null get(car pl,'starde) ) and (get(car pl,'nvars)=l ) and (null(% flagp(s,'to_int) or % flagp(s,'to_fullint) or % flagp(s,'to_sep) or % flagp(s,'to_gensep) or % flagp(s,'to_decoup) or flagp(s,'to_eval)) ) and ((null s ) or (get(car pl,'nvars)>get(s,'nvars) ) or ((get(car pl,'nvars)=get(s,'nvars)) and (get(car pl,'terms)>get(s,'terms)) ) ) then s:=car pl; pl:=cdr pl >>; if null s then remflag1(car oldli,'to_subst) else << if print_ then << write "Equation ",s," is dropped as it is a consequence of others: "$ algebraic write "0 = ",lisp(idty)$ >>$ % assuming s occurs linearly: pl:=coeffn(idty,s,1)$ news:=reval {'QUOTIENT,{'DIFFERENCE,{'TIMES,pl,s},idty},pl}; %for each r in idnties_ do %if not freeof(get(r,'val),s) then << % newr:=reval subst(news,s,get(r,'val)); % newr:=simplifypde(newr,pdes,t,nil)$ % put(r,'val,newr)$ % flag1(r,'to_subst)$ % flag1(r,'to_int)$ %>>$ succ:=t$ pdes:=drop_pde(s,pdes,news)$ oldli:=cdr oldli >> >> >> >>; if succ then return pdes end$ symbolic procedure del_redundant_de(argset)$ begin scalar pdes; if pdes:=del_red_id(car argset) then return {pdes,cadr argset}$ end$ symbolic procedure write_id_to_file(pdes)$ begin scalar s,p,h,pl,ps$ if idnties_ then << ps:=promptstring!*$ promptstring!*:=""$ write"Please give the name of the file in double quotes"$terpri()$ write"without `;' : "$ s:=termread()$ out s; off nat$ write"load crack$"$terpri()$ write"lisp(nequ_:=",nequ_,")$"$terpri()$ write"off batch_mode$"$terpri()$ write"list_of_variables:="$ algebraic write lisp cons('LIST,vl_)$ write"list_of_functions:="$ algebraic write lisp cons('LIST,pdes)$ for each h in pdes do if pl:=assoc(h,depl!*) then for each p in cdr pl do algebraic write "depend ",lisp h,",",lisp p$ write"list_of_equations:="$ algebraic write lisp( cons('LIST,for each h in idnties_ collect get(h,'val))); terpri()$ write"solution_:=crack(list_of_equations,{},"$ terpri()$ write" list_of_functions,"$ terpri()$ write" list_of_variables)$"$ terpri()$ terpri()$ write"end$"$terpri()$ shut s; on nat; promptstring!*:=ps$ >> end$ symbolic procedure remove_idl$ <>$ symbolic procedure start_history(pdes)$ begin scalar l,ps$ ps:=promptstring!*$ promptstring!*:=""$ write"For recording the history of equations all currently"$ terpri()$ write"recorded histories would be deleted as well as all"$ terpri()$ write"present decoupling information, i.e. `dec_with'"$ terpri()$ write"would be set to nil. Please confirm (y/n). "$ l:=termread()$ if (l='y) or (l='Y) then << record_hist:=t; for each l in pdes do put(l,'histry_,l)$ for each l in pdes do put(l,'dec_with,nil)$ >>; promptstring!*:=ps$ end$ symbolic procedure stop_history(pdes)$ <>$ % write"Do you want to delete all dec_with information? (y/n) "$ % l:=termread()$ % if (l='y) or (l='Y) then % for each l in pdes do put(l,'dec_with,nil)$ symbolic procedure idty_integration(argset)$ begin scalar l,pdes,idcp; pdes:=car argset; idcp:=idnties_; while idcp do if not flagp(car idcp,'to_int) then idcp:=cdr idcp else if l:=integrate_idty(car idcp,pdes,%cadr argset, ftem_,vl_) then << pdes:=l;idcp:=nil>> else << remflag1(car idcp,'to_int); idcp:=cdr idcp; >>; if l then return {pdes,cadr argset} end$ symbolic procedure integrate_idty(org_idty,allpdes,%forg, fl,vl)$ % idty is a differential identity between equations % allpdes, fl, vl are lisp lists of equation names, functions and variables % ways to optimize: use conlaw instead of the initial intcurrent2 % use more general methods to take advantage of % non-conservation laws if idnties_ then begin scalar cl,ncl,vlcp,xlist,eql,a,f,newpdes,ftem_bak, nx,dl,l,k,ps,idty,pdes,extrapdes,newidtylist$ %nclu if null org_idty then if null cdr idnties_ then org_idty:=car idnties_ else << show_id()$ ps:=promptstring!*$ promptstring!*:=""$ write"Which of the identities shall be integrated? (no) "$ k:=length(idnties_); repeat l:=termread() until (fixp l) and (0>$ idty:=reval num reval get(org_idty,'val)$ if trivial_idty(allpdes,idty) then return nil$ pdes:=smemberl(allpdes,idty)$ a:=all_deriv_search(idty,pdes)$ xlist:=smemberl(vl,a)$ cl:=intcurrent3(idty,cons('LIST,pdes),cons('LIST,xlist))$ % intcurrent3 is only successful if only 2 derivatives found if (not zerop caddr cl) and inter_divint then cl:=intcurrent2(idty,cons('LIST,pdes),cons('LIST,xlist))$ if zerop caddr cl then << cl:=cdadr cl; vlcp:=xlist; xlist:=nil; while vlcp do << if not zerop car cl then << ncl:=cons(car cl,ncl); xlist:=cons(car vlcp,xlist) >>; cl:=cdr cl; vlcp:=cdr vlcp >>; % ncl:=reverse ncl; % xlist:=reverse xlist; cl:=ncl; % % Now try to get a divergence in less differentiation variables. % % Each component of the divergence is tried to be written as % % a divergence in the other (right) variables % while ncl do << % a:=intcurrent2(car ncl,cons('LIST,pdes),cons('LIST,cdr xlist))$ % if not zerop caddr a then << % cl:=cons(car ncl,cl); ncl:=cdr ncl; % vlcp:=cons(car xlist,vlcp); xlist:=cdr xlist % >> else << % % It was possible to integrate car ncl to div(cdadr a,cdr xlist). % % distribute {'DF,car a,car xlist} to the divergence of cdr ncl % ncl:=cdr ncl; % a:=cdadr a; % nclu:=nil; % while ncl do << % nclu:=cons(reval {'PLUS,car ncl,{'DF,car a,car xlist}}, nclu); % ncl:=cdr ncl; % a:=cdr a % >>; % ncl:=reverse nclu; % xlist:=cdr xlist % >> % >>$ % ncl:=cl; % xlist:=vlcp; nx:=length xlist; while pdes do << ncl:=subst(get(car pdes,'val),car pdes,ncl); pdes:=cdr pdes >>$ ftem_bak:=ftem_; eql:=int_curl(reval cons('LIST,ncl), cons('LIST,fl), cons('LIST,xlist),cons('LIST,varslist(ncl,ftem_,vl)) )$ % eql has the form {'LIST,reval cons('LIST,resu),cons('LIST,neweq)} if (null eql) or (null cdadr eql) or (zerop cadadr eql) then return nil; eql:=cdr eql; if print_ then << ncl:=for i:=1:nx collect {'DF,nth(cl,i),nth(xlist,i)}; ncl:=if cdr ncl then cons('PLUS,ncl) else car ncl; terpri()$ write"The identity "$ % mathprint idty$ mathprint reval ncl; write"can be integrated to "$terpri()$ deprint(cdar eql)$ >>$ if nx < 3 then a:='y else if (null inter_divint) or !*batch_mode then << a:='n; if print_ then << write"The integrated divergence is not used because it ", "has more than 2 terms and"$ terpri()$ if !*batch_mode then write"`inter_divint' is nil." else write"batch_mode is on."$ >>$ terpri() >> else << ps:=promptstring!*$ promptstring!*:=""$ write"Shall this integration be used? (y/n) "$ repeat a:=termread() until (a='y) or (a='n); promptstring!*:=ps >>; if a='n then << a:=setdiff(ftem_,ftem_bak); for each f in a do drop_fct(f)$ ftem_:=ftem_bak >> else << % the extra conditions from the generalized integration: extrapdes:=cdadr eql$ eql:=cdar eql; % eql are now the integrated curl conditions drop_idty(org_idty)$ while eql do << if not zerop car eql then << a:=mkeq(car eql,ftem_,vl,allflags_,nil,list(0),nil,allpdes); newpdes:=cons(a,newpdes); >>; eql:=cdr eql; >>; newpdes:=reverse newpdes; % formulate the new identities for i:=1:nx do << idty:=nth(cl,i); if nx=1 then a:=car newpdes else << % at first sum over df(q^{ji},j), j>; a:=if null a then 0 else if cdr a then cons('PLUS,a) else car a; idty:={'PLUS,idty,a}; % then sum over -df(q^{ij},j), j>i if i=1 then l:=1 else l:=k+nx-i+1; a:=for j:=(i+1):nx collect << k:=l; l:=l+1; {'DF,nth(newpdes,k),nth(xlist,j)} >>; a:=if null a then 0 else if cdr a then cons('PLUS,a) else car a; >>$ newidtylist:=cons({'DIFFERENCE,idty,a},newidtylist); >>; eql:=nil; for each a in extrapdes do << a:=mkeq(a,ftem_,vl,allflags_,t,list(0),nil,allpdes); allpdes:=eqinsert(a,allpdes); to_do_list:=cons(list('subst_level_35,%allpdes,forg,vl_, list a), to_do_list); eql:=cons(a,eql) >>; if print_ then << write"Integration gives: "$ listprint(newpdes)$terpri()$ if eql then << write"with extra conditions: "$ listprint(eql) >>$ >>; for each a in newpdes do allpdes:=eqinsert(a,allpdes)$ % now that allpdes is updated: for each a in newidtylist do new_idty(a,allpdes,t)$ return allpdes >> >> end$ symbolic procedure sortpermuli(a)$ % a is a list of numbers to be sorted and the exchanges of neighbours % are to be counted begin scalar flp,conti,newa; repeat << newa:=nil; conti:=nil; while cdr a do if car a < cadr a then <> else << conti:=t; flp:=not flp; newa:=cons(cadr a,newa); a:=cons(car a,cddr a); >>$ newa:=cons(car a,newa); a:=reverse newa >> until null conti; return flp . a end$ symbolic procedure curlconst(xlist,vl)$ % generates a list q^ij=r^ijk,_k with r^ijk totally antisymmetric % in the order q^(n-1)n,... % xlist is the list of xi,xj,xk % vl is the list of all variables new functions should depend on begin scalar n,qli,i,j,k,qij,a,flp,f,resu,qlicp$ n:=length xlist$ for i:=1:(n-1) do for j:=(i+1):n do << % generation of r^ijk,k qij:=nil; for k:=1:n do if (k neq i) and (k neq j) then << a:=sortpermuli({i,j,k}); flp:=car a; a:=cdr a; qlicp:=qli; while qlicp and (caar qlicp neq a) do qlicp:=cdr qlicp; if qlicp then f:=cdar qlicp else << f:=newfct(fname_,vl,nfct_); nfct_:=add1 nfct_; ftem_:=fctinsert(f,ftem_); qli:=cons(a . f,qli) >>; f:={'DF,f,nth(xlist,k)}; if flp then f:={'MINUS,f}; qij:=cons(f,qij) >>$ if null qij then <> else if cdr qij then qij:=reval cons('PLUS,qij) else qij:=car qij; resu:=cons(qij,resu) >>$ return resu end$ symbolic procedure updt_curl(h2,rmdr,fl,done_xlist,x,cdrxlist,n,k)$ % a subroutine of int_curl begin scalar i,h4,h5,h6,h7,rmdr,y,pint,succ$ if (not zerop reval reval {'DF,rmdr,x}) then << if print_ then <>$ succ:=nil >> else << succ:=t; if done_xlist then << % there is one computed curl component to be updated % integration wrt done_xlist h7:=intcurrent2(rmdr,fl,cons('LIST,done_xlist)); rmdr:=caddr h7; h7:=cdadr h7; % update the already computed h2-components with the new h7-comp. h4:=nil; h5:=-1; for i:=1:(k-1) do << h5:=add1 h5; for h6:=1:(n-k) do <>; h4:=cons({'DIFFERENCE,car h2,car h7},h4); h2:=cdr h2; h7:=cdr h7; for h6:=1:h5 do <> >>; h2:=reverse h4; >>$ % now generalized integration of the remainder if zerop rmdr then pint:=cons(0,nil) else << y:=if cdrxlist then car cdrxlist else car done_xlist; fnew_:=nil$ pint:=partint(rmdr,fl,vl_,y,genint_); % genint is max number of new terms if null pint then succ:=nil else for each h4 in fnew_ do ftem_:=fctinsert(h4,ftem_) >> >>; return if null succ then nil else cons(h2,pint) % pint=cons(generalized integral of rmdr,list of new eqn) end$ symbolic procedure int_curl(pli,fl,xlist,vl)$ % given a vector p^i satisfying p^i,_i=0, find q^{ij}=-q^{ji} % such that p^i=q^{ij},j % car result: (q^{12}, q^{13},.., q^{1n}, q^{23},.., q^{2n},.., q^{(n-1)n}) % each q^{ij} comes with r^{ijk},k % cdr result: list of new conditions in fewer variables % works only if identically satisfied, not modulo some equations % vl is the list of all relevant variables % during computation is h2 = % (q^{kn},.., q^{k(k+1)},q^{(k-1)n},.., q^{(k-1)k},.., % q^{2n},.., q^{23}, q^{1n},.., q^{13},q^{12}} ) begin scalar h1,h2,h3,resu,newpli,xcp,done_xlist,n,k,ok,neweq,ftem_bak$ % conversion from algebraic mode lists to lisp lists: pli:=cdr pli$ xlist:=cdr xlist$ vl:=cdr vl; xcp:=xlist$ n:=length(xlist); k:=0; ok:=t; ftem_bak:=ftem_; if n=1 then return {'LIST,reval cons('LIST,pli),{'LIST}}$ while cdr pli and ok do << k:=add1 k; % the integration has to be done first wrt cdr xlist. The resulting % curl will be used to change the remining pli to be integrated h3:=intcurrent2(reval car pli,fl,cons('LIST,cdr xlist)); pli:=cdr pli; h1:=cdadr h3; h3:=reval reval caddr h3; % h3 now = the remainder of the integration wrt cdr xlist if not zerop h3 then << % here the integration wrt the done_xlist. These curl updates will % not be used to update pli, because df(h3,car xlist)=0 is assumed h3:=updt_curl(h2,h3,fl,done_xlist,car xlist,cdr xlist,n,k)$ if null h3 then ok:=nil else << % generalized integration of the remainder neweq:=append(cddr h3,neweq); h2:=car h3; h1:=cons({'PLUS,car h1,cadr h3},cdr h1); % because of cdr xlist neq nil here q^{k(k+1)} is updated >> >>$ if ok then << % In the first round h2 is naturally nil --> use ok for test % append (q^{kn},.., q^{k(k+1)}) and h2 h2:=append(reverse h1,h2); % update the remaining pli to be integrated newpli:=nil; while h1 do << newpli:=cons({'PLUS,{'DF,car h1,car xlist},car pli},newpli); h1:=cdr h1; pli:=cdr pli >>; pli:=reverse newpli >>; done_xlist:=cons(car xlist,done_xlist); xlist:=cdr xlist >>$ if ok then << pli:=reval car pli; % to get the remainder of the last component of pli integrated if pli neq 0 then << k:=k+1; h3:=updt_curl(h2,pli,fl,done_xlist,car xlist,nil,n,k)$ if null h3 then ok:=nil else << neweq:=append(cddr h3,neweq); h2:=car h3; h2:=cons({'DIFFERENCE,car h2,cadr h3},cdr h2) % because of null xlist here car h2=q^{n-1,n} is updated >>$ >> >>; if null ok then << % drop all new functions h1:=setdiff(ftem_,ftem_bak); for each h2 in h1 do drop_fct(h2)$ ftem_:=ftem_bak >> else << h1:=curlconst(xcp,vl)$ while h1 do << resu:=cons({'PLUS,car h2,car h1},resu); h1:=cdr h1; h2:=cdr h2; >>$ return {'LIST,reval cons('LIST,resu),cons('LIST,neweq)} >> end$ endmodule$ end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/conlaw0.red0000644000175000017500000007107311526203062023636 0ustar giovannigiovanni % CONLAW file with subroutines for CONLAW1/2/3/4 % by Thomas Wolf, September 1997 %---------------------------------------------------------------------- % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic fluid '(reducefunctions_ print_)$ algebraic procedure print_claw(eqlist,qlist,plist,xlist)$ begin scalar n$ n:=length eqlist$ while qlist neq {} do << if length qlist < n then write "+"$ write"( ",first qlist," ) * ( ",first eqlist," )"$ qlist:=rest qlist; eqlist:=rest eqlist >>$ write" = "$ n:=length xlist$ while plist neq {} do << if length plist < n then write "+"$ write"df( ",first plist,", ",first xlist," )"$ plist:=rest plist; xlist:=rest xlist >> end$ symbolic operator lhsli$ symbolic procedure lhsli(eqlist)$ % lhslist1 will be a list of all those lhs's which are a derivative or % a power of a derivative which is used to fix dependencies % of q_i or p_j % lhslist2 will be a list of all lhs's of all equations in their % order with those lhs's set to 0 which can not be used % for substitutions begin scalar lhslist1,lhslist2,h1,flg1,flg2$ for each h1 in cdr eqlist do << flg1:=nil$ % no assignment to lhslist1 done yet if (pairp h1) and (car h1 = 'EQUAL) then << h1:=reval cadr h1; if (pairp h1) and (car h1='EXPT) and (numberp caddr h1) then <> else flg2:=t; if (not numberp h1) and ((atom h1) or ((car h1='DF) and (atom cadr h1) )) then <> >> >>; if null flg1 then lhslist2:=cons(0,lhslist2); >>$ return list('LIST,cons('LIST,lhslist1),cons('LIST,lhslist2)) end$ symbolic operator chksub$ symbolic procedure chksub(eqlist,ulist)$ % eqlist is a list of equations df(f,x,2,y) = ... % this procedure tests whether % - for any equation a derivative on the rhs is equal or a derivative of % the lhs? % - any lhs is equal or the derivative of any other lhs begin scalar h1,h2,derili,complaint$ derili:=for each e1 in cdr eqlist collect cons( all_deriv_search(cadr e1,cdr ulist), % lhs all_deriv_search(caddr e1,cdr ulist) ); % rhs %--- Is for any equation a derivative on the rhs equal or a derivative of %--- the lhs? for each e1 in derili do if car e1 then << h1:=caaar e1; % e.g. h1 = (f x 2 y) for each h2 in cdr e1 do if (car h1 = caar h2) and null which_deriv(cdar h2,cdr h1) then << complaint:=t; write "The left hand side ", if length h1 = 1 then car h1 else cons('DF,h1)$terpri()$ write " is not a leading derivative in its equation!"$ terpri() >> >>$ %--- Is any lhs equal or the derivative of any other lhs? if derili then while cdr derili do << if caar derili then << h1:=caaaar derili$ for each h2 in cdr derili do if (car h2) and (car h1=caaaar h2) and ((null which_deriv(cdr h1,cdaaar h2)) or (null which_deriv(cdaaar h2,cdr h1)) ) then << complaint:=t; write"--> One left hand side (lhs) contains a derivative which"$ terpri()$ write"is equal or a derivative of a derivative on another lhs!"$ terpri()$ >>$ >>$ derili:=cdr derili >>; if complaint then terpri()$ end$ %==== Procedures as in LIEPDE: symbolic procedure comparedif1(u1l,u2l)$ % checks whether u2l has more or at least equally many 1's, 2's, ... % contained as u1l. % returns a list of 1's, 2's, ... which are in excess in u2l % compared with u1l. The returned value is 0 if both are identical begin scalar ul; if u2l=nil then if u1l neq nil then return nil else return 0 else if u1l=nil then return u2l else % both are non-nil if car u1l < car u2l then return nil else if car u1l = car u2l then return comparedif1(cdr u1l,cdr u2l) else << ul:=comparedif1(u1l,cdr u2l); return if not ul then nil else if zerop ul then list car u2l else cons(car u2l,ul) >> end$ % of comparedif1 %------------- symbolic procedure comparedif2(u1,u1list,du2)$ % checks whether du2 is a derivative of u1 differentiated % wrt. u1list begin scalar u2l; u2l:=combidif(du2)$ % u2l=(u2, 1, 1, ..) if car u2l neq u1 then return nil else return comparedif1(u1list, cdr u2l) end$ % of comparedif2 %------------- symbolic procedure listdifdif1(du1,deplist)$ % lists all elements of deplist which are *not* derivatives % of du1 begin scalar u1,u1list,res,h$ h:=combidif(du1); u1:=car h; u1list:=cdr h; for each h in deplist do if not comparedif2(u1,u1list,h) then res:=cons(h,res); return res end$ % of listdifdif1 %------------- symbolic operator listdifdif2$ symbolic procedure listdifdif2(lhslist,deplist)$ % lists all elements of deplist which are *not* derivatives % of any element of lhslist begin scalar h; deplist:=cdr reval deplist; lhslist:=cdr reval lhslist; for each h in lhslist do deplist:=listdifdif1(h,deplist); return cons('LIST,deplist) end$ % of listdifdif2 %------------- symbolic operator totdeg$ symbolic procedure totdeg(p,f)$ % Ordnung (total) der hoechsten Ableitung von f im Ausdruck p eval(cons('PLUS,ldiff1(car ldifftot(reval p,reval f),fctargs reval f)))$ %------------- % symbolic operator totordpot$ % symbolic procedure totordpot(p,f)$ % % Ordnung (total) der hoechsten Ableitung von f im Ausdruck p % % und hoechste Potenz der hoechsten Ableitung % % currently not used % begin scalar a; % a:=ldifftot(reval p,reval f); % return % cons(eval(cons('PLUS,ldiff1(car a,fctargs reval f))), cdr a) % end$ %------------- symbolic procedure diffdeg(p,v)$ % liefert Ordnung der Ableitung von p nach v$ % p Liste Varible+Ordnung der Ableitung, v Variable (Atom) if null p then 0 % alle Variable bearbeitet ? else if car p=v then % v naechste Variable ? if cdr p then if numberp(cadr p) then cadr p % folgt eine Zahl ? else 1 else 1 else diffdeg(cdr p,v)$ % weitersuchen %------------- symbolic procedure ldiff1(l,v)$ % liefert Liste der Ordnungen der Ableitungen nach den Variablen aus v % l Liste (Variable + Ordnung)$ v Liste der Variablen if null v then nil % alle Variable abgearbeitet ? else cons(diffdeg(l,car v),ldiff1(l,cdr v))$ % Ordnung der Ableitung nach % erster Variable anhaengen %------------- symbolic procedure ldifftot(p,f)$ % leading derivative total degree ordering % liefert Liste der Variablen + Ordnungen mit Potenz % p Ausdruck in LISP - Notation, f Funktion ldifftot1(p,f,fctargs f)$ %------------- symbolic procedure ldifftot1(p,f,vl)$ % liefert Liste der Variablen + Ordnungen mit Potenz % p Ausdruck in LISP - Notation, f Funktion, lv Variablenliste begin scalar a$ a:=cons(nil,0)$ if not atom p then % if member(car p,list('EXPT,'PLUS,'MINUS,'TIMES, % 'QUOTIENT,'DF,'EQUAL)) then if member(car p,REDUCEFUNCTIONS_) then % erlaubte Funktionen <> >> else if car p='MINUS then a:=ldifftot1(cadr p,f,vl) else if car p='EXPT then % Exponent % if numberp caddr p then % <> else a:=cons(nil,0) <> % Potenz aus Basis wird mit % Potenz multipliziert else if car p='DF then % Ableitung if cadr p=f then a:=cons(cddr p,1) % f wird differenziert? else a:=cons(nil,0) else % any other non-linear function <>; a:=cons(car a,10000) >> >> else % sonst Konstante bzgl. f if p=f then a:=cons(nil,1) % Funktion selbst else a:=cons(nil,0) % alle uebrigen Fkt. werden else if p=f then a:=cons(nil,1)$ % wie Konstante behandelt return a end$ %------------- symbolic procedure diffreltot(p,q,v)$ % liefert komplizierteren Differentialausdruck$ if diffreltotp(p,q,v) then q else p$ %------------- symbolic procedure diffreltotp(p,q,v)$ % liefert t, falls p einfacherer Differentialausdruck, sonst nil % p, q Paare (liste.power), v Liste der Variablen % liste Liste aus Var. und Ordn. der Ableit. in Diff.ausdr., % power Potenz des Differentialausdrucks begin scalar n,m$ m:=eval(cons('PLUS,ldiff1(car p,v)))$ n:=eval(cons('PLUS,ldiff1(car q,v)))$ return if m>; return allsub end$ %------------- algebraic procedure nextdy(revx,xlist,dy)$ % generates all first order derivatives of lhs dy % revx = reverse xlist; xlist is the list of variables; % dy the old derivative begin scalar x,n,ldy,rdy,ldyx,sublist; x:=first revx; revx:=rest revx; sublist:={}; ldy:=lhs dy; rdy:=rhs dy; while lisp(not member(prepsq simp!* algebraic x, prepsq simp!* algebraic ldy)) and (revx neq {}) do <>; n:=length xlist; if revx neq {} then % dy is not the function itself while first xlist neq x do xlist:=rest xlist; xlist:=reverse xlist; % New higher derivatives while xlist neq {} do <>; return sublist end$ %------------- symbolic procedure combidif(s)$ % extracts the list of derivatives from s: % u`1`1`2 --> (u, 1, 1, 2) begin scalar temp,ans,no,n1; s:=reval s; % to guarantee s is in true prefix form temp:=reverse explode s; while not null temp do <>; compress no >>; if (not fixp n1) then n1:=intern n1; ans:=n1 . ans; if eqcar(temp,'!`) then <>; >>; return ans end$ %------------- symbolic operator dif$ symbolic procedure dif(s,n)$ % e.g.: dif(fnc!`1!`3!`3!`4, 3) --> fnc!`1!`3!`3!`3!`4 begin scalar temp,ans,no,n1,n2,done; s:=reval s; % to guarantee s is in true prefix form temp:=reverse explode s; n2:=reval n; n2:=explode n2; while (not null temp) and (not done) do <>; compress no >>; if (not fixp n1) or ((fixp n1) and (n1 leq n)) then <>; ans:=nconc(no,ans); if eqcar(temp,'!`) then <> >> >>; return prepsq tdf end$ %------------- algebraic procedure simppl(pllist,ulist,tt,xx)$ begin scalar pl,hh,td,xd,lulist,ltt,lxx,ltd,dv,newtd,e1,deno,ok, newpllist,contrace; % contrace:=t; lisp << lulist:=cdr reval algebraic ulist; lxx:=reval algebraic xx; ltt:=reval algebraic tt; >>; newpllist:={}; for each pl in pllist do << td:=first pl; xd:=second pl; repeat << lisp << ltd:=reval algebraic td; if contrace then <>$ dv:=nil; newtd:=nil; deno:=nil; if (pairp ltd) and (car ltd='QUOTIENT) and my_freeof(caddr ltd,ltt) and my_freeof(caddr ltd,lxx) then <>; ok:=t; if (pairp ltd) and (car ltd = 'PLUS) then ltd:= cdr ltd else if (pairp ltd) and (car ltd neq 'TIMES) then ok:=nil else ltd:=list ltd; if contrace then <>$ if ok then << for each e1 in ltd do << hh:=intpde(e1, lulist, list(lxx,ltt), lxx, t); if null hh then hh:=list(nil,e1); dv :=cons(car hh,dv); newtd:=cons(cadr hh,newtd); >>; dv :=reval cons('PLUS,dv); newtd:=reval cons('PLUS,newtd); if deno then <>; if contrace then <>$ % Now the number of f in flist should be equal the number of conditions % or as low as possible n:=0; rhs:=nil; for each d in idtysep do if not zerop car d then << % for each condition n:=add1 n; su:=print_;print_:=nil; x:=newfct('l_,xlist,n); print_:=su; su:=if dno=1 then car d else reval {'QUOTIENT,car d,dno}$ algebraic write x,":=",su$ lsb:=cons({'EQUAL,x,su},lsb); % 5. for each condition integrate all terms y:=cdr d; cpy:=flist; while y and not zerop y do << repeat << d:=ldiffp(y,car cpy)$ if zerop cdr d then if null cpy then <> else cpy:=cdr cpy >> until not zerop cdr d; if car d = nil then << cof:=coeffn(y,car cpy,1); rhs:={'PLUS,{'TIMES,x,cof,car cpy},rhs}; y:=reval reval {'DIFFERENCE,y,{'TIMES,cof,car cpy}} >> else << cof:=coeffn(y,cons('DF,cons(car cpy,car d)),1); rhs:=reval {'PLUS,rhs,{'TIMES,cons('DF,cons({'TIMES,x,cof},car d)), car cpy,{'EXPT,{'MINUS,1},absdeg(car d)}}}; y:=reval reval {'DIFFERENCE,y,{'TIMES,cof,cons('DF,cons(car cpy,car d))}} >> >> >>$ lsb:=cons('LIST,lsb)$ flist:=cons('LIST,flist)$ algebraic << d:=gcd(den lhs,den rhs); lhs:=lhs*d; rhs:=rhs*d; %--- Correctness test d:=sub(subli,lhs)-sub(lsb,rhs); if d neq 0 then write "Not identically zero : ",d$ for each f in flist do algebraic << x:=coeffn(num lhs,f,1); y:=coeffn(num rhs,f,1); d:=gcd(x,y); algebraic write x/d/den lhs," = ",y/d/den rhs$ >> >>$ end$ %------------- end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crack.red0000644000175000017500000001747711526203062023366 0ustar giovannigiovannimodule crack; % Top level CRACK module. % (May require more than one run to compile using Win32-PSL.) % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % CRACK Version 1 Dec 2002 % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% comment Title: CRACK Authors: Thomas Wolf Department of Mathematics Brock University, 500 Glenridge Avenue, St.Catharines, Ontario, Canada L2S 3A1 email: twolf@brocku.ca until 1997: Andreas Brand Institut fuer Informatik Friedrich Schiller Universitaet Jena 07740 Jena, Germany email: maa@hpux.rz.uni-jena.de Abstract: CRACK is a package for solving overdetermined systems of ordinary or partial differential equations (ODEs, PDEs). Examples of programs using CRACK are LIEPDE (for determining point and higher order symmetries), APPLYSYM (to compute symmetry and similarity variables for given point symmetries (symmetry reduction)) and CONLAW (for determining first integrals for ODEs or conservation laws for PDEs). For more details see the manual CRACK.TEX and the manuals of the other packages; % The following additions by FJW are to support CRACK under CSL as % they are defined in PSL. fluid '(promptstring!*)$ !#if (null(getd 'setprop)) symbolic procedure setprop(U, L); %% Store item L as the property list of U. %% FJW: Defined (but NOT flagged lose) in PSL only. %% FJW: A crude implementation for CSL. %% Note that in CSL flags are properties with value t. << for each p in plist U do remprop(U, car p); for each p in L do put(U, car p, cdr p) >>$ !#endif % The following smacro definitions MUST be in this header file! !#if (null(getd 'flag1)) symbolic smacro procedure flag1(U, V); %% The identifier U is flagged V. %% FJW: Defined and flagged lose in PSL only. %% FJW: This implementation based on the PSL manual. flag({U}, V)$ !#endif !#if (null(getd 'remflag1)) symbolic smacro procedure remflag1(U, V); %% Remove V from the property list of identifier U. %% FJW: Defined and flagged lose in PSL only. %% FJW: This implementation based on the PSL manual. remflag({U}, V)$ !#endif global '(!*iconic)$ symbolic fluid '(!*allowdfint_bak !*dfprint_bak !*exp_bak !*ezgcd_bak !*fullroots_bak !*gcd_bak !*mcd_bak !*nopowers_bak !*ratarg_bak !*rational_bak !*batch_mode abs_ adjust_fnc allflags_ batchcount_ backup_ collect_sol confirm_subst cont_ contradiction_ cost_limit5 current_dir % dec_hist dec_hist_list default_proc_list_ do_recycle_eqn do_recycle_fnc done_trafo eqname_ expert_mode explog_ facint_ flin_ force_sep fname_ fnew_ freeabs_ freeint_ ftem_ full_proc_list_ gcfree!* genint_ glob_var global_list_integer global_list_ninteger global_list_number high_gensep homogen_ history_ idname_ idnties_ independence_ ineq_ inter_divint keep_parti last_steps length_inc level_ lex_df lex_fc limit_time lin_problem lin_test_const logoprint_ low_gensep max_gc_counter max_gc_elimin max_gc_fac max_gc_red_len max_gc_short max_gc_ss max_red_len maxalgsys_ mem_eff my_gc_counter nequ_ new_gensep nfct_ nid_ odesolve_ old_history one_argument_functions_ orderings_ poly_only potint_ print_ print_all print_more proc_list_ prop_list pvm_able quick_decoup record_hist recycle_eqns recycle_fcts recycle_ids reducefunctions_ repeat_mode safeint_ session_ simple_orderings size_hist size_watch sol_list solvealg_ stepcounter_ stop_ struc_dim struc_eqn subst_0 subst_1 subst_2 subst_3 subst_4 target_limit_0 target_limit_1 target_limit_2 target_limit_3 target_limit_4 time_ time_limit to_do_list tr_decouple tr_genint tr_gensep tr_main tr_orderings tr_redlength tr_short trig1_ trig2_ trig3_ trig4_ trig5_ trig6_ trig7_ trig8_ userrules_ vl_)$ !#if (getd 'packages_to_load) % Load support packages, but not when compiling: packages_to_load ezgcd,odesolve,factor,int,algint,matrix,groebner; if getd('pvm_mytid) then % Load PVM support packages_to_load pvm,reducepvm; !#else % for REDUCE 3.6 apply1('load_package, '(ezgcd odesolve factor int algint matrix groebner)); !#endif !#if (get 'applysym 'folder) % Means that mkpckge is being used. create!-package('( crack crdec crinit % initialisation and help crmain % main module crsep % separation module crgensep % generalized separation module crint % integration of pde's module crsimp % simplification and substitution module crutil % procedures used in several modules crsimpso % simplification of the results crequsol % equivalence of solutions crshort % reductions in length crorder % orderings support crstruc % special module for structural eqn. crunder % param. solution of underdet. lin. DEs crlinalg % simpl. and sol. of lin. alg. systems crsubsys % identifying and solving subsystems crtrafo % point transformations module crident % working with identities crhomalg % working with bilinear algebraic systems crpvm % interface for PVM % crintfix crstart ), nil); !#else in crdec!.red$ % decouple module in crinit!.red$ % initialisation and help in crmain!.red$ % main module in crsep!.red$ % separation module in crgensep!.red$ % generalized separation module in crint!.red$ % integration of pde's module in crsimp!.red$ % simplification and substitution module in crutil!.red$ % procedures used in several modules in crsimpso!.red$ % simplification of the results in crequsol!.red$ % equivalence of solutions in crshort!.red$ % reductions in length in crorder!.red$ % orderings support in crstruc!.red$ % special module for structural eqn. in crunder!.red$ % param. solution of underdet. lin. DEs in crlinalg!.red$ % simpl. and sol. of lin. alg. systems in crsubsys!.red$ % identifying and solving subsystems in crtrafo!.red$ % point transformations module in crident!.red$ % working with identities in crhomalg!.red$ % working with bilinear algebraic systems in crpvm!.red$ % working parallel on PVM !#if (equal version!* "REDUCE 3.6") in crintfix!.red$ % patch for the integration !#endif setcrackflags()$ !#endif endmodule; end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crint.red0000644000175000017500000026721611526203062023420 0ustar giovannigiovanni%********************************************************************* module integration$ %********************************************************************* % Routines for integration of pde's % Authors: Andreas Brand 1993 1995 % Thomas Wolf since 1993 symbolic procedure ldlist(p,f,vl)$ % provides a reverse list of leading derivatives of f in p, vl is list % of variables begin scalar a$ if not atom p then if member(car p,list('EXPT,'PLUS,'MINUS,'TIMES,'QUOTIENT,'DF,'EQUAL)) then << if (car p='PLUS) or (car p='TIMES) or (car p='QUOTIENT) or (car p='EQUAL) then <> >> else if car p='MINUS then a:=ldlist(cadr p,f,vl) else if car p='EXPT then % if numberp caddr p then a:=ldlist(cadr p,f,vl) else % fuehrende Abl. aus der Basis % else a:=nil if car p='DF then if cadr p=f then <>; a:=list a >> >>$ return a end$ symbolic procedure diffincl(a,b)$ % a,b are lists of leading derivatives which are to be united begin scalar p; while a and b do <>; return if null a then if p then nconc(p,b) else b else if p then a:=nconc(p,a) else a end$ symbolic procedure ddroplow(a,cb)$ % loescht Elemente von a, von denen cb eine Ableitung ist, loescht cb, % wenn ein Element von a eine Ableitung von cb ist begin scalar h; return if null a then list(cb) else <0 then cons(nil,a) % car a=df(cb,.. else ddroplow(cdr a,cb) % cb=df(car a,.. else <> >> end$ symbolic procedure compdiffer(p,q)$ % finds whether p is a derivative of q or q of p or neither begin scalar p!>q,q!>p; while p and ((null p!>q) or (null q!>p)) do <car q then p!>q:=t else % compare orders of derivatives if car pp:=t; p:=cdr p;q:=cdr q >>; return if q!>p then if p!>q then nil % neither else 0 % q is derivative of p else if p!>q then 2 % p is derivative of q else 1 % p equal q end$ symbolic procedure ldintersec(a)$ % determines the intersection of derivatives in the list a begin scalar b; return if null a then nil else <>; b >> end$ symbolic procedure isec(ca,b)$ % determines the minimum derivatives between ca and b begin scalar newb; while ca do <>; return reverse newb end$ symbolic procedure disjun(a,b)$ <>; if b then nil else t >>$ symbolic procedure ddrophigh(a,cb)$ % loescht Elemente von a, die Ableitung von cb sind, % loescht cb, wenn cb Ableitung eines Elements von a ist oder =a ist, % haengt cb ansonsten an begin scalar h; return if null a then list(cb) else <> end$ symbolic procedure elibar(l1,l2,lds)$ begin scalar found1,found2,h; % found1=t if an LD=l1 is found, found2=t if contradiction found while lds and (not found2) do <>; lds:=cdr lds >>; return found1 and (not found2) end$ symbolic procedure intminderiv(p,ftem,vlrev,maxvanz,nfsub)$ % yields a list {nv1,nv2, ... } such that nvi is the minimum % of the highest derivatives w.r.t. vi of all the leading derivatives % of all functions of ftem which are functions of all maxvanz variables. % Only those are kept for which nvi>0. % further a list ((f1 ld's of f1) (f2 ld's of f2)...), begin scalar l,a,listoflds$ while ftem do <>$ ftem:=cdr ftem >>$ return list(a,listoflds) end$ symbolic procedure potintegrable(listoflds)$ begin scalar h,l1,l2,f,n,lds,f1,f2$ if tr_genint then write "Does a potential exist?"$ %------- Determining 2 minimal sets of integration variables % There must be two disjunct LDs such that all others are in their % ideal. This is necessary if we want to eliminate 2 functions. h:=listoflds; l1:=nil; while h do <>; h:=cdr h >>; return if length l1 neq 2 then nil else if not disjun(car l1,cadr l1) then nil else % if there would be an overlap between l1 and l2 then it would have % to be integrated for elimination but it cannot --> no overlap % possible <<% selecting interesting functions for which one LD is = l1 and all % others are derivatives of l2 or equal l2 and vice versa. Two % necessary (one with an LD=l1 and one with an LD=l2) from which at % least one function (f) has no further LD. % Exception: 2 functions with each 2 LDs equal to (l1,l2) (these % functions are counted by n) l2:=cadr l1;l1:=car l1; f:=nil;f1:=nil;f2:=nil;n:=0; h:=listoflds; while h and ((not f1) or (not f2) or ((not f) and (n neq 2))) do <>; if (not f2) or (not f) then if elibar(l2,l1,lds) then <>; h:=cdr h >>; if f1 and ((n>1) or (f2 and f)) then list(l1,l2) else nil >> end$ % of potintegrable symbolic procedure vlofintlist(vl,intlist)$ % provides a list of elements of vl for which the corresponding % elements of intlist are non-zero begin scalar a; while intlist do <>; return a end$ symbolic procedure vlofintfaclist(vl,intfaclist)$ % determining the list of all variables of vl in intfaclist begin scalar e1,a; for each e1 in vl do if not my_freeof(intfaclist,e1) then a:=cons(e1,a); return a end$ symbolic procedure multipleint(intvar,ftem,q,vari,vl,genflag, potflag,partial,doneintvar)$ % multiple integration of q wrt. variables in vl, max. number of % integrations specified by intvar % integrating factors must not depend on doneintvar, doneintvar is % a list of integration variables so far % partial=t then as much as possible of an expression is integrated % even if there is a remainder begin scalar pri,vlcop,v,nmax,geni,intlist,iflag,n,nges,newcond, intfaclist,ph,pih,qh,qih,intfacdepnew,intfacdep$ % intfacdep is a list of variables on which factors of integration % depend so far, other than the integration variable in their % integration --> no integration wrt. these variables by potint % because there the diff. operators wrt. to different variables % need not commute because the integrations are not done % pri:=t$ if (not vari) and (zerop q) then return nil; nges:=0; vlcop:=vl; pih:=t; % Splitting of the equation into the homogeneous and inhomogeneous % part which is of advantage for finding integrating factors q:=splitinhom(q,ftem,vl)$ qh:=car q; qih:=cdr q; q:=nil; while (vari or vlcop) and (pih or (not potflag)) do %------- if for potflag=t one variable can not be integrated the %------- maximal number of times (nmax) then immediate stop because %------- then no elimination of two functions will be possible << %-- The next integration variable: v, no of integrations: nmax if vari then <> else <>; if zerop nmax then intlist:=cons(nil,intlist) else <>$ %------ At first the integration of the homogeneous part intfacdepnew:=intfacdep; if ph and (partial or (zerop cadr ph)) then << %---- For the homogen. part cadr ph must be zero intfaclist:=cons(1,intfaclist); ph:=car ph; if pri then <>$ if pri then <> else if not genflag then pih:=nil else <>$ iflag:='genint >> else if partial then qih:=car pih else pih:=nil >>; if pih then << if pri then write"AAA"$ qh:=ph; if (not potflag) and (n neq 1) then intfacdep:=intfacdepnew %-The first integr. factor of all v-integrations does not % depend on any earlier integration variables and can % therefore be taken out of all integrals --> no incease % of intfacdep for n=1. %-For potential integration the integration variables and % extra-dependencies-variables of integr. factors need not % be disjunct therefore the intfacdep-update only for % not-potflag >> else << if pri then write"BBB"$ % inhomogeneous part can not be integrated therefore % reversing the succesful integration of the hom. part if car intfaclist neq 1 then qih:=reval list('QUOTIENT,qih,car intfaclist); intfaclist:=cdr intfaclist >>; >>; %-- end of the integration of the inhomog. part if pri then write"n=",n," nmax=",nmax," not pih=",not pih$ >> until (n=nmax) or (not pih)$ %---- end of v-integration %------- variables of done integrations are collected for %------- determining integrating factors in later integr. if not zerop n then doneintvar:=cons(v,doneintvar)$ nges:=nges+n; intlist:=cons(intfaclist,intlist) >>$ % of not ( vari and (not member(v,vl))) if vari then <>; if pri then write"ende: intvar=",intvar," vari=",vari, " qh=",qh," qih=",qih$ >> % of (nmax neq zero) >>$ % of ( while (vari or vlcop) and (pih or (not potflag)) ) % intlist and its elements intfaclist are in the inverse order % to vl and the sequence of integrations done q:=reval list('PLUS,qh,qih)$ %--- adding homog. and inhomog. part if pri then <>; return if null iflag then nil else list(q,intlist,newcond,nges) end$ % of multipleint symbolic procedure uplistoflds(intlist,listoflds)$ begin scalar f,h1,h2,h3,h4,lds,itl; while listoflds do <>; h2:=cons(reverse h4,h2) >>; h1:=cons(cons(f,h2),h1) >>; return h1 % updated listoflds end$ % of uplistoflds symbolic procedure addintco(q, ftem, ifac, vl, vari)$ begin scalar v,f,l,vl1; % multi.ing factors to the constants/functions of integration if zerop q then l:=1 else <> else ftem:=cdr ftem$ if f then <> else l:=1 >>; % the constants and functions of integration if vari then q:=list('PLUS,q,intconst(l,vl,vari,list(1))) else <> >>$ return reval q end$ % of addintco symbolic procedure integratepde(p,ftem,vari,genflag,potflag)$ % Generalized integration of the expression p % if not genflag then "normal integration" % Equation p must not be directly separable, otherwise the depen- % dencies of functions of integration on their variables is wrong, % i.e. no dependence on explicit variables % ftem are all functions from the `global' ftem which occur in p, i.e. % ftem:=smemberl(ftem,p)$ % if vari=nil then integration w.r.t. all possible variables within % the equation % else only w.r.t. vari one time begin scalar vl,vlrev,v,intlist, ili1a,ili2a,maxvanz,fsub,h,hh,nfsub,iflag,newcond, n1,n2,pot1,pot2,p1,p2,listoflds,secnd,ifac0, ifac1a,ifac1b,ifac2a,ifac2b,cop,v1a,v2a,pri$ % pri:=t; if pri then <>$ vl:=argset ftem$ vlrev:=reverse vl; if vari then <> else n2:=0; ftem:=union(fnew_,ftem)$ >>; %------------ Existence of a potential ? if (n1=n2) and potflag and (nfsub>1) then %---- at least 2 functions to solve for <>$ if h:=potintegrable(listoflds) then <>$ if pri then <>; secnd:=not secnd; % retry in different order of integration, p is still the same if (iflag neq 'potint) and secnd then <> >> until (iflag eq 'potint) or (not secnd) >>; >>$ %--------- returning the result return if not iflag then nil else <>; h >>, vl, vari)$ if pri then <>$ cons(p,newcond) >> end$ % of integratepde symbolic procedure intpde(p,ftem,vl,x,potint)$ begin scalar ft,ip,h,itgl1,itgl2$ if potint then return intpde_(p,ftem,vl,x,potint)$ % ft are functions of x for each h in ftem do if not freeof(assoc(h,depl!*),x) then ft:=cons(h,ft); ip:=int_partition(p,ft,x)$ if null cdr ip then return intpde_(p,ftem,vl,x,potint)$ while ip do << h:=intpde_(car ip,ftem,vl,x,potint)$ if null h then << ip:=nil; itgl1:=nil; itgl2:=nil >> else << % itgl1:=cons(car h,itgl1); % itgl2:=cons(cadr h,itgl2); itgl1:=nconc(list(car h),itgl1); itgl2:=nconc(list(cadr h),itgl2); ip:=cdr ip >>; >>$ if itgl1 then <>$ return if null itgl1 then nil else {itgl1,itgl2} end$ symbolic procedure drop_x_dif(der,x)$ begin scalar dv,newdv$ % der is a derivative like {'DF,f,u,2,x,3,y,z,2} or {'DF,f,u,2,x,y,z,2} % drops the x-derivative(s) dv:=cddr der; while dv do << if car dv=x then if cdr dv and fixp cadr dv then dv:=cdr dv else else newdv:=cons(car dv,newdv); dv:=cdr dv >>; return if newdv then cons('DF,cons(cadr der,reverse newdv)) else cadr der end$ symbolic procedure strip_x(ex,ft,x)$ begin scalar tm,cex$ % ex is a term % ft is a list of all functions of x which possibly occur in ex return if freeoflist(ex,ft) then 1 else if not pairp ex then ex else if car ex='MINUS then strip_x(cadr ex,ft,x) else if car ex='DF then drop_x_dif(ex,x) else if car ex='EXPT then if not pairp cadr ex then ex else if caadr ex='DF then {'EXPT,drop_x_dif(cadr ex,x),caddr ex} else 1 % strange else if car ex='TIMES then << ex:=cdr ex; while ex do << cex:=car ex; ex:=cdr ex; if not freeoflist(cex,ft) then if not pairp cex then tm:=cons(cex,tm) else if car cex='DF then tm:=cons(drop_x_dif(cex,x),tm) else if car cex='EXPT then if not pairp cadr cex then tm:=cons(cex,tm) else if caadr cex='DF then tm:=cons({'EXPT,drop_x_dif(cadr cex,x),caddr cex},tm) % else strange - no polynomial in ft >>; if null tm then 1 % strange else if length tm > 1 then reval cons('TIMES,tm) % product of factors else car tm % single factor >> else 1 % strange end$ symbolic procedure sort_partition(pname,p,ft,x)$ % The equation is either given by its name pname or its value p % if keep_parti=t then the partitioning will be stored begin scalar stcp,pcop,parti; % parti will be the list of partial sums if pname then if get(pname,'partitioned) then return get(pname,'partitioned) else p:=get(pname,'val)$ if (not pairp p) or (car p neq 'PLUS) then p:=list p else p:=cdr p; while p do << % sort each term into a partial sum stcp:=strip_x(car p,ft,x); % first strip off x_dependent details pcop:=parti; % search for the label in parti while pcop and caar pcop neq stcp do pcop:=cdr pcop; if null pcop then parti:=cons({stcp,1,{car p}},parti) % open a new partial sum else rplaca(pcop,{stcp,add1 cadar pcop, cons(car p,caddar pcop)}); % add the term to an existing partial sum p:=cdr p >>; if pname and keep_parti then put(pname,'partitioned,parti)$ return parti end$ % of sort_partition symbolic procedure int_partition(p,ft,x)$ begin scalar parti,ft,pcop; % the special case of a quotient if (pairp p) and (car p='QUOTIENT) then return if not freeoflist(caddr p,ft) then list p else << pcop:=int_partition(cadr p,ft,x)$ for each h in pcop collect {'QUOTIENT,h,caddr p} >>$ parti:=sort_partition(nil,p,ft,x)$ parti:=idx_sort for each h in parti collect cdr h; return for each h in parti collect if car h = 1 then caadr h else cons('PLUS,cadr h) end$ symbolic procedure intpde_(p,ftem,vl,x,potint)$ % integration of an polynomial expr. p w.r.t. x begin scalar f,ft,l,l1,l2,vl,k,s,a,iflag,flag$ ft:=ftem$ vl:=cons(x,delete(x,vl))$ while ftem and not flag do <> >> >>; l:=l1; >> else l1:=l:=lderiv(p,f,vl)$ while not (flag or << iflag:=intlintest(l,x); if (iflag='NOXDRV) or (iflag='NODRV) then << l2:=start_let_rules()$ p:=reval aeval p$ stop_let_rules(l2)$ l:=lderiv(p,f,vl)$ iflag:=intlintest(l,x) >>; iflag >> ) do <>$ % iflag='nofct is the so far integrable case % the non-integrable cases are: flag neq nil, % (iflag neq nil) and (iflag neq 'nofct), an exception to the % second case is potint where non-integrable rests are allowed if iflag='nofct then ftem:=smemberl(ftem,p) else if potint or (fctlength f> else flag:=(iflag or flag) >> else ftem:=cdr ftem >>$ return if not flag then <> else << p:=reval reval aeval list('DIFFERENCE,p,l2)$ stop_let_rules(k)$ if poly_only then if ratexp(s,ft) then list(s,p) else nil else list(s,p) >> >> >> else nil$ end$ % of intpde_ symbolic procedure explicitpart(p,ft,x)$ % part of a sum p which only explicitly depends on a variable x begin scalar l$ if not member(x,argset smemberl(ft,p)) then l:=p else if pairp p then <> >>$ if not l then l:=0$ return l$ end$ symbolic procedure intconst(co,vl,x,ifalist)$ % The factors in ifalist must be in the order of integrations done if null ifalist then 0 else begin scalar l,l2,f,coli,cotmp$ while ifalist do << cotmp:=coli; coli:=nil; while cotmp do << coli:=cons(list('INT,list('TIMES,car ifalist,car cotmp),x),coli); cotmp:=cdr cotmp >>; coli:=cons(1,coli); ifalist:=cdr ifalist >>; while coli do <>$ if length l>1 then l:=cons('PLUS,l) else if pairp l then l:=car l else l:=0$ if co and co neq 1 then if pairp co then <> else l else nil$ end$ symbolic procedure decderiv1(l,x)$ if null l then nil else if car l=x then if cdr l then if numberp cadr l then if cadr l>2 then cons(car l,cons(sub1 cadr l,cddr l)) else cons(car l,cddr l) else cdr l else nil else cons(car l,decderiv1(cdr l,x))$ symbolic procedure integratede(q,ftem,genflag)$ % Integration of a de % result: newde if successfull, nil otherwise begin scalar l,l1,l2,fl$ ftem:=smemberl(ftem,q)$ again: if l1:=integrableode(q,ftem) then % looking for an integrable ode if l1:=integrateode(q,car l1,cadr l1,caddr l1,ftem) then % trying to integrate it <>$ if l1:=integratepde(q,ftem,nil,genflag,potint_) then % trying to integrate a pde <>$ fl:=t$ if null genflag then l1:=nil$ ftem:=smemberl(union(fnew_,ftem),q); goto again >>$ if fl then <>$ put(f,'maxderivs,cdr get(f,'maxderivs)) >>$ dl:=intersection(l,dl)$ if dl then vl:=cdr vl else vl:=nil>>$ for each f in fl do remprop(f,'maxderivs)$ if fullint and (null dl) then remflag1(q,'to_fullint)$ return dl end else t$ symbolic procedure integrate(q,genintflag,fullint,pdes)$ % integrate pde q; if genintflag is not nil then indirect % integration is allowed % if fullint is not nil then only full integration is allowed % Es wird noch nicht ausgenutzt: % 1) Fcts, die rational auftreten % 2) starde % parameter pdes only for drop_pde_from_idties(), drop when pdes_ global % and for mkeqlist() for adding inequalities begin scalar l,fli,fnew_old$ if fli:=intflagtest(q,fullint) then <>$ if (l:=integratede(get(q,'val),get(q,'fcts),genintflag)) then if fullint and not null car ldiffp(car l,car fli) then <> >> else < cycling? put(q,'dec_with_rl,nil); % " added --> cycling? if print_ then << terpri()$ if cdr l then if get(q,'nvars)=get(cadr l,'nvars) then write "Potential integration of ",q," yields ",l else write "Partially potential integration of ",q," yields ",l else write "Integration of ",q$ terpri()>>$ remflag1(q,'to_fullint)$ remflag1(q,'to_int) >> else << remflag1(q,'to_fullint)$ remflag1(q,'to_int) >> >>$ % if print_ and null l and fullint then terpri()$ % prints unnecc. nl return l$ end$ symbolic procedure quick_integrate_one_pde(pdes)$ begin scalar q,p,r,nv,nvc,miordr,minofu,minodv,ordr,nofu,nodv$ % ,nvmax$ % nvmax:=0; % for each q in ftem_ do if (r:=fctlength q)>nvmax then nvmax:=r; nv:=no_fnc_of_v()$ % the number of functions for each variable % find the lowest order derivative wrt. only one variable miordr:=10000; % the order of the currently best equation minofu:=10000; % the number of functions depending on the % variable wrt. which shall be integrated minodv:=10000; % the number of differentiation variables of % the so far best equation while pdes and (get(car pdes,'length) = 1) do << % only 1 term q:=get(car pdes,'derivs)$ if q and % (get(car pdes,'nvars) = nvmax) cdaar q % any differentiations at all then << q:=caar q$ nodv:=0$ % no of differentiation variables ordr:=0$ % total order of the derivative r:=cdr q; while r do << if fixp car r then ordr:=ordr-1+car r else <>; r:=cdr r >>$ if nodv>1 then nofu:=10000 % nodv = no of functions depending else << % on the integration variable nvc:=nv; while cadr q neq caar nvc do nvc:=cdr nvc; nofu:=cdar nvc; >>$ % no of fncs of v if nodv=1 then if (ordr>; >>$ pdes:=cdr pdes >>$ if p then p:=integrate(p,nil,t,pdes)$ return p end$ symbolic procedure integrate_one_pde(pdes,genintflag,fullint)$ % trying to integrate one pde begin scalar l,l1,m,p,pdescp$ % ,nvmax,h,f$ % nvmax:=0; % for each f in ftem_ do if (h:=fctlength f)>nvmax then nvmax:=h; % at first selecting all eligible de's m:=-1$ pdescp:=pdes$ while pdescp do << if flagp(car pdescp,'to_int) and not(get(car pdescp,'starde)) then << l:=cons(car pdescp,l); if get(car pdescp,'nvars)>m then m:=get(car pdescp,'nvars)$ >>; pdescp:=cdr pdescp >>; l:=reverse l; if mem_eff then % try the shortest equation first while l do if p:=integrate(car l,genintflag,fullint,pdes) then l:=nil else l:=cdr l else % find an equation to be integrated with as many as possible variables % if (m=nvmax) or (null fullint) then while m>=0 do << l1:=l$ while l1 do if (get(car l1,'nvars)=m) and (p:=integrate(car l1,genintflag,fullint,pdes)) then << m:=-1$ l1:=nil >> else l1:=cdr l1$ % if fullint then m:=-1 else m:=sub1 m >>$ return p$ end$ endmodule$ %******************************************************************** module generalized_integration$ %******************************************************************** % Routines for generalized integration of pde's containing unknown % functions % Author: Andreas Brand % December 1991 symbolic procedure gintorder(p,ftem,vl,x)$ % reorder equation p begin scalar l,l1,q,m,b,c,q1,q2$ if pairp(p) and (car p='QUOTIENT) then << q:=caddr p$ p:=cadr p$ l1:=gintorder1(q,ftem,x,t)$ % if DepOnAllVars(car l1,x,vl) then return nil; q1:=car l1; q2:=cadr l1; >>$ if pairp(p) and (car p='PLUS) then p:=cdr p % list of summands else p:=list p$ while p do <> >>$ if l then <>$ if m>0 then b:=list('TIMES,list('EXPT,x,m),b)$ cons(reval b,c)>> else cons(reval car a,cdr reval coeff1(cadr a,x,nil))$ if q then << l:=for each a in l collect cons(car a,for each s in cdr a collect reval list('QUOTIENT,s,q2))$ l:=for each a in l collect cons(reval list('QUOTIENT,car a,q1),cdr a) >>$ >>$ return l$ end$ symbolic procedure DepOnAllVars(c,x,vl)$ % tests for occurence of vars from vl in factors of c depending on x begin scalar l$ if pairp c and (car c='TIMES) then c:=cdr c else c:=list c$ while c and vl do <>$ return (null vl)$ end$ symbolic procedure gintorder1(p,ftem,x,mode2)$ % reorder a term p begin scalar l1,l2,sig$ % mode2 = nil then % l2:list of factors of p not depending % on x or beeing a power of x % l1:all other factors % mode2 = t then % l2:list of factors of p not depending on x % l1:all other factors if pairp p and (car p='MINUS) then <>$ if pairp p and (car p='TIMES) then p:=cdr p else p:=list p$ for each a in p do <>$ l:=gintorder(p,ftem,vl,x)$ % would too many new equations and functions be necessary? if pairp(l) and (length(l)>genint) then return nil; l:=for each s in l collect << h:=varslist(car s,ftem,vl)$ if h=nil then << list('TIMES,x,car s,cons('PLUS,cdr s)) >> else << f:=newfct(fname_,h,nfct_)$ nfct_:=add1 nfct_$ fnew_:=cons(f,fnew_)$ neg:=t$ n:=sub1 length cdr s$ k:=-1$ if (pairp car s) and (caar s='DF) then <> else <>$ reval cons('PLUS, for each sk on cdr s collect <> ) >> >>$ if l then l:=cons(reval cons('PLUS,l),l1)$ if tr_genint then <> else write " nil "$ >>$ return l$ end$ symbolic procedure tailsum(sk,k,x)$ begin scalar j$ j:=-1$ return reval cons('PLUS, for each a in sk collect <> ) end$ symbolic procedure prod(m,n)$ if m>n then 1 else for i:=m:n product i$ endmodule$ %******************************************************************** module intfactor$ %******************************************************************** % Routines for finding integrating factors of PDEs % Author: Thomas Wolf % July 1994 % The following without factorization --> faster but less general %symbolic procedure fctrs(p,vl,v)$ %begin scalar fl1,fl2,neg; % %write"p=",p; % % if car p='MINUS then <>$ % return % if not pairp p then if my_freeof(p,v) and (not freeoflist(p,vl)) then % list(p,1,neg) else % list(1,p,neg) % else if car p='PLUS then list(1,p,neg) % else % if car p='TIMES then % <> else if my_freeof(p,v) and (not freeoflist(p,vl)) then % list(p,1,neg) else % list(1,p,neg) %end$ % of fctrs % symbolic procedure fctrs(p,indep,v)$ begin scalar fl1,fl2; p:=cdr reval factorize p; for each el in p do if freeoflist(el,indep) and ((v=nil) or (not my_freeof(el,v))) then fl1:=cons(el,fl1) else fl2:=cons(el,fl2); if null fl1 then fl1:=1; if null fl2 then fl2:=1; if pairp fl1 then if length fl1 = 1 then fl1:=car fl1 else fl1:=cons('TIMES,fl1); if pairp fl2 then if length fl2 = 1 then fl2:=car fl2 else fl2:=cons('TIMES,fl2); return list(fl1,fl2) end$ % of fctrs symbolic procedure extractfac(p,indep,v)$ % looks for factors of p dependent of v and independent of indep % and returns a list of the numerator factors and a list of the % denominator factors begin scalar nu,de$ return if (pairp p) and (car p='QUOTIENT) then <> else fctrs(p,indep,v) end$ % of extractfac %---------------------------- symbolic procedure get_kernels(ex)$ % gets the list of all kernels in ex begin scalar res,pri$ % pri:=t; ex:=reval ex$ if pri then <>; if pairp ex then if (car ex='QUOTIENT) or (car ex='PLUS) or (car ex='TIMES) then for each s in cdr ex do res:=union(get_kernels s,res) else if (car ex='MINUS) or ((car ex='EXPT) and % (numberp caddr ex)) then % not for e.g. (quotient,2,3) (cadr ex neq 'E) and (cadr ex neq 'e) and (not fixp cadr ex) ) then res:=get_kernels cadr ex else res:=list ex else if idp ex then res:=list ex$ if pri then <>; return res$ end$ %------------------ symbolic procedure specialsol(p,vl,fl,x,indep,gk)$ % tries a power ansatz for the functions in fl in the kernels % of p to make p to zero % indep is a list of kernels, on which the special solution should % not depend. Is useful, to reduce the search-space, e.g. when an % integrating factor for a linear equation for, say f, is to be % found then f itself can not turn up in the integrating factor fl % gk are kernels which occur in p and possibly extra ones which % e.g. are not longer in p because of factorizing p but which are % likely to play a role, if nil then determined below % x is a variable on which each factor in the special solution has % to depend on. begin scalar e1,e2,n,nl,h,hh,ai,sublist,eqs,startval,pri,printold,pcopy; %pri:=t; p:=num p; pcopy:=p; if pri then << terpri()$write"The equation for the integrating factor:"; terpri()$eqprint p; >>; if null gk then gk:=get_kernels(p); for each e1 in fl do << h:=nil; %---- h is the power ansatz if pri then for each e2 in gk do << terpri()$write"e2=",e2; if my_freeof(e2,x) then write" freeof1"; if not freeoflist(e2,fl) then write" not freeoflist"$ if not freeoflist(e2,indep) then write" dependent on indep" >>; %----- nl is the list of constants to be found for each e2 in gk do if (not my_freeof(e2,x)) and % integ. fac. should depend on x freeoflist(e2,fl) and % the ansatz for the functions to be % solved should not include these functions freeoflist(e2,indep) then << n:=gensym();nl:=cons(n,nl); h:=cons(list('EXPT,e2,n),h); >>; if h then << if length h > 1 then h:=cons('TIMES,h) else h:=car h; %-- the list of substitutions for the special ansatz sublist:=cons((e1 . h),sublist); if pri then <>; if length eqs = 1 then eqs:=cdr eqs else eqs:=cons('LIST,eqs); if length startval = 1 then startval:=cdr startval else startval:=cons('LIST,startval); terpri()$write"start rdsolveeval!";terpri()$terpri()$ h:=rdsolveeval list(eqs,startval); eqs:=nil; off rounded; >>; %----- An analytical approach to solve for the constants if null pri then <>; if p and not zerop p then % uebernommen aus SEPAR if not (pairp p and (car p='QUOTIENT) and % " " " intersection(argset smemberl(fl,cadr p),vl)) then p:=separ2(p,fl,vl) else p:=nil; if null pri then print_:=printold; if p then << % possibly investigating linear dependencies of different caar p % solve(lasse x-abhaengige und nl-unabhaengige faktoren fallen von % factorize df(reval list('QUOTIENT, caar p1, caar p2),x),nl). while p do if freeoflist(cdar p,nl) then <> % singular system --> no solution else << eqs:=cons(cdar p,eqs); p:=cdr p >>; >>; if pri then <>; if (null eqs) or (length eqs > maxalgsys_) then return nil else << if pri then << terpri()$write"The algebraic system to solve for ",nl," is:"; if length eqs > 1 then deprint eqs else eqprint car eqs >>; if length eqs > 1 then eqs:=cons('LIST,eqs) else eqs:=car eqs; if pri then <>$ % for catching the error message `singular equations' hh:=cons('LIST,nl); eqs:=<< ai:=!!arbint; err_catch_solve(eqs,hh) >>; if pri then <>; if pri then <> >>; >>; if pri then <>$ for each e1 in sublist do << pcopy:=subst(cdr e1,car e1,pcopy); if pri then <>; %--- Generation of the condition for the integrating factor(s) in fl for each e1 in pl do << %--- extracting factors dependend on x and independent of %--- doneintvar but only if integrations have already been done, %--- i.e. (doneintvar neq nil) gk:=union(gk,get_kernels(e1)); if factr then <>; tozero:=nil; for each e1 in h do if smemberl(fl,e1) then tozero:=cons(e1,tozero)$ tozero:= reval if length tozero > 1 then cons('TIMES,tozero) else car tozero; >>; if nil and pri then <>; h:=nil; % actually only those f in ftem, in which pl is nonlinear, but also % then only integrating factors with a leading derivative low enough h:=specialsol(tozero,vl,fl,x,append(ftem,doneintvar),gk); % h:=specialsol(tozero,vl,fl,x,doneintvar,gk); if pri then <>; if h then << for each e1 in h do << % each e1 is one integrating factor determined if pri then <>; %--- update intfacdep for each e1 in vl do if (e1 neq x) and my_freeof(intfacdep,e1) and ((not my_freeof(h,e1)) or (not my_freeof(exfactors,e1))) then intfacdep:=cons(e1,intfacdep); %--- returns nil if no integrating factor else a list of the %--- factors and the integral if h and print_ and verbse then << terpri()$write"The integrated equation: "; eqprint newequ; terpri()$ if length pl = 1 then write"An integrating factor has been found:" else write"Integrating factors have been found: "$ >>; !#if (equal version!* "REDUCE 3.6") !#else !*precise:=precise_old$ !#endif return if (null h) or (zerop newequ) then nil else list(newequ, for each e1 in h collect << ftr:=car exfactors; exfactors:=cdr exfactors; gk:=if ftr=1 then cdr e1 else reval list('QUOTIENT,cdr e1,ftr); if print_ and verbse then mathprint gk; gk >>, intfacdep) end$ endmodule$ %******************************************************************** module odeintegration$ %******************************************************************** % Routines for integration of ode's containing unnown functions % Author: Thomas Wolf % August 1991 symbolic procedure integrateode(de,fold,xnew,ordr,ftem)$ begin scalar newde,newnewde,l,h,newcond$ h:= % the integrated equation if not xnew then << % Integr. einer alg. Gl. fuer eine Abl. newde:=cadr solveeval list(de,fold)$ if not freeof(newde,'ROOT_OF) then nil else << newde:=reval list('PLUS,cadr newde,list('MINUS,caddr newde))$ if (l:=integratepde(newde,ftem,nil,genint_,nil)) then <> %genflag=t,potflag=nil else nil >> >> else % eine ode fuer ein f? if not pairp fold then % i.e. not df(...,...), i.e. fold=f odeconvert(de,fold,xnew,ordr,ftem) % --> ode fuer eine Abl. von f else << newde:=odeconvert(de,fold,xnew,ordr,ftem)$ if not newde then nil else << newnewde:=cadr solveeval list(newde,fold)$ newnewde:=reval list('PLUS,cadr newnewde,list('MINUS, caddr newnewde))$ ftem:=union(fnew_,ftem)$ newnewde:=integratede(newnewde,ftem,nil)$ if newnewde then <> else newde >> >>; return if not h then nil else cons(h,newcond) end$ % of integrateode symbolic procedure odecheck(ex,fint,ftem)$ % assumes an revaled expression ex % Does wrong if car ex is a list! begin scalar a,b,op,ex1$ %***** ex is a ftem-function ***** if ex=fint then % list(ex,0,0,..) <>$ % not checked if it is a function of an expression of x op:=reverse a>> else if pairp ex then %***** car ex is 'df ***** if (car ex)='df then <>$ op:=cons(b,cons(b,op))>>$ a:=cdr a>>$ op:=reverse op>> >> else %***** car ex is a standard or other function ***** <(if odesolve_ then odesolve_ else 0) then (if cont_ then if yesp("expression to be integrated ? ") then integrableode1(p,ftem)) else integrableode1(p,ftem)$ symbolic procedure integrableode1(p,ftem)$ begin scalar a,b,u,vl,le,uvar, fint,fivar,% the function to be integrated and its variables fold, % the new function of the ode xnew, % the independ. variable of the ode ordr1, % order of the ode ordr2, % order of the derivative for which it is an ode intlist$ % list of ode's ftem:=smemberl(ftem,p)$ vl:=argset ftem$ % p muss genau eine Funktion aus ftem von allen Variablen enthalten. % Die Integrationsvariable darf nicht Argument anderer in p enthaltener % ftem-Funktionen sein. a:=ftem$ b:=nil$ le:=length vl$ while a and vl do <> else <> else vl:=setdiff(vl,uvar)$ a:=cdr a>>$ if not b then vl:=nil$ le:=length p$ if ((1 1 then fold:=cons(car a,fold)>>$ ordr2:=ordr2+car a$ if (car a) neq (cadr a) then <>$ ordr1:=(cadr a) - (car a)>>$ b:=cdr b$ a:=cddr a>>$ fold:=reverse fold$ %fold is the list of diff.variables + number of diff. if fold then fold:=cons('df,cons(fint,fold)) else fold:=fint$ if vl and ((ordr1 neq 0) or (ordr2 neq 0)) then intlist:=list(fold,xnew,ordr1,ordr2) >> % of variable found >>$ % of if return intlist end$ % of integrableode1 symbolic procedure odetest(op,b)$ if not op then b else % op=nil --> first function found if (car op) neq (car b) then '!_abb else % f occurs in differ. fct.s begin scalar dif,a$ dif:=nil$ % dif=t --> different derivatives a:=list(car op)$ % in one variable already found op:=cdr op$ b:=cdr b$ while op do <>$ algebraic !!arbconst:=0$ newde:=algebraic first odesolve(symbolic oldde,symbolic ford_,symbolic xnew)$ ruli:= start_let_rules()$ if !*rational then << off rational; newde:=reval newde; on rational>> else newde:=reval newde; % Instead of the following test one should return several cases zd:=zero_den(newde,cons(ford_,ftem),union(list xnew,argset ftem)); % if safeint_ and zero_den(newde,ftem,argset ftem) then newde:=nil; if freeint_ and null freeof(newde,'INT) then newde:=nil; if freeabs_ and null freeof(newde,'ABS) then newde:=nil; if newde and (cadr newde neq oldde) then << % solution found % Test der Loesung klappt nur, wenn Loesung explizit gegeben if cadr newde neq ford_ then << if print_ then <>; if poly_only then % The solution must be rational in the % function and constants of integration if not rationalp(newde,ford_) then newde:=nil else << j:=1; while (j leq ordr) and rationalp(subst(ford_,list('arbconst,j),newde),ford_) do j:=j+1; if j leq ordr then newde:=nil >>; if pairp newde and (car newde = 'EQUAL) then if (pairp cadr newde) and (caadr newde = 'QUOTIENT) and (zerop caddr newde) then newde:={'EQUAL,cadadr newde,0} else if (pairp caddr newde) and (caaddr newde = 'QUOTIENT) and (zerop cadr newde) then newde:={'EQUAL,0,cadr caddr newde} >> else << null_:=reval reval aeval subst(caddr newde, ford_, oldde)$ % reval reval because of a REDUCE bug for special data, % to be dropped as soon as possible if (null_ neq 0) then << % newde:=nil$ if print_ then << write "odesolve solves : "$ deprint list oldde$ write "to"$ deprint list newde$ Write "which inserted in the equation yields"$ deprint list null_$ >> >> >> >>$ if newde then <>$ depl!*:=delete(assoc(ford_,depl!*),depl!*)$ stop_let_rules(ruli)$ return if null newde then nil else <>$ newde>> end$ endmodule$ %******************************************************************** module divintegration$ %******************************************************************** % Routines to write a given expression as divergence % Author: Thomas Wolf % 1998 symbolic operator intcurrent1$ % used in conlaw2,4 symbolic procedure intcurrent1(divp,ulist,xlist,dulist, nx,eqord,densord)$ % computes a list in reverse order from which the conserved % current is computed through integration begin scalar ii,il,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11,contrace,u, nega,pii,mo,pl,nu$ %contrace:=t; xlist:=cdr xlist; ulist:=cdr ulist; nu:=length ulist; mo:=if eqord>densord then eqord-1 else densord-1$ pl:=for ii:=1:nx collect << % the components W^i il:=nil; pii:=nil; repeat << h11:=cons(ii,il); h1:=derili(h11); h11:=combi(sortli(h11)); if contrace then <>>> h10=",h10; pii:=cons(h10,pii)$ nega:=not nega; >> >>; % for each function u il:=newil(il,mo,nx); >> until null il; pii:=reval if null pii then 0 else if length pii=1 then car pii else cons('PLUS,pii); if contrace then algebraic write"pii-end=",pii; pii >>; % for all ii return cons('LIST,pl) end$ % of intcurrent1 %------------- symbolic operator intcurrent2$ % used in conlaw2,4, crdec symbolic procedure intcurrent2(divp,ulist,xlist)$ % computes the conserved current P_i from the divergence through % partial integration % potential improvement: one could substitute low order derivatives % by high order derivatives using remaining conditions and try again begin scalar h2,h3,h4,h5,h6,h7,h8,e2,e3; % repeated partial integration to compute P_i ulist :=cdr reval ulist; xlist :=cdr reval xlist; h4:=list xlist; % dequ is here a list containing only the conserved density % and flux to drop commen factors repeat << e3:=divp; h3:=car h4; % h3 is the list of variables is a spec. order h4:=cdr h4; h5:=for e2:=1:length h3 collect 0; % h5 is old list of the conserved quantities h8:=0; % h8 counts integrations wrt. all variables repeat << % integrate several times wrt. all variables h8:=h8+1; h2:=h3; % h2 is a copy of h3 h6:=nil; % h6 is new list of the conserved quantities h7:=nil; % h7 is true if any integration was possible while h2 neq nil do << % integrating wrt. each variable e2:=intpde(e3,ulist,h3,car h2,t); if null e2 then e2:=list(nil,e3) else e3:=cadr e2; if (car e2) and (not zerop car e2) then h7:=t; h6:=cons(list('PLUS,car e2,car h5),h6); h5:=cdr h5; h2:=cdr h2 >>; h5:=reverse h6; >> until (h7=nil) % no integration wrt. no variable was possible or (e3=0) % complete integration or (h8=10); % max. 10 integrations wrt. all variables >> until (e3=0) or (h4=nil); return {'LIST,reval cons('LIST, h5),e3} % end of the computation of the conserved current P % result is a {{P_i},remainder} % was successful if 0 = remainder (=e3) end$ % of intcurrent2 %------------- symbolic operator intcurrent3$ % crident symbolic procedure intcurrent3(divp,ulist,xlist)$ % computes the conserved current P_i from the divergence through % partial integration with restriction of maximal 2 terms begin scalar xl,h1,h2,h3,h4,h5,resu1,resu2,resu3,succ; % repeated partial integration to compute P_i ulist :=cdr reval ulist; xlist :=cdr reval xlist; xl:=xlist; resu1:=nil; succ:=nil; % try all possible different pairs of variables while (cdr xl) and not succ do << h1:=intpde(divp,ulist,xlist,car xl,t); if h1 and not zerop car h1 then << resu2:=cons(car h1,resu1); h2:=cdr xl; repeat << h3:=intpde(cadr h1,ulist,xlist,car h2,nil); if h3 and zerop cadr h3 then << h4:=cons(car h3,resu2); for each h5 in cdr h2 do h4:=cons(0,h4); succ:=t; resu3:= {'LIST,cons('LIST,reverse h4),0} >>; h2:=cdr h2; resu2:=cons(0,resu2) >> until succ or null h2; >>; resu1:=cons(0,resu1); xl:=cdr xl >>$ return if succ then resu3 else {'LIST,cons('LIST,cons(0,resu1)),divp} end$ % of intcurrent3 endmodule$ %******************************************************************** module quasilinpde_integration$ %******************************************************************** % Routines to solve a quasilinear first order PDE % Author: Thomas Wolf % summer 1995 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % %---------------------------- algebraic procedure select_indep_var(clist,xlist)$ begin scalar s,scal,notfound,cq,x,xx,xanz,sanz,xcop,ok; % Find the simplest non-zero element of clist notfound:=t; xcop:=xlist; while notfound and (xcop neq {}) do << x :=first xcop ; xcop :=rest xcop ; cq:=first clist; clist:=rest clist; if cq neq 0 then << xanz:=0; for each xx in xlist do if %df(cq,xx) not freeof(cq,xx) then xanz:=xanz+1; ok:=nil; if not s then ok:=t else % to guarantee s neq nil if xanz1 then if part(scal,0)=PLUS then % if possible not a sum if (part(cq,0) neq PLUS) or (length(cq)>; if scal=1 then notfound:=nil >> >>; return {s,scal} end$ % of select_indep_var %---------------------------- algebraic procedure charsyscrack(xlist,cqlist,s,scal,u,ode)$ % formulation and solution of the characteristic ODE-system begin scalar lcopy,x,cS,flist,soln,printold,timeold,facintold, adjustold,safeintold,freeintold,odesolveold, e1,e2,e3,e4,n,nmax,dff,proclistold; % formulating the ode/pde - system . lcopy := cqlist ; cS := {} ; for each x in xlist do << cq := first lcopy ; lcopy := rest lcopy ; if x neq s then << depend x,s; cS := .(scal*df(x,s)-cq,cS) >> >>; if s neq u then <> else flist:={}; for each x in xlist do if s neq x then flist:=.(x,flist); lisp << timeold := time_; time_ :=nil; facintold:=facint_; facint_:=1000; adjustold:=adjust_fnc; adjust_fnc:=t; safeintold:=safeint_; safeint_:=nil; freeintold:=freeint_; freeint_:=nil; odesolveold:=odesolve_; odesolve_:=50; proclistold:=proc_list_; proc_list_:=delete('alg_solve_single,proc_list_) >>$ % solving the odes using crack. if lisp(print_ neq nil) then lisp << write "The equivalent characteristic system:";terpri(); deprint cdr algebraic cS$ %terpri()$ write "for the functions: "; fctprint( cdr reval algebraic flist);write"."; >>; soln:=crack(cS,flist,flist,{}); lcopy:={}; for each x in soln do << e1:=first x; if (e1 neq {}) and (length e1 + length second x = length flist) then << % all remaining conditions are algebraic (non-differential) in all the % functions of flist? e2:={}; e3:={}; for each e4 in third x do if freeof(flist,e4) then e3:=e4 . e3 else e2:=e4 . e2; if (length cS) = (length e3) then << % sufficiently many integrations done for each e4 in e2 do for each e5 in e1 do if lisp(not freeof(lderiv(reval algebraic e5, reval algebraic e4, list(reval algebraic s)),'DF)) then <>; if e2 neq {} then << % It may be possible that derivatives of unsolved functions % occur in the expressions of the evaluated functions: second x nmax:=0; for each e4 in e2 do << % for each unsolved function for each e5 in second x do << % for each solved expression lisp << n:=lderiv(reval algebraic rhs e5,reval algebraic e4, list(reval algebraic s)); n:=if (car n) = nil then 0 else if (length car n) = 3 then 1 else cadddr car n >>; n:=lisp n; if n>nmax then nmax:=n; >>; if nmax>0 then << % adding further conditions e5:=e1; while freeof(first e5,e4) do e5:=rest e5; e5:=first e5; dff:=e4; for n:=1:nmax do << e5 :=df(e5,s); e1:= e5 . e1; dff:=df(dff,s); e3:=dff . e3 >> >> >>; lcopy:=cons({append(second x,e1),e3},lcopy); >> >> >> else if (first x = {}) and (length cS = length third x) then lcopy:=cons({second x,third x},lcopy) >>; lisp << time_:=timeold; facint_:=facintold; adjust_fnc:=adjustold; safeint_:=safeintold; freeint_:=freeintold; odesolve_:=odesolveold; proc_list_:=proclistold >>; return if lcopy={} then <> else s . lcopy % { {{x=..,y=..,u=..,..,0=..},{df(z,s),df(z,s,2),..,c1,c2,c3,..}},..} % df(z,s,..) only if df(z,s,..) turns up in x, y, u. .. . end$ % of charsyscrack %---------------------------- procedure charsyspsfi(xlist,cqlist,u,ode,denf); begin scalar h,s; h:=cqlist; cqlist:={}; while h neq {} do <>; cqlist:=cons(-ode*denf,cqlist); xlist:=cons(u,reverse xlist); s:=lisp gensym(); for each h in xlist do depend h,s; h:=psfi(cqlist,xlist,s); for each h in xlist do if not my_freeof(h,s) then nodepend h,s; return h end$ % of charsyspsfi %---------------------------- algebraic procedure storedepend(xlist)$ % stores the dependencies of the elements of xlist in the returned % list and clears the dependencies begin scalar q,e1,e2$ return for each e1 in xlist collect << q:=fargs e1; for each e2 in q do nodepend e1,e2; cons(e1,q)>> end$ % of storedepend %---------------------------- algebraic procedure restoredepend(prev_depend)$ % assigns the dependencies stored in the argument begin scalar q,s,x; for each s in prev_depend do <> end$ % of restoredepend %---------------------------- symbolic procedure simplifiziere(q,fl)$ begin scalar n; return if not pairp q then q else if member(car q,ONE_ARGUMENT_FUNCTIONS_) or (member(car q,{'EXPT,'QUOTIENT}) and not smemberl(fl,caddr q) ) then simplifiziere(cadr q,fl) else if car q = 'QUOTIENT and not smemberl(fl,cadr q) then simplifiziere(caddr q,fl) else << n:=ncontent(q); if n=1 then q else simplifiziere(reval list('QUOTIENT, q, reval n),fl) >> end$ %---------------------------- algebraic procedure quasilinpde(f,u,xlist); % f ... PDE, u ... unknown function, xlist ... variable list begin scalar i, q, qlist, cq, cqlist, ode, soln, tran, xcop, s, s1, x, xx, h1, h2, scal, qlin, prev_depend, tr_qlp,xlist_cp1,xlist_cp2; symbolic put('ff,'simpfn,'simpiden)$ tr_qlp:=t; if lisp print_ then write"The quasilinear PDE: 0 = ",f,"."; % changing the given pde into a quasi-linear ode . i := 0 ; ode := f; qlist := {}; cqlist:={}; for each x in xlist do <> ; lisp(depl!*:=delete(assoc(u,depl!*),depl!*))$ lisp(depl!*:=delete(assoc(mkid(u,'_),depl!*),depl!*))$ qlist := reverse qlist ; cqlist := reverse cqlist ; % checking for linearity. qlin:=t; for each cq in cqlist do for each q in qlist do if df(cq,q) neq 0 then qlin:=nil; if not qlin then return {}; % soln:=charsyspsfi(xlist,cqlist,u,ode,den f); % Determination of the independent variable for the ODEs pcopy:=cons(-ode,cqlist);xcop:=cons(u,xlist); scal:=select_indep_var(pcopy,xcop)$ s1:=first scal; prev_depend:=storedepend(xlist)$ soln:=charsyscrack(xlist,cqlist,s1,second scal,u,ode); if soln={} then << % try all other coefficients as factors repeat << repeat <> until (pcopy={}) or ((scal neq 0) and (s neq s1)); if (s neq s1) and (scal neq 0) then << if lisp print_ then lisp <>$ soln:=charsyscrack(xlist,cqlist,s,scal,u,ode) >> >> until (soln neq {}) or (xcop={}) >>; % solving for the constants(eg..c1,c2 etc.) and put them in a % linear form. % The first element of soln is the ODE-variable tran:={}; if soln neq {} then << s1:=first soln; for each s in rest soln do <>,x); lisp << x:=cdr x; xlist_cp1:=cdr xlist; xlist_cp2:=xlist_cp1; repeat << for each h1 in xlist_cp1 do if member(h1,x) then xlist_cp2:=delete(h1,xlist_cp2); if xlist_cp1 neq xlist_cp2 then << xlist_cp1:=xlist_cp2; x:=for each h1 in x collect simplifiziere(h1,xlist_cp1) >> >> until xlist_cp1=xlist_cp2; x:=cons('LIST,x); >>$ xx:=tran; while (xx neq {}) and <>; if (h1={}) and (h2={}) then nil else t >> do xx:=rest xx; if xx={} then tran:=.(x,tran); >>; for each s in xlist do if (s neq s1) and (not my_freeof(s,s1)) then nodepend s,s1 >>; for each x in xlist do depend u,x; if lisp print_ then if tran neq {} then << write"The general solution of the PDE is given through"; for each x in tran do write"0 = ", lisp( cons('ff,cdr reval algebraic x)); if length tran>1 then write"with arbitrary function(s) ff(..)." else write"with arbitrary function ff(..)." >>; % restoring the dependencies of the variables of the PDE restoredepend(prev_depend)$ return tran; end$ % of quasilinpde endmodule$ end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crintfix.red0000644000175000017500000003604611526203062024122 0ustar giovannigiovanni%******************************************************************** module intfix$ % Further fixes to the integration package. %******************************************************************** % Routines to extend the REDUCE integrator or to fix problems % Author: Francis Wright % % $Id$ % if lisp !*comp then apply1('load!-package, 'int)$ fluid '(!*depend !*nolnr !*failhard)$ % die folgende Aenderung verhindert das Erzeugen von int* ... remd('simpint!*)$ symbolic procedure simpint!* u$ begin scalar x$ return if (x := opmtch('int . u)) then simp x else simpiden('int . u) % statt else simpiden('int!* . u) end$ % ein Patch fuer das REDUCE 3.5 EZGCD %symbolic procedure simpexpt u$ % % We suppress reordering during exponent evaluation, otherwise % % internal parts (as in e^(a*b)) can have wrong order. % begin scalar expon; % expon := simpexpon carx(cdr u,'expt) where kord!*=nil; % expon := resimp expon; % We still need right order. <--- change. % return simpexpt1(car u,expon,nil) % end$ % Zum Integrieren % put('int, 'simpfn, 'SimpIntPatch)$ %algebraic << % % fuer reelle Rechnungen: % let {abs(~r)**(~n) => r**n when (fixp(n) and evenp(n))}$ % let { % int(1/~x^(~n),~x) => -x/(x^n*(n-1)) when numberp n, % ~x^(~m/~n)*~x => x**((m+n)/n) when (numberp n and numberp m), % int(~z/~y,~x) => log(y) when z = df(y,x)}$ % % if sin(!%x)**2+cos(!%x)**2 neq 1 then % let {sin(~x)**2 => 1-cos(x)**2}$ % % if cosh(!%x)**2 neq (sinh(!%x)**2 + 1) then % let {cosh(~x)**2 => (sinh(x)**2 + 1)}$ % % if sin(!%x)*tan(!%x/2)+cos(!%x) neq 1 then % let {tan(~x/2) => (1-cos(x))/sin(x)}$ % % if sin(!%x)*cot(!%x/2)-cos(!%x) neq 1 then % let {cot(~x/2) => (1+cos(x))/sin(x)}$ % % if sqrt(!%x**2-!%y**2)-sqrt(!%x-!%y)*sqrt(!%x+!%y) neq 0 then % let {sqrt(~x)*sqrt(~y) => sqrt(x*y)} %>>$ endmodule$ module dfint$ % Patch to improve differentiation, mainly of integrals. % This version specifically for use by the crack package. % Francis J. Wright , 27 December 1997 fluid '(!*fjwflag)$ !*fjwflag := t$ switch allowdfint, dfint$ % dfint OFF by default deflist('((dfint ((t (rmsubs)))) (allowdfint ((t (progn (put 'int 'dfform 'dfform_int) (rmsubs))) (nil (remprop 'int 'dfform))))), 'simpfg)$ % There is no code to reverse the df-int commutation, % so no reason to call rmsubs when the switch is turned off. !*allowdfint := t$ % allowdfint ON by default put('int, 'dfform, 'dfform_int)$ % The switch allowdfint ALLOWS differentiation under the integral sign % provided the result simplies, and should normally be on. % The switch dfint FORCES differentiation under the integral sign, % PROVIDED ALLOWDFINT IS ALSO ON, and should normally be turned on % only when required. symbolic procedure diffp(u,v); % U is a standard power, V a kernel. % Value is the standard quotient derivative of U wrt V. begin scalar n,w,x,y,z; integer m; n := cdr u; % integer power. u := car u; % main variable. if u eq v and (w := 1 ./ 1) then go to e else if atom u then go to f %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x)) % and (w := cdr x) then go to e % deriv known. % DSUBL!* not used for now. else if (not atom car u and (w:= difff(u,v))) or (car u eq '!*sq and (w:= diffsq(cadr u,v))) then go to c % extended kernel found. else if x := get(car u,'dfform) then return apply3(x,u,v,n) else if x:= get(car u,dfn_prop u) then nil else if car u eq 'plus and (w := diffsq(simp u,v)) then go to c else go to h; % unknown derivative. y := x; z := cdr u; a: w := diffsq(simp car z,v) . w; if caar w and null car y then go to h; % unknown deriv. y := cdr y; z := cdr z; if z and y then go to a else if z or y then go to h; % arguments do not match. y := reverse w; z := cdr u; w := nil ./ 1; b: % computation of kernel derivative. if caar y then w := addsq(multsq(car y,simp subla(pair(caar x,z), cdar x)), w); x := cdr x; y := cdr y; if y then go to b; c: % save calculated deriv in case it is used again. % if x := atsoc(u,dsubl!*) then go to d % else x := u . nil; % dsubl!* := x . dsubl!*; % d: rplacd(x,xadd(v . w,cdr x,t)); e: % allowance for power. % first check to see if kernel has weight. if (x := atsoc(u,wtl!*)) then w := multpq('k!* .** (-cdr x),w); m := n-1; % Evaluation is far more efficient if results are rationalized. return rationalizesq if n=1 then w else if flagp(dmode!*,'convert) and null(n := int!-equiv!-chk apply1(get(dmode!*,'i2d),n)) then nil ./ 1 else multsq(!*t2q((u .** m) .* n),w); f: % Check for possible unused substitution rule. if not depends(u,v) and (not (x:= atsoc(u,powlis!*)) or not depends(cadddr x,v)) and null !*depend then return nil ./ 1; w := list('df,u,v); w := if x := opmtch w then simp x else mksq(w,1); go to e; h: % Final check for possible kernel deriv. if car u eq 'df % multiple derivative then if depends(cadr u,v) % FJW - my version of above test was simply as follows. Surely, inner % derivative will already have simplied to 0 unless v depends on A! and not(cadr u eq v) % (df (df v A) v) ==> 0 %% and not(cadr u eq v and not depends(v,caddr u)) %% % (df (df v A) v) ==> 0 unless v depends on A. then < (df (df (int F x) v) A) ? % Commute the derivatives to differentiate the integral? if caddr cadr u eq v then % Evaluating (df u v) where u = (df (int F v) A) % Just return (df F A) - derivative absorbed << w := 'df . cadr cadr u . cddr u; go to j >> else if !*allowdfint and % Evaluating (df u v) where u = (df (int F x) A) % (If dfint is also on then this will not arise!) % Commute only if the result simplifies: not_df_p(w := diffsq(simp!* cadr cadr u, v)) then << % Generally must re-evaluate the integral (carefully!) % FJW. Bug fix! % w := aeval{'int, mk!*sq w, caddr cadr u} . cddr u; w := 'df . reval{'int, mk!*sq w, caddr cadr u} . cddr u; go to j >>; % derivative absorbed if (x := find_sub_df(w:= cadr u . derad(v,cddr u), get('df,'kvalue))) then <> else w := 'df . w >> else if null !*depend then return nil ./ 1 else w := {'df,u,v} else w := {'df,u,v}; j: if (x := opmtch w) then w := simp x else if not depends(u,v) and null !*depend then return nil ./ 1 else w := mksq(w,1); go to e end$ % Author: Francis J. Wright % Last revised: 27 December 1997 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic procedure dfform_int(u, v, n); % Simplify a SINGLE derivative of an integral. % u = '(int y x) [as main variable of SQ form] % v = kernel % n = integer power % Return SQ form of df(u**n, v) = n*u**(n-1)*df(u, v) % This routine is called by diffp via the hook % "if x := get(car u,'dfform) then return apply3(x,u,v,n)". % It does not necessarily need to use this hook, but it needs to be % called as an alternative to diffp so that the linearity of % differentiation has already been applied. begin scalar result, x, y; y := simp!* cadr u; % SQ form integrand x := caddr u; % kernel result := if v eq x then y % df(int(y,x), x) -> y replacing the let rule in INT.RED else if not !*intflag!* and % not in the integrator % If used in the integrator it can cause infinite loops, % e.g. in df(int(int(f,x),y),x) and df(int(int(f,x),y),y) !*allowdfint and % must be on for dfint to work << y := diffsq(y, v); !*dfint or not_df_p y >> % it has simplified then simp{'int, mk!*sq y, x} % MUST re-simplify it!!! % i.e. differentiate under the integral sign % df(int(y, x), v) -> int(df(y, v), x). % (Perhaps I should use prepsq - kernels are normally true prefix?) else !*kk2q{'df, u, v}; % remain unchanged if not(n eq 1) then result := multsq( (((u .** (n-1)) .* n) .+ nil) ./ 1, result); return result end$ symbolic procedure not_df_p y; % True if the SQ form y is not a df kernel. not(denr y eq 1 and not domainp (y := numr y) and eqcar(mvar y, 'df))$ endmodule$ module intdf$ % Patch to simpint1 in src/int/trans/driver.red to provide better % simplification of integrals of derivatives. (I think -- hope -- % this is the right place to hook this patch into the integrator!) % This patch was motivated by the needs of crack. % F.J.Wright@Maths.QMW.ac.uk, 31 December 1997 %% load_package int$ %apply1('load!-package, 'int)$ % not at compile time! switch PartialIntDf$ % off by default deflist('((PartialIntDf ((t (rmsubs))))), 'simpfg)$ % If the switch PartialIntDf is turned on then integration by parts is % performed if the result simplifies in the sense that it integrates a % symbolic derivative and does not introduce new symbolic derivatives. % However, because the initial integral contains an unevaluated % derivative then the result must still contain an unevaluated % integral. symbolic procedure simpint1 u; % Varstack* rebound, since FORMLNR use can create recursive % evaluations. (E.g., with int(cos(x)/x**2,x)). begin scalar !*keepsqrts,v,varstack!*; u := 'int . prepsq car u . cdr u; if (v := formlnr u) neq u then if !*nolnr then <> else <>; % FJW: At this point linearity has been applied. return if (v := opmtch u) then simp v % FJW: Check for a directly integrable derivative: else if (v := NestedIntDf(cadr u, caddr u)) then mksq(v,1) else if !*failhard then rerror(int,4,"FAILHARD switch set") % FJW: Integrate by parts if the result simplifies: else if !*PartialIntDf and (v := PartialIntDf(cadr u, caddr u)) then mksq(v,1) else mksq(u,1) end$ symbolic procedure NestedIntDf(y, x); %% int( ... df(f,A,x,B) ..., x) -> ... df(f,A,B) ... %% Find a df(f,A,x,B) among possibly nested int's and df's within %% the integrand y in int(y,x), and return the whole structure y %% but with the derivative integrated; otherwise return nil. %% [A,B are arbitrary sequences of kernels.] not atom y and begin scalar car_y, nested; return if (car_y := car y) eq 'df and memq(x, cddr y) then %% int( df(f, A, x, B), x ) -> df(f, A, B) 'df . cadr y . delete(x, cddr y) %% use delete for portability! %% deleq is defined in CSL, delq in PSL -- oops! else if memq(car_y, '(df int)) and (nested := NestedIntDf(cadr y, x)) then %% int( df(int(df(f, A, x, B), c), C), x ) -> %% df(int(df(f, A, B), c), C) %% int( int(df(f, A, x, B), c), x ) -> %% int(df(f, A, B), c) car_y . nested . cddr y end$ symbolic procedure PartialIntDf(y, x); %% int(u(x)*df(v(x),x), x) -> u(x)*v(x) - int(df(u(x),x)*v(x), x) %% Integrate by parts if the resulting integral simplifies [to %% avoid infinite loops], which means that df(u(x),x) may not %% contain any unevaluated derivatives; otherwise return nil. not atom y and begin scalar denlist, facs, df, u, v; if car y eq 'quotient then << denlist := cddr y; % y := numerator: if atom(y := cadr y) then return % no derivative >>; % y := list of factors: if car y eq 'times then y := cdr y else if denlist then y := y . nil else return; % Find an integrable derivative among the factors: facs := y; while facs and not (eqcar(df := car facs, 'df) and memq(x, cddr df)) do facs := cdr facs; if null facs then return; % no integrable derivative % Construct u(x) and v(x) [v(x) may still be a derivative]: u := delete(df, y); % list of factors u := if null u then 1 else if cdr u then 'times . u else car u; if denlist then u := 'quotient . u . denlist; v := cadr df; % kernel being differentiated if (df := delete(x, cddr df)) then v := 'df . v . df; % Check that df(u(x),x) simplifies: if smemq('df, df := reval {'df,u,x}) then return; return reval {'difference, {'times,u,v}, {'int, {'times, df, v}, x}} end$ endmodule$ end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/liepde.tex0000644000175000017500000003072711526203062023564 0ustar giovannigiovanni\documentclass[12pt]{article} %Sets size of page and margins \oddsidemargin 1mm \evensidemargin 1mm %\topmargin -25mm % \headheight 0pt \headsep 0pt \textwidth 16cm \title{Manual for LIEPDE} \author{Thomas Wolf \\ Department of Mathematics \\ Brock University \\ St.Catharines \\ Ontario, Canada L2S 3A1 \\ twolf@brocku.ca} \begin{document} \maketitle \section{Purpose} The procedure {\tt LIEPDE} computes infinitesimal symmetries for a given single/system of differential equation(s) (ODEs or PDEs) %\begin{equation} % u^{\alpha}_J = w^{\alpha}(x,u^{\beta},...,u^{\beta}_K,...) \label{a1} %\end{equation} \begin{equation} H_A = 0. \label{PDEs} \end{equation} To obey symmetries, differential equations (\ref{PDEs}) for unknown functions $u^\alpha$ of independent variables $x^i$ must be form-invariant under infinitesimal transformations \begin{equation} \tilde{x}^i = x^i + \varepsilon \xi^i, \;\; \;\;\; \tilde{u}^\alpha = u^\alpha + \varepsilon \eta^\alpha \label{tran} \end{equation} of first order in $\varepsilon.$ To transform the equations (\ref{PDEs}) by (\ref{tran}), derivatives of $u^\alpha$ must be transformed, i.e. the part linear in $\varepsilon$ must be determined. The corresponding formulas are (see e.g. \cite{Olv}, \cite{Step}) \begin{eqnarray} \tilde{u}^\alpha_{j_1\ldots j_k} & = & u^\alpha_{j_1\ldots j_k} + \varepsilon \eta^\alpha_{j_1\ldots j_k} + O(\varepsilon^2) \nonumber \\ \vspace{3mm} \eta^\alpha_{j_1\ldots j_{k-1}j_k} & = & \frac{D \eta^\alpha_{j_1\ldots j_{k-1}}}{D x^k} - u^\alpha_{ij_1\ldots j_{k-1}}\frac{D \xi^i}{D x^k} \label{recur} \end{eqnarray} and the complete symmetry condition then takes the form \begin{eqnarray} X H_A & = & 0 \;\; \;\pmod{ H_A = 0} \label{sbed1} \\ X & = & \xi^i \frac{\partial}{\partial x^i} + \eta^\alpha \frac{\partial}{\partial u^\alpha} + \eta^\alpha_m \frac{\partial}{\partial u^\alpha_m} + \eta^\alpha_{mn} \frac{\partial}{\partial u^\alpha_{mn}} + \ldots + \eta^\alpha_{mn\ldots p} \frac{\partial}{\partial u^\alpha_{mn\ldots p}} , \label{sbed2} \end{eqnarray} where mod $H_A = 0$ means that the original PDE-system is used to replace some partial derivatives of $u^\alpha$ to reduce the number of independent variables, because the symmetry condition (\ref{sbed1}) must be fulfilled identically in $x^i, u^\alpha$ and all partial derivatives of $u^\alpha.$ For point symmetries $\xi^i, \eta^\alpha$ are functions of $x^j, u^\beta$ only. For more general higher order symmetries $\xi^i, \eta^\alpha$ may depend on derivatives of $u^\beta$. For those symmetries one can without loss of generality set $\xi^i=0$ due to a symmetry of the symmetry conditions on the manifold of solutions of $H_A=0$ themselves (e.g.\ $\S$5.1 in \cite{Olv}). The shifted generators \[\tilde{\xi^i} = \xi^i + h^i, \; \; \; \; \tilde{\eta^{\alpha}} = \eta^{\alpha} + h^i u^{\alpha},_i\] with arbitrary $h^i=h^i(x^j, u^{\beta},\ldots, u^{\beta}_K)$ represent generators of the same symmetry. \section{Syntax of {\tt LIEPDE}} The procedure {\tt LIEPDE} is called through \\ {\tt LIEPDE({\it problem,symtype,flist,inequ}); } \\ All parameters are lists. \vspace{6pt} \\ The first parameter specifies the DEs to be investigated: \\ {\it problem} has the form \{{\it equations, ulist, xlist}\} where \begin{tabbing} \hspace{0.5cm} {\it equations } \= is a list of equations, each has the form {\tt df(ui,..)=...} where \\ \> the LHS (left hand side) {\tt df(ui,..)} is selected such that \\ \> - The RHS (right h.s.) of an equations must not include \\ \>$\;\,$ the derivative on the LHS nor a derivative of it. \\ \> - Neither the LHS nor any derivative of it of any equation \\ \>$\;\,$ may occur in any other equation.\\ \> - Each of the unknown functions occurs on the LHS of \\ \>$\;\,$ exactly one equation. \\ \hspace{0.5cm} {\it ulist} \> is a list of function names, which can be chosen freely \\ \hspace{0.5cm} {\it xlist} \> is a list of variable names, which can be chosen freely \end{tabbing} Equations can be given as a list of single differential expressions and then the program will try to bring them into the `solved form' {\tt df(ui,..)=...} automatically. If equations are given in the solved form then the above conditions are checked and execution is stopped it they are not satisfied. An easy way to get the equations in the desired form is to use \\ \verb+ FIRST SOLVE({+{\it eq1,eq2,}...\verb+},{+{\it one highest derivative for each function u}\verb+})+ \\ (see the example of the Karpman equations in {\tt LIEPDE.TST}). The example of the Burgers equation in {\tt LIEPDE.TST} demonstrates that the number of symmetries for a given maximal order of the infinitesimal generators depends on the derivative chosen for the LHS. The second parameter {\it symtype} of {\tt LIEPDE} is a list $\{\;\}$ that specifies the symmetry to be calculated. {\it symtype} can have the following values and meanings: \begin{tabbing} \verb+{"point"} + \= Point symmetries with $\xi^i=\xi^i(x^j,u^{\beta}),\; \eta^{\alpha}=\eta^{\alpha}(x^j,u^{\beta})$ are \\ \> determined.\\ \verb+{"contact"}+ \> Contact symmetries with $\xi^i=0, \; \eta=\eta(x^j,u,u_k)$ are \\ \> determined $(u_k = \partial u/\partial x^k)$, which is only applicable if a \\ \> single equation (\ref{PDEs}) with an order $>1$ for a single function \\ \> $u$ is to be investigated. (The {\it symtype} \verb+{"contact"}+ \\ \> is equivalent to \verb+{"general",1}+ (see below) apart from \\ \> the additional checks done for \verb+{"contact"}+.)\\ \verb+{"general"+,{\it order}\verb+}+ \> where {\it order} is an integer $>0$. Generalized symmetries $\xi^i=0,$ \\ \> $\eta^{\alpha}=\eta^{\alpha}(x^j,u^{\beta},\ldots,u^{\beta}_K)$ of a specified order are determined \\ \> (where $_K$ is a multiple index representing {\it order} many indices.) \\ \> NOTE: Characteristic functions of generalized symmetries \\ \> ($= \eta^{\alpha}$ if $\xi^i=0$) are equivalent if they are equal on\\ \> the solution manifold. Therefore, all dependences of\\ \> characteristic functions on the substituted derivatives \\ \> and their derivatives are dropped. For example, if the heat \\ \> equation is given as $u_t=u_{xx}$ (i.e.\ $u_t$ is substituted by $u_{xx}$) \\ \> then \verb+{"general",2}+ would not include characteristic \\ \> functions depending on $u_{tx}$ or $u_{xxx}$. \\ \> THEREFORE: \\ \> If you want to find {\it all} symmetries up to a given order then either \\ \> - avoid using $H_A=0$ to substitute lower order \\ \> $\;\,$derivatives by expressions involving higher derivatives, or \\ \> - increase the order specified in {\it symtype}. \\ \> For an illustration of this effect see the two symmetry \\ \> determinations of the Burgers equation in the file \\ \> {\tt LIEPDE.TST}. \\ \verb+{xi!_+{\it x1}\verb+ =...,..., + \> \\ \verb+ eta!_+{\it u1}\verb+=...,...}+ \> It is possible to specify an ansatz for the symmetry. Such \\ \> an ansatz must specify all $\xi^i$ for all independent variables and \\ \> all $\eta^{\alpha}$ for all dependent variables in terms of differential \\ \> expressions which may involve unknown functions/constants. \\ \> The dependences of the unknown functions have to be declared \\ \> in advance by using the {\tt DEPEND} command. For example, \\ \> \verb+ DEPEND f, t, x, u$ + \\ \> specifies $f$ to be a function of $t,x,u$. If one wants to have $f$ as \\ \> a function of derivatives of $u(t,x)$, say $f$ depending on $u_{txx}$, \\ \> then one \underline{{\it cannot}} write \\ \> \verb+ DEPEND f, df(u,t,x,2)$ + \\ \> but instead must write \\ \> \verb+ DEPEND f, u!`1!`2!`2$ + \\ \> assuming {\it xlist} has been specified as \verb+ {t,x}+. Because $t$ is the \\ \> first variable and $x$ is the second variable in {\it xlist} and $u$ is \\ \> differentiated oncs wrt.\ $t$ and twice wrt.\ $x$ we therefore \\ \> use \verb+ u!`1!`2!`2+. The character {\tt !} is the escape character \\ \> to allow special characters like ` to occur in an identifier. \\ \> \hspace{4mm} For generalized symmetries one usually sets all $\xi^i=0$.\\ \> Then the $\eta^{\alpha}$ are equal to the characteristic functions. \end{tabbing} \noindent The third parameter {\it flist} of {\tt LIEPDE} is a list $\{\;\}$ that includes \begin{itemize} \item all parameters and functions in the equations which are to be determined such that symmetries exist (if any such parameters/functions are specified in {\it flist} then the symmetry conditions formulated in {\tt LIEPDE} become non-linear conditions which may be much harder for {\tt CRACK} to solve with many cases and subcases to be considered.) \item all unknown functions and constants in the ansatz \verb+xi!_..+ and \verb+eta!_..+ if that has been specified in {\it symtype}. \end{itemize} \noindent The fourth parameter {\it inequ} of {\tt LIEPDE} is a list $\{\;\}$ that includes all non-vanishing expressions which represent inequalities for the functions in flist. The procedure {\tt LIEPDE} returns a list containing a list of unsolved conditions if any, a list containing the general solution for $\xi^i, \eta^{\alpha}$ and a list of constants and functions appearing in the general solution or in the remaining unsolved conditions. \section{Flags, parameters} Two flags specify whether symmetry conditions are formulated and solved in stages or in one go. If the equation to be investigated is of higher than first order and point symmetries are investigated then {\tt LIEPDE} allows a set of preliminary conditions to be formulated and solved before formulating and solving the full set of conditions for this equation (more details in \cite{Step}, \cite{Wo}). This successive execution is enabled by setting \\ \verb+ LISP(PRELIM_:=t)$+. \\ The default value is \\ \verb+ LISP(PRELIM_:=NIL)$+. \\ If the preliminary conditions are easy to solve completely then it is advantageous to formulate and solve them first, otherwise the formulation of the complete more overdetermined condition is better. Examples for both cases are given together with comments in {\tt LIEPDE.TST}. If symmetries of a system of equations are to be investigated then with the setting \\ \verb+LISP(INDIVIDUAL_:=t)$+ conditions for the equations are formulated and solved individually which provides a speed up if symmetry conditions are very overdetermined. The default value is \\ \verb+ LISP(INDIVIDUAL_:=NIL)$+. \\ By default {\tt LIEPDE} computes $\xi$ and $\eta$ for each symmetry. If a prolongation of the symmetry vector shall be calculated then the order of this prolongation can be specified by the setting \verb+LISP(PROLONG_ORDER:= ...)$+. \\ Flags that control the solution of the symmetry conditions by {\tt CRACK} are displayed with \verb+CRACKHELP()$+. Among them are: \\ \verb+ LISP (PRINT_:= NIL/0/1/ ...)$+ \\ \verb+PRINT_=NIL+ suppresses all CRACK output, for \verb+PRINT_=n+ ($n$ a positive integer) {\tt CRACK} prints only equations with at most $n$ factors in their terms, and %\verb+ LISP (LOGOPRINT_:=t/nil)$+ \\ %to print/not print a logo at the start of {\tt LIEPDE} \\ \verb+ OFF BATCH_MODE$+ enables the interactive solution of the system of conditions with {\tt CRACK}. \section{Requirements} {\tt REDUCE 3.6} and the files {\tt CRACK.RED, LIEPDE.RED} and all files {\tt CR*.RED} which are read in from {\tt CRACK.RED}. \\ \verb+ IN "crack.red","liepde.red"$+ \\ (and appropriate paths) or compilation with \\ \verb+ FASLOUT "crack"$+ \\ \verb+ IN "crack.red"$+ \\ \verb+ FASLEND$+ \\ \verb+ FASLOUT "liepde"$+ \\ \verb+ IN "liepde.red"$+ \\ \verb+ FASLEND$+ \\ \verb+ BYE$+ \\ and loading afterwards with \verb+ LOAD_PACKAGE crack,liepde$.+ \begin{thebibliography}{99} \bibitem{Olv} P.J. Olver, Applications of Lie Groups to Differential Equations, Springer-Verlag, New York (1986). \bibitem{Step} H. Stephani, Differential Equations, Their solution using symmetries, Ed. M.A.H. MacCallum, Cambridge Univ. Press (1989). \bibitem{Wo} T. Wolf, An efficiency improved program LIEPDE for determining Lie-symmetries of PDEs, Proceedings of ``Modern Group Analysis: advanced analytical and computational methods in mathematical physics'', Acireale, Italy, October 1992, Kluwer Academic Publishers, pP 377-385, 1993. \end{thebibliography} \end{document} mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/conlaw4.red0000644000175000017500000005325011526203062023637 0ustar giovannigiovanni % CONLAW version 4, to calculate conservation laws of systems % of PDEs by calculating characteristic functions % by Thomas Wolf, June 1999 %---------------------------------------------------------------------- % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % symbolic fluid '(print_ logoprint_ potint_ facint_ adjust_fnc)$ %------------- symbolic procedure newil(il,mo,nx)$ if (null il) or (length il>$ %------------- symbolic procedure sortli(l)$ % sort a list of numbers begin scalar l1,l2,l3,m,n$ return if null l then nil else << n:=car l$ l2:=list car l$ l:=cdr l$ while l do << m:=car l$ if m>n then l1:=cons(car l,l1) else if m>$ append(sortli(l1),append(l2,sortli(l3))) >> end$ %------------- %symbolic operator combi$ symbolic procedure combi(ilist)$ % ilist is a list of indexes (of variables of a partial derivative) % and returns length!/k1!/k2!../ki! where kj! is the multiplicity of j. begin integer n0,n1,n2,n3; n1:=1; % ilist:=cdr ilist; while ilist do <> else <>; ilist:=cdr ilist>>; return n1 end$ %------------- symbolic procedure derili(il)$ % make a derivative index list from a list of numbers if null il then nil else begin scalar h1,h2,h3$ h1:=sortli(il); while h1 do << h2:=reval algebraic mkid(!`,lisp car h1); h3:=if h3 then mkid(h2,h3) else h2; h1:=cdr h1 >>; return h3 end$ %------------- algebraic procedure conlaw4(problem,runmode)$ begin scalar contrace,eqlist,ulist,xlist,dequ,cllist,divlist, sb,densord,flist,eqord,maxord,dulist,revdulist,vl,expl, deplist,e1,e2,e3,n,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10,h11, condi,soln,potold,adjustold,udens,gensepold, inequ0,inequ,logoold,treqlist,fl,facold,u,nodep,cpu, gc,cpustart,gcstart,nontriv,cf0,rtnlist,paralist,solns, found,clcopy,extraline,nondiv,nx,nde,nonconstc, mindensord,mindensord0,maxdensord,rules$ backup_reduce_flags()$ lisp <>; cpustart:=lisp time()$ gcstart:=lisp gctime()$ % contrace:=t; %--- extracting input data eqlist:= reverse maklist first problem; ulist := maklist second problem; xlist := maklist third problem; nx:=length xlist; nde:=length eqlist; if contrace then write"eqlist=",eqlist, " ulist=",ulist," xlist=",xlist; mindensord:=part(runmode,1)$ maxdensord:=part(runmode,2)$ expl :=part(runmode,3)$ flist :=part(runmode,4)$ inequ0 :=part(runmode,5)$ problem:=runmode:=0; %--- initial printout lisp(if logoprint_ then <> else terpri()); if nde = 1 then write "The DE under investigation is :" else write "The DEs under investigation are :"; for each e1 in reverse eqlist do write e1; lisp<>$ write"======================================================"$ %--- nodep is a list of derivatives the Q do not depend on nodep:=first lhsli(eqlist)$ %--- Here comes a test that lhs's are properly chosen chksub(eqlist,ulist)$ %--- Checking whether an ansatz for characteristic functions %--- has been made, then denominator of equations is not dropped for n:=1:nde do if not lisp(null get(mkid('q_,n),'avalue)) then cf0:=t; eqlist:=reverse for each e1 in eqlist collect if part(e1,0)=EQUAL then if cf0 then lhs e1 - rhs e1 else num(lhs e1 - rhs e1) else if cf0 then e1 else num e1; if contrace then write"ulist=",ulist," eqlist=",eqlist; %--- initializations to be done only once rtnlist:={}; nondiv:=lisp intern gensym(); % as a marker if p-computation was not succ. %------ the list of parameters of the equation to be determined paralist:={}; for each e1 in flist do if not freeof(eqlist,e1) then paralist:=cons(e1,paralist); %------ determination of the order of the input equations eqord:=0; mindensord0:=mindensord; for each e1 in eqlist do for each e2 in ulist do << h1:=totdeg(e1,e2); if h1>eqord then eqord:=h1 >>; for n:=1:nde do << h1:=mkid(q_,n); if not lisp(null get(mkid('q_,n),'avalue)) then << for each e2 in ulist do << h2:=totdeg(h1,e2); if h2>eqord then eqord:=h2; if h2>mindensord then mindensord:=h2 >>; cf0:=t; >> >>; if contrace then write"eqord=",eqord; if maxdensord> else lisp<< write"Currently conservation laws with characteristic"; terpri(); write"function(s) of order ",densord," are determined"; terpri(); write"======================================================"$ >>; %--- repeated initializations %--- maxord is maximal derivative in condition maxord:=eqord % from the total derivatives + 1 % for safety + if eqord>densord then eqord else densord$ %######## possibly to be increased due to substitutions if contrace then write"maxord=",maxord; if {}=fargs first ulist then for each e1 in ulist do depnd(e1,{xlist}); sb:=subdif1(xlist,ulist,maxord)$ nodepnd ulist; if contrace then write"sb=",sb; dulist:=ulist . reverse for each e1 in sb collect for each e2 in e1 collect rhs e2; sb:=0; revdulist:=reverse dulist; % dulist with decreasing order udens:=part(dulist,densord+1); % derivatives of order densord vl:=for each e1 in dulist join e1; if contrace then write"vl=",vl," udens=",udens; if not flist then fl:={} else fl:=flist; %--- initializing characteristic functions cf, the list of functions fl deplist:=lisp(cons('LIST,setdiff(cdr ulist,cdr nodep))) . for n:=1:densord collect listdifdif2(nodep,part(dulist,n+1)); if expl then deplist:=xlist . deplist; deplist:=reverse deplist; cf:={}; for n:=1:nde do << h1:=mkid(q_,n); if lisp(null get(mkid('q_,n),'avalue)) then << nodepnd({h1}); depnd(h1, deplist); fl:=cons(h1,fl); >>; cf:=cons(h1,cf); >>; cf:=reverse cf; if contrace then write"fl=",fl; if contrace then lisp (write" depl*=",depl!*); %--- generation of the conditions condi:={}; for each u in ulist do << if contrace then write"function=",u; h1:=treqlist; h2:=cf; h3:=0; while h1 neq {} do << % sum over all equations if contrace then write"equation :",first h1; for each e1 in vl do % sum over u and all its derivatives if lisp(reval algebraic(u) = car combidif algebraic(e1)) then << % for u and all its derivatives % e2:=df(first h1, e1); % in CONLAW2 e2:=df(first(h2)*first(h1), e1); if e2 neq 0 then << if contrace then write"e1=",e1; % dequ:=first h2 * e2; % in CONLAW2 dequ:=e2; e2:=1; for each e3 in lisp cons('LIST,cdr combidif(algebraic e1)) do <> >>; dequ:=0; % to compute rhs h2:=treqlist; % " if paralist then h2:=sub(second soln,h2); % " if contrace then write"h2=",h2; % " nontriv:=nil; h3:=for each e2 in cfcopy collect << e3:=for each h4 in e1 sum fdepterms(e2,h4); dequ:=dequ+e3*first h2; h2:=rest h2; % computes rhs if e3 neq 0 then nontriv:=t; e3 >>; if nontriv then << found:=t; cllist:=cons(<>$ if condi neq {} then << write"There are remaining conditions: ", condi; lisp << write"for the functions: "; fctprint cdr reval algebraic fl;terpri(); write"Corresponding CLs might not be shown below as they"; terpri()$write"could be of too low order.";terpri()>>; extraline:=t; >>; if extraline then lisp << write"======================================================"$ terpri() >>; %--- Dropping conservation laws of too low order if (densord > 0) and ((cf0=nil) or (mindensord0 neq 0)) then << h1:={}; h2:={}; for each e1 in cllist do << h5:=udens; while (h5 neq {}) and freeof(e1,first h5) do h5:=rest h5; if h5 neq {} then << h1:=cons(e1,h1); h2:=cons(first divlist,h2) >>; divlist:=rest divlist; >>; cllist:=h1; divlist:=h2 >>; if contrace then write"cllist=",cllist; if cllist neq {} then << %--- Below h1 is the list of W^i in the Anco/Bluman formula h1:=for e1:=1:(length cllist) collect intcurrent1(part(divlist,e1),ulist,xlist,dulist,nx, eqord,densord); %--- Backsubstitution of e.g. u`1`1 --> df(u,x,2) for each e1 in ulist do depnd(e1,{xlist}); on evallhseqp; sb:=subdif1(xlist,ulist,maxord)$ sb:=for each e1 in sb join for each e2 in e1 collect(rhs e2 = lhs e2); off evallhseqp; cllist:=sub(sb,cllist); h1:=sub(sb,h1); if not lisp(freeof(h1,'SUB)) then h1:={} else << %--- lambda integration of h1 to compute P_i h2:=lisp intern gensym()$ h10:=ulist; while h10 neq {} do if not lisp(freeof(h1,'SUB)) then h10:={} else << e1:=first h10; h10:=rest h10; h1:=sub(e1=h2*e1,h1) >>; if not lisp(freeof(h1,'SUB)) then h1:={} else h1:=for each e1 in h1 collect << % i.e. for each cl h10:=sub(sb,first divlist); divlist:=rest divlist; % at first try direct integration to compute p h9:=intcurrent2(h10,append(nonconstc,ulist),xlist); if second h9 = 0 then h9:=first h9 else << % no success --> use lambda-integration h9:=nondiv; h8:=t; % whether intcurrent1 is still ok %--- at first the term h10 = T^i/x^i in conca.tex for each e2 in ulist do << if h8 then h10:=err_catch_sub(e2,0,h10); if h10 eq nil then h8:=nil >>$ if contrace then write"h10-1=",h10$ if h8 and (h10 neq 0) then << for each e2 in xlist do << if h8 then h10:=err_catch_sub(e2,h2*e2,h10); if h10 eq nil then h8:=nil >>$ if h8 then << if contrace then write"h10-2=",h10$ %--- the following is to catch errors in: %--- int(h10*h2**(nx-1),h2) h10:=if not lisp freeof(h10,'SUB) then nil else err_catch_int(h10*h2**(nx-1),h2)$ if contrace then write"h10-3=",h10$ if h10 eq nil then h6:=nil else %--- the following is to catch errors in: %--- sub(h2=1,h10)-sub(h2=0,h10) h6:=err_catch_sub(h2,1,h10); if contrace then write"h6=",h6$ if h6 eq nil then h7:=nil else h7:=err_catch_sub(h2,0,h10); if contrace then write"h7=",h7$ if h7 eq nil then h8:=nil else h10:=h6-h7 >> >>$ if contrace then write"h10-4=",h10$ h4:={}; % h4 becomes the inverse list of P^i h11:=0; while h8 and (e1 neq {}) do << h11:=h11+1; e2:=first e1; e1:=rest e1; if contrace then write"e2=",e2$ h3:=err_catch_int(e2/h2,h2)$ if contrace then write"h3-1=",h3$ %--- the following is to catch errors in: %--- sub(h2=1,h3)-sub(h2=0,h3) h6:=err_catch_sub(h2,1,h3); if h6 eq nil then h7:=nil else h7:=err_catch_sub(h2,0,h3); if h7 eq nil then h8:=nil else h4:=cons(h6-h7+h10*part(xlist,h11),h4) >>; if h8 then h9:=reverse h4 >>; h9 >> >>; if contrace then write"h1-1=",h1$ if h1={} then << lisp << write"The conserved quantities could not be found."$ terpri() >>$ if condi neq {} then lisp << write"For that the remaining conditions should be solved."; terpri() >>; lisp << write"The adjoined symmetries are:"$terpri() >>$ for each e1 in cllist do write e1$ >>$ if contrace then << write"h1=",h1;write"cllist=",cllist;write"eqlist=",eqlist >>; while h1 neq {} do << h2:=first h1; h3:=first cllist; rtnlist:=cons({h3,h2},rtnlist); %--- conditions on parameters if paralist neq {} then for each e2 in second soln do if not freeof(paralist,lhs e2) then <>$ %--- the conservation laws %--- Test whether actually only an adjoint symmetry has been %--- computed and not a conservation law h4:=eqlist; if paralist neq {} then h4:=sub(second soln,h4); h8:=0; if h2 neq nondiv then << h5:=h4; for each e1 in h3 do << h8:=h8 + e1*(first h5)$ h5:=rest h5 >>$ for e1:=1:nx do << h8:=h8-df(part(h2,e1),part(xlist,e1))$ % for test purposes >>; if h8 neq 0 then h2:=nondiv >>; write"Conservation law:"; if h2 neq nondiv then << if nx=2 then h2:=first simppl({h2},ulist,first xlist,second xlist)$ print_claw(h4,h3,h2,xlist)$ %--- factoring out diff operators? h6:={}; for each h5 in nonconstc do if not freeof(h3,h5) then h6:=cons(h5,h6); if h6 neq {} then partintdf(h4,h3,h2,xlist,h6,vl,sb) >> else << while h3 neq {} do << if length h3 < length first cllist then write "+"$ write"(",first h3,") * (",first h4,")"$ h3:=rest h3; h4:=rest h4 >>$ lisp << write"should be a divergence but the program was"$ terpri()$ write"not able to find the conserved current."$ terpri()$ >> >>$ h1:=rest h1; cllist:=rest cllist; write"======================================================"$ >>$ >>; % if cllist neq {} then << nodepnd(ulist); >>; % while solns neq {} do << if found=nil then << write"There is no conservation law of this order."; write"======================================================"$ >> >>; % for densord:=mindensord:maxdensord if fargs first ulist = {} then for each e1 in ulist do depnd(e1,{xlist}); if lisp(!*time) then write "time to run conlaw4: ", lisp time() - cpustart, " ms GC time : ", lisp gctime() - gcstart," ms"$ lisp <>; recover_reduce_flags()$ return rtnlist end$ % of conlaw4 end$ mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crutil.red0000644000175000017500000037775011526203062023610 0ustar giovannigiovanni%******************************************************************** module utilities$ %******************************************************************** % Routines for finding leading derivatives and others % Author: Andreas Brand 1990 1994 % Thomas Wolf since 1994 % Redistribution and use in source and binary forms, with or without % modification, are permitted provided that the following conditions are met: % % * Redistributions of source code must retain the relevant copyright % notice, this list of conditions and the following disclaimer. % * Redistributions in binary form must reproduce the above copyright % notice, this list of conditions and the following disclaimer in the % documentation and/or other materials provided with the distribution. % % THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" % AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, % THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR % PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR % CONTRIBUTORS % BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR % CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF % SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS % INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN % CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) % ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE % POSSIBILITY OF SUCH DAMAGE. % %%%%%%%%%%%%%%%%%%%%%%%%% % properties of pde's % %%%%%%%%%%%%%%%%%%%%%%%%% symbolic procedure drop_dec_with(de1,de2,rl)$ % drop de1 from the 'dec_with or 'dec_with_rl list of de2 % currently for all orderings begin scalar a,b,c$ a:=if rl then get(de2,'dec_with_rl) else get(de2,'dec_with)$ for each b in a do << % for each ordering b b:=delete(de1,b); if length b>1 then c:=cons(b,c); >>; if rl then put(de2,'dec_with_rl,c) else put(de2,'dec_with ,c) end$ symbolic procedure add_dec_with(ordering,de1,de2,rl)$ % add (ordering de1) to 'dec_with or 'dec_with_rl of de2 begin scalar a,b$ a:=if rl then get(de2,'dec_with_rl) else get(de2,'dec_with)$ b:=assoc(ordering,a)$ a:=delete(b,a)$ if b then b:=cons(ordering,cons(de1,cdr b)) else b:=list(ordering,de1)$ if rl then put(de2,'dec_with_rl,cons(b,a)) else put(de2,'dec_with ,cons(b,a))$ end$ symbolic procedure add_both_dec_with(ordering,de1,de2,rl)$ % add (ordering de1) to 'dec_with or 'dec_with_rl of de2 and % add (ordering de2) to 'dec_with or 'dec_with_rl of de1 begin add_dec_with(ordering,de1,de2,rl)$ add_dec_with(ordering,de2,de1,rl)$ end$ symbolic procedure drop_rl_with(de1,de2)$ % drop de1 from the 'rl_with list of de2 put(de2,'rl_with,delete(de1,get(de2,'rl_with)))$ symbolic procedure add_rl_with(de1,de2)$ % add de1 to 'rl_with of de2 and vice versa <>$ symbolic procedure prevent_simp(v,de1,de2)$ % it is df(de1,v) = de2 % add dec_with such that de2 % will not be simplified to 0=0 begin scalar a,b$ % a:=get(de1,'fcts)$ a:=list(0); % all orderings for which de1 is used (-->ord) for each b in a do if member(v,fctargs(b)) then <>; % a:=get(de2,'fcts)$ a:=list(0); % all orderings for which de2 is used (-->ord) for each b in a do if member(v,fctargs(b)) then <>; end$ symbolic procedure termread$ begin scalar val, !*echo; % Don't re-echo tty input if not null old_history then << val:=car old_history$ if print_ then <>$ old_history:=cdr old_history >> else << rds nil; wrs nil$ % Switch I/O to terminal val := read()$ if ifl!* then rds cadr ifl!*$ % Resets I/O streams if ofl!* then wrs cdr ofl!*$ >>$ history_:=cons(val,history_)$ return val end$ symbolic procedure termxread$ begin scalar val, !*echo; % Don't re-echo tty input if not null old_history then << val:=car old_history$ if print_ then <>$ old_history:=cdr old_history >> else << rds nil; wrs nil$ % Switch I/O to terminal val := xread(nil)$ if ifl!* then rds cadr ifl!*$ % Resets I/O streams if ofl!* then wrs cdr ofl!*$ >>$ % history_:=cons(compress(append(explode val,list('$))),history_)$ history_:=cons(val,history_)$ return val end$ symbolic procedure termlistread()$ begin scalar l; l:=termxread()$ if (not null l) and ((atom l) or (pairp l and (car l neq '!*comma!*))) then l:=list('!*comma!*,l); if l and ((not pairp l) or (car l neq '!*comma!*)) then <> else if pairp l then l:=cdr l; % dropping '!*comma!* return l end$ symbolic procedure mkeqlist(vallist,ftem,vl,flaglist,simp_flag,orderl,pdes)$ % make a list of equations % vallist: list of expressions % ftem: list of functions % vl: list of variables % flaglist: list of flags % orderl: list of orderings where the equations are valid % pdes: list of all equations by name to update inequalities % within update() begin scalar l1$ for each a in vallist do l1:=eqinsert(mkeq(a,ftem,vl,flaglist,simp_flag,orderl, nil,append(l1,pdes)),l1)$ return l1 end$ symbolic procedure mkeq(val,ftem,vl,flaglist,simp_flag,orderl,hist,pdes)$ % make a new equation % val: expression % ftem: list of functions % vl: list of variables % flaglist: list of flags % orderl: list of orderings where the equation is valid % hist: the history of val % pdes: list of all equations by name to update inequalities % within update() % If the new equation to be made is only to exist temporarily then % call mkeq with pdes=nil to avoid lasting effects of the temprary pde. % begin scalar s$ s:=new_pde()$ if record_hist and hist then put(s,'histry_,reval hist)$ for each a in flaglist do flag1(s,a)$ if not update(s,val,ftem,vl,simp_flag,orderl,pdes) then <>$ if record_hist and null hist and s then put(s,'histry_,s)$ return s end$ symbolic procedure no_of_derivs(equ)$ begin scalar h,dl; h:=0; dl:=get(equ,'derivs); while dl do << if (pairp caar dl) and (cdaar dl) then h:=add1 h; dl:=cdr dl >>; return h end$ symbolic procedure update(equ,val,ftem,vl,simp_flag,orderl,pdes)$ % update the properties of a pde % equ: pde % val: expression % ftem: list of functions % vl: list of variables % orderl: list of orderings where the equation is valid % pdes: to call addineq at end % *** important ***: % call afterwards also drop_pde_from_idties(p,pdes,pval) and % drop_pde_from_properties() % if this is now a new equation begin scalar l$ if val and not zerop val then << %ftem:=reverse union(smemberl(ftem,val),nil)$ ftem:=sort_according_to(smemberl(ftem,val),ftem_)$ put(equ,'terms,no_of_terms(val))$ if simp_flag then << % the following test to avoid factorizing big equations val:=% if get(equ,'terms)>max_factor then simplifypde(val,ftem,nil,equ) % else simplifypde(val,ftem,t,equ)$ if val and not zerop val then << ftem:=reverse union(smemberl(ftem,val),nil)$ put(equ,'terms,no_of_terms(val))$ >> >>$ >>$ depl!*:=delete(assoc(reval equ,depl!*),depl!*)$ if val and not zerop val then << put(equ,'val,val)$ put(equ,'fcts,ftem)$ for each v in vl do if not my_freeof(val,v) then l:=cons(v,l)$ vl:=sort_according_to(l,vl_); put(equ,'vars,vl)$ if vl then depl!*:=cons(cons(equ,vl),depl!*)$ % needed in expressions in idnties_ put(equ,'nvars,length vl)$ put(equ,'level,level_)$ put(equ,'derivs,sort_derivs(all_deriv_search(val,ftem),ftem,vl))$ if struc_eqn then put(equ,'no_derivs,no_of_derivs(equ)); put(equ,'fcteval_lin,nil)$ put(equ,'fcteval_nca,nil)$ put(equ,'fcteval_nli,nil)$ put(equ,'fct_nli_lin,nil)$ put(equ,'fct_nli_nca,nil)$ put(equ,'fct_nli_nli,nil)$ put(equ,'fct_nli_nus,nil)$ % put(equ,'terms,no_of_terms(val))$ put(equ,'length,pdeweight(val,ftem))$ put(equ,'printlength,delength val)$ put(equ,'rational,nil)$ put(equ,'nonrational,nil)$ put(equ,'allvarfcts,nil)$ put(equ,'orderings,orderl)$ % Orderings ! for each f in reverse ftem do if rationalp(val,f) then <> else put(equ,'nonrational,cons(f,get(equ,'nonrational)))$ % put(equ,'degrees, % too expensive % if linear_pr then cons(1,for each l in get(equ,'rational) % collect (l . 1)) % else fct_degrees(val,get(equ,'rational)) )$ put(equ,'partitioned,nil)$ put(equ,'starde,stardep(ftem,vl))$ flag1(equ,'to_eval)$ if (l:=get(equ,'starde)) then <<%remflag1(equ,'to_eval)$ remflag1(equ,'to_int)$ remflag1(equ,'to_fullint)$ if simp_flag and (zerop cdr l) then flag1(equ,'to_sep)$ % remflag1(equ,'to_diff) >> else remflag1(equ,'to_gensep)$ if get(equ,'starde) and (zerop cdr get(equ,'starde) ) % or (get(equ,'length)<=gensep_)) then else remflag1(equ,'to_sep)$ if get(equ,'nonrational) then <<%remflag1(equ,'to_decoup)$ if not freeoflist(get(equ,'allvarfcts),get(equ,'nonrational)) then remflag1(equ,'to_eval)>>$ % if not get(equ,'allvarfcts) then remflag1(equ,'to_eval)$ if (not get(equ,'rational)) or ((l:=get(equ,'starde)) and (cdr l = 0)) then remflag1(equ,'to_eval)$ if homogen_ then << l:=cdr algebraic find_hom_deg(lisp val); put(equ,'hom_deg,l)$ % if car l=1 then << % i.e. linear in flin_ % l:=get(equ,'derivs); % while l and (null linf or (length linf < 3)) do << % if not freeoflist(car l,flin_) then << % linf:=cons(car l,linf); % if member(car l,ineq_) then fd1:=car l % >>; % l:=cdr l % >>; % if linf and (length linf = 2) and fd1 then <<<< % if NON-ZERO(coeffn(get(equ,'val),fd1,1)) then << % fd2:=car delete(fd1,linf); % braucht pdes, was nicht vorhanden ist % addineq(pdes,fd2); % addineq(pdes,coeffn(get(equ,'val),fd2,1)) % >> % >> % >> >>$ put(equ,'split_test,nil)$ put(equ,'linear_,if lin_problem then t else lin_check(val,ftem))$ new_ineq_from_pde(equ,pdes); return equ >> end$ symbolic procedure new_ineq_from_pde(equ,pdes)$ % currently only effective for equations with 2 terms % If one term of the equation is non-zero then the sum of the % remaining terms has to be non-zero too if pdes and null lin_problem and (get(equ,'terms)=2) % >1) then begin scalar valu; valu:=get(equ,'val); if not (pairp valu and (car valu='PLUS)) then valu:=reval valu; if not (pairp valu and (car valu='PLUS)) then write"err in update" else % for each l in cdr valu do % if null may_vanish l then addineq(pdes,reval{'DIFFERENCE,valu,l}) if null may_vanish cadr valu then addineq(pdes,caddr valu) else if null may_vanish caddr valu then addineq(pdes,cadr valu) end$ symbolic procedure fct_degrees(pv,ftem)$ % ftem are to be the rational functions begin scalar f,l,ll,h,degs$ if den pv then pv:=num pv$ for each f in ftem do << l:=gensym()$ ll:=cons((f . l),ll)$ pv:=subst({'TIMES,l,f},f,pv)$ >>$ pv:=reval pv$ for each l in ll do << degs:=cons((car l . deg(pv,cdr l)),degs)$ >>; h:=cdar ll$ for each l in cdr ll do pv:=subst(h,cdr l,pv)$ pv:=reval pv$ return cons(deg(pv,h),degs) end$ symbolic procedure pde_degree(pv,ftem)$ % ftem are to be the rational functions begin scalar f,h$ if den pv neq 1 then pv:=num pv$ h:=gensym()$ for each f in ftem do pv:=subst({'TIMES,h,f},f,pv)$ pv:=reval pv$ return deg(pv,h) end$ symbolic procedure dfsubst_update(f,der,equ)$ % miniml update of some properties of a pde % equ: pde % der: derivative % f: f new function begin scalar l$ for each d in get(equ,'derivs) do if not member(cadr der,car d) then l:=cons(d,l) else <>$ put(equ,'fcts,subst(f,cadr der,get(equ,'fcts)))$ put(equ,'allvarfcts,subst(f,cadr der,get(equ,'allvarfcts)))$ if get(equ,'allvarfcts) then flag(list equ,'to_eval)$ % This would reactivate equations which resulted due to % substitution of derivative by a function. % 8.March 98: change again: the line 3 lines above has been reactivated put(equ,'rational,subst(f,cadr der,get(equ,'rational)))$ put(equ,'nonrational,subst(f,cadr der,get(equ,'nonrational)))$ put(equ,'derivs,sort_derivs(l,get(equ,'fcts),get(equ,'vars)))$ return equ end$ symbolic procedure eqinsert(s,l)$ % l is a sorted list if not (s or get(s,'val)) or zerop get(s,'length) or member(s,l) then l else if not l then list s else begin scalar l1,n$ l1:=proddel(s,l)$ if car l1 then <get(car l,'length)) do <>$ l1:=append(reverse l1,cons(s,l))$ >> else if l1 then l1:=cadr l1 % or reverse of it else l1:=l$ return l1$ end$ symbolic procedure not_included(a,b)$ % meaning: not_all_a_in_b = setdiff(a,b) % Are all elements of a also in b? If yes then return nil else t % This could be done with setdiff(a,b), only setdiff % copies expressions and needs extra memory whereas here we only % want to know one bit (included or not) begin scalar c$ c:=t; while a and c do << c:=b; while c and ((car a) neq (car c)) do c:=cdr c; % if c=nil then car a is not in b a:=cdr a; >>; return if c then nil else t end$ symbolic procedure proddel(s,l)$ % delete all pdes from l with s as factor % delete s if it is a consequence of any known pde from l begin scalar l1,l2,l3,n,lnew,pdes,s_hist$ if pairp(lnew:=get(s,'val)) and (car lnew='TIMES) then lnew:=cdr lnew else lnew:=list lnew$ n:=length lnew$ pdes:=l$ while l do << if pairp(l1:=get(car l,'val)) and (car l1='TIMES) then l1:=cdr l1 else l1:=list l1$ if n> else << if null not_included(l1,lnew) then % s is a consequence of car l <>$ % one could stop here but continuation can still be useful if null s_hist then s_hist:={'QUOTIENT, {'TIMES,car l,get(s,'val)}, get(car l,'val) }$ >>$ % else if null l3 or (car l3 neq car l) then l2:=cons(car l,l2)$ >>; l:=cdr l >>$ if print_ and l3 then << listprint l3$ if cdr l3 then write " are consequences of ",s else write " is a consequence of ",s; terpri()$ >>$ if s_hist then <>$ return list(s,reverse l2)$ end$ symbolic procedure myprin2l(l,trenn)$ if l then <> else write l>>$ symbolic procedure print_stars(s)$ begin scalar b,star,pv$ pv:=get(s,'val)$ if (pairp pv) and (car pv='TIMES) then pv:=t else pv:=nil$ star:=get(s,'starde)$ if star or pv then << write "("$ if pv then write"#"$ if star then for b:=1:(1+cdr star) do write"*"$ write")"$ >>$ end$ symbolic procedure typeeq(s)$ % print equation if (null print_) or (get(s,'printlength)>print_) then begin scalar a,b$ print_stars(s); write " ",(a:=get(s,'terms))," terms"$ if a neq (b:=get(s,'length)) then write", ",b," factors"$ write", with derivatives"$ if get(s,'starde) then << write": "$ terpri()$ print_derivs(s,nil)$ >> else << write" of functions of all variables: "$ terpri()$ print_derivs(s,t)$ >> end else mathprint list('EQUAL,0,get(s,'val))$ symbolic procedure print_derivs(p,allvarf)$ begin scalar a,d,dl,avf; dl:=get(p,'derivs)$ if allvarf then << avf:=get(p,'allvarfcts); for each d in dl do if not freeoflist(d,avf) then a:=cons(d,a); dl:=reverse a >>$ dl:=for each d in dl collect << a:=if null cdar d then caar d else cons('DF,car d); if cdr d=1 then a else {'EXPT,a,cdr d} >>$ mathprint cons('! ,dl) end$ symbolic procedure typeeqlist(l)$ % print equations and their property lists <print_) then <> else mathprint list('EQUAL,0,get(s,'val))$ if print_all then << write " derivs : "$ terpri()$print_derivs(s,nil)$ % if struc_eqn then << % terpri()$write " no_derivs : ",get(s,'no_derivs)$ % >>$ write " terms : ",get(s,'terms)$ terpri()$write " fcts : ",get(s,'fcts)$ terpri()$write " vars : ",get(s,'vars)$ terpri()$write " nvars : ",get(s,'nvars)$ terpri()$write " length : ",get(s,'length)$ terpri()$write " printlength: ",get(s,'printlength)$ terpri()$write " level : ",get(s,'level)$ terpri()$write " allvarfcts : ",get(s,'allvarfcts)$ terpri()$write " rational : ",get(s,'rational)$ terpri()$write " nonrational: ",get(s,'nonrational)$ terpri()$write " degrees : ",get(s,'degrees)$ terpri()$write " starde : ",get(s,'starde)$ terpri()$write " fcteval_lin: ",get(s,'fcteval_lin)$ terpri()$write " fcteval_nca: ",get(s,'fcteval_nca)$ terpri()$write " fcteval_nli: ",get(s,'fcteval_nli)$ terpri()$write " fct_nli_lin: ",get(s,'fct_nli_lin)$ terpri()$write " fct_nli_nca: ",get(s,'fct_nli_nca)$ terpri()$write " fct_nli_nli: ",get(s,'fct_nli_nli)$ terpri()$write " fct_nli_nus: ",get(s,'fct_nli_nus)$ terpri()$write " rl_with : ",get(s,'rl_with)$ terpri()$write " dec_with : ",get(s,'dec_with)$ terpri()$write " dec_with_rl: ",get(s,'dec_with_rl)$ % terpri()$write " dec_info : ",get(s,'dec_info)$ terpri()$write " to_int : ",flagp(s,'to_int)$ terpri()$write " to_fullint : ",flagp(s,'to_fullint)$ terpri()$write " to_sep : ",flagp(s,'to_sep)$ terpri()$write " to_gensep : ",flagp(s,'to_gensep)$ terpri()$write " to_decoup : ",flagp(s,'to_decoup)$ terpri()$write " to_drop : ",flagp(s,'to_drop)$ terpri()$write " to_eval : ",flagp(s,'to_eval)$ terpri()$write " to_diff : ",flagp(s,'to_diff)$ terpri()$write " to_under : ",flagp(s,'to_under)$ terpri()$write " to_symbol : ",flagp(s,'to_symbol)$ terpri()$write " not_to_eval: ",get(s,'not_to_eval)$ terpri()$write " used_ : ",flagp(s,'used_)$ terpri()$write " orderings : ",get(s,'orderings)$ terpri()$write " histry_ : ",get(s,'histry_)$ terpri()$write " partitioned: ",if get(s,'partitioned) then "not nil" else "nil"$ terpri()$write " split_test : ",get(s,'split_test)$ terpri()$write " linear_ : ",get(s,'linear_)$ if homogen_ then << terpri()$write " hom_deg : ",get(s,'hom_deg) >>$ terpri()>> >> >>$ symbolic procedure rationalp(p,f)$ % tests if p is rational in f and its derivatives not pairp p or ((car p='QUOTIENT) and polyp(cadr p,f) and polyp(caddr p,f)) or ((car p='EQUAL) and rationalp(cadr p,f) and rationalp(caddr p,f)) or polyp(p,f)$ symbolic procedure ratexp(p,ftem)$ if null ftem then t else if rationalp(p,car ftem) then ratexp(p,cdr ftem) else nil$ symbolic procedure polyp(p,f)$ % tests if p is a polynomial in f and its derivatives % p: expression % f: function if my_freeof(p,f) then t else begin scalar a$ if atom p then a:=t else if member(car p,list('EXPT,'PLUS,'MINUS,'TIMES,'QUOTIENT,'DF)) then % erlaubte Funktionen <> else if (car p='MINUS) then a:=polyp(cadr p,f) else if (car p='QUOTIENT) then <> else if car p='EXPT then % Exponent <0 then a:=polyp(cadr p,f)>> else if car p='DF then % Ableitung if (cadr p=f) or freeof(cadr p,f) then a:=t>> else a:=(p=f)$ return a end$ symbolic procedure starp(ft,n)$ % yields T if all functions from ft have less than n arguments begin scalar b$ while not b and ft do % searching a fct of all vars if fctlength car ft=n then b:=t else ft:=cdr ft$ return not b end$ symbolic procedure stardep(ftem,vl)$ % yields: nil, if a function (from ftem) in p depends % on all variables (from vl) % cons(v,n) otherwise, with v being the list of variables % which occur in a minimal number of n functions begin scalar b,v,n$ if starp(ftem,length vl) then < (b:=for each h in ftem sum if member(car vl,fctargs h) then 1 else 0) then <> % a new minimum else if b=n then v:=cons(car vl,v)$ vl:=cdr vl>> >>$ return if v then cons(v,n) % on each varible from v depend n % functions else nil end$ %symbolic procedure no_of_sep_var(ftem)$ %% assuming ftem are all functions from an ise %% How many are there indirectly separable variables? %% If just two then the new indirect separation is possible %begin scalar v,vs$ % vl:=argset(ftem); % for each f in ftem do % vs:=union(setdiff(vl,fctargs f),vs)$ % return vs %end$ symbolic operator parti_fn$ symbolic procedure parti_fn(fl,el)$ % fl ... alg. list of functions, el ... alg. list of equations % partitions fl such that all functions that are somehow dependent on % each other through equations in el are grouped in lists, % returns alg. list of these lists begin scalar f1,f2,f3,f4,f5,e1,e2; fl:=cdr fl; el:=cdr el; while fl do << f1:=nil; % f1 is the sublist of functions depending on each other f2:=list car fl; % f2 ... func.s to be added to f1, not yet checked fl:=cdr fl; while f2 and fl do << f3:=car f2; f2:=cdr f2; f1:=cons(f3,f1); for each f4 in % smemberl will be all functions not registered yet that occur in % an equation in which the function f3 occurs smemberl(fl, % fl ... the remaining functions not known yet to depend <> ) do << f2:=cons(f4,f2); fl:=delete(f4,fl) >> >>; if f2 then f1:=append(f1,f2); f5:=cons(cons('LIST,f1),f5) >>; return cons('LIST,f5) end$ symbolic procedure plot_dependencies(pdes)$ begin scalar ps,fl$ ps:=promptstring!*$ promptstring!*:=""$ fl:=ftem_; if flin_ and yesp "Shall only functions from the linear list flin_ be considered? " then fl:=setdiff(fl,setdiff(fl,flin_))$ promptstring!*:=ps$ plot_dep_matrix(pdes,fl) end$ symbolic procedure plot_dep_matrix(pdes,allf)$ begin scalar f,ml,lf,fl,h,lh,lc,n,m,h; terpri()$ write "Horizontally: function names (each vertical), ", "Vertically: equation indices"$ terpri()$ ml:=0; % the maximal length of all variable names lf:=length allf$ for each f in reverse allf do << h:=explode f; lh:=length h; if lh>ml then ml:=lh; lc:=cons(h,lc); >>$ % print the variable names for n:=1:ml do << terpri()$ write" "$ for m:=1:lf do write << h:=nth(lc,m); if n>length h then " " else nth(nth(lc,m),n) >> >>$ m:=add1 add1 ml; terpri()$terpri()$ for each p in pdes do if m>=0 then << h:=explode p; for n:=3:length h do write nth(h,n); for n:=(sub1 length(h)):5 do write" "$ fl:=get(p,'fcts); if (not get(p,'fcteval_lin)) and (not get(p,'fcteval_nca)) and (not get(p,'fcteval_nli)) then fcteval(p,nil)$ % for writing "s" for each f in allf do if freeof(fl,f) then write" " else if solvable_case(p,f,'fcteval_lin) or solvable_case(p,f,'fcteval_nca) then write"s" else write"+"$ terpri()$ m:=add1 m$ if m=23 then if not yesp "Continue ?" then m:=-1 else m:=0 >>$ end$ symbolic procedure solvable_case(p,f,case)$ begin scalar fe; fe:=get(p,case); while fe and (cdar fe neq f) do fe:=cdr fe$ return fe end$ %symbolic procedure lin_check(pde,fl)$ %<>$ symbolic procedure lin_check(pde,fl)$ % This needs pde to have prefix form. begin scalar a,f; a:=pde; for each f in fl do a:=err_catch_sub(f,0,a); return if a then << for each f in fl do pde:=subst({'TIMES,lin_test_const,f},f,pde); freeof(reval {'QUOTIENT,{'DIFFERENCE,pde,a},lin_test_const},lin_test_const) >> else nil end$ symbolic procedure plot_non0_coeff_ld(s)$ begin scalar dv,dl,dlc,dr,fdl,avf; write " Leading derivatives with non-zero symbol: "$terpri()$ dv:=get(s,'derivs); avf:=get(s,'allvarfcts); while dv do << dr:=caar dv; dv:=cdr dv; if member(car dr,avf) then << dlc:=dl; while dlc and ((caar dlc neq car dr) or which_deriv(car dlc,dr) ) do dlc:=cdr dlc; if null dlc then dl:=cons(dr,dl); % which_deriv(a,b) takes two lists of derivatives and returns how % often you need to diff. a in order to get at least the % derivatives in b. e.g. which_deriv((x 2 y), (x y 2)) returns y >> >>; for each dr in dl do << dr:=if null cdr dr then car dr else cons('DF,dr); if get(s,'linear_) or freeofzero(reval {'DF,get(s,'val),dr},get(s,'fcts), get(s,'vars),get(s,'nonrational)) then fdl:=cons(dr,fdl) >>; mathprint cons('! ,fdl) end$ %%%%%%%%%%%%%%%%%%%%%%%%% % leading derivatives % %%%%%%%%%%%%%%%%%%%%%%%%% symbolic procedure listrel(a,b,l)$ % a>=b w.r.t list l; e.g. l='(a b c) -> a>=a, b>=c member(b,member(a,l))$ symbolic procedure abs_dfrel(p,q,vl)$ % returns t if derivative of p is lower than derivative of q % 0 " equal " % nil " higher " % p,q : derivatives or functions from ftem like ((f x 2 y z 3) . 2) % ftem : list of fcts % vl : list of vars begin scalar a$ return if lex_df then dfrel2(p,q,vl) else if zerop (a:=absdeg(cdar p)-absdeg(cdar q)) then dfrel2(p,q,vl) else a<0$ end$ symbolic procedure mult_derivs(a,b)$ % multiplies deriv. of a and b % a,b list of derivs of the form ((fct var1 n1 ...).pow) begin scalar l$ return if not b then a else if not a then b else << for each s in a do for each r in b do if car s=car r then l:=union(list cons(car r,plus(cdr r,cdr s)),l) else l:=union(list(r,s),l)$ l>>$ end$ symbolic procedure all_deriv_search(p,ftem)$ % yields all derivatives occuring polynomially in a pde p begin scalar a$ if not pairp p then <> else <>$ return a end$ symbolic procedure abs_ld_deriv(p)$ if get(p,'derivs) then reval cons('DF,caar get(p,'derivs))$ symbolic procedure abs_ld_deriv_pow(p)$ if get(p,'derivs) then cdar get(p,'derivs) else 0$ symbolic procedure which_first(a,b,l)$ if null l then nil else if a = car l then a else if b = car l then b else which_first(a,b,cdr l)$ symbolic procedure total_less_dfrel(a,b,ftem,vl)$ % = 0 if a=b, =t if ab begin scalar fa,ad,al,bl$ fa:=caar a$ return if a=b then 0 else if lex_fc then % lex. order. of functions has highest priority if fa=caar b then if (ad:=abs_dfrel(a,b,vl))=0 then % power counts if cdr a < cdr b then t else nil else if ad then t else nil else if fa=which_first(fa,caar b,ftem) then nil else t else % order. of deriv. has higher priority than fcts. % number of variables of functions has still higher priority if (al:=fctlength fa) > (bl:=fctlength caar b) then nil else if bl>al then t else if (ad:=abs_dfrel(a,b,vl))=0 then if fa=caar b then if cdr a < cdr b then t else nil else if fa=which_first(fa,caar b,ftem) then nil else t else if ad then t else nil end$ symbolic procedure sort_derivs(l,ftem,vl)$ % yields a sorted list of all derivatives in l begin scalar l1,l2,a$ return if null l then nil else << a:=car l$ l:=cdr l$ while l do << if total_less_dfrel(a,car l,ftem,vl) then l1:=cons(car l,l1) else l2:=cons(car l,l2)$ l:=cdr l >>$ append(sort_derivs(l1,ftem,vl),cons(a,sort_derivs(l2,ftem,vl)))>> end$ symbolic procedure dfmax(p,q,vl)$ % yields the higher derivative % vl list of variables e.g. p=((x 2 y 3 z).2), q=((x y 4 z).1) % df(f,x,2,y,3,z)^2, df(f,x,y,4,z) if dfrel(p,q,vl) then q else p$ symbolic procedure dfrel(p,q,vl)$ % the relation "p is lower than q" % vl list of vars e.g. p=((x 2 y 3 z).2), q=((x y 4 z).1) if cdr p='infinity then nil else if cdr q='infinity then t else begin scalar a$ return if lex_df then dfrel1(p,q,vl) else if zerop(a:=absdeg(car p)-absdeg(car q)) then dfrel1(p,q,vl) else if a<0 then t else nil end$ symbolic procedure diffrelp(p,q,v)$ % gives t when p "<" q % nil when p ">" q % 0 when p = q % p, q Paare (liste.power), v Liste der Variablen % liste Liste aus Var. und Ordn. der Ableit. in Diff.ausdr., % power Potenz des Differentialausdrucks if cdr p='infinity then nil else if cdr q='infinity then t else dfrel1(p,q,v)$ symbolic procedure dfrel1(p,q,v)$ % p,q like ((f x 2 y z 3) . 2) if null v then % if cdr p = t then if cdr q = t then 0 else nil % else if cdr q = t then t else if cdr p>cdr q then nil else % same derivatives, if cdr p>$ return reverse l end$ symbolic procedure dfdeg(p,v)$ % yields order of deriv. wrt. v$ % e.g p='(x 2 y z 3), v='x --> 2 if null(p:=member(v,p)) then 0 else if null(cdr p) or not fixp(cadr p) then 1 % v without order else cadr p$ % v with order symbolic procedure lower_deg(p,v)$ % reduces the order of the derivative p wrt. v by one % e.g p='(x 2 y z 3), v='z --> p='(x 2 y z 2) % e.g p='(x 2 y z 3), v='y --> p='(x 2 z 3) % returns nil if no v-derivative begin scalar newp$ while p and (car p neq v) do <>$ if p then if null(cdr p) or not fixp(cadr p) then p:=cdr p else << newp:=cons(sub1 cadr p,cons(car p,newp)); p:=cddr p >> else newp:=nil; while p do <>$ return reverse newp end$ symbolic procedure df_int(d1,d2)$ begin scalar n,l$ return if d1 then if d2 then <> else d1$ end$ symbolic procedure linear_fct(p,f)$ begin scalar l$ l:=ld_deriv(p,f)$ return ((car l=f) and (cdr l=1)) end$ % not used anymore: % %symbolic procedure dec_ld_deriv(p,f,vl)$ %% gets leading derivative of f in p wrt. vars order vl %% result: derivative , e.g. '(x 2 y 3 z) %begin scalar l,d,ld$ % l:=get(p,'derivs)$ % vl:=intersection(vl,get(p,'vars))$ % while caaar l neq f do l:=cdr l$ % ld:=car l$l:=cdr l$ % % --> if lex_df then dfrel1() else % d:=absdeg(cdar ld)$ % while l and (caaar l=f) and (d=absdeg cdaar l) do % <>$ % return cdar ld$ %end$ symbolic procedure ld_deriv(p,f)$ % gets leading derivative of f in p % result: derivative + power , e.g. '((DF f x 2 y 3 z) . 3) begin scalar l$ return if l:=get(p,'derivs) then <> else cons(nil,0)$ end$ symbolic procedure ldiffp(p,f)$ % liefert Liste der Variablen + Ordnungen mit Potenz % p Ausdruck in LISP - Notation, f Funktion ld_deriv_search(p,f,fctargs f)$ symbolic procedure ld_deriv_search(p,f,vl)$ % gets leading derivative of function f in expr. p w.r.t % list of variables vl begin scalar a$ if p=f then a:=cons(nil,1) else <> else if car p='DF then if cadr p=f then a:=cons(cddr p,1) else if my_freeof(cadr p,f) then a:=cons(nil,0) % a constant else a:=cons(nil,'infinity) else if my_freeof(p,f) then a:=cons(nil,0) else a:=cons(nil,'infinity) >>$ return a end$ symbolic procedure lderiv(p,f,vl)$ % fuehrende Ableitung in LISP-Notation mit Potenz (als dotted pair) begin scalar l$ l:=ld_deriv_search(p,f,vl)$ return cons(if car l then cons('DF,cons(f,car l)) else if zerop cdr l then nil else f ,cdr l) end$ symbolic procedure splitinhom(q,ftem,vl)$ % Splitting the equation q into the homogeneous and inhom. part % returns dotted pair qhom . qinhom begin scalar qhom,qinhom,denm; vl:=varslist(q,ftem,vl)$ if pairp q and (car q = 'QUOTIENT) then if starp(smemberl(ftem,caddr q),length vl) then <> else return (q . 0) else denm:=1; if pairp q and (car q = 'PLUS) then q:=cdr q else q:=list q; while q do << if starp(smemberl(ftem,car q),length vl) then qinhom:=cons(car q,qinhom) else qhom :=cons(car q,qhom); q:=cdr q >>; if null qinhom then qinhom:=0 else if length qinhom > 1 then qinhom:=cons('PLUS,qinhom) else qinhom:=car qinhom; if null qhom then qhom:=0 else if length qhom > 1 then qhom:=cons('PLUS,qhom) else qhom:=car qhom; if denm neq 1 then <>; return qhom . qinhom end$ symbolic procedure search_den(l)$ % get all denominators and arguments of LOG,... anywhere in a list l begin scalar l1$ if pairp l then if car l='quotient then l1:=union(cddr l,union(search_den(cadr l),search_den(caddr l))) else if member(car l,'(log ln logb log10)) then if pairp cadr l and (caadr l='QUOTIENT) then l1:=union(list cadadr l,search_den(cadr l)) else l1:=union(cdr l,search_den(cadr l)) else for each s in l do l1:=union(search_den(s),l1)$ return l1$ end$ symbolic procedure zero_den(l,ftem,vl)$ begin scalar cases$ l:=search_den(l)$ while l do << if not freeofzero(car l,ftem,vl,ftem) then cases:=cons(car l,cases); l:=cdr l >>$ return cases end$ symbolic procedure forg_int(forg,fges)$ for each ex in forg collect if pairp ex and pairp cadr ex then forg_int_f(ex,smemberl(fges,ex)) else ex$ symbolic procedure forg_int_f(ex,fges)$ % try to integrate expr. ex of the form df(f,...)=expr. begin scalar p,h,f$ p:=caddr ex$ f:=cadadr ex$ if pairp p and (car p='PLUS) then p:=reval cons('PLUS,cons(list('MINUS,cadr ex),cdr p)) else p:=reval list('DIFFERENCE,p,cadr ex)$ p:=integratepde(p,cons(f,fges),nil,nil,nil)$ if p and (car p) and not cdr p then <>$ return ex end$ symbolic operator total_alg_mode_deriv$ symbolic procedure total_alg_mode_deriv(f,x)$ begin scalar tdf$ %,u,uli,v,vli$ tdf:={'DF,f,x}$ % explicit program for chain rule of differentiation which is not used % as currently f=f(u), u=u(x) gives df(f**2,x)=2*f*df(f,x) % % for each u in depl!* do % if not freeof(cdr u,x) then uli:=cons(car u,uli)$ % for each u in uli do << % vli:=nil$ % for each v in depl!* do % if not freeof(cdr v,u) then vli:=cons(car v,vli)$ % algebraic ( tdf:=tdf+df(f,v)*df(v,u)*df(u,x) )$ % >>$ return reval tdf end$ symbolic procedure no_of_v(v,l)$ % v is a variable name, l a list of derivatives like (x 2 y z 3) % it returns the order of v-derivatives <>$ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % general purpose procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% symbolic procedure memberl(a,b)$ % member for a list if a and b then if member(car a,b) then cons(car a,memberl(cdr a,b)) else memberl(cdr a,b)$ symbolic procedure smemberl(fl,ex)$ % smember for a list if fl and ex then if smember(car fl,ex) then cons(car fl,smemberl(cdr fl,ex)) else smemberl(cdr fl,ex)$ symbolic operator my_freeof$ symbolic procedure my_freeof(u,v)$ % a patch for FREEOF in REDUCE 3.5 not(smember(v,u)) and freeofdepl(depl!*,u,v)$ lisp flag('(my_freeof),'BOOLEAN)$ symbolic procedure freeoflist(l,m)$ % liefert t, falls kein Element aus m in l auftritt if null m then t else if freeof(l,car m) then freeoflist(l,cdr m) else nil$ symbolic procedure freeofdepl(de,u,v)$ if null de then t else if smember(v,cdar de) and smember(caar de,u) then nil else freeofdepl(cdr de,u,v)$ symbolic procedure fctins(f,flen,ftem)$ if null ftem then list f else if fctlength car ftem < flen then cons(f,ftem) else cons(car ftem,fctinsert(f,cdr ftem))$ symbolic procedure fctinsert(f,ftem)$ % isert a function f in the function list ftem if freeof(ftem,f) then fctins(f,fctlength f,ftem) else ftem$ symbolic procedure newfct(id,l,nfct)$ begin scalar f$ % Only in the top level function names may be recycled otherwise % name clashes occur when passing back solutions with new functions % of integration but old used names if (null level_) and (id=fname_) and recycle_fcts then << f:=car recycle_fcts$ recycle_fcts:=cdr recycle_fcts >> else f:=mkid(id,nfct)$ depl!*:=delete(assoc(f,depl!*),depl!*)$ %put(f,'simpfn,'simpiden)$ %if pairp l then f:=cons(f,l)$ if pairp l then depl!*:=cons(cons(f,l),depl!*)$ if print_ then <> else write "new constant: ",f>>$ return f$ end$ symbolic procedure drop_fct(f)$ % check before that f is not one of the forg functions! % check dropping f also from ftem_ <>$ symbolic procedure varslist(p,ftem,vl)$ begin scalar l$ ftem:=argset smemberl(ftem,p)$ for each v in vl do if not my_freeof(p,v) or member(v,ftem) then l:=cons(v,l)$ return reverse l$ end$ symbolic procedure var_list(pdes,forg,vl)$ begin scalar l,l1$ for each p in pdes do l:=union(get(p,'vars),l)$ for each v in vl do if member(v,l) or not my_freeof(forg,v) then l1:=cons(v,l1)$ return reverse l1$ end$ symbolic procedure fctlist(ftem,pdes,forg)$ begin scalar fges,l$ for each p in pdes do l:=union(get(p,'fcts),l)$ for each f in ftem do if not freeof(forg,f) or member(f,l) then fges:=fctinsert(f,fges)$ for each f in forg do if not pairp f and not member(f,fges) then fges:=fctinsert(f,fges)$ for each f in l do if not member(f,fges) then fges:=fctinsert(f,fges)$ l:=setdiff(ftem,fges); for each f in l do drop_fct(f)$ return fges$ end$ symbolic operator fargs$ symbolic procedure fargs f$ cons('LIST,fctargs f)$ symbolic procedure fctargs f$ % arguments of a function if (f:=assoc(f,depl!*)) then cdr f$ symbolic procedure fctlength f$ % number of arguments length fctargs f$ symbolic procedure fctsort(l)$ % list sorting begin scalar l1,l2,l3,m,n$ return if null l then nil else <n then l3:=cons(car l,l3) else l2:=cons(car l,l2)$ l:=cdr l>>$ append(fctsort reverse l3,append(reverse l2,fctsort reverse l1))>> end$ symbolic procedure listprint(l)$ % print elements of a lisp list if pairp l then << write car l$ for each v in cdr l do <> >>$ symbolic procedure fctprint1(f)$ % print a function begin scalar vl; if f then if pairp f then << write car f$ if pairp cdr f then << for each a in vl_ do if not freeof(cdr f,a) then vl:=cons(a,vl); write "("$ % listprint cdr f$ listprint append(setdiff(cdr f,vl),reverse vl)$ write ")">> >> else write f$ end$ symbolic procedure fctprint(fl)$ % Ausdrucken der Funktionen aus fl begin scalar l,f,a,n,nn$ n:=0$ while fl do << f:=car fl$ fl:=cdr fl$ if pairp f then if car f='EQUAL then <print_) then <>$ terpri()>> else mathprint f$ n:=0>> else <>$ fctprint1 f$ if fl then write ", "$ n:=add1 n>> else << nn:=reval {'PLUS,4,length explode f, for each a in fctargs f sum add1 length explode a}; if nn+n > 79 then <>$ l:=assoc(f,depl!*)$ fctprint1 if l then l else f$ if fl then write ", "$ n:=nn+n>> >>$ end$ symbolic procedure deprint(l)$ % Ausdrucken der Gl. aus der Liste l if l and print_ then for each x in l do eqprint list('EQUAL,0,x)$ symbolic procedure eqprint(e)$ % Ausdrucken der Gl. e if print_ then begin scalar n$ n:=delength e$ if n>print_ then <> else mathprint e$ end$ symbolic procedure print_level(neu)$ if print_ and level_ then << terpri()$ if neu then write "New level : " else write "Current level : "$ for each m in reverse level_ do write m,"."$ >>$ symbolic procedure print_statistic(pdes,fcts)$ if print_ then begin integer j,k,le,r,s$ scalar n,m,p,el,fl,vl,pl$ %--- printing the stats of equations: if pdes then << terpri()$write "number of equations : ",length pdes$ terpri()$write "total no of terms : ", j:=for each p in pdes sum get(p,'terms)$ k:=for each p in pdes sum get(p,'length)$ if k neq j then <>$ while pdes do << j:=0; el:=nil; for each p in pdes do << vl:=get(p,'vars); if vl then le:=length vl else le:=0; if ((j=0) and null vl) or (j=le) then el:=cons(p,el) else if j> >>; pdes:=setdiff(pdes,el); if el then << n:=length el$ terpri()$write n," equation"$ if n>1 then write"s"$write" in ",j," variable"$ if j neq 1 then write"s"$ write": "$ if struc_eqn then el:=sort_deriv_pdes(el)$ repeat << if struc_eqn then << pl:=first el; el:=cdr el; terpri()$ write length cdr pl," equations with ",car pl," derivative", if car pl = 1 then ":" else "s:"$ pl:=cdr pl >> else <>; terpri()$ k:=0; while pl do << if (k geq 70) then <>$ k:=k+4+length explode car pl + length explode get(car pl,'terms)$ write car pl,"(",get(car pl,'terms)$ r:=get(car pl,'val)$ if (s:=get(car pl,'starde)) then << for r:=1:(1+cdr s) do write"*"$ k:=k+1+cdr s; >>$ if (pairp r) and (car r='TIMES) then write"#"$ if flin_ and freeoflist(r,flin_) then write"a"$ write")"$ pl:=cdr pl$ if pl then write","$ >>; >> until null el; >>$ j:=add1 j; >> >> else <>$ %--- printing the stats of functions: for each f in fcts do if not pairp f then fl:=cons(f,fl)$ if fl then << fl:=fctsort reverse fl$ m:=fctlength car fl$ while m>=0 do << n:=0$ el:=nil; while fl and (fctlength car fl=m) do << n:=add1 n$ el:=cons(car fl,el)$ fl:=cdr fl >>$ if n>0 then if m>0 then << terpri()$ write n," function"$ if n>1 then write"s"$ write" with ",m," argument",if m>1 then "s : " else " : " >> else << terpri()$ write n," constant"$ if n>1 then write"s"$ write" : " >>$ k:=0; while el do << if k=10 then <> else k:=add1 k$ write car el$ el:=cdr el$ if el then write","$ >>$ m:=if fl then fctlength car fl else -1 >> >> else <>$ terpri()$ end$ symbolic procedure get_statistic(pdes,fcts)$ % returns: {time(), % stepcounter_, % number of pdes, % number of terms, % length of pdes, % {{no of eq, no of var in eq}, ...} % {{no of fc, no of var in fc}, ...} % } if contradiction_ then "contradiction" else begin integer j,le$ scalar n,p,el,fl,vl,li,stats$ stats:={for each p in pdes sum get(p,'length), for each p in pdes sum get(p,'terms), length pdes, stepcounter_, time()}$ %--- the statistics of equations: while pdes do << % j is number of variables and el the list of equations j:=0; el:=nil; for each p in pdes do << vl:=get(p,'vars); if vl then le:=length vl else le:=0; if ((j=0) and null vl) or (j=le) then el:=cons(p,el) else if j> >>; pdes:=setdiff(pdes,el); li:=cons({length el,j},li) % length el equations in j variables >>; stats:=cons(li,stats)$ li:=nil; %--- the statistics of functions: for each f in fcts do if not pairp f then fl:=cons(f,fl)$ if fl then << fl:=fctsort reverse fl$ j:=fctlength car fl$ while j>=0 do << n:=0$ while fl and (fctlength car fl=j) do <>$ li:=cons({n,j},li)$ % n functions of j variables j:=if fl then fctlength car fl else -1 >> >>$ return reverse cons(li,stats) end$ symbolic procedure sort_deriv_pdes(pdes)$ begin scalar max_no_deri,cp,pl,res$ max_no_deri:=0; cp:=pdes; while cp do << if get(car cp,'no_derivs)>max_no_deri then max_no_deri:=get(car cp,'no_derivs); cp:=cdr cp >>; repeat << pl:=nil; cp:=pdes; while cp do << if get(car cp,'no_derivs)=max_no_deri then pl:=cons(car cp,pl); cp:=cdr cp >>$ if pl then res:=cons(cons(max_no_deri,reverse pl),res)$ pdes:=setdiff(pdes,pl); max_no_deri:=if zerop max_no_deri then nil else sub1(max_no_deri); >> until (null max_no_deri) or (null pdes); return res end$ symbolic procedure print_pdes(pdes)$ % print all pdes up to some size begin scalar pl,ps,n,pdecp$ terpri()$ if pdes then << if (null !*batch_mode) and (batchcount_> else pdecp:=pdes$ write "equations : "$ if struc_eqn then << pl:=sort_deriv_pdes(pdecp)$ while pl do << terpri()$ write length cdar pl," equations with ",caar pl," derivatives:"$ typeeqlist(cdar pl)$ pl:=cdr pl >> >> else typeeqlist(pdecp) >> else <>$ end$ symbolic procedure print_ineq(ineqs)$ % print all ineqs begin scalar a,b,c$ terpri()$ if ineqs then << terpri()$write "non-vanishing expressions: "$ for each a in ineqs do if pairp a then c:=cons(a,c) else b:=cons(a,b); listprint b;terpri()$ for each a in c do eqprint a >> end$ symbolic procedure print_fcts2(pdes,fcts)$ % print all fcts and vars begin scalar dflist,dfs,f,p,cp,h,hh,ps,showcoef$ for each h in fcts do if not pairp h then hh:=cons(h,hh); ps:=promptstring!*$ promptstring!*:=""$ % write "Which function out of "$terpri()$ % listprint(hh)$ % write"? "$terpri()$ % write"Enter the function name only or ; for all functions."$terpri()$ % % h:=termread(); % if h neq '!; and not_included(list h,hh) then << % write"This is not a function in the list."$ % terpri(); % h:=nil % >>; % if null h then return nil; % if h='!; then fcts:=hh % else fcts:=list h; fcts:=select_from_list(hh,nil)$ pdes:=select_from_list(pdes,nil)$ write"Do you want to see the coefficients of all derivatives in all equations"$ terpri()$ write"in factorized form which may take relatively much time? y/n"$ terpri()$ repeat h:=termread() until (h='y) or (h='n); if h='n then showcoef:=nil else showcoef:=t; promptstring!*:=ps$ while fcts do if pairp car fcts then fcts:=cdr fcts else << f:=car fcts; fcts:=cdr fcts; dflist:=nil; for each p in pdes do if not freeof(get(p,'fcts),f) then << dfs:=get(p,'derivs); while dfs do << if caaar dfs=f then << cp:=dflist; while cp and (caar cp neq caar dfs) do cp:=cdr cp; if cdaar dfs then h:=cons('DF,caar dfs) else h:=caaar dfs; if showcoef then if null cp then dflist:=cons({caar dfs,{'LIST,p, factorize coeffn(get(p,'val),h,1)}}, dflist) else rplaca(cp,cons(caar cp, cons({'LIST,p, factorize coeffn(get(p,'val),h,1)}, cdar cp))) else if null cp then dflist:=cons({caar dfs,p},dflist) else rplaca(cp,cons(caar cp,cons(p,cdar cp))) >>; dfs:=cdr dfs >>; >>; while dflist do << dfs:=car dflist;dflist:=cdr dflist; if cdar dfs then h:=cons('DF,car dfs) else h:=caar dfs; if showcoef then algebraic <> else <> >>; >>; end$ symbolic procedure print_fcts(fcts,vl)$ % print all fcts and vars <>$ if vl then <>$ >>$ symbolic procedure print_pde_fct_ineq(pdes,ineqs,fcts,vl)$ % print all pdes, ineqs and fcts if print_ then begin$ print_pdes(pdes)$ print_ineq(ineqs)$ print_fcts(fcts,vl)$ print_statistic(pdes,fcts) end$ symbolic procedure no_of_terms(d)$ if not pairp d then if (null d) or (zerop d) then 0 else 1 else if car d='PLUS then length d - 1 else if car d='EQUAL then no_of_terms(cadr d) + no_of_terms(caddr d) else if (car d='MINUS) or (car d='QUOTIENT) then no_of_terms(cadr d) else if car d='EXPT then if (not fixp caddr d) or (caddr d < 2) then 1 else % number of terms of (a1+a2+..+an)**r = n+r-1 over r begin scalar h,m,q$ m:=no_of_terms(cadr d)-1; h:=1; for q:=1:caddr d do h:=h*(m+q)/q; return h end else if car d='TIMES then begin scalar h,r; h:=1; for each r in cdr d do h:=h*no_of_terms(r); return h end else 1$ symbolic procedure delength(d)$ % Laenge eines Polynoms in LISP - Notation if not pairp d then if d then 1 else 0 else if (car d='PLUS) or (car d='TIMES) or (car d='QUOTIENT) or (car d='MINUS) or (car d='EQUAL) then for each a in cdr d sum delength(a) else 1$ symbolic procedure pdeweight(d,ftem)$ % Laenge eines Polynoms in LISP - Notation if not smemberl(ftem,d) then 0 else if not pairp d then 1 else if (car d='PLUS) or (car d='TIMES) or (car d='EQUAL) or (car d='QUOTIENT) then for each a in cdr d sum pdeweight(a,ftem) else if (car d='EXPT) then if numberp caddr d then caddr d*pdeweight(cadr d,ftem) else pdeweight(caddr d,ftem)+pdeweight(cadr d,ftem) else if (car d='MINUS) then pdeweight(cadr d,ftem) else 1$ symbolic procedure desort(l)$ % sort expressions hat are the elements of the list l by size for each a in idx_sort for each b in l collect cons(delength b,b) collect cdr a$ symbolic procedure idx_sort(l)$ % All elements of l have a numerical first element and are sorted % by that number begin scalar l1,l2,l3,m,n$ return if null l then nil else <n then l3:=cons(car l,l3) else l2:=cons(car l,l2)$ l:=cdr l>>$ append(idx_sort(l1),append(l2,idx_sort(l3)))>> end$ symbolic procedure rat_idx_sort(l)$ % All elements of l have a rational number first element % and are sorted by that number % The rational number has to be reval-ed ! begin scalar l1,l2,l3,m,n$ return if null l then nil else <>$ append(rat_idx_sort(l1),append(l2,rat_idx_sort(l3)))>> end$ symbolic procedure argset(ftem)$ % List of arguments of all functions in ftem if ftem then union(reverse fctargs car ftem,argset(cdr ftem)) else nil$ symbolic procedure no_fnc_of_v$ begin scalar vl,v,nofu,f,nv$ % How many functions do depend on each variable? vl:=argset(ftem_)$ for each v in vl do << nofu:=0; % the number of functions v occurs in for each f in ftem_ do if not freeof(fctargs f,v) then nofu:=add1 nofu$ nv:=cons((v . nofu),nv)$ >>$ return nv end$ procedure push_vars(liste)$ for each x in liste collect if not boundp x then x else eval x$ % valuecell x$ symbolic procedure backup_pdes(pdes,forg)$ % make a backup of all pdes begin scalar allfl$ return list(push_vars glob_var, for each p in pdes collect list(p, for each q in prop_list collect cons(q,get(p,q)), <>), for each f in forg collect if pairp f then cons(f,get(cadr f,'fcts)) else cons(f,get( f,'fcts)), for each id in idnties_ collect list(id,get(id,'val),flagp(id,'to_int),flagp(id,'to_subst)) ) end$ %symbolic procedure backup_pdes(pdes,forg)$ %% make a backup of all pdes %begin scalar cop$ % cop:=list(nequ_, % for each p in pdes collect % list(p, % for each q in prop_list collect cons(q,get(p,q)), % for each q in allflags_ collect if flagp(p,q) then q), % for each f in forg collect % if pairp f then cons(cadr f,get(cadr f,'fcts)) % else cons(f,get(f,'fcts)), % ftem_, % ineq_, % recycle_ens, % recycle_fcts)$ % return cop %end$ symbolic procedure pop_vars(liste,altewerte)$ foreach x in liste do <>$ symbolic procedure restore_pdes(bak)$ % restore all data: glob_var, pdes, forg begin scalar pdes,forg$ % recover values of global variables pop_vars(glob_var,car bak)$ % recover the pdes for each c in cadr bak do << pdes:=cons(car c,pdes)$ for each s in cadr c do put(car c,car s,cdr s)$ for each s in caddr c do flag1(car c,s) >>$ % recover the properties of forg for each c in caddr bak do << forg:=cons(car c,forg)$ if pairp car c then put(cadar c,'fcts,cdr c) >>$ % recover the properties of idnties_ if cdddr bak then for each c in cadddr bak do << put(car c,'val,cadr c); if caddr c then flag1(car c,'to_int) else if flagp(car c,'to_int) then remflag(car c,'to_int); if caddr c then flag1(car c,'to_subst) else if flagp(car c,'to_subst) then remflag(car c,'to_subst); >>$ return {reverse pdes,reverse forg}$ end$ %symbolic procedure restore_pdes(cop)$ %% restore the pde list cop %% first element must be the old value of nequ_ %% the elements must have the form (p . property_list_of_p) %begin scalar pdes$ % % delete all new produced pdes % for i:=car cop:sub1 nequ_ do setprop(mkid(eqname_,i),nil)$ % nequ_:=car cop$ % for each c in cadr cop do % <>$ % for each c in caddr cop do % put(car c,'fcts,cdr c)$ % ftem_:=cadddr cop$ % ineq_:=car cddddr cop$ % recycle_eqns:= cadr cddddr cop$ % recycle_fcts:= caddr cddddr cop$ % return reverse pdes$ %end$ %symbolic procedure copy_from_backup(copie)$ %% restore the pde list copie %% first element must be the old value of nequ_ %% the elements must have the form (p . property_list_of_p) %% at least recycle_eqns should not work with this procedure %begin scalar l,pdes,cop$ % cop:=cadr copie$ % l:=cop$ % for i:=1:length cop do % <>$ % pdes:=reverse pdes$ % for each p in pdes do % <>$ % for each c in cop do % <>$ % for each c in caddr copie do % put(car c,'fcts,cdr c)$ % ftem_:=cadddr copie$ % return pdes$ %end$ symbolic procedure deletepde(pdes)$ begin scalar s,l,ps$ ps:=promptstring!*$ promptstring!*:=""$ terpri()$ write "Equations to be deleted: "$ l:=select_from_list(pdes,nil)$ promptstring!*:=ps$ for each s in l do if member(s,pdes) then pdes:=drop_pde(s,pdes,nil)$ return pdes end$ symbolic procedure new_pde()$ begin scalar s$ if null car recycle_eqns then << s:=mkid(eqname_,nequ_)$ nequ_:=add1 nequ_$ >> else << s:=caar recycle_eqns$ recycle_eqns:=(cdar recycle_eqns) . (cdr recycle_eqns) >>$ setprop(s,nil)$ return s end$ symbolic procedure drop_pde_from_properties(p,pdes)$ begin for each q in pdes do if q neq p then << drop_dec_with(p,q,t)$ drop_dec_with(p,q,nil)$ drop_rl_with(p,q) >> end$ symbolic procedure drop_pde_from_idties(p,pdes,pval)$ % to be used whenever the equation p is dropped or changed and % afterwards newly characterized in update, % pval is the new value of p in terms of the previous value, % if this is unknown then pval=nil % to be done before setprop(p,nil) begin scalar q,newidval,idnt$ for each q in pdes do if q neq p then if not freeof(get(q,'histry_),p) then put(q,'histry_, if null pval then q else subst(pval,p,get(q,'histry_)))$ if record_hist and (getd 'show_id) then << idnt:=idnties_$ while idnt do << if not freeof(get(car idnt,'val),p) then if null pval then drop_idty(car idnt) else << % Once pdes_ is available as global variable then simplify 'val % before put() newidval:=reval subst(pval,p,get(car idnt,'val))$ if trivial_idty(pdes,newidval) then drop_idty(car idnt) else << put(car idnt,'val,newidval); flag1(car idnt,'to_subst)$ flag1(car idnt,'to_int) >> >>; idnt:=cdr idnt >>; if pval and not zerop pval and (p neq get(p,'histry_)) then << idnt:=reval num reval {'PLUS,get(p,'histry_),{'MINUS,pval}}$ if not zerop idnt then new_idty(idnt,pdes,if pdes then t else nil) >> >> end$ symbolic procedure drop_pde(p,pdes,pval)$ % pval is the value of p in terms of other equations, % if pval=nil then unknown % pdes should be a list of all currently used pde-names begin if do_recycle_eqn then recycle_eqns:=(car recycle_eqns) . union({p},cdr recycle_eqns)$ depl!*:=delete(assoc(reval p,depl!*),depl!*)$ drop_pde_from_idties(p,pdes,pval)$ setprop(p,nil)$ return delete(p,pdes) end$ symbolic procedure change_pde_flag(pdes)$ begin scalar p,ty,h$ repeat << terpri()$ write "From which PDE do you want to change a ", "flag or property, e.g. e_23?"$ terpri()$ p:=termread()$ >> until not freeof(pdes,p)$ terpri()$ write"Type in one of the following flags that is to be flipped "$ terpri()$ write"(e.g. to_int ): "$ terpri()$terpri()$ write allflags_; terpri()$terpri()$ write"or type in one of the following properties that is to be changed"$ terpri()$ write"(e.g. vars ): "$ terpri()$terpri()$ write prop_list; terpri()$terpri()$ ty:=termread()$ if member(ty,allflags_) then << if flagp(p,ty) then remflag1(p,ty) else flag1(p,ty)$ write"The new value of ",ty,": ",flagp(p,ty)$ >> else if member(ty,prop_list) then << terpri()$ write"current value: ",get(p,ty)$ terpri()$ write"new value (e.g. (x y z) ENTER): "$ terpri()$ h:=termread()$ put(p,ty,h)$ write"The new value of ",ty,": ",get(p,ty)$ >> else write"Input not recognized."$ terpri()$ end$ symbolic procedure restore_backup_from_file(pdes,forg,nme)$ begin scalar ps,s,p,echo_bak$ if nme=t then << ps:=promptstring!*$ promptstring!*:=""$ terpri()$ write"Please give the name of the file in double quotes"$terpri()$ write"without `;' : "$ s:=termread()$ >> else if nme then s:=nme else s:=level_string(session_)$ % infile s$ echo_bak:=!*echo; semic!*:='!$; in s$ !*echo:=echo_bak; %-- cleaning up: for each p in pdes do setprop(p,nil)$ for each p in forg do if pairp p then put(cadr p,'fcts,nil)$ %-- assigning the new values: promptstring!*:=ps$ size_hist :=car backup_; backup_:=cdr backup_; stepcounter_:=car backup_; backup_:=cdr backup_; level_ :=car backup_; backup_:=cdr backup_; nfct_ :=car backup_; backup_:=cdr backup_; time_limit :=car backup_; backup_:=cdr backup_; limit_time :=car backup_; backup_:=cdr backup_; history_ :=car backup_; backup_:=cdr backup_; s:=restore_pdes(backup_)$ backup_:=nil; orderings_:=car orderings_; return s end$ symbolic procedure level_string(s)$ << for each m in reverse level_ do s := if s then bldmsg("%w%d.",s,m) else bldmsg("%d.",m ); s>>; symbolic procedure backup_to_file(pdes,forg,nme)$ begin scalar s,ps$ %,levelcp$ if nme=t then << ps:=promptstring!*$ promptstring!*:=""$ terpri()$ write"Please give the name of the file in double quotes"$terpri()$ write"without `;' : "$ s:=termread()$ promptstring!*:=ps$ >> else if nme then s:=nme else s:=level_string(session_)$ out s; off nat$ orderings_:=list orderings_; write"off echo$"$ write "backup_:='"$terpri()$ print cons(size_hist,cons(stepcounter_,cons(level_,cons(nfct_, cons(time_limit,cons(limit_time,cons(history_, backup_pdes(pdes,forg))))))))$ write"$"$terpri()$ write "end$"$terpri()$ shut s; on nat; end$ symbolic procedure delete_backup$ begin scalar s$ s:=level_string(session_); delete!-file s; end$ symbolic procedure restore_and_merge(soln,pdes,forg)$ % pdes, forg are cleaned up % one could just use restore_pdes without assigning bak % but then it would not be stored in a file, such that % rb can reload the file begin scalar bak,newfdep,sol,f,h$ % store ongoing global values in bak newfdep:=nil$ for each sol in soln do if sol then << for each f in caddr sol do if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep); >>; bak:=append(list(size_hist,stepcounter_,level_,nfct_, time_limit,limit_time,history_), newfdep); h:=restore_backup_from_file(pdes,forg,nil)$ size_hist :=car bak; bak:=cdr bak; stepcounter_:=car bak; bak:=cdr bak; level_ :=car bak; bak:=cdr bak; nfct_ :=car bak; bak:=cdr bak; time_limit :=car bak; bak:=cdr bak; limit_time :=car bak; bak:=cdr bak; history_ :=car bak; bak:=cdr bak; depl!* :=append(depl!*,bak); return h end$ symbolic procedure write_in_file(pdes,forg)$ begin scalar p,pl,s,h,ps,wn,vl,ftem$ ps:=promptstring!*$ promptstring!*:=""$ terpri()$ write "Enter a list of equations, like e2,e5,e35; from: "$terpri()$ listprint(pdes)$ terpri()$write "To write all equations just enter ; "$terpri()$ repeat << s:=termlistread()$ h:=s; if s=nil then pl:=pdes else << pl:=nil;h:=nil$ if (null s) or pairp s then << for each p in s do if member(p,pdes) then pl:=cons(p,pl); h:=setdiff(pl,pdes); >> else h:=s; >>; if h then <>$ >> until null h$ write"Shall the name of the equation be written? (y/n) "$ repeat s:=termread() until (s='y) or (s='Y) or (s='n) or (s='N)$ if (s='y) or (s='Y) then wn:=t$ write"Please give the name of the file in double quotes"$terpri()$ write"without `;' : "$ s:=termread()$ out s; off nat$ write"load crack$"$terpri()$ write"lisp(nfct_:=",nfct_,")$"$terpri()$ if wn then write"lisp(nequ_:=",nequ_,")$"$terpri()$ write"off batch_mode$"$terpri()$ for each p in pl do <>$ write"list_of_variables:="$ algebraic write lisp cons('LIST,vl)$ for each p in pl do <>$ write"list_of_functions:="$ algebraic write lisp cons('LIST,ftem)$ for each h in ftem do if assoc(h,depl!*) then << p:=pl; while p and freeof(get(car p,'val),h) do p:=cdr p; if p then << write "depend ",h$ for each v in cdr assoc(h,depl!*) do << write ","$print v >>$ write "$"$terpri()$ % for each v in cdr assoc(h,depl!*) do % algebraic write "depend ",lisp h,",",lisp v$ >> >>$ if wn then << for each h in pl do algebraic (write h,":=",lisp (get(h,'val)))$ write"list_of_equations:="$ algebraic write lisp( cons('LIST,pl) ) >> else << write"list_of_equations:="$ algebraic write lisp( cons('LIST, for each h in pl collect get(h,'val)) )$ >>$ write"list_of_inequalities:="$ algebraic write lisp( cons('LIST,ineq_))$ terpri()$ write"solution_:=crack(list_of_equations,"$ terpri()$ write" list_of_inequalities,"$ terpri()$ write" list_of_functions,"$ terpri()$ write" list_of_variables)$"$ terpri()$ for each h in forg do << terpri()$ if pairp h and (car h = 'EQUAL) then algebraic write lisp(cadr h)," := sub(second first solution_,", lisp(caddr h),")" >>$ terpri()$ write"end$"$terpri()$terpri()$ write"These data were produced with the following input:"$terpri()$terpri()$ write"lisp( old_history := "$terpri()$ write"'",reverse history_,")$"$terpri()$ shut s; on nat; promptstring!*:=ps$ end$ symbolic procedure give_low_priority(pdes,f)$ % It assumes that f is element of ftem_. % It assumes that if f is element of flin_ then flin_ functions % come first in each group of functions with the same number % of independent variables. % If f is element of flin_ then f is put at the end of the flin_ % functions with equally many variables but before the first functions % that occur in ineq_ in order to change ftem_ as little as possible % not to invalidate previous decoupling. begin scalar ftemcp,ano,h,s,fli$ ftemcp:=ftem_$ while ftemcp and (car ftemcp neq f) do << h:=cons(car ftemcp,h)$ ftemcp:=cdr ftemcp >>$ % Is there an element of the remaining ftemcp with the same no of % variables and that is not in ineq_ ? if ftemcp then << ftemcp:=cdr ftemcp; ano:=fctlength f$ if member(f,flin_) then fli:=t$ while ftemcp do if (ano > (fctlength car ftemcp)) or (fli and (not member(car ftemcp,flin_))) then ftemcp:=nil else << h:=cons(car ftemcp,h)$ ftemcp:=cdr ftemcp$ if not member(car h,ineq_) then << while ftemcp and (ano = (fctlength car ftemcp)) and (not member(car ftemcp,ineq_)) and ((not fli) or member(car ftemcp,flin_)) do << h:=cons(car ftemcp,h)$ ftemcp:=cdr ftemcp >>$ if print_ or tr_orderings then << write"The lexicographical ordering of unknowns is changed"$ terpri()$ write"because ",f," has to be non-zero, giving ",f," a low priority."$ terpri()$ write "Old ordering: "$ s:=ftem_; while s do <>$ terpri()$ write "New ordering: "$ s:=append(reverse h,cons(f,ftemcp)); while s do <>$ terpri()$ >>$ change_fcts_ordering(append(reverse h,cons(f,ftemcp)),pdes,vl_)$ ftemcp:=nil >> % of not member(car h,ineq_) >> % of ano > (fctlength car ftemcp) >> % of ftemcp end$ symbolic procedure addineq(pdes,newineq)$ % it assumes newineq involves functions of ftem_ begin scalar h1,h2,h3$ newineq:=simp_ineq(newineq); h1:=cdr err_catch_fac(newineq)$ % h1 is a lisp list of factors if null cdr h1 then << h2:=signchange(car h1); % only one factor if not member(h2,ineq_) then <> >> else for each h2 in h1 do << h2:=signchange(h2); if (not freeoflist(h2,ftem_)) and (not member(h2,ineq_)) then <> >>$ if print_ and h3 then << write"The list of inequalities got extended."$terpri() >>$ % h3 is the list of all new non-zero expressions % if any one of these expressions is an element of ftem_ then it % should get a low priority in the lexicographical ordering for % non-linear problems if flin_ and null lin_problem then % maybe also for flin_=nil for each h2 in h3 do if atom h2 and member(h2,ftem_) then give_low_priority(pdes,h2); % h2 gets a low priority so that it is eliminated late in decoupling % to be available as non-zero coefficient as long as possible to % allow substitutions of other functions without case-distinctions if pdes then for each h2 in h3 do update_fcteval(pdes,h2); % If one term of the equation is non-zero then the sum of the % remaining terms has to be non-zero too if h3 and pdes then for each h2 in pdes do if get(h2,'terms)=2 then new_ineq_from_pde(h2,pdes) end$ % symbolic procedure drop_factor(h,pro)$ % % This procedure drops a factor h or its negative from an expression pro % begin scalar hs,newpro,mi; % hs:=signchange(h); % if pairp pro and (car pro='MINUS) then <>; % if pro = h then newpro:= 1 else % if pro = hs then newpro:=-1 else % if pairp pro and (car pro = 'TIMES) then % if member(h ,pro) then newpro:=reval delete(h ,pro) else % if member(hs,pro) then newpro:=reval list('MINUS,delete(hs,pro)); % if mi and newpro then newpro:=reval list('MINUS,newpro) % return newpro % end$ symbolic procedure update_fcteval(pdes,newineq)$ begin scalar p,pv,ps,hist,h1,h2$ for each p in pdes do << pv:=get(p,'val)$ if pairp pv and (car pv='TIMES) and member(newineq,pv) then << pv:=reval {'QUOTIENT,pv,newineq}; if record_hist then hist:=reval {'QUOTIENT,get(p,'histry_),newineq}$ update(p,pv,get(p,'fcts),get(p,'vars),t,list(0),pdes)$ drop_pde_from_idties(p,pdes,hist)$ drop_pde_from_properties(p,pdes) >> else << ps:=get(p,'fcteval_nli)$ while ps and <> do ps:=cdr ps; if ps then << % We would have to check whether apart from the % new non-zero factor, the other factors can vanish for % specific values of ftem_ or not. Instead of programming % this again here we simply change flags to re-compute all % fct... properties later when a substitution is to be done. flag1(p,'to_eval)$ put(p,'fcteval_lin,nil)$ put(p,'fcteval_nca,nil)$ put(p,'fcteval_nli,nil)$ put(p,'fct_nli_lin,nil)$ put(p,'fct_nli_nca,nil)$ put(p,'fct_nli_nli,nil)$ put(p,'fct_nli_nus,nil)$ >> >> >>$ end$ symbolic procedure addfunction(ft)$ begin scalar f,ff,l,ps,ok$ ps:=promptstring!*$ promptstring!*:=""$ ff:=mkid(fname_,nfct_)$ repeat << ok:=t; terpri()$ write "What is the name of the new function?"$ terpri()$ write "If the name is ",fname_,"+digits then use ",ff,". Terminate with : "$ f:=termread()$ if f=ff then nfct_:=add1 nfct_ else if member(f,ft) then << terpri()$ write"Choose another name. ",f," is already in use."$ ok:=nil >>$ >> until ok; depl!*:=delete(assoc(f,depl!*),depl!*)$ terpri()$ write "Give a list of variables ",f," depends on, for example x,y,z; "$ terpri()$ write "For constant ",f," input a `;' "$ l:=termxread()$ if (pairp l) and (car l='!*comma!*) then l:=cdr l; if pairp l then depl!*:=cons(cons(f,l),depl!*) else if l then depl!*:=cons(list(f,l),depl!*)$ ft:=fctinsert(f,ft)$ ftem_:=fctinsert(f,ftem_)$ promptstring!*:=ps$ return (ft . f) end$ symbolic procedure newinequ(pdes)$ begin scalar ps,ex$ ps:=promptstring!*$ promptstring!*:=""$ write "Input of a value for the new non-vanishing expression."$ terpri()$ write "You can use names of pds, e.g. 3*e_12 - df(e_13,x) + 8; "$ terpri()$ write "Terminate the expression with ; or $ : "$ terpri()$ ex:=termxread()$ for each a in pdes do ex:=subst(get(a,'val),a,ex)$ terpri()$ promptstring!*:=ps$ addineq(pdes,ex)$ end$ symbolic procedure replacepde(pdes,ftem,vl)$ begin scalar p,q,ex,ps,h,newfct,again$ ps:=promptstring!*$ promptstring!*:=""$ repeat << terpri()$ write "Is there a"$ if again then write" further"$ write" new function in the changed/new PDE that"$ terpri()$ write "is to be calculated (y/n)? "$ p:=termread()$ if (p='y) or (p='Y) then << h:=addfunction(ftem)$ ftem:=car h$ if cdr h then newfct:=cons(cdr h,newfct) >>; again:=t >> until (p='n) or (p='N)$ terpri()$ write "If you want to replace a pde then type its name, e.g. e_23 ."$ terpri()$ write "If you want to add a pde then type `new_pde' . "$ p:=termread()$ if (p='NEW_PDE) or member(p,pdes) then < x) without"$ terpri()$ write " dropping non-zero factors and denominators"$ terpri()$ write " (e.g. to introduce integrating factors) (1)"$ terpri()$ write "- simplified completely (2) "$ h:=termread()$ % if h=2 then ex:=reval ex$ % if h<3 then h:=nil % else h:=t$ if h=1 then <> else h:=t$ if p neq 'NEW_PDE then pdes:=drop_pde(p,pdes,{'QUOTIENT,{'TIMES,p,ex},get(p,'val)})$ q:=mkeq(ex,ftem,vl,allflags_,h,list(0),nil,pdes)$ % A new equation with a new function appearing linear and only % algebraically can only have the purpose of a transformation % in which case the new equation should not be solved for the % new function as this would just mean dropping the new equation: if (p='NEW_PDE) and newfct then put(q,'not_to_eval,newfct)$ terpri()$write q$ if p='NEW_PDE then write " is added" else write " replaces ",p$ pdes:=eqinsert(q,pdes)>> else <>$ promptstring!*:=ps$ return list(pdes,ftem) end$ symbolic procedure select_from_list(liste,n)$ begin scalar ps,s$ ps:=promptstring!*$ promptstring!*:=""$ terpri()$ if n then write"Pick ",n," from this list:" else write"Pick from this list"$ terpri()$ listprint(liste)$write";"$terpri()$ if null n then << write"a sublist and input it in the same form. Enter ; to choose all."$ terpri()$ >>$ s:=termlistread()$ if n and n neq length s then << write "Wrong number picked."$terpri()$ s:=nil; >> else if null s then s:=liste else if not_included(s,liste) then << write setdiff(s,liste)," is not allowed."$terpri()$ s:=nil; >>; promptstring!*:=ps$ return s end$ symbolic procedure selectpdes(pdes,n)$ % interactive selection of n pdes % n may be an integer or nil. If nil then the % number of pdes is free. if pdes then begin scalar l,s,ps,m$ ps:=promptstring!*$ promptstring!*:=""$ terpri()$ if null n then << write "How many equations do you want to select? "$terpri()$ write "(number ) : "$terpri()$ n:=termread()$ >>$ write "Please select ",n," equation"$ if n>1 then write "s"$write " from: "$ write pdes$ % fctprint pdes$ terpri()$ m:=0$ s:=t$ while (m1 then write m,". "$ write "pde: "$ s:=termread()$ while not member(s,pdes) do <1 then write m,". "$ write "pde: "$ s:=termread()>>$ if s then <> >>$ promptstring!*:=ps$ return reverse l$ end$ symbolic operator nodepnd$ symbolic procedure nodepnd(fl)$ for each f in cdr fl do depl!*:=delete(assoc(reval f,depl!*),depl!*)$ symbolic procedure err_catch_readin$ begin scalar h,mode_bak,echo_bak$ mode_bak:=!*mode; % as the _stop_ file has to start with 'lisp;' echo_bak:=!*echo; semic!*:='!$; h:= errorset({'in,mkquote {"_stop_"}},nil,nil) where !*protfg=t; !*echo:=echo_bak; semic!*:='!; ; erfg!*:=nil; !*mode:=mode_bak$ return not errorp h end$ symbolic procedure err_catch_solve(eqs,fl)$ % fl='(LIST x y z); eqs='(LIST expr1 expr2 .. ) begin scalar h$ h:=errorset({'solveeval,mkquote{eqs, fl}},nil,nil) where !*protfg=t; erfg!*:=nil; return if errorp h then nil else cdar h % cdr for deleting 'LIST end$ symbolic operator err_catch_sub$ symbolic procedure err_catch_sub(h2,h6,h3)$ % do sub(h2=h6,h3) with error catching begin scalar h4,h5; h4 := list('EQUAL,h2,h6); h5:=errorset({'subeval,mkquote{reval h4, reval h3 }},nil,nil) where !*protfg=t; erfg!*:=nil; return if errorp h5 then nil else car h5 end$ symbolic operator err_catch_int$ symbolic procedure err_catch_int(h2,h3)$ % do int(h2,h3) with error catching begin scalar h5; h5:=errorset({'simpint,mkquote{reval h2, reval h3 }},nil,nil) where !*protfg=t; erfg!*:=nil; return if errorp h5 then nil else if not freeof(car h5,'INT) then nil else prepsq car h5 end$ symbolic procedure beforegcsystemhook()$ my_gc_counter:=add1 my_gc_counter$ symbolic procedure aftergcsystemhook()$ if my_gc_counter > max_gc_counter then << if print_ % and print_more (User must know that not all is computed.) then << write "Stop of a subroutine."$terpri()$ write "Number of garbage collections exceeds ",backup_,"."; terpri()$ >>$ rederr "Heidadeife " >>$ symbolic operator err_catch_fac$ symbolic procedure err_catch_fac(a)$ begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak; bak:=max_gc_counter; max_gc_counter:=my_gc_counter+max_gc_fac; kernlist!*bak:=kernlist!*$ kord!*bak:=kord!*$ bakup_bak:=backup_;backup_:='max_gc_fac$ h:=errorset({'reval,list('FACTORIZE,mkquote a)},nil,nil) where !*protfg=t; kernlist!*:=kernlist!*bak$ kord!*:=kord!*bak; erfg!*:=nil; max_gc_counter:=bak; backup_:=bakup_bak; return if errorp h then {'LIST,a} else car h end$ symbolic operator err_catch_gcd$ symbolic procedure err_catch_gcd(a,b)$ begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak; bak:=max_gc_counter; max_gc_counter:=my_gc_counter+max_gc_fac; kernlist!*bak:=kernlist!*$ kord!*bak:=kord!*$ bakup_bak:=backup_;backup_:='max_gc_fac$ h:=errorset({'reval,list('GCD,mkquote a,mkquote b)},nil,nil) where !*protfg=t; kernlist!*:=kernlist!*bak$ kord!*:=kord!*bak; erfg!*:=nil; max_gc_counter:=bak; backup_:=bakup_bak; return if errorp h then 1 else car h end$ %symbolic operator err_catch_fac$ %symbolic procedure err_catch_fac(a)$ %begin scalar h,bak,bakup_bak; % bak:=max_gc_counter; % max_gc_counter:=my_gc_counter+max_gc_fac; % bakup_bak:=backup_;backup_:='max_gc_fac$ % h:=errorset({'reval,list('FACTORIZE,mkquote a)},nil,nil) % where !*protfg=t; % erfg!*:=nil; % max_gc_counter:=bak; % backup_:=bakup_bak; % return if errorp h then {'LIST,a} % else car h %end$ symbolic procedure factored_form(a)$ % a is expected to be in prefix form begin scalar b; if (pairp a) and (car a = 'PLUS) then << b:=err_catch_fac a$ if b and (length b > 2) then a:=cons('TIMES,cdr b) >>; return a end$ symbolic lispeval '(putd 'countids 'expr '(lambda nil (prog (nn) (setq nn 0) (mapobl (function (lambda (x) (setq nn (plus2 nn 1))))) (return nn))))$ symbolic operator low_mem$ % if garbage collection recovers only 500000 cells then backtrace % to be used only on workstations, not PCs i.e. under LINUX, Windows symbolic procedure newreclaim()$ <>$ symbolic procedure low_mem()$ if not( getd 'oldreclaim) then << copyd('oldreclaim,'!%reclaim); copyd('!%reclaim,'newreclaim); >>$ symbolic operator polyansatz$ symbolic procedure polyansatz(ev,iv,fn,degr,homo)$ % ev, iv are algebraic mode lists % generates a polynomial in the variables ev of degree degr % with functions of the variables iv % if homo then a homogeneous polynomial begin scalar a,fi,el1,el2,f,fl,p,pr; a:=reval list('EXPT,cons('PLUS,if homo then cdr ev else cons(1,cdr ev)),degr)$ a:=reverse cdr a$ fi:=0$ iv:=cdr iv$ for each el1 in a collect << if (not pairp el1) or (car el1 neq 'TIMES) then el1:=list el1 else el1:=cdr el1; f:=newfct(fn,iv,fi); fi:=add1 fi; fl:=cons(f,fl)$ pr:=list f$ for each el2 in el1 do if not fixp el2 then pr:=cons(el2,pr); if length pr>1 then pr:=cons('TIMES,pr) else pr:=car pr; p:=cons(pr,p) >>$ p:=reval cons('PLUS,p)$ return list('LIST,p,cons('LIST,fl)) end$ symbolic operator polyans$ symbolic procedure polyans(ordr,dgr,x,y,d_y,fn)$ % generates a polynom % for i:=0:dgr sum fn"i"(x,y,d_y(1),..,d_y(ordr-1))*d_y(ordr)**i % with fn as the function names and d_y as names or derivatives of y % w.r.t. x begin scalar ll,fl,a,i,f$ i:=sub1 ordr$ while i>0 do <>$ ll:=cons(y,ll)$ ll:=reverse cons(x,ll)$ fl:=nil$ i:=0$ while i<=dgr do <>$ return list('list,reval a,cons('list,fl)) end$ % of polyans symbolic operator sepans$ symbolic procedure sepans(kind,v1,v2,fn)$ % Generates a separation ansatz % v1,v2 = lists of variables, fn = new function name + index added % The first variable of v1 occurs only in one sort of the two sorts of % functions and the remaining variables of v1 in the other sort of % functios. % The variables of v2 occur in all functions. % Returned is a sum of products of each one function of both sorts. % form: fn1(v11;v21,v22,v23,..)*fn2(v12,..,v1n;v21,v22,v23,..)+... % the higher "kind", the more general and difficult the ansatz is % kind = 0 is the full case begin scalar n,vl1,vl2,h1,h2,h3,h4,fl$ if cdr v1 = nil then <> else <>$ return if kind = 0 then <> else if kind = 1 then <> else if kind = 2 then <> else if kind = 3 then <> else if kind = 4 then <> else if kind = 5 then <> else if kind = 6 then <> else if kind = 7 then <> else % ansatz of the form FN = FN1(v11,v2) + FN2(v12,v2) + ... + FNi(v1i,v2) if kind = 8 then <>$ list('LIST, cons('PLUS,fl), cons('LIST,fl))>> else <> end$ % of sepans % % Orderings support! % % change_derivs_ordering(pdes,fl,vl) changes the ordering of the % list of derivatives depending on the current ordering (this % is detected "automatically" by sort_derivs using the lex_df flag to % toggle between total-degree and lexicographic. % symbolic procedure change_derivs_ordering(pdes,fl,vl)$ begin scalar p, dl; for each p in pdes do << if tr_orderings then << terpri()$ write "Old: ", get(p,'derivs)$ >>$ dl := sort_derivs(get(p,'derivs),fl,vl)$ if tr_orderings then << terpri()$ write "New: ", dl$ >>$ put(p,'derivs,dl)$ put(p,'dec_with,nil)$ % only if orderings are not % investigated in parallel (-->ord) put(p,'dec_with_rl,nil) % only if orderings are not .. >>$ return pdes end$ symbolic procedure sort_according_to(r,s)$ % all elements in r that are in s are sorted according to their order in s begin scalar ss,h; for each ss in s do if member(ss,r) then h:=cons(ss,h); return reverse h end$ symbolic procedure change_fcts_ordering(newli,pdes,vl)$ begin scalar s$ ftem_ := newli$ for each s in pdes do put(s,'fcts,sort_according_to(get(s,'fcts),ftem_))$ pdes := change_derivs_ordering(pdes,ftem_,vl)$ if tr_orderings then << terpri()$ write "New functions list: ", ftem_$ >> end$ symbolic procedure check_history(pdes)$ begin scalar p,q,h$ for each p in pdes do << h:=get(p,'histry_); for each q in pdes do h:=subst(get(q,'val),q,h)$ if algebraic((lisp(get(p,'val)) - h) neq 0) then << write"The history value of ",p," is not correct!"$ terpri() >> >> end$ symbolic procedure check_globals$ % to check validity of global variables at start of CRACK begin scalar flag, var$ % The integer variables foreach var in global_list_integer do if not fixp eval(var) then << terpri()$ write var, " needs to be an integer: ", eval(var)," is invalid"$ flag := var >>$ % Now for integer variables allowed to be nil foreach var in global_list_ninteger do if not fixp eval(var) and eval(var) neq nil then << terpri()$ write var, " needs to be an integer or nil: ", eval(var)," is invalid"$ flag := var >>$ % Finally variables containing any number foreach var in global_list_number do if not numberp eval(var) then << terpri()$ write var, " needs to be a number: ", eval(var)," is invalid"$ flag := var >>$ return flag end$ symbolic procedure search_li(l,care)$ % Find the cadr of all sublists which have 'care' as car (no nesting) if pairp l then if car l = care then {cadr l} else begin scalar a,b,resul; for each a in l do if b:=search_li(a,care) then resul:=union(b,resul); return resul end$ symbolic procedure search_li2(l,care)$ % Find all sublists which have 'care' as car (no nesting) if pairp l then if car l = care then list l else begin scalar a,b,resul; for each a in l do if b:=search_li2(a,care) then resul:=union(b,resul); return resul end$ symbolic operator backup_reduce_flags$ symbolic procedure backup_reduce_flags$ % !*nopowers = t to have output of FACTORIZE like in Reduce 3.6 % !*allowdfint = t moved here from crintfix, to enable simplification % of derivatives of integrals begin !*dfprint_bak := cons(!*dfprint,!*dfprint_bak)$ !*exp_bak := cons(!*exp,!*exp_bak)$ !*ezgcd_bak := cons(!*ezgcd,!*ezgcd_bak)$ !*fullroots_bak := cons(!*fullroots,!*fullroots_bak)$ !*gcd_bak := cons(!*gcd,!*gcd_bak)$ !*mcd_bak := cons(!*mcd,!*mcd_bak)$ !*ratarg_bak := cons(!*ratarg,!*ratarg_bak)$ !*rational_bak := cons(!*rational,!*rational_bak)$ if null !*dfprint then algebraic(on dfprint)$ if null !*exp then algebraic(on exp)$ if null !*ezgcd then algebraic(on ezgcd)$ if null !*fullroots then algebraic(on fullroots)$ if !*gcd then algebraic(off gcd)$ if null !*mcd then algebraic(on mcd)$ if null !*ratarg then algebraic(on ratarg)$ if null !*rational then algebraic(on rational)$ !#if (neq version!* "REDUCE 3.6") !*nopowers_bak := cons(!*nopowers,!*nopowers_bak)$ !*allowdfint_bak := cons(!*allowdfint,!*allowdfint_bak)$ if null !*nopowers then algebraic(on nopowers)$ if null !*allowdfint then algebraic(on allowdfint)$ !#endif end$ symbolic operator recover_reduce_flags$ symbolic procedure recover_reduce_flags$ begin if !*dfprint neq car !*dfprint_bak then if !*dfprint then algebraic(off dfprint) else algebraic(on dfprint)$ !*dfprint_bak:= cdr !*dfprint_bak$ if !*exp neq car !*exp_bak then if !*exp then algebraic(off exp) else algebraic(on exp)$ !*exp_bak:= cdr !*exp_bak$ if !*ezgcd neq car !*ezgcd_bak then if !*ezgcd then algebraic(off ezgcd) else algebraic(on ezgcd)$ !*ezgcd_bak:= cdr !*ezgcd_bak$ if !*fullroots neq car !*fullroots_bak then if !*fullroots then algebraic(off fullroots) else algebraic(on fullroots)$ !*fullroots_bak:= cdr !*fullroots_bak$ if !*gcd neq car !*gcd_bak then if !*gcd then algebraic(off gcd) else algebraic(on gcd)$ !*gcd_bak:= cdr !*gcd_bak$ if !*mcd neq car !*mcd_bak then if !*mcd then algebraic(off mcd) else algebraic(on mcd)$ !*mcd_bak:= cdr !*mcd_bak$ if !*ratarg neq car !*ratarg_bak then if !*ratarg then algebraic(off ratarg) else algebraic(on ratarg)$ !*ratarg_bak:= cdr !*ratarg_bak$ if !*rational neq car !*rational_bak then if !*rational then algebraic(off rational) else algebraic(on rational)$ !*rational_bak:= cdr !*rational_bak$ !#if (neq version!* "REDUCE 3.6") if !*nopowers neq car !*nopowers_bak then if !*nopowers then algebraic(off nopowers) else algebraic(on nopowers)$ !*nopowers_bak:= cdr !*nopowers_bak$ if !*allowdfint neq car !*allowdfint_bak then if !*allowdfint then algebraic(off allowdfint) else algebraic(on allowdfint)$ !*allowdfint_bak:= cdr !*allowdfint_bak$ !#endif end$ algebraic procedure maklist(ex)$ % making a list out of an expression if not already if lisp(atom algebraic ex) then {ex} else if lisp(car algebraic ex neq 'LIST) then ex:={ex} else ex$ symbolic procedure add_to_last_steps(h)$ if length last_steps < 20 then last_steps:=cons(h,last_steps) else last_steps:=cons(h,reverse cdr reverse last_steps)$ symbolic procedure same_steps(a,b)$ if (car a = car b ) and ((a = b) or ((car a neq 'subst) and (car a neq 27 ) and (car a neq 11 ) )) then t else nil$ symbolic procedure in_cycle(h)$ begin scalar cpls1,cpls2,n,cycle; cpls1:=last_steps$ if car h='subst then << n:=0$ while cpls1 do << if same_steps(h,car cpls1) then n:=add1 n; cpls1:=cdr cpls1 >>$ cycle:= if n>2 then << % the subst. had been done already >=3 times write"A partial substitution has been repeated too often."$ terpri()$ write"It will now be made rigorously."$ terpri()$ t >> else nil % add_to_last_steps(h) is done outside for substitutions as it is not % clear at this stage whether the substitution will be performed >> else << n:=1$ while cpls1 and (not same_steps(h,car cpls1)) do <>$ if null cpls1 or ((reval {'PLUS,n,n})>length last_steps) then cycle:=nil else << cpls1:=cdr cpls1; cpls2:=last_steps$ while (n>0) and same_steps(car cpls2,car cpls1) do <>$ if (n=0) and print_ then << write if car h = 11 then "An algebraic length reduction" else if car h = 27 then "A length reducing simplification" else "A step", " was prevented"$ terpri()$ write"to avoid a cycle."$ terpri()$ >>$ cycle:=if n>0 then nil else t >>; if null cycle then add_to_last_steps(h)$ >>; return cycle end$ endmodule$ %******************************************************************** module solution_handling$ %******************************************************************** % Routines for storing, retrieving, merging and displaying solutions % Author: Thomas Wolf Dec 2001 symbolic procedure save_solution(eqns,assigns,freef,ineq,file_name)$ % input data are algebraic mode % eqns .. list of remaining unsolved equations % assigns .. list of computed assignments of the form `function = expression' % freef .. list of list of functiones either free or in eqns % ineq .. list of inequalities begin scalar s,levelcp,h,p,conti$ if file_name then s:=file_name else << s:=session_; levelcp:=reverse level_; while levelcp do <>; s:=explode s; s:=compress cons(car s,cons('s,cons('o,cdddr s)))$ >>$ sol_list:=union(list s,sol_list)$ out s; write"off echo$ "$ write"backup_:='("$terpri()$ for each h in freef do if p:=assoc(h,depl!*) then conti:=cons(p,conti); % The first sub-list is a list of dependencies, like ((f x y) (g x)) write"% A list of dependencies, like ((f x y) (g x))"$terpri()$ print conti$write" "$terpri()$ % The next sublist is a list of unsolved equations write"% A list of unsolved equations"$terpri()$ print eqns$write" "$terpri()$ % The next sublist is a list of assignments write"% A list of assignments"$terpri()$ print assigns$write" "$terpri()$ % The next sublist is a list of free or unresolved functions write"% A list of free or unresolved functions"$terpri()$ print freef$write" "$terpri()$ % The next sublist is a list of non-vanishing expressions write"% A list of non-vanishing expressions"$terpri()$ print ineq$terpri()$ write")$"$ % shorter but less clear: print list(conti,eqns,freef,ineq)$ write "end$"$terpri()$ shut s; return s end$ symbolic procedure print_indexed_list(li)$ begin scalar a,h$ terpri()$ h:=0$ for each a in li do << h:=add1 h; write"[",h,"]";terpri()$ mathprint a >> end$ symbolic procedure merge_two(s1,sol1,s2,sol2,absorb)$ % Is sol1 a special case of sol2 ? % If yes, return the new generalized solution sol2 with one less inequality. % If absorb then modify s2 and sol2 if s1 can be absorbed begin scalar eli_2,singular_eli,regular_eli,a,b,cond2,sb,remain_sb, singular_sb,regular_sb,c2,remain_c2,remain_num_c2,h, try_to_sub,try_to_sub_cp,num_sb,num_sb_quo,singular_ex, singular_ex_cp,ineq2,ine,ineqnew,ineqdrop,tr_merge, extra_par_in_s1,gauge_of_s2,gauge_of_s2_cp,did_trafo,n, remain_c2_cp,dropped_assign_in_s2,new_assign_in_s2$ % tr_merge:=t$ if tr_merge then <>$ % At first we list all lhs y_i in assignments y_i=... in sol2 eli_2:=setdiff(for each a in caddr sol2 collect cadr a,cadddr sol2); % We use setdiff because of assignments, like a6=a6 in sol2 % where a6 is a free parameter. % writing assignments of solution 2 as expressions to vanish cond2:=for each a in caddr sol2 collect {'PLUS,cadr a,{'MINUS,caddr a}}; % Do all substitutions a=... from sol1 for which % there is an assignment a=... in sol2 and % collecting the others as remain_sb cond2:=cons('LIST,cond2); sb:=caddr sol1; % all assignments of solution 1 while sb do << a:=car sb; sb:=cdr sb; if member(cadr a,eli_2) then << eli_2:=delete(cadr a,eli_2)$ cond2:=err_catch_sub(cadr a,caddr a,cond2) >> else remain_sb:=cons(a,remain_sb) >>$ eli_2:=append(eli_2,cadddr sol2)$ % eli_2 is now the list of new sol2 parameters % At this stage any sol2 conditions either become singular or zero. % The singular ones are collected in remain_c2. % The same again, now taking only numerators remain_c2:=cond2; cond2:=cdr cond2; c2:=nil$ h:=0$ while cond2 and (null c2 or zerop c2) do << c2:=car cond2; h:=add1 h; if tr_merge then <>$ % Is the numerator of c2 fulfilled by assignments of solution 1? sb:=remain_sb; % all remaining assignments of solution 1 while sb and c2 and not zerop c2 do << a:=car sb; sb:=cdr sb; c2:=algebraic(num(lisp(c2))); if tr_merge then b:=c2; c2:=err_catch_sub(cadr a,caddr a,c2); if tr_merge and (b neq c2) then << write"Sub: ";mathprint a$ if c2 then <> else <> >> >>$ if null c2 then remain_num_c2:=cons(car cond2,remain_num_c2); cond2:=cdr cond2 >>$ if c2 and not zerop c2 then return nil; % sol1 is not special case of sol2 if remain_num_c2 then << % can only occur if there were singular subst. write"Even substitutions in the numerator is giving "$terpri()$ write"singularities like for log(0)."$ terpri()$ return nil >>$ write"Substitutions in numerators give all zero"$terpri()$ % At this stage in the program either all is satisfied (remain_c2 = nil) % or only singular solution 2 assignments remain (remain_c2 <> nil) % but which vanish if numerators are taken. % We now want to find a different order of substitutions, especially % substituting for the free parameter functions of solution 2 % based on remain_sb to be done in remain_c2. % At first we sort all solution 1 assignments into regular_sb and singular_sb. % remain_c2 is not changed in this cond2:=remain_c2; sb:=remain_sb; % all remaining assignments of solution 1 while sb do << a:=car sb; sb:=cdr sb; h:=err_catch_sub(cadr a,caddr a,cond2); if null h then singular_sb:=cons(a,singular_sb) else regular_sb:=cons(a,regular_sb) >>$ if tr_merge then <>$ if tr_merge then <>$ if singular_sb then << write"Substitutions lead to singularities."$terpri()$ write"Solution ",s2," has to be transformed."$terpri() >>$ % We now make a list of vanishing expressions based on singular_sb % which when replaced by 0 in remain_c2 give singularities singular_ex:=for each a in singular_sb collect reval {'PLUS,cadr a,{'MINUS,caddr a}}; if tr_merge then << write"The following are expressions which vanish due to sol1 and"$ terpri()$ write"which lead to singularities when used for substitutions in sol2"$ terpri()$ mathprint cons('LIST,singular_ex) >>$ if tr_merge then << write"The following are all free parameters in sol2 for which there are"$ terpri()$ write"substitutions in sol1"$ terpri()$ >>$ singular_eli:=for each a in singular_sb collect cadr a; regular_eli:=for each a in regular_sb collect cadr a; if tr_merge then <>; if tr_merge then <>; % Before continuing we want to check whether the supposed to be more special % solution sol1 has free parameters which are not free parameters in the more % general solution sol2. That can cause problems, i.e. division through 0 % and non-includedness when in fact sol1 is included in sol2. extra_par_in_s1:=setdiff(cadddr sol1,cadddr sol2); if tr_merge then <>$ for each a in extra_par_in_s1 do << h:=caddr sol2$ while h and cadar h neq a do h:=cdr h; if null h then write"ERROR, there must be an assignment of a in sol2!" else << if tr_merge then << write"Assignment in ",s2," of a variable that is a free parameter in ", s1," :"$ terpri()$ mathprint car h$ >>$ dropped_assign_in_s2:=cons(car h,dropped_assign_in_s2); gauge_of_s2:=cons(algebraic(num(lisp({'PLUS,cadr car h, {'MINUS,caddr car h}}))), gauge_of_s2) >> >>$ gauge_of_s2:=cons('LIST,gauge_of_s2); if tr_merge then <>$ % We should not do all regular substitutions in gauge_of_s2 (tried that) % because some of them may set variables to zero which limits the % possibilities of doing transformations of remain_c2 % We now search for a substitution based on one of the equations % gauge_of_s2. The substitution is to be performed on remain_c2. % One sometimes has to solve for regular_eli as singular_eli % might appear only non-linearly. % try_to_sub:=append(regular_eli,singular_eli); try_to_sub:=append(singular_eli,regular_eli); n:=1; repeat << did_trafo:=nil; gauge_of_s2_cp:=cdr gauge_of_s2; while gauge_of_s2_cp do << sb:=reval car gauge_of_s2_cp$ gauge_of_s2_cp:=cdr gauge_of_s2_cp$ if not zerop sb then << try_to_sub_cp:=try_to_sub; if tr_merge then <>$ sb:=reval cons('TIMES,cons(1,sb)); if tr_merge then <>$ if not freeof(sb,a) and lin_check(sb,{a}) then << num_sb:=reval {'DIFFERENCE, sb,{'TIMES,a,coeffn(sb,a,1)}}; if tr_merge then <>$ singular_ex_cp:=singular_ex; while singular_ex_cp do << if tr_merge then <>$ if h then << gauge_of_s2:=err_catch_sub(cadr b,caddr b,gauge_of_s2); gauge_of_s2:=cons('LIST, for each gauge_of_s2_cp in cdr gauge_of_s2 collect algebraic(num(lisp(gauge_of_s2_cp)))); gauge_of_s2_cp:=nil$ new_assign_in_s2:=cons(b,new_assign_in_s2); did_trafo:=t$ write"In order to avoid a singularity when doing substitutions"$ terpri()$ write"the supposed to be more general solution was transformed using:"$ terpri()$ mathprint b$ if tr_merge then <>$ remain_c2:=h; h:=append(regular_sb,singular_sb); while h and a neq cadar h do h:=cdr h; if h then remain_c2:=append(remain_c2,list {'DIFFERENCE,caddar h,caddr b}); if tr_merge then <>$ singular_ex_cp:=nil; try_to_sub:=delete(a,try_to_sub); try_to_sub_cp:=nil; n:=n+1 >> else singular_ex_cp:=cdr singular_ex_cp >> else singular_ex_cp:=cdr singular_ex_cp >> % while singular_ex_cp >> % if car try_to_sub_cp passes first test >>$ % while try_to_sub_cp >> % if not zerop sb >>$ % while gauge_of_s2_cp >> until (did_trafo=nil)$ if tr_merge then << write"After completing the trafo the new list of parameters of"$ terpri()$ write"sol2 is: ",eli_2$terpri()$ write"sol1 has free parameters: ",cadddr sol1$terpri() >>$ if not_included(cadddr sol1,eli_2) then return << write"Something seems wrong in merge_sol(): after the transformation of"$ terpri()$ write"sol2, all free parameters of sol1 should be free parameters of sol2."$ terpri(); nil >> else << if tr_merge then << write"All free parameters of sol1 are free parameters of sol2"$ terpri() >> >>$ % Now all in remain_c2 has to become zero by using first substitutions % from regular_sb and substituting parameters from sol2 such that % the substituted expression has one of the singular_ex as factor. % We seek global substitutions, i.e. substitutions based on sol1 % which satisfy all sol2 conditions and not for each sol2 condition a % different set of sol1 based substitutions. Therefore substitutions % are done in the whole remain_c2. % try_to_sub are free parameters in sol2 that are contained in % regular_eli and which are therefore not in singular_eli and not free % parameters in sol1. They are to be substituted next because sol1 is % obviously singularity free, so we have to express sol2 in the same % free parameters, so we have to substitute for the free parameters fo % sol2 which are not free parameters of sol1. But we must not use the % same substitutions regular_sb which substitute for them as they lead % to singular substitutions afterwards. % try_to_sub:=memberl(cadddr sol2,regular_eli); % % write"try_to_sub=",try_to_sub$terpri()$ % % % We now search for a substitution in regular_sb which leads to a % % substitution of a member of try_to_sub, say p, ... % b:=regular_sb; % for each sb in b do << % sb_cp:=algebraic(num(lisp({'PLUS,cadr sb,{'MINUS,caddr sb}}))); % try_to_sub_cp:=delete(cadr sb,try_to_sub); % ... but the substitution % % does not originally % % have the form p=... . % while try_to_sub_cp do << % a:=car try_to_sub_cp; try_to_sub_cp:=cdr try_to_sub_cp; % if not freeof(sb_cp,a) and lin_check(sb_cp,{a}) then << % num_sb:={'DIFFERENCE, sb_cp,{'TIMES,a,coeffn(sb_cp,a,1)}}; % % singular_ex_cp:=singular_ex; % while singular_ex_cp do << % % Search for an expression causing a singular substitution % % which is a factor of the substituted expression for a % num_sb_quo:=reval {'QUOTIENT,num_sb,car singular_ex_cp}; % if (not pairp num_sb_quo) or % (car num_sb_quo neq 'QUOTIENT) then << % % i.e. num_sb is a multiple of one of members of singular_ex, HURRAY! % % Do the substitution in remain_c2 % h:=err_catch_sub(cadr sb,caddr sb,remain_c2); % if h then << % write"In order to avoid a singularity when doing substitutions"$ % terpri()$ % write"the supposed to be more general solution was transformed:"$ % terpri()$ % mathprint sb$ % remain_c2:=h; % singular_ex_cp:=nil; % regular_sb:=delete(sb,regular_sb); % try_to_sub:=delete(a,try_to_sub); % try_to_sub_cp:=nil; % >> else singular_ex_cp:=cdr singular_ex_cp % >> else singular_ex_cp:=cdr singular_ex_cp % >> % while singular_ex_cp % >> % if car try_to_sub_cp passes first test % >>$ % while try_to_sub_cp % >>$ % for each sb % Do the remaining regular_sb sb:=append(regular_sb,singular_sb); % all remaining assignments of solution 1 while sb and remain_c2 do << a:=car sb; sb:=cdr sb; remain_c2_cp:=remain_c2$ remain_c2:=err_catch_sub(cadr a,caddr a,remain_c2); if tr_merge then if null remain_c2 then <> else << write"Remaining substitution: ";mathprint a$ %write"remain_c2="$mathprint remain_c2 >> >>$ if null remain_c2 then remain_c2:=remain_c2_cp else remain_c2_cp:=remain_c2; % Drop all zeros. remain_c2_cp:=cdr remain_c2_cp$ while remain_c2_cp and zerop car remain_c2_cp do remain_c2_cp:=cdr remain_c2_cp; if remain_c2_cp then << % s1 is NOT a special case of s2 remain_c2_cp:=remain_c2$ if tr_merge then <>$ % Is there a contradiction of the type that the equivalence of two % assignments, a8=A (from sol1), a8=B (from sol2) requires 0=A-B % which got transformed into an expression C which is built only % from free parameters of sol1 and therefore should not vanish? h:=cadddr sol1; % all free parameters in sol1 while h and << if tr_merge then write"Substitution of ",car h," by: "$ repeat << % find a random integer for the free parameter a:=1+random(10000); % that gives a regular substitution if tr_merge then <>$ a:=err_catch_sub(car h,a,remain_c2_cp) >> until a; remain_c2_cp:=a; while a and ((not numberp car a) or (zerop car a)) do a:=cdr a; not a >> do h:=cdr h; if h then return << write"In the following S1 stands for ",s1,"and S2 stands for ",s2," . ", "Solution S1 fulfills all conditions of solution S2 when conditions", "are made denominator free. But, after rewriting solution S2 so that", "all free parameters of solution S1 are also free parameters of S2", "then the new solution S2 now requires the vanishing of an expression", "in these free parameters which is not allowed by S1. Therefore S1", "is not a special case of S2."$ nil >>$ if tr_merge and remain_c2_cp then <> else return << % return the new s2 as s1 IS a special case of s2 % Which inequality is to be dropped? ineq2:=car cddddr sol2$ while ineq2 do << ine:=car ineq2; % ine should not have denominators, so no extra precautions for substitution: for each a in caddr sol1 do ine:=reval(subst(caddr a,cadr a,ine)); if not zerop reval ine then ineqnew:=cons(car ineq2,ineqnew) else ineqdrop:=cons(car ineq2,ineqdrop)$ ineq2:=cdr ineq2 >>$ if absorb then << % delete the redundant solution sol_list:=delete(s1,sol_list); % system bldmsg ("rm %s",s1); % transform the general solution if that was necessary and % updating the list of free parameters h:=cons('LIST,caddr sol2); b:=cadddr sol2; if tr_merge then << write"h0="$print_indexed_list(h)$ write"dropped_assign_in_s2="$print_indexed_list(dropped_assign_in_s2)$ write"new_assign_in_s2="$print_indexed_list(new_assign_in_s2)$ >>$ for each a in dropped_assign_in_s2 do <>$ if tr_merge then <>$ for each a in reverse new_assign_in_s2 do if h then << b:=delete(reval cadr a,b)$ if tr_merge then <>$ h:=err_catch_sub(cadr a,caddr a,h); if h then h:=reval append(h,list a) >>$ if null h then write"A seemingly successful transformation of ",s2, "went singular when performing the transformation ", "finally on the whole solution." else % save the generalized solution save_solution(cadr sol2,cdr h,b,ineqnew,s2)$ >>; if absorb and null h then nil else << % report the merging if null ineqdrop then << write"Strange: merging ",s1," and ",s2," without dropping inequalities!"$ terpri()$ write"Probably ",s2," had already been merged with ",s1, " or similar before."$ terpri() >> else if print_ then << write"Solution ",s2," includes ",s1," by dropping "$ if length ineqdrop = 1 then write"inequality" else write"inequalities"$terpri()$ for each ine in ineqdrop do mathprint ine >>; s2 % the more general solution >> >> end$ symbolic operator merge_sol$ symbolic procedure merge_sol$ begin scalar s,sol_cp,sl1,sl2,s1,s2,s3,sol1,sol2,echo_bak$ if null session_ then ask_for_session() else << write "Do you want to merge solutions computed in this session,"$ terpri()$ if not yesp "i.e. since loading CRACK the last time? " then ask_for_session() >>$ % reading in sol_list setq(s,bldmsg("%w%w",session_,"sol_list")); in s; % % At fist sort sol_list by the number of free unknowns % for each s1 in sol_list do << % in s1; % s2:=if null cadddr backup_ then 0 else length cadddr backup_; % if cadr backup_ then s2:=s2 - length cadr backup_; % sol_cp:=cons((s2 . s1),sol_cp) % >>$ % sol_cp:=idx_sort(sol_cp)$ % while sol_cp do <>$ sol_cp:=sol_list$ sl1:=sol_cp$ if sl1 then while sl1 and cdr sl1 do << s1:=car sl1; sl1:=cdr sl1; %infile s1; echo_bak:=!*echo; semic!*:='!$; in s1$ !*echo:=echo_bak; sol1:=backup_; if print_ then <>$ sl2:=sl1; while sl2 do << s2:=car sl2; sl2:=cdr sl2; %infile s2$ echo_bak:=!*echo; semic!*:='!$; in s2$ !*echo:=echo_bak; sol2:=backup_; if print_ then <>$ if (null car sol1) and (null car sol2) then % algebraic problem if length cadddr sol1 < length cadddr sol2 then s3:=merge_two(s1,sol1,s2,sol2,t) else if length cadddr sol1 > length cadddr sol2 then s3:=merge_two(s2,sol2,s1,sol1,t) else <> >> else if null (s3:=merge_two(s1,sol1,s2,sol2,t)) then s3:=merge_two(s2,sol2,s1,sol1,t); if s3=s1 then sl1:=delete(s2,sl1) else % not to pair s2 later if s3=s2 then sl2:=nil % to continue with next element in sl1 >> >>; save_sol_list() end$ symbolic procedure save_sol_list$ begin scalar s$ setq(s,bldmsg("%w%w",session_,"sol_list")); out s; write"off echo$ "$ terpri()$ write"sol_list:='"$ print sol_list$write"$"$terpri()$ write "end$"$terpri()$ shut s end$ symbolic procedure ask_for_session$ begin scalar ps$ ps:=promptstring!*$ promptstring!*:="Name of the session in double quotes: "$ terpri()$session_:=termread()$ promptstring!*:=ps end$ symbolic operator pri_sol$ symbolic procedure pri_sol(sin,assgn,crout,html,solcount,fname,prind)$ % print the single solution sin begin scalar a,b,sout$ in sin$ if html then << setq(sout,bldmsg("%w%w%d%w",fname,"-s",solcount,".html")); out sout; write""$terpri()$ terpri()$ write""$terpri()$ write""$terpri()$ write"Solution ",solcount," to problem ",prind,""$terpri()$ write""$terpri()$ terpri()$ write""$terpri()$ terpri()$ write""$terpri()$ terpri() >>$ for each a in car backup_ do for each b in cdr a do algebraic(depend(lisp(car a),lisp b)); backup_:=cdr backup_; terpri()$ if html then write" "$ terpri()$terpri()$ if assgn or html then << if car backup_ then << if html then << write"

Equations

"$terpri()$ write"The following unsolved equations remain:"$terpri()$ write"
"$
   >>      else write"Equations:"$
   for each a in car backup_ do mathprint {'EQUAL,0,a}$
   if html then <"$terpri()>>
  >>$
  if html then <<
   write"
Expressions
"$terpri()$
   write"The solution is given through the following expressions:"$terpri()$
   write"
"$terpri()$
   for each a in cadr backup_ do mathprint a$
   write"
"$terpri()
  >>      else <<
   b:=nil;
   for each a in cadr backup_ do
   if not zerop caddr a then b:=cons(a,b);
   print_fcts(b,nil)$
  >>$
  terpri()$

  if html then <<
   write"
Parameters
"$terpri()$
   write"Apart from the condition that they must not vanish to give"$terpri()$
   write"a non-trivial solution and a non-singular solution with"$terpri()$
   write"non-vanishing denominators, the following parameters are free:"$terpri()$
   write"
 "$
   fctprint caddr backup_;
   write"
"$terpri()
  >>      else <<
   write length caddr backup_," free unknowns: "$ listprint caddr backup_;
   print_ineq(cadddr backup_)$
  >>
 >>$

 if html then <<
  write"
Relevance for the application:
"$
  terpri()$
  % A text for the relevance should be generated in crack_out()
%  write"The solution given above tells us that the system {u_s, v_s}"$
%  terpri()$
%  write"is a higher order symmetry for the lower order system {u_t,v_t}"$
%  terpri()$
%  write"where u=u(t,x) is a scalar function, v=v(t,x) is a vector"$
%  terpri()$
%  write"function of arbitrary dimension and f(..,..) is the scalar"$
%  terpri()$
%  write"product between two such vectors:"$
%  terpri()$
  write"
"
 >>$
 if crout or html then <<
  algebraic (
  crack_out(lisp cons('LIST,car backup_),
           lisp cons('LIST,cadr backup_),
           lisp cons('LIST,caddr backup_),
           lisp cons('LIST,cadddr backup_) ))$
 >>$
 if html then <<
  write"
"$terpri()$
  write"
"$terpri()$
  write""$terpri()$
  write""$terpri()$
  shut sout
 >>
end$

symbolic operator print_all_sol$
symbolic procedure print_all_sol$
begin scalar s,a,assgn,crout,natbak,print_more_bak,fname,solcount,
             html,prind,ps$

 write"This is a reminder for you to read in any file CRACK_OUT.RED"$
 terpri()$
 write"with a procedure CRACK_OUT() in case that is necessary to display"$
 terpri()$
 write"results following from solutions to be printed."$
 terpri()$ terpri()$

 if null session_ then ask_for_session() else <<
  write "Do you want to print solutions computed in this session,"$
  terpri()$
  if not yesp "i.e. since loading CRACK the last time? " then
  ask_for_session()$
  terpri()
 >>$

 % reading in sol_list
 setq(s,bldmsg("%w%w",session_,"sol_list"));
 in s;

 natbak:=!*nat$ print_more_bak:=print_more$ print_more:=t$
 if yesp "Do you want to generate an html file for each solution? "
 then <<
  html:=t$
  solcount:=0$
  terpri()$
  write "What is the file name (including the path)"$
  terpri()$
  write "that shall be used (in double quotes) ? "$
  terpri()$
  write "(A suffix '-si'  will be added for each solution 'i'.) "$
  ps:=promptstring!*$
  promptstring!*:=""$
  fname:=termread()$terpri()$
  write "What is a short name for the problem? "$
  prind:=termread()$
  promptstring!*:=ps$
  terpri()$
 >> else <<
  if yesp "Do you want to see the computed value of each function? "
  then assgn:=t$
  if yesp "Do you want procedure `crack_out' to be called? " then <<
   crout:=t;
   if flin_ and homogen_ then
   if yesp "Do you want to print less (e.g. no symmetries)? "
   then print_more:=nil$
   if not yesp
   "Do you want natural output (no if you want to paste and copy)? "
   then !*nat:=nil$
  >>$
 >>$
 for each a in sol_list do <<
  if html then solcount:=add1 solcount$
  pri_sol(a,assgn,crout,html,solcount,fname,prind)$
 >>$
 !*nat:=natbak;
 print_more:=print_more_bak
end$

symbolic procedure sol_in_list(set1,set2,sol_list2)$
begin scalar set2cp,s1,s2,found,sol1,sol2,same_sets,echo_bak$
 while set1 do <<
  s1:=car set1; set1:=cdr set1;
  %infile s1;
  echo_bak:=!*echo; semic!*:='!$; in s1$ !*echo:=echo_bak;
  sol1:=backup_;
  set2cp:=set2$
  found:=nil$
  while set2cp and not found do <<
   s2:=car set2cp; set2cp:=cdr set2cp;
   %infile s2;
   echo_bak:=!*echo; semic!*:='!$; in s2$ !*echo:=echo_bak;
   sol2:=backup_;
   found:=merge_two(s1,sol1,s2,sol2,nil)$
  >>;
  if not found then <<
   same_sets:=nil;
   if print_ then <<
    write"Solution ",s1," is not included in ",sol_list2$
    terpri()
   >>
  >>
 >>$
 return same_sets
end$

symbolic operator same_sol_sets$
symbolic procedure same_sol_sets$
begin scalar session_bak,set1,set2,sol_list1,sol_list2,echo_bak$
 session_bak:=session_;
 write"Two sets of solutions are compared whether they are identical."$

 write"What is the name of the session that produced the first set of solutions?"$
 terpri()$
 write"(CRACK will look for the file `sessionname'+`sol_list'.)"$terpri()$
 ask_for_session()$

 % reading in sol_list
 setq(sol_list1,bldmsg("%w%w",session_,"sol_list"));
 %infile sol_list1;
 echo_bak:=!*echo; semic!*:='!$; in sol_list1$ !*echo:=echo_bak;
 set1:=sol_list$

 write"What is the name of the session that produced the second set of solutions?"$
 terpri()$
 ask_for_session()$

 % reading in sol_list
 setq(sol_list2,bldmsg("%w%w",session_,"sol_list"));
 %infile sol_list2;
 echo_bak:=!*echo; semic!*:='!$; in sol_list2$ !*echo:=echo_bak;
 set2:=sol_list$

 session_:=session_bak$

 % 1. Check that all solutions in set1 are included in set2.

 sol_in_list(set1,set2,sol_list2)$
 sol_in_list(set2,set1,sol_list1)$

end$

% some PSL specific hacks

!#if (memq 'psl lispsystem!*)
  symbolic procedure delete!-file(fi);
   if memq('unix,lispsystem!*) then
        system bldmsg("rm '%s'",fi) else
        system bldmsg("del ""%s""",fi);
 !#endif

endmodule$

end$

mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/applysym.rlg0000644000175000017500000002032711527635055024173 0ustar  giovannigiovanniFri Feb 18 21:27:34 2011 run on win32
load crack,applysym$


%*******************************************************************%
%                                                                   %
%                    A P P L Y S Y M . T S T                        %
%                    -----------------------                        %
%  applysym.tst contains test examples to test the procedure        %
%  quasilinpde in the file applysym.red.                            %
%                                                                   %
%  Author: Thomas Wolf                                              %
%  Date:   22 May 1998                                              %
%                                                                   %
%  You need crack.red and applysym.red to run this demo.            %
%  To use other contents of the program applysym, not demonstrated  %
%  in this demo you need the program liepde.red.                    %
%                                                                   %
%  To run this demo you read in files with                          %
%     in "crack.red"$                                               %
%     in "applysym.red"$                                            %
%  or, to speed up the calculation you compile them before with     %
%     faslout "crack"$                                              %
%     in "crack.red"$                                               %
%     faslend$                                                      %
%     faslout "applysym"$                                           %
%     in "applysym.red"$                                            %
%     faslend$                                                      %
%  and then load them with                                          %
%     load crack,applysym$                                          %
%                                                                   %
%*******************************************************************%

load crack;



lisp(depl!*:=nil)$

     % clearing of all dependencies
%setcrackflags()$
lisp(print_:=nil)$


on dfprint$



comment
-------------------------------------------------------
This file is supposed to provide an automatic test of
the program APPLYSYM. On the other hand the application
of APPLYSYM is an interactive process, therefore the
interested user should inspect the example described
in APPLYSYM.TEX which demonstrates the application
of symmetries to integrate a 2nd order ODE.
Here the program QUASILINPDE for integrating first
order quasilinear PDE is demonstrated.
The following equation comes up in the elimination
of resonant terms in normal forms of singularities
of vector fields (C.Herssens, P.Bonckaert, Limburgs
Universitair Centrum/Belgium, private communication);

write"-------------------"$


-------------------

lisp(print_:=nil)$



depend w,x,y,z$


QUASILINPDE( df(w,x)*x+df(w,y)*y+2*df(w,z)*z-2*w-x*y,  w,  {x,y,z} )$


   x*y
{{-----,
    z

    - log(z)*x*y + 2*w
  ---------------------,
            z

      x
  ---------}}
   sqrt(z)

nodepend w,x,y,z$



comment
-------------------------------------------------------
The result means that w is defined implicitly through 

        x*y    - log(z)*x*y + 2*w      y              
0 = ff(-----,---------------------,---------)         
         z             z            sqrt(z)           

with an arbitrary function ff of 3 arguments. As the PDE
was linear, the arguments of ff are such that we can 
solve for w:                                   

                        x*y      y             
w = log(z)*x*y/2 + z*f(-----,---------)        
                         z    sqrt(z)          

with an arbitrary function f of 2 arguments.
-------------------------------------------------------
The following PDEs are taken from E. Kamke,
Loesungsmethoden und Loesungen von Differential-
gleichungen, Partielle Differentialgleichungen
erster Ordnung, B.G. Teubner, Stuttgart (1979);


write"-------------------"$


-------------------
% equation 1.4 ----------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*df(z,x)-y, z, {x,y})$


{{log(x)*y - z,y}}

write"-------------------"$


-------------------
% equation 2.5 ----------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x**2*df(z,x)+y**2*df(z,y), z, {x,y})$


    - x + y
{{----------,z}}
     x*y

write"-------------------"$


-------------------
% equation 2.6 ----------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( (x**2-y**2)*df(z,x)+2*x*y*df(z,y), z, {x,y})$


          2    2
      - (x  + y )
{{z,--------------}}
          y

write"-------------------"$


-------------------
% equation 2.7 ----------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( (a0*x-a1)*df(z,x)+(a0*y-a2)*df(z,y), z, {x,y})$


    a1*y - a2*x
{{----------------,z}}
   a1*(a0*x - a1)

write"-------------------"$


-------------------
% equation 2.14 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( a*df(z,x)+b*df(z,y)-x**2+y**2, z, {x,y})$


   2  3            2      3        2  2      2  3
{{a *y  - 3*a*b*x*y  - 3*b *z + 3*b *x *y - b *y ,

  a*y - b*x}}

write"-------------------"$


-------------------
% equation 2.16 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*df(z,x)+y*df(z,y)-a*x, z, {x,y})$


            - a*x
{{a*x - z,--------}}
             y

write"-------------------"$


-------------------
% equation 2.20 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( df(z,x)+df(z,y)-a*z, z, {x,y})$


   a*x
{{e   ,x - y}}

write"-------------------"$


-------------------
% equation 2.21 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( df(z,x)-y*df(z,y)+z, z, {x,y})$


   x    x
{{e *z,e *y}}

write"-------------------"$


-------------------
% equation 2.22 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( 2*df(z,x)-y*df(z,y)+z, z, {x,y})$


   x/2    x/2
{{e   *z,e   *y}}

write"-------------------"$


-------------------
% equation 2.23 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( a*df(z,x)+y*df(z,y)-b*z, z, {x,y})$


   (b*x)/a   y
{{e       ,------}}
             x/a
            e

write"-------------------"$


-------------------
% equation 2.24 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*(df(z,x)-df(z,y))-y*df(z,y), z,{x,y})$


{{x*(x + 2*y),z}}

write"-------------------"$


-------------------
% equation 2.25 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*df(z,x)+y*df(z,y)-az, z, {x,y})$


{{y,x}}

write"-------------------"$


-------------------
% equation 2.26 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*df(z,x)+y*df(z,y)-z+x**2+y**2-1, z, {x,y})$


    2    2
   x  + y  + z + 1   x
{{-----------------,---}}
          y          y

write"-------------------"$


-------------------
% equation 2.39 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( a*x**2*df(z,x)+b*y**2*df(z,y)-c*z**2, z, {x,y})$


   b*y - c*z
{{-----------,
     c*y*z

    - a*x + b*y
  --------------}}
      a*x*y

write"-------------------"$


-------------------
% equation 2.40 ---------------------
lisp(depl!*:=nil)$


depend z,x,y$


QUASILINPDE( x*y**2*df(z,x)+2*y**3*df(z,y)-2*(y*z-x**2)**2, z,
             {x,y})$


           4           2        2
   log(y)*x  - log(y)*x *y*z - y *z
{{----------------------------------,
             2   2
            x *(x  - y*z)

      x
  ---------}}
   sqrt(y)

write"-------------------"$


-------------------
% equation 3.12 ---------------------
lisp(depl!*:=nil)$


depend w,x,y,z$


QUASILINPDE( x*df(w,x)+(a*x+b*y)*df(w,y)+(c*x+d*y+f*z)*df(w,z), w,
             {x,y,z})$


                                                           2
    - a*d*x + b*c*x + b*f*z - b*z - c*f*x - d*f*y + d*y - f *z + f*z
{{-------------------------------------------------------------------,
                          f             2
                         x *(b*f - b - f  + f)

     d*(a*x + b*y - y)
  -----------------------,
    b   2
   x *(b  - b*f - b + f)

  w}}

write"-------------------"$


-------------------
% end -------------------------------

lisp(depl!*:=nil)$


end$


Time for test: 530 ms, plus GC time: 31 ms
@@@@@ Resources used: (1 6 95 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crdec.red0000644000175000017500000013704611526203062023356 0ustar  giovannigiovanni%********************************************************************
module decoupling$
%********************************************************************
%  Routines for decoupling de's
%  Author: Andreas Brand untill 1995,
%          updates and extensions by Thomas Wolf
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure which_deriv(p,q)$
%  yields a list of variables and orders
%  such that one gets at least q by differentiating p w.r.t. the vars
%  p,q: lists of variables and orders
begin scalar l,n,a$
while q do
   if (a:=member(car q,p)) then
      <>
      else n:=1$
      n:=n-(if pairp cdr a and numberp cadr a then cadr a else 1)$
      if n>0 then
               <1 then l:=cons(n,l)>> >>
   else
      <> >>$
return append(reverse l,q)$
end$

symbolic procedure dec_ld_info(p,q,simpp,simpq,f,vl,rl)$
%  gets leading derivatives of f in p and q wrt. vars order vl
%  and the lists of variables and orders for differentiation
begin scalar s,l,l1,l1d,l2,l2d,vl1,vl2,d1,d2,ld1,ld2,wd1,wd2,
             caar_ld,found$
 %
 % if (p has more variables than q) or
 %    (f is not leading function of p)
 % => simpp = t => p must be simplified with (deriv.s of) q
 % if (q has more variables than p) or
 %    (f is not leading function of q)
 % => simpq = t => q must be simplified with (deriv.s of) p
 %
 % vl1 holds the list of _ordered_ variables of p
 % vl2 holds the list of _ordered_ variables of q
 %
 % list all powers of derivatives of f in p as l1 and in q as l2
 %

 if simpp and simpq then return nil$

 vl1:=intersection(vl,get(p,'vars))$
 vl2:=intersection(vl,get(q,'vars))$

 % collect all powers of all derivatives of f
 %
 for each a in get(p,'derivs) do if caar a=f then l1:=cons(a,l1)$
 l1:=sort_derivs(reverse l1,list f,vl1)$
 %
 % l1 is a list of _all_ derivatives of f in p _sorted_ stored as a
 % dotted pair, e.g. ((f x 2 y) . 5) would be f_{xxy}^5, or more
 % generally ((f_1 . power) (f_2 . power) ... )
 %
 %terpri()$write "l10=",l1$
 %
 % keep only highest power of each derivative in l1
 l:=nil$
 for each a in l1 do if not member(cdar a,l) then <<
  l:=cons(cdar a,l)$
  l1d:=cons(list(cdar a,absdeg(cdar a),cdr a),l1d)
 >>$
 %
 % cdar a is the list of derivatives so we are making sure that our
 % list l1 has no repetitions
 %
 l1 :=reverse l$   % e.g. l1  = ( (x 2 y)       (x y 2)      ...)
 l1d:=reverse l1d$ % e.g. l1d = (((x 2 y),3,1) ((x y 2),3,2) ...)

 %
 % The above now applies but with q and l2 instead of p and l1
 %
 % collect all powers of all derivatives of f
 %
 for each a in get(q,'derivs) do if caar a=f then l2:=cons(a,l2)$
 l2:=sort_derivs(reverse l2,list f,vl2)$
 %terpri()$write "l20=",l2$
 % keep only highest power of each derivative in l2
 l:=nil$
 for each a in l2 do if not member(cdar a,l) then <<
  l:=cons(cdar a,l)$
  l2d:=cons(list(cdar a,absdeg(cdar a),cdr a),l2d)
 >>$
 l2 :=reverse l$   % e.g. l2 =  ( (x 2 y)       (x y 2)      ...)
 l2d:=reverse l2d$ % e.g. l2d = (((x 2 y),3,1) ((x y 2),3,2) ...)

 % At this point we have two lists, l1d and l2d resp. containing the
 % sorted list of all derivatives of the function f in p and q
 % together with their highest power

 % At first we note the leading derivative in l1d with its power
 % and check whether there is a derivative in l2d which has in no variable
 % a lower derivative or and either has a higher derivative in at least
 % one variable, or is not of lower degree.

 if not simpp then <<
   %p may be differentiated and q be substituted or new equ. added
   caar_ld:=caar l1d$
   d1:=cadar  l1d$
   d2:=caddar l1d$
   l:=l2d$
   while l and ((d1>
       % At this point we compare the degree of the highest
       % derivative of l1 + number of diff. in order to get the
       % leading deriv. of l2 (aliased to l)
                                else l:=cdr l
   >>
 >>$

 if simpq and null found then return nil;

 % Now, either l is nil and ld2 = leading deriv. of l2 (i.e. highest
 % deriv. of f in q) [this is the case in which leading deriv. in l2
 % can be obtained by diff. of the leading deriv. in l1] OR
 % ld2 is nil and l contains the rest of the deriv. of l2 except the
 % leading one [in this case we _cannot_ obtain the leading deriv. in
 % l2 by diff. the leading deriv. in l1].

 if (not ld2) and (not simpq) then <<
   %
   % We cannot get to the leading deriv. in l2 by diff. of leading
   % deriv. in l1.
   % We now try the opposite way, we try to diff. something in l2 to
   % get into l1.
   %
   caar_ld:=caar l2d$
   d1:=cadar  l2d$
   d2:=caddar l2d$
   l:=l1d$
   found:=nil$
   while l and ((d1>
                                else l:=cdr l
   >>
 >>$

 if simpp and null found then return nil;

 % We now have either ld2 non-nil, i.e. we can get to leading derv. in
 % l2 by differentiation of terms in l1 OR we have ld1 non-nil in
 % which case we have the opposite situation. If neither are non-nil
 % then we have to cross-differentiate to get the ld to match.
 %
 % What we return is
 %
 % ( (s ld(l1)) (nil ld(l2)) )         [ld2 non-nil] or
 % ( (nil ld(l1)) (s ld(l2)) )         [ld1 non-nil] or
 % ( (v ld(l1)) (w ld(l2)) )           [both ld1 _and_ ld2 nil]
 %
 % where v and w are the required diff. to get to ld2 and ld1 resp.
 % and s is the required diff. for the non-nil cases.
 %
 % It is to be interpreted as:
 %
 % Either "diff. ld(l1) by s to get ld(l2)" or
 %               "diff. ld(l2) by s to get ld(l1)" or
 %               "diff. ld(l1) by wd1 and ld(l2) by wd2 to get the
 %               ld's to match".
 %

 return
 if ld2 then cons(cons(s,caar l1d),cons(nil,ld2)) else
 if ld1 then cons(cons(nil,ld1),cons(s,caar l2d)) else <<
   wd1:=which_deriv(caar l1d,caar l2d)$
   wd2:=which_deriv(caar l2d,caar l1d)$
   if (simpq and wd2) or
      (simpp and wd1) or
      (rl and wd1 and wd2) then nil
   else cons(cons(wd1,caar l1d),
             cons(wd2,caar l2d))
 >>
end$

symbolic procedure diffeq(f,sd,r)$
% input of how often equation r is to be differentiated
% sd is the resulting derivative that is to be substituted
% with another equation, eg   sd=(x,2,y)
begin scalar rdif,rd,contradic,a,ad,b,bd,resu,must_be_subst$
  terpri()$
  write"How often is equation ",r," to be differentiated?"$
  terpri()$
  write"(just `;' for no differentiation or, for example, `x,y,2;' ): "$
  rdif:=termlistread()$
  rd:=get(r,'derivs)$
  while rd and null contradic do <<
    a:=caar rd;  % only the differentiations, not the degree
    rd:=cdr rd$
    if f=car a then <<
      ad:=cdr a$
      if cdr a then a:=cons('DF,a)
               else a:=car a; % a is now the function/full derivative
      if null rdif then b:=a else
                        b:=reval cons('DF,cons(a,rdif));
      if pairp b then bd:=cddr b
                 else bd:=nil$
      % There must not result a derivative from differentiating
      % equation r which is a derivative of sd
      if zerop b then <<
        write "The function ",f," differentiated that way gives zero."$
        contradic:=t$
      >>         else
      if (null which_deriv(bd,sd)) and
               which_deriv(sd,bd)  then
      if null rdif then must_be_subst:=b
                   else <<
        contradic:=t$ % sd,r,rdif are not compatible
        terpri()$
        write"This differentiation of equation ",r,
             " will generate a derivative ",b$
        terpri()$
        write" which is a derivative of the derivative to be eliminated."$
        terpri()$
      >>                      else
      if bd = sd then resu:={r,rdif,ad}
    >>
  >>$
  return if contradic or null resu then nil
                                   else resu . must_be_subst
end$

symbolic procedure read_sub_diff(p,q)$
begin scalar ps,s,l0,l,m0,m1,f,sd,info_p,info_q,contradic,let_conflict$
  ps:=promptstring!*$
  promptstring!*:=""$
  terpri()$
  write"What is the derivative to be eliminated? "$
  write"(e.g.  df(f,x,y,2); or f; ) "$terpri()$
  l0:=termxread()$
  l:=reval l0$
  % tests whether the input l is ok
  if null l then return nil else
  if not pairp l then if l0 neq l then let_conflict:=t else
                 else % pairp l
  if car l neq 'DF then if car l0 neq 'DF then <<
    write"Not a derivative!"$ terpri()$
    return nil
  >>                                      else let_conflict:=t
                   else
  if cadr l neq cadr l0 then let_conflict:=t
                        else <<
   m0:=cddr l0; m1:=cddr l;
   while m1 and null let_conflict do
   if fixp car m1 then m1:=cdr m1 else <<
    if no_of_v(car m1,m1) neq no_of_v(car m1,m0) then let_conflict:=t;
    m1:=cdr m1
   >>
  >>$
  if let_conflict then <<
   write "Due to a LET-rule in operation this elimination ",
         "is not possible."$terpri()$
   write "To delete a LET-rule use 'cr'."$terpri()$
   return nil
  >>$

  if pairp l then <>
             else <>$
  info_p:=diffeq(f,sd,p)$
  if info_p then info_q:=diffeq(f,sd,q)$

  promptstring!*:=ps$
  return
  if info_p and info_q then <<
    if null cadar info_p and cadar info_q then s:=p else
    if null cadar info_q and cadar info_p then s:=q else
    if cadar info_p and cadar info_q then s:=nil else <<
      terpri()$
      write"Which equation is to be substituted? Input ",p," or ",q,": "$
      repeat
      s:=reval termread()
      until (s=p) or (s=q)
    >>$
    if s=p and cdr info_q then <<
      contradic:=t$
      terpri()$
      write"The derivative ",cdr info_q," would enter ",p$
      terpri()$
      write" which is a derivative of the derivative to be substituted."$
    >>$
    if s=q and cdr info_p then <<
      contradic:=t;
      terpri()$
      write"The derivative ",cdr info_p," would enter ",q$
      terpri()$
      write" which is a derivative of the derivative to be substituted."$
    >>$
    if contradic then nil
                 else {car info_p,car info_q,l,s,nil} . 1
    % returns the same kind of result as dec_info
  >>                   else nil
end$

symbolic procedure dec_info(p,q,f,vl,rl,ordering)$
% yields information for a decouple reduction step
% i.e. ((info_1
%        info_2
%        deriv_to_eliminate
%        equ_to_be_subst
%        whether_one_equation_must_be_substituted % important for elim. techn.
%       ).num_value)
% where num_value is a measure of cost, e.g.
% result has form (((e4 (x 2 y) (y z))
%                   (e5 (z) (x 2 y 2)) (df f x 2 y 2 z) nil nil) . num_value)
% Criteria:   a) the function f must depend on all vars
%             b) the function and all their derivatives must occur
%                polynomially
begin scalar a,b,l,l1,info,m,n,fp,fq,fpmq,fqmp,s,lenp,lenq,dp,dq,
             simpp,simpq,let_conflict$
  %
  % 'length is the property containing the expression length
  %
  if expert_mode then return read_sub_diff(p,q)$

  lenp:=get(p,'length)$
  lenq:=get(q,'length)$
  if rl and ((lenp*lenq)>max_red_len) then return nil;

  a:=get(p,'vars); b:=get(q,'vars);
  simpp:=(null get(p,'allvarfcts)) or (f neq caaar get(p,'derivs))$
  simpq:=(null get(q,'allvarfcts)) or (f neq caaar get(q,'derivs))$
         % star-equn. or f is not leading function
  l:=dec_ld_info(p,q,simpp,simpq,f,vl,rl)$
  if not l then <<
    add_both_dec_with(ordering,p,q,rl)$
    return nil
  >>$
  %
  % l:= dec_ld_info(p,q,f,vl,rl) returns a list of lists, from which
  % a := caar l sets a to be the differentiations required to get
  % the ld(p) w.r.t. f to match that of ld(q) w.r.t. f,
  % b := caadr l sets b to be the differentiations required to get
  % the ld(q) w.r.t. f to match that of ld(q) w.r.t. f.
  %
  % l1 := cadadr l sets l1 to be the derivative in q which we
  % eliminate, similarly l is the derivative in p which we elim.
  %
  a:=caar l$             % a are the differentiations of p
  b:=cadr l$             % b are the differentiations of q
  if struc_eqn and
     ((a and b and (not freeof(algebraic struc_done,f))) or
      % no integrab. cond.s for functions in struc_done
      ((get(p,'no_derivs)>0) and (get(q,'no_derivs)=0))  or
      ((get(p,'no_derivs)=0) and (get(q,'no_derivs)>0))
      % not using algebr. conditions to simplify diff. cond.
     ) then return nil;
  l1:=cddr l$
  l:=cdar l$
  % Test whether there is a let-rule in operation which changes the
  % target derivative
  if (null a) and (null l) then
  if f neq reval f then let_conflict:=t
                   else    else <<
   m:=reval cons('DF,cons(f,append(l,a)));
   if (not pairp m) or
      (car m neq 'DF) or
      (cadr m neq f) then let_conflict:=t
                     else <<
    m:=cddr m$
    while m and null let_conflict do
    if fixp car m then m:=cdr m else <<
     if (no_of_v(car m,a)+no_of_v(car m,l)) neq
         no_of_v(car m,m)                       then let_conflict:=t;
     m:=cdr m
    >>
   >>
  >>$
  if let_conflict then <<
   if print_ then <<
    write "Due to a let-rule in operation equations ",
          p,",",q," will not be paired."$terpri()$
   >>$
   add_both_dec_with(ordering,p,q,rl)$
   return nil
  >>$

  % s is the equation to be substituted
  if a and not b then s:=q                 % p will be diff.
  else if b and not a then s:=p            % q will be diff.
  else if not (a or b) then                % no diff., only reduction
  if struc_eqn and l and l1 then <<
    % 2 structural equations, both with one or more derivatives
    % --> equation with more derivatives is substituted
    % The case below would work, only this may need fewer substitutions
    m:=get(p,'no_derivs)$
    n:=get(q,'no_derivs)$
    if m>n then s:=p else
    if mget(q,'length) then s:=p
                                     else s:=q
  >>           else <<
    dp:=get(p,'derivs)$
    dq:=get(q,'derivs)$
    repeat <<
      s:=total_less_dfrel(car dp,car dq,ftem_,vl)$
      dp:=cdr dp$
      dq:=cdr dq
    >> until (s neq 0) or (null dp) or (null dq)$
    if (s=t) or ((null dp) and dq) then s:=q
                                   else s:=p
  >>$

  fp:=get(p,'allvarfcts)$ % functions of all vars in p
  fq:=get(q,'allvarfcts)$ % functions of all vars in q

  % If a pde will be replaced by a pde with more fcts of all vars
  % then this pairing will have a lowered priority
  fqmp:=length setdiff(fq,fp);
  fpmq:=length setdiff(fp,fq);
  if nil then
  if tr_decouple then << terpri()$
    write"p=",p," q=",q," s=",s," lfp=",length fp,
         " lfq=",length fq," lfu=",length union(fp,fq),
         " fqmp=",fqmp," fpmq=",fpmq
  >>$
  m:=(1.5^absdeg(a)*lenp+1.5^absdeg(b)*lenq)*
     (length union(fp,fq))**20$
  if nil then
  if tr_decouple then write" m2=",m;
  if s then <<
    % the equation s will be replaced by the new one
    % --> if (null struc_eqn) and fcteval(s,nil) then m:=m*10**7;
    % The above line has been commented out because fcteval takes
    % much time the first time it is called and substitutions
    % are to be done before decoupling anyway
    if (s=q) and (lenp>lenq) then m:=(m*lenp)/lenq else
    if (s=p) and (lenq>lenp) then m:=(m*lenq)/lenp;
    if (s=p) and (fqmp>0) then m:=m*10**(2*fqmp) else
    if (s=q) and (fpmq>0) then m:=m*10**(2*fpmq);
    if struc_eqn then
    if ((a and is_algebraic(p)) or
        (b and is_algebraic(q))    ) then m:=m*10**100 else
    if is_algebraic(p) and is_algebraic(q) then m:=m/10**5;
  >>   else
  % Enlarge m because extra equation is generated (temp. idea)
  m:=m*10$
  % Non-linearity in largest derivative not taken care of.
  if nil then
  if tr_decouple then write" m3=",m;
  info:=cons(list(list(p,a,l),
                  list(q,b,l1),
                  if (null a) and
                     (null l) then f
                              else reval cons('DF,cons(f,append(l,a))),
                  s,
                  simpp or simpq
                 ),
             m)$
  return info$
end$

%symbolic procedure dec_put_info(l,rl)$
%% l has form ((e4 (x 2 y) (y z))
%%             (e5 (z) (x 2 y 2)) (df f x 2 y 2 z) nil)
%% puts informations for decouple reduction step
%% result: ((df f x 2 y 2 z) e4 e5 nil)
%if l then
%begin scalar f$
%  put(caar l,'dec_info,cadar l)$     % saves (x 2 y) for e4
%  put(caadr l,'dec_info,cadadr l)$   % saves (z)     for e5
%  if (cadar l) and (cadadr l) then << % if both eq. are diff.
%    f:=caddr l;
%    if pairp f then f:=cadr f;
%    add_both_dec_with(f,caar l,caadr l,rl)$
%  >>$
%  return list(caddr l,caar l,caadr l,cadddr l)$
%end$

% symbolic procedure dec_put_info(f,l)$
% % put informations for decouple reduction step
% % result: (deriv_to_eliminate pde_1 pde_2)
% if l then
% begin scalar a,b$
%    put(caar l,'dec_info,cadar l)$
%    a:=get(caar l,'dec_with)$
%    b:=assoc(f,a)$
%    a:=delete(b,a)$
%    if b then b:=cons(f,cons(caadr l,cdr b))
%         else b:=list(f,caadr l)$
%    put(caar l,'dec_with,cons(b,a))$
%    put(caadr l,'dec_info,cadadr l)$
%    a:=get(caadr l,'dec_with)$
%    b:=assoc(f,a)$
%    a:=delete(b,a)$
%    if b then b:=cons(f,cons(caar l,cdr b))
%         else b:=list(f,caar l)$
%    put(caadr l,'dec_with,cons(b,a))$
% return list(caddr l,caar l,caadr l)$
% end$

%% symbolic procedure dec_info_leq(p,q)$
%% %  relation "<=" for decouple informations
%% if p and q then
%%    if not (cadar car p and cadadr car p) then
%%       if not (cadar car q and cadadr car q) then (cdr p<=cdr q)
%%                                     else p
%%    else if cadar car q and cadadr car q then (cdr p<=cdr q)
%%                                 else nil
%% else p$

symbolic procedure dec_info_leq(p,q)$
%  relation "<=" for decouple informations
if p and q then (cdr p<=cdr q)
else if p then p
else q$

symbolic procedure dec_and_fct_select(pdes,vl,rl,hp,ordering)$
% select 2 pdes for decoupling
% if rl then one pde must be simplified with the help of
% another one and reduce its length
% if hp then only high priority decouplings (eqns with max 3-4 functions)
begin scalar min,f,l,l1,l2,done_pdes,car_pdes,len,
      d_car_pdes,val_car_pdes,val_p,d_p,w1,w2,rtn,f_in_flin,allvarfl$
  while pdes and null rtn do <<
    car_pdes:=car pdes;
    allvarfl:=get(car_pdes,'allvarfcts);
    if expert_mode or
       (flagp(car_pdes,'to_decoup) and allvarfl and
        ((null hp) or (length(allvarfl)<4))         ) then
    <>
                                         else
              if quick_decoup and l1 and cadddr car l1 and
                 ((null struc_eqn)                    or
                  ((null is_algebraic(car_pdes)) and
                   (null is_algebraic(p       ))     )  )
              then rtn:=car l1
              else if l1 then l2:=cons(l1,l2)
       >>
      >>

    >>$
    done_pdes:=cons(car_pdes,done_pdes)$
    pdes:=cdr pdes
  >>$
  if rtn then return rtn$

  %--- l2 is the list of possible pairings of 2 equations
  %--- pick one of these pairings
  l1:=nil;
  %--- l1 is the list of equations which still can be reduced
  %--- and where f=car get(equ,'allvarfcts), i.e. equations
  %--- which must not be used for generating new equations
  %
  %--- each l in l2 has the form
  %--- (((e4 (x 2 y) (y z)) (e5 (z) (x 2 y 2))
  %---  (df f x 2 y 2 z) nil nil) . num_value)
  for each l in l2 do <<
    f:=caddar l;
    if pairp f then f:=cadr f;
    if (caaar l = cadddr car l) and  % if caaar  l will be subst.
       get(caaar l,'allvarfcts) and
       (f=car get(caaar l,'allvarfcts))
    then l1:=union(list(caaar l),l1);
    if (caadar l = cadddr car l) and % if caadar l will be subst.
       get(caadar l,'allvarfcts) and
       (f=car get(caadar l,'allvarfcts))
    then l1:=union(list(caadar l),l1);
  >>;
  %--- Test that no new equation will be generated from an
  %--- equation from which the leading derivative can still be
  %--- reduced
  for each l in l2 do
  if ((cadaar l = nil)                              or
      (cadr cadar l = nil)                          or
      (freeof(l1,caaar  l) and freeof(l1,caadar l))    ) and
     dec_info_leq(l,min)
  then min:=l;
  if min then <<
   l:=car min$
   if (cadar l) and (cadadr l) then << % if both eq. are diff.
     f:=caddr l;
     if pairp f then f:=cadr f;
     add_both_dec_with(ordering,caar l,caadr l,rl)$
   >>$
   return l     % dec_put_info(car min,rl)$
  >>
end$

symbolic procedure err_catch_elimin(p,ltp,dgp,q,ltq,dgq,x,once)$
begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak;
 bak:=max_gc_counter$ max_gc_counter:=my_gc_counter+max_gc_elimin;
 kernlist!*bak:=kernlist!*$
 kord!*bak:=kord!*$
 bakup_bak:=backup_;backup_:='max_gc_elimin$
 h:=errorset({'elimin,mkquote p,mkquote ltp,mkquote dgp,
                      mkquote q,mkquote ltq,mkquote dgq,
                      mkquote x,mkquote once},nil,nil)
    where !*protfg=t;
 kernlist!*:=kernlist!*bak$
 kord!*:=kord!*bak;
 erfg!*:=nil;
 max_gc_counter:=bak;
 backup_:=bakup_bak;
 return if errorp h then nil
                    else car h
end$

symbolic procedure elimin(p,ltp,dgp,q,ltq,dgq,x,once)$
% returns {resulting_eqn, multiplier_of_ddpcp, multiplier_of_ddqcp}
begin
 scalar dgs,s,flg,quoti,lts,
        fcpp,fcqp,fcsp,
        fcpq,fcqq,fcsq$

 if dgp > dgq then << flg:=t; dgs:=dgq >>
              else dgs:=dgp$

 fcpp:=1; fcpq:=0;
 fcqq:=1; fcqp:=0;

 while dgs neq 0 do <<
  quoti:=reval{'QUOTIENT,ltp,ltq};
  s:=reval{'PLUS,{'TIMES,p,{'DEN,quoti}},
                 {'MINUS,{'TIMES,q,{'NUM,quoti}}}}$
  lts:=reval{'LTERM,s,x}$
  dgs:=reval{'DEG,lts,x}$
  fcsp:=reval{'PLUS,{'TIMES,fcpp,{'DEN,quoti}},
                    {'MINUS,{'TIMES,fcqp,{'NUM,quoti}}}}$
  fcsq:=reval{'PLUS,{'TIMES,fcpq,{'DEN,quoti}},
                    {'MINUS,{'TIMES,fcqq,{'NUM,quoti}}}}$

  if flg=t then <<
   p:=s;
   ltp:=lts;
   dgp:=dgs;
   fcpp:=fcsp;
   fcpq:=fcsq;
   if dgq>dgp then flg:=nil
  >>       else <<
   q:=s;
   ltq:=lts;
   dgq:=dgs;
   fcqp:=fcsp;
   fcqq:=fcsq;
   if dgp>dgq then flg:=t
  >>$
  if once then dgs:=0
 >>;
 quoti:=err_catch_gcd(fcsp,fcsq);
 return {reval{'QUOTIENT,s   ,quoti},
         reval{'QUOTIENT,fcsp,quoti},
         reval{'QUOTIENT,fcsq,quoti} }
end$  % elimin

symbolic procedure dec_new_equation(l,rl)$
% l has form ((e4 (x 2 y) (y z)) (e5 (z) (x 2 y 2)) (df f x 2 y 2 z) nil nil)
% This means: e4 has df(f,y,z) and is differ. wrt. xxy
%             e5 has df(f,x,2,y,2) and is diff. wrt. z
%             to eliminate df(f,x,2,y,2,z),
%             nil is substituted,
%             substitution is not essential
begin scalar ld,f,ip,iq,s,nvl,lcop,p,ddp,ddpcp,ldp,ltp,dgp,pfac,
                                   q,ddq,ddqcp,ldq,ltq,dgq,qfac,h,once$
  % ddpcp will be the name of the equation, e.g.  e4
  % p     at first the value of the equation, later df(p,ip)
  % ddp   will be the history value of the equation
  % ip    is a list of differentiations to be done with p
  % ldp   is the leading derivative in p
  % ltp   at first the lead. term of p then is the leading term in df(p,ip)
  % dgp   at first highpow of ldp in p then highpow of df(ldp,ip) in ltp
  % lcop  is the coefficient of ldp**dgp in ltp
  % pfac  an overall factor of p that has been dropped but that may vanish

  % similar with q

  ld:=caddr l$
  f:=if pairp ld then cadr ld
                 else ld$
  ip:=cadar l$
  iq:=cadadr l$
  s:=cadddr l$
  once:=car cddddr l$
  ddp:=caar l$  ddpcp:=ddp$
  ddq:=caadr l$ ddqcp:=ddq$
  p:=get(ddp,'val)$
  q:=get(ddq,'val)$
  if record_hist then <<
   nvl:=get(ddp,'nvars)$
   if get(ddq,'nvars)>$

  if print_ and ((null rl and tr_decouple) or
                 (     rl and tr_redlength)  ) then
  <>$

  if atom ld then ldp:=ld else <<
   ldp:=cadr ld;
   if caddar l then ldp:=cons('DF,cons(ldp,caddar l))
  >>;
  ltp:=reval{'LTERM,p,ldp};
  dgp:=reval{'DEG,ltp,ldp};
  pfac:=1:
  if ip then <<
    lcop:=reval{'QUOTIENT,ltp,{'EXPT,ldp,dgp}}$
    if (dgp=1) and (not fixp lcop) then <<
      p:=reval cons('DF,cons({'QUOTIENT,{'DIFFERENCE,p,ltp},lcop},ip));
      if record_hist then
      ddp:=reval cons('DF,cons({'QUOTIENT,ddp,lcop},ip));
      h:=reval{'DEN,p}$     % the new lcop
      pfac:=reval {'QUOTIENT,lcop,h}$
      if may_vanish(pfac) and (s=ddqcp) then s:=nil;
      ltp:={'TIMES,ld,h}$
      p:=reval{'PLUS,ltp,{'NUM,p}}$
      if record_hist then ddp:=reval {'TIMES,ddp,h}$
    >>                             else <<
      % p:=cons('DF,cons(p,ip));
      if record_hist then
      ddp:=cons('DF,cons(ddp,ip));
      % ltp:=cons('DF,cons(ltp,ip))
      dgp:=1;
      ltp:={'TIMES,{'DF,p,ldp},cons('DF,cons(ldp,ip))};
      p:=cons('DF,cons(p,ip));
    >>
  >>$

  if atom ld then ldq:=ld else <<
   ldq:=cadr ld;
   if caddar cdr l then ldq:=cons('DF,cons(ldq,caddar cdr l))
  >>;
  ltq:=reval{'LTERM,q,ldq};
  dgq:=reval{'DEG,ltq,ldq};
  qfac:=1:
  if iq then <<
    lcop:=reval{'QUOTIENT,ltq,{'EXPT,ldq,dgq}}$
    if (dgq=1) and (not fixp lcop) then <<
      q:=reval cons('DF,cons({'QUOTIENT,{'DIFFERENCE,q,ltq},lcop},iq));
      if record_hist then
      ddq:=cons('DF,cons({'QUOTIENT,ddq,lcop},iq));
      h:=reval{'DEN,q}$     % the new lcop
      qfac:=reval {'QUOTIENT,lcop,h}$
      if may_vanish(qfac) and (s=ddpcp) then s:=nil;
      ltq:={'TIMES,ld,h}$
      q:=reval{'PLUS,ltq,{'NUM,q}}$
      if record_hist then ddq:=reval {'TIMES,ddq,h}$
    >>                             else <<
      % q:=cons('DF,cons(q,iq));
      if record_hist then
      ddq:=cons('DF,cons(ddq,iq));
      % ltq:=cons('DF,cons(ltq,iq))
      dgq:=1;
      ltq:={'TIMES,{'DF,q,ldq},cons('DF,cons(ldq,iq))};
      q:=cons('DF,cons(q,iq));
    >>
  >>$

  % l:=list(caar l,caadr l)$
  % if iq then q:=simplifypde(reval cons('DF,cons(q,iq)),ftem,nil,nil (?))$
  % if ip then p:=simplifypde(reval cons('DF,cons(p,ip)),ftem,nil,nil (?))$

  % h:=reval !*q2a simpresultant list(p,q,ld)$
  return if (l:=err_catch_elimin(p,ltp,dgp,q,ltq,dgq,ld,once)) then
         list(l,s,ddpcp,ddqcp,ddp,ddq,ld,pfac,qfac)            else nil$
end$ % of dec_new_equation

symbolic procedure dec_reduction(h,pdes,ftem,%forg,
                                 vl,rl,ordering)$
% do a reduction step or a cross differentiation either
% h is the result of dec_new_equation() and has the structure
%   list(elimin(p,ltp,dgp,q,ltq,dgq,ld),s,ddpcp,ddqcp,ddp,ddq,ld,pfac,qfac)$
% if rl then one pde must be simplified with the help of
% another one and reduce its length
begin scalar %p,q,ld,a,s,ip,iq,f,dwsa,dwla,dwlb,el,h,
             %ldp,ldq,ltp,ltq,dgp,dgq,lcop,ddp,ddq,ddpcp,ddqcp,len,nvl$
             s,p,q,ddp,ddq,ld,len,a,ip,iq,pfac,qfac$

 s:=cadr h$
 p:=caddr h$
 q:=cadddr h$
 ddp:=nth(h,5)$
 ddq:=nth(h,6)$
 ld:=nth(h,7)$
 pfac:=nth(h,8)$
 qfac:=nth(h,9)$
 h:=car h$

 % If an equation is to be substituted then the new system must
 % be sufficient after replacing one equations through another one.
 % --> the replaced equation must not have been multiplied with
 % possibly vanishing factors

 if s and (null rl) and % (sufficient_decouple) and
    % for rl=t already checked
    (((s=p) and may_vanish(cadr  h)) or
     ((s=q) and may_vanish(caddr h))    ) then s:=nil$

 % tracing comments

 if (null rl and tr_decouple) or
    (     rl and tr_redlength) then <<
  terpri()$
  write p," (resp its derivative) is multiplied with"$terpri()$
  algebraic write lisp if qfac=1 then cadr h
                                 else {'TIMES,qfac,cadr  h}$
  write q," (resp its derivative) is multiplied with"$terpri()$
  algebraic write lisp if pfac=1 then caddr h
                                 else {'TIMES,pfac,caddr h}$
 >>$

 % If an equation is used for a substitution of a derivative which is
 % not a leading derivative and the length of the equation is
 % increased then drop the new equation

 if (null rl) and % for rl=t the length comparison is already done
    (null expert_mode) and % not explicitly ordered by user
    (car h) and s and ((null struc_eqn) or (atom ld))
 then <<
  len:=no_of_terms(car h);
  if pairp(ld) and (car ld = 'DF) then ld:=cdr ld
                                  else ld:=list ld;
  if ((s=p) and
      (ld neq caar get(p,'derivs)) and
      (len>get(p,'terms))) or
     ((s=q) and
      (ld neq caar get(q,'derivs)) and
      (len>get(q,'terms))) then
  return <<
   if print_ then <<
    write"The tried reduction of a non-leading derivative"$terpri()$
    write"would have only increased the equation's length."$terpri()
   >>$
   add_both_dec_with(ordering,p,q,rl);
   list(nil)
  >>;
  if cdr ld then ld:=cons('DF,ld)
            else ld:=car ld;
 >>$

 % the case of a resulting identity 0=0

 if car h then
 if zerop car h and null rl then <<
  % for rl=t the case that the multipliers contain ftem_ has already
  % been checked
  if print_ then <>$

  if null ip and null iq and null s and
   % if s<>nil then multipliers can not be ftem_ dependent
   (!*batch_mode or
    (batchcount_>=stepcounter_)) then << % i.e. only if batch_mode
   a:=proc_list_;
   % Have already all normal factorizations be tried?
   while a and (car a neq 8) and (car a neq 30) do a:=cdr a;
   if a and car a = 8 then
   to_do_list:=cons(list('factorize_any,%pdes,forg,vl_,
                    list <>
 >>$

 if record_hist and
    (car h) and (zerop car h) then
 new_idty({'PLUS,{'TIMES,cadr  h,ddp},{'TIMES,caddr h,ddq} }, pdes, t);
 % also if car h is not identical 0 but with less variables.
 % It still can be the case that some functions of fewer variables
 % still depend on all the differentiation variables of the divergence
 % Then integration of the curl is not done(possible?)

 % The following lines have been commented out 9.9.2001 as the
 % cycle-test with dec_hist_list is too crude. It is necessary to
 % record which method (decoupling or length-reduction-decoupling or
 % shortening) leads to a repetition, or better just to check only
 % when doing length-reduction because straightforward decoupling
 % should be done anyway.

 %if a and (null s) and member(get(a,'val),dec_hist_list) then <<
 %  drop_pde(a,nil,nil)$
 %  add_both_dec_with(ordering,car l,cadr l,rl);
 %  if print_ and tr_decouple then <<
 %    terpri()$write "the resulting pde would lead to a cycle"$
 %  >>
 %>>                                                      else <<

 if print_ then <<
  write"Eliminate "$
  mathprint ld$
  write"from ",if ip then cons('DF,cons(p,ip))
                     else p, " and ",
               if iq then cons('DF,cons(q,iq))
                     else q, ". "$
  if a then <<
   if s then <<
    write s,": "$terpri()$
    typeeq s;
    write"is replaced by ",a,": "
   >>   else write a," is added: "$
   terpri()$
   typeeq a
  >>   else
  if s then <>$
 >>$
 if null s then add_both_dec_with(ordering,p,q,rl)
           else <<      % reduction, s is the equation to be replaced
  % The following was commented out as in_cycle() is to take care of
  % preventing cycles, l had the value which is now the input of
  % dec_new_equation()
  %
  % l:=delete(s,l)$
  %
  % if not (ip or iq) then <<
  %  % The equations wrt which s has already been decoupled
  %  % are to be listed under dec_with wrt to the equation
  %  % of both that is kept which is car l
  %  % purpose: These decouplings should not be done again
  %  % with car l as this may result in a cycle
  %  dwsa:=get(    s,'dec_with)$
  %  dwla:=get(car l,'dec_with)$
  %  for each el in dwsa do <<
  %   % el are the different orderings, if more than one are
  %   % in use then something must be changed probably
  %   dwlb:=assoc(car el,dwla)$
  %   dwla:=delete(dwlb,dwla)$
  %   if dwlb then dwlb:=cons(car el,union(cdr el,cdr dwlb))
  %           else dwlb:=el$
  %   dwla:=cons(dwlb,dwla)
  %  >>$
  %  put(car l,'dec_with,dwla)$
  % >>$

  % The following was taken out some time ago (now 9.9.2001)
  % because it probably prevented a complete computation
  % % If other than the leading derivatives are reduced then
  % % the new equ. a must inherit 'dec_with from equ. s
  % if a and get(a,'derivs) and
  %    (car get(a,'derivs) = car get(s,'derivs)) then <<
  %  dwsa:=get(s,'dec_with)$
  %  put(a,'dec_with,dwsa)$
  % >>$

  % The following has been taken out with the dec_hist_list test above
  % if dec_hist>0 then <<
  %  if length dec_hist_list>dec_hist then
  %     dec_hist_list:=cdr dec_hist_list$
  %  dec_hist_list:=reverse cons(get(s,'val),reverse dec_hist_list)$
  % >>$

  drop_pde(s,if a then cons(a,pdes) else pdes,nil)

 >>$
 %>>$ commented out together with code from above
 return list(a)
 % a is either a new equation or nil if s has beed reduced to an identity
end$ % of dec_reduction

symbolic procedure dec_fct_check(a,l)$
% checks, if a function occurs in only one pde
begin scalar ft,n$
  ft:=get(a,'fcts)$
  while ft and l do
    <>$
  n:=get(a,'nvars)$
  while ft and (n<=length fctargs(car ft)) do ft:=cdr ft$
  if ft then remflag1(a,'to_decoup)$
  return ft$
end$

symbolic procedure check_cases_for_symbol(l)$
% l has form ((e4 (x 2 y) (y z)) (e5 (z) (x 2 y 2)) (df f x 2 y 2 z) nil nil)
% This means: e4 has df(f,y,z) and is differ. wrt. xxy
%             e5 has df(f,x,2,y,2) and is diff. wrt. z
%             to eliminate df(f,x,2,y,2,z),
%             nil is substituted,
%             substitution is not essential
begin scalar s,h,lde,sy$
 % Is a case-distinction to be made about whether the symbol
 % is zero or non-zero?
 s:=cadddr l;
 if lin_problem or (null s) or
    (not pairp caddr l) or
    (null flagp(if s=caar l then caadr l
                            else caar l,'to_symbol))
 then return nil % no case-distinction
 else <<
  if s=caar l then h:=cadr l else h:=car l$ % h are the data of the lower
                                            % priority (e.g. order) equation
  if null cadr h then return nil else <<    % lower order equ. is not diff.
   remflag1(car h,'to_symbol)$
   lde:=if null caddr h then cadr caddr l    % lead. deriv. is algebraic
                        else cons('DF,cons(cadr caddr l,caddr h));
   % lde is the leading derivative in the lower priority equation
   sy:=reval {'DF,get(car h,'val),lde};
   return
   if freeofzero(sy,get(car h,'fcts),get(car h,'vars),get(car h,'nonrational))
   % if not may_vanish(sy)
   then nil
   else <>$
    t
   >>
  >>
 >>
end$

symbolic procedure dec_one_step(pdes,ftem,%forg,
                                vl,hp,ordering)$
% do one decouple step for 2 pdes from l, differentiate them
% and add the new pde or replace an original one
begin scalar l0,l1,l2,l,ruli$ %,f$
 l:=pdes;
 if not expert_mode then l0:=l
                    else <<
  l0:=selectpdes(l,2)$
  drop_dec_with(car  l0,cadr l0,nil)$
  drop_dec_with(cadr l0,car  l0,nil)$
 >>$
 ruli:=start_let_rules()$
again:
 l1:=dec_and_fct_select(l0,vl,nil,hp,ordering)$
 if null l1 then l:=nil else
 if check_cases_for_symbol(l1) then return l else
 % i.e. dec_one_step was successful even if nothing
 % happened just to continue with to_do
 if null (l2:=dec_new_equation(l1,nil)) then
 < err_catch
   add_both_dec_with(ordering,caar l1,caadr l1,nil)$
   goto again
 >>                                     else
 if null (l2:=dec_reduction(l2,pdes,ftem,%forg,
                        vl,nil,ordering)) then l:=nil else <<
  for each a in cdddr l1 do
  if get(a,'val)=nil then l:=delete(a,l)$
  for each a in l2 do if a then <<
   l:=eqinsert(a,l)$
%  % equations which are added and are still to be reduced and still
%  % contain the function to be decoupled shall not be integrated:
%  if null cadddr l1 then <<% no equation was reduced only a new one is added
%   f:=if pairp caddr l1 then cadr caddr l1 % leading deriv. was a deriv
%                        else caddr l1;     % leading deriv. was a function
%   if not freeof(get(a,'fcts),f) then <<
%    remflag1(a,'to_int)$
%    remflag1(a,'to_fullint)
%   >>$
  >>
  % the following breaks the ordering
  % for each a in l2 do dec_fct_check(a,l)$
 >>$
 stop_let_rules(ruli);
 % if anything has changed then l must be the new pde-list
 return l$
end$

symbolic procedure dec_try_to_red_len(pdes_to_choose_from,vl,ordering)$
begin scalar l1,l2,p,q,s$
again:
 l1:=dec_and_fct_select(pdes_to_choose_from,vl,t,nil,ordering)$
 if l1 then <<
  if in_cycle({27,get(caar l1,'printlength),get(caadr l1,'printlength),
              caddr l1,get(cadddr l1,'printlength),
              length get(cadddr l1,'fcts)}) then <<
   add_both_dec_with(ordering,caar l1,caadr l1,t)$
   goto again;
  >>;
  l2:=dec_new_equation(l1,t)$
  % possible length measures to use:
  %    put(equ,'length,pdeweight(val,ftem))$
  %    put(equ,'printlength,delength val)$
  %    put(equ,'terms,no_of_terms(val))$
  p:=caar   l1$
  q:=caadr  l1$
  s:=cadddr l1$
%  if ( no_of_terms(caar l2)   >
%       get(cadddr l1,'terms)       ) or  % * length_inc
%  disadvantage of 'terms: a big product is one term
  if (null l2) or
     ( pdeweight(caar l2,ftem_) >
       get(cadddr l1,'length)        ) or  % * length_inc
     ((s=p) and may_vanish( cadar l2)) or
     ((s=q) and may_vanish(caddar l2)) then <<
   l2:=nil;
   add_both_dec_with(ordering,p,q,t);
   last_steps:=cdr last_steps; % last_steps had already been updated
                               % in add_to_last_steps() in in_cycle()
   goto again
  >>
 >>;
 return l2
end$

symbolic procedure err_catch_red_len(a1,a2,a3)$
begin scalar h,bak,kernlist!*bak,kord!*bak,bakup_bak;
 bak:=max_gc_counter$ max_gc_counter:=my_gc_counter+max_gc_red_len;
 kernlist!*bak:=kernlist!*$
 kord!*bak:=kord!*$
 bakup_bak:=backup_;backup_:='max_gc_red_len$
 h:=errorset({'dec_try_to_red_len,mkquote a1,mkquote a2,mkquote a3},nil,nil)
    where !*protfg=t;
 kernlist!*:=kernlist!*bak$
 kord!*:=kord!*bak;
 erfg!*:=nil;
 max_gc_counter:=bak;
 backup_:=bakup_bak;
 return if errorp h then nil
                    else car h
end$

symbolic procedure dec_and_red_len_one_step(pdes,ftem,%forg,
                                            vl,ordering)$
% do one length-reducing decouple step for 2 pdes from l,
% differentiate at most one and replace the other one which must
% become shorter, the one replaced must not be multiplied with a
% potentially zero factor
begin scalar l,l1,l2,l3,ruli$ %,f$
  l:=pdes;
  if not expert_mode then l1:=l
                     else <<
    l1:=selectpdes(l,2)$
    drop_dec_with(car  l1,cadr l1,t)$
    drop_dec_with(cadr l1,car  l1,t)$
  >>$
  ruli:=start_let_rules()$
again:
  l2:=err_catch_red_len(l1,vl,ordering)$

  if null l2 then return nil;

  if (l3:=dec_reduction(l2,pdes,ftem,%forg,
                        vl,t,ordering)) then <<
   l:=delete(cadr l2,l)$
   for each a in l3 do if a then <<
    l:=eqinsert(a,l)$
%   % equations which are added and are still to be reduced and still
%   % contain the function to be decoupled shall not be integrated:
%   if null cadddr l1 then <<% no equation was reduced only a new one is added
%    f:=if pairp caddr l1 then cadr caddr l1 % leading deriv. was a deriv
%                         else caddr l1;     % leading deriv. was a function
%    if not freeof(get(a,'fcts),f) then <<
%     remflag1(a,'to_int)$
%     remflag1(a,'to_fullint)
%    >>$
%   >>
   >>$
   % the following breaks the ordering
   % for each a in l3 do dec_fct_check(a,l)$
  >>                                             else
  <>
  >>;
  stop_let_rules(ruli);
  % if anything has changed then l must be the new pde-list
  return l$
end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  procedures for decoupling of similar pde                        %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%symbolic procedure rel_length_diff(p,q)$
%% print length difference in pro cent
%(abs(get(p,'length)-get(q,'length))*100)/
%   (get(p,'length)+get(q,'length))$

%symbolic procedure nearly_same(p,q)$
%begin scalar lp,lq$
% lp:=get(p,'fcts)$
% lq:=get(q,'fcts)$
% if null setdiff(get(p,'allvarfcts),get(q,'allvarfcts)) and
%    null setdiff(get(q,'allvarfcts),get(p,'allvarfcts)) and
%    ((length setdiff(lp,lq)+length setdiff(lq,lp))*100<
%    (length lp+length lq)*same_fcts) then
%    <>$
%end$

%symbolic procedure get_same_pdes(pdes)$
%begin scalar l,n,res$
% while pdes do
%  <>
%       else l:=cdr l
%    else if n>5*same_length then l:=nil
%                            else l:=cdr l$
%  if res then pdes:=nil
%         else pdes:=cdr pdes
%  >>$
% return res$
%end$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crmain.red0000644000175000017500000024146111526203062023544 0ustar  giovannigiovanni%**********************************************************************
module crackstar$
%**********************************************************************
%  Main program
%  Authors: Andreas Brand 1995-97,
%           Thomas Wolf since 1996

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic operator crackshell$
symbolic procedure crackshell$
begin scalar s,ps;
 ps:=promptstring!*$
 promptstring!*:=""$
 terpri()$
 if null old_history then <<
  write"Please give the name of the file in double quotes"$terpri()$
  write"(no ;) from which the session is to be restored: "$
  s:=termread()$
  old_history:={'rb,s};
 >>$
 !*batch_mode:=nil;
 algebraic(crack({},{},{},{}));
 promptstring!*:=ps
end$

symbolic operator crack$
symbolic procedure crack(el,il,fl,vl)$
begin scalar l,l1,l2,n,m,pdes$

 if l:=check_globals() then <<
   write"The global variable ",l," has an incorrect value, please check!"$
   rederr " "
 >>$
 if print_ and logoprint_ then <>$
 if not !*batch_mode then <<
   if not print_ then <>$
   write"Enter `h' for help."$ terpri()$
 >>$
 %rulelist_:=if pairp userrules_ then
 %            if pairp crackrules_
 %             then list('LIST,userrules_,crackrules_)
 %             else list('LIST,userrules_)
 %           else
 %           if pairp crackrules_ then
 %            list('LIST,crackrules_)
 %                                else nil$
 backup_reduce_flags();   % backup of REDUCE flags

 % initializations of global CRACK variables
 to_do_list:=nil$
 fnew_:=nil$
 vl_:=nil$
 stop_:=nil$
 % dec_hist_list:=nil$
 level_:=nil$
 stepcounter_:=0$
 batchcount_:=-1$
 recycle_eqns:=nil . nil$
 recycle_fcts:=nil$
 recycle_ids:=nil$
 n:=time()$
 m:=gctime()$
 if pairp el and (car el='LIST) then el:=cdr el else el:=list el$
 if pairp fl and (car fl='LIST) then fl:=cdr fl else fl:=list fl$
 if pairp vl and (car vl='LIST) then vl:=cdr vl else vl:=list vl$
 if pairp il and (car il='LIST) then il:=cdr il else il:=list il$
 ineq_:=nil;
 ftem_:=fl;  % for addineq and for mkeqlist
 for each p in il do addineq(nil,p);
 il:=nil$
 vl_:=union(reverse argset fl,vl)$  vl:=nil;
 orderings_:=make_orderings(fl, vl_)$     % Orderings support!
 history_:=nil;
 sol_list:=nil;
 % necessary initializations in case structural equations are to solve:
 if struc_eqn then ini_struc()$

 % Orderings Note: orderings_prop_list_all() inserts all the valid
 % orderings into each of the initial equations, i.e. all equations
 % are in all orderings

 % each equation gets a property list
 pdes:=mkeqlist(el,fl,vl_,allflags_,t,orderings_prop_list_all(),nil)$
 l:=pdes;
 while l and get(car l,'linear_) do l:=cdr l;
 if l then lin_problem:=nil else lin_problem:=t;

 el:=nil$ % to free memory
 size_hist:=if size_watch then {get_statistic(pdes,fl)}
                          else nil$

 % the computation:
 l:=crackmain(pdes,fl)$
 if l=list(nil) then l:=nil$
 l:=union(l,nil)$
 if !*time or time_ then
 <>$

 l:=for each a in l collect
      < to be called only from crack() or sub_crack_call()
% > it returns
%   - nil if no solution
%   - {nil} if successful but no solutions are collected (collect_sol=nil)
%   - {sol1,sol2,...}  list of solutions
%     each solution has the form
%        {for each a in pdes collect get(a,'val),
%         forg,setdiff(ftem_,forg),ineq_         }
%
% > The result that is returned is contained completely in the
%   returned value (list) only apart from the variable dependencies
%   of the free functions which is contained in depl!*.
% > apply-calls made within must return either
%   nil or {pdes,forg} or {{sol1,sol2,...}}
% > In the case of more than one solution of an apply call, all of them
%   must be computed because crackmain terminates after such an apply
%   call that returns a list with a single element which then always is
%   treated as a list of solutions.
% > Currently ftem_, ineq_, vl_ are essential (but hidden) input parameters
%   (as well as the properties of the pdes and forg)
% > crackmain() sets the global variable contradiction_.

begin scalar result,l,pl,unsolvable, % dec_hist_list_copy,
             s,ps,batch_one_step,expert_mode_copy,fnc_to_adjust,
                   fnc_adjusted,loopcount,level_length,newli,processes,
             full_proc_list_length$
  level_length:=length level_;
  full_proc_list_length:=length full_proc_list_$
  if level_ then
  history_:=cons(bldmsg("%w%w","*** Start of level ",level_string(nil)),
                 cons('cm,history_));
  if tr_main and print_ then
    <>$
  % depl_copy_:=depl!*$
  % dec_hist_list_copy:=dec_hist_list$
  fnc_to_adjust:=adjust_fnc;
  contradiction_:=nil$
  ftem_:=fctlist(ftem_,pdes,forg)$     % global list of free functions
again:
  repeat <<
    pl:=proc_list_$                    % global list of procedures
    stop_:=nil$
    ftem_:=fctlist(ftem_,pdes,forg)$
    vl_:=var_list(pdes,forg,vl_)$

    if !*batch_mode or
       to_do_list or
       batch_one_step or
       ((batchcount_>=stepcounter_) and
        ((time_limit=nil) or <=l>>)) then

    % automatic part: -----------------------
    <>$
      batch_one_step:=nil$
      expert_mode_copy:=expert_mode$
      if (null to_do_list) or
         (caar to_do_list neq 'split_into_cases) then expert_mode:=nil$
      while pl do <<
        if print_ and print_more then
        if pairp(l:=get(car pl,'description)) then <<
          for each a in l do if a then write a$
          write " : "
        >>                                    else
        write "trying ",car pl," : "$
        l:=apply(car pl,list list(pdes,forg,vl_,pdes))$
        if (length l = 1) and (null car l) then contradiction_:=t;
        if l and not contradiction_ then <<
          if length l = 1      % before the test was: if cases_
          then result:= car l  % car l is a list of crackmain results
                               % resulting from investigating subcases
          else <>$  % no case-splitting
          pl:=nil$
        >>                          else
        if contradiction_ then pl:=nil
                          else <<
          pl:=cdr pl$
          if print_ and print_more then
          <>$
          if not pl then unsolvable:=t
        >>
      >>;
      expert_mode:=expert_mode_copy
    >>
    else % interactive part: -----------------------
    <>$
      rds nil$wrs nil$
      ps:=promptstring!*$
      promptstring!*:="next: "$
      terpri()$s:=termread()$
      % expert_mode:=expert_mode_copy$
      if (s='h) or (s='help) or (s='?) or (s=nil) then printmainmenu()
      else if s='hd then print_hd()
      else if s='hp then print_hp()
      else if s='hf then print_hf()
      else if s='hc then print_hc()
      else if (s='hi) and (getd 'show_id) then print_hi()
      else if s='hb then print_hb()
      % to inspect data -----------------------
      else if s='e then
        if expert_mode then print_pdes(selectpdes(pdes,1))
                       else print_pdes(pdes)
      else if s='eo then <<
        ps:=print_;print_:=1;
        for each s in pdes do <>$
        print_:=ps
      >>
      else if s='pi then print_ineq(ineq_)
      else if s='f then
        <>
      else if s='v then
        <>
      else if s='s then <<
        print_level(nil)$
        print_statistic(pdes,append(forg,setdiff(ftem_,forg)))
      >>
      else if s='fc then <<
        reclaim()$terpri()$            % do garbage collection
        write if not unboundp 'gcfree!* then gcfree!*
                                        else known!-free!-space(),
              " free cells"$
        terpri()$write countids()," identifiers in use"$;
        terpri()
      >>
      else if s='pe then <<
        promptstring!*:=""$
        terpri()$
        write "Which expression do you want to print?"$
        terpri()$
        write "You can use names of equations, e.g. coeffn(e_12,df(f,x,y),2); "$
        terpri()$
        write "Terminate the expression with ; "$
        terpri()$
        l:=termxread()$
        for each s in pdes do l:=subst(get(s,'val),s,l)$
        l:=reval l;
        for each s in forg do
        if (pairp s) and (car s='EQUAL) then l:=subst(caddr s,cadr s,l)$
        terpri()$
        mathprint(reval l)
      >>
      else if s='ph then <<
        terpri()$
        prettyprint reverse history_
      >>
      else if s='pv then <<
        write "Type in a variable from which you want to know its value: ";
        promptstring!*:=""$
        s:=termread()$
        if not atom s then write"This is not a variable name." else
        if null boundp s then write s," has no value"
                         else <> >>
      else if s='t then <<
        expert_mode:=not expert_mode$
        if expert_mode then
        write"The user will choose equations from now on."
                       else
        write"The program will choose equations from now on.";
        expert_mode_copy:=expert_mode
      >>
      else if s='p1 then printproclist()
      else if s='p2 then printfullproclist()
      else if s='# then <<
         write"Type in a number instead of `#' to ",
              "execute a specific module."$
        terpri()
      >>
      else if (s='l) or numberp s then
      <>;
        if (s<=0) or (s>full_proc_list_length) then
        if print_ then <<
          write"The number must be in 1 .. ",full_proc_list_length," ."$
          terpri()
        >>        else                         else
        <<
          loopcount:=0;
          if size_watch then
          size_hist:=cons(get_statistic(pdes,append(forg,
                                                    setdiff(ftem_,forg))),
                          size_hist);
          stepcounter_:=add1 stepcounter_$
          clean_prop_list(pdes)$
          if print_ then
          <>$
          repeat <<
            if to_do_list then loopcount:=sub1 loopcount$
            l:=apply(if to_do_list then 'to_do
                                   else nth(full_proc_list_,s),
                     list list(pdes,forg,vl_,pdes))$
            if (length l = 1) and (null car l) then contradiction_:=t;
            if l and not contradiction_ then <<
              loopcount:=add1 loopcount$
              if length l = 1     % before the test was: if cases_
              then result:=car l  % car l is a list of crackmain results
                                  % resulting from investigating subcases
              else <>$  % no case-splitting
              terpri()$
              if repeat_mode=1 then repeat_mode:=nil
                               else if repeat_mode then <<
                if numberp repeat_mode then repeat_mode:=sub1(repeat_mode);
                if size_watch then
                size_hist:=cons(get_statistic(pdes,append(forg,
                                                          setdiff(ftem_,
                                                                  forg))),
                                size_hist);
                stepcounter_:=add1 stepcounter_$
                clean_prop_list(pdes)$
                if print_ then
                <>$
              >>
            >>
            else if (not contradiction_) and (loopcount=0) then
              <>
          >>
          until (not repeat_mode) or (not l) or contradiction_ or
                  (time_limit and <>);
        >>;
        repeat_mode:=nil
      >>
      else if s='sb then backup_to_file(pdes,forg,t)
      else if s='rb then <<
        l:=restore_backup_from_file(pdes,forg,t)$
        pdes:=car l;forg:=cadr l;
        if null pvm_able then  % assumed not to be started from PVM
        batchcount_:=sub1 stepcounter_
      >>
      else if (s='ep) then <<
       pvm_activate()$
       terpri()$
       if pvm_able then write"Use of PVM is enabled."
                   else write"PVM is not active on this computer."$
      >>
      else if (s='dp) then pvm_able:=nil
      else if (s='pp) and pvm_active() then
        processes:=add_process(processes,pdes,forg)
      else if (s='kp) and pvm_active() then processes:=drop_process(processes)
      else if s='x then !*batch_mode:=t
      else if s='q then stop_:=t
      % to change flags & parameters -----------------------
      else if s='pl then <<
        promptstring!*:="Print length : "$
        s:=termread()$
        if not s or fixp(s) then print_:=s
                            else <<
          terpri()$write "Print length must be NIL or an integer!!!"$
          terpri()
        >>
      >>
      else if s='pm then <<
        print_more:=not print_more;
        if print_more then write"More details will be printed."
                      else write"Fewer details will be printed.";
        terpri()
      >>
      else if s='pa then <<
        print_all:=not print_all;
        if print_all then write"All equation properties will be printed."
                     else write"No equation properties will be printed.";
        terpri()
      >>
      else if s='cp then changeproclist()
      else if s='og then <<
        lex_fc:=not lex_fc$
        if lex_fc then
        write"Lex. ordering of functions has now highest priority."
                  else
        write"Lex. ordering of functions is not of highest priority anymore."$
        terpri()$
        pdes := change_derivs_ordering(pdes,ftem_,vl_)$
      >>
      else if s='od then <<
        lex_df:=not lex_df$
        if lex_df then
        write"From now on lexicographic ordering of derivatives."
                  else
        write"From now on total-degree ordering of derivatives.";
        terpri()$
        pdes := change_derivs_ordering(pdes,ftem_,vl_);
      >>
      else if s='oi then <<
        terpri()$
        write "Current variable ordering is : "$
        s:=vl_;
        while s do <>$
        write";"$terpri()$
        promptstring!*:="New variable ordering : "$
        newli := termlistread()$
        if newli then <<
          if (not not_included(vl_,newli)) and
             (not not_included(newli,vl_)) then <<
            vl_ := newli$
            for each s in pdes do
            put(s,'vars,sort_according_to(get(s,'vars),vl_));
            pdes := change_derivs_ordering(pdes,ftem_,vl_)$
            if tr_orderings then <<
              terpri()$
              write "New variable list: ", vl_$
            >>
          >>$
        >>$
      >>
      else if s='or then <<
        terpri()$
        write "The current variable ordering is going to be reversed. "$
        vl_ := reverse vl_$
        for each s in pdes do
        put(s,'vars,sort_according_to(get(s,'vars),vl_));
        pdes := change_derivs_ordering(pdes,ftem_,vl_)$
        if tr_orderings then <<
          terpri()$
          write "New variable list: ", vl_$
        >>
      >>
      else if s='om then <<
        terpri()$
        write "The current variable ordering is going to be mixed. "$
        s:=vl_; vl_:=nil;
        while s do <<
          l:=nth(s,add1 random length s)$
          s:=delete(l,s);
          vl_:=cons(l,vl_);
        >>;
        for each s in pdes do
        put(s,'vars,sort_according_to(get(s,'vars),vl_));
        pdes := change_derivs_ordering(pdes,ftem_,vl_)$
        if tr_orderings then <<
          terpri()$
          write "New variable list: ", vl_$
        >>
      >>
      else if s='of then <<
        terpri()$
        write "Current function ordering is : "$
        s:=ftem_;
        while s do <>$
        write";"$terpri()$
        promptstring!*:="New function ordering : "$
        newli := termlistread()$
        if newli then <<
         if (not not_included(ftem_,newli)) and
            (not not_included(newli,ftem_)) then
         change_fcts_ordering(newli,pdes,vl_)
        >>
      >>
      else if s='op then <<
        terpri()$
        write "Current orderings are :"$
        terpri()$
        write "Functions : ", ftem_$
        terpri()$
        write "Variables : ", vl_$
      >>
      else if s='ne then <<
        promptstring!*:="Equation name : "$
        s:=termread()$
        if s and idp s then eqname_:=s
                       else
        <>
      >>
      else if s='nf then <<
        promptstring!*:="Function name : "$
        s:=termread()$
        if s and idp s then fname_:=s
                       else
        <>
      >>
      else if s='ni then <<
        promptstring!*:="Identity name : "$
        s:=termread()$
        if s and idp s then idname_:=s
                       else
        <>
      >>
      else if s='na then <>
      else if s='as then <<
        write "Type in an assignment in the form  ",
              "{variable_name,value}; ";terpri()$
        promptstring!*:="The expression: "$
        s:=termxread()$
        if (pairp s) and (car s='LIST) and (idp cadr s)
        then set(cadr s, reval caddr s)
      >>
      else if s='kp then
      if keep_parti then <<
        keep_parti:=nil;
        for each l in pdes do put(l,'partitioned,nil)
      >>            else keep_parti:=t
      else if s='fi then <<
        freeint_:=not freeint_;
        if freeint_ then write"Integration only if result free ",
                              "of explicit integral from now on."
                    else write"Integration result may involve ",
                              "explicit integral from now on.";
      >>
      else if s='fa then <<
        freeabs_:=not freeabs_;
        if freeabs_ then
        write"Integration only if result free of abs() from now on."
                    else
        write"Integration result may involve abs() from now on.";
      >>
      else if s='cs then <<
        confirm_subst:=not confirm_subst;
        if confirm_subst then
        write"The user will confirm substitutions from now on."
                         else
        write"No user confirmation of substitutions from now on.";
      >>
      else if s='fs then <<
        force_sep:=not force_sep;
        if force_sep then write"Separation will be inforced from now on."
                     else write"Separation will not be inforced from now on.";
      >>
      else if s='ll then <<
        write "What is the new line length? ";
        promptstring!* :=""$
        repeat l:=termread() until fixp l;
        promptstring!*:="next: "$
        linelength l
      >>
      else if s='re then <<
        do_recycle_eqn:=not do_recycle_eqn$
        if do_recycle_eqn then
        write"Equation names will be re-used once the equation is dropped."
                          else
        write"Equation names will not be re-used once the equation is dropped."
      >>
      else if s='rf then <<
        do_recycle_fnc:=not do_recycle_fnc$
        if do_recycle_fnc then
        write"Function names will be re-used once the function",
             " is substituted."
                          else
        write"Function names will not be re-used once the function",
             " is substituted."
      >>
      else if s='st then <<
        batchcount_:=sub1 stepcounter_$
        if time_limit then <<
          l:=limit_time - time()$
          if l<0 then write"The time-limit has expired."
                 else <<
            l:=algebraic(round(l/60000))$
            write"The current CPU time limit for automatic ",
                 "execution to stop is: "$
            s:=algebraic(floor(l/60));
            if s>0 then <>$
            write algebraic(l-60*s)," minutes. "$
                 >>
        >>            else write"There is no time-limit set currently."$
        terpri()$
        ps:=promptstring!*$
        promptstring!*:=""$
        if yesp "Do you want to impose a CPU time-limit? " then <<
          time_limit:=t$
          write"How many hours? "$    s:=termread()$
          write"How many minutes? "$  l:=termread()$
          if not numberp s then s:=0$
          if not numberp l then l:=0$
          limit_time:=algebraic (round (s*3600000+l*60000+lisp time()))$
        >>   else time_limit:=nil$
      >>
      else if s='cm then <<
        % do nothing, the input is added as a comment to history_
        ps:=promptstring!*$
        promptstring!*:=""$
        write"Please type your comment in "" "" for the history_ list: "$
        terpri()$
        l:=termread()$
        terpri()$
      >>
      else if s='lr then <<
        ps:=promptstring!*$
        promptstring!*:=""$
        write"Please type in the new LET-rule in the form like"$terpri()$
        write"sqrt(e)**(-~x*log(~y)/~z) => y**(-x/z/2)   : "$
        terpri()$
        l:=termxread()$
        userrules_:=cons('LIST,cons(l,cdr userrules_))$
        algebraic (write "The new list of user defined rules: ",
                         lisp userrules_)$
        terpri()$
        write"Warning: Changes of equations based on LET-rules"$terpri()$
        write"are not recorded in the history of equations."$terpri()$
      >>
      else if s='cr then <<
        ps:=promptstring!*$
        promptstring!*:=""$
        write"These are all the user defined rules: "$      terpri()$
        algebraic (write lisp userrules_);
        write"Give the number of the rule to be dropped: "$ terpri()$
        l:=termread()$
        if l > sub1 length userrules_ then <<
         write"This number is too big."$terpri()
        >>                            else <<
         s:=nil;userrules_:=cdr userrules_;
         while l>1 do <<
          l:=sub1 l;s:=cons(car userrules_,s);userrules_:=cdr userrules_
         >>;
         algebraic(clearrules lisp {'LIST,car userrules_});
         userrules_:=cons('LIST,append(reverse s,cdr userrules_));
         algebraic (write lisp userrules_);
         terpri()$
        >>
      >>
      % to change data of equations -----------------------
      else if s='r then <>
      else if s='n then newinequ(pdes)
      else if s='d then pdes:=deletepde(pdes)
      else if s='c then change_pde_flag(pdes)
      else if s='pt then <> >>
      % to work with identities -----------------------
      else if s='i  and getd 'show_id then show_id()
      else if s='id and getd 'show_id then
           if l:=del_red_id(pdes) then pdes:=l else
      else if s='iw and getd 'show_id then write_id_to_file(pdes)
      else if s='ir and getd 'show_id then remove_idl()
      else if s='ia and getd 'show_id then replace_idty()
      else if s='ih and getd 'show_id then start_history(pdes)
      else if s='ip and getd 'show_id then stop_history(pdes)
      else if s='ii and getd 'show_id then
           if l:=integrate_idty(nil,pdes,%forg,
                                ftem_,vl_) then pdes:=l else
           <>
      else if s='ic then check_history(pdes)
      else if s='iy then
           for each l in pdes do mathprint {'EQUAL,l,get(l,'histry_)}
      % to trace and debug -----------------------
      else if s='tm then <>
      else if s='tg then <>
      else if s='ti then <>
      else if s='td then <>
      else if s='tl then <>
      else if s='ts then <>
      else if s='to then <>
      else if s='tr then <<
        if 'psl memq lispsystem!* then load_package debug$
        ps:=promptstring!*$
        promptstring!*:=""$
        write"Please type the name of the procedure to trace: "$
        l:=termread()$
        terpri()$
        evtr list l
      >>
      else if s='ut then <<
        ps:=promptstring!*$
        promptstring!*:=""$
        write"Please type the name of the procedure to trace: "$
        l:=termread()$
        terpri()$
        evuntr list l
      >>
      else if s='br then <<
        terpri()$write"This is Standard Lisp. Return to Reduce by Ctrl D."$
        terpri()$
        standardlisp()
      >>
      else if s ='pc then <<
       promptstring!* := "The function name: "$
       s:=termread();
       promptstring!* := "The argument list in the form {arg1,...};  : "$
       l:=termxread();
       if (pairp l) and (car l = ' list) and idp s then
          prin2t list ("Result: ", apply(s,cdr l))
      >>
      else if s='in then <<
        ps:=promptstring!*$
        promptstring!*:=""$
        write"Please give the name of the file to be read in"$terpri()$
        write"double quotes (no ;) : "$
        l:=termread()$
        terpri()$
        in l$
      >>
      % otherwise -------------------------------------
      else <>$
      promptstring!*:=ps$
      if ifl!* then rds cadr ifl!*$
      if ofl!* then wrs cdr ofl!*$
     >>;
     if (not pdes) and fnc_to_adjust then
     if fnc_adjusted then <> else
     if contradiction_ or result then fnc_to_adjust:=nil else
     <>
    >>
  until contradiction_ or result or stop_ or unsolvable
        or (not pdes and not fnc_to_adjust)$

  ineq_:=drop_triv_ineq(ineq_);
  if not (contradiction_ or result) then <<
    if (print_ or null collect_sol) and not stop_ then <>>>>>>>> Solution"$
      if level_ then write" of level ",level_string(nil)$
      write" : "$
    >>$
    ftem_:=fctlist(ftem_,pdes,forg)$
    forg:=forg_int(forg,ftem_)$
    if null collect_sol then <>$
    print_pde_fct_ineq(pdes,ineq_,append(forg,setdiff(ftem_,forg)),vl_)$
    if null collect_sol then print_:=s$
    if not stop_ then <<
      % The following is a procedure the user can define to do
      % specific operations with each solution, e.g. substitution of
      % original equations, substitution into formulae,...
      % This became necessary when for non-linear problems non-solutions
      % were introduced.
      algebraic
      (s:=crack_out(lisp cons('LIST,for each a in pdes collect get(a,'val)),
                   lisp cons('LIST,setdiff(forg,ftem_)),
                   lisp cons('LIST,ftem_),
                   lisp cons('LIST,ineq_) ));
      % If s is not null then s is expected to be an algebraic list of
      % expressions that should be zero but are not and therefore make
      % a new start necessary. This is only relevant for non-linear
      % problems.
      if s and (cdr s) and null lin_problem then <<
        for each l in pdes do
        put(l,'val,simplifypde(get(l,'val),ftem_,t,l))$
        pl:=pdes;
        for each l in cdr s do
        pdes:=eqinsert(mkeq(l,ftem_,vl_,allflags_,t,list(0),nil,pdes),pdes)$
        if setdiff(pdes,pl) then <<
          if print_ then <<
            write"Not all conditions are solved."$terpri()$
            write" --> RESTART with extra conditions ",setdiff(pdes,pl)$
            terpri()>>$
          unsolvable:=nil$
          goto again
        >>
      >>
    >>$
    if session_ and null collect_sol then
    save_solution(for each a in pdes collect get(a,'val),
                  setdiff(forg,ftem_),ftem_,ineq_,nil);   % nil:file_name unsp.
    result:=if collect_sol then
            list list(for each a in pdes collect get(a,'val),
                      forg,setdiff(ftem_,forg),ineq_)
                           else list(nil)$
  >>$
  % dec_hist_list:=dec_hist_list_copy$
  if tr_main and print_ then
     <>$
  l:=(length level_)+1-level_length;
  for s:=1:l do if level_ then level_:=cdr level_$
  if level_ then
  history_:=cons(bldmsg("%w%w","*** Back to level ",level_string(nil)),
                 cons('cm,history_));

  % delete property lists
  for l:=1:(sub1 nequ_) do drop_pde(mkid(eqname_,l),pdes,nil)$
  for each l in forg do
  if pairp l then setprop(cadr l,nil)
             else setprop(     l,nil)$
  return result$
end$

algebraic procedure crack_out(eqns,assigns,freef,ineq)$
% eqns    .. list of remaining unsolved equations
% assigns .. list of computed assignments of the form `function = expression'
% freef   .. list of list of functiones either free or in eqns
% ineq    .. list of inequalities
begin
end$

symbolic procedure priproli(proclist)$
begin integer i$
      scalar l,cpy$
 for each a in proclist do <<
  cpy:=full_proc_list_;
  i:=1;
  while a neq car cpy do <>$
  if null cpy then i:=0;
  terpri()$
  if i<10 then write " "$
  write i$
  write " : "$
  if pairp(l:=get(a,'description)) then
     (for each s in l do if s then write s)
  else write a>>$
 terpri()$
end$

symbolic procedure priprolinr(proclist,fullproclist)$
begin integer i,j$
 scalar cfpl$
 j:=0;
 for each a in proclist do <<
  j:=j+1;
  i:=1;
  cfpl:=fullproclist;
  while cfpl and (a neq car cfpl) do <>$
  if cfpl then <1) then write ","$
     if j>21 then <>$
     write i>>$
  >>$
 write";"$terpri()$
end$

symbolic procedure changeproclist()$
begin scalar l,p,ps,err;
   terpri()$
   write "Please type in a list of the numbers 1 .. ",
          length full_proc_list_,", like 1,2,5,4,..,15; which"$
   terpri()$
   write"will be the new priority list of procedures done by CRACK."$
   terpri()$
   write"Numbers stand for the following actions:"$terpri()$
   priproli(full_proc_list_)$
   terpri()$write"The list so far was: "$
   priprolinr(proc_list_,full_proc_list_)$
   ps:=promptstring!*$
   promptstring!*:="The new list: "$
   l:=termlistread()$
   promptstring!*:=ps$
   if null l then err:=t
             else <<
     while l do <<
       if (not fixp car l) or
          (car l > length full_proc_list_)
       then
          <>
       else <<
         p:=union(list nth(full_proc_list_,car l),p);
         l:=cdr l
       >>
     >>;
   >>;
   if not err then
     <>
   else
     <>
end$

symbolic procedure printproclist()$
begin
 terpri()$
 write "Procedures used currently for automatic execution:"$
 priproli(proc_list_)
end$

symbolic procedure printfullproclist()$
begin
 terpri()$
 write "The complete list of available procedures:"$
 priproli(full_proc_list_)
end$

symbolic procedure printmainmenu()$
<>$

symbolic procedure print_hd()$
<>$

symbolic procedure print_hp()$
<>$

symbolic procedure print_hf()$
< functions"
                        else "functions > derivatives"$     terpri()$
  write "od : Toggle ordering of derivatives to ",
              if lex_df then "total-degree"
                        else "lexicographic"$               terpri()$
  write "oi : Interactive change of ordering on variables"$ terpri()$
  write "or : Reverse ordering on variables"$               terpri()$
  write "om : Mix randomly ordering on variables"$          terpri()$
  write "of : Interactive change of ordering on functions"$ terpri()$
  write "op : Print current ordering"$  terpri()$
  write "ne : Root of the name of new generated equations (",
              eqname_,")"$                                  terpri()$
  write "nf : Root of the name of new functions and constants (",
              fname_,")"$                                   terpri()$
  write "ni : Root of the name of new identities (",
              idname_,")"$                                  terpri()$
  write "na : Change output to "$
              if !*nat then write "OFF NAT"
                       else write "ON NAT"$                 terpri()$
  write "as : Input of an assignment"$                      terpri()$
  write "kp : ",if keep_parti then "Do not keep"
                              else "Keep",
              " a partitioned copy of each equation"$       terpri()$
  write "fi : ",if freeint_ then "Allow unresolved integrals"
              else "Forbid unresolved integrals"$           terpri()$
  write "fa : ",if freeabs_ then "Allow solutions of ODEs with ABS()"
              else "Forbid solutions of ODEs with ABS()"$   terpri()$
  write "cs : ",if confirm_subst then
              "No confirmation of intended substitutions/factorizations"
                                 else
              "Confirmation of intended substitutions/factorizations"$
                                                            terpri()$
  write "fs : ",if force_sep
                then "Do not enforce direct separation"
                else "Enforce direct separation"$           terpri()$
  write "ll : change of the line length"$                   terpri()$
  write "re : ",if do_recycle_eqn then "Do not re-cycle equation names."
                                  else "Do re-cycle equation names."$
                                                            terpri()$
  write "rf : ",if do_recycle_fnc then "Do not re-cycle function names."
                                  else "Do re-cycle function names."$
                                                            terpri()$
  write "st : Setting a CPU time limit for un-interrupted run"$
                                                            terpri()$
  write "cm : Adding a comment to the history_ list"$       terpri()$
  write "lr : Adding a LET-rule"$                           terpri()$
  write "cr : Clearing a LET-rule"$                         terpri()$
>>$

symbolic procedure print_hc()$
<>$

symbolic procedure print_hi()$
if getd 'show_id then
<>$

symbolic procedure print_hb()$
<>$

symbolic procedure to_do(arglist)$
if to_do_list then
  begin scalar p,l$
    p:=car to_do_list;
    to_do_list:=cdr to_do_list;
    if tr_main and print_ and print_more then
      if pairp(l:=get(car p,'description)) then
         <>
      else write "trying ",car p," : "$
%    l:=apply(car p,list(list(car arglist,cadr arglist,
%                             caddr arglist,cadddr cdr p)))$
    l:=apply(car p,list(cons(car arglist,cons(cadr arglist,
                             cons(caddr arglist, cdr p)))))$
    if not l then l:=arglist$
    return l$
  end$

symbolic procedure subst_derivative(arglist)$
% Substitution of a derivative of a function by an new function
% in all pdes and in forg
begin scalar f,l,q,g,h,pdes,forg$
  pdes:=car arglist$
  forg:=cadr arglist$
  l:=check_subst_df(pdes,forg)$
  for each d in l do
    <>$
    for each s in pdes do dfsubst_update(f,d,s)$
    % integrating f in order to substitute for cadr d
    % in ineq_
    h:=cddr d;
    g:=f;
    while h do <<
      for r:=1:(if (length h =1) or
                   ((length h > 1) and (not fixp cadr h))
                then 1
                else (cadr h)
               )   do
      g:=list('PLUS,gensym(),list('INT,g,car h));
      h:=cdr h;
      if h and (fixp car h) then h:=cdr h
    >>;
    % now the substitution in ineq_
    ineq_:=for each s in ineq_ collect reval subst(g,cadr d,s);
    if member(cadr d,forg) then
       <>$
    forg:=dfsubst_forg(f,g,cadr d,forg)$
    >>$
  return if l then list(pdes,forg)
              else nil
end$

symbolic procedure undo_subst_derivative(arglist)$
% undo Substitution of a derivative of a function by an new function
% in all pdes and in forg
begin scalar success$
 for each p in car arglist do
     if get(p,'not_to_eval) then
        <>$
 return if success then arglist
                   else nil
end$

%symbolic procedure make_subst(pdes,forg,vl,l1,length_limit,pdelimit,
%                              less_vars,no_df,no_cases,lin_subst,
%                              min_growth,cost_limit,keep_eqn,sub_fc)$

symbolic procedure subst_level_0(arglist)$
% Substitution of a function by an expression of at most length subst_0
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_0,target_limit_0,t,nil,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_03(arglist)$
% Substitution of a function by an expression of at most length subst_0
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_0,target_limit_0,nil,t,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_04(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_1,target_limit_1,nil,t,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_05(arglist)$
% Substitution of a function by an expression of at most length subst_4
% depending on less variables than the function,
% not allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_4,target_limit_0,nil,t,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_1(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on less variables than the function,
% allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_1,target_limit_1,t,nil,nil,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_2(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on less variables than the function,
% allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_2,target_limit_0,t,nil,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_3(arglist)$
% Substitution of a function by an expression of at most length subst_1
% depending on all variables,
% allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_3,target_limit_3,nil,nil,nil,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_33(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% not giving case distinctions,
% no ftem-dep. coefficient
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_4,target_limit_4,nil,nil,t,t,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_35(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% not giving case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_4,target_limit_4,nil,nil,t,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_4(arglist)$
% Substitution of a function by an expression of at most length subst_2
% depending on all variables,
% allowing case distinctions,
% ftem-dep. coefficient allowed
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_4,target_limit_4,nil,nil,nil,nil,nil,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_45(arglist)$
% Substitution of a function by an expression
% such that the growth of all equations is minimal
% with some penalty for non-linearity increasing substitutions
% no substitutions introducing case distinctions
% no growth of total length of all equations
% good for algebraic problems
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            nil,nil,nil,nil,t,nil,t,cost_limit5,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure subst_level_5(arglist)$
% Substitution of a function by an expression
% such that the growth of all equations is minimal
% with some penalty for non-linearity increasing substitutions
% and substitutions introducing case distinctions
% good for algebraic problems
 make_subst(if length arglist > 4 then nth(arglist,5)
                                  else car arglist,
            cadr arglist,caddr arglist,cadddr arglist,
            subst_4,target_limit_4,nil,nil,nil,nil,t,nil,nil,
            if length arglist > 5 then nth(arglist,6)
                                  else nil
           )$

symbolic procedure factorize_any(arglist)$
% Factorization of a pde and investigation of the resulting subcases
begin scalar l$
 if expert_mode then l:=selectpdes(car arglist,1)
                else l:=cadddr arglist$
 return split_and_crack(get_fact_pde(l,nil),
                                    car arglist,cadr arglist)$
end$

symbolic procedure factorize_to_substitute(arglist)$
% Factorization of a pde and investigation of the resulting subcases
begin scalar l$
 if expert_mode then l:=selectpdes(car arglist,1)
                else l:=cadddr arglist$
 return split_and_crack(get_fact_pde(l,t),
                                    car arglist,cadr arglist)$
end$

symbolic procedure separation(arglist)$
% Direct separation of a pde
if vl_ then % otherwise not possible --> save time
begin scalar p,l,l1,pdes,forg$
 pdes:=car arglist$
 forg:=cadr arglist$
 if expert_mode then l1:=selectpdes(pdes,1)
                else l1:=cadddr arglist$
 if (p:=get_separ_pde(l1)) then
    <1) or
          ((length l = 1) and (car l neq p))) then
         <>$
           l:=list(pdes,forg)>> >>$
 return l$
end$

symbolic procedure alg_solve_system(arglist)$
begin scalar pdes,l1,l2,l3,l4,l5,l6,fl,vl,zd,pdes2$
 pdes:=car arglist$
 %l1:=selectpdes(pdes,nil)$
 l1:=select_from_list(pdes,nil)$
 if null l1 then return nil;
 for each l2 in l1 do vl:=union(get(l2,'vars),vl);
 for each l2 in l1 do fl:=union(get(l2,'fcts),fl);
 l1:=for each l2 in l1 collect get(l2,'val)$
 write"Please give a list of constants, functions or derivatives"$
 terpri()$
 write"of functions to be solved algebraically, like f,g,df(g,x,2);"$
 terpri()$
 l2:=termlistread()$
 if l2 then <<
  l3:=cdr solveeval list(cons('LIST,l1),cons('LIST,l2));

  if null l3 then <<
   write"There is no solution."$
   terpri()
  >> else
  if length l3 > 1 then <<
   write"can currently not handle more than 1 solution"$
   terpri()
  >> else <<
   l3:=for each l4 in l3 collect <<        % for each solution l4
    l4:=for each l5 in cdr l4 collect <<
     zd:=union(zero_den(reval l5,fl,vl),zd)$
     l6:=reval {'PLUS,cadr l5,{'MINUS,caddr l5}}$
     if pairp l6 and (car l6 = 'QUOTIENT) then cadr l6
                                          else l6
    >>       % l4 is now a list of expressions to vanish
   >>;
   if length l3 = 1 then << %######### 1 solution - a restriction for now
    l4:=car l3;             % the solution
    pdes2:=pdes;
    for each l5 in l4 do <<
     l5:=mkeq(if zd then cons('TIMES,append(zd,list l5))
                    else l5,
              fl,vl,allflags_,nil,list(0),nil,pdes)$
     pdes:=eqinsert(l5,pdes)$
    >>;
    if print_ then <<
     pdes2:=setdiff(pdes,pdes2);
     write"New equations: ",pdes2$terpri()$
    >>$
    return {pdes,cadr arglist}
   >>
  >>
 >>
end$

symbolic procedure alg_solve_single(arglist)$
% Solving an equation that is algebraic for a function
% or a derivative of a function,
% So far no flag is installed to remember a corresponding
% investigation because the check is quick and done very
% rarely with lowest priority.
begin scalar l,l1,pdes,forg$
 pdes:=car arglist$
 forg:=cadr arglist$
 if expert_mode then l1:=selectpdes(pdes,1)
                else l1:=cadddr arglist$
 if (l:=algsolvederiv(l1)) then
    <>$
 return l
end$

symbolic procedure alg_for_deriv(p)$
% find the first function with only one sort of derivative
% which in addition occurs non-linear
begin scalar dl,d,f$
 dl:=get(p,'derivs);
 while dl and null d do <<  % for each function
  d:=car dl$     % d is the leading power of the leading deriv. of f
  f:=caar d;     % the next function f
  if fctlength f < get(p,'nvars) then <>
                                 else <<
   dl:=cdr dl;
   if cdr d = 1 then d:=nil; % must not be linear in lead. deriv.
   while dl and (f = caaar dl) do <<
    if d and (car d neq caar dl) then d:=nil;
    dl:=cdr dl
   >>
  >>
 >>;
 return d
end$

symbolic procedure algsolvederiv(l)$
begin scalar d,p,abs_was_not_active$
 while l and null (d:=alg_for_deriv(car l)) do l:=cdr l;
 if d then <<
  p:=cdr d$
  algebraic <<
   abs_was_not_active:=if !%x neq abs !%x then t else nil$
   if abs_was_not_active then let abs_
  >>$
  d:=solveeval list(get(car l,'val),
                    if 1=length car d then caar d
                                      else cons('DF,car d));
  algebraic <<
   if abs_was_not_active then clearrules abs_
  >>$

%  d:=solveeval list(cons('LIST,get(car l,'val)),
%                    {'LIST,if 1=length car d then caar d
%                                             else cons('DF,car d)});
  if d and (car d='LIST) and (length d = p+1) then
  p:=for each el in cdr d collect if car el='EQUAL   then
     reval {'NUM,
     reval {'PLUS,cadr el,{'MINUS,caddr el}}} else d:=nil
                                              else d:=nil;
  if d then <<
   d:=cons('TIMES,p);
   p:=car l;
   d:=mkeq(d,get(p,'fcts),get(p,'vars),allflags_,nil,get(p,'orderings),nil,nil)$
   % last argument is nil as no new inequalities are to be expected.
   if print_ then write p," factorized to ",d
  >>
 >>;
 return if d then p . d
             else nil
end$

symbolic procedure quick_integration(arglist)$
% Integration of a short first order de with at most two terms
begin scalar l,l1,pdes,forg$
 pdes:=car arglist$
 forg:=cadr arglist$
 if expert_mode then
 <>
                else l1:=cadddr arglist$
 if (l:=quick_integrate_one_pde(l1)) then
    <>$
 return l$
end$

symbolic procedure full_integration(arglist)$
% Integration of a pde
% only if then a function can be substituted
begin scalar l,l1,pdes,forg$
 pdes:=car arglist$
 forg:=cadr arglist$
 if expert_mode then
 <>
                else l1:=cadddr arglist$
 if (l:=integrate_one_pde(l1,genint_,t)) then
    <>$
 return l$
end$

symbolic procedure integration(arglist)$
% Integration of a pde
begin scalar l,l1,pdes,forg$
 pdes:=car arglist$
 forg:=cadr arglist$
 if expert_mode then
 <>
                else l1:=cadddr arglist$
 if (l:=integrate_one_pde(l1,genint_,nil)) then
    <>$
 return l$
end$

symbolic procedure multintfac(arglist)$
% Seaching of an integrating factor for a set of pde's
begin scalar pdes,forg,l,stem,ftem,vl,vl1$
 pdes:=car arglist$
 if null pdes or (length pdes=1) then return nil$
 forg:=cadr arglist$
 for each p in pdes do
   if not (get(p,'starde) or get(p,'nonrational)) then
     <>$
 vl1:=vl$
 fnew_:=nil$
 while vl1 do
  if (l:=findintfac(stem,ftem,vl,car vl1,nil,nil,nil,nil)) then
    <>
  else vl1:=cdr vl1$
 return l$
end$

symbolic procedure diff_length_reduction(arglist)$
% Do one length reduction step
begin scalar l$
 l:=dec_and_red_len_one_step(car arglist,ftem_,%cadr arglist,
                             caddr arglist,0)$
 % 0 for ordering
 if l then l:=list(l,cadr arglist)$
 return l$
end$

symbolic procedure high_prio_decoupling(arglist)$
% Do one decoupling step
begin scalar l$
 l:=dec_one_step(car arglist,ftem_,%cadr arglist,
                 caddr arglist,t,0)$
 % 0 for ordering
 if l then l:=list(l,cadr arglist)$
 return l$
end$

symbolic procedure decoupling(arglist)$
% Do one decoupling step
begin scalar l$
 l:=dec_one_step(car arglist,ftem_,%cadr arglist,
                 caddr arglist,nil,0)$
 % 0 for ordering
 if l then l:=list(l,cadr arglist)$
 return l$
end$

symbolic procedure clean_dec(p,pdes,flg)$
begin scalar propty,el,nl,newpropty$
 propty:=get(p,flg)$
 for each el in propty do <<
  nl:=intersection(cdr el,pdes);
  if nl then newpropty:=cons(cons(car el,nl),newpropty)
 >>$
 put(p,flg,reverse newpropty)
end$

symbolic procedure clean_prop_list(pdes)$
if null car recycle_eqns          and
        cdr recycle_eqns          and
   (length cdr recycle_eqns > 50) then
<>$
  % recycle_eqns is a pair of 2 lists:
  % (ready to use eqn. names) . (free eqn. names which still
  %                              may occur in prob_list)
  recycle_eqns:=append(car recycle_eqns,reverse cdr recycle_eqns) . nil;
  nil
>>$

symbolic procedure clean_up(pdes)$
begin scalar newpdes;
  while pdes do <<
    if flagp(car pdes,'to_drop) then
    drop_pde(car pdes,nil,nil)  else
    newpdes:=cons(car pdes,newpdes);
    pdes:=cdr pdes
  >>;
  return reverse newpdes
end$

symbolic procedure add_differentiated_pdes(arglist)$
% all pdes in which the leading derivative of a function of all
% vars occurs nonlinear will be differentited w.r.t all vars and
% the resulting pdes are added to the list of pdes
begin scalar pdes,l,l1,q$
 pdes:=car arglist$
 if expert_mode then l1:=selectpdes(pdes,1)
                else l1:=cadddr arglist$
 for each p in l1 do
  if flagp(p,'to_diff) then
% --------------- it should be differentiated only once
    <1) then
         <>$
         for each v in fctargs f do <<
          q:=mkeq(list('DF,get(p,'val),v),get(p,'fcts),get(p,'vars),
                  delete('to_fullint,delete('to_int,delete('to_diff,allflags_))),
                  t,list(0),nil,pdes)$
           prevent_simp(v,p,q)$
           if print_ then write q," "$
           pdes:=eqinsert(q,pdes)>>$
         remflag1(p,'to_diff)$
         l:=cons(pdes,cdr arglist)>>
    >>$
 return l$
end$

symbolic procedure add_diff_ise(arglist)$
% a star-pde is differentiated and then added
begin scalar pdes,l,l1,q,vli$
  pdes:=car arglist$
  if expert_mode then l1:=selectpdes(pdes,1)
                 else l1:=cadddr arglist$
  for each p in l1 do
  if flagp(p,'to_diff)
     and (null l)
     and get(p,'starde)
  then <<
    vli:=if expert_mode then select_from_list(get(p,'vars),nil)
                        else get(p,'vars);
    if print_ then
    <>$
    for each v in vli do
    <>$
      prevent_simp(v,p,q)$
      %check whether q really includes 'fcts and 'vars: should be ok
      if print_ then write q," "$
      pdes:=eqinsert(q,pdes)$
    >>$
    remflag1(p,'to_diff)$
    l:=cons(pdes,cdr arglist)$
  >>$
  return l$
end$

% ACN can not see ANY place where GB_REDUCE gets set, and so is perhaps
% confused by the test that is made on it here...

fluid '(GB_REDUCE);

symbolic procedure alg_groebner(arglist)$
begin scalar pdes,forg,sol,n,result,l1$
  pdes:=car arglist$
  sol:=
  if GB_REDUCE = 'GB then
  algebraic call_gb(lisp(cons('LIST,ftem_)),
                     lisp(cons('LIST,for each p in pdes collect(get(p,'val)))),
                    lisp 'revgradlex)
  else
  algebraic(groebnerf(lisp(cons('LIST,for each p in pdes collect(get(p,'val)))),
                      lisp(cons('LIST,ftem_)),
                      lisp(cons('LIST,ineq_)) ));
  if print_ then <<
    terpri()$
    write"An algebraic Groebner basis computation yields "$
  >>$
  return
  if sol={'LIST,{'LIST,1}} then <<
    if print_ then write"a contradiction."$
    contradiction_:=t$
    nil
  >>                       else <<
    while pdes do pdes:=drop_pde(car pdes,pdes,nil)$
    sol:=cdr sol;
    if null cdr sol then << % only one solution
      sol:=cdar sol;        % a lisp list of necessarily vanishing expressions
      if print_ then <<
        terpri()$
        write"a single new system of conditions."$
        terpri()$
        write"All previous equations are dropped."$
        terpri()$
        write"The new equations are:"$
      >>$
      pdes:=mkeqlist(sol,ftem_,vl_,allflags_,t,%orderings_prop_list_all()
                     list(0),nil)$
      listprint(pdes)$
      if contradiction_ then nil
                        else {pdes,cadr arglist}
    >>              else << % more than one solution
      if print_ then <<
        terpri()$
        write length sol," cases. All previous equations are dropped."$
      >>$
      n:=0$
      forg:=cadr arglist$
      backup_to_file(pdes,forg,nil)$  % with all pdes deleted
      while sol do <<
        n:=n+1$
        level_:=cons(n,level_)$
        if print_ then <<
          print_level(t)$
          terpri()$write "CRACK is now called with a case resulting "$
          terpri()$write "from a Groebner Basis computation : "
        >>;
        % further necessary step to call crackmain():
        recycle_fcts:=nil$  % such that functions generated in the sub-call
                            % will not clash with existing functions
        pdes:=mkeqlist(cdar sol,ftem_,vl_,allflags_,t,
                       %orderings_prop_list_all()
                       list(0),nil)$
        sol:=cdr sol;
        l1:=crackmain(pdes,forg)$
        if l1 and not contradiction_ then result:=union(l1,result);
        contradiction_:=nil$
        if sol then <<
          l1:=restore_backup_from_file(pdes,forg,nil)$
          pdes:=car l1;  forg:=cadr l1;
        >>
      >>;
      delete_backup()$
      list result
    >>
  >>
end$

symbolic procedure split_and_crack(p,pdes,forg)$
%  for each factor of p CRACKMAIN is called
if p then
begin scalar l,l1,q,contrad,result,n,h,d,newpdes,newineq$
             %,sol,f,newfdep$,bak,s
  n:=0$
  l:=cdr get(p,'val)$                 %  list of factors of p
  contrad:=t$
  if print_ then <<
    terpri()$
    write "factorizing ",p$
    write " we get the alternative equations : "$
    deprint(l)>>$
  backup_to_file(pdes,forg,nil)$
  while l
  do <<
    if (null confirm_subst) or (length l = 1) then <>
                                              else <<
      if n>0 then <<
        write"We have the remaining alternative equations : "$
        deprint(l)$
      >>$
      write"Which equation is to be used next? (number, Enter) "$
      repeat <<
        h:=termread()$
        if not fixp h then <>
      >> until fixp h;
      d:=nth(l,h);
      l:=delete(d,l);
      if member(d,ineq_) then <<
        write"It shows that this factor is in the inequality list"$
        terpri()$
        write"of non-zero expressions."$
        terpri()
      >>
    >>;
    if not member(d,ineq_) then <<

      n:=n+1$
      level_:=cons(n,level_)$
      q:=mkeq(d,get(p,'fcts),get(p,'vars),allflags_,nil,
              get(p,'orderings),nil,pdes)$
      if print_ then <<
        print_level(t)$
        terpri()$
        write "CRACK is now called with the new equation ",q," : "$
        deprint(list d)>>$
      % further necessary step to call crackmain():
      recycle_fcts:=nil$  % such that functions generated in the sub-call
                          % will not clash with existing functions
      newpdes:=eqinsert(q,drop_pde(p,pdes,nil))$
      if freeof(newpdes,q) then <<
        write "It turns out that the next factor is a consequence ",
              "of another equation."$ terpri()$
        write "Therefore the investigation of any factors after ",
              "this one is droped."$ terpri()$
        l:=nil
      >>                   else
      to_do_list:=cons(list('subst_level_35,%newpdes,forg,vl_,list q),
                            list q,newpdes),
                       to_do_list)$
      l1:=if pvm_try() and (null collect_sol)
      then remote_crackmain(newpdes,forg) % i.e. l1:=nil
      else crackmain(newpdes,forg)$
%      newfdep:=nil$
%      for each sol in l1 do
%      if sol then <<
%        for each f in caddr sol do
%        if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep);
%      >>;
%      % newfdep are additional dependencies of the new functions in l1
%      pdes:=car restore_pdes(bak)$ % to restore all global variables and pdes
%      depl!*:=append(depl!*,newfdep);

      if l then << % there are further factors=0 to be investigated
        h:=restore_and_merge(l1,pdes,forg)$
        pdes:= car h;
        forg:=cadr h; % was not assigned above as it has not changed probably
        newineq:=union(list d,newineq);                   % new for %1
        for each h in reverse newineq do <<               % new for %1
          if contradictioncheck(h,pdes) then l:=nil;  % new for %1
          % --> drops factors h in all pdes without asking!!
          % if contradictioncheck then h can not be non-zero
          % but that would be so for all remaining cases --> stop
          if not member(h,ineq_) then addineq(pdes,h)     % new for %1
        >>                                                % new for %1
      >>;

      if not contradiction_ then contrad:=nil$
      if l1 and not contradiction_ then result:=union(l1,result);
      contradiction_:=nil$                           % <--- neu
    >>
  >>$
  delete_backup()$
  contradiction_:=contrad$
  if contradiction_ then result:=nil$
  if print_ then <<
    terpri()$
    write"This completes the investigation of all cases of a factorization."$
    terpri()$
  >>$
  return list result
% by returning `list result' and not just `result', what is returned
% is a list with only a single element. This is indicating that the
% content of what is returned from this procedure is a list of
% crackmain returns and not (pdes,forg) which is returned from
% other modules and which is a list of more than one element.
end$

symbolic procedure split_into_cases(arglist)$
% programmed or interactive introduction of two cases whether a
% given expression is zero or not
begin scalar h,hh,s,pdes,forg,contrad,n,q,l1,
             result,ps,intact$%,newfdep,bak,sol,f,depl
  pdes:=car arglist$
  forg:=cadr arglist$
  if cdddr arglist then h:=cadddr arglist$
  if h=pdes then << % interactive call
    intact:=t$
    terpri()$
    write "Type in the expression for which its vanishing and"$
    terpri()$
    write "non-vanishing should be considered."$
    terpri()$
%  write "Terminate with $ or ; : "$
    write "You can use names of pds, e.g.: "$terpri()$
    write "coeffn(e_12,df(f,x,2),1);    or   df(e_12,df(f,x,2));"$
    terpri()$
    ps:=promptstring!*$
    promptstring!*:=""$
    h:=termxread()$
  >>$
  for each hh in pdes do h:=subst(get(hh,'val),hh,h)$
  h:=reval h;

  if not may_vanish(h) then return <<
    write"According to the known inequalities, ",
         "this expression can not vanish!"$
    terpri()$
    write" --> Back to main menu."$terpri()$
    promptstring!*:=ps$
    nil
  >>$
  if intact then <<
    write"If you first want to consider this expression to vanish and"$ terpri()$
    write"afterwards it to be non-zero then input t"$ terpri()$
    write"                        otherwise input nil : "$
    s:=termread()$
    promptstring!*:=ps$
  >>        else s:=t$

  contrad:=t$
  n:=0$
  %-------------------
  backup_to_file(pdes,forg,nil)$ % moved before again:, should be ok
again:
%  bak:=backup_pdes(pdes,forg)$

  n:=add1 n$
  level_:=cons(n,level_)$
  print_level(t)$
  terpri()$

  if s then <<
    q:=mkeq(h,ftem_,vl_,allflags_,t,list(0),nil,pdes)$
    if print_ then <<
      write "CRACK is now called with the assumption 0 = ",q," : "$
      deprint(list h)$
    >>
  >>   else <<
    if print_ then <<
      write "CRACK is now called with assuming  "$terpri()$
      mathprint h$
      write" to be nonzero. "$
    >>$
    addineq(pdes,h)$
  >>$
  % necessary steps to call crackmain():
  recycle_fcts:=nil$  % such that functions generated in the sub-call
                      % will not clash with existing functions

  % This test comes only now as it drops factors s from all pdes
  if (s=nil) and contradictioncheck(h,car arglist) then <<
    if print_ then <<
      write"According to the system of pdes, this expression must be zero!"$
      terpri()$
      write" --> Back to main menu."$
    >>$
    contradiction_:=nil$
    promptstring!*:=ps$
    l1:=nil$
%    newfdep:=nil$
  >>                                               else <<
    l1:=if pvm_try() and (null collect_sol)
    then remote_crackmain(if null s then pdes
                                    else eqinsert(q,pdes),forg) % ie. l1:=nil
    else crackmain(if null s then pdes else eqinsert(q,pdes),forg)$
%    newfdep:=nil$
%    for each sol in l1 do
%    if sol then <<
%      for each f in caddr sol do
%      if depl:=assoc(f,depl!*) then newfdep:=cons(depl,newfdep);
%    >>;
%    % newfdep are additional dependencies of the new functions in l1
  >>;
%  pdes:=car restore_pdes(bak)$   % to restore all global variables and pdes
%  depl!*:=append(depl!*,newfdep);

  hh:=restore_and_merge(l1,pdes,forg)$
  pdes:= car hh;
  forg:=cadr hh;

  if not contradiction_ then contrad:=nil$
  if l1 and not contradiction_ then result:=union(l1,result);
  contradiction_:=nil$

  if n=1 then <>;

  delete_backup()$
  contradiction_:=contrad$
  if contradiction_ then result:=nil$
  if print_ then <<
    terpri()$
    write"This completes the investigation of all cases of a case-distinction."$
    terpri()$
  >>$
  return list result
% by returning `list result' and not just `result', what is returned
% is a list with only a single element. This is indicating that the
% content of what is returned from this procedure is a list of
% crackmain returns and not (pdes,forg) which is returned from
% other modules and which is a list of more than one element.
end$

symbolic procedure stop_batch(arglist)$
begin
 if !*batch_mode then <<
  write"Drop this point from the proc_list_ with 'o, 'cp or quit with 'q."$
  terpri()$
  !*batch_mode:=nil$
 >>$
 batchcount_:=stepcounter_ - 2$
 return {car arglist,cadr arglist}  % only to have arglist involved
end$

symbolic procedure user_defined(arglist)$
begin
 arglist:=nil;  % only to use arglist
end$

symbolic procedure sub_problem(arglist)$
begin scalar ps,s,h,fl,newpdes,sol,pdes,bak,newfdep,f,sub_afterwards$

 if !*batch_mode then return nil;
 terpri()$
 ps:=promptstring!*$
 promptstring!*:=""$
 write"This module so far works only for linear problems."$terpri()$
 write"Do you want to continue (Y/N)? "$
 repeat s:=termread() until (s='y) or (s='n)$
 if s='n then <<
  promptstring!*:=ps$
  return nil
 >>$
 terpri()$

 % Choice
 write"Do you want to specify a set of equation to be solved --> Enter 1"$
 terpri()$
 write"or a set of functions (and then all equations containing"$
 terpri()$
 write"only these functions are selected)                    --> Enter 2: "$
 repeat h:=termread() until h=1 or h=2$

 if h=1 then <<  %------ Input of a subset of equations
  write"Specify a subset of equations to be solved in the form:  "$
  listprint(car arglist)$
  write";"$ terpri()$
  s:=termlistread()$
  if s=nil then newpdes:=nil else
  if not_included(s,car arglist) then <<
   write"Equations ",setdiff(s,car arglist)," are not valid."$
   terpri()$
   newpdes:=nil
  >>                             else <<
   for each h in s do fl:=union(fl,get(h,'fcts));
   newpdes:=s
  >>
 >>     else <<  %------ Input of a subset of functions
  write"Specify a subset of functions to be solved in the form:  "$
  listprint(ftem_)$
  write";"$ terpri()$
  s:=termlistread()$
  if s=nil then newpdes:=nil else
  if not_included(s,ftem_) then <<
   write"Fnctions ",setdiff(s,ftem_)," are not valid."$
   terpri()$
   newpdes:=nil
  >>                             else <<
   fl:=s;
   % Determining a subset of equations containing only these functions
   for each s in car arglist do
   if null setdiff(get(s,'fcts),fl) then newpdes:=cons(s,newpdes)$
   if null newpdes then <<
    write"There is no subset of equations containing only these functions."$
    terpri()
   >>
  >>
 >>;
 if null newpdes then return nil;

 write "Do you want an automatic substitution "$terpri()$
 write "of computed functions afterwards (Y/N)? "$
 repeat s:=termread() until (s='y) or (s='n)$
 if s='y then sub_afterwards:=t
         else sub_afterwards:=nil;

 promptstring!*:=ps$
 write"CRACK is now called with the following subset of equations"$
 terpri()$
 write newpdes$ terpri()$

 bak:=backup_pdes(car arglist,cadr arglist)$
 sol:=crackmain(newpdes,fl)$
 % One could add an dropredund call here
 newfdep:=nil$
 for each s in sol do
 if s then <<
  for each f in caddr s do
  if h:=assoc(f,depl!*) then newfdep:=cons(h,newfdep);
 >>;
 % newfdep are additional dependencies of the new functions in l1
 pdes:=car restore_pdes(bak)$   % to restore all global variables and pdes
 depl!*:=append(depl!*,newfdep);
 ftem_:=union(ftem_,caddar sol)$

 % Test for contradiction or more than one solution
 % to be investigated further
 for each s in caar  sol do
 pdes:=eqinsert(mkeq(s,ftem_,vl_,allflags_,t,list(0),nil),
                pdes)$
 for each s in cadar sol do
 if pairp s and (car s='EQUAL) then <<
  h:=mkeq({'DIFFERENCE,caddr s,cadr s},ftem_,vl_,allflags_,t,list(0),nil,pdes);
  pdes:=eqinsert(h,pdes)$
  if sub_afterwards then
  to_do_list:=cons(list('subst_level_35,%pdes,cadr arglist,caddr arglist,
                        list h),
                   to_do_list)
 >>$
 ftem_:=union(ftem_,caddar sol)$

 return {pdes,cadr arglist}
end$


endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crtrafo.red0000644000175000017500000005176111526203062023735 0ustar  giovannigiovanni%********************************************************************
module transform$
%********************************************************************
%  Routines for performing transformations
%  Author: Thomas Wolf
%  March 1999
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure input_trafo$
begin scalar ulist,vlist,u,v,ylist,xlist,yslist,xslist,oldprompt,xl2,
             notallowed,full_simplify$
 oldprompt:=promptstring!*$
 promptstring!*:=""$

 write"Under the following conditions this program performs arbitrary"$
 terpri()$
 write"transformations."$
 terpri()$terpri()$

 write"If not only variables but also functions are transformed then it"$
 terpri()$
 write"is assumed that all new functions depend on the same new variables"$
 terpri()$
 write"and that all old functions depend on the same old variables."$
 terpri()$ terpri()$

 write"For these procedures to be applicable the old functions and variables"$
 terpri()$
 write"must be given explicitly in terms of the new ones, not involving"$
 terpri()$
 write"unspecified functions of the new ones. Also the differential "$
 terpri()$
 write"equations to be transformed must contain the old independent and"$
 terpri()$
 write"dependent variables and their partial derivatives explicitly."$
 terpri()$

% write"Hint: Splitting a single transformation involving many"$
% terpri()$
% write"variables into many transformations involving each only few"$
% terpri()$
% write"variables speeds the whole transformation up."$
% terpri()$

 terpri()$
 write"Give a list of new functions, e.g. `u1,u2,u3;' in the order to"$
 terpri()$
 write"be used to sort dervatives. If there are no new functions enter ;"$
 terpri()$
 ulist := termlistread()$

 terpri()$
 write"Give a list of all new variables, e.g. 'v1,v2,v3;' in the order to"$
 terpri()$
 write"be used to sort derivatives. If there are no new variables enter ;"$
 terpri()$
 vlist := termlistread()$

 if ulist then <<
  for each u in ulist do
  for each v in vlist do depend u,v$

  terpri()$
  write"Give a list of all substitutions of old functions in terms of"$
  terpri()$
  write"new functions and new variables, e.g. y1=2*u1+u2*v2, y2=u2-u1*v1;"$
  terpri()$
  write"If there are no substitutions of old functions enter ;"$
  terpri()$
  yslist := termlistread()$

  % Check whether all old functions do depend on the same variables
  ylist:=for each u in yslist collect cadr u$
  xlist:=fctargs car ylist$
  for each u in cdr ylist do <<
   xl2:=fctargs u$
   if not_included(xlist,xl2) or
      not_included(xl2,xlist) then <<
    notallowed:=t$
    terpri()$
    write"Functions ",car ylist,",",u," do not depend on the same variables!"$
   >>
  >>
 >>$

 if notallowed then return nil;

 if vlist then <<
  terpri()$
  write"Give a list of all substitutions of old variables in terms of"$
  terpri()$
  write"new functions and new variables, e.g. x1=v1-v2*u2, x2=3*v2+v1*u1;"$
  terpri()$
  xslist := termlistread()$
 >>$

 terpri()$
 write"Shall the transformed equation be fully simplified,"$
 terpri()$
 write"i.e. redundand non-vanishing factors be dropped y/n : "$
 full_simplify:=termread()$
 if (full_simplify='n) then full_simplify:=nil;
 terpri()$

 % Dependence of the new dependent variables on old independent variables
 % which are not transformed
 for each v in xslist do xlist:=setdiff(xlist,list cadr v);
 for each u in ulist do
 for each v in xlist do depend u,v$

 % Also non-changing old variables must enter the transformation as
 % partial derivatives wrt them will have a different meaning
 vlist:=append(vlist,xlist)$
 for each v in xlist do xslist:=cons({'EQUAL,v,v},xslist)$

 % If a test is necessary that all old variables are replaced then do
 % if (not not_included(ftem_,newli)) and
 %    (not not_included(newli,ftem_)) then
 promptstring!*:=oldprompt$

 if print_ then <<
  write"The transformation:"$terpri()$
  if vlist then <<
   write"The new variables: "$
   listprint(vlist)$terpri()
  >>;
  if ulist then <<
   write"The new functions: "$
   listprint(ulist)$terpri()
  >>;
  if xslist then <<
   write"The old variables expressed:"$terpri()$
   mathprint cons('LIST,xslist)
  >>;
  if yslist then <<
   write"The old functions expressed:"$terpri()$
   mathprint cons('LIST,yslist)
  >>;
 >>;

 return {'LIST,cons('LIST,ulist),
               cons('LIST,vlist),
               cons('LIST,yslist),
               cons('LIST,xslist),
               full_simplify }
end$

%----------------------------

symbolic procedure adddep(xlist)$
% all functions depending on old variables get a dependency on
% the new variables
% xlist is a lisp list ((x1,v1,v4,v5),(x2,v2,v3,v4),...)
begin scalar newdep,xs,dp;
 for each xs in xlist do <<
  newdep:=nil$
  while depl!* do <<
   dp:=car depl!*;
   depl!*:=cdr depl!*;
   if not freeof(dp,car xs) then
   dp:=cons(car dp,union(cdr xs,cdr dp))$
   newdep:=cons(dp,newdep);
  >>;
  depl!*:=reverse newdep;
 >>;
end$

%----------------------------

symbolic procedure dropdep(xlist)$
% xlist is a lisp list
begin scalar x,dp,newdep$
 for each x in xlist do <<
  newdep:=nil$
  while depl!* do <<
   dp:=car depl!*;
   depl!*:=cdr depl!*;
   if not freeof(dp,x) then
   dp:=delete(x,dp)$
   newdep:=cons(dp,newdep);
  >>;
  depl!*:=reverse newdep
 >>;
end$

%----------------------------

%symbolic operator TransfoDf$
symbolic procedure TransfoDf(dy,yslist,xlist,vlist)$
% - dy is the derivative to be transformed
% - yslist is a list of already computed substitutions for the old
%   functions and their derivatives
% - xlist is a list of the old variables
% - vlist is a list of the new variables
% All parameters are in prefix form.
% yslist,xlist,vlist are lisp lists
% returns cons(substitution for dy, complete list of substitutions)
begin
 scalar cpy,x,dym1,m,n,newdy,v$
 cpy:=yslist$
 while cpy and
       (dy neq cadar cpy) do cpy:=cdr cpy;
 return
 if not null cpy then cons(car cpy,yslist)          else  % found rule
 if not pairp dy then cons({'EQUAL,dy,dy},yslist) else << % no dy-rule
  % dym1 is one lower x-derivative than dy
  if ( length dy = 3      ) or
     ((length dy = 4) and
      (cadddr dy = 1)     ) then <>
                            else <<
   cpy:=reverse dy;
   dym1:=reverse
   if not numberp car cpy then <> else
   if (car cpy = 1)       then <> else
   if (car cpy = 2)       then <> else
                               <>
  >>;
  yslist:=TransfoDf(dym1,yslist,xlist,vlist);
  dym1:=car yslist;      % dym1 is now a substitution rule for dym1 above
  dym1:=caddr dym1;      % dym1 is now the expression to be substituted
  yslist:=cdr yslist;    % the new substitution list
  % computation of the subst. rule for dy
  m:=1;
  while xlist and (x neq car xlist) do <>$
  if null xlist then newdy:=reval {'DF,dym1,x}
                else <<
   n:=0;
   for each v in vlist do <<
    n:=add1 n;
    if not zerop algebraic(Dv!/Dx(n,m)) then
    newdy:=cons({'TIMES,{'DF,dym1,v},algebraic(Dv!/Dx(n,m))},
                newdy)$
    % {'DF,dym1,v} is the full total derivative as it should be
    % provided all functions depend directly on v (as stored in depl!*)
    % or they do not depend on v but not like f(u(v)) with an
    % unspecified f(u)
   >>;
   newdy:=if cdr newdy then reval cons('PLUS,newdy)
                       else if newdy then reval car newdy
                                     else 0
  >>$

  % return the new subst. rule and the new yslist
  cons({'EQUAL,dy,newdy},cons({'EQUAL,dy,newdy},yslist))
 >>
end$ % of TransfoDf

%----------------------------

symbolic procedure Do_Trafo(arglist,x)$
begin
 scalar yslist,xslist,ulist,vlist,xlist,ylist,m,n,ovar,nvar,e1,e2,e3,
        x,detpd,pdes,hval,trfo,newforg,newineq_,drvs,full_simplify$
        %dyx!/duv,Dv!/Dx

 algebraic <<
  % input of the transformation
  ulist :=first x$ x:=rest x$
  vlist :=first x$ x:=rest x$
  yslist:=first x$
  xslist:=second x$
  full_simplify:=third x$ x:=nil$
 >>$

 % update of depl!*
 xlist:=
 for each e1 in cdr xslist collect <<
  x:=caddr e1$
  e3:=nil;
  for each e2 in cdr vlist do
  if not freeof(x,e2) then e3:=cons(e2,e3);
  cons(cadr e1,e3)
 >>$
 adddep(xlist)$

 algebraic <<
  % checking regularity of the transformation
  m:=length(xslist); n:=length(yslist)+m;
  clear dyx!/duv,Dv!/Dx;
  matrix dyx!/duv(n,n);
  matrix Dv!/Dx(m,m);
  ovar:=append(yslist,xslist);
  nvar:=append(ulist,vlist);
  n:=0;
  for each e1 in ovar do <<
   n:=n+1;m:=0;
   for each e2 in nvar do <<
    m:=m+1;
    dyx!/duv(m,n):=df(rhs e1,e2)
   >>
  >>;

  detpd:=det(dyx!/duv);
  if detpd=0 then <>;
  clear dyx!/duv;
  % computation of Dv/Dx:=(Dx/Dv)^(-1)
  n:=0;
  for each e1 in xslist do <<
   n:=n+1;m:=0;
   for each e2 in vlist do <<
    m:=m+1;
    Dv!/Dx(n,m):=total_alg_mode_deriv(rhs e1,e2)
                % It is assumed that ulist does depend on vlist
   >>
  >>;
  Dv!/Dx:=Dv!/Dx**(-1);
 >>$
 xslist:=cdr xslist$
 yslist:=cdr yslist$
 vlist :=cdr vlist$
 ulist :=cdr ulist$

 % update of global data ftem_, vl_
 if ulist then <<
  for each e1 in yslist do ftem_:=delete(cadr e1,ftem_);
  for each e1 in  ulist do ftem_:=fctinsert(e1,ftem_)$
 >>$

 xlist:=for each e1 in xslist collect cadr e1$
 for each e1 in xlist do vl_:=delete(e1,vl_);
 vl_:=append(vl_,vlist)$

 ylist:=for each e1 in yslist collect cadr e1$

 % update of the pdes
 pdes:=car arglist$
 for each e1 in pdes do <<
  hval:=get(e1,'val)$
  drvs:=append(search_li2(hval,'DF),ylist)$
  for each e3 in drvs do <<
   trfo:=TransfoDf(e3,yslist,xlist,vlist)$
   hval:=subst(caddar trfo,cadar trfo,hval);
   yslist:=cdr trfo
  >>$
  for each e2 in xslist do
  if not freeof(hval,cadr e2) then
  hval:=subst(caddr e2,cadr e2,hval);
  put(e1,'val,hval);
 >>$

 % update of forg
 for each e1 in cadr arglist do
 if (pairp e1) and (car e1 = 'EQUAL) then <<
  hval:=caddr e1;
  drvs:=append(search_li2(hval,'DF),ylist)$
  for each e3 in drvs do <<
   trfo:=TransfoDf(e3,yslist,xlist,vlist)$
   hval:=subst(caddar trfo,cadar trfo,hval);
   yslist:=cdr trfo
  >>$
  for each e2 in xslist do
  if not freeof(hval,cadr e2) then
  hval:=subst(caddr e2,cadr e2,hval);
  hval:=reval hval;

  newforg:=cons({'EQUAL,cadr e1,hval},newforg)$
  e2:=nil;
  for each e3 in ftem_ do
  if not freeof(hval,e3) then e2:=cons(e3,e2);
  put(cadr e1,'fcts,e2)
 >>                                  else
 if not freeof(ylist,e1) then <<
  e3:=yslist;
  while e3 and cadar e3 neq e1 do e3:=cdr e3$
  if e3 then newforg:=cons(car e3,newforg)
        else newforg:=cons(e1,newforg)
 >>                                  else
 newforg:=cons(e1,newforg);

 % update of ineq_
 newineq_:=nil;
 for each e1 in ineq_ do <<
  drvs:=append(search_li2(e1,'DF),ylist)$
  for each e3 in drvs do <<
   trfo:=TransfoDf(e3,yslist,xlist,vlist)$
   e1:=subst(caddar trfo,cadar trfo,e1);
   yslist:=cdr trfo
  >>$
  for each e2 in xslist do
  if not freeof(e1,cadr e2) then
  e1:=subst(caddr e2,cadr e2,e1);
  newineq_:=cons(reval e1,newineq_)
 >>$
 ineq_:=nil;
 for each e1 in newineq_ do addineq(pdes,e1);

 xlist:=nil;
 for each e1 in xslist do
 if cadr e1 neq caddr e1 then xlist:=cons(cadr e1,xlist);
 dropdep(xlist)$

 for each e1 in pdes do <<
  for each e2 in allflags_ do flag1(e1,e2)$
  update(e1,get(e1,'val),ftem_,vl_,full_simplify,list(0),pdes)$
  drop_pde_from_idties(e1,pdes,nil);
  drop_pde_from_properties(e1,pdes)
 >>$

 % cleanup
 algebraic clear Dv!/Dx;
 return {pdes,newforg,vl_}

end$ % of Do_Trafo

%----------------------------

symbolic procedure Find_Trafo(arglist)$
begin
 scalar dli,avf,f,ps,sol,pde,pdes,forg,batch_bak,print_bak,vlist,
        xslist,vl,h1,h2,h3,h4,trtr,eligfncs,eligpdes,epdes,remain,
        maxvno;
% trtr:=t$
 ps:=promptstring!*$
 promptstring!*:=""$
 pdes:=car arglist$
 % If there are functions of fewer variables then transformations can
 % make them to functions of more variables which can add solutions.
 % One could first compute the transformation and then check whether
 % there is an ftem_ function which has an enlarged set of dependent
 % variables and in this case either drops the transformation or one
 % adds extra conditions df(f,y)=0 (where d/dy is to be transformed)
 % for these functions. Instead a preliminary simpler routs is taken
 % in the following, ftem_ may contain only constants or functions
 % of the same number of variables.

 maxvno:=0;
 h1:=ftem_;
 while h1 and <<
  h3:=fctlength car h1$
  if h3=0 then t else
  if maxvno=0 then <> else
  if h3=maxvno then t else nil
 >> do h1:=cdr h1;
 if h1 then return <<
  if print_ then <<
   write"Non-constant functions of fewer variables prevent"$terpri()$
   write"the application of this technique."$terpri()
  >>$
  nil
 >>$
 if trtr then <>$

 % Find eligible PDEs
 while pdes do <<
  pde:=car pdes;pdes:=cdr pdes;
  if get(pde,'nvars)=maxvno then <<
   eligfncs:=nil;
   avf:=get(pde,'allvarfcts)$
   if avf and null cdr avf then <<
    % There must only be one function of all variables because
    % the other one would be part of the inhomogeneity and
    % derivatives of this function would give errors in quasilinpde
    % when the differentiation variable becomes a function in the
    % characteristic ODE system and substitutions are done where
    % the function is substituted by an expression that has been
    % computed. But also if no derivatives occur, crack is strictly
    % speaking not able to deal with funtions of functions.
    % Therefore only one function apart from constants is allowed.
    f:=car avf;
    dli:=get(pde,'derivs);
    h1:=t; h2:=0;  % h2 counts the first order derivatives of f
    while dli and h1 do
    if (not pairp caar dli) or
       (caaar dli neq f) then dli:=cdr dli else
    if null cdaar dli then dli:=cdr dli else % f algebraic
    if null cddaar dli then <>
                       else h1:=nil;
    if null dli and (h2 > 1) then eligfncs:=cons(f,eligfncs)

   >>$
   if eligfncs then <<
    eligpdes:=cons(cons(pde,eligfncs),eligpdes);
    epdes:=cons(pde,epdes)
   >>
  >>
 >>$
 if trtr then <>$
 if null epdes then return nil;

 if expert_mode then pde:=selectpdes(epdes,1)
                else <<
 if trtr then <>$

  % Find PDEs with min number of allvar functions
  h2:=10000;
  for each h1 in epdes do <<
   h3:=length get(h1,'allvarfcts);
   if h3
> else
   if h3=h2 then remain:=cons(h1,remain);
  >>;
  epdes:=remain;
  if trtr then <>$

  % Find PDEs with max number of variables
  h2:=0;
  for each h1 in epdes do <<
   h3:=get(h1,'nvars);
   if h3>h2 then <> else
   if h3=h2 then remain:=cons(h1,remain);
  >>;
  epdes:=remain;
  if trtr then <>$

  % Find shortest of these PDEs
  h2:=10000;
  for each h1 in epdes do <<
   h3:=get(h1,'terms);
   if h3
> else
   if h3=h2 then remain:=cons(h1,remain);
  >>;
  epdes:=remain;
  if trtr then <>$

  pde:=car epdes$   % One could select further the one with the
                    % fewest variables involved in the transformation
  while eligpdes and caar eligpdes neq pde do eligpdes:=cdr eligpdes;
  f:=cadar eligpdes;

 >>$
 if trtr then <>$
 if null pde then return nil;
 if trtr then <>$

 if print_ then <<
  write"Finding a transformation to integrate the 1st order PDE ",pde,":"$
  terpri()$
 >>$

 print_bak:=print_;       print_:=nil$
 batch_bak:=!*batch_mode; !*batch_mode:=t$
 pdes:=car arglist$
 forg:=cadr arglist$

 h1:=level_string(session_)$
 h1:=bldmsg("%s%s.",h1,"qlp")$
 backup_to_file(pdes,forg,h1)$ % moved before again:, should be ok
 if trtr then <>$
 sol:=reval algebraic(quasilinpde(lisp(get(pde,'val)),f,
                                  lisp(cons('LIST,get(pde,'vars)))))$
 restore_backup_from_file(pdes,forg,h1)$
 delete!-file h1;
 if trtr then <>$
 if trtr then <>$

 !*batch_mode:=batch_bak$ print_:=print_bak$
 if null sol or null cdr sol or null cdadr sol then return nil$
 sol:=cadr sol;

 h1:=cdr sol;
 for each h2 in h1 do
 if not freeof(h2,f) then sol:=delete(h2,sol);
 % One could use lin_check(h2,{f}) to test linearity if needed

 h1:=cdr sol;
 if trtr then <>             else xslist:=cdr reval car xslist$
 if trtr then <>$

 h3:=nil;
 while xslist do <<
  f:=car xslist; xslist:=cdr xslist;

  if (car f='EQUAL) and
     ((pairp caddr f) and
      (caaddr f = 'ARBCOMPLEX)) then <<
   h2:=delete(cadr f,h2);
   h3:=cons(cadr f,h3);
   xslist:=subst(1,caddr f,xslist)
  >>
 >>$
 if trtr then <>             else xslist:=car xslist$

 if trtr or print_ then <<
  write"The following variable transformation expresses variables"$
  terpri()$
  listprint(h3);
  write"  through variables  "$
  listprint(vlist); write" :"$terpri()$
  for each f in cdr xslist do mathprint f
 >>$

 h3:=for each h1 in vl collect {'EQUAL,caddr h1,cadr h1};
 done_trafo:=cons('LIST,cons(cons('LIST,h3),cdr done_trafo));

 return Do_Trafo(arglist,{'LIST,{'LIST},cons('LIST,vlist),
                          {'LIST},xslist,t %full_simplify
                         });

end$ % of Find_Trafo

%----------------------------

symbolic procedure General_Trafo(arglist)$
% Doing a transformation for all data relevant in CRACK
% Tramsformation rule for partial derivatives d using total
% derivatives D:
%
%          /   p \ -1
%   d     |  Dx   |    D
%   --- = |  ---  |  * ---
%     p   |    i  |      i
%   dx     \ Dv  /     Dv
%
begin
 scalar x;
 x:=input_trafo()$
 if null x then return
 < no transformation"$nil>>$
 return Do_Trafo(arglist,x)
end$

%----------------------------

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/applysym.tex0000644000175000017500000016006211526203062024174 0ustar  giovannigiovanni\documentclass[12pt]{article}

%Sets size of page and margins
\oddsidemargin -8mm  \evensidemargin -8mm
\topmargin 0pt   \headheight 0pt   \headsep 0pt
\textwidth 17cm

\title{Programs for Applying Symmetries of PDEs}
\author{Thomas Wolf \\                        
        Department of Mathematics \\
        Brock University \\
        St.Catharines \\
        Ontario, Canada L2S 3A1 \\
        twolf@brocku.ca}

\begin{document}
\maketitle
\begin{abstract}
In this paper the programs {\tt APPLYSYM}, {\tt QUASILINPDE} and
{\tt DETRAFO} are described which aim at the utilization
of infinitesimal symmetries of differential equations. The purpose
of {\tt QUASILINPDE} is the general solution of
quasilinear PDEs. This procedure is used by {\tt APPLYSYM}
for the application of point symmetries for either
\begin{itemize}
\item calculating similarity variables to perform a point transformation
which lowers the order of an ODE or effectively reduces the number of
explicitly occuring independent variables in a PDE(-system) or for
\item generalizing given special solutions of ODEs / PDEs with new constant
parameters.
\end{itemize}

The program {\tt DETRAFO} performs arbitrary point- and contact
transformations of ODEs / PDEs and is applied if similarity
and symmetry variables have been found.
The program {\tt APPLYSYM} is used in connection with the program
{\tt LIEPDE} for formulating and solving the conditions for point- and
contact symmetries which is described in \cite{LIEPDE}.
The actual problem solving is done in all these programs through a call
to the package {\tt CRACK} for solving overdetermined PDE-systems.
\end{abstract}

\tableofcontents
%-------------------------------------------------------------------------
\section{Introduction and overview of the symmetry \\ method}
The investigation of infinitesimal symmetries of differential equations
(DEs) with computer algebra programs attrackted considerable attention
over the last years. Corresponding programs are available in all
major computer algebra systems. In a review article by W.\ Hereman
\cite{WHer} about 200 references are given, many of them describing related
software.

One reason for the popularity of the symmetry method
is the fact that Sophus Lie's method
\cite{lie1},\cite{lie2} is the most widely
used method for computing exact solutions of non-linear DEs. Another reason is
that the first step in this
method, the formulation of the determining equation for the generators
of the symmetries, can already be very cumbersome, especially in the
case of PDEs of higher order and/or in case of many dependent and independent
variables. Also, the formulation of the conditions is a straight forward
task involving only differentiations and basic algebra - an ideal task for
computer algebra systems. Less straight forward is the automatic solution
of the symmetry conditions which is the strength of the program {\tt LIEPDE}
(for a comparison with another program see \cite{LIEPDE}).

The novelty described in this paper are programs aiming at
the final third step: Applying symmetries for
\begin{itemize}
\item calculating similarity variables to perform a point transformation
which lowers the order of an ODE or effectively reduces the number of
explicitly occuring independent variables of a PDE(-system) or for
\item generalizing given special solutions of ODEs/PDEs with new constant
parameters.
\end{itemize}
Programs which run on their own but also allow interactive user control
are indispensible for these calculations. On one hand the calculations can
become quite lengthy, like variable transformations of PDEs (of higher order,
with many variables). On the other hand the freedom of choosing the right
linear combination of symmetries and choosing the optimal new symmetry- and
similarity variables makes it necessary to `play' with the problem
interactively.

The focus in this paper is directed on questions of implementation and
efficiency, no principally new mathematics is presented.

In the following subsections a review of the first two steps of the symmetry
method is given as well as the third, i.e.\ the application step is outlined.
Each of the remaining sections is devoted to one procedure.
%---------------------------------------
\subsection{The first step: Formulating the symmetry conditions}

To obey classical Lie-symmetries, differential equations
\begin{equation}
H_A = 0              \label{PDEs}
\end{equation}
for unknown functions $y^\alpha,\;\;1\leq \alpha \leq p$
of independent variables $x^i,\;\;1\leq i \leq q$
must be forminvariant against infinitesimal transformations
\begin{equation}
\tilde{x}^i = x^i + \varepsilon \xi^i, \;\; \;\;\;
        \tilde{y}^\alpha = y^\alpha + \varepsilon \eta^\alpha  \label{tran}
\end{equation}
in first order of $\varepsilon.$ To transform the equations (\ref{PDEs})
by (\ref{tran}), derivatives of $y^\alpha$ must be transformed, i.e. the part
linear in $\varepsilon$ must be determined. The corresponding formulas are
(see e.g. \cite{Olv}, \cite{Step})
\begin{eqnarray}
\tilde{y}^\alpha_{j_1\ldots j_k} & = &
y^\alpha_{j_1\ldots j_k} + \varepsilon
\eta^\alpha_{j_1\ldots j_k} + O(\varepsilon^2)  \nonumber \\ \vspace{3mm}
\eta^\alpha_{j_1\ldots j_{k-1}j_k} & = &
  \frac{D \eta^\alpha_{j_1\ldots j_{k-1}}}{D x^k} -
  y^\alpha_{ij_1\ldots j_{k-1}}\frac{D \xi^i}{D x^k} \label{recur}
\end{eqnarray}
where $D/Dx^k$ means total differentiation w.r.t.\ $x^k$ and
from now on lower latin indices of functions $y^\alpha,$ 
(and later $u^\alpha$)
denote partial differentiation w.r.t.\ the independent variables $x^i,$
(and later $v^i$).
The complete symmetry condition then takes the form
\begin{eqnarray}
X H_A & = & 0 \;\; \; \; \mbox{mod} \; \; \; H_A = 0\  \label{sbed1} \\
X & = & \xi^i \frac{\partial}{\partial x^i} +
 \eta^\alpha \frac{\partial}{\partial y^\alpha} +
 \eta^\alpha_m \frac{\partial}{\partial y^\alpha_m} +
 \eta^\alpha_{mn} \frac{\partial}{\partial y^\alpha_{mn}} + \ldots +
 \eta^\alpha_{mn\ldots p} \frac{\partial}{\partial y^\alpha_{mn\ldots p}}.
\label{sbed2}
\end{eqnarray}
where mod $H_A = 0$ means that the original PDE-system is used to replace
some partial derivatives of $y^\alpha$ to reduce the number of independent
variables, because the symmetry condition (\ref{sbed1}) must be
fulfilled identically in $x^i, y^\alpha$ and all partial
derivatives of $y^\alpha.$

For point symmetries, $\xi^i, \eta^\alpha$ are functions of $x^j,
y^\beta$ and for contact symmetries they depend on $x^j, y^\beta$ and
$y^\beta_k.$ We restrict ourself to point symmetries as those are the only
ones that can be applied by the current version of the program {\tt APPLYSYM}
(see below). For literature about generalized symmetries see \cite{WHer}.

Though the formulation of the symmetry conditions (\ref{sbed1}),
(\ref{sbed2}), (\ref{recur})
is straightforward and handled in principle by all related
programs \cite{WHer}, the computational effort to formulate
the conditions (\ref{sbed1}) may cause problems if
the number of $x^i$ and $y^\alpha$ is high.  This can
partially be avoided if at first only a few conditions are formulated
and solved such that the remaining ones are much shorter and quicker to
formulate.

A first step in this direction is to investigate one PDE $H_A = 0$
after another, as done in \cite{Cham}.  Two methods to partition the
conditions for a single PDE are described by Bocharov/Bronstein
\cite{Alex} and Stephani \cite{Step}.

In the first method only those terms of the symmetry condition
$X H_A = 0$ are calculated which contain 
at least a derivative of $y^\alpha$ of a minimal order $m.$ 
Setting coefficients
of these $u$-derivatives to zero provides symmetry conditions. Lowering the
minimal order $m$ successively then gradually provides all symmetry conditions.

The second method is even more selective. If $H_A$ is of order $n$
then only terms of the symmetry condition $X H_A = 0$ are generated which
contain $n'$th order derivatives of $y^\alpha.$ Furthermore these derivatives
must not occur in $H_A$ itself. They can therefore occur 
in the symmetry condition
(\ref{sbed1}) only in
$\eta^\alpha_{j_1\ldots j_n},$ i.e. in the terms
\[\eta^\alpha_{j_1\ldots j_n}
\frac{\partial H_A}{\partial y^\alpha_{j_1\ldots j_n}}. \]
If only coefficients of $n'$th order derivatives of $y^\alpha$ need to be
accurate to formulate preliminary conditions
then from the total derivatives to be taken in
(\ref{recur}) only that part is performed which differentiates w.r.t.\ the
highest $y^\alpha$-derivatives.
This means, for example, to form only
$y^\alpha_{mnk} \partial/\partial y^\alpha_{mn} $
if the expression, which is to be differentiated totally w.r.t.\ $x^k$,
contains at most second order derivatives of $y^\alpha.$

The second method is applied in {\tt LIEPDE}.
Already the formulation of the remaining conditions is speeded up
considerably through this iteration process. These methods can be applied if
systems of DEs or single PDEs of at least second order are investigated
concerning symmetries.
%---------------------------------------
\subsection{The second step: Solving the symmetry conditions}
The second step in applying the whole method consists in solving the
determining conditions (\ref{sbed1}), (\ref{sbed2}), (\ref{recur})
which are linear homogeneous PDEs for $\xi^i, \eta^\alpha$. The
complete solution of this system is not algorithmic any more because the
solution of a general linear PDE-system is as difficult as the solution of
its non-linear characteristic ODE-system which is not covered by algorithms
so far.

Still algorithms are used successfully to simplify the PDE-system by
calculating
its standard normal form and by integrating exact PDEs
if they turn up in this simplification process \cite{LIEPDE}.
One problem in this respect, for example,
concerns the optimization of the symbiosis of both algorithms. By that we
mean the ranking of priorities between integrating, adding integrability
conditions and doing simplifications by substitutions - all depending on
the length of expressions and the overall structure of the PDE-system.
Also the extension of the class of PDEs which can be integrated exactly is
a problem to be pursuit further.

The program {\tt LIEPDE} which formulates the symmetry conditions calls the
program {\tt CRACK} to solve them. This is done in a number of successive
calls in order to formulate and solve some first order PDEs of the
overdetermined system first and use their solution to formulate and solve the
next subset of conditions as described in the previous subsection. 
Also, {\tt LIEPDE} can work on DEs that contain parametric constants and
parametric functions. An ansatz for the symmetry generators can be
formulated. For more details see \cite{LIEPDE} or \cite{WoBra}.

The procedure {\tt LIEPDE} is called through \\
{\tt LIEPDE({\it problem,symtype,flist,inequ}); } \\
All parameters are lists. \vspace{6pt} \\
The first parameter specifies the DEs to be investigated: \\
{\it problem} has the form \{{\it equations, ulist, xlist}\} where
\begin{tabbing}
\hspace{0.5cm}
 {\it equations } \=  is a list of equations,
              each has the form {\tt df(ui,..)=...} where \\
       \> the LHS (left hand side) {\tt df(ui,..)} is selected such that \\
       \>  - The RHS (right h.s.) of an equations must not include     \\
       \>$\;\,$ the derivative on the LHS nor a derivative of it.  \\
       \>  - Neither the LHS nor any derivative of it of any equation \\
       \>$\;\,$ may occur in any other equation.\\
       \>  - Each of the unknown functions occurs on the LHS of \\
       \>$\;\,$ exactly one equation.  \\
\hspace{0.5cm}
 {\it ulist} \>  is a list of function names, which can be chosen freely \\
\hspace{0.5cm}
 {\it xlist}  \>  is a list of variable names, which can be chosen freely 
\end{tabbing}
Equations can be given as a list of single differential expressions and then
the program will try to bring them into the `solved form' {\tt df(ui,..)=...}
automatically. If equations are given in the solved form then the above
conditions are checked and execution is stopped it they are not satisfied.
An easy way to get the equations in the desired form is to use \\
\verb+    FIRST SOLVE({+{\it eq1,eq2,}...\verb+},{+{\it one highest
derivative for each function u}\verb+})+  \\
(see the example of the Karpman equations in {\tt LIEPDE.TST}). 
The example of the Burgers equation in {\tt LIEPDE.TST} demonstrates 
that the number of symmetries for a given maximal order of the infinitesimal
generators depends on the derivative chosen for the LHS.

The second parameter {\it symtype} of {\tt LIEPDE} is a list $\{\;\}$ that
specifies the symmetry to be calculated. {\it symtype} can have the following
values and meanings:
\begin{tabbing}
\verb+{"point"}         + \= Point symmetries with $\xi^i=\xi^i(x^j,u^{\beta}),\;
                           \eta^{\alpha}=\eta^{\alpha}(x^j,u^{\beta})$ are \\
                          \> determined.\\
\verb+{"contact"}+ \> Contact symmetries with $\xi^i=0, \;
                            \eta=\eta(x^j,u,u_k)$ are \\
\> determined $(u_k = \partial u/\partial x^k)$, which is only applicable if a \\
                      \> single equation (\ref{PDEs}) with an order $>1$ for a 
                             single function \\
                      \> $u$ is to be investigated. (The {\it symtype}
                             \verb+{"contact"}+ \\
\> is equivalent to \verb+{"general",1}+ (see below) apart from \\
\> the additional checks done for \verb+{"contact"}+.)\\
\verb+{"general"+,{\it order}\verb+}+ \> where {\it order} is an integer $>0$. 
      Generalized symmetries $\xi^i=0,$ \\
\> $\eta^{\alpha}=\eta^{\alpha}(x^j,u^{\beta},\ldots,u^{\beta}_K)$ 
      of a specified order are determined \\
\> (where $_K$ is a multiple index representing {\it order} many indices.) \\
\> NOTE: Characteristic functions of generalized symmetries \\
\> ($= \eta^{\alpha}$ if $\xi^i=0$) are equivalent if they are equal on\\
\> the solution manifold. Therefore, all dependences of\\
\> characteristic functions on the substituted derivatives \\
\> and their derivatives are dropped. For example, if the heat \\
\> equation is given as $u_t=u_{xx}$ (i.e.\ $u_t$ is substituted by $u_{xx}$) \\
\> then \verb+{"general",2}+ would not include characteristic \\
\> functions depending on $u_{tx}$ or $u_{xxx}$. \\
\> THEREFORE: \\
\> If you want to find {\it all} symmetries up to a given order then either \\
\> - avoid using $H_A=0$ to substitute lower order \\
\> $\;\,$derivatives by expressions involving higher derivatives, or \\
\> - increase the order specified in {\it symtype}. \\
\> For an illustration of this effect see the two symmetry \\
\> determinations of the Burgers equation in the file \\
\> {\tt LIEPDE.TST}. \\
\verb+{xi!_+{\it x1}\verb+ =...,..., +  \>  \\ 
\verb+ eta!_+{\it u1}\verb+=...,...}+  \> It is possible to specify an
ansatz for the symmetry. Such \\
\> an ansatz must specify all $\xi^i$ for all independent variables and \\
\> all $\eta^{\alpha}$ for all dependent variables in terms of differential \\
\> expressions which may involve unknown functions/constants. \\
\> The dependences of the unknown functions have to be declared \\
\> in advance by using the {\tt DEPEND} command. For example, \\
\> \verb+    DEPEND f, t, x, u$  + \\
\> specifies $f$ to be a function of $t,x,u$. If one wants to have $f$ as \\
\> a function of derivatives of $u(t,x)$, say $f$ depending on $u_{txx}$, \\
\> then one \underline{{\it cannot}} write \\
\> \verb+    DEPEND f, df(u,t,x,2)$ + \\ 
\> but instead must write \\
\> \verb+    DEPEND f, u!`1!`2!`2$ + \\
\> assuming {\it xlist} has been specified as \verb+ {t,x}+. 
   Because $t$ is the \\
\> first variable and $x$ is the second variable in {\it xlist} and $u$ is \\
\> differentiated oncs wrt.\ $t$ and twice wrt.\ $x$ we therefore \\
\> use \verb+ u!`1!`2!`2+. The character {\tt !} is the escape character \\
\> to allow special characters like ` to occur in an identifier. \\
\> \hspace{4mm} For generalized symmetries one usually sets all $\xi^i=0$.\\
\> Then the $\eta^{\alpha}$ are equal to the characteristic functions.
\end{tabbing}
\noindent The third parameter {\it flist} of {\tt LIEPDE} is a list $\{\;\}$ 
that includes
\begin{itemize}
\item all parameters and functions in the equations which are to
      be determined such that symmetries exist (if any such 
      parameters/functions are 
      specified in {\it flist} then the symmetry conditions 
      formulated in {\tt LIEPDE}
      become non-linear conditions which may be much harder for
      {\tt CRACK} to solve with many cases and subcases to be considered.)
\item all unknown functions and constants in the ansatz 
      \verb+xi!_..+ and \verb+eta!_..+
      if that has been specified in {\it symtype}.
\end{itemize}
\noindent The fourth parameter {\it inequ} of {\tt LIEPDE} is a list $\{\;\}$ 
that includes all non-vanishing expressions which represent
inequalities for the functions in flist.

The result of {\tt LIEPDE} is a list with 3 elements, each of which
is a list:
\[ \{\{{\it con}_1,{\it con}_2,\ldots\},
     \{{\tt xi}\__{\ldots}=\ldots, \ldots,
       {\tt eta}\__{\ldots}=\ldots, \ldots\},
     \{{\it flist}\}\}. \]
The first list contains remaining unsolved symmetry conditions {\it con}$_i$. It
is the empty list \{\} if all conditions have been solved. The second list
gives the symmetry generators, i.e.\ expressions for $\xi_i$ and $\eta_j$. The 
last list contains all free constants and functions occuring in the first
and second list.

%That the automatic calculation of symmetries run in most practical cases
%is shown with the following example. It is insofar difficult, as many
%symmetries exist and the solution consequently more difficult is to deriv.
%
%---------------------------------------
%\subsection{Example}
%For the following PDE-system, which takes its simplest form in the
%formalism of exterior forms:
%
%\begin{eqnarray*}
%0 & = & 3k_t,_{tt}-2k_t,_{xx}-2k_t,_{yy}-2k_t,_{zz}-k_x,_{tx}-2k_zk_x,_y \\
%  &   & +2k_yk_x,_z-k_y,_{ty}+2k_zk_y,_x-2k_xk_y,_z-k_z,_{tz}-2k_yk_z,_x+2k_xk_z,_y \\
%0 & = & k_t,_{tx}-2k_zk_t,_y+2k_yk_t,_z+2k_x,_{tt}-3k_x,_{xx}-2k_x,_{yy} \\
%  &   & -2k_x,_{zz}+2k_zk_y,_t-k_y,_{xy}-2k_tk_y,_z-2k_yk_z,_t-k_z,_{xz}+2k_tk_z,_y \\
%0 & = & k_t,_{ty}+2k_zk_t,_x-2k_xk_t,_z-2k_zk_x,_t-k_x,_{xy}+2k_tk_x,_z \\
%  &   & +2k_y,_{tt}-2k_y,_{xx}-3k_y,_{yy}-2k_y,_{zz}+2k_xk_z,_t-2k_tk_z,_x-k_z,_{yz} \\
%0 & = & k_t,_{tz}-2k_yk_t,_x+2k_xk_t,_y+2k_yk_x,_t-k_x,_{xz}-2k_tk_x,_y \\
%  &   & -2k_xk_y,_t+2k_tk_y,_x-k_y,_{yz}+2k_z,_{tt}-2k_z,_{xx}-2k_z,_{yy}-3k_z,_{zz}
%\end{eqnarray*}
%---------------------------------------
\subsection{The third step: Application of infinitesimal symmetries}
If infinitesimal symmetries have been found then
the program {\tt APPLYSYM} can use them for the following purposes:
\begin{enumerate}
\item Calculation of one symmetry variable and further similarity variables.
After transforming
the DE(-system) to these variables, the symmetry variable will not occur
explicitly any more. For ODEs this has the consequence that their order has
effectively been reduced.
\item Generalization of a special solution by one or more constants of
integration.
\end{enumerate}
Both methods are described in the following section.
%-------------------------------------------------------------------------
\section{Applying symmetries with {\tt APPLYSYM}}
%---------------------------------------
\subsection{The first mode: Calculation of similarity and symmetry variables}
In the following we assume that a symmetry generator $X$, given
in (\ref{sbed2}), is known such that ODE(s)/PDE(s) $H_A=0$
satisfy the symmetry condition (\ref{sbed1}). The aim is to
find new dependent functions $u^\alpha = u^\alpha(x^j,y^\beta)$ and
new independent variables $v^i = v^i(x^j,y^\beta),\;\;
1\leq\alpha,\beta\leq p,\;1\leq i,j \leq q$
such that the symmetry generator
$X = \xi^i(x^j,y^\beta)\partial_{x^i} +
     \eta^\alpha(x^j,y^\beta)\partial_{y^\alpha}$
transforms to
\begin{equation}
X = \partial_{v^1}.    \label{sbed3}
\end{equation}

Inverting the above transformation to $x^i=x^i(v^j,u^\beta),
y^\alpha=y^\alpha(v^j,u^\beta)$ and setting \\
$H_A(x^i(v^j,u^\beta), y^\alpha(v^j,u^\beta),\ldots) =
h_A(v^j, u^\beta,\ldots)$
this means that
\begin{eqnarray*}
 0 & = & X H_A(x^i,y^\alpha,y^\beta_j,\ldots)\;\;\; \mbox{mod} \;\;\; H_A=0 \\
   & = & X h_A(v^i,u^\alpha,u^\beta_j,\ldots)\;\;\; \mbox{mod} \;\;\; h_A=0 \\
   & = & \partial_{v^1}h_A(v^i,u^\alpha,u^\beta_j,\ldots)\;\;\; \mbox{mod}
         \;\;\; h_A=0.
\end{eqnarray*}
Consequently, the variable $v^1$ does not occur explicitly in $h_A$.
In the case of an ODE(-system) $(v^1=v)$
the new equations $0=h_A(v,u^\alpha,du^\beta/dv,\ldots)$
are then of lower total order
after the transformation $z = z(u^1) = du^1/dv$ with now $z, u^2,\ldots u^p$
as unknown functions and $u^1$ as independent variable.

The new form (\ref{sbed3}) of $X$ leads directly to conditions for the
symmetry variable $v^1$ and the similarity variables
$v^i|_{i\neq 1}, u^\alpha$ (all functions of $x^k,y^\gamma$):
\begin{eqnarray}
 X v^1 = 1 & = & \xi^i(x^k,y^\gamma)\partial_{x^i}v^1 +
                \eta^\alpha(x^k,y^\gamma)\partial_{y^\alpha}v^1 \label{ql1} \\
 X v^j|_{j\neq 1} = X u^\beta = 0 & = &
                 \xi^i(x^k,y^\gamma)\partial_{x^i}u^\beta +
                 \eta^\alpha(x^k,y^\gamma)\partial_{y^\alpha}u^\beta \label{ql2}
\end{eqnarray}
The general solutions of (\ref{ql1}), (\ref{ql2}) involve free functions
of $p+q-1$ arguments. From the general solution of equation (\ref{ql2}),
$p+q-1$ functionally independent special solutions have to be selected
($v^2,\ldots,v^p$ and $u^1,\ldots,u^q$), 
whereas from (\ref{ql1}) only one solution $v^1$ is needed.
Together, the expressions for the symmetry and similarity variables must
define a non-singular transformation $x,y \rightarrow u,v$.

Different special solutions selected at this stage
will result in different
resulting DEs which are equivalent under point transformations but may
look quite differently. A transformation that is more difficult than another
one will in general
only complicate the new DE(s) compared with the simpler transformation.
We therefore seek the simplest possible special
solutions of (\ref{ql1}), (\ref{ql2}). They also
have to be simple because the transformation has to be inverted to solve for
the old variables in order to do the transformations.

The following steps are performed in the corresponding mode of the
program {\tt APPLYSYM}:
\begin{itemize}
\item The user is asked to specify a symmetry by selecting one symmetry
from all the known symmetries or by specifying a linear combination of them.
\item Through a call of the procedure {\tt QUASILINPDE} (described in a later
section) the two linear first order PDEs (\ref{ql1}), (\ref{ql2}) are
investigated and, if possible, solved.
\item From the general solution of (\ref{ql1}) 1 special solution
is selected and from (\ref{ql2}) $p+q-1$ special
solutions are selected which should be as simple as possible.
\item The user is asked whether the symmetry variable should be one of the
independent variables (as it has been assumed so far) or one of the new
functions (then only derivatives of this function and not the function itself
turn up in the new DE(s)).
\item Through a call of the procedure {\tt DETRAFO} the transformation
$x^i,y^\alpha \rightarrow v^j,u^\beta$ of the DE(s) $H_A=0$ is finally done.
\item The program returns to the starting menu.
\end{itemize}
%---------------------------------------
\subsection{The second mode: Generalization of special solutions}
A second application of infinitesimal symmetries is the generalization
of a known special solution given in implicit form through
$0 = F(x^i,y^\alpha)$. If one knows a symmetry variable $v^1$ and
similarity variables $v^r, u^\alpha,\;\;2\leq r\leq p$ then
$v^1$ can be shifted by a constant $c$ because of
$\partial_{v^1}H_A = 0$ and
therefore the DEs $0 = H_A(v^r,u^\alpha,u^\beta_j,\ldots)$
are unaffected by the shift. Hence from
\[0 = F(x^i, y^\alpha) = F(x^i(v^j,u^\beta), y^\alpha(v^j,u^\beta)) =
\bar{F}(v^j,u^\beta)\] follows that
\[ 0 = \bar{F}(v^1+c,v^r,u^\beta) =
\bar{F}(v^1(x^i,y^\alpha)+c, v^r(x^i,y^\alpha), u^\beta(x^i,y^\alpha))\]
defines implicitly a generalized solution $y^\alpha=y^\alpha(x^i,c)$.

This generalization works only if $\partial_{v^1}\bar{F} \neq 0$ and
if $\bar{F}$ does not already have
a constant additive to $v^1$.

The method above needs to know $x^i=x^i(u^\beta,v^j),\;
y^\alpha=y^\alpha(u^\beta,v^j)$ \underline{and}
$u^\alpha = u^\alpha(x^j,y^\beta), v^\alpha = v^\alpha(x^j,y^\beta)$
which may be practically impossible.
Better is, to integrate $x^i,y^\alpha$ along $X$:
\begin{equation}
\frac{d\bar{x}^i}{d\varepsilon} = \xi^i(\bar{x}^j(\varepsilon),
                                  \bar{y}^\beta(\varepsilon)), \;\;\;\;\;
\frac{d\bar{y}^\alpha}{d\varepsilon} = \eta^\alpha(\bar{x}^j(\varepsilon),
                                       \bar{y}^\beta(\varepsilon))
\label{ODEsys}
\end{equation}
with initial values $\bar{x}^i = x^i, \bar{y}^\alpha = y^\alpha$
for $\varepsilon = 0.$
(This ODE-system is the characteristic system of (\ref{ql2}).)

Knowing only the finite transformations
\begin{equation}
\bar{x}^i = \bar{x}^i(x^j,y^\beta,\varepsilon),\;\;
\bar{y}^\alpha = \bar{y}^\alpha(x^j,y^\beta,\varepsilon)  \label{ODEsol}
\end{equation}
gives immediately the inverse transformation
$\bar{x}^i = \bar{x}^i(x^j,y^\beta,\varepsilon),\;\;
\bar{y}^\alpha = \bar{y}^\alpha(x^j,y^\beta,\varepsilon)$
just by $\varepsilon \rightarrow -\varepsilon$ and renaming
$x^i,y^\alpha \leftrightarrow \bar{x}^i,\bar{y}^\alpha.$

The special solution $0 = F(x^i,y^\alpha)$
is generalized by the new constant
$\varepsilon$ through
\[ 0 = F(x^i,y^\alpha) = F(x^i(\bar{x}^j,\bar{y}^\beta,\varepsilon),
                  y^\alpha(\bar{x}^j,\bar{y}^\beta,\varepsilon)) \]
after dropping the $\bar{~}$.

The steps performed in the corresponding mode of the
program {\tt APPLYSYM} show features of both techniques:
\begin{itemize}
\item The user is asked to specify a symmetry by selecting one symmetry
from all the known symmetries or by specifying a linear combination of them.
\item The special solution to be generalized and the name of the new
constant have to be put in.
\item Through a call of the procedure {\tt QUASILINPDE}, the PDE (\ref{ql1})
is solved which amounts to a solution of its characteristic ODE system
(\ref{ODEsys}) where $v^1=\varepsilon$.
\item {\tt QUASILINPDE} returns a list of constant expressions
\begin{equation}
c_i = c_i(x^k, y^\beta, \varepsilon),\;\;1\leq i\leq p+q
\end{equation}
which are solved for
$x^j=x^j(c_i,\varepsilon),\;\; y^\alpha=y^\alpha(c_i,\varepsilon)$
to obtain the generalized solution through
\[ 0 = F(x^j, y^\alpha)
     = F(     x^j(c_i(x^k, y^\beta, 0), \varepsilon),
         y^\alpha(c_i(x^k, y^\beta, 0), \varepsilon)). \]
\item The new solution is availabe for further generalizations w.r.t.\ other
symmetries.
\end{itemize}
If one would like to generalize a given special solution with $m$ new
constants because $m$ symmetries are known, then one could run the whole
program $m$ times, each time with a different symmetry or one could run the
program once with a linear combination of $m$ symmetry generators which
again is a symmetry generator. Running the program once adds one constant
but we have in addition $m-1$ arbitrary constants in the linear combination
of the symmetries, so $m$ new constants are added.
Usually one will generalize the solution gradually to make solving
(\ref{ODEsys}) gradually more difficult.
%---------------------------------------
\subsection{Syntax}
The call of {\tt APPLYSYM} is
{\tt APPLYSYM}(\{{\it de}, {\it fun}, {\it var}\}, \{{\it sym}, {\it cons}\});
\begin{itemize}
\item {\it de} is a single DE or a list of DEs in the form of a vanishing
      expression or in the form $\ldots=\ldots\;\;$.
\item {\it fun} is the single function or the list of functions occuring
      in {\it de}.
\item {\it var} is the single variable or the list of variables in {\it de}.
\item {\it sym} is a linear combination of all symmetries, each with a
      different constant coefficient, in form of a list of the $\xi^i$ and
      $\eta^\alpha$: \{xi\_\ldots=\ldots,\ldots,eta\_\ldots=\ldots,\ldots\},
      where the indices after `xi\_' are the variable names and after `eta\_'
      the function names.
\item {\it cons} is the list of constants in {\it sym}, one constant for each
      symmetry.
\end{itemize}
The list that is the first argument of {\tt APPLYSYM} is the same as the
first argument of {\tt LIEPDE} and the
second argument is the list that {\tt LIEPDE} returns without its first
element (the unsolved conditions). An example is given below.

What {\tt APPLYSYM} returns depends on the last performed modus.
After modus 1 the return is \\
\{\{{\it newde}, {\it newfun}, {\it newvar}\}, {\it trafo}\} \\
where
\begin{itemize}
\item {\it newde} lists the transformed equation(s)
\item {\it newfun} lists the new function name(s)
\item {\it newvar} lists the new variable name(s)
\item {\it trafo} lists the transformations $x^i=x^i(v^j,u^\beta),
      y^\alpha=y^\alpha(v^j,u^\beta)$
\end{itemize}
After modus 2, {\tt APPLYSYM} returns the generalized special solution.
%---------------------------------------
\subsection{Example: A second order ODE}
Weyl's class of solutions of Einsteins field equations consists of
axialsymmetric time independent metrics of the form
\begin{equation}
{\rm{d}} s^2 = e^{-2 U} \left[ e^{2 k}  \left( \rm{d} \rho^2 + \rm{d}
z^2 \right)+\rho^2 \rm{d} \varphi^2 \right] - e^{2 U} \rm{d} t^2,
\end{equation}
where $U$ and $k$ are functions of $\rho$ and $z$. If one is interested in
generalizing these solutions to have a time dependence then the resulting
DEs can be transformed such that one longer third order ODE for $U$ results
which contains only $\rho$ derivatives \cite{Markus}. Because $U$ appears
not alone but only as derivative, a substitution
\begin{equation}
g = dU/d\rho      \label{g1dgl}
\end{equation}
lowers the order and the introduction of a function
\begin{equation}
h = \rho g - 1    \label{g2dgl}
\end{equation}
simplifies the ODE to
\begin{equation}
0 = 3\rho^2h\,h''
-5\rho^2\,h'^2+5\rho\,h\,h'-20\rho\,h^3h'-20\,h^4+16\,h^6+4\,h^2. \label{hdgl}
\end{equation}
where $'= d/d\rho$.
Calling {\tt LIEPDE} through
\small \begin{verbatim}
depend h,r;
prob:={{-20*h**4+16*h**6+3*r**2*h*df(h,r,2)+5*r*h*df(h,r)
        -20*h**3*r*df(h,r)+4*h**2-5*r**2*df(h,r)**2},
       {h}, {r}};
sym:=liepde(prob, {"point"},{},{});
end; \end{verbatim} \normalsize
gives \small \begin{verbatim}
                          3                       2
sym := {{}, {xi_r= - c10*r  - c11*r, eta_h=c10*h*r }, {c10,c11}}.
\end{verbatim} \normalsize
All conditions have been solved because the first element of {\tt sym}
is $\{\}$. The two existing symmetries are therefore
\begin{equation}
  - \rho^3 \partial_{\rho} +  h \rho^2 \,\partial_{h} \;\;\;\;\;\;\mbox{and}
  \;\;\;\;\;\;\rho \partial_{\rho}.
\end{equation}
Corresponding finite
transformations can be calculated with {\tt APPLYSYM} through
\small \begin{verbatim}
newde:=applysym(prob,rest sym);
\end{verbatim} \normalsize
The interactive session is given below with the user input following
the prompt `{\tt Input:3:}' or following `?'. (Empty lines have been deleted.)
\small \begin{verbatim}
Do you want to find similarity and symmetry variables (enter `1;')
or generalize a special solution with new parameters  (enter `2;')
or exit the program                                   (enter  `;')
Input:3: 1;
\end{verbatim} \normalsize
We enter `1;' because we want to reduce dependencies by finding similarity
variables and one symmetry variable and then doing the transformation such
that the symmetry variable does not explicitly occur in the DE.
\small \begin{verbatim}
----------------------   The 1.  symmetry is:
         3
xi_r= - r
         2
eta_h=h*r
----------------------   The 2.  symmetry is:
xi_r= - r
----------------------
Which single symmetry or linear combination of symmetries
do you want to apply? 
Enter an expression with `sy_(i)' for the i'th symmetry.
sy_(1);
\end{verbatim} \normalsize
We could have entered `sy\_(2);' or a combination of both
as well with the calculation running then
differently.
\small \begin{verbatim}
The symmetry to be applied in the following is
          3          2
{xi_r= - r ,eta_h=h*r }
Enter the name of the new dependent variables:
Input:3: u;
Enter the name of the new independent variables:
Input:3: v;
\end{verbatim} \normalsize
This was the input part, now the real calculation starts.
\small \begin{verbatim}
The ODE/PDE (-system) under investigation is :
                   2            2  2               3
0 = 3*df(h,r,2)*h*r  - 5*df(h,r) *r  - 20*df(h,r)*h *r
                           6       4      2
     + 5*df(h,r)*h*r + 16*h  - 20*h  + 4*h
for the function(s) : h.
It will be looked for a new dependent variable u
and an independent variable v such that the transformed
de(-system) does not depend on u or v.
1. Determination of the similarity variable
                           2
The quasilinear PDE:  0 = r *(df(u_,h)*h - df(u_,r)*r).
The equivalent characteristic system:
               3
0= - df(u_,r)*r
      2
0= - r *(df(h,r)*r + h)
for the functions: h(r)  u_(r).
\end{verbatim} \normalsize
The PDE is equation (\ref{ql2}).
\small \begin{verbatim}
The general solution of the PDE is given through
0 = ff(u_,h*r)
with arbitrary function ff(..).
A suggestion for this function ff provides:
0 =  - h*r + u_
Do you like this choice? (Y or N)
?y
\end{verbatim} \normalsize
For the following calculation only a single special solution of the PDE is
necessary
and this has to be specified from the general solution by choosing a special
function {\tt ff}. (This function is called {\tt ff} to prevent a clash with
names of user variables/functions.) In principle any choice of {\tt ff} would
work, if it defines a non-singular coordinate transformation, i.e.\ here $r$
must be a function of $u\_$. If we have $q$ independent variables and
$p$ functions of them then {\tt ff} has $p+q$ arguments. Because of the
condition $0 = ${\tt ff} one has essentially the freedom of choosing a function
of $p+q-1$ arguments freely. This freedom is also necessary to select $p+q-1$
different functions {\tt ff} and to find as many functionally independent
solutions $u\_$ which all become the new similarity variables. $q$ of them
become the new functions $u^\alpha$ and $p-1$ of them the new variables
$v^2,\ldots,v^p$. Here we have $p=q=1$ (one single ODE).

Though the program could have done that alone, once the general solution
{\tt ff(..)} is known, the user can interfere here to enter a simpler solution,
if possible.
\small \begin{verbatim}
2. Determination of the symmetry variable
                                      2             3
The quasilinear PDE:  0 = df(u_,h)*h*r  - df(u_,r)*r  - 1.
The equivalent characteristic system:
              3
0=df(r,u_) + r
                2
0=df(h,u_) - h*r
for the functions: r(u_)  h(u_)  .
New attempt with a different independent variable
The equivalent characteristic system:
              2
0=df(u_,h)*h*r  - 1
   2
0=r *(df(r,h)*h + r)
for the functions: r(h)  u_(h)  .
The general solution of the PDE is given through
                  2  2       2
             - 2*h *r *u_ + h
0 = ff(h*r,--------------------)
                    2
with arbitrary function ff(..).
A suggestion for this function ff(..) yields:
      2        2
     h *( - 2*r *u_ + 1)
0 = ---------------------
              2
Do you like this choice? (Y or N)
?y
\end{verbatim} \normalsize
Similar to above.
\small \begin{verbatim}
The suggested solution of the algebraic system which will
do the transformation is:
                        sqrt(v)*sqrt(2)
{h=sqrt(v)*sqrt(2)*u,r=-----------------}
                              2*v
Is the solution ok? (Y or N)
?y
In the intended transformation shown above the dependent
variable is u and the independent variable is v.
The symmetry variable is v, i.e. the transformed expression
will be free of v.
Is this selection of dependent and independent variables ok? (Y or N)
?n
\end{verbatim} \normalsize
We so far assumed that the symmetry variable is one of the new variables, but,
of course we also could choose it to be one of the new functions.
If it is one of the functions then only derivatives of this function occur
in the new DE, not the function itself. If it is one of the variables then 
this variable will not occur explicitly.

In our case we prefer (without strong reason) to have the function as
symmetry variable. We therefore answered with `no'. As a consequence, $u$ and
$v$ will exchange names such that still all new functions have the name $u$
and the new variables have name $v$:
\small \begin{verbatim}
Please enter a list of substitutions. For example, to
make the variable, which is so far call u1, to an
independent variable v2 and the variable, which is
so far called v2, to an dependent variable u1,
enter: `{u1=v2, v2=u1};'
Input:3: {u=v,v=u};

The transformed equation which should be free of u:
                            3  6             2  3
0=3*df(u,v,2)*v - 16*df(u,v) *v  - 20*df(u,v) *v  + 5*df(u,v)
Do you want to find similarity and symmetry variables (enter `1;')
or generalize a special solution with new parameters  (enter `2;')
or exit the program                                   (enter  `;')
Input:3: ;
\end{verbatim}
We stop here. The following is returned from our {\tt APPLYSYM} call:
\small \begin{verbatim}
                             3  6             2  3
{{{3*df(u,v,2)*v - 16*df(u,v) *v  - 20*df(u,v) *v + 5*df(u,v)},
  {u},
  {v}},
     sqrt(u)*sqrt(2)
 {r=-----------------, h=sqrt(u)*sqrt(2)*v }}
           2*u
\end{verbatim} \normalsize
The use of {\tt APPLYSYM} effectively provided us the finite
transformation
\begin{equation}
  \rho=(2\,u)^{-1/2},\;\;\;\;\;h=(2\,u)^{1/2}\,v \label{trafo1}.
\end{equation}
and the new ODE
\begin{equation}
0 = 3u''v - 16u'^3v^6 - 20u'^2v^3 + 5u'        \label{udgl}
\end{equation}
where $u=u(v)$ and $'=d/dv.$
Using one symmetry we reduced the 2.\,order ODE (\ref{hdgl})
to a first order ODE (\ref{udgl}) for $u'$ plus one
integration. The second symmetry can be used to reduce the remaining ODE
to an integration too by introducing a variable $w$ through $v^3d/dv = d/dw$,
i.e. $w = -1/(2v^2)$. With
\begin{equation}
p=du/dw                                       \label{udot}
\end{equation}
the remaining ODE is
\[0 = 3\,w\,\frac{dp}{dw} + 2\,p\,(p+1)(4\,p+1)   \]
with solution
\[ \tilde{c}w^{-2}/4 = \tilde{c}v^4 = \frac{p^3(p+1)}{(4\,p+1)^4},\;\;\;
 \tilde{c}=const. \]
Writing (\ref{udot}) as $p = v^3(du/dp)/(dv/dp)$ we get $u$ by integration
and with (\ref{trafo1}) further a parametric solution for $\rho,h$:
\begin{eqnarray}
\rho & = & \left(\frac{3c_1^2(2p-1)}{p^{1/2}(p+1)^{1/2}}+c_2\right)^{-1/2} \\
h & = & \frac{(c_2p^{1/2}(p+1)^{1/2}+6c_1^2p-3c_1^2)^{1/2}p^{1/2}}{c_1(4p+1)}
\end{eqnarray}
where $c_1, c_2 = const.$ and $c_1=\tilde{c}^{1/4}.$ Finally, the metric
function $U(p)$ is obtained as an integral from (\ref{g1dgl}),(\ref{g2dgl}).
%---------------------------------------
\subsection{Limitations of {\tt APPLYSYM}}
Restrictions of the applicability of the program {\tt APPLYSYM} result
from limitations of the program {\tt QUASILINPDE} described in a section below.
Essentially this means that symmetry generators may only be polynomially
non-linear in $x^i, y^\alpha$.
Though even then the solvability can not be guaranteed, the
generators of Lie-symmetries are mostly very simple such that the
resulting PDE (\ref{PDE}) and the corresponding characteristic 
ODE-system have good chances to be solvable.

Apart from these limitations implied through the solution of differential
equations with {\tt CRACK} and algebraic equations with {\tt SOLVE}
the program {\tt APPLYSYM} itself is free of restrictions,
i.e.\ if once new versions of {\tt CRACK, SOLVE}
would be available then {\tt APPLYSYM} would not have to be changed.

Currently, whenever a computational step could not be performed
the user is informed and has the possibility of entering interactively
the solution of the unsolved algebraic system or the unsolved linear PDE.
%-------------------------------------------------------------------------
\section{Solving quasilinear PDEs}
%---------------------------------------
\subsection{The content of {\tt QUASILINPDE}}
The generalization of special solutions of DEs as well as the computation of
similarity and symmetry variables involve the general solution of single
first order linear PDEs.
The procedure {\tt QUASILINPDE} is a general procedure
aiming at the general solution of
PDEs
\begin{equation}
   a_1(w_i,\phi)\phi_{w_1} + a_2(w_i,\phi)\phi_{w_2} + \ldots +
   a_n(w_i,\phi)\phi_{w_n} = b(w_i,\phi) \label{PDE}
\end{equation}
in $n$ independent variables $w_i, i=1\ldots n$ for one unknown function
$\phi=\phi(w_i)$.
\begin{enumerate}
\item
The first step in solving a quasilinear PDE (\ref{PDE})
is the formulation of the corresponding characteristic ODE-system
\begin{eqnarray}
\frac{dw_i}{d\varepsilon} & = & a_i(w_j,\phi) \label{char1}   \\
\frac{d\phi}{d\varepsilon} & = & b(w_j,\phi)  \label{char2}
\end{eqnarray}
for $\phi, w_i$ regarded now as functions of one variable $\varepsilon$.

Because the $a_i$ and $b$ do not depend explicitly on $\varepsilon$, one of the
equations (\ref{char1}),(\ref{char2}) with non-vanishing right hand side
can be used to divide all others through it and by that having a system
with one less ODE to solve. 
If the equation to divide through is one of
(\ref{char1}) then the remaining system would be
\begin{eqnarray}
\frac{dw_i}{dw_k} & = & \frac{a_i}{a_k} , \;\;\;i=1,2,\ldots k-1,k+1,\ldots n
  \label{char3} \\
\frac{d\phi}{dw_k} & = & \frac{b}{a_k}  \label{char4}
\end{eqnarray}
with the independent variable $w_k$ instead of $\varepsilon$.
If instead we divide through equation
(\ref{char2}) then the remaining system would be
\begin{eqnarray}
\frac{dw_i}{d\phi} & = & \frac{a_i}{b} , \;\;\;i=1,2,\ldots n
  \label{char3a}
\end{eqnarray}
with the independent variable $\phi$ instead of $\varepsilon$.

The equation to divide through is chosen by a
subroutine with a heuristic to find the ``simplest'' non-zero
right hand side ($a_k$ or $b$), i.e.\ one which
\begin{itemize}
\item is constant or
\item depends only on one variable or
\item is a product of factors, each of which depends only on
one variable.
\end{itemize}

One purpose of this division is to reduce the number of ODEs by one.
Secondly, the general solution of (\ref{char1}), (\ref{char2}) involves
an additive constant to $\varepsilon$ which is not relevant and would
have to be set to zero. By dividing through one ODE we eliminate
$\varepsilon$ and lose the problem of identifying this constant in the
general solution before we would have to set it to zero.

\item % from enumerate
To solve the system (\ref{char3}), (\ref{char4}) or (\ref{char3a}),
the procedure {\tt CRACK} is called.
Although being designed primarily for the solution of overdetermined
PDE-systems, {\tt CRACK} can also be used to solve simple not
overdetermined ODE-systems. This solution
process is not completely algorithmic. Improved versions of {\tt CRACK}
could be used, without making any changes of {\tt QUASILINPDE} 
necessary.

If the characteristic ODE-system can not be solved in the form
(\ref{char3}), (\ref{char4}) or (\ref{char3a})
then successively all other ODEs of (\ref{char1}), (\ref{char2})
with non-vanishing right hand side are used for division until 
one is found
such that the resulting ODE-system can be solved completely.
Otherwise the PDE can not be solved by {\tt QUASILINPDE}.

\item % from enumerate
If the characteristic ODE-system (\ref{char1}), (\ref{char2}) has been
integrated completely and in full generality to the implicit solution
\begin{equation}
0 = G_i(\phi, w_j, c_k, \varepsilon),\;\;
i,k=1,\ldots,n+1,\;\;j=1,\ldots,n              \label{charsol1}
\end{equation}
then according to the general theory for solving first order PDEs,
$\varepsilon$ has
to be eliminated from one of the equations and to be substituted in the
others to have left $n$ equations.
Also the constant that turns up additively to $\varepsilon$
is to be set to zero. Both tasks are automatically
fulfilled, if, as described above, $\varepsilon$ is already eliminated
from the beginning by dividing all equations of (\ref{char1}),
(\ref{char2})
through one of them.

On either way one ends up with $n$ equations 
\begin{equation}
0=g_i(\phi,w_j,c_k),\;\;i,j,k=1\ldots n             \label{charsol2}
\end{equation}
involving $n$ constants $c_k$.

The final step is to solve (\ref{charsol2}) for the $c_i$ to obtain
\begin{equation}
c_i = c_i(\phi, w_1,\ldots ,w_n) \;\;\;\;\;i=1,\ldots n  . \label{cons}
\end{equation}
The final solution $\phi = \phi(w_i)$ of the PDE (\ref{PDE}) is then
given implicitly through
\[ 0 = F(c_1(\phi,w_i),c_2(\phi,w_i),\ldots,c_n(\phi,w_i)) \]
where $F$ is an arbitrary function with $n$ arguments.
\end{enumerate}
%---------------------------------------
\subsection{Syntax}
The call of {\tt QUASILINPDE} is \\
{\tt QUASILINPDE}({\it de}, {\it fun}, {\it varlist});
\begin{itemize}
\item
{\it de} is the differential expression which vanishes due to the PDE
{\it de}$\; = 0$ or, {\it de} may be the differential equation itself in the
form $\;\;\ldots = \ldots\;\;$.
\item
{\it fun} is the unknown function.
\item
{\it varlist} is the list of variables of {\it fun}.
\end{itemize}
The result of {\tt QUASILINPDE} is a list of general solutions
\[      \{{\it sol}_1, {\it sol}_2, \ldots \}.  \]
If {\tt QUASILINPDE} can not solve the PDE then it returns $\{\}$.
Each solution ${\it sol}_i$ is a list of expressions
\[      \{{\it ex}_1, {\it ex}_2, \ldots \}  \]
such that the dependent function ($\phi$ in (\ref{PDE})) is determined
implicitly through an arbitrary function $F$ and the algebraic
equation \[ 0 = F({\it ex}_1, {\it ex}_2, \ldots). \]
%---------------------------------------
\subsection{Examples}
{\em Example 1:}\\
To solve the quasilinear first order PDE \[1 = xu,_x + uu,_y - zu,_z\]
for the function $u = u(x,y,z),$ the input would be
\small \begin{verbatim}
depend u,x,y,z;
de:=x*df(u,x)+u*df(u,y)-z*df(u,z) - 1;
varlist:={x,y,z};
QUASILINPDE(de,u,varlist);
\end{verbatim} \normalsize
In this example the procedure returns
\[\{ \{ x/e^u, ze^u, u^2 - 2y \} \},\] 
i.e. there is one general solution (because the outer list has only one
element which itself is a list) and $u$ is given implicitly through 
the algebraic equation
\[ 0 = F(x/e^u, ze^u, u^2 - 2y)\] 
with arbitrary function $F.$ \\
{\em Example 2:}\\
For the linear inhomogeneous PDE
\[ 0 = y z,_x + x z,_y - 1, \;\;\;\;\mbox{for}\;\;\;\;z=z(x,y)\]
{\tt QUASILINPDE} returns the result that for an arbitrary function $F,$ the
equation
\[ 0 = F\left(\frac{x+y}{e^z},e^z(x-y)\right) \]
defines the general solution for $z$. \\
{\em Example 3:}\\
For the linear inhomogeneous PDE (3.8) from \cite{KamkePDE}
\[ 0 = x w,_x + (y+z)(w,_y - w,_z), \;\;\;\;\mbox{for}\;\;\;\;w=w(x,y,z)\]
{\tt QUASILINPDE} returns the result 
that for an arbitrary function $F,$ the equation
\[ 0 = F\left(w, \;y+z, \;\ln(x)(y+z)-y\right) \]
defines the general solution for $w$, i.e.\ for any function $f$
\[ w = f\left(y+z, \;\ln(x)(y+z)-y\right) \]
solves the PDE.
%---------------------------------------
\subsection{Limitations of {\tt QUASILINPDE}}
One restriction on the applicability of {\tt QUASILINPDE} results from
the program {\tt CRACK} which tries to solve the
characteristic ODE-system of the PDE. So far {\tt CRACK} can be
applied only to polynomially non-linear DE's, i.e.\ the characteristic 
ODE-system (\ref{char3}),(\ref{char4}) or (\ref{char3a}) may
only be polynomially non-linear, i.e.\ in the PDE (\ref{PDE})
the expressions $a_i$ and $b$ may only be rational in $w_j,\phi$.

The task of {\tt CRACK} is simplified as (\ref{charsol1}) does not have to
be solved for $w_j, \phi$. On the other hand (\ref{charsol1}) has to be
solved for the $c_i$. This gives a 
second restriction coming from the REDUCE function {\tt SOLVE}.
Though {\tt SOLVE} can be applied
to polynomial and transzendential equations, again no guarantee for
solvability can be given.
%-------------------------------------------------------------------------
\section{Transformation of DEs}
%---------------------------------------
\subsection{The content of {\tt DETRAFO}}
Finally, after having found the finite transformations,
the program {\tt APPLYSYM} calls the procedure
{\tt DETRAFO} to perform the transformations. {\tt DETRAFO}
can also be used alone to do point- or higher order transformations
which involve a considerable computational effort if the
differential order of the expression to be transformed is high and
if many dependent and independent variables are involved.
This might be especially useful if one wants to experiment
and try out different coordinate transformations interactively,
using {\tt DETRAFO} as standalone procedure.

To run {\tt DETRAFO}, the old functions $y^{\alpha}$ and old 
variables $x^i$ must be 
known explicitly in terms of algebraic or
differential expressions of the new functions $u^{\beta}$ 
and new variables $v^j$. Then for point transformations the identity
\begin{eqnarray}
dy^{\alpha} & = & \left(y^{\alpha},_{v^i} +
                  y^{\alpha},_{u^{\beta}}u^{\beta},_{v^i}\right) dv^i \\
            & = & y^{\alpha},_{x^j}dx^j  \\
            & = & y^{\alpha},_{x^j}\left(x^j,_{v^i} +
                  x^j,_{u^{\beta}}u^{\beta},_{v^i}\right) dv^i
\end{eqnarray}
provides the transformation
\begin{equation}
y^{\alpha},_{x^j} = \frac{dy^\alpha}{dv^i}\cdot
                    \left(\frac{dx^j}{dv^i}\right)^{-1}   \label{trafo}
\end{equation}
with {\it det}$\left(dx^j/dv^i\right) \neq 0$ because of the regularity
of the transformation which is checked by {\tt DETRAFO}. Non-regular
transformations are not performed.

{\tt DETRAFO} is not restricted to point transformations.
In the case of
contact- or higher order transformations, the total
derivatives $dy^{\alpha}/dv^i$ and $dx^j/dv^i$ then only include all
$v^i-$ derivatives of $u^{\beta}$ which occur in
\begin{eqnarray*}
y^{\alpha} & = & y^{\alpha}(v^i,u^{\beta},u^{\beta},_{v^j},\ldots) \\
x^k        & = & x^k(v^i,u^{\beta},u^{\beta},_{v^j},\ldots).
\end{eqnarray*}
%---------------------------------------
\subsection{Syntax}
The call of {\tt DETRAFO} is
\begin{tabbing}
{\tt DETRAFO}(\=\{{\it ex}$_1$, {\it ex}$_2$, \ldots , {\it ex}$_m$\}, \\
              \>\{{\it ofun}$_1=${\it fex}$_1$, {\it ofun}$_2=${\it fex}$_2$,
               \ldots ,{\it ofun}$_p=${\it fex}$_p$\},  \\
              \>\{{\it ovar}$_1=${\it vex}$_1$, {\it ovar}$_2=${\it vex}$_2$, \ldots ,
                  {\it ovar}$_q=${\it vex}$_q$\},  \\
              \>\{{\it nfun}$_1$, {\it nfun}$_2$, \ldots , {\it nfun}$_p$\},\\
              \>\{{\it nvar}$_1$, {\it nvar}$_2$, \ldots , {\it nvar}$_q$\});
\end{tabbing}     
where $m,p,q$ are arbitrary.
\begin{itemize}
\item
The {\it ex}$_i$ are differential expressions to be transformed.
\item
The second list is the list of old functions {\it ofun} expressed
as expressions {\it fex} in terms
of new functions {\it nfun} and new independent variables {\it nvar}.
\item
Similarly the third list expresses the old independent variables {\it ovar}
as expressions {\it vex} in terms of new functions
{\it nfun} and new independent variables {\it nvar}.
\item
The last two lists include the new functions {\it nfun}
and new independent variables {\it nvar}.
\end{itemize}
Names for {\it ofun, ovar, nfun} and {\it nvar} can be arbitrarily
chosen.

As the result {\tt DETRAFO} returns the first argument of its input,
i.e.\ the list
\[\{{\it ex}_1, {\it ex}_2, \ldots , {\it ex}_m\}\]
where all ${\it ex}_i$ are transformed.
%---------------------------------------
\subsection{Limitations of {\tt DETRAFO}}
The only requirement is that
the old independent variables $x^i$ and old functions $y^\alpha$ must be
given explicitly in terms of new variables $v^j$ and new functions $u^\beta$
as indicated in the syntax.
Then all calculations involve only differentiations and basic algebra.
%-------------------------------------------------------------------------
\section{Availability}
The programs run under {\tt REDUCE 3.6} and are available
by anonymous ftp from \\ {\tt ftp.maths.qmw.ac.uk}, directory 
{\tt pub/tw}.

\begin{thebibliography}{99}
\bibitem{WHer} W.\,Hereman, Chapter 13 in vol 3 of the CRC Handbook of
Lie Group Analysis of Differential Equations, Ed.: N.H.\,Ibragimov,
CRC Press, Boca Raton, Florida (1995).
Systems described in this paper are among others:  \\
DELiA (Alexei Bocharov et.al.) Pascal \\
DIFFGROB2 (Liz Mansfield) Maple \\
DIMSYM (James Sherring and Geoff Prince) REDUCE \\
HSYM (Vladimir Gerdt) Reduce \\
LIE (V. Eliseev, R.N. Fedorova and V.V. Kornyak) Reduce \\
LIE (Alan Head) muMath \\
Lie (Gerd Baumann) Mathematica \\
LIEDF/INFSYM (Peter Gragert and Paul Kersten) Reduce \\
Liesymm (John Carminati, John Devitt and Greg Fee) Maple \\
MathSym (Scott Herod) Mathematica \\
NUSY (Clara Nucci) Reduce \\
PDELIE (Peter Vafeades) Macsyma \\
SPDE (Fritz Schwarz) Reduce and Axiom \\
SYM\_DE (Stanly Steinberg) Macsyma \\
Symmgroup.c (Dominique Berube and Marc de Montigny) Mathematica \\
STANDARD FORM (Gregory Reid and Alan Wittkopf) Maple \\
SYMCAL (Gregory Reid) Macsyma and Maple \\
SYMMGRP.MAX (Benoit Champagne, Willy Hereman and Pavel Winternitz) Macsyma \\
LIE package (Khai Vu) Maple \\
Toolbox for symmetries (Mark Hickman) Maple \\
Lie symmetries (Jeffrey Ondich and Nick Coult) Mathematica.
\bibitem{lie1} S.\, Lie, Sophus Lie's 1880 Transformation Group Paper,
Translated by M.\, Ackerman, comments by R.\, Hermann, Mathematical Sciences 
Press, Brookline, (1975).
\bibitem{lie2} S.\,Lie, Differentialgleichungen, Chelsea Publishing Company,
New York, (1967).
\bibitem{LIEPDE} T.\,Wolf, An efficiency improved program {\tt LIEPDE}
for determining Lie - symmetries of PDEs, Proceedings of the workshop on
Modern group theory methods in Acireale (Sicily) Nov.\,(1992)
\bibitem{Riq} C.\,Riquier, Les syst\`{e}mes d'\'{e}quations 
aux d\'{e}riv\'{e}es partielles, Gauthier--Villars, Paris (1910).
\bibitem{Th} J.\,Thomas, Differential Systems, AMS, Colloquium
publications, v.\,21, N.Y.\,(1937).
\bibitem{Ja} M.\,Janet, Le\c{c}ons sur les syst\`{e}mes d'\'{e}quations aux
d\'{e}riv\'{e}es, Gauthier--Villars, Paris (1929).
\bibitem{Topu} V.L.\,Topunov, Reducing Systems of Linear Differential
Equations to a Passive Form, Acta Appl.\,Math.\,16 (1989) 191--206.
\bibitem{Alex} A.V.\,Bocharov and M.L.\,Bronstein, Efficiently
Implementing Two Methods of the Geometrical Theory of Differential
Equations: An Experience in Algorithm and Software Design, Acta.\,Appl.
Math.\,16 (1989) 143--166.
\bibitem{Olv} P.J. Olver, Applications of Lie Groups to Differential
Equations, Springer-Verlag New York (1986).
\bibitem{Reid1} G.J.\,Reid, A triangularization algorithm which
determines the Lie symmetry algebra of any system of PDEs, J.Phys.\,A:
Math.\,Gen.\,23 (1990) L853-L859.
\bibitem{FS} F.\,Schwarz, Automatically Determining Symmetries of Partial
Differential Equations, Computing 34, (1985) 91-106.
\bibitem{Fush} W.I.\,Fushchich and V.V.\,Kornyak, Computer Algebra
Application for Determining Lie and Lie--B\"{a}cklund Symmetries of
Differential Equations, J.\,Symb.\,Comp.\,7 (1989) 611--619.
\bibitem{Ka} E.\,Kamke, Differentialgleichungen, L\"{o}sungsmethoden
und L\"{o}sungen, Band 1, Gew\"{o}hnliche Differentialgleichungen,
Chelsea Publishing Company, New York, 1959.
\bibitem{KamkePDE} E.\,Kamke, Differentialgleichungen, L\"{o}sungsmethoden
und L\"{o}sungen, Band 2, Partielle Differentialgleichungen, 6.Aufl.,
Teubner, Stuttgart:Teubner, 1979.
\bibitem{Wo} T.\,Wolf, An Analytic Algorithm for Decoupling and Integrating
systems of Nonlinear Partial Differential Equations, J.\,Comp.\,Phys.,
no.\,3, 60 (1985) 437-446 and, Zur analytischen Untersuchung und exakten
L\"{o}sung von Differentialgleichungen mit Computeralgebrasystemen,
Dissertation B, Jena (1989).
\bibitem{WoBra} T.\,Wolf, A. Brand, The Computer Algebra Package {\tt CRACK}
      for Investigating PDEs, Manual for the package {\tt CRACK} in the REDUCE
      network library and in Proceedings of ERCIM School on Partial 
      Differential Equations and Group Theory, April 1992 in Bonn, GMD Bonn.
\bibitem{WM} M.A.H.\,MacCallum, F.J.\,Wright, Algebraic Computing with REDUCE,
Clarendon Press, Oxford (1991).
\bibitem{Mal} M.A.H.\, MacCallum, An Ordinary Differential Equation
Solver for REDUCE, Proc.\, ISAAC'88, Springer Lect.\, Notes in Comp Sci.
358, 196--205.
\bibitem{Step} H.\,Stephani, Differential equations, Their solution using
symmetries, Cambridge University Press (1989).
\bibitem{Karp} V.I.\,Karpman, Phys.\,Lett.\,A 136, 216 (1989)
\bibitem{Cham} B.\,Champagne, W.\,Hereman and P.\,Winternitz, The computer
      calculation of Lie point symmetries of large systems of differential
      equations, Comp.\,Phys.\,Comm.\,66, 319-340 (1991)
\bibitem{Markus} M.\,Kubitza, private communication

\end{thebibliography}

\end{document}


mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/crsimpso.red0000644000175000017500000005552011526203062024131 0ustar  giovannigiovanni%********************************************************************
module simpsolution$
%********************************************************************
%  Routines for simplifying expressions by changing free functions
%  and constants of integration
%  Author: Thomas Wolf
%  Nov 1993

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic operator dropredundant$

symbolic procedure dropredundant(ex,fl,vl,unequ)$
comment
 All arguments are algebraic, ex is the list of expressions or
 equations from which the right side is taken, fl is the list of
 functions to be sorted out, vl the list of all extra independent variables,
 not already included in fl.
 returns algebraic list of redundant functions/const.=0, new EX, new FL;
begin scalar a;
 vl:=union(reverse argset cdr fl,cdr vl)$
 if null ftem_ then ftem_:=cdr fl$
 a:=dropredund(list(list(nil),cdr ex,cdr fl,cdr unequ),nil,vl);
 return if a then list('LIST,cons('LIST,car    a),
                             cons('LIST,caddr  a),
                             cons('LIST,cadddr a) )
             else nil
end$

symbolic procedure del_redundant_fc(arglist)$
% prepares a call of dropredund() from within a crack run
begin
 scalar p,f,fli,nofl,fred,redu,dropped,oldpdes,newpdes,newpval,bak,prolibak$
 bak:=backup_pdes(car arglist,cadr arglist)$
 prolibak:=proc_list_;
 proc_list_:=default_proc_list_;
 if null ftem_ then ftem_:=cadr arglist$

 for each f in cadr arglist do
 if not pairp f then nofl:=cons(f,nofl) else
 if car f='EQUAL then fli:=cons(f,fli)$
 fred:=setdiff(ftem_,nofl);
 if not !*batch_mode then <<
  write"Which functions shall be checked for redundancy? "$
  f:=select_from_list(fred,nil)$
  if f then <>;
 >>$

 redu:=
 dropredund({for each p in car  arglist collect get(p,'val),
             fli,
             fred,
             ineq_},
            nofl,vl_);
 oldpdes:=car restore_pdes(bak)$
 proc_list_:=prolibak;
 if redu and car redu then <<
  for each f in car redu do <<
   dropped:=cons(cadr f,dropped)$
   % none of the dropped functions is in forg so all can be put in:
   drop_fct(cadr f)
  >>$
  ftem_:=setdiff(ftem_,dropped);
  newpval:=cadr redu$
  while newpval do <<
   newpdes:=if get(car oldpdes,'val) = car newpval
            then eqinsert(car oldpdes,newpdes) % cons(car oldpdes,newpdes)
            else <>        else eqinsert(p,newpdes) % cons(p,newpdes)
                 >>;
   newpval:=cdr newpval;
   oldpdes:=cdr oldpdes
  >>$

  % delete the dropped functions in the property list of the forg functions
  for each f in dropped do
  for each p in caddr redu do <<
   if (pairp p) and (car p='EQUAL) then
   put(cadr p,'fcts,delete(f,get(cadr p,'fcts)))
  >>$

  return {newpdes,append(caddr redu,setdiff(nofl,setdiff(nofl,cadr arglist)))}
  % appending only those nofl elements which have been in forg=cadr arglist
 >>
end$

symbolic procedure dropredund(a,nofl,vl)$
begin
 scalar sol,arbit,fl,el1,el2,el3,corres,b,b1,b2,condi,oldcon,
        redund,flstart,fldrop,flnew,newfu,fnew_,newcorres,unequ,
        vlf,vla,potold,newnewfu,todelete,nofl_arbit,ineq_bak,vl_bak,
        ftem_bak,proc_list_bak,session_old,adjust_fnc_bak,level_bak,
        collect_sol_bak$%,printold,batch_mode_old
 % a has the structure of one solution of CRACK in symbolic mode,
 % makes a copy of the free constants and functions in the solution
 % nofl is a list of functions not to be modified or dropped
 % sets to zero the difference between the old solution and the new
 % with replaced constants and functions and finds the non-essential
 % returns  cons(list of redundant fnc./cons=0,new solution)
 if cadr  a then if length cadr  a > 0 then
 if caddr a then if length caddr a > 0 then <<
  %printold:=print_;
  %print_:=nil;
  %batch_mode_old:=!*batch_mode;
  %!*batch_mode:=t;
  if not !*batch_mode then <<
   write"-------------------------------------------------------------"$
   terpri()$
   write" A new CRACK computation starts to find redundand functions. "$
   terpri()$
  >>$
  for each el1 in append(car a,cadr a) do
  if el1 then b1:=cons(if pairp el1 then
                       if car el1 = 'EQUAL then caddr el1
                                           else el1
                                    else el1             ,b1);
  % b1 is the list of expressions to be invariant
  b2:=b1;
  % arbit is the list of original free functions in the input solution
  arbit:=caddr a;

  % flstart is the list of functions which can be gauged and which
  %         turn up in the invariant expressions including the
  %         duplicates of these functions
  % fldrop  is the list of functions which can be dropped and do not
  %         turn up
  % todelete is a list of all new duplicate-functions
  % b2      is a duplicate of the list of invariant expressions b1
  % flnew   is a duplicate of todelete
  % fl      is the list of all functions
  % corres  is a list of correspondences of functions and their dupl.
  for each el1 in arbit do
  if not freeof(nofl,el1) then nofl_arbit:=cons(el1,nofl_arbit)
                          else
  if not my_freeof(b1,el1) then <<
   flstart:=cons(el1,flstart);
   el2:=newfct(fname_,fctargs(el1),nfct_)$
   todelete:=cons(el2,todelete);
   nfct_:=add1 nfct_$
   b2:=subst(el2,el1,b2);
   flnew:=cons(el2,flnew);
   fl:=cons(el1,cons(el2,fl));
   corres:=cons((el1 . el2),corres);
  >>                       else
  fldrop:=cons(el1,fldrop);

  % condi is the set of conditions: difference of related expressions=0
  while b1 do <<
   condi:=cons(reval list('PLUS,car b1,list('MINUS,car b2)),condi);
   b1:=cdr b1;
   b2:=cdr b2
  >>;
  b1:=nil;b2:=nil;
  fnew_:=nil;
  potold:=potint_;
  potint_:=nil;
  session_old:=session_;
  orderings_:=mkvect(1)$
  putv(orderings_,0,list(vl,fl,'default_ordering_function))$
  ineq_bak:=ineq_;    ineq_:=nil;  % temporarily
  vl_bak  :=vl_;      vl_  :=vl;
  ftem_bak:=ftem_;
  level_bak:=level_;  level_:=nil;
  for each b in flnew do ftem_:=fctinsert(b,ftem_)$
  if not freeof(proc_list_,'stop_batch) then <<
   proc_list_bak:=proc_list_;
   proc_list_:=delete('stop_batch,proc_list_)
  >>;
  adjust_fnc_bak:=adjust_fnc; adjust_fnc:=nil;
  collect_sol_bak:=collect_sol$collect_sol:=t$
  b:=crackmain(mkeqlist(condi,fl,vl_,allflags_,t,
                        orderings_prop_list_all(),nil),fl);
  collect_sol:=collect_sol_bak$
  adjust_fnc:=adjust_fnc_bak;  level_:=level_bak;
  ineq_:=ineq_bak;    vl_:=vl_bak;    ftem_:=ftem_bak$ % temporarily
  if proc_list_bak then proc_list_:=proc_list_bak;
  % a solution without inequalities
  %            without remaining equations
  % where each right hand side contains at least one fl-function
  for each b1 in b do
  if (not cadddr b1) and (not car b1) then <<
   el1:=t;
   for each el2 in cadr b1 do % for each computed assignment
   if (pairp el2) and
      (car el2='EQUAL) and
      (null smemberl(fl,caddr el2)) and
      (null smemberl(caddr b1,caddr el2)) then el1:=nil;
   if el1 then b2:=cons(b1,b2);
  >>$
  potint_:=potold;
  session_:=session_old;
  %print_:=printold;
  %!*batch_mode:=batch_mode_old;
  if not !*batch_mode then <<
   terpri()$
   write" The CRACK computation to find redundand functions finished."$terpri()$
   write"------------------------------------------------------------"$terpri()$
  >>$
  if null b2 then return <<
   for each el1 in append(todelete,fldrop) do
   drop_fct(el1)$ % depl!*:=delete(assoc(el1,depl!*),depl!*)$
   if null fldrop then nil
                  else <<

    redund:=for each el1 in fldrop collect list('EQUAL,el1,0);

    oldcon:=car a;
    for each el1 in fldrop do oldcon:=subst(0,el1,oldcon);
    oldcon:=for each el1 in oldcon collect reval el1;

    sol:=cadr a;
    for each el1 in fldrop do sol:=subst(0,el1,sol);
    sol:=for each el1 in sol collect reval el1;

    unequ:=cadddr a;
    for each el1 in fldrop do unequ:=subst(0,el1,unequ);
    unequ:=for each el1 in unequ collect reval el1;

    list(redund,oldcon,sol,union(nofl_arbit,flstart),unequ)
   >>
  >>         else b:=car b2;
  arbit:=caddr b;        % arbit are the free functions of the CRACK run
                         % newfu are the solved functions
  for each el1 in cadr b do
  if not((pairp el1       ) and
         (car el1 = 'EQUAL)     ) then arbit:=cons(el1,arbit)
                                  else newfu:=cons(el1,newfu)$
  oldcon:=car a;
  sol:=cadr a;
  unequ:=cadddr a;

  % flstart are the remaining essential free functions
  % redund are the functions to be dropped, they are set to 0 in
  % the old solution
  for each el1 in corres do
  if member(car el1,arbit) and member(cdr el1,arbit) then <<
   redund:=cons(list('EQUAL,car el1,0),redund);
   fldrop:=cons(car el1,fldrop);
   % the function and its copy are both not essential
   oldcon:=for each el2 in oldcon collect reval subst(0,car el1,el2);
   sol:=for each el2 in sol collect <<
    if (pairp el2) and (car el2='EQUAL) then
    put(cadr el2,'fcts,delete(car el1,get(cadr el2,'fcts)));
    reval subst(0,car el1,el2)
   >>$
   unequ:=for each el2 in unequ collect reval subst(0,car el1,el2);
   arbit:=delete(car el1,arbit);
   arbit:=delete(cdr el1,arbit);
   fl:=delete(car el1,fl);
   fl:=delete(cdr el1,fl);
   flstart:=delete(car el1,flstart);
   flnew:=delete(cdr el1,flnew);
   newfu:=subst(0,car el1,newfu);
   newfu:=subst(0,cdr el1,newfu);
  >>                                                 else
  newcorres:=cons(el1,newcorres);

  % Eliminate from all equations the flnew function in terms of
  % the corresponding flstart function and possibly other terms
  % newnewfu becomes a list of substitutions of new functions
  % by expressions in old functions.
  while newfu do <<
   el1:=car newfu; % el1: evaluated function = expression
   el2:=cadr el1;  % el2: evaluated function
   b:=newcorres;   % the remaining correspondences
   while b and (el2 neq cdar b) do b:=cdr b;
   if b then       % el2 = cdar b is a new function
   if (not freeof(el1,caar b)) then newnewfu:=cons(el1,newnewfu)
                               else <<
    % The right hand side ex1 of equation el1: el2=ex1 does not
    % contain the old function, say f, which corresponds to the
    % new function el2
    % --> search for an equation car el3 in newfu of the form
    % f = ex2, then add el2=ex1+f-ex2 to newnewfu
    el3:=newfu;
    while el3 and (cadar el3 neq caar b) do el3:=cdr el3;
    if el3 then <<
     newnewfu:=cons(list('EQUAL,el2,reval list('PLUS,caddr el1,cadar el3,
                                         list('MINUS,caddar el3)     )),
                    newnewfu);
     newfu:=delete(car el3,newfu)
    >>     else newnewfu:=nil;  % means later that it can not be treated
   >>   else <<    % el2 is an old function
    % like in the case above, only that in order to add equations of
    % the form new_fct = expr in old_fcts can be added to newnewfu,
    % the equations has to be solved for new_fct
    b:=newcorres;  % the correspondences of the remaining functions
    while el2 neq caar b do b:=cdr b; % caar b is now el2 (old function)
    if (not freeof(el1,cdar b)) then  % image function of el2 is in el1
    % solving el1 for the image function cdar b of el2
    newnewfu:=cons(list('EQUAL,cdar b,reval list('PLUS,cdar b,el2,
                                           list('MINUS,caddr el1))
                       ),newnewfu)
                                else <<
     % add an equ. to el1 with (the pri-image function of el2) = ...
     el3:=newfu;
     while el3 and (cadar el3 neq cdar b) do el3:=cdr el3;
     if el3 then <<
      newnewfu:=cons(list('EQUAL,cdar b,
                          reval list('PLUS,caddar el3,cadr el1,
                               list('MINUS,caddr el1)      )),
                     newnewfu);
      newfu:=delete(car el3,newfu)
     >>     else newnewfu:=nil;  % means later that it can not be treated
    >>
   >>;
   newfu:=cdr newfu
  >>;
  newfu:=newnewfu;

  % test, whether each new function has exactly one substitution
  % and no new function appears on a rhs
  if length flnew = length newfu then
  while newnewfu and freeoflist(caddar newnewfu,flnew) do
  newnewfu:=cdr newnewfu;

  if newfu and (not newnewfu) then <<
   % now the conditions have really been solved for the new
   % functions, no new function is on the rhs

   % arbit are all free old and new functions after the above CRACK-run
   % fl are all functions at the start of the above CRACK-run
   % flnew are all remaining new functions
   % flstart are all the old functions
   % new arbit: all functions which came in only through the
   %            last CRACK run
   arbit:=setdiff(setdiff(union(arbit,fl),flnew),flstart);

   % rewriting the substitutions as: old fct = expr in old fcts
   newfu:=
   for each el1 in newfu collect <<
    b:=cadr el1;     % b is a new function
    el2:=newcorres;  % caar el2 the corresponding old function
    while b neq cdar el2 do el2:=cdr el2;
    list('EQUAL,caar el2,reval caddr el1)
   >>;

   % Specifying the functions in arbit which are free to get as many
   % as possible functions flstart to zero
   arbit:=fctsort(arbit)$  % to use the functions with most variables first
   for each el1 in arbit do <<
    vla:=fctargs el1; % variables of the function to be eliminated
    el2:=newfu;
    while el2 do
    if freeof(car el2,el1) then el2:=cdr el2
                           else <<
     vlf:=fctargs cadar el2;
     if (null not_included(vla,vlf)) and
        (null not_included(vlf,vla)) then <<
      % cadar el2 is a function that shall be made to zero
      % by a choice for el1

      % It is checked whether the arbitrary function el1 occurs only
      % linearly algebraically, so that it can be computed by
      % solving equation car el2
      b:=lderiv(caddar el2,el1,vla);
      if cdr b=1 then << % success!! cadar el2 can be set to zero!
       if (car b neq el1) and print_ then <>;
        fctprint b; b:=nil
       >>;
       redund:=cons(list('EQUAL,cadar el2,0),redund);
       fldrop:=cons(cadar el2,fldrop);
       oldcon:=for each el3 in oldcon collect reval subst(0,cadar el2,el3);
       sol:=for each el3 in sol collect <<
        if (pairp el3) and (car el3='EQUAL) then
        put(cadr el3,'fcts,delete(cadar el2,get(cadr el3,'fcts)));
        reval subst(0,cadar el2,el3)
       >>$
       unequ:=for each el3 in unequ collect reval subst(0,cadar el2,el3);
       flstart:=delete(cadar el2,flstart);
       newfu:=delete(car el2,newfu);
       el2:=nil;
      >>
     >>;
     if el2 then el2:=cdr el2
    >>
   >>;

   % substituting all remaining functions arbit in the substitutions
   % newfu to zero which are not already specified
   for each el1 in arbit do newfu:=subst(0,el1,newfu);
  >>;
  if fldrop and print_ then <<
   terpri()$
   write"non-essential dropped constant(s) or function(s): ";
   fctprint fldrop
  >>$
  for each el1 in append(todelete,fldrop) do
  depl!*:=delete(assoc(el1,depl!*),depl!*)$
  return
  if null fldrop then nil
                 else list(redund,oldcon,sol,union(nofl_arbit,flstart),unequ)
 >>
end$

symbolic operator ncontent$
symbolic procedure ncontent p$
% Return numeric content of expression p
% based on simpnprimitive in ezgcd.
<< p := simp!* p;
%   if polyzerop(numr p) then 0 else
   if p=('NIL . 1) then 0 else
   mk!*sq(numeric!-content numr p ./ numeric!-content denr p)
>>$

algebraic procedure absorbconst(exlist,flist)$
% absorbing numerical factors into free constants/functions of flist
% if the list of expressions in exlist is known to be linear in flist
% returns an algebraic list of substitutions to be done
begin
  scalar e1,e2,n,n1,n2,nu,sb,cs1,cs2,!*rational_bak;
  !*rational_bak:=!*rational;
  if !*rational then algebraic(off rational)$
  sb:={};
  for each e1 in flist do <<
    n1:=nil;
    % to make a change of sign at least one equation
    % must demand it which is cs1=t
    % and no equation must forbit it which is cs2=nil
    cs1:=nil; cs2:=t;
    for each e2 in exlist do <<
      n:=coeffn(e2,e1,1);
      if n neq 0 then <<
        % if at least one equation does not demand a change of
        % sign then no change of sign is made

        if (numberp n) and (n<0) then cs1:=t
                                 else
        if lisp pairp reval algebraic n then <<
          if part(n,0)='MINUS then cs1:=t
                              else
          if part(n,0)='QUOTIENT then
          <>$

 level_:=cons(1,level_)$
 if print_ then <<
   print_level(t)$
   terpri()$write "CRACK is now called to check whether a given"$
   terpri()$write "solution is included in the current system."
 >>;
 % further necessary step to call crackmain():
 recycle_fcts:=nil$  % such that functions generated in the sub-call
                     % will not clash with existing functions
 pdes:=append(mkeqlist(cdr solu,ftem_,vl_,allflags_,t,list(0),pdes),pdes)$
 session_bak:=session_$
 session_:=nil$ % to prevent the saving of the solution of this side comput.
 l1:=crackmain(pdes,forg)$
 session_:=session_bak$
 if l1 and not contradiction_ then write"+++++ Solution IS included."
                              else write"+++++ Solution is NOT included."$
 terpri()$
 contradiction_:=nil$
 l1:=restore_backup_from_file(pdes,forg,nil)$
 % not needed: pdes:=car l1;  forg:=cadr l1;
 delete_backup()$
 !*batch_mode:=batch_bak
end$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/conlaw.red0000644000175000017500000000323111526203062023545 0ustar  giovannigiovannimodule conlaw;  % Conservation laws using CRACK

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This header file by FJW, 28 July 1998

create!-package('(conlaw conlaw0 conlaw1 conlaw2 conlaw3 conlaw4),nil);

% FJW: Load support packages, but not when compiling:
!#if (getd 'packages_to_load)
packages_to_load crack;
!#else                                  % for REDUCE 3.6
apply1('load!-package, 'crack);
!#endif

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/crack/dev.red0000644000175000017500000000256011526203062023044 0ustar  giovannigiovanniload crack,conlaw0,conlaw1,conlaw2,conlaw3,conlaw4,liepde,applysym$


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

in "crack.tst";

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/avector/0000755000175000017500000000000011722677365022172 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/avector/avector.tst0000644000175000017500000000400711526203062024347 0ustar  giovannigiovanni% Vector test routine

% Author: David Harper (algebra@liverpool.ac.uk)
%         Computer Algebra Support Officer
%         University of Liverpool Computer Laboratory.

% Please compare carefully the output from running this test file with the
% log file provided to make sure your implementation is correct.

linelength 72;
off allfac; on div;
vec a,b,c;
matrix q;
a := avec(ax,ay,az);
b := avec(bx,by,bz);
q := mat((q11,q12,q13),(q21,q22,q23),(q31,q32,q33));

c := a+b;
c := a-b;
c := a cross b;
d := a dot b;
a dot c; b dot c;
q*a;
c:=2*f*a - b/7;
c(0); c(1); c(2);

1/vmod(a);
b/vmod(a);
(a cross b)/(a dot b);
2/3*vmod(a)*a*(a dot c)/(vmod(a cross c));

a := avec(x**2*y**3,log(z+x),13*z-y);
df(a,x);
df(a,x,y);
int(a,x);
exp(a);
log sin b;

a := avec(ax,ay,az);
depend ax,x,y,z; depend ay,x,y,z; depend az,x,y,z;
depend p,x,y,z;
c := grad p;
div c;
delsq p;
div a;
curl a;
delsq a;

depend h1,x,y,z; depend h2,x,y,z; depend h3,x,y,z;
scalefactors(h1,h2,h3);
grad p;
div a;
curl a;
dp1 := delsq p;
dp2 := div grad p;
dp1-dp2;
delsq a;
curl grad p;
grad div a;
div curl a;

% Examples of integration : (1) Volume integrals

getcsystem 'spherical;

% Example 1 : integration of r**n over a sphere

origin := avec(0,0,0);
upperbound := avec(rr,pi,2*pi);
volintegral(r**n,origin,upperbound);

% Substitute n=0 to get the volume of a sphere
sub(n=0,ws);

% Example 2 : volume of a right-circular cone

getcsystem 'cylindrical;
upperbound := avec(pp*z,h,2*pi);
volintorder := avec(2,0,1);      % Integrate in the order : phi, r, z
cone := volintegral(1,origin,upperbound);

% Now we replace P*Z by RR to get the result in the familiar form

let pp*h=rr;
cone := cone;                    % This is the familiar form
clear pp*h;

% Example 3 : line integral to obtain the length of a line of latitude
%             on a sphere

getcsystem 'spherical;

a := avec(0,0,1);            % Function vector is the tangent to the
			     % line of latitude
curve := avec(rr,latitude,phi);   % Path is round a line of latitude

deflineint(a,curve,phi,0,2*pi);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/avector/avector.rlg0000644000175000017500000007752111527635055024350 0ustar  giovannigiovanniFri Feb 18 21:27:22 2011 run on win32

*** ^ redefined 
% Vector test routine

% Author: David Harper (algebra@liverpool.ac.uk)
%         Computer Algebra Support Officer
%         University of Liverpool Computer Laboratory.

% Please compare carefully the output from running this test file with the
% log file provided to make sure your implementation is correct.

linelength 72;


80

off allfac;

 on div;


vec a,b,c;


matrix q;


a := avec(ax,ay,az);


vec(x) := ax

vec(y) := ay

vec(z) := az


b := avec(bx,by,bz);


vec(x) := bx

vec(y) := by

vec(z) := bz


q := mat((q11,q12,q13),(q21,q22,q23),(q31,q32,q33));


     [q11  q12  q13]
     [             ]
q := [q21  q22  q23]
     [             ]
     [q31  q32  q33]



c := a+b;


vec(x) := ax + bx

vec(y) := ay + by

vec(z) := az + bz


c := a-b;


vec(x) := ax - bx

vec(y) := ay - by

vec(z) := az - bz


c := a cross b;


vec(x) := ay*bz - az*by

vec(y) :=  - ax*bz + az*bx

vec(z) := ax*by - ay*bx


d := a dot b;


d := ax*bx + ay*by + az*bz

a dot c;


0
 b dot c;


0

q*a;


vec(x) := ax*q11 + ay*q12 + az*q13

vec(y) := ax*q21 + ay*q22 + az*q23

vec(z) := ax*q31 + ay*q32 + az*q33


c:=2*f*a - b/7;


                    1
vec(x) := 2*ax*f - ---*bx
                    7

                    1
vec(y) := 2*ay*f - ---*by
                    7

                    1
vec(z) := 2*az*f - ---*bz
                    7


c(0);


          1
2*ax*f - ---*bx
          7
 c(1);


          1
2*ay*f - ---*by
          7
 c(2);


          1
2*az*f - ---*bz
          7


1/vmod(a);


   2     2     2  - 1/2
(ax  + ay  + az )

b/vmod(a);


             2     2     2  - 1/2
vec(x) := (ax  + ay  + az )      *bx

             2     2     2  - 1/2
vec(y) := (ax  + ay  + az )      *by

             2     2     2  - 1/2
vec(z) := (ax  + ay  + az )      *bz


(a cross b)/(a dot b);


               ay*bz - az*by
vec(x) := -----------------------
           ax*bx + ay*by + az*bz

              - ax*bz + az*bx
vec(y) := -----------------------
           ax*bx + ay*by + az*bz

               ax*by - ay*bx
vec(z) := -----------------------
           ax*bx + ay*by + az*bz


2/3*vmod(a)*a*(a dot c)/(vmod(a cross c));


           28     2   2     2   2
vec(x) := ----*(ax *by  + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz
           3

                     2   2     2   2                     2   2     2   2
                 + ay *bx  + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by

                     - 1         2     2     2    3      2     2   2
                )**------*sqrt(ax  + ay  + az )*ax *f - ---*(ax *by
                     2                                   3

                  2   2                                     2   2
              + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx

                  2   2                     2   2     2   2     - 1
              + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                                2

                  2     2     2    2       28     2   2     2   2
          *sqrt(ax  + ay  + az )*ax *bx + ----*(ax *by  + ax *bz
                                           3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2       2      2     2   2     2   2
          *sqrt(ax  + ay  + az )*ax*ay *f - ---*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2              28     2   2     2   2
          *sqrt(ax  + ay  + az )*ax*ay*by + ----*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2       2      2     2   2     2   2
          *sqrt(ax  + ay  + az )*ax*az *f - ---*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2
          *sqrt(ax  + ay  + az )*ax*az*bz

           28     2   2     2   2
vec(y) := ----*(ax *by  + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz
           3

                     2   2     2   2                     2   2     2   2
                 + ay *bx  + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by

                     - 1         2     2     2    2         2     2   2
                )**------*sqrt(ax  + ay  + az )*ax *ay*f - ---*(ax *by
                     2                                      3

                  2   2                                     2   2
              + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx

                  2   2                     2   2     2   2     - 1
              + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                                2

                  2     2     2              28     2   2     2   2
          *sqrt(ax  + ay  + az )*ax*ay*bx + ----*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2    3      2     2   2     2   2
          *sqrt(ax  + ay  + az )*ay *f - ---*(ax *by  + ax *bz
                                          3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2    2       28     2   2     2   2
          *sqrt(ax  + ay  + az )*ay *by + ----*(ax *by  + ax *bz
                                           3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2       2      2     2   2     2   2
          *sqrt(ax  + ay  + az )*ay*az *f - ---*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2
          *sqrt(ax  + ay  + az )*ay*az*bz

           28     2   2     2   2
vec(z) := ----*(ax *by  + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz
           3

                     2   2     2   2                     2   2     2   2
                 + ay *bx  + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by

                     - 1         2     2     2    2         2     2   2
                )**------*sqrt(ax  + ay  + az )*ax *az*f - ---*(ax *by
                     2                                      3

                  2   2                                     2   2
              + ax *bz  - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx

                  2   2                     2   2     2   2     - 1
              + ay *bz  - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                                2

                  2     2     2              28     2   2     2   2
          *sqrt(ax  + ay  + az )*ax*az*bx + ----*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2    2         2     2   2     2   2
          *sqrt(ax  + ay  + az )*ay *az*f - ---*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2              28     2   2     2   2
          *sqrt(ax  + ay  + az )*ay*az*by + ----*(ax *by  + ax *bz
                                             3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2    3      2     2   2     2   2
          *sqrt(ax  + ay  + az )*az *f - ---*(ax *by  + ax *bz
                                          3

                                                  2   2     2   2
              - 2*ax*ay*bx*by - 2*ax*az*bx*bz + ay *bx  + ay *bz

                                  2   2     2   2     - 1
              - 2*ay*az*by*bz + az *bx  + az *by )**------
                                                      2

                  2     2     2    2
          *sqrt(ax  + ay  + az )*az *bz



a := avec(x**2*y**3,log(z+x),13*z-y);


           2  3
vec(x) := x *y

vec(y) := log(x + z)

vec(z) :=  - y + 13*z


df(a,x);


               3
vec(x) := 2*x*y

             1
vec(y) := -------
           x + z

vec(z) := 0


df(a,x,y);


               2
vec(x) := 6*x*y

vec(y) := 0

vec(z) := 0


int(a,x);


           1   3  3
vec(x) := ---*x *y
           3

vec(y) := log(x + z)*x + log(x + z)*z - x

vec(z) :=  - x*y + 13*x*z


exp(a);


            2  3
           x *y
vec(x) := e

vec(y) := x + z

            - y + 13*z
vec(z) := e


log sin b;


vec(x) := log(sin(bx))

vec(y) := log(sin(by))

vec(z) := log(sin(bz))



a := avec(ax,ay,az);


vec(x) := ax

vec(y) := ay

vec(z) := az


depend ax,x,y,z;

 depend ay,x,y,z;

 depend az,x,y,z;


depend p,x,y,z;


c := grad p;


vec(x) := df(p,x)

vec(y) := df(p,y)

vec(z) := df(p,z)


div c;


df(p,x,2) + df(p,y,2) + df(p,z,2)

delsq p;


df(p,x,2) + df(p,y,2) + df(p,z,2)

div a;


df(ax,x) + df(ay,y) + df(az,z)

curl a;


vec(x) :=  - df(ay,z) + df(az,y)

vec(y) := df(ax,z) - df(az,x)

vec(z) :=  - df(ax,y) + df(ay,x)


delsq a;


vec(x) := df(ax,x,2) + df(ax,y,2) + df(ax,z,2)

vec(y) := df(ay,x,2) + df(ay,y,2) + df(ay,z,2)

vec(z) := df(az,x,2) + df(az,y,2) + df(az,z,2)



depend h1,x,y,z;

 depend h2,x,y,z;

 depend h3,x,y,z;


scalefactors(h1,h2,h3);


grad p;


                    -1
vec(x) := df(p,x)*h1

                    -1
vec(y) := df(p,y)*h2

                    -1
vec(z) := df(p,z)*h3


div a;


           -1              -1              -1                 -1   -1
df(ax,x)*h1   + df(ay,y)*h2   + df(az,z)*h3   + df(h1,y)*ay*h1  *h2

                 -1   -1                 -1   -1                 -1   -1
 + df(h1,z)*az*h1  *h3   + df(h2,x)*ax*h1  *h2   + df(h2,z)*az*h2  *h3

                 -1   -1                 -1   -1
 + df(h3,x)*ax*h1  *h3   + df(h3,y)*ay*h2  *h3

curl a;


                        -1              -1                 -1   -1
vec(x) :=  - df(ay,z)*h3   + df(az,y)*h2   - df(h2,z)*ay*h2  *h3

                           -1   -1
           + df(h3,y)*az*h2  *h3

                     -1              -1                 -1   -1
vec(y) := df(ax,z)*h3   - df(az,x)*h1   + df(h1,z)*ax*h1  *h3

                           -1   -1
           - df(h3,x)*az*h1  *h3

                        -1              -1                 -1   -1
vec(z) :=  - df(ax,y)*h2   + df(ay,x)*h1   - df(h1,y)*ax*h1  *h2

                           -1   -1
           + df(h2,x)*ay*h1  *h2


dp1 := delsq p;


                             -3                      -1   -2
dp1 :=  - df(h1,x)*df(p,x)*h1   + df(h1,y)*df(p,y)*h1  *h2

                             -1   -2                      -2   -1
        + df(h1,z)*df(p,z)*h1  *h3   + df(h2,x)*df(p,x)*h1  *h2

                             -3                      -1   -2
        - df(h2,y)*df(p,y)*h2   + df(h2,z)*df(p,z)*h2  *h3

                             -2   -1                      -2   -1
        + df(h3,x)*df(p,x)*h1  *h3   + df(h3,y)*df(p,y)*h2  *h3

                             -3               -2               -2
        - df(h3,z)*df(p,z)*h3   + df(p,x,2)*h1   + df(p,y,2)*h2

                      -2
        + df(p,z,2)*h3

dp2 := div grad p;


                             -3                      -1   -2
dp2 :=  - df(h1,x)*df(p,x)*h1   + df(h1,y)*df(p,y)*h1  *h2

                             -1   -2                      -2   -1
        + df(h1,z)*df(p,z)*h1  *h3   + df(h2,x)*df(p,x)*h1  *h2

                             -3                      -1   -2
        - df(h2,y)*df(p,y)*h2   + df(h2,z)*df(p,z)*h2  *h3

                             -2   -1                      -2   -1
        + df(h3,x)*df(p,x)*h1  *h3   + df(h3,y)*df(p,y)*h2  *h3

                             -3               -2               -2
        - df(h3,z)*df(p,z)*h3   + df(p,x,2)*h1   + df(p,y,2)*h2

                      -2
        + df(p,z,2)*h3

dp1-dp2;


0

delsq a;


                       -2                       -3
vec(x) := df(ax,x,2)*h1   - df(ax,x)*df(h1,x)*h1

                                 -2   -1                       -2   -1
           + df(ax,x)*df(h2,x)*h1  *h2   + df(ax,x)*df(h3,x)*h1  *h3

                          -2                       -1   -2
           + df(ax,y,2)*h2   + df(ax,y)*df(h1,y)*h1  *h2

                                 -3                       -2   -1
           - df(ax,y)*df(h2,y)*h2   + df(ax,y)*df(h3,y)*h2  *h3

                          -2                       -1   -2
           + df(ax,z,2)*h3   + df(ax,z)*df(h1,z)*h1  *h3

                                 -1   -2                       -3
           + df(ax,z)*df(h2,z)*h2  *h3   - df(ax,z)*df(h3,z)*h3

                                   -2   -1
           + 2*df(ay,x)*df(h1,y)*h1  *h2

                                   -1   -2
           - 2*df(ay,y)*df(h2,x)*h1  *h2

                                   -2   -1
           + 2*df(az,x)*df(h1,z)*h1  *h3

                                   -1   -2                   -2   -1
           - 2*df(az,z)*df(h3,x)*h1  *h3   + df(h1,x,y)*ay*h1  *h2

                             -2   -1                          -3   -1
           + df(h1,x,z)*az*h1  *h3   - df(h1,x)*df(h1,y)*ay*h1  *h2

                                    -3   -1
           - df(h1,x)*df(h1,z)*az*h1  *h3

                                    -3   -1
           - df(h1,x)*df(h2,x)*ax*h1  *h2

                                    -3   -1                   -1   -2
           - df(h1,x)*df(h3,x)*ax*h1  *h3   + df(h1,y,2)*ax*h1  *h2

                     2      -2   -2                          -1   -3
           - df(h1,y) *ax*h1  *h2   - df(h1,y)*df(h2,y)*ax*h1  *h2

                                    -1   -2   -1
           + df(h1,y)*df(h3,y)*ax*h1  *h2  *h3

                             -1   -2           2      -2   -2
           + df(h1,z,2)*ax*h1  *h3   - df(h1,z) *ax*h1  *h3

                                    -1   -1   -2
           + df(h1,z)*df(h2,z)*ax*h1  *h2  *h3

                                    -1   -3                   -1   -2
           - df(h1,z)*df(h3,z)*ax*h1  *h3   - df(h2,x,y)*ay*h1  *h2

                             -1   -1   -1                   -2   -1
           + df(h2,x,z)*az*h1  *h2  *h3   + df(h2,x,2)*ax*h1  *h2

                     2      -2   -2                          -1   -3
           - df(h2,x) *ax*h1  *h2   + df(h2,x)*df(h2,y)*ay*h1  *h2

                                    -1   -2   -1
           - df(h2,x)*df(h2,z)*az*h1  *h2  *h3

                                      -1   -2   -1
           - 2*df(h2,x)*df(h3,y)*ay*h1  *h2  *h3

                                      -1   -1   -2
           - 2*df(h2,z)*df(h3,x)*az*h1  *h2  *h3

                             -1   -1   -1                   -1   -2
           + df(h3,x,y)*ay*h1  *h2  *h3   - df(h3,x,z)*az*h1  *h3

                             -2   -1           2      -2   -2
           + df(h3,x,2)*ax*h1  *h3   - df(h3,x) *ax*h1  *h3

                                    -1   -1   -2
           - df(h3,x)*df(h3,y)*ay*h1  *h2  *h3

                                    -1   -3
           + df(h3,x)*df(h3,z)*az*h1  *h3

                                   -2   -1
vec(y) :=  - 2*df(ax,x)*df(h1,y)*h1  *h2

                                   -1   -2                -2
           + 2*df(ax,y)*df(h2,x)*h1  *h2   + df(ay,x,2)*h1

                                 -3                       -2   -1
           - df(ay,x)*df(h1,x)*h1   + df(ay,x)*df(h2,x)*h1  *h2

                                 -2   -1                -2
           + df(ay,x)*df(h3,x)*h1  *h3   + df(ay,y,2)*h2

                                 -1   -2                       -3
           + df(ay,y)*df(h1,y)*h1  *h2   - df(ay,y)*df(h2,y)*h2

                                 -2   -1                -2
           + df(ay,y)*df(h3,y)*h2  *h3   + df(ay,z,2)*h3

                                 -1   -2                       -1   -2
           + df(ay,z)*df(h1,z)*h1  *h3   + df(ay,z)*df(h2,z)*h2  *h3

                                 -3                         -2   -1
           - df(ay,z)*df(h3,z)*h3   + 2*df(az,y)*df(h2,z)*h2  *h3

                                   -1   -2                   -2   -1
           - 2*df(az,z)*df(h3,y)*h2  *h3   - df(h1,x,y)*ax*h1  *h2

                                    -3   -1
           + df(h1,x)*df(h1,y)*ax*h1  *h2

                                    -3   -1
           - df(h1,x)*df(h2,x)*ay*h1  *h2

                             -1   -1   -1                   -1   -2
           + df(h1,y,z)*az*h1  *h2  *h3   + df(h1,y,2)*ay*h1  *h2

                     2      -2   -2
           - df(h1,y) *ay*h1  *h2

                                    -2   -1   -1
           - df(h1,y)*df(h1,z)*az*h1  *h2  *h3

                                    -1   -3
           - df(h1,y)*df(h2,y)*ay*h1  *h2

                                      -2   -1   -1
           - 2*df(h1,y)*df(h3,x)*ax*h1  *h2  *h3

                                    -1   -1   -2
           + df(h1,z)*df(h2,z)*ay*h1  *h2  *h3

                                      -1   -1   -2
           - 2*df(h1,z)*df(h3,y)*az*h1  *h2  *h3

                             -1   -2                   -2   -1
           + df(h2,x,y)*ax*h1  *h2   + df(h2,x,2)*ay*h1  *h2

                     2      -2   -2                          -1   -3
           - df(h2,x) *ay*h1  *h2   - df(h2,x)*df(h2,y)*ax*h1  *h2

                                    -2   -1   -1
           + df(h2,x)*df(h3,x)*ay*h1  *h2  *h3

                             -2   -1                          -3   -1
           + df(h2,y,z)*az*h2  *h3   - df(h2,y)*df(h2,z)*az*h2  *h3

                                    -3   -1                   -1   -2
           - df(h2,y)*df(h3,y)*ay*h2  *h3   + df(h2,z,2)*ay*h2  *h3

                     2      -2   -2                          -1   -3
           - df(h2,z) *ay*h2  *h3   - df(h2,z)*df(h3,z)*ay*h2  *h3

                             -1   -1   -1
           + df(h3,x,y)*ax*h1  *h2  *h3

                                    -1   -1   -2
           - df(h3,x)*df(h3,y)*ax*h1  *h2  *h3

                             -1   -2                   -2   -1
           - df(h3,y,z)*az*h2  *h3   + df(h3,y,2)*ay*h2  *h3

                     2      -2   -2                          -1   -3
           - df(h3,y) *ay*h2  *h3   + df(h3,y)*df(h3,z)*az*h2  *h3

                                   -2   -1
vec(z) :=  - 2*df(ax,x)*df(h1,z)*h1  *h3

                                   -1   -2
           + 2*df(ax,z)*df(h3,x)*h1  *h3

                                   -2   -1
           - 2*df(ay,y)*df(h2,z)*h2  *h3

                                   -1   -2                -2
           + 2*df(ay,z)*df(h3,y)*h2  *h3   + df(az,x,2)*h1

                                 -3                       -2   -1
           - df(az,x)*df(h1,x)*h1   + df(az,x)*df(h2,x)*h1  *h2

                                 -2   -1                -2
           + df(az,x)*df(h3,x)*h1  *h3   + df(az,y,2)*h2

                                 -1   -2                       -3
           + df(az,y)*df(h1,y)*h1  *h2   - df(az,y)*df(h2,y)*h2

                                 -2   -1                -2
           + df(az,y)*df(h3,y)*h2  *h3   + df(az,z,2)*h3

                                 -1   -2                       -1   -2
           + df(az,z)*df(h1,z)*h1  *h3   + df(az,z)*df(h2,z)*h2  *h3

                                 -3                   -2   -1
           - df(az,z)*df(h3,z)*h3   - df(h1,x,z)*ax*h1  *h3

                                    -3   -1
           + df(h1,x)*df(h1,z)*ax*h1  *h3

                                    -3   -1
           - df(h1,x)*df(h3,x)*az*h1  *h3

                             -1   -1   -1
           + df(h1,y,z)*ay*h1  *h2  *h3

                                    -2   -1   -1
           - df(h1,y)*df(h1,z)*ay*h1  *h2  *h3

                                      -1   -2   -1
           - 2*df(h1,y)*df(h2,z)*ay*h1  *h2  *h3

                                    -1   -2   -1
           + df(h1,y)*df(h3,y)*az*h1  *h2  *h3

                             -1   -2           2      -2   -2
           + df(h1,z,2)*az*h1  *h3   - df(h1,z) *az*h1  *h3

                                      -2   -1   -1
           - 2*df(h1,z)*df(h2,x)*ax*h1  *h2  *h3

                                    -1   -3
           - df(h1,z)*df(h3,z)*az*h1  *h3

                             -1   -1   -1
           + df(h2,x,z)*ax*h1  *h2  *h3

                                    -1   -2   -1
           - df(h2,x)*df(h2,z)*ax*h1  *h2  *h3

                                    -2   -1   -1
           + df(h2,x)*df(h3,x)*az*h1  *h2  *h3

                             -2   -1                          -3   -1
           - df(h2,y,z)*ay*h2  *h3   + df(h2,y)*df(h2,z)*ay*h2  *h3

                                    -3   -1                   -1   -2
           - df(h2,y)*df(h3,y)*az*h2  *h3   + df(h2,z,2)*az*h2  *h3

                     2      -2   -2                          -1   -3
           - df(h2,z) *az*h2  *h3   - df(h2,z)*df(h3,z)*az*h2  *h3

                             -1   -2                   -2   -1
           + df(h3,x,z)*ax*h1  *h3   + df(h3,x,2)*az*h1  *h3

                     2      -2   -2                          -1   -3
           - df(h3,x) *az*h1  *h3   - df(h3,x)*df(h3,z)*ax*h1  *h3

                             -1   -2                   -2   -1
           + df(h3,y,z)*ay*h2  *h3   + df(h3,y,2)*az*h2  *h3

                     2      -2   -2                          -1   -3
           - df(h3,y) *az*h2  *h3   - df(h3,y)*df(h3,z)*ay*h2  *h3


curl grad p;


vec(x) := 0

vec(y) := 0

vec(z) := 0


grad div a;


                       -2                       -3
vec(x) := df(ax,x,2)*h1   - df(ax,x)*df(h1,x)*h1

                                 -2   -1                       -2   -1
           + df(ax,x)*df(h2,x)*h1  *h2   + df(ax,x)*df(h3,x)*h1  *h3

                          -1   -1                       -2   -1
           + df(ay,x,y)*h1  *h2   + df(ay,x)*df(h1,y)*h1  *h2

                                 -1   -1   -1
           + df(ay,x)*df(h3,y)*h1  *h2  *h3

                                 -1   -2                -1   -1
           - df(ay,y)*df(h2,x)*h1  *h2   + df(az,x,z)*h1  *h3

                                 -2   -1
           + df(az,x)*df(h1,z)*h1  *h3

                                 -1   -1   -1
           + df(az,x)*df(h2,z)*h1  *h2  *h3

                                 -1   -2                   -2   -1
           - df(az,z)*df(h3,x)*h1  *h3   + df(h1,x,y)*ay*h1  *h2

                             -2   -1                          -3   -1
           + df(h1,x,z)*az*h1  *h3   - df(h1,x)*df(h1,y)*ay*h1  *h2

                                    -3   -1
           - df(h1,x)*df(h1,z)*az*h1  *h3

                                    -3   -1
           - df(h1,x)*df(h2,x)*ax*h1  *h2

                                    -3   -1
           - df(h1,x)*df(h3,x)*ax*h1  *h3

                                    -2   -2
           - df(h1,y)*df(h2,x)*ay*h1  *h2

                                    -2   -2
           - df(h1,z)*df(h3,x)*az*h1  *h3

                             -1   -1   -1                   -2   -1
           + df(h2,x,z)*az*h1  *h2  *h3   + df(h2,x,2)*ax*h1  *h2

                     2      -2   -2
           - df(h2,x) *ax*h1  *h2

                                    -1   -2   -1
           - df(h2,x)*df(h2,z)*az*h1  *h2  *h3

                                    -1   -2   -1
           - df(h2,x)*df(h3,y)*ay*h1  *h2  *h3

                                    -1   -1   -2
           - df(h2,z)*df(h3,x)*az*h1  *h2  *h3

                             -1   -1   -1                   -2   -1
           + df(h3,x,y)*ay*h1  *h2  *h3   + df(h3,x,2)*ax*h1  *h3

                     2      -2   -2
           - df(h3,x) *ax*h1  *h3

                                    -1   -1   -2
           - df(h3,x)*df(h3,y)*ay*h1  *h2  *h3

                       -1   -1                       -2   -1
vec(y) := df(ax,x,y)*h1  *h2   - df(ax,x)*df(h1,y)*h1  *h2

                                 -1   -2
           + df(ax,y)*df(h2,x)*h1  *h2

                                 -1   -1   -1                -2
           + df(ax,y)*df(h3,x)*h1  *h2  *h3   + df(ay,y,2)*h2

                                 -1   -2                       -3
           + df(ay,y)*df(h1,y)*h1  *h2   - df(ay,y)*df(h2,y)*h2

                                 -2   -1                -1   -1
           + df(ay,y)*df(h3,y)*h2  *h3   + df(az,y,z)*h2  *h3

                                 -1   -1   -1
           + df(az,y)*df(h1,z)*h1  *h2  *h3

                                 -2   -1                       -1   -2
           + df(az,y)*df(h2,z)*h2  *h3   - df(az,z)*df(h3,y)*h2  *h3

                             -1   -1   -1                   -1   -2
           + df(h1,y,z)*az*h1  *h2  *h3   + df(h1,y,2)*ay*h1  *h2

                     2      -2   -2
           - df(h1,y) *ay*h1  *h2

                                    -2   -1   -1
           - df(h1,y)*df(h1,z)*az*h1  *h2  *h3

                                    -2   -2
           - df(h1,y)*df(h2,x)*ax*h1  *h2

                                    -1   -3
           - df(h1,y)*df(h2,y)*ay*h1  *h2

                                    -2   -1   -1
           - df(h1,y)*df(h3,x)*ax*h1  *h2  *h3

                                    -1   -1   -2
           - df(h1,z)*df(h3,y)*az*h1  *h2  *h3

                             -1   -2                          -1   -3
           + df(h2,x,y)*ax*h1  *h2   - df(h2,x)*df(h2,y)*ax*h1  *h2

                             -2   -1                          -3   -1
           + df(h2,y,z)*az*h2  *h3   - df(h2,y)*df(h2,z)*az*h2  *h3

                                    -3   -1
           - df(h2,y)*df(h3,y)*ay*h2  *h3

                                    -2   -2
           - df(h2,z)*df(h3,y)*az*h2  *h3

                             -1   -1   -1
           + df(h3,x,y)*ax*h1  *h2  *h3

                                    -1   -1   -2
           - df(h3,x)*df(h3,y)*ax*h1  *h2  *h3

                             -2   -1           2      -2   -2
           + df(h3,y,2)*ay*h2  *h3   - df(h3,y) *ay*h2  *h3

                       -1   -1                       -2   -1
vec(z) := df(ax,x,z)*h1  *h3   - df(ax,x)*df(h1,z)*h1  *h3

                                 -1   -1   -1
           + df(ax,z)*df(h2,x)*h1  *h2  *h3

                                 -1   -2                -1   -1
           + df(ax,z)*df(h3,x)*h1  *h3   + df(ay,y,z)*h2  *h3

                                 -2   -1
           - df(ay,y)*df(h2,z)*h2  *h3

                                 -1   -1   -1
           + df(ay,z)*df(h1,y)*h1  *h2  *h3

                                 -1   -2                -2
           + df(ay,z)*df(h3,y)*h2  *h3   + df(az,z,2)*h3

                                 -1   -2                       -1   -2
           + df(az,z)*df(h1,z)*h1  *h3   + df(az,z)*df(h2,z)*h2  *h3

                                 -3                   -1   -1   -1
           - df(az,z)*df(h3,z)*h3   + df(h1,y,z)*ay*h1  *h2  *h3

                                    -2   -1   -1
           - df(h1,y)*df(h1,z)*ay*h1  *h2  *h3

                                    -1   -2   -1
           - df(h1,y)*df(h2,z)*ay*h1  *h2  *h3

                             -1   -2           2      -2   -2
           + df(h1,z,2)*az*h1  *h3   - df(h1,z) *az*h1  *h3

                                    -2   -1   -1
           - df(h1,z)*df(h2,x)*ax*h1  *h2  *h3

                                    -2   -2
           - df(h1,z)*df(h3,x)*ax*h1  *h3

                                    -1   -3
           - df(h1,z)*df(h3,z)*az*h1  *h3

                             -1   -1   -1
           + df(h2,x,z)*ax*h1  *h2  *h3

                                    -1   -2   -1
           - df(h2,x)*df(h2,z)*ax*h1  *h2  *h3

                             -1   -2           2      -2   -2
           + df(h2,z,2)*az*h2  *h3   - df(h2,z) *az*h2  *h3

                                    -2   -2
           - df(h2,z)*df(h3,y)*ay*h2  *h3

                                    -1   -3                   -1   -2
           - df(h2,z)*df(h3,z)*az*h2  *h3   + df(h3,x,z)*ax*h1  *h3

                                    -1   -3                   -1   -2
           - df(h3,x)*df(h3,z)*ax*h1  *h3   + df(h3,y,z)*ay*h2  *h3

                                    -1   -3
           - df(h3,y)*df(h3,z)*ay*h2  *h3


div curl a;


0


% Examples of integration : (1) Volume integrals

getcsystem 'spherical;


(r theta phi)


% Example 1 : integration of r**n over a sphere

origin := avec(0,0,0);


vec(r) := 0

vec(theta) := 0

vec(phi) := 0


upperbound := avec(rr,pi,2*pi);


vec(r) := rr

vec(theta) := pi

vec(phi) := 2*pi


volintegral(r**n,origin,upperbound);


     n      3
 4*rr *pi*rr
--------------
    n + 3


% Substitute n=0 to get the volume of a sphere
sub(n=0,ws);


 4       3
---*pi*rr
 3


% Example 2 : volume of a right-circular cone

getcsystem 'cylindrical;


(r z phi)

upperbound := avec(pp*z,h,2*pi);


vec(r) := pp*z

vec(z) := h

vec(phi) := 2*pi


volintorder := avec(2,0,1);


vec(r) := 2

vec(z) := 0

vec(phi) := 1

      % Integrate in the order : phi, r, z
cone := volintegral(1,origin,upperbound);


         1   3      2
cone := ---*h *pi*pp
         3


% Now we replace P*Z by RR to get the result in the familiar form

let pp*h=rr;


cone := cone;


         1         2
cone := ---*h*pi*rr
         3
                    % This is the familiar form
clear pp*h;



% Example 3 : line integral to obtain the length of a line of latitude
%             on a sphere

getcsystem 'spherical;


(r theta phi)


a := avec(0,0,1);


vec(r) := 0

vec(theta) := 0

vec(phi) := 1

            % Function vector is the tangent to the
			     % line of latitude
curve := avec(rr,latitude,phi);


vec(r) := rr

vec(theta) := latitude

vec(phi) := phi

   % Path is round a line of latitude

deflineint(a,curve,phi,0,2*pi);


2*sin(latitude)*pi*rr


end;


Time for test: 62 ms
@@@@@ Resources used: (0 0 35 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/avector/avector.tex0000644000175000017500000003341211526203062024337 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\date{}
\title{A Vector Algebra and Calculus Package for REDUCE}
\author{David Harper \\
Astronomy Unit \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road \\
London E1 4NS \\
England \\[0.05in]
Electronic mail: {\it adh@star.qmw.ac.uk}}
\begin{document}
\maketitle

\index{AVECTOR package}

\section{Introduction}

This package \footnote{Reference: Computer Physics Communications,
{\bf 54}, 295-305 (1989)}
is written in RLISP (the LISP meta-language) and is
intended for use with REDUCE 3.4. \index{vector algebra} It provides
REDUCE with the ability to perform vector algebra using the same
notation as scalar algebra.  The basic algebraic operations are
supported, as are differentiation and integration of vectors with
respect to scalar variables, cross product and dot product, component
manipulation and application of scalar functions ({\em e.g.} cosine)
to a vector to yield a vector result.

A set of vector calculus operators are provided for use with any
orthogonal curvilinear coordinate system. These operators are
gradient, divergence, curl and del-squared (Laplacian).  The Laplacian
operator can take scalar or vector arguments.

Several important coordinate systems are pre-defined and can be
invoked by name. It is also possible to create new coordinate systems
by specifying the names of the coordinates and the values of the scale
factors.

\section{Vector declaration and initialisation}

Any name may be declared to be a vector, provided that it has
not previously been declared as a matrix or an array. To
declare a list of names to be vectors use the VEC command:
\index{VEC command}
\begin{verbatim}
   VEC A,B,C;
\end{verbatim}
declares the variables {\tt A}, {\tt B} and {\tt C} to be vectors.
If they have already been assigned (scalar) values, these will be lost.

When a vector is declared using the {\tt VEC} command, it does not
have an initial value.

If a vector value is assigned to a scalar variable, then that
variable will automatically be declared as a vector and the
user will be notified that this has happened.

\index{AVEC function}
A vector may be initialised using the {\tt AVEC} function which
takes three scalar arguments and returns a vector made up
from those scalars. For example
\begin{verbatim}
   A := AVEC(A1, A2, A3);
\end{verbatim}
sets the components of the vector {\tt A} to {\tt A1}, {\tt A2} and {\tt A3}.

\section{Vector algebra}

(In the examples which follow, {\tt V}, {\tt V1}, {\tt V2} {\em etc}
are assumed to be vectors while {\tt S}, {\tt S1}, {\tt S2} etc are scalars.)

\index{+ ! vector} \index{- ! vector} \index{* ! vector} \index{/ ! vector}
The scalar algebra operators +,-,* and / may be used with
vector operands according to the rules of vector algebra.
Thus multiplication and division of a vector by a scalar
are both allowed, but it is an error to multiply or
divide one vector by another.

\begin{tabular}{l l}
{\tt V := V1 + V2 - V3;} & Addition and subtraction \\
{\tt V := S1*3*V1;} & Scalar multiplication \\
{\tt V := V1/S;} & Scalar division \\
{\tt V := -V1;} & Negation \\
\end{tabular}

\index{DOT ! vector} \index{Dot product} \index{CROSS ! vector}
\index{cross product}
\noindent Vector multiplication is carried out using the infix
operators {\tt DOT} and {\tt CROSS}. These are defined to have
higher precedence than scalar multiplication and
division.

\begin{tabular}{l l}
{\tt V := V1 CROSS V2;} & Cross product \\
{\tt S := V1 DOT V2;} & Dot product \\
{\tt V := V1 CROSS V2 + V3;} & \\
{\tt V := (V1 CROSS V2) + V3;} & \\
\end{tabular}

The last two expressions are equivalent due to the precedence of
the {\tt CROSS} operator.

\index{VMOD operator}
The modulus of a vector may be calculated using the {\tt VMOD} operator.

\begin{verbatim}
   S := VMOD V;
\end{verbatim}

A unit vector may be generated from any vector using the {\tt VMOD}
operator.

\begin{verbatim}
   V1 := V/(VMOD V);
\end{verbatim}

Components may be extracted from any vector using index notation
in the same way as an array.

\begin{tabular}{l l}
{\tt V := AVEC(AX, AY, AZ);} & \\
{\tt V(0);} & yields AX \\
{\tt V(1);} & yields AY \\
{\tt V(2);} & yields AZ \\
\end{tabular}

It is also possible to set values of individual components. Following
from above:

\begin{verbatim}
   V(1) := B;
\end{verbatim}

The vector {\tt V} now has components {\tt AX}, {\tt B}, {\tt AZ}.

\index{vector ! differentiation} \index{vector ! integration}
\index{differentiation ! vector} \index{differentiation ! vector}
Vectors may be used as arguments in the differentiation and
integration routines in place of the dependent expression.

\begin{tabular}{l l}
{\tt V := AVEC(X**2, SIN(X), Y);} & \\
{\tt DF(V,X);} & yields (2*X, COS(X), 0) \\
{\tt INT(V,X);} & yields (X**3/3, -COS(X), Y*X) \\
\end{tabular}

Vectors may be given as arguments to monomial functions such as {\tt
SIN}, {\tt LOG} and {\tt TAN}. The result is a vector obtained by
applying the function component-wise to the argument vector.

\begin{tabular}{l l}
{\tt V := AVEC(A1, A2, A3);} & \\
{\tt SIN(V);} & yields (SIN(A1), SIN(A2), SIN(A3)) \\
\end{tabular}

\section{ Vector calculus}

\index{DIV ! operator} \index{divergence ! vector field}
\index{GRAD ! operator} \index{gradient ! vector field}
\index{CURL ! operator} \index{curl ! vector field}
\index{DELSQ ! operator} \index{Laplacian ! vector field}
The vector calculus operators div, grad and curl are recognised.
The Laplacian operator is also available and may be applied to
scalar and vector arguments.

\begin{tabular}{l l}
{\tt V := GRAD S;} & Gradient of a scalar field \\
{\tt S := DIV V;} & Divergence of a vector field \\
{\tt V := CURL V1;} & Curl of a vector field \\
{\tt S := DELSQ S1;} & Laplacian of a scalar field \\
{\tt V := DELSQ V1;} & Laplacian of a vector field \\
\end{tabular}

These operators may be used in any orthogonal curvilinear coordinate
system. The user may alter the names of the coordinates and the values
of the scale factors. Initially the coordinates are {\tt X}, {\tt Y}
and {\tt Z} and the scale factors are all unity.

\index{COORDS vector} \index{HFACTORS scale factors}
There are two special vectors : {\tt COORDS} contains the names
of the coordinates in the current system and {\tt HFACTORS}
contains the values of the scale factors.

\index{COORDINATES operator}
The coordinate names may be changed using the {\tt COORDINATES}
operator.

\begin{verbatim}
   COORDINATES R,THETA,PHI;
\end{verbatim}

This command changes the coordinate names to {\tt R}, {\tt THETA} and
{\tt PHI}.

\index{SCALEFACTORS operator}
The scale factors may be altered using the {\tt SCALEFACTORS} operator.

\begin{verbatim}
   SCALEFACTORS(1,R,R*SIN(THETA));
\end{verbatim}

This command changes the scale factors to {\tt 1}, {\tt R} and {\tt R
SIN(THETA)}.

Note that the arguments of {\tt SCALEFACTORS} must be enclosed in
parentheses. This is not necessary with {\tt COORDINATES}.


When vector differential operators are applied to an expression,
the current set of coordinates are used as the independent
variables and the scale factors are employed in the calculation.
(See, for example, Batchelor G.K. 'An Introduction to Fluid
Mechanics', Appendix 2.)


\index{"!*CSYSTEMS global (AVECTOR)}
Several coordinate systems are pre-defined and may be invoked by
name. To see a list of valid names enter

\begin{verbatim}
   SYMBOLIC !*CSYSTEMS;
\end{verbatim}

and REDUCE will respond with something like

\begin{verbatim}
   (CARTESIAN SPHERICAL CYLINDRICAL)
\end{verbatim}

\index{GETCSYSTEM command}
To choose a coordinate system by name, use the command {\tt GETCSYSTEM}.

To choose the Cartesian coordinate system :
\begin{verbatim}
   GETCSYSTEM 'CARTESIAN;
\end{verbatim}
\index{PUTCSYSTEM command}

Note the quote which prefixes the name of the coordinate system. This
is required because {\tt GETCSYSTEM} (and its complement {\tt
PUTCSYSTEM}) is a {\tt SYMBOLIC} procedure which requires a literal
argument.

REDUCE responds by typing a list of the coordinate names in that
coordinate system. The example above would produce the response

\begin{verbatim}
   (X Y Z)
\end{verbatim}

whilst

\begin{verbatim}
   GETCSYSTEM 'SPHERICAL;
\end{verbatim}

would produce

\begin{verbatim}
   (R THETA PHI)
\end{verbatim}

Note that any attempt to invoke a coordinate system is subject to the
same restrictions as the implied calls to {\tt COORDINATES} and {\tt
SCALEFACTORS}.  In particular, {\tt GETCSYSTEM} fails if any of the
coordinate names has been assigned a value and the previous coordinate
system remains in effect.

A user-defined coordinate system can be assigned a name using the
command {\tt PUTCSYSTEM}. It may then be re-invoked at a later stage using
{\tt GETCSYSTEM}.

\example\index{AVECTOR package ! example}

We define a general coordinate system with coordinate names {\tt
X},{\tt Y},{\tt Z} and scale factors {\tt H1},{\tt H2},{\tt H3} :

\begin{verbatim}
   COORDINATES X,Y,Z;
   SCALEFACTORS(H1,H2,H3);
   PUTCSYSTEM 'GENERAL;
\end{verbatim}

This system may later be invoked by entering

\begin{verbatim}
   GETCSYSTEM 'GENERAL;
\end{verbatim}

\section{Volume and Line Integration}

Several functions are provided to perform volume and line integrals.
These operate in any orthogonal curvilinear coordinate system and
make use of the scale factors described in the previous section.


Definite integrals of scalar and vector expressions may be calculated
using the {\tt DEFINT} function.

\example\index{AVECTOR package ! example}

\index{DEFINT function} \index{integration ! definite (simple)}
\index{definite integration (simple)}
\noindent To calculate the definite integral of $\sin(x)^2$ between 0 and
2$\pi$ we enter

\begin{verbatim}
   DEFINT(SIN(X)**2,X,0,2*PI);
\end{verbatim}

This function is a simple extension of the {\tt INT} function taking
two extra arguments, the lower and upper bounds of integration
respectively.

\index{VOLINTEGRAL function} \index{integration ! volume}
Definite volume integrals may be calculated using the {\tt
VOLINTEGRAL} function whose syntax is as follows :

\noindent {\tt VOLINTEGRAL}({\tt integrand}, vector {\tt lower-bound},
vector {\tt upper-bound});

\example\index{AVECTOR package ! example}

\noindent In spherical polar coordinates we may calculate the volume of a
sphere by integrating unity over the range $r$=0 to {\tt RR}, $\theta$=0 to
{\tt PI}, $\phi$=0 to 2*$\pi$ as follows :

\begin{tabular}{l l}
{\tt VLB := AVEC(0,0,0);} & Lower bound \\
{\tt VUB := AVEC(RR,PI,2*PI);} & Upper bound in $r, \theta, \phi$
 respectively \\
{\tt VOLINTORDER := (0,1,2);} & The order of integration \\
{\tt VOLINTEGRAL(1,VLB,VUB);} & \\
\end{tabular}

\index{VOLINTORDER vector}
Note the use of the special vector {\tt VOLINTORDER} which controls
the order in which the integrations are carried out. This vector
should be set to contain the number 0, 1 and 2 in the required order.
The first component of {\tt VOLINTORDER} contains the index of the
first integration variable, the second component is the index of the
second integration variable and the third component is the index of
the third integration variable.

\example\index{AVECTOR package ! example}

Suppose we wish to calculate the volume of a right circular cone. This
is equivalent to integrating unity over a conical region with the
bounds:

\begin{tabular}{l l}
z = 0 to H  & (H = the height of the cone) \\
r = 0 to pZ & (p = ratio of base diameter to height) \\
phi = 0 to 2*PI & \\
\end{tabular}

We evaluate the volume by integrating a series of infinitesimally thin
circular disks of constant z-value. The integration is thus performed
in the order : d($\phi$) from 0 to $2\pi$, dr from 0 to p*Z, dz from 0 to H.
The order of the indices is thus 2, 0, 1.

\begin{verbatim}
   VOLINTORDER := AVEC(2,0,1);
   VLB := AVEC(0,0,0);
   VUB := AVEC(P*Z,H,2*PI);
   VOLINTEGRAL(1,VLB,VUB);
\end{verbatim}

(At this stage, we replace {\tt P*H} by {\tt RR}, the base radius of the cone,
to obtain the result in its more familiar form.)


\index{LINEINT function} \index{DEFLINEINT function}
\index{integration ! line} \index{line integrals}
Line integrals may be calculated using the {\tt LINEINT} and {\tt DEFLINEINT}
functions. Their general syntax is

\noindent {\tt LINEINT}({\tt vector-function}, {\tt vector-curve},
{\tt variable});

\noindent{\tt DEFLINENINT}({\tt vector-function}, {\tt vector-curve},
{\tt variable}, {\tt lower-bound}, {\tt upper-bound});

\noindent where
\begin{description}
\item[{\tt vector-function}] is any vector-valued expression;
\item[{\tt vector-curve}] is a vector expression which describes the path of
integration in terms of the independent variable;
\item[{\tt variable}] is the independent variable;
\item[{\tt lower-bound}]
\item[{\tt upper-bound}] are the bounds of integration in terms of the
independent variable.
\end{description}

\example\index{AVECTOR package ! example}

In spherical polar coordinates, we may integrate round a line of
constant theta (`latitude') to find the length of such a line. The
vector function is thus the tangent to the `line of latitude', (0,0,1)
and the path is {\tt (0,LAT,PHI)} where {\tt PHI} is the independent
variable. We show how to obtain the definite integral {\em i.e.} from
$\phi=0$ to $2 \pi$ :
\begin{verbatim}
DEFLINEINT(AVEC(0,0,1),AVEC(0,LAT,PHI),PHI,0,2*PI);
\end{verbatim}

\section{Defining new functions and procedures}

Most of the procedures in this package are defined in symbolic mode
and are invoked by the REDUCE expression-evaluator when a vector
expression is encountered. It is not generally possible to define
procedures which accept or return vector values in algebraic mode.
This is a consequence of the way in which the REDUCE interpreter
operates and it affects other non-scalar data types as well : arrays
cannot be passed as algebraic procedure arguments, for example.

\section{Acknowledgements}

This package was written whilst the author was the U.K. Computer
Algebra Support Officer at the University of Liverpool Computer Laboratory.
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/avector/avector.hlp0000644000175000017500000003042011526203062024316 0ustar  giovannigiovanni\chapter[AVECTOR: Vector Algebra]%
        {AVECTOR: A vector algebra and calculus package}
\label{AVECTOR}
\typeout{{AVECTOR: Vector Algebra}}

{\footnotesize
\begin{center}
David Harper \\
Astronomy Unit, Queen Mary and Westfield College \\
University of London \\
Mile End Road \\
London E1 4NS, England \\[0.05in]
e--mail: adh@star.qmw.ac.uk
\end{center}
}
\ttindex{AVECTOR}

This package provides \REDUCE\ with the ability to perform vector
algebra using the same notation as scalar algebra.  The basic
algebraic operations are supported, as are differentiation and
integration of vectors with respect to scalar variables, cross product
and dot product, component manipulation and application of scalar
functions ({\em e.g.} cosine) to a vector to yield a vector result.

\section{Vector declaration and initialisation}

To declare a list of names to be vectors use the VEC command:
\index{VEC command}
\begin{verbatim}
   VEC A,B,C;
\end{verbatim}
declares the variables {\tt A}, {\tt B} and {\tt C} to be vectors.
If they have already been assigned (scalar) values, these will be lost.

When a vector is declared using the {\tt VEC} command, it does not
have an initial value.

If a vector value is assigned to a scalar variable, then that
variable will automatically be declared as a vector and the
user will be notified that this has happened.

\index{AVEC function}
A vector may be initialised using the {\tt AVEC} function which
takes three scalar arguments and returns a vector made up
from those scalars. For example
\begin{verbatim}
   A := AVEC(A1, A2, A3);
\end{verbatim}
sets the components of the vector {\tt A} to {\tt A1}, {\tt A2} and
{\tt A3}. 

\section{Vector algebra}

(In the examples which follow, {\tt V}, {\tt V1}, {\tt V2} {\em etc}
are assumed to be vectors while {\tt S}, {\tt S1}, {\tt S2} etc are
scalars.) 

\index{+ ! vector}\index{- ! vector}\index{* ! vector}\index{/ ! vector}
The scalar algebra operators +,-,* and / may be used with
vector operands according to the rules of vector algebra.
Thus multiplication and division of a vector by a scalar
are both allowed, but it is an error to multiply or
divide one vector by another.

\begin{tabular}{l l}
{\tt V := V1 + V2 - V3;} & Addition and subtraction \\
{\tt V := S1*3*V1;} & Scalar multiplication \\
{\tt V := V1/S;} & Scalar division \\
{\tt V := -V1;} & Negation \\
\end{tabular}

\index{DOT ! vector}\index{Dot product}\index{CROSS ! vector}
\index{cross product}
\noindent Vector multiplication is carried out using the infix
operators {\tt DOT} and {\tt CROSS}.  These are defined to have
higher precedence than scalar multiplication and
division.

\begin{tabular}{l l}
{\tt V := V1 CROSS V2;} & Cross product \\
{\tt S := V1 DOT V2;} & Dot product \\
{\tt V := V1 CROSS V2 + V3;} & \\
{\tt V := (V1 CROSS V2) + V3;} & \\
\end{tabular}

The last two expressions are equivalent due to the precedence of
the {\tt CROSS} operator.

\index{VMOD operator}
The modulus of a vector may be calculated using the {\tt VMOD} operator.

\begin{verbatim}
   S := VMOD V;
\end{verbatim}

A unit vector may be generated from any vector using the {\tt VMOD}
operator.

\begin{verbatim}
   V1 := V/(VMOD V);
\end{verbatim}

Components may be extracted from any vector using index notation
in the same way as an array.

\begin{tabular}{l l}
{\tt V := AVEC(AX, AY, AZ);} & \\
{\tt V(0);} & yields AX \\
{\tt V(1);} & yields AY \\
{\tt V(2);} & yields AZ \\
\end{tabular}

It is also possible to set values of individual components. Following
from above:

\begin{verbatim}
   V(1) := B;
\end{verbatim}

The vector {\tt V} now has components {\tt AX}, {\tt B}, {\tt AZ}.

\index{vector ! differentiation}
\index{vector ! integration}
\index{differentiation ! vector}
\index{differentiation ! vector}
Vectors may be used as arguments in the differentiation and
integration routines in place of the dependent expression.

\begin{tabular}{l l}
{\tt V := AVEC(X**2, SIN(X), Y);} & \\
{\tt DF(V,X);} & yields (2*X, COS(X), 0) \\
{\tt INT(V,X);} & yields (X**3/3, -COS(X), Y*X) \\
\end{tabular}

Vectors may be given as arguments to monomial functions such as {\tt
SIN}, {\tt LOG} and {\tt TAN}. The result is a vector obtained by
applying the function component-wise to the argument vector.

\begin{tabular}{l l}
{\tt V := AVEC(A1, A2, A3);} & \\
{\tt SIN(V);} & yields (SIN(A1), SIN(A2), SIN(A3)) \\
\end{tabular}

\section{Vector calculus}

\index{DIV ! operator}\index{divergence ! vector field}
\index{GRAD ! operator}\index{gradient ! vector field}
\index{CURL ! operator}\index{curl ! vector field}
\index{DELSQ ! operator}\index{Laplacian ! vector field}
The vector calculus operators div, grad and curl are recognised.
The Laplacian operator is also available and may be applied to
scalar and vector arguments.

\begin{tabular}{l l}
{\tt V := GRAD S;} & Gradient of a scalar field \\
{\tt S := DIV V;} & Divergence of a vector field \\
{\tt V := CURL V1;} & Curl of a vector field \\
{\tt S := DELSQ S1;} & Laplacian of a scalar field \\
{\tt V := DELSQ V1;} & Laplacian of a vector field \\
\end{tabular}

These operators may be used in any orthogonal curvilinear coordinate
system. The user may alter the names of the coordinates and the values
of the scale factors. Initially the coordinates are {\tt X}, {\tt Y}
and {\tt Z} and the scale factors are all unity.

\index{COORDS vector}\index{HFACTORS scale factors}
There are two special vectors : {\tt COORDS} contains the names
of the coordinates in the current system and {\tt HFACTORS}
contains the values of the scale factors.

\index{COORDINATES operator}
The coordinate names may be changed using the {\tt COORDINATES}
operator.

\begin{verbatim}
   COORDINATES R,THETA,PHI;
\end{verbatim}

This command changes the coordinate names to {\tt R}, {\tt THETA} and
{\tt PHI}.

\index{SCALEFACTORS operator}
The scale factors may be altered using the {\tt SCALEFACTORS} operator.

\begin{verbatim}
   SCALEFACTORS(1,R,R*SIN(THETA));
\end{verbatim}

This command changes the scale factors to {\tt 1}, {\tt R} and {\tt R
SIN(THETA)}.

Note that the arguments of {\tt SCALEFACTORS} must be enclosed in
parentheses. This is not necessary with {\tt COORDINATES}.


When vector differential operators are applied to an expression,
the current set of coordinates are used as the independent
variables and the scale factors are employed in the calculation.
%%(See, for example, Batchelor G.K. 'An Introduction to Fluid
%%Mechanics', Appendix 2.)


\index{"!*CSYSTEMS global (AVECTOR)}
Several coordinate systems are pre-defined and may be invoked by
name. To see a list of valid names enter

\begin{verbatim}
   SYMBOLIC !*CSYSTEMS;
\end{verbatim}

and \REDUCE\ will respond with something like

\begin{verbatim}
   (CARTESIAN SPHERICAL CYLINDRICAL)
\end{verbatim}

\index{GETCSYSTEM command}
To choose a coordinate system by name, use the command {\tt GETCSYSTEM}.

To choose the Cartesian coordinate system :
\begin{verbatim}
   GETCSYSTEM 'CARTESIAN;
\end{verbatim}
\index{PUTCSYSTEM command}

Note the quote which prefixes the name of the coordinate system. This
is required because {\tt GETCSYSTEM} (and its complement {\tt
PUTCSYSTEM}) is a {\tt SYMBOLIC} procedure which requires a literal
argument.

\REDUCE\ responds by typing a list of the coordinate names in that
coordinate system. The example above would produce the response

\begin{verbatim}
   (X Y Z)
\end{verbatim}

whilst

\begin{verbatim}
   GETCSYSTEM 'SPHERICAL;
\end{verbatim}

would produce

\begin{verbatim}
   (R THETA PHI)
\end{verbatim}

Note that any attempt to invoke a coordinate system is subject to the
same restrictions as the implied calls to {\tt COORDINATES} and {\tt
SCALEFACTORS}.  In particular, {\tt GETCSYSTEM} fails if any of the
coordinate names has been assigned a value and the previous coordinate
system remains in effect.

A user-defined coordinate system can be assigned a name using the
command {\tt PUTCSYSTEM}. It may then be re-invoked at a later stage using
{\tt GETCSYSTEM}.

\example\index{AVECTOR package ! example}

We define a general coordinate system with coordinate names {\tt
X},{\tt Y},{\tt Z} and scale factors {\tt H1},{\tt H2},{\tt H3} :

\begin{verbatim}
   COORDINATES X,Y,Z;
   SCALEFACTORS(H1,H2,H3);
   PUTCSYSTEM 'GENERAL;
\end{verbatim}

This system may later be invoked by entering

\begin{verbatim}
   GETCSYSTEM 'GENERAL;
\end{verbatim}

\section{Volume and Line Integration}

Several functions are provided to perform volume and line integrals.
These operate in any orthogonal curvilinear coordinate system and
make use of the scale factors described in the previous section.

Definite integrals of scalar and vector expressions may be calculated
using the {\tt DEFINT} function\footnote{Not to be confused with the
DEFINT package described in chapter~\ref{DEFINT}}.

\example\index{AVECTOR package ! example}

\index{DEFINT function}\index{integration ! definite (simple)}
\index{definite integration (simple)}
\noindent To calculate the definite integral of $\sin(x)^2$ between 0 and
2$\pi$ we enter

\begin{verbatim}
   DEFINT(SIN(X)**2,X,0,2*PI);
\end{verbatim}

This function is a simple extension of the {\tt INT} function taking
two extra arguments, the lower and upper bounds of integration
respectively.

\index{VOLINTEGRAL function}\index{integration ! volume}
Definite volume integrals may be calculated using the {\tt
VOLINTEGRAL} function whose syntax is as follows :

\noindent {\tt VOLINTEGRAL}({\tt integrand}, vector {\tt lower-bound},
vector {\tt upper-bound});

\example\index{AVECTOR package ! example}

\noindent In spherical polar coordinates we may calculate the volume of a
sphere by integrating unity over the range $r$=0 to {\tt RR}, $\theta$=0 to
{\tt PI}, $\phi$=0 to 2*$\pi$ as follows :

\begin{tabular}{l l}
{\tt VLB := AVEC(0,0,0);} & Lower bound \\
{\tt VUB := AVEC(RR,PI,2*PI);} & Upper bound in $r, \theta, \phi$
 respectively \\
{\tt VOLINTORDER := (0,1,2);} & The order of integration \\
{\tt VOLINTEGRAL(1,VLB,VUB);} & \\
\end{tabular}

\index{VOLINTORDER vector}
Note the use of the special vector {\tt VOLINTORDER} which controls
the order in which the integrations are carried out. This vector
should be set to contain the number 0, 1 and 2 in the required order.
The first component of {\tt VOLINTORDER} contains the index of the
first integration variable, the second component is the index of the
second integration variable and the third component is the index of
the third integration variable.

\example\index{AVECTOR package ! example}

Suppose we wish to calculate the volume of a right circular cone. This
is equivalent to integrating unity over a conical region with the
bounds:

\begin{tabular}{l l}
z = 0 to H  & (H = the height of the cone) \\
r = 0 to pZ & (p = ratio of base diameter to height) \\
phi = 0 to 2*PI & \\
\end{tabular}

We evaluate the volume by integrating a series of infinitesimally thin
circular disks of constant z-value. The integration is thus performed
in the order : d($\phi$) from 0 to $2\pi$, dr from 0 to p*Z, dz from 0 to H.
The order of the indices is thus 2, 0, 1.

\begin{verbatim}
   VOLINTORDER := AVEC(2,0,1);
   VLB := AVEC(0,0,0);
   VUB := AVEC(P*Z,H,2*PI);
   VOLINTEGRAL(1,VLB,VUB);
\end{verbatim}

\index{LINEINT function}\index{DEFLINEINT function}
\index{integration ! line}\index{line integrals}
Line integrals may be calculated using the {\tt LINEINT} and {\tt DEFLINEINT}
functions. Their general syntax is

\noindent {\tt LINEINT}({\tt vector-fnct}, {\tt vector-curve},
{\tt variable});

\noindent{\tt DEFLINENINT}({\tt vector-fnct}, {\tt vector-curve},
{\tt variable}, {\tt lower-bnd}, {\tt upper-bnd});

\noindent where
\begin{description}
\item[{\tt vector-fnct}] is any vector-valued expression;
\item[{\tt vector-curve}] is a vector expression which describes the path of
integration in terms of the independent variable;
\item[{\tt variable}] is the independent variable;
\item[{\tt lower-bnd}]
\item[{\tt upper-bnd}] are the bounds of integration in terms of the
independent variable.
\end{description}

\example\index{AVECTOR package ! example}

In spherical polar coordinates, we may integrate round a line of
constant theta (`latitude') to find the length of such a line. The
vector function is thus the tangent to the `line of latitude', (0,0,1)
and the path is {\tt (0,LAT,PHI)} where {\tt PHI} is the independent
variable. We show how to obtain the definite integral {\em i.e.} from
$\phi=0$ to $2 \pi$ :
\begin{verbatim}
DEFLINEINT(AVEC(0,0,1),AVEC(0,LAT,PHI),PHI,0,2*PI);
\end{verbatim}

mathpiper-0.81f+svn4469+dfsg3/src/packages/avector/avector.red0000644000175000017500000010455611526203062024321 0ustar  giovannigiovannimodule avector;   % Vector algebra and calculus package.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(avector),'(contrib avector));

global '(avector!-loaded!*);

avector!-loaded!* := t;   % To keep CSL happy.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
%   Copyright notice                                                   %
%   ----------------                                                   %
%                                                                      %
%              Author : David Harper                                   %
%                       Computer Laboratory,                           %
%                       University of Liverpool                        %
%                       P.O. Box 147                                   %
%                       Liverpool L69 3BX                              %
%                       ENGLAND                                        %
%                                                                      %
%                       (adh@maths.qmw.ac.uk)                          %
%                                                                      %
%              Date   : 29 February 1988                               %
%                                                                      %
%              Title  : Vector algebra and calculus package            %
%                                                                      %
%       Copyright (c) David Harper 1988                                %
%                                                                      %
%                                                                      %
% (note that David Harper has given explicit permission to remove a    %
%  previous licensing statement in favour of use of the BSD terms      %
%  shown above)                                                        %
%                                                                      %
%   End of copyright notice                                            %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  ***************  This code is designed to operate  ***************  %
%  ***************  with version 3.4 of REDUCE and    ***************  %
%  ***************  the Standard Lisp interpreter.    ***************  %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
%              VECTOR DECLARATIONS MODULE                              %
%                                                                      %
%  This section contains the routines required to interface the        %
%  vector package to REDUCE. The most important routine is the         %
%  vector predicate function VECP which tests an expression to         %
%  determine whether it must be evaluated using the  routine           %
%  VECSM*.                                                             %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


fluid '(!*coords !*csystems !*vectorfunctionlist
        !*vtrace !*vectortracelevel!*);

switch vtrace;

symbolic procedure vecp u;
begin scalar x;
return
  if null u or numberp u then nil
  else if atom u then (get(u,'rtype)='!3vector or threevectorp u)
  else if threevectorp u then t
  else if (atom(x:=car u) and get(x,'rtype)='!3vector)
                            then isvectorindex cadr u
  else if flagp(x,'vectorfn) then t
  else if (flagp(x,'varithop) or flagp(x,'vectormapping))
                            then hasonevector cdr u
  else nil;
 end;

% The following procedure checks for a vector with three components

symbolic procedure threevectorp u;
  vectorp u and (upbv u = 2);

% The following procedure checks to ensure that the arg list contains
% at least one vector
symbolic procedure hasonevector u;
  if null u then nil
    else (vecp car u) or (hasonevector cdr u);

% The following procedure checks that the arg list consists entirely
% of vectors
symbolic procedure areallvectors u;
  if null u then nil
  else if null cdr u then vecp car u
  else (vecp car u) and (areallvectors cdr u);

% The following function checks to see whether its argument is a valid
% vector index i.e. whether it evaluates to an integer 0,1 or 2 or
% is equal to one of the coordinate names
symbolic procedure isvectorindex u;
  not null getvectorindex(u,t);

% The following function evaluates its argument to a vector index
% or NIL if it isn't an integer 0,1 or 2 or one of the coordinate
% names. Set FLG to true if hard-error is required for invalid
% argument.
symbolic procedure getvectorindex(u,flg);
  begin scalar vindx;
  vindx := u;
  if not fixp vindx then vindx:=locate(vindx,!*coords);
  if ((null vindx) or (fixp vindx and (vindx<0 or vindx>2)))
    and flg then rerror(avector,1,list(u,"not a valid vector index"));
  return vindx
  end;

% This routine gives the position of an object in a list. The first
% object is numbered zero. Returns NIL if the object can't be found.

symbolic procedure locate(u,v);
  if not (u memq v) then nil
  else if u=car v then 0
  else 1+locate(u,cdr v);

% We may as well define some utility operators here too.
symbolic smacro procedure first u; car u;
symbolic smacro procedure second u; cadr u;
symbolic smacro procedure third u; caddr u;

% Here we redefine getrtype1 and getrtype2 to handle vectors.

remflag('(getrtype1 getrtype2),'lose);  % We must use these definitions.

symbolic procedure getrtype1 u;
   if threevectorp u then '!3vector else nil;

symbolic procedure getrtype2 u;
   begin scalar x;
     % Next line is maybe only needed by EXCALC.
      return if vecp u then '!3vector
              else if (x:= get(car u,'rtype)) and (x:= get(x,'rtypefn))
               then apply1(x,cdr u)
              else if x := get(car u,'rtypefn) then apply1(x,cdr u)
              else nil
   end;

% The following function declares a list of objects as vectors.

symbolic procedure vec u;
  begin scalar y;
  for each x in u do
  << % Check that the identifier is not already declared as an array
     % or matrix or function
    if not atom x then write("Cannot declare ",x," as a vector")
    else
    << y := gettype x;
       if y memq '(array procedure matrix operator) then
         write("Object ",x," has already been declared as ",y)
       else makenewvector x
    >>;
  >>;
  return nil
  end;

deflist('((vec rlis)),'stat);

% This procedure actually creates a vector.

symbolic procedure makenewvector u;
  begin
%   write("Declaring ",U," a vector");terpri();
    put(u,'rtype,'!3vector);
    put(u,'avalue,list('vector,mkvect(2)));
    return nil
  end;


% Vector function declarations : these are the routines that link
% our new data type into the REDUCE system.

  put('!3vector,'letfn,'veclet);           % Assignment routine
  put('!3vector,'name,'!3vector);          % Our name for the data type
  put('!3vector,'evfn,'!*vecsm!*);         % Evaluation function
  put('!3vector,'prifn,'vecpri!*);         % Printing function
  flag('(!3vector),'sprifn);

  symbolic procedure vecpri!*(u,v,w);
    vecpri(u,v);

% The following routine prints out a vector in a neat way (cf.
% the way in which matrices are printed !)

  symbolic procedure vecpri(u,x);
  begin scalar y,v0,v1,v2,xx;
  y:= if vectorp u then u else getavalue u;
    xx := x;
    if null y then return nil;
%   if null x then xx := 'vec;
    xx := 'vec;
    v0 := getv(y,0);
    v1 := getv(y,1);
    v2 := getv(y,2);
    v0 := aeval v0; v1 := aeval v1; v2 := aeval v2;
    assgnpri(v0,list list(xx,first !*coords),'only);
    assgnpri(v1,list list(xx,second !*coords),'only);
    assgnpri(v2,list list(xx,third !*coords),'only);
    terpri!* t;
  end;

symbolic procedure getavalue u;
   (if x then cadr x else nil) where x=get(u,'avalue);

symbolic procedure indexedvectorp u;
  (vecp car u) and (isvectorindex cadr u);

put('!3vector,'setelemfn,'setvectorelement);

% The following function sets one element of a vector object

symbolic procedure setvectorelement(u,v);
  begin scalar vindx;
  vindx := getvectorindex(cadr u,t);
  putv(getavalue car u,vindx,v);
  return nil
  end;

% If SETK is invoked with an vector atom as its first argument, then
% control will be passed to the routine VECLET

symbolic procedure veclet(u,v,utype,b,vtype);
  begin
  if zerop v then return setvectortozero(u,utype);
  if not equal(vtype,'!3vector)
    then rerror(avector,2,"RHS is not a vector");
  if equal(utype,'!3vector) then put(u,'avalue,list('!3vector,v))
  else if utype memq '(array matrix) then
    rerror(avector,3,list(u,"already defined as ",utype))
  else
  << % We force U to be a vector
     vec u;
     write("*** ",u," re-defined as vector"); terpri();
     put(u,'avalue,list('vector,v))
  >>;
  return v
  end;

% A quick and dirty way of declaring a null vector

symbolic procedure setvectortozero(u,utype);
  begin scalar x;
  x := mkvect 2;
  for k:=0:2 do putv(x,k,aeval 0);
  return veclet(u,x,utype,t,'!3vector)
  end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
%                   VECTOR EVALUATION MODULE                           %
%                                                                      %
% This section contains the routines required to evaluate vector       %
% expressions. The main routine, VECSM!*, is mainly table-driven.      %
% If you wish to include your own routines then you should be          %
% aware of the mechanism used to invoke vector evaluation.             %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure !*vecsm!*(u,v); vecsm!* u;


% The following routine is the main vector evaluation procedure. It
% takes a single argument which is either a vector atom or a
% vector expression in SLISP function form. The value returned may
% be a vector or scalar.

% Note that if the argument is not a vector expression then an
% error results. This is true in particular if the argument is
% an expression in standard-quotient form i.e. a list whose CAR
% is *SQ.

!*vectortracelevel!* := 0;

symbolic procedure prtblanks n;
  for k:=1:min(n,15) do write "  ";

symbolic procedure vecsimp!* u;
  if vecp u then vecsm!* u else u;

symbolic procedure vecsm!* u;
  begin scalar y,vecopr,vargs,v;
  !*vectortracelevel!* := !*vectortracelevel!* + 1;
  if !*vtrace then <>;
  if atom u then v := (if vectorp u then u else getavalue u)
  else if threevectorp u then v := u
  else if (atom(y:= car u) and get(y,'rtype)='!3vector) then
    v := getv(getavalue y,getvectorindex(cadr u,t))

% Those were the simple cases. Now for the tricky operators

% Separate the operator from its operands

  else <<
    vecopr := car u;
    vargs := for each j in cdr u collect vecsimp!* j;

% Select a course of action dependent upon the operator

    if y := get(vecopr,'vectorfunction) then
    % We must check (if the op is an arithmetic operator)
    % to ensure that there are vectors in the argument list
    << if (flagp(vecopr,'vectorfn) or (flagp(vecopr,'varithop) and
       hasonevector vargs)) then v := apply(y,list vargs)
                            else v := aeval append(list(vecopr),vargs)
    >>
    else if flagp(vecopr,'vectormapping) then
    << % Check that the argument is really a vector
      y := car vargs;
      v := if threevectorp y then vectorapply(vecopr,y,cdr vargs)
                             else scalarapply(vecopr,y,cdr vargs)
    >>
    else <>;
  >>;
  if !*vtrace then <<
    y := threevectorp v;
    prtblanks(!*vectortracelevel!*);
    write(if y then "** Vector" else "** Scalar"," result is ",v);
    terpri()>>;
  !*vectortracelevel!* := !*vectortracelevel!* - 1;
  return v
 end;

% Now we define a function to declare a list of scalar functions as
% valid in vector mode too. This means that we can pass them vector
% arguments and get a vector result.

symbolic procedure vectormapping u;
  flag(u,'vectormapping);

deflist('((vectormapping rlis)),'stat);% Deflist used for bootstrapping.

% We will allow the basic transcendental functions to be vector-valued.
% Then we can, for example, evaluate Sin of a vector.

vectormapping 'sin,'cos,'log,'exp,'tan,'asin,'atan,'sinh,'cosh,'tanh;
vectormapping 'quotient,'minus,'df,'int,'sqrt;

% We must put appropriate flags upon the arithmetic operators and
% vector operators too ...
flag('(sub minus difference quotient plus times expt),'varithop);
flag('(avec cross dot vmod grad div curl delsq),'vectorfn);

% We must now define the procedures to carry out vector algebra and
% calculus. They must be given a VECTORFUNCTION property

symbolic smacro procedure vectorfn(oper,vfn);
  put(oper,'vectorfunction,vfn);

% Scalar-vector multiplication

vectorfn('times,'vectormultiply);
symbolic procedure vectormultiply vargs;
  % This routine multiplies together a list made up of scalars,
  % 3x3 matrices and a vector. Note that the combinations
  % vector*vector and vector*matrix are illegal.
  begin scalar  lht,rht,lhtype,rhtype;
  lht := aeval car vargs;         % Begin with first multiplicand
  for each v in cdr vargs do
  << % Deal with each multiplicand in turn
    rht := if vecp v then vecsm!* v
                     else v;
    lhtype := !*typeof  lht;
    rhtype := !*typeof  rht;
    lht :=
      if not (lhtype='!3vector or rhtype='!3vector) then
        aeval list('times,lht,rht)

      else if lhtype='!3vector then
        if null rhtype then vectorapply('times,lht,list rht)
           else rerror(avector,5,"Illegal operation vec*vec or vec*mat")

      else if null lhtype then vectorapply('times,rht,list lht)

      else matrixtimesvector(lht,rht)
  >>;
  return lht
  end;

% Multiplication of a vector by a 3x3 matrix from the left

symbolic procedure matrixtimesvector(mymat,myvec);
  begin scalar rows,myrow,x;
  if atom mymat and idp mymat and null getavalue mymat then
    rerror(avector,6,"Unset matrix in vector multiplication");
  rows := if idp mymat then cdr getavalue mymat else cdr mymat;
  if not (length(rows)=3 and length(car rows)=3) then
    rerror(avector,7,"Matrix must be 3x3 for vector multplication");
  x := mkvect(2);
  for k:=0:2 do
  << % Multiply out a row at a time
    myrow := car rows;
    putv(x,k,aeval list('plus,
                        list('times, first  myrow, getv(myvec,0)),
                        list('times, second myrow, getv(myvec,1)),
                        list('times, third  myrow, getv(myvec,2))));
    rows := cdr rows
  >>;
  return x
  end;

symbolic procedure !*typeof u;
  getrtype u;
% if vecp u then '!3vector
% else if matp u then 'matrix
% else if arrayp u then 'array
% else nil;

% Vector addition

vectorfn('plus,'vectorplus);
symbolic procedure vectorplus vargs;
  % Add an arbitrarily-long list of vectors
  begin scalar x;
  x := vecsm!* car vargs;
  for each v in cdr vargs do x:=vectoradd(x,vecsm!* v);
  return x
  end;

symbolic procedure vectoradd(u,v);
  % Add two vectors or two scalars
  begin scalar x,uisvec,visvec;
  uisvec := vecp u; visvec := vecp v;
  if uisvec and visvec then
  << % Adding two vectors
    x :=mkvect(2);
    for k:=0:2 do putv(x,k,aeval list('plus, getv(u,k), getv(v,k)));
    return x
  >>
  else if not (uisvec or visvec) then
  << % Adding two scalars
    return aeval list('plus, u, v)
  >>
  else rerror(avector,8,"Type mismatch in VECTORADD");
 end;

% Difference of two vectors

vectorfn('difference,'vectordiff);
symbolic procedure vectordiff vargs;
  % Vector - Vector
  begin scalar x,y;
  x := vecsm!* car vargs;
  y := vecsm!* list('minus,cadr vargs);   % Negate the second operand
  return vectoradd(x,y)
  end;

% General case of a quotient involving vectors

vectorfn('quotient,'vectorquot);
symbolic procedure vectorquot vargs;
  % This code deals with the cases
  %
  % (1) Vector / scalar
  % (2) Vector / (scalar-valued vector expression)
  % (3) Scalar / (scalar-valued vector expression)
  %
  begin scalar vdivisor,vdividend;
  vdivisor := aeval cadr vargs;
  if vecp vdivisor
    then rerror(avector,9,"Attempt to divide by a vector");
  vdividend := aeval car vargs;
  if threevectorp vdividend then return vectorapply('quotient,
                                          vdividend, list vdivisor)
  else return aeval list('quotient, vdividend, vdivisor);
 end;

% Vector cross product

vectorfn('cross,'vectorcrossprod);
symbolic procedure vectorcrossprod vargs;
  begin scalar x,y,u0,u1,u2,v0,v1,v2,w0,w1,w2;
  x := vecsm!* car vargs;
  y := vecsm!* cadr vargs;
  u0 := getv(x,0); u1 := getv(x,1); u2 := getv(x,2);
  v0 := getv(y,0); v1 := getv(y,1); v2 := getv(y,2);
  % Calculate each component of the cross product
  w0 := aeval list('difference,
                    list('times,u1,v2),
                    list('times,u2,v1));
  w1 := aeval list('difference,
                    list('times,u2,v0),
                    list('times,u0,v2));
  w2 := aeval list('difference,
                    list('times,u0,v1),
                    list('times,u1,v0));
  x := mkvect(2);
  putv(x,0,w0); putv(x,1,w1); putv(x,2,w2);
  return x
  end;

% Vector modulus

vectorfn('vmod,'vectormod);

% There are two definitions due to the existence of a bug in the REDUCE
% code for SQRT : in the IBM version of REDUCE 3.3 an attempt to take
% SQRT of 0 results in an error, so I have coded round it.

% The first version which follows is the succinct version which will
% work if SQRT(0) doesn't give an error.

% symbolic procedure vectormod u;
%   aeval list('sqrt,list('dot,car u,car u));

% This version is a little longer but it works even if SQRT(0) doesn't.

symbolic procedure vectormod u;
  begin scalar v;
  v := aeval list('dot, car u, car u);
  if zerop v then return 0
             else return aeval list('sqrt,v);
  end;

% Vector dot product

vectorfn('dot,'vectordot);
symbolic procedure vectordot vargs;
  begin scalar x,y,u0,u1,u2,v0,v1,v2;
  x := car vargs;
  y := cadr vargs;
  u0 := getv(x,0); u1 := getv(x,1); u2 := getv(x,2);
  v0 := getv(y,0); v1 := getv(y,1); v2 := getv(y,2);
  % Calculate the scalar product
  return aeval list('plus,
                    list('times,u0,v0),
                    list('times,u1,v1),
                    list('times,u2,v2))
  end;

% Component-wise assignment of a vector (AVEC)

vectorfn('avec,'vectoravec);

deflist('((oper vfn)),'vectorfunction);   % For bootstrapping.

symbolic procedure vectoravec vargs;
  begin scalar x;
  % Build a vector from the argument list
  if not eqn(length(vargs),3) then
            rerror(avector,10,"Incorrect number of args in AVEC");
  x := mkvect(2);
  putv(x,0,aeval first vargs);
  putv(x,1,aeval second vargs);
  putv(x,2,aeval third vargs);
  return x
  end;

% Gradient of a scalar

vectorfn('grad,'vectorgrad);
symbolic procedure vectorgrad vargs;
  begin scalar x,y;
  x := mkvect(2);
  y := aeval car vargs;
  putv(x,0,aeval list('quotient,
                       list('df,y,first !*coords),
                       !*hfac 0));
  putv(x,1,aeval list('quotient,
                       list('df,y,second !*coords),
                       !*hfac 1));
  putv(x,2,aeval list('quotient,
                       list('df,y,third !*coords),
                       !*hfac 2));
  return x
  end;

% Divergence of a vector

vectorfn('div,'vectordiv);
symbolic procedure vectordiv vargs;
  begin scalar x,u0,u1,u2;
  x := vecsm!* car vargs;
  u0 := getv(x,0); u1 := getv(x,1); u2 := getv(x,2);
  u0 := aeval list('times,u0,!*hfac 1,!*hfac 2);
  u1 := aeval list('times,u1,!*hfac 0,!*hfac 2);
  u2 := aeval list('times,u2,!*hfac 0,!*hfac 1);
  x :=  aeval list('plus,
                    list('df,u0,first !*coords),
                    list('df,u1,second !*coords),
                    list('df,u2,third !*coords));
  x := aeval list('quotient,x,list('times,
                          !*hfac 0,!*hfac 1,!*hfac 2));
  return x
  end;

% Curl of a vector

vectorfn('curl,'vectorcurl);
symbolic procedure vectorcurl vargs;
  begin scalar x,u0,u1,u2,v0,v1,v2,w0,w1,w2;
  x := vecsm!* car vargs;
  u0 := aeval list('times,getv(x,0),!*hfac 0);
  u1 := aeval list('times,getv(x,1),!*hfac 1);
  u2 := aeval list('times,getv(x,2),!*hfac 2);
  v0 := first !*coords; v1 := second !*coords; v2 := third !*coords;
  x := mkvect(2);
  w0 := aeval list('times,
                    list('difference,
                          list('df,u2,v1),
                          list('df,u1,v2)),
                    !*hfac 0);
  w1 := aeval list ('times,
                     list('difference,
                          list('df,u0,v2),
                          list('df,u2,v0)),
                    !*hfac 1);
  w2 := aeval list('times,
                    list('difference,
                          list('df,u1,v0),
                          list('df,u0,v1)),
                    !*hfac 2);
  putv(x,0,w0); putv(x,1,w1); putv(x,2,w2);
  x := aeval list('quotient,
                   x,
                   list('times, !*hfac 0, !*hfac 1, !*hfac 2));
    return x
  end;

% Del-squared (Laplacian) of a scalar or vector

vectorfn('delsq,'vectordelsq);
symbolic procedure vectordelsq vargs;
  begin scalar x,y,v0,v1,v2,w0,w1,w2;
  x := vecsm!* car vargs;
  if vecp x then
    % Cunning definition of Laplacian of a vector in terms of
    % grad, div and curl
    return aeval list('difference,
                       list('grad, list('div,x)),
                       list('curl, list('curl,x)))
  else
  << % Laplacian of a scalar ... which simply requires lots of
     % calculus
     if null x then x := car vargs;
     y := aeval list('times,!*hfac 0, !*hfac 1, !*hfac 2);
     v0 := first !*coords;
     v1 := second !*coords;
     v2 := third !*coords;
     w0 := aeval list('df,
                      list('quotient,
                           list('times,
                                !*hfac 1,
                                !*hfac 2,
                                list('df,x,v0)),
                           !*hfac 0),
                      v0);
     w1 := aeval list('df,
                      list('quotient,
                           list('times,
                                !*hfac 2,
                                !*hfac 0,
                                list('df,x,v1)),
                           !*hfac 1),
                      v1);
     w2 := aeval list('df,
                      list('quotient,
                           list('times,
                                !*hfac 0,
                                !*hfac 1,
                                list('df,x,v2)),
                           !*hfac 2),
                      v2);
     return aeval list('quotient,
                       list('plus,w0,w1,w2),
                       y)
  >>;
  end;

% Vector substitution - definition of SUB as a VECTORFN
% function.
vectorfn('sub,'vectorsub);

% Now we have to define mapping for SUB. It's made a little complicated
% by the fact that the argument list for SUB has the interesting bit
% i.e. the vector, at the end.

symbolic procedure vectorsub vargs;
  begin scalar subslist,vexpr,x;
  vexpr := car reverse vargs;    % That was the easy part !
  % Now we need to get the rest of the list
  subslist := reverse cdr reverse vargs; % Dirty, but effective !
  x := mkvect(2);
  for k:=0:2 do
    putv(x,k,aeval append('(sub),
                          append(subslist,list getv(vexpr,k))));
  return x
  end;

% Component-wise application of a scalar operation to a vector

symbolic procedure vectorapply(vecopr,v,args);
  begin scalar vv,x,y;
  x := mkvect(2);
  vv := if not vectorp v then vecsm!* v
                         else v;
  for k:=0:2 do
  << % Apply the operation to each component
    y := getv(vv,k);
    y := if null args then aeval list(vecopr,y)
                      else aeval append(list(vecopr,y),args);
    putv(x,k,y);
  >>;
  return x
  end;

% We need to define a dummy routine to apply a function to a scalar

symbolic procedure scalarapply(op,v,args);
  if null args then aeval list(op,v)
               else aeval append(list(op,v),args);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
%                     COORDINATE SYSTEM MODULE                         %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% We begin with a function which declares the names of the coordinates
% to be used

symbolic procedure coordinates u;
  begin scalar x;
  if not eqn(length(u),3)
    then rerror(avector,11,"Wrong number of args");
  for each y in u do if (x := gettype y) and not(x eq 'operator) then
    rerror(avector,12,"Name declared as coordinate is not a kernel");
  remflag(!*coords,'reserved);
  !*coords := u;
  x := aeval list('avec,first u,second u,third u);
  remflag('(coords),'reserved);
  setk('coords,x);
  flag('(coords),'reserved);
  %flag(u,'reserved);
  return u
  end;


symbolic operator coordinates;

remflag('(dvolume hfactors),'reserved);

algebraic procedure scalefactors(h1,h2,h3);
begin
  remflag('(dvolume hfactors),'reserved);
  hfactors := avec(h1,h2,h3);
  dvolume := h1*h2*h3;
  flag('(dvolume hfactors),'reserved);
 end;

flag('(dvolume hfactors),'reserved);

% We define a procedure that extracts the n-th scale factor

symbolic procedure !*hfac n;
  if not fixp n or n<0 or n>2 then rerror(avector,13,"Invalid index")
  else getv(getavalue 'hfactors,n);

% Now we define two useful operators that allow us to define and
% refer to a coordinate system by name

symbolic procedure getcsystem u;
  begin scalar x,y;
  if not atom u
    then rerror(avector,14,"Invalid name for coordinate system");
  if not flagp(u,'coordinatesystem)
    then rerror(avector,15,"Unknown system");
  x := get(u,'coordinates);
  y := get(u,'scalefactors);
  if x and y then
  << % Put the coordinates and scalefactors in place
    remflag(!*coords,'reserved);
    !*coords := x;
    remflag('(coords),'reserved);
    setk('coords,aeval list('avec,first x, second x, third x));
    flag('(coords),'reserved);
    %flag(x,'reserved);
    put('hfactors,'avalue,list('!3vector,y));
    remflag('(dvolume),'reserved);
    setk('dvolume,aeval list('times, !*hfac 0, !*hfac 1, !*hfac 2));
    flag('(dvolume),'reserved);
    return x
  >>
  else rerror(avector,16,"Incompletely specified coordinate system")
  end;

symbolic procedure putcsystem u;
  begin
  if not atom u
    then rerror(avector,17,"Invalid name for coordinate system");
  flag(list u,'coordinatesystem);
  put(u,'coordinates,!*coords);
  put(u,'scalefactors,getavalue 'hfactors);
  !*csystems := union(list u,!*csystems);
  return u
  end;


deflist('((coordinates rlis)),'stat);
!*coords := '(x y z);
!*csystems := nil;

% The following procedure calculates the derivative of a vector
% function of a scalar variable, including the scale factors in
% the coefficients.

% symbolic operator vecdf;
% Commented out by M.MacCallum or surfint fails

flag('(vecdf), 'vectorfn);
   % To replace previous line - M. MacCallum

vectorfn('vecdf,'vectordf);

symbolic procedure vectordf u;
  begin scalar v,idv,x;
  v := vecsm!* car u;
  idv := cadr u;
  if not vecp v then rerror(avector,18,"First arg is not a vector");
  if not atom idv then rerror(avector,19,"Second arg is not an atom");
  x := mkvect(2);
  for k:=0:2 do
  << % Calculate components one at a time
    putv(x,k,aeval list('times,
                        !*hfac k,
                        list('df,
                             getv(v,k),
                             idv)))
  >>;
  return x
  end;

% We define three popular curvilinear coordinate systems :
% Cartesian, spherical polar and cylindrical

algebraic;
vec coords,hfactors;
% flag('(coords hfactors),'reserved); % Interferes with EXCALC.
infix dot,cross;
precedence dot,*;
precedence cross,*;

coordinates x,y,z;
scalefactors(1,1,1);
putcsystem 'cartesian;

coordinates r,theta,phi;
scalefactors(1,r,r*sin(theta));
putcsystem 'spherical;

coordinates r,z,phi;
scalefactors(1,1,r);
putcsystem 'cylindrical;

% And we choose to use Cartesians initially ...

getcsystem 'cartesian;

% Extensions to REDUCE vector package

% Definite-integral routine ... trivially simple

algebraic procedure defint(fn,x,xlower,xupper);
  begin scalar indefint;
  indefint:=int(fn,x);
  return sub(x=xupper,indefint)-sub(x=xlower,indefint)
  end;

vectormapping 'defint;  % DEFINT is now a vector function too

% Component-extraction utility - allows us to get components
% of vectors which are arguments to algebraic procedures

symbolic procedure component(v,n);
  if not vecp v then rerror(avector,20,"Argument is not a vector")
  else getv(vecsm!* v,n);

symbolic operator component,vecp;

algebraic procedure volintegral(fn,vlower,vupper);
  begin scalar integrand,idpvar,xlower,xupper,kindex;
  integrand := fn*hfactors(0)*hfactors(1)*hfactors(2);
  for k:=0:2 do
  << % Perform each integration separately. The order of integration
     % is determined by the control vector VOLINTORDER
     kindex := volintorder(k);
     idpvar := coords(kindex);
     xlower := component(vlower,kindex);
     xupper := component(vupper,kindex);
     integrand := defint(integrand,idpvar,xlower,xupper);
  >>;
  return integrand
  end;

% Define the initial setting of VOLINTORDER

volintorder := avec(0,1,2);

% Line integral

algebraic procedure lineint(v,curve,ivar);
  begin scalar scalfn,vcomp,hcomp,dcurve;
  scalfn := 0;
  for k:=0:2 do
  << % Form the integrand
    vcomp := component(v,k);
    hcomp := hfactors(k);
    dcurve := df(component(curve,k),ivar);
    scalfn := scalfn + vcomp*hcomp*dcurve
  >>;
  scalfn := vecsub(coords,curve,scalfn) ;     % Added by M. MacCallum
  return int(scalfn,ivar)
  end;

algebraic procedure deflineint(v,curve,ivar,ilb,iub);
  begin scalar indfint;
  indfint := lineint(v,curve,ivar);
  return sub(ivar=iub,indfint)-sub(ivar=ilb,indfint)
  end;

% Attempt to implement dot and cross as single-character infix
%  operators upon vectors

symbolic;

% Cross-product is easy : we simply tell Reduce that up-arrow is a
%  synonym for CROSS

newtok '((!^) cross);

% Dot is more difficult : the period (.) is already defined as the
%  CONS function, and unfortunately REVAL1 spots this before it
%  checks the type of the arguments, so declaring CONS to be
%  VECTORMAPPING won't work. What is required is a hack to the
%  routine that carries out CONS at SYMBOLIC level.

% We now redefine RCONS which is the function invoked when CONS is used
% in Reduce.

remflag('(rcons),'lose);   % We must use this definition.

symbolic procedure rcons u;
   begin scalar x,y;
      argnochk ('cons . u);
      if (y := getrtype(x := reval cadr u)) eq 'vector
        then return mk!*sq simpdot u
% The following line was added to enable . to be used as vector product
% (Amended by M. MacCallum)
       else if (y eq '!3vector)
         then return apply('vectordot,
                           {for each j in u collect vecsimp!* j})
       else if not(y eq 'list) then typerr(x,"list")
       else return 'list . reval car u . cdr x
   end;

vectorfn('cons,'vectordot);

% Rest added by M. MacCallum
flag('(surfint vecsub),'vectorfn);
vectorfn('surfint,'vsurfint);
symbolic procedure vsurfint vargs;
 begin scalar sivar1, sivar2, sivar3, sivar4, sivar5 ;
  if not (length vargs = 8) then rerror(avector,21,
             "Wrong number of args to SURFINT");
  if not (vecp(sivar1 := car vargs) and
          vecp(sivar2 := cadr vargs) and
          idp car(sivar3 := cddr vargs) and
          idp car(sivar4 := cdddr sivar3))
     then rerror(avector,22,
                 "Wrong type(s) of arguments supplied to SURFINT");
  sivar2 := vecsm!* sivar2 ;
  sivar3 := reverse cdddr reverse sivar3 ;
  sivar5 := aeval list('cross,
                       list('vecdf, sivar2, car sivar3),
                       list('vecdf, sivar2, car sivar4)) ;
  sivar1 := vecsm!* sivar1 ;
  sivar5 := aeval list('dot, sivar1, sivar5) ;
  sivar5 := aeval list('vecsub,'coords,sivar2,sivar5);
  return aeval append(list('defint,
                      append(list('defint, sivar5), sivar3)),
                      sivar4) ;
 end ;

vectorfn('vecsub,'vvecsub);
symbolic procedure vvecsub vargs ;
 begin scalar vsarg1, vsarg2, vsarg3;
  if not (length vargs = 3) then rerror(avector,23,
                           "Wrong number of arguments to VECSUB");
  if not (vecp car vargs and vecp cadr vargs) then
        rerror(avector,24,
               "First two arguments to VECSUBS must be vectors");
  vsarg1 := vecsm!* car vargs;
  vsarg2 := vecsm!* cadr vargs;
  vsarg3 := caddr vargs;
  if not vecp vsarg3 then vsarg3 := prepsq cadr vsarg3;
  return  aeval list('sub,
             list('equal, !*a2k component(vsarg1, 0),
                          component(vsarg2, 0)),
             list('equal, !*a2k component(vsarg1, 1),
                          component(vsarg2, 1)),
             list('equal, !*a2k component(vsarg1, 2),
                          component(vsarg2, 2)),
             vsarg3);
 end ;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/0000755000175000017500000000000011722677356022062 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/ranks.red0000644000175000017500000001213111526203062023647 0ustar  giovannigiovannimodule ranks;  % Rank operations.

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(ZERO);

ZERO := mkobject(0,'zero);

symbolic procedure addrank(name,arity,coarity);
   begin scalar m,disambop,x;
      m := length arity;   % Number of arguments.
      disambop := mkrankedname(name,arity,if atom coarity then nil
                                           else car coarity);
      x := get(name,'ranks);
      if null x
        then put(name,'ranks,
                      {m . {mkranklist(arity,disambop,coarity)}})
       else addrank1(disambop,arity,x,m,coarity)
   end;

symbolic procedure addrank0(name,arity,coarity);
   begin scalar m,disambop,x;
      disambop := caadr cadadr coarity;
      m := length arity;   % Number of arguments.
      x := get(name,'ranks);
      if null x
        then put(name,'ranks,
                      {m . {mkranklist(arity,disambop,coarity)}})
       else addrank1(disambop,arity,x,m,coarity)
   end;


symbolic procedure addrank1(disambop,arity,tree,noargs,coarity);
   if noargs = caar tree
     then mergerank(disambop,arity,cdar tree,coarity)
    else if noargs > caar tree
     then rplaca(rplacd(tree,car tree . cdr tree),
                        {noargs,mkranklist(arity,disambop,coarity)})
    else if null cdr tree
     then rplacd(tree,{{noargs,
                        mkranklist(arity,disambop,coarity)}})
    else addrank1(disambop,arity,cdr tree,noargs,coarity);

symbolic procedure mergerank(disambop,arity,tree,coarity);
   if car arity = caar tree
     then if null cdr arity
            then upd_coarity(cdar tree,coarity)

%if cadar tree eq disambop
%                    then <>
%          else <>
           else mergerank(disambop,cdr arity,cdar tree,coarity)
    else if type_greaterp(caar tree,car arity)
     then rplaca(rplacd(tree,car tree . cdr tree),
                 mkranklist(arity,disambop,coarity))
    else if null cdr tree
     then rplacd(tree,{mkranklist(arity,disambop,coarity)})
    else mergerank(disambop,arity,cdr tree,coarity);

symbolic procedure mkrankedname(name,arity,coarity);
   begin scalar x,y;
      if name then x := explode name
       else <>;
      y := explode2 "_";
      for each j in arity do x := nconc(x,append(y,explode j));
      if coarity then x := nconc(x,append(explode2 "!>",explode coarity));
      return intern compress x
   end;

symbolic procedure mkranklist(arity,name,coarity);
   if null cdr arity then {car arity,'lambda,car coarity,'cond . cdr coarity}
%name,coarity}
    else {car arity,mkranklist(cdr arity,name,coarity)};

symbolic procedure upd_coarity(u,v);
   begin         %u: (lambda () (cond ((bool (disambop coarity)) ((bool
     u := cdaddr u;
     if cadr v = car u and null cdr u then return nil else
     if caadr v eq t then aconc(u,cadr v)    %%% THIS MAY BE A PROBLEM
      else rplaca(rplacd(u,car u . cdr u),cadr v) %%% IN FASL VERSION
   end;


symbolic procedure type_greaterp(u,v); u eq 'generic;

symbolic procedure addnullary(arity,props);
%   if null xtype1(car coarity,arity)
%      then rederr {"Types in constraint",arity,"->",car coarity,
%                   "are unrelated"} else
    begin scalar x,y;
           x := get(arity,'!*nullary!*);
           if null x then put(arity,'!*nullary!*,
                              {'lambda,car props,'cond . cdr props})
%            else if y := atsoc(car coarity,x)
%                    then <",
%                                  car coarity,"redefined"};
%                           rplacd(y,cdr coarity)>>
            else put(arity,'!*nullary!*,
                     {'lambda,cadr x,'cond . cadr props . cdr caddr x})
         end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/forall4.red0000644000175000017500000000517411526203062024105 0ustar  giovannigiovannimodule forall4;  % Support for "let" etc. statements in REDUCE 4.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% For the time being, we are defaulting to the REDUCE 3 model until we
% decide how such rules should be handled.

symbolic procedure n_formforall(u,vars);
   mkobject(formforall(u,vars,'algebraic),'noval);

put('forall,'n_formfn,'n_formforall);

symbolic procedure n_formlet(u,vars);
   mkobject(formlet(u,vars,'algebraic),'noval);

put('let,'n_formfn,'n_formlet);

symbolic procedure n_formclear(u,vars);
   mkobject(formclear(u,vars,'algebraic),'noval);

put('clear,'n_formfn,'n_formclear);

symbolic procedure n_formmatch(u,vars);
   mkobject(formmatch(u,vars,'algebraic),'noval);

put('match,'n_formfn,'n_formmatch);

symbolic procedure form4where(u,vars);
   begin scalar expn,equivs;
      expn := n_form1(cadr u,vars);
      equivs := remcomma caddr u;
      equivs := formc('list . equivs,vars,'algebraic);
      equivs := cadr equivs;  % FIX THIS.
      return mkobject(
        {'prog, '(newrule!* oldrules!* v w),
            {'setq, 'w, {'set_rules,{'cdr, equivs}, nil}}, % FIX THIS.
            {'setq, 'u, {'errorset!*,
                            {'mkquote, {'simp4!*,value expn}}, nil}},
            '(restore_rules w),
            '(return (cond ((errorp u) (rederr nil)) (t (car u))))},
        type expn)
   end;

put('where,'n_formfn,'form4where);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/tables.red0000644000175000017500000000316311526203062024010 0ustar  giovannigiovannimodule tables;  % Specific tables for REDUCE 4.

% Author:  Anthony C. Hearn.

% Copyright (c) 1998. Anthony C. Hearn. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These modules are separated from those in reduce4, since the latter
% are needed to compile the former.

create!-package('(tables table1 table2 table3 matrix4),nil);

load_package reduce4;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/table3.red0000644000175000017500000000451611526203062023713 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

install getd(u:variable):generic -> getd1;

install get(u:variable,v:variable):generic -> get;

install prop(u:variable):list -> prop1;

install put(u:variable,v:variable,w:generic):generic -> put;

install lterm(u:poly,v:kernel):poly -> !*lterm;

install sub(u:list,v:generic):generic -> sub!*;

install operator(u:list):noval -> operator1;


% Hooks needed for support of REDUCE 3 operators.

symbolic procedure lterm1(u,v); !*q2f simp lterm(prepf u,v);

symbolic procedure prop1 u; for each j in prop u collect
   if idp j then mkobject(j,'variable)    % Must be a flag.
    else mkobject('list . pair2list j,'generic);

symbolic procedure pair2list u;
   if null u then nil
    else if atom u then list u
    else car u . pair2list cdr u;

symbolic procedure getd1 u; 'list . pair2list getd u;

symbolic procedure operator1 u;
   <>
       else typerr(cadr j,"variable");
     nil>>;

rlistat '(operator);

% !%reduce4();    % This must be final statement!!!!

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/rankstat.red0000644000175000017500000004257311526203062024375 0ustar  giovannigiovannimodule rankstat;

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(curmodule!*);

%symbolic procedure module_stat;
%   begin scalar cursym,module_name,module_parametrization,module_body;
%     module_name := scan();
%     scan();
%     if cursym!* eq '![ then <>;
%     if null(cursym!* eq '!*lcbkt!*) then symerr('module,nil);
%     scan();
%     loop: module_body := aconc(module_body, xread1  'group);
%     cursym := cursym!*;
%     scan();
%     if cursym eq '!*rcbkt!*
%       then return 'theory . module_name . module_parametrization .
%                             module_body
%      else go to loop
%   end;

%put('module,'stat,'module_stat);

symbolic procedure type_stat;
   <>
     where x =  remcomma xread nil;

put('types,'stat,'type_stat);

%%%% There should be at least a function to check if a newly added type
%%%% relation produces a cycle.

symbolic procedure subtype_rels_stat;
   'subtyperels . remcomma xread 'lambda;

put('subtypes,'stat,'subtype_rels_stat);


symbolic procedure n_formsubtyperels(u,vars);
   {'noval,'progn . aconc(for each j in cdr u
                              conc n_formsubtyperels1(j,vars),
                          ''(noval nil))};

symbolic procedure n_formsubtyperels1(u,vars);
   if null eqcar(u,'lessp) then nil
    else append(n_formsubtyperels2(if atom caddr u then {caddr u}
                                    else caddr u,cadr u,vars),
                n_formsubtyperels1(cadr u,vars));

symbolic procedure n_formsubtyperels2(u,v,vars);
   for each j in u conc
    begin scalar x;
      x := if atom v then {v}
            else if car v eq 'lessp
                    then if atom caddr v then {caddr v}
                          else flat_typel caddr v
                  else flat_typel v;
      return {'put,mkquote j,''typetree,
                   {'union,{'get,mkquote j,''typetree},
                    mkquote x}} .
             for each k in x collect
              {'put,mkquote k,''uptree,
                   {'union,{'get,mkquote k,''uptree},
                    mkquote {j}}}
    end;

symbolic procedure flat_typel u;
   car u . if null atom cadr u then flat_typel cadr u else cdr u;


put('subtyperels,'n_formfn,'n_formsubtyperels);
flag('(subtyperels),'always_nform);

newtok '((!- !>) mapped_to); % For now. Should only be active inside the stat.

symbolic procedure ranks_stat;
   begin scalar props,oper,arity,coarity,ranks1;
     %scan();
     loop:
     oper := xread 'for;
     if atom oper then oper := {'!*nullary!*,oper};
     flag('(mapped_to),'delim);
     arity := xread nil;
     if atom arity then arity := {arity}
      else arity := cdr arity;
     remflag('(mapped_to),'delim);
     coarity := xread 'group;
     if atom coarity then props := nil
      else if car coarity eq 'when
                then <>;
        rnk := car u;
        op := caar rnk;
        opvars := cdar rnk;
        arity := cadr rnk;
        coarity := caddr rnk;
        rnk := cdddr rnk;
        props := car rnk;
        if cdr rnk then rnk := cadr rnk else rnk := nil;  % Used by INSTALL.
        if op eq '!*nullary!* then
          <>;

        if props eq 'symmetric
           then <>;
        if eqcar(props,'when) then
           props := {{'value,value n_form1(cadr props,
                                   append(pair(opvars,arity),vars))}}
         else props := {t};
        n := 0;
        z := for each j in opvars
               collect j . intern compress append(explode 'x,
                                                  explode(n := n + 1));
        props := subla(z,{opvars,props});
        for each rankfn in mk_rankfns(op,coarity,arity,props,rnk) do
          e_ptr := cdr rplacd(e_ptr,{rankfn});
        go to a
   end;

put('ranks,'n_formfn,'n_formranks);

flag('(ranks),'always_nform);

symbolic procedure mk_rankfns(op,coarity,arity,props,altop);
   % Symmetry is currently restricted to binary operators.
   % Altop is used by INSTALL.
   begin scalar x,disambop,disambop2,rankfns; integer n; n := 0;
     disambop := mkrankedname(op,arity,if caadr props eq t then nil
                                        else coarity);
     x := for each j in arity
              collect intern compress append(explode j,
                                             explode(n := n + 1));
     rankfns := {'de,disambop,x,
%                'list . (if op then mkquote coarity . {
%                               'list . mkquote op . x}
%                          else mkquote coarity . {'value . x})}
                 {'mkobject,
                   if altop then altop . for each j in x collect {'value,j}
                   % This is to allow for compilation of
                   % ranks u := v : {kernel,poly} -> poly
                   else if op eq 'setq
                     then 'set . for each j in x collect {'value,j}
                    else if op then op . for each j in x collect {'value,j}
                    else 'value . x,
                  mkquote coarity}}
                   . rankfns;
     rankfns := {'addrank0,mkquote op,mkquote arity,
                  mkquote({car props,
                           append(cadr props,
                                 {mkquote {disambop,coarity}})})} . rankfns;
     if null symmetricp(op . arity) then return rankfns;
     if length arity neq 2
        then rederr "only binary symmetric functions are supported";
     if (car arity eq cadr arity) and (caadr props eq t)
        then return rankfns;
     disambop2 := mkrankedname(op,reverse arity,
                               if null(caadr props eq t) then
                                  if car arity eq cadr arity
                      then intern compress append(explode '!!,explode coarity)
                                                  else coarity
                                else nil);
     rankfns := {'de,disambop2,reverse x,disambop . x} . rankfns;
     rankfns := {'addrank0,mkquote op,mkquote reverse arity,
                 mkquote({car props,append(if car arity eq cadr arity
                                              then cadr props
                    else subla(pair(car props,reverse car props),cadr props),
                        {mkquote {disambop2,coarity}})})} . rankfns;
     return rankfns
   end;

symbolic procedure symmetricp u;  % temporary hack.
   (x and ((xtype1(cadr u,car x) and xtype1(caddr u,cadr x))
           or (xtype1(caddr u,car x) and xtype1(cadr u,cadr x))))
   where x = get(car u,'symmetricfn);

symbolic procedure mk_nullaryfns(arity,coarity,props);
   begin scalar x,disambop,n;  n := 0;
     disambop := mkrankedname(nil,arity,coarity);
     x := for each j in arity
              collect intern compress append(explode j,
                                             explode(n := n + 1));
     return {{'addnullary,mkquote car arity,  %mkquote coarity,
              mkquote({car props,
                       append(cadr props,
                             {mkquote {disambop,coarity}})})},
             {'de,disambop,x,
                 'list . mkquote coarity . {'value . x}}}
  end;

% Support for "install" form of definition.

put('install,'stat,'installstat);

symbolic procedure installstat;
   begin scalar mode,oprname,x,y;
        mode := 'generic;  % Default target mode.
        oprname := scan();
        if null idp oprname
          then <>;
        scan();
        x := errorset!*(list('read_param_list,nil),nil);
        if errorp x then go to c;
        x := car x;
        if cursym!* eq '!*colon!* then mode := read_type();
        if null(cursym!* eq 'mapped_to) then go to c;
        y := scan();
        if not(scan() eq '!*semicol!*) then go to c;
%       return list('install,oprname,x,mode,y);
        return {'ranks,{oprname . for each j in x collect car j,
                        for each j in x collect cdr j,mode,nil,y}};
    c:  errorset!*('(symerr (quote install) t),nil)
   end;

endmodule;

end;

% Not needed now.

symbolic procedure n_forminstall(u,vars);
   begin scalar body,mode,name,oldname,truename,typelist,varlis;
        u := cdr u;
        name := car u;
        varlis := cadr u;
        u := cddr u;
        mode := car u;
        oldname := cadr u;
        typelist := for each j in varlis collect cdr j;
        varlis := for each j in varlis collect car j;
        body := oldname . for each j in varlis collect list('value,j);
%       body := {'type_reduce,body,mkquote mode};
        body := {'mkobject,body,mkquote mode};
        truename := name;
        name := mkrankedname(name,typelist,nil);
        body := list('de,name,varlis,body);
        body := list('progn,
                     list('addrank,mkquote truename,mkquote typelist,
                           mkquote mode),
                     body,{'mkobject,mkquote truename,mkquote 'variable});
        return body
   end;

put('install,'n_formfn,'n_forminstall);

% ---------------------

symbolic procedure equations_stat;
   begin scalar x,equations,typed_vars;
     x := scan();
     x := scan();
     s: if flagp(typeid := cursym!*,'typeid)
           then <>;
     ne: x := xread1 'group;
     if null atom caddr x and caaddr x eq 'when
        then x := {{car x,cadr x,cadr caddr x,'when . cddr caddr x}}
      else x := {x,nil};
     equations := aconc(equations,x);
     if cursym!* eq '!*comma!* then <>;
     return 'equations . typed_vars . equations
  end;

put('equations,'stat,'equations_stat);


symbolic procedure form_module(u,vars,mode);
   begin scalar theo,parametrization,sequations,x;
     u := cdr u;
     theo := car u; curtheo!* := theo;
     u := cdr u;
     parametrization := car u;
     u := cdr u;
     for each j in u do
       if car j eq 'is
          then ((if null x
                    then rederr list("theory",caadr j,"not defined")
                  else u := theory_merge(delete(j,u),
                                         textual_sub(cdadr j,x)))
                where x = get(caadr j,'uninterpreted_theory));
     terpri();
     prettyprint u; terpri();
     put(theo,'uninterpreted_theory,u);
     if caar u eq 'types then u := cdr u;
     if caar u eq 'subtype_rels
        then put_sub_type_rels(cdar u,theo);
     while u and (caar u neq 'operations)
         do u := cdr u;
     put_ranks cdar u;
     if null(u := cdr u) then return ;
     if eqcar(car u,'equations)
        then sequations := for each equation in cddar u collect
          if caar equation eq 'replaceby then
          {'replaceby,tag_equation(type_qual(cadar u,cadar equation)),
                      tag_equation(type_qual(cadar u,caddar equation)),
                      if null car cdddar equation then nil
                       else type_qual(cadar u,car cdddar equation)}
          else {'equal,tag_equation(type_qual(cadar u,cadar equation)),
                       tag_equation(type_qual(cadar u,caddar equation))};
     put(theo,'equations,sequations);
     terpri(); prettyprint sequations
   end;

put('theory,'formfn,'form_theory);

symbolic procedure type_qual(u,v); subla(u,v);


symbolic procedure tag_equation(u);
   if null u then nil
    else if null atom u and flagp(car u,'typeid) then u
    else if null atom car u and flagp(caar u,'typeid) then u
    else ((coarity_op(car u,
                      for each j in x
                        collect if atom car j
                                   then car j else caar j) . x)
           where x = for each operand in cdr u
                         collect tag_equation(operand));


symbolic procedure type_eq(u,v);
   if null u and null v then t
    else if car u eq caar v then type_eq(cdr u,cdr v)
    else nil;

symbolic procedure coarity_op(op,arity);
   ((if null x then rederr list(op,"has no definitions")
     else if y then cadr y . op
     else cadr find_closest_arity(x,arity). op)
    where y = assoc_arity(arity,x))
    where x = get(op,'ranks);

symbolic procedure assoc_arity(arity,r);
   if null r then nil
    else if type_eq(arity,caar r) then car r
    else assoc_arity(arity,cdr r);

symbolic procedure find_closest_arity(x,arity);
   begin scalar hs1,hs2,y,coar;
     if length arity = 1
      then <>
      else if length arity = 2
      then <>;
             if null coar then write "couldn't find subtype ";
             return coar>>
     else write "currently only up to binary functions are considered";
  end;

symbolic procedure textual_sub(p,theo);
   subla(for each j in p collect cadr j . caddr j,theo);

symbolic procedure theory_merge(theo1,theo2);
   begin scalar x,y,theo;
     x := assoc('equations,theo1); y := assoc('equations,theo2);
     if x and y
        then theo := {car x . merge_equations(x,y)}
      else if x then theo := {x}
      else if y then theo := {y};
     for each j in '(operations using is subtype_rels types)
       do <>;
     return theo
   end;

symbolic procedure merge_equations(equat1,equat2);
   begin scalar typeid1,typeid2,eqlis1,eqlis2,x,newv; integer n;
     typeid1 := cadr equat1;
     typeid2 := cadr equat2;
     eqlis1 := cddr equat1;
     eqlis2 := cddr equat2;
     for each typevar in typeid1 do
       if x := atsoc(car typevar,typeid2)
          then if cdr typevar = cdr x then nil
            else <>;
    return union(typeid1,typeid2) . append(eqlis1,eqlis2)
  end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/table2.red0000644000175000017500000001753411526203062023716 0ustar  giovannigiovanni% ----- print  -----

% In this version, all these print functions are defined to use the
% standard REDUCE two dimensional format for algebraic expressions.
% This means that "write" can be viewed as a set of recursive calls
% on prin2.


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

ranks print u : {bool} -> bool,
      print u : {list} -> list,
      print u : {noval} -> noval,
      print u : {kernel} -> kernel,
      print u : {variable} -> variable,
      print u : {xkernel} -> xkernel,
      print u : {poly} -> poly,
      print u : {ratpol} -> ratpol,
      print u : {sint} -> sint,
      print u : {string} -> string,
      print u : {generic} -> generic;

symbolic procedure print_sint u;
   print_algebraic u;

symbolic procedure print_poly u;
   <>;

symbolic procedure print_ratpol u;
   <>;

symbolic procedure print_algebraic u;
   <>
     where x=value u;

symbolic procedure print_list u;
   print_list1(u,t);

symbolic procedure print_list1(u,bool);
   % This definition is basically that of INPRINT, except that it
   % decides when to split at the comma by looking at the size of
   % the argument.
   begin scalar l,orig,split,u;
      l := value u;
      prin2!* get('!*lcbkt!*,'prtch);
         % Do it this way so table can change.
      orig := orig!*;
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split := treesizep(l,40);   % 40 is arbitrary choice.
   a: rapply('prin2,list car l);
      l := cdr l;
% print list ("l:",l);
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b: prin2!* get('!*rcbkt!*,'prtch);
      if bool then terpri!* nil;
      orig!* := orig;
      return u
   end;

symbolic procedure print_bool u;
   print_algebraic u;

symbolic procedure print_noval u; nil;

symbolic procedure print_string u;
   print_algebraic u;

symbolic procedure print_kernel u;
   print_algebraic u;

symbolic procedure print_xkernel u;
   print_algebraic u;

symbolic procedure print_variable u;
   print_algebraic u;

symbolic procedure print_generic u;
   print_algebraic u;

% ------ prin2 -----

ranks prin2 u : {bool} -> bool,
      prin2 u : {list} -> list,
      prin2 u : {noval} -> noval,
      prin2 u : {kernel} -> kernel,
      prin2 u : {variable} -> variable,
      prin2 u : {xkernel} -> xkernel,
      prin2 u : {poly} -> poly,
      prin2 u : {ratpol} -> ratpol,
      prin2 u : {sint} -> sint,
      prin2 u : {string} -> string,
      prin2 u : {generic} -> generic;

symbolic procedure prin2_sint u;
   prin2_algebraic u;

symbolic procedure prin2_poly u;
   <>;

symbolic procedure prin2_ratpol u;
   <>;

symbolic procedure prin2_algebraic u;
   <> where x=value u;

symbolic procedure prin2_list u;
   print_list1(u,nil);

symbolic procedure prin2_bool u;
   prin2_algebraic u;

symbolic procedure prin2_noval u; nil;

symbolic procedure prin2_string u;
   prin2_algebraic u;

symbolic procedure prin2_variable u;
   prin2_algebraic u;

symbolic procedure prin2_xkernel u;
   prin2_algebraic u;

symbolic procedure prin2_generic u;
   prin2_algebraic u;


% ------ in ------

% Would need to remove the parse properties first.
%ranks in u : {non_empty_list} -> noval;


% ------------------ on --- off -------------------

remprop('on,'stat);

remprop('off,'stat);

remflag('(on off),'ignore);

ranks on u : {list} -> noval,
      off u : {list} -> noval;

rlistat '(on off);

% This is a messy way to handle a PSL alias problem.

!#if (member 'psl lispsystem!*)
   symbolic procedure !~on_list u; onoff_list(u,t);
   symbolic procedure !~off_list u; onoff_list(u,nil);
 !#else
   symbolic procedure on_list u; onoff_list(u,t);
   symbolic procedure off_list u; onoff_list(u,nil);
 !#endif

symbolic procedure onoff_list(u,bool);
   <>;

% ------------  trace --- traceset ----------------

remprop('tr,'stat);

remprop('untr,'stat);

remprop('trst,'stat);

remprop('untrst,'stat);

rlistat '(tr trst untr untrst);

ranks tr u : {list} -> noval,
      untr u : {list} -> noval,
      trst u : {list} -> noval,
      untrst u : {list} -> noval;

symbolic procedure tr_list u;
  trfn(u,'tr);

symbolic procedure untr_list u;
  trfn(u,'untr);

symbolic procedure trst_list u;
  trfn(u,'trst);

symbolic procedure untrst_list u;
  trfn(u,'untrst);

symbolic procedure trfn(u,v);
   <>;

% ---------------------  write -----------------------------

remprop('write,'stat);

rlistat '(write);

ranks write u : {list} -> noval;

symbolic procedure write_list u;
   <>;

% ---------------------  factor ----------------------------

remprop('factor,'stat);

remprop('remfac,'stat);

rlistat '(factor remfac);

ranks factor u : {list} -> noval,
      remfac u : {list} -> noval;

symbolic procedure factor_list u;
   factor_list1(u,t);

symbolic procedure remfac_list u;
   factor_list1(u,nil);

symbolic procedure factor_list1(u,v);
   <>;

end;

ranks num u: {ratpol} -> poly,
      %lc u : {xpoly} -> poly,
      %ldeg u: {xpoly} -> int,
      %red u: {xpoly} -> poly,
      %idp u: {kernel} -> bool,
      %domainp u: {xpoly} -> bool,
      %zerop u: {xpoly} -> bool,
      u = v: {poly,poly} -> bool,

%ranks u:ratpol -> zero when num u = 0,

symbolic procedure equal_poly_poly(u,v); {'bool,value u = value v};

% An xpoly can't be zero!!
% symbolic procedure zerop_xpoly u; mkobject(null value u,'bool);

symbolic procedure poly!>zero u; mkobject(0,'zero);

%ranks u:poly -> kernel when not domainp u and
%                            ((lc u = 1 and ldeg u = 1) and red u = 0),
%      u:kernel -> variable when idp u;

symbolic procedure lc_xpoly u; mkobject(lc value u,'poly);

symbolic procedure ldeg_xpoly u; mkobject(ldeg value u,'int);

symbolic procedure red_xpoly u;
   mkobject(if red value u then red value u else 0,'poly);

symbolic procedure idp_kernel u; mkobject(idp value u,'bool);

% An xpoly can't become a kernel!!
% symbolic procedure xpoly!>kernel u; mkobject(mvar u,'kernel);

symbolic procedure domainp_poly u; mkobject(domainp value u,'bool);


% ------ LIST -----

subtypes non_empty_list empty_list < list;

ranks u neq v : {list,list} -> bool;

%ranks u:list -> non_empty_list when u neq {};

symbolic procedure neq_list_list(u,v); mkobject(null(value u = value v),'bool);

mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/proc4.red0000644000175000017500000001266411526203062023573 0ustar  giovannigiovannimodule proc4;  % Support for REDUCE 4 procedures.

% Author:  Anthony C. Hearn, Eberhard Schruefer.

% Copyright (c) 1996 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*specification_reduce !*specification);

fluid '(!*spec);

switch spec;

put('spec,'simpfg,'((t (setq !*specification_reduce t) nil)));
%                      (de type_reduce (u v)
%                          (type_reduce1 (list v u)))))));

symbolic procedure n_formproc(u,vars);
   begin scalar body,name,truename,type,typelist,varlis,x,y,
                mode,constraint,pckg_orig;
        u := cdr u;
        name := car u;
        if cadr u then mode := cadr u else mode := 'generic;
        u := cddr u;
        type := if atom car u then car u
                 else caar u;
        pckg_orig := if atom car u then nil
                      else cdar u;
        if flagp(name,'lose) and (!*lose or null !*defn)
          then return progn(lprim list(name,
                            "not defined (LOSE flag)"),
                        nil)
         else if !*redeflg!* and getd name
          then lprim list(name,"redefined");
        varlis := cadr u;
        u := caddr u;
        x := if eqcar(u,'block) then cadr u else nil;
        y := append(varlis,x);
        typelist := for each j in varlis collect cdr j;
        varlis := for each j in varlis collect car j;
        constraint := mode;
        truename := name;
        if !*specification_reduce
           then if (name := get_disambop(name,typelist,mode)) then nil
                 else rederr {"no rank definition found for",name}
         else name := mkrankedname(name,typelist,if atom mode then nil %mode
                                            else caar mode);
        if null atom mode and cdr mode
           then <>
         else constraint := {varlis,{t,mkquote {name,mode}}};
        body := n_form1(u,y);
        if not(mode eq 'generic) and !*specification
          then if type body eq 'generic then body := value body
% Should issue a warning that result type generic prevents type consistency
% check
                else if xtype1(type body,mode) then body := value body
                else if xtype1(mode,type body)
                        then <>
                else rederr {"procedure type",mode,
                             "is unrelated to ceiling type",
                              type body,"of procedure body"}
        else if mode eq 'generic then body := value body
        else body := {'check_type,value body,mkquote mode};
        if !*nosmacros and type eq 'smacro then type := 'expr;

% ---

        if type eq 'expr then body := list('de,name,varlis,body)
         else if type eq 'fexpr then body := list('df,name,varlis,body)
         else if type eq 'macro then body := list('dm,name,varlis,body)
         else if type eq 'emb then return embfn(name,varlis,body)
         else body := {'putc,
                        mkquote name,
                        mkquote type,
                        mkquote {'lambda,varlis,body}};
        body := if !*specification_reduce % should check if we have a rank
                   then {mode,{'progn,body,
                                mkquote mkobject(truename,'variable)}}
                 else {mode,{'progn,
                       {'addrank0,mkquote truename,mkquote typelist,
                           mkquote constraint},
                       {'put,mkquote name,''pckg_orig,mkquote pckg_orig},
                        body,mkquote mkobject(truename,'variable)}};
        if !*defn and type memq '(fexpr macro smacro) then lispeval body;
        return body
   end;

symbolic procedure mkretract(atyp,ttyp,exp);
   {'retract,mkquote atyp,mkquote ttyp,exp};

symbolic procedure retract(atyp,ttyp,exp);
   if xtype1(ttyp,type exp) then exp
    else rederr "was not retractable";

put('procedure,'n_formfn,'n_formproc);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/forstat4.red0000644000175000017500000001136711526203062024311 0ustar  giovannigiovannimodule forstat4;   % Definition of REDUCE 4 FOR loops.

% Author: Anthony C. Hearn.

% Copyright (c) 1995 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


put('for,'n_formfn,'n_formfor);

flag('(go),'non_form);

symbolic procedure top_type u;
   % U is a list of formed expressions.  Result is top type of elements.
   begin scalar v,w;
      v := type car u;
  a:  u := cdr u;
      if null u then return v;
      w := type car u;
      if xtype1(w,v) then go to a
       else if xtype1(v,w) then <>
       else rederr "ugh"
   end;

symbolic procedure n_formfor(u,vars);
   begin scalar action,body,endval,incr,initval,result,testexp,var,x;
         scalar incrtype;
      var := cadr u;
      incr := caddr u;
      incr := list(car incr,cadr incr,caddr incr);
      incrtype := top_type for each j in incr collect n_form1(j,vars);
      action := cadddr u;
      body :=  car cddddr u;
      initval := car incr;
      endval := caddr incr;
      incr := cadr incr;
      x := list('difference,endval,var);
      if incr neq 1 then x := list('times,incr,x);
      x := list('lessp,x,0);
      testexp := x;
      result := gensym();
      x :=
         sublis(list('body2 .
                       list(get(action,'bin),body,result),
               'body3 .
                   body,
               'body . body,
               'initval . initval,
               'nillist . nil,
               'result . result,
               'incrtype . incrtype,
               'initresult . get(action,'initval),
               'resultlist . result,
               'testexp . testexp,
               'updfn . 'plus,
               'updval . incr,
               'var . var),
          if action eq 'do
            then '(rblock ((var . incrtype))
                  (setq var initval)
              lab (cond (testexp (return nil)))
                  body
                  (setq var (updfn var updval))
                  (go lab))
           else if action eq 'collect
            then '(rblock ((var . incrtype) (result . generic)
                          (endptr . generic))
                  (setq var initval)
                  (cond (testexp (return nillist)))
                  (setq result (setq endptr (cons body nil)))
                looplabel
                  (setq var (updfn var updval))
                  (cond (testexp (return resultlist)))
                  (rplacd endptr (cons body nil))
                  (setq endptr (cdr endptr))
                  (go looplabel))
           else if action eq 'conc
            then '(rblock ((var . incrtype) (result . generic)
                          (endptr . generic))
                  (setq var initval)
               startover
                  (cond (testexp (return nillist)))
                  (setq result body)
                  (setq endptr (lastpair resultlist))
                  (setq var (updfn var updval))
                  (cond ((atom endptr) (go startover)))
                looplabel
                  (cond (testexp (return result)))
                  (rplacd endptr body3)
                  (setq endptr (lastpair endptr))
                  (setq var (updfn var updval))
                  (go looplabel))
           else '(rblock ((var . incrtype) (result . generic))
                 (setq var initval)
                 (setq result initresult)
              lab1
                 (cond (testexp (return result)))
                 (setq result body2)
                 (setq var (updfn var updval))
                 (go lab1)));
      return n_form1(x,vars)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/matrix4.red0000644000175000017500000002774611526203062024143 0ustar  giovannigiovannimodule matrices;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Almost generic definition (i.e. independent of datastructure of
% elements). With this it should be possible to have matrices
% inside matrices.

symbolic procedure mkn_matrix u;
   if length u neq 2 then rederr "Incorrect matrix arguments"
    else nlist(nlist(mkobject(0,'zero),cadr u),car u);

remprop('matrix,'stat);

ranks print u : {matrix} -> matrix;

symbolic procedure print_matrix u;
   matpri u;

put('matrix,'stat,'rlis);

put('matrix,'n_formfn,'n_formmatr);

symbolic procedure n_formmatr(u,vars);
   n_formstructure(u,vars,'matrix);

put('matrix,'getfn,'getell);

put('matrix,'putfn,'setell);

endmodule;

end;

symbolic procedure matprixxx(u,v); matpri1(u,v,nil);

% SYMBOLIC PROCEDURE nFORMMAT(U,VARS,MODE);
%    'LIST . MKQUOTE '!*MATrix!* . list('list .
%       FOR EACH X IN CDR U COLLECT
%            ('LIST . nFORMLIS(X,VARS,MODE)));

% PUT('MAT,'nFORMFN,'nFORMMAT);

%symbolic procedure nformmatrix(u,vars,mode);
%    if mode eq 'symbolic then rederr "no symbolic matrices supported"
%     else list('matrixfn,'list . for each j in cdr u collect
%                             <>);

% SYMBOLIC PROCEDURE MATRIXfn U;
%    for each j in u do
%     if null atom j then
%        begin scalar v,w;
%              v := cdr j;
%              FOR N := 1:CAR V DO W := NtaggedZERO CADR V . W;
%              return PUT(CAR J,'matVALUE,list('!*matrix!*,W))
%        end;

   %declares list U as matrices;
%  BEGIN SCALAR V,W,X;
%       FOR EACH J IN U DO
%       IF ATOM J THEN IF NULL (X := rTYPE J)
%                            THEN PUT(J,'RTYPE,'MAT)
%                           ELSE IF X EQ 'MAT
%                THEN <>
%               ELSE TYPERR(LIST(X,J),"matrix")
%            ELSE IF NOT IDP CAR J
%             THEN ERRPRI2(J,'HOLD)
%        ELSE IF NOT (X := rTYPE CAR J) OR X EQ 'MAT
%             THEN <>
%        ELSE TYPERR(LIST(X,CAR J),"matrix")
%  END;

% SYMBOLIC PROCEDURE NtaggedZERO N;
%    % Returns a list of N zeros.
%    IF N=0 THEN NIL ELSE list('!*integer!*,0) . NtaggedZERO(N-1);

% put('matrix,'nformfn,'nformmatrix);


%The *matrix* structure is no yet given an environment field.

% symbolic procedure !*matrix!* u;
%    begin
%      if atom u then return get(u,'matvalue);
%      return mateval list('!*matrix!*,u)
%    end;

% put('mat,'generic,'!*matrix!*);

% FLAG('(MAT),'STRUCT);      % for parsing

% PUT('MAT,'RTYPEFN,'(LAMBDA (X) 'MAT));

% PUT('!*MATrix!*,'RTYPEFN,'(LAMBDA (X) 'MAT));

put('!*matrix!*,'rtype,'mat);


symbolic procedure !*matrixplus2!*(u,v);
   list('!*matrix!*,for each j in
                        addm1(rvalue u,rvalue v,function cons)
                      collect addm1(car j,cdr j,
                                    function !*plus2!*));

symbolic procedure !*matrixdifference!*(u,v);
   list('!*matrix!*,for each j in
                        addm1(rvalue u,rvalue v,function cons)
                      collect addm1(car j,cdr j,
                                    function !*difference!*));

SYMBOLIC PROCEDURE ADDM(U,V);
   %returns sum of two matrix canonical forms U and V;
   FOR EACH J IN ADDM1(U,V,FUNCTION CONS)
      COLLECT ADDM1(CAR J,CDR J,FUNCTION ADDSQ);

SYMBOLIC PROCEDURE ADDM1(U,V,W);
   IF NULL U AND NULL V THEN NIL
    ELSE IF NULL U OR NULL V THEN REDERR "Matrix mismatch"
    ELSE APPLY(W,LIST(CAR U,CAR V)) . ADDM1(CDR U,CDR V,W);

symbolic procedure !*matrixtimes2!*(u,v);
   list('!*matrix!*,for each j in rvalue u collect
                      for each k in x collect scalprod(j,k))
    where x = tp1 rvalue v;

symbolic procedure scalprod(u,v);
   if null u and null v then '(!*integer!* 0)
    else if null u or null v then rederr "Matrix missmatch"
    else !*plus2!*(!*times2!*(car u,car v),
                   scalprod(cdr u,cdr v));

symbolic procedure !*scalar!*matrix!*(u,v);
   list('!*matrix!*,for each j in rvalue v collect
                      for each k in j collect !*times2!*(u,k));

symbolic procedure !*matrixexptn!*(u,n);
   %for now.
   if n < 0 then !*matrixexptn!*(mk!*matrix!* matinv mat2q u,-n)
    else begin scalar x,y;
           x := u;
           y := mateval u;
           while (n := n - 1) > 0 do
              x := !*matrixtimes2!*(mateval x,y);
           return x
         end;

% symbolic procedure !*dfmat!*(u,v);
%    list('!*matrix!*,for each j in rvalue mateval u collect
%                        for each k in j collect
%                             processdf list(k,v));

add!-generic!-table!-entry('difference,'(!*matrix!* !*matrix!*),
          '(lambda (x1 x2)
            (!*matrixdifference!* (mateval x1) (mateval x2))));

add!-generic!-table!-entry('expt,'(!*matrix!* !*integer!*),
          '(lambda (x1 x2)
            (!*matrixexptn!* x1 (rvalue x2))));

add!-generic!-table!-entry('minus,'(!*matrix!*),
          '(lambda (x1)
            (!*scalar!*matrix!* '(!*integer!* -1) (mateval x1))));

add!-generic!-table!-entry('plus2,'(!*matrix!* !*matrix!*),
          '(lambda (x1 x2)
            (!*matrixplus2!* (mateval x1) (mateval x2))));

%The next four are not generic definitions.

add!-generic!-table!-entry('quotient,'(!*matrix!* !*matrix!*),
          '(lambda (x1 x2)
            (mk!*matrix!* (multm (mat2q x1) (matinv (mat2q x2))))));

add!-generic!-table!-entry('quotient,'(!*integer!* !*matrix!*),
          '(lambda (x1 x2)
            (mk!*matrix!* (multsm (!*i2q (rvalue x1))
                                  (matinv (mat2q x2))))));

add!-generic!-table!-entry('quotient,'(!*kernel!* !*matrix!*),
          '(lambda (x1 x2)
            (mk!*matrix!* (multsm (kchk2q x1) (matinv (mat2q x2))))));

add!-generic!-table!-entry('quotient,'(!*sq !*matrix!*),
          '(lambda (x1 x2)
            (mk!*matrix!* (multsm (schk x1) (matinv (mat2q x2))))));

add!-generic!-table!-entry('quotient,'(!*matrix!* !*integer!*),
          '(lambda (x1 x2)
            (!*scalar!*matrix!*
                      (mk!*sq!* (canonsq (cons 1 (rvalue x2))))
                      (mateval x1))));

add!-generic!-table!-entry('quotient,'(!*matrix!* !*kernel!*),
          '(lambda (x1 x2)
            (!*scalar!*matrix!* (mk!*sq!* (invsq (kchk2q x2)))
                                (mateval x1))));

add!-generic!-table!-entry('quotient,'(!*matrix!* !*sq),
          '(lambda (x1 x2)
            (!*scalar!*matrix!* (mk!*sq!* (invsq (schk x2)))
                                (mateval x1))));

add!-generic!-table!-entry('times2,'(!*integer!* !*matrix!*),
          '(lambda (x1 x2) (!*scalar!*matrix!* x1 (mateval x2))));

add!-generic!-table!-entry('times2,'(!*matrix!* !*matrix!*),
          '(lambda (x1 x2)
            (!*matrixtimes2!* (mateval x1) (mateval x2))));

add!-generic!-table!-entry('times2,'(!*kernel!* !*matrix!*),
          '(lambda (x1 x2)
            (!*scalar!*matrix!* x1 (mateval x2))));

add!-generic!-table!-entry('times2,'(!*matrix!* !*kernel!*),
          '(lambda (x1 x2) (!*scalar!*matrix!* x2 x1)));

add!-generic!-table!-entry('times2,'(!*matrix!* !*integer!*),
          '(lambda (x1 x2) (!*scalar!*matrix!* x2 x1)));

add!-generic!-table!-entry('times2,'(!*sq !*matrix!*),
          '(lambda (x1 x2) (!*scalar!*matrix!* x1 x2)));

add!-generic!-table!-entry('times2,'(!*matrix!* !*sq),
          '(lambda (x1 x2) (!*scalar!*matrix!* x2 x1)));


%add!-generic!-table!-entry('print,'(!*matrix!*),
%          '(lambda (x1) (matpri!*2 x1 nil nil)));

add!-generic!-table!-entry('df,'(!*matrix!* !*kernel!*),
          '(lambda (x1 x2) (!*dfmat!* x1 x2)));
%this consruct is not easy to use and very restrictive.

put('!*matrix!*,'prefixfn,function (lambda x; x));

symbolic procedure mateval u;   %this is pretty bad!
   list('!*matrix!*,for each j in rvalue u collect
                      for each k in j collect
                        if eqcar(k,'!*matrix!*) then mateval k
                         else if eqcar(k,'!*integer!*) then k
                         else if renvironment k then k
                         else eval nform(mkprefix k,nil,'algebraic));

symbolic procedure mk!*matrix!* u;
   list('!*matrix!*,for each j in u collect
                      for each k in j collect mk!*sq!* k);

symbolic procedure matpri2(u,v);
   <>;

symbolic procedure matpri!*2(u,v,w);
   matpri2(rvalue u,if v then eval car v else nil);

make!-generic!-definition('det,1);

put('!*det!*,'generic!-function,'processdet);

symbolic procedure processdet u;
  mk!*sq!* detq mat2q u;

symbolic procedure mat2q u;
   for each j in rvalue u collect
     for each k in j collect schk sq k;

SYMBOLIC PROCEDURE TP1 U;
   %returns transpose of the matrix canonical form U;
   %U is destroyed in the process;
   BEGIN SCALAR V,W,X,Y,Z;
    V := W := LIST NIL;
    WHILE CAR U DO
     <>;
       W := CDR RPLACD(W,LIST CDR Y)>>;
    RETURN CDR V
   END;


add!-generic!-table!-entry('print,'(setmat),'(lambda (x)
  (matpri2 (rvalue (caddr x)) (cadr x))));

 add!-generic!-table!-entry('print,'(!*matrix!*),
      '(lambda (x) (matpri2 (rvalue x) "MAT")));

symbolic procedure !*matelem!* u;
   getmatelem u;

symbolic procedure setmatelem(u,v);
   'setmatel . u . letmtr(u,v,get(car u,'matvalue));

put('!*matelem!*,'rtype,'matelem);

put('matelem,'setfn,'setmatelem);

symbolic procedure nformmatelem (u,vars,mode);
   if cdddr u then errpri2(u,t)
    else list('!*matelem!*,mkmatel(u,vars,mode));

symbolic procedure mkmatel(u,vars,mode);
   'list . mkquote car u .
       for each x in cdr u collect list('mkinteger,nform(x,vars,mode));



SYMBOLIC PROCEDURE GETMATELEM U;
   BEGIN SCALAR X;
      X := rvalue GET(CAR U,'matVALUE);
      IF NOT x THEN REDERR LIST("Matrix",CAR U,"not set");
      u := cdr u;
      RETURN NTH(NTH(X,CAR U),CADR U)
   END;

SYMBOLIC PROCEDURE LETMTR(U,V,Y);
   %substitution for matrix elements;
   BEGIN SCALAR Z;
        z := cdr u;
    IF NOT Y THEN REDERR LIST("Matrix",CAR U,"not set");
    RPLACA(PNTH(NTH(rvalue Y,CAR Z),CADR Z),V);
        return v
   END;

symbolic procedure setmat(u,v);
   'setmat . u . list put(u,'matvalue,mateval v);

put('mat,'setfn,'setmat);

mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/reval4.red0000644000175000017500000000606011526203062023732 0ustar  giovannigiovannimodule reval4;   % Support for REDUCE 4 evaluation.

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The following selectors and constructors could be smacros.

symbolic procedure type u; car u;

% mkobject -- defined in block4.red.

symbolic procedure value u; cadr u;

symbolic procedure mknovalobj; mkobject(nil,'noval);

symbolic procedure getobject u;
   (if x and type x eq 'generic then n_form print value x else x)
    where x=get(u,'avalue);

symbolic procedure putobject(u,v,w);
   % Store value v for object u of type w.
   put(u,'avalue,mkobject(v,w));

% ---------------------------------------

symbolic procedure xtype(u,v);
   % True if type of u is liftable to type v.
   xtype1(type u,v);

symbolic procedure xtype1(u,v);
   if null type_in_pckgp u then nil
    else u eq v or xtypelist(get(u,'uptree),v);

symbolic procedure xtypelist(u,v);
   u and (xtype1(car u,v) or xtypelist(cdr u,v));

symbolic procedure rapply(u,v);
   % Apply generic operator u to argument list v.
%  type_reduce1 rapply1(u,v);   % Already done by rapply1.
   rapply1(u,v);

symbolic procedure rapply1(u,v);
   begin scalar x,y;
      % Look for named structure (e.g., array or matrix).
      if (x := getobject u) and (y := get(type x,'getfn))
        then return type_reduce1 apply2(y,x,v);
      x := for each j in v collect type j;
      y := type_function(u,x,v);
      if null y then if flagp(u,'opr) then u := eval_generic(u,v) else
        if null cdr x then rederr list(u,"not defined for type",car x) else
        rederr(u . "not defined for types" . x) else
       u := apply(car y,v);
%     if !*specification_reduce then
      u := type_reduce1 u;      % Always reduce to ground type for now.
      if null !*reduce4    % It must have been turned off.
        then return value u
       else return u
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/reduce4.rlg0000644000175000017500000003432711526203062024111 0ustar  giovannigiovanniNOTE: THIS IS NOT YET CORRECT, BUT REPRESENTS THE STATE OF THE TEST RUN
AS OF THE DATE OF THIS FILE.

Fri Mar  6 11:46:58 PST 1998
REDUCE Development Version, 28-Feb-98 ...

1: 1: 
2: 2: 
3: 3: 3: 3: 3: 3: 3: 3: 3: 
nil

4: 4: Comment This is a standard test file for REDUCE that has been used for
many years.  It only tests a limited number of facilities in the
current system.  In particular, it does not test floating point
arithmetic, or any of the more advanced packages that have been made
available since REDUCE 3.0 was released.  It has been used for a long
time to benchmark the performance of REDUCE.  A description of this
benchmarking with statistics for REDUCE 3.2 was reported in Jed B.
Marti and Anthony C. Hearn, "REDUCE as a Lisp Benchmark", SIGSAM Bull.
19 (1985) 8-16.  That paper also gives information on the the parts of
the system exercised by the test file.  Updated statistics may be found
in the "timings" file in the REDUCE Network Library;


showtime;


Time: 0 ms


on reduce4;



of type: noval
  % For the time being.

comment some examples of the FOR statement;


comment summing the squares of the even positive integers
	through 50;


for i:=2 step 2 until 50 sum i**2;


22100

of type: bint


comment to set  w  to the factorial of 10;


w := for i:=1:10 product i;


3628800

of type: bint


comment alternatively, we could set the elements a(i) of the
	array  a  to the factorial of i by the statements;


array a(10);



of type: noval


a(0):=1$


of type: nzint


for i:=1:10 do a(i):=i*a(i-1);


nil

of type: variable


comment the above version of the FOR statement does not return
	an algebraic value, but we can now use these array
	elements as factorials in expressions, e. g.;


1+a(5);


121

of type: nzint


comment we could have printed the values of each a(i)
	as they were computed by writing the FOR statement as;


for i:=1:10 do write "a(",i,") := ",a(i):= i*a(i-1);

a(1) := 1

a(2) := 2

a(3) := 6

a(4) := 24

a(5) := 120

a(6) := 720

a(7) := 5040

a(8) := 40320

a(9) := 362880

a(10) := 3628800


nil

of type: variable


comment another way to use factorials would be to introduce an
operator FAC by an integer procedure as follows;


procedure fac(n:int)
   begin local m:int;
	m:=1;
    l1:	if n=0 then return m;
	m:=m*n;
	n:=n-1;
	go to l1
   end;


fac

of type: variable


comment we can now use  fac  as an operator in expressions, e. g.;


z**2+fac(4)-2*fac 2*y;


          2
 - 4*y + z  + 24

of type: xpoly


comment note in the above example that the parentheses around
the arguments of FAC may be omitted since it is a unary operator;


comment the following examples illustrate the solution of some
	complete problems;


comment the f and g series (ref  Sconzo, P., Leschack, A. R. and
	 Tobey, R. G., Astronomical Journal, Vol 70 (May 1965);


deps:= -sigma*(mu+2*epsilon)$


of type: xpoly

dmu:= -3*mu*sigma$


of type: xpoly

dsig:= epsilon-2*sigma**2$


of type: xpoly

f1:= 1$


of type: nzint

g1:= 0$


of type: zero

 
for i:= 1:8 do 
 < instead of = in rules 

*** Please use => instead of = in rules 


of type: noval
 

ga(-p2)*g(la,ix)*ga(-p4)*g(la,iy)* (gb(p3)*g(lb,ix)*gb(qi)


ga(-p2)*g(la,ix)*ga(-p4)*g(la,iy)*(gb(p3)*g(lb,ix)*gb(qi) $$$


***** Too few right parentheses 

    *g(lb,iz)*gb(p1)*g(lb,iy)*gb(q2)*g(lb,iz)   +   gb(p3)



***** g not defined for types variable variable 
    *g(lb,iz)*gb(q2)*g(lb,ix)*gb(p1)*g(lb,iz)*gb(qi)*g(lb,iy))$

$*g(lb,iz)*gb(q2)*g(lb,ix)*gb(p1)*g(lb,iz)*gb(qi)*g(lb,iy)$$$)

***** Too many right parentheses 



let qi=p1-k1, q2=p3+k1;


*** Please use => instead of = in rules 

*** Please use => instead of = in rules 


of type: noval


comment it is usually faster to make such substitutions after all the
	trace algebra is done;


write "CXN =",ws;

                                   p1(x(1))
      2*(df(p1(x(1)),x(1))*x(1) + e         - 1)
CXN =--------------------------------------------
                    p1(x(1))     2
                   e        *x(1)



of type: noval


comment end of second physics example;
 

showtime;


Time: 2346 ms  plus GC time: 51 ms


of type: noval


end;


of type: noval

5: 5: 5: 5: 5: 5: 5: 
if(*_yyy_*:=gctime()+-*_yyy_*)>0 $$$


***** ; invalid in if statement 

6: 
;, plus GC time:  prin2<<$$$then

***** Improper delimiter 


*_yyy_**_yyy_*

of type: variable

8: 
 ms ms

of type: string


$>>terpri()>$$$>

***** Improper delimiter 

10: 10: 
Quitting
Fri Mar  6 11:47:01 PST 1998
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/package4.red0000644000175000017500000002454111526203062024220 0ustar  giovannigiovannimodule package4;   % Package support for REDUCE 4.

% Author:  Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


remd 'package; % Don't interfere with existing.

fluid '(curr_pckg!*);

% Packages are stored on the property list of their names
% with their package type as indicator. The first element
% of the property is the base of the package, the second is
% an a-list associating types with their internal types
% and the last element is the package body.

symbolic procedure read_package;
   % Reader for a package (assertions) unit.
   begin scalar pckgtyp,pckg,body,tmp,x;
     pckgtyp := cursym!*;
     body := pckg := read_package_name();
     tmp := cdr pckg;
     if (x := scan()) eq 'extends
        then <>;
     a: if x eq 'package
           then lprie {"Nested package definition not allowed"};
        x := xread1 t;
        if null atom x and (car x memq '(endpackage endassertions))
           then return pckgtyp . body;
        tmp := cdr rplacd(tmp,{x});
        x := scan();
        go to a
   end;

symbolic procedure read_package_name;
   % reader for package header. Takes care of package typed
   % arguments.
   begin scalar n,x,y,z;
     n := scan();
     if null(scan() eq '!*lpar!*) then return {n,nil};
     a: x := scan();
        if not idp x then typerr(x,"parameter");
        y := scan();
        if y eq '!*colon!* then go to assertion;
     b: if y eq '!*comma!* then progn(z := x . z, go to a)
         else if y eq '!*rpar!*
                 then if scan() eq '!*semicol!*
                         then return n . {reversip(x . z)};
     assertion:
      x := x . read_type();
      y := cursym!*;
      go to b
   end;


put('package,'stat,'read_package);
put('assertions,'stat,'read_package);
put('endpackage,'stat,'endstat);
put('endassertions,'stat,'endstat);

symbolic procedure n_form_package(u,vars);
   begin scalar pckg_typ,pckg_name,pckg_parms,enr,mi,x;
     pckg_typ := car u;
     u := cdr u;
     pckg_name := car u; % must do more if parametrized.
   %%-- add check if pckg_name already exists.
     u := cdr u;
     pckg_parms := car u;
   %%-- the execution of the next statement should probably be defered
   %%   until the package parameters are bound. Otherwise we need to
   %%   have all assertions defined prior the definition of the
   %%   parametrized package using it.
   %%   What tags are we going to use?
     if pckg_parms then
        mi := for each arg in pckg_parms collect
                <>;
     u := cdr u;
     if null u then rederr{"empty package",pckg_name};
     enr := if null eqcar(car u,'extends)
               then form_extends_pckg(pckg_name,nil,u)
     % The above line causes a base package to be interpreted
     % as extending an empty package. We might want to have this
     % a combine operation.
             else form_extends_pckg(pckg_name,form_pckg_expr cadar u,cdr u);
     % Now we must update the appropriate env.
     if pckg_parms
        then (if pckg_typ eq 'package
                then <>
              else if pckg_typ eq 'assertions
                then <<"to be filled in">>)
      else mk_new_base_env(pckg_name,(pckg_name . car enr) . cdr enr);
    %%-- still need assertions
     enr := cdr enr;
     if enr and eqcar(car enr,'types) then enr := cdr enr;
     if null pckg_parms and (pckg_typ eq 'package)
        then return {'noval,'progn . for each j in enr
                                       collect cadr n_form1(j,vars)};
     return mknovalobj()
   end;

symbolic procedure types u; nil;
flag('(types),'non_form);

symbolic procedure mk_new_base_env(u,v);
   <>;

symbolic procedure get_pckg u;
   get(u,'base_pckg);

symbolic procedure mk_new_assertion_env(u,v);
   put(u,'assertion_pckg,v);

symbolic procedure mk_new_param_env(u,v,w);
   put(u,'param_pckg,{v,w});

symbolic procedure rm_base_env u;
   for each m in u do remprop(car m,'base_pckg);

symbolic procedure pckg_base u; car u;

symbolic procedure copy_assertions(u,tag);
   begin scalar x,y,sl;
     for each base in pckg_base u do
       if (x := atsoc('types,get(base,'base_pckg)))
          then y := append(cddr x,y);
     sl := mk_retag_sl(y,u,tag);
     return {nil,retag_package(cdr u,sl)}
   end;

symbolic procedure mk_retag_sl(u,v,tag);
   % u contains the package tags that are to be preserved.
   begin scalar x,y,z;
     if x := atsoc('types,v) then x := cddr x;
     tag := append(tag,'(!:));
     for each el in x do
       if null rassoc(cdr el,u)
          then y := (cdr el . <>) . y;
     return y
   end;

symbolic procedure retag_package(u,sl);
   % Copies a package (without its base) and retags types
   % according to the a-list sl.
   if null u then nil
    else if eqcar(car u,'types) or
            eqcar(car u,'subtyperels) or
            eqcar(car u,'ranks)
            then subla(sl,car u) . retag_package(cdr u, sl)
    else if eqcar(car u,'procedure)
            then (caar u . cadar u . subla(sl,caddar u) .
                  car cdddar u . subla(sl,cadr cdddar u) .
                  cddr cdddar u) . retag_package(cdr u, sl);


put('package,'n_formfn,'n_form_package);
put('assertions,'n_formfn,'n_form_package);
put('package,'formfn,'n_form_package);    %just for test under 3.x
put('assertions,'formfn,'n_form_package); %just for test under 3.x


symbolic procedure form_pckg_expr u;
   if atom u then get_pckg u
    else if car u eq 'plus
      then pckg_combine for each arg in cdr u
                          collect form_pckg_expr arg
      else mk_parametrized_pckg u;

symbolic procedure pckg_combine u;
   begin scalar base,body,typs;
 %% All we actually need to return is the new base and an
 %% empty extend. We have to see if this is sufficiently
 %% efficient...
     base := caar u;
     typs := cadar u;
     for each pckg in cdr u do
       <>;
     return {base,typs,body}
   end;

symbolic procedure form_extends_pckg(p,u,v);
   % New types and ops must get a package prefix.
   % Type-relations must accordingly be translated.
   % Op-definitions must be adjusted to new environment.
   % Take care of private (hidden) types.
   begin scalar prefix,ta,x;
    prefix := append(explode p,'(!:));
    if ta := atsoc('types,v)
       then for each typl on cdr ta do
              rplaca(typl,car typl .
               <>);
    ta := cdr ta;
%% - check if we can really do this destructively. Would like to
%    get rid of it anyhow.
    if x := atsoc('types,u) then nconc(ta,cdr x);
   % we still need to lookup the type names for explicitly mentioned
   % types from the imported packages base.
    if x := atsoc('subtyperels,v) then
       rplacd(x,subla(ta,cdr x));
    if x := atsoc('ranks,v) then
       rplacd(x,subla(ta,cdr x));
    for each j in v do
      if eqcar(j,'procedure)
         then <>;
    return (if u then pckg_base u else nil) . v
   end;

symbolic procedure mk_prefix(u,v);
   intern compress append(u,explode v);


%% -- views

symbolic procedure read_view;
   % very primitive reader for views
   begin scalar target,source;
     target := scan();
     if null(scan() eq 'as) then lprie {"keyword 'as' expected"};
     source := scan();
     if null(scan() eq 'with) then lprie {"keyword 'with' expected"};
     return {'view,target,source,xread t}
   end;

symbolic procedure bind_param_package(pckg,views);
   begin scalar x,y,z,sl;
     x := get(pckg,'param_pckg);
%     sl :=
     z := retag_package(car x,sl);
     y := pckg_combine for each v in views collect cadr v;
     return pkg_base car x . y
   end;

%%--

symbolic procedure pckg_geq(u,v);
   (u eq v) or pckg_geql(get(u,'package_dag),v);

symbolic procedure pckg_geql(u,v);
   u and (pckg_geq(car u,v) or pckg_geql(cdr u,v));

symbolic procedure op_in_pckgp u;
   pckg_geq(curr_pckg!*,u);

symbolic procedure type_in_pckgp u;
   pckg_geq(curr_pckg!*,get(u,'package_orig));

symbolic procedure pckg_type u;
  %%% very provisional.....
   begin scalar x,y;
     if null curr_pckg!* then return u;
     x := atsoc('types,get(curr_pckg!*,'base_pckg));
     if null x then return u;
     y := assoc(u,cdr x);
     return if y then cdr y else u
   end;

symbolic procedure pckg_op_chk u;
   if null u then nil
    else if null curr_pckg!* then u
    else if op_in_pckgp u then u
    else nil;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/simp4.red0000644000175000017500000001276411526203062023601 0ustar  giovannigiovannimodule simp4;   % REDUCE 4 extensions for simplification.

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(zero);

symbolic procedure ideval u;
   % Find true (dynamic) value of id u.
%  (if x then x else list('variable,u)) where x=getobject u;
   kernelvalue u;

symbolic procedure kernelvalue u;
   % Return value of untagged kernel u.
   begin scalar x;
      if null subfg!* then return type_reduce(u,'kernel)
       else if x := assoc(u,wtl!*)
        then return if null car(x := mksq('k!*,cdr x)) then x else % *****
                  type_reduce(multsq(x,!*p2f getpower(car fkern u,1) ./ 1),
                              'ratpol)
       else if atom u
        then <>
       else if null !*nosubs and (x := assoc(u,get(car u,'kvalue)))
         % Old-style kernel value without type.
        then return simp4 cadr x
       else if not('used!* memq cddr (x := fkern u))
        then aconc(x,'used!*);
      return mkobject(car x,'xkernel)
   end;

symbolic procedure eval_generic(fn,u);
   % Evaluate a generic function fn with arguments u.
   % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1
   % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a
   % loop in the pattern matcher.
   begin scalar x,y,z;
    u := for each j in u collect
             if x := get(type j,'prefix_convert)
               then apply1(x,value j) else value j;
    if u and car u=0 and flagp(fn,'odd) and not flagp(fn,'nonzero)
      then return ZERO;
    u := fn . u;
    if flagp(fn,'noncom) then ncmp!* := t;
    if null subfg!* then go to c
     else if (z := value(x := kernelvalue u)) neq u then return x;
    u := z;   % Make sure it's unique.
    if flagp(fn,'linear) and (z := formlnr u) neq u
      then return simp4 z
     else if z := opmtch u then return simp4 z
   ;%else if z := get(car u,'opvalfn) then return apply1(z,u);
    c:  if flagp(fn,'symmetric) then u := fn . ordn cdr u
     else if flagp(fn,'antisymmetric)
      then <>;
    if (flagp(fn,'even) or flagp(fn,'odd))
       and x and minusf numr(x := simp car x)   % ******
     then <>;
    u := mksq(u,1);
    if y then u := negsq u;
    return type_reduce(u,'ratpol)
   end;

symbolic procedure simp4!* u;
   % This procedure applies REDUCE 3-style rules to a REDUCE 4 expr.
   % It operates similarly to simp!* for scalar expressions.
   % It should disappear eventually.
   begin scalar !*asymp!*,x;
      if (x := type u) memq '(nzint variable zero) then return u
       else if x eq 'xpoly then u := value u ./ 1
       else if x eq 'xratpol then u := value u
       else rederr {"No simplification for type",x};
      u := subs2 u;
      if !*combinelogs then u := clogsq!* u;
      % Must be here, since clogsq!* can upset girationalizesq!:.
      % For defint, it is necessary to turn off girationalizesq - SLK.
      if dmode!* eq '!:gi!: and not !*norationalgi
        then u := girationalize!: u
       else if !*rationalize then u := rationalizesq u
       else u := rationalizei u;
      % If any leading terms have cancelled, a gcd check is required.
      if !*asymp!* and !*rationalize then u := gcdchk u;
      return type_reduce(u,'ratpol)
   end;

symbolic procedure simp4 u; type_reduce(simp u,'ratpol);

put('xpoly,'prefix_convert,'prepf);

put('xratpol,'prefix_convert,'prepsqxx);

% Flag all generic operators.

% However, mapobl isn't defined in CSL.

%  mapobl function
%  (lambda j; if (get(j,'simpfn) eq 'simpiden) then flag(list j,'opr));

flag('(cos sin),'opr);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/form4.red0000644000175000017500000002635111526203062023571 0ustar  giovannigiovannimodule form4;   % Type analysis for REDUCE 4.

% Authors:  Anthony C. Hearn, Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*specification !*specification_reduce !*generate_retracts
        !*instantiate);

switch instantiate,specification;

% If the switch specification is on, all expression are checked for type
% consistency at form-time. For this to work it is necessary that all
% ranks and type relations are set up prior to function definitions.
% In the code below any n_form function is required to return a list
% whose first element is the ceiling type of the formed expression and
% the second element is the formed expression. The toplevel function
% n_form returns only the formed expression.

%!*specification := t;

symbolic procedure n_form u;
   % Car of n_form1 is the ceiling type.  Cadr is a typed expression.
   cadr n_form1(u,!*vars!*);

symbolic procedure n_form1(u,vars);
   begin scalar x,z,ctype,arity_pairs,args,fnc;
      return if atom u
     then if numberp u
            then if fixp u
                    then if u=0
                            then <>
                          else <>
             else {'float,mkquote list('float,u)}
           else if stringp u then {'string,mkquote {'string,u}}
           else if arrayp u then {'array,mkquote {'array,u}}
           else if x := atsoc(u,vars) then {cdr x, u}
%          else if (x := get(u,'type)) then mkquote {x,mkquote u}
%               % type_reduce
           else if x := get(u,'avalue)
                then {type x,{'ideval,mkquote u}}
           else {x := pckg_type 'variable,{'ideval,mkquote u}}
    else if not idp car u then typerr(car u,"operator")
    else if (null cdr u and car u neq 'list) or flagp(car u,'non_form)
     then {'non_form,u}
    else if flagp(car u,'non_form) then {'non_form,u}
    else if (x := get(car u,'n_formfn)) then apply2(x,u,vars)
    % See if a direct result can be formed.
    else if x := get(car u,'xform)
     then x . for each j in cdr u collect n_form1(j,vars)
    else <>;
           if !*instantiate and fnc
%            then {ctype,mk_type_reduce(car fnc . args,ctype)}
             then {ctype,{'type_reduce1,car fnc . args}}
 %           else if !*specification_reduce
 %             then {ctype,{'type_reduce1,
 %                          {'rapply,mkquote car u,'list . args},ctype}}
            else
           {ctype,{'rapply,mkquote car u,'list . args}}>>
   end;



symbolic procedure mk_type_reduce(u,v);
   % We must not call type_reduce when defining a sort constraint for
   % type v, as we would loop otherwise.
   if flagp(v,'defining) then mkquote {v,u}
    else {'type_reduce,u,mkquote v};

symbolic procedure type_function2(fn,typelist,args);
   % Returns disambiguated function symbol for fn.
   % If retracts are necessary, typelist is destructively changed.
   % Type constraints are ignored as we are here only interested
   % in ceiling types and more information can only be derived
   % by formal proofs.
   begin scalar x;
      return if (x := get(fn,'ranks))
                and (x := assoc(length typelist,x))
                and (x := type_assocf(typelist,cdr x,args))
               then x
              else nil
   end;

symbolic procedure type_assocf(typelist,type_assoc_list,args);
   % Determine if there's a match for typelist in type_assoc_list.
   begin scalar x;
     if x :=
        type_assoc1f(car typelist,cdr typelist,type_assoc_list,args)
        then return x
      else if x := atsoc('generic,type_assoc_list)
        then return cdr x
      else return nil
   end;


symbolic procedure type_assoc1f(type,typelist,type_assoc_list,args);
   begin scalar x,y,z;
      if (type_in_pckgp type and
          (x := type_assoc0f(type,type_assoc_list)))
%         or (x := atsoc('generic,type_assoc_list))
        then if null typelist
        then return ceiling_of_constraints cdaddr cdr x
         % We assume termination with the actual name of function here.
       else if y := type_assoc1f(car typelist,cdr typelist,cdr x,args)
               then return y;
      if z := get(car type,'uptree)
        then <>
       else return nil
   end;

symbolic procedure ceiling_of_constraints u;
   if null u then nil
    else if caar u eq t then cadadr car u
    else ceiling_of_constraints cdr u;

symbolic procedure type_assoc0f(type,type_assoc_list);
   if null type_assoc_list then nil
    else if car type eq caar type_assoc_list  then car type_assoc_list
    else if xtype1(caar type_assoc_list,car type) and !*specification
            then < ",caar type_assoc_list};
                   car type_assoc_list; rplacd(type,{caar type_assoc_list});
                   car type_assoc_list>>
% The above finds a resolution but it might be lower than intended.
% Is the solution to find the closest node or need we to generate all????
    else type_assoc0f(type,cdr type_assoc_list);


flag('(load),'non_form);

put('type,'xform,'type_1);

symbolic procedure type_1 u; list('variable,type u);

symbolic procedure n_formbool(u,vars);
 %%% Should we check if type of u is liftable to bool ???
 %%% Would like to get rid of n_boolvalue*.
   begin scalar x;
     if atom u then if u eq 't then return {'bool,u}
      else if x := atsoc(u,vars)
              then if (cdr x eq 'bool) or (cdr x eq 'generic)
                      then return {'bool,list('n_boolvalue!*,u)}
                    else rederr {"a boolean was expected, but got",cdr x};
     x := n_form1(u,vars);
     if null((type x eq 'bool) or (type x eq 'generic))
        then rederr {"a boolean was expected, but got",type x};
     return {'bool,list('n_boolvalue!*,value x)}
   end;

symbolic procedure n_boolvalue!* u; (v and null(v = 0)) where v=value u;

%  --- COND ---

symbolic procedure n_formcond(u,vars);
   {type x,'cond . value x} where x = n_formcond1(cdr u,vars);

symbolic procedure n_formcond1(u,vars);
   % We need to consider generic a bit more carefully here.
   begin scalar v,eptr,x,restype;
     v := eptr := {nil};
     a: if null u then return {restype,cdr v};
        x := n_form1(cadar u,vars);
        if null restype
           then restype := type x
         else if xtype1(type x,restype) then nil
         else if xtype1(restype,type x) then restype := type x
         else rederr {"types in conditional",type x,"and",restype,
                      "are unrelated"};
        eptr := cdr rplacd(eptr,{{value n_formbool(caar u,vars),
                                  value x}});
        u := cdr u;
        go to a
    end;

put('cond,'n_formfn,'n_formcond);

%  --- LIST ----

symbolic procedure n_formlist(u,vars); % parametrization ??? very crude version
   begin scalar x,y,eltype;
     if null cdr u then return {'empty_list,''(empty_list nil)};
     x := n_form1(cadr u,vars);
     eltype := type x;
     y := value x;
     y := y . for each j in cddr u
                  collect <>;
     return {'non_empty_list,{'mklistt,'list . y}}
   end;

symbolic procedure mklistt u;   %%% this is not consistent with others
   type_reduce(u,'list);

put('list,'n_formfn,'n_formlist);


%  --- PROGN ---

symbolic procedure n_formprogn(u,vars);
   begin scalar restype,x;
     x := for each j in cdr u
             collect <>;
     return {type restype,'progn . x}
   end;

put('progn,'n_formfn,'n_formprogn);

%  --- SETQ ---

symbolic procedure n_formsetq(u,vars);
   begin scalar x,y,z;
   % Note that target type (car z) is target type of assignment.
   z := n_form1(caddr u,vars);
   if idp cadr u and (x := atsoc(cadr u,vars)) then
     <> else
    if not atom cadr u and (x := getobject caadr u)
       and (y := get(type x,'putfn)) then
     return {car z,{y,mkquote x,'list . for each j in cdadr u collect
                        cadr n_form1(j,vars),cadr z}} else
     return {car z,{'rapply,mkquote 'setq,{'list,
                      {'mkobject,mkquote cadr u,mkquote 'variable},
                      cadr z}}}
   end;

put('setq,'n_formfn,'n_formsetq);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/table1.red0000644000175000017500000004016711526203062023713 0ustar  giovannigiovannimodule table1;

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(zero);

%---------

subtypes sint bint < int, zero nzint < sint;

ranks abs u: {int} -> int,
      u < v: {int,int} -> bool,
      u <= v: {int,int} -> bool,
      u > v: {int,int} -> bool,
      u >= v: {int,int} -> bool,
      u:int -> sint when abs u < 5000,
      u:int -> bint when abs u >= 5000,
      u:sint -> zero when u = 0,
      u:sint -> nzint when not(u=0); % not a good type name.

symbolic procedure abs_int u; mkobject(abs value u,'int);

symbolic procedure lessp_int_int(u,v); mkobject(value u < value v,'bool);

symbolic procedure leq_int_int(u,v); mkobject(value u<=value v,'bool);

symbolic procedure greaterp_int_int(u,v); mkobject(value u >= value v,'bool);

symbolic procedure geq_int_int(u,v); mkobject(value u >= value v,'bool);

symbolic procedure equal_int_int(u,v); mkobject(value u = value v,'bool);

%---------

remflag('(and or),'nary);

ranks u and v : {bool,bool} -> bool,
      u or v : {bool,bool} -> bool,
      not u : {bool} -> bool;

symbolic procedure and_bool_bool(u,v); mkobject(value u and value v,'bool);

symbolic procedure or_bool_bool(u,v); mkobject(value u or value v,'bool);

symbolic procedure not_bool u; mkobject(null value u,'bool);

%---------

subtypes zero int kernel xpoly < poly, sint bint < int, zero nzint < sint,
         variable xkernel < kernel, zero poly xratpol < ratpol;

ranks fixp u : {poly} -> bool,
      idp u : {poly} -> bool,
      u:poly -> zero when u=0,
      u:poly -> int when fixp u,
      u:poly -> kernel when kernelp u,
      u:poly -> xpoly when not fixp u and not idp u and not kernelp u;

ranks u:kernel -> variable when idp u;

symbolic procedure kernelp u;
   null domainp u and null red u and lc u =1 and ldeg u = 1;

symbolic procedure fixp_poly u; mkobject(fixp value u,'bool);

symbolic procedure idp_poly u; mkobject(idp value u,'bool);

symbolic procedure poly!>kernel u;
   mkobject(mvar value u,'kernel);


% --------------- rational --------------------

ranks den u : {ratpol} -> poly;  % should be strengthened

ranks u:ratpol -> poly when denr u = 1,
      u:ratpol -> xratpol when denr u neq 1;

symbolic procedure den_ratpol u; mkobject(denr value u,'poly);

symbolic procedure ratpol!>poly u;
   mkobject(numr value u,'poly);


% -----  +  -----

ranks u + v : {sint,sint} -> int,
      u + v : {int,int} -> int,
      u + v : {int,poly} -> poly,
      u + v : {poly,int} -> poly,
      u + v : {kernel,kernel} -> poly,
      u + v : {xpoly,xpoly} -> poly,
      u + v : {kernel,poly} -> poly,
      u + v : {poly,kernel} -> poly;

symbolic procedure plus_sint_sint(u,v);
   mkobject(value u #+ value v,'int);

symbolic procedure plus_int_int(u,v);
  mkobject(value u+value v,'int);

symbolic procedure plus_poly_poly(u,v);
   if type u eq 'zero then v else
      if type v eq 'zero then u else
      if xtype(u,'int) then plus_int_poly(u,v) else
      if xtype(v,'int) then plus_int_poly(v,u) else
      if xtype(u,'kernel) then plus_kernel_poly(u,v) else
      if xtype(v,'kernel) then plus_kernel_poly(v,u) else
      plus_xpoly_xpoly(u,v);

symbolic procedure plus_xpoly_xpoly(u,v);
   mkobject(addf!*(value u,value v),'poly);

symbolic procedure addf!*(u,v);
   (if null x then 0 else x) where x=addf(u,v);

symbolic procedure plus_int_poly(u,v);
   if type u eq 'zero then v else mkobject(addd!*(u,v),'poly);

symbolic procedure plus_poly_int(u,v);
   plus_int_poly(v,u);

symbolic procedure addd!*(u,v);
   if xtype(v,'kernel) then addd(value u,!*k2f value v) else
    addd(value u,value v);

symbolic procedure plus_kernel_kernel(u,v);
   mkobject(addf(!*k2f value u,!*k2f value v),'poly);

symbolic procedure plus_kernel_poly(u,v);
   mkobject(addf!*(!*k2f value u,value v),'poly);


ranks u + v : {xratpol,xratpol} -> ratpol,
      u + v : {poly,xratpol} -> ratpol,
      u + v : {xratpol,poly} -> ratpol;


symbolic procedure plus_xratpol_poly(u,v);
   plus_poly_xratpol(v,u);

symbolic procedure plus_poly_xratpol(u,v);
   % Add a polynomial to non-zero rational.
   begin scalar x,y,z;
      x := mkobject(denr value v,'poly);
      y := times_poly_poly(u,x);
      z := plus_poly_poly(y,mkobject(numr value v,'poly));
      return mkobject(value z ./value x,'xratpol)
   end;

symbolic procedure plus_xratpol_xratpol(u,v);
   mkobject(xaddsq(value u,value v),'ratpol);

symbolic procedure xaddsq(u,v);
   % U and V are non-zero standard quotients.
   % Value is canonical sum of U and V.
   begin scalar x,y,z;
        if null !*exp then <>;
        if !*lcm then x := gcdf!*(denr u,denr v)
         else x := gcdf(denr u,denr v);
        z := canonsq(quotf(denr u,x) ./ quotf(denr v,x));
        y := addf(multf(denr z,numr u),multf(numr z,numr v));
        if null y then return nil ./ 1;
        z := multf(denr u,denr z);
        return if x=1 or (x := gcdf(y,x))=1 then y ./ z
                else canonsq(quotf(y,x) ./ quotf(z,x))
    end;

% -----  -  -----

ranks - u : {int} -> int,
      - u : {kernel} -> poly,
      - u : {poly} -> poly,
      - u : {ratpol} -> ratpol,
      u - v : {int,int} -> int,
      u - v : {int,poly} -> poly,
      u - v : {poly,int} -> poly,
      u - v : {kernel,kernel} -> poly,
      u - v : {poly,poly} -> poly,
      u - v : {ratpol,ratpol} -> ratpol;


symbolic procedure minus_int u; mkobject(-value u,'int);

symbolic procedure difference_int_int(u,v);
   mkobject(value u-value v,'int);

symbolic procedure difference_poly_poly(u,v);
   if type u eq 'zero then minus_poly v else
      if type v eq 'zero then u else
%     if xtype(u,'int) then difference_int_poly(u,v) else
%     if xtype(v,'int)
%       then rapply('minus,list difference_int_poly(v,u)) else
      if xtype(u,'kernel) then difference_kernel_poly(u,v) else
      if xtype(v,'kernel)
        then rapply('minus,list difference_kernel_poly(v,u)) else
      difference_xpoly_xpoly(u,v);

symbolic procedure difference_int_poly(u,v);
   if type u eq 'zero then minus_poly v else
   mkobject(difference!*(u,v),'poly);

symbolic procedure difference_poly_int(u,v);
   if type v eq 'zero then u else
   mkobject(negf difference!*(v,u),'poly);

symbolic procedure difference!*(u,v);
   if xtype(v,'kernel) then addd(value u,negf !*k2f value v) else
    addd(value u,negf value v);

symbolic procedure difference_kernel_kernel(u,v);
   (if null x then ZERO else
     mkobject(x,'poly)) where x=addf(!*k2f value u,negf !*k2f value v);

symbolic procedure difference_kernel_poly(u,v);
   plus_kernel_poly(u,minus_poly v);

symbolic procedure minus_ratpol u;
      if xtype(u,'poly) then minus_poly u else minus_xratpol u;

symbolic procedure minus_xratpol u;
      mkobject(negsq value u,'xratpol);

symbolic procedure minus_poly u;
   if type u eq 'zero then u else
      if xtype(u,'int) then minus_int u else
      if xtype(u,'kernel) then minus_kernel u else
      minus_xpoly u;

symbolic procedure minus_kernel u;
   mkobject(negf !*a2f value u,'xpoly);

symbolic procedure minus_xpoly u;
   mkobject(negf value u,'poly);

symbolic procedure difference_xpoly_xpoly(u,v);
   mkobject(addf!*(value u,negf value v),'poly);

symbolic procedure difference_ratpol_ratpol(u,v);
   if type u eq 'zero then minus_ratpol v else
   if type v eq 'zero then u else
   if xtype(u,'poly)
    then plus_poly_xratpol(u,minus_xratpol v) else
   if xtype(v,'poly) then plus_poly_xratpol(minus_poly v,u) else
   plus_xratpol_xratpol(u,minus_xratpol v);

% -----  *  -----

ranks u*v : {sint,sint} -> int,
      u*v : {int,int} -> int,
      u*v : {int,poly} -> poly,
      u*v : {poly,int} -> poly,
      u*v : {poly,poly} -> poly,
      u*v : {xpoly,xpoly} -> poly,
      u*v : {kernel,kernel} -> poly,
      u*v : {ratpol,ratpol} -> ratpol;


symbolic procedure times_sint_sint(u,v);
   mkobject(value u * value v,'int);   % #* would be better.

symbolic procedure times_int_int(u,v);
  mkobject(value u*value v,'int);

symbolic procedure times_int_poly(u,v);
   if type u eq 'zero then u else mkobject(multd!*(u,v),'poly);

symbolic procedure times_poly_int(u,v);
   times_int_poly(v,u);

symbolic procedure multd!*(u,v);
   if xtype(v,'kernel) then multd(value u,!*k2f value v) else
    multd(value u,value v);

symbolic procedure times_kernel_kernel(u,v);
   mkobject(multf(!*k2f value u,!*k2f value v),'poly);

symbolic procedure times_kernel_poly(u,v);
   mkobject(multf(!*k2f value u,value v),'poly);

symbolic procedure times_poly_poly(u,v);
   if type u eq 'zero then u else
      if type v eq 'zero then v else
      if xtype(u,'int) then times_int_poly(u,v) else
      if xtype(v,'int) then times_int_poly(v,u) else
      if xtype(u,'kernel) then times_kernel_poly(u,v) else
      if xtype(v,'kernel) then times_kernel_poly(v,u) else
      times_xpoly_xpoly(u,v);

symbolic procedure times_xpoly_xpoly(u,v);
   mkobject(multf(value u,value v),'poly);


symbolic procedure times_ratpol_ratpol(u,v);
   % Note that if u is a poly,  v must be a xratpol, since a poly would
   % be caught by times_poly_poly.
   if type u eq 'zero then u else
   if type v eq 'zero then v else
   if xtype(u,'poly) then times_poly_xratpol(u,v) else
   if xtype(v,'poly) then times_poly_xratpol(v,u) else
   times_xratpol_xratpol(u,v);

symbolic procedure times_poly_xratpol(u,v);
   if xtype(u,'kernel)
     then mkobject(xmultsq(!*k2q value u,value v),'ratpol) else
   % Next line catches other poly cases (int and xpoly)
    mkobject(xmultsq(!*f2q value u,value v),'ratpol);

symbolic procedure times_xratpol_xratpol(u,v);
   mkobject(xmultsq(value u,value v),'ratpol);

symbolic procedure xmultsq(u,v);
   % Doesn't need zero etc check.
   multsq(u,v);

% -----  ^  -----

ranks u^n : {int,int} -> int,    % n should be restricted to posint
      u^n : {poly,int} -> poly,
      u^n : {xratpol,int} -> ratpol,
      u^v : {ratpol,ratpol} -> ratpol;

symbolic procedure expt_int_int(u,v); mkobject(value u**value v,'int);

fluid '(ONE);

ONE := mkobject(1,'nzint);

symbolic procedure expt_poly_int(u,v);
   if type v eq 'zero then ONE else
    if xtype(u,'int) then expt_int_int(u,v) else
    if xtype(u,'kernel) then
     mkobject(!*q2f exptsq(!*k2q value u,value v),'poly) else
     mkobject(!*q2f exptsq(value u ./ 1,value v),'xpoly);

symbolic procedure expt_xratpol_int(u,v);
   % Poly case handled by expt_poly_int.
   if type v eq 'zero then ONE else
    mkobject(exptsq(value u,value v),'ratpol);

symbolic procedure expt_ratpol_ratpol(u,v);
   simp4 {'expt,svalue u,svalue v};

symbolic procedure svalue u;
   (if x then apply1(x,y) else y)
    where x=get(type u,'prefix_convert), y=value u;


% ------------- / ----------------

ranks u/v : {ratpol,nzint} -> ratpol,   % the following are too liberal.
      u/v : {ratpol,xpoly} -> ratpol,
      u/v : {ratpol,kernel} -> ratpol,
      u/v : {ratpol,xratpol} -> ratpol;


symbolic procedure quotient_ratpol_nzint(u,v);
   if type u = 'zero then u
    else if xtype(u,'kernel)
     then mkobject(quotsq(!*k2f value u ./ 1,value v ./ 1),'ratpol)
    else if xtype(u,'xpoly) or xtype(u,'int)
     then mkobject(quotsq(value u ./ 1,value v ./ 1),'ratpol)
    else mkobject(quotsq(value u,value v ./ 1),'ratpol);

symbolic procedure quotient_ratpol_xpoly(u,v);
   quotient_ratpol_nzint(u,v);

symbolic procedure quotient_ratpol_kernel(u,v);
   if type u = 'zero then u
    else if xtype(u,'kernel)
     then mkobject(quotsq(!*k2f value u ./ 1,!*k2f value v ./ 1),'ratpol)
    else if xtype(u,'xpoly) or xtype(u,'int)
     then mkobject(quotsq(value u ./ 1,!*k2f value v ./ 1),'ratpol)
    else mkobject(quotsq(value u,!*k2f value v ./ 1),'ratpol);

symbolic procedure quotient_ratpol_xratpol(u,v);
   if type u = 'zero then u
    else if xtype(u,'kernel)
     then mkobject(quotsq(!*k2f value u ./ 1,value v),'ratpol)
    else if xtype(u,'xpoly) or xtype(u,'int)
     then mkobject(quotsq(value u ./ 1,value v),'ratpol)
    else mkobject(quotsq(value u,value v),'ratpol);

% ----- df -----

ranks df(u,v) : {poly,kernel} -> poly,
      df(u,v) : {xratpol,kernel} -> ratpol;

symbolic procedure df_poly_kernel(u,v);
   if type u eq 'zero then u else
    if xtype(u,'int) then ZERO else
    if xtype(u,'kernel) then
      mkobject(diffp(value u .** 1,value v),'ratpol) else
      mkobject(difff(value u,value v),'ratpol);

symbolic procedure df_xratpol_kernel(u,v);
   mkobject(diffsq(value u,value v),'ratpol);


% ----- int (integration) -----

ranks int(u,v) : {poly,kernel} -> ratpol,
      int(u,v) : {xratpol,kernel} -> ratpol;

symbolic procedure int_poly_kernel(u,v);
   if type u eq 'zero then u else
    if xtype(u,'int) then ZERO else
    if xtype(u,'kernel) then
      mkobject(simpint{value u,value v},'ratpol) else
      mkobject(simpint{prepf value u,value v},'ratpol);

symbolic procedure int_xratpol_kernel(u,v);
   mkobject(simpint{prepsq value u,value v},'ratpol);


% -----  list  ---

%ranks u . v : {generic,list} -> non_empty_list,
%      first u : {non_empty_list} -> generic,    % Hmmmmm.
%      rest u : {non_empty_list} -> list,
%      reverse u : {list} -> list;

%symbolic procedure cons_generic_list(u,v);
%   mkobject(u . value v,'non_empty_list);

%symbolic procedure first_non_empty_list u; car value u;

%symbolic procedure rest_non_empty_list u; mkobject(cdr value u,'list);

%symbolic procedure reverse_list u;
%   mkobject(reverse value u,'list);


% -----  setq  -----

ranks u := v : {kernel,poly} -> poly,
      u := v : {kernel,xratpol} -> xratpol;

symbolic procedure setq_kernel_poly(u,v);
   % Make an assignment of v to u.
   if type u eq 'variable then putobject(value u,value v,type v) else
    if xtype(u,'kernel) then nil else
    typerr(u,"assignment");

symbolic procedure setq_kernel_xratpol(u,v);
   setq_kernel_poly(u,v);


% -----  equal neq lessp greaterp  ---

ranks u < v : {int,int} -> bool,
      u > v : {int,int} -> bool,
      u neq v : {int,int} -> bool,
      u = v : {int,int} -> bool;

% These need to check sub-cases.

symbolic procedure greaterp_int_int(u,v);
   mkobject(value u>value v,'bool);

symbolic procedure lessp_int_int(u,v);
   mkobject(value u generic;

symbolic procedure quote_generic u; u;

flag('(quote),'non_form);


% These need to be merged.

symbolic procedure equal_kernel_kernel(u,v);
   mkobject(value u = value v,'bool);

symbolic procedure equal_power_power(u,v);
   mkobject(value u = value v,'bool);

symbolic procedure greaterp_xpower_xpower(u,v);
    greaterp_power_power(u,v);

symbolic procedure greaterp_power_power(u,v);
  mkobject(ordpp(cadar x . cadadr x, cadar y . cadadr y),'bool)
     where x = cdadr u,y = cdadr v;

symbolic procedure greaterp_kernel_kernel(u,v);
   mkobject((value u neq value v) and ordop(value u,value v),'bool);

addrank0('in,'(list),'((x1) (t (quote (in_non_empty_list noval)))));
addrank0('out,'(list),'((x1) (t (quote (out_non_empty_list noval)))));
addrank0('shut,'(list),'((x1) (t (quote (shut_non_empty_list noval)))));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/struct4.red0000644000175000017500000000720011526203062024142 0ustar  giovannigiovannimodule structure; % REDUCE 4 support for indexed structures.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These definitions are very careful about bounds checking. Appropriate
% optimizations in a given system might really speed things up.

symbolic procedure n_formstructure(u,vars,type);
   begin scalar x;
      u := cadr u;
      x := for each x in cdr u collect n_formstructure1(x,vars,type);
      return mkobject(n_structurefn(x,type),'noval)
   end;

symbolic procedure n_formstructure1(u,vars,type);
   begin scalar x;
      if not idp car u
      then typerr(car u,compress append(explode type, explode2 "! name"));
      x := for each j in cdr u collect lispeval cadr n_form1(j,vars);
      x :=  for each j in x collect
                if coercable(type j,'int) then value j
                 else typerr(value j,'int);
     return car u . x
   end;



symbolic procedure n_structurefn(u,type);
   <>;

symbolic procedure n_structurefn1(u,type);
   begin scalar y;
      if flagp(type,'zeroelementp)
        then y := add1lis for each z in cdr u collect lispeval z
       else y := for each z in cdr u collect lispeval z;
      putobject(car u,mkn_structure(y,type),type);
      put(car u,'dimension,y)
   end;

symbolic procedure mkn_structure(u,type);
   % U is a list of positive integers representing structure bounds.
   % Value is a structure.
   if null u then mkobject(0,'zero)
%   else if type eq 'matrix then mkn_matrix u
    else begin integer n; scalar x;
      n := car u - 1;
      x := mkvect n;
      for i:=0:n do putv(x,i,mkn_structure(cdr u,type));
      return x
   end;

symbolic procedure getell(u,v);
   getell1(value u,for each x in v collect value x);

symbolic procedure getell1(u,v);
      if null v then u else getell1(getv(u,car v),cdr v);

symbolic procedure setell(u,v,w);
   setell1(value u,v,w);

symbolic procedure setell1(u,v,w);
   if null v then rederr "Structure confusion" else
   if null cdr v then putv(u,int_check car v,w) else
   setell1(getv(u,int_check car v),cdr v,w);

symbolic procedure int_check u;
   if coercable(type u,'int) then value u else typerr(value u,'int);

% Arrays.

flag('(array),'zeroelementp);

put('array,'n_formfn,'n_formarray);

symbolic procedure n_formarray(u,vars);
   n_formstructure(u,vars,'array);

put('array,'getfn,'getell);

put('array,'putfn,'setell);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/tower.red0000644000175000017500000001547311526203062023705 0ustar  giovannigiovannimodule tower;    % Set up type hierarchy.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*protfg curr_pckg!*);

!*argnochk := nil;

symbolic procedure type_reduce(u,v);
   % Returns minimum type, value pair of expression u of type v.
   type_reduce1 {v,u};
   %type_reduce2(u,v,get(v,'typetree));

symbolic procedure type_reduce2(u,v,w);
   if null w then mkobject(u,v)  % no further reduction possible.
    else if null cdr w then type_reduce(u,car w)
                     % it must be at least this type.
    else (if x and (x := apply2(x,u,v)) then type_reduce(x,car w)
           else type_reduce2(u,v,cdr w))
          where x=(type_in_pckgp car w and get(car w,'boolfn));

symbolic procedure delrelatedtype(u,v);
   if null v then nil
    else if xtype1(car v,u) then cdr v
    else car v . delrelatedtype(u,cdr v);

symbolic procedure type_reduce5 u;
   begin scalar x,y,z,!*protfg; !*protfg := t;
     if null(x := get(type u,'!*nullary!*)) then return u;
     z := get(type u,'typetree);
     a: if null x then return mkobject(value u,car z);
        if null errorp (y := errorset({'apply1,mkquote x,
                                       mkquote u},nil,nil)) and car y
           then <>;
        for each j in cdaddr x do
          z := delrelatedtype(cadr cadadr j,z);
        return if null z then u else mkobject(value u,car z);
        %x := cdr x;
        go to a
   end;

symbolic procedure type_reduce1 u;
   begin scalar x,y;
     if null type_in_pckgp type u or
        null(x := get(type u,'!*nullary!*)) then return u;
     if y := apply1(x,u)
           then <>;
     return u
   end;



symbolic procedure type_function(fn,typelist,args);
   begin scalar x;
      return if (x := get(fn,'ranks))
                and (x := assoc(length typelist,x))
                and (x := type_assoc(typelist,cdr x,args))
               then x
              else nil
   end;

symbolic procedure type_assoc(typelist,type_assoc_list,args);
   % Determine if there's a match for typelist in type_assoc_list.
   begin scalar x;
    if x := type_assoc1(car typelist,cdr typelist,type_assoc_list,args)
       then return x
     else if x := atsoc('generic,type_assoc_list) then return cdr x
     else return nil
   end;


symbolic procedure type_assoc1(type,typelist,type_assoc_list,args);
   begin scalar x,y,z;
      if (type_in_pckgp type and
          (x := type_assoc0(type,type_assoc_list)))
%        or (x := atsoc('generic,type_assoc_list))
        then if null typelist
                then return pckg_op_chk
                       (if atom cadr x then
                          if atom caddr x then cdr x
                        else if z := constraint_apply(cdr x,args)
                              then z else nil)
         % We assume termination with the actual name of function here.
       else if y := type_assoc1(car typelist,cdr typelist,cdr x,args)
               then return y;
      if z := get(type,'uptree)
        then <>
       else return nil
   end;

symbolic procedure constraint_apply(u,v); apply(u,v);


symbolic procedure type_assoc0(type,type_assoc_list);
   assoc(type,type_assoc_list);


symbolic procedure check_type(u,t_type);
   % Checks that bottom type of u is compatible with a target type.
   % Returns u if no error.
   if xtype1(type u,t_type) then u
    else rederr {"Ceiling target type",t_type,
                 "is unrelated to result type",
                                  type u};

symbolic procedure get_disambop(name,arity,coarity);
   begin scalar x;
      return if (x := get(name,'ranks))
                and (x := assoc(length arity,x))
                and (x := disambop_assoc(arity,cdr x,coarity))
               then x
              else nil
   end;

symbolic procedure disambop_assoc(typelist,type_assoc_list,coarity);
   begin scalar x;
     if x :=
        disambop_assoc1(car typelist,cdr typelist,type_assoc_list,coarity)
        then return x
      else if x := atsoc('generic,type_assoc_list) then return cdr x
      else return nil
   end;


symbolic procedure disambop_assoc1(type,typelist,type_assoc_list,coarity);
   begin scalar x,y,z;
      if (type_in_pckgp type and (x := assoc(type,type_assoc_list)))
%        or (x := atsoc('generic,type_assoc_list))
        then if null typelist
                then return pckg_op_chk
                       (%if atom cadr x then
                        %  if atom caddr x then cdr x
                        %else
                        if z := assoc_coarity(coarity,cdr cadddr x)
                              then z else nil)
         % We assume termination with the actual name of function here.
       else if y := disambop_assoc1(car typelist,cdr typelist,cdr x,coarity)
               then return y;
      if z := get(type,'uptree)
        then <>
       else return nil
   end;

symbolic procedure assoc_coarity(coarity,u);
   begin
     a: if null u then return nil;
        if cadar cdadar u eq coarity then return caar cdadar u;
        u := cdr u;
        go to a
   end;

symbolic procedure coercable(u,v);
   % True if type u is coercable to type v (without transformation).
   u=v or coercablelis(u,get(v,'typetree));

symbolic procedure coercablelis(u,v);
   v and (coercable(u,car v) or coercablelis(u,cdr v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/reduce4.red0000644000175000017500000000546711526203062024102 0ustar  giovannigiovannimodule reduce4; % Support for REDUCE 4 interface to REDUCE 3.

% Author: Anthony C. Hearn.

% Copyright (c) 1998. Anthony C. Hearn. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(reduce4 form4 block4 proc4 forstat4 struct4 reval4
                  simp4 forall4 rankstat ranks tower package4),
                  nil);

% Setting differences between REDUCE 3 and 4.

fluid '(!*debug !*eoldelimp !*lower !*mode !*oldmode4 !*reduce4
        lispsystem!*);

% off quotenewnam;

symbolic procedure !%reduce4;
   begin
   %  load!-package 'reduce4;
      load!-package 'tables;
      flag(list !$eol!$,'delchar);
%     !*debug := t;
      !*eoldelimp := t;
      !*lower := t;
      !*oldmode4 := !*mode;
      !*mode := 'algebraic;
      !*reduce4 := t;
      remflag('(plus times),'nary);
 %     !#if (member 'psl lispsystem!*)
 %        <>;
 %     !#endif
   end;

symbolic procedure !%reduce3;
   begin
      remflag(list !$eol!$,'delchar);
%     !*debug := nil;
      !*eoldelimp := nil;
      if !*oldmode4 then !*mode := !*oldmode4 else !*mode := 'symbolic;
      !*reduce4 := nil;
      flag('(plus times),'nary);
 %     !#if (member 'psl lispsystem!*)
 %         define!-alias!-list '(off on);
 %     !#endif
   end;

on quotenewnam;

switch debug, reduce4;

put('reduce4,'simpfg,'((t (!%reduce4)) (nil (!%reduce3))));

% version!* := "REDUCE 4";

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/block4.red0000644000175000017500000001351411526203062023715 0ustar  giovannigiovannimodule block4;   % REDUCE 4 block statement and related operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1995 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(blockrestype!*);

remprop('return,'xform);  %%% has this property in the original version.

symbolic procedure n_formblock(u,vars);
   {type x,'prog . append(n_initprogvars cadr u,value x)}
     where x =  n_formprog1(cddr u,append(cadr u,vars));

symbolic procedure n_initprogvars u;
   begin scalar x,y,z;
    a: if null u then return(reversip!* x . reversip!* y)
       else if (z := get(caar u,'initvalue!*))  % variable
          or (z := get_type_initvalue cdar u)   % type
        then y := mksetq(caar u,mkquote z) . y
       else y := mksetq(caar u,mkquote ideval nil) . y;
      x := caar u . x;
      u := cdr u;
      go to a
   end;

symbolic procedure get_type_initvalue u;
   if atom u then get(u,'initvalue!*) else get(car u,'initvalue!*);

symbolic procedure mkobject(u,v);
   % Makes an object with value u and type v.
   % Next line is a kludge that needs to be fixed up in the poly code.
   if null u and v eq 'poly then list('zero,0) else
   list(v,u);

put('int,'initvalue!*,mkobject(0,'zero));

put('list,'initvalue!*,mkobject(nil,'list));

put('poly,'initvalue!*,mkobject(0,'zero));

symbolic procedure n_formprog(u,vars);
   {type x,'prog . cadr u . value x}
    where x = n_formprog1(cddr u,n_pairvars(cadr u,vars));

symbolic procedure n_formprog1(u,vars);
   % left out the 'modefn' stuff from  above.
   begin scalar eptr,v,blockrestype!*;
     v := eptr := {nil};
     a: if null u
           then return {if blockrestype!* then blockrestype!*
                         else 'noval,cdr v};
        if null car u then nil
         else if atom car u then eptr := cdr rplacd(eptr,{car u})
         else eptr := cdr rplacd(eptr,cdr n_form1(car u,vars));
        u := cdr u;
        go to a
    end;

symbolic procedure n_formreturn(u,vars);
   begin scalar x;
     x := n_form1(cadr u,vars);
     if null blockrestype!*
        then blockrestype!* := type x
      else if xtype1(type x,blockrestype!*) then nil
      else if xtype1(blockrestype!*,type x)
              then blockrestype!* := type x
      else rederr {"block return types",type x,"and",
                   blockrestype!*,"are unrelated"};
     return {type x, 'return . cdr x}
   end;

put('return,'n_formfn,'n_formreturn);


put('rblock,'n_formfn,'n_formblock);

% symbolic procedure decl u;
%    begin scalar varlis,w;
%     a:  if cursym!* eq '!*semicol!* then go to c
%          else if cursym!* eq 'local and !*reduce4 then nil
%          else if not flagp(cursym!*,'type) then return varlis
%          else typerr(cursym!*,"local declaration");
%         w := cursym!*;
%         scan();
%         if not !*reduce4 and cursym!* eq 'procedure
%           then return procstat1 w;
% %       varlis := append(varlis,pairvars(remcomma xread1 nil,nil,w));
%         varlis := append(varlis,read_param_list nil);
%         if not(cursym!* eq '!*semicol!*) or null u then symerr(nil,t);
%     c:  scan();
%         go to a
%    end;

symbolic procedure read_type;
   % This is a very restricted parser for type expressions.
   begin scalar y,z;
      y := scan();
   a: z := scan();
      if z eq '!*lpar!* then <>
       else if null(z memq '(!*comma!* !*rpar!* !*semicol!* mapped_to))
        then <>;
      return y
   end;

symbolic procedure read_param_list u;
   % Read a parameter list, with or without parentheses.
   % Used only when reduce4 is on.
   begin scalar lparp,x,y,z;
      x := cursym!*;
      if not(x eq '!*lpar!*) then go to b;
      lparp := t;
  a:  x := scan();
  b:  if not idp x then typerr(x,"parameter");
      y := scan();
      if y eq '!*colon!* then go to typed
%      else x := x . if u then u
%                     else if not !*reduce4 then 'scalar else 'generic;
       else x := x . 'generic;
  c:  if y eq '!*comma!* then progn(z := x . z, go to a)
       else if y eq '!*rpar!*
        then if lparp
              then if scan() eq '!*semicol!* then return reversip(x . z)
             else if cursym!* eq '!*colon!* and null u
              then return reversip(x . z)
                     else typerr(cursym!*,"delimiter")
              else rerror(rlisp,100,"Too many right parentheses")
       else if y eq '!*semicol!*
        then if lparp
               then rerror(rlisp,101,"Too few right parentheses")
       else return reversip(x . z);
  typed:
      x := x . read_type();
      y := cursym!*;
      go to c
   end;

flag('(local),'type);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/reduce4/reduce4.tst0000644000175000017500000001426411526203062024135 0ustar  giovannigiovanniComment This is a standard test file for REDUCE that has been used for
many years.  It only tests a limited number of facilities in the
current system.  In particular, it does not test floating point
arithmetic, or any of the more advanced packages that have been made
available since REDUCE 3.0 was released.  It has been used for a long
time to benchmark the performance of REDUCE.  A description of this
benchmarking with statistics for REDUCE 3.2 was reported in Jed B.
Marti and Anthony C. Hearn, "REDUCE as a Lisp Benchmark", SIGSAM Bull.
19 (1985) 8-16.  That paper also gives information on the the parts of
the system exercised by the test file.  Updated statistics may be found
in the "timings" file in the REDUCE Network Library;

showtime;

on reduce4;  % For the time being.

comment some examples of the FOR statement;

comment summing the squares of the even positive integers
	through 50;

for i:=2 step 2 until 50 sum i**2;

comment to set  w  to the factorial of 10;

w := for i:=1:10 product i;

comment alternatively, we could set the elements a(i) of the
	array  a  to the factorial of i by the statements;

array a(10);

a(0):=1$

for i:=1:10 do a(i):=i*a(i-1);

comment the above version of the FOR statement does not return
	an algebraic value, but we can now use these array
	elements as factorials in expressions, e. g.;

1+a(5);

comment we could have printed the values of each a(i)
	as they were computed by writing the FOR statement as;

for i:=1:10 do write "a(",i,") := ",a(i):= i*a(i-1);

comment another way to use factorials would be to introduce an
operator FAC by an integer procedure as follows;

procedure fac(n:int)
   begin local m:int;
	m:=1;
    l1:	if n=0 then return m;
	m:=m*n;
	n:=n-1;
	go to l1
   end;

comment we can now use  fac  as an operator in expressions, e. g.;

z**2+fac(4)-2*fac 2*y;

comment note in the above example that the parentheses around
the arguments of FAC may be omitted since it is a unary operator;

comment the following examples illustrate the solution of some
	complete problems;

comment the f and g series (ref  Sconzo, P., Leschack, A. R. and
	 Tobey, R. G., Astronomical Journal, Vol 70 (May 1965);

deps:= -sigma*(mu+2*epsilon)$
dmu:= -3*mu*sigma$
dsig:= epsilon-2*sigma**2$
f1:= 1$
g1:= 0$
 
for i:= 1:8 do 
 <6i`I6>ZnpvZ)n!܈#0?Qw<[&VD~_gNœ~€Gnlrz㫎$FORM7DJVIDjbz+Hr,7`Eb;=͞Oz}=8~|3v.O8*i:m}yYkhYa&P3)Ю
UZH63gLw-Z]KPF})sΫ)cq~ՎFTT:*+g$@QQD=魿b3ϡx[̺(ҟ
l܅\΂ܚR0w9n8y8}GV_Ut._-yp\CV,6ܶUNe06O}GR_CO>|'keǰU2K"8/XmlqM:È{H7|hch!ۼ{7}+ܶa'y3X
g}IfAm[q瓋zF۪Ԥ>6%P@0nyy!>Z
R8V`~y0)tLK\Z$L\\(_/:<MCQ0w~y5fʧ*
&c.wK ]nw<dO;U6jOƦkksr:RrCZfFTbON\Ypz&ԅm$١{`k9BZ'^@v-6\D/_
}UiK0Jh0Iȧt+ث ˤLQRY\W2pl䵬
!/4d +5\"jHeρSW2ފY}uD2&y
3rxES:keUHz߾dG`΢_yzljxXTIuɳ?K#)6yF:&-c;q`~GտKт
{L&k#XXOMO=;̪UA:)N۹S4U:ӉMm4x4wTG׳hE&	,̀0J4/d7B"/b
Q]ёѮ
CeH-qSv_?a-Ytwf?a6hnCwk1·tq߄(![@lx_De`wc3+S߬xꩺfdW,5[$y+aO-WicOZs
>,h\h=KB
y7Y)\&5#Q1zNMril\*w
>_x$hoyKͯ;
Β[i'&4
֨hH	ᵿ8%1GX6_KӤ~|+vR%k mD&~8ت?#NR$i<#H7V1TbweҨq
kL/0twwE[!Ps	?j	}m;3uhZ_Sņ>F>dxNfnk'ehdMlD=	R]L=7o9Zo	m"
'ךF3Ɲ`,;"zs-0'ySw"Q8%k	1bWJY>6cf5[w&B{xusS6w\&lx4n<V%tLA|lw*ۅ$Bbm?nΊ"M䑽!v.bfzMW
>p#Wq V;<`^@;7\5TR4&t&]U8.M,֫AV{@*~*nxUB=^3:[.w[jf5n4;#_Jё@
6C^ͱEnN؟< c\%08=&_u8S$L7";)([\9+`mVs9UE[8|(O wi:tKJlyۂ2q{zo 
5uu>Duoq$j18[p|ɝ	i0
=CDx/>YB`_G;AN]3x0&f}di+P@Ŷ=C[@sOi	շs=mɞ[ݑÍx^2F"ԄۙlƷ!q(bFJr4ڶ[|})VaCrWrcww*T@a[1j{2t!zqk4Cu"aCV:K<,yuu):+AԨ뀍]2[pffgPL$]¾QrDu?yɣij<´p#?━"ns{XOjܸܱWsY-IӺ+VIH	,~U]d4kJbv8nr+m$G۔'SzLva`٣-MsT6T82Rcڳri?7k.߅!%)gA] {Z=+~@
ql4
9*a3bL@7TM[\&('bbwxIyV#a3!~A6UgEYvzŗ&)MN{F$1u>,}sYL_͞hZ,9vCݨ(]4]Ka*_X6_S9yRǢ,fAY.kB7z6<	}DVK2vVkSfٻk#|XLFv;\m5$
p%i&Jpd>ߊ(-
 Xw~  XQ+m"s$iƻKAu#ohMqd
d7q
FNjg'`*HuR)n(B]hժM {(ui︚Q8hگj`J35Ds:,]N*jbt|[Jg#y2>|]|@lN1ԋ	`ba
pɡ5PtuK\S<mow3pF@U$"D`8%EQYlAPCy3'#
OAFȝw|t6(:Q5
X@¯;
'69|xf!-Wd[oSrF7Dv#_m,P`ɓl@riv͒"zv׃q4'KhotKPCEQWiØÖXuzz"ڍhb6IUgXد}]\U?i.δa3[
mٔJʶ@cwgI	qPKϷ:Ԭa7e"%
P)OfhyoJK
US3?Jjs\(B$E.;EC)7O༜[ӌʩ1kbipVZƆ+@L?1irO	'7f]SXɎ3 i;;NRCmƄɚCy(z:귳샼+cp.x'v,31,u=ddIƎmZʚX&>
fp3ZIaߚI>fapFTj!,'0$.cx:Ǔ,^e//2u/CM+ah&c"fi,gާg ynַJeI Ѵe\4B!.R|VJ]8(ß-A6vt&[)lZDȰNNV
HO''an;=gp2DkC-ߢBWXFLC#One/
BY!s4Rg,=DME7d8BM5A#8(%?j/-A3FewU4\oTW04,’}!+ϳ0vA 9IFFJ$[{5zrWFL[!\*f%fƞrRv{&aט.S
\6'x>fv#쪒8`Lփp옎=eN,la߬zvɭpRE;.kh<%f~MD*C't*Y瞿Q*jqLjב~pG-3-ӈ**VTKm4`H)xi
H/g;j:R:Uor}tө#ɝ2m^DJ<NjK
0	ۄ*,c,k&9wDUӔkLUq-n1Juڜe 聭SlG?3o"z{}x;
^oP4DRrXyb0ߑ-ԁm|:rK'No1Z
Kp
BԲŪ?'UuL#%ؕ
=HcAr*SFwE_}bau	R_#CmB!;~]=ۿA	aNwBV5לl5T	;3GAV#`\o]iG%0cn?3x~EzmG$q|_}nsҐ=o+nzLw#0$vqgΐG˾Y@S4׍רγdňOWք&efVjŸb^i#g %#|FC$nk(#d
704QSޕqJ{f9{c(>:
8/rRP&.2M ;P:*yo9-SCk:\Z<ʗ, `
{W廎,$O	
t&<	MK`ґ=ޝKS@13fVN.HH3G6Xq`5NtRc*7ɈRKd8~6=;}Ϻ7KRD.w2QQ_'jgt_
Dfάy]y!U[\@BS˄ǑiDqs|Ktnl=CS}"Ds~0Nw쓶^"}- 9wE|!rf0wGx2iq9s*T^.eHF`1׿hw6޹ԋz,ХρbREJK6[E?j~$ŽB
6,"=cT>%RʀYQcz	4_GYEfF[Nma2L)j}euJ5Ԃq/pU2l.hQzM1&9ۈ"AGďR2mGs&diZh* yKNp17 S"Phf\DƥToj*A;4`}Э!vM5o[lipB)IT78á[LRp
nuRWyz9<kXa53}RNJ*HqQ&*e]u2GΫft.%e2W/[@v%W@1`Y^^O/+b΋إTcZZoHP9ͳ	&:Z|A(JKd߼OIW&W3P_g[$QƧǁEf+3D72)F1Zo*rG.jg77HκZ|0)*VWJl
ŏ&e?nyb@ksA?W	I셃VQ"%W+)#h+`W
KD8SWV+":@kcTi9^DVqE&U_y2
;d\}׏Likc~|])<^k
uK06tz10^=//
',.V#'?Lɪ@eyۀZ^LItw4E'3\HORBmݣe
tR1|D/hy5AZ}ԞK}EGlG@6q)iJۼOtP:JaOE,xKU^
r:UPn3ͯj6Y=r
I-U9>Z/wK|!տ-$,s*f-0eUBuGk5[bitYNq~z#F ΕRh7yW!hG}K٭ڑydEy	UOIY'
**km%bx]瞎%/(%xwbo⹇3W;u6rr[@D(Q{Lv֋.N΂;Zw;:n­Ȱm1IYqM=|mM]ې}}NkG{uw&+Q@ѱ/蓮V(8py!]w&wRT]8
gPiw]=Ӌ!˼j~f4_RL$ P}vH
k.A$L
W_.m
"6̃LB`"Fܦp^	<)oj!Qd%f{|HC4d^v)3X3(z>F{#sXMJc]Uv_殂tkK3yGuYb9#Ȏ/$Uml_O]yԝ'#;=[kMDf}eJZ?>y;5
_BY7`U j6	o%u~.Y\]=
lHԴ/Ck${m+Dَ&!yV1vpPvk̉Cd#>MkR\(~ 1wghXU)s=}Ux5KT-Ŧ"&*8=ȿ'ia}jfք$-#&_8
ܸ06I:`pA\4A։1w53AafLϚߥS
Bnz>87Ccx\
2$S'W3F
.P'%8 }k6u
põ*D}W\M˜-Uږ|A_!Qj8W"`(uH(oM1Y4#|KU`+mMdꋉVHi2k=bw(F-&_F9PJRn>d[=vƘ!A*4B]aI]
^[0pUτ	4BZbcȊ)x2-ŕoeЇWŚ໫"O(/l[OZBg)LȃqWثٖȰP.{R!24UlK
yz3 FT	@a/Xto/:V̄@Qzs;.Lp'Z/sf.M	DĒiQ:;fxAwvVH!=e@Um#Y[qJ2N(bHskB|c*n~r/(
88d^SAeCYg}>J*t<ŝJDm`B A0z,?NnijIr.`M9ΣmGbȸ-w )%]FGg)d"\SshX3U
N(7Ծ
2v2G`fM2m<
е@9=%ӱ
k	(יjiΥ!CyՈ	"%GbH$X8wu[\vZ+7Aƚ H%@9րGy6ӡ#QC=%-hqì	=Yn3#~j1\nmgˆrS$,8{/qKCH%?JH>KfSy=m#Yzת@dSh9 $V)d8sƄk.vdME^a.F1?0_Lv}fw<,oN+E-z1#l2kΘR&溧%:q-Òx4B [=HTBss1P,TǽLС̏R)z9Cp!Vt&?]ji+o{T$qnEZ%N1QәsĄ`!{
bO2+V|0g@M6SbҢ,73V
 1]hWbxmPk[8[mrϿsFm"P:BU\T{(AE*%60uhC*{۬,6|:&֤'#M^x(p9i >E&wӲL°xTvE@ag#Yux2by~ѷ&*<<[l&5e3-o!:\3$5@ж?憉ꗠ/𷅺e$USa,0CloTNTSyޑjU(l`X~pA$'%\,ѿCva܊~t	}fѓ6k}I4&3~(JU/
<]a?0ط^lٷeJ@"]=SFj=lFWq_]&K$M3Bk|$;`IlTkND
ɆCn}WަŒIbk">ـWHWnlGpeSSPR}p\oC*xj;9T8㯷U;Utnk0aCSz L:b11,o
.ԗJǀKѿ+QsSc%]%;?pSt>0evϓho@Stsu7B莐;iVA;U%CcǼD/0	U`<<)

D
}2y|hM3Pr2&<|hOw5s։Un#?}cᔾf/CM$:d	3[!L^˷sA":|ojA:vAgUi[I{U
d%C	[`+ݒw~E٪lˆ`Cnzص	[?e~$`A&rZVdf7:)+<Qҟ25	RnVy(1Aߕ~X+(gn(!y*zJ2TXv9|GGNLaC.)Đ0ӜTruUE'ͺ𪒓}lj6B!R0H3~O}yXո,qe`^Dt]_ԾAW=ʛ|.T~`(ew&L;쉷Vcs@@\#th Uge	ev-=Dnzh{4rUOvj~P.Oeg(?)wFmp'v=#_`Y'߸G32٦ӣ7W9BdN
u
QrdtbIq	(dDɹQ?H±^3Xfl
B@2l\#"QAo簦Pm`WrǯטwKODg+N0ϩNVQXoQ4"M/Pjޯ$j{M|'sTC+'ـѕ]4ZVT
LGq0KZR̉ұ'<^AZs	(Ԓ~XH1AmrSjGFPi	s[e<̝H[/.e[ޠ=L`Fߘl_G@%olF4c& +QDt`!%Y'e=i]Դ4µgh[)BnL&}}E@Zn~N)njջv:^q&v.;a4v>l0۪جDݿ2Ɍ1H}
T?+twi'jF_SA+O>iQ0pR7ၐl=\+iҩ!8Ф)5X*ˬ&@9ZRlВ6Ё$.xHagNY#C# =Fa#K=0:[xz3zz5+N-=bnT)1rl…0^fODa7s~d#=Nq{}KQ	g:s&?SU3rjH΃LI_ʔ_sςo%†'XASsӷRbKuՀel*UL,PgIfZlNs`W5ś`>@1>;11)1>?8è4lPGr^Ѡlw|+ML畢x=uOҖ$CA^{(,**`A^Prm/֍1Dv+c,jVvW+JQTBdedzGAC֗ͼ
xL:#z<%S4oniVHsgt$QԂ;ޣP\aRBC@vBSn
!|/KxP_`A0e~Z^X.~Hi2o՗ũ>((,F8kNM$

Ak{?\m航EVOg_OlKNNCiM2ts(v`5{]ZSZҝ[CHœJHLJy罻L煯GųD%up] X,e	O4b
?3rV׌?{!,2tM633}c =ՅWm%OxPR]v>ND&H{-HJڬJREnH[|MG〦2[chRi2,1b4D -!ydV@CYQD
{Ul^,Z@bOJRI~odYG;7a3_hvg>Ϛu( sU`*Vom0=z=I3д}&~00풤";Nm(->x#gθDw)?]SHiZ7>ѰCcj vda_&iI%peCsZ?l3
-1?3jxI͸'[9/:OmtS'+B\Wtl#ܼ90'!_A1OYˊ~JIY^dj!EǦ1*M=Nz6䎧ƃ
/ڝ	v]r7IJ.\(3פP5,O2*Mu)޽!}O([P%D~|+䛸~WScù)ޱK.gukmD	Ki9O'X
$)NIjw~\(JcR8APq&z\[ddˎ-"*m%=.UVKcfĝ!=h:YdoՒ	3
$5W23[$~Xt_2
PPbWWjчbü!a[D
W?-m
)t{kv)cU׻GuڥgWtt"@E	Ua$[1gN.dﳩwpzk/w<.	VVi
]XDULxWYB`٫ynzAIj2=莣ʛ]C!+׭i9'G;m|uw>e8(A'YSbXFݷ![3hPyᷭ^Oo܋G#f8Q,y-1wm	
#rV
%41G/H) RL%pGFGV#|S7ЪԱ6)2iZH[XyRkG:1I- po}
MY0MIޮPB$c)"[EN?Z7PnrvuB[._5
l4yPQXS3E$ag\#43UV/ǵ
ʱ\ bJRQ/XL
,='{!fNbxer!
8)09yK9;ͺ*$IE	Xm|5Y#F#`.٩2,7X}fkWSKձZqP}S#DQiᮼ`zL>ͻ*@!!zI(a-e,aI|ts:n*K׿G.tP
6&tlG/;# M`-	 zE:ǯk	|.N~u!jjg+JTUvɂޣ}`itԛ^ϳ?~cUcrP.'0L#ub(Y"P4q	]u,ѫ%o%Sk]c,w>%gWgN[?~xBHx{ʹpzdAYxш}x&0w3fr7	v"[Z1Ϛ*'0N6U^8Bvɗۢtmc-Fon7gIUf6ODz
PSRk5BV&uQt4ŅV+Sߋt
a=
)V>'M?yey$7Nٟ'%sc;ڗqM>gfG'wFdZw4\lj\D@ۖYO
@zLo˯3?tU,~FYkƦojg$H[>3Uo8NE5x9vdfjk
Cz<5@oa(|Qb
,`pɄcWX'V A$Q-}SS͑>RJUJ:j)65->nd!Дr(Wp^Z;}VvNڞ_b	؝A5(pŲ+49"y3Q
*a*zRw0YO?e(kbK<%/B<@Xc3r1
EN1Z.J)t޽3QR5,*A\SOלd9ޗD W3:]\/0Pit
.:Q|Qxu, 5FC'zgkD{c+kAS`_]0B8ذi'tL-ۖyh/(+4@9*V~#y{y'mK>q\p&Q)nY	f|\X~ugҵQ6k$oV]M^Cp{䗐dc$]1@{dcKrq	 Оh)
+~	^I9B:hub LЫ@I )X;"0p6Y
h_\k'g,>SAFsf,cy	·r׭q@'7R{,P5EjJօqWTu'ͷ]pFK<+HYGW%o86=>\A:I{GpܦbM_as2}]~iTm_?yˆwrpg8R?S['?oޭq;ST]q 4i]9hނ'༘=~Dͯȹشun6R3`&+fD9''E~~]DXLiKM?;  O3bGJT"^Nֹ܍EpP8qVǐ O`իΪQ<|{k\7%ڬxRm	̽a2a+
-*ԯEs
]Drf'^(z鶳8rȾj{ӆ$pAj()bCkOD[(X^:{"FsQp_̓gFKiE6M`&6'#$ƖE5{B	XVQ8[KѺØm~odrYvݙDBL6XM<0z!ۛ7QQ˒iZi[KC7Q—f{2]^686eCFnVU0nȷ[JpptJb;R7A	E@0jK|$[$Y+;Tɖ`RE=
(JcŘ{³0\e,A6EK/M)g܊];JbM"Fjz'ΘoFz~T3>8֬S"=ןu*F9OsB7<;yH"q|kU+"LFy5XOj(H;b̅&,ZdUi
>L	"P ޘZԮ(te$V䷭oV$)r]1@2݆ߜCsIFrF'j${]!N!	c	AQE̕>+1S|Ih6+s޴z9P$^c/@xI\ԍtA-[VTš(./Bc	Gc!S+ܨo-)]D.:O=kPϫ=!3WKW9umΣq-}/~C-
4((bj3{#
VMj俇ñViTc=aziVkn,POQN5.p@!v̹+jvzx'|~i?-+`倔8!S7>zI0gni*Įz_!1A!cx7t=v'
_Kٺz#ZE$aQvQ(I%W2
ڜBаCT!FZ{:GMR[u7x2K}:qb[
fUeEa_2g%qZ;/ïZh	WqjM
"e	~JܪkK%KL;cx7N	b\v
e}Dj[zDлo[9X`-" =5hª|NqU^c˲4Vѵ4@5w_}){53iNk@#&
CӉibM$
U^̰V
{	mKv:XৎjKmjBqqt'?kr+'9^\ra1(]oi1=/VtvD5P!U"ߖNc`E:s6ܸ^Ĺu
ٍA[ѰP/`wwi`G^"W6IML"xu+(ۻߓ"FH:=ͯbkҎ81O`"ª0',QӤc1K j樸@kTĵJ\FF>[Kd_ʋ}e 'BsFU.~GJUytZ3aT"S.d.$lcg{'ܗ%}Wŕ>+)Dw/#	.}1c2LHA#8imc̢W
w;Hذ	ca^>yxoenB̔MPÎ<ˆ"	`k0lg,&ro^' Kxqo@2Z3ѨG^RlX#veBjqMk#Qѝ؂j$4D;VZ^8d1Q=ӎ(KMPfmWCЬ]^Ss9xbɄq,?;9waU$n̕h
ޖߞU?Ѩ|uٴuklDjؿ;~ T%HCF0{\:PՄ@sC0onZ5*l$a*pbPM;y3}G5Ei(Eр(/NtJܷӨ΢}RW'3ap~Ҧܴ򞡏#=ɺǁ;}JSWyR.`zJTF;i,h	w\;qhAJ ݲ!M۞! ua]!Phӯy˝IG %fy!
v*suz`gF*qΧjP͹@[qk*ݏW$kRژM9u)eyTdA`Ϝ)kJ/}k_Ns6>h?	[)2D%33ؽ7Q}- eglRorLi#zV旯54'j$	c.]'fd"puI$HhOlƠ!w^*ֳUI|PC}ٯB^P."Jfvc]'f̯PTwЍ8郐8@=џlF_)t4[,^'
>rI!Bz97|Fc0OHZp*>uTފkk➯0(3GXdsY~	UC+/2kJy3*e䲉%a@#H\6
lҡ'>	*Bۆ,!G[QVZ-{ۙ}\k"R`dolrmڐ/ŵ'jԗ#gU1q[6WqIEH#Yۼ}XĴ>=A
;bˋj{1Ӓ`-Zx7 0H	Х7p
ܗK@֞ae@yl-~f"QǺqeO3+ZMolƪWR~=k\[Py“n~-~Nw%)Wzi`VdI]3^umFbnf2rq"CT35{[9Ap:[ՋxG>A;27X
8^/4iC2:e(\e~s	Ѭ1tCȻE{o,:=\%V4ئfJh[T>dHЏDz|F+n8S{Jv?y'|Z]uѡ'EEūֻXscM|S>aEƯoА%.mYjJLE"':Gc676=sav;AlkUwWmVREdʱY6	P^;Ztz3>)1Bt|U6SXQ0L^JhK` [S \񯵑Vd6.8y{@]ERBBfS
]tVy]*˨_ s=٫L
>p%h70¶MM=J΂)ȱPhAty$i@O] |kš\dڊS."3#aGRf@QN"t݉0Ec.!&Q
 /W}"T+ק斦qROZS@vHCSCtd;,\wx!`9z~*3Gpq1
,S~~!ҢQEXX'AcVʴh'm=1W\ЃG`9{ޚ.I/!7+Wزc٢JvknZxro-۷tH
X,N^*_<MG\ki_y SX7 nN+azbt>[aLtjvYQ,jTX'*[/O}(,/+LN&.Ojy>s*x{od&&ZHa.y=J=3s5٪%+iwΜC^cNDcbUrVkQX'?(j:
Y¦yˉcᔅhmdg3]9 b_zRKqܕ
YTqM?1៾X,}N(N[@e[ʾxPKLчZ[Ɔe+_suLIUEoUV™p@tI鯂o~X<O?W+‹k<)Ŷ
'k+ED2dd|IX˫m{);ǔ|a>'CL2tdR5"4/(V.q/u앜OyԌ/@mVDx6+ZU^G*7Mms~ஷ/xs09p{<ĤsāKUyY{^C@4j፴UkQ|Q7yDm*aomr[7ˬ<{RяS@nwiYmԞ0ҳPmä}DVDZNYJK//
3;.rRSu"n+%
.S>l~k䐇 RZ0
X	N&zQW=v{"bXLjE>{P[6b2Ҫy8)HWToOa<&{qA:ԍfV6GKRKśTJh|f=
aHd]hTv`} 0hV,DO>W5VQGh]ƀLz|sGW:\2j|Bm!oD,ÿtG՝8X`cGkBv.Ly&a%#&ZYne.غD@is :ߙ+vKlibH(O)sg/3ÝO2.U[ R8d핓V]lǮ(hVqMX,"bFKDAfWLkF:gsjTB`rBxPz(Zl%qOs\G#9u0D%a)db=j
ȉGc^Z>P$QF 8#גϷ4e/J`G5ncu\/vAy:c0C/lΆ2v=
l0t5޸V8KcO^G͞ߓu
bÈq0+v1_)ghҶ'De&'rA 1OÉ%UۘDƖZ{f24^WEe|c*
;f.M{!^*W$FCir-x/X3da<?,
}mY-D`dF|"KFgK>SYXm~GXu{ioU%Gx$ot29IvwR5
r)Uxɇ:yͰHJuG+&.O.4 c@8-`K*S	Cvf 
E‡>Y؟4Z΅F1גN-]Q*-FFTI%`]:(Nji0C+T")LIƼG,ݮg$V&t$p+3?
и
rrEhhg5)ź	)ʙ	8gJA;|_	;Z罁-m(S.!֡rs1:܅!:a<33:X:5X=#o>
^]ɔyR60\ڼts8Ѓ#@/F>`
cT
m}nm{kzePQsEb	W)*/3%W,g&Vm'ڂy6=Sr'xO&Á;lR+.ٙېvB^Nr(0[v[NaQң."Wd@wVO)14d<Dż~IL!@4aOi)my& OzqkiܝIfA\orQr>ԫOSv2ĹE
ch;jq"0.VYQ_ڲ׷E-"'y"ƆTpuÓ2XRNX'YiuˉAfI?UD߲05)Ǡ|gК*\szpv΄§>3LNP,2V`%4Pg##mzKN9-* 5	f6r+Q"4dZ$QltvJ<2/4@=9?ˋ
zB,|jio}º%u=G*]z[$
8]S_量6$N@6{}d&ˤ#]y3۾7KA[c.QwӅ>й R+Q9_$p[G}%'5nXm>ae EE6c(n-өQ0F	*mMֹU|a3A>uy1Ũǘ"qa0ךTbdQzN;BB&9gbx	qL)ꦃcXт86Wٻ/Z#>kzl,D*;"d{2v*3XM7ʙp R#
ǬppoQJ|2OP'bQJ.WZ
U
LsXg.
>8vϿX)~~UV2ѓ1
H)l&aUɲlWD%\_P˂A+7ijэ9rHUtra֩^{Bې#$iOW5tz2*syp_v#Ǯ.^iOt5v	,M[?M8sh7Y5bUA@Ԫyk4;)Rf603*%_Cڹ-9+:/bUS~e^X%8fj:sk5cns)M e`nC,2*m@yIJERUӏIP}-HKH}i	g5l!#3E!Pq}@Tv@khg?q=fcGU:#V8r
(ǣ]7{,MeAZ{=_MJ64~šuP>+::0K(#RpM0O듷ZC;1:$"zw
ղ-en(*9_!7ej0Vj%X6c*p`?x%"(.E5&^҂vCes6o
+^@'꾼Khi"^)q:p(1ln2 H,0iq0TIV\̳e޻27piJ tuKaк [O#X,X5#[|~a;q:rtbf+nWeR~ZS)/՝PM ҩi.Ziŭrpz#dŠ^	@Rg!2Jj2fR;JSI噕CNՋ٢!v$&u^>}%mR]fBS˚QLV8`
ڋCғR1h(sdKn(~-q(+6fFF*f,#[=)ǣ׺Dg%MyMRJSzz;PDi$* P,ﮑ$$DbkM$g@D@0!O=`2>@.41^dɻx7Yb1$&'Jo0{RQx<)NsyG~b#6L/ҥ$ ?d-Rv{v/\TgQbJ5H>bedH  :b#nHiF&+`P	)NZilKgbxw(e`aM;N>cuOmh@RI&7ẽlo!Ტ$-yP-V
df amc}<`PG۲O[NٟϱSjb/
1J`cl`aiBDT5;SЃ|RU)nF?HDiv?+b1l\׼`goVo)%@)̈́╮rK\WnaRb2hJ	37"`܁lo 
M|.hbP}+JA4<%¤)uӝܬeaÆgQ^,7_Zh +v7ө/`}sχ.γirHuG#܉J)FzוQ#cdZh6,y `\|0غ28%%Q^VJ!癓aK-^uok

GI$	ila]/a7e6R|6%jHUߢ'_s}&*ߤDy}m1ѷi"<
?@-vУj\d_5ZrmvCCx]tN/xe\"Uc
b6^z;/4URJc@mғ4{4ܛm^DtuV6"BRL*P'7|ZaЇ#y=
gx?٢fYdΓ%~)18g
ث8GEuׂsFQAk32/zHi0Q~حj	>0oejaȮojʀ|dIMvb3QH>%kql]ޖ9ey]ftʬtrZ^ sDyICɳHNL
5ԺImj\z2UMnjmE+6G-C;p3@+3س	~P<X	V22(@ETCR+3AJ_͒i%mf]&@AM,e' OrZ߿f+,
m2M̧#Trب("+B&n$rqP+	hUonvKM0H8ĎN-<-$x+ÊUUMK4As"qL;-ɾ^
YRȫđHlZ;GL\m
Dw[(,cIUT͏\ܛ
0ض"dK	/奉utME /d|.JoL%Jjn%c55"~G6GcXu7_M
{xL(Kډ=Ѱmr cs!aė_ͷ}?Ts἟fQ(!p)w[랆vN	6\\uT-QA`Cqt^%d.q;Z	x7VUyC=3Yb[lp?	[,!\<`'Qkseh"N,sZj43>Cq4yMz5&_Ɵ*`kztX%aq5}%X#/@{MQ>?lG^~L#N4s,(`\.1V:!c=ނ5.[PznDPݮë
ژEk0!APJmw82~\KwNvW{V:!!0Cy0 tuW(kORU/[]/~IPmHaU`™AX؋
TccD""Hzly:O5"}̳nY'\PUÚv/9YlDvu!6_'].;!a07‘.)0WuɖM˯BϪr)W]4UFi>]lamЇS6DyՈ}Pb:V6c&]TzD
XC܂z|ut:p,a 3jnR3Ǔ_|(ɊH32_[l%^kvWncwOA): DɺeF_W\v4nՌתQI;eOb̝D$:ʼnFҽ5)O6, Rİ7am~"/@4-+`
0?Harn~27'zA&wQ6r*Q]C%?D%
3~*a#-[(Slٯ_U)Qb6A-RZ҂4d/
QrFRd%ۭy8(>A<.1Cnrx	9r5Ƌy4H74vY}җ6d=?ᖤݝOάBgjKS 2M~oA"F\ c|&c:ikQۏ~0tY}iMr)\&#g_ҁ;1FWۖ0NNRKW7p&"TImĵ6w}5+GEX4ͮE5h
ܟ	ޏ)(%c;Cq/S3಩,259czcVh[?(n*'6iS(\U ﱇJ_aca33Av?p%	Qهr_ {=6i5}֭3#Uv_YOn	}uSyy~ΖuL\FU@R=?}o9wdydbH
^zcp	2h`70N90]k[oUt2˩[R/A$W` 17in4ӕ@jBs<yYP˝y=*d2)y5Ȑa3Q!` /wۊϴ=u+X]c?"ogC׆KcT~	T,oV,ZqA>g/re4MsOtX^\hSK/ߊ&46'hnP#$|pYԆhM$vhr΁uNgKw͡ޏM@жT&8tǂ-=o$s6h
E9'X,|Ւq:	ƧLBAN	Y/&g5EKќ#0mt1GU3?t:+%hpz4B7궼?4̀km~yvMkE"fVdm67P S*^jKv`4Y/xC ;fR#Xb(6虲4w&B%iv] 5huSR*dur*Y4ُm{X,ƭcm6;)Վd_g3H|vVi/^<|J$nЩ	Tv't\ityi:B<9LtߨV۹+1qVb9B1`H9+bҀ$_so+6 $NLy?9騗?Ad&O@M*5c}Qc۹!yPDDnY'a?푞3#]mz&biP}I'jT R5yyfZ巷fjP}=ޠ[c⢑xnBq^sW*l"~Y!tG@qfEɦ	wt⮙	xl6`q,:aCoQWư)5v}Kb~ڞtYB:{z
XtgZOLF}6j/GKV^uّQ3O)B*	!/\EX8>5&?rr	g<H O!`?26o#Tފiy
Ξ;۝,G1s5g-]u@3A^35фwf-SJ,Um(8.}򸳈ji3#?`<[//6y+T%QS}Sx?nVںU.0@K*$yo.nsaQ^@t}ζ~h=4X0'dͦj;:g+,Ꮷ
l8ZޕӑFV'S:[Zn!I8MSVn<]TOnsݫomNTf{՚e"92V
?1iPEZ`:>+R!A躤%cꍝ;@!?9JP=tX}Hʮ'LIK$6|J\^qFahmOh!:.˽{1S%Ϻ:#ly?2	nP(q\(5&Src5M86cqg;oi6BC'Jn/`
De4?rLAwAbR6f+==]=t1:
*y
C!:(#H?tr+
08EOm65=ߘA%~ba^ܴ0b␞Dkco#6 ^YxM[$l*)9ԕgoZlsLL,yvvQ5
S7`gTE-A9&u/)XP?}}	$*9/,|3@}S7Z{SL5|\4j^"Wq\->KcV;?S|ǂQG!O[5(PY}YC<Բzൻlƞc lDܞrG]/V11~*a9Zdih=)t9zQ5X
z-F6Q![<T(cx8ޘUc>JOBNP%6û9`Dzkb9yc	?[T_
7 Kr:e 83$˝0lWrSc卾[Z=uDڀn˜4",29n1sݾ:ʑre`矗\,qҎsie`q]b3\qGB[Z	)f	Dd	*f-NHH3]^[?2~'P 7Mɋ*ćvRmlz`dY371,gVʇC
Q"=,@7SdW03S=9yS@Vi7>Fw@6}a=O5{/G;o0t6tpN |lxjn(]Lz*(TdpᩩQoFc8 qtܖ(
"'X`.¸]j)hIkMo7	yt'I]exƶ\hUMe{mhVa
TXL@+ג]dnaGIs ?\噎ڋ?	i2L1KuEӰq5!9&H	gY=>5
DU
	&zD3i'DB[XM/ey0P~?h'l<5< 5%>m,?88{nP4 S&uOQG|`Ӿ[20Z(,|),p
6dTMgꖂ>[R6e5m!|CFlgc$N&dU)	h;S=ښG:ĝ;('ͫ)9{{TK8FGg;nn͡ՙZd׿z$Rjv' ֈd$Fd*Y
W?>Ul0ADcZwRxܟ=Ժw".]=ENC3fsO2
,=cupOv	$Ox0'PDR]ot<
BYHb5FȺ+q˗QvS!1JP@:JǕ_PrҪJOh40`Ku/gX5>TD4șgzY*눽o~Ղ!!
Dl4iN#` J$%?OиdE4!>ڞF(@M:s?ܸBd'"sBXa"̍p~"=?~sGnIcQWoyrkr6joLu~kJ4(>nXlz7a\mٕ=!2Lw`1=uIc!BV`Q/"Q@:GgZd]_Y5Cl֛]SfYc*f߈Qtւz7!yb$41`A
EAߏ.ޝ/ mvoEBPT/v1zAN3ƣ@_^	kvmO1L%5S_!	ۛ)&#Ց
v'|zo:Vܽ~`Z@fJ
cg&x\R|Ɖ1ã4XG`pU[$xx҅NO7s*8آp$ZSaZj٘Hs${6BC\PKNud,&DyE~nk@tq@~\
YJ/]]/Dz?Uխ̳sU4kvIN{KVٴ\zH#ݰU01z/V@	3oQ3
oZnyc6A'lW#ګYI΁o
|fKO~	O17$'~<1?CnX@BdJs-<."p֙Z"9CB/颲oKH%Q"eHCֱ3-GS	)8",6jz.fI	!BŠq*2#`mDm7wC	hK䖌J=Z$
PgnfLJ+bdPyYOK|s#
k	o隃m$/~Ӿ+bkk
~CSB1ЂQ=5B) t~K\o8F_NbN7:r5	y_SngxAszpa}5`+ڪQhҭߧRGf-Ƨ(GO]0ʼHyZA%VʃZ_7oU0/O~+2ﺅ|YJ3GnPob+"o0ʼnb4-2vDk^b!~D
=e!uB$Q5Ӈ6.ex!¤T
/|"dko#֝aD ([&Q<n:0Tj˰M2$a~=-rV[N)xf<%a9|kt8w:B:/A'n~CdjLa]$YAm|%8ѭۋU0Q:\\HA}JW,4&@>{~]#RVN?z\pڈRwۉ\c2`'
6E
5	ʌc-EOW`͹tSov3qT^C808^P1m6#'k"fT!p}l7sQY]nC֍jhiHP@`U	d+>2RPiUW-M%$Pp{sQEc-)z?J3K8y} Jڼc}e.l*n'paҝKމ񀎧DŽE)#19u<Y,B#>@WAd5ՂcM[gƩyƿ\&אR2td[$}:+EX_Yp8lT I2tEgK.qLu A4c 3cXmmthUnFORM!DJVUINFO
XINCLmemo-tools0026.djbzSjbznvQ9t_'邾Ez%2Yݐ4!gkW:Bb˃z7·֑|XIZwd0qZށh.+jWCCc$Г"H4%$qxy|pnyYRΏ݂]7BhϓCF7i%[š)VCֿq4zgBljA,JL
in7tB"ҤA!-㸊OFm*zKbN2YU7Dt5;gnNB{Tuy[	wHLpf_ċMcT~Q-tJ{(yxXN~6/~>Hf7NQٔLխJtĒIx )6׾MӀvXŅQSj`is+l{pڸm9kAVߤ4VƷ?<
ÅYy:瘃n{(cs.Fg%پNMiť=ˢaB63FEQ1Έ ! ص}Hlv=&Z9(P< v9d;S!zZ{_xuH׳s~XJEVh*tCzTWʵ@[1~nYΪg<;N8+*|Uu6yiz-\%mVrTRyx"IC0AD;y,XIb=vXPoՔ-\K`QG Ssz,4H+4¦:7t*c; (Tߗʰj	 k+ӨP*|/F1\Q|s3JfM!{4?C&gMǜl_5"p3@uPmDO/F2BJUɂ[Fe'*핕!x
hBcgNNDŤ#Qy@;@Qߖ:JB']Kx#ʳKj9UN4㞨a2JҩQàLO<k{c{rG=rFc3ι4X6Kw?rqRz
YЎKղB9%l0&g"d2zGYNGAtGٹхi,}cAmTOe,٨IH-k1y	8*@
#cKB"Bs|l
mXan~^*ӄ0[>He:e:X*ψ+
xJo@bywE'Ihج1-/ >ʄkԾqHo[,`
:ǞZ~= e_'Op.
"iNR5W
hFCJ:^FfvH+zĊҩQWuڱ,؏쫹ُL^or}BfoCG,VP̧Ǔk]mDE村7~%]7ĶHDH]d2Bg$qD]7ɉceh).V׸iМ4Ub]As\7s
7.0UWs̟b{r9g
x֖֪awN`K{M
v6@9*
v
F*R__xJQ(Bo)19Ptl~	iF	WJ\H+O?;
mcǯ0UVA S,E\C3@AvWnE=$Pv744X
5;$!MpkHCug|JGa	ETgل-ΥK;Uz 8XӣZeS:,	KXؙ2cWT*4 [Uc3-[@GԘg7|U7bvkl\W@+ማyVJ>X{gV<.Tϩϳ|"t[(Ӯ|Tf]joB6ly"IC憧WEII;|߂bNp.őH=^-	n*@OL>V_3LyCV-gRHҔthP'ڒjB!#7Vk3
!JFs:b\"űT'&:Qj5w욙Y_#4
OQAۖG!%8Lķsp4+~"V"dۣ
)+mRQZ=	
˔/e΁tV{w4ϙKr!Bƺ4h.efB@ٴFw(-18L?+~7]#=,"ⷺ\J6]pd-=U	+Zm*R9̱piJ]RA$jٟ"3(p|ӗ}sH'Q b	#FE1
LG.w{^Mi4Y?=<8!)2hFBKL_4":	Hԁz!kLF`і%!N0!BB"-^nP@+"푲Х-?k<){s(ǐNhְߒݳW(0R5&w9w)p{edo")VzjiiXV'e4"ɥF[Cu垃91C4D\ఙXcsLEi$0̶gݫPU6z#^@OxSjq9Qo5qtd~;=m
́M%ẎlXEzO>*Nm]?X`a:w˕Z){0'yDU7iztmfTg6ى(H8P*ϸ>Eڬ̟XRz8ѢΙ*cLHJsfyiLEEDžs@GKHf+ILWh3YKwH:%)-󏽶b{djp~0V8Uܕ:eQb
'{'R3NQxy52oA˛k!)%Lv'mB }QdN?L?jYüMA-gUW^9m=lGnbv:'0u0_i13i5R
uԺ޸PuA0:Ȗ>Be\ZN,p,8Yxf􊩏L]^Zcuh`_/Z'E/}$:Z.3ڣ7O9i
~ZM}󏡨X6  {x'ﲿ13eYֲ~EI@Hפ/;`("PA$7	k嬹P*[YTzRJ!:"&g/۾_ǀ̧Bћ/>;{Y	g=Nb^b:gP8Ɉ{x}YVI8⦠(AR:hzʈۤ7>?vD򺵄ѯ|Vo؄͎f[
ȩ*LH1m-q`M+xg5Q;ːuɦϬi?g[
瘯d6ߑz6 %y
7A:Baxr-S1-"dx4kSb5㱢2tjݝiG5ubQ&{׈;0*
{;QiQ䩻a,ejʼ7wȉyQֈI56=>|.?RtOwڗSp&>?j[~:E'9~^''T}O2&~m{<ܛc8I
Klo@N	!j\6\ɓ_0ܾA
0G$سQݨԟڤ1Ь/ĭG%DvE[U&lG=.}Re{}Fe
:9CGhO)ݍ@{X؀(WvMm3(':_8fZi!`g͢,™:Cu@WƖ2k?-xI֌T2/_OЏn֌qoGSrl.H
zњH	
9a(jcV#oB`e^ޓ!mI龩[늘m96ߩ&}wv:;'J|..7[`zu"5w6Dk2LɏT֋),}PC
zʷqOy1>g.X)Wh!ülK))M^^QUD$bx5;ړi|5(z4	x3(0ct4
pPi9i^?tb{v1..N^ێڟKHmky(RxںQ6ۺ]l4!\+J^g:owri_;
f)N立gH.W"*	%l)L87&{ǢW b.kemm>D- v}
`|.!3on=3Hy:!PwM駦#s={ޛ_]	"Yza\\riite
y"x"Y)gxJ-X~Ω)z7?0$gC\Þlqc@>U}亏rr`8TEֺFty61_mxIBW2\LvC-Z:Ů٠E{OpʅHi"y? d)}eDX~$%`AܘHg>,ǂ@|ܱ(i>xLMa@r(1dW;2(B׮/m4O&,_8=8J|~0W-A.by=L$tEkt6az]MmmcaM1	]>&~1ߘxHH"D#$?ǿee-4f"P/m`֎8rYa#Hzl[jùP>+lfJ[4X'H )ўhPdL4]<.n8O^CQY'ym0<,xQg?Uc'.9"'\2΋wCԽ YG6-%M0
KC߼0@U{S:]ETߵzx2ӑ(}e]\hS=Jd=ah+"[3-@QK֮LĽZR*bPϗݬQᾉv~3U1"TXTzתY[E]5g2HOXARF/T QCq)]6PX"7CfvJo_1F]!=HFQefe_!ZU$=QopV5~8+΄Ӫԩ*RQxE4["=-z*/ުo]
a݂Bt`__YpAǃps`ȋz?ڱ%=+q%ZCxvJ=B+q"Oo;1&^KEIEzA`([`+	1
:l-BMrs΃,dznafHs)b>A!|Ctd-)w⽶H@qu1mUI+f&"J{Cz9BcڸE;
_>Ӻot=&VB1@~.>]5Wm}FORMKDJVUINFO
XINCLmemo-tools0026.djbzSjbzE>nvQ9d^WB
lblgaG#?ڸ8lw
s'VxBG)%q)vWݟٖXuH:&0`c1n]}2]Vp}4yu"mӟpMG$mVRrt/SUE½`2%t|
91b[
2-;,\Ҝ@,	HPXo %5Dv"9j7]@1c3eyk41!?FK-$>ܘg,DgK^RաTM&Op*U;}G_[v\
M`ZٜNLƾ5kgoVdTGR'YGh~w{r(sRX[
nBn({NlN>S)rUeG i R@[VNsJ5e.TsosH@{/('E&1ѡzgT2
`O[,~iX2CdZIugtr4k R"4"126ݡ-"0k݀wks|U|TR
}5JyMc¥5V*]c']#U$5tCTMeĿ̷߲.<7f)h(8="{i0vKœ
WքKS4ǿTOsNSED6o2Bb)Z(+2]	ٟa*|̺ɶW d4MWO
T8Op=3
P9wm$1($Sq'UbƘZJj3񍬢~A`O9Y,\³CD~$>Yk'as]̐-pAZ7*?q%J
!EE-aaYI]ݥ/]eLLgͯO#{N:?
xܯlT$(Wp߱HjnBI)^W.Ʊ"pKńG5ȫ=4FXZ3d04K+?)NY1\sWڵ+#ݠ٧wkkgIxќ-Ea$&eeLY^r)8$
vh%?fz#>NS`*pպtM+TZos#hB0OI#4݅o7m@SBO+)$FzSճ007	;!3juIK\EwP@]Z3(xD&gipĴ $e82?T#s/TPr<XvI%S*?!yY9{qIIlz̛iʌ6mN1#^G'}1i
{y&HEf*:ʻ2"d6L2W
Hiym0D xZ}歙0_ƭ(/O(( 5C61sN[Xyjq=%}wC~k%
}
8,Q\3nDv{h~Xњ
s_q4 B%|cl]G34.Qօ7AwY#&݇
sBjXB;K!ӧJՕ`hJf)/[	ʤ2ׄ+%V
1+.YC6:?"m?z+fbpU$HGׇowv6qY8cnx[P=LW_1a[U]rܨH{\CL{$}&=ѨU\F3Wl(l||pHgEMtT@+;B߿Avk>mftp)N,+
`,ō@ƚR;q쟅h5TyVTgd&2YY3lP|\[UG&J{V%*,5+aX`Jt!R-ӗPnTl908}UΆ]Hp9qS57Vr]!sX?$,ZIlG]Ţ|+#<$HX5QT14P_K3qtF@lWYLPNׂ0e!tOz0^z@2O	޳p#$**31/0uIQ7~{=Q!tѳY~A4&,_ŻBQ02_on뢆_XnښE_%
%Z}d|d$8YSEr\5I5?4bH,6UmbqP/f'ɉg^'0/4ahTj209aGF!R7~kn}L-.k=soa(0H:Tn#QwxMm:P0s|:qym5C6˘h8@Q'KddBn2 )?M$~Ɩ6ͯ2ƝU;YݨS/3:[]WGҹϡ8(%FUaPR(ТߌfF*Ӹ5"@Y@G#se^BSO=0ĝl
΄RZPN]=8Ӥ=dtcwVj_ey-YlU	>qH~l}
:,{-d_&"R^	cR3 
`21ڧQ@8/?!hr<4޹S5}lo}Ig0mevXkZ(pƇ	T	sl]5$|'NrZsxm4W2deDURgUC:eUۓa
HYTy
fyS%3RRGwr'˕2?\C$ {cL8Q(odg14)j@Cwkҍca9`uJe>g/Ֆ9a 8wt#!('8oǣQJF*nk8s7*~"u(Sh	K pHĥ8ByQLxp43mIgC\)TyU[UbƉ+Pm5[)ܟR1Wj:2i/9%K>_G2]Ytx6eX)E~1a/]S@0=VfA*~鄼2joY 4kzz87/
JL"]*ISyJA] @ q獶%}S`+p
'@Xa)QyXHcnsuub
{(`aNj@wObVK*6 s%mMY6}QRz`Xο(Up-)<-q9fC>X$T"?AKSk]ygP޺L:İ2pM2F#
:OsIrQba<
y7I(1;[86ℊj>9PL>tpqeud-X8aD)	G0՞>辋Na^ˇ3$AUbV+`*DiȠˆɃ@:§{Ii8e,7B
/v'zal3ɞO<aE=Ud*pJ&'n	n'_$-g{a|M&NO-)؇US|fهkMv#-{+jZ@.~@F8\)f\̚3L)\YNl87ػjX64Lc.k5+X5߷A[:ъO.&
])#_BxbDA ^^9Rõ&TD0Gb"/
W{n)XþULuLv}uݹUH:4v
}BDL/.㓁u^*T/ʖ9P..Sl6vιHsn/̹ߚ{ڇDPmю6	/qd"x!svI鐉=(F3lV
F~cӇ4Go;{Ŝ
wDڔ՘Ե~q\PqCb+P@|BN^
yc?Q0KE{ [x{y% ~JjUlLH<HmO'F;\"$͆!G0)y[?R)^4Ɵ
o]'ו8߂
̃,>GҴk^kLlBkt,}u=e<عNǙ0zS^Kk1']%Hs!@T`gɖ4S:'_nBЍ6M[ƴa3V%\6j@9ȷb~Y;)~klZVR=Rw	HsmsВ!٣k  |5<0zRT~3ʐAgCӸG:!DHHYsgmqtw(8$ֳILMѱunWyK@)xB
Lj(GȰE៵Ҏ6N~?az¼; Cw-Y^hrP«b,}>լGbu$_7C9	i3n,Z"/ۆ0a419:[\I#,ia?~ @/6t`@8֥A@nr1XW؛oΚ凸ɦ8E"oC.bn5#Bo#u>X¿0әy.Z{w2!JR~A9_ۘ33Qrkf#3Mnf thSк|f6%
$6uOVNIۼ~PRqe_*\&* $0Lb`d4bmDJ;eqqryCtf/h,tڊĥOǿJNpAd:WI95~'f9QO0wb-zs]2{C]7>?r޴d3z3H"Kʰ$Vo+]N5gdOY=J;3N͗#"ş#w/8~ebbs)%'"d͚/Ox. |7s7n$Q-F(Re8%`?X! \G.Ĺl~҈nvAs2] '\"M:w!-Q׼>J7[1v	j6hY9rm&ZKk*†7n#X0qFQ|.6/H.m˶h\ZaB6-قH	uF{åcQ~H:B16!κ0<󑰼َ8IIڬ,&5Pe7VSQWfBqy7=uG>Xײ._b!G|]oBÉz#.B؄lg"!ṋ̈w>!w`X+w
(M`$shsr8hlaR]^B$g1#F6~rK.SGw敓:0??ǧ QIwbDDmF0Ypʑ[_|=b~WaȄ
aGiNV`h!3媜+>sy{L{v4D7tĹ+(ŵ0A(򬾗j[Zz'D+$qzƩ.1؂˶
bb2xE1!1l|[^Ƿ23N9v
JE#ƫf*1RQSβHofɎN\4(g7||J~e.5og{'E:©˽wǑVaeʕM[y21[|dյ"FEv?]S>	Bf{mMkg^m,P(s(+P
f޾\^Wě&.	f5LF;dBDtXl6Y.#T0i,y#)_%Y9. +~dlPYxY[|nU|{dY
A,ښߚmѬur{?LnOgH
OjsVOlz_ ˮjh&vsji5
m`bc+lڻ :CɄG*tR7y
ιT\!NjATXʠg%	6cAz5jiq5}3Ox&M`IDCջ@ʦN\^ibAQ6\E+s&NKcYv1Fwj'ysصҏs>%bI`t,7+9 w:hsDVNy	-"Vŋ1ƻe<ݨrKBC@Ԓ:8=uzYD;JܥE0 <3-vc^֩__CY'amq_Bm3JOrQ]<9r͠}WyQ=t.Xl8KLltlMLK`WkNKP۰[+B$Ig&6"7բ3ӿ/48cf_:Jq&r*54>T6nL3ǁ֥al_ňhxllт0$֘6j{%ÐଅHNȳ$Tw{Q^I܀Gy$,7A]9w^4Pˍ[𻰾5:#;C~:&d\lgѯ@?nڻq;9\W7̫Mqiy^cS[ĝJO}$|9,zq_/efK_Gv}5X:\೐Ԧ[X̥j"n45D!1{&+0
jN4TB":mM0JA!iU\lfd߄Bbfm]
@Y%j(&0:}}dI?:$tSgTg!M4Qc$^<fϊa{@Q'9d3PKv8N܎V,.u!0PԠйi ,p}=*Z>ޭSтAǢ@V,V|~
=JH S!jWuMmB2-nQǔHˤKr2
#蠤9ƼFog,Ǻ
 Pnb_O>.~s3X.kgI^>R'Tѐ[@Xy[&E;t%;!WzIŇ\Lg5g@nݥ@6MEzg
;zR5
s0ɋШ߻"/e?%$\IyBA8nBGiAP :=7]g 7EQoۄO&E)7'XXDDp+m.|2[zi.'{B;'{-Iqev]l"OCĖQ]М}~>Ļ݅iP	,
Ìдq/ŋBmЁk
OB.fTab:475wH\W&yʣXl޺<iSL`1xtIir9-O?jcm`#Wi،D)ӒC98auU|K4/Xp(8){/}d4Skh5A
W%?J:"
qVefWfMqh-!iKZN-p	CA9Y$Qu"ovĎȺH;=aZ[S]Lru\#"$}l}?Qrz[#JJ
NA	U
Zߓ#=:XlwPc 䯄!MCG$#6e>σ@TL8#yVĚbxqu$ |[h.`)%Y(4*ts0_#J5Lnw9*a͇~.||IM.J&	/ilp.fY%b,>]~ʜ3XF^<6	9
		mÞC2]c0ِ~\Eh*.vr\Lq.)ҿӰ?$AŶGY.UfZA0.@mk| 5֎
)ludxB<(_0>>p=Q
L˥aIh"|pYq;sJHdu%GN>o]sA椀Al"+PbTmjҒW*BoQAUNu@59kCNZtwf>ˎ]'d3;dt6!fȍB!;%dcz$zv~v1(hyVUmCP*O
~>ءM7,,lV>-Zt|>c3F>h8Q,NĘףs\e3s!pbqs'smy.;N00LNy0oH})S4D,L
jHhNjߵiߏƞXSŀф_+_펥=0@\U,5ŧL;h2@+cY*h0=Y@#zhOKK՛(gd"RdSZ!&4NI:$`ю-ט
	T_dI]R_r\2m8aS\%Ƈ5
~1aVU!A~z+X
wJ75Q8kEP6UZ.q7[n{JMY%8޿	R=ீ Dq&+zKsA>D5LmdˆOo2)h=|B8,lTaohYTf%*бle.A6ˋ8B鍌/)lMQXGb$׷~};?V6pqτ
LUN?W |"CLylܘVnY 4b+I|4tG-~aYҋ\ (4FCX47&sW#PZ](]xTLA׫G{sCnm+#}0ޣ0ؿz%Ț
64E;XDsC*]1lQ^b'kL߬o'+!a]w;G	J%߶Ix|8@p[*6Dg9N:Rdc%7:+Ԩ~p->ɽE=wFjsA^3PnTY2%	O0߷s*@LO?\S9ͥh*d-.DS,()9g#t^bd
DY(Hf.t~ |DM;(3/?縞|eV]{,J)RXȠY; ٿiYȋri4}A&K+mMZtXی-@4/I*E3o*~M[G5e,(Kqʾ{(4QmeeuK0vUn9:JAwf8o9v[.m׉@vކ{Bm?_ԃi}0Jj6|=-U+qidǬ=FuW4jY׼iG*wt4PꦵE+Eah;6 ț#Y&=)ο348d-"f
eHLWg.CĈbI?	֮gsrES
Zb	R1"$C~!ңz/SS`&6)ډ݁p]3_gͦv2-lѧ
a2k~!q
~DZ@٬J6D+cuɪ8JuJQӒ	ry
mk,{JF|78|{e~y&
z[kA0QD	CˆO9!'"}GexbbrkVx}_N
/ѷ%dq@	t-Y 
u#@^##WT愮Zc1CZ,1MuJhJY3K׆p1ﲗNzx9
#0~Oڄx,zv=$CZƲ55F`Nz@yX>(=}5LHR@jO@Vң,.(/*|.:#˞¯dx}i]FQkIDDV̿6dUSNBSMJ]+"*ss,T, )Г|bP=k(.zB[/BO#^i3OdP3=mnl`/ﰮ>g[6BmsƬx?ťjlK7WZ;I8mwʫXv!ܺx2Ga=$o0>r}Vׄb'c,Vk{*%wTBnZcfi@FTB!_j{Ӷ:wa5
eškno`sk<ѹJR?Uxn:Gi1##&YV4,Kz+}urW$$42
Ϻ@ֻe,oϟ*(ღV&?lEHpOE@	/x۱Q[)Z8,uAK!'(O[	~#`M|(o-^dIy9d^MM.^,w2旓zU$J#!kޡSf#:o%l.A^x-MHY6B{wfPT`x7)}חΈ#N%uJæS㽙:Ϸoyn63q@(<<7Ln`)7gP,Q2a)Buv!1~89LEm:T|3_
8HVtU	Ȟ9EV7jgMhx:sBua^Ctm:ZShytcݔ(>RlW|@"T{ezDTZ-,֛a8~'1~Ô,¢Cm	k_|::<*Vԯz]3%~>yr|.uk1ǟO}mɇm.A`ǽ	7C!޾RĔOC<>PCo@o[IOdb97HWNY?fЌF/tj@QBi02 xJT,m,
1.h@)WNR,?lRHyHcϽ0"MEOYI[=.G^.d:,I]{Wonf
=?|2蜷GfAtN1+2o@:aXC֐;2v`-Cѭ!(L`~v<(-=oO_ۮq?sXsO:3\SblWf~̆ϝt5WYWgQ^{(U]jA/LF-
pm90?]G$u!ljhjO\9bh7clLb\3fB1j|'A	9+M74ki,O'=:{B"wPt7zC Y#&o)jG:4S{<ІQT@'Hu>%Ge+G1fO³Ջ+~_K)&kC|#}ܯO*:=XݯVT"\@v\rLg
v^/*Ryi@[xq4+?W~#ZFFܕe0ti+Xtf;n/>n{\Ho'w7̼68)eROi2@'>Ӧc~RX-
'v~Wy G%f*hai+v(m_*\Ŋl7{bYVzPi|BP#CאZUIY%)8X^ewO:CI}
2/X}X>ޱlj&лV;nC|[wLjn%ǵbC{k݉{g./`4ڐV":/O*+/h"4|KߩGP@"WPo*p{-M̽G<Rw~P2gt7/Le̊Q*>)k^^~^T>UWl-ȧd]eyHAUP]MLH}+2fBPҗ"k::U⸥@6V5Ìl,|K}-^
g$lC;m@vuI+>A/y6?i|:{‹DKg-#p\y(
u.m_FRǩo
;&@jeO&n+DuDI) ہ9tZoֱmx:#΍hFrz*^ljnKhbiYNVaai90V4CSf
&:	]ֵ"Gj@+c 2lSW)y9pc)m]J܂X'"`s],44oI8A6[b%՝ h60oZJ^5i9c[MAq¨
lYdC;1@KuɅ $H^PB;xv:m{s7ub!dCȮ#\7oti
y6HXz/6"Is`|kӻv@=ɊNL2߰""c	#:\pR0.cQDZpEg}eb@b!Ϧ-7RzCv\֐Lkvm'p6nǟ%?$}B<FORMUDJVUINFO
XINCLmemo-tools0026.djbzSjbzNnvQ9%_w658"eP2@9E1M5O%Za3-ޏ
|ౣK>9'4a_󌏒|bh9%WpBkKb\A,:aÎC(
⃣9yPAX#8/}HZT!Ҧ?A*+f[o=$Y*&COEX@'Y4%>F9I}}:5|aes޽lj}zsk\ZHiˈ;t7QSOz/+F}
=3!Fq6To@$E!V컴FP
&}oCXud;-?$oIJ| Y/AnLoU"z4}HAn]}|I1u :Jll}39i$%*+O0Rrj3 ƊO2w6S&ĩnQvU'bGI]sw{kT.9(!c/ЧWAلj~-7卾I@-$)gDgKDAVCFJ Mpc0Z0&B0d+C=$MnTxܸl S=oӬ7Y*|WQjY"_v}4[QU,A47am$*եu,QE[J(3,h#6DJ8]7ᤗq(ESgDȦi/Ǯ22lY8U]_9[b@DĬEneɣ{ma%v]BkiKabřqNJ03U=Dö}}Ûia"-Z^"[6$"!b*@/[oS?s)#!K(t#Pώhgݟݥj;dRpO'Xk`v49~'!>0o%f)tW%-UU(]lĨݴ^;fLQQ
Ф̦$܏#"-Z@bQxHN%wq17kFd,=#oP^AWs0˔CNt44=֖DA0ZkL:=甮䯶R2p
\%ढtBb!9O!ċa)Y
	҂,<8Q*gDnY)&;nR۟h} )IEB$VmC0ʸdA
[l/ܡvE1!#L[X9yo
[ |qs39Ȝv_hm0B7M5~{W/6yMށ*_!SIe4.$}%홨E
Vk(kKaJk/v*{KEG\gI
U}䖈?تN&%b]u
B^`Gۓ&B
YPbCL>6mGX@1#}GMmsH빽唅d݀.u*/Ih}K[ˇΐ:$4E4ZMN6Co2TEC(rH͂w+?8yǷF]?h*	mcSgkHkw)5D
?rA;w.K4wB˸/ZH:Z nL.X%ib
%u+i_Fgb@k
j8ࠈp/KH),BOd	y P!pc ՟'U~\B?<q\tkIqX{~' qִЇexg6>uF[	~+LR"שzenXs\9wwxDA2Ղ
)
CF[݂X10<++:4b篊F\a?z}!CN/;rbS6iY;9kWz!J%S-Ӛ 
DD;hd4Ft
bT hFןtg&,ϫW-g
ݽݕ#%rGa2nXK*HU=;AIA *=/P)zd:8Ec*`z|,oѷNOc.J5qBO6)D47@瀀@jŔjOĮ]H(舐Vx,x˰J~!cӦ"gko]75'f*n6ǻj666TMa?5M^SEQl>9k(hYlj`ejTfOy3p݌ˣpn1x-R?F	WNlw嬪2c|\t'1ShW\TX1kJk+;אgRB^Q>rfMN#JlLG$}	:Rj&;xc`鼍Y[<-[0:O?|0N0;7{8/c	dBqlt-0MMfMS(cG*D	P7յRmm}L MiͶ
Z2᥏lp=yٗY&B	`ޚ&Gַ^.Y`ZLoɚj6RPKRPKeϼ⪞fc);cV
]hzS	6(0X6s/[p.e ~jz!4$%"##!㾆k2c*8_W_D'4WpjIsOld,$b'z	g')uq#~E̜8܊TwnDg	(9&&8o
I|4wNULћ^jd*rkc(Au@9QX۽
)JЩ=h>d=sE¿c>ZYL(#$'za!YwoL ;\pą(|XfsSd0/{Jt"Ȱh~Ǘ2GcA9nmo|ENCK
UJA:	Pgc*xs;l.cݕcXYXz6>#jxR4) y
1lcā+C|tImA5K&];x],BPk9Eφ]Owop\	
`l'_7e&ϪF3C-r^$?w*R.3w?PfD@u]6G+f N2`ƶ(ܰ	@sڼSsຢˁ%J,p\rv/+Lg}gC,_W9rHSݗ\mHFYɽ_l]|~?Z%2Ҡ[pkB@cw͖p1n&lU/CBfe4T8`*cayKn?e/o/QB
s	5VF{cr@YA;IVRns%H#:)*<@%zQ(ϡʷ
ri\r[j<CF,g`-◎-Zs(=*k7D<%S3s<&0:ew)ɢ.|Q^MEh3>!HUO%:xUr|U%'-l[\yjݵ٣Wl6ץCUra:5]EM6
s-ReI~R
$<
$?VٲB#Ⱦ«%?'׎JyʽDE5X,EԾ(ONmIV+?So/Ү,|snN#Ej.\}3ڦu&w/'`tG^MMAEI#ʑ!ϓhdH/6qze;P:{hZsLrc5t?w~Y:ITy{v/w?-QW/7	Mo9;"X%M
)͋)KFxsp3!Ȏ֪XSae+,㤄7e`kC(%0f"=iTv6K|/ږ=6! H"~m?&}>t_9g$),h|hߤ@ѝ]}kˇ9|K;_/2@ZE~Z|U(y GZ9҆G"XMo(x3 v!UzL+kb7|vXf%A;=Nzl= /[NRa`ï]&z@=rŋڸ8v{ȕgKdh_χd,̤+y
yBkK
/n{>[*lgIm-\'\xK5ZG*(J;y#h1>B3ٰ!tDb67M@d\N}9}RpDr/yZ)@3BWF)SaPS-ݭYun4|t%4 .kjl?+p{%u|M>sް	Ko&G,.gI.ͫ襶֝ʥ]Y٭2o#,2K?zTջš%ж>8_g4a&P}lѸB2Z
}u{JqK'CX0hȚ*H`oPRiO1LS/BCP"k\;HJ(YZ!W¹A69wZ(2Guք8nqUgJMVl9-IzjG]J+SDSһb`*\0g\KezA-HlD-F.-OV́|O+
K5 _+}D(Ur24,_"xHФd_\d3	)
gC3.6ooQnN85ԡxmD6?*=0/\h
xùl]'灐yʡH
$n1Gň!zKaHWZz%q(q-jOlǘ3L?`9{d ):$Ҽ$ϴT2hc*o_?'' dᎎH!!/o<=@!J\uCYOPO)X@hq{4Psf/~ktҼl-,/+*ԋбuc̩7Eßv98z>E+ˮk|qf&1&X4
<{Ot=1kF..%]T>OlzUtwɂgIs^1^I?7|m­#~H+"	%EqDJrπ<@mWRJZ;ѥD%/N~D80[Pqg
4$_!ΐRHz-VWʖON!	S.
3hg5۝~2Us֮}Nm[\!ۀo^."4ys>/%B/5Y?2;puҊ:SurD^B
MGcuw_wj!jBx϶Bnr{\@\')	PvZ+E+Oe%uW5z6주k]''x)5{]8>أOl=E"⃛~Wba1|L%va5(5ؘʻڵϝ85l\o`l#H0H"	7zY :OPo?vqӱ59/Hch93LB$'	~¯NY[)ڷM?o TY
+2fGSoEEhbwf;^'`}S1iѵA.	HBiIbU
4cb5RD0 Jgӵߗ=84}-!d4^ZwTn4JMMa^ք{9su)U}b9vwD|#r,4Z7[ǎ'kL[cҮoV߁0ކtQU!8*bwNa4QD'K!r0](q^':ܤGAN;$`?/N$;&xf͢Gf"-'$T?x,31GN'ƹAeXHW
xSmQ*N#wTƱHs݊BGUU
 Gsb@s{xl6]男'&n7!gA5<3 .:Z:`d&sDXе,X-kcLy5%L=0H'285PȻuڈ@Pc;Sb2Ydo_͛JP۴g/2/e讎
$Z;Ω)lxG;AN"<:`K,\$v[sï~{-hVfB\}¬1]vvt$WZZlDԼbfdXd-o@-Y8ƫ$jyz^|Njdr:iG2]Gi4^՛l7ҶFOW&9C奰wࡖ`kZmP6F?!rk*ۃ^1sKΧX+.Oƿ"NszeuA3Whd} Ծkz`с?L
[^ILj(R.ڝ+)L
$VYIhwq[h;tX\ٙYolJWB$\>iå
pPfu=lOuJ[Mz'{QAwRN}/JNӦ"=y%K%͝ yhYoxpVQ*ULh:e<߮A[C/;R.W<`&apFHF7Xy)RٙPHO5ξ?@}-
!F ',wV5JJ{9(}ߝLR?=Wjb
3JSovn\Dʄd+LK\9SH8`{j#)s1!&IRnBCeU*U ֻn͵*jù%	L_Eq\}n[(x'PׁC3Š$1F-Zw2CD?4DfKAʙd&uy/KK>Gԧ!Mcxy!Ys<	WS;|NztS
`VvxZ?߇ѹ&1ztx+.WQJPfXcC	Γ;Ë'Ump7]+=\#PbSq&J"
>}F/Q4HӳU>I&OR"c`.Mti|Ln킋Zô{ol
U"r&YjmfP} QIc.{Sy(4DB	cl
PoW<0h$.n?k?+;bOzh%ŧJ(;By]\Љ,rৗ'R3gP#!h|BȹʆU}cvC78ujShsCx_]dJ5=C۾k{ʺNmuV>p̊u-PszvMf,_S,)t!D1o+&\7<	C$!U)@DBE"_`
ݐ!46C|stDӝ'{
b$<[Y%аDtqME`t[6ҹOz"智frR9P`V=懕s5P|J8{vЃ+WS'axPf'Ky@s:8+JoG=[;Bȍi1ku#m~tr7T*|rޟ4%	pyJRET! :H?55W^}kyXlV|i듫JSsiژ
za^&Kk̢r8X6s]U
4ڑ\=[C%CLψS4Yn6=v^Q[_(zD{!z(&<	~u猪xxq7=Mn00SG6MKMMxtJč!b|ajjqqP߀:̺LHSg:ϋ_=^=7-^eOWڸ{
ٚ{[F	&4?S-n0=1"@Wۜs,[(֒xopjdaՃQehJ(d'J;'>9ZDQǎ!F}.#MN&zRjW
>p
0*H~>橑t2V` u8L
\`r|c'!Z[ *n/ghb%|>SRMgd?ݴvs
26⭍K1]*7@8i
0k9=..đ(~1DJ}􌨊?ߛ
~YܝÚcwAL/`<ԢEPr\GH v!_OkQO(=62=P~JT!W}:@7+Jǿ	j&JM!|[%
6owψh'th
˳*

ZC7URjK^#UbY#^DM`ʳL@[ܤxyU`GK}حDor!btP.1տ+a\q<'䫣6W:'`;αkfb=<|{WL~U24O/>R\ė=5	:q!𔘛QF,%%n@XCeE;kA+Ï^gb,ә_pߞ7an2DKKV(H
n;Z9H_EĮkcZN?+;Uӻ_3(ɚZȈ	}y)*YJZIkC"X#[M
HՆd-a%Y7t@]êQ}B6Eur@-oh{3({754~J|Nl8Hz!۽^D"[.
U:LǙ;jI)FpLY<f@jpe"Kj!!i(
ˣ.vdOZ+f!Y/E6fA1z}-=1 [\I.V_mWDWDLR`A_o?v}kE<j|s.{|}Jqw+X禭rHO*-He4!of-_Hk(vj
?.A[?h+,u5\f(2ra|~Y_$Aa#$,^lp
vC7ش(lj1I)WI1w93,
PSh}l,?H5~dEZ$-yMyYIEmQXו\p["OAjshwH)y~i8)[@c;s|zğ'{?-(]˪ԓlkg}p$o@J+q4uxSd{wZ:҂|s)ySlt8ӜE3Mm\7bF2ؔ{	/uJ.f!^G9rD5WL6ۀk2^#0[[+ WShZQKY)s5ꓮ.
*@<ruV>gIVs}S[ga<!/tjv,YFwS-a8p?~+^.'2^R	KW=:|nfot3	QʇP5
J}.mSPGBoO#kshÑ9?Bt+9+u1xrVEC\Y<}l}:3tO~}e:kvsm1C\2|[R60x#v%4K`w<*HUgZ	LeNCfLF H\AM\7DJ||Z;9
T"AjJpbDJDFNNҭ|KNae \`	B+㊬#
-##G G7{u%k892K
krE1wF~[`SyfAhuiZOjyK۬oeCY|E\E$ک(0B`qM;ey5C9̨p~c&}h~Ѐ&)DRq<)Z2[*Xg]Ĝ,CMUiTI+5?A(Se1>\_2@UZK劇AGJFѸsayiC¹k̰Zii@~gd{DMy˜R>>g׍Ϩ{V-jԮaw=MpgQԝ6{VKzSK=@CH
=v %=Hhab;զ3b·U
>NA|b7Kb0}W4pb)YlY+~p|^]gaho"SA3ͫE)5:fg%9X3}0_4ϣQ-%`:J|>oȮˇ~}3&{3N=XT&]v5,_wffx3A;x%i+zϬIiN.OPE8pMlkr0	,\Һ.
E
{E~X||"l>Ia*Iebf1sBhVVv}^to7aSsx˕;Qij1k`mt91R@(u2	A/ltCR?c:\0/'_qtN=O+=h:'#MGM2,;:LI(S&| OK]ڷ[dW{m3tt4$+L2?3} YrWu_ҔyYKPFQ]VKۂ2@aM}2D8cs"8.G&'n8([#eB$([#՛ɤ 35so<K^O)b≲ßQC5L~j!AwV~(f*.FA'b_*Y3C[Qp%ʈ%δe=qϻBuY鍑Ff$-&0/,F(Gf?|j`DX_[MY h#j* -ߥT*E/ؚ"r㉽>S[a.U8#1C60\LFτ
~4Elb@]:em?*)$"eda|z	Q7י'`a6~ҹ]kK-obJ8<ٸ)0BeF"TG2eW]	?RY0njD^
	S6P6|gnnG|vuz*91P)WApΆYG"R\*{Scn99`u"J<9sXdLS)QG.Y`]
kzhvKZHCKΜfy#sk^fK0>GJ}
4aՠb(6!7`5W8"=)thO3;,-E*hAFIذI_1^̞!j\"(5`cw%|i2)>@?M㩨Z=**EՌiA&mVuPsu3;x6Ǿ=lB0e"IήΈŐ	Â$~޻٨.<E7^aLQc!8PMjhXM1FQ@˖vh"I˒IL[7txC
ilUN݈MEGQšh
bmTT7 g!"neZpscf=;oX(HpcAUωLR7zztTns,Vjt\.U$;v(z~Y,NXuD 8ljpdD>3%>lcL$s Gʠ4K<*6"$II}3G-dUlSM9||>on¨T0
yzRTe`sŜ#D1iHIrnvQ98rМDžZ4DMEY\H*良b5di"SEERz
kݫz/\<(5󵗤%Ȭl>Sk췻MhvD0W]h,ݣ-V~BcEQk߰vLvs4^UhlF/+^-azxñpjyokz܅:0XsR?>ޱ:^s<_΢_|?]BX>>w%Vmqu^(fq.̎
DQ$,jOoQ|8]`?kvmO4
-+Aœi5mI@2GLKQN]t|oT8gW>t^b-9ڠէ蜵P!q.G01BZ(B</J>6yFE+2154"	?$7,uYqC,	㝥a=^.M~4)F&ny§dÀ:DJB;oh	վb}Y6JR,ɫa؝pxDn9T3ǙT|yG]`.fKƢ:ő1(f%=+W/e%c<^ꊩŀp%k))MzE3@c:ԗhDju"\:ֆsqdvV?8~{q[~thwlm+>=
B=@ʑ[-G?&;["xʿһBLʥ#D֋ñtqw<…bx}VY[fn4KibTeE8;u;VF	hV4Ī?1	orp3m4uYBՈE#7tXFY!hpLSꘐjO	jTOa$gW>d09=-Jt,UOdQX?W'50xOWy2سtprٱmk<4F"%iX/y-zAXUޭ_"׺dgd<3'r;zsPVHYl^-
p,cJ։JdU6|?8ر`ipB*H1f-M"t-BmǾZ'd&
j{k]ӕqeLnGEa41z璥SkI&V%W׺HG'ӺdkvR84z_ZHʉ/97\|͒J;+xKSW=+%zdކYN5f!7㷌PY{bT!mlۓ6~ErQr@O6G`ջ>t_D=2:y(%Lewr	bXh7AinM2IYH}#nĭq|dPn|aOT3Z 	9u)-yO8Bs)꜀//~mUyV'dCHQHcR/[F>w'%ۼq5?yQ>W?@X+8&6>b>
LJèŞ#}.AU`љÛJ=㮍LLS.Fq ^
8@W*V|	Nt\jAJAqƛSF7;_Җ[(#kGm(FG	#]ݿ
#yw3M,Xg5B;zIh2;g[yolmӫjHN;W3@>HHQs e"x8fvn(
bv5
3*niOU/f.Qwiuh!T,6egy{]wG)
 0GdUű/
}Mf1>
]}=co)/ÒR\,JKQ
idXcS	%r8ݡV
fM^75̌.BU}qo6[Cd_t4Oc}~}G-734YV@3Lwg#	FM-Y#EB5{GLyTט0AxioN}BZiZ>df*\Qu局Q%DB*0F!>μ"O&*c3:)GpC
B9^iKf
AZ7/)j]}_ /,CP,ȉ'KPVLWlϪ)f-AV&Zu_hpJyk HF3˒E*$C虱6Œd,"	1]HͰ
L&37,^>\DžKûC?A3J[m:1kq'YtGgtb[wϐL~"Fn[ 1j)&H"t2Q&nazڝ[×=E^qmߜ
¨0'f/QߜuO{FZ1ܿ7eDųnSϽd\o_)+b\9(EkP±]ʼn qlVsu;҄jg7s9,;4gAS]MhSޠhX]^+0b+O&l*N1
SE{%D Q=E%z8&?jc:a\) lX>wGӶXj%jy"jX6bKϗP.ИÃalR{ U
\&JyiӠ*,uF̊,'>n/UO{3ej?;P1\էj/R19vX05`HO̥Ŧ$)~q_t@
z$b䤇q~=oIQhg_X'֬q8&`O	ǡ',(1TgxTA״GWIb"#1PAP20K
:DW	A!p*b*6z߭(QE{+3Py"動$ejAP!2"Cu9mpC*jNLS3;oaB0]Z+j^ą*vtYWx+zWZ\@I*|(;_DK܃A+STBQӶi#`FQ$xDr3<
qBMCCPງo2u%*֝6s33*
Dpan{]Io:'
OHɚRX%Ioa3لD٫='uoCة';gk'9,
8OAb_;U93MJ)>J|OA@Ic0[kGnp#
<76r@Jgl~
D9|S+AcdoG{t$e$GcYC٘,lgPjdS!QbFRA&M,cSoLFCŭPYRPGpO$L3oZU=/'{MRd	U*Az*v=rhKPZ>0Ɓ u/ON%ۗYaDD"Y4u=vL̑dD*WC$,4ە*Yi8M/@1p7ÿm\B&2j-btzj(14c9{Aʬq11ryRhae-
u\
_wxE踺$E^$WEw監<0-Rm:4W122ѷXM
f3b%=U^ y?JH]UvQgaX#td~J>?H4:R
>(X<޺L!&8b\,s+cm7#
%q۲lНB$kByLR,gX4cX+m+KJ	m饨!u6Z$}8v2}g=GO{++s.<XoDߛ{ϩ|% ixW8w5ʶr9|ODz
UEASflDF,U_>Pz]A.P.,(~4GX&nF/S~8dmŠ5InRsI,Tx+v)RY])l}QWOsE
eSݾq}Q?RvUԖeP߮
Hb5rS_G#{0mqS)>d*~OAmAq
};jx퐢H85'媼 4_iW-.[6񗡄W\Ŧڌv<)B7`(.&מx\]H5#BJ{@1F1y7uΥ`jjښ\Ȱ5Ȇ̲/H,άL{Q$ 'znKbw<h^p)Ԩf<=o	-<⠾AR}fe EY;x$u\Uf*W+N5{/ &NᡒvCL$i	/[(H/]v'gmP<(hT-F4ٳm8a0fd=ܐչ|Z0bIIߩ)~*77UDj_kᶢ;H4kŰ62{8YfӺȾ]҇/bɹ=aD$J=#

~̓eR;E%]A*ϦBؙfļ3=a
ʽ1*iKkG1il+C2|6qܢN%KK9={uO8nތ.3~sKj6J86UO68[!2d X:VpbZ튁vTӹC2dE` `8[mQ5|Xslݬ6o.3Z<ߏL̎D
~U[e2}_E!Qi&6ITN=*(	yݣ1ţp
W3sQJCz[.`]tB'(2OEf@S>{봵Y2{$I!r
l{TݏA!할
)@+&Iw_9A	~x6^ ޼+[=ˠ^ղ7Mf\coBxƻ"љ\~\!2mco!tˠsWE"0YE3f{ZFcNiqύׄv9Gd\|qRETYKnmU$5CwN[7XD${*g(]xó˶|^c7*vZ{!:U
P~J'ꨙo`$zDLI&@ً	xnda3"}S|5.Ga>Y_mKIm4%8|N)yK#Xʜz>xx<'{_i
笐AWd)N}p*tB̰&)!
zz`f|MYUltw(+wM"U.4BekH{jh9=hM@I9:7W
,vr7rqCO?zX_^pFN=pZg҉,󷉗ew^XL6DdSOU	ohs|a
l|}ᒝam,3GMzliyMpT,!٬6DVu/m)?FtfXŭH1my}fAY(cI.\jj{1%dWa0NGS2꧚/G@u	g8?~,'dzB3HR٪4^9S=<X>(CSJUGvhD|Ц>iW
ȔwNӤﱺ~DXOutłUơ
8XN5!kG㓿 O);YҼ>__$	☡vBOnvڐq$
M>fx"|gV|9eTX?,+?`1a4z>ũW Tm
mk`XFԛf8\
u1y6nʶ ̝5ciM@*4xג@H'c/`w4`Ld7%A5p>2S"34ve+2U_w!"V|A8޾`ȐCt75Wt.@u'HfZt	w/滐Z>$
1	Kƺ0Ƴ'W!`g:x+D}=80zvEMp>b]?7kӧFP]u+f2S>9|kƆxۑʈ90P%5~f}fF^:]}L0XP]Kx:YOutowߕS^+
4ݤN:m<{vDbc^`@`baMLl,;yaԴAica-T*e({ek'~wv/R`xZuI.B7buYF'yUyW#?2q!. b	K(C&j~O<+JP\Amoh*(7ąil7$5INhmyQ!֋~ww&-B	-PmMϑ0ȣtIWݏl@G/jE*SrUԴuT"oڌYw8x~7=v}ق77O~-S0A6snvxAEiDRf-6pqC;-3xPEԹ"XrlUJꀍw4ZR|LQ*1gCDr	kq]-\1630U{-킥#{ަVu1^[kzjܜ4(}:
/R[2mB\[W\kZMQJؒ_V.x=BF+R5|b
~MЊ?ͦP78m
ttD/F#zm*˷$/kt6R1+71tzCLZ8Ea^X-׍)6x&v-ߖ'c$Qb۾8x@W:=Z6:k}@J	"zԼmuS!X1o(p$KId9]PJRjPrĶ^ķ5/wb/u>+}tWB{mD/k*CP"
ݞPq6^q{*`A8Q70]+C51Q&6f?3)0?2H
TIqqy3c'otᕂJ1&{lwQ
)(Tf[P^tnOqK%Ѻ2:6WMeSjn:ҁ!+!-&+I
F9ޭ!Vs{fgLj"B	]rY?4w (XRvDCuiX8d<-9E'v<)%P4Qۮ71_L3NL"Ok,'
2XuvH/8 #[p1۹\V?.{OtQ>!Lܱ..RV]kj+Z n
4/MŞT|Gm}\XLQ(JÂ$CX[_1T9E#>=af1^^ETHӰ2E]0cֻڮ]_jf#JmT•-~kZ+}E?*^v5DQ76+E35`a6g*暘L ckI_\Gt47ü"s'箍Śmȫ̄L!bħjt`0BQyjD?#Zxb

l_$=q!#!σ:-Rot(nߠFܡFo0em8̓bc'Ѯ8BrPeLSb%gK*1§-kD%z|O(ֺ$fz[3Dߦyәe
6X*atͬxS½5u|\Xwt渾uK!3cz9!\%*ǖ~TCI(j,FJ.ia	G~o5F44!ofVccsa*ז=tvBNAN89Xndgz^"ﭡ.sAgP4C^j:4b|6V}-ޏL}_iVެ$?0(K,Z+(C؀s!./`aw`E8u(GWc-v;hFe
`2NKP$|!E_"x矅S	K}^I|{WaSD!M*Dt{@X~QnlbsAWSx:DU[)/n/0J9/m ku[u$5*M
=ΆThrU-SZG)eIZ:?_p/$HQEC19/Kô@".x?
!Mãv"LD$::tߣXkXfG.jj娬ZkD[;{GlvJ?h8cLVvL9ŕt922x[,Veλf}S01w-mpV\3ĎDOd{Rm
Mq4׻y.u|t1Sy9utG2*("d/<;jרoF6(>:CK;BRO1r0bnQEe)ppSD<ÄWG,TFʜ{gf;7ER8p+WZréU_)G=Vʪ/uEG4H@X*"@
:8Wb,(P,I	r0 3;"	j;Gpoϑ̽}rT"k
.9=ҿLUl,3o2H'jWSQFgc1:ƄmE8f I>g2^3ؘp&5tý8Kw,6эfu->u`O_=6,@Y~N,4s?,U@(*ܫ%
A[
Tq=}Tr)ws֊cZGd,Sίz*KGS3,aˢw0r⮟B' M)tZ0{+
&TbB_zX+щ8XF| '<773;Oy=><4)s
hY=)¢%s
^푧za⣹e,꣛zZS)>40lYؕЏZrO+Gs9{m
?O&jDY1a\]Yńj9R<R6oBZځiMO7"i
Q+XBY;ZCv~%ϵDDvYq#0vz6]BI
UFc8uáPo;bl#گ0^:p

RNY%8AtA*k8Gg
c`ĺNfa\<$,Js
V((y{)foANY$#x%_H֐TfL]ff,KgQӜ@t'==lC ꆩNUq4F9{ZY٭oGs69
hB[Ց}H[2y4 ql7^d$Mjޖ˂]TQ}%Y`%W;ͷ,?[[,Y
un4$桯BZmODf h!7m!;
#PLΰZT#	Nz2DN1dp:Ӄ<5xiC߭J=o_tZ&Xe%ry6JX-X6kz-.j)؇Y|g& 7PZ/'r@Y&rc:$gXt=3;?C`@
$B5Ϝp@$H'	soR#}nv(^q-aejQ$e;z%?31ǪtԾ`+jVAKB@"r~Ӣ0;]Ŵlćha-3S[LK߃:˶#b=F0Ω9o	!
_cuE}G[tFmvG[S<VF=Rͼae"$FUɉ鰑r2EX)U"nMxE.җ7A*6bUr"Q-J|qdVRҒdD_ˊ9u=qrC!Ua(
<`SDRzED$s  f ʅyl
bTKUzҚ>rgמr+ded4f3o䧠<>4.8G) 2={ހHKRFcq{5D]7CB4c4̇/+(-tsxK?I?t&rXSj==Xȿ#id41SdRq%dhf3#$g@v&wش!gd@s8Ye9]_ǿΚk7.1K4ьSEJT(e;sǚe^s}*3Xâ=U7~Vut/f]	ۜ!|pmf¶hC29A>Z:0Z`'z3[i]:킌3I0,mK5VKz2`]>XPX?O%h3OgE̹hOM{'+d/@H|[=A\朱toX`S0—'@1LV-4'?m
ĖmY|i>a[_tL[`+ʒXZxLG^șalyT\L P"lEN**-d9:#+9Jވ3be䁋UHOA?{4%ljdbkeqЏ}1q*.EY-Ka zgK8r
zr9ubov+j$=
LՒ@y@NX)SR\gmMJAV-Hn$.	q9*1A"O0hY}KCU	jzfhOR>%1Ӟ_3p6\y4Ѽx
NI
X猑4LuYKq{/Pwݫ;L(xc|}^0(6Z0?-
n`4iFv{Pbނhৰn7K7 ̖6>K1>bGmii7kQ}vxXP`ީЌ89htyYB+'f+9c8{֮OFzH"),`'`=>x!Vv(O(\
ONl\FљGn^~q8}`Saq+	
|%4dcڔ̫/'A왋
w2ȣ)l_{JGka@~'HĐ+4y\M)-|柚T>x'+yȓcAѭDIuߠw$0R_?w;NmFYL˾dgŽ;bJbjMwfKų̴	"R9ABpcQ1LjFs+3lx)7+DYusO;$ZSd߯`6r'dgzXʄHVE-{g˙X)Ia[HFO[%#=lcht.+e]/eo|/:H~;t]ꌼudYjG2r1E>.rs\!E;Qpmyn$MEJMɵRCqP7]7Xp@')2t"~FQpX)^R?ZJD	6_?ĭف>ZP~.Ja^Kàc5OB$9R
F9	MCBw[){^UL8`wh[YP;\A,_eO|֘q;
U\˥"y	tpp_OM9_#eHEӖ(n%]xiYҶ+띨C
;^"{c5@PG:|ݤˏLwr2C^x?%\9,rf8:Wj#+FǂĊkeɫ
8=U>7vWlDbLčI"DGWV;\VSx
:WK#0oP4>ӥ
W	64{$Ty@vmjyX.w!g}._'X08~[OC2w|_>a%ݘ<@gЄ1RhL2۔jU5*7J2`4m3r'ؕRV;d=&|/y-|:*?O%B?-
8jR0yQ:b=}'Ǐ/C~[7޲׆S0#> ϒT2ӒM!^aAw5QZכkl{XƖzu K2וAmhEpP[avx;ȸ2MD3>E4L+,äJ+۳b.XφzӶ1O'aD]Eo%XC$dʒW [1})VE%fq{c=5bMc侚MǒRI?нM+AtCO^/A&AY0ѐNɐ\ɨ㔁z.&cj5YR(W(^ڹDX;uWiaC
L(=`lj]ē6Ri\D)	s3^̨J̓+yvp_^jI*(>=.a)k_w:{'跦릚ikVzn`
̬䷘~Sy҆NU
?B:(֬w*"!4+eLEɦm/Q0;!%+h̻I+Ë	>t7ui}R2#sI/LL0z4Xx'R%wT8pY"9DVQZJ0k1*fU8;4v_a1Qf|C.zS^bx#i[ң4zP0Zybυ9RW>8T
b0Kh#7;CN.d+(٭k'dt]ZeH:{cI)7[A?/gzH)uY%'ѨL9&JshzHj;tC`ltPHH)}B]Z˼g-zVdP?=QiPɠۦOgA.uW)#/`HA"}zaD mD"`*:mp	7IL$g$Wl#KY&:19?6c]7G.i@$$~YJQ{Z
t*
k!殷{HŇ̤nj-!ON۾Ș#pfG' ۅP'u6U	F17{M2|;d
LŌ	ub'&5vgFᲯ?@$.;`慃R0*wba%
`&cgúuM씌0Cjp.s_=B?/$y>WfkoZܖr7
<}Bh:aW>vR]ߎr.Kr_fgeE㕦#\i+[>m`I&%u0|mA&3ѳ6;=
SHٰUIxeRO`k?VVzw%=q6wu@vo(y/9m$z|{WIJP^]t
a
3²]	;='f=QJ𯽄^.R>D'YoLX!
Y9Va:[	Vcwɡ%š@!"rĥw$ڕBGWh]5
?.'2MkT1gtpE+
'3ʵ{NˬvuHfLvpL9DDaDExр̷rX뻦 ڴ|~(NAu`N_#:g.وOf`2Tz0>2lxY\&W‡'}ѳ;{
հG?Wou
H)D;Znq[!/9*.jVr7ʕ=W9
Gu`7%6
9+ɐЏR.ucQ@
Q,!:m!9W+}3H\nLt]iK#@@TH!)`8f;BxEw0
N,/֤-jǶ$UZU
? ~)|o)$5srF/{6#b@}s]D4-b-͕}8
ٔwDxXAS,BPR%Sp$Z]!R'KHυYW/Na|AQ5fg4 ̔Κ6ۍہjzW#4^A(ra
ٚVVRN	.vUVg2`%>&(c̺1\:#GYro()+)J|;ɏ1PR/vj'ZtX&bJ[#mB-2ܫыD+E5*w!g%j֕Asux+/3w% ff$PxJ06Ô)V5(li쯣`J~5Jt*4rs:3?*.w3$`C3B;̱E;p:Ik[U4yԾsy/S?|̼>?slaK5-lYr~?B7Bw2j\vf.-f,5!雼KH^(^Cl\Lݼ<yY%hI2bYmeTWo"Ɉ>$X#:)G&B_%qR|,T.毋w`Qm6Oԥ3tY
}5Ns%}*(c~Mi|>Lq̒-U͝Bx	㵔"H_yete(1&)IcvגXnY#5yHp
6Zv3>cj֣_|L?:+ _wtکۚyDBl^=ra.t˱ƤO3/}B_
1M=wc"Ǣ(E>e1HhJH鱕T6WξG:N6㇦"qr6l>>Ъ>b,"FRrOfŘ}4c[ϿkwEf&9lt?}qt gm!&ekF"O:f5FZf#v60;#`~i_gA
G	ٿna,=p8n]g):368|WN5ȂegO
7
ئh3“3^nuM96]lVbRdPCd1`ݾG㡅Hg>UMQ>[z."iVoyp,
N4}Pi0f{nlndfqߋn>(Ba=>k/O
[Rz){OQ
9Qo`͌B]Ӗ()IIfH-6/A2]]b8z]E
f5TWyE&EKWpz.Kv"!\ՒT.8;cT!S0WYZװՔYZXToŅK-`k^gOK?^1v:L뽾>۱n[zȝ+_l֠GR/6ޚOrR9;IsxsC}=mstpV`>уߵO߼H":hn?.HT(˃`V1ul̮LA:\!۷s=)笥1CL ˿ll(V{73$黸xΛm6КjqBׅ@?֙*Ӎ!M!cIK!Lɢ~W;VZCV49MXv=Sgyi㼖hqQi$zW,HvVYo٧-uss
5(!Y*qԯԂIaH>&_S~jbDd=(J
mxWu/EkpX'V
B9^FME,{!)9icr#ăp)J0hPjudah}
!Zv~1Q/Sh[{aʎ̌5膶$JO1sDBTpaZ>0>kǧKMo<;Y^м3z.m	 slW5hꀍq!|tz!+25@@8Ւj\h;&06|4H)sG 4<*gҞcFjNzSEQ07e\'<)=f>Txwr]{2ɀ[eeȿld6AQ#EDOGTjWjoCބ-菡
xӸbN_VT	
JFv9FafkI3YN*,a~ΟthHֹMNmo}~(Q
D|и:Ux|6A5̀zYv O"	Lew>JIi>0jN>6)ͱu&~ͧոu07%.GNs]~DyJD,ckvBM2v멗iӈkvF:_I_F}#
(48ùx<鋍)6x}UO!`~kTwY8b.=p4ި4&҂ɬ0i trEЈ0ET'Aa]:\ͭ2ψ9u}د*2(`
x:Oy$ZKqerHK_-۠ɿV<=%EXۗ×kWo6MY8^/K-lE3)Pn>["j*TR[Uud[
eqZ۾tkʧBTYB߾rn.6^fWYEJYTXTz寇ZHJ.;Up)o`E-0Xo[ɾb]]QN_|cmTK\&	a€V>b-qjE8	c7T=X+
Hv\~_&8 OFl1wF!MYr{,IÒϼ6հڜV0A!SwCN|uE0X|?F][d"?ZqG*|, ;S@}9\!psۛ}%>1+ǒ		PkϨb4ϯ#rd<}+sgrsj/`'f>NC+lKсLm\RW-w,xJܳm!ee>P>H|ν0RT?)zeȕa"z	^ǖ)L	֋(z3}1d
,23[X,qpH#
{򅲹ӝ>W?alY_v*ׂun{ﴕ՞/A
KCi1m\pSۃ+chz+K)Lz/g)}l
^m
"s4J}Kֹoɷ3>( x>g=
/K!,rf:Ñ`ˣ[8HYv"I3 nWlZ
ձ5JJ`WOJE560ф-ǩCnW\'e1;DP=ڻHJ֯P-)r60u929Q#:=7ůԙryxOC)D	ɸueKQY(J	l+gDx|:q,h+^;&ґcU:^mclvC_:$xV3Uܭ^،X:ӖEtknѨr`K,چƧSHSyi$s#d.݌n\rAlN9(ř{dXY.gd#x56/:}V"D.ˬӇü<ikgL(.҇t:AZӯ01]Hn1}&G$uG=}1+ԋ}*C*#;@Ӏ!7+Kd	kx
,$jmȹH)/8aH;~g4[2n>pL4o3AzҢ3mG$e3
^?ODla	{GCbRPzcYZHWnSBzLk(ч+
%C{(#D[+Z8ƈ\tJ(aCV.!Nہ	][]ד<ڭ[14i\][ҦmDIg'9u!+K[K\9rwPJ|ԧ,ӽ/%kK:=Jڃ9G݋A$8IfU &"N;sҥX^zl.ϗ(H-^z,>^zA<8+;ۋ&WJ*V_w?9t;mzBN.w0GTka1sHu|_#!1p |+<9W1ÕƸ;r6 =65BgljF{.}.} <ؤ܍B`) AuLc^c
< j?^H"z>ua0q4@_8È<-v5EѓFORMGDJVUINFO
XINCLmemo-tools0026.djbzSjbz@nvQG8ϪNMS
!m:huž^GnF'%FEٓFkLw[ߺy(4
:"*4LR	+|*7H۽οCcE2
`G?h9}JHƌ4`gIix\GDb%wQzv	/H)/	d,X.Sr	4>ռr*"$unԨ9rErk=KXS#RRїPi1AAhKQ^.njnG̃>_'Vr:ew20	6v{w'>L,EmU#D5Ib*~?,0Ko.lv$>KBɚS(Ggɼ`aۺgoF=#hE-1@ΦՄ Ǖ4rH
u(w.&"Դ:v*~P	p-omFI~j$.QH}0gT]r]hG!<!GK2VOǰV_47*͂bp">_MKOiNHj?ToٍP)K֐',rh_]$Ҥ
!(38@_Rq$߃Wz9mQ*c0kU+dp^Bⳤ
O
	 \Tj(AVI#6Fo^.=~WWdf>܉˄\)Y|@|&I:x87ƯIP$me0hD$-d7ޯl:
̣${ȒܪaN;?smnz95sīTgMM_L
d-)ǂ
[X
oະԡ;eVqϡHI+ZZ7o
$4xa|kFCuTVDOC{Vߓ$KE*!A	uy2 k6t@	
t2ty҄|=/	*
݆"$6]2F/FKhE[#haҮ{?GU"a]8?fJT^y,śCtJѼP}㍫
^΃d
}o>0
"+O~
t'oVU;̷Ÿ;c8c{ܧhFШoBӔtQcvY7&լJ&,EZ)k*BPOP5Dg4j].
g"@0c#M	\}0ȟE`HyZuT*(-sdqGZڶd'#QKPԪAww"ZXc:*oĒٷ򬛫q0xBGlɣkٜ,6M4mW@S;E։J6z`<6?l,zrmA	M]ߟ팂
:¼Ny>@b'ڇ9ЪC!K fvsxyⴎ0_!n{-dZbؽ3ɱ?P+~X:2DcMDIc7kʛWSJCN/Uxe~٘&t?=Kť%\ӝǎn%|giA ,ȵ‘ØJJZT/LV&Rqt>]7$]I
Ijp4np%X@s&3
.@z/EN:Hs:F؀XPSJ _iyVi7z΢\?雯1%ȏvUgQ[P9NвJn
 'kLW+/ޑ$YN^yPv'cRAKq1:]hw{5!noq?㹒0Q@+O;rjNS:>:~v;uՅ*aqwIO綤R.7E9>C%襳3Fb	"p\㓟w+sAG
'I6B_Y+:ҀŌ`lGzŶ-r(`
ΈpPn_n@rz>:O⢚uʻv6bI(Fs|숓q1akJ!9C\VAc蹥ۅL^Y/!:h5~.eq8T_}B
zs<*8Sj YiS"=/})!ډdxbخ1rbz8Nb"5	҂
ٙ?#cXXi^*2cb]P
Wqˣ>;g¤PBB֗Wr6ՓZ}'vG>&!@#6JBuUҝ	J]әEz xhi܈[Z:
[ڳRtk4K\:E@h}q>OyeE8E@7W>0YcAG%	:"8Vox/L_n.;ՉaΠ9]T=2$uxzt-
w7.j>/&LdL\3[JRDz2YC7|Ⱥ,=@ҵ=D%>E	~i£[W]x;"ALBX!fm@HArmQ;f8)U4wʤ`5]jN3]F"
bCud*~AC:#rm;$j7]Q`vBDNEPD/C
,gDʠM V,#	@Ml:֭I:Da HD0/ܱJgP^e	I9AuY&\+<ʑ4$=dq~@ъ:pGPڠ:JjXWF9%%Ƣ+ PQ*.|)8&
c_{}g&	s!Q?ɾpʈ%{MYQuB]B"
_1s@N6Q;<7vx5':|k *SO"3BMZhAzӽS;N-&g	$5XhOY4Y8M-+<;iAWJ8@
$i6Z0)GI#y[b0^
E}:UCl7<(Gϲl&v0dէ#GZ-AR/	WCK?sܑ	xaŸHkgsO"n27n9`]#frl0MYX%I3A2'Mxb2:vgpyb!X1~mBtl߳W9SDSgM6Mf /Đkjj*tNw2yVĶNZ0sB"A|*W;4ԿWH*Iܯ*;(sYKÄ~!0n:9 cq`L	kˆS-'ԏۿtHvwPrZ͏3,W|)D;NX(Jӫo~EtoVGm1Gb%qEVl fF0PܱVw{zT}tPi%t{1ZZk`38tr/|(_3.WXpVCljAcZfqFqVDe25:oX]0YvM綇z{	+Hbh^XI⿱= 
1'o~ீ ^`O<(VC$@^ 0,{BY&&tMLM]iA*~	A:[0YUF 2=ZZ?o|qe:D?@Yl>gPdu;%d:'w
񎏼{
}&c0Jf,$N\<9F(@-ڭJiVHdH.FW8"H:xTIGm7%^I>S4nxH#n$:f&"SCGq?s^il>TNeCMMlbvB,!zV=,!'fYhew9ST3 s^eJt90<ہj>ӕ@{`As/5C+!ٌV2O.u_hPVjf&aKfd%CcjKm^i/g}p`R*p^p"TX0}X
ҶF $aNŰN	߬&-ۑgsSď)}Mg6YWi3Hi,/+undj9aglT`B帾bb"Gֱ!{SȲE)::ͻ4m;jYIBE86ܮyO
ƀ+r"3x+Doԙ&_xmN7yl2= <k4^3eo^}4&*)m'tݐ6
xb.`>qS|徥a_eA`C6nCC,$k.,l]T%8GSEVGŮ'9Tw<$jޒ{(b6
7TBBsSPt7	Cy5
tZBު̤-ɃRu|1	pKauAuh?$S,V֛9b3ނ'4DA#B&8([+
jOOiۑa*6g{	OlpAjbd'&T큽ӛDՆTYSl^VCZhg2EL{\ƽEvտ(SQ@`
z-Ҩp҆'Scul;/(pF>sWޅ*hhkVQ?k._i@$o{/xXi( ;3*-w{s{*5D뙬ֆ%d*;7`5S0sq/>X|0eCHal{e-JVdO*QpZٴt8r05a4Me.,_Y҇Ckc8(5ȗGSYOx[F2j&;NZuESq-'Qn~ͬ{b֮Zu	|&g^!y<w.LD%_`V>C؛i/~cMrogcO_rw"R&f!8ilu16|=N͟#įxbJVdvaÆr'WQYڎU0s{hlY.~ZF(=
VBh
#F+݆W@wx\"hj&].^(ʫ_ahBhV,ڱ%ٚ.zEVENX\gBJ>.³pmsOL
բW֩bNI0ut}\(-6s;:"~']UHiŶ/ :dK.;f#WGq'iщ'S4W`uc&=R>ش*LjȡL֮"Cuu]U+|̈́u|/BPQ#+K8w{:0vȝţ}$
ir%JG61W%mT3_2ur>\;6ȤxKJ$˳|k_;Uju>_N&mS29NR}kFIkWM:Y ?*f!
x%J+W]ACL~K԰TK(+93b'Gn~wnkW!IqM5o?rmdzCeyY|*(^fR7Arp1xP[rߗYZBN"6gB``>Vz^I%[֕_ݪpĹg9!vH"4+#z7ct[LɼuU19i):Up.TY] яVdJ,.1&
5Qos 򷤪Hʒ0[6P{ܚdCQu͔x,nNNi:'I[ޅ4Dd҂‰eJ0=.)ʷԊÝԀӫtv Kxӻ
!3M<~*Ry\Ŗh	Y*m`SJmvʬwiZue$!	@mSg:,\[}O2j̲`Y|?iݕUp
ΕPl,lNᱫ':#hr?)=^$ߔ
b0}[C:^pFgMmWRogOfhWm
ltgr_oƘdn~yt6^`~ׁoxu-"ӡդU5݀-W<ЬUrSeQΝӾ=BFP:b旙4q

rob~gQ!XET5JaGcg!bvt\8;Yz9QT(kZeF9EBK8:pVr˔%)hXA%fS1E1BKD5Z%U"mdlM[8T^}فHE	JϝJsy>@^\h%=4ޓ	&m{poLxFq׆Ү+:Zl֑y}H"m\fQ-ډ80觳7ۤyk
	5
'?gʈYL*`rXI\eE1X4Dú*ogv [
xgKSPQnld󅄤j$h[;&拎ٙx:3U]Rۣ@iUlgp-Yݓj96+/{-dV;LNz v( PJ|*:guLÎo[J~9ΆZL]I<ˡٚwҞ?s;_ do	 _?bB:\8}@
"/Ə9js2Klsy2Η%.0=m(d̎H"䆖>­9M
CpxV|BV4V4K_wH.OSa*F-hTh1_u3R8,_gZh6F>eKfsRoUѸ8EnDBhdDn*=_T~Y~`*@qkzPߙE+ta3xfc4!p2[iF3$.MǮC? lWD\_̽gjP"Cvhljڂ[D		Bd>攅ckMnTp=D&	'w43D-bտh_Pa7Q
p&'/㢺Yi.(_
Zj	Ӌsͻ-.+P
=3(:Ӽ|Y^!F*x;w9D:PKZغKsuop_\+s:x
hNE.YOAHbyR	ϊ^c,wRPĂƶ0ncFo1T3`/ˀKO0s׋ҩ&GPxz4nCqꔴKVݔ@8JG%{%z,TSbn]TL©&V0OcDPv+4`H2.{2'1Ot-4bªWOiv_&b|,KdgD9O2YdMz(;T6;+S|FUe.ݝy3`?^^=>1Z%9D0;h~C	[WĖh
z6zHAX͕?pIέ$3Yucde$}_TmJ$XzF>5*px
4"HcRWe&&EЦ4šP.|2@	}9vw"Q>^"0FT'p]|gjV4yodLO1yI>n{SX5H76sR9ZWFVteϠ6"cr 	rvAm0ASCN-}qQSft9@_"{tvuW chޖt$bpx{oC(*8O8U;z56<@
x)gY)/WӇ
=o*9
`һ2T^OF	D1::aSU X9O#Jx7ҟ+pA͗>ɒLtB1mcp$4^JVj"Jωt~ڢ4 F]r~oN;J9,kh>#]:bgWN¡'qeJ-;!&B}vz&vɹ̖b0^Poﹰ	}KR{2@zF=簴)7Uelf%*3`P
Mo
jn)}fnaCMQƀZMgdFxq0.=TnahEk]7Z4AT#	j-<
j=.x/[.Pahi/!*7{Ѝӑd?ZfzY(6/Ww֥l0wZR*:)FޠHsM1z-uq \
O*tצӴܺ{6mP](4].s+\{ic(ǟB!zvO–J8ժS`-
ۧ`tV)hٝVsQ_9
ehǭN:"݉D	s
n`:ZyvJ\:<}~jʪB|F7x,`bUڃRʞޡ09t&-T)־|sda2
ky:O/'1	IRug樶Ӽ7IBrz֪6
,H0V}oWw
djs|[0E7
WXz(We~vZ$rm̳
%EʼnOHwmȏk]mc@.j>r}41e
baprcEϲb-	 t"gldtmGOvz2Ks	dy`E@/^ؐW7Mf͌}N$LK/:Myp߈ήCȧR}fS3
\=6.,uӆ&׆dH6zjLfy536]<*mwU<:')(/Gl
X 'aH+^g@KWM*:XPJ)hfQ$e^n!*L3 ȍ=X/L?9)"?r	KrN`ݫhplrEj[&8 (E|ª# u!cx鉳o|Rûʹɯ9
u[^o8WTKuT`X?8ٕ:QC8m@d螖oJ0"=ZZlJ*~(uCV˼z2zh'rv՛vvdZ/DoH0;fKnZ@Kf6;<TݒPS'C?)*Fpp'MP4Ln
lڡ5JNod0Pfyh !FS9Ab:t,nK`7=Em{ZE[DpV礏o/Ǥ	4sFAWs;-vʝ~o \d(`!hh<n\dFf/1\?a$=-L-IjyWBA(hL>FHg!7گ]L!ry^(0.I0p
Uv\^ΑwSC#0a홥 dFIClYPTBpCV}ޓOkK[5R(⏤NMv.hKb-Y԰ٽJ`![oQT)[pLẅ́3^/}+)3T#6GiEWBV%[fQE'j>e
v;4@˺>6ʕqr3t3<)"NLb(8S"džJ	/1vE6ꠚP&@^1>H9oNOF:7 ր:KXO氕1JآQR:Q%6Im.߲l-Pt2;kmGM>47nYp£U1*o	s^u}!D70ӻMT_Bv7erok3rw';w+>"{;aT	qlk
|JCZ ׻R)Yܚ}p]ƌEpMWѴ}3%fVR/s8>>3ETD`{??*{mg"6垼w7VdK3xb\AkLIfs%ID񏢧u71SmJ_,'Ű)IJj99*h
hAhtbtDҾ{}9[g&7W2Z*]4'">UF; jJg(
p8jHoZt<3V! vZY,/@p! qt]g#ҲW]Mu$~U}t7hO+F%ɖpZm_emXز0O椢qrV@~ȵ4>&=+m+{s9%h4:mdz؉:UGV#galC<6rjX4@u$|*QeEmg0''1zq_\In2ܡ/0"/8KK0Zxsb;ׂ0#T-fqTx0u㧚2kL׋K]$_b,ؼIng`/M
37afqP3Z0O[x:*WF"fx*D}[!%LbP\ݔ30et73>l:Oa	[)fXOJ8nB>bcD17MK>`_:zUw-YB^2yeLdE@!A
x}V32-~;@Bqim~t2`xgN,yԃuj޾>Q&'/\߮h
fC~bƕ
T*ͷ=N0r$%fN2~ 0㸕ߞؒXN<|8pB!t9ΚIbZlu^\fGv.x[b'g+Je&?q!.Jn/ko--vM?3ۗb>\BrvON~dZO?ݑh zԾOy;I/ܪİ^70vQX).ɍf=5$;0eh}PO~/$]*>_ʇxeJ5Nm"dW8Ux4Mx4ׯ
HЬ
C-Q=ڌU6)?9~agQiD7	VAGc&G8iw
*i7'v\! bUp䴱lQm~\%,OŻ׬+;F2Ft^;#%aBQw_|M4MIHGc1;Wk
Y=+(mg}8@^?3lXIM">)i\HQ;4WxUs7w" $2hJZ]jDYuzUU2$.KY܋%웼|iQV"	>SG^C$}Y[)!sT,YYG5M[_pggbE+
@3ik&
aJ	C9e@L-g0CF1CW7j))gq;p'Kfت&C\<݄;}<`=O"^ms*"r|"i74)d޴넢_D~r
<FP3LbR9fIV80.wBFJ߭DwsX
3lqƺ-.]zU0r-hp{6ULeR)WB^P,g=㙌 2KųƞKX2q+aNW5e
c#ҪfҺgE=1fUb*S'%/gie{҃1-q3t*Өwj3^?l۫#d1$Abp55ݸٚkTnEh|vx@֦9iso}iJj3G}6Zł	\yM6a;ɴMSl=.GjO3
y<{KmĪθ@Q1*m;Ϩ:q
8O5ɀEBL/68Jhij@dxD{3?il,B2	
f,HA:YK5\A`}O!&ʘ1nǙETGR'cѵKW\JߝY6)CY,#ܫ>
lkYZ&.Hn?dz"4¶hh|K||w;!9n+]^~37ה2Nɰ8߾z"@b,QJP3A	H8Qw9VưM	̑S`U \P	_%r|18%zB>Kţ*
#$"[H G+0Vc`u@6r!Qa>+xhfЍl5l,d/BDډv+ye#5ds
F43oqo	
Zos{lvBm~ڌZK2^-9

9#bY]?} 'rpdLɛƹ𗖘uQAĬ~C8ŽiAnݐr~?BfN@*}xgz'{ϔ5q$.Q2˅*M!be%[rH
(	H~XW*gS[QpξNN]fte/b~~b>6"M`fnj
Ǫ<]sjLh$fy"Kre	-61
,A*WF^ JҩC?,v^Ff-#M)8>Cv^pv]]I}w;F"ua@
GszmP{-:2N\XuNC2-<$
^y䃈?N_X9||
&^Ve~٪(fٴq..JЦҌct$ u|
?Ո,lW]PDžޖ9wbo#,a_m?@0
)+h\δoMoڈ
DP}@я{'Sf^=SU|ۚT⚁rc)׭FORMVDJVUINFO
XINCLmemo-tools0026.djbzSjbzNnvQZ1lvW*.Z)
?b+,)uۮ)Ơt{)_f&Lٲ|7tvz~DܥPPeD/ob(996FhL'd6}{֏iy5>?`Bbc0ix+<ŵkVt7&ՅjcfA[;xK{qJKi9	wXIӋpGg呢9[(nDNY!BJKP|j4FR>
Mn{,RU\9hec'$cC=iߍ:G%iRL0-vy[$ 6	*o$;)ˎ먧>~\M⒤׀FŚL3xhuؙp\ٻVӻ=T'&Sb-BVK1}e_ApBX:2O_ʎ{*GXAť,A%4`(*1H}kZ=FAi
-"gPw
厡*C<5/`tn^̀Loץ}I~}
W8utZ+MhFYY͘R$kRJ~(ixP:4$0$32^f^aMxV)2Ǥ%Ma
Se-	_8E
qnvHqJ᷾EaR8Uu#EU|q?0AA$@/i"B=IĜ_jekm8*fƐH\~GNϢD]L+NGfW5Vðqb#l5Ybvr*l|jX#gD${GuiPYnfhz]YPB5ݬO-f1˛+݄^w@0+p;g<
錾0b(b.e:촕x#9W::cyʨk"c;R|.
ӬlʮXn
ޓ\_OQd\tS+O#47Ɗ`/E&DH
.D[
f;^0g56ѧmK1zL^FGzK>=$>S;ͻ52j-C1.Rnњ(ʊhnCkє̎FN9gALj61.b0uMZ;0p8}ʎYJ0D{@AZG8kr}t}L֒/\L7reĈWڷ>vZ..Sߘe1aeSN4=H{Ĺy3Lw̧Kf>r%1mB+.4vW'tj!UbiR^@DƼUuTm&4"XjD٢{F*6jm!Eʱbh|@9Zq^YN""&2A4˥{/;lQ:46C|3!~m'|t^+92evSAz[Q?`ba0H`qi*\!BE^[9L+Z;fMx33X/yȉ$H;j=.[52f(D
}C>YwF3@"{q .EumMj`okL!!嶑r7
l-N6SBޣucY(f.7U8<8bNpST](=Tڊg^b_ѧcfE!׃[bD1Y|jCt$Ǫ\T'"hNSڵ?eEn5E]/ʡ|6[)oEiwyB=uĘH9yswƌ5a%sU40GF!T%b!7װ=vGT {ZwYLˌbjOǹrWoa`ؽ,jWNc)B5=b6gs;7qO?NWBRsh1!%qj9;	6ƇodR|ȥ(8ƏthXޕ!%{J!c$bmaNaq!9}ډRfatYhZ5ϴc?&
8l4{X
~79܂Pv(BP(e\Y9xzUmu|
z"a.K+%{Pc67/4olStG"Zcs!RDKE9Ǵ-X1:
wNQ@˺|)ʛ3mũ{E^)Sxvo'WQ]dƙYP1I=mF,=(.t	eOX"/&^v1ɐ_`p=vُw1caZTrCsHGi5Q/bG(gt:>~<h-JU7!	;Y@,6H벯魐q8vʱkւ(N}Gnt&ꗽ
\Tyc_ُ!vw
U'QJվi ;Eެ(#=džǻ,0M6!6A?9,4Ziޯ(&AwE`#y"ǚ4gm'q؄ebO$,;%|nCzm:K\L7gY'ԥ#.P{7a}iNn7|w~Og$jt5XI5*/]Yf8Z`) $Hncis#*x쁔}$q]?p>7Q`!]
hb[uuHtZK«	^D~Z>X);Rg̬QT-OS&k![@
zd=Z(WdM43?ݭ1>߿R)7e^b0TF)z~8ٍYPv*]b:e?V
-f{ p u.gXIGf%4(L:F 
zLoPy:b-HzbzԀ<9Tw-%<
{ro
\_fih`ri*.μޛ=j	G'JvML+0ɴ]d^C\OH(9,<	 \H02>·đΉn
Ek/5pw٤zܯkIН>}>By/Enr3G*94D?;*o֌Xmw\AաAFWs>y"#OȤ53Ef.'-]p+#-5%y?CŖ$F3{9Tj*!z,@тȿYkyL훁!rZȟ9@RofMCG,ʣpB{!{{^z=~H-{h612|
d256t|_gdt'NMc(y,[]EDv'nnB}w6nV:2\0)j%{Lz)vŢ9ݒ)K>V/S

'G;8ȑJm~.ԁ45
wd]{̅ϧgW*qWȎCiP(D&N|-E&0̦.j+4e*B#> ~=~I88dRp&TQ,Cԏx`~::y΄@@ydN
[P
Ѧ:(AZۡ%$/KKQj/8m%̪[C9dڔ'G YwV
&K#
v@o8Cm_qhupǽJdT2fOx?f(é[ޓor5w"}&BqކP_jJңKt*x
Uw
?m310cv$P,2w=!7HSo1;"Ja	F 7[rִ1wgg4+$\:-(*If#=赋|†?O`eP*"ױwEpE>?6&c0$fە!gJ's8,AԤ)'ЯK/71|գ87K'ʉe
eA0WD,q"#R=i7g"0&3ޤ19V:4T
Q]}4}3_wy
OUJĀZJ"F϶'t1	{:<t34蠶S}qB҄o}0n7``7 V~J"<]G?m0N(݉AJn05yẇi3okT
t|j5
OHĻ@hŵCZVrW^b؏>W#~o`-kQ';t"뙗	&
7ui}ٍ`[1C|SZP~P
(	jOjAb	^ʠ*QN(Z5icb^H%B(D'9&@*9{?a&A3!"e,x׭LNSc/[⫱OOby>7WDUdOwok
nv28Wa
U,fl=u MKDa0Q#c,2{l%f	"4{Z`42!ɲtR9
#+F}A#8@6{z"fbU|i8bTB+3ǎ:J1,
A rhL-uR1յùܘ99$>vúvSj^+4|^ɗ(!k˝qVZ:i샣q0h1DHB1\dnR-ټ
qaٖA{k7R"yjᄩklw+=Dl(4B*Y[5RTqg~=v16ϝMekڨL'nG99QuȄ⭜{R;@{5BPΣ):zoWz|=Ygb
q	ث)U6̣
vh6"p+tO0΀vMg؜D4OO-ۘثS`,fXGq/1~ԉ;ۡZX{OG( ҘԆ$X֭b枪m)&_hJI:5~dr"~v$nY87l61rm	r`>g@U*
=~Wz(U7}*Kavˆx
4лǙ,lyJg88Cc+aAdcXBF8aԇ\TwXІ0W
oH<+
G^pRW[Q[65|C?t
@߶	מ⁁ՙ귦eMeǫ@[r\B$ Ɯk?rxX&bC
y@ ՂYTDOJaJ}-B	|hSLS.kեv>kYxx|HoJY3pe/Ӱ8CCG{E_	Be=iX,Ir$RudB?Dadu;5(j]Ԓ/O@l1] ZKjeh !}܀L-ffP	e]o&3jd;v5>~ǧ&_Ezs:3(0̹VtckEsz`am˥^ڂ_,rTג'JH\iD96e)jy3F}e*T
Co'_/H;6V%G3)W# .@nX}W:ϔ);DYJOG)۫2 y&>|Dt	O*o
8ni6tk4ɯLC~DtzH;XDǸ1F}\4R(ܮ/*4>Jq—Eq>k=v!>
g
i\XآSyJu
(A{DPwCĩ>KTy0^Olf	0)PKU=XZLz0} |# 91.l^Pｏco&JmdF,܏rR,)cnGn,'ԑ]XUxGҥK<*rJt(6c&%
[=7岓[l9M
EY+8":7M1)Y]/g%J:nA+Ȧ# 27VaГvetyzʗúbe$XiRu!w0]^33#01aSd+x"tldamۏXҌ8<.ũ{;p(Ħb=vd,b+sv'	gѻMb.xo$~#fŁÙ?ґGÔvoTVMwJluOuLR[bAfabtG89r'M'
JΉ"4%Ayix[nP')W(4?,y,Yj]`r9g݉e.
Q/b"!@D5Ax"bD$i'
kb
7;䃏Ui_[[s3yPwQnlι'R	=ܐlzƼnq.D&d3tzXf܃'XkؽVRRO<>omQ3:->tY_6ߍfۥW,`ǪT͇*cE$Gstթ(H7'մ.znq#8. cX/eP"5h;$=RqJ+Ξg^G{Yx׹oRFxiGc󗌰lPuSWcJ7Kͼqf)`7֧(LCnB]O^۷3^+v3|+зM}~(0RNf'k,'?dJOd&H`{	j
󃭝q?}װBNL8ia!@+mZgy!6M6)Q'*\gl_`?1d>ggQ.I .v!6`	"D7pP?A0.(0=
ZDžJf/B9dke^
q*pi/s)
c@]ZWҗLs%![+3Ԕmm,FnO'Hҹ]=`*qMu4!\pǎƱ?csVa0EtYWsHz[msO2IL=aʓ|c;5& TasHl1lӌIW̯:MZY?V^mcLSe/!̟[\Op=l:ޅ臐xJJہ/06
qrU<}W! 0t:i0Lq5z/ѠBC?5l{`P"ȊrcQG g;`!$ ]Q2$#}8aap`rL</{) ڄ@(@lmf+{O1p$~ToqF:jI,@?U.H۷Mj)a*}60
ͨK{b]
/1(?rx!zGRf~sǀ	( /jDqזLק{v(NR&6ԋu1vp"Nז:z%lo!`7){6TUG&qn0L1
? 4R¸|/{;AoAQw (̣cIVcd=AYsu~Vȿ31C&%af>~nPMNp¤oĿWn /2KyI2Ъ{T;IK/ٷJ%,:3w㧱}z>GT,%kC[#i4ER3ʯeLeR"ٽx@|ijm/v
T30lLmPVQA˪J?LCcnZ3L)ݛy>ya(;y{P
@OSlu٘|ʸ7[ToO\9M~ϳ]vB/ZlA(7Ji1kLg Ny2o@.bk>Bɏ=+nr>+7؉^V	
X%wVVC˨^ A(QovD(NX+;K=ZIikټ'L%Y)f{Xq~G55|Bη񚎇u]$B9RWZX!Rs^`|
J	Yz֧WDWa=k,y |Q(Tz#B})wR1
SmĆyJH$Tk3qKʳz^x~iaM_ ?V
-#>}!d,coIJ:榲dP>@`@qteR'ţ_>Z!Iۻ|CрC<좝^?ř9)1"|&	pvcOC&+A^O"Q*1 7ۄPeX
3Hk; NBH{0eLm}
Ag݉!.tjx:Cg
%qgo-q`hdaq!%NHTH$m8OSQۚO?|Xk=^l!,t/'5-{@Gfγ
Fa<v/uUmP:1mjuwc??v&^BIbhY/Z\d'+@&Az)_C,8sfG1C`K9W	:pӈѿH3hlC(g"	/H_ߒӍ]
	C?% KvE?'~{w~`"Czpp\V(
aW?&tɨҏ,VƼhjQ7
>[iöp`]C?*/58b"I|!	h?ż6(3ghj(UZ_kDۨe0(p0xmLY[c3%>/Aj6_l0cr4YhS*z7ȑoJ'y:˵]ՎHj~?x.D=yEk_k~̢lt籥fzpmrTO
Z WL]^%FTY@8!lS^&>).RS:u1/OѦQ"np4[b'uL6^q!ezdp>ffLMKjΡр+%m c̙EcE؍¥-[[4+O]lK@t %zSfz!,v[zW#.P>4m.ˡہ=*{"dae,n##Һ ۗ<$.|_#}-q~WPAzaÒh
5:EP.S	Wn܃47LPnj,/x-%_X{_10N?(O#e凰u
1ަpkXR ?@h)K3J5,|9rNpJtKI@:
2Z.{\	&[LK{o蟆C)8sN;{	PN4G>G1B<8 uzҐӺ ASJlF`3q+ǬJYLFij SagYuOXB*ˤ)ԭަ!AhŴEp9 Mi\V$[:DZEt
GXhS9pwN4/&i}YGMSqKt=Ga#7%QgW.upf
jզc]*ZME$ͧBm=$X8ju2d1d0ݓ~Aq?LQ"GɋY	t<nQG8GM@׼DQP6E]$xo	Cxy<QkYz@7عeKcШ'>Ѹk򔎁F{hЛsD2_u3wg!30kZOSpy;$6{ǧ~זޥ؆.hJU]09exB\ÝXDm
vز²aXK3:Uƌsnj<_vn.N5hs/0E4t2vo=!zˣctw5O;,LHC88&i|Y`-@	i$$x,=Luq?A*ݫ>]FʢGx3*>W#T7):fȔm"BI%s( u!@ЄvWFqټp{%=EזB#5#LCcyf{5c=1x8}ptE;db.ՔǝUԈfFwWW9@W%#=2PzDxfOH|C\T)X25Ihhij vS9q݉H<
Uu
 ?w_%>x)j^VY3HzL\BSü!@ {8Ƙk-v?plnu2|̾"q\Ȅם@Zi/.6i&1%y dBRI{LyQy#|g~͵'Ke'
|HRׂZnP|4*[mV\Wh~8ifR\k	p#Cx	\e{mg@9ևs4MѺJіӯoŰO0Z/<ʍfjźа['YǾ,=_:ɦ\2Ya0IWe<=1>5wJJۡ'/nqS0	1tF
[M ^&'+2X3l#֡pՙl9\Rvy{"?TrFv*EBb)ǒ8c=z%2P^<pd2_Ui5%J,Igڻ[A,JEv\rqOpov+2"0{*(&n}o"Sj
P5\{0`g-]+% VI*o YYQ%G'R_O_s(T^=݉K-9@-ܞnĈ+k	C͟{1~A%SFDDX,DR/)זp;=&!č5E{c}`'AwРЋ	hwoVJа6㡌1J^G7ZLzoQ#lܤN8:-﮼1IΫmx*-bʗJIwwk}vh1ࢇ$nl?Yt݀<Շvn@+rvv-간Ze$J5ꤹ
D8H
Ӽ ;]R8H
S-	BP5
ݤ1o[R`gO4,3MnXmd|

JasoqHLmʢrߘ7P}</mvgJ;Է:T*XŏAxRNE'oUCH#~\}mPR9P䝮I^gKJ#oyW'nq0˧˂Y6=S?;bQ5>`PͶVnRo:.Åzh!{ca=cB:릍7w%[b:.
]1$*4&>(hA`3{v
"x\˲	NeO'l6!۶1b&)g 4Q|BURu8΍474$"[WGT:'x\xR< nЁ?7Q)oz쀌j>DCͦЋ,YSwڏ%s2Ӓ],t}B\LBdc6Jt}?h^E+m3K`A:Q7vgxMA]F'	Y3|]R!ܘ$PXQ!5- l?eh/{ۼyjY#NjJ܇A@ekjAoF91(o8w%l: E$'e=Ѳ
nt6@MF*~mkׯS0>(O?MNhfChkXT՞&'8͌ڎ`[z 7+95PhAJO@M!MGk.(tAjH7ܕv9H)vNƒ吚N)&VHMLfd̼N,PpX-rm3OyI!:7fAP&6+\+X]3#[]̅Rg7ԔVkeC@`jJqL`aUv"*
 OalDp
TP):آXTnw^H^7x5UZN'Yk#f43gr	ǥR6榩Ư|b3&0\nDA
حL3/K~O
5zy-z,Ew5UnF*mW
 uŹ4'n6DRMbN6`5Tt\LD"X(gYZ(·s'Z)iMSoRsAxZD!f$e"\kRʲ?+iL`e]FlLВf+1i\ɖjMH#F}"Cx02f#L'3}S;U}i{_gɧ8*(Ewʻx44D|;JdlEi~8Q*_ʸz$p)Qp%Bnrpo#xfh}c?L&e[i}#91}[bzobRoS?R9siD-TڶPeT&7Р	'Oqil$if{NK):cZ}K?Z>Zf*O{B@?C~[M[P'Of"\1	JMˀq6XDh69뤨sxr|+m!|G95UwV
bIcd-e%ĉl+ٹq'F]Ľvj@4d;hUel”y`
]U^E'4o%T97zT{Z䒷Z6a*cKۨavFJ9v7R0(s,=-;Vøap'.auв㌜aP_8unJT@4qjȱN%_؅)VLgc)ot
(MyC'AN*8h~ƺΨN'X0z3v,@K1myhKQtk|"u#̫=KWRZg(@]}2mֱod$bA@Ymd	czַFڴcb1$9惭!XℲ,0f4H%x-.2n)@c6lt-8#0fv·pXM3LaJ:
 +U-I\[u1f.RyJڡu
9~o0n1P5'"ӇdW_15hu5% 	[K51 s#K&oAi_s$U\'X_pp{-Hė"V;Ry9Xj-@&rou-3}(p5u:)^v~Ļrt͞_oJ݁K_-%>9jCpz:ƬaH8bty}\_T*d]l\D^iX$,$iY×Y:n直0M:a!
h:z?8oߕQmk12"Uv$~l;n+5dfᒐ!eHDRt$n>%'̀~|vyPzyo(cX$uVsOsfz9n5<%8TB3QUtt!{N80f--6/Gs#뚌nm'_.4X}=)*7Cb?<:)TXTzZH1:$6H6:͜=Sk 
O_id®yp\l.vCY
+FՐ[zN3)a oN9 ٳTQ^*5anʵLpdA%̓+.O$im;!ߘ)zf:J}d+3Yv^mi"v
=AADǒ*6Hzl H%]ܾVǣpy\!9NsaIO.pk5:	N2YS7$ɹV@/(W$DZj$rMAh⹶bHʒȟ$ֳGULw.Ř"nM#.{@r?.͵n躆l	EDNPNG5,\9nD4&Are7q\Oxb/Ȟ槭ox2USk ;AzQCWdDKhz#Qbw7B)PCyD/
34&#Bfpj9rחZ9ϣk[7KE:~ꌋ5bo1>ّE
CnK)ztp[7R#KO
##7U+@ahx<2?MQM^]j$us D[7FHbsfu,Z㬿JÔ#@]Eն
̽+0Ft:RTf̠VÖ]݁N5>:_d!>GWH޳\.[)F]GpIMtv1]VW;AYlwm=z"a99|'K|WW,/*#B,:t'hiz'ڨ-e-_M=땹F%_tRjc>_#7,}"ޓu`O7\_Huם=X."m>\	wZs=|=3	mJM1^jۦp7>sO!;
69%D7@Tr5R}awh(e5j?a-#&ǯՈ>=Nt4:4 -F>qq4g&jYV(Р,L`VJ[)k8[fu^,$YNi^amx±'~(
wuCPu(6$׉ߩE#!do	A `zխIJ/WdjUgFiLWBqgǙ3{e$W]%pw49U=@J@$+e`ߍT@/1W;+RNPyz[:
yA$Y
a[@(l6i&n1C[Sw"Dź1\=SkI?m1.)D?vL&4U:s."_bגFs_T'梦~͑[@T9:h$B&7,n8_eNY*{1P;ԞVUPJo{hn仄oa).[2Pez_N%f-ݐ4XijX޺l)#=f󭂣Е
.$$u >A4=GsY1	HFZ*.>^.%e`06FORM$UDJVUINFO
XINCLmemo-tools0026.djbzSjbz NnvQYl(έ,v?%Zo9O_Dh%0G#zPmdv75\O%SZ=܎'͚A`!c'Q|ۅ5	FӗoVHy6J35M1c⍛]b^YEf#u〄7qSQ4H@K_W9̕ wcl"I.i8Kl8/`gcaM:H0dYKΐmoO%-leYקxfJ{נv!I[J.w>KO>P|)9:beb+w){ibvhNQk	F,g5SiݮVZʙu2B}#GѰ|$ѿgiᢣ 4c*H"q=
3@/h"-- P^ܒ%ɶXi@ܱG/wk֬W3<<{[TǫTDGH),JXNSN`|m$.sM#,NFªL2Kq`=#hvy*dc"c--:&=uR?[GdC*:q;6.:K1eu8[L
-54//
ѫwAd۵6N]b(zϑȰ wp	`Vk4ֶU48x@C!Ym[ct
~m#!=}V1<f;e˖<}x`qټ64](giU~%AoO7Pzu8'iv>
j7_FM<{Ex$?SXصt(a½) K1h2ĥt3e6jUn
KɷZbGX;41<2$B:Os/WҪmmpG}+9252n"F[O?ׂ[IkۓF<^6v
No0;~s$	O̦>2J}U8IսCRi!ZijϨt
2kexMۘ-1}Ƃ1yFىJWht$ㄯ_U^v=C$tX}DeApZ)X*s(@@O&m񛘹;=55BFcYͪlڣy>3飇c.o8hfoٞc`zu_J--ƅ&d#!(jw|Txz
^fNmf)s̞d^Lil
 ޅ7i
|T=R~b24@0Nސ79fhl]=J!YIy'kzTTEԳwv+''?K&jga>R\9	x?Ԏ?r7?Y?)Ѩ2jM4!J2 o_Իgk)	SLtqY8XN֎*k=1{<*esev
&t/D֕*?=9ǜvJJ=LJ: KFiaW0N 	6Dv0ۛg_)c@}wJV?{ћ3M9$1&4:"ԝ)hbZ|"brT
`a	̂j)x`
㟾p{AcQ{vL'Y΅xClb2G`"V1԰Et
bָY2S7\TJc%O(-.q	>x
&`s^m(kW%wz猘0gn!%юA_	ɮZlS1˘&zr81eѹoXIOm\1n^w(,
‚cZC3QLKwU^2<|ޫkc_<##`MS|&udd̬HqTvc~]ޕE:3INp/^OR6AeU5ɻ~Pv}G]fŽIEp^rToW2jl?qQAZ:EA!MՆ|ʞ@iP|2]=k5lDZtTG4y\ W"~fڎNhڭlv&9t_h1'dzihyng%g'мޠkQ"۵z!']L܅e|-c,n1CZT/crtb7p#SP3Z(y$vJ
~oAq,HkzFE45HUpq"Gܙ&#rGIme{:0)	"VB$d
=$nԴU~ގ9hR#bE:]45ӼThI@;2,.X#S(Z=,^M:81λ-m4n/j^X!WDZh
t΅V	9)e74Hsa£ԓȆ(%خ锻{`sxHjH͓:x|=qJ	'(`f"uj߆6$K&Ct}a5lHk#2ђy޲^eQ.@PmJb#hOUN)ԳT3$g9bE1~c3F0*R,I5\wU"W^w,9^mcr*g1HWz*@4*h/GV17]'.}C?Gmc6-Ш:B;Ky!o[O;jϣ,3
72sL>]6[#Aٽs 䗹QfG.Dx#s3u)"ULweV$ԭ>a`pUsu{94n%ynG3.}Hlmp=C!TEuys`4wmg)F߉P[;漟GpG[j,j\9bB`6+[x5D[8J<`1/[c!sDͬ廪C.
F٢Bc&ܕ t@
́HkA#?OnAi[,*9͑dTڶ1q2nn!}aOr
B:lHilB85OJB(KFzHc-G:lxo9NMzcHƞf-hȢyEfj.9%/rJO!oE	CӤ_)Rc
E0@$Pؒ07%:	Z]i
::SLhCKdtHb7-mvCs)!0Y5/#
zgp:LN-3
bb&:Z8 31kǝIT5>X_ED3舅Bx
Zf~)]3r
@\o,84,хj(!Ah"_i"twIs/]8ÑA!*Ǐ䲷@kʴyˀSӈr5D[XOy{AHX lU
%ڟ	u~j}SP6eV8w-CͳXfX\_ySòg~<*=!e. QyhþyHHORxAͷ%*̜HE%9["sӤ𳚣_ا7ۻwdF-yy*{r8v;Gӌ`ĝzbI|nAsxUXk(1[P)_hg-V62E;q׳mR7酙>%3:AĦڿB))$-FLp„hyu3hçy	;Q&$N~029w^
YAt,}'\!E7t-=@4p.Cm%Pk4+RjքpySrI1j!mG[/̀_[
+w*EULM]vs&½$@F.!s)DFI@Lnyzv?oGmT\)啞x1ӎЂay^ӨwMʨѓe/h?oD7A0vݴCr^D,ۿ|{%	*[Ng_(=/&E@±zN?q&r㾡QN5R޺p3|6&$/.dI,pi@$L]|_7rp0{(|iF/I/i
0*(jGM:BSd(z~"s
2?J1snąP{fptJeÂw1Cw^9q-g'7Hbcw/dzZBU׮־ϻxmTe[+PO(.@n'Ǥ?AfD=5]Ȍ`zbvO^ĺ!mUŜ-*kU*qH(EG2Ø}3FUfGu՜\>?qRjwjG$%OXh?8&{Gv6XA7-'Sx7 UOcvOB:F(UN\rf0;tTai/FPω#xt++T? Zn["e4꼕zEODRdINj&!MN -
ϪC6*eLae!۾(iFK,y\Jჾv6_UTS膂kA$&ӆ:e`MQ[6.&s,[-/|.1Ǧ_Ph$^o-W]Mm72c]T1~J#~rh Tnpd$
$Ϻ?D)ղ'H#	izT7g,Q/{~R53]#ԋ8į
sٕIQi,oR~AyH[G1IwQLw7=S}Զ+ߕ²
@f
X
_M)82C*O5
[p:̽cv͆W3kŦH>hoVF@l&d
@vnVcusojPlW|G1W9|0j>Dhpy
qH;;@6<7U}Wl~fOFY[C΢!tf9ر{R֩7CO|'}^VZnȡt+åWK4`3?p1\E8Jz6]eH&b
Ԧ]Yk.TCavSezSSMSI,{^mAL|1T'jVQ
E T9yoZ6ѼɂGvb-r}:ȍ֠G0X[F=b85]KhV5bgvkۤE1Wy3nG;ی ]HU)rh#UVhNg
9`\foV{N,yEjjw;>ie}SUpi{YTDi08;Q\s^AD
 ՔsW0x6as] :Y
M=YIG 
*S}lTXTzȇZH弗jH7VhuiX\-P|Q	z	G-@85B(!ĹS3V!L
|BhtM{>R:t=LdM2%	фCo8\:vZ7$gf
FPtEW5:X4ʭm|j۪*a=̐u"D^=C˭#Ya	v-ԪJik*DB3wZD<4ҵDJ(K#P>0!cpQUk>ذqY_ߊPBJ}(xvZJBO{}d98Fk5M4,[;L;~D\tJI(d~CeFՙbGДئN}ePVJbu^=/| gDO(hgl'hsD_ˍh[|k;PV}6ECzD&C9+Ra򮕎ˬF!^=7":N%Z:J\f3~hçe}'|t+<F&Hm
N}.8)w"Pֹf'Eͣr8#B+]TAHs6f6&3W(URcFORM.DJVUINFO
XINCLmemo-tools0026.djbzSjbz)nvQ9u08x uGn-C*lP1kGqa*P)Zߙq)]̮l!7$prC٨n`1'"D"}Fx2Sܸh.[@OeQ6)zuu8Cr
3>U!/3Sk\=}Cía%*$-N{|f%1]~d'>P=ECY4pLc|Fa܂[]Oh}Ң2$
(?Hpu8[g>vћ 	B`#ېCٝȪoDĜELo-G@g7O{h[U@!S,u&}US؆85[dZ`;F'߉mX7WЂ/ ^7	~f`zQ]
L1v@CCYX.P@3{q]ýdp`
^)=g[wP-+md~[hj?2j{L*-s6ƈ-Sp2H80OYKY(<_][Wm^AV`pN^U^i*:_yN_]fd>]4^z]->JM*kVt3nY*O8	P{|}.>_%H ?+AXu)^e"לRt
\L{`)qJulG
ƩIj~biW:,є
݁#ɰ4ZqGĥNַϕ@oA":#<.}׹*?yN5i2}BJHUD$Ubb^u$\bPaH
cUpO7BFEc-JwPt侀(bRU4SW\:yc^O-ghd$Ĉovr͞P(Y'HעRSn޼~	L1[ﰟwNՔ$rOO²q.DԴH됑"⊆Hjoh#YP7J|FIyx@]sniȲ`/3,t_.&G
x"gJmp6^q9`SX$Rq狇KJTR*dH
W;[,r{
]ݾbX|@;Q嫇KȑyƵDéc[աnޒɜƅkg4]>!ng闰p8hүɯneJ=~)Ā2aujqe1̙ Uv¥iE4{x*tcdRYm ;\zZD꺍%KKE+#`Wy$I%wmT3i0WBbMR:~PiLb*ԣFi`@]ឲI=«:[Z~rڑƮ(ƭ~'Z".W5qOþ^{2Y}ϕ$
	tYsytW;d>y{kбԓiijWBp6SkJ{yMgPmKծ01Qk7Z?PYp#,"Qsn=˕U0:Ȝ4̄WXn'~aߕQt'>\(Ft,ꐋ)f
j;Ka"81^nL8M
Cu%ZM%WF'1>U;K	Qv82bB ",eN'LJ㱫2,Y +N-9LaGyPx}PjnyWE3_K4S?/FJP=#
~Q%eoR/:U KoiѴ!p5V~
IӄPoȭVWL7I;%Y*KF'JQU)IG2`lxx|>Y+̑#1.y.$騫o913N4[mR#7y\Bvha_m;^7(x_]Oj3ݍbj&^|DځnOnfXӱgK>aC)NO>Vkd5I\ts|(㷄eAǧB4=l΃`iOOcoBԠ> #xKodce嘉O>5;Ŧ>ieeKYrXcQ?Lf}*%}?Y|	}gpUO+򁪥$OnHQnfp!0!s[:
Ȝ11oz܅#$.>Lh :R>)^TB%QϮw%#Qpi싙`\?Ԭ
PcѴסJ(YMY]`a;v+jG;˱6]iksKk`ѓ'%iNo(Hst@
'54Yq 3[Qa1
?Gq~+sEFȮvRdU_@ٙU ʬKLo2V^;o%=eѴ~^wR"+'vvX-(2GYzlҁ&w򏒪c.FFr_.:\LL
~CK'82@5$_(\-q|Ivei|8n|^IӑZM{7npVV@ɼ˹x`b
-	D`-$kd"DdEU@m<]q]6q(JkZ %HC&c!Ci|0ҪM+^UJNݦuւ"z>kZ	^.&c_ʻA4g[hCO%&J2:?ڵʿ{71FNʽ7DvIYBKGw%X8|QEijRDS?I9$}f6)"}%nJcxALx%!Y`hVT{j4pURE
en(е$5 ϩVkI]r<#4SkcDB#dYWPXu
^@';dN[+Ohf(T9{;nBJ$5fEY=)r嵽G$D\!'UxHL")ҝ}K_s^V!eAoLn&*J9/VF6R^;x̸*;vv[k6^'+k@FS
 N`KJq[s'Z9.fX@Jl[׸L~5;dX࿎T41g{4ś
Sw?T:`yc"+8~}6_N p'Ҝ2Qṱ_&i,؂
c2Nmqh.mOE wh-ڬȊ|mȲGOpIu>eORvP.` wRK$.2
zB@8J Ÿ
2o@B˿LwW
Ґ`Y:?G2"r4l&JyhNh_Ӏw|JUԻ=yU3r2_YGn0gKKA6,	*yIcGk6O8;v52g9PeK1M;<)p',TޅAjtE˲!Ps(΅>?xtOߦN\<WxrfjM=	yyV0%(`un!!^-ZQtZDPXz	ÿK9\KHa-@ظ0THiΦzFܮD!c#ۘJCT+Z
tǿvz@&?NZ{JJOaDoֳen:'UV*/RlC_5aqcf+C*M}\wCc31cgR1T
w"4G9<"I"1+ߍ*ioq[Kf|]8jXU
XJ~=9T#T\@iB.]/1w7Pwdhk)r4,Y?s#\jcP֐׍=j-l*B,;~.g<Y	0jE:mD
?۞8"Eb`x3|I2ãx(z'?6((NpדfԒ.	7'n
|t=MCa=I5="\e]Uc6^Vҩ*hq\9@O'7[haTPhlO +lVvyJBKͥagRʈRWQ'FC[iX[7<]uRpLat<6^?܋B*ꇝbZ񑅷9GR0٭ޥ7Bt]$l_GKg_Fл"ʱ/2x BJ{8/	/#FK,sHukD.AI;*&+$0c[>"B/igW}
a@"@akr	vܖOK5rԷ]8B=6I"9I|
l7rT]7Z ?*\*Q:OvT6D p+1
Kй$!l
!J\Kt2ȇWz$n/Qj7ky󰐷"PZRMc_`$f9I)Lpzax)0LԞ!
~pJ[E]@M>
v_%r3Ǚ?DOL$=L>!H׻m-OίEX/V@?,2ts|DMF]8ԞU14.q3kaYxoGvOyzq88"YoL溩sCە3ma.}kLpӹ~M<f%P3\l`R`cۜr8Π/cu(G[)u0Rߖ!ڤRfKuZX:fcDj`p8B2Gnh`eRJ`U_hT89ˢ_؋a71lit.JD"TuTtuZUZ>fڇ<#mv79ɲ+
%4B6'V!5ZmV)ΟѢ]'|=8WnȐ#Yn(,\sD}՟8z<	7Ƃ_B5w?ucs[^$qI9LXŎ:r=SVB2~R`azƖ\E1^#uhiGK/
r}Yrܲ/#CjT'+pb&%_nf/y(~浘:FBxXȘ.xkr*%ph9Ťpj+
Ox:2[tK] *2ILodmobq97WPMz{=9Gcz$/a,:;@
.%D:6c˻z$ Ri}y8‹ԾF2SZ_
"dbl:t125V/$!ܩxijc؞qb> { %JZhCg5\s5Z{,WХ! .]:\{ZmISC3A^ 7\$4FͣA3/iX80RDhиIZ=wY!`NYSB|߃Pn,R\-78c`'۟f<J0RI欫_A
u0,u: K"hcnĩ%Xa	q,LY2O4[Mt-_2S|i/;lWc>Ardqx䖟H*IVKdظHSUlu
NQ6^}
-Y6ZTj|D>0,s0Anqc[v"Vvk]#mU6D.  *Jv9,wԾ&oZ1x>@D-J\|d򣟰tvIpaB^:8U0+NpQSm,/֎=lSq(ƒ^n*x	Wx|&0ąl=$-SDs^
3r،R%k!|}]Ö[$%4sg1GS'JRYz7p%ݦQR0$	ܨe﮲hT$pt"Ij.jpim19!_uLPMmv`{╷	U$i>kq&YbX\-(1H6o4cw0ZFNcńs۠4eV4ގe0_\SL|r}ݷSaњfNT)G{A3N}Y6S$ZSY
B=%SN])6JE:Kf)`!XFIL^@G B=P#&bcVihH4Rᄞ7C~OY\ɾ>>w`$OoT6&Jd4J{ձԝ98V-„kňQ]@?iGӷ|kT,=GpKKrU-ӕ
<|Ƀg	{h(\zmVÔuWw0&?cNnfJxdAU;hzR#tT	^%^~'lW;V3G=Ö^3-pUqB}CDU-X3rɱ!:aK)a*M8"O-STgxA10 Nj2R"$_'$Ih+=Fo#[M] mtӜ>^pݤVQzic_hcwm>Mꨞ(.{:&b+Arnf`{=S(mƙAG" +OƋMV
d	{OxRܾXvK1zRV%RT	}F7s/*fƧ4L͚SUCX*=gAuY̮;DT7K}kdY;9xV1t(O>
M8zO	0~1ڢ2~9 xwVKE;
GR]E')`xG-m_u\?eHwSBc΂תhNc6{,NI`6
jKߺS_00&22f:Bqe+lmtkauZs]~QHQ3SI"d..q#ǵd0t8uZ00br;:>8u^J/X̀NQd 1dA=φEoiKqy|DRC}dF9͏jo/̭;'{3#iN^+,-	os|JQWWd-^] -Bz`Eq'$'XԬL)+x@d@饠k]q'qvH0ܽt~@A㾯ICRgdNoI$bSs$Bi$+A9PGˍx|}JfHђL	^x~X!B6"lv`iAWb2}!@/ZOɷ&,+y:aoDAR+2D sRJQyTY`&%,6?ՠcs"d]0|4}
"j=҉^
3BƔ)NQjZ7T:Zp*<ň@89O!#lݶDe!oedqimZ.tM
I^h+ē%ac%@"-*@IϤ2[>^
Vӫ=0mR
h~v+
س߄{@CW?"9W; '@K ,=o,gdgƓ4AYF`c4#DfnOگZz걩wM~O]0I䇦b=RVsƩ뻖*$vs_A 1ǦV
,mpR>~Ҽ@{Qd=Ἷ^Vl~9$nou_z2*{Bd4r	V/W3l"mBsT
@h]=SХ_fu[G~2\!!\M-,j$)]!}B~(JÕ}-ke^=Zßt_*$7u8ƽLkL@!Y/h%zI/`y/29^-7#ݢX(ӥى<dCLle$Rr{?)
w_MjwiQµTR}f71!-û~'h=`T@XO,1P C*e>8c'WGq/Xj$鄟n@2?S\$K=󨌆V	C=R:Wmo_C|G4~rdko76+-ݛss4:FT

wjp:,$#Z Ø`XX9g	,"Ti*}Ϥ"JRk*GvQr2O X7XHCBc?#E63HiF6<}\fֺg
snnOkKY6UDe	&7(Y(̫cԅ=9ʜr	OLrُY뻼9S7nKi[]
/q}2:TJ}E"Ja2BaZyq{eA_雗iztm=_x7p}2DӖ"hFJZ4MIvw
7%|ӟ"~D$k81X\*~w
SxaE|_S7Q5	?Kt|1*/;cN9tffofMQ

XiqU~q/̓|7^2pBdb򆋖Z6Vޫ1ۊ@Ș>9Ů8Zy{RwʃxųH&3bO/9bgtEvuxwY7`qt#CdL%&43qȥھԓgP)[Y.O6ƀ'{".fh壈Uy}ZylFQ8,஻Wf|'QN@I_O-9a>&cWd7ISo\%*5m'Co\9vѵWk@NU[@TЗ@^GTu,j*^`ҔWXVZV&:/g#memH袠QxT+5u:f-f~Bhϭ2*+<|((֊AeݡP?ީ]O);,{9GՇ[GcaT:w#
K>[GpbO.hrb"i	|EC#6BA^F\m. 4S0EIO3%]3u@nIw!>C^0逦w]>q9~"iJLϩyM.+gZOu
~"o!8u$nTTLwx.\n]>#TCm˻1NxU5d@H4X.
)㻽bar%XV:prUpt0yzձlz:Q!fFp&g/	&?Q"unWbOGáI]ո}hCQ;ǒƘb
Y\cOb+Idx']Ρ^81D0H
@Z´öiUIPM:[cHW-4~$:ލB[O,	ѣΙ_#MzPgɬ&iNA^NHrhƋC24u_(>I
.x}OMpx'l=k.dӡVa
i%߅"Y
A3gl	ŊpTOJ`S&8S<6iЩE?|
^$_"Ѧ)A1.ኩrޚva1%~Y
Õ44YBeT[47AOrg{LOGrɸ4|w-*iP)%Gp8R{B$7mZnJJۥ_2T7=M#^PiVmO3fTEV*(iLe^Ld\hS4;Vؓn:<5R[ۥs%AcE?>T`X\YڬW0]|G؇[IăL9uaij]"
8&3
H5Q~&^\5\\A3A?EQ_8̷-{_aN;s@xw;?ЌH3r}~<1(/
q|GԘ`UdO.=K8.r2S^72n#q̹!nJRM3EV	ay*mxv@U{J˰C`3@YgeSdj2~ǻ70JaHY;
W1R'9㧿f#X+щ&HePm$	=eὴy!P$Es^Mҳ먴}`.ҦeE{:A=0l|s{Hbc(WnȄ,O ENɩ/$xmrbM:s`C4FvO$i!M6MWP^1|	!Qbc`?GfkAԕ(|(%nZ~sNB.,yc>kReӐWT-
uX9آyY
܎Ɂ2mqp 
/d\GxH	:
jT嫷R5ߍ ECh#"y'i?u5;weRdg2{>Cls0e{X{ad#{aYKJ7Y1e;@ǴR|PR1>Mp:nWGj\FRQ~'lB"izdik@6hnA=qxNɱGt6jqHi*|I0Kv?Ef<RI"'OAadgbtiai\6ZUJ`{E+TJ"R"H.E?D~*,(t`Ѹئѽб_v}Ie1Q:Ref1]s`vtHe5/7v{ZƇ'~L`B5ۘ
ˍV./K=+kw74ѫߌ2tޞݭj1+QtC$ւT|M &6in\om IO=w:ޞ[CX<M[
y=:OJUf2j]a`;:tZm1]}պeJbUrzZVpK?ZiN}R%+zKpؕ%>b$+Si&:'׬qj׎vo^ r);/Սv9dDj%vIk/
ԉrܻ)57G;k$X1>A}nA!vL)S=SW(о#&Ol QÁlI
y4ˢJso6:	xn=k1pK5HX5{lagvE[ˊ //m]|NyEv<Ķ~b4: Jjx }Tk[|CK}~-)J19nή0Z|\&}EUޣU|
/@R>WEѴ&ģۓ3Uf=NTS|0QŴKK%ڀ1Š@#̹@\=?Ci%KL9RK^^{ѵڈfyBubE
Eoe{fYm҇ݒQHgBᑼI}O57%P1~PTwc߁en~}}\sE|ld=frhZmۍh_-58o~hfs%YRDqNRZiE70;iw/A,fnArh~1
i}RytMynB|>ɥK@
3TVސV̆=к_Wر._:3{$A޴1͝WGQ]^nN3|ȹѬs]cO4Pw53j-j+ݢċ
 	]ܷs gO@3!!Nğˋ4NRV>֏XgIGn7h+nk*1D~up=ViXhh+bhTYd,*@;{	o$חh=W9InW4cf=
_7ikA/FX{0v=
p
}TwRalt>"RT<$_6gzJ*sm8B@[/
|7#Qo6G}G_SITuY)AоAn,,Ŭ@17d5 bnvᡯ=^ⴻwi08%)ӾS+>'м]ٱǿN!S2!U2.<[Pޢmz!(pͷ;d-
Fc	|Zy3Bi]jl4X`I$,[θZÅ!i\r%ΰeDy!"@r8nd9
z6ì̬<$M
|
sD4v&Z<]&hi&[pWbV8Qtm4v_TfkbZ_7`unZx7&u^$Ub8g}ң^Rh8ځҜqŒrܫZVLŸ3p5.w3XQ(pN\FȲN%+7}U=/P~N{>Hr"#
ر-`6-Ô|c[fꄼ#!8nH"N3ꘒoUw9n|7؝]N<(4$G2PlHÃJh	ڂ.;$8Rwj[3Ml$ٍRXz[PM/L9S{ClCcƯo{-T>U &(s)%$[Fٵ-1AO/EyeFϕam]gʬٳ'0Bhԝ?m2Nd 7sXO{?aW~ο$G
a!pz:jsyA[@<="Wf2ʺw'B1$ҞϞPɺdǓ+n!0mNmX$hKHwP<8uwuB["nQMF4d6ߥli?j	*a` m\4s‚Y2H:V[$ q޷5-l]aoA\X2"
7׷
GFzpR/xs{h'6&.@.TOQ6 ?lh	7톃P^]S̢Hx1p<

}TַC Lg.jR4DJ["y:I7Vh^*;[}l@_G!3J`oVS%tS2V#zfgD/
~:${78K9{vW.`mZy+EԄ3.0%sj}-6vze+&'чMx_!d;i?{!i@5F5+ժ&&1NoBՔy	P\؎^ڶow׵-j8RRke%V`ǧL>yeOzcrvh. -%uN&BncPnjAD~SJ-ӅvNJiԫYU޸dU:HX<OaJk@<B;;duez5p]k%z
YD0HXy|)i@7&S238B{ӊ/NԸ[r+ 4sbW&a
$$JiWz)b2)Mn6돕YLeHh9AytW%S_	;(o#xJYUn@
'g{Bxd7Gye6bЯ-[n"顽CnmvB5Zh1$G:75N
~i1-@pQMjjgN<]׊˰4dUwy^L~!vk:jɞU#6hB]m+啟	Bc
|nPpCIĖBO!6&˨EyQ u~]貇0mϒ	zsC01ytK7J٭݄Go7:`]\͟lиny/¬/+Z_(5۷=;[5^\&%ށx5߭1eu.*\+ ڢ+)
ƮQFFvxIY#`D
櫑i]aRNXPA	y(/r7TXTzaZH=B#]ɮ5:$ت*}%XwֿT<>酀eg뫇^@~&og;r&u6eTEJKmR/䧖
5r>1)W>xv[i%7bK}0xܔo)ؔeμMi	,YM|+a?>ğ4um7k<ԘO {{Du4mAVxl
)W>zm䏟uxC<^ "YU 0[K5q:7@SլZQHA,}R'x°AB\zr|r}
omrDɔJaQX^{^?+n/
v59>2Ϣf#wvG* |iRX=ts+x.DN6%:;5ͽY2s)SI>yDHI>rewxmTxqjWDqYT)f[SE)V:x{,UD@ߎ=`f6l{VYfc&T7(%Bzs	`P],	qegk8HO:}ovB%L##}$|nȔI@h鞦7g2'!Z`l8(gl+_Em*	Zȍ'-I"- ^@mfSv.XգSΑiJ.P&QæI	j>B>ͮLsgu'Y@?~lVe
kP^fG,+4e!"W&$w0ILvܙ?X7
OW@U'VTq
.,rRM?i_e #dܐ$0zoL.hLLOf4^3={s/I5GDW
بy[
*HD+V
B4	=T*-$]JeRNqլə3Tegu
GgQ̢2nbdC5<$yU%!ecB&lxnSȮ
Q#߻94BĞD+>2]])İePǩƀz-FMn
)*v1n!ǜ0Y(8,iPV%
I0UCgȠpvb^++>X^
:aVE4s>oiA|٭փfViYb65UhO'"oa귛EI*l!d#"ŕ}c?Wk`A´yZdRB8/$%=;8҅,Ko|@޽峬ݷ7hҐKvlciИ!^SڄrRQ-G
S,s}=ё|awj|ZDhBD^U	x/t`*eGTP#%Bՠt<5Y:--x)u/mtGsZXͣE06&FuG;TOkG֚̕BT/=3OC%)=L\ĮC~&㩲eN/acTPiri1ku#s:X҇obб(/l:qqWU[u9Vc]i)~
sx;Ù~chBbPFՒT-צhY(1;H٢5(;OB&9@>]RqQ"G38`'+YF4Ͻk\7t
_nl)[>-çͣFhvy>90p㩗H(gD4[*}J fJURa4fm@so쨅Z4[PK5[\X_5Rv!sygMJ)%FQ%^I$=n~u*&i
1aG$6~ܻLL8~Gu}@fjۘ}[)Qg9EpC[U>S)Qebc-IN$M9Dip.؉砪S૿@[<8mpxVz-rє
AN`HKzIcV@N>;!Veu[dNߊO
m?lgC|`AuGilrlEE0/GV]`-7>`\/Rlb2@%k,'2>p6jc,Q<[}0XJW"c+
mj	6bş6QFl>tC륝SxĐ Zk`f닓8e1o٬:V_PZ{$C_gAևYg"8͚]b6]M$6\;I'I)Peؿ1JmM;/i?ߟ1jdP%ǫKb҆`ruA"}av$цlOFN`m=53eG"}/*jcx)`PƱwS9\i;ZwI
2;^t)1+
CqkwXvE+DrtkCZj	[3z@:5q}1mvitNH&Pڧ0WU[,۳VThBٟfX,B7ik7!j@ဓI\̖i88ts4L!xHISH40"Ey$/H
#/76t|m)$19?T1a̒>Ӽ(Ε^Ajv.#P`,E^#v7ڜhlirnYbGIPHj8Ah`j>ZBWb;Opuy:]*jl,TvN>Y}HUSJ#=;MG1|xf
S|=^MUAf
mIc/vLs]9?D	1Lj)y9͗65c %w?>}dH?ɋ?G>`r~@n0R2̢M91Jr$AUm!o}&@&z6`)Y}z
>OBϣmjP+"Dw1pUvCVlP8Dzv
޻;o3I?B=ZЉ#AF'۝Z^ڃ%!KafhgOܹf(srlj YX-ܡHp6Uc_<*=(c3:|V,1_A4baum?ўm\2#K/k9+u
ڒ,HrQu32tudC*kYe_ M͖2B@<ةS-?@6-}]S
?o;{
=Ӝ2#/s^~ vvPP/Z+/?Fg0WH%Νāac>i.JVir; [8:qZ=F5H	T(#ӭsǯfު*`;j=I㲀g!8-Q
3!muK$%ưtR
̷=rHCg1`bu_\yZHb<{.;g;L8	-(P'?l߷F㬇%tc/AHS|$V3L#9S
/KR_yyFε¡^T|y^?<6
ִݑm:,>1ZMV(584jr2g 0S;3;DyQ!%(owWp/_z/^x4{m޶¿aTI/b0]1^[$&ϸm@C91ɩUvkFΪl;GEBm]0\WÕ6dڲI->EWY"3B[o%h7!aoEܾUL*
a"LIb>Q4)8K+2؞P>$uI&C],MUF~oC-ǹ!}#^Kߥ{hk1VF%|unr:hԃuʲbd[6CGR^,`	p-P\V
rW,@ch_ K`/%^|kF7q\а;-ndA!z㥵TG]򶮄$ ~bҲUװ(/5]HCo[	\^=8B;K=@W2jӃAo54b!xYr;/̃tXK\E@.٩߈Hiݹ?8_+1νսy;A֪+iPCEd)?oB:KT;-U"7H^H^I4\/v&~
L;]3c>^|^M`\X꬚LV(ʺDԱ1hjΛtk͙νtE} ZL1gW.NVʵ^:&YJQy+g(ep?ƮS~;p.618wpU[9'R*RCr#T?ИV/_]cPԽύI_iȌ?9nNU
=	_)$Q8{D\_t:;j0	1|4mR^^G^,É\{JL/;+OxZXuF?S1Xo1LvKb"	9H#za:Qj
g?Ğ"M:MK7U,@\w{TcvëӾF}9B`ӧbr-~oW]!C&z,7?&S6]&`nZ)h<9b\6>gI$U▘k:{fsefQ37i錨VY:ͅk	"V٥ܐT.	ZQ'LǾPVp^|WقK;J[yX(3Rx?5Gm|DvL^SH)0)bhE5'KLaA`obYzfDDa?|t'Al0rEYYFZpHˉ,H,Fkf<{介Z|ݵ9k<5F.--c>ss6xA3ik*v4qXcC2W`y޽>xX[:s_%Yf
\mNf/41~"ЄU7JKg[\1֖7
l>pQ޻w\wP5z,16S=Y^mߌlŮxUP6\!3_J~H+5B8)Qc/{bMu[s0r(ꆡrE{
Mf1iur/k)b2D_ŧ2GXQ(aNRD,"OS~=}5ڵI~ߝ0܅ӏgg`axTY'_^5V{@.Ik\dh׈ƝQ2,~)G{MҪרgQPޫhW'P|Io)v[:"2L^&~׵5!	Uh<_݃bi
ē^tZ{s15jb$a7j}S$Y^Ao~dxzGF6?	{hnװc&e5 ~	?.fx,UTDt~vq/(y$rF24
'PH	Jf2Y	w{Ʃ0`)x~]yQ;Yh˸YFM>ix:d
6 ʎ6).<PFq9
Hqq;B-=uZ~ڐ	7INJS(Kl`NͶɋ:4$*ai2u;iIZ|$RlZzYs0{}},^,3H%t5vOv-vx{	МԫU`Ԟa>KK8!EWYU
VvRA鏸fpD:
f.9|rP/|3x8C޳^K;3[w=}cK){I>,Qgzkk$π1&(L*D(TV.Uo).]
ƿfvIt9T
d^#(,z[̇11\	DEbZ!5D1UwmE7JD׬|o鋵Aܘ~iݣ,
WLO4cU)@ca}&>KW*Ą{e3Hnny,Ugf*TC(#Ebj##=!Gأ
Ri'|QQs=Qtv	
Kߙq9&*qv!'"Zb9~V9.ܐ3TXTz7ZH/UBLgIaK]NrlD4)$mr;$8XKf/<|dCs%{-@>Ǚ臖rI.	a&IАvxWA<%(T(&5Vu:QRI[WF/N^=	㾴u$9g}u⻣=
A,Z{.C1NG2)5bð@gk7^qt` ߷ރ s+2ŧ'kNGG&3]}CA(X<vb9%!5JWB_GJW;[٢0U>ÈJTXʥeJ;tTGcRj|T}n"PVje}zuEΤh6&E 1)_
@L
VHeEceˉ`SRxe'6ԅ	ۨT=pvMFm	!+L!׭(/~ht)zgSDTSQ q=sa--`C
+
|hIj jyjg&c:'Mu0]h`,"rH*7gs9ӇyK[Yzej&_p\+`8fcM66]L~#hJ 1:4Pb%I'?CXkZ}
q>_,k	B4qTY}/LƳ9;U^+nܝQ4̰TG0Kg(>hęҢn

В#k1w=5֔2eX [BR}=4'`7VւL@E@"݀+Fpgg&x2B4hoy遴4`Fu%V1鶾0|{8:#FORMNhDJVUINFO
XINCLmemo-tools0026.djbzSjbzFAnvQ9&cR*OddHA^L:K:S=8yKh연*LJG#NB4h_ẇAhwN-'f@@`^IV,pRa&	`bduaJûVEWc5p6nFU"8Sӟ	e3LZevÿ	/!#01{u'yq|8#z"#X04PMpQJl*&!ϜCBj
ňx{[):l&Fo*+3"+AKhxā+
^"sY~1r	LhQy|™-TJ?[%
xVHQOWcPRE(VrcA:L2 ZD5ݯ`&{dz"X($5kEo/~uW PW4ZfY.'
_9jI#nV26ǬM\E~@ư EGЙ°Z~Z,GD`ڪZm}nt/gLU*_!Y
a
jƌY>M#jZTRPlS>P7:ێ}XnR}Ȟ.Td
{BwVI2J)Dx#+W;@2n4n@2U1#Rqe2
LAպdSoYA2nkhG)q$%jpeO+`w"bR+w`uBڨ<2ƲRFVP;N̿MĦ{.g6@i"L;S(|?rʹO8	(_)>\ؘw9Sm-swGI/rmC*?qurz~rCݒg3AED7k'4u}֯8e\̅tQqsT<;u!?N\dr\AqNğ;G2xpBОnè"\4ȵi-FH1I%T7EsriVLprQx"GbШù[G^Zs|SmAXh]mrbصqy׈3:sPD&y5\N0;883'/Y' Vv!0k/{a}i_ =Rs;b"mS\ݸ+7n, G,KaZ阬:ik/.V#Ͼ0³L8bv.C7@D2i8]6PWeP:GŠ\Ȉ:.f]UR9#	=x-*ՑfQ1Y{3x&ůK?[I)Ti_}AښqVJߴhW.~3A2CXS{1@%!&o"M}3y[AefLAV~h5p/C$=/F:A4nkSb۔̩[xOh5׋Xr1dOle5Or J~#y̆T.M,pÃccz-X,86Q#YωTcjéZ}r)o7m.ThaZ2Ma`˼7,2EE܉Qb ަi="q?m`٪fѵhv$|wh*C*<[g_Lng$9Gba؈mzn
L!=-{a) Т\:41Z'	yI{pBKEiSKͭtnO띊k*aTi8cyl0OH	UDil| !D`H2F7y3R:
pߢsیз.>̓61z	=+^y- ,%F)9>pp,yG!E]VucxQY
aѲ%V}<͘*6'h#yB-r7~!ed89M:OhRf`Aq|?^)QVXjXF CWz{8bX+c'm |eCM9ЦxrZFkY#d/'e<|v[Xwru+ݓYNR@;
c7@TfS,>-&΁8x(U1aDQE)Ήnck
Hl`/iPpɌK%U}kB+,0i)Τ;#ْ"`RU4
ގmcaB	kp"ܒ)J/tI-qBաo`iq?rwV_m=9G5Z$`^_V^¤rmYf3Js+Kѳ(wpxn
j-8(*Jg.1Q%9lfyF.,>-o*ݎ}xzli(!zA3mQkû˄"%v[&Z!X/zpk&zJ"^QY
ݔȓzxE"0_5CHLP/YN'1T@_PaU96մ=Gc|p2KhݶK0|]6En)b$x_S,l8v^Nk07#9?9΄s.7OІkx¯v6宗N~_#;'xS
{w'ڛ?I*';oR%̎9?:]*^cbZ57#`ٯ*jP+ńf [gRJ̿,y*ݏA41&p.{6Heu
6ejn_8/"p'ꢄ*QXر3zMDXNm{OId5'#4unm-'ʡNY@Xc='䢰9'͈KA>]X~:iE^,qx0>JfQJoo)n# 3Շ1ԉB(^;a<%e+ (|tbFc*SYexNCe#X*ݳpYɎ>1_[
=m!o8m+ӁBMH z~;q˅AcDz4uFŃ$cf-H;NZ:PCͯ<\klyb_NSq~F[1oSd+T%؇L!S|"򰮼KGtN/[ܶGjMP>--OnЪ"01~x.ALtbț 옶؟KO󛌠D\M*:WpOmw>kJT[*x
?C\0S/qxfx"@O=Q71%.h)keF%$xqmP?Ti3tc"5O.aX/GQC)yIruקr="	@4?-N|X	/Kodt-ԊG8{izirN}M,垜7z8fU;1+㌔œ'_oҘZ]맠yƺ蟳|.#(by?YKC8O3#$P_\ieFKaU0P>[ٴ+Ў"$jN>;s)`-o$F	0I]yLJ)-MA]95K} ƬK9N*MT3ԗc~RZG4xr=F,tovwI蒹QIiw%~Z?/y%hfǔDO^!;~ybH|T+eƳԗOWV[&	AmƟOヂQ?\N5b9I`2&G!g n:
I=!*LM{/bE%"zz#~k KJilȏ\͠+GAy_.W@7{mbZ@<#C:<y">Ҍy
!TIk9OH>xN0k/[.qkW09L]^p&p~RxJmܶF[pg^ߙicM^Q;H>q*N py74-x3f
=NJXftvag;p!*R[eVZlr0pr/k*Xz:0"U)V2R.hL@35v:-H;.eZįiwjhos:ncg oBc/Y?s|Ɋ3GHLeopoHjj:	9A:i_	dIiM:;/jCMpsC="Evr~'1rqap;O.g;_SA'(UKxŎTUmLo9K !,
ʖ	@rzr	TJg 1у<)KOB啊
l~
Ԓ%ţ+A=L?%.Vu% 
Zp
Q@y1e	jXWFYTB#AWa{X r"H`b"~k?YF`cL2#T*A{	#Lܕxh_GJ}$^N,e^X'/~^~{%
U	C`W7򎆕2eEL͟x'Hۃa:+2^?qM6D~etC'ʽ:wdT4|AٰV㸫ФcI]%"NߠA
e$VP1dZ.._#dҫ-^B'?:%ۙ/~E{-28߄.mt?wi|Pܫᨼmpid@/p{3Xޔlnqҷ:v4SQd28dC;,E	=p|C:Z~עvkgCr:ԍK?RVKB:L}[
g޸4|uH.V:HV7&
t:o3ի)J:e;vO,b_f?rtfqҙeHJ	HR?gIq |X'jp=W`GZUEUp7B"'\1`'2Y[nӮ:tdUћ+1ˤdۯæBmYYl|p<^)Oix&B
L,@A纡=#SxS[Dri/gSӖMޘm㣮~g8׀ ЎȺ~|.Mp{PVXz	a,Ĕ&
[~'Kug1TXmY^y)y;KR
fѺ5Pl22C
^ýynTDG)*#MXT
UKw(=qP-
*,G2a^d-Щic}9j8$xdz,hq|ػYw*~,HZCfFK	Yjaќ-(cԢBNLUf3̫.2rTBcRoSsђ,[9࿶ېKmc䏿
Fx'Ӽ(lȻ޼cE63mNgRkXL(0Y(7*L[>@qK_&˖~s#QrVuUɛ/$$Ɖ-/-WsjdU;.y^p0$ #*VԹR?W

t/oF<#3en9Sa
/:l|WN7OTXr`,;!V>ƍ>\ \bLkEI9ϛ.)p3ɸydT0pR!GBsw{6-I{7m/4fl:j}TbbEDo@`$)jĥ}BȄD-ǫxy7%x",OQ7^Lc͐yB]מ~bcD(=
evi<)]r<OmV0R~̍!U=pm8xmCcبQH!W̎$FM5OeUQ呛hKKC󢮞mcyގ1#ȄWҷR!Ȭ]}.$;Q'`xUas51\%V&d2(tI|n-T2!h|\6E/e:UG'Ā,,Z

Xy~Y4	"z]\T*X!2{M}u`-ȋQh]
I5cMǞSְ3|3{?:׈Dn%_ëhX?m)ޜQ	 ~ե{5&Y}xVCfAUCxʿc!lknj6@%2m4ΗQ-|w"xc6AN)^ªNH@GcV.(06kң%kCE6b1<	CuwKe}%gBn}qVNɗ#QyV@89|LuHz_?~%;b=%A%>5ۉ=zkNX
>g@)[2 b%W*jF@ܜ KP~wX/~#>XDETNm۔mv]Tgr,aal|.cj"ejT@W#iJ3A2,THQ|E/	k6KpJUdlj皫̈YE{
[ֶ2s4}^˼8}\8,
sL3_mfBjOZ.|]i6~P=̺^yn9=#xn)}ET$/t!{6-{멛*u|w/Pt{0>K88s
*:Qyy/*k6ZM|	E831p]YJR&aeF-TڏOK~WlM8xL8nlIs	2J
]7=/OOf*vv3"l	]V9ʮhPݶ8'9jw6nxS3ʔ6~)mى[hO(
 |KS)&yB~Z,Hв(
RUcC0~F1T.3tʚDfĜP%4Hbs^t-%_buC!e=J4QQst›I-ZGe7oԕ d#۾%Е%4TQS%)Sgs5 LS,)/&+9#r>ݻ@Fvge@@VW'Zɻъ6AI`;Bbk%R5J+()Qв`D:lz6~nߗW5'-횰X`0{"_fdT
ppITHgL>Nqmz7mCXcFWo[;p=b+wJ	1as ǓjC]vHZVL{l%X\O%֣&dn
"V =>m aFH_e~NA7v>A(ͬ>ܢb;z_؈JjBAgL9@愺Mw$ie(Eۡ-d&Ȇ~* e[17V~s}u?+-%-XE(jO1G
1
_&BG`ζxudRs5Bl5?BKH~}%kj#M6[@XzEMA5/ʮC,~ehHdGUxrt{M$,SZeL̦nM3(w(1bҲ_䗵PbXt6gvd"7J7/@SM:[˨3*y
nQ?}Zޅ
6~)ѴH}A!HÐR{=K2;zYB;h*JuGhk^9N+6uM
C
Ɇ͑G_}Ix0V0[;-0}X89n
qJ[	z԰)6u⋞)ʟ22IBXx7&Lц	ݨցm+qJ906CWhfAzŸ0mEp1GWrSU?-׹?In(r{\luSNq X5ے
0|jAVl_q\2[A
XNSrXI!h*vNt
!ZnO%,MWDi4´CMȣ樍M?d,
X#zK\,`|A?⿤o3	䉚֔vڬORi=C[R_LQfݣZf*he=x0PxR	0C)i]E/|0Nƴ.=EP	_(@/jg}U\!s=ZI{F-`4agT*ec忚_c6k".gyR"!J}ABw
o<<
ˤj]s?IF2)y{_[Kqr2ޟK9JLBǩV}# <4m!	P1'賑BE%Zdx1uѭ1CM	RP (2?ε}Drg	ǁ
V@dF-䳊*KΜG#DN>pwF6:	N?sn*i5[F09(W@_ܡ[-o<\	2[msI^Ki8UzY!X4i8s-_3w[d@S\kc)kr#cW_.6PKsvdtR
ww-{V[f٬Ħ9n'-wdq,JM= h&.SjLKP 5搎n9[V%j.
	V7z!V`tݸF[AN[ʓ80F]bp-5Ϩ~>w3#ȏ#pP/ރZy᫚k#xt?qMߘg3A3f-VcꚌm4Y5I5Bk	OO4{j6щ(
W|\;v9tO|}5XP3g
*0 z׹_bVrx
B\vܚ݆0ߵҡjW#/g0=iV:C2oL@UmjsV5\5X)ퟜJ֦s{YA˅3}?c;d&?Nw?2	sl
pmGmm}'_=M "\89%{e^}p1eq;q)TxʺϳBRz7޷G +@	iUjzri=aKp:UY4LH$,js8d::+N][Ik^G]DAU|sgJSnƊErhw)
é`MkA=9'2:qodD$KfD3*\4݅eԊkYf'rk
:@m?.}0$`o!TiTݝ}fn6v.[(yF2Z\{O_jT2Jܟ2y"g	S%Ҽa`ꁈsAjm:!ێ'AbRxf^zߌ8GV5&s-IQ<eE1{EjpnL(gT!鱦"mwǛ\J
uf'ښR'{#٥Xm&q&$fbK.]铚Gx*[##G$
'>ܷR畍ECGpQ>qBHV85O)`3TvC5ڗ2Knw!+2KuoK-# BE7NXtjf*fa	{%2tѰho<SV3VG[EUؚAd*>M$\ZK,Mc{{;驅iTIXHip@bj]|G'̣}=2QZ" /hM7Eïn%9\Oẘ5[1K'y9/*
fcP%0Me_@%WS[QUZyTpqgyKy%'e^0Cݫ
,cJ8S8X!C}Hǝd'Oxbs1ZEpǢ:{xW}Bp(1 H?	 ;J;.݁]JurSmc]JCi'|Lz)[g+Ilb/&Z5oJ-NMxx(7PefHX>UڝrHΌ2/!Ū
ٟȨ#;> LmrF17T~Um#pMZ5Y\iƮ3l/+eXD#X28)zbnTWEɻbrP[f/p2hlq698|Q@WL,wQƊ|.bDP'(~]
< Dv#Yve-<8ư}}*ԭR;@
ThcbN"Qti`Lhs~ztyfF`H\wJ:\扱ՆDĘQ$1S)`V*2c`ֈg"~x=AHRdc]Y@e#^aLjit5!aQnǵ@	$O_\x
,EXN[1aMU?]k	-˜?^+uNiޑhϥ&+cڥN(;
:D@bjI)˛A8?%%db?yȡjS#%EV7閴G/±aBu<%^|qs9qթwwo5|H:
ɻ!^;ްeUi:k818v󆀜dOݚOLj8WCAQ8EJCޟ͛RJ"ȾL	5P|*pDb)?{@r"QO[X{&Wdt9yyzwhS7f5MMBE֏WOQ}5B@SppGPg@B~Zbw.o::'G:QguwZ+̫C${5n6KK5?Y}-AaTu*Z*R=e(E!
&Kw.zi(PP3O%]wð(PkaGJbп¥R0S"O'h"Rd7}~m!rE6C2p$Pt٣5՚ۚMpvG&iaC,Ƭw"씙ڏ\? cɽ
P^5"E9Wzc.WLIa5 #J\9^Mޛ7tREev^[)np:wHs	W`p88"6Ê2cPNܮѹ6w2(F0XYFI"@-,<ꜱj75@ƍB(3(-Q{\e&whs/2~lbMsV({h<\|V̑Q4¸η*wt݂g͊fW9vqCro=o/UroxElPtKʬ@?JsGH6OUH'
ZlFx9
\V_B/8ԿQ,+(뜡dtUܳrC'y+.go?〽!<zzP
TXTzH€\d7uPN+sy ZFNҘF#ki`mo?(}?jV)e]6#lYo@g?% u

Ý^-/G[.! `ƔlT1͊ZTvd1*oF[A;;HT|dTDL Uip΀ݺx2/JŭTW
X
7ooN*
}ES`DX.v:4zuqr!%}Nn3	"2&6"u!>![ϻH)[
 1%_%S$Tڃ/F>Sز"ZY59C
EtܫF(\	WkrARjާKH?@wEhj
+=Um:x.DA[rɨxSBL
}02`En ]fK},E_2E׈R$N'tiG>Q{JbR99Y?>HkW`ӻ@b+WLy+[WFNG!`IsiyIdilk92JrLvw:xZD9QX7FORM46DJVUINFO
XINCLmemo-tools0026.djbzSjbz-nvQ9yUab9h<*ac
䗊M{R}d	j[cY׼c
!wc,XDRUl#+/UUv=n
qpB7!hsH	}pNEc'8]
<+F6ET$QOrzÜ1f(lafט%ȩZ<>Bkv6}q0)$KY>I hޥ)2Zfē:m[AR{ۼ6|g>]
d>EPlc5+$1w9鯩_LBC˘jTF8^T\t[U!9-[T3J1qKs*RDGE^]G5f^
$cL~Am78e!!$Tw4mdiýSM愁܎S
wbZk49bt%Ǥ-#eKG =z9wl`^d-aUެkxA"
wP'r4fF/YJa9M!΃OP"D7 
P>f^}3wv>߼VECi/+%t	o]PԨ,'qC /FRܤG?!b@k>WN_TlF#Xzy%9cĮׂ,a5ʈv9[9U#JAAFN{2'oU'aۢ\Xj쳚"=,?0澕
슱4&v!gDQȷ^r,?n4>L@+נ%PF8?H
CZ@!]e	2UMa$Dbm3^tڡ#@(|GV4%$"-su	TE0n!/52|U(Q5kHTHM
=̋+ >)O+Ut;"!]/EB"7!r)~^_هF~Afij.mS'|p|:%MxJ[y>֩	v.DsS}NSDnzKfYzwzKAnU2Z*t#1+40t{$%Y}k1ƜiWl[|",Eׁi):X)m8Y!!*?*(A	lkIzNj’־?{Od%XUp9LYFpu6|`~!oX,`ܘ/E&
6+[2F^atΧ´\'R`:guFLsLH
nZ˜\E}]u[zqL))Q)v˫;d&ڨ|ç[IҬdvGctD)eA'(#ۉg
=!.|2e~YJD0)W_|EU-sWrIEiIvD\hZEZL?Fr,=\7vnj٪4b&Om^\?{VVn2<$"SxK^<5imZGhCg
5/>ieFe#&+jh0?)pE<=*9ɰZ+.Scړ\|	e(r{DH/Wn,>#]LPZfب$m:bYO7u|A(>Ru7,P'oZ*TʙNt_
BlU!c_$UI~pHǂ0R
~\ؕswzXF42ڟEd\^4/Oc2ٙv+R1Hf܏ I^Q2(ean&^kf͈u7
_As'{BL!o&SnEhnv᪠{;!'r:z">N&Wy@;ܒ$IӉo(".k9ƸԃKDªZ=pJ$GymO8%T
kzbYk)I[;C9gr^yҀ<,䙆c0Rk_
28F\a)EaY:̜OOJS(65jəQټ({rb67NмAN(v21NfCOSY2a\,j#RI0^?&2^E9?4--$hE2?$nQ٬_^~l'+!9,yPHٵIeduVflMԸs|8}JJQ^FYT,+Je7#y@3Yք[ϙe;BR)%Ӆhg2i~Z]V$o;/^;-\d	ho>BVڍBeJ>6ݛP TD½߂ߘ"JcDTD.iٍE]TP f^lZ5)LCkUk}ܿr[#&BMe^VRwG䶝%E}gQG+N|D)uwې'˽n=ےyW
0]M~>R)$߹yeTg2*sƔ(%_fGtŌ4wR
x;/㾆gqG6I"
P֓ ^ٳ <΋Mf>={]eG
,\+]]3>7=
@!t*+sӷG*9b?xMl72#km\^YUPH7,7ɲf=;-
7Oc&/]BK>Ҫp-DaF
AeD;
]?aARPS?ywH5xRO/Ê=H>yIJ!IVk^Xi*~V箛NjɯeT{۳?.{'@LnW S]zUkŨ\
PQ7.h|`YH8%@숄6~i2HN7[8CAysapSoHPy-$K8"ӑ{?tX.wUo.shS{r
}R}9.ӫ^U,b/u@̔,Cdyvī&ђ1;.()i .[
|!E)ɜnlz&Fhe0
nT17i6y@2TJiކ꽦{nDł.ZYiCarݱ:q»M1uh4;Őh:@_bVQYb*)8XB'Gys\ݬoӾyӓkk~>^?oPX'Vw|u8\Ɖ07~דtR:G
RZMC\-ugsijys[H*?
VvRBO9#F/+\)[ i
ȟӌ5ܨQbeВKd@%_Wl5I'ڗRn*N#keC`b9tU{-nj.eP%Ny
],5+u[4>	^:EqCYۖ=n-ǛRp V}`TsL1oseOjLW>@P9FnKbq lCXMΪv%88%
W@!Ak@y7)ZoXU_2#vKˀLAqhMF#fD뼧
`z1
C.9?3@|	0Vh)o^'hD-7.vu~<׌dJ>s H$t.u{I1)~`Cn}=ZCz
)+`qum(oK#qm"h3p"9@F7Z`|kg6c$%ה	VriOJ)qzmkṙAϻ-8#KU6X5Ce"bvܮkHoh\֌NCEUƙ6yW	߮ꟃ}ܞ-8R71l)*]ԸȗyΙB	5!]qޫò1GoO/a\A8Qfk6u˙+zՂ3HoսbپOH-]otPhފhP[ԥSDe&2EwMnK
ȃzr;|"L9Fڭ(W^lX09߲
h:gjxf֍A}#m>.~|eΑ$R|Uȷaw:C}[LӍp]wRt+_͹Dfh|X7`}hsJF]x{Xz2~[axHY>m7!Hۋ;j-)ZfaI'ZͿϤ
E<>|בoGy|DF!{ݟ%|nӪ(y
k,GU΃·_ܓI~nfrI"
3q/\?~=p0%EGtO0T,Ӛ$@q^3EЈUӥpϻLN+ln=QۖA?)4֥gUVW"T"E6eK6\lv}fQJE/7_QgaC#h'ɠXXa[PH@?1-irǧ<-e
b5ABƕFWt 1KZ
݊[URUD
Z`Z@mBm)r&yCfɡ#nQat>/ZPRiTW^>.S1(@߉	?kgHiwKpkoy;(Gk|5z8B!-yZS\pb cm$_21<X>tv6!N&:]g)Lu5A;0n۵@{ëχ5%,Zʊ}~C>57Bdh|:ǝEamB&DkZftxB]sJ5§q8ė+^q@>q9"lu@Iي`rP".tS>RsvߨK\Γ>
8QzZxEtcd[MP錺y7Ý)
5r3]-,s-:c~#߆.BH}-?w67-I݌b{7VR<	A܂u?,v*"#s1L^@nޛ#rzX}¡J#@cni;}k0maށo8WF=ERyҿ>o}aqNj)vɺGYf14vC~UEīS"f'wN}eEȧ09hP_FyZqtQ,oQo^E#s
p2TU!١Ia_жT!sS$JM39"GKyG6^(#Bo)q7? ّ㎺<`wL'uY0³0E2{\hAw HLt=-&gx8^?ؚ`q̫Ӿ3n)̃TasmD%cJ!
ֿ`>ct18bH0zݫNwp1=1~cbWˬ_gpg
F_N/΅쭔LSmpcw)`i9fHBŔc|As48o4%O{(c0	I>~yB|jAA阐LK: L`TѰi*G@_m`}b>\OTs\	}W:ޟޢ'`y
f=7fmӦ.IAPFMHa9o|
UbR]J6OMdeVܦ5"?ʹ2xĕa/&YèIrfnxV?ȳ>	q>\w\=~ӽeln&*?fg_;b`([[ܑZ,0
 iZbh|>vUdApd%62TW%ftE7}[փٵ[q>DA`
Z]<5ŵpeOcla<<*I'&IW͜|;;g* m{1d^hzΖE3*vi}"S2+(@NPr_U AKbos ,`c;RoETEX&2۾ee!4vo
VGZmH%Pi_t#&N
t]R}Fγ㸁*g/ep"L{mh=A:-JXVz[<h?R<`#Ǡhg()uSrʊ*8|d۪YXh{L=DEa&؇U4T</ luB`aVlϺmx6YtG*_*(GEbC^K##MEjn%JL9
PKopAu;çN%!X.w {%x;śwXqXPeP]Nd
+OdPc0>G!W?i8Zً]jAR)
L9pYS++pv	A,-u58;SY8$F8g7ʮ+5wޯ<$SS*f0}c8ɼH%Xqsk$&|X2~qם9`9ȴ42chYߵy΃7Yjj=!FG͢PS]KKcE"(Y$s"rh`KwWOBӮم=YGA]6՗"&b?A~-im!+vJΙWpTW_Ї#
K剔DYӑ*aЯ>7WS#ѣ
VR$ipa%:ݓk%Wκ%$x%6Y-Yjj@F,BjqM}NQD!y֥J;Pp#IKf
ar
g,R}
:pƫ!Y9Djq{a`Jp@|o:%YkigFrs_\Him=;P=?ŵ(>!3!InoWxpǖЍǫov^/\e`:N7,`]i%ʟ}Ykt3;K#tի&'r(%%`\)Mi-tT%- _BW3RRKeBc}q(#7Ij+ ]{>6D#j!iӢSһd1;e$&TJ4'
k|GTx&5F\0_XGJMZ
b3./S͏O19
~J.oE,D;Hޣ~a73pMb>(fc ]3mo~LB;GPOo]%ـ/n_r$V,ۀ?4Im2x|!s%ȫ&mХS
E7L4}-?Z'F52([P`x8zaƋ!{yw=(,r-Bΰr?!A0V~{.!ix2$Q]۰\ӗ6_)yeRx(68Oi0"$wkeFy+YbJ^bZe:k\@u;ULCO+>>UU-cq^wQ5RJ;ZK'.B~>ja20H$'[[|fыEl0s|AIto9U4PDX:kC2*$=6G؅.-;FtLs_6و#tjPF9v14^qcثZ7	˪8v,6ɟ=EsԵ\cAF̿M$%I$=LPan5}+Z㐘9BH	;kWmtuMHTy&s
+$Jےif
5WzdcΙfLJ&zN%g
7L	Z؁)3,rWV
uRz2{͐0fK{nXc)^1C+Sˬ]쏥1c~UP&=VBk">.
"5m؊cSscy)ٷK\*顟X,
:j}+d9>ܙ@?!kT2u>y2|m{yO,z<=ŠE
`<T:ꦌ6ʾwĊ&&׳^R9Jd"f] -|ļװ6Qk'J
OWЭOaʵ	\H{Qt8]fxh/0dN"q26*Hj@AX9dupjPXo-ZwTx)9vM@XЏfS!DpM'wAl$Z0YىG{azwƕ*ٸ
ӄf;~
yqy̝
>4	x
(%l"ay^1
3p?H:zcv(mx3y;;@752H1	Poa'Q+h5RTw;[xk?TwKv|۹zq 9{\(1JCTXTz
HJÅa_6Wa۝J+TxHL&{!uX$P0NXlѸ^h*kAldFa51,ym̚&YѴ1߯}xv8vh#Mh [”f/9k]i|"@ϴ	/L
hD_IܽgkqϹTyv-zI^AzZ(v'3N%Ǔ@V~z~"NC0!_xTy'	aQϻ.E|?Z@b>X	В\VU.rVi\6L'JSPђ@T"#CQ'&1r!V4o6s2ƛMvCFȗT`IRRQ3Mi)E&%Q߸Vrw'	x4D?O9D`Ym""oG6tap` (VQN4Y{>N$,xf rN)^Di"R*dRPH.1]"
J[;kEgfs
cZ-MYdet(lV*@8O̷q!pBt@	e_:0t.aFR사^ǥE,!nMMf&4>UeyВ;gn$ +
dψ'l1:yLg~V܅.ۀ
rpu(ElI9||i4CE\_2|c.[@=M`,:7ۢz ;؀]l,:D=JklKXI<-pB(@+>g}$m?AsQ}Ee	蕷<
Xpр=#g5geH7/Ů8AiD"9D )8,OKQE_uʬyWo,KӞX\:N`O@`3j+u9u{tjrb=|d1.m|̰dЌX#\q=su#cөj|K!)or_\ ҨaIţMo112=wYE_uMN:+1|)\Ԏf[DP,w,ZC}N, CbDˠ<|ԧj2mln[WFUVN0A+azOw儸)ȩ{f-LS;'	Rp":Dfpi}ⷅCnl49&moJɜiR)ުJ}FORM)VDJVUINFO
XINCLmemo-tools0026.djbzSjbz$
nvQY/=si27i)T@~Pc>p6&m"~HV"3QlיgʺE^"Q֘9g
3ܮ'VXN=j"<c˔CZZkޮ
Tb8˙]8`yrסՆ(醊{sY;?
I3#N{c^|rN&6ZiŖE߉nLB#rk1
8Ĝx nC(Q?U@
ˎ\ϸ		yV[{\S6`
CɭxPFT~B+^ڱ
 mEc"ʖʜ9e$BYrf}td-Wx	TҼ4V%0U٧(j7g,KkNvA
z0q>0"~T4N}4SÔfwK,7b-.|XG
\Ty8ĉ(cZe4zCUjEm>ԥ+uC
1=y˦Ȇ\gaLP1f\2:IIn.
\t!o#C	aч\8?m'T\a)
%h"aPPlCq;;Z7a9CG@%nh (9UeLujAWll7	qHUWuK)z71.{ddw[ڦoZAI]SE9S_qCWV!
"]_F=&$&vT3$q_Jth"vu)X{6oFF,3IڨIy%+Hf\ѳgRzOj6W4K[~@]pxr'6oB'
@8J^	Y78=>mI1qHE5(
CvM#-7e44uަy4]q6z>(~w
c	K_miQV(׭%ŝA^JaU*9lES&1ŶcHE1L>+%a
YKe_a\6R|Gb5	VJm͌c%ʩ)߱21sc@cC~С(8FҚ)Vku~Ҡ>_`o8w{"Zk4Se{d\'>_yCd^
4`GB~NS&wH-ϖ/-]?Ь_'Nh<w)Ǚ[7e*܏2FhZڸtEB]ȴY{Y*8^dWM a4eO
v.ZC
G-UvjcrX@3,^Zfę26
&zC~X
볽)6	z ֟bOޠx/5-c	6^
.4@!d/
> )	{)wK
ĒluwfQl(qrsMC:6F=(URE$fZ4}pZ~TF@{z;+oB9)݁LHQ4sۯ[^k;Y3ɝuI>#d
MȺD$n/ikpFw~66W8ltytvJ6/<ݵi_*g)o}t	@8rƑ3e8K`DQCuwPx
.ʨj-Y7IVׇ+n,Wn=ZoYŝLuT#=mOlt=n |b=
veN.'\
XsU,?I b9{lNH`k1fnE	A"uwRbI3OAA*hiXڵ}vVaҐ0QD.AXaGh_[Gu9I P9X6B6:1}斈օ"1TӔxJD8*scn~Xs⃗L}-Yg*،rvӖ0#
%/+y8_U/ԾHƼ܊~i{N8V~y6`޵] V\G~(7'OZFfUheۺqk=cvJ_p󬄟#Ujo!u.>v\hh챑SNa.c:͇2GYuwᒺh4Ȅhb7j9ڗ6@1Ul\4i4H&f1)b#>SՊ3`Y*Wxޙr,N?Qym4WI۳fլtLPrX¤+7ư=hj*~+%2mv?ýg4{;rzPɁ׊ү?чo0:}rxP{0.wxPy%lWA0hx"讀s=Z͈2v3]yC<#ldņz9)+y-r<3v#ەM~5|A`mdCGvH
O8/1LasL\g^:Ye2bR
+E5zr7#(O)n}˯9ˠF94l/bGVJO~!,`ӺgH.,]`!e9.̑0WO9%8lW^|w[~(ldϓ~2{?o]nu6[4#jnjߞ}薊q>04lF\E8$lbv<ۼ))6H\	96rChLhyCGG2)B=#͸=&l$9Pw4N} )$*Zuk`m9w~UT214s̡{!ZzO+)\9ǃ 9:Ϫl|vOm=ثl9LR;`lV7FLY4i`{s!˦v70ѭx$?d\r;Z5rٷLl-z!rd;>k'4飦#A0)ٳ;8ގ\JESq>?f0i4D4F7KE+bٛ	WnB2%=syh w<#)Im/܀^:$b;^`,3=?}Pe.eWUj#Sh;s|YՒyn DMZk u{9& 00,g8҉)$֩T+=dOQ^ܑA)j$tϪV
wf*YyJ\x	;@4I!tӲO_9?fkUim^&JVZ;z@õ8i*8xF@9U
%W!߱p"N~5#pUB?iu Rh4wL.q{Tzn|Uw]zvV\l›\q1Ic%#le,dയ@R
xKNy$^Nc'bZ!R+PXsGU^;t2;~%O RTp|ɘ/9t䝗Vd-Mu%qsu~ʴ|ODC@yӨy¶K#4LSK^@HΈ4ǑF4E>lC6|
6s~bjQTl<*;&ZC*T굍jVl׃-:/i9([6Y<6Mp0b5$fFډԗ( 9xةdVŧm&hv:PoIHbqs,Hk~
5-dLAFYVt?k"chA`'02:ŴQABbtSU/Ë3bsQJ$/}3{8!{?2 zQokb(]"bl,?=bY!)kyL?_7ιv1{בZ̧V#$3hBd`*{n]0q&TzZ̡caV5oں-\d|6By{:RP|&qR._1ii\eՁs|Hɽ,^_97(	L]e%iQW(жoWיCìzW򍅝![3`|J۹H ǶV`acj0n8B^GIE8mW=`Sf55X扁ϭ#W6~]T_~Uٴ2PzxAC	5҄JkOvnIFޒ嫸a^ɛW9mmF"Vc#9mζvE*aYBz@``Ց,S$bp|S7.inr-$3Y\4ZX5Mr{?F.4ؤU[?j0ƅ{nQ6e4#,tvT
PVr?)d
d~O01itpV2okM\|#=9@Mۥ)8Lq̇Cbts-slEՐ5!p]_1E눋XFv9X)\7@Hq&-Ɣ uidQcRոXB=	8ӾcW	[ԢQ\F#fб#3e	ԾtsoIwhQNYn2'nsc>MMдm<*˙2YVEب$8.FK	Zg!i
w=xO}ʴPċ^·sxtPؠoadp-lkOL_@Ll?T~su1p	Ö?&8xL-vo&|um
ӌ!*U9 dp'ըJ7ÂBCFp!+!TFc|WQm#"GƻBP&YVk\^e	O:z,>_Tqu\2Qt׶֟2a	ADͭ?=۟D.oϥDw'Eη!W$'ceB74]!=d
|P10_HiUGFKd޾|RUSAdxvʉH܌壶{ǂZVfb	{a5ڜ@.GF;eEly+ʕx+;Cj*h%
>(I-DhWm|56FMG{zq[<{tHnAExo+eOފ(P5`:Am0ê..%/'Ȱ> mE=XKD*b-S9==xg,O @ps4hu)1kSI?2;ӮSwK0Ǟ͇ٵTu(Y"lj-J&H0ˋZD{;:Qђn5H
{OL2lۋ˾U4|&@s-we+0L!"*(1j/P,zd\QwIs9'N4]Y2>*᳀xy,	jCCn^91վM e qH5Mg[8UV.#'awU]6; !BGܡ|P,+I#wsejGtc$3hĠ	zeYƻj^˰ŪF=:N\cp/	@Jt#
.^:V{1=1
}eFJV~-CSkgKZxphmU?v!9p*4+_dIlBto}5S3MOj?BR~ZHJ.]3GV^u-4+`Mo}0fm?eZE=kaISu)&љY<ٻtCs)ӁLԈ
afwy|$h	^$bh$_s
e*K_&XvE!ݳ_%٦n	ҡcKQ5LF@9i#ӓBZ8Lb*[ܩ+[Cz+p/?JVFұ.g+//eT9RI2BAQёF>lp˓CDLBpm|LTO	_FhxN01:ifS{ͤ
"8i㹱bȀ_ Yr|gόge80Uܚ?̙Y@`	#4Z|5lb	3 
0W":ߨrUoW,^c1\S6r+|UIzUkmd%j㏇&S㴲/d$2rDb?4-jpϧ
TH]~>X8\}P/C>d
}J>
.[44x!S&[>*e>!.4ͺTXTz
rH|z`,yd@zKl;ǩ[7O:π,IDفО}g3B<#vrHCxzw^Ro]ičq{ܤ5yP'r!3B4YeLJl~_OrhkjX
l¤
:ͅD McE>;4"ZkGAع˓/xDђֿm*r a9=upFqvk?|4	;JJX{!_RCvN^,]0ziOw/@dr'!oxtYaT۝cL/>zUn&z5E|ת*m\99#+ě%z(} 1TIcˤlrw{qǎUwdz:iڿcIZqRȶJ?]~ѬTXbabV
ږ҃hW*(5"fd@1+;LWvfde<
06z
>p~pi ^.	RIH$bg*8MREI+GC9&dk
rxm9œ(-r]%~M2b)K5N3=A'T?aX?"Aƭ+(c ,$ur)xk2)^bω7gFİ-`]z9ʭ~'
"8#VY>c%?VP3 <0<֘3½TGFORMWCT>j	k8$e$H+m,P<1~7`VK.E
 ci0"Ҁq._[CƶMu}Ɩ,̕vJm@3S4פ-`FԊ=_`ày6T|]{`F2*6A+8ql7eß/l -MBzn,PS`f-3LŌ3_!
 v4v9d{G!n9"n"7q/(츟2:6s(VY杈o
T|2&&75,|A~pR~$	}i+?!\LG
=whKMlea/[NZ5+G_IaЖph0mV^{zTi;b*OL?OrdA$D8mT8`5r"1b$RHwML115 "uq;|,.8{kbnSQȖm
s<
q%r~7^L yݴ9aUhB^gɁxjd=sT)ZXOQa$}<Gx]	
K0?˦FDR78"mYAzi&H9Zi1f~MvJ?rδ~$`sDxu4"~!"V|$Մ`OY-Ƀ8P|3/h	hG~A
iԂ`9Gb\Hd2ŢAˁU;ח4ռigry#GGtD~C	P9
_XP2Y:U&UvDF=
>E&
d`#&.ZDVHzr0O5
1PG75JB|#Y_HguA8DA`4ߥ&7s {\(
ݎ>U,0^.ǖu/ud';@]Lfi]s|4/ud&:Dw˶einWrݣYF-\D[dɅtw|CÔt<={BxgfY^?`7*z.~/XC%c۰;E4
l2ҝMA:N ջU=ZLvf7v~0:jqo
fVƽk^"Zk2>h7`XO*Qh	Zh"Iag
ߤT4AީxHb({8K/MZEKw۴'P7:2(bKSe#_g/IawPY]?;ɅudYãEۚր)":erHwpހDqX(
-cZLHZVe6S
M{P«ɡG\ãԂMgK
H^F}?LMަrHwJQx䀹~|hz1,}iMK{9ʵÂo,S.DySZs~ZRlļ.%]
*Z^KG_qVya$Ov6KbE$fjhhQV'Fuk&A8`zU(hJ⧇Ժз.t/:m4w~yC2HͰq$3()P?]_*<
@qnUԕ6X$2M.37B?m8qrf"ZLbgQS}MEzmu"c`nIr<a$r.e
}'f\Lku&ٟkTeg{z{3C3\@AhT&PǪDl>߻FuGJXTHR.{*+G
"BSjwGYrQzE+ 0-U!/5dasL2щ*76;Ld0!AVLɚba2퓫,K/:k\F#,~S+~{"vyspLS8>BPYA{}]3ό E60Ja%tLlýgșR&ŚYq8Z0WVw]]jeԎt.Q_6L4NfG=ZөQM~󎳊Ѱڏ%=9$D\h{ZQtéǙAtZÒyRy>KVSA`
i e熧rkVU#5ZZHǰQ;"3c<1oǀ6GE_plC	8gSY揍`7D"'DQhp8C0>aH2--yҴԦ`#p#
N 
Wk^z;Bx5fg~v
W`^^+v"V>Q:5H:̖W4^Wn!\f'KiGD.M9|R7bPfܳ@9=c3;4-}R822t3+0"^E{T: T1Lꢆx|
!fBƧex΢{GZ)c	+.Kki&vƱ=<2T'.;Xţ	6r܁n<6ī/Rlx_}ܞ%aes;10taW=I$Q
K>މnE$C1DDY5>.WA1cgtуYg 2Jy6Lp?\ȧQA%eGȈԊUjG{BFƽ!# O]uA0/Տ5H	oAw"'y'}r.'ѽęh%n,L7BQm[b(/׋%P)K{DlN=i^LCƣ\ml}`BsT!FVhX謸*qAn+gdEK\ŚQ%͕Oet?XTع5J'B@)!Rlѫ;q\vZ0ZaϦFO2/VIX;ktѿ➗"
JK#,gu&erSUlg?J.bZ|oq"Ϲu(1!|lg0y5I|W'"қ iA0$xjizTZB-Ӓ,{̝뿄Szx?pHH2GcjO>Z+E^QS0h5fLuv>܊-E}
,Q:a*)*aVxJ?$@cey
G>XOԝⴜϧPC#s{Ȥ!Ts7+ӝtd"@A3H{:1rZJ:5TҤv9MnK|Ԣ՘(#8ŏS)m$}Wy0B%ADfr=:VNa96:6.GEsBh054d{1`*/_-?Sqq{ܾ\p8Uڿw@X
Prdvu7`
D(^PD x=ugVt 
Nr^"&rA݃:r?d+	QUdM6o=[.y28FRzf7Hel6/"I*i˚t@eZG\L0~Llbh>מ`wީTї? p\|ѯw1di-#8&sn]gŒrH
~hS8,z}73w\Im7Xك1||5H? {}}͐5 >Bvl%j4wZdml[Me>YbSEB
Hu9[}#2}my# ,1jt75ږHQ/YxDiV/zd~k>h'av7Keahy)ճNYQWڮ>0@vH4
ƲAr7	,@'JqH	IHΝrT5D*g7K)J%E$|cI.2F:7X쟉1]l.\H	ȼQEיcTNXA#ǠP۱V3%%u3ȗLYx
>QGٴEZ(P{BGܐ^mWi!]$zNjCݏuD;
nb

s/;
&0ٜi.+'B\VeDHA5ԍ* Zqe{xvahVۉAj3W
X5ՏN_mM1M~5lc>
;=~dClșy椙Oͧ=fIbv6&"u[V7_]fͨ: a<=V~-C,vLo\/*˦*cτ7͐ioHbk
j#Y٢x(ۀaM}n׆GE|X]Onɞҿ;j[-z^P񧫍h5hP+),.i/_oՒ–ݻ"q‽l}:
B[Jipz?p!-KԁT;݃R[٘I;*	pEsLji~@9jM)?Р "2bWH5;6/ڻrvN& K"`TL^^)Rdԃ,U׫'u1z ,!]m'6](*@6
n&ʌ6'鮤Xʡ$048YDkNo,L)||9sa.#(A\ Sxy
.hP?bip.1}K_|Km2ҳl#S/VRzPm&VT5j}pocpZiy|؇„PӍmϚn)D%PV.oyK&Nꓻ%Ne;CɄ-xA_L`qKg/ד$5=o	^L湌q/#^9+3 NbÒ}guLk(Fmmr̈9M!e
-P
ƚ-ʱfal\Ƿq7~WߩP7jOD-Ehpxί;Wx[Gs9ĩ1Bf3It/i8l-entfkbqNwe}]LۂIS@M@i3j&t)Z"¡;7kZ6)@k#
xǬCf8%SE
=K6%1p`YWœ¼Uh/)R%4/)B[Qh
O+p=Aв{X01UIm?Ɖw]2+f2eP`u
߮Vfa?`k͠d0HLC_;RI=UهqH`OO$IO^HɏD^:…"'M% `p;o܁^\Ѿ8	^U't.9pzXmYb>~
|(0=5-6.0=Xr‡#^0KJWn[VzO1E&f=z;$Q](w9=JjmzA6DŽN*x.<
}ԣDb[kJqu4殼}ܫrim3H05H_aGL`'inHƈr҆?>ʇN©=	Ld$~&d/%RMgl&Z8yAQ̍teajؚV	+"F,q~1m1_S
KFYpwn	(6OL2.3yM@> J"5a+*ҡ}@PPLCͮ%N3U# o%>M:Lf-)<|ƣn/ncχOŠŷqׄsEREjL5D7ibz3xYi8xp$Ha܌oֵLe}t8=ECK\?ECzXeFJg͚1jr9O*·YhZb用.(2#󷼯.:_T.қF99')F57c`4!sWgV*]1/~l\i,>%
wz=O>I,^?gנSOZ5!d~)VxTu ϖn̦Ps0	K+<}4U`qdfNCv
ȪګB"a49idTRrD<61Ï3dkMfb7PBR4R;`$Hlwvvmិ/Tr_9UI'hk4/[{Un}S0B=s1,1
?^|c!T󚉼m6~C$T
1?LZss4)(~VV2 $+3WF@2Qn𬮠Ů-$HA%s=LR$Լ- )8Ȝ4I_7xIx[.G`֯WAә+s7pý=P;KKr$ӅzS[,}aN7)4=\矋pylɃj?{10ﾦcr,yzΙFnj,z-/N63o3 u8PzaBHõ)aƆcDT<>;\/N6{	:	,ѻAR+mmDck?TߌBhFaVM`]oޒI˖"
gF1$K'"0U$:'J$Ie&yVXvCנS:=$ʓЍw|'xQlH~T7^6d醠)?i¾8ӡtN̑T󕰨`U&kGVsχ88`%xLYƭpq:+zlF#Q23UY%C &y*h_teraʂW(s}dap`Rދ%qо~H/C4]m|Bu.0V)eܽ
MCBO!ƻ|ď=#i's`A(p%;]yʡqH5	=*rΙ&UOľcr4,y]pUg\ouJ.3!<,j
9ePCq>>s&ԗ,5n[ݖ '-_\G|"On#bXqIWM+Ie`Ms~#/Sw3D<;N7f!&"tR)_í[M	x3LiG{(XDa*(WJfhYO6#O`s0N՟R2a}YmtT4AO2̚fUWv1NBq_[ذԩ6r()",3')3y"6#ߦH[k@/ȡZr7駾C4S?:p%A[	s30_D-!Ն[kkMT&9ؘ!֦'cvˆ\ċ+EwQj-R҈jK
eۣ,/t
Nj^3pP&
yI+x."3]0t	)\A,ݡe#kEdu;VNg6[քYW]uLMDW4])b;O$3bt34Fh{ΝWqfo7u{$ɺ$QW0#|MzFop+ʆmwM7u@
ű*ؤP^bZYV8SuQ(_-XJP._c!)(@
5U̕PtŎ[R.^eI[4: ݕc
l|=>&h%8iHD*݃|hZN0EYѥ-YNAӄ4	c!72E"+!^浻Cɾ&SJ=]T9T'UY=ڗ?jo>%7Q_eg
I<4
dԝf[Ƴ$u6Пds6(trIxm\^Cck@IWM+-$"KL0,F!\oE3Y!9!`!FMQ.y^9T@mrdeΟS>޿zY0N[ėc
pNĔn+A>^po#3l(*Zx>
^xT
oz^!a/a~N'IYRIX\)˱E,cX_lYx:I8պEtBtVYXQs|19
n"v{3uja)8.D6wC
R45,[l\ut$ų%[E>/뵼ڦ )v>FnM50jI3MT[l~\Y{2|ُ95f&X%ZEd߽.=kQu҅

.o VA2ž>f-zJ*kT
KICi՞:
bu$baSS
])i;
P的԰stkJ&;Fz.2'⢗eixS=\)}{R<+k&
|a Y% pQXG<̊vΧ=D^SjF>'Bho $9ٟ,!yCS=9.ܴ|p>G98ؒO
!3DPtzɈGmh,❈gwPS]aԄ\o'i(vذķC	1@(@ڙI\cA$DR,clJ89E=JTxL^A*,@Sr
(EFA
C1@~$1I!ϩ	,MSa_ 6$@v"Tgf_[t{\
mcuco9](ArOecqz<ҡ0]ds_ӷ0Jēi!SnP}ޑƜ]Me
҇s{G0޺R|h4Wo1N_%>	T*ŝ{6,ùÓLпÆrp8h%^V]_2N+ E'Xap[~@?>.bQC
g6z5/qf;O6cpK;WR纇G;x]!A}ao k&a*.v%01LWiDo"Q+Yx[;gbU_1		mW͉[FO殘*`r"]'Iz4&Μ$$%%+pg8JǺN ~8K@witbj
 cM/F3M@JNH>4Ve"g+RfI~QNA!eٍ&ZjqOUSa1	9632~+?9|X"*&+z,F0HQ6$#0μ:gF
^KHf l%A
RLI$5[U4׍!^~I@Q=!~Aa8R4X-']@DGߊmxG^Q;&tmȧX/1){U[jzDWF^a͇PUIuheدK*@lO1_kCD7tԋZ95¡!;즔o5T(NB)Oeu"_G=Njʹ0ELmuICgI8-ICݵ=ȶqLm٫
_"2p㟩󽑖eaY84_.^voyV\Kߺ,낌_'}D\Q,rzX16cF/u0
'@$RT_c4y -T#לDtHgMNWAώGԼ
n*w\	|gZF-~qBe/}9 
yTғukH38UyAԞ^Xg
:7tfl+Y<{T={.+P(eg~tp_ɋyw!M#>tdX97!be,:њCV<``!0F]0D]"M}*N#EO%b6MqT,Xq	o34	u5/s]2EJXΈ8ˑ,_<тpՉOO(9zN
x4pqt0GػYˁĘe{ɌϖI`ZbH0.uǼ0'1ٓDji.ebz08x-L6V1Yd?ς6׍CmLZ0L3[-)7]^	>Ir}EFU`NSߣJ6Y,7z{h=b8(m*ܣV9ʠxTʁEIBzX)T3hCSN	u3mv!QT).۝7AA]Kˀf<N}Oa%w@ES%Ʋ$C4:z;+a/XTnbrR걃oTQFZ)XhOkf&Lԇ&.tn_8Hߪ4j2(FpNNk8V|lq2-en+~ܡz[֏!%j}Lj]WZ.}z݉ߩWrr	SXfcbLuR"n_&a7 hXȰЂn )WaXe`Rano'$\TQcMs+k|ܯVJ\Xb\^sUCsȪk[
D^+odou(yUi\?8aҝZ݈~`tgYUaKG<݋:YW>i%
}ոz;e8JF>GL$MtmOSyEsK
HڌeT6efk|ތ$j![QHɽQhY=ل
7(2x%mZu
૚$]RcK{ UtV엓#a)7 שh;vN9?\L)޶a]1?+y\p$?O3s[a3E?:tR*$q2=l5#>.ư)8;Ei}-Q^B~!c`kqju!BE<6B$Z;ZAߓx";b*֩/Of0**â'JvM8_&}fnjM^ג8#u&l?
k/nፕl{dE魅\=aY"cVxND!kprOɀRi6I֍DhkyÃҦ|$jX&6jmY|P4Z_=u2^$d.ozM čKD5O; 	ƏIlna=™`TjY̿"`Q'Pg7,c0Tۖ0'XtxBn~qp؆/v]CU]X[Nr(tVtKu.7w_IKx'OMTd/E;qTlr:Y pJ{F I2

ըNG(Z:#Xw|)%c-9Um~aUޣ?HMfO|Kxo&U/fm靲͂0fu*~g_~MA7ܨ6zP`d*-7Z&rMD'L0@i'X̎?EgL3L^^u!&yam~''>-ӽdb9ǝhv-ʆ)iybIX}4Nv!O	$_6¾%^[ü5Iˮ5sAWwv:[hq^>
KYyI->&{qj"}:|>ޝ (Id,#.% IN#|N+/dX?9閕KC#nZd0ȴu\-hP
O%uӬny&'td	6es%{
K1qa$eR!(Msߜ	[YDgA%528}coup,T4D ӱi"LAK6*,z]gM0VzH#'EBAtd?_TpF@<=%\wo%$t9!u]L3zS(2+t
AZX^m7Ŧnoz#{#
YZ<ő3Kw)t9WG_C|ֺԬlQ*Fz~bH"ޛ.b$	ҺF8c]5c/!VG@1&t\o
[5{@YJiA^p$ᣑ*h,0oR$3C]>#%f*|WkL7FR%:.C3 >p|Kl	l>$M-;uldͤ,#/}$.e~^Mz+WK7q8zݾLEGgHgۻ!4;4j{GJuִrr30f঎"T9퐼(i	CUAb	E/$\[E
h^Vss[SZۖJ|y=hXbmθ1k٬*N*~fk'%&HS~]Te-vNU\|Vs
j2xQ~G97iʩu)%	#EWɝ)x
"cWN-t
Sܥ~ȟWA19ш1 4zNᵵn,*ًZH#i#6lv=&*CD̲J?c
"=6ũ[ΟdRoZ9 Xff DIWTnPV:GڬdTEFa6a$RNe)ԗNYws#?Qi2"y4ͣ_TXTz悇Hu=
Gݚ5Q^0?ZPZVl3ˍ$w4L{.[j=!f&=듚cbd!'q"E7l퍧.*ڙ'\8̏gc1NkI"5xw70\F3Dܮkô*g^C/
~E^o1FV*{ui}$iɯM%+9?$TO+tƊkؘ=MvO[Xsu?Ma0٠)L֜9)&>uu(3]{92zE9ⷜ̪YqEٟ
e]j;'DC56kE՜WU^'(GEWQl6⍋\F;a7fafoێބ(ey4[BM9v	|
uA&_z;K*_
֝p,XSyj.ӧ͕VphI-Fx\@fRZ1l؈V/6;%7͵@a8Ly'{:)RH
~ePnGlFl+/g`/zeP 4i.rDѣ}?r簯QkpӡzJ9XٔiZ<"AF$,z6t=t6#J澜@T2f]!Aڥ굖87+췗c6]I75	G)]"€³Puܔ{l[6B*G46k[pDoDYA^hId_q#yH%C4ҭlwݼ؋ӄ.?uD	Wk]͐Uh$mj6dֵTŒI(i;G -pGAŵ{~	}e&rO$
>#/G=.fᔲ:93|npi4+1
I`LLYX̱Vϔ!
ݾo7éyy-ùqQZ|bBߚ#r?`YYSs|4o?'lFR
li-1]	2Ws8\)IlZI1Gb60agDj1I`E8
].?b:34t3zI"ZE+dػװu*?D9cɮĉpWxm]fe*NL@GX
pN]8@*Dsr/]%U>h!\+4*tRRY1m2Veײuuulʳ3/|5䒫I.͚E9s|Tͪ(Ъ49p}LEޚ&+6|!]D3;
s	eA[7
O?yTKl.l[ǖh<*n_O<0,n)}PJ+1o&T,25-֑"T_8gdJ5J:h8YUy*`'>s
djZ9.J
3pk
؊sb@`	LG8<Q4@>b;LA.EFORMrDJVUINFO
XINCLmemo-tools0026.djbzSjbznvQYҹr13)IzI*x^ab	2!]`u |ER
G+Sei{|p@6`Ղ:.ÌlpGNtnIREPSF3Qh|S2mfmӑ7+XtH*W͵Pc&o)\+PGBzY"ǀx2#e)#<_#tg]f89R}&zoꋄ8,7lun3L=vl<{YN7oNQ:;댪SQP!e{>ufk-ahJ!Bk딼{{iU8Z¨Ur!fuڿdH^^bbg8ӏh)	_+4I񄴻)Ұ;TAhV^[y!G-Vwk\6n}Ni)tAuXGQ[pB3=P|vjTl&¦@"ێq$ ȯ*^q͙Ó| =*%J3^$HBv
kv>.tk"cB1t'-N4/Uo7;YB0\jxhe3@lyfs\(dVG~eQC4D\lSJP9'$aYw/(0HTKzFL{.`Z9@Q>w㵮C9׎Dh/t7BvJPl>O8>@{E%z`V
Ym|Һ
EqX
vî٥Or	ST#.&-nse%&>oaf)*1lF(q9a`Ӗ'	fp&췞Q39lׇ$$>1z]XZ$CkVfʹ[Ydo'R;^
Lz+d(_jL;M?6lY^f#
|ZOWMWɊy`bqnW(|&eEO
Uɠs&BJ1}^[6Ȫ;8α&v#m
dG՜}(t3L6j?:=υ,g/:j#6Ipv=!ZHoT$(9_92%
[0mo\
%]GyTdRWJ*s&qT,4Osհ;!2wPmε\y,-WI 5v1lmB#AQ]
47}_SFzGr&\gv崸bY+ͨQ'saB
cr&OQw7<6KReI.0yy-c=O[ih}$G= ϓa#/6oR`(;,θL]xEQZTd44
&ܚP3V.0ϑhPDC:{ӽH6'_NJUz='2JTz~`mҝ8R{BqwsTn(!`~}P4WE)Uc>%	^AfP7r"khgNaM6t/1yD
HA8۪0cYsd81į_U
5oW_G,wbBhuKP	M^]U2S@fYSqbx	+h11OaKb}pa6F	'yXRqKABLk[.PHI;ǢՍ`UArAWF{ߧ^.B- t
,ϖyk|OB7>
4:XJ(
v)x5SD܁8גn*e$:wL`iPC*>EӍG|y	讫\zn)iaLF=~	8:hb w0:>޿4U@.Eggj4$55*UE#s_ׂ̘bBwYq!tkY^m"Fl_5\d֑Ƹ$lGztX8QEdrƀth|n	
;W]ge65Uu	;/ ճT HyxzźgpNmg	PT(8+聦v
ྯ#Z'U2U-ѸT$Ҿ#TM`•Z՗E4Dq!C۴F`{m5VAK`]s(B!D`Qb`[`@;\r;6S\Z%x?t́*2ctKHm31`mBY{}QۙL?ts#;іLٞC6҂U#M@Lv8y*g<zmS6~LPFD fǃCH_kyg6ؖ:[r"S;,|5}-s"㰝sLa\/_uo-5@0Ӷ%9}1iJL_;)IUq	yB儦naUn!*f/$Ŏr=7O?t9Nf"+30	-ifa2;hD]0vdsXgkmC^&f^KTy"nf?xTϤ-]ѩm;wዓtZ%nyjU_9Z列07ahk.,U3bee>^ei
RWzGX|5j
s}~AMvwJ0#^QFC@B V~ASl";G tۗ>2,mb{s[cyQI(
V"* 󂜸'={x'Xoݠ*4'lRԺ́!=ړ*zA8ymˇW%1ev42
<67nw}*kTC?9rp]X"Wq0TS[~#Cv"N^~0|Jw&*&V@@D4a"zc&ة̀C=6V:ݸ60A]-`篻*pp>Fb!AٞZ<)lAgt

ͯ
H/;v=<b /aK)lT=x9/ke
g$\
k0%iIkFoŏ%XK*_TgBn#
 ID:\NHO4m"ejE(K7Ҥ2В0הRg{eTTI	ʱ+^	Qm ^%
</rd`wv:F:$.ͯ~mᨅ%[c7|F!hA."g7Vnx}+2
ER8Mǝa!37t;@G@<0d2Vtbi"yvGҀl1bzZJx;p{VQ2l8A.)4ϑn W)s /4QꟾoCWt3\ϭ}|ui6RY7?P8[jN*PaZېQ}}"!X6_&\	?"ua
-*ol3@/(T(ₓ]*I@%JF"tɳ*^w
KrUCp•Dچ(>Q6bBSXx
3m7J뒮lߚX$V׭.[߃}m_]>D#{2N\K_vi.}q<0cL+t1҄
v-vXv262H0`lP[O	cl?=xVOt&:C ȞtdXOy92
Kȿt6FORMCDJVUINFO
XINCLmemo-tools0026.djbzSjbz;nvQG8Ϟs7a; r6LSR۾{r塤kQu38ps6+[\ Heux":THi|M@lΖqoZ:t$?w+1 ZaـS"i{ǝ˗peqЕu|vv)b	u4XS5kC>#Z]m;I
x<:W55Kа	l9y*%oB|KŨstƶ1G_KϏ/Х"'
1OD2L th.x2G;0D9Wg)c
;_c&7XA6^,8w5")`Yd&9.*u͇))I}{Yq&j{z-ozΣmnV!<6Oy);tK8=gpAW"CSS3wYZM5-7JWYܳʼ"[ěu]4nvbʗ_č$ƅhgzTEG?\u
i*=;0#oyy1tp:i:tY)>JZ~~߀`R؍Ynט(#0#?1uYHӞe{p'AaPb+}kSΣMVPJ;܇~;{>	UkG}Ek/@=[1x :YvUĩi˶f(,l?L( tE3t3%6-/2;Ls@hʠ;=Vdwl5us:3H['YFʖ?`~Ӣmc(3	ZiRf	xg"ZȄåa/3}(3ioL;@?AII{8=+e7!2N~gqC;8$
}42UhaoAI6W8lG-QlW{͉69^FYt~ny:Ve}dY+i$m@j(̺Jpȩ$'H:XFAGް0׆!F늦B8ݳWy2ޏG-{gRJ`Z0Ifիb4y^Z*oԻܐp[,Hm=%|x@d4]iX&-CMZiB*o>d9CWMȶh%8Da2cxl#:!=wF9C!%ӓ%pԃ)Jj~;V2;sF bK[jO[8W3|1*'Wf!#L癕a8]biF4XPp`q7XSSTERa_R
>$@Iny[2ٗV97w /=|pJ`=f3iNigJ4c^5wuϢF Az 1Ln˧C-@i3?n$~Mi.:We:sxBd0/LCנ7Uo4;G{r't
p֮ۊ;;A'.":ā8d	 7郳yULl$J
XDC>.:jYC*OjSپ޵CF@.
'ABHש`|Qur
՟p+n=+lmpT|2c9ȌݳV)"9S:9\~pTS&7^5wβ Υ]Qtn"Iٲ?Xw'8mXԶhH1w'ʊ%O?A|I
-Z͂ȇ`'yPΖZ]QmcD<p:TS&!5b³
1Ϳp,yl'uKc>J|bTHaa`=#Lۛ`jPM^3aO}V$/[\('1p$LC.녡!1RQ*w"8kZsU37\';`b!4NbcyQ"TZKN_G6b.bMKK`Sf& N!^h5i)-5SЍ&+֬ R/?FEBܓRYq	}邱
)X)fc9˽,NI'O5	&@d"	pt
PKL<鄬KqӐR*;l=4k<C[㨜izJQ#{J;	PBxLI{6ϰAlKjPJFUIުQcnjwÏLo9{gHD;*-=m*ΕJ
.ɡ})V
Y{
:_(/.T1Tj=ܦ!J~`DgJ9ۖT|Ŏ4|T.5*x}Oo"WYw '94ԢQ_1H9{.b({ &4Y?;q+	uɉƆ+
>^&}(MՌiF/1_8
sځ73Zc&65W`1JhY|$z|LGf 	ciT2cqn]hFТ@!".6AYFf+NO9Fr[P}iW8[͋+Ҳwhz+S漛Gʭ/b.ѦF1\-&A=􌈑	 -
d|'iͲ/.1կ.C^zs1drmf~DGJb*܎QOlB:$HSmy>g֠x`W]_t]ďKi/hXKX[?C]t^C/_(vӏ:J-zEU%^`8wvVPPR_Y,OfRz0/
~v`0]δ>‡Rl,0qK8Fm*GhdjsJRՕyG;3EhZzmF@:^DKh`эrW-%ћS^.kXQ]U3L$JR+h+=GAk)yQKcߢ`X\g3cXalBd}h)qnyiو4.{2O<@dB c~xw=߸vQmI\Ps-nfӐT܄A-.:Tfh7'-R|o+u\aWvToԁ
C Dj}9ȼD{#	Fx
N.4zp8܆dž#UD(!7fMl=O·_W^u&YZJS/ԈU?Rø3}>ڰƂ{С<l@):]:o;x(oDŽMY%oJ_7IJ*
}ѫ?ZӞ`v90	o޼r8ZB
B/a•i~dh
}}-պEi>Z|@HXyl)^6!»GwYбg40'X6X{kGjLb#s06?o9CyA3r^-.yB/pj_E+aJ(Kfv~'Q@wTsQ#n?Z,Ff
]yra[/0vYk~|ABP>[3	WG]0Kb?;BäD>6ނ@>z<1J`=Mü4bxAw	i\w**'_ksl粨*"V0HM2.Ruӧܮ[w*TMeyn7s9wTJi(Tt-0?'^1jcfqwxTC$EH_ꕗJݔ
6DA|I^^b8J "Oݫ& h6x^q(LX9Kd^;Wr8cg%E{Eih	:rUlsI\bW
 (c޽y%w[J!Ppy&jZcE@}" AyӪH7V5*+ҹjX\J<@,Z3t8rkZP'{Fzm`XR:]޵գYrMw͗_)+׶\,ׇǙ톂^/sحwP|徃M	X4UjϊVj,OzFwSk*-w
?)
GM85C+a1fH`D>oۓʋ~IBz6l}=:K4o0=m4y^3͠&޻+	mI18◤[,w#۱@700mSl^xQx5[Ǒ4`[p%a!
а#h*OnaOfezk>`E48~X;J~OTaLDOxEg/2aCRx}ABiNXf!:Y㤅bmy~zKms1:g/u8osLQԕt=øx&`[75\*btN&hsTu1PIc^Ƒ]ݺGW#,V3jұt-CM3XOҖsGPDYG,yVN$kՔ<n񌫹xZ@FA5hU,k:+I:qHasTFռ.껊&RDg,F[ۜCl#b%\NMx]!@\΍i
vkP>LcakmF]-b4Bq/7aZ
'
Duh`4ޠy(X,66ةroI]]%ȼr'9s
 T](kJJ0]޾ܫ%.	j߆է&`{7",0BWzٺ'Rj,}\Et]*'~&Fb#o&{~Fdg6\]<IvrS?U=1f>K,<}s5_C
;Wa_#UlDM~\U
ɂډ|b#(~#N68E}~"᪴9>{r4~Y&ݑ|5dCnܘI'}Ǖs֪U9}\[5܂*rjۗnmg`?קt95Q/(J}Bu2|x[vʴݼmZMO[~a1qe{V*!)4MII#t˻`tX$3N$q$#hSXNޑXuTގ^1k(654md@rq9UPw%tn쿰IL
ٱqB<^
eOY=zX@RY :7>I}XJu}GnWC2	'ZR,e<Ϩt]eX!$NĪFoV~QʻaAN5b[P=WeII6 'R2,&t|OPrGߘ:h	vEt2*&aL:(Ub.fܧ`0nد_fAk;X]ƻgt5%x|[kEN_S5}s`AטH}5Ӵս?2Z0?#Fm~@ߜ!DKv8K({ԥT=jJΠ"}T94byE*ق~p];2T.IϬ.eyZ"OC=T=o]74枝S'/'X'jA"-af`AѓLY3suuߨPbI(?屦}(w$%naWмֈiy|0S;B_VP`ST{-2AxLXjj	qEh@WdGe3pޥ)~+"†8i?`7l=JWR$GΗIԅjlDbys
G?Jqg\=06&U@5F	;ߦ)'oZNc≺V')d gv50 `@e$Y&4	)W2hxqiP3KԱ9*@n5^Z+Lusos=G]]9^V%Q*y@9|Z(%#"McdEt8h1^@ߍn#
nԡ.BbWF^w;b|DB`ӝRE(*àC03;dFę)Pa$'n{{)](iiȝ${*IF|6Ӈ8IU*,uo"!D'+JQ%8I|\ηcb]@uWW$ء
("Q|VC00M,EjBFGHbI|1e'#ԍ7P~O9k}_FvHG;*O4|DrZeӐ-OYpvMJȹ&:_l)kS	ώԨa8Ꙅ`^
e@o'_23%d*^w&e3֋>xX+32K_ڄ}A<7#Ҋ;.<;|kبf]BlC,
ϟ2wi%.`WB,,*I<xdKh(oŁ)u%a?W3
ūCs$8Ƽ^wIhDГM3C Q&}W/ug6ptkTW.c#KpcT7+MU͑Lˆo]H37G4JVc(V[q:M#;T.!gfvLֵ5a4xriBCzαvsf-ܗ#KgFBmcm̱.agѷl]LՏY;yL"e"⚡f`'\n?WMe4~`z>Q_n^l!y$xaדZFÒ?vuSlM
Y3|h"kX+GY%Ez>:kn_:>dh%ePw]>Gn	dCaTlABnʝ2\G.O6pH#GgEC}A$40j:hǔ9\X*38Aj-_>uL!Ӗ2+Jq%\!R(aLlf2WVFQixg)
S5M}p<
̀WADe,{;!b*g`fILC[WE*Τqj9.ӿ͝7:W[cTU2vjxFU%(IsП0o
G^`gC2fUYPsM7Dϑܐ^Z5'wU֫Ve!% kR'Cv/|V3ȭ^WK³<N+%2~Ҧ?gÿ*T
Ƨ#*y}חTt;:|뻔s}ž_q41s+V	r0쮾UglFu!vv{9<-O^,M8:Cґ"Տ hUԼ0rL/Vp;Ci)Xǔcw
Z).-h/Rܗ8c0.Dp}f'b4{cqܫ[m5JFvdz'A)ċZwp52
K'*lOW+|"`,8(E6n'ۣ7Ѕ߂{E/cS~W1߽_?DW3,
2UY='ǤXFǚ1VMZq䡝aVGgBdkH0}+JEԽW!̱"l{*Cuh^ G0v뤮gKw3=*N
7ԆKz Ez'jnd3D6apG(n,̮jfVUVX>dL2Z.n_B|"SnΜbu&8$ED.P-iL^-e^HD(R>5MU=͢5r߃bSdd¦ٹn	JKG6E[
=R'K4~#Õ?lȊ|1̏
nDW)+sIUׁba6,Ğ]x%
om$vKO[
xoVNeڬGW9na>eq@GI?_F|8zPHS/e*["iC/KILIoxgSC$bփ:
*!;Ku8狫L}F9cOF?գ$te/:OF͐:V{Ht4	&(fyR3X$KsZwSjF%6t}3
g:,㺲Q/eҭ(\O+;u[ԕ}.)&qþo5Xb$;~L`:WaGe?989q	lql^,2
i,5eֈU&>}F%v\CvCM7`ППZF_pU=r-*Qݱ-
@ij萻&!LMTR3enqU;K
%sW{~#K#뺙YCwhp%
M7fO6WWq6`hrZDgbAdM"WܱD"wLjSB` c)F
s)W8v3lEH:{XYr8zXI[:gɮ`߾#ėb49	|	aUwZ
	נYZZ3Ĝt-z/%&J|zNlr}@ԅNZiR}9`Vuhsq@/TXTz콇HTP2Sk/g|үv[ao[Cf'ޡ=ErCA*͌\Cy:yv].chS",0lS:Zk_rp|]F8bʪTi܌+EB)y	μŰ?𵿚!e%UD{9bqk>}÷hѬ316f3?ͱ!l{lfiħ\Oh:PW#(h5$ga^}An&PfNhY}yDSc0fP0nU
N!ZbO4`5.wє\}PW*I%!jݕczZk(Sa"j᪙ZAv٠H;NTy&*
sZe1	crqe12<`KQiqxP;n9`O'ŰxHSjJ竰D#<%D?6^}	-:KXWʹ>#p}gK[FMs[
[=OKӅώ_'UcDW]jI[
hW|z8Kcl]zHew%57h>0of''t]nWk\_9R4o`<iRP	GڶxM'>kcdA9j43!N^EƋ2JO}R/z
uFORML}DJVUINFO
XINCLmemo-tools0026.djbzSjbzDnvQ9&T,ZN]qĵ_)YlBARFANIJ"iqLŧ^Ġ!z?u}PC6/,x-mz
ܻyLp:[,mw@tȵ?TƏBꂃnSUqhX?MG~\@DGH?7V~*p[
}?9Ԟp}C3uNI\8xYS
ՠoH暹ܚbis7E3$Һ>^vVG1=LE-6gq{fvg1vh^22EZ/TT&'NWś[aH5YjB\,y+ǤmOvD-.I.
-$93XʸNs?[;-pwlo?LYihDsi>lf?<?KG$+Sv(2-yFi|S~"
$%(g˅ƧɅЩwfZGZG3qF4ؖ$tb]̌fP1;B+>jHԓpXKAX>y8cF
/;dY'
48Yvjp*F0mf0c2)2lWNӁC'` \;83fkQ-8Ԭb<c&
4
jiNۢ	"W
4 6=xf3i3vlاa6ڕӐulKwSi|9%6oRd3ؕ rR`YX>VQmswDA. V&myiĕ/݁F)na9vΖO_J!	)7C\L_v-4luі	@>s&KF/>rcC8j,*Kq!?ʎ@Uߩ>C=l;`c]jyImQe益5)ZtC5Y|18^&`*
Ţ'kQXBcޝ1ris۸3}gq+ې㽨8D
GZktYTqt:'yw1syDr26x{jkw4Ý܍~ݬ@ː.3_㑒is,/{,Pɝv
˔2iA9;B*hq9PH?<V,bo?>WϷdBB"ho{Fv&o8R(fAF`z44ɬt5kG8Q#pf-lJ`:"'!Cg*{wgbE%,&h{8qv`zg-F%칭Fl^FFm/~zʉF*&em%%#݌yM$R.aI׀q\:릏wRDE)TF!1gyXBT3ֵ)tTy(h`Df0sסSn?©w3G~x2 i@6i;e֕S
^<#]E:X%\)
H҆-̥`;#+h9¸utLXQrzVwG>DG"&:?u|TG¢q7T-HUG0D$)`iDFr6бI~u+p^\A h+uel3P;#>`r2/N%`p3RyĬ>:[ZR3Ԟ Gf/`+^)۱_+cCJ
g_A#!hTAf/uNXh?2s_+U2rZoet`R[oTl%×d]Y&%;yyk3#AEб+R4N1$΅fIUd3>4,mg/H~wޕ5q?zv?2u;;Umb㒙{ Elo\NT(g?@v%wY|
ߗb{Ƿ}N;4d
$]WmCNHQm>Wz*MH~uW]>=~	 
UZn2k/K׵,V#;cXY"y65/8]H"Xhpu*N҈!$
Ԩb`qB@I8pQg?ԟRWL	AN>BZSM"bR9q{S0Lu77(2VLQ<gkG@Mn叞O{)opߣa3pSs}֯}:ٱH,^@^8FBMėzlZfR|hX|N֕x[gV?
QLWp#qMxlqE0T{g93"*\Rx=C֘1g@Iv/+UzOŷqU})4T޾}>DnʋKѕ'N(#vSŜ,\2ǡGNgЍZ7lL e2wt!%FFD
՚FӾIa]emn2{\4A""(q~k}>^
{vo bb?-
P0`ǢEL2.P[#S$81x`lI9٠"RZ;?ibapsW7X@f&h<
|uVѺ#
U۴,G6mb3h	G?lNiDzlc m:uψѠK}@pk<:9μ)4D,NF0u5;Z;I1S"O>f^{B#CauڜUəFC{,=m寲M=V
_}3Ң _`a;VRa
-ߡBs`c$tFMW?dGD
W0_
'.FM]UXT?ör%Nrqȫcy&rzVO6f]Ams.e߶J
#x{oFUkzH>tŒM7wY9&%3
WPiȲL)žVCE(̿ԥoT2&(bL a0j^ 5*vs~Z*λ!g9d$C#ofε%A-&v[\dƮ/`S8r|4'粻d9j[h/}60
lRSL^_)QH"9E4e6l'0eC,v]
2Rp09]1W|C̀z:ʒUUB"z)<Ydإ?lL`vgvYVwхe^.8z̟|2N5K5Q$?	3wf3^KW*W
 d<أn?hcS&90=EU^F"n!H'!X')`Ykp,zeI­?ڐba]ς.2dMc4{M
oR	W&4O_D8	AgX%:a"%:?jճ>o}㛺Dޗ;?OpnG@@l'qZ('(svt'N.jf2s6"_򃐎Դ9e%fÔHLM-˹==2-Y7OhlA]9EL`Po3M+ǃ.Gv8 ,w椦r:}Xxh.h}Cx0FW?vJZWDYѬ>8֠]&bnnP&:bb$>݉&Ҵ;|NgV
ۭ&^\}R2F5yÝOM ݧ.o|;f^q^T*;R	@"83[?k%u36`
-Ef?۵ƘD#&F2R'+&Ad;:'տ̱R>#*k5P@㑲xmLJȀ?(d:$q{#vON}W
8:viaL*(
p>a1pXYL9i=b>2pf*O;j~݇z;Eո2H=]SlG;cR@cn2SpOJ{]{,ePs
+1psk4;\9!zHoջl"7O
Zuۇd=q^.M]	
aY~ctMcsᬌV.	(!`y.PG8eJ
ͭsv]J0jZPJ!뺗:CH!9z4%8X{\'O߸7nu4\/]y_#Ss
cMnC.+i	V#Q7.EX@ 胯F37.L@a[Yԝz,C	wRjN;kߢ[]dr`4k\@'S6'?WUث2ԃ]삣ٛGQ(}~	0H+kԀOܡsךӦNs~'NiAԵEo}t23\l`StIWV򓱅T#X
~c'rmzPI9)
KS?5mfҵgla:P	e0p̒Tۧu ZMo|3Jx}EӵM"B	oqV׶4{/L7xgҌ98#؏dF']q)%U1˗~NMPDi5,|eQDe+y4>UAk4fgîoR(m Hrq$ԑR;bNmzkK~:*2W"i'v%BAd]D'^Yo^f|%+G>-|Tk30I:ej)>vQ|soٚ$iH@~F	0!G
IZ~ncŤ)aMCc4Zͺpl,FR|9P} PN)]ͨC8 
m210Y
$}!5t32
M]Tmٗ9Lsݟ!!x`y?f0>˜JP\yr\B;i#WҰ񑤚Hf4)D#&a";rXjGUx}@18TLgo/̦FH&xWKNv	f
v<	ZS[dc`f
Z؀*Zij[jݾ+JWeotf*TUZIs/Q2S8do7UaqMv M*5hW
,,~1hm\H$9ղ]]u>=
'7Ʃ
>RIt›[齵g/I?~5ARZ9ǻ#5T:H6tEպ&I02WzBTfD)tC`?=|
l5F$T3fT%mP@^kjw;q2ޝ
c1?&"j83ۅO	\~EվNIJGCYÖclܪ0SԬi۶&	xͰԦOũX9[g'Ur>kJu2%yq$̣{)Xq9Xk28x"B_«gRim6H26T)Xx/zE@5@44I;nD!
i2TLiY߀G0"}G_ }UoRc'*|܍Ur4?'$v
~#%jK#c~xD';+H-|!KKqsa=Ćq@n`Kum`[򂧯N¶ֻF蹷[BawőxjTzYUU(tϏYdδN+Uuy F31{Ft[]̲:IЖMCTryu}K=2`+3r=_IrQCR(R8AMϦ
hBXQdiA.#v>"#R~~MCUPի!IrLl&D9oymG-ډBȘN=l6&8ǐAnl~=Ԏ0 .̙JOk'`\5̳6w6R>Dԡ)X~G1##t+.{,uz /[b}``oqR޷.jk}bmKLXEV?d@?\GI"ÕOd	`X	^R迫&&#PXUvo1mEdUƢY`cǐͷ\/%r:I>AAF[kݕ=.Gjp1d[˅إi.rjfJ	?^uEBzF|pRKclznp;2@@J@D&z=(?MxZ	`^_#6k\+TMGZ-k$ޓqET";-eɪK̹Li(>37/^y4YzJ	)9v
aOYݗ=N6VY9s#1l)T{} OyFtW+-3dd/xcR^$d&!2Կ"v6,wM2Ez0`iV,~
ͩ=ޠn7%ܷ	XL(R-l5K!][!6QtP@yc;\Ϻa
O
6cw3/dxd6eWOҳ5r|}L22n>vaWZkkd!ۦdEZ].hXgÇ\
Vͧ `bh*,3ȊƲLcJ}QD뽅=uv(pBN(2ނ{I x6*Ե{	jvj3a%Le;TCYQJ;R1	֣7q5}^ي.Q⵳V>	ctRy>l͌XiV*˲eM~;&_{~'+{,$2eF$CyvE3'taIDK8Ā\}]Iw=WΒnX%cƺȷ fLC` fPTj%}%IoE*w$c\4)cH1撟fOȢ9~ԞK\Cᎅ.03RVM1:1+gĀ|Q|:`qMCG̞ůSPڕ8>S,«ը!uqN6KuS/{I=~vhod
=uaGoMNΖX5y,%dEđ^Q[iXT,Ĥ(yRw%YT[@ԓ*)1{4X m9Ѕ|!c`mt9tDfґށ5}K2";	'ZL1v7{l_M̀6;E
`UwMX-.׭@>r,C9Z5/	
c5Qnᥤ~3 lY7}_,{BO|΀X]ٜNVCuN
Ay.ۍ≖>nOr]_|?moy=4ƥ#;lRyt	$(fu'By!0WVVvp!lu++B
rg! Aoc]~mE)ŸL9h_820tZ#"gɯP14E-7pHȗј0WT3λ|&@2T4&͎T?]<G<ItWUbJv-zHc5qvl5ǧw.mCC明*f'90/u<c.xH1c	Џ
{$n'OTJȬvf$X/6uG"PoS؊93%y
忖ˤvFeEӸ]	\92:kz;*'V0=İ:ཱི׃fu
9>|wBg]W|'Ƭ%ic.FhTM1^ʀ{*DG
eE;ׇ*!/`3[uC? fgŪC(6݆`Ő2AߘPf62W
pTJ8$(nswq˵lzigA9#*oonAw% \ҫB4µOYYzy|}_F`Kx5~*d_4B٪hr}zmz8-;4"^IaL!¦Xp9;لiT"č+TkOqMXMqPM@Js[)(hxn
;fCj?fFpwR3ZkI_Tdkk]<">Kk(*T^Nʼn-YåUԢG>L;Xի.;	u	6@ɦ7;zCg򨐾C?+')@j-3ar]!{Ix0lc6E
p)zn8X/k4W)uwqv]vCfm5z-:*k	'	e%_ [{>Z	Ě H
$IE
!o卵5867R7Cw`96
f0--3e'VyGhF>O
}UF1pKt2u;=8gi܄B̨s H98E{;l9e0rRcTT_IO
5=P{3FPvC#0drvȄ0E-E1K-JxK4"uD(UY5B(>I#cpJNj#1FsLuۢo!Da.ٛ$V3A\0Ss_4^bqAz8ٴ}q<+t x	zqT;L΋h#M/s6wL]zs0R)*w7}R˰ױ<2u>N	Qfn(V@1G~'=
2<$p08Ŵ%veAt[`.o3s5Lt
R=[Ӊ5hyt%ItrBq?:FTK~@SHE!:ݫe<}d`&lhN?ԭ-:Wè: ܔ^mH>	ټRG/\i9I1ɍ5r]v9jeD!Mjюz4G'-^w䁊Ӗ2SJx鎖 Z$r"1?糥
	n9ԌD	#-UeJ>TL>r7
mvKMA%fg^8T`DB(P:K=/RXF*lf[nR>JZ}QAr睺]l
`qp)6R.=!v<_!_~.~!MEN4*@edwv//Qs((3@1K6 D%ˢk}Jq^*~e`#N
cԅ4,7J|[m-k1y"cTlCAhɨ9q2Bgv%uhwacA$#=^T;2OoF5Hꎣ: }JfmsՃD==E7~a	ݨD]&d,>`3I UA_զ*޺}s-FU2Z1cK=lv1<ލ8vpfts^Zw!CUZsB1HTXTzoHes>dڤkx|4ciz57;ܐ&.iA]$9W!Kd
Wg8h?aN[;j
%~$Mn
je+@dޠjAKs@T"k&.AHqƉJֲ_7yZHEH".YC
$I~HLZLe(̡fI'FZEGʒN!q	6>Cn[sSxr	IW+Ue6*jNPQk1',]Z{Ǡdw&k
2+,
ӾL,jI
~]n30lamH\U%'xslJ+)TXBa^2Zɐ;|N'3w:/x曏@ka]Kru4F
!B*i;ץR2WbO@y2J9n_~#RrhC̑e
hʛ
$^
$Շ)*TKOsvOX3R
B&)S7anF=ŋ'8+MJ2W[OM=|]jͮ0A
΃%_E?~d:`f)mCFmI>TUf'd;AU
!8C:g7}O6`qC\Yo"l=d^]%JHflZ;Fy`@.ٍde:'MijMYj|(dY5*A'Sl/$a`gb
byiƆ,spO|6?g杷RPП
eKO.u1-j2́ƭkC[z7z<:%7$1Տvc~[uD/_m$U`P<<<}`	-x$$R*4B۬OV`؇=vdua[ʯ_1^_MLn(661Q:6oaKg~ENjXo߻F[#j.ѷc\9߫e{~ K@+B?>jSUSv(zѷ]
Ʉ,wN+u
_ᎈVaNTƍ)d'Tn'dUlA95- ,dy6쭇ң0/+l&n%H8D9W(5н^+_=Y^e*Id,h9>eQNmX[AM-";@KĊ/QE wz5c?%0pDL
%6
2XZ)fċ]a<4ġ8/v[
Ҷ	}`&1nW|![͗L|he*V?^8XOaKp Ul2j(ccuġZGYo
m]>Cy[ʗb1{6JL)zM?K9.2d^WDr?B+lqU{0
f~j$`~JuAcȋ(g6?hzIJ	'(-&Ǥ>^(KL idoXNfJ2Y;x%	[$%eB!@n9Y!`m3=H~XďL Ȩc/s$Cnvvm'J7{.ϸBȇqjɴuڲ]]
z?90@kcDIniF3R㓭;ß0RgVš\'Txi/֛\/c(`{'vFORM;DJVUINFO
XINCLmemo-tools0026.djbzSjbz3nvQ9u09O,[\3qZ*u.lE_₍	%ĊB>mḏ&"g񖹹ҕos:
„bkd:kVp4;U} vGd51,v¡l`٢H:T|:.i{-4{'c瘨m3	u?Ԧ.-$4u =;>3\b}Ӻf׻H$vaߨ_!տvۇ,p>7*qY:$4ꥸ?7iӉVGVZRMZHKߞ
8lnNâ}U`k")S̩N;XW
C!U!~47̟إz{E?-ܸZRC3ݍH+lw,ut,*k%Sް7'&$O!]A*-.Q|e(T;*a$6}#m
"O~#6\VRW6zO-7ħ~lH7@=e(JHENu3v6ü!Dw=:AdNLx$]WBi\ Vcڕ7jgQ]tvQjX$V[>2ExB.I1/OCy	@1S^u\&-(Ȍ!`N\R?:7@&ݴpK/ph`piMߊoܻ-s:0D*8E\vs-ǐuxݓONOAvu\ɤf:tON)qjSpcڢnbatOcBܐˈs9Xҡ}gf
&U,n+j
d
iWd)SO'LlHб/=:p(,١EJlZ=dh§$wvWzJ9< p[;,!ZBPc2AFr&1!M!+=Z̡u;zי`|8xr`C@ջt*UV@DR褳SJz=[p]yd>	PkIB~ЦVARg"&?b
хX#\8Ӫ6ƒ+jc@OuV&h h֪.I㧱{zmߴ8trYZ0:ۯ$*Sŕl,O`A&jv9%Ey#e,.lJ4J+&#ː|l7mF3JgO{ojw4Txkl	Q[8@B=;j'C_y.Qv
_ϾWL!:K)HU{iOE{6Sl9Bq'BJɢ]ۦl5|`p)`#]NKyl,ARm,ӻx8FHzDV"/˥Z5k"مs{[	h'~΅s\]d#-KqRMI1ݳl!n:o*CH瑶+ΟN
>4BFǦ9D
\i-R8hPѦN.b/ݶ[we;VB1
O6M9eW.O3>QX{*`vPDYWBAxR<>9phz<̳mëpA
=|=Y&=s3MTL9|r,yfWu?xku{lC)ˇE؉ٓr`]za۶jJmH$|pR!p~0IګfM%pҨxH8yR9MNTa!;,cD񐹔ā'w\q&Mp+ZqvB=̳֩R %n/Y5쐣&+.0;ëB
nZX+.
sw<
!dkX|,:WiNO>N!Qe988T8 j`+\PZx
6̄y~L7]$9Fϥϕo1}#iNn(wqǠI[dT5jMBk{Kj;|yx1^LwV0ˉZo0(fE-
8'6pzHM.,yOILridp;(&̩NnigcB[ֱOCٜ+]V&-|_(ds3zf'WE>SRxmIL]WBXExpI\|_'<ގ%?eu7uՓ6fVYM,Zai/xJoQ+u
7kLIt4*q:#N
ܑ.
5.266lxr@D3}1|W7Xhmp-uPK8(*2210"kP@ҟl1ÖH8lu!Zoc W25]nCgHQ^\I(=_hv]uu"_|ZH2qWHq4Ju)`4㫻<0R\*D2s9lѤB6Md|>{AV\σmAGRoY?,x܍FO#x!~gV;uA~p'bB֜PBb:_CDmU`$@ـ}SG/4~A01H`pr46~SG6ނ]H%L~^u('RzYΨ™	c	m	[A.qk@#ARa]W:2c|&M7onI53DA|-F49+&Bj#i E-MlZD/2j7w7
ÄqA'$lxZo.9ћb9L	i>p3w1SlV:/OĞAuȠt!M%hƭq@*`+)]
	U_%y9#~`zxvXDgxw7narE65"чAJgG?%{_IeYZ)!j@
>%AIh::؆:co	9͞ڌD#MҪߧT~l,UM7iz MkP	/
pql!ӫ?T b)y>bS7a8=۝R׃Le~Ć
W=hbވ[ֈ(nx6/B.BP`_CZ^sE'&koQ?C97fvOnhεTuKyCRo
Y6~񇱙\NpEhEŒv.mP-(;9֖F\g3Xɿuyd:\-X}[suXҳ.^+A^םVlߨwOl?PQWs|ԇ# o&+PG1V8bqc;4-sA7yܷ7$cS$lF9aRBfl=WmbApRy=u0J=ɍj6ݸ8)iee[V!5;7Úu3lVB2D'dEdշѡQ9*ݶcn5;ƹ~6%_wNSǾ /;4Ѹ&3.yݘ;u\#ׂ3.<^ڏi9MGIpgVJ=zh`?r猵ʰ<6aA";perlAG]N­ҹp\A4	d@R]Eg={,HlHn=d.V2Vp^(^6Y+y-.a9,p	ɾ6"n?T.
ћWIH
]>1lBL1)jK4Kn~*aB/C_i5-e"9OUoyӱiyѪηb	9GVS;Z6zW"ۿvmͻ5{ZIp+p2RDǁycd\O]>9\fXM]XUHZ!dtmuJ#:RgӚ5
^yĆkitS4R)[^<&:}	Lk6Yo[5H)warB:~ϟ6wGDrORUDrU1Q_Rat<҂zƆD1ټڍWGU%vy|85IߵP>e?W痪+[g㠊U0oG=vRdjCUG$n/8h{V%9--+\׏v$"L:QkȾYYX&8vL Wm݇A݊Qu(*vM2\oC7GoEu[;c̆8QEJn(-yj,0r/44{6|i>HaJz^Ma.D_˖MŏU܌qV>3)E L"]g*٦7vop2	yV=|AdgoMG|%7pp>ɱ-d/)tʠ9$(o}(Șhv,p&[xEU^bbJao3i
QAd
7?dř_86JkWE
kCnAI@۹T7 $֞펕Q5z:|QyJ
r{-΍a$d=8(!pGXRJI]jGU)+OP2'`d&i1S
OQh[*JD+e`*M
[\%)1CF{%l҃y?VrKpC?P',h v@o+X/1&*<ks-Mƻm?4{2*H˞P'Q;҄cMkDnr[ޕ4=-irH#('/)
^@/\DZW(KؼA Fq6dfZ.A$̀*0{=WVM	%WY)s4P2K.Lh]gj]Ħ0e{N@>,hܙ*\"zь^T3]2F'2z7>Rb&[iÑ۷c*q \
b,1]WcLݮ+ȮT8!dn))\RE̯(Ɨ^;f9ЎF揧x(
=k2H&̸^ô/[Uj6(
РpMBH^W4!r>~:_E\!9x'9웑ī|:"Z|D9b,n&R磸to9 о;X*1mLŚ_p?G#D%Hw>S$U,=WIQzd>qocr/]y#iZ).8XEa&e_s[6YH#5Z^q<ԐL}ē~?d3c@z{jB 1<<)
œԟKU4+=PԧΤ%&d]@hC||mk3qŭry(-tCƫls21f{
&'Hgn
|]#k#
_&as+CyTTXE<72WԲ$a4Ԝ:ur
cGDJ
SQG%:d뱪P2?*&^@ZH;QO:1gDw;jy~
㏸|ހӛQW2͂yxI#MT}0>IsebY\5m".ձ,MB)j1{?\}QHdvICuS[w8q_U
6<g9,ajV+~X(oŊB=ʒk``k/5V\C3[rcM
b\ Ǎ9W}t*q)q}(zh|yC(r uy[H{I4(FWϒ{oPjW%g;Z(/!R1'6ID;O5\ў
|Y;!0`g6++*5X"|ظQ2hV1)TAk3Ȕ6njS10jCAS|+"9#Zs<&(όuV,Y٢즴꺀[qzRJI_DSTY5rޏb>kF`EЍijGVNrwѾ#ӥO@ӫw/i뚄UhGǹHW[Mxl:i-̕Kٕ@]Ԧ$(&\YTbg?ehdY]7i\cQZ?!BA]:8vWgd*َ-B3i|y@CG~F^tTq˟M18A~ve*Ų[sWMWʏ~V{|ϯK'	_lE0=վI}(Z:iF~`yHʝ?ʹhh	gufa\e`0|
	Zfi0_&Pa}yN	f'gV>H&O83DXHj3}+By$x)j>7p= `|QWi~0>{]쩡A
]S\9	1+S'gQ\۪VJa͵aydڛx?r2SUt^O+R@"P&㜻[5CdP81e՘֚_pGQ1
U‚CA/Q绀Sٮ}oL2dLOLBPze-M
͢"lRm+w/pRx"HR%2	l~
9	u^LXٰD3tvUC5W%S"wɲ>
;6tU=̣̈́2M?zH/_+y{hMp^-Gw`dxp9@KiiP) ]se@J.jݾU6W霿w%xQu&]ƹF/}?%ݳ\]Z5Z•
,5M#T;dkD\^C	\(UEʽP7,x~7A%T@|O*~EPPL`رPZ^
&Bl(2}ʵEc<')g&z7SCۼ!H1u>kVv^zRjA=δs%%s`+`HҮ;͇ҴքDwh=4z]OksG5"X[ڰ]^pZKP$9WO	 _d/yfr5կ;Bﴢ؋PU}
dz\a+3`P@XZҚסd7H?wtkp333b7
S[B0[yu=N(&aS!rsUzOc$OPmx^c5~CzBoaό[wс@^TzhpMl?@:!F>t_ފ̂9b'Ej{Dh&r`uYx+Cx%dx;m[l0uBgFhT`:].؈nbR[XXɰp	dY>qh
%P28SJpJ aB{1#YvǂG0V*8gpݮ0zJq;CD	 s`O;Xt\nmOnR48m(Mv/^?M}Y;b4-Aa_+xܰu'Au1{"tG!Q5Ě:~J:0'V?1rgxUwve6uꮜ}3K0,!8Y
tULXW aM~ЭJf\hz40E:8qBزuQ6*!o8NÛ./̣zɪ3=³IBtv&g6pj{yɯߢ$‘2'cVfWHEqW nmMXi _N_6(|,*ǪЊ
FrEFG/rDyEIʅf5Ѧþ7(AOp\,hYEbpwoy]NdEEi5R-8>qłJnaKGĤf14Ƚ>Ml/a)!},Ll鍊#s+2x|IMY<;W)
W$NIhK.ւ*C߱tż&boaMv~
:TΎE<#ZH
VQ`׼W3 ?CYLI3%IS?rVUѵ'+5Jj4Αtb'{‹{uf%od$[ΏP{	),~c!SS`^QGG荄uۗ7IQ*rGgaWnB^׳$7mhdWTÞ3^#gqv&ΔJY!Gq5`\|1\nţ( ]#ˏCgK$lڑڋLѥx+,phsCfAw+OXx9fֵ뢝]*	f'w0zA07O mA/:TXTzHwc3Idb4`a4MKvV-k8MYf|mti	5ma\@qPR~my#RoG=}_J+|ZѺ;hvGȘ]EbP?޵V؎Ӧ,xX
1֝! CG(ol5T\=̦d^
PXu`WЃޏh6(1nd+ `rN?mx
@v4Cּh0>m:jAW
n`cEKۇGߚnѱTQ*mg#G:6v(ӎƊXj>4zon9FWQcSq;V|}b(n
LG\5aI*NfVF'lP?BeTKMq_[+F=_* jIk~ J{/`BeD|wq;7ElgnJ[6ɦ݋V^!t%hXZzӍx}\pיlYκ;ߙ:vQkgQԬXKݧ+`Ӷp;P!CD_G V27N
~#{~hGrw'ʴH x|°h7:ˉۿm~Sl^
}Qq8w5;d7`̳Fq<"1T
,0q!rH҄<ol56a89TRx}T"b+us$ew		9^ua2_tSK]Ӓ,1-)dV%	2J-K5΂0JsD2טeno'}$Z-CCW\m7RPONH/ p3M=[+1/jןJMjy>?<\Y'JA
h<.RheQmwzN&)x
o.UBbj̿\}^>CSle3%?r7WY{5u},K;ai%)k,><-?@дgJ!l[guͱvLgt\%!Y|IU'n78'B1e^Y3O&ON>2 te&y;ż{']Yx=U
*2nZG{ɐ;+O&XW^i26g(
쳗r\6L-g_d$k
D,sE S,omN2Abи{ڢa.&Xɱ`i[{e	Lh봠uc;V>DN"gFC;qHB%C>Z4gijR?FORMLaDJVUINFO
XINCLmemo-tools0026.djbzSjbzBEnvQ9@m[/\0j	J.VZzڏRa.Ps݋{?37&HQD?:nBi	~'/'QCV2Ĵ%4ҙRNw0<+O߇.G
))(MeP/*`>|ɾ[%.sϒnnO	oNmWgl!2m&IQMP2lKY7RƈJ.DhzUuQ#sf@kS&][ļ_txI;hce 4ppUsQ'/ҜNB|}yNkF-H7Ɏ&χu#E/6v'9r
,]b-qk=ap5RZ=B3͞`D)܄[me7w#{,Żf٭@XAWmiJ	:hpP\+FEql[Hڭj3pB:[^I=*ZuoQ4K{!A{ӿd^HeU슮(烇jp<XGEɩjbj|`bi5	˓"%{OrҬ?\*hξ1u@8vQ~A2ȫ^7eTxgPw<|g9G^IzlPjrVH뙢[P*0n4L9ܽ^{u*/~^HM=O]Yג4JGK[b(s؅Jfc˓"$4IMXJOX$VG
Z&0DFHC&>3,bXL,8rQ,:`FiGCɓud,{X־vf)<*K{p|NQ=©48&ZY`r_݄hQ=Q˜Dt/ eGOzf]0\8o,4~䩱vAwi# !-Htnvhvbj!!@$izd`>zFX-d c1ET]ްKKbX0RY"ʹHY";:̉p)\s1%LS&?Ŏ+l1f؇2I\ca\|~̢]6
TJT0?SmѬ{{M1>ND7J,}+v%Li3F"OЪ6w))ⰳq;Sk>sM~.t?
ٹ,Wr](cplQ.-l*e./,v4ZSΨR8Up9[/1	lu8^)߀ۣ	NF,BM/uB|0@h(|]ccÕoF G/N+ۋ
w(93Z!B9F^j0J ˑbo`"뺰L8qs)nvi{uUu
Wѩ=C)
WQyG4$tuIe|B|6+
QZxY@{b>i[K"?
(X%_ti& |2 B`hyxFKŨx09Q3>	2Y'NTv֚Tiժy5rlcb]MQ7];KZ
-l-M}HP%}X02,d-9xp9O,[׌u{Jֽ،V?/
TWCˡ{Qݤ9,-yyiOe8/o\UcM.%$ŵk
f
Fft^K-mN/ǫqm/^+H|M`ָtvSo}¯qｸx/6?{ ;İU%綳CiW_աNfx^@VSV?X>4b-WO#J;?)iJzl
@YF"+ϖC"3ɐ!yg[ޕ"wIXGΆc,`bBHفj	}5	zQuHx^X#*WbӻC-_q/#pN}JxT^3a]:%]ẃ~IǥlOȢ{1	| $NMl4dx;f(Oa躭u$XZ?j[&ǹDkg@٨S)
84Wۊ^>.-<%VtnYѫ{Px4w!tv5iA'݊Xl:/pWl ţϺHG>Zq&:urŽȖWyQ+Ox>1B4Arʔpt8m\!r@y"OuW~%uo"Hb~efb i-Z&āDZ/ b[{ֽ7Κ y,zr/~H%A2mGI	;DJkuQ"5m%c9gYA./0kBe\Us4	s%X֬
h\;|yBIbZ&H	OeӚc"o8=؇]/%eeޘ*(85!%₄{X(!oGo:$/A=+AXpG]	}EEAUMVq`bVIYTh
F#$ggvTh?o-A,˵4=DXzb~%=0J``Qq~+D<#M`@b 
Ń~mEKc@
%Pmu`%vd~<
fzt-;q\%e'we琲WPvQu`B:Բ_kKȦ̉vܹPB4pO 6(pa`<IDbku̲J+Kn{3ߠx;&"kM'
8;nG֫U@j%kf"};n<䜁=7CL]͑E}6q\DiHѶh.Ø
92FbAdrA.;%8xGBn߮<ޜ_
p~%O7$6g<.k	R
BXv7귋y<
j,4*~Yל̃uJ;41=9,!s?ʪs1j/ݏ"*\8srp0i>p*jbNe\M߰0CMK2B_$.j/Mo?
?	|@PLKDu9wX}gœH_E>Ic*juT7X,#8@Sz&[>9
[;:e\m/T 5MS=ϒH^g֪tT溆PrrcGPg^UFzTkծ}tA&M{
[\>KgߝaQ60H@}Y궴G1"_dU[2&Puef&c@퉆SWD 
_I,/)ʧ?s8Y^ڠUhެˏϣ&4#[P	b z5yxHr^\
cD"ʲ6x_2xJo7^XvNu|}qʟæ,U꼞`Q	W
mmZEj?a/
LƄ{"eңDޘ\`VC/Q۪X/fH& و$pҭ:2џ璷хр"H9EpA	'B;&(`]OJQ\ۈ@)pknIkPgD\Z.:bi	C$)OU.C4B&@.L&[Rck,'ӕ(,P!(J2BU\?[U~t{}Nr
[d8	YJ6gG`T
ƒp- d,̔|3V+IlVqŮ=i]o`fo;o18%~;1jt`ju#ߕ*j:VɅ.5s$U?,4=d_ט0q\*VxYh8Bt.:Ѧ(HXXQG
7#;0o:{U9B/"tqWgz
t@x- _6>jv03ϩ:Iq7bN%U__sqD_1Hi㯲@Y̸ydܺ`"k Ja#s5wưbq߉-*6vTO;bY06;7̽1Kr|<mR)8n[1u=T#­48.J
t'|EָQ{az:cɦA	\p{.4GbhYr_ UѦAF.6şpa
H-7|V܌:$aw'SzwΖ%4|1_UN,?RIJ*_zǘV[:eyot
2}O)q0d]`\d:awYg7yNpqFϯzԃU74|"":R~#vU>9RYcHcd
X>~ i>ʤ`'xx|}%`Q?_Jzx*=zôJBc5[\@@u~esґn	]LT:ߵ­}	saN'!.NZ_ǔ=4;_ӶF/Ǚ}p
S'@217h[S8teJoGiEe˘%>1D?dw@7EB4轮B*i^j>AoRNs%yj{1:;*"s9$LEl13zt$[05T|QZ|#k\u۴
l
R4l"}ˠeƘ2_^YzI/PƴHP,b~@RcV~<^/{`~[<9{P
IEZ/,Ħ0wFl!r2.jO
FW`b
~~![VeY=f5@R=1Hz
|&GfȂІk)L]nm`#^IF)ٻ7e
D̺|8XU5urj5g5\:9ʘH:pNP,Iv@2<;Д9c-Dܳ~47st
H~}K#'_K_vV.}=hلRӚ	O9PΏ
3wcSS@K)6|MG|MU!)3nK2ofӠ?֡8]Jk;kSdHN'c)neS0(Xŧf^Eїҙ=f󟋀_@krNC[anɧƎjE`BA>fϦCo^0*1OHv]0
/0e속F7(wrd7^sg'*>P`hjb$ vN1W>&DyS!-n{P21\
pKx1DGv]PHi*aeEÐӑBUlRԟ;}#QW&BF
`;[e^/m|;|h']Bu9\T~gC]rZLȴ~l]1@>(6o
KFOiCƺ|U!_z
>.;oΣzP':{'LyDod
#8,U.	AuAvQn ,^bE|ARU5t:XaگqzE_{"03̋?[zm*8?+:m`-[׃U[(PAGd;8b@`Z޻+1?BI:yn3mxOXȨ4,}zox'2d
͕t6N>2Ŋy2dեq#Qr&9P_b(&>Ogd`ʧK
Gg͜ @<[WХ^E54y+B_ۯť=6l.sds	OH5G̊=XJkD_в}Qp_նIJmte0{rYQ-P7){G	oiqU?=<\2Y,9*-L4/TB)ddc+CbANЕ^J-8VfjFlޓs9]tQPcDf)+4Ƀ$L.mVYW1%3rP]%6FYA]r`ao9L =*_
}mu܈N5(;:.ɳܩ׳~wnsiG0	P3eyfH]4n6$ǡ~-.wQSGO`ԇ`,Ϛq)ΘQl*dNq˂~'}ꦩ;JC@[a&nT`
	OrZAxeR	WQdUf+U4l1zޥ“6#\T'hEpr4Y
­klL=A`.r.OsZVYohOګ	B~eBsТ`՘^s4Kog]fc-D߱R)U'*\oPU>Q}<P3;úX"sqӞJs1
hOzbekqLMm0LIh-£MФ;g&WНjv&eS֕h?bKwәSdv^
ZҬsfO\
5[&TuBt}$EϠTndTϷc?HzDMΑ=	iP):uƤ`yd(sUc$a$LR`r/7$6mX>T[F
ZhZ:(_\wͽoVUQ'#E庭8gaB7Y~y۹nERٻD/!v|GJ8\2NzE#	rug(ENn]eTG
s	=*5c[uۤ8`iH/>'`q/J/]a,`63Qc&YjQ]A`s*vBG؝;QxPܫ%ߔ.7k-GXߏ:a/1p5Bs+c#B;Qrr/+U%I
:˵G3-LhImD.Wjv]
K}5i(QmK}BGY,(qb.2d={ocqhrc\٩e>th1(6=|@9À&>Py	,	ɀ&IuI#y.:4xUs5+{Il,̸!Ġo7oAtPBjd֓5ɪ9C~ S|+0JogC>2f<(h!/H6N/[22-V
5W«~KݟV&Ve|{KJ;kډޘLiΫ3
=+mɞ\5.k
K[m)04.G-g@,D<Zɬ`&vץȘF f	.tݦO_7Xs_㔀UGîO&d[]gq
kRTĭ+?dVV̇3qu#ϭ9,=(n
_[5`B0߂%Zpkf0%:=v#ya+]jbL .k(ujS+9Egs@:m+!nXDj&ᒷS&׌m$TGДzZ`(O,1>5E+MŒ·!}-!Qˍ8)&33wmE[9ݟS]sqc	RҨWPDfx!_O'sOLsFFnHۄQRµbMO	,aTtQSCL͇AS1x2wOMb&`kJ
 3_P}!J
䎢X3WN}+`
z%&	q~ٮjaO*oLko3a	G(`I脾V42p(G};_uH}-Є]xGA%/FEzDOVXs]'Yq\$WcX"JNx-D?֟o?
WuI(V~s9&?O)頯>/خ]P>D RƾVnyH?d4{V2s\ʌnY!bL~ĸBoS:mB(#sֲFmvv**tTGVrl?ƒT`=޾$M3p
x8y:;6=(FG
JьUQ>rLБlj,0qHkh\fE<f;YLrI"b;AKuyU-ǫ]'!EuɔhV#qZ7qgQ"N;7-x4ٺg~sKmJ
S|Rvl#킞фk{S0=^ړE~5,&X^ܖq8`r
귅knaDCѴM
oyyz-SH?\"ީQ(}TKt0Gȣ|m
	̀aJc'Ϧ5yurt, kFػ42i!UbaDùI#Jf'V	ܢhPkFȝ~@HPC>7foQeAaⲊՕV/iAo&KI2Ķ7An]Zۑ0pumw"N5mehe)\c?v._ɂUΚN86V՞k|Bb$Ś{P>-lY?λZ3z=&t1N;Qv`]%yDK1CܚwCģܡ*._4nqd$)vV,+Ѷa@6E0su_r0;m&paɱXzSYJمC;OA (uWŵC3?NHf

L߅6v@gV	
)DM:B{UcH|P*asWpxGth,G
7:8mΐױ;}v5tAQ<{gOL*ѿuE.w՟1DTJĐ4%ƀ"EmU`ē=5T.^OhL.C֋Kku4.p"Z8@&0ՈX$I`dE&Bح<$}ZXژL="zg㻤/knsSRr}>4K;1Uw&wx/֖UM6_"p={w9*WE<+zn`ZgMMYNXe#
Qg'Wz/ݤcp'Z35P+w:%<./ \yCWV%ЉnTXTz	ćH;/:$aab0ISM6X~
;p0>LKV"X,@mcx`;B8֒t:OK&0+4^^zK/Lʇ7EBQD,->fAVwևzye8	BK0!%NqFmgo(6@4pd為xΗiT QpZU"W^H9ͭKx{-|4ϰh,^|flJ1H
K"`}r?cn]	Ahd5G[u%b0p"тߐwwkrh󵽀?B8t]>%koPk7?
m[Ja#`Wc8{r$XO
:2DۦJI0yM6'_uۼC4Q=6sCkbn}~]shA89̤*=nv} 62hnɣ!`ky`%	k
PDesIA#HI.UI;Rn2S]9CբmޖXw80>DMIgl`\/Bz+>Q
PCr|jʅI.ؐ!
,qiq/L$W)h>C	xV%5Zlq9]0fӋlpї(36j̸mw@|Dyr/p@!0ÚK$kHJjR'(yG"WR:DHgr2{3Q36}@΂Y/1~ijߜ$J–a,w0o=2ęaQqM5184
'Y	u_'O%@˸ѷ?rjoƾ} ;
3.Å i,ɼo=vYvINGq}_^\Q̌7P!
tFodfƴ*~\u
)2(#3	p\DYg_:'u;\9u~$*楩E+$dm.W
|;SM&fo5rYq>eYMS7	@'9ZBҷ}̓0ř?;i_x蠠ͮKz
pnIƒojrx#NN""DOVg^&n63ꨜ{{CBm0	0:O |\J7'%G3':r#P27".gX((ZQ:w`FA[$?"o^	&t]b.*Ϳ9dӏ֫6ʪ
^B$Ϛs9>ؽwC&T[[#c!y|#DADžrO(sVl$J݋LfmxvѾ܎x:J2Z!TK;6SR[q,l<%Y:BPK$>6ۑboR9Ӳ3i^VpCT#ۂ%x{OhI֓
W9?Y,{s\SuɆ+4_Z6k~"f@\TdTM}l?JYjq05AU$'ʍ^WFCTAtxr_1Y`UsƣuPђ3ԼZRFz5"8h!UW`	N#DS|k,yc>dsEl;i=_-yq.DD,䜜FSX*M8s&)w&Ⱦ8t9bmf
\4lC=Gެ1+Qsи?[yJ/Kϊc#9VVuJ:K&},Ko+
XәY{i/ @&͙]7rP
T0J&F8(oBd>?]REfB%6f+zT9-t{.%~{ʼnB4&	(g9CUdo~D=N[=dgDb8pBxsl=V4X͑gO*7*ɢ0/>}r	BLQ.K(<(]vib^ΉfbnaZ52#ItB~}@~i^K~/q`Y
_IͭB8R#u{x7EkDHb5	2uZ:ĦfdD@m:D??(lx&w5A:}׌m@愯P}GŚItC߫S<`%"%t!d7C+{e'h4lOE?g;&{CAJ^}
X]-`ǰe]ϛZpƂxE6ͧGU/Umpή(S鼿MG<p~ВM&k$ڐN
8DgR_*SR`Y4A`W(ྟ'6-!\7>qyϞn7X0
[gzPQiqљqC{eǬÈr.0fcwLCd8`zBQ
G4fIoQ-52.-r
Utp
oвVCr5_9s+wi~6)&%)|:tΈHBӗF_fT*ѳ_g	iW
t]
ݓ&ZdLcѤW:H4Ե+ڿǬkx7:/9H-%#Nؤk"RTqn\΄JT;r(\~;秮Fڶ1ձ,aɐnk#&4ĸBSӌ^ᴁkOl1
k
N=jČuHtWuZI#=LwF
VH:6f?wAu7SI2(o:*Vn*i+_}&p	Yr$N8Rzk%3yiv!?jU]5lZgHdZz],)G
j
!qbJMGb@m
?Jk1mh\	l0WS&
OڸqF}+oٺTH3i3=>w`ϧ'Y|8_ZV65
PF(FwYQ/!˦Yw!#%Ra7Albv6m{k!w(]Ҵ\븵A:aҤC#r>ـSuM^&ľ&S׸22c.˳o"g<6ز;nb \5.Rx83D,nZ
0%QA+_RUHv)|.$P{nd,6b-uGQXvWj]
VO8ZxFoz&-I}Jd ;b:a3{s.	!qMs;U ٧
}8Ń
lJ)4D:FJ*m~g9M}.$9^x%Ky/s`,)/?$E}_*jd~UYIbG|@n:JÆ*mjVD[Nlpv(0:s#|Q>4:]~%q=ZH:E #MaXjC@?lA$'	fu#*m)`+^vKTώ01lg]7\Q!扥F׾ӶL{Bxؑ%OcΌToA{l[Kll~Ct{&rHV:d/*ÙXR6(B߆A|.o#n"eE,@K3/-)E=u8oWW~y&_Ŏqjޓ6)t-j [%&X*a,Obo6kl[oOmofN)wNB3W.n517.woi1V7[.\Z}]'j5s'Pو{W)& s2Lijj0ɆD'Uȫe|IB]?",vM_h['\t	׸&Ub'ѥk
,-\O) _gZpK˒:b˾=2`&H(/jVtñ=ߍa&
YS5"=^f5L~81s=iZ8,wX8=qjWfksǃ)ϣn
k%+g6Gt䎾σm]Z'_7{ʼ2ݙ^u̎
Ij\ʞfz.*sDD`D|idKkBek8g`#;Q#ȻFPrAّuk'23ߒ
Q#C)uRs6C#\}%MC_ODF	dqOR0p}p.c*RrFM\laj/5X@̻vzgyzࡔ͆.ׁ9aCQQ1שV eugVS֤PRʾ.!o	xX8j&bBmba
-֜_ݾ
˿ 7pŽg;/[jLWĻxf#:ή,;YAVʊWjcI
]:Fq?rYy;iPgzkp=ͦ+\)9st76n5_%3/yۘS%f=(FhK
j4V:xD	"4Zu,.'<ټ?@\鈡0RUªD+3#M~.@EY#:5
`	lcK2LXm"QEoXNZEˍiE&۽œo/lhn>)X`	/
h_0w]@tnO1ثلE>
OIb%C]ζ䢧qX*]puPMi*@e-eC2U{S
l*)4d躪b	T?"J@	QXxg1MabUlNޛjD}|RPSkEpZԷ|_Z橚*FEs*O!y>4N1?{B'PI2
 g{BK,|pq*,7ckZa1kJNZ-s+\5pxAa/QT@KcVTgSO&!(83ٻ!f2 MA_D*
}|9`Qi6XoC^X:/t?gէ$d97`d
q(*qBGDb @Uɛi\#a܂-xӒe各3hvY~Uk-$|^ /sxk5J/Gi~pla/)-B@:7}̼4׺ҍqLd^3dSk[b}Пt|M9B?QO|B1ij!>*9jGD`DPƙmV&dG⻕MzQ)d*0f߀ Ϡ(*BeeI狵mY8Xv'Bٶe0|X:_ĵ`
	udiAґ^]RKa|bj)x$D`6a7+HbuCq%%!=Z3Mrbr|(WY8f22Lwe	8AeIEq3&Q?~}V*'S 3G6Y>atrm9\DX6ArwlL#MaZ
z1ԅG-d
 鉨B9ǦMnP	al	3-T4$&hX%-z
;*|ƈWSVBVI$xp5fWνN)1!4qխ@57G_F$9OPNC{w:ZVMm
oW)^P9gjx+W¡_[/Lpxk,ܐ
?:[s,v$N5.se,&]gۍ${ۊWTLX
6["%)JpsS
ƒ!ڎ$vٰr-~fWW25{ɖ4܈j;B;H~S@'lDjmmZ3ƞ
	ODUki0Vr4Po!J2Lg}gO'İxtn)"ha&Uq3=V4}l$z0a7GlF0٥=_Stdj:L?6Rw-84N@t[5,8sʜ=/\o'k!T	-hb[KskV
dP[Tc]W[2|:N2*[MЎ;68Cg*^y^s0sx=Lk6v_)$&rvXC#qc~N/}sm2dBHۇI#㮽M6fEw
1mS&r'go1Xmg+[{:)+S@߉WxͻTHx4E7Ki:K
_)Š_Q%qך8i4e+SL2Y7Ϲ\NN&B65wN`}I;Ik$o=]zBF:aiU+bH'jd=YN1>k#W280Yǣx܏YHYyjtmub8zUVTfzfo^ 
Ƹ
rι?t{cX-hpWZJGa2%adUhL}MCe?3.=uZ|=i۾_[Yp08;<v}*=!T67/!#=fD܇2+-]k<4cOS'1"t]
o
0c\]\uٰ,ʍ0:eRiًG9q	HPA1c]QIewyL3}֨1v5@d*8̐6G
ZАe}+_}+5+診,j멪؀b_c
9?nZj
z{t)Z&1QQe,h!r+2.
A+v/`TC1m:Iu?fgJRhj4A|G%^W,9)2Vj:G
# (anҾ6RCJθ/{ԎV0H"Vn=x>[Ӭ>\-Dn%8Bldz:Q!ot$ݳ2u8FBX~keЖ8
:PwQ٫2Ah_;4f",+=:w4^AĂ=#
Y)wPH f"}"`rT`[}<""&pR"J)kur٪{$DŽ6ٴ
+6@ցԸX(ђ|	p8GxtJkL<F)!"T.
vTo%lvrIl圤h
~J0DppEvQ=Yb>XW]UK[JWy}ⓏQ?
]]V"T
jAOg$%1Oy>Mh㤼~xxbO|_L\~_/J!n;zAs/^=$Q`y%uJaVӴ,ktmQ2kTf->	[h~
nz=MBFa*jMBdí*02;Yq}h
FGM ?dU1V8Kէ,%6'1u1(?c+lQ}ؔ/O_Tu|t"qMm*j)]R[zC݀vBasl7FLƤ@/߫/6DUIHv%`
!617ڕAIwfRє@F$?~/X21q6	r0A*Dـ+06^
7itYNq4'MJB?CxYZ+51iױfڂ8jPod)-[mDnoX5zUuoiSQ)^tJx.l.
:2º,)7vd|>VF{pX'6]yu=q]:LzOkv-VbŰPݝj%9:OV2/l'2yBu3g#..S,?ޙՀC2=.1e$DiZ͒»-\^߃g\ͩ;3U91%G(!ֶ0 Mf yaطT5/o@1QM)#,ڴ(hoX۱L{bE?#tݴ0^kUYe:T[ٖo\?GFnMNŤJ20]cA83iuJ8Mp2-ʶJ%ØSѨ%O8|/ݷRE3O饂GFw	(iBm%t6Az}!Xڝ>;
A^ڰrTQm|jEE[vq^uF{WU#reSZ~])K3DZpJ[q	$3A(OGY)|M*w9'dKU'.B@JSѾ?XkLAY+]!M rg:*4HT4]9Hl>A`fSo<ͷw85Ɉr݊nٹ04ZWg\kݿJɹ.C{FME]6[]$G-f,Qrgؖ]m-T7Y3.OwSeGF?$dߑoBr&{ twDb3RJ`Dسl5fɑC(OBh}6C`c&Ig-@mݚ.Z`ku`92p_R0yOwe+!g e]m[5HO]HgCp_ΫGA0.a<F")uD_Qvv0~\yk<
;[N3HAl"JaZߑϬY/Gcreτ>C#8c]ֻHߒdW~2'xo
VImpzQm`:`vC+"XK)Cmc3uVY(ۑ6AUe&{EbLm"xªhW"a{^P9e'ؗw]0bnltd5zZA7%@,WU)0D܆Hi* Dr)tp)ۘlL	?N$Cg>r
spYh~>p12DZ1
*Agʼnٲv~JН@[=\N,iucKk-N-~2sQ5HW
'CrN,[ByVW疯L!
c=ЂϦI2/d=Zw>hbۀ08Q2VvXfWǍ#L^ 4R!F6KsUōxr>~8ry(x7q.W9L}5lP)BUz`8"OCOk~7}:lL I$7>ʹ7$9ħ"vRz$Ծ`7:gg4Fz(gXCÅi&oOܠ=ڮw}F:N$r9xbIg4Iɛ3ӹ
'!tCFyW.^t&9"tę:+^_HELrR@kq!;"OdZ_H
7\ݰ[~UXg	81pCN_/,k镸 ^ł(GiphEݯtF
9nX,zd2U2(Hm,۳Ik]vl&e)oWs,%bh)z]@)">TJdZa=|+@b
V4Brv}s8V;+H0xF	*e#e'J!ϺKSX288i'_bҗtf'UIDÍ(-@E[Ȝaae2weo89UQmq_Τ&aB$Ee0@Ōx^}Q1p7i-Qx9%ۨa1שcXok$Tcjc>{ˊWm	`,YhFǣYeݟ.eeٶN(ʣ]b D?RDv[LLp)G;Ld
?Ik#TXTz[HT֒/\}:Kuj*B1$"pmCE>^3K-W
|/ʃTm	S"8/]eqdoԷD#3yHbZC۫}c1W@41D-k0^"=B9-RaYÓFЩЎٜEI\[{}tVKb.	nyHa6@᱒+c@&U$hvs~
1O2`%XO:*]'y:v缼N⻰75Ry
*b DpT*;`&+h	:L\'IU|a6GLS8&98:Z"a`?}xaP'P@^Xmd/]dli9R=`}
i\W:
gf=r,S#VBOQWß@.$3%;Dcor64=>΅0.S}cUM΢[VZ
u-!%p"H̽\A"C
D;7V/R]xƐIn:Votw345ϊ[؅dI-ٯkMƾ8agKcD+
6П_ڛ٣z]#	5btګR2פF;
puZz
ϱeGo]`w͉a=)N./([L4LIrR8.Vcbp,2#I6)o޽s髧Y cWaGLPQxu_
L*eV9Lݧa:.Q"ƯWU^T.ݜxȮ7XO˗IZ{KfFP9]F(/P^n:>Grxfl˿"9׈ yc?fe}SRZ0Rd#h5)B5%g2{VL{FzbfxJhy}\VB(Ds#y( gaI<'SMSnU'=:PW''` ҚÞ=TrQpRRtOoOmi	%O5b0X5qO6([mK%?]@#oxh7ã8j'˙eͮ
M8_}A>{7&ST},.lßפ0
p3Y;bmٚ캦a1pH*W08߃s}?%@Xv(.ނ-qnHNԶ
ߣ];V	\	N-SO|+?Qzeg˜tfI-9j:c7S1zbtowZ5U7|Kfz]'nеwѫ2LVI?nkDkTpp&qxɯ3CI	)ZĒ74散u2<&[+F@JJ̿¹csӁ 2vi˸VX4U}~"zgZ:v-g 
g	IO͠ҴԨ.IT;D2R~c+\skߔ!dbjkiCCݝGJeby"^+-4'ABuJvHt+Zim-}-ɓ%Jٝ}|W8Sid.{?Cst@5l,?uǨ28Ty՝T?Nj&}ˇ1
|ٖ|zS{PU٫A	]BL,H=ݚ!ngƕ1rdP7)Np(HVr2ZO܉*{>+XAɇGXLs!D y-Eth-)JXqACΙ&1E(=Bvr|&LpK+:o$st!q{Ms	,$Lbaym5JGZ%x*FHU#hMjA:J/-k[F
OFL/~ǭޫ&N\6v>ZSO]-z7Yz(/Ds۟
8F?EDn)8bHs^G$B=%S9h|jcQ*C4/Țs+<GP^!!6rRԙJ!hKLQ%,d%4I4ŞAj8B˾E]M,+n	evW
 k٩b[@a!0y6|)K8Ō+uzxV?(g鵎hg'pv.t-^@ӷJP(l}[Q5XNܹ7z#oe_	ځBJKɏS3ɰRlS1;dRɜ-%&~WP N2M}+xȕו͑F1fo5,e^0M+YMiHGPSiy=i,)~6u^U܏͠8pԻ)P5uϣE^țy7UO]!
Bâml{yun+5Lf"(K_<av
-DBÞzMNAce-=ޢr޳ICrCS=`%_(&b%rrHE	*Ql&wgLvx93[.VσRu-RuDKT	͞)RkQL`)QX2͓ fU5gKB[Ö"SEfg |f7'3|^BWW0|Q({"~ZFuS]6P0'AR}%E]Je+oҼN(/y.U{/)QucYʁf&iO^Ddr
GS:pAN	\J$f~ն~w}:9!'tu.!G˄jOTgv2ߙZF$ۉ30}Pa5KgaC78'uT"EVL46ȔYdih`'kv:=vl)~qmo˽|S׎WksCDn'ߐ`KO	rGmݘ C$9зCVnAƐy3euZ^Eޓ<vƪo,p/?աǯ J(3\ۄ8MX~"*#FN'!˂)4&P?sQ(F+Ԃrg֍E[5WH_!BD`܄lu#՗0z$&\VMH@C/G,a_X%C0Pl⭘r+I!,t%׷vz+VC+،wyȽ$?%Ce-&7UMv'XAklIĩ^P26Әc2}MVOi	.
Go(PHv%8jK"&w5eFD&Q)lX62YU'd;qN=rT`Pd3_e^Z/GI2f$.X;6}oM?kΦ%Bm7(b[1
q:"T?):JF.)ŢCtpIc",?HNd5:^Qn/ZI*ٷ\C55up ́\߷)VG흟qw_XΤ%Nm%Q.2Vyh
wL(SR4v*򱥁/3G[ڙ*8Кa"qhʊѓ&AoVltȃDdp$ax>AyYy,^{;Zyx7%XKCX;#`X*l5ɏu{8w{V-G/4va0I$31P~!Qt3i5M._AT]hZjhe>5R4ǃ"R)E8Ö$j|́izٵ	U9a@k{h;lycsQl+S?@l}MHbmC̹7Z5(\h.2Y:auuug4y#0v,bխ̀<ワWM|ʹ[p,y;0TC	~#("Z	ai)z{K#u+t>"2J64/“
>:\qrKc~e~g7
8yD
}"AcueIU;fUdw={z
zGm.mWN:BP'zJB;ٙ̕;Ǜ|Fj=n%"}v/~S1wvߛ[0R(/p	i'[B:G%x؂1d=I돶=Qm'̯<{ҡ̻;D u
6v	^:v?FFBႤ+nhJ"Fp)R9Nm2uBh@Y,rSWwTM#1.1>
0S[ʳ0xHﯸEizpX0Uq2K2:.?m+Shk,=is[7.xDB􃵸&9'?XOnHEOm=3>&$䛆̀/+BQyT:9+hycQ|	O@Bя*iuy#]
YxM
'BwUX1\YrP3R_0~⵮rn}_atMeC@}h$H-X6^)A.Sp7N)wYlpMY]r'HOHkY#y!
5*Bx|~ͨ;;^Efl.ǟr[c&0(|Q'd<5x|ͥC+pfPnp"ZI]ZƘ&6J~G=iձSH@p}$|͓"H-q(\uר`86|$s7#
k,^
I,^N`J!{׽nFXi`>qk96儉n?AG4B~?d@yg\P񱴂sDg?5=ڦ\,zUVқY4t#U6erC*vqH(C6eWr@Hl/Y%:wՍRz</	3WmF.r1w:eo6Xup]5)FΓwG2^/N,9M
 (xd{S$=͘z*rdanOPyiknI&&і:o
üPNMr<	 ۋj-ejZAfFah	EFlOкY
}ы{`&$qx.'NY
Sw{E8&h>>/&843#
.P/4h&J$'xSxEJJ%t
'쯟'䫹D6qʈcJןFF}s^]h;2erȂ.͖!]O:z:oրc7xk-(X\; x	afXqoi31V PZ+/%3"pM,94e)v'95hti_[t$
z/mLoU596{0D Ki;RmjQ);;qvMT;cJX0COW]$fU`_fg-EATώ[@s6OXEͽ$Xw]ts7("G2MŚC'Wrљr,ժE
SsRR.Z_DEN?9J^n=Gw.3I`b
fKcBHSC>cOiy9rHʮ%Si~Vayd̐bP4p`OhCHd1a
V.{/_Dp[oq!}:JOK\ӝLSFnE_urVτ%@c'@]a'Y_'&)Qs-Rrٲ6"9RkEߴ}kgU
=h)bANѥ'"r/MmZ
T+ .VhL&h[Yq/b~#R?xg?Z!\r?0B$G#_x3xLvu%/t3-I+>qСЪͅ/Vkwf&~7j9*?pv!gi'_!ez،:и&&1ʥRy4HiD_Csx%_Tڦ<P0
/3nw&gk-~cBSMVv"c;6D׬1raVW;`#1-ng.L*U||c ,~}:J6`p	xnP9"Ňa~AvoYw"U{/pw&X
]f6=yX Da\oPJjw%Գ`ޙ;$
nͶ@	@'I}贇qI Z^W~E<[c`R%߼|jV;@T*i9,R5Kc̈́\黱J=L?1ӎ&(DīɕӊnP.KrFTCe+І#UQE/nFg8=hN,*h$TՂMyx"4(5O).ݣ#vn&l8>I3F	ڠF<+Y'qcٞvfO3:{g afC2w:?h..Gu nB,$
x[E;2JUITxK<*ˉ2͎lWn
0;ݓ*Ai8K˕ZXb
_Dmjy?/lOfS؆l003$C맽<_%bwmwO%
UÂ_D#:*9qےˡnb'/o5LkuňV}d@.1A=9'iR
hEՑJ	E[	[gCF7xp.u
ȠkQdbyΉV
JǏ-jVXCW2܆L$S{yTJA?Ca
.Joyӈ$8!\`I'2h&++
@pYgQYd		m-:xS i/.pz-JQ||?>k\,6ډP'tld~
X${9r&ˉᮂVႧͶ;i&lmؽ4~Zs4ʍ1-1:K.IZ6LTk6T)j'K]b01R@ރwLbX6gt/#R

;!(ʴiaB*_+Lѵ
vF{47Ӳ+E@-ޱMVhzs!`ż0`C-kw\P1<9IH\ƬBäY>IXuF^NfC$vA;

P!rvx20{i
ǣfdce\w:&ғ": f[_ĩ_a;l7ٌXz"føay,؀o20
rl164H<6"AY@=pÎYAmd{FgnKn<K{NFZlI4N~׍mTZK
8\^?e2+RW~#ʿzrhU?
MIӊjܨHƷ 
[<ƒ ]XL.)VV'ª]O'ºv}`*N3௭tT\Oq*IqJ7Z!4t+}*3=AbcSVodlBP,(~hǯl 2-v{
㟇7S(]k6_m[2N`*e=+8MNR]3R#"4IT,׏R'gil[zgR9}uԈ34NN?qSQOSMbq`GZ:Ҭnګ˽r;yTڨ,3uo;KMvTL\apxFkU.EC;ʵSK\wj7Qu}_qgccqxPQw(/P9WpfTq۳-2?u;/WYy$"Љ>nr{,e!s!9J7p.	 }g1267:xW	=d+8KKk-c~5ɴ1vķ>mz)lnZt.9uyBٚqeUXrlP֌{S422mUfYD7ńTCM(NlQbkĜî[m?&ԓg@NovAq6߂W4ȮwQo4[JWT{<;`mBŹ&Q*z`:m~ NOj@'a&`9\w
z$޶iXwi\&4ۛۭ`۰1l8Vb
*;5mq+X./d+@HsiQV1GJҬ?K1xJ<#yx|7ڡf$ڍ:t"\d؟tT&W!B-:KnRgP|-ȴ$"oڜ>ʎپ.*Ȱ+>>puL!|b
6fŶ/)ygcEH!^>&%mfz
]|MiU/ц
|
GgVڀ귵ЅLݍ>_A@b?Y"FUw#ԚyL;_'i9S\@z!Ѕdʕ=T9l&k%Wз"}ȭ.zX(-ZgBC3H>CsJsdOwO@3-_ߐtϊC;Q#rLHͻ.@v2NԖo-rǽc!xpѡ'D6V$b"#tX#,FORMkDDJVUINFO
XINCLmemo-tools0026.djbzSjbza\nvQG:`lM
4	z5hF`8j\e@(?
p׵N=t8n>:gTE5kl$a`1ƹ.HcD>1-3FvG`O넽?Zq~XU/{h,^qSX]ᑨQ%p	^ncsywwuZP:J/qo7gCdڷadf_B=PW~|[&DT7!WTlS֙bvR3Voj9zrوH
|h՘
+!9mYnۇS"3fۧr3;t-L^SQ2)=ar2̯ʖPEUN|闭K:?La#FI!ww&<$|`{po
~9q-[.ܩAz-TfZ4s7ic˱DMHmWalNovJr i;QŎ
?!SWtu@&vKϾMc΁ɨ)
υ<6=^bv$][ŧ?+ՔdǚT &y/nj,vcD.ee|~E"d^Gjޕ/WM`({!Y}GAqO@Ne+{ŏy!uZBǘdĢ)]ŽToJ"kSX(ў#[ЀոuHl+`#ڽ5(PzQCӦc?U=y/W"Y*ȀX(1!HmG3-IAH+Ey>f]^C!՟Cc0swoςǔlY)҆]pI[f>+wjv!ƴc%Kcչf8C]8;PEwT@eNFJ87R_f#_[tBWI{lV~r#^zGtN}. C[h!p
{S^KmM.߳n.ⲎOC5l}ϰgR3~e^dFhCrxDp(_>ݥըe0_.S? 
#Gׇ	as+OLڌArSЯ@œ3CDrч*gBk[Vb<^ZYCׁ3F'\.F%<:LgTkZ?*g"J%N#i[m*o"zNҨbc%U*5f"(B&jܸ"jaA`if7սhb-#ZR@Y)T	h5|lȐH&^jvヴ:1Lŝ9(g6N7VY)cN&a8C|S;WZnW[0
xRxVAz"!bFL%KئːM!Rw1D8`c!y<@ݐ	3'3L\E|/(0,/Y~)LŠ&td@`Z;i<i%!d'=uÎH"F&EQYs9=b[oy/{X72dPӅk7wQ.eA!20w;qr{ւLN-~$6dfZf~.gU1wyo{@
5tԒH\z=E`!X[8xLeVVEX=o=zi+|G-h2A~xoR(ZkkjݟGo.%rafCl@cՓЛߥ 
xh('+@
DD>Tq.XO!D<c
]CN;OB>QJllO?+v5aȎ7?aaH'KarPX>qʤAz_33Wx,HHu.({nQ>kY`Vz|/#׶=K~i'"fib9EJ}"	&DQt"m
G~ϧV|L1&dEdM`b^T6?^Y^Uo:Ofi//ѳ&ӏ&F
JF<吧`Dic8fD׮@E'hJƋh8vF.m
Xb1ċw+ 
,	ɐH,,1ߩ;.nL}+}Kxs/s%U'$+CRsNEӡ5ǖg`
q%O@zUxpsTm
;h5BY_j,/j	> ~1AɥDd׭^-2kkz8:ee4?YuaMd61{%[
I؜{#
/bQ~ʺ5?ש״6'`JWF!$qh<_g^-ڍZ_
R<ϒYq+	XaоJ0?H:H81|jz^'SuԍX}{f\5aDE>]
'VF`DEǗtU$h]sM:ylHt-9')Go}l5]v"tFA4_Ua>l[$C|uVT*a]k~,l3:<
V=bH
3e%Z!|	yqĩ#t$+^K6㟁ĮYkKzE6yBem}!??4d.h2mj;)v^Xא0jIUWR$'AFa"/'?U']Apr;\7|K9},V"s1=x3޵
N;zqt*~7
dKb;>o!'8Be.z߼ؿZX'dNib2@̨0
|b`.;/!d{Kzjm\^"eEk†FiU:z-_\>.&C=&5@,a$;ĠfTO.K̷7SaGzIbSPr2U_0Z,ewҝlwPR:WHLVw-0)X1 UJl8_/(_UJ)J^UH5*MwsbI`V]CO*,?<欦
QTo
1+yw΄~47h:E~YߚhPٱ;jk~I>Vk8~BZz'>E+|7KGƥ-s[om
UWQt@P,CA׉'׶lVbhďCJ[\(g`"a}KԋT`e(**4{Zݶަ/;A葨zTyY6]iWEM*6VmOƺLEJtx:$\P(@1k<כ-
RF@B[mj=0iͤ|nxAK	WB?:]XeG=0taj5/;xQ{2u(?q@cVVˬ#*ԇ>RrA۰N_a?4
;c4G,m>ƥЪQJ=op6 J}tauq>A"yjV.pX,
YgsP")d1=EHf*JMlz=AoBsUUX6+cZqHHԅYZUقKgyn~ɖ-p;ԭhIUɂ>KhsRi?KzRASd-k{#n+mdVS
V;1[l8*׎B0=XP|3R
aҖtx}L-koيO<64ր[jUI|\wy_IהˮիZe?LIfeSti`.~=2sqS$wVwiR>u}H'φ0CS@\ayh`Q.#bNa
x
hHR+1`KC6|
|MhAPJ3O,P7N@b+AT܁hA%	&JrB^yu !iNMXl{2.R3I(%զ@u8	\.k[^h7͵DDC8G\5!u~qG ˭ĊLJ"9Q(	;~g`|{cb^
FJϐѦk3M	cfX"Y=ͳvU<
g͚Mˎzz`Y;pwMָhPZY/$n[$e;x2d./	rjuדKzÒ:/r,k:Hɂyk1+/;^&oh8.jLB+0I\&<_BI0=LT)Liu#<
j9`pBb~C߶}5%|Ç7Qit#(H9?!en"yA	v@QOFRpx.5;c_?)$^5$w=^|5zԽ}11ER"o5j1}?˟ؖ 4魥]Tӭo3%Z_4A(5*60Xaw3c@&Epf]-pklsAugdX"J?\=X>ljh\JFzAv.^=De=Նe/G{ tn$ۏ∑ 뭗izTyᬞc6x$rDN?M
}s2s-Gjt=H,l,91oA
'h݆

\"CY@sqxђkAV`Az*E(ߺ?Oc<_{	kTYaYԹs)}IMET#rϜoz91.ӏ&z
^! naYBL\73R=yUw9jYɽ>>z7v?Ӫ%1#BKrBe;3X`	vJ^18dIX2UE+saZzVcT~#FuQ#^l hS0pYScurqö
Vb	rf;_cz^jdw&K)ŹFAi{b\iHVTjֻrKnSu83&,=,id-eS֝
}hۚ_rNd[+LZs8dG#p]
pȼl]]z
wJ}=#2k/$F#f=&}XOCphXCހ*X]\|e1/}_tpRIBz4HEud~j_'15%sMa8o*+G\eegYDM=G:#
n_j_D4]tGᠸ[q̼Sy#`yt	REsDӒ]3RHv8biHU%L}ok:-	;J=A`7;:akV.8Tb*%@DZQ/oq?pvB5JF{+QP8G(6޿R;nUA_	r}@赲4lUpe_|Jt_JR>*Cز%AJ&>{Ysܸގ**fܰZ1Vՠq1'gdoA«;4QR$*+wzxI'FxδI痳b>a%f[euQXQ1-I 
8%3‡[
$9vѯ`dYȘԈYS´03SeτSͶƯh5}>_4U"$~c22$d՜6#I/tMIe(3N3*7t[)_2,/FHFCB۠_Y꧐UJZb.y4Kvlt:eûDE.0gY(3⓮:H-q)].G{Ѣ9]y7,D.n
`_L,[g7XUgq@f¿=:
}_#ƻ[hYqq4$^?e;N9)(dj&)t?0$XhC/9";['o<G|O~\udx)!hyWV%nG|e%q	6o:E ~_4|}6F8pf~?sA̤lepQT%
H?|ly)5cswӁpb+4z/poWi?֙FNJxEkCMX`=]7]7իbg<"lךCLv7j)Vسpt
To' vڸ߂##c1ŰP!e,QTU"|d+ow
Nv<27ܩ/OV/fq?\v.p9`$J47$5d8)vf>2O\H)CU=Cl_~;*qH;tm(7y>sDDZ lBPf2\I>JfH$A=Sr0jlfgv%4e@`3KoY(.BRo`aĉ>^9Dg:O^ߞ))oHbnS5A^@/0zf0i\C7~m#e*ΰVylP3^O6vs͉!񛅯Ҝ6j!/ߐezsM^t-ӊdOyk)ǵMQ8nd92LU6U
bf=n"O!9,56lC%Rs`JdjMH/es?b=C\~5/eƥUIδV6sf|YSVneo^"o_hTp-2͍He&-*qxFf
5h(n,ޓ7w%[Te]7/I{Wo	gh6Sr$1݆7&ʽZ}STvb-}w
RQ̓(]#-UI=>ILRx* Ě`xsvIX#m-!xb٧.
kSI#Fh ϝd_/fbg#5OV+,hX+pbK-	cvp
	ę_9BXTIEhfR.e?mf/4c5<(7^J.0֊@aFOek@pvn	\CDzEd!uӃ$},w#”WB05ATnkaVvG2<}7XH$1a#i7
U]=6jW-l[2hӳc4d0=s^oW6]i	voF!Q)lNMACjɂrMa1{F}lAr[igiV@M8"IR+1^Uy `\r*ڜSBP	7K|3j44wʅA_s_6YcI6~JLD^hVzp[oo>Drxgþn~ln1y/A;/;d~]ɓcܽ9UXn%y@5*a9TϯTIy\S'Gy$ߟmW{%r^DM3Z-~t۶UKo¤a\uwqޘU2?&"~!~QSmк6oyYXH K%/lZ0k)eWddW8]i$\8b*K\0Xe(,^jghqqYKk$.MgX\DhAb\U+
m <Kaܪfy'&ǯ4J+4;
ؐwmBV_u3.ta~a.oof|^&!)7y4nvDt恄t蝹Wbzg~R0==9~XgPW}6gtf|TJԤ:@Oʝ_M1|*"υL}cG_G3.ip%\[_c[.QըψHDUz!XЛ+ZyCWxBv͘Vt$F^*ZɮFtoyFĚ.EeH$*aTnN	&[G2eFlep;tm:qiʄl
A1l3FK>R|'PfܩL•.tT<T}'s17#MYeҖ#1b:6V+K?_BkQ}k}-#vM5m-\TIV+o׬
TKm@ߎSQgG5GbGI}MU䯳WwT5XBiXIEuVN0uOXzG;<^'ֹ>Ļh%E2l˟*v_┌k-ɏ8&n@:1EʣN1-"	c>MS{_yd79"%INXXXZ9ѬΏ5!$TAOsw.$e[]SckSY!=1C*,sl`(Jzktt7"V 5?
5j.ixi
[͠yJ&EKg8[&bNf+;_Ҭ,E×U᭶ NG(Dz8t2hJ
o%Cgln0+4}4&1/p;33*CPε:};{unVQ)x!L.ӧ&1+SHsIiIV"6V@^fNojZPa~'jf!~H<SٜA2 ̹=&z߸Zgk0w&~h:a Y-510\SL"B9
J?ֵbzLqX[ULlc.LFah]Vyd6,-wcoXzawuEfn|2ys }3/Fd%O(߀z	SkEM7!C,9B,`_gg=%?
4@79 Y@"qYA!:-|wEB9(=rEaYG`.-ҟ&7IuoFQ-I٩rkKQpFwBs]Pxt;[oC+gn~<*k^8n~{`9~beSi9F
V@*lH:N`>ʳDk_͖|@x3$HAҸL 'aQ'm^_lhrdu"yY]_q‹huѯ`m׾vdfyQmi䣳dp3ITn;H۟;hapUCBq,Kd{
I#SE$S_g2
cI͑(Զht)"q0g8ř[m}ɇy<%i/0o5O*4+&MŊ'_xS
M]VG4W=4W>sXK}~8$qYZBo
MpÜxR	̫i(нpF|T"P{Xl	m+rhŧ
U[[9vЙDf%pr}R)m1_ܹo-СHY]F_Hw:td是nƿ˹E]:Grܻڪ&ddoѡ~"DNJ@368
v7\	/oA&s7y9iml	}85&8@J2OL5*#X艋(^@?/sptY=9S0"=-B$񀉗iw1=c⡉0evljo6=5*Tv%>=Zcr;AYXϥiS |  P@aI xՓTEf@M.u]e̋0[L®l7@'0q"y֠ȣD5,oWd#5폤n
	SDZxtzm'AZ .ypܫuCڍ$KYwi@u:]Ir],ŝ;Zp@a_~P1L^@J#P!֖(KfVFߏzev&D9k<p
CȍƮd)+͙ٜ&jK|1;|pnFqi;s&k7RmgyU!
sMv錅qQFF1s[7FI~{c@\vб̼o~4:[{ˌNV
(sPZdr5Iᵞg]=,1\Shd򻉍A[<_t';!#@M
r9jY;5Pwxסz\tOsеv"zfuՑX~)n⇽4ݬsӜuT#)Efd,Yj5ҦS ugZ3
,i܄
J	1ty>G^Dl"oi_Z"J쎕g?mFKAAU#GwOrf>s4OVא,`XPO8ʥ1	vQԸrBjtTc'NK2'pNqX{.CVMssw녢c+$K|Y"֦,pM:j3/4z0\m.t:c}]O
C\yzM$4B8o^#)\Y\ǃv|<^RE'
%h߻Rh;]'fQ)6܂RYx`9ymK͘ICl!%)m"bVJ;3+	m޳"@9T*Mܹ9KLR
>|$u)GkhkC^z?MNUԽ·y*7nt?tzʸI*s9sa5l-ʛ#2	oSa$F`o
8d	N^S.T߇!w\Rh)uv?'͵JaPÔ5F-Ԥrh&wk*CV;sOQ!9)53	Qdg0-ܒ|Z3WSٴSyJlP>[C=	=ȸ߬ǻ\Ń#SSs:dI3@(8^lEwɐ5Phy'p/S;8
FixyT ̕>	Ldsu!N
o"-FtJ2g&4NDy4a'Ṟjkr~=]NʚXCjPwfs8=UMJ`Ptj[iCקR5<(h&~-\`ҁN1)7Kw`("*ZiMfjV<58t\D؃b@%n2\f7͌&
\b}u8JiMI-M@P2e#ʼn{d@8
['*pFxw*)u+;
z
G MԊR.DbDrk[1h!Q(~U:2L#
 .
Q"Plu}[0T%oJYKӂބ^uQoʳ"<6wiĉؘ0:}חDtp	+ۅȜs0D{lAe(5D0ʫdrػA$ָ_LAZ|ɬ,.@P
(F7K^x;wrg j-J}k];iX8L${ٞEJC#.O^4'+ӂyHGѯGO[Ky:x#*%z9(TmZ֘ؓ9E})!Ƒz,L
#%'|A߀uKPX!s

vVK7(<4]ޢ%sJTtgLm
7-CnͰRA<7VKBv)Lg@caJ˱".2P}1x`)qA;$[']Q뤳18yxo?e *D7PuLR@┋,;>3v)pf,I_<4Ft;¥k5z1{ZN*j-yx$48Q{])H/5Ҫ0YWՂT
Hq,"]Ŷ+ft
>`oo+ڴ<,\M3*1v__bd&@+ixy8n8A׺L/i1yJg@\sz6l@!:,<Yt#XIz>Or'4\^la{oΞgGwDRsў3rߗF
0 
$p]vpY+Brڧ@z
7tcq١"kw'	0A;˥E[&p6IOwEL7PR> tԆ0&flԘDE?K$By*CEwp{#ZUP)
&+pk]yGwBj*]P?3Tr'-?q(h3B;"Ñ[.JF%+"MwzZ(.;
*^%8(h*d-i]wZ˞?Ey;9u8$
	[!;yJ*eǼ/\gb$nuV{QX/5#C"E~v#
~mq_g	)h
R!7T@9:PRLt(& 6HJ[ۓi'CI6yYҿΤQ3cR~*]f!v0{O2Y_
<
xj2ｈSnJ?*zFዚ%P&l/)e"u1p:RNʀXK,27aMv/ؑMEu4rRF	'^[G-	3~+
@`W,FRjePwvoc7Q5_5v^qba3e`x#:hE
i3wp~.&g-[d0i[h*?rZxjG|BR@5Iy1jj4>䞐v#LR}7z1٧G\:7yli/(jbh349pJ&-Pm>ީuUTXTz	fHRTXDyeI>ͲAѣŜ@HrS )FgV}`Qt!=V|wƞEsD
Uۛb	&9RGr(8@_&\Oj!1as;fEYoJ6书]-=jh5Ps1+BazxD ]Oɼ%KBy6{Ԝ:aOWXƶ'~_'7KPAI?tH7D<t9wI)F.:S>S3;9WC'>mA
-U9',d}h{}nD)Fn=$ny(4d%SIy*8F|d{(7$G\d9?AwSdI ߻p-
"qlfSV\X};I{5@BRAN)c9Y4{f/sSh~2E5d||,bnpخ)v<,0
vD1;8[|+I[uqjڬ}
g@G7%wƃ\UFfܞ3oNgNvH&/J㳷1tJ /u?=ATmJɃ2q	Z],vT] _i~~M}	ĔMrΚ_Fp"-a=4>Rx3)Qx}#qxA:ʢ/_ng,DqC iEi
sѿh5[qæaH5k6:+sM#=A	`
6Ifu
^׷j(>ϭi|c|kZZ)j|9c@?KzЯAxԃuC;щ76IR&2sU
b@f~3kE2ݚ(-\BڷۂŒbv.~"V=Z-F#{5\읨~i͋;n'9lltM&$R^lF=]Rv&,+J~ZR6Vw,jqA4?FH'޺3,D3t*-wr GRE<"?_l,QzS	qʏ9#$En%IG
	}f֖)*Y)~g~AɿMFZb:s75PɞAUװ*Z\"v/%!k~_-1 KY#IކBq@LHxs	P3at9I|mL]1B	,
~krٴDžs;|A6?7jd[T[/2eW_Ayg‡kVe$Q8@l8(ɽY#&d1[NA>Jr$1>Ggx<orwd0}QQts^s>B뼃`S,Oj{bW|B^}d|yyPqF3St  =?pRtG*2WI[xEu:6I՜tz}+$ `UBecb˧X1.#j7qU2iGxqDF%1d؆.ij %nB(M\yðQ-=&dc"(BYO+E}ќ,L|7cNPw
ӟկR(\O	%+i64ʓ#^wGP,A[U7PB;aܬ%xbG[}#xvxC@Eu8
\@[Yײ,I%Ո&8Xe<`fUXB89w}Kh?2&]_!X.<RG+3
=P3J&mm`X6A.Obj'`>K?X#y^	t4fOϢ<6?FORM7DJVUINFO
XINCLmemo-tools0026.djbzSjbz1nvQY"8X~	+\BJN-˚}]BʵkD}QI#[H)J-K7OʮLpW(qo|VʡNN9%0
_+KœWj1yn{>iGI#KMK+C1^(#"a4c5 R2s*'n_Z*6I>N%pHfw`L'{HLt.o?$Ḛ}{iwnsg#GǮ
,9?eޭPmN`|H]%ub:2YJA1		9P K|Po}IH:T+xOwwMwx-E}ΆcI|Bs}7rIVESh99WnLEՆ;G%҃5TQ5T;Y`=9E@@{\z])>Tb蹝PS3m=?x27kS_1;1e*uiSlx@ȗPsGV]+[۪-I>ܘ1L+YEHҬf~l4tw6@imY6J%\*a7śqp`~{+@cƳ%u<
׼c
nV_Ivv0,d(,QaKEnǶϊ$v	-(! #OZ)eIvʝ՟@?
D*zq͌U1^"Er .V#Jl/UI}:H0+yw|d]Sr烦N*v|]M
q(7AK[%[캥hEFtHMU>GUi%KXolf:C?v΁Tį>:DKs%s6)g1sd98_G4Bsq;a $]_&4R7AFHnect&H|F[*哥SU6\J;ȉL'~)wUG
}WD"jvv㺌DcQ11W??2"5*mJFuSX뫼i~I66N:-{(A͍*Y\te[Q펾'":`ZJ`%Q/Y:|uh<0rv_yR,rJJUяY*hvZ-vTT>M$Y0
lѵye2cJ|E!ˣm8{pDz84=suJW`.	FIu`[YEe!+'R3	vd5gQ@*R{5
$q82HhWV?贍s5UbI!s}!+?a0B8(q>4Z|=ݮOuj4?$a#}
CB_^Udj͍E8L7Ua9k\	PNQ]Bt2uiH*
FnPe94eo37b/j$M%B"h1aw^?w"jTn0[഑lrAiu8_k%/ʜ5v4?ފ(|'@,§-^[\lc:M-K:jI e	d*\=P|PV),ts23	اDc~*hv$Z"8Z	}ف+>gyfщ
CFjk\\()M3˚BCȅ%o؞0|cM/3@ܡc#Fưp{:Y,Ov&wz>wQ;Bw
D)҆sien7ΐuqQ.(f#-Я"8okhk e)qpkO'"z[sz0usH4$X7GZ	*ɱ#ul~AvWWWquK"ưO='ŚB)tC1/#qX7E'>ֿ^퓯fg*N?	}
PKQRd2W9"|&Ԯ,~Ȭ)&MHAh1})md(Geskߐ(nC9:D63\q)7&V3v`k)_pFQUԹv67.rbvlT?Oº{qxS5|WhjucOh*aj_ŷyx|y2R(B
ÈƳzet!gx"Ażr$u>Jm+@YL&lE`J<ϴmPnI]w2C}{H¶+˩H8ߺb<T.VE?sv< ph!&jHΌ7DyJK#Cj"
U(B"͙+Am
bןD[z"Zȴh剿Y}Ykn
t>9b~ЫRH^$RQ]!4*Jkz[a6o^1;ӐA3.D,lJO}aZw&55n뻣2I
nh9=	42do#&%UjqtOwz㋓9'Hu?v8)ŋ-e4
2U?Ī|KA~h|y!@t9?oH_owl#Ŏ4T=#'1 #O
hK5*iVǹKp(R^r1YT5i<`TO^=VW>b.d?b5qhPqXsT5tˁǘz,%9 JU<:>)jNJUᗼXm"I
O3d_7i %6N֒-	j^if2T(džxZ9϶AO8g{|vм\n{ο\gDM>œZxOߋwUCڕFkуnmњSLXlOdqYN9I'dubCpk)OKk:kZ~~ʽQ`!AOO{@c4zR_#Rp9GV/#kZeeLpΪx
.QiЙq/c.nRϖyEtŲk"D46 kXV[
`Z5xFv,/p:urgSؖ1FGP>y(x"?I
_0k&Ͽg5us;+>mxwrd[DTP/&v[3\P^o,@F܈V~&@b1>+:D6M<FaZv][rS5G
Md|~wܢ֖֗QV=rmLC(D品n6PĺrCf3˛d]L?c;xâdgn:
~/*vzؐFԋ=7VєP5Al:vcki`e1~%@4Wrib7xR8Vj`"ٝr
DBhga)d`_´'('>sd{ArgtzMb֜?aq{_$Ѧ,ɸcV/BZAn-BCwο0Q,pP\Q
/8܏I8xeQGA!8fCɤgBNWh}_xĚE'IYy"0
PwM.b$]с%G:fuDIbOvhvR{#i._M􊈄
:%9R
T:WE/,mn2^q<\m22%{yDWċbEwrkt\2掭oE!D(v"v j&}
-f}nY1*]ȉ:#LnL*5^Ꞩ2D
d=Q+=D]}R{zY4_u>US~v'Q	Jʻ.[q(|N|yJ2ݎ:f4a%ol)|PL"Q<4訫b1<
ts|THGo̵eh7Jڞrԩ<JyEoXUEᡯ|jA,{cLx${iԒ(T!Xw뤾dJ<Xj쨣2*vbBfT–RjGTrx}N$fŔnq=e3+/Ģ6f8ibchY)Lf4S]x&cey
;}~!QCOP̜؅;e~xc=GV9	`Yc	vDxs(
MǦʑƿ^U|rc2P>_{Bm0U\zj@VK0XWfbH?0Sw+4o&/{b׬1gPj>s8}jXwt/KE$5V w^?a"ϑՅWMNн"=(
!Xa} dic*7C9;c HƅsxZQF?L2Om;n՗e)
y3~@g}^2i;`~M.`Ljy.;}R[6z2Uzu):7i_Y
3~({dLO
5o~*^+v2>\5C+i	CDFPrtN*c扴:0 Ph
Y9e
ہ/Hscrt
O\|\~RZ͘\by:ꖮ5bsɎWf;4ٮOTLbAP\aL3gjIa\A%NNh4>~_WU'yG0D9Y]^c+AUEJGErTg:}{YQ)*"fDf_$OLy.)x`5D8Ĺ2it9p},ss|ޠY5g[c.{NPH.bqO}w><8ȅ	+NwJfR,70ڵj%2mA>=1	[Ge@b<fܜEstYH#xLV%oE'q(H"x;!֢'[`'&4c!kegI'5t-c'̌XGlX4knH軏u(DM^(urPWC4=쿶xD cmڻo~{
5b!	DV5[j4YTF
IjdDN1ڱ(yB=,>!([/RnD>|t;z
Jf%N̵R7b(щF(rrpo*b5:TY_j:ܺh{I9JԏݿŕsXSwW]Oh:Loΐacũ`cbZ~JP^0̤QJԥltBw
L3_%cnU癞׷W!]N/XuP%"qc:@burטYa2̥ӡw'T.o|ڿـesZFVI=Ex}XIy]?#Uze-+->AT"1ݼ~4IrA jשoz0C:Qr|.0D!lz%GB֞ͷS5+H_n&ANs 9]̀@ה}	k7,3yb'0|orY #M^{3x4yjIݮ?pH:P؄UQ˲ebb75X_R9k)C([+f2ޗLft=iyz6ncm>
U;F`3|±	ên~m@Z݅k_:f{v[7{Oڠ8mQ2' "TyIK+:,ceRɅ	s$0~n~bK pcH@pb]SaGӰD>JY.;'WaF`6t~W1Z5*jcǚI3t&a!
rKV8a{1
rzNztWd3ÊU9o%UyNnCdt[m@ 0H254J/oo-q@ͳ=@?oE2 B"WCaZʐxr&a}:tmrs]mv_]FT4۸&{w%l
<bJo"}!4Mί'HLOc5qsα̬J(]nlvRy^`pKۀjhȦbg8a>}}GgF&L%% QqȻldGNqd?W_Ղ閣t\}ev;@ęn!\S3"0d4$lz^>)j8aw3*é=dNwt;\$zE5,v(zU,(-5~U۞8
$;fZR"UtHoIr[cNǮ("IOprȓgEyb-+;e
=/AX^yXT8($@%N$$je̝bХ\k&^6jӐX/^F|kBd~~	,bWͦ;g^7';\s*  B=ٸUI7J&
;?Jvx10Ӎ
W«4LԬPӔl!b@XkTl=H.1+lL2,S慴[vt\
a|wW5v
eԺK`ִcN3U.nCdQa>[6!1jH@7nܖmT6!}şq;Fvr3iR[8.!nūhAn	v^˷NuJ&u}E(8c!5/Pߏ?97Gⷣ$X58+&}m_eDРi@ܯܙL])X
o#:!cΥaH,M=8M۴y8xF!WQ~]J7LUZWFf+5O>_NV?l˪©N2Rxt2GHxڧ;u"-}+t{絞{Ew(ɗ>}`l{:aL[XķڌdjG5ƿJ^+d߉jp/ACzlڹTq,-.vs ɃU=dZϖذN]'_&ЈvNd{W]
s5^Hjm#b*([*>-kwܺdWYR#yVD\+!-()YOQO+_HY>4ݡܨMcZG%BkA!I̡/D8QN
=NJAR|6`Ypnfki34,@FkvKzDzL- edrM^z%8e`g.'-oYEBt#kjmק&GWH&;5I79Y8mm"ɀ3`ovm<ʌ1e	sX|zoke#oQE7F /3$ZYy?^gvV0Wڰ!?
4/ye01j6Gw
m盄E\_h/p}kv1^2BP0\}d\cNyno갗y>"xJY"m-vmg QPI>fn}uQ}ɵ	EM{uښG9@_`[UKn<n9v>ܢq3I+BnV|G4	YyA?HY2 *N	'_v3`ݷWbcYT`7Pa_֑eAEzךO -pED;]o59#AP!ď2I!,Dbb#:
&mɵO(T>~gJ#T^cϾK
i.=I"45mdtM&/PHo3H|	gJZ;rn[+V{WRƧ.h*.NMh2chO)@ ?qƧl%R5se3~5`pj{7/ETT$ʾe$V)yQx.a7vlk{:٠8cv墜TXTzHJtB"ZQ6`2q*;_AÒZkIdA\E//?iW|mk=戞Pg
!a/n]٩{F[qprQru#9un1IRơ:o͛b6;ʩTM??15~!Lm^u6/00,k`v5C>NrRLM7]JeJ$dJr!Uoc'*"X,$-,x;Qa;jwMϱgfJFRox8aujzbń*xT~O!zH35{JbS⠡oqaC}ՖZ*^.FnwQLKl7J%ab׀vwrڪ.mcȍ*fKÌ(ZyFK$z򞣚Ga]{ˡjy1&$?T?	^$;I!qSVڵۃu!QgZ5I)YLO.aݘ0',aCAPI'zM=	9=D-RTk+,r&7CnF!PC-N#R>yzWO.|ٮ|ͅ^Tב	=SE=߳,SO	U˪;-m.JYS[BmLgwu-#UyK6ueG9zmypf?Ė%Ӂ=My0R/,bJ-ӰubsػV$\N&_#X!B%,Y<{wL
_!侁y)dIMdys򲪯ad)ea_K8h
#PF^\$q]CzGl0[$/9_jW{`ѨwGfϹ!&Kp
1D3frO>se@dEs:^~V2e7M?,1䁀~ֆ=vZѲ9P)2k/hYD0K)kRdDi
vI3.UKbe^&/[}muG$b#U+f~KESZ^yq=0tot1%Y|o"7YNh<$"韐;K&{
=qId^PFiQOEˋ^)lV>m
ptTL1x
oIIKn8m`/* 'Р4CTu=bFORM@JDJVUINFO
XINCLmemo-tools0026.djbzSjbz8nvQG8DiA=3Fb]lZܟjzV

2~|Pŷ9~H+0^Te}N38 zHP:mzl_c|	mV>EA-Kd*j[0/S%iJ1+4_E@k>N`6]D?GixĹ"@qs䗲bG8uA~.(aNi71G*ȊM3;fWYCBh]2Nĥ?kvd*QIAHX~CAq7f'Ak sxt @M<[S]Nr<95mja(t+p~K׋ȹ4M!&-KB%IeCM
O=a/
̥,m4<郡ٗ8Eb.C`iK|{t	K^ӴTi/oyiy-i-
glmp?^uu5z{=ygl3{Rj3u;Vkdž=..<$`p([\;H}Ts|%qTAsc\`cHwߑ$m5$aLq4%ow
z.SUИbo_sxo3ȂTLq\N
s[v:FU!
;%ϡLk^fYSoS{
D"@ o5]R*a<;
Ml:̄ZU!:Gm}U4'cM"+~VnӨ
+ӣ4d/¿apFVoЎUo4dkG&uy7v_h0jQ#hhV{nfӍ+֋XcPɷQy9[`"+fosD|n>;SԘ?闛̅C#l8Qpg5|֠0}ZWҳTLAGq
i^Q;q}%W/eaq''Tb뫪t oyYX0BFN͑4 q}m{
AIkLO}c;+x]Ҕ2%gO'W4b}W]u@ڕ˿aI7<6wukW@)ep|]`=%}	9-,-b G8hnxToQ"GշAmʌJeh"7?8(Qx۶7TLsH`NADm_kdg"qTB$_nbe|ϒXOSž@ 3SˋRgF7Qq¶DI%^0/>M2~r[w#iohb58H%jZG3',6eD$H{ƒgrWNhQn$1p]DؖKX)
;K:
4puI颎#toͼ'}͇5%sYQiK'#kVZ/(~&bĖ0/b&k8D[Bz"CwN0!+R
@c7Yhe3ñ;J)n%$^HHVVkݽEC\lCA{Nnsa5(
~Uw1	&%auURw0Bݖk>;G3n	`C?DiL

}~2KDC)p5rf*/IEz
9N<@`_:&BXϔAED$]sl=˻Md:GFt4Mbؚ6$GS_֪u(
15'r~$+ZĜuxFDr&Gj	-FML|N(PDΔ$w+
N9tSH*8GO‹Wˇn	U)na+}EꩩsCA{iau#O)'SӇ$ƒ*45!!NxIr^<

|EZj0ϢEL`(w{ǴnIG 2+ 9}|].g9)Ơ׷³QF+x
ϲ`T>SިDN+@GZ^^tGczlW\!~vȂKtz?9i4âS(0MGF%33OJ|<ܭݶ*YB&/8E"=h`D7h
?ݢI;$l9;IW/T(EJKVq˝FJr<moHG
En!󉜣4}\O”jOZ?+ae:pt:y
xQ%yCqLN]|}![?_٘[Iҏ֥p[g!݆0ŽD8w_ hHVgvĀM™ʆFR=$2К$6<3%jJIRW?7 `7~\nĪe/~B)SE9=A"eVB\.y2ϰ3E-o+sbX化+IKUT%g+e*Q(F:=]7	UEn8)HM.̧{1
񵷇Y};PO(1c\ҳLnM:!r@͋YǢr%Ey5>+Q7HW`7wiAߥ?CrK1F+ްn(y@IZ3l9G͈qftNp@ѓT"ߒ"U,bRx?:KgSrí8M-v0O0Sӵ&~or9>v%A~]¥42*W9!5tCzئ=Y+zYj%%-,u2>L5s~31l.N9Ng1~ѓA/(;+YJO`l [S
_+EwJKl@\@ڕp՜.<0bq8w8[tEgSiuuyxc{0-9+ZxI{4o2IejTOR3Iw%fUn7$p2S e_rQXrp(k`џÄ5B%СM.4%F#5soU͇7w\@}z`@mPl/tv41KJ+4;Rtfe@۝wGe^8-,(/k_Rnhq!s,KDh2AsgRr)//;PK_3K)*tKR̂Xf?N?|IYJ$eaӡHGH°ѐràI٬m5o/̚"$r{,[Jn!WM!֢% rfC^7"KY(sb|4^q?3SJS"Ig]?VY#810:7( 
=y9m\Vg;+Qh/7E.`ʧ/F /B111=5(h19]n\/O*5]s"Fp|&0*
^nXH0YctWVߡglf5csFAgwU9u@Y[20Z\×2b;l|*&nC.hu!y^7EήgW>4FpJ
NZ)b}ab*8Ю!<[9MU!tBZ闳¡N<_蜡4FY`>t#zOۆt+\d)F{C߅xD6M,o'WG[T]51B=2x>(h8	!χ{7N'xq!GI=BRH!80#P'Y۩e'6&^Lase]Mn*D\5ȇ-:6Ö.O?X,s~ʬBuD㚅4IO@%5UZn)@e=4T9
':j}9dOxږOwU%iL>r.԰mu/CL*ֳ~ SJQƬ!٬2RՌDd'3νzbuHH&φ]Z!p
nq͐(+9twj:]iX.K0ذYKO]m	
5oOH%1p-F:Qy瑧YR38.8("lZ:H/j(O,X8hs=/&l+B+EʆEy ,BcJ+Į4*~
}r&n7WH͏N#ܻxfdž'F:
ZzxK!qF0ou[
iS0[H{kВ"rF)#
]xRivsQIF9*Ps2PUb»{oj<$h{n.B{ppVYE_dv0kigsw0`7{t|Zq*Fg"WDo&VgU`j]R񈴨;TDCCU 6IlO0Y5U2s`BCK`b]+VJ00<Xk|=fd!W`i+*X8G#˫=AٳQ-C(D_I(C>sʔh7؛{B 9	3q.f<|EzPXnGGnGgNvCmcc[𗚚rUElY'e@hi87*ob& ٨"gMy頭X QJ
UG'
$PVN%i%8aڽP,t?{kP:)SBHȉ$a,|oAϿuQ	_;o;_	1
=3Jp\1ټ

 iL6,Yn<0c9D+?ֳ;M6#ms34LbxJmLacZ#ߢ.4Wi`u*Yȟ1_m.T`z6Tvsu$ct&p
MD\^ZkԭDž\ۖYߴׄx@6'ԪȊjV_>gjTk2q~#<-@x`-;]E{lKIe%=>|ed}6"MFnո2`;.ԧ_Rh4+d6e8wX
hދEq==SMTpI-I0b8Ԧ=)m-ױ@oJ'g 3_rŶGu&G%̝Wu.&S'];@蒧hGƋ+jQM:fdC>KDa#NwhNfwtsUZs
	bg}f==gl
1Hy̥2{
d``Rk'NgHC>dܿcԘ^E}(\M䧰*e1]_W~FK5iȫ~0%,2ը\VM b)]5\Iw<%V=aiz[S*Et\`?M1;6yո
e'^-^5Vmon@ǚ<~~qdC'|m5wR CwJã{'4A2{p%̄GUDA_=wm/Dl[ OCx
-(u>wEttM-I\ys<8Om%QFDF\GrC5EpW?F'$n)T-&m2i(PW1Ͼ61&dMȨӹU?1n琿CnUrQ–8Xrq+ޣգq̻F+#J;+V-iw4K9vft	Ul%-:upIDQiw%c,&}5a>=03'P$_Kp^|f)p7JxHv&
nf`%kR]=GoyR$m|Ev绱^(G-cr\ٸ#9q-I3ۤ9l^gF@o'CwIvrѸ,-L$"O}.Azx;|{Ɉ_I+ƓKø8v7u#R}L1qz8DOQEhwZ/LlqV1v{Y_Li"r󆤔`}B
-5McG[$I*9w>` e9\LO,!7p5"I]iRpy'Xp>ķH9=SQ!3#Y?.]jyea2~!ޯRf۝,3
.m6Tr2d)6!ubȪ]툀rrbMaP/t]6B?Z[B3kՇx/%(FpMDY̑
0iM\߽)YA
@xBh}LTĸVNLg~ϴrqSCHd@(3@|Ľ}NVK2L[rq47Vݑ0[
O	_hܱPyYRS'>ޜ9?Ǒ8}e+RLVuk	'N6$TR]װh\vXp0:EXJn/Vpu.•<8:;T.n9{iWL]["o!K}a3혇^gSָ69k	5v&qN#Lfw9"4?N5[dCzÖf)fYȿq9Lޢw!4U+QAv8YN!w}q%%R]T`"|0	kU 	2ҡ/ϋNe%`n?ֈC3
TO	,T7?\T!`),[T8@H&m::;#< luJonoQ1Vww"$'0Kb\ɷcu!Μ)
Jdt:x]hI K6„d&1R%Z>"Lr(l<7{
qS@:IlTe"ıg`H^$~vͩt
\œe
7QpaM_R4eO~hva{_YhBv-xG Rm$̓^CD+((",@Uh(,pWK;Psl'P:q>Qu<.x#kh-}COqk(΂lIB8<}ptIAѢj1q!WAIN{CEs>™	A-9~KΏ\'}KY:q
u%|M=?ny*2?jwcQ+T]	-(ee*EWQ4,G^RI0VZL_\tY4/
ʖB0`hL[u?X!"*HMX_?gpD֣$ꄕC#x=wnآ'kGu ld`IiI
Ʉ%QļU(ql'cZ6ZG`@cQɞ{(~%#7;
bd[0'
wfo9N>,|,R+zsJ@F@3~%2pg~."l?ǴBNppȉii6T2Jdo~5r)omt: ]sߪ7LW:I:tH @$ŹSUxbyČlw|3Tz$BͳS쨿AK)bU,EtM/Hk念VIKިࠑ9_>)HGxO{nmV1!gS'3z+%S:̘(~ƈƎrLwsO`_сp#@
P7~_4+,AGE?{hOU	ڸLޱ*#*nNjmTq3V$	4S{T{/r.TGuOC~SLgSjKw!AQtOcͨ~ƔP}֔bijŤ>@pZ	CC
ZGάUFc-no-ͼvTGiaٿVŚ6<
-hc,_3v#6 ~vxsY~4
+rrHK~
>3"wwxxhJCqg=q\bZy-K\^٢a'[ZPO[`\aV)ٽJsj0:i0+]PwJLB{0߈^KX֭Gĺ,HpWd{CQ>?wx4{#*C~ߍIe8tZK)u2=_1uvˈ;6e]j~,}@W+sܛEGO:e_]彊^~\!ޯkx~6h"\j~㎧.CraDgD	x63,@40|Y."Ҳm–`ĵ m.
a㡈/ǠVt.6J`e}f %hS9,cj#n\r8'8Ȓ[/mc91ʎg"?g'tߡ'I˘D&NN[ڠgk=0s_T%
6:EdTï`4%8HGݘrvno۷3#KcWSӴG^doatM#vc(Bmi!U~XiGVұY76)XC魐3q`6hϗ\B#2^*^T%L[c `dERa8lℾ_d3yK*Kc'\#Z>PIO:Vp}j#c7?Hp$),̚.
#{6˨6}%wS@59h‡ˈ,҅e-873+W{n{~&E"v@o)YpddhO4XԴr+NP9һo;뿹F4O^N	~F4[7ὅi%F,,!E8`]xj'h(|
tAPPrf؟/Ѡ#Y :JS"r˗kuxY
/Y:<%A.i/PHB>j%9V9o(e8B%ܞP;zcô^[|
g?fDi/N51%QDXԏ?8
b
!B?y`)W2I礨76t&0n]=G7?Mچ	9(p+Ʃ}A1Lm%4tz#;#+N,~
6]o?'Ax0Qt6*g7I-"^c_&j6qi`ٻmLUL^s)g+\'
6T.uH-PM8u\aLk5wFhS	ϤVBA?ijh}tlPpV724GZ4v!mg)jI#΋rƋ{{΄镄ԇtAc2)tKaԶ1&gB|IP0fґE"]hQǿS/b!FVQ̱n6^S҃6!qe@ᝨ36ķ_F
x[,	b-`fdzqv1%\nqewBC)ny#i8MbmPo#VR1Ox/CPj*,
QWrf<EsଔlQ@Z߅{'uUv6%%M= 2i:m>3(dii=G%@2Bߚᴞ
mjO"̓2ojQLÉ(H1X~h#-%_hM `FƨfuVk3`>aTXTz:THfekeY[a̓`F)nI|QZȃ5Jf)ûH"4a%̓Y`/}1Tl1ep/3Ss|O";aUĵ|‧Pi/Ke(LŠ`߃@sw,TM=s
)~".{>Q됚&zW4Q
Ι
8>|P֊h.;R&ʤf톄z!ŪIJ}]C4{$]ͨR}y%aTE袌T_U0,/mK%,9iW?Y-RuN]ً|Df5y|x5LbRH*Ni7.95x8q#h<*K?G|vP>;)3iLNld r߀|&l=iGYU]r4&N Kaʋ-oY~5*h-.C	5FBIcA@1iL2l?	'v TpӀUI$.땒uޝ~	IqG6W`U*)F셽}`˼+ULzݮC) ;9P%([`޸!n7F?||p&+g4g7 `f^K|yG52d+=>>F-oޛ/?[Kpo2L.9nzvt_[DR})qitYDtl;ld)
D
&aNkͳKfUh#]£@QzILp	JUo']s)/D(`g65$2Q׷zȚԲpcLܚ_9&6k
|l"'6D7VV[#YifHAtN% E@"0{u޺H'?e!$`
EQxjṭֹ}`^o$TcRsh1D4xp!@ިdvPBUm^ե uUӏFORMDJVUINFO
XINCLmemo-tools0026.djbzSjbz
nvQG8|:mU)twctYc\l"}(tDP'˓=>I6{lp{3] :fBއwTaǟ
P6RK/gחsjȿQ6ټT	1VE5<D!Lٗi W(*䭈JֲvƄZB?*8=x8yw
jyD3yS)u~s-n}`ad5#^߈+R@zq7v=`
m:VZ_?ÿbmn-i΂ loِX=?CSytrJ|s|xmϏmG
]'ODw6Ʈ!XP)fz%^ɒÖ=̓(vMbiZ}ngYzNe
ٗN	;KDgPJgs>#`&wShP/e-`Ttڃ=19+/@펇Z`uՠkw
->e8-{n3|n(ZtNel
PR\_[ΠgEB]vk@kn,nQiCCP@jO8N7{@H*JW^
"*OWVw{*neGsͮdžxk@_݆Ea9&s2V7_w=B#%An~e\r>7(
.5ے*QGecmb>qXUH#x3>LQLxPE"03ý=pK
%PaHǦ&uru;uTU~K#rRz	LE"W6uZCxǕ2|R̾TB0a,FBąI.u幷۔GBAV"
ȷ8A`zgׄXn=N+T@
}:馼Ht
&PM5O0Q٩7F˽]Bk0ta|ZNEi`c;'B>JQDfBNN:K4&o<'Y]#%Ʈu	s>^j6su&[F_Ku%$5k'z?la)qꗓ*xÉAK符\gaz>t✲Vf3y^e)hCh<	HVP_‚lG{xʓչ2/#)Ң{WK.04lҨjc*Ats=#̯
]ILwu!#6_K({PHw0dQo"Z\gY
r>15"$m1	l,uc"cRZƛ=!3S<lB*S!S-3i1P
[b/
ImGǟRrʍI^*
Oʬlv#Oqy+8B	b֑ߺ&s.(*QbMyN-y_+]D!DcT2WYSl"&>\_ލ,9W%a䗳q&|$g[!m?V_<";/,W=`!3`=?謑OP͗a~wP?1rGrˬ^8BeM;0[l	A3D}׳Tg)Q_;Տetաۿw5-<lSbS-RqpVf2[	㶮#~{pjLÙED")k&Ļ4@#e9Hf9
t~M=6HR_7w㬈0P6fad3M4CPn*FH|dùUW/Xh#q k6Iv0j5q0a6ڌ6tI `E|"tRJ-h[.fI,ǂ
gLTjvLqw`/VP>5=qwQn]kIya82o
Ii-ׅ*6$섔IHwћD,nIť.CgT7իk %m`k%qoÚ3fuΫo@lE΀41eO+'l>jr2I:6ߞٸ `v:W5q"EQZj1o$9W-߸=vdB.*Hm_?G-[)NF!$M MtXv{t\_=~x1t*6jUez QҬ3r+
0+~$\!2}abQA*og@q`
{y´Z싁F[
蛲M(5Sh@g;ۓ$K[jIS=~pi;;|zWF ܿom>EVDZ	fe O@y7̺Lۻ1}XgdfE^ő˛g)&b]=>gYOtB- Ĥ֏WwfFAsРR;WKJ{q	%U<Xlp75V=
ʆ-xV8ZiD0tU
steRys0w~n@YnR6 GE5Gܝѵb0T䨩˗ETwr"~I/sΧ"،߯gaqfG-[li](;ܣ;OU*2M0?̓ݽK3Zok,IqSt5`SO>nbN)xun&BϰhRU^Hi"ZoO!%(i aT"aI֏TXTzNHj#"d65u%b	!z.ցVb:ʧ'eKpO,,O	[RUHx	45kZM?gc(]+9sE-{%{xeoJ槠,)x!_Xf.vؤnG7mPH8|+'Fb|؏1N@m?}˧#I+ZeݑW>C{<k[S8ޱz4	N}bҨ4hL࿳5۝R'A5M#rB~PUWϤۖ@ܽXc^${FfW\lᚑ__F
V&iN4Dփg-<9HOe͋	ZػFM;4Eӏ''zZJ+ lT{;giB%j@1miZ"!M(ry~g Jb,ֱRRi`|mU*dJ	5ts	 }ILKFYjkw$ܼ7ihAcSlS[O.|"PzL>`
.DڼMY~|`cxܱ6N
,y'-sR~ȳ9}m2y/|ܥ,oXҨu9ɣ<4"&O=|l;[-wY>X;V^]XpXR!
8xdܚ;N? Gctn#Uq~df(F`Js
o]gF.S	dm;{b	(%٣1+)J#
	)L=*Q&V
ap	~ߨ.l7l~HPݼ-ㅛ-8a+k'g
Ҽ{B%4e"n+ֱ=HP
bnL$2Āo#&2ԈȞ~#Na	a>ͅ}:f‡	KBiIM'רYJD\(29ouVƁ֋>~;`"k%>c}^E- ^9V{pRgHX+c7S͂y040%QiDVǭ_WE)wоo[xr{j\*>)#༁NHsy6~K+,I)RcP~$#=hF!e6#b\u)KYXz3(^6^4pOfrOd=3 $q?_g|f^,Y+8rNgW[oyzuF
ʗH]e38@b:.mTh,03E@]o&ZM
Ay
,u!SBS]=zAvt2<&ۦtҽZ+~%*
ŪB'd9*·3OƍMG&).Jv;ٴʯb;l+5XZ%%$pwd(Ā`,Yߌ/YnKzicɓCw";.'L+LNd-g9g8hIxQE'<+Ϸ"&ԍ\6n+rJٳiZHL@]7D=2gh@U߽ߊ&v_/"X!#ag¹69 jWz}~`
yx~K]<:*څ3m`Hs$äJw̃uO~e*?7=ʉmi!#@oq:@CqeBӧx9Ȏ'?Rȵ]0y=ڶq2LU/[`'n:8(ާ'~h;	P\}+`
om
ǑgEx
)(Z0ʻxgxX;2@8m5O1\اt9{GϘtr?%\C=ims1S gIir2rT
r
s]~3=k8k\ԣq[@|‘zH|"P$E~ 5U	gD55^_smwRZ7k_UA⠌Yʉn8P~yqv/5)!|QK6TĆ'FtUÂsoͳL}$W0\X^,,Ok.?$w*Vy38ہG	/˝_{$L:ݲuKyk7p[R$=gmrZք;WGs?L4ch~yE'AC
mG)4]a
[9cygDKq-Gct~
k~J.Bl
<)&hޤnqW^Val݂3NC1AP@z0ъ4S{DEhgkW:ɿuvvmA՝m;%ǙS1&$ct7ԂhO]13&۽!.v|S"7U{oA4v#j"{~L"s|Cf񺖖/:jo=06Um㨱uQ0gk_ғP'q4u*0B.[EbE0..	v.)4~XN,D3]oǮv&*tf6&i/-r$NNgJĠ9uۻcg[p=m VMЬ[w~2*"u3߹Yk5a}vlZ:z^g'7Dжtxr{ƔCRhR=6@7}-iMUiמH#	Pѽ:\Z2X;M+'Or7k쇲pJ)@0 5Jv̷9M	bO(̿Lo%MEo^a82phݝ
Ta{/QiV<~Aquʲ9)NU#otċT38v"a_r/e_;a&la@CeO?*@p3Jfᓅv9N	8vJk
Ha_I<~)u"UU&324g݆l(y,ᓺ5uLǚDτ2+1/C#).m;Nׄ7z&TZAÑ1ܕ^$\cf(Ek-b$|:"</Hij#mERfHց4죁]sm-_0[O,>[V5.)|uJ4D)A_I;sܢT?BcmVuljͻѿkf'n`$(Ã֟=x0xEM3nx8óMq]'>r":9DM	fiboI4;(TPO1u@YY##
@!;я<F!8^л:{$rfd 50[dB{fobO\__fr9-tjUdRxszZihʢȲu^bGkBEr$^z&*x
_	%-`2G+4ed>%]0xBe?=:kݚuoTp:E
͘4|CWXsq4B݉23_𻦸{^vsܜfQGb9	
6	t`QsD0*)j`@N+VN
gDtqN ӓd;4.qFah*ؑ6帕\-C9]V"`r'fiԿ9bp&ZMznwV"ٳs's_ +!Xzʶxx]/:ߗ֕= /znp?v% V޽xu7HN-k]?@RAY
vutv0F	!HSzߤ<>l9G<)SC$?~P)}S(e̲`N'O(uõ. 2W^O;i䁲9@BIg,0L,f( ;YQ ci^ocnFbLiti`1Sҹ4'Pl09"sOﲟ#rN:8Z.ZVԶI&sW5xr|]lˁ萜J(peoK6zQo>J}jMma܀t檆~Sn>p[ܰP5W
Bq0=ަlc}|,:r{^*mܕq5aVϝ#>D*tw̑:bBD7̙lTJ)uôH7cm4bN78L-& Zz"Vg?Thg?di@_}];X,;kh%%>cSEǜmDf2B}P#*w.=C#f);f"S:)y|dUE^WkSP0#ar<TĈetr<;p
yK86R,:)cTA	g?©[hH&};a}b+bGɃ"mk=dP8C68Qxm'vcu^)CPڇ/=zŢIMB/)mՉzn/rzS',{ݣNyb#wWh#UBJE|o6	HI
uW+Zꄣ23FpnI|4!«u'8\gK"-n
kon_՟*
պdm+ܵ8ÅVl3>AcK`̓q6h9"ivx":8M4͛`ӥCCqqBv7({g9$^r7+K=跬 M%F|
zNWzu}#'K}v`s3Dc@B;⃋>J|#d64fǺɨdRqS0x׆zv{!?"0#)*^OL+^*!w݌E@vɴ)^\'^ߗXX).!EJF(ao8E'Hww6Q8Q|i.#5&y-)1!1`oCw	N9'9pW
FC/kh״M7d&>rd#}@DSH0a;*x{G-k]91|;^V[|KD_
3mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/cdiff-userguide.pdf0000644000175000017500000055305711526203062025336 0ustar  giovannigiovanni%PDF-1.4
%쏢
20 0 obj
<>
stream
x=ْ7r~pk,q);Z=!9C_<
h6ib
<7пAgg5fݟ~9=awZzwљ.2wgg?8P|y/ls@A%c|¥t9DRa>{\6/m\kl.Y7cVH⽃V޺_?Ep]]hݻ*E1a81x|vYimk|o`K"!5*ғwwOf_uKG[@`aBevS傌+JEy_x"_z1rpkF]>`#iqwa!yHZ7NZ+e+gaZRX7ú|_p!0sV:DF+Eh3Z[؊u{`1F#|.eT>(x`=%>%z
TzIKGgct 'Yj		6OdP>~(`VuytvSb"ItHP|\zT YNi2Ɔ<1<*`suV_^T*VF^iA^tṉsjWl`@&-OQW<t,MƥQLCEEx<@"0;6\$K
2+̼XTR;tƁI2` @(hHw~)DDܩ!UDL"8(@R MC`݊
i_!}˘F0--&Z%Ga26dn`x-80A8U SAT,ϒcBCYM.N`N
ݺR€)Dՙj}ęFNM "@("y?ZKؐ1&fqA!t"·WC"ə2(=NNi=.75|޹j`bUIim E&>
Vw'w)/6)M
z991Cr
OkaH ȶeT6sVW+k%Kh[oź>28H!orx&T*c}څ%&XHbxi;ndYylн'ٙ DϽ;b^X-aSixtJ"_K U%*\cҤ^W/a}Y_G:ĂyCEC0+R9ѐm!#8XeC? 34x]F1aM o%hn(֫0PFF`t0t]":t<	fMhj.RŻ|>IxqZk/m?
ұFD[JkPEh	$A3%1TLWMxS]ʣH+x-_L\#M+B'/2.l=(.Iu	fAךC;KWo?RcՆ%mN` +y"ҖJ<v+`-	!Buͫp4CHr3o 7(_xM05Ų W_%O6X8nk5mKJ9LIZ>QI>fƀNHNk3wO:a4B*"֥^`qؐr{HT"1@8B	Tѯ#*О،&&M%g`1K~煘0ei򊏨zJuW.@2_J:CTy58_(K+bF`SyKQ&k.rޗ}f=:f&H'ós4XMO+~`Sam!CA7ߒ*߭r%r
kDeruEC$2c󹷰4,%[Ӹݴ6H35p
BQ熗&2	͘!7Z7`1ذ""F.y/wU}.d|Y^R8O]*6z}nj0/µGJNLd3_ĺiiy:$'o6dQ9pJؕ8,0P{pi}1Q`xr;+\WeXgU)T8ʹQǕaTA(g
aN9&>CíJے)EPpH,p&PÁKe8vNn&LYx`Rp6y,cAf>o5.$3*$^x/UZSjbO5\bm
nyMC
sN\%6BGoT7^K#ߞ'a?a
Z]MW!Iͻ]G<, 1f݇SR%%GKT`Q}汰mmۅ_ȱI.uU
yW䵩N:
z	DG4P2U}dF6`X@lMJpQa=d,tmD C
R8rب6,HaH}>Y0Ni-1хW`R9	fDi\jX~I4[;Id@ϡ‚rnf 0@o҂x(R]߭-=e}].Pr%155e*w4 ma'dA4\CCϳ5rbm1{"fTIڳ J@!2\d$!x׍ą<H,mu|7F7FC"/r%aR9Q~5ڽ\`qG2)$r78ڙJ>v{FX%=
VĵȒ16bV
1`K}UGZ
Tvgc?M]^)>kg1
zYoS)8-Pɸ^yɀ)"u_JSjiW(84>%,%. +zGO,`aO*]N4Jn#pi#'R;qWe]np}D;SZHqkLМɖLʴhFx"f@(4"vf;4"^[k!gtxqq͘F]&db}ژDODi|X{kyJW]6;&?*eXM D=R!`WLωlYpv	i{=%0;u!iKz
Fc5ɌҢR!'Ҵo+l9g=NPVPuvyb*JI~Pj8u(tO:;
iM9Tڇ6'rVL@ƙsmi*1Ua=3Mg-QWCsU	]X!b^C>M]EJ‡W^ڠᝡ?A#L<6M0hVaUv}$ypc[;i{4U3͡hYqUG!hqIsjP!Sš7F dwRY{;ǎD>Y`5-8:)vZiN99Hǧ6VXf_Maʴ":G"rȃitրz?:l:ni)![O34"a?f?YJ|0c[F#a_3djĻ1ý#}Pɐh{8ѹaќTY%grP4Łn-3[T)g+uP8ؠic\3ڻdi苵gMAKG(~`8^$a(hZ߯J%9qVnP#Q͏E.	cى_x'
6OⱛDŽaZ%e{K\1:3
;ꆾEr0]~ٵ<#Vm=뼼,bfM! :?2aPYyRt
{g]Zژ&:mXp269R4&z$t.֩|!43<^r3Fq462G3Hw!4ڥ[dLjyӄҥm
xi."\aLoVAիIS.BMoWe/3;+!nP1ըFXY5?ajraJ{AʛTv,Ju*TA~G)t<ķWݲ5α\gb5mlK,E}4`*v)Fn4N	0sF	\ʱYi&ވ1"u𷌀qq},AQ$vOeRs%Ši@E(I.C]>ǛO;۲wyOe`;uce1^zuҰY&/,Qƕ(&C6xHՓ)j
ԛ󗋭O1dSmm>ڽP|sǾ-Q_&@;
6ɫphۛ
]D{{(7(wvC
U
T!~B\53VWW5blowxT^'뮧)?v\ ˵ltpViMU7zYnXuk4|=z[7T`{ "{&M`!y!F">
stream
xYo]Uamy	PMI6QmQ8%%G!\}ùg,_~#z},?]}w$"?|aqs:]<޻u셞SgϏ>S1G%R<Ñ0sK1(SmB}4>N?9_{Fe	uc)hDNe0T9X-ӜC鍈jD[!gB8knprVNlqwOsRL뇗Z[L<'0aׄIPazM_^ES&MՖV*1MUޞ*
g%*`iMa!#[#vJYX>UPUk]"D3 >DqB7vM83D98*po;w6hFӧVDuЅ
fEf7Bz;kު{\B4p76T ~ 0XG_Eh_
tUnz^ʫ5)u\)NYL@ݰu@
\~G>
>31`
~ƙk\}f#>B:²~Js@iO6HTo^=sBԢaU@`[8p Ɂ+eH"8*WiJP:ɶ
L2Ya|xUّPETžܩ$lHx^7GN7s*OAbP&10N9x
| Jl̑ӾdX8Yɬl9lBJV=H_+9nU7K`:i~}Vi
8ж`g++70v)o ҠGCH+*s=C9x^
ݜԙQXş8pӜ@f)RW	fx!dSS1ǧZ:BPF	+ϖk9m_Gx8nc):q
?)_ZdKYbzh-s4X[_JNk;2P1_{-_tC-L:oM Wmy!0}TE&ZaYZQhUXe^Z:C0߳Xi01#qp4ZAs3Oxb]4gTB![ڋ72#!iz@\839~0K@8w"qv/E8ǑL,Pp#"-?,`	K/K{TVr5ܲ+RCZ5xlCUE'uKTZIw[ēb3X9dEmBFCfg7"nJeW
_dX*IBYNqh3	@KR=BfKXe?yr3r6l&݁X;A@{NWP*zb7[fndrn5s8ǥɘHo1{ӑѕT*jCl6HCXǑM㳣?ޗ//Ks-2!}zt*2ٯ&:8^SgG+]F3mB
n%g6#UmK۴]6?#ck5E8‹*|A:;4RŮ#C(i1S/EI&(>⧤^5y6gj׃(xX@3U\6͠.+Pc͝s򀇪A'Dyaϛ4"CtC|G7iSA{}F2]wb"]	km)|OKF#qbj揪yË͹^1axd0вeVLpӕH`a-e1z᾽?_*qAU!q"rBƊ$**FC+C
$;,r26-*Иz*7Jfe
1

谱*)8)nsDƃ"6uE>$&۲&eŘo
PM7WYJF]^8|%i7!H&BBT	ZB/1ϤI@kmy)Z@I*FGIa׫0M݃p`,XQ,.bٸ,Q%FL1@{Vͷ*ˠ;rƖ厦$f!J]kaX9[EN[-K$O |07O!>L0;b۩"^&-r)GmhfF (Rx-įx:o\qF6SAk|(;]xl#V-<f-ֶjp ܨ;*R,<(ᣡ`[/{+pFX1&\LY%~GkldFlL,.SKT=#|	Ao?ɣNk3)`+u
C|6$]G!f`։/לg^6L$ﭣDе'``L=50%fj!Z&TH	@2mGq:}
K#f>ݧGpެݑ68ZC삿cq{!8'%iPܝ\ox]AY߳+MJ~1jfy!MLN
'rsmFZX)t\:  47F'UH"AoGz}$b9/ۥF`c:Y
UFaraf\Gy@(~Mˣj6k:OcVH<̼RY%a{S;(FU(-@J2(La3#WOk::,WzYŻ՘
Y:&<1n~L
â!w<[ai˜*U( &lhȥC(b2UG
o38$'[#Ɔk^!G`=:@8W6,fKxs0kþ=eT«Y懽'_9d?	ym~ȍE~VXaRQg{TV&S؄hD Mp]`ݽz&h+Ul<
7ܰ1뤵gY]|3A:!';kW-n\/֙2nݪc[A d((b!}M"q5_YPa嬊	v.ya0mJPfF8%lР}Of䳣_RVH7QǨ Vb\j<DFb)b{/LL=k稖2(Uc<.d~d}^O Fjhi\5^jc˻ehY>IE[	i
;v2f4TڽVԚKubߦ[_1<4@rܟѓG |!&[	{8X{RnSBE)18,/a胾&(d5zʽjO&2K\|3ޖB:Qo]da,MDt
Q
@drC{4F6`38rioKSaN}nwK;#иe~5DG6Mf;'%jL+b]uRWyR\mEuJ;"E{ܜOe_%D h%_$t ϭ딝Ts5-ouENu#ؑNRZ2<^foٞ8EzmCb:3N-$^E#,k)m3JI,mc|AԽjFLy`*1;qU&9}Bܼn-zި|%_Fendstream
endobj
56 0 obj
5599
endobj
63 0 obj
<>
stream
x]qȿoQGP$Z
K
%%OUwLuu%0Hٞ>~ډIS/*;z^7~z$|0Et؝~HIBO©GurNHDR 'a+Wf_o|rf476￡IyHM_~wG,yjcTB+⩶;)h5rwa
V7KU;8`eDYlzpr1NK4B
s|6*GuFZ?:J?#N.N`AufW`4!JlͥuUWypc)]#_N`&/2E8,$6takkg)$IV:q
c։	+`Nd5
%̇ϾJ#:-}^>^6+Wv4?߿nO'g4 +AR<I[5J!샯fepks*s/Oc|mKD<}XlU3Uکȹ
[{qFnwS+cB>;]OFM6&Hv[bvafp ܤZ=wWzv
"Hǁ8dhC@o/j0k{KWئe- f#ǀQ`:]z5xU>7LZAKu>^o^"0= '1;2DWΣ0ܭԤZ
U! Ii5zW/?G,p]C}z[)Hh!QZ~dt(*"hV{2
4qf2s##L%Z8
.mpN4Ft*D
jAK;ѯ6<6;KY'DcXEmn9"3w?ϏfvMfG2 e
|I_P&x{Pm0SH;W&@)<ؐNag+@?mPl
ݷ}#=;~M43Gr?ޫ򥵍Gǣo,4^|3&P;`d
Xi=W+XaY
f&ۛ$\%k??2沠2~>ݓ
5C,X5$!5I#+"*E5UXbgjT
+bCV&jFm„o_4Ա-圩tkLXjx|u^5P:K5^m	Ftի`}2~cuxqv˙!x2ziFrN<.25cjlHeT7R3M#Q"T(TWD
h4eIt51BS	i$&(Ex螛30IFC-|1&c6Lj+1$ild=VjB`m\kbo#S!ADğ]ܻܵ(/yd;5I>c9z֫crEL3x}G
CIAq4,{*dp7Dpи qQpkgFi}-M B`dK\)Qٵp^eBWflAv
7=
S΅[ AʠXOi	e+tڦ'{0M;M|..$HFkjYoS
K
$rq\6/E12ƙ>yCbFkׅMInY׹4z[(͕:րpE*+3

6}3p2L6|3(ЍKfp\^jTEwlNhuP끾˛jiHI&hnBfZa|o<:޵D	/2NUsU_Rݯs.3JF?Jw8C쁶뼊h[̍g	k>[?/4 26ǩn`dD@d\-nlKQSRO}Poj$Hqxt@֎(\xa?ИP"`lyPAYc]΍r4~W"X4 eO:Lu̫YJ j\ay	5jHXh$Z\hf
ᷤfL^y$5L+p[U8%9>R
b6b+dK[枃Zb9='$$[.sJKA*̜ǫqm9xԀG(˜bUv=azq kh.ФSN0݁()fy}
|wC/M	Bu[g<U#eY؋d"ͫRg( $]
 0Hב_婀R)/	
ԿuaWǎ8\xa5RMEcPL藣D^_\KU^GB-y9~V+j\I-P
[5m\W;y@D,O ,qWIGIV"&B	׽‘`L050+zE9FL&c~Rh/;!Um&IuiUcYwӋw8%yNV0Ғ]Uذ
4K@j.N6ڟN5LWo$CZylbZiZ|W$U4)_K$aX"t3҉*9XeNm }_uRG<-OdT[	ب$gɭĬ5M8FZ72Ƈ#*n$~őu$wF^vD˞=	0"c4$-6UMHh]*LAX$<Ӫ"+lY4HL;akܞ4[oxIa*-rJ%F+7
O}9\`V(qHx+Mp`乩}SK(Ḡ%ƭ˖	n-)Y5yNBW%ϴ
͕-=]ߧ<<5ϹO*_!f;<6nq7H67r3"c=_fce jq.l쇄Kƹoˍ9&'xTyuLQ3`)tG靨eQ-
&k6WÎj'ߖVwtӱ	qew*ÒC9^rg-Ez1a4sñ\V蚯wͮhy
|\;U^$XĜξf^	5OWBέIpNVJ0_JVr[sarFMtj	^-V9?s)geqg9ySPuH%?:嫟SV4^V>=µЍGOo=}vృ*.-'82ěG-/_^!J>0e_|FejSK.UXX1,Jc≗>oաKy?݇*>PȐ$Gul,ٻe4[*s:_e֌kRjb.`\c*(k=nÖ~ Ͽٶ.UG@ck+EeI3<;pןӉpk/(+eYÖ? T)@NKڥ*v/ShN8_0,1I?8#a箷'-v+2{ޔL/Hl7P
z$sZI.9ʠB爛6½h؇<+=VSFH柦>
stream
x]iq0_n}(HR
S6C(&>U}T5tfg{㩣{?EWJ]yg J?/8%:3Y{^E8uxpu9KTB+t&#%>2(=.Ek]z\tk#sF\gu!]\`c9]K/CH[b2Q㛼-;g<6F8|H__|ǟT&_9:>gx>>Z?xOrˠmڊW
fZZHOʕױ?}~S?Ai}4xG{Vnrƻaa16ЍfA*.dD{wdFY޿~僳ߜE34PP1v	po^Z߼8fUƠE=X!@z>fOIL+wmSj"	wz'zt-~&>}yIϴ,Ctj.SU2s(@e(g2a	(NM;O޿ّ(haTXs`TEl
rӊ~qZ
;p5x6Az2O8JX$S4 3iVBN,&"`kgZaxKvX2|n2ǭu׆fq:6(}"dqzϸEŋl
"P"J`ߔ<#s le#@EE
p'H|hD‡	m^{`Ӱ5i
2ZU
2[bc	A>_Y\@}ck`f.s5b+?3#f`(R&u+/7^Yh:v1Ql6vAG
Pǩ{
^qF5c0}ƻu=iFَ1jvݗiX4A-bs`֜t,:o͇?&WQhgP鈒b3neQF2azh`-gӑsv
?NBqTP"WƤEE}g0Z9 &,	rFԜ
B&0*g|d߀&
k;ѯyo=.V߫qDOXMc\,-jL-
S%'NLj4okgRn	5Rx1t2	<Jig[<]-A<٠F}#Ol,^T(Eos+ގd@{eѣdlN99u]vdoWzVɑW8W.:)nDa!REy>U~}^71Ʃ"vcҴy}н@vaQ3 ru!m`<fќ	k .VD>:؋`ڙ`5#?~#`'FS/7}Īb@]nj/qT PX3q>FiYDž.9(8|'}Z!pE:Xӆ^z&LVeh1$ȂЊ
(U.s&y=hS8HY.q 袺aTmU┥帏Y5ĆՉOL)(wj5%<\<3؅^<l:K|.)/066ЗT{لpJe7]p1oʿ v1[@y1pAwk**.4M&qIӐd'sBv޺3	ٚbTܧ\4M}<$iz{?4tPiҤEU%$7"T򡑯oKA?ЩZr,~^FZF܎2ST,f-qMy3)y/.;{A.h(dqaA$t:3#&[6uwz{K{
{i?+64q`]/v":m[=6gWJBo]/t7dom;}K0n ﴔ53&!Zq`6o2m	˳A/9j0]43LWptɊdXݼ&Z7``U*CUx^XHjra#2)U.Gp.jC&/ڀzrΘJ[s6Ɵ07WNbl	PrƲח%^̞zaRb6"vJ'~r<[G\["*YE;`VE3ޗ^\l_1IO6	̑`ܳImĀ,?HN[
/,G$6@HpBeDx|,IIiXX:À?7\{곟ᕶ1_4|6,tԗ%]9(PSinN!J@xrAvnl'	ЭR{I*.Om/y,4bjy6Ŝt
UN˦2(<'k1n`WX,y*	OРkv{>gf`ÝDؔ*u֐ɚIrԛR,ڛUFy>incfNܥWEcn->h⨰'+Ls>	Nh_l:L^.Z߳~=\sjetbJ}}1ޑOI_4''DE}^\%| WsߌsPFfcC>`Ss;poY3qly
4:cIYOaqB '֗U!¹۞'K{7FR0oVEBoɣuWy!	ZAa~~WA
sn!xIʐ9Kz/PP
D<2뇫3KWbO}\JRygAMX<֡{NuAr؞+}+)wG;۾[9|Wlv+hSanW&>'
V+Q\噽0 NS(u(`V5"IƜL9nCfЫPpc&%QH>:zjd/SL?1!bzjR`彉ZY0gtNR̈́9DIAY+C0TT<,K1zGNy[zd3< Bs֜RK^C͕fKY8)W}+K}@p2uP(RH%ɋ[?ub}픣55'a.
fDEٞ*5Pٹk[!_ l2(1,kwE+]0d^sX	)80؇'
RJw
Sr'HMTEfx簍0Fs#+hͿaפ[c&ۢK$dܖ2'5"z.G*ɴ:S%5AgYOWUԦ_RCQVtߏ!cm.1";jhSC>Rp`\gٽ^ꯠ&k}{HM%L(,2!}ug*XE[Nc9Zi}W^4m%%bqB_ΕkJAmU
"èN}t%i݀&Eh53_JlJr!y⥦fդCLZ>0i"3˕6'!I8>1ۙ@gP]y:0>XҬUFғ;R+تCYSlv^7pu-"&VfX`v+Әoͽ+x̝8;})R+{|y͋j$T7\	#`e+}V0=pU]Y	kLt2P9q)/:NE
uK"QWr].WB'qeh/|ZgfKg/z(fkblpDKz|29:E.`-0	EsXL#ïԭ2{RUg}ؐfz=YU@E:M7:HX\$G9b1XD)/	chd^H
f-BӰ݄_d^w⩫9s)8
_˰{qJ/EAu68o24kC"#Х`ߚ)銧dFx@964w"Bv?e]$_5|>K};;a=l,U0@tlk˟X`HrsSX\%&znoN>'pmwx^DT@qǤʻTᮡw}AћI6U{0uŻMsa0s'_9'<[{gV(b(ـt8-z%+)it?_1%띜tNPv<%A@J/eb˝7Ks
&w4vIfu=F~42L"A>
stream
x]Y?bfmmSv8 ?!–bQ]wfUWw5=p0a´JYYY_=a0'|!IߧN~88}]xC1m~sBA0L̈˓:=cq)pr9ͤjov+_l.Oqpa8YYMh%Tݿ\2=>5L
Ro8x3%o)|K
gaF;&=)I)_qpy}ϊ["\(čV\n)Nb`%Xyf^YƸ^Z3Wgd^B IÍ26ׂG[Bq63^I83"f
')P&o
HTpp|:.=G|
H!ySҸ>s~TXصru:#WJaBKaR@R(8)Ьŗrr%sL:fDyoKE*{shJ.ʳmθEԌ^dĶL:>2(%+%&2:`^xvFQ
IVi	dhu.ț63Wn'0/g'DyRTO24NzYǘMeV#̧rI[+ffcL009V!<] Ҽd&}0MĠ𥽵_ot>7&098=ۊ:0m7N밲Yo<@5@
 -Q`E.%k_4T+3jH
+%8pI%&Edͯ=!fQw)mQpe0
6.ʼnJkylwOu!޼`i4(F4(9<9e
(p1hNY&'A`AaV0(j>gF 5y.uR+jTf4$fyB&wOfHPWrgjed
 NJrDni$6aRżɵ"iNZWZ4S5yZĝ7bfP:*ӬaP	>([qq%J~bZ
}oHjӝoTm<$	&ܐff^B9Q9bϳݏ9'p^[|B
lKYŸ-Ը>)0B_<(ٔ+|Ǭm;ĸȶxņ'*HyQ'	O^9(Ex`mxB(rֶuB[a-.4g=T7+xM(-'(Qlt-	!Ff|àpݧ)_30 2 :Tѵ+]`Fb㽸R.%Ra&*1]ᆀ CTj+ΚG<"tH[|icO౨2/-C8͐/Pδ眚L
pzxh\CM:*D;bqM
ADլ|4#
ău;q-WǨ
l@b:Qx-zבi
te×VթЃCbV_{8F)ޟ3nЩ
|'uUŷT^G1=_{o'ns[[&#IR,P3tr&@LFzI>u=(D}fx$s[4||v8R!JfuV\)GڻaE%ʘ,kUvL{R*;qK[1XUN6YFQٔH[yWx!ecU'p9n2Gp;)õ/9鰻S_a\a
z-)ܿ,C"Q?uKXg!ˆ> (HֻQ8	&f#y[x:5{W:@H:Ň\^Ԓ
+}>87meRT=S|2J5Q8&ګ_R}%殸);yKgIRTK)p'N^҃
YuauFIDKcLߕDx9.Kd<$uHzU.:{iT1FקqY@e !0/0NZn༆Jpǭzft	C\21etb̷Mt"[tbY	jo
]H_wf!M~#Da^9NѢԶeLN2=~/4+40?`. GH*@;32܈^ɹlhQ\qvB=Sn]'o0EVG(WwF]3g!?׼b,kCgcF :JUnbvœ4RWU;37”aioޢ,XzbGgNS(r(h4+n
iŷwN`	nznׄ|-pޙ5	z2VR8}3uh7{5^ی
y-7)U0le90\hJe=g깵C7DecW'v:7ͭK%(6IC[j"e̺BM6ͯ)qlN"Qp,U>0	Sk:$.UEÇh3<71}(<7	A+J0pA1Z_;ϒgpWV6{^[b.8򛰌[^;`xʶg=K=h&8fgM}ќPy+:)§"u)v!8$JRH$p!yO|nQqطq"M҇Br۝mC>X~Ok	敇H; ue/{w+cE齛XEn([rj+*& -aTzl+]A6
++cߘΊ<imm5C	KJK[,_i08v?L؁[5|wPυxe@zWE8.@vzl_i|EOGUfD[mS>$;1jQ=EGb!OdG|H.h+D~-oKxsq:~ђў:Ƕg
+Fx[|d95K靪%&IKKRE(5&B8aG"yP]p0<0qن87E?Bkk}U1=v)#i~>6,!?KL:_CxU2=)yC'?#r׮LFdrAw~lwW3!<&e/֭@U4$FEt]~ܣ`a;Jy%C-p%ᮒ>e&4.#2WTō{jEC͵8ɨ?$?{QffC6**d݌@:5DWw=]L[!ńL?;QR-{0=
d$K|LsLi3mwMSTctF>y9߉b>Ai71veb鶦k1J:oڗ^Yd;ܝntز?hWS9n@lkJm=_fGg]oOuzobI>慵$W-!}E5RR̰ofBO弞!?7dN:btw֥ss<=>
stream
x[[oF_~ia(Їi8B_u-[i#Ɏer}!r!G+ͮK;o~r&j)7ؽۿ6?nDop3zU~{f#2qŸ۳?:;,Hٟ7"iӱݩҊ)庿nݟv)ΰ9˅
МK㻯wHl`\
~{R{A	(>4tj"g(:D$!1q/7M ½'HU>H)\PĬ>~֘Yy`6眤"%M5@iJuiH\CnLCD7XQW&j9]&K8CR&[j<lM8Pp(ZS[uB=Ӕ&51+HOE=2gjۏ_|~4.{`yJ):%3
oh'Zhܤn~d&kUvYBƹɖGOhjlh'BOMGE_Iv9<nP˞B&=vj|->{#˃%ϊ,J75k
g8M&`sr֨m#ϰ+}kWn|,?ǬQkV15Y񪌻#WAlbӔ	e&-"{G&sP@DAc*
"/^&nF">mLq6
"+	xhl?*TSoqSeRYp#r)
<]U3'כqGh+&U\q%H/a2:
6
W8:D*rBK$U%Ǜh`jzx=޽?OԬb!##~;Ҡ SBW"e)*_Qi)pW
hatPLDeJNkMtB	 w9m"szD=$QnrHEL}7m?GI@P9"m-6(ǼEYQ`/0c005]C\T@"'J(-tGs,bzS sа53oz8{tF
Slvzd+UΑʚ(
Ч^@UDg!#߅&r[^r[sR-Ta8/J+`MA+p&^=q	M""	RϾ$T5>^&b=^%	PG9iBmIPp8/;n٧-q34~]B)Z;vUSV[6aNG= lPe{zyM(ֶ
xϡL`	x)14LV;*m IN7`xf">,c>4.JxN@ǁ,-0ƃE>
stream
xr񾕏KGxIKy]"3,RcHQO7iKIKK*BD/;A>|Xf;syw:Ftjߝ<ȼ^+;'t/N.6n|t,z笐r#?xX{k%FhL/lCpa
ڀ~EV*i18fJߟc,R)R~rt:1(_GIc$xNX-ӮӴ5붂o%6-z~߲
6R#ɿ6'#s:G ʒ=K<$wwe?c;2U^{5V#V#˼X3x~Ϳ`g
bViMp;Eހ(-i
9!;S}C7{>>Kd>їYh* A'at[sI|e
z!L;QJk"Qα<0#8c*w!muC
o2肫,bY4Ėr4Z lHP:4a;F\lqJibP,JrFZaLjg%<Ϗ=jX *'rSZ^J%)b-
4]8Ъϓ>zn&\1|;@RNHsIg4ʼnٞfp=Sy1Y;\On@+wԜs7Y6Vm26YK~pWĀ	J-/E"(YIkIj%3]^:3,E@=FH,%Gezxmw	k4U/nYi 6őq\jjhؽaeoA.H)#/UM*Ɋt)%~\/))%~fHdI3dxpRj?LF Hhp:]PIJ(hi=ߛB?:ϛ7*ÄHA79H/JB(BEmPr.!*{1He@]R[PFRwaLE}VGGM9VmZݦvm1l'[y20MfRɏ+I7اld"wg!:OXkgN)	;'.Thu}V-,R+zL}7"FJ|"CCWlw慠X.{^%4ʆi0f$	e%W1T5ś,iOY
!Vb=Z̬݄>1:͠6B'}H4O\TSHI
yY+6&)LUE󗻞yG vP߫	DSgVY
&^9eWAv
?0R?G?MڴFk}!TqMS@j:E+j9KNXsoWV1g@F:Wa2iI]PYLշSUM
FŁjsN?׍}sKpa©)^mpr{3Py77QIUR(Vp>k'4:gS:/M$ㆫZʅCuU[^Md-kUZ~g*z.m*ft6Ie<_E7
`_-?hmCc`+s\jظ5wfojLhTDN3>^y٦^~-5n{yw=
UQIWE=߉/`kpb5m{ܡANQi1
4QTHLс9y/3j_I)jӬY}+4Qkeӯ>5%xSybVb1fRe0=FԜ5Ȃ2PYVI\7o|f`V*t<^XAMqjAJqhPkVEw;V`ao"^~eHx_.c\YtY>H"D^Q&h3'$N=
[<|DiƎ̬%ފ}4*`W+=JА|`yOD!s0b?؆dLDq{
&^a,Ug*@Yq;>Z
@f寴xL(1?vǺVrJ%0ѱ@sH}XG1 rp"!O(\2TD34TqKN6S6x2hQuzAP^xԌ!5ஆvO |ثZ_AadMN!|TOWL~;|OJ]?H?#(Gw
4 ReKW;Wendstream
endobj
99 0 obj
3093
endobj
105 0 obj
<>
stream
x\K!9!@fd
#.b#"9A"K"nrwWJ2l8EUXU3oWR.Oo{)[ow˯`Kς/Nwi/+ƭ\/
gAr%_~hPG/fSʭ].YoS[:n,bݷ͹4~Rզ[k.SgО^{.ܫRAr[/Jp~V[pVuQvSqA*j $8Ԫt⪞$,bR{{q$ym?D5%VNLنy*):@eru*{#~-;L8xƥeNN߾tg RpG2a&k+Jɀ'AʆyRi{>>!җ1B3eTo	~!aa<OI72H?&G<ґ]P9nIئvWivg}HlDE^މ\|OMȟ 2
wWD᛽,7EʡIf,2v8h;'UN(aOj^9]Po,AFR9(IVhx`V.]ˁen0RN@3{̌(:]:]4ȞT1wEP}Eyyz~9POZ,0MFub1WNxz&Dq^'q(U}DBs/</XdU	9OS+-0K2(Y_zy%L($Na|%!}@!PԳXSc-KV$?!%Tk>ySM49U$vC⑹D#S%D|&'3K~5&bQ;G\pyA'Epz8K$(j	V&M3]nRD[
rkLY3R,zD8u+/UɊ鰝e翡D(顾I\gL>32;>Ky0]TMLn&Pn0^j>Vp6^McF.G}J&m2}QÙNZ	=?"ZYZh\*?eoxmZ_l*~6GcuV\DʝhpZ†sV/s9onYzCi}љY3}u<[qƫ	ܖ̠Φ_Hؖ`(*DR¯TgmUJQKI'9obhMo^'cm'7ucVϖty|ڀHQL?ٸ*^|v3Z
FQ"+FNE
Gpf zGA.JS2$yd=WZ0(bgI8͡NvP,P-/$
H,%Ä^/g?*	`[
g`\t
\%aON)I\͹::->JsQ}"
;JB37%pGHSWd(E'N!wuc۴wEyʒ.LQQ|c:4m{@dW2*,~-i2M$T4yWŒWܒa_U3R1M,
8է:w'"E#C#x-p*QeU"i϶"Ύ딚>\k:=E59"˩'ʣKAGkZU㭦{A#nhZ_fW?H/q'io=cG|X2J)Da!췰8V/0o1KrсN7JʘZ>Q|1F+'G=sYfo~IҦUGQ/׉޻F+#8:	6m'ωENfU4)k84hN+Fx=U_N8ChU8TԀf(TC?0f<8Q(Kv>np#f*ڳx.u/}"/O`Uendstream
endobj
106 0 obj
3186
endobj
110 0 obj
<>
stream
x\ݓq~IyY*/VdɑJUz\)ǣl݇㑖R
`f`vK)E5t
<߈Anru#ͳۓXϦOo~-!XD`oP9:zNY!ON{k*F(6tzg*.h_RmVۏJz(Um?YiH-r'`Js3Џ_?xa#4ǝQ255.tҧ66Ԃ^nQ>=	ke+oz08byb=ScV|;SIyk"Rm_4ITycq!M+?`u?(LQ	oqnɉkMAޓSȺ&p%+h;o/ǫzQ"5hFyɜ96;pknݣ%0vHu攘J2`QHe$ȠP#J
ZNKGHy	R5IUl-g(RvVC8T[S%[D@pjд-%/ L[q%uggsgꚖD%J(zKvr~|p*CՑR&C
-ۈW$uvxpĨ%O7C]?\rLPvۼpv!wgdiӚş,6C.\%*`DP_) m&pFy3g̽7
͝,P"#r
{LU,$9e
lOZNVHb2"8ߥ`w	]R$l-fҞT䷈;.׉(
idTȐAc3gkiG.djLZZ0?L?eĒjbE&+ANM&żM(^iPog赩U[[E2	
HY;G͉hgf?L֕)qc3\7k>l3KŸM
?:66lޑ%cVCUZm#Ġ-Li]TUUEBNN
>I'9@ҵB6f6B>3F8eYXUa)[~7g'f
P^Uqq4z6Z ׍
O:?-1NGLsss	^n&za=R
\LDcf1NC/AVBT/dhhkl$I\2n F2^6unJ/
mEhh5v
[^Z8ɟB!ɪGk]?!Cx΋e'J|8RKH5.wobj(8t>6ض+d6RwY#'c]R%n>
ʄ{	d1xoAY+ZjpA#]+u9eYeߛ4KHMEVNܢ?ٸ9n5rHT(A:z9D9.2,=jd5եNkDИkV,wqZ8Ί(O89*.cBm}!?bfy9FC]-C1.s03
EʉYCH3\@J5:\o^Qr٩Sm$?gwzܰ:׬e9+_v߫S<:/:4eXG,4Y9m]N	4&L*\jZit'a1d
B@YfrVg5li§e#RfIglnMUP[iZu"/RCpnqlźo6{-T9b:lN1p{pN@AX +0&&D\L=Wi0|Slch43;]$pp-v8R?,GL
}=kT?KaZr.]t
t浕ù_ߤ籢ͰyφGzWfBMmUhhaI=xQ7̖_Xqf͎ˣraԊFnaz¨f[Ŕ;4}
q."ѝJ(ȢE.pǍӅ	
oJ2@Ca2)T' Ju1ƭŹ!}?%8X[@t6Pק=IeZZ`mْT,l4÷SGKU98t?EʮzU{(vqpϽfz$(ڼTIo|7V~eV*s3ĴKu)$ڴP1D`uˡкyj}k[ m>2̋K?ê}9#?yyL%ohF_GЗAzi18N/t|;?hMB5,mdO,u=X6Ҕ9s+p
ju4Ɣy: O@h"|8Mh)wKyOBk0z\rJ:r0qAg%r9af*
ci<
t2)Zi5jyh)|x7պ1ݫ!6
?
9}$LBt)Z/_!)ԊrE;Ҳq/nz)XJ=e毩MtW6c1)bQ{j #^и%90_:9}cGgI4o5n{cކ~[Oj7E;cN{{M}D!̱8"d~Z'pp)(=5*AwhOQ[zPIőt%ַCjd)YuؤwޘȻO|)WUOiۅp\T%ۏfj'=-)]nm.=8@_Ж*DpX$ a\#9e`5y,+P&RySp/%Uۈ˴UџG($%QR[\fbswT`ܪ-E%tf"&e5&O"6'db~8L%9]Nz#(PПNl2dǮŮՇpԃ/+c(*Qջw:ȝpMϲ]~3zM

K~k;	c~t$y
^z^tḿ,E`#ҫ4oX٩-\R]+c&1^&xz1el16]x$\E΋U2D7
mCk:':m>
stream
xio\tX/E= u,[iY 3;*:$pf87F?>9RˣԽַGϏo~w
3؄!:{76^A89}rϭ<>CTB+-3_9`<<=Ǡ7v;h~tnO{'~9aP6l8ƥ?F!Z+`e؜0eA};
;OpatVX+6a{ce0,b_n
P1	.Uz"$F	@,HYyIQUX)ʑ5Hۑ6WNfn8MR;
ˈ촯i%[s1u"iuR;1Vo֑`:&,|}q.]n58]K>F%-PQ9;oiB7S9o1-
ѩ!@a"[YTfFWhtSw*L,N"'#SNǣ01T.8*jF1{IQO&IB ![`XG!GzGn^|}KdIڿ|VZVZ'InoI~á)s2Z"fb9}0_>	FUaQNJ+;cP˘]6둞`.DbR|	9|<(WR4^Z0`
ΰyrHpdKd'RU8]BHZ/)`@%$UAbX9
DZ@4)'g		"6%nIjjy%SǤ釓ΪjR=nh'RaJe`宋!HKe@B+9Ե>vbE]Npr'jNMvʝ\ 4uuPBvuaB쥗-D;˄YdU/di|ywh^Zc] z5 n2F&co!ĽPuU5C.szR[p[VS_дZnY*|zsq?P.$e~e
cLvSE$ySbwfUR3HlLvZ_Wg	&4T#+˅J2q᯺+g|)<RUQ(:bεO*r=-AFsAvijSxEHZd}&Aa.t$USi_sSުvJY̖8,gI-\B6Lvs*Sx#eCҕ*}*.gwʙ2bmL7MUy-򣼭碻ڳ$Ӛ3krU=*bJ)c~!uj^p8GwUUCKjFY="c	^qjgmxoݰ?:쵰JJ%x
1q>|"xYe"*FfŃH#  bBWC"Sz6Ht'gLO.>Pr{V^ta g,Mx~g ,G6p-̘FW"xy[O"[͌&OU޹*Y>.)81%&u50	z$q-I[O!{}UĦw4H%ĩg%@*aam$
>Bq-CDqyDZϊMQSoNjtJDriVF
.DDJOޠXe [
ԍb.c&zk;˫FngL;'֨&!b)(e:QOЕ3s)u2/ӁDae:Tgq˜j+ޮ!d2[dl2'@~3y5Vch{j#1w?	1o$oUNi%3`	̶(N;Sو5(+Rv5K7sKMi?`5R3 ox@CGX="p2B$ds
|%	#tQ9G쮝H15~$eׇTl=&jOU[TuBQEék5dZ[8QM[]- )],H[#׮O4Xv1;Vƪ6MݐP\)w;^{jܪ͉Oi`ZցvԢC<+BꀲvaȒtL]VG;(5)
&SPB5ANLqA6`)CؽSQC\ckOϬ}_9 APE$2Bof} Mi潡T΄C_0Jk{$[o-td7-l1~?
9Iendstream
endobj
117 0 obj
3804
endobj
122 0 obj
<>
stream
x\K>0r!9Ȭi,>m8{#4z]=vW俧n4Q/HǢ W7{oZ=8+jّ#O'ÈW'H+'`VNΎ[zsVHpR<f"1rPwA%
ϨJeD[ΩiJߟH?@cPD+)`n46o@Nݴq~}?aϏ7Fºm1`*O"<7?b[yFrAh>y4Y{hᒵ?`ߧ#ɁK19`D"6V zZh~*ܼI)ķ1uɃq	ʷ1g&_4vӓ9
Ƞ͚F懴˖nc!cUnـĩ@M
P6ɕF/[
8ph]@4gp#e2h!JM;-

޵̀Q߳DaIÊ)CA8Y[RƑc,o(oGKGi\zW=Ј"yhzvP."~\ԏu9B)GlG]FYՓݫn'g?:G>(7Er;4|sm.O|}tr뻉#,cj8jMSh
7Jlo9E;YdGy}}hFU'TfzU$eȴҧs`i͟,BT:|?lNx1)tQ0zȚ_7[ͶC? >Ş^k\.o(Cʥ6
%I˕cs%aRh+񽬗Nv`Wf>yhW9&~ܞM«sC=liJk?Z
3JV)}I\joK(ƇQjOK:_|zh=䱁N߅.q\s&y+?{(Xyd~JP#|ȼ?4%d*8yNAF,wIaD#+Ⓨz@]'.1: 
,kd':σ86B5@/#l=Odi+#.sV2^R(g&Ff<$iklLB	pqo8qfPlUĬeh8;Vh5
#i|:ť]<A*"srmy6"gU+^N,')[a'%Jb#jِ#91]RrF
3-n™n'
Zms15d`2v{
-
juee9qfLid][9^h-`u1~ɒD5:+q'~IT̖A%FB/
gh5Qi4ƜYKPFӕE.p>Yđ2<(t"kj0*zxrJ9-#&c;녆DaP[Oc/_E:qN"qL"Ԛ`v.lDW
^|3hJzY]f1s5n%SWfPQ>i|V>܀/+'IɁowh3X*~?o`n;!uJQo¡|I3(FOh*duoeQ.U6*
#CϮ3S#dK7N'|2t1pS7"[Zaֿˣ[yjStO~lmDPm&bD~p0߉:%Pza0B~r0lC\l|t`VSlQ!]bW)PRH[mM[kߜrIGZ1}8CUhek
YBN=YVmk;(M,x_W5u*ǸWO^UpWlP'Fd`[y3n}3xdڃ-KkܼwPs071mAFLŔvGCpN#jE~vfR7[5
`&ϳe]UJ.zXB	%xQSk	E"Dp'2##E+h]05[e)RLݽ-q+x%Z{%0|&ZxRX~.	nw=oPtsZ6Evz	kfQ-US\oLJ`zq`O1me䤵LPv`amf1	#+XQ
-06=CgX"QPnU|]e@VʳD{ 1)w
cgQj3"ɹɄÐQ8=-ĪBr3ߏR7u+ǫp:VkB0$a'*(w@}߳eX'lLB]Wi֪X4RyE=wZc
`(}+wUmƎBY$'1D+7O_12?z'I_!'XbXGsѷ:8`$\Csb`,Ԇ}}
%S}DK*'w*d	O`E籗x~IPU&\~LrZxDir-eiBf%ʫޒR,/P.4K1X piJ`QΓ\d!~W+:fLzqGv_I7DgxAJ4"r;rqjJqEWBԨrZYI<݅X'G
>;jZzAim+TxeE?usWA7@`HAxWnKJlHd(‚r_1>W˜"
k4U5a0JuR-*s5'G:2duMNel>M/
~[XW;fe@<+en0=ؑ5,ӻvN'K'i~v]8¤A8$:iuh^̹B!أUj7Ix&RjY
\#A$^Dyt5(N<'tl]R<WczkF@|w*QtVw
웛eR<u@K:pX.sVC#fequfP+xc 7ۋlH~?/֋7aC)KzS%	Ӭ
`ón>oIv/tXgO|c+MK$b|{uomqښϲ&
\iy6endstream
endobj
123 0 obj
4188
endobj
131 0 obj
<>
stream
x\[S7~#+RU/RawYYKY;O|͒l)Bgl|=_!O_K9<ִ>
D+1o@T0r`|W!Fcμ e!c[xߓ_`1?:iAşze}r43nk
xu>R(Lk-j184r7Kڷ>0}P5w.WfDKGc-8$kB폀
<&$^pfpJU:f&ήY8/drko@&$!nb.?Ik/Hgk4(	
jq_bnW ) cxS/ZC@a:	I-NFcXȔ4j'CX(50j4	~hc3qM/Ӓ7ѓWKeZ銗	"Oc*9\di38!aǒH0-Ѐ\^y("*7nuKu$-t
?.L	Ijʍn$bR)LuqZ.+p#LpiuMsFe¨ȺRkݔYPl4FV5	ɻJ7e5\U( Ra\IJ`R:?`Pv$PqV5*%58ls
iXݕvgxNݝTRFTh.^PQ49]"&R}KI6B-IN#@3
2DCˁN%]ԍ*Ÿ`Jj㇖y@[n
*/bg=h9kY&CFaGw'*wb|"#ƨj>g(
C-5V
?(]h-@Y	
C:kEjpxQ
(OB~B4&(s"auminhp?!df*&
#vcW4e͘c
x)eW= L/
<hDG\0e ITsrV2ԓr>·<^t9Y5IF@"XdfҕAwsdSҦ'V'(izsSx^B{AaϦy#8sRT*.Ytwԛ2Zʏ"
`>Yy6A 5k;xXPf]/YoΫn-7Aח@0Sۨs1ֺ;+gS6=sǣ\"3It̄0DDϯDY,xjWe7ZD\҂5F.z8uz|6?aY!T΀sO߼)/Yp}wi
9\)ckHfu?4on
u>&\g.496#Yo$>
stream
x[[oqQbmsi^TKejd˶,Mew?.ɣFCr.ym7,obs~}7|Llot`nc_mpcq,? 3zY LZaC[)=p
zeKm0je"Vn?GjR9џv$?:%9yBl^|ZޝrnvZI8|MÔn{+h??iafnS[3Q a z`l/}ρ)5ܤdlgq2Fև~0B>'/c>Ϩ04FGWA[5swPy͎ܫ3Ϊ4Mj4%i_>jIR8Ը+RkQjګQy ~үybl?vdW3[>v#	X0k#!oQB[	O/,yC)r)3$}qɌ
#?^B-
yZ
egJ1jh3Or&!glAp##>"åNWeN1'X/5͒ZN.35=+mX=<*76=BR]Pu%8UQZmu/O U|qxaJ᫙Gk'$q	;{N~CӐܜ*%G:5]@!ͧY~Ah፛Ÿ^aܣI]mE!q-8]'K0#WOfsW\Aq9aǁ)™z"sF!$.RdzҌh˪vlAL{O(Iwŭ9ޡ1vxnС4gX)KGKZ}}~&,Ŷ$0yROS'G3hߌTX/.%c)#Ũ=i	Оh75d++ěBҴhD(%	ƨ\&D#=Uc+w1`j#b#Aī'ߛ)UaT/A׵b}Z
bм߬ǃShl4_n64mSڮq~
!{C5N1jq!=
67VQ^C^YʓBk7'S
]h0^\Ba}ܛ[mB asrL8jc#ௗIdasg
ٍ2ңL>J
i3i9/.R.,aD
F/K`S\:PvBv#_ZFwNO0So oӣ闟nuQVd~CR
l`m#Rzٴ,52(k_QNQ\lE(%J(\eCsf%BNMD,Y .~EcTn@|T ̺]㴈F˲npٻIǿC{Q_XI1@EhcVws[СǹvA<+wZQ!V(7v{:=.ij_V۸/ӺnF넭t+vyoU8/%Y JBA.dy;2wEԣW1|e$?ꖻ[wS8A$_^5x|edK.	Of9^f@v
9]7;iWFGݩEa7:Gu;Dy+d@鸆~tvӼiL_MpL݂ts_Zì  o;Ϡ3WO~14J/{@ߣyСy;tˀ
9:24Jk,Jieb*0 6wU"5ʼneK?{ۍSf^65Xa^DkO	7Zv:9wl]p-=ƊQʋz*jG]8]D'^;N%bMygLBk M0*}?!@o{"@!y_Dx~c5^cdBnYÃ@
{5v|i"k{_9[%Z>2὘s6LXW!YYs|3TK.W'%JI;6yCsPgܶ-59
mz	0/JŎ^oϹ_ӹ:*ikaljV0gu~Ě~.J}֓
IkWI\]CU,WsZ]\zZhQ^O/G7Z±]|t~E`^	N)h˲FGо",*k\#v"
Dd>U=/xUd5Wy|ECRM^Ѹbq1x;\ǽN^q|X›-K2Ƌ`ڻJͺ^>NrwwMz@W{茳f]'jDjaw{\N3Or*^\?\롴b8PF9:ã
ьԖ{Cq:L3(JÏ{·z%dz^l֒+$Z7kG!xBPK}I򏻜>
stream
x[o۵=Ȟmma<@Ӥ$@lKȒ?;C
ξEd#=ݼ^^.3gZ^]\>~]^1l_OX>8ay|!/?tru"V3YgOZCo<<=ÍGPmte׫kgSZ	)o?BHHۥ}V']'zZ+#?ZCW"AgAz"4'FMXDTY#uw" 5ȷNzڮ=Zz	a[YK%=|˸nQ׶D[<G;y܂^ cȺqRuȌ+BFe`ddɢH&d-iSF&vҩİDtiPV^)P%ICCSIONKTD9T3)œ9x~_)iKhXHM:p?+2+p7h$0V&}kĄeyժ=,m &ZS;2Z)ۃ@ao9Dy0x^HLՄH*+Ot/RcVK҅>1SBksaaen?unFG	HqyG''BXk3^<ž1F xݯDiYXlP7-dz*W0_n>׶
!*d2LTYo+2Q$gb2Kc(4c7=.H1d12>o!#r
Lj]EM2.>KuefO5E+3
(@SFAcSGh#H8unI]b\;RxI:]Ҫboi=
9*v~\lOP%A<
WGZ[@N"29LztEjsxxslr|;6Wh^xtJ뮆Qm{Ƶ!'}ڸ,_X4Ym&wѓɺAuvSƜG2@Oh~prjB`.PjC	N`h@ABBcg3&;>&se~8iP=n0gPkG 9
V&TPPPtM`X,4Ժ*3 w9x54A$Ywܕfg^ H+PM0Yj(xQY$l*_q.q"lm5j!å^oWRZV@ i
旄)dYF`9(z`ztR!fCXAtOr$oB:
tIvfhE:~$""Y&Awär!\
ɚ>L6sY+AT64*`DI@BZQ"M6ͨx1LL*tPVrF'H.0>-|Y
mԳ!MuEUqi6cxb4Дd1+8iH#~At3
5(`4Aar<Ɖ# w+Kj6ȼZS/n[siЛ]Q-O>l5&
"C-Oe8q"]E{0'A%WG}>9.ioT7QHs7ߌVx9^|lTBN„&Y&#DdQLkryU/cEzy[ŚO"4qL"uX0)oΜ>5蛯؜s6K5ZrkPCܔQ]CEL{n
9v='K\@	j\\|꣸L"'sb\k-$A&[]KB3paHDp"HFϞgorV˨CHNXb@p5ŭW7Fʰǰ |B[hEd>(8[}O%͈a J@68h}/EX~%HWZ[i3%)\V73f7ϹT2>'Mf*N4w|?qb|	w9ZSF=+hC2-k9W1(Yޛk{^{Kll]O$9T{2YԻx߱utT:^h9qF)'+n#v>d]3nYwM,׏mIj	;,te<\?}5%}endstream
endobj
143 0 obj
3217
endobj
150 0 obj
<>
stream
xn\oBo9M-PWm-[,˛XC^ҠaHi/yxzb_1_~$A^կVnH:z~z [Y&fֿ9ܰZ8_Y.8A:g;\X)=pig~7\ͥVr-N.Z?dx/} ȏN?zk=q%׭8QR\Fi++d:qs<#ɢ䇇dta|Nִ?$%Sf/1K@OGA~w0HY۰^)&:Ǣs)&6`soHTwV!QM$[&DjMl[%H<%9Mߐ/^/ړ֕͋w^TR,yYDbpd"˟y7.fʔR/ݢԕ3J)_JRR_?Avf0L!8pOIl%`_t`x:~G#юb͓J=-	.9S2z~R@û60;AYq*]~6ΞDӅ:Ob:!Mt4`3@r}1PЯ-;i2yBL@/
Q~ki1VoٸP;OZ|Z
Z֗g>oqTb9h)$jkp 2dN|kg
/K
Ո́HOLDGJ)Y	r2$]i]8D%kkW8/&xԠaS-BuE! :?!!e%(PR77-E5*bF%+ݳ0:0)YxJNr$8RE!7	ӊy
'u<MB@-9}XOtlM8FσI8$7M*/
Fk3T*	@K	EIVb\v`/H_?rSJ	Iz:Rz*XZ' a{}K]da٧"9+2O%reC@:	?i-oQ@LTv($] DaM6 4hjY`6*rH~(lqPpKƿkOX&e9#JbyvGJ;[wDiP,ÐdfQd^xyqpN1=p
Nz\E@8<VxҋITZwK@)BKԜUPV5(ОӴ%@\3kU%01Z%iF(5	$B9\
NT"
~wpc^̫Qe]B@C8
f!庖@U%+d3Ĕ#K5MBAMV$	+a#xtAP,XT}L69l%T)*/\m^:I?:>hlT4XKK{Yěs]@̗2g[.V&
-
W]˞&:obriC2OKMˢѫS)ʁEcTnq2fp5о^MHcMF@] c8ŧ;Бƕ@[X*h;4x9UXZh2B㣖rB93Kn-|1Z5ɽq;49𼤎y>نUiqZ[#JwĶK%n.N侕9BE'TY|\9 iy^4Iî(5"my,Fȉ:YY=%TiLFi#.
'N՞6).ڡ,s߇38oep^4ٺ=M~HI{$dLsJfßY#_|@;uVzy7'`V/v*7bl:6]C[d:岷A8:dj$Ʋ=.5uk}k(|j%q_ܴ]RA07j3R/[7e̻iF*v{bdӒEAײX~*pZ'C(P}zXj\Z)YaVdS25[	SatJN@7ڒmvU_kKQ,DӖbinͽtup3|&g?΄;oD.sjڲ'dk[bk32|<#m	"b%Z{^HW+y=I?T97|xe]~nFkc]g4_wSw:NcWDOԾ4_J؁h`Ɣ!iSC$p*o[^6U~Յr>xIFhq%_Dw-}{noy^NPvnEXRe6
_xX4񖺿foL}4л_qV~F=Q3dZ.zV輑h]!&;<e&<u6Q)ODoQ.]hεBs e`Cx
YKS)n'| @xsB{S?`=+QT[ѵ[G<>v!nY-0z?U&J odqMZxm	̞`O;oozV'IW#endstream
endobj
151 0 obj
3677
endobj
155 0 obj
<>
stream
x\[oA~ypѕmxC
p.@PGH"X2,Ɏd%i}gxrɣ#GM3735gOX_BJWxK?荑n}rS{kF292#ևgwF/b0̽Q߇_0*=S	kƽ(~+뇯(3z8jk
|[bLh7|?{*kQƒ@i#c'N
oHU ncb8GPx]bbGfRT;*xAul
^$Ha/Z\FNrEYP0gup.g)r=gH)BxfnXE5E{>+ǡy+i(/D‡RI%SV9y5MbQ'WEͧ•MܯSþD˅h|E	78D,$njx@\lVm,>@/@Ct~@/AgM@k.HK[q-S?p:FD#S)p-}^DmqњFkaFmzzWZ(moamB//cObs&ҟ	^աz~:@D˳x61;ku]I:H|
h P.x0P9/#C*IVXݖ-$	bY݄V]}4^HAù,̢,V(0>:Rxca6tPaX>"(S: Obd#jBZrv&}
GFɍϤAEۀ\Si3zW־
'R^x0'ĩ%†MM[:Dd c?j5mkZ {f9>jlf\gẈ[Xĉ9";j
?
d|	0M)G}p/8P+ROx.#?x
(̎AGhGzd^ESs!xL/mrYC½3pCڷ'~yꨚN(uGA&If}LΔ*V?m#{Rm6*gC
CPėyvw*Q|>O-CKמ/Nsը.Buf2CWkZ{4H!
VIlv+gĭݚjcc(}cDXƦlcL4&e!NqHUCF.͂RAN(y܆d={K:
DnDFADz*rZf	JJrZIdo6-\}H`?#(4WՁefi=/ΘɩqN2tEFʍzE3HuE_&iw6QSZ,nv{$]h$V'0Tds!Xqזz„&(c<3auuKpC/DI*"]EKyvs.o%((nmmv3Թۘv>\x>	+/pOLřUc	`)Df^e{B{4*jkUWh^V2h/z4dM[ɔ`Y֎q\k>Q(bU^+F66hռf^@(7hw9u[hn8qUM;9yN4e&PDӹE-kEFe9^kBP˫ m1LOh2-v油B=5~JjhdLbj=u(	yܦ,uM.r?EƲ))Z7"
&rV
pTD+5Ѡy^k#FiƧ {Q!S&yQ-ZrڄRei-iqw@[$7nOH)7n:z+.8M;iߐE:Ѳ%ӻ$ܛ۔O绹W|>&UTof◤	N%qM֓NIis
P>%τZpZ7kK8* $ tOmI3pb?`0$ڒ"0E~@D;x6f8`=,z+`܍xac(*%Z--;D!_|4CmF%z`e<<\R|FP/+<
)yɲ6zܾjÖJ}!+ys6h$--d	<=Eqr?Ci(/jZ`gY
Ka*MWsaGYmr:P#CDy7Q2Y9>)RdVBc)ߴ;
i'v9˓nlj);k`rʴcq@-znD~
bT&Yn-/%2CkRA;5F'4H.{yҷ6U9%>ޘT`˴%FN?м'5&+SF7cQijZ_--^k?{:ϪYcڒ6;lHCKU S`Ǫo\ɝ>ǥgɽtYN7dXMVsK1?<>
stream
x\KG&2^iaAlJz[ڕ'{:53=+0L8lj2|W|}pGWgaxW<=>{yƇ?axC1ҭ.aм̭,=3buWk[ks?8f~{t8E3igtϭze}R+}Æ;q
Mh%T΄vv~qG/3+{5󮕔=zwZHA[R8TׇSt}5w;vӻuYv(@X%7)gqy})|fWu&`'SZ:	C,Q֍Lz7Ĺ@mó[Jm~sTjdA)5BA@=Ӿ8.0Q0Tiy˸&ㄯ/'
#KRbBS+to)8 
&_O?DofDoBcw
`X:߸U@g|Ǭ,:J1Yp zs|+r4]Ȁ؝F^pZkaG1azD.{a4F7`J׎z>İځ3@}6T/P*=<}-L\"Dl҃\ +}wy?e2V:2s_6<,ߵTf@D*\kv<,ًnLSy15p8|RsEqP='R]zRPlπSs	{5£SX@xHetM<qG29`JBā3D/oϜZ
zl8þ)(BAxQگ>k0BTc6˲E(P)f_-hazQ&	d.eܔmҬ"B$b8cڢV0"ׁMb9_5R8bp697j!f̽'y|5UI){QRE2[[job{ۄ܆ǍǛ]w"Fy nf9v@wp2&,DbBz1q8xA8qY5ripv`Ao_z2AP!MfUZ7e/6
 >}s]4ʲ4+JɼvƌD 4[yCTd]d
8
L"J"nsNzWM$h
c{ʮțbl<6 	*&Na1q%M@M@2%ʼs{_16s~bǮ(BgM kwFb}a~\9̔x,%x}&&,{0:_Էڿ.i[DM+&1h?sWK+/z	1X2%`~pOFy_iCm083=:36g&BT̰]:#s>t+{~PF>sy6|7JM,Lo[)k"ρNjBvU3pg@[,;<(S|4+oDJefK0K0Kdi6|f$vbKl"5֘MHcXKigk7mcTza=r,OmcniRW1/of	K
_m{JUpI̓`ŒoFF/escygɏc,7j+I(sPYH".Oy9Veowش73M57;v.f=/2alLA!~F3W
ɴVすU	&UڝY">3w,sw`m4_"w>;vр=񆋤D}c7o2߿8sPMeupriٸmTnAy^?vUn;˪Q="w!RrvpP1WvH9~W{4i״IK[u_\M_t`f@%]M5nw3Bf5ܺ}p4쐜~f-xf] Ff(!#JCz/vN8UgG82	 cMQK?mf\bFZwyGxWW=x`0ACɴcY=wH)^
vux~A/Ӧ_	®8Ɍf|6ƟyVmO
o	no[2~<ο17\o3~/a9#(InGU3*5OMdNMM1;u˼~2GO]ٻwdGdnd^FdNq~j2/fR=endstream
endobj
161 0 obj
4323
endobj
165 0 obj
<>
stream
x[Io\>в/	9$@$cȠLeKNY[<1S>>[̰KdX𥉉3t}y۟D~F<|>ÒVh6s7F[('fɆ1[^<xs
ei&脵JϛÅT+>\F:g|C1&9IB7Z k!]Zٔnm/#3ch?#F쇍HLMll&,}-1Oa#6&ac#ـFl">bOpnz\H&lw_:7ƹΑ8G6;f#plv9QpslΉ@r?NqƐmÙ-_,_B"cIVcQ<(>}xc_@dcb	wa=E%~ͯU
gTAs},2LQJd-i+T.j$S6kuH[
.F$Sun	"闆͕iZNE!IT|
UJ{RRZπN׈; *R@.I0}[&NI NN$3i}$35w[:Γ|?)]5݋!xS=BF3Vfe8>9%+<~O@?ۀ''c@ciΏ{RQE)dWs˝Ïg=Ɯ,$ZSpa^edNoĭd8_[fb]!&]VaSаQqrpy`T4	5Sy8bAsçE@5*IL5s5IJIԤ+K
vmOrOH{BAM5(I'ԤZ{S
6ɔIcs,`U#lҲˆ7zZ8dƦd*j|
fVϓlOKbO7FIHZ
GLqKE^i%֓pNJ:q_"=1,C_Cm7aS^z>b"Ir3tpʻwt1ΨR?0^ԛ0[;JOOIK*9W'SiQnҥAr^7aV@leC3U]JvE'iBYλ.z9Q^˷k3PB;V=~g&~dfQJ3^dbٗUC5QMh#`3;7kJ{x)=009-Noct1UR$S"ɔF5OPzB=CWKRmuÌȈFܧP˄%|#«͑}[[}5:=	`=1"U#,Y'ޗUT,NpvۉE#SV{`Ҭ[ޔ]+4(TދuG^Ek*I&5/c-U@8b>ܑSXZ'=vaXӿ_Z}0U[Xk}T^~$F%Ћ4U5[_b6[W>!OIIMw@|oD(@>9ڛ|bV}ͮB2[ܬzsm&I"ƾ|g:zِo^	W60dp̣*=iq},ʇw#g>
stream
x\K7w#f6|]{m}Y3zfy`_L=RULtU̔)3J%gb#)'XLZ,Xr}^$KV.g?V9gx?X	tX0t_.hZ(U
V[!%b\-&H-]{!g*|}z
|$WRva(#%/`]ifRyDp71я{N/HY2{H_>2N<,WBRI/tL/I`efʨd=%ϑ\1eE~Ն`{|>!KBrʊk۝euGu4|EHSR"47SBRnf4mP~'֑m:E
䈟/6|f=ZFhѵcnT8ƽ,(DIƩxk3J@ vTVIzBueS!_ęZ^֊`x*DaeH0AsTQ߱s\w c@eTm(2D{8e\Ikvg]`*@+@9uiBr,䬬>ax
V<
eo]wED`N^JTȨ(DK_gܪ
˛DXQNyUVZ'yע2d'g!yb}N-#6̜9P80wZVƓX$Yqqwjxû[@aCܶ7אDehٿO%Zf4쿾8}.qCCޮPfv	wN{l?TO>p?3
+66_x͆a{/-{#l᭄!9u.}s*L8K1k(Q(jiVuwQ~e:ĔHꤣԘ fߠyGub64b878i5辣D$U5ތ[ڹgtSO44^ْwUA={sZ4D4^rZ"jFBC4]34xC4gojSpiAye,]IH5n0}8m::4/5+acҙ,bEh_nf>߭h@Moa?yӺ=[-5t-Yc'>uՏ@`/[7vdJuSLN7]^J
uI
s_".P'fj~UiɯJ1ӺRjܱ+#fs!y9IN;`>3ȳ<	R.'BtK9>g-jvAwIK\q-ɸ"W[c$Dp)s-A9)|v5hNH[8]I.=Af"}hѷpq2QП?Q _ΦOʕm{fFR%c4kƥ_$$mi5ѓHnlZlTT!,i7Jgc}80VΊ2gʍKi jB\Uqv:%@AFkZxa_bpyE	EiHkmo6BW#$t/-(@
xB9 Z)xoH V{@=87
6aIEZ:sG*9y54qK_sYgE
x?ESj_<9)p.5!ڠCnZR{:fB[AxC
ƃ|rl(*KZ_AWJ߉0(G
̄IɦaQG;;-;<fO+
/O4:Ҟ$z?.;a8o`a/waܧV \Nڸ8K{\k<>D_I0fC̚[GUm<Š*SwgɈzno3ER)mos3+UˇF47zA況
endstream
endobj
171 0 obj
3157
endobj
176 0 obj
<>
stream
x[[o~_
[ Eg>8@Ҥ
CR%Y#Crfgej.wϝOK%ߝ.^br|CK×͖H;Z4ޚV9L̈F֬I!4Zea|tZvJRm^Y|ZV:gtyӏC1&k~ZҀ-9o^kZ%[GlJ[~Oc[3&$_g~/+򇯇v{?.*Hb\sEO(.Q#e~ˋI3-tUޓ3HZ%[Z5:J{LBah'r迡\oȠsf1	_F]T_Clvy5l3ȚCr> Wx#u>^	(7ǥV`GB"x+7ƴFrTU#NT<Ԧcc?lNqEj\b/Ö
[0B_RXyG7- `YcÂ@9W:Mc<P]G$`N?WrJ+uuk
TI[޼^	2g6ݓ.FNA*@ŽHGn;g
,be@G>tP?G-müu
UK3?V5p[BL(($+lH;2rp9]$9ٖ7xRE0Ѵ
Aiteo[F6Dax60
#Cmn[mZ-m
t4_dIX&%aBkQ<Λ S̭:[X`XSbBD{;		pw4&

љ#~:dA=RD}uւ;[*tu:XnP$g8jDV֬6JKdf@%008BU^eNRS,fsz7J[1<"AQʢ
DZx	xt.v^֡K 'f)k'a^zzEos>BhsiMLDUDYWu1΅|tCd#*։TSmi!T!O͛WtܪVw-BN6N3Hchބ"`Q"׸*-0$:rUё1fJ{
l8SAFP9⵺Ä_U혞VZqizZCiD吊'Oґ.]uzvsZ31q1>H(9e
Hs
w> G?!k'Y{͉<nT:t7OoUf
ޫyC&UyHX%eB=ң$HTE&B(kzAŜƐ:tM5	Q.ޅ
iga|NYҙOQDI>'"TϦ	 ڟ]hRIUpOM762	t
tnF%mn9&VlZUn_M%
k␁^sŠ4	c>o0nQ(`svop0ɯJѪ(`"dQ?TpX	_e9KW?+-!P#Odkzi\8T]^q=ى!BVG}xQǣTۀu]Pȇ+>hmЪ:Giܑmy/2N$[YV
ޱ/K΀ko!F)% 2f<ŽDŌ+3|Ǹ3% 3~	Ԡ=Dƌ'ݽ냨q;_r?xwߞ~ze3yϧD|lh'L=YbCA>
stream
x]Y6~m0/96Mz'OI=`{lx/IQRI$Rwk'0lGӆtC?ߟ=zY]٧3曯.lLmfsLҚфDZJo`%&pʹ/!kE6
m֔Ko}LIXh]}[!%>ſΘ45͓-#e.7VJ{.80snj#9mzpCQ5k?f\Ջ9g6VM(]k&M([AnT4Uc/7D]N8JQ^]ֺfTO9s\V|c*/f]뫦k1lL?W6&ݜxIiWjHwMof(;Xݯ&5#g$02^nf[fܩUH5X촬~J^k[Isbjsk5h򬙆}ϾXVOيskhQo+%n@V=w_-kbbS@)6?W~,VͫfX#Meh€H:T(?Mˡ=i6Qem*9~$ѵt%V@r|A:CP.wX̓t~`ωH^IJ1kR~
ڊ4b@jx	46}og6Bd	"9q:zr4jW	3gILff&ii[t{ E2A9GF	9
ipB9LQza1Bd^9Ya5U	 "!ߧi?%"0A~>}i?y`eNG;
VM-ͱ#(w*C-1h>Hg94;0DH6B<x	g<_4΀&q&@!t!l3orXJOtGbX,^
Xݦ1+Iȥ%&Ϝg:ҷa<߂|;Х 0 3
%YhF:u77s1SL3&<=6kil937	6\
9ɏ~aFK9O`|;Ts1T@\ӴHd!R2.fthd÷B"RvB!}Pd3;ꤹw{-im0VYQ*x5tz#ԓ,ai0k/2i eLr83zf@1>f赌e,c
@e
0'kY9<`/]#׎g5xgR	(?*u1Md	RzeL9\AƒGƐмYB,#ښs]rx-]1^QNIQj=5H1{fiRYM¯c:yG~%:&\c_aͧƘb%S=F0 ]JKI)3[ԆįdtŎD8Ig97&&Is+%.fU]qI$y7I|"JnK牐a.L7`3_CV5R4$H3!88ݠ|l3`$`.u5=&*Afo;itPcarzo
ݞ@[DZ:NJq\#n	Nip*fs]wXwXJR&S`TE`k	H*=Pt3&/!Y`o[AiLD_8(	bŰ:=[\)\3qPg6{+ん2(o\Ӷk4Yɵ W >#FǑHH+|2gKѺ9&YTGe#K]	DB[YAj4==`<5sj6ʁtboI4sڙ|eiȻbi'4
MZH:;w$0Yp|瘴*y[ w&!E%FP0wM}N,1ZpNp>ĵ0Cy6K^|7~oC59b>jϻ(_9?}Ɂ.Ɂsԏę4	6ډrWp,D9o`n⒋=mbfD6嚇ޘwj5NadKHdRJ;54kb1QGlFd5Ӭ5x3sS]؆onJK6q~e7)0%̸HsF.r0'cFښ}1P&'MH<}ͧ_4u>รǙe"$&eE%Sf	јe?E_r^Ň}]mvV!, |D?GX`VūZwIFpm7ejJwLMMԄ55BMΧlw	E|"K:?o+L4,
xkyIV~iL+t"je-.n!	-NP*bDg_Q
F7}mcV'/m>
{TYC~f
3	k/G
d	Q[_kiY(~u_ǯܿZ]Uendstream
endobj
182 0 obj
4429
endobj
190 0 obj
<>
stream
x\[~_p̑8_0%qQddaF$>_uLWYX؉#9/UUUFr#^R|5SO&2|=̰b{2޻B©ͽkjcTB+Uh?x̼wwaѣ~.}8|Qp>{7_!
7[Zg3NF	fyiNn[Y!G/'|1z%g[FclwQ|v"
;uW~8#z^faAܛ8*
|Cy?Z$#UcpA/=iքia}D=.C(4"H'Cv,>#'F胎~çuֽk+uv!Ώ*d+I!1q`˘5qΫizx^~ZOW`_J>iXW8_+iv=46QwQu| /+I%*yZɃJ.WJ.v2.]ƽ0i	P\FlNnVɺMCak]Cg7ΪQYXpqeE<
WF.`u_+y}VwW`z;Q g-VV~l9I%4fϺ^]_.79H	sqWeB@m6棢˚@]v+gRfRHL[7	9QVVXa-'"	0])/T}eBbݙ8ZLw}ƒ.lkXϺGמU+&Wg]eM%tW8\C%=96f@|@	`A,hG'Z%<
5F
d2SB,	@B,V+
!{)S(-Dp$crt/GY]l
1:M?f(;6&W&ⴁ4H`",:$6^$2̐=H
R'A#}rBd۟n>$]
xb4&LJ%tnT@*grfFӈr&I=f<2.l2~$FDczbqeIۼszRsT5o[ɨ[x8pR*ulRsa
fCͅGK569H:c74[41d\
.ZdPF~0Ԧ#E@ڋ' mD~HP(PCFx-(\>SF.y}a:˷VX+*+Mlv;zex
(]h(W`x
?$neS4ζ4^~h5piQn8(V wv{<۽+%Ɂ2]hRh/""!^/s i%8}i3;$C8ta:d\z&iLs=!s|L%ـjD4s>go 
%3YLs9cd5֩]c'fkeSGHP=P2@)M,y}JN@	r!(O $~'((Kg{7!op}:/*ɪѫE
	+FʀydSaVE'Yщcƒb1˟ش2bR:^wf2/(O7ɠC`al>._:
g-ػJلM9'Of7ݍO_U
O"+nZVS[uJq16[7BQZ,;`<*:h?8GӾ[~VYFhmh"؇sؚ_G%(,R?RIg&G=;S%g64bjWvԢrL-$ʖ!\r,ONEibVH?m\S̉2P8qGހLL~9:+CrNR7giE3w!tnOtJ6f S8̆@" I#hR`cϐz:	I5 2s3&9QUz!vJByɒ\DIVx\9ۓbE8/geRl$=0ـ9#$YvQ}c>e7yuCQbL=-4«9\5Po{rwHL	.!do:(E$BZϐcUHGIPzaN&QyF\3im%Ӭ@Xs*T4}'基TTi:V)O6UyRgTtFRۓ]mO*j,g/(Й75ݵ\`["#Ƌax/1&>/eͧ$CK?-)9c4Km,a
%='#xت
(LDWvo
d/݉v^Z4vq%\&Wr\_-y;
EqESmS—Z!RPמK?J_HWh靱(f
GXZ=P9[q'dq#Ԑ	m㲦Ԩ[EVF߲B\Βߣ.xǠwb@sGrU5ٗβ>.5@x
mF‡/FФ	'[F/~wq&*'XAƫ$kJ@CR7$Uя F	4mQW钄.ymM#Fވ?*xxFeq%̭MY9xRɞuc٣5z(F߭F7\jٔ2'K@r*\,pxQR8WQzx|#6~R9&WZ,yPtĴq6v̙'޲3rZ/Y,gp=`>ꀐܛ1{a|}.s~7 	j`e
9NqU({1C7%X
K?>m3YidEVX*$H/&E-A"Νʪ~3hnMxыxq^R=չ%QE{٬f_g{r˚@D)BF OCEDc'[I1ac82Sdd]B\BARk	˄xy{_]G?N*ow4ILK'Vtf(.بxUi,Q0ܿd\9&ބn*T6_
W^
]/=-UQP]jyFٓM_OO$RTm La|RVa$D7vAsCh;k!QE-?0W'<=e+*-8A_YYw]BQw%;.C/4]W
endstream
endobj
191 0 obj
4592
endobj
4 0 obj
<>
/Annots[29 0 R
30 0 R
33 0 R
34 0 R
37 0 R
38 0 R
39 0 R
40 0 R
41 0 R
46 0 R
47 0 R]/Contents 20 0 R
>>
endobj
54 0 obj
<>
/Annots[57 0 R]/Contents 55 0 R
>>
endobj
62 0 obj
<>
/Annots[65 0 R
66 0 R
67 0 R
68 0 R]/Contents 63 0 R
>>
endobj
73 0 obj
<>
/Annots[76 0 R
77 0 R
78 0 R]/Contents 74 0 R
>>
endobj
81 0 obj
<>
/Contents 82 0 R
>>
endobj
90 0 obj
<>
/Contents 91 0 R
>>
endobj
97 0 obj
<>
/Annots[100 0 R
101 0 R]/Contents 98 0 R
>>
endobj
104 0 obj
<>
/Contents 105 0 R
>>
endobj
109 0 obj
<>
/Annots[112 0 R]/Contents 110 0 R
>>
endobj
115 0 obj
<>
/Annots[118 0 R]/Contents 116 0 R
>>
endobj
121 0 obj
<>
/Annots[126 0 R
127 0 R]/Contents 122 0 R
>>
endobj
130 0 obj
<>
/Contents 131 0 R
>>
endobj
135 0 obj
<>
/Annots[138 0 R]/Contents 136 0 R
>>
endobj
141 0 obj
<>
/Annots[144 0 R
145 0 R
146 0 R]/Contents 142 0 R
>>
endobj
149 0 obj
<>
/Contents 150 0 R
>>
endobj
154 0 obj
<>
/Contents 155 0 R
>>
endobj
159 0 obj
<>
/Contents 160 0 R
>>
endobj
164 0 obj
<>
/Contents 165 0 R
>>
endobj
169 0 obj
<>
/Annots[172 0 R]/Contents 170 0 R
>>
endobj
175 0 obj
<>
/Contents 176 0 R
>>
endobj
180 0 obj
<>
/Annots[183 0 R
184 0 R
185 0 R
186 0 R]/Contents 181 0 R
>>
endobj
189 0 obj
<>
/Annots[192 0 R
193 0 R
194 0 R
195 0 R
196 0 R
197 0 R
198 0 R]/Contents 190 0 R
>>
endobj
3 0 obj
<< /Type /Pages /Kids [
4 0 R
54 0 R
62 0 R
73 0 R
81 0 R
90 0 R
97 0 R
104 0 R
109 0 R
115 0 R
121 0 R
130 0 R
135 0 R
141 0 R
149 0 R
154 0 R
159 0 R
164 0 R
169 0 R
175 0 R
180 0 R
189 0 R
] /Count 22
>>
endobj
6 0 obj
<< /Count 5 /First 7 0 R /Last 19 0 R >>
endobj
1 0 obj
<>
endobj
7 0 obj
<< /Title(1. Introduction)
/Dest/section.1
/Parent 6 0 R
/Next 8 0 R
>>
endobj
9 0 obj
<< /Title(2.1. Installation of REDUCE)
/Dest/subsection.2.1
/Parent 8 0 R
/Next 10 0 R
>>
endobj
10 0 obj
<< /Title(2.2. Installation of an editor for writing REDUCE programs)
/Dest/subsection.2.2
/Parent 8 0 R
/Prev 9 0 R
>>
endobj
8 0 obj
<< /Title(2. Installation)
/Dest/section.2
/Count -2 /Parent 6 0 R
/Prev 7 0 R
/Next 11 0 R
/First 9 0 R /Last 10 0 R
>>
endobj
11 0 obj
<< /Title(3. Working with CDIFF)
/Dest/section.3
/Parent 6 0 R
/Prev 8 0 R
/Next 12 0 R
>>
endobj
13 0 obj
<< /Title(4.1. Higher symmetries)
/Dest/subsection.4.1
/Parent 12 0 R
/Next 14 0 R
>>
endobj
14 0 obj
<< /Title(4.2. Local conservation laws)
/Dest/subsection.4.2
/Parent 12 0 R
/Prev 13 0 R
/Next 15 0 R
>>
endobj
15 0 obj
<< /Title(4.3. Local Hamiltonian operators)
/Dest/subsection.4.3
/Parent 12 0 R
/Prev 14 0 R
/Next 16 0 R
>>
endobj
16 0 obj
<< /Title(4.4. Non-local Hamiltonian operators)
/Dest/subsection.4.4
/Parent 12 0 R
/Prev 15 0 R
/Next 17 0 R
>>
endobj
17 0 obj
<< /Title(4.5. Computations for systems of PDEs)
/Dest/subsection.4.5
/Parent 12 0 R
/Prev 16 0 R
/Next 18 0 R
>>
endobj
18 0 obj
<< /Title(4.6. Explosion of denominators and how to avoid it)
/Dest/subsection.4.6
/Parent 12 0 R
/Prev 17 0 R
>>
endobj
12 0 obj
<< /Title(4. Computing with CDIFF)
/Dest/section.4
/Count -6 /Parent 6 0 R
/Prev 11 0 R
/Next 19 0 R
/First 13 0 R /Last 18 0 R
>>
endobj
22 0 obj
<>endobj
29 0 obj
<>endobj
30 0 obj
<>
/Subtype/Link>>endobj
33 0 obj
<>endobj
34 0 obj
<>endobj
37 0 obj
<>endobj
38 0 obj
<>endobj
39 0 obj
<>endobj
40 0 obj
<>endobj
41 0 obj
<>endobj
46 0 obj
<>endobj
47 0 obj
<>endobj
52 0 obj
<>
endobj
53 0 obj
<>
endobj
57 0 obj
<>endobj
60 0 obj
<>
endobj
61 0 obj
<>
endobj
65 0 obj
<>endobj
66 0 obj
<>endobj
67 0 obj
<>endobj
68 0 obj
<>endobj
71 0 obj
<>
endobj
72 0 obj
<>
endobj
76 0 obj
<>endobj
77 0 obj
<>endobj
78 0 obj
<>endobj
79 0 obj
<>
endobj
80 0 obj
<>
endobj
88 0 obj
<>
endobj
89 0 obj
<>
endobj
95 0 obj
<>
endobj
96 0 obj
<>
endobj
100 0 obj
<>endobj
101 0 obj
<>endobj
102 0 obj
<>
endobj
103 0 obj
<>
endobj
107 0 obj
<>
endobj
108 0 obj
<>
endobj
112 0 obj
<>endobj
113 0 obj
<>
endobj
114 0 obj
<>
endobj
118 0 obj
<>endobj
119 0 obj
<>
endobj
120 0 obj
<>
endobj
126 0 obj
<>endobj
127 0 obj
<>endobj
128 0 obj
<>
endobj
129 0 obj
<>
endobj
133 0 obj
<>
endobj
134 0 obj
<>
endobj
138 0 obj
<>endobj
139 0 obj
<>
endobj
140 0 obj
<>
endobj
144 0 obj
<>endobj
145 0 obj
<>endobj
146 0 obj
<>endobj
147 0 obj
<>
endobj
148 0 obj
<>
endobj
152 0 obj
<>
endobj
153 0 obj
<>
endobj
157 0 obj
<>
endobj
158 0 obj
<>
endobj
162 0 obj
<>
endobj
163 0 obj
<>
endobj
167 0 obj
<>
endobj
168 0 obj
<>
endobj
172 0 obj
<>endobj
173 0 obj
<>
endobj
174 0 obj
<>
endobj
178 0 obj
<>
endobj
179 0 obj
<>
endobj
183 0 obj
<>
/Subtype/Link>>endobj
184 0 obj
<>
/Subtype/Link>>endobj
185 0 obj
<>
/Subtype/Link>>endobj
186 0 obj
<>
/Subtype/Link>>endobj
187 0 obj
<>
endobj
188 0 obj
<>
endobj
192 0 obj
<>
/Subtype/Link>>endobj
193 0 obj
<>
/Subtype/Link>>endobj
194 0 obj
<>
/Subtype/Link>>endobj
195 0 obj
<>
/Subtype/Link>>endobj
196 0 obj
<>
/Subtype/Link>>endobj
197 0 obj
<>
/Subtype/Link>>endobj
198 0 obj
<>
/Subtype/Link>>endobj
205 0 obj
<>
endobj
206 0 obj
<>
endobj
50 0 obj
<>
endobj
48 0 obj
<>
endobj
225 0 obj
<>
endobj
44 0 obj
<>
endobj
226 0 obj
<>
endobj
42 0 obj
<>
endobj
227 0 obj
<>
endobj
35 0 obj
<>
endobj
228 0 obj
<>
endobj
229 0 obj
<>stream
x]
 >E`0(t6ƶ1U?H=)NG`:&$hijIƻ
o 2kP:+^RTn$֜r2roA9ԗ^\}[bf
H.UQ1bO
9ZU
endstream
endobj
203 0 obj
<>
endobj
230 0 obj
<>
endobj
31 0 obj
<>
endobj
27 0 obj
<>
endobj
231 0 obj
<>
endobj
201 0 obj
<>
endobj
232 0 obj
<>stream
x]O9 y?^4ӸH%Ţ >v"eiͰq:O&nѫ&jWEt:V}^26^dxWBvV}#)q
RanA2t`r	NfbG$ʊwbG8TPU[R
QMo7ghnX
endstream
endobj
199 0 obj
<>
endobj
233 0 obj
<>
endobj
25 0 obj
<>
endobj
234 0 obj
<>
endobj
235 0 obj
<>stream
x]9 E{N
/\X4N"Qx,
¸f/c>8&<=J qQ

|ɒ-;E
PW^M{MM`n:$%dFP.7n{VTf	qV46#`Ej2BV4.-;ƽh
s}DJE!?\cc
endstream
endobj
124 0 obj
<>
endobj
236 0 obj
<>
endobj
23 0 obj
<>
endobj
237 0 obj
<>
endobj
93 0 obj
<>
endobj
238 0 obj
<>
endobj
86 0 obj
<>
endobj
239 0 obj
<>stream
x]An EԴR4dE0`DEo_3#H~2-ߝ.K>q!&_>?C95&-lߌr{Kobű_ú@`NM	6nYS;Vu uI{JÞ'jwUjF4HcUFߓ)A
{nǷS=VtR0-TS;	[y5%K'
endstream
endobj
84 0 obj
<>
endobj
240 0 obj
<>
endobj
69 0 obj
<>
endobj
58 0 obj
<>
endobj
241 0 obj
<>
endobj
51 0 obj
<>
endobj
207 0 obj
<>stream
xeV{TT>9GC,kgFͷhCL00y<A@l8KFLD4-W]Sӫb.rGchUZ}߷>
oFP<_VB#߱\w07ݱ
B_oHL33iƮ3Q3EG׬JEQ&,1ZmJӌg2%NLII'yMԤ1iBWk	&(}4Al6j	7? EKZ4_)NeWQhf3Lb̫TƋf|A`f3ȼ3*EF`PL2"HqOp}d}wѺal}~qo]696$KIt[)wɿ	R解'oiċ8Lp2eg:L$s_ޛ~\x擟w0 *Rnen2s6n] 9GܑG>QwhY1z.ƒ5[4dŹ8b5N&ݼŜ_{}jWX&>cecJw/p>j:0Q);3Kl/`a:2]:{\R7bԍ=0uPиhF1Ix/=؏Q8`H)旷={ygŏ'Y%UDt%K!ɯ8P:3?i^׫?TD2=ިޑ
xUя;X(qY6/+epE1Eq#!×c_e*C
-EĮ4B$@Xkf(kɜ!u졢0#7RޢvsGJ쐔hl;	~jJr#Z\~O#qf-ND;ÜKHFO&4< _LCS0B$?[hmhƑ=‘3؈ѴPs,	;ܩ44H8UXVS\Vꀿ* "ajT?sB cDGm+:hЫ"7b)TЕ{c 8sl~iZytI:99_m(\Eϻ$6*N_"{3j]#SnѕbQjA^9PJz)W[37YČmkPI}hGj[%OQDu>gZfٻ/B0?lރu;d>䦨R.rK
KŊ쌽$.;"<>OBam[fSG֛P_yXA{Ěh*ra1ЈMtЪsJ9C~&٠xRw0WkxDSiEyi5ǎa'A%I| tHm#b;8yO;֝~r1V?깥Xe

O&󌮌mHwëw y4JښPYʏ}xgN}K|":i.!a')ё5-+޻N,fZ>
]iCj(Q6/'n=?OV0OH)?z{'_݁T-;82x1D9It{dДd듌	憆fgv]q6VVz,Eo"ixaNRĄ0?<ۍG%uׂ+S%s
i%?{z)5`,';d=af΍J
i5}պ8KH;xկ9\kЌClc?,u+ꖼF;)]7peB]/8Tjx		:E)u%803uyK%ѽUi#1̺t[rl%,YYI<'S^zuJ
endstream
endobj
49 0 obj
<>
endobj
208 0 obj
<>stream
xXTS>1JvΡ*jhUk"RZ)$@$d B$䡨@bvVo{{o3wYkN]ct+<߷&OƔ;7Xx7{d_iTW3!xr#mNDE*gEnjZnXxWZeI	ܴ̄\YIܔ\QXi5O=,!3gY KiaoR^mKL	nĿY|an ,"+9E0Q^zׄy	[EI)RӸ;f/]avl=-v`;]bl7^`Xlۈm^6c[gX
Bӱ4RdPOzqR'49x!t2w
\:5oi9ӿn} 􁖐-bf$YCf_C|nR7&*D&<	ާˋOM$RMǿ<l
PJASTF(QiU[t
0zodPr[!sřIm`&n2125QiKA͑[\5Zލxһ]ό쯷_yA">E3GLh@d#6/\Iv<Ŀ_/21'k:F\kJA^B.JTupD*R2깿-@F~V*%(j-5ssz,уV\G?ycxPc
cDn/Z2~*_;/lA:YȠ@i*lhV8‰̕P[Q=`-
j-zOg:
G9呲
}2<˶x72tVR&߸[VΠ!2^O
J	p
dPM,v .beV6B4eC]κq-GE\Dƾ!yb6tfz5E0ÿ	:t]jV[BDQD{^AMAF-bR[Ѩ@l`N#q=BeRP穈
5a -$d!̓sHm$;tF86TTVa1p
Dʲ"zxm&a\Yxo]Y&Q[gG?	%I348UGNm#Z,V=%rh	gѬs>za.<a餘8ikyYqۆSCOt:ˉ̩އF7v'ۉ2qw fjjDxI[t]sh&-`bi|ՉUT,(Σ%'z&h%0Sڲ21H81mI]V D{^~p>x-Pmi)%)uы{^_󱭭V%iWd
$!	
ɁSINm&jd]@_J뾗v0]c8У>XdgZn|yP#k3
Ku`1:_]|jalylYgnW83p܆֬~u
-'iyeZC2&
3t=ƾ9qvw8jT5Uo-s'*(UJAƂ,(q!V?^}E]+")!PFNb?_7\6ߟI(DA$Ħs=g&$a"!ZFiEvyoFs-cWB!A)X/]T^B!icj`	$v|>v79>%S	Ҡ-?ΉYRXy,̖N}K?}}_&?~ydfs(]K
+30T4+~NT*-Vp
g `"%[\,l8mk!Bp9o܅	y&p-wjG1g<=!+Dd5ŶDf2E@Ʃ2a\ݴOAR*qkPCa++qJҤit$ρ~7~5# TFO"բ@)sF	sQE\aƞ7μ_e#F\}(G_fQ	)iӉiW˃1'S
endstream
endobj
45 0 obj
<>
endobj
209 0 obj
<>stream
xkTw'¨Zt;B[/xktmW*
-!$!p!)7ju[sv9vif>gyX,VdRrڶUS_BBbKɴbCTx9Y13Y,ܐ$HEl/R^[rzoRѱ^r,[)cx{DY	/lLaŊERƥElnA@y[2^Jf7n%I/R^/`6@,,(/9va{4l/m6coc[wػX2Ec/fcp\XbX{	#FDsr|<+rV!Kth@KVPPH
q#p	_|R uR}:j6KЉ${/;ǽ']i#7&CXz
eVy*Xq}ۃ~iV(Pf57
W?7V!˴H6j!#cշh:^D'G{hx:ܾxu]!{LJ;zn=;M#n'y/ގVL&|>`тR֐^imŎZ{P"/z9viK"r÷xoDO\a.#?Tq]'q𞦬="znq&QqƿګU.2:Rی>(^ՠ3ܪ~N@@]fVW4mu=8ŇXFgaKhź{mdbB\ٚf\TSFcQqYM
h,m2׶+ 
Ä}JJURdx77xkþvEF,lG ̾FPS1T0n˼JJf՘k
`MP٢V藍:7ګ|ՄzMERmb|ısRq
^x
TdFuepiF$
vHVy1ث+5ٔZ	,:^Fǯq4MuOޯDΒ7~͹`hJRܽin١MY\M"\0=ޔ㮧>@/~ϩw-6NO'%>I3
v >S4uL}ar5f*w쥶u6
Jp!iMVLuNi{QWsLk$k-E1mBaDn6R2)PL靋i2?@>3`3E?x%(Ah'%@w&بAqw4>p_2@Rd0J@+}`u&&h-ܜmgķo8&&"m2xbgo%ŏ6o 4ϸrB"}2{)#Ư߂kPR[e|3ŷë$wݘOX񎬥lâJ9ʫd-\8<R(H<	2a~CgCp ~Umz ՒT`J/nL'!=-<{kDDbYC^0O[?͕:)<=(^1̓0@2ⲹ[_3X`Eeݫ4>̄c,^B+ݧ[Za9*
|dr2BS)ׄ'
ȪEw/x~nyhPG*NlR^p:jcjqWmrK|I"n޵ў
endstream
endobj
36 0 obj
<>
endobj
211 0 obj
<>stream
xZ	XSW1{Uz-繂CD@D!3HApuVmժsI}}>{kչ%$K=ƹZ,	:	q֏)v`/
M{Exy	AE"iD{Hh\x`H硾ÜM:yرSHDn$oWG9=22tژ1111}#F69&0rxi2`gF[FE;/
Rjt[{ܰy#D0:gq%qK/߶"`vU;VZvbI]L6}!=l#7Je89PTj95@R+A5ZE
VSC)OjNQnHj=Nhj5CͧRq+O-&PjL-PUʑD9Q}T?JBqCR](LuQ3({*N͢%j2
ՓEnjR<3u촴SWw9vIi=~,f].׺zv{}5gvw=(|Gtyה^z_|yU8ITDZOqo{ߴ~NxmkCއ?|eѥ]w6~@n}
GP:m1s"%lF*;	@T$`'I[C)V{A~фl
 'GtɠS:tCm"r1S;(q,3u	^+Q&rt@SRcOf'y,E!U63d8̣eWϜ?_nZƚv;}X+b6V=8-*PXZLJ(# d)u}FeVF蜊L%
P)<y
N:XwIJ	K/ݵJ!_GCNG4	+S4jpx?K=*8j]ZYO"YHJzՈE>}(>>m|G
M)wb}q#ܭRv"`>p]iڜCzEuDυk`1?zrȌ_N5mٜa$/\ڛXF;X3~~zODpxn%㡇4uk*p گn,mmٰ)H`kc̢GBDݹ}&[:yZ%Ofl>bJ^[/Ǣh#4uʇl\HSx<:+nɠ,2$fƌQ.bSY SĢĢd(4-(wX0&qC07;n&
bȊD#ԐmDz?Zo%h:ꃆȓ@q?J8`+osa0*(9;|oL+mMTBplwz6Il#0$j;K\rX'LfH}	T/Qc =%c#~*_MQId,h7)%6|:I[_20a"5Jl)mhz؈%&	Kb6? W,.5#!Bih,
2I:&6S#ީўZҷ>M@Ij%V+)I3rzf=	iӏvL;Yc7=e	5E؅ IeQa1-LvEjlTJ;({'bei;'d_ڑӲB(aopCQ\FhUV("8P4S)mqI6BN'j۱'Eԅf/,v+:ӑH=:HiRs |ЕhYjX튋|ν;rɅ=g1)FѷPr1!f%QcL'#O]{:fj]ry lbۘw3%d3yb9>Iv7W&wHwdC+yTNⲿ0H)/мySGOqcXp~<NRQ֒|T|3+Jq4Ԝ<hsw[m	[BH&VN5׹(˦?%[{7Ent$5ʄH0}K^0fZJ DdT`AJHqgT(RUMPFZK"Mٖ 4K*
 9!bdžc{VB,!-C>;A
FZtiyjj+~'Yʶ	
Ut;rb&a[QHVd9Uu>CȊ%'>wW>di]k5n%zpʇ̜|2(ް[FѡwK7	FFr{6y3u"!%ʚ9rKMٓa39|em8lGUGDj?*g⵵rD
!"lqƒb^/6CxLĴh|sD7UC3﨤d0#,錺!-ŵYYiZ6Ct&$#mN/"6ETUF"-fmYUa]@2>20.>Z.ovLUˑNU-m+F?6yl(0/;6
w=}dC^OeZz{l)4Mt_#<|Pŷdj" 4t(liU^5VA
J8#5ģevGM
ɋyQ>EXPb21(PScG3NFQI,,ab ×%2<ޮ\	]9tKREIR$~f$“d)6o_F.eýp'PZ
E|2Eﳤʤ[	TZs|/okkP9/ =WU
*(}RDJnNc:ҿN*TP铅>4B,f8
5n!lp{|BچPrڦb'Jd˵`xwǒqp"F)[JF0>k@kl.wEH"FW(Gsw7O ;Zho #>
3w@'􈲉U]xH$dg4"ypHKn*P,I,)l0o7s̔~o~DVYL:Hљ_=~_zoe
XK$v[|hߊ}L&5޾ܯ?NҍG!|Pڴs(ˑOˣƈv\*H׀`Šǐ|jGWՈ<lQGMdP<-ػ/[_͕*t
r^
iij>+b;ƈk^Ω) iQG_^x髸֐sY/ݲ5(Zш68agZ(0[WM4n\Ͽ8_	MEIA}#43ߞ	Ei<$GW\.
+pJZC:d?QaRx 03e^&tW,M ?zJ~P;5cOp,?zu13%RXP`kjm	ޤc+I&fcM`+B¢C+c+ʪ9et/	;Y.C:j6Eϊ0]W.2\M)Ǔdsd{fCSf4nDz
x&:hCw/_Wn\}餢uy})V̸ޫ0WJ5ڂ.+Ԙ[{!SηNoGo;9/!ECGB5wDxDF"BBʣj
bM
Jղ9+UAPUr
DTėEElh;y a 'BO>x*d!W}r%rUF&"3Iød[O^kaP4Krf0>ZEJ(24imW:1YTg*h0KgFN 85$?K-no~/s92HrKRDKwYM*ѫKC=
iV>6CCEƳyQ4#wNׁƃD-kNpjTdJupnl	5gٯ-HwВuV
wuqJO;xP v[-l<@/aEDk2Vo-4>>,_z
aSli+[تyn	<_muN62UGvH$ԙ\kOA5msHڤd>/)(R	*:<AAg׵'$6/ȫgG]bVr-nMJ]NkYYb_F}aD|Y5J-Fkz5ݢ,.D¯ؠ"֟I>J/i4y\MVPʍ/x!½Eө:`JĖDžMbyv_=!6!a}"5	0YF1r~b5i$6~J.Bo$#}QaBCִiAwDZ5tlk	t@)cH*<Ť1WrtEN̽o:ml`^`M K5|7qy$~to<~]z*8\rŵ˼VaQUG`YkOr;7/\=#0EqNeGɬ%9lhd
aa	aK[}Qw䄂Q9|y<4|)q_v^H}BO3poy}^&A"3xΚG$*T=HS4&2%OC"~OB1C9(fɪsAƺ}^oa]A2c,m6ʫc˃CwŪ-wz,ӏ/CL^&hK<[hQ41kV
mƮüu#EIs"Y:m+̢+0Uhc)Q[-=>{@ooQ,Rp5:8ɼsԊySK+jO'O_51gCN׈ZI"86"¢ċ(Q,	iY)G=V!fzILBUi<3x*-l1mKש
\8w
D#nEOb+ǘSQA~I<+EWՂl};$')$M<aWr.FNIz&
e	yzS2 )@V}z?'eB͍$F0%,lyeqa36ӿw$+#:9.襏-CD+gAVY^$k:wLX(d]eu'65w])83nq][y\_i1H/NI7`G{s9l.3SCT;$ޛ%tMoh7J9Ϯ÷>tlB1D+6\I[p7@H[cI1mL}?B(~O2-7QM]퀛[ﺗ{J+6%d|)`
5?jI'gnhނgw¢X$7܁KΕ^>Qg9
?iXAlxf˖NKb[eAASU1jig
p
FJW✮b:ex.H*>T[DW4XE?>FvfhK6JO]-OHK .K%o_D#^edBRq(9Õ#1x,&GE":?
D^]y="BWg!9"i^V#(e!aIYN?|#J{ϼ2>d27ߺbSeq히t뎚<";^J\%{*CնL",xT{G~jYRᶎ;)*KoSlggB;g(r^Hz"ˉČECE
eO׮WB;uߞ1*XdGI[9 ̅*Rc!IAFyk{kVc}u`OwF[PΫȼ`v ۽$'6wԍyѾQooľ;E
endstream
endobj
204 0 obj
<>
endobj
212 0 obj
<>stream
xcd`ab`dddw441U~H3a!]Cg(k7s7BS'``ad/mv/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ
s4u3K2RSRSJsS ӃP%E
)Ey9E%	]L,t0_t!3s3~'6yℾ&O?o6+to^hSwm1I'&#z͉;&uΟw9tpmY(17gon3D{m^t;粃6X۝^oHy҅?M=w!i쫸.sq\2"
endstream
endobj
32 0 obj
<>
endobj
213 0 obj
<>stream
xV	TSg~!SI]}E*vPتVAP$1BGpA)"2%ŠSmGŪVi{9–83sNN?~߽BB̐>øna&q5/MD<>zB@ɘܠSDղGO)2E*fuzYHZP8B(N6=Zw8VV#ƨQQ5 zl^"JwLbF(D1tr憀xfN6"1kF.S> > >$b%Qb)1XF$D D"fs`}bB#on;Aa.k\	gD/K?D%iޤSsxbWpL^jǹ'_p13s&d&k
Bm^ү{FV33H
)B$n
wmT
@RzٍC.*?`vn]2|׳QXLb"߽
_[lParGCG>Xp'#D?σ}CYEmF!ݢPB5-c+6֙W.Eyq0'nOQf5ZfD`[kŕlnvQXj0
W;u|a?Wn\a0ш㛫?<&GaV20t.^!`ܱAMi54d	"I2LQ%miDS|쁅NhG?%#GIQ̆xDC`)x\=UWfdqrI
)QS}|| z)S^YDiTmô 7ٽZH'vX̣z192,M96y\W؅6nug/Fb!cVHYy\Վy
a@u*629Iۓ:)eib(|zJ_Xo6-v:R1[3nD!vDT>Bڄoϰ蟘6찫_J'؄H&;'!ANGVW[n>Zu	ILvȂ45lP;]ґ/X#*FTYT,
;d;I}SbCT3P&y"moaG=uf O,w©̀	!';^p*(6<"'@z8
m&)6bDB?*)EFԯ4
VA*Vo0h#ߓ._Jzr>'&3l:rTwe^9JIٖ3Z*\dq9%v݈,l#nS&Abk\CXR{$TrLTW[Y=/VB_Υ6ŝ>(Q#v䦳';~>.Ɓ۰DzHPӮUT*fJ%E'tDD[CخbpT40B|,hx
{mfJR9tagyԤBu1
o{zO;[_!8N[xCaNRava]#_+=+/'׽E/\:qߎX <|	;^NfR#aV$3k,(8g熲=_VPYX(uyvJVW^Qc&ڿn_"+D~FU)ahJ&:ހ7~mG̦҃]
$&=mA)٥h;^W|wDq~uu)[QZ
b41oVm']t8Ew=y(."پ-:
"l<7u?Z6߇IBh,e]N{289m`)={T4% 
@HQ_a J
yl6=kmp\ƤT=&?ݱAr7^N\Ȭ1)RiҘ&馮+O]N$Zy$Lj׎;&Y}a&s`8ZROJp۬6H勿ҥƅ9K,>;-YDb{=<_u7@}yN;85o_5B_\
,ZCTlF)$	ߑgfaDZzѲ¤`$]4+4(e:DIo"!^NsV@!Dt@l*.nec*&zv}>
endobj
214 0 obj
<>stream
xX	XSg>1zqh&VFm]GT;E.(((kY$KBŽ	[p֭Jm֥h㴷8ߡzvo{_H$>K
$ǎ>0@
z
bHԔ~+g{+ݨ+>jy`V 9}TǑKƑ~)sx{U/\1hKH_=iqcr#m.k>-QJ21ɏ, ﮵ob_RذFɾ;V>լH_!#y)~Uam
w6lH_f,+3kPŋ,.\<קG
_vvnT)P5mET7JSsb'%/'CSB)$&[%Ocih@IFOɔfj"Tlg"+r-u_]ۗj.lL𠅉AEmMmړF}IA|6nYn\Ҝx&=~KGvhiZ]9Dc\W0'CjHEr4毥UhW7/+9kĴ02L#!$gνmʔ#[Jd7z9\d.R
[`
D}YъxɐC^9؎kN~L2y)M*;!,8r,Ɩ
m-KUM\R9G"3yddHȵ.ڱ*R	vcmyI ~=DRI7!\ѕ+p7vX%h!)ۤR\!5[ЅE)h5"MrmYϢ!nX4Xi8.Xx3rp<'ؔRn*#op::]mAѪfޡ;&r4\jDY,.kE|c+T`+u;!.j;p,YJR/Sdwh }*$@|ϩ6mq**m~ _:I?-fOEYn6LiWrVc
pBW瞢aFm+c}hxGB.a]@ 䙳x2dFMϮ~..`멆wK)W U!9 @+#gex(?#ޒ_	*I9dCkCnqy]V%}}W*}ժ6ie"'PzM/WuaH)s6m_F(p%msTo,,2,~{ߊ-\+TM~Fj}|DutבJ\kɐZQmДuo"ܻRKڏ	hNk|"!}骋^z_6d:ޗLFt>^Z.6r6w97T`ҟ̥E
=4a
qT\%	e`SJMkw-+:=8%չԛL^lPNXBSԻ;ݔ^uܕbN0[9y/dq1Upՠɹ6{mJ[`Kݱ+%td'kQSTQv V
rzS93yn.B~-
8~*1STU{qNi;`8k~kvwȼL8WKܖRmo,eӒjK.7Jŗ@lߏ~72\Z+ˣ"[6 6M(Ԛeù6q"'4;(jyLp,g(N["#IY*RmUPbI[Sq `4'o|.v/%6$`=$YwmxvMD`gj]Æ#+8h4֛J
v=?
h>\N<*o>{jA[?z?C@O"q>
k?m@9yjr}R!ӑW]/؟jQ^{⹞[N'/\.3?G)ZkvGR\hA|Xጱhu#6|it^//KQ+^ڛz
>G1l(QjSumUBc)/hTxc}nڞjYuh%>aK/=ok=f#b"?NS{}ã7jt^]$%]f
?
cw:hpv]UtŕZȁd$FȷưGMʌ,*2	2&eo>G/,b'dyLӇkot_YmTӶe53Q+f^Kef΢grua.!zػi0Dyߠ(`{3kLhUT(9w
~{Nwj7|,@K:L9c5Ɛ.>tERNBbj>
`sJ
p,YFzfn{w?%BOXHʝ:G6	!o^.ӓ:ڠ
uՔ!\7Ø!#ę=ã{rR$+OFkJ2WT담PiRD!԰uU]Jmy%׺
"FGs̓_1%~L^-绱\*P7*P*1bY2W%L9+dQAuM&DDVP}Sbu ޞLdStRTy$8֊KR|NDAcVL/ט,~RND'$&V'7VU[:?;@߻-bH(-[yRnD˴y%lT]v!M
h"'#I?ʅM'N2Iۊ\aYp`;$%q\NUAq&xؙQW\ΞhqNKGW'nCDAo?{lyKY6[c]w!12!+CS?;@&An7Qk:VPr)5,t;m{>AmuW-iR|W
o9Rx$yHQgfWά]2.ڨR|wsKa,:sXhڜ)S_Xt:yOn̚Mp.
|5mt-\7*f|9I?_u28IAeM)~PdK3lp7=u2^\__FqGS'r8ʊk|7=M'`߁'>cFvf{FȒ7R}WQJݲt@ūZ~d肨%W(4٠oOKڑywT$꿿d{X*[_gyY09
endstream
endobj
202 0 obj
<>
endobj
215 0 obj
<>stream
x%mLSwo[l P"l†X2(X*\RhV;
2&smPB0̒-K̄,sfY\
|8ryrs1'C~;÷TR`,BND.Pj5
ld~f(ql3%l\f(f3
:le#[,c0f-:sL+`S%fVϱ/b^dtCg,(J8eMB *Q-ʏB`\O	~6b{g14^{d|'Q,r˒@㫿]ЦPg9duڛ@WRA&$V妋M+[
F$RSGZtOLU3a #[ǣOW1@E?	|v.=I^jzn54y)|NSx9G9ADq:uͧiFQ'Ρ>Hr*U>h{CpVTG..N0[1| b7S
YyUkyS
MN2.EcmA'HaN>ǃu
DtI
Ϟ/>˺ޢN+{Es&p^]"j8=*T3 ^y!ddaᇛS+sm}0cW5]! u1iz}G;?{Vuv:*oLnNȑx㜔{	+kÆYdD2sN:#*&ޑQQ3	#c3W}5;9Unw|/5!K=mM-ԃeOVx]Lr]v`z/RK?4
endstream
endobj
200 0 obj
<>
endobj
216 0 obj
<>stream
xcd`ab`ddds
4T~H3a!ann?"~.ȘW79(3=DA#YS\GR17(391O7$#57QOL-Tа())///K-/JQ(,PJ-N-*KMQp+QKMU;NL:)槤%ٙ@2
2sS
YV=?3~y｢wodSq̩UT/[`w޹Kr%+Ks{{&9~&8|z۔v>iEMU3jN2]̳ߦmZ8}eT9-;}籖XZT1wƬ9'4}e3#Gtݓ8V/Iϩn-ǵK~UI=&/it=\{b^W5
endstream
endobj
26 0 obj
<>
endobj
217 0 obj
<>stream
xygXTXPO&^KAzmPffHڀ`ƒ5ؾM>ɽߞ|?<ʬ%DKm9{H??ZXFޕd0lߨk-whJ(%-

6fSlf͘1fqGK:pop.#, j050zPfZ0B/4^#̜.'ƈt}e߲{U>~vzhItז׆Mg{;CçZ{Y#QRF]è6z]\df¢+	h_]&Z,Z˦(b 8Uح*ƟP4:c蝡*:WA4Ҭ 󧛴W`?#6(zesYdocȂo&Y~èzrQȃj"kY{KZ竧.ۺq
:pMqže`	88c7~?->|%;eĂW.+/ᡓϓ[hOϐ!؁u#48QyH{y**g[NRGXtyJ
]S
^~',vCL>CBV*.;'ԉ;f8M(Sr	J!K	ŞM;Mkų3	o3):޺-To2*;\}d/x1WNnﾤSwj:.:Έi50hēc3Bpq2Z\Ȣ0hm0xrnerPCIG:ƮE%}C#tW^JG\?O M@f<ċ$xo62A4YpYڱƜ0r׮͛#i+{#(w懜c)ZJ{0?w=H̼3	>}1$OW"/*H̒\7msI,;k@
hK&z!u+Q3iK`k)FT~7OG%2IL"2ōX
[ыԼȔC~d_p
!Eh,1Vۄ{?퀺]S--
cЋyM4~,
4B!LPyD___̉o,UqΤ6$v:=G]WZQ&iVxM})P(A}&Nހ$als2?ԲA)҇:\m.N,evx-:m$(P')QlEGCJ^Z]Zi4))=rXUNLo%.ل)VXz˘I92J%?.U		"-1)MQ
z켋H~RCR
5X`Xy@LdJ@zE@{(
恗dȿ~yJ>]Ά>WZzbXx]gq5jgWdz4e/q,kcPj~4F-'	MWk^NnF\3p@w/&M
 V,&)ަq@4:4Fdl!ąu!DNFɏΤѸZnE2@BMrev<ѯ1uKJi
9e;T1=EjU瘵oڨtƠZhSV6
AWpo_ʖ%%qFGdU]_QZD.cuȳOl5EWzՖPi:{ou;#>^ض}js,"̼b*b+
+:pdv%J*WfpO@=[*ÚB	9愋x5ddždYGgu>`y)fG%*͗EWr:'g:ߡ.(
4ҞTED'	a"]Z2taU3r=3}Jb&uR|-A+>T VbHASY!pl:vJ΂H&XfQmG'=EwڎWy5r
y3!%5Ueu_.::Sx'{>uD=
 r%8mM'0b~ḧ́޾+ok"S1xZGA8=9i8ڧ/A{oRH[Woo!#Ay{_	Q̢"4Q_<=--
T̢@fØ]@yc
̽
5ђ덝NgP1;^TT`*PIrBxB:TjU1͡}M%2@ .H(-ͪ(Nwpp.
.Z)0VI#oFE!bC31KoA7:vpj6z—ΐKc&eǏo>|&`e;'TGu|bvW/B
"vk6(Ah\0;ήjMe}"w$)-o8pB)OɢǿEMfvh2qk9){?YwB,Iȷ8D#…[pW&(pu,wW?V
A5i|6WSeahZ[>Vpkh:)fLȋAR
I2PqO⿱aK)u&z'h96/	T>$<ؗi$l}hy48$XbїדQ)5tͨ%[GVJ
}⹦ɊB/	_ˆP-(~E_8ycLDYGFEjԟiʉU\	R8hJI\ճ;4FE izQ*W@laŇ3̓H9.QưINqh3K?c#	s2ȁ]qJz>
?MIJͅhy"=Y5zГ7kљ].\]1	J7ؤ	YSUBDXBOXa;^#k򽵧Aoܡb	vxѨ4=PlE&#c/W|Dm:%8<_QZw?ݾўҿI`ɛ01$%0*e/_|!dIݮVxJWf]wL	\iBƵP^VXҽe*-OxuHOD]V$mbd|;Ko[Z=Ckuh]c
(VEseb+
2)*%(R%I"Vr(O*d!9FQ7KLO܆NΎ*ԸNF yCKgnǣ?Ӓ5++q)^$_G$6̿SqQ޲!rpq7BJ6uGX]Q]΁ND!Hopb=AOQ1X!Tu(
-]sۮ^}fw
ޜ.[N4e>?:P|${FE-oP!Zeқ)O[n-߃:ǔ[GoIuFf/yG7gfrZ$hD.W IHȿuܟV@VݕnO>e-@ц3M>MȧlVם&M-K.+]}W;k,|W_`I4C8}f뢃\0bC?_θ	셯Q,<\>Q\+z)tB,dஔ};esmi6"%
Jڻ	}2ȣ:BB	39?M&3yFF_~2X9=1WhΞH4lOewōUQUJP)'?ܹ`:	ނ}e0k/<-AKCE)N)ɫva8
I/"y/ч.:~aTB2tg-ڰWYk(sXpRA0'3B$>PU*Lɪ$2n,C;+'Q+?.[Ҙj~),0/iƓH,=zɑڛc{Fx$h>;(s{68ޫ{w/y{̘$
>Cf-X!M5m?ou>Ni\`]F00S0S,'<ҋz1ix&ԜVFŤ\ZDde1{ 7_#"Kh5dtImy̶l[/
DQo`

endstream
endobj
125 0 obj
<>
endobj
218 0 obj
<>stream
xURLg*SE텨+sR$$20:c-=J#<	XM{m
b-XtDe.4[Ȓip̶,&w1bǗy޼yQyBv&h"JM=u_y,&,/Ʒ7/B}gg>}EK;*Z}{%_WSc÷.	t)̗7vIR:
UG.~pT.?Xr>IG{ܢC:
yV[Z±Kz+>w,;ϱfPE764
HE1G	tb'򩷩BUBަhђtJŤ,,d܂?SU8L)h0#i"tX3Ϩ4-͙_Ϸh
4ua"a/p!cԧ5h}T^a!(
!*{?َT19W=gO79Eۺs3ZZfH}!tN|+ُ7kCf%g7R{ܓYH19y9نǛXKxϸlaڵxbgN'NX#rL??t)SUP$GalPIc,hOFДp}ihBA`"pr$1mx]tHK5zKQ2'߇d&'v4;S&:T,k-}_ěFK%xFI&
jpZ~EC'i}plg
1;U%yj#E6$$a4eoUȜUSglaǛ$÷LQ(eH8Eξh-,WF-㬣
endstream
endobj
24 0 obj
<>
endobj
219 0 obj
<>stream
xX	XTu?0sIɚp!~)+2  :,3 ;"0*K}4+-KLս}=yAH$b|Lau0Z$~ۜi*Ć:qsbx|!q!`gxʨgwS?b%ć:F33s^^,[8a*Ql>+B^FߪՑk挟2U1}Lyy2sJƕ1Uf53Yü3|f2¬c0S4ƛqc1әf&yaܙhca<ƁqdF0h~&/Z)j$T).">ed+qJI#b62;,=dǐo2
jfu؂a_?3φ~aCxC:و#xQȱ7U"aكWWhA,hID(.dCpI

)j޶cb bs
u㳣ZzI(--Nfmai=R{LQbFZL3C`?,`9`k ,2׺+#
eڛ06bI81}\BnE2 DZ
o@'w%#<Qڅ^dL$_68x?a6.CXГ*>rQ!'wєuп
VcI!9<k^~''AWD25,ڣL4HdO0lX[i@|_isWCMd>%ՂNNA֘(l=ɧ	7$WIž˗8eSѾX2w>o?|pQ+`BQI|4(2F`/iDmp0TWBL
e礪rbʷE^LBs!˘GӏƂ{
T2 '^NXv
P^%;Py<8Nn7&Vȃ.ZVz1>(_-Z}Ip"~ǝ&i"`,
., fslbrdހ	|>
><xߣQ.?n\.p%PTNe	eքsD?~!PDZ&2R	rI3r#cgȺ쒨|W1-qVf/<5Ii|rzI&O,
AIJ4C5r>s]P=
+'0`n\ZvigMcǟ
\7ts8/_bb}pD.ذ:Ɓihcjƃ^!Z(FBB'ͪxH³P`h
+6dJxHr$,FѰeqAa>ʡPom=,g9!ZL> &$Z K~as3&fAhrڜd(`>^G@ D
㔾Iyp*+ŊQܐ`өr*8{iĠe%
b,weKRCScu[bghJ.x7dݐKϷ:UɷGYja|ʡ#3uA_#^
I9wXK
wľNK7O&8-gK.K[G_aieAS:H)7t5jaYh_kwjARCW
zUYIϚ8J:#
V|¢yj){`롙Roj:dDSnlkZHOI3sDb1pt$943`
l"sZ,'G&Q0>_^9.5NHX&hl14~cѧ5+eOtVjcBȆHJ3UGEƩS+ǪdBe3:ۨVZb!%KMɒwl[PQ&7@PBlfyːi+ 7j|P$+.6׿Fet[DTOPK)~nfD&PTxw+2I!DyY%$k,5(t7AU``ݳx<:TRTlh5tn'wI]NFvf6d)'8d.Қ
JFdPri:ԴAU!DHM
sI:@xV0GÞCY2fJbKd쿔TYB ܀>7 ˊ(RH??j_Wt&i2nS"ʾ0)I˜!TNЂwYlm!Ѡ-"0TYJb-OqElLU /e]?upMߐ`ZFF&o୑AA#fyFq^,%^oczV\zIZn[Omڶ58>j!){{ڀ'^\~ډD?
y7tR2%Ug5ƶNڝA5537j B6o[#PTJ߄\_
+IXSϡSItG=FPRNP{n:dIZ_^:BGeטv6V般̓=ѝW
ܽcyy
RIILK
Sm92Û7qDGs>on¨
eĵG7)aߊLk}w,9k:fڴCd ;!"H=|&DMfk2s@M3TN)|
DJ6&[
ڸW
>dCQP=7K
endstream
endobj
94 0 obj
<>
endobj
220 0 obj
<>stream
xcd`ab`ddds
T~H3a!#G*k7s7B߳O``ad+ns/,L(QHT04Q020TpM-LNSM,HM,rr3SK*4l2JJ
s4u3K2RSRSJsSn%E
)Ey@vfq6І&Ff".fFF?:wfD/,..\^l+~,_|
G~=cs5LXU<-jwM7ub)[Vќ]wN璼nښZz5K>o-Y][WY1}V
{sI4wT45w4v4v7qTά={k~i1cΔSWwMk_۱c_~Mgɵ{\ e`W
endstream
endobj
87 0 obj
<>
endobj
221 0 obj
<>stream
x]{LSwoU|ntsMA4ٔ=l4SAEPZJ_Zz{z()":NDd̸?4˲]u_/99H$/*h͓h[<{9
?	4/yu!YvC4\4h**ueYsjTڪ2eHT(u¥ZU]V5(SiZh4*ksڊY9
cREUT
ZbFxʖ\u*H]b6@X)-Ŋۉ}p/,$3rgڽVaumE&dVpG/I:-ΑODZ.J'SVd-Qh3wM /|wxwѵ*3;Now-ʡu[#gx

_}9xũr]@Y
zo18Űnob-rx]4',}#R+4@in7fX:H#bĽ,$/q71mquB{n}eG
ss|NnW"
endstream
endobj
85 0 obj
<>
endobj
222 0 obj
<>stream
xV{TueCVffJU	";;T^h01j9=&M{ޜؓ9s93=yg|~|jZګk7\.䳋fʰ{os0wvߢ?l##Z]DfZin7 Lcpkkv]nkq(-Cng_zVZ2OvZ6lcv2=PSm:j FC{8ΩqlJ7g//nyܮK%L^OheI\.$A
';bf	&&wixUW[q<X#h	;rƦ̅R-;V֝˅/_~.(CWMzH2p([|v4S_	[nA92~t)Ejk}{WM>fGǨK-|`v4C
' h}*RxW-k*9@cPmjިQbj
ܣ~*D(zT*a86^p1
nW\I&Бʄ3TPJq:]`z.zG9!My$WcFwPG$CQ*#@69x~iMJRn'.ox-5Pϵ
z(f;'D
F!(MG/A&}Tn+\Do@e&=I!KtX)9=%`Ca8ԦUBsx/Ng BhӰ0K,:rqje'/JkK3⌬MذMe~wF7ݍ>5~kn?ËxmG.GS?JO3r`Q>
endobj
223 0 obj
<>stream
xmLSgǟT֕]{Mj:3nPd]-ʭR	i	DhlS$JDȜ/ٲ1u!K7]6~qQ%6֚~ɟA90Zks(T_aW5kZ!O-riO97|is h>WS&lYPRR&Ux>*cS2nr(RVxׯ(yڊe_d:\ShsRܪH<)KV]VmW>F"؊Jh
ECgP0-̜fW
 N>EuKz;ptB`7m[Y*?-OFq07Q``p2
I-!iYp{
2B]x&:ʓlWp"U3KGrr_OK_h=ɓ>$}>
endobj
224 0 obj
<>stream
xY	XS׶>1prpbǦi@aSbHP;Ό:N0a`G7/O\9+GCg,41_#X"w\hޝBiphG&#(j҅--/ZvUp޹g.?w5kO:m3|٣vz{qoĸI)j8AޤVSoQHj
5RN:j=Z@6Rq&=ʙL-S	j)DPʕJQӨߨ7({ʁSC-5)b(IzS}ՏGS-@jLeCEROE6={\OQھ҇$$Fƕs|τ^z>K
+7_a)P440sۃ*bdzMoWӡᐡC
<
uzaaIBP`cVv1|(@BB.գp7-LmPoQS`trN0Z:K^eJ{[wF0p،%|~T[FDž
!|r ް~q9Cq;c%61A1F؎Ŧ-׵Ўi_||&
TS
:][vc
f!ސm"OiAd0DX0%YJMߌoތ>{+ׯyۼ&*PnosWBp-G5ReJBr*V+Ӓyy!Kr聇@ų͑HΫшq
"cKM5bZQe`bWFb؊et]69~Ӿs[bߊ~=VYe/?5,xg̒%}xH6(ܕ	(To}a"LcmO$n]*{!#T]G(}_L9Ã yH[%'.Ǜ7v`l\O~gGfс:k
bCT[=]+8l; }DVTS]4k
9t[}:r%[
Z/$_%fW
$Fp# XB7䢌.k<ԖW*߸=x'lչVgXexgH
b60qۻ°?mXijW[`fUn #;*=\#vy(i{|1~{ȃs^Ui$RV$CQ$E..@ʸc>gҚn6VÌ[2̨ʴbK'hL]cuƓHABOP\9|1\9& cOϽԿF5("X(Glt&GF#%:O8֘mP,Ej7K9Ng5sQ"˪E~8&
q]V߹+n)3Dl5sP'bz%vա
ʿm~5j?0 `Fi‰1m|E
ȿU!*T0XXGw=jUw`A6Ĵ%(i(ˣ$)z=l[9|\ZpeW_+[~>KO6>GS43@(o?ctg
D~~z-m)USݢ6F/߅0}Y}gSSWgF6,*37w’ނj{ˡ쁾|7>jC`mcmg^Y}tՒ$6S`9]?5G2O{AƂjhwޛs~;&s{iǐ9ߪ{Q(>me]&,{`G?Vx{m_.!>cۖM82s}Iӕ֘8+ezE:N6&(QXO#nND(Mje[6hrQSS.F}Zvzq,ocR-"ATu\
Io<;HR^Qk3PJwsF.bjFmxv힍>0drKe^m*RY@Qe	QHu]-%a΀>3)Cae%ﺁ3FN9eO2ZEHR1E{HDlqQv6dZ#Ï:!q+7%UBj*R:ngszO[F?Xr$'g1{V #GT^(߳سk[;ڢ~WZ	|cMmmFXc4G
uYeܠ-bb[(xRLX`JD]BTȯBdr%6&^-@xѓgxo\7Wӂrk
5<hmN|YQx\?
vĦ2xvJсD.-701(|K9tr܋swHJ:}Hf"$#t;ZBbHR}m_uRIxpzxRre(:z*M7W
4 &ѕ6m[9{=}"D2
Q2YTLVU__]]yxilz4<;.ӗeRq;wҪ;s5anGWK+#
eHʬݾr֔pesX;Z!"mo|GӲ#;ԙe{S'>cj	Ȍmu`TMqHʮP9vhK}C(hpmt6STC~w>8>gŒ.8`!Fp r`fe>	C՛lʿ@ogBxs/z6YuHKx*vVX|ЮjבV[DL
zI6b
F'D콭;~Ac떟z_B_+с^£Ԯ]/[!`gcN8`U
2찹KX3CMLYEoZs0p	}S]ǙגZkvȜq!:`Zl0/6c|C9MYāh+

Q'eD"%bl6$0scݝﷅjItF7OK:
0 zlt'{:PA=ɚʳs
󹦽G ΉޛuuǕ|vv^zyitR`i_.'`jKlȽ8=DnA
\oxW?|OM+IMIMA4
#PEy]>ôZmQn*90sw/5e	#K$^$L%`5raQ`k˂
aED/0&8|jJ
hWg̔F%LŻCQœ@'J\
{g|FQLAKO6%m؈ʸ>!îxhu)9[X*RY)Lv%-1tTq|m&*w訶_"cz΢B=zo<ev̖:w>+ب˩(-[i QZOkTy)*2CEQx$u
grko8oצzQ--(@eLUtq\:%Mab;kTPWR 6FiW#9_dsR$kx`0$%XE4/?'+h'RZRTԦ=F+b2Qr((*N.Hee:]#̪pGit	j! B#I| )xMH.!iK#ؔ(MI)H-':pxoTHh@}xsn63(4ͅ1lۛI8wqK_ICfe塼TG'p%vPˋrLO`5i9)! ϙӧI!gǔEpNMJHSFOupb4cp4/=P r Y7o^hWl7#
UEhovAg),5F"<,ytߑ O'Ug0iHMF)qƕ)ىƁG5KGڋZ"A[1rmw5BM_&ގ$k8uRc3"Q]i;r83k?ڜd&9z"^A([Z1{ӼV֔꫒sSҳɳW\ǡxMBRZR9|p%u#簆#nE'PqS9I4Uiw7FhZ̔DJb+9Q	0Jr[ AL(R}	W$&GԠʳFNED7<α?[vjI+DTGFM~Ȓ>
endobj
5 0 obj
<>endobj
242 0 obj
<>stream




dvips + GPL Ghostscript 8.71
pdfsubject

2010-10-10T00:28:31+02:00
2010-10-10T00:28:31+02:00
LaTeX with hyperref package

()R. Vitolo()


                                                                        
                                                                        

endstream
endobj
2 0 obj
<>endobj
xref
0 243
0000000000 65535 f 
0000097219 00000 n 
0000180656 00000 n 
0000096941 00000 n 
0000092903 00000 n 
0000176332 00000 n 
0000097163 00000 n 
0000097361 00000 n 
0000097689 00000 n 
0000097448 00000 n 
0000097553 00000 n 
0000097825 00000 n 
0000098669 00000 n 
0000097932 00000 n 
0000098034 00000 n 
0000098155 00000 n 
0000098280 00000 n 
0000098409 00000 n 
0000098539 00000 n 
0000176247 00000 n 
0000000015 00000 n 
0000006983 00000 n 
0000098816 00000 n 
0000113722 00000 n 
0000157647 00000 n 
0000112407 00000 n 
0000148745 00000 n 
0000111020 00000 n 
0000140850 00000 n 
0000098858 00000 n 
0000098990 00000 n 
0000110638 00000 n 
0000137255 00000 n 
0000099141 00000 n 
0000099273 00000 n 
0000109435 00000 n 
0000128099 00000 n 
0000099405 00000 n 
0000099538 00000 n 
0000099672 00000 n 
0000099805 00000 n 
0000099937 00000 n 
0000108920 00000 n 
0000126799 00000 n 
0000108439 00000 n 
0000124190 00000 n 
0000100070 00000 n 
0000100203 00000 n 
0000107917 00000 n 
0000119696 00000 n 
0000107638 00000 n 
0000116507 00000 n 
0000100335 00000 n 
0000100367 00000 n 
0000093149 00000 n 
0000007004 00000 n 
0000012675 00000 n 
0000100487 00000 n 
0000115927 00000 n 
0000169490 00000 n 
0000100619 00000 n 
0000100651 00000 n 
0000093326 00000 n 
0000012696 00000 n 
0000019159 00000 n 
0000100738 00000 n 
0000100869 00000 n 
0000101005 00000 n 
0000101142 00000 n 
0000115625 00000 n 
0000168265 00000 n 
0000101277 00000 n 
0000101309 00000 n 
0000093524 00000 n 
0000019180 00000 n 
0000025436 00000 n 
0000101407 00000 n 
0000101540 00000 n 
0000101673 00000 n 
0000101805 00000 n 
0000101837 00000 n 
0000093715 00000 n 
0000025457 00000 n 
0000030734 00000 n 
0000115096 00000 n 
0000165334 00000 n 
0000114502 00000 n 
0000163576 00000 n 
0000101946 00000 n 
0000101978 00000 n 
0000093877 00000 n 
0000030755 00000 n 
0000033811 00000 n 
0000114241 00000 n 
0000162801 00000 n 
0000102087 00000 n 
0000102119 00000 n 
0000094039 00000 n 
0000033832 00000 n 
0000036997 00000 n 
0000102206 00000 n 
0000102341 00000 n 
0000102474 00000 n 
0000102507 00000 n 
0000094227 00000 n 
0000037018 00000 n 
0000040278 00000 n 
0000102617 00000 n 
0000102650 00000 n 
0000094393 00000 n 
0000040300 00000 n 
0000045698 00000 n 
0000102749 00000 n 
0000102883 00000 n 
0000102916 00000 n 
0000094575 00000 n 
0000045720 00000 n 
0000049598 00000 n 
0000103026 00000 n 
0000103165 00000 n 
0000103198 00000 n 
0000094757 00000 n 
0000049620 00000 n 
0000053882 00000 n 
0000113270 00000 n 
0000156339 00000 n 
0000103264 00000 n 
0000103397 00000 n 
0000103536 00000 n 
0000103569 00000 n 
0000094947 00000 n 
0000053904 00000 n 
0000056106 00000 n 
0000103681 00000 n 
0000103714 00000 n 
0000095113 00000 n 
0000056128 00000 n 
0000059589 00000 n 
0000103802 00000 n 
0000103941 00000 n 
0000103974 00000 n 
0000095295 00000 n 
0000059611 00000 n 
0000062902 00000 n 
0000104073 00000 n 
0000104206 00000 n 
0000104345 00000 n 
0000104484 00000 n 
0000104517 00000 n 
0000095493 00000 n 
0000062924 00000 n 
0000066675 00000 n 
0000104605 00000 n 
0000104638 00000 n 
0000095659 00000 n 
0000066697 00000 n 
0000070192 00000 n 
0000104715 00000 n 
0000104748 00000 n 
0000095825 00000 n 
0000070214 00000 n 
0000074611 00000 n 
0000104836 00000 n 
0000104869 00000 n 
0000095991 00000 n 
0000074633 00000 n 
0000077444 00000 n 
0000105003 00000 n 
0000105036 00000 n 
0000096157 00000 n 
0000077466 00000 n 
0000080697 00000 n 
0000105113 00000 n 
0000105245 00000 n 
0000105278 00000 n 
0000096339 00000 n 
0000080719 00000 n 
0000083668 00000 n 
0000105366 00000 n 
0000105399 00000 n 
0000096505 00000 n 
0000083690 00000 n 
0000088193 00000 n 
0000105476 00000 n 
0000105651 00000 n 
0000105804 00000 n 
0000105978 00000 n 
0000106163 00000 n 
0000106196 00000 n 
0000096711 00000 n 
0000088215 00000 n 
0000092881 00000 n 
0000106284 00000 n 
0000106467 00000 n 
0000106657 00000 n 
0000106845 00000 n 
0000106996 00000 n 
0000107149 00000 n 
0000107302 00000 n 
0000112047 00000 n 
0000147955 00000 n 
0000111621 00000 n 
0000146641 00000 n 
0000110381 00000 n 
0000136540 00000 n 
0000107489 00000 n 
0000107522 00000 n 
0000116801 00000 n 
0000119989 00000 n 
0000124452 00000 n 
0000127067 00000 n 
0000128657 00000 n 
0000136757 00000 n 
0000137614 00000 n 
0000141254 00000 n 
0000146883 00000 n 
0000148178 00000 n 
0000149186 00000 n 
0000156638 00000 n 
0000158013 00000 n 
0000163032 00000 n 
0000163816 00000 n 
0000165616 00000 n 
0000168507 00000 n 
0000170046 00000 n 
0000108347 00000 n 
0000108835 00000 n 
0000109286 00000 n 
0000109971 00000 n 
0000110147 00000 n 
0000110548 00000 n 
0000111486 00000 n 
0000111806 00000 n 
0000112304 00000 n 
0000112913 00000 n 
0000113016 00000 n 
0000113537 00000 n 
0000114135 00000 n 
0000114391 00000 n 
0000114781 00000 n 
0000115486 00000 n 
0000116401 00000 n 
0000179036 00000 n 
trailer
<< /Size 243 /Root 1 0 R /Info 2 0 R
/ID [<61EC6EAB2C3184E839E923A6F001E460><61EC6EAB2C3184E839E923A6F001E460>]
>>
startxref
180886
%%EOF
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/super_vectorfield.djvu0000755000175000017500000175247511526203062026225 0ustar  giovannigiovanniAT&TFORM1DJVMDIRMY@$VY@R2brZT^P%9 z|)g\kk*p7%djcC\52~ԉ-E-|O&
}q~*e_BaT?܃]>٬$]2!-U]mudFORMDJVIDjbz%kRnF%Îfn,QZ6
Md؄XYަaAm}`Ҝ_ͽ;SrU[=Vo!T	ӣT7
W1BLmN!Jxmx|0ɢ{VN٣R	]{!sZď+e`t}o.S^5nom|(;'k7ΤʇߒeH
:
SK9IVzKdK둎wUz i]o0NNM@`XmȰAmF
xfIf*y_{8{/ߖz77sw"p:XGC
AQ 4ȅYiZOҬV@E%ڎїEE|w;U#%jEѲT	^Pao0fcM	!7#u欵-+-aѿI!U`H\RC9=Z KX
c;)-ki#f⤉!'-fߠ	ʄ{20?ov8oIKx̋á{ݵ	S:I(AW&gR!gǑ)^kqJTKoe]g~3ߕ5bF,EFZjo~0PIBr8!_(nrxRzם/,A	rĪA+ol>a|UvO9+CW?
&pO@t7Łm{2:EǎJ7.8^#/%ZʕPKWDkz&RaD1灛u/d6jYtWejt "^OBfz.sMaDM:,a4Ʋ%giĔS1;T_[5]+ 7fghÐK&(AQK	!xBR/#R}3	
X9\~P߼#d+׳5WV͎Uafc;>%`q$g~ 	`v	}xth/4^Q)a6n潄LTb1yVmFHW={=Ygs6^=_n/_ѽv!(b*8B5'6 0ѓHO-F1#]='Ֆ;&naζtfL0Nc>9yЪ6`jqH@l1jhTe$(BTH
ΝXYZ.׾-ڻ:E-%"mWGYyv+$~iJUXL`AX6{}
c/EFȮi=tf$8hP9sCFyc%`29FNwbW"pz+d̝Rnfvt4D'r4m!_2Mgx-Gs=ʇ1687y1M̃uŗְqY*)L୬XMl9m2w\o5n:rJa,L3/ȷɜN~*5j̩ZD%ο|At!ePk~368=W7N'ä@Vf߰KNKIoIG'f\X3GQ7u[bgKO*asW\	m)5du)%	68,	,!@~_HFpm?eGkqڪ(E`KL=GvK(]?Ͻ~#/R,
z\i3{P3n7G '5WQt9bm?*x	gYXfՃVVSetRQ ]WO],
ޗ47]6l
P<,TOYQW{ow~J8ȬpxQHZ_}[NZ"
!+,CIxohư'$W_d%݆>-|Wno@BP\LqfB[Aq`Z9pRGioloXє(ac}F4iIڦ24/)zj=,Bi4vr6-9w  ,Aɉ) {ws6AEw41"+مΪ7zAUISfZ?uR2NBriX$IBPV{z&Ҝ¤𫷫VM$6Bȿ&(5R;DI(_kxe]+h<,5Tx`~#-pk1-}H1gBaoތ-S=-ѳ_ZE
(āpe{Ց%c,8%,YUg@cH)o8F1Jm7yd~-,L6w]Iw,+‡]Ider¨>!{CHXUK
^8.91LiN!)`F+"ܽIuùߊrAZ˫[h9znfb߳ߙOE!7RFom5v?E{ÜB$пPb$g[{qRopҝ҉q
%&Y5]v+]grϕgUSz
A_;IWP׶@hR$}ޠū5p\
xI9t. 9i"zQu?`#.!AafXy,y@P9/8f_NC՜j};bN3>g%L&מ>6.ler^f&T>E-lHnܡN\Q_	z<]!iI@%$Qfp55Z1[m|t>oƎ`,%"۴)˖*fԍ.֩@r>wRаPewQkedgO;4/_CT1ٳP:7`v+s^=3^-BoD+)$u|+tO$~B
T4źKRNƨwDN)EQ
l]]Y9x~V^G7
[0/8;2kfZ
cf'{ΈQ_VwƂ$]N/vD6@R|E2V}E~NHIU`5),:ǝ#V`[m\"\,*`CIm[S#rDdȩ!?|mb5xV|߲b]L_
3!/xHW7.Хg9Qm풬f~@0:fvTRO?/'/
#/7!#ȟ#^giܼb^ȳ\Zbj>RVd3O3Mq`'+4.dk9?e]pv	ҹex6	g":D;ub3JI]Cֱ4~xgѺ?L&A$0I0p'Wr]訙K
vj۲s|Q2#>|L#F.iK-TztPwfAbEz'|=4	-$|@
1ZҴ~%./~exvGUy,JHvc<"L:gN#[CvY9r|xꓸw\lt7$+1]*|)}ƍUcz9ΐ8[زN#1h^jkS
Si'"Gk'܈WJZ;@+cGI73ըtQh1d`rٍE	+ٽ¡b];OG*TnnzcgaЖhT[39d$#y%.Ol6X	r)KsQDLCK*[Z6E[iEQ	ZobU$igr) c<{e!L	yw^w(W#KveJ*akYDpw'L'ɗB5j|rCĎGSm6.eyH85}*CyON &vT>G
ۋ,JgiQ*Z9#l?KNb,'n-,nHTP|<&.bD~|]I5NR_H3QE:u`%Tb2:0-[RCS&jJ8Ѻ|nFwavgg
zY3tJSɬvlۖ數]ec/	̢hB레
$>Ak") `Y_G&Sƹ#yz	|f38N(xG9P?q%XzC
L1'dA\$^Ҙ
gbuJ~4hEB^I]vzŷ4P=DN8φ8;[S-ک^SH{>F">Pdne^e,"0w*O~nzraݣeO:Q y]Ή^SM:*Վ8NqRYj\?M*!EZ-&}ksh8P*nD(~T/]U[}&$[YUj|`J'H*=}f]H3o%9qYca,t*saH^
\=(w4PZWǎ?뒵t*ŋ/n
q!sIgDmA8q$86F
'Jb@,ǧlʇ\DG`2$:>*mn7*{R:B1t<|)}vW'WuZͶiDLОE8n׻Ɔ'zy!uNMtg:˴|vE8n<ҫiqXT*Z
`*KVPIN>EdZ<e#'T|;a߾]#+F"a7됞e*He*3~%VK
10Wq*J*uF˪
V'Be¿aנva%z&W/?Uv4egfYv*ì1N2qG?
2GS^$-HJ|mnGM7x⯁Z25ohgn\2cbc۵6Zt!6!̓%Yl|V#s&xD="=}` ֽl\MCbSѪ-xzAo!$h.=k3ޕB ֊5_S`e[11-3H9Xr-jQ5.6zǯHaű돢;uoEQ{
ir>:2AV pH衤NZWÊQ	OeCFJy#u\Y11:gbXʁXQbwܴj	BAO7!>LS6_f&vQ⸇zRUMKq]Fؓ']
~-@JJ>)1	7QmPS:)C_ +qIxF@LΆ×ׁ|ky$<,^(?=΃Pw6pR>Aƞӡι;M0D`xAh):y;ӭ=$i
@ƱOp"$!*L*Q^q~eC5
a`z慫Th(zt;ӽAn D{_JwPÒS-;Zc!^mĪ=׏fAs>SrxFgK_|o!L?r<ӛKYptbP21tIGV̱iYnH^FlMj!ߦqKbx	RTAl*$w,V;0N8XEIWbrHK_1ӂy=`Y7^o/]3h}/c]"($qب(p9eUuVY
,\
#9_R
:nFv+q^¦=Q[䟾&
')
k\q|՛|gޫܽ`.V1>}ֹC
fEچ)#;0
@
٪
YȒ{QHr"劕ȧ6AP]֘ٗ`cxS]l@4uB -tCd1ӊWQ
FQq!2
O5ԇ4/K"LRP_-AoKk[ζm_^(2:{SgEQ~D$¯Ua2 miLvCZ.Nff;":$ť.fR[}<@),>iX*
gj|		/K)*&t!qd]E=]:>(Tqn	D]z*fܶ
_M]]o{k#X*k.3FRgbK"rp߽So*]@4^9-N&9wBf7¾k~=O^ J,Krue"U=,(S%ڎ	h1!5;@r_?ˆMFab%
 Q߉{/YYd^@4kZa-v8_OrTi#U@y4Ӝ-LH#j[,1I]ѩWNkW@Y4Ok,d[^JY50(%ywpߑneg*USUΤWթDaw
pe͗H;%˳Xe0+L'֊
r&!ֲíkFl}~fpG	E5Id%lY&Crq>۫}x0
]$J5&[#KFIm/s5}F2] ZQZ)
ofS|cK3S[>M@PNRHg[>gN'23;ɁrqM%Ǝe0^r%S oʿ@V7n2<҆sGs1i4d2io7Y}˞otO.\xlH &ۉ2\=|-p@g?e3@s6oCc+UAeO_.\ز5@n;}/yL.p
.pT/R,'t
*D'?}:&f%wBwR27Yôho=#\/ڒ=DQ)Pt\wG9ʻMuA"ZU$6>YZ#6M?1MdDˑ
v
nE=VlQP*fF|Yt[֜h@RCh+A8ߣ(8KKa=]v0jjpbzg'Xkz
eo"kۓ[TEޞk|,5-N3)Lr]A

δ_{9f<u"<8+Un/9y/1˃HT,f]ʼ~,ktNzB_2Z}Ppڋ|73†RX07KN1WFIozO/ 	`pR\%:)aMz7j"iײG]lM3{)PGgM1C!MxS}\.!7)lU`b7>[lr
@9ӿS,&lGauI;.z-.\M'ENlpm[GҸd	r9klW0_~
֮5=@>t(ڟ9b7+!.[%/%>a2/ŀiQΈ)ۢvvVz+2[7 ɹ9n&FM}1=mCy6jCp}߂̖3
RCXM$o(@.K56y타|K+eu/VBsڙm&_l>(uEfi؆!
ߏk5=M͒ZFG	eT~PzOeš|(	L<Q!@OmAy?""徉CN

1HkskhDi80ۘk$V]6zY;r@-O1zT^%l2oLߴ;u&e%&K7Z)Lr)r,h]Di.pq850^'n9]mG"1k܃!(~g{Y>?Fz۷]aJaKxڒ,OfCxiB#6}`XR>H
_23qWDshEeX+H
_|O:0
Lv(c[bҋɯ}=Cj^**0ϏIFX5g2[˹r;]g
P|
fh'',X3\]wK8I>L
1>Z~z+~P/Ecro;`V59ŢWFt2	ĩ
}/l7R uZLy3#WZED[KChm7kzEK_Ns^#Ԏ<Ԇf@)[Q*ڏƜ\A2	
ߣ|ω4lĵЮ.*80Gyiag/ŎdC=*iʹ:=,6읛g=Xz-[#O'Gny{7;M5YN8._"WV].=@|lDaM$C:`WFX>ߚ:oSZݻH73%xYCLĒ;_RdgmV)	:ѡXu`*~Cvӥĸڵ^@
qHe=Rbz½D	TD)֠"Ͻ07DzVI87g~\pcTp.l6Md=\U&"HP1y#ؕvTse@JeA˾ih%S>/KsͳZl%4&]ҭ]>oa
Kc]1BO%&3&k2鯸qSiMk屎!#: I֗,׃ǢXyu5#㭅؄SJ>Td3rYLA|ܵY攺'/Ǥ$SR%Q螲jJ]>u}|[Q˙ \?AJejU~g67Fc$VH{haV(seB_:n4_6襜-67*>iщл7:GG!XnKN;e-ͭЋَa/9,h99~,b
 L%n]_DIgY#P*D^`IΟ]_AԷU!mpK~	Ěo/3lX9[Eo'ЗOw,IY<,_jo<F5ûްTTnAC[EVLȆ1eE6؆z9[~%E5zP9ɴ^+2Q(D`=jaS߰Uywav{x	x	s^O7q2VJhD{jyzwd1ߥ<%bBzt{`NhRRSYtknƖjvhgF~f?77/3e~I̊fF ϴҡ.5j[:z{ri?WO!
P}S1?Z9mqҹ,?挜
kKhՔphe9?u%詔	ؔ߇ͲHٚ^{;#bێEdYs".Lt@sNb.ݖ=th:+fGXZ;z~^M~_cP]!
{V[b%h}H,]>,Ip?f(޳Y(vW2X#B3Of>4o"E\tYk:E0#y2$F=8@
ҟp(dyj\ݚ}Ӿ:j'"ouk#Fx?0.҇n	krP^;Ql",{Ni|8I2:FF32։cߨ`M\7k2@(@Y3l:jotgGr|•'6WՓtEovP8,}LwZ)gz[PCjNVV,RH8/7{%>f[4W4w_bZ'\/0qLjh vpZzeV
Rjm3l^^]_:Aq4Rޢ5$F=d}'A]9_j*͝>m2!e#N=3H.uS}˿WfL"i5w>*jn꨾$ W;eQX/Bjͺ,yw65q|U?S7{`W#̕
1~œ*2+MTb>ȇFwOs
Afh_g1?E5.(.#@8fܫㆠhQV{!Lz

=IRvZuK'}1l.#	V6y-u{䖤G#7酋?_U؁QwfKb0٪:pdxRU$q
)NDT5!2!.&Ѐt.52
րZ]|4{zgp?R2-r-bhJL}H2҆l%"A1]یJ\.RpN#C>ԯYe4>vx\z
`JP+ܔ<J	 1B"szk{eFZEK1:p|XrÍ6VJ.yQw8)RG#}kv=Xݿe΋8#!I"\EgAPoqp:;&Ǹ s~sQđd;zhtA7`K׌r8SY,ظy07K7Gn9lBRoXuޥ'
JƱ|gzВo:/ɰ(t,8%t"(6H!|hPѤƖ&e/b]F1hdÅwޗDz4Ր^%y{ԼC?xG3B}7"ZwNRR3pv>f5N+X 
g`N'\0PޯeC ,D`2nOhSCO_h/<tÚ-oFZ
K)Zs@pvJ*/_o.N<9\bVWĖU{)sf$aE3loR.}]Xwb;kE$#Hw'NlRڒ@ۂb@wgfJh]ܰN$iP`x=JS{]ZXj(0|FN=`Ul:Ze\#WxK{˗fȄ	+\;Q*%>&e	ח4ZLrsUBVԹ&4بwFlB$D>9>EXfOMFrBi$6xP)-ϓq;4'ScWa|O0mf+~mIx82%Xso:A!}gݨ9
jQ¨WrJ	Y2Nc:NzyҙIUd3ݛ>vW҇V7nrb2dirsRO&fJkʨLc|PxKswZI<4o#Dr6g47P3ZX3.qƚBrM5VUhpmgH	,"h-[3YhY0m)d'"Lۍ,@Qs[b)@Shv7^Xnm L+nC":AFNV%IQo4VӔolEgSL8ȈA&s@|\wQY>ԉ.h~Be3<*̙K%a4~.4̳ݙYgJX6_f#xY҈ʘ>haZo'<#@ms)Ε;.
JyK3b4+yŊs9BW{bC;Nv+|wߞ{Rs9vC#LJ^HmWEpcHp`okm~}֧NB#7s :Ү$vzi0<DxfsN&0DOjЈ>G햐Ȩ4C嚅r<8+Y^jMQɬacWquvREldi%Mg];r4u(8#o-
NBUˆ.Te3Rg!qvy@R@	֫选*wp]YhZ>+դ%OWql`.|F\H{P6*U{6Ter	SM$" 8//EOh0\GDpr.cdΗ?/
H6?i’.>eLg&}ANXi,n;Nk4Bg@:9l~);cQqX~a.3

lB.N3Q >O.vYmS;D.FEkS+{)9#sӁ}]nZ4sfϸfY}sEl#HԔ9Ʀ^0g`waOzX\f{[FhaFxθOQ}T$1~#큺eߎVK.*X~hY
={9%.Dh?<|d`͑	,H?Tr$YZmHo..F{3O樽$ZzۅVp
]|27YV:q8'K[/UMD+CYmΆK[n蠲C;tYvBqC}8rDxMZ$xu݁}of<3m%
/ U\D	Me+Ƚ
'^%$Qƍ9"܀UOi ƑqCu:^PXR>eooE@<HK$Ž85D)L6&Fݸ9px`PuGwdS*^YkOMvnmJARjӈY5By1\Vr@M	.q	wSu
(|zq%7&x]R_
hX<XG^b\un_Q"Na0QZe%n(
.BLmPRh;|YDZqdzʉexnvpe%'Gےf
g͏
/`gy Ns*i޹R f	2}7`t0
GĄ:(6lMaXuv1kFnd	~?`.lu]Bر#dū4´&?!8P\JF*텍[^KBfP5kuUW>VAL[,xJmfZ^NH`In5:qg"D=a]
^>P21),qe߉mkpMT7Mzؕ [#%UJmsKu>_Ay5\fx@GpsO
8}ScYTrS}"̒ikiT`m=]h	֞x5w8V,[\CιRd֧Z>,[tm_=?V-1#2;V-jªy&C
Z4	,D2
ES?Df}t:
]X0@#mB'}(qձ̿c71ѵ5&O;mt`=@ZWhC}~SlOu@╢+W*_H&Kkbj[2tzg%/阖f1LMpy$|U%B)t&<1FR5|ț,Y%SHkB	/c@|1+AC?C
f+E;7'D'o3q#,/fɋ_H1N5#gD$S񽗂(ʰtb{;WXB&QAtG	0uVjB,'ޓmH={Gd)#&b\]cAuvs$mY,eiWFsraX~_ץ3d&.м566nmKѹg\;	]MRn&JdEc486Täx:)V>{r@Hy-+ax>3^;Q*hx!2D9Noz7KD?7מf;} 1GC[Sz B(T%csd%,73=V5ӗ!VO!|,@DW-q^|T ?V%'nbRZvDU/ c42Dy4]S˒'EEJϒn'nZJ 욡aEiM }pK꼫j(b-|2F>ت0FPEaG.%kh,I%e$`֨ǖn7_czwݟ
oWJ 육F[̲>q-3jI\n֐f1Mͯ>D1Gњ4MA&ݿ7j8gt;譐A9"qͲƜvs 4``597vR}j1#ouaPs]4HBL{ۚ;;	 ["KK8oa^z*[>
S.-ˀ~)K8Oݛ'KZ,]U\`@"@#=nT<@=;;4G;\V#=6^g).Y5uG{,te:{tO
xo=pcwHz%+;r#>7D٪ܻ+hGn B6k8~M9YsLN]Xkg3й4 	,qeݶyx$M9ɯc
5簄q:&l!=R(&]Q;*ۀe8
WX@T>3 [^wMva}'%"Jm;JivS-רTxgeũVָS	0X7_	+)"
k׷ּbZ<u٪
d!(a忑Q݁P	 gF	FqDnQ·7UݷVob#R!
Zz]xU1 Ÿ1P]cg9{2G/ҖG$˾տ@ńR#NTTUK#o}͏~fGk@~IM\+hg>^2{{)4V0ElϹ<q]jtnYN ߨ.*z{Rk\gpQZԽ	'O"FNU8k#!|e[MVyDqi|g-Sf˛rNJPk-{ЫYH1	cuw!N϶T^nC
#T٤!IK荑fg]b~LWKb4U#[~9rOauZ\(gs3pM\C;o3X=m!DTc)Atd79@!ג2azln(=!M͐Kpd{0Ն~mT>?v,Q9ד	ВLҶ; .ca2m].8Pr-o-V!@}vE[;*Kj-V(F}Uysrgz-qgNA؇?...i"M>Cg/V?0<ʿw"\OG&l=xY/z޵
YaӚfj7Bsw^e֡ٞL
|QH݄ӑVՐ
i_koQ>,rf67LEN[tZ:t'/7ale䤔7ŹV+Bn OWIT-qhd
϶ș'@
Z{P7D1 BP!+l)ixْ	r?L`A,e+>PӅX8S2GJtFL`]:<.h{8p}Q#oaD@	5þ^֯aYj
ێfˎ bokA*AZ:i]q򶁣Ƀ!;SX`qLj:grIrP߅+$^&ub?a	eH81g3u?M!R2ГCY`}2iLx+4'X>?xdk0zە:ԭswPV}^@+ϤtAAD7!~vF`rd\92S
"ͣ\){6Lo2C:7VX;iWuy	eHo[HSkYa-
Z;-1&8_K-Λw~U3l߬pFY9WP`D֑>5DbR_~LQo\^"8
`ޫ[xzmH7%"6)"o#gͨj^#ոE )0W
I)i9FvF֟?d~@gCШkwD@:
CJW/aj-oyFkDS]C>F7+%)ru{*HU%J-]3佪ioʂ|17Ufa|L'#'f*5Ś
]9F	nMG9Ҟ(տx>Q[}(68$IXhrty}Iz!vTz%L#2Z;=J-bVx7N͍%G5ENre='|PɝHRȜ#InpI@OƄҗ4d†q9gYp"|;6E8O}lD{#okpNc2Z4$9Ga h8u{;(u.CWZ,C+@<T/.!x/)lHr-Y5:V=+Vdϗ:%c8Y\wU"e	*H4ye(J $b~vpoz2xD}@FD907,bzW
6I<6#XXszA!k˿nHoW
&	(p|GbѽP_	CRe}8f!TTpwQ'x[;4nEFK85_)(P~G&&E>|=峖d#P[Ժخ$9ͅT)5")0֩۳fFm2
	kGWJޠ/[&\!em$>ܺp)lJO5Vf34Jg&x_|"z<5-2@By%ZMN>Z{4}@3犌^ike*[b
'ڣ~ƞi{q+\n47e)v<wO~;=L 蒇$2(-iE5K·@I܍蜒Hun;wMl,Y&]ka8¯u]2gӥ$lwRﵲb?olCr_I%):E
:_i:s@iB
OcD%IZ~moX
Ӻ/QC^#)G~7.cuoBe4WV`À7-QTU/#iAC=Xm})Jar^U(4z+}Ke5"$%fH|5kCD	,W8&"qӧT*cQQ'C+];K`t;'6*zC;#iE2W5Fkŧɭa/<Ґn5k0Rh| _%Fqa_[;D~ IAJU';O'C0\o2;F8t,1+$òJ5z_H$]@iLFqg8&̀
~9iU]-env}OMNr?s(8[gvskDNª3'*1[(Ъ6tw2j|$d.阫#Cm,bzͰzmŒ4	,<%A5$.ۨU_FOLpF[	cVyTSE6`+S7bJ>v4Ls)+9DA-8nE9k,N1'

{ҸD:N(S FLpP\fR2+ĎAgY׹PהP>0v"rcOPKAiu!%؛04I)CHGoRkwY̞`&1O~lD|YGg+3vJ ˶ i1.a.ә
:"iA4(ܥ @ *Djd9PaKb֝([:߆J#{@^f90wٿ I{k.o$oNxe`'	P(
9x6-ghP،2얈eM2f̕6tϐz/^WZ
]MlaO}ԯ%;"3MT=ljB6#K'ET5
P-Mй0*H(r
$ϫ}aɫ
5N?Yſ6IdURf\tX?$ٴ`kJb5&U3l:c^>+hQKѴj6|G+RɷOTshn0d!ABAU07~N:nȦNЛd	.x-nF%:@`v'U^pL	v5$Oݙ4B
ZE,A41}-Ӌn1npσw
LLףȋr6&1ƝD
,NM):]Iŧnm$ɷ!G+CDHh= \UU+}ٺIn8(މۇڲEР	VlѕW0Ab=!=>ҥ+X̸Ŀa;dU.LHxtx>;,-<$	ZI'6$&C7^Fmj
mf1DWc}~c	6Ewcb0ӡohvJXj쁎UΖ69e >	le$
y^m4mSsk,fM\S])
*yFT49!4ijd#C,>}3@C12zjC{y[up-YlV)̃_v͈-[(;|)Ljuәl8Uzkn`yӵj;Dl-q
[%A p+έVF'o0up&"$\ܼZ5+!.' My!w`l};qcOey7X@; ΀iC;6Q9
}8p@@[C%!a3nJʄt%"gn`A\s(&kd)7DYJKϡ8a8݆X!;࿴od3KZ;
f욝FQ7U!_1*f`TzzCLil
auCAs/o5:OGg'(we!xwtU|h=oK+\Tk,ixp-f~c߽t׎I݀D-X'9S/.c||~3L*;
b70וxh?b_2pLnڽc\="|nC.˧!߱!s3;aVI!DC&8<~JY/wzز5;P4]@Qq_^,	8ك
jCQOPAj(s\b$bxrD
帴[w48IOe}Iqm%VRw0kTT$>-$xQݠ6,eR[hix qB=e'VJC[$DB@r|B [pJ{1N,}>w:{o̴Z>%#e皳JE'wIdJŚ^Gٲ*!EpvmvHޣ
b}#etϙ]}UU"C
}\…%`)B 2JfPmG>(sGxoƠ=m}fJjO~شx,Pj{)cS`vRq'<	aT̉+?6Q2Qu&=h=[µ$b?XۚL۲tocنq"HxWHiȆYwztTR]%rY[PLXkrӧQBzPe]
UxW$`y!L_Y]1W{oEL<1htJ4Mk.5PGyIjǞ5q~-}v;Au
.P#xy`bH]u~-
GH+r+au[GUagͰkZ<\~g)@$f+F22j25 j<@m-p&RHpXTڭ? V=n.,(K*	݉nt>/
A躭
D)G5[(\,s@n+_zm8=a㑊!'-^@wU?}'^CYwDӲԐm,r-ˎg-ѷߓhCI5;#y,u䒜NgS
Dl~)Y5wfæ6Ni4@4ԷBJT)u:!}~8Do>tqqÜd26J<5#4˱?;.?SsQ\QjLJ5ÞEܑ0ʄL;t6GmX$p/
)\)M@RHN@|tM}#Ʌ[s,G,OI&rnoﰤ847~gmkdP/<	eP@t82%z!.΋ĭa1,>C|Xf섁1y0rO2hDHU/(~T=		*(f:'kF6"*8FŃhrnsq=ָd5 οpj3?wT:LabW$lZUms7kkr6F+/IdVŷCO%ħs*yWNӬ#pLJk?ArPIy˃]#:{,Ohìé()I@Q5q$rlmXMt6]	(;Kj
4Jx/th:%6X4er H͗ಆtlw>_H}o;MlӲZ[f_W=&|EPay
]2m0%-UV*F}a`Da}	%QE,?Pe#)>U[&/%n$rѓhsc.e^p{0`'jx_.FL=pG*Dq’VF9@9!̈́@ XM1#KzoRȠ͒ؕ1?
//MY$_j3B-
 {O9 QAںí
ZKݶe2m<>fFJt1D3P\Wyv4w[yE
KCO)'!):K)cQt`2w`ygex2;ɐ.)sxubEFtX"LF/<~ !~IAeyBVƖ<5#q/6D|Vq
C@}יP̾qtqc]Jl-|;rf0~K?o(AQf&nYXBOj֤dsU怬*oÀy8Hѹeez$w(}5^ma
cN1#X&9/g<6y{a'lrwLFX!`$!?00b|kZy%[|6qtZ҄熋ToVݽ3hXӃ`ys4F*GLJ=T
9y31&4ֽF.IAg{@L].]9*$['Xo>׈'j%Vy.NEC|Q$}OL%\("	8DG\K6}.ɡV6p0`ucgo2`Zx^:&ɇe|t%]ϫWڊk\^|ehK-Ȳ0{krR;bxH8[)sj|ElRa6H-&cU'W{
c%bIY0WItUM+	cvnĹ)[N,^[ygRݦ[#cꅴQt__rB/ȯ4H|)i<9+$_uSGpN{Yoe׺]nyDp
2t>$Uߐn*ND,Qg 
I5@C`R]!-{\(''.&i(ƇRGvjnt*mS`70@@

H򺦱ig)k]C|A7Ƅ0/ҚgN
ʏPZ!JBET.'	CQ(U<)EB\yb/ϗ߶0nOc^.3:(mw%6v{V7O#,0*¶u
b¬t{wܵ۠f[I,]|{|幝!ޗ8:G^2׾O=m_a𣐎m&sѹ;piB̧պW*+|=APqCx+Ԁ1yƵ%+T\LcaWGnn?e&fҌeH8h]kWaՊ\}8w
?0~~1\Mn 0p0R=Ʉs輆,G\.[q2!+yL,J(RuDM	k*bFp,~6p}8@U{80OQnY~**JM-ahHz{Qt?6ᗽG﷋Bx_JtkT+HюS-]	ڪ:+Nw^:eu9ZP֟O}A/Xf϶AV	-$}>PT/ת3C,Ӻ	r n!ạ|R"g;JڝzAiKF ].IR>m땟MΆe	uU]$׌e5lk\ftjoD0G&cn?tGSԜ֩:ر;;CVj0^vDQ"_!{>lQ.u1*jGϖ[/ޯKX4f
ty3:|1Δ싦 N\~)$Zj5>$#Jlo_=\)J?g*ްWN۵cK`Q٥.Bc_K]Iz}t 5\l\\)¾GGMs=]W*6trQͼDC磜67s7$7.Ie+ KS%iDW-
=f#?m!cKqapK+xxD*^b0npF"4Fd݁Nύ求>d6}W7#ɨd
rggy3uZ:=&ewxp:l#*[h.~.PdBl|L%[[VucddMSۤPǣ7dlelSq
X/hrot86F^4S=`wsBLAR%ϣ(
+utb~cSg!E>kT*MM.gn>Ll;!HؕR3֜0>C8fjW)r#m\K?*;,ܽ6-Epƻ|67BGfIOP'jǵ`_Bኂ,Ƈ_zabGSo
|{>>8vKENAě.2dY2c3m5(??8b߻C˲Qr-a}
MHRХ`$/K/j.		"-PDp+P$˃g53e>P:_WkK½IIg	!1!Ę枮?=֕%gJ?H3foz7!;U1Ƭʎe1kBٵw?([B-	fJNM{M-rJ	Q-4HO4ݖG>+#A; q"N=x/n.IkQ5XU!' v߮$KYhce{-޳9.f<X_^3k8Xpc/h08zϻg
CӅ%~-T?K̤3{;4݈#<pt~&K'[V?9鏣YY;ID8f0QWjqe
rVJ%ݞhEtGB5h9j*kkʱTK綩r1L2
=S?}V|8'yb"K	nk?
KIL{#5"lڋ	M`CN	$uԺB&^F$
BLwćSqw48{Ec1XJZ6cATBE>wÍȏ+ W~y3z2	⫚
\#^bTSnʐ-n,x+`!)-NY!L
QBQȫP⇛iJ׳6@p@oxMe`ݚБ}ͦTOo'ײ4~V߉!IX,<\CKd4/pji.~`1EYP՟ަʎO
WƔhe_X`jWgai~IR6d[rbSyt9xH~B3{dz3ۣ\0-6.vn1Y$\i:.$s|ڴ:xQ-0Đzׇ/tywfRA%]Qզu!P
C*
f]|=/H-`{X+	mFH%]FwUb/o
V\B n5'gj"&!n=Mu^֚ITM! vY7{+D*t:~Xqs1gBǗ`r(?G*
/Qy7Wwwv%6g必I{8P?39[ŸF4@*?bJO}:ܐ.BOcwig͵|~
prUFD=ASzDm8u-'xδlI:,GeE!L1.@!
Y\X.HnKK|YGVo`±ma{ȕszzW٫:OGYJa>z{}橞,Ύ
y{qmҸ
`W%vR'//64fcU_\T#q67fmǸ9ć0!/OR#~֕SKtXP[X6*C}Fc{:
g;pwQrkwG^Md1a>ê'ICk>.iki
08JA(bL%?[֋xY[Kx8#)hτƘāL.nົ$Y,\+B!=Ʀ3'=-Tz?>^KdH\#'`=SkD(VC6Sct=؊J9>f<>q%q=if(>q_;Ny&ta%@	T.	_HdqB1O'6ݟ>p~e+ -2AAy߁lu}GPeY(J*q!7K@Iq7.!Gp)򹵞e;ŠpX*tXÃ=QCs\:.A>+["L%njhIg5	vSDr^g⧤n_&;L:=zvYW:]u#;#LVHsVJvp۫C.Wϭ9+t*=;m]i"Hl-k-b	,3`x.=>Wq"—֗H:˳wH6[Qz7>^@f@ⒾKA4gFŕUxĦVchY|9r>:Z*2x>!%#_xzvjN{7-"?,")^-eny1m鞔~C՘sx(hy\`߽v3V'>3H^>yX:Ja8eUK?`6ӂ' vpΪ3}$N^@wx]\^>ZS 4cs[,/.>ϩ
AڞI026nͰi`)}dcq;ܬ7sqs)gPƮjuzr书ɟZh`:g 
|BJyKm.fi mpt28 1t1Ӎ{!!S'{Z0Vqmnxc{WTk"Yirg?
l.VE7SU$nnFMQᮁW\5ѶC>"s*lZ<$.A] ݖ,)CFd
6M=4s
%]@!Pf7^\jg6>s]v:AvZ`o[*7$ձG`io(8JMXA.[Q_
XLE߼ҽWXbW6-2pmHΕNO2zieiHUy4=4OxI9L͖kf-Հ}廫FpfGO^yOf%Evۘ*H\犐}#[㟨=_jeSxv%N7|~>LDiʡ+i/~vRU.vJJ>t]ƼDC#U5$	`MW
I%nsyOSjM|-oVbOBXËmŦx)5Y
nk
DH; ǁ#/wP*LsU++|*χi02M
yWȇ;~
,afmXa;L:+^9UlPw[`RXҍNqɒ`uCFu`^jYlY)m{_j)b;%2WwLF.9#4&)1z})dPzp+n>Juű(l웥杌3~n9cjBA=o&ˇϘǢ叜CC@vBlU]v:qް2?:G+	T:?.8gjkNLf)7mHkm6ΜO#@=5L0bNε9I#6H7CCCC9r褛/ɌYb{pm߆jzd9}Vw'wînQu8e$X \`ia
"yL8K8!BIxsEpwv~-u.]bM8COшH`٧D􌦼]Tkiy(5
xс~5A3H$Tnu16gG"m]
tq	a!=C?DxaܕL3s=jiDf{Ԃ-+ߛKzXI~tņҤSlJ鲁>nTwgӣra~*gY!}øaX3FZ^_M' ޒG$!ՠ8UQ34!Zjj9SAdP	D]U>s˦ю&;~~mgrLG4quy]l!pWui^~FxƱ^UQ#5_=?ɞ>B{Tz1难8,vm~9R
\%Ss:VAACnP-(|wBߚ|@tUG#ӐKAPyIJC+d	MvS;ٵ!ץlTF!ZqEŤnR%&]0. |˦MȷW
(`B3d].+VM|ڔCI(sk?FuqhB3Z(
؅
ioѕ	D^;'^$4,:2R
ۃO\~wXkn/R']?,9Np{}O&ƈ[yxWC:|k!mpN7<2!cH);L-]K9@–(eVOx<
oi n8uMkԻO'>ӖwUwtg
B}9{07y/h!%qDc5Au(X@caPt:iॊ7ʒVvdhvB7l7u嫱#c-Qz^.[ɬ$9.wwL\dCZ&AZ}tF]蕐ܛŸd|Ѭ5ҊI:Q+sVe͈/9E/(I;"!RT&?xջs]ME 9
YOWv0H&5ljSɹ6ν0sU248`k
ĺG}G'$;r.?ޟ5xej]0C4?chv̄
SdB>fhA`RGJСI:e{φx:%bZ~r>hFPozϢ{9j^_ #>;
n
+WKԃa0o%'2A!x{96IL\?d:j"(Pq׬Zv2[oFZvU/:S{xn)-y=sʷUM_–~Ov'*.`:DY;aԣ6b{=S,HC31KyX?
=OaC
EdJ=|K(7+)=ptd4>17h8 9unR]:
P%PF4
74ABoZX40H҂۩mi2iW?Vb	o#x!CvɃao
/1^TZ@S{[bDөNٹdTA5Z屭$a}usϽ".b%EZa\1|ؤ?SÆw4]n=v;̟vn&W|;JmwD4.2Kxr}5XWVH#\,b3K:%@\<&\}r8Ȉޚ*J=NJ;lqPDp\_ZIGag6ۭA5_p4`\fHJGzVrG!1N5ǡH}%xAs~wz|
q\EƉa!D?ӥxAMZ.oѽ|4M.C67D9iP[rƎ=	
؞xͪ8 :){&+A3(L+Yfz+8Dh){y}8_$#;5?w__Ո]
b
aYq	S
U`ʉ-Gf EёFt+ T8Ҏ\;^dʖfcvHx		ݘO'CaPH.`g7
ȐPm>~DQ!
Y2%u@`$bCfAcE1Eq&RVT:{1O-e]ֹב-p1#GĐ`ouMȳ\gDӕLo,'S$)ֽgTUPMaa<N"A[npA>XL.Lδwn=kc?-c>LtKޕ7	)
-2\J	ڗ mcv
&@mi'sܛw֛T6[S*+MmwathOn&N~:~lhH_<5=GӰّ;KL'5NIvìhy-6C&YXcH&;8*%u6gJai;#nZ<ϒ`,x1tctm&?sGKĦ
h{7TPwK+1kn[t-
vAlwڷ[qp-;ZEh]_p/^$?bgu.zFmj3hzVI{jc>^ap_Wv8 cIyd/yyytX_jЅZL=J=M*FBG}-&V$i}:ϵ@er:yhdAk>!g3Hjy{6Mm8"pp(ɭ'ŽrYNh֦+׾"yah7-hta5nu쐊}@GΓK19BWGmR>%pKӲ7w!/1'b[RYLKٸ7
LP/;26U`CEjX&L,'kf=~ZρT$%k$͎[v3muA8#EwٞL|@nAe.S9L8TFv%Ճ7>9
<:Ӕȵ?g/W$:9C8
xC[~tHؤӷX.oD$Ӆ
"Bn4;4Nq:q*{A,Fz޺#~{
$	7|x]{׈x81/T<`NBڢ#reSjq.c||ū`(lD*h`t4[#.d55PSzd3|x}Tp=\?8	KǛP&2sFPߟ4A.桩=/P516uQy~9~wGM[ip3U|m5}ڽ?4KcWOef'uP/I*Q|$mT
zjPg"JB?
mDQBoݾZjzNKiM@t@3jYF'L.cڰk[9SPY$5^Ǖu--SjEC!ɤU8CL$؁=`O.1đ8X(Q=:UYeA.agx2Zʫ%ʟbuطUK#gJL\
?4V~Vn.%Pi8
q&$߃OW#{|0E6mFuɖjS9,:XX&.sdέsel)`G7t̤h<")8X`k5
~LAYyO2Wgqƪ*.XP]?9EiLnɌj ּ@S؟
zXoi=	''
Ye$9U}1¸>0?`vMmj ":U8S	NmQl͍ZIRSKu}]Iƒﲌ*é[A;`,Y?m@K˩0``άT	MZfNea\˲3orn,
h;3hwMg>'MόN]UTskJH-(oD5iAQq[TvʖOhS4
-۵+ZHԮH<(5b8.2R$7\˟93C{5*8[ȂTuJ0MQ	ʳIՎ񆶅7BSȽz_Oxp)boΤ8qF,z㊫!P"
wp w[% We~X+:ucc8*/$?^)ri#a"B2ZklED&@̄~0lfiŰ\"jaM	e:n20`Ok{TC,NKFj|"N:qyaAtyQ\qizG(ciyD28 %Su?E`c(	>?l'k/)ڢ%a48Kfk:pӳX"ID	/?Fxjiu}<ZO4XhBU##(F˵0(,%4S$u&vWlfFwhwHDFN 9W-m]YWUlΈ+꼒+K$ri6Xu{y V0cc8J>డۍnz(Jmn(Rk'*, ʇ_x!8=hFwJp%h%)ԑX	'Ѿ~STN!I^Y5@Yu?!\$ǔop-cIs0PKOڻ`'EG"V?SpLp̓"0|vɱ&M?HD>~.ô^zoor=_;`"ZXW
9jp!Rxkiaa,s{>毭.y:4۳?;z;DVXwuW,A
d^m@ 좎\vr8QŨPIY˘?gyYF&CpQfWוZ `)c8(o`uM쨠a`1e`".0҅* Pa#	SOo\
Heb(Aȥvݗ7F"u6ɛ9Viҹ6S)[nTiǺGbY4^Uns	l:\d'-1!@@g"EóhMOf@=h MOo_v*]gpd2g3^@_͙T|Ufɻ	x]2>_XMCPmq@RAL7#n.izi,BwGx纒cpgt#VƒbʚFU00_qC}A9\ҵ%P.(ỌRۧCgj
dZаi|6- 牍߶ē!iv:V'R3$vi<7Ciw`@Q墈yI}ooOG$S;@s*7`7l*4Rrgԫ
[)風i%QdTOSx9oݓD2RB
Rߣ R0ccsSLeWk&g!W?'
@L1RM?oPO0_g2,Q}K.&{sRi3-WiN"bwPz`-	Yi+"Ē& :U/Wz>!@u8KK|ls/jx37cX'reDWLO
9anqF`;ƀJB5>]1|<3wH̞@Y!ƤNDzR=w])t;I
RA6;O!l3y
}:1j6t82K$|z73ͩnhk6Vg*`@&~{݋P紂>8[NZa-HW"MN槏[1gI`<`u$^6Y
/"fwxi!83v(z#N
g7L)Qq) ,mCꗡ@uzgj{^9K%@f=V\8ɭ$;uٝ|zH
U4Éw[ǀ!3=bSĚlR9FORM(DJVUINFO
]XINCLmemo-sv0019.djbzSjbz%v{&E5H`^šx2ňaM?2t:Id/,Mf\;N
HHWЕ&!(x*P5عك.3-Y%O1 θER0z,.ʔMtmZ1T
l3 TC'RLd7K
}On׫,֗%*mx'eG&!RT	V\c#9Hw6$$<믅Eq#O|=5i.n8*	qAwǎy2xC}t_kM|
뿿EƄ#?Pz]@6a3"pG=$8|+ᡫۚ2,ݟy];s=FPN]ϩHV::fu`녌_8^;CtZ{glP7S*5>wEcZ%,x=A}c[H֓w$.<6%Mxn
Y$FtkpĒmmi0uTϣL=Cȼ
]+pV/C@q#<'z		-V=ȿF0ѢPaF_J$HLI>r,ͤIDھE" Jā4vո邭"9"<"{hXя
+GJ'	>3O]A;A
\"Gw!D,HGG¸j^Þl.x7?
g~c>mڮѧ"ó"PL).%` !l:sqVXF>ZJ'mY#'~X]8LHV(Ĩb?V*cEE7&nrBa7PBJ{	xBvBu5*,輺Z]JNВ=nPF,E*Pu[iЕU%
G(Z6iS'CؚI=Ş
VqΕm>_]vrڝ#Zƀ $[A'KRH\)(:ف㛆kfl?2`3:o/%%va!wTxbѡܶҢ-/6Y<Pլ]=_ɓ:.p/	;^@AtR,n3DP0N%8ƒeǗ$0*nvCz㪜^]&qe1of;N&<:gy!;*[]Sܶ\:JħmۣWl:ݲVJ4~X[H#Y*3,: ;c9IH-^HezCd7Jl+s%R5""јl8'$T'LE\n~U(BR'mf;K#:8%һx!Bqyqq.ym@
_jf em$փzD.7l		rJak"쪉T켯Э]ʒrNh@H&FDf?Ls_:#	H3fl<$f4<zk Pj7{IKπD#SG+a_U-هM
9k
ɰǣSb9^ǎ6,9kb2=uHC9&5l2#$&I
ɍ~lzoRtwQkO@i8.UBU/C.ohϳ*(~Ee@nYɪ;"	sP;rGsJ˜ĝ@h#O&hRh	ǽMZJA`T[ossڴTza<_nEWRI,(^]l	ڛ
ȫC~환%{zTX2dt|3D"(~V6%~l>meTDA$K9,tA-gpy*NyD(}+̹Z"j$m|Hu,b#u>7
mDn'&ùM3ܧy"@Ύxi!/p,vpݷ/5\i
G=f]F|w4b7= ›з^nyB+/H`QCi3
`cpey]D&5_f:mx_z{VJHSLR_TVAByK<ۊJ/D/1"̛uII0CЈ`
dX{#qָl-?Fim`L3X5c<$c!4h
tWIYn".!:^c}Df8Q8 oA,rRJ8!i/[VVտz!K}D	RӯYq݇g:74oۿ3,Ma+F[0CvD:jY5	u&WFF.dHm#*|'߆hڡbΗO}LGAlJ̭Dȝ
	fRaUJFn6eKP7Ol=ѬғYJ	R bR4&~%7$G#ZD|K)˪ξb@0EJ9j.IE?i\g
61]ބ"K$V/!Ay#2Ӊ/ukMt)2Dq[l7`4j?wY3HX:r›?*a}ܺZʛu;v&.`m9
:_qnybv!ʑ6;]{c'bk@jBCUO*])R8c:|r$FG%2Y8}ź3N؁#p9e10,[Q?DF3T
V>u)
zt+'PF8c|&sYMƾ6plã%*WIGiz&Hx12񣚆QY
DnS9%ð"iA۽0cs̕xA|0H;j'+cJ	@jyۯA)d'	&|t)6[
+P*Xct&w)A,GF̀yX;>jɭ<hH+wq3)]l1M]f2پ,!$l*ʁϋYʯߤl8Btw4-{03d6"voJtջ{M#d0N} Y;
FN1"ixstOׄMgװn:sʒ[`JEYG5?p3i~n{`<	}c
s=欵}{RD |L-X$*rʞ'u>\ch{d>1(4"Ex7.
Fs`̏ ̂#mNz#XhM@6nT$~d_R+lPZ^}i
zDx5CYرkM}]KɘT%!b̹Rtkz#!J㻷9-.,L`(EݬE9)9e|'ŦPD/|RhkA=
:n6((7(:M3'VĔryvlU@e*|L
/Ԍr*̻*r91D{:t#
6-`4;X	@{CZi,.Q$NYNCQӄےXx(B#j:~=N$+Uj'4&憊
_9z#|sO#F&MdYPt-G,l;el`@6:va{-x#œL{E$xEB\ѷ9VEѭƔ "NN9Q-ηjӔ3Q\.jSO.^$g겯]X()	'cP 	o
 ;Tc>ˑܳ*+ߏNPoQKV9v׼?:\!(RˇHWTԐu2 7ϱ88$M㣼i>%>5a*Ӷ]3!ڪo7կ%uDj4K"}}EVbdp1goPK+0\ syibN'6D/]1kŌ{ç\!E{"o9.mR?/B0N*
m:z }2c`YMyt=Ԟ(xrʼnj<[QR-ů
]
"y/ěMTBh:0(#[Tx@/|8(D7[㍦A5E^yZ`DK3`2:L\1J{l6Ҷ1\nLg,'ëY6o9mto;3ё6MRO/7lbޤRwۂr޲*eLsH<	&|8m}~Y@?O`^43~衎T5nYH27vWݠiBQc4*~f.zfcwSS:>-<%Ylᐂ|N9@sq2@T1`u5jW^J|Z*hHǾIr3^XbC0vB9>c3?$md I4ᒉs+,T
C=kbZ,]XngNq 0gy&+A>\HnWPk7	ctel{WAB%-ObLmQXꙶ	tU"Y8)*kZS9;گE̱i2hQu{χv̹얌 3&
k4J_;jL9#4K*?Dףmй#_${W3B,m&o+Tp
hKb&MF{;%
8V_N^]C`˜3a	-Ͼ]L000nqU9m{-@z/)\4O7	*y/%Y%k1Hml
75<k^VJ\P^N/]CXn86K4f
-~
At!
;wM Xe['v<\M?^{ ߛh`:#mˎm7ezb~]/cqZ~4rǤ!7"EQ1Ne:y2{׫XzlAx-jKڳjDS'au?$,e*0-8hX]XIXLcl!
4×[u\YP!}-̥_9mo(A#ˤܗArjmE0+gu nn,kdYۑjÄ$fOZ2\_B-0ʄYA ՉjlܾV8&۱ϕUI
Y];6lswj		0fL9Xdz|?T;6;Z+)M>
yߌbN\r3])Ԍ糳յ]Zʭ0H1Q؋0C7%
&k8#׆1%҅^ZJteciI]W#n'I	U +]NUYn;pAMpd9'>VbnE$*+TOl&.,o_P:f-F>cU3d(?3Nz
㼂jPW*Ba+&ED7*Q=">Uh	JŵتCs^
 avwXIܜZDgwVo=`ؿ6ī?i}ךVZ{\nKwm9[MFkH&
z=|?eD0%0'Qx@^Vsd"NuD~j@tH\M,h+{h2ke==(]fC@#4Tv^V3
J\1u=N3^%-Ӣ9^	[?~%S^t.?G뼠Svg)G,aWQ2^|dVA:MXS3U{FB(?{)SM+)
(݈8ifz
{*ݦOqo4>lջIU,@Շ(#xsu/U
+%\Z4_3UA8 vыB3hbΝ(]b%WYni
r5(a\-M(rgN5sP45t-OUolK35;-nU$讥u8	Q<_d~$]/^[+)e1 ڗBqr=1pٓb@S\08Hl[.[!ߟZP
݆mܹK;ك,]Jbj@!e	vX2	K6#XRFz,Vtw%6)O׬2vnvF)+Rrư|!T(-J`d[ܯG!g).!ЏxAiU3w;A[t	oŠ\3$90v5-"/&:HMD|L9Ux;TLh5.GEInxp%Q	UMhplqM?3sU~sׯ\M?*q<)vRQdw,Z4`ӆ!+oIIH4TS7je+4BQD/>ʥ]u؄=Wwr#Gd`kрJ;d׬\%dd!ܚ[.GBޠF<ȗsIG:?dR֤T.L@{d55
ue4+O0iTwkK,\
a*F&AFg蘓q+YsmvFFbjT:,8#6[B6?sֳ8nW6B\_eQOi-D@_7qj^'oQu8DejeWʗTve]B/0_wH
d^<ݬfsrM`D
fʒg8Č4J^]}<6=ÅQ.}C_(ik$NaOQcTXTzvתY0fP
­[Dsxn;i\=10nDl:-
H2EI)x'ϢC:PγSFt$TqTU6x|+}Sh<>%c|$FkOZCOGsA{5<;d%X8uTT0[k IWOjSZscXSwvL1EDF1٪iV4%Œ9F]3C~@cI'V/|?|Xzcu.ě~VFO8$&3݌I$wm
ȋMVf=	I+Y7@"/;SIȢmꮿ9鿎.Ɋ813NefeHBZFqQLa(^{cbxzL).L\	։Y6-P5z-1*YP&:e=PWTIe};ۓzL8vX;&5!TrΕLq
tuƈCCE
=~f5`;E;*'PƲƫ\Ԟu@bR8al(v$G8f~B;pXB9yȘM∸f0
Kl[c'qYƩ|&Q $nh|M53јFORMYRDJVUINFO
]XINCLmemo-sv0019.djbzSjbzR{&E5NXsnCv([Qs{5]<8JͪEyP%ތfFTeM81zYgmy{26	GBa謥@sj[u.(bb1
#ݦr,j^99*5[=-uzA?jceFP1>:񬱟Kؤ6sHc)$r@NIpuK>Ka\Qg%Ātƣ?זPF!fn$|u@?ݾz|>֋f"	'Ps,*pVmDY,ST L]y\?t(o1Tt līylj
P}?|<1X`CdǯVɩCKip'zۮR>.ҟ{jwȮjhq&(F7Vbg՚;eH\I~͒Y$lDۋ*L!{gL}w?NZZd+lg&-QBoũ,IՎ0z3(c
^N>E$ C}5ܨsMn==OtɍIȄ%%4QoO_݁G$b7Y
v ofHuNeú5jg)K :=8XzeƯ[w~KʤP^|6*֪%9
	PĊ]P Okn[1\GSS
Ox4:j0"&a]x'SED~gZW$ݴlh ҪٖćטYnEEW]X!Am]gkdZwœ~@PF
fٟ\'Ya/R样TߞLQcJU>zox}"ABF_Vxᗥq;ƟD.e"'VY߯ ˪_`M $lcVCEDY)wW汒^Øf~:26I4WL)OXn=уEFTy9;iМzpT0J>

qk@
`*[ZfP2J0(xnqZ~E
ŏQނ=	Z<6P1B
ڋ<{鋛ҦfJlu!X0IPstp<*.*oIhYg 86e@l!)X룽Vz-N  @[7|Jn-a}7|tfMe[bax_B2݁
6h`w9ݼ̭x%;np).q|c]7Eͮ
8T3{PzC<
/;vb2.[*~#2@on:Y8EȦ2Bn>N
$%OI_6
l
&S2
M@h"{DÐU^VmJ6XҒ/Fk/u'w@چ	9(5!Am1scu^!.S&Y1(H$"HOฏeJ{^ddsx
=z*Y} I̶^,Yu炭+fl4±yA \aLJ>_
$X5B>kV*
b:~r>}aEB(c0CO:2.QT	@JaazZEQeR	KOW\"̪?3bۣqSlALg	LF*t;5?zEVH7zCā4)!|?}F%75!vt)P	h-*O4@Ir<15mHL%BP]hu{b5kjQpIbE8@q'L?u<貭3{R2Φ`tj	ac[2Ka z<vn Ec43osrxowSRd;bOhԃ(g9iP@(FPa
be"Q)!."DHnPlnYpyJK]Yv2)	.Z 
ĥ/+{wq43Qt鳔w2,hH;rC֔E;Q`WX- a.~ʲr̈́oB|ݏ*öYs8YļGAPڹO`[ -j~]8C|_v=ćPykM.6h:7(++g-*qN ִ
7`ǟ l]U7,>jy)
yTWC|Z7J=>n	-mcyl¹HDKZe]1vp
K5$-Gm®`y
q""BGc8{Jh܊kL|P;ƕfN̏kz,s‘Y.Uq_K^=j(a8Qmm8)D'86+a+3obZE`.jYeX#-+jx`	rs뀰A+CDm@n&M0c3nuIcJK=O1IRdєDwpO2@hDpY,y@r(|;jI3ɟ{ctRT$߭?>H6>$@bNWҐxCcX+C5qk

-vȝ]H^Y
>b.[CPê;y5:KڨWq0> "6EK}ߡPԞ捝¸q@F]陵6ͶN8"0-r}5#]V!93QۭjqY!1}i][2#9j0[ӡb}=!iZyMt@gu8+N<4l;wI)Lfw;"߹
G=wBĔŤU#CqHt(@wA{St
tMMuiȌ
+Z;vһ]R[>>)UÊ܂m*
eT`'2%вs![KtvK
v@ѵu(y&ׯ7uNܨB((gy6`b:ҟ3
gk8}ԣ*U!	Η%iM')bjr6.R옡g<1.à02tQVH pi~5}Sb_X(u!;̼s5Bj 8=+t{PC
ߌ?x xU[QWo 
W~
<9s?r5\Q{iBߔ|
@L2۽
ܰhw3~^O$-
6@55΀0!{a%#Ā͖/+!QgxOP3̙#<~ u7<|çK$OL&DE9:( ͼ
*t3(\W8P>*eCVSrTs
/):OK20
F6̄)ڂԊ+,/zU̦|8/lXLAR8~=\5Sh'Du?;Q*W2 .1yGZAvYj:xmv7H
HWb]h5_.VO6I)O}Ɣ{tq;ĄIP6/F9̔;r#mWCGCJ琹6=i^]UġM2+4m6WOs#$
c|TAti.>qs}pQG1jE|kWjᡉ4:q᪻Aۺz0G2}JEpc~q)	sKgDme~.e
J':Mf`eZk$
GY-5>b
J1fyCa/}DuUWZ26[,Ø;
OYwݯO6A?a׸OE[mؑEJ߭U#{A>Foɉ`&x_Âf/El,>|LFud41η)-N!GE}W\~YpA}*/yu޺r0@W	FxjwIwCyt:]>*:p1IO@@Ũ;=2_9iA&"
:%ofng]Ruį(3=hb
05V++[B<ӛ}Az
ǜ
0x{a}Iz^<.|%.=r՞-nmcRh;A!R5iJ̚_jJ,\!M"~$(rv>]VcDhFY!QYlb hg9FH&)~Ĵ}mDN\SGá;_ClL$߭*]sm(-9yp$]Z1M}m Ŵ	WhȤYnvLʜI-an#y5q
*PU
"架]g+'̌+p67pN(jV|'z,E5rʎK4Pc5
&ҋM4
2:vDb5&0"x\=A6hZ1%}qj̓@hy s/bWyJkӱ)56[.*XwXn#<=BEE['T˚E`@Z NlNj
X:}h?sS@kL_#s
!ۄ96)De-T@{:ӵ~`ŶWy樦u$9ÙE`[Q9jwn^F{Z"Ve7'}80iQlsyģA_%^|NCju4v܃bwʢ%&nOSc`ZRX
,7Ҕ,!ϊ!jbINWIa8Z)e48"vCY|]V@&$<QdFSk
]G˭y!䧺yd!7ݍn9̥B
=xBc*e*˳? ^՗Wqcic8[ޜ};q/EpMd`K˅yoQ2ёMGӔUa/m@-؊46w3K"Pw7b2@Op>8;"0Zf2sa7{tֺZD5 [JCX1YE5\s(mDxq&*PMmݰ>$g|:L9\_8ۢgX"V4M\?	f'ط7C'SW;tG.3^S0',JU=
J?{lDED+5?j1ar(bGnׅ(Xd/;3]Rŷ릤]G=C1y)oɥ2j&F$[l4_7e&|NZ]ڃMGaf}1Wnyse`h:~
NbϬ =7(װNol#;񭄿;ûeU1E*4҃kt^9_^{;B(bjqL/54\l =tnCBmZ'H+a4D2G3!");!:!lv	he%oQ؅ݞh5c#: ?$)VT[<7±)=fNb8iv?`	|W~`'KմJ,ʼn} ZKw,?
We^~-$H=Pq(MF<`\٭w}\.ɷ;'֖WXsV.o쪸*?B^􏳡`B4mT"CZ!ؖۂGHataap(SkZGB6\wA>iHf`Ij/()GL>x_?!Qh@q6^Ds``Wت:
׮um^W|SS2\V#ypCy]`g&"!+
JKot>J	O5##Ϫ|pY8F1YyyepރMqO.Л-X2m;Dp-O0rfFõ5kx-F~[{][߰9p3i(J3FHha̢GpS2܁OtmĒg=,:WűzO;a
]sgokJ	
00\>
Ѭ9&)N޴ˏOct$qn-fGmoU/1M5r?*s"#Ԛ3[wSs*gykYE8
sBssL={#8ʒ9,FUeK6{&2=ǯ;+r"O{23cfT]G#d76藛Wljp?EOv%/5w1)
cD|B1	[@[,q u5V[Q&¼}Yq:Gw*wNZǚ+pjKӕ悒pHY9
VoIa	@hk[PaGYdipU7HC-"& Sgԓ$g=?gpD͊g#cU"m[X奱UYFԅYϳ8RM\0EG\#rߎ6~?@Jvr?RYg3veMyg	A=Zqf5	-W(GҢBH=I]-*A5taŪL؏tPNyPt8_d!9#;̯*:~h{ bċ"Y7I-6a	\fQڃLэ :H3af:+#Έ`8TJkɘ2֠ٚnUj m)Ni}Rd

ʴ ztڣb_FJYȀWCD&Cٔ
JCH6ɤvPt:ŧ|2P _PPcZ
@I58Llv6ʸXS*9{޴Iu$=!M,H6;odSN8fF1QȦ쿉H?F.[τyDhO;BPS;gY/qwLB̚BЦ}/(MX	QIGʩTmQ¨v˓g3f| x7KAk:Q<-|mRT?E6ɐKHF"\` ߐCöZ4{@jxw P^=1^,_,#rpPj3t>ly!Kƫy`.wHwGF^5@4S+*8dl*/9o.3=CpXsE˲VF1x#[IɈl
8DؙsED2mh|gwg1=crn&,G(KM,;%|_hJLJ%F*jD@GԪ."ƕPH3/@YWyl!`Yc^jF
D
&f/^eL%=V8oKW!<ą@PC$/
mj΢Q]rA}Td-؜FDrǺizy-w	dd	U\,2MF&tu^ffD3ݿa)PvT0]"0%gRQ?-xi:<_y!N] u/-)\%pA^;j	axnr(zӠ`cj{m7r|HrXS= =8k<=K1+B#/.Pt&'ު\>981	P7|#D|kܫ޲4 PcȢ
l{^X	Ark0wDg!Wj
u
8
GuߞQ#'ͺxY-80Y,\:Z0KJwގGtE=Îw[NCr#S3܊k_mAo>я>~!VNnC"W3kğѠ혒ӬB{1֬drngPY5'D0>&稗1OE|.wך*.{;WI)H?6h,1&ۃsAc9f27MpkB$	SY@żfPZa|BBm~y[Gr]2wF\['ش$B>Y>huGi$7y#Lj-u$DoTAv~ϻx;V*z[3sB7T.O`
M}f ؔ4
\NJm
+Bj(}H̛7`zPfM^ac0-!T!ŝj@hK֚;0v
@,QM3
nxU
9۷u
*Sc~ƹn6UŸ+=9Źa/Dfsi̅&*+< L:ߓE8fMTHT[k22f	Ajo$ݝKc򒰨C.*.0@Ǭ*q0q^*rkXa*pw
-+J+α٤ί9?)n~hT8ֵY+(=MhZ Z]s psI6H{bZcpjX[o(.za&%V7s	e9f$Vr&Մ{_yS|n7&fV/D
y^
MCѠ7{N:t>VACt	ginƝ r$7܁/˽f͇q;heґj#$	+QPw'7ґ9 }Hv>&m[R I}K\8
q2GMJ4b]z_%ҕ03̯rOEo|:^1)Pyl&GKLiEfFө&V"t?DO3*c.rFWY3#"7-/0dewu/WKg=T"T l/Bs[}M>pUH^gfMgAQF:I}.*o5cEpfecDc7~tx0+
ou)h^(&I:>1H}*76_dIg	p2D"@_ EK|aOE{yogES>
JR%xXp_,qɎu.*r؉4cȒ2$E[t:à̴eq_}rjfġ7%yRE#q#FQSOр	yn\z_DiOyYWM["m|ҽ
9嫼WQ(w쁽ܮIm;:׾lA6+
>Ͽ3"cQVp*͌Sfub`Ll@_\_5cp	Кm#4dv6g#"+UwUBm.)n
cd䐟6+31R],햎r!aW\9gcz^B8
67Yi)k6qU,8~ry#c"=&G
*ްTs65[l\ga9;h0GYFêD!;cIpÈpHXcV2`7hT}|Vﭩh7;pTNyy"dfJ|(.!vbrn9WYU1^]]Wg\0ճEN쭔}4v~onGW
9YI&|gB|K0{-z}_bqiL7*ܸN|xQӀ!Ko\^G9P/b׻܃{ncAӐjlbl#G=kiKoG
1HH{HoڏnjE=ݷˀOhGsӣK7Uڞq!#P'}^c4
BBJ^"爡Z/wBRaNjK[W0M7~&~ɯ
6h>\CEuQ?n W8ʍ!3QPki2崈.W
!~*Jܼbpej!	*YrV:~1לl
!v>?bN*ވ=-7#FpX~@
Ǔ&ic\d}牽l^UJXLJgoڀ
\`s݉}ql7[3j×5~6go+&HȖ6x%wD|H4Q>Ğ7wU"Վg9)2h
V\gA3zmX.;x6@Hsz}jNM[}*4MZO6:y@Kڟ0_	_qV09UI~N
OR<"ULfb@^g#)nЩb
ɡ
(`,_Sb.
JOYcX#.+mO*0`"fUrYQ:KwЗ;OSk<$QT׀ΏV$ń/2
Ȫ<>
IކZA3\	1!
	K. e
z+?Z9<~
vZXy^X
@uH;*(/1NJ{F&y/
ej;
~-hk[AWVSd&,B;Q#h[]
ysN8Ϙ^͸cU"MP@l#DvHð
{tB
&L&ڹXb]xc4m%oFJw/~PVd:8xqFqm;n[529ކJZԈW}^%[SK!Bk,jh~kW\Qϧ (V2a;#,T4AݵU I|HJ\B4ܹݳX}M*kawP@
 @81uM
Rr~lNnӍIùTy:'![₵J<[!7ZW?U	{vp8]ƅu~dVDHtoo;x|{Ȫ|6| a~~Jt--ݬXT9#.8cs6ox%)4"c#`	AxnBYe2=eL@뒝";1(y,O~咚.w?>qIgQ#oEނ~
ђMÜ(kĐV]¹	xŽV'jRuj"mX,>9rǀ?!Q[O:IegW长UE/m{6ayv:s	OFN&"F{>̖Hǹ9Hv+"nˌOρjpNz@$׈)?)y.)LyxjisP_X 0	Z#""z ><ŀEWOk—:ݖO~z<6[vgd'/DjLS$F84G3LRJ&deׂ)kW#L@ϴ%yw}XW}3=yAFvYRDToĪw
M<Μû}Hv5v@iVPlշ-@B@eEN4A&Tx5r٫?&/hA$9==OxQf=%6]WtwixY*QVj8۬zi_VV	w_wJ*$,eq|SCUQtU;$oExe6C?Uw[G{$Ur]b*yAuM.=+M%{nα,s*BW}5Q½}N{b5ɕp@	EbvRhU

0q<;i6u}8]TJ"窪;.Ќ#F7CKhgvL?/
79^=v:Ж}XZX6U7P|ђpHk<戲M+Jn#?X
;dGbsqWʢI	)#|mЦ Qt
o$r':&
+
s\|g'A<}3r'ZJɷ7KlL}--{/UKʱԣ84_Rp<Vmd.[ɪa
InG5ŔNW5*^p'
t՗d	UM@q[VDY\U!i.R.\|D7k"wךpv™"Z*˂eGdhTa'&թgI'5ȲŻ[3o~"t`1BK1ɉ9

QZCTc3WU69\=>^YRjb|c"rSUmzF1Q5>I|\FNpn? lºAɳkDgW0LWF"ȩL6%(L+Ks3"0(Bd֋5R@oE
u2d\pUĎ1Y$z˲#Ȗ6m-Gm2I3L؈	ޡK$f|y9]%Vp.t2#Gv6Ҿr:2Nڴ7"^;	Ř].FzKplVfh:6DcA~J!Q\x;i
˖gm2Gdր`iΡ{7+9l'H1!nN2t+?TY)ϸ_
W%lUjW\|:JW.mv}v3V Hb49c5^:H2,Kb9cgijT\G}+&s{TY2G./䂖U-{M$ylkWrB]N:݈C*d2$&n)wQVXn"$zhG"3TgJ\`;Ieؕi2[2|
lWۍL,#ܤazFp7UFiF<*k0!W;':yr
bVu	x4qԨnQk!&Uԛ!<<TcnWp{h#A6OH3vÔ"Ih7<*1-ğtݿR$2~2B37BaupL7%r63y:/f'O?	ARP%q:B 6{fYHZ^UTX&E*ڪ«>Ğ\h5s62ey(9C0dhxMDE#\%!MS*ƈQ_5%Ts"&G*nX]$VH2=ɠf_5{7pEwd]4nTq=*U69è8'Z3H2SQ^V
B]p&qDnh1na;%rT!-,\rkqrnru/TXTzhHwlelqldH6=@_?#:m\NB'pݳܠxIx{;Ti]ThmqN	EhdlU^Ҿ0@ħa	NS˟xu5D}
q5dFY*bȟ>p
:aYq8oE*q+4 %vx j"7:Ⰺ]Q/]Wq[ogWfJD;\:)c`F _!le!LJl}
юe

YNb2yia%Ǟ95>sӿ4
^0r80<&l!evE@ERo+0epr;(ӳ%hЬBcE ?=PhQ8uOID%WΣN.?gеȈjtRS
`
R'uuT\6Ťf8ˁC TH#
!Ԝډ_af|R8&VP}>&g`CK1i5evGYnAH	S]+wS)ą_r=/Ekh  
1֡RH~V#g"cs"LxNr_D'wCOǚDZ.R{YP8YŗVAy>{JGj׿?xl~nG2aSxQ[g8g&6ϧݜa$.@7Ni Q2NvmZG">=Q
9j^U,l0h0KNImeˠXhߖ0ѐ_ےqh;tLJn	mE{	"f3m'D͞g?@6,wQ.毊Y4F].kBg2YTo(hy7df@Qu1usXN}^d9=e/_gEo1R:p>Ek&"HD.HiYgݯQw&:Dj]m5p;IW]!g82&OsF@~p xYԝig*?3EV7AeWS%hFORM!DJVUINFO
]XINCLmemo-sv0019.djbzSjbzw{&E8=y(,!W"EyIk|CFY07`Sa;~ɂ,QH+Li˵W[b'O˕+EފW]2KBMBGY^]0rzRjbůa=Qxevj?=_&xs$%LbfӃ?>
uL|&I*D㞊AEJ ;$뙻s?#T)5FrFD^+$bOnѫ[X&R,8ڹ8P脙bD8WTvq*R)śeS
j%eC(AIǛ޴52(7AX{P%v_{vK:Ofէ%[Aq>ǦYۈ}e@_?Vk[
]})FN6Sh43Zaq#aS5r`$^OȕGf>0G@h^eGHcu#uet-;Қ*'h.ɭĤ{hnJWa<xyq
ZwaKIcRІ
Kv:(xU
nG1Л3hYHx@um!Y!Io	]⻧ȨP?^n%	{q
Vc7ŋqJp5SD,܉](F˕idDZxv/chګ^UJP?$q>`H%]ĽfP/qy"HEtZ1x'T]:\uS´<7l꣋ٴ
n]E)z]>b"0l2zr)<44UaMj]Kv#Pw0!VS;\:W4\ٝݴIʟ0*Bijf)?*	}u1t/aO6J!Ȉ?gB,q
]C	ğea݋Na=l,r-l4I
6;BGCw՟EF;_ƴjN2+CNC۟+},dR*J5ԱfŪ~_>q3%RW<1gy受d0Pܥ	u)9N(\US/ȍ;Cυ[H~3,4TzfK/"s;qm
p.+{wlj(3(MmsNzZ˂o.YbdH/n'u;5Khw?/fC
L0= ˕,ii;,%Ж/F	H۳A5ԒON7O|BØysޘs~M
KBZvLĉm%w(&RM /v2.O	i_
`{Bg>S[4V}pSZLfU\X6cH=MR.;x$P^(7=2UgŤM#H{fp8ͭt.bE}SD8n#.#/2dе$ 0$)"@3
g\y6&՗P57OXC҂P÷<ߠ	
eIFm'5Nn/yhG0L3}-FhlgJޮ/dG-ˮ[UV%/H~ZSλ(&\#maJMد	MS;q	=;$ySBy%JDI\)p
.8_흯`,5׌67STSn_]#k6nXbrr>Z9."='DݕA1dXSvs!@l6%F/
dZUZa`M
&wN7{SD:?|-4Exݟ`+6*Is6,jCǹj$c
GC7;AtX~Av{7vudZ)8䜟\S)va
iƨP	:[XN/w
vgrIV}驟}$Iaj'#X:wH!.s$jI"-,2
ԂEXmӟ0S5N#Iꩪ66ԫ>aB7VZyN?йC<=Bn';o<0Py9W"Xl{x0fOeT+#RB^l#)>(ps]iECU֫Z[mI%%azJA7T%[_,`Nj#`-.Y/f6| KRmآ`[}5tR
R;bcLz&@/̗oc
gjz0b
&v-(v*?Er˹m-8q"NA4\rֹ`?[֩?]jm~hIQǝ	N<܌:	`\⿺Rh5kAnl XٝrI͟sPrϓY8kwp?jEeuzUk.6ꏳ!+*Ƨ[,QH[9hhzؽP}dddįYZ3?.]e/`ʩъ'iM}؅cY$;)WrO乳52BEe.R5?#L ~&آ
Z( aFN.Jc9ZA6SC1<}0IQhYܠ	#UO?Ƥ]-Qgu	4|·ZfD5v6s1
n`Hoڂ9)ngdG3db3b1k_٭QSK
qC%Zm"<%;zZTD弌蠠O$䇢܂
61UL[UbpW^hX0
ę]NO4FN`3Xz;
"#ZízuF(%V,.g3ǡ"deA[5_[_d1ʊ
a
)j	eKجWߴ;oL3>hN	)imԊDa56AS_&Io9#2ӆ>fK#]+aKIWB3_ȽQuKd%E5XqNPD{<}oJ<)ZI-1|>>zÎU;/;:4L{n3>͕kπ:N<=ƫ EO	##hv^e89-*uU,2SQ@F>e9qTLlyP:vF/!CML*2899@׸ΰn>k&?uN))IjFzSTي@	z|,nDJ⃉OH^ggPt1+"gi"һ 	'ܡX{eC%I]Al~1Z^Ũ~\\Fe'+cGz\bй\ʋ1Se؊
kw0tM?	䘸P(ǧIIޙB>?ۯepFZFڻ3stݱbӂ4t	O=8v:_RI6l8*]Sb% 0r\g*.\Lh5m~'
 ˱A1hWB0F;|znHZ勈Cz٠!$q/AC߅%J>q{dN
:!LpFo{r CƆKvB(ˌ#4g1?7x1%gzɹ$/(>Ku%ɹѝe]s6hi$D_r:x1xp"lµW)PZ10G-JDvWK~;Ҋ-@s+J^"޲l43[Uh`dexӥIgGMwfQumOhЌʢwh_:Sx˳`84v 63Pd$UZV)#aZM`l.C%aH0Ge-LWDn褋X]I̠ͩ_&	eYdZ}yF9
l_Gw,nϡJfD12HW24
LP|7;Zۺ3ƺ#xJɢLj}򜀲eX"evTUR\:Pܭf Ax*q.3>NeO5ZQU-Vͱ.(iѽS@2$wk>4c=ܕQ9lvapc#tU(N+E5\ekl1prcU4n4]~!@4޹Q^r'lR]Fh*%F֝h/hOPj\xДCg[ٰUI1è'BDs#j4R=TNz	pC/Hohdf$|yA?;#\H]u&J^)FE`Czrޑ;C䠠u`}K9?t(6C޹skp8;To Lz!(UNY$W	qǫaBs+Z+=5&͛̚
!̠"t5G&Koz=HZib0uHe?aٍחEŨkaƢؠg\Ulγ<-sFUW=菱r쮘źbllEx}Kno|}U<='\쯡Zr]c2uǺ$ݒpEV>]O,bYXC{}jٝA)&"eojvEɈ4T<9K@)dđ2(M,nK,4v>ZuQ:݀>nC>M<0a=
O8qR:!^܂=B?K^(m;+v0S~LXZxWz)J~섻Xڮ?Je C/59e9R[_ͺTVUa6:g=ai}V>6BFPtq\i7;rkK~HXq)7K:Y.\yѸX
>f \
Үہb$^B),M4] 4fsӍ,n
6TpסYQEIlv0wOOOM顗@m*BP@[:	t?|z,!mz&KRs;3l D_"98rn,=bXܖ`v§]o٩wYWДT
W!㖤A\SA	
V	E	㡵D̈́{o**Zmr]n*zҞ*t;"stTp({ar?9o^7yl}31
!KuN:>t\o.,s8Us:2IoVWܺ7ab#_Gy>Swg=p?\wLppjft&48G;A"sWd>d1
	7Yefچ!&Or/Dspm>=/&D'Y|nN`wd9;'?m|!w1h}{"
Sld{NPdS\4HMʀ9h*g2ߒ(͋R:nɰu5mtnL[c|B)wTن0PϋA	:a2!0858iYTv艛U7,xZ2=
=?7$d?3[l|pw^4[fe21O`AϷr_f@')IлQwY5A8Iei@L>Ȃ7j*( !`pzi
^7n>88?_r$kݖ{@PLҖ1:zif"p
W/|f=_i\ٔ=:UNnĽc6V?($?"eλsWk1~P	d
R9Nz1q.3q)C:눯'I-GEop U,79Pf~U:Z>KN0r
c7ѠAAJU3ԉHk&yz$pjvlb${zcSƌȥG)EW?Rf`g*f#]bԷ+.YQQG(9äƥx*/ޏ65jkGHKb	J;^HjnpM0
ѲuXqsìi):M̰rÀR9r)*%ǖZn_&R32>w6&50huoxV[ɸCU*ဪEQ1_m5~]bZ+
mQnq2D*l@IË&ʍ2vٯ &ѣSl_
cפ#G&}M~j'{ 
#a	TÁp}
S|"飣ƕtXxW1`>+1lsﳭ(2l5Lf:o 052Waw#2ݿ{'^B2ژI3k芷oD{o'L_/Ex4<'핼.	hQ	tMe-skXN+Gb]"uhIڷuߨ
#9:HrO$"H1bl%h/E)oBJ\e'RSR
O)d#5`\$4ԲI5ydT#6o&
JLvEEΐo|&haS(DñO-*5m&rgcu3ZY=<ҊF[^UNPKk<$ͫIi lS}nN:zMԖ2}F/9hafy'mcuLУ#?,i}
"ݑ_.I06	kdg
rϧ9mZw*=m>s3Yuǎ6^7|nKTE*kg5Ʒ IE3"ȴuІl5^u|nh+p.J[$ɀOE=ݾ]ddHPu.TYƺ/eXFz7IYAQ3v3N[)g;h^8pY-F‚T}r=&6Nьm0!7HpթdWCtt\{ƍ
VD#okӆJu]9wu58A{b\1 s-Ð5 C].J_&]wI9nGͶdO4ѱihE*@VEXspR"SS"ՇX[8 +<@v"[&[vepT@#3Bo2m̂jsBsfX1J}zpg_0Di3LrH|wF2aFvaUae=5R3v[05lbTM9yVooB-hg$ye=U82݌i.}G!ϟ6Rs%wd4WrI*nWo3(wQ@F-7O	0°!^r$%ZdsJ)Bm:.H9 `5f`]2`Q'ƟTsvv5GtZ7{84#ͤRT52WphYòE0Tڔ:LlwL3*ꏭ܏qQ9o
p,%ʓ5Fݤ>mTY\[I<׸}WWCWE' ő,QZ# k5b2:7JtU7yټϰRYgi5e5QDoZ>/0hEB){ȳgRG+*^kݘ%)I7Kn6ODIV<.!&Wx+MVB^Lezca޴F*f%KT?$[?R7qȘW$yjVUޛߴ@yXj0]}O=?8 V!##`oyw4u3TH[fFT=i;<_蛽o:1!y8Mh´-=OKL~)IGmؙIC#ۑ2fAH8Ú/wք,G#F-uk}DI&DM'OUW=N._Nx]&JD[F
07"|Nyb]vnËƜU?ѐtʏPW=/;;$%
D'ڳ~rZ$矆7]MOӦHyGj$wJ:ȩ1xLvbe!ML
rzE܇5>m.jb%5TԬ[k3YGyHMٸ/
27楯
&;#"|Di2eлp\K"uo <7@'ŚxȏiV`P9OH6hEGQ"}FrP{UlrϲTVz+qn=RGfB ]"%Ҿh8BS@#v*V%xpsxW2n9x4:zH	vܔ^k'*"^`
'u5L'OӖ@'?6 IYɼBcqBWO21(eȺz_h~dTݨs,k	c_= |oxG[)
Y`Zî"&I/#6D(Aly_0+蔳xٛVY@hޭT!0Qn^DCl7+$50ӬDNɎF46-COCUab:Ѵұ_k5=cGq~]gv69@N 'zu4V]ڥ(Q~'
o ˋZgx"ML)TĆF,;y_JНE߂eng=T}>:"IMjX:TQ5WJ}?i}(]2H^u%}/i1o7~l ٻvMo-E(lYՇ1zw龛ӣ	Eнx@^OBS?U+Y%*d$~Dͪ/kPF
z>cwYb)>v[Ite1抬1:Lh}qn_L#`a"Sx#Ҟi*rY>Z,6:ϕklBk|7ySM$5yj'uʸsJ<8E/N@6;R$1%KԊ
:Ak
=,,	{q)+1dӕGcN2+†fՃ;³e45tn_o=0NI0Sn\6+o[~
M]4Н~Ax>A3#
̈*AeRL>RԇϖX;s̴A-zx3l	,hhʛ&
52t)XlafW_D-WƉb^VTې(a-m:@QS/ee8hϿt&
,&r%:k?;͋
I36B!4̕{'o݈
BlS7@
;`1|gt^p}wd^vɺ8:yRUfCծh^d2#mD#&ybV~(Bգn@(
ؽ"ySQy"Oz
{mG=o0##&|~,ΝJd7VJ	07ػWdPdɧ
iˁ
@mO6j*ʏaJ
@pefH!>"uh>Bp(X+4-܋0l4Ӵr~a8w$v9nnF+1ȷ>zHAG*{
Zx&E`Ab
%s#`1mdY-J(i;
M`H%. dd=8&1
.;0$r)xQr5E϶dz:D1~fc!]R9W3mmQ埮bDb'KVD]B_XYTg/B|>c<)b6̒ TfL Lfz(RVM0SK|5ȽP{OH&ߨ_cSMX-hþ1`=^~b\"XL>Be"i<8@ŸhZ&>riC$)D;,ۄ46x5}@~',|!e-N(V?fs	h]_#/i9iAV5$Wrȹmv@pxW.QQν7}q~bQJQ4Sɶ<;M(U:<gF'ݍ30
5Idme^fST9W>(솻AcML75͹Dj))o"AxT:8?ErW`|^ĭN<YGZFxzShEB>@
b+GřMh^JTa2F_)9Ik%#A)Iq;b'u	jfl+*b2JԼ^›D?c u;6!*H_uD3^-|8rx˸JPY~t'ig#+#]#zb#9jr;An~6ѨsBp##_üA	ɲVIUdN!-P6ͭ#wR+W	r9r.UrmS@hw?c .ס[2{#Ke8{lRP{IY)1qyV#C@",
a?zYԛk7jPfQa:(6v,|"֪i:៰&
Xr|ICz.iMl[yyNLA
-49iJ<:즩Z`SK~NCcE{"ź4{H+atXzɾBڜVhe|Y5[mY4qKXj$DjR8DctKjcg79@bRgNQ&ϱ62}PX#B؇ϽhIWimzg_T(lxv.[w{A#r{:φ)=y*׊~ĹɁ^(JsJ$zE04bI-1Wi"h$A]؂_`9+bs׋ji_Ğ:D/ԑ􍪛ZJ##OYDBK8̝qTl]ծsRw/V_!2B}+LF]wByzuKaW'w
C^(wX*ptUs-@k
{arh
9
'7EeQ
D
)jR{:[A
3=([΂@vc,!xjk.+'2R-Iɀv&
*R'jNt eKAEmYO+*r1EsadvM_@0
}ns uL9W"{5_r:yHU\+v
#jˬ07TӜ]mDI>D즧*}q
׃BsjnX7^ty	]/Z?I X=Zg◥):Y%=^-~֪Pk4M:)Ob)Ω?l{Si{cZ}<Ն3_1ZD
JYxL[o!KtYpɷey<-?&-#(8Meb16畘'wlmx~=vnT2%<˗5ПMb2I+2w(?a(AHxE9ZtEȪ$VC((LAW1{~5	b"mV1\BL~hpf	#Kf'yy~^z;nMr:q@#ԫ%^̋	K}TwARm`rY#u=lw-1" X+i؃1tօD!~x3\oȽq].E:zw%Yq.ׇ|D?\50M3Y0G&1c?A(d=ͿD{֖	cRL%!9_	h}P.brb!7o	oR܌at,Wä^&O+;Rqj%,i;51P5	Isrs
5,qyc%+~h{%o"lYld1Y 14
ii|?ԔDk7xe|5Q)y0?Wя7@Qb9l^>Ja9&n"x`؊_Ƙ3C;\M)Ά"gƁ۱n'iPMvj\qػ6#'Xo)y7`7 P 6Q*$M)>;>BnCd:"Iחo.GĔwTg,<͌v=Ў>P3,~9T
bEbQXI9]Bva-θZ	8g/oF)ԨhG[>a	&Ŏ=j1lɅ`o=~9[h\$g,E
t2R%@yczCQoؒ,ê`ʄau0
͏nGVQ!}NdOSTeHXcLfSʴd\v
wS]"j8D;hU!
*_aTU*LQlӔ+\g zoLVJl #(I`}$K'nqn]h5Mϝ0Cϟ9\H.3jjRnLZ?s>*>xm:_rulȡdeѕ8ޛT1H
+\sszאF*C*/n:ǎ~XqT+vfmToNcLnzv~L:قt_bDi^ȅXaJȑCb(.6;IáQ¸W/?P;Tn[{x:H3T&5{8kPPeH jvGФ0r3hJ86nrqqIl~#-v̀"Tk	ZìH2[%{rWoyU]
8;"{;x$zVw={J̑	u\ݚj/TPZI?}G, c&ݸ+?SCi4L]S^81iEA,S)aH"efAGPr )
NQYĨƻ:|؋uN_X$oĠNW
)8&}?M#s*ndY'7PdVбl pg}v'p*NA!2t.&m@]3ڳш:EB@©:COJ0=Ӷz!Yig
5lE+)VAB(sSag$
{&-gihhr7)j7^ǶPޯsL-|GNoPU\%D~&' V0H!4sQ;t8YHn9,rwCnzR,憀)ol70m{<F䭊fþWPy``c&HiԕRR-6 )5aO|SC
CQ|l+e|Ey]*WqFTd/Dw>trJlzkX5󛒶4 vE$ޭ4hyk=_kϖ#r,(u*0Ԃ*JEg%SL+ 4)qmtmC9?&߅ztcG%L<q>ϗ~%l︙1K'u>M53oxqD`Ϧ-P'w]snt&$0A2d!jaCbX!ףt:fkQ'}skf%l垸Pni&€p<"\ 1HZ.02a&u}LiW
^~#+63"	G?| Ta~1*%NВר+㦸)Ǜܞ2Gd18vჵfJsY>>XD'-~eon(6$,E0{+NP=/ZP?t	uk{B1 >V?ۋVc)+J1vɵ\uDɐ{	Ko-b((X_Iq ;~v,JBЁV8{6	m*.ABI<%'\'~|hM.A.}%}ڿ>k==jEGU~Hȋ=sɋf2huUMJw%$<?eas:ތB<ǡN|&`A]bMPѵQxq ^%b82FTgϦ#%j亖e>Mq:끲(s$i(CfMTra0udrk*f?g!V
XW߀]{f(9l=U}R{*7GQm7~qXת0$Hf	qD6eAyU(8`~?,p9gh'gGhm߱PxybUk#|"C0Z9tn$2-63
&UAꋱ'S%?^"~Tx/`d Dː3I!fD2t'F̥xUlQ,bP
+FLa8TWh7"Qс|2og?rO"uc.>i;($oa;`<|g$gҶNl	<~-b3P!-|q
ꀿh/˦fs&#zN'1[ʽ} @u	#tL=
>jJ#wIJ7J,z̼	șOǢ/*%_8jU1U@N
	
tqc>q!=##	ߤuRcG Sj00}K٬`?k~Xw~BiIo9.Aeawpb0m$p	rP)zo)a6O!t7Z]*VV--lr"}-}RNn&sӥJޢ@͑䡪磆x[Cu#yJcHJZΖ}Xia~cPQsv80&l%X_o$ԕ7u/l>%uNUZB<;BXM5vot\*2UU~LhX=
nj[gYēnuY^[2cr:d'v4d/N%}Ƹe"$]NUhº&Kz_«'r`󒱵lvhVH@kb6_}>/"ظA=5;iVmwt0S:t!sH,hnbT{p4W_;Vi6`ͳJVdi61}/8$׃|0rz
TO%轝뫯.s/&	LiUNxx tN`YN_هLyAB|9T7P™̮J]!&jj(3`wn@d&q.oJPzRK<=n	^g:qIۄjfBEwo$]a6raePtLEjy8Ε}p#fz4]>M*OM[{:{7UM͌;7|=9U)٪]<4T+GR@G`BEfu[TP{#r/\+!p5c)
n̯$bC$ӻ5EPِreFُѳ!ֆhf΄twd`|xz.dĸd'kx&=.}F9F-Ϯ3oD
2۴)zΡxmLҖD^m*l
ټ< <җ'Johp֬M
ᜯ<
!dqc_+.n'(qd+ 6Wyˎq-T%tʤKƗv"T9A	v`/|ɣu/lnHfc*dۃՍ0gGE4
0Da.T߭&{%Wy/m{0&;0&7 #eY	oqWB96xM=ozg8~鵄ӯJㇱuwM^@$[8P&J*̹gUKcwvx$CGG)7ө!{pgΤIZ
}Kp/!xɌaO@W;rްkraN7SDDQ6)P.7uW~/.!f(j3Kz[w9(8_@.
\&& 	ꫳj@wܻX?ab7	ӑ}#eU"#BL󆙝wu2|UM{V6EDȗ,#̮MIY,HisEp3h?ATa`?:e~!'']$%l\FwD)!t$UI
!:llK`n4W4ЌD[-heAcؿє2`pD;av?lKa"KaʻrL)UaFHwF6V@
)Bq@ԆE̛jhi.#
Yxgv's@Ǐ@ؒ.I'@l4Uϱn&)1u7-܋M*I:FST?#}Vpv4aeIU
 U%:5ܬ;W}{׸ֿE󴠫)jA	DU͕LXY8$UNQSJ53kˁ}
࿛rJSsjw )Bk
+FVx'SWo?bU,cTXm_3VUUZYʂe$8^};nvv^WT*ju͇jhr@œS1zFYkO$#gqGOx1cI4lUg$:QpLLBP4*>؄0^n
YkAXEOxDʶuŷ7j |Ქ`
k?L!O	KU^8MsJ30=tx-#1nYP/;K|GmeE[6P~cƌ1ԝ"lmE[{vĊ&?T6uװZ߈<9(܁sq
{~82[Aj,N_1a[<>ea?D-(r:mF:%A_/U7̧nvN_7̠xp8*kޕ
.%XPd-:8>hE3.HbzWq|er9u ,,P5AL@߷ww5P岇y0/@Ni	K6栝UQZ!#fM
k>k:W~Zq1VN8s&B÷ԳQ+!ba&?|tWbIѾ,eSSz|pwD[P&6dR>=Q$3nFC>3RY|jyz۸ULG`f`STѽ:wWn޲(@)}1lP8߱ϡ.C"0Z<}P*'yQ8V/0թ9WջȐ?Si[Ϳ$ʂBhnk[ 3oPo.Z`
0Eu皦Mit!G	we}MK}~O2B(!p$q27߁aw(#1_PcMEvB
R@J,Jar&g&iT3'm}kA6U{q4D#ty%V<)>=5_bfJ-8()uy0YS^y	g%<^8g-	NjRJ@# F;t4aYkriD$בPUCrah-,o(p{ݮPC1uZk#dDg88Ts?9rMp,)t|'[MEҖ~g+\gVo=\*:=)1̛guOn6|<dfT1\Ij~Cϣ3}ŷe>/jL^#,d7fw-),k!B#D͂kOPh=
9O"qݩ{G_b^⑹VgNw\ՐF
p7VH1N~<dXx5;qܵ˦%+8lK[[0	hWN-$0*rLK(" 3_vM!'aW8d~Tb֛f3,2H _F]cc297fh	,jSꁡğ5FR4>d I)fn8#[M~ZIS4dN?Dе/@>y'TN+wtg,/K3PGfYإK΍|SHDߘX
R_N@(Mmbg/x}??Bǰ6VJE΂6:{8|icn˟G5iJs߹?JTHl&C'el6ގ9-s:*R/9 zS`ȁHisۑOAnIJ!]q=T!-;؊MB	yY8PΫ*msCara"!]kw#,*`fUjNv
~
ܿ*qf wr!b Tv{k7
&7-a{ՉwclŸ>%]ڶa|ċt	žiyc0]zU..D8*۴i_Xo u`LA-{x_:qG)ЖIfSUWL2zSE+.8.:	OS"^}k>{ȦED79iR/
ƩGS39sa7vu&qxI*%qNgݞ@2Jf	:	RXYOJ*b/ew``5
faGi`"*h9p'݋?`	ǠzմV^x,׸ٳ-QBD8+̍&wV'Eb/tJt1_m`Oա<	\{ˡ+D.;B,
T~xBe4m+F⟩<.,*57.Y6_>*zH$}}щ)[
vv/qOKНN,^iϴ"IvM"-o"w7|1%Ê*	#cO%_uXhUk(s\&ܞ#)L&X
l`.(_Ndso9(?HoTXTzMȇZHH,:ܐ_D>	gȽA>Lw \JbXw]6khv207&1&J#
şCh*}4
Jd8dCi
 _Ĭu[0+CAPِZj#m(SN8Jhdow?,4[RudQ<ѭpI&;ڰ-oB+](9PXVt :u=͖rәh	hC\MSt?-+d	T&EBqIӢR)̖'t~T9x
%728[m~0h
"'h oMTsךJ[C5a˔K~"twMeLuBT;0^Jۖ<>#v3]3X3yiZ|ƍBCFsM2%44H{~_o}X+eAk3CP</VsʆGe"i\XϏMI'\(l:sdT		2s"jC2j($Zt՘OCч0iF$[ODS~29[ÎF0G[6cPPVl0uӏ԰nLO#Ȩ"!X{C206h-7͛KYbLaT+PRM{kp!̚|>_Lĭlԏ@$jb\;c|=V'X'o8.2>L1!h/B=#NT"Erj.AM`]b}QI;{b,N
V!;8ޡjZ_5C"xx.d".cFݽ
ܞZnAոA3о>Ti"V.zu"yvq^/c)y-_ه(!GԌEB}p[m\s^$,
Nefɋ[@{W.^㈸>T0JհBnFxhXUE73d8ɔqUtì0J-r2	BQJeAX>3DgT#2}V8m:gcpC.,h;ֵ?ȊhvOR'Q
+g
,q ,=?B
/
N<js:O/y)HWo잯vTGiWX߿jU-iI^7.EAwJC(ҿ~6	mwbpLr2A;ƙ_:lT2	aϸ"6T`7[Q]#>VAV[֚[&c;i#2'|'*Bh7
 ՗܅gr)c׮|k-/iA,YB`6: f_ NZ8뤷{KO]-Hdzt3]J\sQmV!tFORMcDJVUINFO
]XINCLmemo-sv0019.djbzSjbzY{&E=$
6=*KnYx>Wi:[h[:Sz_>#ԙ6vN[ܡ2x.$||Z
2gm+;ZR*
Ikf"2blLq"滛p]o9#yW&s8<>tx%hKOWNɳUW;ͧbFkxomDTZ7&a[xȬbϸIWUm`]0j?%}nXw&~"Bӫ{)wh>cꀘ%ZW1:{u`M>|3z!Wp:?)oHDm:c]r)Ƃx:ogVoӰM|j-
q[ye
[VS;BY_(aΐWfo"˼t-}_`اfݷ妸QVs0y)VM	fURCԿbS"f|bC>OPP]i
3qLȎ52bN	`-uEM<zd+GcV`$a9Ԍ!&h"7|Ƙ:_B,@.z@@YݩTy\v>4iVh܅k=bP;eax

yg\OǛ*YZTOnV:M`
ynP3-Ƃ}&t
O6-pD`1$AS_Na"	*87da}:k.dq\Tz"%}Ԑ5gb|}(;'n/)Mn>dɈH,qzSLCͦISt%5{Z{SIYX.S>$zo7`dY"'-r1(wp]b3D8$se~)Yg̶[;'T9mfV8$N˦?[u\N&qo$ѭrf;.Q#L";e{+sȀYTٸJOa[Pwp 5؀p2i擨jbZM)G
'kFV{y`cnW2X4W솷<%ms@*1hp=Jd]OMhɹhaXm~T!lG55)7"}HҠ[tvc7&le}q.r._KX&Uk
?	Rc"ip]Rű[!7%_?oJemW+
~InUI-Pn|aF6rQ+BT	tzz&ۖӎRWZCZbqS&i,V~ܝ?@I|oܿ\r|2< \&"N HlxS3>"h)q#xN3:q
o:soVY^
=Xa(1x5]c&2tѾ|(>^S?QM˹OLH4j&k	 		bDﾻ{
ͧf>9*ibl3,oyzR=v/
00S{kn;N;Wݕ%	SSW
!6S`;=|2[^[OŠϪ*lh,xpV8@ȈbN,NIȯol8켡|>!+eA	I苔?KI+ы
A+D^-?\.)`Խٲ
4y@n@s&dCBmS]I'\$hrEv
UGaRl$p
}Jpi[Y$b/=kvlj_T2@O
ja&Z`8ܹa&ީ
Kujcjcpܨ2b$"A
:;H::#I2M-ڬUYFMCbXp<و	@sYȚsgu)~V#(喲cֿQV"yc#d@ktҁ	(ӋȱMPYЏ:+Vr1qXċhZ&;vnu%]<hwC0Ct:ٯ0ne{՗wo_>DM]%4V=oi6"l5Hԑs`Ɇb
F`1\*p9?dB,6MvH,R$-wq#ͥ4RЪV88hOriNoaκǵ\..9d0Y÷yBHy5$*7򽻞/*DF_.]O`y.)A7K/.ҠrL[a_MrJ@M_h8YIAIf+S;*2ˤ;c<q1C qӳJP	|yl$ojxi(42?Ȏ~N
|a)mY]QMPhUb"EKdLq&~!/F >Vx0y2,F{둬"!d8jۖ8vA3:L38vdig	#yOnl> `pMU:;WnZ5qX1^FKp&Jܳ=p-McwbQbcEsug T~
Lo`GA8lTLpc(/Ώu=ߖ,LXZX5) 5XOέzwuJy)L^$5omӎ8yR
s@A]/t|'f"Yfm/DɋA,J53/'׹᮹n}tSBGjj|Z*#oψ:,+58dOrk3$;#6!nR `6!YeFT+Pg8SJI#i |cNfdB%A7G#C$xsW0j3iҡ;*k>ʃTH"E_K8b#)wՔOS\'Mi1P_[j;RugM')W<5KӤHuvdSPt`\$FC`H6q,
D!ŃБrZibD@"^P9xyӡD3_&*!/דX/rA`J:9WlB^Nr`@NOSO\O[l.v0̠Fn70}yD4V:դDP٬ӅsW%w=D/-99&}Dv6iђnIB,	uSCwQUzgeJilĿ
bةUiR6"N›!ξHF'`$X:ި#	源Rw'縇hc9}^Z:0	^gA8g>:]ișV]gz
MkMO P2_'z_ڦ8O]糜,Cy*GDξEoĞ*G,lD0>+iW1
Р
0λxmE>Cfw~XGvNس‰Z
3wL.',5[1K-~Y=gbF9G]ʏFՄV95#?,05RuiP]q{2˫n$Y1)$F2+?"G:Z0`?>ᬞ=qSO„-?Ɯqigڂ{"Ѽ{"e$iK+wr^!(358I qf5)d(J˯2[KG^YKd@u-BE+B,tnwfr"3h"`Hk.7I-|\Yqr"(Ucȵ^鴍DmUx|3΅cX-,D_IBeFm^*ɬXע=1#&0bµD	Xq47~Կ?|)uN񥉳<-`!<Ǭ[(fZ4<#XQ <VoYEPyz
C&9pAU^TGmY}RΓ
Yap#M[[VduKN~Lҟ~e	/Q- ȅo/HG-?
4Uҕ9ފhf[5Ig^gk[Lr1FFMПaU|$F_H̓	$F&?Ǧ%Y:XܳRj2^VnFTEC$UF:donR|0J&9Ka)XK26^_tĿb-$K.f5r.y>gX&qu1_ޑ(x)	ZObJX]F;|5Oݔ9Or?S8w\~Qiʋh=z|Rʑ4ML=?&UTFPe1;|Գ`cL},Y	X44qɔMTt-)<`Yk"/xJ+6J
cOu%Ɩ
xϬuJ$0LEgsrܴמ5egHSMmLеA32k>HZ0
ޘÄoH	KEg5E400šiqwIK4f0L4䣤h	BaJTq&xRt"‹
TXǛy֢,h;u5i7f#muWrC-+;>Kjœy,δw'qnCMJi>ຂ^ӫ{Pxl`+䌐L3A!sN>89s
A:@w"O6IN!0LDw#J2z;謘J]_`6X51aHts|UG[|ǭz7R'v6@\	YE8L
:E}L3`3#i2+.*1yJS3Har!ITxϦeԾ{8lX?4[50^C],^]DASc/4J<yM)7<.텽%]=Viܜ̌e.VlxMB*l
]DvK2}xTw&J8hm;θq	7gtHQVw&	v4u-=$ n9~!gɯq7ģ71
'VgV	&N)٤Wcgo0hXcz<_DDAV/&wwݣ`Pd4>oM	0=m;6@b^m5Nٜ@ZϽR3@SIt'A
~2qAAvX+Bx)R/E
 d0kz
oȖ*G>:_Ez{Ty3{D@C=cl9ךּNG"y`L aOdS2Wa-ڣ0=[cBDpfUw'1CIĉ}6fgS2-+O"3${VT/;KlnXjSO|2A珫lP_Hv_ynsUHDWLq_ZRM
%V/79?сaXxEa,j[pf6(OK=%IvJj8I|}r{\ߗ)Rֳ]*ɠ8-Rx`{u&֪6#B
ݙ.vyYnΗw;M>cq?xܐ[UU0VgtubuްĊH뀊M.J	<v1&HR!ߏ9燒Wzr*#5iszg(Nf|,W|`f$)3)yr"vlh	Nl*k5TGd!!IWڽuUgwhv"c`g
fKl]] 6}(;"
Bԟy4ɿX;%zgS68!?ae5}_DU׺+wO<ة?(NxT0Rwg6! 7|6OVNuρ-cj_ϼm_Yfv)=8Gɋ)QCb]a4D;c	.:q_U4!SWJÇ7K A7n	@9*c@Ga:Κσ[<+U7
2/\ЍO';b$	1z`i==Yb&	90VG_g&%s6}4%P\81AY:K'*=NXIHIsW@vj"A߳"[d ɰg_W>O-Kh1o.z찰M*)X\W)O#Q27WXF7CV_{LLH &XT	 žYR!c7,`?I1d#g3Ǒoz`YRNU`O|Mqaq?b&#}6G&@^Ӝ|9n \ىGgŜ)8!m="kUϟI3HtD{AzN|RO
Wa[&0MI'uO?\#94ƞW!upģw"rdR֒tܦn$a+PD7ϡLnYpzݬK`Z?X{W
rhr;-Jv38$yx]ҨUd Il<5XO\zq[6gnK771T$>61췒u%|5:s%@,,,hLȺ*_>^oɳ#SVJS,㭮t$sH3ikY||Pf:(t ^Lޣ{djQ.uJB=V[)8c#qJSxwWɇ^]
TNh+
		w5 i+Eh2Gf_
OHSJO3]V36Jj;Q kO?xl6k"OX|hn~\ Q
vǧ1hh*7vMs_>7Sʨλ|:,yxzjvF"SulHilt(v]v!+3˷Wv3MIXڕn"Ƈ{rzw&>c{	^^`fZYbh]9;6J`U
,SpdψoE
f۩XF$ub%
K@i\f9X! ûjЍd5`Y^>?v˞ؼ29$n
~-QWcF:z[+zo͜ԏX[qH,!7$hRFyy4o夡YN8{ZO'v>BkaDNc ;3g:H5u	uVH_nxtxL/ט7趾PPErwo:Fb8p[VҬk8rIn+H=%ݢ
+AMwVlb[[ǥd'FW[uWV$oï7ҐCM;)AZE&-]ܞ	W[&
~*(en~lѢ؛?7C,9J,LMK&
a0-֞P6VidXe\#S!z?,>XA9r}ג8.Ecd'65o19~ihQ)qiIXvu}u[`f,ueqfX5B>*+7ou/1*ƐJ7%MՎ
.(ʧ{˔n@OZ2
o= }fPGy,*+.;j'dvmV8ڭ
<71WD0R83	u]A%q<@4@fKwxϣYD~,YPF˨3 KY2J!>|\7:L_=BgSC_ӕߩPYwBDn1>&2($a/^t8ķ?Ԋ5_
0Z*bt犣B+}䳿;/CEM5Jù7Y'Ol	VqSQD`fS@l	$OI͇1LfB)܎}^@;!o,&dڧ,iGbĢox^)RH5Cڶ)u>$5ʁb~ӿW
끴漹DUT,fovZ/pfVw/%RJ@	|׶ZIJtOKPH:'|pxj&_!Z#)Q༇҇cxh -Ƨ~>H!b{8ěo?`ǡ[
\%`=$R];ikRXZ<* tFH T_5/Mbp屩 YB+Ы@u#3jˍRW>	⺑©6ލȖrȉn
!Ts	J#h8_ʬ1ng8ӌjaFRF$n`FA _UkGjTˉ:2>.Y413iicˎ2̏(Lx?gURxD|/wT=1	 {.
s*=:7et,jS
"G19=T0&q/HhgDMDHsu_Aƌ(شC8/b$_sFhJMfK=k|B
)	7{&U8f'bB*PLs.]/'t0էF[ߗ%cQeR{=dτk<:E-_̽i4d~֨ۗH#H='ԡo`1g*|zEBQ9-!{Cڕ]]bW~jX߼3ڣJ\F&xcUy>CחbW]']@/UW! XVf@`?*Tzw/(,+dO3LOK 2pa#GuM=EE>2&K~s	Mu ކ8)yr54_]ڈ'^^۸E3J-I~hV|RK\pUiW)KLX(+XR6I@m{sW1oLKWVڇv![x{{18̆9t-4틯"op/PфT[9lĜW?2~08헢wlpTA+'>>Jv{iQ\8zk--=ڂr39v:C+#&;Fh#7K1rv:deORKP>L"rp8ڰ(802.qTAÑw@e~Z֧@Q;Nɬ3׃ހ^ENQ{r&7Ħp,rD2syHSPn1@B=W}FRvC}(T.nM/v>3qtC
fp
ٚf;j&Ξ	ĭɽYQ.D9-5'~4/3M@8	*7A6E֋aM*Q'LJɽH׊]"}
׆Vġ`7%0senbN5ٚTm>s#GH冲iJ[w/E{
-cR\ϊ
w}MMAhÁ˝0]@y6$R@5-[YmrsSh2:.`ĩOøZ⚞B|d-y5|w	4A.ۣ= t#vhKOS8z/'jS.3k%6+!!8u}]y0q+yw0alL:x&R)vG΀g])'8by``
\Iu66!K1()`KGe&@Mbw"EX@tx
#Bf(Ke=8˻SSΖ*⌹XL~O[gaH2\ehʋY#ӲJ(G4ALsP]8q,uj6qxMѿoK%XݣYQ	_Gb/i:cY/2	uC`KSjd9P,s P'?ܠ8ќ25AW_#í;	DV?,!8}OIL~jzME?Bj-.B@kmb9|̆ڡTwAߜ%<^t/vB`iIt:K5\߆4&)N퀮n*TܵԎGX<U/pF1G|5ዀS5CnbEWyZrƶUbGbKcScUui>FH&GóNq&N{]N$;9>gk^*c6*;)ŝqUʕm[
}A+JƛI6yr4: l/$A1M>0rqv	=G*0Rd +??2.n
c	n:d5XB)8yI\&GYۡHx<遵6+:XqJuW&@j':m;nMJPJ}-)pLdSG%lVRv!!فoq"\
pBZX90*wmNbJrTlɛ4A懚Uon@	L`]~/+xoTsb=+"	x8bk<K d@'AJ;icugh@A{ZϨ.z&al6A͡	̔x5>1)';k؉@ybO*wd(UO0=E(reuœ㿄Bn+"!5D(ǟܻKiJQ=,QAa{Ɛju8חYo9@BV)7wܖ_-qtoSibi\3OPtn
VUxT>y/]
џ`v͔
mg1>Of^	Pms6>!L2ӟK'풇+Ib	}L0$n.M΍ߤ*sMv/kWsejXi쉤[\2vUK}K!CV.DUV6^f6[G☿WQ%sV㳁d˼{=pr;:?W},W@芙=bNoJl 
·h&&tD+-wW0}<6֕f;4B_{o[n|y	b0IƹVih
;.\u>abJMI+5|!4m*p'+HR*_R6|ДfA]n$d7Z(qߩ{2\LfIJ"!ە,ޙKiVre>\	Xqh
U"E8<+"HvN`N7S%fƢ4E31qYܕcŚ5-L	NǓHE^g'erﴨHU&6Bz29SAMHICc%!0E9FŸǝxƄ^vIFQ׌eij#Dc22IT~FȔhnj)3 aaN,DXDyKçԣ~ 6J~bC'XLn6{ 4C2ť(yI`lzN*j`4b$
w%Z upBawJ*bܑU$cZrJfH$-3Ldz,(ճݗA?pɤKWt[]Y2U!S!XYv1%(%}k$q9Sv{I(93Sr)e/j9D]†6^갳xW߉ws;Xt`IkiE*GrG
3	Og	bGx5rI8Pcfh(N	c4ӵN{eh߅HoKz}gޯm;osrI
*jР:}掬~QܷO˼C끫hȒ:65`/qU#3PN:
9WPSrݺ>=,}vm]h!lELM\szұtZRuiK_͸;;ܥ7
h[q'.-A׮=s8%~\l/^>q`)s\훖6Ox͒	aTZQ)H!Q1uJt/.5 'K	8OK,gY|7=,>a,du>2(O0!¯:!tG)3 3JĂjr]FLbt{7~sGO,Q.a
WڱD@㲂ƄQsrN<<3EL!r#0	TKu'^HZJY?\^
Zk\//SzhكyU;ⲽIOM.ai'GZpjL߿F$|;[3˾:ܥ;QR=qj,GbryȄ$4gA_M'l%% Rk(9zp"4Hx&*={Ff"a"@{Y(\`?`fOrKz!*F~*uk/fm^RX>W2|3dbrq|FD+/Y*+yu{Q$56m7hk%moc'g^lNңD61;!˺bm?Ȇok#:ɾ	rT>^I!e:jIjj7myCWN,wD^ m&!*¯.btF
6aQ/cB/r+>KNs&_D`	RBp	Ia@hBr32ųBS	^a{$Uh}m'0P	+2O/'O7`"^8m"jJjXB@۸SHR31^*"w@s.&q$!{m ~qHo%)%>3dw_P' .o_ѭ*<ϻiJYܦIĈTFn=NfFlLbͤlw>ԫ;qu@gstHFQxOKcA\{Ί};GdBͰbc
Uv^Zup.>ab}sBLD+bV2PxO0B(k>=PץkVH@8x 8,t=秖Xe>[T"u+<@	E"EmBGqvX
~;U֗ZU|$J
<]B?A0b~dp (
Q2}}CRsumWi䤍4XY'ԗoт
烦 x4G'/.2G}u'ېw7N<]	;Goǿ@o m>`|Ķ!Gɒ1݊%lĥWxWrS9([`񝺌0=RsBNxhmS.42F /cp&MAl7A*/1#4j@;`ã?Xf:yحȬ>Q鬧$?_3piM1!>_NiOrckz/'t!\6n{<?]ǐ{ӯF\D	؍OVSyTҰ+Z:9N/(+E1BSTT 9jϬ	$m}$+QufpJ7LBznUP([<ЕEvŀ()t"y
*v]ݍ$hw[~D	7@ֺ N1Pd_ϟXVEFWin;/JtPfK),J} ɶw/,ݟv<:!Z4ek2tUBB:lR	WxUy4fl.:cuC6mb;Q)x/xv^C<}{іZf=2wF3'm_mpkR.~'T\L	Q;nSI6[B!rxֽy0Ԙ۪%1b6wA|I" ~c6NTA^Tɋm[cq>6򞗗\F=G*&YA<8:.R
^Y
=oNS(!	<7+pn=xžyz.T~q$#s㊨U{'}%k}	Ak'\H?}fR$os<)cPo_MfT|J@;l?Gʛ%<0;4!J˚>q3!OZ4X[߈"o%X h,SDpMp(CX)"a$O.!~vR7jp6{]@ش޴=lzWxdFPdSWDH"X-zFvTY?S}ȊQr`ÔR1O߄zmE6fh4Bdp_#/5! (+;6T*aN\}#wHҁQ3?ta;UeP%>
{>)u9W*Qn7@TL
mQA)upʗXЅjcPmEԲA͏B^Lo6/sk
VTNѺNZ-34ErQs(Z$ay@+l{a~C܁Iq"KtC0!!?DW}1V9(TPNhu%2y՘DA[B7)LJ섟:@p骻)+j/0Af?JQ1zfع]>FfzRAnxM"6(v? z
D
o{iZ5|JuB̄bUq.I\#\mۯST9x6*ξ_i&}m	AԁuOL<(rVѥD‰?}O]f{Vp_e!^0|]˹HJ|.d/FV4_5e^׫Ԏdωy(jӆ3S}w~wInY[qv'BĐTɼ5~QTXTz
?HAy!%Aڠv85ڦנOngzDWuq9i(	tn`v&&U'1ٟGa2U[D"4Zb)pL$S٠!Xh$OOOLxsExp
G~ԔLZF]
'~_4`
зQ;&|ޓc!}WFh
.O;U;u&"wLqG
^u|,˟&}j9sbGs4ɧ€P	3
b	OF§ËU?2a&S`ơ$l99_#%8	}*+cʙ9qs	CU%)-
6|-~K[
XTe}3Y4
ɬqp2	Qp"k?JAh9{!y%FHh:tD	>ۛb`Kuk4tzANlT†?U&QZ3Ė5 ^+w;K;Xb8zT1m[|X94W#|L"j6F[F<ōXAIDS==lͭFY*0S{|
ݐ<
s'?1%=K,>sQAo$wQ	g׏Y=˓~̈5C)pV/]64dm1&?iڞaFO32A?$NX,F`O%cʀ9$e _x!uc-q{EyG*'/O"fmUI&HGTɀ|5:K$Q|-@U*0G'z=AN֦daPhq)^}Љ`!68=K{?#~GƆt.R:i$S;%e"qJg1_gD','-z3`~4٬/A>Hec8<<[CJ2^UngUի/ASq^~:^ϖ?p?!CU~h?i+5Xʦt1Ѧ;;je[BMզ
N>^{̎SSՙ+	8ȨE#'M^->j7[Z0NwNYd+
gdzԧ,f|_sY~W6"HsM!/
8U8Sw[®	e'ĉ`~WMV}\FKJt/Mkі!u1򐏟Mɍ:ٕإڒ J%{Jyvb]"[1H)3VBWk=a??5mt\d)AG;xhx/O{o$YQ}Ϯ:n'.3?(񪯢?&ܥcd	W.Dg}$(Zè_
C5>%&*O9ztJI5Jb(o9.^_{+VSٽȆ+WЪAZr'$}
8t\Y:GQuһ_^gWqЏ:Sb'10"{h¤7g;7a?Dyl wÊJ`=OjYFoW3>Yt2;nN[!>b;.;tfedNVp68o*4=No{Лb<gr<ň>9j|2kYmJ]bC"UmĂnxJ5_N!?p7/jZRx9n Է#ێM?}|	S"=
WH0AiFORMrDJVUINFO
]XINCLmemo-sv0019.djbzSjbz0{&E5)GZӷ3ϻ*xvʡZxS8bcS؎O|w(t,:Gi$lHM9X+m%㥃G/%ϥ=Q4t(qMV \M6T@K0"s
NQC`2Ahہ9D"zAo+L;\(炝%xzh\ؤ
n)iނ$b,(TqcHL=]{GcѸ~kn	'$G|ۻΖ̑7+DW+[]b7D
:̡̹($QDt$Эedi4;+<ϵuXcx"ZR|?uF>hkNb9w@þ@|2Ɏ'/4wv%	ՃytǗYAz:(a*T [iiK>m
]peo`=#?aͅ1.ǻ3nf" KZfӋCsD+MP`] 0Pݙ\?yIаz+pWb!ɨa!e!܎L_F1@Ol?f~W^?}NZ=ǀYm64XIw		'% x+c;gۚw/x'wkDƾz!r\ @N3XC='e!6q.Z~4nZOb
ݾGhSP,LG:AI~
 2uiGPMzlq䀶1]%0#Yr OU-AP2r^8L6=ȧAީ()"i_(91*koP&ەD
yQNbWߓf(Aޙ*OD6?awalc>RNrSJb'"\+ιiQdUrHR$i 	@\]1%y1A}Nz+&B"k&ZEcMݐZߺ4x\Muc;ybt~1 ne8֞_G3vU3͆"o}>^!":]d1sUnΉXaw	1ALĬ Hh#*g#)O%@[d@@3=$uD]H&Xi͜g@3LUN+>[,筊!"bVZC.ِ'zF_@{54x*^zmWN+Xjb2h$^Ij
{kowV՛}%X{Z=2R9]{GW1؅V(t" Zp6e6ovР2X1AԨڼ*]copwŇ
`|z=$Ļ􀥆W-23SE)N7Lk0TFc.6b3k%Ⱦ22&4&gnx}??c>7Ɓ9xF'YhJ(Aأ^Ҧx)0E88smJ^م,{xK
!Rc6ըXx'	WdX:2\c"JgFv
h>_yhֶ֞.q?`#y~R39ɏ`` mXӶUg6ʵ}`H vi$b`13|UKYiyKzLPǔgKl+"AL{{s_2nZf
oss!O/5o(H[C{Dg/1TꐓtT9yVB.u^D?{!`")),*jGiWF0
MiD$!9PyNm«y_:ag^2X*NqOq~;5"ؠF#B
^n+/s2D=Mgh̃>}@oP_3iQx.5^zNED%m#(ZKm\
AT^G.y{9d?E.nR<
>~n[]
6 *F-:jSinC"SSA	vQ*oDeȓ.N'mT`PZc6L:)Ν/?Έ+׈'9_0$(n2=aI%D(Z«w,Ǯb7DFݗ?bɬb2TQp\lt@ʢFS}AyT]	'Xy%}d|>3)U	KX$G=j߱h\4Chc6<:,RdV0bTaC&a>dhVL`{?NY3hjWWio\mOq%Ny_pSC\УL3C˂:"|Z{ADGPe]vYE}~,'_"UO=M\p)KU}op)d&DҘεdI@J?_gEqX4HCI.FVȉs15tkڄoD7vy	$R~4\[:1!=$I>4K(;s(z(e.$mGRuqLKX~~~HU~%Ӥ4
lL:l>Nw'փmYp4aj_a9+X{Vå\-Y?S/7!vp-c{awA7q(b1w>Ey0*PGm=NqpFt4A
\۾h%e+݃

`Z[w`]Ej+v5*SƮ|lnd~
:NcLYv<%~Nvr`]_rʗQ+T䱜w{@0(oO;>JgӄZɏE9PXܢd|OMԇ7,]}xKEFE;EvnwP)|0_m~8@?#$;'$-)BǛ0%FY;.=ity<*n8m@s=2ƽy3פ
Eҝ"JT4ԛWIY^,5kI<_Չ#y/~6ɶ
EF#-w)N7
.RCF0V!.:{:8PF;UOWpgH5>ynj48:趍hn
#J(08u*F+<
Nwf1m]gQ=AJyc>)zG|-=2ުO@(넸V_@c՚",б6E_!sK{?ƵTws
GրvJV}|* oRùN2ݕ#}[T4.N
Xѥ)S0.ԐS`"{}M֭ek^TfįQmAGM̘iR~煱e+nk?rJ`8qxS80^MIUr=2
΢}BX`-j5Wb΍u-LSɍVc.g	ˈW!fOVR-?#e?Dl@bT_tA|cr-I;nj
||^<%b(&OpYW&FQaAQ|("'C):]jM)ZHvTlTs)\ոHTo[_E?[sE`m"q"{1ljGz\|:YΈEgOI@H״dh)czQ%f"k+\ಌ,WE fs043e=tkFI@6L+7M49&M &}b(>8˳\w-z J " pZ6c҉>9$wJ<}|\QTWnlsJ^߭F#}lu]h=xk>),@wp=u8\p6GRQ)Uv%?]8q/:USsuy?Ǡ{y9 ދ6Fxf4[ʡ?ÿE8ʝ[ۚc&FO
E9UVjfq[*e䴱lN=_L{y=2Mڔ|M'#O^ݪ>P_EϮK4Kҹfa蔑[d0y:/LWLŤ=vF+2fdӪ="YL1hgdg@q2od&XR01ϫv`	?:DӍ4fX|F1aW;5yxw*DGf]c{`+	ʚIa2},1ʘZb*;t%2bHs18.'PopEBru'j;c$wL5ҵ}fCek^8堍iQ׷}r83pŖa
y.{K)ɱſ_Yq^/6+O+
X["a1=D|@c$%q!+}q3wːB!bjx58E1z(v"nJ?F(~C,+*>M.a)l6!IgT2K0$<
?w0Tun2g%YVcl+ݗdZ3\P$+^I~<\!^L/-;GAУ{B
.G^*Ź_.8!BjFm45]yN&>#Ul+3R:_ǸS6<7]Akm^0.N*>qJXc;Q$Я"+q\̒%j*v~"1F6$AdT򌧈{ce_.Oaװ#95)ͪBH|ؚ!c~C~`$ˤ$,S]V-Jwr7%Y[!y%Zb4;(h96kP` mbZS77<^Cn`TIy@Wޯ'Y(;t10L=~3YRq%_?>+]`TXʦ1!աi#ջ,IdWO#NMRL>-	%D$Vo#{
>Ht-|e6w)BN)}Q~6e~7c{>hhQ_=	uzZz,n^ԋ27Hh2|԰
H"c|v#5ALYWL(S|.wMU
W+n6zs`䑆ž42+2.;4ǍVoW䂻j%Pʖ.@8@ILJb'L`u0.Rn;@wx&ojD|`])F`B>xlI)Wa7&c郺`BSW$E2QŖ}9sC̆ҟ;2)b&8
ϵ΢+\9]"<<'pWKB''g 0Ϛح*5(/cWUf_{UI6p~i(0"
&]r?<[|FL~Vy&k觧%#g
0d2bo&Sfi}gxhkwdְD\Eתf102&VRL_w6G7F;z{E@:aPŴZ_x^S0n4ުiDVJcltU
dpS0uԸHyJ"S3Z"?ysZ\׈=45/س0v3\}[!ӪHSȉZd$,xJti}Jd/5-vMGe p86pR1hǠ'(n£u$ڐ)Z,"9^ziP*!.;>>!|
R6"ĄAvb;v(;4r̖T(Bς[_B
'Fs>aW4uʑ`̷rt6>I<@B
?L"ݰl[*SD)Vl^j>}N'#yƳP3런mӁ39<՗dBjpʗ(Bl y֫Td
<7H9}"Awr>"HZt>9OPkencr 'w0GT擕IC$8`r'yw)o@
>r	OkťƘU6F-kD
Z*%_;r_PF`t<[S3nZOS&Rl ny^0"(%Y$5@3%J=Ɨ'rHqUGźRWYAD[w0hb/,@\Ulx[6N.oPx@v铚{ԽƆ`N*ߨ,յ?	VTDqxh…:H$8FФl+ҩd}T[੖zp}oض#T.dgyU>*"9]	=],C$QfJ_?(5`x-Yrv qp7IIqYK"+iZ9u `+i354T2L(Zo/&d5nY4}IbvCOʛ.
qM;Dr#^+no
jv(nHtUQm{]ČqV_{MQTc:>R|bQ+icyb[#AV6D6_O~Z$کEIB4x*MӜ&{#7#eAw+nm4(c\Z;nқI|3y9x\8=x25$]Z\sMUX/8j_cfI$ooGl˲*cûzr50dclYFL!GqDȝ2sT<H	ʘb?L[\Ï[7;`w>#u׸Njq@M&"-Z_Ք3r|m;[`Ƚ. hDy'H}VƁTX2\&Jiǒᬷ=_+'9rďNntͲ[
Ϩj%Ns<ŭ뢃;N
?P-F~bتi]Hן)ɭ9A\r>gDJdNm?36VSz!eR.
+	O(YgmCl$
l@Dtrwޓ&$GWkoheaZT DjexW1
v]Qp>T6]d6[Iq>/~˓aXz,iQfMzIg0FuKĝ~E
7 idtB݆=('(ˢ;]=\Bhpp>}!geٽPP8kSBm1֘wPJ7U?*6?PGK<\|}l픀-÷?]`/yQ^ܡ&j
ӷGʿ8mм0;mf[dpW28M:Y X`յ] bē
rڹPrmCצ]IbkU_\{"s~Թsy0⢪E"jCn>z9r22K=sȊ@D	{9ob
  A4-QGp`M2KZǗ1ZeIrAn3	ѭZ%GN	0?'pBz7)*Ԇ/8>ˍ~L
PkjPxI|.`6
:dՙ	x
(`ONKTG<{1? 
'x`VeE>ɻ6'3tg4/,z/O.j>\K-VjԘY¢ԻVtBx`&(#I͑`d?zj7X:r|_`Ul'1Fy
k&pmܐK{3?*N)lLC˻OR/\v#aQ|A*c7G{.S1c_mCjUL4vKFQ=eN{
A:׳zH/k	8-fZwN=WrLFc[gKĨLvɸg٧!wm(%
[KGՃc
ӊ'7ɦ̼EX\ɝtI3Y>j>­_\̵Aj"'Ċ-fc=7o̠lS8,o}%7k$"T^bp97uL{yljR.`
A}2"r\ЄycRI0@ԱAlh\u#)̺eOU-k,:]ګi{k^?yc\>$6C&LH⢘IDbs-ӧ0U~,,ƁB2@
@n}~ir>-u5T[Xz9'kNF͈ٖ6eTWg3b#όtG;r1B-+`w`vN:ײ(ixŀ,yoU@s1i\vɌ
50?1	jő(jka]%v\Q1r {c==2};ߍ2`w;.z0|MWExta(-8grV>WhZYh{.<͘Y	2V%]؂I*
#YИ8ɭrVop(FfAcЈ޶~J$ڃ'3R=x_	~QWmƖaO1u>ߴCHVH!h߹HzoC6f0SvkK>gKfq$nąqGg~WzoɗZЯ[tEB3]`$""A˄X
C|E67Ph^ޔUtz?P;_?m5E{&u
(x!'rfjm\9,K
y{HeKEɄow,kD]ov`!x&[ů"nqƪ(}U*cs[Dx f^r8瘸
C
VTֻbO*(ϘFE2l	?YVʎؼK/t&Xn(7	vPzG%9?PC/	D`ݢQ934Ii>ًLq+h!%-KC[KH)$~zQClңZ۰hL5!v nBQo26,+d@&R:ƷcOʝ'z9R{
E uĽpByz6לd߭k>e.3~a<;*{
TV!oΐ70]Zdt6^
TDQ܄.r*#qW?~o@=2ok典$ktLDimȇRpƝUܜ"9Hr]tˢxοMٮG.+kq4/l5	p5jMK7V+'i6BwSKy
 _*ŕAIv}KA*hpnlD65	f[ȧ؂}58+p
ᅶR_Z$½=o-Du03ߝX]D;?Ԏ?
=m`|?!aG5͠tf`m5/I@
kT_,@|eCT{B}!9'<<-z7G9XWk[zGwH֧.t3 ۼ7Y'y>ԫ1㢚ӆqMuIr{3:CJwDe#"ۤ^nALrN#G-7RVF)tL-vn	pk9k&h?>Ұ-#1IS/g55:4GTsIb͉-ck7*zd-K;oQzB[^ABDvћ/Q/Z\-kN^N/)nnax,ubr6"*˹&YxF{B-*؋;V	*灾G܃jm"0UPo
F!0ϣYtAE>E]̰5ăoBB}n:w8ѥ~bDA.jgq]u`!w1Ƥ:dR}5W~pd}>EuoXq{61T@ߘհ9C
!Luꡦ7CQ"elsۗ[\C D]zɨ;OH`,=@bapVZAva~D-*(4V`U&hg*U*Pshh*Z%pbc_
0d6kdNZ.l)?JƅE-"n!JdS44z5[{M|kxޘ8287{;5R\XQRXK~Į\˶z|U@r4zsՎK*Q%UiIՂogpn5HfmP
B\&o,@b>-\gv6gqgV-ޠTs?ciQMҮ4݅HަPnLVW%$U%탣EbG;jH;ȲLӥW0/4z87wS6ƙvG.QOBhUo#Uhs#tܮL$G!1{0|/5 R[M0m	xT~yD-vlM6џ}Ќ.3oE1)UmA%^xgbKc,Nxj_!҆[9"p5%yGMg'-.d<.mzֶ"
nJ^Rf;Iq̴wT@K`4Q
"_O++67"Jǜ=ށ|ع2j]e0*sߘĔEȍnD(6yK|=X)3I8وWîe#
	6-KP9iR.	QOQ1k1y~ޫ~0#[vDk7>!:357}^vMKA͂EX'DF97M+N^&+};u1)k9Z-
J?=ejٖUs~ͱ&3*M6瓈6CI?w@yzP8x6Prw+X@6-J`>,Xghv,וF|U{w#1ajulO:ƂZZn}kc.I068yngiz$!1&as*awMk<(.oZ_>.y^).ה
\!bn+eK>U_Z_aDth6*M)I87d	}|O26Qx"Sk~>yCM `ʩr.;ߥFӓ
qWءt999_ubgϴGuLO=DE6
ߞg=?dȁ8օtklHRQ'}l?
A|"yHJg[OBD
 L'YW&g`1@':{3Ub;֚Mys-Lw2cc* 	[)KkwX0?7?dΊN-|2
	J 7u5$\Yȫ0$.ʘz-7عF~	_
~?ޝK_+6g\:x 'Qۇs-I5
ve e(
2!(i4xJH7lȳ-'Ohb65HJvP0qǢg"GsULSXXEY 
Vt3/gQї2zdl
 , \),/[VovitaHqI8w⢏5Qi@7XLRh֡MZThZ)GfLWs3Q>S!0H% |eaJCĊ:gKhC-dpL$Hp)yk>>WIf	692iy{$ods]/7c%\B H2jOI~FMU	wVC|=NpaLඕITXb}}*NMpO4`>s0v[U,V:*"uF,;ͱMNnqW~xOa7!J!!ŕUSp8F<%Sw$嵺&w0b{CHmnD竛%{Evb=.
B>1SzoZ9Q21Pe+[2͛	wdG#MGd XITjbvAz.ղDKvzM6Ԅ^*fEgek,c6ήV9@>Qq`\Dm>@^6^[gp9HPH}J^gVUWd;_Tdhҏk#(M0M]30$Y~)YZz9[N03BdhFZ2=cTA[FP|`rʣ.r~ۅ'=
/\~Z-ۂ\m2&].<⡺$@{| ;gH
7}
aVeyfLFD}~&s\QqCγTV&?yrZ̠DRL,Ik螛]O>FB5bqѳq@4.b4kN'$?
=+$O	-H~ˀ~cR:jb{8¶&
Km޳/~q>\dŲP<|պI4δNh
\
e5zhsL9!;FZi9ۂ|7	3D+^V0zñ\D@[YiRkv#ɩc)ESL(Rslѫjt 
F05t,6sҪM3wHu|+FĢl¥EqtC!hU69O	v5λm.%oMoRn=Z޵i:R#T6ZCHg`w2{Қ;]-9^*fZd{42jU$LQr8bTuႋDNMZհ9Oy=H=^b)xPiI#r{/w{~8Uɱҋ~EfԏYzЕeND_ydz 듨k+NjA*Xt{i;Ws;.
ϦiApa@O9#ǃZ7Yeeyď+?_q
F-=L%BF~EJHc
&]0h'gًVE^7ZTf`]vƯfʁj<

kE&Z[M|2?U佺P-֝9$/UŞ^IX^%ƍ[	Hޯϖ]*DaQ3/ڝTGFˬCY&8K8Q\%3&:ކaTY:G~w=>G`
E+}費Ew5Y6ڐjՁX
hcE0W\I$I:hs9ɀK+2Xk&{	I> -Pݹo`ـw/\Y/m$7MFbBKuy-@!Y9@h~ovA7e>{^G@M-zjva[:c^DZK


=M8kuݷV׏}ϫg	5YW
ޤS&q2	\R1{=bQȒԣlp̤kaHKLfv=I~(n17I2+Wt[ݸ
 _@i;@2 C+8NEߵaEwD%%l<~&M~eD
-(0 Vq*w]kquz
\2n(y5iMDqP@qmLٟBeNl*9WI^c2TXѽC\-qBqIAcF~t%-4J<@1{oɍR=46ă
PXvJfg9%/E=Ǩ8X!-L2lꍄMgۖu8!
h0"7dNU6[5U`d^}vO5mfcՇ/]SxL	Q	\X񭽙Tmbag̘
3		FIMvIaEGB9pi4HwV!ahA]N&	$a	/R)}KYvR@BBEXದ:B8Zc~n>{]
˜`0|MEnW	<9~^;/UT+zυ6T2G~a"0Oo"ۻ;#7)*<@>~
Ahp]̎S`7&/>_`eAq=[ ӮliR^m9uŰrI@dXJ9Խü}(+V’'HLKe3s
ÃY̗YDƛU]Οc`Q|w7y`anGA^_*w1;dyr/#KvM޹,OY&MDZ ]hl51P5ڋH.{hG;.l20UYMamǯnJ"2xې%.y	{4-,vhNJ^%Z崘J8eZӾdΉ{M'CO#haj,(zbVZbMC"(uMڞﮰu` t?-5E+GMqԣ‡CqηlS7}fȕ.o~^^]a%\܆NmEcTZش7Q
P[(m|RTSl8|_fsRV2Atv)[{gy{L6J-mR/a+M1kVĈajyiэ>αd\LAsyu9nT	Qn(tw=KPh$'akiT*S3Е:%揣}C66=!^ϒ,0x]OI
J+^&JIYČVdӬ˓0Kg蠄obFK_xQ&`×"vm*'Xa3g1y"Mٗ_CO˱&ofqsكFf!z[؃9.K8~Qe&Pf==_7:Y+cC0"NǫHF=u
oz;ک;rcG$8[ZRs4݁ug6Ig
%gE 3`Nr'jS],/:ʗ(I\y{=@Hn0DȒԐW95,m&e]4V/jY`[oO>z>Ӧ!c
/I$ ojS6mAr'tJdB>CQWUz!]}aY?嬉xu(RbDRrKɮcc_Zڍm5b	$7
q!r\z<^i"FShm&d`"e~3-lM>@BPg^nqhw1YI!=0}hYlg#ZꇓiKl33_}i*b3_~X>b%_ogѱ޼hvn]iڻP_?87= ?>%6{i0nDy%}D|&qdqEϠ{zt tE0.eZ涐fa!Quk
^;32.=Tؼ).&nFO>;) "egL҈1IMOY8}R5xuI<*n}"PQ99+@-tDm;vqInp$VZ&BoU
|H<ĉ
y&-)(9Â	 H$~+~
.Ҿ݄\7ք
DaLNR`ku~\H!O;II|#T,إxC†d`Z}[cЅhk/gi14//q ~f,,z-4̳wCP!cv=\*рIGMwA0osbk%uDAz-2a_2MTQ3{0/(faNWK^kɭQ	 \,K."M7<ЂJūxv{P^yf'#0?I0ڕFaFqLI#xMFz!
{8bsG{uоӂ0ȴ6xjd[ns כ\ n'_ښ\;yEB-ZCq%5'l}~*Udءatn}xBoOms[D_[t|	CAoY,K&GɉM=	%-Wɠbd^ХUC;3jPk	k[>ɧ߸|jXaܛ-@BkWƔ졺]LVyK߰QKu*OC#
?mZ%s^ӟ'Mh
ܤ@jPp~Y(dhD/WTy4awqBCG(1p%kl~ZmUs;-8@W6{Ʈ坔}7`I+QH41l9^J5m/pS
žRI/P8JMxCe)fH瀳hs7_ω&VqnGL=iׅ2H$ώ:t1`Md d&y	!@*@5wyЀHMh[;;uũAOTg+c=cqzw~.[T?/οC`QT-1X8e0&k!(x7Wu:8amM-yc{@eh=W*h
GtmfHdW@ϊU^o'O
ȰԮu{.XA;TZp:T"gdT6擞29L[v
;V@%I䞎R[&W:.(mg/2O
GxDbw2vořXx
8ƌ=ښǐZNfts0ETpu]֑NJx]a9V~C^ZBo8rS4`b
ڽ?Dn
;m6KG^GYB&>({{!ymM9AگipOw>1Zna>#-@іd]̟:cTwJ3+#!
WbYF9-H]
$-STuP4lwT'_#iC
dvY%I0HĦn.g>6ibkc*W;|Pos4H{G_u_^mˌD@YkK CnKQNG~nGӆUd2VPK'?Zis3mKi9EEZP殒6+XZl5>CyN5{!YX8]H^WN5&z9Yj^QUVs$3}7iœ@
IvHUI.#0cQE_uن^5LYaZȶlH,7(Dx;p(ivJo6iVfE3D_1?f><ȟ+[}:.rxHdlq).!
Yv%2
G\	"8n>8EX(V2Viػm{9N]
DiJm.D\B{*$W^T},yfCcFph(g<DD^7I6l9ĊtjlWQL+A|LL06tuasV@\M|Ix=Pek,
1޾eWz-X} xu!0=Hw8(tKRx**{#k~6Nr.jlhfxiJ;w #yt{AzZpQdWǶ,ʎc(z!C.BGtyg_0vDuhVnM	a#.p-}jty:6fWprX3]B\pU>QCL1"Uo,1sOaώaT:BG)sP؎q>x|sS7f-b@RDT@I]N)OM^dp4bxh(u0u5qy}~7ʼn_xsWQg&{/rv(\O &NWH0Dl
APošx|Caؚ?7Ԅ;A\_1!^gy[~si蔹
hȅng0g5ύS9t2E`*.D1>_։F!Op^{ ˩iw,̛C]bXɔz*ۻq?qAGvʄ(&?Evj~-/P᷾蟭[7Ol(oakb?kXo(ƲjQ#0œ$1U
edWWKV{grDPkvZSÃel8ʻ-}mINPFc=U+*d=2v1SbYUMǎ_B*z;gViuYJKO\3cƒibF̶זyIѶ]6xA뗡8no}Ldptð{cݷ0:񙀼z,0+-9F4H_'KEjgJ%G(TwLOa*z8P&ʙw'hapaH>"A[Ľ24y!@Q	?^Pi/rvԹ HIx)jNX:$P&6BMQ󯁢'=3HdѶ6B-9} fJyA%ݦ.~6Ү?׋ݗ!2EJh=CrۃF&
HX- tw7Q{Ժ_gg #{N->bn6ND<g		qO䎑_X94Y @ܖ\>Diy&{ִ@x>AQcP\:?9*dsNKk,Mg]P	p9UsKkSvvSY%T7n̒~L41	&$dbX-QFڜv|OŨ*hV,+4XRq7;fYsϐ6ft	Y/X=ψ^)"0b0J
(]Y)w\-QD%$ݦλ:	NMlx7O$ו='IMla(]R#WmStv?}{oZXGIrcyBL12ŋlLG-3<z4	}f'孺xH0'UC9Λ^6/wPVBA@X2w2CǕ$L5e&*`T5r[XoRK#	:G$kA2c0څda4֚nMRi_K^W0 et3`Qiiъ2p%=`.}]I<>u="EP?
ɥծaek@60ɢ(Ӭf`"{6,<9xw#;(gFO&ɛB8׮E?)j"G5q6ATul/aQڀUrV|BQ Cذ/XȐ:PQ"W:ۮbZE`vټ!|c
Q%ݙ&X]&$r.+XLk9]O0@zk	>g8oQ^wuEIi,	ܡSnZsnY*AcAB
-讐6QgI{F1@'Z45[2U!mkߙr}i2fs<Ӫ1Kb-dOZ
[%Ǿz1UXfψ
/Ȥg@}c\nWҠ%0݉G8*z_~4>U"|Rb`}]hv4#7Q xyXY^DeHRRdO/pNG@hi=Y`϶ܰ9fR͞
'(3lB63S7O1W$g-x:Z
*M^i*u ?̈A306J:zS{FxcG1
VӶfmÜjch2p@ pl̖uf_n0g:,Vw\6!WؐcXKx,zF*(*Tv-C0MkEPSeVse\'%Ӄj6ĘJV9LjR6S
^s͛%mR,} R
4/GS_'DQFk)׿a:)s)(RT+"hIHZvRL(Azץw6K_(IMd/dѕ~n=2#vZtۂ'sl7+SdHHH.Hp9^)OΑ@qiaCr%НD|XA˻LA;oAy:L~=I
6\(<`L3ۚ՞‹B*$0($d#:폆9;/ L?ޘa\ݿ!02:'Զt!.i02͏Cҟ{rwh*$|? Gxh[c3[!9fj.LK9ۥ5XX>zs.[(`ef{:na%ZwǼIu;D8*߯{r.yt=k&WTx[p|cDSZӈN"p%yun0SBұK;Q17FZUD#SzIgņطKE]YolƏڒA%5Jv
%<rӶ!5{V/S_O֎>'uF_̱$1.V8y-h>)y7*iqWfJ&V/P?ի]Zn?i|N@"XмEt*+#?ߟ+76pGKz_}PGh#[1?+ =	V膜W*z|_B	r^!X:Q\6F,tB}C!sAr`O֛[4qwk?|9vd>p!8O9 \h񃾒kQ(r±E>cdf0҉Y2|(v)̒
DyXM9N{Fdw#/\.b!maOqW/C+d6GqPC#Wy[J	a^Muk^m)zM6"HQfG8T{ܬ7HSgCpmm/1a%0ܓ~Vw%@n@k)NlPwh+qMuLeӸDAf[NWQ挖c1@(XPf"j~6Z~1Xꛖz9?.poG*su!nׁ0a2ڻc|J|O;.h;f9PhV)PW8 VEX)fo^bm~m&8
ȟ`/W0R
RꡪDmőPxױuxF!|eSŶ@/n;+K=7E*'WZ2bjhw.sVϏ@FesY7lGGEh֘JLW7̀vۃBA᠋j%sK,QA;kh܍ԁ-	|&;œmV-%CeAJç7XVI4bJv}qHAB9S&	Ywf{~5ٌBG8,2_UITVN!.?|'$	0:)иF%u86´1˙,t[L^	V:%ir]a
@ǶVAŔKTs;JPXr3&hQ;J4)u6X4քO
tzLWy+b]7@^G'?Tw:('gJԤҋӌĦ
핃poԬۉJM[la/b?Α88ήPQ`Fp\E[M` nB)i qN^;79/Ȉ<-m8-;-7!-r7ZE^!-Wb9!±,mؑӵ|m'}?]݌
j;㻸`C
oFVeʾ#0v_'C
'ۇ m͗6O:7t*UoeR.@w_QM7%e繈9"ST5!~$mtD}pXYZe ?t:VJ;P/9?aƠ:mFU$zGjlọf&%WW͚t3hd"xjoO1 -flqZP	IYkrEZ#)k=R.ȤkPCH9P7
5zI5|5dN%KǶ*Ȁu3/qSڪ~[^4sX䲕}lpԛo&@ܽWiKW
@u&J*x&?pCf.@
iUgfhq~nr/6>\5
$BA%.
y1Db̬$gEagkCCӘTjQv`5GPr*›߁!^ĮmT;<
M4˒\z>0O5O"R7$ _IlQ{a)A@q9` ŷz)ٮܰ[>xIfM5Le|Tt~4E\"mj;!l٘Ɓ%Ȑش]ȒC&կwO-i܊;.\
]ڡjjaSdp--jK/M64_zz{(_
SPې$R^{*}m'Z؄/=xjb4׮kX˕8lOc3t8#sm*M(
ww*c%`FLöepREFQ
-*[FaK	㮐9?MP5nH7}J֬{8 n{5G&3IҼPLEUGf8eGЮO)Zt&m	k9D2
|o	!B2{UB0?>,1&}_ovsjݏOY9j/	M@*w"[HtSl58g_pAHA[ZD[|/pYʲkr#z9Ɗ(p]N*xxBY^S1HnMˆs)xK?̟
TezK`۸S}eCg+QPG~>@\wGBy*BEğWJ3sc?ħ"&X:-ץ`UX
xm)y$eoO⭹KL~n*@|hr1GfLQ K,h#!9/RHa(:ω&BTXTz
ă$ݪ)D&tIbl/jIgtTe;!Վ!fc1ɐMX-}a+ҪENM=`F6B)&\~[dM*0^3T8B3P]msV&1؏ȏ3|	 .~MɞNYgTR^"
܀8ހޜBg #\ꡬr:.
Ҿs? {>' jY\ZoQzpe:zi$skNB+9n
exD:yDi&
*@}Ά[F
L<ӽ3^zxst%Fzܘ$T;]2Hi3̡](\Өző{h{Ir>:ɕ7*P40D>6'iUZu$]`~D>DbMKQ90	tBו3.]S( FtDaI+A`{Y4Otv~@|`zq9}s*Bbw8)MQK gmQ.0>TucHMQ6&=l;u_ESjm\]I18ȃ70DL$ap#
ԉ}wQoGϝW-c FfoYԀ0W
{7BL Rw%$5Ē	o!3ދ楩xB;y3\N*8=
.M!tT-lvLzIڋ3ᘣB?IF;&X4ZD-snLeIJ`؃|v-m|Ou[r!5xJAW1pi~"bs)CB"'ӥċfO2ja=(CWQ:naLAS6t	k]mqZ/)wv6xoe1":A؋4umNLjqEb32v&=-GBӓ*ݙu:TB,R)c?NYX|_e>EI?\$sBFHX$_y5@[}`ә_ZW4Qӥ(>\("h
߁dOK:
ϵD^@O)lHsY#n>1t G8j8dyo(h¦qcQ^YuuSx˃־RA~N-JA2Rs&=Mw
K6:hgo|#.i$+;5Zguw	9-{3to|DP$E3RthZrdKX冬NDw((0K+Kf#Q`CFHtN9yx 8̈́n@UN8t_btNFbSکCR$m
) {Jooihi9WS3OYјԀNJ` |pPOe%-Cxh>m"Zb_/&کYK՛^P`te?9fVl/H^rZ)ޗZd緃TqRߊ'A s5sY-YX<^?Ike_~K?
zE|uF4Rj48;~YI~t޽z*ݽj~Q܌Вfs1mUE`ECz߄J3[ߟZ(K>85n!ԓ٣ʼn[.G59Mpcm˜/B:M/jC8B
DɛҸ;[ ..Qk1mE/#3^TCON:&Ͻ8p<0uڇkHp>*8ź0X#1!tkчu}/y^ّOy4NB̗)H(cUMqKSaK/W$`2Iш.M'isxU9
R943=~.&PKr7wuy|_K
CPxߪ09/FORMEDJVUINFO
]XINCLmemo-sv0019.djbzSjbz?w{&E8=mڇc6bvk1Š|B>.J h:h$6.<(wӫ˩=JSM{jR)沌StʚD1WRU8y5WK A>J{\'n
`I%eX:D<4 ZLNMj$pWE?1[?\֧SkE4ޠq0c*l?~hr+hIjvF$`1:`3i4Ο	3[!]:e*c0ǑUmr¸J\5J)sOXy*K"ćRCPYzdc{o,$+k hWM%\D<[\})>,ӵnpЂ! 3Ϋr~z(O:'o2v}qg8;/Vt{"am\(dh;gHyG["l-)c὜dXn>`?mR
À-? 2Qɱkͻ`{?GA@{y5ׇeAN:1GS2a>ԗYMN^8M隿/{Zq. {SF xK]h=nDe;xQtf:@fMsںvEۚv%$Dʥb3>V) $>\H|JԊrUroE}5BKDuibQ:m9NBm~RxsCn;C>~崍k]ɯoDbh;"
ÕU?
@Sw;ĕmRkb.8vXY BG%Jq5q?35DQi-,HOhot݅k_Ek¾QfLJBpAirCi_A>TyYNy5[1y˖%^צ*}pEOUrNX/7)I/]Ժ² \e>`⨢badTi!x-21QN9HʹGC-8q|	mƯ^]{uƧhEgNC9OE&Ahgt3OԎ,סP;{;֝E"^bu|/<juA{њE|:?!Z_o텹4뢝9Kmd
UhGANPaun}x
}xqOcW^llǐ	SC}ȟ]$bNA}-DkU[2{myӇYc6^$Lw6>OqE02Rl#7Jw%MNf1ɖSzSD.|E>c`]
LG'U0$vױUCg^&rx]*0`0+}ᒆ/%m >4
(cS+uћއtK>p}›1lPITa<Yq*f/ZTu9j1,"ZW$COO⸣O^g5h[NSlR-F.#fJ*p_wlJź{?qJ+vD
3S,AyXRп,)<<2چ`1ZAvVTLЫP$g(r
<-{cm!HhVE!pAX̾s(,,Ƞ[G0j'%ppΚI\'!Ϳ)4p•8[Pttp7e0s6(S|N|x627_lg
+_>/.$c<<ӪvDDhIcUN%0(V]C?
-@~j}pK&͞)@?(]oS_ c
'P
 S4~&T/m8*EVTr+O0Z*VRԛ؊ȓS6fL.
n$z7
=%Cxyd^ pvum+	Т؆3GOOaV?y%&B]:m;EJdq[̸zP/:c>jG4StMm8h%xw@ɪ_r>	'UHL:>>FLΠ78W2J&K{@K[l!h4#4J~R\	ZȪRL RYOJGKHI~C|4wӪ[Ϙkn} >NE?Uph6/69p:^P}mc]L_,7$δ؍m_Lmg$SMR`W=(L;:|9VW|a?szYŬ)1Q-~fd(Rp m,)TdN7RAx젻Q>=P&,)DiKbr
zU@5eÚU%sEY ܼ!eS(]!Y4<ɱ Df5%=e]76)q+#:@zC߀-5c8u-%J'źVNw:J[b|Cuft#T؜3\('umfͤP=|~!]c^n#R%muYxvƻ6o=qUY,M{>	Lkn#g]կⲂ$lX1EMcC'wic촢HoXw$O<$5psƣ5,GA"󌱾y\ʳopK{MoS2z?䕻r4_8j	]ո3L M@[#w){fWf,H:bSΒٲi|s1M8W>I6m6&4_\UIJ(6(pqfKiJ|Oyr/FU.(fJ 
^a Ki4,gp"Y`m_JR+\ֻ.F2LY^9R+Jpf1#>YzvJN/kր^}0/s]iyI{\{3tʐ)mAiL{au]`P3@*rzewYhĻc=2z%UG%!7w4đMSpxm&+"6#{1U=_jUjuS2_0#?$x2#ۃa(s|H6zpj#cUƐd*<6c%ogܙ49jn#.;!1t0`T jy{zA$;JQU 1L6(rICA	`+E?]^	ShL%&HlI6v/u-\*чJ<m70IXZ# ,	tb3)<%ݲ'$"p
'9Y$pkbTD#!\q;TCRmR:)B@s a}WsjT赪7h;V4RyyYx]s`) Eyq>v&f'Vp7怓	KWNH0?-$JH>6
%oɋ
gOGjUt	6&}]}5Q!?F&7rfڝX/X+6_;Р#ؓ}q]nαB\SFUwx-ߕ{A![h[Ў!b(c[nngؐpzVC(;PއbA5IW5$ůc'mtc"e̔F.A;'wi|jIt2jdGm~4
6}l'')>_g@[-N& ЊQ49uɿZ>u=p]էNYqvA42;!qJCj%P?mo||}z<`<˽⴯z*
wX"=ە+NJhABIlT%zٱƖ1'Nu-J\f;aθ^~`ӭ%Ǚ=VSyxsfi?_b:^a.i
sY]밓J?Y߶No-'-B4"1)4ԹʫOju59if=8Dءo\k4 !ZJYUScf.uW?*u$t\jiw[Gn
X*x*
ݳ@>t-<#@锻OԒ5F3@$3e"Tgl';_@4Y'ݨ҅
1<ʠ#a.]~0E0+ ?!$$7>3!(n #}!3Xo4?bPP,wSIMVDYz,CiMd
Q:ƌAS
pZ/Jm>>&T4}-5a~G=!Ù>rin~[T5X%Si"*	lˮO4Jm_';a8
SL(ԥ:k댧v`L& Z:BHL
!knƥ[+d1
sxs$IuԲgjKr'KhVu_Pٴ߈
q0R2dUqz}R<4:CV糠Cm*gd]0XĊb^V*O›"׈{|PZo5R-IDn]KεbtqCT@1d5c8sj]pgWCmpRA
q8w
Ȫ̉8/ rA\5Z޵+"9)+BJ;ʂRjkf1ɺh ֥C^	 өcI|vdR]qY	(Q	:-	AuZQz?r ^am	,xt?fٓX,i~}R+	c	OD5?QUͦڭQDQ#[7?-!a)YqwVﳳ`xNtW *:Ӹ,h?rĻB}qS}Al)[_z-T`3C}7d  Mj>Td:Cld}}-µdyr{m4Hc6Ģ󝨵м+?e(؝dH{^PZ(qRgTfp'HZv)[
;p(.x?$t}ICv0Q7s(&b$\ZCql$2֛ȉ\ÙNv|jžFtlZ}\qUGv	J1tm:zgb*]OVPyfwl/v`\xڛ2վ
S+R4^	H?0PZ6lX^̞v݊bZdae~uL_-Ex]fŘNuң[30Fk[4vJ
43)&O+͆gCH-&)Jug+uncGғ//jAE#MUS!sjn@nMԎaXTαgB!?Q[Gu3'?k#eO!ڻIwtՐB)p2Jn.c++OSnr.Tw$[9t*;ꃽݺdk^q
x7M49D6Qv`bT-IIo~`yc19 	_NRi~AJ%==P_bO.M6O;4s2Oxe~!A75PW+Xmq_"V.C~<\Zh74'˵4}=V`"S֘t.҂Gue27ɬVh%Q_2<P$@cݔ'wdlImUh!d^jMͦ
HɄl|桢`=$sݰm1-܆Cn5k`*P)q!"Ksu,]lUAqW.7Hj#j%΂<:#N,vtAC_OL\
M4tzܠ4l*dޗ?vL|AAnn$$.,(&aD,4{,{٬c*q7(;54(Ry0J;dqN{1(^8.DЛ+]Bb֠(NNN6u9x^{]ejd
%0T8F(|s"L~[)/u>Hcf	mt?X9gMq㪘g809xN㇎1IrktoD0+bUM	 .u3K}?b-r< 2nL|{`w~ƟkȦѿ>5!𐢵43qh
>/EEc;/p݋ImGQͱfQW3߄awvGxn@lmH]Q k
3|~qT	%A,g)T	(_90sw{ǣz

}OSKt>B9rNUqN,A@ddG2㬠7Ep]zvJ\V25
X7S|o4}\<,}(&JnAө`(xi!&_д(ҷ?8d1Ѣq`g]%@N
*KKGe:/bE>b߾E8磁]H7 4뭪`y@k8c!Ue
A4T>hɁT;);ɇHnˡS_+",GSO=lZ7̇pfgnk
\/u|2VDH*Q(9ڷ$|	`fO>psOzekUE?NMOsyi<Ham(pKʊr8<'ܲ50
vޏ V
j _"{MN-іȲ~؝	5&ت*c̿6 +L[1x{}ݼ,Nn*j=YېM. *1"MD8#-|ڤ>mPR=u$dZxވCejb!Uv+}N^POAH>4Fo`3u}kj@dq+Ϻ-!jb&ydϥ[6	ŁO>*dNk.<疅6=FIn*fN:,tmAed*ւSq
XKP'7;kū"#é,bt¤'-4S.#Z39GMO;A;Mp)ô=ay]57zq`Zp(A%
&S9_2u0''*	P٦5~{9OXlߏUJm'ĿQ4!jZ_IR5l>#?[RR'TV6ppH`gtuVKj;99͸jrg%:QѤĝ`Sdȝ(uNTnMv~ X
hK#$xzc`27i/PvbC|	ʢxISDl]5:WPT/
<xOpp2kAoEDmϽHPQ2[+[OSaCbTӆg\yPGU%3X0{	=|=Pf79eHW__ZxwK..NXF}sS3vn&fIOwVPS1܀w[]־#gkZ,ֳJٿ5vPFͱH,:酴F]]G\m	K8vW$It8JdM'lJz"dHj5TIN-hdpgBѤv0DX"KaqyˈQq)P^իD7JRӫve!)ݬ[$^QzJ~=R7E>{'
O;jT	Xh]+\zy}X ^b^^%16SCE&᮶䘀T"n?Vk!6ѶG̽8`~>ِ`}hxM[]<>'DFXݢp'""[΃t7.
]
a[7`Ӽ0
s,H&,˂6~q9=W*yʸE=Jq3:vw9TPB9Wk
jYؖ0M3sX'&WK?iF-KнEEN't'SCtMml8fiQ$frV}y@B"`!fUl쵍L<Ye4ϥbluַJ3rh(2{u\kuϷue$(菇6RᤳZJ`sFu1+H|3m~%pjdSz(-Ss}zܟ-BZW-f\M2γgik){z	 DjOU]Zck
]l&;%&|ySv7ÃI;i!%wڟJuQ3Dz>^xjb̦zƢ8~\R0ułʓ
Q%pٗ<@
hƸS3׋)+(ް6_
kdswj;HR*dw{c!l0V۹JtMX>|haPt%Vb%\ZlX"$QSO`H.AI#Ko=LȄd|L|[d3}'|%]U80oDB%T
DV"N!6+80xuB%f
*us~I<ċ[).ףb{[bAϹXKU=

1lyεXwzgVkv8kѨOj5$Ǘ;	!˃K!R툷"!5?Rݎqw#ǂ`M
Wǔ^jΜX}mIt+#D_
dj*#B&g7t=@@:xGE
+g@c#Eǀ}L0(&ױcVYT2CZ@U^ҳ:>vVbh4)&Eh	s?W1n9˞-b^:BAGqd(98?$&(%¦4>UZSHMpq@>-κ܌bmf9{~%]J`4tm#,Pc厙<
|۸zKC_wF`ן$hXۃ5|!JiC$%,%$-I@pϓ>/m<:CRIџIZat$N
D^(o]9ǥ=zⅼ98"[KyQ$+B1ZFloU閡xk3{}=|M2ƞ
鰀Gߨuf=:Dfg;N+ё`&uξz5iq
SDz;
EaԷ3lbis;Cwӊw)iA͠-&|8Vw2@B`K#k7^JA
q#P1:@!JWf}mQx;rE
9vE)aZL*B2d["6\"/ů#M(o_{O.jYTHhm@T73czΦ>Kd4}-'5N*!	5rFo'IӄSuluWD9x7K8IS/f $H‘S gRH;-ǍU0ؠ41>isUP˰x8$#I^Q:F@	)d,qX(c8%<3fm/BP iinm+P%7ɾ wﳳ8$a\qi+C<~Z]|9O˓RT9LQ"wpMџʍVG!QkW%J%TXTzsd@J7l:Ҁ36¿vg8NQg"~(-.U37}`
Kpy;^qZXn"c7*߾7d-$1dMy@vytoQj45&3reK}؋,j|:lW=:hsQ2stLdRR9I`Q	,(PԠXz>bNɴ㟝jqy%52lc3s+_;ȋ(r;Ӣӹ]Tŕ$(n|Bx04YzF-.7#|w緵H]36>ޜ;UEb%w5@$=>l	9_l\CIggݪBt"j@^Ï!=S>b;`$!U4^\Q]+,c5\
ZבbJNXsn2
@t	:cA4C$ع/~G7Ea&])F֏v,Rsc|AҬlq?Ts
B>
8ވw"R{
E Y{W@45}boEUk,IC3ܠHqJ	Pžsj^BZ߲L=1w$qOa_OIx&BQv6](AjhB II=2m6A%IceF8KjwtWt5+v#U'`-psf*[a]ݞMQ
+eX~Jv-6	M
-F9>WCj,o_xK˂Ȭs>dpĸkO;wFP=R`Yy˸r{s)j9z0ksԉ%Xe[Hr-;iS]E_aDK`b`f~ʤ늓sr2itPF5!`ǐsĂ7)jn/z4
P廠Ht3`%*^Jȅw\,{{Ml̐oТג2d&΃( (]ҕ}FORMDJVUINFO
]XINCLmemo-sv0019.djbzSjbz{&E5^`,t=qic`ڜ!۽uϕ-/cl,B>sD0 =$#l'aBPF7Asq\K,ߝqpąnmnפ:p<EOzVݷuJG0mOeOk;1]pedzTmV<̠ku8$w({0ggRL1.4JZ/{-hvM3tm
UM4dˋRSWSTOb7GRi,s%E6߼%zqD4ݘ ~pXJ.&zG"`3يAI
{ȋ+6M@)v%LbFU.S+_PJ,oOMC|7h+7aR!?$4J\|,I~Ś_5tgM/uN0|FMUY$Oq^Lt)t>Gwz2-OM}lΗDNI5)*W/V~ 8q.xD>ɴFmŲx2QPe~![RK~an@'u1)	{-Vf)zkNliju F(Gg*AJ6݊¯#Ҟ`2YR8l
HHPP;yOx<Ԩʰ9UY|G!CkDTŜP)ZʢJĩ)+j/>UFn5|]+G
0rM0mclRAmɒ]Bʾn;w"9
ǝȲ]x]I>Ez\vzi) ,0-Nf=3gGfI]jύC)5'ٟ̅j1HEC"3s*+j.і9{Ⱥk^L@?B.wEVߧBPsBQ~V9΂E`p@`ý}]0=m6wƐi|wD#7'h0"YFdtgMȝ 

_/t|UX,
nXoYfK-嚝H^oSɍ/KGڃtPc)zL&49T%eU°p~,msسƒag;F/[(nF%R0^c2Zwhs`xI)-&A.Z?EWuT)ZQ |)s^}M5f-ϔ˜8xｺ$t*YAIdhUÐr!┚
" }NR'oRb^!ycxuGjqRn1'!.CR"Â*袈qOA~_^vqN.:s-bLKI^hٞN6rRؠP됝F0Dv7
l|Cg! d:PR%F=I%;RfGm%[XS܌MLc;%\ܮ	V3yީk#0]sGF#Ez"5_Ὼ)c6_0,=Xcۃe(	]SyGWl37e]n0]jlOpۂ7R	x[M=xZRZ*c.02J3@ǰ\ý0Ǹ8
	(/	;P5yvA0h9CGa*U[fyi.Ց\NwCwVѡVy'C:6t]:m]<)K>#=xNЁexB@!eDmD@0{?#pU3w$tc$8Xx]_WKO#>r

ӂ.C/nbIЃ-@ݎ;?5pm=>{E=BVo%
9/ |#uP_CiOՓzS3CKD1LiO3!L#2K46_2"\vm3J50mKs~]/eC@&7wKCsKÒ}F^&|j~j6h 8=-sd"@7
E"*jU8dj%KD7D5cMu;]{F\K}#߳>fR@<&iA'ʄhp

+n27m<5z-h"~JR5D
EtY3>ׅre:!/ we\5~uB߲U~l^JXW6^3qOHxLO"$u@JLioYPzՂ*VbЫ}3aûHTtYRCQnXŸ`WO,q˖=aP8`]a`ߎ$kq VyPP'zteY߹kwLV{WIc=5Q4>=:"
~L^5w9tbU$AD@WFz;}Ol*VULl`Jm._蟁v`G*>:'6 2:j?{zzΑ|@S~΋Ҽ#$^(rPp(A|=P83v\]cd'e#
ӇfF?Y\Θ̕(	܊g;mc8ݮ<#Gc{a}Wr
"
X<0I=>g/n[Lar "hAhF\c^iNpn}PT'@@M=b^U1$qEPw	P*8!EHC0∿Wݰ}
^umby˖%k"bGdRk@-]28o태vw*6]BΏXe, !ԥ3*o1s
!dopYX4^)
(bC|jᶧ?o
W,F)Ufj?<:T00U**k(}}^`#OQlPx0ԫJO#@g5m;*}bSgCKj$,>--;zWlZ޸16,%\K׺ǮRyȴwb>@_GDxB铗)o?LJ_רi@Ҧ
Њ"{0Kد2T~^!xwa#*F_%m]X63+-b;+O&Hm. ItZ8Ku*_ v9'\K#ck-^넕4l.?a=)0~ݞ&%6JO'wMikcQsd-a"yIqڌbM.n@p84oKh'E.3s/wbQw7:~<]]\&.wbڔRWZi9rli>^>גl#W+%OM%= *vԱO2DaN56_dz/8hjʒ
d	>󧾃1I+(BjE{tmƼ9y!CiĨ8Y\8 ;dqRc.,v
%;C
kC12(Ȃ2-ףߣśpLOf
/s
(	Fei[$&liO#DۑV!
"g
ON"TĴt[cy"կ[УVc
\LuͿ66ZjjF'tdx#LXzժVD
HuQ aI&L>9>i )+
Y64W&+K (n	c]xlc2M(|Һ_"!ȍԮI8ye
d-u_g``ړSIxqk]<(DYE\&qv\2gJ5R`~$hImxbô'(8kX*j:&, HlE|C<=͙DʙeO1WL9NI/q";p'+bf*h;^x$W~\M勼&lZ*]nQvjH-\W\bb:^-,HΓK^=*CgO:
cR6$.$V}N2DwmFHjtT#I,d
BA7^EI5):)ȞcRZj@vJP/8:xj%yOhy-vTE'_.= z,ۃ3u&
t揋ضrG^g(!عKS,k'AAtuZN!B.ј p(5ejv
qh?{TEB4p9zz~ml>$}ź2<Le'/8mA8ԉ`xO	Zfic5"Zcf0]
n	esHs^[fs7⧊``և_VpM_"f"P&gצ~
`;p*4v= ۛL}5VFo4*B-~;ZU1/CMƪ9_(WcR&QP%IG(Ԣe˫W4O1Ck. %+1hjK"Ԁ(A#q!ݪHH1Qu&oQlyPyuxBy^M?_p	+EF)Rp`i퐗D8;bm}APX!ɑ?G+ru~h)N{g-+Eя_01G&&1$mLqtnѬաPe6bdjAvx'n>??JW4vy86C_/
C)K9A0:n{'Qx^%BmqwdL!72y%
?L=ΟEB
yDcaP )Mkhu;XJ?B+>'>1쌡hПK}$)G!›l|)¸f9;:Y|.(1'*U)0yr{VvPjS<Fz$͙4-(7aLlep>}``v5΁.uqxi/јx+(Wt>(YTnnʲ~mm)2}Y"OmD;9yq6S.Gye\R0 la`ι>b4̷ K5$X,/:?>AMyv^c%,mn|SZb~VU*8]LlTp?YēMɺfBjSQ$r"
d|n"od,	$ZyLʶʇ,aG!ٔE|p3Q'{U3"[,0Cۏgv1#dכĴd DkF*Ǟ~Y$ys0™(t7ɍg1&jYGfO!%s=rzh͐n*ONA9u60'=bфO~nO?r yF
Huy]A$$m7^ҶI''e#h^]	x(L'Rq_#I,K`4mw`Bgjq?Zd6Շ\aycN=OuB125pj0J}i*zjvk5>$pH⭴J"W'7>p%Zfp!
'D|J*.^7b$yI6r0ҵm0޿O
`Gyg|oINk#Ke[^_KkS~=P| ķTMߦBZ3s40cːhFr0ehJĶ}~U&xVrAAg]u2fcbB/5`G.w

IIvyD57to_2l(\M\CjxC{C*8ϑȷGeIe#&﵀sU+&(ވ'^Az,M?FlP)ךZXnϭw7{Q
flTR&A<p}Nhf)*g l!ѧf%6"=Pob}[8zta-#KwםP"5d!-
z+jt{W!lp
0'`T~%x1f75쇬45$*XD+S<3W<8`<^6oLEzǿS<mK%9[ps1#^~KP<𲑎XAQg'ɞG6M,\[1? R4j?p%(\א d>c@P9_Gk
tSXi)YKW	2AU䯇)&	ryE1.:'JO5RߛHXWs\K3Ӗaʿx|EPĮ|5?-j{LaU釷w1SVa|tInU`b|z=;Pݔ"_ł)'o,pͭrrq=:EGg	|A }=#Tᵠh#*(\dG~aں\38h^^:ϭ/^-1kA&Ac$QZ3
C.SGV\]fimhq̺~Kcap-^:>4lHzoAkMfDrԌy&6pl
iYaa	^(L)/ɓ&6e;7N
-Uw#kb[BmpYXPJJאpD™q0*8dgᏦI4gܵ=RʲuyA
(:Ed2+@hloiӅG,<<>W
͍͜\Hg9g簝ࢬrs֘"ۊe8&w>]ǠgmQhmX7ό>n00A`AP
AQezk
a6t{
Hl"&EwP=Y
u<4wx >Z*KQe~T凼?bq{G?ifx
9JX9f4Ȃ-!W{)9H~Mts|񀼊p
Lgz81
AZhu{&wI[ͷc67LTds(=.
F_Cwۡpդc
]7ڏA[Me/7>Po}ٍE@ baVo9r?!T1gFa]lc(!hSG"[tpInOAu-8.fgu
g-cH	#R_!{xf~7XbBmɌc[,Ɏm)>츪P2^҉iLNNHY+	k*0\obAwwjRf"[:"RD(e뵟l2Zm-io׻yLOh>-p6]1Sy'&W<3)XSy$S`	ZUg`aO,^	/oN~R8g@Q/z2
Ɠ~f{$RɿG,&kD)~^->	3=`R`i>˴Lm>
gs<*gtv*yyO7D'ۡT~i|Ųx3E_xԣbܳ4,v|nyަ=E
(4HU!
vf`vѹlr9I=%>``MvK]Z
د
]eǓg3Z=π0gp3~XH)vFCMه~{bT'zU7[X+ׄ׸zjdwpڷv
xݡhy9[WYVĖn?TVʫ#Am
x
 ˍmLM=On;[m6ac=шjGUE

k!hqc^?"uTMWHsɦ!~ræ{-j?bK2^5eFoK(GH
(բbŀJ'6JϙQoGGB%J'CA5@ZZ=lO	"w@c-1&kE)NXt3f%
^G!
%eTBEr@f*+$Tq͈V kDq-0C ]zAEߩׁՌKKZR^a f 7ސ@d@@5Fp&㻲~]jh&3Yv02/J!Q9]Dj\ōu/L=sC~5805̋hMA!-XuWaTjRϞ@|+JJ9tci8L+1xcx:`QH9`w_	,ޯU'ofJ\WwgyDFˏev89\q&[$F{imsˋSJ\CN;py:]VnWkrIX2b*^i-ݓ)]̶)>>ڰ9Bs,8X4#c^1xSǸf!Vfy-)\ @!$`F"$׹m[" S]"D|#m(b3abѸ!âŀXFu$L]'ë9]:oUz~=4Tin^qTi^,;$:yBA 0bk&BD)Ʊ_Z=<Ң'Xʎ=06*9_&@C{cLPi#U;+N/`5q|}k©4
mM-
3\P%Lm/(cJ)aC^6v텍	5
8$MkxK4OvT\Ǻ]RGtp͎yrKeiXV$z$a:{_rtuRO0210XGGdX
`LH\BBj+1y0|Nd?& :D4z(N>j!u_8kMt$۪;JphZ	Ux	;_GR_HkSAqs(tT Zr<@h!I~Z|yCIUe[YgF0-akNX{4F0>h]x`i_ѽ0[֐Ou>XߤC=,玟
e_l+e!M[TnEJڵl5ɹo`jF)	ÛH`wwDAPH-@$3HQwBnDH=}k&";[KrE%, ieEx EߖMG5PMJ;|P1JwhERK
"\OMvoaCJ1P~J	cFZy@&lUgj6
k}ۻpO
$[?TJ‡UZ#N[,8f>NQ>C4;*Z@./փFEXwR},G+y]m""6ۙ`_)-5`	-'QUd7n
HZ%_x.鷪9@;4iQm+|U?Kõw.LĪԓM}y'hv܇5fElE-$5TAUF?$I֞t	7-hC]s"vlPRls!1TBg|r-
E=/))
Dn
Dͨ˯F8aKa	Cj~/)blh}_}vW!(GfEk0ءv*C9!D~>vo#Ŧw"qc/|1\y~;l!N
Y1Iz֥Hf,@Fi3H{m(Ol,Kgc*(:
nܒ5:!ߐ(?)={3+UIE(4pZmEͥB7۱7lj,5qAڂ!TdSeQn;|h\}0.U/yڸr N#]Eh[x;;VlWzZǠ^fyl`d62tTY0*}
|R*WPa/,\XṲnLwc/&e+˵EM3vg_ݜ<~( m&JKWsgfBo)RLRĭ{]]ڼ,m\]a.ͳ[
n47^}qLxޢq+I2p:aT?ҽg¾x`MbW$O!I4dMY狡ܸ.y?>*b
_ˁEQ|3`ޑ?P=
qdY$k`g9Dac.Cp*YNr@nh(Dr[2b#sLs+TIQ,v
y!2SЙvLJRP4c!x,4j?^B33`lKP3oLj/UUbm젻D@QIf{KZ^g٪DXzIaum=7tX|!B'J~(qeG$d<.N0m.N_̑v?n@cW1p0‚YkynD"AuVrQ\qc{V7H|TbDCW85f8`xp=d8a$^;.4UfxIen*WI
l (m-G,ߋ8zMKdpc~D뺍G$?	q]~T;J
\/u:\R-bsKם,]a[v,#z.C}odRRˣ6s%I|^skU&s`V
s2Jj8oH}~a8>S~g6-*K;@(C?SX\y`'E.X
К2:q"Q8q
O#F7|ƲtĒB5~XiČ^çBʝ!ŕ4WyzP2ΌwL][X[;.8VSRg&:HS£@\p?Q%Ȩߙu瑧򯜀͗@q!ҁ6/fvLnykA'%eC\~(&d[T}TαDz?Q٬ouj7їe8`'JWg(lR#."D	U}(wXfǔ,)FbjfKIՌ5!kdO@+UQ-4ѷeC4/BnW0 )|[tӷ,7G|YӛMb%Ob(Zz\J\iDH;B/VT4qZpԍAV鿠u 8n	3A
~MN.?k.h$"Ց#' n].SMk1&%?6$-`5U!I%7K`ySqZ9|\2d\;VL,]90km.#l2>WO(E(2HGp"xQK+zQdbQK?0'+o9"Xu;nFkwmXE@XW[	Si-=\PtbȦFO`_
T'eK+pi'ڨq.824Nz4
Z%1  v42ؑJ;R"xxDѵׄG]-h:'k1iNFHvwlq
@ɰ{^ę
8);q
WE9b{˺[F6֎3+}!@NkS>7@)_dPmB7,vxa`Sd[qϡ,r#u
U"Uw{%
_̼m1XEh|du.|Z]" %Ś`?Y>{R9隳.%q<|		ڀ+m/LNج_}v%$lh|?N&hr.{x:IoNB⒧z0=OII(hؖ@Q^I?dk1jhZ=ѾOu7$:
	(9iΫ*-ՠFg:Q(LL.T5̛@B%i;XiY8יzFbX{F9Ẏ7yz"[)^i>_T?w9xJH8n<~\lObS1},fpv3I2
+pHG^r_Ew$DFdeK}RŎ'*Dｿ+M̂dؙaqRlA1l`[uion[i{PԱNh֍ne``CO˓+/}XW>-]#~b Zpœ\`?Esbt#x{a
[:9mMCq;FI+_qW~u'52޳h{Z	"&Jdwv%1G9P~+`37X`\`xl2&HA첃K*%E*ϚuZ<Ց2yK%g!zF5@ak2 @NqWX4ELgTu<&r=OGګ'Q\Q`KW:3_16;*Эk=N YӁ9HhAk&٥TT-Ngymr'-XI\KFKsŻ64zuqKjK(E6˱DTVl3185lnp?kC
:k/p41zDJ)1>#σ:Fj\*ډ)yloMnɨ+3Ӱь#-lfZӴ)b5LHK2Lbm.$(
0Ra/f_@#aGgMw9b%55#}w_ckx͡QM=VTtk嫶fdK8,4V&/AOw,5I&zxm2av%Jw{̹t̻QTGB.C"j!o=ֿusIɅ3oFh[>jowbg\US+ЋD*+w(\`~򠘄A"nTl'؊
UeN#n5l	YsN
]gxl-
]~g^[MjXK"s9
zU,M?NӘ6mLdb`t:гPbת/sqi[^dy}iWj5:P3xI
}]	斝9|*<{ώ!$YU~d4p#wJnJR۳a俯f*.[61 6$
砠ڑm70fYAليϠհ[ByWV7M}A
d}z6y-Li}Yi8z4Kp
*]5WcGg}]FM
Q$]OM@cDoВ{Ojtn-LND*#fMc5͛G?k*z)p0׃ME7/ߖ5
Ajs[9j(u;YH,%L\#-P0E{n0 n@|0K"yAC^?
d(+H,5:52n*$gxN'p5af:5pKbIu*/):rfH`Xi^ʼnhoIaaC֋pzY<	\V{r.{MmK}$T;#S31
:ukO[kK[;'9#woqL(JsHd2RsF/Ъ,W.ypbM#X0s%ףcBac{{oi7<av$/i
pe儋]>Y·YdWW_7̢u}l3mEʄ+u=!q3KNXf0
\Mqx{	P{=˖/R係K`v'C[7"pپԓ99R4}`*[ciE J*)e793lA]R6v+1ɰ)_Ӈ"cմ~[UkE#(4v_>TVkRpܣuU# 8Ôphk3_uWPDL[ɧkЮĞsi{oPxcoqþ|X0Nj͸vu(L__~v$lEڜʹ]2ʫ(|58f(JE$Q˱$GޏuIZIcLS3Xig/NJY<Шd/q+~T*Rہ>s|#i3gbc/bO!\6:з17jh9%8j1VypG*Цgq[Od4KxjSdPE胵7Ba)m|<Sg,`yD^wѵ[nꮸӢ.7A ߖWLb2gw M=
/\~ԺtV&=@-מBNtX}@=^Dbqp|B,YoS	^bgz:ipG3j*JHKWZ-9Wuy*4mf#*nqf/wWu0/5^WTZj@W` f=~R6i)\
ϠAOi:(KK;툃lOsRw%:pΆNWjJ,ZmSC.Ot?f7a:Z?eV>oF0SdFBw.dtM|9uw2Oaê\wwf蔀;@^0Mœ]:AcrѶ?pmyfJnczer=WgJe:qaNr֌³rBKBxX
Y{ O&0~0Y!2|g.YI[Έ
d&lWEQn[
At;;O߹%G̸rG/맏:ߟ&*{ݛǬW5
adVO+9k9SY}NiWa!"EDK6
AS|OC))GuFgFȄ??]뀊|߀jƹ
lWQYݤωV4 9mT/,-1]t
/Mf:15L鸅D`	n*';1ǧʕU#&ZiU4Ԋ<Ivz-OkĘUg4=)eNT?>G@6FF}5xr'ݞaajnE䥴@J*XXx<'P)״Vh_?YǍٵZ\Lj)
C9/+M>jMO1)Z:M:nC,>g)(|V8Xgi.#69][;J椥nߒ^}h"M~s-M9y${aɯiGL̫Tp2TJ.P`!"hp=Urލ((B~Xw,GtXP
C
~Ÿbhlx%w,Ghqϴ o]̓<Dܭ 
1V	Mj~ػ"="Ɉ~
l([_n؂]4L/<	qTi%g{J>tN<榇ݘ"Xp??ђe)h;SmXVұi&x~;FWbO>=\G3>ǵcj&(/te^[zA{OUUl3Om3O^se3|ͣz4u`^HEAFnʁx>djbg*6`p!B=u,2dJ{h+4?2·wA}Ѭ,LMghT;##~eq5
@Ż(O4@`hZ>DfwDgvXD@
78@c0L=OGg3db":x4&ֹn?Xܲ@wofmj!HgA,3`y?A\1ka"o{Bhic9l
T!'["?ن}:T^)Nu]@{C	ӦלϷ`H%]~#km{H{>	AC;BM2@Wpn:t@
e}%kh|@<;WL/"Uќ^RϨHZqD5ZR>aC9JV;w%\P7U<̒xG{]b+4܃#؀-	s=@"H;"dQ/-0pq%|թ
{V_>/ޭ֖Q'pwIؿc"3;82{2$ÿ1B@Ϸގqt~a±HtIa.έ
ZSx-FNI8`YFV@+vey+Bc{g?uA-选K^icn`b#sZ/Q86:4W3 QggsQH+ppRt_4K}ogCL	C.#V)L:۾7?a|׍~J Ry$S$?Wa)	'AsEܻq!bUmxK7=&&`tt$=b69}.$ؗmi9l]/f_8
c{O&~Ѿm͔g^8Em\ׂKډr/pT{SVYênd1|)šN*@TAhV@XԂTMnȍģgD&?clr]\G-¯aVXMA߯RK$g-XƠF.qH~})
|bGˉzУ]A&F#d^|=Fl^㍪UU-d@%fBU@|g\Ȳjԛ\1um2ViUM'xZh?{s4B P$#YV1|
tGdh뾦Јeeq;?nҗ1񰳴L|/E~KGRx~PՇ(/wQ?&s)muOK7żΠNM5
,i66eCǂwVh̨=9
q!f+\;PNrzJˏ;L.|=`RsϨr{X5٬V_)#EKWBqnp_7Z˵7 ԝyQz9wWTݓ/b)@bӿyjJzgxQk,n7zsF7/W|G'
gEV6FyZ3	8KY5<6=ɠZ('`a+]X“_먠qؠKz*<(s%
AqdCM(c<7;>֎F*we+qԾ2ՋjW-;$b.s,Č_'^Y14^=wl*2#&>YrFBmh8C!$";hjY٭fxm;JZō.t݈@u0#-Q9&D/cXߧbvࣞC1P&/{pVq,#o|Ihe>C]!okfIY|k堅;δqϽY'ub%|g=atQr5"zfY-CV$_O=Di/{?mU%HԽ]K'F9$Ց'A/0׻-V3|A-$H%$ZD_)G`y/ϗLXҳg8U9J_VmG
98ztշ#ܼOW:¯2 Y$W x5>aG}"0Y:r#&U~[quQOXw
F.7jt|o
5 32VQv%f$CO/琤
"qI	[űt8u߁#,Hct,_ɿ΁P<+l~7%&Lxei"5Dq!UO`monMA|n:.JgY2XM]ͷ#`{E:sx)׫su2X=R4B}X)3/	8
)C4aoy.5[ر|k| $~'ꛐ2Q4b0
b_$[&tJGk ~Ŧ/Q(bE{S'=El͊i?e:q5dAhh8bB{|ʙi+](\G8PWLY=5c%TH]8sZ]p3rz1杁.^pr1-`sVuMkdJ>et+#>y@z;;<
7/Cb EHJdjmp4(6bۦ:ɹ{{vPg(=5,X}>x@qJy?`8&!Rqczw
q6?O#c-mI[IiwNDf.
aWM=r[p 22cf̀.ENVB>%{sjIfFI\}W`m6G<k^6r2:đ-P-[1jM}(pו'jM#e+ȱzϋp7ţN41.A3>y"XDz
,[mx;Pי61
LÀ VE5p8mxoEvz-y@F?9w/[f~˃a0EDH{ƬuV^{NKG1T+{ǸVR&;vf|Zɾ%b
ym- *%I>~q-\?+y{'A_:bNg?oDݙ,0sV&sw{%6L?@IXa5@Pssu_=MN8Qzj:CeIBb\nݘE]*\?%|m!E~NoF{°};G
EB`
qS6?4T贓VMڑox

'@	hxp!TVLPJt_Tx8Jƾ,tm"$κWE!;+]	~rBCRnO86	W;;X
(9=kd﷬H ]A(pFT}stiב˵.ҷ|
)B4NTlg׎2F㯬$k&.$2}
f0cgA+pGe2lm
/Q1jf6=P0
,05UDf
MEE)XVt'7.iK
$
CRY>"Ri
q6&5e=y*רb`fgoci0H^"khyOr.WA{![!~hn.1Yˎ8t6v5R)J$ؗ]Dk)ETY@z{.iэsfӻm/g`
PEB©KlҸ%MJf݁1v$猢C	^M#)c{KzIvF|#^a ,d0J%on((
Xsѩx$zIgf㹬P]lCP%?㫠&獌üJjmK+];IjW_:X5o}dA$W(-:%$xwG2e^VItHﻮ/M5|ȒGQ?:#>$	l\+5-(&+,#Ic* /{Y
7mճV+wvy|el$&]+''7@L>G ~vI@Eg)	j\B,~lzMcc!!/ ICDZhz%v|=Pz
O
O˛TOYӪx2#^ݡUElRXӖK	Tٌ|iƂcg!N%xO}΂!@|[-SW疖@0Kszgda{Mܫ[.ZsHjjNyb3
̵Rw]YT;N@tNx_v}q&BqL>5IBt%3f@ɩ8.`[7Bd̺
}[lS,z,
^AT_xGI|CK<>xCkEBCÝ͇',Fq"oHy>W: u&(Gg54C0AgS\NHZuӻKo85E/ͻu0w&*#]c7T^޷i?]2ɘyaAzs$2'2b1-EV+]?~B^nh6XߤsK"^uXഫ㇝NAYܘR	IUr|t/[X 2oՀ3Aɧ۹/XRf=yЅR4gDq{ì3]!B2-2
@u.mTő`NZ\+-tScWF90?v+SŅɜw
@k~YL3.hl<'3Q9e?]*/wiM:>tgN3?{C7ЙrW6q]ҠKkeN
Q42!Em1m
yK-sJX_V'NJO4-IuSb-e_e[gL|/LsIn%2a[́w 8BZc3:vSU}vg*8lPA}m`wQ&

ҰD4M0	'oe+\25%#lawSE%ۆkAk?abYb텎*Xgh3yJR.VEjY*{ A
Ebu`cA	תLypQW&l&Y@'~y}NɄSQ{)!Xyb~t	MWk-$wq9y΋EC{
YE#T("s7݅Tbބw;oF-T)ʏ;Og'\ć󅘚&ccvuߗ39^S0)txtD9%y蛙jX:ބq_n`v[M;,TECa(a`0JF:"xĒ3`-ˇ@>߈+z8.lEd6:&
ڙ"HwNJ{Ӏ~MD8(],祄(y"hͺtL=(Y[
SD+Ƹ_!zxjmZn0'w>Kdo͋rGMK 7#tq|?TXTz!.J?K7\&
)(҆4ݳ*6ɉҧ=l,ўަQrͪ+m|PJF}XaQ&Osn^LJ6uE))+-~:EPȹz3J;>%2D0^]6krQaC+a[M3#a
%C=-LN[7q0_q(W8+M1S^7PKdVv|Dt<*#mJyU@(avlfwh8]Fz?<# 1r5]_~c|I\Umqa9h|9gy8BPA-.ϖ9mRppφWᙏl%.,T&H~>:Qll #{	^\0tTmYtD5tW6\Gzj%Np4dLPD!>{֠gx	ꗉ㖑OYQQOvOtֻ~|Y^ui%Oo(*$ʻp{51:8zx](29&U^LvRBI25'&FD\r[	8MydcIR0SU-\n҅ж{s;]rH\qsz0]=l;!SqQ*GI)oe͗U
X6</E%4wz	D?ONOUviY6/?G,4
.O%Vmn4y4Ay/^,SΉZsz%3*Xb|4Wވî͹wR*ƒ6RS_0X8&ӨgYW˹b}&鉐$7
v_&xO i0DmޛT*ؗ3VUj|K3w$n,znJD s]f[]+
aʹ`w"jm2}56Cfd9J5;42/O0[M
l "jj~Ȟ9IGgh@LݹDmf{3?t3-e^<tj֞%$brR4R"gWΞcKljCEեĢAAs\;"dw:P_BP<@ڴ|iG(`),;Kd?A&`Ux%PwCA8VW/̚K!SfP}.yaLa>`bx	"{?!ʘL}A&ܑEKxN=!+>z
.]}
2υ1mQzvGc"[%LNo@80bJ7y.ߦs6`✀[:sQeN%"HΝေNה~kI`3KhrULvIC_+!G ^{ky1*[FkOɴ<}o}=(]ChnlJ;ʏU"/))ecw|/>|j;†h9{%Ӗ	ނݾt5Ѕ)Y|Z9skMɼSpvM[H*:)ڸ~	 Qqn.'.!Jp#mrug|(G޵LN){I	0Xlo9},dk,|O<WᢴWk6vs{rPTSg̓? WdgCl+I,J{C-=F0Gi!Ǽzv'
m#~=3@?W?H}79Â:Aݳk/ij9)0nD="mj)TN.᦬+'~؀0mֲ$ݕ˱d}lWj&7;f{:<\6ƚ82++9cWVRހ
Q"ƠAwL`L"6];9)"CGxXp8l5 =t3@w
<[0IYa7ˌ|07ґ!`<>&é<kh	rS_,=iP0+,LeD{4uXS܂"@(g3i^rY\ЁF\C**|$:9pP
&Ʈ"O1T=(yo.u4Nj:
6z׻+i x+rC#y9^kן5w5[)UC.uL v08>*0W*!jVtzv0j1kU쎰NcW.(9̠N.LI]PFg|>)nX4'H-DźxpFQpPcz+	{DI7%r#vbraNp5F4!U+aVfM'T/ɬjU@:i׉Gŷx'70)߈Cܵy6/RE;TC?[=nƵrq֒.&L<`W(g3yJ
!`?x*>(-U``5O`*$>TF1PlnSΙ#v 3oJBylygi*pi (cm1UԂ66-V1.(z9X/]1x+#
\1Pv
íe;D+EHYϦXݪb
/>S]LZ#6jd7=+Ғn		
p$:s;gQMQD#KMuy4Tq\]~,8U07
Dh.c.%6fsX=&j
Y#_^v#3		o7T
UUIQaVx"Hk\i _ƥQ"I䟆3l4QPHLR$K!qk_A5=",d9'4З	lb
>qqU
?gj05f*wG	l/[Hq?:>ca!o1tN_L
[1Zu9QL	//þ`_%띖a[ 6zӠ|EblkԇLR}gh!FORML'DJVUINFO
]XINCLmemo-sv0019.djbzSjbzB{&E=$

%x=”B8 uQE$a̜a)kx4$0]Xȅ6R>3G^A슬_@o'`0]t-x^21t
08m_8f5cMɬŦ̿cT0-M8#`j~@_Nb0Apem),Q.9#x)qYUkڏ8po|\t&dH$>3JUduVc՝+^jv\Qlwຖpl~%`s̤I՞h],9M,G?J[ˤ^^eD/HV6ځWӢt';Y5>?c4/ pc~t"eZ:;1"-a:@rf l+BhAxAͧRBEzZz)qjr'xTйC0Xe/Hň
ӿTũbDsfzVt4
otC-Tuv?GI.zݲQ};xybmhBK\/VY.Ho	xq
+hj _jZ%?7|SiInC$:L(Fsc^lf1/w(+C?@<""{K`cRq-J?HQYw@ބZk5ZB"rM2^;]h`P1=)XAs;SIS_v4a7#59K͂#Rڨ*[gt^ C4TFa#hw{AJ	ǫ`EcL,iWPēLg=8J
fhJ=fuiItArEǀyнv$L_Z:*3/U|U,]vOSc,FSxk<h}yTf%a;~pͭ2vT$TK'?T]GWZn8koSPuνFIͽ9Wn
OEV[	!,'rZAqkЋy1f-P9Q?-j׌8dted92@U@pKVOvisƍ-IH&a5u8ݎI>h=i؆w1(MaGuf?b;\;AE~n:`\k.Yo/kʫuWl7`8DFb๜(\g$%j[`j5ad0P.ki%'j	!3̉s3ۈC9:;R!7ș/snjks2WxUafj%
]תx}	:βBs\LEi_tu,u^K+C!6՛sxX.jDh6D{~D崻bvv:'ɀnyXC1mdRDRݞC؛SXv3Ut
܁\R}-Xd"'5E.$9NG-η+IS@	C9CHͲ.-mR
܏w(0zo^CQX3/8)8=rn543g@N20g
Ӵp?_zc^ Wj`@^%K?Vs6fuEDшW[Mz`*$x%.bOɳ1Ӎ0?A_O7s]nLtO0F)^b
дef.6)Z}u\ԇ_8	u&	lU+liY|Co˂{X);~rI(vjV72H-RD-ޗ{zc(zbz''_U*+ife	E?o8kOLPVV6'bD2$FXYkC-J!Lrm3K*.L~uq]>A"+=R^KPfILc0G/hķf[a'B'ߤj !s@g!JUL`7aLۡE=#ky4n|5t;B#w㩨KSxߥi;0Q-g31A@#;8:YX57!
nRMiWk`R.>{ՙ|cQuéT,֌2?Lrz6O5w꾪mp;h=Aӕ?|neO[z}6ëxt"Ddxi^oe,@(Nfn&*Ԙ侊 
R[HV"VfкFzun^vg#
Sh_VV,yؔ"0wTi͜>x?5ˑd.#>Y't&ϖP*e-v(VPh;nkՆ)wܵKl|
Cj7.8~w-gƬ'f^+zKUd{iW3IId/;G\'I[hW(3*.o}Zx4*t띝w>݄`#'GZd[EZX[V'(rA[Eybx۶*tȐ[;K9=xt]LUh1$d}v}})hb[PF*r+)?=cP@Hf?
-)ڧu~g=2^]#RR
ݸɁBrwQ~=|!2E)\O]1IѾL`f|N=z7vCC56`z^n-!J?|v
p͘aLYK2uT)%~k[Y=\AԨ-@ߦ{2zx߾sXEAK֔`;/ЕRU	6W2VݿaFzcWM(s!6ـU3䕌+B`#cN[giL4x8
rNPeWa2nnN޾̔(HF6(^NMЕwˈuM+:niǝf=yb@Bz"ȥ:^rJ'_|(8(BMՏ5A!al]ީXoھkU	gG2w_,+(Xqg忓yH~`it)f]q*
&Lc=kc}Iy`ΰgfgw?ol(
Y=޻&.d1V
L%
i|hX:BƣF-&[*@apMvnوx5QaYkS,52mԪJR߮T~fSzދ))`?Ps$J	$aEE7';i8,pB'6`-"lT\ZRQ\m#C:)M
|zQG;)Yv3x1lAy&¢*)Mq0E9Pi|`Z+-ݲҿ:mx\36x$Su\VEO,*Gk
\ v
1|1]j*	|r:YLhǤnN%,
@H֛ɬ%F&P(?ɾX,>X)sm7iFL=Ȏj,"{^ q519SW%94(C
Đ0K⼝g%#.iΪ|w T^=,'%\1+u-}_u}ؐL
Sf$dE`pu%nF֔OƘ*XZPq9tΙ#54{C8LFګRERt'
4ڪ7`Oo>YTޥn[JyH*;0P=
nXZSS0HLUKjݲ\h	J~Ϡ	g;Ҩ>{%@Vn۔;K N}Ij*ʑB,c!MA뿡Ռq:Ј"⦓'RftbZh/?6Z*98Lgv/JCI.5N,XOE_dVwx>VPG8Gճ2	#k6
z_>?Mh+>ڻ=N\o+}Ů9@p8Ć/`KC!xRUdw*B_GJvi8pW)[`C^^UG	9pytǴJnwz٭18Xpr 8k6P6u6$?awNtmHjzPC̻ǡ^S‘PvG59V!H}(fyxI=iA 3d~aޑ`@[*@#2KRiW. #|
>f9M)Y)ߢʚ92|2Lǝ#|ܸQPNnT.eIWjXX
9PlɂQBX:}._T1TAe!s5B|Ze,
J9px(A]LNJn	,Oc"PݟkܳGΫ
o
vH`{M͹Sɳ:rIoI
`Y:^@nM4vALUК#(ـݮC`vYFfù:/(?ԛg@ϒ_ORbP]_YΩRVphvEa"JrOB*">:H	z3Ә <ݤddaydr]',?y
f$T88:=׳7Ndz!!/tPnXwBx?˥IoKݹ2+_)\xBS$q`\l	U]'k6[
gCXrwݾ8,_ܻv(zvfKCVYta{Li_]U3
p*Vqz\aa;a~TDRr0ӣ eȎI
Yxff#(jGרig#ꞑZ<7TXˀ^%,v.ێz,wym`זܰXxBܳ΢Nu.o-@E\"j Veyͺs뽻
P0jE(VoXwY
[
U8:SRJ+s/O{`VxjmW}YD2a\UNf5uV
!	W*nz%sYQm&3Ir&<N_bE_͍;3qȝ|x{L*ͧT>g'Qj>A&@Cgݛjy'>w ߕW(MGH;v17\0>| 6ZWF"JOH),UzRSڥn*DZ0 &Io6Ռ&|"/G}1Y{YtDe6g8&WZb]US/X	]s/0^V_-(($	0ox{ΟYҫ9($~׃hz:Q _jcd
{4ba5`'/&\3hDZE
FDқpI(6^=v?#CDSJ3Z@нpUļO6K0;0LNCTD@Բ(C%8ˊ}~u,Ϧ
nfҜA
h/RZ

N‘\-ӻ9ͲEiPf$[=#Hg\Y梘8؟n~.  oM?XO"[*U!7B69ufi3oNo:Ij(fӞQ5Dhd%@j`௪#poƋ
}ux3XK
X[RK[$R $يS
oJIRROĊ
7Ei-S(&}z0UA۴M@F_3Tb7\2#ްin]<ܤEe\i[g{!'3W!`.
sD%tƵ?QݍroISyIFޒĭ7wg!wT`Lyթv%qЬHd/"R}9u$lbJ/aWpRE<Rp3a9vIˀր8oNgoU=nn!(#B(|ermyC
4iM6.]vt4 #o
)ѼVG/EujЭՔQȎxTo
RDІ{zF
PWhqEbi1pn)̩Ŭ:/0͡xGoc	|uHd&ĝlG^Y/s|eͷ&97H8X(!1 v;^mcާoVJrD(TCgUd冇#
;5z`3mjp"&ٴw/gGmqی\Ľ08-mJ镑TZේQ-e9h/OIGu3-q) .Pp=l!>C[Hٰ!kMkL!Txp$pOѬke!o˫	-a{rmկ	L;`!%H}od䟱|^vALl65nkF$3݃qDkQˎ7uoלqZR>Aw#R3^AhwwVi0
0]7(kXL`a۩M,4VC.OY?r@\5zZ=nXUB@A~'?*V*D66l߈%:@3HN ~fPXXivfux*?%J3vbq$EY<8g5
z	V{rضp`DyZu
	 6hnAGNӖnnn5yԭc3qǾ	#Y'\D>2H;a["}HeR?b:%{F+_Xeuh;oUFhoDg
+ۚuuFόy>9^Vf*":WW=,%s -zD+@䔟(&)ZOa&}My<韢
tOD:${g"%?4Dm)Gi?5w-@pA
|Jzt	z-ًǍm(Ь&P !Y,F}ؙM6׏v)lnBLL#4
8̟&su1
/KAoȄd1'ja*վj
nKHL ^Bۜsgc},YWZ%Rj8xU\vO
գgfEl$
K-
4&~
5Ӄ Ά3INnBз>P=^D
^1(,27Z&hD#2Ʈ.l^.nZYn@.e5Ed&?ٟs+kypKZ؝)E߫if0r .D
¢\_vnGٸ~KgGYT3r4ęb.nted;Ԑm9y
6GqIDڷZtdkrr$2Dcɏspץ@[
y_p쑷 YNY$i/(2Ev]ڂIK&שfڌăfv SdnGYq?5~-d;{{b!ʛ"0!WBţ^x21<5
ufQuM[/д6ÝѸ)vFVdST_ibpE[	Hhw7GȾ`#®L! pp}ӯ 5JLrb|v4Tw^t.j`y=pӐkn1YwcsCsj
ꙨDKZ-r[Td#׍G'-;6iN#EbvDpDJcB/ўʅ;X3-uQܓzV"M,x=Ɏ6 YTԉԲ>pQT澀H7FP6m#ᨌ/W+VO;⌬]v|
G
ڎ{8`,ZSOoƘWeLҢ^sYZ.O"DvMJ&g5*
H8P̃sOm#yyA}HJ, gUfɛl!|F%TP/_hKRooOQ'௧P&+ۑNS*~:$Ǭ?AxYЮ	QVA:!Uo}7_\̢	K
 ŧ<
&Jݹ1Azr!kE3mĹfm1t'܋v-6Y`Bȉ
ߦ&aMe%hH~HHc
EKFWT+lil}Z[;>I1^{hr\.t6thKVhI#)=$HӺ᢯8p.+`43 NE!b%0zy%~Qontc!	>est†5e%׈2/3OS~K"04wY~QAƁXMOMGF
"
,LAq!# # 0y[#NX0hf|.a49Ł~<ϥ*w9Q9h+)WN]wz0uKJsDw7yo999Il^;QN("pxVqlMl\؋yJJLyMma-Ty~#]t#ۯب*#
8J
;[	U}vV6yT=FN Oa!l:bBٮ[!nFv!IkF.1^4#WT_Gm8FTtwc]hG3GmQgw÷w]* fYPTI]*NY8z&1"|4$N1^|EwiE*wDam,BTWk][ޮeTAY̢3>Aca&~]/n :GxLgNؕ$Xޘlsm9֧Yy^u~A@Ы|F~M7l>Δ8:
Hc	M]6缆520׆K`Oo
Ϟj̻oOdUruuB!x%g;}+\Zgҭ`sr^s*9l~KOMb	c	r*\b\<^ř>qz.#Қ0vٕ`a"`gv=.4;L8|>2yAO})Ia~NB8S@"}:gRH&AP[iغ8
nءi
~B[xۻL~F|}kک+(RIu_hNjv1wَi,1hƿTXTz	`d@J?E@MsՏgޡgӻDpy9~8{AG45Ug('>6h[\iQv2lOb2%kD=݊/XGP[_j﹗sC}n>r5ۿt^S&!ڛܾ8z~OOc7	R*gKxҳz%-rF5oɆHJc\& )Sl [!;V\L̈ϲv/Ҡ5S4QzF;Te?e΢kp**JpƟ]0$B:+(I*TTe".s2|C^&|$r7#mhEHG3ău.b~,"o=$˯#J!Rl2愄7wbA0.hpYGQ[t޹ӱR":u6D3]$HX	^Ttyɓ]y}DEPzS;F13+#˹.~ozǎDZ8.s_ݢ~wuyڝ
é'0"M;}+z#tu3E/(Az)gty蘓zfl/G(U]{'^1pgN Oj-:1?A}ّ+皩S6yi0-CMF>	1|X6_-2ٷC~R4g$ +pBY[5F/O/Kޅ%Iu/?vﰜe"<EŗL[
wj>M~T򱓊3Qh֤b[bڟp&|ӈf5r䚈xO>!;RvU!pmЫOקVݴNllvw<סw#lžlNLX71:$h*"ON"r~R# a$FIF*ADTuj8gO.nBOhܖJrdDR./[}1,
Z\rUkd!+1+.0\O(j
7z%fLфS#ANafP[G8B/ەKle+Wo[ۢPޥUH +LߦQ?Koc|&HȌ<6'Yv<|8~.Xg>d\XCWOLabs]#$>gg9	L$2oy3wj>Erki65wyhұ9
2vVҥr\lmԈewVQO`NCkMF0qm%!,Yw=2>\e_t8Zy׽iFj
7L<#M/)@lc,C(b`O)ddf+Pj%jIswRG%:Me2-y
ď&{ MNE
0q@yHFAeQʣ>'GV29;rfi,X,:
vm):WXi+u<88SU0<X:|Ȉo'^,d>UA"W+ߋ/G>^βmq&⃷*Ue [FORMUFDJVUINFO
]XINCLmemo-sv0019.djbzSjbzJ{&E8=yo;gWӸ\˰6
B^aҫbe?{^Be;`ޕX7Lֆa;dY)!3 	* Y^u+Q#@7C4ܠbװzD̲0@!щq2ЊCUyx->,nQzFNVTL[*a
ԜMB
S:\.l3$nm~@"+rd^#\AiLܖE|kGp鲌p^!':BPI=L;ef?r=DNBhYݮKA-(
jޭ$QU	idt7hpBHHsqe
8giȐO@f]/@\L?N^C\Ģ\1Pg<H205_-v룰,n
&}jJ=m)m9oS~n}Oin$~r?&f"z}hgsUČ{e]B>j=d}:wTN&$䜁EF/(}%Ԕ8hz8pdKwdOO9_51:B=+vkr.k
FU
4@ЄtYX78lAO1ۛm6^S!Nn0ͪÏJJn+aW]+lCFA
nܱ,M^AQ@*=k dI.GbZ*ǘiݽk޽>^Fv#}xqd-%֢TUo3N\B僃ǝt'
UO+EYQ*dfnucͫGu,~XL.v{ub
{
d)0(p1\29̉brZvW%1o/A[xWcISTxS`l	YGYy8u>r/b;}iW
4QȨc|`Dوu7@uV߀*
D\$5+J@pvԩ$>Al sbU5#.,{z
LiGقA!v98b.1̃%:pU9wM	'r/iM^ɯ=kϛ
hT74M4&B*(YerA6v%&Ԯ6mg6J7k=~lR뜄ק [R2pnD!SO_^y+&	05_ʒcL̇MulUݽ΂/x? w#Igxg&1즐hzr?p~B~l6άnXLKE!q'+'gD	sۚa	]F鑚+JB|\<"F۽VCA-*(>t_Z7m#0cWA4Z;mY}`|XwJ%|Y|xҘM-E0-i@C<@9׺b.&Q~t4MI#nob
{{[XY6
B]ìXU_%s^Z2_
vO?kR.#θ4mc+ϿO@C1YVp<'6z#ѥ<>9+q(_2nMO;nO",b#Ⱥ>	׃_iLXy>r}2ʒaru@[{!m>:A|`עN\bqB\tw-mq'˵l+oJucdqzJ$\f^c$& #Dn;us;?D-?C\Z$5!w-JϠ,=V׃.!uz~pbu0+-;S׊5nrWdys8ij=qjmd;3l vP*@Bz=.wB;6S3ZUWR-'[ѨsBm`HW[ @zߌ5|_ڷ&/ADf$ZOF7pz[e\
?KNm_v_J9QY-y+	
0@;D[yNå36'1]
@=7\SiO5[-Wb&rs؎gؼWuiuEtExWld%qSu/`h
f*;k\ə4
c=5NC-]݅Iw+ө7([Sӊ7
ED]2OZtj"hk]Te9̑[)ßlj@O-
,4)ቯ߼m|ʍJۊa.^;f-:3by	۩b85BΛߌ,{tXl[FvMB?a.p}Y/v\'k-$+6Sl3@TL5K],oP`[6d_&)/cRxbDtyf=.wҙ`NjRG3I}tFϷrwÔWdE<Ah9s[iF#?ɂ2uޡI!h
*>dz8ȣP֝;a&;I?nqhݭ%~+ DO܁#5Ar'X:7_
U_wxƬ7t&b
q\2fCGiy]9ɷk*S-nϦҜEs@Kֻf5*~'J^zi:p@NթDf|;'x!&h~8j1ҌH̦@]4	ʜ`Ckq
@ʙTv='I.rv:%\~;7Pv%+(&,+wq01u ձ	5b+ÎSnZdfF[Do݋;s4+g8MwSlbAؑf+[uz
VZɬ`wj`Gg=H;98zVwX~գ%[TN{w1C[F>(W4jjv!02ie8Ĕ.ch\S;O|jZ_*&81<6KW^!(}6YsԷ})ճ픰
0qȣtrC&Md`tYZzv	=bUOg;0btg7rZU,KeحAs㾠
I6#+	OMn>iOsstK>!Q;
v(?l7j!d]$WƼz%I/@Nj?
ioJ9Pky	ѿ^r?3v.<ߦS>_歵@Ż~7IUsO:>UZ;ffDIۄbZQc"nM._;o'_bi}ŷݎ
Z2ٝLw0a[Y_,N}>tk+ٮ{5mU]n-$S=_- PkNj/Z+q\CU԰X7=M);c_:Ҵ}a'5RL+*JЛY98am]S;ڿo$>@V:Ŧz:f&^|M7U,W^*؛i003اd4]rnԤ*WjK;Ը_
ӽo%5݆朲Ufi?o=y<sJk|}BJwd7jұ/9ϐaD
[0
3	}k5E%#[HъũjZ?pBD_Cm+TnGe*_͊ ٞhg1I(cAٯ$:RsaVڅE
\x|jV?o&2ꬵ/qbK0.81aC᭯Jx]o@R-UwXVZ79NUD6߿qRxN4(t%`#JIw,J*k|+V(>>/5W D4ټIШ΀EVZh\]rUak?ET";%iZhGOOWj|uAcE݌nVY!thinw@W
_|Y5/w:öP#M3)DHp"P[~wX%7*\%Π
o}n*X-i2,,1:	M\&jRp'{&5]]cYV?(CUOPHuYqA#qÊCy[̏x;Zs
x7m-RjE%*(:PD;H쨤[vܔ]>>%HIxx9p[{,HYbNk8`qRg0Jch8J466vH,s[<:2gJ:uS$Bࢬ8&W\=szLD!)+;0.[?9nez [z}Vߥ8]W>@eSo0]
$PcnIy5ﲶDsz)J-{𭪈0-
$ѹ5-&qN
KWleѐ[973eRp|XMB=}%O>WAq*h[nu?p؃=ƺ[MK͒
EͶ~NďViXùX}tـ	rk-txWl^,*bwE:.`W|e^a8
ă!	UǾ9]7xACߎ0VG>Lfj0qv֒it,l1Qs(R%q7+AlBQ4
B#Z!-RQ_(̀ՉLud
+,tk
jyR=ٿ[4
`%|\csd]O:<ޯ_C:fa\P"$
QǽAX2[TOwu!j ]Fu9x\=d`ĈhG4eL@WDTh|w]Isˢmr]ajרRBT%u?ǂ/:zd]Zy
 j	ޅZ8&0/3{K3EjPĊ9N3K. P?Z~"<2c@0)N !?Cp]zK.Uee5 w~\bzR/H<7Bc]w\ҏºx9Vo~{,qvTC8a#h-&k> xCo^oUQgasȤDi)	!6|:sH<|Јh9d
j c,rtjZ,r\j%k(咕Fg9	<[UktLxl14&d2J;07<Xjaڵ)t0M_)yqHt0.OyHho6~.%]c~c^ĖB"2!J_jRV"7͐aqy?(w>LF7"ZFȂ"DW:-1XQI-yp+;uC`A;3.앂i7xdvӊgS,ҝcM=4>b"-MkA	)}CQ,L'qq.D}8$Q3UAo9Ek#8*U fZD^QovKRBLzHr Uvo2aoQLȘj9YVfrEGo2ȏdۗWW}܄
v5sڈ'ռg|	1ćc]?+'SI/t	%]&FƮ%gd?}34lP:ӟ[R{>*״9I·VX
0FI=GA
F֓rChS/f6
d9gNZېLLˣV;Vȹ0!O8s8x;֜*é=s{(]Fp(ܮVRo
Vt@1>C+!J/66-~rt3@fZ.{s0WZɎ`y4ZV"qސͽ
}Y`,5emF1	C{OX(!rP;!IÞ^qaeS"h]tAʡ7(v]tJ[M
Q_iz=wCX"$@r8(W?'jZV[ϊ)$Y'xGSrߘʌYqI@CCW%ѽe4b\xF!`)*tMՖrJqzk((L|hVGeuA8n?2G$2m,'wY1rؔX=ß>Gx]N8o4"Xo}h}
BCJ0]pJ=0DZȐq߅#$BGfNnx{xvSHm}8pH(0,c)y~"y-ՐM5Cۣ$ Q2f˸qӧ$,ߞR\:bx=y?P+׃V`uQB/k֛:'nFym
ʓc;,	5IM&0%kLm詣X#Laa'x
p`'-.1!V?e.DplYrb_5RH3k]{JOF
,A5`PG?TF2ʇźiu!(^CQQ8sGi\yRIOU)B3wnWJp
	ÒyMN3Oآ5l4y1MaDq2n 02=\ݹA<2j.x5_^co
QN-!vN0xWpԷf7eS'np/d𕚧x^n
"c9m$j#TQ"zY{dzI.gd$fO=pB%Y5i/:iZ;9p(0;ӒqhN&,0cV->sO5zmw-Q˧Vejn⫲hu	ӁR9^ݖ[m$U*R#alf
jQC}!I<%$2 L=©uZ"=/kݱ>lwmb\9$1lW%\n̼MWD^+Qsr
9af1.Rl{bVTͥ6SA6[	;wqF\Nي}PpZiqV1D'DGT9IwKL&DGnAnƇ>qn^t~z6ni֘EKw=!+z^CIwR'A+FNT|2j͢]1p	s}ۦ0M*k8vxE*brx!šUSZJHRyܺ2

e\9N4n>RT.	U?.xй4aBEfrN^Z=@nn~!6]j6m0wϦCSq2\7AA#cGqiEsEңdntRwz?OF`=BEBS^\Mz ;4G\$!R!> 7KBpt"){I1Pc?EhDPLі}UN<4>WjhJq)`UY_Zag\4Jm{7HC]\6N8,sQnG_A	LAvW"Z/=/u2pco_V2:d+&̅Ety:אIú*
.tS*SR鼋]C㾘V7cEL2נVI?]1:us7FMK$:][7
QTZ*4 B{l/fSl|؏;|aE|YH;y$DQ#XE 4*?p1(L?wV
*n3YS1@ҘMed\f8%CRg86)m9]R*pzw; S$WwS5ڟcoN=g>:dC@?huoY`5m

/Jkm[[؂-F6H3)BRvO*u8K܈mRS4T)T˰CTD<0j+{n9EmYTsMlX4"kCLjjΙ('nb?w(<+Mq='d*N(64rp뚢XsZR'˵N-*Ĉ䶱WMC4f9ak~^tb/?R[N`\Q*9׍n@AD\5RY钣99AFJۘP+!ȕA535X_`֞g\	jMO\{Z֠I[".u2xw#E3{(Ip,c<~*	XZ$[0iJ/d]W{W~{&@ny,В!-yXtO k;+-xvP@p`ZAFrw,⎊~!=^‰%ppVf%N9% ~ݦAt	23IWȞK'5"'28[}3A¹0od(7W4m)!ܣ%QZ~_O!ab8,<S;`YaOyFf(U{~%rHƦ-Zb?=/$JX^~zN&g>d{fwHZKQ$Nm#_0j'0XjBIcF"i,EEfG:CѤ{<@g2=sg鸿(ڤPg3-O\w#+7xĥpS|fJ6VV`1O=КĊ62=¤pUѮd/CZ3IWh4LO8
$Üq(ޑB}U=rU4f6 ZŞB)1烕/RiKUo.&_%Ϊn`IN'U "0$JX;JaXpݔ]7\oáPjAlp'0U[
_aQ=M^=UH94#Er6 7g|(17$_0s.Ŝt`a$4;NL]eh7L>#˾z	-X^v.qIpk;2Eˆ3uI0O4 Z H!dqwVh`d	D}h]I֔nުn]czfv"F5-}2~|JA<6c-:515z/*}/7)`}1ho8t#`6
^,d7B]xRHj%n^oqwnޛ08T\*.WfZTګ^圞NCJuvūE)
SPItBKd$]#ݬ۴RI+ 
!L~Nrw7GSK.-Tg@V;nO{?-π䏽ƆlwOJZ5Ը<&qb6v='s.861kX9ӺWwa\y:#kf/mq(fFԟ8UbI~"Kb吲L.`7݂jkw#Baңzw~Ri4s't4ݓkn+=p_Lys`#qFJm?)o3h;wa0*nCtU~Δ

Ck)W:bF!I9/Ы9ztDhX3R*z;eL9~VWQnf6|:u.'6%g2Zn0yV ̬SXBjwh+޿iC)Xy7Ea~R}]X>+#)dHN1z/s~z5+^M?E:+ m?]4%UTNS(FGh4
B2ie2g==2'ċ='GGw>(	oFq`ȉyeHxORO[7a,o#Om(s{w/dqHT)z	/Y쵏ANz|+&t,rURfY-\թ*hϚ0"uȋUNv
uRRuj%9x~&z8VZqѶq>r^Gߦ푵F6`_^h
oU/#č	dFxGjBCaVp#d

z!7vಜ
kw6˟7
ΤbAmgڅ-`/&b'1M#=H?l=lg`ơR`徣L;^
܂1z;P+Lc%K0r7lJTҳB8~pi~ܩԎ
MtR)3T6t0ĹY8LR@g
^' o
'hO1f
quD督VqEJlhKVUv4&	0sL;Fu8I_y{kԄyS1'QiW8~oen[Xz*6yHD!\Gj}v0͵2&~'!w퐹COՋXv|f((\}9AW
I[T#"u>6d͙zI̓Bnj_ٵUdHriZcdpf
LpJN)3_"PR]~)&3݇v藝tp]Zc~=#A)yFV'Tac	Qth[޴m]kO-IZq:*W!T$ҝЗۤ~+\=A'ܷ
ynd߾{UIԲVkCo(n/)NTxaE$	$t-)mSi$'e"=z\TOtǠ+_Z ]MZ Le|TQhMg?qnGVsnj"xkcM9;n`Gd|{p~ӜWo3gI4$K{acи{,5?Ao݀dF@`.^9H$ďx7,Ik?@i}KώW@S޹+6xdP(,yٓpduxc
%.&-EB0P\^ݛW{+Kڶ$~Ad \`FSpw;hps-k]p
YrA'pq-˞Ef'̓|Dw({LZL}v{B_ȊDuV2JSSm\Δ|R0&
e1
YpQNZXP3'7hPބyKWT$/*0}+z
[T{jŴY+djXX-~Hʓo3sJf$:qru5D8"(t|uQyHz
cU'#
}exSz߶j1k3y
spW'XĔR[|Ȃgv/QPa[.uyly
UqZu\]0qT}	$PoF"
;=ާz0^xַڑLȎAb3в|B!bPW Si2
|W7l2R$)K4!r8s
#pkfa,2[mk%Q)0mUH#"4[K\-i~f fPPZ-/frtxv
_zO]jw*8rnb	|-87J⿌G_m
ӄB@ewL۱8$7k%9pUpg
ۈЅhhȆ7%P)>ӣ(ژk6W?K
'൝gv]0m>+P)Tq'y?^kCas;\_Ͷ<"|!
b'Q&Kp[#}h;"gTy=P28ڴ_0BƵ:l
*rbCWi7?@xsi*dE7/6&qjH@V/ Bgp&FZSJ}e3tE2OPN%!Bb4o@8xS^΋kX
Є]zW>Y(`nuR:py4ϟ \~?8`~V(Qu	AO`	1Y@N$TLeO 9`%>d/UKZ5 4u==oe()tbJ&g]:BCJ#D634TO2u;n䒋v&V%8?ht#՜.bouP2r{AIgn>YNxj6]0"T8NB&:L
g#KkH8R0PA8js45_xv*e9ǘΪAc>DwZҒoj))0ƅf'ᨇz4x'adx?u]~01yᵉt !R}5]mP٢$b1E1j̭ݧMqJ#Lid?/=
9fS(.YOmTqt<;Z)TCm|6lgIUsizUugQ:J.q8%NO2iL5n>4!*^wmKfcF%r^xBM62dP힍tz31Ɩ7E|*7;ŝaA 4-ov4 Ize)UCX8j"Nԝ.A3t@׆	'!^{^!TrTG?ftkA~R5nF`6N~1(zmR\
sb}Vیo#M'?g*wtJ.#4J>Z
L΂%pe_%1wrֽ~+K4B8mnCAjiz@=뇙UnKRαDxإS[T"?TXTz
䍈.J?0hVk!dAa0MYaBEQZƬ*[gl8?_C#^_@{j]@&l^5>8utWiX0(IMXgsng$g:P.w83F@}{eshx3VG.ZWB8=py'qz!88e"5e|zmdug~IF3*{lJeyаJ8o׻+k[c~irSU@g|Rb{"j^Y	st\(dJA8,d"WPp]DDyv5ԏ<5/&xDHiU~(W!f0n>`EؼHe֡(֎m&ݯ}6
,/וw>#~.v	EIo$
R7^xX+ek=Sxpb/CcEEmǻ 
7,cXY:z8yfE$_6`6l;iHtk̵3̕x~YG7|T%(Cu舊̈́}~joH\9z)z'I5qs'|kyӼV'
[`[&`s;^l-)&䆰i1?&6Euα37>PHVp\KT74:&E.7+j<3M0g͹747Kx	ȓs|`֎E]z ;ps.ZK3Z=.$:l]	&™G$n31I2DDv|]|3#r6 ^Pl-3-5'Nsض(3\;ץcG9Kg^8{@G=wGohFn6m<yH()
rjCoo4+&dE鋤W)܂~?IpW-E
*yxEOD_%bs,+U5]
6U*ݢQ-f1z瀎֓p2aguhBQ
g)hT={B5*WH.2W@]z-Ny2';Nm|^J2$-kȁ6/;
5Ҋf7k@Bt[gat6_A)d_sL82K4uU\'LX4bX!z_ԑ3;匂EMc$s _#!r"$Un)`.-BRM_yr"k4) f]xPc|AW!"TM9qj3S7qgc~)^~#塪Q9Zp|^ѳb-:*'r?x*pDRsk=wo?tGsDsQd,.eSrÚ\F6E83_iˆ"8=e'A0,n2Oi,{lv`1_uC0u'Bi2@t8*B]>**3R_ U&dOPh^[03}(&=.AK;-,?RnSuZ :j>~6>6:JVdKvd$uUrY-eu
I:U4|ݨ-xi~+Zpa[vҝ$:~}+f׻Mpٹ~rI8·W@+-		`]h81~PsC<GII!
*N5s^--PZxقOAQ_獃dC?Y'C{[)b/pqAy7$Ƈa/SӳFwb`hb; qgsSEdO59hh=$*oߤB.Ee2ED/H@}ӀARE`è2LVr9vX#FvvC~k>5	Y6KG@gyQ<=NrX>d#cLH55#1>uA,
FN`	I3Q%AZ/)zFq(UXI*L)_'6"zoαurg 䎀vjΩ:IjJ}%VnBˌP	I`7N'pބ^v~\)*Ù"?H9nω:,㹟|V&5m1ߥ2V8=hc-ƊP҉L}/{^>TArh	5VÝ5NNhAI.
*z'WvD|w 3
w\F?ڊeG_HJU2&}{}gծ(}K~`0xN,jqUy`vާZ&6Z>SVΚǮui Br(g"XK?J0e޶Ah@"H.Lř8=76M-	A
{n2~Zhb0 Hae.S_.0w}v_UL(>oJ TZ~\.+;Rq5aڀ}PЪרmUlD<˨"XL3Fq\S(>`6cު]«1	9}Q'Y03dД|CE)>v^w2ЌQ+*Чžvx$z}30=W	lU(xqgucBۈ۽x$谽YOk+p9`\\P{8t
`R	Cܿ^	_PxSE#0KO^M)A!i$?B4۫J
4\Pi:6/1rZ1@Ш
Pɿs/@ƶMv*Ⱥp*JRo'";L

rwF+~hM9[Ee0ޘ+DL 	z)
=JD֐Y4<Ja@x?tpgc4GYcCX@C
r>6g)
%%Hg4ܴm|'yyShSyvQi	؏ίNl"1!>mW# 80	}hT%:eUYy,,lb
s.9m'
u?}imC`E&E'q6P}vׯe?Nǜ
`YC=PUK^YZ;#2s8S#nj~P  TH]–F>ܖ)MΰԻcY}^$	>@-B)0l ~D\2.m|Gh<7N^2l\sgYnN?Ąj2gݕ$gF#|l੅1o,pc#qh ׊Tgx<:`6X~:ahJok*e]9%[]1557HPŒ,NM>6Ufȩ/2 wȝ]a5\}e[qik
jn/4%πy]'j1fNF1Vܤd%e~01wDZȃ
oNhځz!m'sD|ɸ6y(H][I.e]Y16ūPjM{E0	7f܆t$ft.g+z 7tz6btY6
%sO:WDzg\MVSid{T[:a4Qxt-6,l:ܖB
:F,-QZDQFR
 ^(@Mc"F11]vĦ؈"-BbUUŮ iizTGQ$nlZ7b(Ҁ\ƣ2DN꯻fGnpL,3r(,0Da)a{{m +(BB~or%0Dq8fjEsၩ0LLIWݚIO=f?Yv?
?Sw{9(&exqadHsYw-`Y0Q0³idޝ$7Sp yNĚ<{oA67eO."nsiB͎dMd}&n7*c
iBL[XUBfXۻ%8x~&Ig̚YtU"Hd_!䀝^cT=S龦뭫joai,GiPQmwGn
wіPצl&=iYCPE;ִ.	'jmnEF^В)`)*	P@JQu~g@N|O5~8Ckr
VCu+`vz-+q.KPi	>ѥy]F=F4==4hPVAgE9'@=3XjBFGeғT
(kW
ʂ	
(aD+4ѤLZEBTSk[ap.	*oQEM֪)jsS!xc˘_h\R[;(&8.
nr3U]^Jx)jd@~0l0i_B|>'t|,PQK&|,,ciYkcĆ4$\S2}}&29,	9n+%|fgAe󀴢[0	)@%xO+ iPRJ&F#!s_|=tb(*^EySZ(r9jw\'3K^0`
âDH'D5;KdSgȤSQӊ"%_xL0(|hr0fSf(npihm^F+]K/STeK9QC#5Ґr~&rvoRƝ<'-
zۼB/&当BѣdVfy-ҎR&RĬz$?,H)`RyP5vQ4oaBO6l/(3	UL4*=&z	(.U=W'PbEHF~zLM4J*ۥҨC>G=ܳ2Dsy)0Ýզ;`vˮ6S^go$	7NR9{qEsﶏ!.6{fGK?]ESz"i`I0+ܯa&Ku1Z`kJERj@TNًE2jdJcuH-qVFWya:4jOBTݗ}4A;%͵m"HR/g^˙δsze
uq
5 4?R΃ |
7f!n
'[_^YP0[>5sfAbwPZ)ʑs~}
qvmjQXN1Abxb޵\͛t61\JoUXUuBe۬Aϵ=SteЍ^0A'6`.1|pMj
=qd(M? Miprmtt'7z䐰d;ڔzHQ%MK*+=z1F0`&UԮݑ0abGl%a(4`g;x"nlCZPGQ-RCЍ]1j́#=Vu33]yO'Q;_CINk>bR(¸eBϱx'>x={UK5~IğVWqv*6Ybz`׆DQT(@G?
hI5.o9WJ%6caK@:a'r∮hH%Ī5SB3"5kJƆ/O	FE<QØH7R6 v?=!J^"*y@at#vl[ZAQQW"=xOFBru9&ZЃzoGqT.9/޺soD$&GjYKpDS+(c黄|b]aa3:HOX1hVIY&C#;'i>D*7ٕ
.<[Y~/9g&:^Qن4&Z7\@37<̢*ؕwxzcyDԥܿ|Um@G侣	1(WD;wj#cjۋ3*	$\W̥L?U_s@i[XnAs+ýNK)xJ!W255%Ej2(|!;(g3!_4;_ipk9ys*ڗF1/s|":ak2̽&#jT^m1&BU1ft,|_+O+L95>5[O6vvXUfTJπDp_,pj8
`*/ݔڵp	P?ӻ6{=n
^iZ;PQ-FJ-j;jq27CwOȶϛ02Y
!Bc91Ow@Q0]rGBwlj3LۆYxm=X+JEVKOݿA5L
O42 ^BFer]L}؞AUY0읹"i7[咖96n[¬G
*{N\JyС/u`yyw]55]2!П0Z66v^WMqkCh	-}zfr7*P
A|יhM7d蔚ؐX=Q7d8cvbJ:]*
+4#Q1Ϝq۰G$߅qeSxj|l&</	_do
uQ-g2STPĴixEc6'dTE*
VbC:S/q&cB*_'+mhWG0hhH1z0~Pd	hT֭+@SITՀt!  KUrG^Y!\b{'~NϳH7>0_?j/msKp`9YTH^N,Gy!I@dŇ^p
VY\~[q
?0i-.of,08>Ћ0A1npojђW1ZoOE6K9skk_qW9Lc@RŔ yh2qUuQ+ųGd&Wd-F|rx|LsM	70}s[Pm8|^~()Bd\:"QFM3?KwKuWcAӯYm%V>kBM
>A+o[9
mve֣;`ͻL=aؖsݾd"FJz\I`֔ΩE{]HPJlT`ݕ;dw3d̆]0#@0:hʂ+`n$I[ƲŴ)nh`:Ox/	ոF2j\LoRbi"6>MhhQzIf+ ѥB,OOO<0o
]?m(ӟ,c)ҳ~i"f
'UPL#thj:ů92;vfXq
ޣUp$,[2J/V;rxg˺	\iuqTa$&s.M/c֪dTqTņ֭B_ҟ csC%M.xҗ$BXAz-S(M&QQ
^VzUZCH'
{.#n'g΀8<,5yJM4Wd5"MZ<['/l]:Yev,
%J:3˫(p݀i/s1wvngr`fkPwWc{;kmSHLt-ab%2M\}ʧ>ʩ҄u>	+"aJjY/*sn\MJe!R1lNE@0rDCLӬڿ[F;a3zQ'f	\	sFcFV	 y&ҞS&j\koGFڍgt.0V[GI])&j?)U\:kO/}"c#-07?hj^[[}@b:DjcGzH]7gPh؛7Iݿ
&M_6d[$Ck\8F(a!u!:NMoHoe,
y\FLzFx/M~trȹ;T%A4aKa}P$!oJ%o
LMs,,6"!Veή=l|i!(Uwk{4mPMpr
,{	G[H/z%cۂ"^JȐ},E#?$t2Y+њk]ME㍄:_^CӘr0%`G=,1At4}'s0alVόQɡF9XK^Dyn-yǥEDK1-ts{5ɵe^@	0]ptmw8it;$w"Le*Fvqs0[ <QETO%Ups*IJ{.oR'R~)?p9}BA/
Mψ}YJ`5t5\y
"/9lP&
xƈOdVWfQ|
4.-	r?%0!,j ?d;9v-ÇDŽL5e;P(pl,hGdhC-op
ٮ1K-tr
fWpqr~&T35qTgBjsu5|xWc`%_c7P*ܞ;yH@;Io<לGS^(p
]Ĉ~ޫ
#HLbMܛ@HXAlssNQ@a$vu8jz;lCH9H2O/8m^jxPoed+
|	(5:	~.<ZmDDk5:٩g_S=`PI]qslG^͇V0Nrfӱԣ>,?Lq(xQh2"Vi&CvPc&w|S2s:c!*	ٗv@\F[G`lM/9;(QE_ɊZ?5=!Qgapa.Ę^;UGsN9c$,MdfR1Y)%HqHv8`;pFAGXza595/L~/iH<5xsK'}eX>,O8V߼0?ĀK\M@n(UE&i&>kě Ȍ4)mτ"^hZ>l;[PsC"춷	m&%Pd,j͌6bstм]mpGݧzݏSL%"ِP=-U
+C?:or1{c)T\aŹ͇Ygɀt,jMnSz,BD$<-][v@V6_
{9KCTeï7opz3U.Xnh:i݂R{h}XwUe缻Hw{DmA~mbEZ|{?۬FƗ|qwqҐ0@s7fo#DIR3(*l$XDU9y|Ѓ35;VHG Llh61tɒ`Uv*V99l& ީ	k\eEiiZ<\eY^Wѳ"$`2h,@P/B0(⳿+?*|@nQU%B遾j&~+V)c	HSDh@.Om^M
?j5\n<|P+KcsOq
~~zY{躴7_Ϣ?(;X]_R#«Nm^ɸ+?Qjs0ΐUO
lW»"~7w=5hZE5iN,ע'U_iDB,_͎`]fC\y[% "ciev
+KPR:F3
lmMe*^l@Q9
Ʒyc[
HD5[:獺:T-!l5n<ٗ)w	MQw:27Y!"ԼP@
"sx|"H5bLfuJ)[ß>wXVOTyGބ\)NaY"!,	}Rua뼺htBu	l0rFZ^X}:H3<lޜ*iRۖכ2
(:(G$SU3]a!:5ҌJֱ[8^.R*wWgN	99)
3>Z(c܍
f_)>y(<݉Cvظd*PȠf.T8),ϡuSc4\[f&PxyA_!x}N`=b\Az,8^9>'HE;&w'R[ { 瞺סbvP8JdÂaϜlOa.J[/GBs(2'

dAnW~|Gp~4E+66c3|I0D}%5ߴ^9b"ߗ#	ynƁ+NFř'J@>5H`b7$1JM/0Xr`µ~ ظ@R~%&>槝jz݊
pŁW~?5 r`E{	Nn)wr|#w}7#?`p#IkqWQs6&.}}[J|>*3V]1DcX]:
-+
Җ3.$5.坄ߓΠQߕ	/=e_c3t,|"8ʈ}_Jj<10Hޱׁ(U$ee
>0_Q\N
[NIuQ[L]sS$r
B؀`E{D~\w
*T0t)A*hm)(%SWV3>8sIrϏCj4c\]UBּ$ToJ-E*4d"!ԡE&Rr' Yohkқ2MR,i3pD))u0Mxl?GAEq1aMQ'qj؁<)_'ܚM)SxF,K3\1Gw6oR
ZrQlҏ(PW.SpD#&cVObqۣ;74긗o,,=Ӣ@F~巍ɍݛj܁*rF؄=6,G,mϑZ$QueȨrVh(?	$0`_BWТ=@D,j/*S򧟘Y(W8t&1 ^)^/vQE$[Ko<q!(eHWhcc}r֫~\[ݨhaG	ꛢ}PR8~t6
R"R+K&wּ=>{53v	L
Ka#S
SOu@1+Q2m8?em)pYI*O^ZY?@Qi:EYMk0c.r\WЖAX54pr<
G~ۣ{w@e>:_Ӥp[Wj¦d!y`e&."|~,n):Q]Y},*cߋ4UpYLiH0![۾DPS)0Zv,c@M@?賈T߉12a'~'18"1EPbQѧz~]_[bR_T@
d):oFhT(xAΤFEvǪsM'">0p3ӱՉ?QߤAN3ej"i$渞e
ZsTЙ-,@rs_Dݫ>YnIߒF2"b3a&|Jp?Ӕszfͨsy܀mN1bU@w({|%&1ޝKcҝFg͚Mp`qk1`rhQ[\ڳ3~2ϢUL 7p,klE;ogV0専ғY#II04aԂ>:wK! 3O2?=(U0R
`7bDlP҂A2bu#Txgcw0*=>N|''xDZ3C.@ZE$xʉG;{PslPN'_Pp_КR 2X}
&=ݴM;iT[o$_(;\qV{j6@zidn4xF~O!cʿ4WC&V =ѳllT`ZM$.||X|@ZO+vr(>'ÞcR~Rn.76leEUy}IK4g7np3ft{W"@u1&7zi	8OyY/!<ű/'2n
Ø]nth96?0ݑbڭ{)pN'\g: ”5Te3a8pwhR忒&tw͡faL4ky)&̷)D\Np]M.#>z75}xAD:Pz[UXRƐ}7o_NH)zK̛9~o܀kIN躚fCBŖ8+hw҄ku8/aEQB^
N E0\/qR෭0\'M
:P
iBD{E_NwS
D?V)1>Pres92y
w:wA5(4KnNMJ<}#!ԬE*'p3MիXB:4mq9
^T#qpL2Uv^x'NΓme ϲϛ>x
3SXL*/3l9ʛy!
Wa<40='n>Z*-XU$qhB7ڛT+߳挄SW^B`Icz+7ѣ28UO
a^e?AK
_cx5҆6'e_:K.<?|l.7ӛ(΍cht4eN\d6Lg^qdŹ?uq
ýB`Fd	Pzpw3%A
hxqmo<'{'A'gp=D	܌3T1CԡشaT{
ae~/98RūWA"В1Pri[DG<,Yq3wn2~nxX~78
m
vE\y95ԡX?Iy-6jWvPjy0;b$.X-G*Eb7;LAOl"Z8Z&+nc7XXqAfkrʃ=Ŝ̃|1FKrJu].Uۙ]4 @	\JK<\*"r^:.\%6B?>45/URb_.=-]+A8YvMd^`:]MLH90"GE,UtHgFɕlPA	6yZ&v+LbN=.bu@r|N\t-D%6!R]Svu(*oD*UT5}OE
;^]4j~銲Do="&B
59e5*4t6FØ=tT@3W*WmWAB;zAƵc;1"JZqrwDX
_̸=\/@KZ4X0hQ⫙K`9A[z۞]nTSjH[.PzOI1]GЌCT@.ۖ~]4CG@	!xJ%Y]Eb.I1cԅq0X:cpwz߶hO xxbÏm\7pVz}zT2©&'3bQ7kߛ,
_!YRy3dЅއj+Rђ;
h?o(TPolR\XHlw.FY?֚"(\B=澩¤QOX/Zϳ{
e=flB	,j*iXk8pf̥\N6
jxgzTO3}Tj`+75έ	\.NmBnsW@z?s܅4ޞWI"
\l_-ZŬr)Qya!1D.u:cV(ޒ̺^
3W$H
d"1fEI@oj,'ay,g̹!NLN?qrxa-r%V$#%L3`0dK}(&I@HEa2 ;Ģ"zA_ > c4gBv^j}uuBA=J]{0;+R
1]]zn1QJ(465?r(WXQe-~q6;/(L]Q/1,r6!ҙ =%MsV淒N&׶[$=u
+N,w/DJOsY*Mvآcev='L5D^1^F[nJW0%!1높76݆Rp<\t"UhP:֋e,4$Tʣ|	Tόd¸2|DXc2x1:]F0kPU0a$r;3ќP-zĄbi{{8!pvj?UX>&6%LXyK9~x:ٺ&C=4xï-81.?w))Iβ2Q.s/S2pwczgjֆ
jֿy|r2&plŧkj#'ԳB?y)%7dr<Def
)gB4gIKr+.
]8$h9_si&`;hT6(25MR&^P|q.VQwܧ`u7y|oo[dG|e`cbr,8xׅ-9i*b24I]?oi`EGu-#՝ׅRv5&=D"U8'ki24C\ZU܈WĘŬ#+j$-nTv1}ɒݚ2;׆!C{V?qbdN]?

MegA;N=OL'!ݖL|Ǯ܎7.ang/ЇN(7rQ-IvlD¿gX*[a[w{Ƣt]L[&Փ8}T|,^`O6[L7Ǝk	ApѲ	iGA;Z.V~7$I?+~?rB2W{tZ؊nPjݲ
RDۜa3DZCk]h3qW(8{	|u$S#}Ф@e$	ug A?vK[6atzM'09TibukuPeLeڸ57^
%PYQP*zs#kPtMX.MaO#ԬaU†֯3ڈ~߆tcO
iJy40e%E+	XN9h.#vMS9IW0Nre@ggu$5
K CwG v ,8Ύ!q?I7v)5NBY9K?n!3!i{uى+rF
Ɵ-iKdMBϺݕdg^=T'jB@1FT;Ja%?[V瞕#h&ªh#5>`h>S,8g7yDootxdžgU/0#ewBq
VUhڍRt|faVO53:IA\ƿs+*sseW9눢'|k4iK_e9YLE

2MЛO󉼋##wBպZdUgXwdu\(
xؗFe!GNZZR說gm+Lпy{*"R:F~FE0
BwR1M"
2ĕdXXNgR>d-Òг`2!
t}nj|-R燈)	AUEDGQgjk`W
cwϠFB~h,۱KK[NÈhi9r*mgRWF_?fu@}mw/qQK`|#ؔ|XyɃI^x"ޯ5}o
#frjp	DI;3qgB egn^xչ,D;7wjv/ہ](L]eCre/ɖfaؠߜ̉n;%r9沿ӳW2
*1.].Y=6]M-tѲq/VA&EłzWNS-g<\9	*4=	TiBJOI'E/^̢43{u1B	dʣ(q3H*?xy6_su0Axt/s3\n*eV_D\(He21
dI652S~!dph77Fs~3MV>
Y6e,^x1xP:@Yg&/{r5~2gY7BN*/\x0^MkĒ{BC;U2:}x,VSΦҒ	MsA0=
색z,vw_z֝UC`Li@SĄ&dK0l&eL6;%`*eWqAFdxr:eէB︜${%t3wv7wUlmn$T*zi,#kE0t?y9iXGLuBbUr&<̯KFS k83xt^zX0sϊY6'SZYrYWTFd`fDҾ'c^%]%dAKS>4t7Krcrf.ec41Z۷f
@
o_EjLĭC b	JŞ Of6,ZwO~#KGGO(+ȿнRCY_^ë=d:;Uo':E׏~%"V~‡˵ʒgO5iܩ54H?zMsW	W
?k>CkO7Rټ'{
QW~M'i
k2~F\v+mLQvMXFU/ӰƧw|[פֿx{­6Pk
 VuD.\!v\VdTAx_MNuf%lP8k[
55rQC˼I詏
֮2(d抗93G~]?|7D
ڣh\ׅS%to2
*(-41^H:|]d:F6-;jtK3@?! l͛y.U8}\|IjR+w+(JyʔgY~_sVlr8WU㊩X0xTM0i Х?hV̊kPz=򣲬iŵͤTntg;Bw)
`d=yӶ,iIAae*l4ne^vNcQW-vo Ķ68	Y3#ACW?8IM\019Dˢ<+sf>!z
X:MD'C
qY+T+?7AMR:.C־W
e|=K|D*Lj	Tqj4sѿ#(`-SCf"Pq	q2ڌCW	lld_.B0MB%'%>b7v1S
Y7'i'6JSy!$Fb[(#Fڿ1%M2m~qF!q~>zLg	Y-&1/Qbs%QMVkӾJ[a u|vQZkhN1{)Yj_]A$dJ6ѰuY%srKxE+g&0~#^XZ8`;"%f޼U}LP_kLD*l@>HC> e6iC!Ű	lkLL\efz0eZE^>d}[|ֆk$FOY47̽`>{:a?%5(9N^,L2IFZl=d-ٝ$5-9=fODl,^^>Vݓ
*1.XǢ71DzDs	E0p?q(Rsxcq):X,,˩S_ ~/}IpeESȎgh"R.'b$/Mt[?)dV#cΈ*%fsN OPlh큎~8N>CHJXnHER`:&U&?.Ds[@>ܡW92%v$9Wqiv6O,݆SnY2Nukc3#s'ÁbT'k[vRg;9&0%cڎ)HAH3I|.5$o
خ4|:-6OTщ+rH`"ǭ^b44w%6>Ѝ.֚>G\a؛, ,CC#^]$cͮݜ kW,?w&]KOSms$Iw[6Y%Ȥj^E%j"Ѡ
=nxR3CWw
`q*LsOVk*mw,N30Or
wwgHf+xm/},{Gpr=_5IYY{<т+Rp܋˺'#JvJh4D~Jq^K֙j>K5)H睋Ԍac
qI\Wav
: }9
7=OʭCUmP(}RN4E7d#!HؔEצca+/ہf!.	xR>8oVco6ѝǝX<7Pjhے.Lt11+r_('@Uxs#Mn.I#ɓJR9?3EZ*p6pݵ@3]Z1BTbux@5uJϬH9]'@R(-˟۝W7*yrG1M	s!rS.0#vMyn]lhnD/V{9~X #h=߿@o\>TڜR+Ws\UlHfT}DRHXI)Zro:U4֐wOz{(E5VlxZ;%WMjS$t	
Nt}gWcx
eFtXԿ7<{{DXK+o{YȈAQ:2,!^A8	=+r|6]G~,بvnrB^S%8riF|2!S&̱܉3T_}{S╕v"!X]{QÅ܌Ȩ62"|Z)V
xڒ:L+6˔[[HK	}
ù-K
jނG{mVFPJᰤy]ֱ-^p/p)t4;!µ5W-_`N"wT@@PoS{r$tu6Hm1&_?O;D9	ȸI}&w#e۪b?,|j@^8VQW$LLFy!8dMNJ&N0ׯjS=1䌆&5ty3WNU3
v?(KESNy5AYHǷp&+_
΀JӔ=gG̜_bPJڬGAzJ`W+tN.Xb p0/T8py;g~t]z?fPxUhXpU$P6Mhpbv?ƢW}xo@pdO^?G2:p"",galDˮѫ}5Ÿ6Ͳ剻gr
OV/+c	ȃf	Wvv)oPDU+.ϯ?a<z]k={u3{R/פfCowaxxHnGGs܍FRTI!&*\5ΟD
L˧g䑁'څG hs^)Q͟~6si
=lD?UZonh[iOFR}#!RhobN2DFr%Yjv`6hN@	bԤQJ/G@ e`H_4I%zF+Yg)vZ60
5(
Z+S?=n7,T)Egv=(~$VhbOC&2v:q&!|c($dL\M@Q#5DVpI5Ѯne*̦l
v:trZ!xnglWD'|X>!$Wa]Ʀiq$I;\L-um{uI,Ik+dΪ*!;i1Vl`Éa~W˵zݲ38DQVdq^'ZWV4#FORM{WDJVUINFO
]XINCLmemo-sv0019.djbzSjbzm]{&E5*oXᨴdR;gS1[`iqrҀF0K7BA%&޲@
j_a1
tGrAV4.[#F硣!@Dj>ނv,BZGk
"Xݓ:
uiWp {n?ɈۨG@F-K6#Q0zTu.Xc`=3B@L@3?9A-7&'``8	Q}V-d5tukkrʜ\FdI$8d+"["opsu^yO@gEV@EtQyQUvuz sC$_q0K?7[[QZij1)4yP8g#!$IlIzOFQ`uX]B5S#I%鱭W<ޱu2Sf#L$̛Zo7EKv$4|f:s8tpXusō+SF0)yYD]'yU*9}Z
4&gy` GȲXWKkƯ4XJwhh
MJ`v9CU* 
0߿)8zj"= K⛰%&!#{Yeo{ň(q%W]竎Ƨ{V?IIT	T?gаZDB;ԱA+e=8*_0|~*)"؊<w_yTЌnq	̈5DP$SWڔY8T.I2E~AQ
j wIc\7ueWJdl}1aYYon"+~F)~ɿ_}E
ZY
9a3&W1>
a-ųJr|իq^Mԧ鎈.LF禸cIZUms*p1Kf6ʡݐ8_(L4GfYwb4r;'!iڬJXKR2%bO%z$R?#C$6NGc!|/W>츒Ň8+_5Vp92u
s٧":N˒e: U]Rt"@muiuƹ,rXhkuT^P!%@O@8	~ЅolL.t/!wԓ鲺E]WC;r0asosWn~˚p|I&a'풫lJoEc(o}.ܦ]arrmpAy$oTO5(A,t1_%RC$YO*nQ4$CٝHpgrayAozld<{S
ۏS;qU ֫ӆS^

Z=>x
rNKcZ\'Pu?lL`/}Sަ/]eFFqO?YNN{+L attn[R.q#kowjh÷1?:ɑ!F/}H PYU?䇕˾,pLNHY<1Duj59Wzi_q3^njI^۝L	H}uMqk+x"Ak'txXkM
vtޟP4ʺcS?v+,mHoMylyX\0SFSHu}Hܠ|;=5Ν<S!NGQC#z*Nw-L$җ{A=S=XusdĖzHvo/VYm˩SվH	YZدN(TGsM*yxdlZqFZ ]5^Ե9qJ)ϡ3:VRM`ΧczIk]29a-M>j|b#BCf=&~\иv'T,}9vQ$xqb	0}{ȣE{E+.CJ>8^#+Ͷeol֘W~5O%[oRѢR%"n6E_DxyYxƜf
k+T,+KnALi7s}©WQ&'55T3aZ"T@fn|Т}{3Qշ0@C=,b]RwF;:5ՂIngkm)[[Vd;d-8|%2:=|7{Ҭ&@d$k`*nGf&~?߿U{cqD%~\,iNݳfi3+hڲa`N)a+m;um>q=t	oqxqz.07zCR]a%@v+ljؾz)=KҨ_yPKnYG7d
M1Kн3L0Ϋ)-fȹhזp5MGS'-҂#;MiDn?HEH.>JwD#Oj߰:/hU".PHv̗Q˘1kѿձ	SܙEB}l72 hg;),լ]oN{C0QvXs
h[va"Gzc';t)-gꛜzVҒ9{Ka3
[> 6D$eĤEd
4R)wʃ}Ee֝A[WhE^b&~"~j6oA o&0vs5-y)+1Gx)>3x~*)Mv,h"(|fsm1l|YY%~=鈷2`|yHf0{º,͏Oݷ׎E]WkQ= BK4*M1,(aࠪ0$3
apo 1i}-%D9g]F^psU ѻ-ȃt}yHW(BoRe}3nI*"2'݉7ĕ\B;^RL.'WѧqY7F'w/הsveCjCn(yR:r}F
ƠY	aҥuM1[He
"9Q(db6\WZ&4/a[v;b
Z\-2O/)'yT$[Bz	AG:PoQIѨBVsR@N3"wMW*Gr֭x!2Z	X|WD)wIa:t.|AODz7Ԡ8 V'(67nƔ2(:Aă
קn>㴯y:-XxSX{M&Ã&~|;4d7&
Ř`
-mΝgNoI6ʯ닅<	njxPunIX%r*9SACDR3hҔ3uժKAC&nHF&`On~i bb&ƻH2hI_B nlx_k8T&=~v4^Wܟ\bNcqphwkK#W\}
̛V;['Ph-=_?i
o4A!cmH.us595/np\7d
}Fmt-D.K|$FҒ(%*=ZSufU]:T6?Ho֒U_A.V3YEFE=t3aciUǁ'žRF}9Z-@:i&чX=MW2m) `a6g`aT(02\NZ4JT9wfhN7JT]UWE#(ik1&kbzd|nI6_5
wd"B'b-8wdLe+J&fCD5Hs֘:9c9\3)vrqWfVJ?
oI_r̓gc XzejRVu?tDO1̏ߓi	1HԾ.ӣ{'.?Ղ
*n6; n6]uzBHK6hnӫYOP h̢+f|\#]6!]"kux;p/e~;/GX"^*m-OzhV|׾m(E8
Dt8͵c)DXb5i{
>F`fr MS-kBF( ,;/
hM:)OX'VA[wQ$3ڏY#\TYz{:T(i5{>|?
#ªLޑw=Zbqtv7'Au-kgzJ paIFčLߔi|:*I9Еt;[dG~d;PΪ1h&e		o"1Ԛ
v14L,:29~sa ^njR_"N?LƊ8}.ݬ&2?4iߜwyxyD+b,DEvc0a(Ǜnq&.d-_]Wⶦ@gcKQdw
DjZ0pVqM
q2	y75(ʓh y͜|}t#bBr#Jҫu	E~B$,~a򁑈+BG
=S,:Ő2v6mTDYhPNPUԜ@d"̖u\/H*>VQ}-FZ`r{^=qVp%"	RhRfB+V?Q
_vn/}(?d/})y4'PŴ]γz#t
 *^p֨'bF}av)fq0(@7Ѽ,2\\
O?О^D(8Ac䊌v?Ɲ䷥R,MfC܄7=Rt!i0W'L%$UhS /Xi4PI#|3Wu+>=i&#BKɷr/C/ $LAVѝ˦lxA]͉Cr
6vHhٶP	G
 8szBBT7:>w_P)WHo~kjfA43/Mc_ߥ,Ǔ S8hlXYKo67G.`K>C\-졜 oz y0I@GV88 bO	
Sڂdkaǃt61+PJ6+p?'xA.m)L'%z*ড়7*R!c1:40|h'Aj-M'2ĺIgEMp"*
Y6}Nș
[xxR;9p&!j"""k@䁿90kSGSyǏI\/-dJQv`fǕM)>bꇼP1,&une",I=+[>yF765ƃB>Rٻ`[05!SMQC/Z3ZB^pWnpPǍK"H=yL13;VĴՅhvG5y-_@Si*̻[==P5ʽ^P4S)e9q,Y.hIkkgRF!e[By.+EBKCaU4il]>oV`	̕ЧXtivX{3+,a"i(4̘  m%lyI;=Ԧw9TF׮f=E+i7h&P+~LŶ7)+S"t|ۡlڔ]=cgGYYMwZ
 c?2o	Զ]+SJJ|\0#nqi$pj;4tp@
C?b	=qw\UE6{";i,X}Bq\DޓK2ձNG$DgVsdXf'a_-vN)3)$	s[(ds"jnho`A[*0pl+-W	qxddy"C
ye/sU1Jig$'6/=	L"|7+38'Y=ͧ&zO"abkQ\z/L5Hd턘;V{V'7םH;UM0ewHdr\p	:PMօI=u`eD6I^!T*RqYtc	UnqJ/S!"swnjO*$D"E~&DI{#k.-uב:)5UD9w^~03L)ҫ"ƺڳaJYqED2Ҥ-HQ̜\	o	:/!4{|؅#nxN:qP/#}V0HWd"&ݙD}]/{LϋU.xZkUa'.8!B-<=7.RȦ_0EVgrvtHX7u$v+]!HBr"o|_q+bG6KrmvRpSd_lO*>d˝UlH)?ݮЃ[Im{;.1%-86P3-=b3>3y\dpvp:2FYVhb⁛/!eCV[!<
\se}AU(9ln.ߥA({=ԟVyL\ϋ
$JmWN7eQniFF?zvf~x
׮td6bLqxhMFG,ȣT]X&')C`]<'o%:hr~bK	^p6;(W@dE8w{qˌфy'GL2ѻS2\턭ѵPnNjz.RSIeuGiQ9N"1OIرV$clr}F
ဠ#]Hw!Ӯ2_D)jTpl
ugk7cA@&ėDACf=`ܴ3aOSBG,ڎ5Z]Qa&11
Okot66lx+
W1ml0S-I]JL8`f([f-x+axyq[
XS;VwwFp~9ZOx&BYgqabϲ6%>d,PkDl^°Ct3X]=S)zFo}~to:Fo@2]}<
,=H8jپ"$/Re솾ơc$Z!-K]NT)y:iLb5)`tb2a@rY4T.56M˛[~	VU4RGc[Lbf`۷JZ\WC`MP (][#[pEfWJhiPu7^FT~vD(M/j
9)KZP`XB:bQK8f+ި&{px\N
z[P>
%+iP;DL?Ld[yz"/ٚ%"`S_GyH)nR؁|\YAfi@EUe<&+*l7r~b%7p@).,wH;Y*M9kY]YOE0pCwR*Gno/9PO}'ˮ a<:;sC py"O%l=XlxTWh3!tl'ژyA2
n#Mx@7'	g70(Twcko9Nn?;\Y"|	5
 lkX#"Q4sU$jANR+Mz̊"*M/LSO5!_bk OjXƊu@0XS[eVy'Gd0UmRE%/{V1L+z}+Jp
5.8~,T	]P,/cSWUƪEj2}Ssf<ۏg(@wmHmM"\z5{n&,pI/fk:1}8X.|{Zï$<+91)S>
d.Z[Ox5PmjaCTLj\ѧ6c%a
y, -/\GR8"V"%|̗/\ϬŊ;0BʇߧNhq@Q9BhF&IΞ72n[?f73Qȟ 
g۲={'.ϠŊę>}|U=
ux-@dfZ5gSS=ǩf^6Ќ$dx+~~2Sx(iOfr
_ƴ[JVS
ɣSuu
GqI~6<&*o'
EYU%bzK1]JY3ayuN	6ΠsA[o+RO HvχJZ̀F[ &$/jrBw>
;~]p͞NAf(b$QX[?\_Ho%aA˺	5ƂwO7?uϼ/PsYqP;S+1,ޟğv:'xKYfoS'c0^ G~;d"} Vo4V^\DgCUŏnq0I%Z#	{Q
C13xQ>LEq(؇ujfeT{!v"h)ҁ=[܏<s&kbJcV;cdw!I%ZC7nK7Q[QcM8<iXdW&@ؐ5[Ly2rpH吹[#oz.8!T&,)y ~ao\ر^[BwZ1'r9F~$lM7zT?jERy]DzV>4'5?YDե!Ti6U9
,xc'֬
>MVwYʼn"8Pj,4e$|#žO?ܹ=NJQ~9.y_DGҴLz^ydaZl~RVҠ0꙱J0mu~\MAm9Vt٣xb;Sg79 ~Œ`}7tIo9&O1|fK#ߝ!ˬ9d>?zBɦ(FIta1AQ`1#NuRׁ#8{~a({U@	d=l|xXNyoɴSqxXEh#"}(3옽Ne|}qvI
M\Hy^ދ9H%;,np.8?Q%'с8EmZiK߈[$l蔆8nnOH`B("k6zڂ*؇(ല;oO[KVɵ
+_0I4}W(%I-a
9=_2^RːnN{<Ř	`[o`{ERsW<|z(h/b9UpK[_ssj
Bpooh$s1c4V1qƒhqg8E4$4\E;	پnwt_()mL;AF0{%tt?/j'!g{Eb&E@UFJ<!>f"
>3کE
x'p_ɛ|2BYhmqDBJ`X͖)DkdA氠Kx:Q1OI=*;=ƈbm}}cyZۍNV3h/RS8.)jhk9rg(Crɡ>MX1@UqT]ؐ Tmq=}~ZpLͅNOHLaȇ4銪2xjgy5l.8Vey0$)iD#!/A4_Vx'έm0:-)tFRIdfgcfkS|Ui^&301x:[ԖndEm'7u
o]Zꖁ~?NHᮈtUSx&{ڧ{]FnEiMB3hyA,'ܝ\`f@EVyϝxV-ZM]*`>&Kd"/a&µާ`nӖJ#Ǖ8.tmK6ApLֈ3<Ų
Dƅ8R!if,[!E-mbOŒ'R`辏p5cmn4"k`"6@?BcL(Vnfpa6"zUaԌ1О%;?2Pp!OMPTTybXT4 뛢	MX;XG^?%bwbr~!g' *L0 +{Sӿٽu.b$f^ Bz4Eǔ'ɚAx ,\+zʴIJׄN]z٢4U6*!wlosF@g&d,2ऻdDE_QslPu]~\8ױz3
elkESo1cqjΉVxW|Gfm~Ot4h"#C;8h@(11حu{b{Le碐,"ZH=A.5EM8uKґV^uvڥ |f4˛]zKa}_ڕWABSԴ\UcU%{F,:ivȑvlIX \eŨ	*=vi[SHb3Ilq.c0i˅oCǡt)i(b/rǕ_+ei澵3Z@$6rC=a?:3i!'Yi>"4
&3ޥ5,0ryRモun̿B(OgF`j[/Ak֜,Ni>V+ZR|6m7r{1Yޑg1\D2o)f98>Aڲހ;#pNUblU@0=bVܐoCfJ،&`fOj}n26ܓuzG[V?\!kb͑:վy>x	(c/NvQp\YOSs[O[IW櫔J:z@ˌ
B'ʄA
3,z/d?N͓:o (8p QVAfHp\rVJIΜI) 
Pl][f^A%=KvkGrs+LIa`mdZz5eqiF^JDD-r]2fs<]Y8C~?XzaԖiv[&ht4>+Sxym!HR?j
Gqgm ~=w?s:,[[ʱ'fxE_ry]aʕK?S60&kp@
^*Oޑ A02rqfq`srn0?M2.}ӆלŞN	IkS:6	GcdBT#/Jx_Z#f.5N$[`Yڸ2T@3hOig3xDG$io3q#l'СAmjONt(#5
xa#vX"xgv.TWxf36E>FX\q!WW}hīӁYF*WgssAd`D2O
ĀZR7+[_$໌>x+dIbO׉rPUEaSAnнdYxQ~2z5y׃|gbN_mvB	
I%f%a}&cb9ȷaiy&Zzk^,/)XKThXf #`	@
]ؠ3jv@q/AA'kfv[zJݍg*5~0Š1i\N}+t)[҃dOfɅo'jMȃbLrMZyBۢP
b,ڣw>u5!Q	^~HW8M'(2bB _ʾV}<0JZo;>>g>9w4Ns\?.ZRWvJϭap/4^u(aٲ	7v"Gفn-9ܪѵn²J۠̂;=kPyﲣH_:SU"Fp(쏥q\o\j/^,/
/ۼ@?ÀQIg0*_}MQ TP3[BJ,uFR8:B	rscc	j߲V
7>@DP-P6AţЗGۦx5^Հ|*
~gaFE-qAW]P_2z1j#К̀ ^mY6W9+.l)0+z둞@Gୡ|Up9!Ju໤W['
d_gXC5)q|ͬ}A/|C;wGȚ­9T,5e`aoD%Ek~ȉ]i4k"&IYy|9[Ǫaoy&~}_UbjvL>^kIG{!ƵAfm{Y- Cm&
QT9NېBG?&x+T.>#|fECm2Lǹ,.4kN;ϒd*}&_q{x7a)>aF᫷{XݸuK O!߯:~-r4srŵ+*:[B#Lx%%vgү䏧PF4hF×䪔oW$qW(`$xr"NA t\aS]hudz5J+TݢzX*:C:~iC@0#"{RDݚ8NY^p܊[uh|wI&G?22
Wu}Zժ["ek+G;N7g9M@d^P["ċs=E;7؋"-X3xZ
-ABAx$̲oS@LAB)[^?9M`GVK6ǓԱ_tה飞K1Fј_,Ny@*Pĭ(c"PoL1ham>J.no
[_6L@Mc/s9擓4_F5J\ Qd:)>xcgX.cVИ
<,Z7{?^y3jjmfM-&{^6iUjS}A6	s2^^,ኜ
Rxk;;:!"ϥin9\3<^ Ʈg&kqFh$:/i_s'ť)V9?bi+a%
I9)NCHChozVziίMr7IF&Ԟ4 .I>UGM]
NiJ"5p25@bXٰX.-QQ0MY*4>eOROӆ2#'L3/
T)ʮ?W	)$G1зZ"+^d1g&;\v	,5VБ]d׻B;|f@qώQnD3Û	$tH39Gwƀ\Mpन0xy+o@s;t3В j
iC/?PLザ v0'`febsRZG
oKJ#pݺZj
%XLcfevsDojrURG#pO *IrzX C͈P'4[6;-4wS!Isi+-&n
.O*173%
X+A[m4׍K#wK-9H-,ֿ%֎jN`EFl"rKFlEZxd	#FniB1^RҠb2O$^-k;pݞ|-|
Mpc%HP,[зX Ncp!LWCI*m붰ҧ+J˰m}zfsixY})m[!EXM?CI_e&	km5Cf任,$ DwQ,s,&Ε뀒Vڽ[a1d.H@bWKC(DIAl|5R%ߜWkX܃M4$%0|x迴f|t!

p[(TrA1zJkg&=!5&2n*2)s{c¥~Mٯe_:O\r^kPT{-  lyAGTSR&zTܰRR⯢_Ԫ'$wO>2׻FT= 0{"6v[P#7}^D6滧)ݾkx,R955SzկDZ#	
frDl93ó1
.Y8=[n/,f$ێm{}a~%T!6'kiً<@F*vg]C8qNvƖԾ-<`ܳӜ^i+{z	)ykYO44'Xn`…0dKS=J	2K༻0H(esk7D;hnxa;Bv#=Z|raw|iގl;Cz%s{/oP0a!Z`"W%eߛ	z)N(,(A|7I#I0ifjd߼Z:Jsr!/W#-"
qfſ6Ug@}l"Jc8^J:hV1z 	P4'%ov+VK̕ԯcF#_
e2a˕Ɣ-B#f'ԣlY.Ҷ+:ڮú'`駴MzC ~&}NA'K&ݷچɏi!Wa(FFq-	%סC~Bs14= ~o5z!f:7:! k{]M:SBSû(JNg׭DI)%Q1<`B(םkaVNR!ј1kjK*\4cVN)jў}^ѯkQԫsUF(ANFYQid=yZ\^4F` 3]#%l|`G[gBg|)?LScdH4C~̕Gˉf.-|Q+9[G.WGϢU;Y_bpT -dtb[宇[7Z~8wƞD+YX s$i)]Jb#e
Jkf*pŠ'A"ymy2tPu0~ݣwiQ0xjcۯٟ]j'CONApJ'6E{- ~'[9Iӣc?џBID!:-;'Co<`@0ip( @/\,cVT9|4$	PzGiU}J =%P5y6
,;:8$C8A&;+u3$By: Oi8뜛[8<#C;eA*95b10~m8RǦ%Đ5lAݤ}c`2f(]2]F~oG(j8i"7R\E?94V'	fAiF
*ڨ`\ǂ|.ƄαbZJ0j k
`T^9=nms
|TIM]?O&faE1t
s(9sg%?4uSqg@G*+:Ii>tS@h`
c>"QNL!7l:wG*A8`֗¦.Q,E@Ba‹J&p'
$a
.0y
,#¼S5lgyЪn8il8Y)ʆh9)t4`uk)փn]
R/\)m17;uGq)k._)F6_84/Sݐ{$,
3Le°lKfclolaXY#/oWNOyxj-Zi-<qX<]P4KlPHD^` 7m4#B<(k1OOb&PO`&GHP|B[ d\E
eb 	rK[ʺOLf
>W^tII487^CE*r':Y)"rȜe(|#ZZAP/61o/՗_(l buf"B8Rn3^.ĻZ&|G7Lۅ2]c>Y}nȷȖ>/^Ǹa8anB@q)eQށFL$*maQ%Z0_㈱HVJ>ez4#څxJSc2)c׋bI*[7[ՠV|c(\q=U5%;M,F3=foDV4=FsE
v$Ok`Xz:;P
ǚhZ\($>C~s}hHn¬{]
>=CZ{)>۳'k|\:OԠ8雝z_:ߕkтoV	:sQMstp>Htɿ^Ѣr.$ǂ]$Q.vf2ըwNGwsaߕ06G.zJC;-"9fxGdhA&)\_@+S#Y
-량-;
jsFp>Ƭ%, n9?Q&GEȲϊ+p co+3-^$*5JґYA0]H6Hp7΋Pg؊	^S/c$C~sSI2;d~rP[*+*h8C7Wפּ\\	k(GH^0(-5s0'FHS'-8_,DܱK~YF;	e{鯩֒PqRD]#8t[Z\W!\?vU$WzAq^ufy~,띩'~b
ZaG9rgJ#2xԀASuކpnISXKȀ4IghjCl8<@eo>49[_PCJW!V̅ʀKqCNkb>[FbR{
*çdKU$W^3 	 W
+:WT*&)K"*:qܒdjeYJn$Nkv2H9{6{@ޢ4P#|^fJU>^ހH_4~(cps^?OsDEicKcx5Γ@D;z$PVAwt}EIUu%K;n[4eLX+.[XTĩ*gz0ns~2%ٛ!TKh¦ J-_{+;XQő]mwVߘwW2O[v8-[4d޶x?@dIZxjDtDf }.ksNt=
?sB&9GcKxiÅ9>i	KZ*mq{PH@^[m+ay	)ló$ZA;*g-X3v=@kge#;uiܼ
-m/{:ʆ0{MXs>	n܀zդS)T~Ēb~K?6GlC^qp[$IrP6a͈Y}jM>X&9YNt`X6}}ă0m{TCKJb	M(td0Rr79C
B\FkWڎRxV1a
Qz:T3Wu=2,=Q
/E]EK!v[=׀\Da㑥|iN
7qa~@anT4oʀy"u,oA]Nyb,r}U|bý+gU?}s/fr
LsS+?o$x㶂l9G!=_1c!}T!j!""D`((f(ۭYd&hs"ٰT`-(*+}u.v-Ƶ|:I ׂi)b3:HJy #y`sNX.%ꪟhQ2,ǾU]?CG'|G+M܎<>ݼiF/_LML%K']X]r}'wpP䐊J2gBe&ajf:;nN":JֿZ"q,w1?8P4>ْת	F}UODg+.P=Iv蓽ZAWoboN	  Gg&
pn7eib8l/+KqL4Ӫ_	AQ!7[QULz}<8,mLq>͕q
IɟNqfW!f[4}:"͌5",٥ɰ'u1liʽRLHyㄏ0f,?uxIF̽K2kVt(O.RQҋpzmPь2e!σ\45FQ2M;m: &3=[ϭ˞[r7 J,RJ/$
XL\R'&BwO4CK7mjzqx`4p?:@մT0XXsy+#}VQUqU-JS(J6|X
-
U5L]hw>&sE.y5J6*h0枖aN\Q,8ͳܨ}$k쇱] kh
KA-KkP5eRWFn'Pi7BV.$YkHn/i6Y	%xb!tFX,I_A41P:[}&XPڠ9Q65V֧LS{t:u}0E
exuv|?w[YKL-Ed/BlvXK;Bt@ޣ&yH`_67Wf]Fob5[ť.*/m[+B2;_^TwCwzni%-TgSҫ6Ea(np=-P&KkBr&*`g1YT(suΝ4tfS+ȟ\xbyĄ߾:2q+@]sדHǨN94Q`k͖SO|1pNIShǙV]=綥‡ng6,k\cQXή񠎡A85膓C5hvc֜ZR|I])j;1ڷi4~l1ćaMSz
5^p*׳^_pO>]kST>6֓va|:!F֭VypƢib\?<[Y!yҶ=Z^97ki?RvGSwv/F<TB~#
j8\e.gC8k21XiGV&i#GG,`I8ij!BsP;Od	c+\''q粵.R2ctgJ+|l#'M{VGtG)	%׸"$baGeJ-^m"v"
YzP:4m!N-`Aۨë 
^a('ccQlH;?຋}L7[a[E|Mo91`!RDh[9l6[Hq%tUKDK#A``,2H^\dW	
i/%{-$l{ؠ4`J"HڙN\MOW	ҏ{`d!	n4D7y[S-TXTz
.J?eCqe"x+(L]!;T&DA*Mdx(8ݛfL?	j	9rPY}H6O0(Z	'Z:~MA3d+uq}#1T?,ߟe4"o1KF"@0 @Dxfr+ݕ
 	r;«xG;X!r4I&MK}ql?Џgʋ|urG~mWKaD!¢@wGO-SK1&~wlȡhB}g=b->Fu
k}l=.y%/!nH-:D9R
QK_Y9q)N~hSZqtTobGѥi?`c
"VDG;VeWN:4nڟiIdB#R'u+[A0j6tiK8#P~:vyC]4r 3@&kOZjnZ
Pzܔ:E+7S$|;܄6x\M0}	ZXط6)o.a<2{^~
i$9'<2&uzAcŨnT|kKnwڦcgOP[A|;g_5F7AMjIXFB!=>}Y3.`NvW-hyX7eY4nĘ)UmTŸM"kVƺa\=zҌί"oJ(׵NnJ0[cZn59f({o}}|"V0+ \EsVSP	>Xi=&2ފ_?9]N G4*a߻GO@a:"zM]hE۴M@~dIG0j"lue{9}H'f*MuLQ]Grb1}+}ʅTM2m穫^
a
~Z<
D4"EauIa7u}"̖M$]n*G 1!T$=/FGjG
`8;ڊbA7W|!QE" "3ȲF{Z+r&8:~GNRkq00	۳CNqi*|ߘ]9!0觍l`urfOQVWBMܠ/7Z]ml-`pMki׿eB%Oּ.>[+E+H)r"Q\7oK)9TU@䨬ĭG;mq<:[{HC1zlFbD5`JP[6{BzQ1solA|.‘/7_*pahg*XS@Ac`vtv]bTOh
+'H*'.$TL%;.'_]G/2{zuFO)3Hk dY,b׶	
K1r"_7_aLjFPhqbJV?/Ku&MN'-7ԣ' ,g!Q49PI(@5ė1HWgwhMk
+n/sإo
&;1/n`5`ɄeTf6c&3D:K7r10xy#axW8;IF{y
PэMxo
 /Dz{d~C_m$R~rIz*~AcjZ*Oz߹%.@ge+
}!QGnz>u16.qtxF=꼿-C'j_z**q3'1%!?O
GG
8Sf=ap\gQ=fW`$wB^9p+:ݥd/fX\Pt/,qly8GԧlK)ۛTt];=5OZmX~`!nP?]?)Wu‚5B*æDM#`P
BnK,~5r1@ 6A9~&zT5@垼_+gduf=ƛTX7+*_趰>VVsvQ1$~X"cq4	{,UL^3t |4%tקeII5Kz샢:dHls-8#^PI4iӇP|#oo6s?,[k_򀶱!7񳥹hH"oￔo6H!Jt Uy9[oh[NL-,aQ0Ftcƌ'ϔ^)޸HnKo;@S.||y!7d
R>}0Vc#2]qؾEWG*^c^~#ޠ)S^}J]/rw+[; 3[P?aɤM#,Iw(W–(H| ՐXmy	#D]iP4Z]7FTm_?/<-7`5Yoi'¢`[3LZU$};G=ڀko
:|]	L1 Rl$ŘF_df!zwS:Bh3䆞󔅨n7K`<)&v(y:[6go80PIUF)/rz9A+[u9aT!I̦
HH-Y)<$di@ا]1)Yz~!zdY''uZLgv.[}+W̐
}J&哜ObL>FPW
WA
EL8V1xqdmixtӳ,ʍ~4*JN]38:((0`[^:Hqs̈ڐgб$?i:^_D"Jel׮h$,(^F;IV{:~JƷ COta
LVTC"}}zX*Zz؋YG9}'J6@Uu6KIQ{YCvӇUD^ƾFKsw]ް@QE*.]o}	$pb5w
`I&g>~tε(Ҋ8W̚~`鑹_Ҫ>7%~4bbײn?J#`q9Ԩeաa$U_O5$Dr=v)")$-+YW%{~R<!ݬ+3@'R	
⩁lSDn1;wOWLh+vfB
yz~ɒii/32H{Di6}L
>xb+=#W!ߚX2
x
BBʃmpDLNmϠ`N;n[ތP&wwG'A8C@⪆*J$Ed"S~m-H"qePi1T;qkk7(1[ݮ8.m*N#'
*eBqG!XAu0VgօĽEL-7͆V-n
PJG
"Ss()(P0gC1ha2
u6 @%<
9?34=4tpt-{)\Ztu+#VVa{XK
4Nf~yi>~US(vEs1ɽ0,IaTeTj'4?qp%`(Q1BG~5ČhZj:1\༞ɬP@i2
!V;NO>|˷slFeb{xBxXlYp3]1q4L1x].ݘVgxfǖ-\=O]Q-jP\"."98UR}ktQ
+(-bsq+Ƈ]DfU%*ppK 9HYr5ٷ)N咑",II1$tȿQ%d Κ^mѴ͏haVѓ3<5c^P{`^!4}porVdv{"y[0js?jKInoD,5yJxl܇H"87oTRd㰀-J6)&
6/-?eaFS<:Q3>#Rr+hNދ,g>/@R K2;cm|aA;TmIfv8G&PX*sY>@[I`b/ 멨}@G6J|e$VUc9C|A$DX$xzrUGg2]U;Ir@EYڸ?L
3zG0;D%/J1f=)z30%vq]8:g?=ߐu[GMc#{hرI_#t-M)YfF6}XAVCK0~ܓ%0\"(ŝpѫ<+g7U<]6|CE1qސ!((2dۻز0Q
u10n{SkƱdfkJj"ZjՖXW[I0غI8U49|ȸp
Td5N5
:9d-m(롣40͚oz`a+RK^_QPNIթ<>Q@Yl3Qi-2&•CՍ;,σFӘ
ث+zXG)zGh(8%51:ZQ^?m2[7AݫJaCˎ^k7(/iuj#%9AӁWB@):@BKHDtaؓ\6%w7"N&Dp{b\{Ut:_PQF-@,U1C&WL^bZ0&H'	ikj ۣӉ`A 㶑z	َԇW"t
x;XxZx/4-hom-BJ6"wTW
Bǖ/HIU
^[Bym|SBVx(uC.ڊc͚OdJ,\i$uœ3RkK
3:\+?ȉˡc7{4'Oyę2ڙbgMs7֦%&%V]J${mdoe,rⶀ%/,t|5;pRyhTFeE([@MU"x	V0iXAyx[nQ8i^Z?Oe#M?Y!!M,T/}	p_\~֮vIE-),H!F'FUe<)SDLR!gY̷:PQ:A	|_qJDy-<!\3=xHT\$wcuLfwl͈/3k]ƅԳJ[+ |\{.2k$t6qΝlgߊBn$扥\~ŀA	ђꗤ[k
_8N4A?ވNêŅQ	yƙ=>4!~k:8X$P eUe*s43[hL
3WsdmUo1%{G4!!B-v	t9T߱p#aB,wl097jZl16
f
!^tk, NKV3[?],\]ZEr'r
44r
)T—;ZUƁx8'mvnT6IuщhBk04%b.n^3\9"5\n+	)/Q,&zap>
@싷Kf:~K}>!D
ѝh=uv,J,$=(:e$8(zzCL[׻`$|D̛NӇ>h3ǫSi('34f~au&aKs3b'40D̜єǭPUm}
Ӕ[{u?@^m-nLqݻp3h,ڦ`sOD9#Odej+Qw3%;~+Iϖz݈u
R#5rNI0GJH()KfV/!
J
fG̲6۱J5T3R,΅h_ W[yiҫ9l#H"߭+.TBԝ@Y1}Ue.%K0{{`]~.W$\%о/y9_򙐚b䓘-GY~jUφ VGu-MyE|̫a.^mԘR8-|C=Վg+C@jZ|0a~ZBf&w,6D+/#ݯPv׎  @Q;ב璗bWOEĞ.|SJկJɞg!8E`9XRKLW!᫆LZp0㉞8l_ιʬVe-?Oɲݮcn+Xz˂| H*46f9 ~2GkGgc\ZeRtTh
t_	(|/Tc3T2دnR+1	vG)`idνtt=d-5Ql!?p,YNSNPoM>2sˆ_&Z,|p7qP,Y)QyN:665Ö9Qh8SԎ"'sXͺ.<c{~e7R`t2fqJpS|݇(3DPW2QJ
no&y2|
!8=2ZY!k6)p4CTCWuD^){%asg6lXGgS;yk=9E`	F\x XW5«6?%8|ͬ,CgqV5}Nt֮Vaypb,ޭ-=WY)1;Jb<įDvlGߤ	cWkhZC6?ܨ֖?%
5q"O.鷻87M4p&5~!j#\\GZ<~e,&ۨ'W,AIb9pu ]a}t_?&,N1\|SY0e-Hv33[lG3Ϋ#j%˜!|V]a|OJ"|0Ey
1LMibA᮹ŅZ;%|JQDr\j=.$F-罪mqBB*Z]9T-`?שidz8lX4E?]Ɍ|F-ked}2ZQ}a5EV@w`|^Ϗ&-:>tW'|<2]0,-fyA}QzUa&PjKOZo.ĉԾX[@*TIvUwaȓs6px*9SCA|?Y_pͶ}-hJ:$QZ*|,do=Db}/qʔa37("	e/
A0ѧ+RܶU<+;۵y*q[~/dɳE{ߧRKO^&MhM{B+lT\/Bz.BM(˾T!
j{cÈB/-bjMM%BJl]Pw]ĄѲIB
>?Gb`KkDǖ;t
z	i?Vf<~X7k̒eD_
^l?O𸄤Y߭qTgnw]`B6VU⎟Ņ"
=9*x
?Hpvq-( 믇G@y&9ŷ_ؚ;[k!]=/ G,ho(@a ?OK(
HCF/>3^1>tt$&sO?n+\Q3_/Jbjy'MGC^Sv3NԷ|y1=3c@u(D3 ^OvhP7"WwDj~`A׻k?	7j<}՝c?TR5h>>*7l3e MZ1o#v]e,SLjWR]taws=^KD4J	
fE('Q勻GDZg	TX|^ECB*]ƜR:^8dԗj*gils+YwI}2D^?֝?7{r.pD+twd*oL:W~⇆?ￆZ
;5xST2km|0<xk$JY+KL]]&
aYCz⁃Kj\!c4>|jG7%};ob`&ʞA61r'{R"Dx6y:d
J%Tb.j4e_k>uM8wYAf5nFO[eݳĶ`($jO}~1>B'ãrt,!49HDC`Ì=(^RGX64{uşMgE_4ˆJJ	% ~ZJ{rҪ~:k$jTsQ><&Hhw.eXm$SPAQ#&A$nUlcr)oXl%8ESQ[k;tg˚뉒ޞ|4[CZU.=VS't{%:?$O9LukgLYVxKaSA+BPBqIʱ2=Uz?=+l?LL(&&5q,dGDŽ:&ݪpF:(6@VzٛU5uK7hI]AC ?~b90dg|YikE	w$6&}aF, _L 1N>͸X//a%umvؚsЇ&
(Pj(e	o07vP!9`]w͎r~.K-Q]q%O_rirw=ߘ!/\{A=3X/5:f?]A;;K#{T>,V-/b^K4IK79B\X4ծoh1,>AXmvȰ4J6vX";߁ChbGwB?PF҈x@-0\ce^k邋e8$˰ZBաsM}xu^\ggS(Wt7(]
C~`;ao]'۱HObAj.!:O	vu|fSgemᱧmaxxp
qCo)u	*pwuwCl0PD
8dvIzY[ZC/}t,ur+EGgU]Hym.عOtV0[b"{a9P6O\38aVXzE$NW2\vvXj}8u%=Ʈw4βTP>!p;tf~h-xz.4l+-\>d0詨K/J\IJkP1_%icGἹf[iXLLQVfZwIBeq%w[YHVjw;|2ٔGqrNdy"Bl*<6Q,|HuJq6-TϞKTeǍ#0I$if1`7]%bu=/GtN5uҨ3l*ϧ99lܩR$-^Vi8H<;oF.9Z}0	ІC/ĎԽ8z5|^gt 7x]03a͂ɆL-*2{%;IGUb޹S4B.W'$jJ}|7=kUyVNE}/,XF8ic\z!ꌒ`ly*0
`̮׫I
[}]efhɴ.#2h""aĔ(ʜy74ȱ8@d'Z%moe ,f8?3<7LVuu5s;{i5]H6DdT]R51*_DgExH޹X{UwbZ~)"%tMWS\'Go=Q'7A|7YzP!F#=ˇ˅(۸0uS8[ğ"lm"̤Y(){!Fnf9rߌ 0ǡVVw@Kvc2Nٱ!YK#TXT!VW2Xa;q<@5iH%Gܸ'OuN^hYz04,IR~Ӈ/OM֩zAG˴h1Ju`N(gkjg[㲮^*C5ǚ9tqI134
4ć
փ_B4TDgܭ1v2;0rF<2]i>__hf싕+@tiy*(޺!&hb?90QK2f2EfY>CacG>h+V0T7"yzAܩ0`OgswĿ̲Zڱ3[;T6뽱E6J=L,{^
u
dW̛];N~sY;-^k27q1.\oo
x1xqז|9$GTNbs8!Ԃ!+3pAT
~>E$.|%>QB>[f0;ڈe&ENSg{|D'$gwWJ>TYuWD5	\&
l
ϡIHs ؕ&{"y<H'A1Z<#A`&TM_ѢC˧WOJ`F"EzeIc7gE桾vR -d~Jk6,{9?&X۳o8~֞4@&۪wPkDaYi
HN{(!o4@}qANwNQZxB+P1U)Dj*AS щF<\ifC"Ο1m:_<0kQVCmM@BIS =W}@>f]).(Vy{CZsNcdhkꏞiPb.zƋ΍8`S
*u5QJCNB6=cҲv kTNydyﶝ1P?u΃ q7;g䫰2Ŀja>RRx.[`m(Oma
,݃bg!@8!^8KL%MkrT\ݸ{d{R#7GA"IجIzA໇ӃPfdlxs:@՜D
ogf+06p3݊g6 ӶVB6;1d^9mBHYQW\KpETpBnc;v:ݹt+0e3k+6e
7ɞkuiu_-fhgQO+XclguP#zq	q9Rh4I3ǥj
OW,?U,<~Vg
@ģ7J"2S֡C%w&CJ-b5ҷ\)ybnYZ'g*mmisTJ_7WgRn
*Q/Hbbvȭ~V<Ee{P%g]U-fI;8ZcCciYH!kh"$Нm04.}n$Tk0/:wJVy:Fnr:}Фv$!.C(矀I`gx~R@|qvs,Tt?_8n5b<$@9rt-=zO}ڢ!kq%xMUvmtj1rogvRA\wjbR9H%8
~oPO
4	 _7rZA׹k>Hs%o)PA'Ms@o$tbzwk<.{$FnYA"ei;Q~ҹh번f,jr!^>l;#w$_X7ճo{he?a:}m=Q[71Pп)*˲ɯl2Ktj	{:@f25rٳ'>9// TnifB8?\f5uT:A`%ADzH<&d臸JFC4T'Gi^['-4
._-bx_zV֜fNqR'NwmՇt ςGi)ln.yfH03ZWo
d\vc[E
im鷫NCs rp^ndĤ׮!R8M&ÎtVAmn>c\	\{ȠC;
r|>Yj4}>oe[!9y/HZm1ZZj7/HB\E#Z;"͠9]
I͢؎oBYQILª
-ȮvPCe΋MQO3tu-܀{L>yk$o6emUqJS*Avg/R
8Rs*֩mUJ&pv=`x!+G֭6Dh({@M R3%bۘQu520iO2^]֏cx~KZ|lH--4~o傩geZcR43m	T9`O0p▚4)yHY㓄߿sywmPh)S{,ĕV
qu}G-=dũjak,z_u`ʆĐqj
*<>SrF=9;xB{3kP;=4vK\
[U~2^A"R'Wyo'92ats0ǞZ/+Rql3.3lVn}b5W;߃gԂIş".bPb܍yI~ZFˠmw'PֶLHm>BaG;Yq.dM9b}-eC7h*j,b̉2W] ;HdePi
kZL7=T	Zw;a7%A
Prg-Hh20ӥ;9-*[#2*Xl|!1!4Ȓf1Jrv:hwtY6\OB$]92aI41Y1J"1#2T@]/h[W&w
lOFLOdK5bێW=xzKڹ䴬	q=@r:­d՞!9*96+ΐ_apJb_,﹖.˙)}\_`tX&"A=!,i\93Uf/~6c)?y'ܺ5&^Fv<	
1٣Y޺yvwb:-FjK7E)
f33{da3Eoh6ɲ\z*"RB3FBlǺ'ơoP;{=ri6R쐨{
Y(hpi%ah#BGɡUXښ`j'̗&z(Ϫ)z%&YK2#pqQ'?c딒eUƁʊj33lYjE}گ}ʠW}dXueL+6{wofl׫"-3ܑjh6JV۸~}>Q+R+գX-b+W.}!G1K
WKr}3cҎ)%	/'
Usj.K?\@`bbfk*h@׃Ql^-u^};YYmX>;R/iYQp{v5!M#[g驱 I0Lw R@»eZ	)& fj]ALĭCR$\
Xg7kj$tZw`G"Y)NR/ԑhsd*>%IDTNJcd#l
|qE
%yOㄮ=EX(dbҏ:v\6E0B>U\qs&~Oy*
$'..xkh+kifV/se.^
Vݻg}ʹ:غ5=
r5@z_7lg=ʚ=V:rTK$C",/	'ɳ[^9uSBy8,8
	A#b;<)JJ^1̡zxv2fk_dB-jl 4sЯy2[hUnΧx$L<N}M2ipl[,s56Y]1&:I9gr1WqJn;6WtS?&D1DNV2>V;1~(w6?w>C R`^w
ȹFė6D{yˀ>Y0c])
|&٩P5H[_NtepXZACOd(("ߨKՉ/] 7mFoO0Ҙ9[5javT<j7HCVVS*~,9HsxkOJ
>esk9@wrn*;-1oo"Ɋ^T\f6/}uFfI
g|Mz҆YHGL%Bf#{s/]6dEǢn1)/G@bf|+O
96~&"-$L%2U}%S	,"+l+_ݭd@0=bv|4C|1pQs[æ:bDU2KDa;WM"jQcɤGq!`sɓY"^xɖ	\]V3#+va'w3JL'tۿV$oӳވ#]gi],?.4N**>v?P5yDzhoF+rvԹ{1AY1rV?ݬP+|s0o ryOnBiWPOmTMb|Qml0?,V9ѧrTD	:vfA_
Y4Ng˩׍{ܪhv~K$F_ئbdELA<>ˍު	$L|g	Pk&H54P+}׽H:LTcMN{;tLp9dPY#V`!]#o闗.&}	oE%*)*,&H(4Ρ/gAW5*#2%j1M[,
9E'Â|*D{j>FН2CEl7hmjrXI:7V¦],a_}c젩^eܿBJu7⼎@!n98zK04fj/UEJ{4zV`
#
<4C#N־mMu&嶸XXA%:;G	JVԚލl0EG/uzIХ攴^xJpHeP.}[)`z,$hڕ.![s9}n
nZxJS0fJOzÏO<~@`iKpb7DF(ݯrdRM"́n>
ƌ+ha8Ptcc%ߡ_ W9BMn]
\)w"snDQI5	2"Ppֶ݁[0oo&8sK	d%Wş+A.:
oBt[1QGyIdbElLmҭ`NZQCіxI9kq_.(Þwz)I(
j{G).m.J
S%joPʭ@UDwcc2Rc(@~͚0*dN<@@H5Qbab_YئbDrrT}Q4-䊂Je˹A0n/ӹYPxǩʔyicxIo؏A9-Evazt/Jܼ+eVgr/4&Li yMPcxqqlq'["eXzYSI!K~9SbuگfWIۃ5~o2GN@P̎s̴uDw-u=GS!CLM~.#oo
"L'{5daKg-M9tX?;TG|߿aYeoTXTz舉.J>أ!)U-0Oq]c	\Kp`)?AF`AuW<\Qˋ*e+KuK^PΡ(>莏sBʜ&UVT&=@|w#'A%oΥk`]3#6=FAR
:]XiUCV(p?Z?]=$͙Oᙵmz=s87.mGW:B3{_H_s,;5/#hB?@)bj
QE'_.#t_`YS9q(<~:q	$.T[&t!DGjBj4S}A`UL!%sJ8(A`?hа.ٚ3KިX'!`V4PA)NqMx[hG}s&2.PbW-0&o/*
éƉj5Mgʾ ^CtMM;8ŧRz1T	׈3]W&+1NП]^'AFutj
cٛ"uĘ,|@FDS߀yiuM;
ڲFollgu"qH{ڲҾz3lnA?uZíb~@ϥ[O[SK+Um)8綡	TB,is';Wh2!b h
@vg,\i]@PKK
330hPH7^m߉-}늈Hh;^
Y=-Q[p̡
Q;A/
Y:^1YP>ݾ,9X#PB6 '/
&{䉤50JQ^c"p(fڲ]hwf>v3JS80T`7u~	<Խ9q,Ӊ|(L5]6*De#fJmnq/hM}f%;D,2Kdpj'UJT(U6;4P	gjm`mv70DeJT+xגZl+$wsS`g`Szq"sʲi5ܿẗ́qt1ë~D"*ݰYs%$hʄ:K*+^T5jӤL)
B3AoR䓯5Zm|YX?^&.O,>Enb	,}SUA-)2|WsV}EG#pl=2{OG˸>\Ͱ?9,W]n:G"2Q_5"h*l{M"a_Y(5`7qzTۤ}DPZOu1tJyЫ9ҕagϥـ	ڧ*as&m-r
vp.`_c@=LPHri/(C$%_*iz?
@笸ŕ ҊVTwjɇmƜьŶ/+ҽ	=-eFI'ؽ{_pRIӮ]x$0Kݡ)#]ply;_^&ׁM,-.B`oޕ'q)~85Kع\{yMLM=aͭp>ТLa܂,|o*?PgJs5A
x:SKHep!
ť'Ȓ}G?Jiq\\^&Y
5*ۀ3Oĸlʞd)q"9EAÂ۪$Įg@.޼z9O[ne^P5go:;ZJ(>ssaR0vw}J#ɷHu#rmfpL\*.qr6g-)w{H`;詒?`QrcJomsN4pxiܧxOyd|io<4ݴ(w!A0ўi-tRv6Kuu3('5Ֆu7"dO
#'hAT~S;xV?ftSsMB`oYK!t-SZu:wi1ǻ%9#mr
-)=/0^%-xaE^|C5i@뛯ΏԑI!G	!Zӟc[R>9yRΊv䧟_WcW>!ǫu3WK~e(K4ӌTHeX>5{>,=ʢ|EZxD^GAAPiGQ",x<>|dLrڤFDIk`5V3rmg(lLy/{MpwxSv ^L9V23
M kƥ3Nt53Ae}zfć}
fsO4V*.QÅm%]	Ѐ
k6rBF4|Iȿ;<4b T.-F"c8*xRU9F%QФIX]޿
,t^IJ!7P~z&2,a@AG'>1\kc]КyE,	&?RTхNy6,KY?6Q.fBU|+Ҕ,D[Z(Q \٤:2V޻FC{q 2w]AFWkc̔9+_8|*S"Oo{(#1_$,kE}3vejtʖ"xy;}ܘ+sO*y>#g-XQ?+߸攨/>4=_ug,n(X+؈^	BpFM8Q5T30+´2]
v[H2rc䠂s|2ғPbNj*p
XӨg_V9EnϞb4>(d;҈9  \>M:@^
˜Z9DTMK=~v)DKk@LoMЉ)T>ϦNRls2znڌI3&j|wN8(\TC8xzeDP7唻N:T̵n9RUSvn[?bt́sdEsTM~=AJj]Hٕޯi>ROVi( i"\V0'd]R?Ԫ}</D⨓ ?:S{<VX+G×9HCg!TZEg~%EDC5DtƼi\e]mpCT8ڎ/[>P9saH^e<xPV۞]|0`>>EE01N)ZI'\$^N2_TagH`gBXnL&lj_#xJRm\\P]A miS[4Q`QUL͍x$߄ߦ֑2ޚØhWѥ>~tB	5~)BuD RGm
mF/̲Nf\dEq? *]LJ
|[UA^*(8+9H:8ֺq,
'z
-MW?&xVluVNݒI6T#G"MsME-pnpU%HBrN,Pr. ̷ֲ|0&1*`'$hKE)g-x9Oc w=8„n>K-8\'-+{k/l":"gnl"vp~V.Nqr<5;e/oi*Tl-O$!Nj<H4ϡfyOqT-!("H	'u)(O_@4[>]
_d^tFɛ)2C?0#\E sR'[cधO9~N4/8?Xq *0=1h[لJz+GSTl$/׭֮(p▬8mhK7sf;Ou8Z#;+ML|</|_)ؙ~gmÒ6*p7n^YB)xBXqH( .fBmmB_?g1˦Yl3 BEZX]i~0ѷ6ۇ1e羝Sxar@]zH l-D&ڲ+U2nZJaAdYP[{En65Z­bx6N)Ps?#lh"aa*ZFZRŵ8ow^gX/86VteU)dF`/ `ޮVl@yv!R$!,n>꺨ƇۚF~DІp[:ԹE/K$SZmQ+PRI0cv]-[xe}	 c&Uvޝ!zUv貭6f.*L{t;{u0Bg/.~|5	H7
pt~!VһkrK!YR~Hr6.lᢨN=#{P3mT"ȊN$˸&Vȝ{:!8'wȬ	jZ=[Ngf7eOg>Ri޷[=uT9J-qZ-r"L)ZV
b΋{U^A9`h)adFm	vN
Myu3RG<+!-
ezyub?DI;dE-rq罆4wLWLO2N7-^SQP3gX$}
f3%疈FX>4![F(mO&8y>]anx8h[F3+Xf
m^ǩ߼DaꗆQ
E,:*6I%gG}CQ'c$|AiOO`Tul걥[$GR؈V4ׅ.ACہKmڥ-*Lq\?U|YaŁs@ҫRi=J1D
c:Ʉ:Պ7RXGb,!])H@1W7$X|
@/SX0A6wA
Z*cVȤiNUk>YDP})ᚙK0%ygu$zS(*Nɧ
[Ƒ|0ŴY"	ua)S{a*+{4y`*MYKaE>($B3	(g
źEGofu=W6ª]ѓ`zP8TXTz x.J9)
U|uc6u%[6PbK"OjMS<IPj_ٳpRȅK s&:}|AbuDz2m;(iݿ#\^y+HK"M{H\7Άb!O~jS-pPgUN)VZʯ\:ku&-]NwlQOVUY)dd~SXJj`@Ŝ_Bkkste?IZi^#{"{;w̜6W'Bt﵋ϧQ,3@kM*#(JhݢER>	>dRNUYŧ/Il_MAb̃DއqCSA*
p_;#qEBZMEOmze
NR.pM܊is_oun*/a{TFaˮѻJF7ݢàhG@%iϟÐʥF'@{}蹊gb+nv+̭i
GՅ
!SMj$UMюpц'DzMs7QVmԒV#G\+\L$7L.fp>Q!Gd:qR=q
OccB50M;f{/BDKM6Znj$݀3U<(SVceLZ<9&|Qp柤ܤaKKWuUDFB;*
n\^>
(izx؍0eek9}XLsyRÓ8NH
5VB3F~!ځ`WJ9B&EыW{-/LN'!=6ou
29gwڹ8H zw5]8X}ц
K/sqjܙ_G
uy{ZKtG\Ub@\BY)h鎮U!>QD@I
p!Bkd`oZ%%=?ܡxr:<ԛdX~O
"`ѹCaW5Ʉh>*(Xco!*|jtR31BKK x7@҉vmC@\'g`5o:8AĢ3vj#]~\	Mzb)c\#㮾rXE`
{;:)ίpE9'%,tQ/L2I%oĖM~5|;vǼ{gzɳ)*DH`J׀ ւ27R2a^F\^ΨAQM'oEadJ|1љ#(O0l݊YWgr¼l-\:JM#DkN]$-5Q[Ӟfwzv6N*0|~z=kT$\=GrjP3iOP熧pK#_)iyL/	tV	t^[3|Դ)[m}8sUb=m npij<p
B]7F@dasVb#6?-r\6>H~3Jsk[|+K}d-Fv8hu]~UuaN<[jJJ,DkKQ2\pɗCfXVvo-g:M{͒%l0o;V3嘗O!9_!;T4Hņ	HN"Ԥ"~Uv7tZ,=ȃ
,#tNQBF}wEVѰj	@1Z2WWѴ6ht_يa%񐓊ܻg@\Lǧ JuP ̓QSX+X#랺Y}^#S#z'AL|lj`"wIRFZ[EnHacgqM+\Om&tc#S.
zzB#s˨%,.)3ojs~[ٙ!Qrs#-P6N6Dz^=5ue;?2
yˏ)lN$,bʊ>RuДfd,jmMm(Piu;Q`ϾŹ}}ǖ!_82BҶZ-HbXdĩ9J|wQO0}KC3_lpcRQ6$'>%=ȲckʭsP䡴A?'suF3
 qDBV;0aX++vt6v+gKN+'1~[ėZ:m5sek]D/V8w&G^DY~G' aTG'{w&ì7=s4=fonnbĀojne_@.ʔ"z('s&,ѥ\?O罔oq:/Ffbh:+`q#0);֞&w<qΏ"%C̑ypSyqG
,gvH	Nb+TbmB3"yPhZ~SL9Y?w^3O?JW>|BO$]HClkythduy>M:b/IJ)GTEZ,Ia&?['(T6Q#}+5zGQ*O.烹ҼkGJ5۟vtxdcTr('yP>!3?2+W4GL300`ʁS{yn]{R@$|2OW*2tfƟG3M>983y~ުRPZ"d%lUӺj(Ai
?oz	WS~7lgܼf%V#,Hѫ5ar;q'yk~X3jTraR-fE\0v,{qR8Qeg0$tBچ˲	S#.ZW[V;xy@'tyBEyGw˭PPm
Uس+g)!I<%vng$ν/A&fXqvޏND߲n	bJVJ9,J=ww
vR!4^'[/lW_<>'@0@HWеYeX	o©pS>OՃזFǤSHdA+u'f;,ܧ
fU*Tȯ}SU(yd[M|=Ɛd-DhAMVCv麲U@${58jD`llls& O睋1%Zb#ɧT|;+YuG4m§Gq|ލd@&åN쨿(mpw<=id8K<뛴rUj	ܥ̢>]y`ف	*5/hIntkrǯ6sD9Sw;cL0?50rmKY?A!SRi47H?.쑘Czh<=8nܓـs~>ʢ&{ԤEYOzC#P7ɦ_ZZPSHLPVދ`4"@;d~V_9>'BRYQ#pËd4~Ǡ}@ [%iOIW9J<¯~Ɏip}UZi4Xk)&|AŦ6i
2"-#FѥsCdd?-3DO,ݨ)*cv4ഽjEW[d3g
,ZHuN4JqE!uӨ92.R/Twm:>RFu@)әTV}"gFU
(1lN*hЖ('cDM>&a<*f|C	`Pn.3]yۉ,u'Rvu5v0ceSӒ*avˁ<)+juGZ6gوX	n3J_S@ؙg#A+U9W9b	˕t{@s>NywLT4 SjQu7ؤDȊRUe8Ao>Z{ܘ
N+BTe.E{c	{
-,jɕTݐ٪G"/ Y1?"DrYC}vxq$cFuhƲ=TI/B1Oh(1ez)ͤkLM3}@ez	Npj4KUӑ)BJ[yEa`
G&'hd*WY@NwziB|!V=yĥK'iVcT^_pxb$7{|9`߫
I|γpwF&("UgyKjm`s%)J$la|Mخ-\o~kYxܒqygVOP7*ryk1M%HA[/,a=Y[!s"/xS<ވ!ͲۺY[4KM=tz~{j	tOs	 ͙'P΍e&[8ذu
oT#'̠t{3DxTe-IࢱR\E[(tpI}5bGH=|mt	{sEKhn*$
#*>+S<+yu4|rPL"xR~c>>"Qwypm$F	cmuΞs={@q+!m+D}uϱI,вrE:sAvSPX\`l(ݩ~3dP?»yN]|o*PSY?cjXZ"fCcoe/z$UPV.m~@}DVTL}Q
N^2Kd:e
`718Tm"YlWgLj$]tHJFi1'x4
^ KLޟ2(0qژ(1j ֌y$WX%40l?48Vdݨ:$y1q})_K,t+%kTS6kBEeBCVt_^up<K+\O-Mf(&j<84Gl{.ݩqa|
|+	w`
LiqC;EZAQ]\#*D'ŕ.}!N[HX4
(KY`ꭳ:|TdGob/Ԍ	/#4(@o:W*M'X\)kMj+ߥWT1o8Uo\rsUa֪̱RIt*@=;B>UQ^͜ p 4Gb=AZ/	Zhڨ,O-Q.@ˌP~wTRIًiw?d}pʿэb畾`D\j!uX)Gp`;7]zQ}ێT@eS"4
cn;HŚBv-q߻VxIYb&='Jwh	q	Srg&DHRdDƷ':l-C-MNA(X`I!Y_6Vl;͑3tyy
sk-OqΞlt$V	gX0DgV'Iu/$ͱJJ N74
	W{<=5Ȥ-Fi>{/ՠrDndL݈PZJ%vt v[Vk*,3*,([Yz78`/!}N#Yq&:gؖg}L=M_d**z7Ť:>td&,-|kvξOQ5wQKpx#ľx3ǼtYsoG,ڃ%b,TN
LVSoWt[ZV" ,QGl"at("|e2L.͌ݾ`JbIǝCЋ!wEil$b 8x-xE|."jՖA'W:`mE`!nB.+CE_~h1n9ڷ:ZGS9zfoܝG/D@1"[%;EvƤ`Q%=QJDfk6ń'XA/d^AL-	f8[h
@u,dP8PORSYiTg\a{/Q_5qt	னwʼ`v $e9[;R]P%gSo苄t
3V=~
X#ڤ!6ĺ\vgOgOA@j&{(`R*Pi?W]2^^1M\U1gR}=pW@I'hA0"M:͟4:*KK71mNBgkHN_kN0ZXAPQrwRb}#
нyۊ=䃈p!>eC}"קʬ6ic,*k?116fySݘ'-Q,kO`PJDh(R/Z6怲DW#NNI~6#C&dh9NH*Q,zQDg:@DL'UɎruܱ? @]2?Ҫ^3H:$naK1B YU&vS
!g9|8qU%C.?FU4.!WiI8[yS^`1"\K;^tSdsצ̙o&qORɮaģY5}A6	"7M$$ӣ[m$Q#JʮN vPŤط_ͱZodt7bEw.YRg@ǔg	C?֧S66L
vT8͢{r'
PwdN$”
PM|Hq@oѱ|L	
ˈUݿS]n4+IkٛzpTXTz
id@J=t&Q[
+[_KPq1?ZvXQxL2.`G/x9xw&("
^[XP
L«nd0:N&@MJ>7QI΀X!$,þ1
B[)qLX1OX	g[>.KeX"yy_UdNRx3Ѕ;B&D|zxcQκҸqZe'Q3ΌȕzkHޯH_xt0|e<&;d>R;9Ѯ#x wWcG'auqFy=BPCYos8%]㻹|Ƅ~5Ua|]o2GRC՗xb\n'=hn>abϽեw?Zxel"z;ADFUsO'ar
._>x!Pm"z]/6C;%hgv)nxrDNYi#W?/Uڰ[ J(KIև#I$HcgJ
Wvاq-ĺ@0(oG/=9j~)kVn޾@zZ Ty8>z(U&a Rh24m(ˣ!ܚFOnCx~m1Wț;n)	7@-~N9:H<
D|ˆvg9?(+?; ͩlo"X_cY\[_:@Ш&i'Ge"8LFlдy@OcM9XI^ijsKDHY}9̅
(rFe-CCRH"B$5#8@i?50(kr9FM-悝
ppkyFX\Sb32}BrA{N7[DϪh;/CڙOUn݆91rۻ1>ICktG
l&GhD4	@2&2|Gv)5ZDU
fѭ&0朶݋$)ӜM)
?B]M`f}%W$A}vu/|A&q55[Hlom,QhM:6i̼3QvUw8UWFiM)H$;ozAP=FDDߜZxRS޶˪dZFݡhM
P*ڏ6xcwy4{LY|a
ޱۊ`d"-phdə^~F˸
0i&ݗ✍smQ!.󿃂3I%=R]tΟ~ǟgCȑYC3!Rt@F"VZ?Fa"!`Vb)LF ǝU+J\6=y]Ӿ1ðk)M]F#A.$g%NR9tR&
Qfz
حlJQ7#<*{.۹׌ъ+罖Rf!覵%pZ1?)ʮC$*|Q
^´qv90K^W<j:2cAfhFORMkDJVUINFO
]XINCLmemo-sv0019.djbzSjbz^{&E8=yp{g' 87.'i\	Co*rQ ^3l`:x61Dw|3nY^Q9CwUgbWn=َqӧC@!ţL+7?faK4@5ܖ:5awDq ;V=ϻ[vd*gO]p IFvT@di,6Fo;qUn;ݘ%u콍e?^e)lOrc,u;H"0-E"E"N:ES~wۋ+uڮ'8koh(OvTdXsB~ H*8(Rx&-XHÃ+!y

DD(!r߉S!QYnu-8M7UB\ԅJVٻJ
;xPo@yO kYp':n8]Xu*jp_
ϧ	o;P5kھ"ĒM@aDf$d再c1pBa1e(ZtoS9]H&0"[i9/Mrc~{<$^}QlBac#l0(U7q[S\WeJ"tj1gcod.hv~y1 !+7p\Ak3XWsA.7x3/66lR͈"q.;P\rcx.d+ _}`7iehXӲtuo}}b%HiUCeuSC%TcG(uЕ~>^MB~3C{L#f`9h`ȓ=_N
Ut
TbyV\,Ypq:y#E8@;FmRvW3N4?|V*Qk0f=52PS/KJbe/a>[rdr	}>pR8s
mX1w_!n![iGGD5L/xaROW}&7toGq)7%'e7mW$	06-̣ڣ8*/TD>JncIżCAv%|l?}kϛ"lBp%o!E4kHOӦ(6Ѧ=$	ςh7,:dTn4:̶u3qEf dߖ';z,__WhJ1dFu:P
a-*GN1зD)XZ6Ng>w|{҇щ{+%Vn(dzЮ]D|@u~24ʂz(qv{H÷Bi=H]":M&xte)5#^WyaLrbp3w+~ő*XcYпAo%$ytOKdOV/[3aRpbX4ut)v3X(vN{̀.Mtj]!Mbufܱ@AZƂwvJB{/j`O3%׿>{{Cy_L㮵)H́	jNXY9uV'QcWֲpTZ}-\oBLP!u"4^aBӒ!ab(ϳcrT~pm.>в&W-.Slg:C;rl!K8;1Z-k#5=sNV@B+	BuZctܿpIE]-AQZ	J`j(>qh4]u=/mr]ٝ{8>y֟"uhpAQ&wzc֤CKui8|YGot>F|X=tuίcD=/nLSuұ^!2
$l_M{Ay2"^LBί/>GA{I-I&~~5OpCt?:	j`Qє'Ƒ23LnN^r[>lVmcĵgXږ+P1DweU]<2(\tmNNF{SשLܡA4}j}*3X~wbkxN>z]k
ϙ&8ś f|K|/#+.ڋ&+C50)Jc˭18䒨NӾ+rQLw‰	jg]\覠`#6|uA5.;X6	2߂bb|uSp]}D1dj>`ϝmP]T2{U`$nũ]B.XCm,AJYv;
߬M@<_Ut՗iư-F/{ãjzXSLr~n*o%B9O϶Ep'H"Aw(n>G|d%lO[@SӝcP}~
N׌;CNW;37_94*a])EC"LWIŀ)kV40wja3)N=p\9\^B0Wæ}GR*u)3h
vUYvl&N
~V_R
wYγ.UL':߄إ$xl|^=&HD
j
~nWLU&rU##7`U(IZ	f^];"@XxRp,HO{+:oR'޻
FM.^'mUX}vX\"CM] B*M?/mQcb_Z74c`tho'rz(vĪ>.2`Of#TZo)\1f'S[(~y\Y;FZts\
 0~,8 ,	T}?^o1HBu${<=U>n2
RQ
u9	XTrf;U'r%ruQ.=V=|8Ҧ,bcƸ8&?zT˵ex/ǎYU8<4rH@_X u\GEE% Lߌ5m5*(WYGYF eiɘ7;FUIXA+57F؆Ϛ$z3ĚRTҾ r
c;͗N"eJ{+0i߼ HW7M1űo;toyۀ#-gFzܿ膩.~ʠCc3ԯ![$K?:#/99
cYDݟ+v(}8Qދ*}Jy:=0vo7Qb>.SĽk&YtϮ3P-%n$pK?8h|lFS@{w߹׻_y#Öoi%ʦb҆
±ƨ4pn
icܰ%"9e#ɑ(/R$O.U|.7"?~^eo6:U`;+
,JD$`Sו`6BoUZM/Wvo-z
oRZ]1	\ܚȿ[͹a8f<ův`Ai砶M>
}K td3Hڴr6t䇄)V]t`!1oRX:T5WQt2=}_sq>~cĤPXB9ajyz_a)5₿"UH$&<5\-ֵ/
=tf~XzNW]4ج+g4EͬE ,FExo6D+`J3o-2.~`U?3d,UgM+%J/ suY|KV'*88<]Qf?[c/Nze!P:窰	َPؼE}>
Bah,ɧ;F=h,T"*@2|4R;s$aiA)1nߪy
҂5],>#Ҍ8F=%,Ss(01W/xہJ`BѝR:L-7-f.IZNˁDzA$msbNo}\ژ
1o\!J:r)I߫aaG6:La4n<ΰe™OּXH'{Rsy`;sJMCsPM>	2eQӆ0C8̘RnVP؀VdRq(I~o )Tr׮rz88V+3;Z->=X,܊
~#0֪bLXt."f!5ߞmAcF5qmJy>WX%3HU|!`)({*F&u"5j;ȇmlev/tWHau¾"O8a;=
d3;`"B0"J*x	}XriLQ8K:!06Q?JJFQQ
j}8	Yڄ,XG\wy͍aA1^ < 4/kF䮏~9U}6I~}8fW1xAe|H~uBnDgik|9i9+X`"yYXdė:"
<4"
c{mOzߩY!b;@+6i*tY0aZKKLq5ޖ&ڜs@U_]	?nʸsuS'
0a~vZB`K).,c;P|WJ~FKOwy}whi]{;K9\Wl|D/ofkd9tO}mBIїݠ+Ҕ_	uo`D6؍=sDe>lP`n_R+c =Md&f褿Y:y0c;OLxix8tCv>C0wP1d@XQ4+EZ*tEIeZŃN[*p	2߻BvG-?l.QaE
tGe{>Hkgʳ3b&/־]JՍMP|J|G5U@
옑hdg1XQ+iCq=g_cn>X́{a8A͠DW=ˎ̫=LtNdoSOtؿ|ҳ7̗:~H4VLo dp"Gft\h,X}x,LBE )ɣbaG嵮\;rُ/O$ll9IW
~ZcS|]t4gEտbPڠRp$24^v_rr\'-!>~%wxmC/V
tuy6k>'[N~TI)CNpΡ hƋRfh/`GJ!h	\Nõ
OUe
kjs¼XFQ-!>xna-a#ՙ)9,0˽QY2zcZP-ÞCP$q2[N@qށ|Յ$PLu7_C@ek!aN:
2r\ C_Y}$K{n:Aml,ud.{͔tvܤԮc%^̀`dKڲ-	,*WB:A$quy!'{H	>u8)/g32}~.Ãi[;lМjx0WL[G 0Axq.&7XgGxۢ_2ŞU_&M
$}P4;=2t1Q4g0M%{e	-Vg2	ldWFa?oA*m<+%tpg8!/\HQB5XXjIUj,(0G"*xHIhp.+_*Pxq@iN)-^F+3ƒMI`^'
Uim)@u.guVO	I/g|\K:=i9hÅ$V\)
T GCj4'׻Cz:0?.0Ύˉs(2?zdc~;M:":еG&6z0'Bep?uD#|eL}l܇=b[0;w;8هеY.O	'P
L;bR$SB{|6!#ޯ$!JRuB}X]+nAv6ݕLL1FJ.\jt=9x \Wo~(KI[`Dd['iXqh|Ɨapl/
$?qVX*@R}AA"E9Vm//Rй^/on؉B/H?
mndz6a]ae=-|4n|ZhypшciK%N|\/s'g&cXǒ8	\>S4LT՘$XţG<ۗg%!;I=Sbp.Ww /	Xn(bA pAKTte'8.,a@}zW9RCQ1;##ӓۻfaUI=>KCRJshC-|/ghAֹ_D
JdSS%V+lCɠD4zoT8nd%r ;ku>UX3Nsj=SYE];եucj:WWBPO|!4zZU	*\˽YI>xZؙvw
;(p[jj
Qyc9ŠMJ0@BukoAx+$LKCpfIH=8?Ir"Kmfc8HFx2pR.tF)^?| Y-xȊNK~m8$QOA܄oV02s|J-ȵгco֌prxȾmyTɄڪ:hM"v4Đ'=$)cw6SdxT-VmIʍ6FaV*RxZ,'ͣAb~x{O:~Hmuo*D:5>R0_ǴQ!ec
zYV]]Ld1*M5*Jmӿ5փǾNi5<,)KnD#Ϝ]dV^w(e9ۻ,tDn
J@j0!GԦ;&JF1CumvsmHĽ&	|
=82*spXсl@vHaa3
谂0=1&恱MI	1{}=156^OJ&V_z?W%]sȳgEAh}}Gb8Ro&ek.,ȱB(Qft	(zGM80zGx*FwW66Mci>sL\oE;Q?_TP)hLnX)4ȵQHT 3em_ ,Mk(?R=𠬵,K*R8JK[:w]>
l=װ7-E(>p* s}('-_1¶'	鼷v.Fk5Q*lRE~:ZwNvB:6Kab:$<{gyQGJ4pUtdX:̠_XJZ4T+Mu.ʑƁBOqrⰔ@yKǾWKFU]*?"{
VͰnJ].aR_MAP#!!]!>6]I|,se.6L(W_:ݬ;1G]hW/2KV[Y'ɪ*dhw5`#J߯c{a>֥';Jdvq&AAvpKNgZaJuS[ѐ53s58Gh)EҠU8L!kyVsBVB@jc+i `{⑰־fT9W>"yzi1hfqBVϕjߦ"S{pS
R	/7J$m$FLa>]w^0K `I
7oȚA0rIPRJYF*aq*9qE5z$%`IyHJDޱJ\\mZE|7];L{Zϳ[?ϵSM
cdX̴vKy]
3f딋xgx݄7؊璒"|A_gT?S lg.kJ8\x)[JY]^%
Y[Ǔ;7suv(co,]Q9s.	h}-QPR]2@~/3&' q4\Apomӌ"%n4Ĝ\k5A'ͨ4Fߪj{Ssg&S7JSZ&{&PAVJʜ!vMeݍt7h`uJzJFa_cK
Zgߎzbc4=]IE~j&f>,}I:Z.f{JVl13^Ѥ6)Y"w#qI+ύ
8<6_<]Hk6ѵ	}Of05b@v֏p1Q8V
lcr:xM^NPeKԛoM?z58>L
VI+y+$t 7X:T|!
Sv>Sۿd'~&tE%ev	/8NQ,YHȟzHY1
Ng!Ks4
Ȋ
.hCJ.zTO;gʑȯNpɉ8O83	ᩣT)*
-8
$ljn+$c)NOb_sܥ`b'<sk/MS_izf8O31;v*'LoݿtE}|)l3MD'٨ښd7Њ}P;pR(Oi|>璸:;-eb
pq)xlC<DwA=K=ץ/Ui7Odenp˭L0uOE=rk5^3 bpƄr%(g1X'Z	fF0Gw)%~Kb7+.>r됫j=f
{,˴YAՠrzF3:L5q3vcvKlvnK;~U
]\PI#rPv>U
XbNGE
 38CygaCJ 
::!c0w2b1It,yQ7֏.^&lmfdf}93oCwLɟ۷f*Y &M,mx˂y8"azy
xR[Džь"8+x$BzHm<6x.mX8[G`͇xs#e

Sh^"%-7rԬ$}hC*EhK4E\5QkFfy{)e邴B$l:@zxLo:稫\"mYn	wETkZ] me/r*j_rF"5H97ȂY#kNJ9v048bX)&o?ruRo9QTO.âܜXˑ:>R+Eܼ`1уߕ2W&؀0Nh;,Hv׾񟀸U]t?K9o'tYgܾ.aIUo>Q=
w+hcN.pĂYe=l;vVl7"**<,b::L&pM`xk$
^>*ł	{Ka߶˃i<(3]o"\QixNΦR(">?#ajm,d6SKH@#,Qk%HP
Q͇H	CeԬ?K;5YG+q֒~$H0}ƎW.B
Xp5z<aK5<%
iu*>&E){JREa۝_Zb|59#|sR9+;bWG:rRL+d
=4ݾnvtKGM:%%d	iEx>4^Sj&dXR0dw73;jqPK^>LBX
l0g"1#%WYî8}%M@,o:,;&DO(0OߢiO>핡lr[I6MYۺ2 if\Vl/g"Z@ޘuQigHF9ܭ+Wl7ΩPZQ`crZ5Q0ԃ敧LmtpYUfatŅdn/1Ɲ1aU>q7uu߻u\́Ԉ^Vun7ЄE@>DnşqGNu"4#,5QVb%ġ6
 @ɻavEJwD׬i2 |pR[$
*gv
x2Fr*uw}uC>3BN4Fvy(&I;
#-WC]
AռVywԯŕNMz
ں;twƂ0'@RO|ySF6%M7@
q{
iEP3yܗ.͚fE--pΑ#藣Z;` yX?>.Aٟ##GyIn[DNN|K%00}E$|B\RwC==HZ#ώ=h5ECo
ƥy\7`+Db11ḾRg42~ž>Մ)w^#{}pEd
^IpAW7h‘U+wADitlاXlᥑdtj>!axi8ӬMFN&qVtkh[󮆻8\Vɣŝr03sSJE3]Xq8T$fr"yI&ڱ7Ar%{Z駱$i4s˲H@L!_xVV.Yk`t^¨
R3&¦	a;Sg߮PT&YgU%|B48F#gym%7Ql*Tk+6HByEi؞	3n+Ǎk7s+Jp\Nל1)`Qy[,<w=I7F5#zD>!7}܉R0^N,ۗTxKEu *el+jB=B[[Y$՘
F,}{B	}sƔUD|"a)|5
p!uBVN x4$Pp؉<_<=Rvqȥ~e+ h*
svM.Lʹ_
d3p`WKL3P;/EV.RHHM)t#}`Uvu2Wq-^Wd}HidfN̾7;9
slFxa%⚋**
 XCNR@Huzd7(OT+Iq)9*g~BD$GguM,4ڋbcVSe3S4٨	GSoԘ3k3t[PǴ;,KKa䂻Go">mySO)FW;^3t%a
QC<,KJ :In2/fg?yIېo+TI4lS=oDS䞁>7Јzx]~1@4򀳻bi;Tn0{h>5ߒS/"<WASDo7y{_6iU$L €[NƍLa~B
vJH/ȗ]K;Avo*JPnbfLJmO[$RwoIddl֖R1Uϐ}$7WBK/ cJ"qϒ]p%OE%
5:qdy	>>JPVL
If~;1SG*
gsuJ^30`Nn[,O,;\jRD  eɌQDr'0D-&SL^1Ac/W/!AD’׭RަugW.Q0=i> %qJɍCZ_AL"

E"'55Xu`:ʊ=x1߉^vK1"div9We`x5NPbs%n$XVfCNjJMiOOmc$Q
WdYloC}")^Լ*YlDi٭ +Ķt"z?)&B.{b\t_asjNj${bF
b\?^89ȾhPƋ3űIE nu1sk#!5˴x$Tz]0616c">
[kAw󳘜yAVR!w(5_ *`	2
&4;
	#6.ߛ]q0",^{F$9tLp4>^E{WT0g6yY:@Z@E\'9u1]'GsfǚRBPM 4a)NVvmK4ex÷$iOn1`iZΉ͟<]r[{.y{/9ï\*ri&gG.qAjE*|djEQԕM4Ĝ
UCGϖc/|X~'cGBDoU\ɨHeLfʲٓ#
}IZ+2_Fn8އŀ&+1><6utEB=-V~LjmKG!/Ž<~2x"Rb&f72R/fjyt2ɲ٩w0=5rK%T9©.
old֪6~T
'.;O!M
 10y@Z<˷2o-]eDJH~K+~|YWK4	u_/R
	);Y.ժ0}(]9Er/

blsE=Pxt##f5Js"r:&!T&&0u:P8mzfKj;N#Bsߤx=#H0b|^(=:{6(]hXE~:ǦȊA
J^
5!.0JhuV%cA>yz`''^tꀢdJFH[Ν8L2Ҡ1T,m_^x-h0k%h*"<yj9NĤN'Ue^B/}9wzATALث@G
:Yre\jGT[6Q0МTEb=ɞK&~kmk;V̵HdvDN-@Z1Cuˈɥ(xj\Vuk6\{62䧛1ƶ\I:?hBoF{P7[iC\8"TBEAr7F7^u>@l[셔QCfNYAPVku^5 
SXo{[*6,0:A];sxӳ}^c4H0⚸c-főtru;d.ʻRdtffqc]G^q0(M{`fL_0Չ޷GɩrO#.:˙+Gf42m.DJDi_.)3t&:0J]3V)HiYjSz~B\,-g=x@j
4g&$cTr7+|)EzUuMā̤(:dv(<%k}Fj׊'=;
7{Q)dIFGV	E&€Hdno)@͓9,$
W(mhvJWf3tV{mrR#´:	Hc~rU<͎8cgT^UM2$n
4AHr)2?y/DtZpF18θy]6j#iLP97k8OL2H}1vEWDDFalm$Um;mnDƵk=t
B4埈nwd+bH?3%/!줐q4(Vn+Z3B!ç^cҿ~}ys@'ӌPb?U64n|ˡY쒏;llP{nEąę%_+.#&-Co^9g=TF'T/mKW
#eyk|@(D*QAVP03LXiHc-qđ@pݵ]3bW=vb:GdSXЛߣd#Dd`[ԈgFqܰk;%q(9O+B3&˚d(`~WkE۳/`Z_.8v.fk_BoNMw]7_;%`bAf⃗zUK$s!sַ.Խ@B%ewaSOܥ_$<`*GsXvL822RԹV#׏0rΉJ<65b5*ѳJrÌy4L]P{n۠.Z#XYK>z
ƻXwF̎z	O$,Ɯ#7m6:)z&NNZ)^9N-D.KͅF6/Y5uy3_-ۛ
C9!viV/ٯ=`	j?&rLTP #v	ٞ^wWX+f=8eJaz14ζ7=EOois:=/oxo'ޝG˩l6
ܥb0wif9щH]00z.#ˇpO<\Vseq*3vD'WyA	?@: ɉM],T&Ы rSOT~&^Q3U7o	W*H3N͹ DwЪ:0n$Vi	}PxLDo&
ar7GJ>k*N⓴"lwLSnbauaMٯgpdJε$PM6xTȤes]h*t>u8Rbh9\;	LYK\O.C3i5k3_ٔq̝-&3$
Ԗ?ҥ룺hxŐۅBe|O*R~"biIKMK!5JoTK4!"
PJQ=J6+s֒Ir%|X{gO0Vin,O^ >e=V͠y*KpBY'|e>Ve1U>¤XByp	\%쥃1ijνL82?C	"Ag@AKz#]ʦa-v[gÛV{.$~wjIal-l"O]<*}GHbԱÏ\zX%e\eZwa}"@ahOkQӹ6/
`4U9ݨ峄8
KY:%C}l@uȵoU!{['~{g(YIRdWz]]QhKsgG2%	4mJ<_$}V,)|8,ɚ=2D$D:jDi8ٯ &(iPPIR#2G.ĦT͠rPOwNi"N)pN-L-G35gl}
*ފ6A܀(/X
MbjU쑥'#?"p囻sb_3(,?TXTzݲ.J?ETF4GA"xǓQAiA`Ze}DcY\UI_3Z[yp◂GI`D9ƠƑ9P0MrA|Mi?E^ =t/}޿o
ՠ],EI-76&%8\MMbv¥#
UUaENŗkLt	a[_|b[!'
FI2̺_Tr~WBy랞Ճf	-n>V.%:/tcN""^72}S%dAH
3*5.O^	H?x)PcD\+(@(9F	\#Nvs@GNj%~]I氹YӶ6]Zx҅L%Z^V"=3]WBDž,EؙSRlJ";:@#We^ˎ@^O^Vlq(~~&Gno=KRYXwxW4L:sy`b0 `Fss"?mآk1	o.t?d]+)u77ILnU̇ۂ($ಚtl("@OEKݗ굝۝ý_y iaY$y,pO{<ټs
h_ myya@we'w;IAtœ&MdY0ŵʖUt(]&iN4)$n  bA5\}u` &ZLFv[T|giCyiCAÏƎ	[,UYDfƔ˨'	g^[&.-XoY%?HZʌKJd۷?B6\ZKo%cVlN4Eew-
`U9m?pJ]6K&/`"倵\/:Ҭwp,Lpb%n`BWy
>%ָ(Y0a'*iVK6YSr.ꭻkjPHFAX׍
]!u\ 5F0GW=!212\x{S؃| Q.y(xGF
U!l=s(X[J@f˱_hP~EM1[rډxt$rf!1g蛽K1[y"mP'+_Oզ֫;?2I1wgEh
diٝbȬ6ײm;'tIe.Ni_:ME%iGlHLs>76gڲH-)ۏcY[d~X~)\j5$z6F{+LLx	o}{X7VHBK3LHXQY?H+}hvh[nbWz"֧)(*m|Iv!a@y(A٨UdF8S7#&M0m.RA)]eK('ē)7A'ޕ
fbj۴ =r`zlK/5ڤDْf|KΞX6@5gs\!x+0Gg6u%K^?wgammK
G!~.kD9^cG/u9+rdHd`WGyT Z_ؕ$zs[K?W
6n*a_4~yA7X~p?@rʐiWZ7+BԊrh7Z.Fbchp|myήv%:%
_4+YcxNx&aVэ&u(;H&"`D<	kiͶV΃blAh2Da0acRj-+>tAIeJqH5FV?a}M޹1idt-tzB5`-܍IYz%sl%3v
l9LXwX=|(ؿC/#*`c\^&kH]{`T@]PU?yӤ[WݏlPij&wM(:kr@=XPba
.uUyz^Mގ~q>9Qh7߇HDZ6pP#@v,&v?&x*݋H$@
znqC1ȣ0߄ ;"HtCќJ<>Rbyؘ+)guZPm#I#XlxE@>r׬9]cΣrjcg6|U. y;S6{.}KG5f.$AWHA
>zN'FORMDJVUINFO
]XINCLmemo-sv0019.djbzSjbzw
{&E5*oX'#ϐIeU\VpQzm>{@JH`h;iz	]( gc~UZ3Ѽ՚Ciy_ZĤT8*;ZTvטwǭ,cͪ%PW?#,g-
X?$ҡs@	|mK{서\j-WOiY{
"Ӈ~H`hBCP$:*ӭP\4NYkτLmx̧NϋWr'*[e;ϴix;:'43t@by	^N=_Sp-F#+&O%a
^a"BkTyi/G?o3_#fO	|gn"p Q

c1NH,WBw,H""]Pv\!f?oh!"w~o0nϐ>"AC]
YhCҐ4﹖uK}Nlwy'bӿp9įhҚeM1.6ʸJ3ÓJݙʙYe@FDazl8VA/n*tC>)7roזy#Sk}8A@ߝD!h_8B,Ԡ	I*'ᳳ{b<")q|q-_RZ\̯{+Va̾ƣ,ۀЧ~vF+5e3bVvGվS\VY+Ap`xle1_#!/Ξ"xiY
JT$	fa +աRa"dҹ#({+F
6* %KSgUJxKn8՝5q4cyjF^PzrgXpbבwoVj)J`߱"w
uHunØ\C)(?}]ؿgLEG=]˯ZcL-؈!|iTnfex߸m`U޽N&Vgwn# yǟ^M.;>I#o<ҩ[gwu:<,:yN(\8𲣣J,7K-T‘E=(:94;7-Odh]$NSENqcCz.*U^t'ĆE@Q6T7#{a&q7+/pFQSop.0^/p@cJqDDv2XgGBa	P0 Ŏڒ֠me{s[YCTCލHƳʱ'^'Y{C}a;̩fcB?Bsax2R1<\%rmcĴfRgTv4!$pe
x@	_泚
1+bObu]xZ,[Bi_Pc
Ɏ
v\̞2BuE\M׸B
'ܒ|Bj*p BoAnAim<7&5f#I:5frG5ҩD,{lJV]P$mHʔYEJ."@tM-'Nv#SjC#yLyBQ|*sHV)1&h9BׄW}_nٍ/"mM{{|ZR78z"	
dsj>{	geuӭt"RŴʋ-ж_ؤ2 ^X9+y<^@3Yr֫-R!w*T8KkKG:{FS//^,r"ih!m^3I	RQ4P)?yZQF@@<\s!2)nx.	EU2{C݉&Hƶ`:k!'q־4SahLx%#؎7?ˇ [ysO޻+s!*vsj<ym,clj\|'ɶu?5¦
YަE>yh_9+|H܊n®S<\ jD$yX0O0Yu	R?"dI	hIc=\!㵖PM;"|Z|Mf	XceOSI&xY 1,Ͳ'c~=3
фxnD>dc\w->mA5AvM,
Lh1qRP'KiYqcܢp
6|
N:ƊoaVv	Ɖ+?N\PXg 
p=cvN{6÷9Gkx/-|ޮm*ߊ&E-76>U=&tO?p|I:ʛ[ ZyU#3j\`Q'mWG:/>nVp9{[/ftא	.B#9G!rGp4'cO?aȡo;Evej h{@;@=G!S1vb`C/S\݋ccS[O8!>K}`nVBQ4ZGV=
EY{YrBlwPb_yiO;$+r	oj?:Tt~|Kxc+sgc=h-kvB@ep*4mBr0U#R;J/L
gʖ3h-]l&U-`Y",V~aջi$CcL'A"	
,ʱKUc]1O_"IA7(Uo[֍6f8gWF3Rv;I	4(,d :B?O_|9+HJTp`>I6q*#a].))Slܓ}PvLRK浈BꦪvN#<5g8ן^{'%l7?`tyLzrI팸km__]]{ç	zd/q
)N2jl1%N_+r3̩?4Q^A(ʨWAB{b,>02u)G{Dz(.#)({$DYp7L}5<f$Ynbk{h_Y5
H>!EzY}RNq
ԚLf#!K%_r|w|WHUf!+a@5VVVP r{?k1TH䌛rw@I0@i}l>Pz:+C$RѢ4qЃᛠ?,ͰEJ	H 'Ĥ$#%|)&J;gp5/KLG(*J!:@#
&Y~
z(̤F`RhǬwv)BW,QmS{\ugS5~V^v/2U?xBN5`CIBaE?}neh[T&##(yɤ$ڷuH	YB[قg%Bx7ގ~0f?_|8{ rxYAKJyכ4):LS4ĥrrS9([m?4i+B!!$ڒbTGrǘܨ'.1!f3Aag0'Ө/tጳKZu"E`Ny3ߓBAM^y?UKD	D*Q
\GXkÖŤ2F|]0ebC&5@GDމg/il-[(͒bTFͷVv飣G((6ԋm<3ٗYs` ʧIj}%S,-dCR|T!$];a*Øҧuxۂ4R(`'&B#'2`ͥ'\nz	sNMT	.S	2"G0{SvUU'%胥w`FT2g3_$yoOϽ}#<qK䠎V!v/KM1ăt+h/Ug+66{128U7sA CWm@7@ShMм |S*f3Y!رqzc!ɮU&H]Y4//x)r0ÿk@U2qU)&HU2#
ޑ{ Ay4]w7Ƀ'MsQrn5\!!?*zůb6R%?
9\
Cpx>]e+#g57id:"\tN&{BћtZG)$Bvn2kXtQKj#ؚ-YSI^vOf@hR2<crb,g-ŦP̃ M"on:e_L6*V$2d&lq'œY ĀB߻i^kL#"(Ujt_.aҁ,V%3mAyͦIkCGFxiƾ~@\Ķ($OYz
0kZ7NhK|w6UKO
hBrڙmqIi>)df[{>}~$5s\λ3tǯX
[ΟA$'>pV-9	u;dc93:zr)LGR!t㥬קM.A4>6l-/#_r{E$?ǔ'?(I
N'%v?:1q>&݋vxn}ntgl͠H4 W'7\r#l"5u%"j_7]Bugj\[AwZ=d_c·UTG)I
W2F$_`Wff
Uޖ߾l+LAԒr[]RMYWE,~YIC/az)5`@bӝȁо۵+:UjG6
(b`7z,݈ K&[\iq7EP*crHǏO'{'&5#t}IKlFT'i[=umC4s(KcLBx{:ZooHUMi`XJxjQk"V9:YLZq4Ѕ8n^ڭMKk(qxnI83]pF8+"BёЏ@Q,[";MFIKm=l6Zۍ(I~c?sC$Bšt}o7K
^l*lEވ_ebݰ[0ڤ^tٷz&1oOgJ%g
$C&oУJʹ^T5@j]6N@Btit6Ltٕ0g
ѭ炝b!{v7Ԛ"jNirPxۓT3	Z0}/Ei6%j~k/6xj!#-B]\E~").v*9@M:NpjE'x(m
f<Io{N4wb2]m(1/!vPIEcR)vsyLh+4XeXh'b$4ƣy#ej
ѩ`Nܴw|('4%<Ӡ:qWW\%I``{`
<[k"QQ&SA$C!q$2Z!ED&DEQY~)fʮыTp=\P	{CT#ghgtzntXvZBY3oW|P1OEKۻ:nw!MDV;,(YDF2T$HR'³SHwc
G{W[O,L\	wŗH/\]Ąw\H06_ƌ&}:MLSJˤe[6G6{<0O6!j'Qk=SV>=-a.Rxxc4{|"_))rq-+_q307QH1ӽ-_e'5nsUUaC3^pțة|ݕX_-B+~w/LqT"TVrĭ:b>E}tl+bQ!Tl123;C a*haaxlFuN)ࣥ7+a;%|;h\˶f\PӘ'1,dQ!DY:Թw5f,pnhZ>,-кJ@(63T'R(BG':Jmn9;IAU<קdJʹZkE	%{ɖ|$;(TcZ[9=%hVJð^Ȼy&PdO EO4H=ir7j_PU&YLͳ]8nUnl'0aU7nD|#\?7rcl1;F_`$"J\HD6Fd	KuokxhVSHlp;sX^>Ċ^;Ȕcev.ovc
n*}bQlCe퓍!`(=$7HC9&$aHOݒX6
m:oIx)tߦszmʻ$\s8UE
I
CfW7hB@FN#J5QgTDT>`\KaHUwe/TZ I/F"D=" Re!M0maZД6(pxj7"DV3RS3e5.RM
FB#)a@mvYUFRϬg;a>#T^2uTR8>s؜r`~nfLWZv(Ho	|*_Cf+
NrEr㇇)?q|E3(,1!PŋئCjHW4$mtv}N*Op;9f^M.@v1E>ЎOdKb?[.qTK$unKl|ط&i18?gt@eA6ȉcx1fLg>CS

h_hybغ&Z|$+`|Gڮ
n4%6@Ag~!tտAxU
K4N5]OEbi	8þ?@1PS<	dy刬.XYM&*HC)z;,@
Roؒ6gj7XV\N4.bx*N{^8+Lkǐ6f0AIY^I7ά\9X*yk;kP
# clGQw,GXڇ


aG7jk>I+aut@GxoLK3Ḭ"Yai<|x|#}z
g
UZRZ2ha&0uzA
Lb% !q6lJQWr7.o+cL7oݛHRjѺ$B:Juvǒ{7$jogI+Jϔ@/1Dd]PWњ:t}hhc~L'
 *	LW"e!	rrFeG-#4"toc
|r
cÿ-NÌXŠ_+MPMɺo/Leۨ`' G]k`BE6ƂJլKX}Y/ФcȤ8'RPwKe[Y'BUagȷ'90j*lq$H=Bx\?P	֍$+s}U}<rV\Dzk>Lp
y *`4B>|;FoA&\15tԾ^a
z9{robP
IӐl;wM腤S;K6@.mu=Z{38fFj{1rX@<n`'W. H·0g	1;-Jd{9'M.x7s>|=Τ#R	>!gHJWy:{QEXZW\3YÊѝ0rqSRg]E"BW
aCv!'E]ӭW7
@T!/=8J080<}1{AWolMALxశQI;'}~%}Zf5Y`F-)e^"5X=bT5.aE[)BNn
R@			laٕұ/ejR@ȹ2nØH/
ZB0pڬ+g4lRuB!'2nkx
95ut'a衞(0@L順C?;!DcYdIFI}_,5aϭXjMߞtξv'XxP3/Eѷ:tù>-XRœrtrG{D*4v=]ko2h{Gn[vbQ0R۔O=$O~]#/"]\DdiQ=үC?r-4=& m|eѾY.N*P샄S,sg꺲
|]8jR6&677}%eZ{1Ĩ|)|5E/ŗJ=QT!j[xo36گ#۞]xb.zOvБ-ؘBߺH6weL)<5+H<(Y69ܸL?%ןmW\SM<<)C[o%@ZuVB;ɖj3.Zg[-L郟By7%M+UԢ3=@2)Hz%eVl}@F)h0rbsC螤4!6BI!Ĥ7N_e WrMAHVZVNC%lLgD!el&0fTPTy7]Fv6U6W$9[Y]?DD d6NdQ󺐚W4QR&5}Cw&lͩ2%f0U^?Õ[Uydw&w?|%Aͻ?O%XP	?b/`RX;8"rM-sPbI5@ge^vry<Z
x悢4_hMihIn]

/v2rxria*2exyS4{%,N32|9AJMKd;Y=pP~wKcUMKP;ڋs-Jдf_![Z4EV33u9tb앙MLc75Z9F	Ǒ
M[!B[p~Ֆ58x©QD>Zuy8*$/n8xM֜jK!;bǫek/vUzҙ,u(t(ڰpqݽq4@v'

		[ȸ@ڌF#um4 e72Og=e7[:'q{Q{cN%;?[ΆdM1h층-DT5s1SҍK<NCjyѓM"R@

UB#b@^GAJ=n&@:uH]Y6Co|]4q>BmA믢2!}}L_fYD޳>2wQ{]މ6VOg琜G

o8$	/Gb al!u3S+#u.`0@!Ƙ&4yS),
1G܊Rm"
x0p+Bm
*ӳ/;/?#atXdFa{ڍUŘi@Χ#Y[Ay{P0t9Zk #HE?@]NS^|o5V٠d;\o9}w]¢V0
ۓS9\`"@ 68k8IL;&pHG-r>tmqD
U`a ]6Җw	t'>ųT%\i-i	lir;IX࢔6&bC&,d{
gܚ{Gu`^;%t0=$,FjwO=CZt	ۖ:޵Hmq{M?wqpoޱH8Yw3|ޅ(rt՞hȠ)$9	|=>/XlnޫZMGLcE(A
H.wFd}Aַj9lv^]_6Ga*WViZ#r0KZ_{eq폗R@?@?wȖ]w:i'vdejѬUf[,+Q5'~$	*>k,]H
?!^k'6CDph^> {hcToWWc8&	nOw+Ьs8%4[iJdwB}w ܔG:v,PDu$D2ec)	hd<ޕ߃n*jQl(ȤhQL{CVKB@[/qs5 'x;8ii=c>-/-M?egսю߆C2׿@D+A@v$Iwմ`WwiJ5y*f4@;=f(KD$](kWQ>RY3`"mfq!UQS*1M|Ig aNM'F=qodE!U*gLBF4B+dcN$e{Dz	_0\y=2OA vFaU?6	zg
>(AXk1l]ąNr?:R0fx.کjͨFP	ZSZNƗ
j)]UlCxow17AlO'#utƁddfC=/zڗg{,OjHe=&A	֜zty#t4Ghq˾rF
2xzb[xG!]5yd|\:aLg7^e
)4[͸[2!g K̔~)ꈛA;1
Q;,~ªfL>質p;CF3`[%'h$d$9R^/	rqb>&c!P/{txM2qlQaǶtD]ybѣ`asD_cjNI)$~#ܮQ?Ty!i'TڟA{":Bڮ<쳞(-X2ٓZΞ&W-\4ZoHe-&аR#BҨ#Uʣ E3ee9S8z(
s_O]el&lT]*r/`u`?zolHdgMIa$ȌO[ݶRgU-MzH:CRCV@h5&[6mO`yZtDŽvoV{$|^qō=ܼsʺv߈t8~b\٥,GW]W>EF$8"S".IR?]ܹ~1KQcȆg+=(,<|XmynsVp# n܈@r
S	T4k]Hݼ׹_w*7aMq`/=)N+P@gJ.qf)L8.АHGOnrYǿAcI5$j/cO]Ad8	]N#\жh
=r_i#pV|~h&a ('(Wؘuw

m$lAªuHkBWP)dVo/ECm@O*GMG0괄}8ۣae=ʍ6݋
,ѯfHGBte {5TM::*Nv㓏AAp|P~ts#x1}8ԎJR+TXE,oalnnݞH֥Ha[^2ԀՊh|"\}4i\d>}d
#  :>01VznØ?s0~Xo_E
fen.=N
*XԞFzhKkpFEDl-ߩg^񞯴gÐnNJ@~Qgʇ3@emj}eSAwFvh%J`Ůh::z/?||Q,I
R}I~veR`j$x<~M'8$߫6oOҴA0dE_ݍV.ߥ̳G`GY"pZ7t.[5ufPRvrymܠ.)astd[rfm([g}oth=A)cgUxP{لk6Se`:6~\៵'yk<~9џQt+HH75-"C+5g\bOsH`[8NPyhp5|L#{TR$d5U&bD~S
}?z܁D`eqs:4
MS~2UN݆&Yle3mLjq;%{'2Zuse+<(n{$	|1ѐd ©n|S`?{"{>L<1ԓ\EtyW&!4K׫}_eư>fN{RHK%1u}ޕ/05}C~u}/ĘӠk)Yue:mJ7_W?JSKҎ#I'?wSY֚Y1C|I[yVO޲NE5J7i5Wdz"4cC韫
YN?JjF1ohfձx@۠5OBQ?cZC
JzQjX#/n88Ql-$Wk!<A2+PyB=MVn?ԞݟgO3&kw&0\[mm ӄx}z(]2xAwen6 
Q|2zH)1}[*<4Tw`Y츋yJ3]1	=[^:	~5{~vlZ[ᗨ[xE)2!=P+)<:m^41v'#
m6Z_W&eaoEg}!C;"pojE{Zq5Xb1b'dXN\))ozgKekbrZXdt㪭QI-*5S
[G	LO-Zm?K
+QT-־(ނOaDECLU#vVBv3mˉyUM=pʐ&ɳ_$kxH{DM̜p4
(\HP,ۖW,/4G$H:NDӷEL~}6Lu}ifh]kh8C{Az}& ijhԬ66Èdք	1Dr@!H^9n)HϿ
H-ň߆w	0i)#ûȶ	sݴ2,R` .|]Nx)Q>-كa1INh`l#d=jWBlma"zqV>T>kxVA"t`R=Phfڿ-u&2:bMVG
SWADL^d\Xb|e4N]T211u7^XkkIg%hX6 w&3OItXG~z&Gd+t?؄Tw2|ttHqXܣ	33^olDZ.wwD<&`R~ELKUvNjwum(E8~ޚv=U{&oW_h+)FNQC_v=m5 
2S횫83!~N6ɾU.)ㅫ\yKLO͟dзl(Z90&}W3`QULe9\4--]ݵ=.}fSi HnlT6a!2dѝ;]48ϊMTM-` 
	\!L.j_nE0p2Yڸ_@-!=n0Äv>2}`ܙs/6mI޵?9`)6*VL	^	dsKJD40ɞ4ړ`_i!S
~*qz&#;b78Gi;`淅{+	HH)/!-
x2`HЀu|3T	Ɛ2 LC$HjT
4z,yw"»qKyuTޒ 7eb
+nc@U裪!h\6v=@McRXu%!Y+`B,÷`tX͞nv32D?3>F	T'A-$+RjQ꡿bWP5'&j1{b'AcrZO/w]IrB&kC̈́`Gk]t1#=Yg1zqoftɚ[/kLCHnW>Zv2t2Lz51	f/+ۡ+|J	B=
~[)HN{c

cNn(Zb	J''iMӅ䡅etѵcyoDZ@B+	)o'蟑ҽP>{OV*#j"f	IvNswR0|%u#N}ǃGkb+KF{[oxF1+L1*Ǜ›p&[-ԕbUJ}iZ,|o@d0T̹MIL-s6_L(OE(U}`]CFjHr*tUĖg+ӽ[%x:QR`.4W$[v0fKZ쐉/_D'6qˁn &Ufv	 :<	C) >:i>A`$~̂^C,ևȪ4ҵqNzH)1?{Hu(C2ab_R(Aɛs?C526V [ib¯[P,p-RI{ۢT[*m.W
y.jr)E:}-ߌթRN_	
x&Mv}DkEp#NR#9]֪S)=~*>U^pҤ?^M03!S}k#I`_MǝlOj"qT&O!.5G-W|{V$$$4
ʌOI/3`翥*!6G?RX?S8&g5,zJ.q.PrmXT+)0X\CYfx{z/@V}&vP;=)jRxr&>ߚWg٦b}['=	jCOHJ"`̸/2]XRu]]#b1&Qi/s!jRiP%_;n;ixw;
wvQ0pӬY&Y+Wճ}O:#q~SR0SSeEBc:|2#_*HVE|gGGn-d֋BBBÔ[=J,lPQp(/
XfTvލu5FvL+16iiM-C
.uY*R cյKV)σ
Q)*FuK-TVtEԌ"1E`0r)	[bg
rcܐ2XZ^/J,o93cw\Jƫo%!1sN񟵦
B|d}a38=A[H>/]D6ȹԙS0qP1swn921	@10jx5:5Be85Rl;ܑBX@f?r3%qwc(Y)N"NT1SaֵQg=B5_'	JApfOBb{!FΆK̯bЍGpxj	/mAwM
7lf>>qL'	62F}paX\4NȻeM1!j`G}}(ou\x
)zZBAnr۬;D^+9nF!n1@DP1J!r-g'#~˅eIIy\cʵ:(l|xt"WD'nMCb 6`q;ۖc;fWɆִ֥oRi6VtC>H%c,gCo]hHVF)tW}q<*tc5oedY淞"	VAsKg~[+5hbR	5dvN^>8i)AʞBI_;"AG|7=!E P
np.4O,-q7Gz-?E;&{[NJ}L޳5,'-| `}aO.TT2=f`=ĥ/atԋ%:v[g+D\77a*d\Cs3B\X4^*6p_l
!ɳu(=͙N>tSF{>=
@:lOƱva_%^skw"-,֎TzA3s
;`2ugClzEBJiW|\
^d+t׷oCfrծ)o>z?al-,CDBL9чy
9oK24o0-+1xWvbp<_AfD(Gs
p[A2v4uma!iWdl#C6{P+Pue8-0qpi>}ֳ׽txqqbV?
Α|"ϴi!!_Msj 	mC;,e1ٌT<_.ZAdwcy@[WPsOeG	`_4j21Vyڜ^
|>7=RLh2g>ZW{wg5ew㯩A{g숾YyMQm
'6m-H3j;+}$B3*SH$s>`"#6u~[3Mٯlp+F]Z|tԕJ5!OBf[C55f"i{evD;>*}]R3/~2\09V]>Ea/ ZYZð!̗H__bՊ,V,	#xF"~D
&'F|ŋНmȇkW4
QNC*df0lPU>
kI
i/h=a0Mw+i\^˨^;
G~0yEl/-;HQ;M36]IFtTpW`f^W:gp bZ!gVI䄄W*je!hsFkxa;I8F{|LN6[,5$qÝ*	ݡX?WƪDݷQsI6: KbS#\al6qLL7֢Εt(eDjJS%ŘÃveHO8Mf$OsL;bJŀR"Ԫچ11ﻌ=ܵ"b^zoԉfٗ8LBq(XI_=kF[eVg<$\br%}ʓ][ jD{xiJl
@_a|겷)WӖ*%>ʋb1KKYŅn	~0_|֑"14-'\ֱ/,-GIS&QJQwW/#K,~˯r&(ҁ"#HWx@SڵzّQx4G/Ҷ%zߛ#V<d\U
hWXļHs/	]Lu

FYz'SEcNI0i郗yԻ"3V퇨XMφ%"_З202&9bGOvm\o1\JGG}Q"bR)HIruZ\nroܒ?[|cjy@X6g:QN02ѝ;'xPPpכ/gdNQ@=6#+O`NG",E&J.`fw
12CrDJ#1B#`Ԇ'& >MIUWS$ί'leU$o V<:_i;
E6r[{$i6ǒDP=@5#NҹdahM^A)f4͟VE8 a81p?nk¤B'jQ5Als̗,7أj~#>ϸ/قU%swgYǗ41Rm9' #TRMG}|MZ-#ۨ1U,:7W@i@ؙŹ.D՛B	-Td%_9'0@GC
NI05HE3Z\f\{+8QF+#M>vΏ
&tTVEM#''"@dXs&Q{˔[mj%@8	ϩq?n1@cq|pG5/ړEɓE3¨1GT'"TFD1|Bj#kMW뼼}8i3fL*UNŘ][MhD
$"I~㫥_g
_KF`|4|Ϛ*trI
:TXTz
Td@J>HjեZ|]hzbMqA\[@vދchXژqcC֓
+	}~ݯ^>'S82xƽzV]6ʀF>Uc{FFbN~DUjG⥝E\3=Ԛ)D
?OYD-l/o6nhEwY͍{b^RmF*btݝ<%BVabro~HlaFlHUpoTU[{iMJ7GpH8	ZhhTX34V8r9֙5AOKn\biz,''K/dEc&kDi}m!mUZ/!^4'rUU@4XQtc3Y֙B &oԶtlj/;=r2f+g+Lt
Y3Pl"V%UVE52G(j|/!ebؼ']TF-?zc&{o`0p,6} es%Ȁ(ooB=iI3&q"r|yIE@NdD=u2^N+@}ck{jߚ቏傌@n`lF㓘< *
e"[d3oJUC1|#Xmzp R.	ϣ
dNb@kT\^ۻh}|}|9Su%.[695c
sȊGƙ0X%mYԜJ&$?5JBB(1"}z\
xyjIh63>oUJScQ2ef]pҽN(i~ޥfVqzSGWc
Suh:ǃ+$ؕW!Nވz
+ͣ+*|T#iJ䷖xᰩu ,:%%0jatōͧx)H:9Xl)YNzVyͬ:V QAZ8A	B5uuIOumP*j?rW#vI 
04	3S!pq.<7AȍkIִ8p3LYǴBIlk+e206b\0+[
 QmX2W;q)kk"}|GA5䳧GJ>t+hIM_}bʫ8\nsDP{%?H:kݽMlߺ:[R5CXԉ$89R&'L!m4$O	NK,DL|g}hXjG8JBHfz*J"2Ao*GW6{RQZهwل"ZhNgM!. >=rPr>2CWZIj)ҢGe`$ZY״1
MbEмۃlVB!Ij[`֟mb@_?x^N0~TaUiO))-k|s,"فAN5jRo?hS:mLCQqd 9`p䥡MDCͺLdP1r`D,nщ)dH8PJT쳃y~zR]2ҤJFkg(-`)qRT?㴛񇒁eM5MGV8r%j"!үdZ-˙PQ۵݀zm9#,oxˏp6´vϴ{h)IcBKϻժoS])1=ׯA4dr蚨Ϗm[#c,`;SwYiaqRYޔТҝ`eLD'tz9ƗvNG3h@0n?!Þ>)T"|4F^/Mtn7gFmʭf0څ$7,Ɲ׃':d{b)zx6tTJ[T.b]ꂂZ)z9ӂ22^QA%zm`g#e_omڳ >?|&0-?l>$G߰A3xx}a7\j
fgEJ7|r4dE7.B)zs$՟Pt`ذ² ӯ#sƛL#x(n"#0z9P{F'>fiPFjQؕ4:BIT-qֳGOcnU]Qyns%_'V&<s8뗯)W1

}>>ߛ^hZu~*kg+CT134P`TO`dl	{γ^` 2CHvg
Mdyvȋ)؀x?o9/͛pFNǥfgq
glњt1Iv)7}e7hHe;mXd|~zo+3ʸK;S+-_g[^c_&kNlh>n$oEerqQ-TnnKe &OODؙ-$\TWE6;{+ᕃ)D4YI.eȂq
:RrzjgwmZ)k˫r:]0i;E#v"|>"<1=k{lw&-fxR$0ж)#\caXBQc>hl!{Y	$uSjS^,y6^^H3	~ߊ0ZxsAHQy4p|R4YvdbA|da.wJjIϜ`!^gMoO`e"حWJufĬoq¶E!Iyx%G٩#ՓZEp?b-[@1\楟ۥq/"!OmfI@gF1%磗̘EGA:gE-D 썮=,B3CJScIay 8WX|\YoIR@
*Lژu*J|Hzf9T)c&_8hlTŝ-[$^n@ ͙ɰn?_>!i^)*E'm^LFu\Z %׃E讧3FI3uNDMBhqu2ʖ.vQD4`Mk1෻	/'D'Sؒ.^8c[bjGQ|ᬰw.2J:vݒU]}No@xu(yixL|'8B#0^ɬEn >KƧ4u;&Kr&r2:W `Wg/3މE'^@0.Ct 5)+GAq/DžώC|4KHy5*	ٟv,OU1|bn{HYrpHۗW(S.&f ׫cFj,h9kqP͟mw:LyMVbK,v\dE>gtPg?#k6+z,hub֙NJsG?V>!D7JIm=܂ZQJ<+h1#˱1qA )<	RIQ2S6!M8Ha:j!gt1p%ވHr;@grTEs{LUJXDת:3XAMFXaqU$C%t9%a}:ŌHD0Acf?3۰Kz7B*bVWM*B\
-)хNb*qA
yQt}*KqfC"t9"a(*^)f\o"'BR+,ksLs<'>#rTכ(+y&W	
08YH]W[ϻ=V!wFV\;`1z>cՒ^[j>/	S4h%knf`."22sn5hMO;=pQ;MvJTK)~H|_hNǰfq{>(iJQYg8Әv?b#~Ruh:l|a
Ӆ{wrDs$O]*bQbxB{bNoj
Z~%]6VIR6"#!u,],hk+Jjb{6g&[h}'W–fV*/wV>•x{ZX)HSlNɂy]C1E$]YfrmOX74Vr;[J+,>3'å)~W_Vx`K,XzZ7z.!F9[cG逑T}FNLFE&ș3F-)0\=Xud3qֽP6
gj6,x
NQJp?_ض7@n}*dɇ$`mj\E"vg8c#9i2Q1oȉHY!ЬILk8qI~8}B!/`X|ZKW\Q>+r
?1Mf_L<1 '޵S-AMSzAV<.LmLB@i=''-$4Kpњ}%J~ޑ4EQ첻]VQoڷ?UAY	|d!Y4P[%ߓ@;~ooQɼT%މVa~ЈKa,ju/OЯX݁ڃ(4ws~oMH-Oq`Z%
Ptue[>šq>Du?DB
f0L}ގ‹v3HmZ^Ep?Y?|l
_}S$5%fXyf&'>iiW\(60`8,w+Ee59&!rȒ3|Pߧe7cg
k2
5&K杸V"1\5.;$jϴ#0$36kvv`A1A"`]kPGN3gu!HXs`47IkDr{?v>C
3	j"CPh	/M*	cq[5{٧^|\Rރ8C)}BzS-L[&eX9(fYwgfC8M\Ɲ?$A;f^
Z hD%w!')meQ,Â@Q_.9o3T~L;`YV3Y%HpoOS\9؛+Z1s;:ȩè3e	lD%ѡdFAOYgHgie=sM:AFW1Nsq;ҟLQ`	#aL(0yxn8mWTװs&g
YIDW^>rxyH"^ç>.o2N[RtzRɌg㳒,pRsSBҥ']=	-jP>ρƒf.gxԋ F7tH h[_P\N+䁬̯*B4׉ΡAcd&'pmp@w#Sbb-/{ò>q)ަ5wФT,ȧ!Au1K;?u;xͳŅnצgQ@-O!}_1~ӉݎՄ5@ozzkH[cdO(]N>}11#zOQRO
nCǔI#b֕&/_3MA%rsDXX
h}џBSԺÔ(L\:XJ8Ӈif%f|R>!@Mq0DWisS0_;.MU<ŸɖZUR1:9>kʑX"䦏JXBHhEbCsېhDT8x7@G*;PvȊ: .aYo|,ňB:N_1voޒޕcN%Y8j
)42Ĕ質>Ӑ"/
/j#UtҎ(W:¢NW^9`*֗5CID|43edUWS$q=Ό!W~qSlC%}L+iD<2կ'%a_ը՞H&1oqi?c" co,="\/||m-g"F't|,[vɪ26	GW]HF3oHfg[+/qFO}ԧ~|k*÷+,(IoQ>d$B^v@b6	F^YxM5=&'Q	F+sO|櫈h=;"gT?uPϋ	u]
i|czQkM(x
gié_[+E̓~	<(k$ulխasxޫXD	yI67G 	VI@31)nyi*⍋!"vV<0H3'52Pr8@ܬl4oN(d9'~Am|I71V;Y.r hbpQ<$rZ㖭Mj I»X؂!w")*h!~ǃZ\ODdQܔK
#6.ׄm'g_0mX㡳wy>~$GbVUAkȱjejya"HTV.MRI̕xOӋPȔA!݇M嘥qfw}nfpUVeCy*@ݗ_WJM:N"a{trXG/005s¾R0NF
>&DB#+sίl^,O4)	@rs0$Nt
K]j+n&7Q&~3ύAާ?O2_Q_b:cCo
0ʹٽ;bV Y$IVw#bHNxo!,7#mhx"Zꅧ:f%6~e]x+@Y{';SjC#7-o3i_9"{@[eًMCdHYb7t)I8~1y@߹KLJ0a@XpxDRar{ǽJ["Ϥ;iV aV򧒂!OnQvߥ
kehx$t"늀e6Ŕr0D"&x
- ^Xwo>v'5kFpN0[mۉԄ)g
w=!PQ̽H1f((Y.ֶcAeƿ/X;N੮~Q	E0^B4ڹ7Q>9nvd:qa" X_WQ7dh058{&O-9]>֘슾ˆ
mDԢo[3*05Rkf\y7afFBΒ'%x¿2P-x
qK!i[OS̏8$7:mvQԃ1]{QKΗg6TJ`r|Ȑd
|l]N%Xi$!1%eӊZW|d̑@И#o3"=EbhN8?O-JaҎ5NTtYbx:^=|m[vzH/kM7]&|l̽"|89S&J=N1	GbUak]22wg^"05h(uO"ޡ'Bg+uNfEbCxy#Fq!y7'D	r*5[VC˯b^4#2I_ۏ7S|q)Þc7?̘8T4p(
vDJ899et^&K}O|wckxk-@N|	_3\v6%FI_sF즐Ӻ)Tt,uZ_u^s!+ ^cG4Ѳң.ȾtH&|c(9`6E8:gªcQ\9	oE},Z{īer~݄PX4Sa+- ϖecC;	k~G~V}Eә,e_[ɧ'J-37S^r'W+؂Iu4*ڔpqٗ*=4sV5=iZk%4;^L+ԓs4{~Q%T7WQD/#?yQf#)	GK.z=Zݘ#ww(*1279prW	*1JK8MU¶>*t\fbc?Ȓc=~j)5¥ZD$Fe-AʍeS烐&
hitw3dySa}1	mY]8eL7G	_y
;x ޏE:"Doi(;o` 
6U4gpgެm=y׬BX9\*脥x8!Jԛ-kh
Q*K릚钂SL]k+/}
CU_bd _9[O>H/4$j(ɥw>\^4QBWjTm"QVF<4@ejGvKF	tuf]~DW2kp^)^TaKAtCy'AQqWT(KzAEhR|7iگ{$ܐ3F86E r{sHcf@Ho| U4z|ZiWiz=sv0RP/{i[9rYnp
^4GYٖ6$\
u 6ƒٓߦe
9Ck9_Jp|>Gҟv&ÝkvTGHRl:¾eP|oʘ^`fVV`5(

w˫VIEɿAfrkqDȜv#183xbpz^7ԣ8)L}8M~8oע)
jr2:FQt]TKN],͉`&wyVFd]Q!09FgpJ*A#P[tD?Cu]jLJ&E@1-H"LX	QKc5:$Ɉܚ0̮B	԰@E!.LjU[5F驰t ě#9Ζ`g\oi,[	!`EY)ȭPM{9fQ'VcgmQaVTʺ9xm91c5x"3!4*uY_[=Vk3?_Ỹ1$ŎBvR˜wU1|(lf?cwru!F!$b/HnҮ6d;Ih.Wme%aX"Xr .ː103yy`uA9=„~ah_>b8ԏ,NEJeUw#'GF`|	?s6V/B/<|pmfj	%+TQN/C#siPR6_cԡ|N΃O09LJ\ n2bFݢgG?~fu:pydr^O
ؿzA"rzl3fMgl`~?SG?/NJ@?~Kv ywҴvGLRVrZj_!-YW(mF@JS4c*93Lm:LKI?o/SrQh ИnU.Radmo oΠ![vm+dNhXH-,gAns;lZpc楌^lf+.b,c:קS(")%h]ez+12|@|:4T.0DL
=E~v,`N5z)6ܧܩdAVkG6Ǹ[R1ZI..]erާ[_Opkh=̂Ųji	~J(5o`:ӫ-;IHB}9-
Pǁ* M޿oLmDF335ppE@kv9$a% oDF Tdjsiy.`F+=Ai},:VC%\̟0F]o݊V>XӖ;n0=V#%91Cz`C
ϻCbs/Zwv8(_M!2JPdV%HV|	O|KZVFxKwjN}ljD{vy	ՎPz4F ȩTҕ6s'L.ުA`_U}GW
Ę4D]9rUq;_&>,gXK6G[շ>:A}gDP*KjV-XT]Xv.}U@|)$'@mGYrԏIpӟ䁋KM1y03^?
Kۛ'H]`b3j"̢켨T7pq.b{JH
@^=MjlQF@lW*¶c$~ؚ`HeѳߋB9ړ|;YR5?r0}D3|+/r"34bX&SΆaUH5N*'aE6MZ16DPԐ+]dbqMޗ1RiI=ɭVZjEvN`GL'TR"iGpF)ΒE
@D_9rf!ԓMWPLiKU\Lzg~$zS*R/mo``$@?"'k>3_|]ԙZ΀c.G
cڠrpR8ʢ(@d<﯄M[7ѭ3hrH&5
lhj-Y?@sXZ+F6-l;9$E&3heρ``XNC~m5sLs'p|㾤ٸmN{e2X?c
J-ИÏ8ͽ}'3_kˮOc[nVI
p_t.pϓQ['hJ:e~[Rc( S.iHFKӬ_ߌݮjY8^^VʀGn	M$lOSXoe||dZ'zz|8)@83=Ȁr~jT^Ľx!x{*,LYR2/҆Q8={IYLJKX_6tNR->(ԪCU^,mx$aEBeXq6eQ,$6kjd"bsI1Ao`|_ޜ-,k	<Ȉs#9*%Csr'<ﯷGx@D^X}gL7|c%KKI)`s͢:3"/	}1~cn.LFIWrVznѣqFY
-V8s?f9;NTYyA>@`L??<+p+Cf!/5F%94Js5|Phā~B>	0`UQm1Gh_1v?D^6a$,$1lqx>㝀J
Y;JrR,9b=;#`-YXqi4`rxuSg9`DnI̷so_%
(+~^	x$ X--8%DCS.St5*p18B&J׬Cؾf{%`:p 8>/$&v2y
Lx*TW,@]
+KECsWF~PnН16f8^SxV	^5K_*ZCT.;{cc77u|	AP}Cʑ7?ZCT8ǖ}%`x2zP~=އU<}\??IA"X<3_#&) )Y'yd[eS˞: ؟d=XGQE[k/O'HdغYQ2>dy54TmĒ(ɶ8ce} 
ɳ&8	R!iƖz7|j0+`3l=CZ65c?%bVE
	#X~ieHە0DuӶKd6lǞ*{ww?c`yg*rvgn\ui؅7qEyErSv2<*; }YB@puE^iÞ}P$šd**dr'½u~	f.bl$;ΙR~MHTqG2i?݌$Uj{Nd+NgWݙiT\(ӟ#H>rZS$0 t8P) 鯇+IK^]Dqɋ.Qr<,#U>(XӲ>Gf8$O'e^V|%֮f&dٳi]NrwDbV?m+#F= 0-;<ڹP]`dlM$Xn/i_Te-:4f,xkmOVFsM:vR! uő1UÀx#-
+Z>h{Q&h>U
&7R'6&yVefx$Hum[4E9'g"Fk_G>z~S9mjIXrmǨ\J/N.#⥑X9:֪AvModhʫt%ʰ[ |#61zx` S$ cLӽٜYPCjy"`1܌}~F1?K%l Kd8pbwH8)ԿGw̗`cf񱴓I.ŇޥU
:|i[YQlXG[Tuw=sn ig6ȶ6LQdF=f„i͆V#֮	~xa`E:C%ic%۴s^+
均^5Uȴ?"tBrgn.{.HXW7_.9G	&LgE${Z*U:0XP_	|~3&=A8.pzi2]dI8f71G̶jsL4{A89pMwn8%vtGLجuz&Rr	N|9FDn@nC::"u9*jY^pʳ6\b%^qJ%m>
uבJu;4R&0hL
|cnsR-f?ZA,ώw S`gn
YNe63zF7X=">6- tde܊!I~j}#_X&q˷3SlE!p$1sZ'MY8	oz+='@kD|ɒ͗.ҽC`ff9 S*Kf*
۶m,{3iN¦U}tܜg ~ܩu}Y=qcN<@iO{BѴZB|M\b7v^6(-T<4NLWΤ
*HȌdtQͫYuĠem;w4I3ȋK\̯fuèV8ٰ.$3@h$2FH)l2naP_ҁ񈀦\	XUe|hYXʆ]KrNQ>QFj{(a:'h=U|N	]9-ؙOVXL7pՒY'
NBQ5VtYEkHBb rg"<&rաar4ˁ&=3s~/hQ1QXQ/6%fA0Ŀէ֎Hf!x(43PE7|6s?,Yh
Ze4׍UٽE.4 螞=
SDz쇿Fn'8%]]
a*`f@rI	^r9g R!
`˩jzt.e|Ḁ̈̄9}JBN@2S1dTnX$X7;jjBJmأ"VMVr#s=[w)vޅPUC δfJ-l;9@}&hGlGu ;>c_dfJ]E-'tCc-DVRr3y=TA
G~֯f1^8۟M%FQ`ontĔT8ul?$@K|e[tvn]pvmloíߐx{O@F"`%m2hW5LOAi	1	c׽ЏZ[:lqC/G<(AմYUdf/ŻҴE1$Uwf˪
 mK0hˋ,0|?	WY"/K
P6ݓn#A2ɘ	5fs.{U	'uV@>UY$qi%
q;$ 	>/K&F0CgB?RBcg
"
m耗.CkcAqXabv~asq]Y@g:q^g#"6	$ii2dUX85ŇQY-*,ac*p=Ð6=q4b<;ms[P{VAmoS#( p1#>ʴr7#*=h_?S-Hhÿ(b$).1N0qG,\ 6|}(Qχ!
|Ym8BV'"ZW{]t1<-iKZn-IϋuubYׯe4$UBFK&KTzu7&pQ`K
4i$͠^Vd˪&⺑Ǜi8J¸o٤rNvX04Sh
 f-m/5wE/*)W*7E4jumOeb+3V*,zVd].w@ƫ)!̂^DEtL8/@3sym-, Ssnk5_CJ|K*&as-Ib>bT
L	/>9Н,]ˏ̀o'#c}8f/sg?A?tEe4'e:NΏ_s3`Ie<]5}BYאAs-{6"Y0OJ𫉳zXL\|/BD]-u#SViGjAj+k,xq ~N:85}5OtIB*)(j87@7үv?[c2#[(|.?JWՇ~:0rj5wœo3ʆtऒ7[kb%2Ɨo\H/фdgj3ٮ5E?)c@嚤Q[f	*#s^@l*TQ̓ͅ.N8o5,_qLum;uGR$/,UN8לAo=خpjy;wہhpAγ$ÈYKrq
)И^bv	|ҩUwh΢В^nDtҳtl4;lFMjIMc/@-c8cY
B)e%o.^Fg#}1ܲ~i5!Dˆ.l}^Kztа6ʨ0CN~atYOL\Zb2Qˆ0"z㪽xݡJCCXܩtl1m%#]5Li^J>",.?()w'U-w?N'Ih_yi-aL
}(E'Y@Z1TF鱛BwAx^5#b.*a6ޏy7?i1I_ژ$-Y/xR\nXCɱ#GK1!ۖh"+BI&6܅* G:v9ARzÀ2~d$e%+nmA?6bjNk$)e'鿼)ՃQdF?$V"dh%`JM1sߟ|gkmn5&,8ƔF5-ܤQ!*	w;rxc=,uYL){µBxRVLDR/wN
Ij$Jf{iHrS*l(8F5}y|?Y|H.9M#`ܲm6TyCWV}_=&7k7s~b{G%E(	1]{>ĝ5-ؖ8Z/<b>ta:`a[$sS "SƁ-0/9&:q-	5|a(PJCmE4h?TXTz:վ.J?>כZ@[wN7rv{RcwPN()Jjw	\T\n-_14p.uo!4A0~%"NeDł[BVf2P0bfͥЍCcGűd?d\O_-bEQ2][qEZf@94%f u2˾>j EH%pڔN 7а[Z3r/W@3TDh_Mvn:<7"U6	xli?%&H}-0kkI(@툱ҮALgS]`p5	l	 Vhq)\K
'Li->8`]R9.w'&	O/u\
).!PJt۱*JLmpƀ*>ua
j}ͅScV`yfD4a
w.*2Q`
zKF<cdSvSЇ^gSZC9vheACDheyO#+;.݋le*}鵼ߠ:>aK*0e/xv(]o1~2wH%FY#m^,~\
7\2/
p39!{P42q<='Xo=JH}6͸~鿯ߪ6&+S{'Z'+%Wřg}kߕJf$qV.)WS	cH	tZ<ShV-/9ސ-O`~M6
fuczzTv}[sNEp_JO
tj{K\]Đ"Z>WcBa"*m&
.)j_X=M#˞;B/1y~4{JVGo&޽ؔj]ftpf0Ks\"9UrFORMDCDJVUINFO
]XINCLmemo-sv0019.djbzSjbz;a{&E8=yeO2lOLO`B;6/V\ӵ%W6$rl0Kv~8j!WIУiI$HNP(~=q~p%-!EߟW̱;ʉ<)?}`"~mo"cZF$^,CD
:>¹+qJ].CLB@O-IYZ͞ɒxQ-@ᑣ(ZY
1Y2~Ӽ\tome~`zq&1e%;47R4Ql8*PPשRs"Ůo~8Fr^?qmK=c|iEb-iU5sy?b2dPia9!
Irxr9[	_PGFKM}C}C\83\a(F7-w*Kq-lߟNE_E"҉@89zl "v4_ۨ[Ǖ놤&'ٝtc+^sCr	Dz'ntŗs>43C@8Vʑf<qG%4!Z'O$6Qg
sCbnԣ߹.ڦdMiR5B#1\"z{4%C$XPֶ(Fբś4#yZWp3rʹǍ!¼/if9+6y=1Nn		c.Ka/1Ҩ3>KY6T8A-H%a:GStk`K~~C9qR2jI€AwӶanT(3"/	Y!g
`%
QUAdDK\h͞+mQO
[;H;G84Ʀ87]C7MԺD.]y,`%RљڅoHZ\;-ikuj6@$ee
R|[?Vưg~F"p7gVĻR
8Y֛ҥ6;x(z^MS	抌YwCT>B'Ta[>$~@h bZzI-:oԂZFdiIsW4c\1:g{O}PIsێJ@%8EDV=r3SM*}+I-B`T?a1fPa2/1;rMY?EK5۰paPa_1km#c+'o	hIuQ)6i*.Qbv_j
&bC̴	26I$.%ՠ`!RmջK/dF7{K=Picc^4Aqys&]L-U=vN (ak
h귭qey-y^ʠKv}ҟwB'+kÇsqҽl/(/W.jD͙EP~4jDg,0لjX>cܪx髑(]۶n=Ƴg/+E%*=H/5ơJ(,#Ml7VY%)F*l{mH	ɾ\cx09ڄMn-3~Tp!l4v
cUI~>0w(iҕ,S3H-0j#It(D+̸i?{Į`_].%x*Ƥ`=9Rmqu]'xi
kQwW+,;eFOM8]STGNRbS}SqL3p~(lT)L6o #/b[O*V+@/N֓OmPGđz'"TV,ta6P)
oa_Huh(g*}
C#wIbY
n-%^}Mf/9	
h@.)9Ā!yeK#z#UDnu)]:V
+6/C>
t1'Vrj3s_G˗dP-'#N>s^;'!*MpmJ.Z>dy1nӠG&sjWdRxo] uGMJ4biPUw2bF"m$tŧg<qa-&$#ʚvk3EOT3BVsөg°OۗWlK]=}Z2!W@Q7}&4ͦC&sQ-+'(=qO''Pu>2fj+5PA-Kk;|‹H[f	D8w(
;}u:*!TSV%M\ŦOX]ՅUǣA#]c/_ 	۬j\ !!3e@kklRO>.eޘ{Mb8+O(^^+g8ō
}FV-$`+A8Q*6X_R-(>YڵwʛǑ}% A~۸5t,P~Y	ncsNҡ׻MRNRLtu>.gٺ*aNeS"ܤKlā)u'='7
XH?͙z6w2/x`8RZ Jˉܓ#fS"^W;In!zQ%`* 'U,V cT6Pp;z[&Y&s#]AS(T^84DE~ɊEPW)iZo**2SRemh#aHf<*sJe<$zx
Rn0989xH:9_Wr~#ab9PvAJ"u

^FnRyl"W&w^5ڡԇ1D&l>Zc!GV>l9ɑSy eəkP$>vX
M$z‚DG\OL+5ckd6Rg`?SjΟcDCl,H\]LM`fG|*dXmk_LéikWAW+ڑ޽
:F&q$p
hcb~T_#*FĞ}gd4c"j׈}ћF#u["(e%Y֮}l=?r>2q	t[|ܙ7%ՁF!-It29R{7_M	8:{BJ"Q%ž?3%!)L
;6Ζ?8Tcˍxc7`3sQ|݂-oʈIvFypEe+{Oα^ئ-^Tk۱fPitC|nf?H.FUȉ?dq&;c>r?sxcB#b1(Bl$@fBFuͩWZgμSFme	;i+s<@ theNJF-+ziyGPPEkOZt	dFD_ &cfÛkʲFRzw$X>$xTPC_l{\BpexYڡQ:O^
g.炈"JAeO2#M檱7bzLpݫcwA	ݴEpR OcC!;2AǓMA_mD	>fC|x$3sQhhNA"G(Zv?
2~#7
YGԘBQ{,A$N>s9*r{_fS_&;?DD>̿KE~c:{6"^UɋM`@Jg5SM۝4ovNUTn]\tj0XJ5b:UkL,d)%?&T.$բ!::t-\_߫ʦ91K4!ܕ/ܥEn=:'zUY9 5kZ~NaU( 2^٤*W>ˊ~r D0zȤ`Skk6=%;FWPlxɁT6;Ci&u]/g|ɻXt\C93s\ >R)h#ʓXk
bkY^.s^n@uxߧi:{? Ea}z%Y^@&Cbίbe02n5	m}c!۬PBGFcAFfKBS	J{YlXxR"򠄪Cή]r{	ScRsVe>M5ul|
?]PV4ضf,LcΤ_4{_tpC/;y
wȡN7mؒw+h|֑۪¥SE>VFX:;"la|Qԡ$Ypـ
:}hɘ۷*Z"j#F-0[ަ';Yz,@QMNVt!ͶsDbZ,M
NL?-yI25X:$ggc[+۲LIdm
xBr6@V/Q?&=TLP͓d@wo8:?*i~XWN2kWg}J(/?Wӡ	Bɀ\+(]B*tFUy72NM72w'B0tuG槲f *UW/PK7.Z\
X#`Y!OQ]8ي\XЬdOcm妍+bFLdIoOHN{-ڋ_8;IsnϜY5۰.Kuߓ?9<(2~L`%:Yf؊@]Gl%i6H,$i\o$UALe8d>4cto=ܔ'[2W|Ҭ

7R0Fj}:dvKHi/ѥA+UT,(hSr0(M=MhJLQd̒"J@)PKD.@BQpM[oMOWy41,x(6Dk' *҇o	!aHTKy/nwiR>FxxLL`s0f^FG~*n٦~beNI@
'kjG+tbv}R
j_)ъ. -&m-;x&XͼjtAV4]o@]g&|={(:/:BaC2rxAc:rWWD7֐zИaEED`h٭U{h6*th;M ?0<}j!g?mS4$mzԩͳ퉌	0A~THs{>WE\GEBFPE"-砗~,eobGc)+ﬗ҇U\B>zh|)7[+)W齬mʨ)cv+eϤEQV5,\A$8kia]ր'~"8H$/Sy54w1jjOګ,,K\a`~1),ĚzWSUmnո"i5kxX`pR#ʻ0xc`+.4^G|1,:L#ZasPgJGURhMVʂh4-ȳuLy|l|
wtNJ!=@	&L/o2I_ڳOS2FkryoŰ
'$51 +VtO_议3Dֱ!0N!"iX4b(\_xOxh;6!|4|φnqy~#՟N+p[5ђgG:x"A'<҂~q_
)Aڌ	:Ťu^);@r}&\Ś#|'l]طkpoSe
ay?W}[=B\Rk%@Acp
HV
*`殼1QkeY7L	Џh/iZX	ʚ$'HP
&T\1Ӱ$SB*@CDŽ֨#?:QYԇ|`BȋPܱ.k3	ngтszs}\{üOlX/E;TYyVX!5n-xbEoww
.3$FxtkǽEWӀ;0|x"fwݙ/领4_eGħpFC_x0p)o0He.c)9Lox}=^ȿ㜶&	7VI큟}g*`d=^cMz&6v]_$-ZCqR(Q%b,hC~N'`}zR	
Z½:+U(T@^D|Ge$l~[.^̶Hohf T`I(pzHr_.#Ije*=+>GܝRW߳'܏3QdZ#̇$jpn^E8fatLr㣣IL^?LR:NGmu2IQ
)óMVUC*)e𛥇҉7Q6t@;\PzV{>>F^FKm㯞LqY 90hX:>
|}m8?LRHzI~3J$x5z	9`yrt;:5Q!0hWq@J%$tN9*H	H84Xn@T"k׭*@xP8jcOSCrƝ632;0.0WƟUm>FpT6I,TL3P9:ן-^/iPs@FP~륚|uI=Bz})#C \z\y
!$&rC{68Y rK~PSp$	mL}=ƃí{¸d"BrKl V
i}P?R5e0LV-
",~/g
>uצd()ig6;B
\>vy5P6gӠC"ht ? 3P+$.z(Ȃ"qBT歛vaI՟ei<f>˰>q/+{GN͓?H7%Pk
!,zN2;z
5r̆Z)*CTv̔ʌOOiagrĕ*@ϔ,Xպ(zɃuW-2?\8W߃tlb6x.7K!a3%&&/[܈oطѴZ(:>	)EX`W-R04oL2)R&?{s%ҌVm`_K@.GtRp&h/mP9rj\IUҾ}6	ϥLas

t!݆L@ab9)J7x8L;Ew<&,JvP~9axEOW#u"&.^IoE7?k;ajOtOԜSfTaי}?m;0MYIhLZ!CN';hA|S1L4Y0	LK[AXq*0{'>l^dWRozChEr:R1W&gW83H0VA%?P4V*-2N42M\5ؼqضk#`|e>+˰hXҤƝeVO.dOΙPaCTE)jMCqO'}za4z#27'(`+_n"jf}ۡhpĭh$Yw4hѨ'kőVu)D]]1xS=O-]et4%.PVN>ʉXͮΛ/=.ȷLϊZ\FjVH,JD|WKn7\6
AYCog	
ôIϹ U$XVLAs.+fh.S[D-srKW>ɦ@T8 MX	!uUQ秴jezYJE"/ls] $"mE7ҫCR*Ytie՚n!"/NT:/mAϝz^rCGS(niɱJ%˦omDW$0+So:>+R&{9J+8'ю~Yc'õ]:bב^wPlawADFWyru΋yuۊnYL·J9F|\ZRoh&17f6K_
/SƼ4SH:;[TzΈSyeCQJ15,!NXj!XhJcG)_J:rNMȣS4%)@^T[.`=6<~[f6&uv@wjsE
aCz9cpij_gl?}MNLu\笑Xꂉk+LEg>w<`#SB0)qYhLjҽl.Ƭ)a
{mkh5AePez-?ͦ_W8a/JP/<0lcBdbL<4ݿ59xgq\
rBe@Ra,KTj]t,zq[aTXTz.J?%ȼ~>/dR!\ٔ}~I^ so1D|qSq͖3R[(P@6iA_M6PȏuigzϗuQ+X]*ZVS@k1QhчJmJC3iѨE,]zy"vpb=tV/t|tLb&Ĺj1R7U㡞ߪF)	a>jGrB_wP(ִCռ~aě+/3&Ob&	U:,LaI'@2c\u6xJ4D@38#<&|`UhF;kZƬФqS1'Mz&w\QR%,k4Q#C9ewQ誗
83-%-[EP4=*9繡5DBkEN.8 zgè椎o>޽9W0?rC/s	>,6r_bktn$XꛨTdu݀f_
KkwgĂ_)]v!_z"G9| ۿx[3Ë41KPz@^'9=䗁=Zj+\e٨ܙӎõj,m	wl'\zD1 ApDu=aC~dvsٍ@4u9Q
=ǭpAםT-((pI+x  AOx2@QFl#tpVwU pD>`ٖVgF風&e
Wf	7cJ<(-ɷ̻?B4_9ƭ'ͅkHd.YfO獢tZm	wQ-?"
5H@i[
+Nzǒ&vUċc;ΫD<;]~j'Ʃz)	L#=C34p+*/L.K纳.tNJl# ww2@'w8ganHcX#\q"ԹFUr.:쩨NZ>|${0}`n	l@K7էl3(i[[WG*~mf~j~3>3ikA!4З{9W㺾@˿re7F>L"_)+3s̏beϗ:	#ɐ6"ZHBH㧇9.=PL,/~:/[LvWC0R)12Ght*b'A&76b=rޝX5!|
@_1^,,k!Z}]x~o';2f@uBqXb4jFo"BY>K@Q9f35qLeєYy@chMFDXNC{Ь,k40X7  e))\A6԰!Pp!mlZ[UzOGé%8^ncO2>]e8vKIrplA
Ď!I`ܩ8
:N%*Gߚʕ%-{L6uߦ5%9F?0^)3Q5Q1¢JjW\idrzg8kmF"eo=mJ<95E
;(ӥ"OQ9ǧH_FORM6DJVUINFO
]XINCLmemo-sv0019.djbzSjbz0N{&E8=yh]™԰b
8nV2KzN!ʘ[\vL=A_>br@2;{M0
YTX8_,mW&d]e+Ȩȋj=ʢ|*.W̓!N"\.f?1`Iz^*_߽}*&¯Yw%jbF9	׊&*4	j	f\*k=?-q5^N/#=7oq_ŝW`ӹPRe$/.}Xybi*3Y<,qEnNﭮ. [򋙉܉~8E={Y3u):ĶbnnH#o觕)9/tt岭wm)1dƧ~˺Ը(_)_:|a|,k8<>4<,`W9Qqsq	I|X𭽋3H
	0bX]˹_58wJ`fNR;ꇊ$H;HHFE֘n1B]zaĭ]}0:wU2+&ϼ _δ
*F	O[
᳦&M=+#5)/r7F +6gޏsѡDv}8E^J<4,b|!g&yjnLkgE1=/7X'~E(/U(J8v_T:!Kk	<_<|!ΩN/fxSMX}CUէ"(4%.bIZ邞?F:0wV̧ZJ&[؏d"D@Pc0U|QuJ7jU#b |Uufw(
;]9`"}+rN*h?_1*p
(a(A1
}QG'dhh1
d9
rpo\a|#%,&Р߈Õ?K)GuspQRxbf8w5lpXNWva!>}Ip-Og$bʩpͫ;o*ڐ ZEs71%#ػ<`yc~
oaBwn˳[i6dZej3gHЖkB'`x[&ՅQnF65rv§DeU%4ϛtLp
9LQ
2Ԕ{K=I+[VdM2N#._!֍ֿEtBK{~eW2}u6nZM9]؋ vǡ8}j1
X/<<[G ,xF9c5#\_n}(v3.
b^voثKpwΪb6WV|̝#&7]/88~2	ICݪ}4
J${TwNȘŋXX㨼
Z[_N#WʿD
C_W<'	!UV؂ykfp*xa,nL@_.jT/ZxkK\!<4{t4n;|cOn4a41AM3lĖl^/kKIӵ
	uGjPX3'NES1hζUaf?ҞOo4@t\Xy{+rRĂ(4`p'㶃9FQA8_%)SUWd)"?/u^@I&oB4p9SCڐ_zM
$'<\B9pY꘡Ƒ~?AEY׻%[21!_C^
KaUr0}4
ydDs>o|ޓ_'xx~_ۊʥ-v3:'bd	C";SgGAPCKC̴q!4(g`l-ˎ/1J4O¤ɬ0D!'oDt]oIi&#X eHrgWKIk)8=qR%{7["#bB#~bԱlm./|o*0ʪW/܅_K
]LZJi'SwwBqPT?Yn7jgv/r@@ds//!J=/	vJu_y4pMOTḆV.TT]mvY9tRp2K3F`19@?
Ϭ3g+BNʿlr"r+QwΦsw^D!Il8Zpd6ͤ3GF⏤27
Smy7dJ/*uMıO݊Zb%Xhȼ(FHr
MO
Em3"L1!%8[^6)luR0#_3A\3xy]v3xT*Afؿˡo1;@X)޼a~[S׻H:=<dk'5a0'q 
[}vj$
 ֳ/t#B|@S}:¥	&a_pJyWcA
LAΟ6i'0 7#>We||@@(r`
eXRR
>D抱\8ts_JBa錙Vx)9M~+yGM>2Pp&_tili_)puHBv}fefxP@؄׮L{qCӧɱĭ/pP߫acv!'{VO]rDb)րW49.w"m*Վ	SweKH@]4Wl<>r6?!֩j,@*V+E[;}'gc)Ƹc}5t#P%8'>eL8j6y3Jk~{xe'9LDԑڪS
E

hAj$ˊϾAaTZԧ$B`#{b=Unh؏qδ1RFU}d63~&ѢHjBY>bɝ_ē4s6ˉxrJzz/F4F]hӅ~M8P+#ڶ`v6ɁZ٤*~h$e8r2/5eD=
XV7z'x~:qR!֔B+%A7dاXD56.a
jՋ֐ԟPAgoTZnh/b8[
[FJZHEOl2Xh'Ǒ:L>wq=Um
T*gߊ0V7Ro6`I4cb!``#*8=BG0(GFk4@UOr¹48!?62OyfB+³w$P(CQIsЛWr#fK?Zr̈7kjGNrum7}&yT6W|QC]D:
xH fnp/{@’=&{~[G(#Gt@4LIV9)xy9m1^2atO|	k
}l:28_1b:4)B'X]DlURHIF8u߶-JexH|3iGyw"*<,вNڿnOwgP;KʎnO
eڦqA
ZizDFccǒײ6;"O_T&L4K˫pĀt)
_QCSE(.nH.k[#-ƻ/Lۮ"iN|GG\
B^S7Ƹh~e](h\Xf{9o?1H;`m7a8
6G+j Lkgb)ƵIa\V0.=C3Qb$n.)sF%QzAs1C}z jݙ_Z2eZ2Py@%vkZ,vhjq	,
'EE-:'
E%Cm=S}K2qƆ/6L6!Zb3(M$V1nnPȵ2Gh7)bTlQVȳ rm
q0(P+CsPMсx:=NNk[`Sx8S>˓0ochJlХ+vbRS@?ޮ'Xp-3^h2&BYL|^'ẘp?%xp﩮5/m
:X@Hr\|QCRup#zΔC~ufZQˢx6Ra$Mь:&ج*Fe
K^∻iw,iY.%F8	v{×e,zSV:v	38lPLI2}?\k
UF#Yg3aGeA̮#@4WxX֪Ag_b0e#?r9zi}bO#BI	k!5~l%Tt*lfXkVD+I/QˆN:N^<eE;iOnke(qeANSu;!Nb&`I,>G)^'E)y/o3LP%dAsw>xIsDxɣŎ14ۀ{Jh+?Pt:֎F).#1jv@f
z]FsPMÒٽU۾˗(bFxIR^(UL$=V/l,
 _z}NyOmjɶ\IbE9+&K椢!qe*
ݬ$((oQ{i۶.ٻFjdw߃f]BCIˌhɥ-B5D'M_g['oq֔纵x0O^+j\xз˝wT[Y1ͳV8}^߮'mj@/EN!DfߜHWqA(H'ݣnT1ќ5II̤4KqG#A
{8*aizYhWE)dHUkd aLՀQ&ۢ
Sz^U&fU߱:NjMskV!:[FyhJ-v
=9]R*Ef|/C~#XiSӞi_j+.;2ЌddFPUC)^1$'lIF35ic0G(/DQ	uׇFP\~H{t7%+1UwF?;rU5WTT'E"R~?F.[ol/}1VDQ}rJkN|ܐUYr+QH1(c>+%5*$e0t(zWDe?3&xP\"٪4wIoEKm=LiR,[J/]GKmg۠94T22Cz+4/z3w,'=P;zLeY␞Ѓke`t%:7$We?$U&;9mo2oUtqqOf[((kp ,4@ C܍ G}HYw^ڴ$og7U6A6%42~s\,&=:Ϳ̀/u*x%|XƱ2 K%]t2+
4R=WzDDj3_$Ԭu;n/XhUqϐӯ!	'Duuo)(ىb*+S҄wzJ CACxBk*8fb2yW*ڕh`zֵ.ֱMIV!d0iFPPaY_Rf^P1̌1$s
eF|WeN!n=r^u?j@:wJS2+0׿e\2mߤ<ߗӿSeqTv?(|a*{%6ȎPy&-,9	*Soڰx^!#J㦈Ym/juj;UF
9)LDi?b;432Y}1һ9LzE_wu/-Vڹa$7~eil-U-}%]1V8I0eflJc0uX8i;j4eգqgkrd#Lӆ톊NUvNB
;CU`2=ofY)q3W(`"o';Áɷ6vm=0\lb$1-;-"
BҲq݆!4-q3ӓ {}el~6<I2*"wWgrK#5̙Dhy.r$Qx*L]4-E6GWk@;!VOnZI6w~4Ϩ+G!i.ZSZsv|0÷A1NOuh:~b͜/Rag,TXTz	;.J>G9"%]Fʭfx6w
3#?쁉65J:l_\^
Sko=12[ޔ'Hnْ_njA#o07#WSϓF]'Ba#~ áE31	q$-3Df?,-V-G-RvmW("6rwѲ11Jja]AfBq٣?՛RR3T"p+Y_}BFtoq>+k?**vh`J6gaT9^H)$/bkY3VƍBj>nj)ˈU[A_]WMWBtF(c#UBkxHF4gS2L^E߫B:ZPY
<êo|,NG<
yh$͓ hb.O!?nc4
rp.ǩƛp!֬
VXJ;qd)\g$;>G[M!c0V,
$BH!
r:Qp^o_c3SPM:.X:gZL[6h␡w(2Ul4JzW[#2
B=,BF%uݍg]]I-dQ!
KnuHFV9^߾ET6Ao`	KH
']/cģyþ,GEِJh7nY(8}@]']?"MRAP7х(mo-{IwFCKof{!SM.8j?SqN>#?
oa;ΠEȞ"zL9Yj+blT=?w3~CTXF3LEֈi1sԟRrp9_dʗ:~KD+sg>;
   end$

lisp procedure ordlist u;
   ordlist1(u,nil)$

lisp procedure ordlist1(u,v);
   if null u then v
   else ordlist1(cdr u,ordlist2(car u,v))$

lisp procedure ordlist2(x,v);
   if ordp(x,car v) then x . v
   else car v . ordlist2(x,cdr v)$

lisp operator schoonop;
lisp procedure schoonop i;
   begin scalar ol;
      ol:=cdr multi_coeff(list('equ,i),cdr reval 'vars);
      if length ol=1 then return i;
      if car ol neq 0 then equ(put_equations_used(equations_used()+1)):=car ol;
      for each el in cdr ol do equ(put_equations_used(equations_used()+1)):=caddr el;
      equ(i):=0;
      return equations_used();
   end$

procedure hl(m,n,l);
   for i:=m:n do if length num equ i<=l and equ i neq 0
   then elim(i,allowed_opr,forbidden_opr) else if remainder(i,10)=0 then write i$

procedure h i;elim(i,allowed_opr,forbidden_opr)$

lisp operator clean;
lisp procedure clean i;
   begin scalar ol;
      ol:=cdr operator_coeff(list('equ,i),'ext);
      if car ol neq 0 then equ(pte(te+1)):=car ol;
      for each el in cdr ol do
    	 equ(pte(te+1)):=caddr el;
      equ(i):=0;
      return te;
   end$

procedure prl(m,n,l);
   for i:=m:n do if length equ i<=l and equ i neq 0 then write i,"  ",equ i$


% heho

lisp procedure mkpartitions(m,q,min,max,partitie,partitielist);
   if q=1 then
      if m>=min then reverse(m . partitie) . partitielist
      else partitielist
   else
      if min>max then partitielist
      else mkpartitions(m-min,q-1,min,(m-min)/(q-1),min . partitie,
	 mkpartitions(m,q,min+1,max,partitie,partitielist))$

lisp procedure partities(m,q,min);
   mkpartitions(m,q,min,m/q,nil,nil)$

lisp procedure mkallpartitions m;
   for i:=m step -1 until 1 conc partities(m,i,1)$

lisp operator mkvarlist;
lisp procedure mkvarlist(m,q);
   'list . processpartitielist(partities(m,q,0),nil)$

lisp procedure processpartitielist(partitielist,varlist);
   if null partitielist then varlist
   else processpartitielist(cdr partitielist,
      processpartitie(car partitielist,0,nil,nil . nil,varlist))$

lisp procedure processpartitie(partitie,oldi,oldilist,var,varlist);
   if null partitie then if null car var then ('times . cdr var) . varlist else
      ('times . ('ext . reverse ordn car var) . cdr var) . varlist
   else if car partitie=0 then processpartitie(cdr partitie,oldi,oldilist,var,varlist)
   else if car partitie=oldi then
      processcarpartitie(oldi,oldilist,cdr partitie,var,varlist)
   else processcarpartitie(car partitie,
      cdr nth(cdadr get('graadlijst,'avalue),car partitie),
      cdr partitie,var,varlist)$

lisp procedure processcarpartitie(i,ilist,restpartitie,var,varlist);
   if null ilist then varlist
   else if evenp i then
      processcarpartitie(i,cdr ilist,restpartitie,var,
   	 processpartitie(restpartitie,i,ilist,car var . car ilist . cdr var,varlist))
   else
      processcarpartitie(i,cdr ilist,restpartitie,var,
   	 processpartitie(restpartitie,i,cdr ilist,(car ilist . car var) . cdr var,varlist))$


% polynom

lisp procedure mkpartitions1(m,q,min,max,partitie,partitielist);
   if q=1 then
      if m>=min then reverse(m . partitie) . partitielist
      else partitielist
   else
      if min>max then partitielist
      else mkpartitions1(m-min,q-1,min,(m-min)/(q-1),min . partitie,
	 mkpartitions1(m,q,min+1,max,partitie,partitielist))$

lisp procedure partities1(m,q,min);
   mkpartitions1(m,q,min,m/q,nil,nil)$

lisp procedure mkallpartitions1 m;
   for i:=m step -1 until 1 conc partities1(m,i,1)$

lisp operator mkvarlist1;
lisp procedure mkvarlist1(m,q);
   'list . processpartitie1list1(partities1(m,q,0),nil)$

lisp procedure processpartitie1list1(partitielist,varlist);
   if null partitielist then varlist
   else processpartitie1list1(cdr partitielist,
      processpartitie1(car partitielist,0,nil,nil . nil,varlist))$

lisp procedure processpartitie1(partitie,oldi,oldilist,var,varlist);
   if null partitie then if null car var then ('times . cdr var) . varlist else
      ('times . ('ext . reverse ordn car var) . cdr var) . varlist
   else if car partitie=0 then processpartitie1(cdr partitie,oldi,oldilist,var,varlist)
   else if car partitie=oldi then
      processcarpartitie1(oldi,oldilist,cdr partitie,var,varlist)
   else processcarpartitie1(car partitie,
      cdr nth(cdadr get('graadlijst,'avalue),car partitie),
      cdr partitie,var,varlist)$

lisp procedure processcarpartitie1(i,ilist,restpartitie,var,varlist);
   if null ilist then varlist
   else
      processcarpartitie1(i,cdr ilist,restpartitie,var,
   	 processpartitie1(restpartitie,i,ilist,car var . car ilist . cdr var,varlist))$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/cdiff.tst0000755000175000017500000001373711526203062023404 0ustar  giovannigiovanni% Raffaele Vitolo, 09/10/09
% This is the computation for (higher) symmetries of Burgers

% The following instructions initialize the total derivatives. The first
% string is the name of the vector field,
% the second item is the list of even variables
% (note that u1, u2, ... are u_x, u_xx, ...),
% the third item is the list of non-commuting variables
% (`ext' stands for `external' like in external (wedge) product).

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


% Specification of the vectorfield ddx.
% The meaning of the first index is the parity of variables.
% In particular here we have just even variables.
% The second index parametrizes the second item (list)
% in the super_vectorfield declaration.

ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

% Specification of the vectorfield ddt
% In the evolutionary case we never have more than one time derivative
% other derivatives are u_txxx ...

ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

% The equation -- this is also used to specify internal variables.
% For evolutionary equations internal variables are of the type
% (t,x,u,u_x,u_xx,...)

ut:=u2+2*u*u1;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

% Test for verifying the commutation of total derivatives.
% Highest order defined terms yield some `letop'
% which means `careful' in Dutch and is treated as a new variable.

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

%% This is the list of variables with respect to their grading,
%% starting from degree ONE.

graadlijst:={{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

% This is the list of all monomials of degree 0, 1, 2, ... 
% which can be constructed from the above list of elementary variables 
% with their grading.

grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$

% Initialize a counter for the vector of arbitrary constants

ctel:=0;

% we assume a generating function of degree <= 5

sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

% This is the equation ell_B(sym)=0, where B=0 is Burgers'equation
% and sym is the generating function. From now on all equations
% are arranged in a single vector whose name is `equ'.

equ 1:=ddt(sym)-ddx(ddx(sym))-2*u*ddx(sym)-2*u1*sym ;

% This is the list of variables, to be passed to the equation solver.

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

% This is the number of initial equation(s)

tel:=1;

% The following procedure uses multi_coeff (from the package `tools').
% It gets all coefficients of monomials appearing in the initial equation(s).
% The coefficients are put into the vector equ after the initial equations.

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

% This command initialize the equation solver.
% It passes the equation(s) togeher with their number `tel',
% the constants'vector `c', its length `ctel',
% an arbitrary constant `f' that may appear in computations.

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

% Run the procedure splitvars in order to obtain equations on coefficiens
% of each monomial.

splitvars 1;

% Next command tells the solver the total number of equations obtained
% after running splitvars.

pte tel;

% It is worth to write down the equations for the coefficients.

for i:=2:tel do write equ i;

pause;

% This command solves the equations for the coefficients.
% Note that we have to skip the initial equations!

for i:=2:te do es i;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/cdiff.red0000755000175000017500000000354711526203062023342 0ustar  giovannigiovannimodule cdiff;


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
% % *****************************************************************
%
% Authors: P. Gragert, P.H.M. Kersten, G.H.M. Roelofs, G.F. Post
% University of Twente (Enschede, The Netherlands)
%
% Version and Date:  Version 1.0, 1992.
%
% Maintainer: Raffaele Vitolo
% Dipartimento di Matematica, Universita' del Salento (Lecce, Italy)
% email: raffaele.vitolo@unisalento.it
% web: http://poincare.unisalento.it/vitolo
% ===============================================================

create!-package('(cdiff tools21 integrator supervf cdiffx), nil);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/supervf.red0000755000175000017500000003077111526203062023760 0ustar  giovannigiovannimodule supervf;


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
% % *****************************************************************
%
% Authors: P. Gragert, P.H.M. Kersten, G.H.M. Roelofs, G.F. Post
% University of Twente (Enschede, The Netherlands)
%
% Version and Date:  Version 1.0, 1992.
%
% Maintainer: Raffaele Vitolo
% Dipartimento di Matematica, Universita' del Salento (Lecce, Italy)
% email: raffaele.vitolo@unisalento.it
% web: http://poincare.unisalento.it/vitolo
% ===============================================================


symbolic$
% write"Super vectorfield package for REDUCE, $Revision: 1.1 $"$terpri()$

put('ext, 'simpfn, 'simpiden)$




global '(!*natural_wedges)$
!*natural_wedges:=nil$
flag('(natural_wedges), 'switch)$
put('natural_wedges, 'simpfg,
   '((t(natural_wedges_handler t))(nil(natural_wedges_handler nil))))$



algebraic$

lisp operator super_vectorfield;

lisp procedure super_vectorfield(operator_name,even_variables,odd_variables);
   begin
      scalar odd_dimension;
      if not idp operator_name then
         msgpri("SUPER_VECTORFIELD:",operator_name,
	    "is not an identifier",nil,t);
      put(operator_name, 'simpfn, 'super_der_simp);
      flag(list(operator_name), 'full);
      even_variables:=
         if null even_variables then even_variables
         else if atom even_variables then list even_variables
         else if car even_variables= 'list then cdr even_variables
         else even_variables;
      odd_variables:=
         if null odd_variables then odd_variables
         else if atom odd_variables then list odd_variables
         else if car odd_variables= 'list then cdr odd_variables
         else odd_variables;
      odd_dimension:=0;
      for each kernel in odd_variables do
         if length kernel neq 2 or
	 car kernel neq 'ext or
	 not fixp cadr kernel then
            msgpri("SUPER_VECTORFIELD:",kernel,
	       "not a valid odd variable",nil,t)
         else odd_dimension:=max(odd_dimension,cadr kernel);
      put(operator_name, 'variables,even_variables);
      put(operator_name, 'even_dimension,length even_variables);
      put(operator_name, 'odd_dimension,odd_dimension);
      put(operator_name, 'setkfn, 'setk_super_vectorfield);
      return list('list,length even_variables,odd_dimension);
   end$

lisp operator vectorfield;
lisp procedure vectorfield(operator_name,variables);
   super_vectorfield(operator_name,variables,nil)$


lisp operator add_variables_to_vectorfield;
lisp procedure add_variables_to_vectorfield(operator_name,variables);
   if get(operator_name, 'simpfn)neq 'super_der_simp then

      msgpri("ADD_VARIABLE_TO_VECTORFIELD:",operator_name,
	 "not a vectorfield",nil,t)
   else <<
      variables:=append(get(operator_name, 'variables),if null variables then variables else if atom
	 variables then list variables else if
	    car variables= 'list then cdr variables else variables);
      put(operator_name, 'variables,variables);
      put(operator_name, 'even_dimension,length variables)>> $


lisp operator add_odd_variables_to_vectorfield;
lisp procedure add_odd_variables_to_vectorfield(operator_name,odd_variables);
   if get(operator_name, 'simpfn)neq 'super_der_simp then

      msgpri("ADD_VARIABLE_TO_VECTORFIELD:",operator_name,
	 "not a vectorfield",nil,t)
   else begin scalar odd_dimension;
      odd_variables:=if null odd_variables then odd_variables else if atom
	 odd_variables then list odd_variables else if
	    car odd_variables= 'list then cdr odd_variables else odd_variables;
      odd_dimension:=get(operator_name, 'odd_dimension);

      for each kernel in odd_variables do
	 if length kernel neq 2 or car kernel neq 'ext
	    or not fixp cadr kernel then

	       msgpri("SUPER_VECTORFIELD:",kernel,"not a valid odd variable",nil,t)
	 else odd_dimension:=max(odd_dimension,cadr kernel)

	    ;
      return put(operator_name, 'odd_dimension,odd_dimension);
   end$

lisp procedure merge_lists(x1,x2);
   begin scalar cx1,cx2,lx2,clx2,oddskip,sign;

      sign:=1;
      x1:=reverse x1;
      if x1 then cx1:=car x1 else goto b;
   a:if x2 then cx2:=car x2 else goto b;
      if cx10 then return nil;
      if cx1>clx2 then goto b1;

      x2:=clx2 . x2;
      lx2:=cdr lx2;
      oddskip:=not oddskip;
      goto b

	 ;
   b1:

      x2:=cx1 . x2;
      x1:=cdr x1;
      if oddskip and cx1>0 then sign:=-sign;
      if x1 then cx1:=car x1;
      goto b



	 ;
   end$


lisp procedure ext_mult(x1,x2);
   (if null x then nil ./ 1
   else if null cdr x then 1 ./ 1
   else(((!*a2k('ext . cdr x) .^ 1) .* car x) .+ nil) ./ 1)
      where x=merge_lists(cdr x1,cdr x2)$


lisp procedure super_der_simp u;
   if length u=2 then

   begin scalar derivation_name,variables,even_components,odd_components,
	 splitted_numr,splitted_denr;
      derivation_name:=reval car u;
      variables:=get(derivation_name, 'variables);
      u:=simp!* cadr u;

      splitted_numr:=split_form(numr u, '(ext));
      splitted_numr:=
	 (list('ext) . car splitted_numr) . cdr splitted_numr;
      splitted_denr:=split_form(denr u, '(ext));
      splitted_denr:=
	 (list('ext) . car splitted_denr) . cdr splitted_denr;
      even_components:=for i:=1:get(derivation_name, 'even_dimension)collect
	 (nth(variables,i) . split_ext(component, '(ext)))
	    where component=simp!* list(derivation_name,0,i);
      odd_components:=for i:=1:get(derivation_name, 'odd_dimension)collect
	 (i . split_ext(component, '(ext)))
	    where component=simp!* list(derivation_name,1,i)

	       ;
      return subtrsq(
	 quotsq(addsq(even_action(even_components,splitted_numr),
	    odd_action(odd_components,splitted_numr)),denr u ./ 1),
	 quotsq(super_product_sq(even_action(even_components,splitted_denr),
	    numr u ./ 1),
	    multf(denr u,denr u) ./ 1));
   end


   else simpiden u$


lisp procedure split_ext(sq,op_list);
   begin scalar denr_sq,splitted_form;
      denr_sq:=denr sq;
      splitted_form:=split_form(numr sq,op_list);
      return(list('ext) . cancel(car splitted_form ./ denr_sq)) .
	 for each kc_pair in cdr splitted_form collect
	    (car kc_pair . cancel(cdr kc_pair ./ denr_sq))
   end$


lisp procedure even_action(components,splitted_form);
   begin scalar action;
      action:=nil ./ 1;
      for each kc_pair in splitted_form do
	 action:=addsq(action,
	    even_action_sf(components,cdr kc_pair,car kc_pair,1));
      return action;
   end$


lisp procedure even_action_sf(components,sf,ext_kernel,fac);
   begin scalar action;
      action:=nil ./ 1;
      while not domainp sf do
      <> ;
      return action;
   end$


lisp procedure even_action_term(components,term,ext_kernel,fac);
   addsq(even_action_pow(components,car term,
      ext_kernel,!*f2q multf(fac,cdr term)),
      even_action_sf(components,cdr term,
	 ext_kernel,multf(fac,!*p2f car term)))$


lisp procedure even_action_pow(components,pow,ext_kernel,fac);
   begin scalar kernel,n,component,derivative,action,active_components;
      kernel:=car pow;n:=cdr pow;

      if(component:=assoc(kernel,components))then
	 return
 	 <>

	       ;

      active_components:=find_active_components(kernel,components,nil)

	 ;

      action:=nil ./ 1;
      for each component in active_components do
      <> ;
      return multsq(action,fac)

	 ;
   end$


lisp procedure component_action(component,ext_kernel,coefficient);
   begin scalar action;
      action:=nil ./ 1;
      for each kc_pair in cdr component do
	 (if numr ext_product then
	    action:=addsq(action,
	       multsq(multsq(ext_product,even_coefficient),coefficient)))
		  where ext_product=ext_mult(car kc_pair,ext_kernel),
	 even_coefficient=cdr kc_pair;
      return action;
   end$


lisp procedure find_active_components(kernel,components,components_found);
   begin
      components_found:=
	 update_components(kernel .
	    ((if depl_entry then cdr depl_entry)where depl_entry=assoc(kernel,depl!*)),
	    components,components_found)$
      if not atom kernel then
	 for each element in kernel do
	    components_found:=find_active_components(element,components,components_found);
      return components_found;
   end$


lisp procedure update_components(dependencies,components,components_found);
   begin scalar component;
      for each kernel in dependencies do
	 if(component:=assoc(kernel,components))
	    and not assoc(kernel,components_found)then
	       components_found:=component . components_found;
      return components_found;
   end$


lisp procedure odd_action(components,splitted_form);
   begin scalar action,sign,derivative,kernel,coefficient,component;
      action:=nil ./ 1;
      for each kc_pair in splitted_form do
      <>
      >> ;
      return action;
   end$


lisp procedure setk_super_vectorfield(val,value);
   begin scalar vectorfield,var,variables,i,tuple;
      if length val neq 2 then return let2(val,value,nil,t);
      vectorfield:=car val;
      var:=cadr val;

      tuple:=
	 if not atom var and car var= 'ext and length var=2 then
	    list(1,cadr var)
	 else <> ;
	    if null variables then

	       msgpri("SETK_SUPER_VECTORFIELD:",var,
		  "not a valid variable for",vectorfield,t)
	    else list(0,i)>>

	       ;
      return let2(vectorfield . tuple,value,nil,t);
   end$


lisp operator super_product;
lisp procedure super_product(x,y);
   mk!*sq subs2 super_product_sq(simp x,simp y)$

lisp procedure super_product_sq(x,y);
   begin scalar splitted_x,splitted_y,product;
      splitted_x:=split_ext(x, '(ext));
      splitted_y:=split_ext(y, '(ext));
      product:=nil ./ 1;
      for each term_x in splitted_x do
	 for each term_y in splitted_y do
	    product:=addsq(product,
	       multsq(multsq(cdr term_x,cdr term_y),
		  ext_mult(car term_x,car term_y)));
      return product;
   end$


lisp procedure natural_wedges_handler on_off;
   begin scalar save_switch;
      if on_off then
      <>
      else
      <>
   end$



lisp procedure wedge_print ext_kernel;
   if length ext_kernel leq 2 then print_alias ext_kernel
   else inprint('super_product,0,kernels_on_list)
      where kernels_on_list=
	 for each arg in cdr ext_kernel collect list('ext,arg)$

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/integrator.djvu0000755000175000017500000114177711526203062024654 0ustar  giovannigiovanniAT&TFORMDJVMDIRMB!Z6r?YF|lH#
FW
*9^pɮx
*:`62,bqcc;0/v-.07YUL<b^_='l{N	zaڭn<8MQ4BG^yBHn͛_A@h<|'ZUhh2EaGCAިJj*
shQR3^Efff;b9$ FORMDJVIDjbzsQ(/>X8FnB-yKg-Q?J7B֤cl&9'{Azz
d:{t?m@FdqW_DOm+}?X"nҘ/9)[bSm_one1Ш=WAoB#3
4l].ԩ
GHh(;菗P(UXKᡩpd鷅E
92yGpbu+U^pa!qrd:F枌OD#9 #Œƿo
Y2c w1g"^Hd{`畲@?iЊ2t.-qtk꧅3N4F+9D-dNt|	*JDl8/etGFǃr<Y<gmǫI[O~3wjU`\8,AflhS3$=YLWapb8ګOFI0u2>uOg}ds,i7eҏ:F["dUTI8I%uT2%XOr%C	Qvx_pr-9IyIS|pryH=U߹,,7VC4&ةzs]@<&.Mu:[!a詒_yy@QPy_aUȧ156E}nVy#O{yAݯ淊-iM~g8ON;=S䧚nFE4q$	_zHxRZ?++%?TҖ،t=$sj*B&J$OrR>o;G]U;tn=`ug} ,(/|]F#1%?4AԈ@tTw9`6qHrsY'xJr0)E8tl+ '!e^2>,hDݢSu=ɂh6:lj@IrqBr\ɣ_ذ?~S (kٓYGɋuVQa:V8NFrӤ,l>K
3ƸlI"w]bh]in><02xq20k:蛏h= O>܍pQpҁ.8sHIq4~$/2HZ
	LE~nXόoa'\
ڿƅRoL1ur<ڛ#n#>_qghj]K.?aiZq{c-cXݍOm*\jmMq{e,ꚋlÊG=%8fEMd:RJyYY8/P`p[͡MjGǜ:!@^TC~o[6kXԡG/5|l6'~Qgo9eh>eLp:,R*"r&>kIWS~Lu	,IN_?\0^,
T!VT	(q>s:-A'9c*YQ#KuD8!e?C<+pnUۇwU"o%*,"3H
i+@mӉtfOO\Ȗ#{*HTLi1de62ʹZt*sxݣcxi]J(
%!: -s)LSmp<@uӜj#S=zЏ89dS̓omK3۰h5ɵҰnBSY;M$0x[vo_{$ߣcۃ`Yi0^u)?ã`o\[}KqI+
[<[o	e}Ue:fӝ5J&[mtrW80
Q
b$RY4l5Y,&eXL:ET2'a,,WR-9Vƨ;]wCX$l{>+&w<1,==*}`s/~|eUʷ`}D}W˥tq=5"I5bb4iI)B}}UG^hs_W:o)ACbNJQ"޲d"MaY 6[ôYPZ[EiG(/F7"-;y-șZ7&4vN&0J4~ej:Ax/e+Wl}#0q+BlAx+Q:H4)6=ep[͙9rJ&-sHK9N>=~lDJ L`KeǸ㩲C$s$:w:lUEYyCxx
)Dx}-GzWYCgzV7~C)釭`Dk0!'6EA01y2BLm5	={4"陋p+k3F[%q>Zt,>@NX Uo:R|b~G׫c,`æU@ȻDuާiSR`:A12Bh˖%OzM_^CN[~g,j,wz_di`uH>%y.&%KU*
G@pp!ћGhg$!ؕaAC~W"Y
F5X'MV'UIHV~Vo3])+D_
a~Y
Hㅋўm37T]Nwky3oR&nqbzԬVa=1mv+Ep!2y!NM7^V˜\յlhwim嚶<8M#[N׌;`᯷ = q), RgӒ.B#5oYpi)0'2Qq2nc!,I[[UA`VC6^H3R,Dxzjqb04 Sme*-	u8(& QCpf(8?ol34
[ϣe$ʭt*<:OGk>u{m"`.ı嬣<-3Guj]mg`gztٳIZ%6ۈ
RҖ
K@@>Rr*V0_NѪBI.߅Fj'z5!0(T/Z⸐9e9JjKJp-|sM{a;.{b,۞I~C2n^a+7,(n6lZr؍NmQDGzQ.qR^6CGƶ"
+9b{PHDu@g#((kkj_\*'6Rs}"I- N,\2G9 G6`"-W{5CW^
U]喲N=j&3~)'
BhBF˽YSv~85Q
I$gm)1nHĐ Z$,G>gylG
}CD.>Bm;s
ә;B@6ҦXUr
8EW~=|FT0kaۥ/d	+2~rx%?CbbuKlƦۈVc{M;noVXJ+K1,W@,N4^.sSڦ9dٕܣ9-ytTIozY5)dG,i=c6@#tjxnEC'pdb,3f6r.QbxrАaӹJET}r	b0[ٖ/B,5b6<:!c˩)Ȯ_VZX٥nkٺ=w4ۄJLn+W!Wfq'%X!zV~Iߍ!d͉a\wxqxb3 c-U.Z__AUEQ9e[;agEpO3ލqR:HFʩoNe#246Ͷ9R1,Ya.*!G?g_rѪaEgR Xr1R(zH6(z8陥t#
mVΕdzx#5l/O:_1,m33GG
ǔ5b, ye\]֤vUE?	F;OMqƄ);L";_
۵-mC<1=Wv]5O
!_涙Jp|d2e>)'QIr|;ŶOz_{1a|Qv]է=Gp]>={ZRڇ%]̙=f2E4X̌jn8kd3v1g$By=͜"!"Ezgmt#4 ufNh>~|UD&3](
J(@:P"#+.ͺjTA0G1z[)j
L):ymYy$~'T	׆AX!YcFD5F	.폈[`O@>6>奙T8p_x8}
#Aq;cye1VߕP(5a;R>uCV9B79x}["n,h\3p~_nFo"ߵaQ+g:70L&8O몀ｪ57VG-$'6x9Et:3!TbmV@!U
2ZָRTfu7.5?@n1Q*ZMyY/cЮzS@/#}u0n,	J(e'Do'Adx#)82}JفZ褊ףblv\u(Pi|QGɭfvn,؝yǗԒ/Xlw^Yd$Sɉ&#gYַ^:6$zмlZVo5"𑭂v4FgF=ÅX7Y?TJJމpMqI!{;{ODշ{'@;~=MJk$#=O-7:cHe6+7+ l5b5vs6h.~za:eޞXZT|ưKW
|&˰7Kۓ|q$C/ݡ%1K(X.)Ŏ$AWO{VcNZҵ\{}hn稐RʖwٛMX`Iv6Z
.g*AӌY0ugRpr*YaOZܴ	@2	}V@0$vt:v~IY/x:Um>f²NT ˞ >خv&o.|b`%<:~4zo"qlE_6_tUԒI[RTt[kKu_pY5&@g7n֮]
b@
FFc]_`c3턷		D|d}Qj6yq&WVL4j޽bO^9GfDCHTNJ)gc߅
Xݵc(yx	Ln~vh-eh'VBYo\mb6GɃ$5[.nG
\}S;&2,Μqdzd#/vp2Ex;VT™cGڃ%^*1hq/,Rxo9;t->>d79ɆIwVmt|M:Т;ֿ4*ڑnGְdFԅ6/G{IOf03#
T%x[fe%FnSZtKtĦb!w1KE=ޓ܆uץk\J=L?,Φ$7Ir(8g	݇L'$`2-Gdͬ{
5xeaUs9$?&,T^=FaB(HA܏FR93Ғe/ynT"aÅo!	8a?[gZ&(ukREĮRiq)xds?kBm`jx2Ep
K)ڄ$q;ԧPKtkWwj*"Od	Ihf	GStԬ[|(Ԕ1H+]V`t\[;Z{3qC/ѣYBo:
>L^drV\s.hB@f4<5*'tȬ($*KSY7~mQW=\rpȖޔ*d#ӯow'*Q@	X2PW1Uǹ1\V5lh0 pˋZB%K$
~g^-+1чW?$7nǹKjݍbՎTaC7l~Csk%~SR߁4<]8`JvAJf_A.	aj
BQIJT#Ŗ)p'F4W>KQ?"vuIWLJEh`JXsP)ޓd+5SFF&+u!:	BHKAd,:NY.^nMbD3\>qn$ݜ Opgt&q6;UdĩtܫAh-w`iMۊ0t IbuMZ$&_FeQ9Dc(Mdu
p#^W\oBxzعv;؅3e2f+_Y/xo-W*\RPGv8Z!:]9=b&l.yToSBgȥ	8>pgx6	6h^to!R9u@BU'#<]кd؆d/PtaY".	mgr5BX838OUQCɂcr&e*d6({ֶ>ńyx{uBKКXUBX76j,5JZZI-+/.b!}WF{L%j[9,]5RẍGqw ?̨;RץaMD_Zc,GxGVTE|e]Psh!
â:;jPߍPAӉdjw3a 5"%Zd)X_TE
"->̝4Viʂ ļNv1$뺳/5~=ɐb|mJ>g@-UZQҕP}pD;A.ZjZF+
hS`Dz
C}h׳-L4Ns%n#jk8m߁fI()U/oRLn.R5nԯ}(pI@|ok5ّ[SЏJv"(\It4g0Rg𱔴10^Gcz".V Qfeۀ?݆9@;4(mZoZ/C&΢@&6
m"#[q
ƍ9P2k`;aCHߌr$FEݰ.޲{3kwZ*&݂6?3`N^f!}[Ej LG( =%B
y(AzE|vSuDH݂V0rzz
S
B.B-{hvܪsD8R,ЖUm
w'P57ʛa㦤!,:	Xw
$glDWh;HzĜ	7z}.PO#`g۱o$%l׽^rX$[LML$_aQEԘ
FfIkD32W~?.&q֕!.\ϵ#ڊF=l4
8Xs1O`wֽ}ӽȩ6?Jm!SKմWĴ>T.DRM$Lb@Ui9p-E ?I^p3VOwzZc|2Yn61行sme󩘉_;݈=HGP:P2NAcw!#Rƻ}0#`.lH̦g-O4/-SJ.or9D+up!,*>bpJapjAdrWۖ5Aۻ'-&qA42Km_V!Uw$+-k'ZZ9aLo]|T9Ѯ;Bwi{-}W^98lq(],&-WMˍ=wekں:0U4htUf'ʰZ;۹ĥ|4ZǓZC:\Zd\erp1aw;0?
XpC]#30ӸBBoͣ#YiTXD
c+~(Yv"O;5#
yXí.!<ۓD'$3`["bܣ~zZZ!pUR/0ڕ}
> z󂺜5G		;,%*{XӱKwmU0[P&L*y8±-#S
8,SppP~Ȇ
]64
҂\t~2N%dzNWK?\GDBb֓%9ƾZ j+ԾS~>DxT"'!â~m0mdG>c=V^Vi3Fny[	[QE<7=cUqxߚ'|*zw6mP/j |=
LLQxƆ5'RErez:'/a*@rKuʿhu9h\jzUM{ңrͺx%r7.3\ߑ+`[k۳|;Q)F&C&.{`m㎏V:g\w0jzTXy[Y[^!)]f3>s$`Uȸ«)d)FwNTQ :gW~7V.`ljS.fE;~H;шDfQSua	q;\tie@4пO@j?Eƀ𞒂ydUߏwֳLD!Dop4Yl U4G˹}5fgϙZGk;z|,Ϯ	aeș\_'-_jI%_/jyUKqT[QW	K#?A^9(q6I#gn
mBmxj$=C
/nJp]N#(q=UX>EFL̅RR@ȷ|3*Ԡ8>/:ͩEP2~HJkJ5hޖ
_6'>%LM+<}jG$U_qLMy{@u;92w
l$C!4<8t8.vJ9LIQ[Fa*mMd53s@0ݙ%V5	`K㲙?p{y}w

/C10 mhQ5$۽00p-iqP8?1qa4[#
~d;\aQP1W11ݥ~6UkfKָLkXC_c]a7<
k:vPjԘ N1ݲpB#
T.Q;oVRE#xA/t1	m9hIK㌰l~lɴ5GԫiqŨ$J(˧Li%Z;X#(eD?bmI3QdBxö	iGS)=H~c@!)Ջ;װ'FH]A	ݸ
3&@xdtAa]{z=-,cc0g:hC2͔Xn'FELdToZ&zx|2n$#;CꡫXcO!7ioFʔ71ݙDHC{~\)|+d.Ll"!&OɺaO(o؎OZYԙO2.ա,t8f5b?^"HuW!/r("P+w.79h9D M!N=n%T'@2Ɏ٭9zH4l]O|ab J[ۊ#]cq'	C/͔cq]&BHfb =5adi!9A}EVM!`W f\SӨ0s[up6QIY$W[
+AlhmZQJϐ#ї3;LDh5Ak$ub1
9lYxį/'eQRG	rdzX6h#a@!sϲ6EWL0؜kr#d	 %;wOp%qs}j-]5xM$y1(\礌ʺZJ%dcC{f
*7oz MA9L-}<1\2iـG\o
`xF8._L8,UZ5hX\F.~-7ilFN5C35VN*1'`H5kI73Mҏp&yLE|As\i{̻b>zW]z2-o DWbYѕu?>ƬtMvfB|V1vRGl%{oPZB45%Ͽ*8!d]Eb6kN,a4T	_k.RTPB}x
nm[ЈxOJ$@sa(u<~~jXj3/,é1Uu6DX6j}dPnlĄ\`#+il/H=iX\u`u9CoS"	mmjX/.t4p}/r@#Jok}$w.ӊꯢ4?9ddw\R,UXz7Oᄃ!IJXF|6P=$)GW	PdQIynoZ㣚 =m1MkT?`Q)ƅKJ"hwօZt+l4$:H;
nJ5᾵zFtJ*.wyo2eН%PJH7Тp	Qc7;x=CU,>,D$qk*$?h6n흷$Y"7to!pNp'*%mƪUnYzYچIQ100DU'Ԍ.$92lǦ>\MV	D;T[(]/:&o4](ZXYyq|CܞwRCA<,ejl"@{A10?_^gڍ5Q:4M7ۓJn;A".OtSr vWfGbT5OU9ٚH^$}B#}xMhi~q$0lJ]YdP	q4b%멙U꧹X[*4S1G-alԘSI5kYd"_n"
f`MJ\	IKѠ=_!?[!/-r	C|vLRm7uGbκ7{pyiIO;@de(*ٲ(4&vC~j]MyE=FKNu=\Q[2GFryIQjۃWp>tVc˺7>#e1.gfnn3{ixtz|r>(R)'U
ڂW"Ado?5r/"E
?ϧh8;h>))ݡџT')9!$֚wm`&`ŮnSh!"
ߪ5b]*o9wh}[g'(&ҝr*KKsH1 4@JDN2)mǾ[E\%B.ɇlcou{@س.E"s9brKW,`ʼG5[jN=Ldc+Y0çSc9~4F+$9鴗U
5j87Wc^ce
%Y*2#Y?l.)~y=GPM.K
 bC,RNC rC(E(HoA<	Z'$AS~SMZ>9q^٘>__7[B`N㰄'/8L?TEbC1;mdz<@Ae):P9\wB3n	pq.:( Sj.Wu^	NqߝӀ#(	y6qLEbFsK?Kf.
?$C$3چ##͊kDR;=4cWRf~g)ޒOg4^?-l?c`"Οpq?Li0"	@	Cx[)G؀Nui^*@#f>hB/w(>䂑FŒ
?_轰^u41~̍xƉvXl0]㮯<>D9-yItj2ɻ:uP-Y8dHX%͇YkCGo5*q;V	`.E+(6Ԁ"@*bŒ՘bkj7q"S  pRfGB[X#;.jOoH^JFʼn99>(|||`YC6,447J/'DR YFZ_
z>6"-E7MX!>H6/LI5Qp]+ěM1R80)&
v1{kzxիM-ތԡAGzYMqzOj#l
[I)x>%(쨀JoQ<@Ù|r3:n1~xyī،Skapf^YBR{ptCZcx412Ҡ
եt_"dÆ,H;{OtΝL=Scܰ>zL\BuiW1O*ޯ!OwQxJEn^`"}G/EWe!wXvn(TIOv(.#6
LfHGt*@<ͭ	ielC
*eW=t{rzP6j,U659P*S0yE}Z.-8-hh4K_JKYq'<q瑯8Xf	'pL¥FJN
+x+$um|UDjScOɬZŠF1 .ww[:q)5L`priju%s.z
eL[CObp:Ahͱρ u=&[w{)$oa[EjXs>mvyjB|@=7\D&&s1ZbQw#зs78,eql$q)–djQ@il|D	`#7̞%(s/W.Vlħԇ!`P*_#z;p#%nV() ǼHW=#m^Pu֌kSxgwQI%N[U!OW1և	/*gG'YdB&XVʍ
Րt62s'e(*1lx_&8\?|"f;ʄFHhC.2zfOMl|CE^!m@5u'Ê'\vXݱ$Eh:E.4ي
ASFyzT#Aw[.؃O31XTHt7d	6jQE>Q#KM~9sGrٗiϟ?6^F
iU蟫m$i
Qdu}۫e3o.[Aɵ`V^Y$V
NGED+Cc)usB
*`0}+xɨyO3I37bxUop:DE2W a#ן;g;2/4
7r2^fcbܗ<6V/|z'IAep&nxF7}-	ѯςom!S=3~,`U{KyYBuQdT-Y.dk6^픸S C
yoYpR1m#9ȿ2,OrtGJ{J?]F{ڷu9Әk*nXۙS*DW2E@	Bzќ
}fWH;Ŕ6yVV#sq6: ^c\Vd2cq Ej֨iגNaar4$X\B?K`EV"ң%`0긻dE\JWsQ4>:/ӥ\m{)97U0jY:BvR~02z:s='DsЏ
1ӭi۰;k0|s6%zߓVm
\
Wu^vr;

􈀐-w%2۟ߩCl>yUۄ4?.32ohyS-2##7Lߡ\0OGu^HCrn)eԛ~w!4z@76?%:f#Mn9VUhr=V&F2Md-CjkzzvS:Ԡ
Ȉ|IA[
*N.آY)>7"m>7l3LU΢W
2P_.+ٺܦ[BƬpb-wW˔k'vY!-0)JbY&H]_l
9GN\@y9ڻA-A)~$EV9ӻiؖV?<R
/ez(PT蘮Jfi@4
XRxWm=ߡW2gρv`Qgh u0KԱ9lYJ+B m3si$,zIP_1rŭ,|W\!նؕHdBhqevSQ,P^#<ª&uilR|ڶRޛ\"rF7׏i0ٲr}ZH
IGOo\TFB[e_{[ӏoEw\dYDĂq4	nr^*b7]îviQb8m4_,ج[oc$u1pڸy?^J=#%Mӫ1DS8ᔌmnv}$a~NV<7|Ehc@ܟyV{
A_G<œ%A^Q+ƕE\}wd$^i*_|F`,wVtw5b_7uԔjW%n^Yp,ZRg`ilQPvXwYPA@S.~8Y8I+ܻ֢wJ{INvsMC#2un9d#KѬ[-#(Yc^V͜>RqͅIg>=s:JD4ff"W#}R{h]b+5Ew3w򣟂bRJiH17HS'a}BrO
@{
AfMdҀ>xS
nI}:;%ӔCq8(Ft7w5k	:6y.F~ED#mVU{mFqf}v`<])Ҋ0do,<-^vx.س;Dy}Y#QynifUC2c;e7\3RdxŸy}ql/3"j)j6O5‚3T-|[NnNBrߨ Q!s==/̇F~̔QM|=]ş#P30 #ª-U/Lv)Ŋ+_MɆފ(o0X%QX؊x19yI{9rI\bE-9;X<mu7}M<|$MK{̧>p}":%ڲ}n̝YO@vUj~Q.$ÿ+=H	RXEqMl%ҨvwW7TCwWPxƓxb||1HdZam+@'D^VL$ZT.~TI*=70Х-	r8.m= }kapyqf߉+sy6pH-ȏ]tqv7
gx4e10C;ɢEɨe_Ւh~$Ap&_%6de!@
,Q]xl	oϢG):i4Vs
r*{-$ѵ6y3*WѺj_z9S2c^odMYfV(_wҬM:/0cX 
TY
.0ꑔw9t|\r4d)T%BJW2ÐEl0[}Ϲ|yf[W<\Ug'
B])IȧBk.WVH>ke3aT6d;"
Y`uџ}(E|;κGs)h F7V/5|ゾH	ƂDh]K!La|ړ
9{˜ϵ5ϏZ붳$ɹSob,Q+
:mLv&H(kUeoȢ1QteO2ά`8*xߞ$acDS02~(}OJYҧ䄑E.w~mr(bF$OgEO+){fbb/ 揹U1Ңܺۙұb$N^Rxcp B/;pgRNt&p{O?];EA/@&ɒi0EͺѠI!']Im5-61?2>ƥz~Mv"I\1`GeB"h7VN6`	ګA;5s7)bS*m@iQ;KgW(,(JZ7#5Y3֯sD^E_%H"n|*	Qc1B@g Go>ɮH}]$ND.#2/|6ip0 >CXg;靺%
类/:<¢BjA0;rqnM"6ȰUd׽QQAHô5|oHhjI6e iK6^{{Ѫs)/Iӯ~gǎǻ_cCLCʸ3'G}MZ dO%jRJ'
NxO *X8#q=Ebi՝.!eيaexM]-Mg\ye}{Lƪ1LGN%WMjة8Y+r]p@X4 Znhx?w};%4JTj$^t^[tVݸ
7Vh0Exh	^[TA	J
9᥵^IZ3{0wƐ:tLj#=iL16jAo?R@
pDn?Ot СEhB3Aj#5G	
5eA(l*;cF婓B@fZ35ףzo=MNv@ept'ԷDn^ֲ)P	Wq}zP$6J
`|DߨrnD!,?65*!.!PcKAO1&n5bAc:"X?i?Eau_fƩAwm#_jsrZKtX$J5bq`2_"-QzRl^~Zt]b\YX^=}$>":'zt+EY
P^@g8	(ΡF)^*@]
4%%Yl?-$Oor$9^Wڬ"J<ε1
:??zhksMI8uQIj'VXaC[)hFX!:B/"\y6Wv}Z<3FHtE:c[20^ux<[`xa"u.p
뢇cƴ&izU]ɘ}Sܮ<'E.7nbWI͝=C2d0W1gzdq$0vHFbr_.6dJj,k5IVʋUpGU+)Xu>~;כU&^##%ƤZvb#RUtx4#FNfD}eH
WJ8@OPx}/h%Ԉ&!16tC4]K%Amd$ѳ+C^O2'è'(Vv7f#s'pD!ɛ
[3,Ȟ|1ˬuM6@#%ZZtsYW>6|cvPЬ#8p:J*^aiTxتa|ݕWb2L-)
Y[FXؿҋϠZ͒}yVV{p ze˚6j?D4wۑ#22[oia+m,%Ld̴9)-h$ѓDz
RgJyT-VSPR68se!KҢ{)
\HGYQQ:Ɛ^ݸ?\ޮ1CBAlng[*a 
2eOYh琴R
)n1.}!<@lãGBX©8via;zF!G-0CJJB-0FjOwU7/b2pF&wHmsrSNfP7,fM,bH}!s8z?'G$⌨P	":,Ui}FO1gOG98dGYM5/l4P#_S|:rRy=9?qr>
#fQeȅo	"C-&"bH1tn<	M!@Ar5iGV=8y~ISS
.`"K*G1@s!xhZ@^4F.|~Nl_|-|xa~L[0#V718N烈 m7]\UQH/}n/ڍVah\	ge0T
ȯRx'SSQ‹q={fj>uڣwT@@hwp	A4tpgGjbo+኶a^UD;>9'f'ĵmh) ?>boÃh+%A5DG><!++Q% gҍ'Is*7p4 |1v>WixU4":ow%ot)xNN"qcr"OrsgrG|X1rZH)xZ	_:X#@JrpjkF /Y6уS8I+]3OOL<y!Đz?)7_<ݏmKayB8*m4w5);ldbJ:i`	82 RS̏KaPhӣGHeHbI}Ce~ϙ&7\ҊT;7_2K_3f|PͅN"P#˙5)*UekQ6_ibDie('yq{fxNy/t4\!͇UHcs?Oxg?orbkNmQ)Fea@7]YG,
bv\	t0g&&!J3p6o2w돹L%e/7:[fHop*M#]I\:sÂgXnIy/_x1~6Ȫ~T3<)JUJip‚au"! @951}"7Qگ`B[3Jb	BepHSLn1}Y1(̲$eC;CV! q ^l1IRyy=~23 +_#e֕HGBgu&=LQDI+مhps+!/ϚM1ڭ'@
U^cxRx]mI	V뢯~18nw?k3GКAy_$ø+C4Qv+_Ui;u@Hl5:Қ/݃N)hjIyȖ0J9VuhS*}vҝ
W0B*OPl{!=ŶFVe*vTJΦ@@
zpz%_C4&C
8dyx:

92q<%Ub8lI]ܕ*iF:s\%Fv_RJ}'Q=TƂ-b"XhμE?zIҕJs=ʯpP$1MjkX>h"IU?Քa+AWkt*5]VF,ZLaБϷah3[걈خm7fA/e(Fc'*Q6A+ޙ_=&&&a?Q;rQLhGuA|1p|'#ܒ ]}.X;u__8KW'Vo5TPpx0	D6EDdDetXS5iK`س_&lwTR2Gq:oDYa/3FYKyX	Ź_9Q0r*Uge
;S¹Pfp3=}F4Yv,,gCRĸ@V֟ASUVr4y`

4b*C"Y;I0b2tMڠS6cj.JΉoX3sĂln]\``~ՠPbye^In\?:d'	(c0?ޙ)οSpUWiT_c.Wwj+i@Pf/GĔ H\
˸$͊3Y_]}$]3EPQ#Q2KExԃM*`^8!< TGߒD4TSvZ	bA߭vtG$|:}lajާ^P@gHgQMtӋ ]tC}މ,ѧD^j3_3tQ(06M᪾ig	KslZZVݰnij?
'EҼ)GaUFqn.Vc.jb=£_ۿ<JPc$~>Kt"Ovw"TrgRszZcYv0<yS'vuW4dz]5uM}&,(u|^!7uy,;zp\A@f?2(ҥ;RvJZ+#p&cdQgP __XBKnsbS^p9 ,XPx.MXU5]yAȶ+9yRMuj2YMm;b(&}	ވ{6ԈC6W+9 GJ\D-sH!NtlP5x|ҟZRHcXfc[AJ/*%f/RF%mICKh_Uty2 K͗CҝR$~&
,4,=W_߷<BA*JRFk
Ny4)W2CL9͆,,5d9WB%z'_
g>h<% ta$c-ꟻER'_"Y`a:ڑDyf4,_57L힐TWY
+[͡/(U
*ʀQ#7Q{pHuT9W>H3~
]0N#_`>ɐ¾9pH`& +j
uyRsd}R-LT>/ifPgBh((L2b|T`pauX=k.:&:`
B.$UK%Q3/!@'F&7we1ϤˑDz"l.ӓr  Unx/|i!p(ߘZc,3y'	so~k8Hk]"aVGʞ &4f`m{ʅnGEbEŷo3m86')&	VVllbSDV%79JĻ}!ak~܊(?X{|iDfpWvD,RJo.9ģh8$?LJӒ*6-%}|.R ǶoKҥZR|Y1}ؼEBWq	ɷXcd?E"Bb6EDRc[1 &1o+o3`. dEY&ז
+8jaMd]LOo6T
0Řnq`y9XZ pi!%其lȰܮ
RUŔDLG\:i5Qt~};K^]`)$>ClʨG=ۢNW23 r{R[ϥ
	*ֿq=4r>s?Jg
GȷP2< ŒtwǮ!Z$j+`6%{ljBGP~G:?N̴~v݁:QSQvX+4q3PXJ켟4Ȁxb&M^GP:E	fDK`k3jh蝹Lߒ֌C	jhw=[۽Hk+(Mp@Ĕ.?
f6lщ9\>WQ$EVĩ%`^ĭ&9FѴأ
Gc+dANsLӒ$k	+@
fZfBWSUl@}ٺ
n<ib@..+#wYt̂cKx{4NwԳJ_AS7/RE"F%M/3J@g.Rm)Uf4,W:o4#ŧ]Nҹtoϕ%_tN\
vc@L
`':(ye%pٻxdOo?brBZhJ
	Q3yU\	
7e%[x,_!?J{ͺxtPyqbr'#ʝnQR]\F1|ĘDcpɢÿy[hɳ	jKUx*^Xc5
luv{UEzfET
/I2v?4FJ@эE	m.h.*p;6k2)'9졠H쯒]I/B(4$؏6QH?<;<wNۅ/@VkM%latc?{APQ?&ZNy g5(~axnUjn1t1}Y" 
k0˒k1ELZdghbC]m9u]l3 7b
G0-:9=b~G(ѡ`ޏOɂe>z'fnr5^(jE_p=x9qxj95a/{f;Wܫh OR$bPpץ1vڙk`#o~$DnxRXdUk1,8&c4{	Y(*R`vQ?š|ʳF{B?֕xE4|޳n]	ƥMG&?ec{ɓnCSV{7g;69JI04ȶ"GHXۘrHeN2.lqQ	k&_"ܝcDrWRO@a2}qI}U:p@diѬ\;n)_4w܂tEa9պ
@>9@|CYD@&ve/{bCNoh4
č !3%ǒR*y"A|:F5P0w;$gDJ:O<EN&PT	bK)mRy{J캾CνMB \(oƢ*K3Y@_o19oq'+?ʾ 9~X(tBPu_䱗>T='{:2cQ>i$kt-,KQt)t&2l|	Vz껳fC<%{
gs7zl鑚BK/	*ѵrzJ+
N{׵9Qn8rIvq\mm\wa95gY⡰^_Tb	u>ل91)b
H5|M4mMmF=AM#gb^ycGwR|<
ʙF$G!;i\PAR/W7iUIQ
gGLȺ:^{wRbxNRtPu8/O&Vbj)d.1
u#OZLβdov+P	H\>5Z+:8=yCO~Y)YūW`b6Z2۞xE>
ϹdkFQS7nUT*z;=$VdYlУvԷs6qʵ7tIPt&eHQX4Mq\qci1wxS`YNgeBgM3|FH9ŀڅ~hf(ﻛ8fE_yPioK.n4(LVƘ-ag:X6]QV$1
io p=ձs$&~ff

$:_Yz,CFO	y__VSNOr)	{[,LlMjYWApHSAL=iڄ:H񲖉u4UOQh$[Af)is߫#09˻Bު&q-B)
4;>e4KU\'DEQfWrT%Cn}
0}uP[z'@ҬmbNh"aiI`&˰{]:Rps} f3Զ|UliFeR;^C++ɚb:=Iwߣ3؞0w[(uy
AڬEEUBTُ{`T`k'I^#D>bƧL0s0ol6Bw"Q)UN`h_;{đ\bҤb"3H'L>(LbA\@iDq+Yro7=6tjljm].2yu:L8"\Ik(~! U:$+_PaUcTt(!V0T.]#[;^h=4XɷzI=яbN}4@F!TÁo)
+9[3uN$@ôՠ\R5-O;nA2u@׳3FK5<6oZ!RW~6rn|
C낳=A3k8mɔ]̑J]CF6ݕe4>瘝Aw?F_uYswG`EmP@WqnN{
{}<[~'CiAPO:$=E+E^NnŽy*!0*&`H	._J~r
Mky&TyH,W=X^jrڗDGDqUK;kbޙȈNol~C!^`a@bJx<"+ `ti<u%UCvHr3TLavu]|+yFxf@kN7<	
 q$fAj=0=Fw0m- 
-9Б
Lhξ]KǓ=@^INk{H+6-
ђ\S-'5"^hTYf\dZR{V-w W%:F-3w,-@YeiKM&Sׁyx<MNp	|x$tVDu]YyO?)[9Ldz$8"[+V~睥΃WۊP{A|gusKe7L
,F4pdtog/+H4íJFn1/5ޝ=FtP7T?NMiʁyb/F Q]{%FORM!DJVUINFO
XINCLmemo-int0032.djbzSjbzrE`ɒ86M8߽ͪs$
U]5.k5P/ac WkQ*E%zHz;Ex=D3&	Ahg9oJhtC=)i~}'S6Uݷ~z,^aY,2=N3J`蕠n:*qVW!r׶xwۊjtJEĚX(SwtV2rZfm ToY1`0u>4#z1q /u)BZjEۦ{lb'\_cZK1.#|ܚe=uvV@|}/e\VK)gY}eػ"fB])kY9+1Joӓ?I&am3cj5Zԕ?wͪd.bF{(K!߿2vR*1scΪ:]G^%,Wg:it5N1 46:B:>4:"v.#TԭD-7z;`3ܿCv^/C:ζg]SK~+w<{ [tm$(M3\5u\J_+i=A^7a\su9(H]76d9bPLC=!q+%dGصVW;!`OrdJ4PJwTƂoTjDpZb2o	̌|-P^o>M-R6 ݸvFwV;THa;x!*qroivnZػ$>F{o,fNUGĄYg@XZI6iU0Oي"(?9IomQnxR#+JUl\MѓɧBx#—Ė#_BHoO&$vjo{Ҳ}}hoWf;[	dper$qy<#Vtmzdpě;{<>::,lk2[]<έv~˴oߛr@9j]<"Q$w*^Ԗ@$(b<гs!׏fzr!&lqہ4׍7*|FLj=8BN9ZV
)]#9RSw[I|d9d	{ժ~@8ր6,(/9rFF~Ͷt`	 )9گRcHP	1Mo|v֍--܏N61
I9%,	xQE~,w;7tp&tӦ}äY
't-9:Z5R
!DtspϞ?ZmYKe54DzVȪ~{(>XXm$o9*]dy0l}!ۻFr=Ov -kqjhYCɔQЮ#>&[Qky_\nc=8%hN$Ғ.y,
 Th'\Q=c`YL୚t;5H7l@P
Cj#lh"cdO%?lBFDoqhrtnay׼RNj:%JWh5)
עMM
+#%fPVD5eTƫtE?gqz(P.EG?k@s;€@>;g9Ό5P>>y3m`˻J.|	$RDϾ_9eXnkvcIᔺpPSF&>9SG~_>ZgI=#hM8I~A5̗f~e >g%IqUO$bۜ9o?wL	[\yVm!4o493߲N$wbx@'$qp.OgnɲV*rD=#ڜ@t>@uG$jx*2[P
Ѩn,ZN@aq@/ܖ@to@X>ԠЙN+MŶ#%a,sw9C/{"8qi>C$.|pH"=4f~L|:d5c\B
R/]\9/Xշ„X
<(rKV\XڴƤyґ<cs(Fj(L7HO͞}̦-FBK~A5O:n_LƮGcʧɡ+3$᪩I\FTI
a]HpoyDo2DE*,)Jc򌰔RL{܅xO0)3ЬMMwLvٖ<_=Rju
3\	t5|*v5{1C'o*
OɅ+79^(dčN2lNU,ޓ;YGܦ4
\9]?ORHuF1.#W|䌛9^{K~f_(csYfkWgQBq譺Ou{.ZqrRfB!NA6
-yhண<',xMDY_oܟ8~b(LjOqHCu{lQ)ճ4UD-!rDyVp,؈HTlfžF%<}	zVSخG2\ob@CJ)Ij,{Ւ6Zt6=I~vʓb90B"ARǦ=~sW'}ޙ}y^b$ڜ1'~D2%.Lcf+Ob".9 #+HC/P$@@Zgd鈼"ReCOl5u+ç#=`OGZ7J.\߸IQa1=A$i2J91-~&&tbWJ)H	i	)תGsz	]-Hx	ҦP]΀uXbdO?2kR(7EwmVt!yW˥U}uUxô
b0j2*J5@A7Vł<>QP	\ʋc1ħ&9`gϪ|ڜQX;Ͳ"&f'F[w
!L7:|E]ګ{=Ef>M?~4GH>6|ѱtqPD@xQ/?}}k^}mmYFm/WA-d,IȸYծ.[bv ]T)b}<"ō@V[&8.|9׶9mHԖTRp_%:R`[dR	-!(+zL3;zUbS?ҶUPՊy#=&*2>,O}Ϳ!^MXBfYc6Pbxy^
G"dz
>+DbNN*}ø^N<GJAؾ)bLjnP,h3QCO.ph;Koqv`Y/Tt2*bƺ/҆k;"=kJwBAQu̫Y^5_
]Do+kDY~&&X٭ҺGQSY_%A^>unr
FK'-1ݴ=%631Tag#NڽwJCC,NpZH͈Tk~4;Q/ZRS$8zsy0UzDR &LntfOL)K쟤B}-C *Dv4TҙW&ޡlPrPyRpe+4kj|j/ L-YT:!"buO?lAV޾fK"o{oן9Es8x!ZN
ff
Yś㵟`kV˚2"'S`$rƾzK7zEH"=EĮFEx/umxChPKfd2ϊsS׽n5/}15eE/\v=ƂTZK'HtezWVlㄬk3k).*DT3ɓD{ʘ
\OQSQ0KrkSB@Ea
/]ؐ|96ݧ`N8hB-.9>i|RpV\]t=t,ѹkP猑ϡ>pŋ[?+*wިxywXw'آľ'c9J|rj(Lv&5Kr,pӊƒa	,=Qs;Ҫ$9#5%N⭻U=Ps]l}?SIΦP^U3
t>ZOBl)@|R1kEae#Ǔ`%͐dZ
c-}/@yqm(j5fs'!HBdttx+[B]HL'*CJ"L-}
W/fw 8-);je(2yq6L<ӣ_]bBl/aU.a%;a2-?mA*7=?*S621ge0twN`3v1QPrxϿ
X
$*|x|c<˭yB|b
c2`FlJxw#<蔤O"
e Yٳh4=vl7|x}SjOuTXTzתYfc̀A{럸.?
	R5L!ȸvn[+yjr;i0|Wj[ޑ*4n4!~BA*1ͧ~qqb|.%vM2^{;8[pr_uN+]G[5u`Ή_93:8
;wW11RjY/_?IPQYeFy/w*
F$<=MF&,oRޮQF	NҼAͯ+?uB`ڪXٛW&y%[/˿PEv3iMٲ=U+:3`BE9.icwStS*jA\e[+5X
{^72_*5?bt2euW3lar,Z>OĦ
cb_y9[JZµiK&Ɏh:/k4`/Tb7P]x꣼^}ꍻYT$jY|~twv@ܘ_	A:]G
Jl*	{aP+
298"m	UFwKax5F;tr-d?b.2%zDv:0ǀ;ł({9G׋coǫ^33>G]k~h̀bi~o
1KYMuFORM$DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒ8 3g3Bcco5 (`?ihrߧ-`NOL2ĵhȌ6C$i3hJLRIe_k]3p(tI(X-|^]Tʫ8jA	[ pTHm%Sl=V$NʊɻS Gwu0|gj9^E+?\!й!H6HPCJ܋˫^酢ʋ˾	4nhL\QnLSF)QX.'H rd/Zcά?@xL'g/H]I^3e0۠`S8!xt6{L?6REdݷ9[`FO-)'aKiI^.:bk(TS:3o*fN,o8&%8$mП\!%9<6N<1@7![G-ij	x6TXqY/NO8$~eGM)9d1˷ jf
D%҂PE[.Y,?$A3d%I;i
ΰ= NG{f7 Y&i>{캝,݀6=7}ߢMT:_e7Ha3枸Lsx
k;8f?nH,wID

ͣ"ڌ!\J)gBhv.p
RjùkL莓KlG7ʿv.Jj*i-wrm3yb#*|X[#	`R/qP$[2=5C-8{Ee%,býb@bȼ xK\$sJ*rn/B|{ߘ
G:v5f%cl,OgSe.w9(IÇ:Ee/iu΀)1a_wab\ߟX@7kW	# \9JZ8v.tb7L|ϝ#b>x+7A,}:d{s}YUK/_`00x!s\I@Gn!~zm$pr7jԳH|uԪ7ωP񇐷.z5w*yZakI1YnO|R[;ٔY@kF)rF
ZmZC?2uWs
7+4ŐS$>tejj3%BWaZ5͓ˋAhO\hX[;s"w38	8_qpDF;/WRE$}NyFOL]&@u|sḃ)
Kc;P	n`_YM#HQt^ev
.7% b-';D_ń^w|YiQvkJa*KIBs lwDk~]1e83'f; gK$fGnRnpd7NC!Lʋ wwSNv.z˕vDnPR#U}ݩw8~#@HԝVT*Jw37 Tg棶jg-z|̽:Iu!0Cn74Xq ۪32OM0)ce֓Or`
דXgS.LZTKr\-p12٧pj}q#^,+}`f
>%ɟa6S#*д%d ,EY~19UFXgٟ7LFZ_@Uͬ(i-";dH=\l_%wzcfi׬zBTMOd*|"	EO`Yl!ʍ~C"W~Rf3 壬g$Ik`xC@¶ST_=ya˧sۮ0LB"7<+SL[Og.`C~$.~E=g~y[YMn `KA},0X0J?Gp)5:SnB+©WcT^s=sX\Z7@L>JyF)/rWЗ(m	e}xV20񧛏;Ѽ+@
zk{ȏe^wi/
]2:rz6H0O8L'F&ÇOfcmcYzdchϨMڍAV /Z*vKfꃲjI>)x(4dRۚ@(@.L]Z
>dʅE`|N!8?
媬ƒM%3,0Mbw'Y1kDLCԄx@>Z1J_YY!"1@KGdD/D8AqE*E_~^
M5Mm}gܗ80Yxj~
h>U>{&k0&c
_FbAUSc}4gzh*^?Vo5@]~/!Q0Xii#;iI	sɚҰ8\!beեIERAosE
kAJ c˦gXs@1H^.Ea^(sഢHDDܠmb@3@ܕ::[k}%6#=I%F?HXj&ZX(kuYky>mcDS=HT1 />[>[V_
L4cf?QZhaB|<{B{
ڝtC6Ԑ%}#1 #	c41ccD7	
y'Wur	kr_Ą:MWFλYuB@t-m,6&#lmȥuNPZcQH[&VYA|L&SԳ?'=;KǸg?F=;vӕIw#-uTS=2f;r(ڔoBW'ϴ~iE#k6[;^+ᑩn\r2t#F{)ƳW(
t[B#/4N5At6c-1jex7F4A;42A}n${-(us1rAOr.v8y6Mm3d4/1
(!S2p۫ooj22Ʉ<J)X]|}t> RrFX%&eN^\#'Cc2FkԟX|]4B޺_*_o^{#-1$z&U8Zӌ5
HܦGZ0
k&et a}q7ԉ8\ȀSVm<ϊCG($jwzzdBMA|f[A`0JeK[\Q)AH~>q/. ArLXv7;e2΅d
uprt(f*Yei>A
iRr1;={/p+uᎬc>& bz|3aLop-ʿyNNH=z-'@LȨbMF.1-Eg1bǽw[`$0MRRJv4`S	sفkڛelD,&z/PW1UuBI.J&߫C6+="̼%2P9'266[_Te<tEC#1uD;G[	D{{bV7t$Yr@ITxWQ}3S6PF{N*A`Y"k1G0
v%/ڣ2@dGG梧O.gQUL(B71	Jc:e$L{|@>ƣs],o2Z2+~&r˩J8٢>FS
ͮ~uHvϿDt{Vj+ū4=T6T&,PeEU}7b2)͇#T& `^w^n^5Uu1lG
W}d)ZluZFoG)?P'j'Ia)8١E5=:cu hβ΃g_vMy,!L,y4/?UaB>n4(ZnYm}&D[A:4`wb
vX.2ί@@=޹Խoz15l413e*s3By->ܿ'.
(q}$`$T8o`_8rp5"LjEJ‹Z_X7ĤfIW`o'ySC1n
ª
oԋbY]Z(հTzd{Ag>P=~OŘ!pt|BpO>sߒ01FSKMSuv?N,\
EnNYAQ܇@{^"GΏ}dڸ
fM[y1M&V/,3[$BUZTXTz6݇Hmt2g%$My-:qﭜ+3ڝt	8j:@w[qIzໜdۚ+wפ's1AIxCHAG+2t$fYì
h.;A4ӟN+>B=^_H'9_3SO7gj39e6->Z_ J^D,WRj*"6}ٻ~PlyYA~Ng\ gϥ$]\FKzyM/`7q:k3 RI<[qwSTi~zD3Tw=[~6i39Z"κf9vvSb^g%T}je㽩QG֡I7o>}[Vy|4q'xՓ8iSի|ɠT4ׁPI5Yn}a3̗{K0Ԛ_ӕ5Cj2r:-M$MM%b}-8)YLׂ^G2:ݼO6a
/RZoSWe*1	#;v<`36SA\U2,5Z2k{ц8/^7w#nzAڥя`.'Vȏ&b`p>e;kKwFXDdyJ?$_f@Un,0)eTr>jCAPT_8CH_zVm's4xhf25XaO-yLݭx.ؤT*s5x^H"dXI{hp_=P4NZw].LjV2DSf/
_K0	|,-Mz5O5f)^rh<=(%JWրK%^CCh0W^3Gg'2mڟYwSzf@Co:_$C*nZ!́}Nԃ;^Ee틧.`!*H+_
.2wXKAKؘu<9/7#ŵ[0=>oh&g\8\<]W>Fw9v?bwnFѓ$$`ᆧ8bnm~uPkԆH!u.д}0j\f!<{;:'dfdy.Xɘs;Q i.gh^7|R?7
ׅbGI5eXЭށ}^vr,lK0gk7'ӄsvdmx!ymZZT!jF|&-z݆bZPVW%b(ɮXYko1˭k !fxdlSwvHKcI3x&9Лb|D'%*&vW?OS9#XU6{}ڭ>h)L4E] `hJO_"P4d9m󞰳/z` F/6|[Sj#n._#c=3'@I^(L!ޝG:3tU7L˃
u>
ja%\a0dlAW7ѺgU=s7ɏC
#|@_JY?vyxro0NOk4P}L nZ#PQ~g:Qg#ZR;ZL*׷=פ\aKuy wH֭~!F5""moV4֢3)o*\0݇?3N=-z.ݕF'`O:B!(*T-%-=҉5NfPmd_^;@*yo
.vu[B}!@=w`]hcFRT+)m\^2+"l&Н+8\*:&Fy.Íl[&5&[/h72)F9p(:nKԞXQb%;$ZjhS!!buulio01,Rf=:yq1
.ja #8e;<<2@>ۥ;WBe%6]\'G .JmBƱEN5=Ȉ2Q:=ʂQ_۸-}Vd&g-_NooС~?NWPv'N̓oﰡ[!?~)^bۂ|kѵ*"A;0FTꮙf\َ#D->n2P!ؽF,aMkqoP6o߱eȚoL'@"ёs#S`ywP+]enjrMvuBÅb+VB!tQ+C=Euwq`/T#i:,YvY`Ma-53@o,P+l-(_lNjwP,Ukg+֜/ALxWkKdVxJN0o#c`$<NtIp#>yVD! />8W͑V^#(|%Q8mi8&Nz'~?V.>F:)R(L[pa_1퍮z%
BjRk]zkǹAۗ+a]9qL	KzΧFuK/}ฟ]nFw2PljSE2sAYrTz[_B`cIpü3_֯+PWwP/ƕӀPl9oD;S+{,u{|om~%kqB'/:x?yVh	YErLLkS&˕bI*@}lksЂVc]ƴQ)gzwܘɷLИ Md-U	&>J0s~fֽP,Ԯl>y85ۓ&!\ƠnɈ
_-W"{
,9$^첾)C]*n..`ҡG>jkwL#,UݭfszFIEui}]Pl;®̭+
KQ|9J$Xl?6_L?V<["$=uïc="ia=#7&!!b PΨa%D&ddփ?ˆ8G0ͳ1wt("g=TmgrOR_aZ)V95=S*`LO(̳Έlc+ٙVnQHUQ𭺭j^'MXAz;9
@ol@XoBy6OU0B`ʴޛ=%e͑UOv|PtD3aOs#OH0!4xQQb?h57ٝoL2^.dάH˕ZD3Y5W0gz
\Ѓ@xaר+x6n՝BroA'xy|^QQ?YK 4)f$O{0/y6dtީA!"=BqU Ax=EI 15"pG(>x$rW@8&|8ξ/ 9WIj2,qQeSBeOxqLO^=@9')窱
!ME~_}UVwmoJ+S9[8D*PtG%R䆹}/{J|[ 8~(`_jY1{NibgI0ht@9@0WOA죊pfs}1GX&ܴ=g2%ԾeW^$4TsK<xIn&	_74kT],z
VXgJ}ø>XsP@+޶w>Oie֖tգH[JAeSשU|Q'r
0u%0CQR ]dǖC|>&7D'B %ٴz	AAM'!9Ncs;CSE!*∌%ߢiz2T񎷢T	ACj6Q	dk|`k5qC
am'3|dxWkx(Z:	{?9]V)u1m:VDG#|Ѯjr'}Ph~o7n	E
0ЩӬF*XNjxw9=A벱MK=ߝbft c}YqI'_VVg`d@+#7x"[jެJg8oPWM`$Bs|YV`_*nR.*f^`åmv/˖^*>&H-ep;IuYrG!pC*-B能q2ADؿn(lP6.1'HR{tnNE-}]ѫgʀەc!i=nt8172n;#|M[	G2Ӛs64B"7臀v(ݦCb$7дV>ѧь!# @K'4D1U[rθnSﴭ4Ao˟kx=K'xINbQߤDb;VuZ۽ېuXXJԘT]~09_oO+f`[FkM^J2@kX:D:#}&π!Fh-M}vWef~
bSPB
s!R-Z!wmnGFdD5V$X]PjKهu7QEV6L
G
TgUPrT{}^ËKq
q,PZXeD5Kv8|%ı_2CD"FHu>{RŬ4fp?<n+CDpe\*k'ݭPzJbL̴~G_K8AڐGN7;nj1|" HVP^Lx1N6V݋02Hc:hшMnLԗq.*R_]
fR5Hjp;Ζ'˜O_c/*woxEe _{lTFVơȗ-)^Y0DP_̾VJ>ԿD1K+CZ2'@+uڌćC\=u	>0G4LHcQC#@wqFY%,Լ]&<U4]mL:$-e>Ju1hŮu#:;M>So\N*I\
(bYһ]9R卿/
	.Øޡ,Nh2JAi@#p"{-
̩V!jiֱ*t@9#[	nDCDOx;6tĚG܏<3$C!`ݘٷ,,~Vr&[~Km!(l0"w4`j?MN)59ڀ>)dS&	;@y;*
>R|ФF7G8\P;o7])n4$SYF~MAx֏/GZ$n%i=Cew
Am`V~#S'+Px*f\mYQTVăC[=c܋uh4`PO5QFHZV/i*KNnq>0|%T"]+0B[3_rSWvיmcal'UЅ"zC꒖5БJ@ylzõ^PD"y5	_jy"	4e0cl*jZVh,sECՋsuL1&Pv{Ο|W\#t8E]Y$<\E-邮83u|Io`BbZI
ujt:zX̆!#{X 5ޢCȏ-SMWOzutm[
:)lM|=!č5_{J(YD?d}4qGBOeh_z[V3Dm{>t	n[u[lKHJ#Sp445υƚCXH2
5V"fLTc:fYykD`.(:“/
rT	w݄tJ2j],}$U65ն|-\A'~ew!*B=ޟb̰m;Vѿƌ4r0$R&yvB	'g:rI@k'Ņ*z/EZ96KotS=
F)[v%mc3YKv̂P4SNN;nعOVM͐Q;r	K$&Ts!yf̐X*)m#r߅?ɉu_л.(+bX'DOcv\ Pͼٟ<?E_f`` C*$3#ODŮqFP/WI+!)>AZ"u#]T޷Yp!ziYErέIچb'̩H
Gm_Fz=ҒH?DʱJ|p1wv/\(*LEo
VQ r	Y>K엶,*:,Tkz	v;`B_]xC8sU؁DR5 }/; EzhpfWyxE<2ȫ݇cN5*v^ب p.I񷛜G(`( 'u0#qށ7!2TJK_6_B%dܽ
hm
yԶJ2K*FZ傿+*$SY^VdY)B8ZeOI(={1PE`}r.G3
0bdDz;\is|6_)0"kxn0Sf2k2V@^wZFD*))1̈7=ˌ$%6XB?檭	mC|$]til#F5z$R!t`3cξ7ǭsN|F&v^2>&q@+Dui1`UML}R~)~o~.U)]j.CԒ\PfEWj‹_.~%]yگ"%S)8%Fs͘HaHHQ$&ǃ:zɱq(rp[pyvKmGJzzOp}CkFN 4" B'uvmfD}'\Ed؛uIj|݅+5flRJna.)3p&_0I\LvŎ4G͆Kt/n/wgL_gH)&
2PiQp$Q1Rp9
|W~Lt)K!5>͗S4=%?pށix$WZnmO'し2ItsΈZ_k31[hL3NPy|{K
{
1\YEP\/K/|)6ULbRBwA٨)BJ]/P]mB WEf~MoE m@F2L9?TXTzݿZHŧGGJ?mbh$e%9,v̷9)k'
DBek|;h[ݯ9J[ɑE|(Lq^
/<F:ig[T:WY쿶W@3_;<nhrw@,u(vIgeegmo$SI?UgW.HKhWqSmeh
<81,Ь H]cOꦱ|iy”n直u9YNxCg	`
f
Ahp]MH|6 j|YO;iBD;
%U
Z%Z[~0߈ht
ؤ]$/`W
aI܋+5fh'I_l|"JGg~%:xm龬F 88dtVnK.:|͠IQ۫aT6T03(U&Mx7\kO!9i
D,kb?ґvvDu2ZuJb"Bt͕",k1/D9Ta&'ͽh=O~.2TLhYəe)T~=76\HeXff/uA 
	Vokοw闟RԕI"&O[$mYWl&84/̙`I"#lj`fV䆣Z_:/C8^{WFmmTAER&
U_6&,DQ"t'Q1yd
ᙟ@to+kCS=l2ov0@,'g=O`R5Sn_!R@]z뺔IVw֍@qZog^XUT=!}+$-6VD$3{2
>-]%#*.v-n?&>%~֢f[r)3K@z !	ø\o@KDˉ6u'-J[L]ߥ^vUT>!,XhXՄzN-1R(%!/};(‰#*cR{V	u2匋?;IոF%VlJf_F֗lvĻa],4f&ҩcjȵDt|T\Ֆ,i+vCH["ji@Bɏ/}`FJx3KD$]4+4K@1[k}ksw5d!4^ݯE
 1%FRحRT:tڤO@Fy9èez2F6A"*$N.dOhy9/L34Hn%y$p>Қβw.=sYvwYy?HvN~yG"ut"=iJ	H&o@%HڟۦgA?p2c_On")kV5LnྗYHq-L-a\2G$$Z~[m5>
t<KP?V]1y1! ƓG]}]$oL߹,g\Xݠ{k,镫a:Ib"8,z4[Jh,eoΕ7*><¨gn/vJ
;U;'ֆ$+b8@FR"5M0ADj"D-QcVzIL*wZ~b*oPjjYyIJi"zOn"ۭmwIp*=b^T`#.W`2A_[=r+*}-l~w'y/RKg] !ӳ/3FVY̿IV)Š!č5*byIoMY;>Ҋ-P{bh<;j%0CYX*,z̋_*ylGw "LI9^)ۢ
g/17  {76ݜ:ݥsCa(tK2VaX'Ӎ;ypʗ9vnS-M
eכ8؊"JG2#Ddy
n'peknv;Tm8#id1zyI5ZCj1I}p4y*
'([˩
nZ_L+m"1n{>/u!!5-BlAD`:bRJj7[XP
PTYs>FjģLLnζQ"(
/eGut>$E7I®z_ޜd+{d~?\3f
nI3f0aҝS1xahTՁW.ϯ^ahE*%;T !a`>kx&TU3m~ΐY7÷O[(~2rk2e0|s
$0X]x.ҋݹ
}35*#3+YQ_܇ļlNƻ⥺Ö*ӈtagmx-:P:LT?c@/bjj-J5t!}dЈqm]e}ڢ6]͠!cdom]1=IM~ssD[W~P@fC\3L ?zt Vyqhr	Dy?*CL!-%MxrtN@xp&M,IߟKH]ϳs^ ^рZI+ݝ1l|{@Ҥ+0DPoRhH ʓ$LMIx	PN"&$PLC1ʛ#T_b[	zX.3b{"\˯}zjJ'ݳ]}?~&ŽVЮ.R{eu(KtJ[4CgER70C6q`^iݭ	P7qx0Q%͑m8GG%)Kܜ̠PcLW`zuM"[7) %L$h FY5}Q#
eDzTq]4K-/.4	}蛆9fݟe;=
		[j&EyLN;4n7bZcW*qmwr$ytFjѨ
.
pe"jon6]/?`ZEcrTwo`X]ҿ'Jj&MoAַ`ee{Ic43#*
Rgku}+D*LSAkX;>d'.€:0MA>'z5̲]\Ɩ)Qɏ[TMXl6 zh_MK+xmlpk`?J'GGt?}@:zu>&DjSrk$z`-I2:hN6Tș(mo*yLfcU}|;o♮U:9|Z]$"J'|S9sMjY$Y8LMm߿sdoWٚ]FuBiILV׫G4oEkȐ^12nm0"7(&xʒԭ,tdzq>**G/k5K!(&Vcl]+/|Vamz,OAա)>?mp&LUDwhu܈k~Oȭﺼ)YojGm"0W.ސ8qsD

·!G/@ULf1[Tj¤yWiz_DY?3,Y/(w0fȲ/ȔM`{bbAI^0o70U֋8ņYB絀=<]b,i\?@?/$%k"'Nx0Er)ϕ*qu+S(5Ia1`*D>3"%ǖhAKr|פx{zx:Dŝ.uz?(">Xսϡs0eJmw&RїrJGE=%Av~d1|8RKWgF
dҖXۡ/aUlߞ`űcKGDDMNjhx\zqFwҁ7X| 4\HKnWeJr}VEP
Hii-}D3o%Xz1a	ޥ]z%_	[Rחs<"2M*Y&f[tr4Hƶ$x>9hV\ike(%mR2(g6lQf\{^DgDzǶ/%#u,?[j^l?uD(6t߆m5]Sk5;-Lnu@Oa^(rØt'dUV0JHoH+/[Blylo;dT-\f[A囓9z	_uI%nĭ^(B$@d$4b?6ŗ&_fE̵¼xp%f{AS-XMg&Už3K+L&a%Y'	<:H8cxt%c@,`KAnZKc6lQpE+;FdVQXy20ñ&XMUy-+?S3	!h@[d?lÝj]Doa./l{3_zclJDۀ뢜8/>*/(ܺ/tV>)-;Q(f17zÚ~Ƒ5O?#	AB n|cc%lȜ5kbUw{.#KtxMyZELKM.U%¾N<8\/:E'SN0i5&C
.l*ID0T*,%8Vj1bU?a&3X?5_/@(M@!Uƻ+P
~K]M&t]MhjK*kܞDRjGЏjͰ~/nB]ĥɉ+Nd*"ݗ߱mz4HK|@톼ExZ8 Qqz&&ǀ/‡S
iD?#Le'aZAtQqql4LvI\ƺvطVX2^>)1+W2*hW|VDqQE\[ڎj(+a	Ѭ9OPS@kdHOʛ˚h[aLf2n_UXă~zuTsJm4
loJA1W]0>X@9OI@R4fώ_6"G8Ƕ6s'n3/`梁{xB^'S/b+@#e|.1¹sI^$} vvlR ѼrE	jgVvq>o1.ЅHWlwpE70n<yPraP-6ωW! `*`	1^L3c"ONdȪ.
Mt.ݭ">jG
+e! j,U&B|KŒ>hx;}8.;ހBaϵhݸXĊC܉մ簜aI#vRK']M Yuz$JUĖ*Z#-c/ᓊYɈfMuGJ
eݤwDmt݂NgFUo[h`綗v6K(nCfA/zpEG=.#Q<d8Hzǯ35zo&L3K8>3~4¦Cihf
)Wv/'w-"ZBWI@Ԅq	 663rͭ9Nrw;rK3y3f-v3dj꾡;Dy~p#cI0U]ֽ~LԠbg㭴+-
hTRP>FOg`6VEFAr,V::$I$c.n2.֖!~qiM5[ ]/? 75zfZ;Rٺ8.Җs"``08cB~r}NsXn%8Ud.U;kz1мy*wR _TXTzƈn^h,׼Jċ+x]uفreMno+fS#`@יz''٫A%s*J	۹qa031Ѐc#ݲ kEZi)8;z)k}۾ǂOå,ʊYf(dP@=Q.VF	ES*3t2
gF/4|Y082[6J8i"x0|Ki^$t%$	lIOnRp+iΔJ6`vseV_,Jupx1)-6x"oXM5Iv$scaC"j뽾z
gX./L:Ȕ63e*jұW->aE!+HQRjV6CAdaWk]<[ĝOy.S7pN-%@Ae^} }m¿1&]DSyܞ
M\g	166*om5{}E.EN1EQ
YK.|ctQrs:)
kʖ$vUy$V/-岮i5)G}'+"ZߝW޲"Zp^IVű#.jcF/bA2<,ӢkO\W|ہ1[<)R]8(\6˿DYiAQ;?!?9=}Ym[X2=dZQw?ȞWn^z <ĭ詩}>^{k¡3҇1ͶEuʰN-ܠODb-bi9Ɂ9γK`Tԙ_h#ŔȈ]fTVJBYڄޓ)Qw8{+(%d%(r:̪@8"V!,&hsQKp7WL)ѝ.w\=d:%ٻuxN:wy^>K=1/k؊Y8]
$O
Tu>l4l6H,ՑtPz9Xmhq^՗X#_XLup$h̬"-ټ_áUPX+0rKᘥ:
RI01\z	=`β?T?>G%3Uf=ڋx 塰C	b"!KkLU.aleJ>\3F`^pFlN"Aq/iǗ%6ciOؒ3~cZ/V!PS*sɉ*ŢRd_7MtR0~[QwK|BCSOV7C^j'׽?=lx+iP1vHU}koC1 hlX"^DG['՟L`cꥫ8ZI 3eB$59L8JeÝ{oam?O+LmK65АvoH68ZM,Yg!(mR\
l["{-&G?1
]j&&nhefU}.Taݤ4!)3rXnƯ`oE%a粜zUP^N;dOo$ cf}z~;tT)	uVʹ–m.TcU{,,c; ¿|?E󥦎Ղ;T?i@t:i\@N
@언>tVB56kڗfnU^›齆|?[I;jL_Ǔ8jIֹ4)bdoWM?>6*w?[YZ48?+XV75DgS4K0~lQ&Ѧa:KSg^CzkpKah(OoAà8kNo"|+zeWI$2crȻ(qC.vQG&z5B8-M=jӒ7l6:ɞoA9?{d)|2$Zkh;D6
k:M'}Vb+\~_mYب(?Ƭ8(mcSrN*y㩕)2ւ,w{v%]'֍=ZizYVNsaPH+hp*utcw`UZta"XUrЇև.R
+G,p R	.5N[
c\]e["i7vyr$N0]uW|eIވNbVbG}t>!Fޖ+}/>'783R8x%x௸fj6{wX|fEI57Axy:|##ye|?,o\Hk?N)>i`'*)7115\ǍWʧN:nQ6HTgm=Ϥ䒲VQN\ǜK̈1$:g|O߱/|14Sau>C)Idw:&)?
2i^n)u8L>~`XlW䰮uMI}\1%c{	[GJLMo4`Sfr:;Ԍ7=@aGɱ7Sxl,;Kr	NWf|c);E?W]@!P~+v(a{n^Yt͇q9q9h}x@yINN`k=hW6	jtCCɚoR}h-Bv-	E	I؍f	Xt;^,~r?d50ɹpsB&():e`UCt׾P.*#]pzt@cĴMAGp3\4wޛQkEuPY6ijTJni^vJ7kJq)JWb qlfv/GvW73BC,'\"tӖ	l(Kag2KA9̱I]1d~"ua&Z:k• WAv$	2y1^T0(R8AtΫ&?%~I@g7#bZPT[l3\qmtaN9R840QHz\$-O]@6vkPYptWymJg
~Fs	_Pk9KTύשn5=26jH?,/(+SW*Tv8tW܍4%\`B $BpD=\6.y;uC]Cn $ڼ<2
BK~
%`^D6\[aVW❈91D}yMl&'?U0+k`ݡn4=B0忴.v,!#%\	ibPuZz giљ>U.㑓m 6s
`*Is;S@k;Sƙ_:8w8"sհT<-LO(O{%(|zgb*(Z"	P\4ؾ1t.D_A@Lps@;Si;&sv:J5ƔQJ)>y@g{hZ#Q]补^ȃ-f0/}\wz%4TJY	F;Zygэ5d,n|9*_E9[ôPKOWK'1BDŽ'݆@cЫt	b
,CZ=qQJ2}R㎉#g:LcC:,2kE9^HoٳckX˧=*KE%
mcoڄpjɋ-@\/qy[Gqli	q8I@1zs
سA3tAeV6c*8q,k>XldѫIG\r%
vNER+.l{˼|G8pz`:zVQUg	UI/@l6"4eTy%DNb>k9.'Bʌp|tfF%RUI_sdheHܻTz#DWZE,*Lm;	3?AkWaDD-Y,̣l@v&\UFtVS#(C3tmNa+yȹ~/͂	eȳL'ӄpe މc#b->wb
 "b:\'Q^ыl2q8U	Iev,Xi=\|1wЄpeߎE;X=A>ѫ{qChfA;bfɹ|%{q;vDsx(dÝ'_
X	\X?)oG{=.vFAtzwsfk?@B6p @8ܵ7{1#">ˠD	E}'⛺٣Ŗ5OJ̪$J*GcMyM^LCf
|т@u6i2fJri:o
:&+mK+2Uڔmye+ej+϶
kujSQVHt5x68ZJ#Tu1&0KbQ8Ih\d;u_W{ʇuu.TZ(r&AE@	햮 c[a#1C$a1@vjy)
&ĸp3!-?E4]a
L6eL\#XeI7HL7:}B?
Pn59{?@,+XT"}F:]㕺~֍+4>@'#>n(g^?oԃ{Nk88j#/I^tjÛԲM
kۉ&	P_L泐;qӥ:0F,*;2@lzlO$o M0N^xqǐ"`Ydr"f!3B"FLDi{x*dzrwTXTz
dJ?;	A~^yNA.F&|L/JU1\=[Yge6>9+eKRQ%NW4	5)y	S{v
Xr첆ϔgo~yÊ/GR"5d9.?˨-"e0j/eUgSX*F]/|&Z:,%xт;`ҦH	K	>8F[BWw*Zr-jeBsEIF7Qhř#\3#:Jw05῕uLXm2AGNK&jwv*8XN1/Xa::2jcoNR--9˂.7erl7泺т	6I}&9ssW51|6\
dS5MܱEɮ)V
7ezS'xAigBE1<#`"ǫ_`Q%X͋nxijbV-q$e2v:/\K`0e4	'&L
m.sgȋA_ib#֯UJn'3q *sTz[ip=`F.c?O"6Ƃъ>ͧ	:Bcf-6pdNVYIY+Rae,jލｩHgxD48o=O[f
?ZD^>P
^į
~r!1ЍKğl"Od·Km|̠d1+7QaNOB|´KAf~,ZRJaf2.׼hIMV÷oTkxj&PpzqttK+?jKLF,fgl|D9o,	a(ģ{C7aJS5R}WBTC5
$Jgr/Fy
ZCrs&j0cqA>x׸-wU#Xިw/#xɼ?Xʘ4HU
HJ"o6L	[b2Y!锼?6?—Sl?T{VmB:iC$_lZҷ6a5	`T']'fwj$
TTj(s~VRhkt>6cA]^FbEFYt?C=GD2A)KWMH3^PWEէM++j
q`Mg9cgE96AـF;Ԉnyv?Bߋџ<-nwWx2`y~([?\7H;Z1d?{h{9E&2]^-[׿"c(ڝ#gIwS*"Y̺^>
f䦈޽6:]诩s)
#t:ѱcδV.lrTFͮ "Mv
7:N:xpPx+*w`U9&MppM\svtNZ[
r27<{|ÅJ/BS,0+\ӄ'*5[̊㯵n"^ڕUWg]66%'>*#"6gl+Wd|_/:MpI:OY-Ym*ufvf\QmW̑8LoWenjpg͢.hֶ>.G\pF"kkv
%ZדQ=%GX\.yFORM/DJVUINFO
XINCLmemo-int0032.djbzSjbz!'E`ɒY6}[]9+0<i/7t0}eOd]gbJ$eG%k	p4zF.#ۿ=rgqv8K	G= 'K/1d+XTIkcxY}7&y~6tct|^t3靶ivGĿcaO_l_]F^gcTR04 (k#T7nMTe+U4;Szꐶ=L70
ݷd @~RR"rx I}}rN,^gfųƍr8‘Fyz˺)C;L%#>w静i0=F0	Zj:V
H7B4OS7Kü2HAdc(}T.?p6G=>~B7[ձf?
M$ZkOب
7@R9_JƆF_lF >"@.nōNTihȂ&ʮHU& e/]F`(BɱyUᰓ;:a%fµ@l(T‹
g=ՌTݧήB$tZc6dcl:u@**'j(P,.uΐ0%'4Rx	<z}kG^	!KL+F5
c1A
FJی+zGZaxXQe5LYVoҳyKPn8|*,HRrdp`3@jLLl;b36m@
mrh@
yHn-5;6ҢA],ӹEP;9/ju?ЖRsabBD kAnz[>hS;=纂ZoKjlB;S
M1f6Z' ܧ-,]aU.o*5ܛUsSL\D $TN8.ap#4&sI
;iHs_Ոk:Κ,H4#=®>6Plc{(MjDŽ:YS;ƦY3{\$ӪV#!4:~W7
Xt"4|>3W.M߀{0v-PׇTo4^;"٨B[(|2CT?wo$rsucK8;*=|WM%oȹlD1/eiJ\Ɖ(FZIɗE(;D-x⿆1ʾW
!.9@RQFG˧0n/~3>*DZ
%=zC#W,q\	e9cjʨS-ȨY+SnNKx$S^Lw'gE11ʩr0Vh#"4?w	}#c=3vrDY|w~v~Z nNQn,/\.9D+Pi_LIv̹>\1Z-Tõ	4ONq8E(=	Yurb2SbbP_s%p*ܫ&]͵%7:P5dUGLK4y,۶!*e6. S3 5fHF"q~g^Os:PxZ2s&:``Ƿ5p._΂@L=/Q-I\Ȍ)L=wyGqOXlePku0S9.k[f	;Aw>uBgAMAt_YI9df
s0߫[08;pBXӞ/s!1F~YUyT%'y@o#M~9;£gvOvYJjNe
s+/@_mER]m?џ'wPځg'ZoK4s|@ڧ)Ⱦ-c^ qQȁp[4vLt<=ނL4)k,TSQ(./[۳?u$I4>e*7-JkߍLy*q%=%@ZŝrqBF&,>:Q^şU}Iyua=Z2Dltb0PP5:\B7"\Y.wgzO8d,E^T=m£#16@h'6@$8يc)msG)Wt;}3Ih:3Z6#eB%KtP#ܮ|u{la$&L)YP(P
0"%MT	k<__ڣEi[֍>_"F!uavuv/Le%Fl<5Cq2=Qw q},}GA'&ks^ŁzLNOd+U]3+j`1/*I_G4	0>ҙ+ĎL,gkO:\zzZV.Y{A\޶{vl(SoYwM[ui	hťK޼Er>1X0+fE)Vtt]sX_P8gm%/`kd"ݕ|*VE٨?)'C{_`gEmou)2kuJ/Zp>3g[ހR"6P<M8'Or
P0Ӥϐ
Pޣ8D8a@-ް'j܀4J>cM3C?EUxM\bĀWzFAz=Tp7>HI(iN~gg:\]"F&'.ɒ1\z,1ۺ^\ ۻ[Tу"J%S&lgZrR}EԒ3".!M0WEJ?P+J<9۶lLW	+,K;ץUxIvuϴT3;Vo$+x
/ά4эxrVCÿ'hFRq4w֩DZ0DjaSACG>m>Ccj~[b8CcxOFčP
b6)Pr*4qg4i!]#IƇLQ5;DO\*͕DoqV[\)Γf3퓩WeC̦"3ܕ
(\֘@s/7^m#tňcyN^ƾSD*6j]SKMŇͮ[IcH$㙭3ze`y2&Kzy-MXD]0{XĉQH4?$2s;0sKhңԨs{G ["J]KI4N]SBR|Y'qb]
ܶ%e6t!'P2B.EN2s0:@gLt	֚q&?,%_aBOo:MPɠݧ@Z	s~dA	tJ5`0
ttIR&pK|جּ׬FRܫժLX'8=ٖ@rLPrlY*‹/BŅ[8WFϝy@k摁GYS˿	JL(ԾS9ڠţAز"f	/hglO6HAŕ!aXTmFÝҝ51um{nmʶ_ 67nƱ7_r9/)o>Bk
~;=sC2		[
2Jx'~zX߮~H0Oe"旊s'IMT9ipt$m,CRT0EqW-D/~R.~{=QTx-c95CAӭp.AДٸV{'-XE|)9%_qNw@LT=kq~vVʶC%zbDd63k1p˲Uv5Nr F&p Ќփۍ^\|QzcLSz!*OWgE~#tU]s":i((zGAƠ
!VZs4aO>ICS1!Q﹜kr--ڠiÅOT!FuUk`OpyNbX:`V{5`mL\'AI=\SflR^oeנ^5x
?GgopAʌOK~BLi5	lWC,0YqMI1֏\XZhGeV~fKR(ؚ*'j^ϣk^_5Γsxҭn\gw/<('t4<0b/c0#2nSцX9ȝ!ֈ6hܘk!`J(s=ƀxD
ӏW-
Ѱ).*4Mӟ1윢a
O/ڐ5`E*LTVkQpOk<<˧@PkAbF{8]O6˪`^;VgѡI6vڙ/~h'b
_Y5}:4ۯ4}0/nʤ,{DQ'Ў[UpèO`x`$/jE-g		إ JB`S',},549bpk
'q ZVS-V઴T7h-r褅؟QY4[]%\\ˮ6A
ҹmD]!
) (;P돒JJZϺs7>iOOCN/g	*͓KX!
;
>I}]^Zxsߞn (`U\a% )bx=v
QrpyQu>y㭩e>Ͼ-Ľ/J"m$@pZP	
#7M	W_vcjvPBֶ
+h2b!\!h_Wr	%?
"5行BK|"[R
	A>4Gڨh}ؼ8Y\R[$i_݀TgHwޥ2j4DJjBCCǰi
&PG-7oMUi#b7
d-Cs
<<+;p+l0׻Z8
ȹ!o^ 	<\l8%e3A!E	
9ۭCl6dΈǥ˙

#lI*2h"jmn*>-aqw
\Je5$:A>zaOVRo?ui(]cTfJbbo\Һ
0)ire?C؊nKhE=d9'X˜yvkI.]o:!,p/

>
%Y'ҩ̄t#T-32*,хTi]OVWӊ,_XZ`-Vz6φByW0b83q66A}DnbvĘ?гtQ?y8^Ī@Bxq@y~ ",+$lYK
vToIVzqϒH:Q&%Y	xp
iqhPr3 :|s1vڸ0eMLS(n[*h0yp.P0ؠHwA	AEe_Aű2ƎAܬgy;ORNaX\űfH;GKz[}DêkTCJxfxOlKt cy&ꆾ.;.5*䟵rvq-guduT]oMZȺOH	G3k5!okoL
`|BFa)c;o&c5Y.l;.7[64pv:N;ѓ3_=Jx
X_!j6=NMuvwQ~@OtSb5^ȯu}},[U=&í@t'ǀH1}C6	+b
 ͺv^KՔPZ	g,d8\Ҳ{E\8{
Qx_s\ImEOiə]m	w1LIHZ-"lt7/:|  k!f2ҽ""F/9#1(KKc}}dmJ[鑥ǡ
-U!	w驾GRp@SLֈP"6˼V\ķCXjbHɽ22,"R0wQtBڢѥO|8:xi8Hl`EH)IV_ގb[)򰏭(j^ZS6#LȉWWc+vR	gJ&4.ze-aRP[WDDL*]Kߘ_}:seP	3NT|GȎ<~Bm
U+QZUz0_i#)%xbgX$!ҥu;
t2`gɤ"¯~cCwiS!~ڡkRA񫑻K-1^k I҆S! ѩp=Z.p~QY^@FFweKGoyϮ2=NzrnTH9	v2ʒ'pkW*.~@A^g+
j8c\2zG{H7zj<ٓGIj0J3TPOSBA(K6u}rq8ޗy'A_en.ZIx:ebJ=iC7>J(͆]հwWyw+ߎb+F
^8dݺ[s"flz&yvMn)l+ladlN/iAz|>߶^GiϣϒBؙm/-X9VV|ur"|<5kg!
^%ϡkZB+3xZW9w]1&Z
'
h4RRl^)&@ܐ:B]^YY}F"%	Qob}zu2m'HC12/$֝ƛ@nF!|ס٘\2nT]!M*E{N
}k]N[uMA3#L|/(?$UAK1Nͳ/3ba/
P"pCG/>L_dQB)6f,Pea0ߑY ?(i.V}ՉΎ2ιQ[k2'AXwFP٭avo^ec|mRtѸĪaN;Yh#"a*Ց:EE>$(3GMuryÇ
Fb.:BD~h\Llҭ6kI+9 Tc]K.рVblM}ms.ݒ6ώ! KU'dR½y	)tS-q7eۺ^/t^p}5n
Lё?Eo;Ci<~Q|)7e6?\zg,"4Ln i@i.Wvbe91lE
G*:Hh)^c_Ml|%Dgו>d6ˎ:ЦHޑ]vů{M'v>}R0ɓ_f["K)Mr(dׯJ5᠚,ε|riPzU[4,J`Sz7#;5.?Z76C迖)n:pxEĥ$2"	kJ_Λ9CүqciT"H܁/Q	*O`}P9R|͞
'7
V1&T؍Ӯk!L^ (5Aܮ6xiHF=lW^[f=؉byuws5p;"=,U \ɂ"V6K;[	M3fTӳZ/R_Fh޺6&j@eI@7e}QᢳL=16sWv5kÃ"}V"*6sTa18?ZڜyPMT#n*
kI4yXq}336A.	&8i[R^I3r/vmo֖s3X/}.?!moҰSLH/,xS`8,5~kK'Jρ81TCw_:R0;RCg) =cHg*3OYYgdN^[ \(
<._S.jy_Suwg	44WE]Z"X9ߙc57H
QYhW-Ǩk}EK
ZocMto¦r	/xMj{e庫'y~&k	ZSOl+B|AHyPSJڔzfPm^
 .,_J\zl>h(
&D.[^sQz8;5_7htC$)wELF+qc`*Ǥiaѣ(Fa\߫J? Fp>F0Zd-' ̅Iɼ~oֹR//0֙ſm͜})"
IsOgɋ35g@HyE-k!ؕ2KZztQlȜ*i
$H,tecYMCզvy{Y⍹Ǹthc.>
дRJd+zNϾ7UmګYFMVM9гHbv%l&R<`&sKU
keGy?be鎭WtT=a}K}!g3}e5𭬴'R2YL`C
z+Ci9Dv3#5'K޵rO
((ʤb\!0ys)+nO'_[7l
d'J6<wg埉rh3LXGa)ҁ#]za-WURbD·H{: wjr}zۨ0̓^ԡI׍~#jz{xr5=7#Pѝ-,'%C\MIТ>)1pT%_M(.'$@qKJqҏ01Є{)BmcuoUxhl; fHTEXפh\pL^;rpbVJD{o0@+ޏ\<`/!ҋGORa?pͪR/"q;Rι]3:
]yLXapZNX}?(6Ʋ'k;	oMVNP|RUB%s{U_96uY\Ӓ!>BDawS#vinGS1csjrHy}8ͱkk񖑒#>{^^b	GՍW&4_۞Q4' E[}\WHr$y=[=M6*^%%EڸQRL&*Og##O"`6gs5;10eQ0fiCdϺ]8|}
߽(WH,%qP
hOЅ܉&3>JjYvAR
!Rb~O2z#3H,Uwvf^/fI\[n I,6s>7Pܻ~V;Զ~
y$%M{	Rm{g*T5	
4F	Sv#w%7H}a.S+@iҰZXGU@_JY?bW!-z)}@XCpRvStE	sC=
HN2:=ӸcHy%Ma9/moCVmm׆mނXHTⅉ/CxHXhˁAM	$J	U-%_QWp5+!;%EГ߭@1:0raxUK3qυ:{Or
呑t<:Y"TICTJBQe&(ެxY~ᑂBG3Qlalv8'O8.u*UINe.j>4GA9$tl1u[@KTNbbR/#m$bm_M4(s$m_/5}_~,BTH=]	ffH]tpbMa;._|V?4qƇg
gxREd
G9P>tywKX٭tY,\ZK6]:3
U#K28Rb_љ2y@҄N~7TXTzߛd@J>إ^3GMa	T>8n51Q7&e^2{L%nYQx8{30qZp@	D!ePwx؏ncvrEcʎ?&8=>(?TOH6E[3}]E)W8g|ُѯ&bMS:[qIr^p4e|t*hY1go,kcj%v80ϭsy~=D!}=D.Ӵi2#d8y}pa|\NM<\_BHZ#sFږ
̶i +{cU{Д5?V~DYT)p@
8T
G~T0NDӰ{
kE,\
VQL "+
;q!ikGi\eaOt\VX_H"(eNc|_RW]51^7ìWDRԅ>H͏^rK]xT
e[orK@~I41!ΓA$9#
gKʸu׵sFibZjP(Xtt)R-TG>[	x2>yFYCsɛgғTyK̔6~߅
q9e7І?jQ=21ʥb0pR 䓠Gs˺P;Ouš.'uEUu(ר)xvQE:r*JDfkCaK2&0&֡F-~ePXEi_B;S0IN{U552bGCUveN5zza6ZD<6*gJwVH-3ƴUHi35k)ի	I
A>jtg?jV"ԼdnZOf@1~RKxbgV>ywcTU94Oh`V
|hx	䍔E@tΜ"ze|&|"*nT͗/~:ٓvX7:c@j#-]y׆B86>{YA.So\I8v[rtU;A܌q:Dx`K'.vg'hmFH
A).GGn+n}җy@.ax2S_o:+J0"eA
n")kqEd!l걈)rePiҨ`>{hhy5w[̎O#G^2o`Ί*;&p~QBXe'fu/YkJCթ9tJܙB3y-82o7(*m-6A
*rS<𲡑gC) uS鈤z7`3\	tx<5Rv8VoV'
kIbCO}"K^&6ƫwyԷP

M)F@e`$q>˥{wirTKɇ/G&67S6htu?V7)q
`$@|r퐁)xpܗԒ>)6QAj_ox5|ӄBh
Dݽ#0;Ia4D*j_vVO
,OƃK]ɝfTnV"Vh^YMuG6
+twyvsC4}D1\s~,vs|ɴ+=1W-eOLwҳHno/$>n=Daod" Beō8'1$=f=~ 0,nT2Es`eOG1)d'NdޘY]iEb\YD`f=1@ۇLu;Cx\!h7%1	rb
O/xzlD!=26RsLGt
8Z("Ar$*iU_N
Io]؝QmWl08?ڞdPj\Y3#!-|,ZsPru=-z{i\{GgA\*Y)0z(V(p9Oya"Ak)NI(JrnJȔ_6%l\8MȇU20[g
{|jc?MlOkm=|	xLLq[ƙtOPƀAAKyZ#?uqf[K#5E{k$\7j
蔦q	\'Tb{w]M%(=x+)f1:ܯAkO׳˸j˟Eyzt!&#B,D1:ݕUBxp|hH;S@$K4h]O3XW-AulGPyp)G\O=?
\	su2'^tB8{QZ=}>rtD^"Sj+Opx\o2PUifj|/`/oh#cf
|ӥ/=_;l?Pébc9Œ	7zayo1;ӂ.+McJ}NUwUQ0dc
7+ WL)캩8\u+bV {KLmT	x%@W6Y
%);Mc'J} 66c)]dmߜkfdc_h'Bu
7uEUfiM<5yutx
N-c]Mw?m㝫go\D,'H."ǟh5”~EO8m? l1͊p;1m_?0gmU5u&cq-1~v|1qEVΩSr+C(׽-}2-@=fwX{J}T2W$R&~htB]	4l#^QyUhy#e,5{bCM-RI4Y.F`e0~d8N\*^KQ먨"|Iדw
|`ο7^n;.fdU~y-er<\U̜DOсH!}'ф*=$B+ߪ
$D-MِI2zDr?0jRJj;89{q{9[Ja";
&Q!=
ʪA]/{"^ǭw+βL-@oCJ@Nom?Dm?uf³xlƥz\?i3WԯlRVXу9DR׷ǟK3.2Jw;RizI}֫Ƣ9Dɬc8b%czY]|ރeD,]aߙA.PB;HDEܪj>	LkIC
:lcΰTpo9揌8e/TNI	[A;@E4Z{^	䙪O\$;Z$;C[fUwf~Lń:|I p4uQva+KZy`LZ28йV)έWΰP$ܶvڞ7סp"Lw˺B^9 4fKmt&2VayFϳB֯a&{(tR*Ax][r:”FJ@Ҵ@~v.zuܧ%PEj<$xz)}
JTɰ*^K$AЬ+/]]c2MAeBLI`FqȈkKoA>g͝O}@LU ,
}kpK|ooC~ǘpnvFŀrthSPшpDdB݀mGam0ZIQso&y(yyYgͭ_͛aEL5*^nXi7W\wfmVp1M1_7XR"ja3>tfRh8BX^.lߣUQdվ3/L"6930mO',ԁJ qK'`kn5ɵ-8H=@}	dx)xy:ۧ#f>t蒰3Jv|71xOpv@&OzD3@e"Ǻ-+IaLUnI-uW=>YyƟ/oBCwr ycI%O&lNOfEͨ~MF#lUvkfKC'GO`>Ze-)@c$~Pn\-#F|D|TGdRDi#e^clS=f ʭ=LUhD1z{lY#wF2π_]`9.'?fшR9BB-3LHI%]B`<T%0DrrO\N@dWbNgοk$?(
tKZy$UJ!#	Ьr~O>0n ;pznJ1|Ґ]Vj!<8+rg/@>rHRGJ[T86(tk8;pv(Ե우=SpCzO
Qֲf>x$(jVTgG2dJsҞ\>YP|7LN5n.{[V҄{lral[2g׀٢f3히!?cիږ.|s(ooTB֓Bo_sr_*xaN4.=)'
{t]̹ejHŪP\-iOh)prNC2v/˴JIsP=v9nbj %]sJ*9@)"	jvR?Jyp'K,Z2,y\Ҹ&smH.σ,?=ɍ(C@ȞtM8(	HMbxeݦf!`t-Qع>!;CٟZITٙ9[vӍ&-q9L3W%KOK/[l?2ݬn:^;{
xoܐۏ,՝XlՁ%`jo{v]{&E`V
ۇ$=DK_OZ@IK}NNJRk&j;WH,GZ&\s^1*LنBl^DR{Vg 
?GǀRc;H/5ܥAXOt4a}At0O8e3kUg8R`Onm'	QglDXS!>ybƏGκ$˵Ls11g%`ؽAL!cօD(.gB?IZ 

*MsJ8apamJN1ՂJZ2fJ c^L}sǘ
46޽˶G(jĥ]#Nr{"g4g\{,Wˮog	EA}ՃtO`.sBGTXTz1Y.J>7z+OKƼN	:]a$[nuĆ}jPײƀPup"y$2o5hyg2Rw6]>;Yeرq-(ƅ>N>-O.O9ubUj|ʪ,=L3y);b۵(&q߅ GR,jT)O寭Nb_BLa7x!gf 0ݴ( ݲAsU8*g*r[9ꙗ{ب	}K)c7L^T@p]k/{`첮E( ]	q HAq:(QFƺL6/?܍&_=Q=}ĸf!i!dp3as#*c<}ekəƔHkG	-8A^?w~mk-͖ˌ;xʹU>‚Z510Lujm^3=bZxk>is2ݽxyCatl݈!!M5uO<5{Lu_uHuo4Djz:W3j^b㳦"D3e۬_HVd!^w4b?!QۑMK$1-1_(vYy"/6`Fc'k)³RQ6Sw3;@yhcFYZD kokn!0<ۂߡqoD;`cm^h->Ai`	vآ-BH_GX-{㉤D J[N@	6
ȵaos+l8d2/gm[钛hWU(H]<occ=z{g2ZjY+zr.u}"
{;u>t,$d=@
a;|{N!?4ؒb귯'-ڮT+'7匮|"UYTJőb\gXUG3,k.'0C1~"m"#@ܩ0;PNvύ
Hkd\u#x3]PT>Aꆃ-AoÜ5dhP5\0%1foyˮ;	!CpHd,Ԝ,7ˁmޜX<2plVwWxz^f\)\%[.m"\yf
w'Jlo/Lb ;:[zn	L]2lAK]MSC7U5?1+=ݗ}{~(^Sfb62$߭Y:mHSA4޹p0"SG(D-
mCj\gH5ΕmK"&lҴ>,dk[l5?"
9XGYXؙʌH*ϟc4Q}7\#™7DKGZ.1L5K8OgnKo\J~NAp3\@>;;=>R_(G{Y{%i5qWKx\^\{Jsb<^5)T
:nZjV`q5xz>?Ums:ia7L! NwrB0.?dXZF6%(σ
q`^J3ʏ0HM4D5nkj#C_z7)Mє'؏%཰(
rff*hm$>0TI)b.ߖƉ%ClH
F+O/YKSWj#CuEjGp7&Мd)r}]Sd#O!L6kOl[CI
y輠\ko)9jvk:* h:}
~$cKo͝~
%6}Y31|PV-?w@;a]{z0J4J&UK]F\z
'JF/FORM(DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYMXY Y2]h6-w:ß	
ΩM'ߜ1+NW^~H.5h=d:1Zxv5yJ[!"Afk.?k+vYwU;kY`2Y֗1&~+6M[Tm+
kLuJ""`EٷQ]X!ٔ9|uA\<><뚳73nJ&qa,(hx$4H
aWА,	`nuVQ?knҭ٢`Mmܰ^qYS',hT}	#FLs	TIZ Fd-VI,xš#!>ud͓kPAgM2rcPk16#˯0*VrEjk~a=qry}ׂJ\>G)u5VQ=ږ߫dTHȝظB%V-JVb0\˓KvXyV{DW7FoѳaPI2eH]GJ6:%<nYWDcy$:%47|18)H0\E*?$௉޸JJI>dGl$+gAPZx@ }UtaB
?_j#J #4Dny?́l|"`p9ь+1=nP$d[=Ep
m:'eѩ-dRȵɾOJ,Ҫ={dPn` pKHMREX^s{IHA'4#gYZ_RhgkA6ɷ?| cܿJ^Ӣr+N"ݐO3zؐyC̜Ufek2$+q;);MENޢG@rU XeR(e+-Yh|kUr@7h|(+eME!9;4B{ӏgVJ|x]ѣ(nwЭbKPGc3;5g\dd!Sp$\,aSð3)Q99 j͋>g

0cqgv'uw0U2`WMG(`u?`)4Oh894)&sGnBXh/`PnGvK@yw0ԁE"K0F
ӵE3tnȩBh2?h~HЩO.8.SC'AfœwE1Z
n[/4jгG)P\CkB&~=4wBZucQ'.Olt_N"wj%4olGTsD񝬗ٛ|"Իu^Q9.m<Ta)-Dj8."QL
Ec~ow1UD"?KS[<5%v	^	9ςTqVm.岺^( if~⋎\zyؤ	@=Ġwr2^b]Ǵ3Rv~p9)AmokaQPlj|&YiiV0M/DF4 jP]՜\כض`Q}oX@)V!x3Jg-=gɃH‰[r&NH9_h,0ݘVfTzLe`J2ñٳ
[dJi=&zO}:N_a5X_ݬݿ7l{RYiPc_kE*뻑Uk*QշaU>`ZNnӨ
yP~\zv3
q3/qJku]ڋ̉OI
Զ/@򪤦<
Li
(1	"
(~R
#FGGJG{%a>?ߪQn6OL[EԚɁw7c{.YY4hʮ#$7l	QA!Ir
p`'JH*161CJpDy˕!n2[V	ʹP_%fW}H>FZYqpi6ϩ%ywNM;
-KtY \6fVYb~fwM>?+uJ3"4N|X0rI	"<7rb!?acWW?9n̶83A%`O;Ѕ!
ܿ	~}aBXܬ`U!IOmw"OhEnG_F+K)	u<} 0\WK|CвɛGp+ߨM0X4zjAk7OgC7AwoB~z'NBeIs~3DԶ`'v'ckF~TJOO#wRM0uYCDB4I*vD$A.%kl
*ή 5wi(ÑF!>Pa:Q;Ef]pR11	;xoƮiDE/)E'T(~"&4|c
8
ej<]'2*H3s5Ȟ9HiTN<-=qxjcQ/êI+rݨ2f!x&s%GB=5kzTk7`lrҟnq&7xiÿZ;Zo^S
;1ҙ&p<Ƒ*L]}D99J>/ʔS[E$!jy8[JҮJ
B,t<*J5˞&>yu]]Utyg^:S @_O~?[?3»T~Z|߼uiUu~5h:$-2̶j8"#w;d #1{ʤÜk"<'*Zʆrfo	&/Lc; 4em9Z߀oSJ!"{G}{ >G}J@{WU? }V0k~]EX}"{y.VqqNPcub@o+ѭG,w)@*9+K5C~}Pߊ2tXXM犠5!>u!}3B©g_H
'Mbp38hpƉϨЉqYsa8}_f\fa6PSG3:2>6#?u&qB?hi@ct-
@a`
pU;dsm=D2pnƋ{1f6ez⧹'8ysg'a#lؠ^
}:}f7RTd{m7 t*nԩ苆p+5(l8%M)B܉ _
p[1C>H3p>߉Xg pGrɁLe>?:.wMGPx5d#2e6| Cc~b,L?-φ{ե|Q؋r_0ϷJb̯a*\f/blHe_A/wv2Wښҵ"65oz"񞮊tAeJ#	G_d
O%+yp^uv߷KriA/2	i^qW>\]v-Z_/7k>#5hHZ}'GLm8H"̈́mɷ[ǵR֚gbŸQ̴9xe'8nDFaj@M(M&4J'kUT%+'ȁ+kKËZ pɻ,"SI<ӼHp۔,)`)?9c5fG%᪰Qip=ĵqzgH|HaW=-E%
ctҀ(X\Ύ<́~≫[p2tKe]#2IgpŮ̍P};[h*#dO 0~dW[~Ou"K邌/!KPy

w>~ɬ[g
Em/v~sޱ6
*3?ý$ϫ1_I\9=
XIQ..Юk

tBU`4;|B7R$p@̅AyىqSL؈޷/ڹ
`	ٱkU+++fATNװeog,w\鰛m[LChVk9^jQɩ]'|z/93G8D\sϖ5@%@Hr\f愓#=ı-((9
B/{o+SN_5QW۠$ڏwlQᗨ%6`=AX7s0*QgCނ@髰9%0(?H]Z;&wk^*[@X)e1whߎ,>&HCcewc*"=#G]:
.XyE;Gs֥ckZXn|i'J6rIvw?0aC-H~Drp](쐑0Z0vp&E"K%kHX)!IQ΀|/"ȵq"$xvMT&͘
1
A
YDm.38<|=H2Р{ +wE2t%`j	v~I9j*աh;/8E=^-]%ӈuYF=/K=k&	+<$iʙT'{'[6OW7lHĊV.՞ûz#5v_bQzSalJ}S%v=te$C\dAf.
"aj1CZԇq,k#oG	.k87ز~MB0`Ey޹t>Vnbc~8xk
n5[Rֳ
w6ZDI>|yP?ӆEqP{miC.Rj3nv4g|P
I1>ɈUB5:8qZ1єI6JHvq	ЄӅi:	w$φsTO"% ^<سeqP̾[K3IMY0
4DZ|y~;$yMY& nDW}(T?2W,MY`Ӱ22HlFLv. !t9xmf#*KGk.zyϯ&v;vԷj)3cpi$j0]u븺nLS5I^;4 6@!/PCCdHIC]c^"#nh-cS
E	ldB=hidtY
^ڝᜁvD)bN&6P	Cx#[Kfʭ69qNg=9UfVg78-DD‘wPçٌZ+%-7F}xXp+nSԋ/h)Na4Q…se`ҕYDj0!sĂo뇌kk3ne )B^RU
`yw$gPACsvo+
aMTo}01p+2!Sôyh|>{S%>R>t\(kF_U4^
R՗]蝱ЮL~dS2yr)D^WD̹g6>SOFrTʼoGLXLhJc!hu_yxt,u:1tbwaEݖ/	F:
w+~S3qU>@i55Ҡtv'ql-D
CtA0m
Ҳ%?-_>wF"ZkvxV4EPOY{]'Y?v4ir|Avl9m0z`K|ޔ]Ji&Mx*̤ǒIs_l<ӡ4"fsfgK%+kn1"_8l;wU6}I۽ET^SCpN4FihKZ"\dv
@GܾrJ*{z&fPݼ7HF6h0Z[L yoίLUNƟ yԽCw-Xkv8[-'	WD%Է}t32MC4%f0_4Wy(l½P)Vd}3M
F9FjJ^ڎrnYTHo4-7?0/zA%j8Bu-+g8k8dQ|ᚊ1Z	uDTMFe;$Ǜ$#O#=5ﲹ{pY%W
g IKHK#
[&8GxjĊw%7hl
GoL,j:]%GjȔüՔ[FEw%TnBQI@ HĚ틺}FORM)DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYMWzco!+ŕw	c[M}0]9]:FYbSx2Ӗ۶C|E;Wb?<=/m`xoR\yTiŀs4bzr۩h(ʭ0=JclIT!dQ!iZuXd+7a>\)`KA>k?P5SODyg>vk.mc--a
2 R<_j
S1a2ka٨o
Ua(i%k͊WQ
_fXZ=-SEQkju3cZW٧Nc8*Oϻ]#}
MÈ}˒1FO1ጵLQGlQ$=s`[fB2ِHыv|
i<k,8qmf>ֺVM'H\ZDdyI՝!SIlFIqYW2[4\uqSpqk2t"Tg~UØl~|P+;SȸT]Gģ"s'oB`y&yuB0gz
qn. yCO>.OnIWr>q# WmhޛQoP~qAr,Ũ%Jg}V.#ۙxK-6ۃ6WIq9K;q]lYF1pKJGR>UEp2M+#H;nḱ%Sⷅ,[
6G;j48n_f|5z8B5؎,~Wh^ԏ
jaVOQ~[

	72a&tC&Ί #<ꀟ~#W\?LH# Qy8Tvͦu+/Q]ρiGZ_鴦mn[L\[lkҲNRЛh7uU!@԰BVT)؞e,tճ${.[I
d=o>07k®ѯ[OJUkUsB$}߯4[d7XBB<űn>={*

C.:ӣsT?w&2nU™>@c*ka5m#dHy~7yJ,~gGȄ*O+
I9е׿?zoXW-lo%
\QP~hD-O:|^x>GrBlvTi=Uz?8ȋyGG]jRvC:0޸uʛd8U	#\Xj˩qs9Fυ"7?8yayH'J6_pm=Zp?5LzHULgQRAE׿dze.p
,0Ph:2ev!jJUo`J맟zmAƮFR^?&2Nbp{ao988B|^770J"$qӃAÓbH]
:a'V$/[Q=b ^?)NʎpتM&1ÃS sۆWhO@Og[v%OᘸV;N1Y͚zyl痷5bʄ{$
92k'"N5*`;cN8%Nss9x:}w̡Aw[6aqؼ xፊyߚQ~\c}jpO1%^~S*2)G=loQİ_p$.nrꬶOJy6m(lC	3⸅xH~N]+Zmq(UśG^p}4F1XEQǮX)#eP	`Q[	XFgpޛ[
I'P"'[XWʗV-הh8O|."EN|x&a.K理t-VPJutw.Gt}t*gBG9C}دk/^W̐5<G[foow`CNs+E۫Mo^re"V>B>=#M2˜-#,qAGh%A*QBѪ\xM4sk@w
x)EAg>[9>rG2}A[WןEn	%`aʞxGV|y?a.:!ҍ~IfJͫTe`uLP"1\T[˻kz]z}WVNUb
GBzoJs?>X"r|Lólʳ0@.:iynATX]GZ+W~&3iߺAGn
œ_%½j(7k$vY6kap"):\2ԯ
w
CeiAHɊV.Y%21yrU[Rl[Dīg(!jh7{rDfLfنMmq1C[unT(>goҹaMDs#k	]߅COisTͣpsygL S@"}4ճa6,\MU=w4@rG$Ep}@wB'mWOvA#~Gٹ̏יs]>P9nh>qHe2-DdizYj
c-D%)
|Wƞjt-ȯލK6ԡr^Wr2br[|9'+l)
US*:vߤQ9>MC"H0e8ܕzwSh	i03y!?48?)Cot؊(g*{Y^>ZqMB3 }کbn˴2yxҺC
{_1ǝ _r3p:>J'ՋM_b5zO3nrfRZ𔧍IOM&
߃k$Ln}v{J"o+NqAg3j)HZ`P2G4[SFjc~BF%~r7,z4oYxK1M[*-:b;([FɏfE#~7Kl6T
c#? >QȢֳJə鴊d_׽P¾Pq%ؒ"a[$\:zz1vAs'PPYbqnFHDl&f4oE62k;Y,."D* ?	a;Q9x%ϖ*OKvX,I rU;7^3@;?EO|5
߇Bnud'bVD6ݤIZ%]qje"U)UE*$I-_~VsztȠB}sHm|
x6jtn6Tv7ʥ9ϑGJgV!ҊńSo$~^X `RW4̫1\C-Ŀg+hKjqPtg8E*LUKgW+QRDJa+O+x.0Ekqrb4Ɵ~pM>'23fBǃL@LS~۳AU 
:vcUj)=D+"t{)2#\)wmk#kstb,TqE{]]DϻFw#g2YDjָ]Sa")BŞKy>iޖ1'cgp7Ȃ&[9.7ZQrnr梒6"V?`*Bv׺x=kT0U܉
ED
- 6K:knKVanEO!0=xErҢ
!Y럅o䢟QTd1p_zHCr*hp_-Bm}Sk@
}ږj`	jABy
o";2Z}	jft+0u+IQvQM!X{sԘ{UɆвkύ`R.*Cz\MmZլobC~AD%EUM<

۲ ,'>3gK,2mY?zXjw&,IZ[y%P=m.SےSڇ,r%ԏvj'Yz2A&[R)xkRuA5PVvr	?|'Sma`ɂX=WNOge&s(*Iz_䄇T7	GAN9h6gWОi=?UV
bg4F,Ca/gA9|]#{L59BskGwqԝW%$p8\!u6oMJr&=>UǟHųazݚi4z{7ڊkF<튢9lB}tx5uRR+T쨿!"8>01siVh8!
IRR	*ڡgr禀wE?<]"B+Q-tg&Q.iNcI)^p1P oޓ_NeOLj,MyZ~?AOmyjIӔj)GplIqVVf@֘Ywu>s8Ϲ>O[Z~XY"'	=-_%ЖPA>WrMoA4Ԥ~p*TntOSƱ(E ](3l@ 7'0ľ̉<8B­t+-9lz\z+ph(E!9}tYL" v&65MZ2;@Bwl=?"ٗV \Ȣ56~]kp~A.g{V[ Q$|	r);q 3g`H;JS{Qe c%
	KˆV C]8@w3kLE_-1䍟˷lj1k=
^E\]_	ҊZˣڣ[M5{mU^縠\h+1FsHBKzƧxY{?JZ3~+G?[/I$!j4O7:#e:ϑT-R G]tѓaPx,9Zƶ~@efgu%6诜SE<@ѡB*M઼iAY=;?1>莥;N1mR`?	>5`BL"IoSdF?F46@5C*'peea@O5i*sӃ0PRҐ/3YP7|ss{ʣE Uș<&,XƪLx KJg-3b_M
o2R6(-(߸ptk5
1GhwDHds]Pߥ붃9iÕ20ȅ a-Gwd&eJ^0{v򻍆Y55,F..23[YĀŅ\ymұ[r>LUBd⮊.Ni|#Qi];%sUƠ<-FZ{G|wH7sۓ?7ɩ6p3V0TQ|=
m\kRR$p?+jβͥM
N<ݖ|ji.BѣbWAך^1<.{rQ?̃F\j_kV;[+[ gNyإh$8hIiG4(P3-޹RDq&R rSS(*Jβ_`ɱCQ>1"T\1$Ug8ߋ39#3Bw8'DH2f0a]xDm>~'c,B5y[e0Y.8)w+Y4-x͚*E#]QE2';J++*ȩ"^;
*4\lc]cVh.oXꓴ}2D=gkӲߤq&FwPMBXIZ)PaZQUGDg{FecA5K`pو512
e\k1~դ]}*0%TKҘ&ex8>P\F\[h5gRj

xa&<㿿!=&*+1(z5uw.8*~>~AP|P=ښhHU~hKoV)$8*Ir_ɦ'Dj'&օ`ן	i(Rӑ/>ՈoL|ZB@wzx kS^ms:fn5DѨ2`Tř3-p5sHz!)(פwGB,+ׂ_O*k,3C_=֫pmbi(&v[-ዐ.ABҥ~)ޔu.PC0n{K젞3S?CtH)i}4Z/
TnνXU=!U:OY a~z]P5@
Ę/a_>bI ofl"fIRv^cS]h\@{yH~iQMUnF<ڦɜޞy+M/L'YMS4~pKf.mo_iLJ1;CZsRs5ltluXh8duC0AGHdRNJtD(b%n'.O`;e]y[vL	yLL!$T7lTB)߀ޏqRއ
9Ր28V(~f~⨄3&$OD&?jvY,ĄӚxiuޢiulqcjD4Cuu7JMB"AFC
W)*GxW!,T%?ǏdaCmjh=ir-qM]Mq&Qa	pQ\8f\fn,RR̳OPyJ3'ޟFPTLgk&f%Ɗ7žμh_~_p.&:xzqɈkfTb$`hLK $1n6ыNyd$|-
	K$
bCյ׹~, AiNyܐ-#d"AlFHe̅Pʞepü*;i M0CXbXԏ`$P)a@6sz{jRhw?~(>Q&jh[,VtD>עmٔFVdL@VR'”[ ѯAb_XA+"y2ԧR`{,C,<]}jxWAH1!jdMgypR8ƝJ{[#C"b{@U:iƁoe=N35NS*?'}Zۜc`3bfus/?e/G͊{FORM"DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒY￫؞gϡK!R]끒#XӇEGn׍zq}!0hJG9Rm}LpBa{w;4m$"Ӗ[gU1z
ԒXc>AIc0+`y9o~/I2:m'%	X8	y#MHN
*"mjx-gH W"9\{EIK6&E8J!sq,h<2΃a.~e~ʈ#?LZisMcMڼ,;9I!c;1pb@Mޱ#3A;(Y;pq9q#2@^AJXYAP>Qcyq͛YTyisWv;6_1&ŀ2ۆmQX)gCw
+aeڧ7_
7HRlWPuCu0V=`x~V!Ku
c8n'eYO126ֱ48
GR¤S`̘
*|K3륀֑mw,uKA` )EH<+ʁ]c,yb,,j
#"QzJfʑxވ)7(_wϯ?N'6篿p]Qj"/֕ɻRbs/RQ-RԔ+k]S&J8FN"ћa)KQPlHy٨'ʔCJKHm(Tq4pRM{o(^kWZF3K~8JЕ xlиnҽ	Ut[86R {ԯ^9NF¦{t 栚]tPn=iAмěo᝖5ق0k0&y3hɁQlmX(` #d+y3
*T}kVPh_\aUo`G>nF޵v~kEة‚,9c͍}8{óZ+$H$\xˁVm:I
&RJozZggXՖU݄OKu#{mn9	7ɧ3*]%[O
dZmʟ`lXHT6l,jRѝ;_nnȨ	C&O*kx=Z}!p*d8@Y>,4\`ێlTgvDO#qPdo$.GF:V~j+2Ȗ1D?B-(YFxwVGP=_x`T	d$؁ޫ"9YO!am] D&"DMvɾX!orpty&|ίu?!gXvŦ`JRd2/\fƳ
MUsMT,ІKgg$k`"BlN-U>vK;*aZ	+h.[b1V\e$h@eRᎲn;f"^۫)?BҼř{a)ơjy%T̷ N+H}ܞbjIئ|Jr鸅gr@ͥ=ܳ~
p^s1[#Ag1DWAb8u𰊅&iv$+$\
ɗ#k*wnMd,
zP=;t"]BW2VKč4|GNPh.Pܧ^sp*_b+i4t&i|/$[G&]7]+o
yɰ/:mx t˱ͯN5$'Uݝ`/!]9˝ITPĺ;rն^}d6\)⍿0DiF9pjF zt5*Q#gOB7W`y.hkR'xn0_)w[#tt5l  `]~D:6BFx%Uv2g~Sgf~J"V[jeTq1
kaT;3m>#WykGyL5`,'(90mC+`4S/?^wki0bJ>hvcOb[_]rU^~4LFVjoܶ*7lpΈ|.yeg@;Fr?WDOCw3|t7h>Ake-;5$aVR,Ƨ|\W
\ay@
1Y:I쩌AX>mX\Y(c<O>
;88C	7\$gjg\'-Eô9
42%Fs;̊%^fO2\晘+].:=B
%5pCC"XYsp}VWrv	&؜zLs\ }=\ȼ=7w~5?'_-1ugc:w\kYDa%B92?|:ȧ#Y(Ȟ-0xb_mk.n۾qa۷w]o/jɅ_͒6'=cqotٙ
-q֗lMT#؜<6p@QlBm}NZRr-/UUIuq
(oFVD&`[J|d xTHh֤9fh:Ρ>6s$WfaLHֺG>m@:߃gT_W\_s
2$Wv9(@x#]PNb~IK\iWYu]A{:jO#-GDe׍/~Ξ2c#$[s yt;nsG3naX<>$_}JQmZwomҳ9r$Mpx͵ẏcxx$h=2su~Zb*@E3x[Iå\vL@C>=nOX	0GdSS(OԩfAP!2|PNybZS
RوUC@DzAwV
Kt#Ez=>S
hgJ 2d|kFc3LTm!87ֹhGX01I6SiL	`+G^\9BaPYw8B3:܆uZtVD*(CY)pU7(]tU6 Er5|<@ȤPԃWk*@
zqkF
O΂KJtq0Ɯp	RQ;J}rpD<	da0jd=*"zH.	/F
TGɺX$a]+F)BZ^`Q<PC'9xgYEAu.QZU#kH~!?Ȉd84Qc@x>PA{
0~;Ed uFosM0
i/Kɾ7ҥ)C@@3sd}KmuNPBly9H{+Y[Y7窣	GcBLyl;l6y9\a@{LU̚Ex_|Add6Nَ۬
f]C%_Dg"x4WEXYuK22
ec`dJ'@O@Xlvtxumc&^ɸd\NAy%　炒xMH˚#+hᆁ0p薺KhqN,2xz+TOBg6^yiNA/NlĎRsn읾ᕌ-'~9qP
VN=t#S粒$ޡ|G1 "wy杜T@LWLMh,nqsۥ"0Ŷ99$2CE_ww9
c-`OƷC$Pk|Ή0`2>_c/0#/Aq?UIO$A$>WOa^{P)ٞcaoc\C3>ٷ1NҞQ?
֒;z<#*8`TCvଅrq&iCٰǭ3uB,o~3gեY
.Znǩ$G桝H(NoR
j⽊=Zvjr)vvtm6,SN4AqǕTg]f!kձn%i#ǝ)5A)x̰?u?jʠI;dLXAg#gdzԠi3YsJ}!/)C19,:74+H|ܘ8vph4<'9.[xR~
aǑڬ^}fkp~%j+_zŋ9Mƶ[5,HQm.* H$B1Ш&
		{(s!'LW.鋺I86RsCu7[#j¡΅d0b;/x_bm4p5mpZ]_I+Yp7G!q1%z/2D;'C%TΆ@D&WB{y3zBl	6 PSHݸd*e1.5ൗ~3ŭ+,U4oHIWN0O{:-sgZۺB!r fWwXG>ḅuU1{
d԰֥]ȅ_)]≿D,[
\!^&gOlUQQlsB4whYVm)~3zԽ'ݿ8\cM+|Yq,l\ִ?PW9:0*4xF(ͷ?lVM/T|o!;h2'B8}\dB,nu"iE[O$WJMO-Jʔ-\"DѴe7y#Y$5}F'i`Dk.KƸ'];.u7I#&w0܁mO~iYIWv.VU
ӕk=L7ß	Ou|%X	-(YfH,~# 1%"kVqCao3#^r/Vq3D%(s"nINRlЫc#?r9
(#_XGKfR =G™Or~,\MF!?/<9#~@41,B(]ko cÕ(NcD%jgKLwC=8ۍ1~	|JPD̉cf7Na?];+8dpq ԽM䏰H}Lq?/#qFÙٔ˹Ckh(#5u4]pw%VI
G4&[lo@D:={M,&A$~Rsmޟt̠'{PD)mom vOy/43tr+CʼAUkerGqO@_$ln{7@9K ^_6@{ЙʶݽF=D57 )1!=Db+;)1چѹM6-H O
N6e't
{^|ԩDi}X~YMmvdINMщ\gvKlRɘUPsZhFORMDJVUINFO
XINCLmemo-int0032.djbzSjbz
@E`ɒYW~H.2'N7٠Q/qϋua~aF>\Fc^,19:<Hb]dKG%1W^MIb7
l'bs7ȓh8x@mLԾ1Is}uvi!#)!<q2Z8
rN*4^Wh50<<8tL-EoS,3p&{UOU(%WzN5[$m5)ez-䂴hFۭ67ŀ
RW54
Z׻xq#?C
·J{sSym/!r6hhF̟HNFvhşLMQ/\2\fӼyvQRU)"S{o,cr٭P"ܲ.E4B0a\a
ܘ2K7"$OY,0OCzAcw)+D#*2

ē{I5q!B\AG]p dC"`t%ȥlQm-C*\!E-1ʂ_`E~7l1Fq3D	euLaN?/_BOpqE:xrB'sY6A&vgV2O{Wԍr#+\y5x9+h9I<݃K]?InF	9Q6'XOT~G:+CH 8A&y;93
<%~O(Cp8ҩv"O8}ݛB/GLR@KqykGK:Ζ*d3(n_z]C#^'l99`ٓrJyNу[[ڧբ9~w7r#ӷAg,!qBvV ϦyWd$5) Rk8::Ɂ
(DMS&|w@TґEQ¡)I@\\^fbX￟,ԵD^!Ɣ߻{aِ1#~{
f)fpW,1եN>P![4I_YOp6؛Ky&tƔӖaԃ@gPU*q.Lz.յVkѐuKBFC^π<g9
ME}aH57Y6<
IW@wYIՋգhSQ}~T3TlEbyo95+t
)8a)bp|V,kd_SY/kb?'s%/tFnC׏v!;b0$x)7AZ}wSm@^V[&Q%7h.Dr% ?/c"?B"=,3!
4pa[RY&DxڝO3(z3Ƞl1[_#;jD*ݢ2GN=i=TY'ƦCzohdfOZs00Lc͙6]c_oVRAޠp9~">cBbA?Uପ%Z2@Djuʱ3 aY}̡D.r3AֶJN,EdB`&5fƶ; %~x8SWL.Пu둜DUv;e7+FD&B
CzTXTzq|.J<;!6 q귝1 ZOg0}ȥ)b+K%}i	TV^
܂Y|~v~x0Yh/A+!$X//T	"RsD
Fb׿9+Jy<*M* qJJu/!djoq-Ȃ$<@Am%tmcu0%aoCAgNJ.!wC`,D_0Wv駐'E:|SoWNZh6J}	p⮉Ybm]%1
h8_:仓YzӯшpɾS@R/t8|%k=oʹ
1]BYJqa90orGQɅQrVvxGb.5;$)/zڌ
<
.y:0cd-t\NǬYv^vsj-nƭFzcv̐k{x+Ț;C]n)ޣvKv8+dR|	lVBE[șBbnFwkA˄?#iKtQgQ6L슋@nXE7w+dqأ?_nEp#)C޹~Hi.	(ޔP:.`^`>w
	hfѫ0G)`(2ztl`xJf#k)ul {Jj\ŃA}o+J5):_qOvp%'ɯ$j+"t/+7Iˡ,p,B"2}4X+Mٶ0EᚡZleCV=ɲTǠ8Q^i MzԻ!F+eaf^}cD$pSd+#QW]8p'QFCWod*AW#"_͸[HJ'
E$ZĂZPRPxn@R]=9X#ZO-'̏C=_52Kק{!ϐ'Q!/".T?Cl'=`x{6}قSk;GFORM(DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒY+j1u3cҳT>Hr?C2Ɯ]<=]i~pw	/
ܰ:ÿv$ E[^\RF)К|Ȧqp+h$9:Ȩ
错e ӷx͜}oz{"ٖi}CaDߐ "Yb4K7b><4z{QaF**ebg7g/K V|iqkCуDgQm8|ם܀<#,D8]rٳSOJY_ŝq/[g} (nf)ԛf7IJX`hsjWfC猆P
o
)o?T0}"ku}4;U |Uv-hifOoz<ғDs&οvR\7b$"rw֪|.蛟eܡ,HĿSw*Ǩ~xm雋v/&%(*݈ٔmQs`ۂ̛Qi(U>?ʵ'0nK~ɨ.'@e"NV>15Vbxu4ńiT@@-eCExAf./$Q>^S!/ǝΎ霢_+AwX/V6H"Yܩg[Dmiڜ݅cL[qL
`	 ścv3xJfQH!19E al㶛:X0S_b[3d΂.V}b͆LC-	+l%B
ڥ'+gk=Z-W\2ZۘZ,E.g`Z-`cUD*͂"bBuMO'1*]AءAMc&X%GeH|Z`T/`N$Vœ||\Hgr[ ero
.+`z>w"yKN8,wȎ5kXN7A+xAKTbX20"15lGӺJ?bΣn9{a7,0tuɀtNͪnZb;N;=YeC'yrTN*#~8٫YyXoh,^)4.JxUP&(	KEmJgw.$AuN%h/ݬ!
KQ#0UI5}ڟX-VՁBHRRS+rSv$!{&
.T
=hJ!
2]3"E˥J(Qc8	Z	
>`c7Oco>AaC8b?1*C1jH_?O1dwv\8=*g~kI=w_:x*2NTA}
D#ٗF:H ^N33FǷ|\}2Ϧt|TjSṅFAK>l@f!\`H`
!g+v0ՒSHxW[eɪӭ~̛=>ELa٬[^Tѕ)k.ӁlZ-LzIϵƳl睘V-*Y[f
b`>~XÅ
xzIy}kOOU!VpyAmw텉&1鮂?Ξqc߲
	@^y\Ԟ\ƅ%ድ_$#nsB Gx9/qho*xMTZ`3i>we1Df$chŞO
P>h'd[?~#~h:^s/.)m;Ɵs+d}}MK6	r9W&ywb'w,gE!<%gw`o^	A!E۝K̹,~!60Ʊ?EL@Y-E;_$4j⿗VmCB(ܵY_)>A&VI|%hVFaw4s7
h59D9z"a#)2M?U;G`iϒr3u5;Ӈh>n
c9t2ldH>m7_0k6Ux-C>ANF9TxG-;=YE'Izrŧe$<$|:l)OlS2$$.ee[@_ʓW	#ڜ_Y=7p%<ɣRP9qc\9y??rSpcn'wT_UpI7|5-BR&t.kWWMK)/k;Nةz!#THQMX8I.&g"}e2jw?tþpjfP83iRa|O6?Ԥ(ؽM"qӓkkB-f͚ct}!y vQS/FSC[7UR>&dV8|KXkjpA8ե\ix!"	yB{;{NAÞ fФ	ig~P^$TJ]T/NxM6QM(΍}MЩn7n!X/u˷T6Qb&W^A_A/!cO`6zFteW,103 ڬ7#DKi7ٙyilH=|6}_ObO@SjO1dAKd6&Z3]z
Z3JA	co9XcNh	$#qU9Jħg%7<|ȿYJ9$lsCu$$}i"\iTӀf4Fm^\`ԉ^Cf'rꖀ4k͊ܗ{D}?7/~؇	h{Xf52hYp]VSiǼf'&tzПt;.pq	C3OWedv07-@Z^L!6]Oovqc!SN B0ܥygzeS;2R:*EiMՆ503Y;pBRKY 9$Y1B>8|3X'8QVJHr:1K40+嚫򒴧;HԘc"iEID`H7)8z((wߢX'#r>)E_]5>qܦ?#G	::c_ڕ#9.wqǤKZ"V.hYeTsXpRbY#?@;,EX‚z7Hv׸)ðz.,j44d X(Zʼn;I:ɷGZ?Ļ@naCqAu/߄=e@5o~.0(V4GW)؅߉Tm%8p*NvLfY7\s9Rrx2at9PgzaOpũCQG~niYP)j%8eD{^=a]8{'4gpo|[]ΒqQGK
va!:u "ͪ?G8 `vl膋ceQGl=0P*9狺EZ_-;4Y{s`W	qDtc$`]K1uIwFו#8w*/qb@8-,q]+G`#QI56_c1"AV}_|jV'6<*ȻwFFd+M]uyBz!&y|)-ͱlU{@**8l;jhZ^2n8G@-Ж.LH^M<ǨǠ#+W}A.9ʮ[XXpbO=\b+0b+
>ټdɸVB9ba
wƠ8_
`Q<707(y	E_^1z)ڗiWE㜾M82gjz5R
~|<&7eVdP<$Cx憎͍<ϛU?Rk
x7VX6\)5Q,
Tz𣭹(껃bG?]xF]\,V
!=znNAdσ>oW85qdjelֲ=èHIrtI:^0V]"f;:M"UYQ >4{csB#jsn D7zZINCh<5} 1W*Jb٢jt.0ΊZ!_5lkʢseN7YʂoscK&]l֜`V2&Vbu@[1KLnqvD"E)"tK>	Ea8!.$)bpgSǼW~f"LR6b4`j^NbDo쑟S\d#"7vNEC_=Ozo;m휍ǏE@}ށm,_K*brD.mՅ+wѯ*#P>$z,`( wT^_*wJ4$ng=j
5&Yj`9%U"A'nE3
˰1#OEG_h
i҆bvCȰL&gCC"0Sڽąd%ϼK;&w=|AxɅM|+GZ[GĝZ8ҧJ	`{MdҰR{1U?kAqU\p}FɠIՌgyr90(ס,h.]W>([}lk.FA
4{s^Ok0DĚ/42+i>3Y"n[Y
fpYy]%'&Z%9
sorj&0v@BTcˋKHFyZ?+x)VK
 ;-&1DSEb}cr&\7"F	&A_+HUgT@L[*>R[2&\&.%sFS8`Xak+a-ɕ
ul(L
T[*~AX`C ]kfTƜQsI"3IprkOMv׬;xƋ-bt9сwu+,X4SJoú@+LK"וi/yH*w|	6l7bÒ,	Q5HC^@z>SF
5 LwS
PS*K+NǡJ2r(]dM^{Ő^Ni.%R|&
&}Dr*\/
*7fHLW>ks&O#ӝxZcߗSa͝`U)'gqv,Q_ 14G7gW/A;=2\rFFfhn\#ZެQ%ӭU,:`P.2{7gve%DM48ՂQ[VKX4i,d^@Դ&%Bi=J~"*m|늖7hfJ
-0u^~n	&eƨvV(3䏤e-$CU0S~E~f7q/y8A)x+ʐJZ75R0VGL=fe;4v&G6nъݟʝyq`q	jb/zf|@+Y@@m>ˈ_'rqWp)LijHeR"rOڕd704cjYfM1ap/PBO]Rpws>fP=Z!q'`NVG*^c4qt~o%0i+xG.ǥ
DN4ئPi}t/zmR8Ùq>I~7D0 >th;.{b[dkJzq"
3]g#5nsrob]
.6kꟈ6n/s!&FORMDJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYKm4qC>Hj|`&uE$ݖ:|1z>-hSa7FhȋnMF-6^,9! SI*oEǁ%\hLcjʦ3"M~i$:]unu"J3/~Dh.CT-ʳؚ}YmŨFC*L)u|J+EBU;Mrd4ך]G5'J#`#l༚k'g+P{ ;hE !Ȥ6V´A.l75yRR2*>X-|DpN}4I:(vZ1GG	Uo4[]Sա5ͨp!:0MJV:r1az/Jۃn;	C(qB+I!J_(Q'C矧Z
ɤٶFĈ'4</6[j1Zi}h.z7[	1~fd:m-Rt +;:\ra4~Oh┮y]^<=Kqw(⥀܊*V@	auMs]UBV0$7+\"ʬyؔ?b6HrZ
tK9vWQ8$OtI
o]-om$M.c[9aD#A˥2jT	LQj=Ec<7J,O`# ov^0<J؃Y< ep^؉,b6v#1c_t2C
$H]uXYRR%r1VK3OZWʰPPbigl¡leppkjl|2Ӝ5GPۅe7BU홈Qߙ-?NYX%/8^!}/0!{FgpPݡ8.~321xs60oԮs(g1x("{˛Oѵ!
vfDOՒVl^F܉0OUuEd"03Ԇ]{wiKrO:D+E떽uhNjN+2l?uH]<1oB+!;9ԘDc+Ϊ^5o#H_4짝rh`L8سcZjVOlxieZlWyt
Ɏ*ޠމtCeыD H F,,ʢ/l-R}i"MOm$*a`czKmwȗ~VtFM(88JlЈ2S_YB
P3oXKQ	=NHelj3]JY2#$W L,ox*pH^gFCy%/yrnOy3;PeۛN3>1}q?Ԯ̖GtdsC( ;RVZ?{L99#<ܒ7/Bfl	
|(5"VũzUqUO[bkwt-(VoUW2|Ne`o9k_|[?SYl䫝T6)"Y.())xKisry
]P{s`%•*LIVk7Mp/OMxF&W$bW ٢3OmJ i?
Yq4D#lɵ6F֜^f]
['W至yݬa6kh~,F/.l˚9oV*V
 7k$hnx$4KgV('Ց\d
%BInG{CTcV:*h@28}cyS)ecl E敜
ᒊf??sh|#!+u7&H:D}ݍ5(LhV8p}`kV۾<ꁜpʄRVjjs@Z[?-$O5"C
muٶQ>{_՞VrL}ȴF9Ya3]y=ES#L_i[a-k[۰t(hM%/9P/ZUIlr^tEz,D`~	O<ܧ]
RL=hLr,Ž8qп#Īv5+=V	?0ٿ(@v/Q l82)gIU 0N	eĉ
,p5/}cmHWjǻxEČҵ{JQ'L8T%)PfM	X4Z^,?>? M5X[H;V&=i.8z$kh(]ACY?rw8 a䥖0`e;5}?lt^VwJZKw@Z"aw{Xv[+wsw~*\Z4I֝#XM&05]M3O$uwM+Ocd\~^tɆeoI{Y {FKa.EA/D%ٵ,^o%N<3.nQ=KccmYa;AvUdf(ڲUOV\b8	yIot*b`g	
<-<
&퀨
h_==
Pӹ\+~/0I%bhH3*灱dI3-iHfϥJr-FOE`)r#j^itG֜0O:*8jJ{ʁ]	41ӂJ,oIңwDEcF
!ϢA`d>Q$+Կ왮4>@!OVID3}S093%s~P̱sI]h
(NVmͷyjDjcE_TXTz.J=aڑh"|
h筸&)"tbo/KX@u>it}=sO*mU8
y<5?rUXM>wuPM'T=}p^`RXS*JL):of1-3mHjd$föD1DzsO۫eڏ ЭwI#mVTfSox0=hM@NfVѾ*3sh]Akğ	2})'k-S_gY~e^
ID_(<uᄑ[81U
	\'9Jߤ#p^[f2HNM{l!ZbS?ϖQE&E·و1yJUGZNjyN)d&/u92x
̈e>;kyOY*rQ
@{Lovh^`=K}N_]y6utEsiz똖
q oȖ
PP&wu{	0v[5G7lyLj~8 1>`)YO9E{Fƅồ|d4T--iYww,*
W?q(E+O],|=zyYW#֤
晁IcZNun'm!WYUg&Bg{f8d~VNDC}%mLŚu]\$vF.EYWbǞV==@;.ҿN"C;@'31З
IcT0%T_"xasDmɗC2pYy'6S@Jĵ@Νj@4\S»7_%..Tg4w1i>B*d̼>MכgB|A2XaЍlKWz:L3XE;u6FݘE%>4H2LanFQ~hpz^&0{71\%P)r)|n(g/g{b;v;W<<`t4%\YyTBXlFs7{zq쪲gù8v#6\"m)6ۗI7V0;#)GOoLX>UysY"rtT9{kHEDs)TFuƶ?^7NX5%W㘖c/[x L<5#Q8
&R%'h!dnzAe:%ƜcknnDgp$$aw p?ʝv!.
Kt	<؛sFS^.Ɍ8ЁD%9Y	Ew&=@"p$
ձr}WR[
_v[')8.E[Zn;럀5,M /irw
&"r
2cb,ڕthN1@nv1?bs7%	jXf8a.ٍ(+Ԑ ]:i=bL
~Rh
}L-շA(4`SFr'ؠ|W6C-C+7GFSH4!<]'b/K\J|#>R3\#J.*0#U	!ai	Ѳ/WCD0fHFORMDJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒFԟxm{TWMrl6$~,+<aU_j]$Io%ĵn)Hy"  	Et/&p80Y”	ڌzAb0<݆'biD㝝bsko0/-e7=jᐺs)mj<nE7S! Qx`HvZ1XmDgC)
/ZƢўOq%	>l`4f\_xSySlݯuDgϭzEtBtujPp^c:q˔Ae)A^R^%AȅYE+Li=E5h3yAk\VHz~J(Qe'!ֹ(7b`.0iU`x"ѱI8ij
,/Jp5A@(\RHJ$͉#`h\X-ō8&
ǰʹ%@)&کd:0*DкRo;hoᜋ&Uև\sJä6uC7e73o^E;PbТ\{@E&V+!8e4sqNb!JMqrkCzy!v=:+=<>Hpl\uݍ a⿳	$?~ZizIkfW=v%cI
ɕIySa$QܜGP0OS4!+*+)742yns+z=
{]vn$C89XG+}H9CΝi0Mj>.-^	iʾM_
gv[h"`[co&}oBq٦(I2CYJo=JЅ,rĄ1OdEckxP_J\<]J	ƞMnp:/v_IJ
}_>ZHg戮Jɫk?Læ0&4#ȠqܞAݐMP9<ᚊnϞ.϶W	;Sp!s:Psũ.)Qg.͗RVyEbT#]C^Æ㱉-#RQ$xeo@Y?aQ&JmryyJ.He#tnUt%I9`_B{\x
!Xvs@5Od%Z.)|ӎl~"9#e%kVH3́ry"L̡cQ|M#
:euK-%6dJukl=^Nt3(	I`㴆RQ
ZH;Tv>_RۈJqʾVNiˆzm'|\0NY;Ɵ">n_$DV	5*ᴺv'~H|+:˔6;+	M3:rԈ3x%Hk9xE	?Z6;/dm&K)ܙu,y6>l+&7/lq%UP|yaͨ
}DF0$=97W;b(M!Kv{E,F(i4s!KXI1}ep$G)َ]Lx4B;v,㵊Yp\zCv}bU[7{cvꞺ73tWBS~_$tw&
@^.]ko׻	/g-!*#_`y6FR1U]O v - \Ű_F-K?KZ2.EOLtm=hW6>hP@HwN–˛u*.o2yv$I_)"F[Fg!$}v\HZXџdQHRj?yMۊB;8 E.'XD rR)7.̔t7P?]{ԏɰ/[~B&ed^Y[$Sd;KhUs!EV!uWwkO\P`K(:ԡe-
<$Mmy(bHfՀ+nEFaJeP=o|lFP~`1疮J5ߖI"V2 g(oJc2M	l'@:ib€Rd*]?c}Dz>'L.#BoȈ$q/9k
(ZihᏔ,_Kڽ_%nW`Qe(ׂ
iuv|Pq_gA~`sրёmՅE´3jn
rLPsfW砩ˮZUwH
x@
PMz1MKw6R1+l^BXkP9\XMΦVQ#VU~gDgF8,Qǥًi؆rt76axϹFQHU6:C|v	dwJ8}'-&EN/(@=7e3aRVЁQ;*+#=Z	+(nn9ɗn֜ݞ~%J3d'ǻ)ƙnWn^ܰ{'>X9GQ6	rQ<ޘ'11Lnzq!BeW[gd9	Nc«@G)I7>#ȮZkɿ\W_	W	c2MgLVE3,I= L8[٠'3
W(bqZ4{ڤ#Z0yrgm[œqPܹ]X}Qt5tea@S5\<6N!*׶ukz>ebeAA*;jaL3qM]9Zܒx-7;NM9̓RkViira׹?҈e?V񍶟TXTz	攈.J>i)bE[?#ȶ6$lYd9G$h0V'&w^.35hq|(D|Pg4)wb1X,68]Bg|o.ΏUvo/(GAХ@Wz9sJT*Ы^ZO`iAp+yr#IUls
?X|+F,¥4>&&mtcsBSs"ۓtq2)bX#
m؆,<e]<
(E_0C|y˥nޔ #}JFyeK*ؓ(!bTL
Tޓ9[Uq`ӌ5EUpedpu:8X~թaϞM)NtsAYrD\/1mWcl\үf|ɦtǐ@:u6:b.صO(gU_02"d*E=Nˑ?GԼM/5Kl>ٷ&[5*\&|>hS=GTQKMW_?J"7KN0;n<݉qM#:{7cI`QH*yH"".#吇 rvn8q(",_Swl#8	ˉ,w\ki4$Wà%qr	5omQIL]qT`!|]6E8|GQ`]4(ީ)D;TE*gh2xiRuas) gW(
;$U_P${
Pro~j-G:p2UdKL3$c9iMĞV_egӞȖ~5|7z) B>- 	iܗ+-iTa肥blËr=hF,uyzc#fсj|p-$
Yj֊5\Se71?ѥz^NBH{ITw5ʨD2`ֶqd5զOcOa[9%<5
z_x9.1ZzЬ45G,2gP˃97oo@{l_@#Lrw&;#z&|UݨQ=cY"-4.3~@'AX30ئ:xpҧ\oQ`us䴋E|QT^fxBP<\Y
1ҩ+#X*+!7"T//sEJ
E{rCur*ަ{XC~XYG
::Wl6H*9~"@sAo=2}|fWL~ԊҬ6:cLn1zCܦ?qz>Q\i`^>DͶ/B2vSϖ2HST|->:x-#7vںB~)4hȹ'IFYGlNM;5EaG}(qF32V_=1u4DMP;_Okw>p)U6.?x_!Q1fӼUϜ JϷF3H"ydطsx5/_ڴmоY¶GroHs%.A+&Ai/!<ueIP{aFܢP#Kr9x]|^38j"`"-0оFI>/M5>w'0H3ta5I.7&~aG$sv{#\zU^8,@`H?0MzOIU~!ZA\EGǧ&Gi?dG:'ӘC6䦪m̸^sih+:`&Ow41`KgXW
>‰YOL-mVh]޹4?m'i_H`4%C7_,]^#p">;P}%$$|;sb)'O$a)?:0l\[/6RflwݢFXn,	e͏hL*D5<[J n,n4`6l˲_
GU	Q2ˠL;C5Rbo*W 1FORM)DJVUINFO
XINCLmemo-int0032.djbzSjbztE`ɒYOmmTe	ع1_řy)1E2DuZ)XTw2e_څ4X
J yaИh'Z1cCɫ৤IW.Vlc7aN+BKs9B6}Фa'XmN2Шc>=a.O?
RW![ެEuoyK0%K@LS!b='gSˉۘ4\˺ܰh}qæF 'Dpøl5E?_rކ5񷓗?2"'6S]	VJ[6ȝr(}\egbT#ho{!M2b1n w6䂿ln'[^ң	2ChF*o]&bCM8"JHXGWꃽ*̡nu%ߴ[=ګF*PCiMKXP
Vv=ePp+k;S+2#R/iYJ4"
@l6ѥHO%X$(k7{pG]hHL2:GlT+)Kw9zt_)zV[lcŚ^"A"R#O}1X$k=ܟ0?L5^YtcӛDz7g!Z1?eh]RrPF̞^Tݼ-A5";8ܚ
\~O<_y	dY%>\CUV)BIcq	_o;KCPo'IQ {wgFf
Y橕aC[zr0J灪gPo[H0ikG=({@p!S'D2ŋFBU5'XPDBI/G48q5r2Ȯ#ŻFNfն $SwF8ëAc$1NOr5p@O+Nt`X"Y&so-&,$L2Odָ:=0k
BV/U73TW"Z	>r<]eq48?;GaQ24-Y	]ARj;c7Nz~z\UcT gTC0(KBM;kyRB;O+H^ҕo:"7)rC1Q| p.\`E=p%|†5gFnj=ֆ,0EyCZvsSpw)K1Uv}!hg`E W;=}*ZZSUJpT%#U<\mB"!^G(2Z`~e1Xzel|j@/ 
$flKFTx=LZ_+mYôMz{J)[N*H#`#˴9m;?e[oj
R*ŁYLtG8{
&XdsS1a|Kk13Kk?RaS/7뎧<}O6
oiqdA@[^ce7&xaS41hŝ$
"9ww,T4[5Av̽8-]R+qc,C"r'5Xu^tCk[^:qp_jdA!bX9J?Aq<|ėÙޘFGR<=6c	RHYYnrfOF""
!P{Ⱥ*ɨq"w^MhT
fiCz/Yz	[!˄@ɻre/\tɡ= fNhMMn!?eVAa,d?
]31:xAi,%O؇?e6G=]˕`^&!10O b7I])eIM-\&6k|FÏ,OA(۹Z*ɑ䏧Upq
O|YY;L!KPEeR|m)LUX'fAրۏTYuD},|C$vR+u}0yyt*Hʵ}++{Ņ|-iWpEZmf`JhCd\x15Z'/p6!AA7oRj96@x2;@'a݌cRO&ږwUfoGrc2KI!z\2d%gyAznc6&KʣAф^y䊿`5uW_1frS@$ ;fYlRmc_EKg҆Xbj&|;C08vd s'V2o@WqI
S	$ԡMAVii96-
eɵL'kfȵ+ISb)Hl;+a@"qd*^k\W{tmܛ-‡Ą	c5v3_.V="@!@2gǷ9J!Rэ*_zϱH_Wcoff.QG>`
a
XdՊŅ
 x4 R"$̛i#=mJ"8Q:=J4R1iM,b١m;FBb~{BtcS(LNae標k.l>rXi*ؾ6Y`Vox(f!X,xL+زHe#;eO8SįåH=gPJ,dhbp?*+k/ Qm}ii#b#SQdT.ۻ2CLg,@L%#:Eߕv_CF&rRX&,r؄t(bӌ}&Li&Z!
I|4r1VM<DW
ne'Fy5Ϲ7X}@9fGb)W\9U.^s=:d	Af΋aYzgJ@SkRoήymD>tl{/K'f%x8%33cLhON2PܞBB%'ϊa98O)]M)PVLlp>]y?I)Zp
=6U+eҢhD2{hBWzZl>!v(D/{IIO|$;%2ԖKGW\)C rk5މxrBω,רrYtZpIv62+㴿á"gԱc6d,>vCCyEV?lC9gg[4뒽A{LJeY	3wPV?S%D">aO`b󜘟8зx~Kg'=]HHѷury?Ucvsҡ{}F0Kh'R@d5S6mAyqY*^)QWla$F#ے-*c%+cg)>mJcNu鑟
ː_E:.ASb eILn>D;<nE(?#^E7znkz(ݒ.\JˋCd9-a8GtV0<4@"&/XæZɴJ)/;NRe"VTts.G!IEٱ?')k*_&`aW ^-.Կ-6͂	*L"2Ҵ
N6+~@Jݘz*j[[IxېŐ
8yw.lҿgaԕqs^T6*c{ޗ.>QRԅ6ڝ]GQ_nO->ߤ6-!zO1]UB$&*},lޅR7	Rt"\h*5N
E1%L\_%4zrDc%u<Bc`e!Ξ3441F]'O*@I((Cl2PuzFxBZ7jNxرE(b[zTWk_o$5RtkT`S4;߾h,D%j1&	H.v+ҕcMy,E1Js/[,GZ',()üJ+Va!ABnSΤ\jCv`aQĀ!XǑ,`gk\։X?-X2j=RS03Cd5k8/:r	$
q
gZ+M֎Oى~,ZΗ,˜LdY?ʹh*%҈ufU@,cqp>8hu4Wk͚:z1SE56`s,µA/x$boD
;%kNȭ6)WpXlݓoXo[6
܂fn˖ߟXgt,V~U9Nvm#E.uy1G"q.wsvT>k(qԕvCqfDSfn`GX}~D>r&}gW(1im}QPzxk;yNa5!ҥh7x~{B1vg #UAPCJ>DN"ȃ'X'Wl
m.%փ!@tYA6Wo?AjW]I@Ȳa*E}|d OwVpy	SxHaoS|-bv9kqt&XBE\> V9&YJ5C52	6V4wk2GS.RnODD$UV`Ӗ E#xPPE22ը>aw6Iؼz9$6
_:2"0V|\]˔]B >iLcy\kM5W.-;_i(gD*&Oe1eۆ:4ĉZw/g)|w25\hxj^ʳ^F*¥{#g?e67=ݗZc!!T(qF@wy
}"*r[Gpزֹs*]MYOޓp?sH9{uCJ}<+x[K998x;Tl,__{6=q2Pn̬IvZ3
	#Tc_حA))ً	Hj4FC]+u.x
'+
Y+Tk_G|r]]pK)
)xvi`U
dC	6H4H_l~
TSʃU~y2YGO2PV9Ũ״G&	ch&3VM:'App؍Ag`uVAwbveFǜnBGkI:0=#BNT5P̺"ߔ[@	S	n]*
] B%}D`8 c*UCHw\alW2^Fq{6gOTSm])Ȫ`
HEF-4.B%_?S9{mfNP@EjWԴq!z}6,_<ޢ)agc^Oov
/)]oFhIMH|@@WP2JNٴ.ncͧ0I2ti]@i$2CwI;5Z]sth,W d1`"RJB[%~M*"7,>G8ڃw%m%?^Oϐ1R.3I5y'Q"rg̲cniMxG9]rGKs<]/K:%R#&('!dW׋GhT	
H2 Hуiq`%6sD8E_ėQP)G~zh2%Afr|fuOJG7r#
gw5AYO#7#4{c@t#@m@1ض~JEIߘn)]M-Hy޴=dV-.(ֈ	.25|XN$.x`T
@z{_+FXg*PBX j@T_;HrEnb"RYsrbe(9=MB(8IP>Ka}?HNhd+ڪRN7crBZfl$%8fw/6]`5
ŃX`5W:{*/sطV*}xĬ?Ӻjvq^Z~;3Zlj8!ةp3v`k[ӣO%	dwQ6BWՖv!o'fXkfR_҅B?yo[	mÚ(UdYGfl{P$pkGgabP(`$XL|8qs>{kQ.O#*n%kJ2 bnij.	[?("/ c"O7+O4;Ujlu6L&f#ٽʾ(|1gy=1tt+b[֢.~n=]OYI% Ň>`&|smM^|+:6j"$0?_j0դ+Bd衆6j}\T6k91㶟{WɍF/vĘb+?֢DߚYw{B}F	L$=oexIqI5NGbA!6(ɢ=X$gFJ+s<V񞬟0覝-r9[핈*gFN)OnW4(Ug<Ј&	p
}>zCEV>ںwbb<ݏ+tg]~Ou/VàTBW\5zFXT

ahPI$ߣua{?_2mMvpvP;avW,+Z%|u񺮭9g>lwfB@𼐀C'qBwM>FA@*ts.G~d]2ն(B2ՑϑA"aNf>硢{
4#Ovӕ\Pr	]p>9so?&$AX^z1tu,.J+Ȭ?jSңA-1lYx.Mƞd9sB_EY@{ =u'R{%5X$=t%+ZK3V-	F?ْyQ)cj`k`Y)|wӛ5l2
o[V^ޜ[+	@+Ԋh"$Nz؜tG}P,)mOۙ|o5Ù?,߇yUƄeB֞9d@:)ksyo%c~,AV+F|7즲G,b!]r=e
=W 2|"`n342V$*w
E{r:vFORMDJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYI׿ן\}wVwbTHd4P%+w[~+Dh8",Ѷ%
%[0紒"DZX!1	>:6֐Ŷ`u1-md[@-,x
wC&s%'WZ>PY7N*ǢdNm-HJc%&í.:z"l,"(^h~uBop?
\i͜+cZaNqA)SjZLz ـܱ|7ԖJ5F/AKw~:ppX#Op;Ό|F~}!ۃoJsv*_K3>WV7lh𳡦OLGPC
Qj hг_P^i)W2dۄ AOf:hTwr0wxu⯯P$
YyHn(6ڰqϔ~wRq@[kvGǿũSlHo,[<|f@PyzD%X:#?q^0<AV
3]Ė:彨(Pp.XU^sXs3&WlTכEzyK!,RR*B!vЄHjXGPwbi#tF7qa_.υn췻6xy]fqߏMy~'x\Nk 5#?./;qؼ`1%AKOz7fe[S6.b=!\IXrV^ߦ%TlU;_/97
eӨ[YQ-P3<S%ZL}VꅯYZ},&Snm8=C>Gy?^YE	ۥ0JB8mAWv{ADKb/KVB[iP^rxo)A7v	INj)+]`>0CCd͠Iu*IQ4K ɊQqQ$+B gh@xkU4}>хh8X~WUJ7?J8m(ņ?9Ur	A9~Ɖj2soif$d)e!ڢe(9]Avu]X@7H@OTXTzP.J4IAXl~~%Bq{ߤo!n]<n R{SӢ4l:gKC%!j&[EﯢDAd椦hs*?:|J9=pЏ_$el%3UuxZl0F&Qw2
n#l
h1>UdR"z/;nh5~G5r4aͷ]p.=i=c38mWy=b:kurU,k~ê?'RIڄ6Qָ9%cx2+1kEȕJ E30&SXWL	lюQg/j;oIi-|Uc<IDݫz_}F+Hg\pC)g͹1T+S[qZW?BoA)EѤF2+IWlRؓ;/[WL5FDiL|nǺBPFHP8(r{\H	;)a\˪}$c"4	TǪ=bXJ"AvZ1 (R
?'9h
'vf
Ko6__|mQ0lYR&UjR)[ˏqrPՒ7uN.ʲy~/0ɆC~Ow.x:ߓߜƅ(_`pф4#ճ~X$
>u:maꋌ;RdcQFORM0iDJVUINFO
XINCLmemo-int0032.djbzSjbz"NE`ɒYރw1&!3_,3W!P(S(01;sjTFr)YlUw4D)c<;|1oLa;
+_"3||?ɡ-"!<@uy=@0$Ep#ZͨLg$QYNs޴
tǾeXԘ/?'UT9JCTkW#[VZ2vdp2Sߞ1Q2/c\CXę7)&X\T@YK2KkO:)MrF]`NC[B5SBީHg@zگUa|-Ǎ
hPvYrQIo-jHW	װ;aPiME'Kƈ3[]s!B7zZlch!
yOӇwflƞa,Pm	>Mn^&Z;q8mZu/
+X*<8>m;bXv}NǦ,;	Ysrs|-պ)	Bǻpu0s.cГy:Q/yi7ϋDVhJVjZg'L,yvagk&䨻h
|F(u[ saqAeR2c->?'7}$!v$CgDm@lԬ܁)vw+K,Jt!_kz18T1*e0jAٗ?0镞(姕,90Dja#8SK+Vr<5.]YE_EѯCuO2f\Z
Ѡ`YyS(P}'{WQ4e$
>ɪ䓗Q/;0*dW" ñelܿj;E0@ܷ7x"c(iLB!$0(Q\
\Z`lc<aa_W춈He S)zv:eN9Z4?n$oySywm.hHlC&*uȏ›!	y9?p+ϱGCLeՌ"k`J1&]#<5MNANVbm_
2pOAWh#Gc+}ϖB_O
dFLenxDC8KUXG.Y3͙̄
E_b*~[I'wvٔ[53ahKy3o+OQ{KF|[8HhfBS蒕œDUTUw: -ΈtG-u3'Q$ L.ZA]Nr:ܗc7TI&^%s)s,cz L	ɿڢ{RFc#7+~OxGj|h(Hv5l9*0r!X	QJt)wI&O}Eԟ/k~=yzI1Ek(^lmIR~3Z=
v팆X]p;LeƳy	9bkn{#_"13oSLu@ur9DA>wiT^3_&dZmI9xl$F856i{?R[XмJ0f$W_gEnnUW
A?4l3	A 0RO}/~qJO04?|LQ}H5*UUObaqoZL0pdԃK~e>׃|Fvn(dcF>'Ȇ?>eN
n"d9Z*2Q7%z3iQ ɅYE'GM0U).VwS|	5kF/D)L.`Կz)^x ڮp}J%Nz~~ՙf]*bEWdQIX~$iҘ{Nr2Mh#@_;|0.`!W1@"4tSZνYA?RO]U'	u*WO	HࣽgXK6ju8@ gk[E4&hf	G*Iz@eTD:j=nٱ#Do|'Ӕŭ}PW7]
R4f8L3巴B0iL۰Ooiba2}~a
eA@\j<5ulLPrcb/e3w(R5`Qw"RBcݝnugH H"ˡoZ,Vn}CY8<@Iao$F)LX#[/z6֙!W32G~3v[
j(%0bR~NVl*c䰸0"ѳz-&N6nՕkH 'g;+Q>k{~.FSO&l% U]l:AڌB	kuچKY"ZːW*^:.$Wi]--B<<*^ĎӤQT2,+~SXtDŽ浞[{wwi|P{>-1iq>98.GQ٬=!^.t!&^.
Ǜސ%A,X-".e2%z]|jFbq(`kSڧ>ڱ
=cE$HMyS:Pv7u8Ɖ>Pb]}rdHEb>*R&tn=4î:5e#g!L8B\#!z
;Qrꜞ
!M&Ꜽ脚h42 4m6''^ŕj;wkObMqX˽mQ_zW:6o8!7ы
4Uw?xjj&w3fXpXwdyL&$dE!Ԛ|5?JCi$&&OŬCmHPKB-qMr+S\*q_`hXjz![0@TAp,Mx7Z)I?Ń|dC9,qoY*DចQ??['nkI%F=LQF=ܵ{SJtrە,
Nwcoݓםpwr&MfїIN)I1r(-kh8	xm1TZ
/V8r<Db2{\J]y,vmzRs&0 
ۤ-URfcz\bI5zC1
HA	@Y .*%-nϯ>勗͍vpP`;l~Nآ\r,8{?W$xa.ν/Bu
?lW96Sl*J8Fx*%Dջ1~RbvW2:&hVĜc386 Rt*YIp^b0gV$X_tܼt$-u5i
>vMב$59p k/@P:\?FC>_}lֆ%xA;$Z-_jq:0FPڍ>k1jnڬmbkz71c`dHxɍ?{`dϨaͪLލXG**wZfw$9:tJ̉ f]ٜKuH|wjQ,#nyE\s%DWlљ% Ψ&\-?C:\ϱ%I~dY9w_ksH|5vjK%BÑ!:)7픾sug%0KģO_tGlWUX1$zXvyZӾwQRĪ$[4|nb1RRPQ<沎CH_/am[Oq y` i@)"ExG+`g2es3Z,̈`_S܄Ҟ#7LZ,-3hgBnv`4oiߙ_ U@iuuHgC`bg8GNLz/@!g9&2-04vP9~;ld+bQ+)+gPW. Zcyg9Pp%y:cDxuv;R'qxlO#esЖ^?}L?KC
Vv
kFBۮŁC<ÛM~gDODGo7`9ؓu@
ݐ뜒
EPÿf za|JIs'
BZƞN.( q8!f~QWo;tX֫ҘCnW'|K;{M,2&PnkUr{*^H2HfCZBW!Bro2;mn'$m%&~\ޓȚbu
:bJ Ji>GoNeBՍ#"
w$ߞJ%D~7jܸ,vWӵEw7i0ipN_Ar$d7F=oaUlgh"|1胢RO]lQ"(jUsK7YF/Yɹ,mׯh+Y]w&7@/vFLbb(EVFKS;35c9gЛytbCR"|;<+m$^j;Ir)Ds$*0y^I~_ucveh		tනߏiM^|ЀtwY߲S辂f/,G3]R!~p-7sύw0zM'SYZeÙ@՝e hbgP
F8+ޘdSSC2&,F|Ng'Q@# Koiv)MQ
FGGJjQOkmġLKK,sڰ΅mmNOEd2%	"Tyh:g!Vx8qF,Du`eoY|tSghT^j.
sH{HRB]wnd<)A?IG:&$~F)O=bss̄ň0ۭf5r}mƱRj4\+:ZAvx+}A&y.\ҌdyF|/=h4U$K5|F|\zس3>7g!3Mt2+CSI.oN_,ʀ%%98l<2K+d[{C玁.$GRM:WQ.
ҡ}`,~]h@^FXIS4
AK-kTdb~h=
!te֨
ҫQ~dUs-2/S
M{u0TiV)\6>x^qsøL	bKrP_@8@DXo}v|KS AYZܹ8aطN5+.;\jzK"}R-Q&pYF-ЀȍA_$E{-NCxXSOx˲Z>Ix2m>4"TG&Snۿʢg{M]p<`dH!Cf7wf\rN#/o%Q)}::j:`֋៼	
<@LxDFJ8߃@0땟֛qQvjfC3R`0Nk`	z3Ëk\ԸhiªQJ2U!+p1A,z51:*5/
L$Sou>#LmdМ'6lt_Dd
'Z-z3Ρ'-܌Ez?ob6WR.O$z	H8^vD.bjRSadùRYo|@"NԒ!yٰ.f6|
:/Gyys~wk^|lLł0fD[5\jW]k$
!y6T83}rN\J?+Ϻz\¡qaʙ2Nm?}jBSIk)^JCqL~a1"UwFKaď0)#P w&@[yoB} ;)YhVyM+!Sq=kv'/xFѠ{uaQz]ҙ
~rCf5ˎh(cFqT#dd@ϩGXbO^yXKG#TO|G{.QAsY	)KUćWzա\u^݌2S\Եݖȇ3jp@ZtCUۥ]jg
fo)K w
FʏL˷qXoVwl=֣Ydc
x-|m&&L0;`j	bǮ-Gݷ]썏pJQFx@Si l8CK*h)gB8\勺\AVF
d~4"]m NFA	FXw7xe>lWȀ.RMTXh=.=R"
7EA`wŒ˚2-,lX&_\cT@q"ED^8ѸL֌DMM%
]Q.mR97ҴbRL>aP6E:^֪ߋQd>ψ52ކG,,FORM!DJVUINFO
XINCLmemo-int0032.djbzSjbzLE`ɒY
'˃ݝ&G}G=G66eP/wU-fQ_V削fAd3ЗcS0_ә|"eupQՀto R, ?r	S5L#}7e;uj%8IV/fOvݟEtg\:,SE"7F\ZtLN:{\Vt
WDoG|;DNOU`@DH@kBx9B(ɮ&s> F̲*rFyDiSABWU\dR9Cݭ¿mRfR`yD.ÄJEŀ}am"7ܲ~(hsRYE`p_%ka/;RJ:EdWLمgƭa$wsiNc*V9hU3g0tzW]P)[s8`Д~	)dO\N-IGU:N5'q-uKו$m-@b﹠;UTkUZM7חȞ;yә/Sx>
yL!(P9_sEB84
c_[&|eE*w1;;
ψŕ/2ca{rv-w14aflͭOdi}pmޢ{QwFOKT^٨^"a=&U&q]
T 	XJo9ШY>ϥ$zi*`=Hd*["g#V6Jg
aSrX٬>\U:7///"RR̆ѽoC{ѧaTLy+Ԡx	Bk,6HawZDGG6<ͪ#4|D筯J0\._G'H7̤1P);j#&ǀqs7RQ":V'5gf7+5tH&_fJ2P#Jq䨕@Fve-Z
M|7g(?Fk):]O$~\Auɉ;['cn\0Nhֻ> 1$;dƯa)X}ɸdc?`:T#5q8t/mf97ů9ICCўv@#hq
|
FWc1ywUVdFXY5
J侭A;LWfg&EsY7u(I
+:TԼ	q.jDふytT\CRvGn}v\^؏W`fSHLD'iZҏc1vՔ!
}b*E2p*d36Լ5ś'TJlc5OqbQUi';Fx%J='CՌA5Ͷ*VX)ZF82vWGA ~yz:u6N+ԝE;%KIHHlN+K}-!$5_r0CnP'r|a+T/(p]\
j =#_	 MrkEPyHScf&iU'JP3m!)wGK|Q䥤By%[>TwQ3KeCqv4ja=K3?:B^6ĴlPf#!jN%'xQ~=:jZb%72y|o*PWh *m%澕r*EԲIm0"V伝y/s<
|?h5Y%7pHAqtY}x\>ˌ,/^H?;bL>myvpXgqJznIrU)r@eR)
kud4䰤|q]
o,D'8oVA tJ8T<θ&w	
	gk8M=j_?@RsŦﶈl0ʦ%:
61)[~BhXRŸ0.A`FO=ve_Ф
jx
mT6~L`p6ޅ\Q(m^л`˩آE-}T"zlBHzL9MelMĨt:IrDSv1ixN=Bb)v)6e+#VgxJ\ColнP	:	ܴ_za+}v	=(56+lpV|twKN'LmmrӃ2 G˟b M'/s p>䢙{=Jg҅40W!+7t7|N{dIeӯF;=~t:WS
ι
!&}*WغHgvCo"z3H^:3v|Gol߻	7^q4oK]Quu;_4RYT͎3mD̢r03T2SRtMs
pȼ`OBW扡w_j@hA-(\V6ʔL$HT+\_0ϒЏBnہ!m4z=68`*EFBG^@O
gv*Gz&L=d"u+F,H7M	΀cʌ<Ù?wcf@(?P&pziq2{E
7»tA-TeN&I&V(҄[Lt$n8ϕ,[x

pM߬dg1~lObc+FT]幹ѽYR358,'
R!Q˲sɓܟio B0f
b[%md
N41Qw)jc[ԡp`2^,&߸/;w,&%ιdJZՊ| BDluSyʈ[koO늺Yџ2N'{rQx4dZ(=. Z\qtnClԐdǯ* e]AG 	⦊-Y$%hQTD=ui%
*'A)_09KzBxs夬f3EЩʙNy 뉿A1<ڰ	edxs3N"]%z0dY[N0;ް{SԂf
FUd*wYYy]
ni,)sZ'缠Pa$5T?l:2).^zL]d:A39k_ezl2b{|zO]?XMh2AQ1xd` 9Ͱ$/aO?@1a|GT }F͢cҘץcv\/";Ts.j
 uW	DRtA_M,hHR	:en:X|{!$@dEb:JZ@
\w
r~?Y˦µC<1ZꄸPVu:ҿԹ|x WYE46ʨNg
f#¡82s>U{N7k%aViiai|pXTPbq6klL)l!bBk)ɂIH>Df),NM5*`]Ds]3~A
6caX_z8ǒ]TJޒoDĘmkq4B6lawȊ	gM˂a5;~ƨgֻod
[۷[h(4qg_6d!O-ݹn$~RAYLn·<B
Ƽ!0%?iz:l)DЯm,|#ѝ7lt1XjuDRF'޺kS,Io?<ّ>DqHEw9(bTQ0s,un[hc76%qӎ4:$C6l]=P$ޮetb;vaX'"S0򁰲a{gUlѭq_Wd>:ܿVˮ.`*NG;&I:TXTz
O}.J>Bل=Dh]_|rB%x0{t|i%*Leg'O423`-uxr-w{gO6lʫu_%}!gJm9600h.u'X^<]
ƔʬT[^o_cJ.s"M|/J-+FJhoiwșmo%bd8Q	CYZm*\M9%
?FZjtEIdTxOnqW*(ԓ+6!چ	bR##rXzͷ4{iXRGA!K
9~q!i{^l0#2M~rR'TƲ ٩oZ~NԈY*(q=ehA2J/̨Yև:_K:lb}ҕW"*~d8swCI\U>aM™I02G+0Oْӛ!3YHc-𒿪!#A\AQo"oH4e&e

lL)@s*J)]ķB`iOi[;{a>Gsadl@@BYcp\C|)M|Mv8p:1TG$-<}
;7,O#-TւCQ$l^ҭQX,Px}
wv4x_6K뎦e1IQCwT?vFә}\s6wg21yyy:9Y#!|VjѤHXƭu}ڼ^4lCM$ֽ	Ir	{r&f\+6:Ty/{*B1/DRnw^n-z+'6'd43$5H"(Ě$umٙj֜/^ziGO)L#_ ħˀ\ KzӮ<@N-]Q(MΖ0N* C=##+Cec6m$F§xgiBGH핥lgDS}JRup=4-4aWf\BIA,"-zדmgu.IPx=.J"{Q4Slc[71}/ZN_JHU}kC[$	7E㊳4Ғ `21xtjoZT`u~iL
'Bš#xFG#A|םشQogPCr,~ nO5$,ODuc؞}YjGeBUА9(3\HAp&P!gԳGZR{TiМ@EtBT o(."Ȅg摋[2d_Lm.ѸM!'J-1Cl|@?UCwR:_qET96\y8)A3Lxl,K|FEv'mr(
HjVjk|%MU"|G5PT3\:tdِ%S׀Xb˦hmw~0HSCG'nh1q֣q̀&1bIA#f#oۍ]B堑27Yi?L>%[k]{Q4c;0׊"U|1sݵ97g[\˩>4âj-2'UL(LW`Ć[[xJtnO%;ƨヸ.:-:dz
i8F96	z˒/Z=ȇzw`jHueDlփߋq'eD8EzwrnEI~yԎ=G.g/ArYYX?*082(s;o#lsˍr鋕Z[sЦoFW>H*G`H+5B$jpMx*,l_-wqIz迬4X|{U/.%WD[캠,ט#m!av;w(r&.cU]
|r/]97_X	FORM%uDJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYR&*Hȥʘ\COڂUv,FtGGE& ga_P(e)C$ߕ?
wӳ8ke[*fm>{wf{===>w|CIF$Ufb=NϜ~])aH޾
(?	2
g "]Haman7?,,Qe+ͤ7KT6,ѓY>b
*kӿ9OPQ%K҃>|AGdhr].;e0BUC*K.>nٛo#Uq=
<9ƢÂĬ4˲fx[Mk̄`sKk޷[S@BSFB#&S%5\=W'=UZS4H%b'ŝsEd>^'Oֻ>QB#wxaJv>hvc3	8ɹ&5Vm3bը^%ۉWRM:+kvVXdeh~=@rrCAz#g<ض!/"TW]74Yʺҋ]ЦdBy5BU5؆OK9K1!
hLT2ʌGծ51$ِk(#0:@Y^2UXJ(֊':Ekz<]*QcGC=[j҅yi
d}h3ɧGSẎp+5zWnѳ*~t++VL;(=|6svbK+G0t˳00nRiYZt}p/3zv*~xM'iUv8X2NhJ"A..^`lQ﨧@0Řf׼⧖Q=UaIlDl*c;G#̱_K(
'yΩkPSDnuLj9]>HEy	Aj#)?"a[7ҋ1P>3Ei&QT-o/Oy[o]_	Y:uE3>M>!Zh(Jn$S+$1=֟<ѳNK^TSg[ϝJ)pEEi
ҸkP xJFqv[T91c̽tRmKH+Y+;V%`萂hvXԭۏ<h"QE9CYM49G}; ZM9^WMI}:1֝LCNFʼd~XQsr`g\]{Q}$v՟??Q|!u9PHd
Zewz-e(dq8?n3
:rZfĀ,yE܇F
T$ʲ-!2u=B7^$:A9-5BwDORMRwsEmLzADqe3Sqz&-_Jp*lG:0GV	z\
F]#bv;xdf*mc5і$9p3l=IbyI$^lvsds!ksocjflg1F]ӈ+W.6Wc Jbr.x"ϗ&hgvXz`53TQ`33WԪ9Y¥͟]~,-
$ɬ*D"zyhCBmX0j4hsY*VQ*Ҹ/˘7!a%KƥҢ6,z*V{DaӈOմKBxŋDP,)BM7I³Oj',__KCw:JρN MtETi &!ǼD
g3xoX{s/xep?7e%/c(,iꑊhy/PAk(@0_#o)ic6;KDu^ng|\
v?
"=0Bu@}@.>>~<ƽ\2'O(_SÁBxk_-k6rŸ}xXkҡJ~gGA]zzEVܓNU40uh~K\Fdzb3=Dzdk+x1̜|5!yTד
hcf2+hk_?U/i9CPSV)
lb%C-9u9+Z%qTh|f8ND{%<~%=bDN:ʅǝOhI1pVtU3N7Q׆SP
k).&W
upiOac9;wC:zsMy*2J8P[jeg
!BA3km	VSiPE=#jÖ-.Eu4zu+I݌Z*0`sK=olq]:{,KB_xU9ɏ-C$@i9D:^ӻ1:+
`\!@X3`׳VGnڛƝ5@/&ڏsD/θLIFD$;K1D_|!T=s`ժj59N UxGBGp= q]nP}D+1.W{}}$Qt @iNr~Rzf¹37R\d,1nDsjwʮSĎɭ8qhu\!I}tU$'}]~G.C{3h%:$Iz>rͳޙF9&cp_>m}_P:`P
#Zcvh?Qw~xb/Boc'PKW 6Bª54)_ͼ+P`P;gRфCݐ.M{B}`5g/lŮW	܅>M}.61A7ζx-i#t_WSL?IᕛR^6hW#F4m-sksTe8dt|e/^f'7uN	5r%YcP?I/yD}mz$ٛ"8d:I=.D	fPJ%Y׈iA[BL@!DLB䙃k_1`]yG>*.+(P˓ȋ2O<}5Z#鴂FD:l/hp5"HTtpsO/Wm76TXTz?爉.J>A]K3FB/	UQӒAEWd4||ޖ$ov;߫<jWuхRKis1̧V	s
rU`6RKoVUZ>o2G6UBJ:R!Jޑ: WpGaN3wBH2Z`sqȝbq?|i
N2P!BP=	di>++*,gǿ{nZ+n-]DCf:_et~kPhi4gSY1Bk߽W6jRh[XhU5m]o``[S1'w)cF"
=RC;HZVT]SI
n:l-W]pr2m=#LHM${3,MM{`H>WpP~3ew"\u2E<(fb()@]v.
d#Z"}D:9%I8N84	=fs\)٣'R8oz5Ue+#EbP8K\
NHLSI*vv%JgSso:͗"H=6[~"DߕQ?XZ
h,|Uqv^\DV$r2j\ۀҤ^*GF"K8	یC(Vƫ]S5dk䏀ÅbEa|TMdT)V7r:
;4{ݴHͿbhzhÜRq!ן̑p%v^Wh$ٲ1ȇlJKtI Wv)OA* d^<RiG/F%ݮehv̧KdyJ?$|msnfRr0h	Ep&UfpL;cƸCIQoTMX`t,/l}j'^DqWs(!vU
k㏐DZ_@X>dq[b?G>ѦܰQ1Vk22je6լ
kv2R*30~[t
C\VT~]DΘikA=ݦ)TZ)ޝtgX].*4@2Bit"<{.rҡFYLdK#p(Xz{lsoEqQKlsťWq \Cni'ba8Y`)a;G$huVԟQ?%p$
>jd³@)"ط8ܡ'[vWZSqlj﬩AF!;E
Do%aR%DO!ϸyJ5tD2$$g}oT{R?3XveF$IIptbIdt冧Fq vԆZ^|u^-˝|U[D
ܸ
vq*"g5N;
Ah50&FŶ/z)NiMo]֮mHȕ|F2P5=>JvJ|B}_%M| ?x^SqW}ye+2=@(J$d#/CNXv܋h}b쭀zguDUogo,H́M6SIA"r*RxnġU >U16sL!{
 {s
\|$>bB**30!Fڳa!n_NB 7`d9J0Ssտm{>ᘬ+(A+h/g0]yFORMDJVUINFO
XINCLmemo-int0032.djbzSjbz>E`ɒY	0h97zay&},߄@+ ξ!?}ezj\n"fpF22
FHxpSE<۠R|6jS{XI^W/sk9|HqΆ(KbR"l	_@ۤkwp7L=ؚ|LmJއLy +ԃ5G5b8-0;891ne1ligYj:yn㹝2%n
I$bVUpc>ޮ^'4ky
"Pj&̼ƓXq?;j,^@ο@)z̸҅&OUCQԆi@ 	B97߷D]Bi5
DFǵq4eH*Mu8ATVegNf(Ӭo怈6`\|tu9X;vˠRDRS%6뻸G>]f|q=39	.]kF;}aAeypI7n5Q7+E8G0fr&QΕ;UE,Y\h^
j9X0_t)	ߏw.0UyJmR!cX3"@)#y9PVD?U8Tx5?
lxjC=蘮
B.=tb+^JRwuc)w$OuDHy%E)N)
n#m>
s2T$~_}X~L6RDiI(?j\tFR.D*97E!~֩[Ys|fl'{RxwZ
+NV	RI`MLR8GX:3k5p.Bo-1'^̞'2X4vhǤnkZz*ͺ$ã*E(;U`]W
Bٵ+AV=6!1gJUQ@;[iߟ!qxXSWAKd=|zmΣ1s>^2ZR}J~bO	o!1\dn!ubYRjHGϫ6"q랧\`@ϼ.Uزס)׭6VBt^IX*oxrByӞݎ4SlR&N{,tfRI>
&Q)W[j
gY!×A(\clyc9oD Ųaߊ,ʘyoSWKȉ5ǰ7U!F L=kjQ+>vyj%vPR!7Fe~G .6i]XPRBB#
:A|:ϮN+Zkj4@ԪJI%UЮ#w];XaioH݄Ajq=NAMA.)S/6DRWW&n߱' f]Q<) \YMKr~+]ur*"E2T& j2cgֳæR&~@_[$=07Js~"
Un"Q
9ց|ZpTסu
HM0}-W}KA^I6tY!RU@.TőW&PB}Ud$Bx-龵zxQEܤxnꯂBB`WR bɗkG;=owXT}swUL(nqX<85嚝oC
Cl*9Xkw[t
2ޢumdAe7;P/Yl!$TC-?fф:^	:OU6+,mBӮ?7S}aW0=H?R!,.@2)	1.5SB6qFj`Adz̰ڝ0 EFȐ5{z
]1@{z
1\ ;:܈>mgx5*k-GJ+cJvrN5F vkG*	X	j|URʞa8%sF3>ٻ )@?E$ّwQ*,gw.C#5&㙅#otɀg-/f!QpKR\9K\^
z׍\&Ht?
#ӭybXSgn)nJuכ74>5킠ć_>_j4HT%R.69&g	tK0sn,I^hcekWTXTzTw.J=>
آX4DT!W
j,5}ḺqvmtɖFMfƘHFYҊI#:i<γy!WU|dPrk_A`Qi=O.gpD^ۼ9ύ`b2gAzb(c1F#:ĩˌqejoGg:@t$ʡٚd%pL^C'T,P60MHHm6
<|fxv0xի	R2F9#'̹+X@G\|7E19V>vkT+E)R{k%Ջ౗Nzhad44Rf
pKjP6H)n9ߒVL@ɢ|MpZk6S,W ws: 7d$?\Ioc-VҪp4nBJyʟXp׮#ƚ4SE`'YvFiRW^ Bb8ʛ6{9y7VOm|+_d!d4)*aqqEf:D82ŖeCKV/	lJw(ܬƴJCXw2wKȸ!Z]vĂbIEz!_KD[rprʻsED%G
U^y%1o;Sa;NP=S3AR$_WHw(ak
a*G#ޅ/H(zl`Z}^E񱼔Ƶjn*ՅFQFk{q6"l7@^x#o>܊lD~0Q/}.~T8}Z;[Bi	fQxط',xEeBܶI*MT-Ns
~8Xi>TŠ>7D/RL6:O[@ъǨ}ViXJ$`4o71iDaJ`Z[	pm,H-*U.9IwlX)bIt>d_6_P<5}ϑ{2֚DOH1ڟN\`1GHjs(e=TNj43(DFܑuV=gw褬6,@Kc<=.|
y|aN [|%vټC~OxxkϘ}a`l]OGlaQ3W5]0XUa\b
jѿXߒsM! /[z'T}p&no tLKiI
ӄ+M=:a/~U1P_܁G<"^Ődۡiz;aJ^2Qegc'x`%D_:R3M䫡0OYbF|'裂sDg KwºNwR*!:sGկ<|"LA^FORMDJVUINFO
XINCLmemo-int0032.djbzSjbz@E`ɒYyp`	/?G<. ,swǃ
1Kw3ĦvJѸeD4E5^#Gm*M	BJ;b@Jde->dog)?͉{9;mh~Q@[##}$l2bepWQ^_"1KpG0	'a	{'NPL`RoN09[(D{SX8C `B~ʲ6G?oc{zS&E6R:^ES1N`QGZ㴺氒kZ8FG*u` \$\aB8 U>ȿB/^9`S؍>%mZ~2	hr%<'
%^Qto5`8SgҐAc-o'`1fYuU<vk?1	#7]c(>̉rDrN:dmO)x;-rԃ"*//@%j=ʬ\:WE0&J-@ym-_PAHrV
)~2u&fc|PaH3
IfxUE9f–mdDL.qg^N}JdJ[okGh#ʕᕕ|8[Gg-&i92{
-E}YN6&Qc2a_Oyܛۉ0ZyZ[&ZR2ԘFdC5u,Fkl>~P3̆u+1a2z#3azpC^[7au++̲I.;VpD E.ĝ-<'cw3>99r8L0mNcVf<>";
\YcAϭ>TF4Mea&DwQ뻴ن>Nou.Zej
.ej
:YpU1A8\>)-տ|]t87UYaהt!񇖸0AV ^%`20a4ZCA㌦bN^vZ+kX{=Dr6x𨳈zTѷ(vz]!UqeK
jMx[u=S sAE%(3>jz9wc'W]$3GE|K4%븽Ǣg.Xв̢|b1q%,l)ۍ݅x9~OND6(5ԥ HGvykh4M4naMu&CM\AX0	]W>߈.F9G)2tD2Tg>hX%vtc,ULMV$I5E-aѪp:B:NG5Ylt9Qo,'_{$~%]lB} 8q~Fkt&BR	RJCB1%wۥ${*XJAfzPu,b>
BJX^wYBRDyN)ڋ7ԧJcey!4F%puNA
xgOïRH8ЛGX%[	4{`L2n~Њe3p`7=)wސ$UY=q^WGIr@@e;'Ÿ((wz
?c
1dYU%-jnB#ᨕ\s ?I٘FF\Kjl}ڧcϐtIM700,4:
_z5HIH§kV
Nf:ilZ ˿6֟!0m>F$AdJ0>xd;ӗflv3bdbu1nK+^ɺ:G1pщ_sMLaA,SGcO͢dos{QҹlX}j0(vݧ+^;~╰o0vC5D]D):)M\QTTFe}6zʬlfSK4E5tiW.H]-߿#/A'lpo77z0/0a1OuJi3ATg[T
]u"bI@k?YvO馹3QTXTz
d@J>ܰ
;0x(L?^GZĿ#΁aZ#HG yܰe-tb>,̷d~t.6IՆ1zx
(̄Ŏ_21f%zv{'Q\rИlhMZ;qv*0dcq~k~=0+D̡gaڢy Yי(A
j`J\	4A#j3덟4P.}@>CE:<3Ρq!F""łm!ύHuI1E*'%r4"_0kcq:|H uEǡ;Ҙy']L.bi䲭k#>.Ert-]|r+'A-
0fz"pkAi
+
Sh\	un`+}s=	=dIrBTg%`
 .)jB;}$?4g[ߋ;vƌ2fL|pgKRp!f;-7;ʗAAU6A3WN~${, ذZxƹmKZ
y"c,~}Q`` ZtWRjpxB/qu̅~
1Ӂ&?Z^y91G2I߯a]_Vm5SEqՒL
A͏J-F',
5ub]i~#^7td4sBjS$oĮRE؝Ǖ'_TShkuSz:v57[έnu|99bƇWw3,bf+>(*3P+G7'hV	-CL⽃of5{y;qU4;g9#֡PVkJt&Yj-rgV(M	E{fc#JwқOqJ抡iYoIqV{=#M$of[okd\v9#['*cp*kWGT4JšwJ셇H:}1;x{)&$gsÂ4I!@ıgUySTPlȳ姂odz)v='oIԌhNU?g+*D民YQ?-);5O3:lq$0լ^RleadH{
82#b5@HͿ7F[cא3cV1

/~vz8uΌ_d$9!<ʺ˄t^Ӓs	Ljv{~sYq'߹JBΒS{Mӈr۸
/ݸzґ\-OH30yP0V2;Tο?BvЪy&0Нq)U}7,u)|0x:M-)P*OloÒ֊wV!#춎$lE"c6[8hl)wh*@#'Q.@IeעX!G_>jlvARjUjzr|`~YT@<=-Ԛ{x|p\N8ٿVYb1(xhU`Oa6haX
ˈj!xbj<T@	ݒ9	s2hG0zqpT#'&hl	y]kO8(לp$1Nhg,o4Q]$śj׻5nyU.T;&7M'>M>%[IP/]*<
A8pag1z(c#@fqe<)C[WUDK*H:x?0M(Ol,QғbC;P6-u
[vseq/tzC¿Zï'N9`Xa2x;t!6;wuαxKާSθ;$%hhǕqX3	=KN;7H+2w;uhϗ|Z͜!yuO͚o]OmsțC~y!ks8m0=(Q#<O$VSAk읎H
³GE~喱^t^]#ov`6ա({+PQןJWT'svզ)%ZTnm$󧫤$LICpyurT9W[=]g?{v(밋	%8^͐%of;{͂;Ό/>/d!Xo@ph(6mVȝlU
$^YV"G;KQ=
3GQgبoxCg32]+@*OM$\^vhꗲΡ4Z(mhGEE4>`e
PI
hH&T0g5@\HP&֑,٬Se1胆-)٤1m9d +3vLBpⲳUQ
/c:"8dg$3kjDRz=>΂M`pV5{^A~+rKnTB~)6y`&	aҏyn%/z0Yvn.L޹Ɏ]OWHJR4>!Yb~*ϱy7aN珰-p![XQ7,7]I^WP:C-ewoH_zLLʏ^=`:{xo祎GL"9CVP.r$d$Ao 9c'xOO`T{U2U0@gj$Gl??#f6Hw;~VʘOjp6?&c˟qD˶<]:vͬiwFF
mq`Uys'yV/'
@K_,Y8Kũsk+%h!۩ffhOV)#?n3oq&7õ-NtWDRvGw=?3*#u,%tnO؎f.Pqb^?VjPHZ
d #>:R+y|Y4Po߈bԠgZ-!H4(D|t^\m~{c"!@.s
$[=Zp
a.I0.GeD5)F&2ZJiQhvs55[PƴQ8[ZB;
eFA[f}*ݿ
?b
7^IB1^^KK
gV6f(w/BA)	6"꫍^qJlT:EXqE=gy҉fy>FN!!U
x`iUwBqZU|رzbgaJM[7Ey&3M&
hzNrVV䶳2G2te ;^P0#Dȓ~GYIbRft7e:ЯQ
.
I',RJe:eA3S'XVK}-VP^"t[l5[-_STC7ٓ&~C2Tģz3?&gƷܰ$wkj3!lB6CuFT8)
rv8r]OvC :
nW>ﱌB%<1DbkMy-pH2H&+ܼ!nQ}RWzfGO'@!&KaoP`}r.G4
F#ckN.i>x9^J6ݫ];⏦26Yҝ`?C)O1c$z@l΅nn4[Ʃ
{S2P:q&ψ.O Hch>7
s_;3egsmH߉5	[
S醍) 5P3dn󙑵TS?v/&OHds)3B;E~X1!`Q](0\(<7{&g}5wld9R1Ǖ߆\\{!Xx_V.IHM_o.D:mIWl/,Be4o0h`[4n+@/n[hE1\οM+;^?)kٻϏ	?vp<{Ä~'^2'2rvkeu<WԢ,=0k$&qS#+2O	sf`.ZA,҆]6=mj:46D(V;HҪf5K_agT/b"OHH*iO쓷+a]=INIjTf_B%zd͟rYğ:-X0
v7+eXnXɣUtV8,IV:A[j~?\r^(ihi@[d
s+qt"WR@"+t֦k! 
dzኞ[WkS}nZ;?͢FfSdQb%izoffۺly!E>쭟	#]՗v]{=2QCE#9ҍ !,~ 0Ie|wIֆ?uRTSKdbBu9Y+=\<[o#`$p
/¹iwבvƍSk`:V
Il$kJ=@XTX`1=l>ZZ_	\z)|@:Ej^VShE!Y}V)l_^uYh%#ʂw,N$lVw?uj	MED/ƩXDB33vېyda	泣a-((PoGbo)$;CCE8%cR+,Þ녹dXᴊ˥ifL~Y>Z4.#S] b|
Qo
81m`K~K)+>sV1&v|Cy_0qO씐7-HVmB7'?f3Z&vt"^nS^Wt#D\&؉}ڏ%a>Bg'0^+w\.wt}=\=|&a(>R'a;v%}:>qt7KP'5FOxM^@W<E$ABəZOֹ9J6_RbSQ/Id;Fڻò.v2&%W-ZdWcUÁR4-Gg\\;[<Ӗi8G=)ø_b=q\:?(;Yӫ6,0\2m(e}qƳ}:*jL.[C`"Q1
8T܁w:sp@erYkVh񾅰:$da&&	/T}-#;
ϕ]җĎR$(SYQ¤[Z	,  y/-ljl֪x`.ō!3p啧M3 UoOZo2Db+†rlS'):b`Nh\!|eL=BPp^ݮgsgUj^wt)$:=Fb\¥}/2xQ`e*H%챪\51<|윩W[(_]1GDqֿ7N@hU-$7PؽVJc(OA֢rk&7FXI\s$M.eV)0

AFӋfT_3.4}e?Z^u"ƬS-qZkwW|K!w
FORM'DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYa	0soL'[Au2D꽯Q>=E
-ߋs2,+"űwfRRVm@"wEJ_O(i\YH$~U(a"ҟl'eV{K95
Î6iǨr[LaM^	5E-ߛSWjɬL!r}9QɤDroϯfnqb"88F'bj%fs/TAJ^]>ٞ}C.|L~D
J(#)%Oi5㄄p9戝bdtՀJT՗Y64y:CqxNS*\sF0vFnoLu	`FР[$].qh_2-KAHLިnqֿK|>Ÿ/Nh׊/<gzN.XJcqzORsGnpeiMǤĠw؊O,ڵCsUFA?+䠼|[M2dW`\$c!CLbXB6SYxb6Cmت=>qy"ԫǮnѩc3x.du$AP3{Sj5D53| #EI=hNXUm rR$p/<9'.-3T)>m~`
wWbCP[I+&Җ%&ў"bpCceEĩ|Xvԑ-
b[5]*n%T=gK"99
n\E˭ʢ`ko	Pح
	@ 'o(ȁU}@:|Dɪkov@b1%yN/lVf̠em.&sCp#hB{ڠ߯~Z0QJ@豟zo"n5M94H׾zyÂD;XA6RLxo63a|G[6U:uCFIM	^[<`#Ȼ]x0.	\z{гnU;hkcpeQc4~6#c9*CoT0fnd
Qّ7WjFa?h;:bNCgٕ @T Z32thj0>bx=b6yFشdS
}eA	2-lAILW/MrH>-n£ӉgeK[vp!ߋoU@7oE޾Wὤ>(a!!:p<۶yi 3fs|M,ŅbGϞ-ΝMdz4ygor?6@}\uF\>l@0EZ"}y5-jD@7٦)Oit'4䎿k~IVsQeB3Ac|WnsM6S!yyHBg&<_
?D!f1UAFydPq!)aίb!U-9H[ ,iO
v2xĮA-ܛcI?vg:9Qh¥c
l	CV($AChzFJ];c ێ1+/A_M
@IRU)Qk+G_gVݳLpc?p;@nW?H[a4aLZ݇hJ
5q'SH?k9M},Y`kLG a}Rti@%ҋsj8*uOutKT"}yI!J^:i{e薕1L-v$õ)2K`Tzq_yB	Q{wWq(,&C_91Y)`(YrWO5b^:xI4s&7}fA6k=0lZ!f
/#9LcDF(qsy%l0ʹJ0ܪdB{[X^R=B<dW
'W	{l;
4٠xpV9Zp`qMn\}cmZG%*ZʷOl7qv>>wOJ#v_U?X`icTNN5.;N3rʏA_rǡ?B+89a/ 2LN9J_E(e@%;CVDTPXI^
ȯ0]R3l1Qt`*0[bf>$Vl9vڪO
m%тe%qM@8>b:?Kۮ0RRyq6LB^Aѽ}YacJEPQV'x,><]$#ib}مfJyg'/ͬxbNԫ:dMѨ{b
>	8C"q3p#Jh%C$`5bQh?+:ҺG]}+ZC&vNdSٌvfxE}E
	I[{t!ԮVu*kd"DnP!3#ٝ"R+j{TZ){$7\aD7yfj7ITm7;|t&ޖ>Rɩ0jz[vgiIU?&%j|aBΝlv=sa;?1Cj`A1SLPrn7;ï[>ťX;pR&@;7׊4v>34WǸ;kӐB%l4v2B;ʱP_)S$TȌ$#O8\P
^羔/PlR!v7G|_r*+*ﶭ_oAV-?o;ryg洂.sm0w.zi(PRFIx:섊crfHH
Խre@$-+7;`|8b[OKe$<]y)|hrf-_+"xޠ1۱.YU6])07YVhD%zjMZxBl28ԑ_Y^hIX΢=s-
PחP*եdcpkl~	m˂Px&wf[4T]AD_̴H[x'^OK{fsev,t!ӂ1FTZE!7JS1#[	=UI4X/J`Zʋa7ӈXHypJִ_]_};&

X{r![,PU.bAgnj&z߮-G#zI*o`RG9'&	5يO,>K!;&Aqq_]US9soޙ.#%Њ oMmO;5EBE5:wvCPLZBx;87kޅ)Qݱjo	cWKuze?) Y)ds"LKWmV6QAB[Zf]߮?_8Q'<s%oAZ{1i=YP绘˿"ƒyzmI@My  8.E):#쥞*Go|.f@|
]O"{Y*(1-Ye[:6B5S OH"-bJiFO<{ 6&qB!6qv0r+V݀/E$P|hևZnf/ETt0_+1շh=1uOW6
-ɉ{E3x7ÎGL	6^	j&76_գ]\1_GTr"o5d
1St!?K(H0@VJkTUiT@tWħxt
7ӊe)q+Ot̪5:cմkn1\pv+?

,GaO+PI547oOX xD(3*Qefx$GF=W]y/CKwOn|a>l'>F-s&
(@㩽qB/IU>Sa_2'SA ӝ$KJ=G$yZw_R9DlL;SkڬO+V]Ԉ 0"*֊y915Ds$SD%//;oJX^t
ȁ"z?n~Jҳs:}"t(*i
TEQ]䣴O҂DnZ_Нfo\3>_R44T(IbO7vNՐ;T^?N~	Ef7ꓻRŇU倶?ˀ%*WV>L>-eQFB~,X=Kّ[d儌 z\8I'2Z*ɜ**E
)K036F%x*C;q_f|wA+5rΧdťr\(uXNޱt
ʆ*jŐy7(8x29#׫\g1D:i[>켎T*Y“&{3X1C«Hw7 ct/$w&gphh\Ģ>jJ!O=
ee_[Ayh8(3/=\~BZ?.Oo}!׺BjymSCG	NŦc&i*v&Ŋt0G6;i(6gnn|Av_
rG7波X)?hdYl~cxjF8wl+޷RpV0ʔICg z]ql!Y[rLkz6?X-%"@ڣ	GnAqp=H3mj[ o	áWb#\_,ce:N9g
v0V$c!Xw@,|&}iu8ǚkɓU)hp=	zB%Mၿ!s`y_ۗ:O]/~-f(*g:$pT5N޵Պ;'+){=*̛c6J۶b1
䕞9ipِ
Lt
2,;xF<]{
BFt=fe*EnlTXTz舉.J?)L?ָk3\$W}lfFxYQʗAթcFx{G~r	V{ȱ)(WΤ*!d/<"ήE|K6#mw92&FE'
Iخ#@c'B+nv*rF+\g6rKn`!c&"w=oai TGRGh\=!c2&_is	|$U|:ccڶ:,z4Aґ?>F3OP^ưzciBV[,Q1iu9343TsNϑ?tk(dBk{>lyԫHȃN՝P(d=I>$
	N0ݞuT5*X=
nG
Qv6:*܎-e
A3#f+U'M0Ļ[$L)*aNroӣ:.h^LTJ$q"፰%U'Xf|@[x)N+'VgG2.}cË;Qglϳ_`"PIfA^=\ߘ]VϟWuA6f6]fF%t}BYߙ^ǍR:|x"
p4B&$:8}n
i}'Pވmot4$&
l]KE;WO@b4|3c[6-t:
>{l`+kushMȣwdDo,QMLo{_xܷQקR~DŽ4W~d>ݰ&Dn?CG&	ùu7xkZ0A|x1FQ
|qb~)Dp	LQͺg׶%0z7iFyXѵcyVaZ^Vu35v@pG@vtbB'8KY%a[
*	=dXs⾞^УAa^poPm~/?G)cӾ\(ԘSdo7@iG6'9*RHwwW:s7(m
,'_IlE,.W+!4kW˜zBs[
j,*-$k0-ms* vTfZUMp~dₐw^~%IԭcH+~Hn	_-%q\X}etX_񸂵Ú @UX"VO}*-N3ʽ9P1.]GMwG?(J×ɣ
R4&*D-hC=vTq0iٿ?(\'|&l*z$=DU_zSwČ

%-?۽3*:z-VA׏xy{tY}*~Qa0"Ph'n4 F.elOFVxCǜgq|R[1zeti_$[$@k'zDfe$ѱtYls$x>!Q͔WRJF~gJG`6ڈF)hl1ɚ	}\I;
Օõo'f8EŚƕ$܏񥢷r
s}OZcmi/厊
+M]l۲834Z#RO^V-D6i#!8vݟqc(m+[Si)_Pu/#3g=*jëpɡ#A&֜Oy
6Au1.mbɧ0JH;Dbfu)sHa(FSu|]fGh``_f)V5I3y;sXYS~$J/y;?aDaA݈#c@jq)R8ܶ|7Gɨ%)D	*O_%i]"(GM0tʇB*cWZc`_+`Da;4XfρOLADN`.Th3ZYqCwa5\.d7)SM"aќd!aafhY'vfM@V0=̴e
6?SӸy7G~
8eHE(l".\Ώ7Gp}K%nj"|Bey'D	Uʁ{E!C1*z;!+k_wK֌PH.,.UD&Za"..`1G:v|z/m:#RxnGAbټUB\ 8wD7Z95R6!
^vz%}zyi)WZ[ey*rܘzwө8{R{Ldf#C/D(|Tr5rAizTn5e;(?o/8pg_Itۮa=pmWwN.6C&Ny"=.]hfqfaFx
m1 HOh>?Gh'QϠ#vlBt/~js(wzR5CT#-rܕ$K&ƪpM](k޲UO~WkzV/ߣi)s:8;`i88[:*+>
HcZ%ι\؋/Y7W%<ѰP0OfviPS<߄f\-Bӣq
ع>Uj_n싊k$fXAyQ9T50"l{[";—Msh%K56=4iLPYgm
e
}X.`V/)Ч(Z!bFvnd$b@t=o '[iV8Np8]
p;/&Aƃ_u0p{sKW#,̈́;FЮ2#Ni[b
'3(H_uL8m<_z\
w|Zh5]E@d@^AvD
Y/OVf^Ri=բ=~Gh=Fb	Kp咡(h3Nsv%5~ɃNlUN{Dа7Eۘ1I`*A9mދvFD7RqÕ$ȁb3b֑{܇! ͐2ls
0C*&iHY;})w/猫 < ýJNuhDV=ɼfrAIͳu@el.Uiv$Zop$+tsBmhM7uA6E@K\_9
'N`,1J5)]_
>S]ĆIlk/-wXn?`$CR(?I\τ{!@sY Of<.`Tё.T9 4+fdSM¥u/o;6d)>XQ,?[M7‹0t:՘4ij1cwߞI@	
w=MO@t!SsF
gڛ:?豼=?Ra~u-nu}P-/lA'g{9ƅu6==n/(8'gD$otH鶊IJUl	3Yo+߃	=ҔA_\
fU[\oδ#6F@+J\Q$O+*hXP)t.L7EWh[vÄ	zTzt	~		It
U|wvTOCJ5>F?]̺iD0L\{яKE92pu.MN2pZÍe6"8	@Dʤo6]`%M]A
؄t΢"I2N4fٯAR<$vmB/{3өBКyBm1GqMkfsB׫kP;	u'BY;@Qo%h7\3O]_R]3ˊaefF(o
ΆѹUFF[`ͼ>tZ0iQ̕EwJAƺTC:]@AZࡔf]AsB)[mTً?FM/U=_U^
bޯf!i52[^I0XTOS =EZ3oA7
.$R+3i x3K3Nlѭ	Y5[?.~kmŹ
v2:1KGbR`~J+
1H#RD5;jqPYj>~>T-/K>fm1_Gsp+'px`JToW|5I<3iTڊE[( Re6jl"\XS=cPK
xXջպٮ=p)yktieIRsG]J7Lҋzk]UB[!8D!ң]L/>+VL!ҿvcPY%cROT/D$hS~Uà֥*?^gH8vJgV}#Ly&|RYNY;*%P@exjX!W_-@~qlwV6zp	o%c1ȵ4/%/?sO,#}
EnhĒJ{+·o5]
/&¨lq(
eS,]jg/'W~IA	J@q4Kۭ夈EiJ^MՓ]gUr-SYxw/!
5cԶ_][[CrpxHCڀlyz0mЗCpmvO1jf~,
R$uX	='fGaxJSbS ak6ue۴5+(Dsae	H93x<+X3KK!+KLUXm	f$W=X7L6
=ΟO(~[z|]XF aw7;:[Po8cUjscJ̢r"QzYvޙ;FGƭYUf*MuGogJ&*P3.G6(<'\ϐ
3[6+X9.0!O#tVIB_+FӷYJ$}$TUHWkXTD%9jP{m]`ñǤr3M0TZqE`upùFoXrȟ53z-~i+(h8f۝LҰRMFY-k<ZlaϋT|n} B~+XktWOma|vsiƻ_9A{M0H^sW߽5 &\{n>UN5MrTXTzGd@J>;\oÒVAj<8ܱ}AGd SQWVrɅviTL]Z#S|?\V`/flƮZ8\fc; |\_]F\Uj6RDq.~/1xw I$:K@s_2ԏ.79@BGElpaVRt,Sά˜25=t6Ϻ)W|{9ie5`޹kӤsCmۉyK@YWfk!֔J7Z|Wn&T-z*py,E,߾ѣ-΄a1+M6@LCb,ĐSL/섓ל\)7$S{CEP,ӖoMi	d~D,3ǻ?ƛ57
4pJnK^3	?*YK,K*h䫕 AK$^WH|
[ko鬘9M?xB?tGCwVcֺ#]gxHZ&bG6K4Q)Om~q-דHF)HAfng)*RUDpY💟8V;j2t8?¦r`?958{(ef;Pʻ'?¡]5aBK ;tr'E+yViJ7/bHC
{ Y)hY<. KB#R	R#D	
,4N0"z |}Ci㗁;HN?4멪D#:V$iAȚ}z`V|\T$Ptƶq+/7paτD7W˫Я-
L	Xڭ'RPx`-|p\|0{DI643,1V6L2(7*l"-A\|geY'__l5y t3{e8Zk_,FdKz2mϪt)%Eq](UOڔvGDɶ+A
0Y;HQ"נHhs<^~W{}-!qUvLb:Vrܶ:u#R"i>Q|B{HCRgs!ZQaZ@#qeq
:?UdڇWyF8o p*,_oQZ<s$SNBbVZt,1P~E{I6$.rnżc%cBxACp>ۗ8d!"C9(UGM3j~;d	'}Ҏ(&I-Ic1ED/޽xýWK:Ih6^|2Ⱥ!msd?nx뚶cE%
ك?;sZBCQ6ƍ[ʇ@3%.[Så[>;qŚ;){<Nfg32oPi>Yq=4DٔFrg(/RikGyOX]Q[3Veeo+1
 D4	!4zӰ>iڈW`FI^!)pD`˪nS(z<9 JME,n@:m@wU'/Kwg5_$9m-D
.)"ISeS!Z,Uj8?k*;\fqlJO67(ي0qVPsZgl~/Pa}A^=3н.&}RZ "@V:0w3@s{㞮V*#QL5tTT#JV!8](5?廗hP'op5Gulzj;J֟N͝K4TT%Ʉ-}((`\cAoHKyxRBkY{ӹרL]'zTQߖ@_<\,{},Ynm_.@T,*Kӎ-麻߶s7r 3:P31,K~ku@ڿKNiHkV?ʯoݻ)`IrmAޯS'8%T&
Jy`-Z8^WkL#X{8!-;tF-+~չ–ͳm)Q[dw Բ.\$Wjm;3xtxL/I@k7V*C9SyR5ncWd1}fm
rn(uL|sXi!%S oq˰`Y b
o?KšjI[C"60W0BWpԁ=XS(tmo|;hڄjʮܡW7ȼ￦Z!h+Ux>gۂl/F
v7T҅C|*Z;..He,Wf)nuѸ#lf(
*=^3ߘA|fDtwxwF=;s@5%eiġTr.DryA}dl
V*(Yj%Ai%—+xoTlکjUvE&Tyw`FFORM DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒY~s|%xHv1NP|#)(Sk0)iȇ^Kj"RLS1]+u/GNC^["'1~%ߨJOw{b2>OOG1!jGxXڌc	~S/NcL^g%^!|H9Ft4sj
_,KZYN1r0|N~#'e(MDͯ9uCq9Pzv΢p|9͖6H)hC=L<`?NMM.o8P	6QӪZz(m^)v	My/΄=Hޜ7354ȏ(#dXϣړrgQmsM:tzt=
\.>l3w
FmZHq{rz)
ȗG-[ĴSthocRxSԳ*kbNbe֜%0ƅCV!AhQ`ڒc8JTGd[[ޟLբ_ܶ.u]#O@,a\	6"ldg噻+*4w
>;t}آqI+ o=zNvwMS
й"pvj/9[_i-j$Jf{ɬxG/y/vאIK`U>*u
E~bL3nd<`챓5@ֹ+!O3+C,j{:bi )
1dB	'	0	Jo;0Ka+È=3튞:Sݻ)lV1G$G*}he1f̑)>6bYFa31kQ$"w-
_+ߔў,~T6&k)L}oLy8W~Rtx·5~}4nUx(E06mIŘ:tމ4-d{г.0_MM7C>|c$Ji+Òvcx[O|dddz!ȥ@8we¹J(V`["AFlvU^N.ehbCYivsH#`{b]Qfzcv󨠊cmLXX~:Fv2$J@CUCuõWcgЁsnx(W`ٰTN;9wAVIC@j:11oOul4nUUٗ
J02ya5ÆZsvKu*U<)
TZ
pyzLp 5~@B#~Dx\
:'5V"KvO=F5oTVkT8!,Mr'JniRvP~z8^scS'54MԾHF-M!fCiR!QuvizL܈U֮aAh*͟0&BoLhU޼XV6xl#
'Cy-YPy
SOMyR3dsixlY)S!WF^)VVc51yLғ>Gi̫Z,RQ#Pȭboy~vyOD
WX0Q־J\O`TWTMy9oN8bPX
bviOD\
)}zzY%MY5v']"bM3+ds Nkfx-"{BIÒiUQt'Mzcgl>fȲQ??л̭M/&ê׽A)II;:#*{WqMXtszGSa<>ibxݯ#}_Q>/mK}ְkm9	+'@f3G<,
ˊd. %'E1\|RjI:alx2
OB:<~y'NѽD-ule۰=`c#'%W,_%Xam(S08;ZɔZM7ڡ(43r1ntNAWpҠxVfiylE>I͢VK9HLEcJ$2?hv,Ϥ%ˬڌrmBGd GK"`2sqy(b>7#Ɠ20AA9>*>uSӐi9T˄[_%]9ؿ)C*Ē@;[\puahsRh*bv&}E
L1cj vvDK[;jS4q(A~4Y)Mͺvx](
r`f;QC<4
~UF#uo'>v>565]rB0Ipj{kڣ(@xHOڃBOD|):ZX_J̋I9PWik+ĉuD4IowvaDH
EvHNOz?'B)=V*w~v}8!X)D5z%?,+e*BfJc,kȠz9@K7r'.QdNLaZίIdN˞cn4e?cy4̞`[5xi!3gI4oK)0[:%.KY-j.q"}A8+$yW\c&?P76M}T&wcPFzwj_:5ĺѭRRGۡޟvDuM$# 1Hc5`\ +Lً42b/'Hq'y(Kv&t]ernaW?'vdaE8Wh&6%)ݹBph9,?j)y8P.z.18?˦^_bsw	_]bst)9%(I2Tq)h{I
s(Ҙg+!=>oğRf'&۹"KGH#Б._5LeBYL~dZk
tIlGet[+ٙ=0[-EA\mҮ{a,E'8`XU2qS ePoz#tw%[Zw"7fv^eF>LM()[M%;-Nij\۳TfmIlw{uX}/e>LkІ!^EV"@e+ЌIFa',ׅfCZ1A+rH9Y>pkנp,_-_4H:b]YtC$?G}QgDYGZ@A:f.h
N\[{ZZӝ8Mamɬw)	+ܥp%8{̂n"{3OuG=Wz/|lbhGw7l[ppQFv+j:ѩ-A,u֖,=_m>[
Rv24l~=
I,"0EqAl(Q$Cޕc1[:~/s
vPdej~&"~on	+O@@!8[gJtev=!60~:oҊ2#w`T>y5v¹צlxc؜o.y/QZeѸ|{
Ĵ|phLN&k:bÆ5&	Ly)))E-*0_Lf?M7#w*vhKMފ(DF$ܰ}{[ֿ}.!$>|GCmr3Qoþ\ßZ*V贗&~ܶ'bm«NW峢$FS dfwrcDYnYxIW0g=.I5MGo98P ]I9fAzy9,,+ZW4>MfT܀]8AHǧrFg¢I谒{萹`'gL)=0D#ٲM!h),hxtI{eI[$Ɓ$70LM7.xI-{pV?zD[-ĵvd_Rhs{PAOD!W&Gs_Qνc@(L;Ry$@O)4g[ Fh{S7zlS󻳛PZ/Ҷwx~[4Klph
sVuPs\F:[Jt%b9@+~ZztRjg3{
5(99=NnJM嚐9)9:X4֋[hޯYY5aXŚxoqa8pdn6Ҳi1eSȡ~@òaυnjE(dN
j+DYH3!ёBn{^OO
Z
cʱ=@K%̮^
*>YVc?WJ$*S:LmEӃtp{"ja<0(;1o#[όfSFƻ

c:ؽż>ᡬ5W1Oz
dR١/@&K5ɐh, dOV%PFQc44$LH]Y6M*X{32=2	T{*[~A>tZfI4%	_i)ϙbX
vݸ,6~K1}vܕR/^`4[fċ&VdK9\g%dsILeҎ
N;-#N˹-#D
vʿo
YcȥTIwEY>"	|*;PXW&ˌz#cjVY[#&[jmȻ,M.X|kiqH?x!;m9%H Nbe
ک;j%!a*N7!tDeSMX"JK/92+nL(n0Xd2 Ĉ`7pݗ{Ck|(ȫqW!a%q^獞AScL"7ў'CϢR`ղG5u+\o?JK\e.Os'V[4m
tgRk~[di0|b)KM2O<(g0YF=GƨErڼi"Of{	c&֗~{4͝
~'@iײˤ>F@L$OBBBĻo,,oH:+fց!4xEvr!ܩϿ҇Ι(SFi/vԙlAϼSPZB7U >y_.:0˫&O(c*.E]b$O՚^af
>,B
a,b6rc3AN+͖o,%:4D2O$R(_N~[=uB4wOQ+j	`҅NIY?Y$j[eTRF'KZ~WPr}3Cm(|V.XP}bbx˭.Mh
YF98uGTEҼ/Up(F[ۙR`wvbJ>~vB+zB*sW@3\ژW<4r΂En:Xvnv#Rfq\ąQnmI7C+F?TvG djߚoi~7c|wPHj"tFORM DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒYMV7Od5C'#B*M>̏Wm%Wx|r{_7wgr$T]Ȍ=GU"ulc߸-uX
!py"	(EOg&
!+D0}.p URQM
-1ҙIQáS>hU-sTty%c&f`&?z"ِm	s뿦c)
_ zkP-LE,CW6bﻞ7fJFb9(
&L]Y%^gq%:OwPM:%0KUnϗ$M":H"b=5G*~Wц1SޓOBל~x9)wR*^ClQnZ粙#B7i}P+	]){"
Zֱ"K`DOKhL\eZJ
mٞ<"R7ی^TB08cC5f0~.[C,8k(*}|n-m3kG0#
Q HZRlKլwoMj
FnDORv}Tsz7i{aSؕn6갔|>4+ES0ὃ?q%آjm#3&>@:J醧:8.eZO(p^{bz0Z1-P]+*y۞UK{K՝raQ};ډ|?z+JPӖmE':FTo?/")a
k<
*cnȕPE>l"$boVs?"`Ac4bvl@\YGd&5?׵@BAb@w'+{iIn@C@yv&"ťBj|.1$/Gh+*ށ'hbA~h{ܵ[e\m%%m"{*D(oϽ[盒orJC-Kwil'6ʦSiiQ
,=Δ
dP*ߪR*foѥ(^*>ˋZ=EONAH=@Y
̕vQ`2p!l@@,Y٣RLׂ`il	oT[%慵Il=XԼY|k#r;F&#	1Goz߿U&#[LPP1G*OD^_?VaFU7!"Am;Θ^gv?LveUYaS5ٷXͫ"UjaZnDE;J`~$42XaXE6k뤃Zqi͌0~roE?o,
f`Nbc͢kR,OVmMw.6oTR!R_zge>6c\!?څ]f(A~8I/BHH8gV7)Ѯΰm0ulhXEnG(,gsыf/$dUx'΅`E,TΩFCQj戱ZյaNi9(烒(GA	a#.H߶UFhCS,6,Lf^W됮
=v,5UGkujiIf^|)tF*rMOԛ}\S\zrO-`KNJ6p*%%usҸ
Egc5[*g%[A/_&&VÏai6X6t#Oی+9?FY4sW;CvMx0~u=)`IaiBCSKRFwUC66¨@6LZ(Y=gYuġoe}8:)NDt6[*l-Pb{:BSk|Re3VCKBc#XF8)heQ0cb*5G'YZ{D26c
m™!Y_biLw	ը	^OtH\3'>c#<	d05Jqm:M8\ٟLP^!
bNCED@-:^@櫮QՖ)P)J$\h}z{EPf{֞TUUp`W5p|4̠hIz{A9gJ}`ry#ԻV5Rw^7-#K_^Vгx"JN9NBaūA~QvE9eeF,PI""AH}n[P`O(ax
wfȂgrŖ瑪$	hfb7mgk|gJ5)6-8ܜM4_q3G3{gx\3l~筼 e2Lnx

1'#*cJR2Fkk.;b5Ǻ${{nɼb;=0oNaOf_2>&QX4c㗮8~qnv]񕛍}NXY߇nӚ}X	3AX\=v40X?w޹O7{99֩lTz<Lagd; vT":D'Ns)YubvfI$wf^%  %獤bf1kpEI(p(;${y^u={ɹB\>+A/)P?SQ]͏
J4nb٫D.@F~W`$C`X^w
z^hJe;s!1C(L(wj(%_S!5ڜaM3r7¿x^J^!wꢉ	9#	!(a#b-2h{^ua`A-5'\'m
Z0
B6tϪ5ړ
NÈ7jQijκi^|A}:Ӌ*εL"sPTv%fe狙W9mzC3oc<Ó.{{x`
;nGiJFbMbϬNmZy]:ՙwvJD='SobeMmͻ׼lh^0	4G&{P;΀_"ݱ[7UJEŐ	*VFv5P2FeXN%ў_qVsem"c̪Wi<4f߹+GKs5E!bfUPqMjʼgo>YOYQHa|^eOڧW
ڷ#ط_&T@9mzWnlBk
k^qD*,T5(8e")_w26EeLF~pHC'伺pENb@H__Q̒U\̞/̜3[t}z/t|p#G9LI˷lX,7Md8:=."!~0}_H/V|cr	t#
M
ǰ(cM',r{Pxh
;S~6yW@jd=rhB
7Yᜪ@lоaV?C]^D,0
EOUݬ.P5NՎޭVÒ1+@iA2a:U+:jHzT4׾ù(2NazO
Zs}+r{HcPNVĂT)f(
v!RZˎfθX)Q/_:tFj%fJ[R#ruD]TIT kqWtlHO$"Ph7:YW1^3M
3׳1]#eDY{@<9ym󐦫+f`"" 5`O{J@
luxfH`.I^_ޚ3SB,9gXwmJnx 3zbܐ0Z?7bs][\C|O-`0m};lq7V!
\P𹌗q۸]j0fWG8'{T&/!F.eĮMa"fQa]F$/U[y7bSX!K}q"~B(7'/P+hChƙ;h3LR^Ok G~bc콀paBK$&uw&B9́t'>zemH ME5t~B9V
Y	~5g)2K֐TT{%j1?I|O+a^!O84AgA0kW L[	2ElW%4]T')<Is4G䞟-{,ZZeL?^~4^XD݇Z=!PQ1`z$90$P	#bD>was0A]g&՞_Y9N;;h
WG8ZV{ӫi+f1ޮ-iӘ0ވnu!:/kkF5qQl~|ݟޥ]*kxlhV$vAxZWp#ki*њt,1}C]0#&?0_U+xW{>֕OմS&{hCtU,:\͗L%f jӳa+!J< 2?UTtF2dNThy:sV2+ rp@?٢5جQ|3Ski
$iVŗqpܔ`V8xca#|aw%:IĭČ]y뱏TXTzKH+h
	!o=`zڒ__]yݔo}ؓ˹|JBҬ7obawnxBԕ挔 *o]ClDh;uy*&'U=3VS>Ӡ]rq[!KFk.>,l1%7`ߎw8lbMfk
]@WTx)b
$Xp8ϵvflSHad6;v(8\u3=+>}HyBW%X񿱖f4(&|7Ş4$|SI7
xDRk$yj1JX7>c<3Ş:\7'~Jn^3څt~b1Q-^[(?kg_{rxpJ0(HU7wx%3ņ(j[LˬbߡcLzkRo$Q0
vyB#)[0v2m1LRN21~[ۍ!M
?QB՞n)x3ZTc|g	DxB,+rK5P4H34lARނZNd示'%Rj3TgV5sogT̔<+Y?ڥCLU-}q\lgn3*8Hq.{>*
kw6㜠F-/E^wʅrS!&+ 5=3ʡi-[DU@$
7	q*^ս4PrrTpg([<+5]`qM?yKq`od%4f-Fk[`^c-2##	A+/ܦJ@1Q#мvn"m/ʙ%j54Okl:uk;L4֯bI*mbO.3H7$q2;>lzTE:>1< |"6Eud㭗$9~IyǸ߻xZ\S/館^^D\}K&|f#-Os[2{B1E6y~VjkyF3,m(taI؀|M8b֧l^>
 >3"lmh)
ic@z;Iu)t!
:E:]S!G`c	%bZ\nJNmeUF]'*GS6'hQb5Na`Y%0y<&Kyxjt%]WSpO,_T`X\SJPژ2[fRF[ݒYȅG"VU6КIj>Dtv(؁hp&ШȶLgxOUķlsg> };ӔvùEՒFAa?Y49vᵳ8;#0tה,i,%bSR̎2ci.RuCPK4#	wYT
GTZ7@znkЛFT$7Kb1ۅr|;gh_qxjPNe!]dӴU+G̤(_p*AVʮ6ak3%w=Įh+G7o>n0MS|e|w)O`-$D:—mTW*_(ַ2UiA.YBȿߍ|B8 ߩ
dt{p]E"0<d	T`Ce{}ǣIGjpqbǯm0CM?:HxOJ80(*od@W%BN N@Z8DUB^:lAsg)z%)NuH;5knl@[2/WU*iS!Mqi	+K,k̣]+]y=z-:6]+@b=
J+Rypqngb	_>>>T@p=nQQ{}!+-wWB<*
V;jz[8V tk8FzWoVgYbQpk7yó?ߛ= {&Bp^#
YLV&c~O9KV
+Z§ѤV{fX2X(,(O
U!)?1'#\ո`?–lԅɹ%
ȸخht@帍Of^oxV&Fnxʀ"aEmw=pub4N*G8TJd<
n҈`QGV*E?%s!qpk1<gtsw+1;u5;N_x\_y%A똼e^BPP2x
G	pvf?,2tM]/%p#̠&=}zLP/O[8i̻Pf9pOtI"e{%Lw!|c<%y(Bs̒y4o/G:MJGQI$3>3AnK@I0'Cq @G'ukTfAy@ko|>6G?STճ`߁;aˉ]k9E$`it|3jkµB@p8DBd|ϲ\?~!I;M(X`9Nv0iR/0:"kɍv(8:@g B%Z
o{5jήԑ1AYGם
LPWZ90냴U(tzr
C)3-(#4,N5eqiP[B+cNCWF	Ff	E㭛k#Tē50xwdEPwt"+LQ^-s"Q;bNڼm,L84m/K	PL#p:wu@:Ƅ;<@N2VX_PpݵҘK$YN?/>DvF ,ĤZu_ؘQLW*WP y0bU^Cbˀ7d	X/P%"~5q1aYxiAj>VN~H=v0uSiPH_Z;~(v	NlVo_PREyWQ-m{W W(	eH²G7Emm]uFXb#vkuUv_d哖Qg0ʼ2";QCJ&55Jn4n)J/2ѵW4V*&^<]
f/t%a9p}vCjUyTUiuG/[Cﻎi	 &*9xG
"yoفs%eِdk/$(a/3(,v
Ucqo'u~Áu+3G4),NPMk![*[th#r)Ftt&Utx+e*Al#l1|s'L>PE}7XJZ	FfӠ}BĎ2CQ`c>1.yIR*$c
"='b&ի@ע{
9RZ2MK=Xy4#xF
Ylgorūw|zU
uCjbN4gknHRh}
x #)YxM6ˇ}q2_W{td1L^I5ẹ9E~),+Vr^%;c	W{Cs2Q\zWW<6𩓫َuL玮k?NeD#x+g%klިj
o(CDÛҤoG%v/^EqNr)옑*O4䷠6uy0?t,)V[JTXTz!d@J=L5hjAB81{,KJ396Xt=y%=;h]B2d7F$

YP~ԔCX޵}TjFoVm}Cl+;]	7:x9P!OR;Rt.@4qv@ruIG=!F9)d᏷*@/d*4յ/мGPJSz{pɃԐ'>6ES	̀>J	Gz+vJDoٞRE,jfdrkCRX0ʃciX/6TY--7W8f&z6PRP
TT@Acro`eu4wufM2Q	x]CdaE}B+54s74(od@e*40b."`0b*s%j3ELfM/ٗWTy%AC돕7_ugpl>r|b[;եMkc2#޹=6Ig\K,dltߛsޔ{ם9
;
N8j8+#r߷Dۣˊ,"7U1@/2wJƷ9%^I
DFORM%DJVUINFO
XINCLmemo-int0032.djbzSjbzrE`ɒYMV7~F>N&$e/A%%B_UUj߼';
@>d٘c^ՆGml>[9DꁓjOce="3t/6c&ش`{ը-&j8r%gF]:Ol#	p
W+`X}JEq9{e⤸r+CՕSDST=_^=	͝y_0VApl}w8,>ZLp:dE:e{tEBerwirֲqU1}O러pBLXzεHVs^ՠ[G2oPv}`pR12Keqұ~/1;a~ xF꾕Z_|O]qN-rtM,=e'I62i,9,7];8
{I(VHgs}Xި"k%9S,]I55Y
>1|9	s2+Pd/͢-|ԟ*V#νl
݊=$57?%U
WʨʮRlAS\h^q 2\7[$3udpWIySD7&FnA!ϋN.6XiWM^4EΧ5#:->VB?ݯ82@[7->yu3TYʟΕvF?woh-Aury QzwGl"1n]FBӆ:+,;b0;3(qPi2Y[|E/_Ӆ	=2r>Wl#
(XO#4çI_+G>"$ LͮZ8Q#C\T@pl8E&U^W&-ΌcFogC6ߔv<~hh1!
iGO9^MFi|"UL+8iP{='r6ZǨڨc1ޟ-ɚ0.|O:"$9Zרj Py?o0/k,V.@iA+wi7>bY\~J;:)7=j6`6|pzP	O\"Cʲ
WYy$fIWIX(]Bm
,rP^Y혠aȂX'x96(!?(bؐjSl=#f
(S;D]:.MpY|lE\n'Z.Crcp^4A41뤘W]oDt|=fυ:E:D!q5t{t[63$G[:9~?LON,NBVA-$:(1FdbǤѪt@Pפ3kMa=6b,b3BK|hDwF[*:)pX㍞* [v{ꐈ1LF~$[V͉PXҢ:KtG>Mk؀V瀠
1\!
"}ck`0h2KX,	 ?j e}k^e6m@nVp!6;8wP6uHSsm"&$;T}-5_1
4رQ
b0H1ܝZ(߻Vd?ecTO)^@fTtv9ΐ/rqD^<ȯVki&gI=[8?pu/Tv9Mn{?}GN@y
kF~C#|2D-Dꥥ#7tjV1fT+\bB8d3/+1{FfҘR]mU*JXzhJ0L+r!%?x\f\DRBst
HIY9<k;~lDc:%1bzD6i5,5$ni/!\B㬃妕PJ6.L ɜppȿHZWLR['+B
7Hҟ7`R݂6;Qo3y"N^̑(Qzn2T~?"
`2g|;m£y%}:Cڿ|1ٚ+\ی4绽1VW=ݑbS!;wOtnGÐiܝ"`׏*짭HV(@9E1ڊp~Iv%X(>`XwfW!.`a1bGwc_d}t|IPmKG}8GȜ(Wf
3VikA	t\ޕu\Lp}C96vO,`}w.SAȊ\z|ڠ+>`UOWűuWA \vFPiU߿7Z9jވGԗoA16j_EZ7Y[50KF!Wws
C*!&,H䷭O%Za
|n/f!H}H27(EBn慕%3t`^RM9c4PQ}Mx} L*d#mj\;WpBf2W6`cr]I7ԁT#$O` Wl"'Z6jtUGDup()!AT8E*;+ɃVs!	%4677+> %l]ca.)&91v!rC#Y[U,;=Ë!(¾8t~p/-ќ򛟩UJN2
]@$=o=
mUU`5Uo556(6Vnf|mSec7FUu\Ymy a}MUg_͍^Ԅ'Z@I2Q9}d_;_~VgcykZ:e]rRQNq`:Ґ5θo1?Sg{@MWp-!<}OԂop`
@N-`vTreq|4tٺUӻ
/,ovS/e(:+h2a7ߛ\ϝ*$Rف9ڻNg5Yop
w+7!+Is]Eu*.i#}!?ӡ
rx*\3Avl%@.)Z껇fJ9Ys+(Q0xկZrkJ(FERAHlQSiw \* ƍOŁZ&+3JviKKsٿ.^xbzGrVH+a<:kلLGsVzvRDWF5OER%5*{)?~vOTz~R>@P0?!mH;\(WvT9zά_&('XNsCwx#w9Sj(]$[8߹mPg}UK[!v,
Af:J!Vs8[u}(+t:sw*JBЋ,
B=7titFJoDA/珈V:|=LټӧC@Z'd[JiZJݝ%h}M
-},kT%d\1;vgAM…M}C|XVoƧEFLH뽭̼nI覃cRAPA|ʞZkJFBҮ=}j%$iE ]*}˘Z	_Jb$WRc*tBa`άYm{ULPǂeeI-턙'GՑĺj%jTYl5W'e6A QZ-E'-S04@;cTH{kSڤ\"{㎚HDu;5anC}r+;^ [ZqoIXN]x<88F0SY8/V[ݣ?]	+|yk+/jOg`F,gU[aqA7ԣ5"y|ԔW+-[j;S f~b&g(soVMMW@~IWks1j.a0]Hsn@(:#p)Ƙ_㫬:ӈP	_epk0Da5*?ZvZ\SD퇓^!XvJtTT9\HC4@;J΄	m~b*]Sbo_ї]HmK">-d"4G3+KB1q*:%	7ZǮ$BF1Ra(,6i#+ G@G.soC7:c7Af<6=~iD8юB1mIkW8{S(+KYcM9
VVo_i5*gwo=2^3r-Yv,b)B%=αm\f/Kt϶M1	
8ϔyf?f1$%M2nXaIb>n8*i	cׄUSVyAMhX!VxϗDӸo5R,QIae)%LcR-Ghq,AI2	d'ti<"Ũ&FgۄA%v3bY~*82{!$fNS@Ql<6_m\M"k  7U,Z&LCe,ǯz3ч"$ls?j
?C8yd7sܗd&ACZ=/I.3xk)cPQM70v\Nrz2v*S&V/!>2o6>TA=}GC\3<,)|ɶXb~D97R>[G[ٺ(kP/
#YrC_7Lb
zm}T{Ts|G!d*6>ǜn	o"r3nY783w[^v;B%#	k'.Yߊ]q$|LYCIͦ
i@sPˬf>%>$,auֺ]W+WiD%6[tQ)%3ܲr~ӭ;FUÏ4&dMi"8@O$m؟m/n/*Xo?OܸLs͞G$s-Xn>ot@N|2qʒn=CiIIOM6TXTzЛ.J?l.u'm='R"aeX<;ʇڪ+iGJiiwf2G?i84|lmnf*j4 yMit,)|{ˮWr	3&5cwbp.2S#T^Eh^##4*2K@u۠"o-ĝ+l@Hy+S|e4zW+uiiGSm(A{(`
aaV|4ltτT1IpdQd'b(9[˴_g"=崏V-3.7>&Pʉ[Q	
j\g^W2cg.Q5銣>Sa{x:wVd"3ջU+x@gCx/Ex?q4v%d1&}/udLA{Dhn;nB
GQ9YD{o<	>WZ}2OvPu?86I(pRC1y$}'N^;w1T'u
bpzOrv/8B'D
8߱xOf9-^7Ta6.f(WnB
{	_+%YmW@f
3eeTX$$>Wc	/C?!4{pX}H2F㡾PLycƏw	W]9`3%:ka=NCpp!~0Ѡ©BF#NEuf:.v
_/
cha\
sӲa.I7Y~=W_#Զud޲ўp%>ǃfĪ
";тlp6ŧ@	AbK 37e3Di:	d
Zo*R->
y?z:yWEI;ˍ9
lڜLϧj'lؘܠ~a?D.2ŴlRG!	k冭{*ǀK y@TkFp	;/;x]{kc;蒰hHNr,m4Pw]`l3{ܖ5cS>#cӐMm*\ݭs4:ڄ
Ո6@IrG|TL᧏
Eqns.ˑӷa5O7.@0ଯ.NpL<{k}K%Eڳ#?}rXQ(В:+g8!k-Z0d"k!Y.vâ$$CE.?4%nVZE=q|7+5$4Z@\@ 
C2mUTۋm

ϾM)P8An'o-+"߁eLjiL₺SEr/Y@q
ΣpqV@3%2iA;\=*zNj	`|F3+a;CJvl:܏X
ᚚ׫_I(Id|gXM[IaM]9]zp>_2m7?"TF'2l<:נiΫ;?n>w
*y9;ֽбdGW_]3ǥܐ"eXU'Nj,Tf1{~P6GƃNu!T\/qu՞ekv`m`t{:I(r~ÿ$Ju_"oWn
^/8
2A2r{^	'	Esq
e! _'X,_gDby
>+	XwDr+QZJcr?roOUbIz}eTAҲB!*ykS!RGd"񮧾 E"2ZntB3	9шJ$5YKU9K» YƘ}TCR#Ƣb pă쌳qSk\ߝ~ߚ"ϐWr1Ew>dJoj߷>]ƒ?&E`gl?ؖM|GFu;I>`1qycNk͉pn{nZo7azoURp\Z}mE9*?YLıL^xjOkاLsW`6ۄFKE`)RSV}%쿵$Sɨa)dhG[P#xW`PaرX㭷g2Vi=_\
dʉ$iXVQvFy8Fa{+-ٕs2;}n<,8j]r6|l6W۲?c\ܔQO*tdP޲i@-#Lb|1uHvğgHR~i30¼Gf|䳣6{ԕT欺ɹGU;MM.z-9Ck;/L\^`'k
PW
̱7ŐH@d$.gV&gBQy*WF"6]@hٲ
NRX]s*nBS;sTagRVBO$nr)rr$ۺ(uF@ g*
ƴFORM$]DJVUINFO
XINCLmemo-int0032.djbzSjbzE`ɒFԄ@TNddeL;}Y*vz̀CTm	[7gPs^>|\VV3hZ,EunS
̷Vɦ47"bzŒW
ݙg6$T(TK
'w,ޠCو5bi)v"y’2k҆l\ldۡF>n!k캉voZx<Ȏ=a߽O&eMCG
x,-sէM9b""12$? [-͆ޕw6T=
72N25Ro|!JȺoxaoDSiՈ%|4^S''ǝvln/<W~䮎E#گ=W8
ⅻj6bQKRZ@6o0{y˖)|7'6[2l(	FT_ǽF|gFǥYm"Sa"(2֡q9$4*1 `Xŵ$}uSRr$şޣ8Jg$y(-M-֧l5RAg	KM7dHwi^g6.@Ki/<uztjvհ-E-uL;i=e,sThB@IHuwfkEq?	"r܃$Ȝ8Tڔ.I	]=|]/,6Q/ͳ}@grBRO?N۲28.È$E򉷬Te03;ԌaLZ LQfJ䤹%kKc{=phUbkArxu;'Ⱥi{9Q}p+*Ϡj@qNs5ÀOغi,F<d廉zZ/kqHiӏJ1{Q"2}۴&)'`bWWˤAۡOɘWxA^PAk)HgRx hmy}A[?)_y<B8#?wo"'ޟb5tlwõ4Ό$-$-,³hmb3f"o(Q/FoMU9J3GɐTFcSR{]G8B 
j(Fy~m
	́`n&>B7 V.Fģ
,ƚ7Zyqy?Wmٵ%mk&VZ(6$	;sFCJ/	W
/Gx"0/f"׿ں*'cdY~لwM$8RG0iHA&|Ȍq;838>jlǧ{*wQVkM#FcIVL*^ X"_77VU3d֪K(ݙFAg.I}:\n=@*B״@H9ʐo	-YR.T֯`7@+cUw'1>·KM]ZeTZV03%!XO^:wR~X|j!bAfZIXRHVt
%+JF*1W툴ڔcO&YCXGqB`(&Z;T&{'#IG]߄aD8<tosO	ʼngeM2SPD8hBW\ܟl3sZ.,JA3XO4re-3qXJTe5Gq99 Sbu뺈3MދZߑ!7^^ߒ*}onWLTOH'&2a}WA];رׯ)9PK1AcjQ	1DD.SRLD|If(&7vx0@I)--۠yħdau2.6󯅕{BCM[K
؄p:"SףKa}\x.Wi4p!i`zc-{(rTjhLG8*C%@Ahh\#'[G@qwhjỹۆV{%Wp%<ǜ>Ӈ8h̟S25R=Qș0On
STG[L
0v/eY38zA·*˜R.쫖8Y	6UnO+l (cnqkև|1
;)YvG,W6Jf`^Fe9?eV$n0P.Mx'k;zWΗ*5@Vq5L3n/~Ş!CBc
.
vKA7kx
s,>>^qלvIXYwy+N\#Haq
WC``	˕jxVѺ
ښ[٥d㢌L0Qwks
;Wz4k
'qVlox(?\DHbqe졋wlmv")I"a-*̏BhOIyFh@+IOckpJvz}҄)BY'H"!;r+{-UEj-`C?ػO(M>vZƕ7mǬ!ƟɲX%L n"#x.1"}|vOx^SN7>5k357ł5Jy]A6Y,-ĸ[~=Ů`*E.7;=z-^I+y
x$V7VmGƭě
bп7p ۀ.OuãhC8ܔ)-}M1ΝC
!%2o`ȜUUL
 `+o9e+ŗN8Y'NBS	6%50<;$on6z`ZQkQ q]zsXJATfb
؋vQPӢڨ@Nd|@׌#uݣs]۱$y%k 	F2+&$b4@#-Cs7Eol1X"dw$Y7츧M:Ԣ(zY(j,wTVqXT,j
4I9/.5a\@M'
_R%y:c}u;bɭF,ׯ/BFVv?&,վ"tc89b|޳SI0&PpG#wjc@;ۄO
zw|}u,\#]!ABIpK(ёڈ\%:,:~z_*/[q\}GKT ~/IS,vW1)i
yev	Hm\f5Hukƍf.٬cI{M5pJufeWQM>K+OaO0RCp)zE%]\\1ZaE5	"zEd_Y\aJnl.l6
~Xrtk>gehz_1bBGxVh
פQWitx|{dV9t7HF+TrUFuzy#`s3X*zZp`H5vt+?Q3P=qQ;O
)S2A\}gxMwVyxB2TY 6=rtXpp@ MeUʷVTfh J|yFWIEF~$_*BpUz0d7QDr_W®p4,)"Փf9ߖ3#]/KdJov@`]8MGT6փ)hՈu@Hh#t\CtAT`o\ eTNR2H{_?s;/#!_'EAosڬS'Szy|ZJyZ0
¦>dҮF,,+O\=ƥOl\oJ2('Sp:oDHDhN:NشmdGTg#I8e
lgV!YX{F]}dC)+S\BQmBv ?@f%
b皑^].6NZM/˗D)j:/S%7iNq@oPLǣP`Sr6PWZ(쥚{	'O	
`9Fy"ټΕV2U^8wKHɺAy̭Y?Y'S:.DTH
䄐Q֬*mykMh9"E8SՏ
;YptZƶ"hdUK`c`bzQqt&LiU6D#!4lSVߠ)XUEFdA!˥|q=!rVh~h˛>&_d=Q!*d"#*NT^ă	0BU	7,Y.}sB>s[PgnR.73#{x.>i&qܱxb_;a#^{D2S֍dY{LM>./aJ#.o`$j{le˳6ڟ}aVzN9Ct)zPu)&݉SkM+taXaM6c̎h`(c3յRip0KJWJA])j B[60}ZX3(v;Wlj/f%^<RH
;9Mj#T$}Wta[|ƀߏ}YF'ƹxȚ}+651E
Q2=m1{m̴ 36@wP{V{sAߑMU~@СiGJq{u0jȧ4J.7C!j$i1Nn-&[vRQ}V~z&'b\It8NUxG"
a~5+UmG/,*s8t⯜+6Wsr}׿4Ol^)
FcyًѾ/h`"*Jс헾?Ŝ-BcUJ;9M77~-VܠaӢ}
Xdl>;	ٱi,Nv>=5F!}tc;?&o+Scnǽ>"#
[0<[g,i4_@ðBރp2ezl5SK5ݛf]D¤bB--IZw/ZIgtK\*35FfeYhR;)VpڗQlv*mv)إq}44])vl}Н5Ri$m\to,-hSWց}N!r9O
oؖraKmBt ϔ;¬]`!t،|iEC2E*KbȪv~i'TDͣ;X3bt|09eIU"S",|b/uM!<+Cy/K$^IM.Ǹ>|-4a
ǕhZKWp(Iȸ7hL'9ūNB&l7x;/$`koךc\oL=ax8fVao%4CzC%Wю͟=06.pӎ	FE*p8>VlMJ*34>	.
U%k-X68_,VsDXvqlw%I\cfEgH'Ŀ_H>Ȗ`p#

ec4=J{Z1Qz:/K"w
cTi;%2)TGQR@g9qԔeT_gAK):qUyN	#`V|p!Œ/C:.hF1]
SYgzy!MGvf-EL%oT7B0[ԩ5feb$'9b$yއT y%ʕ_{~]?YNcg~-"qm3CNv(ې1!s5|ǟc`ǖ<ݞ'\*'u4%9&E	tYen
=X%uQ#q1
n7[QYjr|e%X A!}fwLv
ҡ2lVbόFMxB<'.AqYU{]_}a`%B1<@x
~b._i`a]3JdN[Ԑ?1P+_C"AOhӪm3sјx,U.	9Z{,Oi}c_:RgvGHD8
ߪоr%բNo
UeDT/8Q؀[s\_mLB-oxv\Qn Q.鵄h hpL!R]y%LW	cvIelʴZs/^-FItAgX`Mx6QNK /}۲u#4'AFB5	|󳭃f"|;t#F|H3FuBC[{;՞3sǝ}^a"7[WN%oXMt΋$|`Ss/_+~F>wvJ2.hTI잙lB_.Sh&/Nxpz  K d4c.'_r[8jP814+Dܛ9x@onjZLXnWG@ЖN$'%0H[
!0Tf;щ.F7e48Rxz#(X-r~WQ	ًNk8N[^iuM.	 nȁ@WKIJ2/9JF2sozG7)ئRGo:#JUV_r?U4`H	IN\F}l_e}VƷ7#ȊDz/߬x^.[v8BOއ'La_JFP	s~:m*٦l
(uĨw\Ѩײ'~̣jx](C,؋5
 ]S~Yl,:xH.ǙD~VrcH[.9=7XPt^rq㒖Y:Q^ {YroK^y;
=lE'
VQ_gIH|UNM]^rRWvIWdVXb6_"!d:R#4zgM8m:|fBWjU4[l:nuZyߺ-/àNdA7+kD8~3S^8"}%1W`4Maa)EUlRg:exh4L}W]2r[0RY]lTCo[MƋq)I@rX’+EE_[02`&ХѶrA_/Cf+[cw8
F|}i]``or"3f4'=FtQ7Q|fp&q>BLډD [TqD
0?)Lg_dY(!&bh,X0=\*K.P5K2Xi,6uxTѸp(¼%Qcce~3X%͖;2䮟[Je+
^_E۸TdqDu 8	FYo掠/H(Yd};mYmK<:g]/)w\!depN'&{6^UGBJBxT̃H?;߼;y?-qe5B2W9H̛~cӖd6FloA=a9.{`酉 =ӪЦJ*Eu]W%Q`#Zaգ0$kA,&z@wI*6Hղ$m0o"'k-4#SPKy#Fqϒ*ѮwX:+K*D]#&3es>,%!Q}`?ZybOW+ɼR,7DP
!)o)4_aFv}/|B7_Z{j`BWx9~\lQ5AZ.KNo_V4P^0(^zx\$=b~~ISFl(`^'5Wpbu;У$giƍDܭ=Xΰ+w6a+=!h/֌q]d.TJUSx)uɠl轼̉SNM;V5WKjri݋>p=9wFO&;!ʏFX(
Rc>hXٹm6	`H5LCs`GAzAuϓwl
?5-h`-7MLP.簸`)S⡡۠,d2BK!J-+B.A2!'</_+
d[W8<Y!*(B+Q{:jFGU!Ϣud[=uZdi0=d֣i`^)猊n%|R!=ೲj>>
x+Ż݌OT]7f`0ţ(nۈanҡ].a.1i6W+Z3!j6#5I,K?δv㨖GU[&|:AKBLu/PYw9snj237&["NZv&0_rcezBxU`V|wOFc8'rFrnYgv%}*n	~e/c$5e&ShTmPe=i?]:^C
{ smfn^>͍1
NW̜q,St8泽X]`Ov6uߠ*RnBY*{/aShR\tqh-3t7+υ=dO_<BO	䇫c-(H[TKEyS(pãTXTzC֠.J?G?8l"gD*d
Onw-瀩fw8LYNl~HTPU1GtZM媾t*#%׌L}v'=n}T0z;lqb፯hnMUGJax!O{0.P'=F'o\j/t61kI.R%aC+Nm*l3{я4y@gcҩ|dQ3.q\2RVk=mg?N90\H4YDYSIs嶕	hlg]
d
X9x>H3*Q	hi59"'§M3C;a#b7HT!k?:,r^zFU4\HX@p3x"%B/I-
wRDJX==%btOC?\W~ycY|\D&bmlĨ!HMO%Cܧ5rЭ}+.L؝AZZ+)}B"gE¼DhѤS/A~5h49~bGY]`A*.ݙ.EIJ֔Ӷeʾq#Ll"8Kϋ	t0\cPK|#
Od
{TxhŜPtN n0Fv៪<dseZALx-QndUL2T@HMC?'D”ad\gtTu=JWB?X<_,m9q7
+KʑSG>{	f
ڦUN$J)ʨyIEj“M&~uZ1{͎:G``&YXSH^h<*r8u8ԩbhZmm?
f~Yxq-	s6zNiN7
BsozR{RhvM(+74uH܃zj>MO|iH8VUh֭!J'&nJ1dڏPiua^,:PI<{kq@ahry{7|]j\jxMe~OpH@g7s=Yhn
u<)c}{q$u_3`_B'J
׷`z'0TMQ#/>_ ,m3zLq
\Q~EUtCII@M!c+:`[Zj1֨gqp<>pÍ`c[de6h5)|[Ȳ%v@{մrئlO۲	M}A|%zn|c^X.TKrfAswMMh07re [s,
+<a>^.osc.q2=
U1X: l')w[C+*W4&5yb;fnDMTSvv(Du3N(!HU=+ RO">{bgKm`pX3a1t!Uk0<+CdClyk7n	7+!hO<z-	}L='kuOV6DT괄/aƛB2"?
mrNLĬв6h^gf%di[F*f=?"ϲ$x<>,gKj>:ܭy`7^5;+2:8	ƹ$QWSGżCDѸLZ],Fm=lUI򘧒(d>ķTcsEeS}DqдGW6#vՏw_n	@C=z\lNhae\638+ s4/=;FORMDJVUINFO
XINCLmemo-int0032.djbzSjbzBE`ɒY%|SW-a@G<(~4Rq%5%1)rߵSŗsVy+6U>閜Bs
g^
Y%z~"08TTyQzkQ"D!dbѠp>cM]0πz,o3Ẃ݆1XCS!fg	v<(;	N7d\J!b%]:ME>\ǁx)jNt?
j:h&YGܪ*# "9%
!3d
ݙncv(pP;hr@_|RӶOC?,gKU:ě@eq4tbછ+[$z
:KlN6+כ%
SWrσ\8d	@ެMo}	%?&ۏ5!YrX^Me~1
oK@]x>-9=wXFPlꦂ'ˁeر';to-vſ+@0,.La5'g
k8Vk!NDG=b<g%˖FR|ʠq&E`In!$3'z%*eHN=	?7͆z~n1Shxuyz-+!D&V)Um[m5uj`#(ܛ*3[)'#Z}L3y«Q]4:{L-	sozȗ	Wp`R1jǤ/؁rKtˋM?+#҅il;4NYKRRV0B6[]nh"dw4)i{%//NvDb4"Iwۛѣm]sۙ;nb*4>3FZ
Actd:Dn̆1)&O+׳
A3`%E+GDrիQlxh=l4P`>
``>&IQc,G*G	T.D{hGzumN?~x&P_̣8KF|GݓM^^[|YabC&@w67Q+:5eLZmYqm!+9+m)'#4<6Uup0y<%2"vsݏh9aaC\6a<5Uv `0*䘐bCY&i.쳮Fs{sC[R0*ݽMno_h`$귳KxU]vPyk7l-x>'~r^S
5p
SWh/s.liy&%Dޝ/,ׂc̯(9l|9F܀^It?hAޘ:JkzzUYP';noQïVAG>ܓłh9 [=D{3Wh7i>%FX~7I^!rcNJ^`3i4Q
oj%9.ICxBv׭Ƣƹty1IN#rݱ%7@@3\6a;e̬S"υq(zBlڪ=X7hڥ`_/I:#?5BP%`L;AP;7dgUP^0wG5]8
	PO9Ww)-2AF}F'[哞@b	wWb_}`dg&L$	N×EGs4X*|وё[iVFvL:uc}F7QyB`&=n6Y3cNirSMʟ=<` p{l40@3"0(S
0\u߸>O~T\FmsYFogf
ʓShz"Jӝ!ЗEhg9HtF	g+;/cO{(0Л'44~ǐ|m#
w^uv*?Wn{}x"7[†y:SHڐ6Up&~gw<|_^=VR:5
^(QXebf=l5,鰾IԢ$])-F;S!,$gIvA'Cx2yA\=qVfhyKH
S~l+w*V1z
AWeA9,	3J	m/$glփno`F!y8>G*
fyF/I=Lw3(~w4IÉ
V
 h0X0ȉ%y`~x=AvnGq5::,"WBօiʬ#s2C9Bq:8шeJI0K[my7ȏ*ϻp>3
҅(1&"N>gvNsyzؚӈruсkRZY`*7d=oΝW-T_J}7oI,p&`35WL&(Q$=#uhY[eaB%K"XE
INl&DkpDiߔ^9ɓҏJE8Oj
Z*(!kV6@ WpB45M"%uoJ(i8)J8hHDD,=Wh?I[dѝ'IF칗
cD3h+Xn
IZ*[-oy>P15&8~/dHU@Ta 1nRH0,g3G鍟B_LRE-q%'U'c]".z"M2ÎvZ;OĶ!Ҽ7b x+I0H6F|TK=Q$Vx#)M^k/Y+H(:oMZ,hLзKETQ$\@6]Ξv,`^|>+S[m$%;@ o`4p=iʓ6?TXTz	Cˈ.J?]ڈ6En(xKfCڻ$jCo50ܦ:h@pTl7Ĺz֑)s(A*,~qerA#ҥr58Ŗҹs*+Q	2[KX6&TѡϞQYy7
u\~NG`=Ba體Ѵs>7!UDsqfncBM^8hH c(~ZZ-HFY[ZgrPj9WKVn?jÁ&<	6vL,NHM=pe6 ]Lb`5\?GHo-:V,Glv"Ā V	EFED/.tvr4 =X̾.sn(v%`fTqb[wGFx~
by{*DSgd-`<{E'hz^5
1-#Me3`;xC~lnAٯ92yNhcV
mX]|{o]q?qtK}%feE)PΞћ4&uIK<&l?=Tnm:C;*ߍ͊
1	X ֜{`O-Cd_}赐ˀ(Z>-	x[{\HYo/J8;4HUOr8:	{r '[oLR_?x4&
Yr.;
'5!gx8ro8r.y51.D|Cl$JnЂIbn"@ٌWiZ,%=E4]WoF@X
3Ē qU(Hb"2s.2ƶgrHP
;N}F(gf2O5h36,CGrwF9j-M^Q.n.fWbr%/L=Ȱ}9{$őc+Ȱ?Qy-ZLhI؊;
cM<ӷ{B=‚9`="hn,V6M[4OKks8Ozc5g]kag"sv>Q?艡j3/ .7Ӌm@vU^Z͆Yt$M--gGWʥLsk۫m0~S~ܫJU!J"l'wehC)r*Z:D~ X%I;tLÓ*k#mFpx>}K~)4i/Irir[FQE#rG~<Lb\v-5Se2Ou6PHo5DKvnR =;8P>_/y`'?JX"T[qep\Gj=Vt>L+keŝe7I]֢\.y8*MǭGޥI_T |to|0_܉-/)C\Pp
6Z~20!YmMӏX[.jJP~F``l{U\Îqw	3h4.%CEXnJǬ[>O5I9gN}9pcMV%wq^&~r.Ff;:@d][AE&SԧoW-bP},CeC>3W~@XEbrɋ4n,#`úyoHszߎ耿S]fimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/0000755000175000017500000000000011722677367023422 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Systems_of_PDEs/0000755000175000017500000000000011722677367026430 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Systems_of_PDEs/Bous_Ham_2_res.red0000755000175000017500000000017311526203062031672 0ustar  giovannigiovanni
phi1 := (c(3)*(2*ext(9)*sig + ext(6)*v + 2*ext(5)*u + ext(3)*u1))/2$

phi2 := (c(3)*(2*ext(6) + ext(5)*v + ext(3)*v1))/2$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Systems_of_PDEs/Bous_Ham_1_res.red0000755000175000017500000000005411526203062031667 0ustar  giovannigiovanni
phi1 := c(6)*ext(6)$

phi2 := c(6)*ext(5)$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Systems_of_PDEs/Bous_Ham_1.red0000755000175000017500000001624111526203062031023 0ustar  giovannigiovanni% Hamiltonian structures for Boussinesq equation
% Degree of the components Fdu+Gdv: [F]=0,[G]=-1
% Raffaele Vitolo, 2 June 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=v1$
ddx(0,5):=u2$
ddx(0,6):=v2$
ddx(0,7):=u3$
ddx(0,8):=v3$
ddx(0,9):=u4$
ddx(0,10):=v4$
ddx(0,11):=u5$
ddx(0,12):=v5$
ddx(0,13):=u6$
ddx(0,14):=v6$
ddx(0,15):=u7$
ddx(0,16):=v7$
ddx(0,17):=u8$
ddx(0,18):=v8$
ddx(0,19):=u9$
ddx(0,20):=v9$
ddx(0,21):=u10$
ddx(0,22):=v10$
ddx(0,23):=u11$
ddx(0,24):=v11$
ddx(0,25):=u12$
ddx(0,26):=v12$
ddx(0,27):=u13$
ddx(0,28):=v13$
ddx(0,29):=u14$
ddx(0,30):=v14$
ddx(0,31):=u15$
ddx(0,32):=v15$
ddx(0,33):=u16$
ddx(0,34):=v16$
ddx(0,35):=u17$
ddx(0,36):=v17$
ddx(0,37):=letop$
ddx(0,38):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=vt$
ddt(0,5):=ut1$
ddt(0,6):=vt1$
ddt(0,7):=ut2$
ddt(0,8):=vt2$
ddt(0,9):=ut3$
ddt(0,10):=vt3$
ddt(0,11):=ut4$
ddt(0,12):=vt4$
ddt(0,13):=ut5$
ddt(0,14):=vt5$
ddt(0,15):=ut6$
ddt(0,16):=vt6$
ddt(0,17):=ut7$
ddt(0,18):=vt7$
ddt(0,19):=ut8$
ddt(0,20):=vt8$
ddt(0,21):=ut9$
ddt(0,22):=vt9$
ddt(0,23):=ut10$
ddt(0,24):=vt10$
ddt(0,25):=ut11$
ddt(0,26):=vt11$
ddt(0,27):=ut12$
ddt(0,28):=vt12$
ddt(0,29):=ut13$
ddt(0,30):=vt13$
ddt(0,31):=ut14$
ddt(0,32):=vt14$
ddt(0,33):=ut15$
ddt(0,34):=vt15$
ddt(0,35):=ut16$
ddt(0,36):=vt16$
ddt(0,37):=letop$
ddt(0,38):=letop$

ut:=u1*v+u*v1+sig*v3;

vt:=u1+v*v1;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

vt1:=ddx vt;
vt2:=ddx vt1;
vt3:=ddx vt2;
vt4:=ddx vt3;
vt5:=ddx vt4;
vt6:=ddx vt5;
vt7:=ddx vt6;
vt8:=ddx vt7;
vt9:=ddx vt8;
vt10:=ddx vt9;
vt11:=ddx vt10;
vt12:=ddx vt11;
vt13:=ddx vt12;
vt14:=ddx vt13;


for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

%we now introduce odd variables ext 1,....,ext 20, and associated relations
%

%Specification of odd variables in ddx

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 5$
ddx(1,4):=ext 6$
ddx(1,5):=ext 7$
ddx(1,6):=ext 8$
ddx(1,7):=ext 9$
ddx(1,8):=ext 10$
ddx(1,9):=ext 11$
ddx(1,10):=ext 12$
ddx(1,11):=ext 13$
ddx(1,12):=ext 14$
ddx(1,13):=ext 15$
ddx(1,14):=ext 16$
ddx(1,15):=ext 17$
ddx(1,16):=ext 18$
ddx(1,17):=ext 19$
ddx(1,18):=ext 20$
ddx(1,19):=ext 21$
ddx(1,20):=ext 22$
ddx(1,21):=ext 23$
ddx(1,22):=ext 24$
ddx(1,23):=ext 25$
ddx(1,24):=ext 26$
ddx(1,25):=ext 27$
ddx(1,26):=ext 28$
ddx(1,27):=ext 29$
ddx(1,28):=ext 30$
ddx(1,29):=ext 31$
ddx(1,30):=ext 32$
ddx(1,31):=ext 33$
ddx(1,32):=ext 34$
ddx(1,33):=ext 35$
ddx(1,34):=ext 36$
ddx(1,35):=ext 37$
ddx(1,36):=ext 38$
ddx(1,37):=letop$
ddx(1,38):=letop$

%Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=+v*ext 5+ext 6$            %v*ext 5+v1*ext 3+ext 6$
ddt(1,4):=u*ext 5+sig*ext 9+v*ext 6$ %sig*ext 9-u1*ext 3+v*ext 6$
ddt(1,5):=ddx(ddt(1,3))$
ddt(1,6):=ddx(ddt(1,4))$
ddt(1,7):=ddx(ddt(1,5))$
ddt(1,8):=ddx(ddt(1,6))$
ddt(1,9):=ddx(ddt(1,7))$
ddt(1,10):=ddx(ddt(1,8))$
ddt(1,11):=ddx(ddt(1,9))$
ddt(1,12):=ddx(ddt(1,10))$
ddt(1,13):=ddx(ddt(1,11))$
ddt(1,14):=ddx(ddt(1,12))$
ddt(1,15):=ddx(ddt(1,13))$
ddt(1,16):=ddx(ddt(1,14))$
ddt(1,17):=ddx(ddt(1,15))$
ddt(1,18):=ddx(ddt(1,16))$
ddt(1,19):=ddx(ddt(1,17))$
ddt(1,20):=ddx(ddt(1,18))$
ddt(1,21):=ddx(ddt(1,19))$
ddt(1,22):=ddx(ddt(1,20))$
ddt(1,23):=ddx(ddt(1,21))$
ddt(1,24):=ddx(ddt(1,22))$
ddt(1,25):=ddx(ddt(1,23))$
ddt(1,26):=ddx(ddt(1,24))$
ddt(1,27):=ddx(ddt(1,25))$
ddt(1,28):=ddx(ddt(1,26))$
ddt(1,29):=ddx(ddt(1,27))$
ddt(1,30):=ddx(ddt(1,28))$
ddt(1,31):=ddx(ddt(1,29))$
ddt(1,32):=ddx(ddt(1,30))$
ddt(1,33):=ddx(ddt(1,31))$
ddt(1,34):=ddx(ddt(1,32))$
ddt(1,35):=ddx(ddt(1,33))$
ddt(1,36):=ddx(ddt(1,34))$
ddt(1,37):=letop$
ddt(1,38):=letop$

% remember: the list starts with 1 !!!!!!!!!

graadlijst:={{v},{u,v1},{u1,v2},{u2,v3},{u3,v4},{u4,v5},
{u5,v6},{u6,v7},{u7,v8},{u8,v9},{u9,v10},{u10,v11},{u11,v12},{u12,v13},
{u13,v14},{u14,v15},{u15,v16},{u16,v17},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};


grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$


ctel:=0;

phi1:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6
$

phi2:=
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 4
$

equ 1:=ddt(phi1)-v*ddx(phi1)-v1*phi1-u1*phi2-u*ddx(phi2)
-sig*ddx(ddx(ddx(phi2)));

equ 2:=-ddx(phi1)-v*ddx(phi2)-v1*phi2+ddt(phi2);

vars:={x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,v7,u8,v8,u9,v9,u10,v10,
u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17};

tel:=2;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

for i:=1:2 do splitext i;

tel1:=tel;

for i:=3:tel1 do begin splitvars i;equ i:=0;end;

pte tel;


end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Systems_of_PDEs/Bous_Ham_2.red0000755000175000017500000001665611526203062031036 0ustar  giovannigiovanni% Hamiltonian structures for Boussinesq equation
% Degree of the components Fdu+Gdv: [F]=1,[G]=0
% Raffaele Vitolo, 2 June 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=v1$
ddx(0,5):=u2$
ddx(0,6):=v2$
ddx(0,7):=u3$
ddx(0,8):=v3$
ddx(0,9):=u4$
ddx(0,10):=v4$
ddx(0,11):=u5$
ddx(0,12):=v5$
ddx(0,13):=u6$
ddx(0,14):=v6$
ddx(0,15):=u7$
ddx(0,16):=v7$
ddx(0,17):=u8$
ddx(0,18):=v8$
ddx(0,19):=u9$
ddx(0,20):=v9$
ddx(0,21):=u10$
ddx(0,22):=v10$
ddx(0,23):=u11$
ddx(0,24):=v11$
ddx(0,25):=u12$
ddx(0,26):=v12$
ddx(0,27):=u13$
ddx(0,28):=v13$
ddx(0,29):=u14$
ddx(0,30):=v14$
ddx(0,31):=u15$
ddx(0,32):=v15$
ddx(0,33):=u16$
ddx(0,34):=v16$
ddx(0,35):=u17$
ddx(0,36):=v17$
ddx(0,37):=letop$
ddx(0,38):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=vt$
ddt(0,5):=ut1$
ddt(0,6):=vt1$
ddt(0,7):=ut2$
ddt(0,8):=vt2$
ddt(0,9):=ut3$
ddt(0,10):=vt3$
ddt(0,11):=ut4$
ddt(0,12):=vt4$
ddt(0,13):=ut5$
ddt(0,14):=vt5$
ddt(0,15):=ut6$
ddt(0,16):=vt6$
ddt(0,17):=ut7$
ddt(0,18):=vt7$
ddt(0,19):=ut8$
ddt(0,20):=vt8$
ddt(0,21):=ut9$
ddt(0,22):=vt9$
ddt(0,23):=ut10$
ddt(0,24):=vt10$
ddt(0,25):=ut11$
ddt(0,26):=vt11$
ddt(0,27):=ut12$
ddt(0,28):=vt12$
ddt(0,29):=ut13$
ddt(0,30):=vt13$
ddt(0,31):=ut14$
ddt(0,32):=vt14$
ddt(0,33):=ut15$
ddt(0,34):=vt15$
ddt(0,35):=ut16$
ddt(0,36):=vt16$
ddt(0,37):=letop$
ddt(0,38):=letop$

ut:=u1*v+u*v1+sig*v3;

vt:=u1+v*v1;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

vt1:=ddx vt;
vt2:=ddx vt1;
vt3:=ddx vt2;
vt4:=ddx vt3;
vt5:=ddx vt4;
vt6:=ddx vt5;
vt7:=ddx vt6;
vt8:=ddx vt7;
vt9:=ddx vt8;
vt10:=ddx vt9;
vt11:=ddx vt10;
vt12:=ddx vt11;
vt13:=ddx vt12;
vt14:=ddx vt13;


for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

%we now introduce odd variables ext 1,....,ext 20, and associated relations
%

%Specification of odd variables in ddx

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 5$
ddx(1,4):=ext 6$
ddx(1,5):=ext 7$
ddx(1,6):=ext 8$
ddx(1,7):=ext 9$
ddx(1,8):=ext 10$
ddx(1,9):=ext 11$
ddx(1,10):=ext 12$
ddx(1,11):=ext 13$
ddx(1,12):=ext 14$
ddx(1,13):=ext 15$
ddx(1,14):=ext 16$
ddx(1,15):=ext 17$
ddx(1,16):=ext 18$
ddx(1,17):=ext 19$
ddx(1,18):=ext 20$
ddx(1,19):=ext 21$
ddx(1,20):=ext 22$
ddx(1,21):=ext 23$
ddx(1,22):=ext 24$
ddx(1,23):=ext 25$
ddx(1,24):=ext 26$
ddx(1,25):=ext 27$
ddx(1,26):=ext 28$
ddx(1,27):=ext 29$
ddx(1,28):=ext 30$
ddx(1,29):=ext 31$
ddx(1,30):=ext 32$
ddx(1,31):=ext 33$
ddx(1,32):=ext 34$
ddx(1,33):=ext 35$
ddx(1,34):=ext 36$
ddx(1,35):=ext 37$
ddx(1,36):=ext 38$
ddx(1,37):=letop$
ddx(1,38):=letop$

%Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=+v*ext 5+ext 6$            %v*ext 5+v1*ext 3+ext 6$
ddt(1,4):=u*ext 5+sig*ext 9+v*ext 6$ %sig*ext 9-u1*ext 3+v*ext 6$
ddt(1,5):=ddx(ddt(1,3))$
ddt(1,6):=ddx(ddt(1,4))$
ddt(1,7):=ddx(ddt(1,5))$
ddt(1,8):=ddx(ddt(1,6))$
ddt(1,9):=ddx(ddt(1,7))$
ddt(1,10):=ddx(ddt(1,8))$
ddt(1,11):=ddx(ddt(1,9))$
ddt(1,12):=ddx(ddt(1,10))$
ddt(1,13):=ddx(ddt(1,11))$
ddt(1,14):=ddx(ddt(1,12))$
ddt(1,15):=ddx(ddt(1,13))$
ddt(1,16):=ddx(ddt(1,14))$
ddt(1,17):=ddx(ddt(1,15))$
ddt(1,18):=ddx(ddt(1,16))$
ddt(1,19):=ddx(ddt(1,17))$
ddt(1,20):=ddx(ddt(1,18))$
ddt(1,21):=ddx(ddt(1,19))$
ddt(1,22):=ddx(ddt(1,20))$
ddt(1,23):=ddx(ddt(1,21))$
ddt(1,24):=ddx(ddt(1,22))$
ddt(1,25):=ddx(ddt(1,23))$
ddt(1,26):=ddx(ddt(1,24))$
ddt(1,27):=ddx(ddt(1,25))$
ddt(1,28):=ddx(ddt(1,26))$
ddt(1,29):=ddx(ddt(1,27))$
ddt(1,30):=ddx(ddt(1,28))$
ddt(1,31):=ddx(ddt(1,29))$
ddt(1,32):=ddx(ddt(1,30))$
ddt(1,33):=ddx(ddt(1,31))$
ddt(1,34):=ddx(ddt(1,32))$
ddt(1,35):=ddx(ddt(1,33))$
ddt(1,36):=ddx(ddt(1,34))$
ddt(1,37):=letop$
ddt(1,38):=letop$

% remember: the list starts with 1 !!!!!!!!!

graadlijst:={{v},{u,v1},{u1,v2},{u2,v3},{u3,v4},{u4,v5},
{u5,v6},{u6,v7},{u7,v8},{u8,v9},{u9,v10},{u10,v11},{u11,v12},{u12,v13},
{u13,v14},{u14,v15},{u15,v16},{u16,v17},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};


grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$


ctel:=0;

phi1:=
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 9+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 6+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 8
$

phi2:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6
$

equ 1:=ddt(phi1)-v*ddx(phi1)-v1*phi1-u1*phi2-u*ddx(phi2)
-sig*ddx(ddx(ddx(phi2)));

equ 2:=-ddx(phi1)-v*ddx(phi2)-v1*phi2+ddt(phi2);

vars:={x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,v7,u8,v8,u9,v9,u10,v10,
u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,u16,v16,u17,v17};

tel:=2;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

for i:=1:2 do splitext i;

tel1:=tel;

for i:=3:tel1 do begin splitvars i;equ i:=0;end;

pte tel;


end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/0000755000175000017500000000000011722677367027051 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_2_res.red0000755000175000017500000000005711526203062032343 0ustar  giovannigiovanni
sym := c(1)*(3*t*u*u1 + 3*t*u3 + 2*u + u1*x)$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_3.red0000755000175000017500000001006011526203062031466 0ustar  giovannigiovanni% Raffaele Vitolo, 09/10/09
% This is the computation for symmetries of KdV
% ansatz: sym=x*(something of degree 1)+t*(something of degree 3)
%  +(something of degree 0)
% NOTE: no terms of degree 1!
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};


grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$

ctel:=0;

sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
x*(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
%(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
t*(for each el in grd3 sum (c(ctel:=ctel+1)*el))$
% (for each el in grd4 sum (c(ctel:=ctel+1)*el))+
%t*(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

equ 1:=ddt(sym)-u*ddx(sym)-u1*sym-ddx(ddx(ddx(sym)));

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

%% procedure splitext i;
%% begin;
%% ll:=operator_coeff(equ i,ext);
%% equ(tel:=tel+1):=first ll;
%% ll:=rest ll;
%% for each el in ll do equ(tel:=tel+1):=second el;
%% end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

%%Q: is it correct to initialize_equations in the following way?

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

%% splitext 1;

splitvars 1;

tel1:=tel;

pte tel;

for i:=2:te do es i;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/Burg_hsym_1_res.red0000755000175000017500000000033211526203062032551 0ustar  giovannigiovanni
sym := (12*c(14)*u**3*u1 + 18*c(14)*u**2*u2 + 36*c(14)*u*u1**2 + 12*c(14)*u*u3 +
 30*c(14)*u1*u2 + 3*c(14)*u4 + 12*c(9)*u**2*u1 + 12*c(9)*u*u2 + 12*c(9)*u1**2 + 
4*c(9)*u3 + 12*c(6)*u*u1 + 6*c(6)*u2 + 12*c(4)*u1)/12$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_2.red0000755000175000017500000000741711526203062031501 0ustar  giovannigiovanni% Raffaele Vitolo, 09/10/09
% This is the computation for symmetries of KdV
% ansatz: sym=x*(something of degree 3)+t*(something of degree  5)
%  +(something of degree 2)
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};


grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$

ctel:=0;

sym:=
%(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
%(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
x*(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
% (for each el in grd4 sum (c(ctel:=ctel+1)*el))+
t*(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

equ 1:=ddt(sym)-u*ddx(sym)-u1*sym-ddx(ddx(ddx(sym)));

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

splitvars 1;

tel1:=tel;

pte tel;

for i:=2:te do es i;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_1.red0000755000175000017500000000740011526203062031470 0ustar  giovannigiovanni% Raffaele Vitolo, 09/10/09
% This is the computation for symmetries of KdV
% Note that here [x]=-1, hence [u]=2 and [t]=-3.
% ansatz: deg(sym) <=5
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;


super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

%% In KdV u has degree two

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$

ctel:=0;

sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

equ 1:=ddt(sym)-u*ddx(sym)-u1*sym-ddx(ddx(ddx(sym)));

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

splitvars 1;

pte tel;

for i:=2:te do es i;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/Burg_hsym_1.red0000755000175000017500000001407511526203062031711 0ustar  giovannigiovanni% Raffaele Vitolo, 09/10/09
% This is the computation for (higher) symmetries of Burgers
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

% The following instructions initialize the total derivatives. The first
% string is the name of the vector field,
% the second item is the list of even variables
% (note that u1, u2, ... are u_x, u_xx, ...),
% the third item is the list of non-commuting variables
% (`ext' stands for `external' like in external (wedge) product).

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


% Specification of the vectorfield ddx.
% The meaning of the first index is the parity of variables.
% In particular here we have just even variables.
% The second index parametrizes the second item (list)
% in the super_vectorfield declaration.

ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

% Specification of the vectorfield ddt
% In the evolutionary case we never have more than one time derivative
% other derivatives are u_txxx ...

ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

% The equation -- this is also used to specify internal variables.
% For evolutionary equations internal variables are of the type
% (t,x,u,u_x,u_xx,...)

ut:=u2+2*u*u1;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

% Test for verifying the commutation of total derivatives.
% Highest order defined terms yield some `letop'
% which means `careful' in Dutch and is treated as a new variable.

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

pause;

%% This is the list of variables with respect to their grading,
%% starting from degree ONE.

graadlijst:={{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

% This is the list of all monomials of degree 0, 1, 2, ... 
% which can be constructed from the above list of elementary variables 
% with their grading.

grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$

% Initialize a counter for the vector of arbitrary constants

ctel:=0;

% we assume a generating function of degree <= 5

sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

% This is the equation ell_B(sym)=0, where B=0 is Burgers'equation
% and sym is the generating function. From now on all equations
% are arranged in a single vector whose name is `equ'.

equ 1:=ddt(sym)-ddx(ddx(sym))-2*u*ddx(sym)-2*u1*sym ;

% This is the list of variables, to be passed to the equation solver.

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

% This is the number of initial equation(s)

tel:=1;

% The following procedure uses multi_coeff (from the package `tools').
% It gets all coefficients of monomials appearing in the initial equation(s).
% The coefficients are put into the vector equ after the initial equations.

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

% This command initialize the equation solver.
% It passes the equation(s) togeher with their number `tel',
% the constants'vector `c', its length `ctel',
% an arbitrary constant `f' that may appear in computations.

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

% Run the procedure splitvars in order to obtain equations on coefficiens
% of each monomial.

splitvars 1;

% Next command tells the solver the total number of equations obtained
% after running splitvars.

pte tel;

% It is worth to write down the equations for the coefficients.

for i:=2:tel do write equ i;

pause;

% This command solves the equations for the coefficients.
% Note that we have to skip the initial equations!

for i:=2:te do es i;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_3_res.red0000755000175000017500000000003111526203062032334 0ustar  giovannigiovanni
sym := c(1)*(t*u1 + 1)$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Higher_Symmetries/KdV_hsym_1_res.red0000755000175000017500000000004711526203062032341 0ustar  giovannigiovanni
sym := c(6)*u*u1 + c(6)*u3 + c(3)*u1$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/README.txt0000644000175000017500000000356311526203062025102 0ustar  giovannigiovanni% % *****************************************************************
% Description: in the subfolders there are various example programs
% of computations in the geometry of differential equations
% with the package CDIFF. All the example programs are released under
% terms stated below.
%
% Author: Raffaele Vitolo
% Dipartimento di Matematica, Universita' del Salento (Lecce, Italy)
% email: raffaele.vitolo@unisalento.it
% web: http://poincare.unisalento.it/vitolo
%
% Version and Date:  Version 1.0, 1 September 2010.
%
% ===============================================================
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Denominators/0000755000175000017500000000000011722677367026064 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Denominators/KdV_denom_1.red0000755000175000017500000000502711526203062030630 0ustar  giovannigiovanni% R. Vitolo, 10 March 2010
% Computation of iterated D_x
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

phi:=1/(u3+u*u1)$

for i:=1:100 do begin
                phi:=ddx(phi)$
                write i;
end;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Denominators/KdV_denom_2.red0000755000175000017500000000536211526203062030633 0ustar  giovannigiovanni% Raffaele Vitolo, 09/04/10
% This is an example on how to avoid denominators
% and always have polynomial computations.
% Trick: introduce one additional variable in ddx which
% is equal to the denominator and introduce its total derivative.
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17,aa21},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$
ddx(0,21):=-aa21**2*(u4+u1**2+u*u2)$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

phi:=aa21;

for i:=1:5 do begin
                phi:=ddx(phi)$
                write i;
end;

;end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Denominators/KdV_denom_2_res.red0000755000175000017500000000555011526203062031503 0ustar  giovannigiovanni
phi := aa21**2*( - 120*aa21**4*u**5*u2**5 - 600*aa21**4*u**4*u1**2*u2**4 - 600*
aa21**4*u**4*u2**4*u4 - 1200*aa21**4*u**3*u1**4*u2**3 - 2400*aa21**4*u**3*u1**2*
u2**3*u4 - 1200*aa21**4*u**3*u2**3*u4**2 - 1200*aa21**4*u**2*u1**6*u2**2 - 3600*
aa21**4*u**2*u1**4*u2**2*u4 - 3600*aa21**4*u**2*u1**2*u2**2*u4**2 - 1200*aa21**4
*u**2*u2**2*u4**3 - 600*aa21**4*u*u1**8*u2 - 2400*aa21**4*u*u1**6*u2*u4 - 3600*
aa21**4*u*u1**4*u2*u4**2 - 2400*aa21**4*u*u1**2*u2*u4**3 - 600*aa21**4*u*u2*u4**
4 - 120*aa21**4*u1**10 - 600*aa21**4*u1**8*u4 - 1200*aa21**4*u1**6*u4**2 - 1200*
aa21**4*u1**4*u4**3 - 600*aa21**4*u1**2*u4**4 - 120*aa21**4*u4**5 + 240*aa21**3*
u**4*u2**3*u3 + 720*aa21**3*u**3*u1**2*u2**2*u3 + 720*aa21**3*u**3*u1*u2**4 + 
240*aa21**3*u**3*u2**3*u5 + 720*aa21**3*u**3*u2**2*u3*u4 + 720*aa21**3*u**2*u1**
4*u2*u3 + 2160*aa21**3*u**2*u1**3*u2**3 + 720*aa21**3*u**2*u1**2*u2**2*u5 + 1440
*aa21**3*u**2*u1**2*u2*u3*u4 + 2160*aa21**3*u**2*u1*u2**3*u4 + 720*aa21**3*u**2*
u2**2*u4*u5 + 720*aa21**3*u**2*u2*u3*u4**2 + 240*aa21**3*u*u1**6*u3 + 2160*aa21
**3*u*u1**5*u2**2 + 720*aa21**3*u*u1**4*u2*u5 + 720*aa21**3*u*u1**4*u3*u4 + 4320
*aa21**3*u*u1**3*u2**2*u4 + 1440*aa21**3*u*u1**2*u2*u4*u5 + 720*aa21**3*u*u1**2*
u3*u4**2 + 2160*aa21**3*u*u1*u2**2*u4**2 + 720*aa21**3*u*u2*u4**2*u5 + 240*aa21
**3*u*u3*u4**3 + 720*aa21**3*u1**7*u2 + 240*aa21**3*u1**6*u5 + 2160*aa21**3*u1**
5*u2*u4 + 720*aa21**3*u1**4*u4*u5 + 2160*aa21**3*u1**3*u2*u4**2 + 720*aa21**3*u1
**2*u4**2*u5 + 720*aa21**3*u1*u2*u4**3 + 240*aa21**3*u4**3*u5 - 60*aa21**2*u**3*
u2**2*u4 - 90*aa21**2*u**3*u2*u3**2 - 120*aa21**2*u**2*u1**2*u2*u4 - 90*aa21**2*
u**2*u1**2*u3**2 - 780*aa21**2*u**2*u1*u2**2*u3 - 180*aa21**2*u**2*u2**4 - 60*
aa21**2*u**2*u2**2*u6 - 180*aa21**2*u**2*u2*u3*u5 - 120*aa21**2*u**2*u2*u4**2 - 
90*aa21**2*u**2*u3**2*u4 - 60*aa21**2*u*u1**4*u4 - 1020*aa21**2*u*u1**3*u2*u3 - 
1170*aa21**2*u*u1**2*u2**3 - 120*aa21**2*u*u1**2*u2*u6 - 180*aa21**2*u*u1**2*u3*
u5 - 120*aa21**2*u*u1**2*u4**2 - 540*aa21**2*u*u1*u2**2*u5 - 1020*aa21**2*u*u1*
u2*u3*u4 - 360*aa21**2*u*u2**3*u4 - 120*aa21**2*u*u2*u4*u6 - 90*aa21**2*u*u2*u5
**2 - 180*aa21**2*u*u3*u4*u5 - 60*aa21**2*u*u4**3 - 240*aa21**2*u1**5*u3 - 990*
aa21**2*u1**4*u2**2 - 60*aa21**2*u1**4*u6 - 540*aa21**2*u1**3*u2*u5 - 480*aa21**
2*u1**3*u3*u4 - 1170*aa21**2*u1**2*u2**2*u4 - 120*aa21**2*u1**2*u4*u6 - 90*aa21
**2*u1**2*u5**2 - 540*aa21**2*u1*u2*u4*u5 - 240*aa21**2*u1*u3*u4**2 - 180*aa21**
2*u2**2*u4**2 - 60*aa21**2*u4**2*u6 - 90*aa21**2*u4*u5**2 + 10*aa21*u**2*u2*u5 +
 20*aa21*u**2*u3*u4 + 10*aa21*u*u1**2*u5 + 110*aa21*u*u1*u2*u4 + 80*aa21*u*u1*u3
**2 + 160*aa21*u*u2**2*u3 + 10*aa21*u*u2*u7 + 20*aa21*u*u3*u6 + 30*aa21*u*u4*u5 
+ 50*aa21*u1**3*u4 + 340*aa21*u1**2*u2*u3 + 10*aa21*u1**2*u7 + 180*aa21*u1*u2**3
 + 60*aa21*u1*u2*u6 + 80*aa21*u1*u3*u5 + 50*aa21*u1*u4**2 + 60*aa21*u2**2*u5 + 
100*aa21*u2*u3*u4 + 10*aa21*u4*u7 + 20*aa21*u5*u6 - u*u6 - 6*u1*u5 - 15*u2*u4 - 
10*u3**2 - u8)$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/0000755000175000017500000000000011722677367027723 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-cl_1.red0000755000175000017500000001405311526203062032713 0ustar  giovannigiovanni% Non-local Hamiltonian operators for KdV
% Computation of covering variables as non-local conservation laws
% Raffaele Vitolo, 30 May 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

% KdV equation

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

% we now introduce odd variables ext 1,....,ext 20, and associated relations

% Specification of odd variables in ddx. We look for conservation laws
% of the form
% fx= phi*ext 3
% ft= f1*ext3+f2*ext4+f3*ext5
%
% The ansatz is chosen because, first of all, ext 4 and ext 5
% can be removed from fx by adding a suitable total divergence;
% moreover it can be proved that phi is a symmetry of KdV.

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$
ddx(1,50):=(t*u1+1)*ext 3$ % degree -2
ddx(1,51):=u1*ext 3$ % degree +1
ddx(1,52):=(u*u1+u3)*ext 3$ % degree +3

%Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$
ddt(1,50):=f1*ext 3+f2*ext 4+f3*ext 5$
ddt(1,51):=f4*ext 3+f5*ext 4+f6*ext 5$
ddt(1,52):=f7*ext 3+f8*ext 4+f9*ext 5$

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$

ctel:=0;

% Note that the equation equ 1 can be solved directly and produces
% what is below. It is more tricky to solve it automatically due
% to the presence of `t' in the generator of the symmetry f3=phi

f3:=t*u1+1$
f1:=u*f3+ddx(ddx(f3))$
f2:=-ddx(f3)$

% The following ansatz keep into account the grading of the starting
% symmetry in ddx(phi*ext 3).

f4:=
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$
f5:=
(for each el in grd4 sum (c(ctel:=ctel+1)*el))$
f6:=
(for each el in grd3 sum (c(ctel:=ctel+1)*el))$

f7:=
(for each el in grd7 sum (c(ctel:=ctel+1)*el))$
f8:=
(for each el in grd6 sum (c(ctel:=ctel+1)*el))$
f9:=
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

% The first equation below is already solved `by hand'.

equ 1:=ddx(f1*ext 3+f2*ext 4+f3*ext 5)-ddt((t*u1+1)*ext 3);

equ 2:=ddx(ddt(1,51))-ddt(ddx(1,51));

equ 3:=ddx(ddt(1,52))-ddt(ddx(1,52));

pause;

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=3;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

for i:=1:3 do splitext i;

tel1:=tel;

for i:=4:tel1 do begin splitvars i;equ i:=0;end;

pte tel;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_Ham_1_res.red0000755000175000017500000000011011526203062032727 0ustar  giovannigiovanni
phi := c(4)*ext(4) + 3*c(3)*ext(6) + 2*c(3)*ext(4)*u + c(3)*ext(3)*u1$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_2.red0000755000175000017500000001454011526203062033024 0ustar  giovannigiovanni% non-local Hamiltonian structures on KdV
% R. Vitolo, 10 March 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

%we now introduce odd variables ext 1,....,ext 20, and associated relations
%

%Specification of odd variables in ddx

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$
ddx(1,50):=(t*u1+1)*ext 3$ % degree -2
ddx(1,51):=u1*ext 3$ % degree +1
ddx(1,52):=(u*u1+u3)*ext 3$ % degree +3

%Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$
ddt(1,50) := ext(5)*t*u1 + ext(5) - ext(4)*t*u2 + ext(3)*t*u*u1 + ext(3)*t*u3 + 
ext(3)*u$
ddt(1,51) := ext(5)*u1 - ext(4)*u2 + ext(3)*u*u1 + ext(3)*u3$
ddt(1,52) := ext(5)*u*u1 + ext(5)*u3 - ext(4)*u*u2 - ext(4)*u1**2 - ext(4)*u4 + 
ext(3)*u**2*u1 + 2*ext(3)*u*u3 + 3*ext(3)*u1*u2 + ext(3)*u5$

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$

ctel:=0;

% use this for the first nonlocal Hamiltonian operator ([phi]=3)
%% phi:=
%% (for each el in grd6 sum (c(ctel:=ctel+1)*el))*ext 50+
%% (for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 51+
%% (for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 52+
%% 
%% (for each el in grd5 sum (c(ctel:=ctel+1)*el))*ext 3+
%% (for each el in grd4 sum (c(ctel:=ctel+1)*el))*ext 4+
%% (for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 5+
%% (for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 6+
%% (for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 7+
%% (for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 8
%% $

% use this for the second nonl. H. op. [phi]=5
phi:=
(for each el in grd8 sum (c(ctel:=ctel+1)*el))*ext 50+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))*ext 51+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 52+

(for each el in grd7 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd6 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))*ext 6+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 8+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 9+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 10
$

% equation for shadows of nonlocal symmetries in \ell^*-covering

equ 1:=ddt(phi)-u*ddx(phi)-u1*phi-ddx(ddx(ddx(phi)));

pause;

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

splitext 1;

tel1:=tel;

for i:=2:tel1 do begin splitvars i;equ i:=0;end;

pte tel;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_loc-cl_2_res.red0000755000175000017500000000010311526203062033376 0ustar  giovannigiovannifxnontriv := c(2)*u + c(1)$

ftnontriv := (c(2)*(u**2 + 2*u2))/2$

././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_2_res.redmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_2_res.r0000755000175000017500000000020111526203062033351 0ustar  giovannigiovanni
phi := c(1)*(ext(51)*u1 - 9*ext(8) - 12*ext(6)*u - 18*ext(5)*u1 - 4*ext(4)*u**2 
- 12*ext(4)*u2 - 4*ext(3)*u*u1 - 3*ext(3)*u3)$
././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-cl_1_res.redmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-cl_1_res.re0000755000175000017500000000060611526203062033417 0ustar  giovannigiovanni
ddx(1,50) := ext(3)*(t*u1 + 1)$

ddx(1,51) := ext(3)*u1$

ddx(1,52) := ext(3)*(u*u1 + u3)$

ddt(1,50) := ext(5)*t*u1 + ext(5) - ext(4)*t*u2 + ext(3)*t*u*u1 + ext(3)*t*u3 + 
ext(3)*u$

ddt(1,51) := ext(5)*u1 - ext(4)*u2 + ext(3)*u*u1 + ext(3)*u3$

ddt(1,52) := ext(5)*u*u1 + ext(5)*u3 - ext(4)*u*u2 - ext(4)*u1**2 - ext(4)*u4 + 
ext(3)*u**2*u1 + 2*ext(3)*u*u3 + 3*ext(3)*u1*u2 + ext(3)*u5$
././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_1_res.redmathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_1_res.r0000755000175000017500000000020111526203062033350 0ustar  giovannigiovanni
phi := c(1)*(ext(51)*u1 - 9*ext(8) - 12*ext(6)*u - 18*ext(5)*u1 - 4*ext(4)*u**2 
- 12*ext(4)*u2 - 4*ext(3)*u*u1 - 3*ext(3)*u3)$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_nloc-Ham_1.red0000755000175000017500000001457011526203062033026 0ustar  giovannigiovanni% Nonlocal Hamiltonian structures on KdV
% Raffaele Vitolo, 30 May 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

% we now introduce odd variables ext 1,....,ext 20, and associated relations
%
% Note that now the variables with index 50,51,52 play an essential role.
% Indeed, these are the covering variables that we can indicate with
% r_1, r_2, r_3. We are going to find a first non-local Hamiltonian operator
% depending linearly on one of these variables. Higher non-local Hamiltonian 
% operators could be found by introducing total derivatives of the r's.
% Of course, the variables are specified through the components of the 
% previously found conservation laws according with the rule
% {r_1}_x=fx, {r_1}_t=ft.

%Specification of odd variables in ddx

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$
ddx(1,50):=(t*u1+1)*ext 3$ % degree -2
ddx(1,51):=u1*ext 3$ % degree +1
ddx(1,52):=(u*u1+u3)*ext 3$ % degree +3

% Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$
ddt(1,50) := ext(5)*t*u1 + ext(5) - ext(4)*t*u2 + ext(3)*t*u*u1 + ext(3)*t*u3 + 
ext(3)*u$
ddt(1,51) := ext(5)*u1 - ext(4)*u2 + ext(3)*u*u1 + ext(3)*u3$
ddt(1,52) := ext(5)*u*u1 + ext(5)*u3 - ext(4)*u*u2 - ext(4)*u1**2 - ext(4)*u4 + 
ext(3)*u**2*u1 + 2*ext(3)*u*u3 + 3*ext(3)*u1*u2 + ext(3)*u5$


graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$

ctel:=0;

% This is the ansatz for the nonlocal Hamiltonian operator.
% It comes from the fact that local Hamiltonian operators have 
% grading -1 and +1 when written in terms of p's. So we are looking 
% for a nonlocal Hamiltonian operator of degree 3.

phi:=
(for each el in grd6 sum (c(ctel:=ctel+1)*el))*ext 50+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 51+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 52+

(for each el in grd5 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 6+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 8
$

% equation for shadows of nonlocal symmetries in \ell^*-covering

equ 1:=ddt(phi)-u*ddx(phi)-u1*phi-ddx(ddx(ddx(phi)));

pause;

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

splitext 1;

tel1:=tel;

for i:=2:tel1 do begin splitvars i;equ i:=0;end;

pte tel;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Hamiltonian_Operators/KdV_Ham_1.red0000755000175000017500000001251211526203062032067 0ustar  giovannigiovanni% Hamiltonian operators on KdV
% Raffaele Vitolo, 10 April 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

%we now introduce odd variables ext 1,....,ext 20, and associated relations
%

%Specification of odd variables in ddx

ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$


%Specification of odd variables in ddt
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$


ctel:=0;

phi:=

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 3+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 4+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6

$


equ 1:=ddt(phi)-u*ddx(phi)-u1*phi-ddx(ddx(ddx(phi)));


vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

equ 1:=equ 1;

pause;

splitext 1;

for i:=2:tel do write equ i:=equ i;

pause;

tel1:=tel;

for i:=2:tel1 do begin splitvars i;equ i:=0;end;

pte tel;

for i:=2:tel do write equ i:=equ i;

pause;

for i:=2:tel do es i;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Conservation_laws/0000755000175000017500000000000011722677367027122 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Conservation_laws/KdV_loc-cl_1_res.red0000755000175000017500000000013411526203062032600 0ustar  giovannigiovanni
fx := c(3)*u1 + c(2)*u + c(1)$

ft := (2*c(3)*u*u1 + 2*c(3)*u3 + c(2)*u**2 + 2*c(2)*u2)/2$
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Conservation_laws/KdV_loc-cl_2_res.red0000755000175000017500000000010311526203062032575 0ustar  giovannigiovannifxnontriv := c(2)*u + c(1)$

ftnontriv := (c(2)*(u**2 + 2*u2))/2$

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Conservation_laws/KdV_loc-cl_1.red0000755000175000017500000001014111526203062031726 0ustar  giovannigiovanni% Local conservation laws for the KdV equation
% program for removing trivial conservation laws
% one should already have conservation laws in the form
% fx=... ft=... possibly depending on constants c.
% Raffaele Vitolo, 30 May 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

% KdV equation

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

% remember that in KdV [u]=2, graadlijst starts from degree 1

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$

ctel:=0;

fx:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))$
ft:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$

equ 1:=ddt(fx)-ddx(ft);

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=1;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});

splitvars 1;

pte tel;

for i:=2:tel do es i;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/examples/Conservation_laws/KdV_loc-cl_2.red0000755000175000017500000001104511526203062031733 0ustar  giovannigiovanni% Local conservation laws for the KdV equation
% program for removing trivial conservation laws
% one should already have conservation laws in the form
% fx=... ft=... possibly depending on constants c.
% Raffaele Vitolo, 30 May 2010
% In order to work with the examples, load first CDIFF with the command
% load_package cdiff;

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

%specification of the vectorfield ddx
%the even variables
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$

%specification of the vectorfield ddt
%the even variables
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
ddt(0,20):=letop$

% KdV equation

ut:=u*u1+u3;

ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));

graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};

grdm6:={0};
grdm5:={0};
grdm4:={0};
grdm3:={0};
grdm2:={0};
grdm1:={0};

grd0:={1};

grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
grd17:= mkvarlist1(17,17)$
grd18:= mkvarlist1(18,18)$
grd19:= mkvarlist1(19,19)$

cctel:=0;

%% fx:=
%% (for each el in grd0 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd1 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd2 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd3 sum (c(ctel:=ctel+1)*el))$
%% ft:=
%% (for each el in grd2 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd3 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd4 sum (c(ctel:=ctel+1)*el))+
%% (for each el in grd5 sum (c(ctel:=ctel+1)*el))$

% Loads the results of the previous computation

fx := c(3)*u1 + c(2)*u + c(1);
ft := (2*c(3)*u*u1 + 2*c(3)*u3 + c(2)*u**2 + 2*c(2)*u2)/2;

% ansatz for f0, the grading must be compatible
% with the system fx-ddx(f0)=0, ft-ddt(f0)=0

f0:=
(for each el in grd0 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd1 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd2 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd3 sum (cc(cctel:=cctel+1)*el))$

equ 1:=fx-ddx(f0);
equ 2:=ft-ddt(f0);

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};

tel:=2;

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;

initialize_equations(equ,tel,{},{cc,cctel,0},{f,0,0});

for i:=1:2 do begin splitvars i;end;

pte tel;

for i:=3:tel do es i;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/integrator.red0000755000175000017500000007007011526203062024440 0ustar  giovannigiovannimodule integrator;


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
% % *****************************************************************
%
% Authors: P. Gragert, P.H.M. Kersten, G.H.M. Roelofs, G.F. Post
% University of Twente (Enschede, The Netherlands)
%
% Version and Date:  Version 1.0, 1992.
%
% Maintainer: Raffaele Vitolo
% Dipartimento di Matematica, Universita' del Salento (Lecce, Italy)
% email: raffaele.vitolo@unisalento.it
% web: http://poincare.unisalento.it/vitolo
% ===============================================================

symbolic$

% write"Integrator package for REDUCE, $Revision: 1.0 $"$terpri()$

put('initialize_equations, 'psopfn, 'initialize_equations1)$



global '(cur_eq_set!*)$
cur_eq_set!*:= 'equ$


fluid '(!*coefficient_check)$
!*coefficient_check:=t$
flag('(coefficient_check), 'switch)$


fluid '(!*polynomial_check)$
!*polynomial_check:=nil$
flag('(polynomial_check), 'switch)$


fluid '(!*allow_differentiation)$
!*allow_differentiation:=nil$
flag('(allow_differentiation), 'switch)$



fluid '(listpri_depth!*)$
listpri_depth!*:=40$


algebraic$


lisp procedure initialize_equations1 specification_list;
   begin scalar operator_name,total_used,variable_list,
	 specification,even_used,odd_used,
      constant_operator,bracketname,function_name,function_list;
      if length specification_list<5 then
	 rederr("INITIALIZE_EQUATIONS: wrong number of parameters");
      if not idp(operator_name:=car specification_list)then
	 rederr("INITIALIZE_EQUATIONS: equations operator must be identifier");
      if not fixp(total_used:=
	 reval car(specification_list:=cdr specification_list))
	    or total_used<0 then
	       rederr("INITIALIZE_EQUATIONS: total number of equations must be positive");
      put(operator_name, 'total_used,total_used);
      variable_list:=reval car(
	 specification_list:=cdr specification_list);
      if atom variable_list or car variable_list neq 'list then
	 rederr("INITIALIZE_EQUATIONS: variable list must be algebraic list");
      put(operator_name, 'variable_list,cdr variable_list);

      specification_list:=cdr specification_list;
      specification:=car specification_list;

      if atom specification or length specification neq 4
	 or car specification neq 'list
	    or not idp(constant_operator:=cadr specification)or
	 not fixp(even_used:=reval caddr specification)or
	 not fixp(odd_used:=reval cadddr specification)
	    or even_used<0 or odd_used<0 then

	       msgpri("INITIALIZE_EQUATIONS: invalid declaration of",
		  specification,nil,nil,t);
      put(operator_name, 'constant_operator,constant_operator);
      if(bracketname:=get(constant_operator, 'bracketname))then
	 put(operator_name, 'bracketname,bracketname);

      if get(constant_operator, 'bracketname)then
	 define_used(bracketname,list('list,even_used,odd_used))
      else
      begin
	 put(constant_operator, 'even_used,even_used);
	 put(constant_operator, 'odd_used,odd_used);
      end;

      for each function_specification in cdr specification_list do
      begin

	 if atom function_specification or length function_specification neq 4
	    or car function_specification neq 'list
	       or not idp(function_name:=cadr function_specification)or
	    not fixp(even_used:=reval caddr function_specification)or
	    not fixp(odd_used:=reval cadddr function_specification)
	       or even_used<0 or odd_used<0 then

		  msgpri("INITIALIZE_EQUATIONS: invalid declaration of",
		     function_specification,nil,nil,t);

	 if get(function_name, 'bracketname)then
	    define_used(bracketname,list('list,even_used,odd_used))
	 else
	 begin
	    put(function_name, 'even_used,even_used);
	    put(function_name, 'odd_used,odd_used);
	 end;
	 function_list:=function_name . function_list;
      end;
      put(operator_name, 'function_list,function_list);
   end$


lisp operator use_equations;
lisp procedure use_equations operator_name;
   begin
      if idp operator_name then
	 cur_eq_set!*:=operator_name
      else rederr("USE_EQUATIONS: argument must be identifier");
   end$


lisp operator integrate_equation;
lisp procedure integrate_equation n;
   begin scalar listpri_depth!*,total_used,equation,denominator,
	 solvable_kernel,solvable_kernels,df_list,function_list,present_functions_list,
      variable_list,absent_variables,
      linear_functions_list,constants_list,bracketname,df_terms,df_functions,
      linear_functions,functions_and_constants_list,commutator_functions,
      present_variables,nr_of_variables,integration_variables;
      listpri_depth!*:=200;
      terpri!* t;

      if null(total_used:=get(cur_eq_set!*, 'total_used))or
	 n>total_used then

	    msgpri("INTEGRATE_EQUATIONS: properly initialize",
	       cur_eq_set!*,nil,nil,t);
      if null(equation:=cadr assoc(list(cur_eq_set!*,n),
	 get(cur_eq_set!*, 'kvalue)))then

	    msgpri("INTEGRATE_EQUATION:",list(cur_eq_set!*,n),
	       "is non-existent",nil,t);
      denominator:=denr(equation:=simp!* equation);
      equation:=numr equation;
      if null equation then
      <> ;

      df_list:=split_form(equation, '(df));
      if try_a_homogeneous_integration(n,denominator,df_list)then goto solved;


      function_list:=get(cur_eq_set!*, 'function_list);
      present_functions_list:=get_recursive_kernels(equation,function_list);
      variable_list:=get(cur_eq_set!*, 'variable_list);
      absent_variables:=variable_list;
      for each function in present_functions_list do
	 for each variable in
	    ((if depl_entry then cdr depl_entry)
	       where depl_entry=assoc(function,depl!*))do
		  absent_variables:=delete(variable,absent_variables);
      if split_equation_polynomially(n,total_used,equation,absent_variables)then
	 goto solved;

      linear_functions_list:=split_form(car df_list,
	 function_list);
      df_list:=cdr df_list;
      constants_list:=split_form(car linear_functions_list,
	 list get(cur_eq_set!*, 'constant_operator));
      linear_functions_list:=cdr linear_functions_list;
      if(bracketname:=get(cur_eq_set!*, 'bracketname))then

	 if length(df_list)=0 and
	 length(linear_functions_list)=0 then
 	 <<
	    if atom(solvable_kernel:=
	       relation_analysis(!*ff2a(equation,denominator),bracketname))
	    then <>
	    else <> ;
	    goto solved
	 >> ;


      df_terms:=for each df_term in df_list join
	 if member(car cadr car df_term,function_list)
	 then list car df_term;
      for each df_term in df_terms do if not member(cadr
	 df_term,df_functions)then df_functions:=cadr(df_term) . df_functions;
      functions_and_constants_list:=append(linear_functions_list,
	 cdr constants_list);
      linear_functions:=for each linear_function in
	 functions_and_constants_list collect car linear_function;
      if bracketname then commutator_functions:=
	 get_recursive_kernels(car constants_list,
	    get(cur_eq_set!*, 'function_list));;

	    present_variables:=variable_list;
	    for each variable in absent_variables do
	       present_variables:=delete(variable,present_variables);
	    nr_of_variables:=length present_variables;
	    for each kernel in linear_functions do if length

	       ((if depl_entry then cdr depl_entry)
		  where depl_entry=assoc(kernel,depl!*))=nr_of_variables then
		     solvable_kernels:=kernel . solvable_kernels;
	    for each kernel in append(df_functions,commutator_functions)do
	       solvable_kernels:=delete(kernel,solvable_kernels);
	    if solvable_kernels then

 	    <>
	       else <>
	    >> ;


	    integration_variables:=present_variables;
	    for each kernel in append(linear_functions,commutator_functions)do
	       for each variable in
		  ((if depl_entry then cdr depl_entry)
		     where depl_entry=assoc(kernel,depl!*))do
			integration_variables:=delete(variable,integration_variables);
	    for each df_function in df_functions do
	       if not (length
		  ((if depl_entry then cdr depl_entry)
		     where depl_entry=assoc(df_function,depl!*))=nr_of_variables) then
			for each variable in
			   ((if depl_entry then cdr depl_entry)
			      where depl_entry=assoc(df_function,depl!*))do
				 integration_variables:=delete(variable,integration_variables);
	    if try_an_inhomogeneous_integration(n,equation,denominator,
	       df_list,df_terms,integration_variables,nr_of_variables)then goto solved;

	    if try_a_differentiation(n,total_used,equation,present_variables,
	       df_terms,linear_functions,commutator_functions)
	    then goto solved;

	    write cur_eq_set!*,"(",n,") not solved";terpri!* t;
   solved:
   end$


lisp procedure successful_message_for(n,action,kernel);
   <> $


lisp procedure not_a_number_message_for(n,action,kernel);
   <> $


lisp procedure try_a_homogeneous_integration(n,denominator,df_list);
   begin scalar solvable_kernel,solvable_kernels,df_kernel;
      return
	 if null car df_list and
	 (cdr df_list)and length(cdr df_list)=1
	 then
	    if(solvable_kernel:=find_solvable_kernel(
	       solvable_kernels:=list(car car cdr df_list),
	       cdr df_list,denominator))then
 	       <>
	    else not_a_number_message_for(n,"Homogeneous integration",
	       car solvable_kernels)
   end$


lisp procedure find_solvable_kernel(kernel_list,kc_list,denominator);
   if !*coefficient_check then
      first_solvable_kernel(kernel_list,kc_list,denominator)
   else car kernel_list$


lisp procedure first_solvable_kernel(kernel_list,kc_list,denominator);
   if kernel_list then
      (if domainp cdr kc_pair or
	 numberp !*ff2a(cdr kc_pair,denominator)
      then car kc_pair
      else first_solvable_kernel(cdr kernel_list,kc_list,denominator))
	 where kc_pair=assoc(car kernel_list,kc_list)$


lisp procedure homogeneous_integration_of df_term;
   begin scalar df_function,function_number,dependency_list,integration_list,
	 coefficient_name,bracketname,even_used,odd_used,
      integration_variable,
      number_of_integrations,solution,new_dependency_list;

      df_function:=cadr df_term;
      if not member(car df_function,get(cur_eq_set!*, 'function_list))
	 or not fixp(function_number:=cadr df_function)
	    or function_number=0 then

	       msgpri("PERFORM_HOMOGENEOUS_INTEGRATION: integration of",
		  df_function,"not allowed",nil,t);
      dependency_list:=
	 ((if depl_entry then cdr depl_entry)
	    where depl_entry=assoc(df_function,depl!*));
      if length dependency_list=1 then
	 coefficient_name:=get(cur_eq_set!*, 'constant_operator)
      else coefficient_name:=car df_function;

      if(bracketname:=get(coefficient_name, 'bracketname))then
      begin even_used:=get(bracketname, 'even_used);
	 odd_used:=get(bracketname, 'odd_used);
      end
      else
      begin
	 even_used:=get(coefficient_name, 'even_used);
	 odd_used:=get(coefficient_name, 'odd_used);
      end;
      integration_list:=cdr cdr df_term;

      if integration_list then integration_variable:=car
	 integration_list else integration_variable:=nil;
      if integration_variable and(integration_list:=cdr integration_list)
	 and fixp car integration_list then
 	 <>
      else number_of_integrations:=1;
      if bracketname then

	 if function_number>0 then
	    (if even_used+number_of_integrations>get(bracketname, 'even_dimension)then
	       change_dimensions_of(bracketname,even_used+number_of_integrations,
		  get(bracketname, 'odd_dimension)))
	 else
	    (if odd_used+number_of_integrations>get(bracketname, 'odd_dimension)then
	       change_dimensions_of(bracketname,get(bracketname, 'even_dimension),
		  odd_used+number_of_integrations));

      solution:=nil ./ 1;
      while integration_variable do
      begin new_dependency_list:=delete(integration_variable,dependency_list);
	 for i:=0:number_of_integrations-1 do
 	 <0 then
		  (even_used:=even_used+1)else-(odd_used:=odd_used+1)),1)));
	    if new_dependency_list then
	       depl!*:=(list(coefficient_name,if function_number>0 then even_used
	       else-odd_used) . new_dependency_list) . depl!*;
	 >> ;

	 if integration_list then integration_variable:=car
	    integration_list else integration_variable:=nil;
	 if integration_variable and(integration_list:=cdr integration_list)
	    and fixp car integration_list then
 	    <>
	 else number_of_integrations:=1


      end;
      solution:=mk!*sq subs2 solution;

      if get(coefficient_name, 'bracketname)then
	 define_used(bracketname,list('list,even_used,odd_used))
      else
      begin
	 put(coefficient_name, 'even_used,even_used);
	 put(coefficient_name, 'odd_used,odd_used);
      end;
      return solution
   end$


lisp procedure split_equation_polynomially(n,total_used,equation,
      absent_variables);
      begin scalar polynomial_variables,equations_list;

	 polynomial_variables:=absent_variables;
	 if !*polynomial_check then
	    polynomial_variables:=for each variable in polynomial_variables join
	       if polynomialp(equation,variable)then list(variable);

	 equations_list:=split_non_linear_form(equation,polynomial_variables);
	 if length equations_list>1 then
 	 <> ;
	 if length equations_list>1 then return t


      end$


lisp procedure polynomialp(expression,kernel);
   if domainp expression then t
   else((main_variable=kernel or not depends(main_variable,kernel))and
      polynomialp(lc expression,kernel)and polynomialp(red expression,kernel))
	 where main_variable=mvar expression$


lisp procedure partial_list(printed_list,nr_of_items);
   'list . broken_list(printed_list,nr_of_items)$

lisp procedure broken_list(list,n);
   if list then if n=0 then '(!.!.!.)
   else car list . broken_list(cdr list,n-1)$


lisp procedure check_differentiation_sequence(sequence,variable_list);
   if null sequence then t
   else if fixp car sequence or
      member(car sequence,variable_list)then
	 check_differentiation_sequence(cdr sequence,variable_list)$


lisp procedure try_an_inhomogeneous_integration(n,equation,denominator,
      df_list,df_terms,integration_variables,nr_of_variables);
      begin scalar solvable_kernel,solvable_kernels,forbidden_functions,
	    df_kernel,inhomogeneous_term;

	 for each df_term in df_terms do
 	 <> ;;

	    return
	       if solvable_kernels then
		  if length(solvable_kernels)=1 then
		     if(solvable_kernel:=find_solvable_kernel(solvable_kernels,df_list,denominator))
		     then
			if(inhomogeneous_term:=linear_solve(mk!*sq(equation ./ 1),solvable_kernel))
			   and(not !*polynomial_check or
			      check_polynomial_integration(solvable_kernel,inhomogeneous_term))
			then
 			<>
			else
 			<>
		     else not_a_number_message_for(n,"Inhomogeneous integration",
			car solvable_kernels)
		  else <>


      end$

lisp procedure check_polynomial_integration(df_term,integration_term);
   begin scalar numerator,denominator,integration_variables,variable,ok;
      numerator:=numr simp integration_term;
      denominator:=denr simp integration_term;
      integration_variables:=
	 for each argument in cdr cdr df_term join
	    if not fixp argument then list argument;
      ok:=t;
      while ok and integration_variables do
      <> ;
      return ok;
   end$


lisp procedure inhomogeneous_integration_of(df_term,inhomogeneous_term);
   begin scalar df_sequence,integration_variables,int_sequence,
	 variable,nr_of_integrations,integration_terms,solution,
      powers,coefficient,int_factor,solution_term,n,k;
      df_sequence:=cdr cdr df_term;

      while df_sequence do
      <>
	 else nr_of_integrations:=1;
	 integration_variables:=variable . integration_variables;
	 int_sequence:=(variable . nr_of_integrations) . int_sequence
      >> ;
      integration_terms:=split_non_linear_form(numr simp inhomogeneous_term,
	 integration_variables);
      integration_terms:=(nil . car integration_terms) .
	 cdr integration_terms;


      solution:=nil ./ 1;
      for each term in integration_terms do
      <> ;
	 solution_term:=multsq(solution_term,coefficient ./ int_factor);
	 solution:=addsq(solution,solution_term)
      >> ;
      solution:=multsq(solution,1 ./ denr simp inhomogeneous_term);
      solution:=mk!*sq subs2 addsq(solution,simp homogeneous_integration_of df_term);
      return solution
   end$


lisp procedure try_a_differentiation(n,total_used,equation,present_variables,
      df_terms,linear_functions,commutator_functions);
      begin scalar differentiations_list,polynomial_order;


	 present_variables:=for each variable in present_variables collect
	    (variable . nil . 0);

	 for each kernel in df_terms do
	    for each variable in
	       ((if depl_entry then cdr depl_entry)
		  where depl_entry=assoc(cadr(kernel),depl!*))do

		     rplacd(entry,kernel . (cddr entry+1))
			where entry=assoc(variable,present_variables);;

			for each kernel in linear_functions do
			   for each variable in
			      ((if depl_entry then cdr depl_entry)
				 where depl_entry=assoc(kernel,depl!*))do

				    rplacd(entry,kernel . (cddr entry+1))
				       where entry=assoc(variable,present_variables);;

				       for each kernel in commutator_functions do
					  for each variable in
					     ((if depl_entry then cdr depl_entry)
						where depl_entry=assoc(kernel,depl!*))do

						   rplacd(entry,nil . (cddr entry+1))
						      where entry=assoc(variable,present_variables);;

						      differentiations_list:=
							 for each entry in present_variables join
							    if cadr entry and cddr entry=1 and
							 (polynomial_order:=get_polynomial_order(
							    linear_solve(mk!*sq(equation ./ 1),cadr entry),car entry))
							    then list(car entry . cadr entry . (polynomial_order+1));
						      return
							 if differentiations_list then
							    if !*allow_differentiation then
 							    <>
							    else <<
							       write"*** ",cur_eq_set!*,"(",n,
								  "): Generation of new equations by differentiation possible.";
							       terpri!* t;write"    Solvable with 'on allow_differentiation'";
							       terpri!* t;t>>


      end$


lisp procedure get_polynomial_order(expression,variable);
   if not depends(denr(expression:=simp expression),variable)and
      (not !*polynomial_check or polynomialp(numr expression,variable))then
      begin scalar kord!*;
	 setkorder list !*a2k variable;
	 expression:=reorder numr expression;
	 return if mvar expression=variable then ldeg expression else 0;
      end$


algebraic procedure integrate_equations(m,n);
   for i:=m:n do integrate_equation(i)$


lisp operator integrate_exceptional_equation;
lisp procedure integrate_exceptional_equation(n);
   integrate_equation(n)
      where
	 !*coefficient_check=nil,
      !*polynomial_check=nil,
      !*allow_differentiation=t$



lisp operator auto_solve;
lisp procedure auto_solve nr_list;
   begin scalar total,old_total,to_do,unsolved,old_unsolved,stuck;
      total:=old_total:=get(cur_eq_set!*, 'total_used);
      to_do:=if fixp nr_list then list nr_list
      else if car nr_list= 'list then cdr nr_list
      else nr_list;
      while not stuck and to_do do begin
	 for each eq_nr in to_do do
 	 <> ;
	 total:=get(cur_eq_set!*, 'total_used);
	 if total=old_total and unsolved and unsolved=old_unsolved then stuck:=t
	 else <>
      end;
      if stuck then return 'list . reverse unsolved
      else <> ;
   end$

lisp operator show_equation;
lisp procedure show_equation n;
   begin scalar equation,total_used,function_list;
      if null(total_used:=get(cur_eq_set!*, 'total_used))or
	 n>total_used then

	    msgpri("SHOW_EQUATION: properly initialize",
	       cur_eq_set!*,nil,nil,t);
      if(equation:=assoc(list(cur_eq_set!*,n),
	 get(cur_eq_set!*, 'kvalue)))then
	 begin
	    equation:=setk(list(cur_eq_set!*,n),aeval cadr equation);
	    varpri(equation,list('setk,mkquote list(cur_eq_set!*,n),
	       mkquote equation), 'only);
	    function_list:=get_recursive_kernels(numr simp equation,
	       get(cur_eq_set!*, 'function_list));
	    if function_list then
 	    <>
	    >>
	    else terpri!* nil
	 end
   end$


algebraic procedure show_equations(m,n);
   for i:=m:n do show_equation i$


lisp operator functions_used,put_functions_used,
   equations_used,put_equations_used;


lisp procedure functions_used function_name;
   list('list,get(function_name, 'even_used),get(function_name, 'odd_used))$


lisp procedure put_functions_used(function_name,even_used,odd_used);
   begin
      if not fixp even_used or even_used<0 or
	 not fixp odd_used or odd_used<0 then

	    msgpri("PUT_FUNCTIONS_USED: used functions number invalid",
	       nil,nil,nil,t);
      put(function_name, 'even_used,even_used);
      put(function_name, 'odd_used,odd_used);
   end$


lisp procedure equations_used;
   get(cur_eq_set!*, 'total_used)$


lisp procedure put_equations_used(n);
   if not fixp n or n<0 then

      msgpri("PUT_EQUATIONS_USED: used equation number invalid",nil,nil,nil,t)
   else put(cur_eq_set!*, 'total_used,n)$


lisp operator df_acts_as_derivation_on;

lisp procedure df_acts_as_derivation_on operator_name;
   begin
      put(operator_name, 'dfform, 'df_as_derivation);
   end$


lisp procedure df_as_derivation(kernel,variable,power);
   begin scalar left_part,right_part,argument,derivative;
      if power neq 1 then

	 msgpri("DF_AS_DERIVATION:",kernel,"must occur linearly",nil,t);
      left_part:=list car kernel;
      right_part:=cdr kernel;
      derivative:=nil . 1;
      while right_part do
      <> ;
      return derivative;
   end$


lisp operator listlength$

lisp procedure listlength l;
   listpri_depth!*:=l$


symbolic procedure listpri l;
   begin
      scalar orig,split,u;
      u:=l;
      l:=cdr l;
      prin2!* get('!*lcbkt!*, 'prtch);
      orig:=orig!*;
      orig!*:=if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split:=treesizep(l,listpri_depth!*);
   a:  maprint(negnumberchk car l,0);
      l:=cdr l;
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b:  prin2!* get('!*rcbkt!*, 'prtch);
      orig!*:=orig;
      return u
   end$

endmodule;
end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/tools21.red0000755000175000017500000006170511526203062023572 0ustar  giovannigiovannimodule tools21;


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
% % *****************************************************************
%
% Authors: P. Gragert, P.H.M. Kersten, G.H.M. Roelofs, G.F. Post
% University of Twente (Enschede, The Netherlands)
%
% Version and Date:  Version 1.0, 1992.
%
% Maintainer: Raffaele Vitolo
% Dipartimento di Matematica, Universita' del Salento (Lecce, Italy)
% email: raffaele.vitolo@unisalento.it
% web: http://poincare.unisalento.it/vitolo
% ===============================================================


symbolic$

%write "Algebraic operator tools for REDUCE, Version 2.1 (August 14, 1996)"$terpri()$


algebraic$

lisp procedure get_first_kernel(form,oplist);
   gfk(form,oplist,nil)$

lisp procedure gfk(form,oplist,l);
   if l or domainp form then l
   else gfk(red form,
      oplist,
      gfk(lc form,
	 oplist,
	 if not atom x and member(car x,oplist) then x else l))
            where x=mvar form$


lisp operator get_kernel;

lisp procedure get_kernel(exprss,oplist);
   gfk(numr simp!* exprss,
      if null oplist then nil
      else if atom oplist then list oplist
      else if car oplist= 'list then cdr oplist
      else oplist,
      nil)$



lisp procedure get_all_kernels(form,oplist);
   gak(form,oplist,nil)$

lisp procedure gak(form,oplist,l);
   if domainp form then l
   else gak(red form,
      oplist,
      gak(lc form,
	 oplist,
	 if not atom x and
	 member(car x,oplist) and
	 not member(x,l) then l:=aconc(l,x)
	 else l))
            where x=mvar form$


lisp operator get_kernels;

lisp procedure get_kernels(exprss,oplist);
   'list . gak(numr simp!* exprss,
      if null oplist
      then nil
      else if atom oplist
      then list oplist
      else if car oplist= 'list
      then cdr oplist
      else oplist,nil)$


lisp procedure get_recursive_kernels(form,oplist);
   grk(form,oplist,nil)$

lisp procedure grk(form,oplist,l);
   if domainp form
   then l else grk(red form,oplist,
      grk(lc form,oplist,

	 if not atom x
	 then begin scalar y;
	    for each arg in cdr x
	       do <> ;
	    return if member(car x,oplist)and not member(x,l)
	    then x . l else l end
	 else l

	    ))
	       where x=mvar form$


lisp operator get_deep_kernels;

lisp procedure get_deep_kernels(exprss,oplist);
   'list . (grk(numr val,
      if null oplist
      then nil
      else if atom oplist
      then list oplist
      else if car oplist= 'list
      then cdr oplist
      else oplist,
      grk(denr val,
	 if null oplist
	 then nil
	 else if atom oplist
	 then list oplist
	 else if car oplist= 'list
	 then cdr oplist
	 else oplist,nil)))
	    where val=simp!* exprss$


lisp procedure tlo(form,l);
   if domainp form then l
   else tlo(red form,
      tlo(lc form,if not atom x and not member(car x,l)
      then car(x) . l else l))
	 where x=mvar form$



put( 'top_level_operators, 'psopfn, 'top_level_operators)$

lisp procedure top_level_operators u;
   'list . union(tlo(numr sq_form,nil),tlo(denr sq_form,nil))
      where sq_form=simp!* car u$


lisp operator write_defs;
lisp procedure write_defs(opr);
   begin for each el in get(opr, 'kvalue)do
      assgnpri(value,list car el, 'only)
	 where value=aeval cadr el
   end$


lisp operator reassign_defs;
lisp procedure reassign_defs(opr);
   begin scalar kvalue_list;
      kvalue_list:=for each el in get(opr, 'kvalue)collect car el;
      for each kernel in kvalue_list do
	 setk(kernel,aeval kernel);
   end$


lisp operator used;
lisp procedure used opkern;
   length get(opkern, 'klist)$

lisp operator known;
lisp procedure known opkern;
   length get(opkern, 'kvalue)$


put( 'clear_op, 'stat, 'rlis)$

lisp procedure clear_op kernel_list;
   for each kernel in kernel_list do
      if atom kernel then
      <>
      else begin scalar op_name,key,entry;
	 op_name:=car kernel;
	 key:=for each i in cdr kernel collect reval i;
	 entry:=na_get(get(op_name, 'na_values),key);
	 if null entry or null cdr entry then
	    msgpri("CLEAR_OP:",kernel,"not found",nil,nil)
	 else rplacd(entry,nil);
      end$



lisp put( 'operator_representation, 'psopfn, 'opr_representation)$
lisp procedure opr_representation l;
   operator_representation(reval car l,reval cadr l,
      if length l>2 then reval caddr l else list( 'list))$

lisp procedure operator_representation(int_opr,even_list,odd_list);
   begin scalar n_even,n_odd;
      if get(int_opr, 'alias_vector)then
	 rederr("OPERATOR_REPRESENTATION: first call CLEAR_OPERATOR_REPRESENTATION");

      even_list:=cdr even_list;
      odd_list:=cdr odd_list;
      if not get(int_opr, 'simpfn)then put(int_opr, 'simpfn, 'simpiden);
      n_even:=0;
      for each el in even_list do
      <> ;
      n_odd:=0;
      for each el in odd_list do
      <> ;
      n_odd:=-n_odd;

      if not get(int_opr, 'prifn)then put(int_opr, 'prifn, 'print_alias);
      put(int_opr, 'alias_vector,n_odd . n_even .
	 list2vector append(reverse odd_list,nil . even_list));
   end$


lisp procedure print_alias l;
   begin scalar i,n_odd,n_even,alias_vector;
      alias_vector:=get(car l, 'alias_vector);
      if alias_vector then <> ;
      if null alias_vector or length l>2 or not fixp(i:=cadr l)or
	 i<-n_odd or i>n_even then

 	 <>


      else maprin getv(alias_vector,i+n_odd)
   end$


lisp operator construct_alias_print;
lisp procedure construct_alias_print(int_opr,even_list,odd_list);
   begin scalar n_even,n_odd;
      even_list:=cdr even_list;odd_list:=cdr odd_list;
      n_even:=length even_list;n_odd:=length odd_list;

      if not get(int_opr, 'prifn)then put(int_opr, 'prifn, 'print_alias);
      put(int_opr, 'alias_vector,n_odd . n_even .
	 list2vector append(reverse odd_list,nil . even_list));
   end$


lisp put( 'add_to_operator_representation, 'psopfn, 'add_to_opr_representation)$

lisp procedure add_to_opr_representation l;
   add_to_operator_representation(reval car l,reval cadr l,
      if length l>2 then reval caddr l else list( 'list))$

lisp procedure add_to_operator_representation(int_opr,even_list,odd_list);
   begin scalar n_even,n_odd,old_list,alias_vector;
      if not get(int_opr, 'alias_vector)
      then rederr("ADD_TO_OPERATOR_REPRESENTATION: first call OPERATOR_REPRESENTATION");
      alias_vector:=get(int_opr, 'alias_vector);
      n_even:=cadr alias_vector;
      n_odd:=-car alias_vector;
      alias_vector:=cddr alias_vector;
      old_list:=for i:=0:upbv alias_vector
	 collect getv(alias_vector,i);

      even_list:=cdr even_list;
      odd_list:=cdr odd_list;
      for each el in even_list
	 do <> ;
      for each el in odd_list
	 do <> ;
      n_odd:=-n_odd;

      put(int_opr, 'alias_vector,n_odd . n_even .
	 list2vector append(reverse odd_list,append(old_list,even_list)));
   end$


lisp operator clear_operator_representation;
lisp procedure clear_operator_representation int_opr;
   begin scalar alias_vector,n_odd,n_even,kernel;
      if(alias_vector:=get(int_opr, 'alias_vector))then
      <> ;
	 clear_alias_print int_opr>>
   end$

lisp operator clear_alias_print;
lisp procedure clear_alias_print int_opr;
   begin
      remprop(int_opr, 'prifn);
      remprop(int_opr, 'alias_vector)
   end$


lisp procedure split_f(form,oplist,fact,kc_list);
   if null form then kc_list
   else if domainp form then
      addf(multf(fact,form),
	 car kc_list) . cdr kc_list
   else if not atom mvar form and member(car mvar form,oplist)then
      if ldeg form neq 1 or get_first_kernel(lc form,oplist)then

	 msgpri("SPLIT_F: expression not linear w.r.t.",
 	    'list . oplist,nil,nil,t)
      else split_f(red form,oplist,fact,
	 update_kc_list(kc_list,mvar form,multf(fact,lc form)))
   else split_f(red form,oplist,fact,
      split_f(lc form,oplist,
	 multf(fact,!*p2f lpow form),kc_list))$


lisp procedure split_form(form,oplist);
   split_f(form,oplist,1,nil . nil)$

lisp procedure list_assoc(car_exprn,a_list);
   if null a_list then a_list else if caar a_list=car_exprn then a_list
   else list_assoc(car_exprn,cdr a_list)$

lisp procedure update_kc_list(kc_list,kernel,coefficient);
   (if rest_list then <> else
	 car kc_list . (kernel . coefficient) . cdr kc_list)
	    where rest_list=list_assoc(kernel,cdr kc_list)$


put( 'operator_coeff, 'psopfn, 'operator_coeff_1)$

lisp procedure operator_coeff_1 u;
   if length u neq 2 then rederr("OPERATOR_COEFF: wrong number of arguments")
   else operator_coeff(car u,reval cadr u)$


lisp procedure operator_coeff(exprn,oplist);
   begin scalar numr_ex,denr_ex,kc_list;
      oplist:=
	 if null oplist
	 then nil
	 else if atom oplist
	 then list oplist
	 else if car oplist= 'list
	 then cdr oplist
	 else oplist;
      exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
      if gfk(denr_ex,oplist,nil)
      then rederr("OPERATOR_COEFF: denominator not independent of operator(s)");
      kc_list:=split_form(numr_ex,oplist);
      return 'list . !*ff2a(car kc_list,denr_ex) .
	 for each kc_pair in cdr kc_list collect
	    list( 'list,car kc_pair,!*ff2a(cdr kc_pair,denr_ex));
   end$


lisp procedure dump_operators(form,oplist,fact);
   if null form then nil
   else if domainp form then multf(fact,form)
   else if not atom mvar form and member(car mvar form,oplist)then
      dump_operators(red form,oplist,fact)
   else
      addf(dump_operators(red form,oplist,fact),
	 dump_operators(lc form,oplist,multf(fact,!*p2f lpow form)))$


put( 'independent_part, 'psopfn, 'independent_part_1)$

lisp procedure independent_part_1 u;
   if length u neq 2 then rederr("INDEPENDENT_PART: wrong number of arguments")
   else independent_part(car u,reval cadr u)$

lisp procedure independent_part(exprn,oplist);
   begin scalar numr_ex,denr_ex;
      oplist:=
	 if null oplist
	 then nil
	 else if atom oplist
	 then list oplist
	 else if car oplist= 'list
	 then cdr oplist
	 else oplist;
      exprn:=simp!* exprn;numr_ex:=numr exprn;denr_ex:=denr exprn;
      if gfk(denr_ex,oplist,nil)
      then rederr("INDEPENDENT_PART: denominator not independent");
      return !*ff2a(dump_operators(numr_ex,oplist,1),denr_ex);
   end$


lisp procedure split_non_linear_f(form,var_list,multi_power,fact,pc_list);
   if null form
   then pc_list
   else if domainp form
   then if multi_power
   then update_kc_list(pc_list,multi_power,multf(fact,form))
   else addf(multf(fact,form),car pc_list) . cdr pc_list
   else split_non_linear_f(red form,var_list,multi_power,fact,
      if(not atom mvar form and member(car mvar form,var_list))
	 or member(mvar form,var_list)
      then split_non_linear_f(lc form,var_list,
	 append(multi_power,list lpow form),fact,pc_list)
      else split_non_linear_f(lc form,var_list,multi_power,
	 multf(fact,!*p2f lpow form),pc_list))$


lisp procedure split_non_linear_form(form,kernel_list);
   split_non_linear_f(form,kernel_list,nil,1,nil . nil)$


put( 'multi_coeff, 'psopfn, 'multi_coeff_1)$

lisp procedure multi_coeff_1 u;
   if length u neq 2 then rederr("MULTI_COEFF: wrong number of arguments")
   else multi_coeff(car u,reval cadr u)$

lisp procedure multi_coeff(exprn,kernel_list);
   begin scalar numr_ex,denr_ex,pc_list;
      kernel_list:=
	 if null kernel_list
	 then nil
	 else if atom kernel_list
	 then list kernel_list
	 else if car kernel_list= 'list
	 then cdr kernel_list
	 else kernel_list;
      exprn:=simp!* exprn;
      numr_ex:=numr exprn;denr_ex:=denr exprn;
      for each generator in kernel_list do if depends(denr_ex,generator)
      then
	 msgpri("MULTI_COEFF: expression is not polynomial w.r.t. ",
 	    'list . kernel_list,nil,nil,t);
      pc_list:=split_non_linear_form(numr_ex,kernel_list);
      return 'list . !*ff2a(car pc_list,denr_ex) .
	 for each pc_pair in cdr pc_list collect
	    list( 'list,convert_multi_power car pc_pair,!*ff2a(cdr pc_pair,denr_ex));
   end$


lisp procedure convert_multi_power multi_power;
   'times . for each power in multi_power collect
      if cdr power=1 then car power else list( 'expt,car power,cdr power)$


lisp procedure split_arguments(arg_list,oplist,splitted_list);
   if null arg_list then splitted_list
   else split_arguments(cdr arg_list,oplist,
      multf(denr first_arg,car splitted_list) .
	 split_form(numr first_arg,oplist) .
	    cdr splitted_list)where first_arg=simp!* car arg_list$

lisp procedure split_non_linear_arguments(arg_list,oplist,splitted_list);
   if null arg_list then splitted_list
   else split_non_linear_arguments(cdr arg_list,oplist,
      multf(denr first_arg,car splitted_list) .
	 split_non_linear_form(numr first_arg,oplist) .
	    cdr splitted_list)where first_arg=simp!* car arg_list$



lisp procedure split_operator u;
   split_arguments(cdr u,get(car u, 'oplist),1 . nil)$

lisp procedure split_non_linear_operator u;
   split_non_linear_arguments(cdr u,get(car u, 'oplist),1 . nil)$



lisp procedure process_arg_stack(arg_stack,op_name,arg_list,fact);
   if null arg_stack then multsq(!*f2q fact,
      apply1(get(op_name, 'resimp_fn),op_name . arg_list))
   else process_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$

lisp procedure process_non_linear_arg_stack(arg_stack,op_name,arg_list,fact);
   if null arg_stack
   then multsq(!*f2q fact,apply1(get(op_name, 'resimp_fn),
      op_name . for each power_set in arg_list
	 collect if power_set=1
	 then power_set
	 else convert_multi_power power_set))
   else process_non_linear_comp_list(car arg_stack,cdr arg_stack,op_name,arg_list,fact)$


lisp procedure process_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
   addsq(process_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
      process_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$

lisp procedure process_non_linear_comp_list(comp_list,arg_stack,op_name,arg_list,fact);
   addsq(process_non_linear_independent_part(car comp_list,arg_stack,op_name,arg_list,fact),
      process_non_linear_components(cdr comp_list,arg_stack,op_name,arg_list,fact))$

lisp procedure process_independent_part(independent_part,arg_stack,
      op_name,arg_list,fact);
   if null independent_part then nil . 1
   else
      process_arg_stack(arg_stack,op_name,1 . arg_list,multf(fact,independent_part))$

lisp procedure process_non_linear_independent_part(independent_part,arg_stack,
      op_name,arg_list,fact);
   if null independent_part then nil . 1
   else
      process_non_linear_arg_stack(arg_stack,op_name,1 . arg_list,multf(fact,independent_part))$



lisp procedure process_components(comp_list,arg_stack,op_name,arg_list,fact);
   if null comp_list then nil . 1
   else
      addsq(process_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
	 process_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
	    multf(fact,cdar comp_list)))$

lisp procedure process_non_linear_components(comp_list,arg_stack,op_name,arg_list,fact);
   if null comp_list then nil . 1
   else
      addsq(process_non_linear_components(cdr comp_list,arg_stack,op_name,arg_list,fact),
	 process_non_linear_arg_stack(arg_stack,op_name,caar comp_list . arg_list,
	    multf(fact,cdar comp_list)))$



lisp procedure build_sum(op_name,arg_stack);
   process_arg_stack(arg_stack,op_name,nil,1)$

lisp procedure build_non_linear_sum(op_name,arg_stack);
   process_non_linear_arg_stack(arg_stack,op_name,nil,1)$


lisp procedure simp_multilinear u;
   quotsq(build_sum(car u,cdr splitted_list),!*f2q car splitted_list)
      where splitted_list=split_operator u$

lisp procedure simp_multimorph u;
   quotsq(build_non_linear_sum(car u,cdr splitted_list),!*f2q car splitted_list)
      where splitted_list=split_non_linear_operator u$



put( 'multilinear, 'stat, 'rlis)$

put( 'multimorph, 'stat, 'rlis)$

lisp procedure multilinear u;
   for each decl in u do
   begin scalar op_name,resimp_fn;
      if length decl neq 2 and length decl neq 3 then

	 msgpri(nil,decl,"invalid multilinear declaration",nil,t);
      if not idp(op_name:=car decl)then

	 msgpri(nil,op_name,"invalid as operator",nil,t);
      put(op_name, 'oplist,
	 if null cadr decl
	 then nil
	 else if atom cadr decl
	 then list cadr decl
	 else if car cadr decl= 'list
	 then cdr cadr decl
	 else cadr decl);
      if(length decl=3 and(resimp_fn:=caddr decl))or
	 (resimp_fn:=get(op_name, 'resimp_fn))or
	 (resimp_fn:=get(op_name, 'simpfn))then put(op_name, 'resimp_fn,resimp_fn)
      else put(op_name, 'resimp_fn, 'simpiden);
      put(op_name, 'simpfn, 'simp_multilinear);
      flag(list(op_name), 'full);
   end$


lisp procedure multimorph u;
   for each decl in u do
   begin scalar op_name,resimp_fn;
      if length decl neq 2 and length decl neq 3 then

	 msgpri(nil,decl,"invalid multimorph declaration",nil,t);
      if not idp(op_name:=car decl)then

	 msgpri(nil,op_name,"invalid as operator",nil,t);
      put(op_name, 'oplist,
	 if null cadr decl
	 then nil
	 else if atom cadr decl
	 then list cadr decl
	 else if car cadr decl= 'list
	 then cdr cadr decl
	 else cadr decl);
      if(length decl=3 and(resimp_fn:=caddr decl))or
	 (resimp_fn:=get(op_name, 'resimp_fn))or
	 (resimp_fn:=get(op_name, 'simpfn))then put(op_name, 'resimp_fn,resimp_fn)
      else put(op_name, 'resimp_fn, 'simpiden);
      put(op_name, 'simpfn, 'simp_multimorph);
      flag(list(op_name), 'full);
   end$


put( 'linear_solve, 'psopfn, 'linear_solve_1)$

lisp procedure linear_solve_1 u;
   if length u neq 2 then
      rederr("LINEAR_SOLVE: wrong number of arguments")
   else linear_solve(car u,!*a2k cadr u)$


lisp procedure linear_solve(exprn,kernel);
   begin scalar kord!*,form;

      exprn:=fctrf numr simp!* exprn;
      exprn:=if domainp car exprn then cdr exprn else(car exprn . 1) . cdr exprn;
      form:=for each factor in exprn join
	 if depends(factor,kernel)then list factor;
      if length form=1 then form:=numr car form else

	 msgpri("LINEAR_SOLVE: expression not linear with respect to",
	    kernel,nil,nil,t);
      setkorder list kernel;
      form:=reorder form;
      if(mvar form=kernel)and(ldeg form=1)and
	 not depends(lc form,kernel)and not depends(red form,kernel)then
	    return !*ff2a(negf red form,lc form)
      else
	 msgpri("LINEAR_SOLVE: expression not linear with respect to",
	    kernel,nil,nil,t);
   end$


put( 'linear_solve_and_assign, 'psopfn, 'linear_solve_and_assign_1)$

lisp procedure linear_solve_and_assign_1 u;
   if length u neq 2 then
      rederr("LINEAR_SOLVE_AND_ASSIGN: wrong number of arguments")
   else linear_solve_and_assign(car u,cadr u)$

lisp procedure linear_solve_and_assign(exprn,kernel);
   setk(krnl,linear_solve(exprn,krnl))
      where krnl=!*a2k kernel$



put( 'solvable_kernels, 'psopfn, 'solvable_kernels_1)$

lisp procedure solvable_kernels_1 u;
   if length u neq 3 then
      rederr("SOLVABLE_KERNELS: wrong number of arguments")
   else solvable_kernels(car u,cadr u,caddr u)$


lisp procedure list_merge(element,merge_list);
   if member(element,merge_list)then merge_list else element .
      merge_list$

lisp procedure mk_kernel_list(form,k_oplist,c_oplist,forbidden,kernel_list);
   if domainp form then kernel_list
   else(
      if not atom kernel then
	 mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
	    mk_kernel_list(lc form,k_oplist,c_oplist,
	       if member(car kernel,c_oplist)then t else forbidden,
	       if member(car kernel,k_oplist)then
		  if not forbidden and ldeg form=1 and
	       not get_first_kernel(lc form,c_oplist)then
		  list_merge(kernel,car kernel_list) . cdr kernel_list
		  else
		     car kernel_list . list_merge(kernel,cdr kernel_list)
	       else kernel_list))
      else mk_kernel_list(red form,k_oplist,c_oplist,forbidden,
	 mk_kernel_list(lc form,k_oplist,c_oplist,forbidden,kernel_list))
	    )where kernel=mvar form$


lisp procedure solvable_kernels(exprn,k_oplist,c_oplist);
   begin scalar form,kernel_list,forbidden_kernels;
      form:=numr simp!* exprn;
      k_oplist:=
	 if null k_oplist
	 then nil
	 else if atom k_oplist
	 then list k_oplist
	 else if car k_oplist= 'list
	 then cdr k_oplist
	 else k_oplist;
      c_oplist:=
	 if null c_oplist
	 then nil
	 else if atom c_oplist
	 then list c_oplist
	 else if car c_oplist= 'list
	 then cdr c_oplist
	 else c_oplist;
      kernel_list:=mk_kernel_list(form,k_oplist,c_oplist,nil,nil . nil);
      forbidden_kernels:=cdr kernel_list;
      kernel_list:=car kernel_list;
      for each kernel in forbidden_kernels do kernel_list:=delete(kernel,kernel_list);
      return 'list . kernel_list;
   end$



lisp procedure na_get(na_list,key);
   if na_list then
      if null key then car na_list
      else(if na_assoc then na_get(cdr na_assoc,cdr key))
	 where na_assoc=assoc(car key,cdr na_list)$

lisp procedure na_put(na_list,key,value);
   if null key then car rplaca(na_list,value)
   else(if na_assoc then na_put(cdr na_assoc,cdr key,value)
   else na_put(cdadr rplacd(na_list,list(car key,nil) . cdr na_list),
      cdr key,value))
	 where na_assoc=assoc(car key,cdr na_list)$


put( 'na_operator, 'stat, 'rlis)$

lisp procedure na_operator u;
   for each decl in u do
   begin
      if not atom decl then
	 msgpri(nil,decl,"invalid na_operator declaration",nil,t);
      put(decl, 'na_values,list(nil));
      put(decl, 'simpfn, 'simp_na_op);
      put(decl, 'setkfn, 'setk_na_op);
      put(decl, 'mksqsubfn, 'mksqsub_na_op);
      put(decl, 'fkernfn, 'fkern_na_op);
      put(decl, 'clearfn, 'clear_na_op);
      put(decl, 'prepsq!*fn, 'prepsq!*_get_kernels);
      flag(list(decl), 'full);
   end$


fluid '(!_na_krnl_);

lisp procedure simp_na_op kernel;
   begin scalar op_name,key,entry;
      op_name:=car kernel;
      key:=for each i in cdr kernel collect reval i;
      return
	 if(entry:=na_get(get(op_name, 'na_values),key))and cdr entry
	 then simp cdr entry
	 else(mksq(op_name . key,1)where !_na_krnl_=list entry);
   end$


lisp procedure setk_na_op(kernel,value);
   begin scalar op_name,key,entry;
      op_name:=car kernel;key:=cdr kernel;
      return
	 if(entry:=na_get(get(op_name, 'na_values),key))then
	    cdr rplacd(entry,value)
	 else cdr na_put(get(op_name, 'na_values),key,
	    list(op_name . key,nil) . value);
   end$


lisp procedure mksqsub_na_op kernel;
   if !_na_krnl_ then
      (car !_na_krnl_ and cdar !_na_krnl_ and list(kernel,cdar !_na_krnl_))
   else
   begin scalar op_name,key,entry;
      op_name:=car kernel;key:=cdr kernel;
      if(entry:=na_get(get(op_name, 'na_values),key))and cdr entry then
	 return list(kernel,cdr entry);
   end$


lisp procedure fkern_na_op kernel;
   begin scalar op_name,key,entry;
      op_name:=car kernel;key:=cdr kernel;
      return
	 if(entry:=if !_na_krnl_ then car !_na_krnl_
	 else na_get(get(op_name, 'na_values),key))then
	    if car entry then car entry
	    else car rplaca(entry,list(kernel,nil))
	 else car na_put(get(op_name, 'na_values),key,list(kernel,nil) . nil);
   end$


lisp procedure prepsq!*_get_kernels(u,op_name);
   ordn get_all_kernels(numr u,op_name)$



endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/cdiff.rlg0000755000175000017500000002547411527635055023373 0ustar  giovannigiovanniFri Feb 18 21:29:01 2011 run on win32
% Raffaele Vitolo, 09/10/09
% This is the computation for (higher) symmetries of Burgers

% The following instructions initialize the total derivatives. The first
% string is the name of the vector field,
% the second item is the list of even variables
% (note that u1, u2, ... are u_x, u_xx, ...),
% the third item is the list of non-commuting variables
% (`ext' stands for `external' like in external (wedge) product).

super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


{20,80}


super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});


{20,80}



% Specification of the vectorfield ddx.
% The meaning of the first index is the parity of variables.
% In particular here we have just even variables.
% The second index parametrizes the second item (list)
% in the super_vectorfield declaration.

ddx(0,1):=1$


ddx(0,2):=0$


ddx(0,3):=u1$


ddx(0,4):=u2$


ddx(0,5):=u3$


ddx(0,6):=u4$


ddx(0,7):=u5$


ddx(0,8):=u6$


ddx(0,9):=u7$


ddx(0,10):=u8$


ddx(0,11):=u9$


ddx(0,12):=u10$


ddx(0,13):=u11$


ddx(0,14):=u12$


ddx(0,15):=u13$


ddx(0,16):=u14$


ddx(0,17):=u15$


ddx(0,18):=u16$


ddx(0,19):=u17$


ddx(0,20):=letop$



% Specification of the vectorfield ddt
% In the evolutionary case we never have more than one time derivative
% other derivatives are u_txxx ...

ddt(0,1):=0$


ddt(0,2):=1$


ddt(0,3):=ut$


ddt(0,4):=ut1$


ddt(0,5):=ut2$


ddt(0,6):=ut3$


ddt(0,7):=ut4$


ddt(0,8):=ut5$


ddt(0,9):=ut6$


ddt(0,10):=ut7$


ddt(0,11):=ut8$


ddt(0,12):=ut9$


ddt(0,13):=ut10$


ddt(0,14):=ut11$


ddt(0,15):=ut12$


ddt(0,16):=ut13$


ddt(0,17):=ut14$


ddt(0,18):=letop$


ddt(0,19):=letop$


ddt(0,20):=letop$



% The equation -- this is also used to specify internal variables.
% For evolutionary equations internal variables are of the type
% (t,x,u,u_x,u_xx,...)

ut:=u2+2*u*u1;


ut := 2*u*u1 + u2


ut1:=ddx ut;


                    2
ut1 := 2*u*u2 + 2*u1  + u3

ut2:=ddx ut1;


ut2 := 2*u*u3 + 6*u1*u2 + u4

ut3:=ddx ut2;


                              2
ut3 := 2*u*u4 + 8*u1*u3 + 6*u2  + u5

ut4:=ddx ut3;


ut4 := 2*u*u5 + 10*u1*u4 + 20*u2*u3 + u6

ut5:=ddx ut4;


                                           2
ut5 := 2*u*u6 + 12*u1*u5 + 30*u2*u4 + 20*u3  + u7

ut6:=ddx ut5;


ut6 := 2*u*u7 + 14*u1*u6 + 42*u2*u5 + 70*u3*u4 + u8

ut7:=ddx ut6;


                                                       2
ut7 := 2*u*u8 + 16*u1*u7 + 56*u2*u6 + 112*u3*u5 + 70*u4  + u9

ut8:=ddx ut7;


ut8 := 2*u*u9 + 18*u1*u8 + u10 + 72*u2*u7 + 168*u3*u6 + 252*u4*u5

ut9:=ddx ut8;


                                                                           2
ut9 := 2*u*u10 + 20*u1*u9 + u11 + 90*u2*u8 + 240*u3*u7 + 420*u4*u6 + 252*u5

ut10:=ddx ut9;


ut10 := 

2*u*u11 + 22*u1*u10 + u12 + 110*u2*u9 + 330*u3*u8 + 660*u4*u7 + 924*u5*u6

ut11:=ddx ut10;


ut11 := 2*u*u12 + 24*u1*u11 + 132*u10*u2 + u13 + 440*u3*u9 + 990*u4*u8

                              2
         + 1584*u5*u7 + 924*u6

ut12:=ddx ut11;


ut12 := 2*u*u13 + 26*u1*u12 + 572*u10*u3 + 156*u11*u2 + u14 + 1430*u4*u9

         + 2574*u5*u8 + 3432*u6*u7

ut13:=ddx ut12;


ut13 := 2*u*u14 + 28*u1*u13 + 2002*u10*u4 + 728*u11*u3 + 182*u12*u2 + u15

                                            2
         + 4004*u5*u9 + 6006*u6*u8 + 3432*u7

ut14:=ddx ut13;


ut14 := 2*u*u15 + 30*u1*u14 + 6006*u10*u5 + 2730*u11*u4 + 910*u12*u3

         + 210*u13*u2 + u16 + 10010*u6*u9 + 12870*u7*u8


% Test for verifying the commutation of total derivatives.
% Highest order defined terms yield some `letop'
% which means `careful' in Dutch and is treated as a new variable.

for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));


*** ev declared operator 

ev(0,1) := 0

ev(0,2) := 0

ev(0,3) := 0

ev(0,4) := 0

ev(0,5) := 0

ev(0,6) := 0

ev(0,7) := 0

ev(0,8) := 0

ev(0,9) := 0

ev(0,10) := 0

ev(0,11) := 0

ev(0,12) := 0

ev(0,13) := 0

ev(0,14) := 0

ev(0,15) := 0

ev(0,16) := 0

ev(0,17) := letop - 2*u*u16 - 32*u1*u15 - 16016*u10*u6 - 8736*u11*u5

             - 3640*u12*u4 - 1120*u13*u3 - 240*u14*u2 - u17 - 22880*u7*u9

                       2
             - 12870*u8


pause;



%% This is the list of variables with respect to their grading,
%% starting from degree ONE.

graadlijst:={{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};


graadlijst := {{u},

               {u1},

               {u2},

               {u3},

               {u4},

               {u5},

               {u6},

               {u7},

               {u8},

               {u9},

               {u10},

               {u11},

               {u12},

               {u13},

               {u14},

               {u15},

               {u16},

               {u17}}


% This is the list of all monomials of degree 0, 1, 2, ... 
% which can be constructed from the above list of elementary variables 
% with their grading.

grd0:={1};


grd0 := {1}

grd1:= mkvarlist1(1,1)$


grd2:= mkvarlist1(2,2)$


grd3:= mkvarlist1(3,3)$


grd4:= mkvarlist1(4,4)$


grd5:= mkvarlist1(5,5)$


grd6:= mkvarlist1(6,6)$


grd7:= mkvarlist1(7,7)$


grd8:= mkvarlist1(8,8)$


grd9:= mkvarlist1(9,9)$


grd10:= mkvarlist1(10,10)$


grd11:= mkvarlist1(11,11)$


grd12:= mkvarlist1(12,12)$


grd13:= mkvarlist1(13,13)$


grd14:= mkvarlist1(14,14)$


grd15:= mkvarlist1(15,15)$


grd16:= mkvarlist1(16,16)$



% Initialize a counter for the vector of arbitrary constants

ctel:=0;


ctel := 0


% we assume a generating function of degree <= 5

sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$


*** c declared operator 


% This is the equation ell_B(sym)=0, where B=0 is Burgers'equation
% and sym is the generating function. From now on all equations
% are arranged in a single vector whose name is `equ'.

equ 1:=ddt(sym)-ddx(ddx(sym))-2*u*ddx(sym)-2*u1*sym ;


*** equ declared operator 

                                                                            2
equ(1) := 2*(4*c(19)*u1*u4 + 10*c(19)*u2*u3 + 3*c(18)*u*u1*u3 + 3*c(18)*u*u2

                                        2                             2
              - c(18)*u1*u4 + 3*c(17)*u1 *u2 - c(17)*u2*u3 + 2*c(16)*u *u1*u2

                                          2                3             2
              - 2*c(16)*u*u1*u3 - c(16)*u1 *u2 + c(15)*u*u1  - c(15)*u*u2

                          2               2                     3          5
              - 2*c(15)*u1 *u2 - 3*c(14)*u *u1*u2 - 3*c(14)*u*u1  - c(13)*u *u1

                          3   2                             2
              - 10*c(13)*u *u1  + 3*c(12)*u1*u3 + 3*c(12)*u2  + 2*c(11)*u*u1*u2

                                      3           2                           3
              - c(11)*u1*u3 + c(10)*u1  - c(10)*u2  - 2*c(9)*u*u1*u2 - c(9)*u1

                      4              2   2
              - c(8)*u *u1 - 6*c(8)*u *u1  + 2*c(7)*u1*u2 - c(6)*u1*u2

                      3                 2         2             2
              - c(5)*u *u1 - 3*c(5)*u*u1  - c(3)*u *u1 - c(3)*u1  - c(2)*u*u1

              - c(1)*u1)


% This is the list of variables, to be passed to the equation solver.

vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};


vars := {x,

         t,

         u,

         u1,

         u2,

         u3,

         u4,

         u5,

         u6,

         u7,

         u8,

         u9,

         u10,

         u11,

         u12,

         u13,

         u14,

         u15,

         u16,

         u17}


% This is the number of initial equation(s)

tel:=1;


tel := 1


% The following procedure uses multi_coeff (from the package `tools').
% It gets all coefficients of monomials appearing in the initial equation(s).
% The coefficients are put into the vector equ after the initial equations.

procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;


splitvars


% This command initialize the equation solver.
% It passes the equation(s) togeher with their number `tel',
% the constants'vector `c', its length `ctel',
% an arbitrary constant `f' that may appear in computations.

initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});



% Run the procedure splitvars in order to obtain equations on coefficiens
% of each monomial.

splitvars 1;



% Next command tells the solver the total number of equations obtained
% after running splitvars.

pte tel;


24


% It is worth to write down the equations for the coefficients.

for i:=2:tel do write equ i;


0

 - 2*c(1)

 - 2*c(2)

 - 2*c(3)

 - 2*c(3)

 - 6*c(5)

 - 2*c(5)

2*(2*c(7) - c(6))

 - 12*c(8)

 - 2*c(8)

2*(c(10) - c(9))

4*(c(11) - c(9))

2*(3*c(12) - c(10))

2*(3*c(12) - c(11))

 - 20*c(13)

 - 2*c(13)

2*(c(15) - 3*c(14))

2*(2*c(16) - 3*c(14))

2*(3*c(17) - c(16) - 2*c(15))

2*(3*c(18) - c(15))

2*(3*c(18) - 2*c(16))

2*(10*c(19) - c(17))

2*(4*c(19) - c(18))


pause;



% This command solves the equations for the coefficients.
% Note that we have to skip the initial equations!

for i:=2:te do es i;


equ(2) = 0

equ(3): Solved for c(1)

equ(4): Solved for c(2)

equ(5): Solved for c(3)

equ(6) = 0

equ(7): Solved for c(5)

equ(8) = 0

equ(9): Solved for c(7)

equ(10): Solved for c(8)

equ(11) = 0

equ(12): Solved for c(10)

equ(13): Solved for c(11)

equ(14): Solved for c(12)

equ(15) = 0

equ(16): Solved for c(13)

equ(17) = 0

equ(18): Solved for c(15)

equ(19): Solved for c(16)

equ(20): Solved for c(17)

equ(21): Solved for c(18)

equ(22) = 0

equ(23): Solved for c(19)

equ(24) = 0


;

end;


Time for test: 31 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 0 19 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/cdiff/cdiff-userguide.tex0000755000175000017500000015533511526203062025365 0ustar  giovannigiovanni\documentclass[12pt]{amsart}
\usepackage{xspace}
\usepackage{amssymb}
\usepackage{amsthm}
\usepackage{color}
\usepackage{mathrsfs}
\usepackage{microtype}
\usepackage{upref}
\usepackage{url}
\usepackage{graphicx}
\usepackage[dvips,%
pdftitle={},%
pdfauthor={R. Vitolo},%
pdfkeywords={}%
pdfsubject={},%
colorlinks,linkcolor={blue},citecolor={blue},urlcolor={red}%
]{hyperref}

% LENGTHS

\setlength{\hfuzz}{3pt}
%\addtolength{\arraycolsep}{5pt}
%\smartqed
%-----------------------------------------------------------------------------%
% PAGE SIZES
%-----------------------------------------------------------------------------%
\setlength{\headheight}{32pt}
\setlength{\headsep}{29pt}
\setlength{\footskip}{28pt}
\setlength{\textwidth}{444pt}
\setlength{\textheight}{636pt}
\setlength{\marginparsep}{7pt}
\setlength{\marginparpush}{7pt}
\setlength{\oddsidemargin}{4.5pt}
\setlength{\marginparwidth}{55pt}
\setlength{\evensidemargin}{4.5pt}
\setlength{\topmargin}{-15pt}
\setlength{\footnotesep}{8.4pt}
\allowdisplaybreaks[4]

% CLAIMS

\swapnumbers
\newtheorem{theorem}{Theorem}
\newtheorem{corollary}[theorem]{Corollary}
\newtheorem{lemma}[theorem]{Lemma}
\newtheorem{proposition}[theorem]{Proposition}
\theoremstyle{definition}
\newtheorem{remark}[theorem]{Remark}
\newtheorem{definition}[theorem]{Definition}
\newtheorem{example}[theorem]{Example}

% MACROS

\newcommand{\cprime}{\/{\mathsurround=0pt$'$}}

\newcommand*{\pd}[2]{\mathchoice{\frac{\partial#1}{\partial#2}}
  {\partial#1/\partial#2}{\partial#1/\partial#2}
  {\partial#1/\partial#2}}
\newcommand*{\od}[2]{\mathchoice{\frac{d#1}{d#2}}
  {d#1/d#2}{d#1/d#2}{d#1/d#2}}
\newcommand*{\fd}[2]{\mathchoice{\frac{\delta#1}{\delta#2}}
  {\delta #1/\delta#2}{\delta#1/\delta#2}{\delta#1/\delta#2}}

%    Notation for an expression evaluated at a particular condition.
%    The optional argument can be used to override automatic sizing
%    of the right vert bar, e.g. \eval[\biggr]{...}_{...}
\newcommand{\eval}[2][\right]{\relax
  \ifx#1\right\relax \left.\fi#2#1\rvert}

%    Enclose the argument in vert-bar delimiters.
%    The optional argument can be used to override automatic sizing,
%    e.g. \abs[\bigg]{...}
\newcommand{\envert}[2][\right]{\relax
  \ifx#1\right\relax \left\lvert\else#1\lvert\fi#2#1\rvert}
\let\abs=\envert

%    Enclose the argument in double-vert-bar delimiters:
%    The optional argument can be used to override automatic sizing,
%    e.g. \norm[\bigg]{...}
\newcommand{\enVert}[2][\right]{\relax
  \ifx#1\right\relax \left\lVert\else#1\lVert\fi#2#1\rVert}
\let\matr=\enVert

\newcommand*{\sdim}[2]{#1\vert#2}
\newcommand{\doubell}{\mathcal{L}}

\let\kappa\varkappa
\let\phi\varphi

\newcommand{\hj}{\bar{\jmath}}
\newcommand{\hd}{\bar{d}}
\newcommand{\J}{\bar{\mathcal{J}}}
\newcommand{\Ji}{{\bar{\mathcal{J}}}^{\infty}}
\newcommand{\hL}{\bar{\Lambda}}
\newcommand{\cC}{\mathcal{C}}
\newcommand{\cE}{\mathcal{E}}
\newcommand{\cL}{\mathcal{L}}
\newcommand{\cJ}{\mathcal{J}}
\newcommand{\g}{\mathfrak{g}}
\newcommand{\hH}{\bar{H}^n}
\newcommand{\Eu}{\mathscr{E}}
\newcommand{\N}{\mathbb{N}}
\newcommand{\R}{\mathbb{R}}
\newcommand{\Z}{\mathbb{Z}}

\newcommand{\alg}{\mathcal{F}}

\newcommand{\id}{\mathrm{id}}

\DeclareMathOperator{\CDiff}{\mathcal{C}Dif{}f}
\DeclareMathOperator{\Der}{D}
\DeclareMathOperator{\CL}{CL}
\DeclareMathOperator{\Dv}{D^v}
\DeclareMathOperator{\cl}{cl}
\DeclareMathOperator{\Diff}{Dif{}f}
\DeclareMathOperator{\diff}{dif{}f}
\DeclareMathOperator{\Smbl}{Smbl}
\DeclareMathOperator{\End}{End}
\DeclareMathOperator{\Hom}{Hom}
\DeclareMathOperator{\Sym}{Sym}
\DeclareMathOperator{\CoSym}{CoSym}
\DeclareMathOperator{\im}{im}
\DeclareMathOperator{\pr}{pr}
\DeclareMathOperator{\supp}{supp}
\newcommand*{\CDiffsym}[1]{\CDiff_{(#1)}^{\,\mathrm{sym}}}
\newcommand*{\CDiffself}[1]{\CDiff_{(#1)}^{\,\mathrm{self}}}
\newcommand*{\CDiffskew}[1]{\CDiff_{(#1)}^{\,\mathrm{skew}}}
\newenvironment{system}{\left\{\begin{array}{l}}{\end{array}\right.}
\newcommand{\cdiff}{CDIFF\xspace}
\newcommand{\reduce}{REDUCE\xspace}

%    Cyrillic letter \`E for use in math. mode
%    (from the Univ. of Washington Cyrillic font)
%\DeclareFontFamily{OT1}{wncyi}{}
%\DeclareFontShape{OT1}{wncyi}{m}{it}{
%   <5> <6> <7> <8> <9> gen * wncyi
%   <10> <10.95> <12> <14.4> <17.28> <20.74> <24.88> wncyi10
%  }{}
%\DeclareSymbolFont{cyrletters}{OT1}{wncyi}{m}{it}
%\DeclareSymbolFontAlphabet{\cyrmath}{cyrletters}
%\DeclareMathSymbol{\re}{\cyrmath}{cyrletters}{"03}
%\newcommand{\Ev}{\re}
\newcommand{\Ev}{E}
\newcommand{\EulerOperator}{\mathscr{E}}

%    HyperTeX commands
\providecommand{\href}[2]{#2}
\providecommand{\urlprefix}{URL }
%\newcommand*{\email}[1]{\href{mailto:#1}{\begingroup \urlstyle{rm}\Url{#1}}}
%\newcommand*{\eprint}[2][]{\href{http://arXiv.org/abs/#2}%
%{\begingroup \Url{arXiv:#2}}}

%\makeatletter
%\renewcommand{\@fnsymbol}[1]{}
%\makeatother

%\markboth{Variational brackets in the geometry of PDEs}%
%{P.H.M. Kersten, I.S. Krasil\cprime shchik, A.M.
%  Verbovetsky, R. Vitolo}

\newcommand{\nota}[2]{\color{red}[{Mark: #1}\par{#2}]\color{black}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\begin{document}

\title[\cdiff user guide]%
{\cdiff: \reduce packages
\\
for computations in geometry of PDEs}

\author[R. Vitolo]{R. Vitolo}
\address{R. Vitolo\\ Dept.\ of Mathematics
  ``E. De Giorgi'', Universit\`a del Salento \\ via per Arnesano, 73100 Lecce,
  Italy} \email{raffaele.vitolo@unisalento.it}

\date{2010 July 22}

\thanks{}

\keywords{\reduce, Hamiltonian operators, generalized symmetries, higher
  symmetries, conservation laws, nonlocal variables.}

\subjclass[2000]{37K05}

\begin{abstract}
  We describe \cdiff, a symbolic computation package for
  the geometry of Differential Equations (DEs, for short) and
  developed by P. Gragert, P.H.M. Kersten, G. Post and G. Roelofs at the
  University of Twente, The Netherlands.

  The package is part of the official \reduce distribution at Sourceforge
  \cite{red}, but it is also distributed on the Geometry of Differential
  Equations web site \url{http://gdeq.org} (GDEQ for short).

  We start from an installation guide for Linux and Windows. Then we focus on
  concrete usage recipes for the computation of higher symmetries, conservation
  laws, Hamiltonian and recursion operators for polynomial differential
  equations. All programs discussed here are shipped together with this manual
  and can be found at the GDEQ website. The mathematical theory on which
  computations are based can be found in refs.~\cite{Many,KKV}.
\end{abstract}

\maketitle

\section{Introduction}

This brief guide refers to using \cdiff, a set of symbolic computation packages
devoted to computations in the geometry of DEs and developed by P. Gragert,
P.H.M. Kersten, G. Post and G. Roelofs at the University of Twente, The
Netherlands.

Initially, the development of the \cdiff packages was started by Gragert and
Kersten for symmetry computations in DEs, then they have been partly rewritten
and extended by Roelofs and Post. The \cdiff packages consist of 3 program
files plus a utility file; only the main three files are documented
\cite{svec,integ,tools}. The \cdiff packages, as well as a copy of the
documentation (including this manual) and several example programs, can be
found both at Sourceforge in the sources of \reduce \cite{red} and in the
Geometry of Differential Equations (GDEQ for short) web site \cite{gdeq}. The
name of the packages, \cdiff, comes from the fact that the package is aimed at
defining differential operators in total derivatives and do computations
involving them.  Such operators are called \emph{$\mathcal{C}$-differential
  operators} (see \cite{Many}).

The main motivation for writing this manual was that \reduce 3.8 recently became
free software, and can be downloaded here \cite{red}. For this reason, we are
able to make our computations accessible to a wider public, also thanks to the
inclusion of \cdiff in the official \reduce distribution. The readers are
warmly invited to send questions, comments, etc., both on the computations and
on the technical aspects of installation and configuration of \reduce, to the
author of the present manual.

\textbf{Acknowledgements.} My warmest thanks are for Paul H.M. Kersten, who
explained to me how to use the \cdiff packages for several computations of
interest in the Geometry of Differential Equations. I also would like to thank
I.S. Krasil'shchik and A.M. Verbovetsky for constant support and stimulating
discussions which led me to write this text.

\section{Installation}

In order to use \cdiff packages you should be able to write \reduce programs
using \cdiff and run them in the \reduce interactive shell. So, you need two
programs: \reduce and a text editor which is preferably oriented to program
development.

\subsection{Installation of \reduce}
\label{sec:installation-reduce}

In order to install \reduce it is enough to download from here \cite{red} a
precompiled binary for your operating system (\emph{e.g.}, 32-bit or 64-bit
Debian-based Linux like Debian itself or Ubuntu, 32-bit Windows) and uncompress
it in your computer in a location of your choice.

For the moment \cdiff packages have been tested under Linux (both 32bit and
64bit) and Windows XP; please contact the author of this guide if you tested
the packages with positive results under Mac or other versions of Windows like
Vista or Windows 7.

A \reduce program using \cdiff packages can be written with any text editor; it
is customary to use the extension \texttt{.red} for \reduce programs, like
\texttt{program.red}. If you wish to run your program, just run the \reduce
executable. After starting \reduce, you would see something like
\begin{verbatim}
Reduce (Free CSL version), 14-Apr-09 ...

1:
\end{verbatim}

Assume that you wrote the program \texttt{program.red}, using \cdiff macros.
The program must contain the line
\begin{verbatim}
load_package cdiff;
\end{verbatim}
just before the first macro from the package \cdiff.
Then you may run the program with the following instruction at the \reduce
prompt:
\begin{verbatim}
1: in "program.red";
 \end{verbatim}
Note that in what follows we will omit the prompt in \reduce commands.

Of course, if the program file \texttt{program.red} \emph{is not} in the place
where the \reduce executable is, you should indicate the full path of the
program, and this depends on your system.
Remember that each time you run \reduce the path at the \reduce prompt is always
the path of the \reduce executable, unless you use an absolute path as
above. However, if you start \reduce with the graphical interface (see below)
you can always use the leftmost menu item \texttt{File>Open\dots} in order to
avoid to write down the whole absolute path.

\subsection{Installation of an editor for writing \reduce programs}
\label{sec:inst-reduce-ide}

Now, let us deal with the problem of editing \reduce programs.

Generally speaking, any text editor can be used to write a \reduce program. A
more suitable choice is an editor for programming languages. Such editors exist
in Linux and Windows, a list can be found here \cite{ed}.

A suggested text editor in Windows is \texttt{notepad++}. This editor is easy
to install, it has support for many programming languages (but \emph{not} for
\reduce!), and has a GPL free license, see \cite{noteppp}. Similar tools in
Linux are \texttt{kwrite} and \texttt{gedit}.

However, the only IDE (Integrated Development Environment) for developing
programs and running them inside the editor itself exists for the great text
editor \texttt{emacs}, which runs in all operating systems, and in particular
Linux and Windows. We stress that an IDE makes the developing-running-debugging
cycle much faster because every step is performed in the same environment.

Installation of \texttt{emacs} in Linux is quite smooth, although it depends on
the Linux distribution; usually it is enough to select the package
\texttt{emacs} in your favourite package management tool, like
\texttt{aptitude, synaptic,} or \texttt{kpackage}.  In order to install
\texttt{emacs} on Windows one has to work a little bit more. See here
\cite{emacswin} for more information.  Assuming that \texttt{emacs} it is
installed and working, the \reduce IDE for \texttt{emacs} can be found here
\cite{redide}.  We refer to their guide for the installation (the procedure is
the same for both Linux and Windows). I tested the IDE with emacs 23.1 under
Debian-based Linux systems (Debian Etch and Squeeze 32-bit and 64-bit, Ubuntu
10.04 64-bit) and Windows XP and it works fine for me.

Suppose you have \texttt{emacs} and its \reduce IDE installed, then there is a
last configuration step that will make \texttt{emacs} and \reduce work together.
Namely, when opening for the first time a \reduce program file with
\texttt{emacs}, go to the \texttt{REDUCE>Customize\dots} menu item and locate
the `\reduce run Program' item. This item contains the command which is issued
by \texttt{emacs} from the \reduce IDE when the menu item \texttt{Run REDUCE>Run
  REDUCE} is selected. Change the command to:
  \begin{itemize}
  \item under Linux (user and location as above):
   \begin{verbatim}
    reduce -w
    \end{verbatim}
  \item under Windows (user and locations as above):
   \begin{verbatim}
    reduce.exe
    \end{verbatim}
  \end{itemize}
This setting will run \reduce inside \texttt{emacs}. If you prefer the (slower)
graphical interface to \reduce, remove `\texttt{-w}'. Note that the graphical
interface will produce \LaTeX\ output, making it much more readable. This
behaviour can be turned off in the graphical interface by issuing the command
\texttt{off fancy;}.

\section{Working with \cdiff}

All programs that we will discuss in this manual can be found inside the
subfolder \texttt{examples} in the folder which contains this manual.  There
are some conventions that I adopted on writing programs which use \cdiff.
\begin{itemize}
\item Program files have the extension \texttt{.red}. This will load
  automatically the reduce-ide mode in emacs (provided you made the
  installation steps described in the reduce-ide guides).
\item Program files have the following names:
  \begin{center}
    \texttt{equationname\_typeofcomputation\_version.red}
  \end{center}
  where \texttt{equationname} stands for the shortened name of the equation
  (\emph{e.g.} Korteweg--de Vries is always indicated by KdV),
  \texttt{typeofcomputation} stands for the type of geometric object which is
  computed with the given file, for example symmetries, Hamiltonian operators,
  etc., \texttt{version} is a version number.
\item More specific information, like the date and more details on the
  computation done in each version, are included as comment lines at the very
  beginning of each file.
\end{itemize}

If you use a generic editor, as soon as you are finished writing a program, you
may run it from within \reduce by following the instructions in the previous
section.

In \texttt{emacs} with \reduce IDE it is easier: issuing the command
\texttt{M-x run-reduce} (or choosing the menu item \texttt{Run REDUCE>Run
  REDUCE}) will split the window in two halves and start \reduce in the bottom
half. If you are running PSL \reduce you must first issue the command
\texttt{lisp set\_bndstk\_size 1000000;} from within \reduce, in order to avoid
memory problems. If you are running CSL \reduce there is no need of that
instruction. Then you may load the program file that you were editing (suppose
that its name is \texttt{program.red}) by issuing \texttt{in "program.red";} at
the \reduce prompt. In fact, \texttt{emacs} lets \reduce assume as its working
directory the directory of the file that you were editing.

Results of a computation consist of the values of one or more unknown. Suppose
that the unknown's name is \texttt{sym}, and assume that, after a computation,
you wish to save the values of \texttt{sym}, possibly for future use from within
\reduce. Issue the following \reduce commands (of course, after you finish your
computations!):
\begin{verbatim}
off nat;
out file_res.red;
sym:=sym;
shut file_res.red;
\end{verbatim}
The above commands will write the content of \texttt{sym} into a file whose
name is \texttt{file\_res.red}, where \texttt{file} stands for a filename which
follows the above convention. The command \texttt{off nat;} is needed in order
to save the variable in a format which could be imported in future \reduce
sessions. If you wish to translate your results in \LaTeX, see the package
\texttt{rlfi} and its own documentation.

\section{Computing with \cdiff}

Here we describe some examples of computations with \cdiff. The parts of
examples which are shared between all examples are described only once. We
stress that all computations presented in this document are included in the
official \reduce distribution and can be also downloaded at the GDEQ website
\cite{gdeq}. The examples can be run with \reduce by typing \texttt{in
  "program.red";} at the \reduce prompt, as explained above.

\textbf{Remark.} The mathematical theories on which the computations are based
can be found in \cite{Many,KKV}.

\subsection{Higher symmetries}\label{sec:higher-symmetries}

In this section we show the computation of (some) higher symmetries of
Burgers'equation $B=u_t-u_{xx}+2uu_x=0$. The corresponding file is
\texttt{Burg\_hsym\_1.red} and the results of the computation are in
\texttt{Burg\_hsym\_1\_res.red}.

The idea underlying this computation is that one can use the scale symmetries
of Burgers'equation to assign ``gradings'' to each variable appearing in the
equation. As a consequence, one could try different ansatz for symmetries with
polynomial generating function. For example, it is possible to require that
they are sum of monomials of given degrees. This ansatz yields a simplification
of the equations for symmetries, because it is possible to solve them in a
``graded'' way, \emph{i.e.}, it is possible to split them into several
equations made by the homogeneous components of the equation for symmetries
with respect to gradings.

In particular, Burgers'equation translates into the following dimensional
equation:
\begin{displaymath}
  [u_t]=[u_{xx}],\quad [u_{xx}=2uu_x].
\end{displaymath}
By the rules $[u_z]=[u]-[z]$ and $[uv]=[u]+[v]$, and choosing $[x]=-1$, we have
$[u]=1$ and $[t]=-2$. This will be used to generate the list of homogeneous
monomials of given grading to be used in the ansatz about the structure of the
generating function of the symmetries.

The following instructions initialize the total derivatives. The first string
is the name of the vector field, the second item is the list of even variables
(note that \texttt{u1}, \texttt{u2}, ... are $u_x$, $u_{xx}$, \dots), the third
item is the list of odd (non-commuting) variables (`ext' stands for `external'
like in external (wedge) product). Note that in this example odd variables are
not strictly needed, but it is better to insert some of them for syntax reasons.
\begin{verbatim}
super_vectorfield(ddx,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});
\end{verbatim}

\begin{verbatim}
super_vectorfield(ddt,{x,t,u,u1,u2,u3,u4,u5,u6,u7,
u8,u9,u10,u11,u12,u13,u14,u15,u16,u17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});
\end{verbatim}

Specification of the vectorfield \texttt{ddx}.  The meaning of the first index
is the parity of variables.  In particular here we have just even variables.
The second index parametrizes the second item (list) in the
\texttt{super\_vectorfield} declaration. More precisely, \texttt{ddx(0,1)}
stands for $\pd{}{x}$, \texttt{ddx(0,2)} stands for $\pd{}{t}$,
\texttt{ddx(0,3)} stands for $\pd{}{u}$, \texttt{ddx(0,4)} stands for
$\pd{}{u_x}$, \dots, and all coordinates $x$, $t$, $u_x$, \dots, are treated as
even coordinates.  Note that \texttt{`\$'} suppresses the output.
\begin{verbatim}
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$
\end{verbatim}
The string \texttt{letop} is treated as a variable; if it appears during
computations it is likely that we went too close to the highest order variables
that we defined in the file. This could mean that we need to extend the
operators and variable list. In case of large output, one can search in it the
string \texttt{letop} to check whether errors occurred.

Specification of the vectorfield \texttt{ddt}. In the evolutionary case we
never have more than one time derivative, other derivatives are
$u_{txxx\cdots}$.
\begin{verbatim}
ddt(0,1):=0$
ddt(0,2):=1$
ddt(0,3):=ut$
ddt(0,4):=ut1$
ddt(0,5):=ut2$
ddt(0,6):=ut3$
ddt(0,7):=ut4$
ddt(0,8):=ut5$
ddt(0,9):=ut6$
ddt(0,10):=ut7$
ddt(0,11):=ut8$
ddt(0,12):=ut9$
ddt(0,13):=ut10$
ddt(0,14):=ut11$
ddt(0,15):=ut12$
ddt(0,16):=ut13$
ddt(0,17):=ut14$
ddt(0,18):=letop$
ddt(0,19):=letop$
sddt(0,20):=letop$
\end{verbatim}

We now give the equation in the form one of the derivatives equated to a
right-hand side expression. The left-hand side derivative is called
\emph{principal}, and the remaining derivatives are called
\emph{parametric}\footnote{This terminology dates back to Riquier, see
  \cite{Mar}}.  For scalar
evolutionary equations with two independent variables internal variables are of
the type $(t,x,u,u_x,u_{xx},\ldots)$.
\begin{verbatim}
ut:=u2+2*u*u1;
\end{verbatim}

\begin{verbatim}
ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
ut4:=ddx ut3;
ut5:=ddx ut4;
ut6:=ddx ut5;
ut7:=ddx ut6;
ut8:=ddx ut7;
ut9:=ddx ut8;
ut10:=ddx ut9;
ut11:=ddx ut10;
ut12:=ddx ut11;
ut13:=ddx ut12;
ut14:=ddx ut13;
\end{verbatim}

Test for verifying the commutation of total derivatives.
Highest order defined terms may yield some \texttt{letop}.
\begin{verbatim}
for i:=1:17 do write ev(0,i):=ddt(ddx(0,i))-ddx(ddt(0,i));
\end{verbatim}

This is the list of variables with respect to their grading,
starting from degree \emph{one}.
\begin{verbatim}
graadlijst:={{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};
\end{verbatim}

This is the list of all monomials of degree $0$, $1$, $2$, \dots which can be
constructed from the above list of elementary variables with their grading.
\begin{verbatim}
grd0:={1};
grd1:= mkvarlist1(1,1)$
grd2:= mkvarlist1(2,2)$
grd3:= mkvarlist1(3,3)$
grd4:= mkvarlist1(4,4)$
grd5:= mkvarlist1(5,5)$
grd6:= mkvarlist1(6,6)$
grd7:= mkvarlist1(7,7)$
grd8:= mkvarlist1(8,8)$
grd9:= mkvarlist1(9,9)$
grd10:= mkvarlist1(10,10)$
grd11:= mkvarlist1(11,11)$
grd12:= mkvarlist1(12,12)$
grd13:= mkvarlist1(13,13)$
grd14:= mkvarlist1(14,14)$
grd15:= mkvarlist1(15,15)$
grd16:= mkvarlist1(16,16)$
\end{verbatim}

Initialize a counter for the vector of arbitrary constants
\begin{verbatim}
ctel:=0;
\end{verbatim}

We assume a generating function \texttt{sym}, \emph{independent of $x$ and
  $t$}, of degree $\leq 5$.
\begin{verbatim}
sym:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$
\end{verbatim}

This is the equation $\bar\ell_B(\mathtt{sym})=0$, where $B=0$ is
Burgers'equation and \texttt{sym} is the generating function. From now on all
equations are arranged in a single vector whose name is \texttt{equ}.
\begin{verbatim}
equ 1:=ddt(sym)-ddx(ddx(sym))-2*u*ddx(sym)-2*u1*sym ;
\end{verbatim}

This is the list of variables, to be passed to the equation solver.
\begin{verbatim}
vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,
u12,u13,u14,u15,u16,u17};
\end{verbatim}

This is the number of initial equation(s)
\begin{verbatim}
tel:=1;
\end{verbatim}

The following procedure uses \texttt{multi\_coeff} (from the package
\texttt{tools}).  It gets all coefficients of monomials appearing in the
initial equation(s).  The coefficients are put into the vector \texttt{equ}
after the initial equations.
\begin{verbatim}
procedure splitvars i;
begin;
ll:=multi_coeff(equ i,vars);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;
\end{verbatim}

This command initializes the equation solver.  It passes
\begin{itemize}
  \item the equation vector \texttt{equ} togeher with its length \texttt{tel}
    (\emph{i.e.}, the total number of equations);
  \item the list of variables with respect to which the system \emph{must not}
    split the equations, \emph{i.e.}, variables with respect to which the
    unknowns are not polynomial. In this case this list is just $\{\}$;
  \item the constants'vector \texttt{c}, its length \texttt{ctel}, and the
    number of negative indexes if any; just $\texttt{0}$ in our example;
  \item the vector of free functions \texttt{f} that may appear in
    computations. Note that in \texttt{$\{$f,0,0 $\}$} the second $\texttt{0}$
    stands for the length of the vector of free functions. In this example
    there are no free functions, but the command needs the presence of at least
    a dummy argument, \texttt{f} in this case. There is also a last zero which
    is the negative length of the vector $f$, just as for constants.
  \end{itemize}
\begin{verbatim}
initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});
\end{verbatim}

Run the procedure splitvars in order to obtain equations on coefficiens
of each monomial.
\begin{verbatim}
splitvars 1;
\end{verbatim}

Next command tells the solver the total number of equations obtained
after running splitvars.
\begin{verbatim}
pte tel;
\end{verbatim}

It is worth to write down the equations for the coefficients.
\begin{verbatim}
for i:=2:tel do write equ i;
\end{verbatim}

This command solves the equations for the coefficients.
Note that we have to skip the initial equations!
\begin{verbatim}
for i:=2:te do es i;
;end;
\end{verbatim}

In the folder \texttt{computations/NewTests/Higher\_symmetries} it is possible
to find the following files:
\begin{description}
\item[Burg\_hsym\_1.red] The above file, together with its results file.
  \item[KdV\_hsym\_1.red] Higher symmetries of KdV, with the ansatz:
    deg(sym) $\leq$ 5.
\item[KdV\_hsym\_2.red] Higher symmetries of KdV, with the ansatz:
  \begin{center}
    sym = x*(something of degree 3) + t*(something of degree  5)\\
  + (something of degree 2).
  \end{center}
    This yields scale symmetries.
\item[KdV\_hsym\_3.red] Higher symmetries of KdV, with the ansatz:
  \begin{center}
    sym = x*(something of degree 1) + t*(something of degree 3)\\
    + (something of degree 0).
  \end{center}
This yields Galilean boosts.
\end{description}

\subsection{Local conservation laws}
\label{sec:local-cons-laws}

In this section we will find (some) local conservation laws for the KdV
equation $F=u_t-u_{xxx}+uu_x=0$. Concretely, we have to find non-trivial $1$-forms
$f=f_xdx+f_tdt$ on $F=0$ such that $\bar d f=0$ on $F=0$. ``Triviality'' of
conservation laws is a delicate matter, for which we invite the reader to have
a look in \cite{Many}.

The files containing this example is \texttt{KdV\_loc-cl\_1.red,
  KdV\_loc-cl\_2.red} and the corresponding results files.

We make use of \texttt{ddx} and \texttt{ddt}, which in the even part are the
same as in the previous example (subsection~\ref{sec:higher-symmetries}).
After defining the total derivatives we prepare the list of graded variables
(recall that in KdV $u$ is of degree $2$):
\begin{verbatim}
graadlijst:={{},{u},{u1},{u2},{u3},{u4},{u5},
{u6},{u7},{u8},{u9},{u10},{u11},{u12},{u13},{u14},{u15},{u16},{u17}};
\end{verbatim}
We make the ansatz
\begin{verbatim}
fx:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))$
ft:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))+
(for each el in grd5 sum (c(ctel:=ctel+1)*el))$
\end{verbatim}
for the components of the conservation law. We have to solve the equation
\begin{verbatim}
equ 1:=ddt(fx)-ddx(ft);
\end{verbatim}
the fact that \texttt{ddx} and \texttt{ddt} are expressed in internal
coordinates on the equation means that the objects that we consider are already
restricted to the equation.

We shall split the equation in its graded summands with the procedure
\texttt{splitvars}, then solve it
\begin{verbatim}
initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});
splitvars 1;
pte tel;
for i:=2:tel do es i;
end;
\end{verbatim}
As a result we get
\begin{verbatim}
fx := c(3)*u1 + c(2)*u + c(1)$
ft := (2*c(3)*u*u1 + 2*c(3)*u3 + c(2)*u**2 + 2*c(2)*u2)/2$
\end{verbatim}
Unfortunately it is clear that the conservation law corresponding to
\texttt{c(3)} is trivial, because it is the total $x$-derivative of $F$; its
restriction on the infinite prolongation of the KdV is zero. Here this fact is
evident; how to get rid of less evident trivialities by an `automatic'
mechanism? We considered this problem in the file \texttt{KdV\_loc-cl\_2.red},
where we solved the equation
\begin{verbatim}
equ 1:=fx-ddx(f0);
equ 2:=ft-ddt(f0);
\end{verbatim}
after having loaded the values \texttt{fx} and \texttt{ft} found by the
previous program. We make the following ansatz on \texttt{f0}:
\begin{verbatim}
f0:=
(for each el in grd0 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd1 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd2 sum (cc(cctel:=cctel+1)*el))+
(for each el in grd3 sum (cc(cctel:=cctel+1)*el))$
\end{verbatim}
Note that this gives a grading which is compatible with the gradings of
\texttt{fx} and \texttt{ft}. After solving the system
\begin{verbatim}
initialize_equations(equ,tel,{},{cc,cctel,0},{f,0,0});
for i:=1:2 do begin splitvars i;end;
pte tel;
for i:=3:tel do es i;
end;
\end{verbatim}
issuing the commands
\begin{verbatim}
fxnontriv := fx-ddx(f0);
ftnontriv := ft-ddt(f0);
\end{verbatim}
we obtain
\begin{verbatim}
fxnontriv := c(2)*u + c(1)$
ftnontriv := (c(2)*(u**2 + 2*u2))/2$
\end{verbatim}
This mechanism can be easily generalized to situations in which the
conservation laws which are found by the program are difficult to treat by pen
and paper.


\subsection{Local Hamiltonian operators}
\label{sec:local-hamilt-oper}

In this section we will find local Hamiltonian operators for the KdV equation
$u_t=u_{xxx}+uu_x$. Concretely, we have to solve $\bar
\ell_{KdV}(\mathtt{phi})=0$ over the equation
\begin{displaymath}
  \left\{\begin{array}{l}
    u_t=u_{xxx}+uu_x\\
    p_t=p_{xxx}+up_x
  \end{array}\right.
\end{displaymath}
or, in geometric terminology, find the shadows of symmetries on the
$\ell^*$-covering of the KdV equation. The reference paper for this type of
computations is \cite{KKV}.

The file containing this example is \texttt{KdV\_Ham\_1.red}.

We make use of \texttt{ddx} and \texttt{ddt}, which in the even part are the
same as in the previous example (subsection~\ref{sec:higher-symmetries}).  We
stress that the linearization $\bar \ell_{KdV}(\mathtt{phi})=0$ is the equation
\begin{verbatim}
ddt(phi)-u*ddx(phi)-u1*phi-ddx(ddx(ddx(phi)))=0
\end{verbatim}
but the total derivatives are lifted to the $\ell^*$ covering, hence they must
contain also derivatives with respect to $p$'s. This will be achieved by
treating $p$ variables as odd and introducing the odd parts of \texttt{ddx} and
\texttt{ddt},
\begin{verbatim}
ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$
\end{verbatim}
In the above definition the first index `1' says that we are dealing with odd
variables, \texttt{ext} indicates anticommuting variables. Here, \texttt{ext 3}
is $p_0$, \texttt{ext 4} is $p_x$, \texttt{ext 5} is $p_{xx}$, \dots so
\texttt{ddx(1,3):=ext 4} indicates $p_x\pd{}{p}$, etc..

Now, remembering that the additional equation is again evolutionary, we can get
rid of $p_t$ by letting it be equal to \texttt{ext 6 + u*ext 4}, as follows:
\begin{verbatim}
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$
\end{verbatim}

Let us make the following ansatz about the Hamiltonian operators:
\begin{verbatim}
phi:=
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 3+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 4+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+

(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6
$
\end{verbatim}
Note that we are looking for generating functions of shadows which are
\emph{linear} with respect to $p$'s. Moreover, having set $[p]=-2$ we will look
for solutions of maximal possible degree $+1$.

After having set
\begin{verbatim}
equ 1:=ddt(phi)-u*ddx(phi)-u1*phi-ddx(ddx(ddx(phi)));
vars:={x,t,u,u1,u2,u3,u4,u5,u6,u7,u8,u9,u10,u11,u12,u13,u14,u15,u16,u17};
tel:=1;
\end{verbatim}
we define the procedures \texttt{splitvars} as in
subsection~\ref{sec:higher-symmetries} and \texttt{splitext} as follows:
\begin{verbatim}
procedure splitext i;
begin;
ll:=operator_coeff(equ i,ext);
equ(tel:=tel+1):=first ll;
ll:=rest ll;
for each el in ll do equ(tel:=tel+1):=second el;
end;
\end{verbatim}
Then we initialize the equations:
\begin{verbatim}
initialize_equations(equ,tel,{},{c,ctel,0},{f,0,0});
\end{verbatim}
do \texttt{splitext}
\begin{verbatim}
splitext 1;
\end{verbatim}
then \texttt{splitvars}
\begin{verbatim}
tel1:=tel;
for i:=2:tel1 do begin splitvars i;equ i:=0;end;
\end{verbatim}
Now we are ready to solve all equations:
\begin{verbatim}
pte tel;
for i:=2:tel do write equ i:=equ i;
pause;
for i:=2:tel do es i;
end;
\end{verbatim}
Note that we want \emph{all} equations to be solved!

The results are the two well-known Hamiltonian operators for the KdV:
\begin{verbatim}
phi := c(4)*ext(4) + 3*c(3)*ext(6) + 2*c(3)*ext(4)*u + c(3)*ext(3)*u1$
\end{verbatim}
Of course, the results correspond to the operators
\begin{gather*}
  \text{\texttt{ext(4)}} \to D_x,\\
  \text{\texttt{3*c(3)*ext(6) +
  2*c(3)*ext(4)*u + c(3)*ext(3)*u1}} \to 3D_{xxx} + 2uD_{x} + u_x
\end{gather*}
Note that each operator is multiplied by one arbitrary real
constant, \texttt{c(4)} and \texttt{c(3)}.

\subsection{Non-local Hamiltonian operators}
\label{sec:non-local-hamilt}

In this section we will show an experimental way to find nonlocal Hamiltonian
operators for the KdV equation. The word `experimental' comes from the lack of
a consistent mathematical theory. The result of the computation (without the
details below) has been published in \cite{KKV}.

We have to solve equations of the type \texttt{ddx(ft)-ddt(fx)} as
in~\ref{sec:local-cons-laws}. The main difference is that we will attempt a
solution on the $\ell^*$-covering (see Subsection~\ref{sec:local-hamilt-oper}).
For this reason, first of all we have to determine covering variables with the
usual mechanism of introducing them through conservation laws, this time on the
$\ell^*$-covering.

As a first step, let us compute conservation laws on the $\ell^*$-covering
whose components are linear in the $p$'s.  This computation can be found in the
file \texttt{KdV\_nloc-cl\_1.red} and related results file. When specifying odd
variables in \texttt{ddx} and \texttt{ddt}, we have something like
\begin{verbatim}
ddx(1,1):=0$
ddx(1,2):=0$
ddx(1,3):=ext 4$
ddx(1,4):=ext 5$
ddx(1,5):=ext 6$
ddx(1,6):=ext 7$
ddx(1,7):=ext 8$
ddx(1,8):=ext 9$
ddx(1,9):=ext 10$
ddx(1,10):=ext 11$
ddx(1,11):=ext 12$
ddx(1,12):=ext 13$
ddx(1,13):=ext 14$
ddx(1,14):=ext 15$
ddx(1,15):=ext 16$
ddx(1,16):=ext 17$
ddx(1,17):=ext 18$
ddx(1,18):=ext 19$
ddx(1,19):=ext 20$
ddx(1,20):=letop$
ddx(1,50):=(t*u1+1)*ext 3$ % degree -2
ddx(1,51):=u1*ext 3$ % degree +1
ddx(1,52):=(u*u1+u3)*ext 3$ % degree +3
\end{verbatim}
and
\begin{verbatim}
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=ext 6 + u*ext 4$
ddt(1,4):=ddx(ddt(1,3))$
ddt(1,5):=ddx(ddt(1,4))$
ddt(1,6):=ddx(ddt(1,5))$
ddt(1,7):=ddx(ddt(1,6))$
ddt(1,8):=ddx(ddt(1,7))$
ddt(1,9):=ddx(ddt(1,8))$
ddt(1,10):=ddx(ddt(1,9))$
ddt(1,11):=ddx(ddt(1,10))$
ddt(1,12):=ddx(ddt(1,11))$
ddt(1,13):=ddx(ddt(1,12))$
ddt(1,14):=ddx(ddt(1,13))$
ddt(1,15):=ddx(ddt(1,14))$
ddt(1,16):=ddx(ddt(1,15))$
ddt(1,17):=ddx(ddt(1,16))$
ddt(1,18):=letop$
ddt(1,19):=letop$
ddt(1,20):=letop$
ddt(1,50):=f1*ext 3+f2*ext 4+f3*ext 5$
ddt(1,51):=f4*ext 3+f5*ext 4+f6*ext 5$
ddt(1,52):=f7*ext 3+f8*ext 4+f9*ext 5$
\end{verbatim}
The variables corresponding to the numbers \texttt{50,51,52} here play a dummy
role, the coefficients of the corresponding vector are the unknown generating
functions of conservation laws on the $\ell^*$-covering.
More precisely, we look for conservation laws
of the form
\begin{verbatim}
fx= phi*ext 3
ft= f1*ext3+f2*ext4+f3*ext5
\end{verbatim}
The ansatz is chosen because, first of all, \texttt{ext 4} and \texttt{ext 5}
can be removed from fx by adding a suitable total divergence (trivial
conservation law); moreover it can be proved that \texttt{phi} is a symmetry of
KdV. We can write down the equations
\begin{verbatim}
equ 1:=ddx(ddt(1,50))-ddt(ddx(1,50));
equ 2:=ddx(ddt(1,51))-ddt(ddx(1,51));
equ 3:=ddx(ddt(1,52))-ddt(ddx(1,52));
\end{verbatim}
However, the above choices make use of a symmetry which contains \texttt{`t'}
in the generator. This would make automatic computations more tricky, but still
possible. In this case the solution of \texttt{equ 1} has been found by hand
and passed to the program:
\begin{verbatim}
f3:=t*u1+1$
f1:=u*f3+ddx(ddx(f3))$
f2:=-ddx(f3)$
\end{verbatim}
together with the ansatz on the coefficients for the other equations
\begin{verbatim}
f4:=(for each el in grd5 sum (c(ctel:=ctel+1)*el))$
f5:=(for each el in grd4 sum (c(ctel:=ctel+1)*el))$
f6:=(for each el in grd3 sum (c(ctel:=ctel+1)*el))$

f7:=(for each el in grd7 sum (c(ctel:=ctel+1)*el))$
f8:=(for each el in grd6 sum (c(ctel:=ctel+1)*el))$
f9:=(for each el in grd5 sum (c(ctel:=ctel+1)*el))$
\end{verbatim}
The previous ansatz keep into account the grading of the starting
symmetry in \texttt{phi*ext 3}. The resulting equations are solved in the usual
way (see the example file).

Now, we solve the equation for shadows of nonlocal symmetries in a covering of
the $\ell^*$-covering. We can choose between three new nonlocal variables
\texttt{ra,rb,rc}. We are going to look for non-local Hamiltonian operators
depending linearly on one of these variables. Higher non-local Hamiltonian 
operators could be found by introducing total derivatives of the r's.
As usual, the new variables are specified through the components of the 
previously found conservation laws according with the rule
\begin{verbatim}
ra_x=fx, ra_t=ft,
\end{verbatim}
and analogously for the others. We define
\begin{verbatim}
ddx(1,50):=(t*u1+1)*ext 3$ % degree -2
ddx(1,51):=u1*ext 3$ % degree +1
ddx(1,52):=(u*u1+u3)*ext 3$ % degree +3
\end{verbatim}
and
\begin{verbatim}
ddt(1,50) := ext(5)*t*u1 + ext(5) - ext(4)*t*u2 + ext(3)*t*u*u1 +
ext(3)*t*u3 + ext(3)*u$
ddt(1,51) := ext(5)*u1 - ext(4)*u2 + ext(3)*u*u1 + ext(3)*u3$
ddt(1,52) := ext(5)*u*u1 + ext(5)*u3 - ext(4)*u*u2 - ext(4)*u1**2 -
ext(4)*u4 + ext(3)*u**2*u1 + 2*ext(3)*u*u3 + 3*ext(3)*u1*u2 + ext(3)*u5$
\end{verbatim}
as it results from the computation of the conservation laws.
The following ansatz for the nonlocal Hamiltonian operator
comes from the fact that local Hamiltonian operators have 
gradings $-1$ and $+1$ when written in terms of $p$'s. So we are looking 
for a nonlocal Hamiltonian operator of degree $3$.
\begin{verbatim}
phi:=
(for each el in grd6 sum (c(ctel:=ctel+1)*el))*ext 50+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 51+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 52+

(for each el in grd5 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd4 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 6+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 8
$
\end{verbatim}
As a solution, we obtain
\begin{verbatim}
phi := c(1)*(ext(51)*u1 - 9*ext(8) - 12*ext(6)*u - 18*ext(5)*u1 -
4*ext(4)*u**2 - 12*ext(4)*u2 - 4*ext(3)*u*u1 - 3*ext(3)*u3)$
\end{verbatim}
where \texttt{ext51} stands for the nonlocal variable \texttt{rb} fulfilling
\begin{verbatim}
rb_x:=u1*ext 3$
rb_t:=ext(5)*u1 - ext(4)*u2 + ext(3)*u*u1 + ext(3)*u3$
\end{verbatim}

\textbf{Remark.} In the file \texttt{KdV\_nloc-Ham\_2.red} it is possible to
find another ansatz for a non-local Hamiltonian operator of degree $+5$.

\subsection{Computations for systems of PDEs}
\label{sec:comp-syst-pdes}

There is no conceptual difference when computing for systems of PDEs. We will
look for Hamiltonian structures for the following Boussinesq equation:
\begin{equation}
  \label{eq:1}
  \left\{
  \begin{array}{l}
  u_t-u_xv-uv_x-\sigma v_{xxx}=0\\
  v_t-u_x-vv_x=0
\end{array}
\right.
\end{equation}
where $\sigma$ is a constant. This example also shows how to deal with jet
spaces with more than one dependent variable. Here gradings can be taken as
\begin{displaymath}
  [t]=-2,\quad [x]=-1,\quad [v]=1,\quad [u]=2,\quad [p]=[\pd{}{u}]=-2,\quad
  [q]=[\pd{}{v}]=-1
\end{displaymath}
where $p$, $q$ are the two coordinates in the space of generating functions of
conservation laws.

The linearization of the above system and its adjoint are, respectively
\begin{displaymath}
  \ell_{\text{Bou}}=
  \begin{pmatrix}
    D_t-vD_x-v_x & -u_x-uD_x-\sigma D_{xxx}\\
    -D_x & D_t-v_x-vD_x
  \end{pmatrix},\ 
  \ell^*_{\text{Bou}}=
  \begin{pmatrix}
    -D_t+vD_x & D_x\\
    uD_x+\sigma D_{xxx} & -D_t+vD_x
  \end{pmatrix}
\end{displaymath}
and lead to the $\ell^*_{\text{Bou}}$ covering equation
\begin{displaymath}
  \label{eq:2}
  \left\{
  \begin{array}{l}
    -p_t+vp_x+q_x=0\\
    up_x+\sigma p_{xxx}-q_t+vq_x=0\\
  u_t-u_xv-uv_x-\sigma v_{xxx}=0\\
  v_t-u_x-vv_x=0
\end{array}
\right.
\end{displaymath}
We have to find shadows of symmetries on the above covering.
Total derivatives must be defined as follows:
\begin{verbatim}
super_vectorfield(ddx,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,
u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});

super_vectorfield(ddt,{x,t,u,v,u1,v1,u2,v2,u3,v3,u4,v4,u5,v5,u6,v6,u7,
v7,u8,v8,u9,v9,u10,v10,u11,v11,u12,v12,u13,v13,u14,v14,u15,v15,
u16,v16,u17,v17},
{ext 1,ext 2,ext 3,ext 4,ext 5,ext 6,ext 7,ext 8,ext 9,ext 10,ext
11,ext 12,ext 13,ext 14,ext 15,ext 16,ext 17,ext 18,ext 19,ext 20,ext
21,ext 22,ext 23,ext 24,ext 25,ext 26,ext 27,ext 28,ext 29,ext 30,
ext 31,ext 32,ext 33,ext 34,ext 35,ext 36,ext 37,ext 38,ext 39,ext 40,
ext 41,ext 42,ext 43,ext 44,ext 45,ext 46,ext 47,ext 48,ext 49,ext 50,
ext 51,ext 52,ext 53,ext 54,ext 55,ext 56,ext 57,ext 58,ext 59,ext 60,
ext 61,ext 62,ext 63,ext 64,ext 65,ext 66,ext 67,ext 68,ext 69,ext 70,
ext 71,ext 72,ext 73,ext 74,ext 75,ext 76,ext 77,ext 78,ext 79,ext 80
});
\end{verbatim}
In the list of coordinates we alternate derivatives of $u$ and derivatives of
$v$. The same must be done for coefficients; for example,
\begin{verbatim}
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=v1$
ddx(0,5):=u2$
ddx(0,6):=v2$
...
\end{verbatim}
After specifying the equation
\begin{verbatim}
ut:=u1*v+u*v1+sig*v3;
vt:=u1+v*v1;
\end{verbatim}
we define the (already introduced) time derivatives:
\begin{verbatim}
ut1:=ddx ut;
ut2:=ddx ut1;
ut3:=ddx ut2;
...
vt1:=ddx vt;
vt2:=ddx vt1;
vt3:=ddx vt2;
...
\end{verbatim}
up to the required order (here the order can be stopped at $15$).  Odd
variables $p$ and $q$ must be specified with an appropriate length (here it is
OK to stop at \texttt{ddx(1,36)}). Recall to replace $p_t$, $q_t$ with the
internal coordinates of the covering:
\begin{verbatim}
ddt(1,1):=0$
ddt(1,2):=0$
ddt(1,3):=+v*ext 5+ext 6$
ddt(1,4):=u*ext 5+sig*ext 9+v*ext 6$
ddt(1,5):=ddx(ddt(1,3))$
...
\end{verbatim}
The list of graded variables:
\begin{verbatim}
graadlijst:={{v},{u,v1},{u1,v2},{u2,v3},{u3,v4},{u4,v5},
{u5,v6},{u6,v7},{u7,v8},{u8,v9},{u9,v10},{u10,v11},{u11,v12},{u12,v13},
{u13,v14},{u14,v15},{u15,v16},{u16,v17},{u17}};
\end{verbatim}
The ansatz for the components of the Hamiltonian operator is
\begin{verbatim}
phi1:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6
$

phi2:=
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 4
$
\end{verbatim}
and the equation for shadows of symmetries is
\begin{verbatim}
equ 1:=ddt(phi1)-v*ddx(phi1)-v1*phi1-u1*phi2-u*ddx(phi2)
-sig*ddx(ddx(ddx(phi2)));
equ 2:=-ddx(phi1)-v*ddx(phi2)-v1*phi2+ddt(phi2);
\end{verbatim}
After the usual procedures for decomposing polynomials we obtain the following
result:
\begin{verbatim}
phi1 := c(6)*ext(6)$
phi2 := c(6)*ext(5)$
\end{verbatim}
which corresponds to the vector $(D_x,D_x)$.  Extending the ansatz to
\begin{verbatim}
phi1:=
(for each el in grd3 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 9+
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 6+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 8
$

phi2:=
(for each el in grd2 sum (c(ctel:=ctel+1)*el))*ext 3+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 5+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 7+
(for each el in grd1 sum (c(ctel:=ctel+1)*el))*ext 4+
(for each el in grd0 sum (c(ctel:=ctel+1)*el))*ext 6
$
\end{verbatim}
allows us to find a second (local) Hamiltonian operator
\begin{verbatim}
phi1 := (c(3)*(2*ext(9)*sig + ext(6)*v + 2*ext(5)*u + ext(3)*u1))/2$
phi2 := (c(3)*(2*ext(6) + ext(5)*v + ext(3)*v1))/2$
\end{verbatim}
There is one more higher local Hamiltonian operator, and a whole hierarchy of
nonlocal Hamiltonian operators~\cite{KKV}.


\subsection{Explosion of denominators and how to avoid it}

Here we propose the computation of the repeated total derivative of a
denominator. This computation fills up the whole memory after some time, and
can be used as a kind of speed test for the system. The file is
\texttt{KdV\_denom\_1.red}.

After having defined total derivatives on the KdV equation, run the following
iteration:
\begin{verbatim}
phi:=1/(u3+u*u1)$
for i:=1:100 do begin
                phi:=ddx(phi)$
                write i;
end;
\end{verbatim}
The program shows the iteration number. At the 18th iteration the program uses
about 600MB of RAM, as shown by \texttt{top} run from another shell, and 100\%\
of one processor.

There is a simple way to avoid denominator explosion. The file is
\texttt{KdV\_denom\_2.red}.

After having defined total derivatives with respect to $x$ (on the KdV
equation, for example) consider in the same \texttt{ddx} a component with a
sufficently high index \textbf{immediately after `letop'} (otherwise
\texttt{super\_vectorfield} does not work!), say \texttt{ddx(0,21)}, and think
of it as being the coefficient to a vector of the type
\begin{verbatim}
aa21:=1/(u3+u*u1);
\end{verbatim}
In this case, its coefficient must be
\begin{verbatim}
ddx(0,21):=-aa21**2*(u4+u1**2+u*u2)$
\end{verbatim}
More particularly, here follows the detailed definition of \texttt{ddx}
\begin{verbatim}
ddx(0,1):=1$
ddx(0,2):=0$
ddx(0,3):=u1$
ddx(0,4):=u2$
ddx(0,5):=u3$
ddx(0,6):=u4$
ddx(0,7):=u5$
ddx(0,8):=u6$
ddx(0,9):=u7$
ddx(0,10):=u8$
ddx(0,11):=u9$
ddx(0,12):=u10$
ddx(0,13):=u11$
ddx(0,14):=u12$
ddx(0,15):=u13$
ddx(0,16):=u14$
ddx(0,17):=u15$
ddx(0,18):=u16$
ddx(0,19):=u17$
ddx(0,20):=letop$
ddx(0,21):=-aa21**2*(u4+u1**2+u*u2)$
\end{verbatim}

Now, suppose that we want to compute the 5th total derivative of
\texttt{phi}. Write the following code:
\begin{verbatim}
phi:=aa30;
for i:=1:5 do begin
                phi:=ddx(phi)$
                write i;
end;
\end{verbatim}
The result is then a polynomial in the additional `denominator' variable
\begin{verbatim}
phi := aa21**2*( - 120*aa21**4*u**5*u2**5 - 600*aa21**4*u**4*u1**2*u2**4 - 600*
aa21**4*u**4*u2**4*u4 - 1200*aa21**4*u**3*u1**4*u2**3 - 2400*aa21**4*u**3*u1**2*
u2**3*u4 - 1200*aa21**4*u**3*u2**3*u4**2 - 1200*aa21**4*u**2*u1**6*u2**2 - 3600*
aa21**4*u**2*u1**4*u2**2*u4 - 3600*aa21**4*u**2*u1**2*u2**2*u4**2 - 1200*aa21**4
*u**2*u2**2*u4**3 - 600*aa21**4*u*u1**8*u2 - 2400*aa21**4*u*u1**6*u2*u4 - 3600*
aa21**4*u*u1**4*u2*u4**2 - 2400*aa21**4*u*u1**2*u2*u4**3 - 600*aa21**4*u*u2*u4**
4 - 120*aa21**4*u1**10 - 600*aa21**4*u1**8*u4 - 1200*aa21**4*u1**6*u4**2 - 1200*
aa21**4*u1**4*u4**3 - 600*aa21**4*u1**2*u4**4 - 120*aa21**4*u4**5 + 240*aa21**3*
u**4*u2**3*u3 + 720*aa21**3*u**3*u1**2*u2**2*u3 + 720*aa21**3*u**3*u1*u2**4 + 
240*aa21**3*u**3*u2**3*u5 + 720*aa21**3*u**3*u2**2*u3*u4 + 720*aa21**3*u**2*u1**
4*u2*u3 + 2160*aa21**3*u**2*u1**3*u2**3 + 720*aa21**3*u**2*u1**2*u2**2*u5 + 1440
*aa21**3*u**2*u1**2*u2*u3*u4 + 2160*aa21**3*u**2*u1*u2**3*u4 + 720*aa21**3*u**2*
u2**2*u4*u5 + 720*aa21**3*u**2*u2*u3*u4**2 + 240*aa21**3*u*u1**6*u3 + 2160*aa21
**3*u*u1**5*u2**2 + 720*aa21**3*u*u1**4*u2*u5 + 720*aa21**3*u*u1**4*u3*u4 + 4320
*aa21**3*u*u1**3*u2**2*u4 + 1440*aa21**3*u*u1**2*u2*u4*u5 + 720*aa21**3*u*u1**2*
u3*u4**2 + 2160*aa21**3*u*u1*u2**2*u4**2 + 720*aa21**3*u*u2*u4**2*u5 + 240*aa21
**3*u*u3*u4**3 + 720*aa21**3*u1**7*u2 + 240*aa21**3*u1**6*u5 + 2160*aa21**3*u1**
5*u2*u4 + 720*aa21**3*u1**4*u4*u5 + 2160*aa21**3*u1**3*u2*u4**2 + 720*aa21**3*u1
**2*u4**2*u5 + 720*aa21**3*u1*u2*u4**3 + 240*aa21**3*u4**3*u5 - 60*aa21**2*u**3*
u2**2*u4 - 90*aa21**2*u**3*u2*u3**2 - 120*aa21**2*u**2*u1**2*u2*u4 - 90*aa21**2*
u**2*u1**2*u3**2 - 780*aa21**2*u**2*u1*u2**2*u3 - 180*aa21**2*u**2*u2**4 - 60*
aa21**2*u**2*u2**2*u6 - 180*aa21**2*u**2*u2*u3*u5 - 120*aa21**2*u**2*u2*u4**2 - 
90*aa21**2*u**2*u3**2*u4 - 60*aa21**2*u*u1**4*u4 - 1020*aa21**2*u*u1**3*u2*u3 - 
1170*aa21**2*u*u1**2*u2**3 - 120*aa21**2*u*u1**2*u2*u6 - 180*aa21**2*u*u1**2*u3*
u5 - 120*aa21**2*u*u1**2*u4**2 - 540*aa21**2*u*u1*u2**2*u5 - 1020*aa21**2*u*u1*
u2*u3*u4 - 360*aa21**2*u*u2**3*u4 - 120*aa21**2*u*u2*u4*u6 - 90*aa21**2*u*u2*u5
**2 - 180*aa21**2*u*u3*u4*u5 - 60*aa21**2*u*u4**3 - 240*aa21**2*u1**5*u3 - 990*
aa21**2*u1**4*u2**2 - 60*aa21**2*u1**4*u6 - 540*aa21**2*u1**3*u2*u5 - 480*aa21**
2*u1**3*u3*u4 - 1170*aa21**2*u1**2*u2**2*u4 - 120*aa21**2*u1**2*u4*u6 - 90*aa21
**2*u1**2*u5**2 - 540*aa21**2*u1*u2*u4*u5 - 240*aa21**2*u1*u3*u4**2 - 180*aa21**
2*u2**2*u4**2 - 60*aa21**2*u4**2*u6 - 90*aa21**2*u4*u5**2 + 10*aa21*u**2*u2*u5 +
 20*aa21*u**2*u3*u4 + 10*aa21*u*u1**2*u5 + 110*aa21*u*u1*u2*u4 + 80*aa21*u*u1*u3
**2 + 160*aa21*u*u2**2*u3 + 10*aa21*u*u2*u7 + 20*aa21*u*u3*u6 + 30*aa21*u*u4*u5 
+ 50*aa21*u1**3*u4 + 340*aa21*u1**2*u2*u3 + 10*aa21*u1**2*u7 + 180*aa21*u1*u2**3
 + 60*aa21*u1*u2*u6 + 80*aa21*u1*u3*u5 + 50*aa21*u1*u4**2 + 60*aa21*u2**2*u5 + 
100*aa21*u2*u3*u4 + 10*aa21*u4*u7 + 20*aa21*u5*u6 - u*u6 - 6*u1*u5 - 15*u2*u4 - 
10*u3**2 - u8)$
\end{verbatim}
where the value of \texttt{aa21} can be replaced back in the expression.


\begin{thebibliography}{99}

\bibitem{red} Obtaining \reduce: \url{http://reduce-algebra.sourceforge.net/}.
  \bibitem{gdeq} Geometry of Differential Equations web site:
    \url{http://gdeq.org}.
  \bibitem{noteppp} \texttt{notepad++}:
    \url{http://notepad-plus.sourceforge.net/}
  \bibitem{ed} List of text editors:
    \url{http://en.wikipedia.org/wiki/List_of_text_editors}
  \bibitem{emacswin} How to install \texttt{emacs} in Windows:
    \url{http://www.cmc.edu/math/alee/emacs/emacs.html}. See also
    \url{http://www.gnu.org/software/emacs/windows/ntemacs.html}
  \bibitem{reducewin} How to install \reduce in Windows:
    \url{http://reduce-algebra.sourceforge.net/windows.html}
  \bibitem{svec} \textsc{G.H.M. Roelofs}, The SUPER VECTORFIELD package for
    REDUCE. Version 1.0, Memorandum 1099, Dept. Appl. Math., University of
    Twente, 1992. Available at \url{http://gdeq.org}.
  \bibitem{integ} \textsc{G.H.M. Roelofs}, The INTEGRATOR package for
    REDUCE. Version 1.0, Memorandum 1100, Dept. Appl. Math., University of
    Twente, 1992. Available at \url{http://gdeq.org}.
  \bibitem{tools} \textsc{G.F. Post}, A manual for the package TOOLS 2.1,
    Memorandum 1331, Dept. Appl. Math., University of Twente, 1996. Available
    at \url{http://gdeq.org}.
  \bibitem{redide} \reduce IDE for \texttt{emacs}:
    \url{http://centaur.maths.qmul.ac.uk/Emacs/REDUCE_IDE/}
  \bibitem{Many} \textsc{A. V. Bocharov, V. N. Chetverikov, S. V.  Duzhin, N.
      G.  Khor{\cprime}kova, I. S.  Krasil{\cprime}shchik, A.  V.  Samokhin,
      Yu.\ N.  Torkhov, A. M. Verbovetsky and A. M.  Vinogradov}: Symmetries
    and Conservation Laws for Differential Equations of Mathematical Physics,
    I.  S.  Krasil{\cprime}shchik and A. M.  Vinogradov eds., Translations of
    Math.  Monographs \textbf{182}, Amer.\ Math.\ Soc. (1999).
  \bibitem{KKV} \textsc{P.H.M. Kersten, I.S. Krasil'shchik, A.M. Verbovetsky,}
    \emph{Hamiltonian operators and $\ell^*$-covering}, Journal of Geometry and
    Physics \textbf{50} (2004), 273--302.
  \bibitem{Mar} \textsc{M. Marvan}, \emph{Sufficient set of integrability
    conditions of an orthonomic system}.  Foundations of Computational
    Mathematics \textbf{9} (2009) 651--674.
\end{thebibliography}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/0000755000175000017500000000000011722677366022036 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/assist/genpurfn.red0000644000175000017500000003600711526203062024340 0ustar  giovannigiovannimodule genpurfn;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


smacro procedure be_last u;
delete(lastcar u, u);

% VARIOUS GENERAL PURPOSE FUNCTIONS

% 1. Generalization of functions already defined in the REDUCE kernel.

symbolic procedure rmkidnew(u);
if null u or null (u:=reval car u) then gensym() else mkid(u,gensym());

put('mkidnew,'psopfn,'rmkidnew); % Usage mkidnew() or mkidnew().

symbolic procedure list_to_ids l;
if atom l then rederr "argument for list_to_ids must be a list"
else
intern compress for each i in cdr l join explode i;

flag('(list_to_ids),'opfn);

symbolic procedure simpsetf u;
% generalizes the function "set" to kernels.
  begin scalar x;
     x := simp!* car u;
if not kernp x  or fixp (!*q2a x) then
                           typerr(!*q2a x,"setvalue kernel") else
      x:=!*q2a x;
     let0 list(list('equal,x,mk!*sq(u := simp!* cadr u)));
     return u
  end;

put ('setvalue, 'simpfn, 'simpsetf);

newtok '((!= !=) setvalue ! !=!=! );

infix ==;

flag('(prin2 ) ,'opfn); % To make it available in the alg. mode.


% 2. New functions closely related to existing ones.

symbolic procedure oddp u$
% Tests if integer U is odd. Is also defined in EXCALC;
not evenp u;

flag('(oddp),'boolean);

symbolic procedure followline(n)$
%It allows to go to a new line at the position  given by the integer N.
<< terpri()$ spaces(n)>>$

flag('(followline ) ,'opfn);

% 3. New general purpose functions.

% 3.1 To handle indexed identifiers.

symbolic procedure charnump!: x;
 if x member list('!0,'!1,'!2,'!3,'!4,'!5,'!6,'!7,'!8,'!9) then t ;

symbolic procedure charnump u;
if null u then t else charnump!: car u and charnump cdr u;

 symbolic procedure detidnum u;
 % Allows one to extract the index  from the identifier u.
 if idp u then
   begin scalar uu;
      if length(uu:= cdr explode u) =1 then go to l1
      else
        while not charnump uu do uu:=cdr uu;
   l1: uu:= compress uu;
      if fixp uu then return uu end;

flag('(detidnum),'opfn);

symbolic procedure dellastdigit u;
% Strips an integer from its last digit.
if fixp u then compress reverse cdr reverse explode u
else typerr(u,"integer");

flag('(dellastdigit),'opfn);

% 3.2 Random number generator.

symbolic procedure randomlist(n,trial);
% This procedure gives a list of trials in number "trial" of
% random numbers between 0 and n. For the algorithm see KNUTH vol. 2.
'list . lisp for j:=1:trial collect random n;

flag('(randomlist),'opfn);

% 3.3 Combinatorial functions, symmetry and sorting.

symbolic procedure transpose(l,i,j);
% i,j are integers, l is a list.
% DESTROYS the initial list.
 begin scalar tmp;
 tmp:=nth(l,i);
 nth(l,i):=nth(l,j);
 nth(l,j):=tmp;
 return l
end;

algebraic procedure combnum(n,nu)$
% Number of combinations of n objects nu to nu.
if nu>n then
rederr "second argument cannot be bigger than first argument"
else  factorial(n)/factorial(nu)/factorial(n-nu)$

symbolic procedure cyclicpermlist l;
% Gives all cyclic permutations of elements of the list l.
if atom l then nil else
 begin scalar x; integer le;
 l:=cdr l;
 le:=length l;
 x:= ('list . l) . x;
 for i:=2:le do x:=('list . (l:=append(cdr l,list car l))) . x;
 return 'list .  reversip x
end;

flag('(cyclicpermlist),'opfn);

symbolic procedure rpermutation u;
if not baglistp(u:=reval car u) then
   nil else if null cdr u then 'list . nil  else
 begin scalar x,prf$ prf:=car u$
    u:=cdr u$
    x:=for each j in  u
    conc  mapcons(permutations delete(j,u),j)$
    x:=for each j in x collect prf . j$
    return prf . x end;

put('permutations,'psopfn,'rpermutation);

symbolic procedure perm_to_num(nindl,indl);
% INPUT : 'indl' : a list of indices.
%         'nindl' : a permutation of 'indl'.
% OUTPUT : an INTEGER (between 0 and (indl)!-1 ) in one-to-one
%          correspondence with 'nindl' for the given 'indl'.
begin integer ln,fln,r,num,pos;
 nindl:=cdr nindl;
 if (ln:=length nindl)= 1 then return num;
 fln:=rnfactorial!* mkratnum ln;
 while ln>=1 do <<
                  << r:=rposition list(lastcar nindl,indl);
                    nindl:=for each j in be_last nindl collect
                       <r then nth(cdr indl,pos-1) else j
                       >>;
                    fln:=fln/ln; num:=num + (ln-r)*fln;
                   >>;
       ln:=ln-1 >>;
return num
end;

symbolic procedure num_to_perm(num,indl);
% Does the reverse job. num is an INTEGER. indl is a list of numbers.
% Constructs the corresponding permutation list starting from indl.
begin integer rk,j,f,m,lst; scalar nindl;
indl:=cdr indl;
rk:=length indl;
f:=rnfactorial!* mkratnum rk;
while rk>=1 do <<
                  <>;
                  rk:=rk-1
                >>;
return 'list . nindl
end;

flag('(perm_to_num num_to_perm),'opfn);

symbolic procedure !:comb(u)$
begin scalar x,prf; integer n;
 if length u neq 2 then
      rederr "combinations called with wrong number of arguments";
 x:=reval car u ;  if not baglistp x then return nil ;
 prf :=car x; x:=cdr x; n:=reval cadr u;
 return prf . (for each j in comb(x,n) collect prf . j)
end;

put('combinations,'psopfn,'!:comb);

put('symmetrize,'simpfn,'simpsumsym);

flag('(symmetrize),'listargp);

symbolic procedure simpsumsym(u);
% The use is SYMMETRIZE(LIST(A,B,...J),operator,perm_function)
% or SYMMETRIZE(LIST(LIST(A,B,C...)),operator,perm_function).
% Works both for OPFN and symbolic procedure functions.
% Does not yet allow odd permutations.
if length u neq 3 then rederr("3 arguments required for symmetrize")
else
begin scalar uu,x,res,oper,fn,bool,boolfn; integer n;
  fn:= caddr u;
  if not(gettype fn eq 'procedure) then typerr(fn,"procedure");
  uu:=(if flagp(fn,'opfn) then <>
          else cdr reval x) where x=car u;
  n:=length uu;
  oper:=cadr u;
   if not idp oper then typerr(oper,"operator") else
   if null flagp(oper,'opfn) then
     if null get(oper,'simpfn) then put(oper,'simpfn,'simpiden);
     flag(list oper, 'listargp);
  x:=if listp  car uu and not boolfn then
                <> else
     if boolfn and listp cadr uu then
                <> else
                        apply1(fn,uu);
  if flagp(fn,'opfn) then x:=alg_to_symb x;
  n:=length x -1;
  if not bool then <<
 res:=( oper . car x) .** 1 .* 1 .+ nil;
 for i:=1:n do << uu:=cadr x; aconc(res,(oper . uu) .** 1 .* 1 );
                                       delqip(uu,x);>>;
           >>
  else
 << res:=(oper . list('list .
      for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil;
    for i:=1:n do << uu:=cadr x;
    aconc(res,(oper . list('list .
          for each i in uu collect mk!*sq simp!* i)) .** 1 .* 1 );
     delqip(uu,x);>>;
  >>;
  if get(oper,'opmtch) or flagp(oper,'opfn) then
        res:=resimp( res ./ 1) else res:=res ./ 1;
return  res
end;

symbolic procedure sortnumlist l;
% Procedure valid only for list of integers.
% Returns the sorted list without destroying l.
'list . (if length x < 10 then bubblesort1 x else
   quicksort_i_to_j(x,1,length x)) where x=cdr l ;

flag('(sortnumlist),'opfn);

symbolic procedure sortlist(l,fn);
if numlis cdr l  then
      if fn eq 'lessp  then sortnumlist l else
      if fn eq 'geq then
      ( 'list . (reverse(if length x <10 then bubblesort1 x else
               quicksort_i_to_j(x,1,length x))) where x=cdr l) else
                             nil else
'list . bubsort1(cdr l,fn);

flag('(sortlist),'opfn);

symbolic procedure bubblesort1 l;
% Elements of l are supposed to be numbers.
begin integer ln;
ln:=length l;
for i:=1:ln do
    for j:=i+1:ln do
           if i neq j and nth(l,i)>nth(l,j) then
            transpose(l,i,j) else nil;
return l
end;

symbolic procedure bubsort1(l,fn);
% Elements of l are numbers or identifiers.
% fn is any ordering function.
begin integer ln;
ln:=length l;
for i:=1:ln do
    for j:=i+1:ln do
           if i neq j and
                apply2(fn,nth(l,j),nth(l,i)) then
            transpose(l,i,j) else nil;
return l
end;

symbolic procedure find_pivot_index(l,i,j);
% l is the list, i and  j are integers.
begin scalar key; integer k;
key:=nth(l,i);
k:=i+1;
a: if k=j+1 then return -1;
if nth(l,k) > key then return k else
if nth(l,k) < key then return i;
 k:=k+1; go to a
end;

symbolic procedure partition(l,i,j,pivot);
% Writes l, all elements less than  pivot to the left
% and elements greater or equal to the right of pivot.
% returns the new pivot.
begin integer le,ri;
le:=i; ri:=j;
a: if le>ri then return le;
     transpose(l,le,ri);
while nth(l,le) < pivot do le:=le+1;
   while nth(l,ri) >= pivot do ri:=ri-1;
   go to a
end;

symbolic procedure quicksort_i_to_j(l, i,j);
begin integer k,pi;
pi:=find_pivot_index(l,i,j);
return if pi neq -1 then
        <>
        else l
end;

symbolic procedure algsort(u,v);
% Based on the PSL sort function.
% May replace all the above functions.
symb_to_alg sort(alg_to_symb u,v);

symbolic operator algsort;

% 4. Functions to check various properties of objects in a list and extract
%    them.

symbolic procedure checkproplist1(l,fn);
% Checks if the list l has the property defined by the function fn.
% fn should preferably be  'function '.
 if null l then t else
 if fn eq 'numberp then
   if apply1(function evalnumberp, car l) then checkproplist1(cdr l,fn)
    else  nil else
 if fn eq 'floatp then
    if atom car l then nil else
    if apply1(function floatp, cdar l ) then checkproplist1(cdr l,fn)
    else nil else
 if get(fn,'number!-of!-args)=1  then
    if apply1(fn,car l) then checkproplist1(cdr l,fn)
    else  nil else
 if get(fn,'number!-of!-args)=2 then
    if apply(fn,list(car l,cadr l)) then checkproplist1(cdr l,fn)
 else nil;

symbolic procedure checkproplist(l,fn);
% fn may be the name of a function or the expression 'function  1 then
   rederr("UNARY boolean function required as argument") else
 'list . extractlist1(cdr l,fn)) where x=get(fn,'number!-of!-args);

flag('(extractlist),'opfn);

% 5. Flags and properties in the ALGEBRAIC mode.

symbolic procedure putflag(u,flg,b)$
% Allows one to put or erase any FLAG on the identifier U.
% U is an idf or a list of idfs, FLAG is an idf, B is T or 0.
if not idp u and not null baglistp u then
              <>
 else      if idp u and b eq t then
            <>
 else      if idp u and b equal 0 then
            <>
 else rederr "*** VARIABLES ARE (idp OR list of flags, T or 0).";

symbolic procedure putprop(u,prop,val,b)$
% Allows to put or erase any PROPERTY on the object U
% U is an idf or a list of idfs, B is T or 0$
if not idp u and baglistp u then
              <>
 else      if idp u and b eq t then
            <>
 else      if idp u and b equal 0 then
            <>
 else rederr "*** VARIABLES ARE (idp OR list of idps, T or 0).";

flag('(putflag putprop),'opfn)$

symbolic procedure rdisplayprop(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,val,aa$ x:=reval car u; val:=reval cadr u;
for each j in !:proplis do if car j eq x and cadr j eq val
                          then aa:=('list . cdr j) . aa;
return if length aa =1 then first aa else 'list . aa
end;

put('displayprop,'psopfn,'rdisplayprop)$

put('displayflag,'psopfn,'rdisplayflag)$

symbolic procedure rdisplayflag(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,aa$ x:=reval car u;
 for each j in !:flaglis do if car j=x then aa:=cons(cadr j,aa)$
 return 'list . aa end;

symbolic procedure clrflg!: u;
for each x in !:flaglis do
            if u eq car x then putflag(car x,cadr x,0) ;

symbolic procedure clearflag u;
% If u equals "all" all flags are eliminated.
% If u is a1,a2,a3.....an flags of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:flaglis
          do putflag (car x,cadr x,0) else
 if null cdr u then clrflg!: car u else
                for each  y in u do clrflg!: y;

symbolic procedure clrprp!: u;
for each x in !:proplis do
          if u eq car x then putprop(car x,cadr x,caddr x,0);

symbolic procedure clearprop u;
% If u equals "all" all properties are eliminated.
% If u is a1,a2,a3...an properties of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:proplis
          do putprop(car x,cadr x,caddr x,0) else
if null cdr u then clrprp!: car u else
                for each  y in u do clrprp!: y;

put('clearflag,'stat,'rlis);

put('clearprop,'stat,'rlis);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/vectorop.red0000644000175000017500000001103111526203062024343 0ustar  giovannigiovannimodule vectorop;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This small module makes basic operation between EXPLICIT
% vectors available. They are assumed to be represented by
% BAGS or LISTS.
% Mixed product is restricted to 3-space vectors.
                ;
symbolic procedure depthl1!: u;
 if null u then t else (caar u neq 'list) and depthl1!: cdr u;

symbolic procedure depthl1 u;
not null getrtype u and  depthl1!: cdr u;

symbolic procedure !:vect(u,v,bool);
   %returns a list whose elements are the sum of each  list elements.
   % null v check not necessary;
   if null u then nil
else  addsq(car u,if null bool then car v else negsq car v)
                                          . !:vect(cdr u,cdr v,bool);
symbolic procedure rsumvect(u);
begin scalar x,y,prf;
x:=reval car u;y:=reval cadr u; prf:=car x;
 if (rdepth list x = 0) or (rdepth list y = 0) then
    rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,nil) collect mk!*sq j) end;

put('sumvect,'psopfn,'rsumvect);

symbolic procedure rminvect(u);
begin scalar x,y,prf;
x:=reval car u;y:=reval cadr u; prf:=car x;
 if (rdepth list x = 0) or (rdepth list y = 0) then
    rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,'minus) collect mk!*sq j) end;

put('minvect,'psopfn,'rminvect);

symbolic procedure !:scalprd(u,v);
   %returns scalar product of two lists;
   if null u and null v then nil ./ 1
    else addsq(multsq(car u,car v),!:scalprd(cdr u,cdr v));

symbolic procedure sscalvect(u);
begin scalar x,y;
  x:=reval car u;y:=reval cadr u;
 if (rdepth list x = 0) or (rdepth list y = 0) then
     rederr " both arguments must be of depth 1 " else
 if length x neq length y then rederr "vector mismatch";
  x:=cdr x; y:=cdr y;
  x:=for each j in x collect simp!* j;
  y:=for each j in y collect simp!* j;
 return mk!*sq !:scalprd(x,y)
end;

put('scalvect,'psopfn,'sscalvect);

symbolic procedure !:pvect3 u;
begin scalar x,y; integer xl;
 if (rdepth list car u = 0) or (rdepth cdr u = 0) then
    rederr " both arguments must be of depth 1 " else
 x:=reval car u;y:=reval cadr u;
 if (xl:=length x) neq 4 then rederr "not 3-space vectors" else
 if xl neq length y then rederr "vector mismatch" ;
 x:=cdr x; y:=cdr y;
 x:=for each j in x collect simp!* j;
 y:=for each j in y collect simp!* j;
 return
 list( addsq(multsq(cadr x,caddr y),negsq multsq(caddr x,cadr y)),
        addsq(multsq(caddr x,car y),negsq multsq(car x,caddr y)),
         addsq(multsq(car x,cadr y),negsq multsq(cadr x,car y)))
end;

symbolic procedure rcrossvect u;
% implemented only with LIST prefix;
'list . (for each j in !:pvect3 u collect mk!*sq j);

put ('crossvect,'psopfn,'rcrossvect);

symbolic procedure smpvect u;
begin scalar x;
if  (rdepth list car u =0) then
    rederr " arguments must be of depth 1 "  else
x:=reval car u; u:=cdr u;
x:=cdr x;
if length x neq 3 then rederr " not 3-space vector";
x:=for each j in x collect simp!* j;
return mk!*sq !:scalprd(x,!:pvect3 u) end;

put('mpvect,'psopfn,'smpvect);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/switchxt.red0000644000175000017500000000301411526203062024361 0ustar  giovannigiovannimodule switchxt;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


switch distribute;

flag('(!*factor !*mcd !*div !*exp !*gcd !*rat !*rational !*rationalize
        !*intstr !*reduced !*ratpri !*revpri !*distribute
        !*ezgcd !*complex !*reduced !*lcm !*precise),'share)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/backtrck.red0000644000175000017500000000746111526203062024302 0ustar  giovannigiovannimodule backtrck;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(g_skip_to_level);

symbolic procedure generate_next_choice(sc, partial_perm, canon);
  begin scalar
              next_perm, comparison, extensions;
       integer
              n_points,  len, next_img;
  n_points := upbve(car sc);
  g_skip_to_level := len := upbve(partial_perm) + 1;
  next_img := 1;
  sc_setbase(sc, partial_perm);
  repeat
    <<
    extensions := candidate_extensions(sc, partial_perm);
    if (member(next_img, extensions)) then
      <<
      next_perm := vectappend1(partial_perm, next_img);
      if acceptable(next_perm) then
        <<
        assign(next_perm);
        comparison := compare(next_perm, canon);
        if comparison = 0 then           % 0 = indifferent
          <<
          if len < n_points then
            canon := car generate_next_choice(sc, next_perm, canon)
        else if canon then
        process_new_automorphism(sc,
                           pe_mult(pe_inv(canon), next_perm));
          >>
        else if comparison = 1 then      % 1 = better
          if len < n_points then
            canon := car generate_next_choice(sc, next_perm, canon)
          else
            canon := copy(next_perm);
        deassign(next_perm)
        >>
      >>;
    next_img := next_img + 1
    >>
  until (next_img > n_points) or (len > g_skip_to_level);
  return canon . sc;
  end;

symbolic procedure candidate_extensions(sc, partial_perm);
  begin   scalar extensions;
 %        integer count;
    if null sc_stabdesc(sc, upbve(partial_perm) + 1) then
    extensions := for count := 1:upbve(car sc) collect count
    else
    extensions := venth(venth(cdr sc, upbve(partial_perm) +1), 5);
 % remove elts of partial_perm from extensions
    for count := 1: upbve(partial_perm) do
    extensions := delete(venth(partial_perm, count), extensions);
  return extensions;
  end;


symbolic procedure process_new_automorphism(sc, new_aut);
  begin scalar inv_new_aut, sd;
        integer count;
   inv_new_aut := pe_inv(new_aut);
%% update stab chain
   count := 0;
   repeat
    <<
    count := count + 1;
    sd := sc_stabdesc(sc, count);
    if null sd then
      sd := sd_create(upbve(car sc), venth(car sc, count));
    sd_addgen(sd, new_aut, inv_new_aut);
    putve(cdr sc, count, sd)
    >>
   until (pe_apply(new_aut, venth(car sc, count)) neq
                                          venth(car sc, count));
    g_skip_to_level := count;
  end;

symbolic procedure canon_order(n);
  begin scalar aut_sc;
  aut_sc := sc_create(n);
  return generate_next_choice(aut_sc, mkve(0), nil);
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/gentens.red0000644000175000017500000005250411526203062024157 0ustar  giovannigiovannimodule gentens;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module defines the characteristics of 'generic' tensors.
% 'generic' means: any nimbers of indices, no transformation
% properties under coordinate transformations assumed, any space
% assignement allowed.
% TENSOR  calls make_tensor which applies on the list of IDP the
% following properties:
% Flags: tensor, full
% Properties: indvarprt, xindvarprt_tens  for printing indices.
%           : SIMPTENSOR for simplification.
%           : Presently used to construct a correct list of indices.
% All arguments are NOT supposed to be tensor-indices. So
% dependencies may be either IMPLICIT ir EXPLICIT.

lisp remflag(list 'minus,'intfn);

fluid '(ycoord!* ymax!* ymin!* obrkp!*);

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!*));

% g_dvnames is a vector.


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

rlistat('(tensor rem_tensor rem_value_tens));

flag('(make_bloc_diagonal),'opfn);

symbolic procedure make_bloc_diagonal te;
% te is a generic tensor. Forces it to be bloc
% diagonal when several spaces are involved.
<>;

symbolic procedure rem_value_tens u;
% remove values of the components of tensors included in u
 << for each x in u do
     if atom x then remprop(x,'kvalue)
      else
     if listp x then
       begin scalar kval,tens,varl,ind;
         tens:=car x;
         kval:=get(tens,'kvalue);
         remprop(tens,'kvalue);
         varl:= splitlist!:(x,'list);
         ind:=if null varl then cdr x else setdiff(cdr x,varl);
         varl:=if varl then car varl;
         ind:= (lambda y;
                 (mkindxlist for each z in y collect revalind z)) ind;
         kval:=delete(assoc(if varl then tens . varl . ind
                                 else tens . ind,kval),kval);
         put(tens,'kvalue,kval);
      end; t>>;

symbolic procedure rem_tensor1 x;
<>;

symbolic procedure elim_names u;
% u is the name of a particular tensor
 if get(u,'partic_tens)='simpdelt then remprop('delta,'name)
  else
 if get(u,'partic_tens)='simpdel then remprop('del,'name)
  else
 if get(u,'partic_tens)='simpeta then remprop('eta,'name)
  else
 if get(u,'partic_tens)='simpepsi then remprop('epsilon,'name)
  else
 if get(u,'partic_tens)='metric then remprop('metric,'name);


symbolic procedure tensor u;
% this is the basic constructor for the tensor object.
 begin;
 u:= for each x in u collect reval x; % correction
  for each x in u do
 if get(x,'avalue) or (flagp(x,'reserved) and null flagp(x,'tensor))
     or getrtype x  or (gettype x eq 'procedure)
     or (x memq list('sin,'cos,'tan,'atan,'acos,'asin,'int,'df))
    then rerror(cantens,1,list(x,"may not be defined as tensor"))
   else make_tensor(x,t);
   return t
 end;


symbolic procedure make_tensor(u,v);
 <>;

symbolic procedure rem_tensor u;
% To erase tensor properties on the list of identifiers u.
 <>;

symbolic procedure tensorp u;
% Elementary function to detect tensors.
 not atom u and flagp(car u,'tensor);

symbolic procedure tensorp!: u;
% u is a list of kernel as it comes from the
% function list_of_factors applied to a standard term.
% returns the number of tensor kernel present.
  begin integer nt;
  <>;
  return nt
end;

 flag(list('make_tensor_belong_space),'opfn);

symbolic procedure make_tensor_belong_space(te,sp);
% te must be a tensor identifier
% introduces the indicator 'belong_to_space
% sp is a space name
% First, if no space is defined, it is, by default, unique
% and nothing should be done.
  if !*onespace then nil
   else
   if flagp(te,'tensor) then
      if get(te,'partic_tens) eq 'simpepsi then
       <>
         else  put(te,'belong_to_space,sp);


rlistat '(make_tensor_belong_anyspace);

symbolic procedure make_tensor_belong_anyspace u;
% replace the list of tensors u in the ON ONESPACE
% environment.
 <>;
 t>>;

symbolic procedure simptensor u;
% Basic simplification procedure for all tensors.
 begin scalar x,ind,func,varl,bool,lsym;
    varl:= splitlist!:(u,'list); % gives ((list ...)) or nil.
   if null varl then
          (if z then <>)where z=extract_vars cdr u;
   ind:=if null varl then cdr u else setdiff(cdr u,varl);
   varl:=if  bool then 'list . varl
            else
           if varl then car varl;
    varl:= reval varl;
    x:= (lambda y;
            mkindxlist for each z in y collect revalind z) ind;
    x:=for each j in x collect reval j; % if substitutions are made.
    x:= (lambda y;
            mkindxlist for each z in y collect revalind z) x;
   x:=car u . x;
  % identify the possible 'dummy indices':
    ind:=split_cov_cont_ids cdr x;
   % Check numeric indices:
    num_ids_range(ind,car u);
    mk_dummy_ids ind;
   % verify if the set of dummy indices is consistent:
    verify_tens_ids ind;
   % if u is chosen bloc-diagonal then check the input
   % and, if symbols belong to different subspaces return 0
    if
      (if x  then apply1(x,ind))where x=get(car u,'bloc_diagonal)
      then return nil ./ 1;
   % If u is a special tensor then apply the relevant simplification
   % function:
    return if func:=get(car x,'partic_tens) then
                   if flagp(car u,'generic)  then
                       if func neq 'simpdelt then apply2(func,x,varl)
                         else apply2(func,x,varl) ./ 1
                    else  apply1(func,x) ./ 1
            else
           if flagp(car x,'symmetric) then
                            mksq(car x .
             if null varl then cont_before_cov ordn cdr x
                 else varl .  cont_before_cov ordn cdr x,1)
            else
           if flagp(car x,'antisymmetric) then
             if repeats
                  (if null affinep u then
                      (lambda y; append(car y,cadr y)
                                            )split_cov_cont_ids cdr x
                     else cdr x)
                            then nil ./ 1
               else
             (if not permp!:(z,cdr x) then
                      negsq mksq(car x . if varl then varl . z
                                          else z,1)
              else mksq(car x . if varl then varl . z
                                 else z,1)
              )where z= cont_before_cov ordn cdr x
            else
           % cases of partial symmetry
           % when the tensor is 0 it is advantageous to detect it
           % BEFORE canonical acts:
           if lsym:=get(car u,'symtree) then
             if symtree_zerop(cdr x,lsym) then nil ./ 1
                  else
                 mksq(if varl then car x . varl . cdr x else x,1)
           else
              mksq(if varl then car x . varl . cdr x else x,1)

 end;

%symbolic procedure current_princ_index_lst(u,v);
 % u is the tensor-kernel, v is its number of indices.
 % it returns a list of the form
 % ((id_tens1 (index1 . 1) (index2 . 2)...))
 % for instance:
 % ((tt (a . 1) ((minus b) . 2) (c . 3) (d . 4)))
 % for the currently handled tensors tt(a,-b,c,d).
 % From it one may extract all informations.
 % subla(v,'tt); ==>
 % ((a . 1) ((minus b) . 2) (c . 3) (d . 4))
 % it is also obtained from the macro 'extract_index_tens'.
% begin integer n;
%       scalar x,id_tens;
%    n:=1;
%    id_tens:=car u;
%    u:=cdr u;
%    while n leq v do
%           <>;
%    return (id_tens . reverse x) . nil
%end;

%symbolic procedure get_n_index(n,u);
 % u is the ouput of the smacro extract_index_tens.
 % n is an integer which corresponds to the index position.
 % gives the corresponding index.
 % it is an atom if contravariant.
 % it is a list which begins by 'minus' if it is
 % covariant.
% if n <= length u then car assoc2(n,u);

%symbolic procedure index_list u;
 % u is the ouput of extract_index_tens.
 % gives the list of indices without their positions
 % order in the list corresponds to the order of indices
 % for instance:
 % (a (minus b) c d) for tt(a,-b,c,d)
 % when the tensor is given explicitly in prefix form,
 % it is better to take the cdr of this form.
 %  begin scalar x;
 %   for i:=1:length u do  x:=get_n_index(i,u) . x;
 %   return reversip x
%end;

symbolic procedure split_cov_cont_ids u;
 % output is the composite list ((cov_indices)(cont_indices))
 % INPUT u is the output of 'index_list' or is simply the cdr
 % of the prefix form.
 begin scalar xcov,xcont;
 while u do << (if careq_minus y then xcov:= (raiseind y) . xcov
               else xcont := y . xcont)where y=car u; u:=cdr u>>;
 return list(reversip xcov,reversip xcont)
end;

symbolic procedure verify_tens_ids u;
% u is the output of split_cov_cont_ids
  begin scalar cov,cnt;
   cov:= car u;
   cnt:=cadr u;
   % eliminate the obviously misplaced dummy indices:
   % i.e. when a dummy index is at least TWICE in cov or cont
      if repeats extract_dummy_ids cov  or
         repeats extract_dummy_ids cnt then
   rerror(cantens,2,
            list(list(car u, cadr u),
             "are inconsistent lists of indices"))

   else return  t

 end;

rlistat '(make_variables remove_variables);

symbolic procedure make_variables u;
% u is a list of idp's.
% declare them as variables.
% allow to distinghish them from indices.
 <>;

symbolic procedure remove_variables u;
% u is a list of idp's.
% declare them as variables.
% allow to distinghish them from indices.
 <>;

symbolic procedure extract_vars u;
 if null u then nil
  else
 if flagp(raiseind!: car u,'variable) then car u . extract_vars cdr u
  else extract_vars cdr u;

symbolic procedure select_vars u;
% used for SYMMETRIZE.
% use extract_vars
 begin scalar varl,ind,bool;
    varl:= splitlist!:(u,'list); % gives ((list ...)) or nil.
   if null varl then
          (if z then <>)where z=extract_vars cdr u;
   ind:=if null varl then cdr u else setdiff(cdr u,varl);
   varl:=if  bool then 'list . varl
            else
           if varl then car varl;
    return list(ind,varl)
 end;

symbolic procedure symb_belong_several_spaces ind;
% ind is the list  which comes from split_cov_cont_ids
if !*onespace then nil
 else
   begin scalar x,sp;
     x:=clean_numid flattens1 ind;
     while x and
      (null get(car x,'space) or get(car x,'space) eq 'wholespace)
         do x:= cdr x;
     if null x then return nil
      else
        while x and (null get(car x,'space)  or
                      get(car x,'space) eq 'wholespace) do x:=cdr x;
      sp:=get(car x,'space);
     while x and (null get(car x,'space) or
             get(car x,'space) eq 'wholespace or
             get(car x,'space) eq sp) do  x:=cdr x;
    return
     if null x then nil else t
end;

symbolic procedure num_ids_range(ind,tens);
% this procedure checks the validity of numeric indices in various
% cases
if !*onespace then
    if out_of_range(ind,dimex!*,nil) then
       rerror(cantens,3,"numeric indices out of range")
     else nil
 else % onespace is OFF.
      % verify if the tensor belong to a subspace:
if null numindxl!* then
    if out_of_range(ind,get_dim_space get(tens,'belong_to_space),
         get_sign_space get(tens,'belong_to_space))
       then   rerror(cantens,3,"numeric indices out of range")
    else  nil
 else  (if null lst_belong_interval(x,int) then
         rerror(cantens,3,"numeric indices do not belong to (sub)-space")
        )where x=extract_numid flattens1 ind,
                int=subla(numindxl!*,get(tens,'belong_to_space));


symbolic procedure restore_tens_idx(u,v);
 % u is a dummy-compatible list,
 % v is the original list of indices given by
 % index_list extract_intex_tens  or cdr .
 % result is the new index_list
 % exemple:
 % u=(d (minus b) a a), v=(a (minus b) c (minus c))
 % restore_tesn_idx(u,v); ==> (d (minus b) a (minus (a)))
 if null u then nil
  else
 if null memq(car u,dummy_id!*) then car u . restore_tens_idx(cdr u,cdr v)
  else
 if atom car u and atom car v then car u . restore_tens_idx(cdr u,cdr v)
  else
 lowerind u . restore_tens_idx(cdr u,cdr v);

symbolic procedure clean_numid u;
 % input is a list of indices.
 % output is a list of 'non-numeric' indices.
 % 11 is the biggest allowed integer
  if null u then nil
   else
 if !*id2num car u then clean_numid cdr u
  else car u . clean_numid cdr u;

symbolic procedure extract_num_id u;
% extract all pseudo-numeric indices from u.
 if null u then nil
  else
 if charnump!: car u then car u . extract_num_id cdr u
  else extract_num_id cdr u;

symbolic procedure extract_numid u;
 % input is a list of indices.
 % output is a list of the corresponding 'numeric' indices.
 % 13 is the biggest allowed integer
  if null u then nil
   else
 (if x  then x . extract_numid cdr u
  else extract_numid cdr u)where x=!*id2num car u;

symbolic procedure mkindxlist u;
% CONSTRUCTS THE COVARIANT and CONTRAVARIANT numeric INDICES.
 for each j in u collect
   if fixp j then !*num2id j else
       if pairp j and fixp cadr j then list('minus, !*num2id cadr j)
                                  else j;

symbolic procedure !*num2id u;
 %CONVERTS A NUMERIC INDEX TO AN ID;
 %TAKEN FROM EXCALC.
    if u<12 then intern cdr assoc(u,
              '((0 . !0) (1 . !1) (2 . !2) (3 . !3) (4 . !4)
                (5 . !5) (6 . !6) (7 . !7) (8 . !8) (9 . !9)
                 (10 . !10) (11 . !11) (12 . !12) (13 . !13)))
   else intern compress append(explode '!!,explode u);

symbolic procedure !*id2num u;
 %CONVERTS AN INDEX TO A NUMBER OR nil IS RETURNED.
 begin scalar x ;
   if x:=  assoc(u, pair_id_num!*) then
    return cdr x
end;

symbolic procedure num_indlistp u;
% returns True if the list of indices
% contains ONLY numeric indices.
 numlis for each y in u collect !*id2num y;

symbolic procedure out_of_range(u,dim,sign);
% dim represents the
% actual space dimension of the space.
% acts only when it is an integer.
% dimsub represents  the subspace signature
% u is the list generated by split_cov_cont_ids
 if fixp dim then
  begin scalar lu,sign_space;
   lu:=extract_numid flattens1 u;
   sign_space:=if null sign then signat!* else sign;
   while lu and
        (if sign_space=1 then car lu < dim
          else
         if sign_space =0 then car lu <=dim)
                                do lu:=cdr lu;
    return if lu then t else nil
  end;

symbolic procedure revalind u;
 % Pour que -0 ne devienne pas +0:
    begin scalar x,y,alglist!*;
      x := subfg!*;
      subfg!* := nil;
      u := subst('!0,0,u);
      % The above line is used to avoid the simplification of -0 to 0.
      y := prepsq simp u;
      subfg!* := x;
      return y
   end;

symbolic procedure revalindl u;
for each ind in u collect revalind ind;

symbolic procedure indvarprt u;
% An extension of the corresponding function of EXCALC
    if null !*nat then <>
     else begin scalar x,y,y2,args,spaceit; integer l,maxposn!*,oldy;
            l := flatsizec flatindxl u+length cdr u-1;
            if l>(linelength nil-spare!*)-posn!* then terpri!* t;
            %avoid breaking of an indexed variable over a line;
            y := ycoord!*;
            maxposn!*:=0;
            prin2!* car u;
            spaceit := if get(car u,'partic_tens) memq {'simpdelt,'simpdel}
                         then  << x := posn!*; nil>>
                         else t;
            for each j on cdr u do
              <maxposn!* then maxposn!*:=posn!*;
                     posn!*:=x;
                  >>;
                if ycoord!*>ymax!* then ymax!* := ycoord!*;
                if ycoord!*>;
            if null cdr u then
              <ymax!* then ymax!* := ycoord!*;
                if ycoord!*>;
            ycoord!* := y;
            if (maxposn!*>0) and (posn!*>;
          end;

put('indvarprt,'expt,'inbrackets);

symbolic procedure xindvarprt_tens(l,p);
  % An extension of the function XINDVARPRT of  EXCALC.
  fancy!-level
  ( if not(get('expt,'infix)>p) then
      fancy!-in!-brackets({'xindvarprt_tens,mkquote l,0}, '!(,'!))
    else
      begin scalar w,x,s,args,spaceit;
        spaceit:=t;
        w:=(fancy!-prefix!-operator car l) where fancy_lower_digits = nil;
                 if get(car l,'partic_tens) memq {'simpdelt,'simpdel}
                                  then spaceit:=nil;
        if w eq 'failed then return w;
        l := cdr l;
        if l then
          <<
          while l and (w neq 'failed) do
            << if (atom car l) or (careq_tilde car l) then
                 (if s eq '!^ then
                    x := car l . x
                  else <<
                    if s then
                      <>;
                    x := {car l};
                    s := '!^>> )
               else (
                 if careq_minus(car l) then
                   ( if s eq '!_
                     then x := cadar l . x
                     else <<
                       if s then
                         <>;
                       x := {cadar l};
                       s := '!_>> )
                 else
                   args:=car l);
              l := cdr l>>;
          if x then
            << if spaceit then fancy!-prin2!*("{}",0);
               w := fancy!-print!-indexlist1(reversip x,s,nil);
               if w eq 'failed then return w >>;
          if args then w:=fancy!-print!-function!-arguments cdr args;
          >>
            else
          <<
             w := fancy!-print!-indexlist1(list('!(,'!)),'!^,nil)
          >>;
       return w;
   end);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/control.red0000644000175000017500000004420511526203062024173 0ustar  giovannigiovannimodule control;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*revpri);

global '(!:flaglis !:proplis indices!*);

switch distribute;

% functions which offer a BETTER CONTROL on various objects.

% 1. BOOLEAN functions.

symbolic procedure nordp(u,v);
% TRUE if a>b, FALSE if a=> else wi:=cdr wi $
  return aa:='list . aa end >>;

put('funcvar,'psopfn ,'rfuncvar);

flag('(e i),'reserved);

symbolic procedure implicit u;
if atom u then u else
 begin scalar prf;
 prf:=car u;
 if get(prf,'simpfn) neq 'simpiden  then
                  rederr list(u,"must be an OPERATOR");
 remprop(car u,'simpfn);
 depl!*:=union(list (car u . reverse
           for each y in cdr u collect implicit y),depl!*);
return prf end;

symbolic procedure depatom a$
%Gives a list of variables declared in DEPEND commands whom A depends
%A must be an atom$
    if not atom a then rederr("ARGUMENT MUST BE AN ATOM") else
         if null assoc(a,depl!*) then a  else
                            'list . reverse cdr assoc(a,depl!*);
flag('(depatom),'opfn);

symbolic procedure explicit u$
% U is an atom. It gives a function named A which depends on the
% variables detected by DEPATOM and this to all levels$
begin scalar aa$
    aa:=depatom u $
    if aa = u then  return u$
    put(u,'simpfn,'simpiden)$
    return u . (for each x in cdr aa collect explicit x) end$

flag('(implicit explicit),'opfn);

symbolic procedure simplify u;
% Enforces simplifications if necessary.
% u is any expression.
 mk!*sq resimp simp!* reval u;

flag('(simplify),'opfn);

% This function is for dummy.red:

rlistat('(remnoncom));

symbolic procedure remnoncom u;
<>;

% To have a better control on the HEPHYS package.

symbolic procedure remvector u;
for each x in u do <>;

symbolic procedure remindex u;
begin;
  for each x in u do <>;
 return t
end;

rlistat('(remvector remindex));

symbolic procedure mkgam(u,v);
% u is supposed to be an idp. v equals either t or another idp.
 if v neq t then
 <>
 else
 <>;

symbolic operator getmas, mkgam;


% 3. Control of SWITCHES.

symbolic procedure switches;
%This procedure allows to  see the values of the switches chosen.
<>;

symbolic procedure switchorg$
%It puts all switches relevant to current algebra calculations to
% their initial values.
<< !*exp:=t;
   !*allfac:=t;
   !*gcd:=nil;
   !*mcd:=t;
   !*div:=nil;
   !*rat:=nil;
   !*distribute:=nil;
   !*intstr:=nil;
   !*rational:=nil;
   !*ezgcd:=nil;
   !*ratarg:=nil;
   !*precise:=t;
   !*complex:=nil;
   !*heugcd:=nil;
   !*lcm:=t;
   !*factor:=nil;
   !*ifactor:=nil;
   !*rationalize:=nil;
   !*reduced:=nil;
   !*savestructr:=nil;
   !*combineexpt:=nil;
   !*revpri:=nil>>;

flag('(switchorg ),'opfn)$

deflist('((switches endstat) (switchorg endstat) ),
           'stat)$

% 4. Control of USER DEFINED objects.

% The procedures below allow to extract from the history of the
% INTERACTIVE run in the ALGEBRAIC mode the data previously
% defined by the user.
% It DOES NOT give insights on operations done
% in the SYMBOLIC mode.

symbolic procedure remvar!:(u,v)$
% This procedure traces and clear both assigned or saved scalars and
% lists.
 begin scalar buf,comm,lv;
     buf:=inputbuflis!*;
     for each x in buf do if not atom (comm:=caddr x)
                                 and car comm = 'setk then
  begin scalar obj;
  l1: if null cddr comm  or car comm eq 'prog then return lv;
         obj:=cadadr comm;
       if  gettype obj  eq v then
     lv:=adjoin(obj,lv);
         comm:=caddr comm;
         go to l1  end;
 if null u then
    <> else return lv
     end;

flag('(displaylst displayscal),'noform);

symbolic  procedure displayscal;
% Allows to see all scalar variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
 union(remvar!:(t,'scalar),remsvar!:(t,'scalar));

symbolic  procedure displaylst$
% Allows to see all list variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
  union(remvar!:(t,'list),remsvar!:(t,'list)) ;

symbolic procedure clearscal$
% Allows to clear all scalar variables introduced
% DIRECTLY ON THE CONSOLE;
<>$

symbolic procedure clearlst$
% Allows to clear all list variables introduced
% DIRECTLY ON THE CONSOLE;
<>;

symbolic procedure remsvar!:(u,v)$
 begin scalar buf,comm,lsv,obj;
     buf:= inputbuflis!*;
     for each x in buf do
      if not atom (comm:=caddr x) and car comm eq 'saveas then
         if  v eq t then
             if gettype (obj:=cadr cadadr comm)
                  member list('scalar,'list,'matrix,'hvector,'tvector)
                  then lsv:=adjoin(obj,lsv)
             else nil
         else if v eq gettype (obj:=cadr cadadr comm)
                  then lsv:=adjoin(obj,lsv);
%     lsv:= !:mkset lsv$
    if null u then
    <> else return lsv
     end;

flag('(displaysvar),'noform);

symbolic  procedure displaysvar;
% Allows to see all variables created by SAVEAS.
remsvar!:(t,t) ;

symbolic  procedure clearsvar;
% Allows to clear  all variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
remsvar!:(nil,t);

symbolic procedure rema!:(u);
% This function works to trace or to clear arrays.
 begin scalar buf,comm,la$
     buf:=inputbuflis!*$
     for each x in buf do if not atom (comm:=caddr x) and
                car comm eq 'arrayfn then
     begin scalar arl,obj;
         arl:=cdaddr comm;
     l1: if null arl then return la else
           if gettype (obj:=cadadr car arl ) eq 'array then
             la:=adjoin(obj,la);
         arl:=cdr arl$
         go to l1  end$
  if null u then
   <> else return la
 end;

flag('(displayar),'noform);

symbolic  procedure displayar;
% Allows to see all array variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
 rema!:(t)$

symbolic procedure clearar;
% Allows to clear array variables introduced
% DIRECTLY ON THE CONSOLE;
rema!:(nil)$

symbolic procedure remm!:(u)$
% This function works to trace or to clear matrices. Be CAREFUL to use
% the declaration MATRIX on input (not m:=mat(...) directly).
% declaration MATRIX ..
%x ==> (97 SYMBOLIC (MATRIX (LIST (LIST (QUOTE MM) 1 1))))
% Declaration MM:=MAT((...))
% x==>(104 ALGEBRAIC
%       (SETK (QUOTE M2) (AEVAL (LIST (QUOTE MAT) (LIST 1) (LIST 1)))))
 begin scalar buf,comm,lm;
     buf:= inputbuflis!*;
  for each x in buf do if  not atom (comm:=caddr x) and
                           car comm eq 'matrix then
      begin scalar lob,obj;
      lob:=cdadr comm;
   l1: if null lob then return lm else
       if gettype(obj:=if length car lob = 2 then cadr car lob else
                    cadadr car lob) then
          lm:=adjoin(obj,lm);
      lob:=cdr lob;
      go to l1  end$
  lm :=union(lm,remvar!:(t,'matrix));
 if null u then
 <> else return lm
end;

flag('(displaymat),'noform);

symbolic procedure displaymat$
% Allows to see all variables of matrix type
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union( remm!:(t),remsvar!:(t,'matrix));

symbolic procedure clearmat$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<>;

symbolic procedure remv!:(u)$
% This function works to trace or to clear vectors.
 begin scalar buf,av$
     buf:= inputbuflis!*$
  for each x in buf do if not atom (x:=caddr x) and
              car x member list('vector,'tvector,'index)
         then
     begin scalar uu,xx$
         uu:=cdadr x$
     l1: if null uu then return av else
           if gettype(xx:=cadar uu) or get(xx,'fdegree) then
             av:=adjoin(xx,av);
         uu:=cdr uu$
         go to l1  end$
  if null u then
   <> else return av
 end$

flag('(displayvec),'noform);

symbolic  procedure displayvec$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remv!:(t),union(remsvar!:(t,'hvector),remsvar!:(t,'tvector)) );

symbolic procedure clearvec$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<>;

symbolic procedure remf!:(u)$
% This function works to trace or to clear forms.
 begin scalar buf,av$
     buf:= inputbuflis!*$
     for each x in buf do if not atom (x:=caddr x) and
                              car x eq 'pform then
     begin scalar uu,xx$
         uu:=cdadr x$
     l1: if null uu then return av else
           if get(xx:=cadadr cdar uu ,'fdegree) or
             (not atom xx and get(xx:=cadr xx,'ifdegree))
    then
             av:=adjoin(xx,av);
         uu:=cdr uu$
         go to l1  end$
  if null u then
   <> else return av
 end$

flag('(displayform),'noform);

symbolic  procedure displayform$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remf!:(t),remvar!:(t,'pform));
symbolic procedure clearform$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<>;

symbolic procedure clear!_all;
<>;

symbolic procedure show u;
begin u:=car u;
           if u eq 'scalars then
              return write "scalars are: ", displayscal()
           else
           if u eq 'lists  then
              return write "lists are: ", displaylst()
           else
           if u eq 'arrays then
               return write "arrays are: ", displayar()
           else
           if u eq 'matrices then
                       return write "matrices are: ",displaymat()
           else
           if u member list('vectors,'tvectors,'indices)  then
                       return  write "vectors are: ", displayvec()
           else
           if u eq 'forms then
                        return write "forms are: ", displayform()
           else
           if u eq 'all then for each i in
            list('scalars,'arrays,'lists,'matrices,'vectors,'forms) do
                        <>;
end;

put('show,'stat,'rlis);

symbolic procedure suppress u;
begin u:=car u;
            if u member list('vectors,'tvectors,'indices) then
                       return clearvec() else
            if u eq 'variables then return clearvar() else
            if u eq 'scalars then return clearscal() else
            if u eq 'lists then return clearlst() else
            if u eq 'saveids  then return clearsvar() else
            if u eq 'matrices then return clearmat() else
            if u eq 'arrays then return clearar() else
            if u eq 'forms then return clearform() else
            if u eq 'all then return clear!_all() end;

put('suppress,'stat,'rlis);


% 5. Complementary means to CLEAR operators and functions.

symbolic procedure clearop u;
<>;

flag('(clearop),'opfn);

symbolic procedure clearfunctions u$
% U is any number of idfs. This function erases properties of  non
% protected functions described by the idfs.
% It is very convenient but is dangerous if applied to the
% basic functions of the system since most of them  are NOT protected.
% It clears all properties introduced by PUTFLAG, PUTPROP and DEPEND.
begin scalar uu,vv$
l1: uu:=car u$
    vv:=cdr rdisplayflag (list  uu )$
    if flagp(uu,'lose) then go to l2 else
    << terpri();spaces(5)$
       write "*** ",uu," is unprotected : Cleared ***"$
       followline(0)>>$
  for each x in !:proplis do
            if u eq car x then putprop(u,cadr x,caddr x,0)
                              else nil;
    remprop('uu,'!*lambdalink);
  if get(uu,'simpfn) then <> ;
    remprop(uu,'psopfn);
    remprop(uu,'expr);
  if get(uu,'subr) then remd uu$
    remprop(uu,'stat);
    remprop(uu,'dfn);
    remprop(uu,'rtypefn);
    remprop(uu,'number!-of!-args);
    remflag(list uu,'opfn)$
    remflag(list uu,'full)$
    remflag(list uu,'odd)$
    remflag(list uu,'even)$
    remflag(list uu,'boolean)$
    remflag(list uu,'used!*)$
    for each x in vv do putflag( uu,x,0)$
    depl!*:=delete(assoc(uu,depl!*),depl!*);
    remflag(list uu,'impfun)$ % to be effective in EXCALC;
    u:= cdr u$ go to l3$
l2: << spaces(5)$
       write "*** ",uu," is a protected function: NOT cleared ***"$
       terpri(); u:=cdr u>>$
l3: if null u then <> else

    go to l1 end$

rlistat '(clearfunctions);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/assist.rlg0000644000175000017500000005423011527635055024046 0ustar  giovannigiovanniFri Feb 18 21:27:18 2011 run on win32
% Test of Assist Package version 2.31.
% DATE : 30 August 1996
% Author: H. Caprasse 
%load_package assist$

Comment 2. HELP for ASSIST:;

;


assist();


 Argument of ASSISTHELP must be an integer between 3 and 14. 

 Each integer corresponds to a section number in the documentation:

 3: switches    4: lists        5: bags      6: sets 

 7: utilities   8: properties and flags  9: control functions 

 10: handling of polynomials 

 11: handling of transcendental functions

 12: handling of n-dimensional vectors 

 13: grassmann variables           14: matrices

;


assisthelp(7);


{{mkidnew,list_to_ids,oddp,followline,detidnum,dellastdigit,==},

 {randomlist,mkrandtabl},

 {permutations,perm_to_num,num_to_perm,combnum,combinations,cyclicpermlist,

  symmetrize,remsym},

 {extremum,sortnumlist,sortlist,algsort},

 {funcvar,implicit,depatom,explicit,simplify,korderlist,remcom},

 {checkproplist,extractlist,array_to_list,list_to_array},

 {remvector,remindex,mkgam}}

;


Comment 3. CONTROL OF SWITCHES:;

;


switches;


      **** exp:=t .................... allfac:= t ****

      **** ezgcd:=nil ................. gcd:= nil ****

      **** mcd:=t ....................... lcm:= t ****

      **** div:=nil ................... rat:= nil ****

      **** intstr:=nil ........... rational:= nil ****

      **** precise:=t ............. reduced:= nil ****

      **** complex:=nil ....... rationalize:= nil ****

      **** factor:= nil ....... combineexpt:= nil ****

      **** revpri:= nil ........ distribute:= nil ****
off exp;

 on gcd;

 off precise;


switches;


      **** exp:=nil .................... allfac:= t ****

      **** ezgcd:=nil ................. gcd:= t ****

      **** mcd:=t ....................... lcm:= t ****

      **** div:=nil ................... rat:= nil ****

      **** intstr:=nil ........... rational:= nil ****

      **** precise:=nil ............. reduced:= nil ****

      **** complex:=nil ....... rationalize:= nil ****

      **** factor:= nil ....... combineexpt:= nil ****

      **** revpri:= nil ........ distribute:= nil ****
switchorg;


switches;


      **** exp:=t .................... allfac:= t ****

      **** ezgcd:=nil ................. gcd:= nil ****

      **** mcd:=t ....................... lcm:= t ****

      **** div:=nil ................... rat:= nil ****

      **** intstr:=nil ........... rational:= nil ****

      **** precise:=t ............. reduced:= nil ****

      **** complex:=nil ....... rationalize:= nil ****

      **** factor:= nil ....... combineexpt:= nil ****

      **** revpri:= nil ........ distribute:= nil ****
;


if !*mcd then "the switch mcd is on";


the switch mcd is on

if !*gcd then "the switch gcd is on";


;


Comment 4. MANIPULATION OF THE LIST STRUCTURE:;

;


t1:=mklist(5);


t1 := {0,0,0,0,0}


Comment   MKLIST does NEVER destroy anything ;


mklist(t1,10);


{0,0,0,0,0,0,0,0,0,0}

mklist(t1,3);


{0,0,0,0,0}

;


sequences 3;


{{0,0,0},

 {1,0,0},

 {0,1,0},

 {1,1,0},

 {0,0,1},

 {1,0,1},

 {0,1,1},

 {1,1,1}}

lisp;


nil

sequences 3;


((0 0 0) (1 0 0) (0 1 0) (1 1 0) (0 0 1) (1 0 1) (0 1 1) (1 1 1))

algebraic;


;


for i:=1:5 do t1:= (t1.i:=mkid(a,i));


t1;


{a1,

 a2,

 a3,

 a4,

 a5}

;


t1.5;


a5

;


t1:=(t1.3).t1;


t1 := {a3,a1,a2,a3,a4,a5}

;


% Notice the blank spaces ! in the following illustration: 
1 . t1;


{1,a3,a1,a2,a3,a4,a5}

;


% Splitting of a list:
split(t1,{1,2,3});


{{a3},

 {a1,a2},

 {a3,a4,a5}}
 
;


% It truncates the list :
split(t1,{3});


{{a3,a1,a2}}

;


% A KERNEL may be coerced to a list:
kernlist sin x;


{x}

;


% algnlist constructs a list which contains n-times a given list 
algnlist(t1,2);


{{a3,

  a1,

  a2,

  a3,

  a4,

  a5},

 {a3,

  a1,

  a2,

  a3,

  a4,

  a5}}
 
;


% Delete :

delete(x, {a,b,x,f,x});


{a,b,f,x}

;


% delete_all eliminates ALL occurences of x: 
delete_all(x,{a,b,x,f,x});


{a,b,f}

;


remove(t1,4);


{a3,a1,a2,a4,a5}

;


% delpair deletes a pair if it is possible.
delpair(a1,pair(t1,t1));


{{a3,a3},

 {a2,a2},

 {a3,a3},

 {a4,a4},

 {a5,a5}}

;

 
elmult(a1,t1);


1

;


frequency append(t1,t1);


{{a3,4},

 {a1,2},

 {a2,2},

 {a4,2},

 {a5,2}}

;


insert(a1,t1,3);


{a3,a1,a1,a2,a3,a4,a5}

;


li:=list(1,2,5);


li := {1,2,5}

;


%  Not to destroy an already ordered list during insertion:
insert_keep_order(4,li,lessp);


{1,2,4,5}

insert_keep_order(bb,t1,ordp);


{a3,

 a1,

 a2,

 a3,

 a4,

 a5,

 bb}

;


% the same function when appending two correctly ORDERED lists:
merge_list(li,li,<);


{1,1,2,2,5,5}

;


merge_list({5,2,1},{5,2,1},geq);


{5,5,2,2,1,1}

;


depth list t1;


2

;


depth a1;


0

% Any list can be flattened into a list of depth 1:
mkdepth_one {1,{{a,b,c}},{c,{{d,e}}}};


{1,

 a,

 b,

 c,

 c,

 d,

 e}

position(a2,t1);


3

appendn(li,li,li);


{1,2,5,1,2,5,1,2,5}

;


clear t1,li;


comment 5. THE BAG STRUCTURE AND OTHER FUNCTION FOR LISTS AND BAGS.
 ;

aa:=bag(x,1,"A");


aa := bag(x,1,A)

putbag bg1,bg2;


t

on errcont;


putbag list;


***** list invalid as BAG

off errcont;


aa:=bg1(x,y**2);


             2
aa := bg1(x,y )

;


if bagp aa then "this is a bag";


this is a bag

;


% A bag is a composite object:
clearbag bg2;


;


depth bg2(x);


0

;


depth bg1(x);


1

;


if baglistp aa then "this is a bag or list";


this is a bag or list

if baglistp {x} then "this is a bag or list";


this is a bag or list

if bagp {x} then "this is a bag";


if bagp aa then "this is a bag";


this is a bag

;


ab:=bag(x1,x2,x3);


ab := bag(x1,x2,x3)

al:=list(y1,y2,y3);


al := {y1,y2,y3}

% The basic lisp functions are also active for bags:
first ab;


bag(x1)
  third ab;


bag(x3)
  first al;


y1

last ab;


bag(x3)
 last al;


y3

belast ab;


bag(x1,x2)
 belast al;


{y1,y2}
 belast {a,b,a,b,a};


{a,b,a,b}

rest ab;


bag(x2,x3)
 rest al;


{y2,y3}


;


% The "dot" plays the role of the function "part":
ab.1;


x1
 al.3;


y3

on errcont;


ab.4;


*** Expression bag(x1,x2,x3) does not have part 4

0

off errcont;


a.ab;


bag(a,x1,x2,x3)

% ... but notice
1 . ab;


bag(1,x1,x2,x3)

% Coercion from bag to list and list to bag:
kernlist(aa);


    2
{x,y }

;


listbag(list x,bg1);


bg1(x)

;


length ab;


3

;


remove(ab,3);


bag(x1,x2)

;


delete(y2,al);


{y1,y3}

;


reverse al;


{y3,y2,y1}

;


member(x3,ab);


bag(x3)

;


al:=list(x**2,x**2,y1,y2,y3);


        2
al := {x ,

        2
       x ,

       y1,

       y2,

       y3}

;


elmult(x**2,al);


2

;


position(y3,al);


5

;


repfirst(xx,al);


     2
{xx,x ,y1,y2,y3}

;


represt(xx,ab);


bag(x1,xx)

;


insert(x,al,3);


  2  2
{x ,x ,x,y1,y2,y3}

insert( b,ab,2);


bag(x1,b,xx)

insert(ab,ab,1);


bag(bag(x1,xx),x1,xx)

;


substitute (new,y1,al);


  2  2
{x ,x ,new,y2,y3}

;


appendn(ab,ab,ab);


{x1,xx,x1,xx,x1,xx}

;


append(ab,al);


           2  2
bag(x1,xx,x ,x ,y1,y2,y3)

append(al,ab);


  2  2
{x ,x ,y1,y2,y3,x1,xx}

clear ab;

 a1;


a1

;

comment Association list or bag may be constructed and thoroughly used;

;


l:=list(a1,a2,a3,a4);


l := {a1,a2,a3,a4}

b:=bg1(x1,x2,x3);


b := bg1(x1,x2,x3)

al:=pair(list(1,2,3,4),l);


al := {{1,a1},{2,a2},{3,a3},{4,a4}}

ab:=pair(bg1(1,2,3),b);


ab := bg1(bg1(1,x1),bg1(2,x2),bg1(3,x3))

;


clear b;


comment : A BOOLEAN function abaglistp to test if it is an association;

;


if abaglistp bag(bag(1,2)) then "it is an associated bag";


it is an associated bag

;


% Values associated to the keys can be extracted
% first occurence ONLY.
;


asfirst(1,al);


{1,a1}

asfirst(3,ab);


bg1(3,x3)

;


assecond(a1,al);


{1,a1}

assecond(x3,ab);


bg1(3,x3)

;


aslast(z,list(list(x1,x2,x3),list(y1,y2,z)));


{y1,y2,z}

asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z)));


{x1,x2,x3}

;


clear a1;


;


% All occurences.
asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2)));


bg1(bg1(x,a1,a2),bg1(x,b1,b2))

asslist(a1,list(list(x,a1),list(y,a1),list(x,y)));


{{x,a1},{y,a1}}

restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));


bg1(bg1(x,b2),bg1(a1,a2))

restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));


bag(bag(x,b2),bag(a1,a2))

;


Comment 6. SETS AND THEIR MANIPULATION FUNCTIONS
;

ts:=mkset list(a1,a1,a,2,2);


ts := {a1,a,2}

if setp ts then "this is a SET";


this is a SET

;


union(ts,ts);


{a1,a,2}

;


diffset(ts,list(a1,a));


{2}

diffset(list(a1,a),ts);


{}

;


symdiff(ts,ts);


{}

;


intersect(listbag(ts,set1),listbag(ts,set2));


set1(a1,a,2)



Comment 7. GENERAL PURPOSE UTILITY FUNCTIONS :;

;


clear a1,a2,a3,a,x,y,z,x1,x2,op$


;


% DETECTION OF A GIVEN VARIABLE IN A GIVEN SET
;


mkidnew();


g0

mkidnew(a);


ag1

;


dellastdigit 23;


2

;


detidnum aa;


detidnum a10;


10

detidnum a1b2z34;


34

;


list_to_ids list(a,1,rr,22);


a1rr22

;


if oddp 3 then "this is an odd integer";


this is an odd integer

;


<>;

1
       8
;


operator foo;


foo(x):=x;


foo(x) := x

foo(x)==value;


value


x;


value
 	% it is equal to value

clear x;


;


randomlist(10,20);


{8,1,8,0,5,7,3,8,0,5,5,9,0,5,2,0,7,5,5,1}

% Generation of tables of random numbers:
% One dimensional:
mkrandtabl({4},10,ar);


{4}

array_to_list ar;


{5,4,4,7}

;


% Two dimensional:
mkrandtabl({3,4},10,ar);


*** array ar redefined 

{3,4}

array_to_list ar;


{{9,5,2,8},{7,3,5,2},{8,1,6,0}}
 
;


% With a base which is a decimal number:
on rounded;


mkrandtabl({5},3.5,ar);


*** array ar redefined 

{5}

array_to_list ar;


{2.77546499305,1.79693268486,3.43100115041,2.11636272025,3.45447023392}

off rounded;


;


% Combinatorial functions :
permutations(bag(a1,a2,a3));


bag(bag(a1,a2,a3),bag(a1,a3,a2),bag(a2,a1,a3),bag(a2,a3,a1),bag(a3,a1,a2),

    bag(a3,a2,a1))

permutations {1,2,3};


{{1,2,3},{1,3,2},{2,1,3},{2,3,1},{3,1,2},{3,2,1}}

;


cyclicpermlist{1,2,3};


{{1,2,3},{2,3,1},{3,1,2}}

;


combnum(8,3);


56

;


combinations({1,2,3},2);


{{2,3},{1,3},{1,2}}

;


perm_to_num({3,2,1,4},{1,2,3,4});


5

num_to_perm(5,{1,2,3,4});


{3,2,1,4}

;


operator op;


symmetric op;


op(x,y)-op(y,x);


0

remsym op;


op(x,y)-op(y,x);


op(x,y) - op(y,x)

;


labc:={a,b,c};


labc := {a,b,c}

symmetrize(labc,foo,cyclicpermlist);


foo(a,b,c) + foo(b,c,a) + foo(c,a,b)

symmetrize(labc,list,permutations);


{a,b,c} + {a,c,b} + {b,a,c} + {b,c,a} + {c,a,b} + {c,b,a}

symmetrize({labc},foo,cyclicpermlist);


foo({a,b,c}) + foo({b,c,a}) + foo({c,a,b})

;


extremum({1,2,3},lessp);


1

extremum({1,2,3},geq);


3

extremum({a,b,c},nordp);


c

;


funcvar(x+y);


{x,y}

funcvar(sin log(x+y));


{x,y}

funcvar(sin pi);


funcvar(x+e+i);


{x}

funcvar sin(x+i*y);


{y,x}

;


operator op;


*** op already defined as operator 

noncom op;


op(0)*op(x)-op(x)*op(0);


 - op(x)*op(0) + op(0)*op(x)

remnoncom op;


t

op(0)*op(x)-op(x)*op(0);


0

clear op;


;


depatom a;


a

depend a,x,y;


depatom a;


{x,y}

;


depend op,x,y,z;


;


implicit op;


op

explicit op;


op(x,y,z)

depend y,zz;


explicit op;


op(x,y(zz),z)

aa:=implicit op;


aa := op

clear op;


;


korder x,z,y;


korderlist;


(x z y)

;


if checkproplist({1,2,3},fixp) then "it is a list of integers";


it is a list of integers

;


if checkproplist({a,b1,c},idp) then "it is a list of identifiers";


it is a list of identifiers

;


if checkproplist({1,b1,c},idp) then "it is a list of identifiers";


;


lmix:={1,1/2,a,"st"};


            1
lmix := {1,---,a,st}
            2

;


extractlist(lmix,fixp);


{1}

extractlist(lmix,numberp);


    1
{1,---}
    2

extractlist(lmix,idp);


{a}

extractlist(lmix,stringp);


{st}

;


% From a list to an array:
list_to_array({a,b,c,d},1,ar);


*** array ar redefined 

array_to_list ar;


{a,b,c,d}
  
list_to_array({{a},{b},{c},{d}},2,ar);


*** array ar redefined 

;


comment 8. PROPERTIES AND FLAGS:;

;


putflag(list(a1,a2),fl1,t);


t

putflag(list(a1,a2),fl2,t);


t

displayflag a1;


{fl1,fl2}

;


clearflag a1,a2;


displayflag a2;


{}

putprop(x1,propname,value,t);


x1

displayprop(x1,prop);


{}

displayprop(x1,propname);


{propname,value}

;


putprop(x1,propname,value,0);


displayprop(x1,propname);


{}

;


Comment 9. CONTROL FUNCTIONS:;

;


alatomp z;


t

z:=s1;


z := s1

alatomp z;


t

;


alkernp z;


t

alkernp log sin r;


t

;


precp(difference,plus);


t

precp(plus,difference);


precp(times,.);


precp(.,times);


t

;


if stringp x then "this is a string";


if stringp "this is a string" then "this is a string";


this is a string

;


if nordp(b,a) then "a is ordered before b";


a is ordered before b

operator op;


for all x,y such that nordp(x,y) let op(x,y)=x+y;


op(a,a);


op(a,a)

op(b,a);


a + b

op(a,b);


op(a,b)

clear op;


;


depvarp(log(sin(x+cos(1/acos rr))),rr);


t

;


clear y,x,u,v;


clear op;


;


% DISPLAY and CLEARING of user's objects of various types entered
% to the console. Only TOP LEVEL assignments are considered up to now.
% The following statements must be made INTERACTIVELY. We put them
% as COMMENTS for the user to experiment with them. We do this because
% in a fresh environment all outputs are nil.
;


% THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY.
% SEE THE ** ASSIST LOG **  FILE .
%v1:=v2:=1;
%show scalars;
%aa:=list(a);
%show lists;
%array ar(2);
%show arrays;
%load matr$
%matrix mm;
%show matrices;
%x**2;
%saveas res;
%show saveids;
%suppress scalars;
%show scalars;
%show lists;
%suppress all;
%show arrays;
%show matrices;
;


comment end of the interactive part;

;


clear op;


operator op;


op(x,y,z);


op(x,y,s1)

clearop op;


t

;


clearfunctions abs,tan;


     *** abs is unprotected : Cleared ***
     *** tan is a protected function: NOT cleared ***


"Clearing is complete"

;


comment  THIS FUNCTION MUST BE USED WITH CARE !!!!!;

;


Comment 10. HANDLING OF POLYNOMIALS

clear x,y,z;

COMMENT  To see the internal representation :;

;


off pri;


;


pol:=(x-2*y+3*z**2-1)**3;


        3    2               2               2              2              4
pol := x  + x *( - 6*y + 9*s1  - 3) + x*(12*y  + y*( - 36*s1  + 12) + 27*s1  - 
            2           3    2       2                    4        2
       18*s1  + 3) - 8*y  + y *(36*s1  - 12) + y*( - 54*s1  + 36*s1  - 6) + 27*

         6        4       2
       s1  - 27*s1  + 9*s1  - 1

;


pold:=distribute pol;


             6        4       2    3      2        2   2      2         2
pold := 27*s1  - 27*s1  + 9*s1  + x  - 6*x *y + 9*x *s1  - 3*x  + 12*x*y  + 27*x

           4          2            2                     3       2   2       2
        *s1  - 18*x*s1  - 36*x*y*s1  + 12*x*y + 3*x - 8*y  + 36*y *s1  - 12*y  -

                4          2
         54*y*s1  + 36*y*s1  - 6*y - 1

;


on distribute;


leadterm (pold);


     6
27*s1

pold:=redexpr pold;


                4       2    3      2        2   2      2         2          4
pold :=  - 27*s1  + 9*s1  + x  - 6*x *y + 9*x *s1  - 3*x  + 12*x*y  + 27*x*s1  -

                2            2                     3       2   2       2
         18*x*s1  - 36*x*y*s1  + 12*x*y + 3*x - 8*y  + 36*y *s1  - 12*y  - 54*y*

          4          2
        s1  + 36*y*s1  - 6*y - 1

leadterm pold;


        4
 - 27*s1

;


off distribute;


polp:=pol$


leadterm polp;


 3
x

polp:=redexpr polp;


         2               2               2              2              4
polp := x *( - 6*y + 9*s1  - 3) + x*(12*y  + y*( - 36*s1  + 12) + 27*s1  - 18*s1
        2           3    2       2                    4        2             6
          + 3) - 8*y  + y *(36*s1  - 12) + y*( - 54*s1  + 36*s1  - 6) + 27*s1  -

              4       2
         27*s1  + 9*s1  - 1

leadterm polp;


 2               2
x *( - 6*y + 9*s1  - 3)

;


monom polp;


      6
{27*s1 ,

         4
  - 27*s1 ,

     2
 9*s1 ,

       2
  - 6*x *y,

    2   2
 9*x *s1 ,

       2
  - 3*x ,

       2
 12*x*y ,

        4
 27*x*s1 ,

           2
  - 18*x*s1 ,

             2
  - 36*x*y*s1 ,

 12*x*y,

 3*x,

       3
  - 8*y ,

     2   2
 36*y *s1 ,

        2
  - 12*y ,

           4
  - 54*y*s1 ,

        2
 36*y*s1 ,

  - 6*y,

 -1}

;


on pri;


;


splitterms polp;


      2  2
{{9*s1 *x ,

        2
  12*x*y ,

  12*x*y,

       4
  27*s1 *x,

  3*x,

       2  2
  36*s1 *y ,

       2
  36*s1 *y,

       6
  27*s1 ,

      2
  9*s1 },

     2
 {6*x *y,

     2
  3*x ,

       2
  36*s1 *x*y,

       2
  18*s1 *x,

     3
  8*y ,

      2
  12*y ,

       4
  54*s1 *y,

  6*y,

       4
  27*s1 ,

  1}}

;


splitplusminus polp;


        6       4         2  2        2  2        2         2        2
{3*(9*s1  + 9*s1 *x + 3*s1 *x  + 12*s1 *y  + 12*s1 *y + 3*s1  + 4*x*y  + 4*x*y

     + x),

         4          4        2            2        2        2      3       2
  - 54*s1 *y - 27*s1  - 36*s1 *x*y - 18*s1 *x - 6*x *y - 3*x  - 8*y  - 12*y

  - 6*y - 1}

;


divpol(pol,x+2*y+3*z**2);


     4       2          2         2    2                     2
{9*s1  + 6*s1 *x - 24*s1 *y - 9*s1  + x  - 8*x*y - 3*x + 28*y  + 18*y + 3,

        3       2
  - 64*y  - 48*y  - 12*y - 1}

;


lowestdeg(pol,y);


0

;


Comment 11.  HANDLING OF SOME TRANSCENDENTAL FUNCTIONS:;

;


trig:=((sin x)**2+(cos x)**2)**4;


trig := 

      8           6       2           4       4           2       6         8
cos(x)  + 4*cos(x) *sin(x)  + 6*cos(x) *sin(x)  + 4*cos(x) *sin(x)  + sin(x)

trigreduce trig;


1

trig:=sin (5x);


trig := sin(5*x)

trigexpand trig;


                4            2       2         4
sin(x)*(5*cos(x)  - 10*cos(x) *sin(x)  + sin(x) )

trigreduce ws;


sin(5*x)

trigexpand sin(x+y+z);


cos(s1)*cos(x)*sin(y) + cos(s1)*cos(y)*sin(x) + cos(x)*cos(y)*sin(s1)

 - sin(s1)*sin(x)*sin(y)

;


;


hypreduce (sinh x **2 -cosh x **2);


-1

;


;


clear a,b,c,d;


;



Comment 13. HANDLING OF N-DIMENSIONAL VECTORS:;

;


clear u1,u2,v1,v2,v3,v4,w3,w4;


u1:=list(v1,v2,v3,v4);


u1 := {v1,v2,v3,v4}

u2:=bag(w1,w2,w3,w4);


u2 := bag(w1,w2,w3,w4)

%
sumvect(u1,u2);


{v1 + w1,

 v2 + w2,

 v3 + w3,

 v4 + w4}

minvect(u2,u1);


bag( - v1 + w1, - v2 + w2, - v3 + w3, - v4 + w4)

scalvect(u1,u2);


v1*w1 + v2*w2 + v3*w3 + v4*w4

crossvect(rest u1,rest u2);


{v3*w4 - v4*w3,

  - v2*w4 + v4*w2,

 v2*w3 - v3*w2}

mpvect(rest u1,rest u2, minvect(rest u1,rest u2));


0

scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2));


0

;


Comment 14. HANDLING OF GRASSMANN OPERATORS:;

;


putgrass eta,eta1;


grasskernel:=
{eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
(~x)*(~x) => 0 when grassp x};


grasskernel := {eta(~x)*eta(~y) =>  - eta(y)*eta(x) when nordp(x,y),

                ~x*~x => 0 when grassp(x)}

;


eta(y)*eta(x);


eta(y)*eta(x)

eta(y)*eta(x) where grasskernel;


 - eta(x)*eta(y)

let grasskernel;


eta(x)^2;


0

eta(y)*eta(x);


 - eta(x)*eta(y)

operator zz;


grassparity (eta(x)*zz(y));


1

grassparity (eta(x)*eta(y));


0

grassparity(eta(x)+zz(y));


parity undefined

clearrules grasskernel;


grasskernel:=
{eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
eta1(~x)*eta(~y) => -eta x * eta1 y,
eta1(~x)*eta1(~y) => -eta1 y * eta1 x when nordp(x,y),
(~x)*(~x) => 0 when grassp x};


grasskernel := {eta(~x)*eta(~y) =>  - eta(y)*eta(x) when nordp(x,y),

                eta1(~x)*eta(~y) =>  - eta(x)*eta1(y),

                eta1(~x)*eta1(~y) =>  - eta1(y)*eta1(x) when nordp(x,y),

                ~x*~x => 0 when grassp(x)}

;


let grasskernel;


eta1(x)*eta(x)*eta1(z)*eta1(w);


 - eta(x)*eta1(s1)*eta1(w)*eta1(x)

clearrules grasskernel;


remgrass eta,eta1;


clearop zz;


t

;


Comment  15. HANDLING OF MATRICES:;

;


clear m,mm,b,b1,bb,cc,a,b,c,d,a1,a2;


load_package matrix;


baglmat(bag(bag(a1,a2)),m);


t

m;


[a1  a2]


on errcont;


;


baglmat(bag(bag(a1),bag(a2)),m);


***** (mat ((*sq ((((a1 . 1) . 1)) . 1) t) (*sq ((((a2 . 1) . 1)) . 1) t))) 
should be an identifier 

off errcont;


%    **** i.e. it cannot redefine the matrix! in order
%         to avoid accidental redefinition of an already given matrix;

clear m;

 baglmat(bag(bag(a1),bag(a2)),m);


t

m;


[a1]
[  ]
[a2]


on errcont;


baglmat(bag(bag(a1),bag(a2)),bag);


***** operator bag invalid as matrix

off errcont;


comment  Right since a bag-like object cannot become a matrix.;

;


coercemat(m,op);


op(op(a1),op(a2))

coercemat(m,list);


{{a1},{a2}}

;


on nero;


unitmat b1(2);


matrix b(2,2);


b:=mat((r1,r2),(s1,s2));


     [r1  r2]
b := [      ]
     [s1  s2]


b1;


[1  0]
[    ]
[0  1]

b;


[r1  r2]
[      ]
[s1  s2]


mkidm(b,1);


[1  0]
[    ]
[0  1]


;


seteltmat(b,newelt,2,2);


[r1    r2  ]
[          ]
[s1  newelt]


geteltmat(b,2,1);


s1

%
b:=matsubr(b,bag(1,2),2);


     [r1  r2]
b := [      ]
     [1   2 ]


;


submat(b,1,2);


[1]


;


bb:=mat((1+i,-i),(-1+i,-i));


      [i + 1   - i]
bb := [           ]
      [i - 1   - i]


cc:=matsubc(bb,bag(1,2),2);


      [i + 1  1]
cc := [        ]
      [i - 1  2]


;


cc:=tp matsubc(bb,bag(1,2),2);


      [i + 1  i - 1]
cc := [            ]
      [  1      2  ]


matextr(bb, bag,1);


bag(i + 1, - i)

;


matextc(bb,list,2);


{ - i, - i}

;


hconcmat(bb,cc);


[i + 1   - i  i + 1  i - 1]
[                         ]
[i - 1   - i    1      2  ]


vconcmat(bb,cc);


[i + 1   - i ]
[            ]
[i - 1   - i ]
[            ]
[i + 1  i - 1]
[            ]
[  1      2  ]


;


tpmat(bb,bb);


[ 2*i     - i + 1   - i + 1  -1]
[                              ]
[  -2     - i + 1   i + 1    -1]
[                              ]
[  -2     i + 1     - i + 1  -1]
[                              ]
[ - 2*i   i + 1     i + 1    -1]


bb tpmat bb;


[ 2*i     - i + 1   - i + 1  -1]
[                              ]
[  -2     - i + 1   i + 1    -1]
[                              ]
[  -2     i + 1     - i + 1  -1]
[                              ]
[ - 2*i   i + 1     i + 1    -1]


;


clear hbb;


hermat(bb,hbb);


[ - i + 1   - (i + 1)]
[                    ]
[   i          i     ]


% id hbb changed to a matrix id and assigned to the hermitian matrix
% of bb.
;


load_package HEPHYS;



% Use of remvector.
;


vector v1,v2;


v1.v2;


v1.v2

remvector v1,v2;


on errcont;


v1.v2;


***** v1 v2 invalid as list or bag

off errcont;


% To see the compatibility with ASSIST:
v1.{v2};


{v1,v2}

;


index u;

 vector v;


(v.u)^2;


v.v

remindex u;


t

(v.u)^2;


   2
u.v

;


% Gamma matrices properties may be translated to any identifier:
clear l,v;


vector v;


g(l,v,v);


v.v

mkgam(op,t);


t

op(l,v,v);


v.v

mkgam(g,0);


operator g;


g(l,v,v);


g(l,v,v)

;


clear g,op;


;


% showtime;
end;


Time for test: 15 ms
@@@@@ Resources used: (0 0 37 4)
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/dummy.tst0000644000175000017500000001150111526203062023677 0ustar  giovannigiovanni% test of DUMMY package version 1.1 running in REDUCE 3.6 and 3.7
% DATE: 15 September 1998
% Authors: H. Caprasse 
%
% Case of commuting operator:
%
operator co1,co2;

% declare dummy indices

% first syntax : base 
%
dummy_base dv;

% dummy indices are dv1, dv2, dv3, ...

exp := co2(dv2)*co2(dv2)$
c_exp := canonical(exp);

exp := dv2*co2(dv2)*co2(dv2)$
c_exp := canonical(exp);

exp := c_exp * co1(dv3);
c_exp := canonical(exp);

%
operator a,aa,dd,te;

clear_dummy_base;

dummy_names a1,a2,b1,b2,mu1,mu2,nu1,nu2;

es1:=a(a1,b1)*a(a2,b2);

asn14:=aa(mu1,a1)*aa(nu2,b2)*dd(nu1,b1,mu2,a2)
         *te(mu1,mu2,nu1,nu2);
asn17:=aa(mu1,a1)*aa(mu2,a2)*dd(nu1,b1,nu2,b2)
          *te(mu1,mu2,nu1,nu2);
             
esn14:=es1*asn14;
esn17:=es1*asn17;
esn:=es1*(asn14+asn17); 
canonical esn;
% that the next result is correct is not trivial 
% to show.
% for esn14 changes of names are 
%
%  nu1 -> nu1
%  b1 -> b2 -> a2
%  mu2 -> nu2 -> mu1 -> mu2
%    
% for esn17 they are
%
%  nu1 -> nu1
%  nu2 -> nu2
%  b1 -> b2 -> a2 -> a1 -> b1
%
% the last result should be zero 
canonical esn -(canonical esn14 +canonical esn17);
% remove dummy_names and operators.
clear_dummy_names;
clear a,aa,dd,te;
%
% Case of anticommuting operators
%
operator ao1, ao2;
anticom ao1, ao2;
% product of anticommuting operators with FREE indices
a_exp := ao1(s1)*ao1(s2) - ao1(s2)*ao1(s1);
a_exp := canonical(a_exp);

% the indices are summed upon, i.e. are DUMMY indices

clear_dummy_names;

dummy_base dv;

a_exp := ao1(dv1)*ao1(dv2)$
canonical(a_exp);

a_exp := ao1(dv1)*ao1(dv2) - ao1(dv2)*ao1(dv1);
a_exp := canonical(a_exp);

a_exp := ao1(dv2,dv3)*ao2(dv1,dv2)$
a_exp := canonical(a_exp);

a_exp := ao1(dv1)*ao1(dv3)*ao2(dv3)*ao2(dv1)$
a_exp := canonical(a_exp);

% Case of non commuting operators
%
operator no1, no2, no3;
noncom no1, no2, no3;

n_exp := no3(dv2)*no2(dv3)*no1(dv1) + no3(dv3)*no2(dv1)*no1(dv2)
         + no3(dv1)*no2(dv2)*no1(dv3);

n_exp:=canonical n_exp;

% ***
% The example below displays a restriction of the package i.e
% The non commuting operators are ASSUMED to COMMUTE with the
% anticommuting operators.
% ***
exp := co1(dv1)*ao1(dv2,dv1,dv4)*no1(dv1,dv5)*co2(dv3)*ao1(dv1,dv3);
canonical(exp);

exp := c_exp * a_exp * no3(dv2)*no2(dv3)*no1(dv1);
can_exp := canonical(exp);

% Case where some operators have a symmetry.
%
operator as1, as2;
antisymmetric as1, as2;

dummy_base s;

% With commuting and antisymmetric:

asc_exp:=as1(s1,s2)*as1(s1,s3)*as1(s3,s4)*co1(s3)*co1(s4)+
        2*as1(s1,s2)*as1(s1,s3)*as1(s3,s4)*co1(s2)*co1(s4)$

canonical asc_exp;

% Indeed: the second term is identically zero as one sees 
%          if the substitutions s2->s4, s4->s2 and 
%           s1->s3, s3->s1 are sucessively done.
% 
% With anticommuting and antisymmetric operators:

dummy_base dv;

exp1 := ao1(dv1)*ao1(dv2)$
canonical(exp1);

exp2 := as1(dv1,dv2)$

canonical(exp2);

canonical(exp1*exp2);

canonical(as1(dv1,dv2)*as2(dv2,dv1));

% With symmetric and antisymmetric operators:

operator ss1, ss2;
symmetric ss1, ss2;

exp := ss1(dv1,dv2)*ss2(dv1,dv2) - ss1(dv2,dv3)*ss2(dv2,dv3);
canonical(exp);

exp := as1(dv1,dv2)*as1(dv3,dv4)*as1(dv1,dv4);
canonical(exp);

% The last result is equal to half the sum given below:
%
exp + sub(dv2 = dv3, dv3 = dv2, dv1 = dv4, dv4 = dv1, exp);

exp1 := as2(dv3,dv2)*as1(dv3,dv4)*as1(dv1,dv2)*as1(dv1,dv4);
canonical(exp1);

exp2 := as2(dv1,dv4)*as1(dv1,dv3)*as1(dv2,dv4)*as1(dv2,dv3);
canonical(exp2);

canonical(exp1-exp2);

% Indeed:
%
exp2 - sub(dv1 = dv3, dv2 = dv1, dv3 = dv4, dv4 = dv2, exp1);

% Case where mixed or incomplete symmetries for operators are declared.

% Function 'symtree' can be used to declare an operator symmetric 
% or antisymmetric:
operator om;

symtree(om,{!+,1,2,3});
exp:=om(dv1,dv2,dv3)+om(dv2,dv1,dv3)+om(dv3,dv2,dv1);
canonical exp;

% Declare om to be antisymmetric in the two last indices ONLY:
symtree(om,{!*,{!*,1},{!-,2,3}});
canonical exp; 

% With an antisymmetric operator m:
operator m;
dummy_base s;
exp := om(nu,s3,s4)*i*psi*(m(s1,s4)*om(mu,s1,s3) 
+ m(s2,s3)*om(mu,s4,s2) - m(s1,s3)*om(mu,s1,s4) 
- m(s2,s4)*om(mu,s3,s2))$

canonical exp;

% Case of the Riemann tensor
%
operator r;
symtree (r, {!+, {!-, 1, 2}, {!-, 3, 4}});
% Without anty dummy indices.
clear_dummy_base;

exp := r(dv1, dv2, dv3, dv4) * r(dv2, dv1, dv4, dv3)$
canonical(exp);

% With dummy indices:
 
dummy_base dv;

canonical( r(x,y,z,t) );
canonical( r(x,y,t,z) );
canonical( r(t,z,y,x) );

exp := r(dv1, dv2, dv3, dv4) * r(dv2, dv1, dv4, dv3)$
canonical(exp);

exp := r(dv1, dv2, dv3, dv4) * r(dv1, dv3, dv2, dv4)$
canonical(exp);

clear_dummy_base;
dummy_names i,j,k,l;

exp := r(i,j,k,l)*ao1(i,j)*ao1(k,l)$

canonical(exp);

exp := r(k,i,l,j)*as1(k,i)*as1(k,j)$
canonical(exp);

% Cleanup of the previousy declared dummy variables..

clear_dummy_names; clear_dummy_base;

exp := co1(dv3)$
c_exp := canonical(exp);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/helpasst.red0000644000175000017500000001132711526203062024335 0ustar  giovannigiovannimodule helpasst;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic procedure assist();
<>;

algebraic procedure assisthelp(n);
 if n = assist then assist()
   else
 if not fixp n then rederr("Argument must be an integer")
   else
 if n>=15 then "Argument must be less then 15"
   else
 if n<3 then "Argument must be greater or equal to 3"
  else
   begin scalar xx;
    xx:= asflist(n,assist_func);
    return if length xx=1 then rest first xx
             else
                 for each i in xx collect rest i
   end$

algebraic(
assist_func:= {{3,  "switches", "switchorg"},
               {4,  "dot", "mklist", "algnlist", "frequency", "sequences",
                   "split", "kernlist"},
               {4, "delete", "delete_all", "remove"},
               {4, "elmult", "insert", "insert_keep_order", "merge_list"},
               {4, "last", "belast", "position", "depth", "mkdepth_one",
                   "pair", "delpair", "appendn"},
               {4, "repfirst", "represt", "asfirst", "aslast",
                   "asrest","restaslist", "asflist", "asslist"},
               {5, "putbag", "clearbag", "bagp", "baglistp", "alistp",
                   "abaglistp", "listbag"},
               {6, "union", "setp", "mkset", "diffset", "symdiff"},
               {7, "mkidnew", "list_to_ids", "oddp", "followline",
                   "detidnum", "dellastdigit", "=="},
               {7, "randomlist", "mkrandtabl"},
               {7, "permutations", "perm_to_num", "num_to_perm",
                   "combnum", "combinations", "cyclicpermlist",
                   "symmetrize", "remsym"},
               {7, "extremum", "sortnumlist", "sortlist","algsort"},
               {7, "funcvar", "implicit", "depatom", "explicit",
                   "simplify", "korderlist", "remcom"},
               {7, "checkproplist", "extractlist", "array_to_list",
                  "list_to_array"},
               {7, "remvector", "remindex", "mkgam"},
               {8, "putflag", "putprop", "displayprop", "displayflag",
                   "clearflag", "clearprop"},
               {9, "nordp", "depvarp", "alatomp", "alkernp", "precp"},
               {9, "show", "suppress", "clearop", "clearfunctions"},
               {10, "alg_to_symb", "symb_to_alg"},
               {10, "gcdnl", "distribute", "leadterm", "redexpr",
                    "monom", "lowestdeg", "splitterms", "splitplusminus",
                    "norm_mon", "norm_pol", "list_coeff_pol"},
               {11, "trigexpand", "hypexpand","trigreduce","hypreduce"},
               {12, "sumvect", "minvect", "sscalvect", "crossvect",
                    "mpvect"},
               {13, "putgrass", "remgrass", "grassp", "grassparity",
                    "ghostfactor"},
               {14, "mkidm", "baglmat", "coercemat", "unitmat","submat",
                    "matsubr", "matsubc", "matextr", "matextc"},
               {14, "hconcmat", "vconcmat", "tpmat", "hermat", "seteltmat",
                    "geteltmat"}});
endmodule;
end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/assist.tex0000644000175000017500000014344111526203062024051 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\newcommand{\nl}{\hfill\newline}
\newcommand{\bq}{\begin{quotation}}
\newcommand{\eq}{\end{quotation}}
\newcommand{\bi}{\begin{itemize}}
\newcommand{\ei}{\end{itemize}}
\title{{\bf ASSIST}\ :\\[2pt]
 A General Purpose Addition to~\REDUCE \\[5pt]
       \mbox{\hfill Version 2.3\hfil}}
\author{Hubert Caprasse \\
D\'epartement d'Astronomie et d'Astrophysique \\
Institut de Physique, B--5, Sart Tilman \\
B--4000 LIEGE 1 \\[3pt]
E--mail: caprasse@vm1.ulg.ac.be}
\begin{document}
\maketitle
%\index{ASSIST package}
\section{Introduction}
 The package ASSIST contains
an appreciable number of additional general purpose functions which allow
one to better adapt \REDUCE\ to various calculational strategies,
to make the programming task more straightforward and, sometimes, 
more efficient.

In contrast with all other packages, ASSIST does not aim to provide either a
new facility to compute a definite class of mathematical objects or to extend
the base of mathematical knowledge of \REDUCE\ .
The functions it contains should be
useful independently of the nature of the application which is considered.
They were initially written while applying \REDUCE\ to specific problems in
theoretical physics. Most of them were designed
in such a way that their applicability range is broad. Though it was not
the primary goal, efficiency has been sought whenever possible.

The source code in ASSIST contains many comments concerning
the meaning and use of the supplementary functions available
in the algebraic mode. These comments, hopefully, make the code transparent
and allow a thorough exploitation of the package. The present documentation
contains a non--technical description of it and describes the
various new facilities it provides.
\section{ Survey of the Available New Facilities}
An elementary help facility is available both within
the MS-DOS\ and Windows environments. It is independent of the
help facility of \REDUCE\ itself. It includes two functions:

\f{ASSIST} is a function which takes no argument. If entered, it returns 
the informations required for a proper use  of \f{ASSISTHELP}.\\   
\f{ASSISTHELP} takes one argument.   
\begin{itemize}
\item[i.] If the argument is the identifier \f{assist}, the function 
returns the information necessary to retrieve the names of all the available
functions.
\item[ii.] If the argument is an integer equal to one of the section numbers
of the present documentation. The names of the functions described
in that section are obtained.\nl
There is, presently, no possibility to retrieve the number and the type of 
the arguments of a given function.
\end{itemize}
The package contains several modules. Their content reflects closely
the various categories of facilities listed below. Some functions do
already exist inside the KERNEL of \REDUCE\ . However, their range
of applicability is {\em extended}.\nl

\begin{itemize}
\item{Control of Switches:}
\begin{quotation}
\noindent
\f{SWITCHES SWITCHORG}
\end{quotation}
\item{Operations on Lists and Bags:}
\begin{quotation}
\noindent
\f{MKLIST KERNLIST ALGNLIST LENGTH \nl
POSITION FREQUENCY SEQUENCES SPLIT \nl
INSERT INSERT\_KEEP\_ORDER MERGE\_LIST \nl
FIRST SECOND THIRD REST REVERSE LAST \nl
BELAST CONS ( . ) APPEND APPENDN \nl
REMOVE DELETE DELETE\_ALL DELPAIR \nl
MEMBER ELMULT PAIR DEPTH MKDEPTH\_ONE \nl
REPFIRST REPREST ASFIRST ASLAST ASREST \nl
ASFLIST ASSLIST RESTASLIST SUBSTITUTE \nl
BAGPROP PUTBAG CLEARBAG BAGP BAGLISTP \nl
ALISTP ABAGLISTP LISTBAG }
\end{quotation}
\item{Operations on Sets:}
\begin{quotation}
\noindent
\f{MKSET SETP UNION INTERSECT DIFFSET SYMDIFF}
\end{quotation}
%\newpage
\item{General Purpose Utility Functions:}
\begin{quotation}
\noindent
\f{LIST\_TO\_IDS MKIDN MKIDNEW DELLASTDIGIT DETIDNUM \\
ODDP FOLLOWLINE  == RANDOMLIST MKRANDTABL \\
PERMUTATIONS CYCLICPERMLIST PERM\_TO\_NUM NUM\_TO\_PERM\\ 
COMBNUM COMBINATIONS SYMMETRIZE REMSYM \\
SORTNUMLIST SORTLIST ALGSORT EXTREMUM GCDNL\\
DEPATOM FUNCVAR IMPLICIT EXPLICIT REMNONCOM \\
KORDERLIST SIMPLIFY CHECKPROPLIST EXTRACTLIST} 
\end{quotation}
\item{ Properties and Flags:}
\begin{quotation}
\noindent
\f{PUTFLAG PUTPROP DISPLAYPROP DISPLAYFLAG \\
CLEARFLAG CLEARPROP }
\end{quotation}
\item{ Control Statements, Control of Environment:}
\begin{quotation}
\noindent
\f{NORDP DEPVARP ALATOMP ALKERNP PRECP \\
 SHOW SUPPRESS CLEAROP CLEARFUNCTIONS }
\end{quotation}
\item{Handling of Polynomials:}
\begin{quotation}
\noindent
\f{ALG\_TO\_SYMB SYMB\_TO\_ALG \\
DISTRIBUTE LEADTERM REDEXPR MONOM\\
LOWESTDEG DIVPOL SPLITTERMS SPLITPLUSMINUS}
\end{quotation}
% \vfill\pagebreak
\item{Handling of Transcendental Functions:}
\begin{quotation}
\noindent
\f{TRIGEXPAND HYPEXPAND TRIGREDUCE HYPREDUCE}
\end{quotation}
\item{Coercion from Lists to Arrays and converse:}
\begin{quotation}
\f{LIST\_TO\_ARRAY ARRAY\_TO\_LIST}
\end{quotation}
\item{Handling of n-dimensional Vectors:}
\begin{quotation}
\noindent
\f{SUMVECT MINVECT SCALVECT CROSSVECT MPVECT }
\end{quotation}
{\item Handling of Grassmann Operators:}
\begin{quotation}
\noindent
\f{PUTGRASS REMGRASS GRASSP GRASSPARITY GHOSTFACTOR }
\end{quotation}
\item{Handling of Matrices:}
\begin{quotation}
\noindent
\f{UNITMAT MKIDM BAGLMAT COERCEMAT \\
SUBMAT MATSUBR MATSUBC RMATEXTR RMATEXTC \\
 HCONCMAT VCONCMAT TPMAT HERMAT \\
SETELTMAT GETELTMAT}
\eq
\item{Control of the HEPHYS package:}
\bq
\noindent
\f{REMVECTOR REMINDEX MKGAM}
\end{quotation}
\end{itemize}
In the following all these functions are described.
\section{Control of Switches}
The two available functions i.e. \f{SWITCHES, SWITCHORG} have
no argument and are called as if they were mere identifiers.

\f{SWITCHES} displays the actual status of the most frequently used switches
when manipulating rational functions. The chosen switches are
\begin{quotation}
\noindent
{\tt EXP, ALLFAC, EZGCD, GCD, MCD, LCM, DIV, RAT, \\%
INTSTR, RATIONAL, PRECISE, REDUCED, RATIONALIZE, \\% 
COMBINEEXPT, COMPLEX, REVPRI, DISTRIBUTE.}
\end{quotation}

The selection is somewhat arbitrary but it may be changed in a trivial
fashion by the user.

The new switch {\tt DISTRIBUTE} allows one to put polynomials in a
distributed form (see the description below of
the new functions for manipulating  them.~).

Most of the symbolic variables {\tt !*EXP, !*DIV, $\ldots$}
which have either the value T or the value NIL are made available in the
algebraic mode so that it becomes possible to write conditional
statements of the kind
\begin{verbatim}

        IF !*EXP THEN DO ......

        IF !*GCD THEN OFF GCD;

\end{verbatim}
\f{SWITCHORG} resets  the switches enumerated above to the status
they had when {\bf starting} \REDUCE\ .
\section{Manipulation of the List Structure}

Additional functions for list manipulations are provided and some already
defined functions in the kernel of \REDUCE\ are modified to properly
generalize them to the available new structure {\tt BAG}.
\begin{itemize}
\item[i.]
Generation of a list of length n with all its elements initialized to 0
and possibility to append to a list $l$ a certain number of
zero's to make it of length $n$:
\begin{verbatim}

        MKLIST n ;    n is an INTEGER

        MKLIST(l,n);    l is List-like, n is an INTEGER

\end{verbatim}

\item[ii.]
Generation of a list of sublists of length n containing p elements
equal to 0 and q elements equal to 1 such that  $$p+q=n .$$
The function \f{SEQUENCES} works both in algebraic and
symbolic modes.  Here is an example in the algebraic mode:
\begin{verbatim}

        SEQUENCES 2 ; ==> {{0,0},{0,1},{1,0},{1,1}}

\end{verbatim}
An arbitrary splitting of a list can be done. The function \f{SPLIT} 
generates a list which contains the splitted parts of the original list.
\begin{verbatim}
        
        SPLIT({a,b,c,d},{1,1,2}) ==> {{a},{b},{c,d}}

\end{verbatim}
The function \f{ALGNLIST} constructs a list which contains n copies  
of a list bound to its first argument.
\begin{verbatim}

        ALGNLIST({a,b,c,d},2); ==> {{a,b,c,d},{a,b,c,d}}

\end{verbatim}
The function \f{KERNLIST} transforms any prefix of a kernel into the
{\bf \verb+list+} prefix. The output list is a copy:
\begin{verbatim}

        KERNLIST (); ==> {}

\end{verbatim}
Four functions to delete elements are \f{DELETE, REMOVE, DELETE\_ALL} and
\f{DELPAIR}. The first two act as in symbolic mode, and the third
eliminates from a given list {\em all}
elements equal to its first argument. The fourth acts on a list of pairs
and eliminates from it the {\em first} pair whose first element is equal to
its first argument :
\begin{verbatim}

        DELETE(x,{a,b,x,f,x}); ==> {a,b,f,x}

        REMOVE({a,b,x,f,x},3); ==> {a,b,f,x}

        DELETE_ALL(x,{a,b,x,f,x}); ==> {a,b,f}

        DELPAIR(a,{{a,1},{b,2},{c,3}}; ==> {{b,2},{c,3}}

\end{verbatim}
\item[iv.]
The function \f{ELMULT} returns an {\em integer} which is the
{\em multiplicity} of its first argument inside the list which is its
second argument.
The function \f{FREQUENCY} gives a list of pairs
whose second element indicates the number of times the first element
appears inside the original list:
\begin{verbatim}

        ELMULT(x,{a,b,x,f,x}) ==> 2

        FREQUENCY({a,b,c,a}); ==> {{a,2},{b,1},{c,1}}

\end{verbatim}
\item[v.]
The function \f{INSERT} allows one to insert a given object into a list
at the desired position.

The functions \f{INSERT\_KEEP\_ORDER} and \f{MERGE\_LIST} allow one to
keep a given ordering when inserting one element inside a list or
when merging two lists. Both have 3 arguments. The last one  is
the name of a binary boolean ordering function:
\begin{verbatim}

        ll:={1,2,3}$

        INSERT(x,ll,3); ==> {1,2,x,3}

        INSERT_KEEP_ORDER(5,ll,lessp); ==> {1,2,3,5}

        MERGE_LIST(ll,ll,lessp); ==> {1,1,2,2,3,3}

\end{verbatim}
Notice that \f{MERGE\_LIST} will act correctly only if the two lists 
are well ordered themselves. 
\item[vi.]
Algebraic lists can be read from right to left or left to right.
They {\em look} symmetrical. One would like to dispose of manipulation
functions which reflect this.
So, to the already defined functions  \f{FIRST} and \f{REST} are
added the functions \f{LAST}  and \f{BELAST}. \f{LAST} gives the last
element of the list while \f{BELAST} gives the list {\em without} its
last element. \\
Various additional functions are provided. They are:
\bq
\noindent
\f{ . (``dot''), POSITION, DEPTH, MKDEPTH\_ONE, \\
PAIR, APPENDN, REPFIRST, REPREST}
\eq
The token ``dot'' needs a special comment. It corresponds to
several different operations.
\begin{enumerate}
\item If one applies it on the left of a list, it acts as the \f{CONS}
function. Note however that blank spaces are required around the dot:
\begin{verbatim}

        4 . {a,b}; ==> {4,a,b}

\end{verbatim}
\item If one applies it on the right of a list, it has the same
effect as the \f{PART} operator:
\begin{verbatim}

         {a,b,c}.2; ==> b

\end{verbatim}
\item If one applies it to  a 4--dimensional vectors, it acts as in the
HEPHYS package.
\end{enumerate}
\f{POSITION} returns the POSITION of the first occurrence of x in
a list or a message if x is not present in it.

\f{DEPTH} returns an {\em integer} equal to the number of levels where a
   list is found if and only if this number is the {\em same} for each
   element of the list  otherwise it returns a message telling the user
  that the list is of {\em unequal depth}. The function \f{MKDEPTH\_ONE}
  allows to transform any list into a list of depth equal to 1.

\f{PAIR} has two arguments which must be lists. It returns a list
whose elements are {\em lists of two elements.}
The $n^{th}$ sublist contains the $n^{th}$ element of the first list
and the $n^{th}$ element of the second list. These types of lists are called
{\em association lists} or ALISTS in the following.
To test for these type of lists a boolean function \f{ABAGLISTP}
is provided. It will be discussed below.\\
\f{APPENDN} has {\em any} fixed number of lists as arguments. It
generalizes the already existing function \f{APPEND} which accepts
only two lists as arguments. It may also be used for arbitrary kernels 
but, in that case, it is important to notice that {\em the concatenated 
object is always a list}.\\
\f{REPFIRST} has two arguments. The first one is any object, the second one
is a list. It replaces the first element of the list by the object. It
works like the symbolic function \f{REPLACA} except that the
original list is not destroyed.\\
\f{REPREST} has also two arguments. It replaces the rest of the list by
its first argument and returns the new list {\em without destroying} the
original list. It is analogous to the symbolic function \f{REPLACD}.
Here are examples:
\begin{verbatim}

        ll:={{a,b}}$
        ll1:=ll.1; ==> {a,b}
        ll.0; ==> list
        0 . ll; ==> {0,{a,b}}

        DEPTH ll; ==> 2

        PAIR(ll1,ll1); ==> {{a,a},{b,b}}

        REPFIRST{new,ll); ==> {new}

        ll3:=APPENDN(ll1,ll1,ll1); ==> {a,b,a,b,a,b}

        POSITION(b,ll3); ==> 2

        REPREST(new,ll3); ==> {a,new}

\end{verbatim}
\item[vii.]
The functions \f{ASFIRST, ASLAST, ASREST, ASFLIST, ASSLIST, \\RESTASLIST}
act on ALISTS or on lists of lists of well defined depths
and have two arguments. The first is the key object
which one seeks to associate in some way with an element of the association
list which is the second argument.\\
\f{ASFIRST} returns the pair whose first element is equal to the
first argument.\\
\f{ASLAST} returns the pair whose last element is equal to the first
argument.\\
\f{ASREST} needs a {\em list} as its first argument. The function
seeks the first sublist of a list of lists (which is its second argument)
equal to its first argument and returns it.\\
\f{RESTASLIST} has a {\em list of keys} as its first argument. It
returns the collection of pairs which meet the criterium of \f{ASREST}.\\
\f{ASFLIST} returns a list containing {\em all pairs} which
satisfy the criteria of the function \f{ASFIRST}. So the output
is also an association list.\\
\f{ASSLIST} returns a list which contains {\em all pairs} which have
their second element equal to the first argument.\\
Here are a few examples:
\begin{verbatim}

        lp:={{a,1},{b,2},{c,3}}$

        ASFIRST(a,lp); ==> {a,1}

        ASLAST(1,lp); ==> {a,1}

        ASREST({1},lp); ==> {a,1}

        RESTASLIST({a,b},lp); ==> {{1},{2}}

        lpp:=APPEND(lp,lp)$

        ASFLIST(a,lpp); ==> {{a,1},{a,1}}

        ASSLIST(1,lpp); ==> {{a,1},{a,1}}

\end{verbatim}
\item[vii.] The function \f{SUBSTITUTE} has three arguments. The first
is the object to be substituted, the second is the object which must be
replaced by the first, and the third is the list in which the substitution 
must be made. Substitution is made to
all levels. It is a more elementary function than \f{SUB} but its
capabilities are less. When dealing with algebraic quantities, it is
important to make sure that {\em all} objects involved in the function
have either the prefix lisp or the standard quotient representation
otherwise it will not properly work.
\end{itemize}
\section{ The Bag Structure and its Associated Functions}
The LIST structure of \REDUCE\ is very convenient for manipulating
groups of objects which are, a priori, unknown. This structure is
endowed with other properties such as ``mapping'' i.e. the fact that
if \verb+OP+ is an operator one gets, by default,
\begin{verbatim}

        OP({x,y}); ==> {OP(x),OP(y)}

\end{verbatim}
It is not permitted to submit lists to the operations valid on rings
so that, for example, lists cannot be indeterminates of polynomials.\\
Very frequently too, procedure arguments cannot be lists.
At the other extreme, so to say, one has the \verb+KERNEL+
structure associated
with the algebraic declaration \verb+operator+ .  This structure behaves as
an ``unbreakable'' one and, for that reason, behaves
like an ordinary identifier.
It may generally be bound to all non-numeric procedure parameters
and it may appear
as an ordinary indeterminate inside polynomials. \\
The \verb+BAG+ structure is intermediate between a list and an operator.
From the operator it borrows the property of being a \verb+KERNEL+ and,
therefore, may be an indeterminate of a polynomial. From the list structure
it borrows the property of being a {\em composite} object.\\[5pt]
\mbox{\underline{{\bf Definition}:\hfill}}\\[4pt]
A bag is an object endowed with the following properties:
\begin{enumerate}
\item It is a \verb+KERNEL+ i.e. it is  composed of an atomic prefix (its
envelope) and
its content (miscellaneous objects).
\item Its content may be handled in an analogous way as the content of a
list. The important difference is that during these manipulations 
the name of the bag is {\em kept}.
\item Properties may be given to the envelope. For instance, one may
declare it \verb+NONCOM+ or \verb+SYMMETRIC+ etc.\ $\ldots$
\end{enumerate}
\vspace{5pt}
\mbox{\underline{{\bf Available Functions}:\hfill}}
\bi
\item[i.] A default bag envelope \verb+BAG+ is defined.
It is a reserved identifier.
An identifier other than \verb+LIST+ or one which is already associated
with a boolean function may be defined as a bag envelope through the
command \f{PUTBAG}. In particular, any operator may also be declared
to be a bag. {\bf When and only when} the identifier is not an already defined
function does \f{PUTBAG} put on it the property of an OPERATOR PREFIX.
The command:
\begin{verbatim}

        PUTBAG id1,id2,....idn;

\end{verbatim}
declares \verb+id1,.....,idn+ as bag envelopes.
Analogously, the command
\begin{verbatim}

        CLEARBAG id1,...idn;

\end{verbatim}
eliminates the bag property on \verb+id1,...,idn+.
\item[ii.] The boolean function \f{BAGP} detects the bag property.
Here is an example:
\begin{verbatim}

        aa:=bag(x,y,z)$

        if BAGP aa then "ok"; ==> ok

\end{verbatim}
\item[iii.] The functions listed below may act both on lists or bags.
Moreover, functions subsequently  defined for  SETS also work for a bag
when its content is a set.
Here is a list of the main ones:

\begin{quotation}
\noindent
\f{FIRST, SECOND, LAST, REST, BELAST, DEPTH, LENGTH, REVERSE,\\
MEMBER, APPEND, . (``dot''), REPFIRST, REPREST} $\ldots$
\end{quotation}

However, since they keep track of the envelope, they act
somewhat differently. Remember that   
\vspace{5pt}
\begin{center}
the NAME of the ENVELOPE is KEPT by the functions \\[3pt]
\f{FIRST, SECOND and LAST}.
\end{center}
Here are a few examples (more examples are
given inside the test file):
\begin{verbatim}

        PUTBAG op; ==> T

        aa:=op(x,y,z)$

        FIRST op(x,y,z); ==> op(x)

        REST op(x,y,z); ==> op(y,z)

        BELAST op(x,y,z); ==> op(x,y)

        APPEND(aa,aa); ==> op(x,y,z,x,y,z)

        APPENDN(aa,aa,aa); ==> {x,y,z,x,y,z,x,y,z}

        LENGTH aa; ==> 3

        DEPTH aa; ==> 1

        MEMBER(y,aa); ==> op(y,z)

\end{verbatim}
When ``appending'' two bags with {\em different} envelopes, the resulting bag
gets the name of the one bound to the first parameter of \f{APPEND}. When  
\f{APPENDN} is used, the output is always a list.\\
The function \f{LENGTH} gives the number of objects contained in the 
bag.
\item[iv.]
The connection between the list and the bag structures is made easy
thanks to \f{KERNLIST} which transforms a bag into a list and thanks to
the coercion function \f{LISTBAG} which transforms a list into a bag. 
This function has 2 arguments
and is used as follows:
\begin{verbatim}

        LISTBAG(,); ==> ()

\end{verbatim}
The identifier \verb++, if allowed, is automatically declared as a bag
envelope or an error message is generated. \\[3pt]
Finally, two boolean functions which work both for bags and lists are
provided. They are \f{BAGLISTP} and \f{ABAGLISTP}.
They return t or nil (in a conditional statement) if their argument
is a bag or a list for the first one, or if their argument is a list of
sublists or a bag containing bags for the second one.
\end{itemize}
\section{Sets and their Manipulation Functions}
Functions for sets exist at the level of symbolic mode. The
package makes them available in algebraic mode but also {\em generalizes}
them so that they can be applied to bag-like objects as well.
\bi
\item[i.]
The constructor \f{MKSET} transforms a list or bag into a set by eliminating
duplicates.
\begin{verbatim}

        MKSET({1,a,a}); ==> {1,a}
        MKSET bag(1,a,1,a); ==> bag(1,a)

\end{verbatim}

\f{SETP} is a boolean function which recognizes set--like objects.
\begin{verbatim}

        if SETP {1,2,3} then ... ;

\end{verbatim}
\item[ii.]
The available functions are
\begin{center}
\f{UNION, INTERSECT, DIFFSET, SYMDIFF}.
\end{center}
They have two arguments which must be sets otherwise an error message
is issued.
Their meaning is transparent from their name. They respectively give the
union, the intersection, the difference and the symmetric difference of two
sets.
\ei
\section{General Purpose Utility Functions}
Functions in this sections have various purposes. They have all been used
many times in applications in some form or another. The form given
to them in this package is adjusted to maximize their range of applications.
\bi
\item[i.]
The functions \f{MKIDNEW DELLASTDIGIT DETIDNUM LIST\_TO\_IDS}
handle identifiers. 

\f{MKIDNEW} has either 0 or 1 argument. 
It generates an identifier which has not yet been used before.
\begin{verbatim}

        MKIDNEW(); ==> g0001

        MKIDNEW(a); ==> ag0002

\end{verbatim}
\f{DELLASTDIGIT} takes an integer as argument and strips it from its last
digit.
\begin{verbatim}

        DELLASTDIGIT 45; ==> 4

\end{verbatim}
\f{DETIDNUM} deletes the last digit from an
identifier. It is a very convenient function when one wants to make a do
loop starting from a set of indices $ a_1, \ldots , a_{n} $.
\begin{verbatim}

        DETIDNUM a23; ==> 23

\end{verbatim}

\f{LIST\_to\_IDS} generalizes the function \f{MKID} to a list of
atoms. It creates and intern an identifier from the concatenation of
the atoms. The first atom cannot be an integer.
\begin{verbatim}

        LIST_TO_IDS {a,1,id,10}; ==> a1id10

\end{verbatim}
The function \f{ODDP}  detects odd integers.

The function \f{FOLLOWLINE} is convenient when using the function \f{PRIN2}.
It allows one to format output text in a much more flexible way than with
the function \f{WRITE}. \\
Try the following examples :
\begin{verbatim}

        <>$ ==> ?

        <>; ==> ?

\end{verbatim}
The function \f{==} is a short and convenient notation for the \f{SET}
function. In fact it is a {\em generalization} of it to allow one to
deal also with KERNELS:
\begin{verbatim}

        operator op;

        op(x):=abs(x)$

        op(x) == x; ==> x

        op(x); ==> x
        
        abs(x); ==> x

\end{verbatim}
The function \f{RANDOMLIST} generates a list of random numbers. It takes
two arguments which are both integers. The first one indicates the range
inside which the random numbers are chosen. The second one indicates how
many numbers are to be generated. Its output is the list of 
generated numbers.
\begin{verbatim}

        RANDOMLIST(10,5); ==> {2,1,3,9,6}

\end{verbatim}
\f{MKRANDTABL} generates a table of random numbers. This table is either
a one or two dimensional array. The base of random numbers may be either
an integer or a decimal number. In this last case, to work properly,
the switch \f{rounded} must be ON. It has three arguments. The first is
either a one integer or a two integer list. The second is the base chosen
to generate the random numbers. The third is the chosen name for the
generated array. In the example below a two-dimensional table of
random integers is generated as array elements of the identifier {\f ar}.
\begin{verbatim}

        MKRANDTABL({3,4},10,ar); ==>

               *** array ar redefined

                      {3,4}

\end{verbatim}
The output is the dimension of the constructed array.

\f{PERMUTATIONS} gives the list of permutations of $n$ objects.
Each permutation is itself a list. \f{CYCLICPERMLIST} gives the list of
{\em cyclic} permutations. For both functions, the argument may
also be a {\tt bag}.
\begin{verbatim}

        PERMUTATIONS {1,2} ==> {{1,2},{2,1}}

        CYCLICPERMLIST {1,2,3} ==>

                {{1,2,3},{2,3,1},{3,1,2}}

\end{verbatim}
\f{PERM\_TO\_NUM} and \f{NUM\_TO\_PERM} allow to associate to a given 
permutation of n numbers or identifiers a number between $0$ and 
$n! - 1$. The first function has the two permutated lists  
as its arguments and it returns an integer. The second one has an integer  
as its first argument and a list as its second argument. It returns the 
list of permutated objects.
\begin{verbatim}

        PERM_TO_NUM({4,3,2,1},{1,2,3,4}) ==> 23

        NUM_TO_PERM(23,{1,2,3,4}); ==> {4,3,2,1}

\end{verbatim}
\f{COMBNUM} gives the number of combinations of $n$ objects
taken $p$ at a time. It has the two integer arguments $n$ and $p$.

\f{COMBINATIONS} gives a list of combinations on $n$ objects taken $p$
at a time. It has two arguments. The first one is a list (or a bag) and
the second one is the integer $p$.
\begin{verbatim}

        COMBINATIONS({1,2,3},2) ==> {{2,3},{1,3},{1,2}}

\end{verbatim}
\f{REMSYM} is a command that suppresses the effect of the \REDUCE\ commands
\verb+symmetric+ or \verb+antisymmetric+ .

\f{SYMMETRIZE} is a powerful function which generates a symmetric expression.
It has 3 arguments. The first is a list (or a list of lists) containing
the expressions which will appear as variables for a kernel. The second
argument is the kernel-name and the third is a permutation function
which exists either in algebraic or symbolic mode. This
function may be constructed by the user. Within this package
the two functions \f{PERMUTATIONS} and \f{CYCLICPERMLIST} may be used.
Examples:
\begin{verbatim}

        ll:={a,b,c}$

        SYMMETRIZE(ll,op,cyclicpermlist); ==>

                OP(A,B,C) + OP(B,C,A) + OP(C,A,B)

        SYMMETRIZE(list ll,op,cyclicpermlist); ==>

                OP({A,B,C}) + OP({B,C,A}) + OP({C,A,B})

\end{verbatim}
Notice that, taking for the first argument a list of lists gives rise to
an expression where  each kernel has a {\em list as argument}. Another
peculiarity of this function is the fact that, unless a pattern matching is
made on the operator \verb+OP+, it needs to be reevaluated. This peculiarity
is convenient when \verb+OP+ is an abstract operator if one wants to 
control the subsequent simplification process. Here is an illustration:
\begin{verbatim}

        op(a,b,c):=a*b*c$

        SYMMETRIZE(ll,op,cyclicpermlist); ==>

                 OP(A,B,C) + OP(B,C,A) + OP(C,A,B)

        REVAL ws; ==>
                 
                 OP(B,C,A) + OP(C,A,B) + A*B*C

        for all x let op(x,a,b)=sin(x*a*b);

        SYMMETRIZE(ll,op,cyclicpermlist); ==>

                  OP(B,C,A) + SIN(A*B*C) + OP(A,B,C)

\end{verbatim}
The functions \f{SORTNUMLIST} and \f{SORTLIST} are functions which sort
lists. They use the {\em bubblesort} and the {\em quicksort} algorithms.

\f{SORTNUMLIST} takes as argument a list of numbers. It sorts it in
increasing order.

\f{SORTLIST} is a generalization of the above function.
It sorts the list according
to any well defined ordering. Its first argument is the list and its
second argument is the ordering function. The content of the list
need not necessarily be numbers but must be such that the ordering function
has a meaning.
\f{ALGSORT} exploits the PSL \f{SORT} function. It is intended to replace
the two functions above.
\begin{verbatim}

        l:={1,3,4,0}$  SORTNUMLIST l; ==> {0,1,3,4}

        ll:={1,a,tt,z}$ SORTLIST(ll,ordp); ==> {a,z,tt,1}

        l:={-1,3,4,0}$  ALGSORT(l,>); ==> {4,3,0,-1}

\end{verbatim}
It is important to realise that using these functions for kernels or bags
may be dangerous since they are destructive. If it is necessary, it is
recommended to first apply \f{KERNLIST} to them to act on a copy.

The function \f{EXTREMUM} is a generalization of the already defined functions
\f{MIN, MAX} to include general orderings. It is a 2 argument function.
The first is the list and the second is the ordering function.
With the list \verb+ll+ defined in the last example, one gets
\begin{verbatim}

        EXTREMUM(ll,ordp); ==> 1

\end{verbatim}

\f{GCDNL} takes a list of integers as argument and returns their gcd.  
\item[iii.] There are four functions to identify dependencies.
\f{FUNCVAR} takes any expression as argument and returns the set of
variables on which it depends. Constants are  eliminated.
\begin{verbatim}

        FUNCVAR(e+pi+sin(log(y)); ==> {y}

\end{verbatim}
\f{DEPATOM} has an {\bf atom} as argument. It returns it if it is
a number or if no dependency has previously been declared. Otherwise,
it returns the list of variables which the prevoius \f{DEPEND} declarations
imply.
\begin{verbatim}

        depend a,x,y;

        DEPATOM a; ==> {x,y}

\end{verbatim}
The functions \f{EXPLICIT} and \f{IMPLICIT} make explicit or
implicit the dependencies. This example shows how they work:
\begin{verbatim}

        depend a,x; depend x,y,z;

        EXPLICIT a; ==> a(x(y,z))

        IMPLICIT ws; ==> a

\end{verbatim}
These are useful when one wants to trace the names of the independent 
variables
and (or) the nature of the dependencies.

\f{KORDERLIST} is a zero argument function which displays the actual
ordering.
\begin{verbatim}

        korder x,y,z;

        KORDERLIST; ==> (x,y,z)

\end{verbatim}

\item[iv.] A command \f{REMNONCOM} to remove the non-commutativity of 
operators previously declared non-commutative is available. Its use is like 
the one of the command \f{NONCOM}.

\item[v.] Filtering functions for lists.

\f{CHECKPROPLIST}  is a  boolean function which checks if the
elements of a list have a definite property. Its first argument
is the list, its second argument is a boolean function
(\f{FIXP NUMBERP $\ldots$}) or an ordering function (as \f{ORDP}).

\f{EXTRACTLIST} extracts from the list given as its first argument
the elements which satisfy the boolean function given as its second
argument. For example:
\begin{verbatim}

        if CHECKPROPLIST({1,2},fixp) then "ok"; ==> ok

        l:={1,a,b,"st")$

        EXTRACTLIST(l,fixp); ==> {1}

        EXTRACTLIST(l,stringp); ==> {st}

\end{verbatim}
\item[vi.] Coercion.

Since lists and arrays have quite distinct behaviour and storage properties,  
it is interesting to coerce lists into arrays and vice-versa in order to 
fully exploit the advantages of both datatypes. The functions  
\f{ARRAY\_TO\_LIST} and \f{LIST\_TO\_ARRAY} are provided to do that easily.
The first function has the array identifier as its unique argument. 
The second
function has three arguments. The first is the list, the second is the 
dimension of the array and the third is the identifier which defines it.  
If the chosen dimension is not compatible with the
the list depth, an error message is issued.  
As an illustration suppose that $ar$ is an array whose components are  
1,2,3,4. then
\begin{verbatim}

        ARRAY_TO_LIST ar; ==> {1,2,3,4}

        LIST_TO_ARRAY({1,2,3,4},1,arr}; ==> 

\end{verbatim}
generates the array $arr$ with the components 1,2,3,4.
\item[vii.] Control of the \f{HEPHYS} package.  

The commands \f{REMVECTOR} and \f{REMINDEX} remove the property of 
being a 4-vector or a 4-index respectively. 

The function \f{MKGAM} allows to assign to any identifier the property 
of a Dirac gamma matrix and, eventually, to suppress it. Its interest lies 
in the fact that, during a calculation, it is often useful to transform 
a gamma matrix into an abstract operator and vice-versa. Moreover, in many 
applications in basic physics, it is interesting to use the identifier $g$ 
for other purposes.  
It takes two arguments. The first is the identifier. The second must be 
chosen equal to {\tt\bf t} if one wants to transform it into a gamma matrix. Any
other binding for this second argument suppresses the property of being 
a gamma matrix the identifier is supposed to have. 
\ei
\section{Properties and Flags}
In spite of the fact that many facets of the handling of
property lists is easily accessible in algebraic mode, it is useful to
provide analogous functions {\em genuine} to the algebraic mode. The reason is
that, altering property lists of objects, may easily destroy the integrity
of the system. The functions, which are here described, {\bf do ignore}
the property list and flags already defined by the system itself. They
generate and track the {\em addtional properties and flags} that the user
issues using them. They offer him
the  possibility to work on property lists so
that he can design a programming style of the ``conceptual'' type.
\bi
\item[i.] We first consider ``flags''. \\
To a given identifier, one may
associate another one linked to it ``in the background''. The  three
functions \f{PUTFLAG, DISPLAYFLAG} and \f{CLEARFLAG} handle them.

\f{PUTFLAG} has 3 arguments. The first one is the identifier or a list
of identifiers, the second one is the name of the flag,
and the third one is T (true) or 0 (zero).
When the third argument is T, it creates the flag, when it is 0 it
destroys it. In this last case, the function does return nil (not seen 
inside the algebraic mode).
\begin{verbatim}

        PUTFLAG(z1,flag_name,t); ==> flag_name

        PUTFLAG({z1,z2},flag1_name,t); ==> t

        PUTFLAG(z2,flag1_name,0) ==>

\end{verbatim}
\f{DISPLAYFLAG} allows one to extract flags. The previous actions give:
\begin{verbatim}

        DISPLAYFLAG z1; ==>{flag_name,flag1_name}

        DISPLAYFLAG z2 ; ==> {}

\end{verbatim}
\f{CLEARFLAG} is a command which clears {\em all} flags associated with
the identifiers $id_1, \ldots , id_n .$
\item[ii.] Properties are handled by similar functions.
\f{PUTPROP} has four arguments. The second argument is, here, the
{\em indicator} of the property. The third argument may be {\em any
valid expression}. The fourth one is also T or 0.
\begin{verbatim}

        PUTPROP(z1,property,x^2,t); ==> z1

\end{verbatim}
In general, one enters
\begin{verbatim}

        PUTPROP(LIST(idp1,idp2,..),,,T);

\end{verbatim}
To display a specific property, one uses
\f{DISPLAYPROP} which takes two arguments. The first is the name of the
identifier, the second is the indicator of the property.
\begin{verbatim}

                                                 2
        DISPLAYPROP(z1,property); ==> {property,x  }

\end{verbatim}
Finally, \f{CLEARPROP} is a nary commmand which clears {\em all}
properties of the identifiers which appear as arguments.
\ei
\section{Control Functions}
Here we describe additional functions which
improve user control on the environment.
\bi
\item[i.]
The first set of functions is composed of unary and binary boolean functions.
They are:
\begin{verbatim}

        ALATOMP x;    x is anything.
        ALKERNP x;    x is anything.
        DEPVARP(x,v); x is anything.

           (v is an atom or a kernel)

\end{verbatim}
\f{ALATOMP} has the value T iff x is an integer or  an identifier
{\em after} it has been evaluated down to the bottom.

\f{ALKERNP} has the value T iff x is a kernel {\em after}
it has been evaluated down to the bottom.

\f{DEPVARP} returns T iff the expression x depends on v at
{\bf any level}.

The above functions together with \f{PRECP} have
 been declared operator functions to ease the verification of
their value.

\f{NORDP} is equal to \verb+NOT+\f{ ORDP}.
\item[ii.]
The next functions allow one to {\em analyze} and to
{\em clean} the environment
of \REDUCE\ created by the user while working
{\bf interactively}. Two functions are provided:\\
\f{SHOW} allows the user to get the various identifiers already
assigned and to see their type. \f{SUPPRESS} selectively clears the
used identifiers or clears them all. It is to be stressed that identifiers
assigned from the input of files are {\bf ignored}.
Both functions have one argument and the same options for this
argument:
\begin{verbatim}

       SHOW (SUPPRESS) all
       SHOW (SUPPRESS) scalars
       SHOW (SUPPRESS) lists
       SHOW (SUPPRESS) saveids    (for saved expressions)
       SHOW (SUPPRESS) matrices
       SHOW (SUPPRESS) arrays
       SHOW (SUPPRESS) vectors
                    (contains vector, index and tvector)
       SHOW (SUPPRESS) forms

\end{verbatim}
The option \verb+all+ is the most convenient for \f{SHOW} but,
with it, it may
takes some time to get the answer after one has worked several hours.
When entering \REDUCE\ the option \verb+all+ for \f{SHOW} gives:
\begin{verbatim}

        SHOW all; ==>

                scalars are: NIL
                arrays are: NIL
                lists are: NIL
                matrices are: NIL
                vectors are: NIL
                forms are: NIL

\end{verbatim}
It is a convenient way to remind the various options. Here is an example
which is valid when one starts from a fresh environment:
\begin{verbatim}

        a:=b:=1$

        SHOW scalars; ==>  scalars are: (A B)

        SUPPRESS scalars; ==> t

        SHOW scalars; ==>  scalars are: NIL

\end{verbatim}
\item[iii.]
The \f{CLEAR} function of the system does not do a complete cleaning of
\verb+OPERATORS+ and \verb+FUNCTIONS+ . The following two functions do a more


complete cleaning and, also, automatically takes into account the
{\em user} flag and properties that the functions
\f{PUTFLAG} and \f{PUTPROP} may have introduced.


Their names are \f{CLEAROP} and \f{CLEARFUNCTIONS}.
\f{CLEAROP} takes one operator as its argument.\\
 \f{CLEARFUNCTIONS} is a nary command. If one issues


\begin{verbatim}


        CLEARFUNCTIONS a1,a2, ... , an $

\end{verbatim}
The functions with names \verb+ a1,a2, ... ,an+  are cleared.
One should be careful when  using this facility since the
only functions which cannot be erased are those which are
protected with the \verb+lose+ flag.
\ei
\section{Handling of Polynomials}
The module contains some utility functions to handle
standard quotients and several new facilities to manipulate polynomials.
\bi
\item[i.] Two functions \f{ALG\_TO\_SYMB} and \f{SYMB\_TO\_ALG}
allow one to change an expression which is in the algebraic standard
quotient form into a prefix lisp form and vice-versa. This is done
in such a way that the symbol \verb+list+ which appears in the
algebraic mode disappears in the symbolic form (there it becomes
a parenthesis ``()'' ) and it is reintroduced in the translation
from a symbolic prefix lisp expression  to an algebraic one.
Here, is an example, showing how the wellknown lisp function
\f{FLATTENS} can be trivially transposed inside the algebraic mode:
\begin{verbatim}

     algebraic procedure ecrase x;
     lisp symb_to_alg flattens1 alg_to_symb algebraic x;

      symbolic procedure flattens1 x;
      % ll; ==> ((A B) ((C D) E))
      % flattens1 ll; (A B C D E)
        if atom x then list x else
        if cdr x then
            append(flattens1 car x, flattens1 cdr x)
          else flattens1 car x;

\end{verbatim}


gives, for instance,
\begin{verbatim}

        ll:={a,{b,{c},d,e},{{{z}}}}$


        ECRASE ll; ==> {A, B, C, D, E, Z}



\end{verbatim}
The function \f{MKDEPTH\_ONE} described above implements that functionality.
\item[ii.]
\f{LEADTERM} and \f{REDEXPR} are the algebraic equivalent of the
symbolic functions \f{LT} and \f{RED}. They give, respectively, the
{\em leading term} and the {\em reductum} of a polynomial. They also work
for rational functions. Their interest lies in the fact that they do not
@@require one to extract the main variable. They work according to the current
ordering of the system:
\begin{verbatim}

        pol:=x++y+z$

        LEADTERM pol; ==> x

        korder y,x,z;

        LEADTERM pol; ==> y

        REDEXPR pol; ==> x + z

\end{verbatim}
By default, the representation of multivariate polynomials is recursive.
It is justified since it is the one which takes the least memory.
With such a representation, the function \f{LEADTERM} does not necessarily
extract a true monom. It extracts a monom in the leading indeterminate
multiplied by a polynomial in the other indeterminates. However, very often,
 one needs to handle true monoms separately. In that case, one needs a
polynomial in {\em distributive} form. Such a form is provided by the
package GROEBNER (H. Melenk et al.). The facility there is, however,
much too involved in many applications and the necessity to load the package 
makes it interesting
to construct an elementary facility to handle the distributive representation 
of polynomials. A new switch has been created for that purpose.
It is called {\tt DISTRIBUTE} and a new function \f{DISTRIBUTE} puts a
polynomial in distributive form. With that switch set to {\bf on},
\f{LEADTERM} gives {\bf true} monoms.

\f{MONOM} transforms a polynomial into a list of monoms. It works
{\em whatever the position of the switch} {\tt DISTRIBUTE}.

\f{SPLITTERMS} is analoguous to \f{MONOM} except that it gives
a list of two lists. The first sublist contains the positive terms
while the second sublist contains the negative terms.

\f{SPLITPLUSMINUS}  gives a list whose first element is the positive
part of the polynomial and its second element is its negative part.
\item[iii.]
Two complementary functions \f{LOWESTDEG} and \f{DIVPOL} are provided.
The first takes a polynomial as its first argument and the name of an
indeterminate as its second argument. It returns the {\em lowest degree}
 in that indeterminate. The second function takes two polynomials and
returns both the quotient and its remainder.
\ei
\section{Handling of Transcendental Functions}
%\item[i.]
The functions \f{TRIGREDUCE} and \f{TRIGEXPAND} and the equivalent
@@ones for hyperbolic functions \f{HYPREDUCE} and \f{HYPEXPAND}
make the transformations to multiple arguments and from
@@multiple arguments to elementary arguments. Here is a simple example:
\begin{verbatim}

        aa:=sin(x+y)$

        TRIGEXPAND aa; ==> SIN(X)*COS(Y) + SIN(Y)*COS(X)

        TRIGREDUCE ws; ==> SIN(Y + X)

\end{verbatim}
When a trigonometric or hyperbolic expression is symmetric with
respect to the interchange of {\tt SIN (SINH)} and {\tt COS (COSH)},
the application of\nl \f{TRIG(HYP)-REDUCE} may often lead to great
simplifications. However, if it is highly assymetric, the repeated
application of \f{TRIG(HYP)-REDUCE} followed by the use of
\f{TRIG(HYP)-EXPAND} will lead to {\em more} complicated
but more symmetric expressions:
\begin{verbatim}

        aa:=(sin(x)^2+cos(x)^2)^3$

        TRIGREDUCE aa; ==> 1

\end{verbatim}
\begin{verbatim}

        bb:=1+sin(x)^3$



        TRIGREDUCE bb; ==>

                - SIN(3*X) + 3*SIN(X) + 4
               ---------------------------
                           4

         TRIGEXPAND ws; ==>


                3                  2
          SIN(X)  - 3*SIN(X)*COS(X)  + 3*SIN(X) + 4
          -------------------------------------------
                             4

\end{verbatim}
%\ei
%\section{Coercion from lists to arrays and converse}
%Sometimes when a list  is very long and,
% especially if frequent access to its elements are needed,
%it is advantageous to (temporarily) transform it into an array.\nl
%\f{LIST\_TO\_ARRAY} has three arguments. The first is the list. The
%second is an integer which indicates the array dimension required. The
%third is the name of an identifier which will play the role of the array
%name generated by it. If the chosen dimension is not compatible with the
% the list depth, an error message is issued.  
%\f{ARRAY\_TO\_LIST} does the opposite coercion. It takes the array
%name as its unique argument.
\section{Handling of n--dimensional Vectors}
Explicit vectors in {\tt EUCLIDEAN} space may be represented by
list-like or bag-like objects of depth 1.
The components may be bags but may {\bf not} be lists.
Functions are provided to do the sum, the difference and the
@@scalar product. When the space-dimension is three there are also functions
for the cross and mixed products.
\f{SUMVECT, MINVECT, SCALVECT, CROSSVECT} have two arguments.
\f{MPVECT} has three arguments. The following example
is sufficient to explain how they work:
\begin{verbatim}

       l:={1,2,3}$

       ll:=list(a,b,c)$

       SUMVECT(l,ll); ==> {A + 1,B + 2,C + 3}

       MINVECT(l,ll); ==> { - A + 1, - B + 2, - C + 3}

       SCALVECT(l,ll); ==> A + 2*B + 3*C

       CROSSVECT(l,ll); ==> { - 3*B + 2*C,3*A - C, - 2*A + B}

       MPVECT(l,ll,l); ==> 0

\end{verbatim}
\section{Handling of Grassmann Operators}
Grassman variables are often used in physics. For them the multiplication
operation is associative, distributive but anticommutative. The
{\tt KERNEL} of \REDUCE\ does not provide it. However, implementing
it in full generality would almost
certainly decrease the overall efficiency of the system. This small
module together with the declaration of antisymmetry for operators is
enough to deal with most calculations. The reason is, that a
product of similar anticommuting kernels can easily  be transformed
into an antisymmetric operator with as many indices as the number of
these kernels. Moreover, one may also issue pattern matching rules
to implement the anticommutativity of the product.
The functions in this module represent the minimum functionality
required to identify them and to handle their specific features.

\f{PUTGRASS} is a (nary) command which give identifiers the property
@@of being the names of Grassmann kernels. \f{REMGRASS} removes this property.

\f{GRASSP} is a boolean function which detects grassmann kernels.

\f{GRASSPARITY} takes a {\bf monom}  as argument and gives its parity.
If the monom is a simple grassmann kernel it returns 1.

\f{GHOSTFACTOR} has two arguments. Each one is a monom. It is equal to
\begin{verbatim}

        (-1)**(GRASSPARITY u * GRASSPARITY v)

\end{verbatim}
Here is an illustration to show how the above functions work:
\begin{verbatim}

        PUTGRASS eta; ==> t

        if GRASSP eta(1) then "grassmann kernel"; ==>

                        grassmann kernel

        aa:=eta(1)*eta(2)-eta(2)*eta(1); ==>

                AA :=  - ETA(2)*ETA(1) + ETA(1)*ETA(2)

        GRASSPARITY eta(1); ==> 1

        GRASSPARITY (eta(1)*eta(2)); ==> 0

        GHOSTFACTOR(eta(1),eta(2)); ==> -1

        grasskernel:=
          {eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
          (~x)*(~x) => 0 when grassp x};

        exp:=eta(1)^2$

        exp where grasskernel; ==> 0

        aa where grasskernel; ==>  - 2*ETA(2)*ETA(1)

\end{verbatim}
\section{Handling of Matrices}
This module provides functions for handling matrices more comfortably.
\bi
\item[i.]
Often, one needs to construct some {\tt UNIT} matrix of
a given dimension. This construction is done by the system thanks
@@to the function \f{UNITMAT}. It is a nary function. The command is
\begin{verbatim}

        UNITMAT M1(n1), M2(n2), .....Mi(ni) ;

\end{verbatim}
where \verb+M1,...Mi+ are names of matrices and
\verb+ n1, n2, ..., ni+ are integers .

@@\f{MKIDM} is a generalization of \f{MKID}. It allows one to connect
two or several matrices. If \verb+u+ and \verb+u1+ are two matrices,
one can go from one to the other:
\begin{verbatim}

        matrix u(2,2);$  unitmat u1(2)$

        u1; ==>

                [1  0]
                [    ]
                [0  1]


        mkidm(u,1); ==>

                [1  0]
                [    ]
                [0  1]

\end{verbatim}
@@This function allows one to make loops on matrices like in the following
illustration. If \verb+U, U1, U2,.., U5+ are matrices:
\begin{verbatim}

        FOR I:=1:5 DO U:=U-MKIDM(U,I);

\end{verbatim}
can be issued.
\item[ii.]
The next functions map matrices on bag-like or list-like objects
and conversely  they generate matrices from bags or lists.

\f{COERCEMAT} transforms the matrix \verb+U+ into a list of lists.
The entry is
\begin{verbatim}

        COERCEMAT(U,id)

\end{verbatim}
where \verb+id+ is equal to \verb+list+ othewise it transforms it into
a bag of bags whose envelope is equal to \verb+id+.

\f{BAGLMAT} does the opposite job. The {\bf first} argument is the
bag-like or list-like object while the second argument is the matrix
identifier. The entry is
\begin{verbatim}

         BAGLMAT(bgl,U)

\end{verbatim}
\verb+bgl+ becomes the matrix \verb+U+ . The transformation is
{\bf not} done if \verb+U+  is {\em already} the  name of a
previously  defined matrix. This is to avoid ACCIDENTAL redefinition
of that matrix.
\item[ii.]
The functions \f{SUBMAT, MATEXTR, MATEXTC} take parts of a given matrix.

\f{SUBMAT} has three arguments. The entry is
\begin{verbatim}

         SUBMAT(U,nr,nc)

\end{verbatim}
The first is the matrix name, and the other two are the row  and column
@@numbers.  It gives the
@@submatrix obtained from \verb+U+ by deleting the row \verb+nr+ and
the column \verb+nc+.
When one of them is equal to zero only column \verb+nc+
or row \verb+nr+ is deleted.

\f{MATEXTR} and \f{MATEXTC} extract a row or a column and place it into
a list-like or bag-like object.
@@The entries are
\begin{verbatim}

        MATEXTR(U,VN,nr)

        MATEXTC(U,VN,nc)

\end{verbatim}
where \verb+U+ is the matrix,  \verb+VN+ is the ``vector name'',
\verb+nr+  and \verb+nc+ are integers.  If \verb+VN+  is equal
to {\tt list} the vector  is given  as a list otherwise  it is
given as a bag.
\item[iii.]
Functions which manipulate matrices. They are
\f{MATSUBR, MATSUBC, HCONCMAT, VCONCMAT, TPMAT, HERMAT}

\f{MATSUBR MATSUBC} substitute rows and columns. They have three arguments.
Entries are:
\begin{verbatim}

        MATSUBR(U,bgl,nr)

        MATSUBC(U,bgl,nc)

\end{verbatim}
The meaning of the variables \verb+U, nr, nc+ is the same as above
while \verb+bgl+ is a list-like or bag-like vector.
Its  length should be compatible with the dimensions of the matrix.

\f{HCONCMAT VCONCMAT} concatenate two matrices. The entries are
\begin{verbatim}

        HCONCMAT(U,V)

        VCONCMAT(U,V)

\end{verbatim}
The  first   function  concatenates  horizontally,   the   second  one
concatenates vertically. The dimensions must match.

\f{TPMAT} makes the tensor product of two matrices. It is also an
{\em infix} function. The entry is
\begin{verbatim}

        TPMAT(U,V) or U TPMAT V

\end{verbatim}
\f{HERMAT} takes the hermitian conjuguate of a matrix
The entry is
\begin{verbatim}

         HERMAT(U,HU)

\end{verbatim}
where \verb+HU+ is the identifier for the hermitian matrix of \verb+U+.
@@It should be {\bf unassigned} for this function to work  successfully.
This is done on  purpose to prevent accidental redefinition of an already
used identifier .
\item[iv.]
\f{SETELMAT GETELMAT} are functions of two integers. The first one
@@resets the element \verb+(i,j)+ while the second one extracts an
element identified by \verb+(i,j)+. They may be useful when
dealing with matrices {\em inside procedures}.
\ei
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/cantens.tex0000644000175000017500000022742111526203062024177 0ustar  giovannigiovanni%% ----------------------------CANTENS.TEX---------------------------------
%
% This is a LaTeX 2.09 file.
% To process it do: 
% latex cantens
% latex cantens
% latex cantens
% makeindex cantens
% latex cantens
%%
\documentstyle[reduce, art11,makeidx]{article}    % Specifies the document style.
\setlength{\parindent}{.5cm}   % Fixes the indentation of the \par command.
\setlength{\parskip}{2mm}      % Fixes the skip of the \par command.
\renewcommand {\textwidth}{12cm}  %  Changes the width of the text.
\renewcommand {\textheight}{18cm}  % Changes the height of the text.
%\renewcommand{\arraystretch}{1}
\baselineskip 10pt
%\footnotesep1cm
%\hoffset -0.9cm
\voffset -1.0cm
\headsep10mm
\newcommand{\nl}{\hfill\newline}  % Convenient to write arbitrary 
				  % stretched lines.
			   % May be put after the begin document. 
\newcommand{\none}{\nonumber \\}
\newcommand{\be}{\begin{equation}}
\newcommand{\ee}{\end{equation}}
\newcommand{\bea}{\begin{eqnarray}}
\newcommand{\eea}{\end{eqnarray}}
\newcommand{\bver}{\begin{verbatim}}
\newcommand{\ever}{\end{verbatim}}
\newcommand{\beas}{\begin{eqnarray*}}
\newcommand{\eeas}{\end{eqnarray*}}
\newcommand{\qd}{\dot q}
\newcommand{\pp}{\dot p}
\newcommand{\ghp}{{\cal P}}
\newcommand{\bq}{\begin{quotation}}
\newcommand{\eq}{\end{quotation}}
\newcommand{\bi}{\begin{itemize}}
\newcommand{\ei}{\end{itemize}}
%\newcommand{\tit}[1]{{\bf\underline{#1}}~:\hfill\\[5pt]} 
\newcommand{\tit}[1]{{\bf #1} \hfill\\[10pt]}
%\newcommand{\f}[1] {{\tt #1}}
\newcommand{\underidx}[2]%
{\renewcommand{\arraystretch}{.5}
\begin{array}[t]{c}
#1 \\
{\scriptstyle #2}
\end{array}
\renewcommand{\arraystretch}{1}}
\newcounter{letter}
\def\theequation{\thesubsection\ \arabic{equation}}
\setcounter{equation}{0}
\newcommand{\eqletter}{\hfill (\theequation\alph{letter}) }
\newcommand{\eql}{\nonumber &\eqletter \cr
           \addtocounter{letter}{1}}
\newcommand{\beal}{\setcounter{letter}{1} \begin{eqnarray}}
\newcommand{\eeal}{\addtocounter{equation}{1}
\end{eqnarray}}
\renewcommand{\ttindex}[1]{{\renewcommand{\_}{\protect\underscore}%
                          \index{#1@{\tt #1}}}}
\tolerance=1000
\makeindex
\begin{document}
\thispagestyle{empty}
\title{{\tt CANTENS}\\
A Package for Manipulations \\
and Simplifications of Indexed Objects}
\date{}
\author{H. Caprasse\\
        Institut de Physique \\
        Sart-Tilman, B-4000 LIEGE\\
        email: {\tt  hubert.caprasse@ulg.ac.be}
}
\maketitle
\section{Introduction}
{\tt CANTENS} \ttindex{CANTENS} is a package that creates an environment
inside {\tt REDUCE}\ttindex{REDUCE} 
which  allows the user to 
manipulate and simplify expressions containing various indexed objects 
like tensors, spinors, fields and quantum fields.  
Briefly said, it allows him 
\begin{itemize}
\item[-] to define generic indexed quantities which can eventually depend 
implicitly or explicitly on any number of variables;
\item[-] to define one or several affine or metric (sub-)spaces, and to work
within them without difficulty;
\item[-] to handle dummy indices and simplify adequatly expressions
which contain them.
\end{itemize}
Beside the above features, it offers the user:
\begin{enumerate}
\item  Several invariant 
elementary tensors  which are always used in the applications involving 
the use of indexed objects like {\tt delta, epsilon, eta} and the 
generalized delta function.   
\item The possibility to define any metric and to make it bloc-diagonal 
if he wishes to.
\item The capability to symmetrize or antisymmetrize any expression.
\item The possibility to introduce any kind of symmetry (even partial symmetries)
for the indexed objects.
\item The choice to work with commutative, non-commutative or anticommutative
indexed objects. 
\end{enumerate}
In this package, one cannot find  algorithms or even specific objects 
(i.e. like the covariant derivative or the SU(3) group structure constants) 
which are of
used either in nuclear and particle physics. 
The objective of the package is simply to allow 
the user to easily formulate {\em his algorithms} in the {\em notations he likes
most}.
%\newpage
The package is also conceived so as to minimize the number of new commands.
However, the large number of new capabilities inherently implies that quite 
a substantial number of new functions and commands must be used. On the other 
hand, in order to avoid too many error  or warning messages the package 
assumes, in many cases, that the user is reponsible of the consistency of its 
inputs. 
The author is aware that the package is still perfectible and 
he will be grateful to all people who shall spare some time to communicate
bugs or suggest improvements.

The documentation below is separated into four sections.
In the first one, the space(s) properties and definitions are described.

In the second one, the commands to geberate and  handle  
generic indexed quantities (called abusively tensors) are illustrated. 
The manipulation and control of free and dummy indices is discussed.

In the third one,  the special tensors are introduced and their properties
discussed especially with respect to their ability to work simultaneously within 
several subspaces.

The last section, which is also the most important,  is devoted entirely to 
the simplification function \index{CANONICAL} CANONICAL. This function 
originates from the package {\tt DUMMY} \ttindex{ DUMMY} and has been 
substantially extended . It takes account of 
all symmetries, make dummy summations and  seeks a ``canonical''
form for any tensorial expression.   Without it, the present 
package would be much less useful.

Finally, an {\bf index} has been created. It contains numerous references
to the text. Different typings have been adopted to make a clear 
distinction between them. The conventions are the following:
\begin{itemize}
\item Procedure keywords are typed in capital  roman letters.
\item Package keywords are typed in typewriter capital letters.
\item Cantens package keywords are  in small typewriter letters.
\item All other keywords are typed in small roman letters.
\end{itemize} 
When {\tt CANTENS} \ttindex{CANTENS} is loaded, the packages
{\tt ASSIST} \ttindex{ASSIST} and {\tt DUMMY}\ttindex{DUMMY} are also 
loaded. 
\section{Handling of space(s)}
\index{space}
One can work either in a {\em single} space environment or in
a multiple space environment. After the package is loaded, 
the single space environment is set and 
a unique space is defined. It is euclidian, and has a symbolic 
dimension equal to {\tt dim}.
The single space environment is determined by the switch
ONESPACE\index{ONESPACE} which is turned on. 
One can verify the above assertions as follows \index{WHOLESPACE\_DIM}:
\begin{verbatim}
      onespace ?; => yes
      
      wholespace_dim ?; => dim

      signature ?; => 0
\end{verbatim}
One can introduce a pseudoeuclidian metric for the above space by the 
command SIGNATURE \index{signature} and verify that the signature is indeed~1:
\begin{verbatim}
      signature 1;

      signature ?; => 1
\end{verbatim}
In principle the signature may be set to any positive 
integer. However, presently,
the package cannot handle signatures larger than 1.
One gets the Minkowski-like space metric\index{Minkowski} 
$$
\left(\begin{array}{cccc}    
	1 & 0 & 0 & 0  \\
	0 & -1 & 0 & 0  \\
        0 & 0 & -1 & 0 \\
        0 & 0 & 0 & -1       
 \end{array}
\right)
$$
which corresponds to the convention of high energy physicists.
It is possible to change it into the  astrophysicists convention using 
the command GLOBAL\_SIGN \index{GLOBAL\_SIGN}: 
\begin{verbatim}
      global_sign ?; => 1
      
      global_sign (-1);
 
      global_sign ?; => -1
\end{verbatim}
This means that the actual metric is now  $(-1,1,1,1)$.
The space dimension may, of course, be assigned at will using the function 
\index{WHOLESPACE\_DIM} WHOLESPACE\_DIM. Below, it is assigned to 4: 
\begin{verbatim}
      wholespace_dim 4; ==> 4
\end{verbatim}
When the switch \index{ONESPACE}ONESPACE is turned off, the system {\em assumes} that this default
space is non-existent and, therefore, that the user is going to define the 
space(s) in which he wants to work.
Unexpected error messages will occur if it is not done.
Once the switch is turned off many more functions become active. A few of them are 
available in the algebraic mode to allow the user to properly conctruct 
and control the properties of the various (sub-)spaces he is going to define
and, also, to assign symbolic indices to some of them.

\index{DEFINE\_SPACES}DEFINE\_SPACES is the space constructor and 
\ttindex{wholespace}{\bf wholespace}
is a reserved identifier which is meant to be the name of the global space 
if subspaces are introduced.   
Suppose we want to define a unique space, we can choose for its any name but 
choosing {\bf wholespace} will be more efficient. On the other hand, it leaves 
open the possibility to introduce subspaces in a more transparent way.
So one writes, for instance,:
\ttindex{signature}\ttindex{indexrange}
\begin{verbatim}
      define_spaces wholespace=
        
             {6,signature=1,indexrange=0 .. 5}; ==>t
\end{verbatim} 
The arguments inside the list, assign respectively the dimension, the signature
and the range of the numeric indices which is allowed. 
Notice that the range starts from 0 and not from 1. This is made to conform with 
the usual convention for spaces of signature equal to 1. However, this is not 
compulsory.
Notice that the declaration of the indexrange may be omitted if this is the 
only  defined space.  
There are two other options which may replace the signature option. 
They are \ttindex{euclidian}{\bf euclidian} and \ttindex{affine}{\bf affine} they 
have both an obvious significance. 

In the subsequent example, an eleven dimension global space is defined 
and two subspaces of this space are specified.
Notice that no indexrange has been declared for the entire space. 
However, the indexrange declaration is compulsory for subspaces otherwise
the package will improperly work when dealing with numeric indices.
\begin{verbatim}
      define_spaces wholespace={11,signature=1}; ==> t

      define_spaces mink=

               {4,signature=1,indexrange=0 .. 3}; ==> t
  
      define_spaces eucl=

               {6,euclidian,indexrange=4 .. 9}; ==> t      
\end{verbatim}
To remind ones the space context in which one is working, the use of the 
function \index{SHOW\_SPACES}SHOW\_SPACES is required. Its output is an 
{\em algebraic value} from which the user can retrieve all the informations
displayed. After the declarations above, this function gives:
\begin{verbatim}
      show_spaces(); ==> 

               {{wholespace,11,signature=1}

                {mink,4,signature=1,indexrange=0..3},

                {eucl,6,euclidian,indexrange=4..9}}
  
\end{verbatim}
If an input error is made  or if one wants to change the space framework, one 
cannot directly redefine the relevant space(s). For instance, the input
\begin{verbatim}
      define_spaces eucl=

                {7,euclidian,indexrange=4 .. 9}; ==> 

          *** Warning: eucl cannot be (or is already)
                       defined as space identifier
             t  
\end{verbatim}
whih aims to fill all dimensions present in {\tt wholespace}
tells that the space {\tt eucl} cannot be redefined. To redefine it effectively, 
one is  to {\em remove} the existing definition first using the function 
\index{REM\_SPACES} REM\_SPACES\ which takes any number of space-names as 
its argument. Here is the illustration:
%\end{document}
\begin{verbatim}
      rem_spaces eucl; ==> t

      show_spaces(); ==>

                 {{wholespace,11,signature=1},

                   {mink,4,signature=1,indexrange=0..3}}

      define_spaces eucl=

                 {7,euclidian,indexrange=4 .. 10}; ==> t

      show_spaces(); ==> 

                  {{wholespace,11,signature=1},

                    {mink,4,signature=1,indexrange=0..3},

                    {eucl,7,euclidian,indexrange=4..10}}
\end{verbatim} 
Here, the user is entirely responsible of the coherence of his construction.
The system does NOT verify it but will incorrectly run if there is a mistake 
at this level. 

When two spaces are direct product of each other (as the color and Minkowski
spaces in quantum chromodynamics), it is not necessary to introduce the 
global space {\tt wholespace}\ttindex{wholespace}. 

``Tensors'' and symbolic indices can be declared to belong to a specific space
or subspace. It is in fact an essential ingredient of the package and make it 
able to handle expressions which involve quantities belonging to several 
(sub-)spaces or to handle bloc-diagonal ``tensors''. This will be discussed in the next section.
Here, we just mention how to declare that some set of symbolic indices belong
to a specific (sub-)space\index{subspaces} or how to declare them to belong 
to any space\index{spaces}.
The relevant command is \index{MK\_IDS\_BELONG\_SPACE} MK\_IDS\_BELONG\_SPACE
whose syntax is 
\begin{verbatim}
      mk_ids_belong_space(,
                          )
\end{verbatim}
For example, within the above declared spaces one could write:
\begin{verbatim}
      mk_ids_belong_space({a0,a1,a2,a3},mink); ==> t

      mk_ids_belong_space({x,y,z,u,v},eucl); ==> t 
\end{verbatim}   
The command \index{MK\_IDS\_BELONG\_ANYSPACE} MK\_IDS\_BELONG\_ANYSPACE 
allows to remake them usable  either in {\tt wholespace}\ttindex{wholespace}
if it is defined or in anyone among the defined spaces.
For instance, the declaration:
\begin{verbatim}
 mk_ids_belong_anyspace a1,a2; ==> t
\end{verbatim}
tells that a1 and a2 belong either to {\tt mink} or to {\tt eucl} or 
to {\tt wholespace}.
\section{Generic tensors and their manipulation}
\index{generic tensor}
\subsection{Definition}
The generic tensors  handled by {\tt CANTENS}\ttindex{CANTENS} are objects 
much more general than usual tensors. The reason is that they are not supposed to 
obey well defined transformation properties under a change of coordinates.
They are only indexed quantities. The indices are either 
contravariantly (upper indices) or covariantly (lower indices) placed. 
They can be symbolic or numeric. When a given index is found both 
in one upper and in one lower place, it is supposed to be summed over 
all space-coordinates it belongs to viz. it is a {\em dummy}\index{dummy}
index 
and {\em automatically recognized} as such.  
So they are supposed to obey the summation rules of tensor calculus.
This why and only why they are called tensors. Moreover, aside from 
indices they may also depend implicitly or explicitly on any number of
{\em  variables}\index{variables}. Within this definition,
tensors may also be spinors, they can be non-commutative or anticommutative,
they may also be algebra generators and represent fields or quantum fields.   
\subsection{Implications of \index{TENSOR}TENSOR\ declaration}
The procedure TENSOR which takes an arbitrary number of identifiers as argument
defines them as operator-like objects which admit an arbitrary number of indices.
Each component has a formal character and may or may not belong to a 
specific (sub-)space. Numeric indices are also allowed. The way to distinguish 
upper and lower indices is the same as the one in the package
\ttindex{EXCALC}{\tt EXCALC} e.g. $-a$ is a lower index and $a$ is an 
upper index.
A special printing function has been created so as to mimic as much as possible
the way of writing such objects on a sheet of paper.
Let us illustrate the use of \index{TENSOR} TENSOR:
\begin{verbatim}
   tensor te; ==> t

   te(3,a,-4,b,-c,7); ==> 
                            3 a   b   7
                        te
                                4   c



  te(3,a,{x,y},-4,b,-c,7); ==>

             3 a   b   7
          te            (x,y)
                 4   c



   te(3,a,-4,b,{u,v},-c,7); ==>

             3 a   b   7
          te            (u,v)
                 4   c


   te({x,y}); ==>  te(x,y)
\end{verbatim} 
Notice that the system distinguishes indices from variables on input 
solely on the basis that the user puts variables {\em inside a list}.

The dependence can also be declared implicit through the \REDUCE\ command 
\index{DEPEND}DEPEND  which is generalized so as to allow to declare a tensor 
to depend on another tensor irrespective of its components. It means that only {\em one}
declaration is enough to express the dependence with respect to 
{\em all its components}.
A simple example:
\index{DF}
\begin{verbatim}
      tensor te,x;

      depend te,x;

      df(te(a,-b),x(c)); ==>

                  a    c
             df(te   ,x )
                    b
\end{verbatim}
Therefore, when {\em all} objects are tensors, the dependence declaration 
is valid for all indices. 

One can also avoid the trouble to place the explicit variables inside a list if
one declare them as variables through the command \index{MAKE\_VARIABLES}
MAKE\_VARIABLES.
This property can also be removed%
\footnote{One important feature of this package is its {\em reversibility}
viz. it gives the user the means to erase its previous operations 
at any time. So, most functions described below do
possess ``removing'' action companions.} using 
\index{REMOVE\_VARIABLES}REMOVE\_VARIABLES:
\begin{verbatim}
      make_variables x,y; ==> t

      te(x,y); ==> te(x,y)


      te(x,y,a); ==> 

                a
             te  (x,y)


      remove_variables x; ==> t


      te(x,y,a); ==>

                x a
             te    (y)
\end{verbatim}
If one does that one must be careful not to substitute a number to such 
declared variables because this number would be considered as an index and 
no longer as a variable. So it is only useful for {\em formal} variables%
\index{variables}.

A tensor can be easily eliminated using the function 
\index{REM\_TENSOR}REM\_TENSOR. It has the syntax
\begin{verbatim}
      rem_tensor t1,t2,t3 ....;
\end{verbatim}
\subsubsection{Dummy \index{dummy} indices recognition}  
\index{dummy}
For all individual tensors met by the evaluator, the system will analyse 
the written indices and will detect those which must be considered dummy 
according to the usual rules of tensor calculus. Those indices will be given
the {\tt dummy} property and will no longer be allowed to play the role 
of {\em free} indices unless the user removes this dummy property. 
In that way, the system checks immediately the consistency of an input. 
Three functions are at the disposal of the user to control dummy indices.
They are \index{DUMMY\_INDICES}DUMMY\_INDICES, \index{REM\_DUMMY\_INDICES}
REM\_DUMMY\_INDICES and \index{REM\_DUMMY\_IDS}REM\_DUMMY\_IDS. 
The following illustrates their use as well as the behaviour of the 
system: 
\begin{verbatim}
      dummy_indices(); ==> {} % In a fresh environment

      te(a,b,-c,-a); ==>

               a b
             te
                   c a

      dummy_indices(); ==> {a}

      te(a,b,-c,a); ==>
              
      ***** ((c)(a b a)) are inconsistent lists of indices

               % a cannot be found twice as an upper index

      te(a,b,-b,-a); ==>

               a b
            te
                   b a

      dummy_indices(); ==> {b,a}

      te(d,-d,d); ==>
 
        ***** ((d)(d d)) are inconsistent lists of indices

      dummy_indices(); ==> {d,b,a}

      rem_dummy_ids d; ==> t

     dummy_indices(); ==> {b,a}

      te(d,d); ==>   
 
               d d
            te              %  This is allowed again.

     dummy_indices(); ==> {b,a}

      rem_dummy_indices(); ==> t

      dummy_indices(); ==> {}
\end{verbatim}
Other verifications of coherence are made when space specifications 
are introduced both in the ON and OFF onespace environment. We shall 
discuss them later\ttindex{onespace OFF}\ttindex{onespace ON}.
\subsubsection{Substitutions, assignements and rewriting rules}
\index{LET}\index{rewriting rules}
The user must be able to manipulate and give specific characteristics 
to the generic tensors he has introduced.  Since tensors are essentially 
\REDUCE\  operators\ttindex{REDUCE}, the usual commands of the system are 
available.
However, some limitations are implied by the fact that indices and,
especially numeric indices, must always be properly recognized before
any substitution or manipulation is done. We have gathered below a set of 
examples which illustrate all the ``delicate'' points.
First, the substitutions\index{SUB}:
\begin{verbatim}
      sub(a=-c,te(a,b)); ==>

                 b
             te
               c

      sub(a=-1,te(a,b)); ==>

                 b
             te
               1

      sub(a=-0,te(a,b)); ==> 
  
               0 b
             te    % sub has replaced -0 by 0. wrong! 

      sub(a=-!0,te(a,b)); ==>

                 b
             te    % right  
               0     

\end{verbatim}
The substitution of an index  by -0 is the {\em only one} case where 
there is a problem. The function SUB replaces -0 by 0 because it does 
not  recognize 0 as an index of course. Such a recognition is 
context dependent and implies a modification of SUB
for this {\em single} exceptional case. Therefore,we have opted, not do do so 
and to use the index 0 which is simply !0 instead of 0. 

Second, the assignements. Here, we advise the user to rely on  the 
operator\ttindex{ASSIST}\index{==}$==$%
\footnote{See the {\tt ASSIST} documentation for its description.} 
instead of the operator \index{:=}$:=$. Again, 
the reason is to avoid the problem raised above  in the case of 
substitutions. $:=$ does not evaluate its lefthandside so that -0 is 
not recognized as an index and simplified to 0 while the $==$ evaluates both 
its lefthandside and its righthandside and do recognize it.
The disadvantage of $==$ is that it  demands that a second assignement 
on a given component 
 be made only after having suppressed {\em explicitly} the first assignement.
This is done by the function \index{REM\_VALUE\_TENS}REM\_VALUE\_TENS 
which can be applied on any component. We stress, however, that if one 
is willing to use -!0 instead of -0 as the lower 0 index, the use of $:=$
is perfectly legitimate:
\begin{verbatim}
      te({x,y},a,-0)==x*y*te(a,-0); ==>

               a
             te   *x*y
                 0

      te({x,y},a,-0); ==>

               a
             te   *x*y
                 0

      te({x,y},a,0); ==>

  
                a 0
             te    (x,y)


      te({x,y},a,-0)==x*y*te(a,-0); ==>

                   a
          ***** te    *x*y invalid as setvalue kernel
                     0

      rem_value_tens te({x,y},a,-0);

      te({x,y},a,-0); ==>

                a
             te    (x,y)
                  0

      te({x,y},a,-0)==(x+y)*te(a,-0); ==>

            a
          te   *(x + y)
              0
\end{verbatim}
In the elementary application below, the use of a tensor avoids the 
introduction of two different operators and  makes the 
calculation  more readable.  
\begin{verbatim}
      te(1)==sin th * cos phi; ==> cos(phi)*sin(th)

      te(-1)==sin th * cos phi; ==> cos(phi)*sin(th)

      te(2)==sin th * sin phi; ==> sin(phi)*sin(th)

      te(-2)==sin th * sin phi; ==> sin(phi)*sin(th)

      te(3)==cos th ; ==> cos(th)

      te(-3)==cos th ; ==> cos(th)

      for i:=1:3 sum te(i)*te(-i); ==>

           2        2          2           2        2
   cos(phi) *sin(th)  + cos(th)  + sin(phi) *sin(th)

      rem_value_tens te; 

      te(2); ==> 

               2
            te 
\end{verbatim}
There is no difference in the manipulation of numeric indices and numeric 
{\em tensor} indices. The function \index{REM\_VALUE\_TENS}REM\_VALUE\_TENS
when applied to a tensor prefix suppresses the value of 
{\em all its components}. Finally, there is no ``interference'' with 
i as a dummy index and i as a numeric index in a loop.       

Third, rewriting rules. They are either global or local and 
can be used as in \REDUCE\ttindex{REDUCE}. 
Again, here,  the -0 index problem exists each time a substitution 
by the index -0 must be made in a template. 
\index{FOR ALL ... LET}
\begin{verbatim}
  % LET:

      let te({x,y},-0)=x*y;

      te({x,y},-0); ==> x*y

      te({x,y},+0); ==> 

                0
             te  (x,y)


      te({x,u},-0); ==>

             te  (x,u)
                0

  % FOR ALL .. LET:

      for all x,a let te({x},a,-b)=x*te(a,-b);

      te({u},1,-b); ==>

               1
             te   *u
                 b

      te({u},c,-b); ==>

               c
             te   *u
                 b

      te({u},b,-b); ==>

               b
             te   *u
                 b

      te({u},a,-a); ==>

                a
             te    (u)
                  a

      for all x,a clear te({x},a,-b);

      te({u},c,-b); ==>

                c
             te    (u)
                  b

      for all a,b let te({x},a,-b)=x*te(a,-b);

      te({x},c,-b); ==>

               c
             te   *x
                 b

      te({x},a,-a); ==>

               a
             te   *x
                 a

   % The index -0 problem:

      te({x},a,-0); ==> % -0 becomes +0 in the template

                a
             te    (x)  %  the rule does not apply. 
                  0

      te({x},0,-!0); ==>

               0
             te   *x      % here it applies.  
                 0
\end{verbatim}
\begin{verbatim}
  % WHERE:
      
      rul:={te(~a) => sin a}; ==>

                        a
             rul := {te  => sin(a)}
                    


      te(1) where rul; ==> sin(1)

      te(1); ==>

                 1
               te
\end{verbatim}
\index{variables}
\begin{verbatim}
  % with variables:

      rul1:={te(~a,{~x,~y}) => x*y*sin(a)}; ==>

    
                        ~a
             rul1 := {te   (~x,~y) => x*y*sin(a)}


      te(a,{x,y}) where rul1; ==> sin(a)*x*y



      te({x,y},a) where rul1; ==> sin(a)*x*y

 
      rul2:={te(-~a,{~x,~y}) => x*y*sin(-a)};


            rul2 := {te   (~x,~y) => x*y*sin(-a)}
                       ~a

      te(-a,{x,y}) where rul2; ==> -sin(a)*x*y

      
      te({x,y},-a) where rul2; ==> -sin(a)*x*y
\end{verbatim}
Notice that the position of the list of variables inside the rule 
may be chosen at will. It is an irrelevant feature of the template.
This may be confusing, so, we advise to write the rules not as 
above but placing the list of variables {\em in front of all indices}
since it is in that canonical form which it is written by the simplification
function of individual tensors. 
\subsection{Behaviour under space specifications}
\index{spaces}
The characteristics and the behaviour of generic tensors described up to now
are independent of all space specifications. They are complete as long as 
we confine to the default space which is active when starting {\tt CANTENS}.
However, as soon as some space specification is introduced, it has some
consequences one the generic tensor properties. This is true both when 
\index{ONESPACE}ONESPACE is switched ON or OFF. Here we shall describe 
how to deal with these features.  

When onespace is ON, if the space dimension is set to an integer, numeric 
indices of any generic tensors are forced to be less or equal that integer 
if the signature is 0 or less than that integer if the signature is equal to 1. 	  
The following illustrates what happens.
\ttindex{onespace ON}
\begin{verbatim}
      on onespace;
  
      wholespace_dim 4; ==> 4

      signature 0; ==> 0

      te(3,a,-b,7); ==> ***** numeric indices out of range

      te(3,a,-b,3); ==>


               3 a   3
             te
                   b

   

      te(4,a,-b,4); ==>


               4 a   4
             te
                   b

      sub(a=5,te(3,a,-b,3));

                   ==> ***** numeric indices out of range

      signature 1; ==> 1

  % Now indices range from 0 to 3:     

      te(4,a,-b,4);

                    ==> ***** numeric indices out of range

      te(0,a,-b,3); ==>

   
                0 a   3
              te
                    b
\end{verbatim}
When onespace is OFF\ttindex{onespace OFF}, many more possibilities to control the input or to 
give specific properties to tensors are open. 
For instance, it is possible to declare that a tensor belongs 
to one of them. It is also possible to declare that some indices 
belongs to one of them.  It is even possible to do that 
for {\em numeric} indices thanks to the declaration
\ttindex{indexrange}indexrange
included optionally in the space definition generated by 
\index{DEFINE\_SPACES}DEFINE\_SPACES. 
First, when onespace is OFF, the run equivalent to the previous one is
like the following:
\index{DEFINE\_SPACES}\index{SHOW\_SPACES}\index{MAKE\_TENSOR\_BELONG\_SPACE}
\index{REM\_SPACES}
\begin{verbatim}
      off onespace;

      define_spaces wholespace={6,signature=1); ==> t

      show_spaces(); ==> {{wholespace,6,signature=1}}

      make_tensor_belong_space(te,wholespace);

                                        ==> wholespace

      te(4,a,-b,6); ==>

                     ***** numeric indices out of range

      te(4,a,-b,5); ==>


               4 a   5
             te
                   b

      rem_spaces wholespace;

      define_spaces wholespace={4,euclidean}; ==> t

      te(a,5,-b); ==> ***** numeric indices out of range

      te(a,4,-b); ==>


               a 4
             te
                   b

      define_spaces eucl={1,signature=0}; ==> t

      show_spaces(); ==> 

        {{wholespace,5,signature=1},
 
                {eucl,1,signature=0}}

      make_tensor_belong_space(te,eucl); ==> eucl

      te(1); ==>

               1
             te

      te(2); ==> ***** numeric indices out of range

      te(0); ==> 

               0
             te
\end{verbatim} 
In the run, the new function \index{MAKE\_TENSOR\_BELONG\_SPACE}
MAKE\_TENSOR\_BELONG\_SPACE
has been used.
One may be surprised that {\tt te(0)} is allowed in the end of 
the previous run and, indeed,
it is incorrect that the system allows {\em two} different components to
{\tt  te}.
This is due to an incomplete definition of the space. When one deals
with spaces of integer dimensions, if one wants to control numeric indices
correctly {\em when} onespace is switched off {\em one must also give the 
indexrange}\ttindex{indexrange}.
So the previous run must be corrected to
\begin{verbatim}
      define_spaces eucl=

                 {1,signature=0,indexrange=1 .. 1}; ==> t

      make_tensor_belong_space(te,eucl); ==> eucl

      te(0); ==> 

        ***** numeric indices do not belong to (sub)-space

      te(1); ==>

               1
             te

      te(2); ==>
 
        ***** numeric indices do not belong to (sub)-space

\end{verbatim} 
Notice that the error message has also changed accordingly.
So, now one can even constrain the 0 component to belong to 
an euclidian space.    

Let us go back to symbolic indices\index{symbolic indices}. 
By default, any symbolic index belongs to the global space or to all
defined partial spaces. In many cases, this is, of course, not consistent.
So, the possibility exists to declare that one or several indices 
belong to a specific (sub-)space. To this end, one is to use the 
function  \index{MK\_IDS\_BELONG\_SPACE}MK\_IDS\_BELONG\_SPACE.
Its syntax is
\begin{verbatim}
      mk_ids_belong_space(,
                                <(sub-)space identifier>)
\end{verbatim}
The function \index{MK\_IDS\_BELONG\_ANYSPACE}MK\_IDS\_BELONG\_ANYSPACE
whose syntax is the same do the reverse operation.

Combined with the declaration \index{MAKE\_TENSOR\_BELONG\_SPACE}
MAKE\_TENSOR\_BELONG\_SPACE, it allows to express all problems
which involve  tensors belonging to different spaces and do the dummy
summations correctly. 
One can also define a tensor which has a \index{bloc-diagonal}
 ``bloc-diagonal'' structure. 
All these features are illustrated in the next sections which describe specific 
tensors and the properties of the extended function \index{CANONICAL}CANONICAL.
\section{Specific tensors}
The means provided in the two previous section to handle generic tensors
already allow to construct any specific tensor we may need.  That the package contains
a certain number of them  is already justified on the level of conviviality.
However, a more important justification is that some basic tensors are so 
universaly and frequently used that a careful programming of these improves 
considerably the robustness and the efficiency of most calculations. 
The choice of the set of specific tensors is not clearcut. We have tried 
to keep their number to a minimum but, experience, may lead us extend it 
without dificulty. So, up to now, the list of specific tensors is:
\begin{list}{-}{\parsep 0in \itemsep 1pt}     
\item {\tt delta} tensor\ttindex{delta},
\item {\tt eta} Minkowski tensor\index{Minkowski}\ttindex{eta},
\item {\tt epsilon} tensor,\ttindex{epsilon}
\item {\tt del} generalised delta tensor,\ttindex{del}
\item {\tt metric} generic tensor metric.\ttindex{metric}    
\end{list}
It is important to realize that the typewriter font names in the list are 
{\em keywords} for the corresponding tensors and do not necessarily correspond 
to their {\em actual names}.  
Indeed, the choice of the names of particular tensors is left to the user.
When startting \ttindex{CANTENS}{\tt CANTENS} specific tensors are NOT 
available.
They must be activated by the user using the function 
\index{MAKE\_PARTIC\_TENS}MAKE\_PARTIC\_TENS whose syntax is:
\begin{verbatim}
      make_partic_tens( , );
\end{verbatim}
The name chosen may be the same as the keyword.
As we shall see, it is never needed to define more than one {\tt delta} 
tensor but it is often needed to define several {\tt epsilon} tensors. 
Hereunder, we describe each of the above tensors especially their 
behaviour in a multi-space environment.
\subsection{ DELTA tensor}
\ttindex{delta}
It is the simplest example of a bloc-diagonal\index{bloc-diagonal}
tensor we mentioned in the
previous section. It can also work in a space which is a direct product
of two spaces. Therefore, one never needs to introduce more than one 
such tensor. If one is working in a graphic environment, it is advantageous 
to choose the keyword as its name. Here we choose {\tt DELT}.
We illustrate how it works  when the switch \index{ONESPACE}onespace is 
successively switched ON and OFF.
\ttindex{onespace ON}
\begin{verbatim}
      on onespace;

      make_partic_tens(delt,delta); ==> t

      delt(a,b); ==> 

          ***** bad choice of indices for DELTA tensor

  % order of upper and lower indices irrelevant:    

      delt(a,-b); ==>

                 a
             delt
                 b

      delt(-b,a); ==>

                 a
             delt
                 b
     
      delt(-a,b); ==>

                 b
             delt
                 a


      wholespace_dim ?; ==> dim

      delt(1,-5); ==> 0

  % dummy summation done:   

      delt(-a,a); ==> dim


      wholespace_dim 4; ==> 4

      delt(1,-5); ==> ***** numeric indices out of range


      wholespace_dim 3; ==> 3

      delt(-a,a); ==> 3
\end{verbatim}
There is a peculiarity of this tensor, viz. it can serve to represent 
the Dirac {\em delta function}\ttindex{delta function}
 when it has no indices and an explicit variable dependency as hereunder
\begin{verbatim}
      delt({x-y}) ==> delt(x-y)
\end{verbatim}
Next we work in the context of several spaces:
\ttindex{onespace OFF}
\begin{verbatim}
      off onespace;

      define_spaces wholespace={5,signature=1}; ==> t

  % we need to assign delta to wholespace when it exists:
      
      make_tensor_belong_space(delt,wholespace);

      delt(a,-a); ==> 5

      delt(0,-0); ==>1

      rem_spaces wholespace; ==> t

      define_spaces wholespace={5,signature=0}; ==> t

      delt(a,-a); ==> 5

      delt(0,-a); ==> 

          ***** bad value of indices for DELTA tensor

\end{verbatim}
The checking of consistency of chosen indices is made in the same way as for 
generic tensor. In fact, all the previous functions which act on generic tensors
may also affect, in the same way, a specific tensor. For instance, it was 
compulsory to explicitly tell that we want {\tt DELT} to belong to the 
wholespace \index{MAKE\_TENSOR\_BELONG\_SPACE}  overwise, 
{\tt DELT} would remain defined on the {\em default space}.
In the next sample run,  we display the bloc-diagonal property of 
the \ttindex{delta} delta tensor\index{bloc-diagonal}.
\begin{verbatim}
      onespace ?; ==> no

      rem_spaces wholespace; ==> t

      define_spaces wholespace={10,signature=1}$

      define_spaces d1={5,euclidian}$
 
      define_spaces d2={2,euclidian}$


      mk_ids_belong_space({a},d1); ==> t

      mk_ids_belong_space({b},d2); ==> t

  % c belongs to wholespace so:

      delt(c,-b); ==>

                 c
             delt
                 b

      delt(c,-c); ==> 10


      delt(b,-b); ==> 2

      delt(a,-a); ==> 5

  % this is especially important:

      delt(a,-b); ==> 0
\end{verbatim}
The bloc-diagonal property of \ttindex{delta}{\tt delt} is made 
active   under two conditions. The first is that the system knows 
to which space it belongs, the second is that indices must be 
declared to belong to a specific space\index{spaces}.
To enforce the same property on a generic tensor, we have to make 
the \index{MAKE\_BLOC\_DIAGONAL}MAKE\_BLOC\_DIAGONAL declaration:
\begin{verbatim}
      make_bloc_diagonal t1,t2, ...;
\end{verbatim}
and to make it active, one proceeds as in the above run.
Starting from a fresh environment, the following sample run 
is illustrative\index{MAKE\_BLOC\_DIAGONAL}:
\begin{verbatim}
      off onespace;

      define_spaces wholespace={6,signature=1}$

      define_spaces mink={4,signature=1,indexrange=0 .. 3}$

      define_spaces eucl={3,euclidian,indexrange=4 .. 6}$

      tensor te;

      make_tensor_belong_space(te,eucl); ==> eucl


  % the key declaration:

      make_bloc_diagonal te; ==> t


  % bloc-diagonal property activation:

      mk_ids_belong_space({a,b,c},eucl); ==> t

      mk_ids_belong_space({m1,m2},mink); ==> t


      te(a,b,m1); ==> 0

      te(a,b,m2); ==> 0

   % bloc-diagonal property suppression:

      mk_ids_belong_anyspace a,b,c,m1,m2; ==> t


      te(a,b,m2); ==>

               a b m2
             te

\end{verbatim}
\subsection{ETA\ Minkowski tensor}
\ttindex{eta}\index{Minkowski}
The use of \index{MAKE\_PARTIC\_TENS}MAKE\_PARTIC\_TENS with the 
keyword {\tt eta} allows to create a Minkowski diagonal metric tensor in a 
one or multi-space context either with the convention of
 high energy physicists or in the convention of astrophysicists.
Any {\tt eta}-like tensor is assumed to work within a space 
of signature 1. Therefore, if the space whose metric, it is supposed 
to describe has a signature 0, an error message follows if one is 
working in an ON onespace \ttindex{onespace ON}\ttindex{onespace OFF} 
context and a warning when in an OFF onespace context.
Illustration:
\index{SIGNATURE}
\begin{verbatim}
      on onespace;

      make_partic_tens(et,eta); ==> t

      signature 0; ==> 0;

      et(-b,-a); ==> 

         *****  signature must be equal to 1 for ETA tensor


      off onespace;

      et(a,b); ==> 
 
          ***  ETA tensor not properly assigned to a space

  % it is then evaluated to zero:

          0

      on onespace;   

      signature 1; ==> 1

      et(-b,-a); ==> 

             et
               a b 
\end{verbatim}
Since {\tt et(a,-a)} is evaluated to the corresponding {\tt delta} tensor,
 one cannot define properly an {\tt eta}\ttindex{eta} tensor without a 
simultaneous introduction of a  {\tt delta} tensor. Otherwise one gets 
the following message:
\begin{verbatim}
      et(a,-a); ==> *****  no name found for (delta)
\end{verbatim}
So we need to issue, for instance, 
\begin{verbatim}
      make_partic_tens(delta,delta); ==> t
\end{verbatim}
The value of its diagonal elements depends on the chosen
{\index{GLOBAL\_SIGN}global sign. The next run illustrates this:
\begin{verbatim}
      global_sign ?; ==> 1

      et(0,0); ==> 1

      et(3,3); ==>  - 1

      global_sign(-1); ==> -1

      et(0,0); ==>  - 1

      et(3,3); ==> 1
\end{verbatim}
The tensor is of course symmetric \index{symmetric}.  
Its indices are checked in the same way as for a generic tensor.
In a multi\_space context\index{spaces}, the {\tt eta} tensor must belong 
to a well defined space of \index{signature}signature 1:
\ttindex{onespace OFF}
\begin{verbatim}
      off onespace;

      define_spaces wholespace={4,signature=1}$  

      make_tensor_belong_space(et,wholespace)$

      et(a,-a); ==> 4
\end{verbatim}
If the space to which {\tt et} belongs to is a subspace\index{subspaces},
one must also
take care to give a space-identity to dummy indices which may appear inside 
it. In the following run, the index {\tt a} belongs to {\tt wholespace} 
\ttindex{wholespace}if it is not told to the system that it is a dummy 
index of the space {\tt mink}:
\begin{verbatim}
      make_tensor_belong_anyspace et; ==> t

      rem_spaces wholespace; ==> t

      define_spaces wholespace={8,signature=1}; ==> t

      define_spaces mink={5,signature=1}; ==> t

      make_tensor_belong_space(et,mink); ==> mink

  % a sits in wholespace:
   
      et(a,-a); ==> 8

      mk_ids_belong_space({a},mink); ==> t

  % a sits in mink:

      et(a,-a); ==>  5    
\end{verbatim}
\subsection{EPSILON tensors}
\ttindex{epsilon}
It is an antisymmetric \index{antisymmetric} tensor which  
 is the invariant tensor for the unitary group transformations in 
n-dimensional complex space which are continuously connected to the 
identity transformation. The number of their indices are always stricty 
equal to the number of space dimensions.
 So, to each specific space is associated a specific {\tt epsilon} tensor.   
Its properties are also dependent on the signature of the space.
We describe how to define and manipulate it in the context of a
unique space and, next, in a multi-space context.
\subsubsection{ONESPACE is ON}
\ttindex{onespace ON}
The use of \index{MAKE\_PARTIC\_TENS} MAKE\_PARTIC\_TENS places it, by default, in an
euclidian space if the signature is 0 and in a Minkowski-type space if 
the signature\index{signature} is 1. 
For higher signatures it is not constructed.
For a space of symbolic dimension, the number of its indices is not 
constrained. When it appears inside an expression, its indices are {\em all}
currently upper or lower indices. However, the system allows for 
mixed positions of the indices. In that case, the output of the system 
is changed compared to the input  only to place all contravariant indices
to the left of the covariant ones.
\begin{verbatim}
      make_partic_tens(eps,epsilon); ==> t
 
      eps(a,d,b,-g,e,-f); ==>

                   a d b e
              - eps
                           g f

      eps(a,d,b,-f,e,-f); ==> 0

  % indices have all the same variance:
 
      eps(-b,-a); ==>

              - eps
                   a b


      signature ?; ==> 0

      eps(1,2,3,4); ==> 1

      eps(-1,-2,-3,-4); ==> 1

      wholespace_dim 3; ==> 3

      eps(-1,-2,-3); ==> 1

      eps(-1,-2,-3,-4); ==> 
           
             ***** numeric indices out of range

      eps(-1,-2,-3,-3); ==> 

             ***** bad number of indices for (eps) tensor

      eps(a,b); ==> 

             ***** bad number of indices for (eps) tensor

      eps(a,b,c); ==> 

                a b c
             eps

   
      eps(a,b,b); ==> 0

\end{verbatim}
When the signature\index{signature} is equal to 1, it is known that 
there exists
two {\em conventions} which are linked to the chosen value 1 or -1 of 
the $(0,1,\ldots,n)$ component. So, the sytem does evaluate all components
in terms of  the $(0,1,\ldots,n)$ upper index component. It is left to the user 
to assign it to 1 or -1\index{GLOBAL\_SIGN}.
\begin{verbatim}
      signature 1; ==> 1

      eps(0,1,2); ==> 

                0 1 2
             eps

      eps(-0,-1,-2); ==>

                0 1 2
             eps

      wholespace_dim 4; ==> 4

      eps(0,1,2,3); ==>

                0 1 2 3
             eps

      eps(-0,-1,-2,-3); ==>

                   0 1 2 3
              - eps

  % change of the global_sign convention: 
   
      global_sign(-1);

      wholespace_dim 3; ==> 3

  % compare with second input:

      eps(-0,-1,-2); ==>

                   0 1 2
              - eps

\end{verbatim}
\subsubsection{ONESPACE is OFF}
\ttindex{onespace OFF}
As already said, several epsilon tensors may be defined. They {\em must} 
be assigned to a well defined (sub-)space otherwise the simplifying 
function \index{CANONICAL}CANONICAL will not properly work.
The set of epsilon tensors defined  associated to their space-name 
may be retrieved using the function  
\index{SHOW\_EPSILONS}SHOW\_EPSILONS.
An important word of caution here. The output of this function does NOT 
show the epsilon tensor one may have defined in the ON onespace context. 
This is so because the default space has {\em NO} name.
Starting  from a fresh environment, the following run illustrates 
this point:
\begin{verbatim}
      show_epsilons(); ==> {}

      onespace ?; ==> yes

      make_partic_tens(eps,epsilon); ==> t

      show_epsilons(); ==> {}
\end{verbatim}
To make the {\tt epsilon} tensor defined in the single space environment 
visible in the multi-space environment, one needs to associate it to 
a space.
For example:
\begin{verbatim}
      off onespace;

      define_spaces wholespace={7,signature=1}; ==> t

      show_epsilons(); ==> {}   % still invisible

      make_tensor_belong_space(eps,wholespace); ==> 

                                            wholespace

      show_epsilons(); ==> {{eps,wholespace}}
\end{verbatim}
Next, let us define an {\em additional} {\tt epsilon}-type tensor: 
\begin{verbatim}
      define_spaces eucl={3,euclidian}; ==> t

      make_partic_tens(ep,epsilon); ==>

              *** Warning: ep MUST belong to a space
                t

      make_tensor_belong_space(ep,eucl); ==> eucl


      show_epsilons(); ==> {{ep,eucl},{eps,wholespace}}
  
  % We show that it is indeed working inside eucl:

      ep(-1,-2,-3); ==> 1

      ep(1,2,3); ==> 1

      ep(a,b,c,d); ==> 

            ***** bad number of indices for  (ep)  tensor

      ep(1,2,4); ==> 

            ***** numeric indices out of range  
\end{verbatim}
As previously, the discrimation between symbolic indices 
\index{symbolic indices}may be introduced 
by assigning them to one or another space\index{spaces}:
\begin{verbatim}
      rem_spaces wholespace;

      define_spaces wholespace={dim,signature=1}; ==> t

      mk_ids_belong_space({e1,e2,e3},eucl); ==> t

      mk_ids_belong_space({a,b,c},wholespace); ==> t

      ep(e1,e2,e3); ==>

               e1 e2 e3
             ep           % accepted

      ep(e1,e2,z); ==>

               e1 e2 z
             ep            % accepted because z
                           % not attached to a space.

      ep(e1,e2,a);==>

          ***** some indices are not in the space of ep


      eps(a,b,c); ==>

                a b c
             eps           % accepted because *symbolic*
                           % space dimension.
\end{verbatim}
{\tt epsilon}-like tensors can also be defined on disjoint spaces. 
The subsequent sample run starts from the environment of the previous one.
It suppresses the space {\tt wholespace}\ttindex{wholespace} as well as the 
space-assignment of the indices {\tt a,b,c}. It  defines the new space
{\tt mink}. Next, the previously defined  {\tt eps} tensor is attached 
to this space. {\tt ep} remains unchanged and {\tt e1,e2,e3} still
belong to the space {\tt eucl}.  
\index{SHOW\_SPACES}\index{SHOW\_EPSILONS}
\begin{verbatim} 
      rem_spaces wholespace; ==> t

      make_tensor_belong_anyspace eps; ==> t

      show_epsilons(); ==> {{ep,eucl}}

      show_spaces(); ==> {{eucl,3,signature=0}}

      mk_ids_belong_anyspace a,b,c; ==> t

      define_spaces mink={4,signature=1}; ==> t

      show_spaces(); ==>

             {{eucl,3,signature=0},

              {mink,4,signature=1}}

      make_tensor_belong_space(eps,mink); ==> mink

      show_epsilons(); ==> {{eps,mink},{ep,eucl}}

      eps(a,b,c,d); ==>

             a b c d
          eps

      eps(e1,b,c,d); ==>

         ***** some indices are not in the space of eps

      ep(e1,b,c,d); ==>

         ***** bad number of indices for  (ep)  tensor

      ep(e1,b,c); ==>

               b c e1
             ep


      ep(e1,e2,e3); ==> 

               e1 e2 e3
             ep 
\end{verbatim}
\subsection{{\tt DEL} generalized delta tensor}
\ttindex{del}
The generalized delta function comes from the contraction of two epsilons. 
It is totally antisymmetric. Suppose its name has been chosen to be $gd$, 
that the space to which it is 
attached has dimension n  while the name of the chosen delta tensor
is $\delta$, then 
one can define it as follows:
$$
gd^{a_1,a_2,\ldots,\a_n}_{b_1,b_2,\ldots, b_n}=
\left|\begin{array}{cccc}    
	\delta^{a_1}_{b_1}  & \delta^{a_1}_{b_2} & \ldots & \delta^{a_1}_{b_n}  \\
	\delta^{a_2}_{b_1} & \delta^{a_2}_{b_2} & \ldots & \delta^{a_2}_{b_n} \\
        \vdots & \vdots & \ddots & \vdots \\
        \delta^{a_n}_{b_1} & \delta^{a_n}_{b_1} & \ldots & \delta^{a_n}_{b_1}       
 \end{array}
\right|
$$
It is, in general uneconomical to explicitly write that determinant except 
for particular {\em numeric}  values of the indices
\index{numeric indices} or when almost all 
upper and lower indices are recognized as dummy indices.
In the sample run below, {\tt gd} is defined as the generalized delta function
in the default space. The main automatic evaluations are illustrated.
The indices which are summed over are always simplified:
\begin{verbatim}
      onespace ? ==> yes

      make_partic_tens(delta,delta); ==> t

      make_partic_tens(gd,del); ==> t

  % immediate simplifications:

      gd(1,2,-3,-4); ==> 0

      gd(1,2,-1,-2); ==> 1

      gd(1,2,-2,-1); ==> -1   % antisymmetric

      gd(a,b,-a,-b); 

             ==> dim*(dim - 1) % summed over dummy indices

      gd(a,b,c,-a,-d,-e); ==>

                    b c
                  gd    *(dim - 2)     
                    d e

      gd(a,b,c,-a,-d,-c); ==> 

                       b      2
                  delta  *(dim  - 3*dim + 2)
                       d

  % no simplification:

      gd(a,b,c,-d,-e,-f); ==>

                    a b c
                  gd
                    d e f
\end{verbatim}
One can force evaluation in terms of the determinant in all cases. 
To this end, the switch \index{EXDELT}EXDELT is provided. It is initially 
OFF. Switching it On will most often give inconveniently large outputs:
\begin{verbatim}
      on exdelt;

      gd(a,b,c,-d,-e,-f); ==>

           a       b       c         a       b       c
      delta  *delta  *delta   - delta  *delta  *delta
           d       e       f         d       f       e

              a       b       c         a       b       c
       - delta  *delta  *delta   + delta  *delta  *delta
              e       d       f         e       f       d

              a       b       c         a       b       c
       + delta  *delta  *delta   - delta  *delta  *delta
              f       d       e         f       e       d
\end{verbatim}
In a multi-space environment, it is never necessary to define several 
such tensor. The reason is that \index{CANONICAL}CANONICAL uses it 
always from the contraction of a pair of {\tt epsilon}-like tensors.
Therefore the  control of indices is already done, the space-dimension 
in which {\tt del} is working  is also well defined. 
\subsection{{\tt METRIC} tensors}
\ttindex{metric}
Very often, one has to define a specific metric. The {\tt metric}-type 
of tensors include all generic properties. The first one is their symmetry,
the second one is their equality to the {\tt delta} \ttindex{delta} tensor
when they get mixed indices, the third one is their optional bloc-diagonality.
So, a metric (generic) tensor is generated by the declaration 
\index{MAKE\_PARTIC\_TENS}
\begin{verbatim} 
      make_partic_tens(,metric);
\end{verbatim} 
By default, when one is working in a multi-space environment, it is 
defined in  {\tt wholespace}{\ttindex{wholespace}
One uses the usual means of \REDUCE\ to give it specific values.
In particular, the metric 'delta' tensor of the euclidian space
can be defined that way.
Implicit or explicit dependences on variables are allowed.
Here is an illustration in the single space environment:
\begin{verbatim}
      make_partic_tens(g,metric); ==> t

      make_partic_tens(delt,delta); ==> t

      onespace ?; ==> yes
   
      g(a,b); ==>

                 a b
                g

      g(b,a); ==>

                 a b
                g

      g(a,b,c); ==>

        ***** bad choice of indices for a METRIC tensor


      g(a,b,{x,y}); ==>

                  a b
                g    (x,y)

      g(a,-b,{x,z}); ==>

                    a
                delt
                    b
   

      let g({x,y},1,1)=1/2(x+y);


      g({x,y},1,1); ==> 

                 x + y
                -------
                   2


      rem_value_tens g({x,y},1,1); 


      g({x,y},1,1); ==>

                 1 1
               g    (x,y)
\end{verbatim}
\section{The simplification function CANONICAL}
\index{CANONICAL}
\subsection{Tensor expressions}
\index{tensor polynomial}
Up to now, we have described the behaviour of individual
tensors and how they simplify themselves whenever possible.
However, this is far from being sufficient. In general, one is
to deal with objects which involve several tensors together 
with various dummy summations between them.
We define a tensor expression as an arbitrary multivariate 
polynomial. The indeterminates of such a polynomial may be 
either an indexed object, an operator, a variable or a rational number.
A tensor-type indeterminate cannot appear to a degree larger 
than one except if it is a trace\index{trace}.
The following is a tensor expression:
\begin{verbatim}

   aa:= delt({x - y})*delt(a, - g)*delt(d, - g)*delt(g, -r)
         
         *eps( - d, - e, - f)*eps(a,b,c)*op(x,y) + 1; ==>


                                a      d      g
          aa := delt(x - y)*delt  *delt  *delt  *eps
                                g      g      r     d e f


                    a b c
                *eps     *op(x,y) + 1

\end{verbatim}
In the above expression, {\tt delt} and {\tt eps} are, respectively, the
{\tt delta}\ttindex{delta} and the {\tt epsilon}\ttindex{epsilon} tensors,
{\tt op} is an operator\index{operator}. 
and {\tt delt(x-y)} is the Dirac delta function.\ttindex{delta function}
Notice that the above expression is not coh\'erent since the first term 
has a variance while the second term is a scalar. Moreover, the 
dummy index {\tt g} appears {\em three} times in the first term.
In fact, on input, each factor  is simplified   and each 
factor is checked for coherence not more.
Therefore, if a dummy summation  appears inside one factor, it will 
be done whenever possible. Hereunder {\tt delt(a,-a)} is 
summed over: 
\index{SUB}
\begin{verbatim}
   sub(g=a,aa); ==>

                          a      d              a b c
          delt(x - y)*delt  *delt  *eps     *eps     
                          r      a     d e f

                    *op(x,y)*dim + 1
\end{verbatim}
\subsection{The use of CANONICAL}
\index{CANONICAL}CANONICAL  is an offspring of the function 
with the same name of the package {\tt DUMMY} 
\ttindex{DUMMY}. It applies to tensor expressions as defined above.   
When it acts, this functions has several features which are 
worth to realise:
\begin{enumerate}
\item It tracks the free indices in each term  and checks their
identity.  It identifies and verify the coherence 
of the various dummy index summations\index{dummy indices}.
\item Dummy indices summations are done on tensor products whenever 
possible since it recognises the particular tensors 
defined above or defined by the user.
\item It seeks a canonical form for the 
various simplified terms, makes the comparison between them.
In that way it maximises simplifications and generates a canonical form 
for the output polynomial.  
\end{enumerate}
Its capabilities  have been extended in four directions:
\begin{itemize}
\item It is able to work within {\em several} spaces\index{spaces}.
\item It manages correctly expressions where 
formal tensor {\em derivatives} are present%
\footnote{In {\tt DUMMY}\ttindex{DUMMY} it does not take them into account}. 
\item It takes into account all symmetries even if partial.
\item As its parent function, it can deal with non-commutative 
and anticommutative indexed objects\index{anticommutative}.
So, Indexed objects may be spinors\index{spinor} or quantum fields.
\end{itemize}
We describe most of these features in the rest of this 
documentation.
\subsection{Check of tensor indices}
\index{indices}
Dummy indices for individual tensors are kept in the memory of 
the system. If they are badly distributed over several tensors,
it is CANONICAL\ which gives an error message:  
\begin{verbatim}
      tensor te,tf; ==> t

      bb:=te(a,b,b)*te(-b); ==>

                         a b b
             bb := te *te
                     b


      canonical bb; ==>

      ***** ((b)(a b b)) are inconsistent lists of indices


      aa:=te(b,-c)*tf(b,-c); ==>

                     b     b
             aa := te   *tf     % b and c are free.
                       c     c

      canonical aa; ==>

               b     b
             te   *tf
                 c     c

      bb:=te(a,c,b)*te(-b)*tf(a)$


      canonical bb; ==>


               a c     b   a
             te     *te *tf
                   b

      delt(a,-a); ==> dim  % a is now a dummy index


      canonical bb; ==>

             ***** wrong use of indices (a)
\end{verbatim}
The message of canonical is clear, the first sublist contains the 
list of all lower indices, and the second one the list of all upper 
indices. The index  {\tt b} is repeated {\em three} times.
In the second example, {\tt b} and {\tt c} are considered as free
indices, so they may be repeated.
The last example shows the interference between the check on 
individual tensors and the one of canonical. The use of {\tt a}
as dummy index inside {\tt delt} does no longer allow {\tt a}  
to be used as a free index in expression {\tt bb}. 
To be usable, one must explicitly remove it as dummy index 
using REM\_DUMMY\_INDICES \index{REM\_DUMMY\_INDICES}.
Dans le quatri\`eme cas, il n'y a pas de probl\`eme puisque {\tt b} et 
{\tt c} sont tous les deux des indices {\em libres}.
CANONICAL\index{CANONICAL} checks that in a tensor polynomial 
all do possess the {\em same} variance:
\begin{verbatim}
      aa:=te(a,c)+x^2; ==>

                     a c    2
             aa := te    + x

      canonical aa; ==>

             ***** scalar added with tensor(s)

      aa:=te(a,b)+tf(a,c); ==>

                     a b     a c
             aa := te    + tf

      canonical aa; ==>

            ***** mismatch in free indices :  ((a c) (a b))
\end{verbatim}
In the message the first two lists of incompatible indices are 
explicitly indicated. So, it is not an exhaustive message and a more 
complete correction may be needed.
Of course, no message of that kind appears if the indices are inside 
ordinary operators%
\footnote{This is the case inside the {\tt DUMMY}\ttindex{DUMMY}\ package.} 
\begin{verbatim}
      dummy_names b; ==> t

      cc:=op(b)*op(a,b,b); ==> cc := op(a,b,b)*op(b)

      canonical cc; ==> op(a,b,b)*op(b)    

      clear_dummy_names; ==> t
\end{verbatim}
\subsection{Position and renaming of dummy indices}
\index{dummy indices}
For a specific tensor, contravariant dummy indices are place 
in front of covariant ones. This already leads to some useful 
simplifications. For instance:
\begin{verbatim}
      pp:=te(a,-a)+te(-a,a)+1; ==> 

                    a     a
          pp := te    + te    + 1
                  a         a

      canonical pp; ==>

              a
          2*te    + 1
                a

      pp:=te(a,-a)+te(-b,b); ==>

                    b     a
          pp := te    + te
                  b         a


      canonical pp; ==> 

              a
          2*te
                a


        pp:=te(r,a,c,d,-a,f)+te(r,-b,c,d,b,f); ==>

                    r   c d b f     r a c d   f
            pp := te            + te
                      b                     a

   canonical pp; ==>


              r a c d   f
          2*te
                      a

\end{verbatim}
In the second and third example, there is also a renaming of the 
dummy variable {\tt b} whih becomes {\tt a}. 
There is a loophole at this point. For some expressions one will 
never reach a stable expression. 
This is the case for the following very simple monom:
\begin{verbatim}
      tensor nt; ==> t

      a1:=nt(-a,d)*nt(-c,a); ==>

                 d     a
             nt   *nt
               a     c

      canonical a1; ==>

    
                     a d
             nt   *nt
               c a

      a12:=a1-canonical a1; ==> 

                        d     a           a d
             a12 := nt   *nt    - nt   *nt
                      a     c       c a


      canonical a12; ==>


                 d     a           a d
           - nt   *nt    + nt   *nt   % changes sign.
               a     c       c a

\end{verbatim}
In the above example, no canonical form can be reached. When applied twice 
on the tensor monom {\tt a1} it gives back {\tt a1}!  

No change of dummy index position is allowed if a tensor belongs
to an  {\tt AFFINE}\ttindex{affine} space.
With the tensor polynomial {\tt pp} introduced above one has:
\ttindex{onespace OFF}
\begin{verbatim}
      off onespace;

      define_spaces aff={dd,affine}; ==> t

      make_tensor_belong_space(te,aff); ==> aff

      mk_ids_belong_space({a,b},aff); ==> t

      canonical pp; ==>

               r   c d a f     r a c d   f
             te            + te
                 a                     a
\end{verbatim}
The renaming of {\tt b} has been made however. 
\subsection{Contractions and summations with particular tensors}
\index{tensor contractions}
This is a central part of the extension of CANONICAL. 
The required contractions and summations can be done in a 
multi-space environment as well in a single space environment.
\begin{center} 
The case of {\tt DELTA}\ttindex{delta}
\end{center}
Dummy indices are recognized  contracted and summed over whenever possible:
\begin{verbatim}
      aa:=delt(a,-b)*delt(b,-c)*delt(c,-a) + 1; ==>

                       a      b      c
             aa := delt  *delt  *delt   + 1
                       b      c      a

      canonical aa; ==> dim + 1

      aa:=delt(a,-b)*delt(b,-c)*delt(c,-d)*te(d,e)$

      canonical aa; ==> 

               a e
             te
\end{verbatim}
CANONICAL will not attempt to make contraction with 
dummy indices included inside ordinary operators:
\index{OPERATOR}
\begin{verbatim}
      operator op;

      aa:=delt(a,-b)*op(b,b)$


      canonical aa; ==>

                a
            delt  *op(b,b)
                b

      dummy_names b; ==> t

      canonical aa; ==>

               a
          delta  *op(b,b)
               b
\end{verbatim}
\begin{center} 
The case of {\tt ETA}\ttindex{eta}
\end{center}
First, we introduce  {\tt ETA}:
\begin{verbatim}
      make_partic_tens(eta,eta); ==> t
   
      signature 1; ==> 1 % necessary

      aa:=delta(a,-b)*eta(b,c); ==> 

                       a     b c
             aa := delt  *eta
                       b

      canonical aa; ==> 

                a c
             eta


      canonical(eta(a,b)*eta(-b,c)); ==>

                a c
             eta
 

      canonical(eta(a,b)*eta(-b,-c)); ==>

                 a
             delt
                 c

      canonical(eta(a,b)*eta(-b,-a)); ==> dim

      canonical (eta(-a,-b)*te(d,-e,f,b)); ==>

               d   f
             te
                 e   a


      aa:=eta(a,b)*eta(-b,-c)*te(-a,c)+1; ==>

                             a b     c
             aa := eta   *eta   *te    + 1
                      b c          a

      canonical aa; ==>

               a
             te    + 1
                 a

      aa:=eta(a,b)*eta(-b,-c)*delta(-a,c)+
 
          1+eta(a,b)*eta(-b,-c)*te(-a,c)$


      canonical aa; ==> 

               a
             te    + dim + 1
                 a
\end{verbatim}
Let us add a generic metric \index{metric tensor} tensor:
\begin{verbatim}
      aa:=g(a,b)*g(-b,-d); ==>

                         a b
             aa := g   *g
                    b d

      canonical aa; ==>

                 a
             delt
                 d

      aa:=g(a,b)*g(c,d)*eta(-c,-e)*eta(e,f)*te(-f,g); ==>

                             e f  a b  c d     g
             aa := eta   *eta   *g   *g   *te
                      c e                    f

      canonical aa; ==>
  
              a b   d g
             g   *te

\end{verbatim}
\begin{center} 
The case of {\tt EPSILON}\ttindex{epsilon}\ttindex{del}
\end{center}
The epsilon tensor plays an important role in many contexts. 
CANONICAL\ realises the contraction of two epsilons if and only if 
they belong to the same space. The proper use of CANONICAL\ on expressions 
which contains it requires a preliminary definition of the tensor {\tt DEL}. 
When the signature\ttindex{signature} is 0; the contraction of 
two epsilons gives a {\tt DEL}-like tensor. When the 
signature is equal to 1, it is equal to {\em minus} a {\tt DEL}-like tensor.
Here we choose 1 for the signature\index{signature} and we work in a 
single space\index{spaces}.
\ttindex{onespace ON}
We define the {\tt DEL} tensor:
\begin{verbatim}
      on onespace;

      wholespace_dim dim; ==> dim
  
      make_partic_tens(gd,del); ==> t

      signature 1; ==> 1
\end{verbatim}
We define the {\tt EPSILON} tensor and show how CANONICAl\ contracts 
expression containing {\em two}%
\footnote{No contractions are done on expressions containing 
three or more epsilons which sit in the {\em same} space.
 We are not sure whether it is useful 
to be more general than we are presently.} 
 of them:
\begin{verbatim}
      aa:=eps(a,b)*eps(-c,-d); ==>

                             a b
             aa := eps   *eps
                      c d

      canonical aa; ==>

                  a b
              - gd
                  c d


      aa:=eps(a,b)*eps(-a,-b); ==>

                             a b
             aa := eps   *eps
                      a b

      canonical aa; ==> dim*( - dim + 1)

      on exdelt;

      gd(-a,-b,a,b); ==> dim*(dim - 1)

      aa:=eps(a,b,c)*eps(-b,-d,-e)$

      canonical aa; ==>

                 a      c              a      c   
             delt  *delt  *dim - 2*delt  *delt  - 
                 d      e              d      e   

                   a      c              a       c
             - delt  *delt  *dim + 2*delt  * delt
                   e      d              e       d

\end{verbatim}
Several expressions which contain the  epsilon tensor together 
with other special tensors are given below as examples to treat 
with CANONICAL: 
\begin{verbatim}
      aa:=eps( - b, - c)*eta(a,b)*eta(a,c); ==>

                       a b    a c
             eps   *eta   *eta
                b c

      canonical aa; ==> 0

      aa:=eps(a,b,c)*te(-a)*te(-b); ==> % te is generic.

                      a b c
             aa := eps     *te *te
                              a   b

      canonical aa; ==> 0

      tensor tf,tg;

      aa:=eps(a,b,c)*te(-a)*tf(-b)*tg(-c)

          + eps(d,e,f)*te(-d)*tf(-e)*tg(-f); ==>

       canonical aa; ==>

                  a b c
             2*eps     *te *tf *tg
                          a   b   c

      aa:=eps(a,b,c)*te(-a)*tf(-c)*tg(-b)
         
          + eps(d,e,f)*te(-d)*tf(-e)*tg(-f)$

   canonical aa; ==> 0
\end{verbatim}
Since \index{CANONICAL}CANONICAL is able to work inside several 
spaces, we can introduce also several epsilons and make the relevant 
simplifications on each (sub)-spaces. This is the goal of the 
next illustration. 
\ttindex{onespace OFF}\index{SHOW\_EPSILONS}
\begin{verbatim}
      off onespace;

      define_spaces wholespace=

                        {dim,signature=1}; ==> t

      define_spaces subspace=

                         {3,signature=0}; ==> t

      show_spaces(); ==>

             {{wholespace,dim,signature=1},

              {subspace,3,signature=0}}

      make_partic_tens(eps,epsilon); ==> t 

      make_partic_tens(kap,epsilon); ==> t 

      make_tensor_belong_space(eps,wholespace);

                              ==> wholespace

      make_tensor_belong_space(kap,subspace);

                              ==> subspace

      show_epsilons(); ==> 

                   {{eps,wholespace},{kap,subspace}}

      off exdelt;

      aa:=kap(a,b,c)*kap(-d,-e,-f)*eps(i,j)*eps(-k,-l)$

      canonical aa; ==>

                  a b c    i j
              - gd      *gd    
                  d e f    k l

\end{verbatim}
If there are no index summation, as in the expression above, one can 
develop both terms into the delta tensor with EXDELT
\index{EXDELT} switched ON. 
In fact, the previous calculation is correct {\em only if there are no 
dummy index} inside the two {\tt gd}'s. 
If some of the indices are 
dummy, then  
we must 
take care of the respective spaces in which the two {\tt gd} tensors 
are considered. Since, the tensor themselves do not belong 
to a given space, the space identification can only be made through 
the indices. This is enough since the {\tt DELTA}-like tensor 
is bloc-diagonal. With {\tt aa} the result of the above illustration,
one gets, for example,: 
\index{MK\_IDS\_BELONG\_SPACE}\index{indices}
\begin{verbatim}
      mk_ids_belong_space({a,b,c,d,e,f},wholespace)$
   
      mk_ids_belong_space({i,j,k,l},subspace)$
  
      sub(d=a,e=b,k=i,aa); ==>

                   c      j         2
             2*delt  *delt  *( - dim  + 3*dim - 2)
                   f      l

      sub(k=i,l=j,aa); ==> 
                                   a b c
                            - 6*gd
                                   d e f
\end{verbatim}
\subsection{CANONICAL\ and symmetries} 
\index{symmetries}
Most of the time, indexed objects have some symmetry property.
When this property is either full symmetry or antisymmetry, there
is no difficulty to implement it using the declarations 
SYMMETRIC\ \index{SYMMETRIC} or \index{ANTISYMMETRIC}ANTISYMMETRIC
of \REDUCE. However, most often, indexed objects are neither 
fully symmetric nor fully antisymmetric: they have {\em partial} 
or {\em mixed} symmetries\index{partial symmetry}\index{mixed symmetry}.       
In the {\tt DUMMY}\ttindex{DUMMY}\ package, the declaration 
\index{SYMTREE}SYMTREE\ allows to impose such type of symmetries 
on operators. This command has been improved and extended to 
apply to tensors.
In order to illustrate it, we shall take the example of the 
wellknown Riemann \index{Rieman tensor}tensor in general relativity.
 Let us remind the reader
that this tensor has four indices. It is separately {\em antisymmetric} with 
respect to the interchange of the first two indices and with respect to the   
interchange of the last two indices. It is {\em symmetric} with respect to 
the interchange of the first two and the last two indices.
In the illustration below, we show how to express this and how 
CANONICAL\ is able to recognize mixed symmetries:  
\begin{verbatim}
      tensor r; ==> t

      symtree(r,{!+,{!-,1,2},{!-,3,4}});

      rem_dummy_indices a,b,c,d; % free indices
   
      ra:=r(b,a,c,d); ==>

                    b a c d
             ra := r

      canonical ra; ==>

                 a b c d
              - r

      ra:=r(c,d,a,b); ==>
                                    c d a b
                             ra := r

      canonical ra; ==>

              a b c d
             r


     canonical r(-c,-d,a,b); ==>

              a b
             r
                  c d

      r(-c,-c,a,b); ==>  0


      ra:=r(-c,-d,c,b); ==>

                        c b
             ra := r
                    c d

      canonical ra; ==>

                 b c
              - r
                     c d
\end{verbatim}
In the last illustration, contravariant indices are placed in front 
of covariant indices and the contravariant indices are transposed. 
The superposition of the two partial symmetries gives a minus sign.

There exists an important (though natural) restriction on the use of 
SYMTREE\ which is linked to the algorithm itself: Integer used to localize
indices must start from 1, be {\em contiguous} and monotoneously increasing. 
For instance, one is not allow to introduce
\begin{verbatim}
      symtree(r,{!*,{!+,1,3},{!*,2,4}});

      symtree(r,{!*,{!+,1,2},{!*,4,5}};

      symtree(r,{!*,{!-,1,3},{!*,2}});
\end{verbatim}
but the subsequent declarations are allowed:
\begin{verbatim}
      symtree(r,{!*,{!+,1,2},{!*,3,4}});

      symtree(r,{!*,{!+,1,2},{!*,3,4,5}});

      symtree(r,{!*,{!-,1,2},{!*,3}});
\end{verbatim}
The first declaration endows {\tt r} with a {\em partial} symmetry 
with respect to the first two indices. 

A side effect of SYMTREE\ is to restrict the number of indices of 
a generic tensor. For instance, the second declaration in the above 
illustrations makes {\tt r} depend on 5 indices as illustrated below:
\begin{verbatim}
      symtree(r,{!*,{!+,1,2},{!*,3,4,5}});

      canonical r(-b,-a,d,c); ==> 

           ***** Index `5' out of range for 

                 ((minus b) (minus a) d c) in nth

      canonical r(-b,-a,d,c,e); ==>

               d c e
          r                   % correct
           a b

      canonical r(-b,-a,d,c,e,g); ==>

               d c e
          r          % The sixth index is forgotten!
           a b
\end{verbatim}
Finally, the function REMSYM\index{REMSYM}\ applied on any tensor
identifier removes all symmetry properties.

Another related question is the frequent need to symmetrize
a tensor polynomial. 
To fulfill it, the function \index{SYMMETRIZE}SYMMETRIZE 
of the package {\tt ASSIST} \ttindex{ASSIST} has been improved and 
generalised. For any kernel\index{kernel} ( which may be either 
an operator or a tensor) that function generates  
\begin{itemize}
\item[-] the sum over the cyclic permutations of indices,
\item[-] the symetric or antisymetric sums over all permutations
of the  indices.
\end{itemize}
Moreover, if it is given a list of indices, it generates a new list
which contains sublists wich contain  the relevant permutations of 
these indices 
\begin{verbatim}
      symmetrize(te(x,y,z,{v}),te,cyclicpermlist); ==>


             x y z         y z x         z x y
          te      (v) + te      (v) + te      (v)

      symmetrize(te(x,y),te,permutations); ==>

               x y     y x
             te    + te

      symmetrize(te(x,y),te,permutations,perm_sign); ==>

               x y     y x
             te    - te

      symmetrize(te(y,x),te,permutations,perm_sign); ==>

               x y     y x
           - te    + te
\end{verbatim}
If one wants to symmetrise an expression which is not a kernel, one 
can also use SYMMETRIZE\ to obtain the desired result as the next 
example shows:
\begin{verbatim}
      ex:=te(a,-b,c)*te1(-a,-d,-e); ==>

                     a   c
             ex := te     *te1
                      b      a d e

      ll:=list(b,c,d,e)$ % the chosen relevant indices 

      lls:=symmetrize(ll,list,cyclicpermlist); ==>

         lls := {{b,c,d,e},{c,d,e,b},{d,e,b,c},{e,b,c,d}}

  % The sum over the cyclic permutations is:

   excyc:=for each i in lls sum 

                   sub(b=i.1,c=i.2,d=i.3,e=i.4,ex);  ==>


                 a   c              a   d         
      excyc := te     *te1      + te     *te1     
                   b      a d e       c      a e b


                   a   e              a   b
               + te     *te1      + te      *te1
                     d      a b c       e       a c d 
                   
\end{verbatim}
\subsection{CANONICAL and tensor derivatives}
\index{tensor derivatives}
Only ordinary (partial) derivatives are fully correctly handled 
by CANONICAL. This is enough, to explicitly construct covariant 
derivatives. We recognize here  that extensions should still be made.
The subsequent illustrations show how CANONICAL\ does indeed 
manage to find  the canonical form and simplify  expressions 
which contain derivatives. Notice, the use of 
the (modified) \index{DEPEND}DEPEND\  declaration.
\ttindex{onespace ON}
\begin{verbatim}
      on onespace;   
 
      tensor te,x; ==> t

      depend te,x;


      aa:=df(te(a,-b),x(-b))-df(te(a,-c),x(-c))$

      canonical aa; ==> 0

      make_partic_tens(eta,eta); ==>  t

      signature 1;

      aa:=df(te(a,-b),x(-b))$

      aa:=aa*eta(-a,-d);

                     a
          aa := df(te   ,x )*eta
                       b  b     a d

    canonical aa; ==>

                 a  a
          df(te   ,x )
               d

\end{verbatim}
In the last example, after contraction, the covariant dummy index {\tt b}
has been changed into the contravariant dummy index {\tt a}. This is allowed
since the space is metric. 
\newpage
\printindex
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/hcvctors.red0000644000175000017500000002037311526203062024346 0ustar  giovannigiovannimodule hcvctors;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The following set of symbolic procedures allow to manipulate
% indices of vectors in the same way as for lists. Coercion from array
% to vectors is also allowed.
% Module necessary to handle DUMMY.RED
% Only functions available in the algebraic mode are commented in
% the TeX file.

symbolic smacro procedure mkve n;
mkvect(n-1);

symbolic smacro procedure mkve!* n;
% n is an integer
% as mkvect but initialize to 0 instead of nil.
% for general tables, use mkarray1(list(i1,...),'algebraic).
mkarray1(list(n),'algebraic);

symbolic smacro procedure putve(ve,i,elt);
% To identify numerology to the one of lists.
% Use: for i:=1:upbve tri  do putve(tri,i,i); ==> [1 2 3 4]
putv(ve,i-1,elt);

symbolic smacro procedure  venth(u,i);
% To identify numerology to the one of lists.
getv(u,i-1);

symbolic smacro procedure array_to_vect u;
% For the use in the algebraic mode, it may be useful to coerce to
% ARRAYS and vice-versa
% Use: array_to_vect algebraic 
  cadr get(u,'avalue);

symbolic procedure mkrandtabl(u,base,ar);
% u is a list of 2 integers which determine the dimensions of the array
% base is integer  or decimal.
% Output is a table of random numbers
if not fixp base and not !*rounded then
                              rederr("ROUNDED should be on") else
begin scalar ve; integer lu;
 lu:=length(u:=alg_to_symb u);
 % if lu > 2 then typerr(u,"one or two integer list");
 ve:=mkarray1(u,'algebraic);
  if lu=1 then
    for i:=1:car u do
       putve(ve,i, if not fixp base then
         mk!*sq((make!:rd random(cdr base)) . 1)
                              else random(base)) else
  if lu=2 then <<
                  for i:=1:car u do putve(ve,i,mkve!* cadr u);
                  for i:=1:car u do for j:=1:cadr u do
                         putve(venth(ve,i),j, if not fixp base then
                               mk!*sq((make!:rd random(cdr base)) . 1)
                                               else random(base))>>
  else return typerr(u,"one or two integer list");
  vect_to_array(list(ve,ar),u);
  return symb_to_alg lengthreval list ar
end;

flag('(mkrandtabl),'opfn);

symbolic procedure upbve u;
% Should be used in FOR ... DO loops.
if null upbv u then 0 else upbv u +1;

% ILLUSTRATION of use of the above macros and function.
%for i:=1:upbve tri do
%        for j:=1:upbve venth(tri,i) do
%               putve(venth(tri,i),j,i*j);

symbolic procedure dimvect u;
% u is a vector or vector of vector or ..
% Gives the dimension of each level.
% Valid only for rectangular patterns.
% May also be used for Young tableaux to get the dimensions of the
% FIRST row and column.
if null u then nil else
  (upbv u + 1) . dimvect ((if not vectorp x then nil
  else x) where x=getv(u,0));

 symbolic procedure index_elt(elt,u);
 % elt is an atom or a number
 % return the position index.
 begin scalar idx; integer ii;
  ii:=1;
  repeat   <>
  until not null idx or ii=upbve u + 1;
  return idx
 end;

 symbolic procedure vect2list u;
 % Coerce a vector into a list at any level. Suitable for the
 % symbolic mode.
 for i := 0 : upbv u collect
 (if null upbv x then x
       else vect2list x) where x= getv(u,i);

symbolic procedure list_str u;
% generates the list of dimensions for the array construction.
%if not listp u  then
%          rederr "Argument to 'list_str' must be a list"
% it is supposed  to pass the test of homo_lst.
 if not listp car u  then length u  . nil
  else length u  . list_str car u;

symbolic procedure n_first_lst(u,n);
if n=0 then nil else
car u  . n_first_lst(cdr u,n-1);

symbolic procedure homo_lst(u,n);
% n indicates the level of homogeneity.
% u is the list.
% It should be filtered by depth which gives n+1 and
% generated by alg_to_symb 
if not listp u then
  rederr " Argument to 'homo_lst' has not the correct dimension"
else
  if n=0 then  1 else
   begin integer nl;
         scalar su;
   su:=u; nl:=length car su;
  % It is supposed here that car su is also a list.
   su:=cdr su ;
   if null su then 1;
   while su and nl= length car su do su:=cdr su;
   if null su then return
     for each i in u product homo_lst(i,n-1)
   else return 0
end;

symbolic procedure list_to_array(u,n,arr);
% Suitable for the algebraic mode.
% Defines n-dimensional arrays.
begin scalar lu;
lu:=alg_to_symb u;
<>;
end;

flag('(list_to_array,array_to_list),'opfn);

symbolic procedure array_to_list u;
% Transforms an array into a list.
% Suitable for the algebraic mode.
% Works at all levels.
symb_to_alg vect2list array_to_vect u;

symbolic procedure list2vectn(u,n);
if n=1 then list2vect u else
begin scalar ll,x;
 if homo_lst(u,n-1)=1 then ll:=list_str u else
 rerror(alg,1,list(n,"Too large to coerce to an array"));
 x:=mkvect (first ll -1); ll:=cdr ll;
 for i:=1: upbv x +1 do putve(x,i,list2vectn(nth(u,i),n-1));
 return x
end;

symbolic procedure list2vect u; list2vect!*(u,'algebraic);

symbolic procedure list2vect!*(u,v); % replaces list2vect
% Coerce a list into a vector
% v may be either SYMBOLIC or ALGEBRAIC
  begin scalar x;
      x:=mkvect(length u -1);
         for i:=1:upbv x +1 do putve(x,i,
            if v = 'algebraic then symb_to_alg nth(u,i) else nth(u,i));
  return x end;

symbolic procedure vect_to_array(u,dim);
% u is a list (vector, array_id)
<>;

symbolic procedure vectappend(v1,v2);
 if not vectorp v1 then typerr(v1,"vector") else
 if not vectorp v2 then vectappend1(v1,v2) else
  begin scalar new;integer dim;
    new:=mkvect(upbv v1 + upbv v2 +1 );
    dim:=upbv v1 + 1;
    for i:=1:dim do putve(new,i,venth(v1,i));
    for i:=(dim+1):(upbv new + 1) do putve(new,i,venth(v2,i-dim));
   return new
end;

symbolic procedure vectappend1(v1,v2);
   begin scalar new; integer dim;
      new:=mkvect(dim:=upbv v1 +1);
      for i:=1:dim do putve(new,i,venth(v1,i));
      putve(new,dim+1,v2);
  return new end;

symbolic procedure vectadd(v1,v2);
% v1 and v2 are supposed to be two numeric vectors.
% So we use PLUS and not SIMPPLUS.
 if not vectorp v1 or not vectorp v2 then
                                rederr("arguments must be vectors")
  else
    begin scalar vadd;
     vadd:=mkvect upbv v1;
     for i:=1:upbve v1 do putve(vadd,i, venth(v1,i)+venth(v2,i));
     return vadd
  end;

 symbolic procedure setelve(ve,l,val);
 % Sets any elements of ve, at any level to val.
 % Example of use:
 % for i:=1:upbve tri do
 %        for j:=1:upbve venth(tri,i) do
 %               setelve(tri,list(i,j),i+j);
  if null l then nil else
  if null cdr l then putve(ve,car l, val) else
  setelve(venth(ve,car l),cdr l,val);

 symbolic procedure ltrident n;
 % Constructs a lower triangular matrix of unit vectors
   begin scalar a;
    a:=mkve!* n;
    for i:=1:n do
    << putve(a,i,mkve!* i);
         for j:=1:i-1 do putve(venth(a,i), j, 0);
        putve(venth(a,i),i,1);>>;
     return a
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/dummycnt.red0000644000175000017500000013634511526203062024362 0ustar  giovannigiovannimodule dummycnt;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(g_dvnames g_dvbase g_sc_ve g_init_stree g_skip_to_level
        !*distribute);

%%%%%%%%%%%%%%%%%%%%%%% MISCELANEOUS ROUTINES %%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure ad_splitname(u);
  if idp u then
    begin scalar uu, nn;
    uu := reverse(explode u);
    while uu and (charnump!: car uu) do
      <<
      nn := car uu . nn;
      uu := cdr uu;
      >>;
    if uu then uu := intern(compress(reverse(uu)));
    if nn then nn := compress(nn);
    return (uu.nn);
    end;

symbolic procedure anticom_assoc(u,v);
  begin  scalar next_cell;
  if null v then
    return nil
  else if u = caar v then
    return (1 . car v)
  else
    <<
    next_cell := anticom_assoc(u, cdr v);
    if null next_cell then return nil;
    if oddp(length(cdar v)) then
      rplaca(next_cell, - car next_cell);
    return next_cell;
    >>;
  end;

%%%%%%%%%%%%%%%%%%%%%%% ORDERING FUNCTIONS %%%%%%%%%%%%%%%%%%%%
symbolic procedure ad_signsort(l, fn);
 begin scalar  tosort, sorted, insertl, dig;
        integer  thesign;
  tosort := copy l;
  thesign := 1;
  sorted := nil;
  while tosort do
    if null sorted then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else if car tosort = car sorted then
      <<
      thesign := 0;
      sorted := tosort := nil;
      >>
    else if apply(fn, {car sorted, car tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      thesign := - thesign;
      insertl := sorted;
      dig := t;
      while dig do
        if null cdr insertl then
          dig := nil
        else if cadr insertl = car tosort then
          <<
          insertl := {nil};
          dig := nil;
          thesign := 0;
          sorted := tosort := nil;
          >>
        else if not apply(fn, {cadr insertl, car tosort}) then
          <<
          insertl := cdr insertl;
          thesign := - thesign;
          >>
        else
          dig := nil;
      if tosort then
        <<
        rplacd(insertl, (car tosort) . cdr insertl);
        tosort := cdr tosort;
        >>;
      >>;
 return (thesign . reverse sorted);
 end;

symbolic procedure cdr_sort(lst, fn);
  begin scalar  tosort, sorted, insertl;
  tosort := lst;
  while tosort do
    <<
    if (null sorted) or apply(fn, {cdar sorted, cdar tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      insertl := sorted;
      while (cdr insertl) and
                    not(apply(fn, {cdadr insertl, cdar tosort})) do
        insertl := cdr insertl;
      rplacd(insertl, (car tosort) . cdr insertl);
      tosort := cdr tosort
      >>
    >>;
  return reverse sorted;
  end;

symbolic procedure cdr_signsort(l, fn);
  begin scalar  tosort, sorted, insertl, dig;
        integer thesign;
  tosort := copy l;
  thesign := 1;
  sorted := nil;
  while tosort do
    if null sorted then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else if cdar tosort = cdar sorted then
      <<
      thesign := 0;
      sorted := tosort := nil;
      >>
    else if apply(fn, {cdar sorted, cdar tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      thesign := - thesign;
      insertl := sorted;
      dig := t;
      while dig do
        if null cdr insertl then
          dig := nil
        else if cdadr insertl = cdar tosort then
          <<
          dig := nil;
          thesign := 0;
          sorted := tosort := nil;
          >>
        else if not apply(fn, {cdadr insertl, cdar tosort}) then
          <<
          insertl := cdr insertl;
          thesign := - thesign;
          >>
        else
          dig := nil;
      if tosort then
        <<
        rplacd(insertl, (car tosort) . cdr insertl);
        tosort := cdr tosort
        >>;
      >>;
  return (thesign . reverse sorted);
  end;

symbolic procedure num_signsort(l);
  ad_signsort(l, function(lambda(x,y); x <= y));

symbolic procedure cons_ordp(u,v, fn);
  if null u then t
  else if null v then nil
  else if pairp u then
    if pairp v then
      if car u = car v then
        cons_ordp(cdr u, cdr v, fn)
      else
        cons_ordp(car u, car v, fn)
    else
      nil
  else if pairp v then t
  else apply2(fn,u,v);

symbolic procedure atom_compare(u,v);
  if numberp u then numberp v and not(u < v)
  else if idp v then orderp(u,v)
  else numberp v;

symbolic procedure idcons_ordp(u,v);
  cons_ordp(u, v, function atom_compare);

symbolic procedure skp_ordp(u,v);
  cons_ordp(car u, car v, function atom_compare);

symbolic procedure numlist_ordp(u,v);
  cons_ordp(u,v,function(lambda(x,y); x <= y));

symbolic procedure ad_numsort(l);
  sort(l,function(lambda(x,y); x <= y));

%%%%%%%%%%%%%%%%%%%%%%% ACCESS ROUTINES %%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure sc_kern(ind);
  caddr venth(g_sc_ve, ind);

symbolic procedure sc_rep(ind);
  cadr venth(g_sc_ve, ind);

symbolic procedure sc_desc(ind);
  car venth(g_sc_ve, ind);

symbolic procedure dummyp(var);
  begin scalar varsplit;
       integer count, res;
  if not idp var then return nil;
  count := 1;
  while count <= upbve(g_dvnames) do
    <<
   if var = venth(g_dvnames, count) then
    <<
      res := count;
      count := upbve(g_dvnames) + 1
      >>
    else
      count := count + 1;
    >>;
  if res eq 0 then
    <<
    varsplit := ad_splitname(var);
    if (car varsplit eq g_dvbase) then
      return cdr varsplit
    >>
  else return res;
  end;

symbolic procedure dv_ind2var(ind);
  if ind <= upbve(g_dvnames) then
    venth(g_dvnames, ind)
  else
    mkid(g_dvbase, ind);

%%%%%%%%%%%%%%%%%%%%%% SYMMETRY CELLS %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure sc_repkern(s_cell, n);
  if car s_cell eq '!* then               % nil symmetric cell
    begin scalar  kern, rest, next_rest;
          integer head, rep;
    rest := cdr s_cell;
    rep := 0;
    while rest do
      <<
      head := car rest;
      kern := {head} . kern;
      rest := cdr rest;
      next_rest := nil;
      rep := rep*2 + 1;
      for each elt in rest do
        <<
        if elt eq head then
          rep := rep * 2 + 1
        else
          <<
          rep := rep * 2;
          next_rest := elt . next_rest
          >>
        >>;
      rest := reverse next_rest;
      >>;
    return {rep, pa_list2vect(reverse kern, n)};
    end
  else
    begin scalar  count, replist, rep, kern;
          integer last_count;
    s_cell := cdr s_cell; % s_cell supposed sorted
    for each elt in s_cell do
      if (count := assoc(elt, replist)) then
        rplacd (count, cdr count + 1)
      else
        replist := (elt . 1) . replist;
    replist := sort(replist, function(lambda(x,y); cdr x <= cdr y));
    last_count := 0;
    for each elt in replist do
      if (cdr elt neq last_count) then
        <<
        rep := (cdr elt . 1) . rep;
        kern := {car elt} . kern;
        last_count := cdr elt;
        >>
      else
        <<
        rplacd(car rep, cdar rep + 1);
        rplaca(kern, car elt . car kern)
        >>;
    return {rep , pa_list2vect(kern, n)};
    end;

%%%%%%%%%%%%%%%%%%%%% PARTITIONS COMP %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure pa_list2vect(pa, n);
  begin scalar  ve, reps;
        integer abs;
  ve := mkve(n);
  for each cell in pa do
    <<
    reps := eval('min . cell) . reps;
    for each elt in cell do putve(ve, elt, car reps);
    >>;
  for count := 1:n do
    <<
    if null venth(ve, count) then
      <<
      if abs = 0 then
        <<
        abs := count;
        reps := abs . reps
        >>;
      putve(ve, count, abs)
      >>
    >>;
  return ((reverse reps) . ve);
  end;

symbolic procedure pa_part2list(p);
  begin scalar  ve;
        integer len, rep;
  len := upbve(cdr p);
  ve := mkve(len);
  for count := len step -1 until 1 do
    <<
    rep := venth(cdr p, count);
    putve(ve, rep, count . venth(ve, rep));
    >>;
  return for each count in car p join copy
    venth(ve,count);
  end;

symbolic procedure pa_vect2list(pa);
  begin scalar  ve;
        integer count, rep;
  ve := mkve(upbve(cdr pa));
  for count := 1 : upbve(cdr pa) do
    <<
    rep := venth(cdr pa, count);
    putve(ve, rep, count . venth(ve,rep));
    >>;
  return for each rep in (car pa) collect ordn(venth(ve, rep));
  end;

symbolic procedure pa_coinc_split(p1, p2);
  begin
     scalar  ve1, ve2, cursplit, split_alist, split_info, coinc, split;
     integer count, plength;
  plength := upbve(cdr p1);
  ve1 := mkve(plength);
  ve2 := mkve(plength);
  split := mkve(plength);
  count := 0;
  for each rep in car p1 do
    <<
    count := count + 1;
    putve(ve1, rep, count)
    >>;
  count := 0;
  for each rep in car p2 do
    <<
    count := count + 1;
    putve(ve2, rep, count)
    >>;
  for count := 1 : plength do
    <<
    cursplit := (venth(ve1, venth(cdr p1, count)) .
                 venth(ve2, venth(cdr p2, count)));
    if (split_info := assoc(cursplit, split_alist)) then
      <<
      rplacd(cdr split_info, cddr split_info + 1);
      putve(split, count, cadr split_info)
      >>
    else
      <<
      split_info := cursplit . (count . 1);
      split_alist := split_info . split_alist;
      putve(split, count, count)
      >>
    >>;
  split_alist :=
     sort(split_alist,
          function(lambda x,y;
            if caar x < caar y then t
            else if caar y < caar x then nil
            else cdar x leq cdar y));
  split := (for each cell in split_alist collect cadr cell) . split;
  coinc := for each cell in split_alist collect
    (car cell) . (cddr cell);
  return coinc . split;
  end;

%%%%%%%%%%%%%%%%%%%%% SYMMETRY TREES %%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure st_flatten(stree);
  if numberp(cadr stree) then
    cdr stree
  else
    for each elt in cdr stree join copy st_flatten(elt);

symbolic procedure st_extract_symcells(stree, maxind);
  begin scalar  ve, symcells;
        integer count;
  if null stree then return (nil . mkve(0));
  symcells := st_extract_symcells1(st_consolidate(stree),nil,1);
  stree := car symcells;
  if not listp stree then % stree is a single symcell
    stree := {'!* , stree};
  symcells := cadr symcells;
  ve := mkve(length(symcells));
  count := upbve(ve);
  while symcells do
    <<
    putve(ve, count, car symcells . sc_repkern(car symcells, maxind));
    symcells := cdr symcells;
    count := count - 1
    >>;
  return(st_consolidate(stree) . ve);
  end;

symbolic procedure st_extract_symcells1(stree, symcells, count);
  begin scalar  res, new_stree;
  if not listp cadr stree then % stree is a symcell
    return { count , stree . symcells, count + 1}
  else
    <<
    new_stree := car stree .
      for each inner_stree in cdr stree collect
        <<
        res := st_extract_symcells1(inner_stree, symcells, count);
        symcells := cadr res;
        count := caddr res;
        if numberp car res then
          {'!*, car res}
        else
          car res
        >>;
    return ({ new_stree, symcells, count })
    >>;
  end;

symbolic procedure st_signchange(ve1, ve2);
  car st_signchange1(g_init_stree, vect2list ve1) *
  car st_signchange1(g_init_stree, vect2list ve2);

symbolic procedure st_signchange1(stree, eltlist);
  begin scalar  levlist, elt_levlist, subsign;
        integer the_sign;
  the_sign := 1;
  levlist := for each child in cdr stree collect
    if numberp child then
      child
    else
      <<
      subsign := st_signchange1(child, eltlist);
      the_sign := the_sign * car subsign;
      cdr subsign
      >>;
  if not cdr levlist then return (the_sign . car levlist);
  elt_levlist := eltlist;
  if member(car eltlist, levlist) then
    elt_levlist := 0 . elt_levlist
  else while not member(cadr elt_levlist, levlist) do
    elt_levlist := cdr elt_levlist;
%% cdr elt_levlist starts with the elements of levlist
%% Compute the sign change
  if car stree eq '!- and not permp(levlist, cdr elt_levlist) then
      the_sign := - the_sign;
%% remove from elt_levlist (and thus from eltlist)
%% the elements of levlist except the last (which will be the
%% ref).
  rplacd(elt_levlist, pnth(cdr elt_levlist, length(levlist)));
  return (the_sign . cadr elt_levlist);
  end;

symbolic procedure st_sorttree(stree, ve, fn);
  cdr st_sorttree1(stree, ve, fn);

symbolic procedure st_sorttree1(stree, ve, fn);
  begin scalar  schild, vallist, sorted, thesign, tosort;
  thesign := 1;
  if numberp cadr stree then
    <<
    if car stree eq '!* then
      <<
      vallist := for each elt in cdr stree collect venth(ve,elt);
      return (vallist . (1 . stree))
      >>;
    tosort := for each elt in cdr stree collect
      elt . venth(ve,elt);
    >>
  else
    <<
    if (car stree) eq '!* then
      <<
      for each child in cdr stree do
        if thesign neq 0 then
          <<
          schild := st_sorttree1(child, ve, fn);
          thesign := thesign * cadr schild;
          vallist := (car schild) . vallist;
          sorted := (cddr schild) . sorted;
          >>;
      if thesign = 0 then
        return (nil . 0 . nil)
      else
        <<
        sorted := reverse sorted;
        vallist := reverse vallist;
        return (vallist . (thesign . ('!* . sorted)));
        >>
      >>;
    for each child in cdr stree do
      if thesign neq 0 then
        <<
        schild := st_sorttree1(child, ve, fn);
        thesign := thesign * cadr schild;
        tosort := ((cddr schild) . (car schild)) . tosort;
        >>;
    >>;
  if thesign = 0 then return (nil . (0 . nil));
  if car stree = '!+ then
    tosort := cdr_sort(tosort, fn)
  else
    <<
    tosort := cdr_signsort(tosort, fn);
    if car tosort = 0 then
      return (nil . (0 . nil))
    else
      thesign := thesign * car tosort;
    tosort := cdr tosort;
    >>;
  % fill up return structures
  while tosort do
    <<
    sorted := (caar tosort) . sorted;
    vallist := (cdar tosort) . vallist;
    tosort := cdr tosort;
    >>;
  sorted := (car stree) . reverse sorted;
  vallist := reverse(vallist);
  return (vallist . (thesign . sorted));
  end;

symbolic procedure st_ad_numsorttree(stree);
  begin scalar sorted;
  sorted := st_ad_numsorttree1(stree);
  return car sorted . cadr sorted;
  end;

symbolic procedure st_ad_numsorttree1(stree);
  begin scalar  subtree, contents, tosort;
        integer thesign;
  if numberp stree then return {1, stree, stree};
  thesign := 1;
  if car stree eq '!* then
    <<
    stree := '!* . for each elt in cdr stree collect
      <<
      subtree := st_ad_numsorttree1(elt);
      thesign := thesign * car subtree;
      contents := cddr subtree . contents;
      cadr subtree
      >>;
    contents := ad_numsort(for each elt in contents join elt);
    return thesign . (stree . contents);
    >>;
  tosort := for each elt in cdr stree collect
    <<
    subtree := st_ad_numsorttree1(elt);
    thesign := thesign * car subtree;
    cdr subtree
    >>;
  if car stree eq '!+ then
    <<
    tosort := cdr_sort(tosort, function numlist_ordp);
    tosort := for each elt in tosort collect
      <<
      contents := (cdr elt) . contents;
      car elt
      >>;
    contents := ad_numsort(for each elt in reverse contents join elt);
    return (thesign . (('!+ . tosort) . contents));
    >>;
  if car stree eq '!- then
    <<
    tosort := cdr_signsort(tosort, function numlist_ordp);
    thesign := car tosort;
    tosort := for each elt in cdr tosort collect
      <<
      contents := (cdr elt) . contents;
      car elt
      >>;
    contents := ad_numsort(for each elt in reverse contents join elt);
    return (thesign . (('!- . tosort) . contents));
    >>;
  end;

symbolic procedure st_consolidate(stree);
  begin scalar join_cells, children, tmp;
   if null stree then return nil;
   if numberp cadr stree then return stree;
   join_cells := t;
   for each child in reverse(cdr stree) do
     <<
     tmp := st_consolidate(child);
     if tmp then
      <<
      if cddr tmp then
        join_cells := nil
      else
        tmp := {'!*, cadr tmp};
      children := tmp . children;
      >>;
    >>;
  if children then
    <<
    if null cdr children then
      return car children;
    if join_cells then
      children := for each elt in children collect cadr elt;
    return (car stree) . children
    >>
  else
    return nil;
  end;

%%%%%%%%%%%%%%%%%%%%%% SKELETONS %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_cambhead(camb);
  begin
  if listp camb then
    <<
    if member(car camb, {'expt, 'minus}) then
      return dv_cambhead(cadr camb);
    if listp camb then return car camb;
    >>;
  end;

symbolic procedure dv_skelhead(skelpair);
  dv_cambhead car(skelpair);

symbolic procedure dv_skelsplit(camb);
  begin scalar  skel, stree, subskels;
        integer count, ind, maxind, thesign;
  thesign := 1;
  if not listp camb then
    if (ind := dummyp(camb)) then
      return {1, ind, ('!~dv . {'!*, ind})}
    else
      return {1, 0, (camb . nil)};
  stree := get(car camb, 'symtree);
  if not stree then
    <<
    stree := for count := 1 : length(cdr camb) collect count;
    if flagp(car  camb, 'symmetric) then
      stree := '!+ . stree
    else if flagp(car camb, 'antisymmetric) then
      stree := '!- . stree
    else
      stree := '!* . stree
    >>;
  subskels := mkve(length(cdr camb));
  count := 0;
  for each arg in cdr camb do
    <<
    count := count + 1;
    if listp arg then
      putve(subskels, count, (arg . nil))
    else if (ind := dummyp(arg)) then
      <<
      maxind := max(maxind, ind);
      putve(subskels, count, ('!~dv . {'!*, ind}))
      >>
    else
      putve(subskels, count, (arg . nil));
    >>;
  stree := st_sorttree(stree, subskels, function skp_ordp);
  if stree and (car stree = 0) then return nil;
  thesign := car stree;
  skel := dv_skelsplit1(cdr stree, subskels);
  stree := st_consolidate(cdr skel);
  skel := (car camb) . car skel;
  return {thesign, maxind, skel . stree};
  end;

symbolic procedure dv_skelsplit1(stree, skelve);
  begin scalar
            cell_stree, child_list, cur_cell, dv_stree, part, skel, ve;
        integer count, len;
  if numberp cadr stree then
    <<
    ve := skelve;
    child_list := cdr stree;
    skel := for each elt in cdr stree collect car venth(ve,elt);
    >>
  else
    <<
    len := length(cdr stree);
    ve := mkve(len);
    count := len;
    for each child in reverse(cdr stree) do
      <<
      putve(ve, count, dv_skelsplit1(child, skelve));
      skel := car(venth(ve,count)) . skel;
      child_list := count . child_list;
      count := count - 1;
      >>;
    skel := for each elt in skel join copy elt;
    >>;
  %% if root of stree is * node, then
  %% no partition of children is necessary
  if car stree eq '!* then
    <<
    for each elt in reverse(child_list) do
      if cdr venth(ve, elt) then
        dv_stree := cdr venth(ve, elt) . dv_stree;
    if length(dv_stree) = 1 then
      dv_stree := car dv_stree
    else if dv_stree then
      dv_stree := '!* . dv_stree;
    return (skel . dv_stree);
    >>;
  %% regroup children with equal skeletons
  for each elt in child_list do
    if null cur_cell then % new skeleton
      cur_cell := car venth(ve, elt) . {cdr venth(ve, elt)}
    else if (car venth(ve, elt)) = (car cur_cell) then
      rplacd(cur_cell, (cdr venth(ve,elt)) . cdr cur_cell)
    else
      <<
      part := cur_cell . part;
      cur_cell := car venth(ve, elt) . {cdr venth(ve, elt)};
      >>;
  part := cur_cell . part;
  %% prepend contribution of each cell to dv_stree
  %% note that cells of part are in reverse order,
  %% as are elements of each cell
  for each cell in part do
    if cdr cell then
      <<
      cell_stree := car stree . reverse(cdr cell);
      dv_stree := cell_stree . dv_stree
      >>;
  %% now set type of dv_stree, if it has more than one element
  if length(dv_stree) neq 1 then
    dv_stree := '!* . dv_stree
  else
    dv_stree := car dv_stree;
  return skel . dv_stree;
  end;


symbolic procedure nodum_varp u;
% u is a list or an atom (index) or !~dv or !~dva
% returns true if it is neither a list nor a dummy var
% nor !~dv or !~dva.
 if listp u then t
   else
 if flagp(u,'dummy) or car ad_splitname u = g_dvbase
                    or u member {'!~dv,'!~dva}
         then nil
  else t;


symbolic procedure list_is_all_free u;
% u is a list of indices
% returns nil if there is at least one dummy index
% or if one of them is !~dv or !~dva.
 if null u then t
  else
 if nodum_varp car u then list_is_all_free cdr u
   else nil;


symbolic procedure dv_skelprod(sklist, maxind);
% This is the corrected function for commuting
% operators which do not depend on dummy variables.
  begin scalar
               skform, stree, symcells, skel, apair, anticom_alist,
               com_alist, noncom_alist, acom_odd, acom_even, idvect,
               varskel;
        integer the_sign, count;
  %% sort skeletons according to lexicograpical order of dv_skelhead,
  %% placing commuting factors before anticommuting factors
  the_sign := 1;
  for each skelpair in sklist do
    <<
    skel := car skelpair;
    varskel:=if listp skel then
                if car skel neq 'expt then cdr skel;
% else
%                     if car skel neq 'expt then cdr skel;
    if flagp(dv_skelhead skelpair , 'anticom) then
      <<
      if (apair := anticom_assoc(skel, anticom_alist)) then
        <<
        if member(cdr skelpair, cddr apair) then
          the_sign := 0
        else
          the_sign := the_sign * car apair;
        rplacd(cdr apair, (cdr skelpair) . (cddr apair))
        >>
      else
        anticom_alist := (skel . {cdr skelpair}) . anticom_alist;
      >>
    else if flagp(dv_skelhead skelpair, 'noncom) then
      noncom_alist := (skel . {cdr skelpair}) . noncom_alist
   % we do not need the "else if" for commuting operators
   %   if no dummy variable is involved:
 %   else  if null list_is_all_free varskel or atom skel then
 %               if(apair := assoc(skel, com_alist)) then
    else  if ( (null list_is_all_free varskel or atom skel) and
               (apair := assoc(skel, com_alist)) ) then
    rplacd (apair, (cdr skelpair) . (cdr apair))
     %           else nil
    else
      com_alist := (skel . {cdr skelpair}) . com_alist;
    >>;
  if the_sign = 0 then return nil;
  %% restore order of factors for each anticom cell
  anticom_alist := for each elt in anticom_alist collect
    (car elt) . reverse(cdr elt);
  %% sort com_alist
  com_alist := sort(com_alist,
                    function(lambda(x,y); idcons_ordp(car x, car y)));
  %% sort anticom_alist, taking care of sign changes
  %% isolate even prod of anticoms from odd prod of anticoms
  for each elt in anticom_alist do
    if evenp(length(cdr elt)) then
      acom_even := elt . acom_even
    else
      acom_odd := elt . acom_odd;
  acom_even := sort(acom_even,
                    function(lambda(x,y); idcons_ordp(car x, car y)));
  anticom_alist := ad_signsort(acom_odd,
                     function(lambda(x,y); idcons_ordp(car x, car y)));
  the_sign := the_sign * car anticom_alist;
  anticom_alist :=
    merge_list1(acom_even, cdr anticom_alist, function idcons_ordp);
  skform := append(com_alist, anticom_alist);
  skform := append(skform, reverse noncom_alist);
  if maxind = 0 then
    <<
    if the_sign = -1 then skform := ((-1) . {nil}) . skform;
    return skform . nil;
    >>;
  %% build complete symtree,
  %% omiting skels which do not depend on dummy variables
  for each elt in reverse noncom_alist do
    stree := cadr elt . stree;
  for each elt in reverse anticom_alist do
    if length(cdr elt) > 1 then
      stree := ('!- . cdr elt) . stree
    else if (cdr elt) then
      stree := cadr elt . stree;
  for each elt in reverse com_alist do
    if length(cdr elt) > 1 then
      stree := ('!+ . cdr elt) . stree
    else if (cdr elt) then
      stree := cadr elt . stree;
  if length(stree) > 1 then
    stree := '!* . stree
  else
    stree := car stree;
  stree := st_consolidate(stree);
  idvect := mkve(maxind);
  for count := 1 : maxind do putve(idvect, count, count);
  stree := st_sorttree(stree, idvect, function numlist_ordp);
  %% the sign change for sorting the symmetry tree does not influence
  %% the sign of the expression.  Indeed, the symtree used to fill up
  %% the blanks in the expression is the symtree stored with the
  %% skeleton, which is not sorted.  Note however that if the sign here
  %% is 0, then the expression is null.
  %  the_sign := the_sign * car stree;
  if car stree = 0 then return nil;
  if the_sign = -1 then
    skform := ((-1) . {nil}) . skform;
  symcells := st_extract_symcells(cdr stree, maxind);
  return skform . symcells;
  end;


symbolic procedure dv_skel2factor1(skel_kern, dvars);
  begin scalar dvar,scr;
    if null skel_kern then return nil;
   return
    if listp skel_kern then
     <>
  else
    if skel_kern eq '!~dv then
      <<
      dvar := car dvars;
      if cdr dvars then
        <<
        rplaca(dvars, cadr dvars);
        rplacd(dvars, cddr dvars);
        >>;
      dvar
      >>
    else
      skel_kern;
  end;

%%%%%%%%%%%%%%% PARTITION SYMMETRY TREES %%%%%%%%%%%%%%%%%%

symbolic procedure pst_termnodep(pst);
  null cdr venth(cdr pst, 1);

symbolic procedure pst_mkpst(stree);
  pst_equitable(nil . pst_mkpst1(stree));

symbolic procedure st_multtermnodep(stree);
  begin
  scalar res, subtrees;
  if car stree neq '!* then return nil;
  subtrees := cdr stree;
  res := t;
  while subtrees do
    <<
    if numberp cadar subtrees then
      subtrees := cdr subtrees
    else
      <<
      subtrees := nil;
      res := nil;
      >>
    >>;
  return res;
  end;

symbolic procedure pst_mkpst1(stree);
  begin
  scalar
    subtrees, s_cells, ve, pst, cell;
  integer
    count, lastcount;
  if null stree then return nil;
  ve := mkve(length(cdr stree));
  subtrees := cdr stree;
  count := 1;
  if numberp(car subtrees) then       % terminal node with single cell
    while subtrees do
      <<
      putve(ve, count, ({car subtrees} . nil));
      count := count + 1;
      subtrees := cdr subtrees;
      >>
  % check if valid as pst terminal node with several cells
  else if st_multtermnodep(stree) then
    <<
    ve := mkve(for each cell in subtrees sum (length(cdr cell)));
    lastcount := 0;
    for each s_cell in subtrees do
      <<
      cell := cdr s_cell;
      if car s_cell eq '!* then
        for count := 1 : length(cell) do
          pst := {count + lastcount} . pst
      else
        pst := (
          for count := 1 : length(cell) collect (count + lastcount)
          ) . pst;
      count := lastcount + 1;
      lastcount := lastcount + length(cell);
      for each elt in cell do
        <<
        putve(ve,count, {{elt}});
        count := count + 1;
        >>;
      >>;
    return (reverse pst . ve);
    >>
  else
    while subtrees do
      <<
      pst := pst_mkpst1(car subtrees);
      s_cells := nil;
      for count2 := 1 : upbve(cdr pst) do
        s_cells := append(car venth(cdr pst, count2), s_cells);
      putve(ve, count, (s_cells . pst));
      count := count + 1;
      subtrees := cdr subtrees;
      >>;
  if ((car stree) eq '!*) then % discrete partition
    pst := ((for count := 1 : upbve(ve) collect {count}) . ve)
  else % single cell partition
    pst := ({(for count := 1 : upbve(ve) join {count})} . ve);
  return pst;
  end;

symbolic procedure pst_subpst(pst, ind);
  venth(cdr pst, ind);

symbolic procedure pst_reduce(pst);
  begin
  scalar
       isolated, f_cell, rpst, tmp, npart, nsubs;
  integer
       ind, count;
  if null pst then return (nil . nil);
  if null cdr pst then return pst;
  f_cell := caar pst;
  while length(f_cell) eq 1 do
    <<
    ind := car f_cell;                   % index of pst_subpst
    if pst_termnodep(pst) then
      <<
      isolated := append(isolated, {caar venth(cdr pst, ind)});
      %% remove first cell from pst, and set f_cell
      if cdar pst then % pst is not fully reduced
        <<
        %% remove first cell
        rplaca(pst, cdar pst);
        %% update pst representation
        npart := for each cell in car pst collect
          for each elt in cell collect
            if (elt > ind) then elt - 1 else elt;
        nsubs := mkve(upbve(cdr pst)-1);
        for count := 1 : upbve(nsubs) do
          if count geq ind then
            putve(nsubs, count, venth(cdr pst, count+1))
          else
            putve(nsubs, count, venth(cdr pst, count));
        rplaca(pst, npart);
        rplacd(pst, nsubs);
        f_cell := caar pst;
        >>
      else % pst fully reduced
        f_cell := pst := nil;
      >>
    else
      <<
      rpst := pst_reduce(cdr pst_subpst(pst,ind));
      if car rpst then
      %% new isolates
        <<
        %% add new isolates to isolated
        isolated := append(isolated, car rpst);
        if cdr rpst then
        %% first subtree in pst was not discrete, update subtree spec
          <<
          tmp := pst_subpst(pst,ind);
          rplaca(tmp, setdiff(car tmp, car rpst));
          rplacd(tmp, cdr rpst);
          f_cell := nil;
          >>
        else  % first subtree in pst was discrete, so remove it
          <<
          if cdar pst then % pst not fully reduced
            <<
            rplaca(pst, cdar pst);
            npart := for each cell in car pst collect
              for each elt in cell collect
                if (elt > ind) then elt - 1 else elt;
            nsubs := mkve(upbve(cdr pst)-1);
            for count := 1 : upbve(nsubs) do
              if count geq ind then
                putve(nsubs, count, venth(cdr pst, count+1))
              else
                putve(nsubs, count, venth(cdr pst, count));
            rplaca(pst, npart);
            rplacd(pst, nsubs);
            f_cell := caar pst;
            >>
          else
            f_cell := pst := nil;
          >>;
        >>
      else
      %% car rpst is nil, so no more isolated d-elts
        <<
        f_cell := nil;
        >>;
      >>
    >>;
  return (isolated . pst);
  end;

symbolic procedure pst_isolable(rpst);
  begin
  scalar
    ve, f_cell;
  %% verify if fully reduced.
  if null cdr rpst then return nil;
  %% f_cell is list of elts in first cell in rpst.
  %% ve is vector of descriptions of elts in f_cell
  f_cell := caadr rpst;
  ve := cddr rpst;
  %% if the elts in f_cell are d-elts, then return the list of d-elts
  if null cdr venth(ve, car f_cell) then
    return for each ind in f_cell collect caar venth(ve, ind);
  return for each ind in f_cell join copy
    pst_isolable(nil . cdr venth(ve, ind));
  end;

symbolic procedure pst_isolate(s_cell, rpst);
  begin
  scalar
    redisol;
  redisol := pst_reduce(pst_isolate1(s_cell, cdr rpst));
  rplaca(redisol, append(car rpst, car redisol));
  return redisol;
  end;

symbolic procedure pst_isolate1(s_cell, pst);
  begin
  scalar
    fcell, tmp, spst;
  integer
    ind;
  %% fcell is the list of elts in the first cell of rpst
  %% ve is the vector of descriptions of elts in fcell
  fcell := caar pst;
  %% find out which elt of fcell needs to be set aside, if any
  tmp := fcell;
  while (ind = 0) do
    <<
    if null tmp then ind := -1;
    ind := car tmp;
    tmp := cdr tmp;
    if not member(s_cell, car (spst := pst_subpst(pst, ind))) then
      ind := 0
    >>;
  %% if no elt should be set aside, then s_cell is not isolable
  if (ind = -1) then return nil;
  %% effectively isolate, splitting first cell if necessary
  if (length(fcell) > 1) then
    <<
    tmp := delete(ind, fcell) . cdar pst;
    tmp := {ind} . tmp;
    rplaca(pst, tmp)
    >>;
  %% if the set aside elt is not a mere dummy variable, then isolate
  %% s_cell in the partition it represents.
  if not pst_termnodep(pst) then
    <<
    spst := car spst . pst_isolate1(s_cell, cdr spst);
    putve(cdr pst, ind, spst)
    >>;
  return pst;
  end;

symbolic procedure pst_equitable(rpst);
  begin
  scalar
    nrpst, reduced, isol;
  if null cdr rpst then return rpst;
  isol := car rpst;
  nrpst := pst_reduce(cdr rpst);
  rplaca(nrpst, append(isol, car nrpst));
  repeat
    <<
    isol := car nrpst;
    nrpst := isol . pst_equitable1(isol, cdr nrpst);
    reduced := pst_reduce(cdr nrpst);
    if car reduced then
      nrpst := (append(isol, car reduced) . cdr reduced);
    reduced := car reduced
    >>
  until not reduced;
  return nrpst;
  end;

symbolic procedure pst_equitable1(isolated, pst);
  begin
  scalar
    isol, ve, alpha, beta, p1, equit, cell, psi;
  integer
    len, k, n_delems;
  if null pst then return nil;
  %% make partition to equitate, merging isolated and car pst
  isol := isolated;
  len := length(isolated);
  ve := mkve(upbve(cdr pst) + len);
  for count := 1 : upbve(cdr pst) do
    putve(ve, count, car venth(cdr pst, count));
  alpha := car pst;
  for count := upbve(cdr pst) + 1 : upbve(ve) do
    <<
    putve(ve, count, {car isol});
    isol := cdr isol;
    alpha := {count} . alpha;
    >>;
  p1 := fullcopy alpha;
  len := length(p1);
  n_delems := upbve(ve);
  while (alpha and len  < n_delems) do
    <<
    beta := car alpha;
    alpha := cdr alpha;
    equit := nil;
    len := 0;
    while(p1) do
      <<
      cell := car p1;
      p1 := cdr p1;
      psi := if cdr cell then
                       pst_partition(cell, beta, ve) else {cell};
      k := length(psi);
      equit := append(equit, psi);
      len := len + k;
      if k geq 2 then alpha := append(cdr psi, alpha);
      >>;
    p1 := equit;
    >>;
  equit := pnth(p1,length(isolated)+1);
  %%% make every child of pst equitable w.r.t. isolated
  if not pst_termnodep(pst) then
    for count := 1 : upbve(cdr pst) do
      <<
      p1 := venth(cdr pst, count);
      putve(cdr pst, count,
            (car p1 . pst_equitable1(isolated, cdr p1)));
      >>;
  return (equit . cdr pst);
  end;

symbolic procedure pst_d1(d1,d2, ve);
  for each e1 in venth(ve,d1) collect ordn
    for each e2 in venth(ve, d2) collect ordn
      car pa_coinc_split(sc_kern(e1), sc_kern(e2));

symbolic procedure pst_d(d1, d2, ve);
  if listp d1 then
    if listp d2 then
      ordn for each e1 in d1 collect
        ordn for each e2 in d2 collect pst_d(e1, e2, ve)
    else
      ordn for each e1 in d1 collect pst_d(e1, d2, ve)
  else
    if listp d2 then
      ordn for each e2 in d2 collect pst_d(d1, e2, ve)
    else
      pst_d1(d1, d2, ve);

symbolic procedure pst_partition(s1, s2, ve);
  begin
  scalar
    elt_d, elt_apair, pst_alist;
  for each elt in s1 do
    <<
    elt_d := pst_d(elt, s2, ve);
    if (elt_apair := assoc(elt_d, pst_alist)) then
      rplacd(elt_apair, elt . cdr elt_apair)
    else
      pst_alist := (elt_d . {elt}) . pst_alist;
    >>;
  % sort regrouped elts according to distance to s2
  pst_alist := sort(pst_alist,
      function( lambda(x,y); numlist_ordp(car x, car y)));
  return for each elt in pst_alist collect reverse(cdr elt);
  end;

%%%%%%%%%%%%%%%%%%%%%%%% BACKTRACKING %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_next_choice(sc, partial_perm, rpst, comp_info);
  begin scalar
    next_perm, extensions, nrpst, new_aut;
  integer
    npoints, len, next_img ;
  npoints := upbve(car sc);
  g_skip_to_level := len := upbve(partial_perm) + 1;
  sc_setbase(sc, partial_perm);
  extensions := pst_isolable(rpst);
  repeat
    <<
    extensions := idsort( intersection
        (extensions, candidate_extensions(sc, partial_perm)));
    if extensions then
      <<
      next_img := car extensions;
      extensions := cdr extensions;
      nrpst := pst_equitable(pst_isolate(next_img, fullcopy(rpst)));
      next_perm := list2vect!*(car nrpst,'symbolic);
      comp_info := dv_compare(next_perm, comp_info, len, npoints);
      if (car comp_info = 0) then
       if (upbve(next_perm) = npoints) then
       <<
       new_aut := pe_mult(pe_inv(venth(cadr comp_info, 1)), next_perm);
          process_new_automorphism(sc, new_aut);
          >>
        else
          comp_info := dv_next_choice(sc, next_perm, nrpst, comp_info)
      else if (car comp_info = 1) then
        if (upbve(next_perm) < npoints) then
          comp_info := dv_next_choice(sc, next_perm, nrpst, comp_info)
        else
          rplaca(comp_info, 0);
      rplacd(cdr comp_info, cdr cddr comp_info);
      >>
    >>
  until (null extensions) or (len > g_skip_to_level);
  return comp_info;
  end;

symbolic procedure can_rep_cell(comp_info, level);
  venth(venth(cadr comp_info, 2), level);

symbolic procedure last_part_kern(comp_info);
  car cddr comp_info;

symbolic procedure dv_compare(next_perm, comp_info, len, npoints);
  begin
  scalar
    part_kern, part_rep, can_rep, curlev, res;
  if car comp_info = 1 then
    return
     dv_fill_comp_info(next_perm, comp_info, len, npoints, nil, nil);
  if len = 1 then
    <<
    part_kern := sc_kern(venth(next_perm, 1));
    part_rep := {sc_rep(venth(next_perm,1))};
    >>
  else
    <<
    part_kern := last_part_kern(comp_info);
    part_kern := pa_coinc_split(part_kern,
                                sc_kern(venth(next_perm, len)));
    part_rep := (sc_rep(venth(next_perm, len)) . car part_kern);
    part_kern := cdr part_kern;
    >>;
  can_rep := can_rep_cell(comp_info, len);
  curlev := len;
  res := 0;
  repeat
    <<
    if equal(can_rep, part_rep) then
      <<
      res := 0;
      if (curlev < upbve(next_perm)) then
        <<
        curlev := curlev + 1;
        part_kern := pa_coinc_split(part_kern,
                                   sc_kern(venth(next_perm, curlev)));
        part_rep := (sc_rep(venth(next_perm,curlev)) . car part_kern);
        part_kern := cdr part_kern;
        can_rep := can_rep_cell(comp_info, curlev);
        >>
      >>
    else if numlist_ordp(can_rep, part_rep) then
      <<
      res := 1;
      rplaca(comp_info, 1);

      comp_info := dv_fill_comp_info(next_perm, comp_info,
                              curlev, npoints, part_rep, part_kern);
      >>
    else
      <<
      res := 2;
      % grow partial permutation kernel stack
      rplacd(cdr comp_info, nil . (cddr comp_info));
      rplaca(comp_info, 2);
      >>
    >>
  until (res neq 0) or (curlev = upbve(next_perm));
  if res = 0 then
    <<
    % update partial permutation stack
    rplacd(cdr comp_info, part_kern . cddr comp_info);
    if (curlev = npoints) and
                 dv_new_aut_hook(next_perm, comp_info) then
      <<
      g_skip_to_level := 0;
      rplaca(comp_info, 2);
      >>;
    >>;
  return comp_info;
  end;


symbolic procedure dv_fill_comp_info(pe, comp_info, len, npoints,
                                     part_rep, part_kern);
  begin scalar
    part_rep;
  integer level;
  if len = 1 then
    <<
    part_kern := sc_kern(venth(pe, 1));
    part_rep := {sc_rep(venth(pe,1))};
    >>
  else if null part_kern then
    <<
    part_kern := last_part_kern(comp_info);
    part_kern := pa_coinc_split(part_kern, sc_kern(venth(pe, len)));
    part_rep := (sc_rep(venth(pe, len)) . car part_kern);
    part_kern := cdr part_kern;
    >>;
  putve(venth(cadr comp_info, 2), len, part_rep);
  level := len + 1;
  while(level <= upbve(pe)) do
    <<
    part_kern := pa_coinc_split(part_kern, sc_kern(venth(pe, level)));
    part_rep := (sc_rep(venth(pe, level)) . car part_kern);
    part_kern := cdr part_kern;
    putve(venth(cadr comp_info, 2), level, part_rep);
    level := level + 1
    >>;
  rplacd(cdr comp_info, part_kern . (cddr comp_info));
  if level = npoints+1 then
    if null venth(cadr comp_info, 1) and
                             dv_null_first_kern(part_kern) then
      <<
      g_skip_to_level := 0;
      rplaca(comp_info, 2);
      >>
    else
      <<
      putve(cadr comp_info, 1, fullcopy(pe));
      putve(cadr comp_info, 3, part_kern);
      >>;
  return comp_info;
  end;

symbolic procedure dv_null_first_kern(kern);
  begin
  scalar
    l_kern, cell, nullexp, acell;
  integer
    count, count2;
  nullexp := nil;
  l_kern := pa_vect2list kern;
  for each cell in l_kern do
    if cdr cell and not nullexp then
      <<
      count := 0;
      for count2 := 1 : upbve(g_sc_ve) do
        if (car (acell := car venth(g_sc_ve, count2)) eq '!-) and
          member (car cell, acell) then count := count + 1;
      if oddp count then
        nullexp := t;
      >>;
  return nullexp;
  end;

symbolic procedure dv_new_aut_hook(pe, comp_info);
  begin
  scalar tmp1, tmp2, ve;
  integer count, thesign;
  thesign := st_signchange(venth(cadr comp_info,1), pe);
  tmp1 := pa_part2list(venth(cadr comp_info, 3));
  tmp2 := pa_part2list(caddr comp_info);
  ve := mkve(length(tmp1));
  count := 1;
  while tmp1 do
    <<
    putve(ve, car tmp1, car tmp2);
    tmp1 := cdr tmp1;
    tmp2 := cdr tmp2;
    count := count + 1;
    >>;
  for count := 1 : upbve(g_sc_ve) do
    <<
    tmp1 := car venth(g_sc_ve, count);
    if car tmp1 eq '!- then
      <<
      tmp1 := cdr tmp1;
      tmp2 := for each elt in tmp1 collect venth(ve,elt);
      % tmp2 is the image of tmp1. Since all cells in g_sc_ve are
      % ordered in increased numerical order
      thesign := thesign * car num_signsort(tmp2);
      >>
    >>;
  if thesign = -1 then
    return t;
  return nil;
  end;

%%%%%%%%%%%%%%%%%%%%%%%%%% TOP LEVEL %%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_canon_monomial(sf);
  begin
  scalar
    tmp, sklist, camb, skel, skprod, aut_sc, can_kern,
    new_dvnames, pst, comp_info, factlst, res, fact,
    sorted_factlst;
  integer
    count, expnt, thesign, maxind;
  %% get skeleton pairs for each one of the factors
  thesign := 1;
  while not domainp sf do
    <<
    tmp := lpow(sf); sf := lc(sf);
    %% suppose exponents are integers
    expnt := cdr tmp; camb := car tmp;
    if expnt neq 1 and flagp(dv_cambhead(camb),'anticom) then
      <<
      skel := nil;
      sf := nil;
      >>
    else
      skel := dv_skelsplit(camb);
    if null skel then
      sf := nil
    else
      <<
      if car skel < 0 then
        <<
        skel := cdr skel;
        if oddp(expnt) then thesign := - thesign
        else rplacd(cdr skel, subst('!-, '!+, cdr skel));
        >>
      else
        skel := cdr skel;
      if (car skel > maxind) then maxind := car skel;
      skel := cadr skel;
      if expnt neq 1 then
        rplaca(skel, {'expt, car skel, expnt});
      sklist := skel . sklist;
      >>;
    >>;
  if null sf then return nil;
  sklist := reverse((sf . nil) . sklist);
  %% regroup factors with identical skeletons
  skprod := dv_skelprod(sklist, maxind);
  if null skprod then return nil;
  sklist := car skprod;
  if maxind > 0 then
    <<
    g_sc_ve := cddr skprod;
    g_init_stree := cadr skprod;
    aut_sc := sc_create(upbve(g_sc_ve));
    comp_info := mkve(3);
    putve(comp_info, 2, mkve(upbve(g_sc_ve)));
    comp_info := {1, comp_info, nil};
    pst := pst_mkpst(g_init_stree);
    tmp := list2vect!*(car pst,'symbolic);
    g_skip_to_level := 1;
    if car pst then
      comp_info := dv_compare(tmp, comp_info, 1, upbve(g_sc_ve));
    if cdr pst then
      comp_info := dv_next_choice(aut_sc, tmp, pst, comp_info);
    if g_skip_to_level = 0 then return nil;
    can_kern := pa_part2list(venth(cadr comp_info, 3));
    count := 0;
    new_dvnames := nil;
    for each elt in can_kern do
      <<
      count := count + 1;
      if elt neq count then
        new_dvnames := (elt . count) . new_dvnames;
      >>;
    >>;
  for each cell in sklist do
    <<
    factlst := nil;
    skel := car cell;
    if cadr cell then
     <<
     for each stree in cdr cell do
       <<
       fact := dv_skel2factor( (skel . stree), new_dvnames);
       if car fact = -1 then
         thesign := - thesign;
       factlst := (cdr fact) . factlst;
       >>;
     factlst := reverse factlst;
     if flagp(dv_cambhead skel, 'anticom) then
       <<
       sorted_factlst := ad_signsort(factlst, 'idcons_ordp);
       thesign := thesign * car sorted_factlst;
       sorted_factlst := cdr sorted_factlst;
       >>
     else
       sorted_factlst :=  sort(factlst, 'idcons_ordp);
     res := append(res, sorted_factlst);
     >>
   else
     res := append(res, {skel});
    >>;
  %% transform res, list of factors, into standard form
  if thesign = -1 then
    skprod := {'minus, 'times . res}
  else if thesign = 1 then
    skprod := 'times . res
  else
    skprod := 0;
  return !*a2f skprod;
  end;

symbolic procedure dv_skel2factor(skelpair, newnames);
  begin
  scalar stree, dvars;
  if null cdr skelpair then return car skelpair;
  stree := sublis(newnames, cdr skelpair);
  stree := st_ad_numsorttree(stree);
  dvars :=
   for each elt in st_flatten(cdr stree) collect dv_ind2var elt;
  return (car stree . dv_skel2factor1(car skelpair, dvars));
  end;

%%%%%%%%%%%%%%%%%%%%%%% USER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure canonical sq;
  begin
  scalar
    sf, denom, res, !*distribute;
  res := nil;
  sq := simp!* car sq;
  denom := denr sq;
  on distribute;
  sf := distri_pol numr sq;
  %% process each monomial in sf
  while not domainp(sf) do
    <<
    res := addf(res, dv_canon_monomial(lt sf .+ nil));
    sf := red sf;
    >>;
  res := addf(res,sf);
  %% simplify the whole thing, and return
  return simp!*( {'!*sq, res ./ denom, nil} )
  end;

put ('canonical, 'simpfn, 'canonical);

flag('(symtree),'opfn);

symbolic procedure symtree (name, s);
  <<
  put (name, 'symtree, alg_to_symb s);
  >>;

symbolic procedure remsym u;
% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
 for each j in u do
   if flagp(j,'symmetric) then remflag(list j,'symmetric)
     else
   if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric)
     else remprop(j,'symtree);

symbolic procedure dummy_names u;
 <>;

rlistat '(dummy_names);

 symbolic procedure show_dummy_names;
  if g_dvnames then symb_to_alg vect2list g_dvnames
     else symb_to_alg list('list);

symbolic procedure dummy_base u;
 if g_dvnames then
     msgpri("Named variables",symb_to_alg vect2list g_dvnames,
                            "must be eliminated",nil,t)
   else g_dvbase := u;

symbolic procedure clear_dummy_base;
<< g_dvbase := nil;t>>;

symbolic procedure clear_dummy_names;
<< g_dvnames := nil;t>>;

flag ('(show_dummy_names clear_dummy_names dummy_base
                                   clear_dummy_base), 'opfn);

deflist(
  '((clear_dummy_base endstat) (clear_dummy_names endstat)),'stat);

symbolic procedure anticom u;
 << for each x in u do
  <>;
  t>>;

symbolic procedure remanticom u;
% ALLOWS TO ELIMINATE THE DECLARED anticom flag.
% Operators becomes COMMUTATIVE operators.
 <<
 for each x in u do
      <>;
    t>>;

deflist('((anticom rlis) (remanticom rlis)),'stat);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/contrtns.red0000644000175000017500000004156511526203062024373 0ustar  giovannigiovannimodule contrtns;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!* !*distribute));

% g_dvnames is a vector.


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

fluid('(indxl_tens!* dummy_id!* g_dvnames)); % g_dvnames is a vector.

% This module contains the procedures which enhances the
% capabilities of 'canonical' which is the master function of DUMMY.RED.
% That function is now able to make tensor-like expressions contractions
% and to find the normal form of an expression containing "tensors"
% and derivatives of these and of operators.

% auxiliary functions to canonical:

symbolic procedure no_dum_varp u;
% u is the mvar of a msf
% returns t if the indices are all variables or if
% no indices.
% this is a variation on 'nodum_varp' which should still
% be improved.
 if null cdr u or (splitlist!:(cdr u,'list)=cdr u)  then t
   else nil;

%symbolic procedure no_dum_varp u;
% u is the mvar of a msf
% returns t if the indices are all variables
% or if
% covariant and contravariant indices are the same.
% this is a variation on 'nodum_varp' which should still
% be improved.
% it was aimed to avoid elimination of powers for traces but
% it does not work because they are treated as operators
% in sep-tens_from_other
% if null cdr u  or (splitlist!:(cdr u,'list)=cdr u)  then t
%   else
%     begin scalar ll;
%      ll:= splitlist!:(cdr u,'list);
%     if ll then
%       <>
%      else
%        ll:=for each y in split_cov_cont_ids cdr u collect ordn y;
%   if car ll = cadr ll then return t
% end;


symbolic procedure sep_tens_from_other u;
% u is a standard form which describes a monomial.
% output is list(,)
% does NOT change ordering since multiplication is not necessarily
% commutative.
 begin scalar mv,tel,other,y;
     other:= !*n2f 1;
  l: if numberp u then return list(reversip tel, multf(other,!*n2f u))
      else
     if atom mvar u  then other:=multf(other,!*p2f lpow u)
      else
     << if y:=get(car mvar u, 'Translate1) then
          << u:=fullcopy u; (mvar u:= apply1(y,mvar u)) >>;
%        if tensorp mvar u then tel:=mvar u . tel
%          else  other :=multf(other,!*p2f lpow u)>>;
         if tensorp(mv:=mvar u) then
            if null no_dum_varp mv
                  or flagp(car mv,'noncom)  then tel:=mvar u  . tel
             else other :=multf(other,!*p2f lpow u)
         else  other :=multf(other,!*p2f lpow u)

      >>;
      u:= lc u;
      go to l;
end;


symbolic procedure all_index_lst u;
% u is a list of tensor kernels.
% output is the list of all indices
% example:
% cc:= car sep_tens_from_other bb;
% ((te r b (minus c)) (te r (minus s) (minus d)) (te (minus r) c d))
% gives (r b (minus c) r (minus s) (minus d) (minus r) c d)
  if null u then nil
   else   append(
                 ((if listp car y and caar y = 'list then cdr y
                  else y ) where y=cdar u),
                                           all_index_lst cdr u);


symbolic procedure del_affin_tens u;
% u is a list of tensor kernels
 if null u then nil
  else
 if affinep car u then  del_affin_tens cdr u
  else car u . del_affin_tens cdr u;

symbolic procedure dv_canon_covcont(sf);
% for Riemanian spaces, places contravariant dummy indices first
% in place.
   if domainp sf then sf
    else
 begin scalar tenslist,idlist,dummyid;
   dummyid:=dummy_id!*;
   tenslist:=car sep_tens_from_other(sf); % get tensor list;
%   y:=del_affin_tens y;
   if null tenslist then return restorealldfs sf;
   idlist:=all_index_lst tenslist; %get list of all indexes;
    for each z in tenslist do
      if (get(car z,'partic_tens)='simpdel) or affinep z then
        for each y in cdr z do
          dummyid:=delete(raiseind!: y, dummyid);
    for each z in idlist do
       if atom z then
          (if z memq dummyid
            % first dummy index is high. no more to do with it.
              then dummyid:=delete(z,dummyid))
       else if careq_minus z and memq(cadr z,dummyid) then
          % first dummy index is low, change this.
           << sf:=subst(list('minus,cadr z),cadr z,sf);
              dummyid:=delete(cadr z,dummyid)>>;
  return restorealldfs sf;
end;

symbolic procedure cov_contp(u,v);
% u and v are  lists of  tensors indices
% verify if one has expressions of the form
% (a,b,c,...) and ((minus a')(minus b')(minus c')...)
% for u and v or for v and u.
% IMPORTANT for epsilon products.
 cov_lst_idsp u and cont_lst_idsp v
 or cont_lst_idsp u and cov_lst_idsp v;

symbolic procedure belong_to_spacep(u,sp);
% u is a list of indices
% sp is the name of a space
% t if ALL INDICES belong to sp.
% I do not think it is still needed. ****
 if null u  or sp = 'wholespace then t
  else
 if get(car u,'space) eq sp  then belong_to_spacep (cdr u,sp);

symbolic procedure extract_tens(tel,sp_tens);
% tel is a list of tensor kernels as given by the car of the
% output of 'sep_tens_from_other'
% sp_tens is the name of a special tensor
% result is a list of these tensors found in tel
  if null tel then nil
  else
  if caar tel = sp_tens then
                 car tel . extract_tens(cdr tel,sp_tens)
   else extract_tens(cdr tel,sp_tens);


symbolic procedure treat_dummy_ids(sf);
% manage all dummy indices by interfacing with dummy.red
% Creates bags of ids belonging to same space, and them call
% the simplification procedure form dummy.
 if !*onespace
  then
    begin scalar user_g_dvnames,res;
      user_g_dvnames:=g_dvnames;
      dummy_nam dummy_id!*;
      res:=dv_canon_monomial sf;
      g_dvnames:=user_g_dvnames;
      return if g_dvnames then dv_canon_covcont dv_canon_monomial res
               else dv_canon_covcont res;
    end
  else
    begin scalar res,partit_space_lst,idxl,sp,user_g_dvnames,bool;
      partit_space_lst:=nil;
      user_g_dvnames:=g_dvnames;
      partit_space_lst:=for each y in spaces!* collect car y . nil;
    % Put each index with the ones belonging to same space
      for each z in dummy_id!* do
        if sp:=space_of_idx z then
    % dummy indices which have not been declared to belong to a (sub)space
    % are assumed to belong to 'wholespace'
    % and no error statement is generated iff 'wholespace' has been defined.
             if idxl:=assoc(sp,partit_space_lst) then
                              cdr idxl:=  z . cdr idxl
               else  rerror(cantens,14,
                 list("Index ",z," does not belong to a defined space"));

      res:=sf;
      for each z in partit_space_lst do
        if (idxl:=cdr z)
          then <>;
        if not bool then res:=dv_canon_monomial res; %% added
        g_dvnames:=user_g_dvnames;
      return if g_dvnames then dv_canon_covcont dv_canon_monomial res
               else dv_canon_covcont res;
    end;


%
% the dummy user procedure modified to perform tens calculations
%

symbolic procedure canonical sq;
  begin scalar sf, denom, !*distribute;
   sq := simp!* car sq;
   denom := denr sq;
   on distribute;
   sf := distri_pol numr sq;
  % Check coherence of dummy and free indices and generate dummy_id!*..
  %% simplify the whole thing, and return
  return simp!*( {'!*sq,
     canonical1(sf, cadr check_ids(sf)) ./ denom, nil} );
  end;

symbolic procedure canonical1 (sf, dumlist);
  begin scalar dummy_id!*, res;
   dummy_id!*:=dumlist;
  % WE MUST BE SURE THAT FURTHER SIMPLIFICATIONS WILL
  % NOT REPLACE AN ST BY SEVERAL ST's
  % IF RULES ARE APPLIED THEY  SHOULD HAVE ACTED BY NOW.
  %  IF SEVERAL TENSORS ARE OF THE EPSI KIND THEY MUST ANALYZED
  %  AND, POSSIBLY, REPLACED BY 'DEL' OR EXPANSIONS OF IT.
  %  FOR INSTANCE e(-a,-b)*e(c,d)=
  %  del(-a,c)*delt(-b,d) - del(-a,d)*delt(-b,c)
  %  then we must generate a SUM of standard forms
  % This is HERE that products of epsilon tensors should be dealt with
  % => SIMPEPSE.RED.
  % Epsi simplification.
   while not domainp sf do
   << res:=addf(res,simpepsi_mon_expr(lt sf .+ nil));
      sf:=red sf;
    >>;
   sf:= distri_pol addf(res,sf);
     res:=nil;
  while not domainp(sf) do
  <<
   (if length car y >=2
      then res:= addf(res,dv_canon_tensor y)
        else  res := addf(res, treat_dummy_ids(lt sf .+ nil)))
                                 where y=sep_tens_from_other (lt sf .+ nil);
    sf:=red sf;
   >>;
   clearallnewids();
  % Now add the domainp term:
   return
     res := addf(res,sf);
  end;

symbolic procedure tensor_has_dummy_idx(dum,te);
% dum is a list of dummy indices
% te is a tensor in prefix form.
% T(rue) if one of the indices of te belongs to dum.
 if null dum then nil
 else
 if smember(car dum, te) then t
 else tensor_has_dummy_idx(cdr dum,te);

symbolic procedure tens_list_is_generic tel;
% tel is a list of tensors
% output is T(rue) if ALL tensors are generic
 if null tel then t else
 if null get(caar tel,'partic_tens) then tens_list_is_generic cdr tel;


symbolic procedure mk_delta_first tel;
% input is a list of tensor kernels.
% output is an equivalent list with
% all delta-like tensors placed first
% and eta-like tensors second.
 begin scalar x,y,z;
  x:=extract_tens(tel,get('delta,'name));
  z:=setdiff(tel,x);
  y:=extract_tens(z,get('eta,'name));
  z:=setdiff(z,y);
 return append(x,append(y,z))
 end;


symbolic procedure dv_canon_tensor u;
% u is list(,)
% output is a standard form given to dv_canon_monomial.
% First take the list of tensor kernels and make the contractions
% if necessary.
  begin scalar x,tel,tel_dum,tel_free,notens;
     tel:=car u; tel_free:=!*n2f 1; notens:=cadr u;
 % replace the list tel by tel_dum
 % where tel_dum contains tensors with dummy indices.
 % and put the rest in tel_free
     for each y in tel do
       if tensor_has_dummy_idx(dummy_id!*,y) then tel_dum:=y . tel_dum
       else tel_free:=multf(!*k2f y,tel_free);
   tel_dum:=tel_dum; % to restitute the order
 % now tel_dum must eventually be transformed by contractions.
 % Two cases appear:
 % all tensors in tel_dum are generic:
  return
   if tens_list_is_generic tel_dum then
    <>;
      multf(restorealldfs tel_free,treat_dummy_ids multf(x,notens))
     >>
 % one or several tensors are particular ones:
  else
  % simptensexpr must output a standard form.
          multf(restorealldfs tel_free,
            treat_dummy_ids multf(simptensexpr(
              mk_delta_first tel_dum,dummy_id!*,1),notens));
 end;

symbolic procedure simptensexpr(tel,dum,i);
% tel is the list of tensor kernels
% dum is the associated list of dummy variable
% output should be the standard form of the contracted tensors.
 begin scalar res;
  res:=!*n2f 1;
 return
      if numberp tel then  !*n2f tel
      else
      if atom tel  or length tel=1 then !*k2f car tel
      else
      if i>=length tel + 1 then
          <>
      else
     (if y memq list('simpdelt,'simpeta,'simpmetric)
      then simpdeltetaexpr(tel,dum,i)
      else simptensexpr(tel,dum,i+1)
%  here the epsi tensors should NOT be considered
%  since they are already simplified.
     )where y=get(car nth(tel,i),'partic_tens);
 end;


symbolic procedure simpdeltetaexpr(tel,dum,i);
% output is the result of contraction of the ith tensor
% with the other ones.
% tensor with the other-ones (at least one is present).
% The SAME procedure appears to be valid for BOTH 'delta' and 'eta'.
 begin scalar itel,rtel,res,old,new;
 % itel is delta tensor kernel.
 % rtel is the list of the other tensors
 % res is the new  list of kernels.
   itel:=nth(tel,i);
  if (id_switch_variance cadr itel) neq caddr itel
                   and intersection(flatindxl cdr itel,dum)  then
  << rtel:=remove(tel,i);
    % let  us identify where the dummy index in itel is:
    % and define substitution variables:
      if (old:=raiseind!: cadr itel) memq dum
        then << old:=id_switch_variance cadr itel; new:=caddr itel >>
        else << old:=id_switch_variance caddr itel; new:=cadr itel >>;
      res:=subst(new,old,rtel);
      return simptensexpr(res,dum,i)
   >>
     else return simptensexpr(tel,dum,i+1);
 end;


symbolic procedure select_epsi_pairs ep;
% result is a list of PAIRS of contractible (to DEL)
% epsilon-pairs.
% if there are 3 or more epsilons of a given kind,
% they are eliminated. So contractions will NOT be done.
% to allow for this, generalize THIS procedure.
% the problem however is which two among the three of
% should we choose.
 if null ep then nil
  else
 (if length x = 2 and cov_contp(cdar x,cdadr x) then
                  x .  select_epsi_pairs cdr ep
   else select_epsi_pairs cdr ep) where x=car ep;


symbolic procedure mk_eps_lst tkl;
% tkl is a list of tensor kernels
% extract the list of contractible epsilon pairs from tkl
% and substracts them from tkl.
% returns list(,) or nil.
 begin scalar eps_lst;
   eps_lst:= if !*onespace and get('epsilon,'name) then
                list extract_tens(tkl,find_name('epsilon))
               else
             if epsilon!* then
                  for each i in epsilon!* collect extract_tens(tkl,car i)
              else nil;
   eps_lst:=select_epsi_pairs eps_lst;
   if null eps_lst then
  return list(nil,tkl);
   for each j in eps_lst do tkl:=setdiff(tkl,j);
  return list(eps_lst,tkl)
 end;

symbolic procedure get_sign_space!: u;
 if null u then signature '? else
  get_sign_space u;

symbolic procedure epsi_to_del(ep);
% ep is a list of contractible epsilon pairs.
% returns a standard form which represents the product of
% the DEL-like objects
% First  task: replace all eps-products by DEL-like objects
% taking properly into account the space signature.
% Second task: reconstruct the SF-product.
 if null ep then nil
   else
  begin scalar del_prd,x,y;
  % del_prd is the SF which results from application of SIMPDEL
   del_prd:=!*n2f 1;
  for each j in ep do
   <>;
   return del_prd
  end;

symbolic procedure simpepsi_mon_expr msf;
% msf  is a monomial standard form.
% result is a NEW STANDARD FORM after simplifications on epsilon products
% presently, we limit simplification to the case of TWO epsilons
% for each defined space .
% since more general products are usually not encountered.
  if domainp msf then msf
   else
    begin scalar tens_msf,notens,x,del_prd;
     % First  see if some simplifications are possible.
       tens_msf:=sep_tens_from_other msf;
       notens:=cadr tens_msf;
       notens:=if notens then notens else !*n2f 1;
       tens_msf:=car tens_msf;
       if null tens_msf then return msf;
     % we have to extract relevant epsilon products from tens_msf
     % and construct the DEL-like product
       x:=mk_eps_lst tens_msf;
       tens_msf:=reverse cadr x;
     % function epsi_to_del returns an SF
       del_prd:= epsi_to_del car x;
     % we do the product of DEL-like tensors and operators.
       x:=if del_prd then multf(del_prd,notens)
              else notens;
       for each j in tens_msf do x:=multf(!*k2f j,x);
       % returns tne new SF which is NO LONGER a monomial.
       return x
     end;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/baglist.red0000644000175000017500000006423511526203062024145 0ustar  giovannigiovannimodule baglist$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global('(!:flaglis !:proplis));

fluid '(!*!:avoid);

% 1. Functions which works on LIST_like objects.

symbolic procedure flattens1 x;
% ll; ==> ((A B) ((C D) E))
% flattens1 ll; (A B C D E)
if atom x then list x else
if cdr x then append(flattens1 car x, flattens1 cdr x) else
   flattens1 car x;

algebraic procedure frequency lst;
% gives a LIST of PAIRS  {{el1,freq1} ...{eln,freqn}}.
% Procedure created by E. Schruefer.
   <>;

algebraic procedure frequency1 lst;
if lst = {} then {}
else begin scalar r,el;
      el := first lst;
      if numberp count!?!? el
      then <>
       else r :=
        {el,count!?!? el} . <>;
        return r
       end;

symbolic procedure sequences n;
% Works properly, both in the symbolic and in the algebraic mode.
if !*mode eq 'symbolic then sequsymb n else
algebraic sequalg n;

flag('(sequences),'opfn);

symbolic procedure sequsymb n;
% Corresponds to the one below in the symbolic mode.
if n=1 then list(list(0),list(1))
 else for each s in sequsymb (n-1) conc list(0 . s,1 . s);

algebraic procedure sequalg n;
% Gives the list  {{0,0 ...,0},{0,0, ..., 1}, ...{1,1, ..., 1}}
% "conc" used in an explicit way.
   if n = 1 then {{0},{1}}
    else for each s in sequalg(n - 1) conc {0 . s,1 . s};

algebraic procedure split(u,v);
% split(list(a,b,c),list(1,1,1)); ==> {{A},{B},{C}}
% split(bag(a,b,c,d),list(1,1,2)); ==> {{A},{B},{C,D}}
% etc.
if symbolic baglistp u and symbolic baglistp v then
 begin scalar x;
    return for each n in v collect
             for i := 1:n collect
                 <>
    end
 else lisp rederr(list(u,v,": must be lists or bags"));

symbolic procedure extremum(l,fn);
% Gives the extremum of elements in list l with respect
% to an ordering function fn. It may be ORDP etc ..
if atom l then l else
(if null x then nil else
 maximum3(x ,cadr l,fn))where x=cdr l;

flag('(extremum),'opfn);

symbolic procedure maximum3(l,m,fn);
if null l then m else
if apply2(fn,car l,m) then maximum3(cdr l,car l,fn) else
 maximum3(cdr l, m,fn);

symbolic procedure rmklis u$
begin scalar s,ss;integer n;
if length u = 2  then
<> else
if length u=1 then
 < (1 1 2 3 4 5)
% l1 and l2 are destroyed
% This is complementary to the function INSERT_KEEP_ORDER
  if null l1 then l2
  else if null l2 then l1
  else if apply2(fn,car l1,car l2) then
                               rplacd(l1,merge_list1(cdr l1,l2,fn))
  else rplacd(l2,merge_list1(l1,cdr l2,fn));

% 2. Introduction of BAG-like objects.

put('bag,'simpfn,'simpiden);

flag('(bag),'bag)$  % the default bag

flag('(bag),'reserved)$

symbolic (!:flaglis:=union(list list('bag,'bag),!:flaglis))$

symbolic procedure !:delete(u,prop,val)$
if prop then
for each x in !:proplis do if x=list(u,prop,val)
              then !:proplis:=delete(x,!:proplis) else nil else
for each x in !:flaglis do if x=list(u,val)
              then !:flaglis:=delete(x,!:flaglis);

symbolic procedure !:bagno u; u eq 'list or flagp(u,'boolean);

symbolic procedure !:bagyes u; getd u or
                  gettype u member list('tvector,'vector) or
                  flagp( u,'opfn) or
                  get(u,'simpfn) or get(u,'psopfn) or
                  get(u,'fdegree) or get(u,'ifdegree);

symbolic procedure simpbagprop u$
% gives the bag property to ident. or baglike-list of identifiers U
% V is T if one creates the property or 0 if one destroys it.
% Use is bagprop(,T or 0)
% Makes tests to avoid giving this property to an unsuitable object.
   begin scalar id,bool;
   id:= car u; bool:= if  cadr u eq t then t;
   if listp id then
    << for each x in id do simpbagprop list(x,bool) $
     return bool>> else
   if  idp id and bool=t then
         if !:bagno id then typerr (id,"BAG") else
         if !:bagyes id then <> else
         <>
   else
   if  idp id and not bool  then
   <>
   else  rederr("BAD ARGUMENT for bagprop");
l1: if bool then !:flaglis:=union(list list(id,'bag),!:flaglis)
      else !:delete(id,nil,'bag) end;

symbolic procedure putbag u;
% gives the bag property to ident. or baglike-list of identifiers u
% V is T to create the bag property.
simpbagprop list(u,t);

symbolic procedure clearbag u;
% destroys the bag property of the identifier or the baglike-list u
simpbagprop list(u,0);

rlistat '(putbag clearbag);

symbolic procedure bagp(u)$
% test of the baglike property of U$
not atom u and flagp(car u ,'bag)$

flag('(bagp),'boolean);

symbolic procedure nbglp(u,n)$
%Function which determines if U is not a bag at the level N.
% Used in DEPTH.
if n=0 then not baglistp u else
if atom u or not bglp!:!: car u  then nil else
begin scalar uu$ uu:= u$
 l1:  uu:=cdr uu$
    if null uu then return t$
    if nbglp(car uu,n-1) then  go to l1 else
          return nil end$

symbolic procedure bglp!:!: u;
if not atom u then bglp!:!: car u else
     if (flagp(u,'bag) or u eq 'list) then t else nil;

symbolic procedure baglistp u;
% This function is supposed to act on a prefix simplified expression.
not atom u and ( car u eq 'list  or flagp(car u,'bag));

symbolic procedure nul!: u; baglistp u and null cdr u;

flag('(baglistp nul!:),'boolean);

symbolic procedure alistp u$
% Not for use in algebraic mode.
if null u then t else
(not atom car u) and alistp cdr u;

symbolic procedure abaglistp u;
% For use in algebraic mode. Recognizes when a bag-like object
% contains bags which themselves contain two and only two objects.
if null baglistp u or null baglistp cadr u then nil else
     begin;
l1:  u:=cdr u;
    if null u then return t ;
     if length car u <3 then return nil else go to l1 end;

flag('(abaglistp),'boolean);

% 3. Definitions of operations on lists and bags.

symbolic procedure rexplis u;
% THIS PROCEDURE GENERALIZES BAGLIST TO ANY OBJECT AND GIVES A LIST OF
% THE ARGUMENTS OF U.
if atom ( u:=reval car u) then nil else
% if kernp mksq(u,1) then 'list . cdr u ;
if kernp mksq(u,1) then
  'list . for each i in cdr u collect mk!*sq simp!* i ;

put('kernlist,'psopfn,'rexplis);

symbolic procedure rlisbag u$
begin scalar x,prf;
x:=reval car u; prf :=reval cadr u;
if atom x then return nil else
<>;
return x end;

put('listbag,'psopfn,'rlisbag);

symbolic procedure rfirst li;
  if bagp( li:=reval car li) then
  if null cdr li then car li . nil else  car li . cadr li . nil else
  if car li neq 'list then typerr(li,"list or bag")
  else if null cdr li then parterr(li,1)
  else cadr li;

put('first,'psopfn,'rfirst);

symbolic procedure rsecond li;
 if bagp( li:=reval car li) then
      if null cdr li or null cddr li then  car li . nil
      else  car li . caddr li . nil
  else if car li neq 'list then typerr(li,"list or bag")
  else if null cdr li or null cddr li then parterr(li,2)
  else caddr li;

put('second,'psopfn,'rsecond);

symbolic procedure rthird li;
  if bagp( li:=reval car li) then
    if null cdr li  or null cddr li or null cdddr li
       then car li . nil else  car li . cadddr li . nil
    else if car li neq 'list then typerr(li,"list or bag")
  else if null cdr li or null cddr li or null cdddr li
    then parterr(li,3)
    else cadddr li;

symbolic procedure rrest li;
if bagp( li:=reval car li) then
  if null cdr li then li . nil else  car li . cddr li  else
if car li neq 'list then typerr(li,"list or bag")
else 'list . if null (li:=cdr li) then li else cdr li;

put('rest,'psopfn,'rrest);

symbolic procedure rreverse u;
<>;

put('reverse,'psopfn,'rreverse);

symbolic procedure rlast u;
<>;

put('last,'psopfn,'rlast);

symbolic procedure rdc u;
if null cdr u then nil else car u . rdc cdr u;

symbolic procedure rbelast u;
<< u:=reval car u;
    if baglistp u then
        if null cdr u then u else
        car u . rdc cdr u   else
    typerr(u, "list or bag")>>;

put('belast,'psopfn,'rbelast);

symbolic procedure rappend u;
   begin scalar x,y;
    if length u neq 2 then rederr("append has TWO arguments");
       x:=reval car u;
       y:=reval cadr u;
    if baglistp x and baglistp y  then
                      return car x . append(cdr x,cdr y)
    else typerr(list(x,y),"list or bag")
   end ;

put('append,'psopfn,'rappend);

symbolic procedure rappendn u;
% This append function works for any number of arguments and all
% types of kernels. Output is always a LIST.
   begin scalar x,y;
      x:= revlis u;
      y:=for each i in x collect mkquote if atom i then
         rederr("arguments must be kernels or lists") else cdr i;
      x:=  eval expand(y,'append);
      return 'list .  x
end ;

put('appendn,'psopfn,'rappendn);

%symbolic procedure rcons u;
% Dans ASSIST.RED
% This procedure does not work perfectly well when the package
% HEPHYS is entered because ISIMPA is applied by reval1 on the
% result of RCONS. When it is given by (BAG (LIST A B) C D) it gives
% the output BAG({A,B}) erasing C and D ! It is due to the fact that
% ISIMP1 and ISIMP2 do not accept SQ forms for identifiers.
% So avoid inputs like list(a,b).bag(c,d) when HEPHYS is loaded.
% begin scalar x,y,z;
%      if (y := getrtypeor(x := revlis u)) eq 'hvector
%        then return if get('cons,'opmtch) and (z:=opmtch('cons . x))
%                      then reval z
%                    else prepsq simpdot x
%      if (y := getrtypeor(x := revlis u)) eq 'hvector
%    then return if get('cons,'opmtch) and (z := opmtch('cons . x))
%                   then reval z
%                 else prepsq subs2 simpdot x
%      else if getrtype(y:=cadr x) eq 'list
%             then return  'list . car x . cdadr x
%      else if bagp y
%             then return   z:=car y . car x . cdr y
%       else if fixp y
%   then return z:= if get('rcons,'cleanupfn) then 'bag . revalpart u
%                                else revalpart u
%       else typerr(x,"list or bag")
%   end;

%symbolic procedure isimpa(u,v);
%   if eqcar(u,'list) then u else
%   if eqcar(u,'bag) then cdr u else !*q2a1(isimpq simp u,v);

symbolic procedure rcons u;
% Dans ASSIST.RED
% This procedure does not work perfectly well when the package
% HEPHYS is entered because ISIMPA is applied by reval1 on the
% result of RCONS. When it is given by (BAG (LIST A B) C D) it gives
% the output BAG({A,B}) erasing C and D ! It is due to the fact that
% ISIMP1 and ISIMP2 do not accept SQ forms for identifiers.
% So avoid inputs like list(a,b).bag(c,d) when HEPHYS is loaded.
 begin scalar x,y,z;
      if (y := getrtypeor(x := revlis u)) eq 'hvector
    then return if get('cons,'opmtch) and (z := opmtch('cons . x))
                   then reval z
                 else prepsq subs2 simpdot x
      else if getrtype(y:=cadr x) eq 'list
             then return  'list . car x . cdadr x
      else if bagp y
             then return   z:=car y . car x . cdr y
      else if fixp y then
         <>
       else typerr(x,"list or bag")
   end;

remflag('(isimpa),'lose);

symbolic procedure isimpa(u,v);
 if eqcar(u,'list) or !*!:avoid or (atom u and get(u,'rtype) eq 'hvector)
   then <>
 else !*q2a1(isimpq simp u,v);

flag('(isimpa),'lose);

put('cons,'setqfn,'(lambda (u v w) (setpart!* u v w)));

put('cons,'psopfn,'rcons);

symbolic procedure lengthreval u;
   begin scalar v,w;
      if length u neq 1
        then rederr "LENGTH called with wrong number of arguments"
       else if idp car u and arrayp car u
        then return 'list . get(car u,'dimension)
       else if bagp (u:=reval car u)
        then return  length cdr u;
      v := aeval u;
      if (w := getrtype v) and (w := get(w,'lengthfn))
        then return apply1(w,v)
       else if atom v then return 1
       else if not idp car v or not(w := get(car v,'lengthfn))
        then typerr(u,"length argument")
       else return apply1(w,cdr v)
   end;

put('length,'psopfn,'lengthreval);

put('size,'psopfn,'lengthreval);

symbolic procedure rremove u;
% Allows one to remove the element n of bag u.
% First argument is a bag or list, second is an integer.
 if length u neq 2 then
       rederr("remove called with wrong number of arguments") else
 begin scalar x;integer n;
 x:=reval car u; n:=reval cadr u;
 if baglistp x  then return car x . remove(cdr x,n) else
 typerr(u, "list or bag")
 % rederr(" first argument is a list or a bag, second is an integer")
end;

put('remove,'psopfn,'rremove);

symbolic procedure rdelete u;
begin scalar x,y;
x:=reval car u; y:=reval cadr u;
if baglistp y then return delete(x,y) end;

put('delete,'psopfn,'rdelete);

% Use is delete(,)

symbolic procedure delete_all(ob,u);
'list . del_all_obj(ob,cdr u);

flag('(delete_all),'opfn);

symbolic procedure del_all_obj(ob,u);
% Deletes from list u ALL objects ob
if null u then nil else
if car u = ob then del_all_obj(ob,cdr u) else
  car u . del_all_obj(ob,cdr u);

symbolic procedure rmember u;
% First argument is anything, second argument is a bag or list.
begin scalar x,y$
  x:=reval car u;
  y:=reval cadr u;
 if baglistp y then
              if (x:=member(x,cdr y))
              then return car y . x else return nil
else typerr(y,"list or bag") end;

put('member,'psopfn,'rmember);

% INPUT MUST BE " member (any , < bag OR list> ) ".

symbolic procedure relmult u;
if length u neq 2 then
      rederr("elmult called with wrong number of arguments") else
begin scalar x,y; integer n;
   x:=reval car u;  % It is the object the multiplicity of which one
                  % wants to compute.
   y:=reval cadr u; % IT IS THE list OR bag
 if x=y then return 1 else
 if baglistp y then
            <>>>
         else typerr(y,"list or bag");
 return n end;

put('elmult,'psopfn,'relmult);

% Use is  " elmult (any , < bag OR list> ) " .

symbolic procedure rpair u$
begin scalar x,y,prf$
 if length u neq 2 then
      rederr("pair called with wrong number of arguments");
 x:=reval car u; y:=reval cadr u$
 if not (baglistp x and baglistp y) then
                  rederr("arguments must be lists or bags") else
 prf:=car x;x:=cdr x; y:=cdr y;
 y:=pair(x,for each j in y collect list j);
 return y:=prf . for each j in y collect prf . j  end;

put('pair,'psopfn,'rpair);

symbolic procedure delpair(elt,u);
'list .
  for each j in  delasc(elt,for each i  in cdr u collect cdr i)
                                                  collect 'list . j ;

flag('(delpair),'opfn);

symbolic procedure depth!: u;
   if not atom u and (car u eq 'list or flagp(car u,'bag))
      then 1 + (if cdr u then depth!: cadr u else 0)
    else 0;

symbolic procedure rdepth(u)$
% Use is depth().
begin scalar x; integer n;
 x := reval car u;
 if nbglp(x,n:=depth!: x) then
     return n else return "bag or list of unequal depths" end;

put('depth,'psopfn,'rdepth);

symbolic procedure rinsert u;
% Use is insert(, , ).
begin scalar x,bg,bbg,prf; integer n;
   bg:=reval cadr u; n:=reval caddr u;
 if not baglistp bg then typerr(bg,"list or bag") else
 if n<=0 then rederr("third argument must be positive an integer") else
 if (n:=n+1) > length bg then return append(bg,x:=list reval car u);
   prf:=car bg; x:=reval car u;
   for i:=3:n do <>;
   bbg:=reverse bbg;
  return bbg:=prf . append(bbg,cons(x,cdr bg))
 end;

put('insert,'psopfn,'rinsert);

% Use is : insert(, , ).

symbolic procedure rposition u$
% Use is position(,).
begin scalar el,bg; integer n;
el:=if null !*exp then reval resimp simp!* car u else reval car u;
if not baglistp (bg:=reval cadr u) then typerr(bg," list or bag");
n:=length( bg:=cdr bg);
if (bg:=member(el,bg))
             then return (n:=n+1-length bg)  else
 msgpri(nil,el,"is not present in list or bag",nil,nil) end;

put('position,'psopfn,'rposition);

% **********

% The functions below, when applied to objects containing SEVERAL bag
% prefixes have a rule to select them in the output object when this
% one is itself a bag: the first level prefix has priority over all
% other prefixes and will be selected, when needed, as the envelope
% of the output.

symbolic procedure !:assoc u;
if length u neq 2 then
      rederr("asfirst called with wrong number of arguments") else
 begin scalar x,y,prf;
  x:=reval car u; y:=reval cadr u;
 if null baglistp y then typerr(y,"list or bag");
  prf:=car y; y:=cdr y;
 if null alistp y then typerr(y, "association list") else
      y:=for each j in y collect cdr j;
 return  if null (y:=assoc(x,y)) then nil else prf . y   end;

put('asfirst,'psopfn,'!:assoc);

% Use is : asfirst(, | )

symbolic procedure !:rassoc u;
if length u neq 2 then
      rederr("assecond called with wrong number of arguments") else
begin scalar x,y,prf;
 x:=reval car u; y:=reval cadr u;
 if null baglistp y then typerr(y,"list or bag");
  prf:=car y; y:=cdr y;
 if null alistp y then typerr(y, "association list") else
     y:=for each j in y collect cdr j;
 return  if null (y:=rassoc(list x,y)) then nil else prf . y   end;

put('assecond,'psopfn,'!:rassoc);

% Use is : assecond(,|)

symbolic procedure !:assoc2 u;
if length u neq 2 then
      rederr("asrest called with wrong number of arguments") else
begin scalar x,y,prf;
  x:=reval car u; y:=reval cadr u;
 if null baglistp x or null baglistp y then
   typerr(list(x,y),"list or bag");
  prf:=car y; y:=cdr y; x:=cdr x;
 if null alistp y then typerr(y, "association list") else
     y:=for each j in y collect cdr j;
 return  if null (y:=assoc2(x,y)) then nil else prf . y   end;

put('asrest,'psopfn,'!:assoc2);

% Use is : asrest(,|)

symbolic procedure lastassoc!*(u,v);
% Use is :
% aslast(,|)
% Finds the sublist in which u is the last element in the
% compound list  or bag v, or nil if it is not found.
   if null v then nil
    else begin scalar vv; vv:=car v;
          while length vv > 1  do vv:=cdr vv;
          if u = car vv then return car v
    else return lastassoc!*(u,cdr v) end;

symbolic procedure !:lassoc u;
if length u neq 2 then
      rederr("aslast called with wrong number of arguments") else
begin scalar x,y,prf;
  x:=reval car u; y:=reval cadr u;
 if null baglistp y then typerr(y,"list or bag");
  prf:=car y; y:=cdr y;
 if null alistp y then typerr(y, "association list") else
      y:=for each j in y collect cdr j;
 return  if null (y:=lastassoc!*(x,y)) then nil else prf . y   end;

put('aslast,'psopfn,'!:lassoc);

symbolic procedure rasflist u;
% Use is :
% asflist(,|)
% This procedure gives the LIST (or BAG) associated with the KEY con-
% tained in the first argument. The KEY is here the FIRST element
% of each sublist contained in the association list .
if length u neq 2 then
      rederr("ASFLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
 x:=reval car u; y:=reval cadr u; prf:=car y;
 if null cdr y then return y;
 for each j in cdr y do if car j neq prf then
 rederr list("prefix INSIDE the list or bag neq to",prf);
  l1: aa:=!:assoc(list(x,y));
     if not aa then return prf . reverse res;
     res:=aa . res;
     y:=delete(aa,y);
     go to l1;
                end$

put('asflist,'psopfn,'rasflist);

symbolic procedure rasslist u;
% Use is :
% asslist(,|)
if length u neq 2 then
      rederr("ASSLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
 x:=reval car u; y:=reval cadr u; prf:=car y;
 if null cdr y then return y;
 for each j in cdr y do if car j neq prf then
 rederr list("prefix INSIDE the list or bag neq to",prf);
  l1: aa:=!:rassoc(list(x,y));
     if not aa then return prf . reverse res;
     res:=aa . res;
     y:=delete(aa,y);
     go to l1;
                end$

put('asslist,'psopfn,'rasslist);

symbolic procedure !:sublis u;
% Use is :
% restaslist(,|)
% Output is a list containing the values associated to the selected
% keys.
if length u neq 2 then
    rederr("restaslist called with wrong number of arguments") else
begin scalar x,y,yy,prf;
  x:=reval car u;
  y:=reval cadr u; prf:=car y;
 if null baglistp y then typerr(y,"list or bag") else
 if null alistp (y:=cdr y) then typerr(y," association list or bag")
 else  y:=for each j in y collect cdr j;
 if baglistp x then <>;
  y:=sublis(y,x); if atom y then yy:=list y else
  for each j in y do if not null j then yy:=j . yy;
  yy:=reverse yy;
  return  prf . for each j in yy collect
                     if atom j then prf . j . nil else prf . j$
        end$

put('restaslist,'psopfn,'!:sublis);

% Use is :
% restaslist(,|)
% Output is a list containing the values associated to the selected
% keys.
% ******* End of functions which may change bag- or list- prefixes.

% FOR SUBSTITUTION OF IDENTIFIERS IT IS CONVENIENT TO USE :

symbolic procedure !:subst u;
 reval subst(reval car u,reval cadr u,reval caddr u);

put('substitute,'psopfn,'!:subst);

% Use is : substitute(,,).
% May serve to transform ALL bags into lists or vice-versa.

symbolic procedure !:repla u;
if length u neq 2 then
      rederr("repfirst called with wrong number of arguments") else
begin scalar x,y,prf;
  y:=reval car u; x:= reval cadr u;
 if null baglistp x then typerr(x,"list or bag");
  prf:= car x; x:=cdr x;
  return prf . rplaca(x,y) end;

put('repfirst,'psopfn,'!:repla);

% Use is : repfirst(, );

symbolic procedure !:repld u;
% Use is : represt(, );
begin scalar x,y,prf;
 if length u neq 2 then
       rederr("replast called with wrong number of arguments");
  y:=reval car u; x:= reval cadr u;
 if null baglistp x then typerr(u,"list or bag");
  prf:= car x; x:=cdr x;
  return prf . rplacd(x,list y) end;

put('represt,'psopfn,'!:repld);


% 4. Functions for SETS.

symbolic procedure !:union u$
begin scalar x,y,prf;
 if length u neq 2 then
       rederr("union called with wrong number of arguments");
  x:=reval car u; y:=reval cadr u;
 if not setp y then rederr "second argument to UNION must be a set";
 if baglistp x and baglistp y then
 <> else return nil;
  return y end;

put('union,'psopfn,'!:union);

symbolic procedure setp u;
null repeats u;

flag('(setp),'boolean);

symbolic procedure rmkset u;
begin scalar x,prf$
  x:=reval car u; prf:=car x;
 if baglistp x then return prf . list2set cdr x
end;

put('mkset,'psopfn,'rmkset);

symbolic procedure !:setdiff u$
begin scalar x,y,prf;
 if length u neq 2 then
       rederr("diffset called with wrong number of arguments");
  x:=reval car u; y:=reval cadr u;
 if baglistp x and baglistp y then
    <> else return nil;
 return y end;

put('diffset,'psopfn,'!:setdiff);

symbolic procedure !:symdiff u$
begin scalar x,y,prf;
 if length u neq 2 then
       rederr("symdiff called with wrong number of arguments");
  x:=reval car u; y:=reval cadr u; prf:=car x;
 if setp x and setp y then return
    prf . append(setdiff(x:=cdr x,y:=cdr y),setdiff(y,x))
end;

put('symdiff,'psopfn,'!:symdiff);

symbolic procedure !:xn u$
begin scalar x,y;
  if length u neq 2 then
      rederr("intersect called with wrong number of arguments");
    x:=reval car u; y:=reval cadr u;
  if setp x and setp y then return car x . intersection(cdr x,cdr y)
 end;

put('intersect,'psopfn,'!:xn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/sl2psl.red0000644000175000017500000000573111526203062023733 0ustar  giovannigiovannimodule sl2psl; % Definitions of functions in PSL but not SL.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Some of these are already in the standard REDUCE now.

deflist('((fixp 1) (numberp 1) (floatp 1) (evenp 1) (oddp 1)
          (stringp 1) (idp 1) (ordp 2) (nordp 2) (equal 2)
                              (geq 2) (leq 2)),'number!-of!-args);

%symbolic procedure lastcar l;
% if atom l then l else
% if atom cdr l then car l else car lastpair cdr l;

symbolic procedure lconc(l1,l2);
% Both arguments are lists l1 is a list of the type
% ((a b c ... f) f)
% Useful for concatenating lists from right to left without copying.
% l1 may be nil to start with.
% REQUIRED FOR FUTURE RELEASE
 if null l1 then rplacd(list l2,lastpair l2) else
 if null car l1 then rplacd(rplaca(l1,l2),l2) else
 <>;

symbolic procedure tconc(l,elm);
 <>
 >>;

symbolic procedure adjoin(elm,st);
 % elm is any object, st is a set.
 if member(elm,st) then st else cons(elm,st);

symbolic procedure list2set u;
% Eliminates redundant elements .
% Replaces !:mkset u of the old ASSIST package.
 if null u then nil else if member(car u,cdr u) then list2set cdr u
 else car u . list2set cdr u;


symbolic procedure delqip1(elm,l);
 if not atom cdr l then
   if elm eq cadr l then rplacd(l,cddr l) else
    delqip1(elm,cdr l);

symbolic procedure delqip(elm,l);
 % Deletes elm from l without copying l.
 % This is the good definition given by Arthur Norman.
 % Used in the function SYMMETRIZE.
 if atom l then l else
 if elm eq car l then cdr l else
        <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/perms.red0000644000175000017500000002311011526203062023631 0ustar  giovannigiovannimodule perms;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% returns product of two permutations

symbolic procedure pe_mult(p1, p2);
  begin scalar prod;
  integer count;
  prod := mkve(upbve(p1));
  for count := 1:upbve(p1) do
    putve(prod, count, venth(p2, venth(p1, count)));
  return prod;
  end;

% returns inverse of permutation
symbolic procedure pe_inv(pe);
  begin
  scalar inv;
  integer count;
  inv := mkve(upbve(pe));
  for count := 1:upbve(pe) do
    putve(inv, venth(pe, count), count);
  return inv;
  end;

% returns image of elt by permutation pe
symbolic smacro procedure pe_apply(pe, elt);
  venth(pe, elt);


%%% Stabilizer chain routines

%% Access macros

symbolic smacro procedure sc_orbits(sc, k);
  venth(venth(cdr sc, k), 1);

symbolic smacro procedure sc_transversal(sc,k);
  venth(venth(cdr sc, k), 2);

symbolic smacro procedure sc_generators(sc,k);
  venth(venth(cdr sc, k), 3);

symbolic smacro procedure sc_inv_generators(sc,k);
  venth(venth(cdr sc, k),4);

symbolic smacro procedure sc_stabdesc(sc, k);
  venth(cdr sc, k);

symbolic smacro procedure sd_orbrep(sd, elt);
  venth(venth(sd,1),elt);

symbolic smacro procedure sd_orbreps(sd);
  venth(sd,5);

%% Building routines

symbolic procedure copy_vect(v1, v2);
  begin
  integer count, top;
  top := upbv v2;
  for count := 0 : top do
    putv(v1, count, getv(v2, count));
  end;

symbolic procedure sd_addgen(sd, pe, inv);
  begin scalar
    t1, t2, orbits, orbreps, transversal, generators, inv_generators,
    new_elems, next_elem;
       integer
    count, img;

%% initialize local variables
  orbits := venth(sd, 1);
  transversal := venth(sd, 2);

%% add generator and inverse
  generators := vectappend1(venth(sd,3), pe);
  inv_generators := vectappend1(venth(sd,4), inv);

%% Join elements from the orbits.
  for count := 1 : upbve(orbits) do
    <<
    t1 := venth(orbits, count);
    while (t1 neq venth(orbits, t1)) do t1 := venth(orbits, t1);
    t2 := venth(orbits, pe_apply(pe, count));
    while (t2 neq venth(orbits, t2)) do t2 := venth(orbits, t2);
    if (t1 < t2) then
      putve(orbits, t2, t1)
    else
      putve(orbits, t1, t2)
    >>;
  for count := 1 : upbve(orbits) do
    <<
    putve(orbits, count, venth(orbits, venth(orbits, count)));
    if venth(orbits, count) = count then
      orbreps := count . orbreps
    >>;

%% extend transversal
  % add images of elements of basic orbit by pe to new_elems
  for count := 1 : upbve(transversal) do
    <<
    if venth(transversal, count) then
      <<
      img := pe_apply(pe, count);
      if null(venth(transversal, img)) then
        <<
        putve(transversal, img, inv);
        new_elems := img . new_elems
        >>
      >>
    >>;
  % add all possible images of each new_elems to the transversal
  while new_elems do
    <<
    next_elem := car new_elems;
    new_elems := cdr new_elems;
    for count := 1 : upbve(generators) do
      <<
      img := pe_apply(venth(generators, count), next_elem);
      if null(venth(transversal, img)) then
        <<
        putve(transversal, img, venth(inv_generators, count));
        new_elems := img . new_elems;
        >>
      >>
    >>;

%% update sd
  putve(sd, 1, orbits);
  putve(sd, 2, transversal);
  putve(sd, 3, generators);
  putve(sd, 4, inv_generators);
  putve(sd, 5, orbreps);
  return sd;
  end;

symbolic procedure sd_create(n, beta);
  begin
  scalar sd, orbits, transversal;
  integer count;
  sd := mkve(5);
  orbits := mkve(n);
for count := 1:n do
    putve(orbits, count, count);
  transversal := mkve(n);
  putve(transversal, beta, 0);

  putve(sd, 1, orbits);
  putve(sd, 2, transversal);
  putve(sd, 3, mkve(0));
  putve(sd, 4, mkve(0));
  putve(sd, 5, for count := 1:n collect count);
  return sd
  end;

symbolic procedure sc_create(n);
  begin
  scalar base;
  integer count;
  for count := n step -1 until 1 do
    base := count . base;
  return ((list2vect!*(base,'symbolic)) . mkve(n));
  end;

symbolic procedure sd_recomp_transversal(sd, beta);
  begin
  scalar
    new_trans,
    new_elems, next_elem,
    generators, inv_generators,
    img;
  integer count;

  new_trans := mkve(upbve(venth(sd,1)));
  new_elems := beta . nil;
  putve(new_trans, beta, 0);
  generators := venth(sd,3);
  inv_generators := venth(sd,4);

  while new_elems do
    <<
    next_elem := car new_elems;
    new_elems := cdr new_elems;
    for count := 1 : upbve(generators) do
      <<
      img := pe_apply(venth(generators, count), next_elem);
      if null(venth(new_trans, img)) then
        <<
        putve(new_trans, img, venth(inv_generators, count));
        new_elems := img . new_elems;
        >>
      >>
    >>;
  putve(sd, 2, new_trans);
  return sd;
  end;

symbolic procedure sc_swapbase(sc, k);
  begin scalar
    sd,                    % stab desc being constructed
    pe, inv_pe,
    nu_1, nu_2,
    sd_reps_orb1,          % O_k \cap orbit reps of sd \ beta_k
    b_orb2;                % O_k+1

  integer
    b_1, b_2,              % reps of basic orbits of G_k and G_k+1
    img,
    sigma, swap,
    count,
    ngens,
    elt;

%% take care of nil stabilizer descriptions

 % if k'th sd is null, then the base may be changed with no other modif
  if null sc_stabdesc(sc,k) then
    <<
    swap := venth(car sc, k);
    putve(car sc, k , venth(car sc, k+1));
    putve(car sc, k+1, swap);
    return sc
    >>;

 % if k+1'th sd is null, then one must create a trivial
 % stabilizer desc
  if null sc_stabdesc(sc,k+1) then
    putve(cdr sc, k+1, sd_create(upbve(car sc), venth(car sc, k+1)));

%% initialize sd to copy of stabdesc(k+2), changing the basic rep

  if (k+2 > upbve(car sc)) or null sc_stabdesc(sc, k+2) then
    sd := sd_create(upbve(car sc), venth(car sc, k))
  else
    <<
    sd := mkve(5);
    putve(sd, 1, fullcopy(sc_orbits(sc, k+2)));
    % make copy of generators, but not total copy
    ngens := upbve(sc_generators(sc, k+2));
    putve(sd, 3, mkve(ngens));
    putve(sd, 4, mkve(ngens));
    for count := 1 : ngens do
      <<
      putve(venth(sd, 3), count, venth(sc_generators(sc, k+2), count));
      putve(venth(sd,4), count, venth(sc_inv_generators(sc,k+2),count))
      >>;
    putve(sd, 5, venth(venth(cdr sc, k+2),5));
    sd_recomp_transversal(sd, venth(car sc, k));
    >>;

%% initialize sd_reps_orb1 and b_orb2
  for count := 1:upbve(car sc) do
    <<
    if venth(sc_transversal(sc, k+1), count) then
      b_orb2 := count . b_orb2;
    if venth(sc_transversal(sc, k), count) then
      sd_reps_orb1 := count . sd_reps_orb1
    >>;

  sd_reps_orb1 :=
    intersection(sd_reps_orb1, venth(sd, 5));

  b_1 := venth(car sc, k);
  b_2 := venth(car sc, k+1);

  sd_reps_orb1 := delete(venth(car sc, k), sd_reps_orb1);
%% join orbits of sd by joining elts of sd_reps_orb1
  while sd_reps_orb1 do
    <<
    elt := car sd_reps_orb1;
    sd_reps_orb1 := cdr sd_reps_orb1;
    nu_1 := nu_2 := nil;
    img := elt;
    while (img neq b_1) do
      <<
      nu_1 :=
        if nu_1 then
          pe_mult(nu_1, venth(sc_transversal(sc,k),img))
        else
          venth(sc_transversal(sc,k),img);
      img := pe_apply(nu_1, elt);
      >>;
    sigma := pe_apply(nu_1, b_2);
    if member(sigma, b_orb2) then
      <<
      img := sigma;
      while (img neq b_2) do
        <<
        nu_2 :=
          if nu_2 then
            pe_mult(nu_1, venth(sc_transversal(sc,k+1),img))
          else
            venth(sc_transversal(sc,k+1),img);
        img := pe_apply(nu_2, sigma);
        >>;
      if nu_2 then
        pe := pe_mult(nu_1, nu_2)
      else
        pe := nu_1;
      inv_pe := pe_inv(pe);
      sd_addgen(sd, pe, inv_pe);
      %% update sd_reps_orb1
      %% nu_1 taken as temp storage
      nu_1 := nil;
      for each img in sd_reps_orb1 do
        if sd_orbrep(sd, img)= img then
          nu_1 := img . nu_1;
      sd_reps_orb1 := nu_1;
      >>
    >>;
%% update base specifications
  swap := venth(car sc, k);
  putve(car sc, k, venth(car sc, k+1));
  putve(car sc, k+1, swap);
%% sd is new description of stabilizer at level k+1 of sc
  putve(cdr sc, k+1, sd);
%% update transversal for sd(k), as base element has changed
  sd_recomp_transversal(sc_stabdesc(sc, k), venth(car sc, k));
  return sc;
  end;

symbolic procedure sc_setbase(sc, base_vect);
  begin integer count, k;
  for count := 1:upbve(base_vect) do
    <<
    if venth(base_vect, count) neq venth(car sc, count) then
      for k := index_elt(venth(base_vect, count), car sc)-1
               step -1 until count do sc_swapbase(sc, k)
    >>;
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/dummy.rlg0000644000175000017500000001701211527635055023670 0ustar  giovannigiovanniFri Feb 18 21:27:18 2011 run on win32
% test of DUMMY package version 1.1 running in REDUCE 3.6 and 3.7
% DATE: 15 September 1998
% Authors: H. Caprasse 
%
% Case of commuting operator:
%
operator co1,co2;



% declare dummy indices

% first syntax : base 
%
dummy_base dv;


dv


% dummy indices are dv1, dv2, dv3, ...

exp := co2(dv2)*co2(dv2)$


c_exp := canonical(exp);


                 2
c_exp := co2(dv1)


exp := dv2*co2(dv2)*co2(dv2)$


c_exp := canonical(exp);


                 2
c_exp := co2(dv1) *dv1


exp := c_exp * co1(dv3);


                        2
exp := co1(dv3)*co2(dv1) *dv1

c_exp := canonical(exp);


                          2
c_exp := co1(dv2)*co2(dv1) *dv1


%
operator a,aa,dd,te;



clear_dummy_base;


t


dummy_names a1,a2,b1,b2,mu1,mu2,nu1,nu2;


t


es1:=a(a1,b1)*a(a2,b2);


es1 := a(a1,b1)*a(a2,b2)


asn14:=aa(mu1,a1)*aa(nu2,b2)*dd(nu1,b1,mu2,a2)
         *te(mu1,mu2,nu1,nu2);


asn14 := aa(mu1,a1)*aa(nu2,b2)*dd(nu1,b1,mu2,a2)*te(mu1,mu2,nu1,nu2)

asn17:=aa(mu1,a1)*aa(mu2,a2)*dd(nu1,b1,nu2,b2)
          *te(mu1,mu2,nu1,nu2);


asn17 := aa(mu1,a1)*aa(mu2,a2)*dd(nu1,b1,nu2,b2)*te(mu1,mu2,nu1,nu2)

             
esn14:=es1*asn14;


esn14 := 

a(a1,b1)*a(a2,b2)*aa(mu1,a1)*aa(nu2,b2)*dd(nu1,b1,mu2,a2)*te(mu1,mu2,nu1,nu2)

esn17:=es1*asn17;


esn17 := 

a(a1,b1)*a(a2,b2)*aa(mu1,a1)*aa(mu2,a2)*dd(nu1,b1,nu2,b2)*te(mu1,mu2,nu1,nu2)

esn:=es1*(asn14+asn17);


esn := a(a1,b1)*a(a2,b2)*aa(mu1,a1)*te(mu1,mu2,nu1,nu2)

       *(aa(mu2,a2)*dd(nu1,b1,nu2,b2) + aa(nu2,b2)*dd(nu1,b1,mu2,a2))
 
canonical esn;


a(a1,a2)*a(b1,b2)*aa(mu2,b1)*(aa(mu1,a1)*dd(nu1,b2,nu2,a2)*te(mu2,mu1,nu1,nu2)

    + aa(mu1,a2)*dd(nu1,b2,nu2,a1)*te(mu2,nu2,nu1,mu1))

% that the next result is correct is not trivial 
% to show.
% for esn14 changes of names are 
%
%  nu1 -> nu1
%  b1 -> b2 -> a2
%  mu2 -> nu2 -> mu1 -> mu2
%    
% for esn17 they are
%
%  nu1 -> nu1
%  nu2 -> nu2
%  b1 -> b2 -> a2 -> a1 -> b1
%
% the last result should be zero 
canonical esn -(canonical esn14 +canonical esn17);


0

% remove dummy_names and operators.
clear_dummy_names;


t

clear a,aa,dd,te;


%
% Case of anticommuting operators
%
operator ao1, ao2;


anticom ao1, ao2;


t

% product of anticommuting operators with FREE indices
a_exp := ao1(s1)*ao1(s2) - ao1(s2)*ao1(s1);


a_exp := ao1(s1)*ao1(s2) - ao1(s2)*ao1(s1)

a_exp := canonical(a_exp);


a_exp := 2*ao1(s1)*ao1(s2)


% the indices are summed upon, i.e. are DUMMY indices

clear_dummy_names;


t


dummy_base dv;


dv


a_exp := ao1(dv1)*ao1(dv2)$


canonical(a_exp);


0


a_exp := ao1(dv1)*ao1(dv2) - ao1(dv2)*ao1(dv1);


a_exp := ao1(dv1)*ao1(dv2) - ao1(dv2)*ao1(dv1)

a_exp := canonical(a_exp);


a_exp := 0


a_exp := ao1(dv2,dv3)*ao2(dv1,dv2)$


a_exp := canonical(a_exp);


a_exp := ao1(dv1,dv2)*ao2(dv3,dv1)


a_exp := ao1(dv1)*ao1(dv3)*ao2(dv3)*ao2(dv1)$


a_exp := canonical(a_exp);


a_exp :=  - ao1(dv1)*ao1(dv2)*ao2(dv1)*ao2(dv2)


% Case of non commuting operators
%
operator no1, no2, no3;


noncom no1, no2, no3;



n_exp := no3(dv2)*no2(dv3)*no1(dv1) + no3(dv3)*no2(dv1)*no1(dv2)
         + no3(dv1)*no2(dv2)*no1(dv3);


n_exp := no3(dv1)*no2(dv2)*no1(dv3) + no3(dv2)*no2(dv3)*no1(dv1)

          + no3(dv3)*no2(dv1)*no1(dv2)


n_exp:=canonical n_exp;


n_exp := 3*no3(dv3)*no2(dv2)*no1(dv1)


% ***
% The example below displays a restriction of the package i.e
% The non commuting operators are ASSUMED to COMMUTE with the
% anticommuting operators.
% ***
exp := co1(dv1)*ao1(dv2,dv1,dv4)*no1(dv1,dv5)*co2(dv3)*ao1(dv1,dv3);


exp := co1(dv1)*co2(dv3)*(ao1(dv2,dv1,dv4)*no1(dv1,dv5)*ao1(dv1,dv3))

canonical(exp);


 - co1(dv1)*co2(dv2)*ao1(dv1,dv2)*ao1(dv3,dv1,dv4)*no1(dv1,dv5)


exp := c_exp * a_exp * no3(dv2)*no2(dv3)*no1(dv1);


                           2
exp :=  - co1(dv2)*co2(dv1) *dv1*ao1(dv1)*ao1(dv2)*ao2(dv1)*ao2(dv2)*no3(dv2)

       *no2(dv3)*no1(dv1)

can_exp := canonical(exp);


                               2
can_exp :=  - co1(dv2)*co2(dv1) *dv1*ao1(dv1)*ao1(dv2)*ao2(dv1)*ao2(dv2)

           *no3(dv2)*no2(dv3)*no1(dv1)


% Case where some operators have a symmetry.
%
operator as1, as2;


antisymmetric as1, as2;



dummy_base s;


s


% With commuting and antisymmetric:

asc_exp:=as1(s1,s2)*as1(s1,s3)*as1(s3,s4)*co1(s3)*co1(s4)+
        2*as1(s1,s2)*as1(s1,s3)*as1(s3,s4)*co1(s2)*co1(s4)$



canonical asc_exp;


as1(s1,s2)*as1(s1,s3)*as1(s3,s4)*co1(s3)*co1(s4)


% Indeed: the second term is identically zero as one sees 
%          if the substitutions s2->s4, s4->s2 and 
%           s1->s3, s3->s1 are sucessively done.
% 
% With anticommuting and antisymmetric operators:

dummy_base dv;


dv


exp1 := ao1(dv1)*ao1(dv2)$


canonical(exp1);


0


exp2 := as1(dv1,dv2)$



canonical(exp2);


0


canonical(exp1*exp2);


as1(dv1,dv2)*ao1(dv1)*ao1(dv2)


canonical(as1(dv1,dv2)*as2(dv2,dv1));


 - as1(dv1,dv2)*as2(dv1,dv2)


% With symmetric and antisymmetric operators:

operator ss1, ss2;


symmetric ss1, ss2;



exp := ss1(dv1,dv2)*ss2(dv1,dv2) - ss1(dv2,dv3)*ss2(dv2,dv3);


exp := ss1(dv1,dv2)*ss2(dv1,dv2) - ss1(dv2,dv3)*ss2(dv2,dv3)

canonical(exp);


0


exp := as1(dv1,dv2)*as1(dv3,dv4)*as1(dv1,dv4);


exp := as1(dv1,dv2)*as1(dv1,dv4)*as1(dv3,dv4)

canonical(exp);


0


% The last result is equal to half the sum given below:
%
exp + sub(dv2 = dv3, dv3 = dv2, dv1 = dv4, dv4 = dv1, exp);


0


exp1 := as2(dv3,dv2)*as1(dv3,dv4)*as1(dv1,dv2)*as1(dv1,dv4);


exp1 :=  - as1(dv1,dv2)*as1(dv1,dv4)*as1(dv3,dv4)*as2(dv2,dv3)

canonical(exp1);


as1(dv1,dv2)*as1(dv1,dv3)*as1(dv3,dv4)*as2(dv2,dv4)


exp2 := as2(dv1,dv4)*as1(dv1,dv3)*as1(dv2,dv4)*as1(dv2,dv3);


exp2 := as1(dv1,dv3)*as1(dv2,dv3)*as1(dv2,dv4)*as2(dv1,dv4)

canonical(exp2);


as1(dv1,dv2)*as1(dv1,dv3)*as1(dv3,dv4)*as2(dv2,dv4)


canonical(exp1-exp2);


0


% Indeed:
%
exp2 - sub(dv1 = dv3, dv2 = dv1, dv3 = dv4, dv4 = dv2, exp1);


0


% Case where mixed or incomplete symmetries for operators are declared.

% Function 'symtree' can be used to declare an operator symmetric 
% or antisymmetric:
operator om;



symtree(om,{!+,1,2,3});


exp:=om(dv1,dv2,dv3)+om(dv2,dv1,dv3)+om(dv3,dv2,dv1);


exp := om(dv1,dv2,dv3) + om(dv2,dv1,dv3) + om(dv3,dv2,dv1)

canonical exp;


3*om(dv1,dv2,dv3)


% Declare om to be antisymmetric in the two last indices ONLY:
symtree(om,{!*,{!*,1},{!-,2,3}});


canonical exp;


0
 

% With an antisymmetric operator m:
operator m;


dummy_base s;


s

exp := om(nu,s3,s4)*i*psi*(m(s1,s4)*om(mu,s1,s3) 
+ m(s2,s3)*om(mu,s4,s2) - m(s1,s3)*om(mu,s1,s4) 
- m(s2,s4)*om(mu,s3,s2))$



canonical exp;


 - 4*m(s1,s2)*om(mu,s1,s3)*om(nu,s2,s3)*i*psi


% Case of the Riemann tensor
%
operator r;


symtree (r, {!+, {!-, 1, 2}, {!-, 3, 4}});


% Without anty dummy indices.
clear_dummy_base;


t


exp := r(dv1, dv2, dv3, dv4) * r(dv2, dv1, dv4, dv3)$


canonical(exp);


                  2
r(dv1,dv2,dv3,dv4)


% With dummy indices:
 
dummy_base dv;


dv


canonical( r(x,y,z,t) );


 - r(t,z,x,y)

canonical( r(x,y,t,z) );


r(t,z,x,y)

canonical( r(t,z,y,x) );


 - r(t,z,x,y)


exp := r(dv1, dv2, dv3, dv4) * r(dv2, dv1, dv4, dv3)$


canonical(exp);


                  2
r(dv1,dv2,dv3,dv4)


exp := r(dv1, dv2, dv3, dv4) * r(dv1, dv3, dv2, dv4)$


canonical(exp);


r(dv1,dv2,dv3,dv4)*r(dv1,dv3,dv2,dv4)


clear_dummy_base;


t

dummy_names i,j,k,l;


t


exp := r(i,j,k,l)*ao1(i,j)*ao1(k,l)$



canonical(exp);


0


exp := r(k,i,l,j)*as1(k,i)*as1(k,j)$


canonical(exp);


 - as1(i,j)*as1(i,k)*r(i,k,j,l)


% Cleanup of the previousy declared dummy variables..

clear_dummy_names;


t
 clear_dummy_base;


t


exp := co1(dv3)$


c_exp := canonical(exp);


c_exp := co1(dv3)


end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 15 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/dummy.tex0000644000175000017500000003363011526203062023674 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\newcommand{\nl}{\hfill\newline}
\newcommand{\bq}{\begin{quotation}}
\newcommand{\eq}{\end{quotation}}
\newcommand{\bi}{\begin{itemize}}
\newcommand{\ei}{\end{itemize}}
\date{}
\title{{\bf DUMMY}\\[3pt]
A package to find the canonical form of expressions involving
dummy variables\\[5pt]
  \mbox{\hfill Version 1.1\hfil}}
\author{Alain Dresse \\
Universit\'e Libre de Bruxelles \\
Boulevard du Triomphe, CP 210/01 \\
B--1050 BRUXELLES \\[3pt]
 and \\[5pt]
Hubert Caprasse \\
Universit\'e de Li\`ege \\
Institut de Physique \\
All\'ee du 6 ao\^ut \\
B--4000 LIEGE \\[3pt]
E--mail: hubert.caprasse@ulg.ac.be}
\begin{document}
\maketitle
\index{DUMMY package}
\section{Introduction}
The possibility to handle dummy variables and to manipulate  
dummy summations are important features in many applications. In particular, 
in theoretical physics, the possibility to represent complicated expressions
concisely and to realize simplifications efficiently depend 
on both capabilities.
However, when dummy variables are used, there are many more  ways 
to express a given mathematical objects since 
the names of dummy variables may be chosen  almost arbitrarily.
Therefore, from the point of view of computer algebra
the simplification problem is much more difficult. 
Given a definite ordering, one is, at least, to find a representation which 
is independent of the names chosen for the dummy variables otherwise, 
simplifications are impossible.  
The package does handle any number of dummy variables and summations 
present in expressions which are arbitrary multivariate polynomials  
and which  have operator objects eventually dependent on one (or several) 
dummy variable(s) as some of their indeterminates.
These operators have the same generality as the one existing in {\tt REDUCE}.  
They can be noncommutative, anticommutative or commutative. They can have 
any kind of symmetry property.
Such polynomials will be called in the following {\em dummy} polynomials.
Any monomial of this kind will be called  {\em dummy} monomial.
For any such object, the package allows to find a well defined 
{\em normal form} in one-to-one correspondance with it.

In section 2, the convention for writing dummy summations is explained 
and the available declarations to introduce or suppress dummy variables
are given.

In section 3, the commands allowing to give 
various algebraic properties to the operators are described.

In section 4, the use of the function {\tt CANONICAL} is 
explained and illustrated.

In section 5, a fairly complete set of references is given.

The use of DUMMY requires that the package {\tt ASSIST} 
 version 2.2 be available.
This is the case when {\tt REDUCE 3.6} is used. When loaded, ASSIST is 
automatically loaded.
\section{Dummy variables and dummy summations}
A dummy variable (let us name it $dv$) is an identifier which runs from 
the integer $i_1$ to another integer $i_2$. To the extent that no 
definite space is defined, $i_1$ and $i_2$ are assumed to be some 
integers which are the {\em same} for all dummy variables.

If $f$ is any {\tt REDUCE} operator, then the simplest dummy summation 
associated to $dv$ is the sum  
$$
\sum_{dv=i_1}^{i_2} f(dv)
$$
and is simply written as
$$
f(dv). 
$$
No other rules govern the implicit summations. $dv$ can appear as many times
we want since the operator $f$ may depend on an arbitrary number of 
variables. So, the package is potentially applicable to many contexts.
For instance, it is possible to add rules of the kind one encounters in 
tensor calculus.      

Obviously, there are as many ways we want to express the {\em same} quantity.
If the name of another dummy variable is $dum$ then 
the previous expression is written as
$$
\sum_{dum=i_1}^{i_2} f(dum)
$$
and the computer algebra system should be able to find that the expression
$$
f(dv)-f(dum);
$$
is equal to $0$.
A very special case which is {\em allowed} is when $f$ is the identity 
operator.
So, a generic dummy polynomial will be a sum 
of dummy monomials of the  kind
$$
\prod_i c_i*f_i(dv_1,\ldots ,dv_{k_i},fr_1,\ldots , fr_{l_i})
$$
where $dv_1,\ldots,$ are dummy variables while $fr_1, \ldots, $ 
are ordinary or free variables. 
  
To declare dummy variables, two commands are available:
\begin{itemize}
\item{i.}
\begin{verbatim}
     dummy_base ;
\end{verbatim}
where {\tt idp} is the name of any unassigned identifier.
\item{ii.}
\begin{verbatim}
     dummy_names ,, ....;
\end{verbatim}
\end{itemize}
The first one  declares $ idp_1,\ldots, idp_n$ as dummy variables i.e.
all variables of the form $idp_{xxx}$ where $xxx$ is a number
will be dummy variables, such as $idp_1, idp_2,\ldots, idp_{23}$.
The second one gives special names for dummy variables.
All other identifiers which may appear are assumed to be {\em free}.
However, there is a restriction: named and base dummy variables 
cannot be declared {\em simultaneously}. The above declarations are 
mutually {\em exclusive}. 
Here is an example  showing that:
\begin{verbatim}

     dummy_base dv; ==> dv

               % dummy indices are dv1, dv2, dv3, ...

     dummy_names i,j,k; ==> 
                 
               ***** The created dummy base dv must be cleared
\end{verbatim}
When this is done, an expression like 
\begin{verbatim}
     op(dv1)*sin(dv2)*abs(i)*op(dv2)$
\end{verbatim}
means a sum over $dv_1,dv_2$.
To clear the dummy base, and to create the dummy names $i,j,k$ one is 
to do
\begin{verbatim}

      clear_dummy_base; ==> t

      dummy_names i,j,k; ==> t
                
                 % dummy indices are i,j,k.
\end{verbatim}
When this is done, an expression like
\begin{verbatim}
     op(dv1)*sin(dv2)*abs(x)*op(i)^3*op(dv2)$
\end{verbatim}
means a sum over $i$.
One should keep in mind that every application of the above commands 
erases the previous ones. 
It is also possible to display the declared dummy names using 
{\tt SHOW\_DUMMY\_NAMES}:
\begin{verbatim}
     show_dummy_names(); ==> {i,j,k}
\end{verbatim}
To suppress {\em all} dummy variables one can enter
\begin{verbatim}
     clear_dummy_names; clear_dummy_base;
\end{verbatim}

\section{The Operators and their Properties}
All dummy variables {\em should appear at first level}
as  arguments of operators. For instance, if $i$ and $j$ are 
dummy variables, the expression 
\begin{verbatim}
     rr:=  op(i,j)-op(j,j)
\end{verbatim}
is allowed but the expression 
\begin{verbatim}
     op(i,op(j)) - op(j,op(j))
\end{verbatim}
is {\em not} allowed. This is because dummy variables are not detected 
if they appear at a level larger than 1. 
Apart from that there is no restrictions. Operators  may be 
commutative, noncommutative or even anticommutative. Therefore 
they may be elements of an algebra, they may be tensors,
spinors, grassman variables, etc. $\ldots$
By default they are assumed to be {\em commutative} and without symmetry
properties. The {\tt REDUCE} command {\tt NONCOM} is taken into account 
and, in addition, the command
\begin{verbatim}
     anticom at1, at2;
\end{verbatim}
makes the operators $at_1$ and $at_2$ anticommutative.

One can also give symmetry properties to them. The usual declarations
{\tt SYMMETRIC and AN\-TI\-SYM\-ME\-TRIC} are taken into account. Moreover
and most important they can be endowed with a {\em partial} symmetry 
through the command {\tt SYMTREE}.
Here are three illustrative examples for the $r$ operator:
\begin{verbatim}
     symtree (r,{!+, 1, 2, 3, 4});
     symtree (r,{!*, 1, {!-, 2, 3, 4}});
     symtree (r, {!+, {!-, 1, 2}, {!-, 3, 4}});
\end{verbatim}
The first one makes the operator (fully) symmetric.
The second one declares it antisymmetric with respect 
to the three last indices. 
The symbols !*,\  !+\  and !-\  at the beginning of each list mean that
the operator has no symmetry, is symmetric or is antisymmetric with respect
to the indices inside the list. Notice that the indices are not denoted
by their names but merely by their natural order of appearance. 1 means the
first written argument of $r$, 2 its second argument etc.
The first command is equivalent to the declaration {\tt symmetric}
except that the number of indices of $r$ is {\em restricted} to 
4 i.e. to the number declared in {\tt SYMTREE}.
In the second example $r$  is stated to have no symmetry with respect 
to the  first index and is declared  to be antisymmetric with respect 
to the three last indices. In the third example, $r$ is made symmetric 
with respect to the interchange  of the pairs of indices 1,2 
and 3,4 respectively and is made antisymmetric separately within
the pairs $(1,2)$ and $(3,4)$. It is the symmetry of the Riemann tensor.
The anticommutation property and the various 
symmetry properties may be suppressed by the commands {\tt REMANTICOM} and 
{\tt REMSYM}. To eliminate partial symmetry properties one can also use 
{\tt SYMTREE}  itself. For example, assuming that $r$ has the Riemann symmetry,
to eliminate it do 
\begin{verbatim}
     symtree (r,{!*, 1, 2, 3, 4});  
\end{verbatim}
However, notice that the number of indices remains fixed and equal to 4
while with {\tt REMSYM} it becomes again arbitrary.
\section{The Function {\tt CANONICAL}}
{\tt CANONICAL} is the most important functionality of the package.
It can be applied on any polynomial whether it is a dummy polynommial 
or not. It returns a normal form uniquely determined 
from the current ordering of the system.  
If the polynomial does not contain any dummy index, it is rewriten
taking into account the various operator properties or symmetries described 
above.
For instance, 
\begin{verbatim}
     symtree (r, {!+, {!-, 1, 2}, {!-, 3, 4}});

     aa:=r(x3,x4,x2,x1)$

     canonical aa; ==>  - r(x1,x2,x3,x4).
\end{verbatim}
If it contains dummy indices, {\tt CANONICAL} takes also into account the 
various dummy summations, makes the relevant simplifications, 
eventually rename the dummy indices  and returns the resulting normal form.
Here is a simple example:
\begin{verbatim}
    operator at1,at2;
    anticom at1,at2;

    dummy_names i,j,k; ==> t

    show_dummy_names(); ==> {i,j,k}

    rr:=at1(i)*at2(k) -at2(k)*at1(i)$
                     

    canonical rr; => 2*at1(i)*at2(j)
\end{verbatim}
It is important to notice, in the above example, that in addition to 
the summations over indices $i$ and $k$, and of the anticommutativity 
property of the operators, {\tt canonical} has replaced the index $k$
by the index $j$. This substitution is essential to get full simplification.
Several other examples are given in the test file and, there, the output
of {\tt CANONICAL} is explained.   

As stated in the previous section, the dependence of operators on dummy 
indices is limited to {\em first} level. An erroneous result
will be generated if it is not the case as the subsequent example 
illustrates:
\begin{verbatim}
    operator op;

    dummy_names i,j;

    rr:=op(i,op(j))-op(j,op(j))$

    canonical rr; ==> 0
\end{verbatim}
Zero is obtained because, in the second term, {\tt CANONICAL} has replaced 
$j$ by $i$ but has left $op(j)$ unchanged because it {\em does not see}
the index $j$ which is inside. This fact has also the consequence that 
it is unable to simplify correctly (or at all) expressions which 
contain some derivatives.
For instance ($i$ and $j$ are dummy indices):
\begin{verbatim}
    aa:=df(op(x,i),x) -df(op(x,j),x)$

    canonical aa; ==> df(op(x,i),x) - df(op(x,j),x)
\end{verbatim} 
instead of zero.
A second limitation is that {\tt CANONICAL} does not add anything to the
 problem of simplifications when side relations (like Bianchi identities) 
are present.
\section{Bibliography}
\begin{list}{-}{\parsep 0in \itemsep 1pt}     
\item\  {\bf Butler, G. and Lam, C. W. H.},
   ``A general backtrack algorithm for the isomorphism problem of
     combinatorial objects",
 J. Symb. Comput. vol.1, (1985) p.363-381.
\item\ {\bf Butler, G. and Cannon, J. J.},
    ``Computing in Permutation and Matrix Groups {I}: Normal Closure,
        Commutator Subgroups, Series",
 Math. Comp. vol.39, number 60, (1982), p. 663-670.
\item\ {\bf Butler, G.},
     ``Computing in Permutation and Matrix Groups {II}:
       Backtrack Algorithm",  Math. Comp. vol.39, number 160,
      (1982), p.671-680.
\item\  {\bf Leon, J.S.},
 ``On an Algorithm for Finding a Base and a Strong 
Generating Setfor a Group Given by Generating Permutations'',
Math. Comp. vol.35, (1980), p941-974.
\item\  {\bf Leon, J. S.},
 ``Computing Automorphism Groups of Combinatorial Objects'',
 Proc. {LMS} Symp. on Computational Group Theory, Durham,
                  England, editor: Atkinson, M. D.,
 Academic Press, London, (1984). 
\item\  {\bf Leon, J. S.},
``Permutation Group Algorithms Based on Partitions, {I}: Theory and
          Algorithms'', J.Symb. Comput.vol.12, (1991) p. 533-583.
\item\  {\bf Linton, Stephen Q.}, ``Double Coset Enumeration'',
        J. Symb. Comput., vol.12, (1991) p. 415-426.
\item\ {\bf McKay, B. D.},
``Computing Automorphism Groups and Canonical Labellings of Graphs'',
Proc. Internat. Conf. on Combinatorial Theory,
Lecture Notes in Mathematics`` vol. 686, (1977), p.223-232,
Springer-Verlag, Berlin.
\item\ {\bf Rodionov, A. Ya. and Taranov, A. Yu.},
``Combinatorial Aspects of Simplification of
Algebraic Expression'', Proceedings of Eurocal 87,
Lecture Notes in Comp. Sci., vol. 378,  (1989), p. 192.
\item\ {\bf Sims, C. C.},
``Determining the Conjugacy Classes of a Permutation Group'',
Computers in Algebra and Number Theory,
SIAM-AMS Proceedings, vol. 4, (1971), p. 191-195,
editor G. Birckhoff and M. {Hall Jr.}, Amer. Math. Soc..
\item\ {\bf Sims, C. C.},
``Computation with Permutation Groups'',
Proc. of the Second Symposium on Symbolic and Algebraic
                          Manipulation, (1971), p. 23-28,
editor S. R. Petrick, Assoc. Comput. Mach., New York.
\item\ {\bf   Burnel A., Caprasse H., Dresse A.},
`` Computing the BRST operator used in Quantization of Gauge Theories''
IJMPC vol. 3, (1993) p.321-35.
\item\ {\bf Caprasse H.},
``BRST charge and Poisson Algebras'',
Discrete Mathematics and Theoretical Computer Science,
Special Issue: Lie Computations papers, http://dmtcs.thomsonscience.com,
(1997).
\end{list}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/cantens.tst0000644000175000017500000002514711526203062024212 0ustar  giovannigiovanni% Test of CANTENS.RED
%
%     Authors: H. Caprasse 
%
% Version and Date:  Version 1.1, 15 September 1998.
%----------------------------------------------------------------
off errcont;
% Default : 
onespace ?;
wholespace_dim ?;  
global_sign ? ; 
signature ?; 
% answers to the 4 previous commands: yes, dim, 1, 0
wholespace_dim 4; 
signature 1;
global_sign(-1);
% answers to the three previous commands: 4, 1, (-1) 
% answer to the command below: {}
show_spaces();
% Several spaces:
off onespace;
onespace ?; 
% answer: no
show_spaces();
define_spaces wholespace={6,signature=1,indexrange=0 .. 5};
% indexrange command is superfluous since 'wholespace':
show_spaces();
rem_spaces wholespace;
define_spaces wholespace={11,signature=1}; 
define_spaces mink={4,signature=1,indexrange=0 .. 3}; 
define_spaces eucl={6,euclidian,indexrange=4 .. 9}; 
show_spaces();
%
% if input error or modifications necessary:
%
define_spaces eucl={7,euclidian,indexrange=4 .. 10};
%
% do:
%
rem_spaces eucl;
define_spaces eucl={7,euclidian,indexrange=4 .. 10};
show_spaces();
% done
%
define_spaces eucl1={1,euclidian,indexrange=11 .. 11}; 
show_spaces();
rem_spaces wholespace,mink,eucl,eucl1;
show_spaces();
%
% Indices can be made to belong to a subspace or replaced 
% in the whole space:
define_spaces eucl={3,euclidean};
show_spaces();
mk_ids_belong_space({a1,a2},eucl);
% a1,a2 belong to the subspace eucl.
mk_ids_belong_anyspace a1,a2;
% replaced in the whole space.
rem_spaces eucl;
%%  
%% GENERIC TENSORS:
on onespace;
wholespace_dim dim;
tensor te; 
te(3,a,-4,b,-c,7); 
te(3,a,{x,y},-4,b,-c,7);
te(3,a,-4,b,{u,v},-c,7);
te({x,y}); 
make_variables x,y;
te(x,y);
te(x,y,a); 
remove_variables x;
te(x,y,a);
remove_variables y;
%
% implicit dependence:
%
operator op2;
depend op1,op2(x);
df(op1,op2(x));
% the next response is 0:
df(op1,op2(y));
clear op2;
% case of a tensor: 
operator op1;
depend te,op1(x); 
df(te(a,-b),op1(x));
% next the outcome is 0:
df(te(a,-b),op1(y));
%
tensor x;
depend te,x;
% outcome is NOT 0:
df(te(a,-b),x(c));
%
% Substitutions:
sub(a=-c,te(a,b));
sub(a=-1,te(a,b)); 
% the following operation is wrong:
sub(a=-0,te(a,b));  
% should be made as following to be correct:
sub(a=-!0,te(a,b)); 
% dummy indices recognition
dummy_indices();
te(a,b,-c,-a);
dummy_indices();
te(a,b,-c,-a);
dummy_indices();
% hereunder an error message correctly occurs:
on errcont;
te(a,b,-c,a);
off errcont;
sub(c=b,te(a,b,-c,-a));
dummy_indices();
% dummy indices suppression:
on errcont;
te(d,-d,d);
off errcont;
dummy_indices();
rem_dummy_indices d;
te(d,d);
dummy_indices();
rem_dummy_indices a,b;
onespace ?;
% case of space of integer dimension:
wholespace_dim 4;
signature 0;
% 7 out of range
on errcont;
te(3,a,-b,7);
off errcont;
te(3,a,-b,3);
te(4,a,-b,4);
% an 'out-of-range' error is issued:
on errcont;
sub(a=5,te(3,a,-b,3));
off errcont;
signature 1;
% now indices should run from 0 to 3 => error: 
on errcont;
te(4,a,-b,4);
off errcont;
% correct:
te(0,a,-b,3);
%
off onespace;
define_spaces wholespace={4,euclidean};
% We MUST say that te BELONG TO A SPACE, here to wholespace:
make_tensor_belong_space(te,wholespace);
on errcont;
te(a,5,-b);
off errcont;
te(a,4,-b);
rem_spaces wholespace;
define_spaces wholespace={5,signature=1};
define_spaces eucl={1,signature=0};
show_spaces();
make_tensor_belong_space(te,eucl);
te(1);
% hereunder, an error message is issued: 
on errcont;
te(2);
off errcont;
% hereunder, an error message should be issued, it is not 
% because no indexrange has been declared:
te(0);
rem_spaces eucl;
define_spaces eucl={1,signature=0,indexrange=1 .. 1};
% NOW an error message is issued:
on errcont;
te(0);
off errcont;
te(1);
% again an error message:
on errcont;
te(2);
off errcont;
%
rem_dummy_indices a,b,c,d;
% symmetry properties:
%
symmetric te;
te(a,-b,c,d);
remsym te;
antisymmetric te;
te(a,b,-c,d);
remsym te;
% mixed symmetries:
tensor r;
% 
symtree(r,{!+,{!-,1,2},{!-,3,4}});
ra:=r(b,a,c,d)$ 
canonical ra; 
ra:=r(c,d,a,b)$
canonical ra;
% here canonical is short-cutted
ra:=r(b,b,c,a);
%
% symmetrization:
on onespace;
symmetrize(r(a,b,c,d),r,permutations,perm_sign);
canonical ws;
off onespace;
symmetrize({a,b,c,d},r,cyclicpermlist);
canonical ws;
rem_tensor r;
% Declared bloc-diagonal tensor:
rem_spaces wholespace,eucl;
define_spaces wholespace={7,signature=1};
define_spaces mink={4,signature=1,indexrange=0 .. 3};
define_spaces eucl={3,euclidian,indexrange=4 .. 6};
show_spaces();
make_tensor_belong_space(te,eucl);
make_bloc_diagonal te;
mk_ids_belong_space({a,b,c},eucl);
te(a,b,z);
mk_ids_belong_space({m1,m2},mink);
te(a,b,m1);
te(a,b,m2);
mk_ids_belong_anyspace a,b,c,m1,m2;
te(a,b,m2);
% how to ASSIGN a particular component ?
% take the simplest context: 
rem_spaces wholespace,mink,eucl;
on onespace;
te({x,y},a,-0)==x*y*te(a,-0); 
te({x,y},a,-0); 
te({x,y},a,0); 
% hereunder an error message  is issued because already assigned:
on errcont;
te({x,y},a,-0)==x*y*te(a,-0);
off errcont;
% clear value:
rem_value_tens te({x,y},a,-0);
te({x,y},a,-0); 
te({x,y},a,-0)==(x+y)*te(a,-0);
% A small illustration
te(1)==sin th * cos phi; 
te(-1)==sin th * cos phi;
te(2)==sin th * sin phi;
te(-2)==sin th * sin phi;
te(3)==cos th ;
te(-3)==cos th ;
for i:=1:3 sum te(i)*te(-i);
rem_value_tens te;
te(2);
let te({x,y},-0)=x*y;
te({x,y},-0);
te({x,y},0);
te({x,u},-0);
for all x,a let te({x},a,-b)=x*te(a,-b);
te({u},1,-b);
te({u},c,-b);
te({u},b,-b);
te({u},a,-a);
for all x,a clear te({x},a,-b);
te({u},c,-b);
% rule for indices only
for all a,b let te({x},a,-b)=x*te(a,-b);
te({x},c,-b);
te({x},a,-a);
% A BUG still exists for -0 i.e. rule does NOT apply:
te({x},a,-0);
% the cure is to use -!0 in this case
te({x},0,-!0);
%
% local rules: 
%
rul:={te(~a) => sin a};
te(1) where rul;
% 
rul1:={te(~a,{~x,~y}) => x*y*sin(a)}; 
%
te(a,{x,y}) where rul1;
te({x,y},a) where rul1;
%
rul2:={te(-~a,{~x,~y}) => x*y*sin(-a)};
% 
te(-a,{x,y}) where rul2; 
te({x,y},-a) where rul2;
%% CANONICAL 
%
% 1. Coherence of tensorial indices.
%
tensor te,tf; 
dummy_indices();
make_tensor_belong_anyspace te;
on errcont;
bb:=te(a,b)*te(-b)*te(b);
% hereunder an error message is issued:
canonical bb;
off errcont;
bb:=te(a,b)*te(-b);
% notice how it is rewritten by canonical:
canonical bb;
% 
dummy_indices();
aa:=te(d,-c)*tf(d,-c);
% if a and c are FREE no error message:
canonical aa;
% do NOT introduce powers for NON-INVARIANT tensors:
aa:=te(d,-c)*te(d,-c);
% Powers are taken away
canonical aa;
% A trace CANNOT be squared because powers are removed by 'canonical':
cc:=te(a,-a)^2$
canonical cc;
%
% Correct writing of the previous squared:
cc:=te(a,-a)*te(b,-b)$
canonical cc;
% all terms must have the same variance:
on errcont;
aa:=te(a,c)+x^2;
canonical aa;
aa:=te(a,b)+tf(a,c);
canonical aa;
off errcont;
dummy_indices();
rem_dummy_indices a,b,c;
dummy_indices();
% a dummy VARIABLE is NOT a dummy INDEX
dummy_names b;
dummy_indices();
% so, no error message in the following: 
canonical(te(b,c)*tf(b,c));
% it is an incorrect input for a variable.
% correct input is:
canonical(te({b},c)*tf({b},c));
clear_dummy_names;
% contravariant indices are placed before covariant ones if possible.
% i.e. Riemanian spaces by default: 
pp:=te(a,-a)+te(-a,a)+1; 
canonical pp;
pp:=te(a,-c)+te(-b,b,a,-c);
canonical pp;
pp:=te(r,a,-f,d,-a,f)+te(r,-b,-c,d,b,c);
canonical pp;
% here, a case where a normal form cannot be obtained:
tensor nt;
a1:=nt(-a,d)*nt(-c,a);
a2:=nt(-c,-a)*nt(a,d); 
% obviously, a1-a2 =0, but ....
canonical(a1-a2);
% does give the same expression with the sign changed.
% zero is either:
canonical a1 -a2;
% or
a1 -canonical a2;
% below the result is a2:
canonical a1;
% below result is a1 again: 
canonical ws;
%  the above manipulations are NOT DONE if space is AFFINE
off onespace;
define_spaces aff={dd,affine};
make_tensor_belong_space(te,aff); 
% dummy indices MUST be declared to belong 
% to a well defined space. here to 'aff':
mk_ids_belong_space({a,b},aff);
canonical(te(-a,a));
canonical(te(-a,a)+te(b,-b));
canonical(te(-a,c));
% put back  the system in the previous status: 
make_tensor_belong_anyspace te;
mk_ids_belong_anyspace a,b;
rem_spaces aff;
on onespace;
%
% 2. Summations with DELTA tensor.
%
make_partic_tens(delta,delta);
aa:=delta(a,-b)*delta(b,-c)*delta(c,-a) + 1;
% below, answer is dim+1:
canonical aa;
aa:=delta(a,-b)*delta(b,-c)*delta(c,-d)*te(d,e)$
canonical aa;
% 3. Summations with DELTA and ETA tensors.
make_partic_tens(eta,eta);
signature 1;
aa:=eta(a,b)*eta(-b,-c);
canonical aa;
aa:=eta(a,b)*eta(-b,-c)*eta(c,d);
canonical aa;
aa:=eta(a,b)*eta(-b,-c)*eta(d,c)*te(d,-a) +te(d,d);
canonical aa;
aa:=delta(a,-b)*eta(b,c);
canonical aa;
aa:=delta(a,-b)*delta(d,-a)*eta(-c,-d)*eta(b,c);
% below the answer is dim:
canonical aa;
aa:=delta(a,-b)*delta(d,-a)*eta(-d,-e)*te(f,g,e);
canonical aa;
% Summations with the addition of the METRIC tensor:
make_partic_tens(g,metric);
g(1,2,{x})==1/4*sin x;
g({x},1,2);
aa:=g(a,b)*g(-a,-c); 
canonical aa;
aa:=g(a,b)*g(c,d)*eta(-c,-b);
% answer is g(a,d):
canonical aa;
tensor te;
aa:=g(a,b)*g(c,d)*eta(-c,-e)*eta(e,f)*te(-f,g);
canonical aa;
% Summations with the addition of the EPSILON tensor.
dummy_indices();
rem_dummy_indices a,b,c,f;
dummy_indices();
wholespace_dim ?;
signature ?;
% define the generalized delta function:
make_partic_tens(gd,del);
make_partic_tens(epsilon,epsilon);
aa:=epsilon(a,b)*epsilon(-c,-d);
% Minus sign reflects the chosen signature.
canonical aa;
aa:=epsilon(a,b)*epsilon(-a,-b);
canonical aa;
aa:=epsilon(a,b,c,d)*epsilon(-a,-b,-c,-e);
canonical aa;
on exdelt;
% extract delta function down to the bottom:
aa:=epsilon(a,b,c)*epsilon(-b,-d,-e);
canonical aa;
off exdelt;
% below expressed in terms of 'gd' tensor.
canonical aa;
rem_dummy_indices a;
aa:=epsilon(- b,-c)*eta(a,b)*eta(a,c);
% answer below is zero:
canonical aa;
aa:=epsilon(a,b,c)*te(-a)*te(-b);
% below the result is again zero.
canonical aa;
%
tensor tf,tg;
aa:=epsilon(a,b,c)*te(-a)*tf(-b)*tg(-c)+epsilon(d,e,f)*te(-d)*tf(-e)*tg(-f);
% below the result is twice the first term.
canonical aa;
aa:=epsilon(a,b,c)*te(-a)*tf(-c)*tg(-b)+epsilon(d,e,f)*te(-d)*tf(-e)*tg(-f);
% below the result is zero.
canonical aa;
% An illustration when working inside several spaces. 
rem_dummy_indices a,b,c,d,e,f;
off onespace;
define_spaces wholespace={dim,signature=1};
define_spaces sub4={4,signature=1};
define_spaces subd={dim-4,signature=0};
show_spaces();
make_partic_tens(epsilon,epsilon);
make_tensor_belong_space(epsilon,sub4);
make_partic_tens(kappa,epsilon);
make_tensor_belong_space(kappa,subd);
show_epsilons();
mk_ids_belong_space({i,j,k,l,m,n,r,s},sub4);
mk_ids_belong_space({a,b,c,d,e,f},subd);
off exdelt;
aa:=kappa(a,b,c)*kappa(-d,-e,-f)*epsilon(i,j,k,l)*epsilon(-k,-l,-i,-j);
canonical aa;
aa:=kappa(a,b,c)*kappa(-d,-e,-f)*epsilon(i,j,k,l)*epsilon(-m,-n,-r,-s);
canonical aa;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/transfns.red0000644000175000017500000000523611526203062024352 0ustar  giovannigiovannimodule transfns;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

algebraic procedure trigexpand wws;
  wws where { sin(~x+~y) => sin(x)*cos(y)+cos(x)*sin(y),
              cos(~x+~y) => cos(x)*cos(y)-sin(x)*sin(y),
              sin((~n)*~x) => sin(x)*cos((n-1)*x)+cos(x)*sin((n-1)*x)
                   when fixp n and n>1,
              cos((~n)*~x) => cos(x)*cos((n-1)*x)-sin(x)*sin((n-1)*x)
                   when fixp n and n>1 };

algebraic procedure hypexpand wws;
  wws where {sinh(~x+~y) => sinh(x)*cosh(y)+cosh(x)*sinh(y),
             cosh(~x+~y) => cosh(x)*cosh(y)+sinh(x)*sinh(y),
           sinh((~n)*~x) => sinh(x)*cosh((n-1)*x)+cosh(x)*sinh((n-1)*x)
                   when fixp n and n>1,
           cosh((~n)*~x) => cosh(x)*cosh((n-1)*x)+sinh(x)*sinh((n-1)*x)
                   when fixp n and n>1 };

operator !#ei!&; !#ei!&(0):=1;

trig!#ei!& := {!#ei!&(~x)**(~n) => !#ei!&(n*x),
               !#ei!&(~x)*!#ei!&(~y) => !#ei!&(x+y)};

let trig!#ei!&;

algebraic procedure trigreduce wws;
        < (!#ei!&(x)+!#ei!&(-x))/2,
                           sin(~x) => -i*(!#ei!&(x)-!#ei!&(-x))/2});
          wws:=(wws where {!#ei!&(~x) => cos x +i*sin x})>>;

algebraic procedure hypreduce wws;
        < (!#ei!&(x)+!#ei!&(-x))/2,
                           sinh(~x) => (!#ei!&(x)-!#ei!&(-x))/2});
          wws:=(wws where {!#ei!&(~x) => cosh(x)+sinh(x)})>>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/auxitens.red0000644000175000017500000001370411526203062024353 0ustar  giovannigiovannimodule auxitens;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% this module introduces basic manipulation functions
% for handling indices and tensor structure

lisp remflag(list 'minus,'intfn);

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!*));

% g_dvnames is a vector.


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.


symbolic procedure raiseind!: u;
if atom u then u else raiseind u;

symbolic procedure lowerind_lst u;
% u is a list of indices.
% transforms into a list of covariant indices
for each j in u collect lowerind j;

symbolic procedure raiseind_lst u;
% u is a list of indices.
% transforms into a list of contravariant indices
for each j in u collect raiseind!: j;

symbolic procedure flatindxl u;
% This is taken from EXCALC
 for each j in u collect
   if atom j
     then j
     else if careq_minus(j)
            then cadr j
            else cdr j;

symbolic procedure cov_lst_idsp u;
% True if all indices in list u are covariant
 if null u then t
 else
 if careq_minus car u then cov_lst_idsp cdr u;

symbolic procedure cont_lst_idsp u;
% True if all indices in list u are contravariant
 if null u then t
 else
 if atom car u then cont_lst_idsp cdr u;

symbolic procedure identify_pos_cov_lst(u,i);
% allows to get the position of a fully covariant list
% u is a list of lists
% returns i which is the position of the FIRST relevant list in u.
% starting value of i is zero.
 if null u then
       if i=0 then nil
       else i-1
 else
 if cov_lst_idsp car u then i:=i+1
 else
 identify_pos_cov_lst(cdr u,i+1);

symbolic procedure identify_pos_cont_lst(u,i);
% allows to get the position of a fully contravariant list
% u is a list of lists
% returns i which is the position of the FIRST relevant list in u.
% starting value of i is zero.
 if null u then
      if i=0 then nil
      else i-1
 else
 if cont_lst_idsp car u then i:=i+1
 else
 identify_pos_cont_lst(cdr u,i+1);

symbolic procedure splitlist!: (u,idp);
% EXTRACTS THE SUBLIST OF ELEMENTS WHOSE CAR ARE EQUAL THE IDP.
% TAG.
% taken from my old tensor package.
  if null u then nil
  else
  if eqcar(car u,idp) then car u . splitlist!:(cdr u,idp)
  else splitlist!:(cdr u,idp);

symbolic procedure list_to_ids!: l;
if atom l then rederr "argument for list_to_ids must be a list"
else
intern compress for each i in l join explode i;


symbolic procedure split!:(u,v);
% split!:(list(a,b,c),list(1,1,1)); ==> {{A},{B},{C}}
% No longer used below but ...
if listp u and listp v then
 begin scalar x;
    return for each n in v collect
             for i := 1:n collect
                 <>
    end;


symbolic procedure symtree_splitlst(idtens,lsy,bool);
% idtens is the tensor indices argument list and lsy
% is cdr of symtree.
% output is the splitted indices list which mirrors lsy
% and make partial reordering whenever possible .
for each i in lsy collect
          if bool and car i memq {'!+,'!-} then
              ordn for each j in cdr i collect nth(idtens,j)
           else  for each j in cdr i collect nth(idtens,j);


symbolic procedure symtree_zerop (idtens,lsym);
% idtens is the list of indices of a given tensor.
% lsym is the symmetry tree list as generated by the
% 'symtree' operator of DUMMY.RED.
% pseudo-boolean: returns the set of indices which is repeated  or
% nil.
% It DOES detect MOST but NOT ALL possibilities leaving the rest for
% canonical.
 if null cdr lsym then nil
  else
 if numlis cdr lsym then
    if car lsym eq '!- and repeats idtens then repeats idtens
      else nil
  else
% here we start considering proper partial symmetries
   begin scalar lsy, idt,y;
     if car lsym eq  '!- then
       if (y := repeats symtree_splitlst(idtens,cdr lsym,nil))
             then return y;
    idt:= symtree_splitlst(idtens,cdr lsym,t);
    if car lsym eq '!- then
         if (y:=repeats idt) then return y;
   lsy:=for each j in cdr lsym collect car j;
    return partsym_zerop(idt,lsy)
   end;


symbolic procedure partsym_zerop(idt,lsy);
% idt: splitted list of indices
% lsy list of tags for partial symmetries.
% they should have the same lengths
 if null idt then nil
  else
 (if car lsy eq '!- and y then y
  else partsym_zerop(cdr idt,cdr lsy))where y=repeats car idt;


symbolic procedure cont_before_cov u;
% is a list of indices some are covariant
% others are contravariant
% returns a list with contravariant indices placed
% in front of the covariant indices.
 begin scalar x;
  x:=splitlist!:(u,'minus);
  return append(setdiff(u,x) ,x)
 end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/opertens.red0000644000175000017500000001670711526203062024360 0ustar  giovannigiovannimodule opertens;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module generalizes CANONICAL to make it active
% on expressions which are arguments of OPERATORS. The typical
% case, presently implemented, is when the expression is under
% the derivative df.
% A general  operator, to be treated as df must be endowed
% with a specific property which makes it "transparent" to canonical
% so that CANONICAL can see the argument(s) it contains, recognize  the
% (eventually explicitly declared) dummy indices these depend on
% and, finally, find their normal form.

switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

fluid '(opertensnewids!*);

symbolic procedure restorealldfs u;
begin scalar y,z,w;
 z:=fullcopy u;
 w:=z;
 l: if domainp z then return w
    else if (not atom mvar z) and (y:=get(car mvar z, 'Translate2))
       then mvar z:=apply1(car y,mvar z);
     z:= lc z;
     go to l;
end;

%symbolic procedure restorealldfs u;
%begin scalar y,z;
% z:=u;
% l: if domainp z then return u
%    else if (not atom mvar z) and (y:=get(car mvar z, 'Translate2))
%       then mvar z:=apply1(car y,mvar z);
%     z:= lc z;
%     go to l;
%end;

symbolic procedure clearallnewids;
% the ephemerous operators created by 'dftypetooper' must
% be eliminated after the normal form is found.
% This is done here.
<>;
  opertensnewids!*:=nil>>;

symbolic procedure dftypetooper(u);
% (df (g a) (n b) 2) as arg and gives back (df_g_n_2 a b)
% df_g_n_2 gets property (dfprop df (g 1) (n 1) 2)
% same occurs for dfpart if it is given the prop ('Transtocanonical 'dftypetooper)
% Declares the results as being a tensor if one of the args at least is tensor
begin scalar name,proplist,arglist,varlist,switchid,IsTens,spacel,z;
 name:=list(car u);
 proplist:= name;
 for each y in cdr u do
   << if listp y then
       << name:=car y . ('!_ . name);
          if flagp(car y,'tensor) then
            << IsTens:=t;
               if null !*onespace and null((z:=get(car y,'belong_to_space)) memq spacel)
                 then spacel:=z . spacel;
               if (listp cadr y) and ((caadr y) eq 'list ) then
                 << proplist:= list(car y, length cdr y - 1, length cadr y - 1) . proplist;
                    varlist:=append(varlist, cdadr y);
                    for each z in cddr y do
                      arglist:=<> . arglist ;>>
               else
                 << proplist:= list(car y, length cdr y) . proplist ;
                    for each z in cdr y do
                      arglist:= <> . arglist ;>>;  >>
          else
           << proplist:= list(car y,length cdr y) . proplist;
              varlist:=append(varlist,cdr y); >>;
        >>
      else
        << name:= y . ('!_ . name);
           proplist:= y . proplist ; >>;
      switchid:=t;
   >>;
 arglist:=reverse(arglist);
 proplist:=reverse(proplist);
 name:=list_to_ids!:(reverse name);
 if IsTens then
  << if flagp(name,'tensor)
       then
         << if get(name,'translate2) and ((cdr get(name,'translate2)) neq proplist) then
              rerror(cantens,13,"problem in number of arg") >>
       else
         <>;
     if varlist then arglist := ('list . varlist) . arglist >>
           else
  << if (get(name,'translate2)) and ( cdr get(name,'translate2) neq proplist) then
         rerror(cantens,13,"problem in number of arg")
       else
         <>  >>;
  return name . arglist;
end;

symbolic procedure opertodftype(u);
% u is an operator (df_g_n_2 a b) where df_g_n_2 has property
% (dfprop (g 1) (n 1) 2)
% gives back the df : (df (g a) (n b) 2)
begin scalar proplist,idslist,varlist,argres,name,i,switchid,y,idsl,varl;
  proplist:=cdr get(car u,'translate2);
  name:=car proplist;
  proplist:=cdr proplist;
  idslist:=cdr u;
  % get variables if there are some
  if ((listp car idslist) and (caar idslist eq 'list)) then
    <>;
  if flagp(car u,'tensor) then
    for each y in proplist do
      <>;
               idsl:=reverse idsl;
               if cddr y then
                 << varl:=nil;
                    for i:=1:caddr y do
                       << varl:= car varlist . varl;
                          varlist:=cdr varlist >>;
                    varl:=reverse varl;
                    argres:=((car y . ( ('list . varl) . idsl)) . argres) >>
               else argres:=((car y . idsl) . argres); >>
          else
           << varl:=nil;
              for i:=1:cadr y do
                << varl:=(car varlist) . varl;
                   varlist:=cdr varlist >>;
              varl:=reverse varl;
              argres:=(((car y) . varl) . argres)>>
        else argres:=y . argres;
        switchid:=t; >>
  else
    << for each y in proplist do
         if listp y then
           << varl:=nil;
              for i:=1:cadr y do
                << varl:=((car idslist) . varl);
                   idslist:=cdr idslist >>;
              varl:=reverse varl;
              argres:=(((car y) . varl) . argres)>>
         else argres:= y. argres; >>;
  return name . (reverse argres)
end;

symbolic procedure makedfperm;
  put('df,'Translate1,'dftypetooper);

flag ('(makedfperm), 'opfn);
deflist('((makedfperm endstat)),'stat);

makedfperm;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/assist.tst0000644000175000017500000002450211526203062024057 0ustar  giovannigiovanni% Test of Assist Package version 2.31.
% DATE : 30 August 1996
% Author: H. Caprasse 
%load_package assist$

Comment 2. HELP for ASSIST:;
;
assist();
;
assisthelp(7);
;
Comment 3. CONTROL OF SWITCHES:;
;
switches;
off exp; on gcd; off precise;
switches;
switchorg;
switches;
;
if !*mcd then "the switch mcd is on";
if !*gcd then "the switch gcd is on";
;
Comment 4. MANIPULATION OF THE LIST STRUCTURE:;
;
t1:=mklist(5);

Comment   MKLIST does NEVER destroy anything ;

mklist(t1,10);
mklist(t1,3);
;
sequences 3;
lisp;
sequences 3;
algebraic;
;
for i:=1:5 do t1:= (t1.i:=mkid(a,i));
t1;
;
t1.5;
;
t1:=(t1.3).t1;
;
% Notice the blank spaces ! in the following illustration: 
1 . t1;
;
% Splitting of a list:
split(t1,{1,2,3}); 
;
% It truncates the list :
split(t1,{3});
;
% A KERNEL may be coerced to a list:
kernlist sin x;
;
% algnlist constructs a list which contains n-times a given list 
algnlist(t1,2); 
;
% Delete :

delete(x, {a,b,x,f,x});
;
% delete_all eliminates ALL occurences of x: 
delete_all(x,{a,b,x,f,x});
;
remove(t1,4);
;
% delpair deletes a pair if it is possible.
delpair(a1,pair(t1,t1));
; 
elmult(a1,t1);
;
frequency append(t1,t1);
;
insert(a1,t1,3);
;
li:=list(1,2,5);
;
%  Not to destroy an already ordered list during insertion:
insert_keep_order(4,li,lessp);
insert_keep_order(bb,t1,ordp);
;
% the same function when appending two correctly ORDERED lists:
merge_list(li,li,<);
;
merge_list({5,2,1},{5,2,1},geq);
;
depth list t1;
;
depth a1;
% Any list can be flattened into a list of depth 1:
mkdepth_one {1,{{a,b,c}},{c,{{d,e}}}};
position(a2,t1);
appendn(li,li,li);
;
clear t1,li;
comment 5. THE BAG STRUCTURE AND OTHER FUNCTION FOR LISTS AND BAGS.
 ;
aa:=bag(x,1,"A");
putbag bg1,bg2;
on errcont;
putbag list;
off errcont;
aa:=bg1(x,y**2);
;
if bagp aa then "this is a bag";
;
% A bag is a composite object:
clearbag bg2;
;
depth bg2(x);
;
depth bg1(x);
;
if baglistp aa then "this is a bag or list";
if baglistp {x} then "this is a bag or list";
if bagp {x} then "this is a bag";
if bagp aa then "this is a bag";
;
ab:=bag(x1,x2,x3);
al:=list(y1,y2,y3);
% The basic lisp functions are also active for bags:
first ab;  third ab;  first al;
last ab; last al;
belast ab; belast al; belast {a,b,a,b,a};
rest ab; rest al;

;
% The "dot" plays the role of the function "part":
ab.1; al.3;
on errcont;
ab.4;
off errcont;
a.ab;
% ... but notice
1 . ab;
% Coercion from bag to list and list to bag:
kernlist(aa);
;
listbag(list x,bg1);
;
length ab;
;
remove(ab,3);
;
delete(y2,al);
;
reverse al;
;
member(x3,ab);
;
al:=list(x**2,x**2,y1,y2,y3);
;
elmult(x**2,al);
;
position(y3,al);
;
repfirst(xx,al);
;
represt(xx,ab);
;
insert(x,al,3);
insert( b,ab,2);
insert(ab,ab,1);
;
substitute (new,y1,al);
;
appendn(ab,ab,ab);
;
append(ab,al);
append(al,ab);
clear ab; a1;
;comment Association list or bag may be constructed and thoroughly used;
;
l:=list(a1,a2,a3,a4);
b:=bg1(x1,x2,x3);
al:=pair(list(1,2,3,4),l);
ab:=pair(bg1(1,2,3),b);
;
clear b;
comment : A BOOLEAN function abaglistp to test if it is an association;
;
if abaglistp bag(bag(1,2)) then "it is an associated bag";
;
% Values associated to the keys can be extracted
% first occurence ONLY.
;
asfirst(1,al);
asfirst(3,ab);
;
assecond(a1,al);
assecond(x3,ab);
;
aslast(z,list(list(x1,x2,x3),list(y1,y2,z)));
asrest(list(x2,x3),list(list(x1,x2,x3),list(y1,y2,z)));
;
clear a1;
;
% All occurences.
asflist(x,bg1(bg1(x,a1,a2),bg1(x,b1,b2)));
asslist(a1,list(list(x,a1),list(y,a1),list(x,y)));
restaslist(bag(a1,x),bg1(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));
restaslist(list(a1,x),bag(bag(x,a1,a2),bag(a1,x,b2),bag(x,y,z)));
;
Comment 6. SETS AND THEIR MANIPULATION FUNCTIONS
;
ts:=mkset list(a1,a1,a,2,2);
if setp ts then "this is a SET";
;
union(ts,ts);
;
diffset(ts,list(a1,a));
diffset(list(a1,a),ts);
;
symdiff(ts,ts);
;
intersect(listbag(ts,set1),listbag(ts,set2));


Comment 7. GENERAL PURPOSE UTILITY FUNCTIONS :;
;
clear a1,a2,a3,a,x,y,z,x1,x2,op$
;
% DETECTION OF A GIVEN VARIABLE IN A GIVEN SET
;
mkidnew();
mkidnew(a);
;
dellastdigit 23;
;
detidnum aa;
detidnum a10;
detidnum a1b2z34;
;
list_to_ids list(a,1,rr,22);
;
if oddp 3 then "this is an odd integer";
;
<>;
;
operator foo;
foo(x):=x;
foo(x)==value;

x; 	% it is equal to value

clear x;
;
randomlist(10,20);
% Generation of tables of random numbers:
% One dimensional:
mkrandtabl({4},10,ar);
array_to_list ar;
;
% Two dimensional:
mkrandtabl({3,4},10,ar);
array_to_list ar; 
;
% With a base which is a decimal number:
on rounded;
mkrandtabl({5},3.5,ar);
array_to_list ar;
off rounded;
;
% Combinatorial functions :
permutations(bag(a1,a2,a3));
permutations {1,2,3};
;
cyclicpermlist{1,2,3};
;
combnum(8,3);
;
combinations({1,2,3},2);
;
perm_to_num({3,2,1,4},{1,2,3,4});
num_to_perm(5,{1,2,3,4});
;
operator op;
symmetric op;
op(x,y)-op(y,x);
remsym op;
op(x,y)-op(y,x);
;
labc:={a,b,c};
symmetrize(labc,foo,cyclicpermlist);
symmetrize(labc,list,permutations);
symmetrize({labc},foo,cyclicpermlist);
;
extremum({1,2,3},lessp);
extremum({1,2,3},geq);
extremum({a,b,c},nordp);
;
funcvar(x+y);
funcvar(sin log(x+y));
funcvar(sin pi);
funcvar(x+e+i);
funcvar sin(x+i*y);
;
operator op;
noncom op;
op(0)*op(x)-op(x)*op(0);
remnoncom op;
op(0)*op(x)-op(x)*op(0);
clear op;
;
depatom a;
depend a,x,y;
depatom a;
;
depend op,x,y,z;
;
implicit op;
explicit op;
depend y,zz;
explicit op;
aa:=implicit op;
clear op;
;
korder x,z,y;
korderlist;
;
if checkproplist({1,2,3},fixp) then "it is a list of integers";
;
if checkproplist({a,b1,c},idp) then "it is a list of identifiers";
;
if checkproplist({1,b1,c},idp) then "it is a list of identifiers";
;
lmix:={1,1/2,a,"st"};
;
extractlist(lmix,fixp);
extractlist(lmix,numberp);
extractlist(lmix,idp);
extractlist(lmix,stringp);
;
% From a list to an array:
list_to_array({a,b,c,d},1,ar);
array_to_list ar;  
list_to_array({{a},{b},{c},{d}},2,ar);
;
comment 8. PROPERTIES AND FLAGS:;
;
putflag(list(a1,a2),fl1,t);
putflag(list(a1,a2),fl2,t);
displayflag a1;
;
clearflag a1,a2;
displayflag a2;
putprop(x1,propname,value,t);
displayprop(x1,prop);
displayprop(x1,propname);
;
putprop(x1,propname,value,0);
displayprop(x1,propname);
;
Comment 9. CONTROL FUNCTIONS:;
;
alatomp z;
z:=s1;
alatomp z;
;
alkernp z;
alkernp log sin r;
;
precp(difference,plus);
precp(plus,difference);
precp(times,.);
precp(.,times);
;
if stringp x then "this is a string";
if stringp "this is a string" then "this is a string";
;
if nordp(b,a) then "a is ordered before b";
operator op;
for all x,y such that nordp(x,y) let op(x,y)=x+y;
op(a,a);
op(b,a);
op(a,b);
clear op;
;
depvarp(log(sin(x+cos(1/acos rr))),rr);
;
clear y,x,u,v;
clear op;
;
% DISPLAY and CLEARING of user's objects of various types entered
% to the console. Only TOP LEVEL assignments are considered up to now.
% The following statements must be made INTERACTIVELY. We put them
% as COMMENTS for the user to experiment with them. We do this because
% in a fresh environment all outputs are nil.
;
% THIS PART OF THE TEST SHOULD BE REALIZED INTERACTIVELY.
% SEE THE ** ASSIST LOG **  FILE .
%v1:=v2:=1;
%show scalars;
%aa:=list(a);
%show lists;
%array ar(2);
%show arrays;
%load matr$
%matrix mm;
%show matrices;
%x**2;
%saveas res;
%show saveids;
%suppress scalars;
%show scalars;
%show lists;
%suppress all;
%show arrays;
%show matrices;
;
comment end of the interactive part;
;
clear op;
operator op;
op(x,y,z);
clearop op;
;
clearfunctions abs,tan;
;
comment  THIS FUNCTION MUST BE USED WITH CARE !!!!!;
;
Comment 10. HANDLING OF POLYNOMIALS

clear x,y,z;
COMMENT  To see the internal representation :;
;
off pri;
;
pol:=(x-2*y+3*z**2-1)**3;
;
pold:=distribute pol;
;
on distribute;
leadterm (pold);
pold:=redexpr pold;
leadterm pold;
;
off distribute;
polp:=pol$
leadterm polp;
polp:=redexpr polp;
leadterm polp;
;
monom polp;
;
on pri;
;
splitterms polp;
;
splitplusminus polp;
;
divpol(pol,x+2*y+3*z**2);
;
lowestdeg(pol,y);
;
Comment 11.  HANDLING OF SOME TRANSCENDENTAL FUNCTIONS:;
;
trig:=((sin x)**2+(cos x)**2)**4;
trigreduce trig;
trig:=sin (5x);
trigexpand trig;
trigreduce ws;
trigexpand sin(x+y+z);
;
;
hypreduce (sinh x **2 -cosh x **2);
;
;
clear a,b,c,d;
;

Comment 13. HANDLING OF N-DIMENSIONAL VECTORS:;
;
clear u1,u2,v1,v2,v3,v4,w3,w4;
u1:=list(v1,v2,v3,v4);
u2:=bag(w1,w2,w3,w4);
%
sumvect(u1,u2);
minvect(u2,u1);
scalvect(u1,u2);
crossvect(rest u1,rest u2);
mpvect(rest u1,rest u2, minvect(rest u1,rest u2));
scalvect(crossvect(rest u1,rest u2),minvect(rest u1,rest u2));
;
Comment 14. HANDLING OF GRASSMANN OPERATORS:;
;
putgrass eta,eta1;
grasskernel:=
{eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
(~x)*(~x) => 0 when grassp x};
;
eta(y)*eta(x);
eta(y)*eta(x) where grasskernel;
let grasskernel;
eta(x)^2;
eta(y)*eta(x);
operator zz;
grassparity (eta(x)*zz(y));
grassparity (eta(x)*eta(y));
grassparity(eta(x)+zz(y));
clearrules grasskernel;
grasskernel:=
{eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
eta1(~x)*eta(~y) => -eta x * eta1 y,
eta1(~x)*eta1(~y) => -eta1 y * eta1 x when nordp(x,y),
(~x)*(~x) => 0 when grassp x};
;
let grasskernel;
eta1(x)*eta(x)*eta1(z)*eta1(w);
clearrules grasskernel;
remgrass eta,eta1;
clearop zz;
;
Comment  15. HANDLING OF MATRICES:;
;
clear m,mm,b,b1,bb,cc,a,b,c,d,a1,a2;
load_package matrix;
baglmat(bag(bag(a1,a2)),m);
m;
on errcont;
;
baglmat(bag(bag(a1),bag(a2)),m);
off errcont;
%    **** i.e. it cannot redefine the matrix! in order
%         to avoid accidental redefinition of an already given matrix;

clear m; baglmat(bag(bag(a1),bag(a2)),m);
m;
on errcont;
baglmat(bag(bag(a1),bag(a2)),bag);
off errcont;
comment  Right since a bag-like object cannot become a matrix.;
;
coercemat(m,op);
coercemat(m,list);
;
on nero;
unitmat b1(2);
matrix b(2,2);
b:=mat((r1,r2),(s1,s2));
b1;b;
mkidm(b,1);
;
seteltmat(b,newelt,2,2);
geteltmat(b,2,1);
%
b:=matsubr(b,bag(1,2),2);
;
submat(b,1,2);
;
bb:=mat((1+i,-i),(-1+i,-i));
cc:=matsubc(bb,bag(1,2),2);
;
cc:=tp matsubc(bb,bag(1,2),2);
matextr(bb, bag,1);
;
matextc(bb,list,2);
;
hconcmat(bb,cc);
vconcmat(bb,cc);
;
tpmat(bb,bb);
bb tpmat bb;
;
clear hbb;
hermat(bb,hbb);
% id hbb changed to a matrix id and assigned to the hermitian matrix
% of bb.
;
load_package HEPHYS;

% Use of remvector.
;
vector v1,v2;
v1.v2;
remvector v1,v2;
on errcont;
v1.v2;
off errcont;
% To see the compatibility with ASSIST:
v1.{v2};
;
index u; vector v;
(v.u)^2;
remindex u;
(v.u)^2;
;
% Gamma matrices properties may be translated to any identifier:
clear l,v;
vector v;
g(l,v,v);
mkgam(op,t);
op(l,v,v);
mkgam(g,0);
operator g;
g(l,v,v);
;
clear g,op;
;
% showtime;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/assist.hlp0000644000175000017500000012157311526203062024036 0ustar  giovannigiovanni\chapter{ASSIST: Various Useful Utilities}
\label{ASSIST}
\typeout{{ASSIST: Various Useful Utilities}}

{\footnotesize
\begin{center}
Hubert Caprasse \\
D\'epartement d'Astronomie et d'Astrophysique \\
Institut de Physique, B--5, Sart Tilman \\
B--4000 LIEGE 1, Belgium\\[0.05in]
e--mail: caprasse@vm1.ulg.ac.be
\end{center}
}

The {\tt ASSIST}\ttindex{ASSIST} package provides a number of general
purpose functions which adapt \REDUCE\ to various
calculational strategies.  All the examples in this section require
the {\tt ASSIST} package to be loaded.

\section{Control of Switches}
The two functions \f{SWITCHES, SWITCHORG}
\ttindex{SWITCHES}\ttindex{SWITCHORG} have no argument and are called
as if they were mere identifiers.

\f{SWITCHES} displays the current status of the most often used switches
when manipulating rational functions; 
{\tt EXP}, {\tt DIV}, {\tt MCD}, {\tt GCD}, {\tt ALLFAC}, {\tt
INTSTR}, {\tt RAT}, {\tt RATIONAL}, {\tt FACTOR}.
The switch {\tt DISTRIBUTE} which controls the handling
of distributed polynomials is included as well (see section~\ref{DISTRIBUTE}).

\f{SWITCHORG} resets (almost) {\em all} switches in the status they
have when {\bf entering} into \REDUCE. (See also {\tt RESET},
chapter~\ref{RESET}\ttindex{RESET}).  The new switch {\tt DISTRIBUTE}
facilitates changing polynomials to a distributed form.

\section{Manipulation of the List Structure}

Functions for list manipulation are provided and are generalised
to deal with the new structure {\tt BAG}.
\begin{itemize}
\item[i.]
Generation of a list of length $n$ with its elements initialised to 0
and also to append to a list $l$ sufficient zeros to
make it of length $n$:\ttindex{MKLIST}
\begin{verbatim}
        MKLIST n;          %% n is an INTEGER
        MKLIST(l,n);       %% l is List-like, n is an INTEGER
\end{verbatim}

\item[ii.]
Generation of a list of sublists of length $n$ containing $p$ elements
equal to $0$ and $n-p$ elements equal to $1$.
\begin{verbatim}
        SEQUENCES 2; ==> {{0,0},{0,1},{1,0},{1,1}}
\end{verbatim}
The function \f{KERNLIST}\ttindex{KERNLIST} transforms any prefix of
a kernel into the {\bf \verb+list+} prefix.  The output list is a copy:
\begin{verbatim}
        KERNLIST (); ==> {}
\end{verbatim}
There are four functions to delete elements from lists.  The
\f{DELETE} function deletes the first occurrence of its first argument
from the second, while \f{REMOVE} removes a numbered element.
\f{DELETE\_ALL} eliminates from a list {\em all} elements equal to its
first argument.  \f{DELPAIR} acts on list of pairs and eliminates from
it the {\em first} pair whose first element is equal to its first
argument:\ttindex{DELETE}\ttindex{REMOVE}\ttindex{DELETE\_ALL}\ttindex{DELPAIR}
\begin{verbatim}
        DELETE(x,{a,b,x,f,x}); ==> {a,b,f,x}
        REMOVE({a,b,x,f,x},3); ==> {a,b,f,x}
        DELETE_ALL(x,{a,b,x,f,x}); ==> {a,b,f}
        DELPAIR(a,{{a,1},{b,2},{c,3}}; ==> {{b,2},{c,3}}
\end{verbatim}
\item[iv.]
The function \f{ELMULT}\ttindex{ELMULT} returns an {\em integer} which is the
{\em multiplicity} of its first argument in the list which is its
second argument.
The function \f{FREQUENCY}\ttindex{FREQUENCY} gives a list of pairs
whose second element indicates the number of times the first element
appears inside the original list:
\begin{verbatim}
        ELMULT(x,{a,b,x,f,x}) ==> 2
        FREQUENCY({a,b,c,a}); ==> {{a,2},{b,1},{c,1}}
\end{verbatim}
\item[v.]  The function \f{INSERT}\ttindex{INSERT} inserts a
given object into a list at the wanted position.  The functions
\f{INSERT\_KEEP\_ORDER}\ttindex{INSERT\_KEEP\_ORDER} and
\f{MERGE\_LIST}\ttindex{MERGE\_LIST} keep a given ordering when
inserting one element inside a list or when merging two lists. Both
have 3 arguments.  The last one is the name of a binary boolean
ordering function: 
\begin{verbatim}
        ll:={1,2,3}$
        INSERT(x,ll,3); ==> {1,2,x,3}
        INSERT_KEEP_ORDER(5,ll,lessp); ==> {1,2,3,5}
        MERGE_LIST(ll,ll,lessp); ==> {1,1,2,2,3,3}
\end{verbatim}
\item[vi.]
Algebraic lists can be read from right to left or left to right.
They {\em look} symmetrical.  It is sometimes convenient to have 
functions which reflect this.  So, as well as \f{FIRST} and \f{REST}
this package provides the functions \f{LAST}\ttindex{LAST} and
\f{BELAST}\ttindex{BELAST}. \f{LAST} gives the last element of the
list while \f{BELAST} gives the list {\em without} its last element. \\
Various additional functions are provided. They are:
\f{CONS}, \f{(.)}, \f{POSITION}, \f{DEPTH}, \f{PAIR}, \f{APPENDN},
\f{REPFIRST}, \f{REPLAST} 
\ttindex{CONS}\ttindex{.}\ttindex{POSITION}\ttindex{DEPTH}
\ttindex{PAIR}\ttindex{APPENDN}\ttindex{REPLAST}\ttindex{REPLAST}
The token ``dot'' needs a special comment. It corresponds to
several different operations.
\begin{enumerate}
\item If one applies it on the left of a list, it acts as the \f{CONS}
function.  Note however that blank spaces are required around the dot:
\begin{verbatim}
        4 . {a,b}; ==> {4,a,b}
\end{verbatim}
\item If one applies it on the right of a list, it has the same
effect as the \f{PART} operator:
\begin{verbatim}
         {a,b,c}.2; ==> b
\end{verbatim}
\item If one applies it on 4--dimensional vectors, it acts as in the
HEPHYS package (chapter~\ref{HEPHYS}
\end{enumerate}
\f{POSITION} returns the position of the first occurrence of x in
a list or a message if x is not present in it.
\f{DEPTH} returns an {\em integer} equal to the number of levels where
a list is found if and only if this number is the {\em same} for each
element of the list otherwise it returns a message telling the user
that list is of {\em unequal depth}.
\f{PAIR} has two arguments which must be lists. It returns a list
whose elements are {\em lists of two elements.}  The $n^{th}$ sublist
contains the $n^{th}$ element of the first list and the $n^{th}$
element of the second list. These types of lists are called {\em
association lists} or ALISTS in the following.
\f{APPENDN} has {\em any} number of lists as arguments, and appends
them all.
\f{REPFIRST} has two arguments. The first one is any object, the
second one is a list. It replaces the first element of the list by the
object.
\f{REPREST} has also two arguments. It replaces the rest of the list
by its first argument and returns the new list without destroying the
original list.
\begin{verbatim}
        ll:={{a,b}}$
        ll1:=ll.1;                 ==> {a,b}
        ll.0;                      ==> list
        0 . ll;                    ==> {0,{a,b}}
        DEPTH ll;                  ==> 2
        PAIR(ll1,ll1);             ==> {{a,a},{b,b}}
        REPFIRST{new,ll);          ==> {new}
        ll3:=APPENDN(ll1,ll1,ll1); ==> {a,b,a,b,a,b}
        POSITION(b,ll3);           ==> 2
        REPREST(new,ll3);          ==> {a,new}
\end{verbatim}
\item[vii.]
The functions \f{ASFIRST}\ttindex{ASFIRST},
\f{ASLAST}\ttindex{ASLAST}, \f{ASREST}\ttindex{ASREST},
\f{ASFLIST}\ttindex{ASFLIST}, \f{ASSLIST}\ttindex{ASSLIST},
\f{RESTASLIST}\ttindex{RESTASLIST}
act on ALISTS or on list of lists of well defined depths
and have two arguments. The first is the key object
which one seeks to associate in some way to an element of the association
list which is the second argument.  \f{ASFIRST} returns the pair whose
first element is equal to the first argument.  \f{ASLAST} returns the
pair whose last element is equal to the first argument.  \f{ASREST}
needs a {\em list} as its first argument.  The function seeks the first
sublist of a list of lists (which is its second argument) 
equal to its first argument and returns it.
\f{RESTASLIST} has a {\em list of keys} as its first arguments.  It
returns the collection of pairs which meet the criterion of \f{ASREST}.
\f{ASFLIST} returns a list containing {\em all pairs} which
satisfy to the criteria of the function \f{ASFIRST}. So the output
is also an ALIST or a list of lists.
\f{ASSLIST} returns a list which contains {\em all pairs} which have
their second element equal to the first argument.
\begin{verbatim}
        lp:={{a,1},{b,2},{c,3}}$
        ASFIRST(a,lp);             ==> {a,1}
        ASLAST(1,lp);              ==> {a,1}
        ASREST({1},lp);            ==> {a,1}
        RESTASLIST({a,b},lp);      ==> {{1},{2}}
        lpp:=APPEND(lp,lp)$
        ASFLIST(a,lpp);            ==> {{a,1},{a,1}}
        ASSLIST(1,lpp);            ==> {{a,1},{a,1}}
\end{verbatim}
\end{itemize}

\section{The Bag Structure and its Associated Functions}
The LIST structure of \REDUCE\ is very convenient for manipulating
groups of objects which are, {\em a priori}, unknown. This structure is
endowed with other properties such as ``mapping'' {\em i.e.\ }the fact
that if \verb+OP+ is an operator one gets, by default,
\begin{verbatim}
        OP({x,y}); ==> {OP(x),OP(y)}
\end{verbatim}
It is not permitted to submit lists to the operations valid on rings
so that lists cannot be indeterminates of polynomials.  Frequently
procedure arguments cannot be lists. 
At the other extreme, so to say, one has the \verb+KERNEL+
structure associated
to the algebraic declaration \verb+operator+.  This structure behaves as
an ``unbreakable'' one and, for that reason, behaves
like an ordinary identifier.
It may generally be bound to all non-numeric procedure parameters
and it may appear
as an ordinary indeterminate inside polynomials. \\
The \verb+BAG+ structure is intermediate between a list and an operator.
From the operator it borrows the property to be a \verb+KERNEL+ and,
therefore, may be an indeterminate of a polynomial. From the list structure
it borrows the property to be a {\em composite} object.\\[5pt]
\mbox{\underline{{\bf Definition}:\hfill}}\\[4pt]
A bag is an object endowed with the following properties:
\begin{enumerate}
\item It is a \verb+KERNEL+ composed of an atomic prefix (its
envelope) and
its content (miscellaneous objects).
\item Its content may be changed in an analogous way as the content of a
list. During these manipulations the name of the bag is {\em conserved}.
\item Properties may be given to the envelope. For instance, one may
declare it \verb+NONCOM+ or \verb+SYMMETRIC+ etc.\ $\ldots$
\end{enumerate}
\vspace{5pt}
\mbox{\underline{{\bf Available Functions}:\hfill}}
\begin{itemize}
\item[i.] A default bag envelope \verb+BAG+\index{BAG} is defined.
It is a reserved identifier.
An identifier other than \verb+LIST+ or one which is already associated
with a boolean function may be defined as a bag envelope through the
command \f{PUTBAG}\ttindex{PUTBAG}.  In particular, any operator may
also be declared  to be a bag. {\bf When and only when} the identifier
is not an already defined function does \f{PUTBAG} puts on it the
property of an OPERATOR PREFIX. 
The command:
\begin{verbatim}
        PUTBAG id1,id2,....idn;
\end{verbatim}
declares \verb+id1,.....,idn+ as bag envelopes.
Analogously, the command\ttindex{CLEARBAG}
\begin{verbatim}
        CLEARBAG id1,...idn;
\end{verbatim}
eliminates the bag property on \verb+id1,...,idn+.
\item[ii.] The boolean function \f{BAGP}\ttindex{BAGP} detects the bag
property. 
\begin{verbatim}
        aa:=bag(x,y,z)$
        if BAGP aa then "ok";     ==> ok
\end{verbatim}
\item[iii.] Most functions defined above for lists do also work for
bags. 
Moreover functions subsequently defined for SETS (see
section~\ref{A-SETS}) also work.
However, because of the conservation of the envelope, they act
somewhat differently. 
\begin{verbatim}
        PUTBAG op;            ==> T
        aa:=op(x,y,z)$
        FIRST op(x,y,z);      ==> op(x)
        REST op(x,y,z);       ==> op(y,z)
        BELAST op(x,y,z);     ==> op(x,y)
        APPEND(aa,aa);        ==> op(x,y,z,x,y,z)
        LENGTH aa;            ==> 3
        DEPTH aa;             ==> 1
\end{verbatim}
When ``appending'' two bags with {\em different} envelopes, the
resulting bag gets the name of the one bound to the first parameter of
\f{APPEND}.
The function \f{LENGTH} gives the actual number of variables on which
the operator (or the function) depends.
The NAME of the ENVELOPE is kept by the functions \f{FIRST},
\f{SECOND}, \f{LAST} and \f{BELAST}.
\item[iv.]
The connection between the list and the bag structures is made easy
thanks to \f{KERNLIST} which transforms a bag into a list and thanks to
the coercion function \f{LISTBAG}\ttindex{LISTBAG}. This function has
2 arguments and is used as follows:
\begin{verbatim}
        LISTBAG(,); ==> ()
\end{verbatim}
The identifier \verb++ if allowed is automatically declared as a bag
envelope or an error message is generated.

Finally, two boolean functions which work both for bags and lists are
provided. They are \f{BAGLISTP}\ttindex{BAGLISTP} and
\f{ABAGLISTP}\ttindex{ABAGLISTP}. 
They return T or NIL (in a conditional statement) if their argument
is a bag or a list for the first one, if their argument is a list of
sublists or a bag containing bags for the second one.
\end{itemize}

\section{Sets and their Manipulation Functions}
\label{A-SETS}

The ASSIST package makes the Standard LISP set functions available in
algebraic mode and also {\em generalises} them so that they can be
applied on bag--like objects as well. 
\begin{itemize}
\item[i.]
The constructor \f{MKSET}\ttindex{MKSET} transforms a list or bag into
a set by eliminating duplicates.
\begin{verbatim}
        MKSET({1,a,a1});      ==> {1,a}
        MKSET bag(1,a,a1);    ==> bag(1,a)
\end{verbatim}

\f{SETP}\ttindex{SETP} is a boolean function which recognises
set--like objects. 
\item[ii.]
The standard functions are \f{UNION}\ttindex{UNION},
\f{INTERSECT}\ttindex{INTERSECT}, \f{DIFFSET}\ttindex{DIFFSET}
and \f{SYMDIFF}\ttindex{SYMDIFF}. 
They have two arguments which must be sets;  otherwise an error message
is issued.
\end{itemize}

\section{General Purpose Utility Functions}

\begin{itemize}
\item[i.]
The functions \f{MKIDNEW}\ttindex{MKIDNEW},
\f{DELLASTDIGIT}\ttindex{DELLASTDIGIT},
\f{DETIDNUM}\ttindex{DETIDNUM}, 
\f{LIST\_TO\_IDS}\ttindex{LIST\_TO\_IDS} 
handle identifiers. \f{MKIDNEW}\ttindex{MKIDNEW} is a variant of \f{MKID}.

\f{MKIDNEW} has either 0 or 1 argument. It generates an identifier which
has not yet been used before.
\begin{verbatim}
        MKIDNEW(); ==> g0001
        MKIDNEW(a); ==> ag0002
\end{verbatim}
\f{DELLASTDIGIT} takes an integer as argument, it strips it from its last
digit.
\begin{verbatim}
        DELLASTDIGIT 45; ==> 4
\end{verbatim}
\f{DETIDNUM}, determines the trailing integer from an identifier.  It is
convenient when one wants to make a do loop starting from a set of
indices $ a_1, \ldots , a_{n} $.
\begin{verbatim}
        DETIDNUM a23; ==> 23
\end{verbatim}

\f{LIST\_to\_IDS} generalises the function \f{MKID} to a list of
atoms. It creates and interns an identifier from the concatenation of
the atoms. The first atom cannot be an integer.
\begin{verbatim}
        LIST_TO_IDS {a,1,id,10}; ==> a1id10
\end{verbatim}
The function \f{ODDP}\ttindex{ODDP} detects odd integers.

The function \f{FOLLOWLINE}\ttindex{FOLLOWLINE} is convenient when
using the function \f{PRIN2} for controlling layout. 
\begin{verbatim}
        <>$
25
        <>$
2
   5
\end{verbatim}

The function \f{RANDOMLIST}\ttindex{RANDOMLIST} generates a list of
positive random numbers.  It takes 
two arguments which are both integers. The first one indicates the range
inside which the random numbers are chosen. The second one indicates how
many numbers are to be generated.
\begin{verbatim}
        RANDOMLIST(10,5); ==> {2,1,3,9,6}
\end{verbatim}
\f{MKRANDTABL}\ttindex{MKRANDTABL} generates a table of random
numbers. This table is either 
a one or two dimensional array.  The base of random numbers may be either
an integer or a floating point number. In this latter case
the switch \f{rounded} must be ON.  The function has three
arguments. The first is either a one integer or a two integer
list. The second is the base chosen to generate the random
numbers. The third is the chosen name for the generated array.  In the
example below a two-dimensional table of integer random numbers is
generated as array elements of the identifier {\f ar}. 
\begin{verbatim}
        MKRANDTABL({3,4},10,ar); ==>
               *** array ar redefined
                      {3,4}
\end{verbatim}
The output is the array dimension.

\f{COMBNUM(n,p)}\ttindex{COMBNUM} gives the number of combinations of
$n$ objects taken $p$ at a time. It has the two integer arguments $n$
and $p$. 

\f{PERMUTATIONS(n)}\ttindex{PERMUTATIONS} gives the list of permutations
on $n$ objects, each permutation being represented as a list.
\f{CYCLICPERMLIST}\ttindex{CYCLICPERMLIST} gives the list of 
{\em cyclic} permutations.  For both functions, the argument may
also be a {\tt bag}.
\begin{verbatim}
        PERMUTATIONS {1,2} ==> {{1,2},{2,1}}
        CYCLICPERMLIST {1,2,3} ==>
                {{1,2,3},{2,3,1},{3,1,2}}
\end{verbatim}
\f{COMBINATIONS}\ttindex{COMBINATIONS} gives a list of combinations on
$n$ objects taken $p$ at a time. The first argument is a
list (or a bag) and the second is the integer $p$.
\begin{verbatim}
        COMBINATIONS({1,2,3},2) ==> {{2,3},{1,3},{1,2}}
\end{verbatim}
\f{REMSYM}\ttindex{REMSYM} is a command that erases the \REDUCE\ commands
{\tt symmetric} or {\tt antisymmetric}.

\f{SYMMETRIZE}\ttindex{SYMMETRIZE} is a powerful function which
generate a symmetric expression.
It has 3 arguments. The first is a list (or a list of lists) containing
the expressions which will appear as variables for a kernel. The second
argument is the kernel-name and the third is a permutation function
which either exist in the algebraic or in the symbolic mode.  This
function may have been constructed by the user.  Within this package
the two functions \f{PERMUTATIONS} and \f{CYCLICPERMLIST} may be used.
\begin{verbatim}
        ll:={a,b,c}$
        SYMMETRIZE(ll,op,cyclicpermlist); ==>
                OP(A,B,C) + OP(B,C,A) + OP(C,A,B)
        SYMMETRIZE(list ll,op,cyclicpermlist); ==>
                OP({A,B,C}) + OP({B,C,A}) + OP({C,A,B})
\end{verbatim}
Notice that taking for the first argument a list of lists gives rise to
an expression where  each kernel has a {\em list as argument}.  Another
peculiarity of this function is that, unless a pattern matching is
made on the operator \verb+OP+, it needs to be reevaluated.  Here is
an illustration: 
\begin{verbatim}
        op(a,b,c):=a*b*c$
        SYMMETRIZE(ll,op,cyclicpermlist); ==>
                 OP(A,B,C) + OP(B,C,A) + OP(C,A,B)
        for all x let op(x,a,b)=sin(x*a*b);
        SYMMETRIZE(ll,op,cyclicpermlist); ==>
                  OP(B,C,A) + SIN(A*B*C) + OP(A,B,C)
\end{verbatim}
The functions \f{SORTNUMLIST}\ttindex{SORTNUMLIST} and
\f{SORTLIST}\ttindex{SORTLIST} are functions which sort 
lists.  They use {\em bubblesort} and {\em quicksort} algorithms.

\f{SORTNUMLIST} takes as argument a list of numbers. It sorts it in
increasing order. 

\f{SORTLIST} is a generalisation of the above function.
It sorts the list according
to any well defined ordering.  Its first argument is the list and its
second argument is the ordering function.  The content of the list
is not necessary numbers but must be such that the ordering function has
a meaning.
\begin{verbatim}
        l:={1,3,4,0}$  SORTNUMLIST l;      ==> {0,1,3,4}
        ll:={1,a,tt,z}$ SORTLIST(ll,ordp); ==> {a,z,tt,1}
\end{verbatim}
Note: using these functions for kernels or bags may be
dangerous since they are destructive. If it is needed, it is recommended
first to apply \f{KERNLIST} on them.

The function \f{EXTREMUM}\ttindex{EXTREMUM} is a generalisation of the
functions \f{MIN} and \f{MAX} to include general orderings.  It is a 2
arguments function.  
The first is the list and the second is the ordering function.
With the list \verb+ll+ defined in the last example, one gets
\begin{verbatim}
        EXTREMUM(ll,ordp); ==> 1
\end{verbatim}
\item[iii.] There are four functions to identify dependencies.
\f{FUNCVAR}\ttindex{FUNCVAR} takes any expression as argument and
returns the set of variables on which it depends. Constants are eliminated.
\begin{verbatim}
        FUNCVAR(e+pi+sin(log(y)); ==> {y}
\end{verbatim}
\f{DEPATOM}\ttindex{DEPATOM} has an {\bf atom} as argument.  It returns
its argument if it is 
a number or if no dependency has previously been declared.  Otherwise,
it returns the list of variables on which in depends as declared in
various {\tt DEPEND} declarations.
\begin{verbatim}
        DEPEND a,x,y;
        DEPATOM a;       ==> {x,y}
\end{verbatim}
The functions \f{EXPLICIT}\ttindex{EXPLICIT} and
\f{IMPLICIT}\ttindex{IMPLICIT} make explicit or 
implicit the dependencies. 
\begin{verbatim}
        depend a,x; depend x,y,z;
        EXPLICIT a;      ==> a(x(y,z))
        IMPLICIT ws;     ==> a
\end{verbatim}
These are useful when one does not know the names of the variables
and (or) the nature of the dependencies.

\f{KORDERLIST}\ttindex{KORDERLIST} is a zero argument function which
display the actual ordering.
\begin{verbatim}
        KORDER x,y,z;
        KORDERLIST;      ==> (x,y,z)
\end{verbatim}
\item[iv.] A function \f{SIMPLIFY}\ttindex{SIMPLIFY} which takes an
arbitrary expression 
is available which {\em forces} down-to-the-bottom simplification of
an expression.  It is useful with \f{SYMMETRIZE}.  It has also proved
useful to simplify some output expressions of the package EXCALC
(chapter~\ref{EXCALC}).
\begin{verbatim}
        l:=op(x,y,z)$
        op(x,y,z):=x*y*z$
        SYMMETRIZE(l,op,cyclicpermlist); ==>
                              op(x,y,z)+op(y,z,x)+op(z,x,y)
        SIMPLIFY ws;      ==> op(y,z,x)+op(z,x,y)+x*y*z
\end{verbatim}
\item[v.] Filtering functions for lists.

\f{CHECKPROLIST}\ttindex{CHECKPROLIST} is a boolean function which
checks if the elements of a list have a definite property.  Its first
argument is the list, and its second argument is a boolean function
(\f{FIXP NUMBERP $\ldots$}) or an ordering function (as \f{ORDP}).

\f{EXTRACTLIST}\ttindex{EXTRACTLIST} extracts from the list given as
its first argument the elements which satisfy the boolean function
given as its second argument.
\begin{verbatim}
        l:={1,a,b,"st")$
        EXTRACTLIST(l,fixp);    ==> {1}
        EXTRACTLIST(l,stringp); ==> {st}
\end{verbatim}
\end{itemize}

\section{Properties and Flags}

It may be useful to provide analogous functions in algebraic mode to
the properties and flags of LISP.  Just using the symbolic mode
functions to alter property lists of objects may easily destroy the
integrity of the system.  The functions which are here described {\bf
do ignore} the property list and flags already defined by the system
itself.  They generate and track the {\em additional properties and
flags} that the user issues using them.  They offer the possibility of
working on property lists in an algebraic context.
\begin{description}
\item[i. Flags] 
To a given identifier, one may
associates another one linked to it ``in the background''. The three
functions \f{PUTFLAG}\ttindex{PUTFLAG},
\f{DISPLAYFLAG}\ttindex{DISPLAYFLAG} and
\f{CLEARFLAG}\ttindex{CLEARFLAG} handle them. 

\f{PUTFLAG} has 3 arguments. The first is the identifier or a list
of identifiers, the second is the name of the flag,
the third is T (true) or 0 (zero).
When the third argument is T, it creates the flag, when it is 0 it
destroys it.
\begin{verbatim}
        PUTFLAG(z1,flag_name,t);       ==> flag_name
        PUTFLAG({z1,z2},flag1_name,t); ==> t
        PUTFLAG(z2,flag1_name,0);      ==>
\end{verbatim}
\f{DISPLAYFLAG} allows to extract flags. Continuing the example:
\begin{verbatim}
        DISPLAYFLAG z1;    ==> {flag_name,flag1_name}
        DISPLAYFLAG z2;    ==> {}
\end{verbatim}
\f{CLEARFLAG} is a command which clears {\em all} flags associated to
the identifiers $id_1, \ldots , id_n$.
\item[ii. Properties]
\f{PUTPROP}\ttindex{PUTPROP} has four arguments.  The second argument
is the {\em indicator} of the property. The third argument may
be {\em any valid expression}. The fourth one is also T or 0. 
\begin{verbatim}
        PUTPROP(z1,property,x^2,t); ==> z1
\end{verbatim}
In general, one enter
\begin{verbatim}
        PUTPROP(LIST(idp1,idp2,..),,,T);
\end{verbatim}
If the last argument is 0 then the property is removed.
To display a specific property, one uses
\f{DISPLAYPROP} which takes two arguments. The first is the name of the
identifier, the second is the indicator of the property.
\begin{verbatim}
                                                 2
        DISPLAYPROP(z1,property); ==> {property,x  }
\end{verbatim}
Finally, \f{CLEARPROP} is a nary commmand which clears {\em all}
properties of the identifiers which appear as arguments.
\end{description}

\section{Control Functions}

The ASSIST package also provides additional functions which
improve the user control of the environment.
\begin{itemize}
\item[i.]
The first set of functions is composed of unary and binary boolean functions.
They are:
\begin{verbatim}
        ALATOMP x;    x is anything.
        ALKERNP x;    x is anything.
        DEPVARP(x,v); x is anything.
                      (v is an atom or a kernel)
\end{verbatim}
\f{ALATOMP}\ttindex{ALATOMP} has the value T iff x is an integer or
an identifier {\em after} it has been evaluated down to the bottom.

\f{ALKERNP}\ttindex{ALKERNP} has the value T iff x is a kernel {\em
after} it has been evaluated down to the bottom.

\f{DEPVARP}\ttindex{DEPVARP} returns T iff the expression x depends on
v at {\bf any level}.

The above functions together with \f{PRECP}\ttindex{PRECP} have been
declared operator functions to ease the verification of their value.

\f{NORDP}\ttindex{NORDP} is essentially equivalent to \verb+not+\f{ORDP}
when inside a conditional statement. Otherwise, it can be used
while \verb+not+\f{ORDP} cannot.
\item[ii.]
The next functions allow one to {\em analyse} and to {\em clean} the
environment of \REDUCE\  which is created by the user while
working interactively.  Two functions are provided:\\ 
\f{SHOW}\ttindex{SHOW} allows to get the various identifiers already
assigned and to see their type.  \f{SUPPRESS}\ttindex{SUPPRESS}
selectively clears the used identifiers or clears them all.  It is to
be stressed that identifiers assigned from the input of files are {\bf
ignored}.  Both functions have one argument and the same options for
this argument:
\begin{verbatim}
       SHOW (SUPPRESS) all
       SHOW (SUPPRESS) scalars
       SHOW (SUPPRESS) lists
       SHOW (SUPPRESS) saveids    (for saved expressions)
       SHOW (SUPPRESS) matrices
       SHOW (SUPPRESS) arrays
       SHOW (SUPPRESS) vectors
                       (contains vector, index and tvector)
       SHOW (SUPPRESS) forms
\end{verbatim}
The option \verb+all+ is the most convenient for \f{SHOW} but it may
takes time to get the answer after one has worked several hours.
When entering \REDUCE\ the option \verb+all+ for \f{SHOW} gives:
\begin{verbatim}
        SHOW all;         ==> scalars are: NIL
                              arrays are: NIL
                              lists are: NIL
                              matrices are: NIL
                              vectors are: NIL
                              forms are: NIL
\end{verbatim}
It is a convenient way to remember the various options.
Starting from a fresh environment
\begin{verbatim}
        a:=b:=1$
        SHOW scalars;     ==>  scalars are: (A B)
        SUPPRESS scalars; ==> t
        SHOW scalars;     ==>  scalars are: NIL
\end{verbatim}
\item[iii.]
The \f{CLEAR}\ttindex{CLEAR} function of the system does not do a
complete cleaning of \verb+OPERATORS+ and \verb+FUNCTIONS+.  The
following two functions do a more complete cleaning and, also
automatically takes into account the {\em user} flag and properties that the
functions \f{PUTFLAG} and \f{PUTPROP} may have introduced.

Their names are \f{CLEAROP}\ttindex{CLEAROP} and
\f{CLEARFUNCTIONS}\ttindex{CLEARFUNCTIONS}. 
\f{CLEAROP} takes one operator as its argument.  \f{CLEARFUNCTIONS} is
a nary command. If one issues 
\begin{verbatim}
        CLEARFUNCTIONS a1,a2, ... , an $
\end{verbatim}
The functions with names \verb+ a1,a2, ... ,an+  are cleared.
One should be careful when using this facility since the
only functions which cannot be erased are those which are
protected with the \verb+lose+ flag.
\end{itemize}

\section{Handling of Polynomials}

The module contains some utility functions to handle
standard quotients and several new facilities to manipulate polynomials.
\begin{itemize}
\item[i.] Two functions \f{ALG\_TO\_SYMB}\ttindex{ALG\_TO\_SYMB} and
\f{SYMB\_TO\_ALG}\ttindex{SYMB\_TO\_ALG} allow the changing of an expression
which is in the algebraic standard quotient form into a prefix lisp
form and vice-versa.  This is made 
in such a way that the symbol \verb+list+ which appears in the
algebraic mode disappear in the symbolic form (there it becomes
a parenthesis ``()'' ) and it is reintroduced in the translation
from a symbolic prefix lisp expression  to an algebraic one.
The following example shows how the well-known lisp function
\f{FLATTENS} can be trivially transportd into algebraic mode:
\begin{verbatim}
     algebraic procedure ecrase x;
     lisp symb_to_alg flattens1 alg_to_symb algebraic x;

      symbolic procedure flattens1 x;
      % ll; ==> ((A B) ((C D) E))
      % flattens1 ll; (A B C D E)
        if atom x then list x else
        if cdr x then
            append(flattens1 car x, flattens1 cdr x)
          else flattens1 car x;
\end{verbatim}
gives, for instance,
\begin{verbatim}
        ll:={a,{b,{c},d,e},{{{z}}}}$
        ECRASE ll; ==> {A, B, C, D, E, Z}
\end{verbatim}
\item[ii.]  \f{LEADTERM}\ttindex{LEADTERM} and
\f{REDEXPR}\ttindex{REDEXPR} are the algebraic equivalent of the
symbolic functions \f{LT} and \f{RED}.  They give the
{\em leading term} and the {\em reductum} of a polynomial. They also
work for rational functions. Their interest lies in the fact that they
do not require to extract the main variable. They work according to
the current ordering of the system:
\begin{verbatim}
        pol:=x+y+z$
        LEADTERM pol; ==> x
        korder y,x,z;
        LEADTERM pol; ==> y
        REDEXPR pol; ==> x + z
\end{verbatim}
By default, the representation of multivariate polynomials is recursive.
With such a representation, the function \f{LEADTERM} does not necessarily
extract a true monom.  It extracts a monom in the leading indeterminate
multiplied by a polynomial in the other indeterminates.  However, very often
one needs to handle true monoms separately.  In that case, one needs a
polynomial in {\em distributive} form.  Such a form is provided by the
package GROEBNER (chapter~\ref{GROEBNER}).  The facility there may be
too involved and the need to load an additional package can be a
problem.  So,
a new switch is created to handle {\em distributed} polynomials. It is
called {\tt DISTRIBUTE}\ttindex{DISTRIBUTE} and a new function
\label{DISTRIBUTE} \f{DISTRIBUTE} puts a polynomial in distributive
form.  With the switch {\bf on}, \f{LEADTERM} gives {\bf true} monoms.

\f{MONOM}\ttindex{MONOM} transforms a polynomial into a list of
monoms. It works whatever the setting of the switch {\tt DISTRIBUTE}.

\f{SPLITTERMS}\ttindex{SPLITTERMS} is analoguous to \f{MONOM} except
that it gives a list of two lists.  The first sublist contains the
positive terms while the second sublist contains the negative terms.

\f{SPLITPLUSMINUS}\ttindex{SPLITPLUSMINUS} gives a list whose first
element is an expression of the positive part of the polynomial and
its second element is its negative part. 
\item[iii.]
Two complementary functions \f{LOWESTDEG}\ttindex{LOWESTDEG} and
\f{DIVPOL}\ttindex{DIVPOL} are provided.
The first takes a polynomial as its first argument and the name of an
indeterminate as its second argument.  It returns the {\em lowest degree}
in that indeterminate.  The second function takes two polynomials and
returns both the quotient and its remainder.
\end{itemize}

\section{Handling of Transcendental Functions}

The functions \f{TRIGREDUCE}\ttindex{TRIGREDUCE} and
\f{TRIGEXPAND}\ttindex{TRIGEXPAND} and the equivalent 
ones for hyperbolic functions \f{HYPREDUCE}\ttindex{HYPREDUCE} and
\f{HYPEXPAND}\ttindex{HYPEXPAND} 
make the transformations to multiple arguments and from
multiple arguments to elementary arguments.
\begin{verbatim}
        aa:=sin(x+y)$
        TRIGEXPAND aa; ==> SIN(X)*COS(Y) + SIN(Y)*COS(X)
        TRIGREDUCE ws; ==> SIN(Y + X)
\end{verbatim}
When a trigonometric or hyperbolic expression is symmetric with
respect to the interchange of {\tt SIN (SINH)} and {\tt COS (COSH)},
the application of \f{TRIG(HYP)REDUCE} may often lead to great
simplifications.  However, if it is highly asymmetric, the repeated
application of \f{TRIG(HYP)REDUCE} followed by the use of
\f{TRIG(HYP)EXPAND} will lead to {\em more} complicated
but more symmetric expressions:
\begin{verbatim}
        aa:=(sin(x)^2+cos(x)^2)^3$
        TRIGREDUCE aa; ==> 1
        bb:=1+sin(x)^3$
        TRIGREDUCE bb; ==>
                - SIN(3*X) + 3*SIN(X) + 4
               ---------------------------
                           4

         TRIGEXPAND ws; ==>
                3                  2
          SIN(X)  - 3*SIN(X)*COS(X)  + 3*SIN(X) + 4
          -------------------------------------------
                             4
\end{verbatim}

See also the TRIGSIMP package (chapter~\ref{TRIGSIMP}).

\section{Coercion from lists to arrays and converse}

Sometimes when a list is very long and especially if frequent access
to its elements are needed it is advantageous (temporarily) to
transform it into an array.
\f{LIST\_TO\_ARRAY}\ttindex{LIST\_TO\_ARRAY} has three arguments.  The
first is the list.  The second is an integer which indicates the array
dimension required.  The third is the name of an identifier which will
play the role of the array name generated by it.  If the chosen
dimension is not compatible with the list depth and structure an error
message is issued.  \f{ARRAY\_TO\_LIST}\ttindex{ARRAY\_TO\_LIST} does
the opposite coercion.  It takes the array name as its sole argument.

\section{Handling of n--dimensional Vectors}

Explicit vectors in {\tt EUCLIDEAN} space may be represented by
list-like or bag-like objects of depth 1.  The components may be bags
but may {\bf not} be lists.  Functions are provided to do the sum, the
difference and the scalar product.  When space-dimension is three
there are also functions for the cross and mixed products.
\f{SUMVECT}\ttindex{SUMVECT}, \f{MINVECT}\ttindex{MINVECT},
\f{SCALVECT}\ttindex{SCALVECT}, \f{CROSSVECT}\ttindex{CROSSVECT} have
two arguments.  \f{MPVECT}\ttindex{MPVECT} has three arguments.
\begin{verbatim}
       l:={1,2,3}$
       ll:=list(a,b,c)$
       SUMVECT(l,ll);    ==> {A + 1,B + 2,C + 3}
       MINVECT(l,ll);    ==> { - A + 1, - B + 2, - C + 3}
       SCALVECT(l,ll);   ==> A + 2*B + 3*C
       CROSSVECT(l,ll);  ==> { - 3*B + 2*C,3*A - C, - 2*A + B}
       MPVECT(l,ll,l);   ==> 0
\end{verbatim}

\section{Handling of Grassmann Operators}

\index{Grassmann Operators}
Grassman variables are often used in physics.  For them the
multiplication operation is associative, distributive but
anticommutative.  The basic \REDUCE\ does not provide this.
However implementing it in full generality would almost certainly
decrease the overall efficiency of the system.  This small module
together with the declaration of antisymmetry for operators is enough
to deal with most calculations.  The reason is, that a product of
similar anticommuting kernels can easily be transformed into an
antisymmetric operator with as many indices as the number of these
kernels.  Moreover, one may also issue pattern matching rules to
implement the anticommutativity of the product.  The functions in this
module represent the minimum functionality required to identify them
and to handle their specific features.

\f{PUTGRASS}\ttindex{PUTGRASS} is a (nary) command which give
identifiers the property to be the names of Grassmann kernels.
\f{REMGRASS}\ttindex{REMGRASS} removes this property. 

\f{GRASSP}\ttindex{GRASSP} is a boolean function which detects
Grassmann kernels. 

\f{GRASSPARITY}\ttindex{GRASSPARITY} takes a {\bf monom}  as argument
and gives its parity.  If the monom is a simple Grassmann kernel it
returns 1. 

\f{GHOSTFACTOR}\ttindex{GHOSTFACTOR} has two arguments.  Each one is a
monom.  It is equal to 
\begin{verbatim}
        (-1)**(GRASSPARITY u * GRASSPARITY v)
\end{verbatim}
Here is an illustration to show how the above functions work:
\begin{verbatim}
        PUTGRASS eta;
        if GRASSP eta(1) then "Grassmann kernel"; ==>
                                                    Grassmann kernel
        aa:=eta(1)*eta(2)-eta(2)*eta(1);       ==>
                              AA :=  - ETA(2)*ETA(1) + ETA(1)*ETA(2)
        GRASSPARITY eta(1);                    ==> 1
        GRASSPARITY (eta(1)*eta(2));           ==> 0
        GHOSTFACTOR(eta(1),eta(2));            ==> -1
        grasskernel:=
          {eta(~x)*eta(~y) => -eta y * eta x when nordp(x,y),
          (~x)*(~x) => 0 when grassp x}$
        exp:=eta(1)^2$
        exp where grasskernel;                 ==> 0
        aa where grasskernel;                  ==>  - 2*ETA(2)*ETA(1)
\end{verbatim}

\section{Handling of Matrices}

There are additional facilities for matrices.
\begin{itemize}
\item[i.]
Often one needs to construct some {\tt UNIT} matrix of
a given dimension.  This construction is performed by the function
\f{UNITMAT}\ttindex{UNITMAT}.  It is a nary function.  The command is 
\begin{verbatim}
        UNITMAT M1(n1), M2(n2), .....Mi(ni) ;
\end{verbatim}
where \verb+M1,...Mi+ are names of matrices and
\verb+ n1, n2, ..., ni+ are integers.

\f{MKIDM}\ttindex{MKIDM} is a generalisation of
\f{MKID}\ttindex{MKID}.  It allows the indexing of matrix names.  If
\verb+u+ and \verb+u1+ are two matrices, one can go from one to the
other: 
\begin{verbatim}
        matrix u(2,2);$  unitmat u1(2)$
        u1; ==>
                [1  0]
                [    ]
                [0  1]

        mkidm(u,1); ==>
                [1  0]
                [    ]
                [0  1]
\end{verbatim}
Note: MKIDM(V,1) will fail even if the matrix V1 exists, unless V is
also a matrix.

This function allows to make loops on matrices like the following.
If \verb+U, U1, U2,.., U5+ are matrices:
\begin{verbatim}
        FOR I:=1:5 DO U:=U-MKIDM(U,I);
\end{verbatim}
\item[ii.]
The next functions map matrices onto bag-like or list-like objects
and conversely they generate matrices from bags or lists.

\f{COERCEMAT}\ttindex{COERCEMAT} transforms the matrix first argument
into a list of lists.
\begin{verbatim}
        COERCEMAT(U,id)
\end{verbatim}
When \verb+id+ is \verb+list+ the matrix is transformed into a list of
lists.  Otherwise it transforms it into a bag of bags whose envelope is
equal to \verb+id+. 

\f{BAGLMAT}\ttindex{BAGLMAT} does the inverse. The {\bf first}
argument is the bag-like or list-like object while the second argument
is the matrix identifier.
\begin{verbatim}
         BAGLMAT(bgl,U)
\end{verbatim}
\verb+bgl+ becomes the matrix \verb+U+. The transformation is
{\bf not} done if \verb+U+ is {\em already} the name of a
previously defined matrix,  to avoid accidental redefinition
of that matrix.
\item[ii.]
The functions \f{SUBMAT}\ttindex{SUBMAT},
\f{MATEXTR}\ttindex{MATEXTR}, \f{MATEXTC}\ttindex{MATEXTC} take parts
of a given matrix.

\f{SUBMAT} has three arguments.
\begin{verbatim}
         SUBMAT(U,nr,nc)
\end{verbatim}
The first is the matrix name, and the other two are the row and column
numbers.  It gives the submatrix obtained from \verb+U+ deleting the
row \verb+nr+ and the column \verb+nc+.  When one of them is equal to
zero only column \verb+nc+ or row \verb+nr+ is deleted.

\f{MATEXTR} and \f{MATEXTC} extract a row or a column and place it into
a list-like or bag-like object.
\begin{verbatim}
        MATEXTR(U,VN,nr)
        MATEXTC(U,VN,nc)
\end{verbatim}
where \verb+U+ is the matrix,  \verb+VN+ is the ``vector name'',
\verb+nr+  and \verb+nc+ are integers.  If \verb+VN+  is equal
to {\tt list} the vector  is given  as a list otherwise  it is
given as a bag.
\item[iii.]
Functions which manipulate matrices: \f{MATSUBR}\ttindex{MATSUBR},
\f{MATSUBC}\ttindex{MATSUBC}, \f{HCONCMAT}\ttindex{HCONCMAT},
\f{VCONCMAT}\ttindex{VCONCMAT}, \f{TPMAT}\ttindex{TPMAT},
\f{HERMAT}\ttindex{HERMAT}.

\f{MATSUBR} and \f{MATSUBC} substitute rows and columns. They have
three arguments. 
\begin{verbatim}
        MATSUBR(U,bgl,nr)
        MATSUBC(U,bgl,nc)
\end{verbatim}
The meaning of the variables \verb+U, nr, nc+ is the same as above
while \verb+bgl+ is a list-like or bag-like vector.
Its  length should be compatible with the dimensions of the matrix.

\f{HCONCMAT} and \f{VCONCMAT} concatenate two matrices.
\begin{verbatim}
        HCONCMAT(U,V)
        VCONCMAT(U,V)
\end{verbatim}
The first function concatenates horizontally, the second one
concatenates vertically. The dimensions must match.

\f{TPMAT} makes the tensor product of two matrices. It is also an
{\em infix} function.
\begin{verbatim}
        TPMAT(U,V) or U TPMAT V
\end{verbatim}
\f{HERMAT} takes the hermitian conjugate of a matrix
\begin{verbatim}
         HERMAT(U,HU)
\end{verbatim}
where \verb+HU+ is the identifier for the hermitian matrix of
\verb+U+.  It should {\bf unassigned} for this function to work
successfully.  This is done on purpose to prevent accidental
redefinition of an already used identifier.
\item[iv.]
\f{SETELMAT} and \f{GETELMAT} are functions of two integers. The first
one reset the element \verb+(i,j)+ while the second one extract an
element identified by \verb+(i,j)+. They may be useful when
dealing with matrices {\em inside procedures}.
\end{itemize}

mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/matrext.red0000644000175000017500000002163311526203062024177 0ustar  giovannigiovannimodule matrext;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module defines additional utility functions for manipulating
% matrices.  Coercions to BAG and LIST structures are defined.

symbolic procedure natnumlis u;
   % True if U is a list of natural numbers.
   % Taken from MATR.RED for bootstrap purpose.
null u or numberp car u and fixp car u and car u>0 and natnumlis cdr u;


symbolic procedure mkidm(u,j);
% This function allows us to RELATE TWO MATRICES by concatanation of
% characters. u AND uj should BOTH be matrices.
%  matsm cadr get(mkid!:(u,j),'avalue) ;
  mkid(u,j);

 flag('(mkidm),'opfn);
 flag('(mkidm),'noval);

symbolic  procedure baglmat (u,op);
% this procedure maps U into the matrix whose name is OP;
% it cannot REDEFINE the matrix OP.
% This is to avoid accidental redefinition of a previous matrix;
if getrtype op  then rederr list(op,"should be an identifier")
else
 begin scalar x,y;
  if atom op then if not (y:=gettype op) then put(op,'rtype,'matrix)
                  else typerr(list(y,op),"matrix");
  if rdepth list u neq 2 then rederr("depth of list or bag must be 2");
      x:=cdr u;
      x:= for each j in x collect for each k in cdr j collect k;
    put(op,'avalue,list('matrix,'mat . x));
return t end;

flag('(baglmat),'opfn);

symbolic procedure rcoercemat u;
% Transforms a matrix into a bag or list. Argument is a list (mat,idp).
% idp is the name to  be given to the line or column vectors.
% The idp-envelope of the bag is the same as the one of the one of the
% subbags$
begin scalar x,prf;
 x:=reval car u;
if getrtype x neq 'matrix then rederr list(x,"should be a matrix");
 prf:= cadr u;
if car x neq 'mat then typerr(x,"matrix") else
 if prf neq 'list then  <>;
 x:=cdr x;
 x:= for each j in x collect (prf .  j);
return prf . x end;

put('coercemat,'psopfn,'rcoercemat);

put('rcoercemat,'number!_of!_args,2);

symbolic procedure n!-1zero(n,k)$
if n=0 then nil else
if k=1 then 1 . nzero(n-1) else
if k=n then  append(nzero(n-1) , (1 . nil))  else
append(nzero(k-1), (1 . nzero(n-k)))$

symbolic procedure unitmat u$
% It creates unit matrices. The argument is of the form A(2),B(5)....$
begin scalar l,sy,x,aa$
for each s in u do
<< if atom s or length (l:= revlis cdr s) neq 1 or not natnumlis l
      then errpri2(s,'hold) else
<>>>;
 end$

put('unitmat,'stat,'rlis);

symbolic procedure  submat (u,nl,nc);
% Allows to extract from the matrix M the matrix obtained when
% the row NL and the column NC have been dropped.
% When NL and NC are out of range gives a copy of M;
if getrtype u neq 'matrix then rederr list(u,"should be a matrix")
else
begin scalar x;
x:=  matsm  u;
    if and(nl=0,nc=0) then return  x else
    if nl neq 0 then x:=remove(x,nl)$
    if nc neq 0 then
         x:=for each j in x collect remove(j,nc);
    return x end;

put('submat,'rtypefn,'getrtypecar);

flag('(submat),'matflg);

symbolic procedure matsubr(m,bgl,nr)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
% It allows to replace row NR of the matrix M by the bag or list BGL;
y:=reval bgl;
 if not baglistp y  then typerr(y,"bag or list") else
 if nr leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
 else
    x:=matsm m$ xl:=length x$
   if length( y:=cdr y) neq xl then  rederr " MATRIX MISMATCH"$
    y:= for each j in y collect simp j;
   if nr-xl >0 then rederr " row number is out of range";
    while (nr:=nr-1) >0
              do <>;
           rplaca(x,y) ;
           res:=append(  reverse res, x) ;
    return  res   end;

put('matsubr,'rtypefn,'getrtypecar);

flag('(matsubr),'matflg);


symbolic procedure matsubc(m,bgl,nc)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
%It allows to replace column NC of the matrix M by the bag or list BGL
y:=reval bgl;
 if not baglistp y  then typerr(y,"bag or list") else
 if nc leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
 else
    x:=tp1 matsm m$ xl:=length x$
   if length( y:=cdr y) neq xl then  rederr " MATRIX MISMATCH"$
    y:= for each j in y collect simp j;
   if nc-xl >0 then rederr " column  number is out of range";
    while (nc:=nc-1) >0
              do <>;
           rplaca(x,y) ;
           res:=tp1 append(  reverse res, x) ;
    return  res   end;

put('matsubc,'rtypefn,'getrtypecar);

flag('(matsubc),'matflg);

symbolic procedure rmatextr u$
% This function allows to extract row N from matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nl;
x:= matsm car u; y:= reval cadr u; n:=reval caddr u;
if  not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y  then  simpbagprop list(y, t)$
nl:=length x;
if n<= 0  or n>nl then return nil$
while n>1 do <>$
if null x then return nil$
return x:=y . ( for each j in car x  collect prepsq j) end$

symbolic procedure rmatextc u$
% This function allows to extract column N from matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nc;
x:= tp1 matsm car u; y:= reval cadr u; n:=reval caddr u;
if  not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y  then  simpbagprop list(y, t)$
nc:=length x;
if n<= 0  or n>nc then return nil$
while n>1 do <>$
if null x then return nil$
return x:=y . ( for each j in car x  collect prepsq j) end$

put('matextr,'psopfn,'rmatextr);

put('matextc,'psopfn,'rmatextc);

symbolic procedure  hconcmat(u,v)$
% Gives the horizontal concatenation of matrices U and V$
  hconcmat!:(matsm u,matsm v );

symbolic procedure hconcmat!:(u,v)$
if null u then v else if null v then u else
append(car u,car v) . hconcmat!:(cdr u,cdr v)$

symbolic put('hconcmat,'rtypefn,'getrtypecar);
symbolic flag('(hconcmat),'matflg);

symbolic procedure vconcmat (u,v)$
% Gives the vertical concatenation of matrices U and V$
 append(matsm u,matsm v);

put('vconcmat,'rtypefn,'getrtypecar);

flag('(vconcmat),'matflg);

symbolic procedure tprodl(u,v)$
begin scalar aa,ul$
l1: if null u then return aa$
    ul:=car u$
    ul:=multsm(ul,v)$
    aa:=hconcmat!:(aa,ul)$
    u:=cdr u$
    go to l1$
    end$

symbolic procedure tpmat(u,v)$
% Constructs the direct product of two matrices;
if null gettype u  then multsm(simp u,matsm v) else
if null gettype v then multsm(simp v,matsm u) else
begin scalar aa,uu,vv$
    uu:=matsm u$ vv:=matsm v$
    for each x in uu do aa:=append (aa,tprodl(x,vv))$
return aa end;

infix tpmat$

put('tpmat,'rtypefn, 'getrtypecar);

flag('(tpmat),'matflg)$

algebraic procedure hermat (m,hm);
% hm must be an identifier with NO value. Returns the
% Hermitiam Conjugate matrix.
begin scalar ml,ll; %ll:=length M;
m:=tp m;
ml:=coercemat(m,list);
ll:=list(length first ml,length ml);
ml:=for j:=1: first ll collect for k:=1:second ll collect
        sub(i=-i,(ml.j).k);
baglmat(ml,hm);
return hm end;

symbolic procedure seteltmat(m,elt,i,j);
% Sets the matrix element (i,j) to elt. Returns the modified matrix.
begin scalar res;res:=matsm m;
rplaca(pnth(nth(res,i),j),simp elt);
return res end;

put('seteltmat,'rtypefn,'getrtypecar);
flag('(seteltmat),'matflg);

symbolic procedure simpgetelt u;
% Gets the matrix element (i,j). Returns the element.
begin scalar mm;
mm:=matsm car u;
return nth(nth(mm,cadr u),caddr u) end;

put('geteltmat, 'simpfn,'simpgetelt);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/selfgra.rlg0000644000175000017500000013117711526203062024155 0ustar  giovannigiovanni1: load cantens$
*** enlarging fasl space by 25000 items

*** .. redefined 

2: in "selfgra.tst";
%%%%%%%%%%%%%%%%%%%  A. Burnel and H. Caprasse  %%%%%%%%%%%%%%%%%%%%%%

% 
% Application of CANTENS.RED 
% Date: 15/09/98
%
% Computes the gluon contribution  to the gluon self-energy in the 
% "finite" theory
% contains initially 18 terms which are reduced to 10 by cantens 
% in a dm-dimensional Minkowski space and 8 terms in a 4-dimensional 
% Minkowski space. 
% 
%          *** Will look much nicer if run in the GRAPHIC mode 
%
% LOADING CANTENS

load cantens$




%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Structure definitions, Minkowski space  X internal symmetry space
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


off onespace;

 % to be allowed to work within several subspaces

define_spaces wholespace={dm+di,signature=1};


t

define_spaces mink={dm,signature=1};


t
%,indexrange=0 .. 3};
define_spaces internal={di,signature=0};


t
%,indexrange=4 .. 11};
%
%  Memberships of indices:
mk_ids_belong_space({mu1,mu2,nu1,nu2,tau},mink);


t

mk_ids_belong_space({a1,a2,b1,b2,c1,c2},internal);


t


                         %%%%%%%%%%%%%%%%
                         % Used Tensors %
                         %%%%%%%%%%%%%%%%

%%                 variables x1,x2 and xi=x1-x2,
%%                 aa, gluon field
%%                 dd, contracted gluon field 
%%                 which appears inside the expression
%%                 a is the antisymmetric structure constant of SU3.
%%                 It is called "a" to assure that it appears first 
%%                 inside REDUCE expressions and to assure that they 
%%                 factorize in front of the output expression.
%
tensor aa,dd,a,x1,x2,xi;


t
 % tensor declaration

make_variables x1,x2,xi;


t
 % variable declaration

% declare to which subspace the declared tensors belong to.

make_tensor_belong_space(x1,mink);


mink
 
make_tensor_belong_space(x2,mink);


mink

make_tensor_belong_space(xi,mink);


mink

make_tensor_belong_space(a,internal);


internal


antisymmetric a;

 % antisymmetry of structure constant.

  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  % building of starting expression to be manipulated  and simplified.

  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


es1:=g^2*a(a1,b1,c1)*a(a2,b2,c2);


        a1 b1 c1  a2 b2 c2  2
es1 := a        *a        *g

as1:=-aa(x1,nu1,-b1)*aa(x2,nu2,-b2)*df(df(dd(xi,mu1,-c1,mu2,-c2),xi(nu
1)),xi(nu2))
*dd(xi,-mu1,-a1,-mu2,-a2);


             nu1           nu2 
as1 :=  - aa       (x1)*aa       (x2)*dd              (xi)
                 b1            b2        mu1 a1 mu2 a2

              mu1    mu2          nu1   nu2
       *df(dd              (xi),xi   ,xi   )
                  c1     c2

as2:=-aa(x1,nu1,-b1)*aa(x2,nu2,-b2)*df(dd(xi,mu1,-c1,mu2,-a2),xi(nu1))

*df(dd(xi,-mu1,-a1,-mu2,-c2),xi(nu2));


             nu1           nu2 
as2 :=  - aa       (x1)*aa       (x2)
                 b1            b2

                                  nu2
       *df(dd              (xi),xi   )
              mu1 a1 mu2 c2

              mu1    mu2          nu1
       *df(dd              (xi),xi   )
                  c1     a2

as3:=aa(x1,nu1,-b1)*df(aa(x2,mu2,-c2),x2(nu2))*df(dd(xi,mu1,-c1,nu2,-b
2),xi(nu1))
*dd(xi,-mu1,-a1,-mu2,-a2);


          nu1                                   mu2          nu2
as3 := aa       (x1)*dd              (xi)*df(aa       (x2),x2   )
              b1        mu1 a1 mu2 a2               c2

              mu1    nu2          nu1
       *df(dd              (xi),xi   )
                  c1     b2

as4:=aa(x1,nu1,-b1)*df(aa(x2,mu2,-c2),x2(nu2))*df(dd(xi,mu1,-c1,-mu2,-
a2),xi(nu1))
*dd(xi,-mu1,-a1,nu2,-b2);


          nu1                  nu2              mu2          nu2
as4 := aa       (x1)*dd              (xi)*df(aa       (x2),x2   )
              b1        mu1 a1     b2               c2

              mu1                 nu1
       *df(dd              (xi),xi   )
                  c1 mu2 a2

as5:=-aa(x1,nu1,-b1)*aa(x2,mu2,-a2)*df(dd(xi,mu1,-c1,nu2,-b2),xi(nu1))

*df(dd(xi,-mu1,-a1,-mu2,-c2),xi(nu2));


             nu1           mu2 
as5 :=  - aa       (x1)*aa       (x2)
                 b1            a2

                                  nu2
       *df(dd              (xi),xi   )
              mu1 a1 mu2 c2

              mu1    nu2          nu1
       *df(dd              (xi),xi   )
                  c1     b2

as6:=-aa(x1,nu1,-b1)*aa(x2,mu2,-a2)*df(df(dd(xi,mu1,-c1,-mu2,-c2),xi(n
u1)),xi(nu2))
*dd(xi,-mu1,-a1,nu2,-b2);


             nu1           mu2                  nu2 
as6 :=  - aa       (x1)*aa       (x2)*dd              (xi)
                 b1            a2        mu1 a1     b2

              mu1                 nu1   nu2
       *df(dd              (xi),xi   ,xi   )
                  c1 mu2 c2

as7:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,nu2,-b2)*df(dd(xi,nu1,-b1,mu2,-
c2),xi(nu2))
*dd(xi,-mu1,-a1,-mu2,-a2);


             nu2 
as7 :=  - aa       (x2)*dd              (xi)
                 b2        mu1 a1 mu2 a2

              mu1          nu1        nu1    mu2          nu2
       *df(aa       (x1),x1   )*df(dd              (xi),xi   )
                  c1                      b1     c2

as8:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,nu2,-b2)*df(dd(xi,-mu1,-a1,mu2,
-c2),xi(nu2))
*dd(xi,nu1,-b1,-mu2,-a2);


             nu2           nu1 
as8 :=  - aa       (x2)*dd              (xi)
                 b2            b1 mu2 a2

              mu1          nu1               mu2          nu2
       *df(aa       (x1),x1   )*df(dd              (xi),xi   )
                  c1                  mu1 a1     c2

as9:=df(aa(x1,mu1,-c1),x1(nu1))*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-
b1,nu2,-b2)
*dd(xi,-mu1,-a1,-mu2,-a2);


                               nu1    nu2 
as9 := dd              (xi)*dd              (xi)
          mu1 a1 mu2 a2            b1     b2

              mu1          nu1        mu2          nu2
       *df(aa       (x1),x1   )*df(aa       (x2),x2   )
                  c1                      c2

as10:=df(aa(x1,mu1,-c1),x1(nu1))*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,
-b1,-mu2,-a2)
*dd(xi,-mu1,-a1,nu2,-b2);


                  nu2           nu1 
as10 := dd              (xi)*dd              (xi)
           mu1 a1     b2            b1 mu2 a2

               mu1          nu1        mu2          nu2
        *df(aa       (x1),x1   )*df(aa       (x2),x2   )
                   c1                      c2

as11:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-a1,-mu
2,-c2),xi(nu2))
*dd(xi,nu1,-b1,nu2,-b2);


              mu2           nu1    nu2 
as11 :=  - aa       (x2)*dd              (xi)
                  a2            b1     b2

               mu1          nu1                            nu2
        *df(aa       (x1),x1   )*df(dd              (xi),xi   )
                   c1                  mu1 a1 mu2 c2

as12:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,mu2,-a2)*df(dd(xi,nu1,-b1,-mu2
,-c2),xi(nu2))
*dd(xi,-mu1,-a1,nu2,-b2);


              mu2                  nu2 
as12 :=  - aa       (x2)*dd              (xi)
                  a2        mu1 a1     b2

               mu1          nu1        nu1                 nu2
        *df(aa       (x1),x1   )*df(dd              (xi),xi   )
                   c1                      b1 mu2 c2

as13:=-aa(x1,mu1,-a1)*aa(x2,nu2,-b2)*df(dd(xi,nu1,-b1,mu2,-c2),xi(nu2)
)
*df(dd(xi,-mu1,-c1,-mu2,-a2),xi(nu1));


              mu1           nu2 
as13 :=  - aa       (x1)*aa       (x2)
                  a1            b2

                                   nu1
        *df(dd              (xi),xi   )
               mu1 c1 mu2 a2

               nu1    mu2          nu2
        *df(dd              (xi),xi   )
                   b1     c2

as14:=-aa(x1,mu1,-a1)*aa(x2,nu2,-b2)*dd(xi,nu1,-b1,mu2,-a2)
*df(dd(xi,-mu1,-c1,-mu2,-c2),xi(nu1),xi(nu2));


              mu1           nu2           nu1    mu2 
as14 :=  - aa       (x1)*aa       (x2)*dd              (xi)
                  a1            b2            b1     a2

                                   nu1   nu2
        *df(dd              (xi),xi   ,xi   )
               mu1 c1 mu2 c2

as15:=aa(x1,mu1,-a1)*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,nu2,-b2)

*df(dd(xi,-mu1,-c1,-mu2,-a2),xi(nu1));


           mu1           nu1    nu2              mu2          nu2
as15 := aa       (x1)*dd              (xi)*df(aa       (x2),x2   )
               a1            b1     b2               c2

                                   nu1
        *df(dd              (xi),xi   )
               mu1 c1 mu2 a2

as16:=aa(x1,mu1,-a1)*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,-mu2,-a2
)
*df(dd(xi,-mu1,-c1,nu2,-b2),xi(nu1));


           mu1           nu1                     mu2          nu2
as16 := aa       (x1)*dd              (xi)*df(aa       (x2),x2   )
               a1            b1 mu2 a2               c2

                      nu2          nu1
        *df(dd              (xi),xi   )
               mu1 c1     b2

as17:=-aa(x1,mu1,-a1)*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-c1,-mu2,-c2),xi(nu
1),xi(nu2))
*dd(xi,nu1,-b1,nu2,-b2);


              mu1           mu2           nu1    nu2 
as17 :=  - aa       (x1)*aa       (x2)*dd              (xi)
                  a1            a2            b1     b2

                                   nu1   nu2
        *df(dd              (xi),xi   ,xi   )
               mu1 c1 mu2 c2

as18:=-aa(x1,mu1,-a1)*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-c1,nu2,-b2),xi(nu1
))
*df(dd(xi,nu1,-b1,-mu2,-c2),xi(nu2));


              mu1           mu2 
as18 :=  - aa       (x1)*aa       (x2)
                  a1            a2

                      nu2          nu1
        *df(dd              (xi),xi   )
               mu1 c1     b2

               nu1                 nu2
        *df(dd              (xi),xi   )
                   b1 mu2 c2


     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     % building of the gluon contribution to gluon self-energy %
     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

es:=es1*for i:=1:18 sum mkid(as,i);


       a1 b1 c1  a2 b2 c2  2        mu1           mu2 
es := a        *a        *g *( - aa       (x1)*aa       (x2)
                                        a1            a2

             nu1    nu2 
         *dd              (xi)
                 b1     b2

                                    nu1   nu2       mu1 
         *df(dd              (xi),xi   ,xi   ) - aa       (x1)
                mu1 c1 mu2 c2                           a1

             mu2                     nu2          nu1
         *aa       (x2)*df(dd              (xi),xi   )
                 a2           mu1 c1     b2

                nu1                 nu2       mu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                    b1 mu2 c2                     a1

             nu2           nu1    mu2 
         *aa       (x2)*dd              (xi)
                 b2            b1     a2

                                    nu1   nu2       mu1 
         *df(dd              (xi),xi   ,xi   ) - aa       (x1)
                mu1 c1 mu2 c2                           a1

             nu2                                  nu1
         *aa       (x2)*df(dd              (xi),xi   )
                 b2           mu1 c1 mu2 a2

                nu1    mu2          nu2       mu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                    b1     c2                     a1

             nu1                     mu2          nu2
         *dd              (xi)*df(aa       (x2),x2   )
                 b1 mu2 a2               c2

                       nu2          nu1       mu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                mu1 c1     b2                     a1

             nu1    nu2              mu2          nu2
         *dd              (xi)*df(aa       (x2),x2   )
                 b1     b2               c2

                                    nu1       nu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                mu1 c1 mu2 a2                     b1

             mu2                  nu2 
         *aa       (x2)*dd              (xi)
                 a2        mu1 a1     b2

                mu1                 nu1   nu2       nu1 
         *df(dd              (xi),xi   ,xi   ) - aa       (x1)
                    c1 mu2 c2                           b1

             mu2                                  nu2
         *aa       (x2)*df(dd              (xi),xi   )
                 a2           mu1 a1 mu2 c2

                mu1    nu2          nu1       nu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                    c1     b2                     b1

             nu2 
         *aa       (x2)*dd              (xi)
                 b2        mu1 a1 mu2 a2

                mu1    mu2          nu1   nu2       nu1 
         *df(dd              (xi),xi   ,xi   ) - aa       (x1)
                    c1     c2                           b1

             nu2                                  nu2
         *aa       (x2)*df(dd              (xi),xi   )
                 b2           mu1 a1 mu2 c2

                mu1    mu2          nu1       nu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                    c1     a2                     b1

                                     mu2          nu2
         *dd              (xi)*df(aa       (x2),x2   )
             mu1 a1 mu2 a2               c2

                mu1    nu2          nu1       nu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                    c1     b2                     b1

                    nu2              mu2          nu2
         *dd              (xi)*df(aa       (x2),x2   )
             mu1 a1     b2               c2

                mu1                 nu1       mu2 
         *df(dd              (xi),xi   ) - aa       (x2)
                    c1 mu2 a2                     a2

                    nu2              mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
             mu1 a1     b2               c1

                nu1                 nu2       mu2 
         *df(dd              (xi),xi   ) - aa       (x2)
                    b1 mu2 c2                     a2

             nu1    nu2              mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
                 b1     b2               c1

                                    nu2       nu2 
         *df(dd              (xi),xi   ) - aa       (x2)
                mu1 a1 mu2 c2                     b2

                                     mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
             mu1 a1 mu2 a2               c1

                nu1    mu2          nu2       nu2 
         *df(dd              (xi),xi   ) - aa       (x2)
                    b1     c2                     b2

             nu1                     mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
                 b1 mu2 a2               c1

                       mu2          nu2
         *df(dd              (xi),xi   ) + dd              (xi)
                mu1 a1     c2                 mu1 a1 mu2 a2

             nu1    nu2              mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
                 b1     b2               c1

                mu2          nu2              nu2 
         *df(aa       (x2),x2   ) + dd              (xi)
                    c2                 mu1 a1     b2

             nu1                     mu1          nu1
         *dd              (xi)*df(aa       (x1),x1   )
                 b1 mu2 a2               c1

                mu2          nu2
         *df(aa       (x2),x2   ))
                    c2


      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      % Are some terms identical ? %
      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
es:=canonical es;


       a1 a2 b1  b2 c1 c2  2        mu1           mu2 
es := a        *a        *g *( - aa       (x1)*aa       (x2)
                                        b2            a1

             nu1    nu2 
         *dd              (xi)
                 c1     a2

                                    nu1   nu2       mu1 
         *df(dd              (xi),xi   ,xi   ) + aa       (x1)
                mu1 c2 mu2 b1                           b2

             mu2           nu1    nu2 
         *aa       (x2)*dd              (xi)
                 a1            c1     a2

                                    mu2   nu1       mu1 
         *df(dd              (xi),xi   ,xi   ) + aa       (x1)
                mu1 c2 nu2 b1                           b2

             mu2           nu1    nu2 
         *aa       (x2)*dd              (xi)
                 a1            c1     a2

                                    mu1   nu2       mu1 
         *df(dd              (xi),xi   ,xi   ) - aa       (x1)
                nu1 c2 mu2 b1                           b2

             mu2           nu1    nu2 
         *aa       (x2)*dd              (xi)
                 a1            c1     a2

                                    mu1   mu2       mu1 
         *df(dd              (xi),xi   ,xi   ) + aa       (x1)
                nu1 c2 nu2 b1                           b2

             mu2                     nu2 
         *aa       (x2)*df(dd              (xi),xi   )
                 a1           mu1 c2     b1       nu1

                                    nu2       mu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                nu1 c1 mu2 a2                     b2

             mu2                     nu2 
         *aa       (x2)*df(dd              (xi),xi   )
                 a1           mu1 c2     b1       nu1

                                    mu2       mu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                nu1 c1 nu2 a2                     b2

             mu2                                  mu1
         *aa       (x2)*df(dd              (xi),xi   )
                 a1           nu1 c1 nu2 a2

                nu1                           mu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                    c2 mu2 b1       nu2           b2

             mu2                                  mu1
         *aa       (x2)*df(dd              (xi),xi   )
                 a1           nu1 c1 nu2 a2

                nu1    nu2          mu2       mu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                    c2     b1                     b2

             mu2    nu1 
         *dd              (xi)*df(aa       (x2),x2   )
                 c1     a1           nu1 a2       nu2

                                    mu2       mu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                mu1 c2 nu2 b1                     b2

             mu2    nu1 
         *dd              (xi)*df(aa       (x2),x2   )
                 c1     a1           nu1 a2       nu2

                                    mu1       mu1 
         *df(dd              (xi),xi   ) + aa       (x1)
                mu2 c2 nu2 b1                     b2

             mu2    nu1              nu2          nu1
         *dd              (xi)*df(aa       (x2),x2   )
                 c1     a1               a2

                                    mu2       mu1 
         *df(dd              (xi),xi   ) - aa       (x1)
                mu1 c2 nu2 b1                     b2

             mu2    nu1              nu2          nu1
         *dd              (xi)*df(aa       (x2),x2   )
                 c1     a1               a2

                                    mu1       mu1 
         *df(dd              (xi),xi   ) + aa       (x2)
                mu2 c2 nu2 b1                     b2

             mu2    nu1 
         *dd              (xi)*df(aa       (x1),x1   )
                 a1     c1           mu2 a2       nu2

                                    nu1       mu1 
         *df(dd              (xi),xi   ) - aa       (x2)
                nu2 b1 mu1 c2                     b2

             mu2    nu1 
         *dd              (xi)*df(aa       (x1),x1   )
                 a1     c1           mu2 a2       nu2

                                    mu1       mu1 
         *df(dd              (xi),xi   ) - aa       (x2)
                nu2 b1 nu1 c2                     b2

             mu2    nu1              nu2          mu2
         *dd              (xi)*df(aa       (x1),x1   )
                 a1     c1               a2

                                    nu1       mu1 
         *df(dd              (xi),xi   ) + aa       (x2)
                nu2 b1 mu1 c2                     b2

             mu2    nu1              nu2          mu2
         *dd              (xi)*df(aa       (x1),x1   )
                 a1     c1               a2

                                    mu1       mu1    mu2 
         *df(dd              (xi),xi   ) - dd              (xi)
                nu2 b1 nu1 c2                     b2     a1

             nu1    nu2                           mu1
         *dd              (xi)*df(aa       (x1),x1   )
                 c1     a2           nu1 c2

                             nu2       mu1    mu2 
         *df(aa       (x2),x2   ) + dd              (xi)
                mu2 b1                     b2     a1

             nu1    nu2                           mu1
         *dd              (xi)*df(aa       (x1),x1   )
                 c1     a2           nu1 c2

                             mu2
         *df(aa       (x2),x2   ))
                nu2 b1

length es;


18

% no simplification
    
tensor dc;


t
  % new tensor
make_tensor_belong_space(dc,mink);


mink
 % belongs to Minkowski space
make_partic_tens(rho,metric);


t
 % "rho" is a metric tensor
make_tensor_belong_space(rho,internal);


internal
 % in the internal space

          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
          % rewriting rule and subsequent simplification %  
          % dd(mu1,mu2,a,b)=>rho(a,b)*dc(mu1,mu2)        %
          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

ddrule:={dd({~xi},~a,~b,~c,~d)=>rho(b,d)*dc({xi},a,c)};


              ~a ~b ~c ~d            b d    a c
ddrule := {dd            (~xi) => rho   *dc    (xi)}
                                            



          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
          % simplification after application of the rule % 
          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


es:=(es where ddrule);


       a1 a2 b1  b2 c1 c2  2        mu1           mu2 
es := a        *a        *g *( - aa       (x1)*aa       (x2)
                                        b2            a1

             nu1 nu2                         nu1   nu2
         *dc        (xi)*df(dc        (xi),xi   ,xi   )*rho
                               mu1 mu2                     a2 c1

                        mu1           mu2           nu1 nu2
         *rho      + aa       (x1)*aa       (x2)*dc        (xi)
             b1 c2          b2            a1        

                              mu2   nu1
         *df(dc        (xi),xi   ,xi   )*rho     *rho      + 
                mu1 nu2                     a2 c1    b1 c2

            mu1           mu2           nu1 nu2
         aa       (x1)*aa       (x2)*dc        (xi)
                b2            a1        

                              mu1   nu2
         *df(dc        (xi),xi   ,xi   )*rho     *rho      - 
                nu1 mu2                     a2 c1    b1 c2

            mu1           mu2           nu1 nu2
         aa       (x1)*aa       (x2)*dc        (xi)
                b2            a1        

                              mu1   mu2
         *df(dc        (xi),xi   ,xi   )*rho     *rho      + 
                nu1 nu2                     a2 c1    b1 c2

            mu1           mu2                  nu2
         aa       (x1)*aa       (x2)*df(dc        (xi),xi   )
                b2            a1           mu1           nu1

                              nu2
         *df(dc        (xi),xi   )*rho     *rho      - 
                nu1 mu2               a2 c1    b1 c2

            mu1           mu2                  nu2
         aa       (x1)*aa       (x2)*df(dc        (xi),xi   )
                b2            a1           mu1           nu1

                              mu2
         *df(dc        (xi),xi   )*rho     *rho      - 
                nu1 nu2               a2 c1    b1 c2

            mu1           mu2                            mu1
         aa       (x1)*aa       (x2)*df(dc        (xi),xi   )
                b2            a1           nu1 nu2

                nu1 
         *df(dc        (xi),xi   )*rho     *rho      + 
                    mu2       nu2     a2 c1    b1 c2

            mu1           mu2                            mu1
         aa       (x1)*aa       (x2)*df(dc        (xi),xi   )
                b2            a1           nu1 nu2

                nu1 nu2       mu2
         *df(dc        (xi),xi   )*rho     *rho      - 
                                      a2 c1    b1 c2

            mu1           mu2 nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b2                          nu1 a2       nu2

                              mu2
         *df(dc        (xi),xi   )*rho     *rho      + 
                mu1 nu2               a1 c1    b1 c2

            mu1           mu2 nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b2                          nu1 a2       nu2

                              mu1
         *df(dc        (xi),xi   )*rho     *rho      + 
                mu2 nu2               a1 c1    b1 c2

            mu1           mu2 nu1           nu2          nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b2                              a2

                              mu2
         *df(dc        (xi),xi   )*rho     *rho      - 
                mu1 nu2               a1 c1    b1 c2

            mu1           mu2 nu1           nu2          nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b2                              a2

                              mu1
         *df(dc        (xi),xi   )*rho     *rho      + 
                mu2 nu2               a1 c1    b1 c2

            mu1           mu2 nu1
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b2                          mu2 a2       nu2

                              nu1
         *df(dc        (xi),xi   )*rho     *rho      - 
                nu2 mu1               a1 c1    b1 c2

            mu1           mu2 nu1
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b2                          mu2 a2       nu2

                              mu1
         *df(dc        (xi),xi   )*rho     *rho      - 
                nu2 nu1               a1 c1    b1 c2

            mu1           mu2 nu1           nu2          mu2
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b2                              a2

                              nu1
         *df(dc        (xi),xi   )*rho     *rho      + 
                nu2 mu1               a1 c1    b1 c2

            mu1           mu2 nu1           nu2          mu2
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b2                              a2

                              mu1
         *df(dc        (xi),xi   )*rho     *rho      - 
                nu2 nu1               a1 c1    b1 c2

            mu1 mu2        nu1 nu2                        mu1
         dc        (xi)*dc        (xi)*df(aa       (x1),x1   )
                                             nu1 c2

                             nu2
         *df(aa       (x2),x2   )*rho     *rho      + 
                mu2 b1               a1 b2    a2 c1

            mu1 mu2        nu1 nu2                        mu1
         dc        (xi)*dc        (xi)*df(aa       (x1),x1   )
                                             nu1 c2

                             mu2
         *df(aa       (x2),x2   )*rho     *rho     )
                nu2 b1               a1 b2    a2 c1

%
es:=canonical es;


       a1 a2 b1  b2        2        mu1           mu2 
es := a        *a        *g *( - aa       (x1)*aa       (x2)
                    a1 a2               b1            b2

             nu1 nu2                         nu1   nu2
         *dc        (xi)*df(dc        (xi),xi   ,xi   ) + 
                               mu1 mu2

            mu1           mu2           nu1 nu2
         aa       (x1)*aa       (x2)*dc        (xi)
                b1            b2        

                              mu2   nu1       mu1 
         *df(dc        (xi),xi   ,xi   ) + aa       (x1)
                mu1 nu2                           b1

             mu2           nu1 nu2
         *aa       (x2)*dc        (xi)
                 b2        

                              mu1   nu2       mu1 
         *df(dc        (xi),xi   ,xi   ) - aa       (x1)
                nu1 mu2                           b1

             mu2           nu1 nu2
         *aa       (x2)*dc        (xi)
                 b2        

                              mu1   mu2       mu1 
         *df(dc        (xi),xi   ,xi   ) + aa       (x1)
                nu1 nu2                           b1

             mu2                  nu1
         *aa       (x2)*df(dc        (xi),xi   )
                 b2           mu1           nu2

                              nu1       mu1           mu2 
         *df(dc        (xi),xi   ) - aa       (x1)*aa       (x2)
                nu2 mu2                     b1            b2

                    nu1                                mu2
         *df(dc        (xi),xi   )*df(dc        (xi),xi   ) - 
                mu1           nu2        nu2 nu1

            mu1           mu2                            nu2
         aa       (x1)*aa       (x2)*df(dc        (xi),xi   )
                b1            b2           nu1 mu2

                nu1 nu2       mu1       mu1           mu2 
         *df(dc        (xi),xi   ) + aa       (x1)*aa       (x2)
                                            b1            b2

                              mu2        nu1 nu2       mu1
         *df(dc        (xi),xi   )*df(dc        (xi),xi   ) + 
                nu1 nu2                  

            mu1           mu2 nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b1                          nu1 b2       nu2

                              mu2       mu1           mu2 nu1
         *df(dc        (xi),xi   ) - aa       (x1)*dc        (xi)
                mu1 nu2                     b1        

                                                      mu1
         *df(aa       (x2),x2   )*df(dc        (xi),xi   ) - 
                nu1 b2       nu2        mu2 nu2

            mu1           mu2 nu1           nu2          nu1
         aa       (x1)*dc        (xi)*df(aa       (x2),x2   )
                b1                              b2

                              mu2       mu1           mu2 nu1
         *df(dc        (xi),xi   ) + aa       (x1)*dc        (xi)
                mu1 nu2                     b1        

                nu2          nu1                      mu1
         *df(aa       (x2),x2   )*df(dc        (xi),xi   ) - 
                    b2                  mu2 nu2

            mu1           mu2 nu1
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b1                          mu2 b2       nu2

                              nu1       mu1           mu2 nu1
         *df(dc        (xi),xi   ) + aa       (x2)*dc        (xi)
                nu2 mu1                     b1        

                                                      mu1
         *df(aa       (x1),x1   )*df(dc        (xi),xi   ) + 
                mu2 b2       nu2        nu2 nu1

            mu1           mu2 nu1           nu2          mu2
         aa       (x2)*dc        (xi)*df(aa       (x1),x1   )
                b1                              b2

                              nu1       mu1           mu2 nu1
         *df(dc        (xi),xi   ) - aa       (x2)*dc        (xi)
                nu2 mu1                     b1        

                nu2          mu2                      mu1
         *df(aa       (x1),x1   )*df(dc        (xi),xi   ) - 
                    b2                  nu2 nu1

            mu1 mu2        nu1 nu2                        mu1
         dc        (xi)*dc        (xi)*df(aa       (x1),x1   )
                                             nu1 b1

                             nu2       mu1 mu2        nu1 nu2
         *df(aa       (x2),x2   ) + dc        (xi)*dc        (xi)
                mu2 b2                                

                             mu1                     mu2
         *df(aa       (x1),x1   )*df(aa       (x2),x2   ))
                nu1 b1                  nu2 b2



               %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
               %         Particular gauge:                       %
               % case of Fermi gauge : dc(mu1,mu2)=g(mu1,mu2)*dc %
               %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

make_partic_tens(delta,delta);


t
 % delta tenseur defined with name "delta"

% eta tenseur introduced with name "eta":
make_partic_tens(eta,eta);


t
  
make_tensor_belong_space(eta,mink);


mink


%  rule for the choice of gauge:

dcrule:={dc({~xi},~a,~c)=>eta(a,c)*dc(xi)};


              ~a ~c            a c   xi
dcrule := {dc      (~xi) => eta   *dc  }
              


% rewriting of the expression

res:=(es where dcrule);


        a1 a2 b1  b2        2        mu1           mu2 
res := a        *a        *g *( - aa       (x1)*aa       (x2)
                     a1 a2               b1            b2

                              mu1   mu2                nu1 nu2
          *dc(xi)*df(dc(xi),xi   ,xi   )*eta       *eta        + 
                                            nu1 nu2

             mu1           mu2 
          aa       (x1)*aa       (x2)*dc(xi)
                 b1            b2

                       mu1   nu2                nu1 nu2
          *df(dc(xi),xi   ,xi   )*eta       *eta        + 
                                     mu2 nu1

             mu1           mu2 
          aa       (x1)*aa       (x2)*dc(xi)
                 b1            b2

                       mu2   nu1                nu1 nu2
          *df(dc(xi),xi   ,xi   )*eta       *eta        - 
                                     mu1 nu2

             mu1           mu2 
          aa       (x1)*aa       (x2)*dc(xi)
                 b1            b2

                       nu1   nu2                nu1 nu2
          *df(dc(xi),xi   ,xi   )*eta       *eta        - 
                                     mu1 mu2

             mu1           mu2             nu1 
          aa       (x1)*aa       (x2)*delta    *df(dc(xi),xi   )
                 b1            b2          mu1              nu2

                       mu2                  mu1 
          *df(dc(xi),xi   )*eta        + aa       (x1)
                               nu1 nu2          b1

              mu2             nu1 
          *aa       (x2)*delta    *df(dc(xi),xi   )
                  b2          mu1              nu2

                       nu1                  mu1 
          *df(dc(xi),xi   )*eta        + aa       (x1)
                               mu2 nu2          b1

              mu2                    mu1              mu2
          *aa       (x2)*df(dc(xi),xi   )*df(dc(xi),xi   )
                  b2

                         nu1 nu2      mu1           mu2 
          *eta       *eta        - aa       (x1)*aa       (x2)
              nu1 nu2                     b1            b2

                       mu1              nu2                nu1 nu2
          *df(dc(xi),xi   )*df(dc(xi),xi   )*eta       *eta
                                                mu2 nu1

                mu1 
           - aa       (x1)*dc(xi)*df(aa       (x2),x2   )
                    b1                  nu1 b2       nu2

                       mu1                mu2 nu1      mu1 
          *df(dc(xi),xi   )*eta       *eta        + aa       (x1)
                               mu2 nu2                     b1

                                                      mu2
          *dc(xi)*df(aa       (x2),x2   )*df(dc(xi),xi   )
                        nu1 b2       nu2

                         mu2 nu1      mu1 
          *eta       *eta        + aa       (x1)*dc(xi)
              mu1 nu2                     b1

                 nu2          nu1              mu1
          *df(aa       (x2),x2   )*df(dc(xi),xi   )*eta
                     b2                                mu2 nu2

              mu2 nu1      mu1 
          *eta        - aa       (x1)*dc(xi)
                               b1

                 nu2          nu1              mu2
          *df(aa       (x2),x2   )*df(dc(xi),xi   )*eta
                     b2                                mu1 nu2

              mu2 nu1      mu1 
          *eta        + aa       (x2)*dc(xi)
                               b1

                                               mu1
          *df(aa       (x1),x1   )*df(dc(xi),xi   )*eta
                 mu2 b2       nu2                      nu1 nu2

              mu2 nu1      mu1 
          *eta        - aa       (x2)*dc(xi)
                               b1

                                               nu1
          *df(aa       (x1),x1   )*df(dc(xi),xi   )*eta
                 mu2 b2       nu2                      mu1 nu2

              mu2 nu1      mu1 
          *eta        - aa       (x2)*dc(xi)
                               b1

                 nu2          mu2              mu1
          *df(aa       (x1),x1   )*df(dc(xi),xi   )*eta
                     b2                                nu1 nu2

              mu2 nu1      mu1 
          *eta        + aa       (x2)*dc(xi)
                               b1

                 nu2          mu2              nu1
          *df(aa       (x1),x1   )*df(dc(xi),xi   )*eta
                     b2                                mu1 nu2

              mu2 nu1           2                    mu1
          *eta        - (dc(xi)) *df(aa       (x1),x1   )
                                        nu1 b1

                              nu2     mu1 mu2    nu1 nu2
          *df(aa       (x2),x2   )*eta       *eta        + 
                 mu2 b2

                  2                    mu1
          (dc(xi)) *df(aa       (x1),x1   )
                          nu1 b1

                              mu2     mu1 mu2    nu1 nu2
          *df(aa       (x2),x2   )*eta       *eta       )
                 nu2 b2


% simplification

res:=canonical res;


        a1 a2 b1  b2        2        mu1 
res := a        *a        *g *( - aa       (x1)*aa       (x2)
                     a1 a2               b1        mu1 b2

                                    mu2       mu1 
          *dc(xi)*df(dc(xi),xi   ,xi   ) - aa       (x1)
                              mu2                 b1

              mu2                           mu1   mu2
          *aa       (x2)*dc(xi)*df(dc(xi),xi   ,xi   )*dm + 2
                  b2

              mu1           mu2 
          *aa       (x1)*aa       (x2)*dc(xi)
                  b1            b2

                       mu1   mu2       mu1           mu2 
          *df(dc(xi),xi   ,xi   ) + aa       (x1)*aa       (x2)
                                           b1            b2

                       mu1              mu2          mu1 
          *df(dc(xi),xi   )*df(dc(xi),xi   )*dm - aa       (x1)
                                                         b1

              mu2                    mu1              mu2
          *aa       (x2)*df(dc(xi),xi   )*df(dc(xi),xi   ) - 
                  b2

             mu1 
          aa       (x1)*dc(xi)*df(aa       (x2),x2   )
                 b1                  mu1 b2       mu2

                       mu2       mu1 
          *df(dc(xi),xi   ) + aa       (x1)*dc(xi)
                                     b1

                 mu2          mu1              mu2
          *df(aa       (x2),x2   )*df(dc(xi),xi   ) + 
                     b2

             mu1 
          aa       (x2)*dc(xi)*df(aa       (x1),x1   )
                 b1                  mu1 b2       mu2

                       mu2       mu1 
          *df(dc(xi),xi   ) - aa       (x2)*dc(xi)
                                     b1

                 mu2          mu1              mu2            2
          *df(aa       (x1),x1   )*df(dc(xi),xi   ) + (dc(xi))
                     b2

                 mu1                                  mu2
          *df(aa       (x1),x1   )*df(aa       (x2),x2   ) - 
                     b1       mu2        mu1 b2

                  2       mu1 
          (dc(xi)) *df(aa       (x1),x1   )
                              b1       mu2

                              mu1
          *df(aa       (x2),x2   ))
                 mu2 b2


                %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                % last rewriting rule:             %
                % second derivative of dc(xi) with %
                %  respect to xi tensor is zero    %
                %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

dalrule:={df(dc(xi),xi(~a),xi(-~a))=>0};


                 xi   ~a
dalrule := {df(dc  ,xi  ,xi  ) => 0}
                           ~a

res:=(res where dalrule);


        a1 a2 b1  b2        2        mu1           mu2 
res := a        *a        *g *( - aa       (x1)*aa       (x2)
                     a1 a2               b1            b2

                              mu1   mu2            mu1 
          *dc(xi)*df(dc(xi),xi   ,xi   )*dm + 2*aa       (x1)
                                                       b1

              mu2                           mu1   mu2
          *aa       (x2)*dc(xi)*df(dc(xi),xi   ,xi   ) + 
                  b2

             mu1           mu2                    mu1
          aa       (x1)*aa       (x2)*df(dc(xi),xi   )
                 b1            b2

                       mu2          mu1           mu2 
          *df(dc(xi),xi   )*dm - aa       (x1)*aa       (x2)
                                        b1            b2

                       mu1              mu2       mu1 
          *df(dc(xi),xi   )*df(dc(xi),xi   ) - aa       (x1)
                                                      b1

                                                      mu2
          *dc(xi)*df(aa       (x2),x2   )*df(dc(xi),xi   ) + 
                        mu1 b2       mu2

             mu1                     mu2          mu1
          aa       (x1)*dc(xi)*df(aa       (x2),x2   )
                 b1                      b2

                       mu2       mu1 
          *df(dc(xi),xi   ) + aa       (x2)*dc(xi)
                                     b1

                                               mu2
          *df(aa       (x1),x1   )*df(dc(xi),xi   ) - 
                 mu1 b2       mu2

             mu1                     mu2          mu1
          aa       (x2)*dc(xi)*df(aa       (x1),x1   )
                 b1                      b2

                       mu2            2       mu1 
          *df(dc(xi),xi   ) + (dc(xi)) *df(aa       (x1),x1   )
                                                  b1       mu2

                              mu2            2
          *df(aa       (x2),x2   ) - (dc(xi))
                 mu1 b2

                 mu1                                  mu1
          *df(aa       (x1),x1   )*df(aa       (x2),x2   ))
                     b1       mu2        mu2 b2

canonical res - res;


0
 % gives 0
length res;


10
   
dm:=4;


dm := 4
 % particularization to 4-dimensional Minkowski space
res4:=res;


         a1 a2 b1  b2        2          mu1           mu2 
res4 := a        *a        *g *( - 2*aa       (x1)*aa       (x2)
                      a1 a2                 b1            b2

                               mu1   mu2         mu1 
           *dc(xi)*df(dc(xi),xi   ,xi   ) + 3*aa       (x1)
                                                     b1

               mu2                    mu1              mu2
           *aa       (x2)*df(dc(xi),xi   )*df(dc(xi),xi   ) - 
                   b2

              mu1 
           aa       (x1)*dc(xi)*df(aa       (x2),x2   )
                  b1                  mu1 b2       mu2

                        mu2       mu1 
           *df(dc(xi),xi   ) + aa       (x1)*dc(xi)
                                      b1

                  mu2          mu1              mu2
           *df(aa       (x2),x2   )*df(dc(xi),xi   ) + 
                      b2

              mu1 
           aa       (x2)*dc(xi)*df(aa       (x1),x1   )
                  b1                  mu1 b2       mu2

                        mu2       mu1 
           *df(dc(xi),xi   ) - aa       (x2)*dc(xi)
                                      b1

                  mu2          mu1              mu2            2
           *df(aa       (x1),x1   )*df(dc(xi),xi   ) + (dc(xi))
                      b2

                  mu1                                  mu2
           *df(aa       (x1),x1   )*df(aa       (x2),x2   ) - 
                      b1       mu2        mu1 b2

                   2       mu1 
           (dc(xi)) *df(aa       (x1),x1   )
                               b1       mu2

                               mu1
           *df(aa       (x2),x2   ))
                  mu2 b2

length res4;


8
 % 8  is the correct number of terms.



end;

3: quit;

Quitting
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/spaces.red0000644000175000017500000003457611526203062024003 0ustar  giovannigiovannimodule spaces; % definition and general properties
                     % of spaces.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


lisp remflag(list 'minus,'intfn);

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!*));

% g_dvnames is a vector.


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

fluid('(indxl_tens!* dummy_id!* g_dvnames)); % g_dvnames is a vector.

% dimex!* = global space dimension. Standard form.
% sgn!* = Choice of "global sign". Equals 1 or -1.
%         1 for high energy physicists, -1 for astrophysicists.
% !*onespace = when OFF allows to introduce a space
%              which is the direct product of two  or more spaces.
% numindxl!* := nil initially. Contains all indexranges: ((sp min max) ..)

dimex!*:= !*k2f 'dim;

sgn!* := 1; % Global sign: determine the convention (+---) ou (-+++)
                  % High energy physicists convention is chosen by default.

signat!* :=0; % number of time-like coordinates.

fluid '(alglist!*);

smacro procedure get_prop_space u;
% To get properties of a given space (subspace).
 subla(spaces!*,u);

symbolic procedure charnump!: x;
 if x memq
  list('!0,'!1,'!2,'!3,'!4,'!5,'!6,'!7,'!8,'!9,'!10,'!11,'!12,'!13)
    then t ;


symbolic procedure get_dim_space u;
 if null u then nil
    else
 (if not atom x then car x)where x=subla(spaces!*,u);

symbolic procedure get_sign_space u;
% To get the signature of a given space (subspace).
% result is nil if space is 'affine'
  if null u then nil else
  (if atom cadr x and null cddr x then
       if cadr x eq 'euclidian then 0
         else nil
    else caddr x)where x=subla(spaces!*,u);

symbolic procedure affinep u;
% u is a tensor kernel
% returns T if the the tensor belongs to an affine space.
(if x then null get_sign_space x)where x=get(car u,'belong_to_space);

symbolic procedure get_indexrange_space u;
% To get the signature of a given space (subspace).
   if null spaces!* then nil
    else
   (if x then
       if not atom x and cddr x and cdddr x then cadddr x
        else
       if cddr x and not atom caddr x then caddr x)
                           where x=if spaces!* then subla(spaces!*,u);


symbolic procedure onespace u;
% Defined specifically for the user. tells if
% one or several spaces are active.
% By default, a UNIQUE space is supposed.
 if  u eq '? then
       if !*onespace then symb_to_alg 'YES else symb_to_alg 'NO
       else nil;


symbolic procedure wholespace_dim u;
% if u is ? gives the space-dimension. else sets the space-dim.
 begin
  if  u eq '? then  return
           prepsq!* !*f2q dimex!*
    else
  if null get('wholespace,'spacedef) then
   <>;
 end;

symbolic procedure global_sign u;
% if u is ? gives the global sign else sets it.
 begin
   if  u eq '? then  return sgn!*
    else return
   sgn!* := u
 end;

symbolic procedure signature u;
% if u is ? gives the number of time-like coordinates else sets it.
 if  u eq '? then signat!*
  else
 if !*onespace and fixp u then signat!*:=u
  else "non-active in OFF ONESPACE";


flag({'onespace,'show_spaces,'wholespace_dim ,
                    'global_sign ,'signature},'opfn);

% The notion of indexrange for numeric indices is now implemented:

% taken from INEQ

newtok '( (!. !.) !*interval!*);

% first, introduction of interval through the command a .. b

if null get('!*interval!*,'simpfn) then
<>;

symbolic procedure mkinterval(u,v);
% u et v sont des entiers
% utility function not yet used for the algebraic mode
 symb_to_alg list('!*interval!*,u,v);

symbolic procedure lst_belong_interval(lst,int);
if null lst then t
  else
if idx_belong_interval(car lst,int) then lst_belong_interval(cdr lst,int)
 else nil;

symbolic procedure idx_belong_interval(idx,int);
% t if numeric index  'idx' belongs to the interval 'int'.
 if null int or atom int then t
  else idx geq car int and idx leq cadr int;

symbolic procedure numids2_belong_same_space(i1,i2,tens);
% basic function to determine if two numeric indices
% belong or not to the same space. Boolean.
% tens is the name of the tensor
  (if x and y then
       begin scalar ind,sp;
          if null numindxl!* then return t;
          ind:=if (sp:=get(tens,'belong_to_space)) then
                   list subla(numindxl!*,sp)
                else  for each x in numindxl!* collect cdr x;
       loop:  if null ind then return nil
               else
              if idx_belong_interval(x,car ind)
                and idx_belong_interval(y,car ind)
                                            then  return t
               else ind:=cdr ind;
               go to loop;
        end)where x=!*id2num i1,y=!*id2num i2;

symbolic procedure num_ids_belong_same_space(u,tens);
% u is a list of numeric indices
% tens is the name of a tensor
<< if oddp length u then u:= car u . u;
  while u and numids2_belong_same_space(car u,cadr u,tens)
  do u:=cddr u; if null u then t else nil>>;

symbolic procedure symb_ids_belong_same_space(u,v);
% u is a list of indices.
% nil is the current starting value for v but may be the
% name of one space. In that case, it verifies that all indices
% in u belong to the v space.
 if null u  or v = 'wholespace then t
  else
 if null get(car u,'space) or get(car u,'space) = v
       then symb_ids_belong_same_space(cdr u,v)
  else
 if null v then symb_ids_belong_same_space(cdr u,get(car u,'space))
  else
 if get(car u,'space) neq v then nil;

symbolic procedure symb_ids_belong_same_space!:(u,v);
% This is a variant of the previous procedure.
% needed for DEL-like tensors when working in OFF onespace
% u is a list of indices.
% nil is the current starting value for v but may be the
% name of one space. In that case, it verifies that all indices
% in u belong to the v space.
 if null u  then t
% v = 'wholespace then t NOT VALID in general since some indices
% may have a restricted range while BELONGING to a
% WELL DEFINED space. Should most probably replace it.
  else
 if null get(car u,'space) or get(car u,'space) = v
       then symb_ids_belong_same_space!:(cdr u,v)
  else
 if null v then symb_ids_belong_same_space!:(cdr u,get(car u,'space))
  else
 if get(car u,'space) neq v then nil;

symbolic procedure ind_same_space_tens(u,tens);
% u are the indices of tens.
% verify that they belong to the same space
% !!! if some indices belong to no space or to the
% wholespace it does not take them into account.
 begin scalar lst,lstnum;
 lst := clean_numid u;
 lstnum:=extract_num_id u;
 return
 if num_ids_belong_same_space(lstnum,tens) and
     symb_ids_belong_same_space(lst,get(tens,'belong_to_space))
   then t
  else nil;
 end;

rlistat ('(define_spaces rem_spaces));

symbolic procedure define_spaces u;
% Define subspaces by the commands:
% define_spaces s={ds,affine}
% or
% define_spaces s={ds,euclidean}
% or
% define_spaces s={ds,signature=,indexrange=a .. b}
  if !*onespace then nil
   else
  if not fixp sgn!* then rederr "set the global sign please" else
   begin scalar sp;rmsubs();
     for each j in u do
       if not eqexpr j then errpri2(j,'hold)
        else
       if get(sp:=cadr j,'spacedef) or
                    flagp(sp,'reserved) or getrtype sp or gettype sp
                 then
                lpri{"*** Warning:",sp,
          " cannot be (or is already) defined as space identifier"}

        else <<(put(sp,'spacedef,
                   if eqexpr caddr y then sp . cadr y . whole_space(sp,y)
                   else sp . whole_euclid_space(sp,y)))where y=caddr j;
     spaces!*:=if null assoc(sp,spaces!*) then
                          union(list get(sp,'spacedef),spaces!*);
     numindxl!* := if space_index_range sp then
                    union( list (sp . space_index_range sp),numindxl!*);>>;
     return t
   end;


symbolic procedure whole_euclid_space(sp,u);
% u is the y of define_spaces
% {ds,euclidean,indexrange=a .. b}
 (if sp eq 'wholespace then
  <> else w)where w=cdr u;


symbolic procedure whole_space(sp, u);
% u is y of define_spaces
% {ds,signature=,indexrange=a .. b}
 (if sp eq 'wholespace then
   <>
   else
  if cddr w then cadadr w . cadr cdadr w . list caddr w
   else cdadr w )where w=cdr u;

%symbolic procedure whole_space(sp, u);
% In case of emergency, I keep it!
% u is y of define_spaces
% {ds,signature=,indexrange=a .. b}
% (if sp eq 'wholespace then
%  <>
%   else
%   if cddr w then cadadr w . cadr cdadr w . list caddr w
%   else cdadr w )where w=cdr u;


symbolic procedure space_index_range u;
% u is the name of a given space
% result is
 begin scalar x;
  x:=get_indexrange_space u;
 return
  if null x then nil
   else bubblesort1( caddr cadr x . caddr x . nil)
 end;

symbolic procedure rem_spaces u;
 <>
     >>;
 t>>;

symbolic procedure mkequal u;
% u is an element of spaces!*
{'equal,'signature,cadr u};

symbolic procedure insert_sign_equal u;
% u is an element of spaces!*
 begin scalar l;
   loop: if null u then return reverse l ;
        if car u neq 'signature then <>
          else <>;
        go to loop;
  end;

symbolic procedure show_spaces();
% Gives the properties of already defined spaces
 begin scalar x;
    x:=for each i in spaces!* collect insert_sign_equal i;
    x:=for each y in x collect 'list .
             for each z in y collect if pairp z then z else mk!*sq !*k2q z;
  return 'list .  reverse x
 end;


 flag(list 'mk_ids_belong_space,'opfn);

symbolic procedure mk_ids_belong_space(u,v);
% u is a list of identifiers which are indices
% v is the name of an already defined (sub)space
% Make  all indices belong to v.
% Works ONLY when the swith onespace is OFF.
 if !*onespace then nil
  else
 if idp u then  <>
  else <>;

rlistat('(mk_ids_belong_anyspace));

symbolic procedure mk_ids_belong_anyspace u;
% makes all x in u belong to the global space.
<>;

symbolic procedure space_of_idx u;
% try to detect the space to which an index belongs to.
 begin scalar sp;
   return
   if sp:=get(u,'space) then sp
     else
   if assoc('wholespace,spaces!*) then 'wholespace
    else if length spaces!* = 1 then
           if yesp list("Does ",u," belong to ",caar spaces!*,"?")
                 then put(u,'space,caar spaces!*)
            else rerror(cantensor,4,list("Space of index ",u," unknown"))
          else
 % it is not clear that this error message should be maintained:
         msgpri(nil,nil,u, "MUST belong to a (sub)space",t);
end;

symbolic procedure space_dim_of_idx u;
% u is the name of an index
% result is the dimension of the space to which it belongs
% or an error message.
  if null !*onespace then
   begin scalar sp;
     sp:=get(u,'space);
     if null sp then return mvar dimex!*
     else  return get_dim_space sp
   end;

symbolic procedure extract_dummy_ids u;
% extracts the dummy indices from a given list
 if null u then nil
 else if car u memq dummy_id!* then
           car u . extract_dummy_ids cdr u
      else extract_dummy_ids cdr u;

rlistat('(rem_dummy_indices));

symbolic procedure rem_dummy_indices u ;
% remove property 'dummy' of all indices in u.
% redefines g_dvnames.
  <>;
    dummy_nam dummy_id!*; t>>;


symbolic procedure dummy_indices;
 symb_to_alg dummy_id!*;

 flag(list('dummy_indices),'opfn);

symbolic procedure mk_dummy_ids u;
 % u is the output of split_cov_cont_ids
 % constructs the 'dummy_id!*' and the g_dvnames globals
 % variable.
  begin scalar y;
    y:=clean_numid intersection(car u,cadr u);
    flag(y,'dummy);
    flag(y,'reserved);
    dummy_id!*:= union(y,dummy_id!*);
%    dummy_nam(dummy_id!*)
  end;

symbolic procedure mk_lst_for_dummy u;
% u is the output of index_list
% It eliminates the  minus sign
 for each x in u collect
  if atom x then x
  else
  if cadr x memq dummy_id!* then cadr x
  else x;

symbolic procedure multiplicity_elt(ob,l);
% ob is an arbitrary index, l is a list of indices
% returns the multiplicity of ob in l.
 begin integer n;
  while l:=memq(ob,l) do <>;
  return n
 end;

symbolic procedure mult_leq_onep u;
% u is a list of indices
if null u then t else
if multiplicity_elt(car u,u) leq 1 then
  mult_leq_onep(cdr u);


symbolic procedure eqn_indices(u,v);
% verify if two indices are fixed (pseudo-numbers) and equal.
(x and y and eqn(x,y))where x=!*id2num u, y=!*id2num v;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/grassman.red0000644000175000017500000000635711526203062024334 0ustar  giovannigiovannimodule grassman;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% fichier de manipulation des variables de Grassmann.
% RATIONAL functions involving Grasman variables inside the
% denominator NOT ALLOWED.
%
symbolic procedure putgrass u;
% Allows to define Grassmann  variables.
for each i in u do
  if not idp i then typerr(i,"grassman variable")
  else <> ;

rlistat '(putgrass remgrass);

symbolic procedure remgrass u;
% Erase the Grassman properties of the identifiers in  u.
for each i in u do
   if flagp(i,'grassman) then
    <>;

symbolic procedure grassp u;
not atom u and flagp(car u, 'grassman);

flag('(grassp),'boolean);

symbolic procedure grassparityini u;
% Not used anymore
if  grassp u then 1 else 0;

symbolic procedure grassparity u;
if atom u then 0 else
if flagp(car u,'grassman) then 1 else
if car u eq 'plus then "parity undefined" else
if car u eq 'minus then grassparity cadr u else
if car u eq 'times
  then remainder(for each i in cdr u sum grassparity i,2) else
if car u eq 'expt then if oddp caddr u then grassparity cadr u  else 0
else
if car u eq 'quotient then grassparity cadr u
else 0;

flag('(grassparity ghostfactor),'opfn);

symbolic procedure ghostfactor(u,v);
% (-1)^(grassparity u * grassparity v)
if reval list('times, grassparity u, grassparity v) = 0 then 1 else -1;

% *****************
% For the time being we let the explicit manipulation of
% Grassman variables as matching rules :
% here is an example of use of the previous functions :
% to try them erase the %
% putgrass eta,prond;

% grasskernel:=
% {(~x)*(~y) => y*x when grassp x and  not grassp y,
% prond(~x)*eta(~y) => -eta(y)*prond(x),
% eta(~x)*eta(~y) => -eta y*eta x when nordp(x,y),
% prond(~x)*prond(~y) => -prond y*prond x when nordp(x,y),
% (~x)*(~x) => 0 when grassp x};

% let grasskernel;
% ***********************

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/assist.red0000644000175000017500000001174711526203062024026 0ustar  giovannigiovannimodule assist; % Header Module valid for REDUCE versions from 3.5 to 3.7.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(assist sl2psl switchxt baglist hcvctors genpurfn
                  control polyexns transfns vectorop grassman matrext
                  helpasst),
                '(contrib assist));

% % *****************************************************************
%
%                Author: H. Caprasse .
%
% Version and Date:  Version 2.31, 15 January 1999.
%
% Revision history to versions 2.0 to 2.3 and 2.31:
%
% 1 Mai 1993    : Correction to SPLITTERMS and RCONS
%               : New functions CYCLICPERMLIST, APPENDN,
%               : INSERT_KEEP_ORDER
%               : CHECKPROPLIST, EXTRACTLIST, SORTNUMLIST.
% 15 Mai 1993   : LIST_TO_IDS replaces MKIDN.
%               : SORTLIST generalises SORTNUMLIST to sort list of ids
%               : ALG_TO_SYMB  et SYMB_TO_ALG created.
%               : MERGE_LIST complementary funct. to INSERT_KEEP_ORDER
% 17 May 1993   : Creation of SYMMETRIZE
% 27 May 1993   : Various modifications and improvements,
% 12 June 1993  : Corrections to UNION, SYMB_TO_ALG and SYMMETRIZE
% 20 June 1993  : Addition of several functions
%               : in the module POLYEXNS.
%               : GCDNL, NORM_MON, NORM_POL, LIST_COEFF_POL
%               : Addition of PERM_TO_NUM and NUM_TO_PERM in module
%               : 'genpurfn'
% 25 June 1993  : Various modifications and corrections.
%               : Functions involved: DEPTH, ADDFD, REMVAR!: .
% 12 Dec. 1993  : Functions CONCSUMLOG and PLUSLOG eliminated.
%               : Function ALGSORT created. It will probably replace
%               : SORTLIST and SORTNUMLIST very soon.
%               : Module 'hcvectors' added. It provides functions to
%               : manipulate symbolic vector as list and for coercion
%               : of list to vector and vice-versa. Needed to run
%               : the package 'DUMMY.RED'.
%               : Module 'SL2PSL' added. By default it is entirely
%               : commented because all psl versions of REDUCE do not
%               : need it. For the other versions some of the included
%               : functions may be needed. It suffices to remove the
%               : comment characters where needed and recompile the
%               : package.
% 20 Dec. 1993  : Function ALGNLIST introduced. Module 'hcvectors'
%               : extended to allow to make coercions from lists
%               : to arrays.
%               : LIST_to_ARRAY, ARRAY_TO_LIST available.
%               : Function MKRANDTABL created.
% 21 Dec. 1993  : Module 'HELPASST' added.
% 21 Jan. 1994  : Corrections for a proper use of number|-of|-args.
%               : Corrections to EXTRACTLIST and LOWESTDEG
% 28 Jan. 1994  : Modification of LIST2VECT. Corrections to
%               : CLEARFUNCTIONS.
% 20 Aug. 1996  : RPOSITION modified to work properly in OFF EXP.
%               : RCONS has been modified to make it compatible
%               : with the dot product of the HEPHYS package.
%               : Function MKDEPTH_ONE added.
%               : The functions PERM_TO_NUM and NUM_TO_PERM are
%               : commented.
%               : The function REMNONCOM to remove the NONCOM property
%               : has been introduced.
%               : Utility functions for the HEPHYS package are
%               : included in the module control. They are
%               : REMINDEX, REMVECTOR, MKGAM, GETMAS.
%               : Module 'HELPASST' modified. HELPASSIST ==> ASSISTHELP.
%               : Additional function ASSIST introduced.
%               : Numerous revised or corrected comments.
% 1 Jan. 1999   : MKIDM modified
% ===============================================================

 fluid '(!*ncmp);
!*ncmp:=t;

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/cantens.rlg0000644000175000017500000004607611527635055024204 0ustar  giovannigiovanniFri Feb 18 21:27:18 2011 run on win32
% Test of CANTENS.RED
%
%     Authors: H. Caprasse 
%
% Version and Date:  Version 1.1, 15 September 1998.
%----------------------------------------------------------------
off errcont;


% Default : 
onespace ?;


yes

wholespace_dim ?;


dim
  
global_sign ? ;


1
 
signature ?;


0
 
% answers to the 4 previous commands: yes, dim, 1, 0
wholespace_dim 4;


4
 
signature 1;


1

global_sign(-1);


-1

% answers to the three previous commands: 4, 1, (-1) 
% answer to the command below: {}
show_spaces();


{}

% Several spaces:
off onespace;


onespace ?;


no
 
% answer: no
show_spaces();


{}

define_spaces wholespace={6,signature=1,indexrange=0 .. 5};


t

% indexrange command is superfluous since 'wholespace':
show_spaces();


{{wholespace,6,signature=1,indexrange=0 .. 5}}

rem_spaces wholespace;


t

define_spaces wholespace={11,signature=1};


t
 
define_spaces mink={4,signature=1,indexrange=0 .. 3};


t
 
define_spaces eucl={6,euclidian,indexrange=4 .. 9};


t
 
show_spaces();


{{wholespace,11,signature=1},

 {mink,4,signature=1,indexrange=0 .. 3},

 {eucl,6,euclidian,indexrange=4 .. 9}}

%
% if input error or modifications necessary:
%
define_spaces eucl={7,euclidian,indexrange=4 .. 10};

*** Warning: eucl  cannot be (or is already) defined as space identifier 
t

%
% do:
%
rem_spaces eucl;


t

define_spaces eucl={7,euclidian,indexrange=4 .. 10};


t

show_spaces();


{{wholespace,11,signature=1},

 {mink,4,signature=1,indexrange=0 .. 3},

 {eucl,7,euclidian,indexrange=4 .. 10}}

% done
%
define_spaces eucl1={1,euclidian,indexrange=11 .. 11};


t
 
show_spaces();


{{wholespace,11,signature=1},

 {mink,4,signature=1,indexrange=0 .. 3},

 {eucl,7,euclidian,indexrange=4 .. 10},

 {eucl1,1,euclidian,indexrange=11 .. 11}}

rem_spaces wholespace,mink,eucl,eucl1;


t

show_spaces();


{}

%
% Indices can be made to belong to a subspace or replaced 
% in the whole space:
define_spaces eucl={3,euclidean};


t

show_spaces();


{{eucl,3,euclidean}}

mk_ids_belong_space({a1,a2},eucl);


t

% a1,a2 belong to the subspace eucl.
mk_ids_belong_anyspace a1,a2;


t

% replaced in the whole space.
rem_spaces eucl;


t

%%  
%% GENERIC TENSORS:
on onespace;


wholespace_dim dim;


dim

tensor te;


t
 
te(3,a,-4,b,-c,7);


  3 a   b   7
te
      4   c 
 
te(3,a,{x,y},-4,b,-c,7);


   3 a   b   7
te            (x,y)
       4   c 

te(3,a,-4,b,{u,v},-c,7);


   3 a   b   7
te            (u,v)
       4   c 

te({x,y});


te(x,y)

 
make_variables x,y;


t

te(x,y);


te(x,y)


te(x,y,a);


   a
te  (x,y)
   
 
remove_variables x;


t

te(x,y,a);


   x a
te    (y)
   

remove_variables y;


t

%
% implicit dependence:
%
operator op2;


depend op1,op2(x);


df(op1,op2(x));


df(op1,op2(x))

% the next response is 0:
df(op1,op2(y));


0

clear op2;


% case of a tensor: 
operator op1;


depend te,op1(x);

 
df(te(a,-b),op1(x));


     a 
df(te   ,op1(x))
       b

% next the outcome is 0:
df(te(a,-b),op1(y));


0

%
tensor x;


t

depend te,x;


% outcome is NOT 0:
df(te(a,-b),x(c));


     a    c
df(te   ,x )
       b

%
% Substitutions:
sub(a=-c,te(a,b));


    b
te
  c 

sub(a=-1,te(a,b));


    b
te
  1 
 
% the following operation is wrong:
sub(a=-0,te(a,b));


  0 b
te
  
% should be made as following to be correct:
sub(a=-!0,te(a,b));


    b
te
  0 
 
% dummy indices recognition
dummy_indices();


{}

te(a,b,-c,-a);


  a b 
te
      c a

dummy_indices();


{a}

te(a,b,-c,-a);


  a b 
te
      c a

dummy_indices();


{a}

% hereunder an error message correctly occurs:
on errcont;


te(a,b,-c,a);


***** ((c) (a b a)) are inconsistent lists of indices 

off errcont;


sub(c=b,te(a,b,-c,-a));


  a b 
te
      b a

dummy_indices();


{b,a}

% dummy indices suppression:
on errcont;


te(d,-d,d);


***** ((d) (d d)) are inconsistent lists of indices 

off errcont;


dummy_indices();


{d,b,a}

rem_dummy_indices d;


t

te(d,d);


  d d
te

dummy_indices();


{b,a}

rem_dummy_indices a,b;


t

onespace ?;


yes

% case of space of integer dimension:
wholespace_dim 4;


4

signature 0;


0

% 7 out of range
on errcont;


te(3,a,-b,7);


***** numeric indices out of range 

off errcont;


te(3,a,-b,3);


  3 a   3
te
      b 

te(4,a,-b,4);


  4 a   4
te
      b 

% an 'out-of-range' error is issued:
on errcont;


sub(a=5,te(3,a,-b,3));


***** numeric indices out of range 

off errcont;


signature 1;


1

% now indices should run from 0 to 3 => error: 
on errcont;


te(4,a,-b,4);


***** numeric indices out of range 

off errcont;


% correct:
te(0,a,-b,3);


  0 a   3
te
      b 

%
off onespace;


define_spaces wholespace={4,euclidean};


t

% We MUST say that te BELONG TO A SPACE, here to wholespace:
make_tensor_belong_space(te,wholespace);


wholespace

on errcont;


te(a,5,-b);


***** numeric indices out of range 

off errcont;


te(a,4,-b);


  a 4 
te
      b

rem_spaces wholespace;


t

define_spaces wholespace={5,signature=1};


t

define_spaces eucl={1,signature=0};


t

show_spaces();


{{wholespace,5,signature=1},

 {eucl,1,signature=0}}

make_tensor_belong_space(te,eucl);


eucl

te(1);


  1
te

% hereunder, an error message is issued: 
on errcont;


te(2);


***** numeric indices out of range 

off errcont;


% hereunder, an error message should be issued, it is not 
% because no indexrange has been declared:
te(0);


  0
te

rem_spaces eucl;


t

define_spaces eucl={1,signature=0,indexrange=1 .. 1};


t

% NOW an error message is issued:
on errcont;


te(0);


***** numeric indices do not belong to (sub)-space 

off errcont;


te(1);


  1
te

% again an error message:
on errcont;


te(2);


***** numeric indices do not belong to (sub)-space 

off errcont;


%
rem_dummy_indices a,b,c,d;


t

% symmetry properties:
%
symmetric te;


te(a,-b,c,d);


  a c d 
te
        b

remsym te;


antisymmetric te;


te(a,b,-c,d);


     a b d 
 - te
           c

remsym te;


% mixed symmetries:
tensor r;


t

% 
symtree(r,{!+,{!-,1,2},{!-,3,4}});


ra:=r(b,a,c,d)$

 
canonical ra;


    a b c d
 - r
 
ra:=r(c,d,a,b)$


canonical ra;


 a b c d
r

% here canonical is short-cutted
ra:=r(b,b,c,a);


ra := 0

%
% symmetrization:
on onespace;


symmetrize(r(a,b,c,d),r,permutations,perm_sign);


 a b c d    a b d c    a c b d    a c d b    a d b c    a d c b    b a c d
r        - r        - r        + r        + r        - r        - r

    b a d c    b c a d    b c d a    b d a c    b d c a    c a b d    c a d b
 + r        + r        - r        - r        + r        + r        - r

    c b a d    c b d a    c d a b    c d b a    d a b c    d a c b    d b a c
 - r        + r        + r        - r        - r        + r        + r

    d b c a    d c a b    d c b a
 - r        - r        + r

canonical ws;


    a b c d    a c b d    a d b c
8*(r        - r        + r       )

off onespace;


symmetrize({a,b,c,d},r,cyclicpermlist);


 a b c d    b c d a    c d a b    d a b c
r        + r        + r        + r

canonical ws;


    a b c d    a d b c
2*(r        - r       )

rem_tensor r;


t

% Declared bloc-diagonal tensor:
rem_spaces wholespace,eucl;


t

define_spaces wholespace={7,signature=1};


t

define_spaces mink={4,signature=1,indexrange=0 .. 3};


t

define_spaces eucl={3,euclidian,indexrange=4 .. 6};


t

show_spaces();


{{wholespace,7,signature=1},

 {mink,4,signature=1,indexrange=0 .. 3},

 {eucl,3,euclidian,indexrange=4 .. 6}}

make_tensor_belong_space(te,eucl);


eucl

make_bloc_diagonal te;


t

mk_ids_belong_space({a,b,c},eucl);


t

te(a,b,z);


  a b z
te

mk_ids_belong_space({m1,m2},mink);


t

te(a,b,m1);


0

te(a,b,m2);


0

mk_ids_belong_anyspace a,b,c,m1,m2;


t

te(a,b,m2);


  a b m2
te

% how to ASSIGN a particular component ?
% take the simplest context: 
rem_spaces wholespace,mink,eucl;


t

on onespace;


te({x,y},a,-0)==x*y*te(a,-0);


  a 
te   *x*y
    0
 
te({x,y},a,-0);


  a 
te   *x*y
    0
 
te({x,y},a,0);


   a 0
te    (x,y)
   
 
% hereunder an error message  is issued because already assigned:
on errcont;


te({x,y},a,-0)==x*y*te(a,-0);


        a 
***** te   *x*y invalid as setvalue kernel
          0

off errcont;


% clear value:
rem_value_tens te({x,y},a,-0);


t

te({x,y},a,-0);


   a 
te    (x,y)
     0
 
te({x,y},a,-0)==(x+y)*te(a,-0);


  a 
te   *(x + y)
    0

% A small illustration
te(1)==sin th * cos phi;


cos(phi)*sin(th)
 
te(-1)==sin th * cos phi;


cos(phi)*sin(th)

te(2)==sin th * sin phi;


sin(phi)*sin(th)

te(-2)==sin th * sin phi;


sin(phi)*sin(th)

te(3)==cos th ;


cos(th)

te(-3)==cos th ;


cos(th)

for i:=1:3 sum te(i)*te(-i);


        2        2          2           2        2
cos(phi) *sin(th)  + cos(th)  + sin(phi) *sin(th)

rem_value_tens te;


t

te(2);


  2
te

let te({x,y},-0)=x*y;


te({x,y},-0);


x*y

te({x,y},0);


   0
te  (x,y)
   

te({x,u},-0);


te  (x,u)
   0

for all x,a let te({x},a,-b)=x*te(a,-b);


te({u},1,-b);


  1 
te   *u
    b

te({u},c,-b);


  c 
te   *u
    b

te({u},b,-b);


  b 
te   *u
    b

te({u},a,-a);


   a 
te    (u)
     a

for all x,a clear te({x},a,-b);


te({u},c,-b);


   c 
te    (u)
     b

% rule for indices only
for all a,b let te({x},a,-b)=x*te(a,-b);


te({x},c,-b);


  c 
te   *x
    b

te({x},a,-a);


  a 
te   *x
    a

% A BUG still exists for -0 i.e. rule does NOT apply:
te({x},a,-0);


   a 
te    (x)
     0

% the cure is to use -!0 in this case
te({x},0,-!0);


  0 
te   *x
    0

%
% local rules: 
%
rul:={te(~a) => sin a};


          ~a
rul := {te   => sin(a)}

te(1) where rul;


sin(1)

% 
rul1:={te(~a,{~x,~y}) => x*y*sin(a)};


           ~a 
rul1 := {te   (~x,~y) => x*y*sin(a)}

 
%
te(a,{x,y}) where rul1;


sin(a)*x*y

te({x,y},a) where rul1;


sin(a)*x*y

%
rul2:={te(-~a,{~x,~y}) => x*y*sin(-a)};


rul2 := {te   (~x,~y) => x*y*sin( - a)}
           ~a 

% 
te(-a,{x,y}) where rul2;


 - sin(a)*x*y
 
te({x,y},-a) where rul2;


 - sin(a)*x*y

%% CANONICAL 
%
% 1. Coherence of tensorial indices.
%
tensor te,tf;

*** Warning:  te redefined as generic tensor  
t
 
dummy_indices();


{a,b}

make_tensor_belong_anyspace te;


t

on errcont;


bb:=te(a,b)*te(-b)*te(b);


            a b   b
bb := te *te   *te
        b

% hereunder an error message is issued:
canonical bb;


***** ((b) (a b b)) are inconsistent lists of indices 

off errcont;


bb:=te(a,b)*te(-b);


            a b
bb := te *te
        b

% notice how it is rewritten by canonical:
canonical bb;


  a     b
te   *te
    b

% 
dummy_indices();


{a,b}

aa:=te(d,-c)*tf(d,-c);


        d     d 
aa := te   *tf
          c     c

% if a and c are FREE no error message:
canonical aa;


  d     d 
te   *tf
    c     c

% do NOT introduce powers for NON-INVARIANT tensors:
aa:=te(d,-c)*te(d,-c);


         d   2
aa := (te   )
           c

% Powers are taken away
canonical aa;


  d 
te
    c

% A trace CANNOT be squared because powers are removed by 'canonical':
cc:=te(a,-a)^2$


canonical cc;


  a 
te
    a

%
% Correct writing of the previous squared:
cc:=te(a,-a)*te(b,-b)$


canonical cc;


  a     b 
te   *te
    a     b

% all terms must have the same variance:
on errcont;


aa:=te(a,c)+x^2;


        a c    2
aa := te    + x

canonical aa;


***** scalar added with tensor(s) 

aa:=te(a,b)+tf(a,c);


        a b     a c
aa := te    + tf

canonical aa;


***** mismatch in free indices :  ((a c) (a b)) 

off errcont;


dummy_indices();


{a,b}

rem_dummy_indices a,b,c;


t

dummy_indices();


{}

% a dummy VARIABLE is NOT a dummy INDEX
dummy_names b;


t

dummy_indices();


{}

% so, no error message in the following: 
canonical(te(b,c)*tf(b,c));


  b c   b c
te   *tf

% it is an incorrect input for a variable.
% correct input is:
canonical(te({b},c)*tf({b},c));


   c       c
te  (b)*tf  (b)
           

clear_dummy_names;


t

% contravariant indices are placed before covariant ones if possible.
% i.e. Riemanian spaces by default: 
pp:=te(a,-a)+te(-a,a)+1;


          a     a 
pp := te    + te    + 1
        a         a
 
canonical pp;


    a 
2*te    + 1
      a

pp:=te(a,-c)+te(-b,b,a,-c);


          b a       a 
pp := te        + te
        b     c       c

canonical pp;


  a       b   a 
te    + te
    c       b   c

pp:=te(r,a,-f,d,-a,f)+te(r,-b,-c,d,b,c);


        r     d b c     r a   d   f
pp := te            + te
          b c               f   a 

canonical pp;


    r a b d 
2*te
            a b

% here, a case where a normal form cannot be obtained:
tensor nt;


t

a1:=nt(-a,d)*nt(-c,a);


          d     a
a1 := nt   *nt
        a     c 

a2:=nt(-c,-a)*nt(a,d);


              a d
a2 := nt   *nt
        c a
 
% obviously, a1-a2 =0, but ....
canonical(a1-a2);


       d     a           a d
 - nt   *nt    + nt   *nt
     a     c       c a

% does give the same expression with the sign changed.
% zero is either:
canonical a1 -a2;


0

% or
a1 -canonical a2;


0

% below the result is a2:
canonical a1;


        a d
nt   *nt
  c a

% below result is a1 again: 
canonical ws;


    d     a
nt   *nt
  a     c 

%  the above manipulations are NOT DONE if space is AFFINE
off onespace;


define_spaces aff={dd,affine};


t

make_tensor_belong_space(te,aff);


aff
 
% dummy indices MUST be declared to belong 
% to a well defined space. here to 'aff':
mk_ids_belong_space({a,b},aff);


t

canonical(te(-a,a));


    a
te
  a 

canonical(te(-a,a)+te(b,-b));


    a     a 
te    + te
  a         a

canonical(te(-a,c));


    c
te
  a 

% put back  the system in the previous status: 
make_tensor_belong_anyspace te;


t

mk_ids_belong_anyspace a,b;


t

rem_spaces aff;


t

on onespace;


%
% 2. Summations with DELTA tensor.
%
make_partic_tens(delta,delta);


t

aa:=delta(a,-b)*delta(b,-c)*delta(c,-a) + 1;


           a       b       c 
aa := delta  *delta  *delta   + 1
           b       c       a

% below, answer is dim+1:
canonical aa;


dim + 1

aa:=delta(a,-b)*delta(b,-c)*delta(c,-d)*te(d,e)$


canonical aa;


  a e
te

% 3. Summations with DELTA and ETA tensors.
make_partic_tens(eta,eta);


t

signature 1;


1

aa:=eta(a,b)*eta(-b,-c);


                a b
aa := eta   *eta
         b c

canonical aa;


     a 
delta
     c

aa:=eta(a,b)*eta(-b,-c)*eta(c,d);


                a b    c d
aa := eta   *eta   *eta
         b c

canonical aa;


   a d
eta

aa:=eta(a,b)*eta(-b,-c)*eta(d,c)*te(d,-a) +te(d,d);


                a b    c d   d       d d
aa := eta   *eta   *eta   *te    + te
         b c                   a

canonical aa;


    d d
2*te

aa:=delta(a,-b)*eta(b,c);


           a     b c
aa := delta  *eta
           b

canonical aa;


   a c
eta

aa:=delta(a,-b)*delta(d,-a)*eta(-c,-d)*eta(b,c);


           a       d            b c
aa := delta  *delta  *eta   *eta
           b       a     c d

% below the answer is dim:
canonical aa;


dim

aa:=delta(a,-b)*delta(d,-a)*eta(-d,-e)*te(f,g,e);


           a       d           f g e
aa := delta  *delta  *eta   *te
           b       a     d e

canonical aa;


  f g 
te
      b

% Summations with the addition of the METRIC tensor:
make_partic_tens(g,metric);


t

g(1,2,{x})==1/4*sin x;


 sin(x)
--------
   4

g({x},1,2);


 sin(x)
--------
   4

aa:=g(a,b)*g(-a,-c);


            a b
aa := g   *g
       a c
 
canonical aa;


     b 
delta
     c

aa:=g(a,b)*g(c,d)*eta(-c,-b);


              a b  c d
aa := eta   *g   *g
         b c

% answer is g(a,d):
canonical aa;


 a d
g

tensor te;

*** Warning:  te redefined as generic tensor  
t

aa:=g(a,b)*g(c,d)*eta(-c,-e)*eta(e,f)*te(-f,g);


                e f  a b  c d     g
aa := eta   *eta   *g   *g   *te
         c e                    f 

canonical aa;


 a b   d g
g   *te

% Summations with the addition of the EPSILON tensor.
dummy_indices();


{c,f,b,a}

rem_dummy_indices a,b,c,f;


t

dummy_indices();


{}

wholespace_dim ?;


dim

signature ?;


1

% define the generalized delta function:
make_partic_tens(gd,del);


t

make_partic_tens(epsilon,epsilon);


t

aa:=epsilon(a,b)*epsilon(-c,-d);


                        a b
aa := epsilon   *epsilon
             c d

% Minus sign reflects the chosen signature.
canonical aa;


     a b
 - gd
     c d 

aa:=epsilon(a,b)*epsilon(-a,-b);


                        a b
aa := epsilon   *epsilon
             a b

canonical aa;


dim*( - dim + 1)

aa:=epsilon(a,b,c,d)*epsilon(-a,-b,-c,-e);


                            a b c d
aa := epsilon       *epsilon
             a b c e

canonical aa;


     d         3        2
delta  *( - dim  + 6*dim  - 11*dim + 6)
     e

on exdelt;


% extract delta function down to the bottom:
aa:=epsilon(a,b,c)*epsilon(-b,-d,-e);


                          a b c
aa := epsilon     *epsilon
             b d e

canonical aa;


     a       c               a       c         a       c 
delta  *delta  *dim - 2*delta  *delta   - delta  *delta  *dim
     d       e               d       e         e       d

          a       c 
 + 2*delta  *delta
          e       d

off exdelt;


% below expressed in terms of 'gd' tensor.
canonical aa;


  a c
gd    *(dim - 2)
  d e 

rem_dummy_indices a;


t

aa:=epsilon(- b,-c)*eta(a,b)*eta(a,c);


                    a b    a c
aa := epsilon   *eta   *eta
             b c

% answer below is zero:
canonical aa;


0

aa:=epsilon(a,b,c)*te(-a)*te(-b);


             a b c
aa := epsilon     *te *te
                     a   b

% below the result is again zero.
canonical aa;


0

%
tensor tf,tg;

*** Warning:  tf redefined as generic tensor  
t

aa:=epsilon(a,b,c)*te(-a)*tf(-b)*tg(-c)+epsilon(d,e,f)*te(-d)*tf(-e)*tg(-f);


             a b c                      d e f
aa := epsilon     *te *tf *tg  + epsilon     *te *tf *tg
                     a   b   c                  d   e   f

% below the result is twice the first term.
canonical aa;


         a b c
2*epsilon     *te *tf *tg
                 a   b   c

aa:=epsilon(a,b,c)*te(-a)*tf(-c)*tg(-b)+epsilon(d,e,f)*te(-d)*tf(-e)*tg(-f);


             a b c                      d e f
aa := epsilon     *te *tf *tg  + epsilon     *te *tf *tg
                     a   c   b                  d   e   f

% below the result is zero.
canonical aa;


0

% An illustration when working inside several spaces. 
rem_dummy_indices a,b,c,d,e,f;


t

off onespace;


define_spaces wholespace={dim,signature=1};


t

define_spaces sub4={4,signature=1};


t

define_spaces subd={dim-4,signature=0};


t

show_spaces();


{{wholespace,dim,signature=1},

 {sub4,4,signature=1},

 {subd,dim - 4,signature=0}}

make_partic_tens(epsilon,epsilon);

*** Warning: epsilon redefined as particular tensor 
t

make_tensor_belong_space(epsilon,sub4);


sub4

make_partic_tens(kappa,epsilon);

*** Warning: kappa MUST belong to a space 
t

make_tensor_belong_space(kappa,subd);


subd

show_epsilons();


{{kappa,subd},{epsilon,sub4}}

mk_ids_belong_space({i,j,k,l,m,n,r,s},sub4);


t

mk_ids_belong_space({a,b,c,d,e,f},subd);


t

off exdelt;


aa:=kappa(a,b,c)*kappa(-d,-e,-f)*epsilon(i,j,k,l)*epsilon(-k,-l,-i,-j);


                            i j k l                 a b c
aa := epsilon       *epsilon       *kappa     *kappa
             i j k l                     d e f

canonical aa;


        a b c
 - 24*gd
        d e f 

aa:=kappa(a,b,c)*kappa(-d,-e,-f)*epsilon(i,j,k,l)*epsilon(-m,-n,-r,-s);


                            i j k l                 a b c
aa := epsilon       *epsilon       *kappa     *kappa
             m n r s                     d e f

canonical aa;


     a b c    i j k l
 - gd      *gd
     d e f    m n r s 

end;


Time for test: 31 ms
@@@@@ Resources used: (0 0 36 14)
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/dummy.red0000644000175000017500000000546611526203062023654 0ustar  giovannigiovannimodule dummy; % Header Module for REDUCE versions from 3.5 to 3.7.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(dummy perms backtrck dummycnt),'(contrib assist));

% % *****************************************************************
%
%            Author: A. Dresse
%
%          Revision: H. Caprasse
%
% All problems should be submitted to H. Caprasse:
%     hubert.caprasse@ulg.ac.be
%
% Version and Date:  Version 1.1, 15 January 1999.
%
% This package is built on top of ASSIST.RED version 2.31 which runs in
% REDUCE 3.6 and REDUCE 3.7. and is available inside the REDUCE library.
%
% Revision history to versions 1.1 :
% %   ****************************************************************
% 30/03/95 : reference to totalcopy eliminated and replaced by
% FULLCOPY
% 15/09/98 : NODUM_VARP and LIST_IS_ALL_FREE created
%          : DV_SKELPROD corrected and modified to allow extension
%          : to tensor-like objects (!~dva introduced).
%          : DUMMY_BASE and DUMMY_NAMES modified
%          : SHOW_DUMMY_NAMES to display dummy names has been created.
%          : Several local variables eliminated.
% 01/01/99 : DV_SKEL2FACTOR1 modified.
% % ******************************************************************


load_package assist;


symbolic procedure fullcopy s;
   % A subset of the PSL totalcopy function.
   if pairp s then fullcopy car s . fullcopy cdr s
    else if vectorp s then
        begin scalar cop; integer si;
        si:=upbv s;
        cop:=mkvect si;
        for i:=0:si do putv(cop,i,fullcopy getv(s,i));
        return cop end
    else s;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/selfgra.tst0000644000175000017500000001572011526203062024176 0ustar  giovannigiovanni%%%%%%%%%%%%%%%%%%%  A. Burnel and H. Caprasse  %%%%%%%%%%%%%%%%%%%%%%
% 
% Application of CANTENS.RED 
% Date: 15/09/98
%
% Computes the gluon contribution  to the gluon self-energy in the 
% "finite" theory
% contains initially 18 terms which are reduced to 10 by cantens 
% in a dm-dimensional Minkowski space and 8 terms in a 4-dimensional 
% Minkowski space. 
% 
%          *** Will look much nicer if run in the GRAPHIC mode 
%
% LOADING CANTENS

load cantens$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Structure definitions, Minkowski space  X internal symmetry space
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

off onespace; % to be allowed to work within several subspaces

define_spaces wholespace={dm+di,signature=1};
define_spaces mink={dm,signature=1};%,indexrange=0 .. 3};
define_spaces internal={di,signature=0};%,indexrange=4 .. 11};
%
%  Memberships of indices:
mk_ids_belong_space({mu1,mu2,nu1,nu2,tau},mink);
mk_ids_belong_space({a1,a2,b1,b2,c1,c2},internal);

                         %%%%%%%%%%%%%%%%
                         % Used Tensors %
                         %%%%%%%%%%%%%%%%

%%                 variables x1,x2 and xi=x1-x2,
%%                 aa, gluon field
%%                 dd, contracted gluon field 
%%                 which appears inside the expression
%%                 a is the antisymmetric structure constant of SU3.
%%                 It is called "a" to assure that it appears first 
%%                 inside REDUCE expressions and to assure that they 
%%                 factorize in front of the output expression.
%
tensor aa,dd,a,x1,x2,xi; % tensor declaration

make_variables x1,x2,xi; % variable declaration

% declare to which subspace the declared tensors belong to.

make_tensor_belong_space(x1,mink); 
make_tensor_belong_space(x2,mink);
make_tensor_belong_space(xi,mink);
make_tensor_belong_space(a,internal);

antisymmetric a; % antisymmetry of structure constant.

  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  % building of starting expression to be manipulated  and simplified.
  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

es1:=g^2*a(a1,b1,c1)*a(a2,b2,c2);
as1:=-aa(x1,nu1,-b1)*aa(x2,nu2,-b2)*df(df(dd(xi,mu1,-c1,mu2,-c2),xi(nu1)),xi(nu2))
*dd(xi,-mu1,-a1,-mu2,-a2);
as2:=-aa(x1,nu1,-b1)*aa(x2,nu2,-b2)*df(dd(xi,mu1,-c1,mu2,-a2),xi(nu1))
*df(dd(xi,-mu1,-a1,-mu2,-c2),xi(nu2));
as3:=aa(x1,nu1,-b1)*df(aa(x2,mu2,-c2),x2(nu2))*df(dd(xi,mu1,-c1,nu2,-b2),xi(nu1))
*dd(xi,-mu1,-a1,-mu2,-a2);
as4:=aa(x1,nu1,-b1)*df(aa(x2,mu2,-c2),x2(nu2))*df(dd(xi,mu1,-c1,-mu2,-a2),xi(nu1))
*dd(xi,-mu1,-a1,nu2,-b2);
as5:=-aa(x1,nu1,-b1)*aa(x2,mu2,-a2)*df(dd(xi,mu1,-c1,nu2,-b2),xi(nu1))
*df(dd(xi,-mu1,-a1,-mu2,-c2),xi(nu2));
as6:=-aa(x1,nu1,-b1)*aa(x2,mu2,-a2)*df(df(dd(xi,mu1,-c1,-mu2,-c2),xi(nu1)),xi(nu2))
*dd(xi,-mu1,-a1,nu2,-b2);
as7:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,nu2,-b2)*df(dd(xi,nu1,-b1,mu2,-c2),xi(nu2))
*dd(xi,-mu1,-a1,-mu2,-a2);
as8:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,nu2,-b2)*df(dd(xi,-mu1,-a1,mu2,-c2),xi(nu2))
*dd(xi,nu1,-b1,-mu2,-a2);
as9:=df(aa(x1,mu1,-c1),x1(nu1))*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,nu2,-b2)
*dd(xi,-mu1,-a1,-mu2,-a2);
as10:=df(aa(x1,mu1,-c1),x1(nu1))*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,-mu2,-a2)
*dd(xi,-mu1,-a1,nu2,-b2);
as11:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-a1,-mu2,-c2),xi(nu2))
*dd(xi,nu1,-b1,nu2,-b2);
as12:=-df(aa(x1,mu1,-c1),x1(nu1))*aa(x2,mu2,-a2)*df(dd(xi,nu1,-b1,-mu2,-c2),xi(nu2))
*dd(xi,-mu1,-a1,nu2,-b2);
as13:=-aa(x1,mu1,-a1)*aa(x2,nu2,-b2)*df(dd(xi,nu1,-b1,mu2,-c2),xi(nu2))
*df(dd(xi,-mu1,-c1,-mu2,-a2),xi(nu1));
as14:=-aa(x1,mu1,-a1)*aa(x2,nu2,-b2)*dd(xi,nu1,-b1,mu2,-a2)
*df(dd(xi,-mu1,-c1,-mu2,-c2),xi(nu1),xi(nu2));
as15:=aa(x1,mu1,-a1)*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,nu2,-b2)
*df(dd(xi,-mu1,-c1,-mu2,-a2),xi(nu1));
as16:=aa(x1,mu1,-a1)*df(aa(x2,mu2,-c2),x2(nu2))*dd(xi,nu1,-b1,-mu2,-a2)
*df(dd(xi,-mu1,-c1,nu2,-b2),xi(nu1));
as17:=-aa(x1,mu1,-a1)*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-c1,-mu2,-c2),xi(nu1),xi(nu2))
*dd(xi,nu1,-b1,nu2,-b2);
as18:=-aa(x1,mu1,-a1)*aa(x2,mu2,-a2)*df(dd(xi,-mu1,-c1,nu2,-b2),xi(nu1))
*df(dd(xi,nu1,-b1,-mu2,-c2),xi(nu2));

     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     % building of the gluon contribution to gluon self-energy %
     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

es:=es1*for i:=1:18 sum mkid(as,i);

      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      % Are some terms identical ? %
      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
es:=canonical es;
length es;
% no simplification
    
tensor dc;  % new tensor
make_tensor_belong_space(dc,mink); % belongs to Minkowski space
make_partic_tens(rho,metric); % "rho" is a metric tensor
make_tensor_belong_space(rho,internal); % in the internal space

          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
          % rewriting rule and subsequent simplification %  
          % dd(mu1,mu2,a,b)=>rho(a,b)*dc(mu1,mu2)        %
          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

ddrule:={dd({~xi},~a,~b,~c,~d)=>rho(b,d)*dc({xi},a,c)};


          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
          % simplification after application of the rule % 
          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


es:=(es where ddrule);
%
es:=canonical es;


               %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
               %         Particular gauge:                       %
               % case of Fermi gauge : dc(mu1,mu2)=g(mu1,mu2)*dc %
               %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

make_partic_tens(delta,delta); % delta tenseur defined with name "delta"

% eta tenseur introduced with name "eta":
make_partic_tens(eta,eta);  
make_tensor_belong_space(eta,mink);

%  rule for the choice of gauge:

dcrule:={dc({~xi},~a,~c)=>eta(a,c)*dc(xi)};

% rewriting of the expression

res:=(es where dcrule);

% simplification

res:=canonical res;

                %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                % last rewriting rule:             %
                % second derivative of dc(xi) with %
                %  respect to xi tensor is zero    %
                %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

dalrule:={df(dc(xi),xi(~a),xi(-~a))=>0};
res:=(res where dalrule);
canonical res - res; % gives 0
length res;   
dm:=4; % particularization to 4-dimensional Minkowski space
res4:=res;
length res4; % 8  is the correct number of terms.



end;
%in "skelsplt.red";
tensor ff;
%symtree(ff,{!*,{!-,1,2},3});
symbolic procedure nordpl(u,v);
if listp u and listp v then nordp(cadr u,cadr v) else
  if listp u then nordp(cadr u,v) else
    if listp v then nordp(u,cadr v) else nordp(u,v);

flag('(nordpl),'opfn);

%frule:={df(aa({x1},~mu1,~b),x1(~mu2))=>ff({x1},-mu2,mu1,b)+df(aa({x1},-mu2,b),x1(-mu1))
%        when nordpl(mu1,mu2)};
%ffrule:={df(aa({x2},~mu1,~b),x2(~mu2))=>ff({x2},-mu2,mu1,b)+df(aa({x2},-mu2,b),x2(-mu1))
%        when nordpl(mu1,mu2)};
frule:={df(aa({~x1},~mu1,~b),~x1(~mu2))=>ff({x1},-mu2,mu1,b)+df(aa({x1},-mu2,b),x1(-mu1))
        when nordpl(mu1,mu2)};
res4 where frule;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/readme0000644000175000017500000000155211526203062023175 0ustar  giovannigiovanniThanks for your interest to our new package!

Files cantens.tst  is still in a draft status.
Some illustrations are still lacking but the main capabilities of 
the package are already displaied. 
Run the test file  both in text mode and in graphic mode (if possible) 
before using the package. The rlg file is the log of the test file run 
in TEXT mode. In graphic mode, the outputs look the same as the ones 
written usually on a sheet of paper. 

The file selfgra.tst and its log file (rlg extension) show how to make 
a non-trivial application of the package.  This application has been 
proposed by Dr. A. Burnel who is an expert in gauge theories.
We think it is a nice illustration of the capabilities of the package.

An almost complete english version of the documentation is available.

   
                
                                          HUBERT CAPRASSEmathpiper-0.81f+svn4469+dfsg3/src/packages/assist/checkind.red0000644000175000017500000000710111526203062024255 0ustar  giovannigiovannimodule checkind;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This modules contains procedures to detect indices,
% check the coherence (variance) of expressions (sum), (free indices)
% declares repeated (1 cov and 1 cont) indices as dummy.

global '(spaces!*);

fluid('(dummy_id!* g_dvnames epsilon!*));


symbolic procedure split_free_dum_ids(ltens);
% ltens est la liste qui provient de sep_tens_from_other.
% result of all_index_lst is the full set of indices.
% verify the consistency of the list of dummy indices.
% output the list (,)
  begin scalar ind,dumlist,freelist;
   ind:=split_cov_cont_ids all_index_lst ltens;
   ind:=list(clean_numid car ind,clean_numid cadr ind);
   dumlist:=intersection(car ind,cadr ind);
   verify_tens_ids ind where dummy_id!*=dumlist;
     % construct the list of covariant FREE indices:
   freelist:=for each y in setdiff(car ind,dumlist)
                                        collect lowerind y;
   % add to it the list of contravariant FREE indices
    freelist:=append(freelist,setdiff(cadr ind,dumlist));
  return list(ordn freelist,dumlist);
 end;

symbolic procedure check_ids(sf);
% check the variance consistency of the input SF
  begin  scalar dumlist, freelist, y;
  freelist:='undefined;
  while not domainp (sf) do
    <<
      y:=sep_tens_from_other (lt sf .+ nil);
      if length car y >=1
        then
          << % There are tensors, get dummy and free indices, compare
            y:= split_free_dum_ids car y;
            if freelist='undefined then freelist:=car y
              else
            if freelist neq car y then rerror(cantens,11,
                    list("mismatch in free indices : ",
                    list(car y, freelist)));
            dumlist:= union(dumlist, cadr y)
          >>
        else
       % no FREE indices
      if freelist then
           if freelist = 'undefined then freelist:=nil
             else rerror(cantens,11,"scalar added with tensor(s)");
       sf:=red sf
    >>;
  if freelist neq 'undefined then
    if (y:=repeats freelist) and extract_dummy_ids y then
      rerror(cantens,12,list("wrong use of indices",y));
  return
     if freelist='undefined or null freelist then list(nil,dumlist)
       else
     if sf then  rerror(cantens,12,"scalar added with tensor(s)")
       else  list(freelist,dumlist)
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/partitns.red0000644000175000017500000004641711526203062024366 0ustar  giovannigiovannimodule partitns;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% definitions of particular tensors.

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*);

fluid('(dummy_id!* g_dvnames epsilon!*));

% epsilon!* keeps track of the various epsilon tensors
% which may be defined when onespace is OFF
% It is a list pairs ( . )

switch exdelt; % default is OFF

switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

flag(list('delta,'epsilon,'del,'eta,'metric), 'reserved); % they are keywords.

symbolic flag(list('make_partic_tens),'opfn);

symbolic procedure make_partic_tens(u,v);
% u is a bare identifier (free of properties)
% the result is T(rue) when it suceeds to create
% the properties of being a particular tensor on u.
% can be trivially generalized to other tensors.
 if v memq {'delta,'eta,'epsilon,'del,'metric} then
 <<
    if get(u,'avalue)
% or (get(u,'reserved) and null flagp(u,'tensor))
     or getrtype u  or (gettype u eq 'procedure) or
     % is this necessary?
     (u memq list('sin,'cos,'tan,'atan,'acos,'asin,'df,'int))  then
        rerror(cantens,5,list(u,"may not be defined as tensor"))
     else
    if flagp(u,'tensor) then
      <>;
% the 'name' indicator allows to find
% the name chosen for a particular tensor from the keyword
% associated to it.
% Only ONE tensor of type 'delta' and 'eta' are allowed so:
  (if x and v memq {'delta,'eta,'del} then rem_tensor1 x)where x=get(v,'name);
   make_tensor(u,nil);  % contains the action of rem_tensor
   put(u,'partic_tens, if v = 'delta then 'simpdelt
                        else
                       if v = 'eta then 'simpeta
                        else
                       if v = 'epsilon then 'simpepsi
                        else
                       if v = 'del then 'simpdel
                        else
                       if v= 'metric then 'simpmetric);
   if null !*onespace and v = 'epsilon
        then
          if epsilon!*
                then <>
               else nil;
    put(v,'name, u);
   if v memq {'metric,'delta} then <>;
   t
 >>
      else "unknown keyword";



symbolic procedure find_name u;
% find the name of a particular tensor whose keyword is u.
% Must still be extended for u=epsilon
(if null x then
      rerror(cantens,6,{" no name found for", list u})
 else x)where x=get(u,'name);

% **** Simplification functions for particular tensors


symbolic procedure simpdelt (x,varl);
% x is is a list { indices}
% for instance (tt a (minus b)) for tt(a,-b)
% varl is the set of variables {v1,v2, ...}
% result is the simplified form of the Dirac delta function if varl is nil
% and cdr x is nil.
 If varl and null cdr x then !*k2f(car x . varl . nil) else
  if null varl or null cdr varl then
 begin scalar delt,ind,y,yv,yc;
  delt := car x; ind:= cdr x;
  y:=split_cov_cont_ids ind;
 if (length car y * length cadr y) neq 1 then
   rerror(cantens,7, "bad choice of indices for DELTA tensor");
  yv:=caar y;
  yc:=caadr y;
 % The conditional statement below can be suppressed if
 % 'wholespace' can be defined with an indexrange.
% if get(delt,'belong_to_space) eq  'wholespace then
%    if get_sign_space('wholespace) = 0 then
%      if yv='!0 or yc ='!0 then
%        rerror(cantens,2,"bad value of indices for DELTA tensor");
 if !*id2num yv and !*id2num yc then return
     if  yv=yc  then 1
      else  0
  else
  if !*onespace then return
       if yv eq yc then dimex!*
       else !*k2f(delt . append(cadr y,lowerind_lst car y))
  else return
   if null get(yv,'space) and yv eq yc then
      if  assoc('wholespace,spaces!*) then !*k2f get_dim_space 'wholespace
       else "not meaningful"
    else
   if  yv eq yc then  !*k2f space_dim_of_idx yv
     else  !*k2f(delt . append(cadr y,lowerind_lst car y))
 end
else "not meaningful";

symbolic procedure simpdel u;
% u is the list { 
% }
% when 'DEL' is used by the system through simpepsi,
% indices are already ordered and, when 'canonical' is entered,
% they are again ordered after contractions. So ordering is
% necessary only if the user enters it from the start.
% in spite of this, the procedure is made to order them
% in all cases. REFINEMENTS to avoid that are possible.
% returns a standard form.
  begin scalar del,ind,x,idv,idc,idvn,idcn,bool,spweight;
        integer free_ind,tot_ind,dim_space;
   del:= car u;
   ind:=cdr u;
   spweight:=1;
 % though it is antisymmetric separately with respect to the cov
 % and cont indices we do not declare it as such for the time being.
   x:=split_cov_cont_ids ind;
   idv:= car x; idc:=cadr x;
   if length idv neq length idc then
      rerror(cantens,7, "bad choice of indices for DEL tensor")
    else
     if null !*onespace then
       if null symb_ids_belong_same_space!:(
                     append(idv,idc),nil) then
        rerror(cantens,7, "all indices should belong to the SAME space")
    else
   if repeats idv or repeats idc then return 0
    else
   if length idc =1 then return
      apply2('simpdelt, find_name('delta) . append(lowerind_lst idv,idc),nil);
  % here we shall start to find the dummy indices which are internal
  % to 'del' as in the case del(a,b,a1..an, -a,-b,-c1, ...-cn) which
  % can be simplified to del(a1,...an,-c1, ...,-cn)*polynomial in the
  % space-dimension or a number if N_space=number
  % first arrange each list so that dummy indices are at the beginning
  % of idv and idc.
    idv:=for each y in idv collect  %au lieu de idvn
                     if null !*id2num y and memq(y,idc) then list('dum,y)
                      else y;
    idc:=for each y in idc collect
                     if null !*id2num y and memq(y,car x) then list('dum,y)
                      else y;
    if permp!:(idvn:=ordn idv,idv)=permp!:(idcn:=ordn idc,idc) then bool:=t;
    % the form of these new lists is ((dum a) (dum b) ..ak..) etc ...
   % 1. they contain only  numeric indices:
      if num_indlistp append(idvn,idcn) then
                       return simpdelnum(idvn,idcn,bool);
   % 2. some indices are symbolic:
       tot_ind:=length idvn;
   %  dummy indices can be present:
      idv:=splitlist!:(idvn,'dum); % if no dummy indices, it is nil.
       free_ind:=tot_ind - length idv;
    % now search the space in which we are working.
      dim_space:= if idv then     %% since, may be, no dummy indices
                       if null spaces!* then  dimex!*
                                else !*k2f space_dim_of_idx cadar idv;
      for i:=free_ind : (tot_ind -1) do
              <>;
       spweight:=!*a2f reval prepf spweight;
      if null idvn then
          return
          if bool then spweight
           else negf spweight;
    % left indices can again be all numeric indices
      if num_indlistp append(idvn,idcn) then
                        return
              multf(spweight,simpdelnum(idvn,idcn,bool));
    % 3. There is no more internal dummy indices, so
        return
%      if !*exdelt then
%             if bool then
%           multf(spweight,extract_delt(del,idvn,idcn,1))
%              else  negf multf(spweight,extract_delt(del,idvn,idcn,1))
%        else
      if !*exdelt then
             if bool then
           multf(spweight,extract_delt(del,idvn,idcn,'full))
              else negf multf(spweight,extract_delt(del,idvn,idcn,'full))
        else
      if length idvn=1 then
            if bool then
            multf(spweight,
                 !*k2f(find_name('delta) . append(lowerind_lst idvn,idcn)))
             else
              negf multf(spweight,
                !*k2f(find_name('delta) . append(lowerind_lst idvn,idcn)))
      else
         if bool then
           multf(spweight,!*k2f(del . append(lowerind_lst idvn ,idcn)))
          else
           multf(spweight,negf
                 !*k2f(del . append(lowerind_lst idvn , idcn)))
 end;


symbolic procedure simpdelnum(idvn,idcn,bool);
% simplification of 'DEL' when all indices are numeric.
 if idvn=idcn then
          if bool then 1
           else   -1
  else 0;

symbolic procedure extract_delt(del,idvn,idcn,depth);
% we  deal with already ordered lists. Numeric indices
% come first like (!1 !2 a). So, extraction is done from
% the left because the result simplify more.
 if length idcn =1 then
    apply2(function simpdelt,
         get('delta,'name) . lowerind car idvn . car idcn . nil,nil)
  else
      begin scalar uu,x,ind;
         ind:=car idcn;
         idcn:=cdr idcn;
         if depth =1 then
               for i:=1:length idvn do
               <>
              else
             if depth='full then
                  for i:=1:length idvn do
                  <>;
       return uu
      end;


symbolic procedure idx_not_member_whosp u;
% u is an index
(if x then x neq 'wholespace) where x=get(u,'space);

symbolic procedure ids_not_member_whosp u;
% U is a list of indices.
 if null u then t
  else
 if idx_not_member_whosp car u then ids_not_member_whosp cdr u
   else nil;

symbolic procedure simpeta u;
% u is a list { indices}
% for instance tt(a b) or tt(a -b) or tt(-a,-b)
% result is the simplified form of the Minkowski metric tensor.
  if (!*onespace and signat!*=0)
   then msgpri(nil,nil,
           "signature must be defined equal to 1 for ETA tensor",nil,t)
   else
  if
   (null !*onespace and null get_sign_space get(car u,'belong_to_space))
     then
    msgpri(nil,nil,
           "ETA tensor not properly assigned to a space",nil,nil)
      else
 begin scalar eta,ind,x;
  eta := car u; ind:= cdr u;
  flag(list eta,'symmetric);
  x:=split_cov_cont_ids ind;
  if car x  and  cadr x  then return
     apply2('simpdelt,find_name('delta) . ind,nil);
 %  Now BOTH indices are up or down, so
  x:=if null car x then cadr x else car x;
  if length x neq 2 then
   rerror(cantens,8, "bad choice of indices for ETA tensor");
  x:=for each y in x collect !*id2num y;
  return if numlis x then num_eta x
         else
  if !*onespace then !*k2f(eta . ordn ind)
  else
  if ids_not_member_whosp {car ind,cadr ind} and
        get(car ind,'space) neq get(cadr ind,'space) then 0
  else !*k2f(eta . ordn ind)
  end;


symbolic procedure num_eta u;
% u is the list of covariant or contravariant indices of ETA.
 if car u = cadr u then
       if car u = 0 then sgn!*
       else  negf sgn!*
 else 0;


symbolic procedure simpepsi u;
% Simplification procedure for the epsilon tensor.
 begin scalar epsi,ind,x,spx,bool;
  epsi := car u;
  % spx is the space epsi belongs to.
  % so we can define SEVERAL epsi tensors.
  spx:= get(epsi,'belong_to_space); % In case several spaces are used.
                                    % otherwise it is nil
  ind:= cdr u;
  flag(list epsi,'antisymmetric);
  x:=split_cov_cont_ids ind;
  if  null car x then x:='cont . cadr x
     else
     if null cadr x then  x:= 'cov . car x
     else
   x:= 'mixed . append(car x, cadr x);
 % If the space has a definite dimension we must take care of the number
 % of indices:
 (if fixp y and y neq length cdr x then
   rerror(cantens,9,
             list("bad number of indices for ", list car u," tensor"))
  )where y= if spx then get_dim_space spx
              else (if fixp z then z)where z=wholespace_dim '?;
  if repeats x then return 0;
%  if null !*onespace then one must verify that all
%  indices belong to the same space as epsi.
   if null !*onespace and spx then
    if null ind_same_space_tens(cdr u,car u) then
      rerror(cantens,9, list("some indices are not in the space of",epsi));
 return
  if car x  eq 'mixed or not num_indlistp cdr x then
   begin scalar xx,xy;
    xx:=ordn ind;
    bool:=permp!:(xx,ind);
    if car x eq 'mixed then
            <>;
    return if bool then
                     !*k2f(epsi . if car x eq 'mixed then
                                  xy else xx)
   else negf !*k2f(epsi . if car x eq 'mixed then
                                  xy else xx)
   end
   else
  % cases where all indices are numeric ones must be handled separately
  % Take the case where either no space is defined or declared. Then
  % space is euclidean.
  % look out ! spx is EUCLIDEAN by default. To avoid it, use
  % 'make_tensor_belong_space'.
  if !*onespace or null spx  then
          if signat!* =0 then num_epsi_euclid(x)
              else
          if signat!* =1 then num_epsi_non_euclid (epsi,x)
            else nil
   else
  if  null get_sign_space spx or get_sign_space spx=0
                                            then  num_epsi_euclid (cdr x)
  else
  if  get_sign_space spx =1 then num_epsi_non_euclid (epsi,x)
  else
  "undetermined signature or signature bigger then 1";
 end;


symbolic procedure num_epsi_non_euclid(epsi,ind);
% epsi is the name of the epsilon tensor
% ind is the list (cont n1 n2  nk) or (cov n1 n2 .. nk)
% result is either 0 OR +- (epsi 0 1 2 .... k))
% i.e. in terms of contravariant indices.
% So, in case of covariant indices we must take care of the
% product eta(0,0)*... *eta(spx,spx) and the convention
% sgn!* enters the game.
 begin scalar x;
 x:=ordn cdr ind;
 return if car ind eq 'cont then
             (if y then y
               else  if permp!:(x,cdr ind) then !*k2f(epsi . x)
                        else negf !*k2f(epsi . x))where
                                             y=!*q2f match_kvalue(epsi,x,nil)
           else
           if car ind eq 'cov then
                 if sgn!* = 1  then
                      if evenp length cdr x then
                        (if y then y
                           else  if permp!:(x,cdr ind) then !*k2f(epsi . x)
                                  else negf !*k2f(epsi . x))where
                                            y=!*q2f match_kvalue(epsi,x,nil)
                       else
                       (if y then negf y
                         else if permp!:(x,cdr ind) then negf !*k2f(epsi . x)
                        else  !*k2f(epsi . x))where
                                            y=!*q2f match_kvalue(epsi,x,nil)
                  else
                 if sgn!* =-1 then
                      (if y then negf y
                       else if permp!:(x,cdr ind) then negf !*k2f(epsi . x)
                              else !*k2f(epsi . x))where
                                            y=!*q2f match_kvalue(epsi,x,nil)
                 else nil
           else nil;
 end;

flag({'show_epsilons},'opfn);

symbolic procedure show_epsilons();
(if null x then {'list}
  else 'list . for each y in x collect
      list('list,mk!*sq !*k2q car y,mk!*sq !*k2q cdr y))where x=epsilon!*;


symbolic procedure match_kvalue(te,ind,varl);
% te is a tensor, result is nil or a standard form.
% Must return a standard quotient.
(if x then  simp!* cadr x)where
                          x= if varl then
                              assoc(te . varl . ind,get(te,'kvalue))
                              else assoc(te . ind,get(te,'kvalue));


symbolic procedure num_epsi_euclid(ind);
% ind is the list (i1, ...,in), therefore
% here epsi(1,2,  n)=1=epsi(-1,-2, ... -n)
  begin scalar x;
    x:=ordn ind;
  return if permp!:(x,ind) then 1
          else -1
  end;


symbolic procedure simpmetric(u,var);
% generic definition of the metric tensor
% covers the possibility of several spaces.
% may depend of any number of variables if needed.
% 'var' is {x1, .. xn}.
% receives an SF and sends back an SQ.
% CORRECTED
 begin scalar g,ind,x;
  if x:=opmtch u then return  simp x;
   g:=car u; ind:=cdr u;
  flag(list g,'symmetric);
   x:=split_cov_cont_ids ind;
  if car x  and  cadr x  then return
     apply2('simpdelt,find_name('delta) . ind,nil) ./ 1;
 %  Now BOTH indices are up or down, so
  x:=if null car x then cadr x else car x;
  if length x neq 2 then
   rerror(cantens,10, "bad choice of indices for a METRIC tensor");
   % case of numeric indices.
     x:=for each y in x collect !*id2num y;
   return if numlis x then
             if !*onespace then
                if x:= match_kvalue(g,ordn ind,var) then x
                 else !*k2f(g . if var then var . ordn ind
                                   else ordn ind) ./ 1
             else mult_spaces_num_metric(g,ind,var) ./ 1
         else
  if !*onespace then
      if x:= match_kvalue(g,ordn ind,var) then x
       else !*k2f(g . if var then var . ordn ind
                        else ordn ind) ./ 1
   else
  if get(car ind,'space) neq get(cadr ind,'space) then 0
   else
  if x:= match_kvalue(g,ordn ind,var) then x
     else !*k2f(g . if var then var . ordn ind
                     else ordn ind) ./ 1
 end;


symbolic procedure mult_spaces_num_metric(g,ind,var);
% g, is the name of the metric tensor
% ind its numeric indices (both covariant or contravariant)
  begin scalar x,y;
   x:=if pairp car ind then raiseind_lst ind else ind;
   return
   if numindxl!* and null numids2_belong_same_space(car x,cadr x,g) then  0
    else
   if y:= match_kvalue(g,if var then var . ordn ind
                                   else ordn ind,var) then y
    else !*k2f(g . if var then var . ordn ind
                     else ordn ind)
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/ctintro.red0000644000175000017500000002150211526203062024170 0ustar  giovannigiovannimodule ctintro;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid('(dummy_id!* g_dvnames));

% g_dvnames is a vector.


% patches and extensions of some functions of the packages ASSIST and
% DUMMY

%
load_package dummy;
%


% function REMSYM is generalised to take account of partial symmetries

symbolic procedure remsym u;
% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
 for each j in u do
   if flagp(j,'symmetric) then remflag(list j,'symmetric)
     else
   if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric)
     else remprop(j,'symtree);

% function SYMMETRIZE is generalized for total antisymmetrization
% and for lists of (cyclic-)permutations.

symbolic procedure sym_sign u;
% u is a standard form for the kernel of a tensor.
% if the permutation sign  of indices is + then returns u else
% returns negf u.
 (if permp!:(ordn y,y) then u else negf u)where y=car select_vars mvar u;

symbolic procedure simpsumsym(u);
% The use is SYMMETRIZE(LIST(A,B,...J),operator,perm_function,[perm_sign])
% or SYMMETRIZE(LIST(LIST(A,B,C...)),operator,perm_function,[perm_sign]).
% [perm_sign] is optional for antisymmetric sums.
% works even if tensors depend explicitly on variables.
% Works both for OPFN and symbolic procedure functions.
% Is not valid for general expressions.
 if length u geq 5 then rederr("less than 5 arguments required for symmetrize")
 else
 begin scalar ut,uu,x,res,oper,fn,sym,bool,boolfn;
  integer n, thesign;
  thesign := 1;
  fn:= caddr u;
  oper:=cadr u;
  if not idp oper then typerr(oper,"operator") else
  if null flagp(oper,'opfn) then
     if null get(oper,'simpfn) then put(oper,'simpfn,'simpiden);
     flag(list oper, 'listargp);
  sym:=if cdddr u then
          if cadddr u eq 'perm_sign then t;
  if sym and null permp!:(cdar u, ordn cdar u) then thesign:=-thesign;
if not(gettype fn eq 'procedure) then typerr(fn,"procedure");
  ut:= select_vars car u;
  uu:=(if flagp(fn,'opfn) then <>
          else  if car reval x eq 'minus then cdadr reval x
                 else cdr reval x) where x=oper . car ut;
   n:=length uu;
  x:=if listp  car uu and null flagp(oper,'tensor) and not boolfn then
                <> else
     if boolfn and listp cadr uu and null flagp(oper,'tensor) then
                <>
       else  apply1(fn,uu); % this applies to tensors
  if flagp(fn,'opfn) then x:=alg_to_symb x;
  n:=length x -1;
  if not bool then <<
     res:= if sym then sym_sign((
                 if cadr ut then oper . (cadr ut . car x)
                   else oper . car x) .** 1 .* 1 .+ nil)
             else
          (if cadr ut then  oper . (cadr ut . car x)
            else oper . car x) .** 1 .* 1 .+ nil ;
  for i:=1:n do
   << uu:=cadr x; aconc(res, if sym then  car sym_sign(
                   (if cadr ut then oper . (cadr ut . uu)
                     else oper . uu) .** 1 .* 1 .+ nil)
                              else
      (if cadr ut then  oper . (cadr ut . uu)
          else oper . uu) .** 1 .* 1); delqip(uu,x);>>;
                    >>
  else
 << res:=if sym then sym_sign((oper . list('list .
      for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil)
           else
        (oper . list('list .
         for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil;
   for i:=1:n do << uu:=cadr x;
    aconc(res, if sym then car sym_sign((oper . list('list .
                  for each j in uu collect simp!* j)) .** 1 .* 1 .+ nil)
                else (oper . list('list .
                 for each i in uu collect mk!*sq simp!* i)) .** 1 .* 1 );
     delqip(uu,x);>>;
 >>;
  return
  if get(oper,'tag) eq 'list then
        simp!*('list . for each w in res collect caar w)
   else
     resimp (multf(!*n2f thesign,res) ./ 1)
end;

%load_package dummyn;

% modifications to dummy.red:

% patch to dummy.red

symbolic procedure dummy_nam u;
% creates the required global vector for dummy.red
% A variant of dummy_names from  DUMMY.
% No declaration flag(..,'dummy) here since
% it is done inside 'mk_dummy_ids'
 <>;


% This part redefines some of the dummy procedures
% to make it tolerate the covariant-contravariant indices.
% and tensors with NO indices.

symbolic procedure dv_skelsplit(camb);
  begin scalar  var_camb,skel, stree, subskels;
        integer count, ind, maxind, thesign;
  thesign := 1;
  var_camb:=if listp camb  then
              if listp cadr camb and caadr camb = 'list then cadr camb;
    if (ind := dummyp(camb)) then
      return {1, ind, ('!~dv . {'!*, ind})}
     else
    if not listp camb  or (var_camb and null cddr camb)
                                      then  return {1, 0, (camb . nil)};
  stree := get(car camb, 'symtree);
   if not stree then
    <<
    stree := for count := 1 : length(if var_camb then cddr camb      %%
                                       else cdr camb) collect count;  %%
    if flagp(car  camb, 'symmetric) then
      stree := '!+ . stree
    else if flagp(car camb, 'antisymmetric) then
      stree := '!- . stree
    else
      stree := '!* . stree
    >>;
  subskels := mkve(length(if var_camb then cddr camb else cdr camb)); %%
  count := 0;
  for each arg in (if var_camb then cddr camb else cdr camb) do   %%
    <<
    count := count + 1;
    if (ind := dummyp(arg)) then
      <<
      maxind := max(maxind, ind);
    if idp arg then  putve(subskels, count, ('!~dv . {'!*, ind}))
                else putve(subskels, count, ('!~dva . {'!*, ind}))
      >>
    else
      putve(subskels, count, (arg . nil));
    >>;
  stree := st_sorttree(stree, subskels, function idcons_ordp);
  if stree and (car stree = 0) then return nil;
  thesign := car stree;
  skel := dv_skelsplit1(cdr stree, subskels);
  stree := st_consolidate(cdr skel);
  skel := if var_camb then (car camb) . var_camb . car skel    %%
           else car camb . car skel;                            %%
  return {thesign, maxind, skel . stree};
  end;


symbolic procedure dummyp(var);
% takes into account the new features i.e.
% some indices may be !0, !1 ....
% others are covariant indices i.e. (minus !), (minus a) etc ...
  begin scalar varsplit;
        integer count, res;
  if listp var then
    if ( careq_minus var) then var:= cadr var
      else return nil;
  if numberp(var) or (!*id2num var)
    then return nil;
  count := 1;
  while count <= upbve(g_dvnames) do
    <<
   if var = venth(g_dvnames, count) then
    <<
      res := count;
      count := upbve(g_dvnames) + 1
      >>
    else
      count := count + 1;
    >>;
  if res = 0 then
    <<
    varsplit := ad_splitname(var);
    if (car varsplit eq g_dvbase) then
      return cdr varsplit
    >>
  else return res;
  end;


symbolic procedure dv_skel2factor1(skel_kern, dvars);
% Take into account of the two sets of generic dummy variables.
% One for the ordinary and contravariant dummy variables, another for
% covariant variables.
% !~dva regenerate COVARIANT dummy variables.
 begin scalar dvar,scr;
   if null skel_kern then return nil;
  return
   if listp skel_kern then
    <>
    else
   if skel_kern eq '!~dv then
       <<
         dvar := car dvars;
         if cdr dvars then
           <<
               rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars);
            >>;
       dvar
       >>
    else
   if skel_kern eq '!~dva then
      <<
        dvar := car dvars;
        if cdr dvars then
          <<
            rplaca(dvars, cadr dvars); rplacd(dvars, cddr dvars);
        >>;
      ('minus . dvar . nil)
      >>
    else
       skel_kern;
  end;


% end of patch to dummy

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/cantens.red0000644000175000017500000001110611526203062024140 0ustar  giovannigiovannimodule cantens; % header module tested for REDUCE 3.6 and 3.7.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(cantens ctintro auxitens gentens spaces
                   partitns checkind opertens contrtns),
                '(contrib cantens));


% This package requires ASSIST and DUMMY.
%
% ************************************************************************
%
%     Authors: H. Caprasse 
%            : F. Fontaine 
%
% Version and Date:  Version 1.11, 15 January 1999.
%
% November 2008 - changed by H Caprasse to use the BSD license as above.
%
% Revision history to versions 1.0 and 1.1:
% 15/12/98 : Flag 'LOOSE' removed on DEPENDS in order to
%          :  allow its redefinition in CSL.
%          : SIMPTENSOR, NUM_EPSI_NON_EUCLID, MATCH_KVALUE and
%          : SIMPMETRIC  modified.
%          : MAKE_PARTIC_TENS no longer protected by the 'reserved'
%          : flag.
%          : Modifications to SYMTREE_ZEROP and DV_SKEL2FACTOR1
%          : to allow proper compilation under CSL.
%% ******************************************************************
%
% an extension of the REDUCE command 'depend':
% patch to extend depend to tensors...

  remflag('(depends),'loose); % because of csl

symbolic procedure depends(u,v);
   if null u or numberp u or numberp v then nil
    else if u=v then u
    else if atom u and u memq frlis!* then t
      %to allow the most general pattern matching to occur;
    else if (lambda x; x and ldepends(cdr x,v)) assoc(u,depl!*)
     then t
    else if not atom u and idp car u and get(car u,'dname) then
        (if depends!-fn then apply2(depends!-fn,u,v) else nil)
           where (depends!-fn = get(car u,'domain!-depends!-fn))
    else if not atom u
      and (ldepends(cdr u,v) or depends(car u,v)) then t
    else if atom v or idp car v and get(car v,'dname) then nil
    % else dependsl(u,cdr v);
    else if flagp(u,'tensor) and pairp v and u=car v then t
    else nil;

% an "importation" from EXCALC:

symbolic procedure permp!:(u,v);
% True if v is an even permutation of u NIl otherwise.
    if null u then t else if car u = car v then permp!:(cdr u,cdr v)
     else not permp!:(cdr u,subst(car v,car u,cdr v));

% global and fluid variables defined.

lisp remflag(list 'minus,'intfn);

global '(dimex!* sgn!*  signat!* spaces!* numindxl!* pair_id_num!*) ;


lisp (pair_id_num!*:= '((!0 . 0) (!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4)
                        (!5 . 5) (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9)
                        (!10 . 10) (!11 . 11) (!12 . 12) (!13 . 13)));

fluid('(dummy_id!* g_dvnames epsilon!*));

% g_dvnames is a vector.


switch onespace;

!*onespace:=t;  % working inside a unique space is the default.

%  Various smacros

smacro procedure id_cov u;
   % to get the covariant identifier
   % u is the output of get_n_index
   cadr u;

smacro procedure id_cont u;
   % to get the contravariant identifier
   % u is the output of get_n_index
   u;

smacro procedure careq_tilde u;
   eqcar(u,'!~);

smacro procedure careq_minus u;
   eqcar(u,'minus);

smacro procedure lowerind u;
   list('minus,u);

smacro procedure raiseind u;
   cadr u;

smacro procedure id_switch_variance u;
 if eqcar(u,'minus) then cadr u
                    else list ('minus, u);


smacro procedure get!-impfun!-args u;
   % Get dependencies of id u.
   cdr assoc(u,depl!*);

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assist/polyexns.red0000644000175000017500000002137211526203062024374 0ustar  giovannigiovannimodule polyexns;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Additional functions which manipulate polynomials.

switch distribute;

symbolic procedure fix_or_str u;
fixp u or stringp u;

symbolic procedure rgcdnl u;
% Searches the common gcd of all the integers inside the list u.
( if length x = 1 then abs car x else
 eval expand(x,'gcdn) ) where x=cdr revlis car u;

put('gcdnl,'psopfn,'rgcdnl);

symbolic procedure alg_to_symb u;
% transforms standard quotient expressions into prefix symbolic ones.
% dd => (LIST 1 (!*SQ ((((A . 2) . 1)) . 1) T)
% !*SQ ((((A . 1) . 1)) . 1) T) 3 (LIST 4))
% alg_to_symb dd ==> (1 (EXPT A 2) A 3 (4))
%
if null u  then nil else
if atom u then  u else
if car u neq 'list then reval u else
if car u eq 'list  then
  for each i in cdr u collect alg_to_symb i;

symbolic procedure symb_to_alg u;
% transforms prefix lisp list into an algebraic list.
% if null u then nil else
if null u then list('list) else
if fix_or_str u  then u else
if atom u then mk!*sq simp!* u  else
if listp u and  (getd car u or get(car u,'simpfn) )
                                 then  mk!*sq simp!* u else
if atomlis u then 'list . for each i in u collect
        if null i then list('list) else
        if fix_or_str i then i else
                            mk!*sq simp!* i
else
  'list . for each i in u collect symb_to_alg i ;

algebraic procedure mkdepth_one x;
% Flattens an algebraic list.
% Not clear if it is really useful.
lisp symb_to_alg flattens1 alg_to_symb algebraic x;

% Elementary functions to manipulate polynomials in
% a DISTRIBUTIVE way.

symbolic procedure addfd (u,v);
% It contains a modification to ADDF to avoid
% a recursive representation.
% U and V are standard forms. Value is a standard form.
if null u then v
else if null v then u
else if  domainp u then addd(u,v)
else if  domainp v then addd(v,u)
else if ordp(lpow u,lpow v)
then lt u .+ addfd(red u,v)
else lt v .+ addfd (u,red v);

symbolic procedure distribute u;
% Works ONLY when RATIONAL is ON.
 begin scalar s, !*rational;
!*rational:=t;
 s:=simp!* u;
 return mk!*sq (distri!_pol(numr s) ./ denr s)
end;

flag('(distribute),'opfn);

symbolic procedure distri!_pol u;
% This function assumes that u is a polynomial given
% as a standard form. It transforms its recursive representation into
% a distributive representation.
if null u then nil else
if atom u then u else
if red u  then
   addfd(distri!_pol !*t2f lt u,distri!_pol red u)
     else
 begin scalar x,y;
 x:=1 ;
 y:=u;
 while  not atom y and null red y do
                        <>;
 if atom y then return multf(x,y) else
 return
 addfd(distri!_pol multf(x,distri!_pol !*t2f lt y),
       distri!_pol multf(x,distri!_pol red y))
end;

symbolic procedure leadterm u;
<>;

flag('(leadterm redexpr ),'opfn);

symbolic procedure redexpr u;
<>;

% Various decompositions.

symbolic procedure list!_of!_monom u;
% It takes a polynomial in distributive form.
% returns a list of monoms.
% u is numr simp!* (algebraic expression)
% if domainp u then u else  ELIMINATED
begin scalar exp,lmon,mon;
     exp:=u;
% l:  if null exp then return lmon ; OLD statement
l:  if null exp then return lmon else
    if domainp exp then return exp . lmon ;
    mon:=if atom exp then exp else lt exp;
    lmon:=(!*t2f mon ) . lmon;
    exp:=red exp;
     go to l;
end;

symbolic procedure monom y;
if !*rational then rederr "MONOM does only work on rings of integers"
else
begin scalar x;
x:=numr simp!* y;
x:=distri!_pol x;
x:=reversip list!_of!_monom x;
x:=for each m in x collect mk!*sq(m ./ 1);
return 'list . x end;

flag('(monom),'opfn);

symbolic procedure coeff_mon u;
% argument is lt numr simp!* "algebraic value".
if atom u then u else
coeff_mon((if atom x then x else lt x)where x=red u);

algebraic procedure list_coeff_pol u;
% Gives the list of coefficients of multivariate polynomial u.
% Terms are distributed.
for each i in monom u collect (lisp coeff_mon (if atom i then i else
                                                    lt numr simp!* i));

algebraic procedure norm_mon u;
% Sets the coefficient of the monom u to 1.
if u=0 then 0 else u/(lisp coeff_mon lt numr simp!* algebraic u);

algebraic procedure norm_pol u;
% Tries to put the leading coefficient to 1 i.e. u to normal form.
% If not, it puts the coefficient of the leading term positive.
if u=0 then 0 else
        begin scalar uu,sign;
        uu:=list_coeff_pol u;
        sign:=first uu /(abs first uu);
       if gcdnl uu = abs first uu then return u:= u/first uu
        else return sign * u
        end ;

symbolic procedure pol_ordp(u,v);
% u and v are multivariate polynomials.
% General ordering function.
(x>;
    aa:=qremf(poln,pold)$
 aa:=mksq(list('list ,prepsq!*( car aa . 1), prepsq!*(cdr aa . 1)),1)$
    if not ratsav then off rational;
    return  aa end$

put('divpol,'simpfn,'!&dpol)$

symbolic procedure lowestdeg(u,v)$
% It extracts the lowest degree in v of the polynomial u.
 begin scalar x,y,uu,vv;
    uu:=simp!* u$
   if domainp uu then return 0;
    uu:=!*q2f uu;
    vv:=erase_pol_cst uu;
    if vv neq uu then return 0;
    vv:=!*a2k v;
    x:=setkorder list v;
    y:=reorder uu; setkorder x;
    y:=reverse y;
    uu:=mvar y;
    if not atom uu then if car uu eq 'expt then
         rederr("exponents must be integers")$
    if uu neq vv then return 0 else
        return  ldeg y
 end;

flag('(lowestdeg),'opfn)$

symbolic procedure erase_pol_cst u;
% u is a standard form.
if null u or numberp u then nil
 else lt u . erase_pol_cst red u;


% Splitting functions.

% For instance 'splitterms' returns a list of plus-terms and minus-terms.

symbolic operator splitterms;

symbolic procedure splitterms u;
   begin scalar a,b;
     if fixp u and evallessp(u, 0) then return
           'list . ('list . 0 . nil) . ('list .  list('minus, u)
                                                       . nil) . nil
     else if
        atom u  or not(car u member(list('plus,'minus))) then  return
           'list . ('list . u . nil) . ('list . 0 . nil) . nil
     else if
        car u eq 'minus then return
           'list . ('list . 0 . nil) . ('list . cdr u) . nil;
     while(u:=cdr u) do
        if atom car u or not (caar u eq 'minus) then a:= car u . a
         else b:=cadar u . b;
     if null a then a:=0 . nil;
     if null b then b:=0 . nil;
     return 'list . ('list . reversip a) . ('list . reversip b) . nil;
   end;

algebraic procedure splitplusminus(u);
% Applies to rational functions.
% u ==> {u+,u-}
 begin scalar uu;
  uu:=splitterms num u;
  return list((for each j in first uu sum j) /den u,
            - (for each j in second uu sum j)/den u)
 end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/0000755000175000017500000000000011722677364021774 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xideal.rlg0000644000175000017500000001551611527635055023752 0ustar  giovannigiovanniFri Feb 18 21:27:53 2011 run on win32

*** ^ redefined 
% Test file for XIDEAL package (Groebner bases for exterior algebra)

% Declare EXCALC variables

pform {x,y,z,t}=0,f(i)=1,{u,u(i),u(i,j)}=0;




% Reductions with xmodideal (all should be zero)

d x^d y      xmodideal {d x - d y};


0

d x^d y^d z  xmodideal {d x^d y - d z^d t};


0

d x^d z^d t  xmodideal {d x^d y - d z^d t};


0

f(2)^d x^d y xmodideal {d t^f(1) - f(2)^f(3),
                         f(3)^f(1) - d x^d y};


0

d t^f(1)^d z xmodideal {d t^f(1) - f(2)^f(3),
                         f(1)^d z - d x^d y,
                         d t^d y - d x^f(2)};


0

f(3)^f(4)^f(5)^f(6)
             xmodideal {f(1)^f(2) + f(3)^f(4) + f(5)^f(6)};


0

f(1)^f(4)^f(5)^f(6)
             xmodideal {f(1)^f(2) + f(2)^f(3) + f(3)^f(4)
                        + f(4)^f(5) + f(5)^f(6)};


0

d x^d y^d z  xmodideal {x**2+y**2+z**2-1,x*d x+y*d y+z*d z};


0



% Changing the division between exterior variables and parameters

xideal {a*d x+y*d y};


  d x*a + d y*y
{---------------}
        a

xvars {a};


xideal {a*d x+y*d y};


{d x*a + d y*y,d x^d y}

xideal({a*d x+y*d y},{a,y});


{d x*a + d y*y,

 d x^d y*y}

xvars {};

       % all 0-forms are coefficients
excoeffs(d u - (a*p - q)*d y);


{1, - a*p + q}

exvars(d u - (a*p - q)*d y);


{d u,d y}

xvars {p,q};

    % p,q are no longer coefficients
excoeffs(d u - (a*p - q)*d y);


{ - a,1,1}

exvars(d u - (a*p - q)*d y);


{d y*p,d y*q,d u}

xvars nil;




% Exterior system for heat equation on 1st jet bundle

S := {d u - u(-t)*d t - u(-x)*d x,
      d u(-t)^d t + d u(-x)^d x,
      d u(-x)^d t - u(-t)*d x^d t};


s := { - d t*u  + d u - d x*u ,
              t              x

       - (d t^d u  + d x^d u ),
                 t          x

      u *d t^d x - d t^d u }
       t                  x


% Check that it's closed.

dS := d S xmodideal S;


ds := {}



% Exterior system for a Monge-Ampere equation

korder d u(-y,-y),d u(-x,-y),d u(-x,-x),d u(-y),d u(-x),d u;


M := {u(-x,-x)*u(-y,-y) - u(-x,-y)**2,
      d u       -  u(-x)*d x   -  u(-y)*d y,
      d u(-x) - u(-x,-x)*d x - u(-x,-y)*d y,
      d u(-y) - u(-x,-y)*d x - u(-y,-y)*d y}$



% Get the full Groebner basis

gbdeg := xideal M;


                            2
gbdeg := {u   *u    - (u   ) ,
           x x  y y     x y

          d u - d x*u  - d y*u ,
                     x        y

          d u  - d x*u    - d y*u   ,
             x        x x        x y

          d u  - d x*u    - d y*u   }
             y        x y        y y


% Changing the term ordering can be dramatic

xorder gradlex;


gradlex

gbgrad := xideal M;


                             2
gbgrad := {u   *u    - (u   ) ,
            x x  y y     x y

            - d u + d x*u  + d y*u ,
                         x        y

            - d u  + d x*u    + d y*u   ,
                 y        x y        y y

            - d u  + d x*u    + d y*u   ,
                 x        x x        x y

           d u ^d x + d u ^d y,
              x          y

            - d u *u    + d u *u   ,
                 x  y y      y  x y

            - d u *u    + d u *u   ,
                 x  x y      y  x x

           d u ^d u ,
              y    x

           d u *u  - d u*u    + d y*u   *u  - d y*u *u   ,
              y  x        x y        x y  y        x  y y

           d u *u  - d u*u    + d y*u   *u  - d y*u   *u ,
              x  x        x x        x x  y        x y  x

           u *d x^d y + d u^d x,
            y

           u   *d x^d y + d u ^d x,
            y y              y

           d u^d x^d y,

            - u   *d u^d y + u *d u ^d y - d u ^d u,
               x y            y    x          x

            - u   *d u^d y + u *d u ^d y,
               x x            x    x

           u   *d u^d y + u *d u ^d x + d u ^d u,
            y y            y    x          y

           d u ^d x^d y,
              x

           d u ^d u^d y,
              x

           d u ^d u^d x,
              x

            - u   *d u^d x + u *d u ^d x,
               y y            y    y

           d u ^d u^d x}
              y


% But the bases are equivalent

gbdeg xmod gbgrad;


{}

xorder deglex;


deglex

gbgrad xmod gbdeg;


{}



% Some Groebner bases

gb := xideal {f(1)^f(2) + f(3)^f(4)};


        1  2    3  4
gb := {f ^f  + f ^f ,

        2  3  4
       f ^f ^f ,

        1  3  4
       f ^f ^f }

gb := xideal {f(1)^f(2), f(1)^f(3)+f(2)^f(4)+f(5)^f(6)};


        1  3    2  4    5  6
gb := {f ^f  + f ^f  + f ^f ,

        1  2
       f ^f ,

        2  5  6
       f ^f ^f ,

        2  3  4    3  5  6
       f ^f ^f  - f ^f ^f ,

        1  5  6
       f ^f ^f ,

        3  4  5  6
       f ^f ^f ^f }



% Non-graded ideals

% Left and right ideals are not the same

d t^(d z+d x^d y) xmodideal {d z+d x^d y};


0

(d z+d x^d y)^d t xmodideal {d z+d x^d y};


 - 2*d t^d z


% Higher order forms can now reduce lower order ones

d x xmodideal {d y^d z + d x,d x^d y + d z};


0


% Anything whose even part is a parameter generates the trivial ideal!!

gb := xideal({x + d y},{});


gb := {1}

gb := xideal {1 + f(1) + f(1)^f(2) + f(2)^f(3)^f(4) + f(3)^f(4)^f(5)^f(6)};


gb := {1}

xvars nil;




% Tracing Groebner basis calculations

on trxideal;


gb := xideal {x-y+y*d x-x*d y};


Input Basis

xpoly(1)= - x^d y + d x^y + x - y


New Basis

xpoly(1)=x^d y - d x^y - x + y


wedge_pair{d y,1} -> xpoly(2)=d x^y^d y - x^d y + y^d y

spoly_pair{2,1} -> xpoly(3)=x^x - 2*x^y + y^y

spoly_pair{1,3} -> xpoly(4)=x^d x^y - 2*x^y^d y + y^y^d y + x^x - x^y

spoly_pair{4,3} -> 0

spoly_pair{4,1} -> 0

spoly_pair{2,4} -> criterion 1 hit

wedge_pair{d x,4} -> 0

wedge_pair{d x,2} -> xpoly(5)=x^d x - x^d y - d x^y + y^d y

New Basis

xpoly(1)=x^d y - d x^y - x + y


xpoly(2)=d x^y^d y - x^d y + y^d y


xpoly(3)=x^x - 2*x^y + y^y


xpoly(4)=x^d x - x^d y - d x^y + y^d y


spoly_pair{4,3} -> 0

spoly_pair{4,1} -> 0

spoly_pair{2,4} -> criterion 1 hit

wedge_pair{d x,4} -> 0

        2            2
gb := {x  - 2*x*y + y ,

        - d x*y + d y*x - x + y,

       d x*x - 2*d x*y + d y*y - x + y,

        - d x*y + d y*y + d x^d y*y - x + y}

off trxideal;




% Same thing in lexicographic order, without full reduction

xorder lex;


lex

off xfullreduce;


gblex := xideal {x-y+y*d x-x*d y};


gblex := {d x*y - d y*y - d x^d y*y + x - y,

          d x*y - d y*x + x - y}


% Manual autoreduction

gblex := xauto gblex;


gblex := {d x*y - d y*y - d x^d y*y + x - y}



% Tracing reduction

on trxmod;


first gb xmod gblex;

x^x - 2*x^y + y^y =

   x^(x - d x^y^d y + d x^y - y^d y - y) +

   (d x^y^d y)^(x - d x^y^d y + d x^y - y^d y - y) +

   ( - d x^y)^(x - d x^y^d y + d x^y - y^d y - y) +

   (y^d y)^(x - d x^y^d y + d x^y - y^d y - y) +

   ( - y)^(x - d x^y^d y + d x^y - y^d y - y) +

   0

0



% Restore defaults

on xfullreduce;


off trxideal,trxmod;


xvars nil;


xorder deglex;


deglex



end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 12 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xideal.red0000644000175000017500000001632311526203062023721 0ustar  giovannigiovannimodule xideal;
%
%                               XIDEAL V2.4
%
%
% Authors:        David Hartley
%                GMD - German National Research Center
%                      for Information Technology
%                D-53754 St Augustin
%                Germany
%
%                email:   David.Hartley@gmd.de
%
%
%               Philip A Tuckey
%                Laboratoire de Physique Mol\'eculaire,
%                Universit\'e de Franche-Comt\'e,
%                25030 Besan\c{}con,
%                France
%
%                email:   pat@rs1.univ-fcomte.fr
%
%
% Description:   Tools for calculations with ideals of polynomials in
%               exterior algebra. Uses Groebner basis algorithms
%               described in D Hartley and P A Tuckey, "A direct
%               characterisation of Groebner bases in Clifford and
%               Grassmann algebras", Preprint MPI-Ph/93-96 1993, and J
%               Apel "A relationship between Groebner bases of ideals
%               and vector modules of G-algebras", Contemp
%               Math 131(1992)195.
%
% Requires:      REDUCE 3.6 patched to 25 Apr 96 or later
%
% Created:          5/8/92  V0      as ideal.red
%
% Modified:      4/3/94  V1      Renamed xideal.red
%                               Compiles independently
%                               Converted right reduction and spolys to
%                               left
%                               Added graded lexicographical ordering
%                               Enabled non-graded ideals
%                               Fixed trivial ideal bug
%                               Removed subform
%                               Renamed xtrace -> xstats
%               1/12/94 V2      Enable 2-sided ideals
%                               Enable p-forms with p >= 0
%               8/12/95  Added subs2 checking in reduction
%               19/1/96 V2.2    Added subs2 checking in xrepartit
%                               Added resimp before subs2
%                               Fixed rtypes of operators
%               16/4/96 V2.3    Added exvars and excoeffs
%
%
% Algebraic mode entry points
%
% xorder k;
%  establishes the term order, where k is one of lex, gradlex (graded by
%  number of factors in term) or deglex (graded by exterior degree of
%  term.)
%
% xvars U,V,W,...;
%  declares which degree 0 kernels are to be regarded as polynomial
%  variables (rest are coefficient parameters). U,V,W can be variables
%  or lists of variables. xvars nil, restores the default, in which all
%  declared 0-forms are polynomial variables.
%
% xideal(S) xideal(S,V,r) or xideal(S,r)
%  calculates an exterior Groebner basis for the list of generator S,
%  with optional 0-form variables V, optionally up to degree r.
%
% xmodideal(F,S) or F xmodideal S
%  reduces F with respect to an exterior Groebner basis for the list of
%  generators S. F may be either a single exterior form,
%  or a list of forms.
%
% xmod(F,S) or F xmod S
%  reduces F with respect to the set of exterior polynomials S, which is
%  not necessarily a Groebner basis. F may be either a single
%  exterior form, or a list of forms. This routine can be used in
%  conjunction with xideal to produce the same effect as xmodideal:
%         F xmodideal S = F xmod xideal(S,exdegree F).
%
% xauto(S)
%  autoreduces the polynomials in S.
%
% exvars(F)
%  returns polynomials variables (as defined by xvars) from F
%
% excoeffs(F)
%  returns polynomials coefficients (as defined by xvars) from F
%
% Switches
%
% xfullreduce   - Allows reduced Groebner bases to be calculated
%                    (default ON)
% trxideal       - Trace spoly and wedge poly production (default OFF)
% trxmod - Trace reduction to normal form (default OFF)
%
% ======================================================================

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Need EXCALC loaded first.

load_package 'excalc;

create!-package('(

     xideal  % Header module
     xgroeb  % GB calculation
     xreduct % Normal form algorithms
     xcrit   % Critical pairs, critical values
     xpowers % Powers, including div relation and lcm.
     xstorage        % Storage and retrieval of critical pairs and polynomials.
     xaux    % Auxiliary functions for XIDEAL
     xexcalc % Modifications to Eberhard Schruefer's excalc

                ),'(contrib xideal));

% Switches

fluid '(!*xfullreduce !*trxideal !*twosided !*trxmod);

switch xfullreduce,trxideal,twosided,trxmod;

!*xfullreduce   := t;    % whether to autoreduce GB
!*trxideal      := nil;  % display new polynomials added to GB
!*twosided      := nil;  % construct GB for two-sided ideal
!*trxmod        := nil;  % display reduction chains


% Global variables

fluid '(xvars!* xtruncate!* xvarlist!* xdegreelist!* zerodivs!*
        xpolylist!*);

xvars!*         := t;    % list of variables to include in partition
xtruncate!*     := nil;  % degree at which to truncate GB
xvarlist!*      := {};   % variables in current problem
xdegreelist!*   := {};   % a-list of degrees of variables
zerodivs!*      := {};   % odd degree variables
xpolylist!*     := {};   % internal list for debugging only

% Macros used in other modules

smacro procedure xkey pr;
  car pr;

smacro procedure pr_type pr;
  cadr pr;

smacro procedure pr_lhs pr;
  caddr pr;

smacro procedure pr_rhs pr;
  cadddr pr;

smacro procedure empty_xset;
  '!*xset!* . nil;

smacro procedure empty_xsetp c;
  null cdr c;

smacro procedure xset_item c;
  car c;


% Macros from other packages for compilation

smacro procedure ldpf u;                   % from excalc
   %selector for leading standard form in patitioned sf;
   caar u;

smacro procedure !*k2pf u;                 % from excalc
   u .* (1 ./ 1) .+ nil;

smacro procedure negpf u;                  % from excalc
   multpfsq(u,(-1) ./ 1);

smacro procedure get!*fdeg u;                      % from excalc
   (if x then car x else nil) where x = get(u,'fdegree);

smacro procedure get!*ifdeg u;                     % from excalc
   (if x then cdr x else nil)
    where x = assoc(length cdr u,get(car u,'ifdegree));

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xexcalc.red0000644000175000017500000001200211526203062024070 0ustar  giovannigiovannimodule xexcalc;

% Modifications to Eberhard Schruefer's excalc

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. The core routines in EXCALC have symbols:

        wedgepf2: pf,wedgepf -> wedgepf
        wedgek2:  lpow pf,lpow wedgepf -> wedgepf
        addpf: pf,pf -> pf
        addpf: wedgepf,wedgepf -> wedgepf

The overloading on addpf makes it hard to modify to use a different
order: the following routines cannot guarantee that ordering of terms
in a polynomial will be the same in pf or wedgpf representation.

endcomment;


global '(dimex!*);


symbolic procedure addpf(u,v);
% change to use termordp!! rather than ordop
   if null u then v
    else if null v then u
    else if ldpf u = 1 then addmpf(u,v)
    else if ldpf v = 1 then addmpf(v,u)
    else if ldpf u = ldpf v then
       (lambda x,y;
        if null numr x then y else ldpf u .* x .+ y)
       (addsq(lc u,lc v),addpf(red u,red v))
    else if termordp!!(ldpf u,ldpf v) then lt u .+ addpf(red u,v)
    else lt v .+ addpf(u,red v);


symbolic procedure termordp!!(u,v);
   % u,v:lpow pf|lpow wedgepf -> termordp!!:bool
   % as for termordp, but trying to accomodate wedgepf and pf terms
   u neq v and
   termordp(guesspftype u,guesspftype v);


symbolic procedure guesspftype u;
   % u:lpow pf|lpow wedgepf -> guesspftype:lpow pf
   % if we have pform x=1,y=1,x(i)=1, then we can't tell whether
   % (x y) means x^y or x(y). Here we choose the former.
   if atom u then u
   else if car u memq '(wedge d partdf hodge innerprod liedf) then u
   else if assoc(length cdr u,get(car u,'ifdegree)) and
           not xvarlistp cdr u then u
   else mknwedge u;


symbolic procedure xvarlistp x;
   % x:list of kernel -> xvarlistp:bool
   % heuristic to check if x is a list of pform variables
   null x or xvarp car x and xvarlistp cdr x;


symbolic procedure addmpf(u,v);
% add extra test for vanishing coefficient
   if null v then u
    else if ldpf v = 1 then
      (if numr x then 1 .* x .+ nil) where x = addsq(lc u,lc v)
    else lt v .+ addmpf(u,red v);


symbolic procedure deg!*form u;
%U is a prefix expression. Result is the degree of u;
% add !*sq prefix forms
   if atom u then get!*fdeg u
    else (if flagp(x,'indexvar) then get!*ifdeg u
           else if x eq 'wedge then deg!*farg cdr u
           else if x eq 'd then addd(1,deg!*form cadr u)
           else if x eq 'hodge then addf(dimex!*,negf deg!*form cadr u)
           else if x eq 'partdf then if cddr u then nil else -1
           else if x eq 'liedf then deg!*form caddr u
           else if x eq 'innerprod then addd(-1,deg!*form caddr u)
           else if x memq '(plus minus difference quotient) then
                     deg!*form cadr u
           else if x eq 'times then deg!*farg cdr u
           else if x eq '!*sq then deg!*form prepsq simp!* u
           else nil) where x = car u;


% The following two routines are copied from the development version of
% excalc to overcome an error message "+++ oddp nil" in the CSL version.


symbolic procedure oddp m;
   if not fixp m then typerr(m,"integer") else remainder(m,2) neq 0;


symbolic procedure wedgek2(u,v,w);
   if u eq car v and null eqcar(u,'wedge)
      then if (fixp n and oddp n) where n = deg!*form u then nil
            else multpfsq(wedgef(u . v),mksgnsq w)
    else if eqcar(car v,'wedge) then wedgek2(u,cdar v,w)
    else if eqcar(u,'wedge)
            then multpfsq(wedgewedge(cdr u,v),mksgnsq w)
    else if wedgeordp(u,car v)
            then multpfsq(wedgef(u . v),mksgnsq w)
    else if cdr v
            then wedgepf2(!*k2pf car v,
                          wedgek2(u,cdr v,addf(w,multf(deg!*form u,
                                                   deg!*form car v))))
    else multpfsq(wedgef list(car v,u),
                  mksgnsq addf(w,multf(deg!*form u,deg!*form car v)));


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xcrit.red0000644000175000017500000001220411526203062023576 0ustar  giovannigiovannimodule xcrit;

% Critical pairs, critical values

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Critical pairs are stored as

        crit_pr ::= {key, type, pf, pf}
        key     ::= mon
        type    ::= 'spoly_pair | 'wedge_pair | 'xcomm_pair

endcomment;


fluid '(xvarlist!* zerodivs!* xtruncate!* !*twosided);


symbolic procedure critical_pairs(q,p,c);
   % q,p:list of pf, c:xset -> critical_pairs:xset
   % add critical pairs for new poly's q to existing xset c,
   % which is based on old poly's p.
   begin scalar f;
   foreach l on q do
     begin
     f := car l;
     foreach g in cdr l do
       (if pr then add_item(pr,c)) where pr = make_spoly_pair(f,g);
     foreach g in p do
       (if pr then add_item(pr,c)) where pr = make_spoly_pair(f,g);
     foreach x in zerodivs!* do
       (if pr then add_item(pr,c)) where pr = make_wedge_pair(x,f);
     foreach x in if !*twosided then xvarlist!* do
       (if pr then add_item(pr,c)) where pr = make_xcomm_pair(x,f);
     end;
   return c;
   end;


symbolic procedure remove_critical_pairs(G,P);
   % G:list of pf, P:xset -> remove_critical_pairs:xset
   % Remove critical pairs for old poly's G from existing xset P.
   <>;


symbolic procedure make_spoly_pair(f,g);
   % f,g:pf -> make_spoly_pair:crit_pr|nil
   % construct critical pair (spoly) for f and g in canonical order
   % return nil if simple criteria fail
   if pfordp(g,f) then make_spoly_pair(g,f) else
   and(t,
       red f or red g,
       not triviallcm(l,xval f,xval g),
       not xdegreecheck mknwedge l,
       {l,'spoly_pair,f,g})
   where l = xlcm(xval f,xval g);


symbolic procedure triviallcm(l,p,q);
   % l,p,q:mon -> triviallcm:bool
   % l is xlcm(p,q), result is t if l = p . q
   xdiv(p,l) = q;


symbolic procedure xdegreecheck u;
   % u:lpow pf -> xdegreecheck:bool
   % result is t if degree of u exceeds truncation
   % degree in graded GB's
   xtruncate!* and xdegree u > xtruncate!*;


symbolic procedure make_wedge_pair(x,f);
   % x:kernel, f:pf -> make_wedge_pair:crit_pr|nil
   % construct critical pair (wedge) for x and f
   % return nil if simple criteria fail
   and(!*twosided and not xtruncate!* or x memq xval f,
       not overall_factor(x,f),
       not xdegreecheck mknwedge l,
       {l,'wedge_pair,!*k2pf x,f})
   where l = xlcm({x,x},xval f);


symbolic procedure overall_factor(x,f);
   % x:kernel,f:pf -> overall_factor:bool
   null f or x memq xval f and overall_factor(x,red f);


symbolic procedure make_xcomm_pair(x,f);
   % x:kernel, f:pf -> make_xcomm_pair:crit_pr|nil
   % construct critical pair (commutator) for x and f
   % return nil if simple criteria fail
   and(!*twosided,
       not xtruncate!*,       % left ideal = right ideal if homogeneous.
       {xval f,'xcomm_pair,!*k2pf x,f});


symbolic procedure critical_element pr;
   % pr:crit_pr -> critical_element:pf
   % calculate a critical element for pr
   apply1(pr_type pr,pr);


symbolic procedure spoly_pair pr;
   % pr:crit_pr -> spoly_pair:pf
   % calculate a critical element for pr
   begin scalar l,f,g;
   f := pr_lhs pr; g := pr_rhs pr;
   l := xkey pr;
   f := wedgepf(!*k2pf mknwedge xdiv(xval f,l),f); % left multiplication
   g := wedgepf(!*k2pf mknwedge xdiv(xval g,l),g); % left multiplication
   return addpf(multpfsq(f,lc g),negpf multpfsq(g,lc f)); % normalise?
   end;


symbolic procedure wedge_pair pr;
   % pr:crit_pr -> wedge_pair:pf
   % calculate a critical element for pr
   if !*twosided and not xdiv(xval pr_lhs pr,xval pr_rhs pr) then
     wedgepf(wedgepf(pr_lhs pr,pr_rhs pr),pr_lhs pr) % split cofactor
   else wedgepf(pr_lhs pr,pr_rhs pr);


symbolic procedure xcomm_pair pr;
   % pr:crit_pr -> xcomm_pair:pf
   % calculate a critical element for pr
   addpf(wedgepf(pr_lhs pr,pr_rhs pr),
         if evenp xdegreemon xval pr_rhs pr
            then wedgepf(pr_rhs pr,negpf pr_lhs pr)
            else wedgepf(pr_rhs pr,pr_lhs pr));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xaux.red0000644000175000017500000002064411526203062023441 0ustar  giovannigiovannimodule xaux;

% Auxiliary functions for XIDEAL

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



Comment.  The routines in EXCALC sometimes use a new type, here called
wedgepf, internally.  It has the same structure as a pf, but the powers
are lists of factors in an implicit wedge product.  The WEDGE tag may
or may not be present.  A pf, typically a 0- or 1-form, can be
converted to this type using mkunarywedge.  More general routines for
converting pf <-> wedgepf are provided here.

It is not necessary for the WEDGE kernels passed to the EXCALC product
routines to be unique (and the output is not), hence two conversions
lpow wedgepf -> lpow pf are given below: mkuwedge constructs a unique
kernel, while mknwedge may be non-unique.  The results of the product
routine wedgepf defined here are unique.

endcomment;


symbolic procedure !*wedgepf2pf f;
   % f:wedgepf -> !*wedgepf2pf:pf
   if null f then nil
   else mkuwedge lpow f .* lc f .+ !*wedgepf2pf red f;


symbolic procedure !*pf2wedgepf f;
   % f:wedgepf -> !*pf2wedgepf:pf
   if null f then nil
   else wedgefax lpow f .* lc f .+ !*pf2wedgepf red f;


symbolic procedure mkuwedge u;
   % u:list of kernel -> mkuwedge:lpow pf
   % result is a unique kernel
   if cdr u then car fkern('wedge . u) else car u;


symbolic procedure mknwedge u;
   % u:list of kernel -> mknwedge:lpow pf
   % result is a non-unique kernel
   if cdr u then 'wedge . u else car u;


symbolic procedure wedgefax u;
   % u:lpow pf -> wedgefax:list of kernel
   if eqcar(u,'wedge) then cdr u else {u};


symbolic procedure wedgepf(u,v);
   % u,v:pf -> wedgepf:pf
   !*wedgepf2pf wedgepf2(u,!*pf2wedgepf v);


Comment.  The list xvars!* is used to decide which 0-form kernels are
counted as parameters and which as variables ("xvars") in partitioned
pf's.  The xvars statement allows this list to be set.

endcomment;


fluid '(xvars!*);

rlistat '(xvars);

symbolic procedure xvars u;
   % u:list of prefix -> xvars:nil
   begin
   xvars!* := if u = {nil} then t else xvarlist u;
   end;


symbolic procedure xvarlist u;
   % u:list of prefix -> xvarlist:list of kernel
   % recursively evaluate and expand lists
   for each x in u join
      if eqcar(x := reval x,'list) then xvarlist cdr x
      else {!*a2k x};


symbolic procedure xpartitsq u;
   % u:sq -> xpartitsq:pf
   % Leaves unexpanded structure if possible
   (if null x then nil
    else if domainp x then 1 .* u .+ nil
    else addpf(if sfp mvar x then
                  wedgepf(xexptpf(xpartitsq(mvar x ./ 1),ldeg x),
                          xpartitsq cancel(lc x ./ y))
               else if xvarp mvar x then
                  wedgepf(xexptpf(xpartitk mvar x,ldeg x),
                          xpartitsq cancel(lc x ./ y))
               else
                  multpfsq(xpartitsq cancel(lc x ./ y),
                           !*p2q lpow x),
               xpartitsq(red x ./ y)))
    where x = numr u, y = denr u;


symbolic procedure xpartitk k;
   % k:kernel -> xpartitk:pf
   % k is an xvar. If k is not a variable (eg a wedge product)
   % then its arguments may need reordering if they've been through subf1.
   if memqcar(k,'(wedge partdf)) then
      (if j=k then !*k2pf k else xpartitop j) where j=reval k
   else !*k2pf k;


symbolic procedure xpartitop u;
   xpartitsq simp!* u;


symbolic procedure xexptpf(u,n);
   % u:pf,n:posint -> xexptpf:pf
   if n = 1 then u
   else wedgepf(u,xexptpf(u,n-1));


symbolic procedure xvarp u;
   % u:kernel -> xvarp:bool
   % Test for exterior variables: p-forms (incl. p=0) and vectors
   % xvars!* controls whether 0-forms are included: if t, then all
   % 0-forms are included, otherwise only those in xvars!*.  Forms of
   % degree other than 0 are always included.  If xvars!* contains x,
   % then sin(x) is not an xvar (unless explicitly listed) since it is
   % algebraically independent.
   % Should the last line be exformp u?
   if xvars!* neq t then
      xdegree u neq 0 or u memq xvars!*
   else if atom u then
      get(u,'fdegree)
   else if flagp(car u,'indexvar) then
      assoc(length cdr u,get(car u,'ifdegree))
   else
      car u memq '(wedge d partdf hodge innerprod liedf);


symbolic operator excoeffs;
symbolic procedure excoeffs u;
   begin scalar x;
   u := 1 .+ xpartitop u;
   while (u := red u) do
      x := mk!*sq lc u . x;
   return makelist reverse x;
   end;


symbolic operator exvars;
symbolic procedure exvars u;
   begin scalar x;
   u := 1 .+ xpartitop u;
   while (u := red u) do
      x := lpow u . x;
   return makelist reverse x;
   end;


% Various auxilliary functions


symbolic procedure xdegree f;
   % f:prefix -> xdegree:int
   % This procedure gives the degree of a homogeneous form (deg!*form in
   % excalc returns nil for 0-forms). Behaves erratically with
   % inhomogeneous forms.
   (if null x then 0 else x) where x = deg!*form f;



symbolic procedure xhomogeneous f;
   % f:pf ->  xhomogeneous:int or nil
   % Result is degree of f if homogeneous, otherwise nil.
   if null f then 0
   else if null red f then xdegree lpow f
   else (if d = xhomogeneous red f then d) where d = xdegree lpow f;


symbolic procedure xmaxdegree f;
   % f:pf -> xmaxdegree:int
   % Returns the maximum degree among the terms of f
   if null f then 0
   else max(xdegree lpow f,xmaxdegree red f);


symbolic procedure xnormalise f;
   % f:pf -> xnormalise:pf
   % rescale f so that the leading coefficient is 1
   if null f then nil
   else if lc f = (1 ./ 1) then f
   else multpfsq(f,invsq lc f);


symbolic procedure subs2pf f;
   % f:pf -> subs2pf:pf
   % Power check for pf. Only leading term is guaranteed correct.
   if f then
      (if numr c then lpow f .* c .+ red f else subs2pf red f)
         where c = subs2 resimp lc f;


symbolic procedure subs2pf!* f;
   % f:pf -> subs2pf!*:pf
   % Power check for pf. All terms guaranteed correct.
   if f then
    (if numr c then lpow f .* c .+ subs2pf!* red f else subs2pf!* red f)
         where c = subs2 resimp lc f;


% Partitioned form printing


symbolic procedure !*pf2a f;
   % f:pf -> !*pf2a:!*sq prefix
   % Returns 0-form ^ 0-form to 0-form * 0-form.
   mk!*sq !*pf2sq repartit f;


symbolic procedure !*pf2a1(f,v);
   % f:pf, v:bool -> !*pf2a1:prefix
   % !*sq prefix if v null, else true prefix.
   % Returns 0-form ^ 0-form to 0-form * 0-form.
   !*q2a1(!*pf2sq repartit f,v);


symbolic procedure preppf f;
   % f:pf -> preppf:prefix
   % produce a partitioned prefix form
   if null(f := preppf0 f) then 0
   else if length f = 1 then car f
   else 'plus . f;


symbolic procedure preppf0 f;
   % f:pf -> preppf0:list of prefix
   % produce a list of prefix terms
   % prepsq!* takes out over minus signs
   if null f then nil
   else preppf1(lpow f,prepsq!* lc f) . preppf0 red f;


symbolic procedure preppf1(k,c);
   % k:lpow pf, c:prefix -> preppf1:prefix
   % extract an overall minus sign, and expand an overall product
   if k = 1 then c
   else if c = 1 then k
   else if eqcar(c,'minus) then {'minus,preppf1(k,cadr c)}
   else if eqcar(c,'times) then append(c,{k})
   else if eqcar(c,'quotient) and eqcar(cadr c,'minus) then
      preppf1(k,{'minus,{'quotient,cadr cadr c,caddr c}})
   else {'times,c,k};


symbolic procedure printpf f;
   % f:pf -> printpf:nil
   % A simple printing routine for use in tracing
   mathprint preppf f;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xstorage.red0000644000175000017500000000736611526203062024316 0ustar  giovannigiovannimodule xstorage;

% Storage and retrieval of critical pairs and polynomials.

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Critical pairs and polynomials are stored in a search tree,
         called an xset here:

        xset            ::= empty_xset | item . xset
        empty_xset      ::= any . nil
        item            ::= any

All changes to xset are made destructively as side-effects.

endcomment;


symbolic smacro procedure xset_ptrs c;
   cdr c;


symbolic smacro procedure left_xset c;
   cadr c;


symbolic smacro procedure right_xset c;
   cddr c;


symbolic procedure find_item(pr,c);
   % pr:item, c:xset -> find_item:xset|nil
   % if pr in c, returns pointer to pr, otherwise nil
   if empty_xsetp c then nil
   else find_item(pr,left_xset c) or
        (if xset_item c = pr then c) or
        find_item(pr,right_xset c);


symbolic procedure add_item(pr,c);
   % pr:item, c:xset -> add_item:nil
   % add new item pr to structure c as side-effect
   % goes left iff xkey pr < xkey xset_item c
   if empty_xsetp c then
    <>
   else if monordp(xkey xset_item c,xkey pr) then
      add_item(pr,left_xset c)
   else
      add_item(pr,right_xset c);


symbolic procedure remove_item(pr,c);
   % pr:item, c:xset -> remove_item:item or nil
   % deletes pr, if present, from c as side-effect
   if c := find_item(pr,c) then remove_root_item c;


symbolic procedure remove_least_item c;
   % c:xset -> remove_least_item:item
   % returns "least" item in structure and deletes it as side-effect
   if empty_xsetp c then rederr "How did we get here?"
   else if empty_xsetp left_xset c then remove_root_item c
   else remove_least_item left_xset c;


symbolic procedure remove_root_item c;
   % c:xset -> remove_root_item:item
   % deletes first item in c, which is not empty
   begin scalar x,y;
   x := left_xset c; y := xset_item c;
   xset_item c := xset_item right_xset c;
   xset_ptrs c := xset_ptrs right_xset c;
   if not empty_xsetp x then % graft x onto the left-most part of c
    <>;
   return y;
   end;


symbolic procedure remove_items(c,u);
   % c:xset of lists, u:list -> remove_items:nil
   % removes all items containing elements of u from c
   begin
   if empty_xsetp c then return;
   remove_items(left_xset c,u);
   remove_items(right_xset c,u);
   if xnp(u,xset_item c) then remove_root_item c;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xideal.tst0000644000175000017500000000551711526203062023764 0ustar  giovannigiovanni% Test file for XIDEAL package (Groebner bases for exterior algebra)

% Declare EXCALC variables

pform {x,y,z,t}=0,f(i)=1,{u,u(i),u(i,j)}=0;


% Reductions with xmodideal (all should be zero)

d x^d y      xmodideal {d x - d y};
d x^d y^d z  xmodideal {d x^d y - d z^d t};
d x^d z^d t  xmodideal {d x^d y - d z^d t};
f(2)^d x^d y xmodideal {d t^f(1) - f(2)^f(3),
                         f(3)^f(1) - d x^d y};
d t^f(1)^d z xmodideal {d t^f(1) - f(2)^f(3),
                         f(1)^d z - d x^d y,
                         d t^d y - d x^f(2)};
f(3)^f(4)^f(5)^f(6)
             xmodideal {f(1)^f(2) + f(3)^f(4) + f(5)^f(6)};
f(1)^f(4)^f(5)^f(6)
             xmodideal {f(1)^f(2) + f(2)^f(3) + f(3)^f(4)
                        + f(4)^f(5) + f(5)^f(6)};
d x^d y^d z  xmodideal {x**2+y**2+z**2-1,x*d x+y*d y+z*d z};


% Changing the division between exterior variables and parameters

xideal {a*d x+y*d y};
xvars {a};
xideal {a*d x+y*d y};
xideal({a*d x+y*d y},{a,y});
xvars {};       % all 0-forms are coefficients
excoeffs(d u - (a*p - q)*d y);
exvars(d u - (a*p - q)*d y);
xvars {p,q};    % p,q are no longer coefficients
excoeffs(d u - (a*p - q)*d y);
exvars(d u - (a*p - q)*d y);
xvars nil;


% Exterior system for heat equation on 1st jet bundle

S := {d u - u(-t)*d t - u(-x)*d x,
      d u(-t)^d t + d u(-x)^d x,
      d u(-x)^d t - u(-t)*d x^d t};

% Check that it's closed.

dS := d S xmodideal S;


% Exterior system for a Monge-Ampere equation

korder d u(-y,-y),d u(-x,-y),d u(-x,-x),d u(-y),d u(-x),d u;
M := {u(-x,-x)*u(-y,-y) - u(-x,-y)**2,
      d u       -  u(-x)*d x   -  u(-y)*d y,
      d u(-x) - u(-x,-x)*d x - u(-x,-y)*d y,
      d u(-y) - u(-x,-y)*d x - u(-y,-y)*d y}$

% Get the full Groebner basis

gbdeg := xideal M;

% Changing the term ordering can be dramatic

xorder gradlex;
gbgrad := xideal M;

% But the bases are equivalent

gbdeg xmod gbgrad;
xorder deglex;
gbgrad xmod gbdeg;


% Some Groebner bases

gb := xideal {f(1)^f(2) + f(3)^f(4)};
gb := xideal {f(1)^f(2), f(1)^f(3)+f(2)^f(4)+f(5)^f(6)};


% Non-graded ideals

% Left and right ideals are not the same

d t^(d z+d x^d y) xmodideal {d z+d x^d y};
(d z+d x^d y)^d t xmodideal {d z+d x^d y};

% Higher order forms can now reduce lower order ones

d x xmodideal {d y^d z + d x,d x^d y + d z};

% Anything whose even part is a parameter generates the trivial ideal!!

gb := xideal({x + d y},{});
gb := xideal {1 + f(1) + f(1)^f(2) + f(2)^f(3)^f(4) + f(3)^f(4)^f(5)^f(6)};
xvars nil;


% Tracing Groebner basis calculations

on trxideal;
gb := xideal {x-y+y*d x-x*d y};
off trxideal;


% Same thing in lexicographic order, without full reduction

xorder lex;
off xfullreduce;
gblex := xideal {x-y+y*d x-x*d y};

% Manual autoreduction

gblex := xauto gblex;


% Tracing reduction

on trxmod;
first gb xmod gblex;


% Restore defaults

on xfullreduce;
off trxideal,trxmod;
xvars nil;
xorder deglex;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xreduct.red0000644000175000017500000001753011526203062024132 0ustar  giovannigiovannimodule xreduct;

% Normal form algorithms

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



fluid '(!*trxmod !*trxideal xtruncate!*);


infix xmod;
precedence xmod,freeof;
put('xmod,'rtypefn,'getrtypecar);
put('xmod,'listfn,'xmodlist);
put('xmod,'simpfn,'simpxmod);


symbolic procedure simpxmod u;
   % u:{prefix,prefix} -> simpxmod:sq
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmod");
   x := getrlist aeval cadr u;
   return !*pf2sq repartit xreduce(xpartitop car u,
                                   for each g in x join
                                      if g := xpartitop g then {g});
   end;


symbolic procedure xmodlist(u,v);
   % u:{prefix,prefix},v:bool -> xmodlist:prefix
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmod");
   x := getrlist aeval cadr u;
   u := foreach f in getrlist aeval car u collect xpartitop f;
   x := for each f in x join
           if f := xpartitop f then {f};
   return makelist foreach f in u join
      if f := xreduce(f,x) then {!*q2a1(!*pf2sq repartit f,v)};
   end;


infix xmodideal;
precedence xmodideal,freeof;
put('xmodideal,'rtypefn,'getrtypecar);
put('xmodideal,'listfn,'xmodideallist);
put('xmodideal,'simpfn,'simpxmodideal);


symbolic procedure simpxmodideal u;
   % u:{prefix,prefix} -> simpxmodideal:sq
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmodideal");
   x := getrlist aeval cadr u;
   u := xpartitop car u;
   xtruncate!* := xmaxdegree u;
   x := for each f in x join if f := xpartitop f then {f};
   foreach f in x do if not xhomogeneous f then xtruncate!* := nil;
   x := xidealpf x where !*trxmod = nil; % is this desirable?
   return !*pf2sq repartit xreduce(u,x);
   end;


symbolic procedure xmodideallist(u,v);
   % u:{prefix,prefix},v:bool -> xmodideallist:prefix
   begin scalar x;
   if length u neq 2 then
      rerror(xideal,0,"Wrong number of arguments to xmodideal");
   x := getrlist aeval cadr u;
   u := foreach f in getrlist aeval car u collect xpartitop f;
   xtruncate!* := eval('max . foreach f in u collect xmaxdegree f);
   x := for each f in x join if f := xpartitop f then {f};
   foreach f in x do if not xhomogeneous f then xtruncate!* := nil;
   x := xidealpf x where !*trxmod = nil; % is this desirable?
   return makelist foreach f in u join
      if f := xreduce(f,x) then {!*q2a1(!*pf2sq repartit f,v)};
   end;


put('xauto,'rtypefn,'quotelist);
put('xauto,'listfn,'xautolist);

symbolic procedure xautolist(u,v);
   % u:{prefix},v:bool -> xautolist:prefix
   begin scalar x;
   if length u neq 1 then
      rerror(xideal,0,"Wrong number of arguments to xauto");
   u := foreach f in getrlist aeval car u collect xpartitop f;
   return makelist foreach f in xautoreduce u join
      {!*q2a1(!*pf2sq repartit f,v)};
   end;


symbolic procedure xreduce(f,p);
   % f:pf, p:list of pf -> xreduce:pf
   % returns left normal form of f wrt p
   % l contains reduction chain (not used at present).
   begin scalar g,l;
   l := nil . nil;
   if !*trxmod then
    <>;
   return g;
   end;


symbolic procedure xreduce1(f,p,l);
   % f:pf, p:list of pf, l:list of {pf,pf} -> xreduce1:pf
   % Returns left normal form of f wrt p. Chain of reducing poly's and
   % cofactors stored in l as side-effect.
   if (f := weak_xreduce1(f,p,l)) then lt f .+ xreduce1(red f,p,l);


symbolic procedure weak_xreduce(f,p);
   % f:pf, p:list of pf, result:pf
   % Returns weak left normal form of f wrt p (i.e. lpow f is
   % irreducible).
   begin scalar g,l;
   l := nil . nil;
   if !*trxmod then
    <>;
   return g;
   end;


symbolic procedure weak_xreduce1(f,p,l);
   % f:pf, p:list of pf, l:list of {pf,pf} -> weak_xreduce1:pf
   % Returns weak left normal form of f wrt p (i.e. lpow f is
   % irreducible).
   % Chain of reducing poly's and cofactors stored in l as side-effect.
   begin scalar q,g,h,c,r;
   q := p;
   while f and q do
     begin
     g := car q; q := cdr q;
     if (r := xdiv(xval g,xval f)) then
       begin
       r := !*k2pf mknwedge r;
       h := wedgepf(r,g); % NB: left multiplication here
       c := quotsq(lc f,lc h);
       f := subs2pf addpf(f,multpfsq(h,negsq c));
       if !*trxmod then l := nconc(l,{{multpfsq(r,c),g}});
       if !*trxmod then
        <>;
       q := p;
       end;
     end;
   return f;
   end;


symbolic procedure xautoreduce F;
   % F:list of pf -> weak_xautoreduce:list of pf
   % returns autoreduced form of F,
   % sorted in increasing order of leading terms
   xautoreduce1 weak_xautoreduce F;


symbolic procedure xautoreduce1 G;
   % G:list of pf -> xautoreduce1:list of pf
   % G is weakly autoreduced, result is autoreduced and sorted
   begin scalar H;
   H := reversip sort(G,'pfordp); % otherwise need to reduce wrt H too.
   G := {};
   while H do
     begin scalar k;
     k := car H; H := cdr H;
     k := xreduce(k,G);
     if k then G := k . G;
     end;
   return reversip G;
   end;


symbolic procedure weak_xautoreduce F;
   % F:list of pf -> weak_xautoreduce:list of pf
   % returns weakly autoreduced form of F
   weak_xautoreduce1(F,{});


symbolic procedure weak_xautoreduce1(F,G);
   % F,G:list of pf -> weak_xautoreduce1:list of pf
   % G is (weakly) autoreduced, F may be reducible wrt G.
   begin
   while F do
      begin scalar k;
      k := car F; F := cdr F;
      if k := weak_xreduce(k,G) then
        begin
        k := xnormalise k;
        foreach h in G do
           if xdiv(xval k,xval h) then
            <>;
        G := append(G,{k});
        end;
      end;
   return G;
   end;


% symbolic procedure print_reduction_chain(f,l,g);
%    % f,g:pf, l:list of {pf,pf} -> print_reduction_chain:nil
%    begin
%    writepri(mkquote preppf f,'nil);
%    writepri(" =",'last);
%    foreach pr in cdr l do
%      <>;
%    writepri("   ",'first);
%    writepri(mkquote preppf g,'last);
%    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xgroeb.red0000644000175000017500000001736411526203062023747 0ustar  giovannigiovannimodule xgroeb;

% GB calculation

% Authors: David Hartley and Philip A Tuckey

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*xfullreduce !*trxideal !*twosided !*trxmod
        xpolylist!* xvarlist!* zerodivs!* xtruncate!*
        xdegreelist!*);

global '(dimex!*);


put('xideal,'rtypefn,'quotelist);
put('xideal,'listfn,'xideallist);


symbolic procedure xideallist(u,v);
   % u:list of prefix,v:bool -> xideallist:prefix
   % Syntax is xideal({poly,...} [,{var,...}] [,degree])
   begin scalar x,y;
   xtruncate!* := nil;       % don't truncate GB
   if atom u
     then rerror(xideal,0,"Wrong number of arguments to xideal");
   if eqcar(x := aeval car u,'list) then
    <>
   else typerr(car u,'list);
   if u and eqcar(y := reval car u,'list) then
    <>;
   if u then
      if fixp(y := reval car u) then
       <>
      else typerr(y,"truncation degree");
   if u then rerror(xideal,0,"Wrong number of arguments to xideal");
   x := xidealpf for each f in x join if f := xpartitop f then {f};
   return makelist for each g in x collect !*q2a1(!*pf2sq repartit g,v);
   end;


symbolic procedure xidealpf p;
   % p:list of pf -> xidealpf:list of pf
   xideal0 storexvars p
      where xvarlist!* = {}, xdegreelist!* = {};


symbolic procedure storexvars p;
   % p:list of pf -> storexvars:list of pf
   % Result is identical to input. Side-effects are to store all pform
   % variables in xvarlist!*, all zero divisors in zerodivs!*, and check
   % whether input is homogeneous in degree or in conflict with dimex!*.
   begin
   xvarlist!* := nil;
   foreach f in p do % collect all variables present in p
    <>;
      xvarlist!* := union(allxvars f,xvarlist!*)>>;
   xvarlist!* := sort(xvarlist!*,'worderp);
   xdegreelist!*
      := (1 . 0) . foreach k in xvarlist!* collect k . xdegree k;
   zerodivs!*:= foreach v in xvarlist!* join if oddp xdegree v then {v};
   if fixp dimex!* and dimex!* < foreach v in xvarlist!* sum xdegree v
     then rerror(xideal,0,
             "too many independent p-forms in XIDEAL (check SPACEDIM)");
   return p;
   end;


symbolic procedure allxvars f;
   % f:pf -> allxvars:list of 
   if null f or lpow f = 1 then nil
   else append(wedgefax lpow f,allxvars red f);


symbolic procedure xideal0 F;
   % F:list of pf -> xideal0:list of pf
   % GB algorithm
   begin scalar G,F0,P;
   if !*trxideal then xprint_basis("Input Basis",F);
   if !*xfullreduce then F := weak_xautoreduce1(F,{});
   if !*trxideal and not xequiv(F,xpolylist!*) then
      xprint_basis("New Basis",F);
   P := critical_pairs(F,{},empty_xset());
   while not empty_xsetp P do
      begin scalar cp,k;
      cp := remove_least_item P;
      if !*trxideal then xprint_pair cp;
      if not xriterion_1(cp,F,P) and not xriterion_2(cp,zerodivs!*,P)
        then if k := weak_xreduce(critical_element cp,F) then
            if lpow k = 1 then % quick exit for trivial ideal
             <
>
            else
             <>
         else if !*trxideal and not !*trxmod then writepri(0,'last);
      end;
   return if !*xfullreduce then xautoreduce1 F
          else reversip sort(F,'pfordp);
   end;


symbolic procedure xriterion_1(cp,G,P);
   if null G then nil
   else if pr_type cp neq 'spoly_pair then nil
   else x neq pr_lhs cp
    and x neq pr_rhs cp
    and xdiv(xval x,xkey cp)
    and (null pr or not find_item(pr,P)
           where pr = make_spoly_pair(x,pr_lhs cp))
    and (null pr or not find_item(pr,P)
           where pr = make_spoly_pair(x,pr_rhs cp))
    and <>
    or  xriterion_1(cp,cdr G,P) where x = car G;


symbolic procedure xriterion_2(cp,G,P);
   % G = zerodivs!* at the start
   % I don't believe this ever returns t for our case
   if null G then nil
   else if pr_type cp neq 'wedge_pair then nil
   else !*k2pf x neq pr_lhs cp
    and xdiv({x,x},xkey cp)
    and (null pr or not find_item(pr,P)
           where pr = make_wedge_pair(x,pr_rhs cp))
    and <>
    or  xriterion_2(cp,cdr G,P) where x = car G;


% The remaining procedure are for tracing and debugging


symbolic procedure xequiv(F,G);
   % F,G:list of pf -> xequiv:bool
   % true if F and G have equal contents, possibly reordered
   length F = length G and sublistp(F,G);


symbolic procedure xregister(k,pr);
   % k:pf, pr:crit_pr -> xregister:pf
   % returns k unchanged
   % xpolylist!* updated as side-effect
   begin
   eval {mkid('xregister_,pr_type pr)};
   if !*trxideal then
    <>;
   return k;
   end;


symbolic procedure xregister_spoly_pair; nil; % Just for counting calls.
symbolic procedure xregister_wedge_pair; nil;
symbolic procedure xregister_xcomm_pair; nil;


symbolic procedure xprint_basis(s,p);
   % s:string, p:list of pf -> xprint_basis:nil
   % Prints heading s, followed by basis p.
   % xpolylist!* updated as a side-effect. Used for tracing.
   begin
   xpolylist!* := p;
   writepri(s,'only);
   foreach f in p do
      mathprint {'equal,{'xpoly,xpolyindex f},preppf f};
   end;



symbolic procedure xpolyindex x;
   length(x member reverse xpolylist!*);


symbolic procedure xprint_pair cp;
   begin
   writepri(mkquote pr_type cp,'first);
   if pr_type cp = 'spoly_pair then
      writepri(mkquote makelist {xpolyindex pr_lhs cp,
                                 xpolyindex pr_rhs cp},
               nil)
   else if pr_type cp = 'wedge_pair then
      writepri(mkquote makelist {lpow pr_lhs cp,
                                 xpolyindex pr_rhs cp},
               nil)
   else
      writepri(mkquote makelist {lpow pr_lhs cp,
                                 xpolyindex pr_rhs cp},
               nil);
   writepri(" -> ",nil);
   end;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xpowers.red0000644000175000017500000001274111526203062024162 0ustar  giovannigiovannimodule xpowers;

% Powers, including div relation and lcm.

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment.  Factor ordering within a product is decided using the current
kernel order.  Term ordering is decided by ordering of the valuation of
terms in the commutative monoid.  The valuation of a poly is simply the
list of factors in the leading power.  Monoid ordering can be either
lex or gradlex.  The div, // and lcm operations are performed within
the monoid.

Monoid elements are given by the type mon:

        mon ::= list of kernel | {1}

endcomment;

fluid '(xdegreelist!* xvarlist!*);


rlistat '(xorder);

symbolic procedure xorder u;
   if u = {nil} then compress pnth(explode get('wedge,'xorder),6)
   else if (idp(u := car u) or idp(u := reval u)) and
           getd mkid('xord_,u) then
      <>
   else typerr(u,"xorder");


put('wedge,'xorder,'xord_deglex);


symbolic procedure xval f;
   % f:pf -> xval:mon
   wedgefax lpow f;


symbolic procedure pfordp(f,g);
   % f,g:pf -> pfordp:bool
   % partial ordering based on term ordering
   % returns t if f > g, otherwise nil (even when no ordering defined)
   if null f then nil
   else if null g then lpow f neq 1 % == termordp(lpow f,1)
   else if not(lpow f eq lpow g) then termordp(lpow f,lpow g)
   else pfordp(red f,red g);


symbolic procedure termordp(u,v);
   % u,v:lpow pf -> termordp:bool
   % returns t if u > v
   monordp(wedgefax u,wedgefax v);


symbolic procedure monordp(u,v);
   % u,v:mon -> monordp:bool
   % returns t if u > v
   apply2(get('wedge,'xorder),u,v);


symbolic procedure factorordp(u,v);
   % u,v:kernel -> factorordp:bool
   % same as worder, but with strict inequality
   % returns t if u > v
   if u eq v then nil
%%?   else if xvarlist!* then v memq (u memq xvarlist!*)
   else worderp(u,v);


symbolic procedure xord_lex(u,v);
   % u,v:mon -> xord_lex:bool
   if null u or car u = 1 then nil
   else if null v or car v = 1 then t
   else if car u eq car v then xord_lex(cdr u,cdr v)
   else factorordp(car u,car v);


symbolic procedure xord_gradlex(u,v);
   % u,v:mon -> xord_gradlex:bool
   if car u = 1 then nil
   else if car v = 1 then t
   else if length u = length v then xord_lex(u,v)
   else length u > length v;


symbolic procedure xord_deglex(u,v);
   % u,v:mon -> xord_deglex:bool
   if car u = 1 then nil
   else if car v = 1 then t
   else (if du = dv then xord_lex(u,v)
   else du > dv) where du = xdegreemon u,
                       dv = xdegreemon v;


symbolic procedure xdegreemon u;
   % u:mon -> xdegreemon:int
   % special degree routine for faster deglex ordering
   if null xdegreelist!* then xdegree mknwedge u
   else foreach k in u sum cdr atsoc(k,xdegreelist!*);


symbolic procedure xord_deggradlex(u,v);
   % u,v:mon -> xord_deggradlex:bool
   if car u = 1 then nil
   else if car v = 1 then t
   else (if du = dv then xord_gradlex(u,v)
   else du > dv) where du = xdegree mknwedge u,
                       dv = xdegree mknwedge v;


symbolic procedure xlcm(r,s);
   % r,s:mon -> xlcm:mon
   % lowest common multiple
   if null r or car r = 1 then s
   else if null s or car s = 1 then r
   else if car r eq car s then car r . xlcm(cdr r,cdr s)
   else if factorordp(car r,car s) then car r . xlcm(cdr r,s)
   else car s . xlcm(r,cdr s);


symbolic procedure xdiv(r,s);
   % r,s:mon -> xdiv:nil|mon
   % returns s//r if r div s, else nil
   if r = {1} then s
   else if sublistp(r,s) then
      if s := listdiff(s,r) then s else {1};


symbolic procedure listunion(x,y);
   % x,y:list -> listunion:list
   % A version of union which takes multiplicities into account.
   % If item z occurs m(x) times in x and m(y) times in y, then it
   % occurs max(m(x),m(y)) times in listunion(x,y). Ordering is x,(y\x).
   % NB. union({z,z},{z}) gives {z}, while union({z},{z,z}) gives {z,z}.
   if null x then y
   else if null y then x
   else car x . listunion(cdr x,
                         if car x member y then delete(car x,y) else y);


symbolic procedure sublistp(x,y);
   % x,y:list -> sublistp:bool
   null x or car x member y and sublistp(cdr x,delete(car x,y));


symbolic procedure listdiff(x,y);
   % x,y:list -> listdiff:list
   if null y then x
   else if null x then nil
   else listdiff(delete(car y,x),cdr y);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xideal/xideal.tex0000644000175000017500000003457411526203062023757 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}

\title{\bf XIDEAL\\
Gr{\"o}bner Bases for Exterior Algebra}

\author{
David Hartley
 \thanks{Postal address: GMD--SCAI, D--53754 St~Augustin, Germany.}
 \thanks{Email: Hartley@gmd.de}				\\
Institute for Algorithms and Scientific Computing	\\
GMD --- German National Research Center			\\
for Information Technology				\\
St Augustin, Germany					\\
\\ \and
Philip A.~Tuckey\thanks{Email: pat@rs3.univ-fcomte.fr}	\\
Laboratoire de Physique Moleculaire			\\
UFR des Sciences et Techniques				\\
Universite de Franche-Comte				\\
25030 Besancon						\\
France							
}

\date{Version 2.4}

\begin{document}
\maketitle

\section{Description}

The method of Gr{\"o}bner bases in commutative polynomial rings introduced by
Buchberger (e.g.~\cite{Buchberger}) is a well-known and very important tool
in polynomial ideal theory, for example in solving the ideal membership
problem. XIDEAL extends the method to exterior algebras using
algorithms from \cite{HT} and \cite{Apel}.

There are two main departures from the commutative polynomial case. First,
owing to the non-commutative product in exterior algebras, ideals are no
longer automatically two-sided, and it is necessary to distinguish between
left and right ideals. Secondly, because there are zero divisors, confluent
reduction relations are no longer sufficient to solve the ideal membership
problem: a unique normal form for every polynomial does not guarantee that
all elements in the ideal reduce to zero. This leads to two possible
definitions of Gr{\"o}bner bases as pointed out by Stokes \cite{Stokes}.

XIDEAL constructs Gr{\"o}bner bases for solving the left ideal membership
problem: Gr{\"o}bner left ideal bases or GLIBs. For graded ideals, where each
form is homogeneous in degree, the distinction between left and right
ideals vanishes. Furthermore, if the generating forms are all homogeneous,
then the Gr{\"o}bner bases for the non-graded and graded ideals are
identical. In this case, XIDEAL is able to save time by truncating the
Gr{\"o}bner basis at some maximum degree if desired.

XIDEAL uses the exterior calculus package EXCALC of E.~Schr{\"u}fer
\cite{EXCALC} to provide the exterior algebra definitions. EXCALC is loaded
automatically with XIDEAL.
% The basis 1-forms for the exterior algebra
% are automatically extracted from the input. Consequently, each expression
% must be written in terms of these 1-forms -- $p$-form kernels with $p>1$
% are not allowed. Similarly all distinct 1-forms in the input are assumed to
% be linearly independent -- if a dimension has been fixed (using the EXCALC
% \f{SPACEDIM} or \f{COFRAME} statements), then input containing more than this
% number of distinct 1-forms will generate an error. The exterior algebra can
% be based on either an abstract vector space or the cotangent space at some
% fixed point on a manifold. Any functions or 0-forms are treated as constant
% non-vanishing coefficients.
The exterior variables may be specified explicitly, or extracted
automatically from the input polynomials.  All distinct exterior variables
in the input are assumed to be linearly independent -- if a dimension has
been fixed (using the EXCALC \f{spacedim} or \f{coframe} statements), then
input containing distinct exterior variables with degrees totaling more
than this number will generate an error.

% The term ordering used is the graded lexicographical ordering based on the
% prevailing EXCALC kernel ordering for the basis 1-forms. This puts
% highest degree first and then sorts terms of the same degree
% lexicographically. The EXCALC kernel ordering can be changed with the
% \REDUCE{} \f{KORDER} or EXCALC \f{FORDER} statements.



\section{Declarations}


\subsubsection*{xorder}

\f{xorder} sets the term ordering for all other calculations. The syntax is
\begin{verbatim}
     xorder k
\end{verbatim}
where \f{k} is one of \f{lex}, \f{gradlex} or \f{deglex}. The
lexicographical ordering \f{lex} is based on the prevailing EXCALC kernel
ordering for the exterior variables. The EXCALC kernel ordering can be
changed with the \REDUCE{} \f{korder} or EXCALC \f{forder} declarations. The
graded lexicographical ordering \f{gradlex} puts terms with more factors
first (irrespective of their exterior degrees) and sorts terms of the same
grading lexicographically. The degree lexicographical ordering \f{deglex}
takes account of the exterior degree of the variables, putting highest
degree first and then sorting terms of the same degree lexicographically.
The default ordering is \f{deglex}.


\subsubsection*{xvars}

It is possible to consider scalar and 0-form variables in exterior
polynomials in two ways: as variables or as coefficient parameters. This
difference is crucial for Gr{\"o}bner basis calculations. By default, all
scalar variables which have been declared as 0-forms are treated as
exterior variables, along with any EXCALC kernels of degree 0. This
division can be changed with the \f{xvars} declaration. The syntax is
\begin{verbatim}
     xvars U,V,W,...
\end{verbatim}
where the arguments are either kernels or lists of kernels. All variables
specified in the \f{xvars} declaration are treated as exterior variables in
subsequent XIDEAL calculations with exterior polynomials, and any other
scalars are treated as parameters. This is true whether or not the
variables have been declared as 0-forms. The declaration
\begin{verbatim}
     xvars {}
\end{verbatim}
causes all degree 0 variables to be treated as parameters, and
\begin{verbatim}
     xvars nil
\end{verbatim}
restores the default. Of course, $p$-form kernels with $p\not=0$ are always
considered as exterior variables. The order of the variables in an
\f{xvars} declaration has no effect on the \REDUCE{} kernel ordering or
XIDEAL term ordering.



\section{Operators}


\subsubsection*{xideal}

\f{xideal} calculates a Gr{\"o}bner left ideal basis in
an exterior algebra. The syntax is
\begin{verbatim}
     xideal(S:list of forms[,V:list of kernels][,R:integer])
           :list of forms.
\end{verbatim}
\f{xideal} calculates a Gr{\"o}bner basis for the left ideal generated by
\f{S} using the current term ordering. The resulting list can be used for
subsequent reductions with \f{xmod} as long as the term ordering is not
changed. Which 0-form variables are to be regarded as exterior variables
can be specified in an optional argument \f{V} (just like an \f{xvars}
declaration). The order of variables in \f{V} has no effect on the term
ordering. If the set of generators \f{S} is graded, an optional parameter
\f{R} can be given, and \f{xideal} produces a truncated basis suitable for
reducing exterior forms of degree less than or equal to \f{R} in the left
ideal. This can save time and space with large problems, but the result
cannot be used for exterior forms of degree greater than \f{R}. The forms
returned by \f{xideal} are sorted in increasing order. See also the
switches \f{trxideal} and \f{xfullreduction}.


\subsubsection*{xmodideal}

\f{xmodideal} reduces exterior forms to their (unique) normal forms modulo
a left ideal. The syntax is
\begin{verbatim}
     xmodideal(F:form, S:list of forms):form
\end{verbatim}
or
\begin{verbatim}
     xmodideal(F:list of forms, S:list of forms)
              :list of forms.
\end{verbatim}
An alternative infix syntax is also available:
\begin{verbatim}
     F xmodideal S.
\end{verbatim}
\f{xmodideal(F,S)} first calculates a Gr{\"o}bner basis for the left ideal
generated by \f{S}, and then reduces \f{F}. \f{F} may be either a single
exterior form, or a list of forms, and \f{S} is a list of forms. If \f{F}
is a list of forms, each element is reduced, and any which vanish are
deleted from the result. 
% If this operator is used more than once, and \f{S} does not change
% between calls, then the Gr{\"o}bner basis is not recalculated. 
If the set of generators \f{S} is graded, then a truncated Gr{\"o}bner basis
is calculated using the degree of \f{F} (or the maximal degree in
\f{F}). See also \f{trxmod}.


\subsubsection*{xmod}

\f{xmod} reduces exterior forms to their (not necessarily unique) normal
forms modulo a set of exterior polynomials. The syntax is
\begin{verbatim}
     xmod(F:form, S:list of forms):form
\end{verbatim}
or
\begin{verbatim}
     xmod(F:list of forms, S:list of forms):list of forms.
\end{verbatim}
An alternative infix syntax is also available:
\begin{verbatim}
     F xmod S.
\end{verbatim}
\f{xmod(F,S)} reduces \f{F} with respect to the set of exterior polynomials
\f{S}, which is not necessarily a Gr{\"o}bner basis. \f{F} may be either a
single exterior form, or a list of forms, and \f{S} is a list of
forms. This operator can be used in conjunction with \f{xideal} to produce
the same effect as \f{xmodideal}: for a single homogeneous form \f{F} and a
set of exterior forms \f{S}, \f{F xmodideal S} is equivalent to \f{F xmod
xideal(S,exdegree F)}. See also \f{trxmod}.


\subsubsection*{xauto}

\f{xauto} autoreduces a set of exterior forms. The syntax is
\begin{verbatim}
     xauto(S:list of forms):list of forms.
\end{verbatim}
\f{xauto S} returns a set of exterior polynomials which generate the same
left ideal, but which are in normal form with respect to each other. For
linear expressions, this is equivalent to finding the reduced row echelon
form of the coefficient matrix.


\subsubsection*{excoeffs}

The operator \f{excoeffs}, with syntax
\begin{verbatim}
     excoeffs(F:form):list of expressions
\end{verbatim}
returns the coefficients from an exterior form as a list. The coefficients
are always scalars, but which degree 0 variables count as coefficient
parameters is controlled by the command \f{xvars}.


\subsubsection*{exvars}

The operator \f{exvars}, with syntax
\begin{verbatim}
     exvars(F:form):list of kernels
\end{verbatim}
returns the exterior powers from an exterior form as a list. All non-scalar
variables are returned, but which degree 0 variables count as coefficient
parameters is controlled by the command \f{xvars}.


\section{Switches} 


\subsubsection*{xfullreduce}

\f{on xfullreduce} allows \f{xideal} and \f{xmodideal} to calculate
reduced, monic Gr{\"o}bner bases, which speeds up subsequent reductions, and
guarantees a unique form for the Gr{\"o}bner basis. \f{off xfullreduce} turns
of this feature, which may speed up calculation of some Gr{\"o}bner
basis. \f{xfullreduce} is \f{on} by default.


\subsubsection*{trxideal}

\f{on trxideal} produces a trace of the calculations done by \f{xideal} and
\f{xmodideal}, showing the basis polynomials and the results of the
critical element calculations. This can generate profuse amounts of output.
\f{trxideal} is \f{off} by default.


\subsubsection*{trxmod}

\f{on trxmod} produces a trace of reductions to normal form during
calculations by XIDEAL operators. \f{trxmod} is \f{off} by default.


% \subsubsection*{XSTATS}

% \f{ON XSTATS} produces counting and timing information. As \f{XIDEAL} is
% running, a hash mark (\verb.#.) is printed for each form taken from the
% input list, followed by a sequences of carets (\verb.^.) and dollar signs
% (\verb.$.). Each caret represents a new basis element obtained by a simple
% wedge product, and each dollar sign represents a new basis element obtained
% from an S-polynomial. At the end, a table is printed summarising the
% calculation. \f{XSTATS} is \f{OFF} by default.

\section{Examples}

Suppose XIDEAL has been loaded, the switches are at their default settings,
and the following exterior variables have been declared:

\begin{verbatim}
     pform x=0,y=0,z=0,t=0,f(i)=1,h=0,hx=0,ht=0;
\end{verbatim}

In a commutative polynomial ring, a single polynomial is its own Gr{\"o}bner
basis. This is no longer true for exterior algebras because of the presence
of zero divisors, and can lead to some surprising reductions:
\begin{verbatim}
     xideal {d x^d y - d z^d t};

          {d t^d z + d x^d y,

           d x^d y^d z,

           d t^d x^d y}

     f(3)^f(4)^f(5)^f(6) 
       xmodideal {f(1)^f(2) + f(3)^f(4) + f(5)^f(6)};

          0
\end{verbatim}

The heat equation, $h_{xx}=h_t$ can be represented by the following
exterior differential system. 
\begin{verbatim}
     S := {d h - ht*d t - hx*d x,
           d ht^d t + d hx^d x,
           d hx^d t - ht*d x^d t};
\end{verbatim}
\f{xmodideal} can be used to check that the exterior differential system is
closed under exterior differentiation.
\begin{verbatim}
     d S xmodideal S;

          {}
\end{verbatim}

\f{xvars}, or a second argument to \f{xideal} can be used to change the
division between exterior variables of degree 0 and parameters.
\begin{verbatim}
        xideal {a*d x+y*d y};

                  d x*a + d y*y
                {---------------}
                        a

        xvars {a};
        xideal {a*d x+y*d y};
 
                {d x*a + d y*y,d x^d y}
 
        xideal({a*d x+y*d y},{a,y});
 
                {d x*a + d y*y,
 
                 d x^d y*y}
 
        xvars {};       % all 0-forms are coefficients
        excoeffs(d u - (a*p - q)*d y);
        
                {1, - a*p + q}
        
        exvars(d u - (a*p - q)*d y);

                {d u,d y}

        xvars {p,q};    % p,q are no longer coefficients
        excoeffs(d u - (a*p - q)*d y);
        
                { - a,1,1}

        exvars(d u - (a*p - q)*d y);

                {d y*p,d y*q,d u}

        xvars nil;
\end{verbatim}


Non-graded left and right ideals are no longer the same:
\begin{verbatim}
     d t^(d z+d x^d y) xmodideal {d z+d x^d y};

          0

     (d z+d x^d y)^d t xmodideal {d z+d x^d y};

           - 2*d t^d z
\end{verbatim}
Any form containing a 0-form term generates the whole ideal:
\begin{verbatim}
     xideal {1 + f(1) + f(1)^f(2) + f(2)^f(3)^f(4)};

          {1}
\end{verbatim}


\begin{thebibliography}{M}

\bibitem{Buchberger}
	B.~Buchberger, {\em
	Gr{\"o}bner Bases: an algorithmic method in polynomial ideal theory,}
	in {\em Multidimensional Systems Theory\/} ed.~N.K.~Bose
	(Reidel, Dordrecht, 1985) chapter 6.
\bibitem{HT}
	D.~Hartley and P.A.~Tuckey, {\em
	A Direct Characterisation of Gr{\"o}bner Bases in Clifford and
	Grassmann Algebras,}
	Preprint MPI-Ph/93--96 (1993).
\bibitem{Apel}
	J.~Apel, {\em A relationship between Gr{\"o}bner bases of ideals and
	vector modules of G-algebras,}
	Contemporary Math.~{\bf 131}(1992)195--204.
\bibitem{Stokes}
	T.~Stokes, {\em
	Gr{\"o}bner bases in exterior algebra,}
	J.~Automated Reasoning {\bf 6}(1990)233--250.
\bibitem{EXCALC}
	E.~Schr{\"u}fer, {\em
	EXCALC, a system for doing calculations in the calculus of modern
	differential geometry, User's manual,}
	(The Rand Corporation, Santa Monica, 1986).

\end{thebibliography}

\end{document}




mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/0000755000175000017500000000000011722677355021511 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/poly/subs4q.red0000644000175000017500000000423411526203062023407 0ustar  giovannigiovannimodule subs4q; % Routines for matching quotients.

% Author: Anthony C. Hearn.
%         modification to more general quotient matching: Herbert Melenk

% Copyright (c) 1992 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure subs4q u;
   % U is a standard quotient,
   % Value is a standard quotient with all quotient substitutions made.
   begin scalar x,w,q,d;
      if null(x:=get('slash,'opmtch)) then return u;
      w := prepsq u;
      remprop('slash,'opmtch); % to prevent endless recursion.
      put('slash!*,'opmtch,x);
      while w and eqcar(q:=w,'quotient) do
          <>;
      u:= if d then simp!* q else u;
      put('slash,'opmtch,x);
      return u;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/polydiv.rlg0000644000175000017500000001316011527635055023700 0ustar  giovannigiovanniFri Feb 18 21:27:12 2011 run on win32
% polydiv.tst  -*- REDUCE -*-

% Test and demonstration file for enhanced polynomial division
% file polydiv.red.

% F.J.Wright@Maths.QMW.ac.uk, 7 Nov 1995.

% The example from "Computer Algebra" by Davenport, Siret & Tournier,
% first edition, section 2.3.3.

% First check that remainder still works as before.

% Compute the gcd of the polynomials a and b by Euclid's algorithm:
a := aa := x^8 + x^6 - 3x^4 - 3x^3 + 8x^2 + 2x - 5;


            8    6      4      3      2
a := aa := x  + x  - 3*x  - 3*x  + 8*x  + 2*x - 5

b := bb := 3x^6 + 5x^4 - 4x^2 - 9x + 21;


              6      4      2
b := bb := 3*x  + 5*x  - 4*x  - 9*x + 21

on rational;

  off allfac;


c := remainder(a, b);


         5   4    1   2    1
c :=  - ---*x  + ---*x  - ---
         9        9        3
  a := b$

  b := c$


c := remainder(a, b);


         117   2          441
c :=  - -----*x  - 9*x + -----
         25               25
  a := b$

  b := c$


c := remainder(a, b);


      233150       102500
c := --------*x - --------
      19773         6591
  a := b$

  b := c$


c := remainder(a, b);


         1288744821
c :=  - ------------
         543589225
  a := b$

  b := c$


c := remainder(a, b);


c := 0

off rational;



% Repeat using pseudo-remainders, to avoid rational arithmetic:
a := aa;


      8    6      4      3      2
a := x  + x  - 3*x  - 3*x  + 8*x  + 2*x - 5

b := bb;


        6      4      2
b := 3*x  + 5*x  - 4*x  - 9*x + 21

c := pseudo_remainder(a, b);


            4      2
c :=  - 15*x  + 3*x  - 9
  a := b$

  b := c$


c := pseudo_remainder(a, b);


            2
c := 15795*x  + 30375*x - 59535
  a := b$

  b := c$


c := pseudo_remainder(a, b);


c := 1254542875143750*x - 1654608338437500
  a := b$

  b := c$


c := pseudo_remainder(a, b);


c := 12593338795500743100931141992187500
  a := b$

  b := c$


c := pseudo_remainder(a, b);


c := 0



% Example from Chris Herssens 
% involving algebraic numbers in the coefficient ring
% (for which naive pseudo-division fails in REDUCE):
factor x;


a:=8*(15*sqrt(2)*x**3 + 18*sqrt(2)*x**2 + 10*sqrt(2)*x + 12*sqrt(2) -
   5*x**4 - 6*x**3 - 30*x**2 - 36*x);


            4    3                       2
a :=  - 40*x  + x *(120*sqrt(2) - 48) + x *(144*sqrt(2) - 240)

      + x*(80*sqrt(2) - 288) + 96*sqrt(2)

b:= - 16320*sqrt(2)*x**3 - 45801*sqrt(2)*x**2 - 50670*sqrt(2)*x -
   26534*sqrt(2) + 15892*x**3 + 70920*x**2 + 86352*x + 24780;


      3                               2
b := x *( - 16320*sqrt(2) + 15892) + x *( - 45801*sqrt(2) + 70920)

      + x*( - 50670*sqrt(2) + 86352) - 26534*sqrt(2) + 24780


pseudo_remainder(a, b, x);


 2                  3/2
x *( - 51343372800*2    + 72663731640*2 + 106394745600*sqrt(2) - 152808065280) +

                    3/2
 x*( - 77924736000*2    + 111722451600*2 + 167518488000*sqrt(2) - 236076547200)

                3/2
 - 26395315200*2    + 21508247760*2 + 58006274400*sqrt(2) - 51393323520

% Note: We must specify the division variable even though the
% polynomials are apparently univariate:
pseudo_remainder(a, b);


*** Main division variable selected is 2**(1/2) 

        7           6            5            4            3            2
652800*x  + 708360*x  - 2656800*x  - 2660160*x  + 4017600*x  + 3676320*x

 - 2630400*x - 2378880


% Confirm that quotient * b + remainder = constant * a:
pseudo_divide(a, b, x);


{x*(652800*sqrt(2) - 635680) - 1958400*2 + 858360*sqrt(2) + 2073984,

  2                  3/2
 x *( - 51343372800*2    + 72663731640*2 + 106394745600*sqrt(2) - 152808065280) 

 + x

                   3/2
 *( - 77924736000*2    + 111722451600*2 + 167518488000*sqrt(2) - 236076547200)

                 3/2
  - 26395315200*2    + 21508247760*2 + 58006274400*sqrt(2) - 51393323520}

first ws * b + second ws;


 4
x *(20748595200*sqrt(2) - 31409618560)

    3
 + x *(119127169920*sqrt(2) - 162183113472)

    2
 + x *(237566198016*sqrt(2) - 337847596800)

 + x*(212209122560*sqrt(2) - 309143634432) + 75383084544*sqrt(2) - 99593256960

ws / a;


  4                                      3
(x *(2593574400*sqrt(2) - 3926202320) + x *(14890896240*sqrt(2) - 20272889184)

     2
  + x *(29695774752*sqrt(2) - 42230949600)

  + x*(26526140320*sqrt(2) - 38642954304) + 9422885568*sqrt(2) - 12449157120)/(

         4    3                     2
    - 5*x  + x *(15*sqrt(2) - 6) + x *(18*sqrt(2) - 30) + x*(10*sqrt(2) - 36)

    + 12*sqrt(2))
                                 % is this constant?
on rationalize;


ws;


 - 518714880*sqrt(2) + 785240464
                                     % yes, it is constant
off rationalize;



on allfac;

  remfac x;



procedure test_pseudo_division(a, b, x);
   begin scalar qr, L;
      qr := pseudo_divide(a, b, x);
      L := lcof(b,x);
      %% For versions of REDUCE prior to 3.6 use:
      %% L := if b freeof x then b else lcof(b,x);
      if first qr * b + second qr =
         L^(deg(a,x)-deg(b,x)+1) * a then
         write "Pseudo-division OK"
      else
         write "Pseudo-division failed"
   end;


test_pseudo_division


a := 5x^4 + 4x^3 + 3x^2 + 2x + 1;


        4      3      2
a := 5*x  + 4*x  + 3*x  + 2*x + 1

test_pseudo_division(a, x, x);


Pseudo-division OK

test_pseudo_division(a, x^3, x);


Pseudo-division OK

test_pseudo_division(a, x^5, x);


Pseudo-division OK

test_pseudo_division(a, x^3 + x, x);


Pseudo-division OK

test_pseudo_division(a, 0, x);


***** Zero divisor 
          % intentional error!
test_pseudo_division(a, 1, x);


Pseudo-division OK


test_pseudo_division(5x^3 + 7y^2, 2x - y, x);


Pseudo-division OK

test_pseudo_division(5x^3 + 7y^2, 2x - y, y);


Pseudo-division OK


end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 10 1)
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/subs3q.red0000644000175000017500000001551611526203062023413 0ustar  giovannigiovannimodule subs3q; % Routines for matching products.

% Author: Anthony C. Hearn.

% Copyright (c) 1992 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*mcd powlis1!* !*sub2 subfg!*);

global '(!*match !*resubs mchfg!*);

symbolic procedure subs3q u;
   %U is a standard quotient.
   %Value is a standard quotient with all product substitutions made;
   begin scalar x;
        x := mchfg!*;   %save value in case we are in inner loop;
        mchfg!* := nil;
        u := quotsq(subs3f numr u,subs3f denr u);
        mchfg!* := x;
        return u
   end;

symbolic procedure subs3f u;
   %U is a standard form.
   %Value is a standard quotient with all product substitutions made;
   subs3f1(u,!*match,t);

symbolic procedure subs3f1(u,l,bool);
   %U is a standard form.
   %L is a list of possible matches.
   %BOOL is a boolean variable which is true if we are at top level.
   %Value is a standard quotient with all product substitutions made;
   begin scalar x,z;
        z := nil ./ 1;
    a:  if null u then return z
         else if domainp u then return addsq(z,u ./ 1)
         else if bool and domainp lc u then go to c;
        x := subs3t(lt u,l);
        if not bool                             %not top level;
         or not mchfg!* then go to b;           %no replacement made;
        mchfg!* := nil;
        if numr x = u and denr x = 1 then <>
         % also shows no replacement made (sometimes true with non
         % commuting expressions)
         else if null !*resubs then go to b
         else if !*sub2 or powlis1!* then x := subs2q x;
           %make another pass;
        x := subs3q x;
    b:  z := addsq(z,x);
        u := cdr u;
        go to a;
    c:  x := list lt u ./ 1;
        go to b
   end;

symbolic procedure subs3t(u,v);
   % U is a standard term, V a list of matching templates.
   % Value is a standard quotient for the substituted term.
   begin scalar bool,w,x,y,z;
        x := mtchk(car u,if domainp cdr u then sizchk(v,1) else v);
        if null x then go to a                  %lpow doesn't match;
         else if null caar x then go to b;      %complete match found;
        y := subs3f1(cdr u,x,nil);              %check tc for match;
        if mchfg!* then return multpq(car u,y);
    a:  return list u . 1;                      %no match;
    b:  x := cddar x;           %list(,);
        z := caadr x;           %leading denom;
        mchfg!* := nil;         %initialize for tc check;
        y := subs3f1(cdr u,!*match,nil);
        mchfg!* := t;
        if car z neq caar u then go to e
         else if z neq car u    %powers don't match;
          then y := multpq(caar u .** (cdar u-cdr z),y);
    b1: y := multsq(simpcar x,y);
        x := cdadr x;
        if null x then return y;
        z := 1;                 %unwind remaining denoms;
    c:  if null x then go to d;
        w:= if atom caar x or sfp caar x then caar x else
             ((lambda ww;
                if kernp ww and eqcar(ww := mvar numr ww,car caar x)
                  then ww
                 else revop1 caar x)
               (simp caar x) where subfg!* = nil);
        % In the non-commutative case we have to be very careful about
        % order of terms in a product. Introducing negative powers
        % solves this problem.
        if noncomp w or not !*mcd then bool := t;
%       z := multpf(mksp(w,if null bool then cdar x else -cdar x),z);
%       original line
        z := multf(z,!*p2f mksp(w,
                                if null bool then cdar x else -cdar x));
        % kernel CAAR X is not unique here. Earlier versions used just
        % CAAR X, but this leads to sums of terms in the wrong order.
        % The code here is probably still not correct in all cases, and
        % may lead to unbounded calculations. Maybe SIMP should be used
        % instead of REVOP1, with appropriate adjustments in the code
        % to construct Z.
        x := cdr x;
        go to c;
    d:  return if not bool then car y . multf(z,cdr y)
                else multf(z,car y) . cdr y;
    e:  if simp car z neq simp caar u then errach list('subs3t,u,x,z);
        %maybe arguments were in different order, otherwise it's fatal;
        if cdr z neq cdar u
          then y:= multpq(caar u .** (cdar u-cdr z),y);
        go to b1
   end;

symbolic procedure sizchk(u,n);
   if null u then nil
    else if length caar u>n then sizchk(cdr u,n)
    else car u . sizchk(cdr u,n);

symbolic procedure mtchk(u,v);
   %U is a standard power, V a list of matching templates.
   %If a match is made, value is of the form:
   %list list(NIL,,,),
   %otherwise value is an updated list of templates;
   begin scalar flg,v1,w,x,y,z;
        flg := noncomp car u;
    a0: if null v then return z;
        v1 := car v;
        w := car v1;
    a:  if null w then go to d;
        x := mtchp1(u,car w,caadr v1,cdadr v1);
    b:  if null x then go to c
         else if car (y := subla(car x,delete(car w,car v1))
                                . list(subla(car x,cadr v1),
                                      subla(car x,caddr v1),
                                      subla(car x,car w)
                                          . cadddr v1))
          then z := y . z
         else if lispeval subla(car x,cdadr v1) then return list y;
        x := cdr x;
        go to b;
    c:  if null flg then <>
         else if cadddr v1 and nocp w then go to e;
    d:  z :=aconc(z,v1);   % Could also be append(z,list v1).
    e:  v := cdr v;
        go to a0
   end;

symbolic procedure nocp u;
   null u or (noncomp caar u and nocp cdr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/poly.tst0000644000175000017500000002565311526203062023221 0ustar  giovannigiovanni% Tests of the poly package polynomial decomposition and gcds.


% Test for the univariate and multivariate polynomial decomposition.

% Herbert Melenk, ZIB Berlin, 1990.

procedure testdecompose u;
   begin scalar r,p,val,nextvar;
       write "decomposition of ",u;
       r := decompose u;
       if length r = 1 then rederr "decomposition failed";
       write " leads to ",r;
	 % test if the result is algebraically correct.
       r := reverse r;
       nextvar := lhs first r; val := rhs first r;
       r := rest r;
       while not(r={}) do
       << p := first r; r := rest r;
          if 'equal = part(p,0) then
          <>
              else
            val := sub(nextvar=val,p);     
       >>;
       if val = u then write "     O.K.  "
          else
         <>;
    end;


    % univariate decompositions
testdecompose(x**4+x**2+1); 
testdecompose(x**6+9x**5+52x**4+177x**3+435x**2+630x+593); 
testdecompose(x**6+6x**4+x**3+9x**2+3x-5); 
testdecompose(x**8-88*x**7+2924*x**6-43912*x**5+263431*x**4-218900*x**3+ 
           65690*x**2-7700*x+234);

    % multivariate cases
testdecompose(u**2+v**2+2u*v+1); 
testdecompose(x**4+2x**3*y + 3x**2*y**2 + 2x*y**3 + y**4 + 2x**2*y  
         +2x*y**2 + 2y**3 + 5 x**2 + 5*x*y + 6*y**2 + 5y + 9);
testdecompose  sub(u=(2 x**2 + 17 x+y + y**3),u**2+2 u + 1);
testdecompose  sub(u=(2 x**2 *y + 17 x+y + y**3),u**2+2 u + 1);

    % some cases which require a special (internal) mapping
testdecompose  ( (x + y)**2);
testdecompose ((x + y**2)**2);
testdecompose  ( (x**2 + y)**2);
testdecompose  ( (u + v)**2 +10 );

    % the decomposition is not unique and might generate quite
    % different images:
testdecompose  ( (u + v + 10)**2 -100 );

    % some special (difficult) cases
testdecompose (X**4 + 88*X**3*Y + 2904*X**2*Y**2 - 10*X**2 
           + 42592*X*Y**3 - 440*X*Y + 234256*Y**4 - 4840*Y**2);

    % a polynomial with complex coefficients
on complex;
testdecompose(X**4 + (88*I)*X**3*Y - 2904*X**2*Y**2 - 10*X**2 - 
              (42592*I)*X*Y**3 - (440*I)*X*Y + 234256*Y**4 + 4840*Y**2);
off complex;


% Examples given by J. Gutierrez and J.M. Olazabal.

f1:=x**6-2x**5+x**4-3x**3+3x**2+5$
testdecompose(f1);

f2:=x**32-1$
testdecompose(f2);

f3:=x**4-(2/3)*x**3-(26/9)*x**2+x+3$
testdecompose(f3);

f4:=sub(x=x**4-x**3-2x+1,x**3-x**2-1)$
testdecompose(f4);

f5:=sub(x=f4,x**5-5)$
testdecompose(f5);

clear f1,f2,f3,f4,f5;


% Tests of gcd code.

% The following examples were introduced in Moses, J. and Yun, D.Y.Y.,
% "The EZ GCD Algorithm", Proc. ACM 73 (1973) 159-166, and considered
% further in Hearn, A.C., "Non-modular Computation of Polynomial GCD's
% Using Trial Division", Proc. EUROSAM 79, 227-239, 72, published as
% Lecture Notes on Comp. Science, # 72, Springer-Verlag, Berlin, 1979.

on gcd;

% The following is the best setting for this file.

on ezgcd;

% In systems that have the heugcd code, the following is also a
% possibility, although not all examples complete in a reasonable time.

% load heugcd; on heugcd;

% The final alternative is to use neither ezgcd nor heugcd. In that case,
% most examples take excessive amounts of computer time.

share n;

operator xx;

% Case 1.

for n := 2:5
   do write gcd(((for i:=1:n sum xx(i))-1)*((for i:=1:n sum xx(i)) + 2),
		((for i:=1:n sum xx(i))+1)
		     *(-3xx(2)*xx(1)**2+xx(2)**2-1)**2);

% Case 2.

let d = (for i:=1:n sum xx(i)**n) + 1;

for n := 2:7 do write gcd(d*((for i:=1:n sum xx(i)**n) - 2),
			  d*((for i:=1:n sum xx(i)**n) + 2));


for n := 2:7 do write gcd(d*((for i:=1:n sum xx(i)**n) - 2),
			  d*((for i:=1:n sum xx(i)**(n-1)) + 2));

% Case 3.

let d = xx(2)**2*xx(1)**2 + (for i := 3:n sum xx(i)**2) + 1;

for n := 2:5
   do write gcd(d*(xx(2)*xx(1) + (for i:=3:n sum xx(i)) + 2)**2,
		d*(xx(1)**2-xx(2)**2 + (for i:=3:n sum xx(i)**2) - 1));

% Case 4.

let u = xx(1) - xx(2)*xx(3) + 1,
    v = xx(1) - xx(2) + 3xx(3);

gcd(u*v**2,v*u**2);

gcd(u*v**3,v*u**3);

gcd(u*v**4,v*u**4);

gcd(u**2*v**4,v**2*u**4);


% Case 5.

let d = (for i := 1:n product (xx(i)+1)) - 3;

for n := 2:5 do write gcd(d*for i := 1:n product (xx(i) - 2),
			  d*for i := 1:n product (xx(i) + 2));

clear d,u,v;


% The following examples were discussed in Char, B.W., Geddes, K.O.,
% Gonnet, G.H., "GCDHEU:  Heuristic Polynomial GCD Algorithm Based
% on Integer GCD Computation", Proc. EUROSAM 84, 285-296, published as
% Lecture Notes on Comp. Science, # 174, Springer-Verlag, Berlin, 1984.


% Maple Problem 1.

gcd(34*x**80-91*x**99+70*x**31-25*x**52+20*x**76-86*x**44-17*x**33
    -6*x**89-56*x**54-17,
    91*x**49+64*x**10-21*x**52-88*x**74-38*x**76-46*x**84-16*x**95
    -81*x**72+96*x**25-20);
    
% Maple Problem 2.

g := 34*x**19-91*x+70*x**7-25*x**16+20*x**3-86;

gcd(g * (64*x**34-21*x**47-126*x**8-46*x**5-16*x**60-81),
    g * (72*x**60-25*x**25-19*x**23-22*x**39-83*x**52+54*x**10+81) );

% Maple Problem 3.

gcd(3427088418+8032938293*x-9181159474*x**2-9955210536*x**3
    +7049846077*x**4-3120124818*x**5-2517523455*x**6+5255435973*x**7
    +2020369281*x**8-7604863368*x**9-8685841867*x**10+4432745169*x**11
    -1746773680*x**12-3351440965*x**13-580100705*x**14+8923168914*x**15
    -5660404998*x**16 +5441358149*x**17-1741572352*x**18
    +9148191435*x**19-4940173788*x**20+6420433154*x**21+980100567*x**22
    -2128455689*x**23+5266911072*x**24-8800333073*x**25-7425750422*x**26
    -3801290114*x**27-7680051202*x**28-4652194273*x**29-8472655390*x**30
    -1656540766*x**31+9577718075*x**32-8137446394*x**33+7232922578*x**34
    +9601468396*x**35-2497427781*x**36-2047603127*x**37-1893414455*x**38
    -2508354375*x**39-2231932228*x**40,
    2503247071-8324774912*x+6797341645*x**2+5418887080*x**3
    -6779305784*x**4+8113537696*x**5+2229288956*x**6+2732713505*x**7
    +9659962054*x**8-1514449131*x**9+7981583323*x**10+3729868918*x**11
    -2849544385*x**12-5246360984*x**13+2570821160*x**14-5533328063*x**15
    -274185102*x**16+8312755945*x**17-2941669352*x**18-4320254985*x**19
    +9331460166*x**20-2906491973*x**21-7780292310*x**22-4971715970*x**23
    -6474871482*x**24-6832431522*x**25-5016229128*x**26-6422216875*x**27
    -471583252*x**28+3073673916*x**29+2297139923*x**30+9034797416*x**31
    +6247010865*x**32+5965858387*x**33-4612062748*x**34+5837579849*x**35
    -2820832810*x**36-7450648226*x**37+2849150856*x**38+2109912954*x**39
    +2914906138*x**40);

% Maple Problem 4.

g := 34271+80330*x-91812*x**2-99553*x**3+70499*x**4-31201*x**5
     -25175*x**6+52555*x**7+20204*x**8-76049*x**9-86859*x**10;

gcd(g * (44328-17468*x-33515*x**2-5801*x**3+89232*x**4-56604*x**5
	 +54414*x**6-17416*x**7+91482*x**8-49402*x**9+64205*x**10
	 +9801*x**11-21285*x**12+52669*x**13-88004*x**14-74258*x**15
	 -38013*x**16-76801*x**17-46522*x**18-84727*x**19-16565*x**20
	 +95778*x**21-81375*x**22+72330*x**23+96015*x**24-24974*x**25
	 -20476*x**26-18934*x**27-25084*x**28-22319*x**29+25033*x**30),
    g * (-83248+67974*x+54189*x**2-67793*x**3+81136*x**4+22293*x**5
	 +27327*x**6+96600*x**7-15145*x**8+79816*x**9+37299*x**10
	 -28496*x**11-52464*x**12+25708*x**13-55334*x**14-2742*x**15
	 +83128*x**16-29417*x**17-43203*x**18+93315*x**19-29065*x**20
	 -77803*x**21-49717*x**22-64749*x**23-68325*x**24-50163*x**25
	 -64222*x**26-4716*x**27+30737*x**28+22972*x**29+90348*x**30));

% Maple Problem 5.

gcd(-8472*x**4*y**10-8137*x**9*y**10-2497*x**4*y**4-2508*x**4*y**6
    -8324*x**9*y**8-6779*x**9*y**6+2733*x**10*y**4+7981*x**7*y**3
    -5246*x**6*y**2-274*x**10*y**3-4320,
    15168*x**3*y-4971*x*y-2283*x*y**5+3074*x**6*y**10+6247*x**8*y**2
    +2849*x**6*y**7-2039*x**7-2626*x**2*y**7+9229*x**6*y**5+2404*y**5
    +1387*x**4*y**8+5602*x**5*y**2-6212*x**3*y**7-8561);

% Maple Problem 6.

g := -19*x**4*y**4+25*y**9+54*x*y**9+22*x**7*y**10-15*x**9*y**7-28;

gcd(g*(91*x**2*y**9+10*x**4*y**8-88*x*y**3-76*x**2-16*x**10*y
       +72*x**10*y**4-20),
    g*(34*x**9-99*x**9*y**3-25*x**8*y**6-76*y**7-17*x**3*y**5
       +89*x**2*y**8-17));

% Maple Problem 7.

gcd(6713544209*x**9+8524923038*x**3*y**3*z**7+6010184640*x*z**7
    +4126613160*x**3*y**4*z**9+2169797500*x**7*y**4*z**9
    +2529913106*x**8*y**5*z**3+7633455535*y*z**3+1159974399*x**2*z**4
    +9788859037*y**8*z**9+3751286109*x**3*y**4*z**3,
    3884033886*x**6*z**8+7709443539*x*y**9*z**6
    +6366356752*x**9*y**4*z**8+6864934459*x**3*y**2*z**6
    +2233335968*x**4*y**9*z**3+2839872507*x**9*y**3*z
    +2514142015*x*y*z**2+1788891562*x**4*y**6*z**6
    +9517398707*x**8*y**7*z**2+7918789924*x**3*y*z**6
    +6054956477*x**6*y**3*z**6);

% Maple Problem 8.

g := u**3*(x**2-y)*z**2+(u-3*u**2*x)*y*z-u**4*x*y+3;
gcd(g * ((y**2+x)*z**2+u**5*(x*y+x**2)*z-y+5),
    g * ((y**2-x)*z**2+u**5*(x*y-x**2)*z+y+9) );

% Maple Problem 9.

g := 34*u**2*y**2*z-25*u**2*v*z**2-18*v*x**2*z**2-18*u**2*x**2*y*z+53
     +x**3;
gcd( g * (-85*u*v**2*y**2*z**2-25*u*v*x*y*z-84*u**2*v**2*y**2*z
      +27*u**2*v*x**2*y**2*z-53*u*x*y**2*z+34*x**3),
     g * (48*x**3-99*u*x**2*y**2*z-69*x*y*z-75*u*v*x*y*z**2
     -43*u**2*v+91*u**2*v**2*y**2*z) );

% Maple Problem 10.

gcd(-9955*v**9*x**3*y**4*z**8+2020*v*y**7*z**4
    -3351*v**5*x**10*y**2*z**8-1741*v**10*x**2*y**9*z**6
    -2128*v**8*y*z**3-7680*v**2*y**4*z**10-8137*v**9*x**10*y**4*z**4
    -1893*v**4*x**4*y**6+6797*v**8*x*y**9*z**6
    +2733*v**10*x**4*y**9*z**7-2849*v**2*x**6*y**2*z**5
    +8312*v**3*x**3*y**10*z**3-7780*v**2*x*y*z**2
    -6422*v**5*x**7*y**6*z**10+6247*v**8*x**2*y**8*z**3
    -7450*v**7*x**6*y**7*z**4+3625*x**4*y**2*z**7+9229*v**6*x**5*y**6
    -112*v**6*x**4*y**8*z**7-7867*v**5*x**8*y**5*z**2
    -6212*v**3*x**7*z**5+8699*v**8*x**2*y**2*z**5
    +4442*v**10*x**5*y**4*z+1965*v**10*y**3*z**3-8906*v**6*x*y**4*z**5
    +5552*x**10*y**4+3055*v**5*x**3*y**6*z**2+6658*v**7*x**10*z**6
    +3721*v**8*x**9*y**4*z**8+9511*v*x**6*y+5437*v**3*x**9*y**9*z**7
    -1957*v**6*x**4*y*z**3+9214*v**3*x**9*y**3*z**7
    +7273*v**2*x**8*y**4*z**10+1701*x**10*y**7*z**2
    +4944*v**5*x**5*y**8*z**8-1935*v**3*x**6*y**10*z**7
    +4029*x**6*y**10*z**3+9462*v**6*x**5*y**4*z**8-3633*v**4*x*y**7*z**5
    -1876,
    -5830*v**7*x**8*y*z**2-1217*v**8*x*y**2*z**5
    -1510*v**9*x**3*y**10*z**10+7036*v**6*x**8*y**3*z**3
    +1022*v**9*y**3*z**8+3791*v**8*x**3*y**7+6906*v**6*x*y*z**10
    +117*v**7*x**2*y**4*z**4+6654*v**6*x**5*y**2*z**3
    -7302*v**10*x**8*y**3-5343*v**8*x**5*y**9*z
    -2244*v**9*x**3*y**8*z**9-3719*v**5*x**10*y**6*z**8
    +2629*x**3*y**2*z**10+8517*x**9*y**6*z**7-9551*v**5*x**6*y**6*z**2
    -7750*x**10*y**7*z**4-5035*v**5*x**2*y**5*z-5967*v**9*x**5*y**9*z**5
    -8517*v**3*x**2*y**7*z**6-2668*v**10*y**9*z**4+1630*v**5*x**5*y*z**8
    +9099*v**7*x**9*y**4*z**3-5358*v**9*x**5*y**6*z**2
    +5766*v**5*y**3*z**4-3624*v*x**4*y**10*z**10
    +8839*v**6*x**9*y**10*z**4+3378*x**7*y**2*z**5+7582*v**7*x*y**8*z**7
    -85*v*x**2*y**9*z**6-9495*v**9*x**10*y**6*z**3+1983*v**9*x**3*y
    -4613*v**10*x**4*y**7*z**6+5529*v**10*x*y**6
    +5030*v**4*x**5*y**4*z**9-9202*x**6*y**3*z**9
    -4988*v**2*x**2*y**10*z**4-8572*v**9*x**7*y**10*z**10
    +4080*v**4*x**8*z**8-382*v**9*x**9*y**2*z**2-7326);

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/rnelem.red0000644000175000017500000000667111526203062023457 0ustar  giovannigiovannimodule rnelem;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*rounded);

% This module adds 10 integer functions to mode rational.

deflist('((fix rnfix!*) (round rnround!*)
  (ceiling rnceiling!*) (floor rnfloor!*) % (isqrt rnisqrt!*)
% (icbrt rnicbrt!*) (irootn rnirootn!*) (ilog2 rnilog2!*) (sgn rnsgn!*)
  (factorial rnfactorial!*) (perm rnperm!*) (choose rnchoose!*))
  ,'!:rn!:);

for each c in '(fix round ceiling floor % isqrt icbrt irootn ilog2 sgn
 factorial perm choose) do put(c,'simpfn,'simpiden);

flag('(fix floor ceiling round isqrt icbrt irootn ilog2 factorial % sgn
 perm choose) ,'integer);

deflist('((perm 2) (choose 2)),'number!-of!-args);

symbolic procedure rnfix!* x; quotient(cadr x,cddr x);

symbolic procedure rnfixchk x;
   (if cdr y=0 then car y
    else error(0,list(prepf x,"is not an integer equivalent")))
   where y=divide(cadr x,cddr x);

% symbolic procedure rnsgn!* x; sgn cadr x;

symbolic procedure rnfloor!* x;
   if cdr(x := divide(cadr x,cddr x))<0 then car x-1 else car x;

symbolic procedure rnceiling!* x;
   if cdr(x := divide(cadr x,cddr x))>0 then car x+1 else car x;

symbolic procedure rnround!* x;
   (if cadr rndifference!:(x,!*i2rn y)=0 then y
    else if rnminusp!: x then -rnround!*('!:rn!: . ((-cadr x) . cddr x))
    else rnfloor!*(rnplus!:(x,'!:rn!: . (1 . 2)))) where y=rnfix!* x;

% symbolic procedure rnisqrt!* x; isqrt rnfix!* x;

symbolic procedure rnilog2!* x; ilog2 rnfix!* x;

symbolic procedure rnfactorial!* x;
   (if fixp y and not(y<0) then nfactorial y
    else !*p2f mksp(list('factorial,y),1))
    where y=rnfixchk x;

symbolic procedure rnperm!*(x,n); perm(rnfixchk x,rnfixchk n);

symbolic procedure perm(x,n);
   if not fixp x or not fixp n or x<0 or x>n
      then terrlst(list(x,n),'perm) else for j := n-x+1:n product j;

symbolic procedure rnchoose!*(x,n); choose(rnfixchk x,rnfixchk n);

symbolic procedure choose(x,n); perm(x,n)/factorial x;

symbolic procedure simprn x;
   begin scalar !*rounded,dmode!*;
      dmode!* := '!:rn!:;
      return for each a in simplist x collect
         if atom a then !*i2rn a else a
   end;

% symbolic procedure rnicbrt!* x; icbrt rnfix!* x;

symbolic procedure rnirootn!*(x,n); irootn(rnfix!* x,rnfixchk n);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/diff.red0000644000175000017500000004546611526203062023112 0ustar  giovannigiovannimodule diff; % Differentiation package.

% Author: Anthony C. Hearn.

% Modifications by: Francis J. Wright.

% Copyright (c) 2000 Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*depend frlis!* powlis!* subfg!* wtl!* depl!*);

fluid '(!*allowdfint !*dfint !*intflag!*);

global '(mcond!*);

% Contains a reference to RPLACD (a table update), commented out.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Turning on the switch `allowdfint' allows "differentiation under the
% integral sign", i.e. df(int(y, x), v) -> int(df(y, v), x), if this
% results in a simplification.  If the switch `dfint' is also turned
% on then this happens regardless of whether the result simplifies.
% Both switches are off by default.

switch allowdfint, dfint;

deflist('((dfint ((t (rmsubs))))
   (allowdfint ((t (progn (put 'int 'dfform 'dfform_int) (rmsubs)))
                (nil (remprop 'int 'dfform))))), 'simpfg);
   % There is no code to reverse the df-int commutation,
   % so no reason to call rmsubs when the switch is turned off.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Consider df(u,x,y,z).

% If none of x,y,z are equal to u then the order of differentiation is
% commuted into a canonical form, unless the switch `nocommutedf' is
% turned on, in which case the order of differentiation is not
% commuted at all.  The switch `nocommutedf' is off by default.

% If one (or more) of x,y,z is equal to u then the order of
% differentiation is NOT commuted and the derivative is NOT simplified
% to zero, unless the switch `commutedf' is turned on.  It is off by
% default.  (CRACK needs to turn it on!)

% The new default behaviour should match the behaviour of REDUCE 3.6.
% Turning on the switch `commutedf' should reproduce the default
% behaviour of REDUCE 3.7.

% If `commutedf' is off and the switch `simpnoncomdf' is on then
% simplify df(u,x,u) -> df(u,x,2)/df(u,x), df(u,x,n,u) ->
% df(u,x,n+1)/df(u,x), as suggested by Alain Moussiaux, PROVIDED u
% depends only on the one variable x.  This simplification removes the
% non-commutative aspect of the derivative.

switch commutedf, nocommutedf, simpnoncomdf;
% Turning either `commutedf' or `nocommutedf' on turns the other off.
% Turning commutation on or noncommutation off, or turning
% simplification of noncommutative derivatives on, causes
% resimplification.
deflist('((commutedf ((t (off1 'nocommutedf) (rmsubs))))
   (nocommutedf ((t (off1 'commutedf)) (nil (rmsubs))))
      (simpnoncomdf ((t (rmsubs))))), 'simpfg);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% If the switch `expanddf' is turned on then REDUCE uses the chain
% rule to expand symbolic derivatives of indirectly dependent
% variables provided the result is unambiguous, i.e. provided there is
% no direct dependence.  It is off by default.  Thus, for example,
% given
% depend f, u, v; depend {u, v}, x;
% then, if `expanddf' is on,
% df(f,x) -> df(f,u)*df(u,x) + df(f,v)*df(v,x)
% whereas after
% depend f, x;
% df(f,x) does not expand at all (since the result would be ambiguous
% and the algorithm would loop).

% For similar handling in the case of explicit dependence,
% e.g. df(f(u(x),v(x)),x), please use the standard package `DFPART' by
% Herbert Melenk.

switch expanddf;
deflist('((expanddf ((t (rmsubs))))), 'simpfg);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure simpdf u;
   % U is a list of forms, the first an expression and the remainder
   % kernels and numbers.
   % Value is derivative of first form wrt rest of list.
   begin scalar v,x,y,z;
      if null subfg!* then return mksq('df . u,1);
      v := cdr u;
      u := simp!* car u;
  a:  if null v or null numr u then return u;
      x := if null y or y=0 then simp!* car v else y;
      if denr x neq 1 or atom numr x
        then typerr(prepsq x,"kernel or integer")
       else (if domainp z
               then if get(car z,'domain!-diff!-fn)
                       then begin scalar dmode!*,alglist!*;
                              x := prepf z;
                              if null prekernp x
                                then typerr(x,"kernel")
                            end
                     else typerr(prepf z,"kernel")
              else if null red z and lc z = 1 and ldeg z = 1
                      then x := mvar z
              else typerr(prepf z,"kernel")) where z = numr x;
      v := cdr v;
      if null v then <>;
      y := simp!* car v;
      % At this point, y must be a kernel or equivalent to an integer.
      % Any other value is an error.
      if null numr y then <>
       else if not(z := d2int y) then <>;
      v := cdr v;
      for i:=1:z do u := diffsq(u,x);
      y := nil;
      go to a
   end;

symbolic procedure d2int u;
   if denr u neq 1 then nil
    else if numberp(u := numr u) then u
    else if not domainp u or not(car u eq '!:rd!:) then nil
    else (if abs(float x - u)1 and noncomp u
          then return addsq(multsq(simpdf {u,v},simpexpt {u,n - 1}),
                            multpq(u .** 1,diffp(u . (n - 1),v)))
         else if u eq v and (w := 1 ./ 1) then go to e
         else if atom u then go to f
         %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x))
%               and (w := cdr x) then go to e   % deriv known.
             % DSUBL!* not used for now.
         else if (not atom car u and (w:= difff(u,v)))
                  or (car u eq '!*sq and (w:= diffsq(cadr u,v)))
          then go to c  % extended kernel found.
         else if x := get(car u,'dfform) then return apply3(x,u,v,n)
         else if x:= get(car u,dfn_prop u) then nil
         else if car u eq 'plus and (w := diffsq(simp u,v))
          then go to c
         else go to h;  % unknown derivative.
        y := x;
        z := cdr u;
    a:  w := diffsq(simp car z,v) . w;
        if caar w and null car y then go to h;  % unknown deriv.
        y := cdr y;
        z := cdr z;
        if z and y then go to a
         else if z or y then go to h;  % arguments do not match.
        y := reverse w;
        z := cdr u;
        w := nil ./ 1;
    b:  % computation of kernel derivative.
        if caar y
          then w := addsq(multsq(car y,simp subla(pair(caar x,z),
                                                   cdar x)),
                          w);
        x := cdr x;
        y := cdr y;
        if y then go to b;
    c:  % save calculated deriv in case it is used again.
        % if x := atsoc(u,dsubl!*) then go to d
        %  else x := u . nil;
        % dsubl!* := x . dsubl!*;
  % d:   rplacd(x,xadd(v . w,cdr x,t));
    e:  % allowance for power.
        % first check to see if kernel has weight.
        if (x := atsoc(u,wtl!*))
          then w := multpq('k!* .** (-cdr x),w);
        m := n-1;
        % Evaluation is far more efficient if results are rationalized.
        return rationalizesq if n=1 then w
                else if flagp(dmode!*,'convert)
                     and null(n := int!-equiv!-chk
                                           apply1(get(dmode!*,'i2d),n))
                 then nil ./ 1
                else multsq(!*t2q((u .** m) .* n),w);
    f:  % Check for possible unused substitution rule.
        if not depends(u,v)
           and (not (x:= atsoc(u,powlis!*))
                 or not depends(cadddr x,v))
           and null !*depend
          then return nil ./ 1;
        % Derivative of a dependent identifier; maybe apply chain
        % rule.  Suppose u(v) = u(a(u),b(u),...), i.e. given
        % depend {u}, a, b, {a, b}, v;
        % then (essentially) depl!* = ((b v) (a v) (u b a))
        if !*expanddf and not(v memq (x:=cdr atsoc(u, depl!*))) then <<
           w := nil ./ 1;
           for each a in x do
              w := addsq(w, multsq(simp{'df,u,a},simp{'df,a,v}));
           go to e
        >>;
        w := list('df,u,v);
        w := if x := opmtch w then simp x else mksq(w,1);
        go to e;
    h:  % Final check for possible kernel deriv.
        if car u eq 'df then <<         % multiple derivative
           if cadr u eq v then
              % (df (df v x y z ...) v) ==> 0 if commutedf
              if !*commutedf and null !*depend then return nil ./ 1
              else if !*simpnoncomdf and (w:=atsoc(v, depl!*))
                 and null cddr w % and (cadr w eq (x:=caddr u))
              then
                 % (df (df v x) v) ==> (df v x 2)/(df v x) etc.
                 % if single independent variable
                 <<
                    x := caddr u;
                    % w := simp {'quotient, {'df,u,x}, {'df,v,x}};
                    w := quotsq(simp{'df,u,x},simp{'df,v,x});
                    go to e
                 >>
           else if eqcar(cadr u, 'int) then
              % (df (df (int F x) A) v) ==> (df (df (int F x) v) A) ?
              % Commute the derivatives to differentiate the integral?
              if caddr cadr u eq v then
                 % Evaluating (df u v) where u = (df (int F v) A)
                 % Just return (df F A) - derivative absorbed
                 << w := 'df . cadr cadr u . cddr u;  go to j >>
              else if !*allowdfint and
                 % Evaluating (df u v) where u = (df (int F x) A)
                 % (If dfint is also on then this will not arise!)
                 % Commute only if the result simplifies:
                 not_df_p(w := diffsq(simp!* cadr cadr u, v))
              then <<
                 % Generally must re-evaluate the integral (carefully!)
                 w := 'df . reval{'int, mk!*sq w, caddr cadr u} . cddr u;
                 go to j >>;  % derivative absorbed
           if (x := find_sub_df(w:= cadr u . merge!-ind!-vars(u,v),
                                           get('df,'kvalue)))
                          then <>
                       else w := 'df . w
        >> else w := {'df,u,v};
   j:   if (x := opmtch w) then w := simp x
         else if not depends(u,v) and null !*depend then return nil ./ 1
         else w := mksq(w,1);
      go to e
   end;

symbolic procedure dfform_int(u, v, n);
   % Simplify a SINGLE derivative of an integral.
   % u = '(int y x) [as main variable of SQ form]
   % v = kernel
   % n = integer power
   % Return SQ form of df(u**n, v) = n*u**(n-1)*df(u, v)
   % This routine is called by diffp via the hook
   % "if x := get(car u,'dfform) then return apply3(x,u,v,n)".
   % It does not necessarily need to use this hook, but it needs to be
   % called as an alternative to diffp so that the linearity of
   % differentiation has already been applied.
   begin scalar result, x, y;
      y := simp!* cadr u;  % SQ form integrand
      x := caddr u;  % kernel
      result :=
      if v eq x then y
         % df(int(y,x), x) -> y  replacing the let rule in INT.RED
      else if not !*intflag!* and       % not in the integrator
         % If used in the integrator it can cause infinite loops,
         % e.g. in df(int(int(f,x),y),x) and df(int(int(f,x),y),y)
         !*allowdfint and               % must be on for dfint to work
            << y := diffsq(y, v);  !*dfint or not_df_p y >>
               % it has simplified
      then simp{'int, mk!*sq y, x}  % MUST re-simplify it!!!
         % i.e. differentiate under the integral sign
         % df(int(y, x), v) -> int(df(y, v), x).
         % (Perhaps I should use prepsq - kernels are normally true prefix?)
      else !*kk2q{'df, u, v};  % remain unchanged
      if not(n=1) then
         result := multsq( (((u .** (n-1)) .* n) .+ nil) ./ 1, result);
      return result
   end;

symbolic procedure not_df_p y;
   % True if the SQ form y is not a df kernel.
   not(denr y eq 1 and
       not domainp (y := numr y) and eqcar(mvar y, 'df));

% Compute a dfn-property name corresponding to the argument number
% of an operator expression. Here we assume that most functions
% will have not more than 3 arguments.

symbolic procedure dfn_prop(w);
  (if n=1 then 'dfn else if n=2 then 'dfn2 else if n=3 then 'dfn3
    else mkid('dfn,n))
     where n=length cdr w;

% The following three functions, and the hooks to this code above, were
% suggested by Gerhard Post and Marcel Roelofs.

symbolic procedure find_sub_df(df_args,df_values);
   df_values and
      (is_sub_df(df_args,car df_values) or
       find_sub_df(df_args,cdr df_values));

symbolic procedure is_sub_df(df_args,df_value);
   begin scalar df_set,kernel,n,entry;
     if car(df_args) neq cadar(df_value) then return nil;  % check fns.
     df_args := dot_df_args cdr df_args;
     df_set  := cddar df_value;
     while df_set and df_args do              % Check differentiations.
       <>;
     return if df_args then (cadr(df_value) . df_args);
   end;

symbolic procedure dot_df_args l;
   begin scalar kernel,n,df_args;
     while l do
       <>;
     return df_args;
   end;

symbolic procedure merge!-ind!-vars(u,v);
   % Consider (df u v) where u = (df a b c d ...)
   % It is non-commuting if a = v or if a in (b c d ...)
   % i.e. if a in (v b c d ...)
   if !*nocommutedf or
      (not !*commutedf and (cadr u memq (v . cddr u)))
   then derad!*(v,cddr u) else derad(v,cddr u);

symbolic procedure derad!*(u,v);        % Non-commuting derad
   %% Return the canonical list of differentiation variables
   %% equivalent to v,u, where v is a LIST of previus differentiation
   %% variables, when df(df(f(v,u), v), u) is simplified to
   %% df(f(v,u), v, u).  Essentially just cons u onto v.
   reverse
      if u eq car(v:=reverse v) then   % x,y, y
         2 . v
      else if numberp car v and u eq cadr v then % x,y,n, y
         (car v + 1) . cdr v
      else u . v;                       % x,y, z

symbolic procedure derad(u,v);
   if null v then list u
    else if numberp car v then car v . derad(u,cdr v)
    else if u=car v then if cdr v and numberp cadr v
                           then u . (cadr v + 1) . cddr v
                          else u . 2 . cdr v
    else if ordp(u,car v) then u . v
    else car v . derad(u,cdr v);

symbolic procedure letdf(u,v,w,x,b);
   begin scalar y,z,dfn;
        if atom cadr x then go to b
         else if not idp caadr x then typerr(caadr x,"operator")
         else if not get(caadr x,'simpfn)
          then <>;
        rmsubs();
        dfn := dfn_prop cadr x;
        if not(mcond!* eq 't)
                or not frlp cdadr x
                or null cddr x
                or cdddr x
                or not frlp cddr x
                or not idlistp cdadr x
                or repeats cdadr x
                or not(caddr x member cdadr x)
         then go to b;
        z := lpos(caddr x,cdadr x);
        if not get(caadr x,dfn)
            then put(caadr x,
                     dfn,
                     nlist(nil,length cdadr x));
        w := get(caadr x,dfn);
        if length w neq length cdadr x
          then rerror(poly,17,
                      list("Incompatible DF rule argument length for",
                            caadr x));
   a:   if null w or z=0 then return errpri1 u
         else if z neq 1
          then <>
         else if null b then y := append(reverse y,nil . cdr w)
         else y := append(reverse y,(cdadr x . v) . cdr w);
        return put(caadr x,dfn,y);
   b:   %check for dependency;
        if caddr x memq frlis!* then return nil
         else if idp cadr x and not(cadr x memq frlis!*)
           then depend1(cadr x,caddr x,t)
         else if not atom cadr x and idp caadr x and frlp cdadr x
          then depend1(caadr x,caddr x,t);
        return nil
   end;

symbolic procedure frlp u;
   null u or (car u memq frlis!* and frlp cdr u);

symbolic procedure lpos(u,v);
   if u eq car v then 1 else lpos(u,cdr v)+1;


endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/compopr.red0000644000175000017500000002507511526203062023653 0ustar  giovannigiovannimodule compopr;   % Operators on Complex Expressions.

% Author: Eberhard Schruefer.
% Modifications by:  Francis Wright.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp !*factor kord!*);

put('repart,'simpfn,'simprepart);

symbolic procedure simprepart u;
   repartsq simp!* car u where !*factor = nil;

symbolic procedure repartsq u;
   multsq(addsq(multsq(repartnum,repartden),
                multsq(impartnum,impartden)),
          invsq addsq(multsq(repartden,repartden),
                      multsq(impartden,impartden)))
   where repartnum = car reimnum, impartnum = cdr reimnum,
         repartden = car reimden, impartden = cdr reimden
   where reimnum = splitcomplex numr u,
         reimden = splitcomplex denr u;

put('impart,'simpfn,'simpimpart);

symbolic procedure simpimpart u;
   impartsq simp!* car u where !*factor = nil;

symbolic procedure impartsq u;
   multsq(addsq(multsq(impartnum,repartden),
                negsq multsq(repartnum,impartden)),
          invsq addsq(multsq(repartden,repartden),
                      multsq(impartden,impartden)))
   where repartnum = car reimnum, impartnum = cdr reimnum,
         repartden = car reimden, impartden = cdr reimden
   where reimnum = splitcomplex numr u,
         reimden = splitcomplex denr u;

put('conj,'simpfn,'simpconj);

symbolic procedure simpconj u;
   conjsq simp!* car u;

symbolic procedure conjsq u;
  (if null numr w then u else addsq(repartsq u,negsq multsq(simp 'i,w)))
   where w=impartsq u;

smacro procedure idomainp; get('i,'idvalfn);
  % Tests if 'i' is transformed to a domain structure.

symbolic procedure splitcomplex u;
   (begin scalar v;
      v := if idomainp() then expand!-imrepart u
            else <>;
                   subs2 expand!-imrepart u>>;
      return take!-realpart v . take!-impart v
    end) where kord!* = kord!*,!*exp = t;

symbolic procedure expand!-imrepart u;
   if domainp u then u ./ 1
    else addsq(multsq(expand!-imrepartpow lpow u,
                      expand!-imrepart lc u),
               expand!-imrepart red u);

symbolic procedure expand!-imrepartpow u;
   % This needs to treat kernels that are standard forms smarter.
   % At the moment, we expand to get the required result.
   begin scalar !*exp,cmpxsplitfn;
     !*exp := t;
     cmpxsplitfn := null idp car u and
                    get(car car u,'cmpxsplitfn);
     return
       exptsq(if null cmpxsplitfn
                 then if car u eq 'i then !*k2q 'i
                       else addsq(mkrepart car u,
                                  multsq(simp 'i,
                                         mkimpart car u))
               else apply1(cmpxsplitfn,car u),cdr u)
    end;

symbolic procedure mkrepart u;
   if realvaluedp u then !*k2q u
    else if sfp u then repartsq(u ./ 1)
    else mksq(list('repart, u),1);

symbolic procedure mkimpart u;
   if realvaluedp u then nil ./ 1
    else if sfp u then impartsq(u ./ 1)
    else mksq(list('impart, u),1);

symbolic procedure take!-realpart u;
   repartf numr u ./ denr u;

symbolic procedure repartf u;
   % We can't check for null dmode!* as there may still be complex
   % domain elements in the expression (e.g., e^repart x).
  (if domainp u
      then if atom u then u
            else if get(car u,'cmpxfn)
            % We now know u is of form (  . ).
              then int!-equiv!-chk(car u . cadr u .
                        cadr apply1(get(car u,'i2d),0))
        % Otherwise we assume it is real
       else u
    else if mvar u eq 'i then repartf red u
%    else if null dmode!* then addf(!*t2f lt u,repartf red u)
    else addf(multpf(lpow u,repartf lc u),repartf red u))
       where u = reorder u where kord!* = 'i . kord!*;

symbolic procedure take!-impart u;
   impartf numr u ./ denr u;

symbolic procedure impartf u;
   % We can't check for null dmode!* as there may still be complex
   % domain elements in the expression.
  (if domainp u
     then if atom u then nil
           else if get(car u,'cmpxfn)
            % We now know u is of form (  . ).
             then int!-equiv!-chk(car u . cddr u .
                                  cadr apply1(get(car u,'i2d),0))
        % Otherwise we assume it is real
       else nil
    else if mvar u eq 'i then addf(lc u,impartf red u)
%   else if null dmode!* then impartf red u
    else addf(multpf(lpow u,impartf lc u),impartf red u))
       where u = reorder u where kord!* = 'i . kord!*;

% The following code attempts to improve the way that the complex
% operators CONJ, REPART and IMPART handle values that are implicitly
% real, namely composed "reality-preserving" functions of explicitly
% real numbers, implicitly real symbolic constants and variables that
% the user has declared using the REALVALUED command defined below.

% All arithmetic operations, direct trig functions and the exponential
% function are "reality-preserving", but inverse trig functions and the
% logarithm are "reality-preserving" only for real arguments in a
% restricted range.  This relates to piecewise-defined functions!  This
% code is believed to make the right decision about implicit reality in
% straightforward cases, and otherwise errs on the side of caution and
% makes no assumption at all, as does the standard REDUCE 3.4 code.  It
% performs only very limited numerical evaluation, which should be very
% fast.  It never performs any approximate numerical evaluation, or any
% sophisticated analysis, both of which would be much slower and/or
% complicated.  The current strategy is believed to represent a
% reasonable compromise, and will normally give the user what they
% expect without undue overhead.

rlistat '(realvalued notrealvalued);   % Make user operators.

symbolic procedure realvalued u;
   % Command to allow the user to declare functions or variables to be
   % implicitly real valued.
   <>;

symbolic procedure notrealvalued u;
   % Undo realvalued declaration.
   % Cannot recover "complexity", so no need for rmsubs().
   for each v in u do
      if not idp v then typerr(v,"id")
       else remflag(list v, 'realvalued);

flag('(realvaluedp),'boolean); % Make realvaluedp available in
                               % algebraic mode.

symbolic procedure realvaluedp u;
   % True if the true prefix kernel form u is explicitly or implicitly
   % real-valued.
   if atom u then numberp u or flagp(u, 'realvalued)
   else begin scalar caru; % cnd
     return
      flagp((caru := car u), 'alwaysrealvalued)
         % real-valued for all possible argument values
      or (flagp(caru, 'realvalued) and realvaluedlist cdr u)
         % real-valued function if arguments are real-valued,
         % an important common special case of condrealvalued.
%%      or ((cnd := get(caru, 'condrealvalued)) and apply(cnd, cdr u))
         % real-valued function if arguments satisfy conditions
         % that depend on the function
      or caru eq '!:rd!:;  % rounded number - least likely?
   end;

symbolic procedure realvaluedlist u;
   % True if every element of the list u of true prefix kernel forms
   % is real-valued.
   realvaluedp car u and (null cdr u or realvaluedlist cdr u);

% Define the real valued properties
% ---------------------------------

% Only operators that can remain symbolic need be considered,
% e.g. NOT nextprime, num, den, deg, det.

% A very small number of functions are real-valued for ALL arguments:

flag('(repart impart abs ceiling floor fix round max min),
     'alwaysrealvalued);

% Symbolic constants:

flag('(pi e infinity),'realvalued);

% Some functions are real-valued if all their arguments are
% real-valued, without further constraints:

% Arithmetic operators:

flag('(plus minus times quotient), 'realvalued);

% Elementary transcendental functions, etc:

flag('(exp cbrt hypot sin cos tan csc sec cot sind cosd tand cscd secd
       cotd sinh cosh tanh csch sech coth atan atand atan2 atan2d acot
       acotd asinh acsch factorial),
     'realvalued);

% Additional such variables and functions can be declared by the user
% with the REALVALUED command defined above.


put('sin,'cmpxsplitfn,'reimsin);

symbolic procedure reimsin u;
   addsq(multsq(simp list('sin,rearg),
                simp list('cosh,imarg)),
         multsq(simp 'i,
                multsq(simp list('cos,rearg),
                       simp list('sinh,imarg))))
   where rearg = prepsq simprepart cdr u,
         imarg = prepsq simpimpart cdr u;

put('cos,'cmpxsplitfn,'reimcos);

symbolic procedure reimcos u;
   addsq(multsq(simp list('cos,rearg),
                simp list('cosh,imarg)),
         multsq(simp 'i,negsq
                multsq(simp list('sin,rearg),
                       simp list('sinh,imarg))))
   where rearg = prepsq simprepart cdr u,
         imarg = prepsq simpimpart cdr u;

put('expt,'cmpxsplitfn,'reimexpt);

symbolic procedure reimexpt u;
   if cadr u eq 'e
     then addsq(reimcos list('cos,reval list('times,'i,caddr u)),
                multsq(simp list('minus,'i),
                    reimsin list('sin,reval list('times,'i,caddr u))))
    else if fixp cadr u and cadr u > 0
              and eqcar(caddr u,'quotient)
              and fixp cadr caddr u
              and fixp caddr caddr u
     then mksq(u,1)
    else addsq(mkrepart u,multsq(simp 'i,mkimpart u));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/polydiv.red0000644000175000017500000001666611526203062023670 0ustar  giovannigiovannimodule polydiv;  % Enhanced polynomial division.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, 6 Nov 1995.

% Defines (or redefines) the following polynomial division operators:
%   divide, div and remainder (mod),
%   pseudo_divide, pseudo_quotient (pseudo_div) and pseudo_remainder.

% However, for now, div has been commented out, since it conflicts with
% other packages (avector and fide).

% ===================================================================

% Enhanced algebraic-mode operators for performing polynomial division
% over the current coefficient domain, based on the operator REMAINDER
% currently defined in poly.red by  put('remainder,'polyfn,'remf);

% divide(p,q) or p divide q returns an algebraic list {quotient,
% remainder} of p divided by q as polynomials over the current domain.

% div(p,q) or p div q returns only the quotient.
% remainder(p,q) or p mod q returns only the remainder.

% div and mod are the operator names used in Pascal for Euclidean
% (integer) division.

% An optional third argument (for the prefix forms) specifies the
% variable to treat as the leading variable for the (effectively
% univariate) polynomial division.


% Interface code
% ==============

% Regular division:
% ----------------

put('divide, 'psopfn, 'poly!-divide);
symbolic procedure poly!-divide u;
   poly!-divide!*(u, nil, nil);

remprop('remainder, 'polyfn);
put('remainder, 'psopfn, 'poly!-remainder);
put('mod, 'psopfn, 'poly!-remainder);   % name from Pascal
symbolic procedure poly!-remainder u;
   poly!-divide!*(u, 'remainder, nil);

% put('div, 'psopfn, 'poly!-quotient);    % name from Pascal
symbolic procedure poly!-quotient u;
   poly!-divide!*(u, 'quotient, nil);

infix divide, mod;
% infix div;
% Set a relatively low precedence:
precedence divide, freeof;  % higher than freeof, lower than +
% precedence div, divide;
% precedence mod, div;


% Pseudo-division:
% ---------------

put('pseudo_divide, 'psopfn, 'pseudo!-divide);
symbolic procedure pseudo!-divide u;
   poly!-divide!*(u, nil, t);

put('pseudo_remainder, 'psopfn, 'pseudo!-remainder);
symbolic procedure pseudo!-remainder u;
   poly!-divide!*(u, 'remainder, t);

put('pseudo_div, 'psopfn, 'pseudo!-quotient);
put('pseudo_quotient, 'psopfn, 'pseudo!-quotient);
symbolic procedure pseudo!-quotient u;
   poly!-divide!*(u, 'quotient, t);


fluid '(kord!*);

symbolic procedure poly!-divide!*(u, fn, pseudo);  % u = (p, q, x)
   % Returns the quotient and remainder of p (pseudo-)divided by q.
   % If specified, x is made the leading variable before dividing,
   % otherwise the first variable found is used.
   begin scalar p, q, x, new_kord;
      if null cdr u then RedErr "Divisor required";
      if length u > 3 then
         RedErr "Division operators take 2 or 3 arguments.";
      if null (q := !*a2f cadr u) then RedErr "Zero divisor";
      p := !*a2f car u;
      if cddr u and (x := !*a2k caddr u) and
         not(kord!* and x eq car kord!*) then <<
            new_kord := t;  updkorder x;
            p := reorder p;  q := reorder q
         >> where kord!* = kord!*;      % preserve environment
      u := if pseudo then pseudo!-qremf(p, q, x) else qremf(p, q);
      p := car u;  q := cdr u;
      if new_kord then <<
         if not(fn eq 'remainder) then p := reorder p;
         if not(fn eq 'quotient) then q := reorder q
      >>;
      return
         if fn eq 'remainder then mk!*sq (q ./ 1)
         else if fn eq 'quotient then mk!*sq (p ./ 1)
         else {'list, mk!*sq (p ./ 1), mk!*sq (q ./ 1)}
   end;


% Pseudo-division code
% ====================

symbolic procedure pseudo!-qremf(u, v, var);
   % Returns quotient and remainder of u pseudo-divided by v wrt var.
   % u and v are standard forms, var is a kernel or nil.
   % If var = nil then var := first kernel found.
   % Internally, polynomials are represented as coeff lists wrt var,
   % i.e. as lists of forms.
   % (Knuth 1981, Seminumerical Algorithms, Algorithm R, page 407.)
   begin scalar no_var, m, n, k, q0, q, car_v, car_u, vv;
      no_var := null var;
      m := if domainp u or (var and not(mvar u eq var)) then  0
      else << if not var then var := mvar u;  ldeg u >>;
      n := if domainp v or (var and not(mvar v eq var)) then  0
      else << if not var then var := mvar v;  ldeg v >>;

      %% The following special-case code for n = 0 and m < n is not
      %% necessary, but could be a cheap efficiency measure.
      %% if zerop n then return multf(exptf(v,m), u) . nil;
      %% if minusp(k := m - n) then return nil . u;

      u := if zerop m then {u} else coeffs u;
      v := if zerop n then {v} else coeffs v;
      if no_var and not(domainp_list v and domainp_list u) then
         msgpri("Main division variable selected is", var,
            nil, nil, nil);
      k := m - n;  car_v := car v;
      while k >= 0 do <<
         %% Compute the quotient q EFFICIENTLY.
         %% q0 = (q_0 ... q_k) without powers of v_n
         q0 := (car_u := car u) . q0;
         vv := cdr v;
         u := for each c in cdr u collect <<
            c := multf(c, car_v);
            if vv then <<
               c := subtrf(c, multf(car_u, car vv));
               vv := cdr vv
            >>;
            c
         >>;
         k := k - 1
      >>;
      if q0 then <<
         %% Reverse q0 and multiply in powers of v_n:
         q := car q0 . nil;  vv := 1;   % v_n^0
         while (q0 := cdr q0) do
            q := multf(car q0, (vv := multf(vv, car_v))) . q
      >>;
      return coeffs!-to!-form(q, var) . coeffs!-to!-form(u, var)
   end;

symbolic procedure coeffs!-to!-form(coeff_list, var);
   % Convert a coefficient list in DESCENDING power order to a
   % standard form wrt the specified variable var:
   coeff_list and
      coeffs!-to!-form1(coeff_list, var, length coeff_list - 1);

symbolic procedure coeffs!-to!-form1(coeff_list, var, d);
   if d > 0 then
      ( if car coeff_list then
         ((var .^ d) .* (car coeff_list)) .+ reductum
      else reductum )
         where reductum =
            coeffs!-to!-form1(cdr coeff_list, var, d - 1)
   else car coeff_list;

symbolic procedure domainp_list coeff_list;
   % Returns true if argument is a list of domain elements:
   null coeff_list or
      (domainp car coeff_list and domainp_list cdr coeff_list);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/modular.red0000644000175000017500000002064311526203062023633 0ustar  giovannigiovannimodule modular; % *** Tables for modular integers ***.

% Author: Anthony C. Hearn and Herbert Melenk.

% Copyright (c) 1995 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(domainlist!*);

fluid '(!*balanced_mod !*modular !*precise current!-modulus alglist!*
        dmode!*);

switch modular,balanced_mod;

domainlist!* := union('(!:mod!:),domainlist!*);

put('modular,'tag,'!:mod!:);
put('!:mod!:,'dname,'modular);
flag('(!:mod!:),'field);
flag('(!:mod!:),'convert);
put('!:mod!:,'i2d,'!*i2mod);
put('!:mod!:,'!:ft!:,'modcnv);
put('!:mod!:,'!:rn!:,'modcnv);
put('!:mod!:,'minusp,'modminusp!:);
put('!:mod!:,'plus,'modplus!:);
put('!:mod!:,'times,'modtimes!:);
put('!:mod!:,'difference,'moddifference!:);
put('!:mod!:,'quotient,'modquotient!:);
put('!:mod!:,'divide,'moddivide!:);
put('!:mod!:,'gcd,'modgcd!:);
put('!:mod!:,'zerop,'modzerop!:);
put('!:mod!:,'onep,'modonep!:);
put('!:mod!:,'factorfn,'factormod!:);
put('!:mod!:,'sqfrfactorfn,'factormod!:);
put('!:mod!:,'expt,'exptmod!:);
put('!:mod!:,'prepfn,'modprep!:);
put('!:mod!:,'prifn,'(lambda(x) (prin2!* (prepf x))));

put('!:mod!:,'unitsfn,'!:mod!:unitconv);

symbolic procedure !*modular2f u;
   % Convert u to a modular number.  Treat 0 as special case, but not 1.
   % Also allow for !*balanced_mod.
   if u=0 then nil
%   else if u=1 then 1
    else if !*balanced_mod
     then if u+u>current!-modulus
            then '!:mod!: . (u - current!-modulus)
           else if u+u <= - current!-modulus
            then !*modular2f(u + current!-modulus)
           else '!:mod!: . u
    else '!:mod!: . u;

symbolic procedure exptmod!:(u,n);
% This procedure will check for cdr u > n-1 if n prime.
% This used to treat 1 as a special case.
   !*modular2f general!-modular!-expt(cdr u,n);

symbolic procedure !:mod!:unitconv(u,v);
  if v=1 then u else
   (if x then multd(x,numr u) ./ multd(x,denr u)
     else mod!-error {'quotient,1,cdr v})
    where x = !*modular2f !:mod!:units(current!-modulus,y,0,1)
    where y = if cdr v>0 or null !*balanced_mod then cdr v
               else current!-modulus+cdr v;

symbolic procedure !:mod!:units(a,b,x,y);
   % Same procedure as general!-reciprocal!-by!-degree in genmod
   %  without error call.
   if b=0 then 0
    else if b=1 then if y < 0 then y+current!-modulus else y
    else begin scalar w;
           w := a/b;
           return !:mod!:units(b,a-b*w,y,x-y*w)
         end;

symbolic procedure !*i2mod u;
   % Converts integer U to modular form.
%  if (u := general!-modular!-number u)=0 then nil else '!:mod!: . u;
   !*modular2f general!-modular!-number u;

symbolic procedure modcnv u;
   rerror(poly,13,list("Conversion between modular integers and",
                       get(car u,'dname),"not defined"));

symbolic procedure modminusp!: u;
   if !*balanced_mod then 2*cdr u > current!-modulus else nil;

symbolic procedure modplus!:(u,v);
   !*modular2f general!-modular!-plus(cdr u,cdr v);

symbolic procedure modtimes!:(u,v);
   !*modular2f general!-modular!-times(cdr u,cdr v);

symbolic procedure moddifference!:(u,v);
   !*modular2f general!-modular!-difference(cdr u,cdr v);

symbolic procedure moddivide!:(u,v); !*i2mod 0 . u;

symbolic procedure modgcd!:(u,v); !*i2mod 1;

symbolic procedure modquotient!:(u,v);
   !*modular2f general!-modular!-times(cdr u,
                                   general!-modular!-reciprocal cdr v);

symbolic procedure modzerop!: u; cdr u=0;

symbolic procedure modonep!: u; cdr u=1;

symbolic procedure factormod!: u;
   begin scalar alglist!*,dmode!*;
      % 1 is needed since factorize expects first factor to be a number.
      return pfactor(!*q2f resimp(u ./ 1),current!-modulus)
   end;

symbolic procedure modprep!: u;
   cdr u;

initdmode 'modular;


% Modular routines are defined in the GENMOD module with the exception
% of the following:

symbolic procedure setmod u;
   % Returns value of CURRENT!-MODULUS on entry unless an error
   % occurs.  It crudely distinguishes between prime moduli, for which
   % division is possible, and others, for which it possibly is not.
   % The code should really distinguish prime powers and composites as
   % well.
   begin scalar dmode!*;
      if not atom u then u := car u;   % Since setmod is a psopfn.
      u := reval u;  % dmode* is NIL, so this won't be reduced wrt
                     % current modulus.
      if fixp u and u>0
        then <>
      else if u=0 or null u then return current!-modulus
       else typerr(u,"modulus")
   end;

put('setmod, 'psopfn, 'setmod);

% A more general definition of general-modular-number.

%symbolic procedure general!-modular!-number m;
   % Returns normalized M.
%   (lambda n; %if n<0 then n+current!-modulus else n)
%   if atom m then remainder(m,current!-modulus)
%    else begin scalar x;
%       x := dcombine(m,current!-modulus,'divide);
%        return cdr x
%     end;

% Support for "mod" as an infix operator.

infix mod;

precedence mod,over;

put('mod,'psopfn,'evalmod);

symbolic procedure evalmod u;
  begin scalar dm,cp,m,mm,w,!*rounded,!*modular;
    if !*complex then
      <>;
    if (dm:=get(dmode!*,'dname)) then setdmode(dm,nil);
    % We need to evaluate the first term before setting any modulus.
    % e.g., a := -8/7; (num a) mod 7;
    w:=aeval!* car u;
    m:=ieval cadr u;
    setdmode('modular,t); !*modular:=t;
    mm:=apply1('setmod,{m});
    w := aeval!* w;
    apply1('setmod,{mm});
    if dm neq 'modular then
     <>;
    if cp then <>;
    return w;
  end;

% Support for function evaluation in the modular domain.
% At present only rational exponentiation, including surds.

put('!:mod!:,'domainvalchk,'mod!-domainvalchk);

symbolic procedure mod!-domainvalchk(fn,u);
   begin scalar w;
    w:=if fn='expt then mod!-expt!-fract(car u,cadr u)
       else nil;
    return if w='failed then nil else w ./1;
   end;

symbolic procedure mod!-expt!-fract(u,x);
 % Modular u**x where x is a rational number n/m. Compute a solution of
 % q^n=u^m. If *precise on, expressions with non-unique are not
 % simplified. Non existing surds are mapped to an error message.
  begin scalar n,m,w;
    if denr u =1 then u:=numr u else go to done;
    if eqcar(u,'!:mod!:) then t
      else if fixp u then u:= '!:mod!: . u else go to done;
    if u='(!:mod!: . 1) then return 1;
    n:=numr x; m:=denr x;
    if not fixp n or not fixp m then go to done;
    if m=1 then return exptmod!:(u,n);
    load!-package 'modsr;
    w := msolve {{'equal,{'expt,'x,m},{'expt,cdr u,n}}};
    if w eq 'failed then return w else w := cdr w;
    if null w then mod!-error({'expt,u,{'quotient,n,m}});
    if null cdr w or null !*precise then return caddr cadr car w;
      % value is not unique - prevent the default integer
      % handling that would compute an incorrect value.
      % e.g. sqrt(4) mod 9 is not 2 but {2,7}.
    return !*k2f car fkern {'expt,cdr u,{'quotient,n,m}};
 done:
    return if null w or cdr w then 'failed else caddr car w;
 end;

symbolic procedure mod!-error u;
   typerr(u, {"expression mod", current!-modulus});

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/decompos.red0000644000175000017500000003402511526203062024000 0ustar  giovannigiovannimodule decompos; % Decomposition of polynomials f(x) = g(h(x)).

% Author: Herbert Melenk .

% Algorithms: 1. univariate case:
%            V.S. Alagar, M.Tanh: Fast Polynomial Decomposition
%            Algorithms, EUROCAL 1985, pp 150-153 (Springer).
%
%             2. multivariate lifting:
%            J. von zur Gathen: Functional Decomposition of Polynomials:
%            the Tame Case, J. Symbolic Computation (1990) 9, 281-299.

% Copyright (c) 1990 ZIB.
%
%     1-July-93  Replaced gensym calls by local name generator.
%                Otherwise decompose may produce different results
%                for identical input.
%    29-Apr.-93: completed normalization of multivariate results:
%                shifting sign and content (field: leading coefficient)
%                and absolute term to the 1st form.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(decomposegensym!*);

put('decompose,'psopfn,'decomposesf);

symbolic procedure decomposesf f;
  'list . reverse decomposef2(simp reval car f,t)
        where !*factor=nil,!*exp=t;

symbolic procedure decomposef1(f,msg);
    decomposef2(f ./ 1 ,msg);

symbolic procedure decomposef2(f,msg);
   begin scalar hvars,r,rr,x,y,u,vars,newvars,d;
      decomposegensym!*:=1000;
      vars := decomposesfvars(numr f,nil);
      newvars := for each x in vars collect decomposegensym();
      d := denr f;
      if not domainp d
        then rerror(poly,18,typerr(prepsq f,"polynomial"));
      f := numr subf(numr f,pair(vars,newvars));
      if length vars = 1 then r := decomposesfuni0 f
       else r := decomposesfmulti(f,newvars);
      hvars := '(u v w a b c d e);
      for each x in vars do hvars := delete (x,hvars);
      while r do
       <>
                      else x:=decomposegensym();
                  u := prepsq subsq(car r,list(mvar numr car r . x));
                  if d neq 1 then<>;
                  rr := (if y then list('EQUAL,y,u) else u) . rr>>
          else <>;
         r := cdr r>>;
      rr := subla(pair(newvars,vars),car rr) . cdr rr;
      return rr
   end;

symbolic procedure decomposesfvars(f,v);
    % Select the kernels from a standard form.
      if domainp f then v else
        decomposesfvars(red f,
            decomposesfvars(lc f,
                if not member(mvar f,v)
                 then append(v,list mvar f) else v));

symbolic procedure decomposesfuni0 f;
    for each p in decomposesfuni f collect (p ./ 1);

symbolic procedure decomposesfuni f;
    % Univariate variant.
   begin scalar x,y,res,ddfl,h,testf;
      integer n;
     n := ldeg f;
     if primep n then return list f;
     x := mvar f; y := decomposegensym();
     ddfl := decomposefctrf decomposedf(f,x);
    if length ddfl > 1 then
     for each d in ddfl do
      if null res and 0=remainder(n , (ldeg d + 1)) then
      <>;
      if null res then return list f else
          return for each u in res join decomposesfuni u
   end;

symbolic procedure decomposefctrf f;
    % Generate all factors of f by combining the prime factors.
   begin scalar u,w,q;
       q := fctrf f; u:= cdr q;
       if length u = 1 and cdar u=1 then return list f;
          % eliminate the two trivial factors.
       w := delete(quotf(f,car q),decomposefctrf1 u);
       w := delete(1,w);
       return w;
   end;

symbolic procedure decomposefctrf1 v;
    % Collect all possible crossproducts from v.
    if null v then '(1) else
    begin scalar r,c,q;
     c:=car v;
     r:=decomposefctrf1 cdr v;
     q:=for i:=1:cdr c collect exptf(car c,i);
     return
      append(r,
       for each u in q join
         for each p in r collect
             multf(u,p)  );
    end;

symbolic procedure decomposebacksubstuni(f,h,x);
  begin scalar c,g,n,p,pars,ansatz,eqs;
     p := 1; n := ldeg f/ldeg h;
     for i:=0:n do
     <>;
     pars := reverse pars;
     ansatz := addf(f , negf ansatz);
     eqs := decomposecoeff(ansatz,list x);
     eqs := solveeval list('list . for each u in eqs collect prepf u,
                       'list . pars);
     eqs := cdr cadr eqs; % select the only solution.
     for i:= 0:n do
       g := addf(g,numr simp list('times,list('expt,x,i),
                                  caddr nth(eqs,i+1)));
     return g
   end;

symbolic procedure decomposedf(f,x);
   % Differentiate a polynomial wrt top-level variable x.
   % Returns a standard form.
    if domainp f or not(mvar f = x) then nil else
    if ldeg f = 1 then lc f else
    mvar f .** (ldeg f - 1) .* multf(lc f,ldeg f)
           .+ decomposedf(red f,x);

symbolic procedure decomposeint(f,x);
   % Integrate a polynomial (standard form) wrt the (main-)variable x.
   % Returns a standard quotient.
    if null f then nil ./ 1 else
    if domainp f then (x .** 1 .* f .+ nil) ./ 1 else
    addsq(multsq((x .** (ldeg f + 1) .* 1 .+ nil)./ 1 ,
                 multsq(lc f./1,1 ./ldeg f+1))
          ,  decomposeint(red f,x));

symbolic procedure decomposecoeff(f,vars);
   % Select the coefficients of f wrt vars.
     begin scalar o;
       o := setkorder vars;
       f := reorder f;
       setkorder o;
       return decomposecoeff1(f,vars)
     end;

symbolic procedure decomposecoeff1(f,vars);
     if domainp f then nil else
     if not member(mvar f,vars) then list f else
     nconc(decomposecoeff1(lc f,vars),decomposecoeff1(red f,vars));

symbolic procedure decomposetdg f;
    % calculate total degree
    if domainp f then 0 else
    max(ldeg f + decomposetdg lc f, decomposetdg red f);

symbolic procedure  decomposedegr(f,vl);
   if domainp f then vl else
   < cdr v then cdr v := ldeg f;
     decomposedegr(lc f,vl);
     decomposedegr(red f,vl);
     vl>> where v = assoc(mvar f,vl);

symbolic procedure compose (u,v);
    % Calculate f(x)=u(v(x)) for standard forms u,v.
    if domainp u then u else
         numr subf(u,list(mvar u . prepf v));

% Multivariate polynomial decomposition.
%
% Technique:
%    select a field as domain (rational),
%      map f to a strongly monic polynomial by variable transform,
%        map f to a univariate image,
%            decompose the univariate polynomial,
%        lift decomposition to multivariate,
%      convert back to original variables,
%    transform back to original domain (if possible).

symbolic procedure decomposesfmulti(f,vars);
   % Multivariant case: map to field (rationals).
    begin scalar dm,ft,r,rr,a,q,c,p1,p2;
      if null dmode!* or not flagp(dmode!*,'field) then
     <> else ft := f;
     r := decomposesfmulti1(ft,vars);
     if dm then setdmode('rational,nil) where !*msg=nil;
     if null cdr r then return list(f./1);
 %   if null dm then return
 %      for each p in r collect (p ./ 1);
       % Convert back to integer polynomials.
     rr := for each p in reverse r collect simp prepf p;
     r := nil;
     while rr and cdr rr do
     <>;
     return car rr . r;
   end;

symbolic procedure decomposesfmulti1(f,vars);
  % Multivariate case: map to strongly monic polynomial.
    begin scalar lvars,ft,rt,x1,a0,kord,u,sigma;
     integer n,m;
       % get the variable with highest degree as main variable.
     u :=  decomposedegr(f,for each x in vars collect (x. 0));
     n := -1;
     for each x in u do
       if n>;
     if n<2 then return list f;
     vars := x1 . delete(x1,vars);
     kord := setkorder vars;
     f := reorder f;
       % Convert f to a strongly monic polynomial.
     n := decomposetdg f;
     x1 := car vars;
     lvars := for each x in cdr vars collect (x . decomposegensym());
    again:
     if m>10 then << rt := list f; goto ret>>;
       % construct transformation sigma
     sigma := for each x in lvars collect x . random 1000;
     ft := numr subf(f,for each x in sigma collect
           (caar x . list('plus,cdar x,list('times,x1,cdr x))));
     if not domainp lc ft then <>;
     a0 := lc ft; ft := quotf(ft,a0);
     rt := decomposesfmnorm(ft,n,sublis(lvars,vars));
     if cdr rt then
      % Transform result back.
     <> else rt := list f;
   ret:
     setkorder kord;
     rt := for each p in rt collect reorder p;
        % try further decomposition of central polynomial.
     return if cdr rt and decomposetdg car rt>1 then
         append(reverse cdr rt,decomposesfmulti1(car rt,vars))
           else reverse rt;
   end;

symbolic procedure decomposelmon f;
   % Extract the variables of the leading monomial.
     if domainp f then nil else
     mvar f . decomposelmon lc f;

symbolic procedure decomposenormfac p1;
  if null dmode!* or not flagp(dmode!*,'field) then
     multf(numr mkabsfd decomposecont p1,decomposesign p1)
    else <>;

symbolic procedure decomposecont f;
   % Calculate the content of f if the domain is a ring.
      if domainp f then f else
      gcdf(decomposecont lc f, decomposecont red f);

symbolic procedure decomposesign f;
   % Compute a unit factor c such that the leading coefficient of
   % f/c is a positive integer.
   if domainp f then numr quotsq(f ./ 1,mkabsfd f)
        else decomposesign lc f;

symbolic procedure decomposesfmnorm(f,n,vars);
   % Multivariate case: map strongly monic polynomial to univariate
   % and lift result.
   begin scalar x,x1,f0,g,u,abort,h,k,tt,q,v;
      integer r,s;
     x1 := car vars;
    % Step 1.
     f0 := numr subf(f,for each y in cdr vars collect (y . 0));
     u := decomposesfuni f0;
        % For multivariate we accept degree=1 polynomials as nontrivial
        % but inhibit recursion.
     if null cdr u then <>;
     x := decomposegensym();
     g := numr subf(car u,list (x1 . x));
     r := ldeg g;
     h := cadr u; u := cddr u;
     while u do
     <>;
      % Step 2.
     s := divide(n,r);
     if not(cdr s=0) then goto fail else s := car s;
     k := h;
     tt := compose(decomposedf(g,x),h);
      % Step 3: Hensel lifting in degree steps.
     for i:=1:s do
       if not abort then
        % Step 4: loop step.
       <>
       >>;
      if abort then goto fail;
      % Step 5: test result and loop for lower part.
      h := k;
      if f = compose(g,h) then return list(g,h);
  fail:  % Exit: no decomposition found.
     return list f;
   end;

symbolic procedure decomposehomog(f,x,d);
   % F is a polynomial (standard form) in x and some other
   % variables. Select that part of f, where the coefficients
   % of x are monomials in total degree d.
   % Result is the sum (standard form) of these monomials.
   begin scalar u,v;
      u := decomposehomog1(f,x,d);
      for each m in u do v := addf(v,m);
      return v;
  end;

symbolic procedure decomposehomog1(f,x,d);
   % Select the monomials.
   if d<0 or null f then nil else
   if domainp f then (if d=0 then list f else nil)
   else begin scalar u1,u2;
     u1:= decomposehomog1(lc f,x,if mvar f = x then d
                                  else d-ldeg f);
     u2:= decomposehomog1(red f,x,d);
     return
        nconc(
         for each v in u1 collect
              multf(mvar f .** ldeg f .*1 .+ nil , v),
           u2);
  end;

symbolic procedure decomposegensym();
   compress(append('(!! !D !! !c !! !.),
            explode2(decomposegensym!*:=decomposegensym!*+1)));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/specfac.red0000644000175000017500000003066211526203062023576 0ustar  giovannigiovannimodule specfac;   % Splitting of low degree polynomials.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*keepsqrts !*sub2 !*surds knowndiscrimsign kord!* zlist);

% switch surds;

exports cubicf,quadraticf,quarticf;

symbolic procedure coeffs pol;
% Extract coefficients of polynomial wrt its main variable and leading
% degree. Result is a list of coefficients.
    begin integer degree,deg1; scalar cofs,mv;
      mv := mvar pol;
      degree := ldeg pol;
      while not domainp pol and mvar pol eq mv do
       <>;
      for i:=1:degree-1 do cofs := nil . cofs;
      return reversip(pol . cofs)
   end;

symbolic procedure shift!-pol pol;
% Shifts main variable, mv, of square free nth degree polynomial pol so
% that coefficient of mv**(n-1) is zero.
% Does not assume pol is univariate.
   begin scalar lc1,ld,mv,pol1,redp,shift,x;
      mv := mvar pol;
      ld := ldeg pol;
      redp := red pol;
      if domainp redp or not(mvar redp eq mv) or ldeg redp<(ld-1)
        then return list(pol,1,nil ./ 1);
      lc1 := lc pol;
      x := lc redp;
      shift := quotsq(!*f2q x,!*f2q multd(ld,lc1));
      pol1 := subf1(pol,list(mv . mk!*sq addsq(!*k2q mv,negsq shift)));
      return list(numr pol1,denr pol1,shift)
   end;

symbolic procedure quadraticf!*(pol,var);
   if domainp pol then errach "invalid quadratic to factr"
    else if mvar pol = var then quadraticf pol
    else begin scalar kord,w;
        kord := kord!*;
        kord!* := list var;
        w := coeffs !*q2f resimp(pol ./ 1);
        kord!* := kord;
        w := quadraticf1(car w,cadr w,caddr w);
        if w eq 'failed then return list(1,pol);
        var := !*k2f var;
        return list(if car w neq 1 then mkrn(1,car w) else 1,
                    addf(multf(var,cadr w),caddr w),
                         addf(multf(var,cadddr w),car cddddr w))
     end;

symbolic procedure quadraticf pol;
   % Finds factors of square free quadratic polynomial pol (if they
   % exist).  Does not assume pol is univariate.
   (if x eq 'failed then list(1,pol)
    else if not domainp car x then list(1,pol)
            % Answer would be rational.
    else list(if car x neq 1 then mkrn(1,car x) else 1,
              y .* cadr x .+ caddr x,y .* cadddr x .+ car cddddr x)
       where y = (mvar pol .** 1))
    where x = quadraticf1(car w,cadr w,caddr w) where w = coeffs pol;

symbolic procedure quadraticf1(a,b,c);
   begin scalar a1,denom,discrim,w;
      if null b and minusf c and not minusf a
       then <>;
      discrim := powsubsf addf(exptf(b,2),multd(-4,multf(a,c)));
      % A null discriminator can arise from a polynomial such as
      % 16x^2+(32i-8)*x-8i-15;
      if null discrim then nil
       else <>
      %        else if not clogflag and minusf discrim
      %         then return 'failed;
               else if minusf discrim then return 'failed;
             discrim:=rootxf(discrim,2);
             if discrim='failed then return discrim>>;
      denom := multd(4,a);
      a := a1 := multd(2,a);
      w := addf(b,discrim);
      c := addf(b,negf discrim);
      b := w;
      if (w := gcdf(a,b)) neq 1
        then <>;
      if (w := gcdf(a,denom)) neq 1 and (w := gcdf(c,denom))
        then <>;
      return list(denom,a1,b,a,c)
    end;

symbolic procedure rootxf(u,n);
   % Return either polynomial nth root of u or "failed".
   begin scalar x,y,z,w;
      if domainp u
        then return if minusf u then 'failed
                     else if atom u and (y := irootn(u,n))**n=u then y
                     else if not atom u and (x := get(car u,'rootfn))
                      then apply2(x,u,n)
                     else if !*surds and not(u member zlist)
                      then nrootn!*(u,n)
                     else 'failed;
      x := comfac u;
      u := quotf(u,comfac!-to!-poly x);
      z := 1;
      if car x then if cdr(y := divide(cdar x,n)) = 0
                      then z := multpf(caar x .** car y,z)
                     else if !*surds
                      then <>
       else return 'failed;
      x := cdr x;
      if domainp x
        then if minusf x then return 'failed
              else if fixp x and (y := irootn(x,n))**n=x
               then z := multd(y,z)
              else if !*surds and fixp x
               then z := multf(nrootn!*(x,n),z)
              else if not atom x and (w := get(car x,'rootfn))
               then apply2(w,x,n)
              else return 'failed
       else if (y := rootxf(x,n)) eq 'failed then return y
       else z := multf(y,z);
      if u=1 then return z;
      x := sqfrf u;
   c: if null x then return z
       else if cdr(y := divide(cdar x,n)) = 0
        then <>
       else if !*surds
        then <>
       else return 'failed;
      go to c
   end;

symbolic procedure mkrootf(u,m,n);
   if m neq 2 or null !*keepsqrts
     then !*p2f mksp(list('expt,u,list('quotient,1,m)),n)
    else if n neq 1 then errach 'mkrootf
    else !*q2f simpsqrt list u;

symbolic procedure nrootn!*(u,n);
   % Returns a standard form representation of the nth root of u.
   begin scalar x;
      if null u then return nil;
      u := nrootn(u,n);
      x := cdr u;         % surd part.
      u := car u;         % rational part.
      if x=1 then return x;
      x := mkrootf(prepf x,n,1);
      return powsubsf multf(u,x)
   end;

symbolic procedure cubicf pol;
   % Split the cubic pol if a change of origin puts it in the form
   % (x-a)**3-b=0.
   begin scalar a,a0,a1,b,neg,p;
      p := shift!-pol pol;
      a := coeffs car p;
      if cadr a then return list(1,pol)
      % Cadr a non nil probably means there are some surds in the
      % coefficients that don't reduce to 0.
       else if caddr a then return list(1,pol);
      % Factorization not possible by this method.
      a0 := cadddr a;
      a := car a;
      if minusf a0 then <>;
      if (a := rootxf(a,3)) eq 'failed
         or (a0 := rootxf(a0,3)) eq 'failed
        then return list(1,pol);
      if neg then a0 := negf a0;
      a := !*f2q a;
      a0 := !*f2q a0;
      p := addsq(!*k2q mvar pol,caddr p);
      % Now numr (a*(mv+shift)+a0) is a factor of pol.
      a1 := numr addsq(multsq(a,p),a0);
      % quotf(pol,a) is quadratic factor. However, the surd division may
      % not work properly, so we calculate factor directly.
      b := multsq(a0,a0);
      b := addsq(b,multsq(negsq multsq(a,a0),p));
      b := numr addsq(b,multsq(multsq(a,a),exptsq(p,2)));
      return aconc!*(quadraticf b,a1)
   end;

symbolic procedure powsubsf u;
   % We believe that the result of this operation must be a polynomial.
   % If subs2q returns a rational, it must be because there are
   % unsimplified surds.  Hopefully rationalizesq can fix those.
   begin scalar !*sub2;
      u := subs2q !*f2q u;
      if denr u neq 1
        then <>;
      return numr u
   end;

symbolic procedure quarticf pol;
  % Splits quartics that can be written in the form
  % (x-a)**4+b*(x-a)**2+c.
  % Note that any call of rootxf can lead to a result "failed."
   begin scalar !*sub2,a,a2,a0,b,dsc,p,p1,p2,q,shift,var;
      var := mvar pol;
      p := shift!-pol pol;
      a := coeffs car p;
      shift := caddr p;
      if cadr a    % pol not correctly shifted, possibly due to sqrt.
      % e.g., 729para^4*be^4 - 81para^3*sqrt(27*be^2*para^2 - 8cte1^3)*
      % sqrt(3)*be^3 - 216para^2*be^2*cte1^3 + 12para*sqrt(27be^2*para^2
      %  - 8*cte1^3)*sqrt(3) *be*cte1^3 + 8*cte1^6.
         or cadddr a then return list(1,pol);
       % Factorization not possible by this method.
      a2 := cddr a;
      a0 := caddr a2;
      a2 := car a2;
      a := car a;
      q := quadraticf1(a,a2,a0);
      if not(q eq 'failed)
        then <>
       else if null !*surds or denr shift neq 1
        then return list(1,pol);
       % Factorization not possible by this method.
      shift := numr shift;
      if knowndiscrimsign eq 'negative then go to complex;
      dsc := powsubsf addf(exptf(a2,2),multd(-4,multf(a,a0)));
      p2 := minusf a0;
      if not p2 and minusf dsc then go to complex;
      p1 := not a2 or minusf a2;
      if not p1 then if p2 then p1 := t else p2 := t;
      p1 := if p1 then 'positive else 'negative;
      p2 := if p2 then 'negative else 'positive;
      a := rootxf(a,2);
      if a eq 'failed then return list(1,pol);
      dsc := rootxf(dsc,2);
      if dsc eq 'failed then return list(1,pol);
      p := invsq !*f2q addf(a,a);
      q := multsq(!*f2q addf(a2,negf dsc),p);
      p := multsq(!*f2q addf(a2,dsc),p);
      b := multf(a,exptf(addf(!*k2f mvar pol,shift),2));
      a := powsubsf addf(b,q);
      b := powsubsf addf(b,p);
      knowndiscrimsign := p1;
      a := quadraticf!*(a,var);
      knowndiscrimsign := p2;
      b := quadraticf!*(b,var);
      knowndiscrimsign := nil;
      return multf(car a,car b) . nconc!*(cdr a,cdr b);
      % Complex case.
   complex:
      a := rootxf(a,2);
      if a eq 'failed then return list(1,pol);
      a0 := rootxf(a0,2);
      if a0 eq 'failed then return list(1,pol);
      a2 := powsubsf addf(multf(2,multf(a,a0)),negf a2);
      a2 := rootxf(a2,2);
      if a2 eq 'failed then return list(1,pol);
      % Now a*(x+shift)**2 (+/-) b*(x+shift) + c is a factor.
      p := addf(!*k2f mvar pol,shift);
      q := addf(multf(a,exptf(p,2)),a0);
      p := multf(a2,p);
      a := powsubsf addf(q,p);
      b := powsubsf addf(q,negf p);
      knowndiscrimsign := 'negative;
      a := quadraticf!*(a,var);
      b := quadraticf!*(b,var);
      knowndiscrimsign := nil;
      return multf(car a,car b) . nconc!*(cdr a,cdr b)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/rational.red0000644000175000017500000001174411526203062024003 0ustar  giovannigiovannimodule rational; % *** Tables for rational numbers ***.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(domainlist!*);

switch rational;

domainlist!* := union('(!:rn!:),domainlist!*);
put('rational,'tag,'!:rn!:);
put('!:rn!:,'dname,'rational);
flag('(!:rn!:),'field);
put('!:rn!:,'i2d,'!*i2rn);
put('!:rn!:,'!:ft!:,'!*rn2ft);
put('!:rn!:,'minus,'rnminus!:);
put('!:rn!:,'minusp,'rnminusp!:);
put('!:rn!:,'plus,'rnplus!:);
put('!:rn!:,'times,'rntimes!:);
put('!:rn!:,'difference,'rndifference!:);
put('!:rn!:,'quotient,'rnquotient!:);
put('!:rn!:,'zerop,'rnzerop!:);
put('!:rn!:,'onep,'rnonep!:);
put('!:rn!:,'factorfn,'rnfactor!:);
put('!:rn!:,'expt,'rnexpt!:);
put('!:rn!:,'prepfn,'rnprep!:);
put('!:rn!:,'prifn,'rnprin);
put('!:rn!:,'intequivfn,'rnequiv);
put('!:rn!:,'rootfn,'rn!:root);
flag('(!:rn!:),'ratmode);

symbolic procedure rnexpt!:(u,n);
  % U is a tagged rational number, n an integer.
  begin scalar v;
     if n=0 then return 1;
     v:=cdr u;
     if (n<0) then <<
        n:=-n;
        if (car v < 0) then
           v:= (- cdr v) . (- car v)
           else v:= (cdr v) . (car v) >>;
     if (n=1) then return (car u) . v;
     return (car u) . ((car v ** n) . (cdr v ** n));
     % No more cancellation can take place in this exponentiation.
  end;

symbolic procedure mkratnum u;
   % U is a domain element. Value is equivalent real or complex
   % rational number.
   if atom u then !*i2rn u
    else if car u eq '!:gi!:
     then apply1(get('!:gi!:,'!:crn!:),u)
    else apply1(get(car u,'!:rn!:),u);

symbolic procedure mkrn(u,v);
   %converts two integers U and V into a rational number, an integer
   %or NIL;
   if v<0 then mkrn(-u,-v)
    else (lambda m; '!:rn!: . ((u/m) . (v/m))) gcdn(u,v);

symbolic procedure !*i2rn u;
   %converts integer U to rational number;
   '!:rn!: . (u . 1);

symbolic procedure rnminus!: u;
   % We must allow for a rational with structured arguments, since
   % lowest-terms can produce such objects.
   car u . !:minus cadr u . cddr u;

symbolic procedure rnminusp!: u;
   % We must allow for a rational with structured arguments, since
   % lowest-terms can produce such objects.
   if atom (u := cadr u) then u < 0 else apply1(get(car u,'minusp),u);

symbolic procedure rnplus!:(u,v);
   mkrn(cadr u*cddr v+cddr u*cadr v,cddr u*cddr v);

symbolic procedure rntimes!:(u,v);
   mkrn(cadr u*cadr v,cddr u*cddr v);

symbolic procedure rndifference!:(u,v);
   mkrn(cadr u*cddr v-cddr u*cadr v,cddr u*cddr v);

symbolic procedure rnquotient!:(u,v);
   mkrn(cadr u*cddr v,cddr u*cadr v);

symbolic procedure rnzerop!: u; cadr u=0;

symbolic procedure rnonep!: u; cadr u=1 and cddr u=1;

symbolic procedure rnfactor!: u;
   begin scalar x,y,dmode!*; integer m,n;
     x := subf(u,nil);
     if not domainp denr x then return {1,(u . 1)};
        % Don't know what else to do.
     y := factorf numr x;
     n := car y;
     dmode!* := '!:rn!:;
     y := for each j in cdr y collect
           <>;
     return int!-equiv!-chk mkrn(n,denr x) . y
   end;

symbolic procedure rnprep!: u;
   % PREPF is called on arguments, since the LOWEST-TERMS code in extout
   % can create rational objects with structured arguments.
   (if cddr u=1 then x else list('quotient,x,prepf cddr u))
    where x = prepf cadr u;

symbolic procedure rnprin u;
   <>;

symbolic procedure rnequiv u;
   % Returns an equivalent integer if possible.
   if cdr(u := cdr u)=1 then car u else nil;

symbolic procedure rn!:root(u,n);
   (if x eq 'failed or y eq 'failed then 'failed else mkrn(x,y))
    where x=rootxf(cadr u,n), y=rootxf(cddr u,n);

initdmode 'rational;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/homog.red0000644000175000017500000000573211526203062023303 0ustar  giovannigiovannimodule homog; % Procedures for factorization of homogeneous polynomials.

% Authors: Shuichi Moritsugu 
%          and Eiichi Goto.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



symbolic procedure homogp s;
   % Confirmation of homogeneous polynomials.
      if domainp s or domainp car s then nil
        else if null cdadr s then nil
        else if domainp cdr lastnondomain cadr s then nil
        else if listsum caaadr s=listsum caar lastnondomain cadr s
         then t
        else nil;

symbolic procedure subs0 nm;
   %Substitution of 0 into exponent list.
      if null nm then nil
        else ((0 . cdaar nm) . cdar nm) . subs0 cdr nm;

symbolic procedure varss(v,d);
   % Ss of single variable.
      ((v . nil) . 1) . ((((d . nil) . 1) . nil) . 1);

symbolic procedure rconstnm(nm,nv,td);
   % Reconstruction of numerator.
      if null nm then nil
        else if domainp nm then ((td . mkzl(nv+1)) . nm) . nil
        else (((td-listsum caar nm) . caar nm) . cdar nm)
             . rconstnm(cdr nm,nv,td);

symbolic procedure rconst1(s,v,td);
   % Reconstruction of one factor.
      if homogp s then s
        else ((v . caar s) . (cdar s+1))
             . (reverse rconstnm(cadr s,cdar s,td) . cddr s);

symbolic procedure rconst(p,fctrlis);
   % Reconstruction of factors.
   begin scalar v,d,td,fs,fcf,ffl,x;
      v := car p; d := cdr p; fcf := car fctrlis;
      for i:=2:length fctrlis do
          <>;
      ffl := fcf . ffl;
      if d>0 then ffl := aconc(ffl,ss2sf varss(v,1) . d);
      return ffl;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/gcd.red0000644000175000017500000002704011526203062022723 0ustar  giovannigiovannimodule gcd; % Greatest common divisor routines.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp !*ezgcd !*gcd !*heugcd !*mcd asymplis!* dmode!*);

switch ezgcd,heugcd;

% Note: The handling of non-commuting quantities in the following is
% dubious. The problem is that to do things properly, a left- and
% right-hand gcd and quotient would be necessary.  For now, the code
% returns 1 if the quotient tests fail in gcdf1 for non-commuting
% arguments.

symbolic procedure comfac p;
  % P is a non-atomic standard form.
  % CAR of result is lowest common power of leading kernel in
  % every term in P (or NIL). CDR is gcd of all coefficients of
  % powers of leading kernel.
  % If field elements are involved, lnc is normalized to 1.
  % We need GCDF here since the same function is used by EZGCD.
   begin scalar x,y;
        if flagp(dmode!*,'field) and ((x := lnc p) neq 1)
          then p := multd(!:recip x,p);
        if null red p then return lt p;
        x := lc p;
        y := mvar p;
    a:  p := red p;
        if degr(p,y)=0
          then return nil
            . if domainp p or not(noncomp y and noncomp mvar p)
                then gcdf(x,p)
               else 1
         else if null red p then return lpow p . gcdf(x,lc p)
         else x := gcdf(lc p,x);
        go to a
   end;

symbolic procedure degr(u,var);
   if domainp u or not(mvar u eq var) then 0 else ldeg u;

put('gcd,'polyfn,'gcdf!*);

put('gcd,'number!-of!-args,2);

symbolic procedure gcdf!*(u,v);
   begin scalar !*gcd; !*gcd := t; return gcdf(u,v) end;

symbolic procedure gcdf(u,v);
   % U and V are standard forms.
   % Value is the gcd of U and V, complete only if *GCD is true.
   begin scalar !*exp,!*rounded;
      % The next line was to prevent numerators moving to denominators
      % as in weight x=1,y=2$ wtlevel 4$ wtest:=(z^4-z^3*y-z^3*x+z^2*y^2
      % +2*z^2*x*y+z^2*x^2-3*z*x^2*y-z*x^3+x^4)/z^5; wtest where z=>a;
      % However, the results are formally correct without it, and it
      % causes other problems.
      % if wtl!* then return 1;
      !*exp := t;
      u := if domainp u or domainp v or not !*ezgcd
      %       or dmode!* memq '(!:rn!: !:rd!:)  % Should be generalized.
              or dmode!* % I don't know what to do in this case.
              or free!-powerp u or free!-powerp v
             then gcdf1(u,v)
            else ezgcdf(u,v);
      return if minusf u then negf u else u
   end;

symbolic procedure free!-powerp u;
   not domainp u
      and (not fixp ldeg u or free!-powerp lc u or free!-powerp red u);

symbolic procedure gcdf1(u,v);
   begin scalar w;
      if null u then return v
       else if null v then return u
       else if u=1 or v=1 then return 1
       else if domainp u then return gcdfd(u,v)
       else if domainp v then return gcdfd(v,u)
       else if not num!-exponents u or not num!-exponents v then 1
       else if quotf1(u,v) then return v
       else if quotf1(v,u) then return u;
      w := gcdf2(u,v);
      if !*gcd and not(dmode!* memq '(!:rd!: !:cr!:))
          and (null quotf1(u,w) or null quotf1(v,w))
        then if noncomfp u or noncomfp v then return 1
              else errach list("gcdf failed",prepf u,prepf v);
              % This probably implies that integer overflow occurred.
      return w
   end;

symbolic procedure gcdf2(u,v);
   % U and V are both non-trivial forms. Value is their GCD.
   % We need to rebind asymplis!* to avoid setting higher powers to 0.
   begin scalar asymplis!*,w,z;
      if not num!-exponents u or not num!-exponents v then return 1;
      if !*gcd and length(w := kernord(u,v))>1
        then <>
       else w := nil;
      % Things can go wrong with noncom oprs.  However, empirically we
      % only need to make sure that both u and v do not have a leading
      % noncom opr.
      if mvar u eq mvar v
        then begin scalar x,y;
                x := comfac u;
                y := comfac v;
                z := gcdf1(cdr x,cdr y);
                u := quotf1(u,comfac!-to!-poly x);
                v := quotf1(v,comfac!-to!-poly y);
                if !*gcd then z := multf(gcdk(u,v),z)
                 else if v and quotf1(u,v) then z := multf(v,z)
                 else if u and quotf1(v,u) then z := multf(u,z);
                if car x and car y
                  then if pdeg car x>pdeg car y
                         then z := multpf(car y,z)
                        else z := multpf(car x,z)
             end
       else if noncomp mvar u and noncomp mvar v
        then z := gcdfnc(u,v,mvar v)
       else if ordop(mvar u,mvar v) then z := gcdf1(cdr comfac u,v)
       else z := gcdf1(cdr comfac v,u);
      if w then <>;
      return z
   end;

symbolic procedure gcdfnc(x,p,y);
   if domainp x or not noncomp mvar x then gcdf1(x,p)
    else if null red x then gcdfnc(lc x,p,y)
    else gcdf1(gcdfnc(lc x,p,y),gcdfnc(red x,p,y));

symbolic procedure num!-exponents u;
  % check that all exponents are integers (this may not be true in
  % rules).
   domainp u or
   fixp ldeg u and num!-exponents lc u and num!-exponents red u;

symbolic procedure gcdfd(u,v);
   % U is a domain element, V a form.
   % Value is gcd of U and V.
%  if not atom u and flagp(car u,'field) then 1 else gcdfd1(u,v);
   if flagp(dmode!*,'field) then 1 else gcdfd1(u,v);

symbolic procedure gcdfd1(u,v);
   if null v then u
    else if domainp v then gcddd(u,v)
    else gcdfd1(gcdfd1(u,lc v),red v);

symbolic procedure gcddd(u,v);
   %U and V are domain elements.  If they are invertable, value is 1
   %otherwise the gcd of U and V as a domain element;
   if u=1 or v=1 then 1
%   else if atom u and atom v then gcdn(u,v)
    else if atom u then if atom v then gcdn(u,v)
                         else if fieldp v then 1
                         else dcombine(u,v,'gcd)
    else if atom v
     then if flagp(car u,'field) then 1 else dcombine(u,v,'gcd)
    else if flagp(car u,'field) or flagp(car v,'field) then 1
    else dcombine(u,v,'gcd);

symbolic procedure gcdk(u,v);
   % U and V are primitive polynomials in the main variable VAR.
   % Result is gcd of U and V.
   begin scalar lclst,var,w,x;
        if u=v then return u
         else if domainp u or degr(v,(var := mvar u))=0 then return 1
         else if ldeg u>;
        if quotf1(u,v) then return v
         else if !*heugcd and (x := heu!-gcd(u,v)) then return x
%        else if flagp(dmode!*,'field) then return 1
              % otherwise problems arise.
         else if ldeg v=1
           or getd 'modular!-multicheck and modular!-multicheck(u,v,var)
           or not !*mcd
          then return 1;
    a:  w := remk(u,v);
        if null w then return v
         else if degr(w,var)=0 then return 1;
        lclst := addlc(v,lclst);
        if x := quotf1(w,lc w) then w := x
         else for each y in lclst do
              % prevent endless loop in !:gi!: or field modes.
            if atom y and not flagp(dmode!*,'field)
              or not
               (domainp y and (flagp(dmode!*,'field)
                  or ((x := get(car y,'units))
                       and y member (for each z in x collect car z))))
            then while (x := quotf1(w,y)) do w := x;
        u := v; v := prim!-part w;
        if degr(v,var)=0 then return 1 else go to a
   end;

symbolic procedure addlc(u,v);
   if u=1 then v
    else (lambda x;
      if x=1 or x=-1 or not atom x and flagp(car x,'field) then v
       else x . v)
     lc u;

symbolic procedure delallasc(u,v);
   if null v then nil
    else if u eq caar v then delallasc(u,cdr v)
    else car v . delallasc(u,cdr v);

symbolic procedure kernord(u,v);
   <>;

symbolic procedure kernord!-split(u,v);
   % splits U and V into a set of powers of those kernels occurring in
   % one form and not the other, and those occurring in both;
   begin scalar x,y;
      u := powers u;
      v := powers v;
      for each j in u do
          if assoc(car j,v) then y := j . y else x := j . x;
      for each j in v do
          if assoc(car j,u) then y := j . y else x := j . x;
      return reversip x . reversip y
   end;

symbolic procedure kernord!-sort u;
   % returns list of kernels ordered so that kernel with lowest maximum
   % power in U (a list of powers) is first, and so on;
   begin scalar x,y;
      while u do
       <>;
      return y
   end;

symbolic procedure maxdeg(u,v);
   if null u then v
    else if cdar u>cdr v then maxdeg(cdr u,car u)
    else maxdeg(cdr u,v);

symbolic procedure powers form;
   % returns a list of the maximum powers of each kernel in FORM.
   % order tends to be opposite to original order.
   powers0(form,nil);

symbolic procedure powers0(form,powlst);
   if null form or domainp form then powlst
    else begin scalar x;
        if (x := atsoc(mvar form,powlst))
%         then ldeg form>cdr x and rplacd(x,ldeg form)
          then (if ldeg form>cdr x
                  then powlst := repasc(mvar form,ldeg form,powlst))
         else powlst := (mvar form . ldeg form) . powlst;
        return powers0(red form,powers0(lc form,powlst))
     end;

put('lcm,'polyfn,'lcm!*);

put('lcm,'number!-of!-args,2);

symbolic procedure lcm!*(u,v);
   begin scalar !*gcd; !*gcd := t; return lcm(u,v) end;

symbolic procedure lcm(u,v);
   %U and V are standard forms. Value is lcm of U and V;
   if null u or null v then nil
    else if u=1 then v     % ONEP
    else if v=1 then u     % ONEP
    else multf(u,quotf(v,gcdf(u,v)));

symbolic procedure remk(u,v);
   %modified pseudo-remainder algorithm
   %U and V are polynomials, value is modified prem of U and V;
   begin scalar f1,var,x; integer k,n;
        f1 := lc v;
        var := mvar v;
        n := ldeg v;
        while (k := degr(u,var)-n)>=0 do
         <0 then x := multpf(var .** k,x);
           u := addf(multf(f1,red u),x)>>;
        return u
   end;

symbolic procedure prim!-part u;
   %returns the primitive part of the polynomial U wrt leading var;
   quotf1(u,comfac!-to!-poly comfac u);

symbolic procedure comfac!-to!-poly u;
   if null car u then cdr u else list u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/polydiv.tst0000644000175000017500000000505111526203062023712 0ustar  giovannigiovanni% polydiv.tst  -*- REDUCE -*-

% Test and demonstration file for enhanced polynomial division
% file polydiv.red.

% F.J.Wright@Maths.QMW.ac.uk, 7 Nov 1995.

% The example from "Computer Algebra" by Davenport, Siret & Tournier,
% first edition, section 2.3.3.

% First check that remainder still works as before.

% Compute the gcd of the polynomials a and b by Euclid's algorithm:
a := aa := x^8 + x^6 - 3x^4 - 3x^3 + 8x^2 + 2x - 5;
b := bb := 3x^6 + 5x^4 - 4x^2 - 9x + 21;
on rational;  off allfac;
c := remainder(a, b);  a := b$  b := c$
c := remainder(a, b);  a := b$  b := c$
c := remainder(a, b);  a := b$  b := c$
c := remainder(a, b);  a := b$  b := c$
c := remainder(a, b);
off rational;

% Repeat using pseudo-remainders, to avoid rational arithmetic:
a := aa;
b := bb;
c := pseudo_remainder(a, b);  a := b$  b := c$
c := pseudo_remainder(a, b);  a := b$  b := c$
c := pseudo_remainder(a, b);  a := b$  b := c$
c := pseudo_remainder(a, b);  a := b$  b := c$
c := pseudo_remainder(a, b);


% Example from Chris Herssens 
% involving algebraic numbers in the coefficient ring
% (for which naive pseudo-division fails in REDUCE):
factor x;
a:=8*(15*sqrt(2)*x**3 + 18*sqrt(2)*x**2 + 10*sqrt(2)*x + 12*sqrt(2) -
   5*x**4 - 6*x**3 - 30*x**2 - 36*x);
b:= - 16320*sqrt(2)*x**3 - 45801*sqrt(2)*x**2 - 50670*sqrt(2)*x -
   26534*sqrt(2) + 15892*x**3 + 70920*x**2 + 86352*x + 24780;

pseudo_remainder(a, b, x);
% Note: We must specify the division variable even though the
% polynomials are apparently univariate:
pseudo_remainder(a, b);

% Confirm that quotient * b + remainder = constant * a:
pseudo_divide(a, b, x);
first ws * b + second ws;
ws / a;                                 % is this constant?
on rationalize;
ws;                                     % yes, it is constant
off rationalize;

on allfac;  remfac x;

procedure test_pseudo_division(a, b, x);
   begin scalar qr, L;
      qr := pseudo_divide(a, b, x);
      L := lcof(b,x);
      %% For versions of REDUCE prior to 3.6 use:
      %% L := if b freeof x then b else lcof(b,x);
      if first qr * b + second qr =
         L^(deg(a,x)-deg(b,x)+1) * a then
         write "Pseudo-division OK"
      else
         write "Pseudo-division failed"
   end;

a := 5x^4 + 4x^3 + 3x^2 + 2x + 1;
test_pseudo_division(a, x, x);
test_pseudo_division(a, x^3, x);
test_pseudo_division(a, x^5, x);
test_pseudo_division(a, x^3 + x, x);
test_pseudo_division(a, 0, x);          % intentional error!
test_pseudo_division(a, 1, x);

test_pseudo_division(5x^3 + 7y^2, 2x - y, x);
test_pseudo_division(5x^3 + 7y^2, 2x - y, y);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/polrep.red0000644000175000017500000006647011526203062023501 0ustar  giovannigiovannimodule polrep; % Arithmetic operations on standard forms and quotients.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*asymp!* !*exp !*factor !*gcd !*lcm !*mcd !*rationalize frlis!*
        !*roundall !*rounded !*sqfree !*sub2 asymplis!* dmode!* subfg!*
        ncmp!* powlis!* wtl!* !*!*processed !*ncmp);

global '(!*group rd!-tolerance!* cr!-tolerance!*);

put('roundall,'simpfg,'((t (rmsubs))));

switch roundall;

!*roundall := t;   % Default is on.

symbolic smacro procedure subtrsq(u,v); addsq(u,negsq v);

symbolic procedure addsq(u,v);
   % U and V are standard quotients.
   % Value is canonical sum of U and V.
   if null numr u then v
    else if null numr v then u
    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
    else begin scalar x,y,z;
        if null !*exp then <>;
        if !*lcm then x := gcdf!*(denr u,denr v)
         else x := gcdf(denr u,denr v);
        z := canonsq(quotf(denr u,x) ./ quotf(denr v,x));
        y := addf(multf(denr z,numr u),multf(numr z,numr v));
        if null y then return nil ./ 1;
        z := multf(denr u,denr z);
        return if x=1 or (x := gcdf(y,x))=1 then y ./ z
                else canonsq(quotf(y,x) ./ quotf(z,x))
    end;

symbolic procedure multsq(u,v);
   % U and V are standard quotients.
   % Value is canonical product of U and V.
   if null numr u or null numr v then nil ./ 1
    else if denr u=1 and denr v=1 then multf(numr u,numr v) ./ 1
    else begin scalar x,y,z;
        x := gcdf(numr u,denr v);
        y := gcdf(numr v,denr u);
        z := multf(quotf(numr u,x),quotf(numr v,y));
        x := multf(quotf(denr u,y),quotf(denr v,x));
        return canonsq(z ./ x)
    end;

symbolic procedure negsq u; negf numr u ./ denr u;

smacro procedure multpq(u,v);
   multsq(!*p2q u,v);

symbolic procedure cancel u;
   %returns canonical form of non-canonical standard form U;
   if !*mcd or denr u=1 then multsq(numr u ./ 1,1 ./ denr u)
    else multsq(numr u ./ 1,simpexpt list(mk!*sq(denr u ./ 1),-1));


% ***** FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD FORMS *****

symbolic smacro procedure peq(u,v);
   %tests for equality of powers U and V;
   u = v;

symbolic procedure addf(u,v);
   % U and V are standard forms. Value is standard form for U+V.
   if null u then v
    else if null v then u
    else if domainp u then addd(u,v)
    else if domainp v then addd(v,u)
    else if peq(lpow u,lpow v)
       then (if null x then y else lpow u .* x .+ y)
             where x=addf(lc u,lc v),y=addf(red u,red v)
    else if ordpp(lpow u,lpow v) then lt u .+ addf(red u,v)
    else lt v .+ addf(u,red v);

symbolic procedure addd(u,v);
   % U is a domain element, V a standard form.
   % Value is a standard form for U+V.
   if null v then u
    else if domainp v then adddm(u,v)
    else lt v .+ addd(u,red v);

symbolic procedure adddm(u,v);
   % U and V are both non-zero domain elements.
   % Value is standard form for U+V.
   % The int-equiv-chk is needed to convert say (:MOD: . 0) to NIL.
   % A simpler function might therefore be possible and more efficient.
   if atom u and atom v
     then (if null dmode!* or not flagp(dmode!*,'convert) then !*n2f x
            else int!-equiv!-chk apply1(get(dmode!*,'i2d),x))
          where x=plus2(u,v)
    else dcombine(u,v,'plus);

symbolic procedure domainp u; atom u or atom car u;

symbolic procedure noncomp u;
   !*ncmp and noncomp1 u;

symbolic procedure noncomp1 u;
  if null pairp u then nil
   else if pairp car u then noncomfp u
   else if car u eq 'taylor!* then nil
   else flagp(car u,'noncom) or noncomlistp cdr u;

symbolic procedure noncomlistp u;
   pairp u and (noncomp1 car u or noncomlistp cdr u);

symbolic procedure multf(u,v);
   % U and V are standard forms.
   % Value is standard form for U*V.
   begin scalar x,y;
    a:  if null u or null v then return nil
         else if u=1 then return v     % ONEP
         else if v=1 then return u     % ONEP
         else if domainp u then return multd(u,v)
         else if domainp v then return multd(v,u)
         else if not(!*exp or ncmp!* or wtl!* or x)
          then <>;
        x := mvar u;
        y := mvar v;
        if noncomfp v and (noncomp x or null !*!*processed)
          then return multfnc(u,v)
         else if x eq y
          then <<% Allow for free variables in rules.
                 if not fixp ldeg u or not fixp ldeg v
                   then x := x .** reval list('plus,ldeg u,ldeg v)
                  else x := mkspm(x,ldeg u+ldeg v);
                 % The order in the next line is IMPORTANT. See analysis
                 % by J.H. Davenport et al. for details.
                 y := addf(multf(red u,v),multf(!*t2f lt u,red v));
                 return if null x or null(u := multf(lc u,lc v))
                    then <>
                   else if x=1 then addf(u,y)
                   else if null !*mcd then addf(!*t2f(x .* u),y)
                   else x .* u .+ y>>
         else if ordop(x,y)
          then <>;
        x := multf(u,lc v);
        y := multf(u,red v);
        return if null x then y else lpow v .* x .+ y
   end;

symbolic procedure noncomfp u;
   % It's possible that ncmp!* would work here.
   !*ncmp and noncomfp1 u;

symbolic procedure noncomfp1 u;
   not domainp u
      and (noncomp mvar u or noncomfp1 lc u or noncomfp1 red u);

symbolic procedure multfnc(u,v);
   % Returns canonical product of U and V, with both main vars non-
   % commutative.
   begin scalar x,y;
      x := multf(lc u,!*t2f lt v);
      if null x then nil
       else if not domainp x and mvar x eq mvar u
        then x := addf(if null (y := mkspm(mvar u,ldeg u+ldeg x))
                         then nil
                        else if y = 1 then lc x
                        else !*t2f(y .* lc x),
                       multf(!*p2f lpow u,red x))
       else if noncomp mvar u then x := !*t2f(lpow u .* x)
       else x := multf(!*p2f lpow u,x) where !*!*processed=t;
      return addf(x,addf(multf(red u,v),multf(!*t2f lt u,red v)))
   end;

symbolic procedure multd(u,v);
   % U is a domain element, V a standard form.
   % Value is standard form for U*V.
   if null v then nil
    else if v=1 then u      % Common enough to be tested.
    else if domainp v then multdm(u,v)
    else lpow v .* multd(u,lc v) .+ multd(u,red v);

symbolic procedure multdm(u,v);
   % U and V are both non-zero domain elements.
   % Value is standard form for U*V;
   if atom u and atom v
     then (lambda x; if null dmode!*
                        or not flagp(dmode!*,'convert) then x
                      else % int!-equiv!-chk
                              apply1(get(dmode!*,'i2d),x))
           times2(u,v)
    else dcombine(u,v,'times);

smacro procedure multpf(u,v); multf(!*p2f u,v);

symbolic procedure negf u;
   if null u then nil
    else if domainp u
           then !:minus if atom u and flagp(dmode!*,'convert)
                          then apply1(get(dmode!*,'i2d),u)
                         else u
    else lpow u .* negf lc u .+ negf red u;

symbolic procedure degreef(pol,var);
   % Find degree of kernel in standard form pol.
   % Note: uniqueness of kernel assumed.
   if domainp pol then 0
    else if mvar pol eq var then ldeg pol
    else max(degreef(lc pol,var),degreef(red pol,var));

put('!*sq,'lengthfn,'!*sqlength);

symbolic procedure !*sqlength u;
   (if denr car u=1 then x else x+termsf denr car u)
    where x = termsf numr car u;

symbolic procedure terms u;
   <>;

flag('(terms),'opfn);

flag('(terms),'noval);

symbolic procedure termsf u;
   % U is a standard form.
   % Value is number of terms in U (excluding kernel structure).
   begin integer n;
      while not domainp u do <>;
      return if null u then n else n+1
   end;

symbolic procedure tmsf u;
   % U is a standard form.
   % Value is number of terms in U (including kernel structure).
   begin integer n; scalar x;
    % Integer declaration initializes N to 0.
      while not domainp u do
       <>;   % Previously, if U was non-zero, we used to add
                         % one more here.
      return if null u then n else n+1
   end;

symbolic procedure tmsf!* u;
   if numberp u and abs fix u=1 then 0 else tmsf u; % Was tmsf u+1.

symbolic procedure tms u; tmsf numr simp!* u;

flag('(tms),'opfn);

flag('(tms),'noval);


% ***** FUNCTIONS FOR WORKING WITH STRUCTURED FORMS *****

fluid '(!*really_off_exp);

symbolic procedure offexpchk u;
   % Return structured form for standard quotient u.
   % The freevar check is required to correctly evaluate rules like
   % for all n let f(a^n-b^n)=c when exp is off and gcd on.
   if !*really_off_exp or
        (frlis!* and freevarinexptchk numr u or freevarinexptchk denr u)
     then u
    else canprod(mkprod numr u,mkprod denr u);

symbolic procedure freevarinexptchk u;
   not domainp u and(not numberp ldeg u or freevarinexptchk lc u
                                   or freevarinexptchk red u);

symbolic procedure mkprod u;
   begin scalar w,x,y,z,!*exp,!*sub2;
      if null u or kernlp u then return u;
      % First make sure there are no further simplifications.
      !*sub2 := t;
      x := subs2(u ./ 1);
      if denr x neq 1 then return u  % We can't do much more here.
       else if numr x neq u
        then <>;
      !*exp := t;
      w := ckrn u;
      u := quotf(u,w);
      x := expnd u;
      if null x or kernlp x then return multf(w,x);
      % After this point, X is not KERNLP.
      % The check below for *MCD was suggested by James Davenport.
      % Without it, on gcd; off mcd,exp; (x**2+2x+1)/x+1; loops
      % forever.
      if !*mcd and (!*sqfree or !*factor or !*gcd)
        then y := fctrf x
       else <>;
      if cdadr y>1 or cddr y
        then <>
       else if not !*group and tmsf u>tmsf caadr y
        then z := multf(mksp!*(caadr y,cdadr y),car y)
       else z := mksp!*(u,1);
      return multf(w,z)
   end;

symbolic procedure expnd u;
  if !*really_off_exp then u else
   begin scalar !*sub2,v;
      u := expnd1 u;
      return if !*sub2 and denr(v := subs2f u) = 1 then numr v
              else u
   end;

symbolic procedure expnd1 u;
   if domainp u then u
    else addf(if not sfp mvar u or ldeg u<0
                then multpf(lpow u,expnd1 lc u)
        else multf(exptf(expnd1 mvar u,ldeg u),expnd1 lc u),
                        expnd1 red u);

symbolic procedure canprod(p,q);
   % P and Q are kernel product standard forms, value is P/Q in
   % which a  top level standard form kernel by itself has been
   % unwound.
   begin scalar v,w,x,y,z;
      if domainp q or red q or (not domainp p and red p)
        then return cancel(p ./ q);
      % Look for possible cancellations.
      while not domainp p or not domainp q do
      if sfpf p then <>
       else if sfpf q then <>
       else if domainp p then <>
       else if domainp q then <>
       else <>;
      v := reprod(v,reprod(x,p));
      w := reprod(w,reprod(y,q));
      if minusf w then <>;
      w := cancel(v ./ w);
      % Final check for unnecessary structure.
      v := numr w;
      if not domainp v and null red v and lc v=1
         and ldeg v=1 and sfp(x := mvar v)
        then v := x;
      w := denr w;
      if not domainp w and null red w and lc w=1
         and ldeg w=1 and sfp(x := mvar w)
        then w := x;
      return canonsq(v ./ w)
   end;

symbolic procedure sfpf u;
   not domainp u and sfp mvar u;

symbolic procedure sfp u;
   % True if mvar U is a standard form.
   not atom u and not atom car u;

symbolic procedure reprod(u,v);
   % U is a list of powers, V a standard form.
   % Value is product of terms in U with V.
   <>; v>>;

symbolic procedure cprod1(p,m,v,w);
   % U is a standard form, which occurs in a kernel raised to power M.
   % V is a list of powers multiplying P**M, W a list dividing it.
   % Value is a dotted pair of lists of powers after all possible
   % kernels have been cancelled.
   begin scalar z;
      z := cprod2(p,m,w,nil);
      w := cadr z;
      v := append(cddr z,v);
      z := cprod2(car z,m,v,t);
      v := cadr z;
      w := append(cddr z,w);
      if car z neq 1 then v := mksp(car z,m) . v;
      return v . w
   end;

symbolic procedure cprod2(p,m,u,b);
   %P and M are as in CPROD1. U is a list of powers. B is true if P**M
   %multiplies U, false if it divides.
   %Value has three parts: the first is the part of P which does not
   %have any common factors with U, the second a list of powers (plus
   %U) which multiply U, and the third a list of powers which divide U;
   %it is implicit here that the kernel standard forms are positive;
   begin scalar n,v,w,y,z;
      while u and p neq 1 do
        <0 then w := mksp(z,n) . w
              else if n<0 then v := mksp(z,-n) . v>>
            else v := car u . v;
           u := cdr u>>;
      return (p . nconc!*(u,v) . w)
   end;

symbolic procedure mkspm(u,p);
   %U is a unique kernel, P an integer;
   %value is 1 if P=0, NIL if U**P is 0, else standard power of U**P;
   % should we add a check for NOT(U EQ K!*) in first line?
   if p=0 then 1
    else begin scalar x;
        if subfg!* and (x:= atsoc(u,asymplis!*)) and cdr x<=p
          then return nil;
        sub2chk u;
        return u .** p
   end;

symbolic procedure sub2chk u;
   %determines if kernel U is such that a power substitution is
   %necessary;
   if subfg!*
      and(atsoc(u,powlis!*) or not atom u and car u memq '(expt sqrt))
     then !*sub2 := t;


% ***** FUNCTIONS FOR DIVIDING STANDARD FORMS *****

symbolic procedure quotsq(u,v);
   multsq(u,invsq v);

symbolic procedure quotf!*(u,v);
   % We do the rationalizesq step to allow for surd divisors.
   if null u then nil
    else (if x then x
           else (if denr y = 1 then numr y
                  else errach list("DIVISION FAILED",u,v))
                 where y=rationalizesq(u ./ v))
          where x=quotf(u,v);

symbolic procedure quotf(u,v);
%  begin scalar xexp;
%       xexp := !*exp;
%       !*exp := t;
%       u := quotf1(u,v);
%       !*exp := xexp;
%       return u
%  end;
   quotf1(u,v) where !*exp = t;

symbolic procedure quotf1(p,q);
   % P and Q are standard forms.
   % Value is the quotient of P and Q if it exists or NIL.
   if null p then nil
    else if p=q then 1
    else if q=1 then p
    else if domainp q then quotfd(p,q)
    else if domainp p then nil
    else if mvar p eq mvar q
     then begin scalar u,v,w,x,xx,y,z,z1; integer n;
    a:if idp(u := rank p) or idp(v := rank q) or u>;

symbolic procedure rnconc(u,v);
   if null u then v
    else if !*ncmp and noncomfp1 u and noncomfp1 v then addf(u,v)
    else begin scalar w;
   % This is like nconc, but doesn't assume its second argument is a
   % list.
            w := u;
            while cdr w do <>;
            rplacd(w,v);
            return u
         end;

symbolic procedure quotfd(p,q);
   % P is a standard form, Q a domain element.
   % Value is P/Q if exact division is possible, or NIL otherwise.
   if p=q then 1
   else if flagp(dmode!*,'field) then divd(p,q)
   else if domainp p then quotdd(p,q)
   else quotk(p,q);

symbolic procedure divd(v,u);
   % U is a domain element, V a standard form.
   % Value is standard form for V/U.
   if null u
     then if null v then rerror(poly,1,"0/0 formed")
           else rerror(poly,2,"Zero divisor")
    else if null v then nil
    else if domainp v then divdm(v,u)
    else lpow v .* divd(lc v,u) .+ divd(red v,u);

symbolic procedure divdm(v,u);
   % U and V are both non-zero domain elements.
   % Value is standard form for V/U.
   if atom v and atom u
     then if remainder(v,u)=0 then v/u
           else !:rn2rd mkrn(v,u)
    else y % (if null dmode!* then y else int!-equiv!-chk y)
          where y=dcombine(v,u,'quotient);

symbolic procedure quotdd(u,v);
   % U and V are domain elements.  Value is U/V if division is exact,
   % NIL otherwise.
   begin scalar w;
      if atom u then
        if atom v then
          <>
          else if (w := get(car v,'i2d)) then u := apply1(w,u)
      else if atom v and (w := get(car u,'i2d)) then v := apply1(w,v);
      return dcombine(u,v,'quotient)
   end;

symbolic procedure quotk(p,q);
   (lambda w;
      if w then if null red p then list (lpow p .* w)
                 else (lambda y;if y then lpow p .* w .+ y else nil)
                          quotf1(red p,q)
         else nil)
      quotf1(lc p,q);

symbolic procedure rank p;
   %P is a standard form
   %Value is the rank of P;
   if !*mcd then ldeg p
    else begin integer m,n; scalar y;
        n := ldeg p;
        y := mvar p;
    a:  m := ldeg p;
        if null red p then return n-m;
        p := red p;
        if degr(p,y)=0 then return if m<0 then if n<0 then -m
                else n-m else n;
        go to a
    end;

symbolic procedure lt!* p;
   %Returns true leading term of polynomial P;
   if !*mcd or ldeg p>0 then car p
    else begin scalar x,y;
        x := lt p;
        y := mvar p;
    a:  p := red p;
        if null p then return x
         else if degr(p,y)=0 then return (y . 0) .* p;
        go to a
   end;

symbolic procedure remf(u,v);
   %returns the remainder of U divided by V;
   if null v then rerror(poly,201,"Zero divisor") else cdr qremf(u,v);

put('remainder,'polyfn,'remf);

symbolic procedure qremf(u,v);
   % Returns the quotient and remainder of U divided by V.
   % Exp cannot be off, otherwise a loop can occur. e.g.,
   % qremf('(((x . 1) . -1) . 1),'(((x . 2)  . -3) . 4)).
   begin integer n; scalar !*exp,x,y,z;
        !*exp := t;
        if domainp v then return qremd(u,v);
        z := list nil;   % Final value.
    a:  if domainp u then return praddf(z,nil . u)
         else if mvar u eq mvar v
          then if (n := ldeg u-ldeg v)<0 then return praddf(z,nil . u)
                else <>
         else if not ordop(mvar u,mvar v)
          then return praddf(z,nil . u);
        x := qremf(lc u,v);
        z := praddf(z,multpf(lpow u,car x) . multpf(lpow u,cdr x));
        u := red u;
        go to a
   end;

symbolic procedure praddf(u,v);
   % U and V are dotted pairs of standard forms.
   addf(car u,car v) . addf(cdr u,cdr v);

symbolic procedure qremd(u,v);
   % Returns a dotted pair of quotient and remainder of form U
   % divided by domain element V.
   if null u then u . u
    else if v=1 then list u
    else if flagp(dmode!*,'field) then list multd(!:recip v,u)
    else if domainp u then !:divide(u,v)
    else begin scalar x;
        x := qremf(lc u,v);
        return praddf(multpf(lpow u,car x) . multpf(lpow u,cdr x),
                        qremd(red u,v))
   end;

symbolic procedure lqremf(u,v);
   %returns a list of coeffs of powers of V in U, constant term first;
   begin scalar x,y;
      y := list u;
      while car(x := qremf(car y,v)) do y := car x . cdr x . cdr y;
      return reversip!* y
   end;

symbolic procedure minusf u;
   %U is a non-zero standard form.
   %Value is T if U has a negative leading numerical coeff,
   %NIL otherwise;
   if null u then nil
    else if domainp u
           then if atom u then u<0 else apply1(get(car u,'minusp),u)
    else minusf lc u;

symbolic procedure absf!* u;
   % Returns representation for absolute value of standard form U.
   (if domainp u then x else !*p2f mksp(list('abs,prepf x),1))
    where x = absf u;

symbolic procedure absf u;
   if minusf u then negf u else u;

symbolic procedure canonsq u;
   % U is a standard quotient.  Value is a standard quotient in which
   % the leading power of the denominator has a positive numerical
   % coefficient and the denominator is normalized where possible.
   if denr u=1 then u
    else if null numr u then nil ./ 1
    else begin scalar x,y;
       % This example shows the following gcd check is needed:
       % a:=1+x/2; let x**2=0; a*a;
       % Should only be needed when an asymptotic reduction occurs.
       if asymplis!* and ((x := gcdf(numr u,denr u)) neq 1)
         then u := quotf(numr u,x) ./ quotf(denr u,x);
       % Now adjust for a positive leading numerical coeff in denr.
        x := lnc denr u;
        if x=1 then return u
         else if atom x then if minusp x
                               then <>
                              else nil
         else if apply1(get(car x,'minusp),x)
                               then <>;
        % Now check for a global field mode, a leading domain coeff
        % with field properties or "unit" properties so we can adjust
        % numr and denr.  The tests are done in the following order
        % since the other order will give wrong results with some
        % polynomials with decimal coefficients in dmode :gi:.
      return if not numberp x and (y := get(dmode!*,'unitsfn))
            then apply2(y,u,x)
         else if flagp(dmode!*,'field)
            or not atom x and flagp(car x,'field) then fieldconv(x,u)
         else u
   end;

symbolic procedure fieldconv(x,u);
   % U is a standard quotient and x the leading numerical coefficient
   % of the denominator.  Returns inverse(x)*numr u/denr u.
   % X is a domain, but d may not be; dmode!* or x is field.
   begin scalar n,d,y; n := numr u; d := denr u;
      if null dmode!* then
         <>
                   else errach list("field conversion",x);
           x := (car x) . (cddr x) . cadr x;
           return simpgd if domainp d then multd(x,n) ./ 1
                          else multd(x,n) ./ multd(x,d)>>;
      return if domainp d then divd(n,d) ./ 1
              else divd(n,x) ./ divd(d,x)
   end;

symbolic procedure simpgd u;
   if null flagp(dmode!*,'field) then u
   else begin scalar x;
           if (x := gcdf(numr u,denr u)) neq 1
             then u := quotf(numr u,x) ./ quotf(denr u,x);
           return u
        end;

symbolic procedure lnc u;
   % U is a standard form.  Value is the leading numerical coefficient.
   if null u then 0
    else if domainp u then u
    else lnc lc u;

symbolic procedure invsq u;
   begin
      if null numr u then rerror(poly,3,"Zero divisor");
      u := revpr u;
      if !*rationalize then u := gcdchk u;
      % Since result may not be in lowest terms.
      return canonsq u
   end;

symbolic procedure gcdchk u;
   % Makes sure standard quotient u is in lowest terms.
   (if x neq 1 then quotf(numr u,x) ./ quotf(denr u,x) else u)
   where x = gcdf(numr u,denr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/polydiv.tex0000644000175000017500000001522211526203062023701 0ustar  giovannigiovanni\documentclass[11pt]{article}

\title{POLYDIV: Enhanced Polynomial Division}

\author{Francis J. Wright \\
School of Mathematical Sciences \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road, London E1 4NS, UK. \\
Email: {\tt F.J.Wright@QMW.ac.uk}}

\date{6 November 1995}

\begin{document}
\maketitle

\begin{abstract}
  This package provides better access to the standard internal
  polynomial division facilities of REDUCE and implements polynomial
  pseudo-division.  It provides optional local control over the main
  variable used for division.
\end{abstract}


\section{Introduction}

The \texttt{polydiv} package provides several enhancements to the
standard REDUCE algebraic-mode facilities for Euclidean division of
polynomials.  The source file (\texttt{polydiv.red}) should be
compiled (using \texttt{faslout}) and loaded when required by
\begin{verbatim}
load_package polydiv;
\end{verbatim}
The numerical coefficient domain is always that specified globally.
Further examples are provided in the test and demonstration file
\texttt{polydiv.tst}.


\section{Polynomial Division}

The \texttt{polydiv} package provides the infix operators \texttt{div}
and \texttt{mod} (as used in Pascal) for the Euclidean quotient and
remainder, e.g.
\begin{verbatim}
(x^2 + y^2) div (x - y);

        x + y

(x^2 + y^2) mod (x - y);

           2
        2*y
\end{verbatim}
(They can also be used as prefix operators.)

It provides a Euclidean division operator \texttt{divide} that returns
both the quotient and the remainder together as the first and second
elements of a list, e.g.
\begin{verbatim}
divide(x^2 + y^2, x - y);

                  2
        {x + y,2*y }
\end{verbatim}
(It can also be used as an infix operator.)

All Euclidean division operators (when used in prefix form, and
including the standard \texttt{remainder} operator) accept an optional
third argument, which specifies the main variable to be used during
the division.  The default is the leading kernel in the current global
ordering.  Specifying the main variable does not change the ordering
of any other variables involved, nor does it change the global
environment.  For example
\begin{verbatim}
div(x^2 + y^2, x - y, y);

         - (x + y)

remainder(x^2 + y^2, x - y, y);

           2
        2*x

divide(x^2 + y^2, x - y, y);

                       2
        { - (x + y),2*x }
\end{verbatim}

Specifying $x$ as main variable gives the same behaviour as the
default shown earlier, i.e.
\begin{verbatim}
divide(x^2 + y^2, x - y, x);

                  2
        {x + y,2*y }

remainder(x^2 + y^2, x - y, x);

           2
        2*y
\end{verbatim}


\section{Polynomial Pseudo-Division}

The polynomial division discussed above is normally most useful for a
univariate polynomial over a field, otherwise the division is likely
to fail giving trivially a zero quotient and a remainder equal to the
dividend.  (A ring of univariate polynomials is a Euclidean domain
only if the coefficient ring is a field.)  For example, over the
integers:
\begin{verbatim}
divide(x^2 + y^2, 2(x - y));

            2    2
        {0,x  + y }
\end{verbatim}

The division of a polynomial $u(x)$ of degree $m$ by a polynomial
$v(x)$ of degree $n \le m$ can be performed over any commutative ring
with identity (such as the integers, or any polynomial ring) if the
polynomial $u(x)$ is first multiplied by $\mathrm{lc}(v,x)^{m-n+1}$
(where lc denotes the leading coefficient).  This is called
\emph{pseudo-division}.  The \texttt{polydiv} package implements the
polynomial pseudo-division operators \texttt{pseudo\_divide},
\texttt{pseudo\_quotient} (or \texttt{pseudo\_div}) and
\texttt{pseudo\_remainder} as prefix operators (only).  When
multivariate polynomials are pseudo-divided it is important which
variable is taken as the main variable, because the leading
coefficient of the divisor is computed with respect to this variable.
Therefore, if this is allowed to default and there is any ambiguity,
i.e.\ the polynomials are multivariate or contain more than one
kernel, the pseudo-division operators output a warning message to
indicate which kernel has been selected as the main variable -- it is
the first kernel found in the internal forms of the dividend and
divisor.  (As usual, the warning can be turned off by making the
switch setting ``\texttt{off msg;}''.)  For example
\begin{verbatim}
pseudo_divide(x^2 + y^2, x - y);

        *** Main division variable selected is x 

                  2
        {x + y,2*y }

pseudo_divide(x^2 + y^2, x - y, x);

                  2
        {x + y,2*y }

pseudo_divide(x^2 + y^2, x - y, y);

                       2
        { - (x + y),2*x }
\end{verbatim}

If the leading coefficient of the divisor is a unit (invertible
element) of the coefficient ring then division and pseudo-division
should be identical, otherwise they are not, e.g.
\begin{verbatim}
divide(x^2 + y^2, 2(x - y));

            2    2
        {0,x  + y }

pseudo_divide(x^2 + y^2, 2(x - y));

        *** Main division variable selected is x

                      2
        {2*(x + y),8*y }
\end{verbatim}

The pseudo-division gives essentially the same result as would
division over the field of fractions of the coefficient ring (apart
from the overall factors [contents] of the quotient and remainder),
e.g.
\begin{verbatim}
on rational;

divide(x^2 + y^2, 2(x - y));

          1             2
        {---*(x + y),2*y }
          2

pseudo_divide(x^2 + y^2, 2(x - y));

        *** Main division variable selected is x

                      2
        {2*(x + y),8*y }
\end{verbatim}

Polynomial division and pseudo-division can only be applied to what
REDUCE regards as polynomials, i.e.\ rational expressions with
denominator 1, e.g.
\begin{verbatim}
off rational;

pseudo_divide((x^2 + y^2)/2, x - y);

                2    2
               x  + y
        ***** --------- invalid as polynomial
                  2
\end{verbatim}

Pseudo-division is implemented in the \texttt{polydiv} package using
an algorithm (D. E. Knuth 1981, \textit{Seminumerical Algorithms},
Algorithm R, page 407) that does not perform any actual division at
all (which proves that it applies over a ring).  It is more efficient
than the naive algorithm, and it also has the advantage that it works
over coefficient domains in which REDUCE may not be able to perform in
practice divisions that are possible mathematically.  An example of
this is coefficient domains involving algebraic numbers, such as the
integers extended by $\sqrt{2}$, as illustrated in the file
\texttt{polydiv.tst}.

The implementation attempts to be reasonably efficient, except that it
always computes the quotient internally even when only the remainder
is required (as does the standard remainder operator).

\end{document}mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/kernel.red0000644000175000017500000000561211526203062023447 0ustar  giovannigiovannimodule kernel;   % Functions for operations on kernels.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(exlist!* kprops!*);

symbolic procedure fkern u;
   % Finds the unique "p-list" reference to the kernel U.  The choice of
   % the search and merge used here has a strong influence on some
   % timings.  The ordered list used here is also used by prepsq* to
   % order factors in printed output, so cannot be unilaterally changed.
   begin scalar x,y;
        if atom u then return list(u,nil)
         else if x := get(car u,'fkernfn) then return apply1(x,u);
        y := if atom car u then get(car u,'klist) else exlist!*;
        if not (x := assoc(u,y))
          then <>
                  else exlist!* := y>>;
        return x
   end;

symbolic procedure kernels u;
   % Returns list of kernels in standard form u.
   kernels1(u,nil);

symbolic procedure kernels1(u,v);
   % We append to end of list to put kernels in the right order, even
   % though a cons on the front of the list would be faster.
   if domainp u then v
    else kernels1(lc u,
                  kernels1(red u,
                           if x memq v then v else append(v,list x)))
         where x=mvar u;

symbolic procedure kernp u;
   % True if U is standard quotient representation for a kernel.
   denr u=1 and not domainp(u := numr u)
        and null red u and lc u=1 and ldeg u=1;     % onep

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/reord.red0000644000175000017500000000712211526203062023300 0ustar  giovannigiovannimodule reord; % Functions for reordering standard forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(alglist!* kord!* ncmp!*);

alglist!* := nil . nil;         % This is first module that uses this.

symbolic procedure reordsq u;
   % Reorders a standard quotient so that current kernel order is used.
   reorder numr u ./ reorder denr u;

symbolic procedure reorder u;
   % Reorders a standard form so that current kernel order is used.
   % Note: this version does not reorder any sfs used as kernels.
   if domainp u then u
    else raddf(rmultpf(lpow u,reorder lc u),reorder red u);

symbolic procedure raddf(u,v);
   % Adds reordered forms U and V.
   if null u then v
    else if null v then u
    else if domainp u then addd(u,v)
    else if domainp v then addd(v,u)
    else if peq(lpow u,lpow v)
     then (lpow u .* raddf(lc u,lc v)) .+ raddf(red u,red v)
    else if ordpp(lpow u,lpow v) then lt u . raddf(red u,v)
    else lt v . raddf(u,red v);

symbolic procedure rmultpf(u,v);
  % Multiplies power U by reordered form V.
   if null v then nil
    else if domainp v or reordop(car u,mvar v) then !*t2f(u .* v)
    else (lpow v .* rmultpf(u,lc v)) .+ rmultpf(u,red v);

symbolic procedure reordop(u,v);
   (!*ncmp and noncomp1 u and noncomp1 v) or ordop(u,v);

symbolic procedure kernel!-list u;
  % Converts u to a list of kernels, expanding lists in u.
  for each x in u join
   <>;

symbolic procedure korder u;
   <>
              else
            val := sub(nextvar=val,p);     
       >>;
       if val = u then write "     O.K.  "
          else
         <>;
    end;


testdecompose



    % univariate decompositions
testdecompose(x**4+x**2+1);


                  4    2
decomposition of x  + x  + 1

            2            2
 leads to {u  + u + 1,u=x }

     O.K.  
 
testdecompose(x**6+9x**5+52x**4+177x**3+435x**2+630x+593);


                  6      5       4        3        2
decomposition of x  + 9*x  + 52*x  + 177*x  + 435*x  + 630*x + 593

            3       2                  2
 leads to {u  + 25*u  + 210*u + 593,u=x  + 3*x}

     O.K.  
 
testdecompose(x**6+6x**4+x**3+9x**2+3x-5);


                  6      4    3      2
decomposition of x  + 6*x  + x  + 9*x  + 3*x - 5

            2            3
 leads to {u  + u - 5,u=x  + 3*x}

     O.K.  
 
testdecompose(x**8-88*x**7+2924*x**6-43912*x**5+263431*x**4-218900*x**3+ 
           65690*x**2-7700*x+234);


                  8       7         6          5           4           3
decomposition of x  - 88*x  + 2924*x  - 43912*x  + 263431*x  - 218900*x

                           2
                  + 65690*x  - 7700*x + 234

            2
 leads to {u  + 35*u + 234,

              2
           u=v  + 10*v,

              2
           v=x  - 22*x}

     O.K.  


    % multivariate cases
testdecompose(u**2+v**2+2u*v+1);


                  2            2
decomposition of u  + 2*u*v + v  + 1

            2
 leads to {w  + 1,w=u + v}

     O.K.  
 
testdecompose(x**4+2x**3*y + 3x**2*y**2 + 2x*y**3 + y**4 + 2x**2*y  
         +2x*y**2 + 2y**3 + 5 x**2 + 5*x*y + 6*y**2 + 5y + 9);


                  4      3        2  2      2        2        3        2
decomposition of x  + 2*x *y + 3*x *y  + 2*x *y + 5*x  + 2*x*y  + 2*x*y  + 5*x*y

                     4      3      2
                  + y  + 2*y  + 6*y  + 5*y + 9

            2              2          2
 leads to {u  + 5*u + 9,u=x  + x*y + y  + y}

     O.K.  

testdecompose  sub(u=(2 x**2 + 17 x+y + y**3),u**2+2 u + 1);


                    4       3      2  3      2          2         3
decomposition of 4*x  + 68*x  + 4*x *y  + 4*x *y + 293*x  + 34*x*y  + 34*x*y

                            6      4      3    2
                  + 34*x + y  + 2*y  + 2*y  + y  + 2*y + 1

            2                2           3
 leads to {u  + 2*u + 1,u=2*x  + 17*x + y  + y}

     O.K.  

testdecompose  sub(u=(2 x**2 *y + 17 x+y + y**3),u**2+2 u + 1);


                    4  2       3        2  4      2  2      2          2
decomposition of 4*x *y  + 68*x *y + 4*x *y  + 4*x *y  + 4*x *y + 289*x

                          3                    6      4      3    2
                  + 34*x*y  + 34*x*y + 34*x + y  + 2*y  + 2*y  + y  + 2*y + 1

            2                2             3
 leads to {u  + 2*u + 1,u=2*x *y + 17*x + y  + y}

     O.K.  


    % some cases which require a special (internal) mapping
testdecompose  ( (x + y)**2);


                  2            2
decomposition of x  + 2*x*y + y

            2
 leads to {u ,u=x + y}

     O.K.  

testdecompose ((x + y**2)**2);


                  2        2    4
decomposition of x  + 2*x*y  + y

            2        2
 leads to {u ,u=x + y }

     O.K.  

testdecompose  ( (x**2 + y)**2);


                  4      2      2
decomposition of x  + 2*x *y + y

            2    2
 leads to {u ,u=x  + y}

     O.K.  

testdecompose  ( (u + v)**2 +10 );


                  2            2
decomposition of u  + 2*u*v + v  + 10

            2
 leads to {w  + 10,w=u + v}

     O.K.  


    % the decomposition is not unique and might generate quite
    % different images:
testdecompose  ( (u + v + 10)**2 -100 );


                  2                   2
decomposition of u  + 2*u*v + 20*u + v  + 20*v

 leads to {w*(w + 20),w=u + v}

     O.K.  


    % some special (difficult) cases
testdecompose (X**4 + 88*X**3*Y + 2904*X**2*Y**2 - 10*X**2 
           + 42592*X*Y**3 - 440*X*Y + 234256*Y**4 - 4840*Y**2);


                  4       3           2  2       2            3
decomposition of x  + 88*x *y + 2904*x *y  - 10*x  + 42592*x*y  - 440*x*y

                            4         2
                  + 234256*y  - 4840*y

                         2
 leads to {u*(u - 10),u=v ,v=x + 22*y}

     O.K.  


    % a polynomial with complex coefficients
on complex;


testdecompose(X**4 + (88*I)*X**3*Y - 2904*X**2*Y**2 - 10*X**2 - 
              (42592*I)*X*Y**3 - (440*I)*X*Y + 234256*Y**4 + 4840*Y**2);


                  4         3           2  2       2              3
decomposition of x  + 88*i*x *y - 2904*x *y  - 10*x  - 42592*i*x*y  - 440*i*x*y

                            4         2
                  + 234256*y  + 4840*y

                         2
 leads to {u*(u - 10),u=v ,v=x + 22*i*y}

     O.K.  

off complex;




% Examples given by J. Gutierrez and J.M. Olazabal.

f1:=x**6-2x**5+x**4-3x**3+3x**2+5$


testdecompose(f1);


                  6      5    4      3      2
decomposition of x  - 2*x  + x  - 3*x  + 3*x  + 5

            2              3    2
 leads to {u  - 3*u + 5,u=x  - x }

     O.K.  


f2:=x**32-1$


testdecompose(f2);


                  32
decomposition of x   - 1

            2        2    2    2    2
 leads to {u  - 1,u=v ,v=w ,w=a ,a=x }

     O.K.  


f3:=x**4-(2/3)*x**3-(26/9)*x**2+x+3$


testdecompose(f3);


                     4      3       2
                  9*x  - 6*x  - 26*x  + 9*x + 27
decomposition of --------------------------------
                                9

             2
            u  - 9*u + 27       2
 leads to {---------------,u=3*x  - x}
                  9

     O.K.  


f4:=sub(x=x**4-x**3-2x+1,x**3-x**2-1)$


testdecompose(f4);


                  12      11      10      9       8       7       6       5
decomposition of x   - 3*x   + 3*x   - 7*x  + 14*x  - 10*x  + 14*x  - 20*x

                       4      3      2
                  + 9*x  - 9*x  + 8*x  - 2*x - 1

            3      2            4    3
 leads to {u  + 2*u  + u - 1,u=x  - x  - 2*x}

     O.K.  


f5:=sub(x=f4,x**5-5)$


testdecompose(f5);


                  60       59        58        57         56         55
decomposition of x   - 15*x   + 105*x   - 485*x   + 1795*x   - 5873*x

                           54          53           52           51           50
                  + 17255*x   - 45845*x   + 112950*x   - 261300*x   + 567203*x

                             49            48            47            46
                  - 1164475*x   + 2280835*x   - 4259830*x   + 7604415*x

                              45             44             43             42
                  - 13053437*x   + 21545220*x   - 34200855*x   + 52436150*x

                              41              40              39              38
                  - 77668230*x   + 111050794*x   - 153746645*x   + 206190770*x

                               37              36              35
                  - 267484170*x   + 336413145*x   - 410387890*x

                               34              33              32
                  + 484672110*x   - 555048350*x   + 616671710*x

                               31              30              29
                  - 663135380*x   + 690884384*x   - 697721320*x

                               28              27              26
                  + 681039235*x   - 642661265*x   + 586604975*x

                               25              24              23
                  - 516016275*x   + 437051535*x   - 356628245*x

                               22              21              20
                  + 278991765*x   - 208571965*x   + 149093999*x

                               19             18             17             16
                  - 101204325*x   + 64656350*x   - 38848040*x   + 21710870*x

                              15            14            13           12
                  - 10971599*x   + 4928210*x   - 1904450*x   + 519730*x

                           11          10          9          8         7
                  - 15845*x   - 71947*x   + 52015*x  - 26740*x  + 5510*x

                          6         5       4        3
                  + 3380*x  - 1972*x  - 75*x  + 195*x  - 10*x - 6

            5      4       3       2
 leads to {u  - 5*u  + 10*u  - 10*u  + 5*u - 6,

              3      2
           u=v  + 2*v  + v,

              4    3
           v=x  - x  - 2*x}

     O.K.  


clear f1,f2,f3,f4,f5;




% Tests of gcd code.

% The following examples were introduced in Moses, J. and Yun, D.Y.Y.,
% "The EZ GCD Algorithm", Proc. ACM 73 (1973) 159-166, and considered
% further in Hearn, A.C., "Non-modular Computation of Polynomial GCD's
% Using Trial Division", Proc. EUROSAM 79, 227-239, 72, published as
% Lecture Notes on Comp. Science, # 72, Springer-Verlag, Berlin, 1979.

on gcd;



% The following is the best setting for this file.

on ezgcd;



% In systems that have the heugcd code, the following is also a
% possibility, although not all examples complete in a reasonable time.

% load heugcd; on heugcd;

% The final alternative is to use neither ezgcd nor heugcd. In that case,
% most examples take excessive amounts of computer time.

share n;



operator xx;



% Case 1.

for n := 2:5
   do write gcd(((for i:=1:n sum xx(i))-1)*((for i:=1:n sum xx(i)) + 2),
		((for i:=1:n sum xx(i))+1)
		     *(-3xx(2)*xx(1)**2+xx(2)**2-1)**2);


1

1

1

1


% Case 2.

let d = (for i:=1:n sum xx(i)**n) + 1;



for n := 2:7 do write gcd(d*((for i:=1:n sum xx(i)**n) - 2),
			  d*((for i:=1:n sum xx(i)**n) + 2));


     2        2
xx(2)  + xx(1)  + 1

     3        3        3
xx(3)  + xx(2)  + xx(1)  + 1

     4        4        4        4
xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     5        5        5        5        5
xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     6        6        6        6        6        6
xx(6)  + xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     7        7        7        7        7        7        7
xx(7)  + xx(6)  + xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1



for n := 2:7 do write gcd(d*((for i:=1:n sum xx(i)**n) - 2),
			  d*((for i:=1:n sum xx(i)**(n-1)) + 2));


     2        2
xx(2)  + xx(1)  + 1

     3        3        3
xx(3)  + xx(2)  + xx(1)  + 1

     4        4        4        4
xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     5        5        5        5        5
xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     6        6        6        6        6        6
xx(6)  + xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1

     7        7        7        7        7        7        7
xx(7)  + xx(6)  + xx(5)  + xx(4)  + xx(3)  + xx(2)  + xx(1)  + 1


% Case 3.

let d = xx(2)**2*xx(1)**2 + (for i := 3:n sum xx(i)**2) + 1;



for n := 2:5
   do write gcd(d*(xx(2)*xx(1) + (for i:=3:n sum xx(i)) + 2)**2,
		d*(xx(1)**2-xx(2)**2 + (for i:=3:n sum xx(i)**2) - 1));


     2      2
xx(2) *xx(1)  + 1

     2        2      2
xx(3)  + xx(2) *xx(1)  + 1

     2        2        2      2
xx(4)  + xx(3)  + xx(2) *xx(1)  + 1

     2        2        2        2      2
xx(5)  + xx(4)  + xx(3)  + xx(2) *xx(1)  + 1


% Case 4.

let u = xx(1) - xx(2)*xx(3) + 1,
    v = xx(1) - xx(2) + 3xx(3);



gcd(u*v**2,v*u**2);


       2                    2
3*xx(3) *xx(2) - xx(3)*xx(2)  + xx(3)*xx(2)*xx(1) - 3*xx(3)*xx(1) - 3*xx(3)

                              2
 + xx(2)*xx(1) + xx(2) - xx(1)  - xx(1)


gcd(u*v**3,v*u**3);


       2                    2
3*xx(3) *xx(2) - xx(3)*xx(2)  + xx(3)*xx(2)*xx(1) - 3*xx(3)*xx(1) - 3*xx(3)

                              2
 + xx(2)*xx(1) + xx(2) - xx(1)  - xx(1)


gcd(u*v**4,v*u**4);


       2                    2
3*xx(3) *xx(2) - xx(3)*xx(2)  + xx(3)*xx(2)*xx(1) - 3*xx(3)*xx(1) - 3*xx(3)

                              2
 + xx(2)*xx(1) + xx(2) - xx(1)  - xx(1)


gcd(u**2*v**4,v**2*u**4);


       4      2          3      3          3      2
9*xx(3) *xx(2)  - 6*xx(3) *xx(2)  + 6*xx(3) *xx(2) *xx(1)

           3                       3              2      4
 - 18*xx(3) *xx(2)*xx(1) - 18*xx(3) *xx(2) + xx(3) *xx(2)

          2      3              2      2      2           2      2
 - 2*xx(3) *xx(2) *xx(1) + xx(3) *xx(2) *xx(1)  + 12*xx(3) *xx(2) *xx(1)

           2      2           2            2           2
 + 12*xx(3) *xx(2)  - 12*xx(3) *xx(2)*xx(1)  - 12*xx(3) *xx(2)*xx(1)

          2      2           2                2                3
 + 9*xx(3) *xx(1)  + 18*xx(3) *xx(1) + 9*xx(3)  - 2*xx(3)*xx(2) *xx(1)

                3                2      2                2
 - 2*xx(3)*xx(2)  + 4*xx(3)*xx(2) *xx(1)  + 4*xx(3)*xx(2) *xx(1)

                      3                      2
 - 2*xx(3)*xx(2)*xx(1)  - 8*xx(3)*xx(2)*xx(1)  - 12*xx(3)*xx(2)*xx(1)

                                3                 2
 - 6*xx(3)*xx(2) + 6*xx(3)*xx(1)  + 12*xx(3)*xx(1)  + 6*xx(3)*xx(1)

        2      2          2              2                3                2
 + xx(2) *xx(1)  + 2*xx(2) *xx(1) + xx(2)  - 2*xx(2)*xx(1)  - 4*xx(2)*xx(1)

                        4          3        2
 - 2*xx(2)*xx(1) + xx(1)  + 2*xx(1)  + xx(1)



% Case 5.

let d = (for i := 1:n product (xx(i)+1)) - 3;



for n := 2:5 do write gcd(d*for i := 1:n product (xx(i) - 2),
			  d*for i := 1:n product (xx(i) + 2));


xx(2)*xx(1) + xx(2) + xx(1) - 2

xx(3)*xx(2)*xx(1) + xx(3)*xx(2) + xx(3)*xx(1) + xx(3) + xx(2)*xx(1) + xx(2)

 + xx(1) - 2

xx(4)*xx(3)*xx(2)*xx(1) + xx(4)*xx(3)*xx(2) + xx(4)*xx(3)*xx(1) + xx(4)*xx(3)

 + xx(4)*xx(2)*xx(1) + xx(4)*xx(2) + xx(4)*xx(1) + xx(4) + xx(3)*xx(2)*xx(1)

 + xx(3)*xx(2) + xx(3)*xx(1) + xx(3) + xx(2)*xx(1) + xx(2) + xx(1) - 2

xx(5)*xx(4)*xx(3)*xx(2)*xx(1) + xx(5)*xx(4)*xx(3)*xx(2)

 + xx(5)*xx(4)*xx(3)*xx(1) + xx(5)*xx(4)*xx(3) + xx(5)*xx(4)*xx(2)*xx(1)

 + xx(5)*xx(4)*xx(2) + xx(5)*xx(4)*xx(1) + xx(5)*xx(4) + xx(5)*xx(3)*xx(2)*xx(1)

 + xx(5)*xx(3)*xx(2) + xx(5)*xx(3)*xx(1) + xx(5)*xx(3) + xx(5)*xx(2)*xx(1)

 + xx(5)*xx(2) + xx(5)*xx(1) + xx(5) + xx(4)*xx(3)*xx(2)*xx(1)

 + xx(4)*xx(3)*xx(2) + xx(4)*xx(3)*xx(1) + xx(4)*xx(3) + xx(4)*xx(2)*xx(1)

 + xx(4)*xx(2) + xx(4)*xx(1) + xx(4) + xx(3)*xx(2)*xx(1) + xx(3)*xx(2)

 + xx(3)*xx(1) + xx(3) + xx(2)*xx(1) + xx(2) + xx(1) - 2


clear d,u,v;




% The following examples were discussed in Char, B.W., Geddes, K.O.,
% Gonnet, G.H., "GCDHEU:  Heuristic Polynomial GCD Algorithm Based
% on Integer GCD Computation", Proc. EUROSAM 84, 285-296, published as
% Lecture Notes on Comp. Science, # 174, Springer-Verlag, Berlin, 1984.


% Maple Problem 1.

gcd(34*x**80-91*x**99+70*x**31-25*x**52+20*x**76-86*x**44-17*x**33
    -6*x**89-56*x**54-17,
    91*x**49+64*x**10-21*x**52-88*x**74-38*x**76-46*x**84-16*x**95
    -81*x**72+96*x**25-20);


1

    
% Maple Problem 2.

g := 34*x**19-91*x+70*x**7-25*x**16+20*x**3-86;


         19       16       7       3
g := 34*x   - 25*x   + 70*x  + 20*x  - 91*x - 86


gcd(g * (64*x**34-21*x**47-126*x**8-46*x**5-16*x**60-81),
    g * (72*x**60-25*x**25-19*x**23-22*x**39-83*x**52+54*x**10+81) );


    19       16       7       3
34*x   - 25*x   + 70*x  + 20*x  - 91*x - 86


% Maple Problem 3.

gcd(3427088418+8032938293*x-9181159474*x**2-9955210536*x**3
    +7049846077*x**4-3120124818*x**5-2517523455*x**6+5255435973*x**7
    +2020369281*x**8-7604863368*x**9-8685841867*x**10+4432745169*x**11
    -1746773680*x**12-3351440965*x**13-580100705*x**14+8923168914*x**15
    -5660404998*x**16 +5441358149*x**17-1741572352*x**18
    +9148191435*x**19-4940173788*x**20+6420433154*x**21+980100567*x**22
    -2128455689*x**23+5266911072*x**24-8800333073*x**25-7425750422*x**26
    -3801290114*x**27-7680051202*x**28-4652194273*x**29-8472655390*x**30
    -1656540766*x**31+9577718075*x**32-8137446394*x**33+7232922578*x**34
    +9601468396*x**35-2497427781*x**36-2047603127*x**37-1893414455*x**38
    -2508354375*x**39-2231932228*x**40,
    2503247071-8324774912*x+6797341645*x**2+5418887080*x**3
    -6779305784*x**4+8113537696*x**5+2229288956*x**6+2732713505*x**7
    +9659962054*x**8-1514449131*x**9+7981583323*x**10+3729868918*x**11
    -2849544385*x**12-5246360984*x**13+2570821160*x**14-5533328063*x**15
    -274185102*x**16+8312755945*x**17-2941669352*x**18-4320254985*x**19
    +9331460166*x**20-2906491973*x**21-7780292310*x**22-4971715970*x**23
    -6474871482*x**24-6832431522*x**25-5016229128*x**26-6422216875*x**27
    -471583252*x**28+3073673916*x**29+2297139923*x**30+9034797416*x**31
    +6247010865*x**32+5965858387*x**33-4612062748*x**34+5837579849*x**35
    -2820832810*x**36-7450648226*x**37+2849150856*x**38+2109912954*x**39
    +2914906138*x**40);


1


% Maple Problem 4.

g := 34271+80330*x-91812*x**2-99553*x**3+70499*x**4-31201*x**5
     -25175*x**6+52555*x**7+20204*x**8-76049*x**9-86859*x**10;


               10          9          8          7          6          5
g :=  - 86859*x   - 76049*x  + 20204*x  + 52555*x  - 25175*x  - 31201*x

               4          3          2
      + 70499*x  - 99553*x  - 91812*x  + 80330*x + 34271


gcd(g * (44328-17468*x-33515*x**2-5801*x**3+89232*x**4-56604*x**5
	 +54414*x**6-17416*x**7+91482*x**8-49402*x**9+64205*x**10
	 +9801*x**11-21285*x**12+52669*x**13-88004*x**14-74258*x**15
	 -38013*x**16-76801*x**17-46522*x**18-84727*x**19-16565*x**20
	 +95778*x**21-81375*x**22+72330*x**23+96015*x**24-24974*x**25
	 -20476*x**26-18934*x**27-25084*x**28-22319*x**29+25033*x**30),
    g * (-83248+67974*x+54189*x**2-67793*x**3+81136*x**4+22293*x**5
	 +27327*x**6+96600*x**7-15145*x**8+79816*x**9+37299*x**10
	 -28496*x**11-52464*x**12+25708*x**13-55334*x**14-2742*x**15
	 +83128*x**16-29417*x**17-43203*x**18+93315*x**19-29065*x**20
	 -77803*x**21-49717*x**22-64749*x**23-68325*x**24-50163*x**25
	 -64222*x**26-4716*x**27+30737*x**28+22972*x**29+90348*x**30));


       10          9          8          7          6          5          4
86859*x   + 76049*x  - 20204*x  - 52555*x  + 25175*x  + 31201*x  - 70499*x

          3          2
 + 99553*x  + 91812*x  - 80330*x - 34271


% Maple Problem 5.

gcd(-8472*x**4*y**10-8137*x**9*y**10-2497*x**4*y**4-2508*x**4*y**6
    -8324*x**9*y**8-6779*x**9*y**6+2733*x**10*y**4+7981*x**7*y**3
    -5246*x**6*y**2-274*x**10*y**3-4320,
    15168*x**3*y-4971*x*y-2283*x*y**5+3074*x**6*y**10+6247*x**8*y**2
    +2849*x**6*y**7-2039*x**7-2626*x**2*y**7+9229*x**6*y**5+2404*y**5
    +1387*x**4*y**8+5602*x**5*y**2-6212*x**3*y**7-8561);


1


% Maple Problem 6.

g := -19*x**4*y**4+25*y**9+54*x*y**9+22*x**7*y**10-15*x**9*y**7-28;


            9  7       7  10       4  4         9       9
g :=  - 15*x *y  + 22*x *y   - 19*x *y  + 54*x*y  + 25*y  - 28


gcd(g*(91*x**2*y**9+10*x**4*y**8-88*x*y**3-76*x**2-16*x**10*y
       +72*x**10*y**4-20),
    g*(34*x**9-99*x**9*y**3-25*x**8*y**6-76*y**7-17*x**3*y**5
       +89*x**2*y**8-17));


    9  7       7  10       4  4         9       9
15*x *y  - 22*x *y   + 19*x *y  - 54*x*y  - 25*y  + 28


% Maple Problem 7.

gcd(6713544209*x**9+8524923038*x**3*y**3*z**7+6010184640*x*z**7
    +4126613160*x**3*y**4*z**9+2169797500*x**7*y**4*z**9
    +2529913106*x**8*y**5*z**3+7633455535*y*z**3+1159974399*x**2*z**4
    +9788859037*y**8*z**9+3751286109*x**3*y**4*z**3,
    3884033886*x**6*z**8+7709443539*x*y**9*z**6
    +6366356752*x**9*y**4*z**8+6864934459*x**3*y**2*z**6
    +2233335968*x**4*y**9*z**3+2839872507*x**9*y**3*z
    +2514142015*x*y*z**2+1788891562*x**4*y**6*z**6
    +9517398707*x**8*y**7*z**2+7918789924*x**3*y*z**6
    +6054956477*x**6*y**3*z**6);


1


% Maple Problem 8.

g := u**3*(x**2-y)*z**2+(u-3*u**2*x)*y*z-u**4*x*y+3;


         4        3  2  2    3    2      2
g :=  - u *x*y + u *x *z  - u *y*z  - 3*u *x*y*z + u*y*z + 3

gcd(g * ((y**2+x)*z**2+u**5*(x*y+x**2)*z-y+5),
    g * ((y**2-x)*z**2+u**5*(x*y-x**2)*z+y+9) );


 4        3  2  2    3    2      2
u *x*y - u *x *z  + u *y*z  + 3*u *x*y*z - u*y*z - 3


% Maple Problem 9.

g := 34*u**2*y**2*z-25*u**2*v*z**2-18*v*x**2*z**2-18*u**2*x**2*y*z+53
     +x**3;


            2    2       2  2           2  2           2  2    3
g :=  - 25*u *v*z  - 18*u *x *y*z + 34*u *y *z - 18*v*x *z  + x  + 53

gcd( g * (-85*u*v**2*y**2*z**2-25*u*v*x*y*z-84*u**2*v**2*y**2*z
      +27*u**2*v*x**2*y**2*z-53*u*x*y**2*z+34*x**3),
     g * (48*x**3-99*u*x**2*y**2*z-69*x*y*z-75*u*v*x*y*z**2
     -43*u**2*v+91*u**2*v**2*y**2*z) );


    2    2       2  2           2  2           2  2    3
25*u *v*z  + 18*u *x *y*z - 34*u *y *z + 18*v*x *z  - x  - 53


% Maple Problem 10.

gcd(-9955*v**9*x**3*y**4*z**8+2020*v*y**7*z**4
    -3351*v**5*x**10*y**2*z**8-1741*v**10*x**2*y**9*z**6
    -2128*v**8*y*z**3-7680*v**2*y**4*z**10-8137*v**9*x**10*y**4*z**4
    -1893*v**4*x**4*y**6+6797*v**8*x*y**9*z**6
    +2733*v**10*x**4*y**9*z**7-2849*v**2*x**6*y**2*z**5
    +8312*v**3*x**3*y**10*z**3-7780*v**2*x*y*z**2
    -6422*v**5*x**7*y**6*z**10+6247*v**8*x**2*y**8*z**3
    -7450*v**7*x**6*y**7*z**4+3625*x**4*y**2*z**7+9229*v**6*x**5*y**6
    -112*v**6*x**4*y**8*z**7-7867*v**5*x**8*y**5*z**2
    -6212*v**3*x**7*z**5+8699*v**8*x**2*y**2*z**5
    +4442*v**10*x**5*y**4*z+1965*v**10*y**3*z**3-8906*v**6*x*y**4*z**5
    +5552*x**10*y**4+3055*v**5*x**3*y**6*z**2+6658*v**7*x**10*z**6
    +3721*v**8*x**9*y**4*z**8+9511*v*x**6*y+5437*v**3*x**9*y**9*z**7
    -1957*v**6*x**4*y*z**3+9214*v**3*x**9*y**3*z**7
    +7273*v**2*x**8*y**4*z**10+1701*x**10*y**7*z**2
    +4944*v**5*x**5*y**8*z**8-1935*v**3*x**6*y**10*z**7
    +4029*x**6*y**10*z**3+9462*v**6*x**5*y**4*z**8-3633*v**4*x*y**7*z**5
    -1876,
    -5830*v**7*x**8*y*z**2-1217*v**8*x*y**2*z**5
    -1510*v**9*x**3*y**10*z**10+7036*v**6*x**8*y**3*z**3
    +1022*v**9*y**3*z**8+3791*v**8*x**3*y**7+6906*v**6*x*y*z**10
    +117*v**7*x**2*y**4*z**4+6654*v**6*x**5*y**2*z**3
    -7302*v**10*x**8*y**3-5343*v**8*x**5*y**9*z
    -2244*v**9*x**3*y**8*z**9-3719*v**5*x**10*y**6*z**8
    +2629*x**3*y**2*z**10+8517*x**9*y**6*z**7-9551*v**5*x**6*y**6*z**2
    -7750*x**10*y**7*z**4-5035*v**5*x**2*y**5*z-5967*v**9*x**5*y**9*z**5
    -8517*v**3*x**2*y**7*z**6-2668*v**10*y**9*z**4+1630*v**5*x**5*y*z**8
    +9099*v**7*x**9*y**4*z**3-5358*v**9*x**5*y**6*z**2
    +5766*v**5*y**3*z**4-3624*v*x**4*y**10*z**10
    +8839*v**6*x**9*y**10*z**4+3378*x**7*y**2*z**5+7582*v**7*x*y**8*z**7
    -85*v*x**2*y**9*z**6-9495*v**9*x**10*y**6*z**3+1983*v**9*x**3*y
    -4613*v**10*x**4*y**7*z**6+5529*v**10*x*y**6
    +5030*v**4*x**5*y**4*z**9-9202*x**6*y**3*z**9
    -4988*v**2*x**2*y**10*z**4-8572*v**9*x**7*y**10*z**10
    +4080*v**4*x**8*z**8-382*v**9*x**9*y**2*z**2-7326);


1


end;


Time for test: 78 ms
@@@@@ Resources used: (0 1 42 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/subs2q.red0000644000175000017500000001766511526203062023421 0ustar  giovannigiovannimodule subs2q;  % Routines for substituting for powers.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp !*mcd !*structure !*sub2 alglist!* dmode!* frlis!*);

fluid '(powlis!* powlis1!*);

global '(!*resubs simpcount!* simplimit!*);

Comment If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not
simplified, to allow some attempt at a structure theorem use, especially
in the integrator;

symbolic procedure subs2q u;
   % Perform power substitutions on u. Check whether substitions
   % on numerator and denominator change these before doing
   % quotient (to avoid undoing rationalization of denominator).
   ((if denr x=1 and denr y=1 and numr x=v and numr y=w then u
      else quotsq(x,y))
     where x=subs2f v, y=subs2f w)
    where v=numr u, w=denr u;

symbolic procedure subs2f u;
   begin scalar x;
        if simpcount!*>simplimit!*
         then <>;
        simpcount!* := simpcount!*+1;
        !*sub2 := nil;
        x := subs2f1 u;
        if (!*sub2 or powlis1!*) and !*resubs
           then if numr x=u and denr x=1 then !*sub2 := nil
                else x := subs2q x;
        simpcount!* := simpcount!*-1;
        return x
   end;

symbolic procedure subs2f1 u;
   if domainp u then !*d2q u
    else begin scalar kern,v,w,x,y,z;
        kern := mvar u;
        z := nil ./ 1;
    a:  if null u or degr(u,kern)=0 then go to a1;
        y := lt u .+ y;
        u := red u;
        go to a;
    a1: x := powlis!*;
    a2: if null x then go to b
         else if caaar y = caar x
          then <>
%        else if eqcar(kern,'sqrt) and cadr kern = caar x
%         then <>;
         else if eqcar(kern,'expt)
                and cadr kern = caar x
                and eqcar(caddr kern,'quotient)
                and cadr caddr kern = 1
                and numberp caddr caddr kern
          then <>;
                 go to e1>>;
        x := cdr x;
        go to a2;
    b:  x := powlis1!*;
    l2: if null x then go to l3
         else if w:= mtchp(caar y,caar x,caddar x,caadar x,cdadar x)
          then go to e1;
        x := cdr x;
        go to l2;
    l3: if eqcar(kern,'expt) and not !*structure then go to l1;
        z := addsq(multpq(caar y,subs2f1 cdar y),z);
    c:  y := cdr y;
        if y then go to a1;
    d:  y := subs2f1 u;
        % mkprod checks structure in "constant" term.
        if null !*exp then y := mkprod numr y ./ mkprod denr y;
        return addsq(z,y);
    e1: z := addsq(multsq(w,subs2f1 cdar y),z);
        go to c;
    l1: if cdaar y=1 and not eqcar(cadr kern,'expt)     % ONEP
          then w := mksq(kern,1)
         else w := simpexpt list(cadr kern,
                                 list('times,caddr kern,cdaar y));
        z := addsq(multsq(w,subs2f1 cdar y),z);
        y := cdr y;
        if y then go to l1 else go to d;
    end;

symbolic procedure subs2p(u,v,w);
   % U is a power, V an integer, and W an algebraic expression, such
   % that CAR U**V=W. Value is standard quotient for U with this
   % substitution.
   begin
      if not fixp cdr u or car(v := divide(cdr u,v))=0
        then return !*p2q u;
      w := exptsq(simp w,car v);
      return if cdr v=0 then w else multpq(car u .** cdr v,w)
   end;

symbolic procedure raddsq(u,n);
   %U is a standard quotient, N and integer. Value is sq for U**(1/N);
   simpexpt list(mk!*sq u,list('quotient,1,n));

symbolic procedure mtchp(u,v,w,flg,bool);
   %U is a standard power, V a power to be matched against.
   %W is the replacement expression.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is the substitution standard quotient if a match found,
   %NIL otherwise;
   begin scalar x;
        x := mtchp1(u,v,flg,bool);
    a:  if null x then return nil
         else if lispeval subla(car x,bool) then go to b;
        x := cdr x;
        go to a;
    b:  v := divide(cdr u,subla(car x,cdr v));
        w := exptsq(simp subla(car x,w),car v);
        if cdr v neq 0 then w := multpq(car u .** cdr v,w);
        return w
   end;

symbolic procedure mtchp1(u,v,flg,bool);
   %U is a standard power, V a power to be matched against.
   %FLG is a flag which is T if an exact power match required.
   %BOOL is a boolean expression to be satisfied for substitution.
   %Value is a list of possible free variable pairings which
   %match conditions;
   begin scalar x;
        if u=v then return list nil
         else if not (x:= mchk!*(car u,car v)) then return nil
         else if cdr v memq frlis!*
             % do not match a free power to 1 or a conflicting match.
          then if cdr u=1 or not(x:= powmtch(cdr v,x,cdr u))
                 then return nil
                else return mapcons(x,cdr v . cdr u)
         else if (flg and not(cdr u=cdr v))
                or not numberp cdr v or not numberp cdr u
                or (if !*mcd then cdr u . ), N a positive integer.
   %Value is the standard power of U**N;
   <1 then !*sub2 := t; car u . n>>;
%   begin scalar v;
%       v := cadr u;
%       if null v then return caar rplaca(cdr u,list (car u . n));
%    a: if n=cdar v then return car v
%        else if n>;
      u := !*p2f mksp(u,n);
      return if b and not evenp n then negf u else u
   end;

symbolic procedure mksfpf(u,n);
   % Raises form U to power N with EXP off. Returns a form.
   % If we assume that MKPROD returns a kernlp form, check for red x
   % is redundant.
   (if n=1 then x
     else if domainp x then !:expt(x,n)
     else if n>=0 and onep lc x and null red x
      then (((if subfg!* and z and cdr z<=m then nil
               else !*p2f mksp(y,m))
            where z=assoc(y,asymplis!*)) where m=ldeg x*n,y=mvar x)
     else exptf2(x,n))
    where x=mkprod u;

symbolic procedure mksq(u,n);
    % U is a kernel, N a non-zero integer.
    % Value is a standard quotient of U**N, after making any
    % possible substitutions for U.
   begin scalar x,y,z;
%  (begin scalar x,y,z;
        if null subfg!* then go to a1
         else if (y := assoc(u,wtl!*))
                and null car(y := mksq('k!*,n*cdr y)) then return y
         else if not atom u then go to b
         else if null !*nosubs and (z:= get(u,'avalue)) then go to c;
        if idp u then flag(list u,'used!*);
        %tell system U used as algebraic var (unless it's a string);
    a:  if !*nosubs or n=1 then go to a1
         else if (z:= assoc(u,asymplis!*)) and cdr z<=n
          then return nil ./ 1
         else if ((z:= assoc(u,powlis!*))
                or not atom u and car u memq '(expt sqrt)
                and (z := assoc(cadr u,powlis!*)))
             and not(n*cadr z<0)
           % Implements explicit sign matching.
          then !*sub2 := t;
    a1: if null x then x := fkern u;
        x := !*p2f getpower(x,n) ./ 1;
        return if y then multsq(y,x) else x;
    b:  if null !*nosubs and atom car u
           and ((z := get(car u,'mksqsubfn)) and (z := apply1(z,u))
                or (z:= assoc(u,get(car u,'kvalue))))
          then go to c
         else if not('used!* memq cddr (x := fkern u))
          then aconc(x,'used!*);
        go to a;
    c:  z := cdr z;
%       varstack!* := u . varstack!*;   % I don't think this is needed.
        %optimization is possible as shown if all expression
        %dependency is known;
        %if cdr z then return exptsq(cdr z,n); % Value already computed.
        if null !*resubs then !*nosubs := t;
        x := simpcar z;
        !*nosubs := nil;
        %rplacd(z,x);           % Save simplified value.
        %subl!* := z . subl!*;
        return exptsq(x,n)
   end;
%  end) where varstack!* := varstack!*; % I don't think this is needed.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/cpxrn.red0000644000175000017500000001427011526203062023321 0ustar  giovannigiovannimodule cpxrn; % *** Support for Complex Rationals.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Copyright (c) 1989 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment this module defines a complex rational as:

      (. ( . >).

The  is '!:crn!: and the  is (n . d) where n and d are
integers;

fluid '(!:prec!:);

global '(bfone!* epsqrt!*);

fluid '(dmode!* !*bfspace !*numval);

switch bfspace,numval; !*bfspace := !*numval := t;

global '(domainlist!*);

domainlist!* := union('(!:crn!:),domainlist!*);

fluid '(!*complex!-rational);

put('complex!-rational,'tag,'!:crn!:);
put('!:crn!:,'dname,'complex!-rational);
flag('(!:crn!:),'field);
put('!:crn!:,'i2d,'i2crn!*);
put('!:crn!:,'plus,'crn!:plus);
put('!:crn!:,'times,'crn!:times);
put('!:crn!:,'difference,'crn!:differ);
put('!:crn!:,'quotient,'crn!:quotient);
put('!:crn!:,'zerop,'crn!:zerop);
put('!:crn!:,'onep,'crn!:onep);
put('!:crn!:,'prepfn,'crn!:prep);
put('!:crn!:,'prifn,'crn!:prin);
put('!:crn!:,'minus,'crn!:minus);
put('!:crn!:,'factorfn,'crn!:factor);
put('!:crn!:,'rationalizefn,'girationalize!:);
put('!:crn!:,'!:rn!:,'!*crn2rn);
put('!:rn!:,'!:crn!:,'!*rn2crn);
put('!:rd!:,'!:crn!:,'!*rd2crn);
put('!:crn!:,'!:rd!:,'!*crn2rd);
put('!:gi!:,'!:crn!:,'!*gi2crn);
put('!:crn!:,'cmpxfn,'mkcrn);
put('!:crn!:,'ivalue,'mkdcrn);
put('!:crn!:,'intequivfn,'crnequiv);
put('!:crn!:,'realtype,'!:rn!:);
put('!:rn!:,'cmpxtype,'!:crn!:);

put('!:crn!:,'minusp,'crn!:minusp);

symbolic procedure crn!:minusp u; caddr u=0 and minusp caadr u;

symbolic procedure mkcrn(u,v); '!:crn!: . u . v;

symbolic smacro procedure crntag x; '!:crn!: . x;

symbolic smacro procedure rntag x; '!:rn!: . x;

symbolic smacro procedure crnrl x; cadr x;

symbolic smacro procedure crnim x; cddr x;

symbolic procedure crn!:simp u; (crntag u) ./ 1;

put('!:crn!:,'simpfn,'crn!:simp);

symbolic procedure mkdcrn u;
   ('!:crn!: . ((0 . 1) . (1 . 1))) ./ 1;

symbolic procedure i2crn!* u; mkcrn(u . 1,0 . 1);
   %converts integer U to tagged crn form.

symbolic procedure !*crn2rn n;
   % Converts a crn number n into a rational if possible.
   if not(car crnim n=0) then cr2rderr() else '!:rn!: . crnrl n;

symbolic procedure !*rn2crn u; mkcrn(cdr u,0 . 1);
   % Converts the (tagged) rational u/v into a (tagged) crn.

symbolic procedure !*crn2rd n;
   if not(car crnim n=0) then cr2rderr() else
     mkround chkrn!* r2bf crnrl n;

symbolic procedure !*rd2crn u; mkcrn(realrat x,0 . 1) where x=round!* u;

symbolic procedure !*gi2crn u; mkcrn((cadr u) . 1,(cddr u) . 1);

symbolic procedure crn!:plus(u,v);
   mkcrn(cdr rnplus!:(rntag crnrl u,rntag crnrl v),
         cdr rnplus!:(rntag crnim u,rntag crnim v));

symbolic procedure crn!:differ(u,v);
   mkcrn(cdr rndifference!:(rntag crnrl u,rntag crnrl v),
         cdr rndifference!:(rntag crnim u,rntag crnim v));

symbolic procedure crn!:times(u,v);
   mkcrn(cdr rndifference!:(rntimes!:(ru,rv),rntimes!:(iu,iv)),
         cdr rnplus!:(rntimes!:(ru,iv),rntimes!:(rv,iu)))
   where ru=rntag crnrl u,iu=rntag crnim u,
         rv=rntag crnrl v,iv=rntag crnim v;

symbolic procedure crn!:quotient(u,v);
 <>
  where ru=rntag crnrl u,iu=rntag crnim u,
        rv=rntag crnrl v,iv=rntag crnim v;

symbolic procedure crn!:minus u;
   mkcrn((-car ru) . cdr ru,(-car iu) . cdr iu)
   where ru=crnrl u,iu=crnim u;

symbolic procedure crn!:zerop u; car crnrl u=0 and car crnim u=0;

symbolic procedure crn!:onep u;  car crnim u=0 and crnrl u='(1 . 1);

symbolic procedure crn!:prep u;
   crnprep1((rntag crnrl u) . rntag crnim u);

symbolic procedure crn!:factor u;
   (begin scalar m,n,p,x,y;
     setdmode('rational,nil) where !*msg = nil;
     x := subf(u,nil);
     y := fctrf numr x;
     n := car y;
     setdmode('rational,t) where !*msg = nil;
     y := for each j in cdr y collect
           <
>;
     return int!-equiv!-chk quotfd(n,denr x) . y
   end) where dmode!*=dmode!*;

symbolic procedure crnprimp u;
   if rnonep!: u then 'i
   else if rnonep!: rnminus!: u then list('minus,'i)
   else list('times,rnprep!: u,'i);

symbolic procedure crnprep1 u;
   if rnzerop!: cdr u then rnprep!: car u
   else if rnzerop!: car u then crnprimp cdr u
   else if rnminusp!: cdr u
      then list('difference,rnprep!: car u,crnprimp rnminus!: cdr u)
   else list('plus,rnprep!: car u,crnprimp cdr u);

symbolic procedure crn!:prin u;
   (if atom v or car v eq 'times or car v memq domainlist!*
      then maprin v
    else <>) where v=crn!:prep u;

symbolic procedure crnequiv u;
   % Returns an equivalent integer if possible.
   if cadr(u := cdr u) = 0 and cdar u = 1 then caar u else nil;

initdmode 'complex!-rational;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/gint.red0000644000175000017500000003227211526203062023132 0ustar  giovannigiovannimodule gint;  % Support for gaussian integers (complex numbers).

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(domainlist!*);

fluid '(!*complex !*gcd);

switch complex;

domainlist!* := union('(!:gi!:),domainlist!*);

symbolic procedure setcmpxmode(u,bool);
   % Sets polynomial domain mode in complex case.
   begin scalar x,y;
      x := get(u,'tag);
      if u eq 'complex
        then if null dmode!*
               then return if null bool then nil
                else <>
         else if null bool
                then return if null !*complex then nil
                else if get(dmode!*,'dname) eq 'complex
                      then <>
                     else <>
         else if dmode!* eq '!:gi!: or get(dmode!*,'realtype)
            then return nil
         else if not (y := get(dmode!*,'cmpxtype))
               then dmoderr(dmode!*,x)
         else <>
      else if null bool then
         if u eq (y := get(get(dmode!*,'realtype),'dname)) then
            <>
            else if null y then return nil
            else offmoderr(u,y)
      else <>
   end;

% Used by gcdk.

symbolic procedure intgcdd(u,v);
   if null u then v
   else if atom u then
      if atom v then gcdn(u,v) else gcdn(cadr v,gcdn(cddr v,u))
   else if atom v then intgcdd(v,u)
      else intgcdd(cadr u,intgcdd(cddr u,v));

put('complex,'tag,'!:gi!:);
put('!:gi!:,'dname,'complex);
put('!:gi!:,'i2d,'!*i2gi);
put('!:gi!:,'minusp,'giminusp!:);
put('!:gi!:,'zerop,'gizerop!:);
put('!:gi!:,'onep,'gionep!:);
put('!:gi!:,'plus,'giplus!:);
put('!:gi!:,'difference,'gidifference!:);
put('!:gi!:,'times,'gitimes!:);
put('!:gi!:,'quotient,'giquotient!:);
put('!:gi!:,'divide,'gidivide!:);
put('!:gi!:,'gcd,'gigcd!:);
put('!:gi!:,'factorfn,'gifactor!:);
% put('!:gi!:,'rationalizefn,'girationalize!:);
put('!:gi!:,'prepfn,'giprep!:);
put('!:gi!:,'intequivfn,'gintequiv!:);
put('!:gi!:,'specprn,'giprn!:);
put('!:gi!:,'prifn,'giprn!:);
put('!:gi!:,'cmpxfn,'mkgi);

put('!:gi!:,'unitsfn,'!:gi!:unitconv);

symbolic procedure !:gi!:unitconv(u,v);
   unitconv(u,v,get('!:gi!:,'units));

put('!:gi!:,'units,'(((!:gi!: 0 . 1) . (!:gi!: 0 . -1))
             ((!:gi!: 0 . -1) . (!:gi!: 0 . 1))));

symbolic procedure unitconv(u,v,w);
   begin scalar z;
   a: if null w then return u;
      z := quotf1(v,caar w);
      if null z or not fixp z then <>;
      z := multf(denr u,cdar w);
      w := multf(numr u,cdar w);
      if minusf z then <>;
      return w ./ z
   end;

symbolic procedure !*i2gi u; '!:gi!: . (u . 0);

symbolic procedure giminusp!: u;
   %*** this is rather a test for u being in a canonical form! ***;
   if cadr u = 0 then minusp cddr u else minusp cadr u;

symbolic procedure gizerop!: u;
   cadr u = 0 and cddr u = 0;

symbolic procedure gionep!: u;
   cadr u=1 and cddr u=0;

symbolic procedure gintequiv!: u;
   if cddr u=0 then cadr u else nil;

symbolic procedure mkdgi u;
   ('!:gi!: . (0 . 1)) ./ 1;

symbolic procedure mkgi(re,im);
   '!:gi!: . (re . im);

symbolic procedure giplus!:(u,v);
   mkgi(cadr u+cadr v,cddr u+cddr v);

symbolic procedure gidifference!:(u,v);
   mkgi(cadr u-cadr v,cddr u-cddr v);

symbolic procedure gitimes!:(u,v);
   (lambda r1,i1,r2,i2;
       mkgi(r1*r2-i1*i2,r1*i2+r2*i1))
    (cadr u,cddr u,cadr v,cddr v);

symbolic procedure giquotient!:(u,v);
% Quotient when the quotient is exact, otherwise zero.
   begin integer r1,i1,r2,i2,d; scalar rr,ii;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rr := divide(r1*r2+i1*i2,d);
     ii := divide(i1*r2-i2*r1,d);
     return if cdr ii=0 and cdr rr=0 then mkgi(car rr,car ii)
             else '!:gi!: . (0 . 0)
   end;

symbolic procedure gidivide!:(u,v);
% Rounded quotient and corresponding remainder. This rounds to the
% NEAREST quotient. In some cases there can be several such (eg when
% dividing by 2) and in that case use resolve the ambiguity by selecting
% the result closes to zero in real and imaginary parts.
   begin integer r1,i1,r2,i2,d,rr,ir,rq,iq;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rq := r1*r2+i1*i2;
     iq := i1*r2-i2*r1;
     rq := car divide(2*rq+if rq<0 then -d+1 else d-1,2*d);
     iq := car divide(2*iq+if iq<0 then -d+1 else d-1,2*d);
     rr := r1-(rq*r2-iq*i2);
     ir := i1-(iq*r2+rq*i2);
     return mkgi(rq,iq) . mkgi(rr,ir)
   end;

symbolic procedure giremainder(u,v);
% Remainder as from gidivide:
   begin integer r1,i1,r2,i2,d,rr,ir,rq,iq;
     r1 := cadr u; i1 := cddr u;
     r2 := cadr v; i2 := cddr v;
     d := r2*r2+i2*i2;
     rq := r1*r2+i1*i2;
     iq := i1*r2-i2*r1;
     rq := car divide(2*rq+if rq<0 then -d+1 else d-1,2*d);
     iq := car divide(2*iq+if iq<0 then -d+1 else d-1,2*d);
     rr := r1-(rq*r2-iq*i2);
     ir := i1-(iq*r2+rq*i2);
     return '!:gi!: . (rr . ir)
   end;

symbolic procedure gigcd!:(u,v);
   % Straightforward Euclidean algorithm.
   if gizerop!: v then fqa u else gigcd!:(v,giremainder(u,v));

symbolic procedure fqa u;
   %calculates the unique first-quadrant associate of u;
  if cddr u=0 then abs cadr u
   else if cadr u=0 then '!:gi!: . (abs cddr u . 0)
   else if (cadr u*cddr u)>0 then
                  '!:gi!: . (abs cadr u . abs cddr u)
   else '!:gi!: . (abs cddr u . abs cadr u);

symbolic procedure gifactor!: u;
   % Trager's modified version of Van der Waerdens algorithm.
   begin scalar x,y,norm,aftrs,ftrs,mvu,dmode!*,!*exp,w,z,l,bool;
         integer s;
     !*exp := t;
     if realp u
        then u := cdr factorf u
      else u := list(u . 1);
     w := 1;
     for each f in u do begin
     u := car f;
     dmode!* := '!:gi!:;
     mvu := power!-sort powers u;
     bool := contains!-oddpower mvu;
     if realp u and bool
        then <>;
     mvu := caar mvu;
     y := u;
     go to b;
     a: l := list(mvu . prepf addf(!*k2f mvu,multd(s,!*k2f 'i)));
        u := numr subf1(y,l);
     b: if realp u
           then if bool
                   then <>
                 else <>;
        norm := multf(u,conjgd u);
        if not sqfrp norm then <>;
     dmode!* := nil;
     ftrs := factorf norm;
     dmode!* := '!:gi!:;
     if null cddr ftrs then <>;
     w := car ftrs;
     l := if s=0 then nil
           else list(mvu . prepf addf(!*k2f mvu,
                                      negf multd(s,!*k2f 'i)));
     for each j in cdr ftrs do
         <>;
     w := multf(u,w) end;
     return w . aftrs
   end;

symbolic procedure normalize!-lcgi u;
   % Normalize lnc by using units as canonsq would do it.
   begin scalar l,x,y;
     l := lnc u;
     if numberp l then return if minusp l then (-1) . negf u
                               else 1 . u;
     x := get('!:gi!:,'units);
     a: if null x then return 1 . u;
        y := quotf1(l,caar x);
        if null y or null fixp y then <>;
        u := multd(cdar x,u);
        return if minusf u then negf caar x . negf u
                else caar x . u
   end;

symbolic procedure contains!-oddpower u;
   if null u then nil
    else if evenp cdar u then contains!-oddpower cdr u
    else t;

symbolic procedure power!-sort u;
   begin scalar x,y;
     while u do
       <>;
     return y
   end;

symbolic procedure sqfrp u;
   % Square free test for poly u over the integers.
   % It works best with ezgcd on.
   begin scalar !*ezgcd, dmode!*;
     % Make sure ezgcd loaded.
     if null getd 'ezgcdf1 then load_package ezgcd;
     !*ezgcd := t;
     return domainp gcdf!*(u,diff(u,mvar u))
   end;

symbolic procedure realp u;
   if domainp u
     then atom u
        or not get(car u,'cmpxfn)
        or cddr u = cddr apply1(get(car u,'i2d),1)
    else realp lc u and realp red u;

symbolic procedure fd2f u;
   if atom u then u
    else if car u eq '!:gi!:
        then addf(!*n2f cadr u,multf(!*k2f 'i,!*n2f cddr u))
    else addf(multf(!*p2f lpow u,fd2f lc u),fd2f red u);


% symbolic procedure giprep!: u;  %giprep1 cdr u;
%   prepsq!* addsq(!*n2f cadr u ./ 1,
%                  multsq(!*n2f cddr u ./ 1, !*k2q 'i));

% symbolic procedure giprep1 u;  %not used now;
%    if cdr u=0 then car u
%     else if car u=0 then retimes list(cdr u,'i)
%     else begin scalar gn;
%            gn := gcdn(car u,cdr u);
%            return retimes list(gn,
%                       replus list(car u/gn,retimes list(cdr u/gn,'i)))
%          end;

symbolic procedure giprep!: u;
   <>
   where rl=cadr u,im=cddr u;

symbolic procedure giprim im; if im=1 then 'i else list('times,im,'i);

symbolic procedure giprn!: v;
   (lambda u;
    if atom u or (car u eq 'times) then maprin u
     else <>) giprep!: v;

% symbolic procedure girationalize!: u;
%    %Rationalizes standard quotient u over the gaussian integers.
%    begin scalar x,y,z;
%       y := denr u;
%       z := conjgd y;
%       if y=z then return u;
%       x := multf(numr u,z);
%       y := multf(y,z);
%       return x ./ y
%    end;

symbolic procedure girationalize!: u;
   % Rationalizes standard quotient u over the gaussian integers.
   begin scalar y,z,!*gcd;
      !*gcd := t;
      if y=(z := conjgd(y := denr u)) then return u;
      % Remove from z any real polynomial factors of y and z.
      z := quotf(z,quotf(
         gcdf(addf(y,z),multf(addf(z,negf y),'!:gi!: . (0 . 1))),2));
      % The following subs2 can undo the above if !*match is non-NIL.
%     return subs2 gigcdsq(multf(numr u,z),multf(y,z))
      return gigcdsq(multf(numr u,z),multf(y,z))
   end;

symbolic procedure gigcdsq(x,y); % remove integer common factor.
   <> >>
         where d=giintgcd(y,0)); x ./ y >>;

symbolic procedure giintgcd(u,d);
   if d=1 then 1 else if null u then d else if atom u then gcdn(u,d)
   else if eqcar(u,'!:gi!:) then gcdn(cadr u,gcdn(cddr u,d))
   else giintgcd(lc u,giintgcd(red u,d));

symbolic procedure conjgd u;
   begin scalar x;
      return if atom u then u
              else if domainp u and (x := get(car u,'cmpxfn))
               then
                  apply2(x,cadr u,
                   if numberp cddr u then -cddr u
                       % Allow for tagged parts of complex object.
                       else if domainp cddr u and not numberp caddr u
                          then !:minus cddr u
                       else cdr !:minus (get(car u,'realtype).cddr u))
              else if domainp u then u   % Should be a real number now.
              else addf(multpf(lpow u,conjgd lc u),conjgd red u)
   end;

initdmode 'complex;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/exptf.red0000644000175000017500000000647311526203062023323 0ustar  giovannigiovannimodule exptf; % Functions for raising canonical forms to a power.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp);

symbolic procedure exptsq(u,n);
   begin scalar x;
      if n=1 then return u
       else if n=0
         then return if null numr u then rerror(poly,4," 0**0 formed")
                      else 1 ./ 1
       else if null numr u then return u
       else if n<0 then return simpexpt list(mk!*sq u,n)
       else if null !*exp
        then return mksfpf(numr u,n) ./ mksfpf(denr u,n)
       else if kernp u then return mksq(mvar numr u,n)
       else if denr u=1 then return exptf(numr u,n) ./ 1
       else if domainp numr u
        then x := multsq(!:expt(numr u,n) ./ 1,1 ./ exptf(denr u,n))
       else <0
                 do x := multf(numr u,numr x) ./ multf(denr u,denr x);
              % We need canonsq for a:=1+x/2; let x^2=0; a^2;
              x := canonsq x>>;
      if null cdr x then rerror(poly,101,"Zero divisor");
      return x
   end;

symbolic procedure exptf(u,n);
   if n < 0 then errach {"exptf",u,n}
    else if domainp u then !:expt(u,n)
    else if !*exp or kernlp u then exptf1(u,n)
    else mksfpf(u,n);

symbolic procedure exptf1(u,n);
   % Iterative multiplication seems to be faster than a binary sub-
   % division algorithm, probably because multiplying a small polynomial
   % by a large one is cheaper than multiplying two medium sized ones.
   if n=0 then 1
    else begin scalar x;
         x := u; while (n := n-1)>0 do x := multf(u,x); return x
         end;

symbolic procedure exptf2(u,n);
   % Binary version of EXPTF1, Used with EXP off, since expressions
   % formed in that case tend to be smaller than with EXP on.
   if n=0 then 1
    else begin scalar x; integer m;
         x := 1;
    a:   m := n;
         if m-2*(n := n/2) neq 0 then x := multf(u,x);
         if n=0 then return x;
         u := multf(u,u);
         go to a
      end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/conj.red0000644000175000017500000001763611526203062023131 0ustar  giovannigiovannimodule conj;  % Rationalize denoms of standard quotients by conjugate
              % computation.

% Author: Anthony C. Hearn.

% Modifications by: Eberhard Schruefer.

% Copyright (c) 1992 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*algint !*rationalize !*structure dmode!* kord!* powlis!*);

put('rationalize,'simpfg,'((t (rmsubs)) (nil (rmsubs))));

symbolic smacro procedure subtrf(u,v);
   % Returns u - v for standard forms u and v.
   addf(u,negf v);

symbolic procedure rationalizesq u;
   % Rationalize the standard quotient u.
   begin scalar !*structure,!*sub2,v,x;  % Modified by R. Liska.
      % We need structure off to form rationalized denominator properly
      % in subs2f1.
      % ACH had hoped that the cost of having GCD on here was small,
      % since the consequences can be large (e.g., df(log((sqrt(a^2+x^2)
      % +2*sqrt(sqrt(a^2+x^2)*a+a*x)+a+x)/(sqrt(a^2+x^2) - a + x)),x)).
      % However, limit((sqrt(x^(2/5) +1) - x^(1/3)-1)/x^(1/3),x,0) takes
      % too long.
      if x := get(dmode!*,'rationalizefn) then u := apply1(x,u);
      % We need the following in case we are in sparse_bareiss.
      powlis!* := '(i 2 (nil . t) -1 nil) . powlis!*;
      v := subs2q u;
      powlis!* := cdr powlis!*;
      % We need the subs2 to get rid of surd powers.
      % We also need to check if u has changed from the example
      % df((1/x)**(2/3),x).
      return if domainp denr v then v
              else if (x := rationalizef denr v) neq 1
               then <>
                      subs2q v>>
             else u
   end;

symbolic procedure lowertowerp(u,v);
   % True if v is potentially an algebraic component of a member of v.
   if null u then nil
    else if atom car u or cdar u = v then lowertowerp(cdr u,v)
    else if caar u eq 'expt
       and eqcar(caddar u,'quotient)
       and cadr caddar u = cadr cadr v  % numerator of quotient.
       and fixp caddr caddar u and fixp caddr cadr v
       and cdr divide(caddr caddar u,caddr cadr v) = 0  % denominator.
       and lowertowerp1(cadar u,car v)
     then car u
    else lowertowerp(cdr u,v);

symbolic procedure lowertowerp1(u,v);
   % This procedure decides if u can be an algebraic extension of v.
   % The = case is decidedly heuristic at the moment.
   % We could think of this as a membership test (including =).
   % However, different SQRT representations complicate things.
   (if x>y then t
     else if numberp u and numberp v then not(gcdn(u,v)=1)
     else x=y)
    where x=exprsize u,y=exprsize v;

symbolic procedure exprsize u;
   % Get size of u.  Iterative to avoid excessive recursion.
   begin integer n;
   a: if null u then return n else if atom u then return n+1;
      n := exprsize car u + n;
      u := cdr u;
      go to a
   end;

symbolic procedure rationalizef u;
   % Look for I and sqrts, cbrts, quartics at present.
   % I'm not sure I in the presence of (-1)^(1/4) say is handled
   % properly.
   % It is assumed that any surd powers have been reduced before
   % entering this procedure.
   begin scalar x,y,z;
      x := z := kernels u;
   a: if null x then return 1;
      y := car x;
      if eqcar(y,'expt) and eqcar(caddr y,'quotient)
          and lowertowerp(z,cdr y)
        then nil
       else if y eq 'i or eqcar(y,'expt) and caddr y = '(quotient 1 2)
          or eqcar(y,'sqrt)
        then return conjquadratic(mkmain(u,y),y)
       else if eqcar(y,'expt) and caddr y = '(quotient 1 3)
        then return conjcubic(mkmain(u,y),y)
       else if eqcar(y,'expt) and caddr y = '(quotient 1 4)
        then return conjquartic(mkmain(u,y),y);
      x := cdr x;
      go to a
   end;

symbolic procedure conjquadratic(u,v);
   if ldeg u = 1
      then subtrf(multf(!*k2f v,reorder lc u),reorder red u)
    else errach list(ldeg u,"invalid power in rationalizef");

symbolic procedure conjcubic(u,v);
   begin scalar c1,c2,c3,w;
     if ldeg u = 2 then <>
                            else c3 := reorder red u>>
      else <>;
     w := conj2 v;
     if w eq 'failed then return u;
     v := !*k2f v;
     return addf(multf(exptf(v,2),subtrf(exptf(c2,2),multf(c1,c3))),
                 addf(multf(v,subtrf(multf(w,exptf(c1,2)),
                                     multf(c2,c3))),
                      subtrf(exptf(c3,2),multf(w,multf(c1,c2)))))
  end;

symbolic procedure conj2 u;
%  (if not domainp denr v then errach list("conj2",u)
   (if not domainp denr v then 'failed
     else if denr v neq 1 then multd(!:recip denr v,numr v)
     else numr v)
   where v = simp cadr u;

symbolic procedure conjquartic(u,v);
   begin scalar c1,c3,c4,q1,q2,q3,q4,w;
     if ldeg u = 3
        then <>
                else c4 := reorder red u>>
      else if ldeg u = 1
              then <>;
     w := conj2 v;
     if w eq 'failed then return u;
     v := !*k2f v;
     q1 := subtrf(addf(exptf(c3,3),multf(c1,exptf(c4,2))),
                  multf(w,multf(c3,exptf(c1,2))));
     q2 := negf addf(multf(w,multf(c4,exptf(c1,2))),
                     multf(exptf(c3,2),c4));
     q3 := addf(multf(c3,exptf(c4,2)),
                subtrf(multf(exptf(w,2),exptf(c1,3)),
                       multf(w,multf(c1,exptf(c3,2)))));
     q4 := subtrf(multf(w,multf(multd(2,c1),multf(c3,c4))),exptf(c4,3));
     return addf(multf(exptf(v,3),q1),
                 addf(multf(exptf(v,2),q2),addf(multf(v,q3),q4)))
    end;

symbolic procedure mkmain(u,var);
   % Make kernel var the main variable of u.
   begin scalar kord!*; kord!* := list var; return reorder u end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/poly.red0000644000175000017500000001431011526203062023145 0ustar  giovannigiovannimodule poly;  % Header module and low-level support for poly package.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(poly polrep quotf gcd exptf kernel mksp reord dmode
                 dmodeop rational rnelem gint cpxrn compopr modular
                 facform homog tdconv primfac specfac kronf conj diff
                 polyop decompos interpol subs2q subs3q subs4q horner),
                nil);

flag('(poly),'core_package);

fluid '(!*mcd !*nosq wtl!*);

% switch nosq;


% Particular infix operators used in standard forms.

newtok '((!. !+) add);

newtok '((!. !*) mult);

newtok '((!. !^) to);

newtok '((!. !* !*) to);

newtok '((!. !/) over);

infix .^,.*,.+,./;


% Constructors and selectors for standard forms.

smacro procedure u.+v; % Standard (polynomial) addition constructor.
   u . v;

smacro procedure lc u;   % Leading coefficient of standard form.
   cdar u;

smacro procedure ldeg u; % Leading degree of standard form.
   cdaar u;

smacro procedure lt u;   % Leading term of standard form.
   car u;

smacro procedure u.*v;  % Standard form multiplication constructor.
   u . v;

smacro procedure mvar u; % Main variable of standard form.
   caaar u;

smacro procedure lpow u; % Leading power of standard form.
   caar u;

smacro procedure pdeg u;
   % Returns the degree of the power U.
   cdr u;

smacro procedure red u; % Reductum of standard form.
   cdr u;

smacro procedure tc u;   % Coefficient of standard term.
   cdr u;

smacro procedure tdeg u; % Degree of standard term.
   cdar u;

smacro procedure tpow u; % Power of standard term.
   car u;

smacro procedure tvar u; % Main variable of a standard term.
   caar u;

smacro procedure numr u; % Numerator of standard quotient.
   car u;

smacro procedure denr u; % Denominator of standard quotient.
   cdr u;

smacro procedure u ./ v; % Constructor for standard quotient.
   u . v;

symbolic smacro procedure domainp u; atom u or atom car u;


% Procedures for converting between parts of standard quotients and
% prefix forms.

symbolic procedure !*a2f u;
   % U is an algebraic expression. Value is the equivalent form
   % or an error if conversion is not possible;
   !*q2f simp!* u;

symbolic procedure !*a2k u;
   % U is an algebraic expression. Value is the equivalent kernel
   % or an error if conversion is not possible.
   % Note: earlier versions used SIMP0.
   begin scalar x;
      if kernp(x := simp!* u) then return mvar numr x
       else typerr(if null u then 0 else u,'kernel)
   end;

symbolic procedure !*a2kwoweight u;
   % U is an algebraic expression. Value is the equivalent kernel
   % neglecting any weights, or an error if conversion is not possible.
   (if kernp x then mvar numr x else typerr(u,'kernel))
    where x=simp!* u where !*uncached=t,wtl!*=nil;

symbolic procedure !*d2q u;
   % Converts domain element U into a standard quotient.
   if numberp u
     then if zerop u then nil ./ 1
   %       else if floatp u then mkfloat u ./ 1
           else u ./ 1
   % The following converts a domain rational to a SQ, which may not
   % be desirable.
   % else if eqcar(u,'!:rn!:) and !*mcd then cdr u
    else if !:zerop u then nil ./ 1 else u ./ 1;

symbolic procedure !*ff2a(u,v);
   % Converts ratio of two forms U and V to a prefix form.
   (if wtl!* then prepsq x else mk!*sq x) where x = cancel( u ./ v);

smacro procedure !*f2a u; prepf u;

smacro procedure !*f2q u;
   % U is a standard form, value is a standard quotient.
   u . 1;

smacro procedure !*k2f u;
   % U is a kernel, value is a standard form.
   list((u .** 1) . 1);

symbolic smacro procedure !*kk2f u;
   % U is a non-unique kernel, value is a standard form.
   list(mksp(u,1) . 1);

symbolic smacro procedure !*kk2q u;
   % U is a non-unique kernel, value is a standard quotient.
   list(mksp(u,1) .* 1) ./ 1;

smacro procedure !*k2q u;
   % U is a kernel, value is a standard quotient.
   list((u .** 1) . 1) . 1;

symbolic procedure !*n2f u;
   % U is a number. Value is a standard form.
   if zerop u then nil else u;

smacro procedure !*p2f u;
   % U is a standard power, value is a standard form.
   list(u . 1);

smacro procedure !*p2q u;
   % U is a standard power, value is a standard quotient.
   list(u . 1) . 1;

symbolic procedure !*q2a u;
   % U is a standard quotient, value is an algebraic expression.
   !*q2a1(u,!*nosq);

symbolic procedure !*q2a1(u,v);
   if null v then mk!*sq u else prepsqxx u;

symbolic procedure !*q2f u;
   % U is a standard quotient, value is a standard form.
   if denr u=1 then numr u else typerr(prepsq u,'polynomial);

symbolic procedure !*q2k u;
   % U is a standard quotient, value is a kernel or an error if
   % conversion not possible.
   if kernp u then mvar numr u else typerr(prepsq u,'kernel);

smacro procedure !*t2f u;
   % U is a standard term, value is a standard form.
   list u;

smacro procedure !*t2q u;
   % U is a standard term, value is a standard quotient.
   list u . 1;

symbolic smacro procedure tvar a; caar a;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/horner.red0000644000175000017500000000545011526203062023464 0ustar  giovannigiovannimodule horner; % Convert an expression into a nested Horner product.

% Author: Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp !*div);

symbolic procedure hornersq u;
  if !*div and null dmode!* and numberp denr u and denr u neq 1 then
   <>
   else hornerf numr u . hornerf denr u;

symbolic procedure hornerf u;
  <>;

symbolic procedure hornerf1 u;
  begin scalar x,a,b,c; integer n,m;
   if domainp u then return u;
   if domainp red u then goto q;

      % Identify the pattern
      %      x^n*a + x^m*b + c with n>m
      % and transform it into
      %      x^m(x^(n-m)*a + b) + c
      % calling hornerf1 again for folding x^m with powers of
      % x in c. Also a and b are folded recursively.
      % The term x^n*a may have the form (x^k*f+g)*x^n*h
      % by recursion; in that case a is (x^k*f+g)*h.

   if (x:=mvar u) = mvar red u then
   << n:=ldeg u; a:=hornerf1 lc u; u:=red u; m:=ldeg u;
      b:=hornerf1 lc u; c:=red u >>
   else if sfp mvar u and not domainp lc u and (x:=mvar lc u)=mvar red u
     and (n:=ldeg lc u)>(m:=ldeg red u) then
   << a:=multf(mvar u,lc lc u); u:=red u; b:=hornerf1 lc u; c:=red u >>
   else goto q;
   return hornerf1
       addf(multf(exptf(!*k2f x,m),
                  addf(multf(exptf(!*k2f x,n-m),a),
                       b)), c);
q: return addf(multf(!*p2f lpow u,hornerf1 lc u),hornerf1 red u);
   end;

put('horner,'polyfn,'hornerf);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/tdconv.red0000644000175000017500000002273511526203062023471 0ustar  giovannigiovannimodule tdconv; % Procedures for conversion of internal & external
               % expressions defined with total degree ordering.

% Authors: Shuichi Moritsugu 
%          and Eiichi Goto.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

symbolic procedure setunion(l1,l2);
   % Union of two sets.
      if null l2 then l1
        else if member(car l2,l1) then setunion(l1,cdr l2)
        else setunion(append(l1,car l2 . nil),cdr l2);

symbolic procedure searchtm term;
   % Search for variables in a term.
      if domainp term then nil
        else caar term . searchpl cdr term;

symbolic procedure searchpl poly;
   % Search for variables in a polynomial.
      if domainp poly then nil
        else setunion(searchtm car poly,searchpl cdr poly);

symbolic procedure qsort l;
   % Quick sort of variables with lexicographic ordering.
      begin scalar a,l1,l2,ll;
            if null l then return nil;
            a:=car l; ll:=cdr l;
            loop : if null ll then go to exit;
   % We need ORDOP rather than ORDERP in next line to be consistent
   % with the way that REDUCE orders expressions.
                   if ordop(a,car ll) then l2:=car ll . l2
                                       else l1:=car ll . l1;
                   ll:=cdr ll; go to loop;
            exit : return append(qsort l1,a . qsort l2);
      end;

symbolic procedure mapins(ep,cfl);
   % Insert of exponent into coefficient list.
      if null cfl then nil
        else ((ep . caar cfl) . cdar cfl) . mapins(ep,cdr cfl);

symbolic procedure mkzl n;
   % Making of zero-list (length = n-1).
      if n=1 then nil else 0 . mkzl(n-1);

symbolic procedure sq2sstm(sqtm,vd);
   % Transformation of term from sq to ss.
      begin scalar ep,cf,cfl;
            if caar sqtm=caar vd
              then <>
              else <>;
            return mapins(ep,cfl);
      end;

symbolic procedure sq2sscfpl(cfpl,vd);
   % Transformation of coefficient polynomial from sq to ss.
      if null cfpl then nil
        else if domainp cfpl then (mkzl(cdr vd+1) . cfpl) . nil
        else append(sq2sstm(car cfpl,vd),sq2sscfpl(cdr cfpl,vd));

symbolic procedure sq2sspl(sqpl,vd);
   % Transformation of polynomial from sq to ss.
      if domainp sqpl then sqpl
        else append(sq2sstm(car sqpl,vd),sq2sspl(cdr sqpl,vd));

symbolic procedure sdlist nm;
   % Classification of ss by the degree of main variable.
      begin scalar anslist,partlist,n,rnm;
            rnm:=nm;
            init : n:=caaar rnm; partlist:= car rnm . nil;
            loop : rnm:=cdr rnm;
                   if null rnm
                     then <>;
                   if domainp rnm
                     then <>;
                   if n=caaar rnm
                     then <>
                     else <>;
            exit : return anslist;
      end;

symbolic procedure univsdl2sq(var,sdl);
   % Transformation from univariate ss to sq.
      if domainp sdl then sdl
        else if zerop caaaar sdl then cdaar sdl
        else ((var . caaaar sdl) . cdaar sdl) . univsdl2sq(var,cdr sdl);

symbolic procedure mapdel sdl;
   % Deletion of the exponent of main variable from ss.
      if null sdl then nil
        else (cdaar sdl . cdar sdl) . mapdel cdr sdl;

symbolic procedure mulvsdl2sq(vd,sdl);
   % Transformation from multivariate ss to sq.
      if domainp sdl then sdl
        else if zerop caaaar sdl
               then if domainp cdr sdl and cdr sdl
                      then append(sdl2sq(cdar vd . sub1 cdr vd,
                                         sdlist mapdel car sdl),
                                  cdr sdl)
                      else sdl2sq(cdar vd . sub1 cdr vd,
                                  sdlist mapdel car sdl)
               else ((caar vd . caaaar sdl)
                      . sdl2sq(cdar vd . sub1 cdr vd,
                               sdlist mapdel car sdl))
                    . mulvsdl2sq(vd,cdr sdl);

symbolic procedure sdl2sq(vd,sdl);
   % Transformation from classified ss to sq.
      if cdr vd=1 then univsdl2sq(caar vd,sdl)
                   else mulvsdl2sq(vd,sdl);

symbolic procedure termorder1(term1,term2);
   % Comparison of ordering between two terms (purely lexicographic
   % ordering).
      if null term1 then 0
        else if zerop term1 and zerop term2 then 0
        else if zerop term1 then -1
        else if zerop term2 then 1
        else if car term1car term2 then 1
        else termorder1(cdr term1,cdr term2);

symbolic procedure listsum l;
   % Total degree.
      if null l then 0 else car l+listsum cdr l;

symbolic procedure termorder(term1,term2);
   % Comparison of ordering between two terms (total degree and
   % lexicographic ordering).
      begin scalar s1,s2;
            if null term1 then 0
              else if zerop term1 and zerop term2 then 0
              else if zerop term1 then -1
              else if zerop term2 then 1;
              s1:=listsum term1; s2:=listsum term2;
              return if s1=s2 then termorder1(term1,term2)
                       else if s1>
     where dmode!* = gdmode!*;

symbolic procedure tstpolyarg2(u,kern);
 <>;

symbolic procedure numrdeg(u,kern);
   begin scalar x;
      kern := !*a2k kern;
      if domainp u then return 0
       else if mvar u eq kern then return !*f2a ldeg u;
      x := updkorder kern;
      u := reorder u;
      if not(mvar u eq kern) then u := 0 else u := ldeg u;
      setkorder x;
%     return !*f2a u
      return u
   end;

symbolic procedure lcofeval u;
   begin scalar kern,x,y;
      if null u or null cdr u or not null cddr u
        then rerror(poly,280,
                    "LCOF called with wrong number of arguments");
      kern := !*a2k cadr u;
      u := simp!* car u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
%     if domainp u then return if null u then 0 else mk!*sq (u . 1)
      if domainp u then return if null u then 0 else !*ff2a(u,y)
       else if mvar u eq kern then return !*ff2a(lc u,y);
      x := updkorder kern;
      u := reorder u;
      if mvar u eq kern then u := lc u;
      setkorder x;
      return if null u then 0 else !*ff2a(u,y)
   end;

put('lcof,'psopfn,'lcofeval);

% Note. This is an older definition still used by some packages.

symbolic procedure lcof(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
      if domainp u then return 0
       else if mvar u eq kern then return !*ff2a(lc u,y);
      x := updkorder kern;
      u := reorder u;
      if mvar u eq kern then u := lc u;
      setkorder x;
      return if null u then 0 else !*ff2a(u,y)
   end;

symbolic procedure lpower(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
%     if domainp u then return 1
      if domainp u then return !*ff2a(1,y)
       else if mvar u eq kern then return !*ff2a(lpow u.*1 .+ nil,y);
      x := updkorder kern;
      u := reorder u;
      if mvar u eq kern then u := lpow u.*1 .+ nil else u := 1;
      setkorder x;
      return !*ff2a(u,y)
   end;

symbolic procedure lterm(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
%     if domainp u then return if null u then 0 else u
      if domainp u then return if null u then 0 else !*ff2a(u,y)
       else if mvar u eq kern then return !*ff2a(lt u .+ nil,y);
      x := updkorder kern;
      u := reorder u;
%     if mvar u eq kern then u := lt u .+ nil else u := nil;
      if mvar u eq kern then u := lt u .+ nil;
      setkorder x;
      u := reorder u;
      return !*ff2a(u,y)
   end;

% symbolic procedure !*lterm u; lt u .+ nil;

symbolic procedure mainvar u;
   if domainp(u := numr simp!* u) then 0
    else sfchk(u := mvar u);

symbolic procedure sfchk u; if sfp u then prepf u else u;

symbolic procedure reduct(u,kern);
   begin scalar x,y;
      u := simp!* u;
      y := denr u;
      tstpolyarg(y,u);
      u := numr u;
      kern := !*a2k kern;
%     if domainp u then return !*ff2a(u,y)
      if domainp u then return 0
       else if mvar u eq kern then return !*ff2a(cdr u,y);
      x := updkorder kern;
      u := reorder u;
%     if mvar u eq kern then u := cdr u;
      if mvar u eq kern then u := cdr u else u := nil;
      setkorder x;
      u := reorder u;
      return !*ff2a(u,y)
   end;

symbolic procedure tstpolyarg(y,u);
   null !*ratarg and y neq 1 and typerr(prepsq u,"polynomial");

% symbolic operator deg,lpower,lterm,mainvar,reduct;

flag('(deg lpower lterm mainvar reduct),'opfn); % This way for booting.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/facform.red0000644000175000017500000003612111526203062023603 0ustar  giovannigiovannimodule facform;  % Factored form representation for standard form polys.

% Author: Anthony C. Hearn.

% Modifications by: Francis J. Wright.

% Copyright (c) 1990 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% INTEGER FACTORS?

% SHOULDN'T SYMMETRIC TESTS ETC BE RUN RECURSIVELY?

fluid '(!*exp !*ezgcd !*factor !*force!-prime !*gcd !*ifactor !*nopowers
        !*kernreverse !*limitedfactors !*sqfree !*trfac current!-modulus
        dmode!* m!-image!-variable ncmp!*);

switch limitedfactors,nopowers;

% switch sqfree;

put('sqfree,'simpfg,'((t (rmsubs) (setq !*exp nil))
                      (nil (rmsubs) (setq !*exp t))));

comment In this module, we consider the manipulation of factored forms.
    These have the structure

        . 

        where the monomial is a standard form (with numerator and
        denominator satisfying the KERNLP test) and a form-power is a
        dotted pair whose car is a standard form and cdr an integer>0.
        We have thus represented the form as a product of a monomial
        quotient and powers of non-monomial factors;

symbolic procedure fac!-merge(u,v);
   % Returns the merge of the factored forms U and V.
   multf(car u,car v) . append(cdr u,cdr v);

symbolic procedure factorize u;
   % Factorize the polynomial u, returning the factors found.
   (begin scalar x,y;
      x := simp!* u;
      y := denr x;
      if not domainp y then typerr(u,"polynomial");
      u := numr x;
      if u = 1 then return
         {'list, if !*nopowers then 1 else {'list,1,1}} % FJW
       else if fixp u then !*ifactor := t;   % Factor an integer.
      if !*force!-prime and not primep !*force!-prime
        then typerr(!*force!-prime,"prime");
      u := if dmode!* and not(dmode!* memq '(!:rd!: !:cr!:))
         then if get(dmode!*,'factorfn)
                 then begin scalar !*factor;
                        !*factor := t;
                         return fctrf u
                      end
           else rerror(poly,14,
                       list("Factorization not supported over domain",
                       get(dmode!*,'dname)))
       else fctrf u;
      return facform2list(u,y)
   end) where !*ifactor = !*ifactor;

symbolic procedure facform2list(x,y);
   % x is a factored form.
   % y is a possible numerical (domain) denominator.
   begin scalar factor!-count,z;
      if null car x and null cdr x then return list 'list
      % car x is now expected to be a number.
       else if null !*nopowers then z := facform2list2 x
        else <<
         z:= (0 . car x) . nil;
         x := reversip!* cdr x;  % This puts factors in better order.
         factor!-count:=0;
         for each fff in x do
         for i:=1:cdr fff do
            z := ((factor!-count:=factor!-count+1) .
                    mk!*sq(car fff ./ 1)) . z;
         z := multiple!-result(z,nil);
         if atom z then typerr(z,"factor form")  % old style input.
          else if numberp cadr z and cadr z<0 and cddr z
           then z := car z .
                           (- cadr z) . mk!*sq negsq simp caddr z
                           . cdddr z;
         % make numerical coefficient positive.
         z := cdr z;
         if car z = 1 then z := cdr z
          else if not fixp car z then z := prepd car z . cdr z
          else if !*ifactor
              then z := append(pairlist2list reversip zfactor car z,
                            cdr z)>>;
      if y neq 1 then z := list('recip,prepd y) . z;
      return 'list . z
  end;

symbolic procedure facform2list2 u;
   begin scalar bool,x;
      if !:minusp(x := car u) then <>;
      u := cdr u;
      if x neq 1
        then if !*ifactor and fixp x
               then u := append(reversip zfactor x,u)
              else u := (x . 1) . u;
      % Adjust for negative sign.
      x := nil;
      for each j in u do
         if bool and not evenp cdr j
           then <>
          else x := j . x;
      % Convert terms to list form.
      u := nil;
      for each j in x do
         if fixp car j then u := {'list,car j,cdr j} . u
          else u := {'list,mk!*sq(car j ./ 1),cdr j} . u;
      return if bool then '(list -1 1) . u else u
   end;

symbolic procedure old_factorize u; factorize u where !*nopowers=t;

flag('(factorize old_factorize),'opfn);

symbolic procedure pairlist2list u;
   for each x in u conc nlist(car x,cdr x);

symbolic procedure fctrf u;
   % U is a standard form. Value is a factored form.
   % The function FACTORF is an assumed entry point to a more complete
   % factorization module.  It returns a form power list.
   (begin scalar !*ezgcd,!*gcd,denom,x,y;
      if domainp u then return list u
       else if ncmp!* and not noncomfp u then ncmp!* := nil;
      !*gcd := t;
      if null !*limitedfactors and null dmode!* then !*ezgcd := t;
      if null !*mcd
        then rerror(poly,15,"Factorization invalid with MCD off")
       else if null !*exp
        then <>;
      % Convert rationals to integers for factorization.
      if dmode!* eq '!:rn!:
        then <>
                else denom := 1>>;
      % Check for homogeneous polynomials.  This can't be done with
      % current code though if non-commuting objects occur.
      if null ncmp!*
        then <>>>;
      u := fctrf1 u;
      if denom
        then <>;
      x := comfac u;
      u := quotf(u,comfac!-to!-poly x);
      y := fctrf1 cdr x;   % factor the content.
      if car x then y := car y . (!*k2f caar x . cdar x) . cdr y;
      if z and (z neq 1) then y := multd(z,car y) . cdr y;
      if domainp u then return multf(u,car y) . cdr y
       else if minusf u
        then <>;
      return fac!-merge(factor!-prim!-f u,y)
   end;

symbolic procedure factorize!-form!-recursion u;
   fctrf1 u;

symbolic procedure factor!-prim!-f u;
   % U is a non-trivial form which is primitive in all its variables
   % and has a positive leading numerical coefficient. Result is a
   % form power list.
   begin scalar v,w,x,y;
      if ncmp!* then return list(1,u . 1);
      if dmode!* and (x := get(dmode!*,'sqfrfactorfn))
        then if !*factor then v := apply1(x,u) else v := list(1,u . 1)
       else if flagp(dmode!*,'field) and ((w := lnc u) neq 1)
        then v := w . sqfrf multd(!:recip w,u)
       else if (w := get(dmode!*,'units)) and (w := assoc(y := lnc u,w))
        then v := y . sqfrf multd(cdr w,u)
       else v := 1 . sqfrf u;
      if x and (x eq get(dmode!*,'factorfn))
        then return v;   % No point in re-factorizing.
      w := list car v;
      for each x in cdr v
         do w := fac!-merge(factor!-prim!-sqfree!-f x,w);
      return w
   end;

symbolic procedure factor!-prim!-sqfree!-f u;
   % U is of the form  . . Result is a factored
   % form.
   % Modified to work properly in rounded (real or complex),
   % rational and complex modes. SLK.
   begin scalar x,y,!*msg,r;
      r := !*rounded;
      % It's probable that lc numr u and denr u will always be 1 if
      % u is univariate.
      if r and univariatep numr u and lc numr u=1 and denr u=1
        then return unifactor u
       else if r or !*complex or !*rational then
         <>;
      if null !*limitedfactors
        then <>;
      v := comfac u;   % Since new order may reveal more factors.
      u := quotf1(u,cdr v);
      if domainp u then errach list("Improper factors in factorf");
      % The example on rounded; solve(df(e^x/(e^(2*x)+1)^1.5,x),{x});
      % shows car v can be non-zero.
      w := car v;
      v := fctrf1 cdr v;
      if w then v := car v . (!*k2f car w . cdr w) . cdr v;
      m!-image!-variable := mvar u;
      u :=
        distribute!.multiplicity(factorize!-primitive!-polynomial u,1);
      setkorder old!-korder;
      if sign then u := (negf caar u . cdar u) . cdr u;
      u := fac!-merge(v,1 . u);
      return car u . for each w in cdr u collect (reorder car w . cdr w)
   end) where current!-modulus = current!-modulus;

symbolic procedure factor!-prim!-sqfree!-f!-1(u,n);
   (exptf(car x,n) . for each j in cdr x collect (j . n))
      where x = prsqfrfacf u;

symbolic procedure sqfrf u;
   % U is a non-trivial form which is primitive in all its variables
   % and has an overall numerical coefficient which should be a unit.
   % SQFRF performs square free factorization on U and returns a
   % form power list.
   % Modified to work properly in rounded (real or complex) modes. SLK.
   begin integer n; scalar !*gcd,units,v,w,x,y,z,!*msg,r;
      !*gcd := t;
      if (r := !*rounded) then
         <>;
      n := 1;
      x := mvar u;
      % With ezgcd off, some sqrts can take a long, long time.
      v := gcdf(u,diff(u,x)) where !*ezgcd = t;
      u := quotf(u,v);
      % If domain is a field, or has non-trivial units, v can have a
      % spurious numerical factor.
      if flagp(dmode!*,'field) and ((y := lnc u) neq 1)
        then <>
      % The following check for units can result in the loss of such
      % a unit.
%      else if (units := get(dmode!*,'units))
%         and (w := assoc(y:= lnc u,units))
%       then <>;
      ;
      while degr(v,x)>0 do
       <>;
         if r then
            <>;
      if v neq 1 and assoc(v,units) then v := 1;
      if v neq 1 then if n=1 then u := multf(v,u)
       else if (w := rassoc(1,z)) then rplaca(w,multf(v,car w))
       else if null z and ((w := rootxf(v,n)) neq 'failed)
        then u := multf(w,u)
       else if not domainp v then z := aconc(z,v . 1)
       else errach {"sqfrf failure",u,n,z};
      return (u . n) . z
   end;

symbolic procedure square_free u;
   'list . for each v in sqfrf !*q2f simp!* u
              collect {'list,mk!*sq(car v . 1),cdr v};

flag('(square_free),'opfn);

symbolic procedure diff(u,v);
   % A polynomial differentation routine which does not check
   % indeterminate dependencies.
   if domainp u then nil
    else addf(addf(multpf(lpow u,diff(lc u,v)),
        multf(lc u,diffp1(lpow u,v))),
          diff(red u,v));

symbolic procedure diffp1(u,v);
   if not( car u eq v) then nil
    else if cdr u=1 then 1
    else multd(cdr u,!*p2f(car u .** (cdr u-1)));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/kronf.red0000644000175000017500000001341511526203062023306 0ustar  giovannigiovannimodule kronf;   % Kronecker factorization of univariate forms.

% Author: Anthony C. Hearn.

% Based on code first written by Mary Ann Moore and Arthur C. Norman.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% exports linfacf,quadfacf;

% imports zfactor;

% Note that only linear and quadratic factors are found here.

symbolic procedure linfacf u; trykrf(u,'(0 1));

symbolic procedure quadfacf u; trykrf(u,'(-1 0 1));

symbolic procedure trykrf(u,points);
   % Look for factor of u by evaluation at points and interpolation.
   % Return (fac . cofac), with fac = nil if none found,
   % and cofac = nil if nothing worthwhile is left.
   begin scalar attempt,mv,values;
      if null u then return nil . nil
       else if length points > ldeg u then return nil . u;
      % Degree is too small to find factors.
      mv := mvar u;
      values := for each j in points collect subuf(j,u);
      if 0 member values
        then <>;
      values := for each j in values collect dfactors j;
      values := for each j in values
                   collect append(j,for each k in j collect !:minus k);
      attempt := search4facf(u,values,nil);
      if null attempt then attempt := nil . u;
      return attempt
   end;

symbolic procedure subuf(u,v);
   % Substitute integer u for main variable in univariate polynomial v.
   % Return an integer or a structured domain element.
   begin scalar z;
      if u=0 then u := nil;
      z := nil;
      while v do
         if domainp v then <>
          else <>;
      return if null z then 0 else z
   end;

symbolic procedure adddm!*(u,v);
   % Adds two domain elements u and v, returning a standard form.
   if null u then v else if null v then u else adddm(u,v);

symbolic procedure multdm!*(u,v);
   % Multiplies two domain elements u and v, returning a standard form.
   if null u or null v then nil else multdm(u,v);

symbolic procedure dfactors n;
   % Produces a list of all (positive) factors of the domain element n.
   begin scalar x;
      if n=0 then return list 0
       else if n=1 then return list 1
       else if !:minusp n then n := !:minus n;
      return if not atom n
        then if (x := get(car n,'factorfn))
               then combinationtimes apply1(x,n)
              else list n
       else combinationtimes zfactor n
   end;

symbolic procedure combinationtimes fl;
   if null fl then list 1
    else begin scalar n,c,res,pr;
        n := caar fl;
        c := cdar fl;
        pr := combinationtimes cdr fl;
        while c>=0 do <>;
        return res
    end;

symbolic procedure putin(n,l,w);
   if null l then w else putin(n,cdr l,(n*car l) . w);

symbolic procedure search4facf(u,values,cv);
   % combinatorial search for factors. cv gets current value set.
   if null values then tryfactorf(u,cv)
    else begin scalar q,w;
      w := car values;
 loop: if null w then return nil;   % no factor found
      q := search4facf(u,cdr values,car w . cv);
      if null q then <>;
      return q
    end;

symbolic procedure tryfactorf(u,cv);
   % Tests if cv represents a factor of u.
   % For the time being, does not work on structured domain elements.
   begin scalar w;
      if null atomlis cv then return nil;
      if null cddr cv then w := linethroughf(cadr cv,car cv,mvar u)
       else w := quadthroughf(caddr cv,cadr cv,car cv,mvar u);
      if w eq 'failed or null (u := quotf(u,w)) then return nil
       else return w . u
   end;

symbolic procedure linethroughf(y0,y1,mv);
   begin scalar x;
      x := y1-y0;
      if x=0 then return 'failed
       else if x<0 then <>;
       return if y0 = 0 or gcdn(x,y0) neq 1 then 'failed
               else (mv .** 1) .* x .+ y0
   end;

symbolic procedure quadthroughf(ym1,y0,y1,mv);
   begin scalar x,y,z;
      x := divide(ym1+y1,2);
      if cdr x=0 then x := car x-y0 else return 'failed;
      if x=0 then return 'failed;
      z := y0;
      y := divide(y1-ym1,2);
      if cdr y=0 then y := car y else return 'failed;
      if gcdn(x,gcdn(y,z)) neq 1 then return 'failed;
      if x<0 then <>;
      if z=0 then return 'failed
       else if y=0 then return ((mv .** 2) .* x) .+ z
       else return ((mv .** 2) .* x) .+ (((mv .** 1) .* y) .+ z)
   end;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/dmode.red0000644000175000017500000002076611526203062023266 0ustar  giovannigiovannimodule dmode; % Functions for defining and using poly domain modes.

% Author: Anthony C. Hearn.
% Modifications by: Stanley L. Kameny.

% Copyright (c) 1992 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment
   *** Description of Definition Requirements for Domain arithmetics ***

Syntactically, such elements have the following form:

:=NIL|integer|

 ::=
        (.),

where NIL represents the domain element zero.

To introduce a new domain, we need to define:

1) A conversion function from integer to the given mode, stored under
   the attribute I2D.

2) A conversion function from new mode to or from every other mode.

3) Particular instances of the binary operations +,- and * for this
   mode.

4) Particular instances of ZEROP, ONEP and MINUSP for this mode.
   Although ONEP could be defined in terms of ZEROP, we believe it is
   more efficient to have both functions (though this has not been
   thoroughly tested).

5) If domain is a field, a quotient must be defined.  If domain is a
   ring, a gcd and divide must be defined, and also a quotient
   function which returns NIL if the division fails.

6) A printing function for this mode that can print the object in a
   linear form. The printing function is associated with the attribute
   PRIFN.  This printing function should enclose the printed expression
   in parentheses if its top level operator has a precedence greater
   than +.

7) A function to convert structure to an appropriate prefix form.

8) A reading function for this mode.

9) A DNAME property for the tag, and a TAG property for the DNAME

10) Optionally, an exponentiation function. If this is not provided,
    repeated squaring is used (cf !:expt in dmodeop.red)

To facilitate this, all such modes should be listed in the global
variable DOMAINLIST!*.

The following rules should also be followed when introducing new
domains:

Some modes, such as modular arithmetic, require that integers be
converted to domain elements when input or addition or multiplication
of such objects occurs.  Such modes should be flagged "convert".

A domain which holds mutable internal state should be flagged
"resimplify" (no Reduce domains are currently so flagged) which means
that attempts to simplify domain elements will actually do so, rather
than just thinking "domain elements are always simplified".

In ALL cases it is assumed that any domain element that tests true to
the zero test can be converted into an explicit 0 (represented by NIL),
and any that tests true to the onep test can be converted into an
explicit 1.  If the domain allows for the conversion of other elements
into equivalent integers, a function under the optional attribute
INTEQUIVFN may also be defined to effect this conversion.

The result of an arithmetic (as opposed to a boolean) operation on
structured domain elements with the same tag must be another structured
domain element with the same tag.  In particular, a domain zero must be
returned as a tagged zero in that domain.

In some cases, it is possible to map functions on domain elements to
domain elements.  To provide for this capability in the complete
system, one can give such functions the domain tag as an indicator.
The results of this evaluation must be a tagged domain element (or an
integer?), but not necessarily an element from the same domain, or the
evaluation should abort with an error.  The error number associated
with this should be in the range 100-150;

fluid '(!*complex dmode!* gdmode!*);

global '(domainlist!*);

symbolic procedure initdmode u;
   % Checks that U is a valid domain mode, and sets up appropriate
   % interfaces to the system.
   begin
      dmodechk u;
      put(u,'simpfg,list(list(t,list('setdmode,mkquote u,t)),
                         list(nil,list('setdmode,mkquote u,nil))))
   end;

% switch complex!-rational,complex!-rounded;

symbolic procedure setdmode(u,bool);
   % Sets polynomial domain mode.  If bool is NIL, integers are used,
   % or in the case of complex, set to the lower domain.
   % Otherwise mode is set to u, or derived from it.
   begin scalar x;
      if (x := get(u,'dname)) then u := x;  % Allow a tag as argument.
      if u eq 'complex!-rational then
        <>
        else if u eq 'complex!-rounded then
          <>;
      if null get(u,'tag)
        then rerror(poly,5,
                   list("Domain mode error:",u,"is not a domain mode"));
      if x := get(u,'package!-name) then load!-package x;
      return if u eq 'complex or !*complex then setcmpxmode(u,bool)
              else setdmode1(u,bool)
   end;

symbolic procedure setdmode1(u,bool);
   begin scalar x,y,z;
      x := get(u,'tag);
      y := dmode!*;
      if null bool
        then return if null y then nil
                     else if u eq (y := get(y,'dname))
                      then <>
                     else offmoderr(u,y)
        else <>;
      % Now make sure there are no other domain switches left on.
      if not (z := get(x,'realtype)) then z := x;
      for each j in domainlist!* do
         if j neq '!:gi!: and not(j eq z)
           then set(intern compress
                       append(explode '!*,explode get(j,'dname)),
                    nil);
      rmsubs();
      y := get(y,'dname);
      if y then lprim list("Domain mode",y,"changed to",u);
      gdmode!* := dmode!* := x;
      return y
   end;

symbolic procedure offmoderr(u,y);
   lpriw("***",list("Failed attempt to turn off",u,"when",y,"is on"));

symbolic procedure dmodechk u;
   % Checks to see if U has complete specification for a domain mode.
   begin scalar z;
      if not(z := get(u,'tag))
        then rerror(poly,6,list("Domain mode error:","No tag for",u))
       else if not(get(z,'dname) eq u)
        then rerror(poly,7,list("Domain mode error:",
                                 "Inconsistent or missing DNAME for",z))
       else if not(z memq domainlist!*)
        then rerror(poly,8,list("Domain mode error:",
                                 z,"not on domain list"));
      u := z;
      for each x in domainlist!*
        do if u=x then nil
            else <>;
%            then rederr list("Domain mode error:",
%                          "No conversion defined between",U,"and",X);
      z := '(plus difference times quotient i2d prepfn prifn
             minusp onep zerop);
      if not flagp(u,'field) then z := 'divide . 'gcd . z;
      for each x in z do if not get(u,x)
             then rerror(poly,9,list("Domain mode error:",
                                      x,"is not defined for",u))
   end;

symbolic procedure dmoderr(u,v);
   rerror(poly,10,list("Conversion between",get(u,'dname),
                       "and",get(v,'dname),"not defined"));

symbolic procedure mkdmoderr(u,v);
   list('lambda,'(!*x!*),list('dmoderr,mkquote u,mkquote v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/interpol.red0000644000175000017500000000522611526203062024024 0ustar  giovannigiovannimodule interpol; % polynomial interpolation (Aitken & Neville).

% Author: Herbert Melenk .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure interpol(fc,x,pts);
   % find a polynomial f(x) such that holds:
   %   f(part(pts,i)) = part(fc,i)  for all i <= lenth pts.
   % The Aitken-Neville schema is used; it is stable for
   % symbolic and numeric values.
 begin scalar d,q,s,p1,p2,x1,x2,f1,f2,fnew;
    if not eqcar(fc,'list) or not eqcar(pts,'list)
       or not(length fc=length pts)
      then rerror(poly,19,"Illegal parameters for interpol");
   s:=for each p in pair(cdr fc,cdr pts) collect
       simp car p . simp cdr p . simp cdr p;
   x:= simp x;
       % outer loop as long as there is more than 1 element.
   while cdr s do
   <>;
      s:=reversip q;
   >>;
   return prepsq caar s;
 end;

% We can't do following for bootstrapping reasons.

% symbolic operator interpol;

flag('(interpol),'opfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/primfac.red0000644000175000017500000001506311526203062023611 0ustar  giovannigiovannimodule primfac;   % Primitive square free polynomial factorization.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*intfac !*surds dmode!* intvar kernlist!* knowndiscrimsign);

symbolic procedure prsqfrfacf u;
   % U is a non-trivial form which is primitive in all its variables,
   % is square free, and has a positive leading numerical coefficient.
   % Result is a list of factors of u, the first a monomial.
   % We order kernels in increasing powers unless kernlist!* has a
   % non-NIL value in which case we use that order (needed by SOLVE).
   % NOTE: For the time being, we bypass this code if the coefficient
   % domain is other than integer.
   begin scalar bool,knowndiscrimsign,v,w;
      if dmode!* then return list(1,u);
      v := if intvar then list intvar           % Integration in effect.
            else if kernlist!* then kernlist!*
            else reverse kernord!-sort powers u;
      % order highest power first.
      % Note: if this procedure ever fails, the korder is then incorrect.
      w := setkorder v;
      u := reorder u;
      if minusf u then <>;
      u := factor!-ordered!-sqfree!-prim!-f u;
      setkorder w;
%     w := resimp car u;
      u := for each x in u collect
              begin
                 v := reorder x;
                 if bool and minusf v
                   then <>;
                 return v
              end;
      if bool then u := negf car u . cdr u;
      % We couldn't fold the minus sign.
      return u
   end;

symbolic procedure factor!-ordered!-sqfree!-prim!-f pol;
   % U is a non-trivial form which is primitive in all its variables,
   % is square free, has a positive leading numerical coefficient,
   % and has a main variable of lowest degree in the form.
   % Result is a list of factors of u, the first a monomial.
   begin integer n; scalar q,res,w;
      if ldeg pol = 1 then return factor!-coeffs pol
       else if univariatep pol
        then <>;
               while car(q := quadfacf pol) do
                <>>>;
      if null pol then return 1 . res
       else if length(w := special!-case!-factor pol)>2
        then <>
       else if ldeg pol < 4 or (n := degreegcd pol) = 1
          then return 1 . pol . res;
      w := cdr sort(dfactors n,function lessp);
      % 1 is always first factor.
      knowndiscrimsign := 'negative;
   a: if null w then <>
       else if length (q := factor!-ordered!-sqfree!-prim!-f
                               downpower(pol,car w))>2
        then <>;
      w := cdr w;
      go to a
   end;

symbolic procedure downpower(pol,n);
    % Reduce the power of each term in pol wrt main variable by factor
    % n.
   downpower1(pol,mvar pol,n);

symbolic procedure downpower1(pol,mv,n);
   if domainp pol or not(mvar pol eq mv) then pol
    else (mv .** (ldeg pol/n)) .* lc pol .+ downpower1(red pol,mv,n);

symbolic procedure uppower(pol,var,n);
    % Raise the power of each term in pol wrt var by factor n.
   if mvar pol = var then uppower1(pol,var,n) else uppower2(pol,var,n);

symbolic procedure uppower1(pol,mv,n);
   if domainp pol or not(mvar pol eq mv) then pol
    else (mv .** (ldeg pol*n)) .* lc pol .+ uppower1(red pol,mv,n);

symbolic procedure uppower2(pol,var,n);
   if domainp pol then pol
    else if mvar pol = var
     then (mvar pol .** (ldeg pol*n)) .* lc pol
                .+ uppower2(red pol,var,n)
    else lpow pol .* uppower2(lc pol,var,n) .+ uppower2(red pol,var,n);

symbolic procedure univariatep pol;
   % True if pol is not a domain element and is univariate with respect
   % to its main variable.
   not domainp pol and univariatep1(pol,mvar pol);

symbolic procedure univariatep1(pol,mv);
   domainp pol
      or mvar pol eq mv and domainp lc pol and univariatep1(red pol,mv);

symbolic procedure special!-case!-factor pol;
   % When integrator calls this, it doesn't want to use the quadratic
   % code.
%  (if degree = 2 and (null !*surds or clogflag) then quadraticf pol
   (if degree = 2 and null !*intfac then quadraticf pol
     else if degree= 3 then cubicf pol
       else if degree = 4 then quarticf pol
       else list(1,pol))
    where degree = ldeg pol;

symbolic procedure degreegcd pol;
   % Returns gcd of degrees of pol with respect to main variable.
   begin integer n; scalar mv;
      mv := mvar pol;
      n := ldeg pol;
      while n>1 and not domainp(pol := red pol) and mvar pol eq mv
         do n := gcdn(n,ldeg pol);
      return n
   end;

symbolic procedure factor!-coeffs u;
   % factor the primitive, square free polynomial U wrt main variable.
   % dummy for now.
   list(1,u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/poly/dmodeop.red0000644000175000017500000002144611526203062023621 0ustar  giovannigiovannimodule dmodeop;  % Generic operators for domain arithmetic.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% internal dividef;

fluid '(!*noequiv);    % !*convert

% switch convert;

% !*convert := t;

symbolic procedure !:difference(u,v);
   if null u then !:minus v else if null v then u
    else if u=v then nil
    else if atom u and atom v then u-v
    else dcombine(u,v,'difference);

symbolic procedure !:divide(u,v);
   % Returns a dotted pair of quotient and remainder of non-invertable
   % domain element U divided by non-invertable domain element V.
   % Note that a zero is returned as NIL.
   if null u then nil . nil
    else if null v then rerror(poly,202,"zero divisor")
    else if atom u and atom v then dividef(u,v)
    else dcombine(u,v,'divide);

symbolic procedure dividef(m,n);
   ((if car x=0 then nil else car x) . if cdr x=0 then nil else cdr x)
   where x=divide(m,n);

symbolic procedure !:expt(u,n);
   % Raises domain element U to integer power N.  Value is a domain
   % element.
   if null u then if n=0 then rerror(poly,11,"0/0 formed") else nil
    else if n=0 then 1
    else if n=1 then u
    else if u=1 then 1
    else if n<0
     then !:recip !:expt(if not fieldp u then mkratnum u else u,-n)
    else if atom u then u**n
%    Moved into the exponentiation method of !:mod!:
%    else if car u eq '!:mod!:
%     then (lambda x; if x=0 then nil else if x=1 then 1 else car u . x)
%          general!-modular!-expt(cdr u,n)
    else begin scalar v,w,x;
      if x := get(car u,'expt)
         then return apply2(x,u,n);
         % There was a special exponentiation method.
      v := apply1(get(car u,'i2d),1);   % unit element.
      x := get(car u,'times);
   a: w := n;
      if w-2*(n := n/2) neq 0 then v := apply2(x,u,v);
      if n=0 then return v;
      u := apply2(x,u,u);
      go to a
   end;

symbolic procedure !:gcd(u,v);
  if null u then v else if null v then u
   else if atom u and atom v then gcdn(u,v)
   else if fieldp u or fieldp v then 1
   else dcombine(u,v,'gcd);

% symbolic procedure !:i2d u;

symbolic procedure !:minus u;
   % U is a domain element. Value is -U.
   if null u then nil
    else if atom u then -u
    else (if x then apply1(x,u) else dcombine(u,-1,'times))
         where x=get(car u,'minus);

symbolic procedure !:minusp u;
   if atom u then minusp u else apply1(get(car u,'minusp),u);

symbolic procedure !:onep u;
   if atom u then onep u else apply1(get(car u,'onep),u);

symbolic procedure !:plus(u,v);
   if null u then v else if null v then u
    else if atom u and atom v
     then (if w=0 then nil else w) where w=u+v
    else dcombine(u,v,'plus);

% symbolic procedure !:prep u;

% symbolic procedure !:print u;

symbolic procedure !:quotient(u,v);
   if null u or u=0 then nil
    else if null v or v=0 then rerror(poly,12,"Zero divisor")
    else if atom u and atom v
     % We might also check that remainder is zero in integer case.
     then if null dmode!* then u/v else
        (if atom recipv then u*recipv else dcombine(u,recipv,'times))
                where recipv=!:recip v
    else dcombine(u,v,'quotient);

symbolic procedure !:recip u;
   % U is an invertable domain element. Value is 1/U.
   begin
      if numberp u
        then if abs u=1 then return u
       else if null dmode!* or dmode!* memq '(!:rd!: !:cr!:)
          then return !:rn2rd mkrn(1,u)
       else u := apply1(get(dmode!*,'i2d),u);
      return (if not atom x and car x='!:rn!: then !:rn2rd x else x)
         where x=dcombine(1,u,'quotient)
   end;

symbolic procedure !:rn2rd x;
   % Convert rn to rd in dmodes rd and cr if roundall is on.
   if !*roundall and !*rounded then !*rn2rd x else x;

symbolic procedure !:times(u,v);
   % We assume neither u nor v can be 0.
   if null u or null v then nil
    else if atom u and atom v then u*v
    else dcombine(u,v,'times);

symbolic procedure !:zerop u;
   if null u or u=0 then t
    else if atom u then nil
    else apply1(get(car u,'zerop),u);

symbolic procedure fieldp u;
   % U is a domain element. Value is T if U is invertable, NIL
   % otherwise.
   not atom u and flagp(car u,'field);

symbolic procedure gettransferfn(u,v);
   % This may be unnecessary.  If dmodechk has been called, then all
   % transfer functions should be defined.
   (if x then x else dmoderr(u,v)) where x=get(u,v);

symbolic procedure dcombine(u,v,fn);
   % U and V are domain elements, but not both atoms (integers).
   % FN is a binary function on domain elements;
   % Value is the domain element representing FN(U,V)
   % or pair of domain elements representing divide(u,v).
   < u but may first have to convert u.
            <>;

symbolic procedure int!-equiv!-chk u;
   % U is a domain element. If U can be converted to 0, result is NIL,
   % if U can be converted to 1, result is 1,
   % if U is a rational or a complex rational and can be converted to
   % an integer, result is that integer,
   % if *convert is on and U can be converted to an integer, result
   % is that integer. Otherwise, U is returned.
   % In most cases, U will be structured.
   if !*noequiv then u
    else begin scalar x;
           if atom u then return if u=0 then nil else u
            else if apply1(get(car u,'zerop),u) then return nil
            else if apply1(get(car u,'onep),u) then return 1
%           else if null !*convert then return u
            else if (x := get(car u,'intequivfn)) and (x := apply1(x,u))
             then return if x=0 then nil else x
            else return u
      end;

% symbolic procedure minuschk u;
%    if eqcar(u,'minus)
%       and (numberp cadr u
%          or not atom cadr u and idp caadr u and get(caadr u,'dname))
%      then !:minus cadr u
%     else u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/0000755000175000017500000000000011722677366021440 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cali/mo.red0000644000175000017500000002770611526203062022537 0ustar  giovannigiovannimodule mo;

COMMENT

               ##################
               ##              ##
               ##  MONOMIALS   ##
               ##              ##
               ##################



Monomials are of the form x^a*e_i with a multipower x^a and a module
component e_i. They belong either to the base ring R (i=0) or to a
free module R^c (c >= i > 0).

All computations are performed with respect to a "current module"
over a "current ring" (=cali!=basering).

To each module component e_i of the current module we assign a
"column degree", i.e. a monomial representing a certain multidegree
of the basis vector e_i. See the module dpmat for more details.
The column degrees of the current module are stored in the assoc.
list cali!=degrees.


Informal syntax :

   ::= ( . )
  < .. part> ::= list of integer

Here exponent lists may have varying length since trailing zeroes are
assumed to be omitted. The zero component of  contains the
module component. It correspond to the phantom var. name cali!=mk.

END COMMENT; 

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% ----------- manipulations of the degree part --------------------

symbolic procedure mo!=sprod(a,b);
% Scalar product of integer lists a and b .
    if not a or not b then 0
    else (car a)#*(car b) #+ mo!=sprod(cdr a,cdr b);

symbolic procedure mo!=deglist(a);
% a is an exponent list. Returns the degree list of a.
  if null a then
      for each x in ring_degrees cali!=basering collect 0
  else (mo!=sum(
      for each x in ring_degrees cali!=basering collect
                mo!=sprod(cdr a,x),
      if b then cddr b else nil)
      where b = assoc(car a,cali!=degrees));

symbolic procedure mo_neworder m;
% Deletes trailing zeroes and returns m with new degree part.
    (m1 . mo!=deglist m1) where m1 =mo!=shorten car m;

symbolic procedure mo_degneworder l;
% New degree parts in the degree list l.
  for each x in l collect car x . mo_neworder cdr x;

symbolic procedure mo!=shorten m;
    begin scalar m1;
    m1:=reverse m;
    while m1 and eqn(car m1,0) do m1:=cdr m1;
    return reversip m1;
    end;

% ------------- comparisions of monomials -----------------

symbolic procedure mo_zero;  nil . mo!=deglist nil;
% Returns the unit monomial x^0.

symbolic procedure mo_zero!? u; mo!=zero car u;

symbolic procedure mo!=zero u;
    null u or car u = 0 and mo!=zero cdr u;

symbolic procedure mo_equal!?(m1,m2);
% Test whether m1 = m2.
    equal(mo!=shorten car m1,mo!=shorten car m2);

symbolic procedure mo_divides!?(m1,m2);
% m1,m2:monomial. true :<=> m1 divides m2
    mo!=modiv1(car m1,car m2);

symbolic procedure mo!=modiv1(e1,e2);
    if not e1 then t else if not e2 then nil
    else leq(car e1,car e2) and mo!=modiv1(cdr e1, cdr e2);

symbolic procedure mo_compare(m1,m2);
% compare (m1,m2) . m1 < m2 => -1 | m1 = m2 => 0 | m1 > m2 => +1
   begin scalar x;
        x:=mo!=degcomp(cdr m1,cdr m2);
        if x=0 then
            x:=if equal(ring_tag cali!=basering,'revlex) then
                       mo!=revlexcomp(car m1, car m2)
               else mo!=lexcomp(car m1,car m2);
        return x;
   end;

symbolic procedure mo_dlexcomp(a,b); mo!=lexcomp(car a,car b)=1;
% Descending lexicographic order, first by mo_comp.

symbolic procedure mo!=degcomp(d1,d2);
    if null d1 then 0
    else if car d1 = car d2 then mo!=degcomp(cdr d1,cdr d2)
    else if car d1 #< car d2 then -1
    else 1;

symbolic procedure mo!=revlexcomp(e1,e2);
    if length e1 #> length e2 then -1
    else if length e2 #> length e1 then 1
    else - mo!=degcomp(reverse e1,reverse e2);

symbolic procedure mo!=lexcomp(e1,e2);
    if null e1 then
        if null e2 then 0 else mo!=lexcomp('(0),e2)
    else if null e2 then mo!=lexcomp(e1,'(0))
    else if car e1 = car e2 then mo!=lexcomp(cdr e1,cdr e2)
    else if car e1 #> car e2 then 1
    else -1;

% ---------- manipulation of the module component --------

symbolic procedure mo_comp v;
% Retuns the module component of v.
    if null car v then 0 else caar v;

symbolic procedure mo_from_ei i;
% Make e_i.
    if i=0 then mo_zero() else (x . mo!=deglist x) where x =list(i);

symbolic procedure mo_vdivides!?(v1,v2);
% Equal module component and v1 divides v2.
   eqn(mo_comp v1,mo_comp v2) and mo_divides!?(v1,v2);

symbolic procedure mo_deletecomp v;
% Delete component part.
   if null car v then v
   else if null cdar v then (nil . mo!=deglist nil)
   else ((x . mo!=deglist x) where x=cons(0,cdar v));

symbolic procedure mo_times_ei(i,m);
% Returns m * e_i or n*e_{i+k}, if m=n*e_k.
   (x . mo!=deglist x)
   where x=if null car m then list(i) else cons(i #+ caar m,cdar m);

symbolic procedure mo_deg m; cdr m;
% Returns the degree part of m.

symbolic procedure mo_getdegree(v,l);
% Compute the (virtual) degree of the monomial v with respect to the
% assoc. list l of column degrees.
  mo_deletecomp(if a then mo_sum(v,cdr a) else v)
  where a =assoc(mo_comp(v),l);

% --------------- monomial arithmetics -----------------------

symbolic procedure mo_lcm (m1,m2);
%  Monomial least common multiple.
    begin scalar x,e1,e2;
        e1:=car m1; e2:=car m2;
        while e1 and e2 do
            < car e2 then car e1 else car e2) . x;
              e1 := cdr e1; e2 := cdr e2>>;
        x:=append(reversip x,if e1 then e1 else e2);
        return (mo!=shorten x) . (mo!=deglist x);
    end;

symbolic procedure mo_gcd (m1,m2);
%  Monomial greatest common divisor.
   begin scalar x,e1,e2;
      e1:=car m1; e2:=car m2;
      while e1 and e2 do
         <>;
      x:=reversip x; return (mo!=shorten x) . (mo!=deglist x);
   end;

symbolic procedure mo_neg v;
% Return v^-1.
  (for each x in car v collect -x).(for each x in cdr v collect -x);

symbolic procedure mo_sum(m1,m2);
%  Monomial product.
   ((mo!=shorten x) . (mo!=deglist x))
                        where x =mo!=sum(car m1,car m2);

symbolic procedure mo!=sum(e1,e2);
    begin scalar x;
      while e1 and e2 do
        <>;
      return append(reversip x,if e1 then e1 else e2);
 end;

symbolic procedure mo_diff (m1,m2); mo_sum(m1,mo_neg m2);

symbolic procedure mo_qrem(m,n);
% m,n monomials. Returns (q . r) with m=n^q*r.
    begin scalar m1,n1,q,q1;
    q:=-1; m1:=cdar m; n1:=cdar n;
    while m1 and n1 and (q neq 0) do
        << if car n1 > 0 then
            << q1:=car m1 / car n1;
               if (q=-1) or (q>q1) then q:=q1;
            >>;
           n1:=cdr n1; m1:=cdr m1;
        >>;
    if n1 or (q=-1) then q:=0;
    return q . mo_diff(m,mo_power(n,q));
    end;

symbolic procedure mo_power(mo,n);
% Monomial power mo^n.
   (for each x in car mo collect n #* x) .
                (for each x in cdr mo collect n #* x);

symbolic procedure mo!=pair(a,b);
  if null a or null b then nil
  else (car a . car b) . mo!=pair(cdr a,cdr b);

symbolic procedure mo_2list m;
% Returns a list (var name . exp) for the monomial m.
  begin scalar k; k:=car m;
  return for each x in
    mo!=pair(ring_names cali!=basering, if k then cdr k else nil)
        join if cdr x neq 0 then {x};
  end;


symbolic procedure mo_varexp(var,m);
% Returns the exponent of var:var. name in the monomial m.
    if not member(var,ring_names cali!=basering) then
                        typerr(var,"variable name")
  else begin scalar c;
    c:=assoc(var,mo_2list m);
    return if c then cdr c else 0
    end;

symbolic procedure mo_inc(m,x,j);
% Return monomial m with power of var. x increased by j.
  begin scalar n,v;
  if not member(x,v:=ring_all_names cali!=basering) then
    typerr(x,"dpoly variable");
  m:=car m;
  while x neq car v do
    << if m then <> else n:=0 . n;
       v:=cdr v;
    >>;
  if m then
    << n:=(car m #+ j).n; if m:=cdr m then n:=nconc(reverse m,n) >>
  else n:=j . n;
  while n and (car n = 0) do n:=cdr n;
  n:=reversip n;
  return n . mo!=deglist n
  end;

symbolic procedure mo_linear m;
% Test whether the monomial m is linear and return the corresponding
% variable or nil.
  (if (length u=1 and cdar u=1) then caar u else nil)
  where u=mo_2list m;

symbolic procedure mo_ecart m;
% Returns the ecart of the monomial m.
    if null car m then 0
    else mo!=sprod(cdar (if a then mo_sum(cdr a,m) else m),
        ring_ecart cali!=basering)
        where a:=atsoc(mo_comp m,cali!=degrees);

symbolic procedure mo_radical m;
% Returns the radical of the monomial m.
   (x . mo!=deglist x)
        where x = for each y in car m collect if y=0 then 0 else 1;

symbolic procedure mo_seed(m,s);
% Set var's outside the list s equal to one.
  begin scalar m1,x,v;
  if not subsetp(s,v:=ring_all_names cali!=basering) then
    typerr(s,"dpoly name's list");
  m1:=car m;
  while m1 and v do
    << x:=cons(if member(car v,s) then car m1 else 0,x);
       m1:=cdr m1; v:=cdr v
    >>;
  while x and eqn(car x,0) do x:=cdr x;
  x:=reversip x;
  return  x . mo!=deglist x;
  end;

symbolic procedure mo_wconvert(m,w);
% Conversion of monomials for weighted Hilbert series.
% w is a list of (integer) weight lists.
   ( x . mo!=deglist x) where
        x = mo!=shorten(0 . for each x in w collect
                (if car m then mo!=sprod(cdar m,x) else 0));

% ---------------- monomial interface ---------------

symbolic procedure mo_from_a u;
% Convert a kernel to a monomial.
   if not(u member ring_all_names cali!=basering) then
                typerr(u,"dpoly variable")
   else begin scalar x,y;
          y:=mo!=shorten
              for each x in ring_all_names cali!=basering collect
                            if x equal u then 1 else 0;
          return  y . mo!=deglist y;
        end;

symbolic procedure mo_2a e;
% Convert a monomial to part of algebraic prefix form of a dpoly.
   mo!=expvec2a1(car e,ring_all_names cali!=basering);

symbolic procedure mo!=expvec2a1(u,v);
    if null u then nil
    else if car u = 0 then mo!=expvec2a1(cdr u,cdr v)
    else if car u = 1 then car v . mo!=expvec2a1(cdr u,cdr v)
    else list('expt,car v,car u) . mo!=expvec2a1(cdr u,cdr v);


symbolic procedure mo_prin(e,v);
% Print monomial e in infix form. V is a boolean variable which is
% true if an element in a product has preceded this one
    mo!=dpevlpri1(car e,ring_all_names cali!=basering,v);

symbolic procedure mo!=dpevlpri1(e,u,v);
    if null e then nil
    else if car e = 0 then mo!=dpevlpri1(cdr e,cdr u,v)
    else < 1 then <>;
           mo!=dpevlpri1(cdr e,cdr u,t)>>;

symbolic procedure mo_support m;
% Returns the support of the monomial m as a list of var. names
% in the correct order.
   begin scalar u;
   for each x in ring_names cali!=basering do
    if mo_divides!?(mo_from_a x,m) then u:=x . u;
   return reversip u;
   end;

endmodule;  % mo

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/bas.red0000644000175000017500000001746611526203062022673 0ustar  giovannigiovannimodule bas;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

              #######################
              ####               ####
              ####  IDEAL BASES  ####
              ####               ####
              #######################


Ideal bases are lists of vector polynomials (with additional
information), constituting the rows of a dpmat (see below).  In a
rep. part there can be stored vectors representing each base element
according to a fixed basis. Usually rep=nil.

Informal syntax :

           ::= list of base elements
  ::= list(nr dpoly length ecart rep)

END COMMENT;


% -------- Reference operators for the base element b ---------

symbolic procedure bas_dpoly b; cadr b;
symbolic procedure bas_dplen b; caddr b;
symbolic procedure bas_nr b; car b;
symbolic procedure bas_dpecart b; cadddr b;
symbolic procedure bas_rep b; nth(b,5);

% ----- Elementary constructors for the base element be --------

symbolic procedure bas_newnumber(nr,be);
% Returns be with new number part.
   nr . cdr be;

symbolic procedure bas_make(nr,pol);
% Make base element with rep=nil.
   list(nr,pol, length pol,dp_ecart pol,nil);

symbolic procedure bas_make1(nr,pol,rep);
% Make base element with prescribed rep.
   list(nr,pol, length pol,dp_ecart pol,rep);

symbolic procedure bas_getelement(i,bas);
% Returns the base element with number i from bas (or nil).
  if null bas then list(i,nil,0,0,nil)
  else if eqn(i,bas_nr car bas) then car bas
  else bas_getelement(i,cdr bas);

% ---------- Operations on base lists ---------------

symbolic procedure bas_sort b;
% Sort the base list b.
  sort(b,function red_better);

symbolic procedure bas_print u;
% Prints a list of distributive polynomials using dp_print.
  begin terpri();
     if null u then print 'empty
     else for each v in u do
            << write bas_nr v, " -->  "; dp_print2 bas_dpoly v >>
  end;

symbolic procedure bas_renumber u;
% Renumber base list u.
  if null u then nil
  else begin scalar i; i:=0;
      return for each x in u collect <>
  end;

symbolic procedure bas_setrelations u;
% Set in the base list u the relation part rep of base element nr. i
% to e_i (provided i>0).
  for each x in u do
        if bas_nr x > 0 then rplaca(cddddr x, dp_from_ei bas_nr x);

symbolic procedure bas_removerelations u;
% Remove relation parts.
  for each x in u do rplaca(cddddr x, nil);

symbolic procedure bas_getrelations u;
% Returns the relations of the base list u as a separate base list.
  begin scalar w;
  for each x in u do w:=bas_make(bas_nr x,bas_rep x) . w;
  return reversip w;
  end;

symbolic procedure bas_from_a u;
% Converts the algebraic (prefix) form u to a base list clearing
% denominators. Only for lists.
   bas_renumber for each v in cdr u collect
        bas_make(0,dp_from_a prepf numr simp v);

symbolic procedure bas_2a u;
% Converts the base list u to its algebraic prefix form.
    append('(list),for each x in u collect dp_2a bas_dpoly x);

symbolic procedure bas_neworder u;
% Returns reordered base list u (e.g. after change of term order).
    for each x in u collect
        bas_make1(bas_nr x,dp_neworder bas_dpoly x,
                                dp_neworder bas_rep x);

symbolic procedure bas_zerodelete u;
% Returns base list u with zero elements deleted but not renumbered.
    if null u then nil
    else if null bas_dpoly car u then bas_zerodelete cdr u
    else car u.bas_zerodelete cdr u;

symbolic procedure bas_simpelement b;
% Returns (b_new . z) with
%       bas_dpoly b_new having leading coefficient 1 or
%       gcd(dp_content bas_poly,dp_content bas_rep) canceled out
% and dpoly_old = z * dpoly_new , rep_old= z * rep_new.

  if null bas_dpoly b then b . bc_fi 1
  else begin scalar z,z1,pol,rep;
    if (z:=bc_inv (z1:=dp_lc bas_dpoly b)) then
        return bas_make1(bas_nr b,
                dp_times_bc(z,bas_dpoly b),
                dp_times_bc(z,bas_rep b))
                        . z1;

    % -- now we assume that base coefficients are a gcd domain ----

    z:=bc_gcd(dp_content bas_dpoly b,dp_content bas_rep b);
    if bc_minus!? z1 then z:=bc_neg z;
    pol:=for each x in bas_dpoly b collect
                car x . car bc_divmod(cdr x,z);
    rep:=for each x in bas_rep b collect
                car x . car bc_divmod(cdr x,z);
    return bas_make1(bas_nr b,pol,rep) . z;
    end;

symbolic procedure bas_simp u;
% Applies bas_simpelement to each dpoly in the base list u.
   for each x in u collect car bas_simpelement x;

symbolic procedure bas_zero!? b;
% Test whether all base elements are zero.
   null b or (null bas_dpoly car b and bas_zero!? cdr b);

symbolic procedure bas_sieve(bas,vars);
% Sieve out all base elements from the base list bas with leading
% term containing a variable from the list of var. names vars and
% renumber the result.
   begin scalar m;  m:=mo_zero();
   for each x in vars do
       if member(x,ring_names cali!=basering) then
            m:=mo_sum(m,mo_from_a x)
       else typerr(x,"variable name");
   return bas_renumber for each x in bas_zerodelete bas join
        if mo_zero!? mo_gcd(m,dp_lmon bas_dpoly x) then {x};
   end;

symbolic procedure bas_homogenize(b,var);
% Homogenize the base list b using the var. name var.
% Note that the rep. part is correct only upto a power of var !
  for each x in b collect
      bas_make1(bas_nr x,dp_homogenize(bas_dpoly x,var),
                dp_homogenize(bas_rep x,var));

symbolic procedure bas_dehomogenize(b,var);
% Set the var. name var in the base list b equal to one.
  begin scalar u,v;
  if not member(var,v:=ring_all_names cali!=basering) then
    typerr(var,"dpoly variable");
  u:=setdiff(v,list var);
  return for each x in b collect
                bas_make1(bas_nr x,dp_seed(bas_dpoly x,u),
                            dp_seed(bas_rep x,u));
  end;

% ---------------- Special tools for local algebra -----------

symbolic procedure bas!=factorunits p;
  if null p then nil
    else bas!=delprod
        for each y in cdr (fctrf numr simp dp_2a p where !*factor=t)
            collect (dp_from_a prepf car y . cdr y);

symbolic procedure bas!=delprod u;
  begin scalar p; p:=dp_fi 1;
     for each x in u do
        if not dp_unit!? car x then p:=dp_prod(p,dp_power(car x,cdr x));
     return p
  end;

symbolic procedure bas!=detectunits p;
  if null p then nil
  else if listtest(cdr p,dp_lmon p,
        function(lambda(x,y);not mo_vdivides!?(y,car x))) then p
  else list dp_term(bc_fi 1,dp_lmon p);

symbolic procedure bas_factorunits b;
  bas_make(bas_nr b,bas!=factorunits bas_dpoly b);

symbolic procedure bas_detectunits b;
  bas_make(bas_nr b,bas!=detectunits bas_dpoly b);


endmodule;  % bas

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/cali.red0000644000175000017500000002541311526203062023025 0ustar  giovannigiovannimodule cali;

% Author H.-G. Graebe | Univ. Leipzig
% graebe@informatik.uni-leipzig.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% terpri(); write "CALI 2.2.1 Last update June 22, 1995"; terpri();

COMMENT

              #########################
              ####                 ####
              ####  HEADER MODULE  ####
              ####                 ####
              #########################

This is the header module of the package CALI, a package for
computational commutative algebra.

Author :        H.-G. Graebe
                Univ. Leipzig
                Institut fuer Informatik
                Augustusplatz 10 - 11
                D - 04109 Leipzig
                Germany

        email : graebe@informatik.uni-leipzig.de


Version : 2.2.1, finished at June 22, 1995.

See cali.chg for change's documentation.

Please send all Comments, bugs, hints, wishes, criticisms etc. to the
above email address.


Abstract :

This package contains algorithms for computations in commutative
algebra closely related to the Groebner algorithm for ideals and
modules. There are facilities for local computations, using a modern
implementation of Mora's standard basis algorithm, that works for
arbitrary term orders. This reflects the full analogy between modules
over local rings and homogeneous (in fact H-local) modules over
polynomial rings.

CALI extends also the term order facilities of the REDUCE internal
groebner package, defining term orders by degree vector lists, and
the rigid implementation of the sugar idea, by a more flexible ecart
vector, in particular useful for local computations. Version 2.2. has
also a common view on normal forms for noetherian and non-noetherian
term orders.

The package was designed mainly as a symbolic mode programming
environment extending the build-in facilities of REDUCE for the
computational approach to problems arising naturally in commutative
algebra. An algebraic mode interface allows to access (in a more
rigid frame) all important features implemented symbolically.

As main topics CALI contains facilities for

-- defining rings, ideals and modules,

-- computing Groebner bases and local standard bases,

-- computing syzygies, resolutions and (graded) Betti numbers,

-- computing (also weighted) Hilbert series, multiplicities,
        independent sets, dimensions,

-- computing normal forms and representations,

-- computing sums, products, intersections, elimination ideals etc.,

-- primality tests, computation of radicals, unmixed radicals,
        equidimensional parts, primary decompositions etc. of ideals
        and modules,

-- advanced applications of Groebner bases (blowup, associated graded
        ring, analytic spread, symmetric algebra, monomial curves),

-- applications of linear algebra techniques to zerodimensional
        ideals, as e.g. the FGLM change of term orders, border bases
        and affine and projective ideals of sets of points,

-- splitting polynomial systems of equations mixing factorization and
        Groebner algorithm, triangular systems, and different versions
        of the extended Groebner factorizer.

Reduce version required :

The program was tested under v. 3.4 - 3.6.
(I had some trouble with the module dualbases under 3.4.1)

Relevant publications :

See the bibliography in the manual.


Key words :

Groebner algorithm for ideals and modules, local standard bases,
Groebner factorizer, extended Groebner factorizer, triangular systems,
normal forms, ideal and module operations, Hilbert series, independent
sets, dual bases, border bases, affine and projective sets of points,
free resolution, constructive commutative algebra, primality test,
radical, unmixed radical, equidimensional part, primary decomposition,
blowup, associated graded ring, analytic spread, symmetric algebra,
monomial curves.



To be done :

eo(vars) : test cali!=basering for eliminationorder according to vars
        -> eliminate

Remind :

Never "put" variables, that are subject to rebounding via "where" !

end comment;

create!-package( '(
        cali            % This header module.
        bcsf            % Base coeff. arithmetics.
        ring            % Base ring and monomial arithmetics.
        mo              % Monomial arithmetic.
        dpoly           % Distr. polynomial (and vector) arithmetics.
        bas             % Polynomial lists.
        dpmat           % dpmat's arithmetic.
        red             % Normal form algorithms and related topics.
        groeb           % Groebner algorithm and related topics.
        groebf          % Groebner factorizer and extensions.
        matop           % Module operations on dpmats.
        quot            % Different quotients.
        moid            % Lead. term ideal algorithms.
        hf              % Hilbert series.
        res             % Resolutions.
        intf            % Interface to algebraic mode.
        odim            % Alg. for zerodimensional ideals and
                        %       modules.
        prime           % Primality test, radical, and primary
                        % decomposition.
        scripts         % Advanced applications, inspired by the
                        %       scripts of Bayer/Stillman.
        calimat         % CALI's extension of the matrix package.
        lf              % The dual bases approach (FGLM etc.).
        triang          % (Zero dimensional) triangular systems.
        ),'(contrib cali));

load!-package 'matrix;

fluid '(
        cali!=basering  % see rings
        cali!=degrees   % see mons in rings
        cali!=monset    % see groeb
        );

                        % Default :
switch
        hardzerotest,   % (off) see bcsf, try simp for each zerotest.
        red_total,      % (on)  see red, do total reductions.
        bcsimp,         % (on)  see red, cancel coefficient's gcd.
        noetherian,     % (on)  see interf, test term orders and
                        %                choose non local algorithms.
        factorprimes,   % (on)  see primes, invoke groebfactor during
                        %               prime decomposition.
        factorunits,    % (off) see groeb, try to remove units from
                        %               polynomials by factorization.
        detectunits,    % (off) see groeb, detect generators of the form
                        %               monomial * unit.
        lexefgb;        % (off) see groebf, invoke the extended
                        %               Groebner factorizer with pure
                        %               lex zerosolve.

% The first initialization :

put('cali,'trace,0);    % No tracing.
% linelength 79;          % This is much more convenient than 80.
                          % However, it causes problems in window sys.

% The new tracing. We hope that this shape will easily interface to a
% forthcoming general trace utility.

symbolic operator setcalitrace;
symbolic procedure setcalitrace(n);
% Set trace intensity.
        put('cali,'trace,n);

symbolic operator setcaliprintterms;
symbolic procedure setcaliprintterms(n);
% Set number of terms to be printed in intermediate output.
  if n<=0 then typerr(n,"number of terms to be printed")
  else put('cali,'printterms,n);

symbolic operator clearcaliprintterms;
symbolic procedure clearcaliprintterms;
% Set intermediate output printing to "all".
  << remprop('cali,'printterms); write"Term print bound cleared";
     terpri();
  >>;

symbolic procedure cali_trace();
% Get the trace intensity.
        get('cali,'trace);

% ---- Some useful things, probably implemented also elsewhere
% ---- in the system.

% symbolic procedure first x; car x;
% symbolic procedure second x; cadr x;
% symbolic procedure third x; caddr x;

symbolic procedure strcat l;
% Concatenate the items in the list l to a string.
  begin scalar u;
  u:=for each x in l join explode x;
  while memq('!!,u) do u:=delete('!!,u);
  while memq('!",u) do u:=delete('!",u);
  return compress append(append('(!"),u),'(!"));
  end;

symbolic procedure numberlistp l;
% l is a list of numbers.
  if null l then t
  else fixp car l and numberlistp cdr l;

symbolic procedure merge(l1,l2,fn);
% Returns the (physical) merge of the two sorted lists l1 and l2.
  if null l1 then l2
  else if null l2 then l1
  else if apply2(fn,car l1,car l2) then rplacd(l1,merge(cdr l1,l2,fn))
  else rplacd(l2,merge(l1,cdr l2,fn));

symbolic procedure listexpand(fn,l); eval expand(l,fn);

symbolic procedure listtest(a,b,f);
% Return the first u in a s.th. f(u,b) or nil.
  if null a then nil
  else if apply2(f,car a,b) then if car a=nil then t else car a
  else listtest(cdr a,b,f);

symbolic procedure listminimize(a,f);
% Returns a minimal list b such that for all v in a ex. u in b such
% that f(u,v). The elements are in the same order as in a.
  if null a then nil else reverse cali!=min(nil,a,f);

symbolic procedure cali!=min(b,a,f);
  if null a then b
  else if listtest(b,car a,f) or listtest(cdr a,car a,f) then
        cali!=min(b,cdr a,f)
  else cali!=min(car a . b,cdr a,f);

% symbolic procedure makelist u; 'list . u;

symbolic procedure subsetp(u,v);
% true :<=> u \subset v
  if null u then t else member(car u,v) and subsetp(cdr u,v);

symbolic procedure disjoint(a,b);
  if null a then t else not member(car a,b) and disjoint(cdr a,b);

symbolic procedure print_lf u;
% Line feed after about 70 characters.
  <69 then <>; prin2 u>>;

symbolic procedure cali_choose(m,k);
% Returns the list of k-subsets of m.
  if (length m < k) then nil
  else if k=1 then for each x in m collect list x
  else nconc(
        for each x in cali_choose(cdr m,k-1) collect (car m . x),
        cali_choose(cdr m,k));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/cali.rlg0000644000175000017500000020560111527635055023052 0ustar  giovannigiovanniFri Feb 18 21:27:23 2011 run on win32
% Author H.-G. Graebe | Univ. Leipzig | Version 28.6.1995
% graebe@informatik.uni-leipzig.de

COMMENT

This is an example session demonstrating and testing the facilities
offered by the commutative algebra package CALI.

END COMMENT;


algebraic;


on echo;


off nat;

 % To make it easier to compare differing output.
showtime;


Time: 0 ms


comment

	####################################
	###				 ###
	###	Introductory Examples    ###
	###				 ###
	####################################

end comment;


% Example 1 : Generating ideals of affine and projective points.


    vars:={t,x,y,z};


vars := {t,x,y,z}$

    setring(vars,degreeorder vars,revlex);


{{t,x,y,z},{{1,1,1,1}},revlex,{1,1,1,1}}$

    mm:=mat((1,1,1,1),(3,2,3,1),(2,1,3,2));


mm := mat((1,1,1,1),(3,2,3,1),(2,1,3,2))$


  % The ideal with zero set at the point in A^4 with coordinates
  % equal to the row vectors of mm :

    setideal(m1,affine_points mm);


{z**2 - 3*z + 2,
y**2 - 4*y + 3,
t - y + z - 1,
2*x - y + 2*z - 3,
y*z - y - 3*z + 3}$


	% All parameters are as they should be :

    dim m1;


0$

    degree m1;


3$

    groebfactor m1;


{{z - 2,y - 3,t - 2,x - 1},
{z - 1,t - 3,y - 3,x - 2},
{z - 1,t - 1,y - 1,x - 1}}$

    resolve m1$


    bettinumbers m1;


{1,5,9,7,2}$


  % The ideal with zero set at the point in P^3 with homogeneous 
  % coordinates equal to the row vectors of mm :

    setideal(m2,proj_points mm);


{2*y**2 - 2*x*z - 7*y*z + 7*z**2,
3*t - 2*x - 2*y + z,
2*x**2 - 4*x*z - y*z + 3*z**2,
2*x*y - 4*x*z - 3*y*z + 5*z**2}$


	% All parameters as they should be ?

    dim m2;


1$

    degree m2;


3$

    groebfactor m2;


{{2*y**2 - 2*x*z - 7*y*z + 7*z**2,
3*t - 2*x - 2*y + z,
2*x**2 - 4*x*z - y*z + 3*z**2,
2*x*y - 4*x*z - 3*y*z + 5*z**2}}$


	% It seems to be prime ?

    isprime m2;


no$


	% Not, of course, but it is known to be unmixed. 
	% Hence we can use 

    easyprimarydecomposition m2;


{{{x - 2*z,y - 3*z,t - 3*z},
{y - 3*z,x - 2*z,t - 3*z}},
{{x - z,y - z,t - z},
{y - z,x - z,t - z}},
{{2*x - z,2*y - 3*z,t - z},
{2*y - 3*z,2*x - z,t - z}}}$

  
% Example 2 : 
% The affine monomial curve with generic point (t^7,t^9,t^10).

    setideal(m,affine_monomial_curve({7,9,10},{x,y,z}));


{x**3*y - z**3,
x**4 - y**2*z,
y**3 - x*z**2}$


	% The base ring was changed as side effect :

    getring();


{{x,y,z},{{7,9,10}},revlex,{7,9,10}}$
 
    vars:=first getring m;


vars := {x,y,z}$


  % Some advanced commutative algebra :
  
  % The analytic spread of m.

    analytic_spread m;


3$


  % The Rees ring Rees_R(vars) over R=S/m.
    
    rees:=blowup(m,vars,{u,v,w});


rees := {u**2*v*x - w**3,
u*v*x**2 - w**2*z,
v*x**3 - w*z**2,
u**3*x - v**2*w,
u**2*x**2 - v*w*y,
u*x**3 - w*y**2,
 - u*w**2 + v**3,
v**2*y - w**2*x,
v*y**2 - w*x*z,
v*z - w*y,
u*z - w*x,
u*y - v*x,
x**3*y - z**3,
x**4 - y**2*z,
 - x*z**2 + y**3}$
 

  % It is multihomogeneous wrt. the degree vectors, constructed during
  % blow up. Lets compute weighted Hilbert series :

    setideal(rees,rees)$


    weights:=second getring();


weights := {{0,0,0,7,9,10},{7,9,10,0,0,0}}$

    weightedhilbertseries(gbasis rees,weights);


( - x**29*y + x**29 - x**20*y + x**20 - x**19*y**11 + x**19*y**10 - x**19*y + x
**19 - x**18*y + x**18 - x**10*y**11 + x**10*y**10 - x**10*y + x**10 - x**9*y**
21 + x**9*y**20 - x**9*y**11 + x**9*y**9 - x**9*y + x**9 + y**23 - y**22 + y**16
 - y**15 + y**14 - y**11 + y**9 - y**8 + y**7 - y + 1)/(x**7*y - x**7 - y + 1)$


  % gr_R(vars), the associated graded ring of the irrelevant ideal
  % over R. The short way.

    interreduce sub(x=0,y=0,z=0,rees);


{w**3,v**2*w, - u*w**2 + v**3}$
 

  % The long (and more general) way. Gives the result in another
  % embedding. 
  
    % Restore the base ring, since it was changed by blowup as a side
    % effect.  
    setring getring m$


    assgrad(m,vars,{u,v,w});


{x,
y,
z,
w**3,
v**2*w,
 - u*w**2 + v**3}$
 

  % Comparing the Rees algebra and the symmetric algebra of M :
  
    setring getring m$


    setideal(rees,blowup({},m,{a,b,c}));


{ - y**2*a + z**2*b + x**3*c,
x*a - y*b - z*c,
 - y**2*a**2 + z**2*a*b + x**2*y*b*c + x**2*z*c**2,
 - y**2*a**3 + z**2*a**2*b + x*y**2*b**2*c + 2*x*y*z*b*c**2 + x*z**2*c**3,
 - y**2*a**4 + z**2*a**3*b + y**3*b**3*c + 3*y**2*z*b**2*c**2 + 3*y*z**2*b*c**3 
+ z**3*c**4}$


	% Lets test weighted Hilbert series once more :

    weights:=second getring();


weights := {{0,0,0,30,28,27},{7,9,10,0,0,0}}$

    weightedhilbertseries(gbasis rees,weights);


(x**58*y**27 + x**30*y**25 - x**30*y**18 - x**30*y**7 - x**28*y**27 + 1)/(x**85*
y**26 - x**85*y**19 - x**85*y**17 - x**85*y**16 + x**85*y**10 + x**85*y**9 + x**
85*y**7 - x**85 - x**58*y**26 + x**58*y**19 + x**58*y**17 + x**58*y**16 - x**58*
y**10 - x**58*y**9 - x**58*y**7 + x**58 - x**57*y**26 + x**57*y**19 + x**57*y**
17 + x**57*y**16 - x**57*y**10 - x**57*y**9 - x**57*y**7 + x**57 - x**55*y**26 +
 x**55*y**19 + x**55*y**17 + x**55*y**16 - x**55*y**10 - x**55*y**9 - x**55*y**7
 + x**55 + x**30*y**26 - x**30*y**19 - x**30*y**17 - x**30*y**16 + x**30*y**10 +
 x**30*y**9 + x**30*y**7 - x**30 + x**28*y**26 - x**28*y**19 - x**28*y**17 - x**
28*y**16 + x**28*y**10 + x**28*y**9 + x**28*y**7 - x**28 + x**27*y**26 - x**27*y
**19 - x**27*y**17 - x**27*y**16 + x**27*y**10 + x**27*y**9 + x**27*y**7 - x**27
 - y**26 + y**19 + y**17 + y**16 - y**10 - y**9 - y**7 + 1)$


	% The symmetric algebra :

    setring getring m$


    setideal(sym,sym(m,{a,b,c}));


{y**2*a - z**2*b - x**3*c,
x*a - y*b - z*c}$

    modequalp(rees,sym);


yes$


  % Symbolic powers :

    setring getring m$


    setideal(m2,idealpower(m,2));


{x**6*y**2 - 2*x**3*y*z**3 + z**6,
x**8 - 2*x**4*y**2*z + y**4*z**2,
y**6 - 2*x*y**3*z**2 + x**2*z**4,
x**7*y - x**3*y**3*z - x**4*z**3 + y**2*z**4,
x**3*y**4 - x**4*y*z**2 - y**3*z**3 + x*z**5,
x**4*y**3 - y**5*z - x**5*z**2 + x*y**2*z**3}$


	% Let's compute a second symbolic power :

    setideal(m3,symbolic_power(m,2));


{x**6*y**2 - 2*x**3*y*z**3 + z**6,
x**8 - 2*x**4*y**2*z + y**4*z**2,
y**6 - 2*x*y**3*z**2 + x**2*z**4,
x**2*y**5 + x**7*z - 3*x**3*y**2*z**2 + y*z**5,
x**7*y - x**3*y**3*z - x**4*z**3 + y**2*z**4,
x**3*y**4 - x**4*y*z**2 - y**3*z**3 + x*z**5,
x**4*y**3 - y**5*z - x**5*z**2 + x*y**2*z**3}$


	% It is different from the ordinary second power.
	% Hence m2 has a trivial component.

    modequalp(m2,m3);


no$


	% Test x for non zero divisor property :

    nzdp(x,m2);


no$

    nzdp(x,m3);


yes$


	% Here is the primary decomposition :

    pd:=primarydecomposition m2;


pd := {{{x**8 - 2*x**4*y**2*z + y**4*z**2,
x**6*y**2 - 2*x**3*y*z**3 + z**6,
x**2*z**4 - 2*x*y**3*z**2 + y**6,
x**7*z - 3*x**3*y**2*z**2 + x**2*y**5 + y*z**5,
x**7*y - x**4*z**3 - x**3*y**3*z + y**2*z**4,
 - x**4*y*z**2 + x**3*y**4 + x*z**5 - y**3*z**3,
 - x**5*z**2 + x**4*y**3 + x*y**2*z**3 - y**5*z},
{ - x*z**2 + y**3,
x**4 - y**2*z,
x**3*y - z**3}},
{{z**2,
x**6*y**2,
y**6,
x**2*y**5*z,
x**3*y**4,
x**4*(x**4 - 2*y**2*z),
x**3*y*(x**4 - y**2*z),
y**3*(x**4 - y**2*z)},
{x,z,y}}}$


	% Compare the result with m2 :

    setideal(m4,matintersect(first first pd, first second pd));


{y**6 - 2*x*y**3*z**2 + x**2*z**4,
x**6*y**2 - 2*x**3*y*z**3 + z**6,
x**8 - 2*x**4*y**2*z + y**4*z**2,
x**2*y**5*z + x**7*z**2 - 3*x**3*y**2*z**3 + y*z**6,
x**4*y**3 - y**5*z - x**5*z**2 + x*y**2*z**3,
x**3*y**4 - x**4*y*z**2 - y**3*z**3 + x*z**5,
x**7*y - x**3*y**3*z - x**4*z**3 + y**2*z**4}$

    modequalp(m2,m4);


yes$


	% Compare the result with m3 :

    setideal(m4,first first pd)$


    modequalp(m3,m4);


yes$


	% The trivial component can also be removed with a stable
	% quotient computation : 

    setideal(m5,matstabquot(m2,vars))$


    modequalp(m3,m5);


yes$



% Example 3 : The Macaulay curve.

    setideal(m,proj_monomial_curve({0,1,3,4},{w,x,y,z}));


{x**3 - w**2*y,
w*y**2 - x**2*z,
y**3 - x*z**2,
x*y - w*z}$

    vars:=first getring();


vars := {w,x,y,z}$

    gbasis m;


{x**3 - w**2*y,
w*y**2 - x**2*z,
y**3 - x*z**2,
x*y - w*z}$

 
  % Test whether m is prime :

    isprime m;


yes$


  % A resolution of m :
    
    resolve m;


{
mat((x**3 - w**2*y),(w*y**2 - x**2*z),(y**3 - x*z**2),(x*y - w*z))$
,

mat((y,w,0, - x**2),(z,x,0, - w*y),(0, - y,w, - x*z),(0, - z,x, - y**2))$
,

mat((z, - y, - x,w))$
,

mat((0))$
}$


  % m has depth = 1 as can be seen from the 
    
    gradedbettinumbers m;


{{0},{2,3,3,3},{4,4,4,4},{5}}$
 

  % Another way to see the non perfectness of m :
    
    hilbertseries m;


( - w**3 + 2*w**2 + 2*w + 1)/(w**2 - 2*w + 1)$
 

  % Just a third approach. Divide out a parameter system :

    ps:=for i:=1:2 collect random_linear_form(vars,1000);


ps := {927*w + 880*x + 292*y + 9*z, - 819*w + 224*x - 572*y - 205*z}$

    setideal(m1,matsum(m,ps))$

 

	% dim should be zero and degree > degree m = 4. 
	% A Gbasis for m1 is computed automatically.

    dim m1;


0$
 
    degree m1;


5$
 

  % The projections of m on the coord. hyperplanes.
 
    for each x in vars collect eliminate(m,{x});


{{ - x*z**2 + y**3},
{ - w*z**3 + y**4},
{ - w**3*z + x**4},
{ - w**2*y + x**3}}$
 

% Example 4 : Two submodules of S^4.
  
	% Get the stored result of the earlier computation.

    r:=resolve m$



  % See whether cali!=degrees contains a relict from earlier
  % computations. 
  
    getdegrees();


{}$


  % Introduce the 2nd and 3rd syzygy module as new modules.
  % Both are submodules in S^4.

    setmodule(m1,second r)$

 setmodule(m2,third r)$

 
 
  % The second is already a gbasis.

    setgbasis m2;


mat((z, - y, - x,w))$
 
    getleadterms m1;


mat((0,x**3,0,0),(0,0,x**3,0),(0,0,w**2*y,0),(0,0,w*y**2,0),(0,0,w*x,0),(0,0,0,x
**2),(0,0,0,w*y),(0,0,0,x*z),(0,0,0,y**2))$
 getleadterms m2;


mat((0,0,0,w))$


  % Since rk(F/M)=rk(F/in(M)), they have ranks 1 resp. 3.

    dim m1;


4$

    indepvarsets m1;


{{w,x,y,z}}$


  % Its intersection is zero :

    matintersect(m1,m2);


mat((0,0,0,0))$


  % Its sum :
 
    setmodule(m3,matsum(m1,m2));


mat(( - y, - w,0,x**2),(0,y, - w,x*z),(0,z, - x,y**2),(z, - y, - x,w),( - y*z - 
z,y**2 - x,x*y,0))$

    dim m3;


3$


  % Hence it has a nontrivial annihilator :

    annihilator m3;


{w**2*y*z + w**2*z - w*x*y + w*y**3 - x**3*z - x**2*y*z - x**2*z**2 + x*y**3}$


  % One can compute isolated primes and primary decomposition also for
  % modules. Let's do it, although being trivial here:
 
    isolatedprimes m3;


{{w**2*y*z + w**2*z - w*x*y + w*y**3 - x**3*z - x**2*y*z - x**2*z**2 + x*y**3}}$


    primarydecomposition m3;


{{
mat((z*( - w*x*z - w*y*z + w*y - w*z + x**2*z + x*y*z - y**3 + y**2*z),w**2*y + 
w**2*z + w*x*y*z + w*x*z**2 - w*x*z + w*y*z**2 - x**2*z**2 + x*y**2*z, - w**3,0)
,(z*( - w*y - w - x*z + y**2), - w*x + w*y*z - x**2*z + x*y**2,w**2*y,0),( - x*z
**2,w*y + x*y*z + x*z**2 - y**3,w*( - w + y**2),0),( - x*z**2,y*(w + x*z), - w**
2 + x**2*z,0),( - y*z, - (w*z + x*y),w*x,0),( - w*y**2 + x**2*z, - w**2*y + x**3
,0,0),(w*y*z - w*y + w*z - x**2*z + y**3 - y**2*z, - w**2 + w*x - w*y*z + x**2*y
 + x**2*z - x*y**2,0,0),( - w*y*z - w*z - y**3 + y**2*z, - w*x + w*y*z - x**2*z 
+ x*y**2,x**3,0),(z*( - w*y - w + y**2), - w*x + w*y**2 + w*y*z + x*y**2,0,0),( 
- z*(y + 1), - x + y**2,x*y,0),(z, - y, - x,w),(w**2*y*z + w**2*z - w*x*y + w*y
**3 - x**3*z - x**2*y*z - x**2*z**2 + x*y**3,0,0,0),( - y, - w,0,x**2),(0,y, - w
,x*z),(0,z, - x,y**2))$
,
{w**2*y*z + w**2*z - w*x*y + w*y**3 - x**3*z - x**2*y*z - x**2*z**2 + x*y**3}}}$


  % To get a meaningful Hilbert series make m1 homogeneous :
 
    setdegrees {1,x,x,x};


{1,x,x,x}$
 
 
  % Reevaluate m1 with the new column degrees. 

    setmodule(m1,m1)$


    hilbertseries m1;


(w**7 - 5*w**6 + 8*w**5 - 2*w**4 - 5*w**3 + 3*w + 1)/(w**4 - 4*w**3 + 6*w**2 - 4
*w + 1)$


% Example 5 : From the MACAULAY manual (D.Bayer, M.Stillman).
% An elliptic curve on the Veronese in P^5.

    rvars:={x,y,z}$

 svars:={a,b,c,d,e,f}$


    r:=setring(rvars,degreeorder rvars,revlex)$


    s:=setring(svars,{for each x in svars collect 2},revlex)$


    map:={s,r,{a=x^2,b=x*y,c=x*z,d=y^2,e=y*z,f=z^2}};


map := {{{a,
b,
c,
d,
e,
f},
{{2,2,2,2,2,2}},
revlex,
{1,1,1,1,1,1}},
{{x,y,z},
{{1,1,1}},
revlex,
{1,1,1}},
{a=x**2,
b=x*y,
c=x*z,
d=y**2,
e=y*z,
f=z**2}}$

    preimage({y^2z-x^3-x*z^2},map);


{ - a*d + b**2,
 - a*e + b*c,
 - b*e + c*d,
 - a*f + c**2,
 - b*f + c*e,
 - d*f + e**2,
a**2 + a*f - b*e,
a*b + b*f - d*e,
a*c + c*f - d*f}$


% Example 6 : The preimage under a rational map.

    r:=setring({x,y},{},lex)$

 s:=setring({t},{},lex)$


    map:={r,s,{x=2t/(t^2+1),y=(t^2-1)/(t^2+1)}};


map := {{{x,y},{},lex,{1,1}},
{{t},{},lex,{1}},
{x=(2*t)/(t**2 + 1),y=(t**2 - 1)/(t**2 + 1)}}$

  
  % The preimage of (0) is the equation of the circle :

    ratpreimage({},map);


{x**2 + y**2 - 1}$


  % The preimage of the point (t=3/2) :

    ratpreimage({2t-3},map);


{13*x - 12,13*y - 5}$



% Example 7 : A zerodimensional ideal.

    setring({x,y,z},{},lex)$


    setideal(n,{x**2 + y + z - 3,x + y**2 + z - 3,x + y + z**2 - 3});


{x**2 + y + z - 3,x + y**2 + z - 3,x + y + z**2 - 3}$


  % The groebner algorithm with factorization :

    groebfactor n;


{{y - 1,z - 1,x - 1},
{y + 3,z + 3,x + 3},
{y - z,z**2 - 2,x + z - 1},
{z**2 - 2,x - z,y + z - 1},
{y + z - 1,z**2 - 2*z - 1,x + z - 1}}$


  % Change the term order and reevaluate n :

    setring({x,y,z},{{1,1,1}},revlex)$


    setideal(n,n);


{x**2 + y + z - 3,y**2 + x + z - 3,z**2 + x + y - 3}$


  % its primes :
 
    zeroprimes n;


{{x - z,z**2 - 2,y + z - 1},
{x + z - 1,y + z - 1,z**2 - 2*z - 1},
{z - 1,x - 1,y - 1},
{z + 3,x + 3,y + 3},
{y - z,z**2 - 2,x + z - 1}}$


  % a vector space basis of S/n :

    getkbase n;


{1,x,x*y,x*y*z,x*z,y,y*z,z}$


% Example 8 : A modular computation. Since REDUCE has no multivariate
% factorizer, factorprimes has to be turned off !

    on modular$

 off factorprimes$


    setmod 181;


1$
 setideal(n1,n);


{x**2 + y + z + 178,y**2 + x + z + 178,z**2 + x + y + 178}$
 zeroprimes n1;


{{y + 180*z,z**2 + 179,x + z + 180},
{x + z + 180,y + z + 180,z**2 + 179*z + 180},
{x + 180*z,z**2 + 179,y + z + 180},
{z + 180,x + 180,y + 180},
{z + 3,x + 3,y + 3}}$

    setmod 7;


181$
 setideal(n1,n);


{x**2 + y + z + 4,y**2 + x + z + 4,z**2 + x + y + 4}$
 zeroprimes n1;


{{z + 6,x + 6,y + 6},
{x + 4,z + 4,y + 2},
{x + 4,z + 2,y + 4},
{z + 4,x + 2,y + 4},
{x + 3,z + 3,y + 3}}$

 
	% Hence some of the primes glue together mod 7.

    zeroprimarydecomposition n1;


{{{z + 6,x + 6,y + 6},
{z + 6,x + 6,y + 6}},
{{z + 4,y + 2,x + 4},
{x + 4,z + 4,y + 2}},
{{z + 2,y + 4,x + 4},
{x + 4,z + 2,y + 4}},
{{z + 4,x + 2,y + 4},
{z + 4,x + 2,y + 4}},
{{x**2 + y + z + 4,
x + y**2 + z + 4,
x + y + z**2 + 4,
3*(x + 5*y*z + 2*y + 2*z + 5),
x*z + 6*x + 3*y + 6*z + 1,
x*y + 6*x + 6*y + 3*z + 1},
{x + 3,z + 3,y + 3}}}$

    off modular$

 on factorprimes$



% Example 9 : Independent sets once more.
  
    n:=10$


    vars:=for i:=1:(2*n) collect mkid(x,i)$


    setring(vars,{},lex)$


    setideal(m,for j:=0:n collect 
            for i:=(j+1):(j+n) product mkid(x,i));


{x1*x2*x3*x4*x5*x6*x7*x8*x9*x10,
x2*x3*x4*x5*x6*x7*x8*x9*x10*x11,
x3*x4*x5*x6*x7*x8*x9*x10*x11*x12,
x4*x5*x6*x7*x8*x9*x10*x11*x12*x13,
x5*x6*x7*x8*x9*x10*x11*x12*x13*x14,
x6*x7*x8*x9*x10*x11*x12*x13*x14*x15,
x7*x8*x9*x10*x11*x12*x13*x14*x15*x16,
x8*x9*x10*x11*x12*x13*x14*x15*x16*x17,
x9*x10*x11*x12*x13*x14*x15*x16*x17*x18,
x10*x11*x12*x13*x14*x15*x16*x17*x18*x19,
x11*x12*x13*x14*x15*x16*x17*x18*x19*x20}$

    setgbasis m$


    indepvarsets m;


{{x2,x3,x4,x5,x6,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x3,x4,x5,x6,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x4,x5,x6,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x5,x6,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x6,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x12,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x3,x4,x5,x6,x7,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x4,x5,x6,x7,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x5,x6,x7,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x6,x7,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x13,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x4,x5,x6,x7,x8,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x5,x6,x7,x8,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x6,x7,x8,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x14,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x5,x6,x7,x8,x9,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x6,x7,x8,x9,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x15,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x6,x7,x8,x9,x10,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x16,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x7,x8,x9,x10,x11,x12,x13,x14,x15,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x12,x13,x14,x15,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x13,x14,x15,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x14,x15,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x15,x17,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x8,x9,x10,x11,x12,x13,x14,x15,x16,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x13,x14,x15,x16,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x14,x15,x16,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x15,x16,x18,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x9,x10,x11,x12,x13,x14,x15,x16,x17,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x14,x15,x16,x17,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x15,x16,x17,x19,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x10,x11,x12,x13,x14,x15,x16,x17,x18,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x15,x16,x17,x18,x20},
{x1,x2,x3,x4,x5,x6,x7,x8,x9,x11,x12,x13,x14,x15,x16,x17,x18,x19}}$

    dim m;


18$

    degree m;


55$



comment

	####################################
	###				 ###
	###     Local Standard Bases     ###
	###				 ###
	####################################

end comment;



% Example 10 : An example from [ Alonso, Mora, Raimondo ] 

    vars := {z,x,y}$


    r:=setring(vars,{},lex)$


    setideal(m,{x^3+(x^2-y^2)*z+z^4,y^3+(x^2-y^2)*z-z^4});


{z**4 + z*x**2 - z*y**2 + x**3,
 - z**4 + z*x**2 - z*y**2 + y**3}$

    dim m;


1$

    degree m;


12$


  % 2 = codim m is the codimension of the curve m. The defining 
  % equations of the singular locus with their nilpotent structure : 

    singular_locus(m,2);


{x**3 - y**3 + 2*z**4,
x**3 + 2*x**2*z + y**3 - 2*y**2*z,
y*(8*x**3 + 3*x**2*y - 11*y**3 + 12*y*z**3),
y*(x**3 + 3*x**2*y + 2*x*y*z + y**3 - 2*y**2*z),
3*x**5 + 3*x**4*y + 22*x**4 + 18*x**3*y**2 + 16*x**3*y + 21*x**2*y**3 + 3*x*y**4
 - 16*x*y**3 + 18*y**5 - 42*y**4*z - 22*y**4 + 24*y**3*z**2}$
 
    groebfactor ws;


{{y,x,z},{81*x + 256,27*z - 64,81*y - 256}}$
 

  % Hence this curve has two singular points : 
  % (x=y=z=0) and (y=-x=256/81,z=64/27)
  % Let's find the brances of the curve through the origin.
  % The first critical tropism is (-1,-1,-1).

    off noetherian$


    setring(vars,{{-1,-1,-1}},lex)$


    setideal(m,m);


{z*x**2 - z*y**2 + x**3 + z**4,
z*x**2 - z*y**2 + y**3 - z**4}$

	% Let's first test two different approaches, not fully
	% integrated into the algebraic interface :
    setideal(m1,homstbasis m);


{x**3 - y**3 + 2*z**4,
z*x**2 - z*y**2 + y**3 - z**4,
z*x*y**2 - z*y**3 - x*y**3 + 2*z**5 + z**4*x,
x**2*y**3 + x*y**4 + y**5 - 2*z**5*x - 2*z**5*y - z**4*x**2 - z**4*x*y - z**4*y
**2,
6*z*y**5 + 2*x*y**5 - 2*y**6 - 4*z**6*x - 4*z**6*y - 2*z**5*x*y - 8*z**5*y**2 + 
z**4*x**3 - 2*z**4*x*y**2 + 3*z**4*y**3}$

    setideal(m2,lazystbasis m);


{x**3 - y**3 + 2*z**4,
z*x**2 - z*y**2 + y**3 - z**4,
z*x*y**2 - z*y**3 - x*y**3 + 2*z**5 + z**4*x,
x**2*y**3 + x*y**4 + y**5 - 2*z**5*x - 2*z**5*y - z**4*x**2 - z**4*x*y - z**4*y
**2,
3*z*y**5 + x*y**5 - y**6 - 2*z**6*x - 2*z**6*y - z**5*x**2 - z**5*x*y - 3*z**5*y
**2 - z**4*x*y**2 + z**4*y**3}$

    setgbasis m1$

 setgbasis m2$


    modequalp(m1,m2);


yes$

    gbasis m;


{x**3 - y**3 + 2*z**4,
z*x**2 - z*y**2 + y**3 - z**4,
z*x*y**2 - z*y**3 - x*y**3 + 2*z**5 + z**4*x,
x**2*y**3 + x*y**4 + y**5 - 2*z**5*x - 2*z**5*y - z**4*x**2 - z**4*x*y - z**4*y
**2,
3*z*y**5 + x*y**5 - y**6 - 2*z**6*x - 2*z**6*y - z**5*x**2 - z**5*x*y - 3*z**5*y
**2 - z**4*x*y**2 + z**4*y**3}$

    modequalp(m,m1);


yes$

    dim m;


1$

    degree m;


9$


  % Find the tangent directions not in z-direction :

    tangentcone m;


{x**3 - y**3,
z*x**2 - z*y**2 + y**3,
z*x*y**2 - z*y**3 - x*y**3,
x**2*y**3 + x*y**4 + y**5,
3*z*y**5 + x*y**5 - y**6}$
 
    setideal(n,sub(z=1,ws));


{x**3 - y**3,
x**2 - y**2 + y**3,
x*y**2 - y**3 - x*y**3,
x**2*y**3 + x*y**4 + y**5,
3*y**5 + x*y**5 - y**6}$

    setring r$

 on noetherian$

 setideal(n,n)$


    degree n;


9$


  % The points of n outside the origin.

    matstabquot(n,{x,y});


{y**2 - 3*y + 3,x - y + 3}$
 

  % Hence there are two branches x=z'*(a-3+x'),y=z'*(a+y'),z=z'
  % with the algebraic number a : a^2-3a+3=0
  % and the new equations for (z',x',y') :

    setrules {a^2=>3a-3};


{a**2 => 3*a - 3}$

    sub(x=z*(a-3+x),y=z*(a+y),m);


{z**3*(a**3 + 3*a**2*x - 9*a**2 + 3*a*x**2 - 16*a*x - 2*a*y + 21*a + x**3 - 8*x
**2 + 21*x - y**2 + z - 18),
z**3*(a**3 + 3*a**2*y + 2*a*x + 3*a*y**2 - 2*a*y - 6*a + x**2 - 6*x + y**3 - y**
2 - z + 9)}$

    setideal(m1,matqquot(ws,z));


{x**3 + (3*a - 7)*x**2 - (5*a - 6)*x + y**3 + (3*a - 2)*y**2 + (5*a - 9)*y,
z - x**2 - (2*a - 6)*x - y**3 - (3*a - 1)*y**2 - (7*a - 9)*y}$


  % This defines a loc. smooth system at the origin, since the
  % jacobian at the origin of the gbasis is nonsingular :

    off noetherian$


    setring getring m;


{{z,x,y},{{-1,-1,-1}},lex,{1,1,1}}$

    setideal(m1,m1);


{ - (5*a - 6)*x + (5*a - 9)*y + (3*a - 7)*x**2 + (3*a - 2)*y**2 + x**3 + y**3,
z - (2*a - 6)*x - (7*a - 9)*y - x**2 - (3*a - 1)*y**2 - y**3}$

    gbasis m1;


{(5*a - 6)*x - (5*a - 9)*y - (3*a - 7)*x**2 - (3*a - 2)*y**2 - x**3 - y**3,
(5*a - 6)*z + 27*y + (9*a - 18)*x**2 - (18*a - 45)*y**2 - (2*a - 6)*x**3 - (7*a 
- 12)*y**3}$


	% clear the rules previously set.

    setrules {};


{}$
 


% Example 11 : The standard basis of another example. 

	% Comparing different approaches.

    vars:={x,y}$


    setring(vars,localorder vars,lex);


{{x,y},{{-1,-1}},lex,{1,1}}$

    ff:=x^5+y^11+(x+x^3)*y^9;


ff := x**5 + x**3*y**9 + x*y**9 + y**11$

    setideal(p1,mat2list matjac({ff},vars));


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8}$

    gbasis p1;


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8,
73205*y**16 + 6561*y**17 - 32805*x**10*y**8 + 294030*x**6*y**12 - 292820*x**2*y
**16 + 120285*x**9*y**10 - 239580*x**5*y**14 + 19683*x**2*y**17}$


    gbtestversion 2$


    setideal(p2,p1);


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8}$

    gbasis p2;


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8,
73205*y**16 + 6561*y**17 - 32805*x**10*y**8 + 294030*x**6*y**12 - 292820*x**2*y
**16 + 120285*x**9*y**10 - 239580*x**5*y**14 + 19683*x**2*y**17}$


    gbtestversion 3$


    setideal(p3,p1);


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8}$

    gbasis p3;


{5*x**4 + y**9 + 3*x**2*y**9,
9*x*y**8 + 11*y**10 + 9*x**3*y**8,
73205*y**16 + 6561*y**17 - 32805*x**10*y**8 + 294030*x**6*y**12 - 292820*x**2*y
**16 + 120285*x**9*y**10 - 239580*x**5*y**14 + 19683*x**2*y**17}$


    gbtestversion 1$


    modequalp(p1,p2);


yes$

    modequalp(p1,p3);


yes$

    dim p1;


0$

    degree p1;


40$


% Example 12 : A local intersection wrt. a non inflimited term order.

    setring({x,y,z},{},revlex);


{{x,y,z},{},revlex,{1,1,1}}$

    m1:=matintersect({x-y^2,y-x^2},{x-z^2,z-x^2},{y-z^2,z-y^2});


m1 := {y*z - x**3*y*z - x*y*z**2 + x**4*y*z**2 - y**2*z**2 + x**3*y**2*z**2 + x*
y**2*z**3 - x**4*y**2*z**3,
x*z - x**2*y*z - x**2*z**2 - x*y*z**2 + x**3*y*z**2 + x**2*y**2*z**2 + x**2*y*z
**3 - x**3*y**2*z**3,
x*y - x**2*y**2 - x**2*y*z - x*y**2*z + x**3*y**2*z + x**2*y**3*z + x**2*y**2*z
**2 - x**3*y**3*z**2}$

  
	% Delete polynomial units post factum :
  
    deleteunits ws;


{y*z,x*z,x*y}$


	% Detecting polynomial units early :

    on detectunits;


    m1:=matintersect({x-y^2,y-x^2},{x-z^2,z-x^2},{y-z^2,z-y^2});


m1 := {y*z,x*z,x*y}$

    off detectunits;




comment

	####################################
	###				 ###
	###  More Advanced Computations  ###
	###				 ###
	####################################

end comment;


  % Return to a noetherian term order:
   
    vars:={x,y,z}$


    setring(vars,degreeorder vars,revlex);


{{x,y,z},{{1,1,1}},revlex,{1,1,1}}$

    on noetherian;



% Example 13 : Use of "mod".

  % Polynomials modulo ideals :

    setideal(m,{2x^2+y+5,3y^2+z+7,7z^2+x+1});


{2*x**2 + y + 5,3*y**2 + z + 7,7*z**2 + x + 1}$

    x^2*y^2*z^2 mod m;


( - x*y*z - 7*x*y - 5*x*z - 35*x - y*z - 7*y - 5*z - 35)/42$


  % Lists of polynomials modulo ideals :

    {x^3,y^3,z^3} mod gbasis m;


{(x*( - y - 5))/2,(y*( - z - 7))/3,( - z*(x + 1))/7}$


  % Matrices modulo modules :

    mm:=mat((x^4,y^4,z^4));


mm := mat((x**4,y**4,z**4))$

    mm1:=tp<< ideal2mat m>>;


mm1 := mat((2*x**2 + y + 5,3*y**2 + z + 7,x + 7*z**2 + 1))$

    mm mod mm1;


mat(((y**2 + 10*y + 25)/4,( - 6*x**2*y**2 - 2*x**2*z - 14*x**2 + 4*y**4 + 3*y**3
 + 15*y**2 + y*z + 7*y + 5*z + 35)/4,( - 2*x**3 - 14*x**2*z**2 - 2*x**2 + x*y + 
5*x + 7*y*z**2 + y + 4*z**4 + 35*z**2 + 5)/4))$


% Example 14 : Powersums through elementary symmetric functions.

    vars:={a,b,c,d,e1,e2,e3,e4}$


    setring(vars,{},lex)$


    m:=interreduce {a+b+c+d-e1,
        a*b+a*c+a*d+b*c+b*d+c*d-e2,
        a*b*c+a*b*d+a*c*d+b*c*d-e3,
        a*b*c*d-e4};


m := {d**4 - d**3*e1 + d**2*e2 - d*e3 + e4,
a + b + c + d - e1,
c**3 + c**2*d - c**2*e1 + c*d**2 - c*d*e1 + c*e2 + d**3 - d**2*e1 + d*e2 - e3,
b**2 + b*c + b*d - b*e1 + c**2 + c*d - c*e1 + d**2 - d*e1 + e2}$

    
    for n:=1:5 collect a^n+b^n+c^n+d^n mod m;


{e1,
e1**2 - 2*e2,
e1**3 - 3*e1*e2 + 3*e3,
e1**4 - 4*e1**2*e2 + 4*e1*e3 + 2*e2**2 - 4*e4,
e1**5 - 5*e1**3*e2 + 5*e1**2*e3 + 5*e1*e2**2 - 5*e1*e4 - 5*e2*e3}$
    

% Example 15 : The setrules mechanism. 

    setring({x,y,z},{},lex)$


    setrules {aa^3=>aa+1};


{aa**3 => aa + 1}$

    setideal(m,{x^2+y+z-aa,x+y^2+z-aa,x+y+z^2-aa});


{x**2 + y + z - aa,x + y**2 + z - aa,x + y + z**2 - aa}$

    gbasis m;


{y**2 - y - z**2 + z,
x + y + z**2 - aa,
2*y*z**2 - (2*aa - 2)*y + z**4 - (2*aa - 1)*z**2 + (aa**2 - aa),
z**6 - (3*aa + 1)*z**4 + 4*z**3 + (3*aa**2 - 2*aa - 2)*z**2 - (4*aa - 4)*z + (3*
aa**2 - 3*aa - 1)}$

    
	% Clear the rules previously set.

    setrules {};


{}$


% Example 16 : The same example with advanced coefficient domains.

    load_package arnum;


    defpoly aa^3-aa-1;


    setideal(m,{x^2+y+z-aa,x+y^2+z-aa,x+y+z^2-aa});


{x**2 + y + z - aa,x + y**2 + z - aa,x + y + z**2 - aa}$

    gbasis m;


{y**2 - y - z**2 + z,
x + y + z**2 - aa,
y*z**2 - (aa - 1)*y + 1/2*z**4 - (aa - 1/2)*z**2 + (1/2*aa**2 - 1/2*aa),
z**6 - (3*aa + 1)*z**4 + 4*z**3 + (3*aa**2 - 2*aa - 2)*z**2 - (4*aa - 4)*z + (3*
aa**2 - 3*aa - 1)}$


	% The following needs some more time since factorization of
	% arnum's is not so easy :

    groebfactor m;


{{y - (aa**2 - aa - 1),
z - (aa**2 - aa - 1),
x + (aa**2 - aa - 2)},
{y + (aa**2 - aa - 1),
z + (aa**2 - aa - 1),
x - (aa**2 - aa)},
{y - z,x - z,z**2 + 2*z - aa},
{z - (aa**2 - aa),
y + (aa**2 - aa - 1),
x + (aa**2 - aa - 1)},
{z - (aa**2 - aa - 1),
y + (aa**2 - aa - 2),
x - (aa**2 - aa - 1)},
{z + (aa**2 - aa - 2),
y - (aa**2 - aa - 1),
x - (aa**2 - aa - 1)},
{z + (aa**2 - aa - 1),
y - (aa**2 - aa),
x + (aa**2 - aa - 1)}}$

    off arnum;


    off rational;




comment

	####################################
	###				 ###
	###  Using Advanced Scripts in   ###
	###	a Complex Example	 ###
	###				 ###
	####################################

end comment;



% Example 17 : The square of the 2-minors of a symmetric 3x3-matrix.

    vars:=for i:=1:6 collect mkid(x,i);


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

    setring(vars,degreeorder vars,revlex);


{{x1,x2,x3,x4,x5,x6},{{1,1,1,1,1,1}},revlex,{1,1,1,1,1,1}}$


	% Generating the ideal :

    mm:=mat((x1,x2,x3),(x2,x4,x5),(x3,x5,x6));


mm := mat((x1,x2,x3),(x2,x4,x5),(x3,x5,x6))$

    m:=ideal_of_minors(mm,2);


m := { - x1*x4 + x2**2,
 - x1*x5 + x2*x3,
 - x1*x6 + x3**2,
 - x2*x5 + x3*x4,
 - x2*x6 + x3*x5,
 - x4*x6 + x5**2}$

    setideal(n,idealpower(m,2));


{x2**4 - 2*x1*x2**2*x4 + x1**2*x4**2,
x3**4 - 2*x1*x3**2*x6 + x1**2*x6**2,
x5**4 - 2*x4*x5**2*x6 + x4**2*x6**2,
x2**2*x3**2 - 2*x1*x2*x3*x5 + x1**2*x5**2,
x3**2*x5**2 - 2*x2*x3*x5*x6 + x2**2*x6**2,
x2**3*x3 - x1*x2*x3*x4 - x1*x2**2*x5 + x1**2*x4*x5,
x2*x3**3 - x1*x3**2*x5 - x1*x2*x3*x6 + x1**2*x5*x6,
x2**2*x3*x4 - x1*x3*x4**2 - x2**3*x5 + x1*x2*x4*x5,
x2**2*x3*x5 - x1*x3*x4*x5 - x2**3*x6 + x1*x2*x4*x6,
x2*x3**2*x5 - x1*x3*x5**2 - x2**2*x3*x6 + x1*x2*x5*x6,
x3**3*x5 - x2*x3**2*x6 - x1*x3*x5*x6 + x1*x2*x6**2,
x2**2*x5**2 - x1*x4*x5**2 - x2**2*x4*x6 + x1*x4**2*x6,
x2*x3*x5**2 - x1*x5**3 - x2*x3*x4*x6 + x1*x4*x5*x6,
x3*x4*x5**2 - x2*x5**3 - x3*x4**2*x6 + x2*x4*x5*x6,
x3*x5**3 - x3*x4*x5*x6 - x2*x5**2*x6 + x2*x4*x6**2,
x3**2*x4**2 - 2*x2*x3*x4*x5 + x1*x4*x5**2 + x2**2*x4*x6 - x1*x4**2*x6,
x2*x3**2*x4 - 2*x1*x3*x4*x5 + x1*x2*x5**2 - x2**3*x6 + x1*x2*x4*x6,
x3**3*x4 - x1*x3*x5**2 - x2**2*x3*x6 - x1*x3*x4*x6 + 2*x1*x2*x5*x6,
x3**2*x4*x5 - x1*x5**3 - 2*x2*x3*x4*x6 + x2**2*x5*x6 + x1*x4*x5*x6,
x3**2*x4*x6 - 2*x2*x3*x5*x6 + x1*x5**2*x6 + x2**2*x6**2 - x1*x4*x6**2,
x1*x3**2*x4 - 2*x1*x2*x3*x5 + x1**2*x5**2 + x1*x2**2*x6 - x1**2*x4*x6}$


	% The ideal itself :

    gbasis n;


{x2**4 - 2*x1*x2**2*x4 + x1**2*x4**2,
x3**4 - 2*x1*x3**2*x6 + x1**2*x6**2,
x5**4 - 2*x4*x5**2*x6 + x4**2*x6**2,
x2**2*x3**2 - 2*x1*x2*x3*x5 + x1**2*x5**2,
x3**2*x5**2 - 2*x2*x3*x5*x6 + x2**2*x6**2,
x2**3*x3 - x1*x2*x3*x4 - x1*x2**2*x5 + x1**2*x4*x5,
x2*x3**3 - x1*x3**2*x5 - x1*x2*x3*x6 + x1**2*x5*x6,
x2**2*x3*x4 - x1*x3*x4**2 - x2**3*x5 + x1*x2*x4*x5,
x2**2*x3*x5 - x1*x3*x4*x5 - x2**3*x6 + x1*x2*x4*x6,
x2*x3**2*x5 - x1*x3*x5**2 - x2**2*x3*x6 + x1*x2*x5*x6,
x3**3*x5 - x2*x3**2*x6 - x1*x3*x5*x6 + x1*x2*x6**2,
x2**2*x5**2 - x1*x4*x5**2 - x2**2*x4*x6 + x1*x4**2*x6,
x2*x3*x5**2 - x1*x5**3 - x2*x3*x4*x6 + x1*x4*x5*x6,
x3*x4*x5**2 - x2*x5**3 - x3*x4**2*x6 + x2*x4*x5*x6,
x3*x5**3 - x3*x4*x5*x6 - x2*x5**2*x6 + x2*x4*x6**2,
x3**2*x4**2 - 2*x2*x3*x4*x5 + x1*x4*x5**2 + x2**2*x4*x6 - x1*x4**2*x6,
x2*x3**2*x4 - 2*x1*x3*x4*x5 + x1*x2*x5**2 - x2**3*x6 + x1*x2*x4*x6,
x3**3*x4 - x1*x3*x5**2 - x2**2*x3*x6 - x1*x3*x4*x6 + 2*x1*x2*x5*x6,
x3**2*x4*x5 - x1*x5**3 - 2*x2*x3*x4*x6 + x2**2*x5*x6 + x1*x4*x5*x6,
x3**2*x4*x6 - 2*x2*x3*x5*x6 + x1*x5**2*x6 + x2**2*x6**2 - x1*x4*x6**2,
x1*x3**2*x4 - 2*x1*x2*x3*x5 + x1**2*x5**2 + x1*x2**2*x6 - x1**2*x4*x6}$

    length n;


21$

    dim n;


3$

    degree n;


16$


	% Its radical.

    radical n;


{ - x1*x5 + x2*x3,
 - x2*x5 + x3*x4,
 - x2*x6 + x3*x5,
 - x1*x4 + x2**2,
 - x1*x6 + x3**2,
 - x4*x6 + x5**2}$


	% Its unmixed radical.

    unmixedradical n;


{ - x1*x5 + x2*x3,
x2*x5 - x3*x4,
 - x2*x6 + x3*x5,
 - x1*x4 + x2**2,
 - x1*x6 + x3**2,
 - x4*x6 + x5**2}$


	% Its equidimensional hull :

    n1:=eqhull n;


n1 := {x1**2*x4**2 - 2*x1*x2**2*x4 + x2**4,
x1**2*x6**2 - 2*x1*x3**2*x6 + x3**4,
x4**2*x6**2 - 2*x4*x5**2*x6 + x5**4,
x1**2*x5**2 - 2*x1*x2*x3*x5 + x2**2*x3**2,
x2**2*x6**2 - 2*x2*x3*x5*x6 + x3**2*x5**2,
x1**2*x4*x5 - x1*x2**2*x5 - x1*x2*x3*x4 + x2**3*x3,
x1**2*x5*x6 - x1*x2*x3*x6 - x1*x3**2*x5 + x2*x3**3,
x1*x2*x4*x5 - x1*x3*x4**2 - x2**3*x5 + x2**2*x3*x4,
x1*x2*x4*x6 - x1*x3*x4*x5 - x2**3*x6 + x2**2*x3*x5,
x1*x2*x5*x6 - x1*x3*x5**2 - x2**2*x3*x6 + x2*x3**2*x5,
x1*x2*x6**2 - x1*x3*x5*x6 - x2*x3**2*x6 + x3**3*x5,
x1*x4**2*x6 - x1*x4*x5**2 - x2**2*x4*x6 + x2**2*x5**2,
x1*x4*x5*x6 - x1*x5**3 - x2*x3*x4*x6 + x2*x3*x5**2,
x2*x4*x5*x6 - x2*x5**3 - x3*x4**2*x6 + x3*x4*x5**2,
x2*x4*x6**2 - x2*x5**2*x6 - x3*x4*x5*x6 + x3*x5**3,
 - x1*x4*x6 + x1*x5**2 + x2**2*x6 - 2*x2*x3*x5 + x3**2*x4}$

    length n1;


16$

    setideal(n1,n1)$

 
    submodulep(n,n1);


yes$

    submodulep(n1,n);


no$


	% Hence there is an embedded component. Let's find it making
	% an excursion to symbolic mode. Of course, this can be done
	% also algebraically. 

    symbolic;


nil

    n:=get('n,'basis);


(dpmat 21 0 ((1 ((((0 0 4) 4) . 1) (((0 1 2 0 1) 4) . -2) (((0 2 0 0 2) 4) . 1))
3 0 nil) (2 ((((0 0 0 4) 4) . 1) (((0 1 0 2 0 0 1) 4) . -2) (((0 2 0 0 0 0 2) 4)
. 1)) 3 0 nil) (3 ((((0 0 0 0 0 4) 4) . 1) (((0 0 0 0 1 2 1) 4) . -2) (((0 0 0 0
2 0 2) 4) . 1)) 3 0 nil) (4 ((((0 0 2 2) 4) . 1) (((0 1 1 1 0 1) 4) . -2) (((0 2
0 0 0 2) 4) . 1)) 3 0 nil) (5 ((((0 0 0 2 0 2) 4) . 1) (((0 0 1 1 0 1 1) 4) . -2
) (((0 0 2 0 0 0 2) 4) . 1)) 3 0 nil) (6 ((((0 0 3 1) 4) . 1) (((0 1 1 1 1) 4) .
-1) (((0 1 2 0 0 1) 4) . -1) (((0 2 0 0 1 1) 4) . 1)) 4 0 nil) (7 ((((0 0 1 3) 4
) . 1) (((0 1 0 2 0 1) 4) . -1) (((0 1 1 1 0 0 1) 4) . -1) (((0 2 0 0 0 1 1) 4)
. 1)) 4 0 nil) (8 ((((0 0 2 1 1) 4) . 1) (((0 1 0 1 2) 4) . -1) (((0 0 3 0 0 1)
4) . -1) (((0 1 1 0 1 1) 4) . 1)) 4 0 nil) (9 ((((0 0 2 1 0 1) 4) . 1) (((0 1 0
1 1 1) 4) . -1) (((0 0 3 0 0 0 1) 4) . -1) (((0 1 1 0 1 0 1) 4) . 1)) 4 0 nil) (
10 ((((0 0 1 2 0 1) 4) . 1) (((0 1 0 1 0 2) 4) . -1) (((0 0 2 1 0 0 1) 4) . -1)
(((0 1 1 0 0 1 1) 4) . 1)) 4 0 nil) (11 ((((0 0 0 3 0 1) 4) . 1) (((0 0 1 2 0 0
1) 4) . -1) (((0 1 0 1 0 1 1) 4) . -1) (((0 1 1 0 0 0 2) 4) . 1)) 4 0 nil) (12 (
(((0 0 2 0 0 2) 4) . 1) (((0 1 0 0 1 2) 4) . -1) (((0 0 2 0 1 0 1) 4) . -1) (((0
1 0 0 2 0 1) 4) . 1)) 4 0 nil) (13 ((((0 0 1 1 0 2) 4) . 1) (((0 1 0 0 0 3) 4) .
-1) (((0 0 1 1 1 0 1) 4) . -1) (((0 1 0 0 1 1 1) 4) . 1)) 4 0 nil) (14 ((((0 0 0
1 1 2) 4) . 1) (((0 0 1 0 0 3) 4) . -1) (((0 0 0 1 2 0 1) 4) . -1) (((0 0 1 0 1
1 1) 4) . 1)) 4 0 nil) (15 ((((0 0 0 1 0 3) 4) . 1) (((0 0 0 1 1 1 1) 4) . -1) (
((0 0 1 0 0 2 1) 4) . -1) (((0 0 1 0 1 0 2) 4) . 1)) 4 0 nil) (16 ((((0 0 0 2 2)
4) . 1) (((0 0 1 1 1 1) 4) . -2) (((0 1 0 0 1 2) 4) . 1) (((0 0 2 0 1 0 1) 4) .
1) (((0 1 0 0 2 0 1) 4) . -1)) 5 0 nil) (17 ((((0 0 1 2 1) 4) . 1) (((0 1 0 1 1
1) 4) . -2) (((0 1 1 0 0 2) 4) . 1) (((0 0 3 0 0 0 1) 4) . -1) (((0 1 1 0 1 0 1)
4) . 1)) 5 0 nil) (18 ((((0 0 0 3 1) 4) . 1) (((0 1 0 1 0 2) 4) . -1) (((0 0 2 1
0 0 1) 4) . -1) (((0 1 0 1 1 0 1) 4) . -1) (((0 1 1 0 0 1 1) 4) . 2)) 5 0 nil) (
19 ((((0 0 0 2 1 1) 4) . 1) (((0 1 0 0 0 3) 4) . -1) (((0 0 1 1 1 0 1) 4) . -2)
(((0 0 2 0 0 1 1) 4) . 1) (((0 1 0 0 1 1 1) 4) . 1)) 5 0 nil) (20 ((((0 0 0 2 1
0 1) 4) . 1) (((0 0 1 1 0 1 1) 4) . -2) (((0 1 0 0 0 2 1) 4) . 1) (((0 0 2 0 0 0
2) 4) . 1) (((0 1 0 0 1 0 2) 4) . -1)) 5 0 nil) (21 ((((0 1 0 2 1) 4) . 1) (((0
1 1 1 0 1) 4) . -2) (((0 2 0 0 0 2) 4) . 1) (((0 1 2 0 0 0 1) 4) . 1) (((0 2 0 0
1 0 1) 4) . -1)) 5 0 nil)) nil nil)


	% This needs even more time than the eqhull, of course.

    u:=primarydecomposition!* n;


(((dpmat 16 0 ((1 ((((0 0 2 1 0 1) 4) . 1) (((0 1 0 1 1 1) 4) . -1) (((0 0 3 0 0
0 1) 4) . -1) (((0 1 1 0 1 0 1) 4) . 1)) 4 0 nil) (2 ((((0 0 1 2 0 1) 4) . 1) ((
(0 1 0 1 0 2) 4) . -1) (((0 0 2 1 0 0 1) 4) . -1) (((0 1 1 0 0 1 1) 4) . 1)) 4 0
nil) (3 ((((0 0 1 1 0 2) 4) . 1) (((0 1 0 0 0 3) 4) . -1) (((0 0 1 1 1 0 1) 4) .
-1) (((0 1 0 0 1 1 1) 4) . 1)) 4 0 nil) (4 ((((0 0 4) 4) . 1) (((0 1 2 0 1) 4) .
-2) (((0 2 0 0 2) 4) . 1)) 3 0 nil) (5 ((((0 0 3 1) 4) . 1) (((0 1 1 1 1) 4) .
-1) (((0 1 2 0 0 1) 4) . -1) (((0 2 0 0 1 1) 4) . 1)) 4 0 nil) (6 ((((0 0 2 2) 4
) . 1) (((0 1 1 1 0 1) 4) . -2) (((0 2 0 0 0 2) 4) . 1)) 3 0 nil) (7 ((((0 0 2 1
1) 4) . 1) (((0 1 0 1 2) 4) . -1) (((0 0 3 0 0 1) 4) . -1) (((0 1 1 0 1 1) 4) .
1)) 4 0 nil) (8 ((((0 0 2 0 0 2) 4) . 1) (((0 1 0 0 1 2) 4) . -1) (((0 0 2 0 1 0
1) 4) . -1) (((0 1 0 0 2 0 1) 4) . 1)) 4 0 nil) (9 ((((0 0 0 4) 4) . 1) (((0 1 0
2 0 0 1) 4) . -2) (((0 2 0 0 0 0 2) 4) . 1)) 3 0 nil) (10 ((((0 0 0 0 0 4) 4) .
1) (((0 0 0 0 1 2 1) 4) . -2) (((0 0 0 0 2 0 2) 4) . 1)) 3 0 nil) (11 ((((0 0 0
2 0 2) 4) . 1) (((0 0 1 1 0 1 1) 4) . -2) (((0 0 2 0 0 0 2) 4) . 1)) 3 0 nil) (
12 ((((0 0 1 3) 4) . 1) (((0 1 0 2 0 1) 4) . -1) (((0 1 1 1 0 0 1) 4) . -1) (((0
2 0 0 0 1 1) 4) . 1)) 4 0 nil) (13 ((((0 0 0 3 0 1) 4) . 1) (((0 0 1 2 0 0 1) 4)
. -1) (((0 1 0 1 0 1 1) 4) . -1) (((0 1 1 0 0 0 2) 4) . 1)) 4 0 nil) (14 ((((0 0
0 1 1 2) 4) . 1) (((0 0 1 0 0 3) 4) . -1) (((0 0 0 1 2 0 1) 4) . -1) (((0 0 1 0
1 1 1) 4) . 1)) 4 0 nil) (15 ((((0 0 0 1 0 3) 4) . 1) (((0 0 0 1 1 1 1) 4) . -1)
(((0 0 1 0 0 2 1) 4) . -1) (((0 0 1 0 1 0 2) 4) . 1)) 4 0 nil) (16 ((((0 0 0 2 1
) 3) . 1) (((0 0 1 1 0 1) 3) . -2) (((0 1 0 0 0 2) 3) . 1) (((0 0 2 0 0 0 1) 3)
. 1) (((0 1 0 0 1 0 1) 3) . -1)) 5 0 nil)) nil t) (dpmat 6 0 ((1 ((((0 0 0 1 0 1
) 2) . 1) (((0 0 1 0 0 0 1) 2) . -1)) 2 0 nil) (2 ((((0 0 0 0 0 2) 2) . 1) (((0
0 0 0 1 0 1) 2) . -1)) 2 0 nil) (3 ((((0 0 0 1 1) 2) . 1) (((0 0 1 0 0 1) 2) .
-1)) 2 0 nil) (4 ((((0 0 0 2) 2) . 1) (((0 1 0 0 0 0 1) 2) . -1)) 2 0 nil) (5 ((
((0 0 1 1) 2) . 1) (((0 1 0 0 0 1) 2) . -1)) 2 0 nil) (6 ((((0 0 2) 2) . 1) (((0
1 0 0 1) 2) . -1)) 2 0 nil)) nil t)) ((dpmat 18 0 ((1 ((((0 0 1 0 0 3) 4) . 1))
1 0 nil) (2 ((((0 0 0 0 0 0 1) 1) . 1)) 1 0 nil) (3 ((((0 0 0 4) 4) . 1)) 1 0
nil) (4 ((((0 0 0 0 0 4) 4) . 1)) 1 0 nil) (5 ((((0 0 0 2 0 2) 4) . 1)) 1 0 nil)
(6 ((((0 0 0 3 0 1) 4) . 1)) 1 0 nil) (7 ((((0 0 0 1 0 3) 4) . 1)) 1 0 nil) (8 (
(((0 0 0 0 1) 1) . 1)) 1 0 nil) (9 ((((0 0 3 0 0 1) 4) . 1)) 1 0 nil) (10 ((((0
0 2 1 0 1) 4) . 1)) 1 0 nil) (11 ((((0 0 1 2 0 1) 4) . 1)) 1 0 nil) (12 ((((0 0
2 0 0 2) 4) . 1)) 1 0 nil) (13 ((((0 0 1 1 0 2) 4) . 1)) 1 0 nil) (14 ((((0 0 4)
4) . 1)) 1 0 nil) (15 ((((0 0 2 2) 4) . 1)) 1 0 nil) (16 ((((0 1) 1) . 1)) 1 0
nil) (17 ((((0 0 1 3) 4) . 1)) 1 0 nil) (18 ((((0 0 3 1) 4) . 1)) 1 0 nil)) nil
t) (dpmat 6 0 ((1 ((((0 0 0 0 0 0 1) 1) . 1)) 1 0 nil) (2 ((((0 0 0 0 1) 1) . 1)
) 1 0 nil) (3 ((((0 1) 1) . 1)) 1 0 nil) (4 ((((0 0 1) 1) . 1)) 1 0 nil) (5 ((((
0 0 0 1) 1) . 1)) 1 0 nil) (6 ((((0 0 0 0 0 1) 1) . 1)) 1 0 nil)) nil t)))

    for each x in u collect easydim!* cadr x;


(3 0)

    for each x in u collect degree!* car x;


(16 20)


	% Hence the embedded component is a trivial one. Let's divide
	% it out by a stable ideal quotient calculation :

    algebraic;


    setideal(n2,matstabquot(n,vars));


{x2**4 - 2*x1*x2**2*x4 + x1**2*x4**2,
x3**4 - 2*x1*x3**2*x6 + x1**2*x6**2,
x5**4 - 2*x4*x5**2*x6 + x4**2*x6**2,
x2**2*x3**2 - 2*x1*x2*x3*x5 + x1**2*x5**2,
x3**2*x5**2 - 2*x2*x3*x5*x6 + x2**2*x6**2,
x2**3*x3 - x1*x2*x3*x4 - x1*x2**2*x5 + x1**2*x4*x5,
x2*x3**3 - x1*x3**2*x5 - x1*x2*x3*x6 + x1**2*x5*x6,
x2**2*x3*x4 - x1*x3*x4**2 - x2**3*x5 + x1*x2*x4*x5,
x2**2*x3*x5 - x1*x3*x4*x5 - x2**3*x6 + x1*x2*x4*x6,
x2*x3**2*x5 - x1*x3*x5**2 - x2**2*x3*x6 + x1*x2*x5*x6,
x3**3*x5 - x2*x3**2*x6 - x1*x3*x5*x6 + x1*x2*x6**2,
x2**2*x5**2 - x1*x4*x5**2 - x2**2*x4*x6 + x1*x4**2*x6,
x2*x3*x5**2 - x1*x5**3 - x2*x3*x4*x6 + x1*x4*x5*x6,
x3*x4*x5**2 - x2*x5**3 - x3*x4**2*x6 + x2*x4*x5*x6,
x3*x5**3 - x3*x4*x5*x6 - x2*x5**2*x6 + x2*x4*x6**2,
x3**2*x4 - 2*x2*x3*x5 + x1*x5**2 + x2**2*x6 - x1*x4*x6}$

    modequalp(n1,n2);


yes$



comment

	########################################
	###				     ###
	###  Test Examples for New Features  ###
	###				     ###
	########################################

end comment;



% ==> Testing the different zerodimensional solver 

	vars:={x,y,z}$


	setring(vars,degreeorder vars,revlex);


{{x,y,z},{{1,1,1}},revlex,{1,1,1}}$

	setideal(m,{x^3+y+z-3,y^3+x+z-3,z^3+x+y-3});


{x**3 + y + z - 3,y**3 + x + z - 3,z**3 + x + y - 3}$

	zerosolve1 m;


{{x + y + z**3 - 3,
y + z**3 + z - 3,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x + y + z**3 - 3,
2*y + z**3 - 3,
z**6 - 2*z**4 - 6*z**3 + 4*z**2 + 6*z + 5},
{x + y + z,
y**2 + y*z + z**2 - 1,
z**3 - z - 3},
{x + z**3 + z - 3,
y - z,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x - z,y - z,z**2 + z + 3},
{x - 1,y - 1,z - 1}}$

	zerosolve2 m;


{{x + y + z**3 - 3,
y + z**3 + z - 3,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x + y + z**3 - 3,
2*y + z**3 - 3,
z**6 - 2*z**4 - 6*z**3 + 4*z**2 + 6*z + 5},
{x + y + z,
y**2 + y*z + z**2 - 1,
z**3 - z - 3},
{x + z**3 + z - 3,
y - z,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x - z,y - z,z**2 + z + 3},
{x - 1,y - 1,z - 1}}$

	setring(vars,{},lex)$

 setideal(m,m)$

 m1:=gbasis m$


	zerosolve  m1;


{{x - 1,y - 1,z - 1},
{x - z,y - z,z**2 + z + 3},
{x + y + z,
y**2 + y*z + z**2 - 1,
z**3 - z - 3},
{2*x + z**3 - 3,
2*y + z**3 - 3,
z**6 - 2*z**4 - 6*z**3 + 4*z**2 + 6*z + 5},
{x + z**3 + z - 3,
y - z,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x - z,
y + z**3 + z - 3,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8}}$

	zerosolve1 m1;


{{x - 1,y - 1,z - 1},
{x - z,y - z,z**2 + z + 3},
{x + y + z,
y**2 + y*z + z**2 - 1,
z**3 - z - 3},
{x - y,
2*y + z**3 - 3,
z**6 - 2*z**4 - 6*z**3 + 4*z**2 + 6*z + 5},
{x + z**3 + z - 3,
y - z,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x - z,
y + z**3 + z - 3,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8}}$

	zerosolve2 m1;


{{x - 1,y - 1,z - 1},
{x - z,y - z,z**2 + z + 3},
{x + y + z,
y**2 + y*z + z**2 - 1,
z**3 - z - 3},
{x - y,
2*y + z**3 - 3,
z**6 - 2*z**4 - 6*z**3 + 4*z**2 + 6*z + 5},
{x + z**3 + z - 3,
y - z,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8},
{x - z,
y + z**3 + z - 3,
z**6 + z**4 - 6*z**3 + z**2 - 3*z + 8}}$


% ==> Testing groebfactor, extendedgroebfactor, extendedgroebfactor1 

  % Gerdt et al. : Seventh order KdV type equation.

A1:=-2*L1**2+L1*L2+2*L1*L3-L2**2-7*L5+21*L6$


A2:=7*L7-2*L1*L4+3/7*L1**3$


B1:=L1*(5*L1-3*L2+L3)$


B2:=L1*(2*L6-4*L4)$


B3:=L1*L7/2$


P1:=L1*(L4-L5/2+L6)$


P2:=(2/7*L1**2-L4)*(-10*L1+5*L2-L3)$


P3:=(2/7*L1**2-L4)*(3*L4-L5+L6)$


P4:=A1*(-3*L1+2*L2)+21*A2$


P5:=A1*(2*L4-2*L5)+A2*(-45*L1+15*L2-3*L3)$


P6:=2*A1*L7+A2*(12*L4-3*L5+2*L6)$


P7:=B1*(2*L2-L1)+7*B2$


P8:=B1*L3+7*B2$


P9:=B1*(-2*L4-2*L5)+B2*(2*L2-8*L1)+84*B3$


P10:=B1*(8/3*L5+6*L6)+B2*(11*L1-17/3*L2+5/3*L3)-168*B3$


P11:=15*B1*L7+B2*(5*L4-2*L5)+B3*(-120*L1+30*L2-6*L3)$


P12:=-3*B1*L7+B2*(-L4/2+L5/4-L6/2)+B3*(24*L1-6*L2)$


P13:=3*B2*L7+B3*(40*L4-8*L5+4*L6)$



polys:={P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13};


polys := {(l1*(2*l4 - l5 + 2*l6))/2,
( - 20*l1**3 + 10*l1**2*l2 - 2*l1**2*l3 + 70*l1*l4 - 35*l2*l4 + 7*l3*l4)/7,
(6*l1**2*l4 - 2*l1**2*l5 + 2*l1**2*l6 - 21*l4**2 + 7*l4*l5 - 7*l4*l6)/7,
15*l1**3 - 7*l1**2*l2 - 6*l1**2*l3 + 5*l1*l2**2 + 4*l1*l2*l3 - 42*l1*l4 + 21*l1*
l5 - 63*l1*l6 - 2*l2**3 - 14*l2*l5 + 42*l2*l6 + 147*l7,
( - 135*l1**4 + 45*l1**3*l2 - 9*l1**3*l3 + 602*l1**2*l4 + 28*l1**2*l5 - 196*l1*
l2*l4 - 14*l1*l2*l5 + 70*l1*l3*l4 - 28*l1*l3*l5 - 2205*l1*l7 - 14*l2**2*l4 + 14*
l2**2*l5 + 735*l2*l7 - 147*l3*l7 - 98*l4*l5 + 294*l4*l6 + 98*l5**2 - 294*l5*l6)/
7,
(36*l1**3*l4 - 9*l1**3*l5 + 6*l1**3*l6 - 28*l1**2*l7 + 14*l1*l2*l7 + 28*l1*l3*l7
 - 168*l1*l4**2 + 42*l1*l4*l5 - 28*l1*l4*l6 - 14*l2**2*l7 + 588*l4*l7 - 245*l5*
l7 + 392*l6*l7)/7,
l1*( - 5*l1**2 + 13*l1*l2 - l1*l3 - 6*l2**2 + 2*l2*l3 - 28*l4 + 14*l6),
l1*(5*l1*l3 - 3*l2*l3 + l3**2 - 28*l4 + 14*l6),
2*l1*(11*l1*l4 - 5*l1*l5 - 8*l1*l6 - l2*l4 + 3*l2*l5 + 2*l2*l6 - l3*l4 - l3*l5 +
 21*l7),
(4*l1*( - 33*l1*l4 + 10*l1*l5 + 39*l1*l6 + 17*l2*l4 - 6*l2*l5 - 22*l2*l6 - 5*l3*
l4 + 2*l3*l5 + 7*l3*l6 - 63*l7))/3,
l1*(15*l1*l7 - 30*l2*l7 + 12*l3*l7 - 20*l4**2 + 8*l4*l5 + 10*l4*l6 - 4*l5*l6),
(l1*( - 6*l1*l7 + 12*l2*l7 - 6*l3*l7 + 4*l4**2 - 2*l4*l5 + 2*l4*l6 + l5*l6 - 2*
l6**2))/2,
4*l1*l7*(2*l4 - l5 + 2*l6)}$

vars:={L7,L6,L5,L4,L3,L2,L1};


vars := {l7,
l6,
l5,
l4,
l3,
l2,
l1}$

clear a1,a2,b1,b2,b3$



	off lexefgb;

 
	setring(vars,{},lex);


{{l7,l6,l5,l4,l3,l2,l1},{},lex,{1,1,1,1,1,1,1}}$


  % The factorized Groebner algorithm.
	groebfactor polys;


{{l1,l4,l7,21*l6 - 7*l5 - l2**2},
{l1,
l4,
7*l5 - l3*l2 + 5*l2**2,
56*l6 - 5*l3*l2 + 23*l2**2,
588*l7 + 7*l3*l2**2 - 37*l2**3},
{l1,
l7,
l3 - 5*l2,
14*l6 - 21*l4 - l2**2,
14*l5 - 63*l4 - l2**2},
{l1,l4,l2,l5,l7},
{7*l4 - 2*l1**2,
l2 - 2*l1,
l3 - 3*l1,
147*l7 - 4*l1**3,
7*l5 - 6*l1**2,
7*l6 - l1**2},
{7*l4 - 2*l1**2,
2*l2 - 7*l1,
l3 - 6*l1,
147*l7 - 4*l1**3,
7*l5 - 9*l1**2,
14*l6 - 5*l1**2},
{l1,
l3 - 5*l2,
63*l4 + 2*l2**2,
63*l5 + 2*l2**2,
63*l6 - 4*l2**2,
1323*l7 + 10*l2**3},
{l1,l2,l3,l7,l5 - l4,l6 + 2*l4},
{l2 - 3*l1,
l3 - 5*l1,
14*l4 - 5*l1**2,
98*l7 - 5*l1**3,
7*l5 - 10*l1**2,
14*l6 - 5*l1**2}}$


  % The extended Groebner factorizer, producing triangular sets.
	extendedgroebfactor polys;


{{{98*l7 - 5*l1**3,
14*l6 - 5*l1**2,
7*l5 - 10*l1**2,
14*l4 - 5*l1**2,
l3 - 5*l1,
l2 - 3*l1},
{},
{l1}},
{{l7,l6 + 2*l4,l5 - l4,l3,l2,l1},{},{l4}},
{{1323*l7 + 10*l2**3,
63*l6 - 4*l2**2,
63*l5 + 2*l2**2,
63*l4 + 2*l2**2,
l3 - 5*l2,
l1},
{},
{l2}},
{{147*l7 - 4*l1**3,
14*l6 - 5*l1**2,
7*l5 - 9*l1**2,
7*l4 - 2*l1**2,
l3 - 6*l1,
2*l2 - 7*l1},
{},
{l1}},
{{147*l7 - 4*l1**3,
7*l6 - l1**2,
7*l5 - 6*l1**2,
7*l4 - 2*l1**2,
l3 - 3*l1,
l2 - 2*l1},
{},
{l1}},
{{l7,l5,l4,l2,l1},{},{l6,l3}},
{{l7,
14*l6 - (l2**2 + 21*l4),
14*l5 - (l2**2 + 63*l4),
l3 - 5*l2,
l1},
{},
{l4,l2}},
{{588*l7 - (37*l2**3 - 7*l2**2*l3),
56*l6 + (23*l2**2 - 5*l2*l3),
7*l5 + (5*l2**2 - l2*l3),
l4,
l1},
{},
{l3,l2}},
{{l7,21*l6 - (l2**2 + 7*l5),l4,l1},{},{l5,l3,l2}}}$


  % The extended Groebner factorizer with subproblem removal check. 
	extendedgroebfactor1 polys;


{{{l7,21*l6 - (l2**2 + 7*l5),l4,l1},{},{l5,l3,l2}},
{{588*l7 - (37*l2**3 - 7*l2**2*l3),
56*l6 + (23*l2**2 - 5*l2*l3),
7*l5 + (5*l2**2 - l2*l3),
l4,
l1},
{},
{l3,l2}},
{{l7,
14*l6 - (l2**2 + 21*l4),
14*l5 - (l2**2 + 63*l4),
l3 - 5*l2,
l1},
{},
{l4,l2}},
{{l7,l5,l4,l2,l1},{},{l6,l3}},
{{147*l7 - 4*l1**3,
7*l6 - l1**2,
7*l5 - 6*l1**2,
7*l4 - 2*l1**2,
l3 - 3*l1,
l2 - 2*l1},
{},
{l1}},
{{147*l7 - 4*l1**3,
14*l6 - 5*l1**2,
7*l5 - 9*l1**2,
7*l4 - 2*l1**2,
l3 - 6*l1,
2*l2 - 7*l1},
{},
{l1}},
{{1323*l7 + 10*l2**3,
63*l6 - 4*l2**2,
63*l5 + 2*l2**2,
63*l4 + 2*l2**2,
l3 - 5*l2,
l1},
{},
{l2}},
{{l7,l6 + 2*l4,l5 - l4,l3,l2,l1},{},{l4}},
{{98*l7 - 5*l1**3,
14*l6 - 5*l1**2,
7*l5 - 10*l1**2,
14*l4 - 5*l1**2,
l3 - 5*l1,
l2 - 3*l1},
{},
{l1}}}$


  % Gonnet's example (ACM SIGSAM Bulletin 17 (1983), 48 - 49)

vars:={a0,a2,a3,a4,a5,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5};


vars := {a0,
a2,
a3,
a4,
a5,
b0,
b1,
b2,
b3,
b4,
b5,
c0,
c1,
c2,
c3,
c4,
c5}$

polys:={a4*b4,
a5*b1+b5+a4*b3+a3*b4,
a2*b2,a5*b5,
(a0+1+a4)*b2+a2*(b0+b1+b4)+c2,
(a0+1+a4)*(b0+b1+b4)+(a3+a5)*b2+a2*(b3+b5)+c0+c1+c4,
(a3+a5)*(b0+b1+b4)+(b3+b5)*(a0+1+a4)+c3+c5-1,
(a3+a5)*(b3+b5),
a5*(b3+b5)+b5*(a3+a5),
b5*(a0+1+2*a4)+a5*(b0+b1+2*b4)+a3*b4+a4*b3+c5,
a4*(b0+b1+2*b4)+a2*b5+a5*b2+(a0+1)*b4+c4,
a2*b4+a4*b2,
a4*b5+a5*b4,
2*a3*b3+a3*b5+a5*b3,
c3+b3*(a0+2+a4)+a3*(b0+2*b1+b4)+b5+a5*b1,
c1+(a0+2+a4)*b1+a2*b3+a3*b2+(b0+b4),
a2*b1+b2,
a5*b3+a3*b5,
b4+a4*b1};


polys := {a4*b4,
a3*b4 + a4*b3 + a5*b1 + b5,
a2*b2,
a5*b5,
a0*b2 + a2*b0 + a2*b1 + a2*b4 + a4*b2 + b2 + c2,
a0*b0 + a0*b1 + a0*b4 + a2*b3 + a2*b5 + a3*b2 + a4*b0 + a4*b1 + a4*b4 + a5*b2 + 
b0 + b1 + b4 + c0 + c1 + c4,
a0*b3 + a0*b5 + a3*b0 + a3*b1 + a3*b4 + a4*b3 + a4*b5 + a5*b0 + a5*b1 + a5*b4 + 
b3 + b5 + c3 + c5 - 1,
a3*b3 + a3*b5 + a5*b3 + a5*b5,
a3*b5 + a5*b3 + 2*a5*b5,
a0*b5 + a3*b4 + a4*b3 + 2*a4*b5 + a5*b0 + a5*b1 + 2*a5*b4 + b5 + c5,
a0*b4 + a2*b5 + a4*b0 + a4*b1 + 2*a4*b4 + a5*b2 + b4 + c4,
a2*b4 + a4*b2,
a4*b5 + a5*b4,
2*a3*b3 + a3*b5 + a5*b3,
a0*b3 + a3*b0 + 2*a3*b1 + a3*b4 + a4*b3 + a5*b1 + 2*b3 + b5 + c3,
a0*b1 + a2*b3 + a3*b2 + a4*b1 + b0 + 2*b1 + b4 + c1,
a2*b1 + b2,
a3*b5 + a5*b3,
a4*b1 + b4}$


	on lexefgb;

 % Switching back to the default.
	setring(vars,{},lex);


{{a0,a2,a3,a4,a5,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5},
{},
lex,
{1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}}$

	groebfactor polys;


{{c5,
b5,
c2,
c4,
b2,
b4,
a4,
a2,
a5,
b3,
a3*b1 + 1,
b0 - b1*c3 + 2*b1,
a0 - a3*c1 + c3,
b1*c3**2 - 2*b1*c3 + b1 - c0 + c1*c3 - 2*c1,
a3*c0 - a3*c1*c3 + 2*a3*c1 + c3**2 - 2*c3 + 1},
{c5,
c4,
b5,
b4,
a4,
b2,
a5,
a3,
b1,
b3 + 1,
a0 - c3 + 2,
b0*c3 - 2*b0 + c0,
a2 - b0 - c1,
b0**2 + b0*c1 + c2,
b0*c0 + c0*c1 - c2*c3 + 2*c2,
c0**2 - c0*c1*c3 + 2*c0*c1 + c2*c3**2 - 4*c2*c3 + 4*c2},
{c5,
b5,
c2,
c4,
b2,
b4,
a4,
a2,
a5,
a3,
b3 + 1,
b0 + b1*c3 + c1,
a0 - c3 + 2,
b1*c3**2 - 2*b1*c3 + b1 - c0 + c1*c3 - 2*c1}}$

	extendedgroebfactor polys;


{{{b1*a0 + (b1 + c1),
a2,
b1*a3 + 1,
a4,
a5,
b0 + b1,
b2,
b3,
b4,
b5,
c0 + c1,
c2,
c3 - 1,
c4,
c5},
{b1,b1},
{b1,c1}},
{{a0,
a2 - b0 - c1,
a3,
a4,
a5,
b0**2 + c1*b0 + c2,
b1,
b2,
b3 + 1,
b4,
b5,
c0,
c3 - 2,
c4,
c5},
{},
{c1,c2}},
{{a0 + 1,a2,a3,a4,a5,b0 + (b1 + c1),b2,b3 + 1,b4,b5,c0 + c1,c2,c3 - 1,c4,c5},
{},
{b1,c1}},
{{a0 - (c3 - 2),
a2,
a3,
a4,
a5,
(c3**2 - 2*c3 + 1)*b0 + (c0*c3 + c1),
(c3**2 - 2*c3 + 1)*b1 - (c0 - c1*c3 + 2*c1),
b2,
b3 + 1,
b4,
b5,
c2,
c4,
c5},
{c3**2 - 2*c3 + 1,c3**2 - 2*c3 + 1},
{c0,c1,c3}},
{{a0 - (c3 - 2),
(c3 - 2)*a2 + c0 - (c1*c3 - 2*c1),
a3,
a4,
a5,
(c3 - 2)*b0 + c0,
b1,
b2,
b3 + 1,
b4,
b5,
c0**2 - (c1*c3 - 2*c1)*c0 + (c2*c3**2 - 4*c2*c3 + 4*c2),
c4,
c5},
{c3 - 2,c3 - 2},
{c1,c2,c3}},
{{(c0 - c1*c3 + 2*c1)*a0 + (c0*c3 + c1),
a2,
(c0 - c1*c3 + 2*c1)*a3 + (c3**2 - 2*c3 + 1),
a4,
a5,
(c3**2 - 2*c3 + 1)*b0 - (c0*c3 - 2*c0 - c1*c3**2 + 4*c1*c3 - 4*c1),
(c3**2 - 2*c3 + 1)*b1 - (c0 - c1*c3 + 2*c1),
b2,
b3,
b4,
b5,
c2,
c4,
c5},
{c0 - c1*c3 + 2*c1,
c0 - c1*c3 + 2*c1,
c3**2 - 2*c3 + 1,
c3**2 - 2*c3 + 1},
{c0,c1,c3}}}$

	extendedgroebfactor1 polys;


{{{(c0 - c1*c3 + 2*c1)*a0 + (c0*c3 + c1),
a2,
(c0 - c1*c3 + 2*c1)*a3 + (c3**2 - 2*c3 + 1),
a4,
a5,
(c3**2 - 2*c3 + 1)*b0 - (c0*c3 - 2*c0 - c1*c3**2 + 4*c1*c3 - 4*c1),
(c3**2 - 2*c3 + 1)*b1 - (c0 - c1*c3 + 2*c1),
b2,
b3,
b4,
b5,
c2,
c4,
c5},
{c0 - c1*c3 + 2*c1,
c0 - c1*c3 + 2*c1,
c3**2 - 2*c3 + 1,
c3**2 - 2*c3 + 1},
{c0,c1,c3}},
{{a0 - (c3 - 2),
(c3 - 2)*a2 + c0 - (c1*c3 - 2*c1),
a3,
a4,
a5,
(c3 - 2)*b0 + c0,
b1,
b2,
b3 + 1,
b4,
b5,
c0**2 - (c1*c3 - 2*c1)*c0 + (c2*c3**2 - 4*c2*c3 + 4*c2),
c4,
c5},
{c3 - 2,c3 - 2},
{c1,c2,c3}},
{{a0 - (c3 - 2),
a2,
a3,
a4,
a5,
(c3**2 - 2*c3 + 1)*b0 + (c0*c3 + c1),
(c3**2 - 2*c3 + 1)*b1 - (c0 - c1*c3 + 2*c1),
b2,
b3 + 1,
b4,
b5,
c2,
c4,
c5},
{c3**2 - 2*c3 + 1,c3**2 - 2*c3 + 1},
{c0,c1,c3}}}$


  % Schwarz' example s5

vars:=for k:=1:5 collect mkid(x,k);


vars := {x1,
x2,
x3,
x4,
x5}$


s5:={
x1**2+x1+2*x2*x5+2*x3*x4,
2*x1*x2+x2+2*x3*x5+x4**2,
2*x1*x3+x2**2+x3+2*x4*x5,
2*x1*x4+2*x2*x3+x4+x5**2,
2*x1*x5+2*x2*x4+x3**2+x5};


s5 := {x1**2 + x1 + 2*x2*x5 + 2*x3*x4,
2*x1*x2 + x2 + 2*x3*x5 + x4**2,
2*x1*x3 + x2**2 + x3 + 2*x4*x5,
2*x1*x4 + 2*x2*x3 + x4 + x5**2,
2*x1*x5 + 2*x2*x4 + x3**2 + x5}$


	setring(vars,degreeorder vars,revlex);


{{x1,x2,x3,x4,x5},{{1,1,1,1,1}},revlex,{1,1,1,1,1}}$

	m:=groebfactor s5;


m := {{x1**2 + 2*x3*x4 + 2*x2*x5 + x1,
2*x1*x2 + x4**2 + 2*x3*x5 + x2,
x2**2 + 2*x1*x3 + 2*x4*x5 + x3,
2*x2*x3 + 2*x1*x4 + x5**2 + x4,
x3**2 + 2*x2*x4 + 2*x1*x5 + x5,
2*x1*x3*x4 + 2*x4**2*x5 + x3*x5**2 + x3*x4,
5*x4**3 + 30*x3*x4*x5 + 15*x2*x5**2 - 2*x5,
10*x3*x4**2 - 10*x1*x5**2 - 5*x5**2 - x4,
625*x4*x5**3 + 50*x3*x4 + 75*x2*x5 - 6,
15*x2*x4**2 + 30*x1*x4*x5 + 5*x5**3 + 15*x4*x5 + x3,
100*x1*x4*x5**2 + 25*x5**4 + 50*x4*x5**2 + x4**2 + 4*x3*x5,
1250*x1*x3*x5**2 + 625*x3*x5**2 - 75*x3*x4 - 50*x2*x5 + 8,
75*x4**2*x5**2 + 50*x3*x5**3 + x2*x4 + 4*x1*x5 + 2*x5,
150*x3*x4*x5**2 + 100*x2*x5**3 - 2*x1*x4 - 13*x5**2 - x4,
625*x2*x5**4 - 50*x1*x4*x5 - 75*x5**3 - 25*x4*x5 - x3,
1250*x3*x5**4 - 200*x2*x4*x5 - 50*x1*x5**2 - 25*x5**2 + 3*x4,
625*x5**5 + 375*x4**2*x5 + 500*x3*x5**2 + 24*x1 + 12,
10*x1*x4**2 + 20*x1*x3*x5 + 20*x4*x5**2 + 5*x4**2 + 10*x3*x5 + x2,
75*x2*x4*x5**2 + 50*x1*x5**3 + 25*x5**3 - 2*x1*x3 - 3*x4*x5 - x3,
1250*x1*x5**4 + 625*x5**4 + 100*x1*x3*x5 + 150*x4*x5**2 + 50*x3*x5 + 3*x2},
{x5,x2,x4,x3,x1},
{x5,x2,x4,x3,x1 + 1}}$


  % Recompute a list of problems with listgroebfactor for another term 
  % order. 
	setring(vars,{},lex);


{{x1,x2,x3,x4,x5},{},lex,{1,1,1,1,1}}$

	listgroebfactor m;


{{5*x5 - 1,
5*x4 - 1,
5*x1 + 4,
5*x2 - 1,
5*x3 - 1},
{5*x5 + 1,
5*x4 + 1,
5*x1 + 1,
5*x2 + 1,
5*x3 + 1},
{5*x1 + 2,
x2 - x5,
25*x5**2 - 5*x5 - 1,
5*x4 + 5*x5 - 1,
5*x3 + 5*x5 - 1},
{5*x1 + 3,
x2 - x5,
25*x5**2 + 5*x5 - 1,
5*x4 + 5*x5 + 1,
5*x3 + 5*x5 + 1},
{5*x1 + 3,
5*x4 - 25*x5**2 + 10*x5 - 2,
x3 - 25*x5**3 + 15*x5**2 - 3*x5,
5*x2 + 125*x5**3 - 50*x5**2 + 10*x5 - 1,
625*x5**4 - 375*x5**3 + 100*x5**2 - 10*x5 + 1},
{5*x1 + 2,
5*x2 + 5*x5 - 1,
5*x4 - 250*x5**3 + 75*x5**2 - 30*x5 + 2,
5*x3 + 250*x5**3 - 75*x5**2 + 30*x5 - 3,
625*x5**4 - 250*x5**3 + 100*x5**2 - 15*x5 + 1},
{x4 + 5*x5**2,
5*x1 + 1,
x3 - 25*x5**3,
5*x2 + 125*x5**3 - 25*x5**2 + 5*x5 - 1,
625*x5**4 - 125*x5**3 + 25*x5**2 - 5*x5 + 1},
{x4 - 5*x5**2,
5*x1 + 4,
x3 - 25*x5**3,
5*x2 + 125*x5**3 + 25*x5**2 + 5*x5 + 1,
625*x5**4 + 125*x5**3 + 25*x5**2 + 5*x5 + 1},
{5*x1 + 3,
5*x2 + 5*x5 + 1,
5*x4 - 250*x5**3 - 75*x5**2 - 30*x5 - 2,
5*x3 + 250*x5**3 + 75*x5**2 + 30*x5 + 3,
625*x5**4 + 250*x5**3 + 100*x5**2 + 15*x5 + 1},
{5*x1 + 2,
5*x4 + 25*x5**2 + 10*x5 + 2,
x3 - 25*x5**3 - 15*x5**2 - 3*x5,
5*x2 + 125*x5**3 + 50*x5**2 + 10*x5 + 1,
625*x5**4 + 375*x5**3 + 100*x5**2 + 10*x5 + 1},
{x5,
x2,
x4,
x3,
x1 + 1},
{x5,
x2,
x4,
x3,
x1}}$



% ==> Testing the linear algebra package

  % Find the ideal of points in affine and projective space. 

	vars:=for k:=1:6 collect mkid(x,k);


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

	setring(vars,degreeorder vars,revlex);


{{x1,x2,x3,x4,x5,x6},{{1,1,1,1,1,1}},revlex,{1,1,1,1,1,1}}$

	matrix mm(10,6);


	on rounded;


	for k:=1:6 do for l:=1:10 do mm(l,k):=floor(exp((k+l)/4));


	off rounded;


	mm;


mat((1,2,2,3,4,5),(2,2,3,4,5,7),(2,3,4,5,7,9),(3,4,5,7,9,12),(4,5,7,9,12,15),(5,
7,9,12,15,20),(7,9,12,15,20,25),(9,12,15,20,25,33),(12,15,20,25,33,42),(15,20,25
,33,42,54))$

	setideal(u,affine_points mm);


{48337*x5**2 - 318*x4*x6 - 75336*x5*x6 + 29579*x6**2 - 11598*x1 - 11016*x2 - 
11352*x3 - 2502*x4 + 18371*x5 - 1837*x6 - 1836,
386696*x1*x6 + 175678*x4*x6 + 20108*x5*x6 - 233347*x6**2 - 5821074*x1 - 831000*
x2 + 1382952*x3 + 741984*x4 - 2153934*x5 + 2692351*x6 - 1491936,
386696*x3*x6 + 239238*x4*x6 - 185716*x5*x6 - 182039*x6**2 - 270738*x1 - 1255800*
x2 - 5052384*x3 - 2106864*x4 + 2351946*x5 + 2434483*x6 - 1562736,
48337*x4**2 - 58746*x4*x6 + 148*x5*x6 + 17725*x6**2 + 2502*x1 + 576*x2 - 1302*x3
 + 25721*x4 - 3488*x5 - 12857*x6 + 96,
193348*x4*x5 - 151394*x4*x6 - 118604*x5*x6 + 92869*x6**2 + 1590*x1 + 8712*x2 + 
16560*x3 - 3708*x4 + 43918*x5 - 43409*x6 + 1452,
386696*x2*x6 - 382090*x4*x6 - 43364*x5*x6 + 123645*x6**2 - 1313130*x1 - 4809120*
x2 + 91464*x3 + 5853096*x4 + 1118658*x5 - 2323361*x6 - 28128,
193348*x6**3 - 78919578*x4*x6 - 63413004*x5*x6 + 81565689*x6**2 + 1412352942*x1 
+ 1563160200*x2 + 761482008*x3 + 10324224*x4 + 304232130*x5 - 1255484065*x6 - 
643375200,
193348*x1*x4 - 3606*x4*x6 + 6664*x5*x6 - 36689*x6**2 - 1729374*x1 - 256248*x2 + 
422132*x3 + 345556*x4 - 671778*x5 + 747089*x6 - 429404,
193348*x3*x4 - 19782*x4*x6 - 57060*x5*x6 + 1407*x6**2 - 86718*x1 - 378840*x2 - 
1475924*x3 - 576996*x4 + 715078*x5 + 671885*x6 - 449836,
386696*x1*x5 + 139942*x4*x6 - 99156*x5*x6 - 94107*x6**2 - 4388370*x1 - 668088*x2
 + 1063040*x3 + 468112*x4 - 1464774*x5 + 1964239*x6 - 1078088,
386696*x3*x5 + 184150*x4*x6 - 329484*x5*x6 + 3733*x6**2 - 302634*x1 - 1062840*x2
 - 3845096*x3 - 1562608*x4 + 1956858*x5 + 1752663*x6 - 1143880,
193348*x1**2 + 50726*x4*x6 + 4164*x5*x6 - 49995*x6**2 - 1502518*x1 - 234624*x2 +
 337000*x3 + 189344*x4 - 544926*x5 + 709519*x6 - 425800,
193348*x1*x2 - 22834*x4*x6 - 3056*x5*x6 - 4123*x6**2 - 1183010*x1 - 780060*x2 + 
282940*x3 + 989552*x4 - 238902*x5 + 102179*x6 - 226684,
386696*x1*x3 + 153254*x4*x6 - 46332*x5*x6 - 109011*x6**2 - 2706290*x1 - 776040*
x2 - 650592*x3 - 288096*x4 - 295470*x5 + 1856303*x6 - 1096080,
96674*x3**2 + 56278*x4*x6 - 44916*x5*x6 - 20423*x6**2 - 85218*x1 - 315900*x2 - 
1104614*x3 - 478348*x4 + 559514*x5 + 528787*x6 - 342672,
193348*x2*x4 - 186922*x4*x6 - 13484*x5*x6 + 80823*x6**2 - 400398*x1 - 1437268*x2
 + 32400*x3 + 1825348*x4 + 346526*x5 - 749039*x6 - 13972,
386696*x2*x5 - 299774*x4*x6 - 183476*x5*x6 + 214259*x6**2 - 1032390*x1 - 3818088
*x2 + 38568*x3 + 4563624*x4 + 1175646*x5 - 2005927*x6 - 56304,
193348*x5*x6**2 - 59111766*x4*x6 - 58092824*x5*x6 + 68856463*x6**2 + 1134803514*
x1 + 1224865560*x2 + 591403776*x3 - 36549312*x4 + 316517430*x5 - 1023460331*x6 -
 498675720,
96674*x2**2 - 69590*x4*x6 - 7908*x5*x6 + 35327*x6**2 - 243426*x1 - 832910*x2 + 
14700*x3 + 1041208*x4 + 204662*x5 - 420851*x6 - 26032,
386696*x2*x3 - 95202*x4*x6 - 92692*x5*x6 + 63421*x6**2 - 736122*x1 - 2670472*x2 
- 1669344*x3 + 2061800*x4 + 1466002*x5 - 394913*x6 - 509528,
96674*x4*x6**2 - 29277416*x4*x6 - 19752504*x5*x6 + 28388673*x6**2 + 433544670*x1
 + 473916360*x2 + 235723620*x3 + 39729120*x4 + 97903830*x5 - 411516489*x6 - 
188800920}$
 setgbasis u$

 dim u;


0$
 degree u;


10$

	setideal(u,proj_points mm);


{457380*x5**3 - 13500*x2*x5*x6 - 20835*x3*x5*x6 + 76950*x4*x5*x6 - 1050234*x5**2
*x6 + 100*x1*x6**2 + 10800*x2*x6**2 + 16568*x3*x6**2 - 60271*x4*x6**2 + 771366*
x5*x6**2 - 179875*x6**3,
330*x4**2 + 1665*x2*x5 + 555*x3*x5 - 4337*x4*x5 - 626*x5**2 + 6*x1*x6 - 1332*x2*
x6 - 450*x3*x6 + 3013*x4*x6 + 2740*x5*x6 - 1635*x6**2,
33*x1*x5 - 90*x2*x5 - 63*x3*x5 + 216*x4*x5 + 60*x5**2 - 25*x1*x6 + 72*x2*x6 + 49
*x3*x6 - 170*x4*x6 - 171*x5*x6 + 97*x6**2,
90*x3**2 - 483*x2*x5 - 183*x3*x5 + 1197*x4*x5 + 174*x5**2 - 2*x1*x6 + 384*x2*x6 
+ 68*x3*x6 - 937*x4*x6 - 738*x5*x6 + 485*x6**2,
330*x3*x4 + 555*x2*x5 + 75*x3*x5 - 1519*x4*x5 - 172*x5**2 + 2*x1*x6 - 444*x2*x6 
- 260*x3*x6 + 1041*x4*x6 + 950*x5*x6 - 545*x6**2,
457380*x4*x5**2 - 10800*x2*x5*x6 - 9045*x3*x5*x6 - 662625*x4*x5*x6 - 265413*x5**
2*x6 + 80*x1*x6**2 + 8640*x2*x6**2 + 7156*x3*x6**2 + 238408*x4*x6**2 + 391452*x5
*x6**2 - 143900*x6**3,
495*x1*x2 + 1977*x2*x5 + 87*x3*x5 - 4824*x4*x5 - 339*x5**2 - 164*x1*x6 - 1707*x2
*x6 - 97*x3*x6 + 3782*x4*x6 + 2697*x5*x6 - 1840*x6**2,
495*x2**2 + 1134*x2*x5 + 939*x3*x5 - 3771*x4*x5 - 822*x5**2 - 4*x1*x6 - 1257*x2*
x6 - 734*x3*x6 + 2956*x4*x6 + 2709*x5*x6 - 1550*x6**2,
990*x1*x3 - 5043*x2*x5 - 1263*x3*x5 + 12321*x4*x5 + 1866*x5**2 - 464*x1*x6 + 
4008*x2*x6 + 788*x3*x6 - 9643*x4*x6 - 7968*x5*x6 + 5165*x6**2,
495*x2*x3 + 1242*x2*x5 - 48*x3*x5 - 3555*x4*x5 - 267*x5**2 + 4*x1*x6 - 1218*x2*
x6 - 157*x3*x6 + 2786*x4*x6 + 2142*x5*x6 - 1420*x6**2,
66*x1*x4 + 345*x2*x5 + 93*x3*x5 - 861*x4*x5 - 120*x5**2 - 38*x1*x6 - 276*x2*x6 -
 76*x3*x6 + 659*x4*x6 + 540*x5*x6 - 337*x6**2,
495*x2*x4 + 1770*x2*x5 + 645*x3*x5 - 4908*x4*x5 - 729*x5**2 + 4*x1*x6 - 1713*x2*
x6 - 520*x3*x6 + 3677*x4*x6 + 3165*x5*x6 - 1915*x6**2,
152460*x3*x5**2 + 5880*x2*x5*x6 - 237983*x3*x5*x6 - 6896*x4*x5*x6 - 71438*x5**2*
x6 + 64*x1*x6**2 - 4704*x2*x6**2 + 92748*x3*x6**2 + 5427*x4*x6**2 + 113560*x5*x6
**2 - 45061*x6**3,
990*x1**2 - 1893*x2*x5 + 447*x3*x5 + 3771*x4*x5 + 426*x5**2 - 524*x1*x6 + 1488*
x2*x6 - 322*x3*x6 - 2923*x4*x6 - 2478*x5*x6 + 1715*x6**2,
457380*x2*x5**2 - 754524*x2*x5*x6 - 31530*x3*x5*x6 + 156561*x4*x5*x6 - 132597*x5
**2*x6 + 136*x1*x6**2 + 310896*x2*x6**2 + 25088*x3*x6**2 - 122581*x4*x6**2 + 
141732*x5*x6**2 - 30097*x6**3}$
 setgbasis u$

 dim u;


1$
 degree u;


10$


  % Change the term order to pure lex in dimension zero.
  % Test both approaches, with and without precomputed borderbasis.

	vars:=for k:=1:6 collect mkid(x,k);


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

	r1:=setring(vars,{},lex);


r1 := {{x1,x2,x3,x4,x5,x6},{},lex,{1,1,1,1,1,1}}$

	r2:=setring(vars,degreeorder vars,revlex);


r2 := {{x1,x2,x3,x4,x5,x6},{{1,1,1,1,1,1}},revlex,{1,1,1,1,1,1}}$

	setideal(m,{x1**2+x1+2*x2*x6+2*x3*x5+x4**2,
		2*x1*x2+x2+2*x3*x6+2*x4*x5,
		2*x1*x3+x2**2+x3+2*x4*x6+x5**2,
		2*x1*x4+2*x2*x3+x4+2*x5*x6,
		2*x1*x5+2*x2*x4+x3**2+x5+x6**2,
		2*x1*x6+2*x2*x5+2*x3*x4+x6});


{x1**2 + x4**2 + 2*x3*x5 + 2*x2*x6 + x1,
2*x1*x2 + 2*x4*x5 + 2*x3*x6 + x2,
x2**2 + 2*x1*x3 + x5**2 + 2*x4*x6 + x3,
2*x2*x3 + 2*x1*x4 + 2*x5*x6 + x4,
x3**2 + 2*x2*x4 + 2*x1*x5 + x6**2 + x5,
2*x3*x4 + 2*x2*x5 + 2*x1*x6 + x6}$

	gbasis m;


{72*x1*x3*x5*x6 + 36*x3*x5*x6 - 2*x1*x6 - x6,
2*x1*x2 + 2*x4*x5 + 2*x3*x6 + x2,
2*x2*x3 + 2*x1*x4 + 2*x5*x6 + x4,
2*x3*x4 + 2*x2*x5 + 2*x1*x6 + x6,
10368*x6**7 + 5040*x4*x6**4 + 140*x4**2*x6 + 252*x2*x6**2 - 15*x6,
1296*x4*x6**5 + 180*x4**2*x6**2 + 180*x2*x6**3 + 4*x2*x4 - 15*x6**2,
2592*x3*x6**5 - 360*x2*x5*x6**2 + 2*x1*x4 + 12*x5*x6 + x4,
72*x3*x5**2*x6 + 72*x2*x5*x6**2 - 2*x1*x4 - 8*x5*x6 - x4,
36*x2*x5**3 - 108*x1*x4*x6**2 - 72*x5*x6**3 - 54*x4*x6**2 - 5*x3*x6,
18*x4**2*x5 + 18*x3*x5**2 - 18*x1*x6**2 - 9*x6**2 - 2*x5,
36*x4*x5**2 + 36*x4**2*x6 + 72*x3*x5*x6 + 36*x2*x6**2 - 5*x6,
x1**2 + x4**2 + 2*x3*x5 + 2*x2*x6 + x1,
x2**2 + 2*x1*x3 + x5**2 + 2*x4*x6 + x3,
x3**2 + 2*x2*x4 + 2*x1*x5 + x6**2 + x5,
2592*x5*x6**5 + 360*x4*x5*x6**2 + 360*x3*x6**3 - 2*x2*x5 + 10*x1*x6 + 5*x6,
2592*x5**2*x6**3 + 1296*x4*x6**4 + 36*x4**2*x6 + 144*x3*x5*x6 + 180*x2*x6**2 - 
13*x6,
72*x5**3*x6 + 216*x4*x5*x6**2 + 72*x3*x6**3 + 2*x2*x5 + 6*x1*x6 + 3*x6,
4*x4**3 - 12*x2*x5**2 - 24*x1*x5*x6 - 4*x6**3 - 12*x5*x6 - x4,
12*x2*x4**2 - 24*x1*x3*x6 - 12*x5**2*x6 - 12*x4*x6**2 - 12*x3*x6 - x2,
1296*x1*x6**5 + 648*x6**5 + 180*x1*x4*x6**2 + 180*x5*x6**3 + 90*x4*x6**2 + x4*x5
 + 6*x3*x6,
2592*x2*x6**5 + 360*x2*x4*x6**2 - 180*x6**4 - 6*x1*x3 - 3*x5**2 - 16*x4*x6 - 3*
x3,
72*x3*x5*x6**3 + 36*x2*x6**4 - x2*x5**2 - 4*x2*x4*x6 - 4*x1*x5*x6 - 6*x6**3 - 2*
x5*x6,
648*x4*x5*x6**3 + 324*x3*x6**4 - 9*x3*x5**2 - 18*x2*x5*x6 + 18*x1*x6**2 + 9*x6**
2 + x5,
2592*x1*x3*x6**3 + 1296*x4*x6**4 + 1296*x3*x6**3 - 36*x4**2*x6 - 72*x3*x5*x6 + 
36*x2*x6**2 + 5*x6,
1080*x2*x4*x6**3 + 216*x6**5 - 60*x1*x3*x6 - 30*x5**2*x6 - 90*x4*x6**2 - 30*x3*
x6 - x2,
72*x4**2*x6**3 + 36*x2*x6**4 + 3*x2*x5**2 + 8*x2*x4*x6 + 6*x1*x5*x6 - 2*x6**3 + 
3*x5*x6,
36*x1*x5**2*x6 + 36*x1*x4*x6**2 + 36*x5*x6**3 + 18*x5**2*x6 + 18*x4*x6**2 + x4*
x5 + 2*x3*x6,
18*x1*x5**3 - 54*x1*x3*x6**2 - 36*x4*x6**3 + 9*x5**3 - 27*x3*x6**2 + x3*x5 - 2*
x2*x6,
18*x1*x4*x5 + 18*x1*x3*x6 + 18*x5**2*x6 + 18*x4*x6**2 + 9*x4*x5 + 9*x3*x6 + x2,
18*x2*x4*x5 + 18*x1*x5**2 + 18*x1*x4*x6 + 18*x5*x6**2 + 9*x5**2 + 9*x4*x6 + x3,
2*x1*x4**2 + 4*x1*x3*x5 + 2*x5**3 + 8*x4*x5*x6 + 2*x3*x6**2 + x4**2 + 2*x3*x5,
72*x1*x4*x6**3 + 36*x5*x6**4 + 36*x4*x6**3 - 2*x1*x3*x5 - x5**3 - 2*x4*x5*x6 + 2
*x3*x6**2 - x3*x5,
3240*x1*x5*x6**3 + 648*x6**5 + 1620*x5*x6**3 + 90*x1*x3*x6 + 90*x5**2*x6 + 180*
x4*x6**2 + 45*x3*x6 + 2*x2,
72*x2*x5**2*x6 + 72*x2*x4*x6**2 + 144*x1*x5*x6**2 + 36*x6**4 + 72*x5*x6**2 - 2*
x1*x3 - x5**2 - x3,
36*x5**4 - 216*x4**2*x6**2 - 432*x3*x5*x6**2 - 288*x2*x6**3 + 2*x2*x4 + 8*x1*x5 
+ 39*x6**2 + 4*x5,
72*x3*x5**3 - 216*x1*x5*x6**2 - 36*x6**4 - 108*x5*x6**2 - 2*x1*x3 - 9*x5**2 - 8*
x4*x6 - x3,
1296*x2*x5*x6**3 + 648*x1*x6**4 + 324*x6**4 - 18*x1*x5**2 - 36*x1*x4*x6 - 72*x5*
x6**2 - 9*x5**2 - 18*x4*x6 - x3,
18*x1*x3*x5**2 + 18*x4**2*x6**2 + 54*x3*x5*x6**2 + 36*x2*x6**3 + 9*x3*x5**2 - x2
*x4 - 2*x1*x5 - 5*x6**2 - x5}$

	m1:=change_termorder(m,r1);


m1 := {46656*x4*x5*x6**6 - x4*x5,
80621568*x5*x6**13 + 44928*x5*x6**7 - x5*x6,
637*x2 + 1077507256320*x6**17 - 927987840*x6**11 - 806157*x6**5,
7*x4**2*x5 + 252*x4*x5*x6**3 - 30233088*x5*x6**12 - 17496*x5*x6**6,
58773123072*x6**19 - 47869056*x6**13 - 45657*x6**7 + x6,
2*x1*x4 + x4 + 1296*x5**3*x6**3 + 3*x5*x6,
2548*x4**2*x6 + 91728*x4*x6**4 + 362797056*x6**13 - 33696*x6**7 - 141*x6,
8491392*x4*x6**7 - 182*x4*x6 + 19591041024*x6**16 + 10917504*x6**10 - 243*x6**4,
17199*x5**4*x6 + 1238328*x5**2*x6**5 + 4353564672*x6**15 - 5003856*x6**9 - 1328*
x6**3,
4245696*x5**2*x6**7 - 91*x5**2*x6 + 8707129344*x6**17 - 12130560*x6**11 + 256*x6
**5,
7*x3 - 567*x5**5 - 204120*x5**3*x6**4 + 524880*x5*x6**8 - 90*x5*x6**2,
2916*x5**7 - 567*x5**3*x6**2 + 347680512*x5*x6**12 + 196668*x5*x6**6 - 4*x5,
14*x1*x6 + 504*x4*x5*x6**2 + 252*x5**3*x6 + 20155392*x5*x6**11 + 8640*x5*x6**5 +
 7*x6,
2548*x4**3 + 19813248*x4*x6**6 - 637*x4 + 39182082048*x6**15 + 30326400*x6**9 + 
4428*x6**3,
1911*x4*x5**2 - 68796*x4*x6**4 - 68796*x5**2*x6**3 - 362797056*x6**13 + 151632*
x6**7 + 50*x6,
1274*x1*x5 + 1651104*x4*x6**5 + 5733*x5**4 + 1238328*x5**2*x6**4 + 637*x5 + 
6530347008*x6**14 - 1667952*x6**8 + 192*x6**2,
1274*x1**2 + 1274*x1 + 1274*x4**2 + 206388*x5**6 - 85995*x5**2*x6**2 - 
11754624614400*x6**18 + 9498228480*x6**12 + 9295668*x6**6}$

	setring r2$

 m2:=change_termorder1(m,r1);


m2 := {46656*x4*x5*x6**6 - x4*x5,
80621568*x5*x6**13 + 44928*x5*x6**7 - x5*x6,
2*x1*x4 + x4 + 1296*x5**3*x6**3 + 3*x5*x6,
637*x2 + 1077507256320*x6**17 - 927987840*x6**11 - 806157*x6**5,
7*x4**2*x5 + 252*x4*x5*x6**3 - 30233088*x5*x6**12 - 17496*x5*x6**6,
58773123072*x6**19 - 47869056*x6**13 - 45657*x6**7 + x6,
2548*x4**2*x6 + 91728*x4*x6**4 + 362797056*x6**13 - 33696*x6**7 - 141*x6,
17199*x5**4*x6 + 1238328*x5**2*x6**5 + 4353564672*x6**15 - 5003856*x6**9 - 1328*
x6**3,
4245696*x5**2*x6**7 - 91*x5**2*x6 + 8707129344*x6**17 - 12130560*x6**11 + 256*x6
**5,
7*x3 - 567*x5**5 - 204120*x5**3*x6**4 + 524880*x5*x6**8 - 90*x5*x6**2,
8491392*x4*x6**7 - 182*x4*x6 + 19591041024*x6**16 + 10917504*x6**10 - 243*x6**4,
2916*x5**7 - 567*x5**3*x6**2 + 347680512*x5*x6**12 + 196668*x5*x6**6 - 4*x5,
14*x1*x6 + 504*x4*x5*x6**2 + 252*x5**3*x6 + 20155392*x5*x6**11 + 8640*x5*x6**5 +
 7*x6,
1911*x4*x5**2 - 68796*x4*x6**4 - 68796*x5**2*x6**3 - 362797056*x6**13 + 151632*
x6**7 + 50*x6,
2548*x4**3 + 19813248*x4*x6**6 - 637*x4 + 39182082048*x6**15 + 30326400*x6**9 + 
4428*x6**3,
1274*x1*x5 + 1651104*x4*x6**5 + 5733*x5**4 + 1238328*x5**2*x6**4 + 637*x5 + 
6530347008*x6**14 - 1667952*x6**8 + 192*x6**2,
1274*x1**2 + 1274*x1 + 1274*x4**2 + 206388*x5**6 - 85995*x5**2*x6**2 - 
11754624614400*x6**18 + 9498228480*x6**12 + 9295668*x6**6}$

	setideal(m1,m1)$

 setideal(m2,m2)$


	setgbasis m1$

 setgbasis m2$

 modequalp(m1,m2);


yes$


% ==> Different hilbert series driver
   
    setideal(m,proj_monomial_curve(w1:={0,2,5,9},{w,x,y,z}));


{x**5 - w**3*y**2,
w*y**3 - x**3*z,
y**4 - w*x*z**2,
x**2*y - w**2*z}$

    weights:={{1,1,1,1},w1};


weights := {{1,1,1,1},{0,2,5,9}}$

    hftestversion 2;


hf!=whilb2$

    f1:=weightedhilbertseries(gbasis m,weights);


f1 := ( - w**5*x**17 + w**4*x**17 - w**4*x**15 + w**4*x**8 + w**3*x**15 + w**3*x
**12 + w**3*x**6 + w**2*x**10 + w**2*x**7 + w**2*x**4 + w*x**5 + w*x**2 + 1)/(w
**2*x**9 - w*x**9 - w + 1)$

    sub(x=1,ws);


( - w**5 + w**4 + 3*w**3 + 3*w**2 + 2*w + 1)/(w**2 - 2*w + 1)$
 % The ordinary Hilbert series.
    hftestversion 1;


hf!=whilb1$
 % The default.
    f2:=weightedhilbertseries(gbasis m,weights);


f2 := ( - w**5*x**17 + w**4*x**17 - w**4*x**15 + w**4*x**8 + w**3*x**15 + w**3*x
**12 + w**3*x**6 + w**2*x**10 + w**2*x**7 + w**2*x**4 + w*x**5 + w*x**2 + 1)/(w
**2*x**9 - w*x**9 - w + 1)$

    sub(x=1,ws);


( - w**5 + w**4 + 3*w**3 + 3*w**2 + 2*w + 1)/(w**2 - 2*w + 1)$
 
    f1-f2;


0$


% ==> Different primary decomposition approaches. The example is due
	% to Shimoyama Takeshi. CALI 2.2. produced auxiliary embedded
	% primes on it.

    vars:={dx,dy,x,y};


vars := {dx,dy,x,y}$

    setring(vars,degreeorder vars,revlex);


{{dx,dy,x,y},{{1,1,1,1}},revlex,{1,1,1,1}}$

    f3:={DY*( - X*DX + Y**2*DY - Y*DY),DX*(X**2*DX - X*DX - Y*DY)}$


    primarydecomposition f3;


{{{dx**3,
dy**3,
dx**2*dy,
dx*dy**2,
dy*( - dx*x + dy*y**2 - dy*y),
dx*(dx*x**2 - dx*x - dy*y)},
{dx,dy}},
{{x*y - x - y,
dx*x - dx - dy*y + dy,
 - dx + dy*y**2 - 2*dy*y + dy},
{x*y - x - y,
dx*x - dx - dy*y + dy,
 - dx + dy*y**2 - 2*dy*y + dy}},
{{dy,x - 1},{dy,x - 1}},
{{dy**2,
dy*x,
x**2,
dx*x + dy*y},
{dy,x}},
{{dx,y - 1},{dx,y - 1}},
{{dx**2,
dx*y,
y**2,
dx*x + dy*y},
{dx,y}},
{{y**2,
x**2,
x*y,
dx*x + dy*y},
{y,x}}}$


showtime;


Time: 1481 ms  plus GC time: 172 ms


end;


Time for test: 1481 ms, plus GC time: 172 ms
@@@@@ Resources used: (2 39 90 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/cali.tst0000644000175000017500000004106011526203062023061 0ustar  giovannigiovanni% Author H.-G. Graebe | Univ. Leipzig | Version 28.6.1995
% graebe@informatik.uni-leipzig.de

COMMENT

This is an example session demonstrating and testing the facilities
offered by the commutative algebra package CALI.

END COMMENT;

algebraic;
on echo;
off nat; % To make it easier to compare differing output.
showtime;

comment

	####################################
	###				 ###
	###	Introductory Examples    ###
	###				 ###
	####################################

end comment;

% Example 1 : Generating ideals of affine and projective points.


    vars:={t,x,y,z};
    setring(vars,degreeorder vars,revlex);
    mm:=mat((1,1,1,1),(3,2,3,1),(2,1,3,2));

  % The ideal with zero set at the point in A^4 with coordinates
  % equal to the row vectors of mm :

    setideal(m1,affine_points mm);

	% All parameters are as they should be :

    dim m1;
    degree m1;
    groebfactor m1;
    resolve m1$
    bettinumbers m1;

  % The ideal with zero set at the point in P^3 with homogeneous 
  % coordinates equal to the row vectors of mm :

    setideal(m2,proj_points mm);

	% All parameters as they should be ?

    dim m2;
    degree m2;
    groebfactor m2;

	% It seems to be prime ?

    isprime m2;

	% Not, of course, but it is known to be unmixed. 
	% Hence we can use 

    easyprimarydecomposition m2;
  
% Example 2 : 
% The affine monomial curve with generic point (t^7,t^9,t^10).

    setideal(m,affine_monomial_curve({7,9,10},{x,y,z}));

	% The base ring was changed as side effect :

    getring(); 
    vars:=first getring m;

  % Some advanced commutative algebra :
  
  % The analytic spread of m.

    analytic_spread m;

  % The Rees ring Rees_R(vars) over R=S/m.
    
    rees:=blowup(m,vars,{u,v,w}); 

  % It is multihomogeneous wrt. the degree vectors, constructed during
  % blow up. Lets compute weighted Hilbert series :

    setideal(rees,rees)$
    weights:=second getring();
    weightedhilbertseries(gbasis rees,weights);

  % gr_R(vars), the associated graded ring of the irrelevant ideal
  % over R. The short way.

    interreduce sub(x=0,y=0,z=0,rees); 

  % The long (and more general) way. Gives the result in another
  % embedding. 
  
    % Restore the base ring, since it was changed by blowup as a side
    % effect.  
    setring getring m$
    assgrad(m,vars,{u,v,w}); 

  % Comparing the Rees algebra and the symmetric algebra of M :
  
    setring getring m$
    setideal(rees,blowup({},m,{a,b,c}));

	% Lets test weighted Hilbert series once more :

    weights:=second getring();
    weightedhilbertseries(gbasis rees,weights);

	% The symmetric algebra :

    setring getring m$
    setideal(sym,sym(m,{a,b,c}));
    modequalp(rees,sym);

  % Symbolic powers :

    setring getring m$
    setideal(m2,idealpower(m,2));

	% Let's compute a second symbolic power :

    setideal(m3,symbolic_power(m,2));

	% It is different from the ordinary second power.
	% Hence m2 has a trivial component.

    modequalp(m2,m3);

	% Test x for non zero divisor property :

    nzdp(x,m2);
    nzdp(x,m3);

	% Here is the primary decomposition :

    pd:=primarydecomposition m2;

	% Compare the result with m2 :

    setideal(m4,matintersect(first first pd, first second pd));
    modequalp(m2,m4);

	% Compare the result with m3 :

    setideal(m4,first first pd)$
    modequalp(m3,m4);

	% The trivial component can also be removed with a stable
	% quotient computation : 

    setideal(m5,matstabquot(m2,vars))$
    modequalp(m3,m5);


% Example 3 : The Macaulay curve.

    setideal(m,proj_monomial_curve({0,1,3,4},{w,x,y,z}));
    vars:=first getring();
    gbasis m;
 
  % Test whether m is prime :

    isprime m;

  % A resolution of m :
    
    resolve m;

  % m has depth = 1 as can be seen from the 
    
    gradedbettinumbers m; 

  % Another way to see the non perfectness of m :
    
    hilbertseries m; 

  % Just a third approach. Divide out a parameter system :

    ps:=for i:=1:2 collect random_linear_form(vars,1000);
    setideal(m1,matsum(m,ps))$ 

	% dim should be zero and degree > degree m = 4. 
	% A Gbasis for m1 is computed automatically.

    dim m1; 
    degree m1; 

  % The projections of m on the coord. hyperplanes.
 
    for each x in vars collect eliminate(m,{x}); 

% Example 4 : Two submodules of S^4.
  
	% Get the stored result of the earlier computation.

    r:=resolve m$

  % See whether cali!=degrees contains a relict from earlier
  % computations. 
  
    getdegrees();

  % Introduce the 2nd and 3rd syzygy module as new modules.
  % Both are submodules in S^4.

    setmodule(m1,second r)$ setmodule(m2,third r)$ 
 
  % The second is already a gbasis.

    setgbasis m2; 
    getleadterms m1; getleadterms m2;

  % Since rk(F/M)=rk(F/in(M)), they have ranks 1 resp. 3.

    dim m1;
    indepvarsets m1;

  % Its intersection is zero :

    matintersect(m1,m2);

  % Its sum :
 
    setmodule(m3,matsum(m1,m2));
    dim m3;

  % Hence it has a nontrivial annihilator :

    annihilator m3;

  % One can compute isolated primes and primary decomposition also for
  % modules. Let's do it, although being trivial here:
 
    isolatedprimes m3;

    primarydecomposition m3;

  % To get a meaningful Hilbert series make m1 homogeneous :
 
    setdegrees {1,x,x,x}; 
 
  % Reevaluate m1 with the new column degrees. 

    setmodule(m1,m1)$
    hilbertseries m1;

% Example 5 : From the MACAULAY manual (D.Bayer, M.Stillman).
% An elliptic curve on the Veronese in P^5.

    rvars:={x,y,z}$ svars:={a,b,c,d,e,f}$
    r:=setring(rvars,degreeorder rvars,revlex)$
    s:=setring(svars,{for each x in svars collect 2},revlex)$
    map:={s,r,{a=x^2,b=x*y,c=x*z,d=y^2,e=y*z,f=z^2}};
    preimage({y^2z-x^3-x*z^2},map);

% Example 6 : The preimage under a rational map.

    r:=setring({x,y},{},lex)$ s:=setring({t},{},lex)$
    map:={r,s,{x=2t/(t^2+1),y=(t^2-1)/(t^2+1)}};
  
  % The preimage of (0) is the equation of the circle :

    ratpreimage({},map);

  % The preimage of the point (t=3/2) :

    ratpreimage({2t-3},map);


% Example 7 : A zerodimensional ideal.

    setring({x,y,z},{},lex)$
    setideal(n,{x**2 + y + z - 3,x + y**2 + z - 3,x + y + z**2 - 3});

  % The groebner algorithm with factorization :

    groebfactor n;

  % Change the term order and reevaluate n :

    setring({x,y,z},{{1,1,1}},revlex)$
    setideal(n,n);

  % its primes :
 
    zeroprimes n;

  % a vector space basis of S/n :

    getkbase n;

% Example 8 : A modular computation. Since REDUCE has no multivariate
% factorizer, factorprimes has to be turned off !

    on modular$ off factorprimes$
    setmod 181; setideal(n1,n); zeroprimes n1;
    setmod 7; setideal(n1,n); zeroprimes n1;
 
	% Hence some of the primes glue together mod 7.

    zeroprimarydecomposition n1;
    off modular$ on factorprimes$

% Example 9 : Independent sets once more.
  
    n:=10$
    vars:=for i:=1:(2*n) collect mkid(x,i)$
    setring(vars,{},lex)$
    setideal(m,for j:=0:n collect 
            for i:=(j+1):(j+n) product mkid(x,i));
    setgbasis m$
    indepvarsets m;
    dim m;
    degree m;


comment

	####################################
	###				 ###
	###     Local Standard Bases     ###
	###				 ###
	####################################

end comment;


% Example 10 : An example from [ Alonso, Mora, Raimondo ] 

    vars := {z,x,y}$
    r:=setring(vars,{},lex)$
    setideal(m,{x^3+(x^2-y^2)*z+z^4,y^3+(x^2-y^2)*z-z^4});
    dim m;
    degree m;

  % 2 = codim m is the codimension of the curve m. The defining 
  % equations of the singular locus with their nilpotent structure : 

    singular_locus(m,2); 
    groebfactor ws; 

  % Hence this curve has two singular points : 
  % (x=y=z=0) and (y=-x=256/81,z=64/27)
  % Let's find the brances of the curve through the origin.
  % The first critical tropism is (-1,-1,-1).

    off noetherian$
    setring(vars,{{-1,-1,-1}},lex)$
    setideal(m,m);
	% Let's first test two different approaches, not fully
	% integrated into the algebraic interface :
    setideal(m1,homstbasis m);
    setideal(m2,lazystbasis m);
    setgbasis m1$ setgbasis m2$
    modequalp(m1,m2);
    gbasis m;
    modequalp(m,m1);
    dim m;
    degree m;

  % Find the tangent directions not in z-direction :

    tangentcone m; 
    setideal(n,sub(z=1,ws));
    setring r$ on noetherian$ setideal(n,n)$
    degree n;

  % The points of n outside the origin.

    matstabquot(n,{x,y}); 

  % Hence there are two branches x=z'*(a-3+x'),y=z'*(a+y'),z=z'
  % with the algebraic number a : a^2-3a+3=0
  % and the new equations for (z',x',y') :

    setrules {a^2=>3a-3};
    sub(x=z*(a-3+x),y=z*(a+y),m);
    setideal(m1,matqquot(ws,z));

  % This defines a loc. smooth system at the origin, since the
  % jacobian at the origin of the gbasis is nonsingular :

    off noetherian$
    setring getring m;
    setideal(m1,m1);
    gbasis m1;

	% clear the rules previously set.

    setrules {}; 


% Example 11 : The standard basis of another example. 

	% Comparing different approaches.

    vars:={x,y}$
    setring(vars,localorder vars,lex);
    ff:=x^5+y^11+(x+x^3)*y^9;
    setideal(p1,mat2list matjac({ff},vars));
    gbasis p1;

    gbtestversion 2$
    setideal(p2,p1);
    gbasis p2;

    gbtestversion 3$
    setideal(p3,p1);
    gbasis p3;

    gbtestversion 1$
    modequalp(p1,p2);
    modequalp(p1,p3);
    dim p1;
    degree p1;

% Example 12 : A local intersection wrt. a non inflimited term order.

    setring({x,y,z},{},revlex);
    m1:=matintersect({x-y^2,y-x^2},{x-z^2,z-x^2},{y-z^2,z-y^2});
  
	% Delete polynomial units post factum :
  
    deleteunits ws;

	% Detecting polynomial units early :

    on detectunits;
    m1:=matintersect({x-y^2,y-x^2},{x-z^2,z-x^2},{y-z^2,z-y^2});
    off detectunits;


comment

	####################################
	###				 ###
	###  More Advanced Computations  ###
	###				 ###
	####################################

end comment;

  % Return to a noetherian term order:
   
    vars:={x,y,z}$
    setring(vars,degreeorder vars,revlex);
    on noetherian;

% Example 13 : Use of "mod".

  % Polynomials modulo ideals :

    setideal(m,{2x^2+y+5,3y^2+z+7,7z^2+x+1});
    x^2*y^2*z^2 mod m;

  % Lists of polynomials modulo ideals :

    {x^3,y^3,z^3} mod gbasis m;

  % Matrices modulo modules :

    mm:=mat((x^4,y^4,z^4));
    mm1:=tp<< ideal2mat m>>;
    mm mod mm1;

% Example 14 : Powersums through elementary symmetric functions.

    vars:={a,b,c,d,e1,e2,e3,e4}$
    setring(vars,{},lex)$
    m:=interreduce {a+b+c+d-e1,
        a*b+a*c+a*d+b*c+b*d+c*d-e2,
        a*b*c+a*b*d+a*c*d+b*c*d-e3,
        a*b*c*d-e4};
    
    for n:=1:5 collect a^n+b^n+c^n+d^n mod m;    

% Example 15 : The setrules mechanism. 

    setring({x,y,z},{},lex)$
    setrules {aa^3=>aa+1};
    setideal(m,{x^2+y+z-aa,x+y^2+z-aa,x+y+z^2-aa});
    gbasis m;
    
	% Clear the rules previously set.

    setrules {};

% Example 16 : The same example with advanced coefficient domains.

    load_package arnum;
    defpoly aa^3-aa-1;
    setideal(m,{x^2+y+z-aa,x+y^2+z-aa,x+y+z^2-aa});
    gbasis m;

	% The following needs some more time since factorization of
	% arnum's is not so easy :

    groebfactor m;
    off arnum;
    off rational;


comment

	####################################
	###				 ###
	###  Using Advanced Scripts in   ###
	###	a Complex Example	 ###
	###				 ###
	####################################

end comment;


% Example 17 : The square of the 2-minors of a symmetric 3x3-matrix.

    vars:=for i:=1:6 collect mkid(x,i);
    setring(vars,degreeorder vars,revlex);

	% Generating the ideal :

    mm:=mat((x1,x2,x3),(x2,x4,x5),(x3,x5,x6));
    m:=ideal_of_minors(mm,2);
    setideal(n,idealpower(m,2));

	% The ideal itself :

    gbasis n;
    length n;
    dim n;
    degree n;

	% Its radical.

    radical n;

	% Its unmixed radical.

    unmixedradical n;

	% Its equidimensional hull :

    n1:=eqhull n;
    length n1;
    setideal(n1,n1)$ 
    submodulep(n,n1);
    submodulep(n1,n);

	% Hence there is an embedded component. Let's find it making
	% an excursion to symbolic mode. Of course, this can be done
	% also algebraically. 

    symbolic;
    n:=get('n,'basis);

	% This needs even more time than the eqhull, of course.

    u:=primarydecomposition!* n;
    for each x in u collect easydim!* cadr x;
    for each x in u collect degree!* car x;

	% Hence the embedded component is a trivial one. Let's divide
	% it out by a stable ideal quotient calculation :

    algebraic;
    setideal(n2,matstabquot(n,vars));
    modequalp(n1,n2);


comment

	########################################
	###				     ###
	###  Test Examples for New Features  ###
	###				     ###
	########################################

end comment;


% ==> Testing the different zerodimensional solver 

	vars:={x,y,z}$
	setring(vars,degreeorder vars,revlex);
	setideal(m,{x^3+y+z-3,y^3+x+z-3,z^3+x+y-3});
	zerosolve1 m;
	zerosolve2 m;
	setring(vars,{},lex)$ setideal(m,m)$ m1:=gbasis m$
	zerosolve  m1;
	zerosolve1 m1;
	zerosolve2 m1;

% ==> Testing groebfactor, extendedgroebfactor, extendedgroebfactor1 

  % Gerdt et al. : Seventh order KdV type equation.

A1:=-2*L1**2+L1*L2+2*L1*L3-L2**2-7*L5+21*L6$
A2:=7*L7-2*L1*L4+3/7*L1**3$
B1:=L1*(5*L1-3*L2+L3)$
B2:=L1*(2*L6-4*L4)$
B3:=L1*L7/2$
P1:=L1*(L4-L5/2+L6)$
P2:=(2/7*L1**2-L4)*(-10*L1+5*L2-L3)$
P3:=(2/7*L1**2-L4)*(3*L4-L5+L6)$
P4:=A1*(-3*L1+2*L2)+21*A2$
P5:=A1*(2*L4-2*L5)+A2*(-45*L1+15*L2-3*L3)$
P6:=2*A1*L7+A2*(12*L4-3*L5+2*L6)$
P7:=B1*(2*L2-L1)+7*B2$
P8:=B1*L3+7*B2$
P9:=B1*(-2*L4-2*L5)+B2*(2*L2-8*L1)+84*B3$
P10:=B1*(8/3*L5+6*L6)+B2*(11*L1-17/3*L2+5/3*L3)-168*B3$
P11:=15*B1*L7+B2*(5*L4-2*L5)+B3*(-120*L1+30*L2-6*L3)$
P12:=-3*B1*L7+B2*(-L4/2+L5/4-L6/2)+B3*(24*L1-6*L2)$
P13:=3*B2*L7+B3*(40*L4-8*L5+4*L6)$

polys:={P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13};
vars:={L7,L6,L5,L4,L3,L2,L1};
clear a1,a2,b1,b2,b3$

	off lexefgb; 
	setring(vars,{},lex);

  % The factorized Groebner algorithm.
	groebfactor polys;

  % The extended Groebner factorizer, producing triangular sets.
	extendedgroebfactor polys;

  % The extended Groebner factorizer with subproblem removal check. 
	extendedgroebfactor1 polys;

  % Gonnet's example (ACM SIGSAM Bulletin 17 (1983), 48 - 49)

vars:={a0,a2,a3,a4,a5,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5};
polys:={a4*b4,
a5*b1+b5+a4*b3+a3*b4,
a2*b2,a5*b5,
(a0+1+a4)*b2+a2*(b0+b1+b4)+c2,
(a0+1+a4)*(b0+b1+b4)+(a3+a5)*b2+a2*(b3+b5)+c0+c1+c4,
(a3+a5)*(b0+b1+b4)+(b3+b5)*(a0+1+a4)+c3+c5-1,
(a3+a5)*(b3+b5),
a5*(b3+b5)+b5*(a3+a5),
b5*(a0+1+2*a4)+a5*(b0+b1+2*b4)+a3*b4+a4*b3+c5,
a4*(b0+b1+2*b4)+a2*b5+a5*b2+(a0+1)*b4+c4,
a2*b4+a4*b2,
a4*b5+a5*b4,
2*a3*b3+a3*b5+a5*b3,
c3+b3*(a0+2+a4)+a3*(b0+2*b1+b4)+b5+a5*b1,
c1+(a0+2+a4)*b1+a2*b3+a3*b2+(b0+b4),
a2*b1+b2,
a5*b3+a3*b5,
b4+a4*b1};

	on lexefgb; % Switching back to the default.
	setring(vars,{},lex);
	groebfactor polys;
	extendedgroebfactor polys;
	extendedgroebfactor1 polys;

  % Schwarz' example s5

vars:=for k:=1:5 collect mkid(x,k);

s5:={
x1**2+x1+2*x2*x5+2*x3*x4,
2*x1*x2+x2+2*x3*x5+x4**2,
2*x1*x3+x2**2+x3+2*x4*x5,
2*x1*x4+2*x2*x3+x4+x5**2,
2*x1*x5+2*x2*x4+x3**2+x5};

	setring(vars,degreeorder vars,revlex);
	m:=groebfactor s5;

  % Recompute a list of problems with listgroebfactor for another term 
  % order. 
	setring(vars,{},lex);
	listgroebfactor m;


% ==> Testing the linear algebra package

  % Find the ideal of points in affine and projective space. 

	vars:=for k:=1:6 collect mkid(x,k);
	setring(vars,degreeorder vars,revlex);
	matrix mm(10,6);
	on rounded;
	for k:=1:6 do for l:=1:10 do mm(l,k):=floor(exp((k+l)/4));
	off rounded;
	mm;
	setideal(u,affine_points mm); setgbasis u$ dim u; degree u;
	setideal(u,proj_points mm); setgbasis u$ dim u; degree u;

  % Change the term order to pure lex in dimension zero.
  % Test both approaches, with and without precomputed borderbasis.

	vars:=for k:=1:6 collect mkid(x,k);
	r1:=setring(vars,{},lex);
	r2:=setring(vars,degreeorder vars,revlex);
	setideal(m,{x1**2+x1+2*x2*x6+2*x3*x5+x4**2,
		2*x1*x2+x2+2*x3*x6+2*x4*x5,
		2*x1*x3+x2**2+x3+2*x4*x6+x5**2,
		2*x1*x4+2*x2*x3+x4+2*x5*x6,
		2*x1*x5+2*x2*x4+x3**2+x5+x6**2,
		2*x1*x6+2*x2*x5+2*x3*x4+x6});
	gbasis m;
	m1:=change_termorder(m,r1);
	setring r2$ m2:=change_termorder1(m,r1);
	setideal(m1,m1)$ setideal(m2,m2)$
	setgbasis m1$ setgbasis m2$ modequalp(m1,m2);

% ==> Different hilbert series driver
   
    setideal(m,proj_monomial_curve(w1:={0,2,5,9},{w,x,y,z}));
    weights:={{1,1,1,1},w1};
    hftestversion 2;
    f1:=weightedhilbertseries(gbasis m,weights);
    sub(x=1,ws); % The ordinary Hilbert series.
    hftestversion 1; % The default.
    f2:=weightedhilbertseries(gbasis m,weights);
    sub(x=1,ws); 
    f1-f2;

% ==> Different primary decomposition approaches. The example is due
	% to Shimoyama Takeshi. CALI 2.2. produced auxiliary embedded
	% primes on it.

    vars:={dx,dy,x,y};
    setring(vars,degreeorder vars,revlex);
    f3:={DY*( - X*DX + Y**2*DY - Y*DY),DX*(X**2*DX - X*DX - Y*DY)}$
    primarydecomposition f3;

showtime;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/scripts.red0000644000175000017500000003362111526203062023604 0ustar  giovannigiovannimodule scripts;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

               ######################
               ##                  ##
               ##     ADVANCED     ##
               ##   APPLICATIONS   ##
               ##                  ##
               ######################

This module contains several additional advanced applications of
standard basis computations, inspired partly by the scripts
distributed with the commutative algebra package MACAULAY
(Bayer/Stillman/Eisenbud).

The following topics are currently covered :
        - [BGK]'s heuristic variable optimization
        - certain stuff on maps (preimage, ratpreimage)
        - ideals of points (in affine and proj. spaces)
        - ideals of (affine and proj.) monomial curves
        - General Rees rings, associated graded rings, and related
                topics (analytic spread, symmetric algebra)
        - several short scripts (minimal generators, symbolic powers
                of primes, singular locus)


END COMMENT;

%---------- [BGK]'s heuristic variable optimization ----------

symbolic operator varopt;
symbolic procedure varopt m;
  if !*mode='algebraic then makelist varopt!* dpmat_from_a m
  else varopt!* m;

symbolic procedure varopt!* m;
% Find a heuristically optimal variable order.
  begin scalar c; c:=mo_zero();
  for each x in dpmat_list m do
    for each y in bas_dpoly x do c:=mo_lcm(c,car y);
  return
    for each x in
        sort(mo_2list c,function(lambda(x,y); cdr x>cdr y)) collect
        car x;
  end;

% ----- Certain stuff on maps -------------

% A ring map is represented as a list
%   {preimage_ring, image_ring, subst_list},
% where subst_list is a substitution list {v1=ex1,v2=ex2,...} in
% algebraic prefix form, i.e. looks like (list (equal var image) ...)

symbolic operator preimage;
symbolic procedure preimage(m,map);
% Compute the preimage of an ideal m under a (polynomial) ring map.
  if !*mode='algebraic then
  begin map:=cdr reval map;
     return preimage!*(reval m,
        {ring_from_a first map, ring_from_a second map, third map});
  end
  else preimage!*(m,map);

symbolic procedure preimage!*(m,map);
% m and the result are given and returned in algebraic prefix form.
  if not !*noetherian then
        rederr"PREIMAGE only for noetherian term orders"
  else begin scalar u,oldring,newring,oldnames;
  if not eqcar(m,'list) then rederr"PREIMAGE only for ideals";
  oldring:=first map; newring:=second map;
  oldnames:=ring_names oldring;
  setring!* ring_sum(newring,oldring);
  u:=bas_renumber for each x in cdr third map collect
  << if not member(second x,oldnames) then
            typerr(second x,"var. name");
     bas_make(0,dp_diff(dp_from_a second x,dp_from_a third x))
  >>;
  m:=matsum!* {dpmat_from_a m,dpmat_make(length u,0,u,nil,nil)};
  m:=dpmat_2a eliminate!*(m,ring_names newring);
  setring!* oldring;
  return m;
  end;

symbolic operator ratpreimage;
symbolic procedure ratpreimage(m,map);
% Compute the preimage of an ideal m under a rational ring map.
  if !*mode='algebraic then
  begin map:=cdr reval map;
  return ratpreimage!*(reval m,
        {ring_from_a first map, ring_from_a second map, third map});
  end
  else ratpreimage!*(m,map);

symbolic procedure ratpreimage!*(m,map);
% m and the result are given and returned in algebraic prefix form.
  if not !*noetherian then
        rederr"RATPREIMAGE only for noetherian term orders"
  else begin scalar u,oldring,newnames,oldnames,f,g,v,g0;
  if not eqcar(m,'list) then rederr"RATPREIMAGE only for ideals";
  oldring:=first map; v:=gensym();
  newnames:=v . ring_names second map;
  oldnames:=ring_names oldring; u:=append(oldnames,newnames);
  setring!* ring_define(u,nil,'lex,for each x in u collect 1);
  g0:=dp_fi 1;
  u:=bas_renumber for each x in cdr third map collect
  << if not member(second x,oldnames) then
            typerr(second x,"var. name");
     f:=simp third x; g:=dp_from_a prepf denr f;
     f:=dp_from_a prepf numr f; g0:=dp_prod(g,g0);
     bas_make(0,dp_diff(dp_prod(g,dp_from_a second x),f))
  >>;
  u:=bas_make(0,dp_diff(dp_prod(g0,dp_from_a v),dp_fi 1)) . u;
  m:=matsum!* {dpmat_from_a m,dpmat_make(length u,0,u,nil,nil)};
  m:=dpmat_2a eliminate!*(m,newnames);
  setring!* oldring;
  return m;
  end;

% ---- The ideals of affine resp. proj. points. The old stuff, but the
% ---- algebraic interface now uses the linear algebra approach.

symbolic procedure affine_points1!* m;
  begin scalar names;
  if length(names:=ring_names cali!=basering) neq length cadr m then
        typerr(m,"coordinate matrix");
  m:=for each x in cdr m collect
         'list . for each y in pair(names,x) collect
                {'plus,car y,{'minus,reval cdr y}};
  m:=for each x in m collect dpmat_from_a x;
  m:=matintersect!* m;
  return m;
  end;

symbolic procedure scripts!=ideal u;
  'list . for each x in cali_choose(u,2) collect
        {'plus,{'times, car first x,cdr second x},
        {'minus,{'times, car second x,cdr first x}}};

symbolic procedure proj_points1!* m;
  begin scalar names;
  if length(names:=ring_names cali!=basering) neq length cadr m then
        typerr(m,"coordinate matrix");
  m:=for each x in cdr m collect scripts!=ideal pair(names,x);
  m:=for each x in m collect interreduce!* dpmat_from_a x;
  m:=matintersect!* m;
  return m;
  end;

% ----- Affine and proj. monomial curves ------------

symbolic operator affine_monomial_curve;
symbolic procedure affine_monomial_curve(l,R);
% l is a list of integers, R contains length l ring var. names.
% Returns the generators of the monomial curve (t^i : i\in l) in R.
  if !*mode='algebraic then
        dpmat_2a affine_monomial_curve!*(cdr reval l,cdr reval R)
  else affine_monomial_curve!*(l,R);

symbolic procedure affine_monomial_curve!*(l,R);
  if not numberlistp l then typerr(l,"number list")
  else if length l neq length R then
        rederr"number of variables doesn't match"
  else begin scalar u,t0,v;
    v:=list gensym();
    r:=ring_define(r,{l},'revlex,l);
    setring!* ring_sum(r,ring_define(v,degreeorder!* v,'lex,'(1)));
    t0:=dp_from_a car v;
    u:=bas_renumber for each x in pair(l,ring_names r) collect
        bas_make(0,dp_diff(dp_from_a cdr x,dp_power(t0,car x)));
    u:=dpmat_make(length u,0,u,nil,nil);
    u:=(eliminate!*(u,v) where cali!=monset=ring_names cali!=basering);
    setring!* r;
    return dpmat_neworder(u,dpmat_gbtag u);
    end;

symbolic operator proj_monomial_curve;
symbolic procedure proj_monomial_curve(l,R);
% l is a list of integers, R contains length l ring var. names.
% Returns the generators of the monomial curve
% (s^(d-i)*t^i : i\in l) in R where d = max { x : x \in l}
  if !*mode='algebraic then
        dpmat_2a proj_monomial_curve!*(cdr reval l,cdr reval R)
  else proj_monomial_curve!*(l,R);

symbolic procedure proj_monomial_curve!*(l,R);
  if not numberlistp l then typerr(l,"number list")
  else if length l neq length R then
        rederr"number of variables doesn't match"
  else begin scalar u,t0,t1,v,d;
    t0:=gensym(); t1:=gensym(); v:={t0,t1};
    d:=listexpand(function max2,l);
    r:=ring_define(r,degreeorder!* r,'revlex,for each x in r collect 1);
    setring!* ring_sum(r,ring_define(v,degreeorder!* v,'lex,'(1 1)));
    t0:=dp_from_a t0; t1:=dp_from_a t1;
    u:=bas_renumber for each x in pair(l,ring_names r) collect
        bas_make(0,dp_diff(dp_from_a cdr x,
                dp_prod(dp_power(t0,car x),dp_power(t1,d-car x))));
    u:=dpmat_make(length u,0,u,nil,nil);
    u:=(eliminate!*(u,v) where cali!=monset=ring_names cali!=basering);
    setring!* r;
    return dpmat_neworder(u,dpmat_gbtag u);
    end;

% -- General Rees rings, associated graded rings, and related topics --

symbolic operator blowup;
symbolic procedure blowup(m,n,vars);
% vars is a list of var. names for the ring R
%       of the same length as dpmat_list n.
% Returns an ideal J such that (S+R)/J == S/M [ N.t ]
%       ( with S = the current ring )
% is the blow up ring of the ideal N over S/M.
% (S+R) is the new current ring.
  if !*mode='algebraic then
        dpmat_2a blowup!*(dpmat_from_a reval m,dpmat_from_a reval n,
                cdr reval vars)
  else blowup!*(M,N,vars);

symbolic procedure blowup!*(M,N,vars);
  if (dpmat_cols m > 0)or(dpmat_cols n > 0) then
        rederr"BLOWUP defined only for ideals"
  else if not !*noetherian then
        rederr"BLOWUP only for noetherian term orders"
  else begin scalar u,s,t0,v,r1;
    if length vars neq dpmat_rows n then
        rederr {"ring must have",dpmat_rows n,"variables"};
    u:=for each x in dpmat_rowdegrees n collect mo_ecart cdr x;
    r1:=ring_define(vars,list u,'revlex,u);
    s:=ring_sum(cali!=basering,r1); v:=list(gensym());
    setring!* ring_sum(s,ring_define(v,degreeorder!* v,'lex,'(1)));
    t0:=dp_from_a car v;
    n:=for each x in
            pair(vars,for each y in dpmat_list n collect bas_dpoly y)
            collect dp_diff(dp_from_a car x,
                            dp_prod(dp_neworder cdr x,t0));
    m:=bas_renumber append(bas_neworder dpmat_list m,
            for each x in n collect bas_make(0,x));
    m:=(eliminate!*(interreduce!* dpmat_make(length m,0,m,nil,nil),v)
        where cali!=monset=nil);
    setring!* s;
    return dpmat_neworder(m,dpmat_gbtag m);
    end;

symbolic operator assgrad;
symbolic procedure assgrad(m,n,vars);
% vars is a list of var. names for the ring T
%       of the same length as dpmat_list n.
% Returns an ideal J such that (S+T)/J == (R/N + N/N^2 + ... )
%       ( with R=S/M and S the current ring )
% is the associated graded ring of the ideal N over R.
% (S+T) is the new current ring.
  if !*mode='algebraic then
        dpmat_2a assgrad!*(dpmat_from_a reval m,dpmat_from_a reval n,
                cdr reval vars)
  else assgrad!*(M,N,vars);

symbolic procedure assgrad!*(M,N,vars);
  if (dpmat_cols m > 0)or(dpmat_cols n > 0) then
        rederr"ASSGRAD defined only for ideals"
  else begin scalar u;
    u:=blowup!*(m,n,vars);
    return matsum!* {u,dpmat_neworder(n,nil)};
    end;

symbolic operator analytic_spread;
symbolic procedure analytic_spread m;
% Returns the analytic spread of the ideal m.
  if !*mode='algebraic then analytic_spread!* dpmat_from_a reval m
  else analytic_spread!* m;

symbolic procedure analytic_spread!* m;
   if (dpmat_cols m>0) then rederr"ANALYTIC SPREAD only for ideals"
   else (begin scalar r,m1,vars;
   r:=ring_names cali!=basering;
   vars:=for each x in dpmat_list m collect gensym();
   m1:=blowup!*(dpmat_from_dpoly nil,m,vars);
   return dim!* gbasis!* matsum!*{m1,dpmat_from_a('list . r)};
   end) where cali!=basering=cali!=basering;

symbolic operator sym;
symbolic procedure sym(M,vars);
% vars is a list of var. names for the ring R
%       of the same length as dpmat_list M.
% Returns an ideal J such that (S+R)/J == Sym(M)
%       ( with S = the current ring )
% is the symmetric algebra of M over S.
% (S+R) is the new current ring.
  if !*mode='algebraic then
        dpmat_2a sym!*(dpmat_from_a M,cdr reval vars)
  else sym!*(m,vars);

symbolic procedure sym!*(m,vars);
% The symmetric algebra of the dpmat m.
   if not !*noetherian then
        rederr"SYM only for noetherian term orders"
   else begin scalar n,u,r1;
    if length vars neq dpmat_rows m then
        rederr {"ring must have",dpmat_rows m,"variables"};
    cali!=degrees:=dpmat_coldegs m;
    u:=for each x in dpmat_rowdegrees m collect mo_ecart cdr x;
    r1:=ring_define(vars,list u,'revlex,u); n:=syzygies!* m;
    setring!* ring_sum(cali!=basering,r1);
    return mat2list!* interreduce!*
                dpmat_mult(dpmat_neworder(n,nil),
                        ideal2mat!* dpmat_from_a('list . vars));
    end;

% ----- Several short scripts ----------

% ------ Minimal generators of an ideal or module.
symbolic operator minimal_generators;
symbolic procedure minimal_generators m;
  if !*mode='algebraic then
        dpmat_2a minimal_generators!* dpmat_from_a reval m
  else minimal_generators!* m;

symbolic procedure minimal_generators!* m;
  car groeb_minimize(m,syzygies!* m);

% ------- Symbolic powers of prime (or unmixed) ideals
symbolic operator symbolic_power;
symbolic procedure symbolic_power(m,d);
  if !*mode='algebraic then
        dpmat_2a symbolic_power!*(dpmat_from_a m,reval d)
  else symbolic_power!*(m,d);

symbolic procedure symbolic_power!*(m,d);
  eqhull!* idealpower!*(m,d);

% ---- non zero divisor property -----------

put('nzdp,'psopfn,'scripts!=nzdp);
symbolic procedure scripts!=nzdp m;
  if length m neq 2 then rederr"Syntax : nzdp(dpoly,dpmat)"
  else begin scalar f,b;
    f:=reval car m; intf_get second m;
    if null(b:=get(second m,'gbasis)) then
        put(second m,'gbasis,b:=gbasis!* get(second m,'basis));
    return if nzdp!*(dp_from_a f,b) then 'yes else 'no;
    end;

symbolic procedure nzdp!*(f,m);
% Test dpoly f for a non zero divisor on coker m. m must be a gbasis.
  submodulep!*(matqquot!*(m,f),m);

endmodule; % scripts

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/dpoly.red0000644000175000017500000003415511526203062023247 0ustar  giovannigiovannimodule dpoly;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

               ##################
               ##              ##
               ## POLYNOMIALS  ##
               ##              ##
               ##################

Polynomial vectors and polynomials are handled in a unique way using
the module component of monomials to store the vector component. If
the component is 0, we have a polynomial, otherwise a vector. They
are represented in a distributive form (dpoly for short).

Informal syntax of (vector) polynomials :

      ::= list of s
       ::= (  .  )

END COMMENT;

% ----------- constructors and selectors -------------------

symbolic procedure dp_lc p;
% Leading base coefficient of the dpoly p.
   cdar p;

symbolic procedure dp_lmon p;
% Leading monomial of the dpoly p.
   caar p;

symbolic procedure dp_term (a,e);
%  Constitutes a term from a:base coeff. and e:monomial.
   (e . a);

symbolic procedure dp_from_ei n;
% Returns e_i as dpoly.
  list dp_term(bc_fi 1,mo_from_ei n);

symbolic procedure dp_fi n;
% dpoly from integer
   if n=0 then nil else
   list dp_term(bc_fi n,mo_zero());

symbolic procedure dp_fbc c;
% Converts the base coefficient c into a dpoly.
   if bc_zero!? c then nil else
   list dp_term(c,mo_zero());

% ------------  dpoly arithmetics ---------------------------

symbolic procedure dp!=comp(i,v);
   if null v then nil
   else if eqn(mo_comp dp_lmon v,i) then car v . dp!=comp(i,cdr v)
   else dp!=comp(i,cdr v);

symbolic procedure dp_comp(i,v);
% Returns the (polynomial) component i of the vector v.
   for each x in dp!=comp(i,v) collect (mo_deletecomp car x) . cdr x;

symbolic procedure dp!=mocompare (t1,t2);
% true <=> term t1 is smaller than term t2 in the current term order.
     eqn(mo_compare (car t1, car t2),1);

symbolic procedure dp_neworder p;
% Returns reordered dpoly p after change of the term order.
   sort(for each x in p collect (mo_neworder car x) . cdr x,
            function dp!=mocompare);

symbolic procedure dp_neg p;
% Returns - p  for the dpoly p.
   for each x in p collect (car x .  bc_neg cdr x);

symbolic procedure dp_times_mo (mo,p);
% Returns p * x^mo for the dpoly p and the monomial mo.
   for each x in p collect (mo_sum(mo,car x) .  cdr x);

symbolic procedure dp_times_bc (bc,p);
% Returns p * bc for the dpoly p and the base coeff. bc.
   for each x in p collect (car x .  bc_prod(bc,cdr x));

symbolic procedure dp_times_bcmo (bc,mo,p);
% Returns p * bc * x^mo for the dpoly p, the monomial mo and the base
% coeff. bc.
   for each x in p collect (mo_sum(mo,car x) .  bc_prod(bc,cdr x));

symbolic procedure dp_times_ei(i,p);
% Returns p * e_i for the dpoly p.
   dp_neworder for each x in p collect (mo_times_ei(i,car x) . cdr x);

symbolic procedure dp_project(p,k);
% Delete all terms x^a*e_i with i>k.
  for each x in p join if mo_comp car x <= k then {x};

symbolic procedure dp_content p;
% Returns the leading coefficient, if invertible, or the content of
% p.
  if null p then bc_fi 0
  else begin scalar w;
        w:=dp_lc p; p:=cdr p;
        while p and not bc_inv w do
         << w:=bc_gcd(w,dp_lc p); p:=cdr p >>;
        return w
        end;

symbolic procedure dp_mondelete(p,s);
% Returns (p.m) with common monomial factor m with support in the
% var. list s deleted.
   if null p or null s then (p . mo_zero()) else
   begin scalar cmf;
     cmf:=dp!=cmf(p,s);
     if mo_zero!? cmf then return (p . cmf)
     else return
       cons(for each x in p collect mo_diff(car x,cmf) . cdr x,cmf)
   end;

symbolic procedure dp!=cmf(p,s);
   begin scalar a;
        a:=mo_seed(dp_lmon p,s); p:=cdr p;
        while p and (not mo_zero!? a) do
                << a:=mo_gcd(a,mo_seed(dp_lmon p,s)); p:=cdr p >>;
        return a
   end;

symbolic procedure dp_unit!? p;
% Tests whether lt p of the dpoly p is a unit.
% This means : p is a unit, if the t.o. is noetherian
%       or   : p is a local unit, if the t.o. is a tangentcone order.
   p and (mo_zero!? dp_lmon p);

symbolic procedure dp_simp pol;
% Returns (pol_new . z) with
%       pol_new having leading coefficient 1 or
%       dp_content pol canceled out
% and pol_old = z * dpoly_new .

  if null pol then pol . bc_fi 1
  else begin scalar z,z1;
    if (z:=bc_inv (z1:=dp_lc pol)) then
        return dp_times_bc(z,pol) . z1;

    % -- now we assume that base coefficients are a gcd domain ----

    z:=dp_content pol;
    if bc_minus!? z1 then z:=bc_neg z;
    pol:=for each x in pol collect
                car x . car bc_divmod(cdr x,z);
    return pol . z;
    end;

symbolic procedure dp_prod(p1,p2);
% Returns p1 * p2 for the dpolys p1 and p2.
    if length p1 <= length p2 then dp!=prod(p1,p2)
                              else dp!=prod(p2,p1);

symbolic procedure dp!=prod(p1,p2);
  if null p1 or null p2 then nil
  else
     begin scalar v;
       for each x in p1 do
                v:=dp_sum( dp_times_bcmo(cdr x,car x, p2 ),v);
       return v;
     end;

symbolic procedure dp_sum(p1,p2);
% Returns p1 + p2 for the dpolys p1 and p2.
    if null p1 then p2
    else if null p2 then p1
    else begin scalar sl,al;
        sl := mo_compare(dp_lmon p1, dp_lmon p2);
        if sl = 1 then return car p1 . dp_sum(cdr p1, p2);
        if sl = -1 then return car p2 . dp_sum(p1, cdr p2);
        al := bc_sum(dp_lc p1, dp_lc p2);
        if bc_zero!? al then return dp_sum(cdr p1, cdr p2)
        else return dp_term(al,dp_lmon p1) . dp_sum(cdr p1, cdr p2)
        end;

symbolic procedure dp_diff(p1,p2);
% Returns p1 - p2 for the dpolys p1 and p2.
    dp_sum(p1, dp_neg p2);

symbolic procedure dp_power(p,n);
% Returns p^n for the dpoly p.
  if (not fixp n) or (n < 0) then typerr(n," exponent")
  else if n=0 then dp_fi 1
  else if n=1 then p
  else if null cdr p then dp!=power1(p,n)
  else dp!=power(p,n);

symbolic procedure dp!=power1(p,n); % For monomials.
  list dp_term(bc_power(dp_lc p,n),mo_power(dp_lmon p,n));

symbolic procedure dp!=power(p,n);
  if n=1 then p
  else if evenp n then dp!=power(dp_prod(p,p),n/2)
  else dp_prod(p,dp!=power(dp_prod(p,p),n/2));

symbolic procedure dp_tcpart p;
% Return the homogeneous degree part of p of highest degree.
  if null p then nil
  else begin scalar d,u; d:=car mo_deg caar p;
  while p and (d=car mo_deg caar p) do
     << u:=car p . u; p:=cdr p >>;
  return reversip u;
  end;

symbolic procedure dp_deletecomp p;
% delete the component part from all terms.
  dp_neworder for each x in p collect mo_deletecomp car x . cdr x;

symbolic procedure dp_factor p;
  for each y in cdr ((fctrf numr simp dp_2a p) where !*factor=t)
            collect dp_from_a prepf car y;

% ------ Converting prefix forms into dpolys ------------------

symbolic procedure dp_from_a u;
% Converts the algebraic (prefix) form u into a dpoly.
   if eqcar(u,'list) or eqcar(u,'mat) then typerr(u,"dpoly")
   else if atom u then dp!=a2dpatom u
   else if not atom car u or not idp car u
                then typerr(car u,"dpoly operator")
   else (if x='dp!=fnpow then dp!=fnpow(dp_from_a cadr u,caddr u)
      else if x then
            apply(x,list for each y in cdr u collect dp_from_a y)
      else dp!=a2dpatom u)
        where x = get(car u,'dp!=fn);

symbolic procedure dp!=a2dpatom u;
% Converts the atom (or kernel) u into a dpoly.
   if u=0 then nil
   else if numberp u or not member(u, ring_all_names cali!=basering)
                then list dp_term(bc_from_a u,mo_zero())
   else list dp_term(bc_fi 1,mo_from_a u);

symbolic procedure dp!=fnsum u;
% U is a list of dpoly expressions. The result is the dpoly
% representation for the sum. Analogously for the other symbolic
% procedures below.
   (<>) where x = car u;

put('plus,'dp!=fn,'dp!=fnsum);

put('plus2,'dp!=fn,'dp!=fnsum);

symbolic procedure dp!=fnprod u;
   (<>) where x = car u;

put('times,'dp!=fn,'dp!=fnprod);

put('times2,'dp!=fn,'dp!=fnprod);

symbolic procedure dp!=fndif u; dp_diff(car u, cadr u);

put('difference,'dp!=fn,'dp!=fndif);

symbolic procedure dp!=fnpow(u,n); dp_power(u,n);

put('expt,'dp!=fn,'dp!=fnpow);

symbolic procedure dp!=fnneg u;
   ( if null v then v else dp_term(bc_neg dp_lc v,dp_lmon v) . cdr v)
        where v = car u;

put('minus,'dp!=fn,'dp!=fnneg);

symbolic procedure dp!=fnquot u;
   if null cadr u or not null cdadr u
         or not mo_zero!? dp_lmon cadr u
      then typerr(dp_2a cadr u,"distributive polynomial denominator")
    else dp!=fnquot1(car u,dp_lc cadr u);

symbolic procedure dp!=fnquot1(u,v);
   if null u then u
    else dp_term(bc_quot(dp_lc u,v), dp_lmon u) .
            dp!=fnquot1(cdr u,v);

put('quotient,'dp!=fn,'dp!=fnquot);

% -------- Converting dpolys into prefix forms -------------
% ------ Authors: R. Gebauer, A. C. Hearn, H. Kredel -------

symbolic procedure dp_2a u;
% Returns the prefix equivalent of the dpoly u.
   if null u then 0 else dp!=replus dp!=2a u;

symbolic procedure dp!=2a u;
   if null u then nil
    else ((if bc_minus!? x then
                        list('minus,dp!=retimes(bc_2a bc_neg x . y))
           else dp!=retimes(bc_2a x . y))
          where x = dp_lc u, y = mo_2a dp_lmon u)
                 . dp!=2a cdr u;

symbolic procedure dp!=replus u;
   if atom u then u else if null cdr u then car u else 'plus . u;

symbolic procedure dp!=retimes u;
% U is a list of prefix expressions the first of which is a number.
% The result is the prefix representation for their product.
   if car u = 1 then if cdr u then dp!=retimes cdr u else 1
    else if null cdr u then car u
    else 'times . u;

% ----------- Printing routines for dpolys --------------
% ---- Authors: R. Gebauer, A. C. Hearn, H. Kredel ------

symbolic procedure dp_print u;
% Prints a distributive polynomial in infix form.
   << terpri();  dp_print1(u,nil); terpri(); terpri() >>;

symbolic procedure dp_print1(u,v);
% Prints a dpoly in infix form.
% U is a distributive form. V is a flag which is true if a term
% has preceded current form.
   if null u then if null v then print_lf 0 else nil
    else begin scalar bool,w;
       w := dp_lc u;
       if bc_minus!? w then <>;
       if bool then print_lf " - " else if v then print_lf " + ";
       ( if not bc_one!? w or mo_zero!? x then
            << bc_prin w; mo_prin(x,t)>>
         else mo_prin(x,nil))
           where x = dp_lmon u;
       dp_print1(cdr u,t)
     end;

symbolic procedure dp_print2 u;
% Prints a dpoly with restricted number of terms.
  (if c and (length u>c) then
        begin scalar i,v,x;
        v:=for i:=1:c collect <>;
        dp_print1(v,nil); write" + # ",length u," terms #"; terpri();
        end
  else << dp_print1(u,nil); terpri() >>)
        where c:=get('cali,'printterms);

% -------------- Auxiliary dpoly operations -------------------

symbolic procedure dp_ecart p;
% Returns the ecart of the dpoly p.
   if null p then 0 else (dp!=ecart p) - (mo_ecart dp_lmon p);

symbolic procedure dp!=ecart p;
   if null p then 0
   else max2(mo_ecart dp_lmon p,dp!=ecart cdr p);

symbolic procedure dp_homogenize(p,x);
% Homogenize (according to mo_ecart) the dpoly p using the variable x.
  if null p then p
  else begin integer maxdeg;
    maxdeg:=0;
    for each y in p do maxdeg:=max2(maxdeg,mo_ecart car y);
    return dp!=compact dp_neworder for each y in p collect
                mo_inc(car y,x,maxdeg-mo_ecart car y) . cdr y;
    end;

symbolic procedure dp_seed(p,s);
% Returns the dpoly p with all vars outside the list s set equal to 1.
  if null p then p
  else dp!=compact dp_neworder
                for each x in p collect mo_seed(car x,s).cdr x;

symbolic procedure dp!=compact p;
% Collect equal terms in the sorted dpoly p.
  if null p then p else dp_sum(list car p,dp!=compact cdr p);

symbolic procedure dp_xlt(p,x);
% x is the main variable. Returns the leading term of p wrt. x or p,
% if p is free of x.
  if null p then p
  else begin scalar d,m;
    d:=mo_varexp(x,dp_lmon p);
    if d=0 then return p;
    return for each m in p join
        if mo_varexp(x,car m)=d then {mo_inc(car m,x,-d) . cdr m};
    end;

% -- dpoly operations based on computation with ideal bases.

symbolic procedure dp_pseudodivmod(g,f);
% Returns a dpoly list {q,r,z} such that z * g = q * f + r and
% z is a dpoly unit. Computes redpol({[f.e_1]},[g.0]).
% g, f and r must belong to the same free module.
   begin scalar u;
   f:=list bas_make1(1,f,dp_from_ei 1);
   g:=bas_make(0,g);
   u:=red_redpol(f,g);
   return {dp_neg dp_deletecomp bas_rep car u,bas_dpoly car u,cdr u};
   end;

symbolic operator dpgcd;
symbolic procedure dpgcd(u,v);
  if !*mode='algebraic then dp_2a dpgcd!*(dp_from_a u,dp_from_a v)
  else dpgcd!*(u,v);

symbolic procedure dpgcd!*(u,v);
% Compute the gcd of two polynomials by the syzygy method :
% 0 = u*u1 + v*v1 => gcd = u/v1 = -v/u1 .
  if dp_unit!? u or dp_unit!? v then dp_fi 1
  else begin scalar w;
    w:=bas_dpoly first dpmat_list
       syzygies!* dpmat_make(2,0,{bas_make(1,u),bas_make(2,v)},nil,nil);
    return car dp_pseudodivmod(u,dp_comp(2,w));
    end;

endmodule; % dpoly

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/hf.red0000644000175000017500000001771211526203062022515 0ustar  giovannigiovannimodule hf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

               ###################################
               ##                               ##
               ##    WEIGHTED HILBERT SERIES    ##
               ##                               ##
               ###################################

This module supports (weighted) Hilbert series computations and
related topics. It contains

        - Two algorithms computing Hilbert series of ideals and
                modules.

Lit.:

[BS]    Bayer, Stillman : J. Symb. Comp. 14 (1992), 31 - 50.

[BCRT]  Bigatti, Conti, Robbiano, Traverso . LNCS 673 (1993), 76 - 88.

The version of the algorithm is chosen through the 'hf!=hf entry on
the property list of 'cali.

END COMMENT;

% Choosing the version of the algorithm and first initialization :

put('cali,'hf!=hf,'hf!=whilb1);

symbolic operator hftestversion;
symbolic procedure hftestversion n;
  if member(n,{1,2}) then
        put('cali,'hf!=hf,mkid('hf!=whilb,n));

% --- first variant : [BS]

symbolic procedure hf!=whilb1(m,w);
% Compute the weighted Hilbert series of the moideal m by the rule
% H(m + (M)) = H((M)) - t^ec(m) * H((M):m)
   if null m then dp_fi 1
   else begin scalar m1,m2;
    for each x in m do
        if mo_linear x then m1:=x . m1 else m2:=x . m2;
    if null m2 then return hf!=whilbmon(m1,w)
    else if null cdr m2 then return hf!=whilbmon(car m2 . m1,w)
    else if hf!=powers m2 then return hf!=whilbmon(append(m1,m2),w)
    else return dp_prod(hf!=whilbmon(m1,w),
            dp_diff(hf!=whilb1(cdr m2,w),
                    dp_times_mo(mo_wconvert(car m2,w),
                        hf!=whilb1(moid_quot(cdr m2,car m2),w))));
    end;

symbolic procedure hf!=whilbmon(m,w);
% Returns the product of the converted dpolys 1 - mo for the
% monomials mo in m.
   if null m then dp_fi 1
   else begin scalar p;
    m:=for each x in m collect
        dp_sum(dp_fi 1,list dp_term(bc_fi(-1),mo_wconvert(x,w)));
    p:=car m;
    for each x in cdr m do p:=dp_prod(p,x);
    return p;
    end;

symbolic procedure hf!=powers m;
% m contains only powers of variables.
  if null m then t
  else (length mo_support car m<2) and hf!=powers cdr m;

Comment

Second variant : by induction on the number of variables using the
exactness of the sequence

        0 --> S/(I:(x))[-deg x] --> S/I --> S/(I+(x)) --> 0

[BCRT] do even better, choosing x not as variable, but as splitting
monomial. I hope to return to that later on.

end Comment;

symbolic procedure hf!=whilb2(m,w);
  if null m then dp_fi 1
   else begin scalar m1,m2,x,p;
    for each x in m do
        if mo_linear x then m1:=x . m1 else m2:=x . m2;
    if null m2 then return hf!=whilbmon(m1,w)
    else if null cdr m2 then return hf!=whilbmon(car m2 . m1,w)
    else if hf!=powers m2 then return hf!=whilbmon(append(m1,m2),w)
    else begin scalar x;
        x:=mo_from_a car mo_support car m2;
        p:=dp_prod(hf!=whilbmon(m1,w),
            dp_sum(hf!=whilb2(moid_red(x . m2),w),
            dp_times_mo(mo_wconvert(x,w),
                hf!=whilb2(moid_quot(m2,x),w))))
        end;
    return p;
    end;

% -------- Weighted Hilbert series from a free resolution --------

symbolic procedure hf_whilb3(u,w);
% Weighted Hilbert series numerator from the resolution u.
  begin scalar sgn,p; sgn:=t;
  for each x in u do
    << if sgn then p:=dp_sum(p,hf!=whilb3(x,w))
       else p:=dp_diff(p,hf!=whilb3(x,w));
       sgn:=not sgn;
    >>;
  return p;
  end;

symbolic procedure hf!=whilb3(u,w);
% Convert column degrees of the dpmat u to a generating polynomial.
  (if length c = dpmat_cols u then
   begin scalar p;
      for each x in c do
        p:=dp_sum(p,{dp_term(bc_fi 1,mo_wconvert(cdr x,w))});
      return p
   end else dp_fi max(1,dpmat_cols u))
  where c:=dpmat_coldegs u;

% ------- The common interface ----------------

symbolic procedure hf_whilb(m,wt);
% Returns the weighted Hilbert series numerator of the dpmat m as
% a dpoly using the internal Hilbert series computation
% get('cali,'hf!=hf) for moideals. m must be a Groebner basis.
  (begin scalar fn,w,lt,p,p1; integer i;
  if null(fn:=get('cali,'hf!=hf)) then
        rederr"No version for the Hilbert function algorithm chosen";
  if dpmat_cols m = 0 then
        return apply2(fn,moid_from_bas dpmat_list m,wt);
    lt:=moid_from_dpmat m;
    for i:=1:dpmat_cols m do
      << p1:=atsoc(i,lt);
         if null p1 then rederr"WHILB with wrong leading term list"
         else p1:=apply2(fn,cdr p1,wt);
         w:=atsoc(i,cali!=degrees);
         if w then p1:=dp_times_mo(mo_wconvert(cdr w,wt),p1);
         p:=dp_sum(p,p1);
       >>;
    return p;
    end) where cali!=degrees:=dpmat_coldegs m;

symbolic procedure hf!=whilb2hs(h,w);
% Converts the Hilbert series numerator h into a rational expression
% with denom = prod ( 1-w(x) | x in ringvars ) and cancels common
% factors. Uses gcdf and returns a s.q.
  begin scalar a,g,den,num;
  num:=numr simp dp_2a h;       % This is the numerator as a s.f.
  den:=1;
  for each x in ring_names cali!=basering do
  << a:=numr simp dp_2a hf!=whilbmon({mo_from_a x},w);
     g:=gcdf!*(num,a);
     num:=quotf(num,g); den:=multf(den,quotf(a,g));
  >>;
  return num ./ den;
  end;

symbolic procedure weightedhilbertseries!*(m,w);
% m must be a Gbasis.
  hf!=whilb2hs(hf_whilb(m,w),w);

symbolic procedure hf_whs_from_resolution(u,w);
% u must be a resolution.
  hf!=whilb2hs(hf_whilb3(u,w),w);

symbolic procedure hilbertseries!* m;
% m must be a Gbasis.
  weightedhilbertseries!*(m,{ring_ecart cali!=basering});

% --------- Multiplicity and dimension ---------------------

symbolic procedure hf_mult n;
% Get the sum of the coefficients of the s.f. (car n). For homogeneous
% ideals and "good" weight vectors this is the multiplicity.
   prepf absf hf!=sum_up car n;

symbolic procedure hf!=sum_up f;
   if numberp f then f else hf!=sum_up car subf(f,list (mvar f . 1));

symbolic procedure hf_dim f;
% Returns the dimension as the pole order at 1 of the HF f.
  if domainp denr f then 0
  else begin scalar g,x,d; integer n;
    f:=denr f; x:=mvar f; n:=0; d:=(((x.1).-1).1);
    while null cdr (g:=qremf(f,d)) do
        << n:=n+1; f:=car g >>;
    return n;
    end;

symbolic procedure degree!* m; hf_mult hilbertseries!* m;

% ------- Algebraic Mode Interface for weighted Hilbert series.

symbolic operator weightedhilbertseries;
symbolic procedure weightedhilbertseries(m,w);
% m must be a gbasis, w a list of weight lists.
  if !*mode='algebraic then
  begin scalar w1,l;
  w1:=for each x in cdr reval w collect cdr x;
  l:=length ring_names cali!=basering;
  for each x in w1 do
        if (not numberlistp x) or (length x neq l)
                then typerr(w,"weight list");
  m:=dpmat_from_a reval m;
  l:=mk!*sq weightedhilbertseries!*(m,w1);
  return l;
  end else weightedhilbertseries!*(m,w);

endmodule; % hf

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/res.red0000644000175000017500000000616411526203062022710 0ustar  giovannigiovannimodule res;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

          ######################
          ###                ###
          ###   RESOLUTIONS  ###
          ###                ###
          ######################

This module contains algorithms on complexes, i.e. chains of modules
(submodules of free modules represented as im f of certain dpmat's).

A chain (in particular a resolution) is a list of dpmat's with the
usual annihilation property of subsequent dpmat's.

This module contains

        - An algorithm to compute a minimal resolution of a dpmat,

        - the same for a local dpmat.

        - the extraction of the (graded) Betti numbers from a
                resolution.

This module is just under development.

END COMMENT;

% ------------- Minimal resolutions --------------

symbolic procedure Resolve!*(m,d);
% Compute a minimal resolution of the dpmat m, i.e. a list of dpmat's
% (s0 s1 s2 ...), where sk is the k-th syzygy module of m, upto the
% d'th part.
  (begin scalar a,u;
  if dpmat_cols m=0 then
    << cali!=degrees:=nil; m:=ideal2mat!* m>>
  else cali!=degrees:=dpmat_coldegs m;
  a:=list(m); u:=syzygies!* m;
  while (not dpmat_zero!? u)and(d>1) do
    << m:=u; u:=syzygies!* m; d:=d-1;
       u:=groeb_minimize(m,u); m:=car u; u:=cdr u; a:=m . a;
    >>;
  return reversip (u.a);
  end) where cali!=degrees:=cali!=degrees;

% ----------------- The Betti numbers -------------

symbolic procedure bettiNumbers!* c;
% Returns the list of Betti numbers of the chain c.
   for each x in c collect dpmat_cols x;

symbolic procedure gradedBettiNumbers!* c;
% Returns the list of degree lists (according to the ecart) of the
% generators of the chain c.
  for each x in c collect
     begin scalar i,d; d:=dpmat_coldegs x;
        return
    if d then sort(for each y in d collect mo_ecart cdr y,'leq)
        else for i:=1:dpmat_cols x collect 0;
     end;

endmodule; % res

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/red.red0000644000175000017500000003135011526203062022664 0ustar  giovannigiovannimodule red;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

                    #################
                    ##             ##
                    ## NORMAL FORM ##
                    ## ALGORITHMS  ##
                    ##             ##
                    #################

This module contains normal form algorithms for base elements. All
reductions executed on the dpoly part, are repeated on the rep part,
hence tracing them up for further use. We do pseudoreduction, but
organized following up the multipliers in a different way than in the
version 2.1 :

For total reduction we hide terms prefixing the current lead term on the
negative slots of the rep part. This allows not to follow up the
multipliers, since head terms are multiplied automatically.

If You nevertheless need the multipliers, You can prepare the base
elements with "red_prepare" to keep track of them using the 0-slot of
the rep-part :

        f --> (f,e_0) -NF-> (f',z*e_0) --> (f' . z)

Extract the multiplier back with "red_extract". This allows a unified
treating of the multipliers for both noetherian and non noetherian
term orders.

For     NF : [f,r] |--> [f',r']         using B={[f_i,r_i]}
with representation parts r, r_i we get

                f' = z*f + \sum a_i*f_i
                r' = z*r + \sum a_i*r_i

The output trace intensity can be managed with cali_trace() that has
the following meaning :

       cali_trace() >=  0      no trace
                       10      '.' for each substitution
                       70      trace interreduce!*
                       80      trace redpol
                       90      show substituents

The reduction strategy is first matching in the simplifier (base)
list. It can be changed overloading red_better, the relation
according to what base lists are sorted. Standard is minimal ecart,
breaking ties with minimal length (since such a strategy is good for
both the classical and the local case).

There are two (head) reduction functions, the usual one and one, that
allows reduction only by reducers with bounded ecart, i.e. where the
ecart of the reducer is leq the ecart of the poly to be reduced. This
allows a unified handling of noetherian and non-noetherian term orders.

Switches :

          red_total :   t      compute total normal forms
                        nil    reduce only until lt is standard
          bcsimp    :   t      apply bas_simp


END COMMENT;

% Standard is :

!*red_total:=t;
!*bcsimp:=t;

symbolic procedure red_better(a,b);
% Base list sort criterion. Simplifier lists are sorted such that the
% best substituent comes first. Due to reduction with bounded ecart we
% need no more lowest ecarts first.
  bas_dplen a < bas_dplen b;

% ---- Preparing data for collecting multipliers  ---

symbolic procedure red_prepare model;
% Prepare the zero rep-part to follow up multipliers
% in the pseudoreductions.
%         if !*binomial then model else
  bas_make1(bas_nr model,bas_dpoly model,
                dp_sum(bas_rep model,dp_from_ei 0));

symbolic procedure red_extract model;
% Returns (model . dpoly), extracting the multiplier part from the
% zero rep-part.
%    if !*binomial then (model . dp_fi 1) else
  (bas_make1(bas_nr model, bas_dpoly model,
                dp_diff(bas_rep model,z)) . z
     where z=dp_comp(0,bas_rep model));

% -------- Substitution operations ----------------

symbolic procedure red_subst(model,basel);
%  model and basel = base elements
%  Returns a base element, such that
%       pol_new := z * pol_old - z1 * mo * f_a
%       rep_new := z * rep_old - z1 * mo * rep_a
% with appropriate base coeff. z and z1 and monomial mo.

%  if !*binomial then red!=subst2(model,basel) else
  red!=subst1(model,basel);

symbolic procedure red!=subst1(model,basel);
    begin scalar polold,polnew,repold,repnew,gcd,mo,fa,z,z1;
        polold:=bas_dpoly model; z1:=dp_lc polold;
        repold:=bas_rep model;
        fa:=bas_dpoly basel; z:= dp_lc fa;
        if !*bcsimp then      % modify z and z1
          if (gcd:=bc_inv z) then
            << z1:=bc_prod(z1,gcd); z:=bc_fi 1 >>
          else
            << gcd:=bc_gcd(z,z1);
               z:=car bc_divmod(z,gcd);
               z1:=car bc_divmod(z1,gcd)
            >>;
        mo:=mo_diff(dp_lmon polold,dp_lmon fa);
        polnew:=dp_diff(dp_times_bc(z,polold),
                                dp_times_bcmo(z1,mo,fa));
        repnew:=dp_diff(dp_times_bc(z,repold),
                                dp_times_bcmo(z1,mo,bas_rep basel));
        if cali_trace() > 79 then
                << prin2 "---> "; dp_print polnew >>
        else if cali_trace() > 0 then prin2 ".";
        if cali_trace() > 89 then
                << prin2 " uses "; dp_print fa >>;
        return bas_make1(bas_nr model,polnew,repnew);
    end;

symbolic procedure red!=subst2(model,basel);
% Only for binomials without representation parts.
    begin scalar m,b,u,r;
    if cali_trace()>0 then prin2 ".";
    m:=bas_dpoly model; b:=bas_dpoly basel;
    if (length b neq 2) or bas_rep model then
            rederr"switch off binomial";
    u:=mo_qrem(dp_lmon m,dp_lmon b);
    r:=list dp_term(dp_lc m,
                mo_sum(mo_power(dp_lmon cdr b,car u),cdr u));
    return bas_make(bas_nr model,dp_sum(r,cdr m));
    end;

% ---------------- Top reduction ------------------------

symbolic procedure red_TopRedBE(bas,model);
% Takes a base element model and returns it top reduced with bounded
% ecart.
  if (null bas_dpoly model) or (null bas) then model
  else begin
     scalar v,q;
     if cali_trace()>79 then
       << write" reduce "; dp_print bas_dpoly model >>;
     while (q:=bas_dpoly model) and
                (v:=red_divtestBE(bas,dp_lmon q,bas_dpecart model)) do
                        model:=red_subst(model,v);
     return model;
     end;

symbolic procedure red_divtestBE(a,b,e);
% Returns the first f in the base list a, such that lt(f) | b
% and ec(f)<=e, else nil. b is a monomial.
  if null a then nil
  else if (bas_dpecart(car a) <= e) and
        mo_vdivides!?(dp_lmon bas_dpoly car a,b) then car a
  else red_divtestBE(cdr a,b,e);

symbolic procedure red_divtest(a,b);
% Returns the first f in the base list a, such that lt(f) | b else nil.
% b is a monomial.
  if null a then nil
  else if mo_vdivides!?(dp_lmon bas_dpoly car a,b) then car a
  else red_divtest(cdr a,b);

symbolic procedure red_TopRed(bas,model);
% Takes a base element model and returns it top reduced.
% For noetherian term orders this is the classical top reduction; no
% additional simplifiers occur. For local term orders it is Mora's
% reduction by minimal ecart.
  if (null bas_dpoly model) or (null bas) then model
  else begin
     scalar v,q;
        % Make first reduction with bounded ecart.
     model:=red_TopRedBE(bas,model);
        % Now loop into reduction with minimal ecart.
     while (q:=bas_dpoly model) and (v:=red_divtest(bas,dp_lmon q)) do
         << v:=red_subst(model,v);
            if not !*noetherian then bas:=red_update(bas,model);
            model:=red_TopRedBE(bas,v);
         >>;
     return model;
     end;

% Management of the simplifier list. Has a meaning only in the
% non noetherian case.

symbolic procedure red_update(simp,b);
% Update the simplifier list simp with the base element b.
    begin
    if cali_trace()>59 then
      << terpri(); write "[ec:",bas_dpecart b,"] ->";
         dp_print2 bas_dpoly b
      >>
    else if cali_trace()>0 then write"*";
    return merge(list b,
                for each x in simp join
                        if red!=cancelsimp(b,x) then nil else {x},
                function red_better);
    end;

symbolic procedure red!=cancelsimp(a,b);
% Test for updating the simplifier list.
  red_better(a,b) and
        mo_vdivides!?(dp_lmon bas_dpoly a,dp_lmon bas_dpoly b);

% ------------- Total reduction and Tail reduction -----------

Comment

For total reduction one has to organize recursive calls of TopRed on
tails of the current model. Since we do pseudoreduction, we have to
multiply the prefix terms with the multiplier during recursive calls.
We do that, hiding the prefix terms on rep part components with
negative component number. Retrival may be done not recursively, but
in a single step.

end Comment;

symbolic procedure red!=hide p;
% Hide the terms of the dpoly p. This is involutive !
  for each x in p collect (mo_times_ei(-1,mo_neg car x) . cdr x);

symbolic procedure red!=hideLt model;
  bas_make1(bas_nr model,cdr p,
        dp_sum(bas_rep model, red!=hide({car p})))
  where p=bas_dpoly model;

symbolic procedure red!=recover model;
% The dpoly part of model is empty, but the rep part contains
% hidden terms.
   begin scalar u,v;
     for each x in bas_rep model do
        if mo_comp car x < 0 then u:=x.u else v:=x.v;
     return bas_make1(bas_nr model, dp_neworder reversip red!=hide u,
                reversip v);
   end;

symbolic procedure red_TailRedDriver(bas,model,redfctn);
% Takes a base element model and reduces the tail with the
% top reduce "redfctn" recursively.
  if (null bas_dpoly model) or (null cdr bas_dpoly model)
                or (null bas) then model
  else begin
     while bas_dpoly model do
        model:=apply2(redfctn,bas,red!=hideLt(model));
     return red!=recover(model);
     end;

symbolic procedure red_TailRed(bas,model);
% The tail reduction as we understand it at the moment.
  if !*noetherian then
        red_TailRedDriver(bas,model,function red_TopRed)
  else red_TailRedDriver(bas,model,function red_TopRedBE);

symbolic procedure red_TotalRed(bas,model);
% Make a terminating total reduction, i.e. for noetherian term orders
% the classical one and for local term orders tail reduction with
% bounded ecart.
  red_TailRed(bas,red_TopRed(bas,model));

% ---------- Reduction of the straightening parts --------

symbolic procedure red_Straight(bas);
% Autoreduce straightening formulae of the base list bas, classical
% in the noetherian case and with bounded ecart in the local case.
  begin scalar u;
  u:=for each x in bas collect red_TailRed(bas,x);
  if !*bcsimp then u:=bas_simp u;
  return sort(u,function red_better);
  end;

symbolic procedure red_collect bas;
% Returns ( bas1 . bas2 ), where bas2 may be reduced with bas1.
    begin scalar bas1,bas2;
    bas1:=listminimize(bas,function (lambda(x,y);
         mo_vdivides!?(dp_lmon bas_dpoly x,dp_lmon bas_dpoly y)));
    bas2:=setdiff(bas,bas1);
    return bas1 . bas2;
    end;

symbolic procedure red_TopInterreduce m;
% Reduce rows of the base list m with red_TopRed until it has pairwise
% incomparable leading terms
% Compute correct representation parts. Do no tail reduction.

    begin scalar c,w,bas1;
    m:=bas_sort bas_zerodelete m;
    if !*bcsimp then m:=bas_simp m;
    while cdr (c:=red_collect m) do
      << if cali_trace()>69 then
                <>;
         m:=nil; w:=cdr c; bas1:=car c;
         while w do
           << c:=red_TopRed(bas1,car w);
              if bas_dpoly c then m:=c . m;
              w:=cdr w
            >>;
         if !*bcsimp then m:=bas_simp m;
         m:=merge(bas1,bas_sort m,function red_better);
      >>;
    return m;
    end;

% ----- Interface to the former syntax --------------

symbolic procedure red_redpol(bas,model);
% Returns (reduced model . multiplier)
  begin scalar m;
  m:=red_prepare model;
  return red_extract
    (if !*red_total then red_TotalRed(bas,m) else red_TopRed(bas,m))
  end;

symbolic procedure red_Interreduce m;
% Applies to arbitrary term orders.
   begin
        % Top reduction, producing pairwise incomparable leading terms.
   m:=red_TopInterreduce m;
   if !*red_total then m:=red_Straight m; % Tail reduction :
   return m;
   end;

endmodule;  % red

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/groeb.red0000644000175000017500000005437111526203062023220 0ustar  giovannigiovannimodule groeb;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

              ##############################
              ##                          ##
              ##      GROEBNER PACKAGE    ##
              ##                          ##
              ##############################

This is now a common package, covering both the noetherian and the
local term orders.

The trace intensity can be managed with cali_trace() by the following
rules :

      cali_trace() >=   0      no trace
                        2      show actual step
                       10      show input and output
                       20      show new base elements
                       30      show pairs
                       40      show actual pairlist
                       50      show S-polynomials

Pair lists have the following informal syntax :

      ::= list of spairs
      < spair >  ::= (komp  groeb!=weight  lcm  p_i  p_j)
               with lcm = lcm(lt(bas_dpoly p_i),lt(bas_dpoly p_j)).


The pair selection strategy is by first matching in the pair list.
It can be changed overloading groeb!=better, the relation according to
what pair lists are sorted. Standard is the sugar strategy.

cali!=monset :

One can manage a list of variables, that are allowed to be canceled
out, if they appear as common factors in a dpoly. This is possible if
these variables are non zero divisors (e.g. for prime ideals) and
affects "pure" Groebner basis computation only.

END COMMENT;


% ############   The outer Groebner engine   #################

put('cali,'groeb!=rf,'groeb!=rf1); % First initialization.

symbolic operator gbtestversion;
symbolic procedure gbtestversion n; % Choose the corresponding driver
  if member(n,{1,2,3}) then
        put('cali,'groeb!=rf,mkid('groeb!=rf,n));

symbolic procedure groeb!=postprocess pol;
% Postprocessing for irreducible H-Polynomials. The switches got
% appropriate local values in the Groebner engine.
  begin
  if !*bcsimp then pol:=car bas_simpelement pol;
  if not !*noetherian then
        if !*factorunits then pol:=bas_factorunits pol
        else if !*detectunits then pol:=bas_detectunits pol;
  if cali!=monset then pol:=bas_make(bas_nr pol,
                      car dp_mondelete(bas_dpoly pol,cali!=monset));
  return pol
  end;

symbolic procedure groeb_stbasis(bas,comp_mgb,comp_ch,comp_syz);
  groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz,
                                function groeb!=generaldriver);

symbolic procedure
        groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz,driver);
% Returns { mgb , change , syz } with
%       dpmat mgb = (if comp_mgb=true the minimal)
%               Groebner basis of the dpmat bas.
%       dpmat change defined by   mgb = change * bas
%               if comp_ch = true.
%       dpmat syz = (not interreduced) syzygy matrix of the dpmat bas
%               if comp_syz = true.
% Changes locally !*factorunits, !*detectunits and cali!=monset.

   if dpmat_zero!? bas then
       {bas,dpmat_unit(dpmat_rows bas,nil),
            dpmat_unit(dpmat_rows bas,nil)}
   else (begin scalar u, gb, syz, change, syz1;

        % ------- Syzygies for the zero base elements.
   if comp_syz then
   << u:=setdiff(for i:=1:dpmat_rows bas collect i,
                for each x in
                bas_zerodelete dpmat_list bas collect bas_nr x);
      syz1:=for each x in u collect bas_make(0,dp_from_ei x);
   >>;

        % ------- Initialize the Groebner computation.
   gb:=bas_zerodelete dpmat_list bas;
                % makes a copy (!) of the base list.
   if comp_ch or comp_syz then
   << !*factorunits:=!*detectunits:=cali!=monset:=nil;
      bas_setrelations gb;
   >>;
   if cali_trace() > 5 then
      << terpri(); write" Compute GBasis of"; bas_print gb >>
   else if cali_trace() > 0 then
      << terpri(); write" Computing GBasis  ";terpri() >>;
   u:=apply(driver,{dpmat_rows bas,dpmat_cols bas,gb,comp_syz});
   syz:=second u;
   if comp_mgb then
        << u:=groeb_mingb car u;
           if !*red_total then
                u:=dpmat_make(dpmat_rows u,dpmat_cols u,
                            red_straight dpmat_list u,
                            cali!=degrees,t);
        >>
   else u:=car u;
   cali!=degrees:=dpmat_rowdegrees bas;
   if comp_ch then
       change:=dpmat_make(dpmat_rows u,dpmat_rows bas,
                bas_neworder bas_getrelations dpmat_list u,
                cali!=degrees,nil);
   bas_removerelations dpmat_list u;
   if comp_syz then
   << syz:=nconc(syz,syz1);
      syz:= dpmat_make(length syz,dpmat_rows bas,
                bas_neworder bas_renumber syz,cali!=degrees,nil);
   >>;
   cali!=degrees:=dpmat_coldegs u;
   return {u,change,syz}
   end) where cali!=degrees:=dpmat_coldegs bas,
                !*factorunits:=!*factorunits,
                !*detectunits:=!*detectunits,
                cali!=monset:=cali!=monset;

% #########   The General Groebner driver ###############

Comment

It returns {gb,syz,trace}  with change on the relation part of gb,
where
  INPUT  : r, c, gb = rows, columns, base list
  OUTPUT :
        gb is the Groebner basis
        syz is the dpmat_list of the syzygy matrix
        trace is the Groebner trace.

There are three different versions of the general driver that branche
according to a reduction function
        rf : {pol,simp} |---> {pol,simp}
found with get('cali,'groeb!=rf):

1. Total reduction with local simplifier lists. For local term orders
        this is (almost) Mora's first version for the tangent cone.

2. Total reduction with global simplifier list. For local term orders
        this is (almost) Mora's SimpStBasis.

3. Total reduction with bounded ecart. This needs no extra simplifier
        list.

end Comment;

symbolic procedure groeb!=generaldriver(r,c,gb,comp_syz);
  begin scalar u, q, syz, p, pl, pol, trace, return_by_unit,
                simp, rf, Ccrit;
    Ccrit:=(not comp_syz) and (c<2); % don't reduce main syzygies
    simp:=sort(listminimize(gb,function red!=cancelsimp),
                function red_better);
    pl:=groeb_makepairlist(gb,Ccrit);
    rf:=get('cali,'groeb!=rf);
    if cali_trace() > 30 then groeb_printpairlist pl;
    if cali_trace() > 5 then
        <>;

    % -------- working out pair list
    while pl and not return_by_unit do
    << % ------- Choose a pair
       p:=car pl; pl:=cdr pl;

       % ------ compute S-polynomial (which is a base element)
       if cali_trace() > 10 then groeb_printpair(p,pl);
       u:=apply2(rf,groeb_spol p,simp);
       pol:=first u; simp:=second u;
       if cali_trace() > 70 then
       << terpri(); write" Reduced S.-pol. : ";
          dp_print2 bas_dpoly pol
       >>;

       if bas_dpoly pol then
              % --- the S-polynomial doesn't reduce to zero
       << pol:=groeb!=postprocess pol;
          r:=r+1;
          pol:=bas_newnumber(r,pol);

                   % --- update the tracelist
          q:=bas_dpoly pol;
          trace:=list(groeb!=i p,groeb!=j p,r,dp_lmon q) . trace;

          if cali_trace() > 20 then
            << terpri(); write r,". ---> "; dp_print2 q >>;
          if Ccrit and (dp_unit!? q) then return_by_unit:=t;

                   % ----- update
          if not return_by_unit then
          << pl:=groeb_updatePL(pl,gb,pol,Ccrit);
             if cali_trace() > 30 then
                << terpri(); groeb_printpairlist pl >>;
              gb:=pol.gb;
              simp:=red_update(simp,pol);
          >>;
       >>

       else % ------ S-polynomial reduces to zero
       if comp_syz then
             syz:=car bas_simpelement(bas_make(0,bas_rep pol)) . syz
    >>;

    % --------  updating the result
    if cali_trace()>0 then
    << terpri(); write " Simplifier list has length ",length simp >>;
    if return_by_unit then return
        % --- no syzygies are to be computed
        {dpmat_from_dpoly pol,nil,reversip trace};
    gb:=dpmat_make(length gb,c,gb,cali!=degrees,t);
    return {gb,syz,reversip trace}
    end;

% --- The different reduction functions.

symbolic procedure groeb!=rf1(pol,simp); {red_TotalRed(simp,pol),simp};

symbolic procedure groeb!=rf2(pol,simp);
  if (null bas_dpoly pol) or (null simp) then {pol,simp}
  else begin scalar v,q;

        % Make first reduction with bounded ecart.
     pol:=red_TopRedBE(simp,pol);

        % Now loop into reduction with minimal ecart.
     while (q:=bas_dpoly pol) and (v:=red_divtest(simp,dp_lmon q)) do
         << v:=red_subst(pol,v);
                % Updating the simplifier list could make sense even
                % for the noetherian case, since it is a global list.
            simp:=red_update(simp,pol);
            pol:=red_TopRedBE(simp,v);
         >>;

        % Now make tail reduction
     if !*red_total and bas_dpoly pol then pol:=red_TailRed(simp,pol);
     return {pol,simp};
     end;

symbolic procedure groeb!=rf3(pol,simp);
% Total reduction with bounded ecart.
  if (null bas_dpoly pol) or (null simp) then {pol,simp}
  else begin
     pol:=red_TopRedBE(simp,pol);
     if bas_dpoly pol then
        pol:=red_TailRedDriver(simp,pol,function red_TopRedBE);
     return {pol,simp};
     end;

% #########   The Lazy Groebner driver ###############

Comment

The lazy groebner driver implements the lazy strategy for local
standard bases, i.e. stepwise reduction of S-Polynomials according to
a refinement of the (ascending) division order on leading terms.

end Comment;


symbolic procedure groeb_lazystbasis(bas,comp_mgb,comp_ch,comp_syz);
  groeb!=choose_driver(bas,comp_mgb,comp_ch,comp_syz,
                                function groeb!=lazydriver);

symbolic procedure groeb!=lazymocompare(a,b);
% A dpoly with leading monomial a should be processed before dpolys
% with leading monomial b.
  mo_ecart a < mo_ecart b;

symbolic procedure groeb!=queuesort(a,b);
% Sort criterion for the queue.
  groeb!=lazymocompare(dp_lmon bas_dpoly a,dp_lmon bas_dpoly b);

symbolic procedure groeb!=nextspol(pl,queue);
% True <=> take first pl next.
  if null queue then t
  else if null pl then nil
  else groeb!=lazymocompare(nth(car pl,3),dp_lmon bas_dpoly car queue);

symbolic procedure groeb!=lazydriver(r,c,gb,comp_syz);
% The lazy version of the driver.
  begin scalar syz, Ccrit, queue, v, simp, p, pl, pol, return_by_unit;
    simp:=sort(listminimize(gb,function red!=cancelsimp),
                function red_better);
    Ccrit:=(not comp_syz) and (c<2); % don't reduce main syzygies
    pl:=groeb_makepairlist(gb,Ccrit);
    if cali_trace() > 30 then groeb_printpairlist pl;
    if cali_trace() > 5 then
        <>;

    % -------- working out pair list

    while (pl or queue) and not return_by_unit do
      if groeb!=nextspol(pl,queue) then
      << p:=car pl; pl:=cdr pl;
         if cali_trace() > 10 then groeb_printpair(p,pl);
         pol:=groeb_spol p;
         if bas_dpoly pol then % back into the queue
             if Ccrit and dp_unit!? bas_dpoly pol then
                        return_by_unit:=t
             else queue:=merge(list pol, queue,
                                    function groeb!=queuesort)
         else if comp_syz then % pol reduced to zero.
                syz:=bas_simpelement bas_make(0,bas_rep pol).syz;
      >>
      else
      << pol:=car queue; queue:=cdr queue;
           % Try one top reduction step
         if (v:=red_divtestBE(simp,dp_lmon bas_dpoly pol,
                        bas_dpecart pol)) then ()
                % do nothing with simp !
         else if (v:=red_divtest(simp,dp_lmon bas_dpoly pol)) then
                simp:=red_update(simp,pol);
           % else v:=nil;
         if v then % do one top reduction step
         << pol:=red_subst(pol,v);
            if bas_dpoly pol then % back into the queue
                queue:=merge(list pol, queue,
                                function groeb!=queuesort)
            else if comp_syz then % pol reduced to zero.
                 syz:=bas_simpelement bas_make(0,bas_rep pol).syz;
         >>
         else % no reduction possible
         << % make a tail reduction with bounded ecart and the
            % usual postprocessing :
            pol:=groeb!=postprocess
                if !*red_total then
                red_TailRedDriver(gb,pol,function red_TopRedBE)
                else pol;
            if dp_unit!? bas_dpoly pol then return_by_unit:=t
            else % update the computation
            << r:=r+1; pol:=bas_newnumber(r,pol);
               if cali_trace() > 20 then
               << terpri(); write r,". --> "; dp_print2 bas_dpoly pol>>;
               pl:=groeb_updatePL(pl,gb,pol,Ccrit);
               simp:=red_update(simp,pol);
               gb:=pol.gb;
            >>
         >>
      >>;

     % --------  updating the result

    if cali_trace()>0 then
    << terpri(); write " Simplifier list has length ",length simp >>;
    if return_by_unit then return {dpmat_from_dpoly pol,nil,nil}
    else return
        {dpmat_make(length simp,c,simp,cali!=degrees,t), syz, nil}
    end;

% ################  The Groebner Tools ##############

% ---------- Critical pair criteria -----------------------

symbolic procedure groeb!=critA(p);
% p is a pair list {(i.k):i running} of pairs with equal module
% component number. Choose those pairs among them that are minimal wrt.
% division order on lcm(i.k).
  listminimize(p,function groeb!=testA);

symbolic procedure groeb!=testA(p,q); mo_divides!?(nth(p,3),nth(q,3));

symbolic procedure groeb!=critB(e,p);
% Delete pairs from p, for which testB is false.
  for each x in p join if not groeb!=testB(e,x) then {x};

symbolic procedure groeb!=testB(e,a);
% e=lt(f_k). Test, whether for a=pair (i j)
% komp(a)=komp(e) and Syz(i,j,k)=[ 1 * * ].
    (mo_comp e=car a)
    and mo_divides!?(e,nth(a,3))
    and (not mo_equal!?(mo_lcm(dp_lmon bas_dpoly nth(a,5),e),
                        nth(a,3)))
    and (not mo_equal!?(mo_lcm(dp_lmon bas_dpoly nth(a,4),e),
                        nth(a,3)));

symbolic procedure groeb!=critC(p);
% Delete main syzygies.
  for each x in p join if not groeb!=testC1 x then {x};

symbolic procedure groeb!=testC1 el;
    mo_equal!?(
        mo_sum(dp_lmon bas_dpoly nth(el,5),
               dp_lmon bas_dpoly nth(el,4)),
        nth(el,3));

symbolic procedure groeb_updatePL(p,gb,be,Ccrit);
% Update the pairlist p with the new base element be and the old ones
% in the base list gb. Discard pairs where both base elements have
% number part 0.
    begin scalar p1,k,a,n; n:=(bas_nr be neq 0);
    a:=dp_lmon bas_dpoly be; k:=mo_comp a;
    for each b in gb do
        if (k=mo_comp dp_lmon bas_dpoly b)
                and(n or (bas_nr b neq 0)) then
                        p1:=groeb!=newpair(k,b,be).p1;
    p1:=groeb!=critA(sort(p1,function groeb!=better));
    if Ccrit then p1:=groeb!=critC p1;
    return
        merge(p1,
              groeb!=critB(a,p), function groeb!=better);
    end;

symbolic procedure groeb_makepairlist(gb,Ccrit);
    begin scalar newgb,p;
    while gb do
    << p:=groeb_updatePL(p,newgb,car gb,Ccrit);
       newgb:=car gb .  newgb; gb:=cdr gb
    >>;
    return p;
    end;

% -------------- Pair Management --------------------

symbolic procedure groeb!=i p; bas_nr nth(p,4);

symbolic procedure groeb!=j p; bas_nr nth(p,5);

symbolic procedure groeb!=better(a,b);
% True if the Spair a is better than the Spair b.
    if (cadr a < cadr b) then t
    else if (cadr a = cadr b) then mo_compare(nth(a,3),nth(b,3))<=0
    else nil;

symbolic procedure groeb!=weight(lcm,p1,p2);
    mo_ecart(lcm) + min2(bas_dpecart p1,bas_dpecart p2);

symbolic procedure groeb!=newpair(k,p1,p2);
% Make an spair from base elements with common component number k.
    list(k,groeb!=weight(lcm,p1,p2),lcm, p1,p2)
        where lcm =mo_lcm(dp_lmon bas_dpoly p1,dp_lmon bas_dpoly p2);

symbolic procedure groeb_printpairlist p;
    begin
    for each x in p do
        << write groeb!=i x,".",groeb!=j x; print_lf  " | " >>;
    terpri();
    end;

symbolic procedure groeb_printpair(pp,p);
    begin terpri();
    write"Investigate (",groeb!=i pp,".",groeb!=j pp,")  ",
        "Pair list has length ",length p; terpri()
    end;

% ------------- S-polynomial constructions -----------------

symbolic procedure groeb_spol pp;
% Make an S-polynomial from the spair pp, i.e. return
% a base element with
%   dpoly = ( zi*mi*(red) pi - zj*mj*(red) pj )
%    rep  = (zi*mi*rep_i - zj*mj*rep_j),
%
%       where mi=lcm/lm(pi), mj=lcm/lm(pj)
%       and  zi and zj are appropriate scalars.
%
    begin scalar pi,pj,ri,rj,zi,zj,lcm,mi,mj,a,b;
      a:=nth(pp,4); b:=nth(pp,5); lcm:=nth(pp,3);
      pi:=bas_dpoly a; pj:=bas_dpoly b; ri:=bas_rep a; rj:=bas_rep b;
      mi:=mo_diff(lcm,dp_lmon pi); mj:=mo_diff(lcm,dp_lmon pj);
      zi:=dp_lc pj; zj:=bc_neg dp_lc pi;
      a:=dp_sum(dp_times_bcmo(zi,mi, cdr pi),
                dp_times_bcmo(zj,mj, cdr pj));
      b:=dp_sum(dp_times_bcmo(zi,mi, ri),
                dp_times_bcmo(zj,mj, rj));
      a:=bas_make1(0,a,b);
      if !*bcsimp then a:=car bas_simpelement a;
      if cali_trace() > 70 then
         << terpri(); write" S.-pol : "; dp_print2 bas_dpoly a >>;
      return a;
    end;

symbolic procedure groeb_mingb gb;
% Returns the min. Groebner basis dpmat mgb of the dpmat gb
% discarding base elements with bas_nr<=0.
   begin scalar u;
    u:=for each x in car red_collect dpmat_list gb join
                if bas_nr x>0 then {x};
        % Choosing base elements with minimal leading terms only.
    return dpmat_make(length u,dpmat_cols gb,bas_renumber u,
                    dpmat_coldegs gb,dpmat_gbtag gb);
    end;

% ------- Minimizing a basis using its syszgies ---------

symbolic procedure groeb!=delete(l,bas);
% Delete base elements from the base list bas with number in the
% integer list l.
    begin scalar b;
    while bas do
      << if not memq(bas_nr car bas,l) then b:=car bas . b;
         bas:= cdr bas
      >>;
    return reverse b
    end;

symbolic procedure groeb_minimize(bas,syz);
% Minimize the dpmat pair bas,syz deleting superfluous base elements
% from bas using syzygies from syz containing unit entries.
   (begin scalar drows, dcols, s,s1,i,j,p,q,y;
   cali!=degrees:=dpmat_coldegs syz;
   s1:=dpmat_list syz; j:=0;
   while j < dpmat_rows syz do
     << j:=j+1;
        if (q:=bas_dpoly bas_getelement(j,s1)) then
          << i:=0;
             while leq(i,dpmat_cols syz) and
                 (memq(i,dcols) or not dp_unit!?(p:=dp_comp(i,q)))
                        do i:=i+1;
             if leq(i,dpmat_cols syz) then
               << drows:=j . drows;
                  dcols:=i . dcols;
                  s1:=for each x in s1 collect
                     if memq(bas_nr x,drows) then x
                     else (bas_make(bas_nr x,
                        dp_diff(dp_prod(y,p),dp_prod(q,dp_comp(i,y))))
                           where y:=bas_dpoly x);
               >>
          >>
     >>;

   % --- s1 becomes the new syzygy part, s the new base part.

   s1:=bas_renumber bas_simp groeb!=delete(drows,s1);
   s1:=dpmat_make(length s1,dpmat_cols syz,s1,cali!=degrees,nil);
                        % The new syzygy matrix of the old basis.
   s:=dpmat_renumber
          dpmat_make(dpmat_rows bas,dpmat_cols bas,
                groeb!=delete(dcols,dpmat_list bas),
                dpmat_coldegs bas,nil);
   s1:=dpmat_mult(s1,dpmat_transpose cdr s);
        % The new syzygy matrix of the new basis, but not yet in the
        % right form since cali!=degrees is empty.
   s:=car s;            % The new basis.
   cali!=degrees:=dpmat_rowdegrees s;
   s1:=interreduce!* dpmat_make(dpmat_rows s1,dpmat_cols s1,
                bas_neworder dpmat_list s1,cali!=degrees,nil);
   return s.s1;
   end) where cali!=degrees:=cali!=degrees;

% ------ Computing standard bases via homogenization ----------------

symbolic procedure groeb_homstbasis(m,comp_mgb,comp_ch,comp_syz);
  (begin scalar v,c,u;
  c:=cali!=basering; v:=list gensym();
  if not(comp_ch or comp_syz) then cali!=monset:=append(v,cali!=monset);
  setring!* ring_sum(c,ring_define(v,nil,'lex,'(1)));
  cali!=degrees:=mo_degneworder dpmat_coldegs m;
  if cali_trace()>0 then print" Homogenize input ";
  u:=(groeb_stbasis(mathomogenize!*(m,car v),
                comp_mgb,comp_ch,comp_syz) where !*noetherian=t);
  if cali_trace()>0 then print" Dehomogenize output ";
  u:=for each x in u collect if x then matdehomogenize!*(x,car v);
  setring!* c; cali!=degrees:=dpmat_coldegs m;
  return {if first u then dpmat_neworder(first u,t),
                if second u then dpmat_neworder(second u,nil),
                if third u then dpmat_neworder(third u,nil)};
  end) where cali!=basering:=cali!=basering,
                cali!=monset:=cali!=monset,
                cali!=degrees:=cali!=degrees;


% Two special versions for standard basis computations, not included
% in full generality into the algebraic interface.

symbolic operator homstbasis;
symbolic procedure homstbasis m;
  if !*mode='algebraic then dpmat_2a homstbasis!* dpmat_from_a m
  else homstbasis!* m;

symbolic procedure homstbasis!* m;
  groeb_mingb car groeb_homstbasis(m,t,nil,nil);

symbolic operator lazystbasis;
symbolic procedure lazystbasis m;
  if !*mode='algebraic then dpmat_2a lazystbasis!* dpmat_from_a m
  else lazystbasis!* m;

symbolic procedure lazystbasis!* m;
  car groeb_lazystbasis(m,t,nil,nil);

endmodule;  % groeb

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/dpmat.red0000644000175000017500000003071311526203062023221 0ustar  giovannigiovannimodule dpmat;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

                 #####################
                 ###               ###
                 ###    MATRICES   ###
                 ###               ###
                 #####################

This module introduces special dpoly matrices with its own matrix
syntax.

Informal syntax :

  ::= list('DPMAT,#rows,#cols,baslist,column_degrees,gb-tag)

Dpmat's are the central data structure exploited in the modules of
this package. Each such matrix describes a map

                   f : R^rows --> R^cols,

that gives rise for the definition of two modules,

                im f = the submodule of R^cols generated by the rows
                       of the matrix

        and  coker f = R^cols/im f.

Conceptually dpmat's are identified with im f.

END COMMENT;

% ------------- Reference operators ----------------

symbolic procedure dpmat_rows m; cadr m;
symbolic procedure dpmat_cols m; caddr m;
symbolic procedure dpmat_list m; cadddr m;
symbolic procedure dpmat_coldegs m; nth(m,5);
symbolic procedure dpmat_gbtag m; nth(m,6);

% ------------- Elementary operations --------------

symbolic procedure dpmat_rowdegrees m;
% Returns the row degrees of the dpmat m as an assoc. list.
  (for each x in dpmat_list m join
        if (bas_nr x > 0) and bas_dpoly x then
                {(bas_nr x).(mo_getdegree(dp_lmon bas_dpoly x,l))})
  where l=dpmat_coldegs m;

symbolic procedure dpmat_make(r,c,bas,degs,gbtag);
  list('dpmat,r,c,bas,degs,gbtag);

symbolic procedure dpmat_element(r,c,mmat);
% Returns mmat[r,c].
   dp_neworder
        dp_comp(c, bas_dpoly bas_getelement(r,dpmat_list mmat));

symbolic procedure dpmat_print m; mathprint dpmat_2a m;

symbolic procedure getleadterms!* m;
% Returns the dpmat with the leading terms of m.
  (begin scalar b;
  b:=for each x in dpmat_list m collect
    bas_make(bas_nr x,list(car bas_dpoly x));
  return dpmat_make(dpmat_rows m,dpmat_cols m,b,cali!=degrees,t);
  end) where cali!=degrees:=dpmat_coldegs m;

% -------- Symbolic mode file transfer --------------

symbolic procedure savemat!*(m,name);
% Save the dpmat m under the name .
  begin scalar nat,c;
  if not (stringp name or idp name) then typerr(name,"file name");
  if not eqcar(m,'dpmat) then typerr(m,"dpmat");
  nat:=!*nat; !*nat:=nil;
  write"Saving as ",name;
  out name$
  write"algebraic(setring "$

  % mathprint prints lists without terminator, but matrices with
  % terminator.

  mathprint ring_2a cali!=basering$ write")$"$
  write"algebraic(<>)$"$
  if (c:=dpmat_coldegs m) then
    << write"algebraic(degrees:="$
    mathprint moid_2a for each x in c collect cdr x$ write")$"$
    >>;
  write"end$"$ terpri()$
  shut name; terpri(); !*nat:=nat;
  end;

symbolic procedure initmat!* name;
% Initialize a dpmat from .
  if not (stringp name or idp name) then typerr(name,"file name")
  else begin scalar m,c; integer i;
     write"Initializing ",name; terpri();
     in name$ m:=reval 'basis; cali!=degrees:=nil;
     if eqcar(m,'list) then
        << m:=bas_from_a m; m:=dpmat_make(length m,0,m,nil,nil)>>
     else if eqcar(m,'mat) then
        << c:=moid_from_a reval 'degrees; i:=0;
           cali!=degrees:=for each x in c collect <>;
           m:=dpmat_from_a m;
        >>
     else typerr(m,"basis or matrix");
     dpmat_print m;
     return m;
     end;

% ---- Algebraic mode file transfer ---------

symbolic operator savemat;
symbolic procedure savemat(m,name);
  if !*mode='algebraic then savemat!*(dpmat_from_a m,name)
  else savemat!*(m,name);

symbolic operator initmat;
symbolic procedure initmat name;
  if !*mode='algebraic then dpmat_2a initmat!* name
  else initmat!* name;

% --------------- Arithmetics for dpmat's ----------------------

symbolic procedure dpmat!=dpsubst(a,b);
% Substitute in the dpoly a each e_i by b_i from the base list b.
   begin scalar v;
   for each x in b do
        v:=dp_sum(v,dp_prod(dp_comp(bas_nr x,a),bas_dpoly x));
   return v;
   end;

symbolic procedure dpmat_mult(a,b);
% Returns a * b.
  if not eqn(dpmat_cols a,dpmat_rows b) then
        rerror('dpmat,1," matrices don't match for MATMULT")
  else dpmat_make( dpmat_rows a, dpmat_cols b,
        for each x in dpmat_list a collect
                bas_make(bas_nr x,
                        dpmat!=dpsubst(bas_dpoly x,dpmat_list b)),
        cali!=degrees,nil)
        where cali!=degrees:=dpmat_coldegs b;

symbolic procedure dpmat_times_dpoly(f,m);
% Returns f * m for the dpoly f and the dpmat m.
   dpmat_make(dpmat_rows m,dpmat_cols m,
        for each x in dpmat_list m collect
            bas_make1(bas_nr x, dp_prod(f,bas_dpoly x),
                        dp_prod(f,bas_rep x)),
        cali!=degrees,nil) where cali!=degrees:=dpmat_coldegs m;

symbolic procedure dpmat_neg a;
% Returns - a.
   dpmat_make(
        dpmat_rows a,
        dpmat_cols a,
        for each x in dpmat_list a collect
            bas_make1(bas_nr x,dp_neg bas_dpoly x, dp_neg bas_rep x),
        cali!=degrees,dpmat_gbtag a)
        where cali!=degrees:=dpmat_coldegs a;

symbolic procedure dpmat_diff(a,b);
% Returns a - b.
  dpmat_sum(a,dpmat_neg b);

symbolic procedure dpmat_sum(a,b);
% Returns a + b.
  if not (eqn(dpmat_rows a,dpmat_rows b)
                and eqn(dpmat_cols a, dpmat_cols b)
                and equal(dpmat_coldegs a,dpmat_coldegs b)) then
        rerror('dpmat,2,"matrices don't match for MATSUM")
  else (begin scalar u,v,w;
        u:=dpmat_list a; v:=dpmat_list b;
        w:=for i:=1:dpmat_rows a collect
            (bas_make1(i,dp_sum(bas_dpoly x,bas_dpoly y),
                            dp_sum(bas_rep x,bas_rep y))
                        where y= bas_getelement(i,v),
                              x= bas_getelement(i,u));
        return dpmat_make(dpmat_rows a,dpmat_cols a,w,cali!=degrees,
                          nil);
        end) where cali!=degrees:=dpmat_coldegs a;

symbolic procedure dpmat_from_dpoly p;
  if null p then dpmat_make(0,0,nil,nil,t)
  else dpmat_make(1,0,list bas_make(1,p),nil,t);

symbolic procedure dpmat_unit(n,degs);
% Returns the unit dpmat of size n.
  dpmat_make(n,n, for i:=1:n collect bas_make(i,dp_from_ei i),degs,t);

symbolic procedure dpmat_unitideal!? m;
  (dpmat_cols m = 0) and null matop_pseudomod(dp_fi 1,m);

symbolic procedure dpmat_transpose m;
% Returns transposed m with consistent column degrees.
  if (dpmat_cols m = 0) then dpmat!=transpose ideal2mat!* m
  else dpmat!=transpose m;

symbolic procedure dpmat!=transpose m;
  (begin scalar b,p,q;
     cali!=degrees:=
        for each x in dpmat_rowdegrees m collect
                (car x).(mo_neg cdr x);
     for i:=1:dpmat_cols m do
       << p:=nil;
          for j:=1:dpmat_rows m do
            << q:=dpmat_element(j,i,m);
               if q then p:=dp_sum(p,dp_times_ei(j,q))
            >>;
          if p then b:=bas_make(i,p) . b;
       >>;
   return dpmat_make(dpmat_cols m,dpmat_rows m,reverse b,
                        cali!=degrees,nil);
   end) where cali!=degrees:=cali!=degrees;

symbolic procedure ideal2mat!* u;
% Returns u as column vector if dpmat_cols u = 0.
  if dpmat_cols u neq 0 then
            rerror('dpmat,4,"IDEAL2MAT only for ideal bases")
  else dpmat_make(dpmat_rows u,1,
                 for each x in dpmat_list u collect
                   bas_make(bas_nr x,dp_times_ei(1,bas_dpoly x)),
                nil,dpmat_gbtag u) where cali!=degrees:=nil;

symbolic procedure dpmat_renumber old;
% Renumber dpmat_list old.
% Returns (new . change) with new = change * old.
  if null dpmat_list old then (old . dpmat_unit(dpmat_rows old,nil))
  else (begin scalar i,u,v,w;
      cali!=degrees:=dpmat_rowdegrees old;
      i:=0; u:=dpmat_list old;
      while u do
        <>;
      return dpmat_make(i,dpmat_cols old,
                        reverse v,dpmat_coldegs old,dpmat_gbtag old) .
             dpmat_make(i,dpmat_rows old,reverse w,cali!=degrees,t);
      end) where cali!=degrees:=cali!=degrees;

symbolic procedure mathomogenize!*(m,var);
% Returns m with homogenized rows using the var. name var.
  dpmat_make(dpmat_rows m, dpmat_cols m,
        bas_homogenize(dpmat_list m,var), cali!=degrees,nil)
  where cali!=degrees:=dpmat_coldegs m;

symbolic operator mathomogenize;
symbolic procedure mathomogenize(m,v);
% Returns the homogenized matrix of m with respect to the variable v.
  if !*mode='algebraic then
        dpmat_2a mathomogenize!*(dpmat_from_a reval m,v)
  else matdehomogenize!*(m,v);

symbolic procedure matdehomogenize!*(m,var);
% Returns m with var. name var set equal to one.
  dpmat_make(dpmat_rows m, dpmat_cols m,
        bas_dehomogenize(dpmat_list m,var), cali!=degrees,nil)
  where cali!=degrees:=dpmat_coldegs m;

symbolic procedure dpmat_sieve(m,vars,gbtag);
% Apply bas_sieve to dpmat_list m. The gbtag slot allows to set the
% gbtag of the result.
  dpmat_make(length x,dpmat_cols m,x,cali!=degrees,gbtag)
        where x=bas_sieve(dpmat_list m,vars)
  where cali!=degrees:=dpmat_coldegs m;

symbolic procedure dpmat_neworder(m,gbtag);
% Apply bas_neworder to dpmat_list m with current cali!=degrees.
% The gbtag sets the gbtag part of the result.
   dpmat_make(dpmat_rows m,dpmat_cols m,
        bas_neworder dpmat_list m,cali!=degrees,gbtag);

symbolic procedure dpmat_zero!? m;
% Test whether m is a zero dpmat.
   bas_zero!? dpmat_list m;

symbolic procedure dpmat_project(m,k);
% Project the dpmat m onto its first k components.
  dpmat_make(dpmat_rows m,k,
        for each x in dpmat_list m collect
                bas_make(bas_nr x,dp_project(bas_dpoly x,k)),
        dpmat_coldegs m,nil);

% ---------- Interface to algebraic mode

symbolic procedure dpmat_2a m;
% Convert the dpmat m to a matrix (c>0) or a polynomial list (c=0) in
% algebraic (pseudo)prefix form.
  if dpmat_cols m=0 then bas_2a dpmat_list m
  else   'mat .
        if dpmat_rows m=0 then list for j:=1:dpmat_cols m collect 0
        else  for i:=1:dpmat_rows m collect
                for j:=1:dpmat_cols m collect
                    dp_2a dpmat_element(i,j,m);

symbolic procedure dpmat_from_a m;
% Convert an algebraic polynomial list or matrix expression into a
% dpmat with respect to the current setting of cali!=degrees.
  if eqcar(m,'mat) then
    begin integer i; scalar u,p; m:=cdr m;
    for each x in m do
      << i:=1; p:=nil;
         for each y in x do
           << p:=dp_sum(p,dp_times_ei(i,dp_from_a reval y)); i:=i+1 >>;
         u:=bas_make(0,p).u
      >>;
    return dpmat_make(length m,length car m,
                bas_renumber reversip u, cali!=degrees,nil);
    end
  else if eqcar(m,'list) then
    ((begin scalar x;  x:=bas_from_a reval m;
    return dpmat_make(length x,0,x,nil,nil)
    end) where cali!=degrees:=nil)
  else typerr(m,"polynomial list or matrix");

% ---- Substitution in dpmats --------------

symbolic procedure dpmat_sub(a,m);
% a=list of (var . alg. prefix form) to be substituted into the dpmat
% m.
   dpmat_from_a subeval1(a,dpmat_2a m)
  where cali!=degrees:=dpmat_coldegs m;

% ------------- Determinant ------------------------

symbolic procedure dpmat_det m;
% Returns the determinant of the dpmat m.
  if dpmat_rows m neq dpmat_cols m then rederr "non-square matrix"
  else dp_from_a prepf numr detq matsm dpmat_2a m;

endmodule; % dpmat

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/calimat.red0000644000175000017500000001416711526203062023533 0ustar  giovannigiovannimodule calimat;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment

                #######################
                #                     #
                #  MATRIX SUPPLEMENT  #
                #                     #
                #######################

Supplement to the REDUCE matrix package.
Matrices are transformed into nested lists of s.q.'s.

end comment;

% ------ The Jacobian matrix -------------

symbolic operator matjac;
symbolic procedure matjac(m,l);
% Returns the Jacobian matrix from the ideal m in prefix form
% (given as an algebraic mode list) with respect to the var. list l.
   if not eqcar(m,'list) then typerr(m,"ideal basis")
   else if not eqcar(l,'list) then typerr(l,"variable list")
   else 'mat . for each x in cdr l collect
        for each y in cdr m collect prepsq difff(numr simp reval y,x);

% ---------- Random linear forms -------------

symbolic operator random_linear_form;
symbolic procedure random_linear_form(vars,bound);
% Returns a random linear form in algebraic prefix form.
  if not eqcar(vars,'list) then typerr(vars,"variable list")
  else 'plus . for each x in cdr vars collect
        {'times,random(2*bound)-bound,x};

% ----- Singular locus -----------

symbolic operator singular_locus;
symbolic procedure singular_locus(m,c);
  if !*mode='algebraic then
        (if not numberp c then
        rederr"Syntax : singular_locus(polynomial list, codimension)"
        else dpmat_2a singular_locus!*(m,c))
  else singular_locus!*(m,c);

symbolic procedure singular_locus!*(m,c);
% m must be a complete intersection of codimension c given as a list
% of polynomials in prefix form. Returns the singular locus computing
% the corresponding jacobian.
  matsum!* {dpmat_from_a m, mat2list!* dpmat_from_a
        minors(matjac(m,makelist ring_names cali!=basering),c)};

% ------------- Minors --------------

symbolic operator minors;
symbolic procedure minors(m,k);
% Returns the matrix of k-minors of the matrix m.
  if not eqcar(m,'mat) then typerr(m,"matrix")
  else begin scalar r,c;
  m:=for each x in cdr m collect for each y in x collect simp y;
  r:=cali_choose(for i:=1:length m collect i,k);
  c:=cali_choose(for i:=1:length car m collect i,k);
  return 'mat . for each x in r collect for each y in c collect
        mk!*sq detq calimat!=submat(m,x,y);
  end;

symbolic operator ideal_of_minors;
symbolic procedure ideal_of_minors(m,k);
% The ideal of the k-minors of the matrix m.
  if !*mode='algebraic then dpmat_2a ideal_of_minors!*(m,k)
  else ideal_of_minors!*(m,k);

symbolic procedure ideal_of_minors!*(m,k);
  if not eqcar(m,'mat) then typerr(m,"matrix") else
  interreduce!* mat2list!* dpmat_from_a minors(m,k);

symbolic procedure calimat!=submat(m,x,y);
  for each a in x collect for each b in y collect nth(nth(m,a),b);

symbolic procedure calimat!=sum(a,b);
  for each x in pair(a,b) collect
  for each y in pair(car x,cdr x) collect addsq(car y,cdr y);

symbolic procedure calimat!=neg a;
  for each x in a collect for each y in x collect negsq y;

symbolic procedure calimat!=tp a;
  tp1 append(a,nil); % since tp1 is destructive.

symbolic procedure calimat!=zero!? a;
  begin scalar b; b:=t;
  for each x in a do for each y in x do b:=b and null car y;
  return b;
  end;

% -------------- Pfaffians ---------------

symbolic procedure calimat!=skewsymmetric!? m;
  calimat!=zero!? calimat!=sum(m,calimat!=tp m);

symbolic operator pfaffian;
symbolic procedure pfaffian m;
% The pfaffian of a skewsymmetric matrix m.
  if not eqcar(m,'mat) then typerr(m,"matrix") else
  begin scalar m1;
  m1:=for each x in cdr m collect for each y in x collect simp y;
  if not calimat!=skewsymmetric!? m1
    then typerr(m,"skewsymmetic matrix");
  return mk!*sq calimat!=pfaff m1;
  end;

symbolic procedure calimat!=pfaff m;
  if length m=1 then nil . 1
  else if length m=2 then cadar m
  else begin scalar a,b,p,c,d,ind,sgn;
      b:=for each x in cdr m collect cdr x;
      a:=cdar m; ind:=for i:=1:length a collect i;
      p:=nil . 1;
      for i:=1:length a do
      << c:=delete(i,ind); d:=calimat!=pfaff calimat!=submat(b,c,c);
         if sgn then d:=negsq d; sgn:=not sgn;
         p:=addsq(p,multsq(nth(a,i),d));
      >>;
      return p;
      end;

symbolic operator ideal_of_pfaffians;
symbolic procedure ideal_of_pfaffians(m,k);
% The ideal of the 2k-pfaffians of the skewsymmetric matrix m.
  if !*mode='algebraic then dpmat_2a ideal_of_pfaffians!*(m,k)
  else ideal_of_pfaffians!*(m,k);

symbolic procedure ideal_of_pfaffians!*(m,k);
% The same, but for a dpmat m.
  if not eqcar(m,'mat) then typerr(m,"matrix") else
  begin scalar m1,u;
  m1:=for each x in cdr m collect for each y in x collect simp y;
  if not calimat!=skewsymmetric!? m1
    then typerr(m,"skewsymmetic matrix");
  u:=cali_choose(for i:=1:length m1 collect i,2*k);
  return interreduce!* dpmat_from_a makelist
        for each x in u collect
                prepsq calimat!=pfaff calimat!=submat(m1,x,x);
  end;

endmodule; % calimat

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/cali.hlp0000644000175000017500000000376011526203062023037 0ustar  giovannigiovanni\chapter{CALI: Computational Commutative Algebra}
\label{CALI}
\typeout{{CALI: Computational Commutative Algebra}}

{\footnotesize
\begin{center}
Hans-Gert Gr\"abe \\
Institut f\"ur Informatik, Universit\"at Leipzig\\ 
Augustusplatz 10 -- 11\\
04109 Leipzig, Germany \\[0.05in]
e--mail: graebe@informatik.uni-leipzig.de
\end{center}
}

\ttindex{CALI}

This package contains algorithms for computations in commutative algebra
closely related to the Gr\"obner algorithm for ideals and modules.  Its
heart is a new implementation of the Gr\"obner algorithm that also allows
for the computation of syzygies.  This implementation is also applicable to
submodules of free modules with generators represented as rows of a matrix.
As main topics CALI contains facilities for
\begin{itemize}
\item defining rings, ideals and modules,

\item computing Gr\"obner bases and local standard bases,

\item computing syzygies, resolutions and (graded) Betti numbers,

\item computing (now also weighted) Hilbert series, multiplicities,
independent sets, and dimensions,

\item computing normal forms and representations,

\item computing sums, products, intersections, quotients, stable
quotients, elimination ideals etc.,

\item primality tests, computation of radicals, unmixed radicals,
equidimensional parts, primary decompositions etc. of ideals and
modules,

\item advanced applications of Gr\"obner bases (blowup, associated graded
ring, analytic spread, symmetric algebra, monomial curves etc.),

\item applications of linear algebra techniques to zero dimensional
        ideals, as {\em e.g.\ }the FGLM change of term orders, border bases
        and affine and projective ideals of sets of points,

\item splitting polynomial systems of equations mixing factorisation and
the Gr\"obner algorithm, triangular systems, and different versions of the
extended Gr\"obner factoriser. 

\end{itemize}

There is more extended documentation on this package elsewhere, which
includes facilities for tracing and switches to control its behaviour.

mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/triang.red0000644000175000017500000002513011526203062023375 0ustar  giovannigiovannimodule triang;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

                ##########################################
                ##                                      ##
                ##    Solving zerodimensional systems   ##
                ##          Triangular systems          ##
                ##                                      ##
                ##########################################


Zerosolve returns lists of dpmats in prefix form, that consist of
triangular systems in the sense of Lazard, provided the input is
radical. For the corresponding definitions and concepts see

[Lazard] D. Lazard: Solving zero dimensional algebraic systems.
                J. Symb. Comp. 13 (1992), 117 - 131.
and

[EFGB] H.-G. Graebe: Triangular systems and factorized Groebner
                bases. Report Nr. 7 (1995), Inst. f. Informatik,
                        Univ. Leipzig.


The triangularization of zerodim. ideal bases is done by Moeller's
approach, see

[Moeller] H.-M. Moeller : On decomposing systems of polynomial
        equations with finitely many solutions.
        J. AAECC 4 (1993), 217 - 230.

We present three implementations :
        -- the pure lex gb (zerosolve)
        -- the "slow turn to pure lex" (zerosolve1)
and
        -- the mix with [FGLM] (zerosolve2)

END COMMENT;

symbolic procedure triang!=trsort(a,b);
  mo_dlexcomp(dp_lmon a,dp_lmon b);

symbolic procedure triang!=makedpmat x;
  makelist for each p in x collect dp_2a p;

% =================================================================
% The pure lex approach.

symbolic operator zerosolve;
symbolic procedure zerosolve m;
  if !*mode='algebraic then makelist zerosolve!* dpmat_from_a m
  else zerosolve!* m;

symbolic procedure zerosolve!* m;
% Solve a zerodimensional dpmat ideal m, first groebfactor it and then
% triangularize it. Returns a list of dpmats in prefix form.
 if (dpmat_cols m>0) or (dim!* m>0) then
        rederr"ZEROSOLVE only for zerodimensional ideals"
 else if not !*noetherian or ring_degrees cali!=basering then
        rederr"ZEROSOLVE only for pure lex. term orders"
 else for each x in groebfactor!*(m,nil) join triang_triang car x;

symbolic procedure triang_triang m;
% m must be a zerodim. ideal gbasis (recommended to be radical)
% wrt. a pure lex term order.
% Returns a list l of dpmats in triangular form.
 if (dpmat_cols m>0) or (dim!* m>0) then
        rederr"Triangularization only for zerodimensional ideals"
 else if not !*noetherian or ring_degrees cali!=basering then
        rederr"Triangularization only for pure lex. term orders"
 else for each x in triang!=triang(m,ring_names cali!=basering) collect
                triang!=makedpmat x;

symbolic procedure triang!=triang(A,vars);
% triang!=triang(A,vars)={f1.x for x in triang!=triang(B,cdr vars)}
%                       \union triang!=triang(A:,vars)
% where A={f1,...,fr}, B={f2~,...fr~}, see [Moeller].
% Returns a list of polynomial lists.
  if dpmat_unitideal!? A then nil
  else begin scalar x,f1,m1,m2,B;
    x:=car vars;
    m1:=sort(for each x in dpmat_list A collect bas_dpoly x,
                function triang!=trsort);
    if length m1 = length vars then return {m1};
    f1:=car m1;
    m2:=for each y in cdr m1 collect bas_make(1,dp_xlt(y,x));
    B:=interreduce!* dpmat_make(length m2,0,m2,nil,nil);
    return append(
    for each u in triang!=triang(B,cdr vars) collect (f1 . u),
                triang!=triang(matstabquot!*(A,B),vars));
    end;

% =================================================================
% Triangularization wrt. an arbitrary term order

symbolic operator zerosolve1;
symbolic procedure zerosolve1 m;
  if !*mode='algebraic then makelist zerosolve1!* dpmat_from_a m
  else zerosolve1!* m;

symbolic procedure zerosolve1!* m;
   for each x in groebfactor!*(m,nil) join triang_triang1 car x;

symbolic procedure triang_triang1 m;
% m must be a zerodim. ideal gbasis (recommended to be radical)
% Returns a list l of dpmats in triangular form.
 if (dpmat_cols m>0) or (dim!* m>0) then
        rederr"Triangularization only for zerodimensional ideals"
 else if not !*noetherian then
        rederr"Triangularization only for noetherian term orders"
 else for each x in triang!=triang1(m,ring_names cali!=basering) collect
                triang!=makedpmat x;

symbolic procedure triang!=triang1(A,vars);
% triang!=triang(A,vars)={f1.x for x in triang!=triang1(B,cdr vars)}
%                       \union triang!=triang1(A:,vars)
% where A={f1,...,fr}, B={f2~,...fr~}, see [Moeller].
% Returns a list of polynomial lists.
  if dpmat_unitideal!? A then nil
  else if length vars = 1 then {{bas_dpoly first dpmat_list A}}
  else (begin scalar u,x,f1,m1,m2,B,vars1,res;
    x:=car vars; vars1:=ring_names cali!=basering;
    setring!* ring_define(vars1,eliminationorder!*(vars1,{x}),
                        'revlex,ring_ecart cali!=basering);
    a:=groebfactor!*(dpmat_neworder(a,nil),nil);
    % Constraints in dimension zero may be skipped :
    a:=for each x in a collect car x;
    for each u in a do
    << m1:=sort(for each x in dpmat_list u collect bas_dpoly x,
                function triang!=trsort);
       f1:=car m1;
       m2:=for each y in cdr m1 collect bas_make(1,dp_xlt(y,x));
       B:=interreduce!* dpmat_make(length m2,0,m2,nil,nil);
       res:=nconc(append(
       for each v in triang!=triang1(B,cdr vars) collect (f1 . v),
                triang!=triang1a(matstabquot!*(u,B),vars)),res);
    >>;
    return res;
    end) where cali!=basering=cali!=basering;

symbolic procedure triang!=triang1a(A,vars);
% triang!=triang(A,vars)={f1.x for x in triang!=triang1(B,cdr vars)}
%                       \union triang!=triang1(A:,vars)
% where A is already a gr basis wrt. the elimination order.
% Returns a list of polynomial lists.
  if dpmat_unitideal!? A then nil
  else if length vars = 1 then {{bas_dpoly first dpmat_list A}}
  else begin scalar u,x,f1,m1,m2,B;
    x:=car vars;
    m1:=sort(for each x in dpmat_list a collect bas_dpoly x,
                function triang!=trsort);
    f1:=car m1;
    m2:=for each y in cdr m1 collect bas_make(1,dp_xlt(y,x));
    B:=interreduce!* dpmat_make(length m2,0,m2,nil,nil);
    return append(
       for each u in triang!=triang1(B,cdr vars) collect (f1 . u),
                triang!=triang1a(matstabquot!*(A,B),vars));
    end;

% =================================================================
% Triangularization wrt. an arbitrary term order and FGLM approach.

symbolic operator zerosolve2;
symbolic procedure zerosolve2 m;
  if !*mode='algebraic then makelist zerosolve2!* dpmat_from_a m
  else zerosolve2!* m;

symbolic procedure zerosolve2!* m;
% Solve a zerodimensional dpmat ideal m, first groebfactoring it and
% secondly triangularizing it.
   for each x in groebfactor!*(m,nil) join triang_triang2 car x;

symbolic procedure triang_triang2 m;
% m must be a zerodim. ideal gbasis (recommended to be radical)
% Returns a list l of dpmats in triangular form.
 if (dpmat_cols m>0) or (dim!* m>0) then
        rederr"Triangularization only for zerodimensional ideals"
 else if not !*noetherian then
        rederr"Triangularization only for noetherian term orders"
 else for each x in triang!=triang2(m,ring_names cali!=basering)
        collect triang!=makedpmat x;

symbolic procedure triang!=triang2(A,vars);
% triang!=triang(A,vars)={f1.x for x in triang!=triang2(B,cdr vars)}
%                       \union triang!=triang2(A:,vars)
% where A={f1,...,fr}, B={f2~,...fr~}, see [Moeller].
% Returns a list of polynomial lists.
  if dpmat_unitideal!? A then nil
  else if length vars = 1 then {{bas_dpoly first dpmat_list A}}
  else (begin scalar u,x,f1,m1,m2,B,vars1,vars2,extravars,res,c1;
    x:=car vars; vars1:=ring_names cali!=basering;
    extravars:=dpmat_from_a('list . (vars2:=setdiff(vars1,vars)));
    % We need this to make A truely zerodimensional.
    c1:=ring_define(vars1,eliminationorder!*(vars1,{x}),
                        'revlex,ring_ecart cali!=basering);
    a:=matsum!* {extravars,a};
    u:=change_termorder!*(a,c1);
    a:=groebfactor!*(dpmat_sieve(u,vars2,nil),nil);
    % Constraints in dimension zero may be skipped :
    a:=for each x in a collect car x;
    for each u in a do
    << m1:=sort(for each x in dpmat_list u collect bas_dpoly x,
                function triang!=trsort);
       f1:=car m1;
       m2:=for each y in cdr m1 collect bas_make(1,dp_xlt(y,x));
       B:=interreduce!* dpmat_make(length m2,0,m2,nil,nil);
       res:=nconc(append(
       for each v in triang!=triang2(B,cdr vars) collect (f1 . v),
                triang!=triang2a(matstabquot!*(u,B),vars)),res);
    >>;
    return res;
    end) where cali!=basering=cali!=basering;

symbolic procedure triang!=triang2a(A,vars);
% triang!=triang(A,vars)={f1.x for x in triang!=triang2(B,cdr vars)}
%                       \union triang!=triang2(A:,vars)
% where A is already a gr basis wrt. the elimination order.
% Returns a list of polynomial lists.
  if dpmat_unitideal!? A then nil
  else if length vars = 1 then {{bas_dpoly first dpmat_list A}}
  else begin scalar u,x,f1,m1,m2,B;
    x:=car vars;
    m1:=sort(for each x in dpmat_list a collect bas_dpoly x,
                function triang!=trsort);
    f1:=car m1;
    m2:=for each y in cdr m1 collect bas_make(1,dp_xlt(y,x));
    B:=interreduce!* dpmat_make(length m2,0,m2,nil,nil);
    return append(
       for each u in triang!=triang2(B,cdr vars) collect (f1 . u),
                triang!=triang2a(matstabquot!*(A,B),vars));
    end;

endmodule; % triang

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/quot.red0000644000175000017500000002303011526203062023076 0ustar  giovannigiovannimodule quot;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

                #################
                #               #
                #   QUOTIENTS   #
                #               #
                #################


This module contains algorithms for different kinds of quotients of
ideals and modules.

END COMMENT;

% -------- Quotient of a module by a polynomial -----------
% Returns m : (f) for a polynomial f.

symbolic operator matquot;
symbolic procedure matquot(m,f);
  if !*mode='algebraic then
     if eqcar(f,'list) or eqcar(f,'mat) then
                rederr("Syntax : matquot(dpmat,dpoly)")
     else dpmat_2a matquot!*(dpmat_from_a reval m,dp_from_a reval f)
  else matquot!*(m,f);

symbolic procedure matquot!*(m,f);
  if dp_unit!? f then m
  else if dpmat_cols m=0 then mat2list!* quot!=quot(ideal2mat!* m,f)
  else quot!=quot(m,f);

symbolic procedure quot!=quot(m,f);
% Note that, if a is a gbasis, then also b.
  begin scalar a,b;
  a:=matintersect!* {m,
    dpmat_times_dpoly(f,dpmat_unit(dpmat_cols m,dpmat_coldegs m))};
  b:=for each x in dpmat_list a collect
    bas_make(bas_nr x,car dp_pseudodivmod(bas_dpoly x,f));
  return dpmat_make(dpmat_rows a,dpmat_cols a,b,
                dpmat_coldegs m,dpmat_gbtag a);
  end;

% -------- Quotient of a module by an ideal -----------
% Returns m:n as a module.

symbolic operator idealquotient;
symbolic procedure idealquotient(m,n);
  if !*mode='algebraic then
        dpmat_2a idealquotient2!*(dpmat_from_a reval m,
                            dpmat_from_a reval n)
  else idealquotient2!*(m,n);

% -------- Quotient of a module by another module  -----------
% Returns m:n as an ideal in S. m and n must be submodules of a common
% free module.

symbolic operator modulequotient;
symbolic procedure modulequotient(m,n);
  if !*mode='algebraic then
        dpmat_2a modulequotient2!*(dpmat_from_a reval m,
                            dpmat_from_a reval n)
  else modulequotient2!*(m,n);

% ---- The annihilator of a module, i.e. Ann coker M := M : F ---

symbolic operator annihilator;
symbolic procedure annihilator m;
  if !*mode='algebraic then
        dpmat_2a annihilator2!* dpmat_from_a reval m
  else annihilator2!* m;

% ---- Quotients as M:N = \intersect { M:f | f \in N } ------

symbolic procedure idealquotient2!*(m,n);
  if dpmat_cols n>0 then rederr"Syntax : idealquotient(dpmat,ideal)"
  else if dpmat_cols m=0 then modulequotient2!*(m,n)
  else if dpmat_cols m=1 then
        ideal2mat!* modulequotient2!*(m,ideal2mat!* n)
  else matintersect!* for each x in dpmat_list n collect
        quot!=quot(m,bas_dpoly x);

symbolic procedure modulequotient2!*(m,n);
  (begin scalar c;
  if not((c:=dpmat_cols m)=dpmat_cols n) then rederr
    "MODULEQUOTIENT only for submodules of a common free module";
  if not equal(dpmat_coldegs m,dpmat_coldegs n) then
          rederr"matrices don't match for MODULEQUOTIENT";
  if (c=0) then << m:=ideal2mat!* m; n:=ideal2mat!* n >>;
  cali!=degrees:=dpmat_coldegs m;
  n:=for each x in dpmat_list n collect matop_pseudomod(bas_dpoly x,m);
  n:=for each x in n join if x then {x};
  return if null n then dpmat_from_dpoly dp_fi 1
  else matintersect!* for each x in n collect quot!=mquot(m,x);
  end) where cali!=degrees:=cali!=degrees;

symbolic procedure quot!=mquot(m,f);
  begin scalar a,b;
  a:=matintersect!*
    {m,dpmat_make(1,dpmat_cols m,list bas_make(1,f),dpmat_coldegs m,t)};
  b:=for each x in dpmat_list a collect
    bas_make(bas_nr x,car dp_pseudodivmod(bas_dpoly x,f));
  return dpmat_make(dpmat_rows a,0,b,nil,nil);
  end;

symbolic procedure annihilator2!* m;
  if dpmat_cols m=0 then m
  else if dpmat_cols m=1 then mat2list!* m
  else modulequotient2!*(m,dpmat_unit(dpmat_cols m,dpmat_coldegs m));

% -------- Quotients by the general element method --------

symbolic procedure idealquotient1!*(m,n);
  if dpmat_cols n>0 then rederr "second parameter must be an ideal"
  else if dpmat_cols m=0 then modulequotient1!*(m,n)
  else if dpmat_cols m=1 then
        ideal2mat!* modulequotient1!*(m,ideal2mat!* n)
  else (begin scalar u1,u2,f,v,r,m1;
  v:=list gensym(); r:=cali!=basering;
  setring!* ring_sum(r,ring_define(v,degreeorder!* v,'revlex,'(1)));
  cali!=degrees:=mo_degneworder dpmat_coldegs m;
  n:=for each x in dpmat_list n collect dp_neworder x;
  u1:=u2:=dp_from_a car v; f:=car n;
  for each x in n do
        << f:=dp_sum(f,dp_prod(u1,x)); u1:=dp_prod(u1,u2) >>;
  m1:=dpmat_sieve(gbasis!* quot!=quot(dpmat_neworder(m,nil),f),v,t);
  setring!* r; cali!=degrees:=dpmat_coldegs m;
  return dpmat_neworder(m1,t);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure modulequotient1!*(m,n);
  (begin scalar c,u1,u2,f,v,r,m1;
  if not((c:=dpmat_cols m)=dpmat_cols n) then rederr
    "MODULEQUOTIENT only for submodules of a common free module";
  if not equal(dpmat_coldegs m,dpmat_coldegs n) then
          rederr"matrices don't match for MODULEQUOTIENT";
  if (c=0) then << m:=ideal2mat!* m; n:=ideal2mat!* n >>;
  cali!=degrees:=dpmat_coldegs m;
  n:=for each x in dpmat_list n collect matop_pseudomod(bas_dpoly x,m);
  n:=for each x in n join if x then {x};
  if null n then return dpmat_from_dpoly dp_fi 1;
  v:=list gensym(); r:=cali!=basering;
  setring!* ring_sum(r,ring_define(v,degreeorder!* v,'revlex,'(1)));
  cali!=degrees:=mo_degneworder cali!=degrees;
  u1:=u2:=dp_from_a car v; f:=dp_neworder car n;
  for each x in n do
     << f:=dp_sum(f,dp_prod(u1,dp_neworder x));
        u1:=dp_prod(u1,u2)
     >>;
  m1:=dpmat_sieve(gbasis!* quot!=mquot(dpmat_neworder(m,nil),f),v,t);
  setring!* r; cali!=degrees:=dpmat_coldegs m;
  return dpmat_neworder(m1,t);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure annihilator1!* m;
  if dpmat_cols m=0 then m
  else if dpmat_cols m=1 then m
  else modulequotient1!*(m,dpmat_unit(dpmat_cols m,dpmat_coldegs m));

% --------------- Stable quotients ------------------------

symbolic operator matqquot;
symbolic procedure matqquot(m,f);
% Stable quotient of dpmat m with respect to a polynomial f, i.e.
% m :  = { v \in F | \exists n : f^n*v \in m }
  if !*mode='algebraic then
     if eqcar(f,'list) or eqcar(f,'mat) then
                rederr("Syntax : matquot(dpmat,dpoly)")
     else dpmat_2a matqquot!*(dpmat_from_a reval m,dp_from_a reval f)
  else matqquot!*(m,f);

symbolic procedure matqquot!*(m,f);
  if dp_unit!? f then m
  else if dpmat_cols m=0 then
        mat2list!* quot!=stabquot(ideal2mat!* m,{f})
  else quot!=stabquot(m,{f});

symbolic operator matstabquot;
symbolic procedure matstabquot(m,f);
% Stable quotient of dpmat m with respect to an ideal f.
  if !*mode='algebraic then dpmat_2a
        matstabquot!*(dpmat_from_a reval m,dpmat_from_a reval f)
  else matstabquot!*(m,f);

symbolic procedure matstabquot!*(m,f);
  if dpmat_cols f > 0 then rederr "stable quotient only by ideals"
  else begin scalar c;
    if (c:=dpmat_cols m)=0 then
        << f:=for each x in dpmat_list f collect
                    matop_pseudomod(bas_dpoly x,m);
           f:=for each x in f join if x then {x}
        >>
    else f:=for each x in dpmat_list f collect bas_dpoly x;
    if null f then return
        if c=0 then dpmat_from_dpoly dp_fi 1
        else dpmat_unit(c,dpmat_coldegs m);
    if dp_unit!? car f then return m;
    if c=0 then return mat2list!* quot!=stabquot(ideal2mat!* m,f)
    else return quot!=stabquot(m,f);
    end;

symbolic procedure quot!=stabquot(m,f);
% m must be a module.
  if dpmat_cols m=0 then rederr"quot_stabquot only for cols>0"
  else (begin scalar m1,p,p1,p2,v,v1,v2,c;
    v1:=gensym(); v2:=gensym(); v:={v1,v2};
    setring!* ring_sum(c:=cali!=basering,
        ring_define(v,degreeorder!* v,'lex,'(1 1)));
    cali!=degrees:=mo_degneworder dpmat_coldegs m;
    p1:=p2:=dp_from_a v1;
    f:=for each x in f collect dp_neworder x;
    p:=car f;
    for each x in cdr f do
    << p:=dp_sum(dp_prod(p1,x),p); p1:=dp_prod(p1,p2) >>;
    p:=dp_diff(dp_fi 1,dp_prod(dp_from_a v2,p));
        % p = 1 - v2 * \sum{f_i * v1^i}
    m1:=matsum!* {dpmat_neworder(m,nil),
        dpmat_times_dpoly(p,
                dpmat_unit(dpmat_cols m,cali!=degrees))};
    m1:=dpmat_sieve(gbasis!* m1,v,t);
    setring!* c; cali!=degrees:=dpmat_coldegs m;
    return dpmat_neworder(m1,t);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

endmodule; % quot

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/moid.red0000644000175000017500000002015311526203062023041 0ustar  giovannigiovannimodule moid;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

               ###########################
               ##                       ##
               ##     MONOMIAL IDEALS   ##
               ##                       ##
               ###########################

This module supports computations with leading term ideals. Moideal
monomials are assumed to be without module component, since a module
moideal decomposes into the direct sum of ideal moideals.

Lit.:
[BS] Bayer, Stillman : J. Symb. Comp. 14 (1992), 31 - 50.

This module contains :

        - A moideal prime decomposition along [BS]

        - An algorithm to find all strongly independent sets using
                moideal primes (also for modules),

        - An algorithm to compute the dimension (dim M := dim in(M))
                based on strongly independent sets.

        - An easy dimension computation, correct for puredimensional
                ideals and modules.

Monomial ideals have the following informal syntax :

         ::= list of monomials

To manage module moideals they are stored as assoc. list of

        ( . )

Moideals are kept ordered with respect to the descending lexicographic
order, see [BS].

END COMMENT;

% ------------- monomial ideal constructors --------------

symbolic procedure moid_from_bas bas;
% Returns the list of leading monomials of the base list bas
% not removing module components.
   for each x in bas_zerodelete bas collect dp_lmon bas_dpoly x;

symbolic procedure moid_from_dpmat m;
% Returns the assoc. list of moideals of the columns of the dpmat m.
  (if dpmat_cols m = 0 then list (0 . u)
  else for i:=1:dpmat_cols m collect
     i . for each x in u join if mo_comp(x)=i then {mo_deletecomp x})
  where u=moid_from_bas dpmat_list m;

symbolic procedure moid_2a m;
% Convert the moideal m to algebraic mode.
  'list . for each x in m collect dp_2a list dp_term(bc_fi 1,x);

symbolic procedure moid_from_a m;
% Convert a moideal from algebraic mode.
  if not eqcar(m,'list) then typerr(m,"moideal")
  else for each x in cdr m collect dp_lmon dp_from_a x;

symbolic procedure moid_print m; mathprint moid_2a m;

% ------- moideal arithmetics ------------------------

symbolic procedure moid_sum(a,b);
% (Reduced) sum of two (v)moideals.
  moid_red append(a,b);

symbolic procedure moid_intersect(a,b);
% Intersection of two (pure !) moideals.
  begin scalar c;
  while b do
    << c:=nconc(for each x in a collect mo_lcm(x,car b),c);
       b:=cdr b
    >>;
  return moid_red c
  end;

symbolic procedure moid_sort m;
% Sorting by descending (pure) lexicographic order, first by mo_comp.
   sort(m,function mo_dlexcomp);

symbolic procedure moid_red m;
% Returns a minimal generating set of the (v)moideal m.
  moid!=red moid_sort m;

symbolic procedure moid!=red m;
  begin scalar v;
  while m do
    << if not moid_member(car m,cdr m) then v:=car m . v;
       m:=cdr m;
    >>;
  return reversip v;
  end;

symbolic procedure moid_member(mo,m);
% true <=> c \in m vdivides mo.
  if null m then nil
  else mo_vdivides!?(car m,mo) or moid_member(mo,cdr m);

symbolic procedure moid_radical u;
% Returns the radical of the (pure) moideal u.
  moid_red for each x in u collect mo_radical x;

symbolic procedure moid_quot(m,x);
% The quotient of the moideal m by the monomial x.
  moid_red for each u in m collect mo_diff(u,mo_gcd(u,x));

% --------------- moideal prime decomposition --------------
% Returns the minimal primes of the moideal m as a list of variable
% lists.

symbolic procedure moid_primes m;
  begin scalar c,m1,m2;
    m:=listminimize(for each x in m collect mo_support x,
                function subsetp);
    for each x in m do
        if length x=1 then m1:=car x . m1
        else m2:=x . m2;
    return for each x in moid!=primes(m2,ring_names cali!=basering)
        collect append(m1,x);
  end;

symbolic procedure moid!=primes(m,vars);
  if null m then list nil
  else begin scalar b; b:=t;
    for each x in m do b:=b and intersection(x,vars);
    if not b then return nil;
    return listminimize(
        for each x in intersection(car m,vars) join
        for each y in moid!=primes(moid!=sps(x,cdr m),
              vars:=delete(x,vars)) collect x . y,
        function subsetp);
  end;

symbolic procedure moid!=sps(x,m);
  for each y in m join if not memq(x,y) then {y};


% ------------ (Strongly) independent sets -----------------

symbolic procedure moid_max l;
  if null l then nil
  else car sort(l,function (lambda(x,y);length x >= length y));


symbolic procedure indepvarsets!* m;
% Returns the sets of (strongly) independent variables for the
% dpmat m. m must be a Groebner basis.
  begin scalar u,n;
    u:=listminimize(
        for each x in moid_from_dpmat m join moid_primes cdr x,
        function subsetp);
    n:=ring_names cali!=basering;
    return for each x in u collect setdiff(n,x);
  end;

% ---------- Dimension and codimension ------------

symbolic procedure moid_goodindepvarset m;
% Returns the lexicographically last maximal independent set of the
% dpmat m.
  begin scalar l,n,l1;
    l:=sort(indepvarsets!* m,
                function (lambda(x,y);length x >= length y));
    if null l then return nil;
    n:=length first l;
    l:=for each x in l join if length x = n then {x};
    for each x in reverse ring_names cali!=basering do
        if length l>1 then
        << l1:=for each y in l join if member(x,y) then {y};
           if l1 then l:=l1;
        >>;
    return first l;
    end;

symbolic procedure dim!* m;
% The dpmat m must be a Groebner basis. Computes the dimension of
% Coker m as the greatest size of a strongly independent set.
  if not eqcar(m,'dpmat) then typerr(m,"DPMAT")
  else length moid_max indepvarsets!* m;

symbolic procedure codim!* m;
  length ring_names cali!=basering - dim!* m;

% ---- An easy independent set procedure -------------

symbolic operator easyindepset;
symbolic procedure easyindepset m;
  if !*mode='algebraic then
        makelist easyindepset!* dpmat_from_a reval m
  else easyindepset!* m;

symbolic procedure easyindepset!* m;
% Returns a maximal with respect to inclusion independent set for the
% moideal m.
  begin scalar b,c,d;
    m:=for each x in m collect mo_support x;
    b:=c:=ring_names cali!=basering;
    for each x in b do if moid!=ept(d:=delete(x,c),m) then c:=d;
    return setdiff(ring_names cali!=basering,c);
  end;

symbolic procedure moid!=ept(l,m);
  if null m then t
  else intersection(l,car m) and moid!=ept(l,cdr m);

symbolic operator easydim;
symbolic procedure easydim m;
  if !*mode='algebraic then easydim!* dpmat_from_a reval m
  else easydim!* m;

symbolic procedure easydim!* m;
% Returns a lower bound for the dimension. The bound is true for
% unmixed ideals (e.g. primes). m must be a gbasis.
  if not eqcar(m,'dpmat) then typerr(m,"DPMAT")
  else listexpand(function max2,
        for each x in moid_from_dpmat m collect
            length easyindepset!* cdr x);

endmodule; % moid

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/matop.red0000644000175000017500000003614111526203062023235 0ustar  giovannigiovannimodule matop;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

              #############################
              ####                     ####
              ####  MATRIX OPERATIONS  ####
              ####                     ####
              #############################


This module contains operations on dpmats, that correspond to module
operations on the corresponding images resp. cokernels.

END COMMENT;

symbolic procedure matop!=testdpmatlist l;
% Test l to be a list of dpmats embedded into a common free module.
  if null l then rederr"Empty DPMAT list"
  else begin scalar c,d;
    for each x in l do
        if not eqcar(x,'dpmat) then typerr(x,"DPMAT");
    c:=dpmat_cols car l; d:=dpmat_coldegs car l;
    for each x in cdr l do
      if not (eqn(c,dpmat_cols x) and equal(d,dpmat_coldegs x)) then
                rederr"Matrices don't match in the DPMAT list";
  end;

symbolic procedure matappend!* l;
% Appends rows of the dpmats in the dpmat list l.
  (begin scalar u,r;
      matop!=testdpmatlist l;
      cali!=degrees:=dpmat_coldegs car l;
      u:=dpmat_list car l; r:=dpmat_rows car l;
      for each y in cdr l do
        << u:=append(u, for each x in dpmat_list y collect
                        bas_newnumber(bas_nr x + r,x));
           r:=r + dpmat_rows y;
        >>;
      return dpmat_make(r,dpmat_cols car l,u,cali!=degrees,nil)
   end) where cali!=degrees:=cali!=degrees;

put('matappend,'psopfn,'matop!=matappend);
symbolic procedure matop!=matappend l;
% Append the dpmats in the list l.
  dpmat_2a matappend!* for each x in l collect dpmat_from_a reval x;

symbolic procedure mat2list!* m;
% Returns the ideal of all elements of m.
  if dpmat_cols m = 0 then m
  else (begin scalar x;
    x:=bas_renumber bas_zerodelete
        for i:=1:dpmat_rows m join
        for j:=1:dpmat_cols m collect
                bas_make(0,dpmat_element(i,j,m));
    return dpmat_make(length x,0,x,nil,
                if dpmat_cols m=1 then dpmat_gbtag m else nil)
    end) where cali!=degrees:=nil;

symbolic procedure matsum!* l;
% Returns the module sum of the dpmat list l.
  interreduce!* matappend!* l;

put('matsum,'psopfn,'matop!=matsum);
put('idealsum,'psopfn,'matop!=matsum);
symbolic procedure matop!=matsum l;
% Returns the sum of the ideals/modules in the list l.
  dpmat_2a matsum!* for each x in l collect dpmat_from_a reval x;

symbolic procedure matop!=idealprod2(a,b);
  if (dpmat_cols a > 0) or (dpmat_cols b > 0 ) then
                rederr"IDEALPROD only for ideals"
  else (begin scalar x;
    x:=bas_renumber
        for each a1 in dpmat_list a join
        for each b1 in dpmat_list b collect
            bas_make(0,dp_prod(bas_dpoly a1,bas_dpoly b1));
    return interreduce!* dpmat_make(length x,0,x,nil,nil)
    end) where cali!=degrees:=nil;

symbolic procedure idealprod!* l;
% Returns the product of the ideals in the dpmat list l.
 if null l then rederr"empty list in IDEALPROD"
 else if length l=1 then car l
 else begin scalar u;
    u:=car l;
    for each x in cdr l do u:=matop!=idealprod2(u,x);
    return u;
    end;

put('idealprod,'psopfn,'matop!=idealprod);
symbolic procedure matop!=idealprod l;
% Returns the product of the ideals in the list l.
  dpmat_2a idealprod!* for each x in l collect dpmat_from_a reval x;

symbolic procedure idealpower!*(a,n);
  if (dpmat_cols a > 0) or (not fixp n) or (n < 0) then
        rederr" Syntax : idealpower(ideal,integer)"
  else if (n=0) then dpmat_from_dpoly dp_fi 1
  else begin scalar w; w:=a;
  for i:=2:n do w:=matop!=idealprod2(w,a);
  return w;
  end;

symbolic operator idealpower;
symbolic procedure idealpower(m,l);
  if !*mode='algebraic then
        dpmat_2a idealpower!*(dpmat_from_a reval m,l)
  else idealpower!*(m,l);

symbolic procedure matop!=shiftdegs(d,n);
% Shift column degrees d n places.
   for each x in d collect ((car x + n) . cdr x);

symbolic procedure directsum!* l;
% Returns the direct sum of the modules in the dpmat list l.
  if null l then rederr"Empty DPMAT list"
  else (begin scalar r,c,u;
    for each x in l do
        if not eqcar(x,'dpmat) then typerr(x,"DPMAT")
        else if dpmat_cols x=0 then
                rederr"DIRECTSUM only for modules";
    c:=r:=0; % Actual column resp. row index.
    cali!=degrees:=nil;
    for each x in l do
       << cali!=degrees:=append(cali!=degrees,
                        matop!=shiftdegs(dpmat_coldegs x,c));
          u:=append(u, for each y in dpmat_list x collect
                bas_make(bas_nr y + r,dp_times_ei(c,bas_dpoly y)));
          r:=r + dpmat_rows x;
          c:=c + dpmat_cols x;
        >>;
    return dpmat_make(r,c,u,cali!=degrees,nil)
    end) where cali!=degrees:=cali!=degrees;

put('directsum,'psopfn,'matop!=directsum);
symbolic procedure matop!=directsum l;
% Returns the direct sum of the modules in the list l.
  dpmat_2a directsum!* for each x in l collect dpmat_from_a reval x;

symbolic operator deleteunits;
symbolic procedure deleteunits m;
  if !*noetherian then m
  else if !*mode='algebraic then dpmat_2a deleteunits!* dpmat_from_a m
  else deleteunits!* m;

symbolic procedure deleteunits!* m;
% Delete units from the base elements of the ideal m.
  if !*noetherian or (dpmat_cols m>0) then m
  else dpmat_make(dpmat_rows m,0,
        for each x in dpmat_list m collect
                bas_factorunits x,nil,dpmat_gbtag m);

symbolic procedure interreduce!* m;
  (begin scalar u;
  u:=red_interreduce dpmat_list m;
  return dpmat_make(length u, dpmat_cols m, bas_renumber u,
                cali!=degrees, dpmat_gbtag m)
  end)  where cali!=degrees:=dpmat_coldegs m;

symbolic operator interreduce;
symbolic procedure interreduce m;
% Interreduce m.
  if !*mode='algebraic then
        dpmat_2a interreduce!* dpmat_from_a reval m
  else interreduce!* m;

symbolic procedure gbasis!* m;
% Produce a minimal Groebner or standard basis of the dpmat m.
  if dpmat_gbtag m then m else car groeb_stbasis(m,t,nil,nil);

put('tangentcone,'psopfn,'matop!=tangentcone);
symbolic procedure matop!=tangentcone m;
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=tangentcone!* c;
  return dpmat_2a c;
  end;

symbolic procedure tangentcone!* m;
% Returns the tangent cone of m, provided the term order has degrees.
% m must be a gbasis.
  if null ring_degrees cali!=basering then
        rederr"tangent cone only for degree orders defined"
  else (begin scalar b;
  b:=for each x in dpmat_list m collect
    bas_make(bas_nr x,dp_tcpart bas_dpoly x);
  return dpmat_make(dpmat_rows m,
        dpmat_cols m,b,cali!=degrees,dpmat_gbtag m);
  end)  where cali!=degrees:=dpmat_coldegs m;


symbolic procedure syzygies1!* bas;
% Returns the (not yet interreduced first) syzygy module of the dpmat
% bas.
  begin
  if cali_trace() > 0 then
    << terpri(); write" Compute syzygies"; terpri() >>;
  return third groeb_stbasis(bas,nil,nil,t);
  end;

symbolic procedure syzygies!* bas;
% Returns the interreduced syzygy basis.
  interreduce!* syzygies1!* bas;

symbolic procedure normalform!*(a,b);
% Returns {a1,r,z} with a1=z*a-r*b where the rows of the dpmat a1 are
% the normalforms of the rows of the dpmat a with respect to the
% dpmat b.
   if not(eqn(dpmat_cols a,dpmat_cols b) and
        equal(dpmat_coldegs a,dpmat_coldegs b)) then
                rederr"dpmats don't match for NORMALFORM"
   else (begin scalar a1,z,u,r;
      bas_setrelations dpmat_list b;
      a1:=for each x in dpmat_list a collect
        << u:=red_redpol(dpmat_list b,x);
           z:=bas_make(bas_nr x,dp_times_ei(bas_nr x,cdr u)).z;
           car u
        >>;
      r:=bas_getrelations a1; bas_removerelations a1;
      bas_removerelations dpmat_list b; z:=reversip z;
      a1:=dpmat_make(dpmat_rows a,dpmat_cols a,a1,cali!=degrees,nil);
      cali!=degrees:=dpmat_rowdegrees b;
      r:=dpmat_make(dpmat_rows a,dpmat_rows b,bas_neworder r,
                            cali!=degrees,nil);
      cali!=degrees:=nil;
      z:=dpmat_make(dpmat_rows a,dpmat_rows a,bas_neworder z,nil,nil);
      return  {a1,r,z};
      end)  where cali!=degrees:=dpmat_coldegs b;

symbolic procedure matop_pseudomod(a,b); car mod!*(a,b);

symbolic procedure mod!*(a,b);
% Returns the normal form of the dpoly a modulo the dpmat b and the
% corresponding unit produced during pseudo division.
  (begin scalar u;
      a:=dp_neworder a; % to be on the safe side.
      u:=red_redpol(dpmat_list b,bas_make(0,a));
      return (bas_dpoly car u) . cdr u;
  end)  where cali!=degrees:=dpmat_coldegs b;

symbolic operator mod;
symbolic procedure mod(a,b);
% True normal form as s.q. also for matrices.
  if !*mode='symbolic then rederr"only for algebraic mode"
  else begin scalar u;
    b:=dpmat_from_a reval b; a:=reval a;
    if eqcar(a,'list) then
        if dpmat_cols b>0 then rederr"entries don't match for MOD"
        else a:=makelist for each x in cdr a collect
           << u:=mod!*(dp_from_a x, b);
              {'quotient,dp_2a car u,dp_2a cdr u}
           >>
    else if eqcar(a,'mat) then
        begin a:=dpmat_from_a a;
        if dpmat_cols a neq dpmat_cols b then
                rederr"entries don't match for MOD";
        a:=for each x in dpmat_list a collect mod!*(bas_dpoly x,b);
        a:='mat.
            for each x in a collect
              << u:=dp_2a cdr x;
                 for i:=1:dpmat_cols b collect
                    {'quotient,dp_2a dp_comp(i,car x),u}
              >>
        end
    else if dpmat_cols b>0 then rederr"entries don't match for MOD"
    else << u:=mod!*(dp_from_a a, b);
            a:={'quotient,dp_2a car u,dp_2a cdr u}
          >>;
    return a;
    end;

infix mod;

symbolic operator normalform;
symbolic procedure normalform(a,b);
% Compute a normal form of the rows of a with respect to b :
%   first result = third result * a + second result * b.
  if !*mode='algebraic then
  begin scalar m;
  m:= normalform!*(dpmat_from_a reval a,dpmat_from_a reval b);
  return {'list,dpmat_2a car m, dpmat_2a cadr m, dpmat_2a caddr m}
  end
  else normalform!*(a,b);

symbolic procedure eliminate!*(m,vars);
% Returns a (dpmat) basis of the elimination module of the dpmat m
% eliminating variables contained in the var. list vars.
% It sets temporary the standard elimination term order, but doesn't
% affect the ecart, and computes a Groebner basis of m.

%  if dpmat_gbtag m and eo(vars) then dpmat_sieve(m,vars,t) else

   (begin scalar c,e,bas,v;
   c:=cali!=basering; e:=ring_ecart c;
   v:=ring_names cali!=basering;
   setring!* ring_define(v,eliminationorder!*(v,vars),'revlex,e);
   cali!=degrees:=nil; % No degrees for proper result !!
   bas:=(bas_sieve(dpmat_list
            car groeb_stbasis(dpmat_neworder(m,nil),t,nil,nil), vars)
            where !*noetherian=t);
   setring!* c; cali!=degrees:=dpmat_coldegs m;
   return dpmat_make(length bas,dpmat_cols m,bas_neworder bas,
                            cali!=degrees,nil);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic operator eliminate;
symbolic procedure eliminate(m,l);
% Returns the elimination ideal/module of m with respect to the
% variables in the list l to be eliminated.
  if !*mode='algebraic then
  begin l:=reval l;
    if not eqcar(l,'list) then typerr(l,"variable list");
    m:=dpmat_from_a m; l:=cdr l;
    return dpmat_2a eliminate!*(m,l);
  end
  else eliminate!*(m,l);

symbolic procedure matintersect!* l;
  if null l then rederr"MATINTERSECT with empty list"
  else if length l=1 then car l
  else (begin scalar c,u,v,p,size;
    matop!=testdpmatlist l;
    size:=dpmat_cols car l;
    v:=for each x in l collect gensym();
    c:=cali!=basering;
    setring!* ring_sum(c,
        ring_define(v,degreeorder!* v,'lex,for each x in v collect 1));
    cali!=degrees:=mo_degneworder dpmat_coldegs car l;
    u:=for each x in pair(v,l) collect
        dpmat_times_dpoly(dp_from_a car x,dpmat_neworder(cdr x,nil));
    p:=dp_fi 1; for each x in v do p:=dp_diff(p,dp_from_a x);
    if size=0 then p:=dpmat_from_dpoly p
    else p:=dpmat_times_dpoly(p,dpmat_unit(size,cali!=degrees));
    p:=gbasis!* matsum!* (p . u);
    p:=dpmat_sieve(p,v,t);
    setring!* c;
    cali!=degrees:=dpmat_coldegs car l;
    return dpmat_neworder(p,t);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

put('matintersect,'psopfn,'matop!=matintersect);
put('idealintersect,'psopfn,'matop!=matintersect);
symbolic procedure matop!=matintersect l;
% Returns the intersection of the submodules of a fixed free module
% in the list l.
  dpmat_2a matintersect!* for each x in l collect dpmat_from_a reval x;


% ------- Submodule property and equality test --------------

put('modequalp,'psopfn,'matop!=equalp);
% Test, whether a and b are module equal.
symbolic procedure matop!=equalp u;
  if length u neq 2 then rederr"Syntax : MODEQUALP(dpmat,dpmat) "
  else begin scalar a,b;
    intf_get first u; intf_get second u;
    if null(a:=get(first u,'gbasis)) then
        put(first u,'gbasis,a:=gbasis!* get(first u,'basis));
    if null(b:=get(second u,'gbasis)) then
        put(second u,'gbasis,b:=gbasis!* get(second u,'basis));
    if modequalp!*(a,b) then return 'yes else return 'no
    end;

symbolic procedure modequalp!*(a,b);
  submodulep!*(a,b) and submodulep!*(b,a);

put('submodulep,'psopfn,'matop!=submodulep);
% Test, whether a is a submodule of b.
symbolic procedure matop!=submodulep u;
  if length u neq 2 then rederr"Syntax : SUBMODULEP(dpmat,dpmat)"
  else begin scalar a,b;
    intf_get second u;
    if null(b:=get(second u,'gbasis)) then
        put(second u,'gbasis,b:=gbasis!* get(second u,'basis));
    a:=dpmat_from_a reval first u;
    if submodulep!*(a,b) then return 'yes else return 'no
    end;

symbolic procedure submodulep!*(a,b);
  if not(dpmat_cols a=dpmat_cols b
     and equal(dpmat_coldegs a,dpmat_coldegs b)) then
    rederr"incompatible modules in SUBMODULEP"
  else (begin
    a:=for each x in dpmat_list a collect bas_dpoly x;
    return not listtest(a,b,function matop_pseudomod)
    end) where cali!=degrees:=dpmat_coldegs a;

endmodule; % matop

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/prime.red0000644000175000017500000007032511526203062023233 0ustar  giovannigiovannimodule prime; % corrected version | 15.6.1995

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



COMMENT

        ####################################
        #                                  #
        #  PRIME DECOMPOSITION, RADICALS,  #
        #        AND RELATED PROBLEMS      #
        #                                  #
        ####################################


This module contains algorithms

    - for zerodimensional ideals :
            - to test whether it is radical
            - to compute its radical
            - for a primality test

    - for zerodimensional ideals and modules :
            - to compute its primes
            - to compute its primary decomposition

    - for arbitrary ideals :
            - for a primality test
            - to compute its radical
            - to test whether it is radical

    - for arbitrary ideals and modules :
        - to compute its isolated primes
        - to compute its primary decomposition and
            the associated primes
        - a shortcut for the primary decomposition
            computation for unmixed modules

The algorithms follow

        Seidenberg : Trans. AMS 197 (1974), 273 - 313.

        Kredel : in Proc. EUROCAL'87, Lecture Notes in Comp. Sci. 378
                (1986), 270 - 281.

        Gianni, Trager, Zacharias :
                J. Symb. Comp. 6 (1988), 149 - 167.

The primary decomposition now proceeds as follows:
        1) compute the isolated primes
        2) compute by ideal separation quasi-primary components
        3) for each of them split off embedded components
        4) apply the decomposition recursively to them
        5) Decide in a last (global) step unnecessary components among
                them

See     Gr\"abe : Factorized Gr\"obner bases and primary
                decomposition. To appear

The switch factorprimes switches between invokation of the Groebner
factorizer (on/ the default) and algorithms, that use only univariate
factorization as described in [GTZ] (off).


END COMMENT;

switch factorprimes;     % (on) see primes

!*factorprimes:=t;      % Invoke the Groebner factorizer first.

% ------ The radical of a zerodimensional ideal -----------

symbolic procedure prime!=mksqrfree(pol,x);
% Make the univariate dpoly p(x) squarefree.
  begin scalar p;
    p:=numr simp dp_2a pol;
    return dp_from_a prepf car qremf(p,gcdf!*(p,numr difff(p,x)))
    end;

put('zeroradical,'psopfn,'prime!=evzero);
symbolic procedure prime!=evzero m;
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  return dpmat_2a zeroradical!* c;
  end;

symbolic procedure zeroradical!* m;
% Returns the radical of the zerodim. ideal m. m must be a gbasis.
  if dpmat_cols m>0 or not dimzerop!* m then
        rederr"ZERORADICAL only for zerodimensional ideals"
  else if dpmat_unitideal!? m then m
  else begin scalar u;
    u:=for each x in ring_names cali!=basering collect
        bas_make(0,prime!=mksqrfree(odim_up(x,m),x));
    u:=dpmat_make(length u,0,bas_renumber u,nil,nil);
    return gbasis!* matsum!* {m,u};
    end;

put('iszeroradical,'psopfn,'prime!=eviszero);
symbolic procedure prime!=eviszero m;
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  return if iszeroradical!* c then 'yes else 'no;
  end;

symbolic procedure iszeroradical!* m;
% Test whether the zerodim. ideal m is radical. m must be a gbasis.
  if dpmat_cols m>0 or not dimzerop!* m then
        rederr"ISZERORADICAL only for zerodimensional ideals"
  else if dpmat_unitideal!? m then t
  else begin scalar isradical;
    isradical:=t;
    for each x in ring_names cali!=basering do
        isradical:=isradical and
            null matop_pseudomod(prime!=mksqrfree(odim_up(x,m),x),m);
    return isradical;
    end;

% ---- The primes of a zerodimensional ideal or module ------

symbolic operator zeroprimes;
symbolic procedure zeroprimes m;
  if !*mode='algebraic then
        makelist for each x in zeroprimes!* dpmat_from_a reval m
                collect dpmat_2a x
  else zeroprimes!* m;

symbolic procedure zeroprimes!* m;
% The primes of the zerodimensional ideal Ann F/M.
% The unit ideal has no primes.
  listminimize(for each x in
        if !*factorprimes then groebf_zeroprimes1(annihilator2!* m,nil)
        else prime_zeroprimes1 gbasis!* annihilator2!* m
                join prime!=zeroprimes2 x, function submodulep!*);

symbolic procedure prime_iszeroprime m;
% Test a zerodimensiomal ideal to be prime. m must be a gbasis.
  if dpmat_cols m>0 or not dimzerop!* m then
    rederr "iszeroprime only for zerodimensional ideals"
  else if dpmat_unitideal!? m then rederr"the ideal is the unit ideal"
  else prime!=iszeroprime1 m and prime!=iszeroprime2 m;

symbolic procedure prime_zeroprimes1 m;
% A first approximation to the isolated primes in dim=0 : Factor all
% univariate polynomials in m.
% m must be a gbasis. Returns a reduced list of gbases.
  if dpmat_cols m>0 then rederr"ZEROPRIMES only for ideals"
  else if dpmat_unitideal!? m then nil
  else if not dimzerop!* m then
        rederr"ZEROPRIMES only for zerodimensional ideals"
  else begin scalar l;
    l:={m};
    for each x in ring_names cali!=basering do
        l:=for each y in l join
                if not member(x,for each v in dpmat_list y join
                        {mo_linear dp_lmon bas_dpoly v}) then
            (begin scalar u,p;
            u:=dp_factor (p:=odim_up(x,y));
            if (length u=1) and equal(car u,p) then return {y}
            else return for each z in u join
                if not dpmat_unitideal!?(p:=gbasis!* matsum!*
                        {y,dpmat_from_dpoly z}) then {p};
            end)
                else {y};
    return l;
    end;

symbolic procedure prime!=iszeroprime1 m;
% A first non primality test.
  if dpmat_cols m>0 then rederr"ISZEROPRIME only for ideals"
  else if dpmat_unitideal!? m then nil
  else if not dimzerop!* m then
        rederr"ISZEROPRIME only for zerodimensional ideals"
  else begin scalar b; b:=t;
    for each x in ring_names cali!=basering do
       b:=b and
            begin scalar u,p;
            u:=dp_factor (p:=odim_up(x,m));
            if (length u=1) and equal(car u,p) then return t
            else return nil
            end;
    return b;
    end;

symbolic procedure prime_gpchange(vars,v,m);
% Change to general position with respect to v. Only for pure lex.
% term order and radical ideal m.
  if null vars or dpmat_unitideal!? m then m
  else begin scalar s,x,a;
    s:=0; x:=mo_from_a car vars;
    a:=list (v.prepf addf(!*k2f v,!*k2f car vars));
            % the substitution rule v -> v + x .
    while not member(x,moid_from_bas dpmat_list m)
                % i.e. m has a leading term equal to x
        and ((s:=s+1) < 10)
                % to avoid too much loops.
        do m:=gbasis!* dpmat_sub(a,m);
    if s=10 then rederr" change to general position failed";
    return prime_gpchange(cdr vars,v,m);
    end;

symbolic procedure prime!=zeroprimes2 m;
% Decompose the radical zerodimensional dmpat ideal m using a general
% position argument. Returns a reduced list of gbases.
  (begin scalar c,v,vars,u,d,r;
    c:=cali!=basering; vars:=ring_names c; v:=gensym();
    u:=setdiff(vars,for each x in moid_from_bas dpmat_list m
                join {mo_linear x});
    if (length u)=1 then return prime!=zeroprimes3(m,first u);
    if ring_tag c='revlex then % for proper ring_sum redefine it.
        r:=ring_define(vars,ring_degrees c,'lex,ring_ecart c)
    else r:=c;
    setring!* ring_sum(r,ring_define(list v,nil,'lex,'(1)));
    cali!=degrees:=nil;
    m:=gbasis!* matsum!*
                {dpmat_neworder(m,nil), dpmat_from_dpoly dp_from_a v};
    u:=setdiff(v.vars,for each x in moid_from_bas dpmat_list m
                join {mo_linear x});
    if not dpmat_unitideal!? m then
      << m:=prime_gpchange(u,v,m);
         u:=for each x in prime!=zeroprimes3(m,v) join
             if not dpmat_unitideal!? x and
                not dpmat_unitideal!?(d:=eliminate!*(x,{v})) then {d}
                    % To recognize (1) even if x is not a gbasis.
      >>
    else u:=nil;
    setring!* c;
    return for each x in u collect gbasis!* dpmat_neworder(x,nil);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=zeroprimes3(m,v);
% m is in general position with univariate polynomial in v.
  begin scalar u,p;
  u:=dpmat_list m;
  while u and not equal(mo_support dp_lmon (p:=bas_dpoly car u),
                        list v) do u:=cdr u;
  if null u then rederr"univariate polynomial not found";
  p:=for each x in cdr ((fctrf numr simp dp_2a p) where !*factor=t)
        collect dpmat_from_dpoly dp_from_a prepf car x;
  return for each x in p collect matsum!* {m,x};
  end;

symbolic procedure prime!=iszeroprime2 m;
% Test the radical zerodimensional dmpat ideal m to be prime using a
% general position argument.
  (begin scalar c,v,vars,u,r;
    c:=cali!=basering; vars:=ring_names c; v:=gensym();
    if ring_tag c='revlex then % for proper ring_sum redefine it.
        r:=ring_define(vars,ring_degrees c,'lex,ring_ecart c)
    else r:=c;
    setring!* ring_sum(r,ring_define(list v,nil,'lex,'(1)));
    cali!=degrees:=nil;
    m:=matsum!* {dpmat_neworder(m,nil), dpmat_from_dpoly dp_from_a v};
    m:=prime_gpchange(vars,v,gbasis!* m);
    u:=prime!=iszeroprime3(m,v);
    setring!* c; return u;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=iszeroprime3(m,v);
  begin scalar u,p;
  u:=dpmat_list m;
  while u and not equal(mo_support dp_lmon (p:=bas_dpoly car u),
                        list v) do u:=cdr u;
  if null u then rederr"univariate polynomial not found";
  if (length(u:=cdr ((fctrf numr simp dp_2a p) where !*factor=t))>1)
        or (cdar u>1) then return nil
  else return t
  end;

% --------- Primality test for an arbitrary ideal. ---------

put('isprime,'psopfn,'prime!=isprime);
symbolic procedure prime!=isprime m;
  begin scalar c;
    intf_test m; intf_get(m:=car m);
    if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
    return if isprime!* c then 'yes else 'no;
  end;

symbolic procedure isprime!* m;
% Test an dpmat ideal m to be prime. m must be a gbasis.
  if dpmat_cols m>0 then rederr"prime test only for ideals"
  else (begin scalar vars,u,v,c1,c2,m1,m2,lc;
    v:=moid_goodindepvarset m; cali!=degrees:=nil;
    if null v then return prime_iszeroprime m;
    vars:=ring_names(c1:=cali!=basering);
        % Change to dimension zero.
    u:=setdiff(ring_names c1,v);
    setring!* ring_rlp(c1,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!*(c2:= ring_define(u,degreeorder!* u,'revlex,
                        for each x in u collect 1));
    m1:=groeb_mingb dpmat_from_a m1;
    if dpmat_unitideal!?(m1) then
      << setring!* c1; rederr"Input must be a gbasis" >>;
    lc:=bc_2a prime!=quot m1; setring!* c1;
        % Test recontraction of m1 to be equal to m.
    m2:=gbasis!* matqquot!*(m,dp_from_a lc);
    if not submodulep!*(m2,m) then return nil;
        % Test the zerodimensional ideal m1 to be prime
    setring!* c2; u:=prime_iszeroprime m1; setring!* c1;
    return u;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic operator isolatedprimes;
symbolic procedure isolatedprimes m;
  if !*mode='algebraic then
        makelist for each x in isolatedprimes!* dpmat_from_a reval m
                collect dpmat_2a x
  else isolatedprimes!* m;

symbolic procedure isolatedprimes!* m;
% Returns the isolated primes of the dpmat m as a dpmat list.
  if !*factorprimes then
        listminimize(
        for each x in groebfactor!*(annihilator2!* m,nil) join
                prime!=factorisoprimes car x,
        function submodulep!*)
  else prime!=isoprimes gbasis!* annihilator2!* m;

symbolic procedure prime!=isoprimes m;
% m is a gbasis and an ideal.
  if dpmat_zero!? m then nil else
  (begin scalar u,c,v,vars,m1,m2,l,p;
    if null(v:=odim_parameter m) then return
        for each x in prime_zeroprimes1 m join prime!=zeroprimes2 x;
    vars:=ring_names(c:=cali!=basering); cali!=degrees:=nil;
    u:=delete(v,vars);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,
                        'revlex,for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=for each x in prime!=isoprimes m1 collect
            (dpmat_2a x . bc_2a prime!=quot x);
    setring!* c;
    l:=for each x in l collect
                gbasis!* matqquot!*(dpmat_from_a car x,dp_from_a cdr x);
    if dp_unit!?(p:=dp_from_a p) or
        submodulep!*(matqquot!*(m,p),m) or
        dpmat_unitideal!?(m2:=gbasis!* matsum!* {m,dpmat_from_dpoly p})
                then return l
    else return
        listminimize(append(l,prime!=isoprimes  m2),
                        function submodulep!*);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=factorisoprimes m;
% m is a gbasis and an ideal.
  if dpmat_zero!? m then nil else
  (begin scalar u,c,v,vars,m1,m2,l,p;
    if null(v:=odim_parameter m) then
        return for each x in groebf_zeroprimes1(m,nil) join
                prime!=zeroprimes2 x;
    vars:=ring_names(c:=cali!=basering); cali!=degrees:=nil;
    u:=delete(v,vars);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,
                        'revlex,for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=for each x in prime!=factorisoprimes m1 collect
            (dpmat_2a x . bc_2a prime!=quot x);
    setring!* c;
    l:=listgroebfactor!* for each x in l collect
                matqquot!*(dpmat_from_a car x,dp_from_a cdr x);
    if dp_unit!?(p:=dp_from_a p) or
        submodulep!*(matqquot!*(m,p),m) or
        null (m2:=groebfactor!*(matsum!* {m,dpmat_from_dpoly p},nil))
                then return l
    else return
        listminimize(append(l,for each x in m2 join
                prime!=factorisoprimes car x), function submodulep!*);
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=quot m;
% The lcm of the leading coefficients of m.
  begin scalar p,u;
    u:=for each x in dpmat_list m collect dp_lc bas_dpoly x;
    if null u then return bc_fi 1;
    p:=car u; for each x in cdr u do p:=bc_lcm(p,x);
    return p
  end;

% ------------------- The radical ---------------------

symbolic operator radical;
symbolic procedure radical m;
% Returns the radical of the dpmat ideal m.
  if !*mode='algebraic then
        dpmat_2a radical!* gbasis!* dpmat_from_a reval m
  else radical!* m;

symbolic procedure radical!* m;
% m must be a gbasis.
  if dpmat_cols m>0 then rederr"RADICAL only for ideals"
  else (begin scalar u,c,v,vars,m1,l,p,p1;
    if null(v:=odim_parameter m) then return zeroradical!* m;
    vars:=ring_names (c:=cali!=basering);
    cali!=degrees:=nil; u:=delete(v,vars);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,
                        'revlex,for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=radical!* m1; p1:=bc_2a prime!=quot l;
    l:=dpmat_2a l; setring!* c;
    l:=gbasis!* matqquot!*(dpmat_from_a l,dp_from_a p1);
    if dp_unit!?(p:=dp_from_a p) or
    submodulep!*(matqquot!*(m,p),m) then return l
    else << m1:=radical!* gbasis!* matsum!* {m,dpmat_from_dpoly p};
            if submodulep!*(m1,l) then l:=m1
            else if not submodulep!*(l,m1) then
                    l:= matintersect!* {l,m1};
         >>;
    return l;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

% ------------------- The unmixed radical ---------------------

symbolic operator unmixedradical;
symbolic procedure unmixedradical m;
% Returns the radical of the dpmat ideal m.
  if !*mode='algebraic then
        dpmat_2a unmixedradical!* gbasis!* dpmat_from_a reval m
  else unmixedradical!* m;

symbolic procedure unmixedradical!* m;
% m must be a gbasis.
  if dpmat_cols m>0 then rederr"UNMIXEDRADICAL only for ideals"
  else (begin scalar u,c,d,v,vars,m1,l,p,p1;
    if null(v:=moid_goodindepvarset m) then return zeroradical!* m;
    vars:=ring_names (c:=cali!=basering);
    d:=length v; u:=setdiff(vars,v);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,'revlex,
                for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=zeroradical!* m1; p1:=bc_2a prime!=quot l;
    l:=dpmat_2a l; setring!* c;
    l:=matqquot!*(dpmat_from_a l,dp_from_a p1);
    if dp_unit!?(p:=dp_from_a p) then return l
    else << m1:=gbasis!* matsum!* {m,dpmat_from_dpoly p};
            if dim!* m1=d then
                l:= matintersect!* {l,unmixedradical!* m1};
         >>;
    return l;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

% ------------------- The equidimensional hull---------------------

symbolic operator eqhull;
symbolic procedure eqhull m;
% Returns the radical of the dpmat ideal m.
  if !*mode='algebraic then
        dpmat_2a eqhull!* gbasis!* dpmat_from_a reval m
  else eqhull!* m;

symbolic procedure eqhull!* m;
% m must be a gbasis.
  begin scalar d;
  if (d:=dim!* m)=0 then return m
  else return prime!=eqhull(m,d)
  end;

symbolic procedure prime!=eqhull(m,d);
% d(>0) is the dimension of the dpmat m.
  (begin scalar u,c,v,vars,m1,l,p;
  v:=moid_goodindepvarset m;
  if length v neq d then
        rederr "EQHULL found a component of wrong dimension";
  vars:=ring_names(c:=cali!=basering);
  cali!=degrees:=nil; u:=setdiff(ring_names c,v);
  setring!* ring_rlp(c,u);
  m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
  setring!* ring_define(u,degreeorder!* u,'revlex,
                                for each x in u collect 1);
  p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
  setring!* c; cali!=degrees:=dpmat_coldegs m;
  if submodulep!*(l:=matqquot!*(m,dp_from_a p),m) then return m;
  m1:=gbasis!* matstabquot!*(m,annihilator2!* l);
  if dim!* m1=d then return matintersect!* {l,prime!=eqhull(m1,d)}
  else return l;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

% ---------- Primary Decomposition Algorithms ------------

Comment

by [GTZ]'s approach:
        - Compute successively a list {(Q_i,p_i)} of pairs
                (primary module, associated prime ideal)
          such that
                Q = \intersection{Q_i}
        - figure out the superfluous components

(Note, that different to our former opinion (v. 2.2.) it is not
sufficient to extract the elements from that list, that are minimal
wrt. inclusion for the primary component. There may be components,
containing none of these minimal primaries, but containing their
intersection !!)

Primary decompositions return a list of {Q,P} pairs with prime
ideal P and corresponding primary component Q.

end comment;

% - The primary decomposition of a zerodimensional ideal or module -

symbolic procedure prime_separate l;
% l is a list of (gbases of) prime ideals.
% Returns a list of (p . f) with p \in l and dpoly f \in all q \in l
% except p.
  for each x in l collect (x . prime!=polynomial(x,delete(x,l)));

symbolic procedure prime!=polynomial(x,l);
% Returns a dpoly f inside all q \in l and outside x.
  if null l then dp_fi 1
  else begin scalar u,p,q;
    p:=prime!=polynomial(x,cdr l);
    if null matop_pseudomod(p,car l) then return p;
    u:=dpmat_list car l;
    while u and null matop_pseudomod(q:=bas_dpoly car u,x) do u:=cdr u;
    if null u then
        rederr"prime ideal separation failed"
    else return dp_prod(p,q);
  end;

symbolic operator zeroprimarydecomposition;
symbolic procedure zeroprimarydecomposition m;
% Returns a list of {Q,p} with p a prime ideal and Q a p-primary
% component of m. For m=S^c the list is empty.
  if !*mode='algebraic then
        makelist for each x in
                zeroprimarydecomposition!* dpmat_from_a reval m
        collect makelist {dpmat_2a first x,dpmat_2a second x}
  else zeroprimarydecomposition!* m;

symbolic procedure zeroprimarydecomposition!* m;
% The symbolic counterpart, returns a list of {Q,p}. m is not
% assumed to be a gbasis.
    if not dimzerop!* m then rederr
 "zeroprimarydecomposition only for zerodimensional ideals or modules"
    else for each f in prime_separate
            (for each y in zeroprimes!* m collect gbasis!* y)
        collect {matqquot!*(m,cdr f),car f};

% -- Primary decomposition for modules without embedded components ---

symbolic operator easyprimarydecomposition;
symbolic procedure easyprimarydecomposition m;
  if !*mode='algebraic then
        makelist for each x in
                easyprimarydecomposition!* dpmat_from_a reval m
        collect makelist {dpmat_2a first x,dpmat_2a second x}
  else easyprimarydecomposition!* m;

symbolic procedure easyprimarydecomposition!* m;
% Primary decomposition for a module without embedded components.
   begin scalar u; u:=isolatedprimes!* m;
      return if null u then nil
        else if length u=1 then {{m,car u}}
        else for each f in
        prime_separate(for each y in u collect gbasis!* y)
                    collect {matqquot!*(m,cdr f),car f};
  end;

% ---- General primary decomposition ----------

symbolic operator primarydecomposition;
symbolic procedure primarydecomposition m;
  if !*mode='algebraic then
        makelist for each x in
                primarydecomposition!* gbasis!* dpmat_from_a reval m
        collect makelist {dpmat_2a first x,dpmat_2a second x}
  else primarydecomposition!* m;

symbolic procedure primarydecomposition!* m;
% m must be a gbasis. The [GTZ] approach.
  if dpmat_cols m=0 then
    for each x in prime!=decompose1 ideal2mat!* m collect
        {mat2list!* first x,second x}
  else prime!=decompose1 m;

% --------------- Implementation of the [GTZ] approach

symbolic procedure prime!=decompose1 m;
% The method as in the final version of the paper: Dropping dimension
% by one in each step.
  (begin scalar u,c,v,vars,m1,l,l1,p,q;
    if null(v:=odim_parameter m) then
            return zeroprimarydecomposition!* m;
    vars:=ring_names (c:=cali!=basering);
    cali!=degrees:=nil; u:=delete(v,vars);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,
                                'revlex,for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=for each x in prime!=decompose1 m1 collect
          {(dpmat_2a first x . bc_2a prime!=quot first x),
           (dpmat_2a second x . bc_2a prime!=quot second x)};
    setring!* c;
    l:=for each x in l collect
    << cali!=degrees:=dpmat_coldegs m;
       {gbasis!* matqquot!*(dpmat_from_a car first x,
                                dp_from_a cdr first x),
        gbasis!* matqquot!*(dpmat_from_a car second x,
                                dp_from_a cdr second x)}
    >>;
    if dp_unit!?(p:=dp_from_a p) or
        submodulep!*(m1:=matqquot!*(m,p),m) then return l
    else
      << q:=p; v:=1;
         while not submodulep!*(m1:=dpmat_times_dpoly(p,m1),m)
                and (v<15) do << q:=dp_prod(p,q); v:=v+1 >>;
        if (v=15) then
                rederr"Power detection in prime!=decompose1 failed";
        l1:=prime!=decompose1 gbasis!* matsum!*
                {m, dpmat_times_dpoly(q,
                        dpmat_unit(dpmat_cols m,dpmat_coldegs m))};

Comment

At this moment M = M:
\intersection (M,q*F), q=p^n, and
        - l is the list of primary comp., lifted from the first part
                (they are lifted from a localization and have p as non
                        zero divisor)
        - l1 is the list of primary comp. of the second part
                (which have p as zero divisor and should be tested
                against M, whether they are indeed necessary)

end comment;

        p:=append(for each x in l collect second x,
                for each x in l1 collect second x);
        l:=append(l,for each x in l1 join
                if prime!=necessary(second x,m,p) then {x});

      >>;
    return l;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=decompose2 m;
% The method as in [BKW] : Reducing directly to dimension zero. This
% is usually a quite bad guess.
  (begin scalar u,c,v,vars,m1,l,l1,p,q;
    v:=moid_goodindepvarset m;
    if null v then return zeroprimarydecomposition!* m;
    vars:=ring_names (c:=cali!=basering);
    cali!=degrees:=nil; u:=setdiff(vars,v);
    setring!* ring_rlp(c,u);
    m1:=dpmat_2a gbasis!* dpmat_neworder(m,nil);
    setring!* ring_define(u,degreeorder!* u,
                                'revlex,for each x in u collect 1);
    p:=bc_2a prime!=quot(m1:=groeb_mingb dpmat_from_a m1);
    l:=for each x in zeroprimarydecomposition!* m1 collect
          {(dpmat_2a first x . bc_2a prime!=quot first x),
           (dpmat_2a second x . bc_2a prime!=quot second x)};
    setring!* c;
    l:=for each x in l collect
    << cali!=degrees:=dpmat_coldegs m;
       {gbasis!* matqquot!*(dpmat_from_a car first x,
                                dp_from_a cdr first x),
        gbasis!* matqquot!*(dpmat_from_a car second x,
                                dp_from_a cdr second x)}
    >>;
    if dp_unit!?(p:=dp_from_a p) or
        submodulep!*(m1:=matqquot!*(m,p),m) then return l
    else
      << q:=p; v:=1;
         while not submodulep!*(m1:=dpmat_times_dpoly(p,m1),m)
                and (v<15) do << q:=dp_prod(p,q); v:=v+1 >>;
        if (v=15) then
                rederr"Power detection in prime!=decompose2 failed";
        l1:=prime!=decompose2 gbasis!* matsum!*
                {m, dpmat_times_dpoly(q,
                        dpmat_unit(dpmat_cols m,dpmat_coldegs m))};
        p:=append(for each x in l collect second x,
                for each x in l1 collect second x);
        l:=append(l,for each x in l1 join
                if prime!=necessary(second x,m,p) then {x});
      >>;
    return l;
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure prime!=necessary(P,m,l);
% P a prime to be testet, M the original module, l the list of
% (possibly) associated primes of M, including P.
% Returns true <=> P is an embedded prime.

begin scalar l1,unit;
  l1:=for each u in l join if (u=p) or submodulep!*(u,p) then {t};
  if null l1 then
        rederr"prime!=necessary: supplied prime's list incorrect";
  if length l1 = 1 then % P is an isolated prime.
        return t;
  unit:=dpmat_unit(dpmat_cols m,cali!=degrees);
        % Unit matrix for reference.
  l1:=for each u in l join if not submodulep!*(u,p) then {u};
        % L_1 = Primes not contained in P.
  l:=delete(p,setdiff(l,l1)); % L = Primes contained in P.
  m:=matqquot!*(m,prime!=polynomial(p,l1));
        % Ass M is now contained in L \union (P).
  return not submodulep!*(matstabquot!*(m,p),m);
  end;

endmodule; % prime

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/bcsf.red0000644000175000017500000001035111526203062023025 0ustar  giovannigiovannimodule bcsf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT


            #######################
            #                     #
            #  BASE COEFFICIENTS  #
            #                     #
            #######################


These base coefficients are standard forms.

A list of REPLACEBY rules may be supplied with the setrules command
that will be applied in an additional simplification process.

This rules list is a list of s.f. pairs, where car should replace cdr.

END COMMENT;

% Standard is :

!*hardzerotest:=nil;

symbolic operator setrules;
symbolic procedure setrules m; setrules!* cdr reval m;

symbolic procedure setrules!* m;
  begin scalar r; r:=ring_names cali!=basering;
  m:=for each x in m collect
        if not eqcar(x,'replaceby) then
                typerr(makelist m,"rules list")
        else (numr simp second x . numr simp third x);
  for each x in m do
    if domainp car x or member(mvar car x,r) then
        rederr"no substitution for ring variables allowed";
  put('cali,'rules,m);
  return getrules();
  end;

symbolic operator getrules;
symbolic procedure getrules();
  makelist for each x in get('cali,'rules) collect
        list('replaceby,prepf car x,prepf cdr x);

symbolic procedure bc!=simp u;
  (if r0 then
  begin scalar r,c; integer i;
  i:=0; r:=r0;
  while r and (i<1000) do
  << c:=qremf(u,caar r);
     if null car c then r:=cdr r
     else
     << u:=addf(multf(car c,cdar r),cdr c);
        i:=i+1; r:=r0;
     >>;
  >>;
  if (i<1000) then return u
  else rederr"recursion depth of bc!=simp too high"
  end
  else u) where r0:=get('cali,'rules);

symbolic procedure  bc_minus!? u; minusf u;

symbolic procedure  bc_zero!? u;
    if (null u or u=0) then t
    else if !*hardzerotest and pairp u then
        null bc!=simp numr simp prepf u
    else nil;

symbolic procedure  bc_fi a; if a=0 then nil else a;

symbolic procedure  bc_one!? u; (u = 1);

symbolic procedure  bc_inv u;
% Test, whether u is invertible. Return the inverse of u or nil.
  if (u=1) or (u=-1) then u
  else begin scalar v; v:=qremf(1,u);
    if cdr v then return nil else return car v;
    end;

symbolic procedure  bc_neg u; negf u;

symbolic procedure  bc_prod (u,v); bc!=simp multf(u,v);

symbolic procedure  bc_quot (u,v);
  (if null cdr w then bc!=simp car w else typerr(v,"denominator"))
  where w=qremf(u,v);

symbolic procedure  bc_sum (u,v); addf(u,v);

symbolic procedure  bc_diff(u,v); addf(u,negf v);

symbolic procedure  bc_power(u,n); bc!=simp exptf(u,n);

symbolic procedure  bc_from_a u; bc!=simp numr simp!* u;

symbolic procedure  bc_2a u; prepf u;

symbolic procedure  bc_prin u;
% Prints a base coefficient in infix form
   ( if domainp u then
         if dmode!*='!:mod!: then prin2 prepf u
         else printsf u
     else << write"("; printsf u; write")" >>) where !*nat=nil;

symbolic procedure bc_divmod(u,v); % Returns quot . rem.
  qremf(u,v);

symbolic procedure bc_gcd(u,v); gcdf!*(u,v);

symbolic procedure bc_lcm(u,v);
    car bc_divmod(bc_prod(u,v),bc_gcd(u,v));

endmodule; % bcsf

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/ring.red0000644000175000017500000002350211526203062023051 0ustar  giovannigiovannimodule ring;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

               ##################
               ##              ##
               ##    RINGS     ##
               ##              ##
               ##################


Informal syntax :

Ring = ('RING (name list) ((degree list list)) deg_type ecart)
        with deg_type = 'lex or 'revlex.

The term order is defined at first comparing successively degrees and
then by the name list lex. or revlex. For details consult the manual.

(name list) contains a phantom name cali!=mk for the module
component, see below in module mo.

The variable cali!=basering contains the actual base ring.

The ecart is a list of positive integers (the ecart vector for the
given ring) and has
        length = length names cali!=basering.
It is used in several places for optimal strategies (noetherina term
orders ) or to guarantee termination (local term orders).
All homogenizations are executed with respect to that list.

END COMMENT;

symbolic procedure ring_define(n,to1,type,ecart);
    list('ring,'cali!=mk . n, to1, type,ecart);

symbolic procedure setring!* c;
  begin
     if !*noetherian and not ring_isnoetherian c then
        rederr"term order is not noetherian";
     cali!=basering:=c;
     setkorder ring_all_names c;
     return c;
  end;

symbolic procedure setecart!* e;
  begin scalar r; r:=cali!=basering;
    if not ring_checkecart(e,ring_names r) then
        typerr(e,"ecart vector")
    else cali!=basering:=
        ring_define(ring_names r,ring_degrees r,ring_tag r,e)
  end;

symbolic procedure ring_2a c;
    makelist {makelist ring_names c,
          makelist for each x in ring_degrees c collect makelist x,
          ring_tag c, makelist ring_ecart c};

symbolic procedure ring_from_a u;
  begin scalar vars,tord,c,r,tag,ecart;
  if not eqcar(u,'list) then typerr(u,"ring") else u:=cdr u;
  vars:=reval car u; tord:=reval cadr u; tag:=reval caddr u;
  if length u=4 then ecart:=reval cadddr u;
  if not(tag memq '(lex revlex)) then typerr(tag,"term order tag");
  if not eqcar(vars,'list) then typerr(vars,"variable list")
  else vars:=cdr vars;
  if tord={'list} then c:=nil
  else if not (c:=ring!=testtord(vars,tord)) then
        typerr(tord,"term order degrees");
  if null ecart then
     if (null tord)or not ring_checkecart(car tord,vars) then
                ecart:=for each x in vars collect 1
     else ecart:=car tord
  else if not ring_checkecart(cdr ecart,vars) then
        typerr(ecart,"ecart list")
  else ecart:=cdr ecart;
  r:=ring_define(vars,c,tag,ecart);
  if !*noetherian and not(ring_isnoetherian r) then
        rederr"Term order is non noetherian";
  return r
  end;

symbolic procedure ring!=testtord(vars,u);
% Test the non empty term order degrees for consistency and return
% the symbolic equivalent of u.
  if (ring!=lengthtest(cdr u,length vars +1)
        and ring!=contenttest cdr u)
            then for each x in cdr u collect cdr x
  else nil;

symbolic procedure ring!=lengthtest(m,v);
% Test, whether m is a list of (algebraic) lists of the length v.
  if null m then t
  else eqcar(car m,'list)
        and (length car m = v)
        and ring!=lengthtest(cdr m,v);

symbolic procedure ring!=contenttest m;
% Test, whether m is a list of (algebraic) number lists.
  if null m then t
  else numberlistp cdar m and ring!=contenttest cdr m;

symbolic procedure ring_names r; % User names only
        cdadr r;

symbolic procedure ring_all_names r; cadr r; % All names

symbolic procedure ring_degrees r; caddr r;

symbolic procedure ring_tag r; cadddr r;

symbolic procedure ring_ecart r; nth(r,5);

% --- Test the term order for the chain condition ------

symbolic procedure ring!=trans d;
% Transpose the degree matrix.
  if (null d)or(null car d) then nil
  else (for each x in d collect car x) .
                ring!=trans(for each x in d collect cdr x);

symbolic procedure ring!=testlex d;
   if null d then t
   else ring!=testlex1(car d) and ring!=testlex(cdr d);

symbolic procedure ring!=testlex1 d;
   if null d then t
   else if car d=0 then ring!=testlex1(cdr d)
   else (car d>0);

symbolic procedure ring!=testrevlex d;
   if null d then t
   else ring!=testrevlex1(car d) and ring!=testrevlex(cdr d);

symbolic procedure ring!=testrevlex1 d;
   if null d then nil
   else if car d=0 then ring!=testrevlex1(cdr d)
   else (car d>0);

symbolic procedure ring_isnoetherian r;
% Test, whether the term order of the ring r satisfies the chain
% condition.
  if ring_tag r ='revlex then
                ring!=testrevlex ring!=trans ring_degrees r
  else ring!=testlex ring!=trans ring_degrees r;

symbolic procedure ring!=degpos d;
  if null d then t
  else (car d>0) and ring!=degpos cdr d;

symbolic procedure ring_checkecart(e,vars);
  (length e=length vars) and ring!=degpos e;

% ---- Test noetherianity switching noetherian on :

put('noetherian,'simpfg,'((t (ring!=test))));

symbolic procedure ring!=test;
  if not ring_isnoetherian cali!=basering then
    << !*noetherian:=nil;
       rederr"Current term order is not noetherian"
    >>;

% ---- Different term orders -------------

symbolic operator eliminationorder;
symbolic procedure eliminationorder(v1,v2);
% Elimination order : v1 = all variables; v2 = variables to eliminate.
  if !*mode='algebraic then
        makelist for each x in
                eliminationorder!*(cdr reval v1,cdr reval v2)
                        collect makelist x
  else eliminationorder!*(v1,v2);

symbolic operator degreeorder;
symbolic procedure degreeorder(vars);
  if !*mode='algebraic then
        makelist for each x in degreeorder!*(cdr reval vars) collect
                makelist x
  else degreeorder!*(vars);

symbolic operator localorder;
symbolic procedure localorder(vars);
  if !*mode='algebraic then
        makelist for each x in localorder!*(cdr reval vars) collect
                makelist x
  else localorder!*(vars);

symbolic operator blockorder;
symbolic procedure blockorder(v1,v2);
  if !*mode='algebraic then
        makelist for each x in
                blockorder!*(cdr reval v1,cdr reval v2)
                        collect makelist x
  else blockorder!*(v1,v2);

symbolic procedure blockorder!*(vars,l);
% l is a list of integers, that sum up to |vars|.
% Returns the degree vector for the corresponding block order.
  if neq(for each x in l sum x,length vars) then
        rederr"block lengths sum doesn't match variable number"
  else begin scalar u; integer pre,post;
  pre:=0; post:=length vars;
  for each x in l do
  << u:=(append(append(for i:=1:pre collect 0,for i:=1:x collect 1),
                for i:=1:post-x collect 0)) . u;
     pre:=pre+x; post:=post-x
  >>;
  return reversip u;
  end;

symbolic procedure eliminationorder!*(v1,v2);
% Elimination order : v1 = all variables
% v2 = variables to eliminate.
  { for each x in v1 collect
        if x member v2 then 1 else 0,
    for each x in v1 collect
        if x member v2 then 0 else 1};

symbolic procedure degreeorder!*(vars);
  {for each x in vars collect 1};

symbolic procedure localorder!*(vars);
  {for each x in vars collect -1};

% ---------- Ring constructors -----------------

symbolic procedure ring_rlp(r,u);
% u is a subset of ring_names r. Returns the ring r with the block order
% "first degrevlex on u, then the order on r"
  ring_define(ring_names r,
  (for each x in ring_names r collect if x member u then 1 else 0)
  . append(reverse for each x in u collect
        for each y in ring_names r collect if x=y then -1 else 0,
                ring_degrees r), ring_tag r, ring_ecart r);

symbolic procedure ring_lp(r,u);
% u is a subset of ring_names r. Returns the ring r with the block order
% "first lex on u, then the order on r"
  ring_define(ring_names r,
  append(for each x in u collect for each y in ring_names r collect
                if x=y then 1 else 0, ring_degrees r),
        ring_tag r, ring_ecart r);

symbolic procedure ring_sum(a,b);
% Returns the direct sum of two base rings with degree matrix at
% first b then a and ecart=appended ecart lists.
  begin scalar vars,zeroa,zerob,degs,ecart;
  if not disjoint(ring_names a,ring_names b) then
    rederr"RINGSUM only for disjoint variable sets";
  vars:=append(ring_names a,ring_names b);
  ecart:=append(ring_ecart a,ring_ecart b);
  zeroa:=for each x in ring_names a collect 0;
  zerob:=for each x in ring_names b collect 0;
  degs:=append(
    for each x in ring_degrees b collect append(zeroa,x),
    for each x in ring_degrees a collect append(x,zerob));
  return ring_define(vars, degs, ring_tag a,ecart);
  end;

% --------- First initialization :

setring!* ring_define('(t x y z),'((1 1 1 1)),'revlex,'(1 1 1 1));

!*noetherian:=t;

% -------- End of first initialization ----------------

endmodule;  % ring

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/cali.tex0000644000175000017500000034256011526203062023060 0ustar  giovannigiovanni%       CALI user documentation
%       H.-G. Graebe | Univ. Leipzig | Version 2.2.1

\documentstyle[11pt]{article}
\date{June 28, 1995}

\textheight 21cm
\textwidth 15cm 
\voffset -60pt
\hoffset -45pt

\newcommand{\gr}{Gr\"obner }
\newcommand{\x}{{\bf x}}
\newcommand{\ind}[1]{{\em #1}\index{#1}}
\newcommand{\pbx}[1]{\mbox{}\hfill \parbox[t]{12cm}{#1} \pagebreak[3]}
\newcommand{\nl}{\newline \hspace*{5mm}}

\makeindex

\title{CALI\\[20pt] A REDUCE Package for \\ 
    Commutative Algebra \\Version 2.2.1}

\author{
Hans-Gert Gr\"abe \\[15pt]
Universit\"at Leipzig\\ 
Institut f\"ur Informatik \\
Augustusplatz 10 -- 11\\
04109 Leipzig / Germany\\[20pt]
email: graebe@informatik.uni-leipzig.de}

\begin{document}

\maketitle

\vfill
Key words: 
affine and projective monomial curves,
affine and projective sets of points, 
analytic spread, 
associated graded ring, 
blowup,
border bases, 
constructive commutative algebra, 
dual bases, 
elimination,
equidimensional part, 
extended \gr factorizer, 
free resolution, 
\gr algorithms for ideals and module, 
\gr factorizer,
ideal and module operations, 
independent sets, 
intersections,
lazy standard bases,
local free resolutions,
local standard bases,
minimal generators,
minors,
normal forms, 
pfaffians,
polynomial maps,
primary decomposition, 
quotients,
symbolic powers,
symmetric algebra, 
triangular systems, 
weighted Hilbert series, 
primality test, 
radical,
unmixed radical.

\pagebreak

\tableofcontents

\pagebreak

\section{Introduction}

This package contains algorithms for computations in commutative
algebra closely related to the \gr algorithm for ideals and modules.
Its heart is a new implementation of the \gr algorithm\footnote{The
data representation even for polynomials is different from that given
in the {\tt groebner} package distributed with REDUCE (and rests on ideas
used in the {\tt dipoly} package).} that allows the computation of
syzygies, too. This implementation is also applicable to submodules of
free modules with generators represented as rows of a matrix.

Moreover CALI contains facilities for local computations, using a
modern implementation of Mora's standard basis algorithm, see
\cite{MPT} and \cite{tcah}, that works for arbitrary term orders.
The full analogy between modules over the local ring \linebreak[1]
$k[x_v:v\in H]_{\bf m}$ and homogeneous (in fact H-local) modules
over $k[x_v:v\in H]$ is reflected through the switch
\ind{Noetherian}.  Turn it on (\gr basis, the default) or off (local
standard basis) to choose appropriate algorithms
automatically. In v.\ 2.2 we present an unified approach to both
cases, using reduction with bounded ecart for non Noetherian term
orders, see \cite{ala} for details. This allows to have a common
driver for the \gr algorithm in both cases.

CALI extends also the restricted term order facilities of the {\tt
groebner} package, defining term orders by degree vector lists, and 
the rigid implementation of the sugar idea, by a more flexible
\ind{ecart} vector, in particular useful for local computations, see
\cite{tcah}. 
\medskip

The package was designed mainly as a symbolic mode programming
environment extending the build-in facilities of REDUCE for the
computational approach to problems arising naturally in commutative
algebra. An algebraic mode interface accesses (in a more rigid frame)
all important features implemented symbolically and thus 
should be favored for short sample computations.

On the other hand, tedious computations are strongly recommended to
be done symbolically since this allows considerably more flexibility
and avoids unnecessary translations of intermediate results from
CALI's internal data representation to the algebraic mode and vice
versa. Moreover, one can easily extend the package with new symbolic
mode scripts, or do more difficult interactive computations. For all
these purposes the symbolic mode interface offers substantially more
facilities than the algebraic one.
\medskip

For a detailed description of special symbolic mode procedures one
should consult the source code and the comments therein. In this
manual we can give only a brief description of the main ideas
incorporated into the package CALI. We concentrate on the data
structure design and the description of the more advanced algorithms.
For sample computations from several fields of commutative algebra
the reader may consult also the {\em cali.tst} file.
\medskip

As main topics CALI contains facilities for
\begin{itemize}
\item defining rings, ideals and modules,

\item computing \gr bases and local standard bases,

\item computing syzygies, resolutions and (graded) Betti numbers,

\item computing (now also weighted) Hilbert series, multiplicities,
independent sets, and dimensions,

\item computing normal forms and representations,

\item computing sums, products, intersections, quotients, stable
quotients, elimination ideals etc.,

\item primality tests, computation of radicals, unmixed radicals,
equidimensional parts, primary decompositions etc. of ideals and
modules,

\item advanced applications of \gr bases (blowup, associated graded
ring, analytic spread, symmetric algebra, monomial curves etc.),

\item applications of linear algebra techniques to zero dimensional
	ideals, as e.g.\ the FGLM change of term orders, border bases
	and affine and projective ideals of sets of points,

\item splitting polynomial systems of equations mixing factorization and
the \gr algorithm, triangular systems, and different versions of the
extended \gr factorizer. 

\end{itemize}

Below we will use freely without further explanation the notions
common for text books and papers about constructive commutative
algebra, assuming the reader to be familiar with the corresponding
ideas and concepts. For further references see e.g.\ the text books
\cite{BKW}, \cite{CLO} and \cite{Mishra} or the survey papers
\cite{B1}, \cite{B2} and \cite{Ro}. 

\subsection{Description of the Documents Distributed with CALI}

The CALI package contains the following files:
\begin{quote}
cali.chg

\pbx{a detailed report of changes from v.\ 2.1 to v.\ 2.2. and 2.2.1}

cali.log

\pbx{the output file, that cali.tst should produce with
\begin{quote} \tt
load\_package cali;

out "logfile"\$

in "cali.tst";

shut "logfile"\$
\end{quote}}

cali.red

\pbx{the CALI source file.}

cali.tex

\pbx{this manual.}

cali.tst

\pbx{a test file with various examples and applications of CALI.}

\end{quote}

CALI should be precompiled as usual, i.e.\ either using the {\em
makefasl} utility of REDUCE or ``by hand'' via
\begin{verbatim}
    faslout "cali"$
    in "cali.red"$
    faslend$
\end{verbatim}
and then loaded via
\begin{verbatim}
    load_package cali;
\end{verbatim}
Upon successful loading CALI responds with a message containing the
version number and the last update of the distribution. 

\begin{center}
\fbox{\parbox{12cm}{Feel free to contact me by email if You have
problems to get CALI started. Also comments, hints, bug reports etc.
are welcome.}}
\end{center}

\subsection{CALI's Language Concept}

From a certain point of view one of the major disadvantage of the
current RLISP (and the underlying PSL) language is the fact
that it supports modularity and data encapsulation only in a
rudimentary way.  Since all parts of code loaded into a session are
visible all the time, name conflicts between different packages may
occur, will occur (even not issuing a warning message), and are hard
to prevent, since packages are developed (and are still developing)
by different research groups at different places and different time.

A (yet rudimentary) concept of REDUCE packages and modules indicates the
direction into what the REDUCE designers are looking for a solution
for this general problem.
\medskip

CALI (2.0 and higher) follows a name concept for internal procedures
to mimick data encapsulation at a semantical level. We hope this way
on the one hand to resolve the conflicts described above at least for
the internal part of CALI and on the other hand to anticipate a
desirable future and already foregoing development of REDUCE towards
a true modularity.

The package CALI is divided into several modules, each of them
introducing either a single new data type together with basic
facilities, constructors, and selectors or a collection of algorithms
subject to a common problem. Each module contains \ind{internal
procedures}, conceptually hidden by this module, \ind{local
procedures}, designed for a CALI wide use, and \ind{global
procedures}, exported by CALI into the general (algebraic or
symbolic) environment of REDUCE. A header \ind{module cali} contains
all (fluid) global variables and switches defined by the pacakge
CALI.

Along these lines the CALI procedures available in symbolic mode are
divided into three types with the following naming convention:
\begin{quote}
\verb|module!=procedure| 

\pbx{internal to the given module.}

\verb|module_procedure| 

\pbx{exported by the given module into the local CALI environment.} 

\verb|procedure!*| 

\pbx{a global procedure usually having a semantically equivalent
procedure (possibly with another parameter list) without trailing
asterisk in algebraic mode.} 
\end{quote} 
There are also symbolic mode equivalents without trailing asterisk, if
the algebraic procedure is not a {\em psopfn}, but a {\em symbolic
operator}. They transfer data to CALI's internal structure and call
the corresponding procedure with trailing asterisk. CALI 2.2 
distinguishes between algebraic and symbolic calls of such a
procedure. In symbolic mode such a procedure calls the corresponding
procedure with trailing asterisk directly without data transfer. 
\medskip

CALI 2.2 follows also a more concise concept for global
variables. There are three types of them: 
\begin{quote} 
True {\em fluid} global variables,

\pbx{that are part of the current data structure, as e.g.\ the current 
base ring and the degree vector. They are often locally rebound to be
restored after interrupts.} 

Global variables, stored on the property list of the package name {\tt
cali}, 

\pbx{that reflect the state of the computational model as e.g.\ the
trace level, the output print level or the chosen version of the \gr
basis algorithm. There are several such parameters in the module
\ind{dualbases} to serve the common dual basis driver with
information for different applications.} 

{\em Switches,}

\pbx{that allow to choose different branches of algorithms. Note that
this concept interferes with the second one. Different {\em versions}
of algorithms, that apply different functions in a common driver, are
{\em not} implemented through switches.} 
\end{quote} 

\subsection{New and Improved Facilities in v.\ 2.1}

The major changes in v.\ 2.1 reflect the experience we've got from the
use of CALI 2.0. The following changes are worth mentioning
explicitely:
\begin{enumerate}
\item The algebraic rule concept was adapted to CALI. It allows to
supply rule based coefficient domains. This is a more efficient way
to deal with (easy) algebraic numbers than through the {\em arnum
package}.

\item \ind{listtest} and \ind{listminimize} provide an unified
concept for different list operations previously scattered in the
source text.

\item There are several new quotient algorithms at the symbolic level
(both the general element and the intersection approaches are
available) and new features for the computation of equidimensional
hull and equidimensional radical.

\item A new \ind{module scripts} offers advanced applications of \gr
bases.

\item Several advanced procedures initialize a \gr basis computation
over a certain intermediate base ring or term order as e.g.\
\ind{eliminate}, \ind{resolve}, \ind{matintersect} or all
\ind{primary decomposition} procedures. Interrupting a computation in
v.\ 2.1 now restores the original values of CALI's global variables,
since all intermediate procedures work with local copies of 
the global variables.\footnote{Note that recovering the base
ring this way may cause some trouble since the intermediate ring,
installed with \ind{setring}, changed possibly the internal variable
order set by {\em setkorder}.} This doesn't apply to advanced
procedures that change the current base ring as e.g.\ \ind{blowup},
\ind{preimage}, \ind{sym} etc.

\end{enumerate}

\subsection{New and Improved Facilities in v.\ 2.2}

Version 2.2 (beside bug fixes) incorporates several new facilities of
constructive non linear algebra that we investigated the last two
years, as e.g.\ dual bases, the \gr factorizer, triangular systems, and
local standard bases. Essential changes concern the following topics:
\begin{enumerate}
\item The CALI modules \ind{red} and \ind{groeb} were rewritten and
the \ind{module mora} was removed. This is  
due to new theoretical insight into standard bases theory as
e.g.\ described in \cite{tcah} or \cite{ala}. The \gr basis algorithm
is reorganized as a \gr driver with simplifier and base lists, that
involves different versions of polynomial reduction according to the
setting via \ind{gbtestversion}. It applies now to
both noetherian and non noetherian term orders in a unified way.

The switches \ind{binomial} and \ind{lazy} were removed.

\item The \gr factorizer was thoroughly revised, extended along the
lines explained in \cite{fgb}, and collected into a separate
\ind{module groebf}. It now allows a list of constraints also in
algebraic mode. Two versions of an \ind{extended \gr factorizer}
produce \ind{triangular systems}, 
i.e.\ a decomposition into quasi prime components, see \cite{efgb},
that are well suited for further (numerical) evaluation. There is also
a version of the \gr factorizer that allows a list of problems as
input. This is especially useful, if a system is splitted with respect
to a ``cheap'' (e.g. degrevlex) term order and the pieces are
recomputed with respect to a ``hard'' (e.g. pure lex) term order.

The extended \gr factorizer involves, after change to dimension zero,
the computation of \ind{triangular systems}. The corresponding module
\ind{triang} extends the facilities for zero dimensional ideals and
modules in the \ind{module odim}.

\item A new \ind{module lf} implements the \ind{dual bases} approach
as described in \cite{MMM}. On this basis there are new
implementations of \ind{affine\_points} and \ind{proj\_points}, that
are significantly faster than the old ones. The linear algebra
\ind{change of term orders} \cite{FGLM} is available, too. There are
two versions, one with precomputed \ind{border basis}, the other with
conventional normal forms.  

\item \ind{dpmat}s now have a \ind{gb-tag} that indicates, whether the
given ideal or module basis is already a \gr basis. This avoids
certain \gr basis recomputations especially during advanced algorithms
as e.g.\ prime decomposition. In the algebraic interface \gr bases are
computed automatically when needed rather than to issue an error
message as in v.\ 2.1. So one can call \ind{modequalp} or \ind{dim}
etc. not having computed \gr bases in advance. Note that such
automatic computation can be avoided with \ind{setgbasis}. 

\item Hilbert series are now \ind{weighted Hilbert series}, since
e.g.\ for blow up rings the generating ideal is multigraded. Usual
Hilbert series are computed as in v.\ 2.1 with respect to the
\ind{ecart vector}. Weighted Hilbert series accept a list of (integer)
weight lists as second parameter.

\item There are some name and conceptual changes to existing
procedures and variables to have a more concise semantic concept. This
concerns 
\begin{quote}
\ind{tracing} (the trace parameter is now stored on the property list
of {\tt cali} and should be set with \ind{setcalitrace}), 

choosing different versions of the \gr algorithm (through
\ind{gbtestversion}) and the Hilbert series computation (through
\ind{hftestversion}), 

some names (\ind{mat2list} replaced \ind{flatten}, \ind{HilbertSeries}
replaced {\em hilbseries}) and

parameter lists of some local and internal procedures (consult {\em
cali.chg} for details).
\end{quote}

\item The \ind{revlex term order} is now the reverse lexicographic
term order on the {\bf reversely} ordered variables. This is consistent
with other computer algebra systems (e.g.\ SINGULAR or
AXIOM)\footnote{But different to the currently distibuted {\tt 
groebner} package in REDUCE. Note that the computations in
\cite{fgb} were done {\em before} these changes.} and implies the same
order on the variables for deglex and degrevlex term orders (this was
the main reason to change the definition).  

\item Ideals of minors, pfaffians and related stuff are now
implemented as extension of the internal {\tt matrix} package and
collected into a separate \ind{module calimat}. Thus they allow more
general expressions, especially with variable exponents, as general
REDUCE matrices do. So one can define generic ideals as e.g.\ ideals
of minors or pfaffians of matrices, containing generic expressions as
elements. They must be specified for further use in CALI substituting
general exponents by integers. 

\end{enumerate}

\subsection{New and Improved Facilities in v.\ 2.2.1\label{221}}

The main change concerns the primary decomposition algorithm, where I
fixed a serious bug for deciding, which embedded primes are really
embedded\footnote{That there must be a bug was pointed out to me by
Shimoyama Takeshi who compared different p.d.\ implementations. The
bug is due to an incorrect test for embedded primes: A (superfluous)
primary component may contain none of the isolated primary components,
but their intersection! Note that neither \cite{GTZ} nor \cite{BKW}
comment on that. Details of the implementation will appear in
\cite{primary}.}. During that remake I incorporated also the \gr
factorizer to compute isolated primes. Since REDUCE has no
multivariate {\em modular} factorizer, the switch \ind{factorprimes}
may be turned off to switch to the former algorithm.



Some minor bugs are fixed, too, e.g.\ the bug that made \ind{radical}
crashing. 




\section{The Computational Model}

This section gives a short introduction into the data type design of
CALI at different levels. First (\S 1 and 2) we describe CALI's way
of algorithmic translation of the abstract algebraic objects {\em
ring of polynomials, ideal} and (finitely generated) {\em module}.
Then (\S 3 and 4) we describe the algebraic mode interface of CALI
and the switches and global variables to drive a session. In the next
chapter we give a more detailed overview of the basic (symbolic mode) data
structures involved with CALI. We refer to the appendix for a short
summary of the commands available in algebraic mode.

\subsection{The Base Ring}

A polynomial ring consists in CALI of the following data:
\begin{quote}
a list of variable names 

\pbx{All variables not occuring in the list of ring names are treated
as parameters. Computations are executed denominatorfree, but the
results are valid only over the corresponding parameter {\em field}
extension.}

a term order and a term order tag

\pbx{They describe the way in which the terms in each polynomial (and
polynomial vector) are ordered.}

an ecart vector

\pbx{A list of positive integers corresponding to the variable
names.}
\end{quote}

A \ind{base ring} may be defined (in algebraic mode) through the
command 
\begin{verbatim}
 setring 
\end{verbatim}
with $$ ::= \{\, vars,\,tord,\,tag\,[,\,ecart\,]\,\} resp.
\begin{verbatim}
 setring(vars, tord, tag [,ecart])
\end{verbatim}
\index{setring}
This sets the global (symbolic) variable \ind{cali!=basering}. Here
{\tt vars} is the list of variable names, {\tt tord} a (possibly
empty) list of weight lists, the \ind{degree vectors}, and {\tt tag}
the tag LEX or REVLEX. Optionally one can supply {\tt ecart}, a list 
of positive integers of the same length as {\tt vars}, to set an ecart
vector different from the default one (see below).

The degree vectors must have the same length as {\tt vars}. If $(w_1\
\ldots\ w_k)$ is the list of degree vectors then 
\[x^aj\ :\ a_i=b_i\quad\mbox{and}\quad a_j>b_j\
\mbox{(revlex.)}\]

Every term order can be represented in such a way, see \cite{MR88}.

During the ring setting the term order will be checked to be
Noetherian (i.e.\ to fulfill the descending chain condition) provided
the \ind{switch Noetherian} is on (the default). The same applies
turning {\em noetherian on}: If the term order of the underlying
base ring isn't Noetherian the switch can't be turned over. Hence,
starting from a non Noetherian term order, one should define {\em
first} a new ring and {\em then} turn the switch on. 

Useful term orders can be defined by the procedures
\begin{quote}
\verb|degreeorder vars|, \index{degreeorder}

\pbx{that returns $tord=\{\{1,\ldots ,1\}\}$.}

\verb|localorder vars|, \index{localorder}

\pbx{that returns $tord=\{\{-1,\ldots ,-1\}\}$ (a non Noetherian term
order for computations in local rings).}

\verb|eliminationorder(vars,elimvars)|, \index{eliminationorder}

\pbx{that returns a term order for elimination of the variables in
{\tt elimvars}, a subset of all {\tt vars}. It's recommended to
combine it with the tag REVLEX.}

\verb|blockorder(vars,integerlist)|, \index{blockorder}

\pbx{that returns the list of degree vectors for the block order with
block lengths given in the {\tt integerlist}. Note that these numbers
should sum up to the length of the variable list supplied as the first
argument.}
\end{quote}

\noindent Examples:
\begin{verbatim}
vars:={x,y,z};
tord:=degreeorder vars;   % Returns {{1,1,1}}.
setring(vars,tord,lex);   % GRADLEX in the groebner package.

% or

setring({a,b,c,d},{},lex); % LEX in the groebner package.

% or

vars:={a,b,c,x,y,z};
tord:=eliminationorder(vars,{x,y,z});
tord:=reverse blockorder(vars,{3,3});
                          % Return both {{0,0,0,1,1,1},{1,1,1,0,0,0}}.
setring(vars,tord,revlex);                          
\end{verbatim}
\pagebreak[2]

The base ring is initialized with \\[10pt]
\verb|{{t,x,y,z},{{1,1,1,1}},revlex,{1,1,1,1}}|,\\[10pt]
i.e.\ $S=k[t,x,y,z]$ supplied with the degree wise reverse
lexicographic term order.
\begin{quote}
\verb|getring m|\index{getring} 

\pbx{returns the ring attached to the object with the identifier
$m$. E.g.\ }  

\verb|setring getring m|

\pbx{(re)sets the base ring to the base ring of the formerly defined
object (ideal or module) $m$.}

\verb|getring()|

\pbx{returns the currently active base ring.}
\end{quote}

CALI defines also an \ind{ecart vector}, attaching to each variable a
positive weight with respect to that homogenizations and related
algorithms are executed. It may be set optionally by the user during
the \ind{setring} command.  (Default: If the term order is a
(positive) degree order then the ecart is the first degree vector,
otherwise each ecart equals 1).

The ecart vector is used in several places for efficiency reason (\gr
basis computation with the sugar strategy) or for termination (local
standard bases). If the input is homogeneous the ecart vector should
reflect this homogeneity rather than the first degree vector to
obtain the best possible performance. For a discussion of local
computations with encoupled ecart vector see \cite{tcah}. In general
the ecart vector is recommended to be chosen in such a way that the
input examples become close to be homogeneous. {\em Homogenizations}
and \ind{Hilbert series} are computed with respect to this ecart
vector.
\medskip

\noindent \verb|getecart()|\index{getecart} returns the ecart vector
currently set.


\subsection{Ideals and Modules}

If $S=k[x_v,\ v \in H]$ is a polynomial ring, a matrix $M$ of size
$r\times c$ defines a map
\[f\ :\ S^r \longrightarrow S^c\]
by the following rule
\[ f(v):=v\cdot M \qquad \mbox{ for } v \in S^r.\]
There are two modules, connected with such a map, $im\ f$, the
submodule of $S^c$ generated by the rows of $M$, and $coker\ f\
(=S^c/im\ f)$. Conceptually we will identify $M$ with $im\ f$ for the
basic algebra, and with $coker\ f$ for more advanced topics of
commutative algebra (Hilbert series, dimension, resolution etc.)
following widely accepted conventions.

With respect to a fixed basis $\{e_1,\ldots ,e_c\}$ one can define
module term orders on $S^c$, \gr bases of submodules of $S^c$ etc.
They generalize the corresponding notions for ideal bases. See
\cite{E} or \cite{MM} for a detailed introduction to this area of
computational commutative algebra. This allows to define joint
facilities for both ideals and submodules of free modules. Moreover
computing syzygies the latter come in in a natural way.

CALI handles ideal and module bases in a unique way representing them
as rows of a \ind{dpmat} ({\bf d}istributive {\bf p}olynomial {\bf
mat}rix). It attaches to each unit vector $e_i$ a monomial $x^{a_i}$,
the $i$-th \ind{column degree} and represents the rows of a dpmat $M$
as lists of module terms $x^ae_i$, sorted with respect to a
\ind{module term order}, that may be roughly\footnote{The correct
definition is even more difficult.} described as 
\bigskip

\begin{tabular}{cccp{6cm}}
$x^ae_ij$ (revlex.)\\}
\end{tabular}

Every dpmat $M$ has its own column degrees (no default !).  They are
managed through a global (symbolic) variable \ind{cali!=degrees}.
\begin{quote}
\verb|getdegrees m| \index{getdegrees}

\pbx{returns the column degrees of the object with identifier m.}

\verb|getdegrees()| 

\pbx{returns the current setting of {\em cali!=degrees}.}

\verb|setdegrees | \index{setdegrees} 

\pbx{sets {\em cali!=degrees} correspondingly. Use this command
before executing {\em setmodule} to give a dpmat prescribed column
degrees since cali!=degrees has no default value and changes during
computations. A good guess is to supply the empty list (i.e.\ all
column degrees are equal to $\x^0$). Be careful defining modules
without prescribed column degrees.}
\end{quote}

To distinguish between \ind{ideals} and \ind{modules} the former are
represented as a \ind{dpmat} with $c=0$ (and hence without column
degrees).  If $I \subset S$ is such an ideal one has to distinguish
between the ideal $I$ (with $c=0$, allowing special ideal operations
as e.g.\ ideal multiplication) and the submodule $I$ of the free
one dimensional module $S^1$ (with $c=1$, allowing matrix operations
as e.g.\  transposition, matrix multiplication etc.). \ind{ideal2mat}
converts an (algebraic) list of polynomials into an (algebraic)
matrix column whereas \ind{mat2list} collects all matrix entries into
a list.

\subsection{The Algebraic Mode Interface}

Corresponding to CALI's general philosophy explained in the
introduction the algebraic mode interface translates algebraic input
into CALI's internal data representation, calls the corresponding
symbolic functions, and retranslates the result back into algebraic
mode. Since \gr basis computations may be very tedious even on small
examples, one should find a well balance between the storage of
results computed earlier and the unavoidable time overhead and memory
request associated with the management of these results.

Therefore CALI distinguishes between {\em free} and {\em bounded}
\index{free identifier}\index{bounded identifier} identifiers. Free
identifiers stand only for their value whereas to bounded identifiers
several internal information is attached to their property list for
later use.
\medskip

After the initialization of the {\em base ring} bounded identifiers
for ideals or modules should be declared via
\begin{verbatim}
setmodule(name,matrix value)
\end{verbatim}
resp.
\begin{verbatim}
setideal(name,list of polynomials)
\end{verbatim}
\index{setmodule}\index{setideal} 
This way the corresponding internal representation (as \ind{dpmat})
is attached to {\tt name} as the property \ind{basis}, the prefix
form as its value and the current base ring as the property
\ind{ring}.

Performing any algebraic operation on objects defined this way their
ring will be compared with the current base ring (including the term
order). If they are different an error message occurs. If {\tt m} is
a valid name, after resetting the base ring
\begin{verbatim}
setmodule(m1,m)
\end{verbatim}
reevaluates {\tt m} with respect to the new base ring (since the
{\em value} of {\tt m} is its prefix form) and assigns the reordered
dpmat to {\tt m1} clearing all information previously computed for
{\tt m1} ({\tt m1} and {\tt m} may coincide).

All computations are performed with respect to the ring $S=k[x_v\in
{\tt vars}]$ over the field $k$. Nevertheless by efficiency reasons
\ind{base coefficients} are represented in a denominator free way as
standard forms. Hence the computational properties of the base
coefficient domain depend on the \ind{dmode} and also on auxiliary
variables, contained in the expressions, but not in the variable
list. They are assumed to be parameters. 

Best performance will be obtained with integer or modular domain
modes, but one can also try \ind{algebraic numbers} as coefficients
as e.g.\ generated by {\tt sqrt} or the {\tt arnum} package. To avoid
an unnecessary slow-down connected with the management of simplified
algebraic expressions there is a \ind{switch hardzerotest} (default:
off) that may be turned on to force an additional simplification of
algebraic coefficients during each zero test. It should be turned on
only for domain modes without canonical representations as e.g.\
mixtures of arnums and square roots. We remind the general zero
decision problem for such domains. 

Alternatively, CALI offers the possibility to define a set of
algebraic substitution rules that will affect CALI's base coefficient
arithmetic only. 
\begin{quote}
\verb|setrules |\index{setrules}

\pbx{transfers the (algebraic) rule list into the internal
representation stored at the {\tt cali} value {\tt rules}.

In particular, {\tt setrules \{\}} clears the rules previously set.} 

\verb|getrules()|\index{getrules}

\pbx{returns the internal CALI rules list in algebraic form.}
\end{quote}

We recommend to use \ind{setrules} for computations with algebraic 
numbers since they are better adapted to the data structure of CALI 
than the algebraic numbers provided by the {\tt arnum} package. 
Note, that due to the zero decision problem
complicated {\em setrules} based computations may produce wrong
results if base coefficient's pseudo division is involved (as e.g.\
with \ind{dp\_pseudodivmod}). In this case we recommend to enlarge
the variable set and add the defining equations of the algebraic
numbers to the equations of the problem\footnote{A {\em qring}
facility for the computation over quotient rings will be incorporated
into future versions.}.
\medskip

The standard domain (Integer) doesn't allow denominators for input.
\ind{setideal} clears automatically the common denominator of each
input expression whereas a polynomial matrix with true rational
coefficients will be rejected by \ind{setmodule}.
\medskip

One can save/initialize ideal and module bases together with their
accompanying data (base ring, degrees) to/from a file:
\begin{verbatim}
savemat(m,name)
\end{verbatim}
resp.
\begin{verbatim}
initmat name
\end{verbatim} execute the file transfer from/to disk files with the
specified file {\tt name}. e.g.\
\begin{verbatim}
savemat(m,"myfile");
\end{verbatim}
saves the base ring and the ideal basis of $m$ to the file ``myfile''
whereas
\begin{verbatim}
setideal(m,initmat "myfile");
\end{verbatim}
sets the current base ring (via a call to \ind{setring}) to the base
ring of $m$ saved at ``myfile'' and then recovers the basis of $m$
from the same file.

\subsection{Switches and Global Variables}

There are several switches, (fluid) global variables, a trace
facility, and global parameters on the property list of the package
name {\tt cali} to control CALI's computations. 
\medskip

\subsubsection*{Switches}

\begin{quote}
\ind{bcsimp}

\pbx{on: Cancel out gcd's of base coefficients. (Default: on)}

\ind{detectunits}

\pbx{on: replace polynomials of the form \newline 
$\langle monomial\rangle * 
\langle polynomial\ unit\rangle $ by $\langle monomial\rangle$ 
during interreductions and standard basis computations.

Affects only local computations. (Default: off)}

\ind{factorprimes}

\pbx{on: Invoke the \gr factorizer during computation of isolated
primes. (Default: on). Note that REDUCE lacks a modular multivariate
factorizer, hence for modular prime decomposition computations this
switch has to be turned off.}

\ind{factorunits}

\pbx{on: factor polynomials and remove polynomial unit factors
during interreductions and standard basis computations.

Affects only local computations. (Default: off)}

\ind{hardzerotest}

\pbx{on: try an additional algebraic simplification of base
coefficients at each base coefficient's zero test. Useful only for
advanced base coefficient domains without canonical REDUCE
representation. May slow down the computation drastically.
(Default: off)}

\ind{lexefgb}

\pbx{on: Use the pure lexicographic term order and \ind{zerosolve}
during reduction to dimension zero in the \ind{extended \gr
factorizer}. This is a single, but possibly hard task compared to the
degrevlex invocation of \ind{zerosolve1}. See \cite{efgb} for a
discussion of different zero dimensional solver strategies. 
(Default: off)} 

\ind{Noetherian}

\pbx{on: choose algorithms for Noetherian term orders.

off: choose algorithms for local term orders. 

(Default: on)}

\ind{red\_total}

\pbx{on: compute total normal forms, i.e. apply reduction (Noetherian
term orders) or reduction with bounded ecart (non Noetherian term
orders to tail terms of polynomials, too. 

off: Do only top reduction.

(Default: on)}

\end{quote}

\subsubsection*{Tracing}

Different to v.\ 2.1 now intermediate output during the computations
is controlled by the value of the {\tt trace} and {\tt printterms}
entries on the property list of the package name {\tt cali}. The
former value controls the intensity of the intermediate output
(Default: 0, no tracing), the latter the number of terms printed in
such intermediate polynomials (Default: all).
\begin{quote}
\verb|setcalitrace |\index{setcalitrace}

\pbx{changes the trace intensity. Set $n=2$ for a sparse tracing (a
dot for each reduction step). 
Other good suggestions are the values 30 or 40 for tracing the \gr
algorithm or $n>70$ for tracing the normal form algorithm. The higher
$n$ the more intermediate information will be given.}

\verb|setcaliprintterms |\index{setcaliprintterms}

\pbx{sets the number of terms that are printed in intermediate
polynomials. Note that this does not affect the output of whole {\em
dpmats}. The output of polynomials with more than $n$ terms ($n>0$)
breaks off and continues with ellipses.}

\verb|clearcaliprintterms()|\index{clearcaliprintterms}

\pbx{clears the {\tt printterms} value forcing full intermediate
output (according to the current trace level).} 
\end{quote}

\subsubsection*{Global Variables}

\begin{quote}
\ind{cali!=basering}

\pbx{The currently active base ring initialized e.g.\ by
\ind{setring}.}

\ind{cali!=degrees}

\pbx{The currently active module component degrees initialized e.g.\
by \ind{setdegrees}.}

\ind{cali!=monset}

\pbx{A list of variable names considered as non zero divisors during
\gr basis computations initialized e.g.\ by \ind{setmonset}. Useful
e.g.\ for binomial ideals defining monomial varieties or other prime
ideals.}

\end{quote}

\subsubsection*{Entries on the Property List of {\tt cali}}

This approach is new for v.\ 2.2. Information concerning the state of
the computational model as e.g.\ trace intensity, base coefficient
rules, or algorithm versions are stored as values on the property list
of the package name \ind{cali}. This concerns
\begin{quote}
\ind{trace} and \ind{printterms}

\pbx{see above.}

\ind{efgb}

\pbx{Changed by the \ind{switch lexefgb}.}

\ind{groeb!=rf}

\pbx{Reduction function invoked during the \gr algorithm. It can be
changed with \ind{gbtestversion}\ $$ ($n=1,2,3$, default is 1).}

\ind{hf!=hf}

\pbx{Variant for the computation of the Hilbert series numerator. It
can be changed with \ind{hftestversion}\ $$ ($n=1,2$, default is 1).}

\ind{rules}

\pbx{Algebraic ``replaceby'' rules introduced to CALI with the
\ind{setrules} command.}

\ind{evlf}, \ind{varlessp}, \ind{sublist}, \ind{varnames},
\ind{oldborderbasis}, \ind{oldring}, \ind{oldbasis} 

\pbx{see \ind{module lf}, implementing the dual bases approach.}
\end{quote}


\section{Basic Data Structures}

In the following we describe the data structure layers underlying the 
dpmat representation in CALI and some important (symbolic) procedures
to handle them. We refer to the source code and the comments therein for
a more complete survey about the procedures available for different
data types.

\subsection{The Coefficient Domain}

Base coefficients as implemented in the \ind{module bcsf} are standard
forms in the variables outside the variable list of the current
ring. All computations are executed "denominator free" over the
corresponding quotient field, i.e.\ gcd's are canceled out without 
request. To avoid this set the \ind{switch bcsimp} off.\footnote{This
induces a rapid base coefficient's growth and doesn't yield {\bf
Z}-\gr bases in the sense of \cite{GTZ} since the S-pair criteria are
different.} In the given implementation we use the s.f. procedure {\em
qremf} for effective divisibility test. We had some trouble with it
under {\em on factor}. 

Additionally it is possible to supply the
parameters occuring as base coefficients with a (global) set of
algebraic rules.\footnote{This is different from the LET rule
mechanism since they must be present in symbolic mode. Hence for a
simultaneous application of the same rules in algebraic mode outside
CALI they must additionally be declared in the usual way.}
\begin{quote}
\verb|setrules!* r|\index{setrules}

\pbx{converts an algebraic mode rules list $r$ as e.g.\ used in
WHERE statements into the internal CALI format.}
\end{quote}

\subsection{The Base Ring}

The \ind{base ring} is defined by its {\tt name list}, the {\tt
degree matrix} (a list of lists of integers), the {\tt ring tag} (LEX
or REVLEX), and the {\tt ecart}. The name list contains a phantom
name {\tt cali!=mk} for the module component at place 0.
\medskip

The \ind{module ring} exports among others the selectors
\ind{ring\_names}, \ind{ring\_degrees}, \ind{ring\_tag},
\ind{ring\_ecart}, the test function \ind{ring\_isnoetherian} and the
transfer procedures from/to an (appropriate, printable by
\ind{mathprint}) algebraic prefix form \ind{ring\_from\_a} (including
extensive tests of the supplied parameters for consistency) and
\ind{ring\_2a}. 

The following procedures allow to define a base ring:
\begin{quote}
\verb|ring_define(name list, degree matrix, ring tag, ecart)|
\index{ring\_define}

\pbx{combines the given parameters to a ring.}

\verb|setring!*  |\index{setring}

\pbx{sets {\em cali!=basering} and checks for consistency with the
\ind{switch Noetherian}. It also sets through 
\ind{setkorder} the current variable list as main variables. It is
strongly recommended to use {\em setring!* \ldots} instead of {\em
cali!=basering:=\ldots}.}
\end{quote}
\verb|degreeorder!*| , \verb|localorder!*|, \verb|eliminationorder!*|, and
\verb|blockorder!*|
\index{degreeorder} 
\index{localorder} 
\index{eliminationorder} 
\index{blockorder} 
define term order matrices in full analogy to algebraic mode.
\medskip

There are three ring constructors for special purposes:
\begin{quote}
\verb|ring_sum(a,b)|\index{ring\_sum}

\pbx{returns a ring, that is constructed in the following way: Its
variable list is the union of the (disjoint) lists of the variables
of the rings $a$ and $b$ (in this order) whereas the degree list is
the union of the (appropriately shifted) degree lists of $b$ and $a$
(in this order). The ring tag is that of $a$. Hence it returns
(essentially) the ring $b\bigoplus a$ if $b$ has a degree part (e.g.\
useful for elimination problems, introducing ``big'' new variables) 
and the ring $a\bigoplus b$ if $b$ has no degree part (introducing 
``small'' new variables).}

\verb|ring_rlp(r,u)|\index{ring\_rlp}

\pbx{$u$ is a subset of the names of the ring $r$. Returns the ring
$r$, but with a term order ``first degrevlex on $u$, then the order on
r''.} 

\verb|ring_lp(r,u)|\index{ring\_lp}

\pbx{As $rlp$, but with a term order ``first lex on $u$, then the
order on r''.}  
\end{quote}

\noindent Example:
\begin{verbatim}
vars:='(x y z)
setring!* ring_define(vars,degreeorder!* vars,'lex,'(1 1 1));   
                        % GRADLEX in the groebner package.
\end{verbatim}

\subsection{Monomials}

The current version uses a place-driven exponent representation
closely related to a vector model. This model handles term orders  on $S$
and module term orders on $S^c$ in a unique way. The zero component of the
exponent list of a monomial contains its module component ($>0$) or 0
(ring element). All computations are executed with respect to a
{\em current ring} (\ind{cali!=basering}) and {\em current (monomial)
weights} of the free generators $e_i, i=1,\ldots,c$, of $S^c$ 
(\ind{cali!=degrees}). For efficiency reasons every monomial has a
precomputed degree part that should be reevaluated if {\tt
cali!=basering} (i.e.\ the term order) or {\tt cali!=degrees} were
changed. {\tt cali!=degrees} contains the list of column degrees of
the current module as an assoc. list and will be set automatically by
(almost) all dpmat procedure calls. Since monomial operations use the
degree list that was precomputed with respect to fixed column degrees
(and base ring) 
\begin{quote}\bf
watch carefully for {\tt cali!=degrees} programming at the monomial 
or dpoly level !
\end{quote}

As procedures there are selectors for the module component, the exponent and
the degree parts, comparison procedures, procedures for the management of
the module component and the degree vector, monomial arithmetic, transfer 
from/to prefix form, and more special tools.  

\subsection{Polynomials and Polynomial Vectors}

CALI uses a distributive representation as a list of terms for both
polynomials and polynomial vectors, where a \ind{term} is a dotted
pair
\[(\ .\ ).\] 
The \ind{ecart} of a polynomial (vector) $f=\sum{t_i}$ with (module)
terms $t_i$ is defined as \[max(ec(t_i))-ec(lt(t_i)),\] see
\cite{tcah}. Here $ec(t_i)$ denotes the ecart of the term $t_i$, i.e.\
the scalar product of the exponent vector of $t_i$ (including the
monomial weight of the module generator) with the ecart vector of the
current base ring.

As procedures there are selectors, dpoly arithmetic including the management
of the module component, procedures for reordering (and reevaluating)
polynomials wrt.\ new term order degrees, for extracting common base
coefficient or monomial factors, for transfer from/to prefix form and for
homogenization and dehomogenization (wrt.\ the current ecart vector).

Two advanced procedures use ideal theory ingredients:
\begin{quote}
\verb|dp_pseudodivmod(g,f)|\index{dp\_pseudodivmod}

\pbx{returns a dpoly list $\{q,r,z\}$ such that $z\cdot g = q\cdot f +
r$ and $z$ is a dpoly unit (i.e.\ a scalar for Noetherian term
orders). For non Noetherian term orders the necessary modifications
are described in \cite{ala}. 

$g, f$ and $r$ belong to the same free module or ideal.
}

\verb|dpgcd(a,b)| \index{dpgcd}

\pbx{computes the gcd of two dpolys $a$ and $b$ by the syzygy method:
The syzygy module of $\{a,b\}$ is generated by a single element
$[-b_0\ \ a_0]$ with $a=ga_0, b=gb_0$, where $g$ is the gcd of $a$
and $b$. Since it uses dpoly pseudodivision it may work not properly
with \ind{setrules}.}
\end{quote}


\subsection{Base Lists}

Ideal bases are one of the main ingredients for dpmats. They are
represented as lists of \ind{base elements} and contain together with
each dpoly entry the following information:
\begin{itemize}
\item a number (the row number of the polynomial vector in the
corresponding dpmat).

\item the dpoly, its ecart (as the main sort criterion), and length. 

\item a representation part, that may contain a representation of the
given dpoly in terms of a certain fixed basis (default: empty).
\end{itemize}

The representation part is managed during normal form computations
and other row arithmetic of dpmats appropriately with the following
procedures: 
\begin{quote}
\verb|bas_setrelations b|\index{bas\_setrelations} 

\pbx{sets the relation part of the base element $i$ in the base list
$b$ to $e_i$.}

\verb|bas_removerelations b|\index{bas\_removerelations} 

\pbx{removes all relations, i.e.\ replaces them with the zero
polynomial vector.}

\verb|bas_getrelations b|\index{bas\_getrelations} 

\pbx{gets the relation part of $b$ as a separate base list.}
\end{quote}

Further there are procedures for selection and construction of base
elements and for the manipulation of lists of base elements as e.g.\
sorting, renumbering, reordering, simplification, deleting zero base
elements, transfer from/to prefix form, homogenization and dehomogenization. 

\subsection{Dpoly Matrices}

Ideals and matrices, represented as \ind{dpmat}s, are the central
data type of the CALI package, as already explained above. Every
dpmat $m$ combines the following information:
\begin{itemize}
\item its size (\ind{dpmat\_rows} m,\ind{dpmat\_cols} m),

\item its base list (\ind{dpmat\_list} m) and

\item its column degrees as an assoc. list of monomials
(\ind{dpmat\_coldegs} m). If this list is empty, all degrees are
assumed to be equal to $x^0$.

\item New in v.\ 2.2 there is a \ind{gb-tag} (\ind{dpmat\_gbtag} m),
indicating that the given base list is already a \gr basis (under the
given term order). 
\end{itemize}

The \ind{module dpmat} contains selectors, constructors, and the
algorithms for the basic management of this data structure as e.g.\
file transfer, transfer from/to algebraic prefix forms, reordering,
simplification, extracting row degrees and leading terms, dpmat matrix
arithmetic, homogenization and dehomogenization. 

The modules {\em matop} and {\em quot} collect more advanced procedures 
for the algebraic management of dpmats.

\subsection{Extending the REDUCE Matrix Package}

In v.\ 2.2 minors, Jacobian matrix, and Pfaffians are available for
general REDUCE matrices. They are collected in the \ind{module
calimat} and allow to define procedures in more generality, especially
allowing variable exponents in polynomial expressions. Such a
generalization is especially useful for the investigation of whole
classes of examples that may be obtained from a generic one by
specialization. In the following $m$ is a matrix given in algebraic
prefix form. 
\begin{quote}
\verb|matjac(m,l)|\index{matjac} 

\pbx{returns the Jacobian matrix of the ideal $m$ (given as an
algebraic mode list) with respect to the variable list $l$.} 

\verb|minors(m,k)|\index{minors} 

\pbx{returns the matrix of $k$-minors of the matrix $m$.}

\verb|ideal_of_minors(m,k)|\index{ideal\_of\_minors} 

\pbx{returns the ideal of the $k$-minors of the matrix $m$.}

\verb|pfaffian m|\index{pfaffian} 

\pbx{returns the pfaffian of a skewsymmetric matrix $m$.}

\verb|ideal_of_pfaffians(m,k)|\index{ideal\_of\_pfaffians} 

\pbx{returns the ideal of the $2k$-pfaffians of the skewsymmetric
matrix $m$.} 

\verb|random_linear_form(vars,bound)|\index{random\_linear\_form} 

\pbx{returns a random linear form in algebraic prefix form in the
supplied variables $vars$ with integer coefficients bounded by the
supplied $bound$.}  

\verb|singular_locus!*(m,c)|\index{singular\_locus} 

\pbx{returns the singular locus of $m$ (as dpmat). $m$ must be an
ideal of codimension $c$ given as a list of polynomials in prefix
form. {\tt Singular\_locus} computes the ideal generated by the
corresponding Jacobian and $m$ itself.}    
\end{quote}

\section{About the Algorithms Implemented in CALI}

Below we give a short explanation of the main algorithmic ideas of
CALI and the way they are implemented and may be accessed
(symbolically). 

\subsection{Normal Form Algorithms}

For v.\ 2.2 we completely revised the implementation of normal form
algorithms due to the insight obtained from our investigations of
normal form procedures for local term orders in \cite{ala} and
\cite{tcah}. It allows a common handling of Noetherian and non
Noetherian term orders already on this level thus making superfluous
the former duplication of reduction procedures in the modules {\em
red} and {\em mora} as in v.\ 2.1.
\medskip

Normal form algorithms reduce polynomials (or polynomial vectors)
with respect to a given finite set of generators of an ideal or
module. The result is not unique except for a total normal form with
respect to a \gr basis. Furthermore different reduction strategies
may yield significant differences in computing time.

CALI reduces by first matching, usually keeping base lists sorted
with respect to the sort predicate \ind{red\_better}. In v.\ 2.2 we
sort solely by the dpoly length, since the introduction of
\ind{red\_TopRedBE}, i.e.\ reduction with bounded ecart, guarantees
termination also for non Noetherian term orders. Overload red\_better
for other reduction strategies. 
\medskip

Reduction procedures produce for a given ideal basis $B\subset S$ and
a polynomial $f\in S$ a (pseudo) normal form $h\in S$ such that
$h\equiv u\cdot f\ mod\ B$ where $u\in S$ is a polynomial unit, i.e.\
a (polynomially represented) non zero domain element in the Noetherian
case (pseudodivision of $f$ by $B$) or a polynomial with a scalar as
leading term in the non Noetherian case. Following up the reduction
steps one can even produce a presentation of $h-u\cdot f$ as a
polynomial combination of the base elements in $B$.

More general, given for $f_i\in B$ and $f$ representations $f_i =
\sum{r_{ik}e_k} = R_i\cdot E^T$ and $f=R\cdot E^T$ as polynomial
combinations wrt.\ a fixed basis $E$ one can produce such a
presentation also for $h$. For this purpose the dpoly $f$ and its
representation are collected into a base element and reduced
simultaneously by the base list $B$, that collects the base elements
and their representations. 
\medskip

The main procedures of the newly designed reduction package are the
following: 
\begin{quote}
\verb|red_TopRedBE(bas,model)|\index{red\_TopRedBE}

\pbx{Top reduction with bounded ecart of the base element $model$ by
the base list $bas$, i.e.\ only reducing the top term and only with
base elements with ecart bounded by that of $model$.} 

\verb|red_TopRed(bas,model)|\index{red\_TopRed}

\pbx{Top reduction of $model$, but without restrictions.}

\verb|red_TailRed(bas,model)|\index{red\_TailRed}

\pbx{Make tail reduction on $model$, i.e.\ top reduction on the tail
terms. For convergence this uses reduction with bounded ecart for non
Noetherian term orders and full reduction otherwise.}
\medskip

There is a common \ind{red\_TailRedDriver} that takes a top reduction
function as parameter. It can be used for experiments with other top
reduction procedure combinations.

\verb|red_TotalRed(bas,model)|\index{red\_TotalRed}

\pbx{A terminating total reduction, i.e. for Noetherian term orders
the classical one and for local term orders using tail reduction with 
bounded ecart.} 

\verb|red_Straight bas|\index{red\_Straight}

\pbx{Reduce (with {\em red\_TailRed}) the tails of the polynomials in
the base list $bas$.}   

\verb|red_TopInterreduce bas|\index{red\_TopInterreduce}

\pbx{Reduces the base list $bas$ with $red\_TopRed$ until it
has pairwise incomparable leading terms, computes correct
representation parts, but does no tail reduction.}  

\verb|red_Interreduce bas|\index{red\_Interreduce}

\pbx{Does top and, if {\tt on red\_total}, also tail interreduction on
the base list $bas$.}  
\end{quote}

Usually, e.g.\ for ideal generation problems, there is no need to care
about the multiplier $u$. If nevertheless one needs its value, the
base element $f$ may be prepared with \ind{red\_prepare} to collect
this information in the 0-slot of its representation part. Extract
this information with \ind{red\_extract}.
\begin{quote}
\verb|red_redpol(bas,model)|\index{red\_redpol}

\pbx{combines this tool with a total reduction of the base element
$model$ and returns a dotted pair 

\centerline{$( . )$.}}   
\end{quote}

Advanced applications call the interfacing procedures
\begin{quote}
\verb|interreduce!* m|\index{interreduce}

\pbx{that returns an interreduced basis of the dpmat $m$.}

\verb|mod!*(f,m)|\index{mod}

\pbx{that returns the dotted pair $(h.u)$ where $h$ is the pseudo
normal form of the dpoly $f$ modulo the dpmat $m$ and $u$ the
corresponding polynomial unit multiplier.}

\verb|normalform!*(a,b)|\index{normalform}

\pbx{that returns $\{a_1,r,z\}$ with $a_1=z*a-r*b$ where the rows of
the dpmat $a_1$ are the normalforms of the rows of the dpmat $a$ with
respect to the dpmat $b$.} 
\end{quote}

For local standard bases the ideal generated by the basic polynomials
may have components not passing through the origin. Although they do
not contribute to the ideal in $Loc(S)=S_{\bf m}$ they usually heavily
increase the necessary computational effort. Hence for local term
orders one should try to remove polynomial units as soon as they 
are detected. To remove them from base elements in an early stage of
the computation one can either try the (cheap) test, whether $f\in S$
is of the form $\langle monomial\rangle *\langle polynomial\
unit\rangle$  or factor $f$ completely and remove polynomial unit
factors. For base elements this may be done with
\ind{bas\_detectunits} or \ind{bas\_factorunits}. 

Moreover there are two switches \ind{detectunits} and
\ind{factorunits}, both off by default, that force such automatic 
simplifications during more advanced computations.

The procedure \ind{deleteunits!*} tries explicitely to factor the
basis polynomials of a dpmat and to remove polynomial units occuring
as one of the factors. 

\subsection{The \gr and Standard Basis Algorithms}

There is now a unique \ind{module groeb} that contains the \gr
resp. standard basis algorithms with syzygy computation facility and
related topics. There are common procedures (working for both
Noetherian and non Noetherian term orders)
\begin{quote}
\verb|gbasis!* m|\index{gbasis}

\pbx{that returns a minimal \gr or standard basis of the dpmat $m$,}

\verb|syzygies!* m|\index{syzygies}

\pbx{that returns an interreduced basis of the first syzygy module of
the dpmat $m$ and}

\verb|syzygies1!* m|\index{syzygies1}

\pbx{that returns a (not yet interreduced) basis of the syzygy module
of the dpmat $m$.}
\end{quote}

These procedures start the outer \gr engine (now also common for both
Noetherian and non Noetherian term orders)
\begin{quote}
\verb|groeb_stbasis(m,mgb,ch,syz)|\index{groeb\_stbasis}
\end{quote}
that returns, applied to the dpmat $m$, three dpmats $g,c,s$ with
\begin{quote}
$g$ --- the minimal reduced \gr basis of $m$ if $mgb=t$,

$c$ --- the transition matrix $g=c\cdot m$ if $ch=t$, and

$s$ --- the (not yet interreduced) syzygy matrix of $m$ if $syz=t$.
\end{quote}

The next layer manages the preparation of the representation parts
of the base elements to carry the syzygy information, calls the
{\em general internal driver}, and extracts the relevant information
from the result of that computation. The general internal driver
branches according to different reduction functions into several
versions. Upto now there are three different strategies for the
reduction procedures for the S-polynomial reduction (different
versions may be chosen via \ind{gbtestversion}): 
\begin{enumerate} 
\item Total reduction with local simplifier lists. For local term
orders this is (almost) Mora's first version for the tangent cone (the
default). 
        
\item Total reduction with global simplifier list. For local term
orders this is (almost) Mora's SimpStBasis, see \cite{MPT}.

\item Total reduction with bounded ecart. 
\end{enumerate} 
The first two versions (almost) coincide for Noetherian term
orders. The third version reduces only with bounded ecart, thus
forcing more pairs to be treated than necessary, but usually less
expensive to be reduced. It is not yet well understood, whether this
idea is of practical importance. 

\ind{groeb\_lazystbasis} calls the lazy standard basis driver instead,
that implements Mora's lazy algorithm, see \cite{MPT}. As
\ind{groeb\_homstbasis}, the computation of \gr and standard bases via
homogenization (Lazard's approach), it is not fully integrated into
the algebraic interface. Use
\begin{quote}
\verb|homstbasis!* m|\index{homstbasis}

\pbx{for the invocation of the homogenization approach to compute a
standard basis of the dpmat $m$ and}

\verb|lazystbasis!* m|\index{lazystbasis}

\pbx{for the lazy algorithm.}
\end{quote}
Experts commonly agree that the classical approach is better for
``computable'' examples, but computations done by the author
on large examples indicate, that both approaches are in fact
independent. 
\medskip

The pair list management uses the sugar strategy, see \cite{GMNRT},
with respect to the current ecart vector. If the input is homogeneous
and the ecart vector reflects this homogeneity then pairs are sorted
by ascending degree. Hence no superfluous base 
elements will be computed in this case. In general the sugar strategy
performs best if the ecart vector is chosen to make the input close
to be homogeneous.

There is another global variable \ind{cali!=monset} that may contain
a list of variable names (a subset of the variable names of the
current base ring). During the ``pure'' \gr algorithm (without syzygy
and representation computations) common monomial factors containing
only these variables will be canceled out. This shortcut is useful if
some of the variables are known to be non zero divisors as e.g.\ in
most implicitation problems.
\begin{quote}
\verb|setmonset!* vars|\index{setmonset}

\pbx{initializes {\em cali!=monset} with a given list of variables
$vars$.} 
\end{quote}

The \gr tools as e.g.\ pair criteria, pair list update, pair
management and S-polynomial construction are available. 
\begin{quote}
\verb|groeb_mingb m|\index{groeb\_mingb}

\pbx{extracts a minimal \gr basis from the dpmat $m$, removing base
elements with leading terms, divisible by other leading terms.} 

\verb|groeb_minimize(bas,syz)|\index{groeb\_minimize}

\pbx{minimizes the dpmat pair $(bas,syz)$ deleting superfluous base
elements from $bas$ using syzygies from $syz$ containing unit
entries.} 
\end{quote}

\subsection{The \gr Factorizer}

If $\bar{k}$ is the algebraic closure of $k$,
$B:=\{f_1,\ldots,f_m\}\subset S$ a finite system of polynomials, and
$C:=\{g_1,\ldots,g_k\}$ a set of side conditions define the {\em
relative set of zeroes}   
\[Z(B,C):=\{a\in \bar{k}^n : \forall\ f\in B\ f(a)=0\mbox{ and }
\forall g\in C\ g(a)\neq 0\}.\]
Its Zariski closure is the zero set of $I(B):<\prod C>$. 

The \gr factorizer solves the following problem:
\begin{quote}
\it Find a collection $(B_\alpha,C_\alpha)$ of \gr bases $B_\alpha$
and side conditions $C_\alpha$ such that 
\[Z(B,C) = \bigcup_\alpha Z(B_\alpha,C_\alpha).\]
\end{quote}
The \ind{module groebf} and the \ind{module triang} contain algorithms
related to that problem, triangular systems, and their generalizations
as described in \cite{fgb} and \cite{efgb}. V. 2.2 thus heavily
extends the algorithmic possibilities that were implemented in former
releases of CALI. 

Note that, different to v.\ 2.1, we work with constraint {\em lists}.
\begin{quote}
\verb|groebfactor!*(bas,con)|\index{groebfactor}

\pbx{returns for the dpmat ideal $bas$ and the constraint list $con$
(of dpolys) a minimal list of $(dpmat, constraint\ list)$ pairs with
the desired property.}
\end{quote}
During a preprocessing it splits the submitted basis $bas$ by a
recursive factorization of polynomials and interreduction of bases
into a (reduced) list of smaller subproblems consisting of a partly
computed \gr basis, a constraint list, and a list of pairs not yet
processed. The main procedure forces the next subproblem to be
processed until another factorization is possible. Then the
subproblem splits into subsubproblems, and the subproblem list will
be updated. Subproblems are kept sorted with respect to their
expected dimension \ind{easydim} forcing this way a {\em depth first}
recursion.  Returned and not yet interreduced \gr bases are, after
interreduction, subject to another call of the preprocessor since
interreduced polynomials may factor anew.
\begin{quote}
\verb|listgroebfactor!* l|\index{listgroebfactor} 

\pbx{proceeds a whole list of dpmats (without constraints) at once and
strips off constraints at the end.}
\end{quote}
\medskip

Using the (ordinary) \gr factorizer even components of different
dimension may keep gluing together. The \ind{extended \gr factorizer}
involves a postprocessing, that guarantees a decomposition into
puredimensional components, given by triangular systems instead of \gr 
bases. Triangular systems in positive dimension must not be \gr bases
of the underlying ideal. They should be preferred, since they are more
simple but contain all information about the (quasi) prime component
that they represent. The complete \gr basis of the corresponding
component can be obtained by an easy stable quotient computation, see
\cite{efgb}. We refer to the same paper for the definition of
\ind{triangular systems} in positive dimension, that is consistent
with our approach. 
\begin{quote}
\verb|extendedgroebfactor!*(bas,c)| and
\verb|extendedgroebfactor1!*(bas,c)| 
\index{extendedgroebfactor} \index{extendedgroebfactor1} 

\pbx{return a list of results $\{b_i,c_i,v_i\}$ in algebraic prefix
form such that $b_i$ is a triangular set wrt.\ the variables $v_i$ and
$c_i$ is a list of constraints, such that $b_i:<\prod c_i>$ is the
(puredimensional) recontraction of the zerodimensional ideal
$b_i\bigotimes_k k(v_i)$. For  the first version the recontraction is
not computed, hence the output may be not minimal. The second version
computes recontractions to decide superfluous components already
during the algorithm. Note that the stable quotient computation
involved for that purpose may drastically slow down the whole
attempt.}  
\end{quote}
The postprocessing involves a change to dimension zero and invokes
(zero dimensional) triangular system computations from the
\ind{module triang}. In a first step \ind{groebf\_zeroprimes1}
incorporates the square free parts of certain univariate polynomials
into these systems and strips off the constraints (since relative sets
of zeroes in dimension zero are Zariski closed), using a splitting
approach analogous to the \gr factorizer. In a second step, according
to the \ind{switch lexefgb}, either \ind{zerosolve!*} or
\ind{zerosolve1!*} converts these intermediate results into lists of
triangular systems in prefix form. If \ind{lexefgb} is {\tt off} (the 
default), the zero dimensional term order is degrevlex and
\ind{zerosolve1!*}, the ``slow turn to lex'' is involved, for {\tt on
lexefgb} the pure lexicographic term order and \ind{zerosolve!*},
M\"ollers original approach, see \cite{Moeller}, are used. Note that
for this term order we need only a single \gr basis computation at
this level.

A third version, \ind{zerosolve2!*}, mixes the first approach with the
FGLM change of term orders. It is not incorporated into the extended
\gr factorizer.

\subsection{Basic Operations on Ideals and Modules}

\gr and local standard bases are the heart of several basic
algorithms in ideal theory, see e.g.\ \cite[6.2.]{BKW}. CALI offers
the following facilities:
\begin{quote}
\verb|submodulep!*(m,n)|\index{submodulep}

\pbx{tests the dpmat $m$ for being a submodule of the dpmat $n$
reducing the basis elements of $m$ with respect to $n$. The result
will be correct provided $n$ is a \gr basis.}

\verb|modequalp!*(m,n)|\index{modequalp}

\pbx{ = submodulep!*(m,n) and submodulep!*(n,m).}

\verb|eliminate!*(m,)| \index{eliminate}

\pbx{computes the elimination ideal/module eliminating the variables
in the given variable list (a subset of the variables of the current
base ring). Changes temporarily the term order to degrevlex.}

\verb|matintersect!* l|\index{matintersect}
\footnote{This can be done for ideals and
modules in an unique way. Hence {\em idealintersect!*} has been
removed in v.\ 2.1.}

\pbx{computes the intersection of the dpmats in the dpmat list $l$
along \cite[6.20]{BKW}.}
\end{quote}

CALI offers several quotient algorithms. They rest on the computation
of quotients by a single element of the following kind: Assume
$M\subset S^c, v\in S^c, f\in S$. Then there are
\begin{quote}
the \ind{module quotient} $M : (v) = \{g\in S\ |\ gv\in M\}$,

the \ind{ideal quotient} $M : (f) = \{w\in S^c\ |\ fw\in M\}$, and

the \ind{stable quotient} $M : (f)^\infty = \{w\in S^c\ |\ \exists\,
n\, :\, f^nw\in M\}$.
\end{quote}
CALI uses the elimination approach \cite[4.4.]{CLO} and
\cite[6.38]{BKW} for their computation:
\begin{quote}
\verb|matquot!*(M,f)|\index{matquot}

\pbx{returns the module or ideal quotient $M:(f)$ depending on $f$.}

\verb|matqquot!*(M,f)|\index{matqquot}

\pbx{returns the stable quotient $M:(f)^\infty$.}
\end{quote}
\ind{matquot!*} calls the pseudo division with remainder
\begin{quote}
\verb|dp_pseudodivmod(g,f)|\index{dp\_pseudodivmod}

\pbx{that returns a dpoly list $\{q,r,z\}$ such that $z\cdot g =
q\cdot f + r$ with a dpoly unit $z$.\ ($g, f$ and $r$ must belong to
the same free module). This is done uniformly for noetherian and
local term orders with an extended normal form algorithm as described
in \cite{ala}.}
\end{quote}
\medskip

In the same way one defines the quotient of a module by another
module (both embedded in a common free module $S^c$), the quotient of
a module by an ideal, and the stable quotient of a module by an
ideal. Algorithms for their computation can be obtained from the
corresponding algorithms for a single element as divisor either by
the generic element method \cite{E} or as an intersection 
\cite[6.31]{BKW}. CALI offers both approaches (X=1 or 2 below) at
the symbolic level, but for true quotients only the latter one is 
integrated into the algebraic mode interface.
\begin{quote}
\verb|idealquotientX!*(M,I)|\index{idealquotient}

\pbx{returns the ideal quotient $M:I$ of the dpmat $M$ by the dpmat
ideal $I$.}

\verb|modulequotientX!*(M,N)|\index{modulequotient}

\pbx{returns the module quotient $M:N$ of the dpmat $M$ by the dpmat
$N$.}

\verb|annihilatorX!* M|\index{annihilator}

\pbx{returns the annihilator of $coker\ M$, i.e.\ the module quotient
$S^c:M$, if $M$ is a submodule of $S^c$.}

\verb|matstabquot!*(M,I)|\index{matstabquot}

\pbx{returns the stable quotient $M:I^\infty$ (only by the general element
method).}
\end{quote}


\subsection{Monomial Ideals}

Monomial ideals occur as ideals of leading terms of (ideal's) \gr
bases and also as components of leading term modules of submodules of
free modules, see \cite{rois}, and reflect some properties of the
original ideal/module. Several parameters of the original ideal or
module may be read off from it as e.g.\ dimension and Hilbert series.  

The \ind{module moid} contains the corresponding algorithms on
monomial ideals. Monomial ideals are lists of monomials, kept sorted
by descending lexicographic order as proposed in \cite{BS}. 

\begin{quote}
\verb|moid_primes u| \index{moid\_primes}

\pbx{returns the minimal primes (as a list of lists of variable
names) of the monomial ideal $u$ using an adaption of the algorithm,
proposed in \cite{BS} for the computation of the codimension.}

\verb|indepvarsets!* m| \index{indepvarsets} 

\pbx{returns (based on {\em moid\_primes}) the list of strongly
independent sets of $m$, see \cite{KW} and \cite{rois} for
definitions.}

\verb|dim!* m| \index{dim}

\pbx{returns the dimension of $coker\ m$ as the size of the largest
independent set.}

\verb|codim!* m| \index{codim}

\pbx{returns the codimension of $coker\ m$.}

\verb|easyindepset!* m| \index{easyindepset}

\pbx{returns a maximal with respect to inclusion independent set of
$m$.}

\verb|easydim!* m| \index{easydim}

\pbx{is a fast dimension algorithm (based on {\em easyindepset}), that
will be correct if $m$ is (radically) unmixed. Since it is
significantly faster than the general dimension
algorithm\footnotemark, it should 
be used, if all maximal independent sets are known to be of equal
cardinality (as e.g.\ for prime or unmixed ideals, see \cite{rois}).}
\footnotetext{This algorithm is of linear time as opposed to the
problem to determine the dimension of an arbitrary monomial ideal,
that is known to be NP-hard in the number of variables, see
\cite{BS}.} 
\end{quote}

\subsection{Hilbert Series}

CALI v. 2.2 now offers also \ind{weighted Hilbert series}, i.e.\
series that may reflect multihomogeneity of ideals and modules. For
this purpose 
a weighted Hilbert series has a list of (integer) degree vectors
as second parameter, and the ideal(s) of leading terms are evaluated
wrt.\ these weights. For the output and polynomial arithmetic,
involved during the computation of the Hilbert series numerator, the
different weight levels are mapped onto the first variables of the
current ring. If $w$ is such a weight vector list and $I$ is a
monomial ideal in the polynomial ring $S=k[x_v\,:\,v\in V]$ we get
(using multi exponent notation) 
\[H(S/I,t) := \sum_{\alpha}{|\{x^a\not\in I\,:\,w(a)=\alpha\}|\cdot
t^\alpha} = \frac{Q(t)}{\prod_{v\in V}{\left(1-t^{w(x_v)}\right)} }\]
for a certain polynomial Hilbert series numerator $Q(t)$. $H(R/I,t)$
is known to be a rational function with pole order at $t=1$ equal to
$dim\ R/I$. Note that \ind{WeightedHilbertSeries} returns a {\em
reduced} rational function where the gcd of numerator and denominator
is canceled out. 

(Non weighted) Hilbert series call the weighted Hilbert series
procedure with a single weight vector, the ecart vector of the current
ring.   

The Hilbert series numerator $Q(t)$ is computed using (the obvious
generalizations to the weighted case of) the algorithms in \cite{BS}
and \cite{BCRT}. Experiments suggest that the former is better for few
generators of high degree whereas the latter has to be preferred for
many generators of low degree. Choose the version with
\ind{hftestversion} $n$, $n=1,\,2$. Bayer/Stillman's approach ($n=1$)
is the default. In the following $m$ is a dpmat and \gr basis.

\begin{quote}
\verb|hf_whilb(m,w)| \index{hf\_whilb} 

\pbx{returns the weighted Hilbert series numerator $Q(t)$ of $m$
according to the version chosen with \ind{hftestversion}.}

\verb|WeightedHilbertSeries!*(m,w)| \index{WeightedHilbertSeries}

\pbx{returns the weighted Hilbert series reduced rational function of
$m$ as s.q.} 

\verb|HilbertSeries!*(m,w)| \index{HilbertSeries}

\pbx{returns the Hilbert series reduced rational function of $m$ wrt.\
the ecart vector of the current ring as s.q.} 

\verb|hf_whilb3(u,w)| and \verb|hf_whs_from_resolution(u,w)|
\index{hf\_whilb3}
\index{hf\_whs\_from\_resolution}

\pbx{compute the weighted Hilbert series numerator and the
corresponding reduced rational function from (the column degrees of) a 
given resolution $u$.}  

\verb|degree!* m| \index{degree}

\pbx{returns the value of the numerator of the reduced Hilbert series
of $m$ at $t=1$. i.e.\ the sum of its coefficients. For the standard
ecart this is the degree of $coker\ m$.} 
\end{quote}

\subsection{Resolutions}

Resolutions of ideals and modules, represented as lists of dpmats, are
computed via repeated syzygy computation with minimization steps
between them to get minimal bases and generators of syzygy
modules. Note that the algorithms apply simultaneously to both
Noetherian and non Noetherian term orders. For compatibility reasons
with further releases v. 2.2 introduces a second parameter to  
bound the number of syzygy modules to be computed, since Hilbert's
syzygy theorem applies only to regular rings.
\begin{quote}
\verb|Resolve!*(m,d)| \index{Resolve} 

\pbx{computes a minimal resolution of the dpmat $m$, i.e. a list of
dpmats $\{s_0, s_1, s_2,\ldots\}$, where $s_k$ is the $k$-th syzygy
module of $m$, upto part $s_d$.}

\verb|BettiNumbers!* c| and \verb|GradedBettiNumbers!* c|
\index{BettiNumbers} 
\index{GradedBettiNumbers} 

\pbx{returns the Betti numbers resp.\ the graded Betti numbers of the
resolution $c$, i.e.\ the list of the lengths resp.\ the degree lists
(according to the ecart) themselves of the dpmats in $c$.}
\end{quote}

\subsection{Zero Dimensional Ideals and Modules}

There are several algorithms that either force the reduction of a
given problem to dimension zero or work only for zero dimensional
ideals or modules.  The \ind{module odim} offers such
algorithms. It contains, e.g.\
\begin{quote}
\verb|dimzerop!* m| \index{dimzerop}

\pbx{that tests a dpmat $m$ for being zero dimensional.}

\verb|getkbase!* m| \index{getkbase}

\pbx{that returns a (monomial) k-vector space basis of $Coker\ m$
provided $m$ is a \gr basis.}

\verb|odim_borderbasis m| \index{odim\_borderbasis}

\pbx{that returns a border basis, see \cite{MMM}, of the
zero dimensional dpmat $m$ as a  list of base elements.}

\verb|odim_parameter m| \index{odim\_parameter}

\pbx{that returns a parameter of the dpmat $m$, i.e.\ a variable $x
\in vars$ such that $k[x]\bigcap Ann\ S^c/m=(0)$, or {\em nil} if $m$
is zero dimensional.}

\verb|odim_up(a,m)| \index{odim\_up}

\pbx{that returns an univariate polynomial (of smallest possible
degree if $m$ is a gbasis) in the variable $a$, that belongs to the
zero dimensional dpmat ideal $m$, using Buchberger's approach 
\cite{B1}.} 
\end{quote}

\subsection{Primary Decomposition and Related Algorithms}

The algorithms of the \ind{module prime} implement the ideas of
\cite{GTZ} with modifications along \cite{Kr} and their natural
generalizations to modules as e.g.\ explained in \cite{Ru}. Version
2.2.1 fixes a serious bug detecting superfluous embedded primary
components, see section \ref{221}, and contains now a second primary
decomposition algorithm, based on ideal separation, as standard. For a
discussion about embedded primes and the ideal separation approach,
see \cite{primary}. 


CALI contains also algorithms for the computation of the unmixed part
of a given module and the unmixed radical of a given ideal (along the
same lines). We followed the stepwise recursion decreasing dimension
in each step by 1 as proposed in (the final version of) \cite{GTZ}
rather than the ``one step'' method described in \cite{BKW} since
handling leading coefficients, i.e.\ standard forms, depending on
several variables is a quite hard job for
REDUCE\footnote{\ind{prime!=decompose2} implements this strategy in
the symbolic mode layer.}.

In the following procedures $m$ must be a \gr basis.
\begin{quote}
\verb|zeroradical!* m| \index{zeroradical}

\pbx{returns the radical of the zero dimensional ideal $m$, using
squarefree decomposition of univariate polynomials.}

\verb|zeroprimes!* m| \index{zeroprimes}

\pbx{computes as in \cite{GTZ} the list of prime ideals of $Ann\ F/M$
if $m$ is zero dimensional, using the (sparse) general position
argument from \cite{KW}.}

\verb|zeroprimarydecomposition!* m| \index{zeroprimarydecomposition}

\pbx{computes the primary components of the zero dimensional dpmat $m$
using prime splitting with the prime ideals of $Ann\ F/M$. It returns
a list of pairs with first entry the primary component
and second entry the corresponding associated prime ideal.}

\verb|isprime!* m| \index{isprime}

\pbx{a (one step) primality test for ideals, extracted from
\cite{GTZ}.} 

\verb|isolatedprimes!* m| \index{isolatedprimes}

\pbx{computes (only) the isolated prime ideals of $Ann\ F/M$.}

\verb|radical!* m| \index{radical}

\pbx{computes the radical of the dpmat ideal $m$, reducing as in
\cite{GTZ} to the zero dimensional case.}

\verb|easyprimarydecomposition!* m| \index{easyprimarydecomposition}

\pbx{computes the primary components of the dpmat $m$, if it has no
embedded components. The algorithm uses prime splitting with the
isolated prime ideals of $Ann\ F/M$. It returns a list of pairs as in
{\em zeroprimarydecomposition!*}.} 

\verb|primarydecomposition!* m| \index{primarydecomposition}

\pbx{computes the primary components of the dpmat $m$ along the lines
of \cite{GTZ}. It returns a list of two-element lists as in {\em
zeroprimarydecomposition!*}.} 

\verb|unmixedradical!* m| \index{unmixedradical}

\pbx{returns the unmixed radical, i.e.\ the intersection of the
isolated primes of top dimension, associated to the dpmat ideal $m$.}

\verb|eqhull!* m| \index{eqhull}

\pbx{returns the equidimensional hull, i.e.\ the intersection of the 
 top dimensional primary components of the dpmat $m$.}
\end{quote}

\subsection{Advanced Algorithms}

The \ind{module scripts} just under further development offers some
advanced topics of the \gr bases theory. It introduces the new data
structure of a \ind{map} between base rings:
\medskip

A ring map 
\[ \phi\ :\ R\longrightarrow S\]
for $R=k[r_i], S=k[s_j]$ is represented in symbolic mode as a list
\[   \{preimage\_ring\ R,\ image\_ring\ S, subst\_list\},\]
where {\tt subst\_list} is a substitution list $\{r_1=\phi_1(s),
r_2=\phi_2(s),\ldots \}$ in algebraic prefix form, i.e.\ looks like
{\tt (list (equal var image) \ldots )}. 

The central tool for several applications is the computation of the
preimage $\phi^{-1}(I)\subset R$ of an ideal $I\subset S$ either
under a polynomial map $\phi$ or its closure in $R$ under a rational
map $\phi$, see \cite[7.69 and 7.71]{BKW}.
\begin{quote}
\verb|preimage!*(m,map)| \index{preimage}

\pbx{computes the preimage of the ideal $m$ in algebraic prefix form
under the given polynomial map and sets the current base ring to the
preimage ring. Returns the result also in algebraic prefix form.}

\verb|ratpreimage!*(m,map)| \index{ratpreimage}

\pbx{computes the closure of the preimage of the ideal $m$ in
algebraic prefix form under the given rational map and sets the
current base ring to the preimage ring. Returns the result also in
algebraic prefix form.}

\end{quote}

Derived applications are
\begin{quote}
\verb|affine_monomial_curve!*(l,vars)|\index{affine\_monomial\_curve}

\pbx{$l$ is a list of integers, $vars$ a list of variable names of the
same length as $l$. The procedure sets the current base ring and
returns the defining ideal of the affine monomial curve with generic
point $(t^i\ :\ i\in l)$ computing the corresponding preimage.}

\verb|analytic_spread!* M|\index{analytic\_spread}

\pbx{Computes the analytic spread of $M$, i.e.\ the dimension of the
exceptional fiber ${\cal R}(M)/m{\cal R}(M)$ of the blowup along $M$ 
over the irrelevant ideal $m$ of the current base ring.}
       
\verb|assgrad!*(M,N,vars)|\index{assgrad}

\pbx{Computes the associated graded ring \[gr_R(N):=
(R/N\oplus N/N^2\oplus\ldots)={\cal R}(N)/N{\cal R}(N)\] over the ring
$R=S/M$, where $M$ and
$N$ are dpmat ideals defined over the current base ring $S$. {\tt
vars} is a list of new variable names one for each generator of $N$.
They are used to create a second ring $T$ with degree order
corresponding to the ecart of the row degrees of $N$ and a ring map
\[\phi : S\oplus T\longrightarrow S.\]
It returns a dpmat ideal $J$ such that $(S\oplus T)/J$ is  a 
presentation of the
desired associated graded ring over the new current base ring
$S\oplus T$.}
       
\verb|blowup!*(M,N,vars)|\index{blowup}

\pbx{Computes the blow up ${\cal R}(N):=R[N\cdot t]$ of $N$ over
the ring $R=S/M$, where $M$ and $N$ are dpmat ideals defined over the
current base ring $S$. {\tt vars} is a list of new variable names one
for each generator of $N$. They are used to create a second ring $T$
with degree order corresponding to the ecart of the row degrees of
$N$ and a ring map
\[\phi : S\oplus T\longrightarrow S.\]
It returns a dpmat ideal $J$ such that $(S\oplus T)/J$ is 
a presentation of the
desired blowup ring over the new current base ring $S\oplus T$.}
       
\verb|proj_monomial_curve!*(l,vars)|\index{proj\_monomial\_curve}

\pbx{$l$ is a list of integers, $vars$ a list of variable names of the
same length as $l$. The procedure set the current base ring and
returns the defining ideal of the projective monomial curve with
generic point \mbox{$(s^{d-i}\cdot t^i\ :\ i\in l)$} in $R$, where 
\mbox{$d=max\{ x\, :\, x\in l\}$}, computing the corresponding preimage.}

\verb|sym!*(M,vars)|\index{sym}

\pbx{Computes the symmetric algebra $Sym(M)$ where $M$ is a dpmat ideal
defined over the current base ring $S$. {\tt vars} is a list of new
variable names one for each generator of $M$. They are used to create
a second ring $R$ with degree order corresponding to the ecart of the
row degrees of $N$ and a ring map
\[\phi : S\oplus R\longrightarrow S.\]
It returns a dpmat ideal $J$ such that $(S\oplus R)/J$ is the
desired symmetric algebra over the new current base ring $S\oplus R$.}
       
\end{quote}


There are several other applications:
\begin{quote}
\verb|minimal_generators!* m| \index{minimal\_generators}

\pbx{returns a set of minimal generators of the dpmat $m$ inspecting
the first syzygy module.}

\verb|nzdp!*(f,m)| \index{nzdp}

\pbx{tests whether the dpoly $f$ is a non zero divisor on $coker\
m$. $m$ must be a \gr basis.} 

\verb|symbolic_power!*(m,d)| \index{symbolic\_power}

\pbx{returns the $d$\/th symbolic power of the prime dpmat ideal $m$ as
the equidimensional hull of the $d$\/th true power. (Hence applies also
to unmixed ideals.)}

\verb|varopt!* m| \index{varopt}

\pbx{finds a heuristically optimal variable order by the approach in
\cite{BGK} and returns the corresponding list of variables.} 
\end{quote}


\subsection{Dual Bases}


For the general ideas underlying the dual bases approach see e.g.\
\cite{MMM}. This paper explains, that constructive problems from very
different areas of commutative algebra can be formulated in a unified
way as the computation of a basis for the intersection of the kernels
of a finite number of linear functionals generating a dual
$S$-module. Our implementation honours 
this point of view, presenting two general drivers \ind{dualbases} and
\ind{dualhbases} for the computation of such bases (even as submodules
of a free module $M=S^m$) with affine resp.\ projective dimension zero.

Such a collection of $N$ linear functionals
\[L\,:\, M=S^m \longrightarrow k^N\]
should be given through values $\{[e_i,L(e_i)], i=1,\ldots,m\}$ on the
generators $e_i$ of $M$ and an evaluation function {\tt
evlf([p,L(p)],x)}, that evaluates $L(p\cdot x)$ from $L(p)$ for $p\in
M$ and the variable $x\in S$.  

\ind{dualbases} starts with a list of such generator/value constructs
generating $M$ and performs Gaussian reduction on expressions $[p\cdot
x,L(p\cdot x)]$, where $p$ was already processed, $L(p)\neq 0$, and
$x\in S$ is a variable. These elements are processed in ascending order
wrt.\ the term order on $M$. This guarantees both termination and that
the resulting basis of $ker\ L$ is a \gr basis. The $N$ values of $L$
are attached to $N$ variables, that are ordered linearly. Gaussian
elimination is executed wrt.\ this variable order.

To initialize the dual bases driver one has to supply the basic
generator/value list (through the parameter list; for ideals just the
one element list containing the generator $[1\in S,L(1)]$), the
evaluation function, and the linear algebra variable order. The latter
are supplied via the property list of {\tt cali} as properties {\tt
evlf} and {\tt varlessp}. Different applications need more entries
on the property list of {\tt cali} to manage the communication between
the driver and the calling routine.

\ind{dualhbases} realizes the same idea for (homogeneous) ideals and
modules of (projective) dimension zero. It produces zerodimensional
``slices'' with ascending degree until it reaches a supremum supplied
by the user, see \cite{MMM} for details.
\medskip

Applications concern affine and projective defining ideals of a finite 
number of points\footnote{This substitutes the ``brute force'' method
computing the corresponding intersections directly as it was
implemented in v. 2.1. The new approach is significantly faster. The
old stuff is available as \ind{affine\_points1!*} and
\ind{proj\_points1!*}.} and two versions (with and without precomputed
border basis) of term order  
changes for zerodimensional ideals and modules as first described in
\cite{FGLM}.  
\begin{quote}
\verb|affine_points!* m| \index{affine\_points}

\pbx{$m$ is a matrix of domain elements (in algebraic prefix form)
with as many columns as the current base ring has ring variables. This
procedure returns the defining ideal of the collection of points in
affine space with coordinates given by the rows of $m$. Note that $m$
may contain parameters. In this case $k$ is treated as rational
function field.} 

\verb|change_termorder!*(m,r)| and \verb|change_termorder1!*(m,r)| 
\index{change\_termorder}
\index{change\_termorder1}

\pbx{$m$ is a \gr basis of a zero dimensional ideal wrt.\ the current
base ring. These procedures change the current ring to $r$ and compute
the \gr basis of $m$ wrt.\ the new ring $r$. The former uses a
precomputed border basis.} 

\verb|proj_points!* m| \index{proj\_points}

\pbx{$m$ is a matrix of domain elements (in algebraic prefix form)
with as many columns as the current base ring has ring variables. This
procedure returns the defining ideal of the collection of points in
projective space with homogeneous coordinates given by the rows of
$m$. Note that $m$ may as for {\tt affine\_points} contain
parameters.}  
\end{quote}

\pagebreak

\appendix
\section{A Short Description of Procedures Available in Algebraic
Mode} 

Here we give a short description, ordered alphabetically, of {\bf
algebraic} procedures offered by CALI in the algebraic mode
interface\footnote{It does {\bf not} contain switches, get\ldots\
procedures, setting trace level and related stuff.}. 

If not stated explicitely procedures take (algebraic mode) polynomial
matrices ($c>0$) or polynomial lists ($c=0$) $m,m1,m2,\ldots\ $ as
input and return results of the same type. $gb$ stands for a bounded
identifier\footnote{Different to v. 2.1 a \gr basis will be computed
automatically, if necessary.}, $gbr$ for one with precomputed
resolution. For the mechanism of \ind{bounded identifier} see the
section ``Algebraic Mode Interface''.

\begin{quote}
\verb|affine_monomial_curve(l,vars)|\index{affine\_monomial\_curve}

\pbx{$l$ is a list of integers, $vars$ a list of variable names of the
same length as $l$. The procedure sets the current base ring and
returns the defining ideal of the affine monomial curve with generic
point $(t^i\ :\ i\in l)$.}

\verb|affine_points m| \index{affine\_points}

\pbx{$m$ is a matrix of domain elements (in algebraic prefix form)
with as many columns as the current base ring has ring variables. This
procedure returns the defining ideal of the collection of points in
affine space with coordinates given by the rows of $m$. Note that $m$
may contain parameters. In this case $k$ is treated as rational
function field.} 

\verb|analytic_spread m|\index{analytic\_spread}

\pbx{Computes the analytic spread of $m$.}
       
\verb|annihilator m| \index{annihilator}

\pbx{returns the annihilator of the dpmat $m\subseteq S^c$, i.e.\
$Ann\ S^c/M$.}

\verb|assgrad(M,N,vars)|\index{assgrad}

\pbx{Computes the associated graded ring $gr_R(N)$ over $R=S/M$, where 
$S$ is the current
base ring. {\tt vars} is a list of new variable names, one for
each generator of $N$.  They are used to create a second ring $T$
to return an ideal $J$ such that $(S\oplus T)/J$ is the desired
associated graded ring over the new current base ring $S\oplus T$.}
       
\verb|bettiNumbers gbr| \index{bettiNumbers}

\pbx{extracts the list of Betti numbers from the resolution of $gbr$.}

\verb|blowup(M,N,vars)|\index{blowup}

\pbx{Computes the blow up ${\cal R}(N)$ of $N$ over the ring $R=S/M$,
where $S$ is the current base ring. {\tt vars} is a list of new
variable names, one for each generator of $N$. They are used to create
a second ring $T$ to return an ideal $J$ such that $(S\oplus T)/J$ is
the desired blowup ring over the new current base ring $S\oplus T$.}
       
\verb|change_termorder(m,r)| and \verb|change_termorder1(m,r)| 
\index{change\_termorder}
\index{change\_termorder1}

\pbx{Change the current ring to $r$ and compute the \gr basis of $m$
wrt.\ the new ring $r$ by the FGLM approach. The former uses
internally a precomputed border basis.} 

\verb|codim gb| \index{codim}

\pbx{returns the codimension of $S^c/gb$.}

\verb|degree gb| \index{degree}

\pbx{returns the multiplicity of $gb$ as the sum of the coefficients
of the (classical) Hilbert series numerator.}

\verb|degsfromresolution gbr| \index{degsfromresolution}

\pbx{returns the list of column degrees from the minimal resolution
of $gbr$.}

\verb|deleteunits m| \index{deleteunits}

\pbx{factors each basis element of the dpmat ideal $m$ and removes
factors that are polynomial units. Applies only to non Noetherian
term orders.}

\verb|dim gb| \index{dim}

\pbx{returns the dimension of $S^c/gb$.}

\verb|dimzerop gb| \index{dimzerop}

\pbx{tests whether $S^c/gb$ is zerodimensional.}

\verb|directsum(m1,m2,...)| \index{directsum}

\pbx{returns the direct sum of the modules $m1,m2,\ldots$, embedded
into the direct sum of the corresponding free modules.}

\verb|dpgcd(f,g)| \index{dpgcd}

\pbx{returns the gcd of two polynomials $f$ and $g$, computed by the
syzygy method.}

\verb|easydim m| and \verb|easyindepset m| 
\index{easydim}\index{easyindepset}

\pbx{ If the given ideal or module is unmixed (e.g.\ prime) then all
maximal strongly independent sets are of equal size and one can look
for a maximal with respect to inclusion rather than size strongly
independent set. These procedures don't test the input for being a
\gr basis or unmixed, but construct a maximal with respect to
inclusion independent set of the basic leading terms resp.\ detect
from this (an approximation for) the dimension.}

\verb|easyprimarydecomposition m| \index{easyprimarydecomposition} 

\pbx{a short primary decomposition using ideal separation of isolated
primes of $m$, that yields true results only for modules without
embedded components. Returns a list of $\{component, associated\
prime\}$ pairs.}  

\verb|eliminate(m,)| \index{eliminate}

\pbx{computes the elimination ideal/module eliminating the variables
in the given variable list (a subset of the variables of the current
base ring). Changes temporarily the term order to degrevlex.}

\verb|eqhull m| \index{eqhull}

\pbx{returns the equidimensional hull of the dpmat $m$.}

\verb|extendedgroebfactor(m,c)| and \verb|extendedgroebfactor1(m,c)| 
\index{extendedgroebfactor} \index{extendedgroebfactor1} 

\pbx{return for a polynomial ideal $m$ and a list of (polynomial)
constraints $c$ a list of results $\{b_i,c_i,v_i\}$, where $b_i$ is a
triangular set wrt.\ the variables $v_i$ and $c_i$ is a list of
constraints, such that   
$Z(m,c) = \bigcup Z(b_i,c_i)$. For the first version the output may be
not minimal. The second version decides superfluous components already
during the algorithm.}  

\verb|gbasis gb| \index{gbasis}

\pbx{returns the \gr resp. local standard basis of $gb$.}

\verb|getkbase gb| \index{getkbase}

\pbx{returns a k-vector space basis of $S^c/gb$, consisting of module
terms, provided $gb$ is zerodimensional.}

\verb|getleadterms gb| \index{getleadterms}

\pbx{returns the dpmat of leading terms of a \gr resp. local standard
basis of $gb$.} 

\verb|GradedBettinumbers gbr| \index{GradedBettinumbers}

\pbx{extracts the list of degree lists of the free summands in a
minimal resolution of $gbr$.}

\verb|groebfactor(m[,c])|\index{groebfactor}

\pbx{returns for the dpmat ideal $m$ and an optional constraint list
$c$ a (reduced) list of dpmats such that the union of their zeroes is
exactly $Z(m,c)$. Factors all polynomials involved in the \gr
algorithms of the partial results.}

\verb|HilbertSeries gb| \index{HilbertSeries}

\pbx{returns the Hilbert series of $gb$ with respect to the current
ecart vector.} 

\verb|homstbasis m| \index{homstbasis}

\pbx{computes the standard basis of $m$ by Lazard's homogenization
approach.} 

\verb|ideal2mat m| \index{ideal2mat}

\pbx{converts the ideal (=list of polynomials) $m$ into a column
vector.} 

\verb|ideal_of_minors(mat,k)| \index{ideal\_of\_minors}

\pbx{computes the generators for the ideal of $k$-minors of the matrix
$mat$.}  

\verb|ideal_of_pfaffians(mat,k)| \index{ideal\_of\_pfaffians}

\pbx{computes the generators for the ideal of the $2k$-pfaffians of
the skewsymmetric matrix $mat$.}  

\verb|idealpower(m,n)| \index{idealpower}

\pbx{returns the interreduced basis of the ideal power $m^n$ with
respect to the integer $n\geq 0$.}

\verb|idealprod(m1,m2,...)| \index{idealprod}

\pbx{returns the interreduced basis of the ideal product 
\mbox{$m1\cdot m2\cdot \ldots$} of the ideals $m1,m2,\ldots$.}

\verb|idealquotient(m1,m2)| \index{idealquotient}

\pbx{returns the ideal quotient $m1:m2$ of the module $m1\subseteq
S^c$ by the ideal $m2$.}

\verb|idealsum(m1,m2,...)| \index{idealsum}

\pbx{returns the interreduced basis of the ideal sum $m1+m2+\ldots$.}

\verb|indepvarsets gb| \index{indepvarsets}

\pbx{returns the list of strongly independent sets of $gb$ with
respect to the current term order, see \cite{KW} for a definition in
the case of ideals and \cite{rois} for submodules of free modules.}

\verb|initmat(m,| \index{initmat}

\pbx{initializes the dpmat $m$ together with its base ring, term order
and column degrees from a file.}

\verb|interreduce m| \index{interreduce}

\pbx{returns the interreduced module basis given by the rows of $m$,
i.e.\ a basis with pairwise indivisible leading terms.}

\verb|isolatedprimes m| \index{isolatedprimes}

\pbx{returns the list of isolated primes of the dpmat $m$, i.e.\ the
isolated primes of $Ann\ S^c/M$.}

\verb|isprime gb| \index{isprime}

\pbx{tests the ideal $gb$ to be prime.}

\verb|iszeroradical gb| \index{iszeroradical}

\pbx{tests the zerodimensional ideal $gb$ to be radical.}

\verb|lazystbasis m| \index{lazystbasis}

\pbx{computes the standard basis of $m$ by the lazy algorithm, see
e.g.\ \cite{MPT}.} 

\verb|listgroebfactor in| \index{listgroebfactor}

\pbx{computes for the list $in$ of ideal bases a list $out$ of \gr
bases by the \gr factorization method, such that 
$\bigcup_{m\in in}Z(m) = \bigcup_{m\in out}Z(m)$.} 

\verb|mat2list m| \index{mat2list}

\pbx{converts the matrix $m$ into a list of its entries.}

\verb|matappend(m1,m2,...)| \index{matappend}

\pbx{collects the rows of the dpmats $m1,m2,\ldots $ to a common
matrix. $m1,m2,\ldots$ must be submodules of the same free module,
i.e.\ have equal column degrees (and size).}

\verb|mathomogenize(m,var)| \index{mathomogenize}
\footnote{Dehomogenize with {\tt sub(z=1,m)} if $z$ is the
homogenizing variable.}

\pbx{returns the result obtained by homogenization of the rows of m
with respect to the variable {\tt var} and the current \ind{ecart
vector}.}

\verb|matintersect(m1,m2,...)| \index{matintersect}

\pbx{returns the interreduced basis of the intersection $m1\bigcap
m2\bigcap \ldots$.}

\verb|matjac(m,)| \index{matjac}

\pbx{returns the Jacobian matrix of the ideal m with respect to the 
supplied variable list}

\verb|matqquot(m,f)| \index{matqquot}

\pbx{returns the stable quotient $m:(f)^\infty$ of the dpmat $m$ by
the polynomial $f\in S$.}

\verb|matquot(m,f)| \index{matquot}

\pbx{returns the quotient $m:(f)$ of the dpmat $m$ by the polynomial
$f\in S$.}

\verb|matstabquot(m1,id)| \index{matstabquot}

\pbx{returns the stable quotient $m1:id^\infty$ of the dpmat $m1$ by
the ideal $id$.}

\verb|matsum(m1,m2,...)| \index{matsum}

\pbx{returns the interreduced basis of the module sum $m1+m2+\ldots$
in a common free module.}

\verb|minimal_generators m| \index{minimal\_generators}

\pbx{returns a set of minimal generators of the dpmat $m$.}

\verb|minors(m,b)| \index{minors}

\pbx{returns the matrix of minors of size $b\times b$ of the matrix
$m$.}  

\verb|a mod m| \index{mod}

\pbx{computes the (true) normal form(s), i.e.\ a standard quotient
representation, of $a$ modulo the dpmat $m$. $a$ may be either a
polynomial or a polynomial list ($c=0$) or a matrix ($c>0$) of the
correct number of columns.} 

\verb|modequalp(gb1,gb2)| \index{modequalp}

\pbx{tests, whether $gb1$ and $gb2$ are equal (returns YES or NO).}

\verb|modulequotient(m1,m2)| \index{modulequotient}

\pbx{returns the module quotient $m1:m2$ of two dpmats $m1,m2$ in a
common free module.}

\verb|normalform(m1,m2)| \index{normalform}

\pbx{returns a list of three dpmats $\{m3,r,z\}$, where $m3$ is the
normalform of $m1$ modulo $m2$, $z$ a scalar matrix of polynomial
units (i.e.\ polynomials of degree 0 in the noetherian case and
polynomials with leading term of degree 0 in the tangent cone case),
and $r$ the relation matrix, such that \[m3=z*m1+r*m2.\]}

\verb|nzdp(f,m)| \index{nzdp}

\pbx{tests whether the dpoly $f$ is a non zero divisor on $coker\
m$.} 

\verb|pfaffian mat| \index{pfaffian}

\pbx{returns the pfaffian of a skewsymmetric matrix $mat$.}

\verb|preimage(m,map)| \index{preimage}

\pbx{computes the preimage of the ideal $m$ under the given
polynomial map and sets the current base ring to the preimage ring.}

\verb|primarydecomposition m| 
\index{primarydecomposition}

\pbx{returns the primary decomposition of the dpmat $m$ as a list of
$\{component, associated\ prime\}$ pairs.}

\verb|proj_monomial_curve(l,vars)|\index{proj\_monomial\_curve}

\pbx{$l$ is a list of integers, $vars$ a list of variable names of the
same length as $l$. The procedure sets the current base ring and
returns the defining ideal of the projective monomial curve with
generic point \mbox{$(s^{d-i}\cdot t^i\ :\ i\in l)$} in $R$ where $d=max\{
x\, :\, x\in l\}$.}

\verb|proj_points m| \index{proj\_points}

\pbx{$m$ is a matrix of domain elements (in algebraic prefix form)
with as many columns as the current base ring has ring variables. This
procedure returns the defining ideal of the collection of points in
projective space with homogeneous coordinates given by the rows of
$m$. Note that $m$ may as for {\tt affine\_points} contain
parameters.}  

\verb|radical m| \index{radical}

\pbx{returns the radical of the dpmat ideal $m$.}

\verb|random_linear_form(vars,bound)| \index{random\_linear\_form}

\pbx{returns a random linear form in the variables {\tt vars} with integer
coefficients less than the supplied {\tt bound}.}

\verb|ratpreimage(m,map)| \index{ratpreimage}

\pbx{computes the closure of the preimage of the ideal $m$ under the
given rational map and sets the current base ring to the preimage
ring.}

\verb|resolve(m[,d])| \index{resolve}

\pbx{returns the first $d$ members of the minimal resolution of the
bounded identifier $m$ as a list of matrices. If the resolution has
less than $d$ non zero members, only those are collected. (Default:
$d=100$)}

\verb|savemat(m,)| \index{savemat}

\pbx{save the dpmat $m$ together with the settings of it base ring,
term order and column degrees to a file.}

\verb|setgbasis m| \index{setgbasis}

\pbx{declares the rows of the bounded identifier $m$ to be already a
\gr resp. local standard basis thus avoiding a possibly time
consuming \gr or standard basis computation.}

\verb|sieve(m,)| \index{sieve}

\pbx{sieves out all base elements with leading terms having a factor
contained in the specified variable list (a subset of the variables
of the current base ring). Useful for elimination problems solved
``by hand''.}

\verb|singular_locus(M,c)| \index{singular\_locus}

\pbx{returns the defining ideal of the singular locus of $Spec\ S/M$
where $M$ is an ideal of codimension $c$, adding to $M$ the generators
of the ideal of the $c$-minors of the Jacobian of $M$.}

\verb|submodulep(m,gb)| \index{submodulep}

\pbx{tests, whether $m$ is a submodule of $gb$ (returns YES or NO).}

\verb|sym(M,vars)|\index{sym}

\pbx{Computes the symmetric algebra $Sym(M)$ where $M$ is an ideal
defined over the current base ring $S$. {\tt vars} is a list of new
variable names, one for each generator of $M$. They are used to create
a second ring $R$ to return an ideal $J$ such that $(S\oplus R)/J$ is
the desired symmetric algebra over the new current base ring $S\oplus
R$.}
       
\verb|symbolic_power(m,d)| \index{symbolic\_power}

\pbx{returns the $d$th symbolic power of the prime dpmat ideal $m$.} 

\verb|syzygies m| \index{syzygies}

\pbx{returns the first syzygy module of the bounded identifier $m$.}

\verb|tangentcone gb| \index{tangentcone}

\pbx{returns the tangent cone part, i.e.\ the homogeneous part of
highest degree with respect to the first degree vector of the term
order from the \gr basis elements of the dpmat $gb$. The term order
must be a degree order.}

\verb|unmixedradical m| \index{unmixedradical}

\pbx{returns the unmixed radical of the dpmat ideal $m$.}

\verb|varopt m| \index{varopt}

\pbx{finds a heuristically optimal variable order, see \cite{BGK}. 
\[\tt vars:=varopt\ m;\ setring(vars,\{\},lex);\ setideal(m,m);\]
changes to the lexicographic term order with heuristically best
performance for a lexicographic \gr basis computation.}

\verb|WeightedHilbertSeries(m,w)| \index{WeightedHilbertSeries}

\pbx{returns the weighted Hilbert series of the dpmat $m$. Note that
$m$ is not a bounded identifier and hence not checked to be a \gr
basis. $w$ is a list of integer weight vectors.} 

\verb|zeroprimarydecomposition m| \index{zeroprimarydecomposition}

\pbx{returns the primary decomposition of the zerodimensional dpmat
$m$ as a list of $\{component, associated\ prime\}$ pairs.}

\verb|zeroprimes m| \index{zeroprimes}

\pbx{returns the list of primes of the zerodimensional dpmat $m$.}

\verb|zeroradical gb| \index{zeroradical}

\pbx{returns the radical of the zerodimensional ideal $gb$.}

\verb|zerosolve m|, \verb|zerosolve1 m| and  \verb|zerosolve2 m| 
\index{zerosolve}\index{zerosolve1}\index{zerosolve2}

\pbx{Returns for a zerodimensional ideal a list of triangular systems
that cover $Z(m)$. {\tt Zerosolve} needs a pure lex.\ term order for
the ``fast'' turn to lex.\ as described in \cite{Moeller}, {\tt
Zerosolve1} is the ``slow'' turn to lex.\ as described in \cite{efgb},
and {\tt Zerosolve2} incorporated the FGLM term order change into {\tt
Zerosolve1}.} 
\end{quote}
\pagebreak


\section{The CALI Module Structure}
\vfill

\begin{tabular}{|p{1.5cm}||p{5.5cm}|p{2cm}|p{4cm}|}
\hline
\sloppy

name & subject & data type & representation \\
\hline

cali & Header module, contains \linebreak 
global variables, switches etc. & --- & ---\\

bcsf & Base coefficient arithmetic & base coeff. & standard forms \\ 

ring & Base ring setting, definition of the term order & base ring &
special type RING\\

mo & monomial arithmetic & monomials & (exp. list . degree list)\\

dpoly & Polynomial and vector arith\-metic & dpolys & list of terms\\

bas & Operations on base lists & base list & list of base elements \\

dpmat & Operations on polynomial matrices, the central data type of
CALI & dpmat & special type DPMAT\\

red & Normal form algorithms & --- & ---\\

groeb & \gr basis algorithm and related ones & --- & ---\\

groebf & the \gr factorizer and its extensions  & --- & ---\\

matop & Operations on (lists of) \linebreak dpmats that correspond to
ideal/module operations & --- & ---\\

quot & Different quotient algorithms & --- & --- \\

moid & Monomial ideal algorithms & monomial ideal & list of monomials \\

hf & weighted Hilbert series & -- & -- \\

res & Resolutions of dpmats & resolution & list of dpmats \\

intf & Interface to algebraic mode & --- & ---\\

odim & Algorithms for zerodimensional ideals and modules & --- & ---\\ 

prime & Primary decomposition and related questions & --- & ---\\

scripts & Advanced applications  & --- & ---\\

calimat & Extension of the matrix package & --- & ---\\

lf & The dual bases approach & --- & ---\\

triang & (Zero dimensional) triangular systems & --- & ---\\
\hline
\end{tabular}
\vfill
\pagebreak

\begin{theindex}

  \item affine\_monomial\_curve, 33, 36
  \item affine\_points, 7, 35, 36
  \item affine\_points1!*, 35
  \item algebraic numbers, 13
  \item analytic\_spread, 33, 36
  \item annihilator, 28, 36
  \item assgrad, 33, 36

  \indexspace

  \item bas\_detectunits, 23
  \item bas\_factorunits, 23
  \item bas\_getrelations, 20
  \item bas\_removerelations, 20
  \item bas\_setrelations, 20
  \item base coefficients, 13
  \item base elements, 19
  \item base ring, 9, 17
  \item basis, 13
  \item bcsimp, 14
  \item BettiNumbers, 30, 36
  \item binomial, 7
  \item blockorder, 10, 18
  \item blowup, 7, 33, 36
  \item border basis, 8
  \item bounded identifier, 13, 36

  \indexspace

  \item cali, 16
  \item cali!=basering, 9, 16, 18
  \item cali!=degrees, 12, 16, 18
  \item cali!=monset, 16, 25
  \item change of term orders, 7
  \item change\_termorder, 35, 37
  \item change\_termorder1, 35, 37
  \item clearcaliprintterms, 16
  \item codim, 29, 37
  \item column degree, 12

  \indexspace

  \item degree, 30, 37
  \item degree vectors, 9
  \item degreeorder, 10, 18
  \item degsfromresolution, 37
  \item deleteunits, 23, 37
  \item detectunits, 14, 23
  \item dim, 8, 29, 37
  \item dimzerop, 31, 37
  \item directsum, 37
  \item dmode, 13
  \item dp\_pseudodivmod, 14, 19, 28
  \item dpgcd, 19, 37
  \item dpmat, 8, 12, 13, 20
  \item dpmat\_coldegs, 20
  \item dpmat\_cols, 20
  \item dpmat\_gbtag, 20
  \item dpmat\_list, 20
  \item dpmat\_rows, 20
  \item dual bases, 6, 7, 34, 35

  \indexspace

  \item easydim, 26, 29, 37
  \item easyindepset, 29, 37
  \item easyprimarydecomposition, 32, 37
  \item ecart, 3, 19
  \item ecart vector, 8, 11, 40
  \item efgb, 16
  \item eliminate, 7, 27, 38
  \item eliminationorder, 10, 18
  \item eqhull, 32, 38
  \item evlf, 17
  \item extended \gr factorizer, 7, 15, 26
  \item extendedgroebfactor, 26, 38
  \item extendedgroebfactor1, 26, 38

  \indexspace

  \item factorunits, 15, 23
  \item flatten, 8
  \item free identifier, 13

  \indexspace

  \item gb-tag, 8, 20
  \item gbasis, 24, 38
  \item gbtestversion, 7, 8, 16, 24
  \item getdegrees, 12
  \item getecart, 11
  \item getkbase, 31, 38
  \item getleadterms, 38
  \item getring, 11
  \item getrules, 13
  \item global procedures, 5
  \item GradedBettiNumbers, 30
  \item gradedbettinumbers, 38
  \item groeb, 7
  \item groeb!=rf, 16
  \item groeb\_homstbasis, 24
  \item groeb\_lazystbasis, 24
  \item groeb\_mingb, 25
  \item groeb\_minimize, 25
  \item groeb\_stbasis, 24
  \item groebf\_zeroprimes1, 27
  \item groebfactor, 26, 38

  \indexspace

  \item hardzerotest, 15
  \item hf!=hf, 16
  \item hf\_whilb, 30
  \item hf\_whilb3, 30
  \item hf\_whs\_from\_resolution, 30
  \item hftestversion, 8, 16, 30
  \item HilbertSeries, 8, 11, 30, 38
  \item homstbasis, 25, 38

  \indexspace

  \item ideal2mat, 12, 38
  \item ideal\_of\_minors, 21, 38
  \item ideal\_of\_pfaffians, 21, 39
  \item idealpower, 39
  \item idealprod, 39
  \item idealquotient, 27, 28, 39
  \item ideals, 12
  \item idealsum, 39
  \item indepvarsets, 29, 39
  \item initmat, 39
  \item internal procedures, 5
  \item interreduce, 23, 39
  \item isolatedprimes, 32, 39
  \item isprime, 32, 39
  \item iszeroradical, 39

  \indexspace

  \item lazy, 7
  \item lazystbasis, 25, 39
  \item lexefgb, 15, 27
  \item lexicographic, 9
  \item listgroebfactor, 26, 39
  \item listminimize, 6
  \item listtest, 6
  \item local procedures, 5
  \item localorder, 10, 18

  \indexspace

  \item map, 32
  \item mat2list, 8, 12, 39
  \item matappend, 40
  \item mathomogenize, 40
  \item mathprint, 17
  \item matintersect, 7, 27, 40
  \item matjac, 21, 40
  \item matqquot, 28, 40
  \item matquot, 28, 40
  \item matstabquot, 28, 40
  \item matsum, 40
  \item minimal\_generators, 34, 40
  \item minors, 21, 40
  \item mod, 23, 40
  \item modequalp, 8, 27, 40
  \item module 
	\subitem bcsf, 17
	\subitem cali, 5
	\subitem calimat, 8, 21
	\subitem dpmat, 20
	\subitem groeb, 24
	\subitem groebf, 7, 26
	\subitem lf, 7, 17
	\subitem moid, 28
	\subitem mora, 7
	\subitem odim, 7, 31
	\subitem prime, 31
	\subitem ring, 17
	\subitem scripts, 7, 32
	\subitem triang, 26, 27
  \item module quotient, 27
  \item module term order, 12
  \item modulequotient, 28, 40
  \item modules, 12
  \item moid\_primes, 29

  \indexspace

  \item Noetherian, 3, 15
  \item normalform, 23, 41
  \item nzdp, 34, 41

  \indexspace

  \item odim\_borderbasis, 31
  \item odim\_parameter, 31
  \item odim\_up, 31
  \item oldbasis, 17
  \item oldborderbasis, 17
  \item oldring, 17

  \indexspace

  \item pfaffian, 21, 41
  \item preimage, 7, 32, 41
  \item primarydecomposition, 7, 41
  \item printterms, 16
  \item proj\_monomial\_curve, 33, 41
  \item proj\_points, 7, 35, 41
  \item proj\_points1!*, 35

  \indexspace

  \item radical, 32, 41
  \item random\_linear\_form, 21, 41
  \item ratpreimage, 33, 41
  \item red, 7
  \item red\_better, 22
  \item red\_extract, 23
  \item red\_Interreduce, 23
  \item red\_prepare, 23
  \item red\_redpol, 23
  \item red\_Straight, 22
  \item red\_TailRed, 22
  \item red\_TailRedDriver, 22
  \item red\_TopInterreduce, 23
  \item red\_TopRed, 22
  \item red\_TopRedBE, 22
  \item red\_total, 15
  \item red\_TotalRed, 22
  \item Resolve, 7, 30, 42
  \item reverse lexicographic, 8, 9
  \item ring, 13
  \item ring\_2a, 17
  \item ring\_define, 17
  \item ring\_degrees, 17
  \item ring\_ecart, 17
  \item ring\_from\_a, 17
  \item ring\_isnoetherian, 17
  \item ring\_lp, 18
  \item ring\_names, 17
  \item ring\_rlp, 18
  \item ring\_sum, 18
  \item ring\_tag, 17
  \item rules, 16

  \indexspace

  \item savemat, 42
  \item setcaliprintterms, 16
  \item setcalitrace, 8, 15
  \item setdegrees, 12, 16
  \item setgbasis, 8, 42
  \item setideal, 13, 14
  \item setkorder, 18
  \item setmodule, 13, 14
  \item setmonset, 16, 25
  \item setring, 7, 9, 11, 14, 16, 18
  \item setrules, 13, 14, 16, 17, 19
  \item sieve, 42
  \item singular\_locus, 21, 42
  \item stable quotient, 27
  \item sublist, 17
  \item submodulep, 27, 42
  \item switch 
	\subitem bcsimp, 17
	\subitem hardzerotest, 13
	\subitem lexefgb, 16, 27
	\subitem Noetherian, 10, 18
  \item sym, 7, 34, 42
  \item symbolic\_power, 34, 42
  \item syzygies, 24, 42
  \item syzygies1, 24

  \indexspace

  \item tangentcone, 42
  \item term, 19
  \item trace, 16
  \item tracing, 8
  \item triang, 7
  \item triangular systems, 7, 26

  \indexspace

  \item unmixedradical, 32, 42

  \indexspace

  \item varlessp, 17
  \item varnames, 17
  \item varopt, 34, 43

  \indexspace

  \item WeightedHilbertSeries, 8, 29, 30, 43

  \indexspace

  \item zeroprimarydecomposition, 31, 32, 43
  \item zeroprimes, 31, 43
  \item zeroradical, 31, 43
  \item zerosolve, 15, 27, 43
  \item zerosolve1, 15, 27, 43
  \item zerosolve2, 27, 43

\end{theindex}

\pagebreak

\begin{thebibliography}{xxx}
\bibitem{BS} D. Bayer, M. Stillman: Computation of Hilbert
functions. {\it J. Symb. Comp. \bf 14} (1992), 31 - 50.
\bibitem{BKW} T. Becker, H. Kredel, V. Weispfenning: \gr bases. A
computational approach to commutative algebra. Grad. Texts in Math.
141, Springer, New York 1993.
\bibitem{BCRT} A. M. Bigatti, P. Conti, L. Robbiano, C. Traverso: A
``divide and conquer'' algorithm for Hilbert-Poincare series,
multiplicity and dimension of monomial ideals. In: Proc. AAECC-10,
LNCS 673 (1993), 76 - 88.
\bibitem{BGK} W. Boege, R. Gebauer, H. Kredel: Some examples for
solving systems of algebraic equations by calculating \gr bases. {\it
J. Symb. Comp. \bf 2} (1986), 83 - 98.
\bibitem{B1} B. Buchberger: \gr bases: An algorithmic method in
polynomial ideal theory. In: Recent trends in multidimensional
system theory (N.~K.~Bose ed), Reidel, Dortrecht 1985, 184 - 232.
\bibitem{B2} B. Buchberger: Applications of \gr bases in non-linear
computational geometry. LNCS 296 (1988), 52 - 80.
\bibitem{CLO} D. Cox, J. Little, D. O'Shea: Ideals, varieties, and
algorithms.  Undergraduate Texts in Math., Springer, New York 1992.
\bibitem{E} D. Eisenbud: Commutative algebra with a view toward
algebraic geometry. Springer, 1995. 
\bibitem{FGLM} Faugere, Gianni, Lazard, Mora: Efficient computations
of zerodimensional \gr bases by change of ordering. {\it
J. Symb. Comp. \bf 16} (1993), 329 - 344. 
\bibitem{GTZ} P. Gianni, B. Trager, G. Zacharias: \gr bases and
primary decomposition of polynomial ideals. {\it J. Symb. Comp. \bf
6} (1988), 149 - 167.
\bibitem{GMNRT} A. Giovini, T. Mora, G. Niesi, L. Robbiano, C.
Traverso: "One sugar cube, please" or Selection strategies in the
Buchberger algorithm. In: Proceedings of the ISSAC'91, ACM Press
1991, 49 - 54.
\bibitem{rois} H.-G. Gr\"abe: Two remarks on independent sets.
{\it J. Alg. Comb. \bf 2} (1993), 137 - 145. 
\bibitem{tcah} H.-G. Gr\"abe: The tangent cone algorithm and
homogenization. {\it J. Pure Applied Alg.\bf 97} (1994), 303 - 312.

\bibitem{ala} H.-G. Gr\"abe: Algorithms in local algebra. To appear

\bibitem{fgb} H.-G. Gr\"abe: On factorized \gr bases. Report Nr. 6
(1994), Inst. f. Informatik, Univ. Leipzig.

To appear in: Proc. ``Computer Algebra in Science and Engineering'',
Bielefeld 1994.

\bibitem{efgb} H.-G. Gr\"abe: Triangular systems and factorized \gr
bases. Report Nr. 7 (1995), Inst. f. Informatik, Univ. Leipzig.

\bibitem{primary} H.-G. Gr\"abe: Factorized \gr bases and primary
decomposition. To appear. 

\bibitem{Kr} H. Kredel: Primary ideal decomposition. In: Proc.
EUROCAL'87, Lecture Notes in Comp. Sci. 378 (1986), 270 - 281.
\bibitem{KW} H. Kredel, V. Weispfenning: Computing dimension and
independent sets for polynomial ideals. {\it J. Symb. Comp. \bf 6} 
(1988), 231 - 247.
\bibitem{MMM} M. Marinari, H.-M. M\"oller, T. Mora: \gr bases of
ideals given by dual bases. In: Proc. ISSAC'91, ACM Press 1991, 55 -
63.
\bibitem{Mishra} B. Mishra: Algorithmic Algebra. Springer, New York
1993.
\bibitem{MM} H.-M. M\"oller, F. Mora: New constructive methods in
classical ideal theory. {\it J. Alg. \bf 100} (1986), 138 -178.
\bibitem{Moeller} H.-M. M\"oller: On decomposing systems of polynomial
equations with finitely many solutions. {\em J. AAECC \bf 4} (1993),
217 - 230.  
\bibitem{MR88} T. Mora, L. Robbiano: The Gr\"obner fan of an ideal.
{\it J. Symb. Comp. \bf 6} (1988), 183 - 208.
\bibitem{Mo88} T. Mora: Seven variations on standard bases. 
Preprint, Univ. Genova, 1988.
\bibitem{MPT} T. Mora, G. Pfister, C. Traverso: An introduction to
the tangent cone algorithm. In: {\em Issues in non-linear geometry and 
robotics, C.M. Hoffman ed.}, JAI Press.
\bibitem{Ro} L. Robbiano: Computer algebra and commutative algebra.
LNCS 357 (1989), 31 - 44.
\bibitem{Ru} E. W. Rutman: \gr bases and primary decomposition of
modules. {\it J. Symb. Comp. \bf 14} (1992), 483 - 503.

\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/lf.red0000644000175000017500000003633111526203062022517 0ustar  giovannigiovannimodule lf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT
              ###############################
              ####                     ####
              ####  DUAL BASES APPROACH  ####
              ####                     ####
              ###############################

The general idea for the dual bases approach :

Given a finite collection of linear functionals L : M=S^n --> k^N, we
want to compute a basis for Ker L as in

[MMM] : Marinari et al., Proc. ISSAC'91, p. 55-63

This generalizes the approach from

[FGLM] : Faugere, Gianni, Lazard, Mora: JSC 16 (1993), 329 - 344.

L is given through values on the generators,
        {[e_i,L(e_i)], i=1 ... n},
and an evaluation function evlf([p,L(p)],x), that evaluates L(p*x)
from L(p) for p in M and the variable x .

We process a queue of elements of M with increasing leading terms,
evaluating each time L on them. Different to [MMM] the queue is stored
as

   {[p,L(p)], l=list of potential multipliers, lt(p*(x:=first l))}

for the potential evaluation of L(p*x) and sorted by the term order
wrt. the third slot. Since we proceed by increasing lt, Gaussian
elimination doesn't disturb leading terms. Hence leading terms of the
result are linearly independent and thus the result a Groebner basis.

This approach applies to very different problem settings, see
[MMM]. CALI manages this variety of applications through different
values on the property list of 'cali.

There are general entries with information about the computation
        'varlessp -- a sort predicate for lf variable names
        'evlf     -- the evaluation function
and special entries, depending on the problem to be solved.

[p,L(p)] is handled as data type lf (linear functions)
        < dpoly > . < list of (var. name).(base coeff.) >
The lf cdr list is the list of the values of the linear functionals
on the given car lf dpoly.

evlf(lf,var) evaluates lf*var and returns a new lf.

There are the following order functions :
        varlessp        = (cdr lf) variable order
        lf!=sort        = lf queue order
        term order      = (car lf) dpoly order

end comment;

symbolic procedure lf_dualbasis(q);
% q is the dual generator set given as a list of input lf values.
% l is the queue to be processed and updated, g the list of kernel
%       elements, produced so far.
  begin scalar g,l,q,r,p,v,u,vars,rf,q1;
  v:=ring_names cali!=basering;
  if null(rf:=get('cali,'evlf)) then
        rederr"For DUALBASIS no evaluation function defined";
  for each ev1 in q do
     if lf!=zero ev1 then
     << if cali_trace()>20 then dp_print2 car q; g:=car q . g >>
     else
     << vars:=v; q1:=ev1.q1;
        while vars do
        << l:={ev1, vars, mo_from_a car vars}.l; vars:=cdr vars >>;
     >>;
  q:=sort(q1,function lf!=less); % The reducer in triangular order.
  l:=sort(l, function lf!=sort); % The queue in increasing term order.
  while l do
  << r:=car l; l:=cdr l;
     vars:=second r; r:=car r;
     p:=lf!=reduce(apply2(rf,r,car vars),q);
     if lf!=zero p then
     << if cali_trace()>20 then dp_print2 car p; g:=car p . g >>
     else
     << q:=merge({p},q,function lf!=less);
        u:=nil; v:=dp_lmon car p;
        while vars do
        << u:={p,vars,mo_sum(v,mo_from_a car vars)}.u;
           vars:=cdr vars
        >>;
        l:=merge(sort(u,function lf!=sort),l,function lf!=sort);
     >>;
  >>;
  g:=bas_renumber bas_zerodelete for each x in g collect bas_make(0,x);
  return interreduce!* groeb_mingb dpmat_make(length g,0,g,nil,t);
  end;

symbolic procedure lf!=sort(a,b);
% Term order on the third slot. Niermann proposes another order here.
  mo_compare(third a,third b)=-1;

symbolic procedure lf_dualhbasis(q,s);
% The homogenized version.
% s is the length of the dual homogenized basis.
% For modules with column degrees not yet correct.
  begin scalar a,d,g,l,l1,r,p,v,u,vars,rf,q1;
  v:=ring_names cali!=basering; d:=0;
  if null(rf:=get('cali,'evlf)) then
        rederr"For DUALHBASIS no evaluation function defined";
  for each ev1 in q do
     if lf!=zero ev1 then
     << if cali_trace()>20 then dp_print2 car q; g:=car q . g >>
     else
     << vars:=v; q1:=ev1.q1;
        while vars do
        << l:={ev1, vars, mo_from_a car vars}.l; vars:=cdr vars >>;
     >>;
  q:=sort(q1,function lf!=less); % The reducer in triangular order.
  l1:=sort(l,function lf!=sort); % The queue in increasing term order.
  repeat
  << % Initialize the computation of the next degree.
     l:=l1; q:=l1:=nil; d:=d+1;
     while l do
     << r:=car l; l:=cdr l;
        vars:=second r; r:=car r;
        p:=lf!=reduce(apply2(rf,r,car vars),q);
        if lf!=zero p then
        << if cali_trace()>20 then dp_print2 car p;
           g:=bas_make(0,car p) . g
        >>
        else
        << q:=merge({p},q,function lf!=less);
           u:=nil; v:=dp_lmon car p;
           while vars do
           << u:={p,vars,mo_sum(v,mo_from_a car vars)}.u;
              vars:=cdr vars
           >>;
           l1:=merge(sort(u,function lf!=sort),l1,function lf!=sort);
        >>;
        g:=bas_renumber bas_zerodelete g;
        a:=dpmat_make(length g,0,g,nil,t);
     >>;
  >>
  until (d>=s) or ((dim!* a = 1) and (length q = s));
  return interreduce!* groeb_mingb a;
  end;

symbolic procedure lf!=compact u;
% Sort the cdr of the lf u and remove zeroes.
  sort(for each x in u join if not bc_zero!? cdr x then {x},
        function (lambda(x,y);
                     apply2(get('cali,'varlessp),car x,car y)));

symbolic procedure lf!=zero l; null cdr l;

symbolic procedure lf!=sum(a,b);
  dp_sum(car a,car b) . lf!=sum1(cdr a,cdr b);

symbolic procedure lf!=times_bc(z,a);
  dp_times_bc(z,car a) . lf!=times_bc1(z,cdr a);

symbolic procedure lf!=times_bc1(z,a);
  if bc_zero!? z then nil
  else for each x in a collect car x . bc_prod(z,cdr x);

symbolic procedure lf!=sum1(a,b);
  if null a then b
  else if null b then a
  else if equal(caar a,caar b) then
        (if bc_zero!? u then lf!=sum1(cdr a,cdr b)
        else (caar a . u).lf!=sum1(cdr a,cdr b))
        where u:=bc_sum(cdar a,cdar b)
  else if apply2(get('cali,'varlessp),caar a,caar b) then
        (car a).lf!=sum1(cdr a,b)
  else (car b).lf!=sum1(a,cdr b);

symbolic procedure lf!=simp a;
  if null cdr a then car dp_simp car a. nil
  else begin scalar z;
    if (z:=bc_inv lf!=lc a) then return lf!=times_bc(z,a);
    z:=dp_content car a;
    for each x in cdr a do z:=bc_gcd(z,cdr x);
    return (for each x in car a collect car x . bc_quot(cdr x,z)) .
        (for each x in cdr a collect car x . bc_quot(cdr x,z));
    end;

% Leading variable and coefficient assuming cdr a nonempty :

symbolic procedure lf!=lvar a; caadr a;
symbolic procedure lf!=lc a; cdadr a;

symbolic procedure lf!=less(a,b);
        apply2(get('cali,'varlessp),lf!=lvar a,lf!=lvar b);

symbolic procedure lf!=reduce(a,l);
  if lf!=zero a or null l or lf!=less(a, car l) then a
  else if (lf!=lvar a = lf!=lvar car l) then
    begin scalar z,z1,z2,b;
    b:=car l; z1:=bc_neg lf!=lc a; z2:=lf!=lc b;
    if !*bcsimp then
      << if (z:=bc_inv z1) then <>
         else
           << z:=bc_gcd(z1,z2);
              z1:=bc_quot(z1,z);
              z2:=bc_quot(z2,z);
           >>;
      >>;
    a:=lf!=sum(lf!=times_bc(z2,a),lf!=times_bc(z1,b));
    if !*bcsimp then a:=lf!=simp a;
    return lf!=reduce(a,cdr l)
    end
  else lf!=reduce(a,cdr l);

% ------------ Application to point evaluation -------------------

% cali has additionally 'varnames and 'sublist.
% It works also for symbolic matrix entries.

symbolic operator affine_points;
symbolic procedure affine_points m;
% m is an algebraic matrix, which rows are the coordinates of points
% in the affine space with Spec = the current ring.
  if !*mode='algebraic then dpmat_2a affine_points!* reval m
  else affine_points!* m;

symbolic procedure affine_points!* m;
  begin scalar names;
  if length(names:=ring_names cali!=basering) neq length cadr m then
        typerr(m,"coordinate matrix");
  put('cali,'sublist,for each x in cdr m collect pair(names,x));
  put('cali,'varnames, names:=for each x in cdr m collect gensym());
  put('cali,'varlessp,'lf!=pointvarlessp);
  put('cali,'evlf,'lf!=pointevlf);
  return lf_dualbasis(
        { dp_fi 1 . lf!=compact
                for each x in names collect (x . bc_fi 1) });
  end;

symbolic operator proj_points;
symbolic procedure proj_points m;
% m is an algebraic matrix, which rows are the coordinates of _points
% in the projective space with Proj = the current ring.
  if !*mode='algebraic then dpmat_2a proj_points!* reval m
  else proj_points!* m;

symbolic procedure proj_points!* m;
% Points must be different in proj. space. This will not be tested !
  begin scalar u,names;
  if length(names:=ring_names cali!=basering) neq length cadr m then
        typerr(m,"coordinate matrix");
  put('cali,'sublist,u:=for each x in cdr m collect pair(names,x));
  put('cali,'varnames, names:=for each x in cdr m collect gensym());
  put('cali,'varlessp,'lf!=pointvarlessp);
  put('cali,'evlf,'lf!=pointevlf);
  return lf_dualhbasis(
        { dp_fi 1 . lf!=compact
                for each x in names collect (x . bc_fi 1) },
        length u);
  end;

symbolic procedure lf!=pointevlf(p,x);
   begin scalar q; p:=dp_2a (q:=dp_prod(car p,dp_from_a x));
   return q . lf!=compact
        pair(get('cali,'varnames),
        for each x in get('cali,'sublist) collect
                bc_from_a subeval1(x,p));
   end;

symbolic procedure lf!=pointvarlessp(x,y); not ordp(x,y);

% ------ Application to Groebner bases under term order change ----

% ----- The version with borderbases :

% cali has additionally 'oldborderbasis.

put('change_termorder,'psopfn,'lf!=change_termorder);
symbolic procedure lf!=change_termorder m;
  begin scalar c,r;
  if (length m neq 2) then
        rederr "Syntax : Change_TermOrder(dpmat identifier, new ring)";
  if (not idp car m) then typerr(m,"dpmat identifier");
  r:=ring_from_a reval second m;
  m:=car m; intf_get m;
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=change_termorder!*(c,r);
  return dpmat_2a c;
  end;

symbolic procedure change_termorder!*(m,r);
% m must be a zerodimensional gbasis with respect to the current term
% order, r the new ring (with the same var. names).
% This procedure sets r as the current ring and computes a gbasis
% of m with respect to r.
  if (dpmat_cols m neq 0) or not dimzerop!* m then
        rederr("CHANGE_TERMORDER only for zerodimensional ideals")
  else if ring_names r neq ring_names cali!=basering then
        typerr(makelist ring_names r,"variable names")
  else begin scalar b;
  if cali_trace()>20 then print"Precomputing the border basis";
  b:=for each x in odim_borderbasis m collect bas_dpoly x;
  if cali_trace()>20 then print"Borderbasis computed";
  setring!* r;
  put('cali,'oldborderbasis, for each x in b collect
        {mo_neworder dp_lmon x, dp_lc x,dp_neg dp_neworder cdr x});
  put('cali,'varlessp,'lf!=tovarlessp);
  put('cali,'evlf,'lf!=toevlf);
  return lf_dualbasis({dp_fi 1 . dp_fi 1})
  end;

symbolic procedure lf!=tovarlessp(a,b); mo_compare(a,b)=1;

symbolic procedure lf!=toevlf(p,x);
  begin scalar a,b,c,d;
  x:=mo_from_a x; c:=get('cali,'oldborderbasis);
  p:=dp_times_mo(x,car p).dp_times_mo(x,cdr p);
        % Now reduce the terms in cdr p with the old borderbasis.
  for each x in cdr p do
      % b is the list of terms already in canonical form,
      % a is a list of (can. form) . (bc_quot), where bc_quot is
      %         a pair of bc's interpreted as a rational multiplier
      %         for the can. form.
      if d:=assoc(car x,c) then a:=(third d . (cdr x . second d)) .a
      else b:=x.b;
  a:=for each x in a collect car x . lf!=reducebc cdr x;
  d:=lf!=denom a;
  a:=for each x in a collect
                dp_times_bc(bc_quot(bc_prod(d,cadr x),cddr x),car x);
  b:=dp_times_bc(d,reversip b);
  for each x in a do b:=dp_sum(x,b);
  return dp_times_bc(d,car p) . b;
  end;

symbolic procedure lf!=reducebc z;
  begin scalar g;
  if g:=bc_inv cdr z then return bc_prod(g,car z) . bc_fi 1;
  g:=bc_gcd(car z,cdr z);
  return bc_quot(car z,g) . bc_quot(cdr z,g);
  end;

symbolic procedure lf!=denom a;
  if null a then bc_fi 1
  else if null cdr a then cddar a
  else bc_lcm(cddar a,lf!=denom cdr a);

% ----- The version without borderbases :

% cali has additionally 'oldring, 'oldbasis

put('change_termorder1,'psopfn,'lf!=change_termorder1);
symbolic procedure lf!=change_termorder1 m;
  begin scalar c,r;
  if (length m neq 2) then
        rederr "Syntax : Change_TermOrder1(dpmat identifier, new ring)";
  if (not idp car m) then typerr(m,"dpmat identifier");
  r:=ring_from_a reval second m;
  m:=car m; intf_get m;
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=change_termorder1!*(c,r);
  return dpmat_2a c;
  end;

symbolic procedure change_termorder1!*(m,r);
% m must be a zerodimensional gbasis with respect to the current term
% order, r the new ring (with the same var. names).
% This procedure sets r as the current ring and computes a gbasis
% of m with respect to r.
  if (dpmat_cols m neq 0) or not dimzerop!* m then
        rederr("change_termorder1 only for zerodimensional ideals")
  else if ring_names r neq ring_names cali!=basering then
        typerr(makelist ring_names r,"variable names")
  else begin scalar c,d;
  c:=if dpmat_cols m=0 then {dp_fi 1}
        else for k:=1:dpmat_cols m collect dp_from_ei k;
  put('cali,'varlessp,'lf!=tovarlessp1);
  put('cali,'evlf,'lf!=toevlf1);
  put('cali,'oldring,cali!=basering);
  put('cali,'oldbasis,m);
  setring!* r;
  d:=if dpmat_cols m=0 then {dp_fi 1}
        else for k:=1:dpmat_cols m collect dp_from_ei k;
  return lf_dualbasis(pair(d,c))
  end;

symbolic procedure lf!=tovarlessp1(a,b);
  (mo_compare(a,b)=1)
  where cali!=basering=get('cali,'oldring);

symbolic procedure lf!=toevlf1(p,x);
% p = ( a . b ). Returns (c*a*x,d) where (d.c)=mod!*(b*x,m).
  begin scalar a,b,c,d;
  a:=dp_times_mo(mo_from_a x,car p);
  (<< b:=dp_times_mo(mo_from_a x,cdr p);
      b:=mod!*(b,get('cali,'oldbasis));
      d:=car b; c:=dp_lc cdr b;
   >>) where cali!=basering:=get('cali,'oldring);
  return dp_times_bc(c,a) . d;
  end;

endmodule; % lf

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/intf.red0000644000175000017500000002725211526203062023060 0ustar  giovannigiovannimodule intf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

            #####################################
            ###                               ###
            ###  INTERFACE TO ALGEBRAIC MODE  ###
            ###                               ###
            #####################################


  There are two types of procedures :

  The first type takes polynomial lists or polynomial matrices as
  input, converts them into dpmats, computes the result and
  reconverts it to algebraic mode.

  The second type is property driven, i.e. Basis, Gbasis, Syzygies
  etc. are attached via properties to an identifier.
  For them, the 'ring property watches, that cali!=basering hasn't
  changed (including the term order). Otherwise the results must be
  reevaluated using setideal(name,name) or setmodule(name,name) since
  otherwise results may become wrong.

   The switch "noetherian" controls whether the term order satisfies
   the chain condition (default is "on") and chooses either the
   groebner algorithm or the local standard basis algorithm.

END COMMENT;

% ----- The properties managed upto now ---------

fluid '(intf!=properties);

intf!=properties:='(basis ring gbasis syzygies resolution hs
                        independentsets);

% --- Some useful common symbolic procedures --------------

symbolic procedure intf!=clean u;
% Removes all properties.
  for each x in intf!=properties do remprop(u,x);

symbolic procedure intf_test m;
  if (length m neq 1)or(not idp car m) then typerr(m,"identifier");

symbolic procedure intf_get m;
% Get the 'basis.
  begin scalar c;
  if not (c:=get(m,'basis)) then typerr(m,"dpmat variable");
  if not equal(get(m,'ring),cali!=basering) then
                rederr"invalid base ring";
  cali!=degrees:=dpmat_coldegs c;
  return c;
  end;

symbolic procedure intf!=set(m,v);
% Attach the dpmat value v to the variable m.
  << put(m,'ring,cali!=basering);
     put(m,'basis,v);
     if dpmat_cols v = 0 then
       << put(m,'rtype,'list); put(m,'avalue,'list.{dpmat_2a v})>>
     else
       <>;
  >>;

% ------ setideal -------------------

put('setideal,'psopfn,'intf!=setideal);
symbolic procedure intf!=setideal u;
% setideal(name,base list)
  begin scalar l;
  if length u neq 2 then rederr "Syntax : setideal(identifier,ideal)";
  if not idp car u then typerr(car u,"ideal name");
  l:=reval cadr u;
  if not eqcar(l,'list) then typerr(l,"ideal basis");
  intf!=clean(car u);
  put(car u,'ring,cali!=basering);
  put(car u,'basis,l:=dpmat_from_a l);
  put(car u,'avalue,'list.{l:=dpmat_2a l});
  put(car u,'rtype,'list);
  return l;
  end;

% --------------- setmodule -----------------------

put('setmodule,'psopfn,'intf!=setmodule);
symbolic procedure intf!=setmodule u;
% setmodule(name,matrix)
  begin scalar l;
  if length u neq 2 then
        rederr "Syntax : setmodule(identifier,module basis)";
  if not idp car u then typerr(car u,"module name");
  l:=reval cadr u;
  if not eqcar(l,'mat) then typerr(l,"module basis");
  intf!=clean(car u);
  put(car u,'ring,cali!=basering);
  put(car u,'basis,dpmat_from_a l);
  put(car u,'avalue,'matrix.{l});
  put(car u,'rtype,'matrix);
  return l;
  end;

% ------------ setring ------------------------

put('setring,'psopfn,'intf!=setring);
% Setring(vars,term order degrees,tag <,ecart>) sets the internal
% variable cali!=basering. The term order is at first by the degrees
% and then by the tag. The tag must be LEX or REVLEX.
% If ecart is not supplied the ecart is set to the default, i.e. the
% first degree vector (noetherian degree order) or to (1 1 .. 1).
% The ring may also be supplied as a list of its arguments as e.g.
% output by "getring".
symbolic procedure intf!=setring u;
  begin
  if length u = 1 then u:=cdr reval car u;
  if not(length u member '(3 4)) then
    rederr "Syntax : setring(vars,term order,tag[,ecart])";
  setring!* ring_from_a ('list . u);
  return ring_2a cali!=basering;
  end;

% ----------- getring --------------------

put('getring,'psopfn,'intf!=getring);
% Get the base ring of an object as the algebraic list
% {vars,tord,tag,ecart}.

symbolic procedure intf!=getring u;
  if null u then ring_2a cali!=basering
  else begin scalar c; c:=get(car u,'ring);
    if null c then typerr(car u,"dpmat variable");
    return ring_2a c;
    end;


% ------- The algebraic interface -------------

symbolic operator ideal2mat;
symbolic procedure ideal2mat m;
% Convert the list of polynomials m into a matrix column.
  if !*mode='symbolic then rederr"only for algebraic mode"
  else if not eqcar(m,'list) then typerr(m,'list)
  else 'mat . for each x in cdr m collect {x};

symbolic operator mat2list;
symbolic procedure mat2list m;
% Flatten the matrix m.
  if !*mode='symbolic then rederr"only for algebraic mode"
  else if not eqcar(m,'mat) then typerr(m,'matrix)
  else 'list . for each x in cdr m join for each y in x collect y;

put('setgbasis,'psopfn,'intf!=setgbasis);
symbolic procedure intf!=setgbasis m;
% Say that the basis is already a Gbasis.
  begin scalar c;
  intf_test m; m:=car m; c:=intf_get m;
  put(m,'gbasis,c);
  return reval m;
  end;

symbolic operator setdegrees;
symbolic procedure setdegrees m;
% Set a term list as actual column degrees. Execute this before
% setmodule to supply a module with prescribed column degrees.
  if !*mode='symbolic then rederr"only for algebraic mode"
  else begin scalar i,b;
  b:=moid_from_a reval m; i:=0;
  cali!=degrees:= for each x in b collect <>;
  return moid_2a for each x in cali!=degrees collect cdr x;
  end;

put('getdegrees,'psopfn,'intf!=getdegrees);
symbolic procedure intf!=getdegrees m;
  begin
  if m then <>;
  return moid_2a for each x in cali!=degrees collect cdr x
  end;

symbolic operator getecart;
symbolic procedure getecart;
  if !*mode='algebraic then makelist ring_ecart cali!=basering
  else ring_ecart cali!=basering;

put('gbasis,'psopfn,'intf!=gbasis);
symbolic procedure intf!=gbasis m;
  begin scalar c,c1;
  intf_test m; m:=car m; c1:=intf_get m;
  if (c:=get(m,'gbasis)) then return dpmat_2a c;
  c:=gbasis!* c1;
  put(m,'gbasis,c);
  return dpmat_2a c;
  end;

symbolic operator setmonset;
symbolic procedure setmonset m;
  if !*mode='algebraic then makelist setmonset!* cdr reval m
  else setmonset!* m;

symbolic procedure setmonset!* m;
  if subsetp(m,ring_names cali!=basering) then cali!=monset:=m
  else typerr(m,"monset list");

symbolic operator getmonset;
symbolic procedure getmonset(); makelist cali!=monset;

put('resolve,'psopfn,'intf!=resolve);
symbolic procedure intf!=resolve m;
  begin scalar c,c1,d;
  intf_test m; if length m=2 then d:=reval cadr m else d:=10;
  m:=car m; c1:=intf_get m;
  if ((c:=get(m,'resolution)) and (car c >= d)) then
        return makelist for each x in cdr c collect dpmat_2a x;
  c:=Resolve!*(c1,d);
  put(m,'resolution,d.c);
  if not get(m,'syzygies) then put(m,'syzygies,cadr c);
  return makelist for each x in c collect dpmat_2a x;
  end;

put('syzygies,'psopfn,'intf!=syzygies);
symbolic procedure intf!=syzygies m;
  begin scalar c,c1;
  intf_test m; m:=car m; c1:=intf_get m;
  if (c:=get(m,'syzygies)) then return dpmat_2a c;
  c:=syzygies!* c1;
  put(m,'syzygies,c);
  return dpmat_2a c;
  end;

put('indepvarsets,'psopfn,'intf!=indepvarsets);
symbolic procedure intf!=indepvarsets m;
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'independentsets)) then
    return makelist for each x in c collect makelist x;
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=indepvarsets!* c;
  put(m,'independentsets,c);
  return makelist for each x in c collect makelist x;
  end;

put('getleadterms,'psopfn,'intf_getleadterms);
symbolic procedure intf_getleadterms m;
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=getleadterms!* c;
  return dpmat_2a c;
  end;

put('hilbertseries,'psopfn,'intf!=hilbertseries);
symbolic procedure intf!=hilbertseries m;
% Returns the Hilbert series of m.
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'hs)) then return mk!*sq c;
  if not(c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  put(m,'hs,c:=hilbertseries!* c);
  return mk!*sq c;
  end;

put('degree,'psopfn,'intf_getmult);
symbolic procedure intf_getmult m;
% Returns the multiplicity of m.
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'hs)) then return hf_mult c;
  if not(c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  put(m,'hs,c:=hilbertseries!* c);
  return hf_mult c;
  end;

put('dim,'psopfn,'intf!=dim);
put('codim,'psopfn,'intf!=codim);
symbolic procedure intf!=dim m;
% Returns the dimension of coker m.
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'hs)) then return hf_dim c;
  if (c:=get(m,'independentsets)) then return length moid_max c;
  if not(c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  c:=indepvarsets!* c; put(m,'independentsets,c);
  return length moid_max c;
  end;

symbolic procedure intf!=codim m;
% Returns the codimension of coker m.
  length ring_names cali!=basering - intf!=dim m;

put('BettiNumbers,'psopfn,'intf!=BettiNumbers);
symbolic procedure intf!=BettiNumbers m;
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'resolution)) then return makelist BettiNumbers!* cdr c
  else rederr"Compute a resolution first";
  end;

put('GradedBettiNumbers,'psopfn,'intf!=GradedBettiNumbers);
symbolic procedure intf!=GradedBettiNumbers m;
  begin scalar c;
  intf_test m; m:=car m; intf_get m;
  if (c:=get(m,'resolution)) then return
    makelist for each x in GradedBettiNumbers!* cdr c collect makelist x
  else rederr"Compute a resolution first";
  end;

put('degsfromresolution,'psopfn,'intf!=degsfromresolution);
symbolic procedure intf!=degsfromresolution m;
  begin scalar c;
  intf_test m; m:=car m;
  if not equal(get(m,'ring),cali!=basering) then
        rederr"invalid base ring";
  if not (c:=get(m,'resolution)) then
        rederr"compute a resolution first";
  return makelist for each x in cdr c collect
            moid_2a for each y in dpmat_coldegs x collect cdr y;
  end;

symbolic operator sieve;
symbolic procedure sieve(m,vars);
% Sieve out all base elements from m containing one of the variables
% in vars in their leading term.
  if !*mode='algebraic then
        dpmat_2a dpmat_sieve(dpmat_from_a reval m,cdr vars,nil)
  else dpmat_sieve(m,vars,nil);

endmodule; % intf

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/groebf.red0000644000175000017500000006141311526203062023361 0ustar  giovannigiovannimodule groebf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment

                ##############################
                ###                        ###
                ###   GROEBNER FACTORIZER  ###
                ###                        ###
                ##############################

The Groebner algorithm with factorization and constraint lists.

New in version 2.2 :

        syntax for groebfactor
        listgroebfactor!*
        extendedgroebfactor!*

There are two versions of the extended groebner factorizer.
One needs the lex. term order, the other supports arbitrary ones (the
default). Switch between both versions via switch lexefgb.

Internal data structure

        result::={dpmat, constraint list }

        extendedresult::=
                {dpmat, constraint list, (dimension | indepvarset) }

        problem::={dpmat, constraint list, pair list, easydim}

        aggregate::=
        { (list of problems) , (list of results) }

For a system with constraints m=(b,c) V(m)=V(b,c) denotes the zero set
V(b)\setminus D(c).

The Groebner algorithm supports only the classical reduction
principle.

end Comment;

% --- The side effect switching lexefgb on or off :

put('lexefgb,'simpfg,'((t (put 'cali 'efgb 'lex))
        (nil (remprop 'cali 'efgb))));


symbolic procedure groebf!=problemsort(a,b);
% Sorted by ascending easydim to force depth first search.
   (nth(a,4) third b;

put('groebfactor,'psopfn,'intf!=groebfactor);
symbolic procedure intf!=groebfactor m;
  begin scalar bas,con;
  bas:=dpmat_from_a reval first m;
  if length m=1 then con:=nil
  else if length m=2 then
        con:=for each x in cdr reval second m collect dp_from_a x
  else rederr("Syntax : GROEBFACTOR(base list [,constraint list])");
  return makelist
        for each x in groebfactor!*(bas,con) collect dpmat_2a first x;
  end;

symbolic operator listgroebfactor;
symbolic procedure listgroebfactor l;
% l is a list of polynomial systems. We look for the union of the
% solution sets.
   if !*mode='algebraic then
        makelist for each x in listgroebfactor!*
                for each y in cdr reval l collect dpmat_from_a y
        collect dpmat_2a x
   else listgroebfactor!* l;

symbolic procedure listgroebfactor!* l;
% Proceed a whole list of dpmats at once.
   begin scalar gbs;
   gbs:=for each x in
        groebf!=preprocess(nil,for each x in l collect {x,nil})
                collect groebf!=initproblem x;
   gbs:=sort(gbs,function groebf!=problemsort);
   return for each x in groebf!=masterprocess(gbs,nil) collect first x;
   end;

symbolic procedure groebfactor!*(bas,poly);
% Returns a list l of results (b,c) such that
%       V(bas,poly) = \union { V(b,c) : (b,c) \in l }

   if dpmat_cols bas > 0 then
        rederr "GROEBFACTOR only for ideal bases"
   else if null !*noetherian then
        rederr "GROEBFACTOR only for noetherian term orders"
   else if dpmat_zero!? bas then list({bas,poly})
   else begin scalar gbs;
   if cali_trace() > 5 then
   << write"GROEBFACTOR the system "; dpmat_print bas >>;
   gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
                groebf!=initproblem x;
   gbs:=sort(gbs,function groebf!=problemsort);
   return groebf!=masterprocess(gbs,nil);
   end;

put('extendedgroebfactor,'psopfn,'intf!=extendedgroebfactor);
symbolic procedure intf!=extendedgroebfactor m;
  begin scalar bas,con;
  bas:=dpmat_from_a reval first m;
  if length m=1 then con:=nil
  else if length m=2 then
        con:=for each x in cdr reval second m collect dp_from_a x
  else rederr
          "Syntax : EXTENDEDGROEBFACTOR(base list [,constraint list])";
  return makelist
        for each x in extendedgroebfactor!*(bas,con) collect
                makelist {first x,makelist second x,makelist third x};
  end;

symbolic procedure extendedgroebfactor!*(bas,poly);
% Returns a list l of extendedresults (b,c,vars) in prefix form such
% that      V(bas,poly) = \union { V(b,c) : (b,c) \in l }
% and b:<\prod c> is puredimensional with independent variable set vars.

   if dpmat_cols bas > 0 then
        rederr "EXTENDEDGROEBFACTOR only for ideal bases"
   else if null !*noetherian then
        rederr "EXTENDEDGROEBFACTOR only for noetherian term orders"
   else if dpmat_zero!? bas then
        list({dpmat_2a bas,nil,ring_names cali!=basering})
   else begin scalar gbs;
   if cali_trace() > 5 then
   << write"EXTENDEDGROEBFACTOR the system "; dpmat_print bas >>;
   gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
                groebf!=initproblem x;
   return groebf!=extendedmasterprocess gbs;
   end;

symbolic procedure groebf!=extendedmasterprocess gbs;
% gbs is a list of problems to process. Returns a list of
% extendedresults in prefix form.
% If {m,con,vars} is such an extendedresult then m:<\prod con> is the
% (puredimensional) recontraction of m\tensor k(vars).
   begin scalar res,res1,u;
   while gbs or res do
     if gbs then
     % The hard postprocessing is done only at the end.
     << gbs:=sort(gbs,function groebf!=problemsort);
        % Convert results to extendedresults and sort them :
        res:=for each x in groebf!=masterprocess(gbs,res) collect
                if (length x=3) then x
                else {first x,second x,dim!* first x};
        res:=sort(res,function groebf!=resultsort);
        gbs:=nil
      >>
      else % Do the first (hard) postprocessing
      << % process result by result :
         u:=groebf!=postprocess2 car res; res:=cdr res;
         % Extract and preprocess new problems from u.
         % This needs descent by dimension of the results proceeded.
         gbs:=for each x in groebf!=preprocess(res,second u)
                        collect groebf!=initproblem x;
         % Extract extendedresults from u.
         % They may be non-GB wrt t h i s  term order, see above.
         res1:=nconc(first u,res1);
      >>;
   return res1;
   end;

% --------- Another version of the extended Groebner factorizer -------
put('extendedgroebfactor1,'psopfn,'intf!=extendedgroebfactor1);
symbolic procedure intf!=extendedgroebfactor1 m;
  begin scalar bas,con;
  bas:=dpmat_from_a reval first m;
  if length m=1 then con:=nil
  else if length m=2 then
        con:=for each x in cdr reval second m collect dp_from_a x
  else rederr
          "Syntax : EXTENDEDGROEBFACTOR1(base list [,constraint list])";
  return makelist
        for each x in extendedgroebfactor1!*(bas,con) collect
                makelist {first x,makelist second x,makelist third x};
  end;

symbolic procedure extendedgroebfactor1!*(bas,poly);
% Returns a list l of extendedresults (b,c,vars) in prefix form such
% that      V(bas,poly) = \union { V(b,c) : (b,c) \in l }
% and b:<\prod c> is puredimensional with independent variable set vars.

   if dpmat_cols bas > 0 then
        rederr "EXTENDEDGROEBFACTOR1 only for ideal bases"
   else if null !*noetherian then
        rederr "EXTENDEDGROEBFACTOR1 only for noetherian term orders"
   else if dpmat_zero!? bas then
        list({dpmat_2a bas,nil,ring_names cali!=basering})
   else begin scalar gbs;
   if cali_trace() > 5 then
   << write"EXTENDEDGROEBFACTOR1 the system "; dpmat_print bas >>;
   gbs:=for each x in groebf!=preprocess(nil,list {bas,poly}) collect
                groebf!=initproblem x;
   return for each x in groebf!=extendedmasterprocess1 gbs collect
                nth(x,4);
   end;

symbolic procedure groebf!=extendedmasterprocess1 gbs;
% Version that computes the retraction of each intermediate result
% to apply FGB shortcuts. gbs is a list of problems to process.
% Returns a list of extendedresults in prefix form.
% If {m,con,vars} is such an extendedresult then m:<\prod con> is the
% (puredimensional) recontraction of m\tensor k(vars).
% internally they are incorporated into res as
%       {dpmat, nil (since no constraints), dim, prefix form}.
   begin scalar res,u,v,p;
   while gbs or
        (p:=listtest(res,nil,function (lambda(x,y); length x<4))) do
     if gbs then
     % The hard postprocessing is done only at the end.
     << gbs:=sort(gbs,function groebf!=problemsort);
        % Convert results to extendedresults and sort them :
        res:=for each x in groebf!=masterprocess(gbs,res) collect
                if (length x>2) then x
                else {first x,second x,dim!* first x};
        res:=sort(res,function groebf!=resultsort);
        gbs:=nil
      >>
      else % Do the first (hard) postprocessing
      << % process result by result :
         u:=groebf!=postprocess2 p; res:=delete(p,res);
         % Extract extendedresults from u and convert them
         % with postprocess3 to quotient ideals.
         v:=for each x in first u collect
                {groebf!=postprocess3 x, nil, length third x,x};
         for each y in v do
           if not groebf!=redtest(res,y) then
                res:=merge({y},groebf!=sieve(res,y),
                        function groebf!=resultsort);
         % Extract and preprocess new problems from u.
         gbs:=for each x in groebf!=preprocess(res,second u) collect
                        groebf!=initproblem x;
       >>;
   return res;
   end;

% ------- end of the second version ------------------------

symbolic procedure groebf!=masterprocess(gbs,res);
% gbs = list of problems, res = list of results (since several times
% involved in the extendedmasterprocess).
% Returns a list of results already postprocessed with (the easy)
% groebf!=postpocess1 where the elements surviving from res may
% change only in the constraints part.
   begin scalar u,v;
   while gbs do
   << if cali_trace()>10 then
                print for each x in gbs collect nth(x,4);
      u:=groebf!=slave car gbs; gbs:=cdr gbs;
      if u then % u is an aggregate.
      << % postprocess the result part returning a list of aggregates.
         v:=for each x in second u collect groebf!=postprocess1(res,x);
         % split up into the problems u and results v
         u:=nconc(car u,for each x in v join car x);
         v:=for each x in v join second x;
         for each y in v do
           if cali_trace() > 5 then
           << write"partial result :"; terpri();
              dpmat_print car y ;
               prin2"constraints : ";
               for each x in second y do dp_print2 x;
           >>;
         for each y in v do
           if not groebf!=redtest(res,y) then
                res:=y . groebf!=sieve(res,y);
         for each x in u do
           if not groebf!=redtest(res,x) then
                gbs:=merge({x},groebf!=sieve(gbs,x),
                                function groebf!=problemsort);
         if cali_trace()>20 then
            << terpri(); write length gbs," remaining branches. ",
               length res," partial results"; terpri()
            >>;
       >>
      else % branch discarded
        if cali_trace()>20 then print"Branch discarded";
   >>;
   return res;
   end;

symbolic procedure groebf!=initproblem x;
% Converts a result into a problem.
  list(car x,second x, groeb_makepairlist(dpmat_list car x,t),
                easydim!* car x);

% The following two procedures make destructive changes
% on the cdr of some of the list elements.

symbolic procedure groebf!=redtest(a,c);
% Ex. u \in a : car u \submodule car c ?
% If so, update the constraints of u.
  begin scalar u;
  u:=listtest(a,c,function(lambda(x,y); submodulep!*(car x,car y)));
  if u then cdr u:=intersection(second u,second c).cddr u;
  return u;
  end;

symbolic procedure groebf!=sieve(a,c);
% Remove u \in a with car c \submodule car u
% and update the constraints of c.
  for each x in a join if not submodulep!*(car c,car x) then {x}
     else << cdr c:=intersection(second x,second c).cddr c; >>;

symbolic procedure groebf!=test(con,m);
% nil <=> ex. f \in con : f mod m = 0. m is a baslist.
  if null m then t
  else if dp_unit!? bas_dpoly first m then nil
  else if null con then t
  else begin scalar p; p:=t;
    while p and con do
    << p:=p and bas_dpoly car red_redpol(m,bas_make(0,car con));
       con:=cdr con
    >>;
    return p;
    end;

symbolic procedure groebf!=newcon(r,d);
% r=(m,c) is a result, d a list of polynomials. Returns the
% (slightly optimized) result list ( (m+(p),c+(q|q>;
    end;

symbolic procedure groebf!=preprocess(a1,b);
% Try to split (factor) each polynomial in each problem of the list b.
% Returns a list of results.
% a1 is a list of results already computed.

  begin scalar a,c,d,back,u;
    if cali_trace()>20 then prin2"preprocessing started";
    while b do
    << if cali_trace()>20 then
       << terpri(); write length a," ready. ";
          write length b," left."; terpri()
       >>;
       c:=car b; b:=cdr b;
       if not (null groebf!=test(second c,dpmat_list car c)
            or groebf!=redtest(a1,c)
            or groebf!=redtest(a,c)) then
       << d:=dpmat_list car c; back:=nil;
          while d and not back do
          << u:=((fctrf numr simp dp_2a bas_dpoly car d)
                        where !*factor=t);
             if (length u>2) or (cdadr u>1) then
             << back:=t;
                b:=append(groebf!=newcon(c,
                        for each y in cdr u collect
                                dp_from_a prepf car y),b);
             >>
             else d:=cdr d
          >>;
          if not back then
          << if cali_trace()>20 then
             << terpri(); write"Subproblem :"; dpmat_print car c >>;
             if not groebf!=redtest(a,c) then a:=c . groebf!=sieve(a,c);
          >>
       >>
    >>;
    if cali_trace()>20 then prin2"preprocessing finished...";
    return a;
    end;

symbolic procedure groebf!=slave c;
% Proceed upto the first splitting. Returns an aggregate.
  begin scalar be,back,p,u,v,a,b,gb,pl,nr,pol,con;

  back:=nil;
  gb:=bas_sort dpmat_list first c;
  con:=second c; pl:=third c; nr:=length gb;
  while pl and not back do
  << p:=car pl; pl:=cdr pl;
     if cali_trace() > 10 then groeb_printpair(p,pl);

     pol:=groeb_spol p;
     if cali_trace() > 70 then
     << terpri(); write"S.-pol : "; dp_print2 bas_dpoly pol >>;
     pol:=bas_dpoly car red_redpol(gb,pol);
     if cali_trace() > 70 then
     << terpri(); write"Reduced S.-pol. : "; dp_print2 pol >>;

     if pol then
     << if !*bcsimp then pol:=car dp_simp pol;
        if dp_unit!? pol then
        << if cali_trace()>20 then print "unit ideal";
           back:=t
        >>
        else
        << % -- factorize pol
           u:=((fctrf numr simp dp_2a pol) where !*factor=t);
           nr:=nr+1;
           if length cdr u=1 then % only one factor
           << pol:=dp_from_a prepf caadr u;
              be:=bas_make(nr,pol);
              u:=be.gb;
              if null groebf!=test(con,u) then
              << back:=t;
                 if cali_trace()>20 then print" zero constraint";
              >>
              else
              << if cali_trace()>20 then
                 << terpri(); write nr,". "; dp_print2 pol >>;
                 pl:=groeb_updatePL(pl,gb,be,t);
                 if cali_trace() > 30 then
                 << terpri(); groeb_printpairlist pl >>;
                 gb:=merge(list be,gb,function red_better);
              >>
           >>
           else % more than one factor
           << for each x in cdr u do
              << pol:=dp_from_a prepf car x;
                 be:=bas_make(nr,pol);
                 a:=be.gb;
                 if groebf!=test(con,a) then
                 << if cali_trace()>20 then
                    << terpri(); write nr; write". "; dp_print2 pol >>;
                    p:=groeb_updatePL(append(pl,nil),gb,be,t);
                    if cali_trace() > 30 then
                    << terpri(); groeb_printpairlist p >>;
                    b:=merge(list be,append(gb,nil),
                        function red_better);
                    b:=dpmat_make(length b,0,b,nil,nil);
                    v:={b,con,p}.v;
                 >>
                 else if cali_trace()>20 then print" zero constraint";
                 if not member(pol,con) then con:=pol . con;
              >>;
              if null v then
                << if cali_trace()>20 then print "Branch canceled";
                   back:=t
                >>
              else if length v=1 then
              << c:=car v; gb:=dpmat_list first c; con:=second c;
                 pl:=third c; v:=nil;
              >>
              else
              << back:=t;
                 if cali_trace()>20 then
                 << write" Branching into ",length v," parts ";
                    terpri();
                 >>;
              >>;
           >>;
        >>;
     >>;
  >>;
  if not back then % pl exhausted => new partial result.
      return
      {nil,list {groeb_mingb dpmat_make(length gb,0,gb,nil,t),con}}
  else if v then return
        {for each x in v collect
                {first x,second x,third x,easydim!* first x},
        nil}
  else return nil;
  end;

symbolic procedure groebf!=postprocess1(res,x);
% Easy postprocessing a result. Returns an aggregate.
% res is a list of results, already obtained.

  begin scalar p,r,v;

     % ---- interreduce and try factorization once more.

     if !*red_total then
     << v:=groebf!=preprocess(res,
                list {dpmat_make(dpmat_rows car x,0,
                   red_straight dpmat_list car x,nil,
                                dpmat_gbtag car x),
                        second x});
        if (length v=1) and dpmat_gbtag caar v then r:=v
        else p:=for each x in v collect groebf!=initproblem x;
     >>
     else r:={x};
     return {p,r};
     end;

symbolic procedure groebf!=postprocess2 m;
  (begin scalar d,vars,u,v,c1,m1,m1a,m2,p,con;
    con:=second m; d:=third m; m:=first m;
    v:=moid_goodindepvarset m;
    if neq(length v,d) then
                rederr"In POSTPROCESS2 the dimension is wrong";
    if null v then return
        {for each x in groebf!=zerosolve(m,con)
            collect {x,nil,nil},nil};

    % -- Prepare data for change to dimension zero :
    % Recompute gbases wrt. the elimination order for u and
    % take only those components for which v remains independent.

    vars:=ring_names(c1:=cali!=basering);
    u:=setdiff(vars,v);
    if get('cali,'efgb)='lex then setring!* ring_lp(c1,u)
    else setring!* ring_rlp(c1,u);
    m1:=for each u in groebfactor!*(dpmat_neworder(m,nil),
                for each x in con collect dp_neworder x) collect
        {first u,second u,dim!* first u};
    for each x in m1 do
      if (third x = d) and member(v,indepvarsets!* car x)
        then m1a := x . m1a
      else m2:=x.m2;
      % m1a : components with indepvarset v
      % m2  : components with v being dependent variables.

    % -- Change to dimension zero.

    m1:=for each x in m1a collect
        {dpmat_2a first x,for each p in second x collect dp_2a p};
    if get('cali,'efgb)='lex then
        setring!* ring_define(u,nil,'lex,for each x in u collect 1)
    else setring!* ring_define(u,degreeorder!* u,'revlex,
                                for each x in u collect 1);
    m1:=for each x in m1 collect
        {groeb_mingb dpmat_from_a first x,
                for each p in second x collect dp_from_a p};

    % Extract the lc's of the lifted Groebner bases and save them
    % for NewCon on the list m1a, since in the zerodimensional part
    % lc's are assumed to be invertible.
    m1a:=pair(m1a,for each x in m1 collect groebf!=elcbe first x);

    % Compute the zerodimensional TriangSets from m1 and their lists
    % of lc's and prepare them for lifting.
    m1:=for each x in m1 join groebf!=zerosolve(first x,second x);
    m1:=for each x in m1 collect {x,groebf!=elcbe dpmat_from_a x};

    % -- Lift all stuff back to c1.

    setring!* c1;

    % Extract the TriangSets as extendedresults in prefix form (!).
    m1:=for each x in m1 collect {first x,second x,v};

    % List of new problems found during recomputation of GB :
    m2:=for each x in m2 collect
        {dpmat_neworder(first x,nil),
         for each y in second x collect dp_neworder y};

    % List of new problems, derived from nonzero conditions for
    % lc's in dimension zero.
    m1a:=for each x in m1a join
        groebf!=newcon({dpmat_neworder(first car x,nil),
                 for each p in second car x collect dp_neworder p},
        for each p in cdr x collect dp_from_a p);

Comment The list of results :

m1 : The list of TriangSets wrt. v produced in this run. They are in
alg. prefix form to remember that they are Groebner bases only
wrt. the pure lex. term order.

m2 : Results (in prefix form), for which v is dependent.

m1a : Branches, where some of the critical lc's of the TriangSets
      vanish.

Both m2 and m1a should be returned in the pool of problems.

end comment;

    return {m1,nconc(m1a,m2)};
   end)
   where cali!=degrees:=cali!=degrees,
                cali!=basering:=cali!=basering;

symbolic procedure groebf!=elcbe(m);
% Extract list of leading coefficients in algebraic prefix form
% from base elements of the dpmat m.
   for each x in dpmat_list m join
        if domainp dp_lc bas_dpoly x then {}
        else {bc_2a dp_lc bas_dpoly x};

symbolic procedure groebf!=postprocess3 u;
% Compute for the extendedresult u={m,con,vars} in prefix form
%       m:<\prod con>.
   matqquot!*(dpmat_from_a first u,
        groebf!=prod for each x in second u collect dp_from_a x);

symbolic procedure groebf!=prod l;
  begin scalar p; p:=dp_fi 1;
  l:=listminimize(for each x in l join dp_factor x,function equal);
  for each x in l do p:=dp_prod(x,p);
  return p;
  end;

symbolic procedure groebf!=zerosolve(m,con);
% Hook for the zerodimensional solver.
% Input : m = zerodimensional dpmat (not to be checked),
%       con = list of dpoly constraints.
% Output : a list of dpmats in prefix form.
  begin scalar u;
  % Look up the constraints, since during the change to dimension zero
  % some of them may trivialize :
  con:=for each x in con join if not dp_unit!? x then {x};
  % Factorized radical computation.
  u:=groebf_zeroprimes1(m,con);
  % Apply the zerosolver to each of these results.
  return for each x in u join
        if get('cali,'efgb)='lex then zerosolve!* x else zerosolve1!* x;
  end;

symbolic procedure groebf_zeroprimes1(m,con);
% Returns a list of gbases for the zerodimensional ideal m,
% incorporating as in the Groebner factorizer the factors of the
% univariate polynomials in m according to such variables, that don't
% appear as leading terms in m.
  begin scalar m1,m2,p,u,l;
  l:=list {m,con};
  for each x in ring_names cali!=basering do
  << m1:=m2:=nil;
     for each y in l do

        % The following checks, whether x is a leading term of first
        % y. Such x may be skipped, since embedding dimension may be
        % reduced. On the other hand, computing univariate polynomials
        % for them is often quite nasty.

        if not member(x,for each v in dpmat_list first y join
                {mo_linear dp_lmon bas_dpoly v}) then
     << p:=odim_up(x,first y); u:=dp_factor p;
        if (length u>1) or not equal(first u,p) then
                m1:=nconc(groebf!=newcon(y,u),m1)
        else m2:=y.m2;
     >>
        else m2:=y.m2;
     l:=groebf!=masterprocess(
        sort(for each x in m1 collect groebf!=initproblem x,
                function groebf!=problemsort),
        m2);
  >>;
  return for each x in l join
        if second x then {matqquot!*(first x,groebf!=prod second x)}
        % Here one can use the linear algebra quotient algorithm, since
        % first x is known to be zerodimensional radical.
        else {first x};
    end;

endmodule; % groebf

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/cali/odim.red0000644000175000017500000001542111526203062023043 0ustar  giovannigiovannimodule odim;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

                ##########################################
                ##                                      ##
                ##   Applications to zerodimensional ##
                ##      ideals and modules.               ##
                ##                                      ##
                ##########################################

getkbase returns a k-vector space basis of S^c/M,
odim_borderbasis computes a borderbasis of M,
odim_up finds univariate polynomials in zerodimensional ideals.

END COMMENT;

% -------------- Test for zero dimension -----------------
% For a true answer m must be a gbasis.

put('dimzerop,'psopfn,'odim!=zerop);
symbolic procedure odim!=zerop m;
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  if dimzerop!* c then return 'yes else return 'no;
  end;

symbolic procedure dimzerop!* m; null odim_parameter m;

symbolic procedure odim_parameter m;
% Return a parameter of the dpmat m or nil, if it is zerodimensional
% or (1).
  odim!=parameter moid_from_dpmat m;

symbolic procedure odim!=parameter m;
  if null m then nil
  else odim!=parameter1 cdar m or odim!=parameter cdr m;

symbolic procedure odim!=parameter1 m;
  if null m then
        ((if u then car u else u)
        where u:= reverse ring_names cali!=basering)
  else if mo_zero!? car m then nil
  else begin scalar b,u;
  u:=for each x in m join if length(b:=mo_support x)=1 then b;
  b:=reverse ring_names cali!=basering;
  while b and member(car b,u) do b:=cdr b;
  return if b then car b else nil;
  end;

% --- Get a k-base of F/M as a list of monomials ----
% m must be a gbasis for the correct result.

put('getkbase,'psopfn,'odim!=evkbase);
symbolic procedure odim!=evkbase m;
  begin scalar c;
  intf_test m; intf_get(m:=car m);
  if not (c:=get(m,'gbasis)) then
        put(m,'gbasis,c:=gbasis!* get(m,'basis));
  return moid_2a getkbase!* c;
  end;

symbolic procedure getkbase!* m;
  if not dimzerop!* m then rederr"dpmat not zerodimensional"
  else for each u in moid_from_dpmat m join
        odim!=kbase(mo_from_ei car u,ring_names cali!=basering,cdr u);

symbolic procedure odim!=kbase(mo,n,m);
  if moid_member(mo,m) then nil
  else mo . for each x on n join
                odim!=kbase(mo_inc(mo,car x,1),append(x,nil),m);

% --- Produce an univariate polynomial inside the ideal m ---

symbolic procedure odim_up(a,m);
% Returns a univariate polynomial (of smallest possible degree if m
% is a gbasis) in the variable a inside the zerodimensional ideal m.
% Uses Buchberger's approach.
  if dpmat_cols m>0 or not dimzerop!* m then
      rederr"univariate polynomials only for zerodimensional ideals"
  else if not member(a,ring_names cali!=basering) then
    typerr(a,"variable name")
  else if dpmat_unitideal!? m then dp_fi 1
  else begin scalar b,v,p,l,q,r;
    % l is a list of ( p(a) . NF p(a) ), sorted by lt NF p(a)
    p:=(dp_fi 1 . dp_fi 1); b:=dpmat_list m;  v:=mo_from_a a;
    while cdr p do
      << l:=merge(list p,l,function odim!=greater);
         q:=dp_times_mo(v,car p);
         r:=red_redpol(b,bas_make(0,dp_times_mo(v,cdr p)));
         p:=odim!=reduce(dp_prod(cdr r,q) . bas_dpoly car r,l);
      >>;
    return
    if !*bcsimp then car dp_simp car p
    else car p;
    end;

symbolic procedure odim!=greater(a,b);
    mo_compare(dp_lmon cdr a,dp_lmon cdr b)=1;

symbolic procedure odim!=reduce(a,l);
  if null cdr a or null l or odim!=greater(a, car l) then a
  else if mo_equal!?(dp_lmon cdr a,dp_lmon cdar l) then
    begin scalar z,z1,z2,b;
    b:=car l; z1:=bc_neg dp_lc cdr a; z2:=dp_lc cdr b;
    if !*bcsimp then
      << if (z:=bc_inv z1) then <>
         else
           << z:=bc_gcd(z1,z2);
              z1:=car bc_divmod(z1,z);
              z2:=car bc_divmod(z2,z);
           >>;
      >>;
    a:=dp_sum(dp_times_bc(z2,car a),dp_times_bc(z1,car b)) .
           dp_sum(dp_times_bc(z2,cdr a),dp_times_bc(z1,cdr b));
    return odim!=reduce(a,cdr l)
    end
  else odim!=reduce(a,cdr l);

% ------------------------- Borderbasis -----------------------

symbolic procedure odim_borderbasis m;
% Returns a border basis of the zerodimensional dpmat m as list of
% base elements.
  if not !*noetherian then
        rederr"BORDERBASIS only for non noetherian term orders"
  else if not dimzerop!* m then
        rederr"BORDERBASIS only for zerodimensional ideals or modules"
  else begin scalar b,v,u,mo,bas;
  bas:=bas_zerodelete dpmat_list m;
  mo:=for each x in bas collect dp_lmon bas_dpoly x;
  v:=for each x in ring_names cali!=basering collect mo_from_a x;
  u:=for each x in bas collect
        {dp_lmon bas_dpoly x,red_tailred(bas,x)};
  while u do
  << b:=append(b,u);
     u:=listminimize(
        for each x in u join
            for each y in v join
                (begin scalar w; w:=mo_sum(first x,y);
                if not listtest(b,w,function(lambda(x,y);car x=y))
                        and not odim!=interior(w,mo) then
                        return {{w,y,bas_dpoly second x}}
                end),
        function(lambda(x,y);car x=car y));
     u:=for each x in u collect
        {first x,
        red_tailred(bas,bas_make(0,dp_times_mo(second x,third x)))};
  >>;
  return bas_renumber for each x in b collect second x;
  end;

symbolic procedure odim!=interior(m,mo);
% true <=> monomial m is in the interior of the moideal mo.
  begin scalar b; b:=t;
  for each x in mo_support m do
        b:=b and moid_member(mo_diff(m,mo_from_a x),mo);
  return b;
  end;

endmodule; % odim

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/0000755000175000017500000000000011722677356021657 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solve.red0000644000175000017500000002163411526203062023466 0ustar  giovannigiovannimodule solve;   % Solve one or more algebraic equations.

% Author: David R. Stoutemyer.
% Major modifications by: David Hartley, Anthony C. Hearn, Herbert
% Melenk, Donald R. Morrison and Rainer Schoepf.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(solve solve1 ppsoln solvelnr glsolve solvealg solvetab
                  quartic),nil);

% Other packages needed by solve package.

load!-package 'matrix;

fluid '(!*exp !*ezgcd !*multiplicities !!gcd dmode!* vars!*);

fluid '(inside!-solveeval solve!-gensymcounter);

% solve!-gensymcounter := 1;

global '(multiplicities!* assumptions requirements);

flag('(multiplicities!* assumptions requirements),
     'share);

% Those switches that are on are now set in entry.red.

% !*multiplicities      Lists all roots with multiplicities if on.
%  !!gcd                SOLVECOEFF returns GCD of powers of its arg in
%                       this.  With the decompose code, this should
%                       only occur with expressions of form x^n + c.

algebraic operator one_of;

put('arbint,'simpfn,'simpiden);

% algebraic operator arbreal;

symbolic operator expand_cases;

symbolic procedure simp!-arbcomplex u;
    simpiden('arbcomplex . u) where dmode!*=nil;

deflist('((arbcomplex simp!-arbcomplex)),'simpfn);


% ***** Utility Functions *****

symbolic procedure freeofl(u,v);
   null v or freeof(u,car v) and freeofl(u,cdr v);

symbolic procedure allkern elst;
   % Returns list of all top-level kernels in the list of standard
   % quotients elst.   Corrected 5 Feb 92 by Francis Wright.
   if null elst then nil
    else union(kernels numr car elst, allkern cdr elst);

symbolic procedure topkern(u,x);
   % Returns list of top level kernels in the standard form u that
   % contain the kernel x;
   for each j in kernels u conc if not freeof(j,x) then list j else nil;

symbolic procedure coeflis ex;
   % Ex is a standard form.  Returns a list of the coefficients of the
   % main variable in ex in the form ((expon . coeff) (expon . coeff)
   % ... ), where the expon's occur in increasing order, and entries do
   % not occur of zero coefficients.  We need to reorder coefficients
   % since kernel order can change in the calling function.
   begin scalar ans,var;
      if domainp ex then return (0 . ex);
      var := mvar ex;
      while not domainp ex and mvar ex=var do
        <>;
      if ex then ans := (0 . reorder ex) . ans;
      return ans
   end;


% ***** Evaluation Interface *****

% Solvemethods!* is a list of procedures which are able to process
% one problem class. Each of its members must check itself
% whether it can be applied or not. The classical equation solver
% is called if none of the methods can contribute.
%
% Protocol:
%
%   input: PSOPFN standard, where the elements of the input list
%          have been passed through REVAL.
%
%   output:
%          'nil: the algorithm cannot be applied because the problem
%               belongs to a different problem class;
%          '(failed): the problem belongs to the class represented
%               by the algorithm but the program has been
%               unable to compute a result. The problem should
%               not be given to any other method - instead the
%               input should be returned.
%          result: the algorithm has been successful and the final
%               result is returned as algebraic form (including an
%               eventually empty result for an "inconsistent" case).

fluid '(solvemethods!*);

put('solve,'psopfn,'solveeval);

symbolic procedure solveeval u;
   % U is a list of prefix expressions. Result is an expression
   % (list  ... ), where  is of the form
   % (equal  , solutions of u viewed as equations
   % or >;
      return if null r then solveeval1 w
        else if eqcar(r,'failed) then 'solve . u
        else r
   end;

% Links to other packages.

symbolic procedure odesolve!* u;
   % 2 arg solve => algebraic always (otherwise cannot algebraically
   % solve an equation involving a derivative!)
   length u neq 2 and smemq('df,u) and
   <>;

solvemethods!* := union('(odesolve!*),solvemethods!*);

symbolic procedure solveeval1 u;
   begin scalar !*ezgcd,!!gcd,vars!*;  integer nargs;
      if atom u then rerror(solve,1,"SOLVE called with no equations")
       else if null dmode!* then !*ezgcd := t;
      nargs := length u;
      if not inside!-solveeval then
      <>;
      u := (if nargs=1 then solve0(car u,nil)
              else if nargs=2 then solve0(car u, cadr u)
              else <>)
             where inside!-solveeval = t, !*resimp = not !*exp;
      if not inside!-solveeval then
      <>;
      return !*solvelist2solveeqlist u
    end;

symbolic procedure !*solvelist2solveeqlist u;
   begin scalar x,y,z;
      u := for each j in u collect solveorder j;
      for each j in u do
         < 1 then x := 'list . x else x := car x;
           z := (caddr j . x) . z>>;
      z := sort(z,function ordp);
      x := nil;
      if !*multiplicities
         then <>
       else <>;
              multiplicities!* := 'list . reversip y>>;
      % Now check for redundant solutions.
%     if length vars!*>1 then z := check_solve_redundancy z;
      return 'list . reversip x
   end;

symbolic procedure solveorder u;
   % Put solve solutions in same order as specified variables.
   begin scalar v,w,x,y,z;
      v := vars!*;
      x := cadr u;      % SOLVE variable order.
      % Check if there are less variables than specified.
      if length x>;
      w := v;
  a:  if null w then return reversip x . v . cddr u
       else if null(y := depassoc(car w,z)) then return u
       else x := cdr y . x;
      w := cdr w;
      go to a
   end;

symbolic procedure depassoc(u,v);
   if null v then nil
    else if u = caar v then car v
    else if depends(caar v,u) then nil   % Can't change order.
    else depassoc(u,cdr v);

% symbolic procedure check_solve_redundancy u;
%     % We assume all solutions are prefixed by LIST.
%     begin scalar x,y;
%        x := for each j in u collect cdr j;   %  Remove the LIST.
%        for each j in u do if not supersetlist(cdr j,x) then y:= j . y;
%        return reversip!* y
%     end;

% symbolic procedure supersetlist(u,v);
%    % Returns true if u is a non-equal superset of any element of v.
%    v and
%      (u neq car v and null setdiff(car v,u) or supersetlist(u,cdr v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solvelnr.red0000644000175000017500000001755011526203062024204 0ustar  giovannigiovannimodule solvelnr; % Code for solving a general system of linear eqns.

% Authors: Anthony C. Hearn and Eberhard Schruefer.
% Modifications by: David Hartley.

% Based on code by David R. Stoutemyer modified by Donald R. Morrison.

% Copyright (c) 1993 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The number of equations and the number of unknowns are arbitrary.
% I.e. the system can be under- or overdetermined.

fluid '(!*cramer !*exp !*solvesingular asymplis!* wtl!*
        !*arbvars !*trsparse !*varopt bareiss!-step!-size!*);

% switch solveinconsistent;

% !*solveinconsistent := t; % Default value.

symbolic procedure solvelnrsys(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvelnrsys: tagged solution list
   % Check the system for sparsity, then decide whether to use the
   % Cramer or Bareiss method.  Using the Bareiss method on sparse
   % systems, 4-step elimination seems to be faster than 2-step.
   % The Bareiss code is not good at handling surds at the moment,
   % hence exptexpflistp test.
   begin scalar w,x;
   if w := solvesparsecheck(exlis,varlis) then exlis := w
     else exlis := exlis . varlis;
%  There used to be a bug in quotfexf!*1 that required exptexpflistp.
%  This shouldn't be needed now.
%  if null !*cramer and null exptexpflistp car exlis
   if null !*cramer
      and null errorp(x :=
           errorset2{'solvebareiss,mkquote car exlis, mkquote cdr exlis}
                      where bareiss!-step!-size!* = if w then 4 else 2)
     then exlis := car x
    else exlis := solvecramer(car exlis,cdr exlis);
   return solvesyspost(exlis,varlis)
   end;

symbolic procedure exptexpflistp u;
   %  True if any of u contains an expt kernel.
   u and (exptexpfp car u or exptexpflistp cdr u);

symbolic procedure exptexpfp u;
   % True if u contains an expt kernel.
   not domainp u
      and ((eqcar(x,'expt) or exptexpfp lc u or exptexpfp red u)
           where x = mvar u);

symbolic procedure solvesyspost(exlis,varlis);
   % exlis: tagged solution list, varlis: list of kernel
   %  -> solvesyspost: tagged solution list
   % Insert arbitrary constants and present
   % solutions in same order as in varlis.
   % Also reorders expressions to prevailing kernel order.
   car exlis . foreach s in cdr exlis collect
      if car s and null cadr s then s else
      begin scalar arbvars,z;
      if !*arbvars or (null cadr s and length varlis = 1) then
         arbvars := foreach v in setdiff(varlis,cadr s) collect
                       v . mvar makearbcomplex()
      else
         varlis := intersection(varlis,cadr s);
      z := pair(cadr s,sublis(arbvars,car s));
      z := append(z,foreach p in arbvars collect car p . !*k2q cdr p);
      return {foreach v in varlis collect reordsq cdr atsoc(v,z),
              varlis,caddr s};
      end;

symbolic procedure solvecramer(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvecramer: tagged solution list
   % Just a different name at the moment.
   glnrsolve(exlis,varlis);

symbolic procedure solvesparsecheck(sys,vl);
   % sys: list of sf, vl: list of kernel
   % -> solvesparsecheck: nil or {list of sf,list of kernel}
   % This program checks for a sparse linear system. If the
   % system is sparse enough, it returns (exlis.varlis) reordered
   % such that a maximum triangular upper diagonal form is
   % established. Otherwise the result is NIL.
   begin scalar vl1,xl,sys1,q,x,y;
         integer sp;

   % First collect a list vl1 where each variable is followed
   % by the number of equations where it occurs, and then
   % by the number of other variables which occur in these
   % equations (connectivity). At the same time, collect a measure
   % of the sparsity.
   sp:=0;
   vl1:= for each x in vl collect x . 0 . nil;
   foreach q in sys do
      foreach x in (xl := intersection(topkerns q,vl)) do
       <>;
   foreach p in vl1 do
      cddr p := length cddr p - 1; % could drop the -1

   % Drop out if density > 80%
   if sp > length sys * length vl * 0.8 then
    <>;

   % If varopt is on, sort variables first by least occurrences and then
   % least connectivity, but allow dependency to override.
   % Reset kernel order and reorder equations.
   if !*trsparse then
     solvesparseprint("Original sparse system",sys,vl);

   if !*varopt then
   << vl1 := sort(vl1,function solvevarordp);
      vl1 := foreach x in vl1 collect car x;
      vl1 := solvevaradjust vl1;
      foreach k in reverse vl1 do updkorder k;
      sys := for each q in sys collect reorder q >>
   else vl1 := foreach x in vl1 collect car x;

   % Next sort equations in ascending order of their first variable
   % and then descending order of the next variable.
   sys1:= (nil . nil) . foreach x in vl1 collect x . nil;
   foreach q in sys do
      <>;
   foreach p in cdr sys1 do
      if cdr p then cdr p := sort(cdr p, function solvesparsesort);

   % Finally split off a leading diagonal system and push the remaining
   % equations down.
   sys := nconc(foreach p in sys1 join if cdr p then {cadr p},
                reversip foreach p in sys1 join if cdr p then cddr p);
   if !*trsparse then
      solvesparseprint("Variables and/or equations rearranged",sys,vl1);
   return sys . vl1
   end;

symbolic procedure solvevarordp(x,y);
   cadr x < cadr y or
   cadr x = cadr y and cddr x < cddr y;

symbolic procedure solvevaradjust u;
   % u:list of kernel -> solvevaradjust:list of kernel
   % Adjust ordering of u to respect dependency ordering by recursively
   % putting variables with no dependencies last
   begin scalar v,y;
   if null u then return nil;
   v := foreach x in u join
              << y := assoc(x,depl!*);
            if null y or null xnp(cdr y,u) then {x} >>;
   return nconc(solvevaradjust setdiff(u,v),v)
   end;

symbolic procedure solvesparseprint(text,sys,vl);
   <>>>;

symbolic procedure topkerns u;
   % u:sf -> topkerns:list of kernel
   % kernels in top level of u
   if domainp u then nil else mvar u . topkerns red u;

symbolic procedure solvesparsesort(x,y);
   % x,y: sf -> solvesparsesort: bool
   if domainp x then nil
   else if domainp y then t
   else if mvar x = mvar y then solvesparsesort(red y,red x)
   else if ordop(mvar x,mvar y) then t
   else nil;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/ineq.red0000644000175000017500000001073411526203062023271 0ustar  giovannigiovannimodule ineq; % Inequalities and linear optimization.

% Author:       Herbert Melenk 

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Driver for solving inequalities and inequality systems.

% Implemented methods:
%
%   -  linear multivariate system
%   -  polynomial/rational univariate inequality and system

% version 2: Jul 2003 Adaptation of the actual REDUCE language stand.
%            Return an isolated equation if only one inequality is
%            entered.

% Common algebraic interface:
%
%     ineq_solve( [,])

create!-package('(ineq linineq liqsimp1 liqsimp2 polineq),'(solve));

load!-package'solve;  % Some routines from solve are needed.

fluid'(solvemethods!*);

if not memq('ineqseval,solvemethods!*) then
      solvemethods!*:='ineqseval!*!*.SOlvemethods!*;

if not get('geq,'simpfn) then
    <>;

if not get('!*interval!*,'simpfn) then
    <>;

symbolic procedure ineqseval!*!* u;
 % Interface to solve.
  (if null w then nil
    else if w='(failed) then if smemql('(leq geq lessp greaterp),u)
      then w else nil else w)where w=ineqseval u;

symbolic procedure ineqseval!* u;
 % Interface to ineq_solve.
  (if null w or w='(failed) then car u else w)where w=ineqseval u;

put('ineq_solve,'psopfn,'ineqseval!*);

symbolic procedure ineqseval u;
  begin scalar s,s1,v,v1,l,w1,w2,err,ineqp,str;
   integer n;
   s:=reval car u;
   s:=if eqcar(s,'list) then cdr s else {s};
   if cdr u then
   <>else
     u:=append(u,{ggvars s});
   % test for linearity, collect variables.
   l:=t;
   s1:=for each q in s join if not err then
   <>>>;
   if err or not ineqp then return nil;
   if null v then v:=v1;
   l:=l and not nonlnrsys(s1,v);
   if length v1 > length v or not subsetp(v,v1) or not l and cdr v1 then
       return'(failed); % Too many indeterminates in inequality system;
   if l and str then
       return'(failed); % No strict linear system.
   u:=if l then linineqseval u else polineqeval u;
   if null cdr u then u:={'list} else if null cddr u then u:=cadr u;
   return u end;

symbolic procedure ggvars s;
begin scalar v;
 for each u in s do v:=ggvars1(u,v);
 if v then(v:=if null cdr v then car v else 'list.v);
 return v end;

symbolic procedure ggvars1(u,v);
   if not atom u and car u member '(leq geq lessp greaterp equal)
     then ggvars2(cadr u,ggvars2(caddr u,v))
    else nil;

symbolic procedure ggvars2(u,v);
if null u or numberp u or(u eq'i and !*complex)then v
 else if atom u then if u member v then v else u.v
 else if car u memq'(plus times expt difference minus quotient)
  then ggvars3(cdr u,v)
 else if u member v then v else u.v;

symbolic procedure ggvars3(u,v);
if null u then v else ggvars3(cdr u,ggvars2(car u,v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/nonlnr.red0000644000175000017500000000504011526203062023635 0ustar  giovannigiovannimodule nonlnr; % Interface to Groebner code for solving non-linear eqns.

% Authors: Anthony C. Hearn and Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trnonlnr vars!*);

global '(loaded!-packages!*);

switch trnonlnr;

symbolic procedure solvenonlnrsys(u,vars!*);
   % Solve list of expressions u with respect to variable list vars!*.
   begin scalar solutions,p,s;
      if not('groebner memq loaded!-packages!*)
        then load!-package 'groebner;
      if !*trnonlnr then lprim "Entering Groebner ...";
      solutions :=
         groesolveeval(list('list . for each x in u collect prepf x,
                            'list . vars!*));
      if !*trnonlnr then lprim "Leaving Groebner ...";
      % Reform result so that !*solvelist2solveeqlist understands it.
%     return for each solu in cdr solutions collect
      return t . for each solu in cdr solutions collect
           <>)
                    . (for each eqn in cdr solu collect cadr eqn)
                    . list 1
           >>;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/liqsimp2.red0000644000175000017500000001657611526203062024107 0ustar  giovannigiovannimodule liqsimp2; % interval simplification level2 by
                 % removal of non-tight hyperplanes.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



fluid'(infinities!*);

symbolic procedure liqsimp2!-maxmin w;
 % W is a list of forms {x.x0 , l , u} where the interval [l,u]
 % has been assigned to the variable x. l and u may be formal
 % expressions dominated by an operator MAX or MIN and including
 % variables of the following intervals. I try to simplify the
 % bounds as far as possible by computing inequality chains.
  begin scalar r;
    infinities!* := {simp 'infinity, simp '(minus infinity)};
    w:= for each q in w collect
      {car q, minmax2ql cadr q, minmax2ql caddr q};
     r:= liqsimp2!-maxmin1 w;
    return for each q in r collect
      {car q, ql2minmax('max,cadr q),ql2minmax('min,caddr q)};
  end;

symbolic procedure ql2minmax(m,l);
  <>;

symbolic procedure minmax2ql(l);
  if pairp l and car l memq '(min max) then
     for each q in cdr l collect simp q else {simp l};

symbolic procedure liqsimp2!-maxmin1 w;
   if null w then nil else
   liqsimp2!-reducecases(car w,liqsimp2!-maxmin1 cdr w);


symbolic procedure liqsimp2!-reducecases(w,ll);
 % ll is alreayd a simplified chain of intervals.
  begin scalar x,l,u,t1,e1,e2,pts,eqns,y;
   x:=caar w; l:=cadr w; u:=caddr w;
   if null cdr l and null cdr u then return w.ll;

     % If I have more than one inequality in the upper
     % or lower part, I compute all pairwise crossing point
     % because these form the new contribution to the edges.
     % An inequality which has no valid point can be excluded
     % from the set. I may ignore infinite points because each
     % line must have at least two points.
   eqns := for each q in delete(car infinities!*,
              delete(cadr infinities!*,append(l,u)))
      collect {q};
     % Compute crossing points.
   t1:=eqns;
   while t1 and cdr t1 do
   <>>>;
   l:=for each q in l join
     if null (y:=assoc(q,eqns)) or cdr y then {q};
   u:=for each q in u join
     if null (y:=assoc(q,eqns)) or cdr y  then {q};
   return{car w,l,u}.ll;
  end;

symbolic procedure liqsimp2_mk_edges(x,e1,e2,l,u,ll);
  % x: current variable,
  % e1,e2: forms defining an edge contribution in x=e1,x=e2 at their
  %        intersection points. e1,e2 free of x.
  % l:     complete lower bounds for x,
  % u:     complete upper bounds for x,
  % ll:    simplified bounds for the lower variables.
 begin scalar form,pts,pl;
   form := subtrsq(e1,e2);
   pl := liqsimp2_mk_edges1(form,ll);
   pts := liqsimp2_mk_edges_check(pl,x,e1,l,u);
   return pts;
  end;

symbolic procedure sfnegativep u;
  if domainp u then minusf u else
  if mvar u = 'infinity then sfnegativep lc u else
  typerr(prepf u,"numeric expression");

symbolic procedure liqsimp2_mk_edges1(f,ll);
  % check f=0 by substituting the hyperplanes in ll.
  if null ll and null numr f then '(nil)
   else
     if null ll then typerr (prepsq f,"soll nicht vorkommen")
   else
  begin scalar fx,fxx,t1,x,l,u,points,pl;
    x:=caaar ll; l:=cadar ll; u:=caddar ll; ll:=cdr ll;
    t1 := delete(car infinities!*,
              delete(cadr infinities!*,append(l,u)));
    if null t1 then t1:='((nil . 1));
    fx:=liqsimp2_mk_edges2(f,x);
    fxx := '(nil . 1);

    points:= if null fx then
       % case 1: f does not depend of x. I must extend all
       % solutions of f wrt the remaining variables
       % by all possible edges from the interval bounds for x.
    <>
    else
      if domainp numr fx then
       % case 2: f has the solution x=a where a does not depend
       % of any further variable. I must select those
       % extensions of x=a which are compatible under the local
       % inequalities.
    << pl:=liqsimp2_mk_edges1(fxx,ll);
       pl := liqsimp2_mk_edges_check(pl,x,fx,l,u);
      pl>>
    else
       % case 3: f depends of x and some more variables.
       % I compute all possible intrsection points with the
       % current interval bounds and extend the to solutions
       % with the remaining variables.
      for each p in t1 join
    <>;
    return points;
   end;

symbolic procedure liqsimp2_mk_edges_check(pl,x,fx,l,u);
 % select those points of pl where sub(x=p,fx) is compatible
 % with the l and u bounds. Extend the compatible points by
 % a value for x.
  for each p in pl join
  begin scalar fine,x1;
   fine:=t;
   x1:=subsq(fx,p);
   for each l1 in l do
      if fine and sfnegativep numr subtrsq(x1,subsq(l1,p)) then
         fine:=nil;
   for each u1 in u do
      if fine and sfnegativep numr subtrsq(subsq(u1,p),x1) then
         fine:=nil;
   return if fine then {(x.prepsq x1).p};
  end;

symbolic procedure liqsimp2_mk_edges2(f,x);
  % solve f(x)=0 for linear standard quotient f. Return
  % nil if x does not occur in f.
  if not smemq(x,f) then nil else
  begin scalar w;
    w:=(reorder numr f) where kord!*={x};
    return quotsq(negf red w./ 1,lc w ./ 1) ;
  end;

% ============= printing ================================

symbolic procedure linineqprint1(text,lh,rh);
         <= ",nil);
           writepri(mkquote prepsq rh,'last)>>;


symbolic procedure linineqprint2(text,prob);
    <>;

symbolic procedure linineqprint3(text,res);
    <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/modroots.red0000644000175000017500000001250711526203062024203 0ustar  giovannigiovannimodule modroots; % Roots of a univariate polynomial mod m,
                 % m not necessarily prime.

% Author: Herbert Melenk, ZIB Berlin.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Algebraic interface: m_roots(polynomial, modulus);

symbolic procedure modroots0(f,m);
 % f: univariate standard form with modular coeffients,
 % m: positive integer modulus.
 % Algorithm: compute roots modulo the biggest factor of m
 % and lift these for the remaining factors. During lifing
 % the number of factors may change in both directions.
 begin scalar ml;
   ml := sort(for each q in zfactor m join
                for i:=1:cdr q collect car q,'lessp);
   return sort(modroots1(f,ml),'lessp);
 end;

symbolic procedure modroots1(f,ml);
   if null cdr ml then modroots2(f,car ml,nil) else
  begin scalar f1,p,q,pq,r,s,x,y;
    p:=car ml; ml:=cdr ml;
    r := modroots1(f,ml);
    if null r then return nil;
    x:=mvar f; y:=gensym();
    q:=for each m in ml product m;
    pq:=p*q;
     % lift roots to p*q:
     %   if f(r)=0 mod q, solve f(n*q+r)=0 mod p.
    for each w in r do
    <>;
    >>;
    return s;
  end;

symbolic procedure modroots2(f,p,rec);
  if domainp f and f then nil
  else if null f then
    if p=2 and rec then '(-1 0 1)
      else for i:=0:(p-1) collect i
  else if p=2 then modroots4(f,t,rec)
  else modroots3(f,p);

symbolic procedure x!*!*p!-w(x,p,w);
  % Make a form x^p - w mod p.
    general!-difference!-mod!-p(x .** p .*1 .+ nil,w);

symbolic procedure modroots3(f,current!-modulus);
 % Roots of a polynomial f mod p, p prime.
 % Algorithm:
 % H. Cohen: Computational Algebraic Number theory, 1.6.1
 begin scalar a,d,p,r,x;  integer n;

     % From now on, we compute with untagged modular coefficients
     % using the routines in "factor/modpoly".
   p := current!-modulus;
   f := general!-reduce!-mod!-p f;
   x := mvar f;

     % gcd(f, x^p - x)
   a := general!-gcd!-mod!-p(f , x!*!*p!-w(x,p,!*k2f x));
   d := ldeg a;
   n := lowestdeg(a,x,0);
   if n>0 then
   <>;
   return append(r,modroots31(a,x,p));
 end;

symbolic procedure modroots31(a,x,p);
  begin scalar a0,a1,a2,b,d,e,s,w;

  s2:
   if domainp a then return nil;
   if ldeg a = 1 then
      return {general!-modular!-quotient(
                 if red a then general!-modular!-minus red a else 0,
                 lc a)};
   if ldeg a = 2 then
   <<
     a2:=lc a; a:=red a;
     if not domainp a then
     <> else a1:=0;
     a0:=if null a then 0 else a;
     d:=general!-modular!-difference(
           general!-modular!-times(a1,a1),
           general!-modular!-times(4,general!-modular!-times(a0,a2)));
     s:=legendre!-symbol(d,p);
     if s=-1 then return nil;
     e:= modsqrt(d,p);
     a2:=general!-modular!-reciprocal general!-modular!-plus(a2,a2);
     a1:=general!-modular!-minus a1;
     return
      {general!-modular!-times(general!-modular!-plus(a1,e),a2),
       general!-modular!-times(general!-modular!-difference(a1,e),a2)};
   >>;

   s3:
    e:=random(p);
      % compute gcd[x ^((p-1)/2) - 1, A(x - e)]
    w:=x!*!*p!-w(x,(p-1)/2,1);
    a1:=general!-reduce!-mod!-p numr subf(a,{x.{'difference,x,e}});
    b:=general!-gcd!-mod!-p(w,a1);
    if domainp b or ldeg b = ldeg a then go to s3;

   s4:
     % Compute both root groups and transform roots back to x - e;
    return
    for each w in union(modroots31(general!-quotient!-mod!-p(a1,b),x,p),
                        modroots31(b,x,p))
       collect general!-modular!-difference(w,e)
 end;

symbolic procedure modroots4(f,w,rec);
  % roots of f mod 2: count terms.
  if domainp f then
  <<
   if f then w:=not w;
   append(
    if null f then '(0),
    if w then (if rec then '(-1 1) else '(1))
         )
  >>
  else modroots4(red f,not w,rec);

put('m_roots,'psopfn,
      function(lambda(u);
               'list . modroots0(numr simp car u,reval cadr u)));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solve.rlg0000644000175000017500000023677011527635055023525 0ustar  giovannigiovanniFri Feb 18 21:27:14 2011 run on win32
% Demonstration of the REDUCE SOLVE package.

on fullroots;

   % To get complete solutions.

% Simultaneous linear fractional equations.

solve({(a*x+y)/(z-1)-3,y+b+z,x-y},{x,y,z});


      - 3*(b + 1)
{{x=--------------,
        a + 4

      - 3*(b + 1)
  y=--------------,
        a + 4

      - a*b - b + 3
  z=----------------}}
         a + 4



% Use of square-free factorization together with recursive use of
% quadratic and binomial solutions.

solve((x**6-x**3-1)*(x**5-1)**2*x**2);


Unknown: x

    2*sqrt( - sqrt(5) - 5) + sqrt(10) - sqrt(2)
{x=---------------------------------------------,
                     4*sqrt(2)

     - 2*sqrt( - sqrt(5) - 5) + sqrt(10) - sqrt(2)
 x=------------------------------------------------,
                      4*sqrt(2)

    2*sqrt(sqrt(5) - 5) - sqrt(10) - sqrt(2)
 x=------------------------------------------,
                   4*sqrt(2)

     - 2*sqrt(sqrt(5) - 5) - sqrt(10) - sqrt(2)
 x=---------------------------------------------,
                     4*sqrt(2)

 x=1,

 x=0,

                    1/3
    ( - sqrt(5) + 1)   *(sqrt(3)*i - 1)
 x=-------------------------------------,
                     1/3
                  2*2

                       1/3
     - ( - sqrt(5) + 1)   *(sqrt(3)*i + 1)
 x=----------------------------------------,
                       1/3
                    2*2

                    1/3
    ( - sqrt(5) + 1)
 x=---------------------,
            1/3
           2

                 1/3
    (sqrt(5) + 1)   *(sqrt(3)*i - 1)
 x=----------------------------------,
                    1/3
                 2*2

                    1/3
     - (sqrt(5) + 1)   *(sqrt(3)*i + 1)
 x=-------------------------------------,
                     1/3
                  2*2

                 1/3
    (sqrt(5) + 1)
 x=------------------}
           1/3
          2


multiplicities!*;


{2,2,2,2,2,2,1,1,1,1,1,1}



% A singular equation without and with a consistent inhomogeneous term.

solve(a,x);


{}


solve(0,x);


{x=arbcomplex(1)}


off solvesingular;



solve(0,x);


{}



% Use of DECOMPOSE to solve high degree polynomials.

solve(x**8-8*x**7+34*x**6-92*x**5+175*x**4-236*x**3+226*x**2-140*x+46);


Unknown: x

    sqrt( - sqrt( - 4*sqrt(3) - 3) - 3)*sqrt(2) + 2
{x=-------------------------------------------------,
                           2

     - sqrt( - sqrt( - 4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=----------------------------------------------------,
                            2

    sqrt( - sqrt(4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=----------------------------------------------,
                         2

     - sqrt( - sqrt(4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=-------------------------------------------------,
                           2

    sqrt(sqrt( - 4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=----------------------------------------------,
                         2

     - sqrt(sqrt( - 4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=-------------------------------------------------,
                           2

    sqrt(sqrt(4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=-------------------------------------------,
                        2

     - sqrt(sqrt(4*sqrt(3) - 3) - 3)*sqrt(2) + 2
 x=----------------------------------------------}
                         2


solve(x**8-88*x**7+2924*x**6-43912*x**5+263431*x**4-218900*x**3+
           65690*x**2-7700*x+234,x);


{x=sqrt( - i + 116) + 11,

 x= - sqrt( - i + 116) + 11,

 x=sqrt(i + 116) + 11,

 x= - sqrt(i + 116) + 11,

 x=4*sqrt(7) + 11,

 x= - 4*sqrt(7) + 11,

 x=2*sqrt(30) + 11,

 x= - 2*sqrt(30) + 11}



% Recursive use of inverses, including multiple branches of rational
% fractional powers.

solve(log(acos(asin(x**(2/3)-b)-1))+2,x);


                 1                        1
{x=sqrt(sin(cos(----) + 1) + b)*(sin(cos(----) + 1) + b),
                  2                        2
                 e                        e

                    1                        1
 x= - sqrt(sin(cos(----) + 1) + b)*(sin(cos(----) + 1) + b)}
                     2                        2
                    e                        e



% Square-free factors that are unsolvable, being of fifth degree,
% transcendental, or without a defined inverse.

operator f;



solve((x-1)*(x+1)*(x-2)*(x+2)*(x-3)*(x*log(x)-1)*(f(x)-1),x);


{f(x) - 1=0,

 x=root_of(log(x_)*x_ - 1,x_,tag_2),

 x=3,

 x=2,

 x=1,

 x=-1,

 x=-2}


multiplicities!*;


{1,1,1,1,1,1,1}



% Factors with more than one distinct top-level kernel, the first factor
% a cubic. (Cubic solution suppressed since it is too messy to be of
% much use).

off fullroots;



solve((x**(1/2)-(x-a)**(1/3))*(acos x-acos(2*x-b))* (2*log x
          -log(x**2+x-c)-4),x);


     2            4          4     2
    e *(sqrt(4*c*e  - 4*c + e ) - e )
{x=-----------------------------------,
                   4
               2*(e  - 1)

        2            4          4     2
     - e *(sqrt(4*c*e  - 4*c + e ) + e )
 x=--------------------------------------,
                     4
                 2*(e  - 1)

                      2/3
 x=root_of(( - a + x_)    - x_,x_,tag_7),

 x=b}


on fullroots;



% Treatment of multiple-argument exponentials as polynomials.

solve(a**(2*x)-3*a**x+2,x);


    2*arbint(3)*i*pi + log(2)
{x=---------------------------,
             log(a)

    2*arbint(2)*i*pi
 x=------------------}
         log(a)



% A 12th degree reciprocal polynomial that is irreductible over the
% integers, having a reduced polynomial that is also reciprocal.
% (Reciprocal polynomials are those that have symmetric or antisymmetric
% coefficient patterns.) We also demonstrate suppression of automatic
% integer root extraction.

solve(x**12-4*x**11+12*x**10-28*x**9+45*x**8-68*x**7+69*x**6-68*x**5+
45*x**4-28*x**3+12*x**2-4*x+1);


Unknown: x

    sqrt( - sqrt(5) - 3)
{x=----------------------,
          sqrt(2)

     - sqrt( - sqrt(5) - 3)
 x=-------------------------,
            sqrt(2)

    2*sqrt( - sqrt(3)*i - 9) - sqrt(6)*i + sqrt(2)
 x=------------------------------------------------,
                      4*sqrt(2)

     - 2*sqrt( - sqrt(3)*i - 9) - sqrt(6)*i + sqrt(2)
 x=---------------------------------------------------,
                        4*sqrt(2)

    2*sqrt( - 3*sqrt(5) - 1) - sqrt(10) + 3*sqrt(2)
 x=-------------------------------------------------,
                       4*sqrt(2)

     - 2*sqrt( - 3*sqrt(5) - 1) - sqrt(10) + 3*sqrt(2)
 x=----------------------------------------------------,
                        4*sqrt(2)

    2*sqrt(sqrt(3)*i - 9) + sqrt(6)*i + sqrt(2)
 x=---------------------------------------------,
                     4*sqrt(2)

     - 2*sqrt(sqrt(3)*i - 9) + sqrt(6)*i + sqrt(2)
 x=------------------------------------------------,
                      4*sqrt(2)

    2*sqrt(3*sqrt(5) - 1) + sqrt(10) + 3*sqrt(2)
 x=----------------------------------------------,
                     4*sqrt(2)

     - 2*sqrt(3*sqrt(5) - 1) + sqrt(10) + 3*sqrt(2)
 x=-------------------------------------------------,
                       4*sqrt(2)

    i*(sqrt(5) - 1)
 x=-----------------,
           2

    i*( - sqrt(5) + 1)
 x=--------------------}
            2



% The treatment of factors with non-unique inverses by introducing
% unique new real or integer indeterminant kernels.

solve((sin x-a)*(2**x-b)*(x**c-3),x);


{x=2*arbint(6)*pi + asin(a),

 x=2*arbint(6)*pi - asin(a) + pi,

    2*arbint(5)*i*pi + log(b)
 x=---------------------------,
             log(2)

    1/c       2*arbint(4)*pi          2*arbint(4)*pi
 x=3   *(cos(----------------) + sin(----------------)*i)}
                    c                       c



% Automatic restriction to principal branches.

off allbranch;



solve((sin x-a)*(2**x-b)*(x**c-3),x);


{x=asin(a),

    1/c
 x=3   ,

    log(b)
 x=--------}
    log(2)



% Regular system of linear equations.

solve({2*x1+x2+3*x3-9,x1-2*x2+x3+2,3*x1+2*x2+2*x3-7}, {x1,x2,x3});


{{x1=-1,x2=2,x3=3}}



% Underdetermined system of linear equations.

on solvesingular;



solve({x1-4*x2+2*x3+1,2*x1-3*x2-x3-5*x4+7,3*x1-7*x2+x3-5*x4+8},
      {x1,x2,x3,x4});


{{x1=4*arbcomplex(8) + 2*arbcomplex(7) - 5,

  x2=arbcomplex(8) + arbcomplex(7) - 1,

  x3=arbcomplex(7),

  x4=arbcomplex(8)}}



% Inconsistent system of linear equations.

solve({2*x1+3*x2-x3-2,7*x1+4*x2+2*x3-8,3*x1-2*x2+4*x3-5},
      {x1,x2,x3});


{}



% Overdetermined system of linear equations.

solve({x1-x2+x3-12,2*x1+3*x2-x3-13,3*x2+4*x3-5,-3*x1+x2+4*x3+20},
      {x1,x2,x3});


{{x1=9,x2=-1,x3=2}}



% Degenerate system of linear equations.

operator xx,yy;



yy(1) := -a**2*b**3-3*a**2*b**2-3*a**2*b+a**2*(xx(3)-2)-a*b-a*c+a*(xx(2)
         -xx(5))-xx(4)-xx(5)+xx(1)-1;


                                             2                      2  3
yy(1) :=  - xx(5)*a - xx(5) - xx(4) + xx(3)*a  + xx(2)*a + xx(1) - a *b

               2  2      2        2
          - 3*a *b  - 3*a *b - 2*a  - a*b - a*c - 1


yy(2) := -a*b**3-b**5+b**4*(-xx(4)-xx(5)+xx(1)-5)-b**3*c+b**3*(xx(2)
         -xx(5)-3)+b**2*(xx(3)-1);


          2            2                    2                            2
yy(2) := b *( - xx(5)*b  - xx(5)*b - xx(4)*b  + xx(3) + xx(2)*b + xx(1)*b  - a*b

                 3      2
              - b  - 5*b  - b*c - 3*b - 1)


yy(3) := -a*b**3*c-3*a*b**2*c-4*a*b*c+a*b*(-xx(4)-xx(5)+xx(1)-1)
         +a*c*(xx(3)-1)-b**2*c-b*c**2+b*c*(xx(2)-xx(5));


yy(3) :=  - xx(5)*a*b - xx(5)*b*c - xx(4)*a*b + xx(3)*a*c + xx(2)*b*c

                           3          2                            2        2
          + xx(1)*a*b - a*b *c - 3*a*b *c - 4*a*b*c - a*b - a*c - b *c - b*c


yy(4) := -a**2-a*c+a*(xx(2)-xx(4)-2*xx(5)+xx(1)-1)-b**4-b**3*c-3*b**3
         -3*b**2*c-2*b**2-2*b*c+b*(xx(3)-xx(2)-xx(4)+xx(1)-2)
         +c*(xx(3)-1);


yy(4) :=  - 2*xx(5)*a - xx(4)*a - xx(4)*b + xx(3)*b + xx(3)*c + xx(2)*a

                                           2              4    3        3
          - xx(2)*b + xx(1)*a + xx(1)*b - a  - a*c - a - b  - b *c - 3*b

               2        2
          - 3*b *c - 2*b  - 2*b*c - 2*b - c


yy(5) := -2*a-3*b**3-9*b**2-11*b-2*c+3*xx(3)+2*xx(2)-xx(4)-3*xx(5)+xx(1)
         -4;


                                                                   3      2
yy(5) :=  - 3*xx(5) - xx(4) + 3*xx(3) + 2*xx(2) + xx(1) - 2*a - 3*b  - 9*b

          - 11*b - 2*c - 4


soln  :=  solve({yy(1),yy(2),yy(3),yy(4),yy(5)},
                {xx(1),xx(2),xx(3),xx(4),xx(5)});


soln := {{xx(1)=arbcomplex(10) + arbcomplex(9) + 1,

          xx(2)=arbcomplex(10) + a + b + c,

                 3      2
          xx(3)=b  + 3*b  + 3*b + 1,

          xx(4)=arbcomplex(9),

          xx(5)=arbcomplex(10)}}


for i  :=  1:5 do xx(i) := part(soln,1,i,2);



for i  :=  1:5 do write yy(i);


0

0

0

0

0



%  Single equations liftable to polynomial systems.

solve ({a*sin x + b*cos x},{x});


                    2    2
              sqrt(a  + b ) - a
{x= - 2*atan(-------------------),
                      b

                 2    2
           sqrt(a  + b ) + a
 x=2*atan(-------------------)}
                   b


solve ({a*sin(x+1) + b*cos(x+1)},{x});


                    2    2
              sqrt(a  + b ) - a
{x= - 2*atan(-------------------) - 1,
                      b

                 2    2
           sqrt(a  + b ) + a
 x=2*atan(-------------------) - 1}
                   b

 
% Intersection of 2 curves: system with a free parameter.

solve ({sqrt(x^2 + y^2)=r,0=sqrt(x)+ y**3-1},{x,y,r});


     6      3
{{x=y  - 2*y  + 1,

  y=arbcomplex(12),

          12      9      6      3    2
  r=sqrt(y   - 4*y  + 6*y  - 4*y  + y  + 1)},

     6      3
 {x=y  - 2*y  + 1,

  y=arbcomplex(11),

             12      9      6      3    2
  r= - sqrt(y   - 4*y  + 6*y  - 4*y  + y  + 1)}}


solve ({e^x - e^(1/2 * x) - 7},{x});


           - sqrt(29) + 1
{x=2*log(-----------------),
                 2

          sqrt(29) + 1
 x=2*log(--------------)}
               2


% Generally not liftable.
  
   % variable inside and outside of sin.

   solve({sin x + x - 1/2},{x});


{x=root_of(2*sin(x_) + 2*x_ - 1,x_,tag_13)}

 
   % Variable inside and outside of exponential.

   solve({e^x - x**2},{x});


                             - 1
{x= - 2*lambert_w(-------------------------)}
                   2*plus_or_minus(tag_14)


   % Variable inside trigonometrical functions with different forms.

   solve ({a*sin(x+1) + b*cos(x+2)},{x});


                                                                        2    2
{x=2*atan((cos(1)*a - sqrt(2*cos(2)*sin(1)*a*b - 2*cos(1)*sin(2)*a*b + a  + b )

            - sin(2)*b)/(cos(2)*b + sin(1)*a)),

                                                                        2    2
 x=2*atan((cos(1)*a + sqrt(2*cos(2)*sin(1)*a*b - 2*cos(1)*sin(2)*a*b + a  + b )

            - sin(2)*b)/(cos(2)*b + sin(1)*a))}

 
   % Undetermined exponents.

   solve({x^a - 2},{x});


    1/a
{x=2   }

 

% Example taken from M.L. Griss, ACM Trans. Math. Softw. 2 (1976) 1.

e1 := x1 - l/(3*k)$



e2 := x2 - 1$



e3 := x3 - 35*b6/(6*l)*x4 + 33*b11/(2*l)*x6 - 715*b15/(14*l)*x8$



e4 := 14*k/(3*l)*x1 - 7*b4/(2*l)*x3 + x4$



e5 := x5 - 891*b11/(40*l)*x6 +3861*b15/(56*l)*x8$



e6 := -88*k/(15*l)*x1 + 22*b4/(5*l)*x3 - 99*b9/(8*l)*x5 +x6$



e7 := -768*k/(5005*b13)*x1 + 576*b4/(5005*b13)*x3 -
      324*b9/(1001*b13)*x5 + x7 - 16*l/(715*b13)*x8$



e8 := 7*l/(143*b15)*x1 + 49*b6/(429*b15)*x4 - 21*b11/(65*b15)*x6 +
      x8 - 7*b2/(143*b15)$



solve({e1,e2,e3,e4,e5,e6,e7,e8},{x1,x2,x3,x4,x5,x6,x7,x8});


       l
{{x1=-----,
      3*k

  x2=1,

                   2
      5*(3*b2*k - l )
  x3=-----------------,
           6*k*l

                             2        2
      7*(45*b2*b4*k - 15*b4*l  - 8*k*l )
  x4=------------------------------------,
                         2
                   36*k*l

                                  2              2             2       4
      2205*b2*b4*b6*k - 108*b2*k*l  - 735*b4*b6*l  - 392*b6*k*l  + 36*l
  x5=--------------------------------------------------------------------,
                                         3
                                   32*k*l

                                                2                  2
  x6=(11*(893025*b2*b4*b6*b9*k - 11520*b2*b4*k*l  - 43740*b2*b9*k*l

                              2            4                   2             4
           - 297675*b4*b6*b9*l  + 3840*b4*l  - 158760*b6*b9*k*l  + 14580*b9*l

                     4             4
           + 2048*k*l ))/(11520*k*l ),

                                                             2
  x7=(47652707025*b11*b2*b4*b6*b9*k - 614718720*b11*b2*b4*k*l

                                 2                             2
       - 2334010140*b11*b2*b9*k*l  - 15884235675*b11*b4*b6*b9*l

                           4                           2                     4
       + 204906240*b11*b4*l  - 8471592360*b11*b6*b9*k*l  + 778003380*b11*b9*l

                          4
       + 109283328*b11*k*l  + 172398476250*b15*b2*b4*b6*b9*k

                                 2                           2
       - 2223936000*b15*b2*b4*k*l  - 8444007000*b15*b2*b9*k*l

                                   2                     4
       - 57466158750*b15*b4*b6*b9*l  + 741312000*b15*b4*l

                                  2                      4                    4
       - 30648618000*b15*b6*b9*k*l  + 2814669000*b15*b9*l  + 395366400*b15*k*l

                               2                 4                   4
       - 172872000*b2*b4*b6*k*l  + 8467200*b2*k*l  + 57624000*b4*b6*l

                        4            6                         3
       + 30732800*b6*k*l  - 2822400*l )/(7729722000*b13*b15*k*l ),

                                                             2
  x8=(7*(972504225*b11*b2*b4*b6*b9*k - 12545280*b11*b2*b4*k*l

                                  2                           2
          - 47632860*b11*b2*b9*k*l  - 324168075*b11*b4*b6*b9*l

                            4                          2                    4
          + 4181760*b11*b4*l  - 172889640*b11*b6*b9*k*l  + 15877620*b11*b9*l

                           4                       2                4
          + 2230272*b11*k*l  - 3528000*b2*b4*b6*k*l  + 172800*b2*k*l

                           4                4          6                    4
          + 1176000*b4*b6*l  + 627200*b6*k*l  - 57600*l ))/(24710400*b15*k*l )}}



f1 := x1 - x*x2 - y*x3 + 1/2*x**2*x4 + x*y*x5 + 1/2*y**2*x6 +
      1/6*x**3*x7 + 1/2*x*y*(x - y)*x8 - 1/6*y**3*x9$



f2 := x1 - y*x3 + 1/2*y**2*x6 - 1/6*y**3*x9$



f3 := x1 + y*x2 - y*x3 + 1/2*y**2*x4 - y**2*x5 + 1/2*y**2*x6 +
      1/6*y**3*x7 + 1/2*y**3*x8 - 1/6*y**3*x9$



f4 := x1 + (1 - x)*x2 - x*x3 + 1/2*(1 - x)**2*x4 - y*(1 - x)*x5 +
      1/2*y**2*x6 + 1/6*(1 - x)**3*x7 + 1/2*y*(1 - x - y)*(1 - x)*x8
      - 1/6*y**3*x9$



f5 := x1 + (1 - x - y)*x2 + 1/2*(1 - x - y)**2*x4 +
      1/6*(1 - x - y)**3*x7$



f6 := x1 + (1 - x - y)*x3 + 1/2*(1 - x - y)*x6 +
      1/6*(1 - x - y)**3*x9$



f7 := x1 - x*x2 + (1 - y)*x3 + 1/2*x*x4 - x*(1 - y)*x5 +
      1/2*(1 - y)**2*x6 - 1/6*x**3*x7 + 1/2*x*(1 - y)*(1 - y + x)*x8
      + 1/6*(1-y)**3*x9$



f8 := x1 - x*x2 + x*x3 + 1/2*x**2*x4 - x**2*x5 + 1/2*x**2*x6 +
      1/6*x**3*x7 - 1/2*x**3*x8 + 1/6*x**3*x9$



f9 := x1 - x*x2 + 1/2*x**2*x4 + 1/6*x**3*x7$



solve({f1,f2,f3,f4,f5,f6,f7,f8,f9},{x1,x2,x3,x4,x5,x6,x7,x8,x9});


{{x1=0,x2=0,x3=0,x4=0,x5=0,x6=0,x7=0,x8=0,x9=0}}


solve({f1 - 1,f2,f3,f4,f5,f6,f7,f8,f9},{x1,x2,x3,x4,x5,x6,x7,x8,x9});


               8         8      7  3       7  2       7         7       6  4
{{x1=(y*( - 8*x *y + 10*x  + 9*x *y  - 49*x *y  + 85*x *y - 43*x  + 23*x *y

                 6  3        6  2        6         6       5  5        5  4
          - 128*x *y  + 266*x *y  - 246*x *y + 77*x  + 20*x *y  - 145*x *y

                 5  3        5  2        5         5      4  6       4  5
          + 383*x *y  - 512*x *y  + 329*x *y - 75*x  + 9*x *y  - 84*x *y

                 4  4        4  3        4  2        4         4      3  7
          + 276*x *y  - 469*x *y  + 464*x *y  - 233*x *y + 43*x  + 3*x *y

                3  6       3  5        3  4        3  3        3  2       3
          - 23*x *y  + 97*x *y  - 196*x *y  + 245*x *y  - 201*x *y  + 87*x *y

                3      2  8       2  7       2  6       2  5       2  4
          - 14*x  - 2*x *y  + 13*x *y  - 25*x *y  + 23*x *y  - 10*x *y

                2  3       2  2       2        2        9         8         7
          - 17*x *y  + 31*x *y  - 15*x *y + 2*x  - 2*x*y  + 10*x*y  - 24*x*y

                  6         5         4         3        2            6      5
          + 41*x*y  - 57*x*y  + 53*x*y  - 24*x*y  + 2*x*y  + x*y - 2*y  + 7*y

               4      3    2       10        10      9  2       9         9
          - 9*y  + 5*y  - y ))/(2*x  *y - 4*x   + 8*x *y  - 24*x *y + 20*x

            8  3       8  2       8         8       7  4       7  3        7  2
         + x *y  - 17*x *y  + 47*x *y - 31*x  - 24*x *y  + 92*x *y  - 105*x *y

               7         7       6  5        6  4        6  3        6  2
         + 18*x *y + 15*x  - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y

                6        6       5  6        5  5        5  4        5  3
         - 104*x *y + 4*x  - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y

                5  2       5        5      4  7       4  6       4  5       4  4
         - 278*x *y  + 83*x *y - 5*x  + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y

                4  3       4  2       4      4       3  8        3  7
         - 149*x *y  + 97*x *y  - 24*x *y + x  + 20*x *y  - 118*x *y

                3  6        3  5        3  4       3  3      3  2      3
         + 244*x *y  - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y

               2  9       2  8        2  7        2  6        2  5       2  4
         + 13*x *y  - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y

               2  3      2  2        10         9         8          7
         + 23*x *y  - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y

                  6         5         4        3      9       8       7      6
         + 100*x*y  - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y

              5
         + 2*y ),

         10        10      9  2       9        9      8  3      8  2      8
  x2=(2*x  *y - 2*x   + 5*x *y  - 12*x *y + 7*x  - 8*x *y  + 9*x *y  + 2*x *y

          8       7  4       7  3       7  2       7         7      6  5
       - x  - 15*x *y  + 65*x *y  - 83*x *y  + 52*x *y - 17*x  + 5*x *y

            6  4       6  3       6  2       6         6       5  6        5  5
       - 5*x *y  - 20*x *y  + 46*x *y  - 54*x *y + 20*x  + 23*x *y  - 151*x *y

              5  4        5  3        5  2       5        5       4  7
       + 321*x *y  - 338*x *y  + 166*x *y  - 13*x *y - 8*x  + 29*x *y

              4  6        4  5        4  4        4  3        4  2       4
       - 207*x *y  + 523*x *y  - 676*x *y  + 522*x *y  - 222*x *y  + 36*x *y

          4       3  8        3  7        3  6        3  5        3  4
       + x  + 16*x *y  - 103*x *y  + 300*x *y  - 463*x *y  + 433*x *y

              3  3       3  2       3      2  9       2  7       2  6       2  5
       - 268*x *y  + 98*x *y  - 15*x *y - x *y  + 22*x *y  - 54*x *y  + 60*x *y

             2  4       2  3       2  2      2          10         9         8
       - 56*x *y  + 44*x *y  - 17*x *y  + 2*x *y - 2*x*y   + 10*x*y  - 22*x*y

               7         6         5         4        3      2      7      6
       + 34*x*y  - 48*x*y  + 48*x*y  - 23*x*y  + 2*x*y  + x*y  - 2*y  + 7*y

            5      4    3         10        10      9  2       9         9
       - 9*y  + 5*y  - y )/(x*(2*x  *y - 4*x   + 8*x *y  - 24*x *y + 20*x

               8  3       8  2       8         8       7  4       7  3
            + x *y  - 17*x *y  + 47*x *y - 31*x  - 24*x *y  + 92*x *y

                   7  2       7         7       6  5        6  4        6  3
            - 105*x *y  + 18*x *y + 15*x  - 28*x *y  + 172*x *y  - 350*x *y

                   6  2        6        6       5  6        5  5        5  4
            + 308*x *y  - 104*x *y + 4*x  - 14*x *y  + 103*x *y  - 290*x *y

                   5  3        5  2       5        5      4  7       4  6
            + 401*x *y  - 278*x *y  + 83*x *y - 5*x  + 6*x *y  - 35*x *y

                  4  5       4  4        4  3       4  2       4      4
            + 14*x *y  + 90*x *y  - 149*x *y  + 97*x *y  - 24*x *y + x

                  3  8        3  7        3  6        3  5        3  4
            + 20*x *y  - 118*x *y  + 244*x *y  - 237*x *y  + 117*x *y

                  3  3      3  2      3         2  9       2  8        2  7
            - 21*x *y  - 7*x *y  + 2*x *y + 13*x *y  - 86*x *y  + 228*x *y

                   2  6        2  5       2  4       2  3      2  2        10
            - 294*x *y  + 204*x *y  - 86*x *y  + 23*x *y  - 2*x *y  + 4*x*y

                    9         8          7          6         5         4
            - 31*x*y  + 84*x*y  - 121*x*y  + 100*x*y  - 48*x*y  + 15*x*y

                   3      9       8       7      6      5
            - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y  + 2*y )),

         9        9      8  2       8         8      7  3       7  2        7
  x3=(2*x *y - 4*x  + 8*x *y  - 32*x *y + 26*x  + 9*x *y  - 70*x *y  + 131*x *y

             7      6  4       6  3        6  2        6         6       5  5
       - 66*x  + 7*x *y  - 73*x *y  + 226*x *y  - 253*x *y + 89*x  + 11*x *y

             5  4        5  3        5  2        5         5       4  6
       - 81*x *y  + 244*x *y  - 383*x *y  + 280*x *y - 73*x  + 13*x *y

             4  5        4  4        4  3        4  2        4         4
       - 89*x *y  + 235*x *y  - 367*x *y  + 360*x *y  - 189*x *y + 39*x

            3  7       3  6        3  5        3  4        3  3        3  2
       + 9*x *y  - 59*x *y  + 156*x *y  - 227*x *y  + 231*x *y  - 171*x *y

             3         3      2  8       2  7       2  6       2  5       2  4
       + 74*x *y - 13*x  + 3*x *y  - 21*x *y  + 62*x *y  - 78*x *y  + 51*x *y

             2  3       2  2       2        2        8         7         6
       - 35*x *y  + 30*x *y  - 14*x *y + 2*x  - 5*x*y  + 18*x*y  - 22*x*y

            5         4         3      2            8      7      6    5      4
       - x*y  + 21*x*y  - 13*x*y  + x*y  + x*y + 2*y  - 6*y  + 6*y  + y  - 6*y

            3    2      10        10      9  2       9         9    8  3
       + 4*y  - y )/(2*x  *y - 4*x   + 8*x *y  - 24*x *y + 20*x  + x *y

               8  2       8         8       7  4       7  3        7  2
         - 17*x *y  + 47*x *y - 31*x  - 24*x *y  + 92*x *y  - 105*x *y

               7         7       6  5        6  4        6  3        6  2
         + 18*x *y + 15*x  - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y

                6        6       5  6        5  5        5  4        5  3
         - 104*x *y + 4*x  - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y

                5  2       5        5      4  7       4  6       4  5       4  4
         - 278*x *y  + 83*x *y - 5*x  + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y

                4  3       4  2       4      4       3  8        3  7
         - 149*x *y  + 97*x *y  - 24*x *y + x  + 20*x *y  - 118*x *y

                3  6        3  5        3  4       3  3      3  2      3
         + 244*x *y  - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y

               2  9       2  8        2  7        2  6        2  5       2  4
         + 13*x *y  - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y

               2  3      2  2        10         9         8          7
         + 23*x *y  - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y

                  6         5         4        3      9       8       7      6
         + 100*x*y  - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y

              5
         + 2*y ),

            9        9      8  2       8        8      7  3       7  2       7
  x4=(2*(2*x *y - 2*x  + 4*x *y  - 10*x *y + 6*x  - 9*x *y  + 21*x *y  - 13*x *y

             7       6  4       6  3        6  2       6         6       5  5
          + x  - 18*x *y  + 88*x *y  - 130*x *y  + 74*x *y - 14*x  - 10*x *y

                5  4        5  3        5  2       5         5      4  6
          + 74*x *y  - 180*x *y  + 191*x *y  - 90*x *y + 15*x  + 4*x *y

                4  5       4  4        4  3        4  2       4        4
          - 18*x *y  - 20*x *y  + 105*x *y  - 111*x *y  + 47*x *y - 7*x

                3  7       3  6        3  5        3  4       3  3      3  2
          + 16*x *y  - 96*x *y  + 188*x *y  - 155*x *y  + 44*x *y  + 8*x *y

               3      3       2  8       2  7        2  6        2  5
          - 6*x *y + x  + 10*x *y  - 62*x *y  + 164*x *y  - 219*x *y

                 2  4       2  3       2  2    2        9         8         7
          + 154*x *y  - 56*x *y  + 10*x *y  - x *y + x*y  - 13*x*y  + 45*x*y

                  6         5         4         3        2      8      7      6
          - 72*x*y  + 64*x*y  - 35*x*y  + 12*x*y  - 2*x*y  + 2*y  - 7*y  + 9*y

               5    4          10        10      9  2       9         9    8  3
          - 5*y  + y ))/(x*(2*x  *y - 4*x   + 8*x *y  - 24*x *y + 20*x  + x *y

                  8  2       8         8       7  4       7  3        7  2
            - 17*x *y  + 47*x *y - 31*x  - 24*x *y  + 92*x *y  - 105*x *y

                  7         7       6  5        6  4        6  3        6  2
            + 18*x *y + 15*x  - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y

                   6        6       5  6        5  5        5  4        5  3
            - 104*x *y + 4*x  - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y

                   5  2       5        5      4  7       4  6       4  5
            - 278*x *y  + 83*x *y - 5*x  + 6*x *y  - 35*x *y  + 14*x *y

                  4  4        4  3       4  2       4      4       3  8
            + 90*x *y  - 149*x *y  + 97*x *y  - 24*x *y + x  + 20*x *y

                   3  7        3  6        3  5        3  4       3  3      3  2
            - 118*x *y  + 244*x *y  - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y

                 3         2  9       2  8        2  7        2  6        2  5
            + 2*x *y + 13*x *y  - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y

                  2  4       2  3      2  2        10         9         8
            - 86*x *y  + 23*x *y  - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y

                     7          6         5         4        3      9       8
            - 121*x*y  + 100*x*y  - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y

                  7      6      5
            + 15*y  - 9*y  + 2*y )),

         10        10      9  2       9        9      8  3       8  2       8
  x5=(2*x  *y - 2*x   + 7*x *y  - 16*x *y + 7*x  - 3*x *y  - 11*x *y  + 21*x *y

          8       7  4       7  3       7  2       7         7      6  5
       - x  - 18*x *y  + 60*x *y  - 46*x *y  + 23*x *y - 17*x  - 4*x *y

             6  4       6  3       6  2       6         6       5  6       5  5
       + 38*x *y  - 70*x *y  + 40*x *y  - 36*x *y + 20*x  + 14*x *y  - 86*x *y

              5  4        5  3        5  2       5        5       4  7
       + 164*x *y  - 182*x *y  + 114*x *y  - 14*x *y - 8*x  + 24*x *y

              4  6        4  5        4  4        4  3        4  2       4
       - 167*x *y  + 387*x *y  - 455*x *y  + 348*x *y  - 164*x *y  + 32*x *y

          4       3  8        3  7        3  6        3  5        3  4
       + x  + 21*x *y  - 130*x *y  + 339*x *y  - 458*x *y  + 370*x *y

              3  3       3  2       3        2  9       2  8        2  7
       - 211*x *y  + 81*x *y  - 14*x *y + 5*x *y  - 43*x *y  + 140*x *y

              2  6        2  5       2  4       2  3       2  2      2
       - 209*x *y  + 165*x *y  - 86*x *y  + 42*x *y  - 16*x *y  + 2*x *y

              9         8         7         6        5        4      3      2
       - 5*x*y  + 20*x*y  - 32*x*y  + 16*x*y  + 8*x*y  - 9*x*y  + x*y  + x*y

            9      8      7    6      5      4    3           10        10
       + 2*y  - 6*y  + 6*y  + y  - 6*y  + 4*y  - y )/(x*y*(2*x  *y - 4*x

                 9  2       9         9    8  3       8  2       8         8
            + 8*x *y  - 24*x *y + 20*x  + x *y  - 17*x *y  + 47*x *y - 31*x

                  7  4       7  3        7  2       7         7       6  5
            - 24*x *y  + 92*x *y  - 105*x *y  + 18*x *y + 15*x  - 28*x *y

                   6  4        6  3        6  2        6        6       5  6
            + 172*x *y  - 350*x *y  + 308*x *y  - 104*x *y + 4*x  - 14*x *y

                   5  5        5  4        5  3        5  2       5        5
            + 103*x *y  - 290*x *y  + 401*x *y  - 278*x *y  + 83*x *y - 5*x

                 4  7       4  6       4  5       4  4        4  3       4  2
            + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y  - 149*x *y  + 97*x *y

                  4      4       3  8        3  7        3  6        3  5
            - 24*x *y + x  + 20*x *y  - 118*x *y  + 244*x *y  - 237*x *y

                   3  4       3  3      3  2      3         2  9       2  8
            + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y + 13*x *y  - 86*x *y

                   2  7        2  6        2  5       2  4       2  3      2  2
            + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y  + 23*x *y  - 2*x *y

                   10         9         8          7          6         5
            + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y  + 100*x*y  - 48*x*y

                    4        3      9       8       7      6      5
            + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y  + 2*y )),

            9        9      8  2       8         8      7  3       7  2
  x6=(2*(2*x *y - 4*x  + 8*x *y  - 24*x *y + 16*x  - 2*x *y  - 19*x *y

                7         7       6  4       6  3       6  2       6         6
          + 50*x *y - 23*x  - 20*x *y  + 71*x *y  - 46*x *y  - 15*x *y + 12*x

               5  5       5  4        5  3        5  2       5        5
          - 8*x *y  + 82*x *y  - 195*x *y  + 155*x *y  - 46*x *y + 2*x

               4  6       4  5       4  4        4  3        4  2       4
          + 8*x *y  - 11*x *y  - 81*x *y  + 184*x *y  - 142*x *y  + 46*x *y

               4       3  6       3  5    3  4       3  3       3  2       3
          - 4*x  - 21*x *y  + 50*x *y  + x *y  - 60*x *y  + 49*x *y  - 14*x *y

             3      2  8       2  7       2  6       2  5       2  4      2  3
          + x  + 6*x *y  - 34*x *y  + 82*x *y  - 99*x *y  + 54*x *y  - 8*x *y

               2  2    2          8         7         6         5         4
          - 4*x *y  + x *y - 6*x*y  + 38*x*y  - 79*x*y  + 78*x*y  - 41*x*y

                  3      2      7       6       5      4    3          10
          + 11*x*y  - x*y  - 4*y  + 10*y  - 10*y  + 5*y  - y ))/(y*(2*x  *y

                 10      9  2       9         9    8  3       8  2       8
            - 4*x   + 8*x *y  - 24*x *y + 20*x  + x *y  - 17*x *y  + 47*x *y

                  8       7  4       7  3        7  2       7         7
            - 31*x  - 24*x *y  + 92*x *y  - 105*x *y  + 18*x *y + 15*x

                  6  5        6  4        6  3        6  2        6        6
            - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y  - 104*x *y + 4*x

                  5  6        5  5        5  4        5  3        5  2       5
            - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y  - 278*x *y  + 83*x *y

                 5      4  7       4  6       4  5       4  4        4  3
            - 5*x  + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y  - 149*x *y

                  4  2       4      4       3  8        3  7        3  6
            + 97*x *y  - 24*x *y + x  + 20*x *y  - 118*x *y  + 244*x *y

                   3  5        3  4       3  3      3  2      3         2  9
            - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y + 13*x *y

                  2  8        2  7        2  6        2  5       2  4       2  3
            - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y  + 23*x *y

                 2  2        10         9         8          7          6
            - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y  + 100*x*y

                    5         4        3      9       8       7      6      5
            - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y  + 2*y )),

          7  2      7      7    6  3      6  2      6        6      5  4
  x7=(6*(x *y  - 2*x *y + x  + x *y  - 4*x *y  + 5*x *y - 2*x  - 6*x *y

                5  3       5  2       5        5      4  5       4  4
          + 26*x *y  - 38*x *y  + 21*x *y - 3*x  - 8*x *y  + 49*x *y

                 4  3        4  2       4        4    3  6       3  5       3  4
          - 106*x *y  + 101*x *y  - 41*x *y + 5*x  - x *y  + 12*x *y  - 42*x *y

                3  3       3  2       3      3      2  7       2  6       2  5
          + 69*x *y  - 52*x *y  + 15*x *y - x  + 4*x *y  - 27*x *y  + 59*x *y

                2  4       2  3      2  2    2          8         7         6
          - 52*x *y  + 14*x *y  + 3*x *y  - x *y + 3*x*y  - 18*x*y  + 39*x*y

                  5         4         3      2      7      6      5      4    3
          - 48*x*y  + 34*x*y  - 11*x*y  + x*y  + 2*y  - 5*y  + 6*y  - 4*y  + y )

               10        10      9  2       9         9    8  3       8  2
      )/(x*(2*x  *y - 4*x   + 8*x *y  - 24*x *y + 20*x  + x *y  - 17*x *y

                   8         8       7  4       7  3        7  2       7
             + 47*x *y - 31*x  - 24*x *y  + 92*x *y  - 105*x *y  + 18*x *y

                   7       6  5        6  4        6  3        6  2        6
             + 15*x  - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y  - 104*x *y

                  6       5  6        5  5        5  4        5  3        5  2
             + 4*x  - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y  - 278*x *y

                   5        5      4  7       4  6       4  5       4  4
             + 83*x *y - 5*x  + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y

                    4  3       4  2       4      4       3  8        3  7
             - 149*x *y  + 97*x *y  - 24*x *y + x  + 20*x *y  - 118*x *y

                    3  6        3  5        3  4       3  3      3  2      3
             + 244*x *y  - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y

                   2  9       2  8        2  7        2  6        2  5
             + 13*x *y  - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y

                   2  4       2  3      2  2        10         9         8
             - 86*x *y  + 23*x *y  - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y

                      7          6         5         4        3      9       8
             - 121*x*y  + 100*x*y  - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y

                   7      6      5
             + 15*y  - 9*y  + 2*y )),

               9    8  2       8         8      7  3       7  2       7
  x8=(2*( - 2*x  + x *y  - 10*x *y + 13*x  + 5*x *y  - 24*x *y  + 49*x *y

                7      6  4       6  3       6  2       6         6      5  5
          - 30*x  + 8*x *y  - 41*x *y  + 75*x *y  - 78*x *y + 32*x  + 7*x *y

                5  4       5  3       5  2       5         5    4  6      4  5
          - 35*x *y  + 61*x *y  - 56*x *y  + 41*x *y - 16*x  - x *y  + 9*x *y

                4  4       4  3       4  2      4        4       3  7       3  6
          - 10*x *y  + 15*x *y  - 22*x *y  + 6*x *y + 3*x  - 10*x *y  + 57*x *y

                 3  5       3  4       3  3       3  2       3        2  8
          - 107*x *y  + 91*x *y  - 55*x *y  + 34*x *y  - 10*x *y - 8*x *y

                2  7        2  6        2  5       2  4       2  3       2  2
          + 46*x *y  - 105*x *y  + 116*x *y  - 63*x *y  + 23*x *y  - 11*x *y

               2          9         8         7         6         5        4
          + 2*x *y - 2*x*y  + 16*x*y  - 42*x*y  + 54*x*y  - 34*x*y  + 6*x*y

               3      2      8      7      6      5    4    3            10
          + x*y  + x*y  - 2*y  + 6*y  - 7*y  + 3*y  + y  - y ))/(x*y*(2*x  *y

                 10      9  2       9         9    8  3       8  2       8
            - 4*x   + 8*x *y  - 24*x *y + 20*x  + x *y  - 17*x *y  + 47*x *y

                  8       7  4       7  3        7  2       7         7
            - 31*x  - 24*x *y  + 92*x *y  - 105*x *y  + 18*x *y + 15*x

                  6  5        6  4        6  3        6  2        6        6
            - 28*x *y  + 172*x *y  - 350*x *y  + 308*x *y  - 104*x *y + 4*x

                  5  6        5  5        5  4        5  3        5  2       5
            - 14*x *y  + 103*x *y  - 290*x *y  + 401*x *y  - 278*x *y  + 83*x *y

                 5      4  7       4  6       4  5       4  4        4  3
            - 5*x  + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y  - 149*x *y

                  4  2       4      4       3  8        3  7        3  6
            + 97*x *y  - 24*x *y + x  + 20*x *y  - 118*x *y  + 244*x *y

                   3  5        3  4       3  3      3  2      3         2  9
            - 237*x *y  + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y + 13*x *y

                  2  8        2  7        2  6        2  5       2  4       2  3
            - 86*x *y  + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y  + 23*x *y

                 2  2        10         9         8          7          6
            - 2*x *y  + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y  + 100*x*y

                    5         4        3      9       8       7      6      5
            - 48*x*y  + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y  + 2*y )),

               7  2      7        7      6  3       6  2      6        6    5  4
  x9=(6*( - 2*x *y  + 2*x *y + 4*x  - 4*x *y  + 16*x *y  - 6*x *y - 8*x  + x *y

                5  3       5  2       5        5      4  5      4  4       4  3
          + 18*x *y  - 56*x *y  + 26*x *y + 3*x  + 4*x *y  - 6*x *y  - 40*x *y

                4  2       4        4      3  6       3  5      3  4       3  3
          + 82*x *y  - 38*x *y + 2*x  - 6*x *y  + 15*x *y  - 9*x *y  + 32*x *y

                3  2       3      3    2  7      2  5      2  4      2  3
          - 46*x *y  + 19*x *y - x  + x *y  - 5*x *y  + 2*x *y  - 7*x *y

                2  2      2          8        7        6         5         4
          + 10*x *y  - 3*x *y - 2*x*y  + 9*x*y  - 4*x*y  - 16*x*y  + 22*x*y

                 3      7      6      5      4      3          10        10
          - 9*x*y  - 2*y  + 2*y  + 2*y  - 4*y  + 2*y ))/(y*(2*x  *y - 4*x

                 9  2       9         9    8  3       8  2       8         8
            + 8*x *y  - 24*x *y + 20*x  + x *y  - 17*x *y  + 47*x *y - 31*x

                  7  4       7  3        7  2       7         7       6  5
            - 24*x *y  + 92*x *y  - 105*x *y  + 18*x *y + 15*x  - 28*x *y

                   6  4        6  3        6  2        6        6       5  6
            + 172*x *y  - 350*x *y  + 308*x *y  - 104*x *y + 4*x  - 14*x *y

                   5  5        5  4        5  3        5  2       5        5
            + 103*x *y  - 290*x *y  + 401*x *y  - 278*x *y  + 83*x *y - 5*x

                 4  7       4  6       4  5       4  4        4  3       4  2
            + 6*x *y  - 35*x *y  + 14*x *y  + 90*x *y  - 149*x *y  + 97*x *y

                  4      4       3  8        3  7        3  6        3  5
            - 24*x *y + x  + 20*x *y  - 118*x *y  + 244*x *y  - 237*x *y

                   3  4       3  3      3  2      3         2  9       2  8
            + 117*x *y  - 21*x *y  - 7*x *y  + 2*x *y + 13*x *y  - 86*x *y

                   2  7        2  6        2  5       2  4       2  3      2  2
            + 228*x *y  - 294*x *y  + 204*x *y  - 86*x *y  + 23*x *y  - 2*x *y

                   10         9         8          7          6         5
            + 4*x*y   - 31*x*y  + 84*x*y  - 121*x*y  + 100*x*y  - 48*x*y

                    4        3      9       8       7      6      5
            + 15*x*y  - 3*x*y  + 4*y  - 12*y  + 15*y  - 9*y  + 2*y ))}}



% The following examples were discussed in Char, B.W., Fee, G.J.,
% Geddes, K.O., Gonnet, G.H., Monagan, M.B., Watt, S.M., "On the
% Design and Performance of the Maple System", Proc. 1984 Macsyma
% Users' Conference, G.E., Schenectady, NY, 1984, 199-219.

% Problem 1.

solve({ -22319*x0+25032*x1-83247*x2+67973*x3+54189*x4
       -67793*x5+81135*x6+22293*x7+27327*x8+96599*x9-15144,
       79815*x0+37299*x1-28495*x2-52463*x3+25708*x4 -55333*x5-
       2742*x6+83127*x7-29417*x8-43202*x9+93314, -29065*x0-77803*x1-
       49717*x2-64748*x3-68324*x4 -50162*x5-64222*x6-
       4716*x7+30737*x8+22971*x9+90348, 62470*x0+59658*x1-
       46120*x2+58376*x3-28208*x4 -74506*x5+28491*x6+21099*x7+29149*x8-
       20387*x9+36254, -98233*x0-26263*x1-63227*x2+34307*x3+92294*x4
       +10148*x5+3192*x6+24044*x7-83764*x8-1121*x9+13871,
       -20427*x0+62666*x1+27330*x2-78670*x3+9036*x4 +56024*x5-4525*x6-
       50589*x7-62127*x8-32846*x9+38466,
       -85609*x0+5424*x1+86992*x2+59651*x3-60859*x4 -55984*x5-
       6061*x6+44417*x7+92421*x8+6701*x9-9459,
       -68255*x0+19652*x1+92650*x2-93032*x3-30191*x4 -31075*x5-
       89060*x6+12150*x7-78089*x8-12462*x9+1027, 55526*x0-
       91202*x1+91329*x2-25919*x3-98215*x4 +30554*x5+913*x6-
       35751*x7+17948*x8-58850*x9+66583, 40612*x0+84364*x1-
       83317*x2+10658*x3+37213*x4 +50489*x5+72040*x6-
       21227*x7+60772*x8+95114*x9-68533});


Unknowns: {x0,x1,x2,x3,x4,x5,x6,x7,x8,x9}

      4352444991703786550093529782474564455970663240687
{{x0=---------------------------------------------------,
      8420785423059099972039395927798127489505890997055

      459141297061698284317621371232198410031030658042
  x1=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      1068462443128238131632235196977352568525519548284
  x2=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      1645748379263608982132912334741766606871657041427
  x3=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      25308331428404990886292916036626876985377936966579
  x4=----------------------------------------------------,
      42103927115295499860196979638990637447529454985275

      17958909252564152456194678743404876001526265937527
  x5=----------------------------------------------------,
      42103927115295499860196979638990637447529454985275

       - 50670056205024448621117426699348037457452368820774
  x6=-------------------------------------------------------,
       42103927115295499860196979638990637447529454985275

       - 11882862555847887107599498171234654114612212813799
  x7=-------------------------------------------------------,
       42103927115295499860196979638990637447529454985275

       - 273286267131634194631661772113331181980867938658
  x8=-----------------------------------------------------,
       8420785423059099972039395927798127489505890997055

      46816360472823082478331070276129336252954604132203
  x9=----------------------------------------------------}}
      42103927115295499860196979638990637447529454985275


solve({ -22319*x0+25032*x1-83247*x2+67973*x3+54189*x4
        -67793*x5+81135*x6+22293*x7+27327*x8+96599*x9-15144,
        79815*x0+37299*x1-28495*x2-52463*x3+25708*x4 -55333*x5-
        2742*x6+83127*x7-29417*x8-43202*x9+93314, -29065*x0-77803*x1-
        49717*x2-64748*x3-68324*x4 -50162*x5-64222*x6-
        4716*x7+30737*x8+22971*x9+90348, 62470*x0+59658*x1-
        46120*x2+58376*x3-28208*x4-74506*x5+28491*x6+21099*x7+29149*x8-
        20387*x9+36254,-98233*x0-26263*x1-63227*x2+34307*x3+92294*x4
        +10148*x5+3192*x6+24044*x7-83764*x8-1121*x9+13871,
        -20427*x0+62666*x1+27330*x2-78670*x3+9036*x4 +56024*x5-4525*x6-
        50589*x7-62127*x8-32846*x9+38466,
        -85609*x0+5424*x1+86992*x2+59651*x3-60859*x4 -55984*x5-
        6061*x6+44417*x7+92421*x8+6701*x9-9459,
        -68255*x0+19652*x1+92650*x2-93032*x3-30191*x4 -31075*x5-
        89060*x6+12150*x7-78089*x8-12462*x9+1027, 55526*x0-
        91202*x1+91329*x2-25919*x3-98215*x4 +30554*x5+913*x6-
        35751*x7+17948*x8-58850*x9+66583, 40612*x0+84364*x1-
        83317*x2+10658*x3+37213*x4 +50489*x5+72040*x6-
        21227*x7+60772*x8+95114*x9-68533});


Unknowns: {x0,x1,x2,x3,x4,x5,x6,x7,x8,x9}

      4352444991703786550093529782474564455970663240687
{{x0=---------------------------------------------------,
      8420785423059099972039395927798127489505890997055

      459141297061698284317621371232198410031030658042
  x1=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      1068462443128238131632235196977352568525519548284
  x2=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      1645748379263608982132912334741766606871657041427
  x3=---------------------------------------------------,
      1684157084611819994407879185559625497901178199411

      25308331428404990886292916036626876985377936966579
  x4=----------------------------------------------------,
      42103927115295499860196979638990637447529454985275

      17958909252564152456194678743404876001526265937527
  x5=----------------------------------------------------,
      42103927115295499860196979638990637447529454985275

       - 50670056205024448621117426699348037457452368820774
  x6=-------------------------------------------------------,
       42103927115295499860196979638990637447529454985275

       - 11882862555847887107599498171234654114612212813799
  x7=-------------------------------------------------------,
       42103927115295499860196979638990637447529454985275

       - 273286267131634194631661772113331181980867938658
  x8=-----------------------------------------------------,
       8420785423059099972039395927798127489505890997055

      46816360472823082478331070276129336252954604132203
  x9=----------------------------------------------------}}
      42103927115295499860196979638990637447529454985275



% The next two problems give the current routines some trouble and
% have therefore been commented out.

% Problem 2.

comment
solve({ 81*x30-96*x21-45, -36*x4+59*x29+26,
       -59*x26+5*x3-33, -81*x19-92*x23-21*x17-9, -46*x29-
       13*x22+22*x24+83, 47*x4-47*x14-15*x26-40, 83*x30+70*x17+56*x10-
       31, 10*x27-90*x9+52*x21+52, -33*x20-97*x26+20*x6-76,
       97*x16+41*x8-13*x12+66, 16*x16-52*x10-73*x28+49, -28*x1-53*x24-
       x27-67, -22*x26-29*x24+73*x10+8, 88*x18+61*x19-98*x9-55, 99*x28-
       91*x26+26*x21-95, -6*x18+25*x7-77*x2+99, 28*x13-50*x17-52*x14-64,
       -50*x20+26*x11+93*x2+77, -70*x8+74*x19-94*x26+86, -18*x18-2*x16-
       79*x23+91, 36*x26-13*x11-53*x25-5, 10*x7+57*x16-85*x10-14,
       -3*x27+44*x4+52*x22-1, 21*x11+20*x25-30*x4-83, 70*x2-97*x19-
       41*x26-50, -51*x8+95*x12-85*x26+45, 83*x30+41*x12+50*x2+53,
       -4*x26+69*x8-58*x5-95, 59*x27-78*x30-66*x23+16, -10*x20-36*x11-
       60*x1-59});



% Problem 3.
comment
solve({ 115*x40+566*x41-378*x42+11401086415/6899901,
       560*x0-45*x1-506*x2-11143386403/8309444, -621*x1-
       328*x2+384*x3+1041841/64675, -856*x2+54*x3+869*x4-41430291/24700,
       596*x3-608*x4-560*x5-10773384/11075,
       -61*x4+444*x5+924*x6+4185100079/11278780, 67*x5-95*x6-
       682*x7+903866812/6618863, 196*x6+926*x7-930*x8-
       2051864151/2031976, -302*x7-311*x8-890*x9-14210414139/27719792,
       121*x8-781*x9-125*x10-4747129093/39901584, 10*x9+555*x10-
       912*x11+32476047/3471829, -151*x38+732*x39-
       397*x40+327281689/173242, 913*x10-259*x11-982*x12-
       18080663/5014020, 305*x11+9*x12-357*x13+1500752933/1780680,
       179*x12-588*x13+665*x14+8128189/51832, 406*x13+843*x14-
       833*x15+201925713/97774, 107*x14+372*x15+505*x16-
       5161192791/3486415, 720*x15-212*x16+607*x17-31529295571/7197760,
       951*x16-685*x17+148*x18+1034546543/711104, -654*x17-
       899*x18+543*x19+1942961717/1646560,
       -448*x18+673*x19+702*x20+856422818/1286375, 396*x19-
       196*x20+218*x21-4386267866/21303625, -233*x20-796*x21-373*x22-
       85246365829/57545250, 921*x21-368*x22+730*x23-
       93446707622/51330363, -424*x22+378*x23+727*x24-
       6673617931/3477462, -633*x23+565*x24-208*x25+8607636805/4092942,
       971*x24+170*x25-865*x26-25224505/18354, 937*x25+333*x26-463*x27-
       339307103/1025430, 494*x26-8*x27-50*x28+57395804/34695,
       530*x27+631*x28-193*x29-8424597157/680022,
       -435*x28+252*x29+916*x30+196828511/19593, 327*x29+403*x30-
       845*x31+8458823325/5927971, 246*x30+881*x31-
       394*x32+13624765321/156546826, 946*x31+169*x32-43*x33-
       53594199271/126093183, -146*x32+503*x33-
       363*x34+66802797635/15234909, -132*x33-
       686*x34+376*x35+8167530636/902635, -38*x34-188*x35-
       583*x36+1814153743/1124240, 389*x35+562*x36-688*x37-
       12251043951/5513560, -769*x37-474*x38-89*x39-2725415872/1235019,
       -625*x36-122*x37+468*x38+7725682775/4506736,
       839*x39+936*x40+703*x41+1912091857/1000749,
       -314*x41+102*x42+790*x43+7290073150/8132873, -905*x42-
       454*x43+524*x44-10110944527/4538233, 379*x43+518*x44-328*x45-
       2071620692/519645, 284*x44-979*x45+690*x46-915987532/16665,
       198*x45-650*x46-763*x47+548801657/11220, 974*x46+12*x47+410*x48-
       3831097561/51051, -498*x47-135*x48-230*x49-18920705/9282,
       665*x48+156*x49+34*x0-27714736/156585, -519*x49-366*x0-730*x1-
       2958446681/798985});



% Problem 4.

% This one needs the Cramer code --- it takes forever otherwise.

on cramer;



solve({ -b*k8/a+c*k8/a, -b*k11/a+c*k11/a,
       -b*k10/a+c*k10/a+k2,
        -k3-b*k9/a+c*k9/a, -b*k14/a+c*k14/a, -b*k15/a+c*k15/a,
        -b*k18/a+c*k18/a-k2, -b*k17/a+c*k17/a, -b*k16/a+c*k16/a+k4,
        -b*k13/a+c*k13/a-b*k21/a+c*k21/a+b*k5/a-c*k5/a,
        b*k44/a-c*k44/a, -b*k45/a+c*k45/a, -b*k20/a+c*k20/a,
        -b*k44/a+c*k44/a, b*k46/a-c*k46/a,
        b**2*k47/a**2-2*b*c*k47/a**2+c**2*k47/a**2,
        k3, -k4, -b*k12/a+c*k12/a-a*k6/b+c*k6/b,
        -b*k19/a+c*k19/a+a*k7/c-b*k7/c, b*k45/a-c*k45/a,
        -b*k46/a+c*k46/a, -k48+c*k48/a+c*k48/b-c**2*k48/(a*b),
        -k49+b*k49/a+b*k49/c-b**2*k49/(a*c), a*k1/b-c*k1/b,
        a*k4/b-c*k4/b, a*k3/b-c*k3/b+k9, -k10+a*k2/b-c*k2/b,
        a*k7/b-c*k7/b, -k9, k11, b*k12/a-c*k12/a+a*k6/b-c*k6/b,
        a*k15/b-c*k15/b, k10+a*k18/b-c*k18/b,
        -k11+a*k17/b-c*k17/b, a*k16/b-c*k16/b,
        -a*k13/b+c*k13/b+a*k21/b-c*k21/b+a*k5/b-c*k5/b,
        -a*k44/b+c*k44/b, a*k45/b-c*k45/b,
        a*k14/c-b*k14/c+a*k20/b-c*k20/b, a*k44/b-c*k44/b,
        -a*k46/b+c*k46/b, -k47+c*k47/a+c*k47/b-c**2*k47/(a*b),
        a*k19/b-c*k19/b, -a*k45/b+c*k45/b, a*k46/b-c*k46/b,
        a**2*k48/b**2-2*a*c*k48/b**2+c**2*k48/b**2,
        -k49+a*k49/b+a*k49/c-a**2*k49/(b*c), k16, -k17,
        -a*k1/c+b*k1/c, -k16-a*k4/c+b*k4/c, -a*k3/c+b*k3/c,
        k18-a*k2/c+b*k2/c, b*k19/a-c*k19/a-a*k7/c+b*k7/c,
        -a*k6/c+b*k6/c, -a*k8/c+b*k8/c, -a*k11/c+b*k11/c+k17,
        -a*k10/c+b*k10/c-k18, -a*k9/c+b*k9/c,
        -a*k14/c+b*k14/c-a*k20/b+c*k20/b,
        -a*k13/c+b*k13/c+a*k21/c-b*k21/c-a*k5/c+b*k5/c,
        a*k44/c-b*k44/c, -a*k45/c+b*k45/c, -a*k44/c+b*k44/c,
        a*k46/c-b*k46/c, -k47+b*k47/a+b*k47/c-b**2*k47/(a*c),
        -a*k12/c+b*k12/c, a*k45/c-b*k45/c, -a*k46/c+b*k46/c,
        -k48+a*k48/b+a*k48/c-a**2*k48/(b*c),
        a**2*k49/c**2-2*a*b*k49/c**2+b**2*k49/c**2, k8, k11, -k15,
        k10-k18, -k17, k9, -k16, -k29, k14-k32, -k21+k23-k31,
        -k24-k30, -k35, k44, -k45, k36, k13-k23+k39, -k20+k38,
        k25+k37, b*k26/a-c*k26/a-k34+k42, -2*k44, k45, k46,
        b*k47/a-c*k47/a, k41, k44, -k46, -b*k47/a+c*k47/a,
        k12+k24, -k19-k25, -a*k27/b+c*k27/b-k33, k45, -k46,
        -a*k48/b+c*k48/b, a*k28/c-b*k28/c+k40, -k45, k46,
        a*k48/b-c*k48/b, a*k49/c-b*k49/c, -a*k49/c+b*k49/c,
        -k1, -k4, -k3, k15, k18-k2, k17, k16, k22, k25-k7,
        k24+k30, k21+k23-k31, k28, -k44, k45, -k30-k6, k20+k32,
        k27+b*k33/a-c*k33/a, k44, -k46, -b*k47/a+c*k47/a, -k36,
        k31-k39-k5, -k32-k38, k19-k37, k26-a*k34/b+c*k34/b-k42,
        k44, -2*k45, k46, a*k48/b-c*k48/b, a*k35/c-b*k35/c-k41,
        -k44, k46, b*k47/a-c*k47/a, -a*k49/c+b*k49/c, -k40, k45,
        -k46, -a*k48/b+c*k48/b, a*k49/c-b*k49/c, k1, k4, k3, -k8,
        -k11, -k10+k2, -k9, k37+k7, -k14-k38, -k22, -k25-k37, -k24+k6,
        -k13-k23+k39, -k28+b*k40/a-c*k40/a, k44, -k45, -k27, -k44,
        k46, b*k47/a-c*k47/a, k29, k32+k38, k31-k39+k5, -k12+k30,
        k35-a*k41/b+c*k41/b, -k44, k45, -k26+k34+a*k42/c-b*k42/c,
        k44, k45, -2*k46, -b*k47/a+c*k47/a, -a*k48/b+c*k48/b,
        a*k49/c-b*k49/c, k33, -k45, k46, a*k48/b-c*k48/b,
        -a*k49/c+b*k49/c },
       {k1, k2, k3, k4, k5, k6, k7, k8, k9, k10, k11, k12, k13, k14,
        k15, k16, k17, k18, k19, k20, k21, k22, k23, k24, k25, k26,
        k27, k28, k29, k30, k31, k32, k33, k34, k35, k36, k37, k38,
        k39, k40, k41, k42, k43, k44, k45, k46, k47, k48, k49});


{{k1=0,

  k2=0,

  k3=0,

  k4=0,

  k5=0,

  k6=0,

  k7=0,

  k8=0,

  k9=0,

  k10=0,

  k11=0,

  k12=0,

  k13=0,

  k14=0,

  k15=0,

  k16=0,

  k17=0,

  k18=0,

  k19=0,

  k20=0,

  k21=0,

  k22=0,

  k23=arbcomplex(14),

  k24=0,

  k25=0,

       arbcomplex(15)*a
  k26=------------------,
              c

  k27=0,

  k28=0,

  k29=0,

  k30=0,

  k31=arbcomplex(14),

  k32=0,

  k33=0,

       arbcomplex(15)*b
  k34=------------------,
              c

  k35=0,

  k36=0,

  k37=0,

  k38=0,

  k39=arbcomplex(14),

  k40=0,

  k41=0,

  k42=arbcomplex(15),

  k43=arbcomplex(16),

  k44=0,

  k45=0,

  k46=0,

  k47=0,

  k48=0,

  k49=0}}


off cramer;



% Problem 5.

solve ({2*a3*b3+a5*b3+a3*b5, a5*b3+2*a5*b5+a3*b5,
        a5*b5, a2*b2, a4*b4, a5*b1+b5+a4*b3+a3*b4,
        a5*b3+a5*b5+a3*b5+a3*b3, a0*b2+b2+a4*b2+a2*b4+c2+a2*b0+a2*b1,
        a0*b0+a0*b1+a0*b4+a3*b2+b0+b1+b4+a4*b0+a4*b1+a2*b5+a4*b4+c1+c4
        +a5*b2+a2*b3+c0,
        -1+a3*b0+a0*b3+a0*b5+a5*b0+b3+b5+a5*b4+a4*b3+a4*b5+a3*b4+a5*b1
        +a3*b1+c3+c5,
        b4+a4*b1, a5*b3+a3*b5, a2*b1+b2, a4*b5+a5*b4, a2*b4+a4*b2,
        a0*b5+a5*b0+a3*b4+2*a5*b4+a5*b1+b5+a4*b3+2*a4*b5+c5,
        a4*b0+2*a4*b4+a2*b5+b4+a4*b1+a5*b2+a0*b4+c4,
        c3+a0*b3+2*b3+b5+a4*b3+a3*b0+2*a3*b1+a5*b1+a3*b4,
        c1+a0*b1+2*b1+a4*b1+a2*b3+b0+a3*b2+b4});


Unknowns: {a0,a2,a3,a4,a5,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5}

{{a0=arbcomplex(25),

  a2=0,

       - 1
  a3=------,
       b1

  a4=0,

  a5=0,

  b0=arbcomplex(24),

  b1=arbcomplex(23),

  b2=0,

  b3=0,

  b4=0,

  b5=0,

  c0= - a0*b0 + b1,

  c1= - a0*b1 - b0 - 2*b1,

  c2=0,

      b0 + 2*b1
  c3=-----------,
         b1

  c4=0,

  c5=0},

 {a0=arbcomplex(20),

  a2=arbcomplex(21),

  a3=0,

  a4=0,

  a5=0,

  b0=arbcomplex(22),

  b1=0,

  b2=0,

  b3=-1,

  b4=0,

  b5=0,

  c0= - a0*b0,

  c1=a2 - b0,

  c2= - a2*b0,

  c3=a0 + 2,

  c4=0,

  c5=0},

 {a0=arbcomplex(17),

  a2=0,

  a3=0,

  a4=0,

  a5=0,

  b0=arbcomplex(18),

  b1=arbcomplex(19),

  b2=0,

  b3=-1,

  b4=0,

  b5=0,

  c0= - a0*b0 + b1,

  c1= - a0*b1 - b0 - 2*b1,

  c2=0,

  c3=a0 + 2,

  c4=0,

  c5=0}}



% Problem 6.

solve({2*a3*b3+a5*b3+a3*b5, a5*b3+2*a5*b5+a3*b5,
       a4*b4, a5*b3+a5*b5+a3*b5+a3*b3, b1, a3*b3, a2*b2, a5*b5,
       a5*b1+b5+a4*b3+a3*b4, a0*b2+b2+a4*b2+a2*b4+c2+a2*b0+a2*b1,
       b4+a4*b1, b3+a3*b1, a5*b3+a3*b5, a2*b1+b2, a4*b5+a5*b4,
       a2*b4+a4*b2, a0*b0+a0*b1+a0*b4+a3*b2+b0+b1+b4+a4*b0+a4*b1
       +a2*b5+a4*b4+c1+c4+a5*b2+a2*b3+c0,-1+a3*b0+a0*b3+a0*b5+a5*b0
       +b3+b5+a5*b4+a4*b3+a4*b5+a3*b4+a5*b1+a3*b1+c3+c5,
       a0*b5+a5*b0+a3*b4+2*a5*b4+a5*b1+b5+a4*b3+2*a4*b5+c5,
       a4*b0+2*a4*b4+a2*b5+b4+a4*b1+a5*b2+a0*b4+c4,
       c3+a0*b3+2*b3+b5+a4*b3+a3*b0+2*a3*b1+a5*b1+a3*b4,
       c1+a0*b1+2*b1+a4*b1+a2*b3+b0+a3*b2+b4});


Unknowns: {a0,a2,a3,a4,a5,b0,b1,b2,b3,b4,b5,c0,c1,c2,c3,c4,c5}

{}


% Example cited by Bruno Buchberger
%        in R.Janssen: Trends in Computer Algebra,
%     Springer, 1987
% Geometry of a simple robot,
%   l1,l2   length of arms
%   ci,si   cos and sin of rotation angles


solve( { c1*c2 -cf*ct*cp + sf*sp,
         s1*c2 - sf*ct*cp - cf*sp,
         s2 + st*cp,
         -c1*s2 - cf*ct*sp + sf*cp,
         -s1*s2 + sf*ct*sp - cf*cp,
         c2 - st*sp,
         s1 - cf*st,
         -c1 - sf*st,
         ct,
         l2*c1*c2 - px,
         l2*s1*c2 - py,
         l2*s2 + l1 - pz,
         c1**2 + s1**2 -1,
         c2**2 + s2**2 -1,
         cf**2 + sf**2 -1,
         ct**2 + st**2 -1,
         cp**2 + sp**2 -1},
      {c1,c2,s1,s2,py,cf,ct,cp,sf,st,sp});


                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
{{c1=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=---------------------------------------,
                       l2

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

  py

                 2               2     2         2               2     2     2
     - sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  =-----------------------------------------------------------------------------
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

  ,

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

      l1 - pz
  cp=---------,
        l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

  st=1,

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=---------------------------------------},
                       l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=---------------------------------------,
                       l2

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

  py

                 2               2     2         2               2     2     2
     - sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  =-----------------------------------------------------------------------------
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

  ,

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

       - l1 + pz
  cp=------------,
          l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

  st=-1,

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=------------------------------------},
                      l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=---------------------------------------,
                       l2

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

                2               2     2         2               2     2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  py=--------------------------------------------------------------------------,
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

       - l1 + pz
  cp=------------,
          l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

  st=-1,

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=------------------------------------},
                      l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=---------------------------------------,
                       l2

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

                2               2     2         2               2     2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  py=--------------------------------------------------------------------------,
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

      l1 - pz
  cp=---------,
        l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

  st=1,

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=---------------------------------------},
                       l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=------------------------------------,
                      l2

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

                2               2     2         2               2     2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  py=--------------------------------------------------------------------------,
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

      l1 - pz
  cp=---------,
        l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

  st=1,

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=------------------------------------},
                      l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=------------------------------------,
                      l2

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

                2               2     2         2               2     2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  py=--------------------------------------------------------------------------,
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

       - l1 + pz
  cp=------------,
          l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

  st=-1,

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=---------------------------------------},
                       l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=------------------------------------,
                      l2

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

  py

                 2               2     2         2               2     2     2
     - sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  =-----------------------------------------------------------------------------
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

  ,

             2               2     2     2
      sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=---------------------------------------,
                2               2     2
         sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

       - l1 + pz
  cp=------------,
          l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

  st=-1,

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=---------------------------------------},
                       l2

                   2               2     2
       - sqrt( - l1  + 2*l1*pz + l2  - pz )*px
 {c1=------------------------------------------,
               2               2     2
             l1  - 2*l1*pz - l2  + pz

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  c2=------------------------------------,
                      l2

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  s1=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

       - l1 + pz
  s2=------------,
          l2

  py

                 2               2     2         2               2     2     2
     - sqrt( - l1  + 2*l1*pz + l2  - pz )*sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  =-----------------------------------------------------------------------------
                                 2               2     2
                          sqrt(l1  - 2*l1*pz - l2  + pz )

  ,

                2               2     2     2
       - sqrt(l1  - 2*l1*pz - l2  + px  + pz )
  cf=------------------------------------------,
                 2               2     2
          sqrt(l1  - 2*l1*pz - l2  + pz )

  ct=0,

      l1 - pz
  cp=---------,
        l2

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )*px
  sf=---------------------------------------,
              2               2     2
            l1  - 2*l1*pz - l2  + pz

  st=1,

                2               2     2
      sqrt( - l1  + 2*l1*pz + l2  - pz )
  sp=------------------------------------}}
                      l2


% Steady state computation of a prototypical chemical
% reaction network (the "Edelstein" network)
 
solve(
 { alpha * c1 - beta * c1**2 - gamma*c1*c2 + epsilon*c3,
   -gamma*c1*c2 + (epsilon+theta)*c3 -eta *c2,
   gamma*c1*c2 + eta*c2 - (epsilon+theta) * c3},
  {c3,c2,c1});


               2
      c1*( - c1 *beta*gamma + c1*alpha*gamma - c1*beta*eta + alpha*eta)
{{c3=-------------------------------------------------------------------,
                        c1*gamma*theta - epsilon*eta

      c1*( - c1*beta*epsilon - c1*beta*theta + alpha*epsilon + alpha*theta)
  c2=-----------------------------------------------------------------------,
                          c1*gamma*theta - epsilon*eta

  c1=arbcomplex(26)}}


solve(
{( - 81*y1**2*y2**2 + 594*y1**2*y2 - 225*y1**2 + 594*y1*y2**2 - 3492*
y1*y2 - 750*y1 - 225*y2**2 - 750*y2 + 14575)/81,
( - 81*y2**2*y3**2 + 594*y2**2*y3 - 225*y2**2 + 594*y2*y3**2 - 3492*
y2*y3 - 750*y2 - 225*y3**2 - 750*y3 + 14575)/81,
( - 81*y1**2*y3**2 + 594*y1**2*y3 - 225*y1**2 + 594*y1*y3**2 - 3492*
y1*y3 - 750*y1 - 225*y3**2 - 750*y3 + 14575)/81,
(2*(81*y1**2*y2**2*y3 + 81*y1**2*y2*y3**2 - 594*y1**2*y2*y3 - 225*y1
**2*y2 - 225*y1**2*y3 + 1650*y1**2 + 81*y1*y2**2*y3**2 - 594*y1*
y2**2*y3 - 225*y1*y2**2 - 594*y1*y2*y3**2 + 2592*y1*y2*y3 + 2550
*y1*y2 - 225*y1*y3**2 + 2550*y1*y3 - 3575*y1 - 225*y2**2*y3 +
1650*y2**2 - 225*y2*y3**2 + 2550*y2*y3 - 3575*y2 + 1650*y3**2 -
3575*y3 - 30250))/81}, {y1,y2,y3,y4});


           2
{{y1=(99*y3  - 582*y3

                      4          3           2
       + 4*sqrt(243*y3  - 3348*y3  + 15282*y3  - 26100*y3 + 11875)*sqrt(2) - 125

                2
      )/(3*(9*y3  - 66*y3 + 25)),

           2
  y2=(99*y3  - 582*y3

                      4          3           2
       - 4*sqrt(243*y3  - 3348*y3  + 15282*y3  - 26100*y3 + 11875)*sqrt(2) - 125

                2
      )/(3*(9*y3  - 66*y3 + 25)),

  y3=arbcomplex(27)},

           2
 {y1=(99*y3  - 582*y3

                      4          3           2
       - 4*sqrt(243*y3  - 3348*y3  + 15282*y3  - 26100*y3 + 11875)*sqrt(2) - 125

                2
      )/(3*(9*y3  - 66*y3 + 25)),

           2
  y2=(99*y3  - 582*y3

                      4          3           2
       + 4*sqrt(243*y3  - 3348*y3  + 15282*y3  - 26100*y3 + 11875)*sqrt(2) - 125

                2
      )/(3*(9*y3  - 66*y3 + 25)),

  y3=arbcomplex(28)},

      11      11      11
 {y1=----,y2=----,y3=----},
      3       3       3

       - 5       - 5       - 5
 {y1=------,y2=------,y3=------}}
       3         3         3


% Another nice nonlinear system.

solve({y=x+t^2,x=y+u^2},{x,y,u,t});


         2
{{x=y - t ,

  y=arbcomplex(32),

  u=t*i,

  t=arbcomplex(31)},

         2
 {x=y - t ,

  y=arbcomplex(30),

  u= - t*i,

  t=arbcomplex(29)}}


% Example from Stan Kameny (relation between Gamma function values)
%   containing surds in the coefficients.

solve({x54=x14/4,x54*x34=sqrt pi/sqrt 2*x32,x32=x12/2,
       x12=sqrt pi, x14*x34=pi*sqrt 2});


Unknowns: {x12,x14,x32,x34,x54}

{{x12=sqrt(pi),

  x14=4*arbcomplex(33),

       sqrt(pi)
  x32=----------,
          2

       sqrt(2)*pi
  x34=------------,
         4*x54

  x54=arbcomplex(33)}}


% A system given by J. Hietarinta with complex coefficients.

on complex;



apu := {2*a - a6,2*b*c3 - 1,i - 2*x + 1,2*x**2 - 2*x + 1,n1 + 1}$



solve apu;


Unknowns: {a,a6,b,c3,n1,x}

     a6
{{a=----,
     2

      1
  b=------,
     2*c3

  c3=arbcomplex(34),

  n1=-1,

       1
  x=-------}}
     1 - i


clear apu;



off complex;



% More examples that can now be solved.

solve({e^(x+y)-1,x-y},{x,y});


{{x=log(-1),y=log(-1)},{x=0,y=0}}


solve({e^(x+y)+sin x,x-y},{x,y});


                 2*y_
{{x=y,y=root_of(e     + sin(y_),y_,tag_16)}}
 % no algebraic solution exists.

solve({e^(x+y)-1,x-y**2},{x,y});


     2          2
{{x=y ,y=0},{x=y ,y=-1}}


solve(e^(y^2) * e^y -1,y);


{y=0}


solve(e^(y^2 +y)-1,y);


{y=0}


solve(e^(y^2)-1,y);


{y=0}


solve(e^(y^2+1)-1,y);


{y=i,y= - i}


solve({e^(x+y+z)-1,x-y**2=1,x**2-z=2},{x,y,z});


     2
{{x=y  + 1,

                         1                      1
                  asinh(---)             asinh(---)
                         2                      2
  y=sqrt(3)*cosh(------------)*i + sinh(------------),
                      3                      3

     4      2
  z=y  + 2*y  - 1},

     2
 {x=y  + 1,

                            1                      1
                     asinh(---)             asinh(---)
                            2                      2
  y= - sqrt(3)*cosh(------------)*i + sinh(------------),
                         3                      3

     4      2
  z=y  + 2*y  - 1},

     2
 {x=y  + 1,

                      1
               asinh(---)
                      2
  y= - 2*sinh(------------),
                   3

     4      2
  z=y  + 2*y  - 1},

     2            4      2
 {x=y  + 1,y=0,z=y  + 2*y  - 1}}


solve(e^(y^4+3y^2+y)-1,y);


                           2/3                   1/3  1/3
{y=(sqrt( - 3*(sqrt(5) + 3)    - 12*(sqrt(5) + 3)   *2    + 2*sqrt(

                           2/3  2/3                1/3           1/3  1/6
            9*(sqrt(5) + 3)   *2    + (sqrt(5) + 3)   *sqrt(15)*3   *3

                              1/3          1/3  1/6                   1/3
             + 3*(sqrt(5) + 3)   *sqrt(3)*3   *3    + 12*(sqrt(5) + 3)

                  1/3           1/6      1/3          1/6      1/3   1/3  1/6
             + 2*6   *sqrt(15)*3    + 6*6   *sqrt(3)*3    + 6*2   )*3   *3

               2/3                 1/3            1/3
          - 3*2   ) + (sqrt(5) + 3)   *sqrt(3) - 2   *sqrt(3))/(2

                    1/6  1/6
      *(sqrt(5) + 3)   *2   *sqrt(3))}


% Transcendental equations proposed by Roger Germundsson
% 

eq1 := 2*asin(x) + asin(2*x) - PI/2;


        2*asin(2*x) + 4*asin(x) - pi
eq1 := ------------------------------
                     2

eq2 := 2*asin(x) - acos(3*x);


eq2 :=  - acos(3*x) + 2*asin(x)

eq3 := acos(x) - atan(x);


eq3 := acos(x) - atan(x)

eq4 := acos(2*x**2 - 4*x -x) - 2*asin(x);


               2
eq4 := acos(2*x  - 5*x) - 2*asin(x)

eq5 := 2*atan(x) - atan( 2*x/(1-x**2) );


              2*x
eq5 := atan(--------) + 2*atan(x)
              2
             x  - 1


sol1 := solve(eq1,x);


            sqrt(3) - 1
sol1 := {x=-------------}
                 2

sol2 := solve(eq2,x);


            sqrt(17) - 3
sol2 := {x=--------------}
                 4

sol3 := solve(eq3,x);


            sqrt(sqrt(5) - 1)
sol3 := {x=-------------------}
                 sqrt(2)

sol4 := solve(eq4,x);


sol4 := {}

sol5 := solve(eq5,x);


sol5 := {x=arbcomplex(36)}
   % This solution should be the open interval
			% (-1,1).

% Example 52 of M. Wester: the function has no real zero although
%  REDUCE 3.5 and Maple tend to return 3/4.

if solve(sqrt(x^2 +1) - x +2,x) neq {} then rederr "Illegal result";



% Using a root_of expression as an algebraic number.

solve(x^5 - x - 1,x);


             5
{x=root_of(x_  - x_ - 1,x_,tag_22)}


w:=rhs first ws;


               5
w := root_of(x_  - x_ - 1,x_,tag_22)


w^5;


          5
root_of(x_  - x_ - 1,x_,tag_22) + 1


w^5-w;


1


clear w;



% The following examples come from Daniel Lichtblau of WRI and were
% communicated by Laurent.Bernardin from ETH Zuerich.

solve(x-Pi/2 = cos(x+Pi),x);


{x=root_of(2*cos(x_) - pi + 2*x_,x_,tag_24)}


solve(exp(x^2+x+2)-1,x);


    sqrt(7)*i - 1
{x=---------------}
          2


solve(log(sqrt(1+z)/sqrt(z-1))=x,z);


     2*x
    e    + 1
{z=----------}
     2*x
    e    - 1


solve({exp(x+3*y-2)=7,3^(2*x-y+4)=2},{x,y});


   x + 3*y      2
{{e        - 7*e =0},

      2*x      y
 {81*3    - 2*3 =0}}


solve(a*3^(c*t)+b*3^((c+a)*t),t);


          - a
    log(------)
          b
{t=-------------}
     log(3)*a


solve(log(x+sqrt(x^2+a))=b,{x});


     2*b
    e    - a
{x=----------}
         b
      2*e


solve(z=log(w)/log(2)+w^2,w);


                              2
{w=root_of(log(w_) + log(2)*w_  - log(2)*z,w_,tag_27)}


solve(w*2^(w^2)=5,w);


              2
            w_
{w=root_of(2   *w_ - 5,w_,tag_29)}


solve(log(x/y)=1/y^2*(x+(1/x)),y);


                x        2    2
{y=root_of(log(----)*x*y_  - x  - 1,y_,tag_31)}
                y_


solve(exp(z)=w*z^(-n),z);


             n  z_
{z=root_of(z_ *e   - w,z_,tag_33)}


solve(-log(3)+log(2+y/3)/2-log(y/3)/2=(-I)/2*Pi,y);


     - 3
{y=------}
     5


solve(-log(x)-log(y/x)/2+log(2+y/x)/2=(-3*I)/2*Pi,y);


     - 2*x
{y=--------}
     2
    x  + 1


solve((I+1)*log(x)+(3*I+3)*log(x+3)=7,x);


             i         3*i   4       i         3*i   3        i         3*i   2
{x=root_of(x_ *(x_ + 3)   *x_  + 9*x_ *(x_ + 3)   *x_  + 27*x_ *(x_ + 3)   *x_

                   i         3*i       7
            + 27*x_ *(x_ + 3)   *x_ - e ,x_,tag_35)}


solve(x+sqrt(x)=1,x);


     - sqrt(5) + 3
{x=----------------}
          2


solve({cos(1/5+alpha+x)=5,cos(2/5+alpha-x)=6},{alpha,x});


       5*alpha - 5*x + 2
{{cos(-------------------) - 6=0},
               5

       5*alpha + 5*x + 1
 {cos(-------------------) - 5=0}}
               5


end;


Time for test: 1403 ms, plus GC time: 127 ms
@@@@@ Resources used: (2 18 153 54)
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/polineq.red0000644000175000017500000001016411526203062024001 0ustar  giovannigiovannimodule polineq; % Solve univariate polynomial inequality systems;

% Author: Herbert Melenk, ZIB Berlin.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% All rights reserved.

% Method: compute the real roots of all numerators and denominators
% and check the intervals between them.

global '(!!arbint);

if not get('arbreal,'simpfn) then mkop 'arbreal;

symbolic procedure polineqeval u;
 begin scalar w,x;
   w:=reval car u;
   if eqcar(w,'list) then w:=for each q in cdr w collect reval q
      else w:={w};
   if cdr u then x:=reval cadr u;
   if eqcar(x,'list) then if cddr x then typerr(x,"variable")
       else x:=cadr x;
   return polineq0(w,x);
  end;

symbolic procedure polineq0(ul,x);
  begin scalar b,n,d,l,w,wl,op,u,r,s,x,y,z;
   loop:
     u:=car ul; ul:=cdr ul;
     if not pairp u or not((op:=car u) memq '(geq greaterp leq lessp))
      then go to typerr;
     s:= s or op = 'greaterp or op = 'lessp;
     w:=simp if op='greaterp or op='geq
               then {'difference,cadr u,caddr u}
              else {'difference,caddr u,cadr u};
     wl := w.wl;
     y:=(not domainp numr w and mvar numr w) or
        (not domainp denr w and mvar denr w);
      % check for a polynomial in a free variable.
     if null y or x and x neq y
        or pairp y and (get(car y,'!:rd!:) or get(car y,'opmtch))
         then go to typerr;
     x:=y;
     n:= append(n,polineq!-realroots(numr w,x));
     d:= append(d,polineq!-realroots(denr w,x));
   if ul then go to loop;
   for each y in append(n,d) do if not(y member b) then b:=y.b;
   if null b then return if polineqcheck(wl,{x . 0})
         then {'list,{'equal,x,{'arbreal,!!arbint := !!arbint+1}}}
                   else '(list);
    b:=sort(b,'evallessp);
      % Create the intervals;
    while b do
    <>;
      % check and collect the intervals;
    for each v in l do
    << if polineqcheck(wl,{x.car v}) then
       r:=(if null cadr v then
             {if s then 'lessp else 'leq, x, caddr v}
           else if null caddr v then
             {if s then 'greaterp else 'geq, x, cadr v}
           else {'equal,x, '!*interval!*.cdr v}) . r
    >>;
    return 'list.r;
typerr: rederr("wrong arguments for polynomial inequality solver");
  end;

symbolic procedure polineqcheck(wl,p);
   null wl or not minusf numr subsq(car wl,p)
                and polineqcheck(cdr wl,p);

symbolic procedure polineq!-realroots(u,x);
  % return real roots of u, if possible as rational numbers.
 if domainp u then nil else
 for each f in cdr fctrf u join
 <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/ineq.tst0000644000175000017500000000232511526203062023326 0ustar  giovannigiovanni% polynomial Inequality (Example where another system returned {1 <= x})

ineq_solve(  (2*x^2+x-1)/(x-1) >=  (x+1/2)^2 ,x);

ineq_solve({(2*x^2+x-1)/(x-1) >=  (x+1/2)^2, x>0});

ineq_solve({(2*x^2+x-1)/(x-1) >=  (x+1/2)^2, x<-1});


% Systems for determining indices of Jacobi polynomials (Winfried Neun).

reg := 
{2*a - 3>=0, 3>=0, 3>=0, 1>=0, 1>=0, 5>=0, 4>=0, 2*a - 4>=0, 2>=0,
 2>=0, 0>=0, 2*a - 2>=0, k + 1>=0, - 2*a + k - 3>=0, - 2*a + k - 2>=0,
  - 2*a + k>=0, k - 7>=0, 2*a - k + 4>=0, 2*a - k + 5>=0, 2*a - k + 3>=0}$

ineq_solve(reg,{k,a});

reg:=
{a + b - c>=0, a - b + c>=0, - a + b + c>=0, 0>=0, 2>=0,
 2*c - 2>=0, a - b + c>=0, a + b - c>=0, - a + b + c - 2>=0,
 2>=0, 0>=0, 2*b - 2>=0, k + 1>=0, - a - b - c + k>=0,
  - a - b - c + k + 2>=0, - 2*b + k>=0, - 2*c + k>=0, a + b + c - k>=0,
 2*b + 2*c - k - 2>=0, a + b + c - k>=0}$

ineq_solve (reg,{k,a,b,c});

clear reg;

% Example from Richard Liska.

lvars:={a,b,d}$
lfcond := {d>=0,
           b + d>=0,
           2 a - b + d + 2>=0,
            - a + 2 d + 1>=0,
           b>=0,
           2 a - b>=0,
            - a + 2 d>=0,
           b - d>=0,
           2 a - b - d - 2>=0,
            - a + 2 d - 1>=0}$

ineq_solve(lfcond,lvars);

clear lfcond,lvars;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/modsr.tst0000644000175000017500000000255011526203062023516 0ustar  giovannigiovanni% Test series for the package MODSR: SOLVE and ROOTS for
% modular polynomials and modular polynomial systems.
% Moduli need not be primes.

on modular;

setmod 8;
m_solve(2x=3);         % {}
m_solve(2x=4);         % {{x=2},{x=6}}
m_solve(x^2-1);        % {{x=1},{x=3},{x=5},{x=7}}
m_solve({x^2-y^3=3});  % {{x=0,y=5}, {x=2,y=1}, {x=4,y=5}, {x=6,y=1}}
m_solve({x^2-y^3=3,x=2});  % {{y=1,x=2}}
m_solve({x=2,x^2-y^3=3});  % {{x=2,y=1}}
m_solve({x1,x2 + 6,2*x1**3 + 4*x2**4 + x3 + 6}); % {{x1=0,x2=2,x3=2}}

setmod 800;
m_solve(x^2-1);
  % {{x=1}, {x=49}, {x=351}, {x=399}, {x=401}, {x=449}, {x=751}, {x=799}}

m_solve({x1 + 51,
282*x1^4 + x2 + 468,
x3 + 1054,
256*x1^2 + 257*x2^4 + 197*x3 + x4 + 653,
255*x1^4 + 40*x2^2 + x5 + 868,
230*x1^4 + 670*x3 + 575*x4^4 + 373*x5^3 + x6 + 1328,
182*x4^4 + 727*x5^2 + 609*x6**4 + x7 + 1032,
623*x1^3 + 614*x2^4 + 463*x3**2 + 365*x4 + 300*x7 + x8 + 1681});

% {{x1=749,x2=50,x3=546,x4=729,x5=77,x6=438,x7=419,x8=399}}

m_solve{x+y=4,x^2+y^2=8};

off modular;

% m_roots has the modulus as its second argument.

m_roots(x^2-1,8);   %  {1,3,5,7}
m_roots(x^3-1,7);   %  {1,2,4}
m_roots(x^3-x,7);   %  {0,1,6}
m_roots((x-1)*(x-2)*(x-3),7); % {1,2,3}
m_roots((x-1)*(x-2)*(x^3-1)*(x-5),7); % {1,2,4,5}
m_roots((x-1)*(x-2)*(x^3-1)*(x-5),1009); % {1,2,5,374,634}
m_roots((x-1)*(x-2)*(x^3-1)*(x-5),1000);
length ws;                               % 35

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/linineq.red0000644000175000017500000004232611526203062023776 0ustar  giovannigiovannimodule linineq; % Linear inequalities and linear optimization.

% Author:       Herbert Melenk 

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version 1     January 1990
% Version 1.1   February 1990
%               added parameter "record=t"
% Version 2     May 1991
%               added Branch-and-Bound for Integer Prgramming
% Version 3     Dec 1994
%               added formal simplifier for MAX/MIN expressions.
%               Changed "inf" to "infinity".
%               Operator linineq_solve new.
% Version 4     Jan 95
%               use polytope points for the simplification of MAX/MIN
%               expressions.
% Version 5     Jul 2003
%               Adaptation of the actual REDUCE language standard.
%               Correction of the handling of an isolated linear
%               inequality (call "getrlist" only if the car of
%               the expression is "list").

%
% Solution of linear inequalities & equations with numerical
% coefficients.
%
%   Fourier(1826) /Motzkin(1936): George. B. Dantzig,
%                  Linear Programming and Extensions.


put('linineq,'psopfn,
       function (lambda(u);
                    rederr "USE simplex (package linalg) instead"));

global '(!*trlinineq !*trlinineqint !*prlinineq);
switch trlinineq,prlinineq,trlinineqint;
fluid '(linineqinterval!* linineqrecord!*);

fluid '(!*ineqerr);   % error code

symbolic procedure linineqeval u;
  % Interface for algebraic mode.
   begin scalar prob,equa,requa,vars,oldorder,res,u1,x,y,p,e,msg;
         scalar direction,rec,linineqrecord!*,r,intvars,w1,w2,op;
      msg:=!*prlinineq or !*trlinineq;
      !*ineqerr :=nil;
      u1:=reval car u;
      u1:= if car u1='list then getrlist u1 else {u1};
      u:=cdr u;
      if u then
      <>;
      while u do <> >>;
      x:=nil;
      for each u in vars do
       <> else
                <>;
         if smember(u,u1)and not member(u,x)then x:=u.x>>;
      x:=vars:=reversip x;
      while u1 do
      <>;
        op:=car u; w1:=reval cadr u; w2:=reval caddr u;
        if op='geq then
          if smemq('infinity,w2)then nil else
          if eqcar(w2,'max)then
             for each q in cdr w2 do
               u1:=append(u1,{{'geq,w1,q}})
          else prob:=(simp w1.simp w2).prob else
        if op='leq then
         if smemq('infinity,w2)then nil else
         if eqcar(w2,'min)then
             for each q in cdr w2 do
               u1:=append(u1,{{'leq,w1,q}})
          else prob:=(simp w2.simp w1).prob else
        if op='equal then
            if eqcar(w2,'!*interval!*)then
              u1:=append(u1,{{'geq,w1,cadr w2},{'leq,w1,caddr w2}})
            else
             equa:=(simp w1.simp w2).equa
         else
           <> >>;
        % control the linearity
      for each p in append(equa,prob)do
      <>;
        vars:=linineqevaltest(numr car p,
                        linineqevaltest(numr cdr p,vars))>>;
      if msg then <>;
      oldorder:=setkorder vars;
      prob:=for each p in prob collect
       (reorder numr car p./denr car p).
             (reorder numr cdr p./denr cdr p);
      equa:= for each p in equa collect
       (reorder numr car p./denr car p).
             (reorder numr cdr p./denr cdr p);
       % eliminate variables from equations
      while equa do
      <> >>
         else
        <>
                 else
                 <<
          prob:=for each p in prob collect
                        subsq(car p,u).subsq(cdr p,u);
          equa:=for each p in equa collect
                        subsq(car p,u).subsq(cdr p,u);
          requa:=append(u,requa);
          if msg then
            <>;
          vars:=delete(x,vars);
                 >> >> >>;
      res:=if intvars
               then linineqint(prob,vars,msg,direction,rec,intvars)
             else linineq1(prob,vars,msg,direction,rec);
          % backsubstitution in equations;
      if null res then return '(list)else if res=t then res:=nil;
      for each e in requa do
      <> >>;
      setkorder oldorder;
      r:=if rec then for each p in
               liqsimp!-maxmin pair(res,linineqrecord!*)
            collect
                   {'list,{'equal,caar p,cdar p},cadr p,caddr p}
            else
           for each p in res collect {'equal,car p,cdr p};
      return 'list.r end;

% put('linineq_solve,'psopfn,'linineqseval);

symbolic procedure linineqseval u;
% neu (eine Zeile):
   'list.reversip for each q in
     cdr linineqeval append(u,'((equal record t)))
       collect {'equal,cadr cadr q,
        if caddr q = cadddr q then caddr q else '!*interval!*.cddr q};

symbolic procedure linineqevaltest(f,v);
   % Collect the variables in standard form f and control linearity.
     if domainp f then v else
     if not(ldeg f=1)then
           <>
       else
     if member(mvar f,v)then linineqevaltest(red f,v)else
         linineqevaltest(red f,mvar f.v);

symbolic procedure linineq0(prob,vars,dir,rec);
  % Interface for symbolic mode.
  % Prob is a list (e1,e2,..)of algebraic expressions without
  % relational operators, which are interpreted as
  % set of inequalities ei >= 0. They are linear in the
  % variables vars.
  % Silent operation: result=nil if the system is inconsistent.
   begin scalar oldorder,res;
      linineqrecord!*:=nil;
      oldorder:=setkorder vars;
      prob:=for each u in prob collect simp u.(nil./1);
      res:=linineq1(prob,vars,nil,dir,rec);
      setkorder oldorder;
      return res end;

symbolic procedure linineqint(prob,vars,msg,dir,rec,intvars);
  begin scalar x,x0,y,y0,y1,z,w,problems,best,z,z0,zbest,zf,bestr;
       % test integer variables and adjust order;
    for each x in vars do
      if member(x,intvars)then<>;
    if intvars
      then <>;
    intvars:=reversip w;
       % select primary optimization principle.
        if dir then<>;
      if w then
      <<% test feasability;
        y:=list prob;
        for each x in intvars do
        <> >> >>;
        if cdr y then
         problems:=append(problems,for each q in y collect z0.q)
        else
         <  is feasable">>
       >>;  % if w
               % without target dont need additional result.
           if best and null dir then problems:=nil
     >>;  % while problems
   linineqrecord!*:=bestr;
   return best end;

symbolic procedure linineq1(prob,vars,msg,dir,rec);
  % Algebraic evaluation of a set of inequalities:
  % prob is a list of pairs of standard quotients,
  % (( p1.q1)(p2.q2) .. (pn.qn))
  % which are interpreted as inequalities:
  %     pi >= qi ;
  % vars is the list of (linear) variables.
  % dir  the direction of final optimization
  % rec  switch; if t, the record of inequatlities is produced
  % Result is NIL if the system has no solution; otherwise
  % the solution has the form of an association list
  %  ((v1.val1)(v2.val2) ... (vn.valn)),
  % where vi are the variables and vali are values in algebraic
  % form. NIL if the system has no solution.
  %
   begin scalar v,vq,lh,rh,x,y,z,prob1,prob2,prob3,prob4,nprob,sw,sol;
      if null vars then return linineq2(prob,msg);
      v:=car vars; vars:=cdr vars;
      vq:=mksq(v,1);
      if !*trlinineq then
       linineqprint2({"next variable:",v,"; initial system:"},prob);
      prob:=linineqnormalize prob;
      for each p in prob do
       <>else if domainp numr rh and domainp numr lh then
                prob4:=(lh.rh).prob4 else
                prob3:=(lh.rh).prob3>>;
      if null prob1 and null prob2 and vars then
      << sol:=linineq1(prob,vars,msg,dir,rec);
         if rec then linineqrecord!* :=
             append(linineqrecord!*,'(((minus infinity) infinity)));
         return if sol then (v. 0).sol else nil>>;
      if !*trlinineq then
      <>;
      if rec then
      << x:=for each u in prob1 collect prepsq cdr u;
         y:=for each u in prob2 collect prepsq car u;
         x:=if null x then '(minus infinity)else
              if null cdr x then car x else 'max. x;
         y:=if null y then 'infinity else
              if null cdr y then car y else 'min.y;
         linineqrecord!*:=append(linineqrecord!*,{{x,y}})>>;
      if not linineq2(prob4,msg) then return nil;
      nprob:=append(prob3,
         for each x in prob1 join
           for each y in prob2 collect
             car y.cdr x);
      if vars then
       << if null(sol:=linineq1(nprob,vars,msg,dir,rec))then return nil>>
        else if not linineq2(nprob,msg)then return nil;
         % lower bound:
      x:=if null prob1 then nil else
         linineqevalmax for each p in prob1 collect
                subsq(cdr p,sol);
         % upper bound:
      y:=if null prob2 then nil else
         linineqevalmin for each p in prob2 collect
                subsq(car p,sol);
      if (z:=assoc(v,dir))then z:= cdr z;
      if msg then
      <>;
     linineqinterval!*:=x.y;
     if z='min and null x or z='max and null y then
      <>;
      if not(x=y)then
        if z='min then y:=nil else if z='max then x:=nil;
      if msg then
      << writepri(
        if null x and null y then " completely free: " else
        if null y then " minimum: " else
        if null x then " maximum: " else
        if x=y then " zero length interval: " else " middle: ",nil)>>;
      if null x and null y then x:=0 else % completely free
      if null x then x:=prepsq y else
      if null y then x:=prepsq x else
      if sqlessp(y,x)then
        <>;
      if sqlessp(lh,rh)then
        <= ",nil);
                        writepri(mkquote prepsq rh,'last)>>;
          return nil>>;
      prob:=cdr prob;
      goto loop end;

symbolic procedure linineqnormalize prob;
    % Normalize system: reform all inequalities such that they have
    % the canonical form %     polynomial >= constant
    %      (canonical restriction: absolute term of lhs=0,
    %                              denominator of lhs = 1).
    % and remove those, which have same lhs, but smaller rhs
    % (the latter are superfluous).
   begin scalar r,lh,rh,d,ab,x;
     for each p in prob do
     <>;
       ab:=negf ab;
       lh:=multsq(addf(lh,ab)./1,1 ./ x);
       rh:=multsq(ab ./ 1, 1 ./ x);
         % removal of redundant elements
       x:=assoc(lh,r);
       if null x then r:=(lh.rh).r else
         if sqlessp(cdr x,rh)then rplacd(x,rh)>>;
     if !*trlinineq then
         linineqprint2("normalized and reduced:",r);
     return r end;

symbolic procedure linineqevalmin u;
   % Compute the minimum among the list u with sq's.
     linineqevalmin1(car u,cdr u);

symbolic procedure linineqevalmin1(q,u);
   if null u then q else
  (linineqevalmin1( if x and !:minusp x then q else car u, cdr u)
       )where x=numr addsq(q,negsq car u);

symbolic procedure linineqevalmax u;
   % compute the maximum among the list u with sq's
     linineqevalmax1(car u,cdr u);

symbolic procedure linineqevalmax1(q,u);
   if null u then q else
  (linineqevalmax1(
     if x and !:minusp x then car u else q, cdr u)
        )where x=numr addsq(q,negsq car u);

symbolic procedure sqlessp(q1,q2);
   (x and !:minusp x)where x=numr addsq(q1,negsq q2);

symbolic procedure liqsimp!-maxmin w;
   liqsimp2!-maxmin liqsimp1!-maxmin w;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/rsolve.tst0000644000175000017500000000516511526203062023711 0ustar  giovannigiovanni% Test file for i_solve and r_solve operators.
% Author: F.J.Wright@Maths.QMW.ac.uk
% Version 1.051, 16 Jan 1995

i_solve((x - 10)*(x + 20)*(x - 30)*(x + 40)*(x - 50));
% {x=-20,x=-40,x=50,x=30,x=10}

i_solve(x^4 - 1, x);
% {x=1,x=-1}

i_solve(x^4 + 1);
% {}

r_solve((x^2 - 1)*(x^2 - 9));
% {x=1,x=-3,x=3,x=-1}

r_solve(9x^2 - 1);
%     1      - 1
% {x=---,x=------}
%     3      3

r_solve(9x^2 - 4, x);
%      - 2     2
% {x=------,x=---}
%      3       3

r_solve(9x^2 + 16, x);
% {}

r_solve((9x^2 - 16)*(x^2 - 9), x);
%      - 4              4
% {x=------,x=3,x=-3,x=---}
%      3                3

% First two examples from Loos' paper:
% ===================================
r_solve(6x^4 - 11x^3 - x^2 - 4);
%      - 2
% {x=------,x=2}
%      3

r_solve(2x^3 + 12x^2 + 13x + 15);
% {x=-5}

% Remaining four CORRECTED examples from Loos' paper:
% ==================================================
r_solve(2x^4 - 4x^3 + 3x^2 - 5x - 2);
% {x=2}

r_solve(6x^5 + 11x^4 - x^3 + 5x - 6);
%      - 3     2
% {x=------,x=---}
%      2       3

r_solve(x^5 - 5x^4 + 2x^3 - 25x^2 + 21x + 270);
% {x=3,x=5,x=-2}

r_solve(2x^6 + x^5 - 9x^4 - 6x^3 - 5x^2 - 7x + 6);
%     1
% {x=---,x=-2}
%     2

% Degenerate equations:
% ====================
i_solve 0;
% {}

i_solve(0, x);
% {x=arbint(1)}

r_solve(a = a, x);
% {x=arbrat(2)}

r_solve(x^2 - 1, y);
% {}

% Test of options and multiplicity:
% ================================
i_solve(x^4 - 1, x, noeqs);
% {1,-1}

i_solve((x^4 - 1)^3, x);
% {x=1,x=-1}
root_multiplicities;
% {3,3}

on multiplicities;
i_solve((x^4 - 1)^3, x);
% {x=1,x=1,x=1,x=-1,x=-1,x=-1}
root_multiplicities;
% {}

i_solve((x^4 - 1)^3, x, separate);
% {x=1,x=-1}
root_multiplicities;
% {3,3}
off multiplicities;

i_solve((x^4 - 1)^3, x, multiplicities);
% {x=1,x=1,x=1,x=-1,x=-1,x=-1}
root_multiplicities;
% {}

i_solve((x^4 - 1)^3, x, expand, noeqs);
% {1,1,1,-1,-1,-1}
root_multiplicities;
% {}

i_solve((x^4 - 1)^3, x, together);
% {{x=1,3},{x=-1,3}}
root_multiplicities;
% {}

i_solve((x^4 - 1)^3, x, together, noeqs);
% {{1,3},{-1,3}}
root_multiplicities;
% {}

i_solve((x^4 - 1)^3, x, nomul);
% {x=-1,x=1}
root_multiplicities;
% {}

% Test of error handling:
% ======================
on errcont;
r_solve();
% ***** r/i_solve called with no equations 

r_solve(x^2 - a, x);
%               2
% *****  - a + x  invalid as univariate polynomial over Z

r_solve(x^2 - 1, x, foo);
% ***** foo invalid as optional r/i_solve argument

r_solve({x^2 - 1}, x);
%         2
% ***** {x  - 1} invalid as univariate polynomial over Z

on complex;
i_solve((x-1)*(x-i), x);
%                     2
% *****  - i*x + i + x  - x invalid as univariate polynomial over Z

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solve1.red0000644000175000017500000011134111526203062023542 0ustar  giovannigiovannimodule solve1; % Fundamental SOLVE procedures.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*allbranch !*arbvars !*exp !*ezgcd !*fullroots !*limitedfactors
        !*multiplicities !*notseparate !*numval !*numval!* !*precise
        !*rounded !*solvealgp !*solvesingular !*varopt !!gcd !:prec!:
        asymplis!* alglist!* dmode!* kord!* vars!*
        !*!*norootvarrenamep!*!*);

% NB: !*!*norootvarrenamep!*!* is internal to this module, and should
%     *never* be changed by a user.

global '(!!arbint multiplicities!* assumptions requirements);

switch allbranch,arbvars,fullroots,multiplicities,solvesingular;
       % nonlnr.

% !*varopt := t;   % Set now in alg/intro.

put('fullroots,'simpfg,'((t (rmsubs))));

flag('(!*allbranch multiplicities!* assumptions requirements),
     'share);

% Those switches that are on are now set in entry.red.

% !*allbranch     := t; % Returns all branches of solutions if T.
% !*arbvars       := t; % Presents solutions to singular systems
                      % in terms of original variables if NIL
% !*multiplicities      Lists all roots with multiplicities if on.
% !*fullroots   := t; % Computes full roots of cubics and quartics.
% !*solvesingular := t; % Default value.
%  !!gcd                SOLVECOEFF returns GCD of powers of its arg in
%                       this.  With the decompose code, this should
%                       only occur with expressions of form x^n + c.

Comment most of these procedures return a list of "solve solutions".  A
   solve solution is a list with three fields: the list of solutions,
   the corresponding variables (or NIL if the equations could not be
   solved --- in which case there is only one solution in the first
   field) and the multiplicity;

symbolic procedure solve0(elst,xlst);
   % This is the driving function for the solve package.
   % Elst is any prefix expression, including a list prefixed by LIST.
   % Xlst is a kernel or list of kernels.  Solves eqns in elst for
   % vars in xlst, returning either a list of solutions, a single
   % solution, or NIL if the solutions are inconsistent.
   begin scalar !*exp,!*notseparate,w;  integer neqn;
   % NOTSEPARATE used be set on.  However, this led to wrong results in
   % solve(({ex*z+y*b1-x*b2,-z*b1+ex*y+x*b3,z*b2-y*b3+ex*x}
   %        where ex=sqrt(-b1**2-b2**2-b3**2)),{x,y,z});
   !*exp := t; % !*notseparate := t;
   % Form a list of equations as expressions.
   elst := for each j in solveargchk elst collect simp!* !*eqn2a j;
   neqn := length elst;   % There must be at least one.
   % Determine variables.
   if null xlst
     then <>
             else <>;
            terpri!* nil>>
    else <>;
   if length vars!* = 0
     then rerror(solve,3,"SOLVE called with no variables");
   if neqn = 1 and length vars!* = 1
      then if null numr car elst
              then return if !*solvesingular
                          then {{{!*f2q makearbcomplex()},vars!*,1}}
                          else nil
              else if solutionp(w := solvesq(car elst,car vars!*,1))
                      or null !*solvealgp
                      or univariatep numr car elst
                      then return w;
   % More than one equation or variable, or single eqn has no solution.
    elst := for each j in elst collect numr j;
    w := solvesys(elst,vars!*);
    if null w then return nil;
    if car w memq {'t,'inconsistent,'singular} then return cdr w
     else if car w eq 'failed or null car w
      then return for each j in elst collect list(list(j ./ 1),nil,1)
     else errach list("Improper solve solution tag",car w)
   end;

symbolic procedure basic!-kern u;
   <> where w=nil;

symbolic procedure basic!-kern1 u;
   % Expand a composite kernel.
   begin scalar w;
      if atom u then return {u} else
       if algebraic!-function car u and
        (w := allbkern for each q in cdr u collect simp q)
        then return w
       else return {u}
   end;

symbolic procedure algebraic!-function q;
 % Returns T if q is a name of an operator with algebraic evaluation
 % properties.
   flagp(q,'realvalued) or
      flagp(q,'alwaysrealvalued) or
      get(q,'!:rd!:) or
      get(q,'!:cr!:) or
      get(q,'opmtch);

symbolic procedure allbkern elst;
 % extract all elementary kernels from list of quotients.
  if null elst then nil else
   union(basic!-kern kernels numr car elst, allbkern cdr elst);

symbolic procedure solvevars elst;
 <> where s=nil;

symbolic procedure solutionp u;
   null u or cadar u and not root_of_soln_p caar u and solutionp cdr u;

symbolic procedure root_of_soln_p u;
   null cdr u and kernp (u := car u) and eqcar(mvar numr u,'root_of);

symbolic procedure solveargchk u;
   if getrtype (u := reval u) eq 'list then cdr reval u
    else if atom u or not(car u eq 'lst) then list u
    else cdr u;


% ***** Procedures for collecting side information about the solution.

symbolic procedure solve!-clean!-info(fl,flg);
   % Check for constants and multiples in side relations fl.
   % If flg is t then relations are factorised and constants removed.
   % Otherwise the relations are autoreduced and the presence of a
   % constant truncates the whole list.
  begin scalar r,w,p;
     for each form in cdr fl do if not p then
        if constant_exprp(form := reval form) then
          (if not flg then p := r := {1})
        else
          if flg then
            for each w in cdr fctrf numr simp form do
             <>
          else
             <>;
     return 'list . for each q in r collect prepf q
  end;


% ***** Procedures for solving a single eqn *****

symbolic procedure solvesq (ex,var,mul);
   % We assume that if a solution is a "root_of", then the denominator
   % will not reduce to zero when this root is substituted in.  Without
   % this test, the subf calculation can be very, very long.
   begin scalar r,x;
      r:= for each w in solvesq1(ex,var,mul) join
        if null cadr w
           or eqcar(x := prepsq caar w,'root_of)
           or numr subfx(denr ex,{caadr w . x}) then {w};
      if r and not domainp denr ex then
           assumptions:=append(assumptions,{prepf denr ex});
      return r
  end;

symbolic procedure subfx(u,v);
   (if errorp x then nil ./ 1 else car x)
      where x = errorset2 {'subf,mkquote u,mkquote v};

symbolic procedure solvesq1 (ex,var,mul);
   % Attempts to find solutions for standard quotient ex with respect to
   % top level occurrences of var and kernels containing variable var.
   % Solutions containing more than one such kernel are returned
   % unsolved, and solve1 is applied to the other solutions.  Integer
   % mul is the multiplicity passed from any previous factorizations.
   % Returns a list of triplets consisting of solutions, variables and
   % multiplicity.
     begin scalar e1,oldkorder,x1,y,z;  integer mu;
      ex := numr ex;
      if null(x1 := topkern(ex,var)) then return nil;
      oldkorder := setkorder list var;
      % The following section should be extended for other cases.
      e1 := reorder ex;
      setkorder oldkorder;
      if !*modular then
      <>;
      if mvar e1 = var and null cdr x1 and ldeg e1 =1
        then return {{{quotsq(negf reorder red e1 ./1,
                              reorder lc e1 ./ 1)},
                     {var},mul}};
     % don't call fctrf here in rounded mode, so polynomial won't get
     % rounded (since factoring isn't going to succeed)
      ex := if !*rounded then {1,ex . 1} else fctrf ex;
      % Now process monomial.
      if domainp car ex then ex := cdr ex
       else ex := (car ex . 1) . cdr ex;
      for each j in ex do
        <1
             and (y := solvedecomp(reverse y,car x1,mu))
            then z := solnsmerge(y,z)
           else if (degr(y := reorder e1,var) where kord!*={var}) = 1
              and not smember(var,delete(var,x1))
                  % var may not be unique here.
            then <>
           else if x1
            then z := solnsmerge(
             if null cdr x1 then solve1(e1,car x1,var,mu)
              else if (y := principle!-of!-powers!-soln(e1,x1,var,mu))
                          neq 'unsolved
               then y
              else if not smemq('sol,x1 := solve!-apply!-rules(e1,var))
               then solvesq(x1,var,mu)
              else mkrootsof(e1 ./ 1,var,mu),
                 z)>>;
      return z
   end;

symbolic procedure solvedecomp(u,var,mu);
   % Solve for decomposed expression.  At the moment, only one
   % level of decomposition is considered.
   begin scalar failed,x,y;
      if length(x := solve0(car u,cadadr u))=1 then return nil;
      u := cdr u;
      while u do
       <>
             else x := solnsmerge(
                        solve0(list('difference,prepsq caar j,caddar u),
                               if cdr u then cadadr u else var),x);
         if failed then u := nil else u := cdr u>>;
      return if failed then nil else adjustmul(x,mu)
   end;

symbolic procedure adjustmul(u,n);
   % Multiply the multiplicities of the solutions in u by n.
   if n=1 then u
    else for each x in u collect list(car x,cadr x,n*caddr x);

symbolic procedure solve1(e1,x1,var,mu);
   Comment e1 is a standard form, non-trivial in the kernel x1, which
      is itself a function of var, mu is an integer.  Uses roots of
      unity, known solutions, inverses, together with quadratic, cubic
      and quartic formulas, treating other cases as unsolvable.
      Returns a list of solve solutions;
   begin scalar !*numval!*;
      !*numval!* := !*numval;    % Keep value for use in solve11.
      return solve11(e1,x1,var,mu)
   end;

symbolic procedure solve11(e1,x1,var,mu);
   begin scalar !*numval,b,coefs,hipow,w;  integer n;
      % The next test should check for true degree in var.
      if null !*fullroots and null !*rounded and numrdeg(e1,var)>2
        then return mkrootsof(e1 ./ 1,var,mu);
      !*numval := t;   % Assume that actual numerical values wanted.
      coefs:= errorset!*(list('solvecoeff,mkquote e1,mkquote x1),nil);
      if atom coefs or atom x1 and x1 neq var
        then return mkrootsof(e1 ./ 1,var,mu);
          % solvecoeff problem - no soln.
      coefs := car coefs;
      n:= !!gcd;   % numerical gcd of powers.
      hipow := car(w:=car reverse coefs);
      if not domainp numr cdr w then
        assumptions:=append(assumptions,{prepf numr cdr w});
      if not domainp denr cdr w then
        assumptions:=append(assumptions,{prepf denr cdr w});
      if hipow = 1
        then return begin scalar lincoeff,y,z;
           if null cdr coefs then b := 0
            else b := prepsq quotsq(negsq cdar coefs,cdadr coefs);
           if n neq 1 then b := list('expt,b,list('quotient,1,n));
           % We may need to merge more solutions in the following if
           % there are repeated roots.
           for k := 0:n-1 do   % equation in power of var.
            <>;
         return y
        end
       else if hipow=2
        then return <>
       else return solvehipow(e1,x1,var,mu,coefs,hipow)
 end;

symbolic procedure solnsmerge(u,v);
   if null u then v
    else solnsmerge(cdr u,solnmerge(caar u,cadar u,caddar u,v));

symbolic procedure getcoeff(u,n);
   % Get the nth coefficient in the list u as a standard quotient.
   if null u then nil ./ 1
    else if n=caar u then cdar u
    else if n>
              else <>;
                     for each j in solvesq(c,'!!x,mu) do z :=
                      solnsmerge(
                      solvesq(addsq(1 ./ 1,multsq(d,subtrsq(d,caar j))),
                                var,caddr j),z);
                     z>>
       else if solve1test2(coefs,rcoeffs,f)
          % coefficients antisymmetric
        then <>;
               solnsmerge(solvesq(e1,var,mu),b)>>
          % equation has no symmetry
          % now look for real roots before cubics or quartics.  We must
          % reverse the answer from solveroots so that roots come out
          % in same order from SOLVE.
%      else if !*numval!* and dmode!* memq '(!:rd!: !:cr!:)
      % this forces solveroots independent of numval.
       else if !*rounded and univariatep e1
        then reversip solveroots(e1,var,mu)
       else if null !*fullroots then mkrootsof(e1 ./ 1,var,mu)
       else if hipow=3
        then <>
       else if hipow=4
        then <>
       else mkrootsof(e1 ./ 1,var,mu)
          % We can't solve quintic and higher.
   end;

symbolic procedure solnmerge(u,varlist,mu,y);
   % Merge solutions in case of multiplicities. It may be that this is
   % only needed for the trivial solution x=0.
   if null y then list list(u,varlist,mu)
    else if u = caar y and varlist = cadar y
           then list(caar y,cadar y,mu+caddar y) . cdr y
    else car y . solnmerge(u,varlist,mu,cdr y);

symbolic procedure nilchk u; if null u then !*f2q u else u;

symbolic procedure solve1test1(coefs,rcoeffs,f);
   % True if equation is symmetric in its coefficients. f is midpoint.
   begin integer j,p;
      if null coefs or caar coefs neq 0 or null !*fullroots
        then return nil;
      p := caar coefs + caar rcoeffs;
   a: if j>f then return t
       else if (caar coefs + caar rcoeffs) neq p
               or cdar coefs neq cdar rcoeffs then return nil;
      coefs := cdr coefs;
      rcoeffs := cdr rcoeffs;
      j := j+1;
      go to a
   end;

symbolic procedure solve1test2(coefs,rcoeffs,f);
   % True if equation is antisymmetric in its coefficients. f is
   %  midpoint.
   begin integer j,p;
      if null coefs or caar coefs neq 0 or null !*fullroots
        then return nil;
      p := caar coefs + caar rcoeffs;
   a: if j>f then return t
       else if (caar coefs + caar rcoeffs) neq p
          or numr addsq(cdar coefs,cdar rcoeffs) then return nil;
      coefs := cdr coefs;
      rcoeffs := cdr rcoeffs;
      j := j+1;
      go to a
   end;

symbolic procedure solveabs u;
   begin scalar mu,var,lincoeff;
      var := cadr u;
      mu := caddr u;
      lincoeff := cadddr u;
      u := simp!* caar u;
      return solnsmerge(solvesq(addsq(u,lincoeff),var,mu),
                    solvesq(subtrsq(u,lincoeff),var,mu))
   end;

put('abs,'solvefn,'solveabs);

symbolic procedure solveexpt u;
   begin scalar c,mu,var,lincoeff;
      var := cadr u;
      mu := caddr u;
      lincoeff := cadddr u;
%       the following line made solve(x^(1/2)=0) etc. wrong
%      if null numr lincoeff then return nil;
      u := car u;
      return if freeof(car u,var)    % c**(...) = b.
    then if null numr lincoeff then nil else
        <>
                else c:=0;
                solvesq(subtrsq(simp!* cadr u,
                     quotsq(addsq(solveexpt!-logterm lincoeff,
                                  simp!* c),
                        simp!* list('log,car u))),var,mu)>>
       else if freeof(cadr u,var) and null numr lincoeff  %(...)**b=0.
        then if check!-condition {'equal,{'sign,cadr u},1}
                 then solvesq(simp!* car u,var,mu)
                else solveexpt!-rootsof(u,lincoeff,var,mu)
       else if freeof(cadr u,var)   %  (...)**(m/n) = b;
        then if ratnump cadr u
           then solve!-fractional!-power(u,lincoeff,var,mu)
          else <<   %  (...)**c = b.
                 if !*allbranch
                   then <>
%                         c := mkexp list('times,
%                                         list('arbreal,!!arbint))>>
                  else c:=1;
                 solvesq(subtrsq(simp!* car u,
                multsq(simp!* list('expt,
                           mk!*sq lincoeff,
                           mk!*sq invsq
                              simp!* cadr u),
                       simp!* c)),var,mu)>>
        %  (...)**(...) = b : transcendental.
%   else list list(list subtrsq(simp!*('expt . u),lincoeff),nil,mu)
    else solveexpt!-rootsof(u,lincoeff,var,mu)
   end;

symbolic procedure solveexpt!-rootsof(u,lincoeff,var,mu);
    mkrootsof(subtrsq(simp!*('expt . u),lincoeff),var,mu);

put('expt,'solvefn,'solveexpt);

symbolic procedure solveexpt!-logterm lincoeff;
  % compute log(lincoeff), ignoring multiplicity and converting
  % log(-a) to log(a) + i pi.
   simp!* list('log,mk!*sq lincoeff);
%  if not !*allbranch or not minusf numr lincoeff
%     then simp!* list('log,mk!*sq lincoeff)
%  else
%   addsq(simp!*'(times i pi),
%         simp!* {'log,mk!*sq(negf numr lincoeff ./ denr lincoeff)});

symbolic procedure solvelog u;
   solvesq(subtrsq(simp!* caar u,simp!* list('expt,'e,mk!*sq cadddr u)),
          cadr u,caddr u);

put('log,'solvefn,'solvelog);

symbolic procedure solveinvpat(u,op);
   begin scalar c,f;
      f:=get(op,'solveinvpat);
      if smemq('arbint,f) then f:=subst(
         if !*allbranch then list('arbint,!!arbint:=!!arbint+1) else 0,
          'arbint,f);
      if not !*allbranch then f:={car f};
      return
       for each c in reverse f join
         solvesq(simp!*
                    subst(caar u,'(~v),subst(mk!*sq cadddr u,'(~r),c)),
                 cadr u,caddr u)
   end;


put('cos,'solveinvpat,
{ quote (- ~v + acos(~r) + 2*arbint*pi),
  quote (- ~v - acos(~r) + 2*arbint*pi) });

put('cos,'solvefn, '(lambda(u) (solveinvpat u 'cos)));

put('sin,'solveinvpat,
{ quote (- ~v + asin(~r) + 2*arbint*pi),
  quote (- ~v - asin(~r) + 2*arbint*pi + pi) });

put('sin,'solvefn, '(lambda(u) (solveinvpat u 'sin)));

put('sec,'solveinvpat,
{ quote (- ~v + asec(~r) + 2*arbint*pi),
  quote (- ~v - asec(~r) + 2*arbint*pi) });

put('sec,'solvefn, '(lambda(u) (solveinvpat u 'sec)));

put('csc,'solveinvpat,
{ quote (- ~v + acsc(~r) + 2*arbint*pi),
  quote (- ~v - acsc(~r) + 2*arbint*pi + pi) });

put('csc,'solvefn, '(lambda(u) (solveinvpat u 'csc)));

put('tan,'solveinvpat, { quote (- ~v + atan(~r) + arbint*pi)});

put('tan,'solvefn, '(lambda(u) (solveinvpat u 'tan)));

put('cot,'solveinvpat, { quote (- ~v + acot(~r) + arbint*pi)});

put('cot,'solvefn, '(lambda(u) (solveinvpat u 'cot)));

put('cosh,'solveinvpat,
{ quote (- ~v + acosh(~r) + 2*arbint*i*pi),
  quote (- ~v - acosh(~r) + 2*arbint*i*pi) });

put('cosh,'solvefn, '(lambda(u) (solveinvpat u 'cosh)));

put('sinh,'solveinvpat,
{ quote (- ~v + asinh(~r) + 2*arbint*i*pi),
  quote (- ~v - asinh(~r) + 2*arbint*i*pi + i*pi) });

put('sinh,'solvefn, '(lambda(u) (solveinvpat u 'sinh)));

put('sech,'solveinvpat,
{ quote (- ~v + asech(~r) + 2*arbint*i*pi),
  quote (- ~v - asech(~r) + 2*arbint*i*pi) });

put('sech,'solvefn, '(lambda(u) (solveinvpat u 'sech)));

put('csch,'solveinvpat,
{ quote (- ~v + acsch(~r) + 2*arbint*i*pi),
  quote (- ~v - acsch(~r) + 2*arbint*i*pi + i*pi) });

put('csch,'solvefn, '(lambda(u) (solveinvpat u 'csch)));

put('tanh,'solveinvpat, { quote (- ~v + atanh(~r) + arbint*i*pi)});

put('tanh,'solvefn, '(lambda(u) (solveinvpat u 'tanh)));

put('coth,'solveinvpat, { quote (- ~v + acoth(~r) + arbint*i*pi)});

put('coth,'solvefn, '(lambda(u) (solveinvpat u 'coth)));

symbolic procedure mkexp u;
   reval(aeval!*({'plus,{'cos,x},{'times,'i,{'sin,x}}}
            where x = reval u)
          where !*rounded = nil,dmode!* = nil);

symbolic procedure solvecoeff(ex,var);
   % Ex is a standard form and var a kernel.  Returns a list of
   % dotted pairs of exponents and coefficients (as standard quotients)
   % of var in ex, lowest power first, with exponents divided by their
   % gcd. This gcd is stored in !!GCD.
   begin scalar clist,oldkord;
      oldkord := updkorder var;
      clist := reorder ex;
      setkorder oldkord;
      clist := coeflis clist;
      !!gcd := caar clist;
      for each x in cdr clist do !!gcd := gcdn(car x,!!gcd);
      for each x in clist
         do <>;
      return clist
   end;

symbolic procedure solveroots(ex,var,mu);
   % Ex is a square and content free univariate standard form, var the
   % relevant variable and mu the root multiplicity.  Finds insoluble,
   % complex roots of EX, returning a list of solve solutions.
   begin scalar x,y;
      x := reval list('root_val,mk!*sq(ex ./ 1));
      if not(car x eq 'list)
        then errach list("incorrect root format",ex);
      for each z in cdr x do
         y := solnsmerge(
                 solvesq(if not(car z eq 'equal)
                           then errach list("incorrect root format",ex)
                          else simpplus {cadr z,{'minus,caddr z}},
                         var,mu),
                         y);
      return y
   end;


% ***** Procedures for solving a system of eqns *****

Comment. The routines for solving systems of equations return a "tagged
solution list", where

        tagged solution list ::= tag . list of solve solution
        tag ::= t | nil | 'inconsistent | 'singular | 'failed
        solve solution ::= {solution rhs,solution lhs,multiplicity} |
                           {solution rhs,nil,multiplicity}
        solution rhs ::= list of sq
        solution lhs ::= list of kernel
        multiplicity ::= posint

If the tag is anything but t, the list of solve solutions is empty. See
solvenonlnrsys for more about the tags;

symbolic procedure solvesys(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvesys: tagged solution list
   % The expressions in exlis are reordered wrt the kernels in varlis,
   % and solved. For some switch settings, the internal
   % solve procedure may produce an error, leaving the kernel order
   % disturbed, so an errorset is used here.
   begin scalar oldkord,oldvars;
        % The standard methods for linear and polynomial system
        % don't work for non-prime modulus.
      if !*modular then
        <>;
      oldvars := vars!*; % Protect this from change in sub-problems.
      oldkord := setkorder varlis;
      exlis := for each j in exlis collect reorder j;
      exlis := errorset!*({'solvemixedsys,mkquote exlis,mkquote varlis},
     t);
      setkorder oldkord;
      vars!* := oldvars;
      if errorp exlis then error1();
      return car exlis;
   end;

symbolic procedure solvemixedsys(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvemixedsys: tagged solution list
   % Solve a mixed linear/nonlinear system, solving the linear
   % part and substituting into the nonlinear until a core nonlinear
   % system remains. Assumes solvenonlnrsys and solvelnrsys both handle
   % all trivial cases properly.
   if null cadr(exlis := siftnonlnr(exlis,varlis)) then % linear
      solvelnrsys(car exlis,varlis)
   else if null car exlis then                          % nonlinear
      solvenonlnrsys(cadr exlis,varlis)
   else                                                 % mixed
      begin scalar x,y,z;
      x := solvelnrsys(car exlis,varlis) where !*arbvars = nil;
      if car x = 'inconsistent then return x
      else x := cadr x;
      z := pair(cadr x,foreach ex in car x collect mk!*sq ex);
      % David Hartley wanted the "resimp" in the next command, but
      % couldn't remember why ...
      exlis := foreach ex in cadr exlis join
                  if ex := numr subs2 resimp subf(ex,z) then {ex};
      varlis := setdiff(varlis,cadr x); % remaining free variables
      y := solvemixedsys(exlis,varlis);
      if car y memq {'inconsistent,'singular,'failed,nil} then return y
      else return t . foreach s in cdr y collect
            <>;
      end;

symbolic procedure siftnonlnr(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> siftnonlnr: {list of sf, list of sf}
   % separate exlis into {linear,nonlinear}
   begin scalar lin,nonlin;
   foreach ex in exlis do
      if ex then
               if nonlnr(ex,varlis) then nonlin := ex . nonlin
               else lin := ex . lin;
   return {reversip lin,reversip nonlin};
   end;

symbolic procedure nonlnrsys(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> nonlnrsys: bool
   if null exlis then nil
   else nonlnr(car exlis,varlis) or nonlnrsys(cdr exlis,varlis);


symbolic procedure nonlnr(ex,varlis);
   % ex: sf, varlis: list of kernel -> nonlnr: bool
   if domainp ex then nil
   else if mvar ex member varlis then
        ldeg ex>1 or not freeofl(lc ex,varlis) or
        nonlnr(red ex,varlis)
   else not freeofl(mvar ex,varlis) or
        nonlnr(lc ex,varlis) or
        nonlnr(red ex,varlis);


% ***** Support for one_of and root_of *****.

symbolic procedure mkrootsoftag();
   begin scalar name; integer n;
 loop: n:=n #+1;
    name := intern compress append('(t a g _),explode n);
    if flagp(name,'used!*) then go to loop;
    return reval name;
  end;

symbolic procedure mkrootsof(e1,var,mu);
   begin scalar x,name;
      x := if idp var then var else 'q_;
      name := !*!*norootvarrenamep!*!* or mkrootsoftag();
      if not !*!*norootvarrenamep!*!*
        then while smember(x,e1) do
             x := intern compress append(explode x,explode '!_);
      e1 := prepsq!* e1;
      if x neq var then e1 := subst(x,var,e1);
      return list list(list !*kk2q list('root_of,e1,x,name),list var,mu)
   end;

put('root_of,'psopfn,'root_of_eval);

symbolic procedure root_of_eval u;
   begin scalar !*!*norootvarrenamep!*!*,x,n;
      if null cdr u then rederr "Too few arguments to root_eval";
      n := if cddr u then caddr u else mkrootsoftag();
      !*!*norootvarrenamep!*!* := n;
      x := solveeval1{car u,cadr u};
      if eqcar(x,'list) then x := cdr x else typerr(x,"list");
      x := foreach j in x collect if eqcar(j,'equal) then caddr j
                                   else typerr(j,"equation");
      if null x then rederr "solve confusion in root_of_eval"
       else if null cdr x then return car x
       else return{'one_of, 'list . x,n}
   end;

put('root_of,'subfunc,'subrootof);

symbolic procedure subrootof(l,expn);
   % Sets up a formal SUB expression when necessary.
   begin scalar x,y;
      for each j in cddr expn do
         if (x := assoc(j,l)) then <>;
      expn := sublis(l,car expn)
                 . for each j in cdr expn collect subsublis(l,j);
        %to ensure only opr and individual args are transformed;
      if null y then return expn;
      expn := aconc!*(for each j in reversip!* y
                     collect list('equal,car j,aeval cdr j),expn);
      return if l then subeval expn
              else mk!*sq !*p2q mksp('sub . expn,1)
   end;

symbolic procedure polypeval u;
   % True if car u is a "pure" polynomial in cadr u (i.e., no other
   % kernels contain cadr u).
   begin scalar bool,v;
      v := cadr u;
      u := simpcar u;
      if cdr u neq 1 then return nil else u := kernels car u;
      while u and null bool do
        <>;
      return null bool
   end;

put('polyp,'psopfn,'polypeval);

(algebraic <<

depend(!~p,!~x); % Needed for the simplification of the rule pattern.

let root_of(~p,~x,~tg)^~n =>
       sub(x=root_of(p,x,tg),
           -reduct(p,x)/coeffn(p,x,deg(p,x))) ^ (n-deg(p,x)+1)
               when polyp(p,x) and fixp n and deg(p,x)>=1 and n>=deg(p,x);

nodepend(!~p,!~x);

>>) where dmode!*=nil,!*modular=nil,!*rounded=nil,!*complex=nil;

symbolic procedure expand_cases u;
   begin scalar bool,sl,tags;
      sl:=list nil; tags:=list nil;
      u := reval u;
      if not eqcar(u,'list) then typerr(u,"equation list")
        else u := cdr u;
      if eqcar(car u,'list)
        then <>
       else u := for each j in u collect {j};
      u := for each j in u join expand_case1(j,sl,tags);
      return 'list .
         for each j in u collect if null bool then car j else 'list . j
   end;

symbolic procedure expand_case1(u,sl,tags);
   if null u then nil
    else expand_merge(expand_case2(car u,sl,tags),
                      expand_case1(cdr u,sl,tags));

symbolic procedure expand_merge(u,v);
   if null v then for each j in u collect {j}
    else for each j in u join for each k in v collect j . k;

symbolic procedure expand_case2(u,sl,tags);
   begin scalar tag,v,var;
      var := cadr u; v := caddr u;
      if eqcar(v,'one_of)
        then <>
      % The next section doesn't do anything currently since root_of
      % is wrapped in a !*sq at this point.
       else if eqcar(v,'root_of)
        then <>;
      return {u}
   end;

% Rules for solving inverse trigonometrical functions.

fluid '(solve_invtrig_soln!*);

share solve_invtrig_soln!*;

symbolic procedure check_solve_inv_trig(fn,equ,var);
   begin scalar x,s;
     x := evalletsub2({'(solve_trig_rules),{'simp!*,mkquote {fn,equ}}},
                      nil);
     if errorp x or not ((x := car x) freeof '(asin acos atan))
       then return nil;
     for each sol in cdr solveeval1 {mk!*sq subtrsq(x,simp!* {fn,0}),
                                    var} do
       if is_solution(sol,equ) then s := caddr sol . s;
     if null s then <> % no solution found
      else if null cdr s then s := car s     % one solution
      else s := 'one_of . s;
     solve_invtrig_soln!* := {'difference,var,s};
     return t
   end;

flag('(check_solve_inv_trig),'boolean);

symbolic procedure is_solution(sol,equ);
   begin scalar var,s,rhs,result;
     var := cadr sol;
     rhs := caddr sol;
     equ := numr simp!* equ;
     if eqcar(rhs,'one_of)
       then result := check!-solns(for each s in cdr rhs collect
                                     {{simp!* s},{var},1},
                                   equ,var)
      else if eqcar(rhs,'root_of) then result := t
      else result := check!-solns({{{simp!* rhs},{var},1}},equ,var);
     return if not (result eq 'unsolved) then result else nil
   end;

symbolic procedure check!-condition u;
   null !*precise or eval formbool(u,nil,'algebraic);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/modsr.tex0000644000175000017500000000170611526203062023506 0ustar  giovannigiovanni\documentclass[12pt]{article}

\newcommand{\ttindex}[1]{{\renewcommand{\_}{\protect\underscore}%
                          \index{#1@{\tt #1}}}}

\title{MODSR: Modular solve and roots}

\author{
Herbert Melenk \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Takustra\"se 7 \\
D--14195 Berlin--Dahlem, Germany \\[0.05in]
e--mail: melenk@zib.de
}

\begin{document}
\maketitle

This package supports the SOLVE and ROOTS operators for modular polynomials
and modular polynomial systems.  The moduli need not be primes.  {\tt
M\_SOLVE} requires a modulus to be set.  {\tt M\_ROOTS} takes the
modulus as a second argument. For example:

\begin{verbatim}
on modular; setmod 8;
m_solve(2x=4);            ->  {{X=2},{X=6}}
m_solve({x^2-y^3=3});
    ->  {{X=0,Y=5}, {X=2,Y=1}, {X=4,Y=5}, {X=6,Y=1}}
m_solve({x=2,x^2-y^3=3}); ->  {{X=2,Y=1}}
off modular;
m_roots(x^2-1,8);         ->  {1,3,5,7}
m_roots(x^3-x,7);         ->  {0,1,6}
\end{verbatim}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/ineq.rlg0000644000175000017500000000323111527635055023311 0ustar  giovannigiovanniFri Feb 18 21:27:16 2011 run on win32
% polynomial Inequality (Example where another system returned {1 <= x})

ineq_solve(  (2*x^2+x-1)/(x-1) >=  (x+1/2)^2 ,x);


{x=( - 0.894358 .. 0.326583),x=(1 .. 2.56777)}


ineq_solve({(2*x^2+x-1)/(x-1) >=  (x+1/2)^2, x>0});


{x=(0 .. 0.326583),x=(1 .. 2.56777)}


ineq_solve({(2*x^2+x-1)/(x-1) >=  (x+1/2)^2, x<-1});


{}



% Systems for determining indices of Jacobi polynomials (Winfried Neun).

reg := 
{2*a - 3>=0, 3>=0, 3>=0, 1>=0, 1>=0, 5>=0, 4>=0, 2*a - 4>=0, 2>=0,
 2>=0, 0>=0, 2*a - 2>=0, k + 1>=0, - 2*a + k - 3>=0, - 2*a + k - 2>=0,
  - 2*a + k>=0, k - 7>=0, 2*a - k + 4>=0, 2*a - k + 5>=0, 2*a - k + 3>=0}$



ineq_solve(reg,{k,a});


{a=(2 .. infinity),k=2*a + 3}


reg:=
{a + b - c>=0, a - b + c>=0, - a + b + c>=0, 0>=0, 2>=0,
 2*c - 2>=0, a - b + c>=0, a + b - c>=0, - a + b + c - 2>=0,
 2>=0, 0>=0, 2*b - 2>=0, k + 1>=0, - a - b - c + k>=0,
  - a - b - c + k + 2>=0, - 2*b + k>=0, - 2*c + k>=0, a + b + c - k>=0,
 2*b + 2*c - k - 2>=0, a + b + c - k>=0}$



ineq_solve (reg,{k,a,b,c});


{c=(1 .. infinity),

 b=(1 .. infinity),

 a=(max( - b + c,b - c) .. b + c - 2),

 k=a + b + c}


clear reg;



% Example from Richard Liska.

lvars:={a,b,d}$


lfcond := {d>=0,
           b + d>=0,
           2 a - b + d + 2>=0,
            - a + 2 d + 1>=0,
           b>=0,
           2 a - b>=0,
            - a + 2 d>=0,
           b - d>=0,
           2 a - b - d - 2>=0,
            - a + 2 d - 1>=0}$



ineq_solve(lfcond,lvars);


{d=(2 .. infinity),

 b=(d .. 3*d - 4),

     b + d + 2
 a=(----------- .. 2*d - 1)}
         2


clear lfcond,lvars;



end;


Time for test: 1 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 0 4 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/ppsoln.red0000644000175000017500000001552311526203062023651 0ustar  giovannigiovannimodule ppsoln;  % Solve surd eqns, mainly by principle of powers method.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*complex !*msg !*numval !*ppsoln);

global '(bfone!*);

!*ppsoln := t;   % Keep this as internal switch.

symbolic procedure solve!-fractional!-power(u,x,var,mu);
   % Attempts solution of equation car u**cadr u=x with respect to
   % kernel var and with multiplicity mu, where cadr u is a rational
   % number.
   begin scalar v,w,z;
      v := simp!* car u;
      w := simp!* cadr u;
      z := solvesq(subs2 subtrsq(exptsq(v,numr w),exptsq(x,denr w)),
                   var,mu);
      w := subtrsq(simp('expt . u),x);
      z := check!-solns(z,numr w,var);
%     return if z eq 'unsolved then list list(list w,nil,mu) else z
      return if z eq 'unsolved then mkrootsof(w,var,mu) else z
   end;

symbolic procedure principle!-of!-powers!-soln(ex,x1,var,mu);
   % Finds solutions of ex=0 by the principle of powers method.  Return
   % 'unsolved if solutions can't be found.
   begin scalar z;
   a: if null x1 then return 'unsolved
       else if suitable!-expt car x1
          and not((z := pr!-pow!-soln1(ex,car x1,var,mu)) eq 'unsolved)
         then return z;
      x1 := cdr x1;
      go to a
   end;

symbolic procedure pr!-pow!-soln1(ex,y,var,mu);
   begin scalar oldkord,z;
      oldkord := updkorder y;
      z := reorder ex;
      setkorder oldkord;
      if ldeg z neq 1 then return 'unsolved;
      z := coeflis z;
      if length z neq 2 or caar z neq 0
        then errach list("solve confused",ex,z);
      z := exptsq(quotsq(negsq(cdar z ./ 1),cdadr z ./ 1),
            caddr caddr y);
      z := solvesq(subs2 addsq(simp!* cadr y,negsq z),var,mu);
      z := check!-solns(z,ex,var);
      return z
   end;

symbolic procedure check!-solns(z,ex,var);
   begin scalar x,y;
      % With surds, it's possible to generate 0/0 because of incomplete
      % simplification, hence this check.  However, if !*reduced is set
      % true at a higher point (e.g., in solve0), some examples become
      % more complicated (e.g., solve(2asin(x) + asin(2x) - pi/2,x)).
      if not errorp (x :=
            errorset2 {'check!-solns1,mkquote z,mkquote ex,mkquote var})
        then return car x
       else if ex = (y := (numr simp!* prepf ex where !*reduced=t))
          or errorp (x :=
            errorset2 {'check!-solns1,mkquote z,mkquote y,mkquote var})
        then return 'unsolved
       else return car x
   end;

symbolic procedure check!-solns1(z,ex,var);
   begin scalar x,y,fv,sx,vs;
      fv := freevarl(ex,var);
      for each z1 in z do
        fv := union(fv,union(freevarl(numr caar z1,var),
                             freevarl(denr caar z1,var)));
      fv := delete('i,fv);
      % This does only one random setting!!
      if fv then for each v in fv do
        if not flagp(v,'constant) then
           vs := (v . list('quotient,1+random 999,1000)) . vs;
      sx := if vs then numr subf(ex,vs) else ex;
      while z do
         if null cadar z
           or
            errorp(y := errorset2 {'check!-solns2,mkquote ex,mkquote z})
           then <>
          else z := cdr z;
      return if null x then 'unsolved else x
   end;

symbolic procedure check!-solns2(ex,z);
   % With root_of in z, infinite loops can occur
   % (e.g., on evallhseqp; solve(2sqrt(x^2+1)+log(sqrt(x^2+1)-1)
   %                                -log(sqrt(x^2+1)+1)=a,x)).
   if smemq('root_of,z) then rederr 'check!-solns
    else numr subf(ex,{caadar z . mk!*sq caaar z});

symbolic procedure suitable!-expt u;
   eqcar(u,'expt) and eqcar(caddr u,'quotient) and cadr caddr u = 1
      and fixp caddr caddr u;

symbolic procedure freevarl(ex,var);
 <>
   where l=if var then list var else nil;

symbolic procedure varsift(a,var);
   if atom a then
      if not(null a or numberp a or a eq var) then list a else nil
   else if get(car a,'dname) then nil
   else if car a eq '!*sq then varsift(prepsq cadr a,var)
%  else if car a memq '(arbint arbcomplex) then list a
   else if car a memq '(arbint arbcomplex)
     or (get(car a,'simpfn) eq 'simpiden and not smember(var,a))
    then list a
   else for each c in cdr a join varsift(c,var);

symbolic procedure numvalue u;
   % Find floating point value of sf u.
   begin scalar !*numval,x,c,cp,p,m;
      m := !*msg; !*msg := nil;
      !*numval := t;
      c := ('i memq freevarl(u,nil));
      if (cp := !*complex) then off complex;
      x := setdmode('rounded,t); p := precision 10;
      if x eq '!:rd!: then x := 'rounded;  % <==== to avoid error later
      if c then on complex;
      !*msg := m;
      u := numr simp prepf u;
      !*msg := nil;
      if c then off complex;
      if x then setdmode(x,t) else setdmode('rounded,nil);
      if cp then on complex; precision p;
      !*msg := m;
      return
        if eqcar(u,'!:rd!:) and (numvchk(100,z) where z=round!* u)
        or eqcar(u,'!:cr!:) and (numvchk(10,z) where z=retag crrl u)
           and (numvchk(10,z) where z=retag crim u)
            then nil else u
   end;

symbolic procedure numvchk(fact,z);
   if atom z then fact*abs z<1
   else lessp!:(timbf(bfloat fact,abs!: z),bfone!*);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/rsolve.tex0000644000175000017500000001063311526203062023673 0ustar  giovannigiovanni\documentstyle[11pt]{article}

\title{R/I\_SOLVE: Rational/Integer Polynomial Solvers}

\author{Francis J. Wright \\
School of Mathematical Sciences \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road, London E1 4NS, UK. \\
E-mail: {\tt F.J.Wright@QMW.ac.uk}}

\date{27 January 1995}

\begin{document}
\maketitle

\begin{abstract}
  This package provides the operators \verb|r/i_solve| that compute
  respectively the exact rational or integer zeros of a single
  univariate polynomial using fast modular methods.
\end{abstract}


\section{Introduction}

This package provides operators that compute the exact rational zeros
of a single univariate polynomial using fast modular methods.  The
algorithm used is that described by R. Loos (1983): Computing rational
zeros of integral polynomials by $p$-adic expansion, {\it SIAM J.
Computing}, {\bf 12}, 286--293.  The operator \verb|r_solve| computes
all rational zeros whereas the operator \verb|i_solve| computes only
integer zeros in a way that is slightly more efficient than extracting
them from the rational zeros.  The \verb|r_solve| and \verb|i_solve|
interfaces are almost identical, and are intended to be completely
compatible with that of the general \verb|solve| operator, although
\verb|r_solve| and \verb|i_solve| give more convenient output when
only rational or integer zeros respectively are required.  The current
implementation appears to be faster than \verb|solve| by a factor that
depends on the example, but is typically up to about 2.
  
I plan to extend this package to compute Gaussian integer and rational
zeros and zeros of polynomial systems.


\section{The user interface}

The first argument is required and must simplify to either a
univariate polynomial expression or equation with integer, rational or
rounded coefficients.  Symbolic coefficients are not allowed (and
currently complex coefficients are not allowed either.)  The argument
is simplified to a quotient of integer polynomials and the denominator
is silently ignored.
  
Subsequent arguments are optional.  If the polynomial variable is to
be specified then it must be the first optional argument, and if the
first optional argument is not a valid option (see below) then it is
(mis-)interpreted as the polynomial variable.  However, since the
variable in a non-constant univariate polynomial can be deduced from
the polynomial it is unnecessary to specify it separately, except in
the degenerate case that the first argument simplifies to either 0 or
$0 = 0$.  In this case the result is returned by \verb|i_solve| in
terms of the operator \verb|arbint| and by \verb|r_solve| in terms of
the (new) analogous operator \verb|arbrat|.  The operator
\verb|i_solve| will generally run slightly faster than \verb|r_solve|.
  
The (rational or integer) zeros of the first argument are returned as
a list and the default output format is the same as that used by
\verb|solve|.  Each distinct zero is returned in the form of an
equation with the variable on the left and the multiplicities of the
zeros are assigned to the variable \verb|root_multiplicities| as a
list.  However, if the switch \verb|multiplicities| is turned on then
each zero is explicitly included in the solution list the appropriate
number of times (and \verb|root_multiplicities| has no value).
  
\begin{sloppypar}
Optional keyword arguments acting as local switches allow other output
formats.  They have the following meanings:
\begin{description}
\item[\verb|separate|:] assign the multiplicity list to the global
  variable \verb|root_multiplicities| (the default);
\item[\verb|expand| or \verb|multiplicities|:] expand the solution
  list to include multiple zeros multiple times (the default if the
  \verb|multiplicities| switch is on);
\item[\verb|together|:] return each solution as a list whose second
  element is the multiplicity;
\item[\verb|nomul|:] do not compute multiplicities (thereby saving
  some time);
\item[\verb|noeqs|:] do not return univariate zeros as equations but
  just as values.
\end{description}
\end{sloppypar}


\section{Examples}

\begin{verbatim}
r_solve((9x^2 - 16)*(x^2 - 9), x);
\end{verbatim}
\[
  \left\{x=\frac{-4}{3},x=3,x=-3,x=\frac{4}{3}\right\}
\]
\begin{verbatim}
i_solve((9x^2 - 16)*(x^2 - 9), x);
\end{verbatim}
\[
  \{x=3,x=-3\}
\]
See the test/demonstration file \verb|rsolve.tst| for more examples.


\section{Tracing}

The switch {\tt trsolve} turns on tracing of the algorithm.  It is off
by default.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/modsolve.red0000644000175000017500000001524611526203062024170 0ustar  giovannigiovannimodule modsolve; % Solve modular.

% Author: Herbert Melenk 

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Algebraic interface: m_solve(eqn/eqnlist [,variables]).

% Some routines from solve and factor(modpoly) are needed.

fluid'(!*trnonlnr current!-modulus);

% The limit '10000000' for the current modulus has been calculated
% using a 500 MHz 686 machine which needs 115 seconds for a square root
% computation for that limit.  For faster machines the limit may be set
% a bit higher, for slower machines it should be set lower.

load!-package 'solve;
load!-package 'factor;

put('m_solve,'psopfn,'msolve);

symbolic procedure msolve(u);
  begin scalar s,s1,v,v1,w;
   s:=reval car u;
   s:=if eqcar(s,'list) then cdr s else {s};
   if cdr u then
   <>;
   % test, collect variables.
   s1:=for each q in s collect
   <>;
     % Reject parametric modular equation system.
   for each p in s1 do
     for each x in kernels p do
       if not member(x,v) then fail:=t;
   if fail then
    <>;
   w:=msolve!-psys(s1,v);
 done:
   if w='failed then go to failed;
   w:=for each q in w collect
     {for each r in q collect simp cdr r,
      for each r in q collect car r,1};
   return if tg then t.w else w;
 failed:
   return if null cdr s1 and null cdr v and null tg
            then mkrootsof(car s1 ./1,car v,1)
           else if tg then '(failed)
           else 'failed
 end;

symbolic procedure msolve!-poly1(f,x);
  % polynomial f(x);
 begin scalar w,l;
  if domainp f then nil
   else if ldeg f=1 then
   <current!-modulus)
             then w:=general!-modular!-number w;
     w:={w};
     go to done>>;
 enum:
    l:=lowestdeg(f,x,0);
    if l>0 then f:=quotf(f,numr simp{'expt,x,l});
    f:=general!-reduce!-mod!-p moduntag f;
    w:=for i:=1:current!-modulus -1 join
      if null general!-evaluate!-mod!-p(f,x,i) then {i};
    if l>0 then w:=append(w,{nil});
 done:
    return for each q in w collect{x.prepf q}
 end;

symbolic procedure msolve!-poly(f,l);
  % Solve one polynomial wrt several variables.
  begin scalar x,vl,limit;
   limit:=10000000; %%%%%%%%%%%%%%%%%%%%%%%%%%%% limit
   if current!-modulus>limit then
      <>;
   vl:=kernels f;
   for each x in l do
    <>;
   if null l then return nil;
   return if vl then msolve!-polya(f,l) else msolve!-polyn(f,l)
 end;

symbolic procedure msolve!-polyn(f,l);
(if null cdr l then msolve!-poly1(f,car l) else
 for i:=0:current!-modulus -1 join
  for each s in msolve!-polyn(numr subf(f,{x.i}),cdr l)
   collect (x.i).s) where x=car l;

symbolic procedure msolve!-polya(f,l);
  % 'f' is a polynomial with variables in 'l' and at least one more
  % formal parameter. 'f' can be solved only if 'f' is linear in one of
  % the variables with an invertible coefficient.  Otherwise we must
  % return a root-of expression.
  begin scalar x,c,w;
    for each y in l do if null x then
      if 1=ldeg ((w:=reorder f) where kord!*={y}) then x:=y;
    if null x then go to none;
    c:=lc w; w:=red w;
    if not domainp c then go to none;
    c:=safe!-modrecip c;
    if null c then go to none;
    return{{x.prepf multf(negf w,c)}};
 none: return{{car l.mk!*sq caaar mkrootsof(f./1,car l,1)}}
 end;

symbolic procedure msolve!-psys(s,v);
  % Solve system 's' for variables 'v'. 's' has no additional free
  % parameters.
  begin scalar b,o,z,w;
    if current!-modulus * length s>1000
        and primep current!-modulus then
    <<% Domain is a field and big problem - compute a Groebner base
      % first.
       load!-package 'groebner;load!-package 'groebnr2;
       o:=apply1('torder,{'list.v,'lex});
       b:=groebnereval{'list.for each p in s collect prepf p};
       z:=gzerodimeval{b};
       % The reverse basis for increasing variable number.
       s:=reversip for each p in cdr b collect numr simp p;
       apply1('torder,cdr o)>>
     else
    <<% Rearrange system for increasing variable number.
       w:=for each p in s collect
         length(for each x in v join if smemq(x,p)then{x}).p;
       w:=for each p in sort(w,'lesspcar) collect cdr p>>;
    return msolve!-psys1(s,v)end;

symbolic procedure msolve!-psys1(s,v);
  % Solve system by successive substitution.
  begin scalar w,w1,f,f1;
    w:={nil};
    for each f in s do
    <>;
      w:=w1>>;
    return w
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/modsr.red0000644000175000017500000002242311526203062023457 0ustar  giovannigiovannimodule modsr; % Modular Solve and Roots.

% Author: Herbert Melenk, ZIB Berlin, Jan 95.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(modsr modsqrt modroots modsolve),'(solve));

fluid '(current!-modulus);

% Some routines from solve and factor(modpoly) are needed.

load!-package 'solve;
load!-package 'factor;

% Now a few things that MIGHT have been in the factorizer but were not
% It is quite possible that as a matter of style these few functions
% should be put into factor.red, even though they are not used there,
% since that way they live near their friends and are more generally
% useful???

symbolic procedure general!-evaluate!-mod!-p(a,v,n);
   % Evaluate polynomial A at the point V=N.
    if domainp a then a
    else if n=0 then general!-evaluate!-mod!-p(a,v,nil)
    else if v=nil then errorf "Variable=NIL in GENERAL-EVALUATE-MOD-P"
    else if mvar a=v
     then general!-horner!-rule!-mod!-p(lc a,ldeg a,red a,n,v)
    else adjoin!-term(lpow a,
      general!-evaluate!-mod!-p(lc a,v,n),
      general!-evaluate!-mod!-p(red a,v,n));

symbolic procedure general!-horner!-rule!-mod!-p(v,degg,a,n,var);
   % V is the running total, and it must be multiplied by n**deg and
   % added to the value of a at n.
    if domainp a or not(mvar a=var)
      then if null n or zerop n then a
            else <>
    else begin scalar newdeg;
      newdeg:=ldeg a;
      return general!-horner!-rule!-mod!-p(
          if null n or zerop n then lc a
          else general!-plus!-mod!-p(lc a,
             general!-times!-mod!-p(v,
                general!-expt!-mod!-p(n,idifference(degg,newdeg)))),
       newdeg,red a,n,var)
    end;

symbolic procedure general!-expt!-mod!-p(a,n);
   % a**n.
    if n=0 then 1
    else if n=1 then a
    else begin scalar w,x;
     w:=divide(n,2);
     x:=general!-expt!-mod!-p(a,car w);
     x:=general!-times!-mod!-p(x,x);
     if not (cdr w = 0) then x:=general!-times!-mod!-p(x,a);
     return x
    end;

symbolic procedure general!-monic!-mod!-p a;
   % This procedure can only cope with polys that have a numeric
   % leading coeff.
   if a=nil then nil
   else if domainp a then 1
   else if lc a = 1 then a
   else if not domainp lc a then
       errorf "LC NOT NUMERIC IN GENERAL-MONIC-MOD-P"
   else general!-multiply!-by!-constant!-mod!-p(a,
     general!-modular!-reciprocal lc a);

symbolic procedure general!-quotient!-mod!-p(a,b);
   % Truncated quotient of a by b.
    if null b then errorf "B=0 IN GENERAL-QUOTIENT-MOD-P"
    else if domainp b then general!-multiply!-by!-constant!-mod!-p(a,
                             general!-modular!-reciprocal b)
    else if a=nil then nil
    else if domainp a then exact!-quotient!-flag:=nil
    else if mvar a=mvar b then general!-xquotient!-mod!-p(a,b,mvar b)
    else if ordop(mvar a,mvar b) then
       adjoin!-term(lpow a,
          general!-quotient!-mod!-p(lc a,b),
          general!-quotient!-mod!-p(red a,b))
    else exact!-quotient!-flag:=nil;


symbolic procedure general!-xquotient!-mod!-p(a,b,v);
   % Truncated quotient a/b given that b is nontrivial.
    if a=nil then nil
    else if (domainp a) or (not(mvar a=v)) or
      ilessp(ldeg a,ldeg b) then exact!-quotient!-flag:=nil
    else if ldeg a = ldeg b then begin scalar w;
      w:=general!-quotient!-mod!-p(lc a,lc b);
      if general!-difference!-mod!-p(a,general!-times!-mod!-p(w,b)) then
        exact!-quotient!-flag:=nil;
      return w
      end
    else begin scalar term;
      term:=mksp(mvar a,idifference(ldeg a,ldeg b)) .*
        general!-quotient!-mod!-p(lc a,lc b);
   % That is the leading term of the quotient.  Now subtract term*b from
   % a.
      a:=general!-plus!-mod!-p(red a,
                general!-times!-term!-mod!-p(general!-negate!-term term,
                                             red b));
   % or a:=a-b*term given leading terms must cancel.
      return term .+ general!-xquotient!-mod!-p(a,b,v)
    end;

symbolic procedure general!-negate!-term term;
   % Negate a term.
    tpow term .* general!-minus!-mod!-p tc term;


symbolic procedure general!-remainder!-mod!-p(a,b);
   % Remainder when a is divided by b.
    if null b then errorf "B=0 IN GENERAL-REMAINDER-MOD-P"
    else if domainp b then nil
    else if domainp a then a
    else general!-xremainder!-mod!-p(a,b,mvar b);


symbolic procedure general!-xremainder!-mod!-p(a,b,v);
   % Remainder when the modular polynomial a is divided by b, given that
   % b is non degenerate.
   if (domainp a) or (not(mvar a=v)) or ilessp(ldeg a,ldeg b) then a
   else begin
    scalar q,w;
    q:=general!-quotient!-mod!-p(general!-minus!-mod!-p lc a,lc b);
   % compute -lc of quotient.
    w:=idifference(ldeg a,ldeg b); %ldeg of quotient;
    if w=0 then a:=general!-plus!-mod!-p(red a,
      general!-multiply!-by!-constant!-mod!-p(red b,q))
    else
      a:=general!-plus!-mod!-p(red a,general!-times!-term!-mod!-p(
            mksp(mvar b,w) .* q,red b));
   % The above lines of code use red a and red b because by construc-
   % tion the leading terms of the required % answers will cancel out.
     return general!-xremainder!-mod!-p(a,b,v)
   end;

symbolic procedure general!-multiply!-by!-constant!-mod!-p(a,n);
   % Multiply the polynomial a by the constant n.
   if null a then nil
   else if n=1 then a
   else if domainp a then !*n2f general!-modular!-times(a,n)
   else adjoin!-term(lpow a,
                     general!-multiply!-by!-constant!-mod!-p(lc a,n),
     general!-multiply!-by!-constant!-mod!-p(red a,n));

symbolic procedure general!-gcd!-mod!-p(a,b);
   % Return the monic gcd of the two modular univariate polynomials a
   % and b.  Set REDUCTION-COUNT to the number of steps taken in the
   % process.
 << reduction!-count := 0;
    if null a then monic!-mod!-p b
    else if null b then monic!-mod!-p a
    else if domainp a then 1
    else if domainp b then 1
    else if igreaterp(ldeg a,ldeg b) then
      general!-ordered!-gcd!-mod!-p(a,b)
    else general!-ordered!-gcd!-mod!-p(b,a) >>;

symbolic procedure general!-ordered!-gcd!-mod!-p(a,b);
   % As above, but deg a > deg b.
  begin scalar steps;
    steps := 0;
top:
    a := general!-reduce!-degree!-mod!-p(a,b);
    if null a then return general!-monic!-mod!-p b;
    steps := steps + 1;
    if domainp a then <<
        reduction!-count := reduction!-count+steps;
        return 1 >>
    else if ldeg a>;

symbolic procedure lowestdeg(f,x,n);
   if null f then n else
   if domainp f or mvar f neq x then 0 else
   lowestdeg(red f,x,ldeg f);

symbolic procedure reduce!-mod!-p!*(f,p);
  (general!-reduce!-mod!-p f) where current!-modulus = p;

symbolic procedure moduntag f;
  if eqcar(f,'!:mod!:) then cdr f else
  if atom f then f else
  moduntag car f . moduntag cdr f;

symbolic procedure safe!-modrecip u;
   % Return 1/u or nil.
   begin scalar q,!*msg,!*protfg;
      !*msg := nil; !*protfg := t;
      if eqcar(u,'!:mod!:) then u := cdr u;
      q := errorset({'general!-modular!-reciprocal, u},nil,nil);
      erfg!* := nil;
      return if errorp q then nil else car q
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/rsolve.txt0000644000175000017500000000243711526203062023715 0ustar  giovannigiovanniRational and integer zeros of a univariate polynomial
using fast modular methods.

Author: F.J.Wright@Maths.QMW.ac.uk
Version 1.05, 2 Oct 1994

The operators r_solve and i_solve take a single univariate polynomial (or
polynomial equation) as argument, and optionally the variable as second
argument, and return respectively the sets of rational and integer zeros.
Any denominator is completely ignored!  See the test/demo file rsolve.tst
for examples.

Default output format is the same as used by solve (including respecting
the multiplicities switch), but optional arguments allow other output
formats (see the source file rsolve.red for details).  Solutions of
degenerate equations are expressed by r_solve and i_solve using the
operators ARBRAT (which is new) and ARBINT respectively.

Computing only the integer zeros is slightly more efficient than extracting
them from the rational zeros.  This algorithm appears to be faster than
solve by a factor that depends on the example, but typically up to about 2,
and gives more convenient output if only integer or rational zeros are
required.

The algorithm used is that described by R. Loos (1983): Computing rational
zeros of integral polynomials by p-adic expansion.  SIAM J. Computing. 12,
286--293.

The switch TRSOLVE turns on tracing of the algorithm.
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solve.tst0000644000175000017500000004772611526203062023540 0ustar  giovannigiovanni% Demonstration of the REDUCE SOLVE package.

on fullroots;   % To get complete solutions.

% Simultaneous linear fractional equations.

solve({(a*x+y)/(z-1)-3,y+b+z,x-y},{x,y,z});


% Use of square-free factorization together with recursive use of
% quadratic and binomial solutions.

solve((x**6-x**3-1)*(x**5-1)**2*x**2);

multiplicities!*;


% A singular equation without and with a consistent inhomogeneous term.

solve(a,x);

solve(0,x);

off solvesingular;

solve(0,x);


% Use of DECOMPOSE to solve high degree polynomials.

solve(x**8-8*x**7+34*x**6-92*x**5+175*x**4-236*x**3+226*x**2-140*x+46);

solve(x**8-88*x**7+2924*x**6-43912*x**5+263431*x**4-218900*x**3+
           65690*x**2-7700*x+234,x);


% Recursive use of inverses, including multiple branches of rational
% fractional powers.

solve(log(acos(asin(x**(2/3)-b)-1))+2,x);


% Square-free factors that are unsolvable, being of fifth degree,
% transcendental, or without a defined inverse.

operator f;

solve((x-1)*(x+1)*(x-2)*(x+2)*(x-3)*(x*log(x)-1)*(f(x)-1),x);

multiplicities!*;


% Factors with more than one distinct top-level kernel, the first factor
% a cubic. (Cubic solution suppressed since it is too messy to be of
% much use).

off fullroots;

solve((x**(1/2)-(x-a)**(1/3))*(acos x-acos(2*x-b))* (2*log x
          -log(x**2+x-c)-4),x);

on fullroots;

% Treatment of multiple-argument exponentials as polynomials.

solve(a**(2*x)-3*a**x+2,x);


% A 12th degree reciprocal polynomial that is irreductible over the
% integers, having a reduced polynomial that is also reciprocal.
% (Reciprocal polynomials are those that have symmetric or antisymmetric
% coefficient patterns.) We also demonstrate suppression of automatic
% integer root extraction.

solve(x**12-4*x**11+12*x**10-28*x**9+45*x**8-68*x**7+69*x**6-68*x**5+
45*x**4-28*x**3+12*x**2-4*x+1);


% The treatment of factors with non-unique inverses by introducing
% unique new real or integer indeterminant kernels.

solve((sin x-a)*(2**x-b)*(x**c-3),x);


% Automatic restriction to principal branches.

off allbranch;

solve((sin x-a)*(2**x-b)*(x**c-3),x);


% Regular system of linear equations.

solve({2*x1+x2+3*x3-9,x1-2*x2+x3+2,3*x1+2*x2+2*x3-7}, {x1,x2,x3});


% Underdetermined system of linear equations.

on solvesingular;

solve({x1-4*x2+2*x3+1,2*x1-3*x2-x3-5*x4+7,3*x1-7*x2+x3-5*x4+8},
      {x1,x2,x3,x4});


% Inconsistent system of linear equations.

solve({2*x1+3*x2-x3-2,7*x1+4*x2+2*x3-8,3*x1-2*x2+4*x3-5},
      {x1,x2,x3});


% Overdetermined system of linear equations.

solve({x1-x2+x3-12,2*x1+3*x2-x3-13,3*x2+4*x3-5,-3*x1+x2+4*x3+20},
      {x1,x2,x3});


% Degenerate system of linear equations.

operator xx,yy;

yy(1) := -a**2*b**3-3*a**2*b**2-3*a**2*b+a**2*(xx(3)-2)-a*b-a*c+a*(xx(2)
         -xx(5))-xx(4)-xx(5)+xx(1)-1;

yy(2) := -a*b**3-b**5+b**4*(-xx(4)-xx(5)+xx(1)-5)-b**3*c+b**3*(xx(2)
         -xx(5)-3)+b**2*(xx(3)-1);

yy(3) := -a*b**3*c-3*a*b**2*c-4*a*b*c+a*b*(-xx(4)-xx(5)+xx(1)-1)
         +a*c*(xx(3)-1)-b**2*c-b*c**2+b*c*(xx(2)-xx(5));

yy(4) := -a**2-a*c+a*(xx(2)-xx(4)-2*xx(5)+xx(1)-1)-b**4-b**3*c-3*b**3
         -3*b**2*c-2*b**2-2*b*c+b*(xx(3)-xx(2)-xx(4)+xx(1)-2)
         +c*(xx(3)-1);

yy(5) := -2*a-3*b**3-9*b**2-11*b-2*c+3*xx(3)+2*xx(2)-xx(4)-3*xx(5)+xx(1)
         -4;

soln  :=  solve({yy(1),yy(2),yy(3),yy(4),yy(5)},
                {xx(1),xx(2),xx(3),xx(4),xx(5)});

for i  :=  1:5 do xx(i) := part(soln,1,i,2);

for i  :=  1:5 do write yy(i);


%  Single equations liftable to polynomial systems.

solve ({a*sin x + b*cos x},{x});

solve ({a*sin(x+1) + b*cos(x+1)},{x});
 
% Intersection of 2 curves: system with a free parameter.

solve ({sqrt(x^2 + y^2)=r,0=sqrt(x)+ y**3-1},{x,y,r});

solve ({e^x - e^(1/2 * x) - 7},{x});

% Generally not liftable.
  
   % variable inside and outside of sin.

   solve({sin x + x - 1/2},{x});
 
   % Variable inside and outside of exponential.

   solve({e^x - x**2},{x});

   % Variable inside trigonometrical functions with different forms.

   solve ({a*sin(x+1) + b*cos(x+2)},{x});
 
   % Undetermined exponents.

   solve({x^a - 2},{x});
 

% Example taken from M.L. Griss, ACM Trans. Math. Softw. 2 (1976) 1.

e1 := x1 - l/(3*k)$

e2 := x2 - 1$

e3 := x3 - 35*b6/(6*l)*x4 + 33*b11/(2*l)*x6 - 715*b15/(14*l)*x8$

e4 := 14*k/(3*l)*x1 - 7*b4/(2*l)*x3 + x4$

e5 := x5 - 891*b11/(40*l)*x6 +3861*b15/(56*l)*x8$

e6 := -88*k/(15*l)*x1 + 22*b4/(5*l)*x3 - 99*b9/(8*l)*x5 +x6$

e7 := -768*k/(5005*b13)*x1 + 576*b4/(5005*b13)*x3 -
      324*b9/(1001*b13)*x5 + x7 - 16*l/(715*b13)*x8$

e8 := 7*l/(143*b15)*x1 + 49*b6/(429*b15)*x4 - 21*b11/(65*b15)*x6 +
      x8 - 7*b2/(143*b15)$

solve({e1,e2,e3,e4,e5,e6,e7,e8},{x1,x2,x3,x4,x5,x6,x7,x8});


f1 := x1 - x*x2 - y*x3 + 1/2*x**2*x4 + x*y*x5 + 1/2*y**2*x6 +
      1/6*x**3*x7 + 1/2*x*y*(x - y)*x8 - 1/6*y**3*x9$

f2 := x1 - y*x3 + 1/2*y**2*x6 - 1/6*y**3*x9$

f3 := x1 + y*x2 - y*x3 + 1/2*y**2*x4 - y**2*x5 + 1/2*y**2*x6 +
      1/6*y**3*x7 + 1/2*y**3*x8 - 1/6*y**3*x9$

f4 := x1 + (1 - x)*x2 - x*x3 + 1/2*(1 - x)**2*x4 - y*(1 - x)*x5 +
      1/2*y**2*x6 + 1/6*(1 - x)**3*x7 + 1/2*y*(1 - x - y)*(1 - x)*x8
      - 1/6*y**3*x9$

f5 := x1 + (1 - x - y)*x2 + 1/2*(1 - x - y)**2*x4 +
      1/6*(1 - x - y)**3*x7$

f6 := x1 + (1 - x - y)*x3 + 1/2*(1 - x - y)*x6 +
      1/6*(1 - x - y)**3*x9$

f7 := x1 - x*x2 + (1 - y)*x3 + 1/2*x*x4 - x*(1 - y)*x5 +
      1/2*(1 - y)**2*x6 - 1/6*x**3*x7 + 1/2*x*(1 - y)*(1 - y + x)*x8
      + 1/6*(1-y)**3*x9$

f8 := x1 - x*x2 + x*x3 + 1/2*x**2*x4 - x**2*x5 + 1/2*x**2*x6 +
      1/6*x**3*x7 - 1/2*x**3*x8 + 1/6*x**3*x9$

f9 := x1 - x*x2 + 1/2*x**2*x4 + 1/6*x**3*x7$

solve({f1,f2,f3,f4,f5,f6,f7,f8,f9},{x1,x2,x3,x4,x5,x6,x7,x8,x9});

solve({f1 - 1,f2,f3,f4,f5,f6,f7,f8,f9},{x1,x2,x3,x4,x5,x6,x7,x8,x9});


% The following examples were discussed in Char, B.W., Fee, G.J.,
% Geddes, K.O., Gonnet, G.H., Monagan, M.B., Watt, S.M., "On the
% Design and Performance of the Maple System", Proc. 1984 Macsyma
% Users' Conference, G.E., Schenectady, NY, 1984, 199-219.

% Problem 1.

solve({ -22319*x0+25032*x1-83247*x2+67973*x3+54189*x4
       -67793*x5+81135*x6+22293*x7+27327*x8+96599*x9-15144,
       79815*x0+37299*x1-28495*x2-52463*x3+25708*x4 -55333*x5-
       2742*x6+83127*x7-29417*x8-43202*x9+93314, -29065*x0-77803*x1-
       49717*x2-64748*x3-68324*x4 -50162*x5-64222*x6-
       4716*x7+30737*x8+22971*x9+90348, 62470*x0+59658*x1-
       46120*x2+58376*x3-28208*x4 -74506*x5+28491*x6+21099*x7+29149*x8-
       20387*x9+36254, -98233*x0-26263*x1-63227*x2+34307*x3+92294*x4
       +10148*x5+3192*x6+24044*x7-83764*x8-1121*x9+13871,
       -20427*x0+62666*x1+27330*x2-78670*x3+9036*x4 +56024*x5-4525*x6-
       50589*x7-62127*x8-32846*x9+38466,
       -85609*x0+5424*x1+86992*x2+59651*x3-60859*x4 -55984*x5-
       6061*x6+44417*x7+92421*x8+6701*x9-9459,
       -68255*x0+19652*x1+92650*x2-93032*x3-30191*x4 -31075*x5-
       89060*x6+12150*x7-78089*x8-12462*x9+1027, 55526*x0-
       91202*x1+91329*x2-25919*x3-98215*x4 +30554*x5+913*x6-
       35751*x7+17948*x8-58850*x9+66583, 40612*x0+84364*x1-
       83317*x2+10658*x3+37213*x4 +50489*x5+72040*x6-
       21227*x7+60772*x8+95114*x9-68533});

solve({ -22319*x0+25032*x1-83247*x2+67973*x3+54189*x4
        -67793*x5+81135*x6+22293*x7+27327*x8+96599*x9-15144,
        79815*x0+37299*x1-28495*x2-52463*x3+25708*x4 -55333*x5-
        2742*x6+83127*x7-29417*x8-43202*x9+93314, -29065*x0-77803*x1-
        49717*x2-64748*x3-68324*x4 -50162*x5-64222*x6-
        4716*x7+30737*x8+22971*x9+90348, 62470*x0+59658*x1-
        46120*x2+58376*x3-28208*x4-74506*x5+28491*x6+21099*x7+29149*x8-
        20387*x9+36254,-98233*x0-26263*x1-63227*x2+34307*x3+92294*x4
        +10148*x5+3192*x6+24044*x7-83764*x8-1121*x9+13871,
        -20427*x0+62666*x1+27330*x2-78670*x3+9036*x4 +56024*x5-4525*x6-
        50589*x7-62127*x8-32846*x9+38466,
        -85609*x0+5424*x1+86992*x2+59651*x3-60859*x4 -55984*x5-
        6061*x6+44417*x7+92421*x8+6701*x9-9459,
        -68255*x0+19652*x1+92650*x2-93032*x3-30191*x4 -31075*x5-
        89060*x6+12150*x7-78089*x8-12462*x9+1027, 55526*x0-
        91202*x1+91329*x2-25919*x3-98215*x4 +30554*x5+913*x6-
        35751*x7+17948*x8-58850*x9+66583, 40612*x0+84364*x1-
        83317*x2+10658*x3+37213*x4 +50489*x5+72040*x6-
        21227*x7+60772*x8+95114*x9-68533});


% The next two problems give the current routines some trouble and
% have therefore been commented out.

% Problem 2.

comment
solve({ 81*x30-96*x21-45, -36*x4+59*x29+26,
       -59*x26+5*x3-33, -81*x19-92*x23-21*x17-9, -46*x29-
       13*x22+22*x24+83, 47*x4-47*x14-15*x26-40, 83*x30+70*x17+56*x10-
       31, 10*x27-90*x9+52*x21+52, -33*x20-97*x26+20*x6-76,
       97*x16+41*x8-13*x12+66, 16*x16-52*x10-73*x28+49, -28*x1-53*x24-
       x27-67, -22*x26-29*x24+73*x10+8, 88*x18+61*x19-98*x9-55, 99*x28-
       91*x26+26*x21-95, -6*x18+25*x7-77*x2+99, 28*x13-50*x17-52*x14-64,
       -50*x20+26*x11+93*x2+77, -70*x8+74*x19-94*x26+86, -18*x18-2*x16-
       79*x23+91, 36*x26-13*x11-53*x25-5, 10*x7+57*x16-85*x10-14,
       -3*x27+44*x4+52*x22-1, 21*x11+20*x25-30*x4-83, 70*x2-97*x19-
       41*x26-50, -51*x8+95*x12-85*x26+45, 83*x30+41*x12+50*x2+53,
       -4*x26+69*x8-58*x5-95, 59*x27-78*x30-66*x23+16, -10*x20-36*x11-
       60*x1-59});


% Problem 3.
comment
solve({ 115*x40+566*x41-378*x42+11401086415/6899901,
       560*x0-45*x1-506*x2-11143386403/8309444, -621*x1-
       328*x2+384*x3+1041841/64675, -856*x2+54*x3+869*x4-41430291/24700,
       596*x3-608*x4-560*x5-10773384/11075,
       -61*x4+444*x5+924*x6+4185100079/11278780, 67*x5-95*x6-
       682*x7+903866812/6618863, 196*x6+926*x7-930*x8-
       2051864151/2031976, -302*x7-311*x8-890*x9-14210414139/27719792,
       121*x8-781*x9-125*x10-4747129093/39901584, 10*x9+555*x10-
       912*x11+32476047/3471829, -151*x38+732*x39-
       397*x40+327281689/173242, 913*x10-259*x11-982*x12-
       18080663/5014020, 305*x11+9*x12-357*x13+1500752933/1780680,
       179*x12-588*x13+665*x14+8128189/51832, 406*x13+843*x14-
       833*x15+201925713/97774, 107*x14+372*x15+505*x16-
       5161192791/3486415, 720*x15-212*x16+607*x17-31529295571/7197760,
       951*x16-685*x17+148*x18+1034546543/711104, -654*x17-
       899*x18+543*x19+1942961717/1646560,
       -448*x18+673*x19+702*x20+856422818/1286375, 396*x19-
       196*x20+218*x21-4386267866/21303625, -233*x20-796*x21-373*x22-
       85246365829/57545250, 921*x21-368*x22+730*x23-
       93446707622/51330363, -424*x22+378*x23+727*x24-
       6673617931/3477462, -633*x23+565*x24-208*x25+8607636805/4092942,
       971*x24+170*x25-865*x26-25224505/18354, 937*x25+333*x26-463*x27-
       339307103/1025430, 494*x26-8*x27-50*x28+57395804/34695,
       530*x27+631*x28-193*x29-8424597157/680022,
       -435*x28+252*x29+916*x30+196828511/19593, 327*x29+403*x30-
       845*x31+8458823325/5927971, 246*x30+881*x31-
       394*x32+13624765321/156546826, 946*x31+169*x32-43*x33-
       53594199271/126093183, -146*x32+503*x33-
       363*x34+66802797635/15234909, -132*x33-
       686*x34+376*x35+8167530636/902635, -38*x34-188*x35-
       583*x36+1814153743/1124240, 389*x35+562*x36-688*x37-
       12251043951/5513560, -769*x37-474*x38-89*x39-2725415872/1235019,
       -625*x36-122*x37+468*x38+7725682775/4506736,
       839*x39+936*x40+703*x41+1912091857/1000749,
       -314*x41+102*x42+790*x43+7290073150/8132873, -905*x42-
       454*x43+524*x44-10110944527/4538233, 379*x43+518*x44-328*x45-
       2071620692/519645, 284*x44-979*x45+690*x46-915987532/16665,
       198*x45-650*x46-763*x47+548801657/11220, 974*x46+12*x47+410*x48-
       3831097561/51051, -498*x47-135*x48-230*x49-18920705/9282,
       665*x48+156*x49+34*x0-27714736/156585, -519*x49-366*x0-730*x1-
       2958446681/798985});


% Problem 4.

% This one needs the Cramer code --- it takes forever otherwise.

on cramer;

solve({ -b*k8/a+c*k8/a, -b*k11/a+c*k11/a,
       -b*k10/a+c*k10/a+k2,
        -k3-b*k9/a+c*k9/a, -b*k14/a+c*k14/a, -b*k15/a+c*k15/a,
        -b*k18/a+c*k18/a-k2, -b*k17/a+c*k17/a, -b*k16/a+c*k16/a+k4,
        -b*k13/a+c*k13/a-b*k21/a+c*k21/a+b*k5/a-c*k5/a,
        b*k44/a-c*k44/a, -b*k45/a+c*k45/a, -b*k20/a+c*k20/a,
        -b*k44/a+c*k44/a, b*k46/a-c*k46/a,
        b**2*k47/a**2-2*b*c*k47/a**2+c**2*k47/a**2,
        k3, -k4, -b*k12/a+c*k12/a-a*k6/b+c*k6/b,
        -b*k19/a+c*k19/a+a*k7/c-b*k7/c, b*k45/a-c*k45/a,
        -b*k46/a+c*k46/a, -k48+c*k48/a+c*k48/b-c**2*k48/(a*b),
        -k49+b*k49/a+b*k49/c-b**2*k49/(a*c), a*k1/b-c*k1/b,
        a*k4/b-c*k4/b, a*k3/b-c*k3/b+k9, -k10+a*k2/b-c*k2/b,
        a*k7/b-c*k7/b, -k9, k11, b*k12/a-c*k12/a+a*k6/b-c*k6/b,
        a*k15/b-c*k15/b, k10+a*k18/b-c*k18/b,
        -k11+a*k17/b-c*k17/b, a*k16/b-c*k16/b,
        -a*k13/b+c*k13/b+a*k21/b-c*k21/b+a*k5/b-c*k5/b,
        -a*k44/b+c*k44/b, a*k45/b-c*k45/b,
        a*k14/c-b*k14/c+a*k20/b-c*k20/b, a*k44/b-c*k44/b,
        -a*k46/b+c*k46/b, -k47+c*k47/a+c*k47/b-c**2*k47/(a*b),
        a*k19/b-c*k19/b, -a*k45/b+c*k45/b, a*k46/b-c*k46/b,
        a**2*k48/b**2-2*a*c*k48/b**2+c**2*k48/b**2,
        -k49+a*k49/b+a*k49/c-a**2*k49/(b*c), k16, -k17,
        -a*k1/c+b*k1/c, -k16-a*k4/c+b*k4/c, -a*k3/c+b*k3/c,
        k18-a*k2/c+b*k2/c, b*k19/a-c*k19/a-a*k7/c+b*k7/c,
        -a*k6/c+b*k6/c, -a*k8/c+b*k8/c, -a*k11/c+b*k11/c+k17,
        -a*k10/c+b*k10/c-k18, -a*k9/c+b*k9/c,
        -a*k14/c+b*k14/c-a*k20/b+c*k20/b,
        -a*k13/c+b*k13/c+a*k21/c-b*k21/c-a*k5/c+b*k5/c,
        a*k44/c-b*k44/c, -a*k45/c+b*k45/c, -a*k44/c+b*k44/c,
        a*k46/c-b*k46/c, -k47+b*k47/a+b*k47/c-b**2*k47/(a*c),
        -a*k12/c+b*k12/c, a*k45/c-b*k45/c, -a*k46/c+b*k46/c,
        -k48+a*k48/b+a*k48/c-a**2*k48/(b*c),
        a**2*k49/c**2-2*a*b*k49/c**2+b**2*k49/c**2, k8, k11, -k15,
        k10-k18, -k17, k9, -k16, -k29, k14-k32, -k21+k23-k31,
        -k24-k30, -k35, k44, -k45, k36, k13-k23+k39, -k20+k38,
        k25+k37, b*k26/a-c*k26/a-k34+k42, -2*k44, k45, k46,
        b*k47/a-c*k47/a, k41, k44, -k46, -b*k47/a+c*k47/a,
        k12+k24, -k19-k25, -a*k27/b+c*k27/b-k33, k45, -k46,
        -a*k48/b+c*k48/b, a*k28/c-b*k28/c+k40, -k45, k46,
        a*k48/b-c*k48/b, a*k49/c-b*k49/c, -a*k49/c+b*k49/c,
        -k1, -k4, -k3, k15, k18-k2, k17, k16, k22, k25-k7,
        k24+k30, k21+k23-k31, k28, -k44, k45, -k30-k6, k20+k32,
        k27+b*k33/a-c*k33/a, k44, -k46, -b*k47/a+c*k47/a, -k36,
        k31-k39-k5, -k32-k38, k19-k37, k26-a*k34/b+c*k34/b-k42,
        k44, -2*k45, k46, a*k48/b-c*k48/b, a*k35/c-b*k35/c-k41,
        -k44, k46, b*k47/a-c*k47/a, -a*k49/c+b*k49/c, -k40, k45,
        -k46, -a*k48/b+c*k48/b, a*k49/c-b*k49/c, k1, k4, k3, -k8,
        -k11, -k10+k2, -k9, k37+k7, -k14-k38, -k22, -k25-k37, -k24+k6,
        -k13-k23+k39, -k28+b*k40/a-c*k40/a, k44, -k45, -k27, -k44,
        k46, b*k47/a-c*k47/a, k29, k32+k38, k31-k39+k5, -k12+k30,
        k35-a*k41/b+c*k41/b, -k44, k45, -k26+k34+a*k42/c-b*k42/c,
        k44, k45, -2*k46, -b*k47/a+c*k47/a, -a*k48/b+c*k48/b,
        a*k49/c-b*k49/c, k33, -k45, k46, a*k48/b-c*k48/b,
        -a*k49/c+b*k49/c },
       {k1, k2, k3, k4, k5, k6, k7, k8, k9, k10, k11, k12, k13, k14,
        k15, k16, k17, k18, k19, k20, k21, k22, k23, k24, k25, k26,
        k27, k28, k29, k30, k31, k32, k33, k34, k35, k36, k37, k38,
        k39, k40, k41, k42, k43, k44, k45, k46, k47, k48, k49});

off cramer;

% Problem 5.

solve ({2*a3*b3+a5*b3+a3*b5, a5*b3+2*a5*b5+a3*b5,
        a5*b5, a2*b2, a4*b4, a5*b1+b5+a4*b3+a3*b4,
        a5*b3+a5*b5+a3*b5+a3*b3, a0*b2+b2+a4*b2+a2*b4+c2+a2*b0+a2*b1,
        a0*b0+a0*b1+a0*b4+a3*b2+b0+b1+b4+a4*b0+a4*b1+a2*b5+a4*b4+c1+c4
        +a5*b2+a2*b3+c0,
        -1+a3*b0+a0*b3+a0*b5+a5*b0+b3+b5+a5*b4+a4*b3+a4*b5+a3*b4+a5*b1
        +a3*b1+c3+c5,
        b4+a4*b1, a5*b3+a3*b5, a2*b1+b2, a4*b5+a5*b4, a2*b4+a4*b2,
        a0*b5+a5*b0+a3*b4+2*a5*b4+a5*b1+b5+a4*b3+2*a4*b5+c5,
        a4*b0+2*a4*b4+a2*b5+b4+a4*b1+a5*b2+a0*b4+c4,
        c3+a0*b3+2*b3+b5+a4*b3+a3*b0+2*a3*b1+a5*b1+a3*b4,
        c1+a0*b1+2*b1+a4*b1+a2*b3+b0+a3*b2+b4});


% Problem 6.

solve({2*a3*b3+a5*b3+a3*b5, a5*b3+2*a5*b5+a3*b5,
       a4*b4, a5*b3+a5*b5+a3*b5+a3*b3, b1, a3*b3, a2*b2, a5*b5,
       a5*b1+b5+a4*b3+a3*b4, a0*b2+b2+a4*b2+a2*b4+c2+a2*b0+a2*b1,
       b4+a4*b1, b3+a3*b1, a5*b3+a3*b5, a2*b1+b2, a4*b5+a5*b4,
       a2*b4+a4*b2, a0*b0+a0*b1+a0*b4+a3*b2+b0+b1+b4+a4*b0+a4*b1
       +a2*b5+a4*b4+c1+c4+a5*b2+a2*b3+c0,-1+a3*b0+a0*b3+a0*b5+a5*b0
       +b3+b5+a5*b4+a4*b3+a4*b5+a3*b4+a5*b1+a3*b1+c3+c5,
       a0*b5+a5*b0+a3*b4+2*a5*b4+a5*b1+b5+a4*b3+2*a4*b5+c5,
       a4*b0+2*a4*b4+a2*b5+b4+a4*b1+a5*b2+a0*b4+c4,
       c3+a0*b3+2*b3+b5+a4*b3+a3*b0+2*a3*b1+a5*b1+a3*b4,
       c1+a0*b1+2*b1+a4*b1+a2*b3+b0+a3*b2+b4});

% Example cited by Bruno Buchberger
%        in R.Janssen: Trends in Computer Algebra,
%     Springer, 1987
% Geometry of a simple robot,
%   l1,l2   length of arms
%   ci,si   cos and sin of rotation angles


solve( { c1*c2 -cf*ct*cp + sf*sp,
         s1*c2 - sf*ct*cp - cf*sp,
         s2 + st*cp,
         -c1*s2 - cf*ct*sp + sf*cp,
         -s1*s2 + sf*ct*sp - cf*cp,
         c2 - st*sp,
         s1 - cf*st,
         -c1 - sf*st,
         ct,
         l2*c1*c2 - px,
         l2*s1*c2 - py,
         l2*s2 + l1 - pz,
         c1**2 + s1**2 -1,
         c2**2 + s2**2 -1,
         cf**2 + sf**2 -1,
         ct**2 + st**2 -1,
         cp**2 + sp**2 -1},
      {c1,c2,s1,s2,py,cf,ct,cp,sf,st,sp});

% Steady state computation of a prototypical chemical
% reaction network (the "Edelstein" network)
 
solve(
 { alpha * c1 - beta * c1**2 - gamma*c1*c2 + epsilon*c3,
   -gamma*c1*c2 + (epsilon+theta)*c3 -eta *c2,
   gamma*c1*c2 + eta*c2 - (epsilon+theta) * c3},
  {c3,c2,c1});

solve(
{( - 81*y1**2*y2**2 + 594*y1**2*y2 - 225*y1**2 + 594*y1*y2**2 - 3492*
y1*y2 - 750*y1 - 225*y2**2 - 750*y2 + 14575)/81,
( - 81*y2**2*y3**2 + 594*y2**2*y3 - 225*y2**2 + 594*y2*y3**2 - 3492*
y2*y3 - 750*y2 - 225*y3**2 - 750*y3 + 14575)/81,
( - 81*y1**2*y3**2 + 594*y1**2*y3 - 225*y1**2 + 594*y1*y3**2 - 3492*
y1*y3 - 750*y1 - 225*y3**2 - 750*y3 + 14575)/81,
(2*(81*y1**2*y2**2*y3 + 81*y1**2*y2*y3**2 - 594*y1**2*y2*y3 - 225*y1
**2*y2 - 225*y1**2*y3 + 1650*y1**2 + 81*y1*y2**2*y3**2 - 594*y1*
y2**2*y3 - 225*y1*y2**2 - 594*y1*y2*y3**2 + 2592*y1*y2*y3 + 2550
*y1*y2 - 225*y1*y3**2 + 2550*y1*y3 - 3575*y1 - 225*y2**2*y3 +
1650*y2**2 - 225*y2*y3**2 + 2550*y2*y3 - 3575*y2 + 1650*y3**2 -
3575*y3 - 30250))/81}, {y1,y2,y3,y4});

% Another nice nonlinear system.

solve({y=x+t^2,x=y+u^2},{x,y,u,t});

% Example from Stan Kameny (relation between Gamma function values)
%   containing surds in the coefficients.

solve({x54=x14/4,x54*x34=sqrt pi/sqrt 2*x32,x32=x12/2,
       x12=sqrt pi, x14*x34=pi*sqrt 2});

% A system given by J. Hietarinta with complex coefficients.

on complex;

apu := {2*a - a6,2*b*c3 - 1,i - 2*x + 1,2*x**2 - 2*x + 1,n1 + 1}$

solve apu;

clear apu;

off complex;

% More examples that can now be solved.

solve({e^(x+y)-1,x-y},{x,y});

solve({e^(x+y)+sin x,x-y},{x,y}); % no algebraic solution exists.

solve({e^(x+y)-1,x-y**2},{x,y});

solve(e^(y^2) * e^y -1,y);

solve(e^(y^2 +y)-1,y);

solve(e^(y^2)-1,y);

solve(e^(y^2+1)-1,y);

solve({e^(x+y+z)-1,x-y**2=1,x**2-z=2},{x,y,z});

solve(e^(y^4+3y^2+y)-1,y);

% Transcendental equations proposed by Roger Germundsson
% 

eq1 := 2*asin(x) + asin(2*x) - PI/2;
eq2 := 2*asin(x) - acos(3*x);
eq3 := acos(x) - atan(x);
eq4 := acos(2*x**2 - 4*x -x) - 2*asin(x);
eq5 := 2*atan(x) - atan( 2*x/(1-x**2) );

sol1 := solve(eq1,x);
sol2 := solve(eq2,x);
sol3 := solve(eq3,x);
sol4 := solve(eq4,x);
sol5 := solve(eq5,x);   % This solution should be the open interval
			% (-1,1).

% Example 52 of M. Wester: the function has no real zero although
%  REDUCE 3.5 and Maple tend to return 3/4.

if solve(sqrt(x^2 +1) - x +2,x) neq {} then rederr "Illegal result";

% Using a root_of expression as an algebraic number.

solve(x^5 - x - 1,x);

w:=rhs first ws;

w^5;

w^5-w;

clear w;

% The following examples come from Daniel Lichtblau of WRI and were
% communicated by Laurent.Bernardin from ETH Zuerich.

solve(x-Pi/2 = cos(x+Pi),x);

solve(exp(x^2+x+2)-1,x);

solve(log(sqrt(1+z)/sqrt(z-1))=x,z);

solve({exp(x+3*y-2)=7,3^(2*x-y+4)=2},{x,y});

solve(a*3^(c*t)+b*3^((c+a)*t),t);

solve(log(x+sqrt(x^2+a))=b,{x});

solve(z=log(w)/log(2)+w^2,w);

solve(w*2^(w^2)=5,w);

solve(log(x/y)=1/y^2*(x+(1/x)),y);

solve(exp(z)=w*z^(-n),z);

solve(-log(3)+log(2+y/3)/2-log(y/3)/2=(-I)/2*Pi,y);

solve(-log(x)-log(y/x)/2+log(2+y/x)/2=(-3*I)/2*Pi,y);

solve((I+1)*log(x)+(3*I+3)*log(x+3)=7,x);

solve(x+sqrt(x)=1,x);

solve({cos(1/5+alpha+x)=5,cos(2/5+alpha-x)=6},{alpha,x});

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/solvealg.red0000644000175000017500000011744011526203062024153 0ustar  giovannigiovannimodule solvealg;  % Solution of equations and systems which can
                  % be lifted to algebraic (polynomial) systems.

% Author: Herbert Melenk.

% Copyright (c) 1992 The RAND Corporation and Konrad-Zuse-Zentrum.
% All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% August 1992: added material for
%    rule set for reduction of trig. polynomial terms to
%      elementary expressions in sin and cos,
%    constant expressions in sin, cos and constant roots,
%    closed form results for trigonometric systems.
%    general exponentials.
%    avoiding false solutions with surds.
%
% May 1993: better handling of products of exponentials
%       with common base,
%    additional computation branch for linear parts of
%       nonlinear systems.
% July 1996: safe handling of twice (or more) the same input
%     (not handling the case, that one equation is a multiple
%      of an other one)
% January 2001: improved "solvenonlnrsyslin" (inhibiting an infinite
%      recursion.


fluid '(!*expandexpt);   % from simp.red

fluid '( system!*        % system to be solved
         osystem!*       % original system on input
         uv!*            % user supplied variables
         iv!*            % internal variables
         fv!*            % restricted variables
         kl!*            % kernels to be investigated
         sub!*           % global substitutions
         inv!*           % global inverse substitutions
         depl!*          % reduce dependency list
         !*solvealgp     % true if using this module
         solvealgdb!*    % collecting some data
         last!-vars!*    % collection of innermost aux variables
         const!-vars!*   % variables representing constants
         root!-vars!*    % variables representing root expressions
         !*expli         % local switch: explicit solution
         groebroots!*    % predefined roots from input surds
         !*test_solvealg % debugging support
         !*arbvars
         !*varopt
         solve!-gensymcounter
       );

fluid'(!*trnonlnr);
  % If set on, the modified system and the Groebner result
  % or the reason for the failure are printed.

global'(loaded!-packages!* !!arbint);

switch trnonlnr;

!*solvealgp:=t;

%     Solvenonlnrsys receives a system of standard forms and
%     a list of variables from 'solve'. The system is lifted to
%     a polynomial system (if possible) in substituting the
%     non-atomic kernels by new variables and appending additonal
%     relations, e.g.
%         replace                        add
%       sin u,cos u  -> su,cu        su^2+cu^2-1
%         u^(1/3)    -> v            v^3 - u
%          ...
%     in a recursive style. If completely successful, the
%     system definitely can be treated by Groebner or any
%     other polynomial system solver.
%
%     Return value is a pair
%          (tag . res)
%     where 'res' is nil or a structure for !*solvelist2solveeqlist
%     and 'tag' is one of the following:
%
%       t             a satisfactory solution was generated,
%
%       failed        the algorithm cannot be applied ('res=nil')
%
%       inconsistent  the algorithm could prove that the
%                     the system has no solution ('res=nil')
%
%       nil           the complexity of the system could
%                     be reduced, but some (or all) relations
%                     remain still implicit.

% Rules to be applied locally for converting composite transcendental
% function forms into simpler ones

algebraic <<
solvealg!-rules1:=
{ sin(~alpha + ~beta) => sin(alpha)*cos(beta) + cos(alpha)*sin(beta),
  cos(~alpha + ~beta) => cos(alpha)*cos(beta) - sin(alpha)*sin(beta),
  sin(~n*~alpha) => sin(alpha)*cos((n-1)*alpha)
                  + cos(alpha)*sin((n-1)*alpha) when fixp n,
  cos(~n*~alpha) => cos(alpha)*cos((n-1)*alpha)
                  - sin(alpha)*sin((n-1)*alpha) when fixp n,
  sin(~alpha)**2 => 1 - cos(alpha)**2,
  sinh(~alpha+~beta) => sinh(alpha)*cosh(beta) + cosh(alpha)*sinh(beta),
  cosh(~alpha+~beta) => cosh(alpha)*cosh(beta) + sinh(alpha)*sinh(beta),
  sinh(~n*~alpha) => sinh(alpha)*cosh((n-1)*alpha)
                   + cosh(alpha)*sinh((n-1)*alpha) when fixp n,
  cosh(~n*~alpha) => cosh(alpha)*cosh((n-1)*alpha)
                   + sinh(alpha)*sinh((n-1)*alpha) when fixp n,
  sinh(~alpha)**2 => cosh(alpha)**2 - 1};

solvealg!-rules2:=
{ tan(~alpha) => sin(alpha)/cos(alpha),
  cot(~alpha) => cos(alpha)/sin(alpha),
  tanh(~alpha) => sinh(alpha)/cosh(alpha),
  coth(~alpha) => cosh(alpha)/sinh(alpha) } ;

solvealg!-rules3:=
{ sin(~alpha)**2 => 1 - cos(alpha)**2,
  sinh(~alpha)**2 => cosh(alpha)**2 - 1};

% Artificial operator for matching powers in a product.

operator my!-expt;

solvealg!-rules4:=
 {my!-expt(~a,~b)*my!-expt(a,~c) => my!-expt(a,b+c),
  my!-expt(~a,~b)*a => my!-expt(a,b+1)
 %my!-expt(~a,~b)/my!-expt(a,~c) => my!-expt(a,b-c)
  };

>>;

symbolic procedure solvenonlnrsys(sys,uv);
  % Interface to algebraic system solver.
  % Factorize the system and collect solutions.
  % After factoring we resimplify with *expandexpt off
  % in order to have exponentials to one basis
  % collected.
solvenonlnrsys0(sys,uv,nil);

symbolic procedure solvenonlnrsys0(sys,uv,lvars);
  begin scalar q,r,s,tag,!*expandexpt;
   s:=sys;sys:=nil;
   for each x in s do sys:=union(sys,{x});
   s:='(nil);
   if solve!-psysp(sys,uv) then s:={sys} else
      for each p in sys do
         <>;
   tag:='failed;r:=nil;
   for each u in s do
      <<% Collect exponentials with same base.
        u:=solvenonlnrcollectexpt u;
        q:=solvenonlnrsys1(u,uv);
        if eqcar(q,'failed) then q:=solvenonlnrsyssep(u,uv);
        if eqcar(q,'failed) then q:=solvenonlnrsyslin(u,uv,nil,lvars);
        if eqcar(q,'not) then q:=solvenonlnrsyslin(u,uv,t,lvars);
        if eqcar(q,'not) then q:='(failed);
        if car q and car q neq 'failed then tag:=car q;
        q:=if car q neq 'failed then cdr q else
                for each j in u collect {{j ./ 1},nil,1};
        r:=union(q,r)>>;
   return if tag eq 'inconsistent or tag eq 'failed then {tag}
       else tag.r end;

symbolic procedure topkernlis(u,v);
   v and (topkern(u,car v) or topkernlis(u,cdr v));

symbolic procedure solvenonlnrcollectexpt u;
  % 'u' is a list of standard forms. Reform these
  % such that products of exponentials with same basis
  % are collected.
   if not smemq('expt,u) then u else
   <>;

symbolic procedure solvenonlnrsyslin(eqs,vars,mode,lvars);
 % 'eqs' is a system of equations (standard forms,
 % implicitly equated to zero); this routine tries
 % to reduce the system recursively by separation,
 % if one variable occurs in one equation only linearly.
 % Mode=nil: simple version: only pure linear variables
 %           are substituted.
 %      t:   extended version: replacing variables with
 %           degree 1 and potentially complicated
 %           coefficients.
 % Returns solution or
 %     '(not)   if not applicable
 %     '(failed)if applicable but solution failed.
begin scalar d,e,e1,lx,n,s,q,x,v,w,w1,neqs,nvars;
 v:=vars;
 var_loop:if null v then return'(not);x:=car v;v:=cdr v;w:=eqs;
 if x member lvars then go to var_loop;lvars:=x.lvars;lx:={x};
 eqn_loop:if null w then goto var_loop;e:=car w;w:=cdr w;
   if null e then goto eqn_loop;
   if domainp e then return'(inconsistent);
   e1:=reorder e where kord!*=lx;
   if not(mvar e1=x) or ldeg e1>1 or
     smemq(x,d:=lc e1)or smemq(x,n:=red e1)then goto eqn_loop;
   if not mode then
   <>;
    % Linear form found: 'd*x+n=0'. This is basis for a solution
    % 'x=-n/d'. In a second branch the case'{n=0,d=0}'has to
    % be considered if 'd' is not a constant.
   n:=reorder n;d:=reorder d;
    % Step 1: Substitute in remaining equations, solve
    % and add linear formula to the result.
   s:=quotsq(negf n ./ 1, d ./ 1);
   neqs:=for each eqn in delete(e,eqs)join
     <>;
   nvars:=for each y in delete(x,vars)join if smemq(y,neqs)then{y};
   w:=if null neqs then'(t(nil nil 1))else
    if null nvars then'(inconsistent)else
    if cdr neqs then solvenonlnrsys0(neqs,nvars,lvars)
    else solvenonlnrsysone(car neqs,car nvars);
   if car w eq'failed then return w;
   w:=add!-variable!-to!-tagged!-solutions(x,s,w);
   if domainp d or not mode then return w;
    % Step 2: Add an eventual solution for'n=0,d=0'.
   w1:=solvenonlnrsys0(n.d.eqs,vars,lvars);
   return merge!-two!-tagged!-solutions(w,w1)end;

symbolic procedure solvenonlnrsysone(f,x);
 % Equation system has been reduced to one. Using 'solvesq'.
  begin scalar w;w:=solvesq(f ./ 1,x,1);
   if null w then return'(inconsistent)
   else if null cadr car w then return'(failed);
%  if not smemq('root_of,w) then goto ret;
%    % here we try to find out whether a root_of
%    % expression is a useful information or whether
%    % it is simply an echo of the input.
%  if cdr w then goto ret; % multiple branches: good.
%  q := prepsq caar car w;
%  if not eqcar(q,'root_of) % not on top level: good.
%     then goto ret;
%  q:=subst(x,caddr q,cadr q);
%  if f = numr simp q then return '(failed);
%ret:
   return t.w end;

symbolic procedure add!-variable!-to!-tagged!-solutions(x,s,y);
  % 'y' is a tagged solution. Add equation 'x=s' to all members.
  if eqcar(y,'inconsistent) then y else
  if null y or null cdr y then{t,{{s},{x},1}}else
  car y.for each q in cdr y collect
   % Put new solution into the last position.
     {append(car q,{s}),append(cadr q,{x}),caddr q};

symbolic procedure merge!-two!-tagged!-solutions(w1,w2);
  % 'w1' and 'w2' are tagged solution sets. Merge these and
  % eliminate inconsistent cases.
  if car w1='failed or car w2='failed then'(failed)else
  if car w1='inconsistent then w2 else
  if car w2='inconsistent then w1 else
  car w1.append(cdr w1,cdr w2);

symbolic procedure solvenonlnrsyssep(eqs,vars);
 % 'eqs' is a system of equations (standard forms,
 % implicitly equated to zero); this routine tries
 % to reduce the system recursively by separation,
 % if one variable occurs only in one equation.
  begin scalar y,r,s,r0,u,w,tag;
   if null vars then return'(failed) else
   if null cdr eqs then
   <>;
   for each x in vars do if null y then
   <>;
   if null y then return'(failed);
   r:=car r;
   s:=solvenonlnrsys(delete(r,eqs),delete(y,vars));
   if car s='failed then return s else s:=cdr s;
   tag:=t;
   u:=for each s0 in s join
   <
 p do w:=w #- p;
           i:=i#+1;
         >>;
    if null r then typerr({'sqrt,a},"expression mod p");
    return r;
   end;

symbolic procedure modsqrt2(a,p);
 % General algorithm for arbitrary prime p:
 % H. Cohen: Computational Algebraic Number theory, 1.5.1
   begin integer a,b,m,r,y,e,p,q,tt,n,p!-1,x,z;
     x:=a; p!-1:=p-1;
     q:=p-1;
     while evenp q do <>;

 s1: repeat n:=random(p) until legendre!-symbol(n,p)=p!-1;
     z:=general!-modular!-expt(n,q);

 s2: y:=z; r:=e; x:=general!-modular!-expt(a,(q-1)/2);
     b:=modp(a*x*x,p); x:=modp(a*x,p);

 s3: if modp(b,p)=1 then return x;
     m:=0;
     repeat m:=m+1 until general!-modular!-expt(b,expt(2,m)) = 1 or m=r;
     if m=r then typerr({'sqrt,a},"expression mod p");

 s4: tt:= general!-modular!-expt(y,expt(2,r-m-1));
     y:= general!-modular!-times(tt,tt); r:=m;
     x:=general!-modular!-times(x,tt);
     b:=general!-modular!-times(b,y);
     goto s3;
   end;

symbolic procedure modsqrt!*(u);
    %  print {"we got through:", u};
    !*modular2f modsqrt(cdr u,current!-modulus);

put('sqrt,'!:mod!:,'modsqrt!*);

algebraic operator legendre_symbol;

symbolic procedure legendre!-symbol(a,p);
   general!-modular!-expt(a,(p-1)/2);

algebraic procedure legendre_symbol1(a,p);
 begin scalar !*modular,current!-modulus,dmode!*,res;
   if p=1 then return 1;
   if primep p and remainder(p,2) =1
     then <>
    else rederr(
       "The second argument to legendre_symbol must be an odd prime");
   return( if res=p-1 then -1 else res);
 end;

algebraic let legendre_symbol(~a,~p)
       => legendre_symbol1(a,p) when fixp a and fixp p;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/quartic.red0000644000175000017500000002356611526203062024014 0ustar  giovannigiovannimodule quartic;  % Procedures for solving cubic, quadratic and quartic
                 % eqns.

% Author: Anthony C. Hearn.
% Modifications by: Stanley L. Kameny, Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*sub2 !*rounded !*trigform dmode!*);

!*trigform := t;   % Default value.

switch trigform;

symbolic procedure multfq(u,v);
   % Multiplies standard form U by standard quotient V.
   begin scalar x;
      x := gcdf(u,denr v);
      return multf(quotf(u,x),numr v) ./ quotf(denr v,x)
   end;

symbolic procedure quotsqf(u,v);
   % Forms quotient of standard quotient U and standard form V.
   begin scalar x;
      x := gcdf(numr u,v);
      return quotf(numr u,x) ./ multf(quotf(v,x),denr u)
   end;

symbolic procedure cubertq u;
   % Rationalizing the value in this and the following function leads
   % usually to neater results.
%  rationalizesq
      simpexpt list(mk!*sq subs2!* u,'(quotient 1 3));
   % simprad(u,3);

symbolic procedure sqrtq u;
%  rationalizesq
      simpexpt list(mk!*sq subs2!* u,'(quotient 1 2));
   % simprad(u,2);

% symbolic procedure subs2!* u; <>;

symbolic procedure solvequadratic(a2,a1,a0);
   % A2, a1 and a0 are standard quotients.
   % Solves a2*x**2+a1*x+a0=0 for x.
   % Returns a list of standard quotient solutions.
   % Modified to use root_val to compute numeric roots.  SLK.
   if !*rounded and numcoef a0 and numcoef a1 and numcoef a2
      then for each z in cdr root_val list mkpolyexp2(a2,a1,a0)
         collect simp!* (if eqcar(z,'equal) then caddr z
                          else errach {"Quadratic confusion",z})
    else begin scalar d;
      d := sqrtq subtrsq(quotsqf(exptsq(a1,2),4),multsq(a2,a0));
      a1 := quotsqf(negsq a1,2);
      return list(subs2!* quotsq(addsq(a1,d),a2),
                  subs2!* quotsq(subtrsq(a1,d),a2))
   end;

symbolic procedure numcoef a; denr a = 1 and domainp numr a;

symbolic procedure mkpolyexp2(a2,a1,a0);
  % The use of 'x is arbitrary here, since it is not used by root_val.
   <>;

symbolic procedure solvecubic(a3,a2,a1,a0);
   % A3, a2, a1 and a0 are standard quotients.
   % Solves a3*x**3+a2*x**2+a1*x+a0=0 for x.
   % Returns a list of standard quotient solutions.
   % See Abramowitz and Stegun, Sect. 3.8.2, for solutions in
   % terms of surds and Bronstein for solutions in terms of
   % trig functions.
   begin scalar q,r,sm,sp,s1,s2,x;
      a2 := quotsq(a2,a3);
      a1 := quotsq(a1,a3);
      a0 := quotsq(a0,a3);
      q := subtrsq(quotsqf(a1,3),quotsqf(exptsq(a2,2),9));
      r := subtrsq(quotsqf(subtrsq(multsq(a1,a2),multfq(3,a0)),6),
                   quotsqf(exptsq(a2,3),27));
      if null numr q or not !*trigform or not all_real(a0,a1,a2)
        then go to cbr;
    % this section uses trig functions, but only when a0,a1,a2 are real.
      s2 := sqrtq simp {'abs,prepsq q};
      if pos_num r then s2 := negsq s2;
      if pos_num q
         then <>
       else if pos_num addsq(exptsq(q,3),exptsq(r,2))
         then <>
       else   <>;
      return {subs2!* subtrsq(multsq(s2,multsq(-2 ./ 1,sp)),quotsqf(a2,3)),
              subs2!* subtrsq(multsq(s2,addsq(sp,sm)),quotsqf(a2,3)),
              subs2!* subtrsq(multsq(s2,subtrsq(sp,sm)),quotsqf(a2,3))};
 cbr: x := sqrtq addsq(exptsq(q,3),exptsq(r,2));
      s1 := cubertq addsq(r,x);
      s2 := if numr s1 then negsq quotsq(q,s1)
             else cubertq subtrsq(r,x);
         % This optimization only works if s1 is non zero.
      sp := addsq(s1,s2);
      sm := quotsqf(multsq(simp '(times i (sqrt 3)),subtrsq(s1,s2)),2);
 com: x := subtrsq(sp,quotsqf(a2,3));
      sp := negsq addsq(quotsqf(sp,2),quotsqf(a2,3));
      return list(subs2!* x,subs2!* addsq(sp,sm),
                  subs2!* subtrsq(sp,sm))
   end;

symbolic procedure pos_num a;
   begin scalar dmode,!*msg,!*numval;
      dmode := dmode!*;
      !*numval := t;
      on rounded,complex;
      a := resimp a;
      a := real_1 a and (numr simp list('sign,mk!*sq a)=1);
      off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      return a
   end;

symbolic procedure trigsq(a,fn);
   simpiden list(fn,mk!*sq subs2!* a);

symbolic procedure all_real(a,b,c);
   begin scalar dmode,!*ezgcd,!*msg,!*numval;
      % If ezgcd is on, modular arithmetic with rounded numbers can be
      % attempted.
      dmode := dmode!*;
      !*numval := t;
      on complex,rounded;
      % We should probably put an errorset here, so mode is correctly
      % reset with an error.
      a := real_1(a := resimp a) and real_1(b := resimp b)
           and real_1(c := resimp c);
      off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      return a
   end;

symbolic procedure real_1 x;
   numberp denr x and domainp numr x and null numr impartsq x;

symbolic procedure one_real a;
   begin scalar dmode,!*msg,!*numval;
      dmode := dmode!*;
      !*numval := t;
      on complex,rounded;
      a := real_1 resimp a;
      off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      return a end;

symbolic procedure solvequartic(a4,a3,a2,a1,a0);
   % Solve the quartic equation a4*x**4+a3*x**3+a2*x**2+a1*x+a0 = 0,
   % where the ai are standard quotients, using technique described in
   % Section 3.8.3 of Abramowitz and Stegun;
   begin scalar x,y,yy,cx,z,s,l,zz1,zz2,dmode,neg,!*msg,!*numval,
                a1cr,a2cr,a3cr,xcr,ycr,zcr;
      % Convert equation to monomial form.
      dmode := dmode!*;
      a3 := quotsq(a3,a4);
      a2 := quotsq(a2,a4);
      a1 := quotsq(a1,a4);
      a0 := quotsq(a0,a4);
      % Build and solve the resultant cubic equation.  We select the
      % real root if there is only one; or if there are three, we choose
      % one that yields real coefficients for the quadratics.  If no
      % roots are known to be real, we use an arbitrary one.
      yy := subtrsq(exptsq(a3,2),multfq(4,a2));
      x := solvecubic(!*f2q 1,
                      negsq a2,
                      subs2!* subtrsq(multsq(a1,a3),multfq(4,a0)),
                      subs2!* negsq addsq(exptsq(a1,2),
                                          multsq(a0,yy)));
      cx := car x;
      % Now check for real roots of the cubic.
      for each rr in x do if one_real rr then s := append(s,list rr);
      x := if (l := length s)=1 then car s else cx;
      % Now solve the two equivalent quadratic equations.
      a3 := quotsqf(a3,2); yy := quotsqf(yy,4);
      % select real coefficient for quadratic if possible.
      y := addsq(yy,x);
      if l<2 then go to zz;
loop: if not pos_num negsq y then go to zz else if l=1 then
        <>;
      l := l-1; s := cdr s; x := car s;
      y := addsq(yy,x); go to loop;
  zz: y := sqrtq y;
      x := quotsqf(x,2);
      z := sqrtq subtrsq(exptsq(x,2),a0);
     % the following test is needed, according to some editions of
     % Abramowitz and Stegun, to select the correct signs
     % (for the terms z) in the quadratics to produce correct roots.
     % Unfortunately, this test may fail for coefficients which are not
     % numeric because of the inability to recognize zero.
      !*numval := t;
      on rounded,complex;
      a1cr := resimp a1; a2cr := resimp a2; a3cr := resimp a3;
      xcr := resimp x; ycr := resimp y; zcr := resimp z;
      if null numr
         (zz1 :=
           resimp subtrsq(a1cr,addsq(multsq(subtrsq(a3cr,ycr),addsq(xcr,zcr)),
                 multsq(addsq(a3cr,ycr),subtrsq(xcr,zcr))))) then go to rst;
      if null numr
         (zz2 :=
           resimp subtrsq(a1cr,addsq(multsq(subtrsq(a3cr,ycr),subtrsq(xcr,zcr)),
                 multsq(addsq(a3cr,ycr),addsq(xcr,zcr)))))
         then <>;
      if domainp numr zz1 and domainp numr zz2
             and numberp denr zz1 and numberp denr zz2 and
         numr simp list('sign,list('difference,list('norm,mk!*sq zz1),
           list('norm,mk!*sq zz2)))=1 then neg := t;
 rst: off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      if neg then z := negsq z;
      return append(solvequadratic(!*f2q 1,subtrsq(a3,y),subtrsq(x,z)),
                    solvequadratic(!*f2q 1,addsq(a3,y),addsq(x,z)))
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/desir.tex0000644000175000017500000003354411526203062023475 0ustar  giovannigiovanni\documentclass[a4paper]{article}

\usepackage[dvipdfm]{graphicx}
\usepackage[dvipdfm]{color}
\usepackage[dvipdfm]{hyperref}

\setlength{\parindent}{0cm}

\title{{\bf DESIR} \\
\ \\
\ \\
SOLUTIONS FORMELLES~ D'EQUATIONS DIFFERENTIELLES \\
LINEAIRES ET HOMOGENES \\
AU VOISINAGE DE POINTS SINGULIERS REGULIERS ET IRREGULIERS \\
}

\begin{document}

\maketitle

\begin{center}
Differential linear homogenous Equation Solutions in the \\
neighbourhood of Irregular and Regular singular points \\
\ \\
Version 3.1~ -~ Septembre 89 \\
\ \\
\ \\
Groupe de Calcul Formel de Grenoble \\
laboratoire TIM3 \\
\ \\
(C. Dicrescenzo, F. Richard-Jung, E. Tournier) \\
\ \\
E-mail: dicresc@afp.imag.fr \\
\ \\
\ \\
\end{center}

\begin{enumerate}
\item Introduction
\item Form of solutions
\item Interactive use
\item Direct use
\item Useful functions
\item Limitations
\item Implementation
\end{enumerate}

\section{INTRODUCTION}

This software enables the basis of formal solutions to be computed for an
ordinary homogeneous differential equation with polynomial coefficients
over Q of any order, in the neighbourhood of zero ( regular or irregular
singular point, or ordinary point ). \\
Tools have been added to deal with equations with a polynomial right-hand
side, parameters and a singular point not to be found at zero. \\

This software can be used in two ways : 
\begin{itemize}
\item direct ( DELIRE procedure )
\item interactive ( DESIR procedure)
\end{itemize}

The basic procedure is the DELIRE procedure which enables the solutions of
a linear homogeneous differential equation to be computed in the neigh-
bourhood of zero. \\

The DESIR procedure is a procedure without argument whereby DELIRE can be
called without preliminary treatment to the data, that is to say, in an
interactive autonomous way. This procedure also proposes some transfor-
mations on the initial equation. This allows one to start comfortably
with an equation which has a non zero singular point, a polynomial
right-hand side and parameters. \\
This document is a succint user manual. For more details on the underlying
mathematics and the algorithms used, the reader can refer to : \\
\begin{center}
\begin{description}
\item[E. Tournier] : Solutions formelles d'equations differentielles - Le
logiciel de calcul formel DESIR. \\
These d'Etat de l'Universite Joseph Fourier (Grenoble - avril 87).
\end{description}
\end{center}

He will find more precision on use of parameters in :
\begin{center}
\begin{description}
\item[F. Richard-Jung] : Representation graphique de solutions d'equations
differentielles dans le champ complexe. \\
These de l'Universite Louis Pasteur (Strasbourg - septembre 88).
\end{description}
\end{center}

\section{FORMS OF SOLUTIONS}
We have tried to represent solutions in the simplest form possible. For
that, we have had to choose different forms according to the complexity
of the equation (parameters) and the later use we shall have of these
solutions. \\

\char`\"{}{\bf general solution}\char`\"{}~ =~ \{......, \{ split\_sol , cond \},....\} \\

\begin{center}
\begin{tabular}{lcp{9cm}}

cond & = & list of conditions or empty list (if there is no condition)
	     that parameters have to verify such that split\_sol is in the
	     basis of solutions. In fact, if there are parameters, basis of
	     solutions can have different expressions according to the values
	     of parameters. ( Note : if cond=\{\}, the list \char`\"{}general
	     solution\char`\"{} has one element only.) \\
split\_sol &  = & \{ $q , ram , polysol , r$ \} \\
	   &    & ( \char`\"{} split solution \char`\"{} enables precise information
	           on the solution to be obtained immediately ) \\
\end{tabular}
\end{center}

The variable in the differential operator being x, solutions are expressed in
respect to a new variable xt, which is a fractional power of x, in the
following way : \\

\begin{center}
\begin{tabular}{lcl}
$q$ & : & polynomial in $1/xt$ with complex coefficients \\
$ram$ & : & $xt$ = ${x}^{ram}$ ($1/ram$ is an integer) \\
$polysol$ & : & $polynomial$ in $log(xt)$ with formal series in $xt$ coefficients \\
$r$ & : & root of a complex coefficient polynomial (\char`\"{}indicial 
          equation\char`\"{}). \\
\end{tabular}
\end{center}
\ \\
\char`\"{}{\bf standard solution}\char`\"{}~ = $e^{qx} x^{r*ram} polysolx$ \\

$qx$ and $polysolx$ are $q$ and $polysol$ expressions in which $xt$ has been
replaced by $x^{ram}$ \\

N.B. : the form of these solutions is simplified according to the nature of
the point zero.
\begin{itemize}
\item[-] if 0 is a regular singular point : the series appearing in $polysol$ are
         convergent, $ram$ = 1 and $q$ = 0.
\item[-] if 0 is a regular point, we also have : $polysol$ is constant in $log(xt)$
         (no logarithmic terms).
\end{itemize}

\section{INTERACTIVE USE}
\ \\
\begin{tabular}{lcl}
To call the procedure & : & desir(); \\
                      &   & solution:=desir(); \\
\end{tabular}
\ \\
The DESIR procedure computes formal solutions of a linear homogeneous
differential equation in an interactive way. \\
In this equation the variable \emph{must be x}. \\

The procedure requires the order and the coefficients of the equation, the
names of parameters if there are any, then if the user wants to transform
this equation and how ( for example to bring back a singular point to zero
see procedures changehom, changevar, changefonc - ). \par
This procedure DISPLAYS the solutions and RETURNS a list of general term
\{ lcoeff, \{....,\{ general\_solution \},....\}\}. The number of elements in
this list is linked to the number of transformations requested : \\
\begin{tabular}{rl}
{*} & lcoeff : list of coefficients of the differential equation \\
{*} & general\_solution : solution written in the general form \\
\end{tabular}

\section{DIRECT USE}

{\bf procedure delire($x,k,grille,lcoeff,param$);} \\
\ \\
This procedure computes formal solutions of a linear homogeneous differential 
equation with polynomial coefficients over Q and of any order, in the
neighborhood of zero, regular or irregular singular point. In fact it
initializes the call of the NEWTON procedure that is a recursive procedure
(algorithm of NEWTON-RAMIS-MALGRANGE)

\begin{center}
\begin{tabular}{lcp{11cm}}
$x$ & : & variable \\
$k$ & : & \char`\"{}number of desired terms\char`\"{}. \\ 
  &   & For each formal series in $xt$ appearing in $polysol$, \\
  &   & $a_0+a_1 xt+a_2 xt^2+...+a_n xt^n+\ldots$, we compute the
        $k+1$ first coefficients $a_0, a_1,\ldots,a_k.$ \\
$grille$ & : & the coefficients of the differential operator are polynomial in
	     $x^{grille}$ (in general $grille=1$) \\
$lcoeff$ & : & list of coefficients of the differential operator (in increasing
	     order of differentiation) \\
$param$ & : & list of parameters \\
\end{tabular}
\end{center}
\ \\
This procedure RETURNS the list of general solutions.

\section{USEFUL FUNCTIONS}

\subsection{Reading of equation coefficients}

{\bf procedure lectabcoef( );} \\
\ \\
This procedure is called by DESIR to read the coefficients of an equation,
in \emph{increasing order of differentiation}, but can be used independently. \par

reading of n : order of the equation. \\
reading of parameters (only if a variable other than $x$ appears in the
coefficients) \\
this procedure returns the list \{ $lcoeff , param$ \} made up of the list
of coefficients and the list of parameters (which can be empty).

\subsection{Verification of results}

{\bf procedure solvalide($solutions,solk,k$);} \\
\ \\
This procedure enables the validity of the solution number solk in the list
\char`\"{}solutions\char`\"{} to be verified. \\
$solutions$ = \{$lcoeff$,\{....,\{$general\_solution$\},....\}\} is any element
of the list returned by DESIR or is \{$lcoeff,sol$\} where $sol$ is the list 
returned by DELIRE. \\

If we carry over the solution $e^{qx} x^{r*ram} polysolx$ in the equation, the
result has the form $e^{qx} x^{r*ram} reste$, where $reste$ is a polynomial in
$log(xt)$, with polynomial coefficients in $xt$. This procedure computes the
minimal valuation V of $reste$ as polynomial in $xt$, using $k$ \char`\"{}number
of desired terms\char`\"{} asked for at the call of DESIR or DELIRE, and DISPLAYS
the \char`\"{}theoretical\char`\"{} size order of the regular part of the result
: $x^{ram*(r+v)}$. \\

On the other hand, this procedure carries over the solution in the equation
and DISPLAYS the significative term of the result. This is of the form :

\[e^{qx} x^a polynomial(log(xt)), \qquad \mbox{with} \quad a>=ram*(r+v).\]

Finally this procedure RETURNS the complete result of the carry over of the
solution in the equation. \par
This procedure cannot be used if the solution number solk is linked to a
condition.

\subsection{Writing of different forms of results}

{\bf procedure standsol(solutions);} \\
\ \\
This procedure enables the simplified form of each solution to be obtained
from the list \char`\"{}solutions\char`\"{}, \{$lcoeff$,\{...,\{$general\_solution$\},....\}\}
which is one of the elements of the list returned by DESIR, or \{$lcoeff,sol$\} where
$sol$ is the list returned by DELIRE. \par
This procedure RETURNS a list of 3 elements : \{ $lcoeff, solstand, solcond$ \} \\
\ \\
\begin{tabular}{lcp{9cm}}
$lcoef$ & = & list of differential equation coefficients \\
$solstand$ & = & list of solutions written in standard form \\
$solcond$ & = & list of conditional solutions that have not been written
              in standard form. This solutions remain in general form. \\
\end{tabular} \\
\ \\
This procedure has no meaning for \char`\"{}conditional\char`\"{} solutions.
In case, a value has to be given to~ the parameters, that can be done either by 
calling the procedure SORPARAM that displays and returns these solutions in the
standard form, either by calling the procedure SOLPARAM which returns
these solutions in general form. \\
\ \\
{\bf procedure sorsol(sol);} \\
\ \\
This procedure is called by DESIR to write the solution $sol$, given in
general form, in standard form with enumeration of different conditions (if
there are any). \\
It can be used independently.

\subsection{Writing of solutions after the choice of parameters}

{\bf procedure sorparam($solutions,param$);} \\
\ \\
This is an interactive procedure which displays the solutions evaluated :
the value of parameters is requested. \\
\ \\
\begin{tabular}{lcl}
$solutions$ & : & \{$lcoeff$,\{....,\{$general\_solution$\},....\}\} \\
$param$ & : & list of parameters. \\
\end{tabular} \\
\ \\
It returns the list formed of 2 elements :
\begin{itemize}
\item list of evaluated coefficients of the equation
\item list of standard solutions evaluated for the value of parameters.
\end{itemize}

{\bf procedure solparam($solutions,param,valparam$);} \\
\ \\
This procedure evaluates the general solutions for the value of parameters
given by valparam and returns these solutions in general form. \\
\ \\
\begin{tabular}{lcl}
$solutions$ & : & \{$lcoeff$,\{....,\{$general\_solution$\},....\}\} \\
$param$ & : & list of parameters \\
$valparam$ & : & list of parameters values \\
\end{tabular} \\
\ \\
It returns the list formed of 2 elements :
\begin{itemize}
\item list of evaluated coefficients of the equation 
\item list of solutions in general form, evaluated for the value of parameters.
\end{itemize}

\subsection{Transformations}

{\bf procedure changehom($lcoeff,x,secmember,id$);} \\
\ \\
Differentiation of an equation with right-hand side. \\
\ \\
\begin{tabular}{lcl}
$lcoeff$ & : & list of coefficients of the equation \\
$x$ & : & variable \\
$secmember$ & : & right-hand side \\
$id$ & : & order of the differentiation. \\
\end{tabular} \\
\ \\
It returns the list of coefficients of the differentiated equation.
It enables an equation with polynomial right-hand side to be transformed
into a homogeneous equation by differentiating id times,
$id$ = degre($secmember$) + 1. \\
\ \\
{\bf procedure changevar($lcoeff,x,v,fct$);} \\
\ \\
Changing of variable in the homogeneous equation defined by the list,lcoeff
of its coefficients : the old variable $x$ and the new variable $v$ are linked
by the relation $x = fct(v)$. \par

It returns the list of coefficients in respect to the variable $v$ of the new
equation. \par

examples of use : \par

\begin{itemize}
\item[-] translation enabling a rational singularity to be brought back to zero.
\item[-] $x = 1/v$ brings the infinity to 0.
\end{itemize}

{\bf procedure changefonc($lcoeff,x,q,fct$);} \\
\ \\
Changing of unknown function in the homogeneous equation defined by the
list lcoeff of its coefficients : \\
\ \\
\begin{tabular}{lcl}
$lcoeff$ & : & list of coefficients of the initial equation \\
$x$      & : & variable \\
$q$ & : & new unknown function \\
$fct$ & : & $y$ being the unknown function~ $y = fct(q)$ \\
\end{tabular} \\
\ \\
It returns the list of coefficients of the new equation. \par

Example of use : \par

this procedure enables the computation,in the neighbourhood of an irregular
singularity, of the \char`\"{}reduced\char`\"{} equation associated to one
of the slopes (the Newton polygon having a null slope of no null length). 
This equation gives much informations on the associated divergent series.

\subsection{Optional writing of intermediary results}

{\bf switch trdesir} : when it is ON, at each step of the Newton algorithm, a
description of the Newton polygon is displayed (it is possible to follow
the break of slopes), and at each call of the FROBENIUS procedure ( case of
a null slope ) the corresponding indicial equation is displayed. \par

By default, this switch is OFF.

\section{LIMITATIONS}

\begin{enumerate}
\item This DESIR version is limited to differential equations leading
to indicial equations of degree $<=$ 3. To pass beyond this limit, a further
version written in the D5 environment of the computation with algebraic
numbers has to be used.
\item The computation of a basis of solutions for an equation depending on
parameters is assured only when the indicial equations are of degree $<=$ 2.
\end{enumerate}

\section{IMPLEMENTATION}

This software uses the 3.3 version of REDUCE.

\end{document}







mathpiper-0.81f+svn4469+dfsg3/src/packages/solve/desir.tst0000644000175000017500000001072611526203062023504 0ustar  giovannigiovannioff echo;
write
 "Premier exemple: utilisation interactive sur une equation simple";
write "desir();                       %appel de DESIR";
desir();
3;                             %ordre de l'equation
1;x;x;x**6;                    %coefficients
non;                           %correction ?
non;                           %transformation ?
4;                             %nombre de termes a calculer
non;                           %transformation ?
write "solvalide(first ws,1,4);";
solvalide(first ws,1,4);

write "Le meme exemple en utilisation directe";
write "lcoeff:={1,x,x,x**6};";
lcoeff:={1,x,x,x**6};
write "param:={};";
param:={};
write "on trdesir;             %obtention facultative d'une trace";
on trdesir;
showtime;
write "sol:=delire(x,4,1,lcoeff,param);";
sol:=delire(x,4,1,lcoeff,param);
write "showtime;                      %temps d'execution de 'delire'";
showtime;
on div;j:=0$
for each elt in sol do
    <>;
write "solvalide({lcoeff,sol},2,4)$";
solvalide({lcoeff,sol},2,4)$
write "solvalide({lcoeff,sol},3,4)$";
solvalide({lcoeff,sol},3,4)$
off div;
write "off trdesir;";
off trdesir;

write "Deuxieme exemple : utilisation interactive, parametres et";
write "transformations";
write "desir();";
desir();
2;                             %ordre de l'equation
x**2-nu**2;x;x**2;             %coefficients
non;                           %correction ?
1;                             %nombre de parametres
nu;                            %nom du parametre
non;                           %transformation ?
2;                             %nombre de termes a calculer
oui;                           %transformation ?
2;                             %changement de variable
1/v;                           %x=1/v
non;                           %transformation ?
2;                             %nombre de termes a calculer
non$                           %transformation ?
sol:=ws$
write "sol1:=first sol$        %solutions au voisinage de 0";
sol1:=first sol$               %solutions au voisinage de 0
write "sol2:=second sol$       %solutions au voisinage de l'infini";
sol2:=second sol$              %solutions au voisinage de l'infini
write "solvalide(sol1,1,2)$";
solvalide(sol1,1,2)$           %presence de solutions conditionnelles
write "solvalide(sol2,1,2)$";
solvalide(sol2,1,2)$    %la verification de la validite des solutions
                        %au voisinage de l'infini est possible malgre
                        %le parametre (pas de condition).
write
 "Remarque : la verification de la validite des solutions est possible";
write "malgre la presence d'un parametre (pas de condition).";
write "standsol(sol1);                %=sol1...sans interet!";
standsol(sol1);                %=sol1...
write "standsol(sol2);      %solutions retournees sous forme standard.";
standsol(sol2);
write "Pour revoir les solutions au voisinage de 0 :";
j:=0$
write "for each elt in second sol1 do";
write "          <>;";
for each elt in second sol1 do
          <>;
write
"Evaluation des solns au voisinage de 0 pour une valeur particuliere";
write "du parametre :";
write "sorparam(sol1,{nu});%evaluation des solutions au voisinage de 0";
write "                 %pour une valeur particuliere du parametre";
write "                 %nu = 1";
write "                 %ecriture et retour des solutions sous forme";
write "                 %standard";
sorparam(sol1,{nu});    %evaluation des solutions au voisinage de 0
                        %pour une valeur particuliere du parametre
1;                      %valeur de nu
                        %ecriture et retour des solutions sous forme
                        %standard
write "solparam(sol1,{nu},{1});";
solparam(sol1,{nu},{1}); %meme fonction avec retour des solutions sous
                         %forme generalisee, ce qui permet d'enchainer
write "Meme fonction avec retour des solutions sous forme generalisee,";
write "ce qui permet d'enchainer :";
write "solvalide(ws,1,2)$";
solvalide(ws,1,2)$

write
 "L'exemple suivant a ete cree specialement pour tester l'algorithme";
write "et utiliser un grand nombre de procedures :";
lcoeff:={x+1,2*x**2*(x+1),x**4,(5*x**7)/2,x**10};
param:={};
showtime;
write "sol:=delire(x,4,1,lcoeff,param);";
sol:=delire(x,4,1,lcoeff,param)$
showtime;
on div;j:=0$
for each elt in sol do
    <>;
solvalide({lcoeff,sol},1,4)$
solvalide({lcoeff,sol},3,4)$
off div;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/0000755000175000017500000000000011722677362022035 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/inspect.red0000644000175000017500000004300411526203062024157 0ustar  giovannigiovannimodule inspect;   % Rlisp88 Code inspector.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%  Author: Jed Marti.

%  Description: Formats and displays the active annotation associated
%   with various RLISP data structures.
%  Notes: Things left to work on:
%    DEFINE constants.
%    SWITCH
%    CLASS, instances, scripts, etc.
%    The line numbers are pretty much the input expression numbers
%    (where comments are counted). Fixing this would require a
%    modification to the RLISP lexical scanner.
%  Dependencies:
%  Revision History: (Created Fri Jan  3 08:40:29 1992)
%    Wed Feb 26 09:39:28 1992 Add file/line numbers to functions.
%          Upgrade comments.
%    Sun Mar  1 11:09:30 1992 Try GLOBAL and FLUID declarations. Also
%          clear COMMENT!* after each use.
%    Fri Mar 13 17:28:41 1992 Add the comment reformatting routine
%          fmtcmt.
%    Fri Oct  8 12:06:00 1993 Fix use if ifl!*, remove printf's. Make
%      work with old RLISP syntax first.  No active comments in this
%      code.

expr procedure describe x;
   % DESCRIBE(X) -- Inspect any data structure X. This main routine
   % farms out the work accordingly.
   if pairp x then << prin2t "A dotted-pair or list"; nil >>
    else if vectorp x then
     if i!&recordinstp x then i!&recordinst x
      else  <>
   else if codep x then <>
   else if numberp x then
      if fixp x then <>
      else if floatp x then <>
      else <>
   else if stringp x then <>
   else if idp x then
     if i!&recordp x then i!&record x
     else if i!&functionp x then i!&function x
     else if i!&constantp x then i!&constant x
     else if i!&modulep x then i!&module x
     else if get(x, 'newnam) then i!&idnewnam x
     else i!&id x
   else <>;

expr procedure i!&idnewnam x;
   % I!&IDNEWNAM(X) - This is the result of a define.
   <>;

expr procedure i!&recordp x;
   % I!&RECORDP(X) -- X is an id. Returns T if this looks like an RLISP
   % record.
   get(x,'formfn) eq 'form!_record!_constructor;

expr procedure i!&record x;
% I!&RECORD(X) -- X is an id and the name of a record constructor. Try
%  and display as much about the record as possible. Note that record
%  instances are handled by the vector case temporarily.
<< prin1 x; prin2t " is a record constructor with the following fields";
   prin2t "** not implemented. **";
   nil >>;

expr procedure i!&recordinstp x;
% I!&RECORDINSTP(X) -- Returns T if X (a vector) looks like a record
% instance.
begin scalar tmp;
  if not idp getv(x,0) then return nil;
  if not (tmp :=  getd getv(x,0)) then return nil;
  if not eqcar(getd getv(x,0),'macro) then return nil;
  if atom (tmp := errorset({getv(x,0)},nil,nil)) then return nil;
  if upbv x neq upbv car tmp then return nil;
  return t
end;

expr procedure i!&recordinst x;
% x is identified as a record.
<< prin2 "A "; prin1 getv(x,0); prin2t " record with ";
   for i:=1:upbv x
       do << prin2 "   "; prin1 i; prin2 ": "; print getv(x,i)>>;
   nil >>;

expr procedure i!&functionp x;
% I!&FUNCTIONP(X) -- X is an id. Returns T if it is also the name of a
%  function or SMACRO.
get(x, 'smacro) or getd x;

expr procedure i!&function x;
% I!&FUNCTION(X) - X is a function or SMACRO name. Farm out the
%  description based on its type.
if get(x, 'smacro) then i!&function!-smacro x
 else (if eqcar(w, 'macro) then i!&function!-macro(x, cdr w)
       else if eqcar(w, 'expr) then i!&function!-expr(x, cdr w)
       else if eqcar(w, 'fexpr) then i!&function!-fexpr(x, cdr w)
       else i!&function!-unknown(x, w)) where w := getd x;

expr procedure i!&function!-smacro x;
% I!&FUNCTION!-SMACRO(X) -- X is the name of an SMACRO. Display what we
%  know about it.
begin scalar tmp, d;
  d := get(x, 'smacro);
  prin1 x; prin2 " is an SMACRO with ";
  if not (tmp := get(x, 'number!-of!-args)) then
   if eqcar(d, 'lambda) and cdr d then tmp := length cadr d
   else tmp := nil;
  if onep tmp then prin2t "one argument"
    else if not tmp then prin2t "an unknown number of arguments"
    else << prin1 tmp; prin2t " arguments" >>;
  if tmp := get(x, 'active!-annotation) then
     << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp>>
end;


expr procedure i!&function!-expr(x, d);
%  I!&FUNCTION!-EXPR(X, D) -- X is the name of an EXPR type function and
%  D is it's definition. Display what we know about it.
begin scalar tmp;
  prin1 x; prin2 " is an EXPR with ";
  if not (tmp := get(x, 'number!-of!-args)) then
   if eqcar(d, 'lambda) and cdr d then tmp := length cadr d
   else tmp := nil;
  if onep tmp then prin2t "one argument"
    else if not tmp then prin2t "an unknown number of arguments"
    else << prin1 tmp; prin2t " arguments" >>;
  if tmp := get(x, 'active!-annotation) then
     << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >>
end;


expr procedure i!&function!-fexpr(x, d);
%  I!&FUNCTION!-FEXPR(X, D) -- X is the name of an FEXPR type function
%  and D is its definition. Display what we know about it.
begin scalar tmp;
  prin1 x; prin2t " is an FEXPR";
  if tmp := get(x, 'active!-annotation) then
     << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >>
end;


expr procedure i!&function!-macro(x, d);
% I!&FUNCTION!-MACRO(X, D) -- X is the name of a MACRO type function and
%  D its definition. Display what we know.
begin scalar tmp;
  prin1 x; prin2t " is a MACRO";
  if tmp := get(x, 'active!-annotation) then
     << i!&whereis tmp; i!&dump if pairp tmp then car tmp else tmp >>
end;


expr procedure i!&whereis x;
% I!&WHEREIS(X) -- We might have a (comment line-number file). If so,
%  display this information.
if length x = 3 then
  << prin2 "Function ends on line "; prin1 cadr x;
     prin2 " in file "; prin2t caddr x >>;


expr procedure i!&constantp x;
% I!&CONSTANTP(X) - Returns T if X is a constant.
  constantp x;

expr procedure i!&id x;
% I!&ID(X) -- X is an id see if we can find out anything about it.
if globalp x then i!&id1(x, 'global)
 else if fluidp x then i!&id1(x, 'fluid)
 else << prin2 "Don't know anything about "; print x; nil >>;

expr procedure i!&id1(x, ty);
% I!&ID1(X, TY) -- X is TY (global or fluid). Print out what we know
%  about this id.
begin scalar a;
  prin2 "Identifier '"; prin1 x; prin2 "' is "; prin2 ty;
  if a := get(x, 'active!-annotation) then
    if length a = 3 then
       << prin2 " defined line "; prin1 cadr a;
          prin2 " in file "; prin2t caddr a;
          i!&dump car a >>
    else i!&dump a
  else terpri()
end;

expr procedure i!&constant x;
% I!&CONSTANT(X) - X is some sort of constant. Not much we can say about
% it.
   <>;

expr procedure i!&modulep x;
% I!&MODULEP(X) - Returns T if x looks like a module.
flagp(x, 'module);

expr procedure i!&module x;
% I!&MODULE(X) - Display the facts about a module.
(if filep r88 then  i!&module1(x, i!&moduleb x, r88)
  else if filep rd then i!&module1(x, i!&moduleb x, rd)
  else i!&module2 x)
where r88 := string!-downcase
                compress nconc('!" . explode2 x, '(!. !r !8 !8 !")),
      rd := string!-downcase
                compress nconc('!" . explode2 x, '(!. !r !e !d !"));


expr procedure i!&module1(mname, bfile, sfile);
% I!&MODULE(MNAME, BFILE, SFILE) - Display data about module MNAME
%  with object file BFILE, source file SFILE. PSL/UNIX specific.
begin scalar sfs, bfs;
  if sfile then sfs := filestatus sfile;
  if bfile then bfs := filestatus bfile;
  if sfile then
     if bfile then
      << prin2 "Module ";
         prin1 mname;
         prin2 " source file ";
         prin2 sfile;
         prin2 " fasl file ";
         prin2 bfile;
         prin2 " and is ";
         print i!&dcomp(sfs, bfs) >>
     else
      << prin2 "Module ";
         prin1 mname;
         prin2 " has source file ";
         prin2 sfile;
         prin2 " written ";
         prin2t i!&sdt sfs >>
  else if bfile then
     << prin2 "Module ";
        prin1 mname;
        prin2 " has fasl file ";
        prin2 bfile;
        prin2 " written ";
        prin2t i!&sdt bfs >>
  else
   << prin2 "Module ";
      prin1 mname;
      prin2t ", can't find any files." >>;
  if sfs := get(mname, 'active!-annotation) then
    if pairp sfs then i!&dump car sfs else i!&dump sfs;
end;


expr procedure i!&module2 mname;
% I!&MODULE2(MNAME) - called when we don't know much about a module.
<< prin2 "Can't find source or fasl file for module ";
   print mname;
   if sfs then if pairp sfs then i!&dump car sfs else i!&dump sfs >>
        where sfs := get(mname, 'active!-annotation);


expr procedure i!&dcomp(s1, s2);
% I!&DCOMP(S1, S2) -- two PSL file statuses. Compare the WRITETIMES
%  and return " OUT OF DATE." or " UP TO DATE.".
if i!&dt s1 > i!&dt s2 then " out of date." else " up to date.";

expr procedure i!&dt x;
(if w then cddr w else 0) where w := atsoc('writetime, x);

expr procedure i!&sdt x;
(if w then cadr w else "no date") where w := atsoc('writetime, x);

expr procedure i!&moduleb x;
% I!&MODULEB(X) - Find which directory LOADDIRECTORIES!* the .b file
%  is and return the file name.
begin scalar fs, fn;
  fs := loaddirectories!*
  while pairp fs
   do << fn := string!-downcase
                nconc('!" . explode2 car fs,
                      nconc(explode2 x, '(!. !b !")));
         if filep fn then fs := fn
           else fs := cdr fs >>;
  return fs
end;


%-----------------------------------------------------------------------
% Basic active comment formatting. Remove the leading blank from the
% first line, all blanks at start of each subsequent line, but only
% of the shortest line.

expr procedure i!&dump x;
% I!&DUMP(X) - X is a string or something. Display its characters but
%  dump blanks at the beginning of each line as appropriate.
begin scalar lnes, minsp, v;
  lnes := reversip i!&makelines(explode2 x, {nil});
  minsp := 5000;
  for each x in cdr lnes do
      if (v:= i!&spcount x) < minsp then minsp := v;
  i!&prn i!&delspace(5000, car lnes);
  for each l in cdr lnes do i!&prn i!&delspace(minsp, l)
end;

expr procedure i!&makelines(x, l);
%  I!&MAKELINES(X, L) -- Remove EOL's form x and convert to a list of
% sentences. L is used to build this list, call this with L = NIL.
  if null x then reversip car l . cdr l
   else if eqcar(x, !$eol!$) then
        i!&makelines(cdr x, nil . (reversip car l . cdr l))
   else << car l := car x . car l; i!&makelines(cdr x, l) >>;

expr procedure i!&spcount l;
% I!&SPCOUNT(l) -- Count spaces in front of line l and return.
if null l then 0
  else if eqcar(l, '! ) then add1 i!&spcount cdr l
  else 0;

expr procedure i!&delspace(n, l);
%  I!&DELSPACE(N, L) -- Delete n spaces from the front of line L and
%  return a new list. Quit if the list is short or runs into some
%  non-blank character.
if null l then nil
  else if zerop n then l
  else if eqcar(l, '! ) then i!&delspace(n - 1, cdr l)
  else l;

expr procedure i!&prn x;
% I!&PRN(x) -- Display the characters of list x and then terminate the
%  line.
<< for each c in x do prin2 c;
   terpri() >>;


%-----------------------------------------------------------------------
% Hacks to make active comments work.

fluid '(!*saveactives);
switch saveactives;


expr procedure i!&makeComment;
% I!&MAKECOMMENT() - returns (comment line file) for packing active
%  annotation data away.
mkquote {cadr Comment!*, curline!*,
         if ifl!* then car ifl!* else "unknown"};


expr procedure nformproc(a, b, c);
% NFORMPROC(A, B, C) -- Temporary wrapper for FORMPROC to save the
%  function active annotation if the SAVEACTIVES switch is on. Also
%  put the file name and current line out there.
begin scalar v,w;
  v := if !*saveactives and comment!* then
      <>
        else formproc(a, b, c);
  comment!* := nil;
  return v
end;

put('procedure,'formfn,'nformproc);


expr procedure formmodule(u, vars, mode);
% FORMMODULE(U,VARS,MODE) - Save any active annotation on the property
%  of the module. Clear comment after use.
begin scalar x;
  x := if !*saveactives and Comment!* then
     {'progn, {'cond, {'!*saveactives,
                       {'put, mkquote cadr u,
                         mkquote 'active!-annotation,
                         i!&makecomment()}}},
              {'flag, mkquote {cadr u}, mkquote 'MODULE},
              {'module, mkquote{cdr u}}}
  else {'module, mkquote cdr u};
  Comment!* := nil;
  return x
end;

% put('module, 'formfn, 'formmodule);


expr procedure formglobalfluid(u, vars, mode);
% FORMGLOBALFLUID(U, VARS, MODE) -- Attach active annotation to the
%  variables declared.
if !*saveactives and Comment!* then
 {{'lambda, {'!$v!$},
     {'progn,
       {'cond, {'!*saveactives,
                {'mapcar, '!$v!$,
                   {'function,
                     {'lambda, {'!$u!$}, {'put, '!$u!$,
                                           mkquote 'active!-annotation,
                                           i!&makeComment()}}}}}},
       {car u, '!$v!$}}}, formc(cadr u, vars, mode)}
 else {car u, formc(cadr u, vars, mode)};

% put('global, 'formfn, 'formglobalfluid);

% put('fluid, 'formfn, 'formglobalfluid);


expr procedure fmtcmt(ano, ind, rm);
begin scalar la, ind3, tcs, c, coll, colle, curbl, cbl;
  la := explode2 ano;
  if (ind3 := ind + 3) > (rm - 10) then error(0, "margins too small");
  tcs := rm - ind3;

  % Remove extra blanks from front.
%  la := deblank la;

  % STATE 1: Now scan the lines dumping tokens to the output.
  spaces ind;
  prin2 "/* ";
loop: if null la then return prin2 " */";
  if c := fmtfulllineof(car la, la) then
     << la := fmtremoveline la;
        for i:=1:tcs do prin2 c;
        terpri();
        spaces ind3;
        go to loop >>
  else if fmtblankline la then
     << if posn() > ind3 then terpri();
        terpri();
        spaces ind3;
        la := fmtremoveline la;
        go to loop >>
  else if eqcar(la, !$eol!$) then
     << terpri(); spaces ind3;go to loop >>
  else if eqcar(la, '! ) then go to state4;

  % STATE 2: Collect characters to EOL, blank, or NIL.
state2: coll := colle := {car la};
  la := cdr la;

state2a: if null la then
       << fmtdumptok(coll, ind3, rm);
          go to loop >>
    else if eqcar(la, !$eol!$) then
       << fmtdumptok(coll, ind3, rm);
          la := cdr la;
          go to loop >>
    else if eqcar(la, '! ) then
       << fmtdumptok(coll, ind3, rm);
          go to state3 >>;
    cdr colle := {car la};
    colle := cdr colle;
    la := cdr la;
    go to state2a;

  % STATE 3: Skip blanks to NIL, EOL, or next token.
state3: if null la then go to loop
     else if eqcar(la, !$eol!$) then << la := cdr la; go to loop >>
     else if eqcar(la, '! ) then << la := cdr la; go to state3 >>
     else go to state2;


  % STATE 4: We've got a line that starts with a blank. Dump it to the
  % output line.
state4: curbl := 0; cbl := t;
state4a: prin2 car la;
  if cbl and eqcar(la, '! ) then curbl := add1 curbl else cbl := nil;
  la := cdr la;
  if null la then go to loop;
  if eqcar(la, !$eol!$) then
    << terpri(); spaces ind3;la := cdr la; go to loop >>;
  if posn() >= rm then << terpri(); spaces(1 + ind3 + curbl) >>;
  go to state4a
end;



expr procedure fmtblankline l;
% FMTBLANKLINE(L) -- returns T if the rest of the current line is
%  all blanks.
if null l or eqcar(l, !$eol!$) then t
  else if eqcar(l, '! ) then fmtblankline cdr l;


expr procedure fmtfulllineof(c, la);
% FMTFULLLINEOF(C, LA) -- Returns C if LA up to the end or !$EOL!$ is
%  all one character.
if null la then c
  else if eqcar(la, c) then fmtfulllineof(c, cdr la)
  else if eqcar(la, !$eol!$) then c
  else nil;



expr procedure fmtremoveline la;
% FMTREMOVELINE(LA) -- returns the remainder of LA up to the end or the
%  first !$EOL!$.
if la and not eqcar(la, !$eol!$) then fmtremoveline cdr la else cdr la;


expr procedure fmtdumptok(l, ind, rm);
if (length l + posn()) > rm then
  << terpri(); spaces ind; for each x in l do prin2 x; prin2 " " >>
else << for each x in l do prin2 x;
        if posn() <= rm then prin2 " " >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/rlisp88.red0000644000175000017500000001060411526203062024023 0ustar  giovannigiovannimodule rlisp88;   % Support for the RLISP '88 superset.

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*minusliter !*mode !*oldminusliter !*rlisp88 forbinops!*
        oldmode!*);

switch rlisp88;

create!-package('(rlisp88 for88 loops88 bquote comment rvector mstruct
                  records inspect),
                '(rlisp));

symbolic procedure rlisp88_on;
   begin
      if !*rlisp88 then return nil;
      !*rlisp88 := t;
      !*oldminusliter := !*minusliter;
      !*minusliter := t;
      deflist('((module formmodule) (global formglobalfluid)
                (fluid formglobalfluid) (procedure nformproc)),
              'formfn);
      remprop('join,'newnam);
      put('conc,'newnam,'join);
      put('oldwhen,'infix,get('when,'infix));
      remprop('when,'infix);
      flag('(for),'nochange);   % Check on this.
      deflist(forbinops!*,'bin);
      deflist('((for forstat88) (repeat repeatstat88)
                (while whilstat88)),'stat);
      deflist('((for formfor88) (repeat formrepeat88)
                (while formwhile88)),'formfn);
      copyd('for,'for88);
      copyd('oldrepeat!*,'repeat);
      remd 'repeat;
      copyd('repeat,'repeat88);
      copyd('oldwhile!*,'while);
      remd 'while;   % To avoid messages.
      copyd('while,'while88);
      if not(!*mode eq 'symbolic)
        then <>;
      deflist('((array rlis) (def rlis) (index rlis)),'stat);
      put('array,'formfn,'formarray);
      put('add,'number!-of!-args,2);
      put('add,'smacro,'(lambda (u v) (cons u v)))
   end;

put('rlisp88,'simpfg,'((t (rlisp88_on)) (nil (rlisp88_off))));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/rvector.red0000644000175000017500000000767711526203062024216 0ustar  giovannigiovannimodule rvector; % Definition of RLISP vectors and operations on them.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*fastvector);

global '(cursym!*);

switch fastvector;

% Add to system table.

flag('(vec!*),'vecfn);

% Parsing interface.

symbolic procedure xreadvec;
   % Expects a list of expressions enclosed by [, ].
   begin scalar cursym,delim,lst;
        if scan() eq '!*rsqb!* then <>;
    a:      lst := aconc(lst,xread1 'group);
        cursym := cursym!*;
        scan();
        if cursym eq '!*rsqb!*
          then return if delim eq '!*semicol!* then 'progn . lst
                       else list('vec!*,'list . lst)
         else if null delim then delim := cursym
         else if not(delim eq cursym)
          then symerr("Syntax error: mixed , and ; in vector",nil);
        go to a
   end;

put('!*lsqb!*,'stat,'xreadvec);

newtok '((![) !*lsqb!*);

newtok '((!]) !*rsqb!*);

flag('(!*rsqb!*),'delim);

flag('(!*rsqb!*),'nodel);

symbolic procedure vec!* u;
   % Make a vector out of elements of u.
   begin scalar n,x;
      n := length u - 1;
      x := mkvect n;
      for i:= 0:n do <>;
      return x
   end;

% Evaluation interface.

% symbolic procedure setv(u,v);
%   <>;


% Length interface.


% Printing interface.


% Definitions of operations on vectors.

symbolic procedure getvect(u,vars,mode);
   expandgetv(symbid(car u,vars),formlis(evalvecarg cdr u,vars,mode));

symbolic procedure expandgetv(u,v);
   if null v then u
    else expandgetv(list(if !*fastvector then 'igetv else 'getv,
                         u,car v),
                    cdr v);

symbolic procedure putvect(u,vars,mode);
   expandputv(symbid(caar u,vars),formlis(evalvecarg cdar u,vars,mode),
              form1(cadr u,vars,mode));

symbolic procedure expandputv(u,v,w);
   if null cdr v
     then list(if !*fastvector then 'iputv else 'putv,u,car v,w)
    else expandputv(list(if !*fastvector then 'igetv else 'getv,
                         u,car v),
                    cdr v,w);

symbolic procedure evalvecarg u;
%   if u and null cdr u and vectorp car u
%     then for i:=0:upbv car u collect getv(car u,i) else
   if u and null cdr u and eqcar(car u,'vec!*)
       and eqcar(cadar u,'list)
     then cdadar u
    else u;

% Support for arrays defined in terms of vectors.

symbolic procedure mkar1 u;
   begin scalar x;
      x := mkvect car u;
      if cdr u then for i:= 0:upbv x do putv(x,i,mkar1 cdr u);
      return x
   end;

symbolic macro procedure array u;
   % Create an array from the elements in u.
   list('vec!*,'list . cdr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/rlisp88.tst0000644000175000017500000023333511526203062024073 0ustar  giovannigiovanni% Test of Rlisp88 version of Rlisp. Many of these functions are taken
% from the solved exercises in the book "RLISP '88: An Evolutionary
% Approach to Program Design and Reuse".

% Author: Jed B. Marti.

on rlisp88;

% Confidence test tries to do a little of everything. This doesn't really
% test itself so  you need to compare to the log file. Syntax errors on
% the other hand should be cause for alarm.

%                             ARRAYS
% 1. Single dimension array.
global '(v1);
v1 := mkarray 5;
for i:=0:5 do v1[i] := 3**i;
v1;


% 2. 2D array.
global '(v3x3);
v3x3 := mkarray(2, 2);
for row := 0:2 do
  for col := 0:2 do
     v3x3[row, col] := if row = col then 1.0 else 0.0;
v3x3;

% 3. Triangular array.
global '(tri);
tri := mkarray 3;
for row := 0:3 do tri[row] := mkarray row;
for row := 0:3 do
  for col := 0:row do
     tri[row,col] := row * col;
tri;

% 4. ARRAY test.
expr procedure rotate theta;
/* Generates rotation array for angle theta (in radians) */
array(array(cosd theta, - sind theta, 0.0),
      array(sind theta, cosd theta, 0.0),
      array(0.0, 0.0, 1.0));
rotate 45.0;

% 5. Random elements.
% Now create a vector with random elements.
M3 := ARRAY('A, 3 + 4, ARRAY("String", 'ID), '(a b));
M3[2, 1];
M4 := ARRAY(ARRAY('a, 'b), ARRAY('c, 'd));
M4[1];

% 6. Array addition.
expr procedure ArrayAdd(a, b);
if vectorp a then
    for i:=0:uc
        with c, uc
        initially c :=  mkarray(uc := upbv a)
        do c[i] := ArrayAdd(a[i], b[i])
        returns c
  else a + b;
ArrayAdd(array(array(array(1, 2), array(3, 4)),
               array(array(5, 6), array(7, 8))),
         array(array(array(1, 1), array(2, 2)),
               array(array(3, 3), array(4, 4))));

%                               RECORDS
% 1: Declaration.
RECORD MAPF  /* A MAPF record defines
               the contents of a MAPF file. */
  WITH 
  MAPF!:NAME := ""        /* Name of MAPF (a string) */,
  MAPF!:NUMBER := 0       /* MAPF number (integer) */,
  MAPF!:ROAD-COUNT := 0   /* Number of roads */,
  MAPF!:NODE-COUNT := 0   /* Number of nodes */,
  MAPF!:LLAT := 0.0       /* Lower left hand corner map latitude */,
  MAPF!:LLONG := 0.0      /* Lower left hand corner map longitude */,
  MAPF!:ULAT := 0.0       /* Upper right hand corner map latitude */,
  MAPF!:ULONG := 0.0      /* Upper right hand corner map longitude */;

% 2: Creation.
global '(r1 r2 r3);
r1 := mapf();
r2 := mapf(mapf!:name := "foobar", mapf!:road-count := 34);
r3 := list('a . r1, 'b . r2);

% 3: Accessing.
mapf!:number r1;
mapf!:road-count cdr assoc('b, r3);

% 4: Assignment.
mapf!:number r1 := 7622;
mapf!:road-count cdr assoc('b, r3) := 376;
mapf!:node-count(mapf!:name r2 := mapf()) := 34;
r2;


% 5. Options.
RECORD complex /* Stores complex reals */
  WITH
   R := 0.0  /* Real part */,
   I := 0.0  /* Imaginary part */
  HAS CONSTRUCTOR;
Make-Complex(I := 34.0, R := 12.0);

RECORD Rational /* Representation of rational numbers */
  WITH
    Num := 0  /* Numerator */,
    Den := 1  /* Denominator */
  HAS CONSTRUCTOR = rat;

expr procedure gcd(p, q);
if q > p then gcd(q, p)
else (if r = 0 then q else gcd(q, r)) where r = remainder(p,q);

expr procedure Rational(a, b);
/* Build a rational number in lowest terms */
  Rat(Num := a / g, Den := b / g) where g := gcd(a, b);
Rational(34, 12);


RECORD Timing /* Timing Record for RLISP test */
  WITH
    Machine := ""    /* Machine name */,
    Storage := 0     /* Main storage in bits */,
    TimeMS = 0       /* Test time in milliseconds */
  HAS NO CONSTRUCTOR;



% PREDICATE option.
RECORD History /* Record of an event */
  WITH
    EventTime := 0.0   /* Time of event (units) */,
    EventData := NIL   /* List with (type ...) */
  HAS PREDICATE = History!?;

History!? History(EventData := '(MOVE 34.5 52.5));


%                            FOR LOOP
% 1) Basic test.
EXPR PROCEDURE LPRINT lst;
/* LPRINT displays each element of its argument separated by blanks.
   After the last element has been displayed, the print line is
   terminated. */
FOR EACH element IN lst 
    DO << PRIN2 element; PRINC " " >>
    FINALLY TERPRI()
    RETURNS lst;
LPRINT '(Now is the time to use RLISP);

% 2) Basic iteration in both directions.
FOR i:=5 STEP -2 UNTIL 0 DO PRINT i;
FOR i:=1:3 DO PRINT i;

% 3) COLLECT option.
FOR EACH leftpart IN '(A B C)
    EACH rightpart IN '(1 2 "string")
    COLLECT leftpart . rightpart;

% 4) IN/ON iterators.
FOR EACH X IN '(a b c) DO PRINT x;
FOR EACH x ON '(a b c) DO PRINT x;


% 5) EVERY option.
FOR EACH x IN '(A B C) EVERY IDP x
    RETURNS "They are all id's";
FOR EACH x IN '(A B 12) EVERY IDP x
    RETURNS "They are all id's";

% 6) INITIALLY/FINALLY option.
EXPR PROCEDURE ListPrint x;
/* ListPrint(x) displays each element of x separated by blanks. The
   first element is prefixed with "*** ". The last element is suffixed
   with a period and a new line. */
FOR EACH element ON x 
    INITIALLY PRIN2 "*** "
    DO << PRIN2 CAR element;
          IF CDR element THEN PRIN2 " " >>
    FINALLY << PRIN2 "."; TERPRI() >>;
ListPrint '(The quick brown bert died);


% 7) MAXIMIZE/MINIMIZE options.
FOR EACH x IN '(A B 12 -34 2.3)
    WHEN NUMBERP x
    MAXIMIZE x;
FOR EACH x IN '(A B 12 -34 2.3)
    WHEN NUMBERP x
    MINIMIZE x;


% 8) RETURNS option.
EXPR PROCEDURE ListFiddle(f, x);
/* ListFiddle displays every element of its second argument and returns
   a list of those for which the first argument returns non-NIL. */
FOR EACH element IN x
   WITH clist
   DO << PRINT element;
         IF APPLY(f, LIST element) THEN clist := element . clist >>
   RETURNS REVERSIP clist;
ListFiddle(FUNCTION ATOM, '(a (BANG 12) "OOPS!"));


% 9) SOME option.
FOR EACH x IN '(a b 12) SOME NUMBERP x
    DO PRINT x;

% 10) UNTIL/WHILE options.
EXPR PROCEDURE CollectUpTo l;
/* CollectUpTo collect all the elements of the list l up to the
   first number. */
FOR EACH x IN l UNTIL NUMBERP x COLLECT x;
CollectUpTo '(a b c 1 2 3);

% 11) WHEN/UNLESS options.
FOR EACH x IN '(A 12 "A String" 32)
    WHEN NUMBERP x
    COLLECT x;


% ##### Basic Tests #####
% Tests some very basic things that seem to go wrong frequently.

% Numbers.
if +1 neq 1 then error(0, "+1 doesn't parse");
if -1 neq - 1 then error(0, "-1 doesn't parse");

expr procedure factorial n;
if n < 2 then 1 else n * factorial(n - 1);

if +2432902008176640000 neq factorial 20 then 
    error(0, "bignum + doesn't work");
if -2432902008176640000 neq - factorial 20 then
    error(0, "bignum - doesn't work");

% This actually blew up at one time.
if -3.14159 neq - 3.14159 then error(0, "negative floats don't work");
if +3.14159 neq 3.14159 then error(0, "positive floats don't work");


% ##### Safe Functions #####

% Description: A set of CAR/CDR alternatives that
%    return NIL when CAR/CDR of an atom is tried.

expr procedure SafeCar x;
/* Returns CAR of a list or NIL. */
if atom x then nil else car x;

expr procedure SafeCdr x;
/* Returns CDR of a list or NIL. */
if atom x then nil else cdr x;

expr procedure SafeFirst x; SafeCar x;
expr procedure SafeSecond x; SafeCar SafeCdr x;
expr procedure SafeThird x; SafeSecond SafeCdr x;


% ##### Test of Procedures #####

%------------------------- Exercise #1 -------------------------

expr procedure delassoc(x, a);
/* Delete the element from x from the alist a non-destructively. Returns
 the reconstructed list. */
if null a then nil
  else if atom a then a . delassoc(x, cdr a)
  else if caar a = x then cdr a
  else car a . delassoc(x, cdr a);


if delassoc('a, '((a b) (c d))) = '((c d)) 
   then "Test 1 delassoc OK"
   else error(0, "Test 1 delassoc failed");

if delassoc('b, '((a b) (b c) (c d))) = '((a b) (c d))
   then "Test 2 delassoc OK"
   else error(0, "Test 2 delassoc failed");

if delassoc('c, '((a b) (b c) (c d))) = '((a b) (b c))
   then "Test 3 delassoc OK"
   else error(0, "Test 3 delassoc failed");

if delassoc('d, '((a b) (b c) (c d))) = '((a b) (b c) (c d))
   then "Test 4 delassoc OK"
   else error(0, "Test 4 delassoc failed");


%------------------------- Exercise #2 -------------------------
expr procedure gcd(u, v);
if v = 0 then u else gcd(v, remainder(u, v));

if gcd(2, 4) = 2 then "Test 1 GCD OK" else error(0, "Test 1 GCD fails");
if gcd(13, 7) = 1
  then "Test 2 GCD OK" else error(0, "Test 2 GCD fails");
if gcd(15, 10) = 5
  then "Test 3 GCD OK" else error(0, "Test 3 GCD fails");
if gcd(-15, 10) = -5
  then "Test 4 GCD OK" else error(0, "Test 4 GCD fails");
if gcd(-15, 0) = -15
  then "Test 5 GCD OK" else error(0, "Test 5 GCD fails");


%-------------------- Exercise #3 --------------------
expr procedure properintersection(a, b);
/* Returns the proper intersection of proper sets a and b.
  The set representation is a list of elements with the
  EQUAL relation. */
if null a then nil
  else if car a member b then car a . properintersection(cdr a, b)
  else properintersection(cdr a, b);

% Test an EQ intersection.
properintersection('(a b), '(b c));
if properintersection('(a b), '(b c)) = '(b)
     then "Test 1 properintersection OK"
     else error(0, "Test 1 properintersection fails");

% Test an EQUAL intersection.
properintersection('((a) b (c)), '((a) b (c)));
if properintersection('((a) b (c)), '((a) b (c))) = '((a) b (c))
     then "Test 2 properintersection OK"
     else error(0, "Test 2 properintersection fails");

% Test an EQUAL intersection, out of order.
properintersection('((a) b (c)), '(b (c) (a)));
if properintersection('((a) b (c)), '(b (c) (a))) = '((a) b (c))
     then "Test 3 properintersection OK"
     else error(0, "Test 3 properintersection fails");

% Test an empty intersection.
properintersection('((a) b (c)), '(a (b) c));
if properintersection('((a) b (c)), '(a (b) c)) = nil
     then "Test 4 properintersection OK"
     else error(0, "Test 4 properintersection fails");



%-------------------- Exercise #4 -------------------------

expr procedure TreeVisit(a, tree, c);
/* Preorder visit of tree to find a. Returns path from root. c
  contains path to root of tree so far. */
if null tree then nil
  else if a = car tree then append(c, {a})
  else TreeVisit(a, cadr tree, append(c, {car tree})) or
       TreeVisit(a, caddr tree, append(c, {car tree}));

TreeVisit('c, '(a (b (d nil nil) (c nil nil)) (e nil nil)), nil);
if TreeVisit('c, '(a (b (d nil nil) (c nil nil)) (e nil nil)), nil)
             = '(a b c)
     then "Test 1 TreeVisit OK"
     else error(0, "Test 1 TreeVisit fails");

TreeVisit('h, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil);
if TreeVisit('h, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil))),nil) = '(a e g h)
     then "Test 2 TreeVisit OK"
     else error(0, "Test 2 TreeVisit fails");

if TreeVisit('i, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = nil
     then "Test 3 TreeVisit OK"
     else error(0, "Test 3 TreeVisit fails");

if TreeVisit('a, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = '(a)
     then "Test 4 TreeVisit OK"
     else error(0, "Test 4 TreeVisit fails");

if TreeVisit('e, '(a (b (d nil nil) (c nil nil))
                  (e (f nil nil) (g (h nil nil) nil)) ), nil) = '(a e)
     then "Test 5 TreeVisit OK"
     else error(0, "Test 5 TreeVisit fails");


%-------------------- Exercise #5 ------------------------- 

expr procedure lookfor(str, l);
/* Search for the list str (using =) in the top level
   of list l. Returns str and remaining part of l if
   found. */
if null l then nil
  else if lookfor1(str, l) then l
  else lookfor(str, cdr l);

expr procedure lookfor1(str, l);
if null str then t
  else if null l then nil
  else if car str = car l then lookfor1(cdr str, cdr l);


if lookfor('(n o w),'(h e l l o a n d n o w i t i s)) = '(n o w i t i s)
  then "Test 1 lookfor OK"
  else error(0, "Test 1 lookfor fails");

if lookfor('(now is), '(now we have nothing is)) = NIL
  then "Test 2 lookfor OK"
  else error(0, "Test 2 lookfor fails");

if lookfor('(now is), '(well hello!, now)) = NIL
  then "Test 3 lookfor OK"
  else error(0, "Test 3 lookfor fails");


%-------------------- Exercise #6 ------------------------- 

expr procedure add(a, b, carry, modulus);
/* Add two numbers stored as lists with digits of
  modulus. Carry passes the carry around. Tries to
  suppress leading 0's but fails with negatives. */
if null a then
  if null b then if zerop carry then nil
                   else {carry}
  else remainder(carry + car b, modulus) .
        add(nil, cdr b, (carry + car b) / modulus, modulus)
else if null b then add(b, a, carry, modulus)
else remainder(car a + car b + carry, modulus) .
      add(cdr a, cdr b, (car a + car b + carry) / modulus,
          modulus);


if add('(9 9), '(9 9), 0, 10) = '(8 9 1)
  then "Test 1 add OK"
  else error(0, "Test 1 add fails");

if add('(-9 -9), '(9 9), 0, 10) = '(0 0)
  then "Test 2 add OK"
  else error(0, "Test 2 add fails");

if add('(9 9 9), '(9 9 9 9), 0, 10) = '(8 9 9 0 1)
  then "Test 3 add OK"
  else error(0, "Test 3 add fails");

if add('(99 99 99), '(99 99 99 99), 0, 100) = '(98 99 99 0 1)
  then "Test 4 add OK"
  else error(0, "Test 4 add fails");

if add('(13 12), '(15 1), 0, 16) = '(12 14)
  then "Test 5 add OK"
  else error(0, "Test 5 add fails");


%-------------------- Exercise #7 ------------------------- 

expr procedure clength(l, tmp);
/* Compute the length of the (possibly circular) list l.
  tmp is used to pass values looked at down the list. */
if null l or l memq tmp then 0
  else 1 + clength(cdr l, l . tmp);

if clength('(a b c), nil) = 3
  then "Test 1 clength OK"
  else error(0, "Test 1 clength fails");


<< xxx := '(a b c); cdr lastpair xxx := xxx; nil >>;

if clength(xxx, nil) = 3
  then "Test 2 clength OK"
  else error(0, "Test 1 clength fails");

if clength(append('(a b c), xxx), nil) = 6
  then "Test 3 clength OK"
  else error(0, "Test 1 clength fails");

%------------------------- Exercise #8 -------------------------

expr procedure fringe x;
/* FRINGE(X) -- returns the fringe of X (the atoms at the
  end of the tree structure of X). */
if atom x then {x}
  else if cdr x then append(fringe car x, fringe cdr x)
  else fringe car x;

if fringe nil = '(NIL)
  then "Test 1 fringe OK"
  else error(0, "Test 1 fringe fails");

if fringe '(a b . c) = '(a b c)
  then "Test 2 fringe OK"
  else error(0, "Test 2 fringe fails");

if fringe '((((a) . b) (c . d)) . e) = '(a b c d e)
  then "Test 3 fringe OK"
  else error(0, "Test 3 fringe fails");


%------------------------- Exercise #9 -------------------------
expr procedure delall(x, l);
/* DELALL(X, L) -- Delete all X's from the list L using EQUAL
  test. The list is reconstructed. */
if null l then nil
  else if x = car l then delall(x, cdr l)
  else car l . delall(x, cdr l);

if delall('X, nil) = NIL
  then "Test 1 delall OK"
  else error(0, "Test 1 delall fails");

if delall('X, '(X)) = NIL
  then "Test 2 delall OK"
  else error(0, "Test 2 delall fails");

if delall('X, '(A)) = '(A)
  then "Test 3 delall OK"
  else error(0, "Test 3 delall fails");

if delall('(X B), '(A (B) (X B))) = '(A (B))
  then "Test 4 delall OK"
  else error(0, "Test 4 delall fails");

if delall('(X B), '((X B) (X B))) = NIL
  then "Test 5 delall OK"
  else error(0, "Test 5 delall fails");

if delall('(X B), '((X B) X B (X B))) = '(X B)
  then "Test 6 delall OK"
  else error(0, "Test 6 delall fails");


% ------------------------- Exercise #10 -------------------------
expr procedure startswith(prefix, word);
/* STARTSWITH(PREFIX, WORD) -- Returns T if the list of
  characters WORD begins with the list of characters PREFIX. */
if null prefix then T
  else if word then
     if car prefix eq car word then
         startswith(cdr prefix, cdr word);

if startswith('(P R E), '(P R E S I D E N T)) = T
  then "Test 1 startswith OK!"
  else error(0, "Test 1 startswith fails");

if startswith('(P R E), '(P O S T F I X)) = NIL
  then "Test 2 startswith OK!"
  else error(0, "Test 2 startswith fails");

if startswith('(P R E), '(P R E)) = T
  then "Test 3 startswith OK!"
  else error(0, "Test 3 startswith fails");

if startswith('(P R E), '(P R)) = NIL
  then "Test 4 startswith OK!"
  else error(0, "Test 4 startswith fails");

if startswith('(P R E), NIL) = NIL
  then "Test 5 startswith OK!"
  else error(0, "Test 5 startswith fails");

if startswith('(P R E), '(P P R E)) = NIL
  then "Test 6 startswith OK!"
  else error(0, "Test 6 startswith fails");


% ##### Test of Definitions #####

%------------------------- Exercise #1 -------------------------
expr procedure goodlist l;
/* GOODLIST(L) - returns T if L is a proper list. */
if null l then T
  else if pairp l then goodlist cdr l;

if goodlist '(a b c) = T
  then "Test 1 goodlist OK"
  else error(0, "Test 1 goodlist fails");

if goodlist nil = T
  then "Test 2 goodlist OK"
  else error(0, "Test 2 goodlist fails");

if goodlist '(a . b) = NIL
  then "Test 3 goodlist OK"
  else error(0, "Test 3 goodlist fails");


%------------------------- Exercise #2 -------------------------
expr procedure fmember(a, b, fn);
/* FMEMBER(A, B, FN) - Returns rest of B is A is a member
  of B using the FN of two arguments as an equality check. */
if null b then nil
  else if apply(fn, {a, car b}) then b
  else fmember(a, cdr b, fn);

if fmember('a, '(b c a d), function EQ) = '(a d)
  then "Test 1 fmember is OK"
  else error(0, "Test 1 fmember fails");

if fmember('(a), '((b c) (a) d), function EQ) = NIL
  then "Test 2 fmember is OK"
  else error(0, "Test 2 fmember fails");

if fmember('(a), '((b c) (a) d), function EQUAL) = '((a) d)
  then "Test 3 fmember is OK"
  else error(0, "Test 3 fmember fails");

if fmember(34, '(1 2 56 12), function LESSP) = '(56 12)
  then "Test 4 fmember is OK"
  else error(0, "Test 4 fmember fails");

%------------------------- Exercise #3-4 -------------------------
expr procedure findem(l, fn);
/* FINDEM(L, FN) - returns a list of elements in L that satisfy
  the single argument function FN. */
if null l then nil
  else if apply(fn, {car l}) then car l . findem(cdr l, fn)
  else findem(cdr l, fn);

if findem('(a 1 23 b "foo"), function idp) = '(a b)
  then "Test 1 findem OK!"
  else error(0, "Test 1 findem fails");

if findem('(1 3 a (44) 12 9),
          function (lambda x; numberp x and x < 10)) = '(1 3 9)
  then "Test 2 findem OK!"
  else error(0, "Test 2 findem fails");



%------------------------- Exercise #5 -------------------------
expr procedure insert(a, l, f);
/* Insert the value a into list l based on the partial ordering function
  f(x,y). Non-destructive insertion. */
if null l then {a}
  else if apply(f, {car l, a}) then a . l
  else car l . insert(a, cdr l, f);


% Basic ascending order sort.
insert(6, '(1 5 10), function geq);
if insert(6, '(1 5 10), function geq) = '(1 5 6 10)
     then "Test 1 insert (>=) OK"
     else error(0, "Test 1 insert (>=) fails");

% Try inserting element at end of list.
insert(11, '(1 5 10), function geq);
if insert(11, '(1 5 10), function geq) = '(1 5 10 11)
     then "Test 2 insert (>=) OK"
     else error(0, "Test 2 insert (>=) fails");

% Tru inserting something at the list beginning.
insert(-1, '(1 5 10), function geq);
if insert(-1, '(1 5 10), function geq) = '(-1 1 5 10)
     then "Test 3 insert (>=) OK"
     else error(0, "Test 3 insert (>=) fails");


% Insert into an empty list.
insert('34, nil, function leq);
if insert(34, nil, function leq) = '(34)
     then "Test 4 insert (<=) OK"
     else error(0, "Test 4 insert (<=) fails");

% Use a funny insertion function for (order . any);
expr procedure cargeq(a, b); car a >= car b;
insert('(34 . any), '((5 . now) (20 . and) (30 . then) (40 . but)),
       function cargeq);
if insert('(34 . any), '((5 . now) (20 . and) (30 . then) (40 . but)),
       function cargeq) = '((5 . now) (20 . and) (30 . then) (34 . any)
                            (40 . but))
     then "Test 5 insert (>=) OK"
     else error(0, "Test 5 insert (>=) fails");


% ###### FOR Loop Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure floatlist l;
/* FLOATLIST(L) returns a list of all floating point
   numbers in list L. */
for each x in l
    when floatp x
    collect x;

if floatlist '(3 3.4 a nil) = '(3.4)
  then "Test 1 floatlist OK"
  else error(0, "Test 1 floatlist fails");

if floatlist '(3.4 1.222 1.0e22) = '(3.4 1.222 1.0e22)
  then "Test 2 floatlist OK"
  else error(0, "Test 2 floatlist fails");

if floatlist '(a b c) = NIL
  then "Test 3 floatlist OK"
  else error(0, "Test 3 floatlist fails");


%------------------------- Exercise #2 -------------------------
expr procedure revpairnum l;
/* REVPAIRNUM(L) returns elements of L in a pair with
  the CAR a number starting at length of L and working
  backwards.*/
for i:=length l step -1 until 0
    each x in l
    collect i . x;

if revpairnum '(a b c) = '((3 . a) (2 . b) (1 . c))
  then "Test 1 revpairnum OK"
  else error(0, "Test 1 revpairnum fails");

if revpairnum  nil = nil
  then "Test 2 revpairnum OK"
  else error(0, "Test 2 revpairnum fails");

if revpairnum '(a) = '((1 . a))
  then "Test 3 revpairnum OK"
  else error(0, "Test 3 revpairnum fails");

%------------------------- Exercise #3 -------------------------
expr procedure lflatten l;
/* LFLATTEN(L) destructively flattens the list L
  to all levels. */
if listp l then for each x in l conc lflatten x
  else {l};

if lflatten '(a (b) c (e (e))) = '(a b c e e)
  then "Test 1 lflatten OK"
  else error(0, "Test 1 lflatten fails");

if lflatten '(a b c) = '(a b c)
  then "Test 2 lflatten OK"
  else error(0, "Test 2 lflatten fails");

if lflatten nil = nil
  then "Test 3 lflatten OK"
  else error(0, "Test 3 lflatten fails");

if lflatten '(a (b (c (d)))) = '(a b c d)
  then "Test 4 lflatten OK"
  else error(0, "Test 4 lflatten fails");

%------------------------- Exercise #4 -------------------------
expr procedure realstuff l;
/* REALSTUFF(L) returns the number of non-nil items in l. */
for each x in l count x;

if realstuff '(a b nil c) = 3
  then "Test 1 realstuff OK"
  else error(0, "Test 1 realstuff fails");

if realstuff '(nil nil nil) = 0
  then "Test 2 realstuff OK"
  else error(0, "Test 2 realstuff fails");

if realstuff '(a b c d) = 4
  then "Test 3 realstuff OK"
  else error(0, "Test 3 realstuff fails");

%------------------------- Exercise #5 -------------------------
expr procedure psentence s;
/* PSENTENCE(S) prints the list of "words" S with
  separating blanks and a period at the end. */
for each w on s
    do << prin2 car w;
          if cdr w then prin2 " " else prin2t "." >>;

psentence '(The man in the field is happy);

%------------------------- Exercise #6 -------------------------
expr procedure bsort v;
/* BSORT(V) sorts the vector V into ascending order using
  bubble sort. */
for i:=0:sub1 upbv v
    returns v
    do for j:=add1 i:upbv v
           when i neq j and v[i] > v[j]
           with tmp
           do << tmp := v[j]; v[j] := v[i]; v[i] := tmp >>;

xxx := [4,3,2,1, 5];
if bsort xxx = [1,2,3,4,5]
  then "Test 1 bsort OK"
  else error(0, "Test 1 bsort fails");

xxx := [1];
if bsort xxx = [1]
  then "Test 2 bsort OK"
  else error(0, "Test 2 bsort fails");


%------------------------- Exercise #7 -------------------------
expr procedure bsortt v;
/* BSORTT(V) sorts the vector V into ascending order using
  bubble sort. It verifies that all elements are numbers. */
<< for i:=0:upbv v 
       when not numberp v[i]
       do error(0, {v[i], "is not a number for BSORTT"});
   for i:=0:sub1 upbv v
       returns v
       do for j:=add1 i:upbv v
              when i neq j and v[i] > v[j]
              with tmp
              do << tmp := v[j]; v[j] := v[i]; v[i] := tmp >> >>;

xxx := [1,2,'a];
if atom errorset(quote bsortt xxx, nil, nil)
  then "Test 1 bsortt OK"
  else error(0, "Test 1 bsortt fails");

xxx := [1, 4, 3, 1];
if car errorset(quote bsortt xxx, nil, nil) = [1,1,3,4]
  then "Test 2 bsortt OK"
  else error(0, "Test 2 bsortt fails");


% ------------------------- Exercise #8 -------------------------
expr procedure average l;
/* AVERAGE(L) compute the average of the numbers
  in list L. Returns 0 if there are none. */
for each x in l
    with sm, cnt
    initially sm := cnt := 0
    when numberp x
    do << sm := sm + x; cnt := cnt + 1 >>
    returns if cnt > 0 then sm / cnt else 0;

if average '(a 12 34) = 23 then
  "Test 1 average OK"
  else error(0, "Test 1 average fails");

if average '(a b c) = 0 then
  "Test 2 average OK"
  else error(0, "Test 2 average fails");

if average '(a b c 5 6) = 5 then
  "Test 3 average OK"
  else error(0, "Test 3 average fails");

if average '(a b c 5 6.0) = 5.5 then
  "Test 4 average OK"
  else error(0, "Test 4 average fails");

%------------------------- Exercise #9 -------------------------
expr procedure boundingbox L;
/* BOUNDINGBOX(L) returns a list of
  (min X, max X, min Y, max Y)
 for the list L of dotted-pairs (x . y). */
{ for each x in L minimize car x,
  for each x in L maximize car x,
  for each y in L minimize cdr y,
  for each y in L maximize cdr y};


if boundingbox '((0 . 1) (4 . 5)) = '(0 4 1 5)
  then "Test 1 boundingbox OK"
  else error(0, "Test 1 boundingbox fails");

if boundingbox nil = '(0 0 0 0)
  then "Test 2 boundingbox OK"
  else error(0, "Test 2 boundingbox fails");

if boundingbox '((-5 . 3.4) (3.3 . 2.3) (1.2 . 33)
                 (-5 . -8) (22.11 . 3.14) (2 . 3)) = '(-5 22.11 -8 33)
  then "Test 3 boundingbox OK"
  else error(0, "Test 3 boundingbox fails");


%------------------------- Exercise #10 -------------------------

expr procedure maxlists(a, b);
/* MAXLISTS(A, B) -- Build a list such that for each pair
  of elements in lists A and B the new list has the largest
  element. */
for each ae in a
    each be in b
    collect max(ae, be);

if maxlists('(3 1.2), '(44.22 0.9 1.3)) = '(44.22 1.2)
  then "Test 1 maxlists OK"
  else error(0, "Test 1 maxlists fails");

if maxlists(nil, '(44.22 0.9 1.3)) = nil
  then "Test 2 maxlists OK"
  else error(0, "Test 2 maxlists fails");

if maxlists('(44.22 0.9 1.3), nil) = nil
  then "Test 3 maxlists OK"
  else error(0, "Test 3 maxlists fails");

if maxlists('(1.0 1.2 3.4), '(1 1)) = '(1.0 1.2)
  then "Test 4 maxlists OK"
  else error(0, "Test 4 maxlists fails");

%------------------------- Exercise #11 -------------------------
expr procedure numberedlist l;
/* NUMBEREDLIST(L) -- returns an a-list with the CAR being
  elements of L and CDR, the position in the list of the
  element starting with 0. */
for i:=0:length l
    each e in l
    collect e . i;

if numberedlist nil = nil
  then "Test 1 numberedlist is OK"
  else error(0, "Test 1 numberedlist fails");

if numberedlist '(a) = '((a . 0))
  then "Test 2 numberedlist is OK"
  else error(0, "Test 2 numberedlist fails");

if numberedlist '(a b c) = '((a . 0) (b . 1) (c . 2))
  then "Test 2 numberedlist is OK"
  else error(0, "Test 2 numberedlist fails");



%------------------------- Exercise #12 -------------------------
expr procedure reduce x;
/* REDUCE(X) -- X is a list of things some of which are
  encapsulated as (!! . y) and returns x. Destructively
  replace these elements with just y. */
for each v on x
    when eqcar(car v, '!!)
    do car v := cdar v
    returns x;

global '(x11);
x11 := '((!! . a) (b c) (d (!! . 34)));

if reduce x11 = '(a (b c) (d (!! . 34)))
  then "Test 1 reduce OK"
  else error(0, "Test 1 reduce fails");

if x11 = '(a (b c) (d (!! . 34)))
  then "Test 2 reduce OK"
  else error(0, "Test 2 reduce fails");


% ##### Further Procedure Tests #####

%------------------------- Exercise #1 -------------------------
expr procedure removeflags x;
/* REMOVEFLAGS(X) -- Scan list x replacing each top level
  occurrence of (!! . x) with x (whatever x is) and return
  the list. Replacement is destructive. */
while x and eqcar(car x, '!!)
      with v
      initially v := x
      do << print x; car x := cdar x;  print x; x := cdr x >>
      returns v;

xxx := '((!!. a) (!! . b) c (!! . d));
if removeflags xxx = '(a b c (!! . d))
 then "Test 1 removeflags OK"
 else error(0, "Test 1 removeflags fails");

if xxx = '(a b c (!! . d))
 then "Test 2 removeflags OK"
 else error(0, "Test 2 removeflags fails");


%------------------------- Exercise #2 -------------------------

expr procedure read2char c;
/* READ2CHAR(C) -- Read characters to C and return the
 list including C. Terminates at end of file. */
repeat l := (ch := readch()) . l
       with ch, l
       until ch eq c or ch eq !$EOF!$
       returns reversip l;

if read2char '!* = {!$EOL!$, 'a, 'b, 'c, '!*}
  then "Test 1 read2char OK"
  else error(0, "Test 1 read2char fails");
abc*

%------------------------- Exercise #3 -------------------------

expr procedure skipblanks l;
/* SKIPBLANKS(L) - Returns L with leading blanks
  removed. */
while l and eqcar(l, '! )
      do l := cdr l
      returns l;

if skipblanks '(!  !  !  a b) neq '(a b)
  then error(0, "Skipblanks fails test #1");

if skipblanks nil
  then error(0, "Skipblanks fails test #2");

if skipblanks '(!  !  !  )
  then error(0, "Skipblanks fails test #3");

if skipblanks '(!  !  a b !  ) neq '(a b ! )
  then error(0, "Skipblanks fails test #4");

%------------------------- Exercise #4 -------------------------

expr procedure ntoken l;
/* NTOKEN(L) - Scan over blanks in l. Then collect
  and return all characters up to the next blank
  returning a dotted-pair of (token . rest of L) or
  NIL if none is found. */
while l and eqcar(l, '! ) do l := cdr l
 returns
  if l then
     while l and not eqcar(l, '! )
           with tok
           do << tok := car l . tok;
                 l := cdr l >>
           returns (reversip tok . l);


if ntoken '(!  !  a b !  ) neq '((a b) . (!  ))
  then error(0, "ntoken fails test #1");

if ntoken nil then error(0, "ntoken fails test #2");

if ntoken '(!  !  !  ) then  error(0, "ntoken fails test #3");

if ntoken '(!  !  a b) neq '((a b) . nil) 
  then error(0, "ntoken fails test #4");


% ##### Block Statement Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure r2nums;
/* R2NUMS() -- Read 2 numbers and return as a list. */
begin scalar n1;
  n1 := read();
  return {n1, read()}
end;

if r2nums() = '(2 3)
  then "Test 1 r2nums OK"
  else error(0, "Test 1 r2nums failed");
2 3

%------------------------- Exercise #2 -------------------------
expr procedure readcoordinate;
/* READCOORDINATE() -- Read a coordinate and return
 it in radians. If prefixed with @, convert from
 degrees. If a list convert from degrees minutes
 seconds. */
begin scalar x;
  return
    (if (x := read()) eq '!@ then read() / 57.2957795130823208767981
      else if pairp x then
        (car x + cadr x / 60.0 + caddr x / 3600.0)
            / 57.2957795130823208767981
      else x)
end;

fluid '(val);
val := readcoordinate();
@ 57.29577
if val < 1.000001 AND val > 0.999999
  then "Test 1 readcoordinate OK"
  else error(0, "Test 1 readcoordinate failed");

% This fails with poor arithmetic.
val := readcoordinate();
(57 17 44.772)
if val < 1.000001 AND val > 0.999999
  then "Test 2 readcoordinate OK"
  else error(0, "Test 2 readcoordinate failed");
unfluid '(val);


if readcoordinate() = 1.0
  then "Test 3 readcoordinate OK"
  else error(0, "Test 3 readcoordinate failed");
1.0


%------------------------- Exercise #3 -------------------------
expr procedure delallnils l;
/* DELALLNILS(L) - destructively remove all NIL's from
  list L. The resulting value is always EQ to L. */
begin scalar p, prev;
   p := l;
loop: if null p then return l;
    if null car p then 
      if null cdr p then
         if null prev then return nil
         else << cdr prev := nil;
                 return l >>
      else << car p := cadr p;
              cdr p := cddr p;
              go to loop >>;
    prev := p;
    p := cdr p;
    go to loop
end;

fluid '(xxx yyy);    % New - added to aid CSL.
xxx := '(a b c nil d);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 1 dellallnils OK"
  else error(0, "Test 1 delallnils Fails!");

xxx := '(a nil b nil c nil d);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 2 dellallnils OK"
  else error(0, "Test 2 delallnils Fails!");

xxx := '(a nil b nil c nil d nil);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 3 dellallnils OK"
  else error(0, "Test 3 delallnils Fails!");

xxx := '(a nil nil nil nil b c d);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 4 dellallnils OK"
  else error(0, "Test 4 delallnils Fails!");

xxx := '(nil a b c d);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 5 dellallnils OK"
  else error(0, "Test 5 delallnils Fails!");

xxx := '(nil nil nil a b c d);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 6 dellallnils OK"
  else error(0, "Test 6 delallnils Fails!");

xxx := '(a b c d nil nil nil);
yyy := delallnils xxx;
if yyy = '(a b c d) and yyy eq xxx
  then "Test 7 dellallnils OK"
  else error(0, "Test 7 delallnils Fails!");


%------------------------- Exercise 4 -------------------------

expr procedure dprin1 x;
/* DPRIN1(X) - Print X in dotted-pair notation (to
  all levels). Returns X as its value. */
if vectorp x then 
  << prin2 "[";
     for i:=0:upbv x
         do << dprin1 x[i];
               if i < upbv x then prin2 " " >>;
     prin2 "]";
     x >>
  else if atom x then prin1 x
  else << prin2 "(";
          dprin1 car x;
          prin2 " . ";
          dprin1 cdr x;
          prin2 ")";
          x >>;

% The test is hard to make because we're doing output.
% Verify the results by hand and make sure it returns the
% argument.
dprin1 nil;
dprin1 '(a . b);
dprin1 '(a 1 "foo");
dprin1 '(((a)));
<< x := mkvect 2; x[0] := 'a; x[1] := '(b c); x[2] := 34; >>;
dprin1 {'(b c), x, 34};


% ##### Property List Exercises #####

%---------------------------- Exercise #1 ------------------------------

global '(stack!*);
expr procedure pexecute l;
/* PEXECUTE(L) - L is a stack language. Constants are
  placed on the global stack!*, id's mean a function
  call to a function under the STACKFN property of the
  function name. Other values are placed on the stack
  without evaluation. */
if null l then nil
else if constantp car l then
    << stack!* := car l . stack!*;
       pexecute cdr l >>
  else if idp car l then
    if get(car l, 'STACKFN) then
       << apply(get(car l, 'STACKFN), nil);
          pexecute cdr l >>
    else error(0, {car l, "undefined function"})
  else << stack!* := car l . stack!*;
          pexecute cdr l >>;

 expr procedure pdiff;
/* PADD1() - Subtract the 2nd stack elt from the
  first and replace top two entries with result. */
stack!* := (cadr stack!* - car stack!*) . cddr stack!*;
put('!-, 'STACKFN, 'pdiff);

expr procedure pplus2;
/* PPLUS2() - Pop and add the top two numbers
  on the stack and push the result. */
stack!* := (car stack!* + cadr stack!*) . cddr stack!*;
put('!+, 'STACKFN, 'pplus2);

expr procedure pprint;
/* PPRINT() - Print the top stack element. */
print car stack!*;
put('PRINT, 'STACKFN, 'pprint);


pexecute '(3 4 !+);
if stack!* neq '(7) then error(0, "PEXECUTE test #1 fails");
stack!* := nil;

pexecute '(5 3 !- 2 4 !+ !+);
if stack!* neq '(8) then error(0, "PEXECUTE test #2 fails");


%---------------------------- Exercise #2 ------------------------------

expr procedure pexecute l;
/* PEXECUTE(L) - L is a stack language. Constants are
  placed on the global stack!*, id's mean a function
  call to a function under the STACKFN property of the
  function name. Other values are placed on the stack
  without evaluation. */
if null l then nil
else if constantp car l then
    << stack!* := car l . stack!*;
       pexecute cdr l >>
  else if idp car l then
    if eqcar(l, 'QUOTE) then
       << stack!* := cadr l . stack!*;
          pexecute cddr l >>
    else if flagp(car l, 'STACKVAR) then
       << stack!* := get(car l, 'STACKVAL) . stack!*;
          pexecute cdr l >>
    else if get(car l, 'STACKFN) then
       << apply(get(car l, 'STACKFN), nil);
          pexecute cdr l >>
    else error(0, {car l, "undefined function"})
  else << stack!* := car l . stack!*;
          pexecute cdr l >>;


expr procedure pset;
/* PSET() - Put the second value on the stack under
  the STACKVAL attribute of the first. Flag the id as
  a STACKVAR for later use. Pop the top stack
  element. */
<< put(car stack!*, 'STACKVAL, cadr stack!*);
   flag({car stack!*}, 'STACKVAR);
   stack!* := cdr stack!* >>;
put('SET, 'STACKFN, 'pset);

stack!* := nil;
pexecute '(4.5 quote x set 4 !+ x !+ PRINT);
if stack!* neq '(13.0) then error(0, "Test 3 PEXECUTE fails");


% ##### Records Exercises #####

%------------------------- Exercise #1 -------------------------

record qtree /* QTREE is a quad tree node element. */
 with
   node := NIL        /* Node name */,
   q1 := NIL          /* Child #1 */,
   q2 := NIL          /* Child #2 */,
   q3 := NIL          /* Child #3 */,
   q4 := NIL          /* Child #4 */;


expr procedure qvisit q;
/* QVISIT(Q) -- Q is a QTREE data structure or NIL as are
  each of its children. Return a preorder visit of each
  node. */
if null q then nil
  else append({node q},
              append(qvisit q1 q,
               append(qvisit q2 q,
                append(qvisit q3 q, qvisit q4 q))));


/* A simple quad tree. */
global '(qdemo);
qdemo := qtree(node := 'A,
            q1 := qtree(node := 'B),
            q2 := qtree(node := 'C),
            q3 := qtree(node := 'D,
                        q1 := qtree(node := 'E)),
            q4 := qtree(node := 'F));

if qvisit qdemo = '(A B C D E F)
  then "Test 1 qvisit OK!"
  else error(0, "Test 1 qvisit Fails!");

/* The quadtree in the book. */
global '(qdemo2);
qdemo2 := qtree(node := 'A,
    q1 := qtree(node := 'B),
    q2 := qtree(node := 'C),
    q3 := qtree(node := 'D,
         q1 := qtree(node := 'E,
            q2 := qtree(node := 'F)),
         q2 := qtree(node := 'G),
         q3 := qtree(node := 'H),
         q4 := qtree(node := 'I)));

if qvisit qdemo2 = '(A B C D E F G H I)
  then "Test 2 qvisit OK!"
  else error(0, "Test 2 qvisit Fails!");

if qvisit nil = NIL
  then "Test 3 qvisit OK!"
  else error(0, "Test 3 qvisit Fails!");


%------------------------- Exercise #2 -------------------------

expr procedure qsearch(q, val, fn);
/* QSEARCH(Q, VAL, FN) -- Returns the node path from the
  root of the quadtree Q to VAL using FN as an equality
  function whose first argument is from the tree and
  second VAL. */
if null q then nil
else if apply(fn, {val, node q}) then {node q}
else begin scalar v;
  if v := qsearch(q1 q, val, fn) then return node q . v;
  if v := qsearch(q2 q, val, fn) then return node q . v;
  if v := qsearch(q3 q, val, fn) then return node q . v;
  if v := qsearch(q4 q, val, fn) then return node q . v
end;

if qsearch(qdemo, 'E, function EQ) = '(A D E)
  then "Test 1 qsearch OK!"
  else error(0, "Test 1 qsearch fails");

if qsearch(qdemo, 'XXX, function EQ) = nil
  then "Test 2 qsearch OK!"
  else error(0, "Test 2 qsearch fails");

if qsearch(qdemo2, 'F, function EQ) = '(A D E F)
  then "Test 3 qsearch OK!"
  else error(0, "Test 3 qsearch fails");


%------------------------- Exercise #3 -------------------------

record commchain
/* A COMMCHAIN is an n-ary tree with superior and
 subordinate links. */
with 
  name := NIL          /* Name of this node. */,
  superior := NIL      /* Pointer to superior node. */,
  subordinates := NIL  /* List of subordinates. */;


expr procedure backchain(l, sup);
/* BACKCHAIN(L, SUP) -- Fill in the SUPERIOR fields of
  each record in the n-ary tree (links in the SUBORDINATES
  field) to the lowest level. SUP is the current 
  superior. */
if null l then nil
 else << superior l := sup;
         for each sb in subordinates l
             do backchain(sb, l) >>;

/* Demo the back chain. */
global '(cch);
cch :=
  commchain(
    name := 'TOP,
    subordinates :=
      {commchain(name := 'LEV1-A),
       commchain(
          name := 'LEV1-B,
          subordinates := 
            {commchain(name := 'LEV2-A),
             commchain(name := 'LEV2-B)}),
       commchain(name := 'LEV1-C)});

% Wrap this up to avoid printing problems. 
<< backchain(cch, 'COMMANDER); NIL >>;


if superior cch EQ 'COMMANDER
  then "Test 1 backchain OK!"
  else error(0, "Test 1 backchain Fails!");

if name superior car subordinates cch EQ 'TOP
  then "Test 2 backchain OK!"
  else error(0, "Test 2 backchain Fails!");

if name superior car subordinates cadr subordinates cch
      eq 'LEV1-B
  then "Test 3 backchain OK!"
  else error(0, "Test 3 backchain Fails!");


% ##### Local Variable Exercises #####

%------------------------- Exercise #1 -------------------------

expr procedure lookup(v, a);
/* LOOKUP(V, A) -> Look for V in A and signal an error if not present.*/
(if rv then cdr rv else error(0, {v, "not in association list"}))
  where rv := assoc(v, a);


if lookup('a, '((a . b) (c . d))) = 'b
  then "Test 1 lookup success"
  else error(0, "Test 1 lookup fails");

if errorset(quote lookup('f, '((a . b) (c . d))), nil, nil) = 0
  then "Test 2 lookup success"
  else error(0, "Test 2 lookup fails");

%------------------------- Exercise #2 -------------------------

expr procedure quadratic(a, b, c);
/* QUADRATIC(A, B, C) -- Returns both solutions of the
  quadratic equation A*X^2 + B*X + C */
{(-B + U) / V, (-B - U) / V}
  where U := SQRT(B^2 - 4*A*C),
        V := 2.0 * A;

if quadratic(1.0, 2.0, 1.0) = '(-1.0 -1.0)
  then "Test 1 quadratic OK!"
  else error(0, "Test 1 quadratic Fails!");

if quadratic(1.0, 0.0, -1.0) = '(1.0 -1.0)
  then "Test 2 quadratic OK!"
  else error(0, "Test 2 quadratic Fails!");


%------------------------- Exercise #3 -------------------------
expr procedure lineintersection(x1, y1,
                                x2, y2,
                                x3, y3,
                                x4, y4);
/* LINEINTERSECTION(X1,Y1,X2,Y2,X3,Y3,X4,Y4) -
  Computes the intersection of line X1,Y1 ->
  X2,Y2 with X3,Y3 -> X4,Y4 if any. Returns NIL
  if no such intersection. */
(if zerop denom or zerop d1 or zerop d2 then nil
    else
     ((if p1 < 0 or p1 > d1 or p2 < 0 or p2 > d2
       then nil
       else (x1 + (x2 - x1) * p1 / d1) .
            (y1 + (y2 - y1) * p1 / d1))
          where p1 := num1 / denom,
                p2 := num2 / denom)
    where 
      num1 := d1*(x1*y3 - x1*y4 - x3*y1 + x3*y4
              + x4*y1 - x4*y3),
      num2 := d2*(- x1*y2 + x1*y3 + x2*y1 - x2*y3
              - x3*y1 + x3*y2))
where d1 :=sqrt((x2 - x1)^2 + (y2 - y1)^2),
      d2 := sqrt((x4 - x3)^2 + (y4 - y3)^2),
      denom := x1*y3 - x1*y4 - x2*y3 + x2*y4
               - x3*y1 + x3*y2 + x4*y1 - x4*y2;

if lineintersection(1, 1, 3, 3, 1, 2, 5, 2) = '(2.0 . 2.0)
  then "Test 1 LINEINTERSECTION success!"
  else error(0, "Test 1 LINEINTERSECTION fails intersect test");

% intersection at start and end points.
if lineintersection(1, 1, 2, 2, 1, 1, 1, 0) = '(1.0 . 1.0)
  then "Test 2 LINEINTERSECTION success!"
  else error(0, "Test 2LINEINTERSECTION fails intersect at start test");
if lineintersection(1, 1, 2, 2, 0, 1, 2, 2) = '(2.0 . 2.0)
  then "Test 3 LINEINTERSECTION success!"
  else error(0,
            "Test 3 LINEINTERSECTION fails intersect at endpoint test");
if lineintersection(1, 1, 2, 2, 2, 2, 3, 4) = '(2.0 . 2.0)
  then "Test 4 LINEINTERSECTION success!"
  else error(0,
      "Test 4 LINEINTERSECTION fails intersect end - begin point test");

% Now try no intersection test.
if null lineintersection(1, 1, 2, 3, 2, 4, 4, 5)
  then "Test 5 LINEINTERSECTION success!"
  else error(0,
            "Test 5 LINEINTERSECTION fails quadrant 1 no intersection");
if null lineintersection(1, 1, 2, 2, 1.75, 1.5, 5, 1.75)
  then "Test 6 LINEINTERSECTION success!"
  else error(0,
            "Test 6 LINEINTERSECTION fails quadrant 2 no intersection");



%------------------------- Exercise #4 -------------------------

expr procedure stdev x;
/* STDEV(X) - compute the standard deviation of the
  numbers in list X. */
if null x then 0
else (sqrt((for each v in x sum (v - avg)^2) / n)
         where avg := (for each v in x sum v) / n)
           where n := length x;

if stdev '(3.0 3.0 3.0) neq 0.0 then
  error(0, "Test 1 STDEV fails");


% ##### Array Exercises #####

%------------------------- Exercise #1 -------------------------
expr procedure vaverage v;
/* VAVERAGE(V) -- compute the average of all numeric
  elements of the vector v. */
(if cnt > 0 then
    ((for i:=0:upbv v when numberp v[i] sum v[i]) / float cnt)
  else 0.0)
 where cnt := for i:=0:upbv v count numberp v[i];

if vaverage array(1,2,3) = 2.0
  then "Test 1 vaverage is OK"
  else error(0, "Test 1 vaverage fails");

if vaverage array(3, 'a, 3, 6.0, 'f) = 4.0
  then "Test 2 vaverage is OK"
  else error(0, "Test 2 vaverage fails");

if vaverage array('a, 'b) = 0.0
  then "Test 3 vaverage is OK"
  else error(0, "Test 3 vaverage fails");

%------------------------- Exercise #2 -------------------------

expr procedure MAPPEND(a, b);
/* MAPPEND(A, B) -- Appends array B to array A and
  returns a new array with both. */
begin scalar c, ua;
  c := mkvect((ua := 1 + upbv a) + upbv b);
  for i:=0:upbv a do c[i] := a[i];
  for i:=0:upbv b do c[i + ua] := b[i];
  return c
end;

global '(a1 a2);
a1 := array(1, 2, 3);
a2 := array(3, 4, 5, 6);

if mappend(a1, a2) = array(1,2,3,3,4,5,6)
  then "Test 1 MAPPEND is OK"
  else error(0, "Test 1 MAPPEND fails");

if mappend(mkvect 0, mkvect 0) = mkvect 1
  then "Test 2 MAPPEND is OK"
  else error(0, "Test 2 MAPPEND fails");


%------------------------- Exercise #3 -------------------------

expr procedure indx(a, v);
/* INDX(A, V) -- returns index of A in V using EQ test,
  otherwise NIL. */
for i:=0:upbv v
    until a eq v[i]
    returns if i <= upbv v then i


if indx('a, array(1, 2, 'a, 34)) = 2
  then "Test 1 indx OK"
  else error(0, "Test 1 indx fails");

if null indx('a, array(1, 2, 3, 4))
  then "Test 2 indx OK"
  else error(0, "Test 2 indx fails");


%------------------------- Exercise #4 -------------------------
expr procedure mpy4x4(a, b);
/* MPY4X4(A, B) -- Create a new 4x4 matrix and return with
  the product of A and B in it. */
for row:=0:3
    with c, s
    initially c := mkarray(3,3)
    do << for col := 0:3 do
              do c[row,col] :=
                   for p := 0:3 sum a[row,p] * b[p,col] >>
    returns c;


expr procedure translate4x4(x, y, z);
/* TRANSLATE4X4(X, Y, Z) -- Generate and return a
 4x4 matrix to translate X, Y, Z. */
array(array(1.0, 0.0, 0.0, 0.0),
      array(0.0, 1.0, 0.0, 0.0),
      array(0.0, 0.0, 1.0, 0.0),
      array(x,   y,   z,   1.0));

expr procedure rotatex4x4 th;
/* ROTATEX4X4(TH) -- Generate a 4x4 rotation matrix about
  the X axis, TH radians. */
array(array(1.0,     0.0,    0.0,     0.0),
      array(0.0,     cos th, -sin th, 0.0),
      array(0.0,     sin th, cos th,  0.0),
      array(0.0,     0.0,    0.0,     1.0));



expr procedure mappoint(x, y, z, m);
/* MAPPOINT(X, Y, Z, M) -- Returns the transformed point
  X, Y, Z by the 4x4 matrix M. */
{x*m[0,0] + y*m[1,0] + z*m[2,0] + m[3,0],
 x*m[0,1] + y*m[1,1] + z*m[2,1] + m[3,1],
 x*m[0,2] + y*m[1,2] + z*m[2,2] + m[3,2]};


/* tmat is test matrix to rotate about x. In our tests we
  have to construct the resulting numbers on the fly
  because when input, they aren't the same for EQUAL. */
global '(tmat);
tmat := rotatex4x4(45.0 / 57.29577);

if mappoint(0.0, 0.0, 0.0, tmat) = '(0.0 0.0 0.0)
  then "Test 1 4x4 OK"
  else error(0, "Test 1 4x4 failed");
if mappoint(1.0, 0.0, 0.0, tmat) = '(1.0 0.0 0.0)
  then "Test 2 4x4 OK"
  else error(0, "Test 2 4x4 failed");
if mappoint(0.0, 1.0, 0.0, tmat) =
     {0.0, cos(45.0 / 57.29577), - sin(45.0 / 57.29577)}
  then "Test 3 4x4 OK"
  else error(0, "Test 3 4x4 failed");
if mappoint(1.0, 1.0, 0.0, tmat) =
     {1.0, cos(45.0 / 57.29577), - sin(45.0 / 57.29577)}
  then "Test 4 4x4 OK"
  else error(0, "Test 4 4x4 failed");
if mappoint(0.0, 0.0, 1.0, tmat) = 
     {0.0, sin(45.0 / 57.29577), cos(45.0 / 57.29577)}
  then "Test 5 4x4 OK"
  else error(0, "Test 5 4x4 failed");
if mappoint(1.0, 0.0, 1.0, tmat) = 
     {1.0, sin(45.0 / 57.29577), cos(45.0 / 57.29577)}
  then "Test 6 4x4 OK"
  else error(0, "Test 6 4x4 failed");
if mappoint(0.0, 1.0, 1.0, tmat) =
     {0.0, cos(45.0 / 57.29577) + sin(45.0 / 57.29577),
      cos(45.0 / 57.29577) - sin(45.0 / 57.29577)}
  then "Test 7 4x4 OK"
  else error(0, "Test 7 4x4 failed");
if mappoint(1.0, 1.0, 1.0, tmat) = 
     {1.0, cos(45.0 / 57.29577) + sin(45.0 / 57.29577),
      cos(45.0 / 57.29577) - sin(45.0 / 57.29577)}
  then "Test 8 4x4 OK"
  else error(0, "Test 8 4x4 failed");


/* Now try the multiplication routine. */
tmat := mpy4x4(rotatex4x4(45.0 / 57.29577),
               translate4x4(1.0, 2.0, 3.0));
if mappoint(0.0, 0.0, 0.0, tmat) = '(1.0 2.0 3.0)
  then "Test 9 4x4 OK"
  else error(0, "Test 9 4x4 failed");
if mappoint(0.0, 0.0, 1.0, tmat) =
     {1.0, 2.0 + sin(45.0 / 57.29577),
      3.0 + cos(45.0 / 57.29577)}
  then "Test 10 4x4 OK"
  else error(0, "Test 10 4x4 failed");
  

%------------------------- Exercise 4 -------------------------

expr procedure ltident n;
/* LTIDENT(N) -- Create and return a lower triangular,
   square, identity matrix with N+1 rows. */
for i:=0:n
    with a
    initially a := mkvect n
    do << a[i] := mkvect i;
          for j:=0:i - 1 do a[i,j] := 0.0;
          a[i,i] := 1.0 >>
    returns a;

expr procedure ltmpy(a, b);
/* LTMPY(A, B) -- Compute the product of two square,
  lower triangular matrices of the same size and return.
  Note that the product is also lower triangular. */
(for i:=0:rows
     with c
     initially c := mkvect rows
     do << c[i] := mkvect i;
           for j:=0:i do
               c[i,j] := for k:=j:i sum a[i,k] * b[k,j] >>
     returns c)
  where rows := upbv a;

if ltident 2 = array(array(1.0),
                     array(0.0, 1.0),
                     array(0.0, 0.0, 1.0))
  then "Test 1 ltident OK"
  else "Test 1 ltident fails";

if ltident 0 = array(array(1.0))
  then "Test 2 ltident OK"
  else "Test 2 ltident fails";

if ltmpy(ltident 2, ltident 2) = ltident 2
  then "Test 3 ltident OK"
  else "Test 3 ltident fails";

if ltmpy(array(array(1.0),
               array(1.0, 2.0),
               array(1.0, 2.0, 3.0)),
         array(array(1.0),
               array(1.0, 2.0),
               array(1.0, 2.0, 3.0))) = 
   array(array(1.0),
         array(3.0, 4.0),
         array(6.0, 10.0, 9.0))
  then "Test 4 ltmpy OK"
  else error(0, "Test 4 ltmpy fails");

if ltmpy(array(array(1.2),
               array(3.4, 5.0),
               array(1.0,-2.3,-1.3)), ltident 2)
     = array(array(1.2),
             array(3.4, 5.0),
             array(1.0, -2.3, -1.3))
  then "Test 5 ltmpy OK"
  else error(0, "Test 5 ltmpy fails");

                

%------------------------- Exercise #5 -------------------------

expr procedure coerce(a, b, pth, cmat);
/* COERCE(A,B,PTH,CMAT) -- return a list of functions 
  to coerce type A (an index into CMAT) into type B. PTH
  is NIL   to start and CMAT the coercion table arranged
  with "from" type as rows, "to" type as columns. */
if cmat[a,b] then cmat[a,b] . pth
else
  for j:=0:upbv cmat[a]
      with cp
      until j neq a and cmat[a,j] and
            not (cmat[a,j] memq pth) and
            not(cmat[j,a] memq pth) and
            (cp := coerce(j, b, cmat[a,j] . pth, cmat))
      returns cp;

/* Create the coercion array. Here int=0, string=1,
  float=2, complex=3, and gaussian=4 */
global '(cpath);
cpath :=
 array(array('ident,   'int2str, 'float,   nil,      nil),
       array('str2int, 'ident,   'str2flt, nil,      nil),
       array('fix,     'flt2str, 'ident,   'flt2cplx,nil),
       array(nil,      nil,      nil,      'ident, 'cfix),
       array(nil,      nil,      nil,    'cfloat, 'ident));


% Coerce int to complex.
if coerce(0, 3, nil, cpath) = '(FLT2CPLX STR2FLT INT2STR)
  then "Test 1 coerce OK"
  else error(0, "Test 1 coerce fails");

% Coerce Complex into int.
if coerce(3, 0, nil, cpath) = NIL
  then "Test 2 coerce OK"
  else error(0, "Test 2 coerce fails");

% Coerce int into gaussian.
if coerce(0, 4, nil, cpath) = 
       '(CFIX FLT2CPLX STR2FLT INT2STR)
  then "Test 3 coerce OK"
  else error(0, "Test 3 coerce fails");

               
    
%------------------------- Exercise #6 -------------------------

expr procedure cellvon(a, b, fn);
/* CELLVON(A, B, FN) -- Compute the next generation of the
  cellular matrix A and place it into B. Use the VonNeumann
  neighborhood and the function FN to compute the next
  generation. The space edges are wrapped into a torus*/
for r:=0:rows
    with rows, cols
    initially << rows := upbv a; cols := upbv a[1] >>
    do for c:=0:cols
        do b[r,c] := apply(fn,
             {a[r,c],
              a[torus(r + 1, rows), torus(c - 1, cols)],
              a[torus(r + 1, rows), c],
              a[torus(r + 1, rows), torus(c + 1, cols)],
              a[r, torus(c + 1, cols)],
              a[torus(r - 1, rows), torus(c + 1, cols)],
              a[torus(r - 1, rows), c],
              a[torus(r - 1, rows), torus(c - 1, cols)],
              a[r, torus(c - 1, cols)]});

expr procedure torus(i, v);
/* TORUS(I, V) -- A positive modulus: if I is less than
  0, wrap to V, or if it exceeds V, wrap to I. */
if i < 0 then v 
  else if i > v then 0
  else i;

expr procedure life(c, n1, n2, n3, n4, n5, n6, n7, n8);
/* LIFE(C, N1 ... N8) -- Game of life rules. Here C is
  the cell being examined and N1-N8 are the VonNeumann
  neighbor states. */
(if c = 1 then if cnt = 2 or cnt = 3 then 1 else 0
  else if cnt = 3 then 1 else 0)
 where cnt = n1 + n2 + n3 + n4 + n5 + n6 + n7 + n8;

/* LIFESTATES contains a vector of states and what
  character to print. */
global '(LIFESTATES);
LIFESTATES := array(" ", "*");

expr procedure pcell(gen, a, pr);
/* PCELL(GEN, A) -- Display the state of the GEN generation
  of the cellular matrix A. Display a * for state=1, and
  a blank for state 0. */
for r:=0:rows
    with rows, cols
    initially << rows := upbv a; cols := upbv a[1];
                 terpri(); prin2 "Generation: "; print gen >>
    do << terpri();
          for c:=0:cols do prin2 pr[a[r,c]] >>;



expr procedure rungame(a, n, fn, pr);
/* RUNGAME(A, N, FN, PR) -- Run through N generations
  starting with the cellular matrix A and using the
  function FNto compute the new generation. Use the array
  PR to display the state. */
for i:=1:n
    with tmp, b
    initially b := mkarray(upbv a, upbv a[1])
    do << pcell(i, a, pr);
          cellvon(a, b, function life);
          tmp := a;  a := b;  b := tmp >>;
 

/* SEED is the seed array with 1's for on state, 0 for
  off. */
global '(seed);
seed := array(
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 1, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 1, 0, 0, 0),
  array(0, 0, 0, 0, 1, 1, 1, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
  array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0));

rungame(seed, 10, function life, LIFESTATES);


%------------------------- Exercise #7 -------------------------

expr procedure compact heep;
/* compact(HEEP) -- HEEP is an array of blocks of
  sequentially allocated items. The first entry in each 
  block is INUSE, the second the total number of entries
  + 2 (for the header). The remainder are random values.
  Free blocks are the same but instead have the header
  FREE. Returns a compacted structure with a single FREE
  entry at the end with entries changed to *. Returns the
  number of free entries. */
begin scalar dest, src, last, u;
  last := dest := src := 0;
loop: if src > upbv heep then
        if src = dest then return 0
        else << heep[dest] := 'FREE;
                heep[dest+1] := src - dest;
                for i:=dest+2:upbv heep do heep[i] := '!*;
                return heep[dest+1] >>;
  if heep[src] eq 'FREE then
       src := heep[src+1] + src
  else << u := heep[src+1] + src - 1;
          for i:=src:u do << heep[dest] := heep[i];
                             dest := dest + 1 >>;
          src := u + 1 >>;
  go to loop
end;


/* A simple array to test. */
global '(H);
H := array('INUSE, 3, 0,
           'FREE, 4, '!*, '!*,
           'INUSE, 4, 0, 1,
           'FREE, 3, '!*,
           'FREE, 5, '!*, '!*, '!*,
           'INUSE, 5, 0, 1, 2,
           'INUSE, 5, 3, 4, 5);

if compact H = 12
  then "Test 1 compact OK!"
  else error(0, "Test 1 compact fails!");
if H = array('INUSE, 3, 0, 'INUSE, 4, 0, 1, 'INUSE,
             5, 0, 1, 2, 'INUSE, 5, 3, 4, 5,
             'FREE, 12, '!*, '!*, '!*, '!*, '!*, '!*,
             '!*, '!*, '!*, '!*)
  then "Test 2 compact OK!"
  else error(0, "Test 2 compact fails!");

/* Test a completely full one. */
H := array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3);
if compact H = 0
  then "Test 3 compact OK!"
  else error(0, "Test 3 compact fails!");
if H = array('INUSE, 3, 0, 'INUSE, 5, 1, 2, 3)
  then "Test 4 compact OK!"
  else error(0, "Test 4 compact fails!");


/* Test a completely empty one. */
H := array('FREE, 3, '!*, 'FREE, 5, '!*, '!*, '!*);
if compact H = 8 
  then "Test 5 compact OK!"
  else error(0, "Test 5 compact fails!");
if H = array('FREE, 8, '!*, '!*, '!*, '!*, '!*, '!*)
  then "Test 6 compact OK!"
  else error(0, "Test 6 compact fails!");


%------------------------- Exercise #8 -------------------------

expr procedure HISTOGRAM(v, n);
/* HISTOGRAM(V,N) -- V is an arbitrarily size vector of
  numbers. Compute its an N element histogram over its
  range and return it. */
begin scalar minv, maxv, h, range;
  minv := maxv := v[0];
  for i:=1:upbv v
      do << if v[i] < minv then minv := v[i];
            if v[i] > maxv then maxv := v[i] >>;
  range := maxv - minv;
  h := mkvect(n - 1);
  for i:=0:n - 1 do h[i] := 0;
  for i:=0:upbv v
      with hn
      do << hn := fix(n * (v[i] - minv) / range);
            if hn = n then hn := hn - 1;
            h[hn] := h[hn] + 1 >>;
  return h
end;

global '(v1);
<< v1 := mkvect 100;
   for i:=0:100 do v1[i] := float i >>;

if HISTOGRAM(v1, 1) = array(101)
  then "Test 1 HISTOGRAM OK!"
  else error(0, "Test 1 HISTOGRAM Fails!");

if HISTOGRAM(v1, 2) = array(50, 51)
  then "Test 2 HISTOGRAM OK!"
  else error(0, "Test 2 HISTOGRAM Fails!");

if HISTOGRAM(v1, 7) = array(15, 14, 14, 15, 14, 14, 15)
  then "Test 3 HISTOGRAM OK!"
  else error(0, "Test 3 HISTOGRAM Fails!");


%------------------------- Exercise #9 -------------------------

expr procedure rarray n;
/* RARRAY(N) - generate an NxN matrix with uniform
  distribution random numbers in the range 0.0 -> 1.0. */
for x:=0:n
    with a
    initially a := mkarray(n,n)
    returns a
    do for y:=0:n do a[x,y] := random(1000) / 1000.0;

if upbv rarray 4 =  4
  then "Test 1 rarray OK"
  else error(0, "Test 1 rarray fails");


expr procedure addcircle(a, r, xc, yc, v);
/* ADDCIRCLE(A, R, XC, YC, V) -- Add V to each cell within
  distance R from center point XC, YC and return a new
  matrix with these values. Values always remain in the
  range 0.0 -> 1.0. */
begin scalar uax, uay, b;
  b := mkarray(uax := upbv a, uay := upbv a[0]);
  for x:=0:uax do
    for y:=0:uay do
       b[x,y] := if sqrt((x - xc)^2 + (y - yc)^2) <= r
            then min(1.0, v + a[x,y]) else a[x,y];
  return b
end;

global '(xxx);
xxx := array(array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0),
             array(0, 0, 0, 0, 0));

% This will fail if sqrt isn't very accurate. 
if addcircle(xxx, 2.0, 2, 2, 0.75) = 
  array(array(0,    0,    0.75, 0,    0),
        array(0,    0.75, 0.75, 0.75, 0),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0,    0.75, 0.75, 0.75, 0),
        array(0,    0,    0.75, 0,    0))
  then "Test 1 addcircle OK!"
  else error(0, "Test 1 addcircle fails!");

if addcircle(xxx, 10.0, 2, 2, 0.75) = 
  array(array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75),
        array(0.75, 0.75, 0.75, 0.75, 0.75))
  then "Test 2 addcircle OK!"
  else error(0, "Test 2 addcircle fails!");


%------------------------- Exercise #10 -------------------------

expr procedure areaaverage(a, n);
/* AREAAVERAGE(A, N) -- Compute the average of the NxN
  neighborhood of each cell in the matrix A and return a
  new matrix with these values. */
begin scalar uax, uay, sm, cnt, b, n2;
  n2 := n / 2;
  b := mkarray(uax := upbv a, uay := upbv a[1]);
  for x := 0:uax do
   for y := 0:uay do
     << sm := 0.0;
        cnt := 0;
        for xp := max(0, x - n2):min(uax, x + n2) do
          for yp := max(0, y - n2):min(uay, y + n2) do
            << sm := sm + a[xp,yp];
               cnt := cnt + 1 >>;
        b[x,y] := sm / cnt >>;
  return b
end;

global '(ninth);
xxx[2,2] := 1.0;
ninth := 1.0 / 9.0;

if areaaverage(xxx, 3) =
  array(array(0.0, 0.0,   0.0,   0.0,   0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, ninth, ninth, ninth, 0.0),
        array(0.0, 0.0,   0.0,   0.0,   0.0))
  then "Test 1 areaaverage OK!"
  else error(0, "Test 1 areaaverage Fails!");


%------------------------- Exercise #11 -------------------------

expr procedure laplace a;
/* LAPLACE(A) -- Compute the Laplacian on A but assuming
  0.0 at the borders. Returns a new array the same size
  as A. */
begin scalar uax, uay, b, sm;
  b := mkarray(uax := upbv a, uay := upbv a[0]);
  for x := 0:uax do
   for y := 0:uay do
     << sm := 0.0;
        for xp := max(0, x - 1):min(uax, x + 1)
          when xp neq x do
          for yp := max(0, y - 1):min(uay, y + 1)
            when yp neq y
            do sm := sm + a[xp,yp];
        b[x,y] := max(0.0, min(5.0 * a[x,y] - sm, 1.0)) >>;
  return b
end;


xxx := array(array(0,0,0,0,0),
             array(0,1,1,1,0),
             array(0,1,1,1,0),
             array(0,1,1,1,0),
             array(0,0,0,0,0));
if laplace xxx = array(array(0.0, 0.0, 0.0, 0.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 1.0, 1.0, 1.0, 0.0),
                       array(0.0, 0.0, 0.0, 0.0, 0.0))
  then "Test 1 laplace OK!"
  else error(0, "Test 1 laplace fails!");


%------------------------- Exercise #12 -------------------------

expr procedure threshold(a, vl, vh);
/* THRESHOLD(A, VL, VH) -- Returns a new matrix of the same
  size as A with each cell set to 1.0 that is 
  VL <= A(i,j) <= VH. Others are set to 0.0. */
for x := 0:uax
    with uax, uay, b
    initially b := mkarray(uax := upbv a,
                           uay := upbv a[0])
    returns b
    do for y := 0:uay
         do b[x,y] := 
               if a[x,y] >= vl and a[x,y] <= vh then 1.0
                                                else 0.0;

xxx := mkarray(4,4);
for i:=0:4 do for j:=0:4 do xxx[i,j] := i * j;

if threshold(xxx, 8, 10) = array(
  array(0.0, 0.0, 0.0, 0.0, 0.0),
  array(0.0, 0.0, 0.0, 0.0, 0.0),
  array(0.0, 0.0, 0.0, 0.0, 1.0),
  array(0.0, 0.0, 0.0, 1.0, 0.0),
  array(0.0, 0.0, 1.0, 0.0, 0.0))
  then "Test 1 threshold OK!"
  else error(0, "Test 1 threshold Fails!");



expr procedure dump(a, f);
/* DUMP(A,F) -- Dump an array A into a PicTex format
  file for document processing. */
begin scalar fh;
  fh := wrs open(f, 'output);
  for x:=0:upbv a do
    for y:=0:upbv a[0] do
      printf("\setshadegrid span <%wpt>%n\vshade %d %d %d %d %d %d /%n",
             max(0.5, 5.5 - a[x,y]*5.0),
             x, y, y+1, x+1, y, y+1);
  close wrs fh;
end;


% ##### Macro Exercises #####

%------------------------- Exercise -----------------------
macro procedure appendl x;
/* APPENDL( ...) - append all the lists together. */
 expand(cdr x, 'append);

if appendl('(a b), '(c d), '(e f)) = '(a b c d e f)
  then "Test 1 appendl OK!"
  else error(0, "Test 1 appendl fails!");
if appendl '(a b c) = '(a b c)
  then "Test 2 appendl OK!"
  else error(0, "Test 2 appendl fails!");
if appendl nil = nil
  then "Test 3 appendl OK!"
  else error(0, "Test 3 appendl fails!");

%------------------------- Exercise ------------------------
macro procedure nconcl x;
/* NCONCL(...) - destructive concatenation of all the
  lists. */
  expand(cdr x, 'nconc);

global '(b1 b2 b3);
b1 := '(a b);
b2 := '(c d);
b3 := '(e f);
if nconcl(b1, b2, b3) = '(a b c d e f)
  then "Test 1 nconcl OK!"
  else error(0, "Test 1 nconcl fails!");
if b1 = '(a b c d e f)
  then "Test 2 nconcl OK!"
  else error(0, "Test 2 nconcl fails!");
if b2 = '(c d e f)
  then "Test 3 nconcl OK!"
  else error(0, "Test 3 nconcl fails!");
if b3 = '(e f)
  then "Test 4 nconcl OK!"
  else error(0, "Test 4 nconcl fails!");


%------------------------- Exercise ------------------------
smacro procedure d(x1, y1, x2, y2);
/* D(X1, Y1, X2, Y2) - Euclidean distance between points
  (X1,Y1) -> (X2,Y2) */
sqrt((x1 - x2)^2 + (y1 - y2)^2);

% This fails with poor sqrt.
if d(0, 0, 3, 4) = 5.0
  then "Test 1 d OK!"
  else error(0, "Test 1 d Fails!");
if d(0, 0, 1, 1) = sqrt 2
  then "Test 2 d OK!"
  else error(0, "Test 2 d Fails!");

%------------------------- Exercise -------------------------
macro procedure pop x;
/* POP(X) - Assuming X is an identifier, pop the stack
  and return the popped value. */
(`(prog (!$V!$)
     (setq !$V!$ (car #v))
     (setq #v (cdr #v))
     (return !$V!$))) where v := cadr x;

xxx := '(A B);
if pop xxx eq 'A
  then "Test 1 POP ok!"
  else error(0, "Test 1 POP fails!");
if xxx = '(B) 
  then "Test 1 POP ok!"
  else error(0, "Test 1 POP fails!");
if pop xxx eq 'B
  then "Test 2 POP ok!"
  else error(0, "Test 2 POP fails!");
if xxx eq NIL
  then "Test 2 POP ok!"
  else error(0, "Test 2 POP fails!");

%------------------------- Exercise -------------------------

macro procedure push x;
/* PUSH(ST, V) - push V onto ST (an identifier) and 
  return V. */
`(progn (setq #st (cons #v #st))
        #v)
  where st := cadr x,
        v := caddr x;

if push(xxx, 'A) = 'A
  then "Test 1 push OK!"
  else error(0, "Test 1 push fails");
if xxx = '(A)
  then "Test 1 push OK!"
  else error(0, "Test 1 push fails");
if push(xxx, 'B) = 'B
  then "Test 2 push OK!"
  else error(0, "Test 2 push fails");
if xxx = '(B A)
  then "Test 2 push OK!"
  else error(0, "Test 2 push fails");
  
%------------------------- Exercise -------------------------

macro procedure format x;
/* FORMAT("str", ...) - A formatted print utility. It
  looks for %x things in str, printing everything else.
  A property of printf!-format will cause a call on
  the named function with the corresponding argument.
  This should return a print form to use. A property
  printf!-expand calls a function without an argument.
  Common controls are:
    %n new line
    %p prin2 call.
    %w prin1 call.
*/
begin scalar str, localstr, m;
  str := explode2 cadr x;
  x := cddr x;
loop: if null str then
    << if localstr then
          m := {'prin2, makestring reversip localstr} . m;
       return 'progn . reverse m  >>;
  if eqcar(str, '!%) then
     if cdr str then
       if fn := get(cadr str, 'printf!-format) then
         << if localstr then 
              << m := {'prin2, makestring reversip localstr} . m;
                 localstr := nil >>;
            m := apply(fn, {car x}) . m;
            x := cdr x;
            str := cddr str; 
            go to loop >>
       else if fn := get(cadr str, 'printf!-expand) then
         << if localstr then
              << m := {'prin2, makestring reverse localstr} . m;
                 localstr := nil >>;
            m := apply(fn, nil) . m;
            str := cddr str; 
            go to loop >>;
  localstr := car str . localstr;
  str := cdr str;
  go to loop
end;

expr procedure makestring l;
/* MAKESTRING(L) - convert the list of character L into
  a string. */
 compress('!" . append(l, '(!")));

expr procedure printf!-terpri;
/* PRINTF!-TERPRI() - Generates a TERPRI call for %n */
 '(terpri);
put('!n, 'printf!-expand, 'printf!-terpri);
put('!N, 'printf!-expand, 'printf!-terpri);

expr procedure printf!-prin1 x;
/* PRINTF!-PRIN1(X) - Generates a PRIN1 call for %w */
 {'prin1, x};
put('!w, 'printf!-format, 'printf!-prin1);
put('!W, 'printf!-format, 'printf!-prin1);

expr procedure printf!-prin2 x; 
/* PRINTF!-PRIN2(X) - Generates a PRIN2 call for %p */
 {'prin2, x};
put('!p, 'printf!-format, 'printf!-prin2);
put('!P, 'printf!-format, 'printf!-prin2);

%------------------------- Exercise -------------------------
macro procedure rmsg x;
/* RMSG("str", ...) - A formatted string utility. It
  looks for %x things in str, copying everything else.
  A property of rmsg!-format will cause a call on
  the named function with the corresponding argument.
  This should return a explode form to use. A property
  rmsg!-expand calls a function without an argument.
  Common controls are:
    %n new line
    %p explode2 call.
    %w explode call.
*/
begin scalar str, localstr, m;
  str := explode2 cadr x;
  x := cddr x;
loop: if null str then
    << if localstr then
          m := mkquote reversip localstr . m;
       return `(makestring (nconcl #@(reversip m)))  >>;
  if eqcar(str, '!%) then
     if cdr str then
       if fn := get(cadr str, 'rmsg!-format) then
         << if localstr then 
              << m := mkquote reversip localstr . m;
                 localstr := nil >>;
            m := apply(fn, {car x}) . m;
            x := cdr x;
            str := cddr str; 
            go to loop >>
       else if fn := get(cadr str, 'rmsg!-expand) then
         << if localstr then
              << m := mkquote reversip localstr . m;
                 localstr := nil >>;
            m := apply(fn, nil) . m;
            str := cddr str; 
            go to loop >>;
  localstr := car str . localstr;
  str := cdr str;
  go to loop
end;

expr procedure makestring l;
/* MAKESTRING(L) - convert the list of character L into
  a string. */
 compress('!" . append(l, '(!")));

expr procedure rmsg!-terpri;
/* RMSG!-TERPRI() - Generates an EOL. */
mkquote {!$eol!$};
put('!n, 'rmsg!-expand, 'rmsg!-terpri);
put('!N, 'rmsg!-expand, 'rmsg!-terpri);

expr procedure rmsg!-prin1 x;
/* RMSG!-PRIN1(X) - Generates an EXPLODE call */
 `(fixstr (explode #x));
put('!w, 'rmsg!-format, 'rmsg!-prin1);
put('!W, 'rmsg!-format, 'rmsg!-prin1);

expr procedure rmsg!-prin2 x; 
/* RMSG!-PRIN2(X) - Generates an EXPLODE2 call for x. */
 `(explode2 #x);
put('!p, 'rmsg!-format, 'rmsg!-prin2);
put('!P, 'rmsg!-format, 'rmsg!-prin2);

expr procedure fixstr x;
/* FIXSTR(X) - Double up "'s in x. */
if null x then nil
  else if eqcar(x, '!") then '!" . '!" . fixstr cdr x
  else car x . fixstr cdr x;


if rmsg "abc" = "abc"
  then "Test 1 rmsg OK!"
  else error(0, "Test 1 rmsg fails!");

if rmsg("Test %w test", 12) = "Test 12 test"
  then "Test 2 rmsg OK!"
  else error(0, "Test 2 rmsg fails!");

if rmsg("Test %w string", "foo") = "Test ""foo"" string"
  then "Test 3 rmsg OK!"
  else error(0, "Test 3 rmsg fails!");

if rmsg("Test %w now %p", "foo", "foo") = "Test ""foo"" now foo"
  then "Test 4 rmsg OK!"
  else error(0, "Test 4 rmsg fails!");

%------------------------- Exercise -------------------------
define CFLAG = T;

macro procedure ifcflag x;
/* IFCLFAG(X) - generate the code for X if CFLAG is non-NIL,
  otherwise generate NIL (this can't be used everywhere). */
if CFLAG then cadr x else nil;

ifCFLAG expr procedure pslfoo x; car x;
if getd 'pslfoo
  then "Test 1 ifCFLAG OK!"
  else error(0, "Test 1 ifCFLAG fails!");


% ##### Interactive Exercises #####

%------------------------- Exercise #2 -------------------------

/* Lists functions that have been embedded with count code. */
global '(EMBEDDED!*);
EMBEDDED!* := NIL;

expr procedure embed f;
/* EMBED(F) - wrap function F with counter code. Error if F is
   not interpreted. Put the information under property COUNT and
   add to the global list EMBEDDED!*. */
begin scalar def, args, nfn;
  if not(def := getd f) then  error(0, {f, "is undefined"});
  if codep cdr def then error(0, {f, "is not interpreted"});
  put(f, 'COUNT, 0);
  if f memq EMBEDDED!* then return NIL;
  EMBEDDED!* := f . EMBEDDED!*;
  putd(nfn := intern gensym(), car def, cdr def);
  putd(f, car def,
       {'lambda, caddr def,
        {'progn,
           {'put, mkquote f, mkquote 'COUNT,
                  {'add1, {'get, mkquote f, mkquote 'COUNT}}},
           nfn . caddr def}});
  return f
end;


expr procedure stats;
/* STATS() - list all the embedded functions and their 
   counts. */
for each f in EMBEDDED!*
    do << prin1 f; prin2 "  "; print get(f, 'COUNT) >>;


expr procedure pcnt x;
/* PCNT(X) - returns the number of dotted-pairs in X (vectors
  can hide dotted-pairs). */
if atom x then 0
  else 1 + pcnt car x + pcnt cdr x;

if embed 'pcnt eq 'pcnt 
  then "Test 1 embed OK!"
  else error(0, "Test 1 embed Fails!");
if get('pcnt, 'count) = 0
  then "Test 2 embed OK!"
  else error(0, "Test 2 embed Fails!");
if pcnt '(a . (b . c)) = 2
  then "Test 3 embed OK!"
  else error(0, "Test 3 embed Fails!");
if get('pcnt, 'COUNT) = 5
  then "Test 4 embed OK!"
  else error(0, "Test 4 embed Fails!");
if EMBEDDED!* = '(PCNT)
  then "Test 5 embed OK!"
  else error(0, "Test 5 embed Fails!");

% Just a visual check.
stats();


%   ##### Test the inspector module #####
%
% We set LINELENGTH to various values to check how good we do on output.
% Don't let the default screw up the test:
LINELENGTH 80;

% Describe some of the basic data types.
% Dotted-pairs.
describe '(a . b);

% Vectors;
global '(xvar);
xvar := mkvect 3;
describe xvar;

% Records.
record insprec /* A record for testing. */
  with
    field1 := 'a;
xvar := insprec();
describe xvar;
describe 'insprec;

% A code pointer (usually).
describe cdr getd 'car;

% Numbers.
describe 1;
describe 3.14159;

% Strings
describe "This is a string";

% identifiers of various sourts.
describe 'car;
describe 'a!-plain!-jane!-identifier;  
describe nil;   % This message is sort of funny in odd ways.


% Now let's get serious. Here's a global with no active comment. The
% remprop is something you shouldn't know about but allows us to run
% the test file multiple times and get the same results.
remprop('TheCow, 'NEWNAM);
DEFINE TheCow = "How now brown cow";
describe 'TheCow;

off saveactives;
/* I never saw a purple cow, I never hope to see one now. */
global '(PurpleCow);
describe 'PurpleCow;

on saveactives;
/* But I'd rather see one than be one! */
global '(Pcow);
describe 'Pcow;

% Now we march on to procedures.
% Here's one with no comment and we don't save it.
off saveactives;
remd 'comtest1;
expr procedure comtest1 x;
print x;
describe 'comtest1;

% Here's one with no comment and we do save it.
on saveactives;
remd 'comtest2;
expr procedure comtest2(x, y);
print x;
describe 'comtest2;

% Here's one with a comment but we don't save it.
off saveactives;
remd 'comtest3;
expr procedure comtest3(x, y, z);
/* You should never see this comment. */
print x;
describe 'comtest3;

% Here's one with a comment and we should see it.
on saveactives;
remd 'comtest4;
expr procedure comtest4(x, y, z, xx);
/* COMTEST4(X, Y, Z, XX) - A well commented routine. This routine
  does almost nothing, but a good article thereof. */
print x;
describe 'comtest4;

% Now try MACROS.

remd 'comtest5;
macro procedure comtest5 x;
/* COMTEST5(X) - A macro that doesn't really do much of anything. */
{'car, cadr x};
describe 'comtest5;


smacro procedure comtest6 x;
/* COMTEST6(X) - a SMACRO with an active comment. This smacro expands
  to take CAR of its argument. */
car x;
describe 'comtest6;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Module testing.

/* This is a test module which occurs at the top level just to make
  sure that the module type works. */
module testmodule;
endmodule;
describe 'testmodule;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Format testing. Put a big comment out there and look at it with
% various line lengths.

/* ********************
This is a test comment. We'll try do different things with it in
different contexts. Does it work?

  expr procedure fact n;
    if n < 2 then 1 else n * fact(n - 1);

Well hoop de doo! Is there anything else funny?

 +------------+----------+
 |  Column 1  |  Col. 2  |
 +------------+----------+
 | Aardvarks  |      345 |
 +------------+----------+
 | Zarfs      |        3 |
 +------------+----------+
/// */
global '(testvariable);

describe 'testvariable;
LINELENGTH 60;
describe 'testvariable;
LINELENGTH 50;
describe 'testvariable;
LINELENGTH 40;
describe 'testvariable;
LINELENGTH 30;
describe 'testvariable;
LINELENGTH 20;
describe 'testvariable;
LINELENGTH 10;
describe 'testvariable;


% ##### Records Package #####

global '(rec1 rec2);

% Simple test.
record rtest1;
rec1 := rtest1();

if rec1 neq array 'rtest1 then
  error(0, "Test 1 RECORD fails creation test!");
if null rtest1p rec1 then
  error(0, "Test 1 RECORD fails predicate test!");


% A record with two fields.
record rtest2 with field1 := 0, field2 := 1;

% Test default creation.
rec2 := rtest2();
if rec2 neq array('rtest2, 0, 1) then
  error(0, "Test 2 RECORD fails to create a record");
if null rtest2p rec2 then
  error(0, "Test 2 RECORD fails predicate test");
if rtest2p rec1 then
  error(0, "Test 2 RECORD fails to test record differences");



% Build a record with a predicate. Remove any old occurrence.
remd 'rtest3!?;
record rtest3 with field1 := 0, field2 := 1 has predicate = rtest3!?;

if not getd 'rtest3!? then 
  error(0, "Test 3 RECORD fails - no predicate built");
if rtest3!? rec2 then
  error(0, "Test 3 RECORD fails - predicate returns T on non RTEST3 record");
for each x in {'identifier, 12, 12.3, "a string", cdr getd 'car,
               '(a list), array("an", "array")}
  when rtest3!? x
  do error(0, {"Test 3 RECORD fails - predicate returns T on", x});

rec2 := rtest3();
if not rtest3!? rec2 then
  error(0, "Test 3 RECORD fails - predicate returns NIL on record");


% Check that the no-predicate option works.
remd 'rtest4p;      % Just to make sure.
record rtest4 with a := 34, b := 56 has no predicate;
if getd 'rtest4p then
  error(0, "Test 4 RECORD fails - NO PREDICATE option generates a predicate");


% Verify that the CONSTRUCTOR option works.
remd 'rtest5;
remd 'make-rtest5;
record rtest5 with r5a := 0, r5b := 1 has constructor;

if getd 'rtest5 then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR generates simple constructor");
if not getd 'make-rtest5 then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate constructor");
if not rtest5p make-rtest5() then
  error(0, "Test 5 RECORD fails - CONSTRUCTOR doesn't generate record");

% Verify that the named constructor works.
remd 'rtest6; remd 'please-make-rtest6;
record rtest6 with r6a := 0 has constructor = please!-make!-arecord;

if getd 'rtest6 then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR generates simple constructor");
if getd 'make-rtest6 then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR generates make- constructor");
if not getd 'please-make-arecord then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate constructor");
if not rtest6p please-make-arecord() then
  error(0, "Test 6 RECORD fails - CONSTRUCTOR doesn't generate record");


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp88/records.red0000644000175000017500000001263611526203062024162 0ustar  giovannigiovannimodule records; % A record package for RLISP using MSTRUCT.

% Author:  Bruce Florman.

% Copyright:  (c) 1989 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Revision History:
%  01/26/89 BAF -- Added this file header.
%       Sat Apr 24 12:38:32 1993 - Remove non-RLISP'88 functions (first,
%           etc.).

% BothTimes Load MSTRUCT;

%-----------------------------------------------------------------------
%      RECORD Declaration
%-----------------------------------------------------------------------

Expr PROCEDURE RecordStat();
% RECORD 
%  { /*  */ }
%  { WITH  :=  { ,  :=  }... }
%  { HAS >;

symbolic operator gb!-plus;

algebraic operator .+;

algebraic << let (~a .+ ~b) => gb!-plus(a,b) when idealp a and idealp b>>;

symbolic procedure gb!-times(a,b);
<>;

symbolic operator gb!-times;

algebraic operator .*;

algebraic << let (~a .* ~b) => gb!-times(a,b) when idealp a and idealp b>>;

symbolic procedure gb!-intersect(a,b);
   begin scalar tt,oo,q,v;
      tt:='!-!-t; v:= id!-vars!*;
      oo := eval '(torder '(lex));
      a := cdr test!-ideal reval a;
      b := cdr test!-ideal reval b;
      q:='i. append(
       for each p in a collect {'times,tt,p},
       for each p in b collect {'times,{'difference,1,tt},p});
      id!-vars!* := 'list . tt. cdr id!-vars!*;
      q:= errorset({'gb,mkquote q},nil,!*backtrace);
      id!-vars!* := v;
      eval{'torder,mkquote{oo}};
      if errorp q then rederr "ideal intersection failed";
      q:=for each p in cdar q join if not smemq(tt,p) then {p};
      return gb('i . q) end;

symbolic operator gb!-intersect;

algebraic operator intersection;

algebraic < gb!-intersect(a,b)
               when idealp a and idealp b>>;

newtok '((!. !:) id!-quotient);
algebraic operator id!-quotient;
infix id!-quotient;
precedence id!-quotient,/;

symbolic procedure gb!-quotient(a,b);
<>;

symbolic procedure gb!-quotient1(a,b);
begin scalar q; q:='i.cdr idquotienteval{ideal2list a,car b,id!-vars!*};
 return if null cdr b then q else gb!-intersect(q,gb!-quotient1(a,cdr b)) end;

symbolic operator gb!-quotient;
algebraic operator over;

algebraic < gb!-quotient(a,b) when idealp a and idealp b>>;

algebraic < gb!-quotient(a,b) when idealp a and idealp b>>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/ideals.rlg0000644000175000017500000000307011527635055024272 0ustar  giovannigiovanniFri Feb 18 21:27:56 2011 run on win32
I_setting(x,y,z);



torder revgradlex;


{{},lex}


u := I(x*z-y**2, x**3-y*z);


              2  3
u := i(x*z - y ,x  - y*z)

y member I(x,y^2);


0

x member I(x,y^2);


1

I(x,y^2) subset I(x,y);


1
         % yes
I(x,y) subset I(x,y^2);


0
         % no

% examples taken from Cox, Little, O'Shea: "Ideals, Varieties and Algorithms"




q1 := u .: I(x);


         3        2      2           2
q1 := i(x  - y*z,x *y - z , - x*z + y )
                        % quotient ideal

q2 := u .+ I(x^2 * y - z^2);


         3        2      2           2
q2 := i(x  - y*z,x *y - z , - x*z + y )
            % sum ideal

if q1 .= q2 then write "same ideal";


same ideal
    % test equality

intersection(u,I(y));


   3      2    2  2      2             3
i(x *y - y *z,x *y  - y*z , - x*y*z + y )
                   % ideal intersection

u .: I(y);


   3        2      2           2
i(x  - y*z,x *y - z , - x*z + y )


u .: I(x,y);


   3        2      2           2
i(x  - y*z,x *y - z , - x*z + y )


%-----------------------------------------------------

u1 := I(x,y^2);


           2
u1 := i(x,y )

u1u1:= u1 .* u1;


           4    2  2
u1u1 := i(y ,x*y ,x )
                       % square ideal
u0 :=I(x,y);


u0 := i(x,y)


% test equality/inclusion for u1,u1u1,u0

u1 .= u1u1;


0
     % no

u1 subset u1u1;


0
 % no

u1u1 subset u1;


1
 % yes

u1 .= u0;


0
       % no

u1 subset u0;


1
   % yes

intersection (I(x) , I(x^2,x*y,y^2)) .= intersection(I(x) , I(x^2,y));


1
 

end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 2 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/glexconv.red0000644000175000017500000003432611526203062024640 0ustar  giovannigiovannimodule glexconv;% Newbase - algorithm :
% Faugere,Gianni,Lazard,Mora .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


flag('(gvarslast),'share);

switch groebfac,trgroeb;

% Variables for counting and numbering .
fluid '(pcount!*);

fluid '(glexmat!*);% Matrix for the indirect lex ordering .

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Interface functions .

% Parameters;
%      glexconvert(basis,[vars],[maxdeg=n],[newvars={x,y,..}]) .

symbolic procedure glexconverteval u;
begin scalar !*groebfac,!*groebrm,!*factor,!*gsugar,
  v,bas,vars,maxdeg,newvars,!*exp;!*exp:=t;
 u:=for each p in u collect reval p;
 bas:=car u;u:=cdr u;
 while u do
 << v:=car u;u:=cdr u;
    if eqcar(v,'list)and null vars then vars:=v
     else if eqcar(v,'equal)then
      if(v:=cdr v)and eqcar(v,'maxdeg)then maxdeg:=cadr v
       else if eqcar(v,'newvars)then newvars:=cadr v
        else << prin2(car v);
                rerror(groebnr2,4,"glexconvert, keyword unknown")>>
       else rerror(groebnr2,5,
                       "Glexconvert, too many positional parameters")>>;
 return glexbase1(bas,vars,maxdeg,newvars)end;

put( 'glexconvert,'psopfn,'glexconverteval);

symbolic procedure glexbase1(u,v,maxdeg,nv);
begin scalar vars,w,nd,oldorder,!*gcd,!*ezgcd,!*gsugar;
 integer pcount!*;!*gcd:=t;
 w:=for each j in groerevlist u
  collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebnr2,6,"Empty list in Groebner");
 vars:=groebnervars(w,v);
 !*vdpinteger:=!*vdpmodular:=nil;
 if not flagp(dmode!*,'field)then !*vdpinteger:=t
  else if !*modular then !*vdpmodular:=t;
 if null vars then vdperr 'groebner;
 oldorder:=vdpinit vars;
                  % Cancel common denominators .
 w:=for each j in w collect reorder numr simp j;
                  % Optimize varable sequence if desired .
 w:=for each j in w collect f2vdp j;
 for each p in w do nd:=nd or not vdpcoeffcientsfromdomain!? p;
 if nd then
 << !*vdpmodular:= nil;!*vdpinteger:=t;glexdomain!*:=2 >>
  else  glexdomain!*:=1;
 if glexdomain!*=1 and not !*vdpmodular then !*ezgcd:=t;
 if null maxdeg then maxdeg:=200;
 if nv then nv:=groerevlist nv;
 if null nv then nv:=vars else
  for each x in nv do if not member(x,vars) then
  << rerror(groebnr2,7,{ "new variable ",x,
                           " is not a basis variable" })>>;
 u:=for each v in nv collect a2vdp v;
 gbtest w;
 w:=glexbase2(w,u,maxdeg);
 w:='list.for each j in w collect prepf j;
 setkorder oldorder;
 gvarslast:='list.vars;return w end;

fluid '(glexeqsys!* glexvars!* glexcount!* glexsub!*);

symbolic procedure glexbase2(oldbase,vars,maxdeg);
% In contrast to documented algorithm monbase ist a list of
% triplets(mon . cof . vect)
% such that cof * mon== vect modulo oldbase
%(cof is needed because of the integer algoritm).
begin scalar lexbase,staircase,monbase;
 scalar monom,listofnexts,vect,q,glexeqsys!*,glexvars!*,glexsub!*;
 integer n;
 if not groezerodim!?(oldbase,length vars)then
  prin2t "####### warning: ideal is not zerodimensional ######";
             % Prepare matrix for the indirect lex ordering .
  glexmat!*:=for each u in vars collect vdpevlmon u;
  monbase:=staircase:=lexbase:=nil;
  monom:=a2vdp 1;listofnexts:=nil;
  while not(monom=nil)do
  << if not glexmultipletest(monom,staircase)then
     << vect:=glexnormalform(monom,oldbase);
        q:=glexlinrel(monom,vect,monbase);
        if q then
        << lexbase:=q . lexbase;maxdeg:=nil;
           staircase:=monom . staircase >>
           else
           << monbase:=glexaddtomonbase(monom,vect,monbase);
             n:=n #+1;
             if maxdeg and n#> maxdeg then
              rerror(groebnr2,8,"No univar. polynomial within degree bound");
             listofnexts:=glexinsernexts(monom,listofnexts,vars)>> >>;
     if null listofnexts then monom:=nil
      else << monom:=car listofnexts;listofnexts:=cdr listofnexts >>
 >>;return lexbase end;

symbolic procedure glexinsernexts(monom,l,vars);
begin scalar x;
 for each v in vars do
 << x:=vdpprod(monom,v);
   if not vdpmember(x,l)then
   << vdpputprop(x,'factor,monom);
      vdpputprop(x,'monfac,v);
      l:=glexinsernexts1(x,l)>> >>;return l end;

symbolic procedure glexmultipletest(monom,staircase);
 if null staircase then nil
  else if vevmtest!?(vdpevlmon monom,vdpevlmon car staircase)
        then t
    else glexmultipletest(monom,cdr staircase);

symbolic procedure glexinsernexts1(m,l);
 if null l then list m
  else if glexcomp(vdpevlmon m,vdpevlmon car l)then m . l
        else car l . glexinsernexts1(m,cdr l);

symbolic procedure glexcomp(ev1,ev2);
% True if ev1 is greater than ev2;
% we use an indirect ordering here(mapping via newbase variables) .
 glexcomp0(glexcompmap(ev1,glexmat!*), glexcompmap(ev2,glexmat!*));

symbolic procedure glexcomp0(ev1,ev2);
 if null ev1 then nil
  else if null ev2 then glexcomp0(ev1,'(0))
        else if(car ev1 #- car ev2)=0
              then glexcomp0( cdr ev1,cdr ev2)
               else if car ev1 #< car ev2 then t else nil;

symbolic procedure glexcompmap(ev,ma);
 if null ma then nil
  else glexcompmap1(ev,car ma). glexcompmap(ev,cdr ma);

symbolic procedure glexcompmap1(ev1,ev2);
% The dot product of two vectors .
 if null ev1 or null ev2 then 0
  else(car ev1 #* car ev2)#+ glexcompmap1(cdr ev1,cdr ev2);

symbolic procedure glexaddtomonbase(monom,vect,monbase);
% Primary effect:(monom . vect) . monbase;
% Secondary effect: builds the equation system .
begin scalar x;
 if null glexeqsys!* then
 << glexeqsys!*:=a2vdp 0;glexcount!*:=-1 >>;
 x:=mkid('gunivar,glexcount!*:=glexcount!*+1);
 glexeqsys!*:=vdpsum(glexeqsys!*,vdpprod(a2vdp x,cdr vect));
 glexsub!*:=(x .(monom . vect)) . glexsub!*;
 glexvars!*:=x . glexvars!*;
 return(monom . vect). monbase end;

symbolic procedure glexlinrelold(monom,vect,monbase);
 if monbase then
  begin scalar sys,sub,auxvars,r,v,x;
   integer n;
   v:=cdr vect;
   for each b in reverse monbase do
   << x:=mkid('gunivar,n);n:=n + 1;
    v:=vdpsum(v,vdpprod(a2vdp x,cddr b));
    sub:=( x . b). sub;
    auxvars:=x . auxvars >>;
   while not vdpzero!? v do
   << sys:=vdp2f vdpfmon(vdplbc v,nil). sys;v:=vdpred v >>;
   x:=sys;sys:=groelinsolve(sys,auxvars);
   if null sys then return nil;
          % Construct the lex polynomial .
   if !*trgroeb then prin2t "======= constructing new basis polynomial";
   r:=vdp2f vdpprod(monom,car vect)./ 1;
   for each s in sub do
    r:= addsq(r,multsq(vdp2f vdpprod(cadr s,caddr s)./ 1,
                            cdr assoc(car s,sys)));
   r:=vdp2f vdpsimpcont f2vdp numr r;return r end;

symbolic procedure glexlinrel(monom,vect,monbase);
 if monbase then
  begin scalar sys,r,v,x;
   v:=vdpsum(cdr vect,glexeqsys!*);
   while not vdpzero!? v do
   << sys:=vdp2f vdpfmon(vdplbc v,nil). sys;v:=vdpred v >>;
   x:=sys;sys:=groelinsolve(sys,glexvars!*);
   if null sys then return nil;
   r:=vdp2f vdpprod(monom,car vect)./ 1; % Construct the lex polynomial.
   for each s in glexsub!* do
    r:= addsq(r,multsq(vdp2f vdpprod(cadr s,caddr s)./ 1,
                            cdr assoc(car s,sys)));
   r:=vdp2f vdpsimpcont f2vdp numr r;
   return r end;

symbolic procedure glexnormalform(m,g);
% Reduce 'm' wrt basis 'g';
% the reduction product is preserved in m for later usage .
 begin scalar cof,vect,r,f,fac1;
  if !*trgroeb then prin2t "======= reducing ";
  fac1:=vdpgetprop(m,'factor);
  if fac1 then vect:=vdpgetprop(fac1,'vector);
  if vect then
  <>
  else
  <>;
  r:=glexnormalform1(f,g,cof);
  vdpputprop(m,'vector,r);
  if !*trgroeb then
  < ";vdpprint cdr r>>;return r end;


symbolic procedure glexnormalform1(f,g,cof);
begin scalar f1,c,vev,divisor,done,fold,a,b;
 fold:=f;f1:=vdpzero();a:= a2vdp 1;
 while not vdpzero!? f do
 begin vev:=vdpevlmon f;c:=vdplbc f;
  divisor:=groebsearchinlist(vev,g); if divisor then done:=t;
  if divisor then
   if !*vdpinteger then
   <>
     else f:=groebreduceonesteprat(f,nil,c,vev,divisor)
    else
     <>end;
  if not done then return cof.fold;
  f:=groebsimpcont2(f1,cof);cof:=secondvalue!*; return cof.f end;


symbolic procedure groelinsolve(equations,xvars);
(begin scalar r,q,test,oldmod,oldmodulus;
  if !*trgroeb then prin2t "======= testing linear dependency ";
  r:=t;
  if not !*modular and glexdomain!*=1 then
  <> where !*ezgcd=nil;
  if null r then return nil;
  r:=groelinsolve1(equations,xvars);
  if null r then return nil;
         % Divide out the common content .
  for each s in r do if not(denr cdr s=1)then test:=t;
  if test then return r;
  q:=numr cdr car r;
% for each s in cdr r do
%  if q neq 1 then
%   q:=gcdf!*(q,numr cdr s);
% if q=1 then return r;
% r:=for each s in r collect
%  car s .(quotf(numr cdr s,q)./ 1);
  return r end)where !*ezgcd=!*ezgcd;% Stack old value.

symbolic procedure groelinsolve1(equations,xvars);
% Gaussian elimination in integer mode;
% free of unexact divisions(see Davenport et al,CA,pp 86 - 87
% special cases: trivial equations are ruled out early.
% INPUT:
% equations:     List of standard forms.
% xvars:
% OUTPUT:
% list of pairs(var.solu) where solu is a standard quotient.
% Internal data structure: standard forms as polynomials invars.
begin scalar oldorder,x,p,solutions,val,later,break,gc,field;
 oldorder:=setkorder xvars;
 field:=dmode!* and flagp(dmode!*,'field);
 equations:=for each eqa in equations collect reorder eqa;
 for each eqa in equations do
  if eqa and domainp eqa then break:= t;
 if break then goto empty;
 equations:=sort(equations,function grloelinord);
again: break:=nil;
 for each eqa in equations do if not break then
     % First step: eliminate equations of type 23=0 and 17 * u=0
     %                                    and 17 * u + 22=0.
 <> >>;
 if break=0 then goto again else if break then goto empty;
     % Perform an elimination loop.
 if null equations then goto ready;
 equations:=sort(equations,function grloelinord);
 p:=car equations;x:=mvar p;
 equations:=for each eqa in cdr equations collect
  if mvar eqa=x then
  <>;
   if not domainp eqa then eqa:=numr multsq(eqa ./ 1,1 ./ lc eqa);
   %%%%%%eqa:=groelinscont(eqa,xvars);
   eqa>>
   else eqa;
  later:=p.later;goto again;
ready:   % Do backsubstitutions .
  while later do
  <>;
     x:=mvar p;
     val:=if lc p=1 then negf red p ./ 1
      else quotsq(negf red p ./ 1,lc p ./ 1);
     solutions:=(x.val).solutions>>;
   if break then goto empty else goto finis;
empty: solutions:=nil;
finis: setkorder oldorder;
  solutions:=for each s in solutions collect
   car s.(reorder numr cdr s ./ reorder denr cdr s);
  return solutions end;

symbolic procedure grloelinord(u,v);
% Apply ordop to the mainvars of 'u' and 'v'.
 ordop(mvar u,mvar v);

%symbolic procedure groelinscont(f,vars);
%% Reduce content from standard form f.
% if domainp f then f else
%  begin scalar c;
%   c:=groelinscont1(lc f,red f,vars);
%   if c=1 then return f;
%   prin2 "*************content: ";print c;
%   return quotf(f,c)end;

%symbolic procedure groelinscont1(q,f,vars);
%% Calculate the contents of standard form 'f'.
% if null f or q=1 then q
%  else if domainp f or not member(mvar f,vars)then gcdf!*(q,f)
%   else groelinscont1(gcdf!*(q,lc f),red f,vars);

symbolic procedure groelinsub(s,a);
% 's' is a standard form linear in the top level variables,
% a is an assiciation list(variable.sq). ...
% The value is the standard form,where all substitutions
% from a are done in 's'(common denominator ignored).
 numr groelinsub1(s,a);

symbolic procedure groelinsub1(s,a);
 if domainp s then s  ./ 1
  else(if x then addsq(multsq(cdr x,lc s ./ 1), y)
          else addsq(lt s.+nil ./ 1,y))
    where x=assoc(mvar s,a), y=groelinsub1(red s,a);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/new1.tex0000644000175000017500000000345411526203062023711 0ustar  giovannigiovannithe following is new in july 2001:

\subsubsection{$greduce$\_$orders$: Reduction with several term orders}
The shortest polynomial with different polynomial term orders is computed
with the operator $greduce$\_$orders$:
 
\begin{description}
\ttindex{$greduce$\_$orders$}
\item[{\it greduce\_orders}]($exp$, \{$exp1$, $exp2$, \ldots , $expm$\}
[,\{$v_1$,$v_2$ \ldots $v_n$\}]);
 
where {\it exp} is an expression and $\{exp1, exp2,\ldots , expm\}$ is
a list of any number of expressions or equations. The list of variables
$v_1,v_2 \ldots v_n$ may be omitted; if set, the variables must be a list.
\end{description}
 
The expression {\it exp} is reduced by {\it greduce} with the orders
in the shared variable {\it gorders}, which must be a list of term
orders (if set). By default it is set to
 
\begin{center}
$\{revgradlex,gradlex,lex\}$
\end{center}
 
The shortest polynomial is the result.
The order with the shortest polynomial is set to the shared variable
{\it gorder}. A Groebner basis of the system \{$exp1$, $exp2$, \ldots ,
$expm$\} is computed for each element of $orders$.
With the default setting {\it gorder} in most cases will be set
to {\it revgradlex}.
If the variable set is given, these variables are taken; otherwise all
variables of the system \{$exp1$, $exp2$, \ldots , $expm$\} are
extracted.
 
The Groebner basis computations can take some time; if interrupted, the
intermediate result of the reduction is set to the shared variable
$greduce$\_$result$, if one is done already. However, this is not
nesessarily the minimal form.
 
If the variable {\it gorders} should be set to orders with a parameter,
the term oder has to be replaced by a list; the first element is the
term oder selected, followed by its parameter(s), e.g.
 
\begin{center}
$orders:=\{\{gradlexgradlex,2\},\{lexgradlex,2\}\}$
\end{center}
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/traverso.red0000644000175000017500000001002311526203062024644 0ustar  giovannigiovannimodule traverso;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Buchberger algorithm base on "sugar" strategy;
% see Giovini-Mora-Niesi-Robbiano-Traverso:
% One sugar gube,please. ISSAC 91 proceddings,pp 49-54.

!*gtraverso!-sloppy:=t;

symbolic procedure gtraverso(g0,fact,abort1);
begin scalar g,d,s,h,p,!*gsugar;
 fact:=nil;abort1:=nil;!*gsugar:=t;
 g0:=for each fj in g0 join if not vdpzero!? fj then
  <>;
main_loop:
 if null g0 and null d then return gtraversofinal g;
 if g0 then <>
  else
  <>;
      if vevzero!? vdpevlmon h then % base 1 found
      <<   !*trgroeb and groebmess5(p,h);d:=g:=g0:=nil>>>>;
       h:=groebenumerate h;!*trgroeb and groebmess5(p,h);
       groebsavelterm h;
          % New pair list.
      d:=gtraversopairlist(h,g,d);
          % New basis.
      g:=nconc(g,{h});goto main_loop end;

symbolic procedure gtraversopairlist(gk,g,d);
% gk: new polynomial,g: current basis,d: old pair list.
begin scalar a,ev,r,n,nn,q;
    % Delete triange relations from old pair list.
 d:=gtraversopairsdiscard1(gk,d);
    % Build new pair list.
 ev:=vdpevlmon gk;
 for each p in g do if not groebbuchcrit4t(ev,a:=vdpevlmon p)
  then r:=vevlcm(ev,a).r
% One line added and one line changed 26.3.2001 (Melenk).
  else<>;
    % Delete from new pairs equivalents to coprime lcm.
  for each q in r do for each p in n do if car p = q then n:=delete(p,n);
    % Discard multiples: collect survivers in n.
  if !*gtraverso!-sloppy then !*gsugar:=nil;
  n:=groebcplistsort n;!*gsugar:=t;
  nn:=n;n:=nil;
  for each p in nn do
  <>;
  return groebcplistmerge(d,reversip n)end;

symbolic procedure gtraversopairsdiscard1(gk,d);
% Crit B.
begin scalar gi,gj,tij,evk;
 evk:=vdpevlmon gk;
 for each pij in d do
 <>;return d end;

symbolic procedure vevstrictlydivides!?(ev1,ev2);
   not(ev1=ev2)and vevdivides!?(ev1,ev2);

symbolic procedure gtraversofinal g;
% Final reduction and sorting.
begin scalar r,p,!*gsugar;
 g:=vdplsort g; % Descending.
 while g do
 <>;
 return list reversip r end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebfac.red0000644000175000017500000001165111526203062024557 0ustar  giovannigiovannimodule groebfac; % Factorization of polynomials during Groebner calc'n.

imports factor;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure groebfactorize (h,abort1,g,g99);
  begin scalar r,tim,gctim,h1,groebactualg99!*,groebfabort!*,test;
    scalar s;
    s:=!*gsugar and gsugar h;
    groebactualg99!* := g99; groebactualg!* := g;
    groebfabort!* := abort1;
    if vdpgetprop(h,'irreducible) then return groebfactorize3 h;
    tim := time();
    gctim := gctime();
         !*trgroeb and groebmess7 h;
    r := if r := vdpgetprop(h,'factors) then r
     else if !*groebrm then groebfactorize1 h
     else if not !*vdpmodular then groebfactorize2 h
     else nil;
    factortime!* := factortime!* + time() - tim -(gctime()-gctim);
    if null r then <>;
               if cdr r then !*trgroeb and groebmess14 (h,r);
    vdpputprop(h,'factors,r);
    for each p in r do
       if vdpmember(car p,g) then test:= car p;
    if test then
       <>;
    h1 := car r;
    for each p in r do
       if vdpmember(car p,abort1) then
            <>
       else vdpputprop(car p,'irreducible,t);
    if null r then r := list h1;     % at least one
    if null cdr r then groebfactorize3 caar r;
       % inherit sugar if no substantial factor.
    if !*gsugar then
     if null cdr r then gsetsugar(caar r,s) else
       for each p in r do gsetsugar(car p,vdptdeg car p);
    return 'factor . r end;

symbolic procedure groebfactorize1 h;
  % factorize: separate monomial factors which were detected already;
   begin scalar monf,vp,n,e,h1,h2,vp2;
        monf := vdpgetprop(h,'monfac);
        if null monf then
             return if not !*vdpmodular then groebfactorize2 h
                                       else nil;     % no factor
        h2 := vdpdivmon (h,vbcfi 1,monf);

       if groebmonfac neq 0 then
       <<                                 % now build a polynomial from
        n := 0;                           % each variable in MONFAC
        for each x in monf do
            <> >> >>
        else
        !*trgroeb and groebmess15 monf;
                  % append body of orig. poly, factorized
        if not vdpzero!? h2 and
           not vevzero!? vdpevlmon h2 then
               <>;
                   % ascending sorting
    %   if length vp = 1 then return nil;
        h1 := vp;
        return reverse  for each x in h1 collect list vdpenumerate x end;

symbolic procedure groebfactorize2 h;
  % tries to factorize a h-polynomial via REDUCE factorizer
   begin scalar h1,h2,!*factor; !*factor := t;
        h1 := groefctrf vdp2f h;
        if null cdr h1 then return nil;
        if null cddr h1      % only one element in factorization list
           and cdr cadr h1 = 1     % and multiplicity = 1
                then return nil;
        h2 := for each l in cdr h1 join
            for i:=1:cdr l collect car l;
        h2 := vdplsort for each p in h2 collect vdpsimpcont f2vdp p;
        return for each x in h2 collect list vdpenumerate x end;

symbolic procedure groefctrf p;
   (fctrf p) where !*factor=t,current!-modulus = current!-modulus;

symbolic procedure groebfactorize3 h;
  % additional efforts to factor something.
 <>;

endmodule;;end ;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebopt.red0000644000175000017500000000634111526203062024630 0ustar  giovannigiovannimodule groebopt;


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%   optimization of the sequence of variables
%

% Optimization of variable sequence;the theoretical background can be found
% in  Boege/Gebauer/Kredel,J.Symb.Comp(1986)I,83-98
% Techniques modfied to the following algorithm
%
% x > y if
%  x appears in a higher power than y
%       or
%  the highest powers are equal, but x appears more often with that power.
%
% An explicit dependency DEPENDS X,Y will supersede the optimality.

symbolic procedure vdpvordopt(w,vars);
 % w : list of polynomials(standard forms),vars: list of variables;
 % returns(w . vars), both reorderdered
 begin scalar c;vars:=sort(vars,'ordop);
  c:=for each x in vars collect x . 0 . 0;
  for each poly in w do vdpvordopt1(poly,vars,c);
  c:=sort(c,function vdpvordopt2);
  intvdpvars!*:=for each v in c collect car v;
  vars:=vdpvordopt31 intvdpvars!*;
  if !*trgroeb then
  <>;
  return(for each poly in w collect reorder poly). vars end;

symbolic procedure vdpvordopt1(p,vl,c);
 if null p then 0 else
 if domainp p or null vl then 1 else
 if mvar p neq car vl then vdpvordopt1(p,cdr vl,c)else
 begin scalar var,pow,slot;integer n;
  n:=vdpvordopt1(lc p,cdr vl,c);
  var:=mvar p;pow:=ldeg p;slot:=assoc(var,c);
  if pow #> cadr slot then
  <>
  else rplacd(cdr slot,n #+ cddr slot);
  return n #+ vdpvordopt1(red p,vl,c)end;

symbolic procedure vdpvordopt2(sl1,sl2);
% Compare two slots from the power table .
<>;

symbolic procedure vdpvordopt31 u;
% ' u ' : list of variables;
% returns ' u ' reordered to respect dependency ordering .
begin scalar v,y;if null u then return nil;
 v:=foreach x in u join
  <>;
 return nconc(vdpvordopt31 setdiff(u,v), v)end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groesolv.doc0000755000175000017500000000341211526203062024641 0ustar  giovannigiovanni%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%			  Details of ordering relation
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

                   David Hartley 

In the problem

        on groebopt;
        depend x,w;
        groesolve({w+x-y,x-z},{w,x,y,z});

        -> {{w= - x + y,z=x}}.

turning on trgroeb shows that the groebopt module chooses

        optimized sequence of kernels: (w y z x)

so the "sort(intvdpvars!*,function vdpvordopt3)" line in vdpvordop has not
picked up the dependency (which should put x before w).

Writing a D b for depends(a,b) and a > b for the "optimal" ordering
ignoring dependency constraints, vdpvordopt3 defines a relation >> by

        a >> b iff a D b or a > b.

Since we have w > y > z > x and x D w, we get both w >> x and x >> w, so >>
is not antisymmetric.

I tried to correct this by setting

        a >> b iff a D b or not(b D a) and a > b,

which makes >> antisymmetric, but this is still no good, since we get w >> y
and y >> x but x >> w, so it's not transitive.

I've racked my brains trying to think how to construct an ordering relation
from D and >, but can't come up with anything non-trivial. The problem
seems to be that D is only a partial ordering. Maybe someone who knows a
bit more set theory could help. 

The answer I've settled on is very crude, and disrupts > a lot. Starting
with the complete set of variables V, define a strictly shrinking sequence
of subsets by

	V(1) = V
	V(i+1) = {x in V(i) | x D y for some y in V(i)}

Then, for each x in V define grade(x) to be the maximum i such that x is in
V(i). The grading can be combined with > in the usual way to give an
ordering relation: grade(x) > grade(y) or (grade(x) = grade(y) and x > y).

mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/hilbert2.red0000644000175000017500000003130311526203062024516 0ustar  giovannigiovannimodule hilberts;% Hilbert series of a set of Monomials .

% Author : Joachim Hollman,Royal Institute for Technology,Stockholm,Sweden
%  email :  < joachim@nada.kth.se >
% Improvement : Herbert Melenk,ZIB Berlin,Takustr 9,email : < melenk@zib.de >

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


comment

A very brief " description " of the method used.

M=k[x,y,z]/(x^2*y,x*z^2,y^2)
                    x.
0 --> ker(x.) --> M --> M --> M/x --> 0

M/x = k[x,y,z]/(x^2*y,x*z^2,y^2,x) = k[x,y,z]/(x,y^2)

ker(x.) =((x) +(x^2*y,x*z^2,y^2))/(x^2*y,x*z^2,y^2) =

        =(x,y^2)/(x^2*y,x*z^2,y^2)

Hilb(ker(x.)) = Hilb        - Hilb
                 (x,y^2)    (x^2*y,x*z^2,y^2)

        = 1/(1-t)^3 - Hilb                -
                          k[x,y,z]/(x,y^2)

          -(1/(1-t)^3 - Hilb
                          k[x,y,z]/(x^2*y,x*z^2,y^2)

        = Hilb -Hilb
              M     k[x,y,z]/(x,y^2)

If you only keep the numerator in Hilb = N(t)/(1-t)^3
                                       M
then you get

(1-t)N(t) = N(t)  - t(N(t) - N(t)   )
      I       I+(x)       I       Ann(x) + I

i.e.

 N(t) = N(t)  + t N(t)           (*)
  I       I+(x)      Ann(x) + I

Where
      I          =(x^2*y,x*z^2,y^2)
      I +(x)    =(x,y^2)
      I + Ann(x) =(x*y,z^2,y^2)
      N(t) is the numerator polynomial in Hilb
      I                                       k[x,y,z]/I

Equation(*)is what we use to compute the numerator polynomial,i.e.
we " divide out " one variable at a time until we reach a base case.
( One is not limited to single variables but I don't know of any good
strategy for selecting a monomial.)

Usage : hilb({ monomial_1,...,monomial_n } [,variable ]);

fluid '(nvars!*);

% ************** MACROS ETC. **************

smacro procedure term(c,v,e);{ ' times,c,{ ' expt,v,e } };

% -------------- safety check --------------

smacro procedure varp m;and(m,atom(m), not(numberp(m)));

smacro procedure checkexpt m;
 eqcar(m,' expt)and varp(cadr(m)) and numberp(caddr(m));

smacro procedure checksinglevar m;
 if varp(m)then t else checkexpt(m);

smacro procedure checkmon m;
 if checksinglevar(m)then t
 else if eqcar(m,' times)then checktimes(cdr(m)) else nil;

smacro procedure checkargs(monl,var);
 listp monl and eqcar(monl,' list)and
  varp(var)and checkmonl(monl);

symbolic procedure makevector(n,pat);
begin scalar v;v:=mkvect n;
 for i:=1:n do putv(v,i,pat);return v end;

% -------------- monomials --------------

smacro procedure allocmon n;makevector(n,0);

smacro procedure getnthexp(mon,n);getv(mon,n);

smacro procedure setnthexp(mon,n,d);putv(mon,n,d);

smacro procedure gettdeg mon;getv(mon,0);

smacro procedure settdeg(mon,d);putv(mon,0, d);

% -------------- ideals --------------

smacro procedure theemptyideal();{ nil,nil };

smacro procedure getnextmon ideal;
<< x:=caadr ideal;
   if cdadr ideal then ideal:={ car ideal,cdadr ideal }
    else ideal:=theemptyideal();x >>;

smacro procedure notemptyideal ideal;cadr ideal;

smacro procedure firstmon ideal;caadr ideal;

smacro procedure appendideals(ideal1,ideal2);
{ car ideal2,append(cadr ideal1,cadr ideal2)};

symbolic procedure insertvar(var,ideal);
% Inserts variable var as last generator of ideal
begin scalar last;last:={ makeonevarmon(var)};
 return({ last,append(cadr ideal,last)})end;

symbolic procedure addtoideal(mon,ideal);
% Add mon as generator to the ideal
begin scalar last;last:={ mon };
 if ideal = theemptyideal() then rplaca(cdr(ideal), last)
  else rplacd(car(ideal), last);
 rplaca(ideal,last)end;

% ************** END OF MACROS ETC. **************

% ************** INTERFACE TO ALGEBRAIC MODE **************

symbolic procedure hilbsereval u;
begin scalar l,monl,var;l:=length u;
 if l < 1 or l > 2 then rerror(groebnr2,17,
       "Usage: hilb({monomial_1,...,monomial_n} [,variable])")
  else if l = 1 then
  << monl:=reval car u;var:=' x >> else
    << monl:= reval car u;var:=reval cadr u >>;
  monl:= ' list . for each aa in(cdr monl)collect reval aa;
  if not checkargs(monl,var)then rerror(groebnr2,18,
        "Usage: hilb({monomial_1,...,monomial_n} [,variable])");
%  return(aeval
%            {'QUOTIENT,
%                 coefflist2prefix(NPol(gltb2arrideal(monl)), var),
%           {'EXPT,list('PLUS,1,list('TIMES,-1,var)},
%               nvars!*)});
 return(aeval coefflist2prefix(npol(gltb2arrideal(monl)),var)) end;

% Define "hilb" to be the algebraic mode function
put(' hilb,' psopfn,' hilbsereval);

symbolic procedure checkmonl monl;
begin scalar flag,tmp;flag:=t;monl:=gltbfix(monl);
 while monl and flag do
 << tmp:=car monl;
    flag:= checkmon(tmp);monl:=cdr monl >>;
 return flag end;

symbolic procedure checktimes m;
begin scalar flag,tmp;flag:=t;
 while m and flag do
 << tmp:=car m;flag:=checksinglevar(tmp);
    m:=cdr m >>;return flag end;

symbolic procedure coefflist2prefix(cl,var);
begin scalar poly;integer i;
 for each c in cl do
 << poly:=term(c,var,i). poly;
   i:=i + 1 >>;return ' plus . poly end;

symbolic procedure indets l;
% "Indets"  returns a list containing all the
% indeterminates of l.
% L is supposed to have a form similar to the variable
% GLTB in the Groebner basis package.
%(LIST(EXPT Z 2)(EXPT X 2) Y)
begin scalar varlist;
 for each m in l do
  if m neq ' list then
   if atom(m) then varlist:=union({ m },varlist)
    else if eqcar(m,' expt)then varlist:=union({ cadr(m)},varlist)
    else varlist:=union(indets(cdr(m)),varlist);
 return varlist end;

symbolic procedure buildassoc l;
% Given a list of indeterminates(x1 x2 ...xn) we produce
% an a-list of the form(( x1 . 1)(x2 . 2)...(xn . n)).
begin integer i;
 return(for each var in l collect progn(i:=i #+1,var . i)) end;

symbolic procedure mons l;
% Rewrite the leading monomials(i . e . GLTB).
% the result is a list of monomials of the form :
%(variable . exponent)or(( variable1 . exponent1)...
% (variablen . exponentn))
%
% mons('(LIST(EXPT Z 2)(EXPT X 2)(TIMES Y(EXPT X 3))));
%(((Y . 1)(X . 3))(X . 2)(Z . 2)).
begin scalar monlist;
 for each m in l do
  if m neq ' list then monlist:=
    if atom(m)then(m . 1). monlist
     else if eqcar(m,' expt)
      then(cadr m . caddr m). monlist
      else(for each x in cdr(m)collect monsaux(x)) . monlist;
 return monlist end;

symbolic procedure monsaux m;
 if eqcar(m,'expt)then cadr m . caddr m else m . 1;

symbolic procedure lmon2arrmon m;
% List-monomial to array-monomial
% a list-monomial has the form:(variable_number . exponent)
% or is a list with entries of this form.
% "variable_number" is the number associated with the variable,
% see buildassoc().
begin scalar mon;integer tdeg;mon:=allocmon nvars!*;
 if listp m then
  for each varnodotexp in m do
  << setnthexp(mon,car varnodotexp,cdr varnodotexp);
      tdeg:=tdeg + cdr varnodotexp >>
  else
  << setnthexp(mon,car m,cdr m);tdeg:=tdeg + cdr m >>;
 settdeg(mon,tdeg);return mon end;

symbolic procedure gltbfix l;
% Sometimes GLTB has the form(list(list ...))
% instead of(list ...).
 if listp cadr l and caadr(l)= ' list then cadr l else l;

symbolic procedure gege(m1,m2);
 if gettdeg(m1)>= gettdeg(m2)then t else nil;

symbolic procedure getendptr l;
begin scalar ptr;while l do << ptr:=l;l:=cdr l >>;
 return ptr end;

symbolic procedure gltb2arrideal xgltb;
% Convert the monomial ideal given by GLTB(in list form)
% to a list of vectors where each vector represents a monomial.
begin scalar l;l:=indets(gltbfix(xgltb));nvars!*:=length(l);
 l:=sublis(buildassoc(l), mons(gltbfix(xgltb)));
 l:=for each m in l collect lmon2arrmon(m);
 l:=sort(l,' gege);
 return { getendptr(l), l } end;

% ************** END OF INTERFACE TO ALGEBRAIC MODE **************

%************** PROCEDURES **************

symbolic procedure npol ideal;
% Recursively computes the numerator of the Hilbert series.
begin scalar v,si;v:=nextvar ideal;
 if not v then return basecasepol ideal;
 si:=splitideal(ideal,v);
 return shiftadd(npol car si,npol cadr si)end;

symbolic procedure dividesbyvar(var,mon);
begin scalar div;if getnthexp(mon,var)= 0 then return nil;
 div:=allocmon nvars!*;
 for i:=1 : nvars!* do setnthexp(div,i,getnthexp(mon,i));
 setnthexp(div,var, getnthexp(mon,var)- 1);
 settdeg(div,gettdeg mon - 1);return div end;

symbolic procedure divides(m1,m2);
% Does m1 divide m2?
% m1 and m2 are monomials;
% result: either nil(when m1 does not divide m2)or m2 / m1.
begin scalar m,d,i;i:=1;m:=allocmon(nvars!*);
 settdeg(m,d:=gettdeg(m2)- gettdeg(m1));
 while d >= 0 and i <= nvars!* do
 << setnthexp(m,i,d:=getnthexp(m2,i)- getnthexp(m1,i));
    i:= i+1 >>;
    return if d < 0 then nil else m end;

symbolic procedure shiftadd(p1,p2);
% p1 + z * p2;
% p1 and p2 are polynomials(nonempty coefficient lists).
begin scalar p,pptr;pptr:=p:=car p1 . nil;
 p1:=cdr p1;
 while p1 and p2 do
 << rplacd(pptr,(car p1 + car p2). nil);
   p1:=cdr p1;p2:=cdr p2;pptr:=cdr pptr >>;
 if p1 then rplacd(pptr,p1)
  else rplacd(pptr,p2);return p end;

symbolic procedure remmult(ipp1,ipp2);
% The union of two ideals with redundancy of generators eliminated.
begin scalar fmon,inew,isearch,primeflag,x;
 % fix;x is used in the macro...
 x:=nil;inew:=theemptyideal();
 while notemptyideal(ipp1)and notemptyideal(ipp2)do
  begin if gettdeg(firstmon(ipp2)) < gettdeg(firstmon(ipp1))
   then << fmon:=getnextmon(ipp1);isearch:=ipp2 >>
    else << fmon:=getnextmon(ipp2);isearch:=ipp1 >>;
 primeflag:=t;
 while primeflag and notemptyideal(isearch)do
  if divides(getnextmon(isearch), fmon)then primeflag:=nil;
 if primeflag then addtoideal(fmon,inew)end;
 return if notemptyideal(ipp1)then appendideals(inew,ipp1)
  else appendideals(inew,ipp2)end;

symbolic procedure nextvar ideal;
% Extracts a variable in the ideal suitable for division.
begin scalar m,var,x;x:=nil;
 repeat
 << m:=getnextmon ideal;
   var:=getvarifnotsingle m;
    >> until var or ideal = theemptyideal();
 return var end;

symbolic procedure getvarifnotsingle mon;
% Returns nil if the monomial is in a single variable,
% otherwise the index of the second variable of the monomial.
begin scalar foundvarflag,exp;integer i;
 while not foundvarflag do
 << i:=i + 1;exp:=getnthexp(mon,i);
    if exp > 0 then foundvarflag:=t >>;
 foundvarflag:=nil;
 while i < nvars!* and not foundvarflag do
 << i:=i + 1;exp:=getnthexp(mon,i);
    if exp > 0 then foundvarflag:=t >>;
 if foundvarflag then return i else return nil end;

symbolic procedure makeonevarmon vindex;
% Returns the monomial consisting of the single variable vindex.
begin scalar mon;mon:=allocmon nvars!*;
 for i:=1 : nvars!* do setnthexp(mon,i,0);
 setnthexp(mon,vindex,1);
 settdeg(mon,1);return mon end;

symbolic procedure splitideal(ideal,var);
% Splits the ideal into two simpler ideals.
begin scalar div,ideal1,ideal2,m,x;x:=nil;
 ideal1:=theemptyideal();ideal2:=theemptyideal();
 while notemptyideal(ideal)do
 << m:=getnextmon(ideal);
    if div:=dividesbyvar(var,m)then addtoideal(div,ideal2)
     else addtoideal(m,ideal1)>>;
    ideal2:=remmult(ideal1,ideal2);ideal1:=insertvar(var,ideal1);
 return { ideal1,ideal2 } end;

symbolic procedure basecasepol ideal;
% In the base case every monomial is of the form Xi ^ ei;
% result : the numerator polynomial of the Hilbert series
%          i.e.(1 - z ^ e1)*(1 - z ^ e2)* ...
begin scalar p,degsofar,e;integer tdeg;
 for each mon in cadr ideal do tdeg:=tdeg + gettdeg mon;
 p:=makevector(tdeg,0);putv(p,0,1);degsofar:=0;
 for each mon in cadr ideal do
 << e:=gettdeg mon;
    for j:= degsofar step -1 until 0 do
     putv(p,j + e,getv(p,j+e)- getv(p,j));
    degsofar:=degsofar + e >>;
 return vector2list p end;

symbolic procedure vector2list v;
% Convert a vector v to a list.  No type checking is done.
begin scalar u;
  for i:=upbv v step -1 until 0 do u:=getv(v,i).u;
  return u end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/grinter2.red0000644000175000017500000000572611526203062024551 0ustar  giovannigiovannimodule grinter2;% Interface of Groebner package to REDUCE:
% autoloadint entry points to operators of groebnr2.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

symbolic procedure groebnr2entry(fn,u);
<>;


symbolic procedure groebnr2load();load!-package'groebnr2;

put('gsort,'psopfn,'(lambda(u)(groebnr2entry 'gsort u)));
put('gsplit,'psopfn,'(lambda(u)(groebnr2entry 'gsplit u)));
put('gspoly,'psopfn,'(lambda(u)(groebnr2entry 'gspoly u)));
put('gvars,'psopfn,'(lambda(u)(groebnr2entry 'gvars u)));
put('greduce,'psopfn,'(lambda(u)(groebnr2entry 'greduce u)));
put('greduce_orders,'psopfn,
 '(lambda(u)(groebnr2entry 'greduce_orders u)));
put('preduce,'psopfn,'(lambda(u)(groebnr2entry 'preduce u)));
put('groebnert,'psopfn,'(lambda(u)(groebnr2entry 'groebnert u)));
put('preducet,'psopfn,'(lambda(u)(groebnr2entry 'preducet u)));
put('groebnerm,'psopfn,'(lambda(u)(groebnr2entry 'groebnerm u)));
put('glexconvert,'psopfn,'(lambda(u)(groebnr2entry 'glexconvert u)));
put('hilbertpolynomial,'psopfn,
 '(lambda(u)(groebnr2entry 'hilbertpolynomial u)));
put('gzerodim!?,'psopfn,
    '(lambda(u)(groebnr2entry 'gzerodim!? u)));
put('dd_groebner,'psopfn,'(lambda(u)(groebnr2entry 'dd_groebner u)));

put('trgroeb,'simpfg,'((t(groebnr2load))));
put('trgroebs,'simpfg,'((t(groebnr2load)(setq !*trgroeb t))
                      (nil(setq !*trgroeb nil))));
put('trgroebr,'simpfg,'((t(groebnr2load))));
put('groebstat,'simpfg,'((t(groebnr2load))));
put('groebweak,'simpfg,'((t(groebnr2load))));
% put('groebres,'simpfg,'((t(groebnr2load))));

symbolic procedure groebtestrestriction(a1,a2);
<>;
put('groebner_walk,'psopfn,
 '(lambda(u)(groebnr2entry'groebner_walk u)));

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebcri.red0000644000175000017500000001275311526203062024607 0ustar  giovannigiovannimodule groebcri;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Criteria for the Buchberger algorithm .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

smacro procedure atleast2elementsin u;
% Test if u has at least a cadr element .
 u and cdr u;

symbolic procedure groebbuchcrit4(p1,p2,e);
% Buchberger criterion 4 . p1 and p2 are distributive
% polynomials . e is the least common multiple of
% the leading exponent vectors of the distributive
% polynomials p1 and p2 . groebBuchcrit4(p1,p2,e)returns a
% boolean expression . True,if the reduction of the
% distributive polynomials p1 and p2 is necessary else false .
% Orig:
%     e neq vevsum(vdpevlmon p1,vdpevlmon p2);
 << e;groebbuchcrit4t(vdpevlmon p1,vdpevlmon p2)>>;

symbolic procedure groebbuchcrit4t(e1,e2);
% Nonconstructive test of lcm(e1,e2)=e1 + e2;
% equivalent: no matches of nonzero elements .
 if null e1 or null e2 then nil else
  if(car e1 neq 0)and(car e2 neq 0)then t
   else groebbuchcrit4t(cdr e1,cdr e2);

symbolic procedure groebinvokecritbuch4(p,d2);
% Buchberger's criterion 4 is tested on the pair p and the list
% D2 of critical pairs is updated with respect to that crit .
% Result is the updated D2 .
begin scalar p1,p2,vev1,vev2,f1,f2,fd,b4;
 p1:=cadr p;p2:=caddr p;vev1:=vdpevlmon p1;vev2:=vdpevlmon p2;
 f1:=vdpgetprop(p1,'monfac);f2:=vdpgetprop(p2,'monfac);
                   % Discard known common factors first .
 if f1 and f2 then
 << fd:=vevmin(f1,f2);
    b4:=groebbuchcrit4t(vevdif(vev1,fd), vevdif(vev2,fd));
    if b4 and    % Is the body itself a common factor ?
             vevdif(vev1,f1)=vevdif(vev2,f2)
                         % Test if the polys reduced by their monom .
                         % factor are equal .
                     and groebbuchcrit4compatible(p1,f1,p2,f2)
                       then b4:=nil >>
  else b4:=groebbuchcrit4t(vev1,vev2);
 if b4 then d2:=append(d2,{p})else b4count!*:=b4count!* + 1;
 return d2 end;

symbolic procedure groebbuchcrit4compatible(p1,f1,p2,f2);
% p1,p2 polys,f1,f2 exponent vectors(monomials), which are known to
% be factors of their f;
% tests, if p1 / f1=p2 / f2 .
 if vdpzero!? p1 then vdpzero!? p2
  else if vdplbc p1=vdplbc p2 and
    groebbuchcrit4compatiblevev(vdpevlmon p1,f1,vdpevlmon p2,f2)
   then groebbuchcrit4compatible(vdpred p1,f1,vdpred p2,f2)
    else nil;

symbolic procedure groebbuchcrit4compatiblevev(vev1,f1,vev2,f2);
 if null vev1 then null vev2 else
  if(if f1 then car vev1 - car f1 else car vev1)=
  (if f2 then car vev2 - car f2 else car vev2)then
    groebbuchcrit4compatiblevev(cdr vev1,
     if f1 then cdr f1 else nil,cdr vev2,
     if f2 then cdr f2 else nil)else nil;

symbolic procedure groebinvokecritf d1;
% GroebInvokeCritF tests a list D1 of critical pairs . It cancels all
% critical pairs but one in D1 having the same lcm(i . e . car
% component)as car(D1). This only one is chosen,if possible,
% such that it doesn't satisfy groebBuchcrit4 .
% Version: moeller upgraded 5.7.87 .
begin scalar tp1,p2,active;
 tp1:=caar d1;active:=atleast2elementsin d1;
 while active do
 << p2:=cadr d1;
    if car p2=tp1 then
    << fcount!*:=fcount!* + 1;
       if not groebbuchcrit4t(cadr p2,caddr p2)then d1:=cdr d1
        else d1:=groedeletip(p2,d1);
       active:=atleast2elementsin d1 >>
     else active:=nil >>;
 return d1 end;

symbolic procedure groebinvokecritm(p1,d1);
% D1 is a list of critical pairs,p1 is a critical pair .
% Crit M tests,if the lcm of p1 divides one of the lcm's in D1 .
% If so,this object is eliminated .
% Result is the updated D1 .
<< for each p3 in d1 do if buchvevdivides!?(car p1,car p3)then
   << mcount!*:=mcount!* + 1;
      d1:=groedeletip(p3,d1)>>;    %  Criterion M .
    d1 >>;

symbolic procedure groebinvokecritb(fj,d);
% D is a list of critical pairs,fj is a polynomial .
% Crit B allows to eliminate a pair from D,if the leading monomial
% of fj divides the lcm of the pair,but the lcm of fj with each of
% the members of the pair is not the lcm of the pair itself .
% Result is the updated D .
<< for each p in d do
    if buchvevdivides!?(vdpevlmon fj,car p)and
     tt(fj,cadr p)neq car p and % Criterion B .
     tt(fj,caddr p)neq car p then
      << bcount!*:=bcount!* +1;d:=delete(p,d)>>;d >>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebsor.red0000644000175000017500000000565611526203062024641 0ustar  giovannigiovannimodule groebsor;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Maintenance of lists of critical pairs(sorting etc .).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure groebcplistsortin(p,pl);
% Distributive polynomial critical pair list sort. pl is a
% special list for Groebner calculation, p is a pair.
% Returns the updated list pl(p sorted into).
 if null pl then list p else
 <>;

symbolic procedure groebcplistsortin1(p,pl);
% Destructive insert of ' p ' into nonnull ' pl ' .
 if not groebcpcompless!?(car pl,p)
  then <>
   else if null cdr pl then rplacd(pl,list p)
   else groebcplistsortin1(p,cdr pl);

symbolic procedure groebcplistsort g;
 <> where gg=nil;

symbolic procedure groebcplistmerge(pl1,pl2);
% Distributive polynomial critical pair list merge. pl1 and pl2
% are critical pair lists used in the Groebner calculation.
% groebcplistmerge(pl1,pl2) returns the merged list.
begin scalar cpl1,cpl2,sl;
 if null pl1 then return pl2;
 if null pl2 then return pl1;
 cpl1:=car pl1;cpl2:=car pl2;
 sl:=groebcpcompless!?(cpl1,cpl2);
 return(if sl then cpl1 . groebcplistmerge(cdr pl1,pl2)
  else cpl2 . groebcplistmerge(pl1,cdr pl2)) end;

symbolic procedure groebcpcompless!?(p1,p2);
% Compare 2 pairs wrt their sugar(=cadddr) or their lcm(=car).
 if !*gsugar then
 (if not(d=0)then d < 0 else if not(q=0)then q < 0 else
   vdpnumber(caddr p1)< vdpnumber(caddr p2)
  ) where d=cadddr p1 - cadddr p2,q=vevcomp(car p1,car p2)
  else vevcompless!?(car p1,car p2);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebtra.red0000644000175000017500000004155711526203062024624 0ustar  giovannigiovannimodule groebtra;

% Calculation of a Groebner base with the Buchberger algorithm
% including the backtracking information which denotes the
% dependency between base and input polynomials .

% Authors: H. Melenk, H.M. Moeller, W. Neun;date : August 2000


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

switch groebopt,groebfac,trgroeb,trgroebs,trgroeb1,
       trgroebr,groebstat,groebprot;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Interface

symbolic procedure groebnertraeval u;
% Backtracking Groebner calculation .
begin integer n;scalar !*groebfac,!*groebrm,!*groebprot,!*gsugar;
 n:=length u;if n=1 then return groebnertra1(reval car u,nil,nil)
  else if n neq 2 then rerror(groebnr2,10,
                    "groebnert called with wrong number of arguments")
  else return groebnertra1(reval car u,reval cadr u,nil)end;

put('groebnert,'psopfn,'groebnertraeval);

symbolic procedure groebnertra1(u,v,mod1);
% Buchberger algorithm system driver. u is a list of expressions
% and v a list of variables or NIL in which case the variables in u
% are used.
begin scalar vars,w,y,z,x,np,oldorder,groetags!*,tagvars;
 integer pcount!*,nmod;
 u:=for each j in getrlist u collect
 <>;
       if not eqcar(mod1,'list) then
        rerror(groebnr2,14,"illegal column weights specified");
       vars:=groebnervars(z,v);
       tagvars:=for i:=1 : nmod collect mkid('! col,i);
       w:=for each vect in w collect
       <>;
      w:=for each j in u collect cdr j;
                  % Optimize varable sequence if desired .
      if !*groebopt then <>;
      w:=pair(for each x in u collect car x,w);
      w:=for each j in w collect
      <>;
      if not !*vdpInteger then
      <>>>;
      w:=groebtra2 w;
      w:=if mod1 then groebnermodres(w,nmod,tagvars)else
                       groebnertrares w;
      setkorder oldorder;
      gvarslast:='list . vars;return w end;

symbolic procedure groebnertrares w;
begin scalar c,u;
 return'list . for each j in w collect
 <> end;

symbolic procedure groebnermodres(w,n,tagvars);
begin scalar x,c,oldorder;
 c:=for each u in w collect prepsq vdpgetprop(u,'cofact);
 oldorder:=setkorder tagvars;
 w:=for each u in w collect
'list . <> else nil>>;
 setkorder oldorder;
         % Reestablish term order for output .
 w:=for each u in w collect vdp2a a2vdp u;
 w:=pair(w,c);
 return'list . for each p in w collect
  if cdr p=0 then car p else
   {'equal,car p,cdr p} end;

symbolic procedure preduceteval pars;
% Trace version of PREDUCE;
% parameters:
%     1      expression to be reduced,
%        (formula or equation)
%     2      polynomials or equations;base for reduction;
%            must be equations with atomic lhs;
%     3      optional: list of variables .
begin scalar vars,x,y,u,v,w,z,oldorder,!*factor,!*exp,
 !*gsugar;integer pcount!*;!*exp:=t;
 pars:=groeparams(pars,2,3);
 y:=car pars;u:=cadr pars;v:= caddr pars;
 u:=for each j in getrlist u collect
 <>;
 if null u then rerror(groebnr2,15,"empty list in preducet");
 w:=for each p in u collect cdr p;% The polynomials .
 groedomainmode();
 vars:=if null v then
  for each j in gvarlis w collect !*a2k j else  getrlist v;
 if not vars then vdperr'preducet;
 oldorder:=vdpinit vars;
 u:=for each x in u collect
 <>;
 w:=for each j in u collect
 <>;
 if not eqcar(y,'equal)then y:={'equal,y,y};
 x:=a2vdp caddr y;          % The expression .
 vdpputprop(x,'cofact,simp cadr y);% The lhs(name etc.) .
 w:=tranormalform(x,w,'sort,'f);
 u:={'equal,vdp2a w,prepsq vdpgetprop(w,'cofact)};
 setkorder oldorder;return u end;

put('preducet,'psopfn,'preduceteval);

symbolic procedure groebnermodeval u;
% Groebner for moduli calculation .
( if n=0 or n > 3 then
   rerror(groebnr2,16,
    "groebnerm called with wrong number of arguments")
  else groebnertra1(reval car u,
        if n >= 2 then reval cadr u else nil,
        if n >= 3 then reval caddr u else'(list 1))
  )where n=length u;

put('groebnerm,'psopfn,'groebnermodeval);

symbolic procedure groebtra2 p;
% Setup all global variables for the Buchberger algorithm;
% printing of statistics .
begin scalar groetime!*,tim1,spac,spac1,p1,
 pairsdone!*,factorlvevel!*;integer factortime!*;
 groetime!*:=time();
 vdponepol();% We construct dynamically .
 hcount!*:=pcount!*:=mcount!*:=fcount!*:=
 bcount!*:=b4count!*:=hzerocount!*:=basecount!*:=0;
 if !*trgroeb then
 <>;
 spac:=gctime();p1:= groebtra3 p;
 if !*trgroeb or !*trgroebr or !*groebstat then
 <>;
 return p1 end;

symbolic procedure groebtra3 g0;
begin scalar x,g,d,d1,d2,p,p1,s,h,g99,one;
 x:=for each fj in g0 collect vdpenumerate trasimpcont fj;
 for each fj in x do g:=vdplsortin(fj,g0);
 g0:=g;g:=nil;
% iteration :
 while(d or g0)and not one do
 begin if g0 then
 <<       % Take next poly from input .
    h:=car g0;g0:=cdr g0;p:={nil,h,h}>>
 else
 <<       % Take next poly from pairs .
    p:=car d;d:=cdr d;
    s:=traspolynom(cadr p, caddr p);tramess3(p,s);
    h:=groebnormalform(s,g99,'tree);% Piloting wo cofact .
    if vdpzero!? h then groebmess4(p,d)
     else h:=trasimpcont tranormalform(s,g99,'tree,'h)>>;
 if vdpzero!? h then goto bott;
 if vevzero!? vdpevlmon h then % Base 1 found .
 <<       tramess5(p,h);
   g0:=d:=nil;g:={h};goto bott>>;
 s:= nil;
                  % h polynomial is accepted now .
 h:=vdpenumerate h;
                        tramess5(p,h);
                              % Construct new critical pairs .
 d1:=nil;
 for each f in g do
  if groebmoducrit(f,h)then
  <>>>;
                  groebmess51 d1;
 d2:=nil;
 while d1 do
 <>;
 d:=groebinvokecritb(h,d);
 d:=groebcplistmerge(d,d2);
 g:=h . g;
 g99:=groebstreeadd(h,g99);
                            groebmess8(g,d);
bott: end;
 return groebtra3post g end;

symbolic procedure groebtra3post g;
% Final reduction .
begin scalar r,p;
 g:=vdplsort g;
 while g do
 <>;
 return reversip r end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Reduction of polynomials .
%

symbolic procedure tranormalform(f,g,type,mode);
% General procedure for reduction of one polynomial from a set;
%  f is a polynomial, G is a set of polynomials either in
% a search tree or in a sorted list;
% type describes the ordering of the set G :
%  'TREE     G is a search tree,
%  'SORT     G is a sorted list,
%  'LIST     G is a list, but not sorted .
%  f has to be reduced modulo G;
% version for idealQuotient : doing side effect calculations for
% the cofactors;only headterm reduction .
begin scalar c,vev,divisor,break;
 while not vdpzero!? f and not break do
 begin vev:=vdpevlmon f;c:=vdplbc f;
  divisor:=groebsearchinlist(vev,g);
  if divisor and !*trgroebs then
    <>;
  if divisor then if !*vdpinteger  then
   f:=trareduceonestepint(f,nil,c,vev,divisor)
  else f:=trareduceonesteprat(f,nil,c,vev,divisor)
  else break:=t end;
 if mode='f then f:=tranormalform1(f,g,type,mode);
 return f end;

symbolic procedure tranormalform1(f,g,type,mode);
% Reduction of subsequent terms .
begin scalar c,vev,divisor,break,f1;
 mode:=nil;f1:=f;type:=nil;
 while not vdpzero!? f and not vdpzero!? f1 do
 <>;
       if divisor then
       <>>>>>;
 return f end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  special reduction procedures

symbolic procedure trareduceonestepint(f,dummy,c,vev,g1);
% Reduction step for integer case :
% calculate f=a * f - b * g a,b such that leading term vanishes
%                      (vev of lvbc g divides vev of lvbc f)
% and  calculate f1=a * f1;
% return value=f,secondvalue f1 .
begin scalar vevlcm,a,b,cg,x,fcofa,gcofa;
 dummy:=nil;fcofa:=vdpgetprop(f,'cofact);
 if null fcofa then fcofa:=nil ./ 1;
 gcofa:=vdpgetprop(g1,'cofact);
 if null gcofa then gcofa:=nil ./ 1;
 vevlcm:=vevdif(vev,vdpevlmon g1);
 cg:=vdpLbc g1;
            % Calculate coefficient factors .
 x:=vbcgcd(c,cg);a:=vbcquot(cg,x);b:=vbcquot(c,x);
 f:=vdpilcomb1(f,a,vevzero(),g1,vbcneg b,vevlcm);
 x:=vdpilcomb1tra(fcofa,a,vevzero(),gcofa,vbcneg b,vevlcm);
 vdpputprop(f,'cofact,x);return f end;

symbolic procedure trareduceonesteprat(f,dummy,c,vev,g1);
% Reduction step for rational case :
% calculate f=f - g / vdpLbc(f)
begin scalar x,fcofa,gcofa,vev;
 dummy:=nil;fcofa:=vdpgetprop(f,'cofact);
 gcofa:=vdpgetprop(g1,'cofact);
 vev:=vevdif(vev,vdpevlmon g1);
 x:=vbcneg vbcquot(c,vdplbc g1);
 f:=vdpilcomb1(f,a2vbc 1,vevzero(),g1,x,vev);
 x:=vdpilcomb1tra(fcofa,a2vbc 1,vevzero(),gcofa,x,vev);
 vdpputprop(f,'cofact,x);return f end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Calculation of an S-polynomial .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure traspolynom(p1,p2);
begin scalar s,ep1,ep2,ep,rp1,rp2,db1,db2,x,
 cofac1,cofac2;
 if vdpzero!? p1  then return p1;if vdpzero!? p1  then return p2;
 cofac1:=vdpgetprop(p1,'cofact);cofac2:=vdpgetprop(p2,'cofact);
 ep1:=vdpevlmon p1;ep2:=vdpevlmon p2;ep:=vevlcm(ep1,ep2);
 rp1:=vdpred p1;rp2:=vdpred p2;
 db1:=vdplbc p1;db2:=vdplbc p2;
 if !*vdpinteger then
 <>;
 ep1:=vevdif(ep,ep1);ep2:=vevdif(ep,ep2);db2:=vbcneg db2;
 s:=vdpilcomb1(rp2,db1,ep2,rp1,db2,ep1);
 x:=vdpilcomb1tra(cofac2,db1,ep2,cofac1,db2,ep1);
 vdpputprop(s,'cofact,x);return s end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Normalisation with cofactors taken into accounta .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure trasimpcont p;
 if !*vdpinteger then trasimpconti p else trasimpcontr p;

% Routines for integer coefficient case :
% calculation of contents and dividing all coefficients by it .

symbolic procedure trasimpconti p;
% Calculate the contents of p and divide all coefficients by it .
begin scalar res,num,cofac;
 if vdpzero!? p then return p;
 cofac:=vdpgetprop(p,'cofact);
 num:=car vdpcontenti p;
 if not vbcplus!? num then num:=vbcneg num;
 if not vbcplus!? vdpLbc p then num:=vbcneg num;
 if vbcone!? num then return p;
 res:=vdpreduceconti(p,num,nil);
 cofac:=vdpreducecontitra(cofac,num,nil);
 res:=vdpputprop(res,'cofact,cofac);
 return res end;

% Routines for rational coefficient case :
% calculation of contents and dividing all coefficients by it .

symbolic procedure trasimpcontr p;
% Calculate the contents of p and divide all coefficients by it .
begin scalar res,cofac;
 cofac:=vdpgetprop(p,'cofact);
 if vdpzero!? p or vdplbc p then return p;
 res:=vdpreduceconti(p,vdplbc p,nil);
 cofac:=vdpreducecontitra(cofac,vdplbc p,nil);
 res:=vdpputprop(res,'cofact,cofac);return res end;

symbolic procedure vdpilcomb1tra(cofac1,db1,ep1,cofac2,db2,ep2);
% The linear combination, here done for the cofactors(standard quotients);
 addsq(multsq(cofac1,vdp2f vdpfmon(db1,ep1)./ 1),
         multsq(cofac2,vdp2f vdpfmon(db2,ep2)./ 1));

symbolic procedure vdpreducecontitra(cofac,num,dummy);
% Divide the cofactor by a number .
<>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Special handling of moduli .
%

symbolic procedure groebmoducrit(p1,p2);
 null groetags!*
  or pnth(vdpevlmon p1,groetags!*)=pnth(vdpevlmon p2,groetags!*);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Trace messages .
%

symbolic procedure tramess0 x;
 if !*trgroeb then
  <>;

symbolic procedure tramess1(x,p1,p2);
 if !*trgroeb then
 <>;

symbolic procedure tramess5(p,pp);
 if car p then                  % print for true h-Polys
 <>>>
  else if !*trgroeb then             % print for input polys
  <>;

symbolic procedure tramess3(p,s);
 if !*trgroebs then <<
   prin2 "S-polynomial from ";groebpairprint p;vdpprint s;prin2t "with cofactor";
   writepri(mkquote prepsq  vdpgetprop(s,'cofact),'only);
   groetimeprint();terprit 3>>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/buchbg.red0000644000175000017500000011121611546212573024250 0ustar  giovannigiovannimodule buchbg;% Central Groebner base code: Buchberger algorithm.

% Authors: H. Melenk,H. M. Moeller,W. Neun
% ZIB Berlin,August 2000

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


flag('(groebrestriction groebresmax gvarslast groebmonfac
           groebprotfile glterms),'share);

groebrestriction:=nil;groebresmax:=300;groebmonfac:=1;
groecontcount!*:=10;
!*gsugar:=t;
!*groelterms:=t;
!*groebfullreduction:=t;
!*groebdivide:=t;

switch groebopt,trgroeb,trgroebs,trgroeb1,
 trgroebr,groebfullreduction,groebstat,groebprot;

% Variables for counting and numbering.

% Option'groebopt'"optimizes" the given input
%                         polynomial set(variable ordering).
% option'trgroeb'Prints intermediate
%                         results on the output file.
% option'trgroeb1'Prints internal representation
%                         of critical pair list d.
% option'trgroebs'Prints's'- polynomials
%                         on the output file.
% option'trgroebr'Prints(intermediate)results and
%                         computation statistics.
% option'groebstat'The statistics are printed.
%
% option'groebrm'Multiplicities of factors in h-polynomials are reduced
%                         to simple factors .
% option'groebdivide'The algorithm avoids all divisions(only for modular
%                         calculation), if this switch is set off.
% option'groebprot'Write a protocol to the variable "groebprotfile".

symbolic procedure buchvevdivides!?(vev1,vev2);
% Test : vev1 divides vev2 ? for exponent vectors vev1,vev2.
vevmtest!?(vev2,vev1)and
(null gmodule!* or gevcompatible1(vev1,vev2,gmodule!*));

symbolic procedure gevcompatible1(v1,v2,g);
% Test whether'v1'and'v2'belong to the same vector column.
 if null g then t
  else if null v1 then(null v2 or gevcompatible1('(0), v2,g))
  else if null v2 then gevcompatible1(v1,'(0), g)else
(car g=0 or car v1=car v2)
     and gevcompatible1(cdr v1,cdr v2,cdr g);

symbolic procedure gcompatible(f,h);
 (null gmodule!* or gevcompatible1(vdpevlmon f,vdpevlmon h,gmodule!*));

%symbolic procedure gcompatible(f,h);
% null gmodule!* or gevcompatible1(vdpevlmon f,vdpevlmon h,gmodule!*);

symbolic procedure groebmakepair(f,h);
% Construct a pair from polynomials'f'and'h'.
begin scalar ttt,sf,sh;
 ttt:=tt(f,h);
 return if !*gsugar then
 << sf:=gsugar(f)#+ vevtdeg vevdif(ttt,vdpevlmon f);
  sh:=gsugar(h)#+ vevtdeg vevdif(ttt,vdpevlmon h);
{ttt,f,h,max(sf,sh)}>>
 else{ttt,f,h}end;

% The 1-polynomial will be constructed at run time
% because the length of the vev is not known in advance.
fluid'(vdpone!*);

symbolic procedure vdponepol;
% Construct the polynomial=1.
 vdpone!*:=vdpfmon(a2vbc 1,vevzero());

symbolic procedure groebner2(p,r);
% Setup all global variables for the Buchberger algorithm,
% printing of statistics.
 begin scalar groetime!*,tim1,spac,spac1,p1,factortime!*,
  pairsdone!*,factorlevel!*,groesfactors!*,!*gcd;
  factortime!*:=0;groetime!*:=time();
  vdponepol();% we construct dynamically
  hcount!*:=0;mcount!*:=0;fcount!*:=0;
  bcount!*:=0;b4count!*:=0;hzerocount!*:=0;
  basecount!*:=0;!*gcd:=t;glterms:={'list};
  groecontcount!*:=10;
  if !*trgroeb then
  <>;
   spac:=gctime();
   p1:= if !*groebfac or null !*gsugar
    then groebbasein(p,!*groebfac,r)where !*gsugar=nil
    else gtraverso(p,nil,nil);
   if !*trgroeb or !*trgroebr or !*groebstat then
   <>;
     prin2"(time spent for garbage collection:  ";
     prin2 spac1;prin2t "          milliseconds)";terprit 1;
     prin2"H-polynomials total: ";prin2t hcount!*;
     prin2"H-polynomials zero : ";prin2t hzerocount!*;
     prin2"Crit M hits: ";prin2t mcount!*;
     prin2"Crit F hits: ";prin2t fcount!*;
     prin2"Crit B hits: ";prin2t bcount!*;
     prin2"Crit B4 hits: ";prin2t b4count!*>>;return p1 end;

smacro procedure testabort h;
 vdpmember(h,abort1)or
'cancel=( abort2:=groebtestabort(h,abort2));

symbolic procedure groebenumerate f;
%'f'is a temporary result. Prepare it for medium range storage
% and ssign a number.
 if vdpzero!? f then f else
 <> >>;f>>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Buchberger's Algorithm
%
% INPUT :   G0={f1,...,fr} set of nonzero polynomials.
% OUTPUT:   groebner basis(list of nonzero polynomials).
%
% internal variables:
%
% problems  list of problems to be processed. Problems is non nil,
%           if the inital problem was split by a successful factoring.
% results   Collection of results from problems.
% g         Basis under construction.
% g1        Local pointer to g.
% d         List of critical pairs during algorithm.
% d1,d2     Local lists of pairs during update of d.
% f,fj      Polynomials.
% p,p1,p2   Pairs.
% s,h       Polynomials in the central part of the algorithm
%       (the "s-poly" and the "h-poly" selon Buchberger).
% g99       Set of polynomials used for reduction.
% abort1    List of polynomials in factorization context.
%           S calculation branch can be cancelled if one of
%           these polys is detected.
% abort2    List of sets of polynomials. If a new h polynomial
%           is calculated,it should be removed from the sets.
%           If one set becomes null,the set restriction is
%           fulfilled and the branch can be cancelled.

% Fix by Herbert Melenk, Feb 2011

symbolic procedure groebbasein(g0,fact,abort1);
begin scalar abort2,d,d1,d2,g,gg,g1,g99,h,hlist,lasth,lv,p,problems,vars_g,
   p1,results,s,x;integer gvbc,probcount!*;
 groebabort!*:=abort1;lv:=length vdpvars!*;
 for each p in g0 do if vdpzero!? p then g0:=delete(p,g0);
 if !*groebprereduce then g0:=groebprereduce g0;
 x:=for each fj in g0 collect
 <>;
  if !*groebprot then
  for each f in x do
  <>;
  g0:=x;
                                   % Establish the initial problem
  problems:={{nil,nil,nil,g0,abort1,nil,nil,vbccurrentmode!*,nil,nil}};
  !*trgroeb and groebmess1(g,d);
  go to macroloop;
macroloop:
while problems and gvbc < groebresmax do
begin
                                   % Pick up next problem
 x:=car problems;d:=car x;g:=cadr x;
 % g99:=groeblistreconstruct caddr x;
 g99:=vdplsort caddr x;g0:=cadddr x;abort1:=nth(x,5);
 abort2:=nth(x,6);pairsdone!*:=nth(x,7);h:=nth(x,8);
                     % vbccurrentmode!*
 factorlevel!*:=nth(x,9);groesfactors!*:=nth(x,10);
 problems:=cdr problems;
 g0:=% Sort'g0',but keep factor in first position
 if factorlevel!* and  g0 and cdr g0 then car g0.vdplsort cdr g0
  else vdplsort g0;x:=nil;lasth:=nil;
            !*trgroeb and groebmess23(g0,abort1,abort2);
 while d or g0 do
 begin
  if groebfasttest(g0,g,d,g99)then go to stop;
  !*trgroeb and groebmess50 g;
  if g0 then
  <>else
  <>
  >>;
  if vdpzero!? h then go to bott;
  if vevzero!? vdpevlmon h then % base 1 found
  <>;
  if testabort(h)then
  <>;
  s:= nil;
                % Look for implicit or explicit factorization
  hlist:=nil;
  if groebrestriction!* then hlist:=groebtestrestriction(h,abort1);
  if not hlist and fact then hlist:=groebfactorize(h,abort1,g,g99);
  if hlist='zero then go to bott;
  if groefeedback!* then g0:=append(groefeedback!*,g0);
  groefeedback!*:=nil;
               % Factorisation found but only one factor survived
  if hlist and length hlist=2 then<>;
  if hlist then
  <>;
              %'h'polynomial is accepted now
  h:=groebenumerate h;!*trgroeb and groebmess5(p,h);
                          % Construct new critical pairs
  d1:=nil;
               !*trgroeb and groebmess50(g);
  gg:=g;vars_g:=variables g;                                  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  for each f in g do
   if(car p or % That means "not an input polynomial"
       not member(vdpnumber h.vdpnumber f,pairsdone!*)
        )and gcompatible(f,h)then
  <>
  >>;
  if vars_g neq variables g then g:=gg;                       %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
                !*trgroeb and groebmess51 d1;
  d2:=nil;
  while d1 do
  <>;
  d:=groebinvokecritb(h,d);
  d:=groebcplistmerge(d,d2);
                     % Monomials and binomials
  if vdplength h < 3 and car p then
  <>;% Base{1} found
                                               % very late now
  if fact and not vdpzero!? f then
  <>;
                                   % Generate new subproblems
     x:=0;
     for each h in hlist do
     <>;
      g:=g1:=nil;% Cancel actual final reduction
      f:=nil >> >>;
    if f and vdpevlmon h neq vdpevlmon f then
    <>else
     if f and not vdpzero!? f then g1:=append(g1,{f})>>;
 return g1.problems end;

symbolic procedure groebbasein3 results;
% Final postprocessing: remove multiple bases from the result.
 begin scalar x,g,f,p1,p2;
  x:=nil;g:=results;p1:=p2:=0;
  while results do
  <> >>;
 results:=if null x then{{vdpone!*}}else x;
 return results end;

fluid'(!*vbccompress);

symbolic procedure groebchain(h,f,g99);
% Test if a chain from h-plynomials can be computed from the'h'.
begin scalar count,found,h1,h2,h3;
 secondvalue!*:=nil;
 return h;% Erst einmal.
 if not buchvevdivides!?(vdpevlmon h,vdpevlmon f)
  then return h;
 h2:=h;h1:=f;found:=t;count:=0;
 while found do
 <>
  else if vdpone!? h3 then
  <>
  else if buchvevdivides!?(vdpevlmon h3,vdpevlmon h2)then
  <>
  else found:=nil>>;
  return if count > 0 then
  <>else h end;


symbolic procedure groebencapsulate(hlist,d,g0,g,g99,
               abort1,abort2,problems,fact);
%'hlist'is a factorized h-poly. This procedure has the job to
% form new problems from hlist and to add them to problems.
% Result is problems.
% Standard procedure: only creation of subproblems.
begin scalar factl,     % List of factorizations under way.
 u,y,z;integer fc;
 if length vdpvars!* > 10 or car hlist neq'factor then
  return groebencapsulatehardcase(hlist,d,g0,g,g99,
   abort1,abort2,problems,fact);
                        % Encapsulate for each factor.
  factl:=groebrecfactl{hlist};
               !*trgroeb and groebmess22(factl,abort1,abort2);
  for each x in reverse factl do
  <>;
   return problems end;

symbolic procedure groebencapsulatehardcase(hlist,d,g0,g,g99,
               abort1,abort2,problems,fact);
%'hlist'is a factorized h-poly. This procedure has the job to
% form new problems from hlist and to add them to problems.
% Result is problems.
% First the procedure tries to compute new h-polynomials from the
% remaining pairs which are not affected by the factors in hlist.
% Purpose is to find further factorizations and to do calculations
% in common for all factors in order to shorten the separate later
% branches.
begin scalar factl,     % List of factorizations under way.
  factr,     % Variables under factorization.
  break,d1,d2,f,fl1,gc,h,p,pd,p1,s,u,y,z;
 integer fc;
 factl:={hlist};factr:=vdpspace car cadr hlist;
 for each x in cdr hlist do
 for each p in x do factr:=vevunion(factr,vdpspace p);
% ITER:
                             % Now process additional pairs.
 while d or g0 do
 begin
  break:=nil;
  if g0 then
  <<               % Next poly from input.
   s:=car g0;g0:=cdr g0;p:={nil,s,s}>>
    else
  <<               % Next poly fropm pairs.
   p:=car d;d:=delete(p,d);
   if not vdporthspacep(car p,factr)then
    s:=nil else
    <> >>;
    if null s or not vdporthspacep(vdpevlmon s,factr)then
    <<                     % Throw away s polynomial .
     f:=cadr p;
     if not vdpmember3(f,g0,g,gc)then gc:=f.gc;
     f:=caddr p;
     if car p and not vdpmember3(f,g0,g,gc)
      then gc:=f.gc;go to bott>>;
     h:=groebnormalform(s,g99,'tree);
     if vdpzero!? h and car p then !*trgroeb and groebmess4(p,d);
     if not vdporthspacep(vdpevlmon h,factr)then
     <<                     % Throw away h-polynomial.
      f:=cadr p;
      if not vdpmember3(f,g0,g,gc)then gc:=f.gc;
      f:=caddr p;
      if car p and not vdpmember3(f,g0,g,gc)then gc:=f.gc;
      go to bott>>;
%%%  if car p then
%%%    pairsdone!*:=(vdpnumber cadr p.vdpnumber caddr p).pairsdone!*;
     if vdpzero!? h then go to bott;
     if vevzero!? vdpevlmon h then     % Base 1 found.
      go to stop;
     h:=groebsimpcontnormalform h;%  Coefficients normalized.
     if testabort h then
     <>;
     s:=nil;hlist:=nil;
     if groebrestriction!* then hlist:=groebtestrestriction(h,abort1);
     if hlist='cancel then go to stop;
     if not hlist and fact then
     hlist:=groebfactorize(h,abort1,g,g99);
     if groefeedback!* then g0:=append(groefeedback!*,g0);
     groefeedback!*:=nil;
     if hlist and length hlist=2 then
     <>;
     if hlist then
     <>;
     h:=groebenumerate h;      % Ready now.
                    !*trgroeb and groebmess5(p,h);
                          % Construct new critical pairs.
     d1:=nil;
     for each f in g do
      if tt(f,h)=vdpevlmon(f)and gcompatible(f,h)then
      <>;
                 !*trgroeb and groebmess51 d1;
       d2:=nil;
       while d1 do
       <>;
        d:=groebinvokecritb(h,d);d:=groebcplistmerge(d,d2);
        if vdplength h < 3 then
        <>;
 return res end;

symbolic procedure groebtestabort(h,abort2);
% Tests if h is member of one of the sets in abort2.
% if yes, it is deleted. If one wet becomes null,the message
% "CANCEL is returned, otherwise the updated abort2.
begin scalar x,break,res;
          % First test the occurence.
 x:=abort2;
 while x and not break do
 <>;
 if not break then return abort2;% not relvevant
 break:=nil;
 while abort2 and not break do
 <>;
   !*trgroeb and groebmess25(h,res);
  if break then return'cancel;
  return res end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Reduction of polynomials.
%

symbolic procedure groebnormalform(f,g,type);
 groebnormalform0(f,g,type,nil);

symbolic procedure groebnormalform0(f,g,type,m);
% General procedure for reduction of one polynomial from a set
%'f'is a polynomial,'g'is a set of polynomials either in
%  a search tree or in a sorted list.
%'f'has to be reduced modulo'g'.
%'m'is indicator,whether a selection('m'is true)is wanted.
begin scalar a,break,c,divisor,done,f0,f1,f2,fold,gl,vev;
 integer n,s1,s2;
 scalar zzz;
  if !*groebweak and !*vdpinteger
   and groebweakzerotest( f,g,type)then return f2vdp nil;
  fold:=f;f1:=vdpzero();a:= vbcfi 1;
  gsetsugar(f1,gsugar f);
  while not vdpzero!? f do
  begin
   vev:=vdpevlmon f;c:=vdplbc f;
   if not !*groebfullreduction and not vdpzero!? f1 then g:=nil;
    if null g then
    <>;
    divisor:=groebsearchinlist(vev,g);
    if divisor then<>else gl:=cdr gl>> >>;
ret:  return f1 end;

symbolic procedure groecontentcontrol u;
%'u'indicates,that a substantial content reduction was done;
% update content reduction limit from'u'.
 groecontcount!*:=if not numberp groecontcount!* then 10 else
  if u then max(0,groecontcount!*-1)
   else min(10,groecontcount!*+1);

symbolic procedure groebvbcbig!? a;
% Test if'a'is a "big" coefficient.
(if numberp x then(x > 1000000000000 or x <-1000000000000)
  else t)where x=vbcnumber a;

symbolic procedure groebnormalformselect v;
% Select the vdp'v',if the'vdplastvar*'- variable occurs in all
% terms(then return it)or don't select it(then return'nil').
 if countlastvar(v,t)#> 0 then v;

symbolic procedure groebsimpcontnormalform h;
% SimpCont version preserving the property SUGAR.
 if vdpzero!? h then h else
 begin scalar sugar,c;
  sugar:=gsugar h;c:=vdplbc h;
  h:=vdpsimpcont h;gsetsugar(h,sugar);
  if !*groebprot and not(c=vdplbc h)then groebreductionprotocol2
   reval{'quotient,vbc2a vdplbc h,vbc2a c};
  return h end;

symbolic procedure groebsimpcont2(f,f1);
% Simplify two polynomials with the gcd of their contents.
 begin scalar c,s1,s2;
  s1:=gsugar f;s2:=gsugar f1;
  c:=vdpcontent f;
  if vbcone!? vbcabs c then go to ready;
  if not vdpzero!? f1 then
  <>;
   f:=vdpdivmon(f,c,nil);
                 !*trgroeb and groebmess28 c;
   groebsaveltermbc c;
   gsetsugar(f,s1);gsetsugar(f1,s2);
ready:secondvalue!*:=f1;return f end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  Special case reductions.
%

symbolic procedure groebprereduce g;
% Reduce the polynomials in g with themselves.
% The reduction is continued until headterms are stable is possible.
 begin scalar res,work,oldvev,f,oldf,!*groebweak,
  !*groebfullreduction;integer count;
  if !*trgroebs then
  <>;
  res:=nil;% Delete zero polynomials from'g'.
  for each f in g do if not vdpzero!? f then res:=f.res;
  work:=g:=res:=reversip res;
  while work do
  <> >>;
      if not vdpzero!? f then
      <> >> >>;
  return for each f in res collect vdpsimpcont f end;

symbolic procedure groebreducefromfactors(g,facts);
% Reduce the polynomials in G from those in facts.
 begin scalar new,gnew,f,nold,nnew,numbers;
  if !*trgroebs then
  <>;
  while g do
  <> >>
  else if vevzero!? vdpevlmon new then
  <>;
   g:=nil;
   gnew:={vdpone!*}>>
  else<> >>;
        gnew:=new.gnew>> >>;
   secondvalue!*:=numbers;
   return gnew end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  Support for reduction by "simple" polynomials.

symbolic procedure groebnormalform1(f,p);
% Short version;reduce f by p;
% special case: p is a monomial.
 if vdplength p=1 then vdpcancelmvev(f,vdpevlmon p)
  else groebnormalform(f,{p},nil);

symbolic procedure groebprofitsfromvev(p,vev);
% Tests,if at least one monomial from p would be reduced by vev.
 if vdpzero!? p then nil
  else if buchvevdivides!?(vev,vdpevlmon p)then t
  else groebprofitsfromvev(vdpred p,vev);

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  Special reduction procedures.

symbolic procedure groebreduceonestepint(f,f1,c,vev,g1);
% Reduction step for integer case:
% calculate f= a*f-b*g a,b such that leading term vanishes
%(vev of lvbc g divides vev of lvbc f)
% and  calculate f1=a * f1;
% return value=f,secondvalue=f1.
 begin scalar vevlcm,a,b,cg,x,rg1;
% Trivial case: g1 single monomial.
  if vdpzero!?(rg1:=vdpred g1)
   then return<>;
  vevlcm:=vevdif(vev,vdpevlmon g1);
  cg:=vdplbc g1;
            % Calculate coefficient factors .
  x:=if not !*groebdivide then vbcfi 1 else vbcgcd(c,cg);
  a:=vbcquot(cg,x);
  b:=vbcquot(c,x);
            % Multiply relvevant parts from f and f1 by a(vbc).
  if f1 and not vdpzero!? f1 then f1:=vdpvbcprod(f1,a);
  if !*groebprot then groebreductionprotocol(a,vbcneg b,vevlcm,g1);
  f:= vdpilcomb1(vdpred f,a,vevzero(),
                     rg1,vbcneg b,vevlcm);
            % Return with f and f1.
  secondvalue!*:= f1;thirdvalue!*:=a;return f end;

symbolic procedure groebreduceonesteprat(f,dummy,c,vev,g1);
% Reduction step for rational case:
% calculate f= f-g/vdpLbc(f).
 begin scalar x,rg1,vevlcm;
            % Trivial case: g1 single monomial.
  dummy:=nil;
  if vdpzero!?(rg1:=vdpred g1)then return vdpred f;
            % Calculate coefficient factors.
  x:=vbcneg vbcquot(c,vdplbc g1);
  vevlcm:=vevdif(vev,vdpevlmon g1);
  if !*groebprot then
   groebreductionprotocol( a2vbc 1,x,vevlcm,g1);
  return vdpilcomb1(vdpred f,a2vbc 1,vevzero(),
                            rg1,x,vevlcm)end;

symbolic procedure groebreductionprotocol(a,b,vevlcm,g1);
 if !*groebprot then
  groebprotfile:=
   if not vbcone!? a then
    append(groebprotfile,
  {{'equal,'candidate,
         {'times,'candidate,vbc2a a}},
   {'equal,'candidate,
         {'plus,'candidate,
              {'times,vdp2a vdpfmon(b,vevlcm),
                              mkid('poly,vdpnumber g1)}}}
   })
    else
    append(groebprotfile,
 {{'equal,'candidate,
         {'plus,'candidate,
              {'times,vdp2a vdpfmon(b,vevlcm),
                              mkid('poly,vdpnumber g1)}}}
   });

symbolic procedure groebreductionprotocol2 a;
 if !*groebprot then
  groebprotfile:=
   if not(a=1)then
    append(groebprotfile,
 {{'equal,'candidate,{'times,'candidate,a}}});

symbolic procedure groebreductionprotocolborder();
 append(groebprotfile,'!+!+!+!+!+!+!+!+!+!+!+!+!+!+!+!+.nil);

symbolic procedure groebprotsetq(a,b);
 groebprotfile:=append(groebprotfile,{{'equal,a,b}});

symbolic procedure groebprotval a;
 groebprotfile:=
  append(groebprotfile,{{'equal,'intermediateresult,a}});

symbolic procedure subset!?(s1,s2);
% Tests,if s1 is a subset of s2.
 if null s1 then t else
 if member(car s1,s2)then subset!?(cdr s1,s2)
  else nil;

symbolic procedure vevsplit vev;
% Split vev such that each exponent vector has only one 1.
 begin scalar e,vp;integer n;
  for each x in vev do
  <> >>;return vp end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Calculation of an S-polynomial.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% General strategy:
%
% groebspolynom4 calculates the traditional s-polynomial from p1,p2
%(linear combination such that the highest term vanishes).
% groebspolynom2 subtracts multiples of p2 from the s-polynomial such
% that head terms are eliminated early.

symbolic procedure groebspolynom(p1,p2);
 groebspolynom2(p1,p2);

symbolic procedure groebspolynom2(p1,p2);
 if vdpzero!? p1 then p2 else if vdpzero!? p2 then p1 else
 begin scalar cand,s,tp1,tp2,ts;
  s:=groebspolynom3(p1,p2);
  if vdpzero!? s or vdpone!? s or !*groebprot then return s;
  tp1:=vdpevlmon p1;tp2:=vdpevlmon p2;
  while not vdpzero!? s
   and(( buchvevdivides!?(tp2,(ts:=vdpevlmon s)) and(cand:=p2))
           or(buchvevdivides!?(tp1,(ts:=vdpevlmon s))
                and(cand:=p1)))
    do<>;
   return s end;

symbolic procedure groebspolynom3(p,q);
 begin scalar r;r:=groebspolynom4(p,q);
  groebsavelterm r;return r end;

symbolic procedure groebspolynom4(p1,p2);
 begin scalar db1,db2,ep1,ep2,ep,r,rp1,rp2,x;
  ep1:=vdpevlmon p1;ep2:=vdpevlmon p2;
  ep:=vevlcm(ep1,ep2);
  rp1:=vdpred p1;rp2:=vdpred p2;
  gsetsugar(rp1,gsugar p1);gsetsugar(rp2,gsugar p2);
  r:=(if vdpzero!? rp1 and vdpzero!? rp2 then rp1
         else(if vdpzero!? rp1 then
          <>
         else if vdpzero!? rp2 then
          <>
         else
          <> >>;
             vdpilcomb1(rp2,db1,vevdif(ep,ep2),
              rp1,vbcneg db2,vevdif(ep,ep1)) >>
  ));
  if !*groebprot then
   groebprotsetq('candidate,
{'difference,
  {'times,vdp2a vdpfmon(db2,vevdif(ep,ep2)),
                mkid('poly,vdpnumber p1)},
  {'times,vdp2a vdpfmon(db1,vevdif(ep,ep1)),
                mkid('poly,vdpnumber p2)}});
  return r end;

symbolic procedure groebsavelterm r;
 if !*groelterms and not vdpzero!? r then groebsaveltermbc vdplbc r;

symbolic procedure groebsaveltermbc r;
 <> >>;

symbolic procedure sfcont f;
% Calculate the integer content of standard form f.
 if domainp f then f else gcdf(sfcont lc f,sfcont red f);

symbolic procedure vdplmon u;vdpfmon(vdplbc u,vdplbc u);

symbolic procedure vdpmember3(p,g1,g2,g3);
% Test membership of p in one of then lists g1,g2,g3.
 vdpmember(p,g1)or vdpmember(p,g2)or vdpmember(p,g3);

symbolic procedure groebabortid(base,abort1);
% Test whether one of the elements in abort1 is
% member of the ideal described by base. Definite
% test here.
 if null abort1 then nil else
  vdpzero!?(groebnormalform(car abort1,base,'list))
   or groebabortid(base,cdr abort1);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebnr2.red0000644000175000017500000000540411526203062024526 0ustar  giovannigiovannimodule groebnr2;% Part 2 of the Groebner package.

create!-package('(groebnr2 groebman glexconv groebmes groebrst groebtra%groebres
 groeweak hilberts hilbertp hggroeb kuechl greduo), '(contrib groebner));

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load!-package 'groebner;

imports a2vdp,f2vdp,a2vbc,vdp2a,vdp2f,vbc2a,
        vdpfmon,vdpappendvdp,vdplbc,
        vdpred,vdplastmon,vevnth,

        vdpzero!?,vdpredzero!?,vdpone!?,vevzero!?,
        vbcplus!?,vbcone!?,vbcnumberp!?,vevdivides!?,vevcompless!?,
        vdpequal,vdpmember,vevequal,

        vdpsum,vdpprod,vdpdivmon,cdpcancelvev,vdplcomb1,vdpcontent,
        vdpsimpcont,vdplcm,vdpresimp,

        vbcsum,vbcdif,vbcneg,vbcprod,vbcquot,vbcinv,vbcgcd,

        vevsum,vevsum0,vevdif,vevtdeg,vevzero,

        vdpilcomb1,vdpprin2,

        vdpputprop,vdpgetprop,vdplsort,vdplsortin,vdpprint,
        vdpprin3t,vdprectoint,

        groebmess24,groebmess4,groebmess2,groebmess51,groebmess8,
        groebmessff,groebmess5,groebmess34,groebmess29,groebmess32,
        groebmess30,groebmess31,groebmess36,groebmess37,groebmess35,
        groebmess33,

        vevweightedcomp2,vdpvbcprod,vdpcanelmvev,

        gsetsugar,

        rnonep!:,rntimes!:,!*i2rn,rnminusp!:,rndifference!:,rnzerop!:,
        rnplus!:,rnquotient!:,rnequiv,rnprep!:,mkrn,

        vdpcoeffcientsfromdomain!?,

        simp,addsq,multsq,

        rerror,vdpcleanup,torder2;

exports gdimensioneval,glexconvert,greduce,preduce,groebnert,dd_groebner,
 hilbertpolynomial,gsort,gsplit,gspoly,gzerodim!?,groeb!-w1;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebman.red0000644000175000017500000001507011526203062024600 0ustar  giovannigiovannimodule groebman;  % Operators for manipulation of bases and
                  % polynomials in Groebner style.

flag ('(groebrestriction groebresmax gvarslast groebprotfile gltb),'share);

% control of the polynomial arithmetic actually loaded

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure gsorteval pars;
% reformat a polynomial or a list of polynomials by a distributive
% ordering; a list will be sorted  and zeros are elimiated
   begin scalar vars,u,v,w,oldorder,nolist,!*factor,!*exp,!*gsugar;
         integer n,pcount!*;!*exp:=t;
      n:=length pars;
      u:=reval car pars;
      v:=if n>1 then reval cadr pars else nil;
      if not eqcar(u,'list) then
      <>;
      w:= for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      vars:=groebnervars(w,v);
      if not vars then vdperr 'gsort;
      oldorder:= vdpinit vars;
      !*vdpinteger:=nil;
      w:=for each j in w collect a2vdp j;
      w:=vdplsort w;
      w:=for each x in w collect vdp2a x;
      while member(0,w) do w:=delete(0,w);
      setkorder oldorder;
      return if nolist and w then car w else 'list.w end;

put('gsort,'psopfn,'gsorteval);

symbolic procedure gspliteval pars;
% split a polynomial into leading monomial and reductum;
   begin scalar vars,x,u,v,w,oldorder,!*factor,!*exp,!*gsugar;
         integer n,pcount!*;!*exp:=t;
      n:=length pars;
      u:=reval car pars;
      v:=if n>1 then reval cadr pars else nil;
      u:=list('list,u);
      w:=for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      vars:=groebnervars(w,v);
      if not vars then  vdperr 'gsplit;
      oldorder:=vdpinit vars;
      !*vdpinteger:=nil;
      w:=a2vdp car w;
      if vdpzero!? w then x:=w else
      <>;
      w:={'list,vdp2a x,vdp2a w};
      setkorder oldorder;return w end;

put('gsplit,'psopfn,'gspliteval);

symbolic procedure gspolyeval pars;
% calculate the S Polynomial from two given polynomials
   begin scalar vars,u,u1,u2,v,w,oldorder,!*factor,!*exp,!*gsugar;
         integer n,pcount!*;!*exp:=t;
      n:=length pars;
      if n<2 or n#>3 then
           rerror(groebnr2,1,"gspoly, illegal number or parameters");
      u1:= car pars;u2:= cadr pars;
      u:={'list,u1,u2};
      v:=if n>2 then groerevlist caddr pars else nil;
      w:=for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      vars:=groebnervars(w,v);
      if not vars then vdperr 'gspoly;
      groedomainmode();
      oldorder:=vdpinit vars;
      w:=for each j in w collect f2vdp numr simp j;
      w:=vdp2a groebspolynom3 (car w,cadr w);
      setkorder oldorder;return w end;

put('gspoly,'psopfn,'gspolyeval);

symbolic procedure gvarseval u;
% u is a list of polynomials; gvars extracts the variables from u
   begin integer n;scalar v,!*factor,!*exp,!*gsugar;!*exp:=t;
      n:=length u;
      v:=for each j in groerevlist reval car u collect
                      if eqexpr j then !*eqn2a j else j;
      v:=groebnervars(v,nil);
      v:=if n=2 then
         intersection (v,groerevlist reval cadr u) else v;
      return 'list.v end;

put('gvars,'psopfn,'gvarseval);

symbolic procedure greduceeval pars;
%  Polynomial reduction modulo a Groebner basis driver. u is an
% expression and v a list of expressions.  Greduce calculates the
% polynomial u reduced wrt the list of expressions v reduced to a
% groebner basis modulo using the optional caddr argument as the
% order of variables.
%     1      expression to be reduced
%     2      polynomials or equations; base for reduction
%     3      optional: list of variables
  begin scalar vars,x,u,v,w,np,oldorder,!*factor,!*groebfac,!*exp;
       scalar !*gsugar;
       integer n,pcount!*;!*exp:=t;
      if !*groebprot then groebprotfile:={'list};
      n:=length pars;
      x:=reval car pars;
      u:=reval cadr pars;
      v:=if n>2 then reval caddr pars else nil;
      w:=for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      if null w then rerror(groebnr2,2,"Empty list in greduce");
      vars:=groebnervars(w,v);
      if not vars then vdperr 'greduce;
      oldorder:=vdpinit vars;
      groedomainmode();
                  % cancel common denominators
      w:=for each j in w collect reorder numr simp j;
                  % optimize varable sequence if desired
      if !*groebopt then<>;
      w:=for each j in w collect f2vdp j;
      if !*groebprot then w:=for each j in w collect vdpenumerate j;
      if not !*vdpinteger then
      <> >>;
      w:=groebner2(w,nil);x:=a2vdp x;
      if !*groebprot then
          <>;
      w:=car w;
      !*vdpinteger:=nil;
      w:=groebnormalform(x,w,'sort);
      w:=vdp2a w;
      setkorder oldorder;
      gvarslast:='list.vars;
      return if w then w else 0 end;

put('greduce,'psopfn,'greduceeval);

put('preduce,'psopfn,'preduceeval);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebner.tex0000644000175000017500000016605411526203062024650 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{GROEBNER: A Package for Calculating Gr\"obner Bases, Version 3.0}
\date{}
\author{
H. Melenk \& W. Neun \\[0.05in]
Konrad--Zuse--Zentrum \\
f\"ur Informationstechnik Berlin \\
Takustrasse 7 \\
D--14195 Berlin--Dahlem \\
Germany \\[0.05in]
Email:  melenk@zib.de \\[0.05in]
and \\[0.05in]
H.M. M\"oller \\[0.05in]
FB Mathematik \\
Vogelpothsweg 87\\
Universit\"at Dortmund \\
D--44221 Dortmund \\
Germany\\[0.05in]
Email: moeller@math.uni--dortmund.de}

\begin{document}
\maketitle

\index{Gr\"obner Bases}
Gr\"obner bases are a valuable tool for solving problems in
connection with multivariate polynomials, such as solving systems of
algebraic equations and analyzing polynomial ideals. For a definition
of Gr\"obner bases, a survey of possible applications and further
references, see~\cite{Buchberger:85}. Examples are given in \cite{Boege:86},
in \cite{Buchberger:88} and also in the test file for this package.

\index{Groebner package} \index{Buchberger's Algorithm}
The $groebner$ package calculates Gr\"obner bases using the
Buchberger algorithm.  It can be used over a variety of different
coefficient domains, and for different variable and term orderings.

The current version of the package uses parts of a previous
version, written by  R. Gebauer, A.C. Hearn, H. Kredel and H. M.
M\"oller. The algorithms implemented in the current version are
documented in \cite{Faugere:89}, \cite{Gebauer:88},
\cite{Kredel:88a} and \cite{Giovini:91}.
The operator $saturation$ has been implemented in July 2000 (Herbert Melenk).
\section{Background}

\subsection{Variables, Domains and Polynomials}

The various functions of the $groebner$ package manipulate
equations and/or polynomials; equations are internally
transformed into  polynomials by forming the difference of
left-hand side and right-hand side, if equations are given.

All manipulations take place in a ring of polynomials in some
variables $x1, \ldots , xn$ over a coefficient domain $d$:
\[ d [x1,\ldots , xn], \]
where $d$ is a field or at least a ring without zero divisors.
The set of variables $x1,\ldots ,xn$ can be given explicitly by the
user or it is extracted automatically from the
input expressions.

All \REDUCE \  kernels can play the role of ``variables'' in this context;
examples are

%{\small
\begin{verbatim}
x y z22 sin(alpha) cos(alpha) c(1,2,3) c(1,3,2) farina4711
\end{verbatim}
%}

The domain $d$ is the current \REDUCE \  domain with those kernels
adjoined that are not members of the list of variables. So the
elements of $d$ may be complicated polynomials themselves over
kernels not in the list of variables; if, however, the variables are
extracted automatically from the input expressions, $d$ is identical
with the current \REDUCE \  domain. It is useful to regard kernels not
being members of the list of variables as ``parameters'', e.g.
\[
\begin{array}{c}
 a * x + (a - b) * y**2 \;\mbox{ with ``variables''}\ \{x,y\} \\
\mbox{and ``parameters''  $\;a\;$ and $\;b\;$}\;.
\end{array}
\]

The exponents of $groebner$ variables must be positive integers.

A $groebner$ variable may not occur as a parameter (or part
of a parameter) of a coefficient function. This condition is
tested in the beginning of the $groebner$ calculation; if it is
violated, an error message occurs (with the variable name), and the
calculation is aborted. When the $groebner$ package is called by
$solve$, the test is switched off internally.

The current version of the Buchberger algorithm has two internal
modes, a field mode and a ring mode. In the starting phase the
algorithm analyzes the domain type; if it recognizes $d$ as being a
ring it uses the ring mode, otherwise the field mode is needed.
Normally field calculations occur only if all coefficients are numbers
and if the current \REDUCE \  domain is a field (e.g. rational numbers,
modular numbers modulo a prime). In general, the ring mode is faster.
When no specific
\REDUCE \  domain is selected, the ring mode is used, even if the input
formulas contain fractional coefficients: they are multiplied by their
common denominators so that they become integer polynomials. Zeroes of the
denominators are included in the result list.

\subsection{Term Ordering} \par
In the theory of Gr\"obner bases, the terms of polynomials are
considered as ordered. Several order modes are available in
the current package, including the basic modes:
\index{lex ! term order} \index{gradlex ! term order}
\index{revgradlex ! term order}

\begin{center}
$lex$, $gradlex$, $revgradlex$
\end{center}

All orderings are based on an ordering among the variables. For
each pair of variables $(a,b)$ an order relation must be defined, e.g.
``$ a\gg b $''. The greater sign $\gg$  does not represent a numerical
relation among the variables; it can be interpreted only in terms of
formula representation: ``$a$'' will be placed in front of ``$b$'' or
``$a$''  is more complicated than ``$b$''.

The sequence of variables constitutes this order base. So the notion
of
\[ \{x1,x2,x3\} \]

as a list of variables at the same time means
\[ x1 \gg x2 \gg x3 \]
with respect to the term order.

If terms (products of powers of variables) are compared with $lex$,
that term is chosen which has a greater variable or a higher degree
if the greatest variable is the first in both. With $gradlex$ the sum of
all exponents (the total degree) is compared first, and if that does
not lead to a decision, the $lex$ method is taken for the final decision.
The $revgradlex$ method also compares the total degree first, but
afterward it uses the $lex$ method in the reverse direction; this is the
method originally used by Buchberger.

\example \ with $\{x,y,z\}$: \index{Groebner package ! example}
\[
\begin{array}{rlll}
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf lex:}}\\
 x * y **3 & \gg & y ** 48 & \mbox{(heavier variable)} \\
 x**4 * y**2 & \gg  & x**3 * y**10 & \mbox{(higher degree in 1st
variable)} \vspace*{2mm} \\
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf gradlex:}} \\
  y**3 * z**4 & \gg & x**3 * y**3 & \mbox{(higher total degree)} \\
  x*z  &        \gg & y**2  & \mbox{(equal total degree)}
\vspace*{2mm}\\
\multicolumn{2}{l}{\hspace*{-1cm}\mbox{\bf
revgradlex:}} \\
 y**3 * z**4 & \gg &  x**3 * y**3 & \mbox{(higher total degree)} \\
 x*z         & \ll  &  y**2       & \mbox{(equal total degree,} \\
 & & & \mbox{so reverse order of lex)}
\end{array}
\]

The formal description of the term order modes is similar to
\cite{Kredel:88}; this description regards only the exponents of a term,
which are written as vectors of integers with $0$ for exponents of a
variable which does not occur:
\[
\begin{array}{l}
  (e) = (e1,\ldots , en) \;\mbox{ representing }\; x1**e1 \ x2**e2 \cdots
  xn**en. \\
  \deg(e) \; \mbox{ is the sum over all elements of } \;(e) \\
  (e) \gg (l) \Longleftrightarrow (e)-(l)\gg (0) = (0,\ldots ,0)
\end{array}
\]
\[
\begin{array}{rll}
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf lex:}} \\
  (e) > lex > (0) & \Longrightarrow  & e_k > 0 \mbox{ and } e_j =0
\mbox{ for }\; j=1,\ldots , k-1\vspace*{2mm} \\
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf
gradlex:}} \\
  (e) >gl> (0)  & \Longrightarrow  & \deg(e)>0  \mbox { or } (e) >lex>
(0)\vspace*{2mm} \\
\multicolumn{1}{l}{\hspace*{-.5cm}\mbox{\bf
revgradlex:}}\\
  (e) >rgl> (0) & \Longrightarrow & \deg(e)>0  \mbox{ or }(e)  1$: the vectors with $n$ elements of $r$
form a $module$ under vector addition (= componentwise addition)
and multiplication with elements of $r$. For a submodule
given by a finite basis a Gr\"obner basis
can be computed, and the facilities of the $groebner$ package
can be used except the operators $groebnerf$ and $groesolve$.

The vectors are encoded using auxiliary variables which represent
the unit vectors in the module. E.g. using ${v_1,v_2,v_3}$ the
module element $[x_1^2,0,x_1-x_2]$ is represented as
$x_1^2 v_1 + x_1 v_3 - x_2 v_3$. The use of ${v_1,v_2,v_3}$
as unit vectors is set up by assigning the set of auxiliary variables
to the share variable $gmodule$, e.g.
\begin{verbatim}
   gmodule := {v1,v2,v3};
\end{verbatim}
After this declaration all monomials built from these variables
are considered as an algebraically independent basis of a vector
space. However, you had best use them only linearly. Once $gmodule$
has been set, the auxiliary variables automatically will be
added to the end of each variable list (if they are not yet
member there).
Example:
\begin{verbatim}
   torder({x,y,v1,v2,v3},lex)$
   gmodule := {v1,v2,v3}$
   g:=groebner{x^2*v1 + y*v2,x*y*v1 - v3,2y*v1 + y*v3};

       2
g := {x *v1 + y*v2,

              2
      x*v3 + y *v2,

       3
      y *v2 - 2*v3,

      2*y*v1 + y*v3}

   preduce((x+y)^3*v1,g);

             1   3         2
 - x*y*v2 - ---*y *v3 - 3*y *v2 + 3*y*v3
             2

\end{verbatim}

In many cases a total degree oriented term order will be adequate
for computations in modules, e.g. for all cases where the
submodule membership is investigated. However, arranging
the auxiliary variables in an elimination oriented term order
can give interesting results. E.g.
\begin{verbatim}
   p1:=(x-1)*(x^2-x+3)$  p2:=(x-1)*(x^2+x-5)$
   gmodule := {v1,v2,v3};
   torder({v1,x,v2,v3},lex)$
   gb:=groebner {p1*v1+v2,p2*v1+v3};

gb := {30*v1*x - 30*v1 + x*v2 - x*v3 + 5*v2 - 3*v3,

        2       2
       x *v2 - x *v3 + x*v2 + x*v3 - 5*v2 - 3*v3}

   g:=coeffn(first gb,v1,1);

g := 30*(x - 1)

   c1:=coeffn(first gb,v2,1);

c1 := x + 5

   c2:=coeffn(first gb,v3,1);

c2 :=  - x - 3

   c1*p1 + c2*p2;

30*(x - 1)

\end{verbatim}
Here two polynomials
are entered as vectors $[p_1,1,0]$ and $[p_2,0,1]$. Using a term
ordering such that the first dimension ranges highest and the
other components lowest, a classical cofactor computation is
executed just as in the extended Euclidean algorithm.
Consequently the leading polynomial in the resulting
basis shows the greatest common divisor of $p_1$ and $p_2$,
found as a coefficient of $v_1$ while the coefficients
of $v_2$ and $v_3$ are the cofactors $c_1$ and $c_2$ of the polynomials
$p_1$ and $p_2$ with the relation $gcd(p_1,p_2) = c_1p_1 + c_2p_2$.

\subsection{Additional Orderings}
Besides the basic orderings, there are ordering options that are used for
special purposes.

\subsubsection{Separating the Variables into Groups }
\index{grouped ordering}
It is often desirable to separate variables
and formal parameters in a system of polynomials.
This can be done with a {\it lex} Gr\"obner
basis.  That however may be hard to compute as it does more
separation than necessary. The following orderings group the
variables into two (or more) sets, where inside each set a classical
ordering acts, while the sets are handled via their total degrees,
which are compared in elimination style. So the Gr\"obner basis will
eliminate the members of the first set, if algebraically possible.
{\it torder} here gets an additional parameter which describe the
grouping \ttindex{torder}
\begin{center}{\it
\begin{tabular}{l}
torder ($vl$,$gradlexgradlex$, $n$) \\
torder ($vl$,$gradlexrevgradlex$,$n$) \\
torder ($vl$,$lexgradlex$, $n$) \\
torder ($vl$,$lexrevgradlex$, $n$)
\end{tabular}}
\end{center}
Here the integer $n$ is the number of variables in the first group
and the names combine the local ordering for the first and second
group, e.g.
\begin{center}
\begin{tabular}{llll}
\multicolumn{4}{l}{{\it lexgradlex}, 3 for $\{x_1,x_2,x_3,x_4,x_5\}$:} \\
\multicolumn{4}{l}{$x_1^{i_1}\ldots x_5^{i_5} \gg x_1^{j_1}\ldots
x_5^{j_5}$} \\
if & & & $(i_1,i_2,i_3) \gg_{lex}(j_1,j_2,j_3)$ \\
& or & & $(i_1,i_2,i_3) = (j_1,j_2,j_3)$ \\
& & and & $(i_4,i_5) \gg_{gradlex}(j_4,j_5)$
\end{tabular}
\end{center}
Note that in the second place there is no {\it lex} ordering available;
that would not make sense.

\subsubsection{Weighted Ordering}
\ttindex{torder} \index{weighted ordering}
The statement
\begin{center}
\begin{tabular}{cl}
{\it torder} &($vl$,weighted, $\{n_1,n_2,n_3  \ldots$\}) ; \\
\end{tabular}
\end{center}
establishes a graduated ordering, where the exponents are first
multiplied by the given weights. If there are less weight values than
variables, the weight 1 is added automatically. If the weighted
degree calculation is not decidable, a $lex$ comparison follows.

\subsubsection{Graded Ordering}
\ttindex{torder} \index{graded ordering}
The statement
\begin{center}
\begin{tabular}{cl}
{\it torder} &($vl$,graded, $\{n_1,n_2,n_3 \ldots\}$,$order_2$) ; \\
\end{tabular}
\end{center}
establishes a graduated ordering, where the exponents are first
multiplied by the given weights. If there are less weight values than
variables, the weight 1 is added automatically. If the weighted
degree calculation is not decidable, the term order $order_2$ specified
in the following argument(s) is used.  The ordering $graded$ is designed
primarily for use with the operator $dd\_groebner$.

\subsubsection{Matrix Ordering}
\ttindex{torder} \index{matrix ordering}
The statement
\begin{center}
\begin{tabular}{cl}
{\it torder} &($vl$,matrix, $m$) ; \\
\end{tabular}
\end{center}
where $m$ is a matrix with integer elements and row length which
corresponds to the variable number. The exponents of each monomial
form a vector; two monomials are compared by multiplying their
exponent vectors first with $m$ and comparing the resulting vector
lexicographically. E.g. the unit matrix establishes the classical
$lex$ term order mode, a matrix with a first row of ones followed
by the rows of a unit matrix corresponds to the $gradlex$ ordering.

The matrix $m$ must have at least as many rows as columns; a non--square
matrix contains redundant rows. The matrix must have full rank, and
the top non--zero element of each column must be positive.

The generality of the matrix based term order has its price: the
computing time spent in the term sorting is significantly higher
than with the specialized term orders. To overcome this problem,
you can compile a matrix term order ; the
compilation reduces the computing time overhead significantly.
If you set the switch $comp$ on, any new order matrix is compiled
when any operator of the $groebner$ package accesses it for the
first time. Alternatively you can compile a matrix explicitly
\begin{verbatim}
    torder_compile(,);
\end{verbatim}
where $$ is a name (an identifier) and $$ is a term order matrix.
$torder\_compile$ transforms the matrix into a LISP program, which
is compiled by the LISP compiler when $comp$ is on or when you
generate a fast loadable module. Later you can activate the new term
order by using the name $$ in a $torder$ statement as term ordering
mode.

\subsection{Gr\"obner Bases for Graded Homogeneous Systems}

For a homogeneous system of polynomials under a term order
{\it graded}, {\it gradlex}, {\it revgradlex} or {\it weighted}
a Gr\"obner Base can be computed with limiting the grade
of the intermediate $s$--polynomials:
\begin{description}
\ttindex{dd\_groebner}
\item [{\it dd\_groebner}]($d1$,$d2$,$\{p_1,p_2,\ldots\}$);
\end{description}
where $d1$ is a non--negative integer and $d2$ is an integer
$>$ $d1$ or ``infinity". A pair of polynomials is considered
only if the grade of the lcm of their head terms is between
$d1$ and $d2$. See \cite{BeWei:93} for the mathematical background.
For the term orders {\it graded} or {\it weighted} the (first) weight
vector is used for the grade computation. Otherwise the total
degree of a term is used.

\section{Ideal Decomposition \& Equation System Solving}
Based on the elementary Gr\"obner operations, the $groebner$ package offers
additional operators, which allow the decomposition of an ideal or of a
system of equations down to the individual solutions.

\subsection{Solutions Based on Lex Type Gr\"obner Bases}

\subsubsection{groesolve: Solution of a Set of Polynomial Equations}
\ttindex{groesolve} \ttindex{groebnerf}
The $groesolve$ operator incorporates a macro algorithm;
lexical Gr\"obner bases are computed by $groebnerf$ and decomposed
into simpler ones by ideal decomposition techniques; if algebraically
possible, the problem is reduced to univariate polynomials which are
solved by $solve$; if $rounded$ is on, numerical approximations are
computed for the roots of the univariate polynomials.
\[
 groesolve(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots ,
varn\}]); \]
where $\{exp1, exp2,\ldots , expm\}$ is a list of any number of
expressions or equations, $\{var1, var2, \ldots , varn\}$ is an
optional list of variables.

The result is a set of subsets. The subsets contain the solutions of the
polynomial equations. If there are only finitely many solutions,
then each subset is a set of expressions of triangular type
$\{exp1, exp2,\ldots , expn\},$ where $exp1$ depends only on
$var1,$ $exp2$ depends only on $var1$ and $var2$ etc. until $expn$ which
depends on $var1,\ldots,varn.$ This allows a successive determination of
the solution components. If there are infinitely many solutions,
some subsets consist in less than $n$ expressions. By considering some
of the variables as ``free parameters'',  these subsets are usually
again of triangular type.

\example (Intersections of a line with a circle):
\index{groebner package ! example}

\[ groesolve(\{x**2 - y**2 - a, p*x+q*y+s\},\{x,y\}); \]

\begin{verbatim}
                   2      2    2             2    2
   {{x=(sqrt( - a*p  + a*q  + s )*q - p*s)/(p  - q ),
                      2      2    2             2    2
     y= - (sqrt( - a*p  + a*q  + s )*p - q*s)/(p  - q )},
                      2      2    2             2    2
    {x= - (sqrt( - a*p  + a*q  + s )*q + p*s)/(p  - q ),
                   2      2    2             2    2
     y=(sqrt( - a*p  + a*q  + s )*p + q*s)/(p  - q )}}
\end{verbatim}

If the system is zero--dimensional (has a number of isolated solutions),
the algorithm described in \cite{Hillebrand:99} is used, if the decomposition
leaves a polynomial with mixed leading term. Hillebrand has written the
article and M\"oller was the tutor of this job.

The reordering of the $groesolve$ variables is controlled by the
\REDUCE \ switch $varopt$. If $varopt$ is $on$ (which is the default
of $varopt$), the variable sequence is optimized (the variables are reordered).
If $varopt$ is $off$, the given variable sequence is taken (if no variables
are given, the order of the \REDUCE \ system is taken instead). In general, the
reordering of the variables makes the Gr\"obner basis computation
significantly faster.
A variable dependency, declare by one (or several) $depend$ statements,
is regarded (if $varopt$ is $on$). The switch $groebopt$ has no meaning
for $groesolve$; it is stored during its processing.

\subsubsection{$groepostproc$: Postprocessing of a Gr\"obner Basis}
\ttindex{groepostproc}
In many cases, it is difficult to do the general Gr\"obner processing.
If a Gr\"obner basis with a {\it lex} ordering is calculated already (e.g.,
by very individual parameter settings), the solutions can be derived
from it by a call to $groepostproc$. $groesolve$ is functionally
equivalent to a call to $groebnerf$ and subsequent calls to
$groepostproc$ for each partial basis.
\[
 groepostproc(\{exp1, exp2, \ldots , expm\}[,\{var1, var2, \ldots ,
varn\}]);
\]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions, \linebreak[4] $\{var1, var2, \ldots ,$ $ varn\}$ is an
optional list of variables. The expressions must be a {\it lex} Gr\"obner
basis with the given variables; the ordering must be still active.

The result is the same as with $groesolve$.

\begin{verbatim}
groepostproc({x3**2 + x3 + x2 - 1,
              x2*x3 + x1*x3 + x3 + x1*x2 + x1 + 2,
              x2**2 + 2*x2 - 1,
              x1**2 - 2},{x3,x2,x1});

{{x3= - sqrt(2),

  x2=sqrt(2) - 1,

  x1=sqrt(2)},

 {x3=sqrt(2),

  x2= - (sqrt(2) + 1),

  x1= - sqrt(2)},

      sqrt(4*sqrt(2) + 9) - 1
 {x3=-------------------------,
                 2

  x2= - (sqrt(2) + 1),

  x1=sqrt(2)},

       - (sqrt(4*sqrt(2) + 9) + 1)
 {x3=------------------------------,
                   2

  x2= - (sqrt(2) + 1),

  x1=sqrt(2)},

      sqrt( - 4*sqrt(2) + 9) - 1
 {x3=----------------------------,
                  2

  x2=sqrt(2) - 1,

  x1= - sqrt(2)},

       - (sqrt( - 4*sqrt(2) + 9) + 1)
 {x3=---------------------------------,
                     2

  x2=sqrt(2) - 1,

  x1= - sqrt(2)}}
\end{verbatim}

\subsubsection{Idealquotient: Quotient of an Ideal and an Expression}
\ttindex{idealquotient} \index{ideal quotient}
Let $i$ be an ideal and $f$ be a polynomial in the same
variables. Then the algebraic quotient is defined by
\[
i:f = \{ p \;| \; p * f \;\mbox{    member of }\; i\}\;.
\]
The ideal quotient $i:f$ contains $i$ and is obviously part of the
whole polynomial ring, i.e. contained in $\{1\}$. The case $i:f =
\{1\}$ is equivalent to $f$ being a member of  $i$. The other extremal
case, $i:f=i$, occurs, when $f$ does not vanish at any general zero of $i$.
The explanation of the notion ``general zero'' introduced by van der
Waerden, however, is beyond the aim of this manual. The operation
of $groesolve$/$groepostproc$ is based on nested ideal quotient
calculations.

If $i$ is given by a basis and $f$ is given as an expression, the
quotient can be calculated by
\[
idealquotient (\{exp1, \ldots , expm\}, exp); \]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions or equations, {\it exp} is a single expression or equation.

$idealquotient$ calculates the algebraic quotient of the ideal $i$
with the basis  $\{exp1, exp2, \ldots , expm\}$ and {\it exp} with
respect to  the variables given or extracted.  $\{exp1, exp2, \ldots ,
expm\}$ is not necessarily a Gr\"obner basis.
The result is the Gr\"obner basis of the quotient.

\subsubsection{Saturation: Saturation of an Ideal and an Expression}
\ttindex{saturation}
The $saturation$ computes the quotient on an ideal and an arbitrary power
of an expression $exp**n$ with arbitrary $n$. The call is
\[ saturation (\{exp1, \ldots , expm\}, exp); \]
where $\{exp1, exp2, \ldots , expm\}$ is a list of any number of
expressions or equations, {\it exp} is a single expression or equation.

$saturation$ calls $idealquotient$ several times, until the result is
stable, and returns it.

\subsection{Operators for Gr\"obner Bases in all Term Orderings}
\index{Hilbert polynomial}
In some cases where no Gr\"obner
basis with lexical ordering can be calculated, a calculation with a total
degree ordering is still possible. Then the Hilbert polynomial gives
information about the dimension of the solutions space and for finite
sets of solutions univariate polynomials can be calculated. The solutions
of the equation system then is contained in the cross product of all
solutions of all univariate polynomials.

\subsubsection{Hilbertpolynomial: Hilbert Polynomial of an Ideal}
\ttindex{Hilbertpolynomial}
This algorithm was contributed by {\sc Joachim Hollman}, Royal
Institute of Technology, Stockholm (private communication).

\[
hilbertpolynomial (\{exp1, \ldots , expm\})\;;
\]
where $\{exp1, \ldots , expm\}$ is a list of any number of expressions
or equations.

$hilertpolynomial$ calculates the Hilbert polynomial of the ideal
with basis $\{exp1, \ldots , expm\}$ with respect to the
variables given or extracted provided the given term ordering is
compatible with the degree, such as the $gradlex$- or $revgradlex$-ordering.
The term ordering of the basis
must be active and $\{exp1, \ldots$, $ expm\}$ should be a
Gr\"obner basis with respect to this ordering. The Hilbert polynomial
gives information about the cardinality of solutions of the system
$\{exp1, \ldots , expm\}$: if the Hilbert polynomial is an
integer, the system has only a discrete set of solutions and the
polynomial is identical with the number of solutions counted with
their multiplicities. Otherwise the degree of the Hilbert
polynomial is the dimension of the solution space.

If the Hilbert polynomial is not a constant, it is constructed with the
variable ``x'' regardless of whether $x$ is member of
$\{var1, \ldots , varn\}$ or not. The value of this polynomial at
sufficiently large numbers  ``x'' is the difference
of the dimension of the linear vector space of all polynomials of degree
$ \leq x $ minus the dimension of the subspace of all polynomials of
degree $\leq x $ which belong also to the ideal.

$x$ must be an undefined variable or the value of $x$ must be an undefined
variable; otherwise a warning is given and a new (generated) variable
is taken instead.
 
\paragraph{Remark:} The number of zeros in an ideal and the
Hilbert polynomial depend only on the leading terms of the
Gr\"obner basis. So if a subsequent Hilbert calculation is planned, the
Gr\"obner calculation should be performed with $on$ $gltbasis$ and
the value of $gltb$ (or its elements in a $groebnerf$ context) should be
given to $hilbertpolynomial$. In this manner, a lot of computing time can be
saved in the case of long calculations.

\section{Calculations ``by Hand''}
The following operators support explicit calculations with
polynomials in a distributive representation at the \REDUCE \  top level.
So they allow one to do Gr\"obner type evaluations stepwise by
separate calls. Note that the normal \REDUCE \  arithmetic can be used
for arithmetic combinations of monomials and polynomials.

\subsection{Representing Polynomials in Distributive Form}
\ttindex{gsort}
\[ gsort p; \]
where $p$ is a polynomial or a list of polynomials.

If $p$ is a single polynomial, the result is a reordered version of $p$
in the distributive representation according to the variables and the
current term order mode; if $p$ is a list, its members are converted
into distributive representation and the result is the list sorted by
the term ordering of the leading terms; zero polynomials are
eliminated from the result.

\begin{verbatim}
     torder({alpha,beta,gamma},lex);

     dip := gsort(gamma*(alpha-1)**2*(beta+1)**2);


                2     2                2
    dip := alpha *beta *gamma + 2*alpha *beta*gamma

           2                     2
    + alpha *gamma - 2*alpha*beta *gamma - 4*alpha*beta*gamma

                           2
     - 2*alpha*gamma + beta *gamma + 2*beta*gamma + gamma

 \end{verbatim}

\subsection{Splitting of a Polynomial into Leading Term and Reductum}
\ttindex{gsplit}
\[ gsplit p; \]
where $p$ is a polynomial.

$gsplit$ converts the polynomial $p$ into distributive representation
and splits it into leading monomial and reductum. The result is a list
with two elements, the leading monomial and the reductum.

\begin{verbatim}
   gslit dip;

          2     2
    {alpha *beta *gamma,

            2                   2                     2
     2*alpha *beta*gamma + alpha *gamma - 2*alpha*beta *gamma

                         2
     - 4*alpha*beta*gamma - 2*alpha*gamma + beta *gamma


     + 2*beta*gamma + gamma}

 \end{verbatim}

\subsection{Calculation of Buchberger's S-polynomial}
\ttindex{gspoly}
\[ gspoly (p1,p2); \]
where $p1$  and $p2$ are polynomials.

$gspoly$ calculates the $s$-polynomial from $p1$  and $p2$;

Example for a complete calculation (taken from {\sc Davenport et al.}
 \cite{Davenport:88a}):
\begin{verbatim}
   torder({x,y,z},lex)$
   g1  :=  x**3*y*z - x*z**2;
   g2  :=  x*y**2*z - x*y*z;
   g3  :=  x**2*y**2 - z;$

   % first S-polynomial

   g4  :=  gspoly(g2,g3);$

           2        2
    g4 := x *y*z - z

    % next S-polynomial

    p :=  gspoly(g2,g4); $

          2          2
    p := x *y*z - y*z

    % and reducing, here only by g4

    g5  :=  preduce(p,{g4});

                2    2
    g5 :=  - y*z  + z

    % last S-polynomial}

    g6  :=  gspoly(g4,g5);

           2  2    3
    g6 := x *z  - z

    % and the final basis sorted descending

    gsort{g2,g3,g4,g5,g6};

      2  2
    {x *y  - z,

      2        2
     x *y*z - z ,

      2  2    3
     x *z  - z ,

        2
     x*y *z - x*y*z,

           2    2
      - y*z  + z }
 \end{verbatim}

\bibliography{groebner}
\bibliographystyle{plain}
\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groext.red0000644000175000017500000000740711526203062024323 0ustar  giovannigiovannimodule groext; % author: Herbert Melenk, ZIB Berlin.
               % version 3: removal of the return value 'superfluous' and
               %  switching to 'groebnerf'.
               % version 4: extending ALL bases, which do not reduce the
               %  polynomial to zero; 'groext11' has now a list for any
               %  new polynmial with a '1', if the polynomial is not reduced
               %  to zero by the basis; otherwise it has a '0'.
               % version 5: determine the subcases by Groebner base
               %  computaions.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(groext),'(contrib groebner));

load!-package 'groebner;put('groext,'psopfn,'groexteval);

fluid'(groext11);groext11:='(list);share groext11;

symbolic procedure groexteval u;
begin scalar gg,ll,v;
 !*groebopt:=nil;
 if not(2=length u) then
  rerror(groext,1,"groext: illegal number of parameters.");
 gg:=reval car u;
 if not eqcar(gg,'list) then
  rerror(groext,2,"groext: first parameter must be a list of lists.");
 gg:=cdr gg;ll:=reval cadr u;
 if not eqcar(ll,'list) then
  rerror(groext,3,"groext: second parameter must be a list.");
 ll:=for each lll in cdr ll collect reval{'num,lll};
 v:=groext1(gg,ll);
 return if null u then 'empty else if v=t then car u else 'list.v end;

symbolic procedure groext1(gg,ll);
begin scalar a,aa,b,bb,c,ii,l;
 l:=length ll;
 gg:=for each ggg in gg collect ggg.for each gggg in ggg collect gggg;
 groext11:=nil;
 for each lll in ll do
 <> >>;
  groext11:=c.groext11>>;
 groext11:='list.reversip groext11;
 for each ggg in gg do ii:=nconc(groext3 cdr ggg,ii);
 if null ii then return nil;
% for each iii in ii do if null groext2(iii,ii) then jj:=iii.jj
%  else ii:=deletip(iii,ii);
 a:=ii;
aa:if null a then go to cc;aa:=car a;a:=cdr a;b:=ii;
bb:if null b then go to aa;bb:=car b;b:=cdr b;
 if groext2(aa,bb)then<>;go to bb;
cc:return reversip ii end;

symbolic procedure groext2(a,b);
% Test, if the Groebner basis 'a' describes a subproblem of one of
% the Groebner basis 'b'; return 't' then. Otherwise return 'nil'.
if a eq b then nil else
begin scalar !*groebfac;
 !*groebfac:=t;return if b=cadr groebner1(append(b,cdr a),nil,nil)then t
    else nil end;

fluid'(!*groebfac);

symbolic procedure groext3 a;
% Simulate "Groebner a;".
begin scalar b,!*groebfac;!*groebfac:=t;b:=groebner1(a,nil,nil);
 return if b='(list(list 1))then nil else cdr b end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/greduo.red0000644000175000017500000000573211526203062024277 0ustar  giovannigiovannimodule greduo;
% Compute 'greduce' with several orders for the minimal polynomial.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global'(gorder gorders greduce_result);

share gorder;

share gorders;

share greduce_result;

if null gorders then gorders:='(list revgradlex gradlex lex);

symbolic procedure greduce!-orders!-eval u;
% 'Greduce_orders(p,g)'; the result is the (minimal) reduction of 'p'
% corresponding to the global variable '*orders', eventually '0'.
begin scalar b,g,l,o,p,r,rr,s,ss,v,x;
 l:=length u;
 if 2>l or 3>;
 v:='list.groebnervars(cdr g,v);
 for each oo in cdr gorders do
  if null b then
  <>;
    if rr=0 then b:=t>>;return r end;

put('greduce_orders,'psopfn,'greduce!-orders!-eval);

symbolic procedure greduce!-orders!-size p;
% Compute the size of the polynomial 'p'.
if atom p then 1 else
if eqcar(p,'expt)then(1+greduce!-orders!-size cadr p+2*x
  where x=if fixp caddr p and caddr p>1 and caddr p<30 then caddr p
          else 5*greduce!-orders!-size caddr p)else
 for each x in p sum greduce!-orders!-size x;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/pk-groeb.tex0000644000175000017500000010066711526203062024551 0ustar  giovannigiovanni\section{Groebner package}
\begin{Introduction}{Groebner bases}
The GROEBNER package calculates \nameindex{Groebner bases} using the
\nameindex{Buchberger algorithm} and provides related algorithms
for arithmetic with ideal bases, such as ideal quotients,
Hilbert polynomials (\nameindex{Hollmann algorithm}), 
basis conversion (
\nameindex{Faugere-Gianni-Lazard-Mora algorithm}), independent  
variable set (\nameindex{Kredel-Weispfenning algorithm}).



Some routines of the Groebner package are used by \nameref{solve} - in
that context the package is loaded automatically. However, if you
want to use the package by explicit calls you must load it by
\begin{verbatim}
    load_package groebner;
\end{verbatim}

For the common parameter setting of most operators in this package 
see \nameref{ideal parameters}.
\end{Introduction}



\begin{Concept}{Ideal Parameters}
\index{polynomial}
Most operators of the \name{Groebner} package compute expressions in a
polynomial ring which given as \meta{R}[\meta{var},\meta{var},...] where
\meta{R} is the current REDUCE coefficient domain.  All algebraically
exact domains of REDUCE are supported.  The package can operate over rings
and fields.  The operation mode is distinguished automatically.  In
general the ring mode is a bit faster than the field mode.  The factoring
variant can be applied only over domains which allow you factoring of
multivariate polynomials.

The variable sequence \meta{var} is either declared explicitly as argument
in form of a \nameref{list} in \nameref{torder}, or it is extracted
automatically from the expressions.  In the second case the current REDUCE
system order is used (see \nameref{korder}) for arranging the variables.
If some kernels should play the role of formal parameters (the ground
domain \meta{R} then is the polynomial ring over these), the variable
sequences must be given explicitly.

All REDUCE \nameref{kernel}s can be used as variables.  But please note,
that all variables are considered as independent.  E.g. when using
\name{sin(a)} and \name{cos(a)} as variables, the basic relation
\name{sin(a)^2+cos(a)^2-1=0} must be explicitly added to an equation set
because the Groebner operators don't include such knowledge automatically.

The terms (monomials) in polynomials are arranged according to the current
\nameref{term order}.  Note that the algebraic properties of the computed
results only are valid as long as neither the ordering nor the variable
sequence changes.

The input expressions \meta{exp} can be polynomials \meta{p}, rational
functions \meta{n}/\meta{d} or equations \meta{lh}=\meta{rh} built from
polynomials or rational functions.  Apart from the \name{tracing}
algorithms \nameref{groebnert} and \nameref{preducet}, where the equations
have a specific meaning, equations are converted to simple expressions by
taking the difference of the left-hand and right-hand sides
\meta{lh}-\meta{rh}=>\meta{p}.  Rational functions are converted to
polynomials by converting the expression to a common denominator form
first, and then using the numerator only \meta{n}=>\meta{p}.  So eventual
zeros of the denominators are ignored.

A basis on input or output of an algorithm is coded as \nameref{list} of
expressions \{\meta{exp},\meta{exp},...\} . \end{Concept}

%-----------------------------------------------------------------
\subsection{Term order}
%-----------------------------------------------------------------
\begin{Introduction}{Term order}
\index{distributive polynomials}
For all \name{Groebner} operations the polynomials are 
represented in distributive form: a sum of terms (monomials).
The terms are ordered corresponding to the actual \name{term order}
which is set by the \nameref{torder} operator, and to the
actual variable sequence which is either given as explicit
parameter or by the system \nameref{kernel} order. 
\end{Introduction}

\begin{Operator}{torder}
The operator \name{torder} sets the actual variable sequence and term order.

1. simple term order:
\begin{Syntax}
  \name{torder}\(\meta{vl}, \meta{m}\)
\end{Syntax}

where  \meta{vl} is a \nameref{list} of variables (\nameref{kernel}s) and
\meta{m} is the name of a simple \nameref{term order} mode 
\ref{lex term order}, \ref{gradlex term order}, 
\ref{revgradlex term order} or another implemented parameterless mode.

2. stepped term order:
\begin{Syntax}
  
  \name{torder} \(\meta{vl},\meta{m},\meta{n}\)

\end{Syntax}
  
where \meta{m} is the name of a two step term order, one of
\nameref{gradlexgradlex term order}, \nameref{gradlexrevgradlex term order},
\nameref{lexgradlex term order} or \nameref{lexrevgradlex term order}, and
\meta{n} is a positive integer.

3. weighted term order
\begin{Syntax}
 \name{torder} \(\meta{vl}, \name{weighted}, \meta{n},\meta{n},...\); 
\end{Syntax}

where the \meta{n} are positive integers, see \nameref{weighted term order}.

4. matrix term order
\begin{Syntax}
 \name{torder} \(\meta{vl}, \name{matrix}, \meta{m}\); 
\end{Syntax}

where \meta{m} is a matrix with integer elements, see 
\nameref{torder_compile}.

5. compiled term order
\begin{Syntax}
 \name{torder} \(\meta{vl}, \name{co}\); 
\end{Syntax}

where \meta{co} is the name of a routine generated by 
\nameref{torder_compile}.

\name{torder} sets the variable sequence and the term order mode. If the
an empty list is used as variable sequence, the automatic variable extraction
is activated. The defaults are the empty variable list an the 
\nameref{lex term order}. 
The previous setting is returned as a list. 

Alternatively to the above syntax the arguments of \name{torder} may be 
collected in a \nameref{list} and passed as one argument to 
\name{torder}.

\end{Operator}
%------------------------------------------------------------
\begin{Operator}{torder_compile}
\index{term order}
A matrix can be converted into
a compilable LISP program for faster execution by using
\begin{Syntax}
    \name{torder\_compile}\(\meta{name},\meta{mat}\)
\end{Syntax}
where \meta{name} is an identifier for the new term order and \meta{mat}
is an integer matrix to be used as \nameref{matrix term order}. Afterwards
the term order can be activated by using \meta{name} in a \nameref{torder}
expression. The resulting program is compiled if the switch \nameref{comp}
is on, or if the  \name{torder\_compile} expression is part of a compiled
module.
\end{Operator}
%------------------------------------------------------------
\begin{Concept}{lex term order}
\index{term order}\index{variable elimination}
The terms are ordered lexicographically: two terms t1 t2 
are compared for their degrees 
along the fixed variable sequence: t1 is higher than t2
if the first different degree is higher in t1.
This order has the \name{elimination property}
for \name{groebner basis} calculations.
If the ideal has a univariate polynomial in the last
variable the groebner basis will contain
such polynomial. \name{Lex} is best
suited for solving of polynomial equation systems.

\end{Concept}

%------------------------------------------------------------
\begin{Concept}{gradlex term order}
\index{term order}
The terms are ordered first with their total
degree, and if the total degree is identical
the comparison is \nameref{lex term order}.
With \name{groebner} basis calculations this term order
produces polynomials of lowest degree.
\end{Concept}

%------------------------------------------------------------
\begin{Concept}{revgradlex term order}
\index{term order}
The terms are ordered first with their total
degree (degree sum), and if the total degree is identical
the comparison is the inverse of \nameref{lex term order}.
With \nameref{groebner} and \nameref{groebnerf} 
calculations this term order
is similar to \nameref{gradlex term order}; it is known
as most efficient ordering with respect to computing time.
\end{Concept}

%------------------------------------------------------------
\begin{Concept}{gradlexgradlex term order}
\index{term order}
The terms are separated into two groups where the
second parameter of the \nameref{torder} call determines
the length of the first group. For a comparison first
the total degrees of both variable groups are compared.
If both are equal 
\nameref{gradlex term order} comparison is applied to the first
group, and if that does not decide \nameref{gradlex term order}
is applied for the second group. This order has the elimination
property for the variable groups. It can be used e.g. for
separating variables from parameters.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{gradlexrevgradlex term order}
\index{term order}
Similar to \nameref{gradlexgradlex term order}, but using
\nameref{revgradlex term order} for the second group.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{lexgradlex term order}
\index{term order}
Similar to \nameref{gradlexgradlex term order}, but using
\nameref{lex term order} for the first group.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{lexrevgradlex term order}
\index{term order}
Similar to \nameref{gradlexgradlex term order}, but using
\nameref{lex term order} for the first group
\nameref{revgradlex term order} for the second group.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{weighted term order}
\index{term order}
establishes a graduated ordering
similar to \nameref{gradlex term order}, where the exponents first are
multiplied by the given weights. If there are less weight values than
variables, the weight list is extended by ones. If the weighted degree
comparison is not decidable, the 
\nameref{lex term order} is used.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{graded term order}
\index{term order}
establishes a cascaded term ordering:  first a graduated ordering
similar to \nameref{gradlex term order} is used, where the exponents first are
multiplied by the given weights. If there are less weight values than
variables, the weight list is extended by ones. If the weighted degree
comparison is not decidable, the term ordering described in the following
parameters of the \nameref{torder} command is used.
\end{Concept}
%------------------------------------------------------------
\begin{Concept}{matrix term order}
\index{term order}
Any arbitrary term order mode can be installed by a matrix with
integer elements where the row length corresponds to the variable
number. The matrix must have at least as many rows as columns.
It must have full rank, and the top nonzero element of each column
must be positive.

The matrix \name{term order mode}
defines a term order where the exponent vectors of the monomials are
first multiplied by the matrix and the resulting vectors are compared
lexicographically.

If the switch \nameref{comp} is on, the matrix is converted into
a compiled LISP program for faster execution. A matrix can also be
compiled explicitly, see \nameref{torder_compile}.
\end{Concept}
%--------------------------------------------------------------- 
%------------------------------------------------------------
\subsection{Basic Groebner operators}
%-------------------------------------------------------------
\begin{Operator}{gvars}
\begin{Syntax}

  \name{gvars}\(\{\meta{exp},\meta{exp},... \}\)

\end{Syntax}
 where \meta{exp} are expressions or \nameref{equation}s.

\name{gvars} extracts from the expressions the \nameref{kernel}\name{s} 
which can 
play the role of variables for a \nameref{groebner} or \nameref{groebnerf} 
calculation. 
\end{Operator}

%---------------------------------------------------------------

\begin{Operator}{groebner}
\index{Buchberger algorithm}
\begin{Syntax}

  \name{groebner}\(\{\name{exp}, ...\}\)

\end{Syntax}
where \{\name{exp}, ... \} is a list of
expressions or equations.


The operator \name{groebner} implements the Buchberger algorithm
for computing Groebner bases for a given set of
expressions with respect to the given set of variables in the order
given.  As a side effect, the sequence of variables is stored as a REDUCE list
in the shared variable \nameref{gvarslast} - this is important in cases
where the algorithm rearranges the variable sequence because \nameref{groebopt}
is \name{on}.

\begin{Examples}
   groebner({x**2+y**2-1,x-y})  &  \{X - Y,2*Y**2 -1\}
\end{Examples}
\begin{Related}
\item[ \nameref{groebnerf} operator]
\item[ \nameref{gvarslast} variable]
\item[ \nameref{groebopt} switch]
\item[ \nameref{groebprereduce} switch]
\item[ \nameref{groebfullreduction} switch]
\item[ \nameref{gltbasis} switch]
\item[ \nameref{gltb} variable]
\item[ \nameref{glterms} variable]
\item[ \nameref{groebstat} switch]
\item[ \nameref{trgroeb} switch]
\item[ \nameref{trgroebs} switch]
\item[ \nameref{groebprot} switch]
\item[ \nameref{groebprotfile} variable]
\item[ \nameref{groebnert} operator]
\end{Related}
\end{Operator}
%-------------------------------------------------------

\begin{Operator}{groebner\_walk}
The operator \name{groebner\_walk} computes a \nameref{lex} basis
from a given \nameref{graded} (or \nameref{weighted}) one.
\begin{Syntax}
   \name{groebner\_walk}\(\meta{g}\)
\end{Syntax}

where \meta{g} is a \nameref{graded} basis (or \nameref{weighted} basis
with a weight vector with one repeated element) of the polynomial ideal. 
\name{Groebner\_walk} computes a sequence of monomial bases, each
time lifting the full system to a complete basis.  \name{Groebner\_walk}
should be called only in cases, where a normal \nameref{kex} computation
would take too much computer time.

The operator \nameref{torder} has to be called before in order to
define the variable sequence and the term order mode of \meta{g}. 

The variable \nameref{gvarslast} is not set.

Do not call \name{groebner\_walk} with \name{on} \nameref{groebopt}.

\name{Groebner\_walk} includes some overhead (such as e. g. 
computation with division). On the other hand, sometimes
\name{groebner\_walk} is faster than a direct \nameref{lex} computation.
\end{Operator}

%-------------------------------------------------------

\begin{Switch}{groebopt}
If \name{groebopt} is set ON, the sequence of variables is optimized
with respect to execution speed of \name{groebner} calculations; 
note that the final list of variables is available in \nameref{gvarslast}.
By default \name{groebopt} is off, conserving the original variable
sequence.

An explicitly declared dependency using the \nameref{depend}
declaration  supersedes the variable optimization.
\begin{Examples}

   depend a, x, y;

\end{Examples}
guarantees that a will be placed in front of x and y.
\end{Switch}


%-------------------------------------------------------

\begin{Variable}{gvarslast}
After a \nameref{groebner} or \nameref{groebnerf} calculation
the actual variable sequence is stored in the variable 
\name{gvarslast}. If \nameref{groebopt} is \name{on}
\name{gvarslast} shows the variable sequence after reordering.
\end{Variable}

%--------------------------------------------------------------

\begin{Switch}{groebprereduce}
If \name{groebprereduce} set ON, \nameref{groebner} 
and \nameref{groebnerf} try to simplify the
input expressions: if the head term of an input expression is a
multiple of the head term of another expression, it can be reduced;
these reductions are done cyclicly as long as possible in order to
shorten the main part of the algorithm.

By default \name{groebprereduce} is off.
\end{Switch}

%---------------------------------------------------------------

\begin{Switch}{groebfullreduction}
If \name{groebfullreduction} set off, the polynomial reduction steps during
\nameref{groebner} and \nameref{groebnerf} are limited to the pure head
term reduction; subsequent terms are reduced otherwise.

By default \name{groebfullreduction} is on.
\end{Switch}

%----------------------------------------------------------------

\begin{Switch}{gltbasis}
If \name{gltbasis} set on, the leading terms of the result basis 
of a \nameref{groebner} or \nameref{groebnerf} calculation are
extracted. They are collected as a basis of monomials, which is
available as value of the global variable \nameref{gltb}.
\end{Switch}
%------------------------------------------------------------------
\begin{Variable}{gltb}
See \nameref{gltbasis}
\end{Variable}
%------------------------------------------------------------------

\begin{Variable}{glterms}
If the expressions in a \nameref{groebner} or \nameref{groebnerf} 
call contain parameters (symbols
which are not member of the variable list), the share variable
\name{glterms} is set to a list of expression which during the
calculation were assumed to be nonzero. The calculated bases 
are valid only under the assumption that all these expressions do
not vanish.
\end{Variable}

%-----------------------------------------------------------
\begin{Switch}{groebstat}
if \name{groebstat} is on, a summary of the 
\nameref{groebner} or \nameref{groebnerf} computation is printed
at the end 
including the computing time, the number of intermediate
H polynomials and the counters for the criteria hits.
\end{Switch}

%-----------------------------------------------------------
\begin{Switch}{trgroeb}
if \name{trgroeb} is on, intermediate H polynomials are 
printed during a \nameref{groebner} 
or \nameref{groebnerf} calculation.
\end{Switch}

%-----------------------------------------------------------
\begin{Switch}{trgroebs}
if \name{trgroebs} is on, intermediate H and S polynomials are 
printed during a \nameref{groebner} or \nameref{groebnerf} calculation.
\end{Switch}

%-----------------------------------------------------------
\begin{Operator}{gzerodim?} 
\begin{Syntax}

  \name{gzerodim!?}\(\meta{basis}\)

\end{Syntax}
where \meta{bas} is a Groebner basis in the current 
\nameref{term order} with the actual setting 
(see \nameref{ideal parameters}). 


\name{gzerodim!?} tests whether the ideal spanned by the given basis 
has dimension zero. If yes, the number of zeros is returned,
\nameref{nil} otherwise.
\end{Operator}

%---------------------------------------------------------------

\begin{Operator}{gdimension}
\index{ideal dimension}\index{groebner}
\begin{Syntax}

     \name{gdimension}\(\meta{bas}\) 

\end{Syntax}
where \meta{bas} is a \nameref{groebner} basis in the current
term order (see \nameref{ideal parameters}). 
\name{gdimension} computes the dimension of the ideal
spanned by the given basis and returns the dimension as an integer
number. The Kredel-Weispfenning algorithm is used: the dimension
is the length of the longest independent variable set,
see \nameref{gindependent\_sets}
\end{Operator}


%---------------------------------------------------------------

\begin{Operator}{gindependent\_sets}
\index{ideal variables}\index{ideal dimension}\index{groebner}
\index{Kredel-Weispfenning algorithm}
\begin{Syntax}

  \name{gindependent\_sets}\(\meta{bas}\)

\end{Syntax}
where \meta{bas} is a \nameref{groebner} basis in any \name{term order} 
(which must be the current \name{term order}) with the specified
variables (see \nameref{ideal parameters}). 


\name{Gindependent_sets} computes the maximal
left independent variable sets of the ideal, that are 
the variable sets which play the role of free parameters in the
current ideal basis. Each set is a list which is a subset of the
variable list. The result is a list of these sets. For an
ideal with dimension zero the list is empty.
The Kredel-Weispfenning algorithm is used.
\end{Operator}

%--------------------------------------------------------------

\begin{Operator}{dd_groebner}
For a homogeneous system of polynomials under 
\nameref{graded term order}, \nameref{gradlex term order}, 
\nameref{revgradlex term order} 
or \nameref{weighted term order} 
a Groebner Base can be computed with limiting the grade
of the intermediate S polynomials: 
\begin{Syntax}
\name{dd_groebner}\(\meta{d1},\meta{d2},\meta{plist}\)
\end{Syntax}
where \meta{d1} is a non negative integer and \meta{d2} is an integer
or ``infinity". A pair of polynomials is considered
only if the grade of the lcm of their head terms is between
\meta{d1} and \meta{d2}.
For the term orders \name{graded} or \name{weighted} the (first) weight
vector is used for the grade computation. Otherwise the total
degree of a term is used.
\end{Operator}

%--------------------------------------------------------------


\begin{Operator}{glexconvert}
\index{ideal variables}\index{term order}
\begin{Syntax}

\name{glexconvert}\(\meta{bas}[,\meta{vars}][,MAXDEG=\meta{mx}]
[,NEWVARS=\meta{nv}]\)

\end{Syntax}
where \meta{bas} is a \nameref{groebner} basis
in the current term order,  \meta{mx} (optional) is a positive
integer and \meta{nvl} (optional) is a list of variables 
(see \nameref{ideal parameters}).


The operator \name{glexconvert} converts the basis 
of a zero-dimensional ideal (finite number
of isolated solutions) from arbitrary ordering into a basis under 
\nameref{lex term order}. 


The parameter \meta{newvars} defines the new variable sequence. 
If omitted, the
original variable sequence is used. If only a subset of variables is
specified here, the partial ideal basis is evaluated. 

If \meta{newvars} is a list with one element, the minimal
\nameindex{univariate polynomial} is computed.

\meta{maxdeg} is an upper limit for the degrees. The algorithm stops with
an error message, if this limit is reached.

A warning occurs, if the ideal is not zero dimensional.
\begin{Comments}
During the call the \name{term order} of the input basis must
be active.
\end{Comments}
\end{Operator}

%--------------------------------------------------------------

\begin{Operator}{greduce}
\begin{Syntax}

\name{greduce}\(exp, \{exp1, exp2, \ldots , expm\}\)

\end{Syntax}

where exp is an expression, and \{exp1, exp2, ... , expm\} is
a list of expressions or equations.


\name{greduce} is functionally equivalent with a call to
\nameref{groebner} and then a call to \nameref{preduce}.
\end{Operator}

%---------------------------------------------------------

\begin{Operator}{preduce}
\begin{Syntax}

 \name{preduce}\(\meta{p}, \{\meta{exp}, \ldots \}\)

\end{Syntax}

where \meta{p} is an expression, and \{\meta{exp}, ... \} is
a list of expressions or equations.


\name{Preduce} computes the remainder of \name{exp}
modulo the given set of polynomials resp. equations.
This result is unique (canonical) only if the given set
is a \name{groebner} basis under the current \nameref{term order}

see also: \nameref{preducet} operator.

\end{Operator}


%-------------------------------------------

\begin{Operator}{idealquotient}
\begin{Syntax}

\name{idealquotient}\(\{\meta{exp}, ...\}, \meta{d}\)

\end{Syntax}
where \{\meta{exp},...\} is a list of 
expressions or equations,  \meta{d} is a single expression or equation.


\name{Idealquotient} computes the ideal quotient:
ideal spanned by the expressions \{\meta{exp},...\}
divided by the single polynomial/expression \meta{f}. The result
is the \nameref{groebner} basis of the quotient ideal.
\end{Operator}

%-------------------------------------------------------------

\begin{Operator}{hilbertpolynomial}
\index{Hollmann algorithm}
\begin{Syntax}

  hilbertpolynomial\(\meta{bas}\)

\end{Syntax}
where \meta{bas} is a \nameref{groebner} basis in the
current \nameref{term order}.

The degree of the \name{Hilbert polynomial} is the
dimension of the ideal spanned by the basis. For an
ideal of dimension zero the Hilbert polynomial is a
constant which is the number of common zeros of the
ideal (including eventual multiplicities).
The \name{Hollmann algorithm} is used.
\end{Operator}

%-------------------------------------------

\begin{Operator}{saturation}
\begin{Syntax}

\name{saturation}\(\{\meta{exp}, ...\}, \meta{p}\)

\end{Syntax}
where \{\meta{exp},...\} is a list of
expressions or equations,  \meta{p} is a single polynomial.

\name{Saturation} computes the quotient of the polynomial \meta{p}
and a power (with unknown but finite exponent) of the ideal built from
\{\meta{exp}, ...\}. The result is the computed quotient. \name{Saturation}
calls \nameref{idealquotient} several times until the result does not change
any more.
\end{Operator}

%-------------------------------------------------------------
\subsection{Factorizing Groebner bases}
%-------------------------------------------------------------

\begin{Operator}{groebnerf}
\begin{Syntax}

\name{groebnerf}\(\{\meta{exp}, ...\}[,\{\},\{\meta{nz}, ... \}]\);

\end{Syntax}
where \{\meta{exp}, ... \} is a list of expressions or
equations, and \{\meta{nz},... \} is
an optional list of polynomials to be considered as non zero
for this calculation. An empty list must be passed as second argument
if the non-zero list is specified.


\name{groebnerf} tries to separate polynomials into individual factors and
to branch the computation in a recursive manner (factorization tree).
The result is a list of partial Groebner bases. 
Multiplicities (one factor with a higher power, the same partial basis
twice) are deleted as early as possible in order to speed up the
calculation. 

The third parameter of \name{groebnerf} declares some polynomials
nonzero. If any of these is found in a branch of the calculation
the branch is canceled. 

\begin{Bigexample}
groebnerf({ 3*x**2*y+2*x*y+y+9*x**2+5*x = 3,  
            2*x**3*y-x*y-y+6*x**3-2*x**2-3*x = -3, 
            x**3*y+x**2*y+3*x**3+2*x**2 }, {y,x});

       {{Y - 3,X},

                      2
    {2*Y + 2*X - 1,2*X  - 5*X - 5}}
\end{Bigexample}

\begin{Related}
\item[ \nameref{groebresmax} variable]
\item[ \nameref{groebmonfac} variable]
\item[ \nameref{groebrestriction} variable]
\item[ \nameref{groebner} operator]
\item[ \nameref{gvarslast} variable]
\item[ \nameref{groebopt} switch]
\item[ \nameref{groebprereduce} switch]
\item[ \nameref{groebfullreduction} switch]
\item[ \nameref{gltbasis} switch]
\item[ \nameref{gltb} variable]
\item[ \nameref{glterms} variable]
\item[ \nameref{groebstat} switch]
\item[ \nameref{trgroeb} switch]
\item[ \nameref{trgroebs} switch]
\item[ \nameref{groebnert} operator]
\end{Related}

\end{Operator}

% ------------------------------------------------------------------

\begin{Variable}{groebmonfac}
The variable \name{groebmonfac} is connected to
the handling of monomial factors.  A monomial factor is a product
of variable powers as a factor, e.g. x**2*y  in  x**3*y -
2*x**2*y**2.  A monomial factor represents a solution of the type
 x = 0  or  y = 0 with a certain multiplicity.  With
\nameref{groebnerf} the multiplicity of monomial factors is lowered 
to the value of the shared variable \name{groebmonfac}
which by default is 1 (= monomial factors remain present, but their
multiplicity is brought down). With
\name{groebmonfac}:= 0
the monomial factors are suppressed completely.
\end{Variable}

% ----------------------------------------------------------------
\begin{Variable}{groebresmax}
The variable \name{groebresmax}
controls  during \nameref{groebnerf} calculations
the number of partial results. Its default value is 300. If
more partial results are calculated, the calculation is
terminated.
\end{Variable}

% ----------------------------------------------------------------
\begin{Variable}{groebrestriction}
During \nameref{groebnerf} calculations 
irrelevant branches can be excluded
by setting the variable \name{groebrestriction}. The
following restrictions are implemented:
\begin{Syntax} 
     \name{groebrestriction} := \name{nonnegative} \\
     \name{groebrestriction} := \name{positive}\\
     \name{groebrestriction} := \name{zeropoint}
\end{Syntax}
With \name{nonnegative} branches are excluded where one
polynomial has no nonnegative real zeros; with \name{positive}
the restriction is sharpened to positive zeros only.
The restriction \name{zeropoint} excludes all branches
which do not have the origin (0,0,...0) in their solution
set.
\end{Variable}

%---------------------------------------------------------
\subsection{Tracing Groebner bases}
%---------------------------------------------------------
\index{tracing Groebner}
\begin{Switch}{groebprot}
If \name{groebprot} is \name{ON} the computation steps during
\nameref{preduce}, \nameref{greduce} and \nameref{groebner}
are collected in a list which is assigned to the variable
\nameref{groebprotfile}.
\end{Switch}
%----------------------------------------------------------
\begin{Variable}{groebprotfile}
See \nameref{groebprot} switch.
\end{Variable}
%----------------------------------------------------------

\begin{Operator}{groebnert}
\begin{Syntax}

  \name{groebnert}\(\{\meta{v}=\meta{exp},...\}\)

\end{Syntax}
where \meta{v} are \nameref{kernel}\name{s} (simple or indexed variables),
\meta{exp} are polynomials.


\name{groebnert} is functionally equivalent to a \nameref{groebner}
call for \{\meta{exp},...\}, but the result is a set of
equations where the left-hand sides are the basis elements while
the right-hand sides are the same values expressed as combinations
of the input formulas, expressed in terms of the names \meta{v}
\begin{Bigexample}
    groebnert({p1=2*x**2+4*y**2-100,p2=2*x-y+1});

   GB1 := {2*X - Y + 1=P2,

           2
        9*Y  - 2*Y - 199= - 2*X*P2 - Y*P2 + 2*P1 + P2}
\end{Bigexample}
\end{Operator}
%----------------------------------------------------------

\begin{Operator}{preducet}
\begin{Syntax}

\name{preduce}\(\meta{p},\{\meta{v}=\meta{exp}...\}\)
\end{Syntax}
where \meta{p} is an expression, \meta{v} are kernels 
(simple or indexed variables),
\name{exp} are polynomials.

\name{preducet} computes the remainder of \meta{p} modulo \{\meta{exp},...\}
similar to \nameref{preduce}, but the result is an equation
which expresses the remainder as combination of the polynomials.
\begin{Bigexample}
                             
   GB2 := {G1=2*X - Y + 1,G2=9*Y**2  - 2*Y - 199}
   preducet(q=x**2,gb2);

 - 16*Y + 208= - 18*X*G1 - 9*Y*G1 + 36*Q + 9*G1 - G2
\end{Bigexample}
\end{Operator}

%------------------------------------------------------------
\subsection{Groebner Bases for Modules}
%------------------------------------------------------------
\begin{Concept}{Module}
Given a polynomial ring, e.g. R=Z[x,y,...] and an integer n>1.
The vectors with n elements of R form a free MODULE under
elementwise addition and multiplication with elements of R.

For a submodule given by a finite basis a Groebner basis
can be computed, and the facilities of the GROEBNER package
are available except the operators \nameref{groebnerf}
and \name{groesolve}. The vectors are encoded using auxiliary
variables which represent the unit vectors in the module.
These are declared in the share variable \nameref{gmodule}.

\end{Concept}

\begin{Variable}{gmodule}
The vectors of a free \nameref{module} over a polynomial ring R 
are encoded as linear combinations with unit vectors of
M which are represented by auxiliary variables. These
must be collected in the variable \name{gmodule} before
any call to an operator of the Groebner package.

\begin{verbatim}
   torder({x,y,v1,v2,v3})$
   gmodule := {v1,v2,v3}$
   g:=groebner({x^2*v1 + y*v2,x*y*v1 - v3,2y*v1 + y*v3});
\end{verbatim}

compute the Groebner basis of the submodule

\begin{verbatim}
      ([x^2,y,0],[xy,0,-1],[0,2y,y])
\end{verbatim}
The members of the list \name{gmodule} are automatically
appended to the end of the variable list, if they are not
yet members there. They take part in the actual term ordering.
\end{Variable}

%------------------------------------------------------------
\subsection{Computing with distributive polynomials}
%------------------------------------------------------------

\begin{Operator}{gsort}
\index{distributive polynomials}
\begin{Syntax}

 \name{gsort}\(\meta{p}\)
\end{Syntax}
where \meta{p} is a polynomial or a list of polynomials.

The polynomials are reordered and sorted corresponding to
the current \nameref{term order}.
\begin{Examples}

  torder lex;\\  
  gsort(x**2+2x*y+y**2,{y,x});  &  {y**2+2y*x+x**2}

\end{Examples}
\end{Operator}

%------------------------------------------------------------

\begin{Operator}{gsplit}
\index{distributive polynomials}
\begin{Syntax}

 \name{gsplit}\(\meta{p}[,\meta{vars}]\);
\end{Syntax}
where \meta{p} is a polynomial or a list of polynomials.

The polynomial is reordered corresponding to the 
the current \nameref{term order} and then
separated into leading term and reductum. Result is
a list with the leading term as first and the reductum
as second element.
\begin{Examples}

  torder lex;\\  
  gsplit(x**2+2x*y+y**2,{y,x});  &  \{y**2,2y*x+x**2\}

\end{Examples}
\end{Operator}
%-------------------------------------------------------

\begin{Operator}{gspoly}
\index{distributive polynomials}
\begin{Syntax}

 \name{gspoly}\(\meta{p1},\meta{p2}\);

\end{Syntax}
where \meta{p1} and \meta{p2} are polynomials.

The \name{subtraction} polynomial of p1 and p2 is computed
corresponding to the method of the Buchberger algorithm for
computing \name{groebner bases}: p1 and p2 are multiplied
with terms such that when subtracting them the leading terms 
cancel each other.
\end{Operator}

mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/ideals.tst0000644000175000017500000000157311526203062024312 0ustar  giovannigiovanniI_setting(x,y,z);

torder revgradlex;

u := I(x*z-y**2, x**3-y*z);
y member I(x,y^2);
x member I(x,y^2);
I(x,y^2) subset I(x,y);         % yes
I(x,y) subset I(x,y^2);         % no

% examples taken from Cox, Little, O'Shea: "Ideals, Varieties and Algorithms"




q1 := u .: I(x);                        % quotient ideal

q2 := u .+ I(x^2 * y - z^2);            % sum ideal

if q1 .= q2 then write "same ideal";    % test equality

intersection(u,I(y));                   % ideal intersection

u .: I(y);

u .: I(x,y);

%-----------------------------------------------------

u1 := I(x,y^2);
u1u1:= u1 .* u1;                       % square ideal
u0 :=I(x,y);

% test equality/inclusion for u1,u1u1,u0

u1 .= u1u1;     % no

u1 subset u1u1; % no

u1u1 subset u1; % yes

u1 .= u0;       % no

u1 subset u0;   % yes

intersection (I(x) , I(x^2,x*y,y^2)) .= intersection(I(x) , I(x^2,y)); 

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebspa.red0000644000175000017500000000673111526203062024614 0ustar  giovannigiovannimodule groebspa;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
% Manipulation of subspaces .
% A subspace among the variables is described by an exponent vector
% with only zeroes and ones . It terminates with the last
% one . It may be null(nil).
%
% 24.9.2007 HM enable the call "vevunion(...,nil)".

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



symbolic procedure vevunion(e1,e2);
if null e2 then (e1 or vevunion2()) else
begin scalar x,y;y:=vevunion1(e1,e2);
 x:=reverse y;if car x = 1 then return y;
 while x and car x = 0 do x:=cdr x;return reversip x end;

symbolic procedure vevunion1(e1,e2);
 if vdpsubspacep(e1,e2)then e2 else
 if vdpsubspacep(e2,e1)then e1 else
 (if car e1 neq 0 or car e2 neq 0 then 1 . z else
  0 . z) where z=vevunion1(cdr e1,cdr e2);

symbolic procedure vevunion2;
 <> where y=vevunion3 vdpvars!*;

symbolic procedure vevunion3 x;
  if null x then nil else (0 . vevunion3 cdr x);

symbolic procedure vdpsubspacep(e1,e2);
% Test if e1 describes a subspace from e2 .
 if null e1 then t else
 if null e2 then vdpspacenullp e1 else
 if car e1 > car e2 then nil else
 if e1 = e2 then t else vdpsubspacep(cdr e1,cdr e2);

symbolic procedure vdporthspacep(e1,e2);
% Test if e1 and e2 describe orthogonal spaces(no intersection).
 if null e1 or null e2 then t else
 if car e2 = 0 or car e1 = 0 then vdporthspacep(cdr e1,cdr e2)else nil;

symbolic procedure vdpspacenullp e1;
% Test if e1 describes an null space .
 if null e1 then t else
 if car e1 = 0 then vdpspacenullp cdr e1 else nil;

symbolic procedure vdpspace p;
% Determine the variables of the polynomial .
begin scalar x,y;
 if vdpzero!? p then return nil;
 x:=vdpgetprop(p,'subroom);
 if x then return x;
 x:=vevunion(nil,vdpevlmon p);
 y:=vdpred p;
 while not vdpzero!? y do
 <>;
 vdpputprop(p,'subroom,x);
 return x end;

symbolic procedure vdpunivariate!? p;
 if vdpgetprop(p,'univariate)then t
  else begin scalar ev;integer n;
   ev:=vdpevlmon p;
   for each x in ev do
    if not(x = 0)then n:=n #+ 1;
    if not(n = 1)then return nil;
    ev:=vdpspace p;
    for each x in ev do
     if not(x = 0)then n:=n #+ 1;
     if not(n = 1)then return nil;
     vdpputprop(p,'univariate,t);
     return t end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebres.red0000644000175000017500000001015311526203062024613 0ustar  giovannigiovannimodule groebres;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Optimization of h-Polynomials by resultant calculation and
%  factorization .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The resultant is calculated from a h-polynomial and its predecessor
% if both are bivariate in the same variables and if these variables
% are the last ones in vdpvars* .

symbolic procedure groebtestresultant(h1,h2,lv);
     begin scalar v1,hlist;
         v1 := indexcpl(vevsum0(lv,h1),1);
         if groebrescheck!?(2,v1,lv)
            and indexcpl(vevsum0(lv,h2),1)=v1
            then hlist :=
                   reverse vdplsort
                    groebhlistfromresultant
                        (h1,h2,cadr reverse vdpvars!*)
          else
         if groebrescheck1!?(2,v1,lv)
            and indexcpl(vevsum0(lv,h2),1)=v1
            then hlist :=
                   reverse vdplsort
                    groebhlistfromresultant
                        (h1,h2,caddr reverse vdpvars!*);
         if null hlist then return nil;
         return ' resultant .
              for each x in hlist collect {h2,vdpenumerate x} end;

symbolic procedure groebhlistfromresultant(h1,h0,x);
% new h-polynomial calculation: calculate
% the resultant of the two distributive polynomials h1 and h0
% with respect to x.
begin scalar ct00,hh,hh1,hs2;
   ct00:= time();
   hh:= vdpsimpcont groebresultant(h1,h0,x);
   if !*trgroeb  then <>;
   hs2:= nil;
   if not vdpzero!? hh then
       << hh1:= vdp2a vdprectoint(hh,vdplcm hh);
          hh1:= fctrf !*q2f simp hh1;
          if cdr hh1 and cddr hh1 then
               hs2:= for each p in cdr hh1 collect a2vdp prepf car p;
          if !*trgroeb and hs2 then
                    <>;
           >>;
  return hs2 end;


symbolic procedure groebresultant(p1,p2,x);
begin scalar q1,q2,q;
q1:=vdp2a vdprectoint(p1,vdplcm p1);
q2:=vdp2a vdprectoint(p2,vdplcm p2);
q:=a2vdp prepsq simpresultant {q1,q2,x};
return q end;

symbolic procedure groebrescheck!?(a,h1,vl);
  length h1 = a and car h1 = vl - 1;


symbolic procedure groebrescheck1!?(a,h1,vl);
  length h1 = a and car h1 = vl - 2 and cadr h1 = vl - 1;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/grinterf.red0000644000175000017500000002461311526203062024631 0ustar  giovannigiovanni% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module grinterf;% Interface of Groebner package to reduce.
% Entry points to the main module and general interface support.

flag('(groebrestriction gvarslast groebprotfile gltb glterms gmodule),'share);

switch groebopt,trgroeb,gltbasis,gsugar;

vdpsortmode!*:='lex;% Initial mode .

gltb:='(list);    % Initially empty .

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Interface functions .

symbolic procedure groebnereval u;
% Non factorizing Groebner calculation .
begin scalar n,!*groebfac,!*groebrm,!*factor,!*exp;!*exp:=t;
 n:=length u;
 if n=1 then return cadr groebner1(reval car u,nil,nil)
  else if n neq 2
   then rerror(groebner,1,"groebner called with wrong number of arguments");
 u:=groebner1(reval car u,reval cadr u,nil);
 if !*gltbasis then gltb:=cadr gltb;
 return cadr u end;

put('groebner,'psopfn,'groebnereval);

symbolic procedure groebnerfeval u;
% Non factorizing Groebner calculation .
begin scalar n,!*groebfac,!*groebrm,!*factor,!*exp,!*ezgcd,
 s,r,q;!*exp:=t;
 !*groebrm:=!*groebfac:=t;
 groebrestriction!*:=reval groebrestriction;
 if null dmode!* then !*ezgcd:=t;
 n:=length u;
 r:=if n=1 then groebner1(reval car u,nil,nil)else
      if n=2 then groebner1(reval car u,reval cadr u,nil)else
      if n neq 3
        then rerror(groebner,2,
            "groebner called with wrong number of arguments")
       else  groebner1(reval car u,reval cadr u,reval caddr u);
 q:=r;
       % Remove duplicates.
 while q do<>;
 return r end;

put('groebnerf,'psopfn,'groebnerfeval);

symbolic procedure idquotienteval u;
begin scalar n,!*factor,!*exp;!*exp:=t;
 n:=length u;
 if n=2 then return groebidq(reval car u,reval cadr u,nil)
 else if n neq 3
  then rerror(groebner,3,"idquotient called with wrong number of arguments")
   else return groebidq(reval car u,reval cadr u,reval caddr u)end;

put('idealquotient,'psopfn,'idquotienteval);

symbolic procedure saturationeval u;
begin scalar a,b,c,!*factor,!*exp;!*exp:=t;
 if length u=2 then go to aa;
 rerror(groebner,19,"saturation called with wrong number of arguments");
aa:a:=reval car u;
 if car a='list then go to bb;
 rerror(groebner,20,"saturation, first parameter must be a list");
bb:a:='list.for each aa in cdr a collect
  if eqexpr aa then reval !*eqn2a aa else aa;
 c:=reval cadr u;
 if car c='list then
  rerror(groebner,25,"saturation, second parameter must not be a list");
 if eqexpr c then c:=reval !*eqn2a c;
 while not(b=a)do<>;return b end;

put('saturation,'psopfn,'saturationeval);

symbolic procedure groebner1(u,v,r);
% Buchberger algorithm system driver.'u'is a list of expressions
% and'v'a list of variables or nil in which case the variables in'u'
% are used.
begin scalar vars,w,np,oldorder,!*grmod!*;integer pcount!*;
 w:=for each j in groerevlist u
  collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebner,4,"empty list in groebner");
 vars:=groebnervars(w,v);
 if r then r:=groerevlist r;
 groedomainmode();
 if vars then go to notempty;
 u:=0;for each p in w do if p neq 0 then u:=1;
 return{'list,{'list,u}};
notempty:if dmode!* eq'!:mod!: and null setdiff(gvarlis w,vars)
  and current!-modulus < largest!-small!-modulus
   then !*grmod!*:=t;
 oldorder:=vdpinit vars;
                  % Cancel common denominators.
 w:=for each j in w collect reorder numr simp j;
                  % Optimize variable sequence if desired.
 if !*groebopt and vdpsortmode!* memq'(lex gradlex revgradlex)
  then<>;
 w:=for each j in w collect f2vdp j;
 if not !*vdpinteger then
 <>>>;
 if !*groebprot then groebprotfile:={'list};
 if r then r:=for each p in r collect vdpsimpcont f2vdp numr simp p;
 w:=groebner2(w,r);
 if cdr w then  % Remove redundant partial bases.
 begin scalar !*gsugar;
  for each b in w do
   for each c in w do
    if b and b neq c then
    <>>>end;
 if !*gltbasis then
  gltb:='list.for each base in w collect
         'list.for each j in base collect vdp2a vdpfmon(a2vbc 1,vdpevlmon j);
 w:='list.for each base in w collect 'list.for each j in base collect vdp2a j;
 vdpcleanup();gvarslast:='list.vars;return w end;

symbolic procedure groebnervars(w,v);
begin scalar z,dv,gdv,vars;
 if v='(list)then v:=nil;
 v:=v or(gdv:=cdr global!-dipvars!*)and global!-dipvars!*;
 vars:=
  if null v then
   for each j in gvarlis w collect !*a2k j
  else                      % test, if vars are really used
  <>;dv>>;
 return gdv or vars end;

symbolic procedure groebnerzerobc u;
%'u'is the list of parameters in a Groebner job. Extract the
% corresponding rules from !*match and powlis!*.
if u then
 begin scalar w,m,p;
  bczerodivl!*:=nil;m:=!*match;!*match:=nil;p:=powlis!*;powlis!*:=nil;
  for each r in m do if cadr r='(nil.t)then
  <>;
 for each r in p do if member(car r,u)and caddr r='(nil.t)then
 <>;
 for each r in asymplis!* do if member(car r,u)then
  bczerodivl!*:=(r .* 1 .+ nil).bczerodivl!*;
 !*match:=m;powlis!*:=p end;

% Hier

symbolic procedure gvarlis u;
% Finds variables(kernels)in the list of expressions u.
sort(gvarlis1(u,nil),function ordop);

symbolic procedure gvarlis1(u,v);
if null u then v else union(gvar1(car u,v),gvarlis1(cdr u,v));

symbolic procedure gvar1(u,v);
if null u or numberp u or(u eq'i and !*complex)then v
 else if atom u then if u member v then v else u.v
 else if get(car u,'dname)then v
 else if car u memq'(plus times expt difference minus)
  then gvarlis1(cdr u,v)
 else if car u eq'quotient then gvar1(cadr u,v)
 else if u member v then v else u.v;

symbolic procedure groebidq(u,f,v);
% Ideal quotient.'u'is a list of expressions(gbasis),'f'a polynomial
%  and'v'a list of variables or nil.
begin scalar vars,w,np,oldorder,!*factor,!*exp;integer pcount!*;
 !*exp:=t;
 w:=for each j in groerevlist u
  collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebner,5,"empty list in idealquotient");
 if eqexpr f then f:=!*eqn2a f;
 vars:=groebnervars(w,v);
 groedomainmode();
 if null vars then vdperr'idealquotient;
 oldorder:=vdpinit vars;
                  % Cancel common denominators.
 w:=for each j in w collect numr simp j;
 f:=numr simp f;
 w:=for each j in w collect f2vdp j;
 f:=f2vdp f;% Now do the conversions.
 if not !*vdpinteger then
 <> >>;
 w:=groebidq2(w,f);
 w:='list.for each j in w collect vdp2a j;
 setkorder oldorder;
 return w end;

fluid'(!*backtrace);

symbolic procedure vdperr name;
% Case that no variables were found.
<>;

symbolic procedure groeparams(u,nmin,nmax);
%'u'is a list of psopfn-parameters;they are given to reval and
% the number of parameters is controlled to be between nmin,nmax;
% result is the list of evaluated parameters padded with nils.
begin scalar n,w;n:=length u;
 if n < nmin or n > nmax then rerror(groebner,7,
         "illegal number of parameters in call to groebner package");
 u:=for each v in u collect
 <>;
 while length u < nmax do u:=append(u,'(nil));return u end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Initialization of the distributive polynomial arithmetic.
%

symbolic procedure vdpinit vars;
begin scalar r,gm;
% Eventually set up module basis.
 if eqcar(gmodule,'list)and cdr gmodule then
  gm:=for each y in cdr gmodule collect
  <>;
  r:=vdpinit2 vars;
          % Convert an eventual module basis.
  gmodule!*:=if gm then vdpevlmon a2vdp('times.gm);return r end;

symbolic procedure groedomainmode();
<>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Some lisp functions which are not member of standard lisp.
%

symbolic procedure groedeletip(a,b);
begin scalar q;
 while b and a=car b do b:=cdr b;if null b then return nil;
 q:=b;
 while cdr b do if a=cadr b then cdr b:=cddr b else b:=cdr b;
 return q end;

symbolic procedure groerevlist u;
<>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/hille.red0000644000175000017500000002454611526203062024113 0ustar  giovannigiovannimodule hille; % Hillebrand decomposition of a zero - dimensional polynomial
% ideal following
% D. Hillebrand: Triangulierung nulldimensionaler Ideale - Implementierung und
% Vergleich zweier Algorithmen. Diplomarbeit im Studiengang Mathematik
% der Universit"at Dortmund. Betreuer: Prof. Dr. H. M. M"oller, 1999
% Dasi: hille.sav7

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% triang4: groeposthillebrand: interface for the solver (for zero -
% dimensional polynomial ideals).

symbolic procedure groeposthillebrand(u,v);
% Solve - interface for the module 'hille' (for:Hillebrand);
% ' u ' is the (partial) basis in external form (the first word is 'list);
% ' v ' is the total list of variables (the first word is 'list);
% the routine returns a list of solutions, if 'u' is zero-dimensional;
% else it returns 'nil'.
begin scalar a,d,e;u:=cdr u;
 vdpinit groebnervars(u,nil);groedomainmode();
 a:=for each uu in u collect numr simp uu;
 vars!*:=dipvars!*:=vdpvars!*:=cdr v;
 if null hillebrandtriangular(cdr v,a,nil)then return nil;
  % From now on, the zero-dimensionality has been assured.
 !*groebopt:=nil;
 a:=hillebrand(a,nil);
 for each b in a do
 <>;
 return groesolvearb(e,v) end;           %%%AENDERUNG 18.9.00

% triang3: saturation of a basis and a polynomial.

symbolic procedure hillebrandstdsat(g,p);
% Compute the basis of the saturation ideal ' g ' and polynomial ' p ' .
begin scalar a,b,c,e;
 if cdr g then go to a ;
  % ' g ' is a one - polynomial list .
 p:=p./ 1;g:=car g ./ 1;a:=t;
 while a do<>;
 e:=if not domainp numr g then{numr g}else nil;return e;
a: % The list 'g' has more than one polynomial.
 p:=prepf p;a:='list.for each gg in g collect prepf gg;
 b:=saturationeval{a,p};
 if b='(list 1)then return'(1);
 c:=for each bb in cdr b collect numr simp bb;
 return sort(c,function hillebrandcompare)end;

symbolic procedure hillebrandquot(g,p);
% Compute the quotient of 'g' and 'p', if 'p' divides 'g' as a
% polynomial (if 'p' is a polynomial divisor of 'g', ignoring the
% quotients of coefficients).
(if hillebrandvar(denr a , vars!*)then numr a ./ 1 else nil)
 where a=quotsq(g,p);

symbolic procedure hillebrandvar(p,m);
% Tests, if the variables of 'p' are contained in 'm' ; 'nil'
% if a variable of 'p' is part of 'm' ; else return 't'.
if domainp p then t else if mvar p member m then nil else
 hillebrandvar(lc p,m)and hillebrandvar(red p,m);

% triang2: the main routine 'hillebrand1'.

symbolic procedure hillebrand(g,fact);
% 'g' ist an untagged list of standard polynomials, a Groebner basis,
% 'fact' is a swich which involves faczorization (if set).
begin scalar a ; vars!*:=dipvars!*;!*trgroesolv and hillebrandmsg1 g;
 a:=hillebrand1(sort(g,function hillebrandcompare),fact);
 !*trgroesolv and hillebrandmsg2 a;return a end;

% The sorting is inverse to the normal sorting (polynomial with the
% highest leading term (normally) is the last one).

symbolic procedure hillebrandcompare(a,b);
% Comparison of 'a' and 'b' (standard polynomials) after inverse 'lex' principle.
hillebrandcompare1(a,b,vars!*);

symbolic procedure hillebrandcompare1(a,b,v);
% If the result is 't', 'a' and 'b' are sorted 'a'<'b'; if the result
% is 'nil', they are ordered 'b'<'a'.
begin scalar aa,bb,c;
 aa:=a;bb:=b;
 if domainp aa or not(mvar aa member v) then return t else
 if domainp bb or not(mvar bb member v) then
  (if mvar aa member v then return nil else return t);
aa: if domainp bb or not(mvar bb member v)then
  (if domainp aa or not(mvar aa member v)then
      return hillebrandcompare1(red a,red b,v)else return t) else
 if mvar aa member v and mvar aa=mvar bb then
  (if ldeg aa=ldeg bb then<>else
    if ldeg aa #< ldeg bb then return t else return nil)else
 if(c:=mvar bb member v)then
  (if domainp aa or not(mvar aa member c)or mvar aa member cdr c then return t else
     if mvar aa member v then return nil);
 return hillebrandcompare1(red a,red b,v)end;

% The routine HILLEBRAND1: the main(recursive) routine.

symbolic procedure hillebrand1(g,fact);
% Input: 'g' : a (reduced ) lexicographical groebner basis,
% fact: a switch, which involves factorization (if set);
% output: a list of bases (a decomposition of 'g' in triangular bases),
% internal form.
% 16. Jan 2005: test for '(1)' added. HM.
if g='(1)then nil else
if hillebrandtriangular(vars!*,g,t)then hillebrandfactorizelast(g,fact)else
begin scalar a,aa,b,c,r,f,ff,fh,g2,g3,h,l,o;
% first part of the split.
 g3:=g;while cdr g3 do g3:=cdr g3;
 a:=hillebranddecompose(g,mvar car g3);
 c:=for each aa in cdr a collect lc aa ;
 r:=hillebrandgroebner hillebrandjoin(car a,c);
 f:=hillebrand1(r,fact); % Recursive call with reduced basis.
 aa:=hillebrandlast g;
 for each tt in f do
 <> ; % append(tt,{b}).ff
 f:=reversip ff;
% second part of the split.
 h:=car a; % H := { g_1 1, ... , g_n-1 c_n-1 }
 o:=length c;
 for k := 1:o do
 <>;
   h:=append(h,{nth(c,o)})>>;
 f:=for each ff in f collect sort(ff,function hillebrandcompare);
 return f end;

% Append a basis, (if that is not empty).

symbolic procedure hillebrandappend(a,b);
if null car b then a else append(a,b);

symbolic procedure hillebrandappend1(ff,tt,b);
% append(tt,{b}).ff.
<>;

% Detect, if 'g' is already triangular.

symbolic procedure hillebrandtriangular(a,g,m);
% 'a' is the list of variables, 'g' is the Groebner basis. If m='t',
% a basis with a mixed leading term is rejected. If m='nil', only the
% zero - dimensionality is tested (that each variable occurs once isolated).
begin scalar b,c;
 for each gg in g do
  if domainp lc gg or not(mvar lc gg member a)then b:=mvar gg.b else c:=t;
 if m and c then return nil;
 c:=t;for each gg in g do c and(c:=hillebrandtriangular1(a,gg,b));
 return c end;

symbolic procedure hillebrandtriangular1(a,g,b);
% Test, if all variables of 'g' occur in 'b'; return
% 't' then; return 'nil' if that is not the case. 'g'
% is a standard polynomial ; the 'variables' are the leading ones.
if domainp g or not(mvar g member a)then t else
 if not(mvar g member b)then nil else
  hillebrandtriangular1(a,lc g,b)and hillebrandtriangular1(a,red g,b);

symbolic procedure hillebrandfactorizelast(g,f);
% Factorize the last polynomial of 'g' if 'f' is non-nil.
if null f then {g} else
begin scalar a,b,c,d;
 aa: if cdr g then<>;if cdr g then go to aa;
 b:=fctrf car g;if domainp car b then b:=cdr b;
 c:=for each bb in b collect
  <>;
 return if null cdr c then c else
  for each cc in c collect sort(cc,function hillebrandcompare)end ;

% Decompose 'g' wrt'n'-th variable 'v'.

symbolic procedure hillebranddecompose(g,v);
begin scalar a,b,c,d;
 while g do
 <>;
 return reversip a.reversip cdr b end;

symbolic procedure hillebranddecompose1(p,v,vv,m);
% 'p' is a polynomial; look, if it is a product of the
% variable 'v'; return '1' if the leading factor is not a product of
% variable 'v', '2' if it is.
if domainp p or not(mvar p member vv)then m else
  hillebranddecompose1(lc p,v,vv,n)
 where n=if mvar p=v then 2 else if m #< 1 and mvar p member vv then 1 else m;

% Join 2 lists.

symbolic procedure hillebrandjoin(a,b);
% Join 'a' and 'b' if 'b' is not 'nil'.
if null b then a else append(a,b);

% Last  polynomial of a list.

symbolic procedure hillebrandlast g;
<>;

% Compute a Groebner basis .

symbolic procedure hillebrandgroebner g;
% Compute the Groebner basis of 'g'; return the Groebner basis as a sorted
% list of standard polynomials sorted descending.
begin scalar a,b,c,d;
 for each gg in g do
 <>;
 b:=groebnereval{'list.a,'list.vars!*}
  where dipvars!*=dipvars!*,vdpvars!*=vdpvars!*;
 c:=for each x in cdr b collect numr simp x;
 return sort(c,function hillebrandcompare)end;

% Compute the normal form of a polynomial.

symbolic procedure hillebrandnormalform(p,g);
% Compute 'p' modulo Groebner basis 'g'.
<>;

symbolic procedure hillebrandf2vdp p;
gsetsugar(a,nil)where a=f2vdp p;

% General .

symbolic procedure hillebrandmsg1 g;
if !*trgroesolv then
<>;
 writepri(" } with respect to ",nil);
 writepri(mkquote('list.vars!*),'last);
 writepri(" ",'only);>>;

symbolic procedure hillebrandmsg2 a;
if !*trgroesolv then
<>;
  writepri(" } ",'last)>>;
 writepri(" ",'only);>>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebidq.red0000644000175000017500000002743711526203062024614 0ustar  giovannigiovannimodule groebidq;

% Calculation of ideal quotient using a modified Buchberger algorithm .

% Authors: H . Melenk,H . M . Moeller,W . Neun,July 1988 .

switch groebfac,groebrm,trgroeb,trgroebs,trgroebr,groebstat;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


!*groebidqbasis:=t;       % Default : basis from idq .

% Variables for counting and numbering .

symbolic procedure groebidq2(p,f);
% Setup all global variables for the Buchberger algorithm;
% printing of statistics .
begin scalar groetime!*,tim1,spac,spac1,p1,
  pairsdone!*,!*gsugar;
 groetime!*:=time();
 vdponepol();% we construct dynamically
 hcount!*:=0;pcount!*:=0;mcount!*:=0;fcount!*:=0;bcount!*:=0;
 b4count!*:=0;hzerocount!*:=0;basecount!*:=0;
 if !*trgroeb then
 << prin2 "IDQ Calculation starting ";terprit 2 >>;
 spac:=gctime();p1:=  groebidq3(p,f);
 if !*trgroeb or !*trgroebr or !*groebstat then
 << spac1:=gctime()-spac;terpri();
  prin2t "statistics for IDQ calculation";
  prin2t "==============================";
  prin2 " total computing time(including gc): ";
  prin2(( tim1:=time())-groetime!*);prin2t "          milliseconds  ";
  prin2 "(time spent for garbage collection:  ";prin2 spac1;
  prin2t "          milliseconds)";terprit 1;
  prin2  "H-polynomials total: ";prin2t hcount!*;
  prin2  "H-polynomials zero : ";prin2t hzerocount!*;
  prin2  "Crit M hits: ";prin2t mcount!*;
  prin2  "Crit F hits: ";prin2t fcount!*;
  prin2  "Crit B hits: ";prin2t bcount!*;
  prin2  "Crit B4 hits: ";prin2t b4count!* >>;
 return if !*groebidqbasis then car groebner2(p1,nil)else p1 end;

symbolic procedure groebidq3(g0,fff);
begin scalar result,x,g,d,d1,d2,p,p1,s,h,g99,one,gi;
 gi:=g0;fff:=vdpsimpcont fff;
 vdpputprop(fff,' number,0);   % Assign number 0 .
 vdpputprop(fff,' cofact,a2vdp 1);% Assign cofactor 1 .
 x:=for each fj in g0 collect
 << fj:=vdpenumerate vdpsimpcont fj;
  vdpputprop(fj,' cofact,a2vdp 0);% Assign cofactor 0 .
  fj >>;
 g0:={ fff };
 for each fj in x do g0:=vdplsortin(fj,g0);
% ITERATION :
  while(d or g0)and not one do
  begin if g0 then
  <<          % Take next poly from input .
   h:=car g0;g0:=cdr g0;p:={ nil,h,h };>>
   else <<          % Take next poly from pairs .
    p:=car d;d:=delete(p,d);s:=idqspolynom(cadr p, caddr p);
   idqmess3(p,s);h:=idqsimpcont idqnormalform(s,g99,'tree);
   if vdpzero!? h then
   <<      !*trgroeb and groebmess4(p,d);
    x:=vdpgetprop(h,'cofact);
    if not vdpzero!? x then
     if vevzero!? vdpevlmon x then one:= t else
     << result:=idqtoresult(x,result);idqmess0 x >>;
   >> >>;
   if vdpzero!? h then goto bott;
   if vevzero!? vdpevlmon h then % Base 1 found .
   <<          idqmess4(p,h);
     result:=gi;d:=g0:=nil;goto bott >>;
     s:=nil;
                  % h polynomial is accepted now .
     h:=vdpenumerate h;
                        idqmess4(p,h);
                              % Construct new critical pairs .
     d1:=nil;
     for each f in g do
     << d1:=groebcplistsortin({ tt(f,h), f,h },d1);
      if tt(f,h)=vdpevlmon f then
      << g:=delete(f,g);!*trgroeb and groebmess2 f >> >>;
                  !*trgroeb and groebmess51 d1;
       d2:=nil;
       while d1 do
       << d1:=groebinvokecritf d1;
        p1:=car d1;d1:=cdr d1;
        if groebbuchcrit4t(cadr p1,caddr p1)
         then d2:=append(d2,list p1)
          else
          << x:=idqdirectelement(cadr p1,caddr p1);
           if not vdpzero!? x then
            if vevzero!? vdpevlmon x then one:= t else
            << idqmess1(x,cadr p1,caddr p1);
             result:=idqtoresult(x,result)>> >>;
       d1:=groebinvokecritm(p1,d1) >>;
             %   D:=groebInvokeCritB(h,D);
       d:=groebcplistmerge(d,d2);
       g:=h . g;
       g99:=groebstreeadd(h,g99);
                            !*trgroeb and groebmess8(g,d);
bott: end;%  ITERATION
                      % Now calculate groebner base from quotient base .
 if one then result:=list vdpfmon(a2vbc 1,vevzero());
 idqmess2 result;return result end;% MACROLOOP

symbolic procedure idqtoresult(x,r);
% X is a new element for the quotient r,
% is is reduced by r and then added .
<< x:=groebsimpcontnormalform groebnormalform(x,r,' sort);
 if vdpzero!? x then r else vdplsortin(x,r)>>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%    Reduction of polynomials .
%

symbolic procedure idqnormalform(f,g,type);
% General procedure for reduction of one polynomial from a set;
% f is a polynomial, G is a Set of polynomials either in
% a search tree or in a sorted list;
% type describes the ordering of the set G :
%    'TREE     G is a search tree
%    'SORT     G is a sorted list
%    'LIST     G is a list,but not sorted;
% f has to be reduced modulo G;
% version for idealQuotient : doing side effect calculations for
% the cofactors;only headterm reduction .
begin scalar c,vev,divisor,done,fold;
 fold:=f;
 while not vdpzero!? f and g do
 begin vev:=vdpevlmon f;c:=vdplbc f;
  if type='sort then
   while g and vevcompless!?(vev,vdpevlmon(car g)) do g:=cdr g;
  divisor:=groebsearchinlist(vev,g);
  if divisor then done:=t;% True action indicator .
  if divisor and !*trgroebs then
  << prin2 "//-";prin2 vdpnumber divisor >>;
  if divisor then
   if !*vdpinteger then f:=idqreduceonestepint(f,nil,c,vev,divisor)
    else f:=idqreduceonesteprat(f,nil,c,vev,divisor)
   else g:=nil end;
 return if done then f else fold % In order to preserve history .
 end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  Special reduction procedures .

symbolic procedure idqreduceonestepint(f,dummy,c,vev,g1);
% Reduction step for integer case :
% calculate f=a * f-b * g   a,b such that leading term vanishes
%                     (vev of lvbc g divides vev of lvbc f)
%
% and  calculate f1=a * f1;
% return value=f,secondvalue=f1 .
begin scalar vevlcm,a,b,cg,x,fcofa,gcofa;
 dummy:=nil;fcofa:=vdpgetprop(f,' cofact);
 gcofa:=vdpgetprop(g1,' cofact);vevlcm:=vevdif(vev,vdpevlmon g1);
 cg:=vdplbc g1;
            % Calculate coefficient factors .
 x:=vbcgcd(c,cg);a:=vbcquot(cg,x);
 b:=vbcquot(c,x);
 f:=vdpilcomb1(vdpred f,a,vevzero(),vdpred g1,vbcneg b,vevlcm);
  x:=vdpilcomb1(fcofa,a,vevzero(),gcofa,vbcneg b,vevlcm);
  vdpputprop(f,' cofact,x);return f end;

symbolic procedure idqreduceonesteprat(f,dummy,c,vev,g1);
% Reduction step for rational case :
% calculate f=f-g / vdplbc f .
begin scalar x,fcofa,gcofa,vev;
 dummy:=nil;fcofa:=vdpgetprop(f,' cofact);
 gcofa:=vdpgetprop(g1,' cofact);vev:=vevdif(vev,vdpevlmon g1);
 x:=vbcneg vbcquot(c,vdplbc g1);
 f:=vdpilcomb1(vdpred f,a2vbc 1,vevzero(),vdpred g1,x,vev);
 x:=vdpilcomb1(fcofa,a2vbc 1,vevzero(),gcofa,x,vev);
 vdpputprop(f,' cofact,x);return f end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Calculation of an S-polynomial and related things .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure idqspolynom(p1,p2);
begin scalar s,ep1,ep2,ep,rp1,rp2,db1,db2,x,
 cofac1,cofac2;
 if vdpzero!? p1 then return p1;if vdpzero!? p2 then return p2;
 cofac1:=vdpgetprop(p1,' cofact);
 cofac2:=vdpgetprop(p2,' cofact);
 ep1:=vdpevlmon p1;ep2:=vdpevlmon p2;ep:=vevlcm(ep1,ep2);
 rp1:=vdpred p1;rp2:=vdpred p2;db1:=vdplbc p1;db2:=vdplbc p2;
 if !*vdpinteger then
 << x:=vbcgcd(db1,db2);
  db1:=vbcquot(db1,x);db2:=vbcquot(db2,x)>>;
 ep1:=vevdif(ep,ep1);ep2:=vevdif(ep,ep2);db2:=vbcneg db2;
 s:=vdpilcomb1(rp2,db1,ep2,rp1,db2,ep1);
 x:=vdpilcomb1(cofac2,db1,ep2,cofac1,db2,ep1);
 vdpputprop(s,' cofact,x);return s end;

symbolic procedure idqdirectelement(p1,p2);
% The s-Polynomial is reducable to zero because of
% buchcrit 4 . So we can calculate the corresponing cofactor directly .
( if vdpzero!? c1 and vdpzero!? c2 then c1
   else vdpdif(vdpprod(p1,c2), vdpprod(p2,c1))
                     )where c1=vdpgetprop(p1,' cofact),
                                 c2=vdpgetprop(p2,' cofact);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   Normailsation with cofactors taken into account .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure idqsimpcont p;
 if !*vdpinteger then idqsimpconti p else idqsimpcontr p;

% Routines for integer coefficient case :
% Calculation of contents and dividing all coefficients by it .

symbolic procedure idqsimpconti p;
% Calculate the contents of p and divide all coefficients by it .
begin scalar res,num,cofac;
 if vdpzero!? p then return p;
 cofac:=vdpgetprop(p,' cofact);num:=car vdpcontenti p;
 if not vdpzero!? cofac then num:=vbcgcd(num,car vdpcontenti cofac);
 if not vbcplus!? num then num:=vbcneg num;
 if not vbcplus!? vdplbc p then num:=vbcneg num;
 if vbcone!? num then return p;
 res:=vdpreduceconti(p,num,nil);
 if not vdpzero!? cofac then cofac:=vdpreduceconti(cofac,num,nil);
 res:=vdpputprop(res,' cofact,cofac);
 return res end;

% Routines for rational coefficient case :
% calculation of contents and dividing all coefficients by it .

symbolic procedure idqsimpcontr p;
% Calculate the contents of p and divide all coefficients by it .
begin scalar res,cofac;
 cofac:=vdpgetprop(p,' cofact);
 if vdpzero!? p then return p;
 if vbcone!? vdplbc p then return p;
 res:=vdpreduceconti(p,vdplbc p,nil);
 if not vdpzero!? cofac then
  cofac:=vdpreduceconti(cofac,vdplbc p,nil);
 res:=vdpputprop(res,' cofact,cofac);return res end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Trace messages .
%

symbolic procedure idqmess0 x;
if !*trgroeb then
 << prin2t "adding member to intermediate quotient basis:";
  vdpprint x;terpri() >>;

symbolic procedure idqmess1(x,p1,p2);
if !*trgroeb then
 << prin2 "pair(";prin2 vdpnumber p1;prin2 ",";
  prin2 vdpnumber p2;
  prin2t ") adding member to intermediate quotient basis:";
  vdpprint x;terpri() >>;

symbolic procedure idqmess2 b;
if !*trgroeb then
 << prin2t "---------------------------------------------------";
  prin2 "the full intermediate base of the ideal quotient is:";
  for each x in b do vdpprin3t x;
  prin2t "---------------------------------------------------";
  terpri() >>;

symbolic procedure idqmess3(p,s);
if !*trgroebs then
 << prin2 "S-polynomial from ";groebpairprint p;vdpprint s;
  prin2t "with cofactor";vdpprint vdpgetprop(s,' cofact);
  groetimeprint();terprit 3 >>;

symbolic procedure idqmess4(p,h);
if car p then                  % Print for true h-Polys .
 << hcount!*:=hcount!* #+ 1;
  if !*trgroeb then << terpri();prin2  "H-polynomial ";
  prin2 pcount!*;
  groebmessff(" from pair(",cadr p,nil);
  groebmessff(",",caddr p,")");vdpprint h;
  prin2t "with cofactor";vdpprint vdpgetprop(h,' cofact);
  groetimeprint() >> >>
 else
  if !*trgroeb then <<          % Print for input polys .
   prin2t "candidate from input:";
   vdpprint h;
   groetimeprint() >>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebner.red0000644000175000017500000001115511526203062024611 0ustar  giovannigiovannimodule groebner;

% Author: Herbert Melenk
% in cooperation with Winfried Neun, H. Michael Moeller.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% module structure:
%     GROEBNER  package + GROEBNR2 package
%  polynomial arithmetic:
%     VDP2DIP package included in DIPOLY package

fluid '(asymplis!* basecount!* bcount!* bczerodivl!* b4count!* current!-modulus
 currentvdpmodule!* denominators!* depl!* dipsortmode!* dipvars!* dmode!*
 factorlevel!* factortime!* factorlvevel!* fcount!* fourthvalue!* glexdomain!*
 global!-dipvars!* gmodule gmodule!* groebabort!* groebactualg!*
 groebactualg99!* groebdomain!* groebfabort!* groebmodular!* groebrestriction!*
 groebroots!* groecontcount!* groefeedback!* groesfactors!* groesoldb!*
 groesoldmode!* groesolvelevel!* groetags!* groetime!* fourthvalue!*
 hcount!* hzerocount!* intvdpvars!* mcount!*
 pcount!* pairsdone!* powlis!* probcount!* secondvalue!* thirdvalue!*
 variables!* vars!* vbccurrentmode!* vdplastvar!* vdpone!* vdpsortmode!*
 vdpvars!* vbcmodule!* vdpsortmode!* vdpsortextension!* vdpvars!*
 !*arbvars !*complex !*compxroots !*convert !*divisor !*exp !*ezgcd
 !*factor !*fullreduction !*gcd !*gltbasis !*greduce !*gsugar !*grmod!*
 !*groebcomplex !*groebdivide !*groebfac !*groebfullreduction !*groebheufact
 !*groebidqbasis !*groebnumval !*groebopt !*groebprot !*groebprereduce
 !*groebreduce !*groebsubs !*groebprot
 !*groebrm !*groebstat !*groebweak !*groelterms !*groesolgarbage !*groesolrecurs
 !*groebrm !*groebstat !*gsugar !*gtraverso!-sloppy !*msg !*precise !*trgroeb
 !*trgroebr !*trgroebr1 !*trgroebs !*trgroebsi !*trgroeb1 !*varopt !*vdpinteger
 !*vdpmodular
 !*notestparameters
);

global '(assumptions gltb glterms groebmonfac groebprotfile groebrestriction
 groebresmax gvarslast largest!-small!-modulus requirements !*match !*trgroesolv);

currentvdpmodule!*:='vdp2dip;

create!-package('(groebner grinterf grinter2 buchbg groebcri groesolv groebopt
 groebsea groebsor groebspa groebfac groebidq kredelw traverso hille),
 '(contrib groebner));

put('groebner,'version,3.1);

% Other packages needed.

load!-package ' dipoly;

if(null v or v < 4.1)where v=get('dipoly,'version)
  then rederr {"wrong dipoly module",
                "(get and compile dipoly, before you compile groebner)"};

smacro procedure tt(s1,s2);
  % Lcm of leading terms of s1 and s2 .
vevlcm(vdpevlmon s1,vdpevlmon s2);

smacro procedure vdpnumber f;vdpgetprop(f,'number);

imports a2vdp,a2vbc,dependsl,domainp,eqexpr,f2vdp,fctrf,korder,lc,lpow,
 multroot0,
 makearbcomplex,mvar,numr,precision,prepcadr,prepf,prepsq,
 reorder,rerror,reval,
 setkorder, simp,solveeval,torder,
 vdp2a,vdp2f,vdpfmon,vdpappendmon,vdpappendvdp,vdplbc,vdpred,vdplastmon,
 vdpzero!?,vdpredzero!?,vdpone!?,vevzero!?, vbcplus!?,vbcone!?,vbcnumberp!?,vevdivides!?,
 vdpequal,vdpmember,vdpsum,vdpdif,vdpprod,vdpdivmon,vdpcancelvev,
 vdplcomb1,vdpcontent, vbcsum,vbcdif,vbcneg,vbcprod,vbcquot,vbcinv,vbcgcd,vbcabs,vbcone!?,
 vdpputprop,vdpgetprop,vdplsort,vdplsortin,vdpprint,
 vdpprin3t,vdpcondense,vdplcm,vdprectoint,vdpsimpcont,vdpvbcprod,vdpcancelmvev,vdpprin2,
 vdplength,vdpilcomb1,vdpinit,vdpinit2,vdpcleanup,
 vevcompless!?,vevdif,vevequal,vevsum,vevnth,vevtdeg,vevweightedcomp2,vevzero,
 writepri,
 !*eqn2a;

exports groebnereval,groesolveeval,groepostsolveeval,idquotienteval,
 gdimensioneval,glexconvert,greduce,preduce,preduceeval,groebnert,dd_groebner,
 hilbertpolynomial,gsort,gsplit,gspoly,gzerodim!?;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groeweak.red0000644000175000017500000001335311526203062024614 0ustar  giovannigiovannimodule groeweak;% Weak test for f ~ 0 modulo g .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


switch groebweak;

symbolic procedure groebweakzerotest(f,g,type);
% Test f == 0 modulo g with ON MODULAR .
begin scalar f1,c,vev,divisor,oldmode,a;
 if vdpzero!? f then return f;
 if current!-modulus = 1 then setmod list 2097143;
 oldmode:=setdmode(' modular,t);
 f:=groebvdp2mod f;
 f1:=vdpzero();a:=vbcfi 1;
 while not vdpzero!? f and vdpzero!? f1 do
 begin
  vev:=vdpevlmon f;c:=vdpLbc f;
  if type = 'sort then while g and vevcompless!?(vev,vdpevlmon(car g))
   do g:=cdr g;
  divisor:=groebsearchinlist(vev,g);
  if divisor and !*trgroebs then
  <>;
  if divisor then
   if vdplength divisor = 1 then f:=vdpcancelmvev(f,vdpevlmon divisor)
    else <>
   else f1:=f end;
 if not vdpzero!? f1 and !*trgroebs then
 <>;
 setdmode(' modular,nil);
 if oldmode then setdmode(get(oldmode,' dname), t);
  return vdpzero!? f1 end;

symbolic procedure groebweaktestbranch!=1(poly,g,d);
% Test gb(g)== { 1 } in modular style .
 groebweakbasistest({ poly },g,d);

symbolic procedure groebweakbasistest(g0,g,d);
begin scalar oldmode,d,d1,d2,p,p1,s,h;
 scalar !*vdpinteger;  % Switch to field type calclulation .
 return nil;
 if not !*groebfac then return nil;
 if current!-modulus= 1 then setmod { 2097143 };
 if !*trgroeb then
  prin2t "---------------- modular test of branch ------";
 oldmode:=setdmode(' modular,t);
 g0:=for each p in g0 collect groebvdp2mod p;
 g:=for each p in g collect groebvdp2mod p;
 d:=for each p in d collect { car p,
             groebvdp2mod cadr p,groebvdp2mod caddr p };
 while d or g0 do
 begin if g0 then
 <<        % Take next poly from input .
  h:=car g0;g0:=cdr g0;p:={ nil,h,h }>>
  else
 <<        % Take next poly from pairs .
  p:=car d;d:=delete(p,d);
  s:=groebspolynom(cadr p,caddr p);
  h:=groebsimpcontnormalform groebnormalform(s,g,' sort);
  if vdpzero!? h then !*trgroeb and groebmess4(p,d)>>;
  if vdpzero!? h then
  <>;
  if vevzero!? vdpevlmon h then % Base 1 found .
  <<       !*trgroeb and groebmess5(p,h);goto stop>>;
  s:=nil;
  h:=vdpenumerate h;!*trgroeb and groebmess5(p,h);
                              % Construct new critical pairs .
  d1:=nil;
  for each f in g do
  <>>>;
          !*trgroeb and groebmess51 d1;
  d2:=nil;
  while d1 do
  <>;
  d:=groebinvokecritb(h,d);d:=groebcplistmerge(d,d2);g:=h . g;
  go to bott;
stop: d:=g:=g0:=nil;
bott: end;
 if !*trgroeb and null g then
          prin2t "**** modular test detects empty branch!";
 if !*trgroeb then
          prin2t "------ end of  modular test of branch ------";
 setdmode(' modular,nil);
 if oldmode then setdmode(get(oldmode,' dname), t);
  return  null g end;

fluid '(!*localtest);

symbolic procedure groebfasttest(g0,g,d,g99);
 if !*localtest then
 <>
  else if !*groebweak and g and vdpunivariate!? car g
   then groebweakbasistest(g0,g,d);

symbolic procedure groebvdp2mod f;
% Convert a vdp in modular form;in case of headterm loss,nil is returned .
begin scalar u,c,mf;
 u:=vdpgetprop(f,' modimage);
 if u then return if u = ' nasty then nil else u;
 mf:=vdpresimp f;
 if !*gsugar then vdpputprop(mf,' sugar,vdpgetprop(f,' sugar));
 c:=errorset!*( { ' vbcinv,mkquote vdplbc mf },nil);
 if not pairp c then
 <>;
 u:=vdpvbcprod(mf,car c);
 vdpputprop(u,' number,vdpgetprop(f,' number));
 vdpputprop(f,' modimage,u);
 if !*gsugar then vdpputprop(u,' sugar,vdpgetprop(f,' sugar));
 return u end;


symbolic procedure groebmodeval(f,break);
% Evaluate LISP form r with REDUCE modular domain .
begin scalar oldmode,a,!*vdpinteger,groebmodular!*;
 groebmodular!*:=t;break:=nil;
 if current!-modulus = 1 then setmod list 2097143;
 oldmode:=setdmode(' modular,t);
 a:=errorset!*(f,t);
 setdmode(' modular,nil);
 if oldmode then setdmode(get(oldmode,' dname), t);
 return if atom a then nil else car a end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebner.tst0000644000175000017500000002023511526203062024650 0ustar  giovannigiovanni% Examples of use of Groebner code.

% In the Examples 1 - 3 the polynomial ring for the ideal operations
% (variable sequence, term order mode) is defined globally in advance.

% Example 1, Linz 85.

torder ({q1,q2,q3,q4,q5,q6},lex)$

groebner {q1,
          q2**2 + q3**2 + q4**2,
          q4*q3*q2,
          q3**2*q2**2 + q4**2*q2**2 + q4**2*q3**2,
          q6**2 + 1/3*q5**2,
          q6**3 - q5**2*q6,
          2*q2**2*q6 - q3**2*q6 - q4**2*q6 + q3**2*q5 - q4**2*q5,
          2*q2**2*q6**2 - q3**2*q6**2 - q4**2*q6**2 - 2*q3**2*q5*q6
          + 2*q4**2*q5*q6 - 2/3*q2**2*q5**2 + 1/3*q3**2*q5**2
          + 1/3*q4**2*q5**2,
          - q3**2*q2**2*q6 - q4**2*q2**2*q6 + 2*q4**2*q3**2*q6 -
          q3**2*q2**2*q5 + q4**2*q2**2*q5,
          - q3**2*q2**2*q6**2 - q4**2*q2**2*q6**2 + 2*q4**2*q3**2*q6**2
          + 2*q3**2*q2**2*q5*q6 - 2*q4**2*q2**2*q5*q6 + 1/3*q3**2*q2**2
          *q5**2 + 1/3*q4**2*q2**2*q5**2 - 2/3*q4**2*q3**2*q5**2,
          - 3*q3**2*q2**4*q5*q6**2 + 3*q4**2*q2**4*q5*q6**2
          + 3*q3**4*q2**2*q5*q6**2 - 3*q4**4*q2**2*q5*q6**2
          - 3*q4**2*q3**4*q5*q6**2 + 3*q4**4*q3**2*q5*q6**2
          + 1/3*q3**2*q2**4*q5**3 - 1/3*q4**2*q2**4*q5**3
          - 1/3*q3**4*q2**2*q5**3 + 1/3*q4**4*q2**2*q5**3 + 1/3*q4**2
            *q3**4*q5**3 - 1/3*q4**4*q3**2*q5**3};


% Example 2. (Little) Trinks problem with 7 polynomials in 6 variables.

trinkspolys:={45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          - 9*w + 15*p*t + 20*z*s,
          w*p + 2*z*t - 11*b**3,
          99*w - 11*s*b + 3*b**2,
          b**2 + 33/50*b + 2673/10000}$

trinksvars :=  {w,p,z,t,s,b}$
torder(trinksvars,lex)$
switch varopt; off varopt;
groebner trinkspolys;

groesolve ws;
 

% Example 3. Hairer, Runge-Kutta 1, 6 polynomials 8 variables.
 
torder({c2,c3,b3,b2,b1,a21,a32,a31},lex);
groebnerf{c2 - a21,
          c3 - a31 - a32,
          b1 + b2 + b3 - 1,
          b2*c2 + b3*c3 - 1/2,
          b2*c2**2 + b3*c3**2 - 1/3,
          b3*a32*c2 - 1/6};
 
        
% The examples 4 and 5 use automatic variable extraction.

% Example 4.
 
torder gradlex$
 
g4:= 
groebner{b + e + f - 1,
         c + d + 2*e - 3,
         b + d + 2*f - 1,
         a - b - c - d - e - f,
         d*e*a**2 - 1569/31250*b*c**3,
         c*f - 587/15625*b*d};
hilbertpolynomial g4;
glexconvert(g4,gvarslast,newvars={e},maxdeg=8);

% Example 5.

off varopt;
torder({u0,u2,u3,u1},lex)$
groesolve({u0**2 - u0 + 2*u1**2 + 2*u2**2 + 2*u3**2,
          2*u0*u1 + 2*u1*u2 + 2*u2*u3 - u1,
          2*u0*u2 + u1**2 + 2*u1*u3 - u2,
          u0 + 2*u1 + 2*u2 + 2*u3 - 1},
         {u0,u2,u3,u1});
 
% Example 6. (Big) Trinks problem with 6 polynomials in 6 variables.
 
torder(trinksvars,lex)$
btbas:=
 groebner{45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          -9*w + 15*p*t + 20*z*s,
           w*p + 2*z*t - 11*b**3,
          99*w - 11*b*s + 3*b**2};
 
% The above system has dimension zero. Therefore its Hilbert polynomial
% is a constant which is the number of zero points (including complex
% zeros and multipliticities);

hilbertpolynomial ws;

% Example of Groebner with numerical postprocessing.

on rounded;off varopt;
groesolve(trinkspolys,trinksvars);
off rounded;

% Additional groebner operators.

% Reduce one polynomial wrt the basis of big Trinks. The result 0
% is a proof for the ideal membership of the polynomial.

torder(trinksvars,lex)$
preduce(45*p + 35*s - 165*b - 36,btbas);
 
% The following examples show how to work with the distributive
% form of polynomials.

torder({u0,u1,u2,u3},gradlex)$
gsplit(2*u0*u2 + u1**2 + 2*u1*u3 - u2,{u0,u1,u2,u3});

torder(trinksvars,lex)$
gsort trinkspolys;
 
gspoly(first trinkspolys,second trinkspolys);

gvars trinkspolys;

% Tagged basis and reduction trace. A tagged basis is a basis where
% each polynomial is equated to a linear combination of the input
% set. A tagged reduction shows how the result is computed by using
% the basis polynomials.

% First example for tagged polynomials: show how a polynomial is
% represented as linear combination of the basis polynomials.

  % First I set up an environment for the computation.

torder(trinksvars,lex)$

  % Then I compute an ordinary Groebner basis.

bas:=groebner trinkspolys$

  % Next I assign a tag to each basis polynomial.

taggedbas:=for i:=1:length bas collect mkid(p,i)=part(bas,i);

  % And finally I reduce a (tagged) polynomial wrt the tagged basis.

preducet(new=w*p + 2*z*t - 11*b**3,taggedbas);

% Second example for tagged polynomials: representing a Groebner basis 
% as a combination of the input polynomials, here in a simple geometric
% problem.

torder({x,y},lex)$
groebnert {circle=x**2 + y**2 - r**2,line=a*x + b*y};

% In the third example I enter two polynomials that have no common zero.
% Consequently the basis is {1}. The tagged computation gives me a proof
% for the inconsistency of the system which is independent of the
% Groebner formalism.

groebnert {circle1=x**2 + y**2 - 10,circle2=x**2 + y**2 - 2};

% Solve a special elimination task by using a blockwise elimination
% order defined by a matrix.  The equation set goes back to A.M.H.
% Levelt (Nijmegen).  The question is whether there is a member in the
% ideal which depends only on two variables.  Here we select x4 and y1.
% The existence of such a polynomial proves that the system has exactly
% one degree of freedom.

% The first two rows of the term order matrix define the groupwise
% elimination. The remaining lines define a secondary local
% lexicographical behavior which is needed to construct an admissible
% ordering.

f1:=y1^2 + z1^2 -1;
f2:=x2^2 + y2^2 + z2^2 -1;
f3:=x3^2 + y3^2 + z3^2 -1;
f4:=x4^2 + z4^2 -1;
f5:=y1*y2 + z1*z2;
f6:=x2*x3 + y2*y3 + z2*z3;
f7:=x3*x4 + z3*z4;
f8:=x2 + x3 + x4 + 1;
f9:=y1 + y2 + y3 - 1;
f10:=z1 + z2 + z3 + z4;

eqns:={f1,f2,f3,f4,f5,f6,f7,f8,f9,f10}$
vars:={x2,x3,y2,y3,z1,z2,z3,z4,x4,y1}$

torder(vars,matrix,
mat((1,1,1,1,1,1,1,1,0,0),
    (0,0,0,0,0,0,0,0,1,1),
    (1,0,0,0,0,0,0,0,0,0),
    (0,1,0,0,0,0,0,0,0,0),
    (0,0,1,0,0,0,0,0,0,0),
    (0,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0),
    (0,0,0,0,0,1,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,0),
    (0,0,0,0,0,0,0,0,1,0)));

first reverse groebner(eqns,vars);

% For a faster execution we convert the matrix into a
% proper machine code routine.

on comp;
torder_compile(levelt,mat(
  (1,1,1,1,1,1,1,1,0,0),
  (0,0,0,0,0,0,0,0,1,1),
  (1,0,0,0,0,0,0,0,0,0),
  (0,1,0,0,0,0,0,0,0,0),
  (0,0,1,0,0,0,0,0,0,0),
  (0,0,0,1,0,0,0,0,0,0),
  (0,0,0,0,1,0,0,0,0,0),
  (0,0,0,0,0,1,0,0,0,0),
  (0,0,0,0,0,0,1,0,0,0),
  (0,0,0,0,0,0,0,0,1,0)));
torder(vars,levelt)$
first reverse groebner(eqns,vars);

% For a homogeneous polynomial set we compute a graded Groebner
% basis with grade limits. We use the graded term order with lex
% as following order. As the grade vector has no zeros, this ordering
% is functionally equivalent to a weighted ordering.

torder({x,y,z},graded,{1,1,2},lex);
dd_groebner(0,10,{x^10*y + y*z^5, x*y^12 + y*z^6});  
dd_groebner(0,50,{x^10*y + y*z^5, x*y^12 + y*z^6});  
dd_groebner(0,infinity,{x^10*y + y*z^5, x*y^12 + y*z^6});  

% Test groebner_walk
trinkspolys := {45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          - 9*w + 15*p*t + 20*z*s,
          w*p + 2*z*t - 11*b**3,
          99*w - 11*s*b + 3*b**2,
          b**2 + 33/50*b + 2673/10000}$
trinksvars :=  {w,p,z,t,s,b}$
torder(trinksvars,gradlex)$
gg:=groebner trinkspolys$
g:=groebner_walk gg$

on div$
g;

on varopt;
g1:=solve({first g},{b});
g0:=sub({first g1},g);
solve({ second g0},{w});
solve({third g0},{p});
solve({part(g0,4)},{z});
solve({part(g0,5)},{t});
solve({part(g0,6)},{s});

g0:=sub({second g1},g);
solve({second g0},{w});
solve({third g0},{p});
solve({part(g0,4)},{z});
solve({part(g0,5)},{t});
solve({part(g0,6)},{s});

% Example after the book "David Cox, John Little, Donal O'Shea:
% "Ideals, Varieties and Algorithms", chapter 2, paragraph 8, example 3.
% This example was given by Shigetoshi Katsura (Japan).
 
off groebopt;torder({x,y,z,l},lex);
g:=groebner{3*x^2+2*y*z-2*x*l,2*x*z-2*y*l,2*x*y-2*z-2*z*l,x^2+y^2+z^2-1}$
gdimension g;
gindependent_sets g;

clear g, gg, trinkspolys, trinksvars$

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/hggroeb.red0000644000175000017500000000772611526203062024434 0ustar  giovannigiovannimodule hggroeb; % Homogeneous Graded Grobner bases.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%    Buchberger algorithm for homogeneous graded polynomial
%    systems. d1 and d2 are positive integers (d2 may be
%    infinity). Compute the basis for the sectin [d1,d2].
%
%    see Becker-Weispfenning, Chapter 10.
%
%    A local redefinition of the function groebspolynom is
%    used to exclude pairs which do not fit into the grade interval.

fluid '(dd!-1!* dd!-2!*);

% imported fluids.

symbolic procedure dd_groebner!* q;
  (begin scalar vars,w,np,oldorder,!*redefmsg;
         integer pcount!*;
      w := for each j in groerevlist u
              collect if eqexpr j then !*eqn2a j else j;
      vars := groebnervars(w,nil);
      if null vars then rerror(groebner,4,"empty system groebner");
      groedomainmode();
      oldorder := vdpinit vars;
                  % cancel common denominators
      w := for each j in w collect f2vdp numr simp j;
      dd_homog!-check w;
      if not !*vdpInteger then
      <>;
      >>;
      if !*groebprot then <>;
      if tst then typerr(vdp2a q,"homogeneous polynomial");
    >> end ;

copyd('true!-groebspolynom,'groebspolynom);

symbolic procedure dd!-groebspolynom(p1,p2);
  (if (dd!-1!* <= d and (dd!-2!*='infinity or d <= dd!-2!*)) then
       true!-groebspolynom(p1,p2) else a2vdp 0)
   where d=ev!-gamma vevlcm(vdpevlmon p1, vdpevlmon p2);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/kredelw.red0000644000175000017500000000705611526203062024450 0ustar  giovannigiovannimodule kredelw;% Kredel Weispfenning algorithm .

% Author: H . Melenk(ZIB Berlin).

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure gdimension_eval u;
begin integer n,m;
 for each s in cdr gindependent_seteval u
  do if(m:=length cdr s) > n then n:=m;
 return n end;

put('gdimension,'psopfn,'gdimension_eval);

symbolic procedure gindependent_seteval pars;
% Independent set algorithm(Kredel/Weispfenning).
% Parameters:
%     1      Groebner basis
%     2      optional: list of variables.
begin scalar a,u,v,vars,w,oldorder,!*factor,!*exp,!*gsugar,!*groebopt;!*exp:=t;
 u:=reval car pars;
 v:=if cdr pars then reval cadr pars else nil;
 w:=for each j in groerevlist u collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebnr2,3,"empty list");
 a:=if global!-dipvars!* and cdr global!-dipvars!* then cdr global!-dipvars!*
  else gvarlis w;
 vars:=if null v then for each j in a collect !*a2k j else groerevlist v;
 if not vars then return'(list);
 oldorder:=vdpinit vars;
 w:=for each j in w collect vdpevlmon a2vdp j;
 vars:=for each y in vars collect y.vdpevlmon a2vdp y;
 w:=groebkwprec(vars,nil,w,nil);
 return 'list.for each s in w collect
         'list.reversip for each x in s collect car x end;

put('gindependent_sets,'psopfn,'gindependent_seteval);

symbolic procedure groebkwprec(vars,s,lt,m);
% Recursive Kredel Weispfennig algorithm.
% vars: unprocessed variables,
% s:    current subset of s,
% lt:   leading term basis,
% m:    collection of independent sets so far.
% Returns : updated m .
begin scalar x,s1,bool;
 s1:=for each y in s collect cdr y;
 while vars do
 <>;
 bool:=t;
 for each y in m do % bool and not subsetp(s,y);
 bool:=bool and not(length s=length intersection(s,y));
 return if bool then s.m else m end;

symbolic procedure groebkwprec1(s,lt);
% t if intersection of T(s) and lt is empty.
if null lt then t else groebkwprec2(s,car lt)and groebkwprec1(s,cdr lt);

symbolic procedure groebkwprec2(s,mon);
% t if monomial not in T(s).
<>;

symbolic procedure vevcan0(m,mon);
% Divide multiples of m1 out of mon.
if vevzero!? m then mon else
 if vevzero!? mon then nil else
 (if car m neq 0 then 0 else car mon).vevcan0(cdr m,cdr mon);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/kuechl.red0000644000175000017500000003127611526203062024267 0ustar  giovannigiovannimodule kuechl;% Walking faster,B . Amrhrein,O . Gloor,W . Kuechlin
% in: Calmet,Limongelli(Eds .)Design and
% Implementation of Symbolic Computation Systems,Sept.1996

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version 3 with a rational local solution(after letters from H.M.Moeller).
% Version 4 with keeping the polynomials as DIPs converting only
% their order mode.

switch trgroeb;

put('groebner_walk,' psopfn,' groeb!-walk);

symbolic procedure groeb!-walk u;
begin if !*groebopt then
  rerror(groebner,31,"don't call 'groebner_walk' with 'on groebopt'");
  if null dipvars!* then rerror(groebner,30,"'torder' must be called before");
  groetime!*:=time();
  !*gsugar:=t;!*groebrm:=nil;u:=car groeparams(u,1,1);
  groebnervars(u,nil);u:=groeb!-list(u,'simp);
  groedomainmode();u:=groeb!-w2 u;
  return'list.groeb!-collect(u,'mk!*sq)end;

symbolic procedure groeb!-list(u,fcn);
% Execute the function ' fcn ' for the elements of the algebriac
% list 'u'.
<>;

symbolic procedure groeb!-collect(l,f);
% Collect the elements of function 'f' applied to the elements of
% the symbolic list 'l'. If 'f' is a number,map 'l' only.
for each x in l collect if numberp f then f else apply1(f,x);

symbolic procedure groeb!-w2 g;
% This is(essentially)the routine Groebner_Walk.
% G is a list of standard quotients,
% a Groebner basis gradlex or based on a vector like [1 1 1 ...].
% The result is the Groebner basis(standard quotients)with the
% final term order(lex)as its main order.
begin scalar iwv,owv,omega,gomega,gomegaplus,tt,tto,pc;
 scalar first,mx,imx,mmx,immx,nn,ll,prim;
 scalar !*vdpinteger,!*groebdivide;
 !*vdpinteger: nil;        % switch on division mode
 !*groebdivide:=t;
 first:=t;pcount!*:=0;mmx:=!*i2rn 1;immx:=mmx;
 iwv:=groeb!-collect(dipvars!*,1);
 omega:=iwv;              % Input order vector.
 owv:=1 .groeb!-collect(cdr dipvars!*,0);
 tto:=owv;                % Output order vector .
 groeb!-w9('weighted,omega);% Install omega as weighted order.
 g:=groeb!-collect(g,'sq2vdp);
 pc:=pcount!*;
 gbtest g;                  % Test the Groebner property.
 nn:=length dipvars!*;
 ll:=rninv!: !*i2rn nn;   % Inverse of the length.
 prim:=t;                 % Preset.
loop:groeb!-w9(' weighted,omega);
 mx:=groeb!-w6!-4 groeb!-collect(omega,1);
                              % Compute the maximum of \omega.
        if !*trgroeb then groebmess34 cadr mx;
 imx:=rninv!: mx;
 g:=if first then groeb!-collect(g,'vdpsimpcont) else groeb!-w10 g;
        if !*trgroeb then groebmess29 omega;
 gomega:=if first or not prim then g
         else groeb!-w3(g,omega); % G_\omega = initials(G_\omega);
 pcount!*:=pc;
        if !*trgroeb and not first then groebmess32 gomega;
 gomegaplus:=if first then{gomega}else gtraverso(gomega,nil,nil);
 if cdr gomegaplus then rerror(groebner,31,
                "groebner_walk,cdr of 'groebner' must be nil")
  else gomegaplus:=car gomegaplus;
        if !*trgroeb and not first then groebmess30 gomegaplus;
 if not first and prim
  then g:=groeb!-w4(gomegaplus,gomega,g)
  else if not prim then g:=gomega;
      % G=lift(G_{%omega}{plus},<{plus},G_{%omega),G,<)
 if not first then g:=for each x in g collect gsetsugar(x,nil);
        if !*trgroeb and not first then groebmess31 g;
 if groeb!-w5(omega,imx,tto,immx)then go to ret;
       % Stop if tt has been 1 once.
 if not first and rnonep!: tt then go to ret;% Secodary abort crit.
 tt:=groeb!-w6!-6(g,tto,immx,omega,imx,ll);% Determine_border .
        if !*trgroeb then groebmess36 tt;
 if null tt then go to ret;
        % criterion: take primary only if tt neq 1
 prim:=not rnonep!: tt;
        if !*trgroeb then groebmess37 prim;
          %\omega =(1-t)*\omega+t*tau
 omega:=groeb!-w7(tt,omega,imx,tto,immx);
        if !*trgroeb then groebmess35 omega;
 first:=nil;go to loop;
ret:
        if !*trgroeb then groebmess33 g;
 g:=groeb!-collect(g,'vdpsimpcont);
 g:=groeb!-collect(g,'vdp2sq);
 return g end;

symbolic procedure groeb!-w3(g,omega);
% Extract head terms of g corresponding to omega.
begin scalar x,y,gg,ff;
 gg:=for each f in g collect<>;
  ff>>;return gg end;

symbolic procedure groeb!-w4(gb,gomega,g);
% gb     Groebner basis of gomega,
% gomega head term system g_\omega of g,
% g      full(original)system of polynomials.
begin scalar x;
 for each y in gb do gsetsugar(y,nil);
 x:=for each y in gomega collect groeb!-w8(y,gb);
 x:=for each z in x collect groeb!-w4!-1(z,g);return x end;

symbolic procedure groeb!-w4!-1(pl,fs);
% pl is a list of polynomials corresponding to the full system fs.
% Compute the sum of pl*fs. Result is the sum.
begin scalar z;z:=vdpzero();
 gsetsugar(z,0);
 for each p in pair(pl,fs)do
  if car p then z:=vdpsum(z,vdpprod(car p,cdr p));
 z:=vdpsimpcont z;return z end;

symbolic procedure groeb!-w5(ev1,x1,ev2,x2);
% ev1=ev2 equality test.
 groeb!-w5!-1(x1,ev1,x2,ev2);

symbolic procedure groeb!-w5!-1(x1,ev1,x2,ev2);
( null ev1 and null ev2)or
(rntimes!:(!*i2rn car ev1,x1)=rntimes!:(!*i2rn car ev2,x2)
         and groeb!-w5!-1(x1,cdr ev1,x2,cdr ev2));

symbolic procedure groeb!-w6!-4 omega;
% Compute the weighted length of \omega.
 groeb!-w6!-5(omega,vdpsortextension!*,0);

symbolic procedure groeb!-w6!-5(omega,v,m);
 if null omega then !*i2rn m
  else if 0=car omega then groeb!-w6!-5(cdr omega,cdr v,m)
    else if 1 = car omega
     then groeb!-w6!-5(cdr omega,cdr v,m #+ car v)
      else groeb!-w6!-5(cdr omega,cdr v,m #+ car omega #* car v);

symbolic procedure groeb!-w6!-6(gb,tt,ifactt,tp,ifactp,ll);
% Compute the weight border(minimum over all polynomials of gb).
begin scalar mn,x,zero,one;
 zero:=!*i2rn 0;one:=!*i2rn 1;
 while not null gb do
 <>;return mn end;

symbolic procedure groeb!-w6!-7(pol,tt,ifactt,tp,ifactp,zero,one,ll);
% Compute the minimal weight for one polynomial;the idea is,
% that the polynomial has a degree greater than 0.
begin scalar a,b,ev1,ev2,x,y,z,mn;
 ev1:=vdpevlmon pol;
 a:=evweightedcomp2(0,ev1,vdpsortextension!*);
 y:=groeb!-w6!-8(ev1,tt,ifactt,tp,ifactp,zero,zero,one,ll);
 y:=(rnminus!: car y).(rnminus!: cdr y);
 pol:=vdpred pol;
 while not(vdpzero!? pol)do
 <>>>>>;return mn end;

symbolic procedure groeb!-w6!-8(ev,tt,ifactt,tp,ifactp,sum1,sum2,m,dm);
begin scalar x,y,z;
 if ev then<>;
 return
  if null ev then sum1.sum2 else
   groeb!-w6!-8(cdr ev,cdr tt,ifactt,cdr tp,ifactp,
    rnplus!:(sum1,rntimes!:(y,x)),
    rnplus!:(sum2,rntimes!:(rndifference!:(z,y),x)),
    rndifference!:(m,dm),
    dm)end;

symbolic procedure groeb!-w6!-9(ev,tt,ifactt,tp,ifactp,y1,y2,m,dm,done);
% Compute the rational solution s:
%(tp+s*(tt-tp))*ev1=(tp+s*(tt-tp))*evn.
% The sum with ev1 is collected already in y1 and y2(with negative sign).
% This routine collects the sum with evn and computes the solution.
begin scalar x,y,z;
 if ev then<>;
 return if null ev then
         if null done then nil
          else rnquotient!:(rnminus!: y1,y2)
         else
         groeb!-w6!-9(cdr ev,cdr tt,ifactt,cdr tp,ifactp,
              rnplus!:(y1,rntimes!:(y,x)),
              rnplus!:(y2,rntimes!:(rndifference!:(z,y),x)),
              rndifference!:(m,dm),
              dm,
              done or not(car ev = 0)) end;

symbolic procedure groeb!-w7(tt,omega,x,tto,y);
% Compute omega*x*(1-tt)+tto*y*tt.
% tt is a rational number.
% x and y are rational numbers(inverses of the legths of omega/tt).
begin scalar n,z;n:=!*i2rn 1;
 omega:=for each g in omega collect
 <>;
 omega:=for each a in omega collect rnequiv rntimes!:(a,!*i2rn n);
 return omega end;

symbolic procedure groeb!-w7!-1(n,m);
% Compute lcm of n and m. N and m are rational numbers.
% Return the lcm.
% Ignore the denominators of n and m.
begin scalar x,y,z;
 if atom n then x:=n else
 <>;
 if atom m then y:=m else
 <>;
 z:=lcm(x,y);return z end;

symbolic procedure groeb!-w8(p,gb);
% Computes the cofactor of p wrt gb.
% Result is a list of cofactors corresponding to g.
% The cofactor 0 is represented as nil.
begin scalar x,y;
 x:=groeb!-w8!-1(p,gb);p:=secondvalue!*;
 while not vdpzero!? p do
 <>;return x end;

symbolic procedure groeb!-w8!-1(p,gb);
% Search in groebner basis gb the polynomial which divides the
% head monomial of the polynomial p. The walk version of
% groebsearchinlist.
% Result: the sequence corresponding to g with the monomial
% factor inserted.
begin scalar e,cc,r,done,pp;
 pp:=vdpevlmon p;cc:=vdplbc p;
 r:=for each poly in gb collect
  if done then nil else
   if vevdivides!?(vdpevlmon poly,pp)then
   <>
   else nil;
 if null e then
 <>;
 return r end;

symbolic procedure groeb!-w9(mode,ext);
% Switch on vdp order mode 'mode' with extension 'ext'.
% Result is the previous extension.
begin scalar x;
 x:=vdpsortextension!*;vdpsortextension!*:=ext;
 torder2 mode;return x end;

symbolic procedure groeb!-w10 s;
% Convert the dips in s corresponding to the actual order.
groeb!-collect(s,'groeb!-w10!-1);

symbolic procedure groeb!-w10!-1 p;
% Convert the dip p corresponding to the actal order.
begin scalar x;
 x:=vdpfmon(vdplbc p,vdpevlmon p);
 x:=gsetsugar(vdpenumerate x,nil);
 p:=vdpred p;
 while not vdpzero!? p do
 <>;
 return x end;

symbolic procedure rninv!: x;
% Return inverse of a(rational)number x: 1/x.
<>;

symbolic procedure sq2vdp s;
% Standard quotient to vdp.
begin scalar x,y;x:=f2vdp numr s;
 gsetsugar(x,nil);y:=f2vdp denr s;
 gsetsugar(y,0);s:=vdpdivmon(x,vdplbc y,vdpevlmon y);
 return s end;

symbolic procedure vdp2sq v;
% Conversion vdp to standard quotient.
begin scalar x,y,z,one;one := 1 ./ 1;x := nil ./ 1;
 while not vdpzero!? v do
 <>;return x end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/hilberts.red0000644000175000017500000003107611526203062024626 0ustar  giovannigiovannimodule hilberts;% Hilbert series of a set of Monomials .

% Author : Joachim Hollman,Royal Institute for Technology,Stockholm,Sweden
%  email :  < joachim@nada.kth.se >
% Improvement : Herbert Melenk,ZIB Berlin,Takustr 9,email : < melenk@zib.de >

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


comment

A very brief " description " of the method used.

M=k[x,y,z]/(x^2*y,x*z^2,y^2)
                    x.
0 --> ker(x.) --> M --> M --> M/x --> 0

M/x = k[x,y,z]/(x^2*y,x*z^2,y^2,x) = k[x,y,z]/(x,y^2)

ker(x.) =((x) +(x^2*y,x*z^2,y^2))/(x^2*y,x*z^2,y^2) =

        =(x,y^2)/(x^2*y,x*z^2,y^2)

Hilb(ker(x.)) = Hilb        - Hilb
                 (x,y^2)    (x^2*y,x*z^2,y^2)

        = 1/(1-t)^3 - Hilb                -
                          k[x,y,z]/(x,y^2)

          -(1/(1-t)^3 - Hilb
                          k[x,y,z]/(x^2*y,x*z^2,y^2)

        = Hilb -Hilb
              M     k[x,y,z]/(x,y^2)

If you only keep the numerator in Hilb = N(t)/(1-t)^3
                                       M
then you get

(1-t)N(t) = N(t)  - t(N(t) - N(t)   )
      I       I+(x)       I       Ann(x) + I

i.e.

 N(t) = N(t)  + t N(t)           (*)
  I       I+(x)      Ann(x) + I

Where
      I          =(x^2*y,x*z^2,y^2)
      I +(x)    =(x,y^2)
      I + Ann(x) =(x*y,z^2,y^2)
      N(t) is the numerator polynomial in Hilb
      I                                       k[x,y,z]/I

Equation(*)is what we use to compute the numerator polynomial,i.e.
we " divide out " one variable at a time until we reach a base case.
( One is not limited to single variables but I don't know of any good
strategy for selecting a monomial.)

Usage : hilb({ monomial_1,...,monomial_n } [,variable ]);

fluid '(nvars!*);

% ************** MACROS ETC. **************

smacro procedure term(c,v,e);{ ' times,c,{ ' expt,v,e } };

% -------------- safety check --------------

smacro procedure varp m;
 idp m and m or pairp m and get(car m,'simpfn)='simpiden;

smacro procedure checkexpt m;
 eqcar(m,'expt)and varp cadr m and numberp caddr m;

smacro procedure checksinglevar m;
 if varp m then t else checkexpt m;

smacro procedure checkmon m;
 if checksinglevar m then t
 else if eqcar(m,'times)then checktimes cdr m else nil;

smacro procedure checkargs(monl,var);
 listp monl and eqcar(monl,'list)and
  varp var and checkmonl monl;

symbolic procedure makevector(n,pat);
begin scalar v;v:=mkvect n;
 for i:=1:n do putv(v,i,pat);return v end;

% -------------- monomials --------------

smacro procedure allocmon n;makevector(n,0);

smacro procedure getnthexp(mon,n);getv(mon,n);

smacro procedure setnthexp(mon,n,d);putv(mon,n,d);

smacro procedure gettdeg mon;getv(mon,0);

smacro procedure settdeg(mon,d);putv(mon,0,d);

% -------------- ideals --------------

smacro procedure theemptyideal();{nil,nil};

smacro procedure getnextmon ideal;
<>;

smacro procedure notemptyideal ideal;cadr ideal;

smacro procedure firstmon ideal;caadr ideal;

smacro procedure appendideals(ideal1,ideal2);
{car ideal2,append(cadr ideal1,cadr ideal2)};

symbolic procedure insertvar(var,ideal);
% Inserts variable var as last generator of ideal
begin scalar last;last:={makeonevarmon var};
 return({last,append(cadr ideal,last)})end;

symbolic procedure addtoideal(mon,ideal);
% Add mon as generator to the ideal
begin scalar last;last:={mon};
 if ideal = theemptyideal()then rplaca(cdr(ideal),last)
  else rplacd(car(ideal),last);
 rplaca(ideal,last)end;

% ************** END OF MACROS ETC. **************

% ************** INTERFACE TO ALGEBRAIC MODE **************

symbolic procedure hilbsereval u;
begin scalar l,monl,var;l:=length u;
 if l < 1 or l > 2 then rerror(groebnr2,17,
       "Usage: hilb({monomial_1,...,monomial_n} [,variable])")
  else if l = 1 then
  <>;
 return flag end;

symbolic procedure checktimes m;
begin scalar flag,tmp;flag:=t;
 while m and flag do
 <>;return flag end;

symbolic procedure coefflist2prefix(cl,var);
begin scalar poly;integer i;
 for each c in cl do
 <>;return'plus.poly end;

symbolic procedure indets l;
% "Indets"  returns a list containing all the
% indeterminates of l.
% L is supposed to have a form similar to the variable
% GLTB in the Groebner basis package.
%(LIST(EXPT Z 2)(EXPT X 2) Y)
begin scalar varlist;
 for each m in l do
  if m neq'list then
   if atom m then varlist:=union({m},varlist)
    else if eqcar(m,'expt)then varlist:=union({cadr m},varlist)
    else varlist:=union(indets cdr m,varlist);
 return varlist end;

symbolic procedure buildassoc l;
% Given a list of indeterminates(x1 x2 ...xn) we produce
% an a-list of the form(( x1 . 1)(x2 . 2)...(xn . n)).
begin integer i;
 return(for each var in l collect progn(i:=i #+1,var.i)) end;

symbolic procedure mons l;
% Rewrite the leading monomials(i . e . GLTB).
% the result is a list of monomials of the form :
%(variable . exponent)or(( variable1 . exponent1)...
% (variablen . exponentn))
%
% mons('(LIST(EXPT Z 2)(EXPT X 2)(TIMES Y(EXPT X 3))));
%(((Y . 1)(X . 3))(X . 2)(Z . 2)).
begin scalar monlist;
 for each m in l do
  if m neq'list then monlist:=
    if atom m then(m. 1).monlist
     else if eqcar(m,'expt)
      then(cadr m.caddr m).monlist
      else(for each x in cdr m collect monsaux x).monlist;
 return monlist end;

symbolic procedure monsaux m;
 if eqcar(m,'expt)then cadr m.caddr m else m . 1;

symbolic procedure lmon2arrmon m;
% List-monomial to array-monomial
% a list-monomial has the form:(variable_number . exponent)
% or is a list with entries of this form.
% "variable_number" is the number associated with the variable,
% see buildassoc().
begin scalar mon;integer tdeg;mon:=allocmon nvars!*;
 if listp m then
  for each varnodotexp in m do
  <>
  else
  <>;
 settdeg(mon,tdeg);return mon end;

symbolic procedure gltbfix l;
% Sometimes GLTB has the form(list(list ...))
% instead of(list ...).
 if listp cadr l and caadr(l)='list then cadr l else l;

symbolic procedure gege(m1,m2);
 if gettdeg m1 >= gettdeg m2 then t else nil;

symbolic procedure getendptr l;
begin scalar ptr;while l do<>;
 return ptr end;

symbolic procedure gltb2arrideal xgltb;
% Convert the monomial ideal given by GLTB(in list form)
% to a list of vectors where each vector represents a monomial.
begin scalar l;l:=indets(gltbfix(xgltb));nvars!*:=length(l);
 l:=sublis(buildassoc l,mons gltbfix xgltb);
 l:=for each m in l collect lmon2arrmon(m);
 l:=sort(l,' gege);
 return{getendptr(l),l}end;

% ************** END OF INTERFACE TO ALGEBRAIC MODE **************

%************** PROCEDURES **************

symbolic procedure npol ideal;
% Recursively computes the numerator of the Hilbert series.
begin scalar v,si;v:=nextvar ideal;
 if not v then return basecasepol ideal;
 si:=splitideal(ideal,v);
 return shiftadd(npol car si,npol cadr si)end;

symbolic procedure dividesbyvar(var,mon);
begin scalar div;if getnthexp(mon,var)=0 then return nil;
 div:=allocmon nvars!*;
 for i:=1 : nvars!* do setnthexp(div,i,getnthexp(mon,i));
 setnthexp(div,var,getnthexp(mon,var)- 1);
 settdeg(div,gettdeg mon - 1);return div end;

symbolic procedure divides(m1,m2);
% Does m1 divide m2?
% m1 and m2 are monomials;
% result: either nil(when m1 does not divide m2)or m2 / m1.
begin scalar m,d,i;i:=1;m:=allocmon nvars!*;
 settdeg(m,d:=gettdeg m2 - gettdeg m1);
 while d >= 0 and i <= nvars!* do
 <>;
   return if d < 0 then nil else m end;

symbolic procedure shiftadd(p1,p2);
% p1 + z * p2;
% p1 and p2 are polynomials(nonempty coefficient lists).
begin scalar p,pptr;pptr:=p:=car p1.nil;
 p1:=cdr p1;
 while p1 and p2 do
 <>;
 if p1 then rplacd(pptr,p1)
  else rplacd(pptr,p2);return p end;

symbolic procedure remmult(ipp1,ipp2);
% The union of two ideals with redundancy of generators eliminated.
begin scalar fmon,inew,isearch,primeflag,x;
 % fix;x is used in the macro...
 x:=nil;inew:=theemptyideal();
 while notemptyideal(ipp1)and notemptyideal(ipp2)do
  begin if gettdeg(firstmon(ipp2)) < gettdeg(firstmon(ipp1))
   then<>
    else <>;
 primeflag:=t;
 while primeflag and notemptyideal isearch do
  if divides(getnextmon isearch,fmon)then primeflag:=nil;
 if primeflag then addtoideal(fmon,inew)end;
 return if notemptyideal ipp1 then appendideals(inew,ipp1)
  else appendideals(inew,ipp2)end;

symbolic procedure nextvar ideal;
% Extracts a variable in the ideal suitable for division.
begin scalar m,var,x;x:=nil;
 repeat
 <>until var or ideal=theemptyideal();
 return var end;

symbolic procedure getvarifnotsingle mon;
% Returns nil if the monomial is in a single variable,
% otherwise the index of the second variable of the monomial.
begin scalar foundvarflag,exp;integer i;
 while not foundvarflag do
 <0 then foundvarflag:=t>>;
 foundvarflag:=nil;
 while i0 then foundvarflag:=t>>;
 if foundvarflag then return i else return nil end;

symbolic procedure makeonevarmon vindex;
% Returns the monomial consisting of the single variable vindex.
begin scalar mon;mon:=allocmon nvars!*;
 for i:=1:nvars!* do setnthexp(mon,i,0);
 setnthexp(mon,vindex,1);
 settdeg(mon,1);return mon end;

symbolic procedure splitideal(ideal,var);
% Splits the ideal into two simpler ideals.
begin scalar div,ideal1,ideal2,m,x;x:=nil;
 ideal1:=theemptyideal();ideal2:=theemptyideal();
 while notemptyideal(ideal)do
 <>;
   ideal2:=remmult(ideal1,ideal2);ideal1:=insertvar(var,ideal1);
 return{ideal1,ideal2}end;

symbolic procedure basecasepol ideal;
% In the base case every monomial is of the form Xi ^ ei;
% result : the numerator polynomial of the Hilbert series
%          i.e.(1 - z ^ e1)*(1 - z ^ e2)* ...
begin scalar p,degsofar,e;integer tdeg;
 for each mon in cadr ideal do tdeg:=tdeg+gettdeg mon;
 p:=makevector(tdeg,0);putv(p,0,1);degsofar:=0;
 for each mon in cadr ideal do
 <>;
 return vector2list p end;

symbolic procedure vector2list v;
% Convert a vector v to a list.  No type checking is done.
begin scalar u;
  for i:=upbv v step -1 until 0 do u:=getv(v,i).u;
  return u end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/ideals.tex0000644000175000017500000000763611526203062024306 0ustar  giovannigiovanni\documentstyle[12pt]{article}
\begin{document}
\begin{center} {\Large Polynomial Ideals} \end{center}
\begin{center} Arithmetic for polynomial ideals supported by 
Gr\"obner bases \end{center}
\begin{center} Version 1.0 May 1992 \end{center}

\begin{center} Herbert Melenk \\ Konrad-Zuse-Zentrum f\"ur
Informationstechnik \\
Takustra\"se 7 \\ D14195 Berlin--Dahlem \\ Federal Republic of Germany \\ 
melenk@zib.de \\ May 1992 \end{center}

\section{Introduction}

This package implements the basic arithmetic for polynomial ideals
by exploiting the Gr\"obner bases package of REDUCE.
In order to save computing time all intermediate Gr\"obner bases
are stored internally such that time consuming repetitions
are inhibited. A uniform setting facilitates the access.

\section{Initialization}

Prior to any computation the set of variables has to be declared
by calling the operator $I\_setting$ . E.g. in order to initiate
computations in the polynomial ring $Q[x,y,z]$ call
\begin{verbatim}
    I_setting(x,y,z);
\end{verbatim}
A subsequent call to $I\_setting$ allows one to select another set
of variables; at the same time the internal data structures
are cleared in order to free memory resources.

\section{Bases}

An ideal is represented by a basis (set of polynomials) tagged
with the symbol $I$, e.g.
\begin{verbatim}
   u := I(x*z-y**2, x**3-y*z);
\end{verbatim}
Alternatively a list of polynomials can be used as input basis; however,
all arithmetic results will be presented in the above form. The
operator $ideal2list$ allows one to convert an ideal basis into a
conventional REDUCE list.

\subsection{Operators}

Because of syntactical restrictions in REDUCE, special operators
have to be used for ideal arithmetic: 

\begin{verbatim}
         .+            ideal sum (infix)
         .*            ideal product (infix)
         .:            ideal quotient (infix)
         ./            ideal quotient (infix)
         .=            ideal equality test (infix)
         subset        ideal inclusion test (infix)
         intersection  ideal intersection (prefix,binary)
         member        test for membership in an ideal
                         (infix: polynomial and ideal)
         gb            Groebner basis of an ideal (prefix, unary)
         ideal2list    convert ideal basis to polynomial list 
                         (prefix,unary)
\end{verbatim}

Example:

\begin{verbatim}
    I(x+y,x^2) .* I(x-z);

      2                      2    2
   I(X  + X*Y - X*Z - Y*Z,X*Y  - Y *Z)
\end{verbatim}

The test operators return the values 1 (=true) or 0 (=false)
such that they can be used in REDUCE $if-then-else$ statements
directly.

The results of $sum,product, quotient,intersction$ are ideals
represented by their Gr\"obner basis in the current setting and
term order. The term order can be modified using the operator
$torder$ from the Gr\"obner package. Note that ideal equality 
cannot be tested with the REDUCE equal sign:

\begin{verbatim}

   I(x,y)  = I(y,x)       is false
   I(x,y) .= I(y,x)       is true

\end{verbatim}

\section{Algorithms}

The operators $groebner$, $preduce$ and $idealquotient$ of the 
REDUCE Gr\"obner package support the basic algorithms:

$GB(Iu_1,u_2...) \rightarrow groebner(\{u_1,u_2...\},\{x,...\})$

$p \in I_1 \rightarrow p=0 \ mod \ I_1$

$I_1 : I(p) \rightarrow (I_1 \bigcap I(p)) / p \ elementwise$

\noindent
On top of these the Ideals package implements the following 
operations:


$I(u_1,u_2...)+I(v_1,v_2...) \rightarrow GB(I(u_1,u_2...,v_1,v_2...))$


$I(u_1,u_2...)*I(v_1,v_2...)\rightarrow 
 GB(I(u_1*v_1,u_1*v2,...,u_2*v_1,u_2*v_2...))$


$I_1 \bigcap I_2 \rightarrow
  Q[x,...] \bigcap GB_{lex}(t*I_1 + (1-t)*I_2,\{t,x,..\}) $


$I_1 : I(p_1,p_2,...) \rightarrow I_1 : I(p_1) \bigcap I_1 : I(p_2)
\bigcap ...$

$I_1 = I_2 \rightarrow GB(I_1)=GB(I_2)$

$I_1 \subseteq I_2
   \rightarrow \ u_i \in I_2 \ \forall \ u_i \in I_1=I(u_1,u_2...)$

\section{Examples}

Please consult the file $ideals.tst$.
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebner.rlg0000644000175000017500000007043611527635055024646 0ustar  giovannigiovanniFri Feb 18 21:27:55 2011 run on win32
% Examples of use of Groebner code.

% In the Examples 1 - 3 the polynomial ring for the ideal operations
% (variable sequence, term order mode) is defined globally in advance.

% Example 1, Linz 85.

torder ({q1,q2,q3,q4,q5,q6},lex)$



groebner {q1,
          q2**2 + q3**2 + q4**2,
          q4*q3*q2,
          q3**2*q2**2 + q4**2*q2**2 + q4**2*q3**2,
          q6**2 + 1/3*q5**2,
          q6**3 - q5**2*q6,
          2*q2**2*q6 - q3**2*q6 - q4**2*q6 + q3**2*q5 - q4**2*q5,
          2*q2**2*q6**2 - q3**2*q6**2 - q4**2*q6**2 - 2*q3**2*q5*q6
          + 2*q4**2*q5*q6 - 2/3*q2**2*q5**2 + 1/3*q3**2*q5**2
          + 1/3*q4**2*q5**2,
          - q3**2*q2**2*q6 - q4**2*q2**2*q6 + 2*q4**2*q3**2*q6 -
          q3**2*q2**2*q5 + q4**2*q2**2*q5,
          - q3**2*q2**2*q6**2 - q4**2*q2**2*q6**2 + 2*q4**2*q3**2*q6**2
          + 2*q3**2*q2**2*q5*q6 - 2*q4**2*q2**2*q5*q6 + 1/3*q3**2*q2**2
          *q5**2 + 1/3*q4**2*q2**2*q5**2 - 2/3*q4**2*q3**2*q5**2,
          - 3*q3**2*q2**4*q5*q6**2 + 3*q4**2*q2**4*q5*q6**2
          + 3*q3**4*q2**2*q5*q6**2 - 3*q4**4*q2**2*q5*q6**2
          - 3*q4**2*q3**4*q5*q6**2 + 3*q4**4*q3**2*q5*q6**2
          + 1/3*q3**2*q2**4*q5**3 - 1/3*q4**2*q2**4*q5**3
          - 1/3*q3**4*q2**2*q5**3 + 1/3*q4**4*q2**2*q5**3 + 1/3*q4**2
            *q3**4*q5**3 - 1/3*q4**4*q3**2*q5**3};


{q1,

   2     2     2
 q2  + q3  + q4 ,

 q2*q3*q4,

      4
 q2*q4 *q6,

      3             3
 q2*q4 *q5 + 3*q2*q4 *q6,

      3   2
 q2*q4 *q6 ,

   4     2   2     4
 q3  + q3 *q4  + q4 ,

   3           3
 q3 *q4 + q3*q4 ,

   2   2
 q3 *q4 *q6,

   2          2        2          2
 q3 *q5 - 3*q3 *q6 - q4 *q5 - 3*q4 *q6,

   2   2     2   2
 q3 *q6  + q4 *q6 ,

      4
 q3*q4 *q6,

      3
 q3*q4 *q5,

      3   2
 q3*q4 *q6 ,

   5
 q4 ,

   4        4
 q4 *q5 + q4 *q6,

   4   2
 q4 *q6 ,

   2           2   2
 q4 *q5*q6 - q4 *q6 ,

   2       2
 q5  + 3*q6 ,

   3
 q6 }



% Example 2. (Little) Trinks problem with 7 polynomials in 6 variables.

trinkspolys:={45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          - 9*w + 15*p*t + 20*z*s,
          w*p + 2*z*t - 11*b**3,
          99*w - 11*s*b + 3*b**2,
          b**2 + 33/50*b + 2673/10000}$



trinksvars :=  {w,p,z,t,s,b}$


torder(trinksvars,lex)$


switch varopt;

 off varopt;


groebner trinkspolys;


{60000*w + 9500*b + 3969,

 1800*p - 3100*b - 1377,

 18000*z + 24500*b + 10287,

 750*t - 1850*b + 81,

 200*s - 500*b - 9,

        2
 10000*b  + 6600*b + 2673}


groesolve ws;


     3*(4*sqrt(11)*i - 11)
{{b=-----------------------,
              100

     62*sqrt(11)*i + 59
  p=--------------------,
            300

     3*(5*sqrt(11)*i - 13)
  s=-----------------------,
              50

     148*sqrt(11)*i - 461
  t=----------------------,
             500

      - 190*sqrt(11)*i - 139
  w=-------------------------,
              10000

      - 490*sqrt(11)*i - 367
  z=-------------------------},
              3000

     3*( - 4*sqrt(11)*i - 11)
 {b=--------------------------,
               100

      - 62*sqrt(11)*i + 59
  p=-----------------------,
              300

     3*( - 5*sqrt(11)*i - 13)
  s=--------------------------,
                50

      - 148*sqrt(11)*i - 461
  t=-------------------------,
               500

     190*sqrt(11)*i - 139
  w=----------------------,
            10000

     490*sqrt(11)*i - 367
  z=----------------------}}
             3000

 

% Example 3. Hairer, Runge-Kutta 1, 6 polynomials 8 variables.
 
torder({c2,c3,b3,b2,b1,a21,a32,a31},lex);


{{w,p,z,t,s,b},lex}

groebnerf{c2 - a21,
          c3 - a31 - a32,
          b1 + b2 + b3 - 1,
          b2*c2 + b3*c3 - 1/2,
          b2*c2**2 + b3*c3**2 - 1/3,
          b3*a32*c2 - 1/6};


{{c2 - a21,

  c3 - a32 - a31,

  b3 + b2 + b1 - 1,

              2            2                            2    2            2    2
  96*b2*b1*a31  - 96*b2*a31  + 96*b2*a31 - 32*b2 - 72*b1 *a32 *a31 - 48*b1 *a32

           2        2         2                2    3             2
   - 144*b1 *a32*a31  - 144*b1 *a32*a31 - 72*b1 *a31  + 198*b1*a32 *a31

              2                 2                                          3
   + 60*b1*a32  + 396*b1*a32*a31  + 72*b1*a32*a31 - 144*b1*a32 + 198*b1*a31

               2                                                    2
   - 108*b1*a31  - 24*b1*a31 - 81*a21*a32*a31 + 54*a21*a32 - 126*a32 *a31

           2              2                                 3          2
   - 12*a32  - 252*a32*a31  + 126*a32*a31 + 36*a32 - 126*a31  + 162*a31

   - 30*a31 - 12,

                                2                                      2
  8*b2*a21 - 8*b2*a31 + 6*b1*a32  + 12*b1*a32*a31 + 4*b1*a32 + 6*b1*a31

                                 2                             2
   - 4*b1*a31 - 9*a21*a32 - 6*a32  - 12*a32*a31 + 8*a32 - 6*a31  + 10*a31 - 2,

                     2                                       2
  8*b2*a32 + 6*b1*a32  + 12*b1*a32*a31 + 12*b1*a32 + 6*b1*a31  + 4*b1*a31

                      2                     2
   - 9*a21*a32 - 6*a32  - 12*a32*a31 - 6*a31  + 2*a31 + 2,

                          2                           2                    2
  12*b1*a21*a32 - 6*b1*a32  - 12*b1*a32*a31 - 6*b1*a31  - 3*a21*a32 + 6*a32

                               2
   + 12*a32*a31 - 6*a32 + 6*a31  - 6*a31 + 2,

                         2                          2
  4*b1*a21*a31 + 2*b1*a32  + 4*b1*a32*a31 + 2*b1*a31  - 3*a21*a32 - 4*a21*a31

                  2                            2
   + 2*a21 - 2*a32  - 4*a32*a31 + 4*a32 - 2*a31  + 4*a31 - 2,

          3            2                    2           3            2
  6*b1*a32  + 18*b1*a32 *a31 + 18*b1*a32*a31  + 6*b1*a31  - 9*a21*a32

                                      3         2             2             2
   - 9*a21*a32*a31 + 6*a21*a32 - 6*a32  - 18*a32 *a31 + 12*a32  - 18*a32*a31

                               3        2
   + 18*a32*a31 - 6*a32 - 6*a31  + 6*a31  - 2*a31,

       2                                2                  2
  3*a21 *a32 - 3*a21*a32 - a21*a31 + a32  + 2*a32*a31 + a31 }}

 
        
% The examples 4 and 5 use automatic variable extraction.

% Example 4.
 
torder gradlex$


 
g4:= 
groebner{b + e + f - 1,
         c + d + 2*e - 3,
         b + d + 2*f - 1,
         a - b - c - d - e - f,
         d*e*a**2 - 1569/31250*b*c**3,
         c*f - 587/15625*b*d};


                                                   5
g4 := {144534461790680056924571742971580442350868*f

                                                      4
        - 644899801559202566371326081182412388593750*f

                                                         2
        - 5642454222593591361522253644740080176968509*e*f

                                                       3
        + 1026970650200404602876625225711718032483739*f

        + 60671378319336814425425106786936647125250*e*f

                                                        2
        + 12135463840178290842421221291430776956948795*f

        + 82342665293813692270756265387326300721851*e

        - 6546572608747272255841866021042619274525791*f

        - 455593441982762135422235490670177670637,

                              3                        4
       8282838608877853969*e*f  - 2667985333760708531*f

                                2                        3
        - 315490964385538173*e*f  - 8319462093247392142*f  - 25594942638053*e*f

                              2
        + 318993777538462620*f  + 33851175608089*e + 34163367871142*f

        - 8568425233089,

            2                      2
       587*e  - 46875*e*f + 15038*f  - 587*e + 47462*f,

       a + 2*e - 4,

       b + e + f - 1,

       c + 3*e - f - 3,

       d - e + f}

hilbertpolynomial g4;


8

glexconvert(g4,gvarslast,newvars={e},maxdeg=8);


                         8                            7
{8724935291855297898986*e  - 82886885272625330040367*e

                              6                             5
  + 304980377204235125220384*e  - 524915947547338451201596*e

                              4                            3
  + 362375013966993813907616*e  + 52719473339686639067952*e

                              2
  - 154986762992209058701440*e  + 27347344067139574366944*e + 430203494102932512

 }


% Example 5.

off varopt;


torder({u0,u2,u3,u1},lex)$


groesolve({u0**2 - u0 + 2*u1**2 + 2*u2**2 + 2*u3**2,
          2*u0*u1 + 2*u1*u2 + 2*u2*u3 - u1,
          2*u0*u2 + u1**2 + 2*u1*u3 - u2,
          u0 + 2*u1 + 2*u2 + 2*u3 - 1},
         {u0,u2,u3,u1});


{{u0=1,u2=0,u3=0,u1=0},

      1           1
 {u0=---,u2=0,u3=---,u1=0},
      3           3

                 5              4              3             2
 {u0=(85796172*u1  - 47481552*u1  - 10265256*u1  + 4828462*u1  + 414200*u1

       - 24707)/164805,

                  5              4              3             2
  u2=(490926744*u1  - 82790424*u1  - 46802952*u1  + 5425849*u1  + 1108070*u1

       - 83819)/164805,

  u3

                  5             4             3            2
     - 35588322*u1  + 7102080*u1  + 3462372*u1  - 522672*u1  - 98665*u1 + 11905
  =-----------------------------------------------------------------------------
                                       10987

  ,

                      6           5           4          3         2
  u1=root_of(24948*u1_  - 8424*u1_  - 1908*u1_  + 736*u1_  + 24*u1_  - 18*u1_

              + 1,u1_,tag_1)}}

 
% Example 6. (Big) Trinks problem with 6 polynomials in 6 variables.
 
torder(trinksvars,lex)$


btbas:=
 groebner{45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          -9*w + 15*p*t + 20*z*s,
           w*p + 2*z*t - 11*b**3,
          99*w - 11*b*s + 3*b**2};


btbas := {17766149161458472422166115589155691471353640232570952361584640*w

                                                                               9
           + 3032932981764169411024286535087872715152793150994240000000000000*b

           + 11886822444254795859791802829918904596379497649520730600000000000

            8
          *b  + 

                                                                             7
          18842475008351431516615767365088235858572104823839818660000000000*b  +

                                                                              6
           18478618789454571665641479626067848900525899492180377333740000000*b  

                                                                               5
          + 11752365113063961011548983119538614396423298749092231098450400000*b

                                                                               4
           + 5110161259755495688253057699488605142801193206234091633443430000*b

                                                                               3
           + 1496961750963944475883560598484727796781670457510019079125319720*b

                                                                              2
           + 288690575257721822668492218552623049380964882774348400629792405*b

           + 36675221781192845731725910375461662443650512572339688148737880*b

           + 1576363174251807401047861085627012261518448811764870474808048,

          1079293561558602199646591522041208256884733644128685355966266880*p + 

                                                                               9
          3268477702530974927415861070452491173139572636038856000000000000000*b

           + 

          12885633343818230635528913313274512975854362843839764665000000000000

            8
          *b  + 

          20548731096300848092222002490748474767709483225818633322500000000000

            7
          *b  + 

          20182049540868333737979937480097593847242554499522522583343500000000

            6
          *b  + 

          12840592651209104850152262711039251760751322701157046861979660000000

            5
          *b  + 

                                                                               4
          5569707184558884260455460870514004047533638259197462099687709750000*b

           + 1626104523905067336734029117969017435050069455164231436772691393000

            3
          *b  + 

                                                                              2
          317837165064133808425156860561547977935248864650364953213370433325*b

           + 38814916107963233682867824475195786374043607759221055124383464600*b

           + 1271557117681971715777755868970298734422034654142333039426477936,

          79947671226563125899747520151200611621091381046569285627130880*z - 

                                                                              9
          207000360174268878618253807286221414267374039050881600000000000000*b  

          - 816930976846005632807581869594187232031930825060787069000000000000

            8
          *b  - 

                                                                               7
          1304191848597021137419209873493260430019068809677834324500000000000*b

           - 1281648951757969533154633755921969360988365079018184794999100000000

            6
          *b  - 

                                                                              5
          816111850476984294981540451378918253659030380648143145999676000000*b  

          - 354123157925898223808181474698490366723104830470028121053590350000

            4
          *b  - 

                                                                              3
          103524414072393919562685172085266423030522292688870620316927889800*b  

                                                                               2
          - 20314259597530323830287024948271996904872237353588201428371308545*b

           - 2537917907646239051588678539186026277776904294491429226344955896*b

           - 101754994043218022355542895254001231074817584410141704072917808,

          53964678077930109982329576102060412844236682206434267798313344*t - 

                                                                              9
          232158787821822686686268803096828213303267879649894080000000000000*b  

          - 914339994087255788035842922803409884324637299732580010200000000000

            8
          *b  - 

                                                                               7
          1456553024942306848445635398194494646048613632462079804220000000000*b

           - 1429773468085320579659912540829309032262384742022357855878580000000

            6
          *b  - 

                                                                              5
          908944691139155009098308941935669674404431611232759364790656800000*b  

          - 394123305458525780887811122985868682566594060374758630590008810000

            4
          *b  - 

                                                                              3
          114919063563435384108358931167592408356874179358918284670595993240*b  

                                                                               2
          - 22376181506466478409426169614162075694852682500804198791108921475*b

           - 2945714266609139709176973289117451707834537151497408879223183208*b

           - 127343046946408668687682889109197718306724189305639804298381200,

          23984301367968937769924256045360183486327414313970785688139264*s - 

                                                                             9
          93385077215170712211881744870071176375416361029681600000000000000*b  -

                                                                               8
           368160952680520875300826094664986085024410366966850419000000000000*b

           - 587106602751452802634914356878527850505985235023389523500000000000

            7
          *b  - 

                                                                              6
          576629986881952392513712499431359824206930128557786359524100000000*b  

          - 366874075748831567147207506029692907450037791461629910342276000000

            5
          *b  - 

                                                                              4
          159134490987396693155870310586114401358103950262784631419648850000*b  

                                                                               3
          - 46460129254430495335257974799114783858573413004692326764934039800*b

                                                                               2
           - 9081061858975251669290196016044227941007110418581855806096298095*b

           - 1222066452390803097568723620648006189979646603457892421797898376*b

           - 60999770483681527871286545331521866855137759127008037834271184,

                                10                          9
          43808000000000000000*b   + 189995300000000000000*b

                                    8                          7
           + 343169730200000000000*b  + 377900184178000000000*b

                                    6                          5
           + 277427432368460000000*b  + 141636786601439800000*b

                                   4                         3
           + 50921375336016834000*b  + 12792266529459977340*b

                                  2
           + 2215667232541084905*b  + 237653554658069880*b + 8984801833047216}

 
% The above system has dimension zero. Therefore its Hilbert polynomial
% is a constant which is the number of zero points (including complex
% zeros and multipliticities);

hilbertpolynomial ws;


10


% Example of Groebner with numerical postprocessing.

on rounded;

off varopt;


groesolve(trinkspolys,trinksvars);


{{b= - 0.397994974843*i - 0.33,

  p= - 0.685435790007*i + 0.196666666667,

  s= - 0.994987437107*i - 0.78,

  t= - 0.981720937945*i - 0.922,

  w=0.0630158710168*i - 0.0139,

  z=0.541715382425*i - 0.122333333333},

 {b=0.397994974843*i - 0.33,

  p=0.685435790007*i + 0.196666666667,

  s=0.994987437107*i - 0.78,

  t=0.981720937945*i - 0.922,

  w= - 0.0630158710168*i - 0.0139,

  z= - 0.541715382425*i - 0.122333333333}}

off rounded;



% Additional groebner operators.

% Reduce one polynomial wrt the basis of big Trinks. The result 0
% is a proof for the ideal membership of the polynomial.

torder(trinksvars,lex)$


preduce(45*p + 35*s - 165*b - 36,btbas);


0

 
% The following examples show how to work with the distributive
% form of polynomials.

torder({u0,u1,u2,u3},gradlex)$


gsplit(2*u0*u2 + u1**2 + 2*u1*u3 - u2,{u0,u1,u2,u3});


           2
{2*u0*u2,u1  + 2*u1*u3 - u2}


torder(trinksvars,lex)$


gsort trinkspolys;


                   3
{w*p + 2*z*t - 11*b ,

                    2
 99*w - 11*s*b + 3*b ,

  - 9*w + 15*p*t + 20*z*s,

                                    2
 15*w + 25*p*s + 30*z - 18*t - 165*b ,

 35*p + 40*z + 25*t - 27*s,

 45*p + 35*s - 165*b - 36,

  2    33       2673
 b  + ----*b + -------}
       50       10000

 
gspoly(first trinkspolys,second trinkspolys);


360*z + 225*t - 488*s + 1155*b + 252


gvars trinkspolys;


{w,p,z,t,s,b}


% Tagged basis and reduction trace. A tagged basis is a basis where
% each polynomial is equated to a linear combination of the input
% set. A tagged reduction shows how the result is computed by using
% the basis polynomials.

% First example for tagged polynomials: show how a polynomial is
% represented as linear combination of the basis polynomials.

  % First I set up an environment for the computation.

torder(trinksvars,lex)$



  % Then I compute an ordinary Groebner basis.

bas:=groebner trinkspolys$



  % Next I assign a tag to each basis polynomial.

taggedbas:=for i:=1:length bas collect mkid(p,i)=part(bas,i);


taggedbas := {p1=9500*b + 60000*w + 3969,

              p2= - 3100*b + 1800*p - 1377,

              p3=24500*b + 18000*z + 10287,

              p4= - 1850*b + 750*t + 81,

              p5= - 500*b + 200*s - 9,

                        2
              p6=10000*b  + 6600*b + 2673}


  % And finally I reduce a (tagged) polynomial wrt the tagged basis.

preducet(new=w*p + 2*z*t - 11*b**3,taggedbas);


                                                         3                    2
857375000000*p*w + 1714750000000*t*z + 2376000000000000*w  + 471517200000000*w

                                              2
 + 31190862780000*w + 687758524299=992750000*b *p1 - 6270000000*b*p1*w

                                                       2
 - 414760500*b*p1 + 857375000000*new + 39600000000*p1*w  + 5239080000*p1*w

 + 173282571*p1


% Second example for tagged polynomials: representing a Groebner basis 
% as a combination of the input polynomials, here in a simple geometric
% problem.

torder({x,y},lex)$


groebnert {circle=x**2 + y**2 - r**2,line=a*x + b*y};

 left 
------------------------------------------------------------------------------
 >> accum. cpu time : 0 ms 
 left 
------------------------------------------------------------------------------
 >> accum. cpu time : 0 ms 

{ - a*x - b*y= - line,

   2    2   2    2  2  2
 (a  + b )*y  - a *r =a *circle - a*line*x + b*line*y}


% In the third example I enter two polynomials that have no common zero.
% Consequently the basis is {1}. The tagged computation gives me a proof
% for the inconsistency of the system which is independent of the
% Groebner formalism.

groebnert {circle1=x**2 + y**2 - 10,circle2=x**2 + y**2 - 2};


     - circle1 + circle2
{1=----------------------}
             8


% Solve a special elimination task by using a blockwise elimination
% order defined by a matrix.  The equation set goes back to A.M.H.
% Levelt (Nijmegen).  The question is whether there is a member in the
% ideal which depends only on two variables.  Here we select x4 and y1.
% The existence of such a polynomial proves that the system has exactly
% one degree of freedom.

% The first two rows of the term order matrix define the groupwise
% elimination. The remaining lines define a secondary local
% lexicographical behavior which is needed to construct an admissible
% ordering.

f1:=y1^2 + z1^2 -1;


        2     2
f1 := y1  + z1  - 1

f2:=x2^2 + y2^2 + z2^2 -1;


        2     2     2
f2 := x2  + y2  + z2  - 1

f3:=x3^2 + y3^2 + z3^2 -1;


        2     2     2
f3 := x3  + y3  + z3  - 1

f4:=x4^2 + z4^2 -1;


        2     2
f4 := x4  + z4  - 1

f5:=y1*y2 + z1*z2;


f5 := y1*y2 + z1*z2

f6:=x2*x3 + y2*y3 + z2*z3;


f6 := x2*x3 + y2*y3 + z2*z3

f7:=x3*x4 + z3*z4;


f7 := x3*x4 + z3*z4

f8:=x2 + x3 + x4 + 1;


f8 := x2 + x3 + x4 + 1

f9:=y1 + y2 + y3 - 1;


f9 := y1 + y2 + y3 - 1

f10:=z1 + z2 + z3 + z4;


f10 := z1 + z2 + z3 + z4


eqns:={f1,f2,f3,f4,f5,f6,f7,f8,f9,f10}$


vars:={x2,x3,y2,y3,z1,z2,z3,z4,x4,y1}$



torder(vars,matrix,
mat((1,1,1,1,1,1,1,1,0,0),
    (0,0,0,0,0,0,0,0,1,1),
    (1,0,0,0,0,0,0,0,0,0),
    (0,1,0,0,0,0,0,0,0,0),
    (0,0,1,0,0,0,0,0,0,0),
    (0,0,0,1,0,0,0,0,0,0),
    (0,0,0,0,1,0,0,0,0,0),
    (0,0,0,0,0,1,0,0,0,0),
    (0,0,0,0,0,0,1,0,0,0),
    (0,0,0,0,0,0,0,0,1,0)));


{{x,y},lex}


first reverse groebner(eqns,vars);


  2   2       2                        2
x4 *y1  - 2*x4  + 2*x4*y1 - 2*x4 - 2*y1  + 2*y1


% For a faster execution we convert the matrix into a
% proper machine code routine.

on comp;


torder_compile(levelt,mat(
  (1,1,1,1,1,1,1,1,0,0),
  (0,0,0,0,0,0,0,0,1,1),
  (1,0,0,0,0,0,0,0,0,0),
  (0,1,0,0,0,0,0,0,0,0),
  (0,0,1,0,0,0,0,0,0,0),
  (0,0,0,1,0,0,0,0,0,0),
  (0,0,0,0,1,0,0,0,0,0),
  (0,0,0,0,0,1,0,0,0,0),
  (0,0,0,0,0,0,1,0,0,0),
  (0,0,0,0,0,0,0,0,1,0)));

+++ levelt compiled, 324 + 20 bytes

levelt

torder(vars,levelt)$


first reverse groebner(eqns,vars);


  2   2       2                        2
x4 *y1  - 2*x4  + 2*x4*y1 - 2*x4 - 2*y1  + 2*y1


% For a homogeneous polynomial set we compute a graded Groebner
% basis with grade limits. We use the graded term order with lex
% as following order. As the grade vector has no zeros, this ordering
% is functionally equivalent to a weighted ordering.

torder({x,y,z},graded,{1,1,2},lex);


{{x2,x3,y2,y3,z1,z2,z3,z4,x4,y1},levelt}

dd_groebner(0,10,{x^10*y + y*z^5, x*y^12 + y*z^6});


    12      6  10        5
{x*y   + y*z ,x  *y + y*z }
  
dd_groebner(0,50,{x^10*y + y*z^5, x*y^12 + y*z^6});


  7    18    34  5
{x *y*z   - y  *z ,

  8    12    23  5
 x *y*z   + y  *z ,

  9    6    12  5
 x *y*z  - y  *z ,

    12      6
 x*y   + y*z ,

  10        5
 x  *y + y*z }
  
dd_groebner(0,infinity,{x^10*y + y*z^5, x*y^12 + y*z^6});


  111  5      60
{y   *z  + y*z  ,

      54    100  5
 x*y*z   - y   *z ,

  2    48    89  5
 x *y*z   + y  *z ,

  3    42    78  5
 x *y*z   - y  *z ,

  4    36    67  5
 x *y*z   + y  *z ,

  5    30    56  5
 x *y*z   - y  *z ,

  6    24    45  5
 x *y*z   + y  *z ,

  7    18    34  5
 x *y*z   - y  *z ,

  8    12    23  5
 x *y*z   + y  *z ,

  9    6    12  5
 x *y*z  - y  *z ,

    12      6
 x*y   + y*z ,

  10        5
 x  *y + y*z }
  

% Test groebner_walk
trinkspolys := {45*p + 35*s - 165*b - 36,
          35*p + 40*z + 25*t - 27*s,
          15*w + 25*p*s + 30*z - 18*t - 165*b**2,
          - 9*w + 15*p*t + 20*z*s,
          w*p + 2*z*t - 11*b**3,
          99*w - 11*s*b + 3*b**2,
          b**2 + 33/50*b + 2673/10000}$


trinksvars :=  {w,p,z,t,s,b}$


torder(trinksvars,gradlex)$


gg:=groebner trinkspolys$


g:=groebner_walk gg$



on div$


g;


  2    33       2673
{b  + ----*b + -------,
       50       10000

  19            1323
 -----*b + w + -------,
  120           20000

     31           153
  - ----*b + p - -----,
     18           200

  49           1143
 ----*b + z + ------,
  36           2000

     37           27
  - ----*b + t + -----,
     15           250

     5            9
  - ---*b + s - -----}
     2           200


on varopt;


g1:=solve({first g},{b});


          3                 33
g1 := {b=----*sqrt(11)*i - -----,
          25                100

             3                 33
       b= - ----*sqrt(11)*i - -----}
             25                100

g0:=sub({first g1},g);


g0 := {0,

         19                      139
       ------*sqrt(11)*i + w + -------,
        1000                    10000

           31                     59
        - -----*sqrt(11)*i + p - -----,
           150                    300

        49                     367
       -----*sqrt(11)*i + z + ------,
        300                    3000

           37                     461
        - -----*sqrt(11)*i + t + -----,
           125                    500

           3                     39
        - ----*sqrt(11)*i + s + ----}
           10                    50

solve({ second g0},{w});


        19                  139
{w= - ------*sqrt(11)*i - -------}
       1000                10000

solve({third g0},{p});


    31                 59
{p=-----*sqrt(11)*i + -----}
    150                300

solve({part(g0,4)},{z});


       49                 367
{z= - -----*sqrt(11)*i - ------}
       300                3000

solve({part(g0,5)},{t});


    37                 461
{t=-----*sqrt(11)*i - -----}
    125                500

solve({part(g0,6)},{s});


    3                 39
{s=----*sqrt(11)*i - ----}
    10                50


g0:=sub({second g1},g);


g0 := {0,

            19                      139
        - ------*sqrt(11)*i + w + -------,
           1000                    10000

        31                     59
       -----*sqrt(11)*i + p - -----,
        150                    300

           49                     367
        - -----*sqrt(11)*i + z + ------,
           300                    3000

        37                     461
       -----*sqrt(11)*i + t + -----,
        125                    500

        3                     39
       ----*sqrt(11)*i + s + ----}
        10                    50

solve({second g0},{w});


     19                  139
{w=------*sqrt(11)*i - -------}
    1000                10000

solve({third g0},{p});


       31                 59
{p= - -----*sqrt(11)*i + -----}
       150                300

solve({part(g0,4)},{z});


    49                 367
{z=-----*sqrt(11)*i - ------}
    300                3000

solve({part(g0,5)},{t});


       37                 461
{t= - -----*sqrt(11)*i - -----}
       125                500

solve({part(g0,6)},{s});


       3                 39
{s= - ----*sqrt(11)*i - ----}
       10                50


% Example after the book "David Cox, John Little, Donal O'Shea:
% "Ideals, Varieties and Algorithms", chapter 2, paragraph 8, example 3.
% This example was given by Shigetoshi Katsura (Japan).
 
off groebopt;

torder({x,y,z,l},lex);


{{w,p,z,t,s,b},gradlex,1,0,0,0,0,0}

g:=groebner{3*x^2+2*y*z-2*x*l,2*x*z-2*y*l,2*x*y-2*z-2*z*l,x^2+y^2+z^2-1}$


gdimension g;


0

gindependent_sets g;


{{}}


clear g, gg, trinkspolys, trinksvars$



end;


Time for test: 124 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 1 45 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groesolv.red0000644000175000017500000004733011526203062024652 0ustar  giovannigiovannimodule groesolv;% Tools for solving systems of polynomials(and poly-
% nomial equations)based on Groebner basis techniques.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%   Authors:     H. Melenk(ZI Berlin,Germany)
%                H. M Moeller(when this module was written Fernuniversitaet Hagen,
%                                now Universitaet Dortmund,Germany)
%                W. Neun(ZI Berlin,Germany)
%
%    Aug 1992:   accepting external solutions for univariate pols.
%    March 1994: access to roots / multroot.
%    Feb 1995: assumptions,requirements added.
%    Oct 2001: the REDUCE switch 'varopt' is copied to the switch
%              'groebopt' (which is saved during then processing of
%              'groesolve').
%    March 2005: the test for parameters is switched off, if
%              !*notestparameters is t.

% Operators:
%
%      GROESOLVE      does the whole job of solving a nonlinear
%                     set of expressions and/or equations.
%
%      GROEPOSTPROC   expects that its first parameter is a
%                     lexical groebner base already.

groesolvelevel!*:=0;

symbolic procedure groesolveeval u;
begin scalar !*ezgcd,gblist,oldtorder,res,!*groebopt,!*precise,
 y,fail,problems,denominators!*,variables!*,gmodule,at,!*notestparameters;
 !*notestparameters:=t;
 if null dmode!* then !*ezgcd:=t;
  % Copy the REDUCE switch 'varopt' to the switch 'groebopt'.
 !*groebopt:=!*varopt;gvarslast:='(list);
 oldtorder:=apply1('torder,'(lex));
 groesoldmode!*:=get(dmode!*,'dname);
 !*groebcomplex:=!*complex;
 groesetdmode(groesoldmode!*,nil);
 problems:={u};
 while problems and not fail do
 <>;
     for each r in res do if gb
                % Do not compare with the mother problem .
             and not subsetp(car r,car u)
       then if groesolvidsubset!?(gb,car r,variables!*)then
              res:=delete(r,res)else
            if groesolvidsubset!?(car r,gb,variables!*)then
             <>;
     if gb then
     <>;
      for each d in denominators!* do
       problems:={append(gb,{d}), variables!*}.problems;
      denominators!*:=nil>>>>>>;
 apply1('torder,{oldtorder});
 problems:=nil;if fail then res:=nil;
 if null res then requirements:=append(requirements,at)
  else assumptions:=append(assumptions,at);
 for each r in res do problems:=union(cdr r,problems);
 return'list.groesolve!-redun2 problems end;

symbolic procedure groesolve!-redun2 sol;
% Sol is a list of solutions;remove redundancies,now not
% by ideal theory but by simple substitution.
begin scalar b;
 for each s in sol do
  if s memq sol then
  <>;
 return sol end;

symbolic procedure groesolve!-redun2a(r,s);
% Redundancy test: if sub(s,r)=> trivial then t because s
% is a special case of r.
if smemq('root_of,s)then nil else
 begin scalar q,!*evallhseqp,!*protfg;
  !*evallhseqp:=t;!*protfg:=t;
  q:=errorset({'subeval,mkquote{s,r}},nil,nil);
  if errorp q then <>;
  q:=cdar q;
  while q and 0=reval{'difference,cadar q,caddar q}do q:=cdr q;
  return null q end;

symbolic procedure groesolvidsubset!?(b1,b2,vars);
% Test if ideal b1 is a subset of ideal b2.
%(b2 is a specialization of b1 wrt zeros).
null b1 or(car b1='list or 0=preduceeval{car b1,b2,vars})and
 groesolvidsubset!?(cdr b1,b2,vars);

symbolic procedure groesolvearb(r,vars);
% Cover unmentioned variables.
 if atom r or not !*arbvars then r else
 for each s in r collect
  <>;

%------------------- Driver for the postprocessor ----------------

symbolic procedure groesolve0(a,vars);
begin scalar r,ids,newvars,newa;
 if(r:=groepostnumsolve(a,vars))then return r;
 if(r:=groepostfastsolve(a,vars)) then return r;
 if(r:=groeposthillebrand(a,vars)) then return r;
 r:=groepostsolveeval{a,vars};
 if r neq'failed then return cdr r;
 ids:=cdr gindependent_seteval{a,vars};
 if null ids then goto nullerr;
 ids:=car ids;
 newvars:='list.for each x in cdr vars join
                 if not(x memq ids)then{x};
 newa:=groebnereval{a,newvars};
 denominators!*:=cdr glterms;
 if newa='(list 1)then rerror(groebner,24,"recomputation for dim=0 failed");
 r:=groepostfastsolve(newa,newvars);
 if r then return r;
 r:=groepostsolveeval{a,vars};
 if r neq'failed then return cdr r;
nullerr:
  rerror(groebner,23,
        "Moeller ideal decomposition failed with 0 dim ideal.")end;

symbolic procedure groepostnumsolve(gb,vars);
if not errorp errorset('(load!-package'roots2), nil,nil)
 and getd'multroot0
  and get(dmode!*,'dname)member'( rounded complex!-rounded)
  and length gb=length vars and groepostnumsolve1(gb,vars)
  then(cdr reval multroot0(precision 0,gb))where !*compxroots=t;

symbolic procedure groepostnumsolve1(gb,vars);
if null gb then t else
 groepostnumsolve1(cdr gb,cdr vars)and
 <>where q=t;

symbolic procedure groepostfastsolve(gb,vars);
% Try to find a fast solution.
begin scalar u,p1,p2,fail,kl,res;
 if !*trgroesolv then prin2t "fast solve attempt";
 groesoldmode!*:=get(dmode!*,'dname);
 !*groebnumval:=member(groesoldmode!*,'(rounded complex!-rounded));
 groesetdmode(groesoldmode!*,'nil);
 u:=kl:=for each p in cdr gb collect
 <>;
 if u='((nil)) then goto trivial;
 while u and cdr u do
 <>;
 if fail then goto exit;
 res:=for each r in groepostfastsolve1(reverse kl,nil,0)
        collect'list.reverse r;
 goto exit;
trivial:
 res:={'list.for each x in cdr vars collect{'equal,x,mvar makearbcomplex()}};
exit:
 groesetdmode(groesoldmode!*,t);
 return res end;

fluid'(f);

symbolic procedure groepostfastsolve1(fl,sub,n);
 if null fl then'(nil)else
  begin scalar u,f,v,sub1;
   n:=n #+ 1;
   f:=car fl;v:=car f;f:=numr subf(cdr f,sub);
   if null f then return groepostfastsolve1(cdr fl,sub,n);
  % v:=car sort(v,function(lambda(x,y);degr(f,x)>degr(f,y)));
   v:=car v;
(f:=reorder f)where kord!*={v};
   if not domainp lc f then groepostcollectden reorder lc f;
   u:=groesolvepolyv(prepf f,v);
   return for each s in u join
   <> end;

unfluid'(f);

symbolic procedure groepostcollectden d;
% d is a non trivial denominator(standard form);
% collect its factors.
 for each p in cdr fctrf d do
  if not member(p:=prepf car p,denominators!*)then
   denominators!*:=p.denominators!*;

put('groesolve,'psopfn,'groesolveeval);

symbolic procedure groepostsolveeval u;
begin scalar a,b,vars,oldorder,groesoldb!*;
 scalar !*groebprereduce,!*groebopt,!*groesolgarbage;
 groesoldmode!*:=get(dmode!*,'dname);
 groesetdmode(groesoldmode!*,'nil);
 !*groebnumval:=member(groesoldmode!*,'(rounded complex!-rounded));
 if vdpsortmode!*='lex then t else
  rerror(groebner,8,"groepostproc, illegal torder;(only lex allowed)");
 a:=groerevlist reval car u;
 vars:=cdr u and groerevlist cadr u or groebnervars(a,nil);
 oldorder:=setkorder vars;
 b:= groesolve1(a,a,vars);
 a:=nil;
 if b eq'failed then a:=b else
 <>;
 setkorder oldorder;
 groesetdmode(groesoldmode!*,t);
 return a end;

put('groepostproc,'psopfn,'groepostsolveeval);

% Data structure:
%
%  All polynomials are held in prefix form(expressions).
%  Transformation to standard quotients / standard forms is done locally
%  only;distributive form is not used here.
%
%  A zero is a set of equations,if possible with a variable on the
%  lhs each
%       e.g.{y=17,z=b+8};
%        internally:(( equal y 17)(equal z(plus b 8)))
%  A zeroset is a list of zeros
%       elgl{{y=17,z=b+8},{e=17,z=b-8}}
%  Internally the sets(lists)are kept untagged as lists;the
%  tag'list is only added to the results and to those lists which
%  are parameters to algebraic operators not in this package.

symbolic procedure groesolve1(a,fulla,vars);
%  a lex Groebner basis or tail of lex Groebner basis.
%  fulla the complete lex Groebner basis to a.
%  vars  the list of variables.
if null a or a='(1)then nil else
<>;
         % step 1
 f1:=car a;
 a1:=cdr a;
 test:=nil;
 mv:=intersection(vars,ltermvariables f1);% test Buchcrit 4
 for each p in a1 do if intersection(mv,ltermvariables p)then test:=t;
 if not test then
 <>;
   ng2:=groesolve1(a,a,vars);
   if ng2 eq'failed then <>
>>else
  <>;
   for each g in t1 do
   <>>>;
 if null phi then return nil;% 29.8.88
 t1:=t2;
 q:=cdr groebidq('list.a,'times.phi,'list.vars);
 if not(car q=1)then
 <>;
 if !*groesolgarbage then return groesolverestruct(q,phi,vars,ngall);
 while t1 do
 <> >>>>;
 return ngall end;

symbolic procedure groesolverestruct(a,phi,vars,ngall);
% There was a problem with an embedded solution in phi such that
% a : phi=a;
% we try a heuristic by making one variable a formal parameter.
begin scalar newa,newvars,mv,oldorder,solu;
 mv:=ltermvariables('times.phi);
 mv:=car mv;
 newvars:=delete(mv,vars);
 oldorder:=setkorder newvars;
 newa:=cdr groebnereval{'list.a,'list.newvars};
 !*groesolgarbage:=nil;
  solu:=groesolve1(newa,newa,newvars);
 setkorder oldorder;
 return if !*groesolgarbage then ngall else solu end;

symbolic procedure ltermvariables u;
% Extract variables of leading term in u.
begin scalar v;
 u:=numr simp u;
 while not domainp u do<>;
 return reversip v end;

symbolic procedure zerosetintersection(ng,poly,vars);
% ng is a zeroset, poly is a polynomial.
% The routine maps the zeros in'ng'by the polynomial:
%   each zero is substituted into the polynomial,
%   that gives a univariate
%   solved by SOLVE or numerical techniques.
% The result is the solution'ng',including the solutions of the
% polynomial.
begin scalar res,ns,testpoly,ppoly,sol,s,var,dom;
 res:=();
 poly:=simp poly;
 var:=if not domainp numr poly then groesolmvar(numr poly,vars)
  else'constant;
loop:
 if ng=()then go to finish;
 ns:=car ng;ng:=cdr ng;
 testpoly:=poly;
 dom:=groesoldmode!* or'rational;
 groesetdmode(dom,t);
 testpoly:=simp prepsq testpoly;
 for each u in ns do
  if idp lhs u and not smemq('root_of,rhs u)then
  <>;
 groesetdmode(dom,nil);
 ppoly:=prepf numr testpoly;
 sol:=groesolvepolyv(ppoly,var);
 res:=append(res,for each r in sol collect append(r,ns));
 go to loop;
finish:
 return res end;

symbolic procedure groesolmvar(poly,vars);
% Select main variable wrt vars sequence.
<>;


% Solving a single polynomial with respect to its main variable .

symbolic procedure groesolvepoly p;groesolvepolyv(p,mainvar p);

symbolic procedure groesolvepolyv(p,var);
% Find the zeros for one polynomial p in the variable'var'.
% Current dmode is'nil'.
( begin scalar res,u,!*convert,y,z;
  if(u:=assoc(var,depl!*))then depl!*:=delete(u,depl!*);
  if !*trgroesolv then
  <>;
 for each s in groebroots!* do
  if 0=reval{'difference,p,car s}then res:=cdr s;
 if res then return res;
 groesetdmode(groesoldmode!*,t);
 u:=numr simp p;
 res:=if !*groebnumval and univariatepolynomial!? u
  then groeroots(p,var)
  else(solveeval{p,var})
    where kord!*=nil,alglist!*=nil.nil;
 res:=cdr res;
       % Collect nontrivial denominator factors.
       % Reorder for different local order during solveeval.
 for each x in res do
 <>;
 res:=for each x in res collect {x};
 groesetdmode(groesoldmode!*,nil);
 return res end) where depl!*=depl!*;

symbolic procedure univariatepolynomial!? fm;
 domainp fm or univariatepolynomial!?1(fm,mvar fm);

symbolic procedure univariatepolynomial!?1(fm,v);
 domainp fm or
 domainp lc fm and v=mvar fm and univariatepolynomial!?1(red fm,v);

symbolic procedure predecessor(r,l);
% Looks for the  predecessor of'r'in'l'.
 if not pairp l or not pairp cdr l or r=car l
  then rerror(groebner,9,"no predecessor available")else
  if r=cadr l then car l else predecessor(r,cdr l);

symbolic procedure zerosetunion(ng1,ng2);<>;

symbolic procedure zerosetunion1(ng1,ng2);
% Unify zeroset structures.
 if ng1=()then ng2
  else if zerosetmember(car ng1,ng2)then zerosetunion1(cdr ng1,ng2)
  else car ng1.zerosetunion1(cdr ng1,ng2);

symbolic procedure zerosetmember(ns,ng);
 if ng=()then nil else
 if zeroequal(ns,car ng)then ng else zerosetmember(ns,cdr ng);

symbolic procedure zeroequal(ns1,ns2);
 if zerosubset(ns1,ns2)then zerosubset(ns2,ns1)else nil;

symbolic procedure zerosubset(ns1,ns2);
 if null ns1 then t else
 if member(car ns1,ns2)then zerosubset(cdr ns1,ns2)else nil;

symbolic procedure groesetdmode(dmode,dir);
% Interface for switching an arbitrary domain on/off.
% Preserve complex mode. Turn on EZGCD whenever possible.
 if null dmode then nil else
 begin scalar !*msg,x,y;
  if null dir then
  <>>>
  else
  <>
  else y:=setdmode(dmode,t);
  if memq(dmode,'(rounded complex!-rounded)) then !*rounded:=t>>;
 !*ezgcd:=null dmode!*;return y end;

symbolic procedure preduceeval pars;
% Polynomial reduction driver.'u'is an expression and v a list of
% expressions. Preduce calculates the polynomial u reduced wrt the list
% of expressions'v'.
% Parameters:
%     1      Expression to be reduced,
%     2      polynomials or equations;base for reduction.
%     3      Optional: list of variables.
begin scalar n,vars,x,u,v,w,oldorder,!*factor,!*exp,!*gsugar,!*vdpinteger;
 integer pcount!*;!*exp:=t;
 if !*groebprot then groebprotfile:={'list};
 n:=length pars;
 x:=reval car pars;
 u:=reval cadr pars;
 v:=if n #> 2 then reval caddr pars else nil;
 w:=for each j in groerevlist u collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebnr2,3,"empty list in preduce.");
 vars:=groebnervars(w,v);
 if not vars then vdperr'preduce;
 oldorder:=vdpinit vars;
 w:=for each j in w collect a2vdp j;
 x:=a2vdp x;
 if !*groebprot then
 <>;
 w:=groebnormalform(x,w,'sort);
 w:=vdp2a w;
 setkorder oldorder;
 return if w then w else 0 end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% The following code is the interface to Stan's rootfinder.
%

symbolic procedure groeroots(p,x);
 begin scalar r;
  x:=nil;r:=reval{'roots,p};
         % Re-evaluate rhs in order to get prefix form.
  r:=for each e in cdr r collect{'equal,cadr e,reval caddr e};
  return'list.r end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebsea.red0000644000175000017500000001142511526203062024575 0ustar  giovannigiovannimodule groebsea;

% Support of search for reduction polynomials.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Search for reduction candidates in a list.

symbolic procedure groebsearchinlist(vev,g);
 % Search for a polynomial in the list 'g',such that the lcm divides
 % vev;'g' is expected to be sorted in descending sequence.
 if null g then nil
 else if buchvevdivides!?(vdpevlmon car g,vev)then car g
 else groebsearchinlist(vev,cdr g);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Search list for polynomials;
%  simple variant: mapped to list.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure groeblistadd(poly,stru);
% Add one polynomial to the tree;
% if this is a simple polynomial(mono or bino), reform
% the list.
 if hcount!* #< 5000 then vdplsortin(poly,stru)
  else vdplsortinreplacing(poly,stru);

symbolic procedure groebstreeadd(poly,stru);
% Map 'groebstreeadd' to 'groeblistadd'.
 groeblistadd(poly,stru);

% symbolic procedure groeblistreconstruct u;
% % Reconstructs a tree from a linear list of polynomials.
%              vdplsort u;

symbolic procedure groebvevdivides!?(e1,e2);
% Look, if 'e1' is a factor of 'e2'.
 if null e1 then t else if null e2 then(if vevzero!? e1 then t else nil)else
 if car e1 #> car e2 then nil else groebvevdivides!?(cdr e1,cdr e2);

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
% Reforming g, d and g99 when a very simple polynomial was
% found(e.g. a monomial, a binomial).

symbolic procedure groebsecondaryreduction(poly,g,g99,d,gc,
    mode);
 % If poly is a simple polynomial, the polynomials in 'g' and 'g99'
 % are reduced in a second pass. Result is 'g',secondvalue is  'g99'.
 % 'mode' says, that 'g99' has to be modified in place.
 begin scalar break,first,p,pl,rep,rpoly,vev,x;
  mode:=nil;
  secondvalue!*:=g99;thirdvalue!*:=d;fourthvalue!*:=gc;
  vev:=vdpevlmon poly;rpoly:=vdpred poly;
        % Cancel redundant elements in 'g99'.
  for each p in g99 do if buchvevdivides!?(vev,vdpevlmon p)
   then g99:=delete(p,g99);
  if vdplength poly > 2 or  vevzero!? vev then return g;
  if !*groebweak and not vdpzero!? rpoly
   and(groebweaktestbranch!=1(poly,g,d)) then return 'abort;
        !*trgroeb and groebmess50 g;
  pl:=union(g,g99);first:=t;
  while pl and not break do
 <>>>;
  if break then return 'abort;
                           % Reform 'g99'.
  g99:=for each p in g99 collect groebsecondaryreplace(p,rep);
  secondvalue!*:= groebsecondaryremovemultiples g99;
  thirdvalue!*:=d;% Reform 'd'.
  fourthvalue!*:=groebsecondaryremovemultiples   % Reform 'gc'.
  for each y in gc collect groebsecondaryreplace(y,rep);
  g:=for each y in g collect groebsecondaryreplace(y,rep);
         !*trgroeb and groebmess50 g;
  return groebsecondaryremovemultiples g end;

symbolic procedure groebsecondaryremovemultiples g;
 if null g then nil else
  if vdpzero!? car g or member(car g,cdr g)then
   groebsecondaryremovemultiples cdr g else
    car g.groebsecondaryremovemultiples cdr g;

symbolic procedure groebsecondaryreplace(x,rep);
(if y then cdr y else x)where y=atsoc(x,rep);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/hilbertp.red0000644000175000017500000001576711526203062024634 0ustar  giovannigiovannimodule hilbertp;% Computing Hilbert Polynomial from the Hilbert series.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure newhilbi(bas,var,vars);
 begin scalar baslt,n,u,grad,h,joa,a,ii,dim0,varx,dmode!*,!*modular;
 % Extract leading terms .
 baslt:= for each p in cdr bas  collect
 << u:=hgspliteval list(p,vars);cadr u >>;
 % Replace non atomic elements in the varlist by gensyms .
 for each x in cdr vars do
  if(pairp x)then
    baslt:=cdr subeval {{'equal,x,gensym()},' list . baslt};
 varx:=!*a2f var;
%%%%%%%%%%%%%%%
 if not(cdaar varx =1 and cdar varx =1 and null cdr varx)then
   <" ;prin2 var;prin2 "< has been set;";
     terpri();
     var:=gensym();varx:=!*a2f var;
     prin2 "***** >";prin2 var;prin2 "< is selected as variable.";
     terpri()>>;
%%%%%%%%%%%%%%%
 % Compute the Hilbertseries .
 joa:=hilbsereval list(' list . baslt,var);
 % Get the Hilbert polynomial .
 grad:=deg(joa,var);
 a:=for i:=0 : grad collect coeffn(joa,var,i);
 n:= length cdr vars;
% dim0:=( for i:=1 : n product(var + i)) /(for i:=1 : n product i);
 dim0:=1;
 for i:=1 : n do dim0:=multf(addd(i,varx),dim0);
 dim0:=multsq(dim0 ./ 1,1 ./(for i:=1 : n product i));
 h:=multsq(car a ./ 1,dim0);
 a:=cdr a;
 ii:=0;
 while a do
 << dim0:=multsq(dim0,addf(varx,numr simp(minus ii))
                        ./ addf(varx,numr simp(n - ii)));
  ii:=ii + 1;
  if not(car a = 0)then h:=addsq(h,multsq(car a ./ 1,dim0));
  a:=cdr a  >>;
 return mk!*sq h end;

symbolic procedure psnewhilbi u;
begin scalar zz,pl,vl;pl:=reval car u;
 if cdr u then vl:=listeval(cadr u,nil);
 zz:='list.groebnervars(cdr pl,vl);
 return  newhilbi(pl,'x,zz)end;

put('hilbertpolynomial,'psopfn,'psnewhilbi);

symbolic procedure hgspliteval pars;
% A variant of Gsplit from grinterf.red.
% Split a polynomial into leading monomial and reductum.
begin scalar vars,x,u,v,w,oldorder,!*factor,!*exp;
 integer n,pcount!*;!*exp:=t;
 n:=length pars;
 u:=reval car pars;
 v:=if n > 1 then reval cadr pars else nil;
 u:={'list,u};
 w:=for each j in groerevlist u
  collect if eqexpr j then !*eqn2a j else j;
 vars:=groebnervars(w,v);
 if not vars then   vdperr ' hilbertpolynomial;
 oldorder:=vdpinit vars;
 w:=a2vdp car w;
 if vdpzero!? w then x:=w else
%     <>;
 w:={' list,vdp2a x,vdp2a w};
 setkorder oldorder;
 return w end;

% Simple Array access method for one- and two-dimensional arrays .
% NO check against misusage is done !

% Usage:   Rar:=makeRarray list dim1;Rar:=makeRarray {dim1,dim2};
%          val:=getRarray(Rar,ind1);val:=getrarray(Rar,ind1,ind2);
%          putRarray(Rar,ind1,val); PutRarray(Rar,in1,ind2,val);

% For two dimensional array access only !

macro procedure functionindex2 u;
begin scalar dims,ind1,ind2;
 dims:=cadr u;ind1:=caddr u;ind2:=cadddr u;
 return         %%%%((ind1 #- 1) #* cadr dims) #+ ind2;
  {'iplus2,ind2,{'itimes2,{'cadr,dims},
                              {'iplus2,ind1,-1}}} end;

macro procedure getrarray u;
begin scalar arry,inds;
 arry:=cadr u;inds:=cddr u;
 if length inds = 1 then
  return  {'getv,{'cdr,arry},car inds}
  else return {'getv,{'cdr,arry},
                    'functionIndex2.{'car,arry}.inds} end;

symbolic procedure makerarray dims;
begin scalar u,n;
 n:=for each i in dims product i;
 u:=mkvect n;return dims . u end;

macro procedure putrarray u;
begin scalar arry,inds,val;
 arry:=cadr u;
 inds:=cddr u;
 val:=nth(u,length u);   % PSL: lastcar u;
 if length inds = 2 then
  return  {'putv,{'cdr,arry},car inds,val}
  else return {'putv,{'cdr,arry},'functionindex2 .
               {' car,arry}.car inds.cadr inds.nil,val} end;

symbolic procedure hilbertzerodimp(nrall,n,rarray);
begin integer i,k,count,vicount;
 while(( i:=i+1)<= nrall and count < n)do
 begin vicount:=1;
  for k:=1 : n do
   if(getrarray(rarray,i,k)= 0)then vicount:=vicount + 1;
  if vicount = n  then count:=count + 1;
  end;return count = n end;

symbolic procedure groezerodim!?(f,n);
begin scalar explist,a;integer r;
           %explist:= list( vev(lt(f1)),...,vev(lt(fr)));
 explist:= for each fi in f collect vdpevlmon fi;
 r:= length f;
 a:=makerarray {r,n};
 for i:=1 step 1 until r do
  for k:=1 step 1 until n do
   putrarray(a,i,k,nth(nth(explist,i),k));
 return hilbertzerodimp(r,n,a)end;

symbolic procedure gzerodimeval u;
begin scalar vl;
 if cdr u then vl:=reval cadr u;return gzerodim1(reval car u,vl)end;

put('gzerodim!?,'psopfn,'gzerodimeval);

symbolic procedure gzerodim1(u,v);
begin scalar vars,w,oldorder;
 w:=for each j in getrlist u
  collect if eqexpr j then !*eqn2a j else j;
 if null w then rerror(groebnr2,21,"empty list in hilbertpolynomial");
 vars:=groebnervars(w,v);
 oldorder:=vdpinit vars;
 w:=for each j in w collect f2vdp numr simp j;
 w:=groezerodim!?(w,length vars);
 setkorder oldorder;
 return if w then newhilbi(u,'x,'list.v)else nil end;

symbolic procedure gbtest g;
% Test,if the given set of polynomials is a Groebner basis .
% Only fast to compute plausilbility test .
begin scalar fredu,g1,r,s;
 g:=vdplsort g;
        % Make abbreviated version of g .
 g1:= for each p in g collect
 <>;
 while g1 do
 <>;
      if groebsearchinlist(vdpevlmon car g1,cdr g1)then fredu:=t;
      g1:=cdr g1>>;
 if fredu then
 <> end;

endmodule;; end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebmes.red0000644000175000017500000002517111526203062024614 0ustar  giovannigiovannimodule groebmes;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Trace messages for the algorithms .
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure groebpairprint(p);
<< groebmessff(" pair(",cadr p,nil);
 groebmessff(",",caddr p,nil);
 prin2 "), ";prin2 " lcm = ";print car p >>;

symbolic procedure groetimeprint;
<< prin2 " >> accum. cpu time : ";
 prin2(time() - groetime!*);prin2t " ms " >>;

symbolic procedure groebmessff(m1,f,m2);
<< prin2 m1;prin2 vdpnumber f;
 if !*gsugar then << prin2 " / ";prin2 gsugar f >>;
 if m2 then prin2t m2 >>;

symbolic procedure groebmess1(g,d);
if !*trgroeb then << g := g;d := d;
 prin2 " variables : ";print vdpvars!*;
 printbl();prin2t " Start of ITERATION ";terpri() >>;

symbolic procedure groebmess2 f;
if !*trgroeb then << terpri();
 groebmessff(" polynomial ",f," eliminated ");
 groetimeprint() >>;

symbolic procedure groebmess2a(f,cf,fn);
if !*trgroeb then << terpri();
 groebmessff("polynomial ",f,nil);
 groebmessff(" elim . with cofactor ",cf," to ");
 vdpprint fn;terpri();groetimeprint() >>;

symbolic procedure groebmess3(p,s);
if !*trgroebs then << prin2 " S - polynomial from ";
 groebpairprint p;vdpprint s;terpri();
 groetimeprint();terprit 3 >>;

symbolic procedure groebmess4(p,d);
<< hcount!* := hcount!* + 1;
 hzerocount!* := hzerocount!* + 1;
 if !*trgroeb then << terpri();printbl();
  groebmessff(" reduction(",cadr p,nil);
  groebmessff(",",caddr p,nil);
  prin2 ")leads to 0;";
  prin2 n;
  prin2 if n = 1 then " pair" else " pairs" >> where n = length d;
  prin2t " left ";
  printbl();groetimeprint() >>;

symbolic procedure groebmess41 p;
<< hcount!* := hcount!* + 1;
 hzerocount!* := hzerocount!* + 1;
 if !*trgroeb then << terpri();printbl();
  groebmessff(" polynomial(",p,nil);
  prin2 ")reduced to 0;";
  terpri();printbl();groetimeprint() >> >>;

symbolic procedure groebmess5(p,h);
if car p then
<< hcount!* := hcount!* + 1;
 if !*trgroeb then << terpri();prin2  " H - polynomial ";
  prin2 pcount!*;prin2 " ev : ";prin2 vdpevlmon h;
  groebmessff(" from pair(",cadr p,nil);
  groebmessff(",",caddr p,")");
  vdpprint h;terpri();groetimeprint() >> >>
 else
 if !*trgroeb then << prin2t " from actual problem input : ";
  vdpprint h;groetimeprint() >>;

symbolic procedure groebmess50 g;
if !*trgroeb1 then << prin2 " list of active polynomials : ";
 for each d1 in g do
  << prin2 vdpgetprop(d1,'number);prin2 " " >>;terprit 2 >>;

symbolic procedure groebmess51 d;
if !*trgroeb1 then <<
 prin2t " Candidates for pairs in this step : ";
 for each d1 in d do groebpairprint d1;terprit 2 >>;

symbolic procedure groebmess52 d;
if !*trgroeb1 then <<
 prin2t " Actual new pairs from this step : ";
 for each d1 in d do groebpairprint d1;terprit 2 >>;

symbolic procedure groebmess7 h;
if !*trgroebs then
<< prin2t " Testing factorization for ";vdpprint h >>;

symbolic procedure groebmess8(g,d);
if !*trgroeb1 then <<
 g := g;prin2t " actual pairs : ";
 if null d then prin2t " null "
  else for each d1 in d do groebpairprint d1;
 groetimeprint() >>
 else if !*trgroeb then <<
  prin2 n;prin2t if n = 1 then " pair" else " pairs " >>
   where n = length d;

symbolic procedure groebmess13(g,problems);
if !*trgroeb or !*trgroebr then <<
 if g then << basecount!* := basecount!* + 1;
 printbl();printbl();
 prin2  " end of iteration ";
 for each f in reverse factorlevel!* do
 << prin2 f;prin2 " . " >>;
 prin2 ";basis ";prin2 basecount!*;prin2t " : ";
 prin2 " { ";for each g1 in g do vdpprin3t g1;prin2t " } ";
 printbl();printbl();groetimeprint() >>
 else
 << printbl();prin2  " end of iteration branch ";
  for each f in reverse factorlevel!* do
  << prin2 f;prin2 " . " >>;
  prin2t "  ";printbl();groetimeprint() >>;
  if problems and !*trgroeb then
  << groetimeprint();terpri();printbl();
   prin2 " number of partial problems still to be solved : ";
   prin2t length problems;terpri();
   prin2 " preparing  next problem ";
   if car car problems = 'file then prin2 cdr car problems
    else if cadddr car problems then
     vdpprint car cadddr car problems;terpri() >> >>;

symbolic procedure groebmess14(h,hf);
if !*trgroeb then <<
 prin2 " ******************* factorization of polynomial ";
(if x then prin2t x else terpri())where x = vdpnumber h;
 prin2t " factors : ";
 for each g in hf do vdpprint car g;groetimeprint() >>;

symbolic procedure  groebmess15 f;
if !*trgroeb then
<< prin2t " ***** monomial factor reduced : ";
 vdpprint vdpfmon(a2vbc 1,f)>>;

symbolic procedure groebmess19(p,restr,u);
if !*trgroeb then <<
 u := u;restr := restr;printbl();
 prin2  " calculation branch ";
 for each f in reverse factorlevel!* do
 << prin2 f;prin2 " . " >>;
 prin2t " cancelled because ";vdpprint p;
 prin2t " is member of an actual abort condition ";
 printbl();printbl() >>;

symbolic procedure groebmess19a(p,u);
if !*trgroeb then << u := u;printbl();
 prin2  " during branch preparation ";
 for each f in reverse u do << prin2 f;prin2 "." >>;
 prin2t " cancelled because ";vdpprint p;
 prin2t " was found in the ideal branch ";printbl() >>;

symbolic procedure groebmess20 p;
if !*trgroeb then <<
 terpri();prin2 " secondary reduction starting with ";vdpprint p >>;

symbolic procedure groebmess21(p1,p2);
if !*trgroeb then <<
 prin2 " polynomial ";prin2 vdpnumber p1;
 prin2 " replaced during secondary reduction by ";
 vdpprint p2 >>;

symbolic procedure groebmess22(factl,abort1,abort2);
if null factl then nil
 else if !*trgroeb then
  begin integer n;
   prin2t " BRANCHING after factorization point ";
   n := 0;for each x in reverse factl do
   << n := n+1;prin2 " branch ";
    for each f in reverse factorlevel!* do << prin2 f;prin2 " . " >>;
    prin2t n;for each y in car x do vdpprint y;
    prin2t " simple IGNORE restrictions for this branch : ";
    for each y in abort1 do vdpprint y;
    for each y in cadr x do vdpprint y;
    if abort2 or caddr x then
    << prin2t " set type IGNORE  restrictions for this branch : ";
     for each y in abort2 do vdpprintset y;
     for each y in caddr x do vdpprintset y >>;
    printbl() >> end;

symbolic procedure  groebmess23(g0,rest1,rest2);
if !*trgroeb then
 if null factorlevel!* then
  prin2t " ** starting calculation ****************************** "
  else << prin2 "** resuming calculation for branch ";
 for each f in reverse factorlevel!* do << prin2 f;prin2 "." >>;
 terpri();if rest1 or rest2 then
 << prin2t " -------IGNORE restrictions for this branch : ";
  g0 := g0;for each x in rest1 do vdpprint x;
  for each x in rest2 do vdpprintset x >> >>;

symbolic procedure groebmess24(h,problems1,restr);
 %  if !*trgroeb then
<< prin2t " ********** polynomial affected by branch restriction : ";
 vdpprint h;if restr then prin2t " under current restrictions ";
 for each x in restr do vdpprint x;
 if null problems1 then prin2t "        CANCELLED "
 else << prin2t " partitioned into ";vdpprintset car problems1 >> >>;

symbolic procedure groebmess25(h,abort2);
<< prin2t " reduction of set type cancel conditions by ";
 vdpprint h;prin2t " remaining : ";
 for each x in abort2 do vdpprintset x >>;

symbolic procedure groebmess26(f1,f2);
if !*trgroebs and not vdpequal(f1,f2)then
 << terpri();prin2t  " during final reduction ";
  vdpprint f1;prin2t " reduced to ";vdpprint f2;terpri() >>;

symbolic procedure groebmess27 r;
if !*trgroeb then << terpri();
 prin2t " factor ignored(considered already): ";vdpprint r >>;

symbolic procedure groebmess27a(h,r);
if !*trgroeb then
<< terpri();vdpprint h;
 prin2t "     reduced to zero by factor ";vdpprint r >>;

symbolic procedure groebmess28 r;
if !*trgroeb then
<< writepri(" interim content reduction : ",'first);
 writepri(mkquote prepsq r,'last)>>;

symbolic procedure groebmess29 omega;
if !*trgroeb then
<< terpri();prin2 " actual weight vector : [ ";
 for each x in omega do << prin2 " ";prin2 x >>;prin2 " ] ";
 terpri();terpri() >>;

symbolic procedure groebmess30 gomegaplus;
if !*trgroeb and gomegaplus then
<< terpri();prin2 " new head term(or full)basis ";terpri();
 for each x in gomegaplus do << vdpprint x;terpri() >> >>;

symbolic procedure groebmess31 gg;
if !*trgroeb then << prin2 " full basis ";terpri();
 for each x in gg do << vdpprint x;terpri();terpri() >> >>;

symbolic procedure groebmess32 g;
if !*trgroeb then << terpri();
 prin2 " ***** start of iteation with ";terpri();
 for each x in g do vdpprint x;
 prin2 " **************************** ";terpri() >>;

symbolic procedure groebmess33 g;
if !*trgroeb then
<< terpri();prin2 " ***** resulting system ***** ";terpri();
 for each x in g do vdpprint x;
 prin2 " **************************** ";terpri() >>;

symbolic procedure groebmess34 mx;
if !*trgroeb then
<< terpri();prin2 " sum of weight vector ";print mx;terpri() >>;

symbolic procedure groebmess35 omega;
if !*trgroeb then
<< terpri();prin2 " next weight vector ";print omega;terpri() >>;

symbolic procedure groebmess36 tt;
if !*trgroeb then
<< terpri();prin2 " new weight : ";print tt >>;

symbolic procedure groebmess37 s;
if !*trgroeb then
<< if not s then prin2 " NOT ";prin2 " taking initials ";
 terpri();terpri() >>;

symbolic procedure printbl();printb(linelength nil #- 2);

symbolic procedure printb n;<< for i := 1 : n do prin2 "-";terpri() >>;

symbolic procedure vdpprintset l;
if l then << prin2 " { ";vdpprin2 car l;
 for each x in cdr l do << prin2 ";";vdpprin2 x >>;
 prin2t " } " >>;

symbolic procedure vdpprin2l u;
<< prin2 "(";vdpprin2 car u;
 for each x in cdr u do << prin2 ",";vdpprin2 x >>;rin2 ")" >>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/groebner/groebner.bib0000644000175000017500000001202311526203062024566 0ustar  giovannigiovanni% Bibliography for groebner.tex

@INPROCEEDINGS{AG:98,
 AUTHOR = "Beatrice Amrhein and Oliver Gloor",
 TITLE  = {The Fractal Walk},
 CROSSREF = {GB:98},
 PAGES = {305 --322},
 YEAR  = 1998}

@INPROCEEDINGS{AGK:961,
 AUTHOR = "Beatrice Amrhein and Oliver Gloor and Wolfgang Kuechlin",
 TITLE = {How Fast Does the Walk Run?},
 CROSSREF = {RW:96},
 PAGES = {8.1 -- 8.9},
 YEAR = 1996}

@INPROCEEDINGS{AGK:962,
 AUTHOR = "Beatrice Amrhein and Oliver Gloor and Wolfgang Kuechlin",
 TITLE = {Walking Faster},
 CROSSREF = {DISCO:96},
 PAGES = {150 --161},
 YEAR = 1996}

@BOOK{BeWei:93,
 AUTHOR = "Thomas Becker and Volker Weispfenning",
 TITLE = "{G}r{\"o}bner Bases",
 PUBLISHER = "Springer", YEAR = 1993}

@ARTICLE{Boege:86,
 AUTHOR = "W. Boege and R. Gebauer and H. Kredel",
 TITLE = "Some Examples for Solving Systems of Algebraic Equations
by Calculating {G}r{\"o}bner Bases",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1986, VOLUME = 2, NUMBER = 1, PAGES = "83-98", MONTH = "March"}

@INCOLLECTION{Buchberger:85,
 AUTHOR = "Bruno Buchberger",
 TITLE = "{G}r{\"o}bner Bases: An Algorithmic Method in Polynomial Ideal Theory",
 EDITOR = "N. K. Bose",
 BOOKTITLE = "Progress, directions and open problems in multidimensional
systems theory",
 PAGES = "184-232",
 PUBLISHER = "Dordrecht: Reidel",
 YEAR = 1985}

@INCOLLECTION{Buchberger:88,
 AUTHOR = "Bruno Buchberger",
 TITLE = "Applications of {G}r{\"o}bner bases in Non-Linear Computational
Geometry",
 EDITOR = "R. Janssen",
 BOOKTITLE = "Trends in Computer Algebra",
 PAGES = "52-80",
 PUBLISHER = "Berlin, Heidelberg", YEAR = 1988}

@PROCEEDINGS{GB:98,
 TITLE = {Gr\"obner Bases and Applications},
 BOOKTITLE = {Gr\"obner Bases and Applications},
 SUBTITLE = {Int.\ Conf.\ ``33 Years of Gr\"obner Bases''},
 YEAR = {1998},
 EDITOR = {Bruno Buchberger an Franz Winkler},
 PUBLISHER = {Cambridge University Press},
 SERIES = {LMS},
 VOLUME = 251,
 MONTH = Feb}

@PROCEEDINGS{RW:96,
 TITLE = {5th Rhine Workshop on Computer Algebra},
 BOOKTITLE = {5th Rhine Workshop on Computer Algebra},
 YEAR = {1996},
 EDITOR = {Alain Carriere and Louis Remy Oudin},
 PUBLISHER = {Institut Franco--Allemand de Recherches de Saint--Louis},
 VOLUME = {PR 801/96},
 MONTH = Jan}
 
@PROCEEDINGS{DISCO:96,
 TITLE = {Design and Implementation of Symbolic Computation Systems},
 BOOKTITLE = {Design and Implementation of Symbolic Computation Systems},
 SUBTITLE = {International Symposium, DISCO 1996},
 YEAR = {1996},
 EDITOR = {J. Calmet and C. Limongelli},
 PUBLISHER = {Springer},
 SERIES = {Lecture Notes in Computer Science},
 VOLUME = 1128}

@ARTICLE{CKM:97,
 AUTHOR = "S. Collart and M. Kalkbrener and D. Mall",
 TITLE = {Converting Bases with the {G}r\"obner Walk},
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1997,
 VOLUME = 24,
 PAGES =  "465 - 469"}

@BOOK{Davenport:88a,
 AUTHOR = "James H. Davenport and Yves Siret and Evelyne Tournier",
 TITLE = {Computer Algebra, Systems and Algorithms for Algebraic
Computation},
 PUBLISHER = "Academic Press",
 PRINTING = "2nd",
 YEAR = 1989}

@INCOLLECTION{Ebert:81,
 AUTHOR = "K. H. Ebert and P. Deuflhard",
 EDITOR = "W. Jaeger",
 TITLE = {Modelling of Chemical Reaction Systems},
 PUBLISHER = "Springer Verlag",
 BOOKTITLE = "Springer Ser. Chem. Phys",
 VOLUME = 18,
 YEAR = 1981}

@TECHREPORT{Faugere:89,
 AUTHOR = "J. C. Faug{\`e}re and P. Gianni and  D. Lazard and T. Mora",
 TITLE = {Efficient Computation of Zero-Dimensional {G}r\"obner Bases by
Change of Ordering},
 YEAR = 1989}

@ARTICLE{Gebauer:88,
 AUTHOR = "R{\"u}diger Gebauer and H. Michael M{\"o}ller",
 TITLE = "On an Installation of {B}uchberger's Algorithm",
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1988,
 VOLUME = 6,
 NUMBER = "2 and 3",
 PAGES = "275-286"}

@TECHREPORT{Hillebrand:99,
 AUTHOR = "Dietmar Hillebrand",
 TITLE = {Triangulierung nulldimensionaler {I}deale - {I}mplementierung und
{V}ergleich zweier {A}lgorithmen - in {G}erman . {D}iplomarbeit im {S}tudiengang
{M}athematik der {U}niversit{\"a}t {D}ortmund. {B}etreuer: Prof. {D}r. {H}. {M}.
{M}{\"o}ller}, YEAR = 1999}

@ARTICLE{Kredel:88,
 AUTHOR = "Heinz Kredel",
 TITLE = {Admissible termorderings used in Computer Algebra Systems},
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1988,
 VOLUME = 22,
 NUMBER = 1,
 PAGES = "28-31",
 MONTH = "January"}

@ARTICLE{Kredel:88a,
 AUTHOR = "Heinz Kredel and Volker Weispfenning",
 TITLE = {Computing Dimension and Independent Sets for Polynomial Ideals},
 JOURNAL = "J. Symbolic Computation",
 YEAR = 1988,
 VOLUME = 6,
 NUMBER = 1,
 PAGES = "231-247",
 MONTH = "November"}

@TECHREPORT{Melenk:88,
 AUTHOR = "Herbert Melenk and H. Michael M{\"o}ller and Winfried Neun",
 TITLE = "On {G}r{\"o}bner Bases Computation on a Supercomputer Using {REDUCE}",
 INSTITUTION = "Konrad-Zuse-Zentrum f{\"u}r Informationstechnik Berlin",
 YEAR = 1988,
 TYPE = "Preprint",
 NUMBER = "SC 88-2",
 MONTH = "January"}

@INPROCEEDINGS{Giovini:91,
 AUTHOR = "A. Giovini and T. Mora and G. Niesi and L. Robbiano and C. Traverso",
 TITLE = "One sugar cube, please OR Selection strategies in the
   {B}uchberger algorithm",
 BOOKTITLE = "Proc. of {ISSAC} '91",
 YEAR = 1991,
 PAGES = "49-55"}

mathpiper-0.81f+svn4469+dfsg3/src/packages/qsum/0000755000175000017500000000000011722677355021513 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/qsum/qsum.tex0000644000175000017500000007763111526203062023216 0ustar  giovannigiovanni\documentstyle[11pt, amsfonts, reduce, alltt]{article}

\title{{\tt QSUM}\\A Package for the Indefinite\\ and Definite Summation\\
of \textsl{q}-hypergeometric Terms}
\date{}
\author{Harald B\"oing\\
	Wolfram Koepf\\
	\\
	Konrad Zuse Zentrum f\"ur Informationstechnik Berlin \\
	Takustr.\ 7 \\
	D-14195 Berlin-Dahlem \\
	\\
	email: {\tt  koepf@zib.de}
}

%%\input{amssym.def}
\newcommand{\N} {\Bbb N}
\newcommand{\Z}{\Bbb Z}

\newcommand{\funkdef}[3]{\left\{\!\!\!\begin{array}{cc}
                                #1 & \!\!\!\mbox{\rm{if} $#2$ } \\
                                #3 & \!\!\!\mbox{\rm{otherwise}}
                                \end{array}
                         \right.}
\newcommand{\funkdefff}[6]{\left\{\begin{array}{ccc}
                                 #1 && \mbox{{if} $#2$ } \\
                                 #3 && \mbox{{if} $#4$ } \\
                                 #5 && \mbox{{if} $#6$ }
                                 \end{array}
                          \right.}

\newcommand{\qphihyp}[5]{{}_{#1}\phi_{#2}\left.\left[\begin{array}{c}
	#3 \\ #4 \end{array}\right|q,#5\right]}
\newcommand{\qpsihyp}[5]{{}_{#1}\psi_{#2}\left.\left[\begin{array}{c}
	#3 \\ #4 \end{array}\right|q,#5\right]}
\newcommand{\hyp}[5]{{}_{#1}F_{#2}\left.\left[\begin{array}{c}
	#3 \\ #4 \end{array}\right|#5\right]}

\newcommand{\fcn}[2]{{\mathrm #1}(#2)}
\newcommand{\ifcn}[3]{{\mathrm #1}_{#2}(#3)}
\newcommand{\qgosper}{$q$-Gosper\ }
\newcommand{\qgosperalg}{\qgosper algorithm\ }
\newcommand{\qzeilalg}{$q$-Zeilberger algorithm\ }
\newcommand{\qfac}[2]{\left(#1;\,q\right)_{#2}}
\newcommand{\qatom}[1]{\left(#1;\,q\right)_{\infty}}
%\newcommand{\qbinomial}[2]{\left(\begin{array}{c}#1\\#2\end{array}\right)_q}
%\newcommand{\binomial}[2]{\left(\begin{array}{c}#1\\#2\end{array}\right)}
\newcommand{\binomial}[2]{{#1 \choose #2}}
\newcommand{\qbinomial}[2]{{{#1 \choose #2}\!}_q}
\newcommand{\qfactorial}[2]{}

\newcounter{redprompt}
{\setcounter{redprompt}{0}}
\newcommand{\redprompt}{\stepcounter{redprompt}\theredprompt:}
\newenvironment{redoutput}{\small\begin{alltt}}{\end{alltt}\noindent{}}

% ----------------------------------------------------------------------

\begin{document}
%
\maketitle
%
\section{Introduction}

This package is an implementation of the $q$-analogues of Gosper's
and Zeil\-berger's%
%
\footnote{The {\tt ZEILBERG} package (see \cite{Koepf2})
contains the hypergeometric versions. Those algorithms are described in 
\cite{Gosper},\cite{hyper_Zeilberger1},\cite{hyper_Zeilberger2}
and \cite{Koepf1}.}
%
algorithm for indefinite, and definite summation of
$q$-hypergeo\-metric terms, respectively.

An expression $a_k$ is called a {\sl $q$-hypergeometric term}, if
$a_{k}/a_{k-1}$ is a rational function with respect to $q^k$. Most
$q$-terms are based on the {\sl $q$-shifted factorial} or 
{\sl qpochhammer}. Other typical $q$-hypergeometric terms are ratios 
of products of powers, $q$-factorials, $q$-binomial coefficients, and 
$q$-shifted factorials that are integer-linear in their arguments.

% ----------------------------------------------------------------------

\section{Elementary \textsl{q}-Functions}
Our package supports the input of the following elementary 
$q$-functions:
\begin{itemize}
%
\item {\verb@qpochhammer(a,q,infinity)@}\[
	\qfac{a}{\infty}:= \prod_{j=0}^{\infty}{\left(1-a\,q^j\right)}
	\]
\item {\verb@qpochhammer(a,q,k)@} \[
	\qfac{a}{k}:= \funkdefff{\prod_{j=0}^{k-1}{\left(1-a\,q^j\right)}}%
		{k>0}{1}{k=0}{\prod_{j=1}^{k}{\left(1-a\,q^{-j}\right)^{-1}}}{k<0}
	\]
\item {\verb@qbrackets(k,q)@}
	\[  {}[q,k]:=\frac{q^k-1}{q-1}  \]
\item {\verb@qfactorial(k,q)@}
	\[   {}[k]_q!:= \frac{\qfac{q}{k}}{(1-q)^k}  \]
\item {\verb@qbinomial(n,k,q)@}
	\[  \qbinomial{n}{k}:=
		\frac{\qfac{q}{n}}{\qfac{q}{k}\cdot\qfac{q}{n-k}} \]
\end{itemize}

Furthermore it is possible to use an abbreviation for the
{\sl generalized $q$-hypergeometric series}
({\sl basic generalized hypergeometric series}, 
see e.\,g.\ \cite{GasperRahman}, Chapter 1) which is defined as:
\begin{eqnarray*}
	\qphihyp{r}{s}{a_1,a_2,\ldots,a_r}{b_1,b_2,\ldots,b_s}{z}:= 
	\hspace{15em}\\ \hspace{10em}
	\sum_{k=0}^{\infty}{\frac{\qfac{a_1,a_2,\ldots,a_r}{k}}
	{\qfac{b_1,b_2,\ldots,b_s}{k}}
	\,\frac{z^k}{\qfac{q}{k}}\,\left[(-1)^k\,
	q^{\binomial{k}{2}}\right]^{1+s-r}}
\end{eqnarray*}
where $\qfac{a_1,a_2,\ldots,a_r}{k}$ is a short form to write the
product $\prod_{j=1}^r{\qfac{a_j}{k}}$. An ${}_r\phi_s$ series
terminates if one of its numerator parameters is of the form
$q^{-n}$ with $n\in\N$. The additional factor
$\left[(-1)^k\,q^{\binomial{k}{2}}\right]^{1+s-r}$ (which does not
occur in the corresponding definition of the {\sl generalized
hypergeometric function}) is due to a {\sl confluence process}.
With this factor one gets the simple formula:
\[
	\lim_{a_r\rightarrow\infty}{\qphihyp{r}{s}{a_1,a_2,\ldots,a_r}
	{b_1,b_2,\ldots,b_s}{z}} = 
	{\qphihyp{r-1}{s}{a_1,a_2,\ldots,a_{r-1}}{b_1,b_2,\ldots,b_s}{z}}.
\]
Another variation is the {\sl bilateral basic hypergeometric
series} (see e.\,g.\ \cite{GasperRahman}, Chapter 5) that is defined as
\[
	\qpsihyp{r}{s}{a_1,a_2,\ldots,a_r}{b_1,b_2,\ldots,b_s}{z}:=
	\sum_{k=-\infty}^{\infty}{\frac{\qfac{a_1,a_2,\ldots,a_r}{k}}
	{\qfac{b_1,b_2,\ldots,b_s}{k}}\,z^k\,
	\left[(-1)^k\,q^{\binomial{k}{2}}\right]^{s-r}}.
\]
The \textsl{summands} of those generalized $q$-hypergeometric series may
be entered by
\begin{itemize}
	\item {\protect\verb-qphihyperterm({a1,a2,...,a3},{b1,b2,...,b3},q,z,k)-}
		and
	\item {\protect\verb-qpsihyperterm({a1,a2,...,a3},{b1,b2,...,b3},q,z,k)-}
\end{itemize}
respectively.

% ----------------------------------------------------------------------

\section{\textsl{q}-Gosper Algorithm}
\label{qgosper}

The \qgosperalg \cite{Koornwinder} is a {\sl decision procedure}, that
decides by algebraic calculations whether or not a given 
$q$-hypergeometric term $a_k$ has a $q$-hypergeometric term 
antidifference $g_k$, i.\,e.\ $a_k=g_{k}-g_{k-1}$ with 
$g_{k}/g_{k-1}$ rational in $q^k$. The ratio $g_k/a_k$ is also rational
in $q^k$ --- an important fact which makes the 
\textsl{rational certification} (see \S~\ref{qzeilberger}) of Zeilberger's
algorithm possible. If the procedure is successful
it returns $g_k$, in which case we call $a_k$ 
{\sl $q$-Gosper-summable}. Otherwise
{\sl no $q$-hypergeometric antidifference exists}. Therefore
if the \qgosperalg does not return a $q$-hypergeometric antidifference,
it has {\sl proved} that no such solution exists, an information
that may be quite useful and important. 

Any antidifference is uniquely determined up to a constant, and is
denoted by
\[
g_k=\sum a_k\,\delta_k
\;.
\]
Finding $g_k$ given $a_k$ is called {\sl indefinite summation}.
The antidifference operator $\Sigma$ is the inverse of the downward 
difference operator $\nabla a_k=a_{k}-a_{k-1}$. There is an analogous
summation theory corresponding to the upward difference operator 
$\Delta a_k=a_{k+1}-a_k$.

In case, an antidifference $g_k$ of $a_k$ is known, any sum
$\sum_{k=m}^n{a_k}$ can be easily calculated by an evaluation of 
$g$ at the boundary points like in the integration case:
\[
	\sum_{k=m}^{n}{a_k} = g_{n}-g_{m-1}
\]


% ======================================================================

\section{\textsl{q}-Zeilberger Algorithm}
\label{qzeilberger}

The $q$-Zeilberger algorithm \cite{Koornwinder}
deals with the {\sl definite summation} of 
$q$-hyper\-geo\-metric terms $\fcn{f}{n,k}$ wrt.\ $n$ and $k$:
\[
	\fcn{s}{n}:= \sum_{k=-\infty}^\infty{\fcn{f}{n,k}}
\]
Zeilberger's idea is to use Gosper's algorithm to find an
inhomogeneous recurrence equation with polynomial coefficients
for $\fcn{f}{n,k}$ of the form
\begin{equation} \label{eq:f_n_k-recursion}
	\sum_{j=0}^J{\ifcn{\sigma}{j}{n}\cdot \fcn{f}{n+j,k}} = 
	\fcn{g}{k}-\fcn{g}{k-1},
\end{equation}
where $\fcn{g}{k}/\fcn{f}{k}$ is rational in $q^k$ and $q^n$.
Assuming finite support of $\fcn{f}{n,k}$ wrt.\ $k$
(i.\,e. $\fcn{f}{n,k}=0$ for any $n$ and all sufficiently large $k$)
we can sum equation (\ref{eq:f_n_k-recursion}) over all $k\in\Z$.
Thus we receive a homogeneous recurrence equation with polynomial
coefficients (called {\sl holonomic equation}) for $\fcn{s}{n}$:
\begin{equation} \label{holonomic_recurrence}
	\sum_{j=0}^J{\ifcn{\sigma}{j}{n}\cdot \fcn{s}{n+j}} = 0
\end{equation}
%
At this stage the implementation assumes that the summation
bounds are infinite and the input term has finite support wrt.\ $k$.
If those input requirements are not fulfilled the resulting 
recursion is probably not valid. Thus we strongly advise the user to 
check those requirements.

Despite this restriction you may still be able to get valuable
information by the program: On request it returns the
left hand side of the recurrence equation (\ref{holonomic_recurrence})
\textsl{and} the antidifference $\fcn{g}{k}$ of equation
(\ref{eq:f_n_k-recursion}). 

Once you have the certificate $\fcn{g}{k}$ it is trivial
(at least theoretically) to prove equation (\ref{holonomic_recurrence})
as long as the input requirements are fulfilled. Let's assume
somone gives us equation (\ref{eq:f_n_k-recursion}). If we divide
it by $\fcn{f}{n,k}$ we get a rational identity (in $q^n$ and $q^k$) 
---due to the fact that $\fcn{g}{k}/\fcn{f}{n,k}$ is rational in 
$q^n$ and $q^k$. Once we confirmed this identity we sum equation
(\ref{eq:f_n_k-recursion}) over $k\in\Z$:
\begin{equation}
	\sum_{k\in\Z}\sum_{j=0}^J{\ifcn{\sigma}{j}{n}\cdot \fcn{f}{n+j,k}} = 
	\sum_{k\in\Z}{\left(\fcn{g}{k}-\fcn{g}{k-1}\right)},
\end{equation}
Again we exploit the
fact that $\fcn{g}{k}$ is a rational multiple of $\fcn{f}{n,k}$ and thus
$\fcn{g}{k}$ has \textsl{finite support} which makes the telescoping sum
on the right hand side vanish. If we exchange the order of summation we
get equation (\ref{holonomic_recurrence}) which finishes the proof. 


Note that we may relax the requirements for $\fcn{f}{n,k}$:
An infinite support is possible as long as 
$\lim\limits_{k\rightarrow\infty}{\fcn{g}{k}}=0$. 
(This is certainly true if 
$\lim\limits_{k\rightarrow\infty}{\fcn{p}{k}\,\fcn{f}{k}}=0$ for
all polynomials $\fcn{p}{k}$.)

For a quite general class of $q$-hypergeometric terms 
({\sl proper q-hypergeometric terms}) the \qzeilalg
always finds a recurrence equation, not necessarily of lowest
order though. Unlike Zeilberger's original algorithm its
$q$-analogue more often fails to determine the recursion of
lowest possible order, however (see \cite{Paule1}).

If the resulting recurrence equation is of first order
\[
	\fcn{a}{n}\,\fcn{s}{n-1}+\fcn{b}{n}\,\fcn{s}{n}=0
\;,
\]
$\fcn{s}{n}$ turns out to be a $q$-hypergeometric term
(as a and b are polynomials in $q^n$),
and a $q$-hypergeometric solution can be easily established using a 
suitable initial value.

If the resulting recurrence equation has order larger than one, 
this information can be used for identification purposes:
Any other expression satisfying the same recurrence equation, and the same
initial values, represents the same function.

Our implementation is mainly based on \cite{Koornwinder} and on the
hypergeometric analogue described in \cite{Koepf1}. 
More examples can be found in \cite{GasperRahman}, \cite{Gasper},
some of which are contained in the test file 
{\tt qsum.tst}.

% ======================================================================

\section{\REDUCE{} operator {\tt QGOSPER}}
\label{reduce_qgosper}

The QSUM package must be loaded by:

\begin{redoutput}
\redprompt load qsum;
\end{redoutput}
The {\tt qgosper} operator is an implementation of the $q$-Gosper
algorithm.
\begin{itemize}
	\item {\verb@qgosper(a,q,k)@} determines a $q$-hypergeometric
		antidifference. (By default it returns a {\sl downward}
		antidifference, which may be changed by the switch 
		{\verb@qgosper_down@}; see also 
		\S~\ref{switches}.)
		If it does not return a \textsl{q}-hypergeometric antidifference,
		then such an antidifference does not exist.
	\item {\verb@qgosper(a,q,k,m,n)@} determines a closed formula
		for the definite sum $\sum\limits_{k=m}^n a_k$ using the
		$q$-analogue of Gosper's algorithm. 
		This is only successful if \textsl{q}-Gosper's algorithm applies.
\end{itemize}

{\bf Examples}: The following two examples can be found in 
	\cite{GasperRahman} ((II.3) and (2.3.4)).

\begin{redoutput}
\redprompt qgosper(qpochhammer(a,q,k)*q^k/qpochhammer(q,q,k),q,k);

   k
 (q *a - 1)*qpochhammer(a,q,k)
-------------------------------
  (a - 1)*qpochhammer(q,q,k)

\redprompt qgosper(qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*
   qpochhammer(q^(-n),q,k)*q^(n*k)/(qpochhammer(a,q^2,k)*
   qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k)),q,k);

     k*n   k          k    n               1
( - q   *(q *a - 1)*(q  - q )*qpochhammer(----,q,k)
                                            n
                                           q

                 2  2                           2*k          n
 *qpochhammer(a*q ,q ,k)*qpochhammer(a,q,k))/((q   *a - 1)*(q  - 1)

               n                         2
 *qpochhammer(q *a*q,q,k)*qpochhammer(a,q ,k)*qpochhammer(q,q,k))
\end{redoutput}

Here are some other simple examples:
\begin{redoutput}
\redprompt qgosper(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k),q,k);

***** No q-hypergeometric antidifference exists. 

\redprompt off qgosper_down;

\redprompt qgosper(q^k*qbrackets(k,q),q,k);

     k           k
  - q *(q + 1 - q )*qbrackets(k,q)
-----------------------------------
       k
     (q  - 1)*(q + 1)*(q - 1)

\redprompt on qgosper_down;

\redprompt qgosper(q^k,q,k,0,n);

  n
 q *q - 1
----------
  q - 1
\end{redoutput}
\vspace{-2ex}%
% ----------------------------------------------------------------------
%
\section{\REDUCE{} operator {\tt QSUMRECURSION}}
\label{reduce_qsumrecursion}

The {\tt qsumrecursion} operator is an implementation of the
$q$-Zeilberger algorithm.
It tries to determine a homogeneous recurrence equation for 
$\fcn{summ}{n}$ wrt. $n$ with polynomial coefficients (in $n$), where
%
\[
	\fcn{summ}{n}:= \sum_{k=-\infty}^{\infty}{\fcn{f}{n,k}}.
\]
%
If successful the left hand side of the recurrence equation 
(\ref{holonomic_recurrence}) is returned.

There are three different ways to pass a summand $\fcn{f}{n,k}$
to {\verb@qsumrecursion@}:
%
\begin{itemize}
	\item {\verb@qsumrecursion(f,q,k,n)@}, where {\tt f} is a
		$q$-hypergeometric term wrt. {\tt k} and {\tt n},
		{\tt k} is the summation variable and {\tt n} the recursion
		variable, {\tt q} is a symbol.
	\item {\verb@qsumrecursion(upper,lower,q,z,n)@} is a shortcut for \\
		{\verb@qsumrecursion(qphihyperterm(upper,lower,q,z,k),q,k,n)@}
	\item {\verb@qsumrecursion(f,upper,lower,q,z,n)@} is a similar 
		shortcut for\\
		{\verb@qsumrecursion(f*qphihyperterm(upper,lower,q,z,k),q,k,n)@},
\end{itemize}
%
i.\,e.\ {\tt upper} and {\tt lower} are lists of upper and lower
parameters of the generalized $q$-hypergeometric function.
The third form is handy if you have any additional factors.

For all three instances the following variations are allowed:
\begin{itemize}
	\item If for some reason the recursion order is known in
		advance you can specify it as an additional ({\sl optional}\,)
		argument at the very end of the parameter sequence. There are two
		ways. If you just specify a positive integer, 
		{\tt qsumrecursion} looks only for a recurrence equation of this order.
		You can also specify a range by a list of two positive integers,
		i.\,e.\ the first one specifying the lowest and the second one the
		highest order.

		By default {\tt qsumrecursion} will search for recurrences
		of order from 1 to 5. (The global variable 
		{\verb@qsumrecursion_recrange!*@} controls this behavior,
		see \S~\ref{switches}.)
	\item Usually {\tt qsumrecursion} uses {\tt summ} as a name
		for the $\mathrm{summ}$-function defined above. If you want
		to use another operator, say e.\,g. {\tt s}, then the
		following syntax applies: {\verb@qsumrecursion(f,q,k,s(n))@}
\end{itemize}

As a first example we want to consider the {\sl q-binomial theorem}:
\[
	\sum_{k=0}^\infty{\frac{\qfac{a}{k}}{\qfac{q}{k}}z^k} =
	\frac{\qfac{a\,z}{\infty}}{\qfac{z}{\infty}},
\]
provided that $|z|,|q|<1$.
It is the $q$-analogue of the binomial theorem in the sense that
\[
	\lim_{q\rightarrow{}1^-}\;{\sum_{k=0}^\infty{
	\frac{\qfac{q^a}{k}}{\qfac{q}{k}}z^k}} \;\;=\;\; 
	\sum_{k=0}^\infty{\frac{(a)_k}{k!}z^k} \;\;=\;\; (1-z)^{-a}\;.
\]
For $a:=q^{-n}$ with $n\in\N$ our implementation gets:
\begin{redoutput}
\redprompt qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/
   qpochhammer(q,q,k),q,k,n);

      n                     n
 - ((q  - z)*summ(n - 1) - q *summ(n))
\end{redoutput}
%
Notice that the input requirements are fulfilled. For $n\in\N$ the
summand is zero for all $k>n$ as $\qfac{q^{-n}}{k}=0$ and 
the $\qfac{q}{k}$-term in the denominator makes the summand
vanish for all $k<0$.

With the switch \verb@qsumrecursion_certificate@ it is possible
to get the antidifference $g_k$ described above. When switched
on, \verb@qsumrecursion@ returns a list with five entries,
see \S~\ref{switches}. For the
last example we get:

\begin{redoutput}
\redprompt on qsumrecursion_certificate;

\redprompt proof:= qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/
    qpochhammer(q,q,k),q,k,n);

                n                     n
proof := { - ((q  - z)*summ(n - 1) - q *summ(n)),

                k    n
            - (q  - q )*z
          ----------------,
                n
               q  - 1

            k              1
           z *qpochhammer(----,q,k)
                            n
                           q
          --------------------------,
              qpochhammer(q,q,k)

          k,

          downward_antidifference}

\redprompt off qsumrecursion_certificate;
\end{redoutput}
%
\\[-2.5ex]\noindent{}
Let's define the list entries as \verb@{rec,cert,f,k,dir}@. If you
substitute $\fcn{summ}{n+j}$ by $\fcn{f}{n+j,k}$ in \verb@rec@ then
you obtain the left hand side of equation (\ref{eq:f_n_k-recursion}),
where \verb@f@ is the input summand. The function
$\fcn{g}{k}:=\verb@f*cert@$ is the corresponding
antidifference, where \verb@dir@ states which sort of antidifference
was calculated {\tt downward\_antidifference} or 
{\tt upward\_antidifference}, see also \S~\ref{switches}.
Those informations enable you to prove the recurrence equation for
the sum or supply you with the necessary informations to determine
an inhomogeneous recurrence equation for a sum with nonnatural bounds.

For our last example we can now calculate both sides of
equation (\ref{eq:f_n_k-recursion}):

\begin{redoutput}
\redprompt lhside:= qsimpcomb(sub(summ(n)=part(proof,3),
    summ(n-1)=sub(n=n-1,part(proof,3)),part(proof,1)));

            k   k   n         n                       1
           z *(q *(q  - z) + q *(z - 1))*qpochhammer(----,q,k)
                                                       n
                                                      q
lhside := -----------------------------------------------------
                         n
                       (q  - 1)*qpochhammer(q,q,k)

\redprompt rhside:= qsimpcomb((part(proof,2)*part(proof,3)-
    sub(k=k-1,part(proof,2)*part(proof,3))));

               k    k    n       n   k                    1
            - z *((q  - q )*z - q *(q  - 1))*qpochhammer(----,q,k)
                                                           n
                                                          q
rhside := ---------------------------------------------------------
                           n
                         (q  - 1)*qpochhammer(q,q,k)

\redprompt qsimpcomb((rhside-lhside)/part(proof,3));

0
\end{redoutput}
%
\\[-2.5ex]\noindent{}
Thus we have proved the validity of the recurrence equation.

As some other examples we want to consider some generalizations
of orthogonal polynomials from the 
Askey--Wilson--scheme \cite{KoekoekSwarttouw}: The $q$-Laguerre
(3.21), $q$-Charlier (3.23) and the continuous $q$-Jacobi (3.10)
polynomials.


\begin{redoutput}
\redprompt operator qlaguerre,qcharlier;

\redprompt qsumrecursion(qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n),
    \{q^(-n)\}, \{q^(alpha+1)\}, q, -x*q^(n+alpha+1), qlaguerre(n));

           n       alpha + n   n
((q + 1 - q )*q - q         *(q *x + q))*qlaguerre(n - 1)

      alpha + n                           n
 + ((q          - q)*qlaguerre(n - 2) + (q  - 1)*qlaguerre(n))*q

\redprompt qsumrecursion(\{q^(-n),q^(-x)\},\{0\},q,-q^(n+1)/a,qcharlier(n));

      x            n       n       2*n
 - ((q *((q + 1 - q )*a + q )*q - q   )*qcharlier(n - 1)

	  x    n          n
  + q *((q  + a*q)*(q  - q)*qcharlier(n - 2) - qcharlier(n)*a*q))

\redprompt on qsum_nullspace;

\redprompt term:= qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n)*
    qphihyperterm(\{q^(-n),q^(n+alpha+beta+1),
    q^(alpha/2+1/4)*exp(I*theta), q^(alpha/2+1/4)*exp(-I*theta)\},
    \{q^(alpha+1), -q^((alpha+beta+1)/2), -q^((alpha+beta+2)/2)\}, 
    q,q,k)$

\redprompt qsumrecursion(term,q,k,n,2);
\end{redoutput}
{\footnotesize
\begin{alltt}
      n  i*theta   alpha   beta   n
 - ((q *e       *(q     *(q    *(q *(q + 1) - q) - q

               alpha + beta + n           n    beta + n
            + q                *(q + 1 - q  - q        )) - 

         (alpha + beta)/2   alpha   n                beta + n           n
        q                *(q     *(q *(q + 1) - q + q        *(q + 1 - q ))

                2*alpha + beta + 2*n
            - (q                     + q)))*(sqrt(q) + q) + 

      (2*alpha + 1)/4   2*i*theta        alpha + beta + 2*n    2
     q               *(e          + 1)*(q                   - q )

        alpha + beta + 2*n         alpha + beta + 2*n
     *(q                   - 1))*(q                   - q)*summ(n - 1) - 

     i*theta    (alpha + beta + 2*n)/2   (alpha + beta + 2*n)/2
    e       *((q                      *(q                       + q)

                  (alpha + beta + 2*n)/2
               *(q                       - q)*(sqrt(q) + q) + 

                 (2*alpha + 2*beta + 4*n + 1)/2
               (q                               + q)
\newpage
                  alpha + beta + 2*n    2     alpha + beta + n
               *(q                   - q ))*(q                 - 1)

                 n                  alpha               alpha + beta + 2*n
              *(q  - 1)*summ(n) + (q     *(sqrt(q)*q + q                  )

                     (3*alpha + beta + 2*n)/2
                  + q                        *(sqrt(q) + q))

                 alpha + beta + 2*n        alpha + n        beta + n
              *(q                   - 1)*(q          - q)*(q         - q)

              *summ(n - 2)))

\redprompt off qsum_nullspace;
\end{alltt}}

The setting of {\verb@qsum_nullspace@} 
(see \cite{Paule1} and \S~\ref{switches})
results in a faster
calculation of the recurrence equation for this example.


% ----------------------------------------------------------------------

\section{Simplification Operators}
\label{simplification}

An essential step in the algorithms introduced above is to decide
whether a term $a_k$ is $q$-hypergeometric, i.\,e.\ if the
ratio $a_{k}/a_{k-1}$ is rational in $q^k$.

The procedure \verb@qsimpcomb@ provides this facility. It tries to
simplify all exponential expressions in the given term and applies
some transformation rules to the known elementary $q$-functions
as \verb@qpochhammer@, \verb@qbrackets@, \verb@qbinomial@
and \verb@qfactorial@. Note that the procedure may fail to
completely simplify some expressions. This is due to the fact that the
procedure was designed to simplify ratios of $q$-hypergeometric
terms in the form $\fcn{f}{k}/\fcn{f}{k-1}$ and not arbitrary 
$q$-hypergeometric terms. 

E.\,g.\ an expression like 
$\qfac{a}{-n}\cdot\qfac{a/q^n}{n}$
is not recognized as 1, despite the transformation formula
\[ \qfac{a}{-n} \;=\; \frac{1}{\qfac{a/q^n}{n}},\]
which is valid for $n\in\N$.

Note that due to necessary simplification of powers, the switch
\verb@precise@ is (locally) turned off in \verb@qsimpcomb@. This
might produce wrong results if the input term contains 
e.\,g.\ complex variables.

The following synomyms may be used:
\begin{itemize}
	\item \verb@up_qratio(f,k)@ or \verb@qratio(f,k)@ for
		\verb@qsimpcomb(sub(k=k+1,f)/f)@ and
	\item \verb@down_qratio(f,k)@ for \verb@qsimpcomp(f/sub(k=k-1,f))@.
\end{itemize}

% ----------------------------------------------------------------------

\section{Global Variables and Switches}
\label{switches}

The following switches can be used in connection with
the {\tt QSUM} package:
%
\begin{itemize}
	\item \verb@qsum_trace@, default setting is off. If it is
		turned on some intermediate results are printed.
	\item \verb@qgosper_down@, default setting is on. It determines
		whether \verb@qgosper@ returns a downward or an upward
		antidifference $g_k$ for the input term $a_k$,
	   i.\,e.\ $a_k=g_k-g_{k-1}$ or $a_k=g_{k+1}-g_k$ respectively.
	\item \verb@qsumrecursion_down@, default setting is on. If it is
		switched on a downward recurrence equation will be returned by
		\verb@qsumrecursion@. Switching it off leads to an upward
		recurrence equation.
	\item \verb@qsum_nullspace@, default setting is off. The 
		antidifference $\fcn{g}{k}$ is always a rational multiple (in $q^k$)
		of the input term $\fcn{f}{k}$. \verb@qgosper@ and \verb@qsumrecursion@
		determine this certificate, which requires solving a set of
		linear equations. If the switch \verb@qsum_nullspace@ is
		turned on a modified nullspace-algorithm will be used for
		solving those equations. In general this method is slower.
		However if the resulting recurrence equation is quite complicated
		it might help to switch on \verb@qsum_nullspace@.
		See also \cite{Knuth} and \cite{Paule1}.
	\item \verb@qgosper_specialsol@, default setting is on. The
		antidifference $\fcn{g}{k}$ which is determined by 
		\verb@qgosper@ might not be unique. If this switch is turned on,
		just one special solution is returned. If you want
		to see all solutions, you should turn the switch off.
	\item \verb@qsumrecursion_exp@, default setting is off. This
		switch determines if the coefficients of the
		resulting recurrence equation should
		be factored. Turning it off might speed up the calculation
		(if factoring is complicated). Note that
		when turning on \verb@qsum_nullspace@ usually no speedup
		occurs by switching \verb@qsumrecursion_exp@ on.
	\item \verb@qsumrecursion_certificate@, default off. 
		As Zeilberger's algorithm 
		delivers a recurrence equation for a $q$-hypergeometric term
		$\mathrm{f}(n,k)$, see equation (\ref{eq:f_n_k-recursion}),
		this switch is used to get all necessary informations for
		proving this recurrence equation.

		If it is set on, instead of simply returning the 
		resulting recurrence equation (for the sum)---if one 
		exists---\verb@qsumrecursion@  returns 
		a list \verb@{rec,cert,f,k,dir}@ with
		five items: The first entry contains the
		recurrence equation, while the other items enable you to
		prove the recurrence a posteriori by rational arithmetic.

		If we denote by \verb@r@ the recurrence
		\verb@rec@ where we substituted the \verb@summ@-function
		by the input term \verb@f@ (with the corresponding shifts
		in \verb@n@) then the following equation is valid:
		\[  \verb@r = cert*f - sub(k=k-1,cert*f)@  \]
		or
		\[  \verb@r = sub(k=k+1,cert*f) - cert*f@  \]
		if \verb@dir=downward_antidifference@ or
		\verb@dir=upward_antidifference@ respectively.
\end{itemize}

The global variable \verb@qsumrecursion_recrange!*@ controls for
which recursion orders the procedure \verb@qsumrecursion@ looks.
It has to be a list with two entries, the first one representing
the lowest and the second one the highest order of a recursion
to search for. By default it is set to \verb@{1,5}@.

% ----------------------------------------------------------------------

\section{Messages}

The following messages may occur:
\begin{itemize}
%
	\item If your call to \verb@qgosper@ or \verb@qsumrecursion@
		reveals some incorrect syntax, e.\,g.\ wrong number of 
		arguments or wrong type you may receive the following messages:
		\begin{verbatim}***** Wrong number of arguments.\end{verbatim}
		or
		\begin{verbatim}***** Wrong type of arguments.\end{verbatim}
%
	\item If you call \verb@qgosper@ with a summand term that
		is free of the summation variable you get
		\begin{verbatim}
			WARNING: Summand is independent of summation variable.
			***** No q-hypergeometric antidifference exists.
		\end{verbatim}
%
%	\item It is not allowed to specify bounds in \verb@qgosper@ which
%		contain the summation variable. Otherwise you get the message:
%		\begin{verbatim}
%		***** Summation bounds contain the summation variable. 
%		\end{verbatim}
%
	\item If \verb@qgosper@ finds no antidifference it returns:
		\begin{verbatim}
		***** No q-hypergeometric antidifference exists.
		\end{verbatim}
%
	\item If \verb@qsumrecursion@ finds no recursion in the specified
		range it returns:
		\begin{verbatim}***** Found no recursion. Use higher order.\end{verbatim}
		(If you do not pass a range as an argument to \verb@qsumrecursion@
		the default range in \verb@qsumrecursion_recrange!*@ will be used.)
%
	\item If the input term passed to \verb@qgosper@ 
		(\verb@qsumrecursion@) is not $q$-hyper\-geometric wrt.\ the 
		summation variable --- say $k$ --- (and the recursion variable) 
		then you get
		\begin{verbatim}
		***** Input term is probably not q-hypergeometric.
		\end{verbatim}
		With all the examples we tested, our procedures decided properly
		whether the input term was $q$-hypergeometric or not. However, we
		cannot guarantee in general that \verb@qsimpcomb@ {\sl always} returns
		an expression that {\sl looks} rational in $q^k$ if it actually is.
%
	\item If the global variable \verb@qsumrecursion_recrange!*@ was
		assigned an invalid value:
		\begin{verbatim}
		Global variable qsumrecursion_recrange!* must be a list
		of two positive integers: {lo,hi} with lo<=hi.
		***** Invalid value of qsumrecursion_recrange!* 
		\end{verbatim}
%
\end{itemize}

% ----------------------------------------------------------------------

\begin{thebibliography}{99}

\bibitem{AskeyWilson}
% check
Askey R.\ and Wilson, J.:
{\sl Some Basic Hypergeometric Orthogonal Polynomials that Generalize Jacobi
Polynomials}. Memoirs Amer.\ Math.\ Soc.\ 319, Providence, RI, 1985.

\bibitem{Gasper}
Gasper, G.:
{\sl Lecture Notes for an Introductory Minicourse on $q$-Series}.
1995. To obtain from  
ftp://unvie6.un.or.at/siam/opsf\_new/\linebreak 00index\_by\_author.html.

\bibitem{GasperRahman}
Gasper, G.\ and Rahman, M.:
{\sl Basic Hypergeometric Series},
Encyclopedia of Mathematics and its Applications, 
{\bf 35}, (G.-C.\ Rota, ed.), Cambridge University Press,
London and New York, 1990.

\bibitem{Gosper}
Gosper Jr., R.\ W.:
Decision procedure for indefinite hypergeometric
summation. Proc.\ Natl.\ Acad.\ Sci.\ USA {\bf 75}, 1978, 40--42.

\bibitem{Knuth}
Knuth, D.\ E.:
{\sl The Art of Computer Programming, Seminumerical Algorithms}.
2nd ed., 1981, Addison-Wesley Publishing Company.

\bibitem{Koepf1}
Koepf, W.:
Algorithms for $m$-fold hypergeometric summation.
Journal of Symbolic Computation {\bf 20}, 1995, 399--417.
%(Zbl.\ Math.\ 851.68049, summary).

\bibitem{Koepf2}
Koepf, W.:
REDUCE package for indefinite and definite summation.
% Konrad-Zuse-Zentrum Berlin (ZIB), Technical Report TR 94-9, 1994.
SIGSAM Bulletin {\bf 29}, 1995, 14--30.

\bibitem{Koornwinder}
Koornwinder, T.\ H.:
On Zeilberger's algorithm and its $q$-analogue: a rigorous description.
J.\ of Comput.\ and Appl.\ Math.\ {\bf 48}, 1993, 91--111.

\bibitem{KoekoekSwarttouw}
Koekoek, R.\ und Swarttouw, R.F.:
{\sl The Askey-scheme of Hypergeometric Orthogonal
Polynomials and its $q$-analogue}. Report 94--05, Tech\-nische Universiteit
Delft, Faculty of Technical Mathematics and Informatics, Delft, 1994.


\bibitem{Paule1}
Paule, P.\ und Riese, A.:
A Mathematica \textsl{q}-analogue of Zeilberger's\linebreak[4]
algorithm based on an
algebraically motivated approach to \textsl{q}-hyper\-geometric telescoping.
Fields Proceedings of the Workshop `Special Functions, \textsl{q}-Series
and Related Topics', organized by the Fields Institute for Research in
Mathematical Sciences at Univerisity College,
12-23 June 1995, Toronto, Ontario,179--210.

\bibitem{hyper_Zeilberger1}
Zeilberger, D.:
A fast algorithm for proving terminating hypergeometric identities.
Discrete Math.\ {\bf 80}, 1990, 207--211.

\bibitem{hyper_Zeilberger2}
Zeilberger, D.:
The method of creative telescoping.
J.\ Symbolic Computation {\bf 11}, 1991, 195--204.

\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/qsum/qsum.tst0000644000175000017500000000670111526203062023216 0ustar  giovannigiovanni% Test file for the REDUCE package QSUM
%
% Copyright (c) Wolfram Koepf, Harald Boeing, Konrad-Zuse-Zentrum Berlin, 1997
%
% Implementation of the q-Gosper and q-Zeilberger algorithms
%
% Reference:
%
% Koornwinder, T. H.:
% On Zeilberger's algorithm and its q-analogue: a rigorous description.
% J. of Comput. and Appl. Math. 48, 1993, 91-111.
%
% Some examples are from
%
% Koekoek, R. and Swarttouw, R.F.:
% The Askey-scheme of Hypergeometric Orthogonal Polynomials and its q-analogue.
% Report 94-05, Technische Universiteit Delft, Faculty of Technical Mathematics
% and Informatics, Delft, 1994.
%
% Gasper, G. and Rahman, M.:
% Basic Hypergeometric Series.
% Encyclopedia of Mathematics and its Applications 35. 
% Ed. by G.-C. Rota, Cambridge University Press, London and New York, 1990.


% Results of manual qsum.tex
%
load qsum;
qgosper(qpochhammer(a,q,k)*q^k/qpochhammer(q,q,k),q,k);
qgosper(qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*
        qpochhammer(q^(-n),q,k)*q^(n*k)/(qpochhammer(a,q^2,k)*
        qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k)),q,k);
qgosper(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k)*z^n,q,k);
off qgosper_down;
qgosper(q^k*qbrackets(k,q),q,k);
on qgosper_down;
qgosper(q^k,q,k,0,n);
qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k),q,k,n);
on qsumrecursion_certificate;
proof:=qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k),q,k,n);
off qsumrecursion_certificate;
% proof of statement
lhside:= qsimpcomb(sub(summ(n)=part(proof,3),
summ(n-1)=sub(n=n-1,part(proof,3)),part(proof,1)));
rhside:= qsimpcomb((part(proof,2)*part(proof,3)-
sub(k=k-1,part(proof,2)*part(proof,3))));
qsimpcomb((rhside-lhside)/part(proof,3));
% proof done
operator qlaguerre, qcharlier;
% q-Laguerre polynomials, Koekoek, Swarttouw (3.21)
qsumrecursion(qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n),
   {q^(-n)}, {q^(alpha+1)}, q, -x*q^(n+alpha+1), qlaguerre(n));
% q-Charlier polynomials, Koekoek, Swarttouw (3.23) 
qsumrecursion({q^(-n),q^(-x)},{0},q,-q^(n+1)/a,qcharlier(n));
% continuous q-Jacobi polynomials, Koekoek, Swarttouw (3.10)
%% on qsum_nullspace;
%% term:= qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n)*
%%    qphihyperterm({q^(-n),q^(n+alpha+beta+1),
%%    q^(alpha/2+1/4)*exp(I*theta), q^(alpha/2+1/4)*exp(-I*theta)},
%%    {q^(alpha+1), -q^((alpha+beta+1)/2), -q^((alpha+beta+2)/2)},
%%     q, q, k)$
%% qsumrecursion(term,q,k,n,2);
%% off qsum_nullspace;

 
% Some more qgosper results with proof
%
% Gasper, Rahman (2.3.4)
term:=qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*qpochhammer(q^(-n),q,k)*
q^(n*k)/(qpochhammer(a,q^2,k)*qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k));

result:=qgosper(qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*
qpochhammer(q^(-n),q,k)*q^(n*k)/
(qpochhammer(a,q^2,k)*qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k)),q,k);

qsimpcomb(result-sub(k=k-1,result)-term);

% Gasper, Rahman (3.8.16)
term:=(1-a*c*q^(4*k))*(1-b/c*q^(-2*k))*qpochhammer(a,q,k)*qpochhammer(b,q,k)*
qpochhammer(q^(-3*n),q^3,k)*qpochhammer(a*c^2/b*q^(3*n),q^3,k)*q^(3*k)/
((1-a*c)*(1-b/c)*qpochhammer(c*q^3,q^3,k)*qpochhammer(a*c/b*q^3,q^3,k)*
qpochhammer(a*c*q^(3*n+1),q,k)*qpochhammer(b/c*q^(1-3*n),q,k));

result:=qgosper((1-a*c*q^(4*k))*(1-b/c*q^(-2*k))*qpochhammer(a,q,k)*
qpochhammer(b,q,k)*qpochhammer(q^(-3*n),q^3,k)*qpochhammer(a*c^2/
b*q^(3*n),q^3,k)*q^(3*k)/((1-a*c)*(1-b/c)*qpochhammer(c*q^3,q^3,k)*
qpochhammer(a*c/b*q^3,q^3,k)*qpochhammer(a*c*q^(3*n+1),q,k)*
qpochhammer(b/c*q^(1-3*n),q,k)),q,k);

qsimpcomb(result-sub(k=k-1,result)-term);

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/qsum/qsum.rlg0000644000175000017500000002162711527635055023210 0ustar  giovannigiovanniFri Feb 18 21:27:59 2011 run on win32
% Test file for the REDUCE package QSUM
%
% Copyright (c) Wolfram Koepf, Harald Boeing, Konrad-Zuse-Zentrum Berlin, 1997
%
% Implementation of the q-Gosper and q-Zeilberger algorithms
%
% Reference:
%
% Koornwinder, T. H.:
% On Zeilberger's algorithm and its q-analogue: a rigorous description.
% J. of Comput. and Appl. Math. 48, 1993, 91-111.
%
% Some examples are from
%
% Koekoek, R. and Swarttouw, R.F.:
% The Askey-scheme of Hypergeometric Orthogonal Polynomials and its q-analogue.
% Report 94-05, Technische Universiteit Delft, Faculty of Technical Mathematics
% and Informatics, Delft, 1994.
%
% Gasper, G. and Rahman, M.:
% Basic Hypergeometric Series.
% Encyclopedia of Mathematics and its Applications 35. 
% Ed. by G.-C. Rota, Cambridge University Press, London and New York, 1990.


% Results of manual qsum.tex
%
load qsum;


qgosper(qpochhammer(a,q,k)*q^k/qpochhammer(q,q,k),q,k);


   k
 (q *a - 1)*qpochhammer(a,q,k)
-------------------------------
  (a - 1)*qpochhammer(q,q,k)

qgosper(qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*
        qpochhammer(q^(-n),q,k)*q^(n*k)/(qpochhammer(a,q^2,k)*
        qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k)),q,k);


     k*n   k          k    n               1                       2  2
( - q   *(q *a - 1)*(q  - q )*qpochhammer(----,q,k)*qpochhammer(a*q ,q ,k)
                                            n
                                           q

                         2*k          n                   n
 *qpochhammer(a,q,k))/((q   *a - 1)*(q  - 1)*qpochhammer(q *a*q,q,k)

                   2
   *qpochhammer(a,q ,k)*qpochhammer(q,q,k))

qgosper(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k)*z^n,q,k);


***** No q-hypergeometric antidifference exists. 

off qgosper_down;


qgosper(q^k*qbrackets(k,q),q,k);


     k           k
  - q *(q + 1 - q )*qbrackets(k,q)
-----------------------------------
       k
     (q  - 1)*(q + 1)*(q - 1)

on qgosper_down;


qgosper(q^k,q,k,0,n);


  n
 q *q - 1
----------
  q - 1

qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k),q,k,n);


      n                     n
 - ((q  - z)*summ(n - 1) - q *summ(n))

on qsumrecursion_certificate;


proof:=qsumrecursion(qpochhammer(q^(-n),q,k)*z^k/qpochhammer(q,q,k),q,k,n);


                n                     n
proof := { - ((q  - z)*summ(n - 1) - q *summ(n)),

                k    n
            - (q  - q )*z
          ----------------,
                n
               q  - 1

            k              1
           z *qpochhammer(----,q,k)
                            n
                           q
          --------------------------,
              qpochhammer(q,q,k)

          k,

          downward_antidifference}

off qsumrecursion_certificate;


% proof of statement
lhside:= qsimpcomb(sub(summ(n)=part(proof,3),
summ(n-1)=sub(n=n-1,part(proof,3)),part(proof,1)));


            k   k   n         n                       1
           z *(q *(q  - z) + q *(z - 1))*qpochhammer(----,q,k)
                                                       n
                                                      q
lhside := -----------------------------------------------------
                         n
                       (q  - 1)*qpochhammer(q,q,k)

rhside:= qsimpcomb((part(proof,2)*part(proof,3)-
sub(k=k-1,part(proof,2)*part(proof,3))));


               k    k    n       n   k                    1
            - z *((q  - q )*z - q *(q  - 1))*qpochhammer(----,q,k)
                                                           n
                                                          q
rhside := ---------------------------------------------------------
                           n
                         (q  - 1)*qpochhammer(q,q,k)

qsimpcomb((rhside-lhside)/part(proof,3));


0

% proof done
operator qlaguerre, qcharlier;


% q-Laguerre polynomials, Koekoek, Swarttouw (3.21)
qsumrecursion(qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n),
   {q^(-n)}, {q^(alpha+1)}, q, -x*q^(n+alpha+1), qlaguerre(n));


           n       alpha + n   n
((q + 1 - q )*q - q         *(q *x + q))*qlaguerre(n - 1)

      alpha + n                           n
 + ((q          - q)*qlaguerre(n - 2) + (q  - 1)*qlaguerre(n))*q

% q-Charlier polynomials, Koekoek, Swarttouw (3.23) 
qsumrecursion({q^(-n),q^(-x)},{0},q,-q^(n+1)/a,qcharlier(n));


      x            n       n       2*n
 - ((q *((q + 1 - q )*a + q )*q - q   )*qcharlier(n - 1)

        x    n          n
     + q *((q  + a*q)*(q  - q)*qcharlier(n - 2) - qcharlier(n)*a*q))

% continuous q-Jacobi polynomials, Koekoek, Swarttouw (3.10)
%% on qsum_nullspace;
%% term:= qpochhammer(q^(alpha+1),q,n)/qpochhammer(q,q,n)*
%%    qphihyperterm({q^(-n),q^(n+alpha+beta+1),
%%    q^(alpha/2+1/4)*exp(I*theta), q^(alpha/2+1/4)*exp(-I*theta)},
%%    {q^(alpha+1), -q^((alpha+beta+1)/2), -q^((alpha+beta+2)/2)},
%%     q, q, k)$
%% qsumrecursion(term,q,k,n,2);
%% off qsum_nullspace;

 
% Some more qgosper results with proof
%
% Gasper, Rahman (2.3.4)
term:=qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*qpochhammer(q^(-n),q,k)*
q^(n*k)/(qpochhammer(a,q^2,k)*qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k));


          k*n              1                       2  2
         q   *qpochhammer(----,q,k)*qpochhammer(a*q ,q ,k)*qpochhammer(a,q,k)
                            n
                           q
term := ----------------------------------------------------------------------
                         n                         2
            qpochhammer(q *a*q,q,k)*qpochhammer(a,q ,k)*qpochhammer(q,q,k)


result:=qgosper(qpochhammer(a,q,k)*qpochhammer(a*q^2,q^2,k)*
qpochhammer(q^(-n),q,k)*q^(n*k)/
(qpochhammer(a,q^2,k)*qpochhammer(a*q^(n+1),q,k)*qpochhammer(q,q,k)),q,k);


               k*n   k          k    n               1
result := ( - q   *(q *a - 1)*(q  - q )*qpochhammer(----,q,k)
                                                      n
                                                     q

                           2  2                           2*k          n
           *qpochhammer(a*q ,q ,k)*qpochhammer(a,q,k))/((q   *a - 1)*(q  - 1)

                           n                         2
             *qpochhammer(q *a*q,q,k)*qpochhammer(a,q ,k)*qpochhammer(q,q,k))


qsimpcomb(result-sub(k=k-1,result)-term);


0


% Gasper, Rahman (3.8.16)
term:=(1-a*c*q^(4*k))*(1-b/c*q^(-2*k))*qpochhammer(a,q,k)*qpochhammer(b,q,k)*
qpochhammer(q^(-3*n),q^3,k)*qpochhammer(a*c^2/b*q^(3*n),q^3,k)*q^(3*k)/
((1-a*c)*(1-b/c)*qpochhammer(c*q^3,q^3,k)*qpochhammer(a*c/b*q^3,q^3,k)*
qpochhammer(a*c*q^(3*n+1),q,k)*qpochhammer(b/c*q^(1-3*n),q,k));


                          3*n    2
          k              q   *a*c    3                  1     3
term := (q *qpochhammer(-----------,q ,k)*qpochhammer(------,q ,k)
                             b                          3*n
                                                       q

         *qpochhammer(a,q,k)*qpochhammer(b,q,k)

                                                                       3
               6*k    2    4*k          2*k                       a*c*q    3
         *( - q   *a*c  + q   *a*b*c + q   *c - b))/(qpochhammer(--------,q ,k)
                                                                    b

                          b*q                      3*n
           *qpochhammer(--------,q,k)*qpochhammer(q   *a*c*q,q,k)
                          3*n
                         q   *c

                           3  3                2
           *qpochhammer(c*q ,q ,k)*(a*b*c - a*c  - b + c))


result:=qgosper((1-a*c*q^(4*k))*(1-b/c*q^(-2*k))*qpochhammer(a,q,k)*
qpochhammer(b,q,k)*qpochhammer(q^(-3*n),q^3,k)*qpochhammer(a*c^2/
b*q^(3*n),q^3,k)*q^(3*k)/((1-a*c)*(1-b/c)*qpochhammer(c*q^3,q^3,k)*
qpochhammer(a*c/b*q^3,q^3,k)*qpochhammer(a*c*q^(3*n+1),q,k)*
qpochhammer(b/c*q^(1-3*n),q,k)),q,k);


                3*k + 3*n    2        2*k    k + n    2*n    k          k
result := ( - (q         *a*c  - b)*(q    + q      + q   )*(q *a - 1)*(q *b - 1)

                                    3*n    2
              k    n               q   *a*c    3                  1     3
           *(q  - q )*qpochhammer(-----------,q ,k)*qpochhammer(------,q ,k)
                                       b                          3*n
                                                                 q

                                                        3*n
           *qpochhammer(a,q,k)*qpochhammer(b,q,k)*c)/((q   *a*c - b)

                                                               3
                3*n                                       a*c*q    3
             *(q   *c - 1)*(a*c - 1)*(b - c)*qpochhammer(--------,q ,k)
                                                            b

                            b*q                      3*n
             *qpochhammer(--------,q,k)*qpochhammer(q   *a*c*q,q,k)
                            3*n
                           q   *c

                             3  3
             *qpochhammer(c*q ,q ,k))


qsimpcomb(result-sub(k=k-1,result)-term);


0


end;


Time for test: 265 ms
@@@@@ Resources used: (0 2 96 1)
mathpiper-0.81f+svn4469+dfsg3/src/packages/qsum/qsum.red0000644000175000017500000020116611526203062023160 0ustar  giovannigiovannimodule qsum; % summation of q-hypergeometric terms

% Authors: Wolfram Koepf, Harald Boeing
% Version 1.0, May 1997.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

% ----------------------------------------------------------------------

share !*qsumrecursion!@sub;
lisp setq(!*qsumrecursion!@sub, list(!*redefmsg, !*echo, !*output));
lisp setq(!*redefmsg, nil);
off echo;
off output;

% ------------------------------ SWITCHES ------------------------------

switch qsum_nullspace;
switch qsum_trace;
switch qgosper_down;
switch qgosper_specialsol;

switch qsumrecursion_down;
switch qsumrecursion_exp;
switch qsumrecursion_certificate;

switch qsumrecursion_profile;
lisp setq(!*qsumrecursion_profile, nil);

lisp setq(!*qsum_nullspace, nil);
lisp setq(!*qsum_trace, nil);
lisp setq(!*qgosper_down, t);
lisp setq(!*qgosper_specialsol, t);

lisp setq(!*qsumrecursion_down, t);
lisp setq(!*qsumrecursion_exp, nil);
lisp setq(!*qsumrecursion_certificate, nil);

% ------------------------ GLOBAL VARIABLES ----------------------------

clear summ;
operator summ;
clear arbcomplex;
operator arbcomplex;

share qsumrecursion_recrange!*;
qsumrecursion_recrange!*:= {1,5};


% ======================================================================

for all x,n such that fixp(n/2) and not(lisp !*complex) let
        abs(x)^n=x^n;

% ======================================================================
% ----------------------------------------------------------------------

% BESCHREIBUNG:
%
%      new_simpexpt ist gedacht um das Fakorisieren von Exponenten
%      (bei on factor) zu verhindern.
%
%      Die alte Prozedure simpexpt wird vorher mittels
%           copyd('original_simpexpt, 'simpexpt)
%      gesichert. Anschlie"sen kann die neue Prozedur
%      mittels
%           copyd('simpexpt, 'new_simpexpt)
%      als neuer Standard gesetzt werden. Will man dies wieder
%      r"uckg"angig machen, so mu"s man die alte Prozedur mittels
%           copyd('simpexpt, 'original_simpexpt)
%      wieder als Standard defininieren.
%
%
%
%

lisp;
if null(getd 'original_simpexpt) then
        copyd('original_simpexpt, 'simpexpt);
algebraic;

% ----------------------------------------------------------------------

symbolic procedure new_simpexpt(u);
begin
        scalar !*PRECISE, !*FACTOR, !*EXP, !*MCD, !*ALLFAC, redefmode;

        % Schalte exp ein, damit die Exponenten expandiert werden.
        % Ausschalten von PRECISE um Vereinfachungen wie
        %  (x*y)^k => x^k*y^k zu erreichen.
        on EXP, MCD;  off PRECISE, ALLFAC;  % switch-setting

        if eqcar(car u, 'minus) then
                return multsq(original_simpexpt({{'minus,1},cadr(u)}),
                        new_simpexpt({cadar(u),cadr(u)}));

        % Rufe zun"achst die Original-Prozedur auf...
        % Da diese rekursive programmiert ist, kann sie sich selber wieder
        % aufrufen, so da"s sie zun"achst wieder als Standard
        % wiederherzustellen ist.
        % Zudem ist zu verhindern, da"s Warning-messages
        % Function has been redefined erscheinen...
        redefmode:= !*redefmsg;
        !*redefmsg:= nil;
        copyd('simpexpt, 'original_simpexpt);

        u:= simpexpt u;

        copyd('simpexpt, 'new_simpexpt);

        !*redefmsg:= redefmode;

        return u;
end;

% ----------------------------------------------------------------------
%  ----------------------------------------------------------------------

% some compatibility functions for Maple sources.
% by Winfried Neun

put('PolynomQQ,'psopfn,'polynomQQQ);

algebraic procedure polynomq4(expr1,k);
begin scalar !*exp;
on exp;
return polynomqq(expr1,k);
end;


% checks if expr is rational in var
algebraic procedure type_ratpoly(expr1,var);
begin
scalar deno, nume;
deno:=den expr1;
nume:=num expr1;
  if (PolynomQQ (deno,var) and PolynomQQ (nume,var))
    then return t else return nil;
end;
flag ('(type_ratpoly),'boolean);

symbolic procedure tttype_ratpoly(u,xx);
  ( if fixp xx then t else
        if not eqcar (xx , '!*sq) then  nil
          else and(polynomQQQ(list(mk!*sq (numr cadr xx ./ 1),
                                  reval cadr u))
                 ,polynomQQQ(list(mk!*sq (denr cadr xx ./ 1),
                                  reval cadr u)))
 ) where xx = aeval(car u);

flag ('(tttype_ratpoly),'boolean);

%checks if x is polynomial in var
symbolic procedure PolynomQ (x,var);

 if not fixp denr simp x then NIL else
 begin scalar kerns,kern,aa;

 kerns:=kernels !*q2f simp x;

 aa: if null kerns then return T;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end;

flag('(PolynomQ),'opfn);

flag ('(PolynomQ type_ratpoly),'boolean);


symbolic procedure PolynomQQQ (x);

(if fixp xx then t else
 if not onep denr (xx:=cadr xx) then NIL
 else begin scalar kerns,kern,aa,var,fform,mvv,degg;

 fform:=sfp  mvar  numr xx;
 var:=reval cadr x;
 if fform then << xx:=numr xx;
    while (xx neq 1) do
     << mvv:=mvar  xx;
        degg:=ldeg  xx;
        xx:=lc  xx;
        if domainp mvv then <> >> else
        kerns:=append ( append (kernels mvv,kernels degg),kerns) >> >>
   else kerns:=kernels !*q2f xx;

 aa: if null kerns then return T;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end) where xx = aeval(car x);

put('PolynomQQ,'psopfn,'polynomQQQ);

symbolic procedure ttttype_ratpoly(u);
  ( if fixp xx then t else
        if not eqcar (xx , '!*sq) then nil
          else and(polynomQQQ(list(mk!*sq (numr cadr xx ./ 1), reval cadr u))
                  ,polynomQQQ(list(mk!*sq (denr cadr xx ./ 1), reval cadr u)))
 ) where xx = aeval(car u);

flag ('(type_ratpoly),'boolean);

put('type_ratpoly,'psopfn,'ttttype_ratpoly);


% ----------------------------------------------------------------------
% ----------------------------------------------------------------------

symbolic procedure start;
begin
        return (profile_time!*:= {'list, time(), gctime()});
end$

symbolic operator start;

% ----------------------------------------------------------------------

symbolic procedure stop;
begin
        scalar gct, cput;
        gct:= gctime() - caddr(profile_time!*);
        cput:= time() - cadr(profile_time!*) - gct;
        return {'list, cput, gct};
end$

symbolic operator stop;

% ----------------------------------------------------------------------

symbolic procedure showprofile;
begin
        scalar tim;
        prin2 "CPU: ";
        tim:= time() - cadr(profile_time!*);
        prin2 tim;
        tim:= gctime() - caddr(profile_time!*);
        if (tim=0) then return terpri();
        prin2 " ,  GC: ";
        prin2 tim;
        terpri();
end$

symbolic operator showprofile;

% ----------------------------------------------------------------------

operator timing!-cpu!+gc!*, timing!-gc!*;

algebraic procedure timing(n);
begin
        if (n=start) then return <>;
        if numberp(timing!-cpu!+gc!*(n)) then <<
                timing!-gc!*(n):= (lisp gctime()) - timing!-gc!*(n);
                timing!-cpu!+gc!*(n):= (lisp time()) - timing!-cpu!+gc!*(n);
        >> else <<
                timing!-gc!*(n):= (lisp gctime());
                timing!-cpu!+gc!*(n):= (lisp time());
        >>;
        return {timing!-cpu!+gc!*(n)-timing!-gc!*(n), timing!-gc!*(n)};
end$

% ----------------------------------------------------------------------

algebraic procedure showtiming(n);
        {timing!-cpu!+gc!*(n)-timing!-gc!*(n), timing!-gc!*(n)};

% ----------------------------------------------------------------------

algebraic procedure showcputiming(n);
        timing!-cpu!+gc!*(n) - timing!-gc!*(n);

% ----------------------------------------------------------------------

algebraic procedure showgctiming(n);
        timing!-gc!*(n);

% ----------------------------------------------------------------------
% ======================================================================

symbolic procedure product2list(term);
begin
        scalar !*FACTOR, !*EXP, !*LIMITEDFACTORS, !*MCD, l, z;
        on FACTOR, MCD;  off LIMITEDFACTORS;  % switch-setting
        term:= simp aeval(term);
        z:= numr term;
        l:= {};
        while pairp(z) and (red(z) eq nil) do begin
                l:= mk!*sq(((((mvar(z) . ldeg(z)) . 1) . nil)) . 1) . l;
                z:= lc(z);
        end;
        if not eqn(z,1) then l:= mk!*sq(z . 1) . l;
        z:= denr term;
        while pairp(z) and (red(z) eq nil) do begin
                l:= mk!*sq(((((mvar(z) . -ldeg(z)) . 1) . red(z))) . 1) . l;
                z:= lc(z);
        end;
        if not eqn(z,1) then l:= mk!*sq(1.z) . l;
        return 'list . l;
end$

symbolic operator product2list;

% ----------------------------------------------------------------------

symbolic procedure sum2list(z);
begin
        scalar !*FACTOR, !*EXP, !*MCD, !*ALLFAC, l, denom;
        on EXP, MCD; off ALLFAC;  % switch-setting
        z:= simp aeval(z);
        denom:= denr z;
        z:= numr z;
        if atom(z) or not(numberp(denom)) then
                return 'list . {mk!*sq(z . denom)};
        l:= {};
        repeat <<
                l:= mk!*sq(((((mvar(z) . ldeg(z)) . lc(z)) . nil)) . denom) . l;
                z:= red(z);
        >> until atom(z) or null(z);
        if not(null(z)) then l:= mk!*sq(z . 1) . l;
        return 'list . l;
end$

symbolic operator sum2list;

% ----------------------------------------------------------------------
% ======================================================================
% ----------------------------------------------------------------------

algebraic procedure laurentcoeff(p, x);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*DIV, np, dp;
        on EXP, MCD;  off DIV;  % switch-setting
        np:= coeff(num(p),x);
        dp:= sub(x=1, den(p));
        return (for each j in np collect (j/dp));
end$

% ----------------------------------------------------------------------

algebraic procedure laurentcoeffn(p, x, n);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*RATIONAL, DMODE!*, !*DIV, np, dp, d;
        on EXP, MCD; off RATIONAL;  % switch-setting
        dp:= den(p);
        d:= deg(dp, x);
        np:= num(p) / sub(x=1,dp);
        n:= n + d;
        if (n < 0) then return 0;
        return coeffn(np,x,n);
end;

% ----------------------------------------------------------------------

algebraic procedure laurentdegree(p, x);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*DIV, !*RATIONAL, DMODE!*;
        on EXP, MCD;  off DIV, RATIONAL;  % switch-setting
        return (deg(num(p),x) - deg(den(p),x));
end$

% ----------------------------------------------------------------------

algebraic procedure laurentldegree(p, x);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*DIV, !*RATIONAL, DMODE!*;
        on EXP, MCD;  off DIV, RATIONAL;  % switch-setting
        p:= sub(x=1/x, p);
        return (deg(den(p),x) - deg(num(p),x));
end$

% ----------------------------------------------------------------------
% ----------------------------------------------------------------------
% ----------------------------------------------------------------------

symbolic procedure nullspace_size(x);
begin
        if atom(x) then
                return 1
        else
                return (nullspace_size(car x) + nullspace_size(cdr x));
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_equations2sqmatrix(gls, var, m, n);
begin
        scalar a, gl;
        timing('nullspace_equations2sqmatrix);
        a:= mkvect(m);
        for j:=0:m do putv(a, j, mkvect(n+1));
        for row:=0:m do begin
                gl:= car(gls);
                if pairp(gl) and (car(gl) = 'equal) then
                        gl:= addsq(simp(cadr(gl)), negsq(simp(caddr(gl))))
                else
                        gl:= simp(gl);
                gls:= cdr(gls);
                for j:=0:n do begin
                        putv(getv(a,row), j, simp(coeffn(aeval mk!*sq gl, getv(var,j), 1)));
                        gl:= (subsq(gl, {getv(var,j) . 0}));
                end;
                putv(getv(a,row), n+1, gl);
        end;
        timing('nullspace_equations2sqmatrix);
        return a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspacesolve(a, var);
begin
        scalar !*FACTOR, !*EXP, !*GCD, !*MCD, !*LIMITEDFACTORS,
                        m, n, nr_pref_va, va;
        timing('nullspacesolve);
        on EXP, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
        % put equations into list and remove 'zeroe-entries'...
        if pairp(a) and (car(a) = 'list) then
                a:= cdr(a)
        else
                a:= (a . nil);
        m:= length(a);
        va:= nil;
        for j:=1:m do begin
                n:= car(a);
                a:= cdr(a);
                if (n neq 0) then va:= n . va;
        end;
        a:= va;
        % put variables in list and then into a vector
        if pairp(var) and (car(var) = 'list) then
                var:= cdr(var)
        else
                var:= (var . nil);
        m:= length(a) - 1;
        n:= length(var) - 1;
        nr_pref_va:= n;
        va:= mkvect(n);
        for j:=0:n do <>;
        a:= nullspace_equations2sqmatrix(a, va, m, n);
        on FACTOR;  % switch-setting
        a:= a;
        a:= nullspace_triangulize(a, va, m, n+1, nr_pref_va);
        va:= cadr(a);
        a:= car(a);
        a:= nullspace_sort(a);
        a:= nullspace_matrix2solution(a, va);
        timing('nullspacesolve);
        return a;
end$

symbolic operator nullspacesolve;
% ----------------------------------------------------------------------

symbolic procedure nullspace_showmat(a);
begin
        scalar m, n;
        m:= upbv(a);
        n:= upbv(getv(a,1));
        for j:=0:m do begin
                prin2("{");
                for i:=0:n do begin
                        prin2(prepsq getv(getv(a,j),i));
                        prin2("  ");
                end;
                prin2t("}");
        end;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize(a, var, m, n, nr_pref_va);
begin
        scalar tmp, c, not_changed, j, pivot;
        timing('nullspace_triangulize);
        % Determine number of equations and number of columns
        % Initialize vector c determines whether a row was "triangulized"
        c:= mkvect(m);
        for j:=0:m do putv(c,j,-1);
        not_changed:= (for j:=0:m collect j);
        % Start triangulization
        for k:=0:m do begin
                pivot:= nullspace_triangulize_pivot
                        (a, not_changed, m, n-1, k, nr_pref_va);
                if (pivot neq nil) then begin
                        j:= cadr(pivot);
                        % Exchange columns such that pivot-element is at column k
                        nullspace_triangulize_exchange_columns(a, j, k);
                        % Change variable order
                        tmp:= getv(var,j);
                        putv(var,j,getv(var,k));
                        putv(var,k,tmp);
                        j:= car(pivot);
                        pivot:= simp mk!*sq negsq(getv(getv(a,j),k));
                        for l:=0:n do
                                putv(getv(a,j), l, simp mk!*sq quotsq(getv(getv(a,j),l),pivot));
                        % Mark row j as 'used'
                        putv(c,j,k);
                        not_changed:= {};
                        for l:=0:m do
                                if (getv(c,l) < 0) then not_changed:= l.not_changed;
                        % Eliminate column-entry k in 'unused' rows
                        for each h in not_changed do begin
                                pivot:= getv(getv(a,h),k);
                                for l:=0:k-1 do <<
                                        tmp:= simp mk!*sq multsq(pivot,getv(getv(a,j),l));
                                        tmp:= simp mk!*sq addsq(getv(getv(a,h),l),tmp);
                                        putv(getv(a,h),l,tmp);
                                >>;
                                putv(getv(a,h),k,simp(0));
                                for l:=k+1:n do <<
                                        tmp:= simp mk!*sq multsq(pivot,getv(getv(a,j),l));
                                        tmp:= simp mk!*sq addsq(getv(getv(a,h),l),tmp);
                                        putv(getv(a,h),l,tmp);
                                >>;
                        end; % of for each h in not_changed
                end; % of if (pivot neq nil)
        end; % of for k:=0:n
        timing('nullspace_triangulize);
        return {a, var};
end$

% ----------------------------------------------------------------------

symbolic procedure
        nullspace_triangulize_pivot(a, not_changed, m, n, k, nr_pref_va);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*GCD,
                        row, pivot, pivotsize, l1, l2, tmp;
        timing('nullspace_triangulize_pivot);
        off FACTOR, EXP, MCD, GCD;  % switch-setting
        pivot:= nil;
        pivotsize:= {10^10, 10^10};
        for each j in not_changed do begin
                for h:=k:nr_pref_va do begin
                        row:= getv(a,j);
                        tmp:= getv(row,h);
                        if (tmp neq simp(0)) then begin
                                l1:= nullspace_size(tmp);
                                if (l1 < car(pivotsize)+10) then begin
                                        l2:= (for r:=k:n sum
                                                nullspace_size(quotsq(getv(row,r),tmp)));
                                        if (l2 < cadr(pivotsize)+100) then begin
                                                pivot:= {j, h};
                                                pivotsize:= {l1, l2};
                                        end;
                                end;
                        end;  % of if
                end;  % of for h:=k:nr_pref_va
        end; % of for each j
        timing('nullspace_triangulize_pivot);
        if (nr_pref_va < n) and (pivot = nil) then
                return nullspace_triangulize_pivot(a, not_changed, m, n, k, n);
        return pivot;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize_exchange_columns(a, j, k);
begin
        scalar length_a, tmp;
        if (j = k) then return a;
        length_a:= upbv(a);
        for l:=0:length_a do begin
                tmp:= getv(getv(a,l), j);
                putv(getv(a,l), j, getv(getv(a,l),k));
                putv(getv(a,l), k, tmp);
        end;
        return a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_triangulize_exchange_rows(a, j, k);
begin
        scalar tmp;
        if (j = k) then return a;
        tmp:= getv(a, j);
        putv(a, j, getv(a,k));
        putv(a, k, tmp);
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_sort_comp(l1, l2);
begin
        scalar z1, z2, len1, len2, zeroe;
        zeroe:= simp(0);
        z1:= 0;
        len1:= upbv(l1);
        while (z1 <= len1) and (getv(l1,z1) = zeroe) do z1:= z1+1;
        z2:= 0;
        len2:= upbv(l2);
        while (z2 <= len2) and (getv(l2,z2) = zeroe) do z2:= z2+1;
        if (z1 > z2) then return t else return nil;
end$


% ----------------------------------------------------------------------

symbolic procedure nullspace_bubblesort(l,fn);
begin
   scalar ln, tmp;
   ln:= upbv(l);
   for i:=0:ln do
      for j:=i+1:ln do
         if (i neq j) and apply2(fn,getv(l,j),getv(l,i)) then begin
            tmp:= getv(l,i);
                                putv(l, i, getv(l,j));
                                putv(l, j, tmp);
         end;
   return l;
end$


% ----------------------------------------------------------------------

symbolic procedure nullspace_sort(a);
begin
        scalar n, zeroelist, l, sorted_a;
        timing('nullspace_sort);
        a:= nullspace_bubblesort(a, 'nullspace_sort_comp);
        l:= upbv(getv(a,0));
        zeroelist:= mkvect(l);
        for j:=0:l do putv(zeroelist, j, simp(0));
        n:= 0;
        l:= upbv(a);
        while (n <= l) and (getv(a,n) = zeroelist) do n:= n+1;
        sorted_a:= mkvect(l-n);
        for j:=n:l do putv(sorted_a,j-n,getv(a,j));
        timing('nullspace_sort);
        return sorted_a;
end$

% ----------------------------------------------------------------------

symbolic procedure nullspace_matrix2solution(a, var);
begin
        scalar m, n, solu, tmp, row;
        timing('nullspace_matrix2solution);
        m:= upbv(a);
        n:= upbv(var);
        % All rows with zeroe entries (only) have been cancelled.
        % If the first row has n zeroes as first entries, then the
        % last one has to be different from zeroe, i.e. there is no
        % solution!
        solu:= (for j:=0:n collect getv(getv(a,0),j));
        if (solu = (for j:=0:n collect simp(0))) then
                return <>;
        % Backsubstitution...
        % Append 1 to variables for righhandside of equation.
        solu:= mkvect(n+1);
        for j:=0:n do putv(solu, j, simp(getv(var,j)));
        putv(solu, n+1, simp(1));
        for j:=m step (-1) until 0 do begin
                tmp:= simp(0);
                row:= getv(a,m-j);
                for h:=j+1:n+1 do
                        tmp:= addsq(tmp, multsq(negsq(getv(row,h)),getv(solu,h)));
                putv(solu, j, quotsq(tmp, getv(row,j)));
        end; % of for j
        solu:= (for j:=0:n collect
                {'equal, getv(var,j), mk!*sq(getv(solu,j))});
        timing('nullspace_matrix2solution);
        return ('list . solu);
end$

% ----------------------------------------------------------------------

algebraic procedure nullspace_profile();
begin
        write "nullspace_coefflist:        ",
                showcputiming(nullspace_equations2sqmatrix);
        write "nullspace_triangulize:      ",
                showcputiming(nullspace_triangulize);
        write "nullspace_triangulize_pivot:",
                showcputiming(nullspace_triangulize_pivot);
        write "nullspace_sort:             ",
                showcputiming(nullspace_sort);
        write "nullspace_matrix2solution:  ",
                showcputiming(nullspace_matrix2solution);
        write "nullspace:                  ",
                showcputiming(nullspacesolve), "   (", showgctiming(nullspacesolve), ")";
end$

% ----------------------------------------------------------------------
% ======================================================================

algebraic procedure trace_qsum(text, term);
begin
        if (lisp !*qsum_trace) then
                write text, "    ", (sub(!*qsumrecursion!@sub, term));
end$

% ======================================================================
% ----------------------------------------------------------------------

symbolic procedure qsumrecursion_number(n, d);
begin
        scalar l, b;
        l:= explode reval n;
        b:= d-length(l);
        if (b > 0) then for j:=1:b do prin2(" ");
        for each j in l do prin1 compress list(j);
end;

% ----------------------------------------------------------------------

symbolic procedure qsumrecursion_qprofile;
begin
        scalar qrat, qupd, qdis, qfin, qsol, qdeg, qsum, qsgc, maxt, lmax;
        qrat:= reval showcputiming('qratios);
        qupd:= reval showcputiming('qupdate);
        qdis:= reval showcputiming('qdispersionset);
        qfin:= reval showcputiming('qfindf);
        qsol:= reval showcputiming('solve);
        qdeg:= reval showcputiming('qdegreebound);
        qsum:= reval showcputiming('qsumrecursion);
        qsgc:= reval showgctiming('qsumrecursion);
        maxt:= length explode max(qrat,qupd,qdis,qsol,qdeg,qsum);
        lmax:= length explode max(qdis,qsol,qsgc);
        prin2t " ";
        prin2  " qratios:        ";
        qsumrecursion_number(qrat, maxt);
        prin2t "";
        prin2  " qupdate:        ";
        qsumrecursion_number(qupd, maxt);
        prin2  "     (";
        qsumrecursion_number(qdis, lmax);
        prin2t " qdispersionset)";
        prin2  " qfindf:         ";
        qsumrecursion_number(qfin, maxt);
        prin2  "     (";
        qsumrecursion_number(qsol, lmax);
        prin2  " solve,  ";
        prin2  qdeg; %qsumrecursion_number(qdeg, lmax);
        prin2t " qdegreebound)";
        prin2  " qsumrecursion:  ";
        qsumrecursion_number(qsum, maxt);
        prin2  "     (";
        qsumrecursion_number(qsgc, lmax);
        prin2t " gc-time)";
end$

symbolic operator qsumrecursion_qprofile;

% ----------------------------------------------------------------------
% ======================================================================

clear binomial, qpochhammer, qfac, qbinomial, qbrackets, qfactorial;
operator binomial, qpochhammer, qfac, qbinomial, qbrackets, qfactorial;

% ======================================================================

algebraic procedure qpsihyperterm(nu, de, q, z, n);
begin
        scalar  r, s;
   r:= length(nu);
   s:= length(de);
        nu:= (for each j in nu product qpochhammer(j,q,n));
        de:= (for each j in de product qpochhammer(j,q,n));
   nu:= nu * (-1)^((s-r)*n) * q^((s-r)*n*(n-1)/2) * z^n;
   return nu/de;
end$

% ----------------------------------------------------------------------

algebraic procedure qphihyperterm(nu, de, q, z, n);
begin
        scalar r, s;
   r:= length(nu);
   s:= length(de);
        nu:= (for each j in nu product qpochhammer(j,q,n));
        de:= (for each j in de product qpochhammer(j,q,n));
   nu:= nu * z^n * ((-1)^n*q^(n*(n-1)/2))^(1+s-r);
   return nu/(de * qpochhammer(q,q,n));
end$


% ======================================================================
% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_integer_part_sf(f);
begin
        scalar l, tmp, z;
        l:= nil;
        while pairp(f) do <<
                tmp:= qsimpcomb_standard_integer_part_sf(lc f);
                z:= ((mvar f).(ldeg f));
                repeat <<
                        l:= (((z.car(tmp)).nil) . l);
                        tmp:= cdr(tmp);
                >> until null(tmp);
                f:= red f;
        >>;
        if not(null f) then l:= (f . l);
        return l;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_integer_part(z);
begin
        scalar !*BALANCED_MOD, !*EXP, !*FACTOR, !*RATIONAL, !*DMODE,
                n, d, tmp;
        on EXP;  off BALANCED_MOD, RATIONAL;  % switch-setting
        z:= simp aeval mk!*sq z;
        n:= numr z;
        d:= denr z;
        n:= qsimpcomb_standard_integer_part_sf n;
        if null(n) then return 0;
        z:= simp 0;
        repeat <<
                tmp:= simp mk!*sq (car(n) . d);
                if (fixp numr tmp) and (fixp denr tmp) then z:= addsq(z, tmp);
                n:= cdr n;
        >> until null(n);
        if eqn(denr z,1) then
                if null(numr z) then return 0 else return (numr z);
        n:= numr z;
        d:= denr z;
        z:= (car qremf(n,d));
        if (null(z) and !:minusp(n)) or !:minusp(z) then
                z:= addf(z,-1);
        if null(z) then return 0 else return z;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_qexp_part_sf(f,q);
begin
        scalar p, z;
        p:= simp nil;
        while pairp(f) and (null (red f)) do <<
                if (mvar(f) eq q) then
                        p:= addsq(p, simp(ldeg f))
                else
                        begin
                                z:= mvar f;
                                if pairp(z) and (car(z) eq 'expt) and (cadr(z) eq q) then
                                        p:= addsq(p, simp({'times,caddr z,ldeg(f)}));
                        end;
                f:= lc f;
        >>;
        return p;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_standard_qexp_part(a,q,qe);
begin
        scalar !*FACTOR, !*EXP, n, d;
        on FACTOR;  % switch-setting
        a:= simp aeval mk!*sq a;
        n:= numr a;
        d:= denr a;
        n:= qsimpcomb_standard_qexp_part_sf(n,q);
        d:= qsimpcomb_standard_qexp_part_sf(d,q);
        n:= subtrsq(n,d);
        n:= qsimpcomb_standard_integer_part(quotsq(n,(simp qe)));
        d:= simp {'expt,q,{'times,mk!*sq(simp n),qe}};
        if null(simp aeval mk!*sq(subtrsq(a, d))) then
                n:= !:difference(n,-1);
        return (n);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer_finite(u);
begin
        scalar k, f, f1, jj;
        k:= caddr(u);
        f:= simp(1);
        if !:zerop(k) then return f;
        jj:= gensym();
        f1:= simp({'difference,1,{'times,car(u),{'expt,cadr(u),jj}}});
        if !:minusp(k) then
                (for j:=k:-1 do f:= quotsq(f,subsq(f1,{jj.j})))
        else <<
                k:= reval({'difference,k,1});
                for j:=0:k do f:= multsq(f,subsq(f1,{jj.j}));
        >>;
        return f;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer_infinity(u,a,q,qe,k,m);
begin
        scalar jj, f, f2;
        if (k eq simp({'minus,'infinity})) or !:zerop(m) then
                return mksq(('qpochhammer.u),1)
        else if (k neq simp('infinity)) then
                rederr "Invalid arguments in qpochhammer.";
        f:= simp(1);
        jj:= gensym();
        a:= prepsq quotsq(a, simp {'expt,q,{'times,qe,m}});
        f2:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,jj}}}};
        if !:minusp(m) then % (m < 0)
                for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}))
        else % (m >= 0)
                for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
        f:= multsq(f, mksq({'qpochhammer,a,cadr(u),caddr(u)},1));
        return f;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qpochhammer(u);
begin
        scalar a, q, qq, qe, k, n, m, f, jj, f1, f2;

        if not eqn(length u,3) then
                rederr "Invalid number of arguments in qpochhammer";

        if fixp(caddr u) then
                return qsimpcomb_qpochhammer_finite(u);

        a:= simp car u;
        qq:= simp cadr u;
        q:= qq;
        k:= simp caddr u;

        % Die vereinfachten Argumente wieder als Liste nach u,
        % damit der zur"uckgelieferte qpochhammer-Term
        % standardisierte Argumente besitzt. (Sonst k"urzen sich diese
        % unter Umst"anden nicht ordentlich weg...)
        u:= {prepsq(a), prepsq(qq), prepsq(k)};

        if idp(cadr u) then <<
                qe:= 1;
                q:= mvar(numr q);
        >> else if eqn(denr q,1) then <<
                q:= numr q;
                qe:= ldeg q;
                if not eqn(lc q,1) or not(idp(mvar q)) then
                        rederr "Invalid arguments in qpochhammer";
                q:= mvar q;
        >> else if eqn(numr q,1) then <<
                q:= denr q;
                qe:= -(ldeg q);
                if not eqn(lc q,1) or not(idp(mvar q)) then
                        rederr "Invalid arguments in qpochhammer.";
                q:= mvar q;
        >> else
                rederr "Invalid arguments in qpochhammer.";

        if null(a) then return (simp 1);

        if (a eq qq) then
                m:= 0
        else <<
                m:= qsimpcomb_standard_qexp_part(a,q,qe);
                if (a eq simp({'expt,q,{'times,qe,m}})) and !:minusp(!:minus(m)) then
                        m:= !:difference(m,1);
        >>;
        n:= qsimpcomb_standard_integer_part(k);

        if !:zerop(n) and !:zerop(m) then
                return mksq(('qpochhammer.u),1);

        if not(freeof(k,'infinity)) then
                return qsimpcomb_qpochhammer_infinity(u,a,q,qe,k,m);

        f:= simp 1;
        jj:= gensym();
        qq:= cadr u;
        a:= prepsq quotsq(a, simp {'expt,q,{'times,m,qe}});
        k:= prepsq subtrsq(k,simp(n));
        f1:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,{'plus,jj,k}}}}};
        f2:= simp {'difference,1,{'times,a,{'expt,q,{'times,qe,jj}}}};
        if !:minusp(!:plus(n,m)) then  % (m+n < 0)
                if !:minusp(m) then <<  % (m < 0)
                        for j:=m+n:-1 do f:= quotsq(f, subsq(f1, {jj.j}));
                        for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}));
                >> else << % (m >= 0)
                        for j:=m+n:-1 do f:= quotsq(f, subsq(f1, {jj.j}));
                        for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
                >>
        else % (m+n >= 0)
                if !:minusp(m) then <<  % (m < 0)
                        for j:=0:n+m-1 do f:= multsq(f, subsq(f1, {jj.j}));
                        for j:=m:-1 do f:= multsq(f, subsq(f2, {jj.j}));
                >> else << % (m >= 0)
                        for j:=0:n+m-1 do f:= multsq(f, subsq(f1, {jj.j}));
                        for j:=0:m-1 do f:= quotsq(f, subsq(f2, {jj.j}));
                >>;
        u:= multsq(f, mksq({'qpochhammer,a,qq,k},1));
        return u;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_binomial(u);
begin
        scalar f, n, k;
        if not(fixp(cadr(u)) and (cadr(u) >= 0)) then
                return mksq({'binomial,car u,cadr u},1);
        n:= simp(car u);
        k:= cadr u;
        if eqn(k,0) then return simp(1);
        f:= simp 1;
        for j:=0:(!:difference(k,1)) do f:= multsq(f, subtrsq(n,simp(j)));
        f:= quotsq(f, simp({'factorial,k}));
        return f;
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qbinomial(u);
begin
        scalar n, k, q;
        n:= car u;
        k:= cadr u;
        q:= caddr u;
        u:= {'quotient,{'qpochhammer,q,q,n},{'times,
                {'qpochhammer,q,q,k},{'qpochhammer,q,q,{'difference,n,k}}}};
        return mksq(u,1);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qbrackets(u);
begin
        scalar n, q;
        n:= car u;
        q:= cadr u;
        u:= {'quotient,{'difference,{'expt,q,n},1},{'difference,q,1}};
        return mksq(u,1);
end;

% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qfactorial(u);
begin
        scalar n, q;
        n:= car u;
        q:= cadr u;
        u:= {'quotient,{'qpochhammer,q,q,n},{'expt,{'difference,1,q},n}};
        return mksq(u,1);
end;


% ----------------------------------------------------------------------

symbolic procedure qsimpcomb_qfac(u);
begin
        return mksq(('qpochhammer . u), 1);
end;
% ----------------------------------------------------------------------

symbolic procedure qsimplify(f);
begin
        scalar !*precise, !*factor, !*exp, !*mcd, !*gcd, !*rational,
                redefmode, orig_bino, orig_qbin, orig_qbra, orig_qfct,
                orig_qfac, orig_qpoc;
        on FACTOR, MCD, GCD;  off RATIONAL, PRECISE;  % switch-setting

        if (length(f) neq 1) then
                rederr "Wrong number of arguments in qsimp";

        % Install the procedure new_simpexpt, which does more rigid
        % simplifications of powers and save original one
        % AND prevent redefined-messages.
        redefmode:= !*redefmsg;
        !*redefmsg:= nil;
        copyd('simpexpt, 'new_simpexpt);
        orig_bino:= get('binomial,    'simpfn);
        put('binomial,    'simpfn, 'qsimpcomb_binomial);

        f:= aeval(car f);

        % Get old 'simplify-functions' for q-expressions
        orig_qbin:= get('qbinomial,   'simpfn);
        orig_qbra:= get('qbrackets,   'simpfn);
        orig_qfct:= get('qfactorial,  'simpfn);
        orig_qfac:= get('qfac,        'simpfn);
        orig_qpoc:= get('qpochhammer, 'simpfn);

        % Declare all 'simplify-functions' for q-expressions
        put('qbinomial,   'simpfn, 'qsimpcomb_qbinomial);
        put('qbrackets,   'simpfn, 'qsimpcomb_qbrackets);
        put('qfactorial,  'simpfn, 'qsimpcomb_qfactorial);
        put('qfac,        'simpfn, 'qsimpcomb_qpochhammer);
        put('qpochhammer, 'simpfn, 'qsimpcomb_qpochhammer);

        % Simplify expression
        rmsubs();
        f:= mk!*sq(simp(reval f));

        % Hide all 'simplify-functions
        put('binomial,    'simpfn, orig_bino);
        put('qbinomial,   'simpfn, orig_qbin);
        put('qbrackets,   'simpfn, orig_qbra);
        put('qfactorial,  'simpfn, orig_qfct);
        put('qfac,        'simpfn, orig_qfac);
        put('qpochhammer, 'simpfn, orig_qpoc);

        % Restore old simpexpt and former !*redefmsg-mode
        copyd('simpexpt, 'original_simpexpt);
        !*redefmsg:= redefmode;

        return f;
end;

put('qsimpcomb, 'psopfn, 'qsimplify);

% ----------------------------------------------------------------------
% ======================================================================

algebraic procedure down_qratio(a, k);
begin
   a:= qsimpcomb(a / sub(k=k-1,a));
        return a;
end$

% ----------------------------------------------------------------------

algebraic procedure up_qratio(a, k);
begin
   a:= qsimpcomb(sub(k=k+1,a) / a);
        return a;
end$

% ----------------------------------------------------------------------

algebraic procedure qratio(a, k);
begin
   a:= qsimpcomb(sub(k=k+1,a) / a);
        return a;
end$

% ======================================================================

% ----------------------------------------------------------------------

% select patch by W. Neun 12.96

symbolic procedure select!-eval u;
 % select from a list l members according to a boolean test.
 begin scalar l,w,v,r;
  l := reval cadr u; w := car u;
  if atom l or (car l neq'list and not flagp(car l,'nary)) then
           typerr(l,"select operand");
  if idp w and get(w,'number!-of!-args)=1 then w:={w,{'~,'!&!&}};
  if eqcar(w,'replaceby) then <>;
  w:=freequote formbool(w,nil,'algebraic);
  if v then w:={'replaceby,v,w};
  r:=for each q in
        pair(cdr map!-eval1(l,w,function(lambda y;y),'lispeval),cdr l)
      join if car q and car q neq 0 then {cdr q};
  if r then return car l . r;
  if (r:=atsoc(car l,'((plus . 0)(times . 1)(and . 1)(or . 0))))
    then return cdr r
   %else rederr {"empty selection for operator ",car l}
    else return list('list);
end$

% ======================================================================

algebraic procedure type_homogeneous(f,z);
begin
        scalar !*EXP, !*FACTOR, !*MCD, c, deg_f;
        on EXP, MCD;  % switch-setting
        if not(type_ratpoly(f,z)) then return nil;
        deg_f:= laurentdegree(f,z);
        c:= laurentcoeffn(f,z,deg_f);
        if ((f - c*z^deg_f) = 0) and freeof(c,z) then return t;
        return nil;
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qprimedispersion(f, g, q, qk);
begin
        scalar !*EXP, !*FACTOR, !*GCD, !*MCD, n, m, a, b, c, d, j;
        on EXP, MCD;  off GCD; % switch-setting
        f:= f;
        n:= laurentdegree(f,qk);
        if (n = 0) or (n neq laurentdegree(g,qk)) then return {};
        m:= laurentldegree(f, qk);
        if (m = n) or (m neq laurentldegree(g, qk)) then return {};
        a:= laurentcoeffn(f,qk,n);
        b:= laurentcoeffn(f,qk,m);
        c:= laurentcoeffn(g,qk,n);
        d:= laurentcoeffn(g,qk,m);
        on GCD;  % switch-setting
        j:= a*d / (b*c);
        off GCD;  % switch-setting
        if not type_homogeneous(j,q) then return {};
        j:= laurentdegree(j,q) / (n-m);
        if not(fixp(j) and (-1 < j)) then return {};
        m:= sub(qk=qk*q^j, g);
        c:= laurentcoeffn(m, qk, n);
        if ((c*f-a*m) = 0) then return j;
        return {};
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdispersionset_simple_factorlist(p, x);
begin
        scalar !*EXP, !*FACTOR, !*GCD, !*LIMITEDFACTORS, !*MCD;
        on FACTOR, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
        p:= product2list(p);
        p:= (for each j in p collect if (arglength(j)>-1) and
                (part(j,0)=expt) and (fixp(part(j,2))) then part(j,1) else j);
        p:= select(not freeof(~z,x), p);
        return p;
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdispersionset(qq, rr, q, qk);
begin
        scalar disp, j;
        timing(qdispersionset);
        qq:= qgosper_qdispersionset_simple_factorlist(qq, qk);
        rr:= qgosper_qdispersionset_simple_factorlist(rr, qk);
        disp:= {};
        for each f in qq do
                for each g in rr do begin
                        j:= qgosper_qprimedispersion(f,g,q,qk);
                        if (j neq {}) and not(j member disp) then disp:= j.disp;
                end;
        trace_qsum("dispersionset:", disp);
        timing(qdispersionset);
        return disp;
end$

% ======================================================================

algebraic procedure qgosper_qupdate(pp, qq, rr, q, qk);
begin
        scalar !*FACTOR, !*EXP, !*MCD, !*DIV, !*GCD, !*LIMITEDFACTORS, disp, g;
        timing(qupdate);
        on FACTOR, MCD, DIV;  off LIMITEDFACTORS;  % switch-setting
        disp:= qgosper_qdispersionset(qq, rr, q, qk);
        for each j in disp do begin
                on EXP;  % switch-setting;
                g:= gcd(qq, sub(qk=qk*q^j,rr));
                on FACTOR;  % switch-setting
                if not freeof(g, qk) then begin
                        qq:= qq / g;
                        rr:= rr / sub(qk=qk/q^j, g);
                        pp:= pp * (for l:=0:j-1 product sub(qk=qk/q^l, g));
                end;  % of if
        end;  % of for
        trace_qsum("q-Gosper representation:", {pp, qq, rr});
        timing(qupdate);
        return {pp, qq, rr};
end$

% ======================================================================

algebraic procedure qgosper_qdegreebound_q_exponent(f, q);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*GCD, !*COMBINELOGS, !*EXPANDLOGS;
        on EXPANDLOGS, EXP, MCD, GCD;  OFF COMBINELOGS;  % switch-setting
        return log(f)/log(q);
end$

% ----------------------------------------------------------------------

algebraic procedure qgosper_qdegreebound(pp, qq, rr, q, qk);
begin
        scalar !*MCD, !*FACTOR, !*EXP, !*GCD,
                        ldegpp,ldegqq,ldegrr,ldegff,dd,ee,degpp,degqq,degrr,degff;
        timing(qdegreebound);
        on EXP, MCD;  off GCD;  % switch-setting
        % untere Gradschranke
        ldegpp:= laurentldegree(pp, qk);
        ldegqq:= laurentldegree(qq, qk);
        ldegrr:= laurentldegree(rr, qk);
        if (ldegqq neq ldegrr) then
                ldegff:= ldegpp - min(ldegqq, ldegrr)
        else begin
                dd:= laurentcoeffn(qq, qk, ldegqq);
                ee:= laurentcoeffn(rr, qk, ldegqq);
                ee:= qgosper_qdegreebound_q_exponent(ee/dd, q);
                if fixp(ee) then
                        ldegff:= min(ee,ldegpp) - ldegqq
                else
                        ldegff:= ldegpp - ldegqq;
        end; % of else
        % obere Gradschranke
        degpp:= laurentdegree(pp, qk);
        degqq:= laurentdegree(qq, qk);
        degrr:= laurentdegree(rr, qk);
        if (degqq neq degrr) then
                degff:= degpp - max(degqq, degrr)
        else begin
                dd:= laurentcoeffn(qq, qk, degqq);
                ee:= laurentcoeffn(rr, qk, degqq);
                ee:= qgosper_qdegreebound_q_exponent(ee/dd, q);
                if fixp(ee) then
                        degff:= max(ee,degpp) - degqq
                else
                        degff:= degpp - degqq;
        end; % of else
        timing(qdegreebound);
        if (degff < ldegff) then return {};
        return {ldegff, degff};
end$

% ======================================================================

symbolic procedure qsumrecursion_inds2arbcmplx(u);
begin
        scalar solu, var, arbsubs, gl, tmp, j;
        solu:= car u;
        if not(freeof(solu, 'arbcomplex)) then return solu;
        if null(cdr(solu)) then return 'list.nil;
        if (caadr(solu) eq 'list) then solu:= 'list. cdadr(solu);
        solu:= cdr(solu);
        var:= cdr(reval cadr(u));
        arbsubs:= nil;
        for each gl in solu do <<
                tmp:= var;
                while (tmp neq nil) do <<
                        j:= car(tmp);
                        tmp:= cdr(tmp);
                        if pairp(gl) and not(freeof(caddr(gl),j)) then <<
                                arbsubs:= {'equal,j,prepsq(!*f2q(makearbcomplex()))}.arbsubs;
                                var:= delete(j, var);
                        >>;
                >>;
        >>;
        if (arbsubs eq nil) then return car u;
        arbsubs:= 'list . arbsubs;
        tmp:= nil;
        while (solu neq nil) do <<
                gl:= car(solu);
                solu:= cdr(solu);
                if pairp(gl) then
                        caddr(gl):= reval({'sub, arbsubs, caddr(gl)});
                tmp:= gl . tmp;
        >>;
        tmp:= 'list . tmp;
        return tmp;
end$

put('qsumrecursion_indets2arbcomplex, 'psopfn, 'qsumrecursion_inds2arbcmplx);

% ======================================================================

algebraic procedure qgosper_qfindf(pqr, q, qk);
begin
        scalar !*EXP, !*FACTOR, !*MCD, !*CRAMER,
                        pp, qq, rr, d, var, f, a, i, eqn, solu;
        timing(qfindf);
        on EXP, MCD;  % switch-setting
        pp:= part(pqr, 1);
        qq:= part(pqr, 2);
        rr:= part(pqr, 3);
        d:= qgosper_qdegreebound(pp, qq, rr, q, qk);
        trace_qsum("degreebounds:", d);
        if (d = {}) then return <>;
        var:= (for j:=part(d,1):part(d,2) collect (lisp gensym()));
        f:= (for j:=part(d,1):part(d,2) sum part(var,j-part(d,1)+1)*qk^j);
        eqn:= sub(qk=qk*q,qq)*f - rr*sub(qk=qk/q,f) - pp;
        eqn:= laurentcoeff(eqn,qk);
        on CRAMER;  % switch-setting
        timing(solve);
        if (lisp !*qsum_nullspace) then
                solu:= nullspacesolve(eqn, var)
        else
                solu:= solve(eqn, var);
        timing(solve);
        on FACTOR;  % switch-setting
        if (solu = {}) then return <>;
        solu:= qsumrecursion_indets2arbcomplex(solu, var);
        f:= sub(solu, f);
        for each j in var do if not(freeof(f,j)) then
                sub(j=(lisp mk!*sq !*f2q makearbcomplex()), f);
        timing(qfindf);
        return f;
end$

% ======================================================================

% Old Version with f as laurentpolynomial:
% f:= (for j:=part(d,1):part(d,2) sum part(var,j-part(d,1)+1)*qk^j);
% eqn:= sub(qk=qk*q,qq)*f - rr*sub(qk=qk/q,f) - pp;
% eqn:= laurentcoeff(eqn, qk);

algebraic procedure qsumrecursion_qfindf_equations
        (pp, qq, rr, d, q, qk, sigma_var);
begin
        scalar !*EXP, !*FACTOR, !*LIMITEDFACTORS, !*MCD, !*CRAMER,
                        var, f, eqn, solu, ld;
        on EXP, MCD;  % switch-setting
        var:= (for j:=part(d,1):part(d,2) collect (lisp gensym()));
        if (part(d,1) < 0) then begin
                f:= (for j:=0:part(d,2)-part(d,1) sum part(var,j+1)*qk^j);
                ld:= -part(d,1);
                eqn:= sub(qk=qk*q^2,qq)*sub(qk=qk*q,f) - sub(qk=qk*q,rr)*f*
                                q^ld - sub(qk=qk*q,pp)*qk^ld*q^ld;
                end
        else begin
      f:= (for j:=part(d,1):part(d,2) sum part(var,j+part(d,1)+1)*qk^j);
                eqn:= sub(qk=qk*q^2,qq)*sub(qk=qk*q,f) - sub(qk=qk*q,rr)*f -
                                sub(qk=qk*q,pp);
        end;

        var:= append(sigma_var, var);
        timing(solve);
        if (lisp !*qsum_nullspace) then begin
                eqn:= coeff(eqn, qk);
                for each i in var do factor i;
                on FACTOR, MCD;  % switch-setting
                eqn:= eqn;
                solu:= nullspacesolve(eqn, var);
                for each i in var do remfac i;
                end
        else begin
                on CRAMER;  % switch-setting
                eqn:= coeff(eqn, qk);
                solu:= solve(eqn, var);
        end; % of else
        timing(solve);
        if (solu = {}) then return {};
        solu:= qsumrecursion_indets2arbcomplex(solu, var);
        if (lisp !*qsumrecursion_certificate) then <<
                f:= sub(solu, f);
        >> else
                f:= nil;
        solu:= {f, select(qsumrecursion_has(~w,sigma_var), solu)};
        if (lisp !*qsumrecursion_exp) and not(lisp !*qsum_nullspace) then
                on EXP  % switch-setting
        else
                on FACTOR;  % switch-setting
        solu:= reval solu;
        return solu;
end$

% ======================================================================

symbolic procedure qsumrecursion_has(z, varlist);
begin
        scalar has;
        has:= nil;
        repeat <<
                varlist:= cdr varlist;
                has:= not freeof(z, car varlist);
        >> until null(cdr varlist) or has;
        return has;
end$

symbolic operator qsumrecursion_has$

% ======================================================================

algebraic procedure qsumrecursion_qfindf(pqr, q, qk, sigma_var);
begin
        scalar !*FACTOR, !*EXP, !*LIMITEDFACTORS, !*MCD, !*CRAMER,
                        pp, qq, rr, d, var, f, a, i, eqn, solu;
        timing(qfindf);
        on EXP, MCD;  % switch-setting
        pp:= part(pqr, 1);
        qq:= part(pqr, 2);
        rr:= part(pqr, 3);
        d:= qgosper_qdegreebound(pp, qq, rr, q, qk);
        trace_qsum("degreebounds:", d);
        if (d = {}) then return <>;
        solu:= qsumrecursion_qfindf_equations(pp, qq, rr, d, q, qk, sigma_var);
        timing(qfindf);
        return solu;
end$

% ======================================================================

symbolic procedure qsumrecursion_range(x);
begin
        scalar lo, hi;
        if (length(qsumrecursion_recrange!*) neq 3) or
                not(pairp(qsumrecursion_recrange!*) and
                (car(qsumrecursion_recrange!*) = 'list)) then <<
                write "Global variable qsumrecursion_recrange!* must be a list";
                write "of two positive integers: {lo,hi} with lo<=hi.";
                rederr "Invalid value of qsumrecursion_recrange!*";
        >>;
        lo:= cadr(qsumrecursion_recrange!*);
        hi:= caddr(qsumrecursion_recrange!*);
        if not(fixp(lo) and fixp(hi) and (0>;
        if null(x) then return {'list, lo, hi};
        if (length(x) neq 1) then rederr "Wrong type of arguments.";
        x:= car(x);
        if (fixp(x)) and (x > 0) then return {'list, x, x};
        if atom(x) or (car(x) neq 'list) or (length(x) neq 3) then
                rederr "Wrong type of arguments.";
        x:= cdr(x);
        lo:= car(x);
        hi:= cdr(x);
        if not(fixp(lo) and fixp(hi) and (lo<=hi) and (0>;
        arg:= cdddr(arg);
        if not(null(arg)) then begin
                m:= car(arg);
                n:= cadr(arg);
                %if not(freeof(m,k)) or not(freeof(n,k)) then
                %       rederr "Summation bounds contain the summation variable.";
        end;
        f:= qgosper_eval(f,q,k);
        if not(null(arg)) then begin
                f:= simp(f);
                if !*qgosper_down then
                        m:= aeval {'plus, m, list('minus, 1)}
                else
                        n:= aeval {'plus, n, 1};
                f:= subtrsq(subsq(f,{k . n}), subsq(f,{k . m}));
                f:= mk!*sq(f);
        end;  % of if
        return f;
end$

put('qgosper, 'psopfn, 'qgosper);

% ======================================================================

algebraic procedure qgosper_eval(a, q, k);
begin
        scalar !*PRECISE, !*EXP, !*FACTOR, !*MCD, qk, pqr, f, redefmode;
        on FACTOR, MCD; off PRECISE;  % switch-setting

        % Turn off function-has-been-redefined-messages.
        share redefmode;
        redefmode:= (lisp !*redefmsg);
        lisp (!*redefmsg:= nil);

        % Set new_simpexpt as standard which does more simplifications
        % on power-terms:
        copyd('simpexpt, 'new_simpexpt);

        qk:= (lisp gensym());
        f:= down_qratio(a,k);
% qsimpcomb_simpexpt shouldn't be necessary any longer (new_simpexpt!)
% f:= qsimpcomb_simpexpt(down_qratio(a,k), q);

        if (lisp !*qsum_trace) then
                write "Applied substitution: ", q^k=k;
        !*qsumrecursion!@sub:= {qk=k};
        trace_qsum("down ratio wrt. k:", sub(qk=k,f));
        f:= (f where (q^k=>qk));
        if not(freeof(f,k)) then
                rederr "Input term is probably not q-hypergeometric.";

        pqr:= qgosper_qupdate(1, num(f), den(f), q, qk);
        f:= qgosper_qfindf(pqr, q, qk);

        if (f = {}) then
                rederr "No q-hypergeometric antidifference exists.";
        if (lisp !*qgosper_down) then % Gosper downwards
                f:= sub(qk=q^(k+1), part(pqr,2)) * sub(qk=q^k, f/part(pqr,1)) * a
        else % Gosper upwards:
                f:= sub(qk=q^k, part(pqr,3)/part(pqr,1)) * sub(qk=q^(k-1), f) * a;

        if (lisp !*qgosper_specialsol) then
                f:= (f where (arbcomplex(~z) => 0));

        % restore simpexpt and proper redefmsg-mode...
        copyd('simpexpt, 'original_simpexpt);
        lisp (!*redefmsg:= redefmode);
        return f;
end$

% ======================================================================
% ======================================================================

algebraic procedure qsumrecursion_denom_lcm(dl);
begin
        scalar !*FACTOR, !*EXP, !*GCD, !*MCD, g;
        on FACTOR, MCD, GCD;  % switch-setting
        g:= (part(dl,1)*part(dl,2)/gcd(part(dl,1),part(dl,2)));
        if (length(dl) = 2) then return g;
        dl:= (for j:=3:length(dl) collect j);
        return qsumrecursion_denom_lcm(g . dl);
end$

% ======================================================================

algebraic procedure qsumrecursion_denom(req, vars);
begin
        scalar !*FACTOR, !*EXP, !*GCD, !*MCD, numer, denom;
        on FACTOR, MCD, GCD;  % switch-setting
        numer:= (for each j in vars collect coeffn(req,j,1)*j);
        denom:= (for each j in numer collect den(j));
        denom:= qsumrecursion_denom_lcm(denom);
        numer:= (for each j in numer collect j*denom);
        off FACTOR; off EXP; % lisp setq(!*really_off_exp,t);  % switch-setting
        return (for each j in numer sum j);
end$

% ======================================================================

algebraic procedure qsumrecursion_qratios(f, q, k, qk, n, qn);
begin
        scalar !*FACTOR, !*EXP, !*MCD, !*GCD, !*LIMITEDFACTORS, kn_ratio;
        on FACTOR, MCD;  off GCD, LIMITEDFACTORS;  % switch-setting
        timing(qratios);
        kn_ratio:= {down_qratio(f,k), qratio(f,n)};
        kn_ratio:= (kn_ratio where {q^k=>qk, q^n=>qn});
        !*qsumrecursion!@sub:= {qk=k, qn=n};
        if not freeof(kn_ratio,k) then
                %<>;
                rederr "Input term is probably not q-hypergeometric.";
        trace_qsum("Applied the substitutions:", {q^k=>k, q^n=>n});
        trace_qsum("down ratio wrt. k:", part(kn_ratio,1));
        trace_qsum("up ratio wrt. n:", part(kn_ratio,2));
        timing(qratios);
        return kn_ratio;
end$

% ======================================================================


algebraic procedure qsumrecursion_eval(f, q, k, summ, n, recrange);
begin
        scalar !*PRECISE, !*FACTOR, !*EXP, !*MCD, !*GCD, !*LIMITEDFACTORS,
                        redefmode, qk, qn, rk, rn, lo, hi, a, poly, sigmalist,
                        record, pqr, fpol, solu, cert;
        timing(start); timing(qsumrecursion);

        on FACTOR, MCD;  off PRECISE, GCD, LIMITEDFACTORS;  % switch-setting
        % Turn off function-has-been-redefined-messages.
        share redefmode;
        redefmode:= (lisp !*redefmsg);
        lisp (!*redefmsg:= nil);

        % Set new_simpexpt as standard which does more simplifications
        % on power-terms:
        copyd('simpexpt, 'new_simpexpt);

        lo:= part(recrange, 1);
        hi:= part(recrange, 2);
        qk:= (lisp gensym());
        qn:= (lisp gensym());
%clear sigma; operator sigma;
   rn:= qsumrecursion_qratios(f, q, k, qk, n, qn);
        rk:= part(rn, 1);
        if (lisp !*qsumrecursion_down) then
                rn:= 1 / sub(n=n-1, qn=qn/q, part(rn, 2))
        else
                rn:= part(rn, 2);
        poly:= 1;
        record:= 0;
        sigmalist:= {};
        repeat begin
                record:= record + 1;
                sigmalist:= append(sigmalist, {lisp intern gensym()});
%!*qsumrecursion!@sub:= append(!*qsumrecursion!@sub,
%       {first reverse sigmalist=sigma(record)});
                if (lisp !*qsumrecursion_down) then
                        a:= (for l:=0:record-1 product sub({n=n-l, qn=qn/q^l}, rn))
                else
                        a:= (for l:=0:record-1 product sub({n=n+l, qn=qn*q^l}, rn));
                on GCD;  % switch-setting???
                poly:= poly + part(sigmalist,record)*a;
                fpol:= {};
                if (record >= lo) then begin
                        a:= rk * sub(qk=qk/q, den(poly)) / den(poly);
                        off GCD;  % switch-setting???
%trace_qsum("rat:=", a);
                        pqr:= qgosper_qupdate(num(poly), num(a), den(a), q, qk);
                        fpol:= qsumrecursion_qfindf(pqr, q, qk, sigmalist);
                end;
        end until (fpol neq {}) or (record = hi);
        if (fpol = {}) then
                rederr "Found no recursion. Use higher order.";
        solu:= part(fpol, 2);
        fpol:= part(fpol, 1);
        if (lisp !*qsumrecursion_down) then
                rec:= summ(n) + (for j:=1:record sum part(sigmalist,j)*summ(n-j))
        else
                rec:= summ(n) + (for j:=1:record sum part(sigmalist,j)*summ(n+j));
        if (lisp !*qsumrecursion_exp) then
                on EXP  % switch-setting
        else
                on FACTOR;  % switch-setting
        factor summ;
        rec:= sub(solu, rec);
        if (lisp !*qsumrecursion_certificate) then begin
                pqr:= sub(solu, pqr);
                cert:= den(rec) * sub(solu, poly);
                if (lisp !*qgosper_down) then << % Gosper downwards
                        cert:= cert * sub(qk=qk*q,part(pqr,2))*fpol/part(pqr,1);
                        a:= downward_antidifference;
                >> else <<% Gosper upwards:
                        cert:= cert * part(pqr,3)/part(pqr,1)*sub(qk=qk/q,fpol);
                        a:= upward_antidifference;
                >>;
                rec:= {num rec, cert, f, k, a};
                end
        else
                rec:= num rec;
        timing(qsumrecursion);
        if (lisp !*qsumrecursion_profile) then qsumrecursion_qprofile();

        % restore original simpexpt and redefmsg-mode...
        copyd('simpexpt, 'original_simpexpt);
        lisp (!*redefmsg:= redefmode);

        return sub(qn=q^n, qk=q^k, rec);
end$

% ======================================================================
% ======================================================================


lisp setq(!*redefmsg, nth(!*qsumrecursion!@sub,1));
lisp setq(!*echo, nth(!*qsumrecursion!@sub,2));
lisp setq(!*output, nth(!*qsumrecursion!@sub,3));

endmodule;

$end$

mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/0000755000175000017500000000000011722677363022356 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.tex0000644000175000017500000005247111526203062024721 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{ORTHOVEC: Version 2 of the REDUCE program
for 3-D vector analysis in orthogonal curvilinear coordinates}
\date{}
\author{James W.~Eastwood \\ AEA Technology \\ Culham Laboratory \\
Abingdon \\ Oxon OX14 3DB \\[0.1in]
Email: eastwood\#jim\%nersc.mfenet@ccc.nersc.gov \\[0.1in] June 1990}
\begin{document}
\maketitle
\index{ORTHOVEC package}

The revised version of ORTHOVEC is a collection of REDUCE 3.4 procedures and
operations which provide a simple to use environment for the manipulation of
scalars and vectors.  Operations include addition, subtraction, dot and cross
products, division, modulus, div, grad, curl, laplacian, differentiation,
integration, ${\bf a \cdot \nabla}$ and Taylor expansion.  Version 2 is
summarized in \cite{Eastwood:91}.  It differs from the original (\cite
{Eastwood:87}) in revised notation and extended capabilities.

%\begin{center}
%{\Large{\bf New Version Summary}}
%\end{center}
%\begin{tabular}{ll}
%\underline{Title of program}:&ORTHOVEC\\[2ex]
%\underline{Catalogue number}:&AAXY\\[2ex]
%\underline{Program obtainable from}: &CPC Program Library,\\
%&Queen's University of Belfast, N.~Ireland\\[2ex]
%\underline{Reference to original program}: &CPC 47 (1987) 139-147\\[2ex]
%\underline{Operating system}:&UNIX, MS-DOS + ARM-OS\\[2ex]
%\underline{Programming Language used}: &REDUCE 3.4\\[2ex]
%\underline{High speed storage required}: &As for 
%the underlying PSL/REDUCE \\
%&system, typically $>$ 1 Megabyte\\[2ex]
%\underline{No. of lines in combined programs and test deck}:&600 \\[2ex]
%\underline{Keywords}: & Computer Algebra, Vector Analysis,\\
%& series Expansion,  Plasma Physics, \\
%&Hydrodynamics, Electromagnetics.\\[2ex]
%\underline{Author of original program}: &James W. EASTWOOD\\[2ex]
%\underline{Nature of Physical Problem}: 
%&There is a wide range using vector\\
%& calculus in orthogonal curvilinear coordinates\\
%& and vector integration, differentiation\\
%& and series expansion.\\[2ex]
%\underline{Method of Solution}: & computer aided algebra using\\
%&standard orthogonal curvilinear coordinates\\
%&for differential and integral operators.\\[2ex]
%\underline{Typical running time}: 
%& This is strongly problem dependent:\\
%&the test examples given took respectively\\
%& 10,19 and 48 seconds on a SUN 4/310,\\
%&SUN 4/110 and ACORN Springboard. \\[2ex]
%\underline{Unusual Features of the Program}: 
%&The REDUCE procedures use\\
%&LISP vectors \cite{r2}
%to provide a compact\\
%&mathematical notation similar\\
%& to that normally found in vector\\
%& analysis textbooks.\\
%\end{tabular}

\section{Introduction}
The revised version of ORTHOVEC\cite{Eastwood:91} is, like the
original\cite{Eastwood:87}, a collection of REDUCE procedures and
operators designed to simplify the machine aided manipulation of vectors
and vector expansions frequently met in many areas of applied mathematics.
The revisions have been introduced for two reasons: firstly, to add extra
capabilities missing from the original and secondly, to tidy up input and
output to make the package easier to use.
\newpage
The changes from Version 1 include:

\begin{enumerate}
\item merging of scalar and vector unary and binary operators, $+, - , *, /
$
\item extensions of the definitions of division and exponentiation 
to vectors
\item new vector dependency procedures
\item application of l'H\^opital's rule in limits and Taylor expansions
\item a new component selector operator
\item algebraic mode output of LISP vector components
\end{enumerate}

The LISP vector primitives are again used to store vectors, although 
with the introduction of LIST types in algebraic mode in REDUCE
3.4, the implementation may have been more simply achieved 
using lists to store vector components.

The philosophy used in Version 2 follows that used in the original:
namely, algebraic mode is used wherever possible.  The view is taken
that some computational inefficiencies are acceptable if it allows
coding to be intelligible to (and thence adaptable by) users other
than LISP experts familiar with the internal workings of REDUCE.

Procedures and operators in ORTHOVEC fall into the five classes: 
initialisation, input-output, algebraic operations, differential
operations and integral operations.  Definitions are given in 
the following sections, and
a summary of the procedure names and their meanings are give in Table 1.
The final section discusses test examples.

\section{Initialisation}\label{vstart}
\ttindex{VSTART}
The procedure VSTART initialises ORTHOVEC.  It may be
called after ORTHOVEC has been INputted (or LOADed if a fast load
version has been made) to reset coordinates.  VSTART provides a
menu of standard coordinate systems:-


\begin{enumerate}
\index{cartesian coordinates}
\item cartesian $(x, y, z) = $ {\tt (x, y, z)}
\index{cylindrical coordinates}
\item cylindrical $(r, \theta, z) = $ {\tt (r, th, z)}
\index{spherical coordinates}
\item spherical $(r, \theta, \phi) = $ {\tt (r, th, ph) }
\item general $( u_1, u_2, u_3 ) = $ {\tt (u1, u2, u3) }
\item others
\end{enumerate}

which the user selects by number.  Selecting options (1)-(4)
automatically sets up the coordinates and scale factors.  Selection
option (5) shows the user how to select another coordinate system.  If
VSTART is not called, then the default cartesian coordinates are used.
ORTHOVEC may be re-initialised to a new coordinate system at any time
during a given REDUCE session by typing
\begin{verbatim}
VSTART $.
\end{verbatim}

\section{Input-Output}

ORTHOVEC assumes all quantities are either scalars or 3 component
vectors.  To define a vector $a$ with components $(c_1, c_2, c_3)$ use
the procedure SVEC as follows \ttindex{SVEC}
\begin{verbatim}
a := svec(c1, c2, c3);
\end{verbatim}

The standard REDUCE output for vectors when using the terminator ``$;$''
is to list the three components inside square brackets
$[\cdots]$, with each component in prefix form.  A replacement for the
standard REDUCE procedure MAPRIN is included in
the package to change the 
output of LISP vector components to algebraic notation.  The procedure
\ttindex{VOUT} VOUT (which returns the value of its argument)
can be used to give labelled output of components 
in algebraic form: e.g.,
\begin{verbatim}
b := svec (sin(x)**2, y**2, z)$
vout(b)$
\end{verbatim}

The operator {\tt \_} can be used to select a particular 
component (1, 2 or 3) for output e.g.
\begin{verbatim}
b_1 ;
\end{verbatim}

\section{Algebraic Operations}

Six infix operators, sum, difference, quotient, times, exponentiation
and cross product, and four prefix
operators, plus, minus, reciprocal
and  modulus are defined in ORTHOVEC.  These operators can take suitable
combinations of scalar and vector arguments,
and in the case of scalar arguments reduce to the usual definitions of
$ +, -, *, /, $ etc.

The operators are represented by symbols 
\index{+ ! 3-D vector} \index{- ! 3-D vector} \index{/ ! 3-D vector}
\index{* ! 3-D vector} \index{* ! 3-D vector} \index{"\^{} ! 3-D vector}
\index{$><$ ! 3-D vector}
\begin{verbatim}  
+, -, /, *, ^, ><
\end{verbatim}

\index{$><$ ! diphthong} The composite {\tt ><} is an
attempt to represent the cross product symbol 
$\times$ in ASCII characters.
If we let ${\bf v}$ be a vector and $s$ be a scalar, then
valid combinations of arguments of the 
procedures and operators and the type of the result 
are as summarised below.  The notation used is\\
{\em result :=procedure(left argument, right argument) } or\\
{\em result :=(left operand) operator (right operand) } . \\

\newpage
\underline{Vector Addition} \\
\ttindex{VECTORPLUS} \ttindex{VECTORADD} \index{vector ! addition}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORPLUS({\bf v})  &{\rm or}& {\bf v} &:=&  +  {\bf v} \\
     s  &:=& VECTORPLUS(s)  &{\rm or} &      s  &:=&  +       s  \\
{\bf v} &:=& VECTORADD({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&  
{\bf v} +  {\bf v} \\
     s  &:=& VECTORADD(s,s)  &{\rm or }&      s  &:=&  s + s \\
\end{tabular} \\

\underline{Vector Subtraction} \\
\ttindex{VECTORMINUS} \ttindex{VECTORDIFFERENCE} \index{vector ! subtraction}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORMINUS({\bf v})  &{\rm or}&
 {\bf v} &:=&  -  {\bf v} \\
 s  &:=& VECTORMINUS(s)  &{\rm or} &      s  &:=&  -       s  \\
{\bf v} &:=& VECTORDIFFERENCE({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&
  {\bf v} -  {\bf v} \\
 s  &:=& VECTORDIFFERENCE(s,s)  &{\rm or }&      s  &:=&  s - s \\
\end{tabular} \\

\underline{Vector Division}\\
\ttindex{VECTORRECIP} \ttindex{VECTORQUOTIENT} \index{vector ! division}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORRECIP({\bf v})  &{\rm or}& {\bf v} &:=&  /  
{\bf v} \\
 s  &:=& VECTORRECIP(s)  &{\rm or} &      s  &:=&  /       s  \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&  
{\bf v} /  {\bf v} \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},    s  )  &{\rm or }& {\bf v} &:=&  
{\bf v} /     s    \\
{\bf v} &:=& VECTORQUOTIENT(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&  
   s    /  {\bf v} \\
     s  &:=& VECTORQUOTIENT(s,s)  &{\rm or }&      s  &:=&  s / s       
       \\
\end{tabular} \\

\underline{Vector Multiplication}\\ 
\ttindex{VECTORTIMES} \index{vector ! multiplication}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORTIMES(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&     
s    *  {\bf v} \\
{\bf v} &:=& VECTORTIMES({\bf v},   s   )  &{\rm or }& {\bf v} &:=& {\bf
 v}  *     s    \\
   s    &:=& VECTORTIMES({\bf v},{\bf v})  &{\rm or }&    s    &:=& {\bf
 v}  *  {\bf v} \\
   s    &:=& VECTORTIMES(   s   ,   s   )  &{\rm or }&    s    &:=&     
s    *     s    \\
\end{tabular} \\
 
\underline{Vector Cross Product} \\
\ttindex{VECTORCROSS} \index{cross product} \index{vector ! cross product}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORCROSS({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=& {\bf
 v} $\times$   {\bf v} \\
\end{tabular} \\
 
\underline{Vector Exponentiation}\\
\ttindex{VECTOREXPT} \index{vector ! exponentiation}
\begin{tabular}{rclcrcl}
   s    &:=& VECTOREXPT ({\bf v},   s   )  &{\rm or }&    s    &:=& {\bf
 v}  \^{} s   \\
   s    &:=& VECTOREXPT (   s   ,   s   )  &{\rm or }&    s    &:=&    s
     \^{} s   \\
\end{tabular} \\

\underline{Vector Modulus}\\
\ttindex{VMOD} \index{vector ! modulus}
\begin{tabular}{rcl}
   s    &:=& VMOD (s)\\
   s    &:=& VMOD ({\bf v}) \\
\end{tabular} \\

All other combinations of operands for these operators lead to error 
messages being issued.  The first two instances of vector
multiplication are scalar multiplication of vectors, the third is the
\index{vector ! dot product} \index{vector ! inner product}
\index{inner product} \index{dot product}
product of two scalars and the last is the inner (dot) product.  The
prefix operators  {\tt +, -, /} can take either scalar or vector
arguments and return results of the same type as their arguments. 
VMOD returns a scalar.

In compound expressions, parentheses may be used to specify the order of
combination.  If parentheses are omitted the ordering of the
operators, in increasing order of precedence is
\begin{verbatim}
+ | - | dotgrad | * | >< | ^ | _
\end{verbatim}
and these are placed in the precedence list defined in REDUCE
after $<$.
The differential operator DOTGRAD is defined in the \index{DOTGRAD operator}
following section, and the component selector {\tt \_} was introduced in
section 3.

Vector divisions are defined as follows:  If ${\bf a}$ and ${\bf b}$ are
vectors and $c$ is a scalar, then
\begin{eqnarray*}
{\bf a} /  {\bf b} & = &  \frac{{\bf a} \cdot {\bf b}}{  \mid {\bf b} 
\mid^2}\\
c / {\bf a}   & = &  \frac{c {\bf a}  }{ \mid {\bf a} \mid^2}
\end{eqnarray*}

Both scalar multiplication and dot products are given by the same symbol, 
braces are advisable to ensure the correct
precedences in expressions such as $({\bf a} \cdot {\bf b}) 
({\bf c} \cdot {\bf d})$.

Vector exponentiation is defined as the power of the modulus:\\
${\bf a}^n \equiv  {\rm VMOD}(a)^n =   \mid {\bf a} \mid^n$

\section{Differential Operations}
Differential operators provided are div, grad, curl, delsq, and dotgrad.
\index{div operator} \index{grad operator} \index{curl operator}
\index{delsq operator} \index{dotgrad operator}
All but the last of these are prefix operators having a single
vector or scalar argument as appropriate.  Valid combinations of 
operator and argument, and the type of the result are shown in table~\ref{vvecttable}.


\begin{table}
\begin{center}
\begin{tabular}{rcl}
s & := & div ({\bf v})  \\
{\bf v} & := & grad(s) \\
{\bf v} & := & curl({\bf v})  \\
{\bf v} & := & delsq({\bf v}) \\
 s  & := & delsq(s) \\
{\bf v} & := & {\bf v}  dotgrad {\bf v}  \\
 s & := & {\bf v}  dotgrad  s 
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combinations of operator and argument}\label{vvecttable}
\end{table}

All other combinations of operator and argument type cause error
messages to be issued.  The differential operators have their usual
meanings~\cite{Speigel:59}.  The coordinate system used by these operators is
set by invoking  VSTART (cf. Sec.~\ref{vstart}).  The names {\tt h1}, 
{\tt h2}  and {\tt h3 } are
reserved for the scale factors, and {\tt u1}, {\tt u2} and {\tt u3} are 
used for the coordinates.

A vector extension, VDF, of the REDUCE procedure DF allows the 
differentiation of a vector (scalar) with respect to a scalar to be
performed.  Allowed forms are \ttindex{VDF}
VDF({\bf v}, s)  $\rightarrow$  {\bf v}   and
VDF(s, s)  $\rightarrow$   s , 
where, for example\\
\begin{eqnarray*}
{\tt vdf( B,x)} \equiv \frac{\partial {\bf B}}{\partial x}
\end{eqnarray*}

The standard REDUCE procedures DEPEND and NODEPEND have been redefined
to allow dependences of vectors to be compactly
defined.  For example \index{DEPEND statement} \index{NODEPEND statement}
\begin{verbatim}
a := svec(a1,a2,a3)$;
depend a,x,y;
\end{verbatim}
causes all three components {\tt a1},{\tt a2} and {\tt a3} of {\tt a} 
to be treated as functions of {\tt x} and {\tt y}.
Individual component dependences can still be defined if desired.
\begin{verbatim}
depend a3,z;
\end{verbatim}

The procedure VTAYLOR gives truncated Taylor series expansions of scalar
or vector functions:- \ttindex{VTAYLOR}
\begin{verbatim}
vtaylor(vex,vx,vpt,vorder);
\end{verbatim}
returns the series expansion of the expression 
VEX  with respect to variable VX \ttindex{VORDER}
about point VPT  to order VORDER.  Valid
combinations of argument types are shown in table~\ref{ORTHOVEC:validexp}. \\

\begin{table}
\begin{center}
\begin{tabular}{cccc}
VEX & VX & VPT &  VORDER \\[2ex]
{\bf v} & {\bf v} &  {\bf v} &  {\bf v}\\
{\bf v} &  {\bf v} & {\bf v} & s\\
{\bf v} & s & s & s \\
s & {\bf v} &  {\bf v} & {\bf v}   \\
s & {\bf v} & {\bf v} & s\\
s & s & s & s\\
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combination of argument types.}\label{ORTHOVEC:validexp}
\end{table}

Any other combinations cause error messages to be issued.  Elements of
VORDER must be non-negative integers, otherwise error messages are
issued.  If scalar VORDER is given for a vector expansion, expansions
in each component are truncated at the same order, VORDER.

The new version of Taylor expansion applies \index{l'H\^opital's rule}
l'H\^opital's rule in evaluating coefficients, so handle cases such as
$\sin(x) / (x) $ , etc.  which the original version of ORTHOVEC could
not. The procedure used for this is LIMIT, \ttindex{LIMIT} which can
be used directly to find the limit of a scalar function {\tt ex} of
variable {\tt x} at point {\tt pt}:-

\begin{verbatim}
ans := limit(ex,x,pt);
\end{verbatim}

\section{Integral Operations}
Definite and indefinite vector, volume and scalar line integration
procedures are included in ORTHOVEC.  They are defined as follows:
\ttindex{VINT} \ttindex{DVINT}
\ttindex{VOLINT} \ttindex{DVOLINT} \ttindex{LINEINT} \ttindex{DLINEINT}
\begin{eqnarray*}
{\rm VINT} ({\bf v},x) & = & \int {\bf v}(x)dx\\
%
{\rm DVINT} ({\bf v},x, a, b) & = & \int^b_a {\bf v} (x) dx\\
%
{\rm VOLINT} ({\bf v}) & = & \int {\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm DVOLINT}({\bf v},{\bf l},{\bf u},n) & = & \int^{\bf u}_{\bf l}
{\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm LINEINT} ({\bf v, \omega}, t) & = & \int {\bf v} \cdot {\bf dr}
\equiv \int v_i h_i \frac{\partial \omega_i}{\partial t} dt\\
%
{\rm DLINEINT} ({\bf v, \omega} t, a, b) & = & \int^b_a v_i h_i
\frac{\partial \omega_i}{\partial t} dt\\
\end{eqnarray*}

In the vector and volume integrals, ${\bf v}$ are vector or scalar,
$a, b,x$ and $n$ are scalar.  Vectors ${\bf l}$ and ${\bf u}$ contain
expressions for lower and upper bounds to the integrals.  The integer
index $n$ defines the order in which the integrals over $u_1, u_2$ and
$u_3$ are performed in order to allow for functional dependencies in
the integral bounds:

\begin{center} 
\begin{tabular}{ll}
n & order\\ 1 & $u_1~u_2~u_3$\\
%
2 & $u_3~u_1~u_2$\\
%
3 & $u_2~u_3~u_1$\\
%
4 & $u_1~u_3~u_2$\\
%
5 & $u_2~u_1~u_3$\\ otherwise & $u_3~u_2~u_1$\\
\end{tabular}
\end{center}


The vector ${\bf \omega}$ in the line integral's arguments contain
explicit paramterisation of the coordinates $u_1, u_2, u_3$ of the
line ${\bf u}(t)$ along which the integral is taken.

\begin{table}
\begin{center}
\begin{tabular}{|l c l|} \hline 
\multicolumn{1}{|c}{Procedures} & & \multicolumn{1}{c|}{Description} \\ \hline
VSTART & & select coordinate
system \\ & & \\ SVEC & & set up a vector \\ VOUT & & output a vector
\\ VECTORCOMPONENT & \_ & extract a vector component (1-3) \\ & & \\
VECTORADD & + & add two vectors or scalars \\ 
VECTORPLUS & + & unary vector or scalar plus\\ 
VECTORMINUS & - & unary vector or scalar minus\\ 
VECTORDIFFERENCE & - & subtract two vectors or scalars \\ 
VECTORQUOTIENT & / & vector divided by scalar \\ 
VECTORRECIP & / & unary vector or scalar division \\ & & \ \ \ (reciprocal)\\ 
VECTORTIMES & * & multiply vector or scalar by \\ & & \ \ \ vector/scalar \\ 
VECTORCROSS & $><$ & cross product of two vectors \\ 
VECTOREXPT & \^{} & exponentiate vector modulus or scalar \\
VMOD & & length of vector or scalar \\ \hline
\end{tabular}
\end{center}
\caption{Procedures names and operators used in ORTHOVEC (part 1)}
\end{table}

\begin{table}
\begin{center}
\begin{tabular}{|l l|} \hline 
\multicolumn{1}{|c}{Procedures} & \multicolumn{1}{c|}{Description} \\ \hline 
DIV & divergence of vector \\ 
GRAD & gradient of scalar \\ 
CURL & curl of vector \\ 
DELSQ & laplacian of scalar or vector \\ 
DOTGRAD & (vector).grad(scalar or vector) \\ &  \\ 
VTAYLOR & vector or scalar Taylor series of vector or scalar \\ 
VPTAYLOR & vector or scalar Taylor series of scalar \\ 
TAYLOR & scalar Taylor series of scalar \\
LIMIT & limit of quotient using l'H\^opital's rule \\ &  \\
VINT & vector integral \\ 
DVINT & definite vector integral \\ 
VOLINT & volume integral \\ 
DVOLINT & definite volume integral \\ 
LINEINT & line integral \\ 
DLINEINT & definite line integral \\  & \\
MAPRIN & vector extension of REDUCE MAPRIN \\
DEPEND & vector extension of REDUCE DEPEND \\
NODEPEND & vector extension of REDUCE NODEPEND \\ \hline 
\end{tabular}
\end{center}
\caption{Procedures names and operators used in ORTHOVEC (part 2)}
\end{table}


\section{Test Cases}

To use the REDUCE source version of ORTHOVEC, initiate a REDUCE
session and then IN the file {\em orthovec.red} containing ORTHOVEC.
However, it is recommended that for efficiency a compiled fast loading
version be made and LOADed when required (see Sec.~18 of the REDUCE
manual).  If coordinate dependent differential and integral operators
other than cartesian are needed, then VSTART must be used to reset
coordinates and scale factors.

Six  simple examples are given in the Test Run Output file 
{\em orthovectest.log} to illustrate the working of ORTHOVEC.  
The input lines were taken from the file
{\em orthovectest.red} (the Test Run Input), but could 
equally well be typed in at the Terminal.

\example\index{ORTHOVEC package ! example}

Show that
\begin{eqnarray*}
({\bf a}  \times {\bf b}) \cdot ({\bf c} \times {\bf d}) - ({\bf a} 
\cdot {\bf c})({\bf b} \cdot {\bf d})
 + ({\bf a} \cdot {\bf d})({\bf b} \cdot {\bf c}) \equiv 0
\end{eqnarray*}
 
\example\index{ORTHOVEC package ! example}\label{ORTHOVEC:eqm}

Write the equation of motion
\begin{eqnarray*}
\frac{\partial {\bf v}}{\partial t} + {\bf v} \cdot {\bf \nabla v} 
+ {\bf \nabla} p - curl ({\bf B}) \times {\bf B}
\end{eqnarray*}
in cylindrical coordinates.

\example\index{ORTHOVEC package ! example}\label{ORTHOVEC:taylor}

Taylor expand
\begin{itemize}
\item $\sin(x) \cos(y) +e^z$
about the point $(0,0,0)$ to third order in $x$, fourth order in $y$ and
fifth order in $z$.

\item $\sin(x)/x$ about $x$ to fifth order.

\item ${\bf v}$ about ${\bf x}=(x,y,z)$ to fifth order, where
${\bf v} = (x/ \sin(x),(e^y-1)/y,(1+z)^{10})$.
\end{itemize}

\example\index{ORTHOVEC package ! example}

Obtain the second component of the equation of motion in
example~\ref{ORTHOVEC:eqm}, and the first component of the final
vector Taylor series in example~\ref{ORTHOVEC:taylor}.

\example\index{ORTHOVEC package ! example}

Evaluate the line integral 
\begin{eqnarray*}
\int^{{\bf r}_2}_{{\bf r}_1} {\bf A} \cdot d{\bf r}
\end{eqnarray*}
from point ${\bf r}_1 = (1,1,1)$ to point
${\bf r}_2 = (2,4,8)$ along the path $(x,y,z) = (s, s^2, s^3)$ where\\
\begin{eqnarray*}
{\bf A} = (3x^2 + 5y) {\bf i} - 12xy{\bf j} + 2xyz^2{\bf k}
\end{eqnarray*}
and $({\bf i, j, k})$ are unit vectors in the ($x,y,z$) directions.

\example\index{ORTHOVEC package ! example}

Find the volume $V$ common to the intersecting cylinders $x^2 + y^2 
= r^2$ and $x^2 + z^2 = r^2$ i.e. evaluate
\begin{eqnarray*}
V = 8 \int^r_0 dx \int^{ub}_0 dy \int^{ub}_0 dz
\end{eqnarray*}
where $ub = \overline{\sqrt { r^2 - x^2}}$
\bibliography{orthovec}
\bibliographystyle{plain}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.bib0000644000175000017500000000125111526203062024643 0ustar  giovannigiovanni@ARTICLE{Eastwood:87,
 AUTHOR = "James W. Eastwood",
 TITLE = "Orthovec:  A {REDUCE} Program for {3-D} Vector Analysis
in Orthogonal Curvilinear Coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1987, VOLUME = 47, NUMBER = 1, PAGES = "139-147", MONTH = "October"}

@ARTICLE{Eastwood:91,
 AUTHOR = "James W. Eastwood",
 TITLE = "{ORTHOVEC:} version 2 of the {REDUCE} program for {3-D} vector
analysis in orthogonal curvilinear coordinates",
 JOURNAL = "Comp. Phys. Commun.",
 YEAR = 1991, VOLUME = 64, NUMBER = 1, PAGES = "121-122", MONTH = "April"}

@BOOK{Speigel:59,
  AUTHOR = "M . Speigel",
  TITLE = "Vector Analysis",
  PUBLISHER = "Scheum Publishing Co.", YEAR = 1959}
mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.rlg0000644000175000017500000000663611527635055024723 0ustar  giovannigiovanniFri Feb 18 21:27:58 2011 run on win32

*** + redefined 

*** - redefined 

*** * redefined 

*** / redefined 

*** ^ redefined 
%===========================================
%test file for ORTHOVEC version 2, June 1990
%===========================================

showtime;


Time: 0 ms


%example 1: vector identity
a:=svec(a1,a2,a3);


a := [a1,a2,a3]

b:=svec(b1,b2,b3);


b := [b1,b2,b3]

c:=svec(c1,c2,c3);


c := [c1,c2,c3]

d:=svec(d1,d2,d3);


d := [d1,d2,d3]


a>< b )$


[1] ( - df(br,th)*bt - df(br,z)*bz*r + df(bt,r)*bt*r + df(bz,r)*bz*r + df(p,r)*r

                                                         2     2
      + df(vr,r)*r*vr + df(vr,th)*vt + df(vr,z)*r*vz + bt  - vt )/r

[2] (df(br,th)*br - df(bt,r)*br*r - df(bt,z)*bz*r + df(bz,th)*bz + df(p,th)

      + df(vt,r)*r*vr + df(vt,th)*vt + df(vt,z)*r*vz - br*bt + vr*vt)/r

[3] (df(br,z)*br*r + df(bt,z)*bt*r - df(bz,r)*br*r - df(bz,th)*bt + df(p,z)*r

      + df(vz,r)*r*vr + df(vz,th)*vt + df(vz,z)*r*vz)/r

%showtime;

%example 3: Taylor expansions
on div;


on revpri;


vtaylor(sin(x)*cos(y)+e**z,svec(x,y,z),svec(0,0,0),svec(3,4,5));


         1   2    1   3    1    4     1    5        1     2    1      4    1   3
1 + z + ---*z  + ---*z  + ----*z  + -----*z  + x - ---*x*y  + ----*x*y  - ---*x
         2        6        24        120            2          24          6

    1    3  2     1    3  4
 + ----*x *y  - -----*x *y
    12           144

vtaylor(sin(x)/x,x,0,5);


     1   2     1    4
1 - ---*x  + -----*x
     6        120

te:=vtaylor(svec(x/sin(x),(e**y-1)/y,(1+z)**10),svec(x,y,z),
svec(0,0,0),5);


                  2      4                      2       3      4    5
        360 + 60*x  + 7*x    720 + 360*y + 120*y  + 30*y  + 6*y  + y
te := [--------------------,------------------------------------------,1 + 10*z
               360                             720

             2        3        4        5
       + 45*z  + 120*z  + 210*z  + 252*z ]

%showtime;

%example 4: extract components
eom _2;


 -1                -1                            -1
r  *vr*vt - br*bt*r   + df(vt,z)*vz + df(vt,th)*r  *vt + df(vt,r)*vr

             -1                 -1
 + df(p,th)*r   + df(bz,th)*bz*r   - df(bt,z)*bz - df(bt,r)*br

                 -1
 + df(br,th)*br*r

te _1;


     1   2     7    4
1 + ---*x  + -----*x
     6        360

off div;


off revpri;


%showtime;

%example 5: Line Integral
vstart$


Select Coordinate System by number

1] cartesian

2] cylindrical

3] spherical

4] general

5] others

1

coordinate type = 1

coordinates = x,y,z

scale factors = 1,1,1
dlineint(svec(3*x**2+5*y,-12*y*z,2*x*y*z**2),svec(s,s**2,s**3),s,1,2);


 68491
-------
  42

%showtime;

%example 6: Volume Integral
ub:=sqrt(r**2-x**2)$


8 * dvolint(1,svec(0,0,0),svec(r,ub,ub),6);


     3
 16*r
-------
   3


%===========================================
% end of test
%===========================================
showtime;


Time: 48 ms  plus GC time: 15 ms


;

end;


Time for test: 48 ms, plus GC time: 15 ms
@@@@@ Resources used: (0 0 5 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.tst0000644000175000017500000000221511526203062024722 0ustar  giovannigiovanni%===========================================
%test file for ORTHOVEC version 2, June 1990
%===========================================

showtime;

%example 1: vector identity
a:=svec(a1,a2,a3);
b:=svec(b1,b2,b3);
c:=svec(c1,c2,c3);
d:=svec(d1,d2,d3);

a>< b )$
%showtime;

%example 3: Taylor expansions
on div;
on revpri;
vtaylor(sin(x)*cos(y)+e**z,svec(x,y,z),svec(0,0,0),svec(3,4,5));
vtaylor(sin(x)/x,x,0,5);
te:=vtaylor(svec(x/sin(x),(e**y-1)/y,(1+z)**10),svec(x,y,z),
svec(0,0,0),5);
%showtime;

%example 4: extract components
eom _2;
te _1;
off div;
off revpri;
%showtime;

%example 5: Line Integral
vstart$
1
dlineint(svec(3*x**2+5*y,-12*y*z,2*x*y*z**2),svec(s,s**2,s**3),s,1,2);
%showtime;

%example 6: Volume Integral
ub:=sqrt(r**2-x**2)$
8 * dvolint(1,svec(0,0,0),svec(r,ub,ub),6);

%===========================================
% end of test
%===========================================
showtime;

;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.hlp0000644000175000017500000003067411526203062024705 0ustar  giovannigiovanni\chapter[ORTHOVEC: scalars and vectors]%
        {ORTHOVEC: Manipulation of scalars and vectors}
\label{ORTHOVEC}
\typeout{{ORTHOVEC: Manipulation of scalars and vectors}}

{\footnotesize
\begin{center}
James W.~Eastwood \\
AEA Technology, Culham Laboratory \\
Abingdon \\
Oxon OX14 3DB, England \\[0.05in]
e--mail: jim\_eastwood@aeat.co.uk
\end{center}
}
\ttindex{ORTHOVEC}

The ORTHOVEC package is a collection of \REDUCE\ procedures and
operations which provide a simple to use environment for the
manipulation of scalars and vectors.  Operations include addition,
subtraction, dot and cross products, division, modulus, div, grad,
curl, laplacian, differentiation, integration, ${\bf a \cdot \nabla}$
and Taylor expansion.

\section{Initialisation}\label{vstart}
\ttindex{VSTART}
The procedure \f{START} initialises ORTHOVEC. VSTART provides a
menu of standard coordinate systems:-

\begin{enumerate}
\index{cartesian coordinates}
\item cartesian $(x, y, z) = $ {\tt (x, y, z)}
\index{cylindrical coordinates}
\item cylindrical $(r, \theta, z) = $ {\tt (r, th, z)}
\index{spherical coordinates}
\item spherical $(r, \theta, \phi) = $ {\tt (r, th, ph) }
\item general $( u_1, u_2, u_3 ) = $ {\tt (u1, u2, u3) }
\item others
\end{enumerate}

which the user selects by number.  Selecting options (1)-(4)
automatically sets up the coordinates and scale factors.  Selection
option (5) shows the user how to select another coordinate system.  If
VSTART is not called, then the default cartesian coordinates are used.
ORTHOVEC may be re-initialised to a new coordinate system at any time
during a given \REDUCE\ session by typing
\begin{verbatim}
VSTART $.
\end{verbatim}

\section{Input-Output}

ORTHOVEC assumes all quantities are either scalars or 3 component
vectors.  To define a vector $a$ with components $(c_1, c_2, c_3)$ use
the procedure SVEC:\ttindex{SVEC}
\begin{verbatim}
a := svec(c1, c2, c3);
\end{verbatim}

The procedure\ttindex{VOUT} \f{VOUT} (which returns the value of its
argument) can be used to give labelled output of components
in algebraic form:
\begin{verbatim}
b := svec (sin(x)**2, y**2, z)$
vout(b)$
\end{verbatim}

The operator {\tt \_} can be used to select a particular
component (1, 2 or 3) for output {\em e.g.}
\begin{verbatim}
b_1 ;
\end{verbatim}

\section{Algebraic Operations}

Six infix operators, sum, difference, quotient, times, exponentiation
and cross product, and four prefix
operators, plus, minus, reciprocal
and  modulus are defined in ORTHOVEC.  These operators can take suitable
combinations of scalar and vector arguments,
and in the case of scalar arguments reduce to the usual definitions of
$ +, -, *, /, $ etc.

The operators are represented by symbols
\index{+ ! 3-D vector}\index{- ! 3-D vector}\index{/ ! 3-D vector}
\index{* ! 3-D vector}\index{* ! 3-D vector}\index{"\^{} ! 3-D vector}
\index{$><$ ! 3-D vector}
\begin{verbatim}
+, -, /, *, ^, ><
\end{verbatim}

\index{$><$ ! diphthong} The composite {\tt ><} is an
attempt to represent the cross product symbol
$\times$ in ASCII characters.
If we let ${\bf v}$ be a vector and $s$ be a scalar, then
valid combinations of arguments of the
procedures and operators and the type of the result
are as summarised below.  The notation used is\\
{\em result :=procedure(left argument, right argument) } or\\
{\em result :=(left operand) operator (right operand) } . \\

\underline{Vector Addition} \\
\ttindex{VECTORPLUS}\ttindex{VECTORADD}\index{vector ! addition}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORPLUS({\bf v})  &{\rm or}& {\bf v} &:=&  +  {\bf v} \\
     s  &:=& VECTORPLUS(s)  &{\rm or} &      s  &:=&  +       s  \\
{\bf v} &:=& VECTORADD({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&
{\bf v} +  {\bf v} \\
     s  &:=& VECTORADD(s,s)  &{\rm or }&      s  &:=&  s + s \\
\end{tabular} \\

\underline{Vector Subtraction} \\
\ttindex{VECTORMINUS}\ttindex{VECTORDIFFERENCE}\index{vector ! subtraction}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORMINUS({\bf v})  &{\rm or}&
 {\bf v} &:=&  -  {\bf v} \\
 s  &:=& VECTORMINUS(s)  &{\rm or} &      s  &:=&  -       s  \\
{\bf v} &:=& VECTORDIFFERENCE({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&
  {\bf v} -  {\bf v} \\
 s  &:=& VECTORDIFFERENCE(s,s)  &{\rm or }&      s  &:=&  s - s \\
\end{tabular} \\

\underline{Vector Division}\\
\ttindex{VECTORRECIP}\ttindex{VECTORQUOTIENT}\index{vector ! division}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORRECIP({\bf v})  &{\rm or}& {\bf v} &:=&  /
{\bf v} \\
 s  &:=& VECTORRECIP(s)  &{\rm or} &      s  &:=&  /       s  \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=&
{\bf v} /  {\bf v} \\
{\bf v} &:=& VECTORQUOTIENT({\bf v},    s  )  &{\rm or }& {\bf v} &:=&
{\bf v} /     s    \\
{\bf v} &:=& VECTORQUOTIENT(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&
   s    /  {\bf v} \\
     s  &:=& VECTORQUOTIENT(s,s)  &{\rm or }&      s  &:=&  s / s
       \\
\end{tabular} \\

\underline{Vector Multiplication}\\
\ttindex{VECTORTIMES}\index{vector ! multiplication}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORTIMES(   s   ,{\bf v})  &{\rm or }& {\bf v} &:=&
s    *  {\bf v} \\
{\bf v} &:=& VECTORTIMES({\bf v},   s   )  &{\rm or }& {\bf v} &:=& {\bf
 v}  *     s    \\
   s    &:=& VECTORTIMES({\bf v},{\bf v})  &{\rm or }&    s    &:=& {\bf
 v}  *  {\bf v} \\
   s    &:=& VECTORTIMES(   s   ,   s   )  &{\rm or }&    s    &:=&
s    *     s    \\
\end{tabular} \\

\underline{Vector Cross Product} \\
\ttindex{VECTORCROSS}\index{cross product}\index{vector ! cross product}
\begin{tabular}{rclcrcl}
{\bf v} &:=& VECTORCROSS({\bf v},{\bf v})  &{\rm or }& {\bf v} &:=& {\bf
 v} $\times$   {\bf v} \\
\end{tabular} \\

\underline{Vector Exponentiation}\\
\ttindex{VECTOREXPT}\index{vector ! exponentiation}
\begin{tabular}{rclcrcl}
   s    &:=& VECTOREXPT ({\bf v},   s   )  &{\rm or }&    s    &:=& {\bf
 v}  \^{} s   \\
   s    &:=& VECTOREXPT (   s   ,   s   )  &{\rm or }&    s    &:=&    s
     \^{} s   \\
\end{tabular} \\

\underline{Vector Modulus}\\
\ttindex{VMOD}\index{vector ! modulus}
\begin{tabular}{rcl}
   s    &:=& VMOD (s)\\
   s    &:=& VMOD ({\bf v}) \\
\end{tabular} \\

All other combinations of operands for these operators lead to error
messages being issued.  The first two instances of vector
multiplication are scalar multiplication of vectors, the third is the
\index{vector ! dot product}\index{vector ! inner product}
\index{inner product}\index{dot product}
product of two scalars and the last is the inner (dot) product.  The
prefix operators  {\tt +, -, /} can take either scalar or vector
arguments and return results of the same type as their arguments.
VMOD returns a scalar.

In compound expressions, parentheses may be used to specify the order of
combination.  If parentheses are omitted the ordering of the
operators, in increasing order of precedence is
\begin{verbatim}
+ | - | dotgrad | * | >< | ^ | _
\end{verbatim}
and these are placed in the precedence list defined in \REDUCE{}
after $<$.

Vector divisions are defined as follows:  If ${\bf a}$ and ${\bf b}$ are
vectors and $c$ is a scalar, then
\begin{eqnarray*}
{\bf a} /  {\bf b} & = &  \frac{{\bf a} \cdot {\bf b}}{  \mid {\bf b}
\mid^2}\\
c / {\bf a}   & = &  \frac{c {\bf a}  }{ \mid {\bf a} \mid^2}
\end{eqnarray*}

Both scalar multiplication and dot products are given by the same symbol,
braces are advisable to ensure the correct
precedences in expressions such as $({\bf a} \cdot {\bf b})
({\bf c} \cdot {\bf d})$.

Vector exponentiation is defined as the power of the modulus:\\
${\bf a}^n \equiv  {\rm VMOD}(a)^n =   \mid {\bf a} \mid^n$

\section{Differential Operations}
Differential operators provided are div, grad, curl, delsq, and dotgrad.
\index{div operator}\index{grad operator}\index{curl operator}
\index{delsq operator}\index{dotgrad operator}
All but the last of these are prefix operators having a single
vector or scalar argument as appropriate.  Valid combinations of
operator and argument, and the type of the result are shown in
table~\ref{vvecttable}.


\begin{table}
\begin{center}
\begin{tabular}{rcl}
s & := & div ({\bf v})  \\
{\bf v} & := & grad(s) \\
{\bf v} & := & curl({\bf v})  \\
{\bf v} & := & delsq({\bf v}) \\
 s  & := & delsq(s) \\
{\bf v} & := & {\bf v}  dotgrad {\bf v}  \\
 s & := & {\bf v}  dotgrad  s
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combinations of operator and argument}\label{vvecttable}
\end{table}

All other combinations of operator and argument type cause error
messages to be issued.  The differential operators have their usual
meanings.  The coordinate system used by these operators is
set by invoking  VSTART (cf. Sec.~\ref{vstart}).  The names {\tt h1},
{\tt h2}  and {\tt h3 } are
reserved for the scale factors, and {\tt u1}, {\tt u2} and {\tt u3} are
used for the coordinates.

A vector extension, VDF, of the \REDUCE\ procedure DF allows the
differentiation of a vector (scalar) with respect to a scalar to be
performed.  Allowed forms are\ttindex{VDF}
VDF({\bf v}, s)  $\rightarrow$  {\bf v}   and
VDF(s, s)  $\rightarrow$   s ,
where, for example\\
\begin{eqnarray*}
{\tt vdf( B,x)} \equiv \frac{\partial {\bf B}}{\partial x}
\end{eqnarray*}

The standard \REDUCE\ procedures DEPEND and NODEPEND have been redefined
to allow dependences of vectors to be compactly
defined.  For example\index{DEPEND statement}\index{NODEPEND statement}
\begin{verbatim}
a := svec(a1,a2,a3)$;
depend a,x,y;
\end{verbatim}
causes all three components {\tt a1},{\tt a2} and {\tt a3} of {\tt a}
to be treated as functions of {\tt x} and {\tt y}.
Individual component dependences can still be defined if desired.
\begin{verbatim}
depend a3,z;
\end{verbatim}

The procedure VTAYLOR gives truncated Taylor series expansions of scalar
or vector functions:-\ttindex{VTAYLOR}
\begin{verbatim}
vtaylor(vex,vx,vpt,vorder);
\end{verbatim}
returns the series expansion of the expression
VEX  with respect to variable VX\ttindex{VORDER}
about point VPT  to order VORDER.  Valid
combinations of argument types are shown in table~\ref{ORTHOVEC:validexp}. \\

\begin{table}
\begin{center}
\begin{tabular}{cccc}
VEX & VX & VPT &  VORDER \\[2ex]
{\bf v} & {\bf v} &  {\bf v} &  {\bf v}\\
{\bf v} &  {\bf v} & {\bf v} & s\\
{\bf v} & s & s & s \\
s & {\bf v} &  {\bf v} & {\bf v}   \\
s & {\bf v} & {\bf v} & s\\
s & s & s & s\\
\end{tabular}
\end{center}
\caption{ORTHOVEC valid combination of argument types.}\label{ORTHOVEC:validexp}
\end{table}

Any other combinations cause error messages to be issued.  Elements of
VORDER must be non-negative integers, otherwise error messages are
issued.  If scalar VORDER is given for a vector expansion, expansions
in each component are truncated at the same order, VORDER.

The new version of Taylor expansion applies\index{l'H\^opital's rule}
l'H\^opital's rule in evaluating coefficients, so handle cases such as
$\sin(x) / (x) $ , etc.  which the original version of ORTHOVEC could
not. The procedure used for this is LIMIT,\ttindex{LIMIT} which can
be used directly to find the limit of a scalar function {\tt ex} of
variable {\tt x} at point {\tt pt}:-

\begin{verbatim}
ans := limit(ex,x,pt);
\end{verbatim}

\section{Integral Operations}
Definite and indefinite vector, volume and scalar line integration
procedures are included in ORTHOVEC.  They are defined as follows:
\ttindex{VINT}\ttindex{DVINT}
\ttindex{VOLINT}\ttindex{DVOLINT}\ttindex{LINEINT}\ttindex{DLINEINT}
\begin{eqnarray*}
{\rm VINT} ({\bf v},x) & = & \int {\bf v}(x)dx\\
%
{\rm DVINT} ({\bf v},x, a, b) & = & \int^b_a {\bf v} (x) dx\\
%
{\rm VOLINT} ({\bf v}) & = & \int {\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm DVOLINT}({\bf v},{\bf l},{\bf u},n) & = & \int^{\bf u}_{\bf l}
{\bf v} h_1 h_2 h_3 du_1 du_2 du_3\\
%
{\rm LINEINT} ({\bf v, \omega}, t) & = & \int {\bf v} \cdot {\bf dr}
\equiv \int v_i h_i \frac{\partial \omega_i}{\partial t} dt\\
%
{\rm DLINEINT} ({\bf v, \omega} t, a, b) & = & \int^b_a v_i h_i
\frac{\partial \omega_i}{\partial t} dt\\
\end{eqnarray*}

In the vector and volume integrals, ${\bf v}$ are vector or scalar,
$a, b,x$ and $n$ are scalar.  Vectors ${\bf l}$ and ${\bf u}$ contain
expressions for lower and upper bounds to the integrals.  The integer
index $n$ defines the order in which the integrals over $u_1, u_2$ and
$u_3$ are performed in order to allow for functional dependencies in
the integral bounds:

\begin{center}
\begin{tabular}{ll}
n & order\\ 1 & $u_1~u_2~u_3$\\
%
2 & $u_3~u_1~u_2$\\
%
3 & $u_2~u_3~u_1$\\
%
4 & $u_1~u_3~u_2$\\
%
5 & $u_2~u_1~u_3$\\ otherwise & $u_3~u_2~u_1$\\
\end{tabular}
\end{center}


The vector ${\bf \omega}$ in the line integral's arguments contain
explicit parameterisation of the coordinates $u_1, u_2, u_3$ of the
line ${\bf u}(t)$ along which the integral is taken.

mathpiper-0.81f+svn4469+dfsg3/src/packages/orthovec/orthovec.red0000644000175000017500000004273411526203062024674 0ustar  giovannigiovannimodule orthovec;  % 3-D vector calculus package.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(orthovec),'(contrib avector));

%          %========================================%
%          %              ORTHOVEC                  %
%          %========================================%
%          %     A 3-D VECTOR CALCULUS PACKAGE      %
%          %     USING ORTHOGONAL CURVILINEAR       %
%          %            COORDINATES                 %
%          %                                        %
%          %   copyright James W Eastwood,          %
%          %             Culham Laboratory,         %
%          %             Abingdon, Oxon.            %
%          %                                        %
%          %             February 1987              %
%          %                                        %
%          %   This new version differs from the    %
%          %   original version published in CPC,   %
%          %   47(1987)139-147 in the following     %
%          %   respects:                            %
%          %                                        %
%          %   *.+.,etc replaced by +,-,*,/         %
%          %   *unary vector +,-,/ introduced       %
%          %   *vector component selector _         %
%          %   *general tidy up                     %
%          %   *L'Hopitals rule in Taylor series    %
%          %   *extended division definition        %
%          %   *algebraic output of lisp vectors    %
%          %   *exponentiation of vectors           %
%          %   *vector extension of depend          %
%          %                                        %
%          %            Version 2                   %
%          %        All rights reserved             %
%          %     copyright James W Eastwood         %
%          %             June 1990                  %
%          %                                        %
%          %   This is a preliminary version of     %
%          %   the NEW VERSION of ORTHOVEC which    %
%          %   will be available from the Computer  %
%          %   Physics Communications Program       %
%          %   Library, Dept. of Applied Maths and  %
%          %   Theoretical Physics, The Queen's     %
%          %   University of Belfast, Belfast       %
%          %   BT7 1NN, Northern Ireland.           %
%          %   See any copy of CPC for further      %
%          %   details of the library services.     %
%          %                                        %
%          %========================================%
%          %       REDUCE 3.4 is assumed            %
%          %========================================%
%
%
%
%-------------------------------------------------------------------
%                       INITIALISATION
%%

algebraic;

%select coordinate system
%========================
procedure vstart0;
begin scalar ctype;
write "Select Coordinate System by number";
write "1] cartesian";
write "2] cylindrical";
write "3] spherical";
write "4] general";
write "5] others";
%remove previous settings
clear u1,u2,u3,h1,h2,h3;
depend h1,u1,u2,u3;
depend h2,u1,u2,u3;
depend h3,u1,u2,u3;
nodepend h1,u1,u2,u3;
nodepend h2,u1,u2,u3;
nodepend h3,u1,u2,u3;
%select coordinate system
ctype := symbolic read();
if ctype=1 then
 << u1:=x;u2:=y;u3:=z;h1:=1;h2:=1;h3:=1 >>
 else if ctype=2 then
  << u1:=r;u2:=th;u3:=z;h1:=1;h2:=r;h3:=1 >>
  else if ctype=3 then
   << u1:=r;u2:=th;u3:=ph;h1:=1;h2:=r;h3:=r*sin(th) >>
   else if ctype=4 then
    << depend h1,u1,u2,u3;depend h2,u1,u2,u3;depend h3,u1,u2,u3 >>
    else << write "To define another coordinate system, give values ";
    write "to components u1,u2,u3 and give functional form or";
    write "DEPEND for scale factors h1,h2 and h3. For example,";
write "to set up paraboloidal coords u,v,w type in:-";
write "u1:=u;u2:=v;u3:=w;h1:=sqrt(u**2+v**2);h2:=h1;h3:=u*v;">>;
write "coordinate type = ",ctype;
write "coordinates = ",u1,",",u2,",",u3;
write "scale factors = ",h1,",",h2,",",h3;
return
end$
let vstart=vstart0()$

%give access to lisp vector procedures
%=======================================
symbolic operator putv,getv,mkvect;
flag('(vectorp), 'direct);
flag('(vectorp), 'boolean);

%-------------------------------------------------------------------
%                      INPUT-OUTPUT
%
%set a new vector
%===================
procedure svec(c1,c2,c3);
begin scalar a;a:=mkvect(2);
putv(a,0,c1);putv(a,1,c2);putv(a,2,c3);
return a
end$

%output a vector
%===============
procedure vout(v);
begin;
if vectorp(v) then
  for j:=0:2 do write "[",j+1,"] ",getv(v,j)
  else write v;
return v
end$

%-------------------------------------------------------------------
%               REDEFINITION OF SOME STANDARD PROCEDURES
%
% Vector extension of standard definitions of depend and nodepend.

remflag('(depend nodepend),'lose);   % We must use these definitions.

symbolic procedure depend u;
begin scalar v,w; v:= !*a2k car u;
for each x in cdr u do
if vectorp(v) then
 for ic:=0:upbv(v) do
 <>
 else depend1(car u,x,t)
end$

symbolic procedure nodepend u;
begin scalar v,w;
rmsubs();
v:= !*a2k car u;
for each x in cdr u do
if vectorp(v) then
 for ic:=0:upbv(v) do
 <>
 else depend1(car u,x,nil)
end $

%
%-------------------------------------------------------------------
%                      ALGEBRAIC OPERATIONS
%
%define symbols for vector algebra
%=====================================
newtok '(( !+ ) vectoradd);
newtok '(( !- ) vectordifference);
newtok '((!> !< ) vectorcross);
newtok '(( !* ) vectortimes);
newtok '(( !/ ) vectorquotient);
newtok '(( !_ ) vectorcomponent);
newtok '(( !^ ) vectorexpt);
%
%define operators
%================
operator vectorminus,vectorplus,vectorrecip;
infix vectoradd,vectordifference,vectorcross,vectorexpt,
      vectorcomponent,vectortimes,vectorquotient,dotgrad;
precedence vectoradd,<;
precedence vectordifference,vectoradd;
precedence dotgrad,vectordifference;
precedence vectortimes,dotgrad;
precedence vectorcross,vectortimes;
precedence vectorquotient,vectorcross;
precedence vectorexpt,vectorquotient;
precedence vectorcomponent,vectorexpt;

deflist( '(
   (vectordifference vectorminus)
   (vectoradd vectorplus)
   (vectorquotient vectorrecip)
   (vectorrecip vectorrecip)
 ), 'unary)$

deflist('((vectorminus vectorplus) (vectorrecip vectortimes)),
                 'alt)$

%extract component of a vector
%=============================
procedure vectorcomponent(v,ic);
if vectorp(v) then
  if ic=1 or ic=2 or ic=3 then getv(v,ic-1)
    else rerror(orthovec,1,"Incorrect component number")
  else rerror(orthovec,2,"Not a vector")$

%
%add vector or scalar pair v1 and v2
%===================================
procedure vectoradd(v1,v2);
begin scalar v3;
if vectorp(v1) and vectorp(v2) then
  <>
  else
  if not(vectorp(v1)) and not(vectorp(v2)) then v3:=plus(v1, v2)
     else rerror(orthovec,3,"Incorrect args to vector add");
return v3
end$

%unary plus
%==========
procedure vectorplus(v);v$
%
%negate vector or scalar v
%=========================
procedure vectorminus(v);
begin scalar v3;
if vectorp(v) then
  <>
  else v3:=minus(v);
return v3
end$

%scalar or vector subtraction
%============================
procedure vectordifference(v1,v2);(v1 + vectorminus(v2))$

%dot product or scalar times
%===========================
procedure vectortimes(v1,v2);
begin scalar v3;
if vectorp(v1) and vectorp(v2) then
  v3:= for ic:=0:2 sum times(getv(v1,ic),getv(v2,ic))
  else
  if not(vectorp(v1)) and not(vectorp(v2)) then
    v3:=times(v1 , v2 )
    else if vectorp(v1) and not(vectorp(v2)) then
      <>
      else
      <>;
return v3
end$

%vector cross product
%====================
procedure vectorcross(v1,v2);
begin scalar v3;
if vectorp(v1) and vectorp(v2) then
  <>
  else rerror(orthovec,4,"Incorrect args to vector cross product");
return v3
end$

%vector division
%===============
procedure vectorquotient(v1,v2);
if vectorp(v1) then
 if vectorp(v2) then
  quotient (v1*v2,v2*v2)
  else v1*recip(v2)
 else if vectorp(v2) then
  v1*v2*recip(v2*v2)
  else quotient(v1,v2)$

procedure vectorrecip(v);
if vectorp(v) then
 v*recip(v*v)
 else recip(v)$

%length of vector
%================
procedure vmod(v);sqrt(v * v)$

%vector exponentiation
%=====================
procedure vectorexpt(v,n);
if vectorp(v) then expt(vmod(v),n) else expt(v,n)$

%-------------------------------------------------------------------
%                      DIFFERENTIAL OPERATIONS
%

%div
%===
procedure div(v);
if vectorp(v) then
  (df(h2*h3*getv(v,0),u1)+df(h3*h1*getv(v,1),u2)
    +df(h1*h2*getv(v,2),u3))/h1/h2/h3
  else rerror(orthovec,5,"Incorrect arguments to div")$

%grad
%====
procedure grad(s);
begin scalar v;
v:=mkvect(2);
if vectorp(s) then
  rerror(orthovec,6,"Incorrect argument to grad")
  else << putv(v,0,df(s,u1)/h1);
          putv(v,1,df(s,u2)/h2);
          putv(v,2,df(s,u3)/h3) >>;
return v
end$

%curl
%====
procedure curl(v);
begin scalar v1;
v1:=mkvect(2);
if vectorp(v) then
  << putv(v1,0,(df(h3*getv(v,2),u2)-df(h2*getv(v,1),u3))/h2/h3);
     putv(v1,1,(df(h1*getv(v,0),u3)-df(h3*getv(v,2),u1))/h3/h1);
     putv(v1,2,(df(h2*getv(v,1),u1)-df(h1*getv(v,0),u2))/h1/h2) >>
  else rerror(orthovec,7,"Incorrect argument to curl");
return v1
end$

%laplacian
%=========
procedure delsq(v);
if vectorp(v) then (grad(div(v)) - curl(curl(v))) else div(grad(v))$

%differentiation
%===============
procedure vdf(v,x);
begin scalar v1;
if vectorp(x) then
  rerror(orthovec,8,"Second argument to VDF must be scalar")
  else if vectorp(v) then
    <>
    else v1:=df(v,x);
return v1
end$

%v1.grad(v2)
%===========
procedure dotgrad(v1,v2);
if vectorp(v1) then
  if vectorp(v2) then
    (1/2)*(grad(v1 * v2) + v1 * div(v2)  - div(v1) * v2
          - (curl(v1 >< v2) + v1 >< curl(v2) - curl(v1) >< v2 ))
    else v1 * grad(v2)
  else rerror(orthovec,9,"Incorrect arguments to dotgrad")$

%3-D Vector Taylor Expansion about vector point
%==============================================
procedure vtaylor(vex,vx,vpt,vorder);
%note: expression vex, variable vx, point vpt and order vorder
%      are any legal mixture of vectors and scalars
begin scalar vseries;
if vectorp(vex) then
  <>
  else vseries:=vptaylor(vex,vx,vpt,vorder);
return vseries
end$

%Scalar Taylor expansion about vector point
%==========================================
procedure vptaylor(sex,vx,vpt,vorder);
%vector variable
if vectorp(vx) then
  if vectorp(vpt) then
%vector order
    if vectorp(vorder) then
      taylor( taylor( taylor( sex,
      getv(vx,0), getv(vpt,0), getv(vorder,0) ),
      getv(vx,1), getv(vpt,1), getv(vorder,1) ),
      getv(vx,2), getv(vpt,2), getv(vorder,2) )
      else
      taylor( taylor( taylor( sex,
      getv(vx,0), getv(vpt,0), vorder),
      getv(vx,1), getv(vpt,1), vorder),
      getv(vx,2), getv(vpt,2), vorder)
    else rerror(orthovec,10,"VTAYLOR: vector VX mismatches scalar VPT")
%scalar variable
  else if vectorp(vpt) then
    rerror(orthovec,11,"VTAYLOR: scalar VX mismatches vector VPT")
    else if vectorp(vorder) then
      rerror(orthovec,12,"VTAYLOR: scalar VX mismatches vector VORDER")
      else taylor(sex,vx,vpt,vorder)$

%Scalar Taylor expansion of ex wrt x about point pt to order n
%=============================================================
procedure taylor(ex,x,pt,n);
begin scalar term,series,dx,mfac;
if numberp n then <<
  mfac:=1;dx:=x-pt;term:=ex;
  series:= limit(ex,x,pt) +
  for k:=1:n sum limit((term:=df(term,x)),x,pt)*(mfac:=mfac*dx/k) >>
  else rerror(orthovec,13,
              "Truncation orders of Taylor series must be integers");
return series
end$
%
%limiting value of exression ex as x tends to pt
%===============================================
procedure limit(ex,x,pt);
begin scalar lim,denex,numex;
%polynomial
lim:=if (denex:=den(ex))=1 then sub(x=pt,ex)
 else
%zero denom rational
 if sub(x=pt,denex)=0 then
%l'hopital's rule
  << if sub(x=pt,(numex:=num(ex)))=0 then
   limit(df(numex,x)/df(denex,x),x,pt)
%singular
   else rerror(orthovec,14,"Singular coefficient found by LIMIT")>>
%nonzero denom rational
  else sub(x=pt,ex);
return lim
end$
%
%-------------------------------------------------------------------
%                      INTEGRAL OPERATIONS
%
% Vector Integral
%================
procedure vint(v,x);
begin scalar v1;
if vectorp(x) then
  rerror(orthovec,15,"Second argument to VINT must be scalar")
  else if vectorp(v) then
    <>
    else v1:=int(v,x);
return v1
end$

%Definite Vector Integral
%========================
procedure dvint(v,x,xlb,xub);
begin scalar integr,intval;
if vectorp(xlb) or vectorp(xub)
  then rerror(orthovec,16,"Limits to DVINT must be scalar")
  else if vectorp(v) then
    <> >>
    else
    <>;
return intval
end$

%Volume Integral
%===============
procedure volint(v);
begin scalar v1;
if vectorp(v) then
  <>
  else v1:= int( int( int(v*h1*h2*h3,u1),u2),u3);
return v1
end$

%Definite Volume Integral
%========================
procedure dvolint(v,vlb,vub,n);
begin scalar v1,intgrnd;
if vectorp(vlb) and vectorp(vub) then
  <>
  else rerror(orthovec,17,"Bounds to DVOLINT must be vectors");
return v1
end$

%Scalar Line Integral
%====================
procedure lineint(v,vline,tt);
if vectorp(v) and vectorp(vline) and not vectorp(tt) then
 int(sub( u1=getv(vline,0), u2=getv(vline,1), u3=getv(vline,2),
  getv(v,0) * df(getv(vline,0),tt) *  h1 +
  getv(v,1) * df(getv(vline,1),tt) *  h2 +
  getv(v,2) * df(getv(vline,2),tt) *  h3 ) , tt)
 else rerror(orthovec,18,"Incorrect arguments to LINEINT")$

%Definite Scalar Line Integral
%=============================
procedure dlineint(v,vline,tt,tlb,tub);
begin scalar integr,intval;
if vectorp(tlb) or vectorp(tub)
  then rerror(orthovec,19,"Limits to DLINEINT must be scalar")
  else <>;
return intval
end$

%
%-------------------------------------------------------------------
%        SET DEFAULT COORDINATES TO CARTESIAN
%
% write "Cartesian coordinates selected by default";
% write "If you wish to change this then type VSTART";
% write "and follow the instructions given.";
% write "u1,u2,u3 are reserved for coordinate names";
% write "h1,h2,h3 are reserved for scale factor names";
ctype:=1$u1:=x$u2:=y$u3:=z$h1:=1$h2:=1$h3:=1$
% write "coordinate type = ",ctype;
% write "coordinates = ",u1,",",u2,",",u3;
% write "scale factors = ",h1,",",h2,",",h3;

%-------------------------------------------------------------------

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/0000755000175000017500000000000011722677364022361 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geoprover.rlg0000644000175000017500000005441611527635055025103 0ustar  giovannigiovanniFri Feb 18 21:28:57 2011 run on win32

 Geoprover  1.3a  Last update  December 30, 2002
% GeoProver test file for Reduce, created on Jan 18 2003
load cali,geoprover;


off nat;

 on echo;


in "$reduce/packages/geometry/supp.red"$


geo_simplify$

geo_normal$

geo_subs$

geo_gbasis$

geo_groebfactor$

geo_normalf$

geo_eliminate$

geo_solve$

geo_solveconstrained$

geo_eval$


% Example Arnon
% 
% The problem:
% Let $ABCD$ be a square and $P$ a point on the line parallel to $BD$
% through $C$ such that $l(BD)=l(BP)$, where $l(BD)$ denotes the
% distance between $B$ and $D$. Let $Q$ be the intersection point of
% $BF$ and $CD$. Show that $l(DP)=l(DQ)$.
% 
% The solution:

vars_:=List(x1, x2, x3);


vars_ := {x1,x2,x3}$

% Points
A__:=Point(0,0);


a__ := {0,0}$
 B__:=Point(1,0);


b__ := {1,0}$
 P__:=Point(x1,x2);


p__ := {x1,x2}$

% coordinates
D__:=rotate(A__,B__,1/2);


d__ := {0,1}$

C__:=par_point(D__,A__,B__);


c__ := {1,1}$
 
Q__:=varpoint(D__,C__,x3);


q__ := {x3,1}$

% polynomials
polys_:=List(on_line(P__,par_line(C__,pp_line(B__,D__))),
  eq_dist(B__,D__,B__,P__), on_line(Q__,pp_line(B__,P__)));


polys_ := {x1 + x2 - 2,
 - x1**2 + 2*x1 - x2**2 + 1,
 - x1 + x2*x3 - x2 + 1}$

% conclusion
con_:=eq_dist(D__,P__,D__,Q__);


con_ := x1**2 + x2**2 - 2*x2 - x3**2 + 1$

% solution
gb_:=geo_gbasis(polys_,vars_);


gb_ := {x3**2 + 2*x3 - 2,2*x2 - x3 - 2,2*x1 + x3 - 2}$

result_:=geo_normalf(con_,gb_,vars_);


result_ := 0$



% Example CircumCenter_1
% 
% The problem:
% The intersection point of the midpoint perpendiculars is the
% center of the circumscribed circle.
% 
% The solution:

parameters_:=List(a1, a2, b1, b2, c1, c2);


parameters_ := {a1,
a2,
b1,
b2,
c1,
c2}$

% Points
A__:=Point(a1,a2);


a__ := {a1,a2}$

B__:=Point(b1,b2);


b__ := {b1,b2}$

C__:=Point(c1,c2);


c__ := {c1,c2}$

% coordinates
M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));


m__ := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1
**2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - 
a2*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$

% conclusion
result_:=List( eq_dist(M__,A__,M__,B__), eq_dist(M__,A__,M__,C__) );


result_ := {0,0}$



% Example EulerLine_1
% 
% The problem:
% Euler's line: The center $M$ of the circumscribed circle,
% the orthocenter $H$ and the barycenter $S$ are collinear and $S$
% divides $MH$ with ratio 1:2.
% 
% The solution:

parameters_:=List(a1, a2, b1, b2, c1, c2);


parameters_ := {a1,
a2,
b1,
b2,
c1,
c2}$

% Points
A__:=Point(a1,a2);


a__ := {a1,a2}$

B__:=Point(b1,b2);


b__ := {b1,b2}$

C__:=Point(c1,c2);


c__ := {c1,c2}$

% coordinates
S__:=intersection_point(median(A__,B__,C__),median(B__,C__,A__));


s__ := {(a1 + b1 + c1)/3,(a2 + b2 + c2)/3}$

M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));


m__ := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1
**2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - 
a2*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$

H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));


h__ := {( - a1*a2*b1 + a1*a2*c1 + a1*b1*b2 - a1*c1*c2 - a2**2*b2 + a2**2*c2 + a2
*b2**2 - a2*c2**2 - b1*b2*c1 + b1*c1*c2 - b2**2*c2 + b2*c2**2)/(a1*b2 - a1*c2 - 
a2*b1 + a2*c1 + b1*c2 - b2*c1),
(a1**2*b1 - a1**2*c1 + a1*a2*b2 - a1*a2*c2 - a1*b1**2 + a1*c1**2 - a2*b1*b2 + a2
*c1*c2 + b1**2*c1 + b1*b2*c2 - b1*c1**2 - b2*c1*c2)/(a1*b2 - a1*c2 - a2*b1 + a2*
c1 + b1*c2 - b2*c1)}$

% conclusion
result_:=List(is_collinear(M__,H__,S__), sqrdist(S__,fixedpoint(M__,H__,1/3)));


result_ := {0,0}$



% Example Brocard_3
% 
% The problem:
% Theorem about the Brocard points:
% Let $\Delta\,ABC$ be a triangle. The circles $c_1$ through $A,B$ and
% tangent to $g(AC)$, $c_2$ through $B,C$ and tangent to $g(AB)$, and
% $c_3$ through $A,C$ and tangent to $g(BC)$ pass through a common
% point.
% 
% The solution:

parameters_:=List(u1, u2);


parameters_ := {u1,u2}$

% Points
A__:=Point(0,0);


a__ := {0,0}$

B__:=Point(1,0);


b__ := {1,0}$

C__:=Point(u1,u2);


c__ := {u1,u2}$

% coordinates
M_1_:=intersection_point(altitude(A__,A__,C__),p_bisector(A__,B__));


m_1_ := {1/2,( - u1)/(2*u2)}$

M_2_:=intersection_point(altitude(B__,B__,A__),p_bisector(B__,C__));


m_2_ := {1,(u1**2 - 2*u1 + u2**2 + 1)/(2*u2)}$

M_3_:=intersection_point(altitude(C__,C__,B__),p_bisector(A__,C__));


m_3_ := {( - u1**2 + 2*u1 - u2**2)/2,(u1**3 - u1**2 + u1*u2**2 + u2**2)/(2*u2)}$

c1_:=pc_circle(M_1_,A__);


c1_ := {u2, - u2,u1,0}$

c2_:=pc_circle(M_2_,B__);


c2_ := {u2, - 2*u2, - u1**2 + 2*u1 - u2**2 - 1,u2}$

c3_:=pc_circle(M_3_,C__);


c3_ := {u2,
u2*(u1**2 - 2*u1 + u2**2),
 - u1**3 + u1**2 - u1*u2**2 - u2**2,
0}$

P__:=other_cc_point(B__,c1_,c2_);


p__ := {(u1**3 - u1**2 + u1*u2**2 + u1 + u2**2)/(u1**4 - 2*u1**3 + 2*u1**2*u2**2
 + 3*u1**2 - 2*u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1),
(u2*(u1**2 - 2*u1 + u2**2 + 1))/(u1**4 - 2*u1**3 + 2*u1**2*u2**2 + 3*u1**2 - 2*
u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1)}$

% conclusion
result_:= on_circle(P__,c3_);


result_ := 0$



% Example Feuerbach_1
% 
% The problem:
% Feuerbach's circle or nine-point circle: The midpoint $N$ of $MH$ is
% the center of a circle that passes through nine special points, the
% three pedal points of the altitudes, the midpoints of the sides of the
% triangle and the midpoints of the upper parts of the three altitudes.
% 
% The solution:

parameters_:=List(u1, u2, u3);


parameters_ := {u1,u2,u3}$

% Points
A__:=Point(0,0);


a__ := {0,0}$

B__:=Point(u1,0);


b__ := {u1,0}$

C__:=Point(u2,u3);


c__ := {u2,u3}$

% coordinates
H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));


h__ := {u2,(u2*(u1 - u2))/u3}$

D__:=intersection_point(pp_line(A__,B__),pp_line(H__,C__));


d__ := {u2,0}$

M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));


m__ := {u1/2,( - u1*u2 + u2**2 + u3**2)/(2*u3)}$

N__:=midpoint(M__,H__);


n__ := {(u1 + 2*u2)/4,(u1*u2 - u2**2 + u3**2)/(4*u3)}$

% conclusion
result_:=List( eq_dist(N__,midpoint(A__,B__),N__,midpoint(B__,C__)),
  eq_dist(N__,midpoint(A__,B__),N__,midpoint(H__,C__)),
  eq_dist(N__,midpoint(A__,B__),N__,D__) );


result_ := {0,0,0}$



% Example FeuerbachTangency_1
% 
% The problem:
% For an arbitrary triangle $\Delta\,ABC$ Feuerbach's circle (nine-point
% circle) is tangent to its 4 tangent circles.
% 
% The solution:

vars_:=List(x1, x2);


vars_ := {x1,x2}$

parameters_:=List(u1, u2);


parameters_ := {u1,u2}$

% Points
A__:=Point(0,0);


a__ := {0,0}$

B__:=Point(2,0);


b__ := {2,0}$

C__:=Point(u1,u2);


c__ := {u1,u2}$

P__:=Point(x1,x2);


p__ := {x1,x2}$

% coordinates
M__:=intersection_point(p_bisector(A__,B__), p_bisector(B__,C__));


m__ := {1,(u1**2 - 2*u1 + u2**2)/(2*u2)}$

H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));


h__ := {u1,(u1*( - u1 + 2))/u2}$

N__:=midpoint(M__,H__);


n__ := {(u1 + 1)/2,( - u1**2 + 2*u1 + u2**2)/(4*u2)}$

c1_:=pc_circle(N__,midpoint(A__,B__));


c1_ := {2*u2,
 - 2*u2*(u1 + 1),
u1**2 - 2*u1 - u2**2,
2*u1*u2}$

Q__:=pedalpoint(P__,pp_line(A__,B__));


q__ := {x1,0}$

% polynomials
polys_:=List(on_bisector(P__,A__,B__,C__), on_bisector(P__,B__,C__,A__));


polys_ := {2*( - 2*u1*x1*x2 + 4*u1*x2 + u2*x1**2 - 4*u2*x1 - u2*x2**2 + 4*u2 + 4
*x1*x2 - 8*x2),
2*( - u1**3*x2 + u1**2*u2*x1 - u1**2*u2 + u1**2*x1*x2 + 2*u1**2*x2 - u1*u2**2*x2
 - u1*u2*x1**2 + u1*u2*x2**2 - 2*u1*x1*x2 + u2**3*x1 - u2**3 - u2**2*x1*x2 + 2*
u2**2*x2 + u2*x1**2 - u2*x2**2)}$

% conclusion
con_:=is_cc_tangent(pc_circle(P__,Q__),c1_);


con_ := 16*u2*( - u1**3*x1*x2 + u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1**
2*u2*x2**2 + u1**2*u2 + u1**2*x1**2*x2 + u1**2*x1*x2 - 2*u1**2*x2 + u1*u2**2*x1*
x2 - u1*u2**2*x2 - 2*u1*u2*x1**3 + 4*u1*u2*x1**2 - 2*u1*u2*x1 + 2*u1*u2*x2**2 - 
2*u1*x1**2*x2 + 2*u1*x1*x2 - u2**2*x1**2*x2 + u2**2*x1*x2 + u2*x1**4 - 2*u2*x1**
3 + u2*x1**2 - u2*x2**2)$

% solution
gb_:=geo_gbasis(polys_,vars_);


gb_ := {u1**2*u2*x2**2 - 2*u1**2*x2**3 - 2*u1*u2*x2**2 + 4*u1*x2**3 + u2**3*x2**
2 - u2**3 - 2*u2**2*x2**3 + 4*u2**2*x2 + u2*x2**4 - 4*u2*x2**2,
 - u1**2*u2*x2 - 2*u1**2*x2**2 + u1*u2**2*x1 - u1*u2**2 + 2*u1*u2*x2 + 4*u1*x2**
2 - u2**2*x1 - u2**2*x2**2 + 2*u2**2 + u2*x2**3 - 4*u2*x2}$

result_:=geo_normalf(con_,gb_,vars_);


result_ := 0$



% Example GeneralizedFermatPoint_1
% 
% The problem:
% A generalized theorem about Napoleon triangles:
% Let $\Delta\,ABC$ be an arbitrary triangle and $P,Q$ and $R$ the third
% vertex of isosceles triangles with equal base angles erected
% externally on the sides $BC, AC$ and $AB$ of the triangle. Then the
% lines $g(AP), g(BQ)$ and $g(CR)$ pass through a common point.
% 
% The solution:

vars_:=List(x1, x2, x3, x4, x5);


vars_ := {x1,
x2,
x3,
x4,
x5}$

parameters_:=List(u1, u2, u3);


parameters_ := {u1,u2,u3}$

% Points
A__:=Point(0,0);


a__ := {0,0}$

B__:=Point(2,0);


b__ := {2,0}$

C__:=Point(u1,u2);


c__ := {u1,u2}$

P__:=Point(x1,x2);


p__ := {x1,x2}$

Q__:=Point(x3,x4);


q__ := {x3,x4}$

R__:=Point(x5,u3);


r__ := {x5,u3}$

% polynomials
polys_:=List(eq_dist(P__,B__,P__,C__), 
  eq_dist(Q__,A__,Q__,C__),  
  eq_dist(R__,A__,R__,B__), 
  eq_angle(R__,A__,B__,P__,B__,C__), 
  eq_angle(Q__,C__,A__,P__,B__,C__));


polys_ := { - u1**2 + 2*u1*x1 - u2**2 + 2*u2*x2 - 4*x1 + 4,
 - u1**2 + 2*u1*x3 - u2**2 + 2*u2*x4,
4*(x5 - 1),
(u1*u3*x1 - 2*u1*u3 - u1*x2*x5 + u2*u3*x2 + u2*x1*x5 - 2*u2*x5 - 2*u3*x1 + 4*u3 
+ 2*x2*x5)/(x5*(u1*x1 - 2*u1 + u2*x2 - 2*x1 + 4)),
( - u1**3*x2 + u1**2*u2*x1 - 2*u1**2*u2 - u1**2*x1*x4 + u1**2*x2*x3 + 2*u1**2*x2
 + 2*u1**2*x4 - u1*u2**2*x2 + 2*u1*x1*x4 - 2*u1*x2*x3 - 4*u1*x4 + u2**3*x1 - 2*
u2**3 - u2**2*x1*x4 + u2**2*x2*x3 + 2*u2**2*x2 + 2*u2**2*x4 - 2*u2*x1*x3 - 2*u2*
x2*x4 + 4*u2*x3)/(u1**3*x1 - 2*u1**3 + u1**2*u2*x2 - u1**2*x1*x3 - 2*u1**2*x1 + 
2*u1**2*x3 + 4*u1**2 + u1*u2**2*x1 - 2*u1*u2**2 - u1*u2*x1*x4 - u1*u2*x2*x3 + 2*
u1*u2*x4 + 2*u1*x1*x3 - 4*u1*x3 + u2**3*x2 - 2*u2**2*x1 - u2**2*x2*x4 + 4*u2**2 
+ 2*u2*x1*x4 - 4*u2*x4)}$

% conclusion
con_:=is_concurrent(pp_line(A__,P__), pp_line(B__,Q__), pp_line(C__,R__));


con_ :=  - u1*u3*x1*x4 + u1*u3*x2*x3 - 2*u1*u3*x2 + 2*u1*x2*x4 + u2*x1*x4*x5 - 2
*u2*x1*x4 - u2*x2*x3*x5 + 2*u2*x2*x5 + 2*u3*x1*x4 - 2*x2*x4*x5$

% solution
sol_:=geo_solve(polys_,vars_);


sol_ := {{x1=(u1 - u2*u3 + 2)/2,
x2=(u1*u3 + u2 - 2*u3)/2,
x3=(u1 + u2*u3)/2,
x4=( - u1*u3 + u2)/2,
x5=1}}$

result_:=geo_eval(con_,sol_);


result_ := {0}$



% Example TaylorCircle_1
% 
% The problem:
% Let $\Delta\,ABC$ be an arbitrary triangle. Consider the three
% altitude pedal points and the pedal points of the perpendiculars from
% these points onto the the opposite sides of the triangle. Show that
% these 6 points are on a common circle, the {\em Taylor circle}.
% 
% The solution:

parameters_:=List(u1, u2, u3);


parameters_ := {u1,u2,u3}$

% Points
A__:=Point(u1,0);


a__ := {u1,0}$

B__:=Point(u2,0);


b__ := {u2,0}$

C__:=Point(0,u3);


c__ := {0,u3}$

% coordinates
P__:=pedalpoint(A__,pp_line(B__,C__));


p__ := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),
(u2*u3*( - u1 + u2))/(u2**2 + u3**2)}$

Q__:=pedalpoint(B__,pp_line(A__,C__));


q__ := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),
(u1*u3*(u1 - u2))/(u1**2 + u3**2)}$

R__:=pedalpoint(C__,pp_line(A__,B__));


r__ := {0,0}$

P_1_:=pedalpoint(P__,pp_line(A__,B__));


p_1_ := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),0}$

P_2_:=pedalpoint(P__,pp_line(A__,C__));


p_2_ := {(u1*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 +
 u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

Q_1_:=pedalpoint(Q__,pp_line(A__,B__));


q_1_ := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),0}$

Q_2_:=pedalpoint(Q__,pp_line(B__,C__));


q_2_ := {(u2*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 +
 u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

R_1_:=pedalpoint(R__,pp_line(A__,C__));


r_1_ := {(u1*u3**2)/(u1**2 + u3**2),(u1**2*u3)/(u1**2 + u3**2)}$

R_2_:=pedalpoint(R__,pp_line(B__,C__));


r_2_ := {(u2*u3**2)/(u2**2 + u3**2),(u2**2*u3)/(u2**2 + u3**2)}$

% conclusion
result_:=List( is_concyclic(P_1_,P_2_,Q_1_,Q_2_), 
  is_concyclic(P_1_,P_2_,Q_1_,R_1_),
  is_concyclic(P_1_,P_2_,Q_1_,R_2_));


result_ := {0,0,0}$



% Example Miquel_1
% 
% The problem:
% Miquels theorem: Let $\Delta\,ABC$ be a triangle. Fix arbitrary points
% $P,Q,R$ on the sides $AB, BC, AC$. Then the three circles through each
% vertex and the chosen points on adjacent sides pass through a common
% point.
% 
% The solution:

parameters_:=List(c1, c2, u1, u2, u3);


parameters_ := {c1,
c2,
u1,
u2,
u3}$

% Points
A__:=Point(0,0);


a__ := {0,0}$

B__:=Point(1,0);


b__ := {1,0}$

C__:=Point(c1,c2);


c__ := {c1,c2}$

% coordinates
P__:=varpoint(A__,B__,u1);


p__ := {u1,0}$

Q__:=varpoint(B__,C__,u2);


q__ := {c1*u2 - u2 + 1,c2*u2}$

R__:=varpoint(A__,C__,u3);


r__ := {c1*u3,c2*u3}$

X__:=other_cc_point(P__,p3_circle(A__,P__,R__),p3_circle(B__,P__,Q__));


x__ := {( - c1**4*u2*u3 + c1**4*u3**2 + c1**3*u1*u2 - c1**3*u1*u3 + 2*c1**3*u2*
u3 - c1**3*u3 - 2*c1**2*c2**2*u2*u3 + 2*c1**2*c2**2*u3**2 - 2*c1**2*u1*u2 - c1**
2*u1*u3 + c1**2*u1 - c1**2*u2*u3 + c1**2*u3 + c1*c2**2*u1*u2 - c1*c2**2*u1*u3 + 
2*c1*c2**2*u2*u3 - c1*c2**2*u3 + c1*u1**2 + c1*u1*u2 - c1*u1 - c2**4*u2*u3 + c2
**4*u3**2 - c2**2*u1*u3 + c2**2*u1 - c2**2*u2*u3 + c2**2*u3)/(c1**4*u2**2 - 2*c1
**4*u2*u3 + c1**4*u3**2 - 4*c1**3*u2**2 + 4*c1**3*u2*u3 + 2*c1**3*u2 - 2*c1**3*
u3 + 2*c1**2*c2**2*u2**2 - 4*c1**2*c2**2*u2*u3 + 2*c1**2*c2**2*u3**2 + 2*c1**2*
u1*u2 - 2*c1**2*u1*u3 + 6*c1**2*u2**2 - 2*c1**2*u2*u3 - 6*c1**2*u2 + 2*c1**2*u3 
+ c1**2 - 4*c1*c2**2*u2**2 + 4*c1*c2**2*u2*u3 + 2*c1*c2**2*u2 - 2*c1*c2**2*u3 - 
4*c1*u1*u2 + 2*c1*u1 - 4*c1*u2**2 + 6*c1*u2 - 2*c1 + c2**4*u2**2 - 2*c2**4*u2*u3
 + c2**4*u3**2 + 2*c2**2*u1*u2 - 2*c2**2*u1*u3 + 2*c2**2*u2**2 - 2*c2**2*u2*u3 -
 2*c2**2*u2 + 2*c2**2*u3 + c2**2 + u1**2 + 2*u1*u2 - 2*u1 + u2**2 - 2*u2 + 1),
(c2*(c1**2*u1*u2 - c1**2*u1*u3 + c1**2*u3 - 2*c1*u1*u2 + c2**2*u1*u2 - c2**2*u1*
u3 + c2**2*u3 + u1**2 + u1*u2 - u1))/(c1**4*u2**2 - 2*c1**4*u2*u3 + c1**4*u3**2 
- 4*c1**3*u2**2 + 4*c1**3*u2*u3 + 2*c1**3*u2 - 2*c1**3*u3 + 2*c1**2*c2**2*u2**2 
- 4*c1**2*c2**2*u2*u3 + 2*c1**2*c2**2*u3**2 + 2*c1**2*u1*u2 - 2*c1**2*u1*u3 + 6*
c1**2*u2**2 - 2*c1**2*u2*u3 - 6*c1**2*u2 + 2*c1**2*u3 + c1**2 - 4*c1*c2**2*u2**2
 + 4*c1*c2**2*u2*u3 + 2*c1*c2**2*u2 - 2*c1*c2**2*u3 - 4*c1*u1*u2 + 2*c1*u1 - 4*
c1*u2**2 + 6*c1*u2 - 2*c1 + c2**4*u2**2 - 2*c2**4*u2*u3 + c2**4*u3**2 + 2*c2**2*
u1*u2 - 2*c2**2*u1*u3 + 2*c2**2*u2**2 - 2*c2**2*u2*u3 - 2*c2**2*u2 + 2*c2**2*u3 
+ c2**2 + u1**2 + 2*u1*u2 - 2*u1 + u2**2 - 2*u2 + 1)}$

% conclusion
result_:=on_circle(X__,p3_circle(C__,Q__,R__));


result_ := 0$



% Example PappusPoint_1
% 
% The problem:
% Let $A,B,C$ and $P,Q,R$ be two triples of collinear points. Then by
% the Theorem of Pappus the intersection points $g(AQ)\wedge g(BP),
% g(AR)\wedge g(CP)$ and $g(BR)\wedge g(CQ)$ are collinear. 
% 
% Permuting $P,Q,R$ we get six such {\em Pappus lines}.  Those
% corresponding to even resp. odd permutations are concurrent.
% 
% The solution:

parameters_:=List(u1, u2, u3, u4, u5, u6, u7, u8);


parameters_ := {u1,
u2,
u3,
u4,
u5,
u6,
u7,
u8}$

% Points
A__:=Point(u1,0);


a__ := {u1,0}$

B__:=Point(u2,0);


b__ := {u2,0}$

P__:=Point(u4,u5);


p__ := {u4,u5}$

Q__:=Point(u6,u7);


q__ := {u6,u7}$

% coordinates
C__:=varpoint(A__,B__,u3);


c__ := { - u1*u3 + u1 + u2*u3,0}$

R__:=varpoint(P__,Q__,u8);


r__ := { - u4*u8 + u4 + u6*u8, - u5*u8 + u5 + u7*u8}$

% conclusion
result_:=is_concurrent(pappus_line(A__,B__,C__,P__,Q__,R__),
  pappus_line(A__,B__,C__,Q__,R__,P__), 
  pappus_line(A__,B__,C__,R__,P__,Q__));


result_ := 0$



% Example IMO/36_1
% 
% The problem:
% Let $A,B,C,D$ be four distinct points on a line, in that order. The
% circles with diameters $AC$ and $BD$ intersect at the points $X$ and
% $Y$. The line $XY$ meets $BC$ at the point $Z$. Let $P$ be a point on
% the line $XY$ different from $Z$. The line $CP$ intersects the circle
% with diameter $AC$ at the points $C$ and $M$, and the line $BP$
% intersects the circle with diameter $BD$ at the points $B$ and
% $N$. Prove that the lines $AM, DN$ and $XY$ are concurrent.
% 
% The solution:

vars_:=List(x1, x2, x3, x4, x5, x6);


vars_ := {x1,
x2,
x3,
x4,
x5,
x6}$

parameters_:=List(u1, u2, u3);


parameters_ := {u1,u2,u3}$

% Points
X__:=Point(0,1);


x__ := {0,1}$

Y__:=Point(0,-1);


y__ := {0,-1}$

M__:=Point(x1,x2);


m__ := {x1,x2}$

N__:=Point(x3,x4);


n__ := {x3,x4}$

% coordinates
P__:=varpoint(X__,Y__,u3);


p__ := {0, - 2*u3 + 1}$

Z__:=midpoint(X__,Y__);


z__ := {0,0}$

l_:=p_bisector(X__,Y__);


l_ := {0,1,0}$

B__:=line_slider(l_,u1);


b__ := {u1,0}$

C__:=line_slider(l_,u2);


c__ := {u2,0}$

A__:=line_slider(l_,x5);


a__ := {x5,0}$

D__:=line_slider(l_,x6);


d__ := {x6,0}$

% polynomials
polys_:=List(is_concyclic(X__,Y__,B__,N__), is_concyclic(X__,Y__,C__,M__),
  is_concyclic(X__,Y__,B__,D__), is_concyclic(X__,Y__,C__,A__),
  is_collinear(B__,P__,N__), is_collinear(C__,P__,M__));


polys_ := { - u1**2*x3 + u1*x3**2 + u1*x4**2 - u1 + x3,
 - u2**2*x1 + u2*x1**2 + u2*x2**2 - u2 + x1,
 - u1**2*x6 + u1*x6**2 - u1 + x6,
 - u2**2*x5 + u2*x5**2 - u2 + x5,
 - 2*u1*u3 - u1*x4 + u1 + 2*u3*x3 - x3,
 - 2*u2*u3 - u2*x2 + u2 + 2*u3*x1 - x1}$

% constraints
nondeg_:=List(x5-u2,x1-u2,x6-u1,x3-u1);


nondeg_ := { - u2 + x5,
 - u2 + x1,
 - u1 + x6,
 - u1 + x3}$

% conclusion
con_:=is_concurrent(pp_line(A__,M__),pp_line(D__,N__),pp_line(X__,Y__));


con_ :=  - x1*x4*x6 + x2*x3*x5 - x2*x5*x6 + x4*x5*x6$

% solution
sol_:=geo_solveconstrained(polys_,vars_,nondeg_);


sol_ := {{x1=(4*u2*u3**2 - 4*u2*u3)/(u2**2 + 4*u3**2 - 4*u3 + 1),
x2=( - 2*u2**2*u3 + u2**2 - 2*u3 + 1)/(u2**2 + 4*u3**2 - 4*u3 + 1),
x3=(4*u1*u3**2 - 4*u1*u3)/(u1**2 + 4*u3**2 - 4*u3 + 1),
x4=( - 2*u1**2*u3 + u1**2 - 2*u3 + 1)/(u1**2 + 4*u3**2 - 4*u3 + 1),
x5=( - 1)/u2,
x6=( - 1)/u1}}$

result_:=geo_eval(con_,sol_);


result_ := {0}$



% Example IMO/43_2
% 
% The problem:
% 
% No verbal problem description available
% 
% The solution:

vars_:=List(x1, x2);


vars_ := {x1,x2}$

parameters_:=List(u1);


parameters_ := {u1}$

% Points
B__:=Point(-1,0);


b__ := {-1,0}$

C__:=Point(1,0);


c__ := {1,0}$

% coordinates
O__:=midpoint(B__,C__);


o__ := {0,0}$

gamma_:=pc_circle(O__,B__);


gamma_ := {1,0,0,-1}$

D__:=circle_slider(O__,B__,u1);


d__ := {( - u1**2 + 1)/(u1**2 + 1),(2*u1)/(u1**2 + 1)}$

E__:=circle_slider(O__,B__,x1);


e__ := {( - x1**2 + 1)/(x1**2 + 1),(2*x1)/(x1**2 + 1)}$

F__:=circle_slider(O__,B__,x2);


f__ := {( - x2**2 + 1)/(x2**2 + 1),(2*x2)/(x2**2 + 1)}$

A__:=sym_point(B__,pp_line(O__,D__));


a__ := {( - u1**4 + 6*u1**2 - 1)/(u1**4 + 2*u1**2 + 1),(4*u1*(u1**2 - 1))/(u1**4
 + 2*u1**2 + 1)}$

J__:=intersection_point(pp_line(A__,C__), par_line(O__, pp_line(A__,D__)));


j__ := {(2*(3*u1**2 - 1))/(u1**4 + 2*u1**2 + 1),(2*u1*(u1**2 - 3))/(u1**4 + 2*u1
**2 + 1)}$

m_:=p_bisector(O__,A__);


m_ := {2*(u1**4 - 6*u1**2 + 1),8*u1*( - u1**2 + 1),u1**4 + 2*u1**2 + 1}$

P_1_:=pedalpoint(J__,m_);


p_1_ := {( - u1**8 + 20*u1**6 + 10*u1**4 - 12*u1**2 - 1)/(2*(u1**8 + 4*u1**6 + 6
*u1**4 + 4*u1**2 + 1)),
(4*u1**3*(u1**4 - 2*u1**2 - 3))/(u1**8 + 4*u1**6 + 6*u1**4 + 4*u1**2 + 1)}$

P_2_:=pedalpoint(J__,pp_line(C__,E__));


p_2_ := {(u1**4 - 2*u1**3*x1 + 6*u1**2*x1**2 + 2*u1**2 + 6*u1*x1 - 2*x1**2 + 1)/
(u1**4*x1**2 + u1**4 + 2*u1**2*x1**2 + 2*u1**2 + x1**2 + 1),
(u1**4*x1 + 2*u1**3 - 4*u1**2*x1 - 6*u1 + 3*x1)/(u1**4*x1**2 + u1**4 + 2*u1**2*
x1**2 + 2*u1**2 + x1**2 + 1)}$

P_3_:=pedalpoint(J__,pp_line(C__,F__));


p_3_ := {(u1**4 - 2*u1**3*x2 + 6*u1**2*x2**2 + 2*u1**2 + 6*u1*x2 - 2*x2**2 + 1)/
(u1**4*x2**2 + u1**4 + 2*u1**2*x2**2 + 2*u1**2 + x2**2 + 1),
(u1**4*x2 + 2*u1**3 - 4*u1**2*x2 - 6*u1 + 3*x2)/(u1**4*x2**2 + u1**4 + 2*u1**2*
x2**2 + 2*u1**2 + x2**2 + 1)}$

% polynomials
polys_:=List(on_line(E__,m_), on_line(F__,m_));


polys_ := {( - u1**4*x1**2 + 3*u1**4 - 16*u1**3*x1 + 14*u1**2*x1**2 - 10*u1**2 +
 16*u1*x1 - x1**2 + 3)/(x1**2 + 1),
( - u1**4*x2**2 + 3*u1**4 - 16*u1**3*x2 + 14*u1**2*x2**2 - 10*u1**2 + 16*u1*x2 -
 x2**2 + 3)/(x2**2 + 1)}$

% constraints
nondegs_:=List(x1-x2);


nondegs_ := {x1 - x2}$

% conclusion
con_:=List(eq_dist(J__,P_1_,J__,P_2_), eq_dist(J__,P_1_,J__,P_3_));


con_ := {(u1**8*x1**4 - 2*u1**8*x1**2 - 3*u1**8 + 16*u1**7*x1**3 + 16*u1**7*x1 -
 20*u1**6*x1**4 + 8*u1**6*x1**2 + 28*u1**6 - 112*u1**5*x1**3 - 112*u1**5*x1 + 94
*u1**4*x1**4 + 4*u1**4*x1**2 - 90*u1**4 + 240*u1**3*x1**3 + 240*u1**3*x1 - 132*
u1**2*x1**4 - 24*u1**2*x1**2 + 108*u1**2 - 144*u1*x1**3 - 144*u1*x1 + 9*x1**4 - 
18*x1**2 - 27)/(4*(u1**8*x1**4 + 2*u1**8*x1**2 + u1**8 + 4*u1**6*x1**4 + 8*u1**6
*x1**2 + 4*u1**6 + 6*u1**4*x1**4 + 12*u1**4*x1**2 + 6*u1**4 + 4*u1**2*x1**4 + 8*
u1**2*x1**2 + 4*u1**2 + x1**4 + 2*x1**2 + 1)),
(u1**8*x2**4 - 2*u1**8*x2**2 - 3*u1**8 + 16*u1**7*x2**3 + 16*u1**7*x2 - 20*u1**6
*x2**4 + 8*u1**6*x2**2 + 28*u1**6 - 112*u1**5*x2**3 - 112*u1**5*x2 + 94*u1**4*x2
**4 + 4*u1**4*x2**2 - 90*u1**4 + 240*u1**3*x2**3 + 240*u1**3*x2 - 132*u1**2*x2**
4 - 24*u1**2*x2**2 + 108*u1**2 - 144*u1*x2**3 - 144*u1*x2 + 9*x2**4 - 18*x2**2 -
 27)/(4*(u1**8*x2**4 + 2*u1**8*x2**2 + u1**8 + 4*u1**6*x2**4 + 8*u1**6*x2**2 + 4
*u1**6 + 6*u1**4*x2**4 + 12*u1**4*x2**2 + 6*u1**4 + 4*u1**2*x2**4 + 8*u1**2*x2**
2 + 4*u1**2 + x2**4 + 2*x2**2 + 1))}$

% solution
sol_:=geo_solveconstrained(polys_,vars_,nondegs_);


sol_ := {{x1=(sqrt(3)*u1**4 + 2*sqrt(3)*u1**2 + sqrt(3) - 8*u1**3 + 8*u1)/(u1**4
 - 14*u1**2 + 1),
x2=(sqrt(3)*u1**4 + 2*sqrt(3)*u1**2 + sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*u1**
2 + 1)},
{x1=(sqrt(3)*u1**4 + 2*sqrt(3)*u1**2 + sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*u1
**2 + 1),
x2=( - sqrt(3)*u1**4 - 2*sqrt(3)*u1**2 - sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*
u1**2 + 1)},
{x1=( - sqrt(3)*u1**4 - 2*sqrt(3)*u1**2 - sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*
u1**2 + 1),
x2=(sqrt(3)*u1**4 + 2*sqrt(3)*u1**2 + sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*u1**
2 + 1)},
{x1=( - sqrt(3)*u1**4 - 2*sqrt(3)*u1**2 - sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*
u1**2 + 1),
x2=( - sqrt(3)*u1**4 - 2*sqrt(3)*u1**2 - sqrt(3) - 8*u1**3 + 8*u1)/(u1**4 - 14*
u1**2 + 1)}}$
 
result_:=geo_simplify(geo_eval(con_,sol_));


result_ := {{0,0},{0,0},{0,0},{0,0}}$


showtime;


Time: 203 ms  plus GC time: 46 ms


end;


Time for test: 203 ms, plus GC time: 62 ms
@@@@@ Resources used: (1 3 40 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geoprover.tst0000644000175000017500000002317311526203062025111 0ustar  giovannigiovanni% GeoProver test file for Reduce, created on Jan 18 2003
load cali,geoprover;
off nat; on echo;
in "$reduce/packages/geometry/supp.red"$

% Example Arnon
% 
% The problem:
% Let $ABCD$ be a square and $P$ a point on the line parallel to $BD$
% through $C$ such that $l(BD)=l(BP)$, where $l(BD)$ denotes the
% distance between $B$ and $D$. Let $Q$ be the intersection point of
% $BF$ and $CD$. Show that $l(DP)=l(DQ)$.
% 
% The solution:

vars_:=List(x1, x2, x3);
% Points
A__:=Point(0,0); B__:=Point(1,0); P__:=Point(x1,x2);
% coordinates
D__:=rotate(A__,B__,1/2);
C__:=par_point(D__,A__,B__); 
Q__:=varpoint(D__,C__,x3);
% polynomials
polys_:=List(on_line(P__,par_line(C__,pp_line(B__,D__))),
  eq_dist(B__,D__,B__,P__), on_line(Q__,pp_line(B__,P__)));
% conclusion
con_:=eq_dist(D__,P__,D__,Q__);
% solution
gb_:=geo_gbasis(polys_,vars_);
result_:=geo_normalf(con_,gb_,vars_);


% Example CircumCenter_1
% 
% The problem:
% The intersection point of the midpoint perpendiculars is the
% center of the circumscribed circle.
% 
% The solution:

parameters_:=List(a1, a2, b1, b2, c1, c2);
% Points
A__:=Point(a1,a2);
B__:=Point(b1,b2);
C__:=Point(c1,c2);
% coordinates
M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));
% conclusion
result_:=List( eq_dist(M__,A__,M__,B__), eq_dist(M__,A__,M__,C__) );


% Example EulerLine_1
% 
% The problem:
% Euler's line: The center $M$ of the circumscribed circle,
% the orthocenter $H$ and the barycenter $S$ are collinear and $S$
% divides $MH$ with ratio 1:2.
% 
% The solution:

parameters_:=List(a1, a2, b1, b2, c1, c2);
% Points
A__:=Point(a1,a2);
B__:=Point(b1,b2);
C__:=Point(c1,c2);
% coordinates
S__:=intersection_point(median(A__,B__,C__),median(B__,C__,A__));
M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));
H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));
% conclusion
result_:=List(is_collinear(M__,H__,S__), sqrdist(S__,fixedpoint(M__,H__,1/3)));


% Example Brocard_3
% 
% The problem:
% Theorem about the Brocard points:
% Let $\Delta\,ABC$ be a triangle. The circles $c_1$ through $A,B$ and
% tangent to $g(AC)$, $c_2$ through $B,C$ and tangent to $g(AB)$, and
% $c_3$ through $A,C$ and tangent to $g(BC)$ pass through a common
% point.
% 
% The solution:

parameters_:=List(u1, u2);
% Points
A__:=Point(0,0);
B__:=Point(1,0);
C__:=Point(u1,u2);
% coordinates
M_1_:=intersection_point(altitude(A__,A__,C__),p_bisector(A__,B__));
M_2_:=intersection_point(altitude(B__,B__,A__),p_bisector(B__,C__));
M_3_:=intersection_point(altitude(C__,C__,B__),p_bisector(A__,C__));
c1_:=pc_circle(M_1_,A__);
c2_:=pc_circle(M_2_,B__);
c3_:=pc_circle(M_3_,C__);
P__:=other_cc_point(B__,c1_,c2_);
% conclusion
result_:= on_circle(P__,c3_);


% Example Feuerbach_1
% 
% The problem:
% Feuerbach's circle or nine-point circle: The midpoint $N$ of $MH$ is
% the center of a circle that passes through nine special points, the
% three pedal points of the altitudes, the midpoints of the sides of the
% triangle and the midpoints of the upper parts of the three altitudes.
% 
% The solution:

parameters_:=List(u1, u2, u3);
% Points
A__:=Point(0,0);
B__:=Point(u1,0);
C__:=Point(u2,u3);
% coordinates
H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));
D__:=intersection_point(pp_line(A__,B__),pp_line(H__,C__));
M__:=intersection_point(p_bisector(A__,B__),
  p_bisector(B__,C__));
N__:=midpoint(M__,H__);
% conclusion
result_:=List( eq_dist(N__,midpoint(A__,B__),N__,midpoint(B__,C__)),
  eq_dist(N__,midpoint(A__,B__),N__,midpoint(H__,C__)),
  eq_dist(N__,midpoint(A__,B__),N__,D__) );


% Example FeuerbachTangency_1
% 
% The problem:
% For an arbitrary triangle $\Delta\,ABC$ Feuerbach's circle (nine-point
% circle) is tangent to its 4 tangent circles.
% 
% The solution:

vars_:=List(x1, x2);
parameters_:=List(u1, u2);
% Points
A__:=Point(0,0);
B__:=Point(2,0);
C__:=Point(u1,u2);
P__:=Point(x1,x2);
% coordinates
M__:=intersection_point(p_bisector(A__,B__), p_bisector(B__,C__));
H__:=intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));
N__:=midpoint(M__,H__);
c1_:=pc_circle(N__,midpoint(A__,B__));
Q__:=pedalpoint(P__,pp_line(A__,B__));
% polynomials
polys_:=List(on_bisector(P__,A__,B__,C__), on_bisector(P__,B__,C__,A__));
% conclusion
con_:=is_cc_tangent(pc_circle(P__,Q__),c1_);
% solution
gb_:=geo_gbasis(polys_,vars_);
result_:=geo_normalf(con_,gb_,vars_);


% Example GeneralizedFermatPoint_1
% 
% The problem:
% A generalized theorem about Napoleon triangles:
% Let $\Delta\,ABC$ be an arbitrary triangle and $P,Q$ and $R$ the third
% vertex of isosceles triangles with equal base angles erected
% externally on the sides $BC, AC$ and $AB$ of the triangle. Then the
% lines $g(AP), g(BQ)$ and $g(CR)$ pass through a common point.
% 
% The solution:

vars_:=List(x1, x2, x3, x4, x5);
parameters_:=List(u1, u2, u3);
% Points
A__:=Point(0,0);
B__:=Point(2,0);
C__:=Point(u1,u2);
P__:=Point(x1,x2);
Q__:=Point(x3,x4);
R__:=Point(x5,u3);
% polynomials
polys_:=List(eq_dist(P__,B__,P__,C__), 
  eq_dist(Q__,A__,Q__,C__),  
  eq_dist(R__,A__,R__,B__), 
  eq_angle(R__,A__,B__,P__,B__,C__), 
  eq_angle(Q__,C__,A__,P__,B__,C__));
% conclusion
con_:=is_concurrent(pp_line(A__,P__), pp_line(B__,Q__), pp_line(C__,R__));
% solution
sol_:=geo_solve(polys_,vars_);
result_:=geo_eval(con_,sol_);


% Example TaylorCircle_1
% 
% The problem:
% Let $\Delta\,ABC$ be an arbitrary triangle. Consider the three
% altitude pedal points and the pedal points of the perpendiculars from
% these points onto the the opposite sides of the triangle. Show that
% these 6 points are on a common circle, the {\em Taylor circle}.
% 
% The solution:

parameters_:=List(u1, u2, u3);
% Points
A__:=Point(u1,0);
B__:=Point(u2,0);
C__:=Point(0,u3);
% coordinates
P__:=pedalpoint(A__,pp_line(B__,C__));
Q__:=pedalpoint(B__,pp_line(A__,C__));
R__:=pedalpoint(C__,pp_line(A__,B__));
P_1_:=pedalpoint(P__,pp_line(A__,B__));
P_2_:=pedalpoint(P__,pp_line(A__,C__));
Q_1_:=pedalpoint(Q__,pp_line(A__,B__));
Q_2_:=pedalpoint(Q__,pp_line(B__,C__));
R_1_:=pedalpoint(R__,pp_line(A__,C__));
R_2_:=pedalpoint(R__,pp_line(B__,C__));
% conclusion
result_:=List( is_concyclic(P_1_,P_2_,Q_1_,Q_2_), 
  is_concyclic(P_1_,P_2_,Q_1_,R_1_),
  is_concyclic(P_1_,P_2_,Q_1_,R_2_));


% Example Miquel_1
% 
% The problem:
% Miquels theorem: Let $\Delta\,ABC$ be a triangle. Fix arbitrary points
% $P,Q,R$ on the sides $AB, BC, AC$. Then the three circles through each
% vertex and the chosen points on adjacent sides pass through a common
% point.
% 
% The solution:

parameters_:=List(c1, c2, u1, u2, u3);
% Points
A__:=Point(0,0);
B__:=Point(1,0);
C__:=Point(c1,c2);
% coordinates
P__:=varpoint(A__,B__,u1);
Q__:=varpoint(B__,C__,u2);
R__:=varpoint(A__,C__,u3);
X__:=other_cc_point(P__,p3_circle(A__,P__,R__),p3_circle(B__,P__,Q__));
% conclusion
result_:=on_circle(X__,p3_circle(C__,Q__,R__));


% Example PappusPoint_1
% 
% The problem:
% Let $A,B,C$ and $P,Q,R$ be two triples of collinear points. Then by
% the Theorem of Pappus the intersection points $g(AQ)\wedge g(BP),
% g(AR)\wedge g(CP)$ and $g(BR)\wedge g(CQ)$ are collinear. 
% 
% Permuting $P,Q,R$ we get six such {\em Pappus lines}.  Those
% corresponding to even resp. odd permutations are concurrent.
% 
% The solution:

parameters_:=List(u1, u2, u3, u4, u5, u6, u7, u8);
% Points
A__:=Point(u1,0);
B__:=Point(u2,0);
P__:=Point(u4,u5);
Q__:=Point(u6,u7);
% coordinates
C__:=varpoint(A__,B__,u3);
R__:=varpoint(P__,Q__,u8);
% conclusion
result_:=is_concurrent(pappus_line(A__,B__,C__,P__,Q__,R__),
  pappus_line(A__,B__,C__,Q__,R__,P__), 
  pappus_line(A__,B__,C__,R__,P__,Q__));


% Example IMO/36_1
% 
% The problem:
% Let $A,B,C,D$ be four distinct points on a line, in that order. The
% circles with diameters $AC$ and $BD$ intersect at the points $X$ and
% $Y$. The line $XY$ meets $BC$ at the point $Z$. Let $P$ be a point on
% the line $XY$ different from $Z$. The line $CP$ intersects the circle
% with diameter $AC$ at the points $C$ and $M$, and the line $BP$
% intersects the circle with diameter $BD$ at the points $B$ and
% $N$. Prove that the lines $AM, DN$ and $XY$ are concurrent.
% 
% The solution:

vars_:=List(x1, x2, x3, x4, x5, x6);
parameters_:=List(u1, u2, u3);
% Points
X__:=Point(0,1);
Y__:=Point(0,-1);
M__:=Point(x1,x2);
N__:=Point(x3,x4);
% coordinates
P__:=varpoint(X__,Y__,u3);
Z__:=midpoint(X__,Y__);
l_:=p_bisector(X__,Y__);
B__:=line_slider(l_,u1);
C__:=line_slider(l_,u2);
A__:=line_slider(l_,x5);
D__:=line_slider(l_,x6);
% polynomials
polys_:=List(is_concyclic(X__,Y__,B__,N__), is_concyclic(X__,Y__,C__,M__),
  is_concyclic(X__,Y__,B__,D__), is_concyclic(X__,Y__,C__,A__),
  is_collinear(B__,P__,N__), is_collinear(C__,P__,M__));
% constraints
nondeg_:=List(x5-u2,x1-u2,x6-u1,x3-u1);
% conclusion
con_:=is_concurrent(pp_line(A__,M__),pp_line(D__,N__),pp_line(X__,Y__));
% solution
sol_:=geo_solveconstrained(polys_,vars_,nondeg_);
result_:=geo_eval(con_,sol_);


% Example IMO/43_2
% 
% The problem:
% 
% No verbal problem description available
% 
% The solution:

vars_:=List(x1, x2);
parameters_:=List(u1);
% Points
B__:=Point(-1,0);
C__:=Point(1,0);
% coordinates
O__:=midpoint(B__,C__);
gamma_:=pc_circle(O__,B__);
D__:=circle_slider(O__,B__,u1);
E__:=circle_slider(O__,B__,x1);
F__:=circle_slider(O__,B__,x2);
A__:=sym_point(B__,pp_line(O__,D__));
J__:=intersection_point(pp_line(A__,C__), par_line(O__, pp_line(A__,D__)));
m_:=p_bisector(O__,A__);
P_1_:=pedalpoint(J__,m_);
P_2_:=pedalpoint(J__,pp_line(C__,E__));
P_3_:=pedalpoint(J__,pp_line(C__,F__));
% polynomials
polys_:=List(on_line(E__,m_), on_line(F__,m_));
% constraints
nondegs_:=List(x1-x2);
% conclusion
con_:=List(eq_dist(J__,P_1_,J__,P_2_), eq_dist(J__,P_1_,J__,P_3_));
% solution
sol_:=geo_solveconstrained(polys_,vars_,nondegs_); 
result_:=geo_simplify(geo_eval(con_,sol_));

showtime;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geometry.tex0000644000175000017500000016725711526203062024736 0ustar  giovannigiovanni\documentclass{article}

\title{\geo\ : A Small Package for Mechanized (Plane) Geometry
Manipulations\\[20pt] Version 1.1}

\author{Hans-Gert Gr\"abe, Univ. Leipzig, Germany}

\date{September 7, 1998}

\newenvironment{code}{\tt \begin{tabbing}
\hspace*{1cm}\=\hspace*{1cm}\=\hspace*{1cm}\=
\hspace*{1cm}\=\hspace*{1cm}\=\kill
}{\end{tabbing}}
\newcommand{\formel}[1]{\[\begin{array}{l} #1\end{array}\]}
\newcommand{\iks}{{\bf x}}
\newcommand{\uhh}{{\bf u}}
\newcommand{\vau}{{\bf v}}
\newcommand{\geo}{{\sc Geometry}}
\newcommand{\gr}{{Gr\"obner}}
\newcommand{\xxyy}[2] {\noindent{\tt #1} \\\hspace*{1cm}
\parbox[t]{9cm}{#2} \\[6pt]}

\begin{document}

\maketitle

\section{Introduction}

Geometry is not only a part of mathematics with ancient roots but also
a vivid area of modern research. Especially the field of geometry,
called by some negligence ``elementary'', continues to attract the
attention also of the great community of leisure mathematicians.  This
is probably due to the small set of prerequisites necessary to
formulate the problems posed in this area and the erudition and non
formal approaches ubiquitously needed to solve them. Examples from
this area are also an indispensable component of high school
mathematical competitions of different levels upto the International
Mathematics Olympiad (IMO) \cite{IMO}.
\medskip

The great range of ideas involved in elementary geometry theorem
proving inspired mathematicians to search for a common toolbox that
allows to discover such geometric statements or, at least, to prove
them in a more unified way. These attempts again may be traced back
until ancient times, e.g., to Euclid and his axiomatic approach to
geometry. 

Axiomatic approaches are mainly directed towards the introduction of
coordinates that allow to quantify geometric statements and to use the
full power of algebraic and even analytic arguments to prove geometry
theorems. Different ways of axiomatization lead to different, even
non-commutative, {\em rings of scalars}, the basic domain of
coordinate values, see \cite{Wu:94}.

Taking rational, real or even complex coordinates for granted (as we
will do in the following) it turns out that geometry theorems may be
classified due to their symmetry group as statements in, e.g.,
projective, affine or Euclidean (Cartesian) geometry. Below such a
distinction will be important for the freedom to choose appropriate
coordinate systems.
\medskip

It may be surprising that tedious but mostly straightforward
manipulations of the algebraic counterparts of geometric statements
allow to prove many theorems in geometry with even ingenious ``true
geometric'' proofs. With the help of a Computer Algebra System
supporting algebraic manipulations this approach obtains new power.
The method is not automatic, since one often needs a good feeling how
to encode a problem efficiently, but mechanized in the sense that one
can develop a tool box to support this encoding and some very standard
tools to derive a (mathematically strong~!) proof from these encoded
data.

The attempts to algorithmize this part of mathematics found their
culmination in the 80's in the work of W.-T. Wu \cite{Wu:94} on ``the
Chinese Prover'' and the fundamental book \cite{Chou:88} of S.-C. Chou
who proved 512 geometry theorems with this mechanized method, see also
\cite{Chou:84}, \cite{Chou:90}, \cite{Wu:84a}, \cite{Wu:84b}.

Since the geometric interpretation of algebraic expressions depends
heavily on the properties of the field of scalars, we get another
classification of geometry theorems: Those with coordinate version
valid over the algebraically closed field ${\bf C}$ and those with
coordinate version valid (or may be even formulated) only over ${\bf
R}$. The latter statements include {\em ordered geometry}, that uses
the distinction between ``inside'' and ``outside'', since ${\bf C}$
doesn't admit monotone orderings.
\medskip

This package \geo, written in the algebraic mode of Reduce, should
provide the casual user with a couple of procedures that allow him/her
to mechanize his/her own geometry proofs. Together with the Reduce
built-in simplifier for rational functions, the {\tt solve} function,
and the \gr\ utilities\footnote{Unfortunately, the built in \gr\
package of Reduce doesn't admit enough flexibility for our purposes.}
of the author's package CALI \cite{CALI} (part of the Reduce library)
it allows for proving a wide range of theorems of unordered geometry,
see the examples below and in the test file {\tt geometry.tst}.

This package grew up from a course of lectures for students of
computer science on this topic held by the author at the Univ. of
Leipzig in fall 1996 and was updated after a similar lecture in spring
1998.

\section{Mechanizing Geometry Proving}

Most geometric statements are of the following form:
\begin{quote}
Given certain (more or less) arbitrarily chosen points and/or lines we
construct certain derived points and lines from them. Then the
(relative) position of these geometric objects is of a certain
specific kind regardless of the (absolute) position of the chosen
data. 
\end{quote}

To obtain evidence for such a statement (recommended before attempting
to prove it~!) one makes usually one or several drawings, choosing the
independent data appropriately and constructing the dependent ones out
of them (best with ruler and compass, if possible). A computer may be
helpful in such a task, since the constructions are purely algorithmic
and computers are best suited for algorithmic tasks. Given appropriate
data structures such construction steps may be encoded into {\em
functions} that afterwards need only to be called with appropriate
parameters.

Even more general statements may be transformed into such a form and
must be transformed to create drawings. This may sometimes involve
constructions that can't be executed with ruler and compass as, e.g.,
angle trisection in Morley's theorem or construction of a conic in
Pascal's theorem.

\subsection{Algorithmization of (plane) geometry}

The representation of geometric objects through coordinates is best
suited for both compact (finite) data encoding and regeometrization of
derived objects, e.g., through graphic output. Note that the target
language for realization of these ideas on a computer can be almost
every computer language and is not restricted to those supporting
symbolic computations. Different geometric objects may be collected
into a {\em scene}. Rapid graphic output of such a scene with
different parameters may be collected into animations or even
interactive drag-and-move pictures if supported by the programming
system. (All this is not (yet) supported by \geo.)
\medskip

We will demonstrate this approach on geometric objects, containing
points and lines, represented as pairs {\tt P:Point=$(p_{1},p_{2})$}
or tripels {\tt g:Line=$(g_{1}, g_{2}, g_{3})$} of a certain basic
type {\tt Scalar}, e.g., floating point reals. Here $g$ represents the
homogeneous coordinates of the line $\{(x,y)\, :\, g_{1}x + g_{2}y +
g_{3}=0\}$.  In this setting geometric constructions may be understood
as functions constructing new geometric objects from given ones.
Implementing such functions variables occur in a natural way as formal
parameters that are assigned with special values of the correct type
during execution.
\medskip

1) For example, the equation
\[(x-p_{1})(q_{2}-p_{2}) - (y-p_{2})(q_{1}-p_{1})=0\] 
 of the line through two given points $P=(p_{1},p_{2}),\,
Q=(q_{1},q_{2})$ yields the function
\begin{code}
pp\_line(P,Q:Point):Line == 
	$(q_{2}-p_{2},p_{1}-q_{1},p_{2}q_{1}-p_{1}q_{2})$
\end{code}
that returns the (representation of the) line through these two
points. In this function $P$ and $Q$ are neither special nor general
points but formal parameters of type {\tt Point}.

2) The (coordinates of the) intersection point of two lines may be
computed solving the corresponding system of linear equations. We get
a partially defined function, since there is no or a not uniquely
defined intersection point, if the two lines are parallel. In this
case our function terminates with an error message.
\begin{code}
intersection\_point(a,b:Line):Point == \+\\
d:=$a_{1}b_{2}-a_{2}b_{1}$;\\
if $d=0$ then error ``Lines are parallel''\\
else return $((a_{2}b_{3}-a_{3}b_{2})/d,(a_{3}b_{1}-a_{1}b_{3})/d)$
\end{code}
Again $a$ and $b$ are formal parameters, here of the type {\tt Line}.

3) In the same way we may define a line $l$ through a given point $P$ 
perpendicular to a second line $a$ as
\begin{code}
lot(P:Point,a:Line):Line == $(a_{2},-a_{1},a_{1}p_{2}-a_{2}p_{1})$
\end{code}
and a line through $P$ parallel to $a$ as
\begin{code}
par(P:Point,a:Line):Line == $(a_{1},a_{2},-a_{1}p_{1}-a_{2}p_{2})$
\end{code}

4) All functions so far returned objects with coordinates being
rational expressions in the input parameters, thus especially well
suited for algebraic manipulations. To keep this nice property we
introduce only the {\em squared Euclidean distance}
\begin{code}
sqrdist(P,Q:Point):Scalar == $(p_{1}-q_{1})^{2}+(p_{2}-q_{2})^{2}$
\end{code}

5) Due to the relative nature of geometric statements some of the
points and lines may be chosen arbitrarily or with certain
restrictions. Hence we need appropriate constructors for points and
lines given by their coordinates
\begin{code}
Point(a,b:Scalar):Point == $(a,b)$\\
Line(a,b,c::Scalar):Line == $(a,b,c)$
\end{code}
and also for a point on a given line. For this purpose we provide two
different functions
\begin{code}
choose\_Point(a:Line,u:Scalar):Point == \+\\
if $a_{2}=0$ then\+\\ 
if $a_{1}=0$ then error ``a is not a line''\\
else return $(-a_{3}/a_{1},u)$\-\\
else return $(u,-(a_{3}+a_1\,u)/a_{2})$
\end{code}
that chooses a point on a line $a$ and
\begin{code}
varPoint(P,Q:Point,u:Scalar):Point == 
$(u\,a_{1}+(1-u)\,b_{1},u\,a_{2}+(1-u)\,b_{2})$
\end{code}
that chooses a point on the line through two given points. The main
reason to have also the second definition is that $u$ has a well
defined geometric meaning in this case. For example, the midpoint of
$PQ$ corresponds to $u={1\over 2}$:
\begin{code}
midPoint(P,Q:Point):Point == varPoint(P,Q,1/2)
\end{code}

6) One can compose these functions to get more complicated geometric
objects as, e.g., the pedal point of a perpendicular
\begin{code}
pedalPoint(P:Point,a:Line):Point == intersection\_point(lot(P,a),a),
\end{code}
the midpoint perpendicular of $BC$ 
\begin{code}
mp(B,C:Point):Line == lot(midPoint(B,C),line(B,C)),
\end{code}
the altitude to $BC$ in the triangle $\Delta\,ABC$
\begin{code}
altitude(A,B,C:Point):Line == lot(A,line(B,C))
\end{code}
and the median line
\begin{code}
median(A,B,C:Point):Line == line(A,midPoint(B,C))
\end{code}

7) We can also test geometric conditions to be fulfilled, e.g., whether
two lines $a$ and $b$ are parallel or orthogonal
\begin{code}
parallel(a,b:Line):Boolean == $(a_{1}b_{2}-a_{2}b_{1}=0)$
\end{code}
resp.
\begin{code}
orthogonal(a,b:Line):Boolean == $(a_{1}b_{1}+a_{2}b_{2}=0)$
\end{code}
or whether a given point is on a given line
\begin{code}
point\_on\_line(P:Point,a:Line):Boolean ==
$(a_{1}p_{1}+a_{2}p_{2}+a_{3}=0)$
\end{code}
The corresponding procedures implemented in the package return the
value of the expression to be equated to zero instead of a boolean.

Even more complicated conditions may be checked as, e.g., whether
three lines have a point in common or whether three points are on a
common line. For a complete collection of the available procedures we
refer to the section \ref{description}.
\medskip

Note that due to the linearity of points and lines all procedures
considered so far return data with coordinates that are rational in
the input parameters. One can easily enlarge the ideas presented in
this section to handle also non linear objects as circles and angles,
compute intersection points of circles, tangent lines etc., if the
basic domain {\tt Scalar} admits to solve non-linear (mainly
quadratic) equations. Since non-linear equations usually have more
than one solution, branching ideas should be incorporated, too. For
example, intersecting a circle and a line the program should consider
both intersection points.

\subsection{Mechanized evidence of geometric statements}

With a computer and these prerequisites at hand one may obtain
evidence of geometric statements not only from plots but also
computationally, converting the statement to be checked into a
function depending on the variable coordinates as parameters and
plugging in different values for them. 

For example, the following function tests whether the three midpoint
perpendiculars in a triangle given by the coordinates of its vertices
$A,B,C$ pass through a common point
\begin{code}
test(A,B,C:Point):Boolean ==\\\>\>\> 
concurrent(mp(A,B,C),mp(B,C,A),mp(C,A,B))
\end{code}
Plugging in different values for $A,B,C$ we can verify the theorem for
many different special geometric configurations. Of course this is
not yet a {\bf proof}.
\medskip

Lets add another remark: {\tt Point} and {\tt Line} are not only the
basic data types of our geometry, but data type functions parametrized
by the data type {\tt Scalar}. To have the full functionality of our
procedures {\tt Scalar} must be a field with effective zero test.

\section{Geometry Theorems of Constructive Type}

Implementing the functions described above in a system, that admits
also symbolic computations, we can execute the same computations also
with symbolic values, i.e. taking a pure transcendental extension of
${\bf Q}$ as scalars. The procedures then return (simplified) symbolic
expressions that specialize under (almost all) substitutions of
``real'' values for these symbolic ones to the same values as if they
were computed by the original procedures with the specialized input.
This leads to the notion of {\em generic geometric configurations}. A
geometric statement holds in this generic configuration, i.e., the
corresponding symbolic expression simplifies to zero, if and only if
it is ``generically true'', i.e., holds for all special coordinate
values except degenerate ones.

\subsection{Geometric configurations of constructive type}

This approach is especially powerful, if all geometric objects
involved into a configuration may be constructed step by step and have
{\em rational} expressions in the algebraically independent variables
as symbolic coordinates.
\medskip

{\sc Definition: } We say that a geometric configuration is of {\em
constructive type}\footnote{This notion is different from
\cite{Chou:88}.}, if its generic configuration may be constructed step
by step in such a way, that the coordinates of each successive
geometric object may be expressed as rational functions of the
coordinates of objects already available or algebraically independent
variables, and the conclusion may be expressed as vanishing of a
rational function in the coordinates of the available geometric
objects.
\medskip

Substituting the corresponding rational expressions of the coordinates
of the involved geometric objects into the coordinate slots of newly
constructed objects and finally into the conclusion expression, we
obtain successively rational expressions in the given algebraically
independent variables.
\begin{quote}\it
A geometry theorem of constructive type is generically true if and
only if (its configuration is not contradictory and) the conclusion
expression simplifies to zero.
\end{quote}

Indeed, if this expression simplifies to zero, the algebraic version
of the theorem will be satisfied for all ``admissible'' values of the
parameters. If the expression doesn't simplify to zero, the theorem
fails for almost all such parameters.

Note that due to cancelation of denominators the domain of definition
of the simplified expression may be greater than the (common) domain
of definition of the different parts of the unsimplified
expression. The correct non degeneracy conditions describing
``admissibility'' may be collected during the computation. Collecting
up the zero expression indicates, that the geometric configuration is
contradictory. Hence the statement, that a certain geometric
configuration of constructive type is contradictory, is of
constructive type, too.

The package \geo\ provides procedures {\tt clear\_ndg(), print\_ndg()}
to manage and print these non degeneracy conditions and also a
procedure {\tt add\_ndg(d)} as a hook for their user driven
management.

\subsection{Some one line proofs}

Take independent variables $a_1,a_2,b_1,b_2,c_1,c_2$ and
\begin{code}
A:=Point(a1,a2);\ B:=Point(b1,b2);\ C:=Point(c1,c2); 
\end{code}
as the vertices of a generic triangle. We can prove the following
geometric statements about triangles computing the corresponding
(compound) symbolic expressions and proving that they simplify to
zero. Note that Reduce does simplification automatically.
\medskip

\noindent 1) The midpoint perpendiculars of $\Delta\,ABC$ pass through
a common point since
\begin{code}\+\>
concurrent(mp(A,B),mp(B,C),mp(C,A));
\end{code}
simplifies to zero.
\medskip

\noindent 2) The intersection point of the midpoint perpendiculars
\begin{code}\+\>
M:=intersection\_point(mp(A,B),mp(B,C));
\end{code}
is the center of the circumscribed circle since
\begin{code}\+\>
sqrdist(M,A) - sqrdist(M,B);	
\end{code}
simplifies to zero.
\medskip

\noindent 3) {\em Euler's line}: 
\begin{quote}
The center $M$ of the circumscribed circle, the orthocenter $H$ and
the barycenter $S$ are collinear and $S$ divides $MH$ with ratio 1:2.
\end{quote}
Compute the coordinates of the corresponding points
\begin{code}\+\>
M:=intersection\_point(mp(a,b,c),mp(b,c,a));\\
H:=intersection\_point(altitude(a,b,c),altitude(b,c,a));\\
S:=intersection\_point(median(a,b,c),median(b,c,a));
\end{code}
and then prove that
\begin{code}\+\>
		collinear(M,H,S);\\
                sqrdist(S,varpoint(M,H,2/3));
\end{code}
both simplify to zero.
\medskip

\noindent 4) {\em Feuerbach's circle}: 
\begin{quote}
The midpoint $N$ of $MH$ is the center of a circle that passes through
nine special points, the three pedal points of the altitudes, the
midpoints of the sides of the triangle and the midpoints of the upper
parts of the three altitudes.
\end{quote}
\begin{code}\+\>
         N:=midpoint(M,H);\\[8pt]

                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(B,C));\\
                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(H,C));\\[8pt]

         D:=intersection\_point(pp\_line(A,B),pp\_line(H,C));\\
                sqrdist(N,midpoint(A,B))-sqrdist(N,D);
\end{code}
Again the last expression simplifies to zero thus proving the theorem.

\section{Non-linear Geometric Objects}

\geo\ provides several functions to handle angles and circles as
non-linear geometric objects.

\subsection{Angles and bisectors}

(Oriented) angles between two given lines are presented as tangens of
the difference of the corresponding slopes. Since
\[\tan(\alpha-\beta) = \frac{\tan(\alpha)-\tan(\beta)}{1+
\tan(\alpha)\, \tan(\beta)}\] 
we get for the angle between two lines $g,h$
\begin{code}\>
l2\_angle(g,h:Line):Scalar == $\frac{g_2h_1-g_1h_2}{g_1h_1+g_2h_2}$
\end{code}

Note that in unordered geometry we can't distinguish between inner and
outer angles. Hence we cannot describe (rationally) the parameters of
the angle bisector of a triangle. For a point $P$ the equation 
\begin{code}\>
l2\_angle(pp\_line(A,B),pp\_line(P,B)) =\\\>\>\>
	l2\_angle(pp\_line(P,B),pp\_line(C,B))
\end{code}
i.e., $\angle\,ABP=\angle\,PBC$, describes the condition to be located
on either the inner or outer bisector of $\angle\,ABC$. Clearing
denominators yields a procedure
\begin{code}\>
point\_on\_bisector(P,A,B,C)
\end{code}
that returns on generic input a polynomial of (total) degree 4 and
quadratic in the coordinates of $P$ that describes the condition for
$P$ to be on (either the inner or the outer) bisector of
$\angle\,ABC$.
\medskip

With some more effort one can also employ such indirect geometric
descriptions. For example, we can prove the following unordered
version of the bisector intersection theorem.
\medskip

\noindent 5) There are four common points on the three bisector pairs
of a given triangle $\Delta\,ABC$. Indeed, due to Cartesian symmetry
we may choose a special coordinate system with origin $A$ and (after
scaling) $x$-axes unit point $B$. The remaining point $C$ is
arbitrary. Then the corresponding generic geometric configuration is
described with two independent parameters $u_1,u_2$ -- the coordinates
of $C$:
\begin{code}\>
A:=Point(0,0); B:=Point(1,0); C:=Point(u1,u2);
\end{code}
A point {\tt P:=Point(x1,x2)} is an intersection point of three
bisectors iff it is a common zero of the polynomial system
\begin{code}
polys:=\{\>\>\+\+ point\_on\_bisector(P,A,B,C),\\ 
point\_on\_bisector(P,B,C,A),\\
point\_on\_bisector(P,C,A,B)\},
\end{code}
i.e., of the polynomial system
\begin{quote}
$\hspace*{-2ex}\{\ {x_1}^{2}\,u_2 -2\,x_1\,x_2\,u_1 +2\,x_1\,x_2
-2\,x_1\,u_2 -{x_2}^{2}\,u_2 +2\,x_2\,u_1 -2 \,x_2 +u_2,\\
2\,{x_1}^{2}\,u_1\,u_2 -{x_1}^{2}\,u_2 -2\,x_1\,x_2\,{u_1}^{2}
+2\,x_1\,x_2\,u_1 +2\,x_1\,x_2\,{u_2}^{2} -2\,x_1\,{u_1}^{2}\,u_2
-2\,x_1\,{u_2}^{3} -2\,{x_2}^{2}\,u_1\, u_2 +{x_2}^{2}\,u_2
+2\,x_2\,{u_1}^{3} -2\,x_2\,{u_1}^{2} +2\,x_2\,u_1\,{u_2}^{2} -2\,x_2
\,{u_2}^{2} +{u_1}^{2}\,u_2 +{u_2}^{3},\\ {x_1}^{2}\,u_2
-2\,x_1\,x_2\,u_1 -{x_2}^{2}\,u_2\}$
\end{quote}
with indeterminates $x_1,x_2$ over the coefficient field ${\bf
Q}(u_1,u_2)$. A \gr\ basis computation with CALI
\begin{code}\>\+
load cali;\\
setring(\{$x_1,x_2$\},\{\},lex);\\
setideal(polys,polys);\\
gbasis polys;
\end{code}
yields the following equivalent system:
\begin{quote}
$\hspace*{-2ex}\{\ 4\,{x_2}^{4}\,u_2 -8\,{x_2}^{3}\,{u_1}^{2}
+8\,{x_2}^{3}\,u_1 -8\,{x_2}^{3}\,{u_2}^{2 }
+4\,{x_2}^{2}\,{u_1}^{2}\,u_2 -4\,{x_2}^{2}\,u_1\,u_2
+4\,{x_2}^{2}\,{u_2}^{3} -4\,{ x_2}^{2}\,u_2 +4\,x_2\,{u_2}^{2}
-{u_2}^{3},\\ 2\,x_1\,u_1\,{u_2}^{2} -x_1\,{u_2}^{2} +2\,{
x_2}^{3}\,u_2 -4\,{x_2}^{2}\,{u_1}^{2} +4\,{x_2}^{2}\,u_1
-2\,{x_2}^{2}\,{u_2}^{2} -2\, x_2\,{u_1}^{2}\,u_2 +2\,x_2\,u_1\,u_2
-2\,x_2\,u_2 -u_1\,{u_2}^{2} +{u_2}^{2}\} $
\end{quote}
The first equation has 4 solutions in $x_2$ and each of them may be
completed with a single value for $x_1$ determined from the second
equation. Hence the system $polys$ has four generic solutions
corresponding to the four expected intersection points.  The solutions
have algebraic coordinates of degree 4 over the generic field of
scalars ${\bf Q}(u_1,u_2)$ and specialize to the correct ``special''
intersection points for almost all values for the parameters $u_1$ and
$u_2$.

Although it is hard to give an explicit description through radicals
of these symbolic values, one can compute with them knowing their
minimal polynomials. Since in this situation $x_2$ is the distance
from $P$ to the line $AB$, we can prove that each of the four points
has equal distance to each of the 3 lines through two vertices of
$\Delta\,ABC$, i.e., that these points are the centers of its incircle
and the three excircles. First we compute the differences of the
corresponding squared distances
\begin{code}\>\+
con1:=sqrdist(P,pedalpoint(p,pp\_line(A,C)))-x2\^{}2;\\
con2:=sqrdist(p,pedalpoint(p,pp\_line(B,C)))-x2\^{}2;
\end{code}
The numerator of each of these two expressions should simplify to zero
under the special algebraic values of $x_1,x_2$. This may be verified
computing their normal forms with respect to the above \gr\ basis: 
\begin{code}\>\+
con1 mod gbasis polys;\\
con2 mod gbasis polys;
\end{code}
Note that \cite{Wu:94} proposes also a constructive proof for the
bisector intersection theorem:

Start with $A,B$ and the intersection point $P$ of the bisectors
through $A$ and $B$. Then $g(AC)$ and $g(BC)$ are symmetric to $g(AB)$
wrt.\ $g(AP)$ and $g(BP)$ and $P$ must be on their bisector:
\begin{code}\>\+
A:=Point(0,0); B:=Point(1,0); P:=Point(u1,u2);\\
l1:=pp\_line(A,B);\\
l2:=symline(l1,pp\_line(A,P));\\
l3:=symline(l1,pp\_line(B,P));\\[6pt]

point\_on\_bisector(P,A,B,intersection\_point(l2,l3));
\end{code}
As desired the last expression simplifies to zero.


\subsection{Circles}

The package \geo\ supplies two different types for encoding circles.
The first type is {\tt Circle1} that stores the pair $(M,s)$, the
center and the squared radius of the circle. The implementation of
{\tt point\_on\_circle1(P,c)} and \linebreak {\tt p3\_circle1(A,B,C)}
is almost straightforward. The latter function finds the circle
through 3 given points, computing its center as the intersection point
of two midpoint perpendiculars.

For purposes of analytic geometry it is often better to work with the
representation {\tt Circle} derived from the description of the circle
as the set of points $(x,y)$ for which the expression
\[(x-m_1)^2+(y-m_2)^2-r^2 = (x^2+y^2) -2\,m_1\,x -2\,m_2\,y
+m_1^2+m_2^2-r^2 \] 
vanishes. We use homogeneous coordinates {\tt k:Circle}
$=(k_1,k_2,k_3,k_4)$ for the circle
\[k:=\{\,(x,y)\ :\ k_1*(x^2+y^2)+k_2*x+k_3*y+k_4 = 0\}\]
since they admit denominator free computations and include also lines
as special circles with infinite radius: The line $g=(g_1,g_2,g_3)$ is
the circle $(0,g_1,g_2,g_3)$.

Its easy to derive formulas {\tt circle\_center(k)} for the center of
the circle $k$ and {\tt circle\_sqradius(k)} for its squared radius.
It is also straightforward to test {\tt point\_on\_circle(P,k)}.  The
parameters of the circle {\tt p3\_circle(A,B,C)} through 3 given
points 
\begin{code}\>
A:=Point($a_1,a_2$); B:=Point($b_1,b_2$); C=Point($c_1,c_2$); 
\end{code}
may be obtained from a nontrivial solution of the corresponding
homogeneous linear system with coefficient matrix
\[\left(\begin{array}{cccc} 
a_1^2+a_2^2 & a_1 & a_2 & 1 \\ b_1^2+b_2^2 & b_1 & b_2 & 1 \\
c_1^2+c_2^2 & c_1 & c_2 & 1 \\
\end{array}\right)
\] 
The condition that 4 points are on a common circle then may be
expressed as
\begin{code}\>
p4\_circle(A,B,C,D) == point\_on\_circle(D,p3\_circle(A,B,C));
\end{code}
For generic points $A,B,C,D$ this yields a polynomial $p_4$ of degree
4 in their coordinates.

Note that this condition is equivalent to the circular angle theorem:
For generic points $A,B,C,D$
\begin{code}\+\>
  u:=angle(pp\_line(A,D),pp\_line(B,D));\\
  v:=angle(pp\_line(A,C),pp\_line(B,C));\\
  (num(u)*den(v)-den(u)*num(v));
\end{code}
yields the same condition $p_4$. The common denominator {\tt
den(u)*den(v)} corresponds to the degeneracy condition that either
$A,B,C$ or $A,B,D$ are collinear.
\medskip

This condition is also equivalent to {\em Ptolemy's theorem}:
\begin{quote}
For points $A,B,C,D$ are (in that order) on a circle iff
\[l(AB)*l(CD)+l(AD)*l(BC) = l(AC)*l(BD),\]
i.e., the sum of the products of the lengths of opposite sides of the
cyclic quadrilateral $ABCD$ equals the product of the lengths of its
diagonals. 
\end{quote}
For an elementary proof see \cite[2.61]{Coxeter:67}. To get a
mechanized proof with the tools developed so far we are faced with
several problems. First the theorem invokes distances and not their
squares. Second the theorem uses the order of the given points.
Unordered geometry can't even distinguish between sides and diagonals
of a quadrilateral.

The fist problem may be solved by repeated squaring. Denoting the
lengths appropriately we get step by step
\[\begin{array}{c}
p\cdot r + q\cdot s = t\cdot u\\
(p\,r)^2+(q\,s)^2-(t\,u)^2 = -(2\,p\,q\,r\,s)\\
((p\,r)^2+(q\,s)^2-(t\,u)^2)^2 - (2\,p\,q\,r\,s)^2 = 0
\end{array}\]
arriving at an expression that contains only squared distances. This
expression 
\[{\tt poly:= }\ p^4\,r^4 - 2\,p^2\,q^2\,r^2\,s^2 -
2\,p^2\,r^2\,t^2\,u^2 + q^4\,s^4 - 2\,q^2\, s ^2\,t^2\,u^2 + t^4\,u^4
\] 
is symmetric in pairs of opposite sides thus solving also the second
problem. Substituting the corresponding squared distances of generic
points $A,B,C,D$ we obtain exactly the square of the condition $p_4$. 
\medskip

As for bisector coordinates the coordinates of intersection points of
a circle and a line generally can't be expressed rationally in terms
of the coordinates of the circles. For a generic circle {\tt c:=
Circle($c_1,c_2,c_3,c_4$)} and a generic line {\tt
d:=Line($d_1,d_2,d_3$)} we may solve the line equation for $y$ and
substitute the result into the circle equation to get a single
polynomial $q(x)$ of degree 2 with zeroes being the $x$-coordinate of
the two intersection points of {\tt c} and {\tt d}:
\begin{code}\>\+
vars:=\{x,y\};\\
polys:=\{c1*(x\^{}2+y\^{}2)+c2*x+c3*y+c4, d1*x+d2*y+d3\};\\
s:=solve(second polys,y);\\
q:=num sub(s,first polys);
\end{code}
$q:={x}^{2}\,c_1\,({d_1}^{2} +{d_2}^{2}) +x\,(2\,c_1\,d_1\,d_3 +
c_2\,{d_2}^{2} -c_3\,d_1\,d_2 ) +(c_1\,{d_3}^{2} -c_3\,d_2\,d_3
+c_4\,{d_2}^{2})$
\medskip

In many cases {\tt d} is the line through a specified point {\tt P:=
Point($p_1,p_2$)} on the circle. Fixing these coordinates as generic
ones we get the algebraic relations
\begin{code}\>
polys:=\{point\_on\_line(P,d), point\_on\_circle(P,c)\};
\end{code}
\formel{\{d_1\,p_1 +d_2\,p_2 +d_3, c_1\,{p_1}^{2} +c_1\,{p_2}^{2}
 +c_2\,p_1 +c_3\,p_2 +c_4\}}
between the coordinates of $c, d$ and $P$. This dependency may be
removed solving these equations for $d_3$ and $c_4$. In the new
coordinates the polynomial $q(x)$ factors
\begin{code}\>\+
s:=solve(polys,\{d3,c4\});\\
factorize sub(s,q);
\end{code}
into $x-p_1$ and a second factor that is linear in $x$. This yields
the coordinates for the intersection point of {\tt c} and {\tt d}
different from {\tt P} that are saved into a function {\tt
other\_cl\_point(P,c,d)}. Similarly we computed the coordinates of the
second intersection point of two circles $c_1$ and $c_2$ passing
through a common point {\tt P} and saved into a function {\tt
other\_cc\_point(P,c1,c2)}. 

Also conditions on the coordinates of a circle and a line resp.\ two
circles to be tangent may be derived in a similar way.
\medskip

\noindent 6) These functions admit a constructive proof of {\em
Miquels theorem}:
\begin{quote} Let $\Delta\,ABC$ be a triangle. Fix arbitrary points
$P,Q,R$ on the sides $AB, BC, AC$. Then the three circles through each
vertex and the chosen points on adjacent sides pass through a common
point.
\end{quote}
Take as above 
\begin{code}\>
A:=Point(0,0); B:=Point(1,0); C:=Point(c1,c2);
\end{code}
Generic points on the sides may be introduced with three auxiliary
indeterminates: 
\begin{code}\>\+
P:=choose\_pl(pp\_line(A,B),u1);\\
Q:=choose\_pl(pp\_line(B,C),u2);\\
R:=choose\_pl(pp\_line(A,C),u3);
\end{code}
Then 
\begin{code}\>
X:=other\_cc\_point(P,p3\_circle(A,P,R),p3\_circle(B,P,Q));
\end{code}
is the intersection point of two of the circles different from {\tt P}
(its generic coordinates contain 182 terms) and since
\begin{code}\>
point\_on\_circle(X,p3\_circle(C,Q,R));
\end{code}
simplifies to zero the third circle also passes through {\tt X}.

\section{Geometry Theorems of Equational Type}

As already seen in the last section non-linear geometric conditions
are best given through implicit polynomial dependency conditions on
the coordinates of the geometric objects. In this more general setting
a geometric statement may be translated into a {\em generic geometric
configuration}, involving different geometric objects with coordinates
depending on (algebraically independent) variables $\vau = (v_1,
\ldots, v_n)$, a system of {\em polynomial conditions} $F= \{f_1,
\ldots, f_r\}$ expressing the implicit geometric conditions and a
polynomial $g$ encoding the geometric conclusion, such that, for a
certain polynomial non degeneracy condition $h$, the following holds:
\begin{quote}\it
The geometric statement is true iff for all non degenerate correct
special geometric configurations, i.e., with coordinates, obtained
from the generic ones by specialization $v_i\mapsto c_i$ in such a
way, that $f({\bf c})=0$ for all $f\in F$ but $h({\bf c})\neq 0$, the
conclusion holds, i.e., $g({\bf c})$ vanishes.
\end{quote}
Denoting by $Z(F)$ the set of zeroes of the polynomial system $F$ and
writing $Z(h)=Z(\{h\})$ for short, we arrive at {\em geometry theorems
of equational type}, that may be shortly stated in the form
\[Z(F)\setminus Z(h) \subseteq Z(g).\]
Over an algebraically closed field, e.g. ${\bf C}$, this is equivalent
to the ideal membership problem
\[g\cdot h\in rad\ I(F),\]
where $rad\ I(F)$ is the radical of the ideal generated by $F$. Even
if $h$ is unknown a detailed analysis of the different components of
the ideal $I(F)$ allows to obtain more insight into the geometric
problem.
\medskip

Note the symmetry between $g$ and $h$ in the latter formulation of
geometry theorems. This allows to derive {\em non degeneracy
conditions} for a given geometry theorem of equational type from the
stable ideal quotient
\[h\in rad\ I(F):g^\infty.\]
Since every element of this ideal may serve as non degeneracy
condition there is no weakest condition among them, if the ideal is
not principal.

\subsection{Dependent and independent variables}

Let $S=R[v_1,\ldots,v_n]$ be the polynomial ring in the given
variables over the field of scalars $R$. The polynomial system $F$
describes algebraic dependency relations between these variables in
such a way that the values of some of the variables may be chosen
(almost) arbitrarily whereas the remaining variables are determined
upto a finite number of values by these choices.
\medskip

A set of variables $\uhh\subset\vau$ is called {\em independent} wrt.\
the ideal $I=I(F)$ iff $I\cap R[\uhh]=(0)$, i.e., the variables are
algebraically independent modulo $I$. If $\uhh$ is a maximal subset
with this property the remaining variables $\iks=\vau\setminus\uhh$
are called {\em dependent}.

Although a maximal set of independent variables may be read off from a
\gr\ basis of $I$ there is often a natural choice of dependent and
independent variables induced from the geometric problem. $\uhh$ is a
maximal independent set of variables iff $F$ has a finite number of
solutions as polynomial system in $\iks$ over the generic scalar field
$R(\uhh)$. In many cases this may be proved with less effort than
computing a \gr\ basis of $I$ over $S$.

If $F$ has an infinite number of solutions then $\uhh$ was independent
but not maximal. If $F$ has no solution then $\uhh$ was not
independent. 

\subsection{Geometry theorems of linear type}

We arrive at a particularly nice situation in the case when $F$ is a
non degenerate quadratic linear system of equations in $\iks$ over
$R(\uhh)$. Such geometry theorems are called {\em of linear type}.

In this case there is a unique (rational) solution $\iks = \iks(\uhh)$
that may be substituted for the dependent variables into the geometric
conclusion $g=g(\iks,\uhh)$. We obtain as for geometry theorems of
constructive type a rational expression in $\uhh$ and 
\begin{quote}\it
the geometry theorem holds (under the non degeneracy condition
$h=det(F)\in R[\uhh]$, where $det(F)$ is the determinant of the linear
system $F$) iff this expression simplifies to zero.
\end{quote}


\noindent 7) As an example consider the {\em theorem of Pappus}:
\begin{quote}
Let $A,B,C$ and $P,Q,R$ be two triples of collinear points. Then the
intersection points $g(AQ)\wedge g(BP), g(AR)\wedge g(CP)$ and
$g(BR)\wedge g(CQ)$ are collinear.
\end{quote}
The geometric conditions put no restrictions on $A,B,P,Q$ and one
restriction on each $C$ and $R$. Hence we may take as generic
coordinates
\begin{code}\>\+
A:=Point(u1,u2); B:=Point(u3,u4); C:=Point(x1,u5);\\
P:=Point(u6,u7); Q:=Point(u8,u9); R:=Point(u0,x2);
\end{code}
with $u_0,\ldots,u_9$ independent and $x_1,x_2$ dependent, as
polynomial conditions
\begin{code}\>
F:=\{collinear(A,B,C), collinear(P,Q,R)\};
\end{code}
and as conclusion
\begin{code}\+\+
con:=collinear(\\
	intersection\_point(pp\_line(A,Q),pp\_line(P,B)),\\
	intersection\_point(pp\_line(A,R),pp\_line(P,C)),\\
	intersection\_point(pp\_line(B,R),pp\_line(Q,C)));
\end{code}
a rational expression with 462 terms. The polynomial conditions are
linear in $x_1,x_2$ and already separated. Hence
\begin{code}\>\+
sol:=solve(polys,\{x1,x2\});\\
sub(sol,con);
\end{code}
proves the theorem since the expression obtained from $con$
substituting the dependent variables by their rational expressions in
$\uhh$ simplifies to zero.
\medskip

As for most theorems of linear type the linear system may be solved
``geometrically'' and the whole theorem may be translated into a
constructive geometric statement:
\begin{code}\>\+
A:=Point(u1,u2); B:=Point(u3,u4);\\ 
P:=Point(u6,u7); Q:=Point(u8,u9);\\[6pt] 

C:=choose\_pl(pp\_line(A,B),u5);\\
R:=choose\_pl(pp\_line(P,Q),u0);\\[6pt]

con:=collinear(\+\\
	intersection\_point(pp\_line(A,Q),pp\_line(P,B)),\\
	intersection\_point(pp\_line(A,R),pp\_line(P,C)),\\
	intersection\_point(pp\_line(B,R),pp\_line(Q,C)));
\end{code}

\subsection{Geometry theorems of non-linear type}

Lets return to the general situation of a polynomial system $F\subset
S$ that describes algebraic dependency relations, a subdivision
$\vau=\iks\cup\uhh$ of the variables into dependent and independent
ones, and the conclusion polynomial $g(\iks,\uhh)\in S$. The set of
zeros $Z(F)$ may be decomposed into irreducible components that
correspond to prime components $P_\alpha$ of the ideal $I=I(F)$
generated by $F$ over the ring $S=R[\iks,\uhh]$.

Since $P_\alpha\supset I$ the variables $\uhh$ may become dependent
wrt.\ $P_\alpha$. Prime components where $\uhh$ remains independent
are called {\em generic}, the other components are called {\em
special}.  Note that each special component contains a non zero
polynomial in $R[\uhh]$. Multiplying them all together yields a non
degeneracy condition $h=h(\uhh)\in R[\uhh]$ on the independent
variables such that a zero $P\in Z(F)$ with $h(P)\neq 0$ necessarily
belongs to one of the generic components. Hence they are the
``essential'' components and we say that the geometry theorem is {\em
generically true}, when the conclusion polynomial $g$ vanishes on all
these generic components.
\medskip

If we compute in the ring $S'=R(\uhh)[\iks]$, i.e., consider the
independent variables as parameters, exactly the generic components
remain visible. Indeed, this corresponds to a localization of $S$ by
the multiplicative set $R[\uhh]\setminus\{0\}$. Hence the geometry
theorem is generically true iff $g\in rad(I)\cdot S'$, i.e. $g$
belongs to the radical of the ideal $I$ in this special extension of
$S$. A sufficient condition can be derived from a \gr\ basis $G$ of
$F$ with the $\uhh$ variables as parameters: Test whether $g\ mod\ G
=0$, i.e., the normal form vanishes. More subtle examples may be
analyzed with the \gr\ factorizer or more advanced techniques from the
authors package CALI, \cite{CALI}.
\medskip

\noindent 8) As an application we consider the following nice theorem
from \cite[ch. 4, \S\ 2]{Coxeter:67} about Napoleon triangles:
\begin{quote}
Let $\Delta\,ABC$ be an arbitrary triangle and $P,Q$ and $R$ the third
vertex of equilateral triangles erected externally on the sides $BC,
AC$ and $AB$ of the triangle. Then the lines $g(AP), g(BQ)$ and
$g(CR)$ pass through a common point, the {\em Fermat point} of the
triangle $\Delta\,ABC$.
\end{quote}

A mechanized proof again will be faced with the difficulty that
unordered geometry can't distinguish between different sides wrt.\ a
line. A straightforward formulation of the geometric conditions starts
with independent coordinates for $A,B,C$ and dependent coordinates for
$P,Q,R$. W.l.o.g. we may fix the coordinates in the following way:
\begin{code}\+\>
A:=Point(0,0); B:=Point(0,2); C:=Point(u1,u2);\\
P:=Point(x1,x2); Q:=Point(x3,x4); R:=Point(x5,x6);
\end{code}
There are 6 geometric conditions for the 6 dependent variables.
\begin{code}\+\+
polys:=\{\>\>sqrdist(P,B)-sqrdist(B,C), sqrdist(P,C)-sqrdist(B,C),\\ 
	sqrdist(Q,A)-sqrdist(A,C), sqrdist(Q,C)-sqrdist(A,C),\\ 
	sqrdist(R,B)-sqrdist(A,B), sqrdist(R,A)-sqrdist(A,B)\};
\end{code}
\formel{
{x_1}^{2} +{x_2}^{2} -4\,x_2 -{u_1}^{2} -{u_2}^{2} +4\,u_2\\ 
{x_1}^{2} -2\,x_1\,u_1 +{ x_2}^{2} -2\,x_2\,u_2 +4\,u_2 -4\\ 
{x_3}^{2} +{x_4}^{2} -{u_1}^{2} -{u_2}^{2}\\ 
{x_3}^{2} -2\,x_3\,u_1 +{x_4}^{2} -2\,x_4\,u_2\\ 
{x_5}^{2} +{x_6}^{2} -4\,x_6\\ 
{x_5}^{2} +{x_6}^{2} -4}
These equations may be divided into three groups of two quadratic
relations for the coordinates of each of the points $P,Q,R$. Each of
this pairs has (only) two solutions, the inner and the outer triangle
vertex, since it may easily be reduced to a quadratic and a linear
equation, the line equation of the corresponding midpoint
perpendicular. Hence the whole system has 8 solutions and by geometric
reasons the conclusion
\begin{code}\>
con:=concurrent(pp\_line(A,P), pp\_line(B,Q), pp\_line(C,R));
\end{code}
will hold on at most two of them. Due to the special structure the
interreduced polynomial system is already a \gr\ basis and hence can't
be split by the \gr\ factorizer. A full decomposition into isolated
primes yields four components over $R(\uhh)$, each corresponding to a
pair of solutions over the algebraic closure. On one of them the
conclusion polynomial reduces to zero thus proving the geometry
theorem. 
\begin{code}\>\+
vars:=\{x1,x2,x3,x4,x5,x6\};\\
setring(vars,\{\},lex);\\
iso:=isolatedprimes polys;\\[6pt]

for each u in iso collect con mod u;
\end{code}
With a formulation as in \cite[p.~123]{Chou:88}, that uses oriented
angles, we may force all Napoleon triangles to be erected on the {\em
same} side (internally resp.\ externally) and prove a more general
theorem as above. Taking isosceles triangles with equal base angles
and (due to one more degree of freedom) $x_5$ as independent the
conclusion remains valid:
\begin{code}
polys2:=\{\>\>sqrdist(P,B)-sqrdist(P,C),\+\+\\ 
	sqrdist(Q,A)-sqrdist(Q,C),  \\
	sqrdist(R,A)-sqrdist(R,B), \\
	num(p3\_angle(R,A,B)-p3\_angle(P,B,C)), \\
	num(p3\_angle(Q,C,A)-p3\_angle(P,B,C))\};\-\-\\[6pt]

sol:=solve(polys2,\{x1,x2,x3,x4,x6\});\\
sub(first sol,con);
\end{code}
again simplifies to zero. Note that the new theorem is of linear type.

\section{The Procedures Supplied by \geo}\label{description}

This section contains a short description of all procedures available
in \geo. We refer to the data types {\tt Scalar, Point, Line, Circle1}
and {\tt Circle} described above. Booleans are represented as extended
booleans, i.e.\ the procedure returns a {\tt Scalar} that is zero iff
the condition is fulfilled. In some cases also a non zero result has a
geometric meaning. For example, {\tt collinear(A,B,C)} returns the
signed area of the corresponding parallelogram.
\bigskip

\xxyy{angle\_sum(a,b:Scalar):Scalar }{Returns $\tan(\alpha+\beta)$, if
$a=\tan(\alpha), b=\tan(\beta)$.} 
\xxyy{altitude(A,B,C:Point):Line }{The altitude from $A$ onto
$g(BC)$. } 
\xxyy{c1\_circle(M:Point,sqr:Scalar):Circle}{The circle with given
center and sqradius.}  
\xxyy{cc\_tangent(c1,c2:Circle):Scalar}{Zero iff $c_1$ and $c_2$ are
tangent.}  
\xxyy{choose\_pc(M:Point,r,u):Point}{Chooses a point on the circle
around $M$ with radius $r$ using its rational parametrization with
parameter  $u$.}
\xxyy{choose\_pl(a:Line,u):Point }{Chooses a point on $a$ using
parameter $u$.} 
\xxyy{Circle(c1,c2,c3,c4:Scalar):Circle}{The {\tt Circle} constructor.} 
\xxyy{Circle1(M:Point,sqr:Scalar):Circle1}{The {\tt Circle1}
constructor. } 
\xxyy{circle\_center(c:Circle):Point}{The center of $c$.} 
\xxyy{circle\_sqradius(c:Circle):Point}{The sqradius of $c$.} 
\xxyy{cl\_tangent(c:Circle,l:Line):Scalar}{Zero iff $l$ is tangent to
$c$.} 
\xxyy{collinear(A,B,C:Point):Scalar}{Zero iff $A,B,C$ are on a common
line. In general the signed area of the parallelogram spanned by
$\vec{AB}$ and $\vec{AC}$. }
\xxyy{concurrent(a,b,c:Line):Scalar}{Zero iff $a,b,c$ have a common
point.} 
\xxyy{intersection\_point(a,b:Line):Point}{The intersection point of
the lines $a,b$. }
\xxyy{l2\_angle(a,b:Line):Scalar}{Tangens of the angle between $a$ and
$b$. } 
\xxyy{Line(a,b,c:Scalar):Line}{The {\tt Line} constructor.}
\xxyy{lot(P:Point,a:Line):Line}{The perpendicular from $P$ onto $a$.}
\xxyy{median(A,B,C:Point):Line}{The median line from $A$ to $BC$.}
\xxyy{midpoint(A,B:Point):Point}{The midpoint of $AB$. }
\xxyy{mp(B,C:Point):Line}{The midpoint perpendicular of $BC$.}
\xxyy{orthogonal(a,b:Line):Scalar}{zero iff the lines $a,b$ are
orthogonal. }
\xxyy{other\_cc\_point(P:Point,c1,c2:Circle):Point}{ $c_1$ and $c_2$
intersect at $P$. The procedure returns the second intersection
point. }
\xxyy{other\_cl\_point(P:Point,c:Circle,l:Line):Point}{$c$ and $l$
intersect at $P$. The procedure returns the second intersection
point.}
\xxyy{p3\_angle(A,B,C:Point):Scalar}{Tangens of the angle between
$\vec{BA}$ and $\vec{BC}$. }
\xxyy{p3\_circle(A,B,C:Point):Circle\ {\rm or\ }\\
p3\_circle1(A,B,C:Point):Circle1}{The circle through 3 given points. }
\xxyy{p4\_circle(A,B,C,D:Point):Scalar}{Zero iff four given points
are on a common circle. }
\xxyy{par(P:Point,a:Line):Line}{The line through $P$ parallel to
$a$. } 
\xxyy{parallel(a,b:Line):Scalar}{Zero iff the lines $a,b$ are
parallel. }
\xxyy{pedalpoint(P:Point,a:Line):Point}{The pedal point of the
perpendicular from $P$ onto $a$.} 
\xxyy{Point(a,b:Scalar):Point}{The {\tt Point} constructor.}
\xxyy{point\_on\_bisector(P,A,B,C:Point):Scalar}{Zero iff $P$ is a
point on the (inner or outer) bisector of the angle $\angle\,ABC$.}  
\xxyy{point\_on\_circle(P:Point,c:Circle):Scalar\ {\rm or\ }\\
point\_on\_circle1(P:Point,c:Circle1):Scalar}{Zero iff $P$ is on the
circle $c$.} 
\xxyy{point\_on\_line(P:Point,a:Line):Scalar}{Zero iff $P$ is on the
line $a$. }
\xxyy{pp\_line(A,B:Point):Line}{The line through $A$ and $B$.}
\xxyy{sqrdist(A,B:Point):Scalar}{Square of the distance between $A$
and $B$.} 
\xxyy{sympoint(P:Point,l:Line):Point}{The point symmetric to $P$ wrt.\
the line $l$.} 
\xxyy{symline(a:Line,l:Line):Line}{The line symmetric to $a$ wrt.\ the
line $l$.} 
\xxyy{varpoint(A,B:Point,u):Point}{The point $D=u\cdot A+(1-u)\cdot
B$. }

\noindent \geo\ supplies as additional tools the functions
\bigskip

\xxyy{extractmat(polys,vars)}{Returns the coefficient matrix of the
list of equations $polys$ that are linear in the variables $vars$. }
\xxyy{red\_hom\_coords(u:\{Line,Circle\})}{Returns the reduced
homogeneous coordinates of $u$, i.e., divides out the content. }



\section{More Examples}

Here we give a more detailed explanation of some of the examples
collected in the test file {\tt geometry.tst} and give a list of
exercises. Their solutions can be found in the test file, too.

\subsection{Theorems that can be translated into theorems of
constructive or linear type}

There are many geometry theorems that may be reformulated as theorems
of constructive type.
\medskip


\noindent 9) The affine version of {\em Desargue's theorem}: 
\begin{quote}
If two triangles $\Delta\,ABC$ and $\Delta\,RST$ are in similarity
position,\linebreak i.e., $g(AB)\,\|g(RS),\ g(BC)\|g(ST)$ and
$g(AC)\|g(RT)$, then $g(AR),\linebreak g(BS)$ and $g(CT)$ pass through
a common point (or are parallel).
\end{quote}

The given configuration may be constructed step by step in the
following way: Take $A,B,C,R$ arbitrarily, choose $S$ arbitrarily on
the line through $R$ parallel to $g(AB)$ and $T$ as the intersection
point of the lines through $R$ parallel to $g(AC)$ and through $S$
parallel to $g(BC)$.
\begin{code}\>\+
A:=Point(a1,a2); B:=Point(b1,b2);\\ 
C:=Point(c1,c2); R:=Point(d1,d2);\\
S:=choose\_pl(par(R,pp\_line(A,B)),u);\\
T:=intersection\_point(\\\>\>
	par(R,pp\_line(A,C)),par(S,pp\_line(B,C)));\\[6pt]

con:=concurrent(pp\_line(A,R),pp\_line(B,S),pp\_line(C,T));
\end{code}
Another proof may be obtained translating the statement into a theorem
of linear type. Since the geometric conditions put no restrictions on
$A,B,C,R$, one restriction on $S$ ($g(AB)\|g(RS)$) and two
restrictions on $T$ ($g(BC)\|g(ST),\,$ $g(AC)\|g(RT)$),
we may take as generic coordinates
\begin{code}\>\+
A:=Point(u1,u2); B:=Point(u3,u4); C:=Point(u5,u6);\\
R:=Point(u7,u8); S:=Point(u9,x1); T:=Point(x2,x3);
\end{code}
with $u_1,\ldots,u_9$ independent and $x_1,x_2,x_3$ dependent, as
polynomial conditions
\begin{code}\+\+
polys:=\{\>\>parallel(pp\_line(R,S),pp\_line(A,B)),\\
	parallel(pp\_line(S,T),pp\_line(B,C)),\\
	parallel(pp\_line(R,T),pp\_line(A,C))\};
\end{code}
and as conclusion
\begin{code}\>
con:=concurrent(pp\_line(A,R),pp\_line(B,S),pp\_line(C,T));
\end{code}
The polynomial conditions are linear in $x_1,x_2,x_3$ and thus 
\begin{code}\>\+
sol:=solve(polys,\{x1,x2,x3\});\\
sub(sol,con);
\end{code}
proves the theorem since the expression obtained from $con$
substituting the dependent variables by their rational expressions in
$\uhh$ simplifies to zero.
\medskip

The general version of {\em Desargue's theorem}:
\begin{quote}
The lines $g(AR),\ g(BS)$ and $g(CT)$ pass through a common point iff
the intersection points $g(AB)\wedge g(RS),\ g(BC)\wedge g(ST)$ and
$g(AC)\wedge g(RT)$ are collinear.
\end{quote}
may be reduced to the above theorem by a projective transformation
mapping the line through the three intersection points to infinity.
Its algebraic formulation
\begin{code}\>\+
A:=Point(0,0); B:=Point(0,1); C:=Point(u5,u6);\\
R:=Point(u7,u8); S:=Point(u9,u1); T:=Point(u2,x1);\\[6pt]
con1:=collinear(\+\\intersection\_point(pp\_line(R,S),pp\_line(A,B)),\\
	intersection\_point(pp\_line(S,T),pp\_line(B,C)),\\
	intersection\_point(pp\_line(R,T),pp\_line(A,C)));\-\\

con2:=concurrent(pp\_line(A,R),pp\_line(B,S),pp\_line(C,T));
\end{code}
contains a polynomial $con_2$ linear in $x_1$ and a rational function
$con_1$ with numerator quadratic in $x_1$ that factors as
\[{\rm num}(con_1)=con_2\cdot {\rm collinear}(R,S,T)\]
thus also proving the general theorem.
\medskip

\noindent 10) Consider the following theorem about the {\em Brocard
points} (\cite[p.~336]{Chou:88})
\begin{quote}
Let $\Delta\,ABC$ be a triangle. The circles $c_1$ through $A,B$ and
tangent to $g(AC)$, $c_2$ through $B,C$ and tangent to $g(AB)$, and
$c_3$ through $A,C$ and tangent to $g(BC)$ pass through a common
point.
\end{quote}
It leads to a theorem of linear type that can't be translated into
constructive type in an obvious way. The circles may be described each
by 3 dependent variables and 3 conditions
\begin{code}\>\+
A:=Point(0,0); B:=Point(1,0); C:=Point(u1,u2);\\[6pt]

c1:=Circle(1,x1,x2,x3);\\
c2:=Circle(1,x4,x5,x6);\\
c3:=Circle(1,x7,x8,x9);\-\\[6pt]

polys:=\{\>\>
	cl\_tangent(c1,pp\_line(A,C)), \+\+\\
	point\_on\_circle(A,c1), \\
	point\_on\_circle(B,c1), \\
	cl\_tangent(c2,pp\_line(A,B)), \\
	point\_on\_circle(B,c2), \\
	point\_on\_circle(C,c2), \\
	cl\_tangent(c3,pp\_line(B,C)), \\
	point\_on\_circle(A,c3), \\
	point\_on\_circle(C,c3)\};
\end{code}
that are linear in the dependent variables. Hence the coordinates of
the circles and the intersection point of two of them may be computed
and checked for incidence with the third circle:
\begin{code}\>\+
vars:=\{x1,x2,x3,x4,x5,x6,x7,x8,x9\};\\
sol:=solve(polys,vars);\\[6pt]

P:=other\_cc\_point(C,sub(sol,c1),sub(sol,c2));\\
con:=point\_on\_circle(P,sub(sol,c3));
\end{code}
Again $con$ simplifies to zero thus proving the theorem.
\medskip

Even some theorems involving nonlinear objects as circles may be
translated into theorems of constructive type using a rational
parametrization of the non linear object. For a circle with radius $r$
and center $M=(m_1,m_2)$ we may use the rational parametrization
\[\{(\frac{1-u^2}{1+u^2}r+m_1,\frac{2u}{1+u^2}r+m_2)\ |\ u\in {\bf
C}\}.\] 
This way we can prove
\medskip

\noindent 11) {\em Simson's theorem} (\cite[p. 261]{Chou:84},
\cite[thm. 2.51]{Coxeter:67}):
\begin{quote}
Let $P$ be a point on the circle circumscribed to the triangle
$\Delta\,ABC$ and $X,Y,Z$ the pedal points of the perpendiculars from
$P$ onto the lines passing through pairs of vertices of the triangle.
These points are collinear.
\end{quote}

Take the center $M$ of the circumscribed circle as the origin and $r$
as its radius. The proof of the problem may be mechanized in the
following way:
\begin{code}\>\+
        M:=Point(0,0);\\
        A:=choose\_pc(M,r,u1);\\
        B:=choose\_pc(M,r,u2);\\
        C:=choose\_pc(M,r,u3);\\
        P:=choose\_pc(M,r,u4);\\
        X:=pedalpoint(P,pp\_line(A,B));\\
        Y:=pedalpoint(P,pp\_line(B,C));\\
        Z:=pedalpoint(P,pp\_line(A,C));\\[8pt]
 
        con:=collinear(X,Y,Z);
\end{code}
Since $con$ simplifies to zero this proves the theorem.

 
\subsection{Theorems of equational type}

An ``almost'' constructive proof of Simson's theorem may be obtained
in the following way:
\begin{code}\>\+
	A:=Point(0,0); B:=Point(u1,u2);\\
	C:=Point(u3,u4); P:=Point(u5,x1);\\
        X:=pedalpoint(P,pp\_line(A,B));\\
        Y:=pedalpoint(P,pp\_line(B,C));\\
        Z:=pedalpoint(P,pp\_line(A,C));\\[6pt]

	poly:=p4\_circle(A,B,C,P);\\[6pt]
 
        con:=collinear(X,Y,Z);
\end{code}
There is a single dependent variable bound by the quadratic condition
$poly$ that the given points are on a common circle. $con$ is a
rational expression with numerator equal to
\formel{poly\cdot {\rm collinear}(A,B,C)^2. }
Since the second factor may be considered as degeneracy condition this
also proves Simson's theorem. The factors of the denominator
\formel{{\rm den}(con)={\rm sqrdist}(A,B)\cdot {\rm sqrdist}(A,C)\cdot
{\rm sqrdist}(B,C) }
are exactly the non degeneracy conditions collected during the
computation. They may be printed with {\tt print\_ndg()}.
\medskip

One may also substitute the rational coordinate construction of
$X,Y,Z$ through {\tt pedalpoint} with additional dependent variables
and polynomial conditions:
\begin{code}\>\+
M:=Point(0,0); A:=Point(0,1); \\
B:=Point(u1,x1); C:=Point(u2,x2); P:=Point(u3,x3);\\
X:=varpoint(A,B,x4);\\ Y:=varpoint(B,C,x5);\\ Z:=varpoint(A,C,x6);
\end{code}
The polynomial conditions
\begin{code}
polys:=\{\>\> sqrdist(M,B)-1, sqrdist(M,C)-1, sqrdist(M,P)-1,\+\+\\
	orthogonal(pp\_line(A,B),pp\_line(P,X)),\\
	orthogonal(pp\_line(A,C),pp\_line(P,Z)),\\
	orthogonal(pp\_line(B,C),pp\_line(P,Y))\};
\end{code}
contain three quadratic polynomials in $x_1,x_2,x_3$ and three
polynomials linear in $x_4,x_5,x_6$. The quadratic polynomials
correspond to different points on the circle with given
$x$-coordinate.  The best variable order eliminates linear variables
first. Thus the following computations prove the theorem
\begin{code}
con:=collinear(X,Y,Z);\\[8pt]

vars:=\{x4,x5,x6,x1,x2,x3\};\\
setring(vars,\{\},lex);\\
setideal(polys,polys);\\
con mod gbasis polys;
\end{code}
since the conclusion polynomial reduces to zero.
\medskip

\noindent 12) The Butterfly Theorem (\cite[p. 269]{Chou:84},
\cite[thm. 2.81]{Coxeter:67}) :
\begin{quote}
Let $A,B,C,D$ be four points on a circle with center $O$, $P$ the
intersection point of $AC$ and $BD$ and $F$ resp. $G$ the intersection
point of the line through $P$ perpendicular to $OP$ with $AB$
resp. $CD$. Then $P$ is the midpoint of $FG$.
\end{quote}
Taking $P$ as the origin and the lines $g(FG)$ and $g(OP)$ as axes we
get the following coordinatization:
\begin{code}\>\+
P:=Point(0,0); O:=Point(u1,0);\\
A:=Point(u2,u3); B:=Point(u4,x1);\\
C:=Point(x2,x3); D:=Point(x4,x5); \\
F:=Point(0,x6); G:=Point(0,x7);\-\\[6pt]

polys:=\{\>\> sqrdist(O,B)-sqrdist(O,A),\+\+\\
	sqrdist(O,C)-sqrdist(O,A), \\
	sqrdist(O,D)-sqrdist(O,A),\\
	point\_on\_line(P,pp\_line(A,C)),\\
	point\_on\_line(P,pp\_line(B,D)),\\
	point\_on\_line(F,pp\_line(A,D)),\\
	point\_on\_line(G,pp\_line(B,C))\};\-\-\\[6pt]

con:=num sqrdist(P,midpoint(F,G));
\end{code}
Note that the formulation of the theorem includes $A\neq C$ and $B\neq
D$. Hence the conclusion may (and will) fail on some of the components
of $Z(polys)$. This can be avoided supplying appropriate constraints
to the \gr\ factorizer:
\begin{code}\>\+
vars:=\{x6,x7,x3,x5,x1,x2,x4\};\\
setring(vars,\{\},lex);\\[6pt]

sol:=groebfactor(polys,\{sqrdist(A,C),sqrdist(B,D)\});\\[6pt]

for each u in sol collect con mod u;
\end{code}
$sol$ contains a single solution that reduces the conclusion $con$ to
zero. Hence the \gr\ factorizer could split the components and remove
the auxiliary ones.



Note that there is also a constructive proof of the Butterfly theorem,
see {\tt geometry.tst}.
\medskip


\noindent 13) Let's prove another property of Feuerbach's circle
(\cite[thm. 5.61]{Coxeter:67}): 
\begin{quote}
For an arbitrary triangle $\Delta\,ABC$ Feuerbach's circle is tangent
to its in- and excircles (tangent circles for short).
\end{quote}
Take the same coordinates as in example 5 and construct the
coordinates of the center $N$ of Feuerbach's circle $c_1$ as in
example 4:
\begin{code}\>\+
A:=Point(0,0); B:=Point(2,0); C:=Point(u1,u2);\\
 
M:=intersection\_point(mp(A,B),mp(B,C));\\
H:=intersection\_point(altitude(A,B,C),altitude(B,C,A));\\
N:=midpoint(M,H);\\[6pt]	

c1:=c1\_circle(N,sqrdist(N,midpoint(A,B)));
\end{code}
The coordinates of the center {\tt P:=Point(x1,x2)} of one of the
tangent circles are bound by the conditions
\begin{code}
polys:=\{point\_on\_bisector(P,A,B,C), point\_on\_bisector(P,B,C,A)\};
\end{code}
Due to the choice of the coordinates $x_2$ is the radius of this
circle.  Hence the conclusion may be expressed as
\begin{code}\>
con:=cc\_tangent(c1\_circle(P,x2\^{}2),c1);
\end{code}
The polynomial conditions $polys$ have four generic solutions, the
centers of the four tangent circles, as derived in example 5. Since
\begin{code}\>\+
vars:=\{x1,x2\};\\
setring(vars,\{\},lex);\\
setideal(polys,polys);\\
num con mod gbasis polys;
\end{code}
yields zero this proves that all four circles are tangent to
Feuerbach's circle. \cite[ch.5,\S 6]{Coxeter:67} points out that
Feuerbach's circle of $\Delta\,ABC$ coincides with Feuerbach's circle
of each of the triangles $\Delta\,ABH,\, \Delta\,ACH$ and
$\Delta\,BCH$. Hence there are another 12 circles tangent to
$c_1$. This may be proved




Note that the proof in \cite{Coxeter:67} uses inversion geometry. The
author doesn't know about a really ``elementary'' proof of this
theorem.

\section{Exercises}

\begin{itemize}
\item[1.] (\cite[p. 267]{Chou:84}) Let $ABCD$ be a square and $P$ a
point on the line parallel to $BD$ through $C$ such that
$l(BD)=l(BP)$, where $l(BD)$ denotes the distance between $B$ and
$D$. Let $Q$ be the intersection point of $BF$ and $CD$. Show that
$l(DP)=l(DQ)$.

\item[2.] The altitudes' pedal points theorem: Let $P,Q,R$ be the
altitudes' pedal points in the triangle $\Delta\,ABC$. Show that the
altitude through $Q$ bisects $\angle\, PQR$.

\item[3.] Let $\Delta\,ABC$ be an arbitrary triangle. Consider the
three altitude pedal points and the pedal points of the perpendiculars
from these points onto the the opposite sides of the triangle. Show
that these 6 points are on a common circle, the {\em Taylor circle}.  

\item[4.] Prove the formula \[F(\Delta\,ABC) = \frac{a\,b\,c}{4\,R},\]
for the area of the triangle $\Delta\,ABC$, if $a,b,c$ are the lengths
of its sides and $R$ the radius of its circumscribed circle.

\item[5.] (\cite[p. 283]{Chou:84}) Let $k$ be a circle, $A$ the contact
point of the tangent line from a point $B$ to $k$, $M$ the midpoint of
$AB$ and $D$ a point on $k$. Let $C$ be the second intersection point
of $DM$ with $k$, $E$ the second intersection point of $BD$ with $k$
and $F$ the second intersection point of $BC$ with $k$. Show that $EF$
is parallel to $AB$.

\item[6.] (35th IMO 1995, Toronto, problem 1, \cite{IMO}) Let
$A,B,C,D$ be four distinct points on a line, in that order. The
circles with diameters $AC$ and $BD$ intersect at the points $X$ and
$Y$. The line $XY$ meets $BC$ at the point $Z$. Let $P$ be a point on
the line $XY$ different from $Z$. The line $CP$ intersects the circle
with diameter $AC$ at the points $C$ and $M$, and the line $BP$
intersects the circle with diameter $BD$ at the points $B$ and
$N$. Prove that the lines $AM, DN$ and $XY$ are concurrent.

\item[7.] (34th IMO 1994, Hong Kong, problem 2, \cite{IMO}) $ABC$ is
an isosceles triangle with $AB = AC$. Suppose that
\begin{enumerate}
\item[(i)] $M$ is the midpoint of $BC$ and $O$ is the point on the
line $AM$ such that $OB$ is perpendicular to $AB$;
\item[(ii)] $Q$ is an arbitrary point on the segment $BC$ different
from $B$ and $C$;
\item[(iii)] $E$ lies on the line $AB$ and $F$ lies on the line $AC$
such that $E, Q$ and $F$ are distinct and collinear.
\end{enumerate}
\noindent
Prove that $OQ$ is perpendicular to $EF$ if and only if $QE = QF$.

\item[8.] (4th IMO 1959, Czechia, problem 6, \cite{Morozova:68}) Show
that the distance $d$ between the centers of the inscribed and the
circumscribed circles of a triangle $\Delta\,ABC$ satisfies
$d^2=r^2-2r\rho$, where $r$ is the radius of the circumscribed circle
and $\rho$ the radius of the inscribed circle.

\item[9.] (1th IMO 1959, Roumania, problem 5, \cite{Morozova:68}) Let
$M$ be a point on AB, $AMCD$ and $MBEF$ squares to the same side of
$g(AB)$ and $N$ the intersection point of their circumscribed circles,
different from $M$.
\begin{enumerate}
\item[(i)] Show that $g(AF)$ and $g(BC)$ intersect at $N$.
\item[(ii)] Show that all lines $g(MN)$ for various $M$ meet at a
common point. 
\end{enumerate}

\end{itemize}


\bibliographystyle{plain} \bibliography{geometry}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geometry.red0000644000175000017500000003327711526203062024702 0ustar  giovannigiovanni% geometry  Version 1.1 | 6.9.98
% Author | H.-G. Graebe | Univ. Leipzig
% graebe@informatik.uni-leipzig.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


COMMENT

The package GEOMETRY is a small package for mechanized (plane)
geometry manipulations with non degeneracy tracing.

It provides the casual user with a couple of procedures that allow
him/her to mechanize his/her own geometry proofs. It grew up from a
course of lectures for students of computer science on this topic held
by the author at the Univ. of Leipzig in fall 1996 and was updated
after a similar lecture in spring 1998.

Author :        H.-G. Graebe
                Univ. Leipzig
                Institut fuer Informatik
                Augustusplatz 10 - 11
                D - 04109 Leipzig
                Germany

        email : graebe@informatik.uni-leipzig.de


Version : 1.1, finished at Sept 6, 1998.

Please send all Comments, bugs, hints, wishes, criticisms etc. to the
above email address.

Reduce version required : The program was tested under v. 3.6. but
should run also under older versions. For the test file the pacakge
CALI should be available.

Relevant publications : See the bibliography in the manual.

Key words : Mechanized geometry theorem proving.

end comment;

module geometry;

comment

Data structures:

        Point A :== {a1,a2}    <=> A=(a1,a2)
        Line  a :== {a1,a2,a3} <=> a1*x+a2*y+a3
                (including degenerate lines with a1=a2=0)

end comment;

put ('geometry,'name," Geometry ")$
put ('geometry,'version," 1.1 ")$
put ('geometry,'date," Sept 6, 1998 ")$

algebraic(write(" Geometry ", get('geometry,'version),
        " Last update ",get('geometry,'date)));

% ============= vector geometry ===============

comment

For affine (plane) geometry one can try to express the coordinates of
all points in the configuration through barycentric coordinates wrt.
three fixed non collinear "base points". Comparison of coefficients
yields equations for the nondetermined ratios that may be solved.

end comment;

algebraic procedure getcoord(u,base);
  % extract coordinates wrt. base point list base.
  begin u:={u};
  for each x in base do u:=for each y in u join coeff(y,x);
  return u;
  end;

% ============= Handling non degeneracy conditions ===============

algebraic procedure clear_ndg; !*ndg!*:={};
algebraic procedure print_ndg; !*ndg!*;
algebraic procedure add_ndg(d);
  if not member(d,!*ndg!*) then !*ndg!*:=d . !*ndg!*;

clear_ndg();

% ================= elementary geometric constructions ===============

% Generators:

algebraic procedure Point(a,b); {a,b};
algebraic procedure Line(a,b,c); {a,b,c};

algebraic procedure pp_line(a,b);
% The line through A and B.
  Line(part(b,2)-part(a,2),part(a,1)-part(b,1),
        part(a,2)*part(b,1)-part(a,1)*part(b,2));

algebraic procedure intersection_point(a,b);
% The intersection point of the lines a,b.
   begin scalar d,d1,d2;
   d:=part(a,1)*part(b,2)-part(b,1)*part(a,2);
   d1:=part(a,3)*part(b,2)-part(b,3)*part(a,2);
   d2:=part(a,1)*part(b,3)-part(b,1)*part(a,3);
   if d=0 then rederr"Lines are parallel";
   add_ndg(num d);
   return Point(-d1/d,-d2/d);
   end;

algebraic procedure lot(p,a);
% The perpendicular from P onto the line a.
  begin scalar u,v; u:=first a; v:=second a;
  return Line(v,-u,u*second p-v*first p);
  end;

algebraic procedure par(p,a);
% The parallel to line a through P.
  Line(part(a,1),part(a,2),
        -(part(a,1)*part(p,1)+part(a,2) *part(p,2)));

algebraic procedure pedalpoint(p,a);
% The pedal point of the perpendicular from P onto the line a.
  intersection_point(lot(P,a),a);

algebraic procedure midpoint(a,b);
% The midpoint of AB
  Point((part(a,1)+part(b,1))/2, (part(a,2)+part(b,2))/2);

algebraic procedure varpoint(a,b,l);
% The point D=l*A+(1-l)*B.
  Point(l*part(a,1)+(1-l)*part(b,1),l*part(a,2)+(1-l)*part(b,2));

algebraic procedure choose_pl(a,u);
% Choose a point on the line a using parameter u.
  begin scalar p,d;
  if part(a,2)=0 then
        << p:=Point(-part(a,3)/part(a,1),u); d:=part(a,1); >>
  else
        << p:=Point(u,-(part(a,3)+part(a,1)*u)/part(a,2));
           d:=part(a,2);
        >>;
  add_ndg(num d);
  return p;
  end;

algebraic procedure sqrdist(a,b);
% The square of the distance between the points A and B.
  (part(b,1)-part(a,1))^2+(part(b,2)-part(a,2))^2;

% ================= elementary geometric properties ===============

algebraic procedure collinear(a,b,c);
% A,B,C are on a common line.
det mat((part(a,1),part(a,2),1),
        (part(b,1),part(b,2),1),
        (part(c,1),part(c,2),1));

algebraic procedure concurrent(a,b,c);
% Lines a,b,c have a common point.
det mat((part(a,1),part(a,2),part(a,3)),
        (part(b,1),part(b,2),part(b,3)),
        (part(c,1),part(c,2),part(c,3)));

algebraic procedure parallel(a,b);
% 0 <=> the lines a,b are parallel.
  part(a,1)*part(b,2)-part(b,1)*part(a,2);

algebraic procedure orthogonal(a,b);
% 0 <=> the lines a,b are orthogonal.
  part(a,1)*part(b,1)+part(a,2)*part(b,2);

algebraic procedure point_on_line(p,a);
% Substitute point P into the line a.
  part(p,1)*part(a,1)+part(p,2)*part(a,2)+part(a,3);

% ================= the transversals in a triangle ===============

algebraic procedure mp(b,c);
% Midpoint perpendicular of BC.
  lot(midpoint(b,c),pp_line(b,c));

algebraic procedure altitude(a,b,c);
% Altitude from A onto BC.
  lot(a,pp_line(b,c));

algebraic procedure median(a,b,c);
% Median line from A to BC.
  pp_line(a,midpoint(b,c));

%       #########################################
%       #                                       #
%       #      Non linear geometric objects      #
%       #                                       #
%       #########################################


% ===================== angles

algebraic procedure l2_angle(a,b);
% tan of the angle between the lines a and b.
  begin scalar d; d:=(part(a,1)*part(b,1)+part(a,2)*part(b,2));
  add_ndg(num(d));
  return (part(a,2)*part(b,1)-part(b,2)*part(a,1))/d;
  end;

algebraic procedure p3_angle(A,B,C);
% tan of the angle between the lines BA and BC
  l2_angle(pp_line(B,A),pp_line(B,C));

algebraic procedure angle_sum(a,b);
% a=tan(\alpha), b=tan(\beta). Returns tan(\alpha+\beta)
  begin scalar d; d:=(1-a*b); add_ndg(num d);
  return (a+b)/d;
  end;

algebraic procedure point_on_bisector(P,A,B,C);
% P is a point on the bisector of the angle ABC.
% Returns num(u)*den(v)-num(v)*den(u) with
% u:=angle(pp_line(A,B),pp_line(P,B))
% v:=angle(pp_line(P,B),pp_line(C,B))
  begin scalar a1,a2,b1,b2,c1,c2,p1,p2;
        a1:=part(A,1); a2:=part(A,2);
        b1:=part(b,1); b2:=part(b,2);
        c1:=part(c,1); c2:=part(c,2);
        p1:=part(p,1); p2:=part(p,2);
  return ( - a1*b2 + a1*p2 + a2*b1 - a2*p1 - b1*p2 + b2*p1)*(b1**2 -
  b1*c1 - b1*p1 + b2**2 - b2*c2 - b2*p2 + c1*p1 + c2*p2) - (a1*b1 -
  a1*p1 + a2*b2 - a2*p2 - b1**2 + b1*p1 - b2**2 + b2*p2)*(b1*c2 -
  b1*p2 - b2*c1 + b2*p1 + c1*p2 - c2*p1)
  end;

% ========== symmetric lines and points

algebraic procedure sympoint(P,l);
% The point symmetric to P wrt. the line l.
  varpoint(P,pedalpoint(P,l),-1);

algebraic procedure symline(a,l);
% The line symmetric to a wrt. the line l.
  begin scalar a1,a2,a3,l1,l2,l3,u;
  a1:=part(a,1); a2:=part(a,2); a3:=part(a,3);
  l1:=part(l,1); l2:=part(l,2); l3:=part(l,3);
  u:=l1^2 - l2^2;
  return Line(- a1*u - 2*a2*l1*l2, - 2*a1*l1*l2 + a2*u,
                - 2*(a1*l1 + a2*l2)*l3 + a3*(l1^2 + l2^2));
  end;

% ===================== circles

comment

        Circle1 represents a circle as the pair {M,sqr} consisting of
        the center M and the square of its radius.

end comment;

algebraic procedure Circle1(M,sqr); {M,sqr};

algebraic procedure p3_circle1(A,B,C);
% The circle through three given points
  begin scalar M;
  M:=intersection_point(mp(A,B),mp(B,C));
  return Circle1(M,sqrdist(M,A));
  end;

algebraic procedure point_on_circle1(P,c);
% Test a point P to be on c:Circle1.
  sqrdist(P,part(c,1))-part(c,2);

algebraic procedure choose_pc(M,r,u);
% Choose a point on the circle with center M and radius (not squared
% radius !) r using a rational parametrization of the circle.
  begin scalar d;
  d:=(u^2+1); add_ndg(num d);
  return Point(r*(u^2-1)/d+part(M,1), 2*r*u/d+part(M,2));
  end;

comment

Another approach represents a circle through its equation

                      c1*(x^2+y^2)+c2*x+c3*y+c4

This is better adapted for analytic geometry. The coordinates are
homogeneous as those for lines, hence we may adjust either c1=1 or
allow for division-free computations without such a scaling. Another
advantage of the latter is, that for c1=0 we get lines as circles with
infinite radius.

A circle is henceforth a quadruple c={c1,c2,c3,c4}.

end comment;

algebraic procedure Circle(c1,c2,c3,c4); {c1,c2,c3,c4};

algebraic procedure c1_circle(M,sqr);
% Circle from center M and squared radius sqr.
  Circle(1, -2*part(M,1), -2*part(M,2),
        part(M,1)^2 + part(M,2)^2 - sqr);

algebraic procedure circle_center c;
% The center of the circle c.
  begin add_ndg(num part(c,1));
  return Point(-part(c,2)/2/part(c,1) ,-part(c,3)/(2*part(c,1)));
  end;

algebraic procedure circle_sqradius c;
% The squared radius of the circle c.
  begin add_ndg(num part(c,1));
  return
   ((part(c,2)^2+part(c,3)^2) - 4*part(c,4)*part(c,1)) /
        (2*part(c,1))^2;
  end;

algebraic procedure p3_circle(A,B,C);
% The circle through three given points
  begin scalar a1,a2,a3,b1,b2,b3,c1,c2,c3;
  a1:=part(A,1); a2:=part(A,2); a3:=a1^2+a2^2;
  b1:=part(b,1); b2:=part(b,2); b3:=b1^2+b2^2;
  c1:=part(c,1); c2:=part(c,2); c3:=c1^2+c2^2;
  return Circle(a1*(b2-c2) + (a2-b2)*c1 + b1*(c2-a2),
    a3*(c2-b2) + (a2-c2)*b3 + (b2-a2)*c3,
    a3*(b1-c1) + (c1-a1)*b3 + (a1-b1)*c3,
    a3*(b2*c1-b1*c2) + (a1*c2-a2*c1)*b3 + (a2*b1-a1*b2)*c3)
  end;

algebraic procedure point_on_circle(P,c);
  begin scalar p1,p2; p1:=part(P,1); p2:=part(P,2);
  return part(c,1)*(p1^2+p2^2)+part(c,2)*p1+part(c,3)*p2+part(c,4);
  end;

algebraic procedure p4_circle(A,B,C,D);
  point_on_circle(D,p3_circle(A,B,C));

% Intersecting with circles

algebraic procedure other_cl_point(P,c,l);
% circle c and line l intersect at P. The procedure returns their
% second intersection point.
  if point_on_line(P,l) neq 0 then rederr "Point not on the line"
  else if point_on_circle(P,c) neq 0 then
        rederr "Point not on the circle"
  else begin scalar c1,c2,c3,l1,l2,d,d1,p1,p2;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3);
  l1:=part(l,1); l2:=part(l,2); p1:=part(P,1); p2:=part(P,2);
  d:=c1*(l1^2 + l2^2); add_ndg(num d); d1:=c1*(l1^2-l2^2);
  return {(d1*p1+((2*c1*p2 + c3)*l1-c2*l2)*l2)/d,
        (- d1*p2+((2*c1*p1 + c2)*l2-c3*l1)*l1)/d};
  end;

algebraic procedure other_cc_point(P,c1,c2);
% Circles c1 and c2 intersect at P. The procedure returns their
% second intersection point, computing by elimination the line through
% the common intersection points.
  begin scalar l;
  l:=for i:=2:4 collect
        (part(c1,1)*part(c2,i)-part(c1,i)*part(c2,1));
  return other_cl_point(P,c1,l);
  end;

algebraic procedure cl_tangent(c,l);
% Line l is tangent to the circle c.
  begin scalar c1,c2,c3,c4,l1,l2,l3;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3); c4:=part(c,4);
  l1:=part(l,1); l2:=part(l,2); l3:=part(l,3);
  return - 4*c1^2*l3^2 + 4*c1*c2*l1*l3 + 4*c1*c3*l2*l3 -
        4*c1*c4*l1^2 - 4*c1*c4*l2^2 + c2^2*l2^2 - 2*c2*c3*l1*l2 +
        c3^2*l1^2
  end;

algebraic procedure cc_tangent(c,d);
% Two circles c,d are tangent.
  begin scalar c1,c2,c3,c4,d1,d2,d3,d4;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3); c4:=part(c,4);
  d1:=part(d,1); d2:=part(d,2); d3:=part(d,3); d4:=part(d,4);
  return
4*c1^2*d4^2 - 4*c1*c2*d2*d4 - 4*c1*c3*d3*d4 - 8*c1*c4*d1*d4 +
4*c1*c4*d2^2 + 4*c1*c4*d3^2 + 4*c2^2*d1*d4 - c2^2*d3^2 + 2*c2*c3*d2*d3
- 4*c2*c4*d1*d2 + 4*c3^2*d1*d4 - c3^2*d2^2 - 4*c3*c4*d1*d3 +
4*c4^2*d1^2
  end;

% ============= some additional tools ===============

symbolic operator list2mat;
symbolic procedure list2mat u;
  'mat. for each x in cdr reval u collect cdr x;

algebraic procedure extractmat(polys,vars);
% extract the coefficient matrix from the linear system polys.
  begin
  if length polys neq length vars then
        rederr"Number of variables doesn't match";
  for each p in polys do for each x in vars do
        if deg(p,x)>1 then rederr"Equations not of linear type";
  return list2mat
        for each x in vars collect
        for each p in polys collect coeffn(p,x,1);
end;

algebraic procedure red_hom_coords u;
% Divide out the content of homogeneous coordinates.
  begin scalar l,g;
  l:=den first u; g:=num first u;
  for each x in rest u do <>;
  add_ndg(g);
  return for each x in u collect (x*l/g);
  end;



endmodule; % geometry

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/supp.red0000644000175000017500000000472411526203062024031 0ustar  giovannigiovanni%###############################################################
%
% FILE:    supp.red
% AUTHOR:  graebe
% CREATED: 2/2002
% PURPOSE: Interface for the extended GEO syntax to Reduce
% VERSION: $Id: supp.red,v 1.1 2002/12/26 16:27:22 compalg Exp $


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

algebraic procedure geo_simplify u; u;
algebraic procedure geo_normal u; u;
algebraic procedure geo_subs(a,b,c); sub(a=b,c);

algebraic procedure geo_gbasis(polys,vars);
  begin
  setring(vars,{},lex);
  setideal(uhu,polys);
  return gbasis uhu;
  end;

algebraic procedure geo_groebfactor(polys,vars,nondeg);
  begin
  setring(vars,{},lex);
  return groebfactor(polys,nondeg);
  end;

algebraic procedure geo_normalf(p,polys,vars);
  begin
  setring(vars,{},lex);
  return p mod polys;
  end;

algebraic procedure geo_eliminate(polys,vars,elivars);
  begin
  setring(vars,{},lex);
  return eliminate(polys,elivars);
  end;

algebraic procedure geo_solve(polys,vars);
  solve(polys,vars);

algebraic procedure geo_solveconstrained(polys,vars,nondegs);
  begin scalar u;
  setring(vars,{},lex);
  u:=groebfactor(polys,nondegs);
  return for each x in u join solve(x,vars);
  end;

algebraic procedure geo_eval(con,sol);
  for each x in sol collect sub(x,con);

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geoprover.html0000644000175000017500000002340311526203062025237 0ustar  giovannigiovanni

GeoProver v. 1.3a



The GeoProver Package for Mechanized (Plane) Geometry Theorem Proving 

 Version 1.3a


 




AUTHOR   : Hans-Gert Graebe

 ADDRESS  : Univ. Leipzig, Institut f. Informatik, D - 04109 Leipzig, Germany

 URL    : 
 http://www.informatik.uni-leipzig.de/~graebe 






Introduction



The GeoProver is a small package for
mechanized (plane) geometry manipulations with non degeneracy
tracing, available for different CAS platforms (Maple, MuPAD,
Mathematica, and Reduce).



It provides the casual user with a couple of procedures that
allow him/her to mechanize his/her own geometry proofs. Version
1.1 grew out from a course of lectures for students of computer
science on this topic held by the author at the Univ. of Leipzig
in fall 1996 and was updated after a similar lecture in spring
1998.  



The (completely revised) version 1.2, finished in March 2002,
was set up as a generic software project to manage the code for
different platforms in a unified way. There is a close relationship
to the SymbolicData project (see 
http://www.symbolicdata.org).


For examples we refer to the test file, but also to the
SymbolicData GEO collection. It contains many (generic) proof
schemes of geometry theorems, mainly from Chou's book. These proof
schemes can be translated to the GeoProver syntax for different
platforms with SymbolicData tools.



For version 1.3 the syntax definition (the GeoCode) was
separated from the GeoProver implementation. The latter is an
implementation of the GeoCode standard using the coordinate
method. 



Note that function names change with different versions of the
GeoCode standard. GeoProver 1.3 implements the GeoCode standard
1.3. 



Please send comments, bug reports, hints, wishes, criticisms
etc. to the author.



Basic Data Types



Basic data types are Points, Lines, and
Circles.

  

A point A:=Point(a,b) represents a point with
coordinates (a1,a2). 



A line l:=Line(a,b,c) represents the line
{ (x,y) : a*x+b*y+c=0 }. 



A circle c:=Circle(c1,c2,c3,c4) represents the
circle { (x,y) : c1*(x^2+y^2)+c2*x+c3*y+c4=0 }. 



Available functions





 Point(a:Scalar, b:Scalar)  Point constructor. Returns a coding for the point with
coordinates (a,b).

 altitude(A:Point, B:Point, C:Point)  The altitude from A onto g(BC).

 angle_sum(a:Scalar, b:Scalar)  Returns tan(alpha+beta), if a=tan(alpha), b=tan(beta).

 centroid(A:Point, B:Point, C:Point)  Centroid of the triangle ABC.

 circle_center(c:Circle)  The center of the circle c.

 circle_slider(M:Point, A:Point, u:Scalar)  Choose a point on the circle with center M and point
A on the perimeter using a rational parametrization with
parameter u.

 circle_sqradius(c:Circle)  The squared radius of the circle c.

 circumcenter(A:Point, B:Point, C:Point)  The circumcenter of the triangle ABC.

 csym_point(P:Point, Q:Point)  The point symmetric to P wrt. Q as symmetry center.

 eq_angle(A:Point, B:Point, C:Point, D:Point, E:Point, F:Point)  Test for equal angle w(ABC) = w(DEF).

 eq_dist(A:Point, B:Point, C:Point, D:Point)  Test for equal distance d(AB) = d(CD).

 fixedpoint(A:Point, B:Point, u:Scalar)  The point D=(1-u)*A+u*B on the line AB for a fixed value of u.

 intersection_point(a:Line, b:Line)  The intersection point of the lines a,b.

 is_cc_tangent(c1:Circle, c2:Circle)  Zero iff circles c_1 and c_2 are tangent.

 is_cl_tangent(c:Circle, l:Line)  Zero iff the line l is tangent to the circle c.

 is_collinear(A:Point, B:Point, C:Point)  Zero iff A,B,C are on a common line. For the signed area
of the triangle ABC use triangle_area.

 is_concurrent(a:Line, b:Line, c:Line)  Zero iff the lines a,b,c pass through a common point.

 is_concyclic(A:Point, B:Point, C:Point, D:Point)  Zero iff four given points are on a common circle.

 is_equal(A:Scalar, B:Scalar)  Test for equality of A and B.

 is_orthogonal(a:Line, b:Line)  zero iff the lines a,b are orthogonal.

 is_parallel(a:Line, b:Line)  Zero iff the lines a,b are parallel.

 l2_angle(a:Line, b:Line)  Tangens of the angle between a and b.

 line_slider(a:Line, u:Scalar)  Chooses a point on a using parameter u.

 median(A:Point, B:Point, C:Point)  The median line from A to BC.

 midpoint(A:Point, B:Point)  The midpoint of AB.

 on_bisector(P:Point, A:Point, B:Point, C:Point)  Zero iff P is a point on the (inner or outer) bisector of the
angle \angle ABC.

 on_circle(P:Point, c:Circle)  Zero iff P is on the circle c.

 on_line(P:Point, a:Line)  Zero iff P is on the line
a.

 ortho_line(P:Point, a:Line)  The line through P orthogonal to the line a.

 orthocenter(A:Point, B:Point, C:Point)  Orthocenter of the triangle ABC.

 other_cc_point(P:Point, c1:Circle, c2:Circle)  c_1 and c_2 intersect at P. 
The procedure returns the second intersection point.

 other_cl_point(P:Point, c:Circle, l:Line)  c and l intersect at P. 
The procedure returns the second intersection point.

 other_incenter(M:Point, A:Point, B:Point)  Let ABC be a triangle and M the incenter of
ABC. Returns the excenter of ABC on the bisector
CM.

 p3_angle(A:Point, B:Point, C:Point)  Tangens of the angle between BA and BC.

 p3_circle(A:Point, B:Point, C:Point)  The circle through 3 given points.

 p9_center(A:Point, B:Point, C:Point)  Center of the nine-point circle of the triangle ABC.

 p9_circle(A:Point, B:Point, C:Point)  The nine-point circle (Feuerbach circle) of the triangle ABC.

 p_bisector(B:Point, C:Point)  The perpendicular bisector of BC.

 pappus_line(A:Point, B:Point, C:Point, D:Point, E:Point, F:Point)  The Pappus line of a conic 6-tuple of points.

 par_line(P:Point, a:Line)  The line through P parallel to line a.

 par_point(A:Point, B:Point, C:Point)  Point D that makes ABCD a parallelogram.

 pc_circle(M:Point, A:Point)  The circle with given center M and circumfere point A.

 pedalpoint(P:Point, a:Line)  The pedal point of the perpendicular from P onto a.

 pp_line(A:Point, B:Point)  The line through A and B.

 radical_axis(c1:Circle, c2:Circle)  The radical axis of two circles, i.e. the line of point with equal pc_degree
wrt. to both circles. If the circles intersect this is the line through their
intersection points.  If the circles don't intersect this are the point with
equal tangent segments to both circles.

 rotate(C:Point, A:Point, angle:Scalar)  Rotate point A (counterclockwise) around center C with angle angle*Pi.

 sqrdist(A:Point, B:Point)  Squared distance between A and B.

 sqrdist_pl(A:Point, l:Line)  Squared distance between point A and line 
l.

 sym_line(a:Line, l:Line)  The line symmetric to a wrt. the line l.

 sym_point(P:Point, l:Line)  The point symmetric to P wrt. line l.

 triangle_area(A:Point, B:Point, C:Point)  Signed area of the directed triangle ABC.

 varpoint(A:Point, B:Point, u:Scalar)  The point D=(1-u)*A+u*B that slides on the line 
AB, with parameter u.




Acknowledgements



Malte Witte translated the code of version 1.1 from Reduce to
Maple, MuPAD, and Mathematica and compiled many examples for the
SymbolicData GEO proof scheme collection, mainly from Chou's
book.



Benjamin Friedrich collected examples and solutions with
geometric background from IMO contests.




mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geometry.bib0000644000175000017500000000464411526203062024660 0ustar  giovannigiovanni@Misc{IMO,
  key={IMO},
  title =	 {{International Mathematics Olympiad (IMO)}},
  howpublished = {Available from\\ {\tt
                  http://olympiads.win.tue.nl/imo}},   
}

@Manual{CALI,
  title = 	 {{CALI -- A Reduce package for commutative algebra.
                  Version 2.2.1}},
  author =	 {Gr\"abe, H.-G.},
  organization = {Uni Leipzig},
  year =	 {June 1995},
  address =	 {Available from\\ {\tt
http://www.informatik.uni-leipzig.de/\~{}compalg}},
}

@InCollection{Chou:84,
  author = 	 {Chou, S.-C.},
  title = 	 {Proving elementary geometry theorems using {Wu's}
                  algorithm}, 
  booktitle = 	 {Contemp. Math.},
  publisher = 	 {AMS, Providence, Rhode Island},
  year =	 {1984},
  volume =	 {19},
  pages =	 {243 - 286},
}

@Book{Chou:88,
  author = 	 {Chou, S.-C.},
  title = 	 {Mechanical geometry theorem proving},
  publisher = 	 {Reidel, Dortrecht},
  year = 	 {1988},
}

@InProceedings{Chou:90,
  author = 	 {Chou, S.-C.},
  title = 	 {Automated reasoning in geometries using the
                  characteristic set method and {Gr\"obner} basis
                  method}, 
  booktitle = 	 {Proc. ISSAC-90},
  publisher =	 {ACM Press},
  year = 	 {1990},
  pages =	 {255-260},
}

@Book{Coxeter:67,
  author = 	 {Coxeter, H.S.M. and Greitzer, S.L.},
  title = 	 {Geometry revisted},
  publisher = 	 {Random House, The L.W. Singer Comp., New York},
  year = 	 {1967},
}

@InCollection{Wu:84a,
  author = 	 {Wu, W.-T.},
  title = 	 {On the decision problem and the mechanization of
                  theorem-proving in elementary geometry},   
  booktitle = 	 {Contemp. Math.},
  publisher = 	 {AMS, Providence, Rhode Island},
  year =	 {1984},
  volume =	 {19},
  pages =	 {213 - 234},
}

@InCollection{Wu:84b,
  author = 	 {Wu, W.-T.},
  title = 	 {Some recent advances in mechanical theorem proving
                  of geometry},  
  booktitle = 	 {Contemp. Math.},
  publisher = 	 {AMS, Providence, Rhode Island},
  year =	 {1984},
  volume =	 {19},
  pages =	 {235 - 241},
}

@Book{Morozova:68,
  author = 	 {Morozova, E.A. and Petrakov, I.S.},
  title = 	 {International Mathematics Olympiads},
  publisher = 	 {Prosve\v{s}\v{c}enie, Moscow},
  year = 	 {1968},
  note =	 {(in russian)}, 
}



@Book{Wu:94,
  author = 	 {Wu, W.-T.},
  title = 	 {Mechanical Theorem Proving in Geometries},
  number =	 {1},
  series =	 {Texts and Monographs in Symbolic Computation},
  publisher = 	 {Springer, Wien},
  year = 	 {1994},
}

mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geometry.rlg0000644000175000017500000011627011526203062024707 0ustar  giovannigiovanniThu Jan 28 23:37:50 MET 1999
REDUCE 3.7, 15-Jan-99 ...

1: 1: 
2: 2: 2: 2: 2: 2: 2: 2: 2: 
 Geometry  1.1  Last update  Sept 6, 1998 

3: 3: % Author H.-G. Graebe | Univ. Leipzig | Version 6.9.1998
% graebe@informatik.uni-leipzig.de

comment 

Test suite for the package GEOMETRY 1.1

end comment;


algebraic;


load cali,geometry;


off nat;


on echo;


showtime;


Time: 190 ms



% #####################
% Some one line proofs
% #####################

% A generic triangle ABC

A:=Point(a1,a2);


a := {a1,a2}$
 B:=Point(b1,b2);


b := {b1,b2}$
 C:=Point(c1,c2);


c := {c1,c2}$


% Its midpoint perpendiculars have a point in common:

	concurrent(mp(a,b),mp(b,c),mp(c,a));


0$

 
% This point

	M:=intersection_point(mp(a,b),mp(b,c));


m := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1**
2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - a2
*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$


% is the center of the circumscribed circle

	sqrdist(M,A) - sqrdist(M,B);


0$
	

% The altitutes intersection theorem

	concurrent(altitude(a,b,c),altitude(b,c,a),altitude(c,a,b));


0$


% The median intersection theorem

	concurrent(median(a,b,c),median(b,c,a),median(c,a,b));


0$


% Euler's line

        M:=intersection_point(mp(a,b),mp(b,c));


m := {(a1**2*b2 - a1**2*c2 + a2**2*b2 - a2**2*c2 - a2*b1**2 - a2*b2**2 + a2*c1**
2 + a2*c2**2 + b1**2*c2 + b2**2*c2 - b2*c1**2 - b2*c2**2)/(2*(a1*b2 - a1*c2 - a2
*b1 + a2*c1 + b1*c2 - b2*c1)),
( - a1**2*b1 + a1**2*c1 + a1*b1**2 + a1*b2**2 - a1*c1**2 - a1*c2**2 - a2**2*b1 +
 a2**2*c1 - b1**2*c1 + b1*c1**2 + b1*c2**2 - b2**2*c1)/(2*(a1*b2 - a1*c2 - a2*b1
 + a2*c1 + b1*c2 - b2*c1))}$

        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));


h := {( - a1*a2*b1 + a1*a2*c1 + a1*b1*b2 - a1*c1*c2 - a2**2*b2 + a2**2*c2 + a2*
b2**2 - a2*c2**2 - b1*b2*c1 + b1*c1*c2 - b2**2*c2 + b2*c2**2)/(a1*b2 - a1*c2 - 
a2*b1 + a2*c1 + b1*c2 - b2*c1),
(a1**2*b1 - a1**2*c1 + a1*a2*b2 - a1*a2*c2 - a1*b1**2 + a1*c1**2 - a2*b1*b2 + a2
*c1*c2 + b1**2*c1 + b1*b2*c2 - b1*c1**2 - b2*c1*c2)/(a1*b2 - a1*c2 - a2*b1 + a2*
c1 + b1*c2 - b2*c1)}$

        S:=intersection_point(median(a,b,c),median(b,c,a));


s := {(a1 + b1 + c1)/3,(a2 + b2 + c2)/3}$


                collinear(M,H,S);


0$

                sqrdist(S,varpoint(M,H,2/3));


0$


% Feuerbach's circle

	% Choose a special coordinate system
	A:=Point(0,0);


a := {0,0}$
 B:=Point(u1,0);


b := {u1,0}$
 C:=Point(u2,u3);


c := {u2,u3}$


        M:=intersection_point(mp(a,b),mp(b,c));


m := {u1/2,( - u1*u2 + u2**2 + u3**2)/(2*u3)}$

        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));


h := {u2,(u2*(u1 - u2))/u3}$

        N:=midpoint(M,H);


n := {(u1 + 2*u2)/4,(u1*u2 - u2**2 + u3**2)/(4*u3)}$


                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(B,C));


0$

                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(H,C));


0$


        D:=intersection_point(pp_line(A,B),pp_line(H,C));


d := {u2,0}$


                sqrdist(N,midpoint(A,B))-sqrdist(N,D);


0$


clear_ndg();


{}$
 clear(A,B,C,D,M,H,S,N);



% ############################# 
% Non-linear Geometric Objects
% #############################

% Bisector intersection theorem
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(x1,x2);


p := {x1,x2}$

 
polys:={
        point_on_bisector(P,A,B,C),
        point_on_bisector(P,B,C,A),
        point_on_bisector(P,C,A,B)};


polys := { - 2*u1*x1*x2 + 2*u1*x2 + u2*x1**2 - 2*u2*x1 - u2*x2**2 + u2 + 2*x1*x2
 - 2*x2,
 - 2*u1**3*x2 + 2*u1**2*u2*x1 - u1**2*u2 + 2*u1**2*x1*x2 + 2*u1**2*x2 - 2*u1*u2
**2*x2 - 2*u1*u2*x1**2 + 2*u1*u2*x2**2 - 2*u1*x1*x2 + 2*u2**3*x1 - u2**3 - 2*u2
**2*x1*x2 + 2*u2**2*x2 + u2*x1**2 - u2*x2**2,
2*u1*x1*x2 - u2*x1**2 + u2*x2**2}$


con1:=num(sqrdist(P,pedalpoint(p,pp_line(A,C)))-x2^2);


con1 := u2*( - 2*u1**3*x1*x2 + u1**2*u2*x1**2 - u1**2*u2*x2**2 - 2*u1*u2**2*x1*
x2 + u2**3*x1**2 - u2**3*x2**2)$

con2:=num(sqrdist(p,pedalpoint(p,pp_line(B,C)))-x2^2);


con2 := u2*( - 2*u1**3*x1*x2 + 2*u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1
**2*u2*x2**2 + u1**2*u2 + 6*u1**2*x1*x2 - 6*u1**2*x2 - 2*u1*u2**2*x1*x2 + 2*u1*
u2**2*x2 - 2*u1*u2*x1**2 + 4*u1*u2*x1 + 2*u1*u2*x2**2 - 2*u1*u2 - 6*u1*x1*x2 + 6
*u1*x2 + u2**3*x1**2 - 2*u2**3*x1 - u2**3*x2**2 + u2**3 + 2*u2**2*x1*x2 - 2*u2**
2*x2 + u2*x1**2 - 2*u2*x1 - u2*x2**2 + u2 + 2*x1*x2 - 2*x2)$


setring({x1,x2},{},lex);


{{x1,x2},{},lex,{1,1}}$

setideal(polys,polys);


{u2*x1**2 - (2*u1 - 2)*x1*x2 - (2*u2)*x1 - u2*x2**2 + (2*u1 - 2)*x2 + u2,
 - (2*u1*u2 - u2)*x1**2 + (2*u1**2 - 2*u1 - 2*u2**2)*x1*x2 + (2*u1**2*u2 + 2*u2
**3)*x1 + (2*u1*u2 - u2)*x2**2 - (2*u1**3 - 2*u1**2 + 2*u1*u2**2 - 2*u2**2)*x2 -
 (u1**2*u2 + u2**3),
 - u2*x1**2 + (2*u1)*x1*x2 + u2*x2**2}$

gbasis polys;


{(4*u2)*x2**4 - (8*u1**2 - 8*u1 + 8*u2**2)*x2**3 + (4*u1**2*u2 - 4*u1*u2 + 4*u2
**3 - 4*u2)*x2**2 + (4*u2**2)*x2 - u2**3,
(2*u1*u2**2 - u2**2)*x1 + (2*u2)*x2**3 - (4*u1**2 - 4*u1 + 2*u2**2)*x2**2 - (2*
u1**2*u2 - 2*u1*u2 + 2*u2)*x2 - (u1*u2**2 - u2**2)}$

{con1,con2} mod gbasis polys;


{0,0}$


% Bisector intersection theorem. A constructive proof.
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 P:=Point(u1,u2);


p := {u1,u2}$

l1:=pp_line(A,B);


l1 := {0,-1,0}$

l2:=symline(l1,pp_line(A,P));


l2 := { - 2*u1*u2,u1**2 - u2**2,0}$

l3:=symline(l1,pp_line(B,P));


l3 := {2*u2*( - u1 + 1),
u1**2 - 2*u1 - u2**2 + 1,
2*u2*(u1 - 1)}$


point_on_bisector(P,A,B,intersection_point(l2,l3));


0$


clear_ndg();


{}$
 clear(A,B,C,P,l1,l2,l3);



% Miquel's theorem

on gcd;


A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(c1,c2);


c := {c1,c2}$

P:=choose_pl(pp_line(A,B),u1);


p := {u1,0}$

Q:=choose_pl(pp_line(B,C),u2);


q := {u2,(c2*(u2 - 1))/(c1 - 1)}$

R:=choose_pl(pp_line(A,C),u3);


r := {u3,(c2*u3)/c1}$


X:=other_cc_point(P,p3_circle(A,P,R),p3_circle(B,P,Q))$



point_on_circle(X,p3_circle(C,Q,R));


0$


off gcd;


clear_ndg();


{}$
 clear(A,B,C,P,Q,R,X);



% ########################
% Theorems of linear type
% ########################

% Pappus' theorem

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
 C:=Point(x1,u5);


c := {x1,u5}$
 
P:=Point(u6,u7);


p := {u6,u7}$
 Q:=Point(u8,u9);


q := {u8,u9}$
 R:=Point(u0,x2);


r := {u0,x2}$


polys:={collinear(A,B,C), collinear(P,Q,R)};


polys := {u1*u4 - u1*u5 - u2*u3 + u2*x1 + u3*u5 - u4*x1,
u0*u7 - u0*u9 + u6*u9 - u6*x2 - u7*u8 + u8*x2}$


con:=collinear(
	intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)))$



vars:={x1,x2};


vars := {x1,x2}$

sol:=solve(polys,vars);


sol := {{x1=( - u1*u4 + u1*u5 + u2*u3 - u3*u5)/(u2 - u4),
x2=(u0*u7 - u0*u9 + u6*u9 - u7*u8)/(u6 - u8)}}$


sub(sol,con);


0$


% Pappus' theorem. A constructive approach

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
  
P:=Point(u6,u7);


p := {u6,u7}$
 Q:=Point(u8,u9);


q := {u8,u9}$
 

C:=choose_pl(pp_line(A,B),u5);


c := {u5,
(u1*u4 - u2*u3 + u2*u5 - u4*u5)/(u1 - u3)}$

R:=choose_pl(pp_line(P,Q),u0);


r := {u0,
(u0*u7 - u0*u9 + u6*u9 - u7*u8)/(u6 - u8)}$


con:=collinear(intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)));


con := 0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% ###########################
% Theorems of non linear type
% ###########################

% Fermat Point

A:=Point(0,0);


a := {0,0}$
 B:=Point(0,2);


b := {0,2}$
 C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(x1,x2);


p := {x1,x2}$
 Q:=Point(x3,x4);


q := {x3,x4}$
 R:=Point(x5,x6);


r := {x5,x6}$


polys1:={sqrdist(P,B)-sqrdist(B,C), sqrdist(P,C)-sqrdist(B,C), 
	sqrdist(Q,A)-sqrdist(A,C), sqrdist(Q,C)-sqrdist(A,C), 
	sqrdist(R,B)-sqrdist(A,B), sqrdist(R,A)-sqrdist(A,B)};


polys1 := { - u1**2 - u2**2 + 4*u2 + x1**2 + x2**2 - 4*x2,
 - 2*u1*x1 - 2*u2*x2 + 4*u2 + x1**2 + x2**2 - 4,
 - u1**2 - u2**2 + x3**2 + x4**2,
 - 2*u1*x3 - 2*u2*x4 + x3**2 + x4**2,
x5**2 + x6**2 - 4*x6,
x5**2 + x6**2 - 4}$


con:=concurrent(pp_line(A,P), pp_line(B,Q), pp_line(C,R));


con :=  - u1*x1*x4*x6 + 2*u1*x1*x6 + u1*x2*x3*x6 - 2*u1*x2*x3 + 2*u2*x1*x3 + u2*
x1*x4*x5 - 2*u2*x1*x5 - u2*x2*x3*x5 - 2*x1*x3*x6 + 2*x2*x3*x5$


vars:={x1,x2,x3,x4,x5,x6};


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

setring(vars,{},lex);


{{x1,x2,x3,x4,x5,x6},{},lex,{1,1,1,1,1,1}}$

iso:=isolatedprimes polys1;


iso := {{x5**2 - 3,
x6 - 1,
u1*x5 - u2 + 2*x4,
 - u1*x5 - u2 + 2*x2 - 2,
 - u1 - u2*x5 + 2*x3,
 - u1 + u2*x5 + 2*x1 - 2*x5},
{x5**2 - 3,
x6 - 1,
 - u1*x5 - u2 + 2*x4,
u1*x5 - u2 + 2*x2 - 2,
 - u1 + u2*x5 + 2*x3,
 - u1 - u2*x5 + 2*x1 + 2*x5},
{x5**2 - 3,
x6 - 1,
u1*x5 - u2 + 2*x4,
u1*x5 - u2 + 2*x2 - 2,
 - u1 - u2*x5 + 2*x3,
 - u1 - u2*x5 + 2*x1 + 2*x5},
{x5**2 - 3,
x6 - 1,
 - u1*x5 - u2 + 2*x4,
 - u1*x5 - u2 + 2*x2 - 2,
 - u1 + u2*x5 + 2*x3,
 - u1 + u2*x5 + 2*x1 - 2*x5}}$


for each u in iso collect con mod u;


{ - 3*u1**2*u2 + 3*u1**2 - 2*u1*u2*x5 + 2*u1*x5 - 3*u2**3 + 9*u2**2 - 6*u2,
0,
(u1**3*x5 + 3*u1**2*u2 - 6*u1**2 + u1*u2**2*x5 - 4*u1*u2*x5 + 3*u2**3 - 18*u2**2
 + 24*u2)/2,
( - u1**3*x5 + 3*u1**2*u2 - u1*u2**2*x5 + 4*u1*x5 + 3*u2**3 - 12*u2)/2}$


polys2:={sqrdist(P,B)-sqrdist(P,C), 
	sqrdist(Q,A)-sqrdist(Q,C),  
	sqrdist(R,A)-sqrdist(R,B), 
	num(p3_angle(R,A,B)-p3_angle(P,B,C)), 
	num(p3_angle(Q,C,A)-p3_angle(P,B,C))};


polys2 := { - u1**2 + 2*u1*x1 - u2**2 + 2*u2*x2 - 4*x2 + 4,
 - u1**2 + 2*u1*x3 - u2**2 + 2*u2*x4,
4*(x6 - 1),
 - u1*x1*x5 - u1*x2*x6 + 2*u1*x6 + u2*x1*x6 - u2*x2*x5 + 2*u2*x5 - 2*x1*x6 + 2*
x2*x5 - 4*x5,
u1**3*x2 - 2*u1**3 - u1**2*u2*x1 + u1**2*x1*x4 + 2*u1**2*x1 - u1**2*x2*x3 + 2*u1
**2*x3 + u1*u2**2*x2 - 2*u1*u2**2 - 2*u1*x1*x3 - 2*u1*x2*x4 + 4*u1*x4 - u2**3*x1
 + u2**2*x1*x4 + 2*u2**2*x1 - u2**2*x2*x3 + 2*u2**2*x3 - 2*u2*x1*x4 + 2*u2*x2*x3
 - 4*u2*x3}$


sol:=solve(polys2,{x1,x2,x3,x4,x6});


sol := {{x2=( - u1*x5 + u2 + 2)/2,
x4=(u1*x5 + u2)/2,
x1=(u1 + u2*x5 - 2*x5)/2,
x3=(u1 - u2*x5)/2,
x6=1}}$

sub(sol,con);


0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% ####################
%  Desargue's theorem
% ####################

% A constructive proof.

A:=Point(a1,a2);


a := {a1,a2}$
 B:=Point(b1,b2);


b := {b1,b2}$
 
C:=Point(c1,c2);


c := {c1,c2}$
 R:=Point(d1,d2);


r := {d1,d2}$


S:=choose_pl(par(R,pp_line(A,B)),u);


s := {u,
(a1*d2 - a2*d1 + a2*u - b1*d2 + b2*d1 - b2*u)/(a1 - b1)}$

T:=intersection_point(par(R,pp_line(A,C)),par(S,pp_line(B,C)));


t := {(a1*u - b1*d1 + c1*d1 - c1*u)/(a1 - b1),
(a1*d2 - a2*d1 + a2*u - b1*d2 + c2*d1 - c2*u)/(a1 - b1)}$

 
con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con := 0$


% Desargue's theorem as theorem of linear type.

A:=Point(u1,u2);


a := {u1,u2}$
 B:=Point(u3,u4);


b := {u3,u4}$
 C:=Point(u5,u6);


c := {u5,u6}$

R:=Point(u7,u8);


r := {u7,u8}$
 S:=Point(u9,x1);


s := {u9,x1}$
 T:=Point(x2,x3);


t := {x2,x3}$


polys:={parallel(pp_line(R,S),pp_line(A,B)),
	parallel(pp_line(S,T),pp_line(B,C)),
	parallel(pp_line(R,T),pp_line(A,C))};


polys := { - u1*u8 + u1*x1 + u2*u7 - u2*u9 + u3*u8 - u3*x1 - u4*u7 + u4*u9,
 - u3*x1 + u3*x3 + u4*u9 - u4*x2 + u5*x1 - u5*x3 - u6*u9 + u6*x2,
 - u1*u8 + u1*x3 + u2*u7 - u2*x2 + u5*u8 - u5*x3 - u6*u7 + u6*x2}$


con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con :=  - u1*u3*u6*u8 + u1*u3*u6*x1 + u1*u3*u8*x3 - u1*u3*x1*x3 + u1*u4*u5*u8 - 
u1*u4*u5*x3 - u1*u4*u6*u9 + u1*u4*u6*x2 - u1*u4*u8*x2 + u1*u4*u9*x3 - u1*u5*u8*
x1 + u1*u5*x1*x3 + u1*u6*u8*u9 - u1*u6*x1*x2 - u1*u8*u9*x3 + u1*u8*x1*x2 - u2*u3
*u5*x1 + u2*u3*u5*x3 + u2*u3*u6*u7 - u2*u3*u6*x2 - u2*u3*u7*x3 + u2*u3*x1*x2 - 
u2*u4*u5*u7 + u2*u4*u5*u9 + u2*u4*u7*x2 - u2*u4*u9*x2 + u2*u5*u7*x1 - u2*u5*u9*
x3 - u2*u6*u7*u9 + u2*u6*u9*x2 + u2*u7*u9*x3 - u2*u7*x1*x2 + u3*u5*u8*x1 - u3*u5
*u8*x3 - u3*u6*u7*x1 + u3*u6*u8*x2 + u3*u7*x1*x3 - u3*u8*x1*x2 + u4*u5*u7*x3 - 
u4*u5*u8*u9 + u4*u6*u7*u9 - u4*u6*u7*x2 - u4*u7*u9*x3 + u4*u8*u9*x2 - u5*u7*x1*
x3 + u5*u8*u9*x3 + u6*u7*x1*x2 - u6*u8*u9*x2$


sol:=solve(polys,{x1,x2,x3});


sol := {{x1=(u1*u8 - u2*u7 + u2*u9 - u3*u8 + u4*u7 - u4*u9)/(u1 - u3),
x2=(u1*u9 - u3*u7 + u5*u7 - u5*u9)/(u1 - u3),
x3=(u1*u8 - u2*u7 + u2*u9 - u3*u8 + u6*u7 - u6*u9)/(u1 - u3)}}$

sub(sol,con);


0$


% The general theorem of Desargue.

A:=Point(0,0);


a := {0,0}$
 B:=Point(0,1);


b := {0,1}$
 C:=Point(u5,u6);


c := {u5,u6}$

R:=Point(u7,u8);


r := {u7,u8}$
 S:=Point(u9,u1);


s := {u9,u1}$
 T:=Point(u2,x1);


t := {u2,x1}$


con1:=collinear(intersection_point(pp_line(R,S),pp_line(A,B)),
	intersection_point(pp_line(S,T),pp_line(B,C)),
	intersection_point(pp_line(R,T),pp_line(A,C)));


con1 := (u5*( - u1**2*u2**2*u6*u7 + u1**2*u2*u5*u7*x1 + u1**2*u2*u6*u7**2 - u1**
2*u5*u7**2*x1 + u1*u2**2*u6*u7*u8 + u1*u2**2*u6*u7 + u1*u2**2*u6*u8*u9 - u1*u2**
2*u8*u9 - u1*u2*u5*u7*u8*x1 - u1*u2*u5*u7*x1 - u1*u2*u5*u8*u9*x1 + u1*u2*u5*u8*
u9 - u1*u2*u6*u7**2*x1 - u1*u2*u6*u7**2 - 2*u1*u2*u6*u7*u8*u9 + u1*u2*u6*u7*u9*
x1 - u1*u2*u6*u7*u9 + u1*u2*u7*u8*u9 + u1*u2*u7*u9*x1 + u1*u5*u7**2*x1**2 + u1*
u5*u7**2*x1 + 2*u1*u5*u7*u8*u9*x1 - u1*u5*u7*u8*u9 - u1*u5*u7*u9*x1**2 + u1*u6*
u7**2*u9 - u1*u7**2*u9*x1 - u2**2*u6*u7*u8 - u2**2*u6*u8**2*u9 + u2**2*u8**2*u9 
+ u2*u5*u7*u8*x1 + u2*u5*u8**2*u9*x1 - u2*u5*u8**2*u9 + u2*u6*u7**2*x1 + u2*u6*
u7*u8*u9*x1 + 2*u2*u6*u7*u8*u9 - u2*u6*u7*u9*x1 + u2*u6*u8**2*u9**2 - u2*u6*u8*
u9**2*x1 - 2*u2*u7*u8*u9*x1 - u2*u8**2*u9**2 + u2*u8*u9**2*x1 - u5*u7**2*x1**2 -
 u5*u7*u8*u9*x1**2 + u5*u7*u9*x1**2 - u5*u8**2*u9**2*x1 + u5*u8**2*u9**2 + u5*u8
*u9**2*x1**2 - u5*u8*u9**2*x1 - u6*u7**2*u9*x1 - u6*u7*u8*u9**2 + u6*u7*u9**2*x1
 + u7**2*u9*x1**2 + u7*u8*u9**2*x1 - u7*u9**2*x1**2))/(u1*u2*u5*u6*u7 - u1*u2*u5
*u6*u9 + u1*u5**2*u7*u8 - u1*u5**2*u7*x1 - u1*u5**2*u8*u9 + u1*u5**2*u9*x1 - u1*
u5*u6*u7**2 + u1*u5*u6*u7*u9 + u2**2*u6**2*u7 - u2**2*u6**2*u9 - u2**2*u6*u7 + 
u2**2*u6*u9 + u2*u5*u6*u7*u8 - 2*u2*u5*u6*u7*x1 - u2*u5*u6*u8*u9 + 2*u2*u5*u6*u9
*x1 - u2*u5*u7*u8 + u2*u5*u7*x1 + u2*u5*u8*u9 - u2*u5*u9*x1 - u2*u6**2*u7**2 + 
u2*u6**2*u9**2 + u2*u6*u7**2 - u2*u6*u9**2 - u5**2*u7*u8*x1 + u5**2*u7*x1**2 + 
u5**2*u8*u9*x1 - u5**2*u9*x1**2 + u5*u6*u7**2*x1 - u5*u6*u7*u8*u9 + u5*u6*u8*u9
**2 - u5*u6*u9**2*x1 + u5*u7*u8*u9 - u5*u7*u9*x1 - u5*u8*u9**2 + u5*u9**2*x1 + 
u6**2*u7**2*u9 - u6**2*u7*u9**2 - u6*u7**2*u9 + u6*u7*u9**2)$


con2:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));


con2 := u1*u2*u6*u7 - u1*u5*u7*x1 - u2*u6*u7 - u2*u6*u8*u9 + u2*u8*u9 + u5*u7*x1
 + u5*u8*u9*x1 - u5*u8*u9 + u6*u7*u9 - u7*u9*x1$


sol:=solve(con2,x1);


sol := {x1=(u1*u2*u6*u7 - u2*u6*u7 - u2*u6*u8*u9 + u2*u8*u9 - u5*u8*u9 + u6*u7*
u9)/(u1*u5*u7 - u5*u7 - u5*u8*u9 + u7*u9)}$

sub(sol,con1);


0$


clear_ndg();


{}$
 clear(A,B,C,R,S,T);



% #################
%  Brocard points
% #################

A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(u1,u2);


c := {u1,u2}$


c1:=Circle(1,x1,x2,x3);


c1 := {1,x1,x2,x3}$

c2:=Circle(1,x4,x5,x6);


c2 := {1,x4,x5,x6}$

c3:=Circle(1,x7,x8,x9);


c3 := {1,x7,x8,x9}$


polys:={
	cl_tangent(c1,pp_line(A,C)), 
	point_on_circle(A,c1), 
	point_on_circle(B,c1), 
	cl_tangent(c2,pp_line(A,B)), 
	point_on_circle(B,c2), 
	point_on_circle(C,c2), 
	cl_tangent(c3,pp_line(B,C)), 
	point_on_circle(A,c3), 
	point_on_circle(C,c3)};


polys := {u1**2*x1**2 - 4*u1**2*x3 + 2*u1*u2*x1*x2 + u2**2*x2**2 - 4*u2**2*x3,
x3,
x1 + x3 + 1,
x4**2 - 4*x6,
x4 + x6 + 1,
u1**2 + u1*x4 + u2**2 + u2*x5 + x6,
u1**2*x7**2 - 4*u1**2*x9 + 2*u1*u2*x7*x8 + 4*u1*u2*x8 - 2*u1*x7**2 + 8*u1*x9 - 4
*u2**2*x7 + u2**2*x8**2 - 4*u2**2*x9 - 4*u2**2 - 2*u2*x7*x8 - 4*u2*x8 + x7**2 - 
4*x9,
x9,
u1**2 + u1*x7 + u2**2 + u2*x8 + x9}$

 
vars:={x1,x2,x3,x4,x5,x6,x7,x8,x9};


vars := {x1,
x2,
x3,
x4,
x5,
x6,
x7,
x8,
x9}$

sol:=solve(polys,vars);


sol := {{x6=1,
x8=( - u1**3 + u1**2 - u1*u2**2 - u2**2)/u2,
x2=u1/u2,
x1=-1,
x3=0,
x4=-2,
x5=( - u1**2 + 2*u1 - u2**2 - 1)/u2,
x7=u1**2 - 2*u1 + u2**2,
x9=0}}$


P:=other_cc_point(B,sub(sol,c1),sub(sol,c2));


p := {(u1**3 - u1**2 + u1*u2**2 + u1 + u2**2)/(u1**4 - 2*u1**3 + 2*u1**2*u2**2 +
 3*u1**2 - 2*u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1),
(u2*(u1**2 - 2*u1 + u2**2 + 1))/(u1**4 - 2*u1**3 + 2*u1**2*u2**2 + 3*u1**2 - 2*
u1*u2**2 - 2*u1 + u2**4 + 3*u2**2 + 1)}$

con:=point_on_circle(P,sub(sol,c3));


con := 0$


clear_ndg();


{}$
 clear A,B,C,c1,c2,c3;

	

% ##################
%  Simson's theorem
% ##################

% A constructive proof

        M:=Point(0,0);


m := {0,0}$

        A:=choose_pc(M,r,u1);


a := {(r*(u1**2 - 1))/(u1**2 + 1),(2*r*u1)/(u1**2 + 1)}$

        B:=choose_pc(M,r,u2);


b := {(r*(u2**2 - 1))/(u2**2 + 1),(2*r*u2)/(u2**2 + 1)}$

        C:=choose_pc(M,r,u3);


c := {(r*(u3**2 - 1))/(u3**2 + 1),(2*r*u3)/(u3**2 + 1)}$

        P:=choose_pc(M,r,u4);


p := {(r*(u4**2 - 1))/(u4**2 + 1),(2*r*u4)/(u4**2 + 1)}$

        X:=pedalpoint(P,pp_line(A,B))$


        Y:=pedalpoint(P,pp_line(B,C))$


        Z:=pedalpoint(P,pp_line(A,C))$


 
        collinear(X,Y,Z);


0$


clear_ndg();


{}$
 clear(M,A,B,C,P,X,Y,Z);



% Simson's theorem almost constructive

clear_ndg();


{}$


	A:=Point(0,0);


a := {0,0}$
 B:=Point(u1,u2);


b := {u1,u2}$
 
	C:=Point(u3,u4);


c := {u3,u4}$
 P:=Point(u5,x1);


p := {u5,x1}$

        X:=pedalpoint(P,pp_line(A,B));


x := {(u1*(u1*u5 + u2*x1))/(u1**2 + u2**2),
(u2*(u1*u5 + u2*x1))/(u1**2 + u2**2)}$

        Y:=pedalpoint(P,pp_line(B,C));


y := {(u1**2*u5 - u1*u2*u4 + u1*u2*x1 - 2*u1*u3*u5 + u1*u4**2 - u1*u4*x1 + u2**2
*u3 - u2*u3*u4 - u2*u3*x1 + u3**2*u5 + u3*u4*x1)/(u1**2 - 2*u1*u3 + u2**2 - 2*u2
*u4 + u3**2 + u4**2),
(u1**2*u4 - u1*u2*u3 + u1*u2*u5 - u1*u3*u4 - u1*u4*u5 + u2**2*x1 + u2*u3**2 - u2
*u3*u5 - 2*u2*u4*x1 + u3*u4*u5 + u4**2*x1)/(u1**2 - 2*u1*u3 + u2**2 - 2*u2*u4 + 
u3**2 + u4**2)}$

        Z:=pedalpoint(P,pp_line(A,C));


z := {(u3*(u3*u5 + u4*x1))/(u3**2 + u4**2),
(u4*(u3*u5 + u4*x1))/(u3**2 + u4**2)}$


	poly:=p4_circle(A,B,C,P);


poly := u1**2*u3*x1 - u1**2*u4*u5 - u1*u3**2*x1 - u1*u4**2*x1 + u1*u4*u5**2 + u1
*u4*x1**2 + u2**2*u3*x1 - u2**2*u4*u5 + u2*u3**2*u5 - u2*u3*u5**2 - u2*u3*x1**2 
+ u2*u4**2*u5$
 

        con:=collinear(X,Y,Z);


con := ( - u1**4*u3*u4**2*x1 + u1**4*u4**3*u5 + 2*u1**3*u2*u3**2*u4*x1 - 2*u1**3
*u2*u3*u4**2*u5 + u1**3*u3**2*u4**2*x1 + u1**3*u4**4*x1 - u1**3*u4**3*u5**2 - u1
**3*u4**3*x1**2 - u1**2*u2**2*u3**3*x1 + u1**2*u2**2*u3**2*u4*u5 - u1**2*u2**2*
u3*u4**2*x1 + u1**2*u2**2*u4**3*u5 - 2*u1**2*u2*u3**3*u4*x1 - u1**2*u2*u3**2*u4
**2*u5 - 2*u1**2*u2*u3*u4**3*x1 + 3*u1**2*u2*u3*u4**2*u5**2 + 3*u1**2*u2*u3*u4**
2*x1**2 - u1**2*u2*u4**4*u5 + 2*u1*u2**3*u3**2*u4*x1 - 2*u1*u2**3*u3*u4**2*u5 + 
u1*u2**2*u3**4*x1 + 2*u1*u2**2*u3**3*u4*u5 + u1*u2**2*u3**2*u4**2*x1 - 3*u1*u2**
2*u3**2*u4*u5**2 - 3*u1*u2**2*u3**2*u4*x1**2 + 2*u1*u2**2*u3*u4**3*u5 - u2**4*u3
**3*x1 + u2**4*u3**2*u4*u5 - u2**3*u3**4*u5 + u2**3*u3**3*u5**2 + u2**3*u3**3*x1
**2 - u2**3*u3**2*u4**2*u5)/(u1**4*u3**2 + u1**4*u4**2 - 2*u1**3*u3**3 - 2*u1**3
*u3*u4**2 + 2*u1**2*u2**2*u3**2 + 2*u1**2*u2**2*u4**2 - 2*u1**2*u2*u3**2*u4 - 2*
u1**2*u2*u4**3 + u1**2*u3**4 + 2*u1**2*u3**2*u4**2 + u1**2*u4**4 - 2*u1*u2**2*u3
**3 - 2*u1*u2**2*u3*u4**2 + u2**4*u3**2 + u2**4*u4**2 - 2*u2**3*u3**2*u4 - 2*u2
**3*u4**3 + u2**2*u3**4 + 2*u2**2*u3**2*u4**2 + u2**2*u4**4)$


	remainder(num con,poly);


0$


print_ndg();


{u3**2 + u4**2,
u1**2 - 2*u1*u3 + u2**2 - 2*u2*u4 + u3**2 + u4**2,
u1**2 + u2**2}$


% Equational proof, first version:

M:=Point(0,0);


m := {0,0}$
 A:=Point(0,1);


a := {0,1}$
 
B:=Point(u1,x1);


b := {u1,x1}$
 C:=Point(u2,x2);


c := {u2,x2}$
 P:=Point(u3,x3);


p := {u3,x3}$


X:=varpoint(A,B,x4);


x := {u1*( - x4 + 1), - x1*x4 + x1 + x4}$
 Y:=varpoint(B,C,x5);


y := {u1*x5 - u2*x5 + u2,x1*x5 - x2*x5 + x2}$
 Z:=varpoint(A,C,x6);


z := {u2*( - x6 + 1), - x2*x6 + x2 + x6}$


polys:={sqrdist(M,B)-1, sqrdist(M,C)-1, sqrdist(M,P)-1,
	orthogonal(pp_line(A,B),pp_line(P,X)),
	orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y))};


polys := {u1**2 + x1**2 - 1,
u2**2 + x2**2 - 1,
u3**2 + x3**2 - 1,
 - u1**2*x4 + u1**2 - u1*u3 - x1**2*x4 + x1**2 - x1*x3 + 2*x1*x4 - x1 + x3 - x4,
 - u2**2*x6 + u2**2 - u2*u3 - x2**2*x6 + x2**2 - x2*x3 + 2*x2*x6 - x2 + x3 - x6,
 - u1**2*x5 + 2*u1*u2*x5 - u1*u2 + u1*u3 - u2**2*x5 + u2**2 - u2*u3 - x1**2*x5 +
 2*x1*x2*x5 - x1*x2 + x1*x3 - x2**2*x5 + x2**2 - x2*x3}$


con:=collinear(X,Y,Z);


con := u1*x2*x4*x5 - u1*x2*x4*x6 - u1*x2*x5*x6 + u1*x2*x6 - u1*x4*x5 + u1*x4*x6 
+ u1*x5*x6 - u1*x6 - u2*x1*x4*x5 + u2*x1*x4*x6 + u2*x1*x5*x6 - u2*x1*x6 + u2*x4*
x5 - u2*x4*x6 - u2*x5*x6 + u2*x6$


vars:={x4,x5,x6,x1,x2,x3};


vars := {x4,
x5,
x6,
x1,
x2,
x3}$

setring(vars,{},lex);


{{x4,x5,x6,x1,x2,x3},{},lex,{1,1,1,1,1,1}}$

setideal(polys,polys);


{x1**2 + (u1**2 - 1),
x2**2 + (u2**2 - 1),
x3**2 + (u3**2 - 1),
 - x4*x1**2 + 2*x4*x1 - (u1**2 + 1)*x4 + x1**2 - x1*x3 - x1 + x3 + (u1**2 - u1*
u3),
 - x6*x2**2 + 2*x6*x2 - (u2**2 + 1)*x6 + x2**2 - x2*x3 - x2 + x3 + (u2**2 - u2*
u3),
 - x5*x1**2 + 2*x5*x1*x2 - x5*x2**2 - (u1**2 - 2*u1*u2 + u2**2)*x5 - x1*x2 + x1*
x3 + x2**2 - x2*x3 - (u1*u2 - u1*u3 - u2**2 + u2*u3)}$

con mod gbasis polys;


0$


% Second version:

A:=Point(0,0);


a := {0,0}$

B:=Point(1,0);


b := {1,0}$

C:=Point(u1,u2);


c := {u1,u2}$

P:=Point(u3,x1);


p := {u3,x1}$

X:=Point(x2,0);


x := {x2,0}$
		% => on the line AB 
Y:=varpoint(B,C,x3);


y := { - u1*x3 + u1 + x3,u2*( - x3 + 1)}$

Z:=varpoint(A,C,x4);


z := {u1*( - x4 + 1),u2*( - x4 + 1)}$


polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	p4_circle(A,B,C,P)};


polys := { - u1**2*x4 + u1**2 - u1*u3 - u2**2*x4 + u2**2 - u2*x1,
 - u1**2*x3 + u1**2 - u1*u3 + 2*u1*x3 - u1 - u2**2*x3 + u2**2 - u2*x1 + u3 - x3,
 - u3 + x2,
 - u1**2*x1 + u1*x1 - u2**2*x1 + u2*u3**2 - u2*u3 + u2*x1**2}$


con:=collinear(X,Y,Z);


con := u2*( - x2*x3 + x2*x4 - x3*x4 + x3)$


vars:={x2,x3,x4,x1};


vars := {x2,x3,x4,x1}$

setring(vars,{},lex);


{{x2,x3,x4,x1},{},lex,{1,1,1,1}}$

con mod interreduce polys;


0$


% The inverse theorem

polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	collinear(X,Y,Z)};


polys := { - u1**2*x4 + u1**2 - u1*u3 - u2**2*x4 + u2**2 - u2*x1,
 - u1**2*x3 + u1**2 - u1*u3 + 2*u1*x3 - u1 - u2**2*x3 + u2**2 - u2*x1 + u3 - x3,
 - u3 + x2,
u2*( - x2*x3 + x2*x4 - x3*x4 + x3)}$


con:=p4_circle(A,B,C,P);


con :=  - u1**2*x1 + u1*x1 - u2**2*x1 + u2*u3**2 - u2*u3 + u2*x1**2$


con mod interreduce polys;


0$


clear_ndg();


{}$
 clear(M,A,B,C,P,Y,Z);



% ########################
%  The butterfly theorem
% ########################
 
% An equational proof with groebner factorizer and constraints. 

P:=Point(0,0);


p := {0,0}$

O:=Point(u1,0);


o := {u1,0}$

A:=Point(u2,u3);


a := {u2,u3}$
	
B:=Point(u4,x1);


b := {u4,x1}$

C:=Point(x2,x3);


c := {x2,x3}$
 
D:=Point(x4,x5);


d := {x4,x5}$
 
F:=Point(0,x6);


f := {0,x6}$

G:=Point(0,x7);


g := {0,x7}$


polys:={sqrdist(O,B)-sqrdist(O,A), 
	sqrdist(O,C)-sqrdist(O,A), 
	sqrdist(O,D)-sqrdist(O,A),
	point_on_line(P,pp_line(A,C)),
	point_on_line(P,pp_line(B,D)),
	point_on_line(F,pp_line(A,D)),
	point_on_line(G,pp_line(B,C))
};


polys := {2*u1*u2 - 2*u1*u4 - u2**2 - u3**2 + u4**2 + x1**2,
2*u1*u2 - 2*u1*x2 - u2**2 - u3**2 + x2**2 + x3**2,
2*u1*u2 - 2*u1*x4 - u2**2 - u3**2 + x4**2 + x5**2,
 - u2*x3 + u3*x2,
 - u4*x5 + x1*x4,
 - u2*x5 + u2*x6 + u3*x4 - x4*x6,
 - u4*x3 + u4*x7 + x1*x2 - x2*x7}$


con:=num sqrdist(P,midpoint(F,G));


con := x6**2 + 2*x6*x7 + x7**2$


vars:={x6,x7,x3,x5,x1,x2,x4};


vars := {x6,
x7,
x3,
x5,
x1,
x2,
x4}$

setring(vars,{},lex);


{{x6,x7,x3,x5,x1,x2,x4},{},lex,{1,1,1,1,1,1,1}}$


sol:=groebfactor(polys,{sqrdist(A,C),sqrdist(B,D)});


sol := {{x1**2 + (2*u1*u2 - 2*u1*u4 - u2**2 - u3**2 + u4**2),
(u2**2 + u3**2)*x3 - (2*u1*u2*u3 - u2**2*u3 - u3**3),
(2*u1*u2 - 2*u1*u4 - u2**2 - u3**2)*x5 + (2*u1*u2 - u2**2 - u3**2)*x1,
(2*u1*u2 - 2*u1*u4 - u2**2 - u3**2)*x4 + (2*u1*u2*u4 - u2**2*u4 - u3**2*u4),
(u2**2 + u3**2)*x2 - (2*u1*u2**2 - u2**3 - u2*u3**2),
(2*u1*u2**2 - u2**3 - u2**2*u4 - u2*u3**2 - u3**2*u4)*x7 - (2*u1*u2**2 - u2**3 -
 u2*u3**2)*x1 + (2*u1*u2*u3*u4 - u2**2*u3*u4 - u3**3*u4),
(2*u1*u2**2 - u2**3 - u2**2*u4 - u2*u3**2 - u3**2*u4)*x6 + (2*u1*u2**2 - u2**3 -
 u2*u3**2)*x1 - (2*u1*u2*u3*u4 - u2**2*u3*u4 - u3**3*u4)}}$


for each u in sol collect con mod u;


{0}$


% A constructive proof

on gcd;



O:=Point(0,0);


o := {0,0}$

A:=Point(1,0);


a := {1,0}$
	
B:=choose_pc(O,1,u1);


b := {(u1**2 - 1)/(u1**2 + 1),(2*u1)/(u1**2 + 1)}$

C:=choose_pc(O,1,u2);


c := {(u2**2 - 1)/(u2**2 + 1),(2*u2)/(u2**2 + 1)}$

D:=choose_pc(O,1,u3);


d := {(u3**2 - 1)/(u3**2 + 1),(2*u3)/(u3**2 + 1)}$

P:=intersection_point(pp_line(A,C),pp_line(B,D));


p := {(u1*u2 - u1*u3 + u2*u3 - 1)/(u1*u2 - u1*u3 + u2*u3 + 1),
(2*u2)/(u1*u2 - u1*u3 + u2*u3 + 1)}$


h:=lot(P,pp_line(O,P));


h := {( - u1*u2 + u1*u3 - u2*u3 + 1)/(u1*u2 - u1*u3 + u2*u3 + 1),
( - 2*u2)/(u1*u2 - u1*u3 + u2*u3 + 1),
(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 + 2*u1*u2**2*u3 - 2*u1*u2*u3**2 - 2*
u1*u2 + 2*u1*u3 + u2**2*u3**2 + 4*u2**2 - 2*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2
*u3 + u1**2*u3**2 + 2*u1*u2**2*u3 - 2*u1*u2*u3**2 + 2*u1*u2 - 2*u1*u3 + u2**2*u3
**2 + 2*u2*u3 + 1)}$


F:=intersection_point(h,pp_line(A,D));


f := {(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - 2*u1*u2 + 2*u1*u3 - u2**2*u3
**2 + 4*u2**2 - 4*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - u2**2*
u3**2 - 2*u2*u3 - 1),
(2*u3*(u1*u2 - u1*u3 - 2*u2**2 + u2*u3 - 1))/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**
2*u3**2 - u2**2*u3**2 - 2*u2*u3 - 1)}$
 
G:=intersection_point(h,pp_line(B,C));


g := {(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - 2*u1*u2 + 2*u1*u3 - u2**2*u3
**2 - 4*u2**2 + 4*u2*u3 + 1)/(u1**2*u2**2 - 2*u1**2*u2*u3 + u1**2*u3**2 - u2**2*
u3**2 - 2*u2*u3 - 1),
(2*(2*u1*u2**2 - 3*u1*u2*u3 + u1*u3**2 - u2*u3**2 - 2*u2 + u3))/(u1**2*u2**2 - 2
*u1**2*u2*u3 + u1**2*u3**2 - u2**2*u3**2 - 2*u2*u3 - 1)}$


con:=sqrdist(P,midpoint(F,G));


con := 0$


off gcd;


clear_ndg();


{}$
 clear(O,A,B,C,D,P,h,F,G);



% ################################
% Tangency of Feuerbach's circle
% ################################
 
A:=Point(0,0);


a := {0,0}$
 B:=Point(2,0);


b := {2,0}$
 C:=Point(u1,u2);


c := {u1,u2}$

M:=intersection_point(mp(A,B),mp(B,C));


m := {1,(u1**2 - 2*u1 + u2**2)/(2*u2)}$

H:=intersection_point(altitude(A,B,C),altitude(B,C,A));


h := {u1,(u1*( - u1 + 2))/u2}$

N:=midpoint(M,H);


n := {(u1 + 1)/2,( - u1**2 + 2*u1 + u2**2)/(4*u2)}$
	
c1:=c1_circle(N,sqrdist(N,midpoint(A,B)));


c1 := {1, - (u1 + 1),(u1**2 - 2*u1 - u2**2)/(2*u2),u1}$

			% Feuerbach's circle

P:=Point(x1,x2);


p := {x1,x2}$
	% => x2 is the radius of the inscribed circle. 

polys:={point_on_bisector(P,A,B,C), point_on_bisector(P,B,C,A)};


polys := {2*( - 2*u1*x1*x2 + 4*u1*x2 + u2*x1**2 - 4*u2*x1 - u2*x2**2 + 4*u2 + 4*
x1*x2 - 8*x2),
2*( - u1**3*x2 + u1**2*u2*x1 - u1**2*u2 + u1**2*x1*x2 + 2*u1**2*x2 - u1*u2**2*x2
 - u1*u2*x1**2 + u1*u2*x2**2 - 2*u1*x1*x2 + u2**3*x1 - u2**3 - u2**2*x1*x2 + 2*
u2**2*x2 + u2*x1**2 - u2*x2**2)}$


con:=cc_tangent(c1_circle(P,x2^2),c1);


con := (4*( - u1**3*x1*x2 + u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1**2*u2
*x2**2 + u1**2*u2 + u1**2*x1**2*x2 + u1**2*x1*x2 - 2*u1**2*x2 + u1*u2**2*x1*x2 -
 u1*u2**2*x2 - 2*u1*u2*x1**3 + 4*u1*u2*x1**2 - 2*u1*u2*x1 + 2*u1*u2*x2**2 - 2*u1
*x1**2*x2 + 2*u1*x1*x2 - u2**2*x1**2*x2 + u2**2*x1*x2 + u2*x1**4 - 2*u2*x1**3 + 
u2*x1**2 - u2*x2**2))/u2$
 

vars:={x1,x2};


vars := {x1,x2}$

setring(vars,{},lex);


{{x1,x2},{},lex,{1,1}}$

setideal(polys,polys);


{(2*u2)*x1**2 - (4*u1 - 8)*x1*x2 - (8*u2)*x1 - (2*u2)*x2**2 + (8*u1 - 16)*x2 + 8
*u2,
 - (2*u1*u2 - 2*u2)*x1**2 + (2*u1**2 - 4*u1 - 2*u2**2)*x1*x2 + (2*u1**2*u2 + 2*
u2**3)*x1 + (2*u1*u2 - 2*u2)*x2**2 - (2*u1**3 - 4*u1**2 + 2*u1*u2**2 - 4*u2**2)*
x2 - (2*u1**2*u2 + 2*u2**3)}$

num con mod gbasis polys;


0$


% Now let P be the incenter of the triangle ABH

polys1:={point_on_bisector(P,A,B,H), point_on_bisector(P,B,H,A)};


polys1 := {(2*( - u1**2*x1**2 + 4*u1**2*x1 + u1**2*x2**2 - 4*u1**2 - 2*u1*u2*x1*
x2 + 4*u1*u2*x2 + 2*u1*x1**2 - 8*u1*x1 - 2*u1*x2**2 + 8*u1 + 4*u2*x1*x2 - 8*u2*
x2))/u2,
(2*u1*( - u1**5*x1 + u1**5 - u1**4*u2*x2 + 6*u1**4*x1 - 6*u1**4 - u1**3*u2**2*x1
 + u1**3*u2**2 - u1**3*u2*x1*x2 + 6*u1**3*u2*x2 - 12*u1**3*x1 + 12*u1**3 - u1**2
*u2**3*x2 + u1**2*u2**2*x1**2 + 2*u1**2*u2**2*x1 - u1**2*u2**2*x2**2 - 2*u1**2*
u2**2 + 4*u1**2*u2*x1*x2 - 12*u1**2*u2*x2 + 8*u1**2*x1 - 8*u1**2 + u1*u2**3*x1*
x2 + 2*u1*u2**3*x2 - 3*u1*u2**2*x1**2 + 3*u1*u2**2*x2**2 - 4*u1*u2*x1*x2 + 8*u1*
u2*x2 - 2*u2**3*x1*x2 + 2*u2**2*x1**2 - 2*u2**2*x2**2))/u2**3}$


con1:=cc_tangent(c1_circle(P,x2^2),c1);


con1 := (4*( - u1**3*x1*x2 + u1**3*x2 + u1**2*u2*x1**2 - 2*u1**2*u2*x1 - u1**2*
u2*x2**2 + u1**2*u2 + u1**2*x1**2*x2 + u1**2*x1*x2 - 2*u1**2*x2 + u1*u2**2*x1*x2
 - u1*u2**2*x2 - 2*u1*u2*x1**3 + 4*u1*u2*x1**2 - 2*u1*u2*x1 + 2*u1*u2*x2**2 - 2*
u1*x1**2*x2 + 2*u1*x1*x2 - u2**2*x1**2*x2 + u2**2*x1*x2 + u2*x1**4 - 2*u2*x1**3 
+ u2*x1**2 - u2*x2**2))/u2$
 
setideal(polys1,polys1);


{ - (2*u1**2 - 4*u1)*x1**2 - (4*u1*u2 - 8*u2)*x1*x2 + (8*u1**2 - 16*u1)*x1 + (2*
u1**2 - 4*u1)*x2**2 + (8*u1*u2 - 16*u2)*x2 - (8*u1**2 - 16*u1),
(2*u1**3*u2**2 - 6*u1**2*u2**2 + 4*u1*u2**2)*x1**2 - (2*u1**4*u2 - 8*u1**3*u2 - 
2*u1**2*u2**3 + 8*u1**2*u2 + 4*u1*u2**3)*x1*x2 - (2*u1**6 - 12*u1**5 + 2*u1**4*
u2**2 + 24*u1**4 - 4*u1**3*u2**2 - 16*u1**3)*x1 - (2*u1**3*u2**2 - 6*u1**2*u2**2
 + 4*u1*u2**2)*x2**2 - (2*u1**5*u2 - 12*u1**4*u2 + 2*u1**3*u2**3 + 24*u1**3*u2 -
 4*u1**2*u2**3 - 16*u1**2*u2)*x2 + (2*u1**6 - 12*u1**5 + 2*u1**4*u2**2 + 24*u1**
4 - 4*u1**3*u2**2 - 16*u1**3)}$

num con1 mod gbasis polys1;


0$


clear_ndg();


{}$
 clear A,B,C,P,M,N,H,c1;



% #############################
% Solutions to the exercises
% #############################

% 1)

A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 C:=Point(1,1);


c := {1,1}$
 D:=Point(0,1);


d := {0,1}$

P:=Point(x1,x2);


p := {x1,x2}$
 Q:=Point(x3,1);


q := {x3,1}$


polys:={point_on_line(P,par(C,pp_line(B,D))),
	sqrdist(B,D)-sqrdist(B,P),
	point_on_line(Q,pp_line(B,P))};


polys := {x1 + x2 - 2,
 - x1**2 + 2*x1 - x2**2 + 1,
 - x1 + x2*x3 - x2 + 1}$


con:=sqrdist(D,P)-sqrdist(D,Q);


con := x1**2 + x2**2 - 2*x2 - x3**2 + 1$


setring({x1,x2,x3},{},lex);


{{x1,x2,x3},{},lex,{1,1,1}}$

setideal(polys,polys);


{x1 + x2 - 2,
 - x1**2 + 2*x1 - x2**2 + 1,
 - x1 + x2*x3 - x2 + 1}$

con mod gbasis polys;


0$


clear_ndg();


{}$
 clear(A,B,C,D,P,Q);



% 2)

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
Q:=Point(0,0);


q := {0,0}$
		% the pedal point on AB
R:=pedalpoint(B,pp_line(A,C));


r := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),
(u1*u3*(u1 - u2))/(u1**2 + u3**2)}$
 
P:=pedalpoint(A,pp_line(B,C));


p := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),
(u2*u3*( - u1 + u2))/(u2**2 + u3**2)}$
 

con1:=point_on_bisector(C,P,Q,R);


con1 := 0$

con2:=angle_sum(p3_angle(P,Q,C),p3_angle(R,Q,C));


con2 := 0$


clear_ndg();


{}$
 clear(A,B,C,P,Q,R);



% 3)

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
P:=pedalpoint(A,pp_line(B,C));


p := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),
(u2*u3*( - u1 + u2))/(u2**2 + u3**2)}$
 
Q:=pedalpoint(B,pp_line(A,C));


q := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),
(u1*u3*(u1 - u2))/(u1**2 + u3**2)}$
 
R:=pedalpoint(C,pp_line(A,B));


r := {0,0}$


P1:=pedalpoint(P,pp_line(A,B));


p1 := {(u2*(u1*u2 + u3**2))/(u2**2 + u3**2),0}$

P2:=pedalpoint(P,pp_line(A,C));


p2 := {(u1*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 + 
u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

Q1:=pedalpoint(Q,pp_line(A,B));


q1 := {(u1*(u1*u2 + u3**2))/(u1**2 + u3**2),0}$

Q2:=pedalpoint(Q,pp_line(B,C));


q2 := {(u2*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))/(u1**2*u2**2 + u1**2*u3**2 + 
u2**2*u3**2 + u3**4),
(u3**3*(u1**2 - 2*u1*u2 + u2**2))/(u1**2*u2**2 + u1**2*u3**2 + u2**2*u3**2 + u3
**4)}$

R1:=pedalpoint(R,pp_line(A,C));


r1 := {(u1*u3**2)/(u1**2 + u3**2),(u1**2*u3)/(u1**2 + u3**2)}$

R2:=pedalpoint(R,pp_line(B,C));


r2 := {(u2*u3**2)/(u2**2 + u3**2),(u2**2*u3)/(u2**2 + u3**2)}$


con:=for each X in {Q2,R1,R2} collect p4_circle(P1,P2,Q1,X);


con := {0,0,0}$


clear_ndg();


{}$
 clear(O,A,B,C,P,Q,R,P1,P2,Q1,Q2,R1,R2);



% 4) 

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
		% => Pedalpoint from C is (0,0)
M:=intersection_point(mp(A,B),mp(B,C));


m := {(u1 + u2)/2,(u1*u2 + u3**2)/(2*u3)}$


% Prove (2*h_c*R = a*b)^2

con:=4*u3^2*sqrdist(M,A)-sqrdist(C,B)*sqrdist(A,C);


con := 0$


clear_ndg();


{}$
 clear(A,B,C,M);



% 5. A solution of constructive type.

on gcd;


O:=Point(0,u1);


o := {0,u1}$
 A:=Point(0,0);


a := {0,0}$
	% hence k has radius u1.
B:=Point(u2,0);


b := {u2,0}$

M:=midpoint(A,B);


m := {u2/2,0}$

D:=choose_pc(O,u1,u3);


d := {(u1*(u3**2 - 1))/(u3**2 + 1),(u1*(u3**2 + 2*u3 + 1))/(u3**2 + 1)}$
 
k:=c1_circle(O,u1^2);


k := {1,0, - 2*u1,0}$

C:=other_cl_point(D,k,pp_line(M,D));


c := {(u1*u2*(4*u1*u3**2 + 8*u1*u3 + 4*u1 - u2*u3**2 + u2))/(8*u1**2*u3**2 + 16*
u1**2*u3 + 8*u1**2 - 4*u1*u2*u3**2 + 4*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(8*u1**2*u3**2 + 16*u1**2*u3 + 8*u1**2 - 4*u1*u2*
u3**2 + 4*u1*u2 + u2**2*u3**2 + u2**2)}$

Eh:=other_cl_point(D,k,pp_line(B,D));


eh := {(u1*u2*(2*u1*u3**2 + 4*u1*u3 + 2*u1 - u2*u3**2 + u2))/(2*u1**2*u3**2 + 4*
u1**2*u3 + 2*u1**2 - 2*u1*u2*u3**2 + 2*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(2*u1**2*u3**2 + 4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3
**2 + 2*u1*u2 + u2**2*u3**2 + u2**2)}$

F:=other_cl_point(C,k,pp_line(B,C));


f := {(u1*u2*( - 2*u1*u3**2 - 4*u1*u3 - 2*u1 + u2*u3**2 - u2))/(2*u1**2*u3**2 + 
4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3**2 + 2*u1*u2 + u2**2*u3**2 + u2**2),
(u1*u2**2*(u3**2 + 2*u3 + 1))/(2*u1**2*u3**2 + 4*u1**2*u3 + 2*u1**2 - 2*u1*u2*u3
**2 + 2*u1*u2 + u2**2*u3**2 + u2**2)}$


con:=parallel(pp_line(A,B),pp_line(Eh,F));


con := 0$


off gcd;


clear_ndg();


{}$
 clear(O,A,B,C,D,Eh,F,M,k);



% 6)

Z:=Point(0,0);


z := {0,0}$
 X:=Point(0,1);


x := {0,1}$
 Y:=Point(0,-1);


y := {0,-1}$
 
B:=Point(u1,0);


b := {u1,0}$
 C:=Point(u2,0);


c := {u2,0}$
 P:=Point(0,u3);


p := {0,u3}$

M:=Point(x1,x2);


m := {x1,x2}$
 N:=Point(x3,x4);


n := {x3,x4}$
 
A:=Point(x5,0);


a := {x5,0}$
 D:=Point(x6,0);


d := {x6,0}$


polys:={p4_circle(X,Y,B,N), p4_circle(X,Y,C,M),
	p4_circle(X,Y,B,D), p4_circle(X,Y,C,A),
	collinear(B,P,N), collinear(C,P,M)};


polys := {2*( - u1**2*x3 + u1*x3**2 + u1*x4**2 - u1 + x3),
2*( - u2**2*x1 + u2*x1**2 + u2*x2**2 - u2 + x1),
2*( - u1**2*x6 + u1*x6**2 - u1 + x6),
2*( - u2**2*x5 + u2*x5**2 - u2 + x5),
u1*u3 - u1*x4 - u3*x3,
u2*u3 - u2*x2 - u3*x1}$


con:=concurrent(pp_line(A,M),pp_line(D,N),pp_line(X,Y));


con := 2*( - x1*x4*x6 + x2*x3*x5 - x2*x5*x6 + x4*x5*x6)$


vars:={x1,x2,x3,x4,x5,x6};


vars := {x1,
x2,
x3,
x4,
x5,
x6}$

setring(vars,{},lex);


{{x1,x2,x3,x4,x5,x6},{},lex,{1,1,1,1,1,1}}$

res:=groebfactor(polys,{x5-u2,x1-u2,x6-u1,x3-u1});


res := {{u1*x6 + 1,
(u2**2 + u3**2)*x2 - (u2**2*u3 + u3),
(u2**2 + u3**2)*x1 - (u2*u3**2 - u2),
(u1**2 + u3**2)*x4 - (u1**2*u3 + u3),
(u1**2 + u3**2)*x3 - (u1*u3**2 - u1),
u2*x5 + 1}}$

	% constraints A\neq C, M\neq C, D\neq B, N\neq B
for each u in res collect con mod u;


{0}$


clear_ndg();


{}$
 clear(Z,X,Y,B,C,P,M,N,A,D);



% 7)

M:=Point(0,0);


m := {0,0}$

A:=Point(0,u1);


a := {0,u1}$
 B:=Point(-1,0);


b := {-1,0}$
 C:=Point(1,0);


c := {1,0}$
 
Eh:=varpoint(A,B,x1);


eh := {x1 - 1,u1*x1}$
 F:=varpoint(A,C,x2);


f := { - x2 + 1,u1*x2}$

O:=intersection_point(pp_line(A,M),lot(B,pp_line(A,B)));


o := {0,( - 1)/u1}$
 
Q:=intersection_point(pp_line(Eh,F),pp_line(B,C));


q := {( - 2*x1*x2 + x1 + x2)/(x1 - x2),0}$


con1:=num orthogonal(pp_line(O,Q),pp_line(Eh,Q));


con1 := 2*x1*(x1**2*x2 - x1**2 + x1*x2**2 - 2*x1*x2 + x1 - x2**2 + x2)$

con2:=num sqrdist(Q,midpoint(Eh,F));


con2 := u1**2*x1**4 - 2*u1**2*x1**2*x2**2 + u1**2*x2**4 + x1**4 + 4*x1**3*x2 - 4
*x1**3 + 6*x1**2*x2**2 - 12*x1**2*x2 + 4*x1**2 + 4*x1*x2**3 - 12*x1*x2**2 + 8*x1
*x2 + x2**4 - 4*x2**3 + 4*x2**2$


vars:={x1,x2};


vars := {x1,x2}$

setring(vars,{},lex);


{{x1,x2},{},lex,{1,1}}$

p1:=groebfactor({con1},{x1-1,x2-1,x1,x2});


p1 := {{x1 + x2}}$

p2:=groebfactor({con2},{x1-1,x2-1,x1,x2});


p2 := {{x1 + x2},
{(u1**2 + 1)*x1**2 - (2*u1**2 - 2)*x1*x2 - 4*x1 + (u1**2 + 1)*x2**2 - 4*x2 + 4}}
$

	% constraint A,C\neq Eh, B,C\neq F

for each u in p1 collect con2 mod u;


{0}$

for each u in p2 collect con1 mod u;


{0,
(2*(5*u1**4*x1*x2**3 - 8*u1**4*x1*x2**2 + 3*u1**4*x1*x2 - 3*u1**4*x2**4 + 4*u1**
4*x2**3 - u1**4*x2**2 - 10*u1**2*x1*x2**3 + 32*u1**2*x1*x2**2 - 30*u1**2*x1*x2 +
 8*u1**2*x1 - 2*u1**2*x2**4 + 12*u1**2*x2**3 - 26*u1**2*x2**2 + 20*u1**2*x2 - 4*
u1**2 + x1*x2**3 - 8*x1*x2**2 + 15*x1*x2 - 8*x1 + x2**4 - 8*x2**3 + 23*x2**2 - 
28*x2 + 12))/(u1**4 + 2*u1**2 + 1)}$


% Note that the second component of p2 has no relevant *real* roots,
% since it factors as u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 :

u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 mod second p2;


0$


clear_ndg();


{}$
 clear(M,A,B,C,O,Eh,F,Q);



% 8)

on gcd;

 

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 l1:=pp_line(A,B);


l1 := {0,u1 - u2,0}$

M:=Point(0,u3);


m := {0,u3}$
		% the incenter, hence u3 = incircle radius 

C:=intersection_point(symline(l1,pp_line(A,M)),
		symline(l1,pp_line(B,M)));


c := {(u3**2*(u1 + u2))/(u1*u2 + u3**2),
(2*u1*u2*u3)/(u1*u2 + u3**2)}$
  

N:=intersection_point(mp(A,B),mp(B,C));


n := {(u1 + u2)/2,
(u1**2*u2**2 - u1**2*u3**2 + 4*u1*u2*u3**2 - u2**2*u3**2 + u3**4)/(4*u3*(u1*u2 +
 u3**2))}$
 % the outcenter

sqr_rad:=sqrdist(A,N);


sqr_rad := (u1**4*u2**4 + 2*u1**4*u2**2*u3**2 + u1**4*u3**4 + 2*u1**2*u2**4*u3**
2 + 4*u1**2*u2**2*u3**4 + 2*u1**2*u3**6 + u2**4*u3**4 + 2*u2**2*u3**6 + u3**8)/(
16*u3**2*(u1**2*u2**2 + 2*u1*u2*u3**2 + u3**4))$
	% the outcircle sqradius.

(sqr_rad-sqrdist(M,N))^2-4*u3^2*sqr_rad;


0$


off gcd;


clear_ndg();


{}$
 clear A,B,C,M,N,l1,sqr_rad;



% 9)

on gcd;



A:=Point(0,0);


a := {0,0}$
 B:=Point(1,0);


b := {1,0}$
 M:=Point(u1,0);


m := {u1,0}$

C:=Point(u1,u1);


c := {u1,u1}$
 F:=Point(u1,1-u1);


f := {u1, - u1 + 1}$


c1:=red_hom_coords p3_circle(A,M,C);


c1 := {1, - u1, - u1,0}$
 
c2:=red_hom_coords p3_circle(B,M,F);


c2 := {-1,u1 + 1, - u1 + 1, - u1}$

N:=other_cc_point(M,c1,c2);


n := {u1**2/(2*u1**2 - 2*u1 + 1),(u1*( - u1 + 1))/(2*u1**2 - 2*u1 + 1)}$


point_on_line(N,pp_line(A,F));


0$

point_on_line(N,pp_line(B,C));


0$


l1:=red_hom_coords pp_line(M,N);


l1 := {-1,2*u1 - 1,u1}$

l2:=sub(u1=u2,l1);


l2 := {-1,2*u2 - 1,u2}$


intersection_point(l1,l2);


{1/2,( - 1)/2}$
 % = (1/2,-1/2)

off gcd;


clear_ndg();


{}$
 clear A,B,C,F,M,N,c1,c2,l1,l2;



% ####################
% Some more examples
% ####################

% Origin: D. Wang at
%	http://cosmos.imag.fr/ATINF/Dongming.Wang/geother.html
% --------------------------
% Given triangle ABC, H orthocenter, O circumcenter, A1 circumcenter
% of BHC, B1 circumcenter of AHC.
%
% Claim: OH, AA1, BB1 are concurrent.
% --------------------------

A:=Point(u1,0);


a := {u1,0}$
 B:=Point(u2,0);


b := {u2,0}$
 C:=Point(0,u3);


c := {0,u3}$
 
H:=intersection_point(altitude(C,A,B),altitude(A,B,C));


h := {0,( - u1*u2)/u3}$

O:=circle_center(p3_circle(A,B,C));


o := {(u1 + u2)/2,(u1*u2 + u3**2)/(2*u3)}$
 
A1:=circle_center(p3_circle(H,B,C));


a1 := {( - u1 + u2)/2,( - u1*u2 + u3**2)/(2*u3)}$
 
B1:=circle_center(p3_circle(H,A,C));


b1 := {(u1 - u2)/2,( - u1*u2 + u3**2)/(2*u3)}$
 

con:=concurrent(pp_line(O,H),pp_line(A,A1),pp_line(B,B1));


con := 0$


end;

4: 4: 4: 4: 4: 4: 4: 4: 4: 

Time for test: 9680 ms, plus GC time: 880 ms

5: 5: 
Quitting
Thu Jan 28 23:38:39 MET 1999
mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geoprover_1_2.htm0000644000175000017500000000727311526203062025533 0ustar  giovannigiovanni

GeoProver version 1.2




The GeoProver Package for Mechanized (Plane) Geometry Theorem 
Proving 

Version 1.2


Freezed at March 6, 2002 




  
  

    AUTHOR 
    : 
    Hans-Gert Graebe 
  

    ADDRESS 
    : 
    Univ. Leipzig, Institut f. Informatik, D - 04109 Leipzig, Germany 
  

    URL 
    : 
    http://www.informatik.uni-leipzig.de/~graebe 

  

    EMAIL 
    : 
    graebe@informatik.uni-leipzig.de 


Key Words
geometry theorem proving 

Introduction


The GeoProver (formerly GEOMETRY) is a small package for mechanized 
(plane) geometry manipulations with non degeneracy tracing, available for 
different CAS platforms (Maple, MuPAD, Mathematica, and Reduce).


It provides the casual user with a couple of procedures that allow him/her to 
mechanize his/her own geometry proofs. Version 1.1 grew out from a course of 
lectures for students of computer science on this topic held by the author at 
the Univ. of Leipzig in fall 1996 and was updated after a similar lecture in 
spring 1998. 


The (completely revised) version 1.2, finished in March 2002, was set up as a 
generic software project to manage the code for different platforms in a unified 
way. Even most of the function names changed due to more concise naming 
conventions. There is a close relationship to the SymbolicData project (see http://www.symbolicdata.org/). 


For examples we refer to the SymbolicData GEO table that contains many proof 
schemes of geometry theorems, mainly from Chou's book, and an interface from 
SymbolicData to the GeoProver.


Comments, bug reports, hints, wishes, criticisms etc. are welcome. Please 
send them to the author.


Bibliography


If you have used the GeoProver in the preparation of a publication, please 
cite it in the following format (in particular, refer explicitely to the used 
version): 
\bibitem{GeoProver}
H.-G. Gr\"abe.
\newblock {\sc GeoProver} 1.2 -- {A Small Package for Mechanized Plane Geometry
  Theorem Proving}, 2002.
\newblock {With versions for Reduce, Maple, MuPAD and Mathematica.}\\ See
  \url{http://www.informatik.uni-leipzig.de/~compalg/software}.



If you are using BibTeX, you can use the following BibTeX entry
@Misc{GeoProver,
  author =       {Gr\"abe, H.-G.},
  title =        {{\sc GeoProver} 1.2 -- {A Small Package for
                  Mechanized Plane Geometry Theorem Proving}},
  year =         {2002},
  note =         {{With versions for Reduce, Maple, MuPAD and
                  Mathematica.}\\  See
                  \url{http://www.informatik.uni-leipzig.de/~compalg/software}
                  },
}



Acknowledgements


Malte Witte translated the code of version 1.1 from Reduce to Maple, MuPAD, 
and Mathematica and filled the SymbolicData GEO table with many examples from 
mechanized geometry theorem proving, mainly from Chou's book.


Benjamin Friedrich collected examples and solutions with geometric background 
from IMO contests.


Upgrade Information
Proof schemes from Version 1.1 require an upgrade. 
There is a perl script changeFiles.pl to support this upgrade. 

mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geometry.tst0000644000175000017500000003432311526203062024733 0ustar  giovannigiovanni% Author H.-G. Graebe | Univ. Leipzig | Version 6.9.1998
% graebe@informatik.uni-leipzig.de

comment 

Test suite for the package GEOMETRY 1.1

end comment;

algebraic;
load cali,geometry;
off nat;
on echo;
showtime;


% #####################
% Some one line proofs
% #####################

% A generic triangle ABC

A:=Point(a1,a2); B:=Point(b1,b2); C:=Point(c1,c2);

% Its midpoint perpendiculars have a point in common:

	concurrent(mp(a,b),mp(b,c),mp(c,a));
 
% This point

	M:=intersection_point(mp(a,b),mp(b,c));

% is the center of the circumscribed circle

	sqrdist(M,A) - sqrdist(M,B);	

% The altitutes intersection theorem

	concurrent(altitude(a,b,c),altitude(b,c,a),altitude(c,a,b));

% The median intersection theorem

	concurrent(median(a,b,c),median(b,c,a),median(c,a,b));

% Euler's line

        M:=intersection_point(mp(a,b),mp(b,c));
        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));
        S:=intersection_point(median(a,b,c),median(b,c,a));

                collinear(M,H,S);
                sqrdist(S,varpoint(M,H,2/3));

% Feuerbach's circle

	% Choose a special coordinate system
	A:=Point(0,0); B:=Point(u1,0); C:=Point(u2,u3);

        M:=intersection_point(mp(a,b),mp(b,c));
        H:=intersection_point(altitude(a,b,c),altitude(b,c,a));
        N:=midpoint(M,H);

                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(B,C));
                sqrdist(N,midpoint(A,B))-sqrdist(N,midpoint(H,C));

        D:=intersection_point(pp_line(A,B),pp_line(H,C));

                sqrdist(N,midpoint(A,B))-sqrdist(N,D);

clear_ndg(); clear(A,B,C,D,M,H,S,N);

% ############################# 
% Non-linear Geometric Objects
% #############################

% Bisector intersection theorem
 
A:=Point(0,0); B:=Point(1,0); C:=Point(u1,u2);
P:=Point(x1,x2);
 
polys:={
        point_on_bisector(P,A,B,C),
        point_on_bisector(P,B,C,A),
        point_on_bisector(P,C,A,B)};

con1:=num(sqrdist(P,pedalpoint(p,pp_line(A,C)))-x2^2);
con2:=num(sqrdist(p,pedalpoint(p,pp_line(B,C)))-x2^2);

setring({x1,x2},{},lex);
setideal(polys,polys);
gbasis polys;
{con1,con2} mod gbasis polys;

% Bisector intersection theorem. A constructive proof.
 
A:=Point(0,0); B:=Point(1,0); P:=Point(u1,u2);
l1:=pp_line(A,B);
l2:=symline(l1,pp_line(A,P));
l3:=symline(l1,pp_line(B,P));

point_on_bisector(P,A,B,intersection_point(l2,l3));

clear_ndg(); clear(A,B,C,P,l1,l2,l3);

% Miquel's theorem

on gcd;
A:=Point(0,0); B:=Point(1,0); C:=Point(c1,c2);
P:=choose_pl(pp_line(A,B),u1);
Q:=choose_pl(pp_line(B,C),u2);
R:=choose_pl(pp_line(A,C),u3);

X:=other_cc_point(P,p3_circle(A,P,R),p3_circle(B,P,Q))$

point_on_circle(X,p3_circle(C,Q,R));

off gcd;
clear_ndg(); clear(A,B,C,P,Q,R,X);

% ########################
% Theorems of linear type
% ########################

% Pappus' theorem

A:=Point(u1,u2); B:=Point(u3,u4); C:=Point(x1,u5); 
P:=Point(u6,u7); Q:=Point(u8,u9); R:=Point(u0,x2);

polys:={collinear(A,B,C), collinear(P,Q,R)};

con:=collinear(
	intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)))$

vars:={x1,x2};
sol:=solve(polys,vars);

sub(sol,con);

% Pappus' theorem. A constructive approach

A:=Point(u1,u2); B:=Point(u3,u4);  
P:=Point(u6,u7); Q:=Point(u8,u9); 

C:=choose_pl(pp_line(A,B),u5);
R:=choose_pl(pp_line(P,Q),u0);

con:=collinear(intersection_point(pp_line(A,Q),pp_line(P,B)),
	intersection_point(pp_line(A,R),pp_line(P,C)),
	intersection_point(pp_line(B,R),pp_line(Q,C)));

clear_ndg(); clear(A,B,C,P,Q,R);

% ###########################
% Theorems of non linear type
% ###########################

% Fermat Point

A:=Point(0,0); B:=Point(0,2); C:=Point(u1,u2);
P:=Point(x1,x2); Q:=Point(x3,x4); R:=Point(x5,x6);

polys1:={sqrdist(P,B)-sqrdist(B,C), sqrdist(P,C)-sqrdist(B,C), 
	sqrdist(Q,A)-sqrdist(A,C), sqrdist(Q,C)-sqrdist(A,C), 
	sqrdist(R,B)-sqrdist(A,B), sqrdist(R,A)-sqrdist(A,B)};

con:=concurrent(pp_line(A,P), pp_line(B,Q), pp_line(C,R));

vars:={x1,x2,x3,x4,x5,x6};
setring(vars,{},lex);
iso:=isolatedprimes polys1;

for each u in iso collect con mod u;

polys2:={sqrdist(P,B)-sqrdist(P,C), 
	sqrdist(Q,A)-sqrdist(Q,C),  
	sqrdist(R,A)-sqrdist(R,B), 
	num(p3_angle(R,A,B)-p3_angle(P,B,C)), 
	num(p3_angle(Q,C,A)-p3_angle(P,B,C))};

sol:=solve(polys2,{x1,x2,x3,x4,x6});
sub(sol,con);

clear_ndg(); clear(A,B,C,P,Q,R);

% ####################
%  Desargue's theorem
% ####################

% A constructive proof.

A:=Point(a1,a2); B:=Point(b1,b2); 
C:=Point(c1,c2); R:=Point(d1,d2);

S:=choose_pl(par(R,pp_line(A,B)),u);
T:=intersection_point(par(R,pp_line(A,C)),par(S,pp_line(B,C)));
 
con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));

% Desargue's theorem as theorem of linear type.

A:=Point(u1,u2); B:=Point(u3,u4); C:=Point(u5,u6);
R:=Point(u7,u8); S:=Point(u9,x1); T:=Point(x2,x3);

polys:={parallel(pp_line(R,S),pp_line(A,B)),
	parallel(pp_line(S,T),pp_line(B,C)),
	parallel(pp_line(R,T),pp_line(A,C))};

con:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));

sol:=solve(polys,{x1,x2,x3});
sub(sol,con);

% The general theorem of Desargue.

A:=Point(0,0); B:=Point(0,1); C:=Point(u5,u6);
R:=Point(u7,u8); S:=Point(u9,u1); T:=Point(u2,x1);

con1:=collinear(intersection_point(pp_line(R,S),pp_line(A,B)),
	intersection_point(pp_line(S,T),pp_line(B,C)),
	intersection_point(pp_line(R,T),pp_line(A,C)));

con2:=concurrent(pp_line(A,R),pp_line(B,S),pp_line(C,T));

sol:=solve(con2,x1);
sub(sol,con1);

clear_ndg(); clear(A,B,C,R,S,T);

% #################
%  Brocard points
% #################

A:=Point(0,0); B:=Point(1,0); C:=Point(u1,u2);

c1:=Circle(1,x1,x2,x3);
c2:=Circle(1,x4,x5,x6);
c3:=Circle(1,x7,x8,x9);

polys:={
	cl_tangent(c1,pp_line(A,C)), 
	point_on_circle(A,c1), 
	point_on_circle(B,c1), 
	cl_tangent(c2,pp_line(A,B)), 
	point_on_circle(B,c2), 
	point_on_circle(C,c2), 
	cl_tangent(c3,pp_line(B,C)), 
	point_on_circle(A,c3), 
	point_on_circle(C,c3)};
 
vars:={x1,x2,x3,x4,x5,x6,x7,x8,x9};
sol:=solve(polys,vars);

P:=other_cc_point(B,sub(sol,c1),sub(sol,c2));
con:=point_on_circle(P,sub(sol,c3));

clear_ndg(); clear A,B,C,c1,c2,c3;	

% ##################
%  Simson's theorem
% ##################

% A constructive proof

        M:=Point(0,0);
        A:=choose_pc(M,r,u1);
        B:=choose_pc(M,r,u2);
        C:=choose_pc(M,r,u3);
        P:=choose_pc(M,r,u4);
        X:=pedalpoint(P,pp_line(A,B))$
        Y:=pedalpoint(P,pp_line(B,C))$
        Z:=pedalpoint(P,pp_line(A,C))$
 
        collinear(X,Y,Z);

clear_ndg(); clear(M,A,B,C,P,X,Y,Z);

% Simson's theorem almost constructive

clear_ndg();

	A:=Point(0,0); B:=Point(u1,u2); 
	C:=Point(u3,u4); P:=Point(u5,x1);
        X:=pedalpoint(P,pp_line(A,B));
        Y:=pedalpoint(P,pp_line(B,C));
        Z:=pedalpoint(P,pp_line(A,C));

	poly:=p4_circle(A,B,C,P); 

        con:=collinear(X,Y,Z);

	remainder(num con,poly);

print_ndg();

% Equational proof, first version:

M:=Point(0,0); A:=Point(0,1); 
B:=Point(u1,x1); C:=Point(u2,x2); P:=Point(u3,x3);

X:=varpoint(A,B,x4); Y:=varpoint(B,C,x5); Z:=varpoint(A,C,x6);

polys:={sqrdist(M,B)-1, sqrdist(M,C)-1, sqrdist(M,P)-1,
	orthogonal(pp_line(A,B),pp_line(P,X)),
	orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y))};

con:=collinear(X,Y,Z);

vars:={x4,x5,x6,x1,x2,x3};
setring(vars,{},lex);
setideal(polys,polys);
con mod gbasis polys;

% Second version:

A:=Point(0,0);
B:=Point(1,0);
C:=Point(u1,u2);
P:=Point(u3,x1);
X:=Point(x2,0);		% => on the line AB 
Y:=varpoint(B,C,x3);
Z:=varpoint(A,C,x4);

polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	p4_circle(A,B,C,P)};

con:=collinear(X,Y,Z);

vars:={x2,x3,x4,x1};
setring(vars,{},lex);
con mod interreduce polys;

% The inverse theorem

polys:={orthogonal(pp_line(A,C),pp_line(P,Z)),
	orthogonal(pp_line(B,C),pp_line(P,Y)),
	orthogonal(pp_line(A,B),pp_line(P,X)),
       	collinear(X,Y,Z)};

con:=p4_circle(A,B,C,P);

con mod interreduce polys;

clear_ndg(); clear(M,A,B,C,P,Y,Z);

% ########################
%  The butterfly theorem
% ########################
 
% An equational proof with groebner factorizer and constraints. 

P:=Point(0,0);
O:=Point(u1,0);
A:=Point(u2,u3);	
B:=Point(u4,x1);
C:=Point(x2,x3); 
D:=Point(x4,x5); 
F:=Point(0,x6);
G:=Point(0,x7);

polys:={sqrdist(O,B)-sqrdist(O,A), 
	sqrdist(O,C)-sqrdist(O,A), 
	sqrdist(O,D)-sqrdist(O,A),
	point_on_line(P,pp_line(A,C)),
	point_on_line(P,pp_line(B,D)),
	point_on_line(F,pp_line(A,D)),
	point_on_line(G,pp_line(B,C))
};

con:=num sqrdist(P,midpoint(F,G));

vars:={x6,x7,x3,x5,x1,x2,x4};
setring(vars,{},lex);

sol:=groebfactor(polys,{sqrdist(A,C),sqrdist(B,D)});

for each u in sol collect con mod u;

% A constructive proof

on gcd;

O:=Point(0,0);
A:=Point(1,0);	
B:=choose_pc(O,1,u1);
C:=choose_pc(O,1,u2);
D:=choose_pc(O,1,u3);
P:=intersection_point(pp_line(A,C),pp_line(B,D));

h:=lot(P,pp_line(O,P));

F:=intersection_point(h,pp_line(A,D)); 
G:=intersection_point(h,pp_line(B,C));

con:=sqrdist(P,midpoint(F,G));

off gcd;
clear_ndg(); clear(O,A,B,C,D,P,h,F,G);

% ################################
% Tangency of Feuerbach's circle
% ################################
 
A:=Point(0,0); B:=Point(2,0); C:=Point(u1,u2);
M:=intersection_point(mp(A,B),mp(B,C));
H:=intersection_point(altitude(A,B,C),altitude(B,C,A));
N:=midpoint(M,H);	
c1:=c1_circle(N,sqrdist(N,midpoint(A,B)));
			% Feuerbach's circle

P:=Point(x1,x2);	% => x2 is the radius of the inscribed circle. 

polys:={point_on_bisector(P,A,B,C), point_on_bisector(P,B,C,A)};

con:=cc_tangent(c1_circle(P,x2^2),c1); 

vars:={x1,x2};
setring(vars,{},lex);
setideal(polys,polys);
num con mod gbasis polys;

% Now let P be the incenter of the triangle ABH

polys1:={point_on_bisector(P,A,B,H), point_on_bisector(P,B,H,A)};

con1:=cc_tangent(c1_circle(P,x2^2),c1); 
setideal(polys1,polys1);
num con1 mod gbasis polys1;

clear_ndg(); clear A,B,C,P,M,N,H,c1;

% #############################
% Solutions to the exercises
% #############################

% 1)

A:=Point(0,0); B:=Point(1,0); C:=Point(1,1); D:=Point(0,1);
P:=Point(x1,x2); Q:=Point(x3,1);

polys:={point_on_line(P,par(C,pp_line(B,D))),
	sqrdist(B,D)-sqrdist(B,P),
	point_on_line(Q,pp_line(B,P))};

con:=sqrdist(D,P)-sqrdist(D,Q);

setring({x1,x2,x3},{},lex);
setideal(polys,polys);
con mod gbasis polys;

clear_ndg(); clear(A,B,C,D,P,Q);

% 2)

A:=Point(u1,0); B:=Point(u2,0); C:=Point(0,u3); 
Q:=Point(0,0);		% the pedal point on AB
R:=pedalpoint(B,pp_line(A,C)); 
P:=pedalpoint(A,pp_line(B,C)); 

con1:=point_on_bisector(C,P,Q,R);
con2:=angle_sum(p3_angle(P,Q,C),p3_angle(R,Q,C));

clear_ndg(); clear(A,B,C,P,Q,R);

% 3)

A:=Point(u1,0); B:=Point(u2,0); C:=Point(0,u3); 
P:=pedalpoint(A,pp_line(B,C)); 
Q:=pedalpoint(B,pp_line(A,C)); 
R:=pedalpoint(C,pp_line(A,B));

P1:=pedalpoint(P,pp_line(A,B));
P2:=pedalpoint(P,pp_line(A,C));
Q1:=pedalpoint(Q,pp_line(A,B));
Q2:=pedalpoint(Q,pp_line(B,C));
R1:=pedalpoint(R,pp_line(A,C));
R2:=pedalpoint(R,pp_line(B,C));

con:=for each X in {Q2,R1,R2} collect p4_circle(P1,P2,Q1,X);

clear_ndg(); clear(O,A,B,C,P,Q,R,P1,P2,Q1,Q2,R1,R2);

% 4) 

A:=Point(u1,0); B:=Point(u2,0); C:=Point(0,u3); 
		% => Pedalpoint from C is (0,0)
M:=intersection_point(mp(A,B),mp(B,C));

% Prove (2*h_c*R = a*b)^2

con:=4*u3^2*sqrdist(M,A)-sqrdist(C,B)*sqrdist(A,C);

clear_ndg(); clear(A,B,C,M);

% 5. A solution of constructive type.

on gcd;
O:=Point(0,u1); A:=Point(0,0);	% hence k has radius u1.
B:=Point(u2,0);
M:=midpoint(A,B);
D:=choose_pc(O,u1,u3); 
k:=c1_circle(O,u1^2);
C:=other_cl_point(D,k,pp_line(M,D));
Eh:=other_cl_point(D,k,pp_line(B,D));
F:=other_cl_point(C,k,pp_line(B,C));

con:=parallel(pp_line(A,B),pp_line(Eh,F));

off gcd;
clear_ndg(); clear(O,A,B,C,D,Eh,F,M,k);

% 6)

Z:=Point(0,0); X:=Point(0,1); Y:=Point(0,-1); 
B:=Point(u1,0); C:=Point(u2,0); P:=Point(0,u3);
M:=Point(x1,x2); N:=Point(x3,x4); 
A:=Point(x5,0); D:=Point(x6,0);

polys:={p4_circle(X,Y,B,N), p4_circle(X,Y,C,M),
	p4_circle(X,Y,B,D), p4_circle(X,Y,C,A),
	collinear(B,P,N), collinear(C,P,M)};

con:=concurrent(pp_line(A,M),pp_line(D,N),pp_line(X,Y));

vars:={x1,x2,x3,x4,x5,x6};
setring(vars,{},lex);
res:=groebfactor(polys,{x5-u2,x1-u2,x6-u1,x3-u1});
	% constraints A\neq C, M\neq C, D\neq B, N\neq B
for each u in res collect con mod u;

clear_ndg(); clear(Z,X,Y,B,C,P,M,N,A,D);

% 7)

M:=Point(0,0);
A:=Point(0,u1); B:=Point(-1,0); C:=Point(1,0); 
Eh:=varpoint(A,B,x1); F:=varpoint(A,C,x2);
O:=intersection_point(pp_line(A,M),lot(B,pp_line(A,B))); 
Q:=intersection_point(pp_line(Eh,F),pp_line(B,C));

con1:=num orthogonal(pp_line(O,Q),pp_line(Eh,Q));
con2:=num sqrdist(Q,midpoint(Eh,F));

vars:={x1,x2};
setring(vars,{},lex);
p1:=groebfactor({con1},{x1-1,x2-1,x1,x2});
p2:=groebfactor({con2},{x1-1,x2-1,x1,x2});
	% constraint A,C\neq Eh, B,C\neq F

for each u in p1 collect con2 mod u;
for each u in p2 collect con1 mod u;

% Note that the second component of p2 has no relevant *real* roots,
% since it factors as u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 :

u1^2 * (x1 - x2)^2 + (x1 + x2 -2)^2 mod second p2;

clear_ndg(); clear(M,A,B,C,O,Eh,F,Q);

% 8)

on gcd; 

A:=Point(u1,0); B:=Point(u2,0); l1:=pp_line(A,B);
M:=Point(0,u3);		% the incenter, hence u3 = incircle radius 

C:=intersection_point(symline(l1,pp_line(A,M)),
		symline(l1,pp_line(B,M)));  

N:=intersection_point(mp(A,B),mp(B,C)); % the outcenter

sqr_rad:=sqrdist(A,N);	% the outcircle sqradius.

(sqr_rad-sqrdist(M,N))^2-4*u3^2*sqr_rad;

off gcd;
clear_ndg(); clear A,B,C,M,N,l1,sqr_rad;

% 9)

on gcd;

A:=Point(0,0); B:=Point(1,0); M:=Point(u1,0);
C:=Point(u1,u1); F:=Point(u1,1-u1);

c1:=red_hom_coords p3_circle(A,M,C); 
c2:=red_hom_coords p3_circle(B,M,F);
N:=other_cc_point(M,c1,c2);

point_on_line(N,pp_line(A,F));
point_on_line(N,pp_line(B,C));

l1:=red_hom_coords pp_line(M,N);
l2:=sub(u1=u2,l1);

intersection_point(l1,l2); % = (1/2,-1/2)

off gcd;
clear_ndg(); clear A,B,C,F,M,N,c1,c2,l1,l2;

% ####################
% Some more examples
% ####################

% Origin: D. Wang at
%	http://cosmos.imag.fr/ATINF/Dongming.Wang/geother.html
% --------------------------
% Given triangle ABC, H orthocenter, O circumcenter, A1 circumcenter
% of BHC, B1 circumcenter of AHC.
%
% Claim: OH, AA1, BB1 are concurrent.
% --------------------------

A:=Point(u1,0); B:=Point(u2,0); C:=Point(0,u3); 
H:=intersection_point(altitude(C,A,B),altitude(A,B,C));
O:=circle_center(p3_circle(A,B,C)); 
A1:=circle_center(p3_circle(H,B,C)); 
B1:=circle_center(p3_circle(H,A,C)); 

con:=concurrent(pp_line(O,H),pp_line(A,A1),pp_line(B,B1));

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/README0000644000175000017500000000045711526203062023225 0ustar  giovannigiovanniThis directory contains the Reduce GeoProver Package sources.

     GeoProver.red	    - the main package
     GeoProver.tst	    - a test file (plain ASCII)
     supp.red		    - a supplement used in GeoProver.tst
     GeoProver.out	    - output of the test
     GeoProver.html	    - A help file in HTML

mathpiper-0.81f+svn4469+dfsg3/src/packages/geometry/geoprover.red0000644000175000017500000003267011526203062025053 0ustar  giovannigiovanni% GeoProver | Version 1.3a | Jan 20 2003
% Author: H.-G. Graebe, Univ. Leipzig, Germany
% http://www.informatik.uni-leipzig.de/~graebe

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module geoprover;

comment

GeoProver inline part. Version 1.3

Data structures:

        Point A  :== {a1,a2}       <=> A=(a1,a2)
        Line  a  :== {a1,a2,a3}    <=> a1*x+a2*y+a3 = 0
        Circle c :== {c0,c1,c2,c3} <=> c0*(x^2+y^2)+c1*x+c2*y+c3 = 0

end comment;

put ('geoprover,'name," GeoProver ")$
put ('geoprover,'version," 1.3a ")$
put ('geoprover,'date," December 30, 2002")$

algebraic(write(" Geoprover ", get('geoprover,'version),
        " Last update ",get('geoprover,'date)));

% ============= Handling non degeneracy conditions ===============

algebraic procedure clear_ndg; !*ndg!*:={};
algebraic procedure print_ndg; !*ndg!*;
algebraic procedure add_ndg(d);
  if not member(d,!*ndg!*) then !*ndg!*:=d . !*ndg!*;

clear_ndg();  % Initialization

% ================= elementary geometric constructions ===============

% Generators:

algebraic procedure is_equal(a,b); a-b;
%algebraic procedure Normal(a); a;
algebraic procedure Point(a,b); {a,b};
algebraic procedure Line(a,b,c); reduce_coords({a,b,c});

algebraic procedure par_point(a,b,c);
  Point(part(a,1)-part(b,1)+part(c,1),
  part(a,2)-part(b,2)+part(c,2));

algebraic procedure pp_line(a,b);
% The line through A and B.
  Line(part(b,2)-part(a,2),part(a,1)-part(b,1),
        part(a,2)*part(b,1)-part(a,1)*part(b,2));

algebraic procedure intersection_point(a,b);
% The intersection point of the lines a,b.
   begin scalar d,d1,d2;
   d:=part(a,1)*part(b,2)-part(b,1)*part(a,2);
   d1:=part(a,3)*part(b,2)-part(b,3)*part(a,2);
   d2:=part(a,1)*part(b,3)-part(b,1)*part(a,3);
   if d=0 then rederr"Lines are parallel";
   add_ndg(num d);
   return Point(-d1/d,-d2/d);
   end;

algebraic procedure ortho_line(p,a);
% The line through P orthogonal to the line a.
  begin scalar u,v; u:=first a; v:=second a;
  return Line(v,-u,u*second p-v*first p);
  end;

algebraic procedure par_line(p,a);
% The parallel to line a through P.
  Line(part(a,1),part(a,2),
        -(part(a,1)*part(p,1)+part(a,2) *part(p,2)));

algebraic procedure varpoint(b,a,l);
% The point D=l*A+(1-l)*B.
  Point(l*part(a,1)+(1-l)*part(b,1),l*part(a,2)+(1-l)*part(b,2));

algebraic procedure line_slider(a,u);
% Slider on the line a using parameter u.
  begin scalar p,d;
  if part(a,2)=0 then
        << p:=Point(-part(a,3)/part(a,1),u); d:=part(a,1); >>
  else
        << p:=Point(u,-(part(a,3)+part(a,1)*u)/part(a,2));
           d:=part(a,2);
        >>;
  add_ndg(num d);
  return p;
  end;

algebraic procedure circle_slider(M,A,u);
% Slider on the circle with center M and circumfere point A using
% parameter u.
  begin scalar a1,a2,m1,m2,d;
  a1:=part(A,1); a2:=part(A,2); d:= u^2 + 1;
  m1:=part(M,1); m2:=part(M,2);
  add_ndg(num d);
  return Point((a1*(u^2-1) + 2*m1 + 2*(m2-a2)*u)/d,
         (a2 + 2*(m1-a1)*u + (2*m2-a2)*u^2)/d);
  end;

algebraic procedure sqrdist(a,b);
% The square of the distance between the points A and B.
  (part(b,1)-part(a,1))^2+(part(b,2)-part(a,2))^2;

% ================= elementary geometric properties ===============

algebraic procedure is_collinear(a,b,c);
% A,B,C are on a common line.
det mat((part(a,1),part(a,2),1),
        (part(b,1),part(b,2),1),
        (part(c,1),part(c,2),1));

algebraic procedure is_concurrent(a,b,c);
% Lines a,b,c have a common point.
det mat((part(a,1),part(a,2),part(a,3)),
        (part(b,1),part(b,2),part(b,3)),
        (part(c,1),part(c,2),part(c,3)));

algebraic procedure is_parallel(a,b);
% 0 <=> the lines a,b are parallel.
  part(a,1)*part(b,2)-part(b,1)*part(a,2);

algebraic procedure is_orthogonal(a,b);
% 0 <=> the lines a,b are orthogonal.
  part(a,1)*part(b,1)+part(a,2)*part(b,2);

algebraic procedure on_line(p,a);
% Substitute point P into the line a.
  part(p,1)*part(a,1)+part(p,2)*part(a,2)+part(a,3);

algebraic procedure eq_dist(a,b,c,d); sqrdist(a,b)-sqrdist(c,d);

%       #########################################
%       #                                       #
%       #      Non linear geometric objects      #
%       #                                       #
%       #########################################


% ===================== angles

algebraic procedure l2_angle(a,b);
% tan of the angle between the lines a and b.
  begin scalar d; d:=(part(a,1)*part(b,1)+part(a,2)*part(b,2));
  add_ndg(num(d));
  return (part(a,2)*part(b,1)-part(b,2)*part(a,1))/d;
  end;

algebraic procedure angle_sum(a,b);
% a=tan(\alpha), b=tan(\beta). Returns tan(\alpha+\beta)
  begin scalar d; d:=(1-a*b); add_ndg(num d);
  return (a+b)/d;
  end;

algebraic procedure eq_angle(a,b,c,d,e,f);
  p3_angle(a,b,c)-p3_angle(d,e,f);

algebraic procedure on_bisector(P,A,B,C);
% P is a point on the bisector of the angle ABC.
% Returns num(u)*den(v)-num(v)*den(u) with
% u:=angle(pp_line(A,B),pp_line(P,B))
% v:=angle(pp_line(P,B),pp_line(C,B))
  begin scalar a1,a2,b1,b2,c1,c2,p1,p2;
        a1:=part(A,1); a2:=part(A,2);
        b1:=part(b,1); b2:=part(b,2);
        c1:=part(c,1); c2:=part(c,2);
        p1:=part(p,1); p2:=part(p,2);
  return ( - a1*b2 + a1*p2 + a2*b1 - a2*p1 - b1*p2 + b2*p1)*(b1^2 -
  b1*c1 - b1*p1 + b2^2 - b2*c2 - b2*p2 + c1*p1 + c2*p2) - (a1*b1 -
  a1*p1 + a2*b2 - a2*p2 - b1^2 + b1*p1 - b2^2 + b2*p2)*(b1*c2 -
  b1*p2 - b2*c1 + b2*p1 + c1*p2 - c2*p1)
  end;

algebraic procedure rotate(C, A, angle);
  begin scalar ac1,ac2;
  ac1:=part(A,1)-part(C,1); ac2:=part(A,2)-part(C,2);
  return Point(part(C,1)+ac1*cos(angle*pi)-ac2*sin(angle*pi),
    part(C,2)+ac1*sin(angle*pi)+ac2*cos(angle*pi));
  end;

% ========== symmetric lines and points

algebraic procedure sym_line(a,l);
% The line symmetric to a wrt. the line l.
  begin scalar a1,a2,a3,l1,l2,l3,u;
  a1:=part(a,1); a2:=part(a,2); a3:=part(a,3);
  l1:=part(l,1); l2:=part(l,2); l3:=part(l,3);
  u:=l1^2 - l2^2;
  return Line(- a1*u - 2*a2*l1*l2, - 2*a1*l1*l2 + a2*u,
                - 2*(a1*l1 + a2*l2)*l3 + a3*(l1^2 + l2^2));
  end;

% ===================== circles

algebraic procedure Circle(c1,c2,c3,c4); reduce_coords({c1,c2,c3,c4});

algebraic procedure pc_circle(M,A);
% Circle with center M and Point A on circumference.
  Circle(1, -2*part(M,1), -2*part(M,2),
            part(A,1)*(2*part(M,1)-part(A,1)) +
            part(A,2)*(2*part(M,2)-part(A,2)));

algebraic procedure circle_center c;
% The center of the circle c.
  begin add_ndg(num part(c,1));
  return Point(-part(c,2)/2/part(c,1) ,-part(c,3)/(2*part(c,1)));
  end;

algebraic procedure circle_sqradius c;
% The squared radius of the circle c.
  begin add_ndg(num part(c,1));
  return
   ((part(c,2)^2+part(c,3)^2) - 4*part(c,4)*part(c,1)) /
        (2*part(c,1))^2;
  end;

algebraic procedure p3_circle(A,B,C);
% The circle through three given points
  begin scalar a1,a2,a3,b1,b2,b3,c1,c2,c3;
  a1:=part(A,1); a2:=part(A,2); a3:=a1^2+a2^2;
  b1:=part(b,1); b2:=part(b,2); b3:=b1^2+b2^2;
  c1:=part(c,1); c2:=part(c,2); c3:=c1^2+c2^2;
  return Circle(a1*(b2-c2) + (a2-b2)*c1 + b1*(c2-a2),
    a3*(c2-b2) + (a2-c2)*b3 + (b2-a2)*c3,
    a3*(b1-c1) + (c1-a1)*b3 + (a1-b1)*c3,
    a3*(b2*c1-b1*c2) + (a1*c2-a2*c1)*b3 + (a2*b1-a1*b2)*c3)
  end;

algebraic procedure on_circle(P,c);
  begin scalar p1,p2; p1:=part(P,1); p2:=part(P,2);
  return part(c,1)*(p1^2+p2^2)+part(c,2)*p1+part(c,3)*p2+part(c,4);
  end;

% Intersecting with circles

algebraic procedure other_cl_point(P,c,l);
% circle c and line l intersect at P. The procedure returns their
% second intersection point.
  if on_line(P,l) neq 0 then rederr "Point not on the line"
  else if on_circle(P,c) neq 0 then
        rederr "Point not on the circle"
  else begin scalar c1,c2,c3,l1,l2,d,d1,p1,p2;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3);
  l1:=part(l,1); l2:=part(l,2); p1:=part(P,1); p2:=part(P,2);
  d:=c1*(l1^2 + l2^2); add_ndg(num d); d1:=c1*(l1^2-l2^2);
  return {(d1*p1+((2*c1*p2 + c3)*l1-c2*l2)*l2)/d,
        (- d1*p2+((2*c1*p1 + c2)*l2-c3*l1)*l1)/d};
  end;

algebraic procedure radical_axis(c1,c2);
% Radical axis of the circles c1 and c2, i.e. the line through the
% intersection points of the two circles if they intersect.
  for i:=2:4 collect
        (part(c1,1)*part(c2,i)-part(c1,i)*part(c2,1));

algebraic procedure other_cc_point(P,c1,c2);
% Circles c1 and c2 intersect at P. The procedure returns their
% second intersection point.
  other_cl_point(P,c1,radical_axis(c1,c2));

algebraic procedure is_cl_tangent(c,l);
% Line l is tangent to the circle c.
  begin scalar c1,c2,c3,c4,l1,l2,l3;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3); c4:=part(c,4);
  l1:=part(l,1); l2:=part(l,2); l3:=part(l,3);
  return - 4*c1^2*l3^2 + 4*c1*c2*l1*l3 + 4*c1*c3*l2*l3 -
        4*c1*c4*l1^2 - 4*c1*c4*l2^2 + c2^2*l2^2 - 2*c2*c3*l1*l2 +
        c3^2*l1^2
  end;

algebraic procedure is_cc_tangent(c,d);
% Two circles c,d are tangent.
  begin scalar c1,c2,c3,c4,d1,d2,d3,d4;
  c1:=part(c,1); c2:=part(c,2); c3:=part(c,3); c4:=part(c,4);
  d1:=part(d,1); d2:=part(d,2); d3:=part(d,3); d4:=part(d,4);
  return
4*c1^2*d4^2 - 4*c1*c2*d2*d4 - 4*c1*c3*d3*d4 - 8*c1*c4*d1*d4 +
4*c1*c4*d2^2 + 4*c1*c4*d3^2 + 4*c2^2*d1*d4 - c2^2*d3^2 + 2*c2*c3*d2*d3
- 4*c2*c4*d1*d2 + 4*c3^2*d1*d4 - c3^2*d2^2 - 4*c3*c4*d1*d3 +
4*c4^2*d1^2
  end;

% ============= some additional tools ===============

symbolic operator list2mat;
symbolic procedure list2mat u;
  'mat. for each x in cdr reval u collect cdr x;

algebraic procedure extractmat(polys,vars);
% extract the coefficient matrix from the linear system polys.
  begin
  if length polys neq length vars then
        rederr"Number of variables doesn't match";
  for each p in polys do for each x in vars do
        if deg(p,x)>1 then rederr"Equations not of linear type";
  return list2mat
        for each x in vars collect
        for each p in polys collect coeffn(p,x,1);
end;

algebraic procedure reduce_coords u;
% Divide out the content of homogeneous coordinates.
  begin scalar l,g;
  l:=den first u; g:=num first u;
  for each x in rest u do <>;
  add_ndg(g);
  return for each x in u collect (x*l/g);
  end;

% ================ new

algebraic procedure circle_inverse(M,R,P);
% compute the inverse of P wrt. the circle pc_circle(M,R)
  begin scalar m1,m2,r1,r2,p1,p2,d;
  m1:=part(M,1); m2:=part(M,2);
  r1:=part(R,1); r2:=part(R,2);
  p1:=part(P,1); p2:=part(P,2);
  d:=(m1-p1)^2+(m2-p2)^2;
  add_ndg(d);
  return ((m1-p1)^2+(m2-p2)^2+(m1-r1)^2+(m2-r2)^2)/d;
  end;

% GeoProver code generated from database

algebraic procedure altitude(A__,B__,C__);
        ortho_line(A__,pp_line(B__,C__));

algebraic procedure centroid(A__,B__,C__);
        intersection_point(median(A__,B__,C__),median(B__,C__,A__));

algebraic procedure circumcenter(A__,B__,C__);
        intersection_point(p_bisector(A__,B__), p_bisector(B__,C__));

algebraic procedure csym_point(P__,Q__);
        varpoint(Q__,P__,-1);

algebraic procedure fixedpoint(A__,B__,u_);
        varpoint(A__,B__,u_);

algebraic procedure is_concyclic(A__,B__,C__,D__);
        on_circle(D__,p3_circle(A__,B__,C__));

algebraic procedure median(A__,B__,C__);
        pp_line(A__,midpoint(B__,C__));

algebraic procedure midpoint(A__,B__);
        fixedpoint(A__,B__,1/2);

algebraic procedure orthocenter(A__,B__,C__);
        intersection_point(altitude(A__,B__,C__),altitude(B__,C__,A__));

algebraic procedure other_incenter(M__,A__,B__);
        intersection_point(ortho_line(A__,pp_line(M__,A__)),
ortho_line(B__,pp_line(M__,B__)));

algebraic procedure p3_angle(A__,B__,C__);
        l2_angle(pp_line(B__,A__),pp_line(B__,C__));

algebraic procedure p9_center(A__,B__,C__);
        circle_center(p9_circle(A__,B__,C__));

algebraic procedure p9_circle(A__,B__,C__);
        p3_circle(midpoint(A__,B__),midpoint(A__,C__),midpoint(B__,C__));

algebraic procedure p_bisector(B__,C__);
        ortho_line(midpoint(B__,C__),pp_line(B__,C__));

algebraic procedure pappus_line(A__,B__,C__,D__,E__,F__);
        pp_line(intersection_point(pp_line(A__,E__),pp_line(B__,D__)),
        intersection_point(pp_line(A__,F__),pp_line(C__,D__)));

algebraic procedure pedalpoint(P__,a_);
        intersection_point(ortho_line(P__,a_),a_);

algebraic procedure sqrdist_pl(A__,l_);
        sqrdist(A__,pedalpoint(A__,l_));

algebraic procedure sym_point(P__,l_);
        fixedpoint(P__,pedalpoint(P__,l_),2);

algebraic procedure triangle_area(A__,B__,C__);
        1/2*is_collinear(A__,B__,C__);

endmodule; % GeoProver

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/0000755000175000017500000000000011722677361021456 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/misc/dfpart.red0000644000175000017500000001664211526203062023424 0ustar  giovannigiovannimodule dfpart;  % support of generic differentiation.

% Author: H. Melenk
% May 1993
% Copyright (c) Konrad-Zuse-Zentrum Berlin, all rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(dfpart),'(contrib misc));

fluid '(ycoord!* ymin!*);

put('dfp,'simpfn,'simpdfp);

symbolic procedure simpdfp u;
   begin scalar f,fn,dd,p,w,l;
     if length u<2 then goto error;
     f := reval car u;
     if not pairp f then return
        if member(cadr u,frlis!*) then mksq('dfp.u,1)
        else simpdf(f . cdr cadr u);
     fn:=car f;
     p:=cdr f;
     dd :=reval cadr u;
     if not member(dd,frlis!*) and not eqcar(dd,'list) then
     << dd:= dd.for each y in cddr u collect reval y;
        dd:= 'list.dfp!-normalize(dd,nil);
        % apply pattern matching again
        return simp {'dfp,f,dd};
     >>;
     l:=get(fn,'generic_function);
     w:= t;
     if l and eqcar(dd,'list) then
        for each y in cdr dd do
           w:=w and member(y,l);
     if not w then return nil ./ 1;
     if dd='(list) then return mksq(f,1);
     if l and flagp(fn,'dfp_commute) then
      dd := 'list . sort(cdr dd,'ordp) where kord!*=l;
     u:={'dfp,f,dd};
     return mksq(u,1);
  error:
   typerr('dfp . u,"generic differential");
   end;

symbolic procedure dfp!-normalize(l,x);
   if null l then nil else
   if idp car l then car l . dfp!-normalize(cdr l,car l)
   else if numberp car l then
     append(for i:=2:car l collect x,dfp!-normalize(cdr l,nil))
   else typerr(car l,"dfp variable");

symbolic procedure generic_function u;
 for each fc in u do
 begin scalar rs,pars,fcn;
      integer l;
    if atom fc or not idp (fcn:=car fc)
       then typerr(fc, "generic function");
    l := length cdr fc;
    algebraic clear fcn;
    apply('depend,list fc);
    apply('operator,list list fcn) where !*mode='algebraic;
    pars := for i:=1:l collect {'!~,gensym()};
    rs := {'list ,
     {'replaceby,
       {'df, {fcn},{'!~,'!:x}},
       {'df, fc ,'!:x}},
     {'replaceby,
       {'df, fcn . pars,{'!~,'!:x}},
       'plus .
         for i:=1:l collect
          {'times,{'dfp, fcn.pars,{'list,nth(cdr fc,i)}},
                 {'df,nth(pars,i),'!:x}
     }}};
   put(fcn,'generic_function,cdr fc);
   put(fcn,'subfunc,'generic!-sub);
   algebraic let rs;
  end;


put('generic_function,'stat,'rlis);

symbolic procedure dfp_commute u;
  for each f in u do
  <>;

put('dfp_commute,'stat,'rlis);

symbolic procedure generic_arguments f;
  % List of generic arguments of f.
  'list. get(car f,'generic_function);

symbolic procedure actual_arguments f;
  % List of actual arguments of f. If none are given,
  % return the generic arguments.
  'list . (cdr f or get(car f,'generic_function));

symbolic operator generic_arguments;
symbolic operator actual_arguments;

% differentiation rules

symbolic procedure dfp!-rule!-found(newform,oldf);
    not eqcar(newform,'dfp) or cadr newform neq oldf;

symbolic operator dfp!-rule!-found;

symbolic procedure soft!-append(a,b);
   <>;

symbolic operator soft!-append;

algebraic;

dfp_rules:={

    df(dfp(~f,~q),~x) =>
    for i:=1:length generic_arguments(f) sum
         dfp(f,append(q,{part(generic_arguments f,i)}))
             *df(part(actual_arguments f,i),x),

    dfp(~f+~g,~q) => dfp(f,q) + dfp(f,q),

    dfp(-~f,~q) => -dfp(f,q),

       % recursive unrolling

    dfp(~f,~q) => dfp(dfp(f,{first q}),rest q) when
        arglength q neq -1 and part(q,0)=list and
        length q>1 and dfp!-rule!-found(dfp(f,{first q}),f),

       % Now we can concentrate on single derivatives,
       % the rest wil be done by unrolling.

    dfp(~f*~g,{~q}) =>
      dfp(f,{q})*g + dfp(g,{q})*f,

    dfp(~f/~g,{~q}) =>
      (dfp(f,{q})*g - dfp(g,{q})*f)/g**2,

    dfp(~f**~n,{~q}) =>
      n*f**(n-1)*dfp(f,{q}) when numberp n,

    dfp(dfp(~f,~q),~r) => dfp(f,soft!-append(q,r))
}$

let dfp_rules;

symbolic;

symbolic procedure generic!-sub(u,v);
    dfp!-sub(u,{'dfp,v,{'list}});

symbolic procedure dfp!-sub(u,v);
  % Subsitutions take place first in the arguments.
  % If the generic funtion is to be replaced:
  %  1. differentiate the target expression formally,
  %  2. transfer the arguments into the result expression.
  begin scalar p,f,fn,nf,l,w;
    f:=cadr v;
    p:=cdr f;
    l:=get(fn:=car f,'generic_function);
      % If f has no arguments, insert generic arguments if
      % one of these would be toched by the substitution.
    if null p then
    <>;
    p:= cdr listsub(u,'list.p);
    if null(nf:=assoc(fn,u)) and null(nf:=assoc(fn.l,u))
       then return {'dfp,fn.p,caddr v};
    nf := reval cdr nf;
    nf:=dfp!-sub1(nf,if p then pair(l,p),u);
    return {'dfp,nf,caddr v};
  end;

symbolic procedure dfp!-sub1(u,l,s);
 % U: expression to replace a generic function.
 % l: alist for inherited generic arguments.
 % s: alist for substituted expressions.
  if idp u then
    if get(u,'generic_function) then dfp!-sub1({u},l,s)
      else u
   else if atom u then u else
  begin scalar op,p,pp;
   op:=car u;
   if (p:=get(op,'generic_function)) then
     <>;
   return op. for each q in cdr u collect dfp!-sub1(q,l,s);
  end;

put('dfp,'subfunc,'dfp!-sub);

% ------------------ printing ----------------------------

symbolic procedure dfppri l;
  begin scalar dd,f;
    if not !*nat or !*fort then return 'failed;
    f:=cadr l; dd:=caddr l;
    if atom f or not get(car f,'generic_function)
        then return 'failed;
    prin2!* car f;
    ycoord!* := ycoord!*-1;
    if ycoord!* < ymin!* then ymin!*:=ycoord!*;
    for each y in cdr dd do prin2!* y;
    ycoord!* := ycoord!*+1;
    if cdr f then
    << prin2!* "(";
       inprint('!*comma!*,0,cdr f);
       prin2!* ")";
    >>;
    return l;
  end;

put('dfp,'prifn,'dfppri);

symbolic procedure fancy!-dfppri l;
       fancy!-dfpriindexed(l,nil);

put('dfp,'fancy!-prifn,'fancy!-dfppri);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rlfi.red0000644000175000017500000005445411526203062023103 0ustar  giovannigiovannimodule rlfi;

%***********************************************************************
%*****                                                            ******
%*****     M O D U L E     R L F I      Ver. 1.2.1   23/05/1995   ******
%*****                                                            ******
%***********************************************************************
%*****   Program for LATEX syntax of REDUCE output formulas,      ******
%*****   to activate it, turn the LATEX switch ON.                ******
%*****   Program can be used only on systems supporting lower     ******
%*****   case characters through OFF RAISE.                       ******
%*****   Note that in REDUCE 3.6 one has to input REDUCE commands ******
%*****   in lower case!!!!!                                       ******
%***********************************************************************

% Author: Richard Liska
%         Faculty of Nuclear Sciences and Physical Engineering
%         Czech Technical University in Prague
%         Brehova 7, 115 19 Prague 1, Czech Republic
% E-mail: liska@siduri.fjfi.cvut.cz
% Program RLFI, Version REDUCE 3.6  23/05/1995

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% History:
%     Ver. 1.01    17/11/1989   ******
%     Ver. 1.1     27/05/1991   ******
%     Ver. 1.1.1   27/08/1992   ****** added lists
%     Ver. 1.2     02/10/1992   ****** corrected lists, underscores _,
%           added all prefix operators from REDUCE kernel and SOLVE,
%           subscripts for ARBINT etc., VERBATIM OFF by default -
%           prints REDUCE Input: (to avoid empty verbatims), corrected
%           repeated printing of longer ids, added ROUNDED numbers
%     Ver. 1.2.1   23/05/1995   ****** minor change to 3.6

create!-package('(rlfi),'(contrib misc));

fluid'(posn!* orig!*);

% Global variables and their default values
global '(mstyle!* nochar!* nochar1!* linel!* laline!* ncharspr!*
         mstyles!*);
nochar!*:=nil;   % List of identifiers longer than one character
                 % used in previous commands
nochar1!*:=nil;  % List of identifiers longer than one character
                 % in actual command which are used for the first time
laline!*:=72;    % Linelength of output file
ncharspr!*:=0;   % Position on output line
linel!*:=linelength nil . laline!*; % actual length of line

mstyle!*:='!d!i!s!p!l!a!y!m!a!t!h;         % Default mathematical style
                                           % Possible math. styles
mstyles!*:= '(!m!a!t!h !d!i!s!p!l!a!y!m!a!t!h !e!q!u!a!t!i!o!n);

% Declaration of symbols and operators for LaTeX
flag('(!a!lp!h!a !b!e!t!a !g!a!m!m!a !d!e!l!t!a !e!p!s!i!l!o!n
       !v!a!r!e!p!s!i!l!o!n !z!e!t!a !e!t!a !t!h!e!t!a !v!a!r!t!h!e!t!a
       !i!o!t!a !k!a!p!p!a !l!a!m!b!d!a !m!u !n!u !x!i !p!i !v!a!r!p!i
       !r!h!o !v!a!r!r!h!o !s!i!g!m!a !v!a!r!s!i!g!m!a !t!a!u
       !u!p!s!i!l!o!n !p!h!i !v!a!r!p!h!i !c!h!i !p!s!i !o!m!e!g!a
       !G!a!m!m!a !D!e!l!t!a !T!h!e!t!a !L!a!m!b!d!a !X!i !P!i
       !S!i!g!m!a !U!p!s!i!l!o!n !P!h!i !P!s!i !O!m!e!g!a !i!n!f!t!y
       !h!b!a!r !n!a!b!l!a !p!e!r!p alpha beta gamma delta epsilon
       varepsilon zeta eta theta vartheta iota kappa lambda mu nu xi pi
       varpi rho varrho sigma varsigma tau upsilon phi varphi chi psi
       omega Gamma Delta Theta Lambda Xi Pi Sigma Upsilon Phi Psi Omega
       infty hbar nabla perp),'symbol);

flag('(!h!a!t !c!h!e!c!k !b!r!e!v!e !a!c!u!t!e !g!r!a!v!e !t!i!l!d!e
       !b!a!r !v!e!c !d!o!t !d!d!o!t hat check breve acute grave tilde
       bar vec dot ddot),'accdef);


deflist('((!b!o!l!d !{!\!b!f! )(!r!o!m!a!n !{!\r!m! )
          (bold !{!\!b!f! )(roman !{!\r!m! )),'fontdef);

deflist('((!( !\!l!e!f!t!() (!) !\!r!i!g!h!t!)) (!P!I !\!p!i! )
         (!p!i !\pi! ) (!E !e) (!I !i) (e !e) (i !i)),'name);

deflist('((times ! )(setq !=)(geq !\!g!e!q! )(leq !\!l!e!q! )),'lapr);

% LaTeX supported operators

deflist('(
          (acos !\!a!r!c!c!o!s) (coth !\!c!o!t!h)   (sec !\!s!e!c)
          (asin !\!a!r!c!s!i!n) (csc  !\!c!s!c)     (sin !\!s!i!n)
          (atan !\!a!r!c!t!a!n) (exp !\!e!x!p)      (sinh !\!s!i!n!h)
          (arg !\!a!r!g)        (ln !\!l!n)         (tan !\!t!a!n)
          (cos !\!c!o!s)        (log !\!l!o!g)      (tanh !\!t!a!n!h)
          (cosh !\!c!o!s!h)     (max !\!m!a!x)      (sum !\!s!u!m)
          (cot !\!c!o!t)        (min !\!m!i!n)      (product !\!p!r!o!d)
          ),'lapop);


% Other REDUCE operators

deflist('(
(abs        "{\rm abs}")           (deg2rad    "{\rm deg2rad}")
(acosd      "{\rm acosd}")         (dilog      "{\rm dilog}")
(acosh      "{\rm acosh}")         (dms2deg    "{\rm dms2deg}")
(acot       "{\rm acot}")          (dms2rad    "{\rm dms2rad}")
(acotd      "{\rm acotd}")         (erf        "{\rm erf}")
(acoth      "{\rm acoth}")         (expint     "{\rm expint}")
(acsc       "{\rm acsc}")          (factorial  "{\rm factorial}")
(acscd      "{\rm acscd}")         (fix        "{\rm fix}")
(acsch      "{\rm acsch}")         (floor      "{\rm floor}")
(arbcomplex "{\rm arbcomplex}")    (hypot      "{\rm hypot}")
(arbint     "{\rm arbint}")        (icbrt      "{\rm icbrt}")
(arbreal    "{\rm arbreal}")       (ilog2      "{\rm ilog2}")
(argd       "{\rm argd}")          (impart     "{\rm impart}")
(asec       "{\rm asec}")          (irootn     "{\rm irootn}")
(asecd      "{\rm asecd}")         (isqrt      "{\rm isqrt}")
(asech      "{\rm asech}")         (log10      "{\rm log10}")
(asind      "{\rm asind}")         (logb       "{\rm logb}")
(asinh      "{\rm asinh}")         (norm       "{\rm norm}")
(atan2      "{\rm atan2}")         (one_of     "{\rm one_of}")
(atan2d     "{\rm atan2d}")        (perm       "{\rm perm}")
(atand      "{\rm atand}")         (rad2deg    "{\rm rad2deg}")
(atanh      "{\rm atanh}")         (rad2dms    "{\rm rad2dms}")
(cbrt       "{\rm cbrt}")          (repart     "{\rm repart}")
(ceiling    "{\rm ceiling}")       (root_of    "{\rm root_of}")
(choose     "{\rm choose}")        (round      "{\rm round}")
(cosd       "{\rm cosd}")          (secd       "{\rm secd}")
(cosh       "{\rm cosh}")          (sech       "{\rm sech}")
(cotd       "{\rm cotd}")          (sgn        "{\rm sgn}")
(cscd       "{\rm cscd}")          (sind       "{\rm sind}")
(csch       "{\rm csch}")          (sol        "{\rm sol}")
(deg2dms    "{\rm deg2dms}")       (tand       "{\rm tand}")
          ),'lapop);

symbolic procedure get!*(u,v);
if numberp u then nil else get(u,v);

fluid '(!*latex !*lasimp !*verbatim !*!*a2sfn);
switch latex,lasimp,verbatim;
!*lasimp := t;
symbolic put('latex,'simpfg,'((t (latexon)) (nil(latexoff)) ));
symbolic put('verbatim,'simpfg,'((t (verbatimon)) (nil (verbatimoff))));

symbolic procedure latexon;
% Procedure called after ON LATEX
<>;
  put('tex,'rtypefn,'(lambda(x) 'tex)) >>;

symbolic procedure latexoff;
% Procedure called after OFF LATEX
<>;
  prin2t "\end{document}";
  rmsubs() >>;

procedure verbatimon;
<>;
  !*echo:=t>>;

procedure verbatimoff;
<>;
  !*echo:=nil >>;

symbolic procedure texaeval u;
% Procedure replaces the AEVAL procedure in the LATEX mode
if !*lasimp then list('tex,aeval u)
  else list('tex,u);

% deklarace latex modu;
put('tex,'tag,'tex);
put('tex,'simpfn,'simpcar);
put('tex,'typeletfn,'texlet);
put('tex,'prifn,'latexprint);
put('tex,'setprifn,'setlaprin);
flag('(tex),'sprifn);

symbolic procedure texlet(u,v,tu,b,tv);
% Assignment procedure for LATEX mode
% !!! match can be evaluated like let!!!!;
if eqcar(v,'tex) then let2(u,cadr v,nil,b)
  else msgpri(" value for ",u," not assigned ",v,nil);

symbolic procedure latexprint u;
% Prints expression U in the LaTeX syntax
<>;

symbolic procedure setlaprin(u,v);
% Prints assignment command in LaTeX syntax
<>;

symbolic procedure mathstyle u;
% Defines the output mathematical style
if car u memq mstyles!* then <>
  else msgpri(" mathematical style ",car u," not supported ",nil,nil);

put('mathstyle,'stat,'rlis);

symbolic procedure prinlabegin;
% Initializes the output
<>;
  linel!*:=linelength nil . laline!*;
  if ofl!* then linelength(laline!* + 2)
    else laline!*:=car linel!* - 2;
  prin2 "\begin{";
  prin2 mstyle!*;
  prin2t "}" >>;

symbolic procedure prinlaend;
% Ends the output of one expression
<>;
  ncharspr!*:=0;
  if nochar1!*
    then msgpri(" Longer than one character identifiers used ",
                nil,nochar1!*,nil,nil);
  if ofl!* then linelength(car linel!*)
    else laline!*:=cdr linel!*;
  nochar!*:=append(nochar!*,nochar1!*);
  nochar1!*:=nil >>;

symbolic procedure latexprin u;
% Prints expression U in the LaTeX syntax
if eqcar(u,'tex) then maprintla(cadr u,0)
  else maprintla(u,0);

symbolic procedure texprla(u,p);
maprintla(car u,p);

put('tex,'laprifn,'texprla);

symbolic procedure maprintla(l,p);
% L is printed expression, P is the infix precedence of infix operator
% Procedure is similar to that one in the REDUCE source
begin
  scalar x;
  if null l then return nil
    else if numberp l then go to c
    else if atom l then return prinlatom l
    else if stringp l then return prin2la l
    else if not atom car l then return maprintla(car l,p)
    else if (x:=get(car l,'laprifn)) and
        ((not flagp(car l,'fulla)
          and not (apply(x,list(cdr l,p)) eq 'failed))
        or (flagp(car l,'fulla) and not(apply(x,list(l,p)) eq 'failed)))
           then return l
    else if (x:=get(car l,'indexed)) then return prinidop(car l,cdr l,x)
    else if x:=get(car l,'infix) then go to a
    else if car l eq '!:rd!: then return
      begin
        scalar !*nat,ll;
        % max. estimate
        ll:=if floatp cdr l then lengthc cdr l
             else lengthc cadr l + lengthc cddr l + 5;
        if ncharspr!* + ll > laline!* then
            <>
          else ncharspr!*:=ncharspr!* + ll;
        posn!*:=orig!*;
        rd!:prin l
      end;
  oprinla(car l);
  prinpopargs(car l,cdr l,p);
  return l;
a:p:=x>p;
  if null p and car l eq 'equal then p:=t;
  if p then go to b;
  prinlatom '!(;
b:inprinla(car l,x,cdr l);
  if p then return l;
  prinlatom '!);
  return l;
c:if not(l<0) or p>;

procedure chundexp u;
% Replaces underscores _ in ids by \_
% except if u = !_
begin
  scalar x;
  u:=explode2 u;
  x:=u;
  if eqcar(u,'_) and cdr u then u:='!\ . u;
a:if null cdr x then goto r;
  if cadr x eq '_ then
      <>;
  x:=cdr x;
  goto a;
r:return u
end;

symbolic procedure inprinla(op,p,l);
% Prints infix operator OP with arguments in the list L
begin
  if get(op,'alt) then go to a;
  maprintla(car l,p);
a0:l:=cdr l;
a:if null l then return nil
    else if atom car l or not(op eq get!*(caar l,'alt)) then
      <>
    else maprintla(car l,p);
  go to a0;
end;

symbolic procedure oprinla op;
% Prints operator OP
begin
  scalar x;
  if x:=get(op,'lapr) then prin2la x
    else if x:=get(op,'prtch) then prin2la x
    else if x:=get(op,'lapop) then <>
    else prinlatom op
end;

% Definition of new operator of division --> horizontal division line
newtok '((!\) backslash);
deflist('((backslash recip)),'unary);
algebraic infix \;
precedence 'backslash,'quotient;
put('backslash,'simpfn,'simpiden);

symbolic procedure prin2la u;
% Prints atom or string U, checks the length of line
% CHUNDEXP makes the change _ -> \_
begin
  scalar l;
  u:=chundexp u;
  l:=length u;
  if ncharspr!* + l > laline!* then <>;
  for each a in u do prin2 a;
  ncharspr!*:=ncharspr!* + l
end;

symbolic procedure prinfrac(l,p);
% Prints the fraction with horizontal division line
<>;
put('backslash,'laprifn,'prinfrac);

symbolic procedure defindex u;
% Defines the placing of indices of an operator
for each a in u do defindex1 a;
put('defindex,'stat,'rlis);

symbolic procedure defindex1 u;
begin
  scalar at,x;
  at:=car u;
  for each a in cdr u do if not(a memq '(arg up down leftup leftdown))
                           then x:=t;
  if not atom at or null cdr u then x:=t;
  return if x then msgpri(" Syntax error ",u,nil,nil,'hold)
           else put(at,'indexed,cdr u)
end;

symbolic procedure prinidop(op,args,mask);
% Prints operator with indices. MASK describe the place of indices
begin
  scalar arg,up,down,lup,ldown;
  if null args then return prinlatom op;
a:if car mask eq 'arg then arg:=car args . arg
    else if car mask eq 'up then up:=car args . up
    else if car mask eq 'down then down:=car args . down
    else if car mask eq 'leftup then lup:=car args . lup
    else if car mask eq 'leftdown then ldown:=car args . ldown;
  mask:=cdr mask;
  args:=cdr args;
  if mask and args then go to a;
  mask:='(arg);
  if args then go to a;
  arg:=reverse arg;
  up:=reverse up;
  down:=reverse down;
  lup:=reverse lup;
  ldown:=reverse ldown;
  if lup or ldown then prin2la "\:";
  if lup then
      <>;
  if ldown then
      <>;
  oprinla op;
  if up then
      <>;
  if down then
      <>;
  if arg then
      <>;
  return op
end;

symbolic procedure prinindexs ndxs;
% Prints indexces NDXS, if all indices are atoms prints them withouth
% separating commas
begin
  scalar b;
  for each a in ndxs do if not atom a then b:=t;
  if not b then for each a in ndxs do prinlatom a
    else inprinla('!*comma!*,0,ndxs)
end;

symbolic procedure exptprla(args,p);
% Prints powers
begin
  scalar arg,exp,ilist;
  arg:=car args;
  exp:=cadr args;
  if not atom exp and car exp eq 'quotient and cadr exp = 1
     and atom caddr exp
    then if caddr exp = 2 then
                <>
              else
                <>
    else if atom arg then
      <>
    else if atom car arg and not (ilist:=get(car arg,'indexed)) and
                not get(car arg,'laprifn) and
                not get(car arg,'infix) and atom exp then
             <>
    else if atom car arg and (ilist:=get(car arg,'indexed)) and
                 not memq('up,ilist) then
              <>
    else
      <>;
  return args
end;
put('expt,'laprifn,'exptprla);

procedure sqrtprla(arg,p);
% Prints square root
<>;
put('sqrt,'laprifn,'sqrtprla);

symbolic procedure intprla(args,p);
% Prints indefinite itegral
begin
  scalar arg,var;
  if null args or null cdr args or not atom cadr args
    then return 'failed;
  arg:=car args;
  var:=cadr args;
  prin2la "\int ";
  maprintla(arg,0);
  prin2la "\:d\,";
  prinlatom var;
  return args
end;
put('int,'laprifn,'intprla);

symbolic procedure dintprla(args,p);
% Prints definite integral
begin
  scalar down,up,arg,var;
  if null args or null cdr args or null cddr args or null cdddr args or
     not atom (var:=cadddr args) then return 'failed;
  down:=car args;
  up:=cadr args;
  arg:=caddr args;
  prin2la "\int";
  prin2la "_";
  prin2la "{";
  maprintla(down,0);
  prin2la "}^{";
  maprintla(up,0);
  prin2la "}";
  maprintla(arg,0);
  prin2la "\:d\,";
  prinlatom var;
  return args
end;
put('dint,'laprifn,'dintprla);

symbolic procedure sumprla(ex,p);
% Prints a sum
begin
  scalar op,down,up,arg;
  if not get(op:=car ex,'lapop) or null cdr ex or null cddr ex
     or null cdddr ex
    then return 'failed;
  down:=cadr ex;
  up:=caddr ex;
  arg:=cadddr ex;
  oprinla op;
  if down then
      <>;
  if up then
      <>;
  maprintla(arg,get('times,'infix) - 1);
  return ex
end;
put('sum,'laprifn,'sumprla);
put('product,'laprifn,'sumprla);
flag('(sum product),'fulla);

symbolic procedure sqprla(args,p);
% Prints standard quotient
maprintla(prepsq!* car args,p);
put('!*sq,'laprifn,'sqprla);

symbolic procedure dfprla(dfex,p);
% Prints derivaves
begin
  scalar op,ord,arg,x,argup;
  op:=get(car dfex,'lapop);
  arg:=cadr dfex;
  dfex:=cddr dfex;
  x:=dfex;
  ord:=0;
a:if null cdr x then
      <>
    else if fixp cadr x then
      <>
    else
      <>;
  if x then go to a;
  if atom arg or (not get(car arg,'infix) and not get(car arg,'laprifn))
    then argup:=t;
  prin2la "\frac{";
  prin2la op;
  if ord=1 then prin2la "\,"
    else
      <>;
  if argup then maprintla(arg,0);
  prin2la "}{";
  x:=dfex;
b:if not atom car x and cdr x and fixp cadr x then prin2la "(";
  prin2la op;
  if null cdr x or not fixp cadr x then
      <>
    else
      <>;
  if x then go to b;
  prin2la "}";
  if null argup then maprintla(arg,get('quotient,'infix));
  return arg
end;

put('df,'laprifn,'dfprla);
put('pdf,'laprifn,'dfprla);
flag('(df pdf),'fulla);
put('df,'lapop,"{\rm d}");
put('pdf,'lapop,"\partial ");

procedure listprla(args,p);
% Prints list of expressions
if args then
<>;
  terpri();
  prin2 "\right\}">>
else prin2 "\{\}";

put('list,'laprifn,'listprla);

put('arbint,'indexed,'(down));
put('arbreal,'indexed,'(down));
put('arbcomplex,'indexed,'(down));

algebraic;

operator pdf,dint,product;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie.tex0000644000175000017500000001746411526203062022746 0ustar  giovannigiovanni\documentstyle{article}
\parindent0cm
%\textwidth 15.5cm\textheight 22.0cm\columnwidth\textwidth
%\hoffset-1.5cm\voffset-1.5cm
\begin{document}
%\parskip 10pt plus 1pt \parindent 0pt
\title{The {LIE} Package}
\author{Carsten and Franziska Sch\"obel\\
The Leipzig University, Computer Science Dept.\\
Augustusplatz 10/11, O-7010 Leipzig, Germany\\
Email: cschoeb@aix550.informatik.uni-leipzig.de}
\date{22 January 1993}
\maketitle
{\bf LIE} is a package of functions for the classification of real n-dimensional
Lie algebras. It consists of two modules: {\bf liendmc1} and {\bf lie1234}.
\\[0.3cm]{\large\bf liendmc1}\\[0.1cm]
With the help of the functions in this module real n-dimensional Lie algebras
$L$ with a derived algebra $L^{(1)}$ of dimension 1 can be classified. $L$ has
to be defined by its structure constants $c_{ij}^k$ in the basis
$\{X_1,\ldots,X_n\}$ with $[X_i,X_j]=c_{ij}^k X_k$. The user must define an
ARRAY LIENSTRUCIN($n,n,n$) with n being the dimension of the Lie algebra $L$.
The structure constants LIENSTRUCIN($i,j,k$):=$c_{ij}^k$ for $i).
\end{verbatim}
{\tt } corresponds to the dimension $n$. The procedure simplifies
the structure of $L$ performing real linear transformations. The returned
value is a list of the form
\begin{verbatim}
   (i) {LIE_ALGEBRA(2),COMMUTATIVE(n-2)} or
   (ii) {HEISENBERG(k),COMMUTATIVE(n-k)}
\end{verbatim}
with $3\leq k\leq n$, $k$ odd.\\
The concepts correspond to the following theorem ({\tt LIE\_ALGEBRA(2)}
$\rightarrow L_2$, {\tt HEISENBERG(k)} $\rightarrow H_k$ and
{\tt COMMUTATIVE(n-k)} $\rightarrow C_{n-k}$):\\[0.2cm]
{\bf Theorem.} Every real $n$-dimensional Lie algebra $L$ with a 1-dimensional
derived algebra can be decomposed into one of the following forms:\\[0.1cm]
\hspace*{0.3cm} (i) $C(L)\cap L^{(1)}=\{0\}\, :\; L_2\oplus C_{n-2}$
or\\[0.05cm]
\hspace*{0.3cm} (ii) $C(L)\cap L^{(1)}=L^{(1)}\, :\; H_k\oplus C_{n-k}\quad
(k=2r-1,\, r\geq 2)$, with\newpage
\hspace*{0.3cm} 1. $C(L)=C_j\oplus (L^{(1)}\cap C(L))$
and dim$\,C_j=j$ ,\\[0.05cm]
\hspace*{0.3cm} 2. $L_2$ is generated by
$Y_1,Y_2$ with $[Y_1,Y_2]=Y_1$ ,\\[0.05cm]
\hspace*{0.3cm} 3. $H_k$ is generated by $\{Y_1,\ldots,Y_k\}$ with\\
\hspace*{0.7cm} $[Y_2,Y_3]=\cdots =[Y_{k-1},Y_k]=Y_1$.\\[0.2cm]
(cf. \cite{cssmp92})\\[0.2cm]
The returned list is also stored as LIE\_LIST. The matrix LIENTRANS gives the
transformation from the given basis $\{X_1,\ldots ,X_n\}$ into the standard
basis $\{Y_1,\ldots ,Y_n\}$: $Y_j=($LIENTRANS$)_j^k X_k$.\\[0.1cm]
A more detailed output can be obtained by turning on the switch TR\_LIE:
\begin{verbatim}
   ON TR_LIE;
\end{verbatim}
before the procedure LIENDIMCOM1 is called.\\[0.1cm]
The returned list could be an input for a data bank in which mathematical
relevant properties of the obtained Lie algebras are stored.\\[0.3cm]
{\large\bf lie1234}\\[0.1cm]
This part of the package classifies real low-dimensional Lie algebras $L$
of the dimension
$n:=$dim$\,L=1,2,3,4$. $L$ is also given by its structure constants $c_{ij}^k$
in the basis $\{X_1,\ldots,X_n\}$ with $[X_i,X_j]=c_{ij}^k X_k$. An ARRAY
LIESTRIN($n,n,n$) has to be defined and LIESTRIN($i,j,k$):=$c_{ij}^k$ for
$i).
\end{verbatim}
{\tt } should be the dimension of the Lie algebra $L$. The procedure
stepwise simplifies the commutator relations of $L$ using properties of
invariance like the dimension of the centre, of the derived algebra,
unimodularity etc.  The returned value has the form:
\begin{verbatim}
   {LIEALG(n),COMTAB(m)},
\end{verbatim}
where $m$ corresponds to the number of the standard form (basis:
$\{Y_1,\ldots,Y_n\}$) in an enumeration scheme. The corresponding enumeration
schemes are listed below (cf. \cite{ntz-preprint27/92},\cite{mmpreprint1979}).
In case that the standard form in the enumeration scheme depends on one (or two)
parameter(s) $p_1$ (and $p_2$) the list is expanded to:
\begin{verbatim}
   {LIEALG(n),COMTAB(m),p1,p2}.
\end{verbatim}
This returned value is also stored as LIE\_CLASS. The linear transformation from
the basis $\{X_1,\ldots,X_n\}$ into the basis of the standard form
$\{Y_1,\ldots,Y_n\}$ is given by the matrix LIEMAT:
$Y_j=($LIEMAT$)_j^k X_k$.\newpage
By turning on the switch TR\_LIE:
\begin{verbatim}
   ON TR_LIE;
\end{verbatim}
before the procedure LIECLASS is called the output contains not only the
list LIE\_CLASS but also the non-vanishing commutator relations in the
standard form.\\[0.1cm]
By the value $m$ and the parameters further examinations of the Lie algebra
are possible, especially if in a data bank mathematical relevant properties
of the enumerated standard forms are stored.\\[0.3cm]
{\large\bf Enumeration schemes for lie1234}\\[0.2cm]
\hspace*{0.3cm}\begin{tabular}{l|l}returned list LIE\_CLASS&
the corresponding commutator relations\\[0.1cm]\hline
{LIEALG(1),COMTAB(0)}&commutative case\\[0.1cm]\hline
{LIEALG(2),COMTAB(0)}&commutative case\\[0.1cm]
{LIEALG(2),COMTAB(1)}&$[Y_1,Y_2]=Y_2$\\[0.1cm]\hline
{LIEALG(3),COMTAB(0)}&commutative case\\[0.1cm]
{LIEALG(3),COMTAB(1)}&$[Y_1,Y_2]=Y_3$\\[0.1cm]
{LIEALG(3),COMTAB(2)}&$[Y_1,Y_3]=Y_3$\\[0.1cm]
{LIEALG(3),COMTAB(3)}&$[Y_1,Y_3]=Y_1,[Y_2,Y_3]=Y_2$\\[0.1cm]
{LIEALG(3),COMTAB(4)}&$[Y_1,Y_3]=Y_2,[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(3),COMTAB(5)}&$[Y_1,Y_3]=-Y_2,[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(3),COMTAB(6)}&$[Y_1,Y_3]=-Y_1+p_1 Y_2,[Y_2,Y_3]=Y_1,p_1\neq 0$\\[0.1cm]
{LIEALG(3),COMTAB(7)}&$[Y_1,Y_2]=Y_3,[Y_1,Y_3]=-Y_2,[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(3),COMTAB(8)}&$[Y_1,Y_2]=Y_3,[Y_1,Y_3]=Y_2,[Y_2,Y_3]=Y_1$\\[0.1cm]\hline
{LIEALG(4),COMTAB(0)}&commutative case\\[0.1cm]
{LIEALG(4),COMTAB(1)}&$[Y_1,Y_4]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(2)}&$[Y_2,Y_4]=Y_1$\\[0,1cm]
{LIEALG(4),COMTAB(3)}&$[Y_1,Y_3]=Y_1,[Y_2,Y_4]=Y_2$\\[0.1cm]
{LIEALG(4),COMTAB(4)}&$[Y_1,Y_3]=-Y_2,[Y_2,Y_4]=Y_2,$\\
                     &$[Y_1,Y_4]=[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(5)}&$[Y_2,Y_4]=Y_2,[Y_1,Y_4]=[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(6)}&$[Y_2,Y_4]=Y_1,[Y_3,Y_4]=Y_2$\\[0.1cm]
{LIEALG(4),COMTAB(7)}&$[Y_2,Y_4]=Y_2,[Y_3,Y_4]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(8)}&$[Y_1,Y_4]=-Y_2,[Y_2,Y_4]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(9)}&$[Y_1,Y_4]=-Y_1+p_1 Y_2,[Y_2,Y_4]=Y_1,p_1\neq 0$\\[0.1cm]
{LIEALG(4),COMTAB(10)}&$[Y_1,Y_4]=Y_1,[Y_2,Y_4]=Y_2$\\[0.1cm]
{LIEALG(4),COMTAB(11)}&$[Y_1,Y_4]=Y_2,[Y_2,Y_4]=Y_1$
\end{tabular}\\
\hspace*{0.3cm}\begin{tabular}{l|l}returned list LIE\_CLASS&
the corresponding commutator relations\\[0.1cm]\hline
{LIEALG(4),COMTAB(12)}&$[Y_1,Y_4]=Y_1+Y_2,[Y_2,Y_4]=Y_2+Y_3,$\\
                      &$[Y_3,Y_4]=Y_3$\\[0.1cm]
{LIEALG(4),COMTAB(13)}&$[Y_1,Y_4]=Y_1,[Y_2,Y_4]=p_1 Y_2,[Y_3,Y_4]=p_2 Y_3,$\\
                      &$p_1,p_2\neq 0$\\[0.1cm]
{LIEALG(4),COMTAB(14)}&$[Y_1,Y_4]=p_1 Y_1+Y_2,[Y_2,Y_4]=-Y_1+p_1 Y_2,$\\
                      &$[Y_3,Y_4]=p_2 Y_3,p_2\neq 0$\\[0.1cm]
{LIEALG(4),COMTAB(15)}&$[Y_1,Y_4]=p_1 Y_1+Y_2,[Y_2,Y_4]=p_1 Y_2,$\\
                      &$[Y_3,Y_4]=Y_3,p_1\neq 0$\\[0.1cm]
{LIEALG(4),COMTAB(16)}&$[Y_1,Y_4]=2 Y_1,[Y_2,Y_3]=Y_1,$\\
                      &$[Y_2,Y_4]=(1+p_1) Y_2,[Y_3,Y_4]=(1-p_1) Y_3,$\\
                      &$p_1\geq 0$\\[0.1cm]
{LIEALG(4),COMTAB(17)}&$[Y_1,Y_4]=2 Y_1,[Y_2,Y_3]=Y_1,$\\
                      &$[Y_2,Y_4]=Y_2-p_1 Y_3,[Y_3,Y_4]=p_1 Y_2+Y_3,$\\
                      &$p_1\neq 0$\\[0.1cm]
{LIEALG(4),COMTAB(18)}&$[Y_1,Y_4]=2 Y_1,[Y_2,Y_3]=Y_1,$\\
                      &$[Y_2,Y_4]=Y_2+Y_3,[Y_3,Y_4]=Y_3$\\[0.1cm]
{LIEALG(4),COMTAB(19)}&$[Y_2,Y_3]=Y_1,[Y_2,Y_4]=Y_3,[Y_3,Y_4]=Y_2$\\[0.1cm]
{LIEALG(4),COMTAB(20)}&$[Y_2,Y_3]=Y_1,[Y_2,Y_4]=-Y_3,[Y_3,Y_4]=Y_2$\\[0.1cm]
{LIEALG(4),COMTAB(21)}&$[Y_1,Y_2]=Y_3,[Y_1,Y_3]=-Y_2,[Y_2,Y_3]=Y_1$\\[0.1cm]
{LIEALG(4),COMTAB(22)}&$[Y_1,Y_2]=Y_3,[Y_1,Y_3]=Y_2,[Y_2,Y_3]=Y_1$
\end{tabular}
\bibliography{lie}
\bibliographystyle{plain}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compact.bib0000644000175000017500000000046611526203062023551 0ustar  giovannigiovanni@INPROCEEDINGS{Hornfeldt:82,
  AUTHOR = "L. Hornfeldt",
  TITLE = "A Sum-Substitutor used as Trigonometric Simplifier",
  BOOKTITLE = "Proc. {EUROCAM} '82",
  PAGES = "188-195",
  SERIES = "Lecture Notes on Comp. Science",
  NUMBER = 144,
  PUBLISHER = "Springer-Verlag",
  ADDRESS = "Berlin",
  YEAR = 1982}

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/sets.tex0000644000175000017500000003132211526203062023140 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}

\title{SETS: A Basic Set Theory Package}

\author{Francis J. Wright \\
School of Mathematical Sciences \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road, London E1 4NS, UK. \\
Email: {\tt F.J.Wright@QMW.ac.uk}}

\begin{document}
\maketitle

\begin{abstract}
  The SETS package for \REDUCE 3.5 and later versions provides
  algebraic-mode support for set operations on lists regarded as sets
  (or representing explicit sets) and on implicit sets represented by
  identifiers.  It provides the set-valued infix operators (with
  synonyms) {\tt union}, {\tt intersection} ({\tt intersect}) and {\tt
  setdiff} (\verb|\|, {\tt minus}) and the Boolean-valued infix
  operators (predicates) {\tt member}, {\tt subset\_eq}, {\tt subset},
  {\tt set\_eq}.  The union and intersection operators are n-ary and
  the rest are binary.  A list can be explicitly converted to the
  canonical set representation by applying the operator {\tt mkset}.
  (The package also provides an operator not specifically related to
  set theory called {\tt evalb} that allows the value of any
  Boolean-valued expression to be displayed in algebraic mode.)
\end{abstract}


\section{Introduction}

REDUCE has no specific representation for a set, neither in algebraic
mode nor internally, and any object that is mathematically a set is
represented in REDUCE as a list.  The difference between a set and a
list is that in a set the ordering of elements is not significant and
duplicate elements are not allowed (or are ignored).  Hence a list
provides a perfectly natural and satisfactory representation for a set
(but not vice versa).  Some languages, such as Maple, provide
different internal representations for sets and lists, which may allow
sets to be processed more efficiently, but this is not {\em
necessary}.

This package supports set theoretic operations on lists and represents
the results as normal algebraic-mode lists, so that all other REDUCE
facilities that apply to lists can still be applied to lists that have
been constructed by explicit set operations.  The algebraic-mode set
operations provided by this package have all been available in
symbolic mode for a long time, and indeed are used internally by the
rest of REDUCE, so in that sense set theory facilities in REDUCE are
far from new.  What this package does is make them available in
algebraic mode, generalize their operation by extending the arity of
union and intersection, and allow their arguments to be implicit sets
represented by unbound identifiers.  It performs some simplifications
on such symbolic set-valued expressions, but this is currently rather
{\it ad hoc\/} and is probably incomplete.

For examples of the operation of the SETS package see (or run) the
test file {\tt sets.tst}.  This package is experimental and
developments are under consideration; if you have suggestions for
improvements (or corrections) then please send them to me (FJW),
preferably by email.  The package is intended to be run under
\REDUCE 3.5 and later versions; it may well run correctly under earlier
versions although I cannot provide support for such use.


\section{Infix operator precedence}

The set operators are currently inserted into the standard REDUCE
precedence list (see page 28, \S2.7, of the REDUCE 3.6 manual) as
follows:
\begin{verbatim}
or and not member memq = set_eq neq eq >= > <= < subset_eq
subset freeof + - setdiff union intersection * / ^ .
\end{verbatim}


\section{Explicit set representation and {\tt mkset}}

Explicit sets are represented by lists, and this package does not
require any restrictions at all on the forms of lists that are
regarded as sets.  Nevertheless, duplicate elements in a set
correspond by definition to the same element and it is conventional
and convenient to represent them by a single element, i.e.\ to remove
any duplicate elements.  I will call this a normal representation.
Since the order of elements in a set is irrelevant it is also
conventional and may be convenient to sort them into some standard
order, and an appropriate ordering of a normal representation gives a
canonical representation.  This means that two identical sets have
identical representations, and therefore the standard REDUCE equality
predicate ({\tt =}) correctly determines set equality; without a
canonical representation this is not the case.

Pre-processing of explicit set-valued arguments of the set-valued
operators to remove duplicates is always done because of the obvious
efficiency advantage if there were any duplicates, and hence explicit
sets appearing in the values of such operators will never contain any
duplicate elements.  Such sets are also currently sorted, mainly
because the result looks better.  The ordering used satisfies the {\tt
ordp} predicate used for most sorting within REDUCE, except that
explicit integers are sorted into increasing numerical order rather
than the decreasing order that satisfies {\tt ordp}.

Hence explicit sets appearing in the result of any set operator are
currently returned in a canonical form.  Any explicit set can also be
put into this form by applying the operator {\tt mkset} to the list
representing it.  For example
\begin{verbatim}
mkset {1,2,y,x*y,x+y};

{x + y,x*y,y,1,2}
\end{verbatim}

The empty set is represented by the empty list \verb|{}|.


\section{Union and intersection}

The operator {\tt intersection} (the name used internally) has the
shorter synonym {\tt intersect}.  These operators will probably most
commonly be used as binary infix operators applied to explicit sets,
e.g.
\begin{verbatim}
{1,2,3} union {2,3,4};

{1,2,3,4}

{1,2,3} intersect {2,3,4};

{2,3}
\end{verbatim}
They can also be used as n-ary operators with any number of arguments,
in which case it saves typing to use them as prefix operators (which
is possible with all REDUCE infix operators), e.g.
\begin{verbatim}
{1,2,3} union {2,3,4} union {3,4,5};

{1,2,3,4,5}

intersect({1,2,3}, {2,3,4}, {3,4,5});

{3}
\end{verbatim}
For completeness, they can currently also be used as unary operators,
in which case they just return their arguments (in canonical form),
and so act as slightly less efficient versions of {\tt mkset} (but
this may change), e.g.
\begin{verbatim}
union {1,5,3,5,1};

{1,3,5}
\end{verbatim}


\section{Symbolic set expressions}

If one or more of the arguments evaluates to an unbound identifier
then it is regarded as representing a symbolic implicit set, and the
union or intersection will evaluate to an expression that still
contains the union or intersection operator.  These two operators are
symmetric, and so if they remain symbolic their arguments will be
sorted as for any symmetric operator.  Such symbolic set expressions
are simplified, but the simplification may not be complete in
non-trivial cases.  For example:
\begin{verbatim}
a union b union {} union b union {7,3};

{3,7} union a union b

a intersect {};

{}
\end{verbatim}

In implementations of REDUCE that provide fancy display using
mathematical notation, such as PSL-REDUCE~3.6 for MS-Windows, the
empty set, union, intersection and set difference are all displayed
using their conventional mathematical symbols, namely $\emptyset$,
$\cup$, $\cap$, $\setminus$.

A symbolic set expression is a valid argument for any other set
operator, e.g.
\begin{verbatim}
a union (b intersect c);

b intersection c union a
\end{verbatim}

Intersection distributes over union, which is not applied by default
but is implemented as a rule list assigned to the variable {\tt
set\_distribution\_rule}, e.g.
\begin{verbatim}
a intersect (b union c);

(b union c) intersection a

a intersect (b union c) where set_distribution_rule;

a intersection b union a intersection c
\end{verbatim}


\section{Set difference}

The set difference operator is represented by the symbol \verb|\| and
is always output using this symbol, although it can also be input using
either of the two names {\tt setdiff} (the name used internally) or
{\tt minus} (as used in Maple).  It is a binary operator, its operands
may be any combination of explicit or implicit sets, and it may be
used in an argument of any other set operator.  Here are some
examples:
\begin{verbatim}
{1,2,3} \ {2,4};

{1,3}

{1,2,3} \ {};

{1,2,3}

a \ {1,2};

a\{1,2}

a \ a;

{}

a \ {};

a

{} \ a;

{}
\end{verbatim}


\section{Predicates on sets}

These are all binary infix operators.  Currently, like all REDUCE
predicates, they can only be used within conditional statements ({\tt
if}, {\tt while}, {\tt repeat}) or within the argument of the {\tt
evalb} operator provided by this package, and they cannot remain
symbolic -- a predicate that cannot be evaluated to a Boolean value
causes a normal REDUCE error.

The {\tt evalb} operator provides a convenient shorthand for an {\tt
if} statement designed purely to display the value of any Boolean
expression (not only predicates defined in this package).  It has some
similarity with the {\tt evalb} function in Maple, except that the
values returned by {\tt evalb} in REDUCE (the identifiers {\tt true}
and {\tt false}) have no significance to REDUCE itself.  Hence, in
REDUCE, use of {\tt evalb} is {\em never\/} necessary.
\begin{verbatim}
if a = a then true else false;

true

evalb(a = a);

true

if a = b then true else false;

false

evalb(a = b);

false

evalb 1;

true

evalb 0;

false
\end{verbatim}
I will use the {\tt evalb} operator in preference to an explicit {\tt
if} statement for purposes of illustration.


\subsection{Set membership}

Set membership is tested by the predicate {\tt member}.  Its left
operand is regarded as a potential set element and its right operand
{\em must\/} evaluate to an explicit set.  There is currently no sense
in which the right operand could be an implicit set; this would
require a mechanism for declaring implicit set membership (akin to
implicit variable dependence) which is currently not implemented.  Set
membership testing works like this:
\begin{verbatim}
evalb(1 member {1,2,3});

true

evalb(2 member {1,2} intersect {2,3});

true

evalb(a member b);

***** b invalid as list
\end{verbatim}


\subsection{Set inclusion}

Set inclusion is tested by the predicate {\tt subset\_eq} where {\tt a
subset\_eq b} is true if the set $a$ is either a subset of or equal to
the set $b$; strict inclusion is tested by the predicate {\tt subset}
where {\tt a subset b} is true if the set $a$ is {\em strictly\/} a
subset of the set $b$ and is false is $a$ is equal to $b$.  These
predicates provide some support for symbolic set expressions, but this
is not yet correct as indicated below.  Here are some examples:
\begin{verbatim}
evalb({1,2} subset_eq {1,2,3});

true

evalb({1,2} subset_eq {1,2});

true

evalb({1,2} subset {1,2});

false


evalb(a subset a union b);

true

evalb(a\b subset a);

true

evalb(a intersect b subset a union b);  %%% BUG

false
\end{verbatim}

An undecidable predicate causes a normal REDUCE error, e.g.
\begin{verbatim}
evalb(a subset_eq {b});

***** Cannot evaluate a subset_eq {b} as Boolean-valued set
 expression

evalb(a subset_eq b);  %%% BUG

false
\end{verbatim}


\subsection{Set equality}

As explained above, equality of two sets in canonical form can be
reliably tested by the standard REDUCE equality predicate ({\tt =}).
This package also provides the predicate {\tt set\_eq} to test
equality of two sets not represented canonically.  The two predicates
behave identically for operands that are symbolic set expressions
because these are always evaluated to canonical form (although
currently this is probably strictly true only in simple cases).  Here
are some examples:
\begin{verbatim}
evalb({1,2,3} = {1,2,3});

true

evalb({2,1,3} = {1,3,2});

false

evalb(mkset{2,1,3} = mkset{1,3,2});

true

evalb({2,1,3} set_eq {1,3,2});

true

evalb(a union a = a\{});

true
\end{verbatim}


\section{Installation}

The source file {\tt sets.red} can be read into REDUCE when required
using {\tt IN}.  If the ``professional'' version is being used this
should be done with {\tt ON COMP} set, but it is much better to
compile the code as a {\tt FASL} file using {\tt FASLOUT} and then
load it with {\tt LOAD\_PACKAGE} (or {\tt LOAD}).  See the REDUCE
manual and implementation-specific guide for further details.

This package has to redefine the REDUCE internal procedure {\tt
mk!*sq} and a warning about this can be expected and ignored.  I
believe (and hope!) that this redefinition is safe and will not have
any unexpected consequences for the rest of REDUCE.


\section{Possible future developments}

\begin{itemize}
\item Unary union/intersection to implement repeated
  union/intersection on a set of sets.
\item More symbolic set algebra, canonical forms for set expressions,
  more complete simplification.
\item Better support for Boolean variables via a version (evalb10?)
  of {\tt evalb} that returns 1/0 instead of {\tt true}/{\tt false},
  or predicates that return 1/0 directly.
\end{itemize}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/randpoly.rlg0000644000175000017500000002320211527635055024010 0ustar  giovannigiovanniFri Feb 18 21:27:52 2011 run on win32
% randpoly.tst

% F.J.Wright@Maths.QMW.ac.uk, 14 July 1994

off allfac;

  on div, errcont;



% Univariate:
% ----------
randpoly x;


       5       4       3       2
 - 68*x  + 45*x  - 13*x  + 27*x  + 54*x - 15

% Equivalent to above:
randpoly {x};


    5       4       3       2
23*x  - 83*x  + 75*x  - 89*x  - 24*x + 54

randpoly(x, dense);


   5       4       3       2
4*x  + 17*x  - 53*x  + 53*x  + 88*x - 12
  % univariate default already dense
randpoly(x, degree=10, ord=5);


       10       9       8       7       6       5
 - 83*x   + 28*x  - 13*x  - 65*x  + 55*x  - 26*x


% Bivariate:
% ---------
% Default is sparse
randpoly {x,y};


    3  2       3         2           2
29*x *y  + 12*x *y - 33*x *y - 64*x*y  - 19*x - 13

randpoly({x,y}, dense);


       5       4         4      3  2       3         3    2  3       2  2
 - 12*x  + 11*x *y - 26*x  + 2*x *y  + 69*x *y - 93*x  + x *y  - 93*x *y

       2         2         4         3         2                       5       4
 + 19*x *y + 95*x  + 51*x*y  + 68*x*y  + 77*x*y  + 25*x*y - 27*x + 63*y  + 37*y

       3       2
 - 89*y  - 76*y  + 28*y - 67

randpoly({x,y}, degree=10);


    10       7       6       2  8       2  5         9
19*x   + 16*x  + 86*x  + 82*x *y  - 62*x *y  + 41*x*y

% Lots of terms:
randpoly({x,y}, dense, degree=10);


    9         9      8  2       8         8       7  3       7  2       7
43*x *y + 67*x  - 6*x *y  - 11*x *y - 88*x  - 87*x *y  - 36*x *y  + 27*x *y

       7       6  4       6  3       6  2       6         6       5  5
 - 56*x  + 41*x *y  + 52*x *y  + 15*x *y  + 84*x *y - 76*x  - 59*x *y

       5  4       5  3       5  2       5         5       4  6       4  5
 + 74*x *y  + 90*x *y  - 50*x *y  - 35*x *y - 90*x  - 51*x *y  + 73*x *y

      4  4       4  3       4  2       4         4       3  7       3  6
 - 5*x *y  + 34*x *y  + 88*x *y  + 87*x *y - 33*x  - 41*x *y  - 12*x *y

       3  5       3  4       3  3       3  2       3         3       2  8
 + 29*x *y  - 14*x *y  - 35*x *y  - 77*x *y  + 21*x *y + 43*x  - 73*x *y

       2  7       2  6       2  5       2  4       2  3       2  2       2
 - 55*x *y  + 27*x *y  - 41*x *y  + 45*x *y  - 25*x *y  + 46*x *y  - 95*x *y

       2         9         8         7         6         5         4         3
 + 71*x  - 70*x*y  - 50*x*y  + 93*x*y  + 77*x*y  + 98*x*y  - 72*x*y  - 84*x*y

         2                       10       9       8       7       6    5       4
 - 39*x*y  - 86*x*y - 22*x - 66*y   + 31*y  - 58*y  + 60*y  - 65*y  - y  - 71*y

       3       2
 + 49*y  + 91*y  - 34*y + 49

randpoly({x,y}, dense, degree=10, ord=5);


    10       9         9       8  2       8      8       7  3       7  2       7
55*x   - 23*x *y - 33*x  - 22*x *y  - 94*x *y + x  + 14*x *y  + 85*x *y  - 60*x

       6  4      6  3       6  2       6         6       5  5       5  4
 + 60*x *y  + 9*x *y  - 27*x *y  + 44*x *y + 43*x  + 75*x *y  + 10*x *y

       5  3       5  2       5         5       4  6       4  5       4  4
 + 30*x *y  - 48*x *y  + 63*x *y - 65*x  - 60*x *y  - 75*x *y  - 39*x *y

       4  3       4  2       4         3  7       3  6       3  5       3  4
 + 34*x *y  - 52*x *y  - 41*x *y + 86*x *y  - 65*x *y  - 44*x *y  + 40*x *y

       3  3       3  2       2  8       2  7       2  6       2  5       2  4
 + 67*x *y  - 84*x *y  + 45*x *y  - 36*x *y  + 32*x *y  - 85*x *y  - 53*x *y

      2  3         9         7         6         5       10       9       8
 + 7*x *y  - 10*x*y  + 19*x*y  + 22*x*y  + 32*x*y  - 38*y   - 24*y  - 93*y

       7       6       5
 + 25*y  + 53*y  + 83*y

% Sparse:
randpoly({x,y}, deg=10, ord=5);


       8         7  2    3  4      3  3       2  8      9
 - 68*x *y - 31*x *y  + x *y  + 8*x *y  + 72*x *y  - 3*y

% Dense again:
randpoly({x,y}, terms=1000, maxdeg=10, mindeg=5);


    10       9         9       8  2       8         8       7  3       7  2
41*x   + 31*x *y + 59*x  - 83*x *y  - 30*x *y + 21*x  + 82*x *y  + 74*x *y

       7         7       6  4       6  3      6  2       6         6       5  5
 - 21*x *y - 74*x  - 80*x *y  + 61*x *y  + 4*x *y  - 81*x *y + 14*x  - 91*x *y

       5  4       5  3       5  2       5         5       4  5       4  4
 + 61*x *y  - 61*x *y  + 21*x *y  - 60*x *y + 26*x  + 73*x *y  - 41*x *y

       4  3    4  2       4         3  7       3  6       3  5       3  4
 + 26*x *y  - x *y  - 28*x *y + 42*x *y  + 20*x *y  - 50*x *y  - 41*x *y

       3  3       3  2       2  8       2  7       2  6       2  5       2  4
 + 91*x *y  - 39*x *y  - 36*x *y  - 24*x *y  + 85*x *y  + 39*x *y  - 48*x *y

      2  3         9         8         7         6         5         4       10
 + 3*x *y  - 50*x*y  + 87*x*y  - 78*x*y  + 64*x*y  - 87*x*y  - 65*x*y  - 52*y

       9       8       7      6       5
 - 30*y  - 88*y  + 24*y  + 7*y  - 54*y


% Exponent and coefficient functions:
% ----------------------------------
randpoly({x,y}, expons = rand(-10 .. 10));


       4  -7                -1         -2      -4  3       -4  -5
 - 70*x *y   - 61*x*y - 87*x  *y + 26*x   + 9*x  *y  + 16*x  *y

% Trivial example:
randpoly({x,y}, expons = proc 5);


    5  5
69*x *y

randpoly({x,y}, expons = proc(2*random(0 .. 5)));


    10  10       6  6       6  4        4  10       4
21*x  *y   + 77*x *y  + 50*x *y  + 123*x *y   + 73*x


randpoly({x,y}, coeffs = rand(-999 .. 999));


    3          2          2          4         2        3
58*x *y - 723*x *y + 113*x  - 200*x*y  + 61*x*y  + 311*y

procedure coe; randpoly(a, terms=2)$


randpoly({x,y}, coeffs = coe);


    4  3  2       4  3         4  2         4    2       4  5       4  4
97*a *x *y  + 97*a *x *y + 97*a *x *y + 97*a *x*y  + 97*a *y  + 97*a *y

       2  3  2       2  3         2  2         2    2       2  5       2  4
 - 85*a *x *y  - 85*a *x *y - 85*a *x *y - 85*a *x*y  - 85*a *y  - 85*a *y

randpoly({x,y}, coeffs = coe, degree = 10);


       5  6  2       5  5  5       5  5  2       5  4  6       5  4       5  6
 - 44*a *x *y  - 44*a *x *y  - 44*a *x *y  - 44*a *x *y  - 44*a *x  - 44*a *y

       3  6  2       3  5  5       3  5  2       3  4  6       3  4       3  6
 + 33*a *x *y  + 33*a *x *y  + 33*a *x *y  + 33*a *x *y  + 33*a *x  + 33*a *y


% Polynomials composed with general expressions:
% ---------------------------------------------
randpoly({x,y^2});


    4  2       4       2  6         4         2       2
43*x *y  - 45*x  + 83*x *y  - 24*x*y  + 73*x*y  + 36*y

randpoly(x^2 - y^2);


       10        8  2       8        6  4        6  2       6        4  6
 - 44*x   + 220*x *y  + 92*x  - 440*x *y  - 368*x *y  - 48*x  + 440*x *y

        4  4        4  2       4        2  8        2  6        2  4       2  2
 + 552*x *y  + 144*x *y  + 42*x  - 220*x *y  - 368*x *y  - 144*x *y  - 84*x *y

       2       10       8       6       4       2
 + 52*x  + 44*y   + 92*y  + 48*y  + 42*y  - 52*y  + 30

% This should give the constant term:
sub(x=y, ws);


30

randpoly({x^2 - a^2, y - b});


    6         6        4  2        4    2      4            4  2        4  2
63*a *b - 63*a *y + 4*a *b  - 189*a *b*x  - 8*a *b*y + 189*a *x *y + 4*a *y

       4       2  4        2  3        2  2  2        2  2  2        2    4
 + 50*a  + 48*a *b  - 192*a *b *y - 8*a *b *x  + 288*a *b *y  + 189*a *b*x

       2    2          2    3       2          2  4        2  2  2        2  2
 + 16*a *b*x *y - 192*a *b*y  + 59*a *b - 189*a *x *y - 8*a *x *y  - 100*a *x

       2  4       2         4  2        3  2         3      2  4        2  2  2
 + 48*a *y  - 59*a *y - 48*b *x  + 192*b *x *y - 42*b  + 4*b *x  - 288*b *x *y

        2           6        4            2  3         2          2       6
 + 126*b *y - 63*b*x  - 8*b*x *y + 192*b*x *y  - 59*b*x  - 126*b*y  + 63*x *y

      4  2       4       2  4       2         3
 + 4*x *y  + 50*x  - 48*x *y  + 59*x *y + 42*y

% This should give the constant term:
sub(x=a, y=b, ws);


0


% Polynomials with specified zeros:
% --------------------------------
randpoly(x = a);


    5        4         4        3  2       3         3        2  3       2  2
32*a  - 160*a *x - 12*a  + 320*a *x  + 48*a *x - 31*a  - 320*a *x  - 72*a *x

       2         2          4         3         2                        5
 + 93*a *x + 87*a  + 160*a*x  + 48*a*x  - 93*a*x  - 174*a*x - 31*a - 32*x

       4       3       2
 - 12*x  + 31*x  + 87*x  + 31*x

% This should give 0:
sub(x=a, ws);


0

randpoly({x = a, y = b});


       3  2       3           3  2       3       2  3       2  2          2  2
 - 24*a *b  + 48*a *b*y - 24*a *y  - 26*a  + 92*a *b  + 72*a *b *x - 276*a *b *y

        2              2    2       2    2       2         2  3       2      4
 - 144*a *b*x*y + 276*a *b*y  + 72*a *x*y  + 78*a *x - 92*a *y  - 43*a  - a*b

          3          3           2  2          2            2  2            2
 - 184*a*b *x + 4*a*b *y - 72*a*b *x  + 552*a*b *x*y - 6*a*b *y  + 144*a*b*x *y

              2          3         2  2         2            3               4
 - 552*a*b*x*y  + 4*a*b*y  - 72*a*x *y  - 78*a*x  + 184*a*x*y  + 86*a*x - a*y

           4         3  2      3           2  3        2  2        2    2
 + 24*a + b *x + 92*b *x  - 4*b *x*y + 24*b *x  - 276*b *x *y + 6*b *x*y

         3            2  2          3       3  2       3       2  3       2
 - 48*b*x *y + 276*b*x *y  - 4*b*x*y  + 24*x *y  + 26*x  - 92*x *y  - 43*x

      4
 + x*y  - 24*x

% This should give 0:
sub(x=a, y=b, ws);


0


% Invalid input detection:
% -----------------------
randpoly({x,y}, degree=foo);


***** degree=foo invalid as optional randpoly argument

randpoly({x,y}, foo);


***** foo invalid as optional randpoly argument

randpoly({x,y}, degree=-5);


***** degree=-5 invalid as optional randpoly argument


on allfac;

  off div, errcont;



end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 11 3)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/dfpart.rlg0000644000175000017500000003033411527635055023444 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
depend y,x;


generic_function f(x,y);


df(f(),x);


df(y,x)*f (x,y) + f (x,y)
         y         x

df(f(x,y),x);


df(y,x)*f (x,y) + f (x,y)
         y         x

df(f(x,x**3),x);


      3            3   2
f (x,x ) + 3*f (x,x )*x
 x            y

df(f(x,z**3),x);


      3
f (x,z )
 x

df(a*f(x,y),x);


a*(df(y,x)*f (x,y) + f (x,y))
            y         x

dfp(a*f(x,y),x);


f (x,y)*a
 x

df(f(x,y),x,2);


                           2
df(y,x,2)*f (x,y) + df(y,x) *f  (x,y) + df(y,x)*f  (x,y) + df(y,x)*f  (x,y)
           y                  yy                 xy                 yx

 + f  (x,y)
    xx

df(dfp(f(x,y),x),x);


df(y,x)*f  (x,y) + f  (x,y)
         xy         xx

df(dfp(f(x,x**3),x),x);


       3             3   2
f  (x,x ) + 3*f  (x,x )*x
 xx            xy


% using a generic fucntion with commutative derivatives
generic_function u(x,y);


dfp_commute u(x,y);


df(u(x,y),x,x);


                           2
df(y,x,2)*u (x,y) + df(y,x) *u  (x,y) + 2*df(y,x)*u  (x,y) + u  (x,y)
           y                  yy                   xy         xx


% explicitly declare 1st and second derivative commutative
generic_function v(x,y);


let dfp(v(~a,~b),{y,x}) => dfp(v(a,b),{x,y});


df(v(),x,2);


                           2
df(y,x,2)*v (x,y) + df(y,x) *v  (x,y) + 2*df(y,x)*v  (x,y) + v  (x,y)
           y                  yy                   xy         xx


% substitute expressions for the arguments
w:=df(f(),x,2);


                                2
w := df(y,x,2)*f (x,y) + df(y,x) *f  (x,y) + df(y,x)*f  (x,y) + df(y,x)*f  (x,y)
                y                  yy                 xy                 yx

      + f  (x,y)
         xx

sub(x=0,y=x,w);


f  (0,x) + f  (0,x) + f  (0,x) + f  (0,x)
 xx         xy         yx         yy


% composite generic functions
generic_function g(x,y);


generic_function h(y,z);


depend z,x;


w:=df(g()*h(),x);


w := 

df(y,x)*g (x,y)*h() + df(y,x)*h (y,z)*g() + df(z,x)*h (y,z)*g() + g (x,y)*h()
         y                     y                     z             x

sub(y=0,w);


df(z,x)*h (0,z)*g(x,0) + g (x,0)*h(0,z)
         z                x

% substituting g*h for f in a partial derivative of f,
% inheriting the arguments of f. Here no derivative of h
% appears because h does not depend of x.
sub(f=g*h,dfp(f(a,b),x));


g (a,b)*h(b,z)
 x


% indexes.

% in the following total differential the partial
% derivatives wrt i and j do not appear because i and
% j do not depend of x.

generic_function m(i,j,x,y);


df(m(i,j,x,y),x);


df(y,x)*m (i,j,x,y) + m (i,j,x,y)
         y             x


% computation with a differential equation.

generic_function f(x,y);


operator y;


let df(y(~x),x) => f(x,y(x));



% some derivatives

df(y(x),x);


f(x,y(x))

df(y(x),x,2);


f (x,y(x)) + f (x,y(x))*f(x,y(x))
 x            y

df(y(x),x,3);


f  (x,y(x)) + f  (x,y(x))*f(x,y(x)) + f (x,y(x))*f (x,y(x))
 xx            xy                      x          y

                                                2             2
 + f  (x,y(x))*f(x,y(x)) + f  (x,y(x))*f(x,y(x))  + f (x,y(x)) *f(x,y(x))
    yx                      yy                       y

sub(x=22,ws);


f  (22,y(22)) + f  (22,y(22))*f(22,y(22)) + f (22,y(22))*f (22,y(22))
 xx              xy                          x            y

                                                        2
 + f  (22,y(22))*f(22,y(22)) + f  (22,y(22))*f(22,y(22))
    yx                          yy

               2
 + f (22,y(22)) *f(22,y(22))
    y


% taylor expansion for y

load_package taylor;


taylor(y(x0+h),h,0,3);


                         f (x0,y(x0)) + f (x0,y(x0))*f(x0,y(x0))
                          x              y                         2
y(x0) + f(x0,y(x0))*h + -----------------------------------------*h  + (
                                            2

   f  (x0,y(x0)) + f  (x0,y(x0))*f(x0,y(x0)) + f (x0,y(x0))*f (x0,y(x0))
    xx              xy                          x            y

                                                           2
    + f  (x0,y(x0))*f(x0,y(x0)) + f  (x0,y(x0))*f(x0,y(x0))
       yx                          yy

                  2                 3      4
    + f (x0,y(x0)) *f(x0,y(x0)))/6*h  + O(h )
       y


clear w;



%------------------------ Runge Kutta -------------------------
% computing Runge Kutta formulas for ODE systems Y'=F(x,y(x));
% forms corresponding to Ralston Rabinowitz

load_package taylor;


operator alpha,beta,w,k;



% s= order of Runge Kutta formula

s:=3;


s := 3
  

generic_function f(x,y);


operator y;


*** y already defined as operator 


% introduce ODE

let df(y(~x),x)=>f(x,y(x));

 

% formal series for solution

y1_form := taylor(y(x0+h),h,0,s);


                                    f (x0,y(x0)) + f (x0,y(x0))*f(x0,y(x0))
                                     x              y                         2
y1_form := y(x0) + f(x0,y(x0))*h + -----------------------------------------*h  
                                                       2

           + (f  (x0,y(x0)) + f  (x0,y(x0))*f(x0,y(x0))
               xx              xy

               + f (x0,y(x0))*f (x0,y(x0)) + f  (x0,y(x0))*f(x0,y(x0))
                  x            y              yx

                                          2               2                 3
               + f  (x0,y(x0))*f(x0,y(x0))  + f (x0,y(x0)) *f(x0,y(x0)))/6*h
                  yy                           y

                 4
            + O(h )


% Runge-Kutta Ansatz:

let alpha(1)=>0;



for i:=1:s do
   let k(i) => h*f(x0 + alpha(i)*h, 
                  y(x0) + for j:=1:(i-1) sum beta(i,j)*k(j));


y1_ansatz:= y(x0) + for i:=1:s sum w(i)*k(i);


y1_ansatz := f(alpha(3)*h + x0,

               beta(3,2)*f(alpha(2)*h + x0,beta(2,1)*f(x0,y(x0))*h + y(x0))*h

                + beta(3,1)*f(x0,y(x0))*h + y(x0))*w(3)*h

              + f(alpha(2)*h + x0,beta(2,1)*f(x0,y(x0))*h + y(x0))*w(2)*h

              + f(x0,y(x0))*w(1)*h + y(x0)


y1_ansatz := taylor(y1_ansatz,h,0,s);


y1_ansatz := y(x0) + f(x0,y(x0))*(w(3) + w(2) + w(1))*h + (

                alpha(3)*f (x0,y(x0))*w(3) + alpha(2)*f (x0,y(x0))*w(2)
                          x                            x

                 + beta(3,2)*f (x0,y(x0))*f(x0,y(x0))*w(3)
                              y

                 + beta(3,1)*f (x0,y(x0))*f(x0,y(x0))*w(3)
                              y

                                                             2
                 + beta(2,1)*f (x0,y(x0))*f(x0,y(x0))*w(2))*h  + (
                              y

                        2
                alpha(3) *f  (x0,y(x0))*w(3)
                           xx

                 + alpha(3)*beta(3,2)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                       xy

                 + alpha(3)*beta(3,2)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                       yx

                 + alpha(3)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                       xy

                 + alpha(3)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                       yx

                           2
                 + alpha(2) *f  (x0,y(x0))*w(2)
                              xx

                 + 2*alpha(2)*beta(3,2)*f (x0,y(x0))*f (x0,y(x0))*w(3)
                                         x            y

                 + alpha(2)*beta(2,1)*f  (x0,y(x0))*f(x0,y(x0))*w(2)
                                       xy

                 + alpha(2)*beta(2,1)*f  (x0,y(x0))*f(x0,y(x0))*w(2)
                                       yx

                            2                          2
                 + beta(3,2) *f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                               yy

                                                                  2
                 + 2*beta(3,2)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                                          yy

                                                     2
                 + 2*beta(3,2)*beta(2,1)*f (x0,y(x0)) *f(x0,y(x0))*w(3)
                                          y

                            2                          2
                 + beta(3,1) *f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                               yy

                            2                          2          3      4
                 + beta(2,1) *f  (x0,y(x0))*f(x0,y(x0)) *w(2))/2*h  + O(h )
                               yy


% compute y1_form - y1_ans and collect coeffients of powers of h

y1_diff := num(taylortostandard(y1_ansatz)-taylortostandard(y1_form))$


cl := coeff(y1_diff,h);


cl := {0,

       6*f(x0,y(x0))*(w(3) + w(2) + w(1) - 1),

       3*(2*alpha(3)*f (x0,y(x0))*w(3) + 2*alpha(2)*f (x0,y(x0))*w(2)
                      x                              x

           + 2*beta(3,2)*f (x0,y(x0))*f(x0,y(x0))*w(3)
                          y

           + 2*beta(3,1)*f (x0,y(x0))*f(x0,y(x0))*w(3)
                          y

           + 2*beta(2,1)*f (x0,y(x0))*f(x0,y(x0))*w(2) - f (x0,y(x0))
                          y                               x

           - f (x0,y(x0))*f(x0,y(x0))),
              y

                 2
       3*alpha(3) *f  (x0,y(x0))*w(3)
                    xx

        + 3*alpha(3)*beta(3,2)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                xy

        + 3*alpha(3)*beta(3,2)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                yx

        + 3*alpha(3)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                xy

        + 3*alpha(3)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0))*w(3)
                                yx

                    2
        + 3*alpha(2) *f  (x0,y(x0))*w(2)
                       xx

        + 6*alpha(2)*beta(3,2)*f (x0,y(x0))*f (x0,y(x0))*w(3)
                                x            y

        + 3*alpha(2)*beta(2,1)*f  (x0,y(x0))*f(x0,y(x0))*w(2)
                                xy

        + 3*alpha(2)*beta(2,1)*f  (x0,y(x0))*f(x0,y(x0))*w(2)
                                yx

                     2                          2
        + 3*beta(3,2) *f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                        yy

                                                         2
        + 6*beta(3,2)*beta(3,1)*f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                                 yy

                                            2
        + 6*beta(3,2)*beta(2,1)*f (x0,y(x0)) *f(x0,y(x0))*w(3)
                                 y

                     2                          2
        + 3*beta(3,1) *f  (x0,y(x0))*f(x0,y(x0)) *w(3)
                        yy

                     2                          2
        + 3*beta(2,1) *f  (x0,y(x0))*f(x0,y(x0)) *w(2) - f  (x0,y(x0))
                        yy                                xx

        - f  (x0,y(x0))*f(x0,y(x0)) - f (x0,y(x0))*f (x0,y(x0))
           xy                          x            y

                                                               2
        - f  (x0,y(x0))*f(x0,y(x0)) - f  (x0,y(x0))*f(x0,y(x0))
           yx                          yy

                      2
        - f (x0,y(x0)) *f(x0,y(x0))}
           y


% f_forms: forms of f and its derivatives which occur in cl

f_forms :=q := {f(x0,y(x0))}$


for i:=1:(s-1) do
  <>;


f_forms;


{f(x0,y(x0)),

 f (x0,y(x0)),
  x

 f (x0,y(x0)),
  y

 f  (x0,y(x0)),
  xx

 f  (x0,y(x0)),
  xy

 f  (x0,y(x0)),
  yx

 f  (x0,y(x0))}
  yy


% extract coefficients of the f_forms in cl

sys := cl$


for each fr in f_forms do
  sys:=for each c in sys join coeff(c,fr);


% and eliminate zeros
sys := for each c in sys join if c neq 0 then {c} else {};


sys := {6*(w(3) + w(2) + w(1) - 1),

        3*(2*alpha(3)*w(3) + 2*alpha(2)*w(2) - 1),

        3*(2*beta(3,2)*w(3) + 2*beta(3,1)*w(3) + 2*beta(2,1)*w(2) - 1),

                  2                  2
        3*alpha(3) *w(3) + 3*alpha(2) *w(2) - 1,

        6*alpha(2)*beta(3,2)*w(3) - 1,

        3*alpha(3)*beta(3,2)*w(3) + 3*alpha(3)*beta(3,1)*w(3)

         + 3*alpha(2)*beta(2,1)*w(2) - 1,

        3*alpha(3)*beta(3,2)*w(3) + 3*alpha(3)*beta(3,1)*w(3)

         + 3*alpha(2)*beta(2,1)*w(2) - 1,

        6*beta(3,2)*beta(2,1)*w(3) - 1,

                   2                                                2
        3*beta(3,2) *w(3) + 6*beta(3,2)*beta(3,1)*w(3) + 3*beta(3,1) *w(3)

                      2
         + 3*beta(2,1) *w(2) - 1}


end;


Time for test: 46 ms
@@@@@ Resources used: (0 0 16 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/limits.txt0000644000175000017500000000373211526203062023506 0ustar  giovannigiovanni
                         A REDUCE Limits Package

                            Stanley L. Kameny
                    E-mail: stan%valley.uucp@rand.org


LIMITS is a fast limit package for REDUCE for functions which are
continuous except for computable poles and singularities, based on some
earlier work by Ian Cohen and John P. Fitch.  The Truncated Power Series
package is used for non-critical points, at which the value of the
function is the constant term in the expansion around that point.
L'Hopital's rule is used in critical cases, with preprocessing of
 forms and reformatting of product forms in order to
be able to apply l'Hopital's rule.  A limited amount of bounded arithmetic
is also employed where applicable.


Normal entry points:

     LIMIT(EXPRN:algebraic, VAR:kernel, LIMPOINT:algebraic): algebraic

This is the standard way of calling limit, applying all of the methods.


Direction-dependent limits:

     LIMIT!+(EXPRN:algebraic, VAR:kernel, LIMPOINT:algebraic): algebraic

     LIMIT!-(EXPRN:algebraic, VAR:kernel, LIMPOINT:algebraic): algebraic


If the limit depends upon the direction of approach to the LIMPOINT, the
functions LIMIT!+ and LIMIT!- may be used.  They are defined by:

     LIMIT!+ (LIMIT!-) (EXP,VAR,LIMPOINT) ->
        LIMIT(EXP*,eps,0) EXP*=sub(VAR=VAR+(-)eps^2,EXP)


Calling functions provided mainly for diagnostic purposes:

     LIMIT0(EXPRN:algebraic, VAR:kernel, LIMPOINT:algebraic): algebraic

This function will use all parts of the limits package, but it does not
combine log terms before taking limits, so it may fail if there is a sum
of log terms which have a removable singularity in some of the terms.


     LIMIT1(EXPRN:algebraic, VAR:kernel, LIMPOINT:algebraic): algebraic

This function uses the TPS branch only, and will fail if the limpoint is
singular.


     LIMIT2(TOP:algebraic, BOT:algebraic, VAR:kernel, LIMPOINT:algebraic):
            algebraic

This function applies L'Hopital's rule to the quotient (TOP/BOT).
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/cedit.red0000644000175000017500000002031511526203062023224 0ustar  giovannigiovannimodule cedit; % REDUCE input string editor.

% Author: Anthony C. Hearn;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(cedit),'(util));

fluid '(!*mode rprifn!* rterfn!*);

global '(!$eol!$
         !*blanknotok!*
         !*eagain
         !*full
         crbuf!*
         crbuf1!*
         crbuflis!*
         esc!*
         inputbuflis!*
         statcounter);


%esc!* := intern ascii 125;   %this is system dependent and defines
                              %a terminator for strings.

symbolic procedure rplacw(u,v);
   if atom u or atom v then errach list('rplacw,u,v)
    else rplacd(rplaca(u,car v),cdr v);

symbolic procedure cedit n;
   begin scalar x,ochan;
      if null terminalp() then rederr "Edit must be from a terminal";
      ochan := wrs nil;
      if n eq 'fn then x := reversip crbuf!*
       else if null n
        then if null crbuflis!*
               then <>
              else x := cdar crbuflis!*
       else if (x := assoc(car n,crbuflis!*))
        then x := cedit0(cdr x,car n)
       else <>;
      crbuf!* := nil;
      x := for each j in x collect j;   %to make a copy.
      terpri();
      editp x;
      terpri();
      x := cedit1 x;
      wrs ochan;
      if x eq 'failed then nil else crbuf1!* := x
   end;

symbolic procedure cedit0(u,n);
   % Returns input string augmented by appropriate mode.
   begin scalar x;
      if not(x := assoc(n,inputbuflis!*)) or ((x := cadr x) eq !*mode)
        then return u
       else return append(explode x,append(cdr explode '! ,u))
   end;

symbolic procedure cedit1 u;
   begin scalar x,y,z;
      z := setpchar '!>;
      if not !*eagain
        then <>;
      while u and (car u eq !$eol!$) do u := cdr u;
      u := append(u,list '! );   %to avoid 'last char' problem.
      if !*full then editp u;
    top:
      x := u;   %current pointer position.
    a:
      y := readch();   %current command.
      if y eq '!P or y eq '!p then editp x
       else if y eq '!I or y eq '!i then editi x
       else if y eq '!C or y eq '!c then editc x
       else if y eq '!D or y eq '!d then editd x
       else if y eq '!F or y eq '!f then x := editf(x,nil)
       else if y eq '!E or y eq '!e
        then <>
       else if y eq '!Q or y eq '!q then <>
       else if y eq '!? then edith()
       else if y eq '!B or y eq '!b then go to top
       else if y eq '!K or y eq '!k then editf(x,t)
       else if y eq '!S or y eq '!s then x := edits x
       else if y eq '!  and not !*blanknotok!* or y eq '!X or y eq '!x
        then x := editn x
       else if y eq '!  and !*blanknotok!* then go to a
       else if y eq !$eol!$ then go to a
       else lprim!* list(y,"Invalid editor character");
      go to a
   end;

symbolic procedure editc x;
   if null cdr x then lprim!* "No more characters"
    else rplaca(x,readch());

symbolic procedure editd x;
   if null cdr x then lprim!* "No more characters"
    else rplacw(x,cadr x . cddr x);

symbolic procedure editf(x,bool);
   begin scalar y,z;
      y := cdr x;
      z := readch();
      if null y then return <>;
      while cdr y and not(z eq car y) do y := cdr y;
      return if null cdr y then <>
                else if bool then rplacw(x,car y . cdr y)
                else y
   end;

symbolic procedure edith;
   <   replace next character by ";
     prin2t "   D              delete next character";
     prin2t "   E              end editing and reread text";
     prin2t
    "   F   move pointer to next occurrence of ";
     prin2t
       "   I   insert  in front of pointer";
     prin2t "   K   delete all chars until ";
     prin2t "   P              print string from current pointer";
     prin2t "   Q              give up with error exit";
     prin2t
       "   S search for first occurrence of ";
     prin2t "                      positioning pointer just before it";
     prin2t "    or X   move pointer right one character";
     terpri();
     prin2t
       "ALL COMMAND SEQUENCES SHOULD BE FOLLOWED BY A CARRIAGE RETURN";
     prin2t "    TO BECOME EFFECTIVE">>;

symbolic procedure editi x;
   begin scalar y,z;
      while (y := readch()) neq esc!* do z := y . z;
      rplacw(x,nconc(reversip z,car x . cdr x))
   end;

symbolic procedure editn x;
   if null cdr x then lprim!* "NO MORE CHARACTERS"
    else cdr x;

symbolic procedure editp u;
   <>;

symbolic procedure editp1 u;
   for each x in u do if x eq !$eol!$ then terpri() else prin2 x;

symbolic procedure edits u;
   begin scalar x,y,z;
      x := u;
      while (y := readch()) neq esc!* do z := y . z;
      z := reversip z;
  a:  if null x then return <>
       else if edmatch(z,x) then return x;
      x := cdr x;
      go to a
   end;

symbolic procedure edmatch(u,v);
   % Matches list of characters U against V. Returns rest of V if
   % match occurs or NIL otherwise.
   if null u then v
    else if null v then nil
    else if car u=car v then edmatch(cdr u,cdr v)
    else nil;

symbolic procedure lprim!* u; <>;

Comment Editing Function Definitions;

remprop('editdef,'stat);

symbolic procedure editdef u; editdef1 car u;

symbolic procedure editdef1 u;
   begin scalar type,x;
      if null(x := getd u) then return lprim list(u,"not defined")
       else if codep cdr x or not eqcar(cdr x,'lambda)
        then return lprim list(u,"cannot be edited");
      type := car x;
      x := cdr x;
      if type eq 'expr then x := 'de . u . cdr x
       else if type eq 'fexpr then x := 'df . u . cdr x
       else if type eq 'macro then x := 'dm . u . cdr x
       else rederr list("strange function type",type);
      rprifn!* := 'add2buf;
      rterfn!* := 'addter2buf;
      crbuf!* := nil;
      x := errorset!*(list('rprint,mkquote x),t);
      rprifn!* := nil;
      rterfn!* := nil;
      if errorp x then return (crbuf!* := nil);
      crbuf!* := cedit 'fn;
      return nil
   end;

symbolic procedure add2buf u; crbuf!* := u . crbuf!*;

symbolic procedure addter2buf; crbuf!* := !$eol!$ . crbuf!*;

put('editdef,'stat,'rlis);

Comment Displaying past input expressions;

put('display,'stat,'rlis);

symbolic procedure display u;
   % Displays input stack in reverse order.
   % Modification to reverse list added by F. Kako.
  begin scalar x,w;
      u := car u;
      x := crbuflis!*;
      terpri();
      if not numberp u then u := length x;
      while u>0 and x do
       <>;
      for each j in w do
       <>
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/sets.red0000644000175000017500000002540211526203062023114 0ustar  giovannigiovannimodule sets;  % Operators for basic set theory.

%% Author: F.J.Wright@Maths.QMW.ac.uk.
%% Date: 20 Feb 1994.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% WARNING: This module patches mk!*sq.

%% To do:
%% Improve symbolic set-Boolean analysis.
%% Rationalize the coding?

%% A nice illustration of fancy maths printing in the graphics mode
%% of PSL-REDUCE under MS-Windows and X, but it works properly only with
%% interface versions compiled from sources dated after 14 Feb 1994.

%% Defines the set-valued infix operators (with synonyms):
%%   union, intersection (intersect), setdiff (minus, \),
%% and the Boolean-valued infix operators:
%%   member, subset_eq, subset, set_eq.
%% Arguments may be algebraic-mode lists representing explicit sets,
%% or identifiers representing symbolic sets, or set-valued expressions.
%% Lists are converted to sets by deleting any duplicate elements, and
%% sets are sorted into a canonical ordering before being returned.
%% This can also be done explicitly by applying the unary operator
%% mkset.  The set-valued operators may remain symbolic, but
%% REDUCE does not currently support this concept for Boolean-valued
%% operators, and so neither does this package (although it could).
%% Set-theoretic simplifications are performed, but probably not fully.

%% A naive power set procedure is included as an algebraic example
%% in the test file (sets.tst).


%% A proposed new coding style:
deflist('((local scalar)), 'newnam);
%% (DEFLIST used because flagged eval -- PUT does not work during
%% faslout!)

%% One good reason not to use `\' in place of `!' ?
newtok '((!\) setdiff);
%% NOTE that this works in graphics mode under Windows or X PSL-REDUCE
%% ONLY with versions compiled from sources dated after 14 Feb 1994.
%% The following statement should really be in fmprint.red:
put('setdiff, 'fancy!-infix!-symbol, "\backslash");

%% A set is sorted before it is returned for purely cosmetic reasons,
%% except that together with duplicate elimination this makes the repre-
%% sentation canonical and so list equality can be used as set equality.

create!-package('(sets),'(contrib misc));

symbolic smacro procedure sort!-set l;
   sort(l, function set!-ordp);

symbolic procedure set!-ordp(u, v);
   %% Ordp alone (as used by ordn to implement symmetry) looks strange.
   %% This seems like a reasonable compromise.
   if numberp u and numberp v then u < v else ordp(u, v);


%% Set-valued operators:
%% ====================
infix union, intersection, setdiff;
put('intersect, 'newnam, 'intersection);
put('minus, 'newnam, 'setdiff);         % cf. Maple!
precedence setdiff, -;
precedence union, setdiff;
precedence intersection, union;

%% Must be simpfns for let rules to be applicable.
put('union, 'simpfn, 'simpunion);
put('intersection, 'simpfn, 'simpintersection);
put('setdiff, 'simpfn, 'simpsetdiff);

flag('(union intersection), 'nary);     % associativity
put('union, 'unary, 'union);            % for completeness
put('intersection, 'unary, 'intersection);
listargp union, intersection;           % necessary for unary case
%% Symmetry is normally implemented by simpiden, which is not
%% used here and the symmetry is implemented explicitly,
%% but the symmetric flag is also used when applying let rules.
flag('(union intersection), 'symmetric); % commutativity

%% Intersection distributes over union, which is implemented
%% as a rule list at the end of this file.

global '(empty_set);  symbolic(empty_set := '(list));

%% Below ordn sorts for symmetry as in simpiden for symmetric operators

symbolic procedure simpunion args;
   %% x union {} = x, union x = x
   !*kk2q(if car r eq 'union
      then if cdr(r := delete(empty_set, cdr r))
         then 'union . ordn r else car r
      else r)
   where r = applysetop('union, args);

symbolic procedure simpintersection args;
   %% x intersect {} = {}, intersection x = x
   !*kk2q(if car r eq 'intersection
      then if empty_set member(r := cdr r) then empty_set
         else if cdr r then 'intersection . ordn r else car r
      else r)
   where r = applysetop('intersection, args);

symbolic procedure simpsetdiff args;
   %% x setdiff x = {} setdiff x = {}, x setdiff {} = x.
   !*kk2q(if car r eq 'setdiff
      then if cadr r = caddr r or cadr r = empty_set then empty_set
         else if caddr r = empty_set then cadr r else r
      else r)
   where r = applysetop('setdiff, args);

%% The following mechanism allows unevaluated operators to remain
%% symbolic and supports n-ary union and intersection.

%% Allow set-valued expressions as sets:
flag('(union, intersection, setdiff), 'setvalued);

symbolic procedure applysetop(setop, args);
   %% Apply binary Lisp-level set functions to pairs of explicit
   %% set args and collect symbolic args:
   begin local set_arg, sym_args, setdiff_args;
      set_arg := 0;                    % cannot use nil as initial value
      setdiff_args := for each u in args collect
      %% reval form makes handling kernels and sorting easier:
         if eqcar(u := reval u, 'list) then
            << u := delete!-dups cdr u;
               set_arg := if set_arg = 0 then u
                  else apply2(setop, set_arg, u);
               make!-set u >>
         else if idp u or (pairp u and flagp(car u, 'setvalued)) then
            %% Implement idempotency for union and intersection:
            << if not(u member sym_args)
                 then sym_args := u . sym_args; u >>
         %% else typerr(if eqcar(u,'!*sq) then prepsq cadr u
         %%              else u,"set");
         else typerr(u, "set");         % u was reval'ed
      return if sym_args then
         setop . if setop eq 'setdiff then setdiff_args else
            if set_arg = 0 then sym_args
             else make!-set set_arg . sym_args
      else aeval make!-set set_arg      % aeval NEEDED for consistency
   end;

symbolic operator mkset;

symbolic procedure mkset rlist;
   %% Make a set from an algebraic-mode list:
   make!-set delete!-dups getrlist rlist;

%% The function list2set is already defined in PSL
%% to remove duplicates and PARTIALLY sort,
%% but it is not defined in the REDUCE sources.

symbolic procedure make!-set l;
   makelist sort!-set l;

symbolic procedure delete!-dups l;
   if l then
      if car l member cdr l then delete!-dups(cdr l)
      else car l . delete!-dups(cdr l);


%% Boolean-valued operators:
%% ========================
infix subset_eq, subset, set_eq;        % member already declared
precedence subset_eq, <;
precedence subset, subset_eq;
precedence set_eq, =;

put('member, 'boolfn, 'evalmember);
put('subset_eq, 'boolfn, 'evalsubset_eq);
put('subset, 'boolfn, 'evalsubset);
put('set_eq, 'boolfn, 'evalset_eq);

%% Boolfns get their arguments aeval'd automatically.

symbolic procedure evalmember(el, rlist);
   %% Special case -- only applicable to explicit lists.
   member(el, getrlist rlist);

symbolic procedure evalsubset_eq(u, v);
   (if atom r then r else apply(function equal, r) or evalsymsubset r)
      where r = evalsetbool('subset_eq, u, v);

put('subset_eq, 'setboolfn, function subsetp);

symbolic procedure evalsubset(u, v);
   (if atom r then r else evalsymsubset r)
      where r = evalsetbool('subset, u, v);

put('subset, 'setboolfn, function subsetneqp);

symbolic procedure subsetneqp(u, v);
   subsetp(u,v) and not subsetp(v,u);

symbolic procedure evalsymsubset args;
   %% This analysis assumes symbolic sets are non-empty, otherwise
   %% the relation may be equality rather than strict inclusion.
   %% Could or should this analysis be extended?
   ((eqcar(v, 'union) and u member cdr v) or
    (eqcar(u, 'intersection) and v member cdr u) or
    (eqcar(u, 'setdiff) and
       (cadr u = v or (eqcar(v, 'union) and cadr u member cdr v))))
      where u = car args, v = cadr args;

%% Set equality can use list equality provided the representation
%% is canonical (duplicate-free and ordered).  The following set
%% equality predicate is independent of set implementation,
%% and implements precisely the formal mathematical definition.

symbolic procedure evalset_eq(u, v);
   (if atom r then r else apply(function equal, r))
      where r = evalsetbool('set_eq, u, v);

put('set_eq, 'setboolfn, function setequal);

symbolic procedure setequal(u, v);
   subsetp(u,v) and subsetp(v,u);

symbolic procedure evalsetbool(setbool, u, v);
   begin local r, set_args, sym_args;
      r := for each el in {u, v} collect
         if eqcar(el, 'list) then
            << set_args := t;  cdr el >>
         %% reval form makes handling kernels easier:
         else if idp(el := reval el) or
               (pairp el and flagp(car el, 'setvalued)) then
            << sym_args := t;  el >>
         else typerr(el, "set");        % el was reval'ed
      return if set_args then
         if sym_args then               % RedErr
            msgpri("Cannot evaluate", {setbool, reval u, reval v},
               "as Boolean-valued set expression", nil, t)
         else apply(get(setbool,'setboolfn), r)
      else r
   end;


%% Boolean evaluation operator:
%% ===========================
%% Nothing to do with sets, but useful for testing Boolean operators:

symbolic operator evalb;                % cf. Maple
symbolic procedure evalb condition;
   if eval formbool(condition, nil, 'algebraic) then 'true else 'false;

flag('(evalb), 'noval);  % because evalb evals its argument itself

%% Note that this does not work - it generates the wrong code:
%% algebraic procedure evalb condition;
%%    if condition then true else false;


%% Set simplification rules:
%% ========================

algebraic;

set_distribution_rule := {~x intersection (~y union ~z) =>
   (x intersection y) union (x intersection z)};

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reacteqn.txt0000644000175000017500000001242311526203062024004 0ustar  giovannigiovanni 
      REDUCE Support for Reaction Equation Systems
 
                 Herbert Melenk
 
            Konrad-Zuse-Zentrum Berlin
 
                 January 1991
 


The REDUCE package REACTEQN allows one to transform chemical reaction 
systems into ordinary differential equation systems (ode) 
corresponding to the laws of pure mass action. 
 
A single reaction equation is an expression of the form
 
   +  +  ... ->  +  +  ...
                       or
   +  +  ... <>  +  +  ...
 
where the  are arbitrary names of species (REDUCE symbols)
and the  are positive integer numbers. The number 1
can be omitted. The connector -> describes a one way reaction,
while <> describes a forward and backward reaction.

A reaction system is a list of reaction equations, each of them
optionally followed by one or two expressions for the rate
constants. A rate constant can a number, a symbol or an 
arbitrary REDUCE expression. If a rate constant is missing,
an automatic constant of the form RATE(n) (where n is an
integer counter) is generated. For double reactions the
first constant is used for the forward direction, the second
one for the backward direction.
 
The names of the species are collected in a list bound to
the REDUCE variable SPECIES. This list is automatically filled
during the processing of a reaction system. The species enter
in an order corresponding to their appearance in the reaction
system and the resulting ode's will be ordered in the same manner. 
If a list of species is preassigned to the variable
SPECIES either explicitly or from previous operations, the 
given order will be maintained and will dominate the formatting
process. So the ordering of the result can be easily influenced
by the user.
 
Syntax:
    reac2ode {    [, [,]] 
               [, [, [,]]] 
                       .... 
                  };
 
        where two rates are applicable only for <> reactions.

        Result is a system of explicit ordinary differential
        equations with polynomial righthand sides. As side
        effect the following variables are set:

         lists:

           rates:  list of the rates in the system

           species: list of the species in the system

         matrices:
 
           inputmat: matrix of the input coefficients
 
           outputmat: matrix of the output coefficients
               
In the matrices the row number corresponds to the input reaction 
number, while the column number corresponds to the species index.

Note: if the rates are numerical values, it will be in most cases
      appropriate to select a REDUCE evaluation mode for floating
      point numbers. That is
        REDUCE 3.3: on float,numval;
        REDUCE 3.4: on rounded;
 
Inputmat and outputmat can be used for linear algebra type 
investigations of the reaction system. The classical reaction 
matrix is the difference of these matrices; however, the two 
matrices contain more information than their differences because 
the appearance of a species on both sides is not reflected by 
the reaction matrix.

EXAMPLES:

% Example taken from Feinberg (Chemical Engineering):

   species := {A1,A2,A3,A4,A5};

   reac2ode {  A1 + A4 <> 2A1,       rho, beta,
               A1 + A2 <> A3,        gamma, epsilon,
               A3      <> A2 + A5,   theta, mue};
 
        
                             2
{DF(A1,T)=RHO*A1*A4 - BETA*A1  - GAMMA*A1*A2 + EPSILON*A3,

 DF(A2,T)= - GAMMA*A1*A2 + EPSILON*A3 + THETA*A3 - MUE*A2*A5,

 DF(A3,T)=GAMMA*A1*A2 - EPSILON*A3 - THETA*A3 + MUE*A2*A5,

                                2
 DF(A4,T)= - RHO*A1*A4 + BETA*A1 ,

 DF(A5,T)=THETA*A3 - MUE*A2*A5}

% the corresponding matrices:

  inputmat;

[1  0  0  1  0]
[             ]
[1  1  0  0  0]
[             ]
[0  0  1  0  0]


  outputmat;

[2  0  0  0  0]
[             ]
[0  0  1  0  0]
[             ]
[0  1  0  0  1]


% computation of the classical reaction matrix as difference
% of output and input matrix:

  reactmat := outputmat-inputmat;

            [1   0   0   -1  0]
            [                 ]
REACTMAT := [-1  -1  1   0   0]
            [                 ]
            [0   1   -1  0   1]

% Example with automatic generation of rate constants
% and automatic extraction of species
 
   species := {};
   reac2ode {  A1 + A4 <> 2A1, 
               A1 + A2 <> A3,
               a3      <> A2 + A5};
 
new species: A1
new species: A4
new species: A3
new species: A2
new species: A5


               2
{DF(A1,T)= - A1 *RATE(2) + A1*A4*RATE(1) - A1*A2*RATE(3) + 

     A3*RATE(4),

            2
 DF(A4,T)=A1 *RATE(2) - A1*A4*RATE(1),

 DF(A2,T)= - A1*A2*RATE(3) - A2*A5*RATE(6) + A3*RATE(5) + A3*RATE(4),

 DF(A3,T)=A1*A2*RATE(3) + A2*A5*RATE(6) - A3*RATE(5) - A3*RATE(4),

 DF(A5,T)= - A2*A5*RATE(6) + A3*RATE(5)}


% Example with rates computed from numerical expressions
 
   species := {};
   reac2ode {  A1 + A4 <> 2A1, 17.3* 22.4^1.5,
                               0.04* 22.4^1.5 };
 
new species: A1
new species: A4

                       2
{DF(A1,T)= - 4.24065*A1  + 1834.08*A1*A4,

                    2
 DF(A4,T)=4.24065*A1  - 1834.08*A1*A4}

Herbert Melenk
Konrad-Zuse-Zentrum fuer Informationstechnik
Heilbronner Str 10
D 1000 Berlin 31
Germany

Phone: (49) 30 89604 195
FAX:   (49) 30 89604 125
E-mail:  melenk@zib.de

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rcref.red0000644000175000017500000005225111526203062023241 0ustar  giovannigiovannimodule rcref; % Cross reference program.

% Author: Martin L. Griss, with modifications by Anthony C. Hearn and
%            Winfried Neun.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Requires REDIO and SORT support.

create!-package('(rcref redio),'(util));

fluid '(!*backtrace !*cref !*defn !*mode !*nocrefpri calls!* curfun!*
        dfprint!* globs!* locls!* toplv!*);

global '(undefg!* gseen!* btime!* expand!* haveargs!* notuse!* nolist!*
        dclglb!* entpts!* undefns!* seen!* tseen!* xseen!* op!*!* cloc!*
        pfiles!* curlin!* pretitl!* !*creftime !*saveprops maxarg!*
        !*crefsummary !*comp !*raise !*rlisp !*globals !*algebraics);

switch cref;

!*algebraics:='t; % Default is normal parse of algebraic.
!*globals:='t;  % Do analyze globals.
% !*rlisp:=nil;   % REDUCE as default.
maxarg!*:=15;   % Maximum args in Standard Lisp.


deflist('((anlfn procstat) (crflapo procstat)),'stat);

flag('(anlfn crflapo),'compile);

flag('(bldmsg printf),'naryargs);  % Added by Eberhard Schruefer.

comment  EXPAND flag on these forces expansion of MACROS;

expand!* := '(for foreach repeat while);

nolist!* := nconc(for each j in slfns!* collect car j,nolist!*);

nolist!* := append('(and cond endmodule lambda list max min module or
                     plus prog prog2 progn putc switch times),
                   nolist!*);

flag ('(plus times and or lambda progn max min cond prog case list),
       'naryargs);

dclglb!*:='(!*comp emsg!* !*raise);

if not getd 'begin then
  flag('(rds deflist flag fluid global remprop remflag unfluid
           setq crefoff),'eval);

symbolic procedure crefon;
  begin btime!*:=time();
        dfprint!* := 'refprint;
        !*defn := t;
        if not !*algebraics then put('algebraic,'newnam,'symbolic);
        flag(nolist!*,'nolist);
        flag(expand!*,'expand);
        flag(dclglb!*,'dclglb);
%  Global lists.
        entpts!*:=nil;  % Entry points to package.
        undefns!*:=nil; % Functions undefined in package.
        seen!*:=nil;    % List of all encountered functions.
        tseen!*:=nil;   % List of all encountered types not flagged
                        % FUNCTION.
        gseen!*:=nil;   % All encountered globals.
        pfiles!*:=nil;  % Processed files.
        undefg!*:=nil;  % Undeclared globals encountered.
        curlin!*:=nil;  % Position in file(s) of current command.
        pretitl!*:=nil; % T if error or questionables found.
% Usages in specific function under analysis.
        globs!*:=nil;   % Globals refered to in this.
        calls!*:=nil;   % Functions called by this.
        locls!*:=nil;   % Defined local variables in this.
        toplv!*:=t;     % NIL if inside function body.
        curfun!*:=nil;  % Current function beeing analyzed.
        op!*!*:=nil;    % Current op. in LAP code.
        if not !*nocrefpri
          then setpage("  Errors or questionables",nil);
        if not getd 'begin then crefonlsp()   % In Lisp.
   end;

symbolic procedure undefdchk fn;
 if not flagp(fn,'defd) then undefns!* := fn . undefns!*;

symbolic procedure princng u;
   princn getes u;

symbolic procedure crefoff;
   % Main call, sets up, alphabetizes and prints.
   begin scalar tim,x;
        crefoff1();
        tim:=time()-btime!*;
        setpage("  Summary",nil);
        newpage();
        pfiles!*:=punused("Crossreference listing for files:",
                          for each z in pfiles!* collect cdr z);
        entpts!*:=punused("Entry Points:",entpts!*);
        undefns!*:=punused("Undefined Functions:",undefns!*);
        undefg!*:=punused("Undeclared Global Variables:",undefg!*);
        gseen!*:=punused("Global variables:",gseen!*);
        seen!*:=punused("Functions:",seen!*);
        for each z in tseen!* do
          <> >>;
        if !*crefsummary then goto xy;
        if !*globals and gseen!* then
              <>;
        if seen!* then cref52("  Function Usage",seen!*);
        for each z in tseen!* do
           cref52(list("  ",car z," procedures"),cdr z);
        setpage("  Toplevel calls:",nil);
        x:=t;
        for each z in pfiles!* do
         if get(z,'calls) or get(z,'globs) then
           <>;
             newline 0; newline 0; princng z;
             spaces!-to 15; underline2 (linelength(nil)-10);
             cref51(z,'calls,"Calls:");
             if !*globals then cref51(z,'globs,"Globals:")>>;
  xy:   if !*saveprops then goto xx;
        rempropss(seen!*,'(gall calls globs calledby alsois sameas));
        remflagss(seen!*,'(seen cinthis defd));
        rempropss(gseen!*,'(usedby usedunby boundby setby));
        remflagss(gseen!*,'(dclglb gseen glb2rf glb2bd glb2st));
        for each z in tseen!* do remprop(car z,'funs);
%       for each z in haveargs!* do remprop(z,'number!-of!-args);
        haveargs!* := gseen!* := seen!* := tseen!* := nil;
  xx:   newline 2;
        if not !*creftime then return;
        btime!*:=time()-btime!*;
        setpage(" Timing Information",nil);
        newpage(); newline 0;
        prtatm " Total Time="; prtnum btime!*;
        prtatm " (ms)";
        newline 0;
        prtatm " Analysis Time="; prtnum tim;
        newline 0;
        prtatm " Sorting Time="; prtnum (btime!*-tim);
        newline 0; newline 0
  end;

symbolic procedure crefoff1;
   begin scalar x;
        dfprint!* := nil;
        !*defn := nil;
        if not !*algebraics
          then remprop('algebraic,'newnam);     % Back to normal.
         for each fn in seen!* do
         <>;
        tseen!*:=for each z in idsort tseen!* collect
         <>;
           z.x>>;
        for each z in gseen!* do
         if get(z,'usedunby) then undefg!*:=z . undefg!*;
   end;

symbolic procedure punused(x,y);
 if y then
  <>;

symbolic procedure cref52(x,y);
 <>;

symbolic procedure cref5 fn;
   % Print single entry.
   begin scalar x,y;
        newline 0; newline 0;
        prin1 fn; spaces!-to 15;
        y:=get(fn,'gall);
        if y then <>
         else prin2 "Undefined";
        spaces!-to 25;
        if flagp(fn,'naryargs) then prin2 "  Nary Args  "
         else if (y:=get(fn,'number!-of!-args)) then
          <>;
        underline2 (linelength(nil)-10);
        if x then
          <>;
        cref51(fn,'calledby,"Called by:");
        cref51(fn,'calls,"Calls:");
        cref51(fn,'alsois,"Is also:");
        cref51(fn,'sameas,"Same as:");
        if !*globals then cref51(fn,'globs,"Globals:")
   end;

symbolic procedure cref51(x,y,z);
 if (x:=get(x,y)) then <>;

symbolic procedure cref6 glb;
   % Print single global usage entry.
      <>;

symbolic procedure cref61(x,y,z);
   if (x:=get(x,y)) then
     <>;

% Analyze bodies of LISP functions for functions called, and globals
% used, undefined.

smacro procedure flag1(u,v); flag(list u,v);

smacro procedure remflag1(u,v); remflag(list u,v);

smacro procedure isglob u;
 flagp(u,'dclglb);

smacro procedure chkseen s;
   % Has this name been encountered already?
        if not flagp(s,'seen) then
          <>;

smacro procedure globref u;
  if not flagp(u,'glb2rf)
   then <>;

smacro procedure anatom u;
   % Global seen before local..ie detect extended from this.
   if !*globals and u and not(u eq 't)
      and idp u and not assoc(u,locls!*)
     then globref u;

smacro procedure chkgseen g;
 if not flagp(g,'gseen) then <>;

symbolic procedure do!-global l;
  % Catch global defns.
  % Distinguish FLUID from GLOBAL later.
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <>;

put('global,'anlfn,'do!-global);

put('fluid,'anlfn,'do!-global);

symbolic anlfn procedure unfluid l;
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <>;

symbolic procedure add2locs ll;
  begin scalar oldloc;
   if !*globals then for each gg in ll do
      <>
         else locls!*:=(gg . list nil) . locls!*;
        if isglob(gg) or flagp(gg,'glb2rf) then globind gg;
        if flagp(gg,'seen) then
          <> >>
  end;

symbolic procedure qerline u;
   if !*nocrefpri then nil
    else if pretitl!* then newline u
    else <>;

symbolic procedure globind gg;
  <>;

symbolic procedure remlocs lln;
   begin scalar oldloc;
    if !*globals then for each ll in lln do
      <>
   end;

symbolic procedure efface1(u,v);
 if null v then nil
  else if u eq car v then cdr v
  else rplacd(v,efface1(u,cdr v));

symbolic procedure add2calls fn;
   % Update local CALLS!*.
   not flagp(fn,'cinthis) and
      <>;

symbolic procedure anform u;
   if atom u then anatom u else anform1 u;

symbolic procedure anforml l;
   begin
        while not atom l do <>;
        if l then anatom l
   end;

symbolic procedure anform1 u;
   begin scalar fn,x;
        fn:=car u; u:=cdr u;
        if not atom fn then return <>;
        if not idp fn then return nil
         else if isglob fn then <>
         else if assoc(fn,locls!*) then return anforml u;
        add2calls fn;
        checkargcount(fn,length u);
        if flagp(fn,'noanl) then nil
         else if x:=get(fn,'anlfn) then apply1(x,u)
         else anforml u
   end;

symbolic anlfn procedure lambda u;
 <>;

symbolic procedure anlsetq u;
 <>;

put('setq,'anlfn,'anlsetq);

symbolic anlfn procedure cond u;
 for each x in u do anforml x;

symbolic anlfn procedure prog u;
 <>;

symbolic anlfn procedure function u;
 if pairp(u:=car u) then anform1 u
  else if isglob u then globref u
  else if null assoc(u,locls!*) then add2calls u;

flag('(quote go),'noanl);

symbolic anlfn procedure errorset u;
 begin scalar fn,x;
  anforml cdr u;
  if eqcar(u:=car u,'quote) then return ersanform cadr u
   else if not((eqcar(u,'cons) or (x:=eqcar(u,'list)))
               and quotp(fn:=cadr u))
    then return anform u;
  anforml cddr u;
  if pairp(fn:=cadr fn) then anform1 fn
   else if flagp(fn,'glb2rf) then nil
   else if isglob fn then globref fn
   else <>
 end;

symbolic procedure ersanform u;
 begin scalar locls!*;
  return anform u
 end;

symbolic procedure anlmap u;
 <>;

for each x in '(map mapc maplist mapcar mapcon mapcan) do
 put(x,'anlfn,'anlmap);

symbolic anlfn procedure lispapply u;
 begin scalar fn;
  anforml cdr u;
  if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list)
    then checkargcount(fn,length cdr u)
 end;

symbolic anlfn procedure apply u;
 begin scalar fn;
  anforml cdr u;
  if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list)
    then checkargcount(fn,length cdr u)
 end;

symbolic procedure quotp u; eqcar(u,'quote) or eqcar(u,'function);

put('cref ,'simpfg ,'((t (crefon)) (nil (crefoff))));

symbolic procedure outref(s,varlis,body,type);
 begin scalar curfun!*,calls!*,globs!*,locls!*,toplv!*,a;
  a:=if varlis memq '(anp!!atom anp!!idb anp!!eq anp!!unknown)
       then nil
      else length varlis;
  s := outrdefun(s,type,if a then a else get(body,'number!-of!-args));
  if a then <>
   else if null body or not idp body then nil
   else if varlis eq 'anp!!eq
    then <>
   else add2calls body;
  outrefend s
 end;

symbolic procedure traput(u,v,w);
 begin scalar a;
  if a:=get(u,v) then
    (if not(toplv!* or w memq a) then rplacd(a,w . cdr a))
   else put(u,v,list w)
 end;

smacro procedure toput(u,v,w);
 if w then put(u,v,if toplv!* then union(w,get(u,v)) else w);

symbolic procedure outrefend s;
  <> >>;
    toput(s,'globs,globs!*);
    for each x in globs!* do
        <>,s);
          remflag1(x,'glb2rf);
          if flagp(x,'glb2bd)
            then <>;
          if flagp(x,'glb2st)
            then <> >> >>;

symbolic procedure recref(s,type);
          <>;

symbolic procedure outrdefun(s,type,v);
  begin
    s:=qtypnm(s,type);
    if flagp(s,'defd) then recref(s,type)
     else flag1(s,'defd);
    if flagp(type,'function) and (isglob s or assoc(s,locls!*)) then
      <>;
    if v and not flagp(type,'naryarg) then defineargs(s,v)
     else if flagp(type,'naryarg) and not flagp(s,'naryargs)
      then flag1(s,'naryargs);
    put(s,'gall,curlin!* . type);
    globs!*:=nil;
    calls!*:=nil;
    return curfun!*:=s
  end;

flag('(macro fexpr),'naryarg);

symbolic procedure qtypnm(s,type);
 if flagp(type,'function) then <>
  else begin scalar x,y,z;
        if (y:=get(type,'tseen)) and (x:=atsoc(s,cdr y))
          then return cdr x;
        if null y then
          <>;
        x := compress (z := explode s);
        rplacd(y,(s . x) . cdr y);
        y := append(car y,z);
        put(x,'rccnam,length y . y);
        traput(type,'funs,x);
        return x
       end;

symbolic procedure defineargs(name,n);
  begin scalar calledwith,x;
    calledwith:=get(name,'number!-of!-args);
    if null calledwith then return hasarg(name,n);
    if n=calledwith then return nil;
    if x := get(name,'calledby) then instdof(name,n,calledwith,x);
    hasarg(name,n)
  end;

symbolic procedure instdof(name,n,m,fnlst);
  <>;

symbolic procedure hasarg(name,n);
  <maxarg!* then
           <>;
    if name neq 'bldmsg then put(name,'number!-of!-args,n)>>;

symbolic procedure checkargcount(name,n);
  begin scalar correctn;
    if flagp(name,'naryargs) then return nil;
    correctn:=get(name,'number!-of!-args);
    if null correctn then return hasarg(name,n);
    if not(correctn=n) then instdof(name,correctn,n,list curfun!*)
  end;

symbolic procedure refprint u;
 begin scalar x,y;
% x:=if cloc!* then filemk car cloc!* else "*ttyinput*";
  x:=if cloc!* then car cloc!* else "*TTYINPUT*";
  if (curfun!*:=assoc(x,pfiles!*)) then
    <>
   else <>;
  curlin!*:=if cloc!* and cdr cloc!* then x . cdr cloc!* else nil;
  calls!*:=globs!*:=locls!*:=nil;
  anform u;
  outrefend curfun!*
 end;

symbolic procedure filemk u;
   % Convert a file specification from lisp format to a string.
   % This is essentially the inverse of MKFILE.
 begin scalar dev,name,flg,flg2;
  if null u then return nil
   else if atom u then name := explode2 u
   else for each x in u do
    if x eq 'dir!: then flg := t
     else if atom x then
      if flg then dev := '!< . nconc(explode2 x,list '!>)
       else if x eq 'dsk!: then dev:=nil
       else if !%devp x then dev := explode2 x
       else name := explode2 x
     else if atom cdr x then
      name := nconc(explode2 car x,'!. . explode2 cdr x)
     else <>;
  u := if flg2 then nconc(name,dev)
        else nconc(dev,name);
  return compress('!" . nconc(u,'(!")))
 end;

flag('(smacro nmacro),'cref);

symbolic anlfn procedure put u;
 if toplv!* and qcputx cadr u then anputx u
  else anforml u;

put('putc,'anlfn,get('put,'anlfn));

symbolic procedure qcputx u;
 eqcar(u,'quote) and (flagp(cadr u,'cref) or flagp(cadr u,'compile));

symbolic procedure anputx u;
 begin scalar nam,typ,body;
  nam:=qcrf car u;
  typ:=qcrf cadr u;
  u:=caddr u;
  if atom u then <>
     else if idp u then <>
   else <>;

flag('(expr fexpr macro smacro nmacro),'function);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/changevr.rlg0000644000175000017500000001425311527635055023763 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
%*********************************************************************;
%         This is a test file    for  the  CHANGEVAR package.         ;
%         Make sure that before you attempt to run it the             ;
%         MATRIX package and CHANGEVAR is loaded.                     ;
%*********************************************************************;
algebraic;


%*********************************************************************;
% ON DISPJACOBIAN;   % To get the Jacobians printed, remove the...    ;
%                      ... percentage sign before the word ON         ;
%*********************************************************************;
%                                                                     ;
%               *** First test problem ***                            ;
%                                                                     ;
% Here are two  Euler type of differential equations,                 ;
%                                                                     ;
%         3             2                                             ;
%      2 x  y'''  +  3 x  y''  -  y  =  0                             ;
%                                                                     ;
%                                                                     ;
%          2                                                          ;
%      5 x  y''  -   x y' + 7 y  =  0                                 ;
%                                                                     ;
%                                                                     ;
% An Euler equation can be converted into a (linear) equation with    ;
% constant coefficients by making change of independent variable:     ;
%                                                                     ;
%                         u                                           ;
%                    x = e                                            ;
%                                                                     ;
% The  resulting equations will be                                    ;
%                                                                     ;
%                                                                     ;
%      2 y'''  -  3 y''  +  y' -  y  =  0                             ;
%                                                                     ;
% and                                                                 ;
%                                                                     ;
%      5  y''  -  6 y' + 7 y  =  0                                    ;
%                                                                     ;
%                                                                     ;
% Where, now (prime) denotes differentiation with respect to the new  ;
% independent variable: u                                             ;
% How this change of variable is done using CHANGEVAR follows.        ;
%                                                                     ;
%*********************************************************************;

operator y;



changevar(y, u, x=e**u, { 2*x**3*df(y(x),x,3)+3*x**2*df(y(x),x,2)-y(x),
                          5*x**2*df(y(x),x,2)-x*df(y(x),x)+7*y(x) } ) ;


{2*df(y(u),u,3) - 3*df(y(u),u,2) + df(y(u),u) - y(u),

 5*df(y(u),u,2) - 6*df(y(u),u) + 7*y(u)}


%*********************************************************************;
%               *** Second test problem ***                           ;
%                                                                     ;
% Now, the problem is to obtain the polar coordinate form of Laplace's;
% equation:                                                           ;
%                                                                     ;
%          2              2                                           ;
%         d  u           d  u                                         ;
%        ------    +    ------    =    0                              ;
%            2              2                                         ;
%         d x            d y                                          ;
%                                                                     ;
% (The differentiations are partial)                                  ;
%                                                                     ;
% For polar coordinates the change of variables are :                 ;
%                                                                     ;
%        x = r cos(theta) ,    y = r sin(theta)                       ;
%                                                                     ;
% As known, the result is :                                           ;
%                                                                     ;
%                                                                     ;
%          2                                     2                    ;
%         d  u         1    d  u         1      d  u                  ;
%        ------   +   ---  ------   +   ---  ----------   =   0       ;
%            2         r    d r           2          2                ;
%         d r                            r    d theta                 ;
%                                                                     ;
% How this change of variable is done using CHANGEVAR follows.        ;
%                                                                     ;
%                              2       2                              ;
% (To get rid of the boring sin  + cos   terms we introduce a LET     ;
%  statement)                                                         ;
%                                                                     ;
%*********************************************************************;

operator u;



let sin theta**2 = 1 - cos theta**2 ;



changevar(u, { r , theta }, { x=r*cos theta, y=r*sin theta },
          df(u(x,y),x,2)+df(u(x,y),y,2) ) ;


                     2
 df(u(r,theta),r,2)*r  + df(u(r,theta),r)*r + df(u(r,theta),theta,2)
---------------------------------------------------------------------
                                  2
                                 r


end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 12 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rlfi.tex0000644000175000017500000002434011526203062023120 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{RLFI\\
       A \REDUCE{} \LaTeX{} Formula Interface\\
       Version 1.2.1}
\date{May 23, 1995}
\author{Richard Liska, Ladislav Drska\\
        Computational Physics Group\\
        Faculty of Nuclear Sciences and Physical Engineering\\
        Czech Technical University in Prague\\
        Brehova 7, 115 19 Prague 1, Czech Republic\\
        E-mail: liska@siduri.fjfi.cvut.cz}
\begin{document}
\maketitle

\vskip1.cm

High quality typesetting of mathematical formulas is a quite tedious
task.  One of the most sophisticated typesetting programs for
mathematical text \TeX{} \cite{Knuth:84}, together with its widely used
macro package \LaTeX{} \cite{Lamport:86}, has a strange syntax of
mathematical formulas, especially of the complicated type.  This is the
main reason which lead us to designing the formula interface between the
computer algebra system \REDUCE{} and the document preparation system
\LaTeX{}.  The other reason is that all available syntaxes of the
\REDUCE{} formula output are line oriented and thus not suitable for
typesetting in mathematical text.  The idea of interfacing a computer
algebra system to a typesetting program has already been used, eg.  in
\cite{Fateman:87} presenting the \TeX{} output of the MACSYMA computer
algebra system.

The formula interface presented here adds to \REDUCE{} the new syntax of
formula output, namely \LaTeX{} syntax, and can also be named \REDUCE{} -
\LaTeX{} translator.  Text generated by \REDUCE{} in this syntax can be
directly used in \LaTeX{} source documents.  Various mathematical
constructions are supported by the interface including subscripts,
superscripts, font changing, Greek letters, divide-bars, integral and
sum signs, derivatives etc.

The interface can be used in two ways:
\begin{itemize}
\item for typesetting of results of \REDUCE{} algebraic calculations.
\item for typesetting of users formulas.
\end{itemize}

The latter can even be used by users unfamiliar with the \REDUCE{}
system, because the \REDUCE{} input syntax of formulas is almost the
same as the syntax of the majority of programming languages.  We aimed
at speeding up the process of formula typesetting, because we are
convinced, that the writing of correct complicated formulas in the
\REDUCE{} syntax is a much more simpler task than writing them in the
\LaTeX{} syntax full of keywords and special characters \verb+ \, {, ^+
etc.  It is clear, that not every formula produced by the interface is
typeset in the best format from an aesthetic point of view.  When a user
is not satisfied with the result, he can add some \LaTeX{} commands to the
\REDUCE{} output - \LaTeX{} input.

The interface is connected to \REDUCE{} by three new switches and
several statements.  To activate the \LaTeX{} output mode the switch {\tt
latex} must be set {\tt on}.  this switch, similar to the switch {\tt
fort} producing FORTRAN output, being {\tt on} causes all outputs to be
written in the \LaTeX{} syntax of formulas.  The switch {\tt VERBATIM} is
used for input printing control.  If it is {\tt on} input to \REDUCE{} system
is typeset in \LaTeX{} verbatim environment after the line containing
the string {\tt REDUCE Input:}.

The switch {\tt lasimp} controls the algebraic evaluation of input
formulas.  If it is {\tt on} every formula is evaluated, simplified and
written in the form given by ordinary \REDUCE{} statements and switches
such as {\tt factor}, {\tt order}, {\tt rat} etc.  In the case when the
{\tt lasimp} switch is {\tt off} evaluation, simplification or
reordering of formulas is not performed and \REDUCE{} acts only as a
formula parser and the form of the formula output is exactly the same as
that of the input, the only difference remains in the syntax.  The mode
{\tt off lasimp} is designed especially for typesetting of formulas for
which the user needs preservation of their structure.  This switch has
no meaning if the switch {\tt Latex} is {\tt off} and thus is working
only for \LaTeX{} output.

For every  identifier  used  in  the  typeset  \REDUCE{}  formula
the following properties can be defined by the statement {\tt defid}:
\begin{itemize}
\item its printing symbol (Greek letters can be used).
\item the font in which the symbol will be typeset.
\item accent which will be typeset above the symbol.
\end{itemize}

Symbols with indexes are treated in \REDUCE{} as operators.  Each index
corresponds to an argument of the operator.  The meaning of operator
arguments (where one wants to typeset them) is declared by the statement
{\tt defindex}.  This statement causes the arguments to be typeset as
subscripts or superscripts (on left or right-hand side of the operator)
or as arguments of the operator.

The statement {\tt mathstyle} defines the style of formula typesetting.
The variable {\tt laline!*} defines the length of output lines.

The fractions with horizontal divide bars are typeset by using the
new \REDUCE{} infix operator \verb+\+.  This operator is not
algebraically simplified.  During typesetting of powers the checking on
the form of the power base and exponent is performed to determine the
form of the typeset expression (eg.  sqrt symbol, using parentheses).

Some special forms can be typeset by using \REDUCE{} prefix operators.
These are as follows:
\begin{itemize}
\item {\tt int} - integral of an expression.
\item {\tt dint} - definite integral of an expression.
\item {\tt df} - derivative of an expression.
\item {\tt pdf} - partial derivative of an expression.
\item {\tt sum} - sum of expressions.
\item {\tt product} - product of expressions.
\item {\tt sqrt} - square root of expression.
\end{itemize}
There are still some problems unsolved in the present version of the
interface as follows:
\begin{itemize}
\item breaking the formulas which do not fit on one line.
\item automatic decision where to use divide bars in fractions.
\item distinction of two- or more-character identifiers from the product
  of one-character symbols.
\item typesetting of matrices.
\end{itemize}

\vskip0.5cm

\centerline{\bf Description of files}

\begin{description}
\item[rlfi.red] - \REDUCE{} source file for this interface.
\item[rlfi.tex] - this document.
\item[rlfi.bib] - bibliography file for this document.
\item[rlfi.tst] - test file for this interface.
\item[rlfi.log] - \LaTeX{} output of the test session,
                   can be directly used as \LaTeX{} input file.
\end{description}


\centerline{\bf Remark}

After finishing presented interface, we have found another work
\cite{Antweiler:89}, which solves the same problem. The RLFI package has
been described in \cite{Drska:90} too.



\bibliography{rlfi}
\bibliographystyle{plain}

\vskip0.5cm

\section{APPENDIX: Summary and syntax}

{\bf Warning}

The RLFI package can be used only on systems supporting lower case
letters with {\tt off raise} statement. The package distinquishes the
upper and lower case letters, so be carefull in typing them.
In \REDUCE 3.6 the \REDUCE commands have to be typed in lower-case
while the switch {\tt latex} is {\tt on}, in previous versions
the commands had to be typed in upper-case.

{\bf Switches}

\begin{description}
\item[{\tt latex}]
- If {\tt on} output is in \LaTeX{} format. It turns {\tt off} the {\tt
raise} switch if it is set {\tt on} and {\tt on} the {\tt raise} switch
if it is set {\tt off}. By default is {\tt off}.
\item[{\tt lasimp}]
- If {\tt on} formulas are evaluated (simplified), \REDUCE{} works
as usually. If {\tt off} no evaluation is performed and the structure
of formulas is preserved. By default is {\tt on}.
\item[{\tt verbatim}]
- If {\tt on} the \REDUCE{} input, while {\tt latex} switch being {\tt
on}, is printed in \LaTeX{} verbatim environment. The acutal \REDUCE{}
input is printed after the line containing the string {\tt "REDUCE
Input:"}.  It turns {\tt on} resp. {\tt off} the {\tt echo} switch when
turned {\tt on} resp. {\tt off}. by default is {\tt off}.
\end{description}

{\bf Operators}

\begin{description}
\item[infix] - \verb+\+
\item[prefix] - {\tt int,dint,df,pdf,sum,product,sqrt} and all \REDUCE{}
prefix operators defined in the \REDUCE{} kernel and the SOLVE module.
\end{description}

\begin{verbatim}
    \ 
   int(,)
   dint(,,,)
   df(,)
    ::= |,
    ::= |,
    ::= 
    ::= 
    ::= 
    ::= 
    ::= 
   pdf(,)
   sum(,,)
   product(,,)
   sqrt()
\end{verbatim}

{\tt } is any algebraic expression. Where appropriate,
it can include also relational operators (e.g. argument {\tt } of
{\tt sum} or {\tt product} operators is usually equation). {\tt
} is identifier or prefix operator with arguments as described
in \cite{Hearn:95}. Interface supports typesetting lists of algebraic
expressions.


{\bf Statements}

\begin{verbatim}
   mathstyle ;
    ::= math | displaymath | equation
   defid ,;
    ::=  | ,
    ::=  | |
    ::= name = 
    ::= font = 
    ::= accent = 
    ::=  | 
    ::= alpha|beta|gamma|delta|epsilon|
      varepsilon|zeta|eta|theta|vartheta|iota|kappa|lambda|
      mu|nu|xi|pi|varpi|rho|varrho|sigma|varsigma|tau|
      upsilon|phi|varphi|chi|psi|omega|Gamma|Delta|Theta|
      Lambda|Xi|Pi|Sigma|Upsilon|Phi|Psi|Omega|infty|hbar
    ::= bold|roman
    ::=hat|check|breve|acute|grave|tilde|bar|vec|
      dot|ddot
\end{verbatim}

For special symbols and accents see \cite{Lamport:86}, p. 43, 45, 51.

\begin{verbatim}
   defindex ;
    ::=  | ,
    ::= ()
    ::= 
    ::=  | ,
      
    ::= arg | up | down | leftup | leftdown
\end{verbatim}

The meaning of the statements is briefly described in the preceding
text.

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/changevr.red0000644000175000017500000002516611526203062023742 0ustar  giovannigiovannimodule changevr;   % Facility to perform CHANGE of independent VARs.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*********************************************************************;
%                   -------------------------------                   ;
%                      C  H  A  N  G  E  V  A  R                      ;
%                   -------------------------------                   ;
%                                                                     ;
%   A REDUCE facility to perform CHANGE of independent VARiable(s)    ;
%   in differential equation (or a set of them).                      ;
%                                                                     ;
%                                                                     ;
%   Author : Gokturk Ucoluk                                           ;
%   Date   : Oct. 1989                                                ;
%   Place  : Middle East Tech. Univ., Physics Dept., Turkey.          ;
%   Email  : A07917 @ TRMETU.BITNET  or   A06794 @ TRMETU.BITNET      ;
%                                                                     ;
%   Version: 1.00                                                     ;
%                                                                     ;
%        ( *** Requires: REDUCE 3.0 or greater *** )                  ;
%        ( *** Requires: Matrix package to be present *** )           ;
%                                                                     ;
%   There exists a document written in LaTeX that explains the        ;
%   package in more detail.                                           ;
%                                                                     ;
%   Keywords : differential equation, change of variable, Jacobian    ;
%                                                                     ;

%*********************************************************************;

create!-package('(changevr),'(contrib misc));

load!-package 'matrix;

fluid '(powlis!* wtl!*);

global '(!*derexp !*dispjacobian);
switch derexp, dispjacobian ;  % on derexp       : Smart chain ruling
                               % on dispjacobian : Displays inverse
                               %                   Jacobian.
symbolic procedure simpchangevar v;
begin scalar u,f,j,dvar,flg;
     dvar := if pairp car v then cdar v else car v.nil;
     v := cdr v;                        % Dvar: list of depend. var
     u :=  if pairp car v then cdar v else car v.nil;
     v := cdr v;                        % u: list of new variables
     if eqcar(car v,'list) then v := append(cdar v,cdr v);
     while cdr v do
       << if caar v neq 'equal
            then rederr "improper new variable declaration";
          f := cdar v . f;  % f: list of entries (oldvar  func(newvrbs))
          v := cdr v >>;    %                           i     i
     v := reval car v;     % v: holds now last expression (maybe a list)
     if length u < length f then  rederr "Too few new variables"
      else if length u > length f then rederr "Too few old variables";
     % Now we form the Jacobian matrix ;
     j := for each entry in f collect
            for each newvrb in u collect
                reval list('df,cadr entry, newvrb);
     j := cdr aeval list('quotient,1,'mat.j);
          % j: holds inverse Jacobian.
     % We have to define the dependencies of old variables to new
     % variables.
     for each new in u do
       for each old in f do
          depend1(new, car old, t);
     % Below everything is perplexed :
     % The aim is to introduce  LET DF(new   ,old   ) = jacobian
     %                                   row    col            row,col
     % With the pairing trick below we do it in one step.
     %  new   : car row,   old   : caar col,   jacobian       : cdr col
     %     row                col                      row,col
     %
     for each row in pair(u,j) do
       for each col in pair(f,cdr row) do
        <<
          let2(list('df,car row,caar col), sqchk cdr col, nil, t);
          if !*dispjacobian and !*msg then
             mathprint list('equal,list('df,car row,caar col),
                            sqchk cdr col)
        >>;
     flg := !*derexp;
     !*derexp := t;

     v := changearg(dvar,u,v);

     for each  entry in f do
       v := subcare(car entry, cadr entry, v);
     % now here comes the striking point ... we evaluate the last
     % argument.
     v := simp!* v;
     % Now clean up the mess of LET;
     for each new in u do
       for each old in f do
          << let2(list('df,new,car old), nil, nil, nil);
             let2(list('df,new,car old), nil, t,   nil) >>;
     !*derexp := flg;
     return v;
end;

put('changevar,'simpfn,'simpchangevar);

symbolic procedure changearg(f,u,x);
if atom x then x
 else if car x memq f then car x . u
 else changearg(f,u,car x) . changearg(f,u,cdr x);


 symbolic procedure subcare(x,y,z);   % shall be used after changearg ;
 if null z then nil
  else if x = z then y
  else if atom z or get(car z,'subfunc) then z
  else (subcare(x,y,car z) . subcare(x,y,cdr z));


% Updated version of DIFFP.. chain rule handling is smarter. ;
% Example: If F is an operator and R has a implicit dependency on X,
%          declared by a preceding DEPEND R,X .. then the former version
%          of DIFFP, provided in REDUCE 3.3, was such that an algebraic
%          evaluation of    DF(F(R),X)    will evaluate to itself, that
%          means no change will happen. With the below given update this
%          is improved.   If the new provided flag DEREXP is OFF  then
%          the differentiation functions exactly like it was before,
%          but if DEREXP is ON then the chain rule is taken further to
%          yield the result:    DF(F(R),R)*DF(R,X)  .

remflag('(diffp),'lose);   % Since we want to reload it.

symbolic procedure diffp(u,v);
   %U is a standard power, V a kernel.
   % Value is the standard quotient derivative of U wrt V.
   begin scalar n,w,x,y,z,key; integer m;
        n := cdr u;     %integer power;
        u := car u;     %main variable;
        if u eq v and (w := 1 ./ 1) then go to e
         else if atom u then go to f
         %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x))
%               and (w := cdr x) then go to e   %deriv known;
             %DSUBL!* not used for now;
         else if (not atom car u and (w:= difff(u,v)))
                  or (car u eq '!*sq and (w:= diffsq(cadr u,v)))
          then go to c  %extended kernel found;
         else if x := get(car u,'dfform) then return apply3(x,u,v,n)
         else if x:= get(car u,dfn_prop u) then nil
         else if car u eq 'plus and (w:=diffsq(simp u,v))
          then go to c
         else go to h;  %unknown derivative;
        y := x;
        z := cdr u;
    a:  w := diffsq(simp car z,v) . w;
        if caar w and null car y then go to h;  %unknown deriv;
        y := cdr y;
        z := cdr z;
        if z and y then go to a
         else if z or y then go to h;  %arguments do not match;
        y := reverse w;
        z := cdr u;
        w := nil ./ 1;
    b:  %computation of kernel derivative;
        if caar y
          then w := addsq(multsq(car y,simp subla(pair(caar x,z),
                                                   cdar x)),
                          w);
        x := cdr x;
        y := cdr y;
        if y then go to b;
    c:  %save calculated deriv in case it is used again;
        %if x := atsoc(u,dsubl!*) then go to d
        %else x := u . nil;
        %dsubl!* := x . dsubl!*;
  % d:   rplacd(x,xadd(v . w,cdr x,t));
    e:  %allowance for power;
        %first check to see if kernel has weight;
        if (x := atsoc(u,wtl!*))
          then w := multpq('k!* .** (-cdr x),w);
        m := n-1;
        % Evaluation is far more efficient if results are rationalized.
        return rationalizesq if n=1 then w
                else if flagp(dmode!*,'convert)
                     and null(n := int!-equiv!-chk
                                           apply1(get(dmode!*,'i2d),n))
                 then nil ./ 1
                else multsq(!*t2q((u .** m) .* n),w);
    f:  % Check for possible unused substitution rule.
        if not depends(u,v)
           and (not (x:= atsoc(u,powlis!*))
                 or not smember(v,simp cadddr x))
          then return nil ./ 1;
        w := list('df,u,v);
        go to j;
    h:  %final check for possible kernel deriv;
        y := nil;
        if car u eq 'df then key:=t;
        w := if key then 'df . cadr u . derad(v,cddr u)
              else list('df,u,v);
        y := cddr u;
        w := if (x := opmtch w) then simp x
              else if (not depends(cadr w,lastcar w))
                 and (not numberp lastcar w)
               then nil ./ 1
              else if !*derexp then
                    begin
                        if atom cadr w then return mksq(w,1);
                        w := nil ./ 1;
                        for each m in cdr(if key then cadr u else u) do
                          w := addsq(multsq(
                                 if (x := opmtch (z :=
                                  'df . if key then (cadr u.derad(m,y))
                                         else list(u,m) )) then
                                  simp x else mksq(z,1),
                                  diffsq(simp m,v)),
                                  w);
                        return w
                    end
              else mksq(w,1);
        go to e;
    j:  w := if x := opmtch w then simp x else mksq(w,1);
        go to e
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/pf.red0000644000175000017500000001531311526203062022543 0ustar  giovannigiovannimodule pf;  % Compute partial fractions for an expression.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment PF is the top level operator for finding the partial fractions
of an expression.  It returns the partial fractions as a list.

The algorithms used here are relatively unsophisticated, and use the
extended Euclidean algorithm to break up expressions into factors.
Much more sophisticated algorithms exist in the literature;

fluid '(!*exp !*limitedfactors !*gcd kord!*);

symbolic operator pf;

flag('(pf),'noval);   % Since PF will do its own simplification.

symbolic procedure pf(u,var);
   % Convert an algebraic expression into partial fractions.
   begin scalar !*exp,!*gcd,kord!*,!*limitedfactors,polypart,rfactor,
                u1,u2,u3,u4,var,x,xx,y;
      !*exp := !*gcd := t;
      xx := updkorder var;         % Make var the main variable.
      x := subs2 resimp simp!* u;  % To allow for OFF EXP forms.
      u1 := denr x;
      if degr(u1,var) = 0 then <>;
      u2 := qremsq(!*f2q numr x,!*f2q u1,var); %Extract polynomial part.
      if caar u2 then polypart := car u2;
      rfactor := 1 ./ 1;           % Factor for rational part.
      u2 := cdr u2;
      u3 := fctrf u1;              % Factorize denominator.
      x := cdr u3;
      u3 := car u3;
      % Process monomial part.
      while not domainp u3 do
       <>;
         u3 := lc u3>>;
      if u3 neq 1 then <>;
      % Separate power factors in denominator.
      while length x>1 do
       <>
          else <>;
         x := cdr x>>;
      u3 := exptf(caar x,cdar x);
      if u2 = (nil ./ 1) then nil
       else if degr(u3,var)=0
        then rfactor := numr rfactor ./ multf(u3,denr rfactor)
      % Remove spurious polynomial in numerator.
       else y := (multsq(rfactor,remsq(u2,!*f2q u3,var)) . car x) . y;
      x := nil;
      % Finally break down non-linear terms in denominator.
      for each j in y do
         if cddr j =1 then x := j . x
          else x := append(pfpower(car j,cadr j,cddr j,var),x);
      x := for each j in x
              collect list('quotient,prepsq!* car j,
                           if cddr j=1 then prepf cadr j
                            else list('expt,prepf cadr j,cddr j));
      if polypart then x := prepsq!* polypart . x;
      setkorder xx;
      return 'list . x
   end;

symbolic procedure xeucl(u,v,var);
   % Extended Euclidean algorithm with rational coefficients.
   % I.e., find polynomials Q, R in var with rational coefficients (as
   % standard quotients) such that Q*u + R*v = 1, where u and v are
   % relatively prime standard forms in variable var.  Returns Q . R.
   begin scalar q,r,s,w;
      q := list(1 ./ 1,nil ./ 1);
      r := list(nil ./ 1,1 ./ 1);
      if degr(u,var) < degr(v,var)
        then <>;
      u := !*f2q u; v := !*f2q v;
      while numr v do
       <>;
      v := lnc numr u ./ denr u;   % Is it possible for this not to be
                                   % in lowest terms, and, if so, does
                                   % it matter?
      r := quotsq(v,u);
      return multsq(r,quotsq(car q,v)) . multsq(r,quotsq(cadr q,v))
  end;

symbolic procedure qremsq(u,v,var);
   % Find rational quotient and remainder (as standard quotients)
   % dividing standard quotients u by v wrt var.
   % This should really be done more directly without using quotsq.
   (quotsq(addsq(u,negsq x),v) . x) where x=remsq(u,v,var);

symbolic procedure remsq(u,v,var);
   % Find rational and remainder (as a standard quotient) on
   % dividing standard quotients u by v wrt var.
   begin integer m,n; scalar x;
      n := degr(numr v,var);
      if n=0 then rederr list "Remsq given zero degree polynomial";
      while (m := degr(numr u,var))>= n do
       <>;
      return u
   end;

symbolic procedure pfpower(u,v,n,var);
   % Convert u/v^n into partial fractions.
   begin scalar x,z;
      while degr(numr u,var)>0 do
       <>;
      if numr u then z := (u . v . n) . z;
      return z
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reddom.red0000644000175000017500000001473511526203062023417 0ustar  giovannigiovannimodule reddom;   % Reduction of domain elements.

% Author: Anthony C. Hearn.

% Copyright (c) 1989 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(mv!-vars!*);

global '(!*xxx !*yyy);

% switch xxx,yyy;

!*xxx := !*yyy := t;


% Operations on domain elements.

symbolic smacro procedure domain!-!+(u,v); u+v;

symbolic smacro procedure domain!-!-(u,v); u-v;

symbolic smacro procedure domain!-!*(u,v); u*v;

symbolic smacro procedure domain!-divide(u,v); divide(u,v);


% Operations on domain element lists.

symbolic procedure mv!-domainlist!-!+(u,v);
   if null u then nil
    else domain!-!+(car u,car v) . mv!-domainlist!-!+(cdr u,cdr v);

symbolic procedure mv!-domainlist!-!-(u,v);
   if null u then nil
    else domain!-!-(car u,car v) . mv!-domainlist!-!-(cdr u,cdr v);

symbolic procedure mv!-domainlist!-!*(u,v);
   if null v then nil
    else domain!-!*(u,car v) . mv!-domainlist!-!*(u,cdr v);

% Procedures for actually reducing domain elements.

symbolic procedure reduce(u,v);
   % Reduce domain element list u with respect to an equal length domain
   % element list v.  We assume that v has been reduced to lowest terms.
   begin scalar weightlist,x;
      % Look for equal ratios of elements.
      x := u;
      IF !*YYY THEN
      x := reduce!-ratios(x,v);
      % Define weighting list.
      weightlist := set!-weights v;
      % Choose column elimination with lowest weight.
      IF !*XXX THEN
      x := reduce!-columns(x,v,weightlist);
      % Look for a reduction in weight of the expression.
      IF !*XXX THEN
      x := reduce!-weights(x,v,weightlist);
      return x
   end;

   symbolic procedure set!-weights v;
      % Define weights to be associated with the reduction test.
      % The current definition is pretty naive.
      begin integer n;
%         return reversip for each j in v collect (n := n+1)
          return reversip (0 . for each j in cdr v collect 1)
      end;

   symbolic procedure reduce!-ratios(u,v);
      begin scalar x;
         if null(x := red!-ratios1(u,v)) then return u;
         x := mv!-domainlist!-!-(mv!-domainlist!-!*(car x,u),
                                      mv!-domainlist!-!*(cdr x,v));
         return if zeros u >= zeros x then u
                 else reduce!-ratios(x,v)
      end;

      symbolic procedure zeros u;
         if null u then 0
          else if car u = 0 then 1+zeros cdr u
          else zeros cdr u;

      symbolic procedure red!-ratios1(u,v);
         u and (red!-ratios2(cdr u,cdr v,car u,car v)
                   or red!-ratios1(cdr u,cdr v));

         symbolic procedure red!-ratios2(u,v,u1,v1);
            % The remainder check is needed for the example
            % reduce('(3 0 -3 0 0 0 0),(2 -1 -2 -1 3 -1 1));
            begin integer n;
               return if null u then nil
                       else if (n := u1*car v) = v1*car u and n neq 0
                         and remainder(gcdn(v1,u1),v1)=0
                        then red!-lowest!-terms(v1,u1)
                       else red!-ratios2(cdr u,cdr v,u1,v1)
            end;

            symbolic procedure red!-lowest!-terms(u,v);
               begin scalar x;
                  if u<0 then <>;
                  x := gcdn(u,v);
                  % We must have x = u from call in red-ratios2.  If
                  % not, something is awfully wrong.
                  if x neq u then errach list("red-lowest-terms",u,v);
                  return 1 . (v/x)
               end;

symbolic procedure reduce!-columns(u,v,weightlist);
   begin scalar w,x,y,z,z1;
      x := u;
      y := v;
      w := (u . red!-weight(u,weightlist));
   a: if null x then return car w
       else if car x=0 or car y=0 then nil
       else if cdr(z := domain!-divide(car x,car y))=0
        then <>;
      x := cdr x;
      y := cdr y;
      go to a
   end;

   symbolic procedure more!-apartp(u,v);
      cadr u=2 and cadr u=cadr v and cadar u=0 and cadar v neq 0;

   symbolic procedure reduce!-weights(u,v,weightlist);
      begin scalar success,x,y,z;
         x := red!-weight(u,weightlist);
      a: y := mv!-domainlist!-!+(u,v);
         z := red!-weight(y,weightlist);
         if red!-weight!-less!-p(z,x)
           then <>;
         if success then return u;
      b: y := mv!-domainlist!-!-(u,v);
         z := red!-weight(y,weightlist);
         if red!-weight!-less!-p(z,x) then <>;
         return u
      end;

      symbolic procedure red!-weight(u,weightlist);
         nonzero!-length u . red!-weight1(u,weightlist);

         symbolic procedure red!-weight1(u,weightlist);
            if null u then 0
             else abs car u*car weightlist
                     + red!-weight1(cdr u,cdr weightlist);

         symbolic procedure nonzero!-length u;
            if null u then 0
             else if car u=0 then nonzero!-length cdr u
             else add1 nonzero!-length cdr u;

      symbolic procedure red!-weight!-less!-p(u,v);
         if car u=car v then cdr u
% Given to the REDUCE community for what it is worth.
% Revised August 1995 for Reduce 3.6.
%
create!-package('(reset),'(contrib misc));

% The command RESETREDUCE works through the history of previous
% commands, and clears any values which have been assigned, plus any
% rules, arrays and the like.  It also sets the various switches to
% their initial values.  It is not complete, but does work for most
% things that cause a gradual loss of space.  It would be relatively
% easy to make it interactive, so allowing for selective resetting.

fluid '(!*asterisk !*dfprint !*fortupper !*horner 
        !*list !*noarg !*nosplit !*ratpri !*revpri);

symbolic procedure resetreduce;
 begin
  scalar mode,statno,comm;
 % Set all switches back to initial values
 % These may vary from system to system!!

  !*algint:=nil;      !*adjprec:=nil; !*allbranch:=nil;  !*allfac:=t;
  !*arbvars:=nil;     !*asterisk:=t;  !*backtrace:=nil;
  !*balanced_mod:=nil; !*bfspace:=nil; !*combineexpt:=nil;
  !*combinelogs:=nil; !*comp:=nil;    !*complex:=nil;
  !*compxroots:=nil;  !*cramer:=nil;  !*cref:=nil;       !*defn:=nil;
  !*demo:=nil;        !*dfprint:=nil; !*div:=nil;        !*echo:=nil;
  !*errcont:=nil;     !*evallhseqp:=nil;                 !*exp:=t;
  !*expandexpt:=t;    !*expandlogs:=nil;                 !*ezgcd:=nil;
  !*factor:=nil;      !*fastfor:=nil; !*force:=nil;      !*fort:=nil;
  !*fortupper:=nil;   !*fullprec:=nil;!*fullprecision:=nil;
  !*fullroots:=nil;   !*gcd:=nil;     !*heugcd:=nil;     !*horner:=nil;
  !*ifactor:=nil;     !*int:=nil;     !*intstr:=nil;     !*lcm:=t;
  !*lessspace:=nil;   !*limitedfactors:=nil;             !*list:=nil;
  !*listargs:=nil;    !*lower:=t;     !*mcd:=t;          !*modular:=nil;
  !*msg:=t;           !*multiplicities:=nil;             !*nat:=t;
  !*nero:=nil;        !*noarg:=t;     !*noconvert:=nil;  !*nonlnr:=nil;
  !*nosplit:=t;       !*numval:=t;    !*output:=t;       !*period:=t;
                      !*pgwd:=nil;    !*plap:=nil;       !*precise:=t;
  !*pret:=nil;        !*pri:=t;       !*pwrds:=t;
  !*quotenewnam:=t;   !*raise:=nil;   !*rat:=nil;        !*ratarg:=nil;
  !*rational:=nil;    !*rationalize:=nil;                !*ratpri:=t;
  !*reduced:=nil;     !*revpri:=nil;  !*rlisp88:=nil;    !*rootmsg:=nil;
  !*roundall:=t;      !*roundbf:=nil; !*rounded:=nil;  % !*savedef:=nil;
  !*savestructr:=nil; !*solvesingular:=nil;              !*time:=nil;
  !*trallfac:=nil;    !*trfac:=nil;   !*trint:=nil;      !*trroot:=nil;

  % Now work down previous inputs
  foreach stat in inputbuflis!* do <<
        statno:=car stat;
        mode:=cadr stat;
        comm:=caddr stat;
%       princ "Dealing with input "; princ statno;
%       princ " in mode "; print mode;
%       prin2t comm;
%       princ "car comm="; prin2t car comm;
        if mode='algebraic then algreset(comm)
        else if mode='symbolic then symbreset(comm)
    >>;
 inputbuflis!*:=nil
 end;

symbolic procedure algreset(comm);
 begin scalar forallfn;
    if atom comm then return nil;
    forallfn:='forall;
    if car comm='setk then remprop(cadadr comm,'avalue)
    else if car comm='arrayfn then
        foreach y in cdaddr comm do <<
            remprop(cadadr y,'dimension);
            remprop(cadadr y,'rvalue);
            remprop(cadadr y,'rtype) >>
    else if car comm='progn then foreach y in cdr comm do algreset(y)
    else if car comm='prog then foreach y in cdr comm do algreset(y)
    else if car comm='setq then nil
    else if car comm='go then nil
    else if car comm='cond then
        foreach y in cdr comm do <<
            algreset(car comm); algreset(cadr comm) >>
    else if car comm='flag then eval('remflag . (cdr comm))
    else if car comm='de then remd cadr comm
    else if car comm='let then
        foreach xx in cdadr comm do clear car cdaddr xx
    else if car comm='clear then nil
    else if car comm='forall and caadr cadddr cadr comm = 'let then
        foreach xx in cdadr cadddr cadr comm do
           forallfn list(cadr cadadr comm,cadr cadr cdadr comm,
                        list('clear, list('list, caddr cadr xx)))
 %   else I do not know what to do!!
 end;

symbolic procedure symbreset(comm);
  <<
    if car comm='setq then set(cadr comm,nil)
    else if car comm='progn then foreach y in cdr comm do symbreset(y)
    else if car comm='flag then eval('remflag . (cdr comm))
    else if car comm='de then remd cadr comm
%   else I do not know what to do!!
  >>;

put('resetreduce,'stat,'endstat);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/limits.rlg0000644000175000017500000002275111527635055023471 0ustar  giovannigiovanniFri Feb 18 21:28:02 2011 run on win32
% Tests of limits package.

limit(sin(x)/x,x,0);


1
 % 1
limit(sin(x)^2/x,x,0);


0
 % 0
limit(sin(x)/x,x,1);


sin(1)
 % sin(1)
limit(1/x,x,0);


infinity
 % infinity
limit(-1/x,x,0);


 - infinity
 % - infinity
limit((sin(x)-x)/x^3,x,0);


  - 1
------
  6
 % -1/6
limit(x*sin(1/x),x,infinity);


1
 % 1
limit(sin x/x^2,x,0);


infinity
 % infinity
limit(x^2*sin(1/x),x,infinity);


infinity
 % infinity

% Simple examples from Schaum's Theory & Problems of Advanced Calculus

limit(x^2-6x+4,x,2);


-4
 % -4
limit((x+3)*(2x-1)/(x^2+3x-2),x,-1);


 3
---
 2
 % 3/2
limit((sqrt(4+h)-2)/h,h,0);


 1
---
 4
 % 1/4
limit((sqrt(x)-2)/(4-x),x,4);


  - 1
------
  4
 % -1/4
limit((x^2-4)/(x-2),x,2);


4
 % 4
limit(1/(2x-5),x,-1);


  - 1
------
  7
 % -1/7
limit(sqrt(x)/(x+1),x,1);


 1
---
 2
 % 1/2
limit((2x+5)/(3x-2),x,infinity);


 2
---
 3
 % 2/3
limit((1/(x+3)-2/(3x+5))/(x-1),x,1);


 1
----
 32
 % 1/32
limit(sin(3x)/x,x,0);


3
 % 3
limit((1-cos(x))/x^2,x,0);


 1
---
 2
 % 1/2
limit((6x-sin(2x))/(2x+3*sin(4x)),x,0);


 2
---
 7
 % 2/7
limit((1-2*cos(x)+cos(2x))/x^2,x,0);


-1
 % -1
limit((3*sin(pi*x) - sin(3*pi*x))/x^3,x,0);


    3
4*pi
 % 4*pi^3
limit((cos(a*x)-cos(b*x))/x^2,x,0);


     2    2
  - a  + b
------------
     2
 % (-a^2 + b^2)/2
limit((e^x-1)/x,x,0);


1
 % 1
limit((a^x-b^x)/x,x,0);


log(a) - log(b)
 % log(a) - log(b)

% Examples taken from Hyslop's Real Variable

limit(sinh(2x)^2/log(1+x^2),x,0);


4
 % 4
limit(x^2*(e^(1/x)-1)*(log(x+2)-log(x)),x,infinity);


2
 % 2
limit(x^alpha*log(x+1)^2/log(x),x,infinity);


                        2
       alpha  log(x + 1)
limit(x     *-------------,x,infinity)
                log(x)

  %% if repart alpha < 0 then 0 else infinity.
  %% fails because answer depends in essential way on parameter.

limit((2*cosh(x)-2-x^2)/log(1+x^2)^2,x,0);


 1
----
 12
 % 1/12
limit((x*sinh(x)-2+2*cosh(x))/(x^4+2*x^2),x,0);


1
 % 1
limit((2*sinh(x)-tanh(x))/(e^x-1),x,0);


1
 % 1
limit(x*tanh(x)/(sqrt(1-x^2)-1),x,0);


-2
 % -2
limit((2*log(1+x)+x^2-2*x)/x^3,x,0);


 2
---
 3
 % 2/3
limit((e^(5*x)-2*x)^(1/x),x,0);


 3
e
 % e^3
limit(log(log(x))/log(x)^2,x,infinity);


0
 % 0

% These are adapted from Lession 4 from Stoutmyer

limit((e^x-1)/x, x, 0);


1
 % 1
limit(((1-x)/log(x))**2, x, 1);


1
 % 1
limit(x/(e**x-1), x, 0);


1
 % 1

%% One sided limits
limit!+(sin(x)/sqrt(x),x,0);


0
 % 0
limit!-(sin(x)/sqrt(x),x,0);


0
 % 0


limit(x/log x,x,0);


0
 % 0
limit(log(1 + x)/log x,x,infinity);


1
 % 1
limit(log x/sqrt x,x,infinity);


0
 % 0
limit!+(sqrt x/sin x,x,0);


infinity
 % infinity
limit(log x,x,0);


 - infinity
 % - infinity
limit(x*log x,x,0);


0
 % 0
limit(log x/log(2x),x,0);


1
 % 1
limit(log x*log(1+x)*(1+x),x,0);


0
 % 0
limit(log x/x,x,infinity);


0
 % 0
limit(log x/sqrt x,x,infinity);


0
 % 0
limit(log x,x,infinity);


infinity
 % infinity
limit(log(x+1)/sin x,x,0);


1
 % 1
limit(log(1+1/x)*sin x,x,0);


0
 % 0
limit(-log(1+x)*(x+2)/sin x,x,0);


-2
 % -2
limit(-log x*(3+x)/log(2x),x,0);


-3
 % -3
limit(log(x+1)^2/sqrt x,x,infinity);


0
 % 0
limit(log(x + 1) - log x,x,infinity);


0
 % 0
limit(-(log x)^2/log log x,x,infinity);


 - infinity
 % - infinity
limit(log(x-1)/sin x,x,0);


sign(log(-1))*infinity
 % infinity

limit!-(sqrt x/sin x,x,0);


 - sign(i)*infinity
 % infinity
limit(log x-log(2x),x,0);


 - log(2)
 % - log(2)
limit(sqrt x-sqrt(x+1),x,infinity);


0
 % 0

limit(sin sin x/x,x,0);


1
 % 1
limit!-(sin x/cos x,x,pi/2);


infinity
 % infinity % this works!
limit!+(sin x/cos x,x,pi/2);


 - infinity
 % - infinity % so does this!
limit(sin x/cosh x,x,infinity);


0
 % 0
limit(sin x/x,x,infinity);


0
 % 0
limit(x*sin(1/x),x,0);


0
 % 0
limit(exp x/((exp x + exp(-x))/2),x,infinity);


2
 % 2
% limit(exp x/cosh x,x,infinity); % fails in this form, but if cosh is
  %defined using let, then it works.
limit((sin(x^2)/(x*sinh x)),x,0);


1
 % 1
limit(log x*sin(x^2)/(x*sinh x),x,0);


 - infinity
 % - infinity
limit(sin(x^2)/(x*sinh x*log x),x,0);


0
 % 0
limit(log x/log(x^2),x,0);


 1
---
 2
 % 1/2
limit(log(x^2)-log(x^2+8x),x,0);


 - infinity
 % - infinity
limit(log(x^2)-log(x^2+8x),x,infinity);


0
 % 0
limit(sqrt(x+5)-sqrt x,x,infinity);


0
 % 0
limit(2^(log x),x,0);


0
 % 0

% Additional examples
limit((sin tan x-tan sin x)/(asin atan x-atan asin x),x,0);


1
 % 1

% This one has the value infinity, but fails with de L'Hospital's rule:
limit((e+1)^(x^2)/e^x,x,infinity);


               2
              x
       (e + 1)
limit(-----------,x,infinity)
           x
          e
 % infinity  % fails

comment
The following examples were not in the previous set$


% Simon test examples:
limit(log(x-a)/((a-b)*(a-c)) + log(2(x-b))/((b-c)*(b-a))
      + log(x-c)/((c-a)*(c-b)),x,infinity);


       - log(2)
----------------------
              2
 a*b - a*c - b  + b*c
 % log(1/2)/((a-b)*(b-c))

limit(1/(e^x-e^(x-1/x^2)),x,infinity);


             1
limit(----------------,x,infinity)
                    2
        x    x - 1/x
       e  - e
 % infinity  % fails

% new capabilities: branch points at the origin, needed for definite
% integration.

limit(x+sqrt x,x,0);


0
 % 0
limit!+(sqrt x/(x+1),x,0);


0
 % 0
limit!+(x^(1/3)/(x+1),x,0);


0
 % 0
limit(log(x)^2/x^(1/3),x,0);


infinity
 % infinity
limit(log x/x^(1/3),x,0);


 - infinity
 % - infinity

h := (X^(1/3) + 3*X**(1/4))/(7*(SQRT(X + 9) - 3)**(1/4));


             1/4    1/3
          3*x    + x
h := ------------------------
                         1/4
      7*(sqrt(x + 9) - 3)

limit(h,x,0);


    1/4
 3*6
--------
   7
 % 3/7*6^(1/4)

% Examples from Paul S. Wang's thesis:

limit(x^log(1/x),x,infinity);


0
 % 0
limit(cos x - 1/(e^x^2 - 1),x,0);


 - infinity
 % - infinity
limit((1+a*x)^(1/x),x,infinity);


               1/x
limit((1 + a*x)   ,x,infinity)
 % 1
limit(x^2*sqrt(4*x^4+5)-2*x^4,x,infinity);


 5
---
 4
 % 5/4
limit!+(1/x-1/sin x,x,0);


0
 % 0
limit(e^(x*sqrt(x^2+1))-e^(x^2),x,infinity);


               2          2
       x*sqrt(x  + 1)    x
limit(e               - e  ,x,infinity)
 % 0 fails
limit((e^x+x*log x)/(log(x^4+x+1)+e^sqrt(x^3+1)),x,infinity);


                 x
                e  + x*log(x)
limit(---------------------------------,x,infinity)
                                3
            4             sqrt(x  + 1)
       log(x  + x + 1) + e
 %0 % fails
limit!-(1/(x^3-6*x+11*x-6),x,2);


 1
----
 12
 % 1/12
limit((x*sqrt(x+5))/(sqrt(4*x^3+1)+x),x,infinity);


 1
---
 2
 % 1/2
limit!-(tan x/log cos x,x,pi/2);


 - infinity
 % - infinity

z0 := z*(z-2*pi*i)*(z-pi*i/2)/(sinh z - i);


                            2      2
       z*( - 5*i*pi*z - 2*pi  + 2*z )
z0 := --------------------------------
              2*(sinh(z) - i)

limit(df(z0,z),z,pi*i/2);


sign(i)*infinity
 % infinity
z1 := z0*(z-pi*i/2);


                3            2       2        3
       z*(2*i*pi  - 12*i*pi*z  - 9*pi *z + 4*z )
z1 := -------------------------------------------
                    4*(sinh(z) - i)

limit(df(z1,z),z,pi*i/2);


 - 2*pi
 % -2*pi

% and the analogous problem:
z2 := z*(z-2*pi)*(z-pi/2)/(sin z - 1);


              2               2
       z*(2*pi  - 5*pi*z + 2*z )
z2 := ---------------------------
            2*(sin(z) - 1)

limit(df(z2,z),z,pi/2);


 - infinity
 % infinity
z3 := z2*(z-pi/2);


                 3       2            2      3
       z*( - 2*pi  + 9*pi *z - 12*pi*z  + 4*z )
z3 := ------------------------------------------
                    4*(sin(z) - 1)

limit(df(z3,z),z,pi/2);


2*pi
 % 2*pi

% A test by Wolfram Koepf.
f:=x^2/(3*(-27*x^2 - 2*x^3 + 3^(3/2)*(27*x^4 + 4*x^5)^(1/2))^(1/3));


                                 2
                                x
f := --------------------------------------------------------
                                        2      3       2 1/3
      3*(3*sqrt(4*x + 27)*sqrt(3)*abs(x)  - 2*x  - 27*x )

L0:=limit(f,x,0);


l0 := 0
 % L0 := 0
f1:=((f-L0)/x^(1/3))$


L1:=limit(f1,x,0);


l1 := 0
 % L1 := 0
f2:=((f1-L1)/x^(1/3))$


L2:=limit(f2,x,0);


        - 1
l2 := ------
        1/3
       2
 % L2 := -1/2^(1/3)
f3:=((f2-L2)/x^(1/3))$


L3:=limit(f3,x,0);


l3 := 0
 % L3 := 0
f4:=((f3-L3)/x^(1/3))$


L4:=limit(f4,x,0);


l4 := 0
 % L4 := 0
f5:=((f4-L4)/x^(1/3))$


L5:=limit(f5,x,0);


           2/3
        - 2
l5 := ---------
         81
 % L5 = -2^(2/3)/81
f6:=((f5-L5)/x^(1/3))$


L6:=limit(f6,x,0);


l6 := 0
 % L6 := 0
f7:=((f6-L6)/x^(1/3))$


L7:=limit(f7,x,0);


l7 := 0
 % L7 := 0
f8:=((f7-L7)/x^(1/3))$


L8:=limit(f8,x,0);


           7
l8 := -----------
             1/3
       6561*2
 % L8 := 7/(6561*2^(1/3))

limit(log(1+x)^2/x^(1/3),x,infinity);


0
  % 0
limit(e^(log(1+x)^2/x^(1/3)),x,infinity);


1
 % 1

ss := (sqrt(x^(2/5) +1) - x^(1/3)-1)/x^(1/3);


             2/5         1/3
       sqrt(x    + 1) - x    - 1
ss := ---------------------------
                  1/3
                 x

limit(ss,x,0);


-1
 % -1
limit(exp(ss),x,0);


 1
---
 e
 % 1/e
limit(log x,x,-1);


log(-1)
 % log(-1)
limit(log(ss),x,0);


log(-1)
 % log(-1)

ss := ((x^(1/2) - 1)^(1/3) + (x^(1/5) + 1)^2)/x^(1/5);


                    1/3    2/5      1/5
       (sqrt(x) - 1)    + x    + 2*x    + 1
ss := --------------------------------------
                        1/5
                       x

limit(ss,x,0);


2
 % 2

h := (X^(1/5) + 3*X**(1/4))^2/(7*(SQRT(X + 9) - 3 - x/6))**(1/5);


       1/5   2/5      9/20
      6   *(x    + 6*x     + 9*sqrt(x))
h := -----------------------------------
                              1/5  1/5
      (6*sqrt(x + 9) - x - 18)   *7

limit(h,x,0);


     3/5
  - 6
---------
   1/5
  7
 % -6^(3/5)/7^(1/5)

end;


Time for test: 515 ms
@@@@@ Resources used: (0 6 19 800)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/dfpart.tst0000644000175000017500000000473611526203062023465 0ustar  giovannigiovannidepend y,x;
generic_function f(x,y);
df(f(),x);
df(f(x,y),x);
df(f(x,x**3),x);
df(f(x,z**3),x);
df(a*f(x,y),x);
dfp(a*f(x,y),x);
df(f(x,y),x,2);
df(dfp(f(x,y),x),x);
df(dfp(f(x,x**3),x),x);

% using a generic fucntion with commutative derivatives
generic_function u(x,y);
dfp_commute u(x,y);
df(u(x,y),x,x);

% explicitly declare 1st and second derivative commutative
generic_function v(x,y);
let dfp(v(~a,~b),{y,x}) => dfp(v(a,b),{x,y});
df(v(),x,2);

% substitute expressions for the arguments
w:=df(f(),x,2);
sub(x=0,y=x,w);

% composite generic functions
generic_function g(x,y);
generic_function h(y,z);
depend z,x;
w:=df(g()*h(),x);
sub(y=0,w);
% substituting g*h for f in a partial derivative of f,
% inheriting the arguments of f. Here no derivative of h
% appears because h does not depend of x.
sub(f=g*h,dfp(f(a,b),x));

% indexes.

% in the following total differential the partial
% derivatives wrt i and j do not appear because i and
% j do not depend of x.

generic_function m(i,j,x,y);
df(m(i,j,x,y),x);

% computation with a differential equation.

generic_function f(x,y);
operator y;
let df(y(~x),x) => f(x,y(x));

% some derivatives

df(y(x),x);
df(y(x),x,2);
df(y(x),x,3);
sub(x=22,ws);

% taylor expansion for y

load_package taylor;
taylor(y(x0+h),h,0,3);

clear w;

%------------------------ Runge Kutta -------------------------
% computing Runge Kutta formulas for ODE systems Y'=F(x,y(x));
% forms corresponding to Ralston Rabinowitz

load_package taylor;
operator alpha,beta,w,k;

% s= order of Runge Kutta formula

s:=3;  

generic_function f(x,y);
operator y;

% introduce ODE

let df(y(~x),x)=>f(x,y(x)); 

% formal series for solution

y1_form := taylor(y(x0+h),h,0,s);

% Runge-Kutta Ansatz:

let alpha(1)=>0;

for i:=1:s do
   let k(i) => h*f(x0 + alpha(i)*h, 
                  y(x0) + for j:=1:(i-1) sum beta(i,j)*k(j));
y1_ansatz:= y(x0) + for i:=1:s sum w(i)*k(i);

y1_ansatz := taylor(y1_ansatz,h,0,s);

% compute y1_form - y1_ans and collect coeffients of powers of h

y1_diff := num(taylortostandard(y1_ansatz)-taylortostandard(y1_form))$
cl := coeff(y1_diff,h);

% f_forms: forms of f and its derivatives which occur in cl

f_forms :=q := {f(x0,y(x0))}$
for i:=1:(s-1) do
  <>;
f_forms;

% extract coefficients of the f_forms in cl

sys := cl$
for each fr in f_forms do
  sys:=for each c in sys join coeff(c,fr);
% and eliminate zeros
sys := for each c in sys join if c neq 0 then {c} else {};

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/comfac.red0000644000175000017500000000423711526203062023371 0ustar  giovannigiovannimodule comfac;   % Multivariate common factor/content routines.

% Author: Anthony C. Hearn.

% Copyright (c) 1989 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic smacro procedure domain!-gcd(u,v); gcdn(u,v);

symbolic smacro procedure domain!-onep u; onep u;

symbolic procedure mv!-pow!-zerop u;
   null u or zerop car u and mv!-pow!-zerop cdr u;

symbolic procedure mv!-pow!-gcd(u,v);
   if null u then nil
    else min(car u,car v) . mv!-pow!-gcd(cdr u,cdr v);

symbolic procedure mv!-content u;
   % Finds the term that is the content of u.
      if null u then nil
       else begin scalar x,y;
         x := mv!-lc u;
         y := mv!-lpow u;
      a: u := mv!-red u;
         if null u or domain!-onep x and mv!-pow!-zerop y
           then return mv!-!.!*(y,x);
         x := domain!-gcd(x,mv!-lc u);
         y := mv!-pow!-gcd(y,mv!-lpow u);
         go to a
       end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reset.tex0000644000175000017500000000134311526203062023304 0ustar  giovannigiovanni\documentclass[12pt]{article}

\newcommand{\ttindex}[1]{{\renewcommand{\_}{\protect\underscore}%
                          \index{#1@{\tt #1}}}}

\title{RESET: Reset REDUCE to its initial state}


\author{
J. P. Fitch \\
School of Mathematical Sciences, University of Bath\\
BATH BA2 7AY, England \\[0.05in]
e--mail: jpff@cs.bath.ac.uk
}
\begin{document}
\maketitle

This package defines a command {\tt RESETREDUCE}
\ttindex{RESETREDUCE} that works through the history of previous
commands, and clears any values which have been assigned, plus any
rules, arrays and the like.  It also sets the various switches to
their initial values.  It is not complete, but does work for most
things that cause a gradual loss of space.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/odeex.red0000644000175000017500000001053111526203062023237 0ustar  giovannigiovanni%  A SIMPLE PROGRAM FOR COMPUTING SOLUTIONS OF ODES BY TAYLOR SERIES.

% Author: Andreas Strotmann .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

% 1. The simplest case.

% Compute the first N terms of the Taylor series of the solution of
% the explicit ordinary first order differential equation
% y' = f(x,y)
% in a neighborhood of x0 *if* f is holomorphic in x and y at (x0,y0).

PROCEDURE detaylor(f,x,y,x0,y0,N);

begin scalar wj, pot;
  wj:=f; pot:=x-x0;
  return ( y0+sub({x=x0,y=y0},f)*(x-x0) +
            for j:=2:n sum
              << wj:= df(wj,x)+f*df(wj,y);
                 pot := pot*(x-x0)/j;
               sub({x=x0,y=y0},wj)*pot>>);
end;

% Example: y'=xy

detaylor(x*y,x,y,0,1,5);

% 2. The general case.

% Vectors (= systems of ODEs) are encoded as lists.

% 2.1 Auxiliaries.

infix lplusl;

precedence lplusl,+;

procedure x lplusl y; % vector + vector
  begin scalar auxy;
    auxy:= y;
    return
     foreach xi in x collect <>
        where s= first auxy+ xi;
  end;

infix ltimesl;

precedence ltimesl,*;

procedure x ltimesl y; % vector * vector -> scalar
  begin scalar auxy;
    auxy:= y;
    return
     foreach xi in x sum <> where s=first auxy* xi;
  end;

infix ltimess;

precedence ltimess,*;

procedure x ltimess y; % vector * scalar  -> vector
  foreach xi in x collect y*xi;

% 2.2 The central procedure.

% Compute the first N terms of the Taylor series of the solution of
% the initial value problem
% (y1,...,yn)'=(f1(x,y1,...,yn), ... , fn(x,y1,...,yn))
%   such that  y1(x0)=y10, ..., yn(x0)=yn0
% for a system of explicit ordinary first order differential equations
% in a neighborhood of x0 *if* f is holomorphic in x and all the yi at
% (x0, y10,....,yn0).
%
% Input format:  flis={f1,...,fn},
%                Anfangswerte={x=x0, y1=y10,..., yn=yn0}
%
% NOTE: none of the yi may DEPEND on x (i.e., be symbols declared to
%       do so).
%       The yi MUST be symbols so DF can handle them.

procedure odetaylor(flis,Anfangswerte,N);
begin scalar pot,x,y,x0,y0,wj,res;
 % Split args (see comment above for format):
 x:=  lhs first Anfangswerte;
 x0:= rhs first Anfangswerte;
 y:=  for each gl in rest Anfangswerte collect lhs gl;
 y0:= for each gl in rest Anfangswerte collect rhs gl;
% Initialisations (= degree one of the taylor polynomial)
res:= y0 lplusl (sub(Anfangswerte,flis) ltimess (x-x0));
pot:= x-x0;
 wj:= flis;
% Main loop:
for j:=2:n do
   << wj:= foreach wij in wj
             collect df(wij,x) + (flis ltimesl
                                    foreach yk in y  % one row of the
                                                     % Jacobian
                                      collect df(wij,yk));  %of wj wrt y
% The above DFs should be PARTDFs, really. In REDUCE 3.4, maybe they
%    can...
     pot := pot*(x-x0)/j;
     res:= res lplusl (sub(Anfangswerte,wj) ltimess pot);
           %should be sub...
   >>;
 % DONE:
 return res;
end;

% Examples:

factor x;

% y''=-y.

odetaylor({yprime,-y}, {x=0,y=0,yprime=1}, 4);

% And something wild just for fun:

odetaylor({sin y2, cos(x*y1*y2)}, {x=0,y1=pi/2, y2=pi*7/4}, 4);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/randpoly.tex0000644000175000017500000005111511526203062024014 0ustar  giovannigiovanni\documentstyle[11pt]{article}

\newcommand{\REDUCE}{REDUCE}

\title{RANDPOLY: A Random Polynomial Generator}

\author{Francis J. Wright \\
School of Mathematical Sciences \\
Queen Mary and Westfield College \\
University of London \\
Mile End Road, London E1 4NS, UK. \\
Email: {\tt F.J.Wright@QMW.ac.uk}}

\date{14 July 1994}

\begin{document}
\maketitle

\begin{abstract}
  This package is based on a port of the Maple random polynomial
  generator together with some support facilities for the generation
  of random numbers and anonymous procedures.
\end{abstract}


\section{Introduction}

The operator {\tt randpoly} is based on a port of the Maple random
polynomial generator.  In fact, although by default it generates a
univariate or multivariate polynomial, in its most general form it
generates a sum of products of arbitrary integer powers of the
variables multiplied by arbitrary coefficient expressions, in which
the variable powers and coefficient expressions are the results of
calling user-supplied functions (with no arguments).  Moreover, the
``variables'' can be arbitrary expressions, which are composed with
the underlying polynomial-like function.

The user interface, code structure and algorithms used are essentially
identical to those in the Maple version.  The package also provides an
analogue of the Maple {\tt rand} random-number-generator generator,
primarily for use by {\tt randpoly}.  There are principally two
reasons for translating these facilities rather than designing
comparable facilites anew: (1) the Maple design seems satisfactory and
has already been ``proven'' within Maple, so there is no good reason
to repeat the design effort; (2) the main use for these facilities is
in testing the performance of other algebraic code, and there is an
advantage in having essentially the same test data generator
implemented in both Maple and REDUCE\@.  Moreover, it is interesting
to see the extent to which a facility can be translated without change
between two systems.  (This aspect will be described elsewhere.)

Sections \ref{sec:Basic} and \ref{sec:Advanced} describe respectively
basic and more advanced use of {\tt randpoly}; \S\ref{sec:Subsidiary}
describes subsidiary functions provided to support advanced use of
{\tt randpoly}; \S\ref{sec:Examples} gives examples; an appendix gives
some details of the only non-trivial algorithm, that used to compute
random sparse polynomials.  Additional examples of the use of {\tt
randpoly} are given in the test and demonstration file {\tt
randpoly.tst}.


\section{Basic use of {\tt randpoly}}
\label{sec:Basic}

The operator {\tt randpoly} requires at least one argument
corresponding to the polynomial variable or variables, which must be
either a single expression or a list of expressions.%
\footnote{If it is a single expression then the univariate code is
invoked; if it is a list then the multivariate code is invoked, and in
the special case of a list of one element the multivariate code is
invoked to generate a univariate polynomial, but the result should be
indistinguishable from that resulting from specifying a single
expression not in a list.} %
In effect, {\tt randpoly} replaces each input expression by an
internal variable and then substitutes the input expression for the
internal variable in the generated polynomial (and by default expands
the result as usual), although in fact if the input expression is a
REDUCE kernel then it is used directly.  The rest of this document
uses the term ``variable'' to refer to a general input expression or
the internal variable used to represent it, and all references to the
polynomial structure, such as its degree, are with respect to these
internal variables.  The actual degree of a generated polynomial might
be different from its degree in the internal variables.

By default, the polynomial generated has degree 5 and contains 6
terms.  Therefore, if it is univariate it is dense whereas if it is
multivariate it is sparse.


\subsection{Optional arguments}

Other arguments can optionally be specified, in any order, after the
first compulsory variable argument.  All arguments receive full
algebraic evaluation, subject to the current switch settings etc.  The
arguments are processed in the order given, so that if more than one
argument relates to the same property then the last one specified
takes effect.  Optional arguments are either keywords or equations
with keywords on the left.

In general, the polynomial is sparse by default, unless the keyword
{\tt dense} is specified as an optional argument.  (The keyword {\tt
sparse} is also accepted, but is the default.)  The default degree can
be changed by specifying an optional argument of the form
\begin{center}
  {\tt degree = {\it natural number}}.
\end{center}
In the multivariate case this is the total degree, i.e.\ the sum of
the degrees with respect to the individual variables.  The keywords
{\tt deg} and {\tt maxdeg} can also be used in place of {\tt degree}.
More complicated monomial degree bounds can be constructed by using
the coefficient function described below to return a monomial or
polynomial coefficient expression.  Moreover, {\tt randpoly} respects
internally the REDUCE ``asymptotic'' commands {\tt let}, {\tt weight}
etc.\ described in \S10.4 of the \REDUCE{} 3.6 manual, which can be used
to exercise additional control over the polynomial generated.

In the sparse case (only), the default maximum number of terms
generated can be changed by specifying an optional argument of the
form
\begin{center}
  {\tt terms = {\it natural number}}.
\end{center}
The actual number of terms generated will be the minimum of the value
of {\tt terms} and the number of terms in a dense polynomial of the
specified degree, number of variables, etc.


\section{Advanced use of {\tt randpoly}}
\label{sec:Advanced}

The default order (or minimum or trailing degree) can be changed by
specifying an optional argument of the form
\begin{center}
  {\tt ord = {\it natural number}}.
\end{center}
The keyword is {\tt ord} rather than {\tt order} because {\tt order}
is a reserved command name in REDUCE\@.  The keyword {\tt mindeg} can
also be used in place of {\tt ord}.  In the multivariate case this is
the total degree, i.e.\ the sum of the degrees with respect to the
individual variables.  The order normally defaults to 0.

However, the input expressions to {\tt randpoly} can also be
equations, in which case the order defaults to 1 rather than 0.  Input
equations are converted to the difference of their two sides before
being substituted into the generated polynomial.  The purpose of this
facility is to easily generate polynomials with a specified zero -- for
example
\begin{center}\tt
  randpoly(x = a);
\end{center}
generates a polynomial that is guaranteed to vanish at $x = a$, but is
otherwise random.

Order specification and equation input are extensions of the current
Maple version of {\tt randpoly}.

The operator {\tt randpoly} accepts two further optional arguments in
the form of equations with the keywords {\tt coeffs} and {\tt expons}
on the left.  The right sides of each of these equations must evaluate
to objects that can be applied as functions of no variables.  These
functions should be normal algebraic procedures (or something
equivalent); the {\tt coeffs} procedure may return any algebraic
expression, but the {\tt expons} procedure must return an integer
(otherwise {\tt randpoly} reports an error).  The values returned by
the functions should normally be random, because it is the randomness
of the coefficients and, in the sparse case, of the exponents that
makes the constructed polynomial random.

A convenient special case is to use the function {\tt rand} on the
right of one or both of these equations; when called with a single
argument {\tt rand} returns an anonymous function of no variables that
generates a random integer.  The single argument of {\tt rand} should
normally be an integer range in the form $a~..~b$, where $a$, $b$ are
integers such that $a < b$.  The spaces around (or at least before)
the infix operator ``..'' are necessary in some cases in REDUCE and
generally recommended.  For example, the {\tt expons} argument might
take the form
\begin{center}\tt
  expons = rand(0~..~n)
\end{center}
where {\tt n} will be the maximum degree with respect to each variable
{\em independently}.  In the case of {\tt coeffs} the lower limit will
often be the negative of the upper limit to give a balanced
coefficient range, so that the {\tt coeffs} argument might take the
form
\begin{center}\tt
  coeffs = rand(-n~..~n)
\end{center}
which will generate random integer coefficients in the range $[-n,n]$.


\section{Subsidiary functions: rand, proc, random}
\label{sec:Subsidiary}

\subsection{Rand: a random-number-generator generator}

The first argument of {\tt rand} must be either an integer range in
the form $a~..~b$, where $a$, $b$ are integers such that $a < b$, or a
positive integer $n$ which is equivalent to the range $0~..~n-1$.  The
operator {\tt rand} constructs a function of no arguments that calls
the REDUCE random number generator function {\tt random} to return a
random integer in the range specified; in the case that the first
argument of {\tt rand} is a single positive integer $n$ the function
constructed just calls {\tt random($n$)}, otherwise the call of {\tt
random} is scaled and shifted.

As an additional convenience, if {\tt rand} is called with a second
argument that is an identifier then the call of {\tt rand} acts
exactly like a procedure definition with the identifier as the
procedure name.  The procedure generated can then be called with an
empty argument list by the algebraic processor.

[Note that {\tt rand()} with no argument is an error in REDUCE and
does not return directly a random number in a default range as it does
in Maple -- use instead the REDUCE function {\tt random} (see below).]


\subsection{Proc: an anonymous procedure generator}

The operator {\tt proc} provides a generalization of {\tt rand}, and
is primarily intended to be used with expressions involving the {\tt
random} function (see below).  Essentially, it provides a mechanism to
prevent functions such as {\tt random} being evaluated when the
arguments to {\tt randpoly} are evaluated, which is too early.  {\tt
Proc} accepts a single argument which is converted into the body of an
anonymous procedure, which is returned as the value of {\tt proc}.
(If a named procedure is required then the normal REDUCE {\tt
procedure} statement should be used instead.)  Examples are given in
the following sections, and in the file {\tt randpoly.tst}.


\subsection{Random: a generalized interface}

As an additional convenience, this package extends the interface to
the standard REDUCE {\tt random} function so that it will directly
accept either a natural number or an integer range as its argument,
exactly as for the first argument of {\tt rand}.  Hence effectively
\begin{center}\tt
  rand(X) = proc random(X)
\end{center}
although {\tt rand} is marginally more efficient.  However, {\tt proc}
and the generalized {\tt random} interface allow expressions such as
the following anonymous random fraction generator to be easily
constructed:
\begin{center}\tt
  proc(random(-99~..~99)/random(1~..~99))
\end{center}


\subsection{Further support for procs}

{\tt Rand} is a special case of {\tt proc}, and (for either) if the
switch {\tt comp} is {\tt on} (and the compiler is available) then the
generated procedure body is compiled.

{\tt Rand} with a single argument and {\tt proc} both return as their
values anonymous procedures, which if they are not compiled are Lisp
lambda expressions.  However, if compilation is in effect then they
return only an identifier that has no external significance%
\footnote{It is not interned on the oblist.} %
but which can be applied as a function in the same way as a lambda
expression.

It is primarily intended that such ``proc expressions'' will be used
immediately as input to {\tt randpoly}.  The algebraic processor is
not intended to handle lambda expressions.  However, they can be
output or assigned to variables in algebraic mode, although the output
form looks a little strange and is probably best not displayed.  But
beware that lambda expressions cannot be evaluated by the algebraic
processor (at least, not without declaring some internal Lisp
functions to be algebraic operators).  Therefore, for testing purposes
or curious users, this package provides the operators {\tt showproc}
and {\tt evalproc} respectively to display and evaluate ``proc
expressions'' output by {\tt rand} or {\tt proc} (or in fact any
lambda expression), in the case of {\tt showproc} provided they are
not compiled.


\section{Examples}
\label{sec:Examples}

The file {\tt randpoly.tst} gives a set of test and demonstration
examples.

The following additional examples were taken from the Maple {\tt
randpoly} help file and converted to REDUCE syntax by replacing [~] by
\{~\} and making the other changes shown explicitly:
\begin{verbatim}
randpoly(x);

       5       4       3       2
 - 54*x  - 92*x  - 30*x  + 73*x  - 69*x - 67


randpoly({x, y}, terms = 20);

    5       4         4       3  2       3         3
31*x  - 17*x *y - 48*x  - 15*x *y  + 80*x *y + 92*x

       2  3      2         2         4         3         2
 + 86*x *y  + 2*x *y - 44*x  + 83*x*y  + 85*x*y  + 55*x*y

                       5       4      3       2
 - 27*x*y + 33*x - 98*y  + 51*y  - 2*y  + 70*y  - 60*y - 10


randpoly({x, sin(x), cos(x)});

                   4            3              3
sin(x)*( - 4*cos(x)  - 85*cos(x) *x + 50*sin(x)

                    2
         - 20*sin(x) *x + 76*sin(x)*x + 96*sin(x))


% randpoly(z, expons = rand(-5..5));  % Maple
% A generalized random "polynomial"!
% Note that spaces are needed around .. in REDUCE.
on div; off allfac;
randpoly(z, expons = rand(-5 .. 5));

       4       3       -3       -4      -5
 - 39*z  + 14*z  - 77*z   - 37*z   - 8*z

off div; on allfac;
% randpoly([x], coeffs = proc() randpoly(y) end);  % Maple
randpoly({x}, coeffs = proc randpoly(y));

    5  5       5  4       5  3       5  2       5         5
95*x *y  - 53*x *y  - 78*x *y  + 69*x *y  + 58*x *y - 58*x

       4  5       4  4       4  3       4  2       4
 + 64*x *y  + 93*x *y  - 21*x *y  + 24*x *y  - 13*x *y

       4       3  5       3  4       3  3       3  2
 - 28*x  - 57*x *y  - 78*x *y  - 44*x *y  + 37*x *y

       3         3       2  5       2  4    2  3       2  2
 - 64*x *y - 95*x  - 71*x *y  - 69*x *y  - x *y  - 49*x *y

       2         2         5         4         3         2
 + 77*x *y + 48*x  + 38*x*y  + 93*x*y  - 65*x*y  - 83*x*y

                       5       4       3       2
 + 25*x*y + 51*x + 35*y  - 18*y  - 59*y  + 73*y  - y + 31


% A more conventional alternative is ...
%   procedure r; randpoly(y)$  randpoly({x}, coeffs = r);
% or, in fact, equivalently ...
%   randpoly({x}, coeffs = procedure r; randpoly(y));

randpoly({x, y}, dense);

    5       4         4       3  2       3         3
85*x  + 43*x *y + 68*x  + 87*x *y  - 93*x *y - 20*x

       2  2       2        2         4         3         2
 - 74*x *y  - 29*x *y + 7*x  + 10*x*y  + 62*x*y  - 86*x*y

                       5       4       3       2
 + 15*x*y - 97*x - 53*y  + 71*y  - 46*y  - 28*y  + 79*y + 44
\end{verbatim}


\appendix

\newfont{\SYM}{msbm10 scaled\magstephalf} % AMS "blackboard bold" etc
\newcommand{\N}{\mbox{\SYM N}}		%%% {{\bf N}}

\newcommand{\th}{\mbox{$^{\it th}$}}

\newtheorem{prop}{Proposition}

\newenvironment{proof}%
   {\par\addvspace\baselineskip\noindent{\bf Proof~}}%
   {\hspace*{\fill}$\Box$\par\addvspace\baselineskip}

\section{Algorithmic background}

The only part of this package that involves any mathematics that is
not completely trivial is the procedure to generate a sparse set of
monomials of specified maximum and minimum total degrees in a
specified set of variables.  This involves some combinatorics, and the
Maple implementation calls some procedures from the Maple
Combinatorial Functions Package {\tt combinat} (of which I have
implemented restricted versions in REDUCE).

Given the maximum possible number $N$ of terms (in a dense
polynomial), the required number of terms (in the sparse polynomial)
is selected as a random subset of the natural numbers up to $N$, where
each number indexes a term.  In the univariate case these indices are
used directly as monomial exponents, but in the multivariate case they
are converted to monomial exponent vectors using a lexicographic
ordering.


\subsection{Numbers of polynomial terms}

By explicitly enumerating cases with 1, 2, etc.\ variables, as
indicated by the inductive proof below, one deduces that:

\begin{prop}
  In $n$ variables, the number of distinct monomials having total
  degree precisely $r$ is $^{r+n-1}C_{n-1}$, and the maximum number of
  distinct monomials in a polynomial of maximum total degree $d$ is
  $^{d+n}C_n$.
\end{prop}

\begin{proof}
  Suppose the first part of the proposition is true, namely that there
  are at most
  \[
    N_h(n,r) = {}^{r+n-1}C_{n-1}
  \]
  distinct monomials in an $n$-variable {\em homogeneous\/}
  polynomial of total degree $r$.  Then there are at most
  \[
    N(d,r) = \sum_{r=0}^d {}^{r+n-1}C_{n-1} = {}^{d+n}C_n
  \]
  distinct monomials in an $n$-variable polynomial of maximum total
  degree $d$.

  The sum follows from the fact that
  \[
    {}^{r+n}C_n = \frac{(r+n)^{\underline n}}{n!}
  \]
  where $x^{\underline n} = x(x-1)(x-2)\cdots(x-n+1)$ denotes a
  falling factorial, and
  \[
    \sum_{a \leq x < b} x^{\underline n} =
    \left. \frac{x^{\underline{n+1}}}{n+1} \right|_a^b.
  \]
  (See, for example, D. H. Greene \& D. E. Knuth, {\it Mathematics
  for the Analysis of Algorithms}, Birkh\"auser, Second Edn.\ 1982,
  equation (1.37)).  Hence the second part of the proposition follows
  from the first.

  The proposition holds for 1 variable ($n = 1$), because there is
  clearly 1 distinct monomial of each degree precisely $r$ and hence
  at most $d+1$ distinct monomials in a polynomial of maximum degree
  $d$.

  Suppose that the proposition holds for $n$ variables, which are
  represented by the vector $X$.  Then a homogeneous polynomial of
  degree $r$ in the $n+1$ variables $X$ together with the single
  variable $x$ has the form
  \[
    x^r P_0(X) + x^{r-1} P_1(X) + \cdots + x^0 P_r(X)
  \]
  where $P_s(X)$ represents a polynomial of maximum total degree $s$
  in the $n$ variables $X$, which therefore contains at most
  $^{s+n}C_n$ distinct monomials.  The homogeneous polynomial of
  degree $r$ in $n+1$ terms therefore contains at most
  \[
    \sum_{s=0}^r {}^{s+n}C_n = {}^{r+n+1}C_{n+1}
  \]
  distinct monomials.
  Hence the proposition holds for $n+1$ variables, and therefore by
  induction it holds for all $n$.
\end{proof}


\subsection{Mapping indices to exponent vectors}

The previous proposition is also the basis of the algorithm to map
term indices $m \in \N$ to exponent vectors $v \in \N^n$, where $n$ is
the number of variables.

Define a norm $\|\cdot\|$ on exponent vectors by $\|v\| = \sum_{i=1}^n
v_i$, which corresponds to the total degree of the monomial.  Then,
from the previous proposition, the number of exponent vectors of
length $n$ with norm $\|v\| \leq d$ is $N(n,d) = {}^{d+n}C_n$.  The
elements of the $m\th$ exponent vector are constructed recursively by
applying the algorithm to successive tail vectors, so let a subscript
denote the length of the vector to which a symbol refers.

The aim is to compute the vector of length $n$ with index $m = m_n$.
If this vector has norm $d_n$ then the index and norm must satisfy
\[
  N(n,d_n-1) \leq m_n < N(n,d_n),
\]
which can be used (as explained below) to compute $d_n$ given $n$ and
$m_n$.  Since there are $N(n,d_n-1)$ vectors with norm less than
$d_n$, the index of the $(n-1)$-element tail vector must be given by
$m_{n-1} = m_n - N(n,d_n-1)$, which can be used recursively to compute
the norm $d_{n-1}$ of the tail vector.  From this, the first element
of the exponent vector is given by $v_1 = d_n - d_{n-1}$.

The algorithm therefore has a natural recursive structure that
computes the norm of each tail subvector as the recursion stack is
built up, but can only compute the first term of each tail subvector
as the recursion stack is unwound.  Hence, it constructs the exponent
vector from right to left, whilst being applied to the elements from
left to right.  The recursion is terminated by the observation that
$v_1 = d_1 = m_1$ for an exponent vector of length $n = 1$.

The main sub-procedure, given the required length $n$ and index $m_n$
of an exponent vector, must return its norm $d_n$ and the index of its
tail subvector of length $n-1$.  Within this procedure, $N(n,d)$ can
be efficiently computed for values of $d$ increasing from 0, for which
$N(n,0) = {}^nC_n = 1$, until $N(n,d) > m$ by using the observation
that
\[
   N(n,d) = {}^{d+n}C_n = \frac{(d+n)(d-1+n)\cdots(1+n)}{d!}.
\]

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/boolean.tex0000644000175000017500000001270611526203062023606 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{BOOLEAN: Computing with boolean expressions}
\date{}
\author{
H. Melenk\\[0.05in]
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Takustra\"se 7 \\
D--14195 Berlin -- Dahlem \\
Federal Republic of Germany \\[0.05in]
E--mail: melenk@zib.de \\[0.05in]
}

\begin{document}
\maketitle

\section{Introduction}

The package {\bf Boolean} supports the computation with
boolean expressions in the propositional calculus.
The data objects are composed from algebraic expressions (``atomic parts'', ``leafs'')
connected by the infix boolean operators {\bf and}, {\bf or}, 
{\bf implies}, {\bf equiv}, and the unary prefix operator
{\bf not}. {\bf Boolean} allows you to simplify expressions
built from these operators, and to test properties like
equivalence, subset property etc. Also the reduction of
a boolean expression by a partial evaluation and combination
of its atomic parts is supported.

\section{Entering boolean expressions}

In order to distinguish boolean data expressions from 
boolean expressions in the \REDUCE programming
language (e.g. in an {\bf if} statement), each expression
must be tagged explicitly by an operator {\bf boolean}.
Otherwise the boolean operators are not accepted in the
\REDUCE  algebraic mode input.
The first argument of {\bf boolean} can be any boolean expression,
which may contain references to other boolean values.
\begin{verbatim}
    boolean (a and b or c);
    q := boolean(a and b implies c);
    boolean(q or not c);
\end{verbatim}
Brackets are used to override the operator precedence as usual.
The leafs or atoms of a boolean expression are those parts which
do not contain a leading boolean operator. These are
considered as constants during the boolean evaluation. There
are two pre-defined values:
\begin{itemize}
\item {\bf true}, {\bf t} or {\bf 1}
\item {\bf false}, {\bf nil} or {\bf 0}
\end{itemize}
These represent the boolean constants. In a result
form they are used only as {\bf 1} and {\bf 0}.

By default, a {\bf boolean} expression is converted  to a
disjunctive normal form, that is a form where terms are connected
by {\bf or} on the top level and each term is set of leaf
expressions, eventually preceded by {\bf not} and connected
by  {\bf and}. An operators {\bf or} or {\bf and} is omitted
if it would have only one single operand. The result of
the transformation is again an expression with leading 
operator {\bf boolean} such that the boolean expressions
remain separated from other algebraic data. Only the boolean
constants {\bf 0} and {\bf 1} are returned untagged.

On output, the
operators {\bf and} and {\bf or} are represented as
\verb+/\+ and \verb+\/+, respectively.
\begin{verbatim}
boolean(true and false);    ->   0
boolean(a or not(b and c)); -> boolean(not(b) \/ not(c) \/ a)
boolean(a equiv not c);     -> boolean(not(a)/\c \/ a/\not(c))
\end{verbatim}

\section{Normal forms}

The {\bf disjunctive} normal form is used by default. It
represents the ``natural'' view and allows us to represent
any form free or parentheses.
Alternatively a {\bf conjunctive} normal form can be
selected as simplification target, which is a form with
leading operator {\bf and}. To produce that form add the keyword  {\bf and}
as an additional argument to a call of {\bf boolean}.
\begin{verbatim}
boolean (a or b implies c); 
                    -> 
     boolean(not(a)/\not(b) \/ c)

boolean (a or b implies c, and); 
                    ->
     boolean((not(a) \/ c)/\(not(b) \/ c))
\end{verbatim}

Usually the result is a fully reduced disjunctive or conjuntive normal
form, where all redundant elements have been eliminated following the
rules

$ a \wedge b \vee \neg a \wedge b \longleftrightarrow b$

$ a \vee b \wedge \neg a \vee b \longleftrightarrow b$
 

Internally the full normal forms are computed
as intermediate result; in these forms each term contains
all leaf expressions, each one exactly once. This unreduced form is returned 
when you set the additional keyword {\bf full}:
\begin{verbatim}
boolean (a or b implies c, full);
                   ->
boolean(a/\b/\c \/ a/\not(b)/\c \/ not(a)/\b/\c \/ not(a)/\not(b)/\c

         \/ not(a)/\not(b)/\not(c))
\end{verbatim}

The keywords {\bf full} and {\bf and} may be combined.

\section{Evaluation of a boolean expression}

If the leafs of the boolean expression are algebraic expressions
which may evaluate to logical values because the environment
has changed (e.g. variables have been bound), you can re--investigate
the expression using the operator {\tt testbool} with the boolean
expression as argument. This operator tries to evaluate all
leaf expressions in \REDUCE boolean style. As many
terms as possible are replaced by their boolean values; the others
remain unchanged. The resulting expression is contracted to a
minimal form. The result {\bf 1} (= true) or {\bf 0} (=false)
signals that the complete expression could be evaluated. 

In the following example the leafs are built as numeric greater test.
For using ${\bf >}$ in the expressions the greater sign must
be declared operator first. The error messages are meaningless.
\begin{verbatim}
operator >;
fm:=boolean(x>v or not (u>v));
        ->
    fm := boolean(not(u>v) \/ x>v)

v:=10$

testbool fm;

   ***** u - 10 invalid as number
   ***** x - 10 invalid as number

        ->
   boolean(not(u>10) \/ x>10)

x:=3$
testbool fm;

   ***** u - 10 invalid as number

        ->
   boolean(not(u>10))

x:=17$

testbool fm;

   ***** u - 10 invalid as number
      
        ->
    1
 
\end{verbatim}
\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/boolean.red0000644000175000017500000001543011526203062023555 0ustar  giovannigiovannimodule boolean; % Propositional calculus support.

% Author: Herbert Melenk
%         Konrad Zuse Zentrum Berlin

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% A form in propositional calculus is transformed to a canonical DNF
% (disjuinct normal form) and then converted back to a or-not-form.
% Polynomials are used as intermediate form mapping or to plus and
% and to times. The variables are embedded in kernels prop* and
% negated variables are represented as not_prop* operators.

create!-package('(boolean),'(contrib misc));

algebraic operator prop!*, not_prop!*;

algebraic infix implies;
algebraic infix equiv;
algebraic precedence equiv,=>;
algebraic precedence implies,equiv;

algebraic
let prop!*(~x)*prop!*(x)=>prop!*(x),
    not_prop!*(~x)*not_prop!*(x)=>not_prop!*(x),
    prop!*(~x)*not_prop!*(x)=>0;

fluid '(propvars!* !'and !'or !'true !'false);

symbolic procedure simp!-prop u;
  begin scalar propvars!*,w,opt;
      % convert to intermediate standard form.
    opt:=for each f in cdr u collect reval f;
    if member('and,opt) then
    <>
      else
    <>;
    w:=reval prepf simp!-prop1(car u,t);
    if w=0 then return simp !'false;
      % add for each variable a true value "and (x or not x)".
    for each x in propvars!* do
      w:=reval{'times,w,prepf simp!-prop1({!'or,x,{'not,x}},t)};
         % transform to distributive.
    w:=simp!-prop!-dist w;
    if not member('full,opt) then w:=simp!-prop2 w;
    w :=simp!-prop!-form w;
    if numberp w then return w ./ 1;
    if not atom w then w:={'boolean,w};
    return (w .**1 .*1 .+nil) ./ 1;
  end;

put('boolean,'simpfn,'simp!-prop);

symbolic procedure simp!-prop1(u,m);
 % Convert logical form to polynomial.
 begin scalar w;
  if atom u then goto z;
  if car u = !'and and m or car u=!'or and not m then
    <>
  else if car u=!'or and m or car u=!'and and not m then
   <>
  else if car u='not then w:=simp!-prop1(cadr u,not m)
  else if car u ='implies then
    (if m then w:=simp!-prop1({'or,{'not,cadr u},caddr u},t) else
               w:=simp!-prop1({'or,{'not,caddr u},cadr u},t))
  else if car u= 'equiv then w:=simp!-prop1(
     {'or,{'and,cadr u,caddr u},{'and,{'not,cadr u},{'not,caddr u}}},m)
  else goto z1;
  return w;
 z:
  if u=1 or u=t or u='true then u:=m else
  if u=0 or u=nil or u='false then u:=not m;
  if u=t then return simp!-prop1('(or !*true (not !*true)),t);
  if u=nil then return simp!-prop1('(and !*true (not !*true)),t);
 z1:
  u:=reval u;
  if eqcar(u,'boolean) then return simp!-prop1(cadr u,m);
  w:= numr simp{if m then 'prop!* else 'not_prop!*,u};
  if not member(u,propvars!*) then propvars!*:=u.propvars!*;
  return w;
 end;


symbolic procedure simp!-prop2 w;
 % Remove redundant elements, convert back.
  begin scalar y,z,o,q1,q2,term,old;
   for each x in propvars!* do
   <>;
      z:=subst(q2,q1,term);
      old:=term.old;
      if (o:=member(z,w)) then
        << if o then <>;
           term:=delete(q1,term);
           old:=union({term},old);
        >>;
    >>;
    w:=old;
   >>;
   return simp!-prop!-condense w;
  end;

symbolic procedure simp!-prop!-condense u;
  begin scalar w,r;
   u:=sort(u,function(lambda(v1,v2);length(v1)>;
   return ordn r;
 end;

symbolic procedure simp!-prop!-dist w;
  % convert to a distributive form.
  <>;
    sort(w,function  simp!-prop!-order)
  >>;

symbolic procedure simp!-prop!-order(a,b);
  if null a then nil else
  if caar a = caar b then simp!-prop!-order(cdr a,cdr b) else
  if caar a = 'prop!* then t else nil;

symbolic procedure simp!-prop!-form u;
  if u='(nil) then !'true else
  <>;
    if cdr u then !'or . u else car u
  >>;

fluid '(bool!-break!*);

%symbolic procedure boolean!-eval u;
%   <> where v=nil,bool!-break!*=nil;
%
%put('boolean,'boolfn,'boolean!-eval);

symbolic procedure test!-bool u;
  mk!*sq simp!-prop list boolean!-eval1 car u;

put('testbool,'psopfn,'test!-bool);

symbolic procedure boolean!-eval1 u;
  begin scalar v;
  return
   if eqcar(u,'sq!*) and cddr u and eqcar(v:=prespsq cadr u,'boolean)
       then boolean!-eval2 cadr v
   else boolean!-eval2 prepf numr simp!-prop list u;
  end;

symbolic procedure boolean!-eval2 u;
  if eqcar(u,'boolean) then boolean!-eval2 cadr u else
  if eqcar(u,'and) or eqcar(u,'or) or eqcar(u,'not)
     then car u. for each x in cdr u collect boolean!-eval2 x
  else
   <>
                 else car r>>
       where r=nil;


put('and,'prtch,"/\");
put('or,'prtch," \/ ");

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/boolean.tst0000644000175000017500000000124311526203062023612 0ustar  giovannigiovanni% Test series for the boolean package.

boolean true;
boolean false;
boolean (true and false);
boolean (true or false);
boolean (x and true);
boolean (x and false);
boolean (x or true);
boolean (x or false);
boolean (not(x and y));
boolean (not(x or y));
boolean (x or y or(x and y));
boolean (x and y and (x or y));
boolean (x or (not x));
boolean (x and (not x));
boolean (x and y or not x);
boolean (a and b implies c and d);
boolean (a and b implies c and d, and);
boolean (a or b implies c or d);
boolean (a or b implies c or d, and,full); 

operator >;
fm:=boolean(x>v or not (u>v));
v:=10;
testbool fm;
x:=3;
testbool fm;
clear x;
x:=17;
testbool fm;
clear v,x;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/randpoly.red0000644000175000017500000003773511526203062024002 0ustar  giovannigiovannimodule randpoly;  % A random (generalized) polynomial generator

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, 14 July 1994

% Based on a port of the Maple randpoly function.
% See RANDPOLY.TEX for documentation, and RANDPOLY.TST for examples.

create!-package('(randpoly),'(contrib misc));

symbolic smacro procedure apply_c c;
   % Apply a coefficient generator function c that returns
   % a prefix form and convert it to standard quotient form.
   simp!* apply(c, nil);

symbolic procedure apply_e e;
   % Apply an exponent generator function e
   % and check that it has returned an integer.
   if fixp(e := apply(e, nil)) then e else
      RedErr "randpoly expons function must return an integer";

put('randpoly, 'simpfn, 'randpoly);

flag('(randpoly), 'listargp);  % allow single list argument

symbolic procedure randpoly u;
   % Use: randpoly(vars, options)
   % vars: expression or list of expressions -- usually indeterminates
   % options: optional equations (of the form `option = value')
   % or keywords specifying properties:
   %
   %    Option   Use                                   Default Value
   %    ------   ---                                   -------------
   %    coeffs = procedure to generate a coefficient   rand(-99 .. 99)
   %    expons = procedure to generate an exponent     rand(6)
   %               (must return an integer)
   %    degree, deg or maxdeg = maximum total degree   5
   %    ord or mindeg = minimum total degree           0 (or 1)
   %      (defaults to 1 if any "variable" is an equation)
   %    terms  = number of terms generated if sparse   6
   %    dense    the polynomial is to be dense         sparse
   %    sparse   the polynomial is to be sparse        sparse

   begin scalar v, univar, c, e, trms, d, o, s, p, sublist;

      % Default values for options:
      %% c := rand {-99 .. 99};  % rand is a psopfn
      c := function(lambda(); random(199) - 99);
      d := 5;  o := 0;  trms := 6;  s := 'sparse;

      % Evaluate arguments and process "variables":
      begin scalar wtl!*;
         % Ignore weights when evaluating args, including in revlis.
         v := car(u := revlis u);
         v := if eqcar(v, 'list) then cdr v else
            << univar := t; v . nil >>;
         v := for each vv in v collect
            begin scalar tmpvar;
               if eqexpr vv then << vv := !*eqn2a vv;  o := 1 >>
               else if kernp simp!* vv then return vv;
               tmpvar := gensym();
               sublist := {'equal, tmpvar, vv} . sublist;
               return tmpvar
            end;
         if univar then v := car v
      end;

      % Process options:
      for each x in cdr u do
         if x eq 'dense or x eq 'sparse then s := x
         else if not (eqexpr x and
            (if cadr x eq 'coeffs and functionp caddr x then
               c := caddr x
            else if cadr x eq 'expons and functionp caddr x then
               e := caddr x
            else if cadr x memq '(degree deg maxdeg) and
               natnump caddr x then d := caddr x
            else if cadr x memq '(ord mindeg) and
               natnump caddr x then o := caddr x
            else if cadr x eq 'terms and natnump caddr x then
               trms := caddr x))
         then typerr(x, "optional randpoly argument");

      % Generate the random polynomial:
      p := nil ./ 1;
      if o <= d then
      if s eq 'sparse then
         if null e then
            for each x in rand!-mons!-sparse(v,trms,d,o,univar) do
               p := addsq(p, multsq(apply_c c, x ./ 1))
         else
            if univar then
               for i := 1 : trms do
                  p := addsq(p, multsq(apply_c c,
                                       !*kp2q(v, apply_e e)))
            else
               for i := 1 : trms do
                  (if numr cc then p := addsq(p, <<
                     for each vv in v do
                        cc := multsq(cc, !*kp2q(vv, apply_e e));
                     cc >> ))
                  where cc = apply_c c
      else   % s eq 'dense
         if univar then <<  p := apply_c c;
            if o > 0 then p := multsq(p, mksq(v,o));
            for i := o + 1 : d do
               p := addsq(p, multsq(apply_c c, mksq(v,i))) >>
         else
            for each x in rand!-mons!-dense(v,d,o) do
               p := addsq(p, multsq(apply_c c, x ./ 1));
      return
         % Make any necessary substitutions for temporary variables:
         if sublist then
            simp!* subeval append(sublist, {mk!*sq p})
         else p
   end;

symbolic procedure functionp f;
   % Returns t if f can be applied as a function.
   getd f or eqcar(f,'lambda);

symbolic procedure natnump n;
   % Returns t if n is a natural number.
   fixp n and n >= 0;

symbolic smacro procedure kp2f(k, p);
   % k : unique kernel, p : natural number > 0
   % Returns k^p as a standard form, taking account of
   % both asymptotic let rules and weightings.
   numr mksq(k, p);

symbolic procedure !*kp2f(k, p);
   % k : unique kernel, p : natural number
   % Returns k^p as a standard form, taking account of
   % both asymptotic let rules and weightings.
   if p > 0 then kp2f(k, p) else 1;

symbolic procedure !*kp2q(k, p);
   % k : unique kernel, p : any integer
   % Returns k^p as a standard quotient, taking account of
   % both asymptotic let rules and weightings.
   if p > 0 then mksq(k, p)
   else if zerop p then 1 ./ 1
   else
      % Is this the right behaviour?
      % cf. part of procedure invsq in POLY.RED
      if null numr(k := mksq(k, -p)) then RedErr "Zero divisor"
      else revpr k;


symbolic procedure rand!-mons!-dense(v, d, o);
   % v : list of variables,
   % d : max total degree, o : min total degree.
   % Recursively returns a dense list of multivariate monomials
   % with total degree in [o, d] as STANDARD FORMS.
   begin scalar v_1;  v_1 := car v;  v := cdr v;
      return
         if null v then  % single variable
            (if o > 0 then kp2f(v_1,o) else 1)
            . for i := o + 1 : d collect kp2f(v_1,i)
         else append( rand!-mons!-dense(v, d, o),
            for i := 1 : d join
               (for each x in rand!-mons!-dense(v, d - i, max(0, o - i))
                  collect multf(v_1!^i, x))
                     where v_1!^i = kp2f(v_1,i) )
   end;


symbolic procedure rand!-mons!-sparse(v, trms, d, o, univar);
   % v : (list of) variable(s), trms: number of terms,
   % d : max total degree, o : min total degree.
   % Returns a sparse list of at most trms monomials
   % with total degree in [o, d] as STANDARD FORMS.
   begin scalar n, v_1, maxtrms, otrms, s;
      if univar then maxtrms := d + 1 - o else <<
         n := length v;  v_1 := car v;
         otrms := if zerop o then 0 else binomial(n + o - 1, n);
            % max # terms to degree o-1:
         maxtrms := binomial(n + d, n) - otrms
            % max # terms in poly := max # terms to degree d - otrms
      >>;
      % Choose a random subset of the maxtrms terms by "index":
      s := rand!-comb(maxtrms, min(maxtrms,trms));
      return
      if univar then
         for each ss in s collect !*kp2f(v, ss + o)
      else
         for each ss in s collect
         begin scalar p;  p := 1;
            % Convert term "index" to exponent vector:
            ss := nil . inttovec(ss + otrms, n);
            for each vv in v do
               p := multf(!*kp2f(vv, car(ss := cdr ss)), p);
            return p
         end
   end;


% Support procedures for randpoly
% ===============================

global '(!_BinomialK !_BinomialB !_BinomialN);

% binomial in the specfn package is implemented as an algebraic
% operator, and I suspect is not very efficient.  It will not clash
% with the following implementation, which is about 50% faster on
% my PC for binomial(200, 100) (with its caching disabled);

symbolic procedure binomial(n, k);
   % Returns the binomial coefficient ASSUMING n, k integer >= 0.
   begin scalar n1, b;
      % Global !_BinomialK, !_BinomialB, !_BinomialN
      if k = 0 then return 1;
      if n < 2*k then return binomial(n,n-k);
      n1 := n+1;
      if !_BinomialN = n then <<        % Partial result exits ...
         b := !_BinomialB;
         if !_BinomialK <= k then
            for i := !_BinomialK+1 : k do
               b := quotient((n1-i)*b,i)
         else
            for i := !_BinomialK step -1 until k+1 do
               b := quotient(i*b,n1-i) >>
      else <<                           % First binomial computation
         b := 1;
         for i := 1 : k do
            b := quotient((n1-i)*b,i);
         !_BinomialN := n >>;
      !_BinomialK := k;
      return !_BinomialB := b
   end;


symbolic procedure rand!-comb(n, m);
   % Returns a list containing a random combination of m of the
   % first n NATURAL NUMBERS, ASSUMING integer n >= m >= 0.
   % (The values returned are 1 less than those
   % returned by the Maple randcomb function.)
   if m = n then for i := 0 : m - 1 collect i
   else begin scalar s;
      if n - m < m then
      begin scalar r;
         r := rand!-comb(n, n - m);
         for rr := 0 : n - 1 do
            if not(rr member r) then s := rr . s
      end
      else
         for i := 0 : m - 1 do
         begin scalar rr;
            while (rr := random n) member s do; % nothing
            s := rr . s
         end;
      return s
   end;


symbolic procedure inttovec(m, n);
   % Returns the m'th (in lexicographic order) list of n
   % non-negative integers, ASSUMING integer m >= 0, n > 0.
   inttovec1(n, inttovec!-solve(n,m));

symbolic procedure inttovec1(n, dm);
   % n > 0 : integer;  dm : dotted pair, d . m', where
   % d = norm of vector in N^n and m' = index of its tail in N^{n-1}.
   % Returns list representing vector in N^n, constructed recursively.
   % First vector element v_1 satisfies v_1 = d - norm of tail vector.
   if n = 1 then car dm . nil else
      ( (car dm - car dm1) . inttovec1(n - 1, dm1) )
         where dm1 = inttovec!-solve(n - 1, cdr dm); % dotted pair

symbolic procedure inttovec!-solve(n, m);
   % n > 0, m >= 0 : integer
   % Main subalgorithm to compute the vector in N^n with index m.
   % Returns as a dotted pair d . m' the norm (total degree) d in N^n
   % and the index m' of the tail sub-vector in N^{n-1}.
   % d is computed to satisfy ^{d-1+n}C_n <= m < ^{d+n}C_n,
   % where ^{d+n}C_n = number of n-vectors of norm d.
   if m = 0 or n = 1 then m . 0 else
   begin scalar d, c, cc;
      d := 0;  cc := 1;  % cc = ^{d+n}C_n
      repeat <<
         c := cc;  d := d + 1;          % c  = ^{d+n}C_n
         cc := quotient((n + d)*c, d);  % cc = ^{d+1+n}C_n
      >> until cc > m;
      return d . (m - c)
   end;


% Support for anonymous procedures (`proc's),
% ==========================================
% especially random number generators.
% ===================================

% Based partly on Maple's proc and rand function, and intended mainly
% for use with the randpoly operator.

% Interval code based on numeric.red and gnuplot.red by Herbert Melenk.
% Create .. infix operator, avoiding warning if already defined.
% (It is pre-defined via plot/plothook.sl at least in PSL-REDUCE.)

newtok '( (!. !.) !*interval!*);

precedence .., or;

algebraic operator ..;

put('!*interval!*, 'PRTCH, '! !.!.! );

put('rand, 'psopfn, 'rand);

symbolic procedure rand u;
   % Returns a random number generator, and compiles it if COMP is on.
   % Optional second argument generates a named procedure.
   if null u or (cdr u and cddr u) then
      RedErr "rand takes 1 or 2 arguments"
   else begin scalar fname, fn;
      if cdr u and not idp(fname := reval cadr u) then
         typerr(fname, "procedure name");
      fn := if fixp(u := reval car u) and u > 0 then {'random, u}
      else if eqcar(u,'!*interval!*) then
      begin scalar a, b;
        if not(fixp(a := cadr u) and fixp(b := caddr u) and a>
      else if !*comp then putd(gensym(), 'expr, fn)
      else fn
   end;


% Redefine the algebraic-mode random operator.
remflag('(random), 'opfn);
put('random, 'psopfn, 'evalrandom);

symbolic procedure evalrandom u;
   % More flexible interface to the random function.
   if null u or cdr u then RedErr "random takes a single argument"
   else if eqcar(u := reval car u,'!*interval!*) then
   begin scalar a, b;
     if not(fixp(a := cadr u) and fixp(b := caddr u) and a < b) then
     RedErr
     "random range argument a .. b must have integer a,b with a < b";
     return if zerop a then random(b + 1) else a + random(b - a + 1)
   end
   else if fixp u and u > 0 then random u
      % N.B. random also makes this check, but does not accept a range
   else typerr(u, "integer or integer range");


% Proc turns its argument expression into a lambda expression
% and compiles it if COMP is ON.  Provides a general version of rand.
% Some such mechanism is necessary to prevent expressions containing
% random number generators being evaluated too early.

put('proc, 'psopfn, 'proc);

symbolic procedure proc u;
   % Returns an anonymous procedure definition,
   % compiled if COMP is ON.
   if null u then RedErr "proc requires at least a body argument"
   else <<
      % aeval!* necessary instead of aeval here to avoid caching
      % and hence loss of possible randomness within loops:
      u := {'lambda, nil, {'aeval!*, mkquote car u}};
      if !*comp then putd(gensym(), 'expr, u) else u
   >>;


% User access procedures to evaluate and display procs etc.
% ========================================================
% Not necessary -- provided only for test purposes and curious users!

put('evalproc, 'psopfn, 'evalproc);

symbolic procedure evalproc r;
   % r : proc, arg_1, ..., arg_n; args optional
   % Evaluates a proc applied to the subsequent arguments.
   apply(getproc car r, revlis cdr r);

put('showproc, 'psopfn, 'showproc);

symbolic procedure showproc r;
   % Displays a proc.
   (if codep rr then
      RedErr "Argument is a compiled proc -- cannot display"
   else << terpri(); rprint subst('plus, 'plus2, rr); >>)
      where rr = getproc car r;

symbolic procedure getproc r;
   % Support procedure: get a proc body.
   (  if idp r then
         getfnbody r or
         ( (r := get(r, 'avalue)) and car r eq 'scalar
            and eqcar(r := cadr r, 'lambda) and r ) or
         getfnbody r
      else if pairp r then
         if car r eq 'lambda then r  % share variable
         else if eqcar(r := ( (if x then apply(x, {cdr r}))
            where x = get(car r, 'psopfn) ), 'lambda) then r )
   or RedErr "Argument is not a proc";

symbolic procedure getfnbody r;
   (r := getd r) and cdr r;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/misc.red0000644000175000017500000000256611526203062023077 0ustar  giovannigiovannimodule misc;    % Miscellaneous algebraic code.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(misc),nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/randpoly.tst0000644000175000017500000000306411526203062024026 0ustar  giovannigiovanni% randpoly.tst

% F.J.Wright@Maths.QMW.ac.uk, 14 July 1994

off allfac;  on div, errcont;

% Univariate:
% ----------
randpoly x;
% Equivalent to above:
randpoly {x};
randpoly(x, dense);  % univariate default already dense
randpoly(x, degree=10, ord=5);

% Bivariate:
% ---------
% Default is sparse
randpoly {x,y};
randpoly({x,y}, dense);
randpoly({x,y}, degree=10);
% Lots of terms:
randpoly({x,y}, dense, degree=10);
randpoly({x,y}, dense, degree=10, ord=5);
% Sparse:
randpoly({x,y}, deg=10, ord=5);
% Dense again:
randpoly({x,y}, terms=1000, maxdeg=10, mindeg=5);

% Exponent and coefficient functions:
% ----------------------------------
randpoly({x,y}, expons = rand(-10 .. 10));
% Trivial example:
randpoly({x,y}, expons = proc 5);
randpoly({x,y}, expons = proc(2*random(0 .. 5)));

randpoly({x,y}, coeffs = rand(-999 .. 999));
procedure coe; randpoly(a, terms=2)$
randpoly({x,y}, coeffs = coe);
randpoly({x,y}, coeffs = coe, degree = 10);

% Polynomials composed with general expressions:
% ---------------------------------------------
randpoly({x,y^2});
randpoly(x^2 - y^2);
% This should give the constant term:
sub(x=y, ws);
randpoly({x^2 - a^2, y - b});
% This should give the constant term:
sub(x=a, y=b, ws);

% Polynomials with specified zeros:
% --------------------------------
randpoly(x = a);
% This should give 0:
sub(x=a, ws);
randpoly({x = a, y = b});
% This should give 0:
sub(x=a, y=b, ws);

% Invalid input detection:
% -----------------------
randpoly({x,y}, degree=foo);
randpoly({x,y}, foo);
randpoly({x,y}, degree=-5);

on allfac;  off div, errcont;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compactf.red0000644000175000017500000002277511526203062023744 0ustar  giovannigiovannimodule compactf; % Algorithms for compacting algebraic expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(frlis!* mv!-vars!*);

global '(!*trcompact);

switch trcompact;

% Interface to REDUCE simplifier.

put('compact,'simpfn,'simpcompact);

symbolic procedure simpcompact u;
   begin scalar bool;
      if null u or null cdr u
       then rerror(compact,1,
                   list("Wrong number of arguments to compact"));
      if null !*exp then <>;
      u := errorset!*(list('simpcompact1,mkquote u),nil);
      if bool then !*exp := nil;
      if errorp u then rerror(compact,2,"Compact error");
      return car u
   end;

symbolic procedure simpcompact1 u;
   begin scalar v,x,y,w;
      v := simp!* car u;
      u := cadr u;
      if idp u
        then if eqcar(x := get(u,'avalue),'list)
               then u := cadr x
              else typerr(u,"list")
       else if getrtype u eq 'list then u := cdr u
       else typerr(u,"list");
      u := for each j in u collect
      << w:=t;
         if eqcar(j,'equal) or eqcar(j,'replaceby) then
         << if eqcar(y:=caddr j,'when) then
            <>;
           j:= {'difference,cadr j,y}>>;
          % propagate free variables.
         if(y:=compactfmatch2 j) then
         <>;
       j.w>>;
      for each j in u do v := compactsq(v,simp!* car j,cdr j);
      return v
   end;

symbolic procedure compactbool w;
    % Reform condtion w for later evaluation and substitution.
    % Without this reform (list (quote ~)(quote x)) would not
    % be substituted by subst('(((~ x).y)..)... .
   if atom w then w else
   if eqcar(w,'list) and cdr w and cadr w='(quote !~) then
       {'quote,{'!~,cadr caddr w}} else
   compactbool car w . compactbool cdr w;

% True beginning of compacting routines.

symbolic procedure compactsq(u,v,c);
   % U is a standard quotient, v a standard quotient for equation v=0.
   % Result is a standard quotient for u reduced wrt v=0.
   begin
      if denr v neq 1
        then msgpri("Relation denominator",prepf denr v,"discarded",
                    nil,nil);
      v := numr v;
      return multsq(compactf(numr u,v,c) ./ 1,
                    1 ./ compactf(denr u,v,c))
   end;

symbolic procedure compactf(u,v,c);
   % U is a standard form, v a standard form for an equation v=0.
   % C is a condition for applying v.
   % Result is a standard form for u reduced wrt v=0.
   begin scalar x; integer n;
      if !*trcompact
       then <>;
      while x neq u do <>;
      if !*trcompact and n>2
        then <>;
      return u
   end;

symbolic procedure compactf0(u,v,c);
 begin scalar x,y,w;
   x := kernels u;
   y := kernels v;
   if not smemq('!~,v) then return compactf1(u,v,x,y);
   for each p in compactfmatch(x,y) do
    if p and not smemq('!~,w:=sublis(p,c)) and eval w and
        not smemq('!~,w:=numr subf(v,p)) then
       u:=compactf1(u,w,x,kernels w);
   return u;
 end;

symbolic procedure compactfmatch(x,y);
 % Finds all possible matches between free variables in
 % kernels of list x and pattern list y, including incomplete,
 % inconsistent and the empty match.
   if null x or null y then '(nil) else
   begin scalar y1,z,r;
    z:=compactfmatch(x,cdr y);
    if not smemq('!~,car y) then return z;
    y1:=car y; y:= cdr y;
    r:=for each x1 in x join
     for each w in compactfmatch1(x1,y1) join
      for each q in compactfmatch(delete(x1,x),sublis(w,y)) collect
       union(w,q);
    return union(r,z);
    end;

symbolic procedure compactfmatch1(x,y);
   if car y = '!~ then {{y.x}} else
   if pairp x and car x=car y then
     mcharg(cdr x,cdr y,car y)
         where frlis!* =nconc(compactfmatch2 y,frlis!*);

symbolic procedure compactfmatch2 y;
   if atom y then nil else
   if car y = '!~ then {y} else
   append(compactfmatch2(car y),compactfmatch2(cdr y));

symbolic procedure compactf1(u,v,x,y);
   begin scalar z;
    %  x := kernels u;
    %  y := kernels v;
      z := intersection(x,y);                 % find common vars.
      if null z then return u;
%  Unfortunately, it's too expensive in space to generate all perms.
%  as in this example:
%       l:={-c31*c21+c32*c22+c33*c23+c34*c24=t1};
%       x:= -c31*c21+c32*c22+c33*c23+c34*c24;
%       compact(x,l);     % out of heap space
%     for each j in permutations z do u := compactf11(u,v,x,y,j);
      return compactf11(u,v,x,y,z)
%     return u
   end;

symbolic procedure compactf11(u,v,x,y,z);
   begin scalar w;
      if domainp u then return u;
      y := append(z,setdiff(y,z));            % vars in eqn.
      x := append(setdiff(x,z),y);            % all vars.
      x := setkorder x;
      u := reorder u;                         % reorder expressions.
      v := reorder v;
      z := comfac!-to!-poly comfac u;
      u := quotf(u,z);
      u := remchkf(u,v,y);
      w := compactf2(u,mv!-reduced!-coeffs sf2mv(v,y),y);
      if termsf w < termsf u then u := w;
      % Now reduce z (required, e.g. for compact(u1*(h0+h1),{h0+h1=z1}))
      if not kernlp z
        then <>;
      u := multf(z,u);
      setkorder x;
      u := reorder u;
      if !*trcompact
       then <>;
      return u
   end;

symbolic procedure remchkf(u,v,vars);
   % This procedure returns u after checking if a smaller remainder
   % results after division by v.  It is potentially inefficient, since
   % we check all the way down the list, term by term.  However, the
   % process terminates when we no longer have any relevant kernels.
   (if domainp x or null intersection(kernels u,vars) then x
     else lt x .+ remchkf(red x,v,vars))
   where x=remchkf1(u,v);

symbolic procedure remchkf1(u,v);
   begin integer n;
      n := termsf u;
      v := xremf(u,v,n);
      if null v or termsf(v := car v)>=n then return u
       else if !*trcompact then prin2t "*** Remainder smaller";
      return v
   end;

symbolic procedure xremf(u,v,m);
   % Returns the quotient and remainder of U divided by V, or NIL if
   % the number of terms in the remainder exceeds M.
   % The goal is to keep terms u+terms z<=m.
   % There is some slop in the count, so one must check sizes on
   % leaving.
   begin integer m1,m2,n; scalar x,y,z;
        if domainp v then return list cdr qremd(u,v);
        m2 := termsf u;
    a:  if m<= 0 then return nil
         else if domainp u then return list addf(z,u)
         else if mvar u eq mvar v
          then if (n := ldeg u-ldeg v)<0 then return list addf(z,u)
                else <>
         else if not ordop(mvar u,mvar v) then return list addf(z,u);
        m := m+m1;
        x := xremf(lc u,v,m);
        if null x then return nil;
        z := addf(z,multpf(lpow u,car x));
        m1 := termsf z;
        m := m-m1;
        u := red u;
        go to a
   end;

symbolic procedure compactf2(u,v,vars);
  % U is standard form for expression, v for equation. W is ordered
  % list of variables in v. Result is a compacted form for u.
    if domainp u then u
     else if mvar u memq vars then compactf3(u,v,vars)
     else lpow u .* compactf2(lc u,v,vars) .+ compactf2(red u,v,vars);

symbolic procedure compactf3(u,v,vars);
   begin scalar mv!-vars!*;
      mv!-vars!* := vars;
      return mv2sf(mv!-compact(sf2mv(u,vars),v,nil),vars)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/sets.rlg0000644000175000017500000000476611527635055023154 0ustar  giovannigiovanniFri Feb 18 21:27:53 2011 run on win32
%% sets.tst

%% Author: F.J.Wright@Maths.QMW.ac.uk
%% Date: 20 Feb 1994

%% Test of REDUCE sets package, based on the examples on page 51 of
%% the "Maple V Language Reference Manual"
%% by Char, Geddes, Gonnet, Leong, Monagan and Watt (Springer, 1991).

%% The output (especially of symbolic set expressions) looks better
%% using PSL-REDUCE under MS-Windows or X in graphics mode.

%% Note that REDUCE supports n-ary symbolic infix operators,
%% does not require any special quoting to use an infix operator
%% as a prefix operator, and supports member as an infix operator.
%% However, REDUCE ALWAYS requires  evalb  to explicitly evaluate a
%% Boolean expression outside of a conditional statement.
%% Maple 5.2 does not provide any subset predicates.

clear a, b, c, x, y, z;



s := {x,y} union {y,z};


s := {x,y,z}

% s := {x,y,z}

t := union({x,y},{y,z});


t := {x,y,z}

% t := {x,y,z}

evalb(s = t);


true

% true

evalb(s set_eq t);


true

% true

evalb(member(y, s));


true

% true

evalb(y member s);


true

% true

evalb(y member {x*y, y*z});


false

% false

evalb(x*y member {x*y, y*z});


true

% true

{3,4} union a union {3,7} union b;


{3,4,7} union a union b

% {3,4,7} union a union b

{x,y,z} minus {y,z,w};


{x}

% {x}

a minus b;


a\b

% a\b

a\b;


a\b

% a\b

minus(a,a);


{}

% {}

{x,y,z} intersect {y,z,w};


{y,z}

% {y,z}

intersect(a,c,b,a);


a intersection b intersection c

% a intersection b intersection c

%% End of Maple examples.

(a union b) intersect c where set_distribution_rule;


a intersection c union b intersection c

% a intersection c union b intersection c

algebraic procedure power_set s;
   %% Power set of a set as an algebraic list (inefficiently):
   if s = {} then {{}} else
      {s} union for each el in s join power_set(s\{el});


power_set


power_set{};


{{}}

power_set{1};


{{1},{}}

power_set{1,2};


{{2},{1,2},{1},{}}

power_set{1,2,3};


{{3},{2,3},{2},{1,3},{1,2,3},{1,2},{1},{}}



evalb 1;


true

% true

evalb 0;


false

% false

evalb(a = a);


true

% true

evalb(a = b);


false

% false

evalb(2 member {1,2} union {2,3});


true

% true

evalb({2} member {1,2} union {2,3});


false

% false

evalb({1,3} subset {1,2} union {2,3});


true

% true

evalb(a subset a union b);


true

% true

evalb(a subset_eq a union b);


true

% true

evalb(a set_eq a union b);


false

% false

evalb(a\b subset a union c);


true

% true

mkset{1,2,1};


{1,2}

% {1,2}

end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 5 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie.tst0000644000175000017500000000326211526203062022747 0ustar  giovannigiovanni% test file for the Lie package

% 1. n-dimensional Lie algebras with dimL1=1
% n=6

array lienstrucin(6,6,6)$

lienstrucin(1,2,2):=lienstrucin(1,2,6):=lienstrucin(1,5,2):=-1$
lienstrucin(1,5,6):=lienstrucin(2,5,3):=lienstrucin(2,5,5):=-1$
lienstrucin(1,2,3):=lienstrucin(1,2,5):=lienstrucin(1,5,3):=1$
lienstrucin(1,5,5):=lienstrucin(2,5,2):=lienstrucin(2,5,6):=1$

liendimcom1(6);

% transformation matrix

lientrans;

clear lienstrucin$

% n=8

array lienstrucin(8,8,8)$

lienstrucin(1,2,2):=lienstrucin(1,5,2):=lienstrucin(2,4,3):=1$
lienstrucin(2,4,5):=lienstrucin(4,5,2):=1$
lienstrucin(1,2,3):=lienstrucin(1,2,5):=lienstrucin(1,5,3):=-1$
lienstrucin(1,5,5):=lienstrucin(2,4,2):=lienstrucin(4,5,3):=-1$
lienstrucin(4,5,5):=-1$
lienstrucin(1,2,6):=lienstrucin(1,5,6):=lienstrucin(4,5,6):=5$
lienstrucin(2,4,6):=-5$

liendimcom1(8);

% same with verbose output

on tr_lie$

liendimcom1(8);

clear lienstrucin$

off tr_lie$

% 2. 4-dimensional Lie algebras

% Korteweg-de Vries Equation: u_t+u_{xxx}+uu_x=0
% symmetry algebra spanned by four vector fields:
% v_1=d_x, v_2=d_t, v_3=td_x+d_u, v_4=xd_x+3td_t-2ud_u

array liestrin(4,4,4)$

liestrin(1,4,1):=liestrin(2,3,1):=1$
liestrin(2,4,2):=3$
liestrin(3,4,3):=-2$

lieclass(4);

clear liestrin$


% dimL1=3, dimL2=3

array liestrin(4,4,4)$

liestrin(1,2,1):=-6$liestrin(1,2,3):=-2$liestrin(1,2,4):=6$
liestrin(1,3,1):=-1$liestrin(1,3,2):=1$liestrin(1,3,4):=1$
liestrin(2,3,1):=-3$liestrin(2,3,4):=2$
liestrin(2,4,1):=6$liestrin(2,4,3):=2$liestrin(2,4,4):=-6$
liestrin(3,4,1):=1$liestrin(3,4,2):=-1$liestrin(3,4,4):=-1$

lieclass(4);

% same with verbose output

on tr_lie$

lieclass(4);

% transformation matrix

liemat;

clear liestrin$

off tr_lie$


end$


mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/dfpart.tex0000644000175000017500000001626611526203062023454 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{DFPART: A Package for Calculating with Derivatives of 
Generic Functions}
\date{}
\author{
H. Melenk \\[0.05in]
Konrad--Zuse--Zentrum \\
f\"ur Informationstechnik Berlin \\
Takustra\"se 7 \\
D--14195 Berlin--Dahlem \\
Federal Republic of Germany \\[0.05in]
Email:  melenk@zib.de}

\begin{document}
\maketitle

\index{derivatives} 
\index{partial derivatives}
\index{generic function}

The package {\tt DFPART} supports computations with total and partial
derivatives of formal function objects. Such computations can
be useful in the context of differential equations or
power series expansions.

\section{Generic Functions}

A generic function is a symbol which represents a mathematical
function. The minimal information about a generic function 
function is the number of its arguments. In order to facilitate
the programming and for a better readable output this package
assumes that the arguments of a generic function have default
names such as $f(x,y)$,$q(rho,phi)$. 
A generic function is declared by prototype form in a statement

\vspace{.1in}
 {\tt GENERIC\_FUNCTION} $fname(arg_1,arg_2\cdots arg_n)$;
\vspace{.1in}

\noindent
where $fname$ is the (new) name of a function and $arg_i$ are
symbols for its formal arguments. 
In the following $fname$ is referred to as ``generic function",
$arg_1,arg_2\cdots arg_n$ as ``generic arguments" and
$fname(arg_1,arg_2\cdots arg_n)$ as ``generic form".
Examples:

\begin{verbatim}
   generic_function f(x,y);
   generic_function g(z);
\end{verbatim}


After this declaration {\REDUCE} knows that 
\begin{itemize}
\item there are formal partial derivatives $\frac{\partial f}{\partial x}$,
$\frac{\partial f}{\partial y}$ $\frac{\partial g}{\partial z}$
and higher ones, while partial derivatives of $f$ and $g$
with respect to other variables are assumed as zero,
\item expressions of the type $f()$, $g()$ are abbreviations for
$f(x,y)$, $g(z)$,
\item expressions of the type $f(u,v)$ are abbreviations for\\
$sub(x=u,y=v,f(x,y))$
\item a total derivative $\frac{d f(u,v)}{d w}$ has to be computed
as $\frac{\partial f}{\partial x} \frac{d u}{d w} +
    \frac{\partial f}{\partial y} \frac{d v}{d w}$
\end{itemize}

\section{Partial Derivatives}

The operator {\tt DFP} represents a partial derivative:

\vspace{.1in}
 {\tt DFP}($expr,{dfarg_1,dfarg_2\cdots dfarg_n}$);
\vspace{.1in}

\noindent
where $expr$ is a function expression and $dfarg_i$ are
the differentiation variables. Examples:

\begin{verbatim}
    dfp(f(),{x,y});
\end{verbatim}
means $\frac{\partial ^2 f}{\partial x \partial y}$ and
\begin{verbatim}
    dfp(f(u,v),{x,y});
\end{verbatim}
stands for $\frac{\partial ^2 f}{\partial x \partial y} (u,v)$.
For compatibility with the $DF$ operator the differentiation
variables need not be entered in list form; instead the syntax
of {\tt DF} can be used, where the function expression is followed
by the differentiation variables, eventually with repetition
numbers. Such forms are interenally converted to the above
form with a list as second parameter.

The expression $expr$ can be a generic function
with or without arguments, or an arithmetic expression built
from generic functions and other algebraic parts. In the
second case the standard differentiation rules are applied
in order to reduce each derivative expressions to a minimal
form.

When the switch {\tt NAT} is on partial derivatives of generic
functions are printed in standard index notation, that is
$f_{xy}$ for $\frac{\partial ^2 f}{\partial x \partial y}$
and $f_{xy}(u,v)$ for $\frac{\partial ^2 f}{\partial x \partial y}(u,v)$.
Therefore single characters should be used for the arguments
whenever possible. Examples:

\begin{verbatim}

  generic_function f(x,y);
  generic_function g(y);
  dfp(f(),x,2);

  F
   XX

  dfp(f()*g(),x,2);

  F  *G()
   XX

  dfp(f()*g(),x,y);

  F  *G() + F *G
   XY        X  Y

\end{verbatim}

The difference between partial and total derivatives is
illustrated by the following example:

\begin{verbatim}
  generic_function h(x);
  dfp(f(x,h(x))*g(h(x)),x);

  F (X,H(X))*G(H(X))
   X

  df(f(x,h(x))*g(h(x)),x);

  F (X,H(X))*G(H(X)) + F (X,H(X))*H (X)*G(H(X))
   X                    Y          X

   + G (H(X))*H (X)*F(X,H(X))
      Y        X
\end{verbatim}

Cooperation of partial derivatives and Taylor series under
a differential side relation $\frac{dq}{dx}=f(x,q)$:

\begin{verbatim}
  load_package taylor;
  operator q; 
  let df(q(~x),x) => f(x,q(x));
  taylor(q(x0+h),h,0,3);

                         F (X0,Q(X0)) + F (X0,Q(X0))*F(X0,Q(X0))
                          X              Y                         2
Q(X0) + F(X0,Q(X0))*H + -----------------------------------------*H
                                            2

+ (F  (X0,Q(X0)) + F  (X0,Q(X0))*F(X0,Q(X0))
    XX              XY

    + F (X0,Q(X0))*F (X0,Q(X0)) + F  (X0,Q(X0))*F(X0,Q(X0))
       X            Y              YX

                               2               2                 3
    + F  (X0,Q(X0))*F(X0,Q(X0))  + F (X0,Q(X0)) *F(X0,Q(X0)))/6*H
       YY                           Y

      4
 + O(H )

\end{verbatim}

Normally partial differentials are assumed as non-commutative

\begin{verbatim}
  dfp(f(),x,y)-dfp(f(),y,x);

  F   - F
   XY    YX
\end{verbatim}

However, a generic function can be declared to have globally
interchangeable partial derivatives using the declaration 
{\tt DFP\_COMMUTE}
which takes the name of a generic function or a generic function
form as argument. For such a function differentiation variables are
rearranged corresponding to the sequence of the generic variables.

\begin{verbatim}
  generic_function q(x,y);
  dfp_commute q(x,y);
  dfp(q(),{x,y,y}) + dfp(q(),{y,x,y}) + dfp(q(),{y,y,x});

  3*Q
     XYY
\end{verbatim}

If only a part of the derivatives commute, this has to be
declared using the standard {\REDUCE} rule mechanism. Please
note that then the derivative variables must be written as
list.

\section{Substitutions}

When a generic form or a {\tt DFP} expression takes part in a 
substitution the following steps are performed:
\begin{enumerate}
\item The substitutions are performed for the arguments. If the
argument list is empty the substitution is applied to the
generic arguments of the function; if these change, the resulting
forms are used as new actual arguments.
If the generic function itself is not affected by the substitution,
the process stops here.
\item If the function name or the generic function
form occurs as a left hand side in the substitution list,
it is replaced by the corresponding right hand side.
\item The new form is partially differentiated according to the
list of partial derivative variables.
\item The (eventually modified) actual parameters are substituted
into the form for their corresponding generic variables.
This substitution is done by name.
\end{enumerate}

Examples:
\begin{verbatim}
  generic_function f(x,y);
  sub(y=10,f());
 
  F(X,10)

  sub(y=10,dfp(f(),x,2));


  F  (X,10)
   XX

  sub(y=10,dfp(f(y,y),x,2));

  F  (10,10)
   XX

  sub(f=x**3*y**3,dfp(f(),x,2));

       3
  6*X*Y

  generic_function ff(y,z);
  sub(f=ff,f(a,b));

  FF(B,Z)
\end{verbatim}

The dataset $dfpart.tst$ contains more examples,
including a complete application for computing the coefficient
equations for Runge-Kutta ODE solvers.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/limits.tex0000644000175000017500000000522611526203062023467 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{A REDUCE Limits Package}
\date{}
\author{Stanley L. Kameny \\ Email: stan\%valley.uucp@rand.org}
\begin{document}
\maketitle

\index{LIMITS package}
LIMITS is a fast limit package for REDUCE for functions which are
continuous except for computable poles and singularities, based on some
earlier work by Ian Cohen and John P. Fitch.  The Truncated Power Series
package is used for non-critical points, at which the value of the
function is the constant term in the expansion around that point.
\index{l'H\^opital's rule}
l'H\^opital's rule is used in critical cases, with preprocessing of
$\infty - \infty$ forms and reformatting of product forms in order
to apply l'H\^opital's rule.  A limited amount of bounded arithmetic
is also employed where applicable.

\section{Normal entry points}
\ttindex{LIMIT}
\vspace{.1in}
\noindent {\tt LIMIT}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

This is the standard way of calling limit, applying all of the methods. The
result is the limit of EXPRN as VAR approaches LIMPOINT.


\section{Direction-dependent limits}

\ttindex{LIMIT+} \ttindex{LIMIT-}
\vspace{.1in}
\noindent {\tt LIMIT!+}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic} \\
\noindent {\tt LIMIT!-}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

If the limit depends upon the direction of approach to the {\tt LIMPOINT},
the functions {\tt LIMIT!+} and {\tt LIMIT!-} may be used.  They are
defined by:

\vspace{.1in}
\noindent{\tt LIMIT!+ (LIMIT!-)} (EXP,VAR,LIMPOINT) $\rightarrow$ \\
\hspace*{2em}{\tt LIMIT}(EXP*,$\epsilon$,0)
EXP*=sub(VAR=VAR+(-)$\epsilon^2$,EXP)

\section{Diagnostic Functions}

\ttindex{LIMIT0}
\vspace{.1in}
\noindent {\tt LIMIT0}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

This function will use all parts of the limits package, but it does not
combine log terms before taking limits, so it may fail if there is a sum
of log terms which have a removable singularity in some of the terms.

\ttindex{LIMIT1}
\vspace{.1in}
\noindent {\tt LIMIT1}(EXPRN:{\em algebraic}, VAR:{\em kernel},
LIMPOINT:{\em algebraic}):{\em algebraic}
\vspace{.1in}

\index{TPS package}
This function uses the TPS branch only, and will fail if the limit point is
singular.

\ttindex{LIMIT2}
\vspace{.1in}
\begin{tabbing}
{\tt LIMIT2}(\=TOP:{\em algebraic}, \\
\>BOT:{\em algebraic}, \\
\>VAR:{\em kernel}, \\
\>LIMPOINT:{\em algebraic}):{\em algebraic}
\end{tabbing}
\vspace{.1in}

This function applies l'H\^opital's rule to the quotient (TOP/BOT).
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rlfi.rlg0000644000175000017500000000541611527635055023123 0ustar  giovannigiovanniFri Feb 18 21:27:53 2011 run on win32
off echo,msg;

\documentstyle{article}
\begin{document}
\begin{displaymath}
\frac{a^{5}+5 a^{4} b+10 a^{3} b^{2}+10 a^{2} b^{3}+5 a b^{4}+b^{5}}{a^{4}-4 a
^{3} b+6 a^{2} b^{2}-4 a b^{3}+b^{4}}
\end{displaymath}
\begin{displaymath}
x=a^{3}+3 a^{2} b+3 a b^{2}+b^{3}
\end{displaymath}
\begin{displaymath}
\left\{
a^{3}+3 a^{2} b+3 a b^{2}+b^{3} , 3 \left(a^{2}+2 a b+b^{2}\right) , 6 \left(a
+b\right)
\right\}
\end{displaymath}
\begin{displaymath}
\left\{
\left\{
a , a^{3}+3 a^{2} b+3 a b^{2}+b^{3}
\right\} , a^{3}+3 a^{2} b+3 a b^{2}+b^{3}
\right\}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

solve(a^7-13*a+5);


Unknown: a

\end{verbatim}
\begin{displaymath}
\left\{
a={\rm root\_of} \left(a\_^{7}-13 a\_+5,a\_,tag\_1\right)
\right\}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

solve(a**(2*y)-3*a**y+2,y);


\end{verbatim}
\begin{displaymath}
\left\{
y=\left(2 {\rm arbint} _{2} i \pi +\log \,2\right)/\log \,a , y=\left(2 
{\rm arbint} _{1} i \pi \right)/\log \,a
\right\}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

off verbatim;


\end{verbatim}
\begin{displaymath}
3 \left(\frac{{\rm d}^{2}a}{{\rm d}c^{2}} a^{2}+2 \frac{{\rm d}^{2}a}{{\rm d}c
^{2}} a b+\frac{{\rm d}^{2}a}{{\rm d}c^{2}} b^{2}+2 \left(\frac{{\rm d}\,a}{
{\rm d}\,c}\right)^{2} a+2 \left(\frac{{\rm d}\,a}{{\rm d}\,c}\right)^{2} b
\right)
\end{displaymath}
\begin{displaymath}
\cos ^{2}\,\alpha +\sin ^{2}\,\alpha =1
\end{displaymath}
\begin{displaymath}
\sin \left(\alpha +\beta \right)=\cos \,\alpha \: \sin \,\beta \:+\cos \,
\beta \: \sin \,\alpha \:
\end{displaymath}
\begin{displaymath}
\frac{\partial \,{\bf \tilde{u}}^{e}}{\partial \,t}+c \frac{\partial ^{2}{\bf 
\tilde{u}}^{e}}{\partial x^{2}}+b \frac{\partial \,{\bf \tilde{u}}^{i}}{
\partial \,x}={\bf f}^{e}
\end{displaymath}
\begin{displaymath}
\frac{{\bf \tilde{u}}^{e}_{j+1,k}-{\bf \tilde{u}}^{e}_{jk}}{\delta \,t}+c 
\frac{{\bf \tilde{u}}^{e}_{j,k+1}-2 {\bf \tilde{u}}^{e}_{jk}+{\bf \tilde{u}}^{
e}_{j,k-1}}{\delta ^{2}\,x}+b \frac{{\bf \tilde{u}}^{i}_{j,k+1/2}-{\bf \tilde{
u}}^{i}_{j,k-1/2}}{\delta \,x}={\bf f}^{e}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

product(k=1,2*n+1,f(2*i k+1)\(i(2*k+1)-1));


\end{verbatim}
\begin{displaymath}
\prod _{k=1}^{2 n+1}\frac{{\bf f}^{2 i_{k}+1}}{i_{2 k+1}-1}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

int(u(e,j,k,x)*f(e,x),x);


\end{verbatim}
\begin{displaymath}
\int {\bf \tilde{u}}^{e}_{jk}\left(x\right) {\bf f}^{e}\left(x\right)\:d\,x
\end{displaymath}
\begin{verbatim}
REDUCE Input:

sum(i=0,n,sqrt u(e,i));


\end{verbatim}
\begin{displaymath}
\sum _{i=0}^{n}\sqrt {{\bf \tilde{u}}^{e}_{i}}
\end{displaymath}
\begin{verbatim}
REDUCE Input:

off latex,verbatim;


\end{verbatim}
\end{document}


Time for test: 1 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 0 4 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reacteqn.rlg0000644000175000017500000000441411527635055023766 0ustar  giovannigiovanniFri Feb 18 21:27:52 2011 run on win32
% Examples for the conversion of reaction equations to ordinary
% differential equations.

% Example taken from Feinberg (Chemical Engineering):

   species := {A1,A2,A3,A4,A5};


species := {a1,

            a2,

            a3,

            a4,

            a5}


   reac2ode {  A1 + A4 <> 2A1,       rho, beta,
               A1 + A2 <> A3,        gamma, epsilon,
               A3      <> A2 + A5,   theta, mue};


                             2
{df(a1,t)=rho*a1*a4 - beta*a1  - gamma*a1*a2 + epsilon*a3,

 df(a2,t)= - gamma*a1*a2 + epsilon*a3 + theta*a3 - mue*a2*a5,

 df(a3,t)=gamma*a1*a2 - epsilon*a3 - theta*a3 + mue*a2*a5,

                                2
 df(a4,t)= - rho*a1*a4 + beta*a1 ,

 df(a5,t)=theta*a3 - mue*a2*a5}

        
  inputmat;


[1  0  0  1  0]
[             ]
[1  1  0  0  0]
[             ]
[0  0  1  0  0]



  outputmat;


[2  0  0  0  0]
[             ]
[0  0  1  0  0]
[             ]
[0  1  0  0  1]



% Computation of the classical reaction matrix as difference
% of output and input matrix:

  reactmat := outputmat-inputmat;


            [1   0   0   -1  0]
            [                 ]
reactmat := [-1  -1  1   0   0]
            [                 ]
            [0   1   -1  0   1]



% Example with automatic generation of rate constants and automatic
% extraction of species.
 
   species := {};


species := {}

   reac2ode {  A1 + A4 <> 2A1, 
               A1 + A2 <> A3,
               A3      <> A2 + A5};

new species: a1
new species: a4
new species: a2
new species: a3
new species: a5

               2
{df(a1,t)= - a1 *rate(2) + a1*a4*rate(1) - a1*a2*rate(3) + a3*rate(4),

            2
 df(a4,t)=a1 *rate(2) - a1*a4*rate(1),

 df(a2,t)= - a1*a2*rate(3) - a2*a5*rate(6) + a3*rate(5) + a3*rate(4),

 df(a3,t)=a1*a2*rate(3) + a2*a5*rate(6) - a3*rate(5) - a3*rate(4),

 df(a5,t)= - a2*a5*rate(6) + a3*rate(5)}

 
   on rounded;


   species := {};


species := {}

   reac2ode {  A1 + A4 <> 2A1, 17.3* 22.4**1.5,
                               0.04* 22.4**1.5 };

new species: a1
new species: a4

                             2
{df(a1,t)= - 4.24064598853*a1  + 1834.07939004*a1*a4,

                          2
 df(a4,t)=4.24064598853*a1  - 1834.07939004*a1*a4}


end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 4 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reacteqn.red0000644000175000017500000001337511526203062023746 0ustar  giovannigiovannimodule reacteqn;  % REDUCE support for reaction equations.

% Author: H. Melenk
% January 1991
% Copyright (c) Konrad-Zuse-Zentrum Berlin, all rights reserved.

create!-package('(reacteqn),'(contrib misc));

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Introduce operators for chemical equations.

algebraic operator rightarrow;
newtok '((!- !>) rightarrow);
infix rightarrow;
precedence rightarrow,equal;

algebraic operator doublearrow;
newtok '((!< !>) doublearrow);
infix doublearrow;
precedence doublearrow,equal;

algebraic operator rate;


global '(species); share species;
global '(rates); share rates;

put('reac2ode,'psopfn,'r2oeval);

symbolic procedure r2oeval u;
  begin scalar r,k,x,rhs,lhs,ratel,odel,oldorder,lhsl,rhsl;
       integer rc;
    if eqcar(species,'list) then
      odel:=for each x in cdr species collect reval x . 0;
    u := reval car u;
    if not eqcar(u,'list) then typerr(u,"list of reactions");
    u := cdr u;
 loop:
    if null u then goto finis;
    r := reval car u; u := cdr u;
    if not pairp r or not memq(car r,'(rightarrow doublearrow))
       then goto synerror;
    lhs := r2speclist cadr r;
    rhs := r2speclist caddr r;
      % include new species
    for each x in append(lhs,rhs) do
               odel:=r2oaddspecies(cdr x,odel);
      % generate contribution from forward reaction.
    k := if u and (x:=reval car u) and
         not(pairp x and memq(car x,'(rightarrow doublearrow)))
          then <> else list('rate,rc:=rc+1);
    ratel := k . ratel;
    r2oreaction(lhs,rhs,k,odel);
     % eventually generate backward reaction
    if car r='doublearrow then
    <> else list('rate,rc:=rc+1);
      ratel := k . ratel;
      r2oreaction(rhs,lhs,k,odel);
    >>;
    lhsl := lhs.lhsl; rhsl := rhs.rhsl;
    goto loop;
  finis:
   ratel := reversip ratel;
   rates := 'list. ratel;
   for each x in ratel do
     if numberp x or pairp x and get(car x,'dname) then
        ratel := delete(x,ratel);
   species := 'list. for each x in odel collect car x;
   r2omat(cdr species,reversip lhsl,reversip rhsl);
   for each r in ratel do if not idp r then
        ratel:=delete(r,ratel);
   if ratel then eval list('order,mkquote ratel);
   oldorder := setkorder append(ratel,cdr species);
   odel := 'list .
     for each x in odel collect
       list('equal,list('df,car x,'t),reval cdr x);
   setkorder oldorder;
   return odel;
  synerror:
    typerr(r,"reaction");
  end;

symbolic procedure  r2omat(sp,lhsl,rhsl);
  % construct input and output matrices in REDUCE syntax.
  begin scalar m; integer nreac,nspec,j;
    nspec := length sp; nreac:= length lhsl;
    apply ('matrix,list list list('inputmat,nreac,nspec));
    apply ('matrix,list list list('outputmat,nreac,nspec));
    for i:=1:nreac do
    << for each x in nth(lhsl,i) do
       <>;
       for each x in nth(rhsl,i) do
       <>;
    >>;
  end;

symbolic procedure r2findindex(a,l); r2findindex1(a,l,1);

symbolic procedure r2findindex1(a,l,n);
   if null l then rederr "index not found" else
   if a=car l then n else r2findindex1(a,cdr l,n+1);


symbolic procedure r2speclist u;
  % convert lhs/rhs to a list of pairs (multiplicity . spec).
  <>;

symbolic procedure r2speclist1 x;
  if eqcar(x,'times) then r2speclist2(cadr x,caddr x,cdddr x)
   else 1 . x;

symbolic procedure r2speclist2(x1,x2,rst);
  if not null rst or not fixp x1 and not fixp x2 then
     typerr(append(list('times,x1,x2),rst),"species") else
     if fixp x1 then x1.x2 else x2.x1;

symbolic procedure r2oaddspecies(s,odel);
  % generate a new (empty) equation for a new species.
   if assoc(s,odel) then odel else
    <>;

symbolic procedure r2oreaction(lhs,rhs,k,odel);
  % add the contribution of one reaction to the ode's.
   begin scalar coeff,e;
     coeff := k;
     for each x in lhs do
      coeff:=aeval list('times,coeff,list('expt,cdr x,car x));
     for each x in lhs do
     <>;
     for each x in rhs do
     <>;
     return odel;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/boolean.rlg0000644000175000017500000000242311527635055023601 0ustar  giovannigiovanniFri Feb 18 21:27:23 2011 run on win32
% Test series for the boolean package.

boolean true;


1

boolean false;


0

boolean (true and false);


0

boolean (true or false);


1

boolean (x and true);


x

boolean (x and false);


0

boolean (x or true);


1

boolean (x or false);


x

boolean (not(x and y));


boolean(not(x) \/ not(y))

boolean (not(x or y));


boolean(not(x)/\not(y))

boolean (x or y or(x and y));


boolean(x \/ y)

boolean (x and y and (x or y));


boolean(x/\y)

boolean (x or (not x));


1

boolean (x and (not x));


0

boolean (x and y or not x);


boolean(not(x) \/ y)

boolean (a and b implies c and d);


boolean(not(a) \/ not(b) \/ c/\d)

boolean (a and b implies c and d, and);


boolean((not(a) \/ not(b) \/ c)/\(not(a) \/ not(b) \/ d))

boolean (a or b implies c or d);


boolean(not(a)/\not(b) \/ c \/ d)

boolean (a or b implies c or d, and,full);


boolean((a \/ not(b) \/ c \/ d)/\(not(a) \/ b \/ c \/ d)

        /\(not(a) \/ not(b) \/ c \/ d))
 

operator >;


fm:=boolean(x>v or not (u>v));


fm := boolean(not(u>v) \/ x>v)

v:=10;


v := 10

testbool fm;


boolean(not(u>10) \/ x>10)

x:=3;


x := 3

testbool fm;


boolean(not(u>10))

clear x;


x:=17;


x := 17

testbool fm;


1

clear v,x;



end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 2 4)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rlfi.bib0000644000175000017500000000233111526203062023050 0ustar  giovannigiovanni@BOOK{Knuth:84,
  AUTHOR={Donald E. Knuth},
  TITLE={The \TeX\  book},
  PUBLISHER={Addison-Wesley},
  YEAR={1984},
  ADDRESS={Reading} }

@BOOK{Lamport:86,
  AUTHOR={Leslie Lamport},
  TITLE={\LaTeX\  - A Document Preparation System},
  PUBLISHER={Addison-Wesley},
  YEAR={1986},
  ADDRESS={Reading} }

@ARTICLE{Fateman:87,
  AUTHOR={Richard J. Fateman},
  TITLE={\protect{\TeX\ } Output from MACSYMA-like Systems},
  JOURNAL={ACM SIGSAM Bulletin},
  YEAR={1987},
  VOLUME={21},
  NUMBER={4},
  NOTE={Issue \#82},
  PAGES={1-5} }

@ARTICLE{Antweiler:89,
 AUTHOR = {Werner Antweiler and Andreas Strotmann and Volker Winkelmann},
 TITLE = {A {\TeX-{REDUCE}-Interface}},
 JOURNAL = {SIGSAM Bulletin},
 YEAR = {1989},
 VOLUME = {23},
 MONTH = {February},
 PAGES = {26-33}}

@ARTICLE{Drska:90,
  AUTHOR={Ladislav Drska and Richard Liska and Milan Sinor},
  TITLE={Two practical packages for computational physics -
          \protect{GCPM, RLFI}},
  JOURNAL={Comp. Phys. Comm.},
  YEAR={1990},
  VOLUME={61},
  PAGES={225-230}}

@TECHREPORT{Hearn:95,
  AUTHOR={Anthony C. Hearn},
  TITLE={\protect{REDUCE} User's Manual, Version 3.6},
  INSTITUTION={The RAND Corporation},
  YEAR={1995},
  NUMBER={CP 78 (Rev. 7/95)},
  ADDRESS={Santa Monica} }
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie.bib0000644000175000017500000000135311526203062022670 0ustar  giovannigiovanni@INPROCEEDINGS{cssmp92,
  AUTHOR = "C. Schoebel",
  TITLE = "Classification of Real n-Dimensional Lie Algebras with a
           Low-Dimensional Derived Algebra",
  BOOKTITLE = "Proc. {Symposium on Mathematical Physics} '92",
  YEAR = 1993}
  
@ARTICLE{ntz-preprint27/92,
  AUTHOR = "F. Schoebel",
  TITLE = "The Symbolic Classification of Real Four-Dimensional Lie Algebras",
  BOOKTITLE = "NTZ-Preprint Nr.27/92",
  PUBLISHER = "Universitaet Leipzig",
  ADDRESS = "Leipzig",
  YEAR = 1992}
  
@ARTICLE{mmpreprint1979,
  AUTHOR = "M.A.H. MacCallum",
  TITLE = "On the Classification of the Real four-dimensional Lie Algebras",
  BOOKTITLE = "Preprint, Queen Mary College",
  PUBLISHER = "Queen Mary College",
  ADDRESS = "London",
  YEAR = 1979}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/ftr.red0000644000175000017500000002305211526203062022730 0ustar  giovannigiovannimodule ftr;  % Various utilities for working with files and modules.

% ACN 2008: I BELIEVE that really all this code is now historic and
% not of great current use, but there were times in the past where it
% was used to re-structure the REDUCE source files...






% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% NOTE: This module uses Standard Lisp global *RAISE as a fluid.

% This module supports several applications of file-transform.
% Currently we have:

% make-dist-files:

% module_file_split:

% downcase_file:

% trunc:


create!-package('(ftr),'(util));

fluid '(!*echo !*downcase !*upcase current!-char!* previous!-char!*
        member!-channel!* old!-channel!*);

global '(!*raise charassoc!*);

global '(dir!*);  % output directory name.

% global '(dirchar!*);

switch downcase,upcase;

dir!* := "";   % default.

% dirchar!* := "/";


% ***** utility functions *****.

symbolic procedure s!-match(u,v);
   % Returns true if list of characters u begins with same characters
   % (regardless of case) as lower case string v.
   s!-match1(u,explode2 v);

symbolic procedure s!-match1(u,v);
   null v
      or u and (car u eq car v
                   or red!-uppercasep car u
                      and red!-char!-downcase car u eq car v)
         and s!-match1(cdr u,cdr v);

symbolic procedure reverse!-chars!-to!-string u;
   compress('!" . reversip('!" . u));

symbolic procedure red!-lowercasep u;
   u memq '(!a !b !c !d !e !f !g !h !i !j !k !l !m !n !o !p !q !r !s
            !t !u !v !w !x !y !z);

symbolic procedure red!-uppercasep u;
   u memq '(!A !B !C !D !E !F !G !H !I !J !K !L !M !N !O !P !Q !R !S !T
            !U !V !W !X !Y !Z);

symbolic procedure red!-char!-downcase u;
   (if x then cdr x else u) where x = atsoc(u,charassoc!*);

symbolic procedure string!-upcase u;
   begin scalar z;
      if not stringp u then u := '!" . append(explode2 u,'(!"))
       else u := explode u;
      for each x in u do z := red!-char!-upcase x . z;
      return compress reverse z
   end;

symbolic procedure red!-char!-upcase u;
   (if x then car x else u) where x = rassoc(u,charassoc!*);


% ***** functions for manipulating regular REDUCE module files *****.

symbolic procedure module_file_split u;
   file!-transform(u,function module!-file!-split1);

symbolic procedure module!-file!-split1;
   begin scalar x,!*raise;
      while not errorp (x := errorset!*('(uread),t))
            and (x := car x) neq !$eof!$
            and x neq 'END!; do
         if x neq 'MODULE then rerror(ftr,1,"Invalid module format")
          else begin scalar ochan,oldochan,y;
             y := xread t;   % Should be module name.
             ochan:= open(concat(dir!*,concat(mkfil y,".red")),'output);
             oldochan := wrs ochan;
             prin2 "module "; prin2 y; prin2 ";";
             read!-module();
             wrs oldochan;
             close ochan
            end
   end;

symbolic procedure uread;
   begin scalar !*raise; !*raise := t; return read() end;

symbolic procedure read!-module;
   begin integer eolcount; scalar x,y;
      eolcount := 0;
   a: if errorp (x := errorset!*('(readch),t))
         or (x := car x) = !$eof!$
         or eolcount > 20
        then rerror(ftr,2,"Invalid module format")
       else if x = !$eol!$ then eolcount := eolcount+1
       else eolcount := 0;
      prin2 x;
      if x memq '(!e !E)
         then if y = '(L U D O M D N E)
                  or y = '(!l !u !d !o !m !d !n !e)
                then <>
               else y := list x
        else if x memq '(N D M O U L !n !d !m !o !u !l)
         then y := x . y
        else y := nil;
     go to a
   end;

symbolic procedure make!-dist!-files u;
   % Makes a set of distribution files from the list of packages u.
   % Setting u to packages* in $rsrc/build/packages.red makes complete
   % set.
   for each x in u do make_dist_file x;

symbolic procedure make_dist_file x;
   begin scalar !*downcase,!*echo,!*int,!*lower,msg,!*raise,ochan,
                oldochan,v;
      !*downcase := t;
      v := concat(string!-downcase x,".red");
      prin2 "Creating ";
      prin2 v;
      prin2t " ...";
      ochan := open(mkfil v,'output);
      oldochan := wrs ochan;
      evload list x;   % To get package list.
      v := get(x,'package);
      if null v then v := list x;
      for each j in v do
	 file!-transform(module2file(j,x),function write_module);
      prin2t if !*downcase then "end;" else "END;";
      wrs oldochan;
      close ochan
   end;

symbolic procedure module2file(u,v);
   % Converts the module u to a fully rooted file name with v the
   % package name, assuming files exist on $rsrc followed by path
   % defined by package given by associate of u in modules!*.
   begin scalar x;
      x := "$reduce/src/";
      for each j in get(v,'path) do
%        x := concat(x,concat(string!-downcase j,dirchar!*));
	 x := concat(x,concat(string!-downcase j,"/"));
      return concat(x,concat(string!-downcase u,".red"))
   end;

symbolic procedure write_module;
   begin scalar x; repeat (x := write!-line nil) until x eq 'done end;

symbolic procedure write!-line bool;
   begin integer countr; scalar x,y;
      countr := 0;
      % EOF kludge.
      while (x := readline()) = "" and countr<10 do countr := countr+1;
      if countr=10 then return 'done
       else if countr>0 then for i:=1:countr do terpri();
      y := explode2 x;
      if null bool and s!-match(y,"endmodule;")
%        or bool and s!-match(x,"end;")
        then <>;
               return 'done>>;
      x := y;
  a:  if null x then return terpri();
      y := car x;
  b:  if y = '!% then return <>
       else if y = '!"
        then <>
       else if y = '!!
        then <>
       else if s!-match(x,"comment")
        then <>
       else if y = '!  then
          <>;

symbolic procedure read!-trunc;
   begin integer count;
         scalar !*echo,!*int,!*raise,bool,ochan,oldochan,x;
      oldochan := wrs (ochan := open("output",'output));
      while (x := readch()) neq !$eof!$ do
         if x eq !$eol!$ then <>
          else if null bool
           then <79>>;
      write oldochan;
      close ochan
   end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie.rlg0000644000175000017500000000615611527635055022742 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
% test file for the Lie package

% 1. n-dimensional Lie algebras with dimL1=1
% n=6

array lienstrucin(6,6,6)$



lienstrucin(1,2,2):=lienstrucin(1,2,6):=lienstrucin(1,5,2):=-1$


lienstrucin(1,5,6):=lienstrucin(2,5,3):=lienstrucin(2,5,5):=-1$


lienstrucin(1,2,3):=lienstrucin(1,2,5):=lienstrucin(1,5,3):=1$


lienstrucin(1,5,5):=lienstrucin(2,5,2):=lienstrucin(2,5,6):=1$



liendimcom1(6);


{lie_algebra(2),commutative(4)}


% transformation matrix

lientrans;


[0  -1  1   0  1   -1]
[                    ]
[0  1   0   0  0   0 ]
[                    ]
[1  1   -1  0  -1  1 ]
[                    ]
[0  0   0   1  0   0 ]
[                    ]
[0  0   -1  0  0   1 ]
[                    ]
[0  0   0   0  0   1 ]



clear lienstrucin$



% n=8

array lienstrucin(8,8,8)$



lienstrucin(1,2,2):=lienstrucin(1,5,2):=lienstrucin(2,4,3):=1$


lienstrucin(2,4,5):=lienstrucin(4,5,2):=1$


lienstrucin(1,2,3):=lienstrucin(1,2,5):=lienstrucin(1,5,3):=-1$


lienstrucin(1,5,5):=lienstrucin(2,4,2):=lienstrucin(4,5,3):=-1$


lienstrucin(4,5,5):=-1$


lienstrucin(1,2,6):=lienstrucin(1,5,6):=lienstrucin(4,5,6):=5$


lienstrucin(2,4,6):=-5$



liendimcom1(8);


{heisenberg(3),commutative(5)}


% same with verbose output

on tr_lie$



liendimcom1(8);


Your Lie algebra is the direct sum of the Lie algebra H(3)

and the 5-dimensional commutative Lie algebra, where

H(3) is 3-dimensional and there exists a basis

{X(1),...,X(3)} in H(3) with:

[X(2),X(3)]=[X(2*i),X(2*i+1)]=...=[X(2),X(3)]=X(1)

The transformation into this form is:

X(1):=5*y(6) - y(5) - y(3) + y(2)

X(2):=y(1)

X(3):=y(2)

X(4):=y(4) - y(1)

X(5):=y(5) - y(2)

X(6):=y(6)

X(7):=y(7)

X(8):=y(8)

{heisenberg(3),commutative(5)}


clear lienstrucin$



off tr_lie$



% 2. 4-dimensional Lie algebras

% Korteweg-de Vries Equation: u_t+u_{xxx}+uu_x=0
% symmetry algebra spanned by four vector fields:
% v_1=d_x, v_2=d_t, v_3=td_x+d_u, v_4=xd_x+3td_t-2ud_u

array liestrin(4,4,4)$



liestrin(1,4,1):=liestrin(2,3,1):=1$


liestrin(2,4,2):=3$


liestrin(3,4,3):=-2$



lieclass(4);


{liealg(4),comtab(16),5}


clear liestrin$




% dimL1=3, dimL2=3

array liestrin(4,4,4)$



liestrin(1,2,1):=-6$

liestrin(1,2,3):=-2$

liestrin(1,2,4):=6$


liestrin(1,3,1):=-1$

liestrin(1,3,2):=1$

liestrin(1,3,4):=1$


liestrin(2,3,1):=-3$

liestrin(2,3,4):=2$


liestrin(2,4,1):=6$

liestrin(2,4,3):=2$

liestrin(2,4,4):=-6$


liestrin(3,4,1):=1$

liestrin(3,4,2):=-1$

liestrin(3,4,4):=-1$



lieclass(4);


{liealg(4),comtab(21)}


% same with verbose output

on tr_lie$



lieclass(4);


[W,X]=Y, [W,Y]=-X, [X,Y]=W

{liealg(4),comtab(21)}


% transformation matrix

liemat;


[    3          0      1     -3    ]
[                                  ]
[   - 3                       2    ]
[---------      0      0  ---------]
[ sqrt(2)                  sqrt(2) ]
[                                  ]
[   - 1         1             1    ]
[---------  ---------  0  ---------]
[ sqrt(2)    sqrt(2)       sqrt(2) ]
[                                  ]
[   -2          0      0      2    ]



clear liestrin$



off tr_lie$




end$


Time for test: 109 ms
@@@@@ Resources used: (0 2 5 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compact.rlg0000644000175000017500000001657511527635055023625 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
% Tests of the COMPACT package.

% Author: Anthony C. Hearn.

% First some simple examples.

aa := {cos(x)^2+sin(x)^2-1};


             2         2
aa := {cos(x)  + sin(x)  - 1}


xx := 2*cos(x)^2+2*sin(x)^2-2;


               2         2
xx := 2*(cos(x)  + sin(x)  - 1)


compact(xx,aa);


0


xx := (1-cos(x)^2)^4;


            8           6           4           2
xx := cos(x)  - 4*cos(x)  + 6*cos(x)  - 4*cos(x)  + 1


compact(xx,aa);


      8
sin(x)


% These examples are from Lars Hornfeldt.

% This should be cos x^10*sin x^10.

compact(((1-(sin x)**2)**5)*((1-(cos x)**2)**5)
	    *(((sin x)**2+(cos x)**2)**5),
	{cos x^2+sin x^2=1});


      10           2       4         10           8           2
sin(x)  *(10*cos(x) *sin(x)  - sin(x)   + 5*sin(x)  - 5*sin(x)  + 1)


% This example illustrates the problem in the above. It is cos(x)^6.

compact(-3cos(x)^2*sin(x)^2-sin(x)^6+1,{cos x^2+sin x^2-1});


           2       2         6
 - 3*cos(x) *sin(x)  - sin(x)  + 1


compact(s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2,
	{cos x^2+sin x^2=1});


      2           2
cos(x) *s + sin(x) *c + 1


xx := s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2
	*((sin x)**2+(cos x)**2)*(sin x)**499*(cos x)**499;


            503       499         501       501         2           2
xx := cos(x)   *sin(x)    + cos(x)   *sin(x)    - cos(x) *c - sin(x) *s

               2
       + sin(x)  + c + s


compact(xx,{cos(x)^2+sin(x)^2=1});


      501       499         2           2           2
cos(x)   *sin(x)    + cos(x) *s + sin(x) *c + sin(x)


compact((s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2)
	     *((sin x)**2+(cos x)**2)*(sin x)**499*(cos x)**499,
	 {cos x^2+sin x^2=1});


      499       499        2           2
cos(x)   *sin(x)   *(cos(x) *s + sin(x) *c + 1)


compact(df((1-(sin x)**2)**4,x),{cos x^2+sin x^2=1});


                         2       2         6
8*cos(x)*sin(x)*(3*cos(x) *sin(x)  + sin(x)  - 1)


% End of Lars Hornfeld examples.

xx := a*(cos(x)+2*sin(x))^3-w*(cos(x)-sin(x))^2;


            3             2                  2                     2
xx := cos(x) *a + 6*cos(x) *sin(x)*a - cos(x) *w + 12*cos(x)*sin(x) *a

                                     3           2
       + 2*cos(x)*sin(x)*w + 8*sin(x) *a - sin(x) *w


compact(xx,aa);


                2                                            3
11*cos(x)*sin(x) *a + 2*cos(x)*sin(x)*w + cos(x)*a + 2*sin(x) *a + 6*sin(x)*a

 - w


xx := (1-cos(x)^2)^2+(1-sin(x)^2)^2;


            4           2         4           2
xx := cos(x)  - 2*cos(x)  + sin(x)  - 2*sin(x)  + 2


compact(xx,aa);


           2       2
 - 2*cos(x) *sin(x)  + 1


xx := (c^2-1)^6+7(s-1)^4+23(c+s)^5;


       12      10       8       6       5        4         4        3  2
xx := c   - 6*c   + 15*c  - 20*c  + 23*c  + 115*c *s + 15*c  + 230*c *s

              2  3      2          4       5      4       3       2
       + 230*c *s  - 6*c  + 115*c*s  + 23*s  + 7*s  - 28*s  + 42*s  - 28*s + 8


compact(xx,{c+s=1});


 12      10       8       6       4      2
c   - 6*c   + 15*c  - 20*c  + 22*c  - 6*c  + 24


yy := (c+1)^6*s^6+7c^4+23;


       6  6      5  6       4  6      4       3  6       2  6        6    6
yy := c *s  + 6*c *s  + 15*c *s  + 7*c  + 20*c *s  + 15*c *s  + 6*c*s  + s  + 23


compact(yy,{c+s=1});


 6  6      5  6       4  6      4       3  6       2  6        6    6
c *s  + 6*c *s  + 15*c *s  + 7*c  + 20*c *s  + 15*c *s  + 6*c*s  + s  + 23


zz := xx^3+c^6*s^6$



compact(zz,{c+s=1});


 36       34        32        30         28         26          24          22
c   - 18*c   + 153*c   - 816*c   + 3081*c   - 8820*c   + 20019*c   - 37272*c

          20          18           16           14           12      11
 + 58854*c   - 81314*c   + 100488*c   - 111840*c   + 111341*c   - 6*c

          10       9          8      7          6          4          2
 - 97545*c   - 20*c  + 80439*c  - 6*c  - 53783*c  + 40608*c  - 10368*c  + 13824


xx := (c+s)^5 - 55(1-s)^2 + 77(1-c)^3 + (c+2s)^8;


       8       7          6  2        5  3    5         4  4      4
xx := c  + 16*c *s + 112*c *s  + 448*c *s  + c  + 1120*c *s  + 5*c *s

               3  5       3  2       3         2  6       2  3        2
       + 1792*c *s  + 10*c *s  - 77*c  + 1792*c *s  + 10*c *s  + 231*c

                 7        4                8    5       2
       + 1024*c*s  + 5*c*s  - 231*c + 256*s  + s  - 55*s  + 110*s + 22


% This should reduce to something like:

yy := 1 - 55c^2 + 77s^3 + (1+s)^8;


             2    8      7       6       5       4        3       2
yy :=  - 55*c  + s  + 8*s  + 28*s  + 56*s  + 70*s  + 133*s  + 28*s  + 8*s + 2


% The result contains the same number but different terms.

compact(xx,{c+s=1});


 8      7       6       5       4        3       2
s  + 8*s  + 28*s  + 56*s  + 70*s  + 133*s  - 27*s  + 118*s - 53


compact(yy,{c+s=1});


 8      7       6       5       4        3       2
s  + 8*s  + 28*s  + 56*s  + 70*s  + 133*s  - 27*s  + 118*s - 53


% Test showing order of expressions is important.

d2:= - 4*r3a**2 - 4*r3b**2 - 4*r3c**2 + 3*r3**2$



d1:=  4 * r3a**2 * r3
   +  4 * r3b**2 * r3
   +  4 * r3c**2 * r3
   + 16 * r3a * r3b * r3c
   -      r3**3$



d0:= 16 * r3a**4
   + 16 * r3b**4
   + 16 * r3c**4
   +       r3**4
   - 32 * r3a**2 * r3b**2
   - 32 * r3a**2 * r3c**2
   - 32 * r3b**2 * r3c**2
   -  8 * r3a**2 *  r3**2
   -  8 * r3b**2 *  r3**2
   -  8 * r3c**2 *  r3**2
   - 64 * r3a * r3b * r3c * r3$



alist := { c0 = d0, c1 = d1, c2 = d2}$



blist := { c2 = d2, c1 = d1, c0 = d0}$



d:= d2 * l*l + d1 * l + d0;


        2   2      2    2      2    2      2    2       3             2
d := 3*l *r3  - 4*l *r3a  - 4*l *r3b  - 4*l *r3c  - l*r3  + 4*l*r3*r3a

                  2             2                        4       2    2
      + 4*l*r3*r3b  + 4*l*r3*r3c  + 16*l*r3a*r3b*r3c + r3  - 8*r3 *r3a

            2    2       2    2                             4         2    2
      - 8*r3 *r3b  - 8*r3 *r3c  - 64*r3*r3a*r3b*r3c + 16*r3a  - 32*r3a *r3b

              2    2         4         2    2         4
      - 32*r3a *r3c  + 16*r3b  - 32*r3b *r3c  + 16*r3c


compact(d,alist);


                2
c0 + c1*l + c2*l
 % Works fine.

compact(d,blist);


    2                    2           2         3                          4
c2*l  - c2*l*r3 + 2*c2*r3  + 8*c2*r3a  + 2*l*r3  + 16*l*r3a*r3b*r3c - 5*r3

        2    2                             4         4         2    2         4
 - 24*r3 *r3a  - 64*r3*r3a*r3b*r3c + 48*r3a  + 16*r3b  - 32*r3b *r3c  + 16*r3c
 % Only c2=d2 is applied.

% This example illustrates why parallel application of the individual
% side relations is necessary.

lst:={x1=a+b+c, x2=a-b-c, x3=-a+b-c, x4=-a-b+c};


lst := {x1=a + b + c,

        x2=a - b - c,

        x3= - a + b - c,

        x4= - a - b + c}


z1:=(a+b+c)*(a-b-c)*(-a+b-c);


          3    2      2        2                2    3    2        2    3
z1 :=  - a  + a *b - a *c + a*b  + 2*a*b*c + a*c  - b  - b *c + b*c  + c
    % This is x1*x2*x3.

z2:=(a+b+c)*(a-b-c)*(-a+b-c)*(-a-b+c);


       4      2  2      2  2    4      2  2    4
z2 := a  - 2*a *b  - 2*a *c  + b  - 2*b *c  + c
   % This is x1*x2*x3*x4.

compact(z1,lst);


                       2
x1*(4*a*b + 2*c*x1 - x1 )
 % Not the best solution but better than nothing.

compact(z2,lst);


 4      2  2      2  2    4      2  2    4
a  - 2*a *b  - 2*a *c  + b  - 2*b *c  + c
 % Does nothing.

end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 10 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reacteqn.tex0000644000175000017500000001316211526203062023766 0ustar  giovannigiovanni\documentclass[a4paper]{article}

\usepackage[dvipdfm]{graphicx}
\usepackage[dvipdfm]{color}
\usepackage[dvipdfm]{hyperref}

\usepackage{reduce}


\title{REDUCE Support for Reaction Equation Systems}
\author{Herbert Melenk \\
	Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin \\
	Takustra{\ss}e 7 \\
	D--14195 Berlin--Dahlem \\
	Germany \\
	e-mail: melenk@zib.de \\
	January 1991}
\date{}

\setlength{\parindent}{0cm}

\begin{document}

\maketitle


The REDUCE package REACTEQN allows one to transform chemical reaction 
systems into ordinary differential equation systems (ode) 
corresponding to the laws of pure mass action.  \\
A single reaction equation is an expression of the form

 \meta{n1}\meta{s1} + \meta{n2}\meta{s2} + \ldots $->$ \meta{n3}\meta{s3} + \meta{n4}\meta{s4} + \ldots

 or

 \meta{n1}\meta{s1} + \meta{n2}\meta{s2} + \ldots \meta{} \meta{n3}\meta{s3} + \meta{n4}\meta{s4} + \ldots

where the \meta{si} are arbitrary names of species (REDUCE symbols)
and the \meta{ni} are positive integer numbers. The number 1
can be omitted. The connector $->$ describes a one way reaction,
while \meta{\ } describes a forward and backward reaction. \\
\ \\
A reaction system is a list of reaction equations, each of them
optionally followed by one or two expressions for the rate
constants. A rate constant can a number, a symbol or an 
arbitrary REDUCE expression. If a rate constant is missing,
an automatic constant of the form RATE(n) (where n is an
integer counter) is generated. For double reactions the
first constant is used for the forward direction, the second
one for the backward direction. \\
\ \\
The names of the species are collected in a list bound to
the REDUCE variable SPECIES. This list is automatically filled
during the processing of a reaction system. The species enter
in an order corresponding to their appearance in the reaction
system and the resulting ode's will be ordered in the same manner.  \\
\ \\
If a list of species is preassigned to the variable
SPECIES either explicitly or from previous operations, the 
given order will be maintained and will dominate the formatting
process. So the ordering of the result can be easily influenced
by the user. \\
\ \\

Syntax:

 reac2ode \{ \meta{reaction} {[},\meta{rate} {[},\meta{rate}{]}{]} 

 {[},\meta{reaction} {[},\meta{rate} {[},\meta{rate}{]}{]}{]} 

 .... 

 \};

where two rates are applicable only for \meta{} reactions. \\
\ \\
 Result is a system of explicit ordinary differential
 equations with polynomial righthand sides. As side
 effect the following variables are set: \\
\ \\
 lists:



 rates: list of the rates in the system



 species: list of the species in the system



 matrices:



 inputmat: matrix of the input coefficients



 outputmat: matrix of the output coefficients

In the matrices the row number corresponds to the input reaction 
number, while the column number corresponds to the species index.
Note: if the rates are numerical values, it will be in most cases
appropriate to select a REDUCE evaluation mode for floating
point numbers. That is \\
\ \\

 REDUCE 3.3: on float,numval;

 REDUCE 3.4: on rounded;

Inputmat and outputmat can be used for linear algebra type 
investigations of the reaction system. The classical reaction 
matrix is the difference of these matrices; however, the two 
matrices contain more information than their differences because 
the appearance of a species on both sides is not reflected by 
the reaction matrix. \\
\ \\
EXAMPLES:

\% Example taken from Feinberg (Chemical Engineering):


 species := \{A1,A2,A3,A4,A5\};


 reac2ode \{ A1 + A4 $<>$ 2A1, rho, beta,

 A1 + A2 $<>$ A3, gamma, epsilon,

 A3 $<>$ A2 + A5, theta, mue\};
 

 2

\{DF(A1,T)=RHO{*}A1{*}A4 - BETA{*}A1 - GAMMA{*}A1{*}A2 + EPSILON{*}A3,



DF(A2,T)= - GAMMA{*}A1{*}A2 + EPSILON{*}A3 + THETA{*}A3 - MUE{*}A2{*}A5,



DF(A3,T)=GAMMA{*}A1{*}A2 - EPSILON{*}A3 - THETA{*}A3 + MUE{*}A2{*}A5,


 2

DF(A4,T)= - RHO{*}A1{*}A4 + BETA{*}A1 ,


DF(A5,T)=THETA{*}A3 - MUE{*}A2{*}A5\}


\% the corresponding matrices:


 inputmat;

\begin{verbatim}

                [ 1 0 0 1 0 ]

                [           ]

                [ 1 1 0 0 0 ]

                [           ]

                [ 0 0 1 0 0 ]

\end{verbatim}

 outputmat;

\begin{verbatim}

                [ 2 0 0 0 0 ]

                [           ] 

                [ 0 0 1 0 0 ] 

                [           ] 

                [ 0 1 0 0 1 ] 

\end{verbatim}


\% computation of the classical reaction matrix as difference

\% of output and input matrix:


 reactmat := outputmat-inputmat;

\begin{verbatim}

             [ 1   0   0   -1  0 ]

             [                   ] 

REACTMAT :=  [ -1  -1  1   0   0 ] 

             [                   ] 

             [ 0   1   -1  0   1 ]

\end{verbatim}

\% Example with automatic generation of rate constants

\% and automatic extraction of species


 species := \{\};

 reac2ode \{ A1 + A4 $<>$ 2A1, 

 A1 + A2 $<>$ A3,

 a3 $<>$ A2 + A5\};


new species: A1

new species: A4

new species: A3

new species: A2

new species: A5



 2

\{DF(A1,T)= - A1 {*}RATE(2) + A1{*}A4{*}RATE(1) - A1{*}A2{*}RATE(3) + 


 A3{*}RATE(4),


 2

DF(A4,T)=A1 {*}RATE(2) - A1{*}A4{*}RATE(1),


DF(A2,T)= - A1{*}A2{*}RATE(3) - A2{*}A5{*}RATE(6) + A3{*}RATE(5) + A3{*}RATE(4),


DF(A3,T)=A1{*}A2{*}RATE(3) + A2{*}A5{*}RATE(6) - A3{*}RATE(5) - A3{*}RATE(4),


DF(A5,T)= - A2{*}A5{*}RATE(6) + A3{*}RATE(5)\}



\% Example with rates computed from numerical expressions


 species := \{\};

 reac2ode \{ A1 + A4 $<>$ 2A1, 17.3{*} 22.4\^{}1.5,

 0.04{*} 22.4\^{}1.5 \};


new species: A1

new species: A4


 2

\{DF(A1,T)= - 4.24065{*}A1 + 1834.08{*}A1{*}A4,


 2

DF(A4,T)=4.24065{*}A1 - 1834.08{*}A1{*}A4\}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/rlfi.tst0000644000175000017500000000131511526203062023127 0ustar  giovannigiovannioff echo,msg;
on latex;
((a+b)**5)\(a-b)**4;
x:=(a+b)**3;
{x,df(x,a),df(x,a,2)};
{{a,x},x};
on verbatim;
solve(a^7-13*a+5);
solve(a**(2*y)-3*a**y+2,y);
off verbatim;
depend a,c;
df(x,c,2);
defid al,name=alpha;
defid be,name=beta;
sin al**2+cos al**2=1;
sin(al+be)=sin al*cos be+cos al*sin be;
off lasimp;
defid u,font=bold,accent=tilde;
defid f,font=bold;
defid d,name=delta;
defindex u(up,down,down),f(up),i(down);
pdf(u e,t)+c*pdf(u e,x,2)+b*pdf(u i,x)=f e;
(u(e,j+1,k)-u(e,j,k))\ d t +c*(u(e,j,k+1)-2*u(e,j,k)+u(e,j,
k-1))\d(x)**2+ b*(u(i,j,k+1/2)-u(i,j,k-1/2))\d x=f e;
on verbatim;
product(k=1,2*n+1,f(2*i k+1)\(i(2*k+1)-1));
int(u(e,j,k,x)*f(e,x),x);
sum(i=0,n,sqrt u(e,i));
off latex,verbatim;
on lasimp;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/reacteqn.tst0000644000175000017500000000151311526203062023775 0ustar  giovannigiovanni% Examples for the conversion of reaction equations to ordinary
% differential equations.

% Example taken from Feinberg (Chemical Engineering):

   species := {A1,A2,A3,A4,A5};

   reac2ode {  A1 + A4 <> 2A1,       rho, beta,
               A1 + A2 <> A3,        gamma, epsilon,
               A3      <> A2 + A5,   theta, mue};
        
  inputmat;

  outputmat;

% Computation of the classical reaction matrix as difference
% of output and input matrix:

  reactmat := outputmat-inputmat;

% Example with automatic generation of rate constants and automatic
% extraction of species.
 
   species := {};
   reac2ode {  A1 + A4 <> 2A1, 
               A1 + A2 <> A3,
               A3      <> A2 + A5};
 
   on rounded;
   species := {};
   reac2ode {  A1 + A4 <> 2A1, 17.3* 22.4**1.5,
                               0.04* 22.4**1.5 };

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/redio.red0000644000175000017500000001320011526203062023231 0ustar  giovannigiovannimodule redio; % General Purpose I/O package, sorting and positioning.

% Author: Martin L. Griss.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modified by: Anthony C. Hearn.

fluid '(orig!*);

global '(!*formfeed lnnum!* maxln!* pgnum!* title!*);

% This module is functionally equivalent to the PSL file PSL-CREFIO.RED.

% FORMFEED (ON)  controls ^L or spacer of ====;

symbolic procedure initio();
% Set-up common defaults;
   begin
        !*formfeed:=t;
        orig!*:=0;
        lnnum!*:=0;
        linelength(75);
        maxln!*:=55;
        title!*:=nil;
        pgnum!*:=1;
   end;

% symbolic procedure lposn(); lnnum!*; % Actually part of Standard LISP.

initio();

symbolic procedure setpgln(p,l);
  begin if p then maxln!*:=p;
        if l then linelength(l);
  end;

% We use EXPLODE to produce a list of chars from atomname,
% and TERPRI() to terminate a buffer..all else
% done in package..spaces,tabs,etc. ;

Comment Character lists are (length . chars), for FITS;


symbolic  procedure getes u;
   % Returns for U , eee=(Length . List of char);
   begin scalar eee;
      if not idp u then return <>;
      if not(eee:=get(u,'rccnam))
        then <>;
        return eee
   end;

% symbolic smacro procedure prtwrd u;
%   if numberp u then prtnum u else prtatm u;

symbolic procedure prtatm u;
        prin2 u;        % For a nice print;

symbolic procedure prtlst u;
 if atom u then prin2 u else for each x in u do prin2 x;

symbolic procedure prtnum n;
   % We use this kludge to defeat the new line that several LISPs
   % including PSL like to insert when printing a number near the line
   % boundary.
   for each x in explode2 n do prin2 x;

symbolic procedure princn eee;
% output a list of chars, update POSN();
         while (eee:=cdr eee) do prin2 car eee;

symbolic procedure spaces n; for i:=1:n do prin2 '!  ;

symbolic procedure spaces!-to n;
   begin scalar x;
        x := n - posn();
        if x<1 then newline n
         else spaces x;
   end;

symbolic procedure setpage(title,page);
% Initialise current page and title;
   begin
        title!*:= title ;
        pgnum!*:=page;
   end;

symbolic procedure newline n;
% Begins a fresh line at posn N;
   begin
        lnnum!*:=lnnum!*+1;
        if lnnum!*>=maxln!* then newpage()
         else terpri();
        spaces(orig!*+n);
   end;

symbolic procedure newpage();
% Start a fresh page, with PGNUM and TITLE, if needed;
   begin scalar a;
%       a:=lposn();
        a := lnnum!*;
        lnnum!*:=0;
        if posn() neq 0 then newline 0;
        if a neq 0 then formfeed();
        if title!* then
          <>;
        spaces!-to (linelength(nil)-4);
        if pgnum!* then <>
         else pgnum!*:=2;
        newline 10;
        newline 0;
   end;

symbolic procedure underline2 n;
        if n>=linelength(nil) then
          <>
         else begin scalar j;
                j:=n-posn();
                for i:=0:j do prin2 '!-;
              end;

symbolic procedure lprint(u,n);
% prints a list of atoms within block LINELENGTH(NIL)-n;
   begin scalar eee; integer l,m;
        spaces!-to n;
        l := linelength nil-posn();
        if l<=0 then error(13,"WINDOW TOO SMALL FOR LPRINT");
        while u do
           <>
              else begin
                 eee := cdr eee;
              a: for i := 1:m do <>;
                 newline n;
                 if null eee then nil
                  else if length eee<(m := l) then princn(nil . eee)
                  else go to a
                end;
             if posn()>
   end;

symbolic procedure rempropss(atmlst,lst);
   for each x in atmlst do
      for each y in lst do remprop(x,y);


symbolic procedure remflagss(atmlst,lst);
   for each x in lst do remflag(atmlst,x);

symbolic procedure formfeed;
        if !*formfeed then eject()
         else <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/pf.tst0000644000175000017500000000151511526203062022602 0ustar  giovannigiovanni% Tests of the partial fraction module.

% Author: Anthony C. Hearn

off exp;

pf(2/((x+1)^2*(x+2)),x);

pf(x/((x+1)^2*(x+2)^2*(x+3)),x);

pf(x/(x^2-2x-3),x);

pf((10x^2-11x-6)/(x^3-x^2-2x),x);

pf(x^2/((x+1)*(x^2+1)),x);

pf((2x^6-11x^5+37x^4-94x^3+212x^2-471x+661)
 /(x^7-5x^6+5x^5-25x^4+115x^3-63x^2+135x-675),x);

% A harder example.

pf(((2*w**2+2*h**2*l**2*t**2+2*h**2*l**2*qst**2)*z**2-8*h**2*l**2*qst
     *t*z+2*w**2+2*h**2*l**2*t**2+2*h**2*l**2*qst**2)/((w**2+h**4*l**2)
     *((w**2+l**2*t**4+2*l**2*qst**2*t**2+l**2*qst**4)*z**4+(-8*l**2
     *qst*t**3-8*l**2*qst**3*t)*z**3+(2*w**2+2*l**2*t**4+20*l**2*
     qst**2*t**2+2*l**2*qst**4)*z**2+(-8*l**2*qst*t**3-8*l**2*qst**3
     *t)*z+w**2+l**2*t**4+2*l**2*qst**2*t**2+l**2*qst**4))
   -2*h**2/((w**2+h**4*l**2)*((t**2+qst**2+h**2)*z**2-4*qst*t*z+t**2
      +qst**2+h**2)),z);

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie.red0000644000175000017500000000311711526203062022706 0ustar  giovannigiovannimodule lie; % Header module for classification of Lie algebras.

% Author: Carsten and Franziska Schoebel.
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(lie liendmc1 lie1234),'(contrib lie));

switch tr_lie;

load!-package 'matrix;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/changevr.tex0000644000175000017500000001744311526203062023767 0ustar  giovannigiovanni\newcommand{\definedas}{\stackrel{\triangle}{=}}
\newcommand{\spc}{\;\;\;\;\;}
\newcommand{\mspc}{\;\;\;\;\;\;\;\;\;\;}
\newcommand{\lspc}{\;\;\;\;\;\;\;\;\;\;\;\;\;\;\;}

\documentstyle[fleqn,11pt]{article}

\renewcommand{\baselinestretch}{1.1}
\newcommand{\eg}[1]{\begin{quote}{\tt #1} \end{quote}}
\setlength{\textwidth}{15cm}
\addtolength{\oddsidemargin}{-1cm}

\title{                    CHANGEVR,  \\
                         A REDUCE Facility   \\
                              to   \\
                    Perform Change of Independent Variable(s)\\
                               in \\
                    Differential Equations\\[2cm]
        }
\author{
          G. \"{U}\c{c}oluk
	     \thanks{Email address: UCOLUK@TRMETU.BITNET}
                     \\
                               Department of Physics \\
                               Middle East Technical University \\
                               Ankara, Turkey
       }
\date{October 1989}

\begin{document}
\maketitle
\newpage

\section{Introduction}
The mathematics behind the change of independent variable(s) in differential
equations is quite straightforward. It is basically the application of the
chain rule. If the dependent variable of the differential equation is $F$,
the independent variables are $x_{i}$ and the new independent variables are
$u_{i}$ (where ${\scriptstyle i=1\ldots n}$) then the first derivatives are:
\[
    \frac{\partial F}{\partial x_{i}} = \frac{\partial F}{\partial u_{j}}
                                        \frac{\partial u_{j}}{\partial x_{i}}
\]
We assumed Einstein's summation convention. Here the problem is to
calculate the $\partial u_{j}/\partial x_{i}$ terms if the change of variables
is given by
\[
    x_{i} = f_{i}(u_{1},\ldots,u_{n})
\]
The first thought might be solving the above given equations for $u_{j}$ and
then differentiating them with respect to $x_{i}$, then again making use of the
equations above, substituting new variables for the old ones in the calculated
derivatives. This is not always a  preferable way to proceed. Mainly because
the functions $f_{i}$ may not always be easily invertible. Another approach
that makes use of the Jacobian is better. Consider the above given equations
which relate the old variables to the new ones. Let us differentiate them:
\begin{eqnarray*}
  \frac{\partial x_{j}}{\partial x_{i}} & = &
        \frac{\partial f_{j}}{\partial x_{i}}   \\
  \delta_{ij} & = &
        \frac{\partial f_{j}}{\partial u_{k}}
        \frac{\partial u_{k}}{\partial x_{i}}
\end{eqnarray*}
The first derivative is nothing but the $(j,k)$ th entry of the Jacobian matrix.

So if we speak in matrix language
\[ {\bf 1 = J \cdot D} \]
where we defined the Jacobian
\[ {\bf J}_{ij} \definedas  \frac{\partial f_{i}}{\partial u_{j}} \]
and the matrix of the derivatives we wanted to obtain as
\[ {\bf D}_{ij} \definedas  \frac{\partial u_{i}}{\partial x_{j}}. \]
If the Jacobian has a non-vanishing determinant then it is invertible and
we are able to write from the matrix equation above:
\[ {\bf  D = J^{-1}} \]
so finally we have what we want
\[
   \frac{\partial u_{i}}{\partial x_{j}} = \left[{\bf J^{-1}}\right]_{ij}
\]

The higher derivatives are obtained by the successive application of the chain
rule and using the definitions of the old variables in terms of the new ones. It

can be easily verified that the only derivatives that are needed to be
calculated are the first order ones which are obtained above.

\section{How to Use CHANGEVR}
{\bf This facility requires the matrix package to be present in the session}.
So if it is not autoloaded in your REDUCE implementation, say
\eg{LOAD\_PACKAGE MATRIX;}
in the REDUCE environment. Then load {\tt CHANGEVR} by the statement:
\eg{LOAD\_PACKAGE CHANGEVR\$}
Now the REDUCE function {\tt CHANGEVAR} is ready to use. {\bf Note:  The
package is named CHANGEVR, but the function has the name CHANGEVAR}.  The
function {\tt CHANGEVAR} has (at least) four different arguments.  Here we
give a list them:
\begin{itemize}
\item {\bf FIRST ARGUMENT} \\
     Is a list of the dependent variables of the differential equation.
     They shall be enclosed in a pair of curly braces and separated by commas.
     If there is only one dependent variable there is no need for the curly
     braces.
\item {\bf SECOND ARGUMENT}  \\
     Is a list of the {\bf new} independent variables. Similar to what is said
     for the first argument, these shall also be separated by commas,
     enclosed in curly braces and the curly braces can be omitted if there is
     only one new variable.
\item {\bf THIRD ARGUMENT}  \\
     Is a list of equations separated by commas, where each of the equation
     is of the form
      \eg{{\em old variable} = {\em a function in new variables}}
     The left hand side cannot be a non-kernel structure. In this argument
     the functions which give the old variables in terms of the new ones are
     introduced. It is possible to omit totally the curly braces which enclose
     the list. {\bf Please note that only for this argument it is allowed to
     omit the curly braces even if the list has \underline{more than one}
     items}.
\item {\bf LAST ARGUMENT}  \\
     Is a list of algebraic expressions which evaluates to  differential
     equations, separated by commas, enclosed in curly braces.
     So, variables in which differential equations are already stored may be
     used freely. Again it is possible to omit the curly braces if there is
     only {\bf one} differential equation.
\end{itemize}

If the last argument is a list then the result of {\tt CHANGEVAR} is also a
list.

It is possible to display the entries of the inverse Jacobian, explained
in the introduction.  To do so, turn {\tt ON} the flag {DISPJACOBIAN} by a
statement: \eg{ON DISPJACOBIAN;}

\section{AN EXAMPLE\ldots\ldots The 2-dim. Laplace Equation}
The 2-dimensional Laplace equation in cartesian coordinates is:
\[
   \frac{\partial^{2} u}{\partial x^{2}} +
   \frac{\partial^{2} u}{\partial y^{2}} = 0
\]
Now assume we want to obtain the polar coordinate form of Laplace equation.
The change of variables is:
\[
   x = r \cos \theta, \mspc  y = r \sin \theta
\]
The solution using {\tt CHANGEVAR}  (of course after it is properly loaded)
is as follows
\eg{CHANGEVAR(\{u\},\{r,theta\},\{x=r*cos theta,y=r*sin theta\}, \\
    \hspace*{2cm}     \{df(u(x,y),x,2)+df(u(x,y),y,2)\} )}
Here we could omit the curly braces in the first and last arguments (because
those lists have only one member) and the curly braces in the third argument
(because they are optional), but you cannot leave off the curly braces in the
second argument. So one could equivalently write
\eg{CHANGEVAR(u,\{r,theta\},x=r*cos theta,y=r*sin theta,        \\
    \hspace*{2cm}     df(u(x,y),x,2)+df(u(x,y),y,2) )}

If you have tried out the above example, you will notice that the denominator
contains a $\cos^{2} \theta + \sin^{2} \theta$ which is actually equal to $1$.
This has of course nothing to do with the {\tt CHANGEVAR} facility introduced
here.  One has to be overcome these pattern matching problems by the
conventional methods REDUCE provides (a {\tt LET} statement, for example,
will fix it).

Secondly you will notice that your {\tt u(x,y)} operator has changed to
{\tt u(r,theta)} in the result. Nothing magical  about this. That is just what
we do with pencil and paper. {\tt u(r,theta)} represents the  the transformed
dependent variable.

\section{ANOTHER EXAMPLE\ldots\ldots An Euler Equation}
Consider a differential equation which is of Euler type, for instance:
\[
   x^{3}y''' - 3 x^{2}y'' + 6 x y' - 6 y = 0
\]
Where prime denotes differentiation with respect to $x$. As is well known,
Euler type of equations are solved by a change of variable:
\[
   x = e^{u}
\]
So our  {\tt CHANGEVAR} call reads as follows:
\eg{CHANGEVAR(y, u, x=e**u, x**3*df(y(x),x,3)-   \\
    \hspace*{2cm}   3*x**2*df(y(x),x,2)+6*x*df(y(x),x)-6*y(x))}

\end{document}



mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/mvmatch.red0000644000175000017500000000762411526203062023603 0ustar  giovannigiovannimodule mvmatch;  % Side relation matching against expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure mv!-compact(u,v,w);
   % Compares a multivariate form u with a multivariate form template v
   % and reduces u appropriately.
   % Previously, the content was removed from u.  However, this does
   % not work well if the same content is in v.
   begin scalar x,y;   % z;
      if null u then return mv!-reverse w;
%     if null w then <>
%      else z := nzeros length mv!-lpow u . 1;
        % check first terms.
      if (x := mv!-pow!-chk(u,v))
          and (y := mv!-compact2(u,mv!-pow!-mv!-!+(x,v)))
%       then return mv!-term!-!*(z,mv!-compact(y,v,w))
        then return mv!-compact(y,v,w)
        % check second terms.
       else if (x := mv!-pow!-chk(u,mv!-red v))
          and not mv!-pow!-assoc(y := mv!-pow!-!+(x,mv!-lpow v),w)
          and (y := mv!-compact2(mv!-!.!+(mv!-!.!*(y,0),u),
                                 mv!-pow!-mv!-!+(x,v)))
%       then return mv!-term!-!*(z,mv!-compact(y,v,w))
%      else return mv!-term!-!*(z,mv!-compact(mv!-red u,v,mv!-lt u . w))
        then return mv!-compact(y,v,w)
       else return mv!-compact(mv!-red u,v,mv!-lt u . w)
   end;

symbolic procedure mv!-pow!-assoc(u,v); assoc(u,v);

symbolic procedure mv!-reverse u; reversip u;

symbolic procedure mv!-pow!-chk(u,v);
%  (u := mv!-pow!-!-(caar u,caar v)) and not mv!-pow!-minusp u and u;
   if v and (u := mv!-pow!-!-(caar u,caar v)) and not mv!-pow!-minusp u
     then u
    else nil;

symbolic procedure mv!-compact2(u,v);
   % U and v are multivariate forms whose first powlists are equal.
   % Value is a suitable multiplier of v which when subtracted from u
   % results in a more compact expression.
   begin scalar x,y,z;
      x := equiv!-coeffs(u,v);
      z := mv!-domainlist v;
      y := reduce(x,z);
      return if y=x then nil
           else mv!-!+(mv!-coeff!-replace(v,mv!-domainlist!-!-(y,x)),u)
   end;

symbolic procedure mv!-coeff!-replace(u,v);
   % Replaces coefficients of multivariate form u by those in domain
   % list v.
   if null u then nil
    else if car v=0 then mv!-coeff!-replace(mv!-red u,cdr v)
    else mv!-!.!+(mv!-!.!*(mv!-lpow u,car v),
                mv!-coeff!-replace(mv!-red u,cdr v));

symbolic procedure equiv!-coeffs(u,v);
   if null u then nzeros length v
    else if null v then nil
    else if mv!-lpow u = mv!-lpow v
     then cdar u . equiv!-coeffs(cdr u,cdr v)
    else if mv!-pow!-!>(mv!-lpow u,mv!-lpow v)
     then equiv!-coeffs(cdr u,v)
    else 0 . equiv!-coeffs(u,cdr v);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/sets.tst0000644000175000017500000000376011526203062023157 0ustar  giovannigiovanni%% sets.tst

%% Author: F.J.Wright@Maths.QMW.ac.uk
%% Date: 20 Feb 1994

%% Test of REDUCE sets package, based on the examples on page 51 of
%% the "Maple V Language Reference Manual"
%% by Char, Geddes, Gonnet, Leong, Monagan and Watt (Springer, 1991).

%% The output (especially of symbolic set expressions) looks better
%% using PSL-REDUCE under MS-Windows or X in graphics mode.

%% Note that REDUCE supports n-ary symbolic infix operators,
%% does not require any special quoting to use an infix operator
%% as a prefix operator, and supports member as an infix operator.
%% However, REDUCE ALWAYS requires  evalb  to explicitly evaluate a
%% Boolean expression outside of a conditional statement.
%% Maple 5.2 does not provide any subset predicates.

clear a, b, c, x, y, z;

s := {x,y} union {y,z};
% s := {x,y,z}

t := union({x,y},{y,z});
% t := {x,y,z}

evalb(s = t);
% true

evalb(s set_eq t);
% true

evalb(member(y, s));
% true

evalb(y member s);
% true

evalb(y member {x*y, y*z});
% false

evalb(x*y member {x*y, y*z});
% true

{3,4} union a union {3,7} union b;
% {3,4,7} union a union b

{x,y,z} minus {y,z,w};
% {x}

a minus b;
% a\b

a\b;
% a\b

minus(a,a);
% {}

{x,y,z} intersect {y,z,w};
% {y,z}

intersect(a,c,b,a);
% a intersection b intersection c

%% End of Maple examples.

(a union b) intersect c where set_distribution_rule;
% a intersection c union b intersection c

algebraic procedure power_set s;
   %% Power set of a set as an algebraic list (inefficiently):
   if s = {} then {{}} else
      {s} union for each el in s join power_set(s\{el});

power_set{};
power_set{1};
power_set{1,2};
power_set{1,2,3};


evalb 1;
% true

evalb 0;
% false

evalb(a = a);
% true

evalb(a = b);
% false

evalb(2 member {1,2} union {2,3});
% true

evalb({2} member {1,2} union {2,3});
% false

evalb({1,3} subset {1,2} union {2,3});
% true

evalb(a subset a union b);
% true

evalb(a subset_eq a union b);
% true

evalb(a set_eq a union b);
% false

evalb(a\b subset a union c);
% true

mkset{1,2,1};
% {1,2}

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compact.tst0000644000175000017500000000476411526203062023634 0ustar  giovannigiovanni% Tests of the COMPACT package.

% Author: Anthony C. Hearn.

% First some simple examples.

aa := {cos(x)^2+sin(x)^2-1};

xx := 2*cos(x)^2+2*sin(x)^2-2;

compact(xx,aa);

xx := (1-cos(x)^2)^4;

compact(xx,aa);

% These examples are from Lars Hornfeldt.

% This should be cos x^10*sin x^10.

compact(((1-(sin x)**2)**5)*((1-(cos x)**2)**5)
	    *(((sin x)**2+(cos x)**2)**5),
	{cos x^2+sin x^2=1});

% This example illustrates the problem in the above. It is cos(x)^6.

compact(-3cos(x)^2*sin(x)^2-sin(x)^6+1,{cos x^2+sin x^2-1});

compact(s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2,
	{cos x^2+sin x^2=1});

xx := s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2
	*((sin x)**2+(cos x)**2)*(sin x)**499*(cos x)**499;

compact(xx,{cos(x)^2+sin(x)^2=1});

compact((s*(1-(sin x**2))+c*(1-(cos x)**2)+(sin x)**2+(cos x)**2)
	     *((sin x)**2+(cos x)**2)*(sin x)**499*(cos x)**499,
	 {cos x^2+sin x^2=1});

compact(df((1-(sin x)**2)**4,x),{cos x^2+sin x^2=1});

% End of Lars Hornfeld examples.

xx := a*(cos(x)+2*sin(x))^3-w*(cos(x)-sin(x))^2;

compact(xx,aa);

xx := (1-cos(x)^2)^2+(1-sin(x)^2)^2;

compact(xx,aa);

xx := (c^2-1)^6+7(s-1)^4+23(c+s)^5;

compact(xx,{c+s=1});

yy := (c+1)^6*s^6+7c^4+23;

compact(yy,{c+s=1});

zz := xx^3+c^6*s^6$

compact(zz,{c+s=1});

xx := (c+s)^5 - 55(1-s)^2 + 77(1-c)^3 + (c+2s)^8;

% This should reduce to something like:

yy := 1 - 55c^2 + 77s^3 + (1+s)^8;

% The result contains the same number but different terms.

compact(xx,{c+s=1});

compact(yy,{c+s=1});

% Test showing order of expressions is important.

d2:= - 4*r3a**2 - 4*r3b**2 - 4*r3c**2 + 3*r3**2$

d1:=  4 * r3a**2 * r3
   +  4 * r3b**2 * r3
   +  4 * r3c**2 * r3
   + 16 * r3a * r3b * r3c
   -      r3**3$

d0:= 16 * r3a**4
   + 16 * r3b**4
   + 16 * r3c**4
   +       r3**4
   - 32 * r3a**2 * r3b**2
   - 32 * r3a**2 * r3c**2
   - 32 * r3b**2 * r3c**2
   -  8 * r3a**2 *  r3**2
   -  8 * r3b**2 *  r3**2
   -  8 * r3c**2 *  r3**2
   - 64 * r3a * r3b * r3c * r3$

alist := { c0 = d0, c1 = d1, c2 = d2}$

blist := { c2 = d2, c1 = d1, c0 = d0}$

d:= d2 * l*l + d1 * l + d0;

compact(d,alist); % Works fine.

compact(d,blist); % Only c2=d2 is applied.

% This example illustrates why parallel application of the individual
% side relations is necessary.

lst:={x1=a+b+c, x2=a-b-c, x3=-a+b-c, x4=-a-b+c};

z1:=(a+b+c)*(a-b-c)*(-a+b-c);    % This is x1*x2*x3.

z2:=(a+b+c)*(a-b-c)*(-a+b-c)*(-a-b+c);   % This is x1*x2*x3*x4.

compact(z1,lst); % Not the best solution but better than nothing.

compact(z2,lst); % Does nothing.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compact.red0000644000175000017500000000354711526203062023572 0ustar  giovannigiovannimodule compact;  % Header module for compact code.

% Author: Anthony C. Hearn.

% Copyright (c) 1989 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(compact mv mvmatch reddom compactf comfac),
                '(contrib compact));

% These smacros are used in more than one module.

symbolic smacro procedure mv!-!.!+(u,v); u . v;

symbolic smacro procedure mv!-!.!*(u,v); u . v;

symbolic smacro procedure mv!-lc u; cdar u;

symbolic smacro procedure mv!-lpow u; caar u;

symbolic smacro procedure mv!-lt u; car u;

symbolic smacro procedure mv!-red u; cdr u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/limits.red0000644000175000017500000006040711526203062023443 0ustar  giovannigiovannimodule limits;

%% A fast limit package for REDUCE for functions which are continuous
%% except for computable poles and singularities.

%% Author: Stanley L. Kameny.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% Revised 23 Mar 1993.  Version 1.4.

%% Modifications by:  Winfried Neun.

%% Added capability for using either the Taylor series package or the
%% Truncated Power Series Package.

%% Added provisions for transformation of certain irrational functions
%% into rational functions before limit calculation in order to be able
%% to compute series.

%% Changed the algebraic interface so that if limit package fails, an
%% equivalent of the original expression is returned.

%% Allowed for limited recursion through limsimp.

%% Corrected several bugs.

%% Date: 10 Oct 1990. Original version.

%% The Truncated Power Series package is used for non-critical points.
%% L'Hopital's rule is used in critical cases, with preprocessing of
%%  forms and reformatting of product forms in
%% order to be able to apply l'Hopital's rule.  A limited amount of
%% bounded arithmetic is also employed where applicable.

%% This limits package makes use of the ideas embodied in the
%% limit.red package, by Ian Cohen and John Fitch, 11 July 1990
%% that is in reduce-netlib;  in fact, some code is lifted bodily.
%% The idea of using the Truncated Power Series package to compute
%% limits at non-critical points, and the substitutions used in limit!+
%% and limit!- come from there.

load!-package 'tps; %load!-package 'taylor;

lisp(ps!:order!-limit := 100);

switch usetaylor; off usetaylor;

fluid '(!*precise lhop!# lplus!# !*protfg !*msg !*rounded !*complex
        !#nnn lim00!# !*crlimtest !*lim00rec);

!*lim00rec := t;  % Default value.

global '(erfg!* exptconv!#);

global '(abslims!#);
symbolic(abslims!# := {0,1,-1,'infinity,'(minus infinity)});
 % others may be added.

fluid '(lsimpdpth); global '(ld0!#); symbolic(ld0!# := 3);

flag('(limit limit!+ limit!- limit2),'full);

symbolic
for each c in '(limit limit!+ limit!- limit2) do
  <>;

symbolic procedure limit2(top,bot,xxx,a);
   lhopital(top,bot,xxx,a) where lhop!#=0;

symbolic procedure limit!+(ex,x,a);
<>;

symbolic procedure limit!-(ex,x,a);
<>;

symbolic procedure limit(ex,xxx,a); limit0(limlogsort ex,xxx,a)
  where !*combinelogs=nil,lhop!#=0,lplus!#=0,lim00!#=nil,lsimpdpth=0;

symbolic procedure limlogsort x;
   begin scalar !*precise;
      x := prepsq simp!* x;
      return if countof('log,x)>1 then logsort x else x
   end;

symbolic procedure countof(u,v);
   if u = v then 1 else if atom v then 0
      else countof(u,car v)+countof(u,cdr v);

symbolic procedure simplimit u;
   % The kludgey handling of cot needs to be fixed some day.
   begin scalar fn,exprn,var,val,old,v,!*precise,!*protfg;
     if length u neq 4
       then rerror(limit,1,
                   "Improper number of arguments to limit operator");
     fn:= car u; exprn := cadr u; var := !*a2k caddr u; val := cadddr u;
     !*protfg := t;   % ACH: I'm not sure why this is needed.
     old := get('cot,'opmtch);
     put('cot,'opmtch,
         '(((!~x) (nil . t) (quotient (cos !~x) (sin !~x)) nil)));
     v := errorset!*({'apply,mkquote fn,mkquote {exprn,var,val}},nil);
     put('cot,'opmtch,old);
     !*protfg := nil;
     return if errorp v or (v := car v) = aeval 'failed then mksq(u,1)
             else simp!* v
   end;

symbolic procedure limit0(exp,x,a);
   begin scalar exp1;
     exp1 := simp!* exp;
     if a = 'infinity then
        return limit00(subsq(exp1,{x . {'quotient,1,{'expt,x,2}}}),x);
     if a = '(minus infinity) then
        return limit00(subsq(exp1,{x . {'quotient,-1,{'expt,x,2}}}),x);
     return
        (<> where y=nil) end;

symbolic procedure limit00(ex,x);
   begin scalar p,p1,z,xpwrlcm,lim,ls;
     if (lim := crlimitset(p := prepsq ex,x)) then go to ret;
     if not lim00!# then
       <>;
         if (z := pwrdenp(p1,x)) neq 1 then
            ex := simp!*{'expt,p1,z};
         if (lim := crlimitset(p := prepsq ex,x)) then go to ret>>;
     % tps has failed because ex has a branch point at a or is undefined
     % at a or tps itself has failed or Reduce has not recognized the
     % numeric value of an expression.
     if %xpwrlcm and xpwrlcm>1 or
     lsimpdpth>ld0!#
       then lim := aeval 'failed else
       <>
    end;

symbolic procedure factrprep p;
   begin scalar !*factor;
     !*factor := t;
     return prepsq simp!* p end;

symbolic procedure expt2exp(p,x);
   if atom p then p
   else if eqcar(p,'expt)
      and not freeof(cadr p,x) and not freeof(caddr p,x) then
        <>
   else expt2exp(car p,x) . expt2exp(cdr p,x);

symbolic procedure xpwrlcmp(p,x);
   if atom p then 1
   else if eqcar(p,'expt) and cadr p = x then getdenom caddr p
   else if eqcar(p,'sqrt) then getdenomx(cadr p,x)
   else lcm(xpwrlcmp(car p,x),xpwrlcmp(cdr p,x));

symbolic procedure getdenomx(p,x);
   if freeof(p,x) then 1
   else if eqcar(p,'minus) then getdenomx(cadr p,x)
   else if p = x or eqcar(p,'times) and x member cdr p then 2
   else xpwrlcmp(p,x);

symbolic procedure getdenom p;
   if eqcar(p,'minus) then getdenom cadr p
   else if eqcar(p,'quotient) and numberp caddr p then caddr p
   else 1;

symbolic procedure pwrdenp(p,x);
   if atom p then 1
   else if eqcar(p,'expt) and not freeof(cadr p,x)
      then getdenom caddr p
   else if eqcar(p,'sqrt) and not freeof(cadr p,x) then 2
   else if eqcar(p,'minus) then pwrdenp(cadr p,x)
   else if car p member '(times quotient) then
      (<>
       where m=1)
   else if atom car p then 1
   else lcm(pwrdenp(car p,x),pwrdenp(cdr p,x));

symbolic procedure limitset(ex,x,a);
 if !*usetaylor then
  <>
 else % use tps.
  begin scalar oldpslim;
      !*protfg := t; oldpslim := simppsexplim '(1);
      ex := errorset!*({'limit1p,mkquote ex,mkquote x,mkquote a},nil);
      !*protfg := nil; simppsexplim list car oldpslim;
      return if errorp ex then nil else car ex
  end;

symbolic procedure limit1t(ex,x,a);
   begin scalar nnn, vvv,oldklist;
     oldklist := get('taylor!*,'klist);
     ex := {ex,x,a,0};
     vvv := errorset!*({'simptaylor,mkquote ex},!*backtrace);
     put('taylor!*,'klist,oldklist);
     if errorp vvv then <>
      else ex := car vvv;
     if kernp ex then ex := mvar numr ex
      else return nil;
     if not eqcar(ex,'taylor!*) then return nil
       else ex := cadr ex;
    % ex is now the list of coefs and values, but we need the lowest
    % order non-zero value, which may not be the first of these.
    % if this list is empty the result is zero
    while ex and null numr cdr car ex do ex := cdr ex;
    if null ex then return (!#nnn := 0) else
       !#nnn := nnn := caaaar ex;
     vvv := cdar ex;
     return
       if tayexp!-greaterp(nnn,0) then 0
       else if nnn=0 then mk!*sq vvv
       else if !*complex then 'infinity
       else if domainp(nnn := numr vvv) then
         (if !:minusp nnn
         then aeval '(minus infinity) else 'infinity)
       else aeval{'times,{'sign,prepsq vvv},'infinity}
   end;

symbolic procedure limit1p(ex,x,a);
   begin scalar aaa, nnn, vvv;
     aaa := mk!*sq simpps1(ex,x,a);
     !#nnn := nnn := mk!*sq simppsorder list aaa;
     vvv := simppsterm1(aaa,min(nnn,0));
     return
       if nnn>0 then 0
       else if nnn=0 then mk!*sq vvv
       else if !*complex then 'infinity
       else if domainp(nnn := car vvv) then
         (if !:minusp nnn then aeval '(minus infinity)
                          else 'infinity)
       else aeval{'times,{'sign,prepsq vvv},'infinity}
   end;

symbolic procedure crlimitset(ex,x);
 (begin scalar lim1,lim2,n1,fg,limcr,!#nnn;
    lim1 := limitset(ex,x,0);
    if null lim1 then if r and c then return nil else go to a;
    if (n1 := !#nnn) < 0 or lim1 member abslims!#
       or r and c then return lim1;
 a: if not !*crlimtest then return lim1;
    if not r then on rounded; if not c then on complex;
    if not (lim2 := limitset(ex,x,0))
      or !#nnn > n1 then <>;
    if !#nnn < n1 or lim2 member abslims!# then go to ret;
   % at this point, both lim1 and lim2 have values.  If they are
   % equivalent, we want lim1; otherwise lim2.
    if (limcr := topevalsetsq lim1) and
       evalequal(prepsq simp!* lim2,prepsq limcr)
         then fg := t;
ret:if not r then off rounded; if not c then off complex;
    return if fg then lim1 else lim2 end)
  where r=!*rounded,c=!*complex,!*msg=nil;

symbolic procedure topevalsetsq u;
  <>
  where r=!*rounded,c=!*complex,!*msg=nil;

put('times,'limsfn,'ltimesfn);
put('quotient,'limsfn,'lquotfn);
put('plus,'limsfn,'lplusfn);
put('expt,'limsfn,'lexptfn);

symbolic procedure limsimp(ex,x);
  % called when limit1 has failed, to apply more sophisticated methods.
  % output must be aeval form.
   begin scalar y,c,z,m,ex0;
      if eqcar(ex,'minus) then <>;
      ex0 := ex;
      if not atom ex then  % check for plus, times, or quotient.
         <>
         else <>;
      if y eq 'plus then go to ret;
      if y eq 'expt then if ex then return ex else ex := ex0 . 1;
      if z then<>
         else <>;
      ex := lhopital(z,c,x,0);
 ret: if m and prepsq simp!* ex neq 'failed then
         ex := aeval lminus2 ex;
      return ex end;

symbolic procedure lminus2 ex;
   if numberp ex then -ex
   else if eqcar(ex,'minus) then cadr ex
   else list('minus,ex);

symbolic procedure ltimesfn(ex,x); specchk(ex,1,x);

symbolic procedure lquotfn(ex,x);
 %  (if eqcar(n,'expt) and (nlim :=lexptfn(n,x))
specchk(cadr ex,caddr ex,x);

symbolic procedure lexptfn(ex,x);
   if not evalequal(cadr ex,0) and
     freeof (cadr ex,x) and limit00(simp!* caddr ex,x)=0
     then 1;

symbolic procedure specchk(top,bot,x);
   begin scalar tlist,blist,tinfs,binfs,tlogs,blogs,tzros,bzros,
         tnrms,bnrms,m;
      if eqcar(top,'minus) then <>;
      if eqcar(bot,'minus) then <>;
      tlist := limsort(timsift(top,x),x);
      blist := limsort(timsift(bot,x),x);
      tinfs := cdr(tlogs := logcomb(cadr tlist,x)); tlogs := car tlogs;
      binfs := cdr(blogs := logcomb(cadr blist,x)); blogs := car blogs;
      tzros := car tlist; tnrms := caddr tlist;
      bzros := car blist; bnrms := caddr blist;
      if tlogs and not blogs then
         <>
      else if blogs and not tlogs then
         <>
      else
         <>;
      if m then top := list('minus,top);
      return top . bot end;

symbolic procedure trimq l;
   if l then list list('quotient,1,
      if length l>1 then 'times . l else car l);

symbolic procedure triml l;
   if null l then 1 else if length l>1 then 'times . l else car l;

symbolic procedure limsort(ex,x);
   begin scalar zros,infs,nrms,q,s;
      for each c in ex do
         if (q := numr(s := simp!* limit00(simp!* c,x)))
              and numberp q and not zerop q then nrms := q . nrms
         else if null q or zerop q then zros := c . zros
         else if caaar q memq '(failed infinity) then infs := c.infs
         else nrms := (prepsq s) . nrms;
      return list(zros,infs,nrms) end;

symbolic procedure logcomb(tinf,x);
  % separate product list into log terms and others.
   begin scalar tlog,c,z;
      while tinf do
         <>;
      return tlog . reversip z end;

symbolic procedure logjoin(p,x);
  % combine log terms in sum list into a single log.
   begin scalar ll,z;
      for each c in cdr p do
         if freeof(c,x) then z := c . z
         else if eqcar(c,'log) then ll := (cadr c) . ll
         else if eqcar(c,'minus) and eqcar(cadr c,'log) then
            ll := list('quotient,1,cadadr c) . ll
         else z := c . z;
      if ll then ll := list list('log,'times . ll);
      return (car p) . append(ll,reversip z) end;

symbolic procedure timsift(ex,x);
   if eqcar(ex,'times) then cdr ex
   else if eqcar(ex,'plus) then list logjoin(ex,x)
    % for plus, combine log terms, change infinity - infinity to
    % inner quotient.
   else list ex;

symbolic procedure lplusfn(ex,x);
  % combine logs and evaluate each limit term.  if infinity - infinity
  % is found, attempt conversion to quotient form for lhopital.
   begin scalar z,infs,nrms,vals,vp,vm,cz,vnix;
      lplus!# := lplus!# + 1;
     % write "lplus#=",lplus!#; terpri();
      if lplus!#>4 then return aeval 'failed;
      z := limsort(cdr ex,x); % ignore car z, a list of 0's.
      nrms := caddr z; infs := cadr z;
      if length infs>1 then
         <>;
     % at this point, only infs needs to be evaluated.
      vals := for each c in infs collect
         minfix prepsq simp!* limit00(simp!* c,x);
      z := infs;
      for each c in vals do
         <>;
      if vm and not vp or vp and not vm or length vnix = 1
         or length vm > 1 or length vp > 1 then return aeval 'failed;
      if vm then vm := qform(car vp,vm);
      if vnix then vnix := qform(car vnix,cdr vnix);
      vm := append(nrms,append(vm,vnix));
      return if null vm then 0 else
         limit00(simp!* if length vm>1 then 'plus . vm else car vm,x)
         end;

symbolic procedure minfix v;
   if eqcar(v,'minus) and numberp cadr v then -cadr v else v;

symbolic procedure qform(a,b);
   list list('quotient,list('plus,1,
      list('quotient,if length b = 1 then car b else 'plus . b,a)),
         list ('quotient,1,a));

symbolic procedure lhopital(top,bot,xxx,a);
  begin scalar limt, limb, nvt, nvb;
     nvt := notval(limt := limfix(top,xxx,a));
     nvb := notval(limb := limfix(bot,xxx,a));
 % possibilities for lims are {failed, infinity, -infinity, bounded,
 % nonzero, zero} and each combination of cases has to be handled.
     if limt=0 and limb=0 or nvt and nvb then go to lhop;
     if specval limt or specval limb then return speccomb(limt,limb);
     if limb=0 then return aeval 'infinity;  % maybe impossible.
     return aeval list('quotient,limt,limb);
lhop: lhop!# := lhop!#+1;
    %  write "lhop#=",lhop!#; terpri();
      if lhop!#>6 then return aeval 'failed;
      return limit0(prepsq quotsq(diffsq(simp!* top,xxx),
          diffsq(simp!* bot,xxx)),xxx,a) end;

symbolic procedure notval lim;
   not lim or infinp prepsq simp!* lim;

symbolic procedure infinp x; member(x,'(infinity (minus infinity)));

symbolic procedure specval lim;
   notval lim or lim eq 'bounded;


symbolic procedure speccomb(a,b);
 aeval
  (if not a or not b or b eq 'bounded then 'failed
   else if notval b then 0
   else if notval a then
      if numberp b then
         if b>=0 then a
         else if a eq 'infinity then '(minus infinity) else 'infinity
      else ((if c then
        <> else {'quotient,a,b})
          where c=topevalsetsq prepsq simp!* b,cc=nil)
   else 'failed);

symbolic procedure limfix(ex,x,a);
   (if val then val
       else limitest(ex,x,a))
    where val=limitset(ex,x,a);

symbolic procedure limitest(ex,x,a);
  if ex then if atom ex then if ex eq x then a else ex else
  begin scalar y,arg,val;
    if eqcar(ex,'expt) then
       if cadr ex eq 'e then ex := list('exp,caddr ex)
       else return exptest(cadr ex,caddr ex,x,a);
    if (y := get(car ex,'fixfn)) then
       <>
    else if (y := get(car ex,'limcomb)) then
       return apply3(y,cdr ex,x,a) end;

symbolic procedure exptest(b,n,x,a);
   if numberp n then
      if n<0 then limquot1(1,exptest(b,-n,x,a))
      else if n=0 then 1 else
        ((if 2*y=n then limlabs limitest(b,x,a) else limitest(b,x,a))
         where y=n/2)
   else if numberp b and b>1 then limitest(list('exp,n),x,a);

symbolic procedure limlabs a;
   if null a then nil
   else if infinp a then 'infinity
   else if a eq 'bounded then 'bounded else
     begin scalar n,d; d := denr(n := simp!* a); n := numr n;
     return if null n then a else if not numberp n then nil
         else mk!*sq abs a ./ d end;

symbolic procedure limplus(exl,x,a);
   if null exl then 0
   else limplus1(mkalg limfix(car exl,x,a),limplus(cdr exl,x,a));

symbolic procedure limplus1(a,b);
   if null a or null b then nil
   else if infinp a
      then if infinp b
         then if a eq b then a else nil else a
   else if infinp b then b
   else if a eq 'bounded or b eq 'bounded then 'bounded
   else mk!*sq addsq(simp!* a,simp!* b);

symbolic procedure limtimes(exl,x,a);
   if null exl then 1
  else ltimes1(mkalg limfix(car exl,x,a),limtimes(cdr exl,x,a));

symbolic procedure mkalg x;
   minfix if eqcar(x,'!*sq) then prepsq simp!* x else x;

symbolic procedure ltimes1(a,b);
 begin scalar c;
  return if null a or null b then nil
   else if infinp a then
         if infinp b  then
           if a = b then 'infinity else '(minus infinity)
           else if b eq 'bounded or b=0 then nil
           else if (c := limposp b) eq 'failed then nil
           else if c then a else lminus1 a
   else if infinp b then
      if a eq 'bounded or a=0 then nil
      else if (c := limposp a) eq 'failed then nil
      else if c then b else lminus1 b
   else if a eq 'bounded or b eq 'bounded then 'bounded
   else mk!*sq multsq(simp!* a,simp!* b) end;

symbolic procedure limposp a;
  (if n and not numberp n then 'failed else n and n>0)
  where n=numr simp!* a;

symbolic procedure lminus(exl,x,a);
   lminus1 mkalg limfix(car exl,x,a);

symbolic procedure lminus1 a; if a then
   if a eq 'infinity then '(minus infinity)
   else if a = '(minus infinity) then 'infinity
   else if a eq 'bounded then a
   else mk!*sq negsq simp!* a;

symbolic procedure limquot(exl,x,a);
   limquot1(mkalg limfix(car exl,x,a),mkalg limfix(cadr exl,x,a));

symbolic procedure limquot1(a,b);
 begin scalar c;
  return if null a or null b then nil
   else if infinp a then
         if infinp b then nil
           else if b eq 'bounded then nil
           else if b=0 then a
           else if (c := limposp b) eq 'failed then nil
           else if c then a else lminus1 a
   else if infinp b then 0
   else if a eq 'bounded then if b=0 then nil else 'bounded
   else if b=0 or b eq 'bounded then nil
   else mk!*sq quotsq(simp!* a,simp!* b) end;

put('log,'fixfn,'fixlog);
put('sin,'fixfn,'fixsin);
put('cos,'fixfn,'fixsin);
put('sqrt,'fixfn,'fixsqrt);
put('cosh,'fixfn,'fixcosh);
put('sinh,'fixfn,'fixsinh);
put('exp,'fixfn,'fixexp);
put('plus,'limcomb,'limplus);
put('minus,'limcomb,'lminus);
put('times,'limcomb,'limtimes);
put('quotient,'limcomb,'limquot);

symbolic procedure fixlog x;
   if zerop x then '(minus infinity) else if infinp x then 'infinity;

symbolic procedure fixsqrt x;
   if zerop x then 0 else if infinp x then 'infinity;

symbolic procedure fixsin x;
   if infinp x then 'bounded;

symbolic procedure fixcosh x;
   if infinp x then 'infinity;

symbolic procedure fixsinh x;
   if infinp x then x;

symbolic procedure fixexp x;
   if x eq 'infinity then x else if x = '(minus infinity) then 0;

% Special case rules.

algebraic let {
 limit((~a + (~b)^(~x))^(~c/x),x,infinity) => b^c
    when b freeof x and a freeof x and c freeof x};

algebraic let {
 limit((~a + (~b)^((~x)^(~n)))^(~c/((x)^n)),x,infinity) => b^c
        when (b freeof x) and a freeof x and fixp n and (n > 1)
        and c freeof x };

algebraic let {
 limit(1/(~a + (~b)^(~x))^(~c/x),x,infinity) => b^(-c)
    when b freeof x and a freeof x and c freeof x};

algebraic let {
 limit(1/(~a + (~b)^((~x)^(~n)))^(~c/((x)^n)),x,infinity) => b^(-c)
        when (b freeof x) and a freeof x and fixp n and (n > 1)
        and c freeof x };

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/liendmc1.red0000644000175000017500000002045711526203062023637 0ustar  giovannigiovannimodule liendmc1; % N-dimensional Lie algebras with 1-dimensional derived
                 % algebra.
% Author: Carsten Schoebel.
% e-mail: cschoeb@aix550.informatik.uni-leipzig.de .
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;
operator heisenberg,commutative,lie_algebra;

algebraic procedure liendimcom1(n);
begin
 if (not(symbolic fixp(n)) or n<2) then
 symbolic rederr "dimension out of range";
 symbolic (if gettype 'lienstrucin neq 'ARRAY then
          rederr "lienstrucin not ARRAY");
 if length lienstrucin neq {n+1,n+1,n+1} then
          symbolic rederr "dimension of lienstrucin out of range";
 matrix lientrans(n,n);
   array lie_cc(n,n,n);
 lieninstruc(n);
 lienjactest(n);if lie_jtest neq 0 then
  <>;
 <> else
  if lie_dim=1 then <>else
    <>;
 clear lie_dim,lie_help,lie_p,lie_q,lie_tt,lie_s,lie_kk!*,lie_control>>;
 clear lie_jtest,lie_cc;return lie_list
end;

algebraic procedure lieninstruc(n);
begin
 for i:=1:n-1 do for j:=i+1:n do for k:=1:n do
 <>
end;

algebraic procedure lienjactest(n);
begin
 lie_jtest:=0;
 for i:=1:n-2 do
  for j:=i+1:n-1 do
   for k:=j+1:n do
    for l:=1:n do
    if (for r:=1:n sum
           lie_cc(j,k,r)*lie_cc(i,r,l)+lie_cc(i,j,r)*lie_cc(k,r,l)+
           lie_cc(k,i,r)*lie_cc(j,r,l)) neq 0 then <>
end;

algebraic procedure liendimcom(n);
begin integer r;
      scalar he;
 lie_dim:=0;
 for i:=1:n-1 do
  for j:=i:n do
   for k:=1:n do
   if lie_cc(i,j,k) neq 0 then
    <>;
 if lie_dim neq 0 then
 <>>>;
 if lie_dim=1 then
 <>;
   for i:=1:n do lientrans(1,i):=lie_cc(lie_p,lie_q,i);
   if lie_help=0 then
   <>>>>> else
   <>>>>>>>>>;
end;

algebraic procedure liencentincom(n,tt,p,q);
begin integer con1,con2;
      matrix lie_lamb(n,n);
 lie_control:=0;
 con1:=con2:=0;
 for i:=4:n do
  if (i neq tt and i neq p and i neq q) then
  lientrans(i,i):=1 else
   if (tt neq 1 and p neq 1 and q neq 1 and con1 neq 1) then
   <> else
    if (tt neq 2 and p neq 2 and q neq 2 and con2 neq 1) then
    <> else lientrans(i,3):=1;
if n>3 then <4 then
  for i:=4 step 2 until n do if (i+1)=n then <> else
       if i+1>else
                       i:=n+1>>>>
end;

algebraic procedure lienfindpair(n,m);
begin scalar he;
      matrix lie_a(n,n);
 lie_control:=0;
 for i:=m:n-1 do
  for j:=i+1:n do
  <>>>;clear lie_a
end;

algebraic procedure liennewstruc(n,m,tt);
begin matrix lie_a(n,n);
 lie_a:=lie_a**0;
 for i:=m:n-1 do
  for j:=i+1:n do
  lie_lamb(i,j):=(for k:=1:n sum for l:=1:n sum
         lientrans(i,k)*lientrans(j,l)*lie_cc(k,l,tt))/lientrans(1,tt);
 for i:=m+2:n do
 <>;
 lientrans:=lie_a*lientrans;
 for i:=m+2:n-1 do
  for j:=i+1:n do
  lie_lamb(i,j):=(for k:=1:n sum for l:=1:n sum
    lientrans(i,k)*lientrans(j,l)*lie_cc(k,l,tt))/lientrans(1,tt);
    clear lie_a
end;

algebraic procedure liencentoutcom(n,tt,s);
begin integer pp,qq;
      matrix lie_lamb(2,n),lie_a(n,n);
 for i:=3:n do
 <>;
 if (tt>2 and s>2) then
   <> else if (tt>2 or s>2) then
 <2 then <> else <>;
 lientrans(qq,qq):=0;lientrans(qq,pp):=1;
 lie_lamb(1,qq):=(for j:=1:n sum
    lientrans(1,j)*lie_cc(j,pp,tt))/lientrans(1,tt);
 lie_lamb(2,qq):=lie_cc(s,pp,tt)*lientrans(2,s)/lientrans(1,tt)>>;
 lie_a:=lie_a**0;
 for i:=3:n do
 <>;
 lientrans:=lie_a*lientrans;clear lie_lamb,lie_a
end;

algebraic procedure lienoutform(at,n,lhelp,kk);
begin operator y;
lie_a:=at;
 if lhelp=1 then
 <>else
 <>;
  write "The transformation into this form is:";
 for i:=1:n do write "X(",i,"):=",for j:=1:n sum
      lie_a(i,j)*y(j);clear y,lie_a
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/mv.red0000644000175000017500000001254511526203062022564 0ustar  giovannigiovannimodule mv; % Operations on multivariate forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1989 The RAND Corporation.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These smacros are local to this module.

symbolic smacro procedure mv!-term!-coeff u; cdr u;

symbolic smacro procedure mv!-term!-pow u; car u;

symbolic smacro procedure mv!-tpow u; car u;

symbolic smacro procedure mv!-tc u; cdr u;

symbolic procedure mv!-!+(u,v);
   if null u then v
    else if null v then u
    else if mv!-lpow u= mv!-lpow v
     then (lambda x;
            if x=0 then mv!-!+(mv!-red u,mv!-red v)
             else mv!-!.!+(mv!-!.!*(mv!-lpow u,x),
                           mv!-!+(mv!-red u,mv!-red v)))
          (mv!-lc u + mv!-lc v)
    else if mv!-pow!-!>(mv!-lpow u,mv!-lpow v)
     then mv!-!.!+(mv!-lt u,mv!-!+(mv!-red u,v))
    else mv!-!.!+(mv!-lt v,mv!-!+(u,mv!-red v));

symbolic smacro procedure domain!-!*(u,v); u*v;

symbolic smacro procedure domain!-!/(u,v); u/v;

symbolic procedure mv!-term!-!*(u,v);
   % U is a (non-zero) term and v a multivariate form. Result is
   % product of u and v.
   if null v then nil
    else mv!-!.!+(mv!-!.!*(mv!-pow!-!+(mv!-tpow u,mv!-lpow v),
                           domain!-!*(mv!-tc u,mv!-lc v)),
                  mv!-term!-!*(u,mv!-red v));

symbolic procedure mv!-term!-!/(u,v);
   % Returns the result of the (exact) division of u by term v.
   if null u then nil
    else mv!-!.!+(mv!-!.!*(mv!-pow!-!-(mv!-lpow u,mv!-tpow v),
                           domain!-!/(mv!-lc u,mv!-tc v)),
                  mv!-term!-!/(mv!-red u,v));

symbolic procedure mv!-domainlist u;
   if null u then nil
    else mv!-lc u . mv!-domainlist mv!-red u;

symbolic procedure mv!-pow!-mv!-!+(u,v);
   if null v then nil
    else mv!-!.!+(mv!-pow!-mv!-term!-!+(u,mv!-lt v),
                  mv!-pow!-mv!-!+(u,mv!-red v));

symbolic procedure mv!-pow!-mv!-term!-!+(u,v);
   mv!-!.!*(mv!-pow!-!+(u,mv!-term!-pow v), mv!-term!-coeff v);

symbolic procedure mv!-pow!-!+(u,v);
   if null u then nil
    else (car u+car v) . mv!-pow!-!+(cdr u,cdr v);

symbolic procedure mv!-pow!-!-(u,v);
   if null u then nil
    else (car u-car v) . mv!-pow!-!-(cdr u,cdr v);

symbolic procedure mv!-pow!-!*(u,v);
   if null v then nil
    else (u*car v) . mv!-pow!-!*(u,cdr v);

symbolic procedure mv!-pow!-minusp u;
   if null u then nil
    else car u<0 or mv!-pow!-minusp cdr u;

symbolic procedure mv!-pow!-!>(u,v);
   if null u then nil
    else if car u=car v then mv!-pow!-!>(cdr u,cdr v)
    else car u>car v;

symbolic procedure mv!-reduced!-coeffs u;
   % reduce coefficients of u to lowest terms.
   begin scalar x,y;
      x := mv!-lc u;
      y := mv!-red u;
      while y and x neq 1 do <>;
      return if x=1 then u else mv!-!/(u,x)
   end;

symbolic procedure mv!-!/(u,v);
   if null u then nil
    else mv!-!.!+(mv!-!.!*(mv!-lpow u,mv!-lc u/v),mv!-!/(mv!-red u,v));


% Functions that convert between standard forms and multivariate forms.

symbolic procedure sf2mv(u,varlist);
   % Converts the standard form u to a multivariate form wrt varlist.
   sf2mv1(u,nil,varlist);

symbolic procedure sf2mv1(u,powers,varlist);
   if null u then nil
    else if domainp u
     then list(append(powers,nzeros length varlist) . u)
    else if mvar u = car varlist     % This should be eq, but seems to
                                     % need equal.
     then append(sf2mv1(lc u,append(powers,list ldeg u),cdr varlist),
                 sf2mv1(red u,powers,varlist))
    else sf2mv1(u,append(powers,list 0),cdr varlist);

symbolic procedure nzeros n; if n=0 then nil else 0 . nzeros(n-1);

symbolic procedure mv2sf(u,varlist);
   % converts the multivariate form u to a standard form wrt varlist.
   % This version uses addf to fold terms - there is probably a more
   % direct method.
   if null u then nil
    else addf(mv2sf1(mv!-lpow u,cdar u,varlist),mv2sf(cdr u,varlist));

symbolic procedure mv2sf1(powers,cf,varlist);
   if null powers then cf
    else if car powers=0 then mv2sf1(cdr powers,cf,cdr varlist)
    else !*t2f((car varlist .** car powers)
                 .* mv2sf1(cdr powers,cf,cdr varlist));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/lie1234.red0000644000175000017500000015131611526203062023225 0ustar  giovannigiovannimodule lie1234;
% n-dimensional Lie algebras up to n=4.
% Author: Carsten and Franziska Schoebel.
% e-mail: cschoeb@aix550.informatik.uni-leipzig.de .
% Copyright (c) 1993 The Leipzig University, Computer Science Dept.
% All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;
operator liealg,comtab;

algebraic procedure lieclass(dim);
begin
 if not(dim=1 or dim=2 or dim=3 or dim=4) then
  symbolic rederr "dimension out of range";
 symbolic(if gettype 'liestrin neq 'ARRAY then
          rederr "liestrin not ARRAY");
 if length liestrin neq {dim+1,dim+1,dim+1} then
  symbolic rederr "dimension of liestrin out of range";
 if dim=1 then <> else
     if dim=2 then lie2(liestrin(1,2,1),liestrin(1,2,2)) else
      if dim=3 then <>;
                      lie3(lie3_ff);clear lie3_ff>> else
      <>;return lie_class
end;

algebraic procedure lie2(f,g);
BEGIN
  IF G=0 THEN
   IF F=0 THEN liemat:=MAT((1,0),(0,1))
   ELSE liemat:=MAT((0,-1/F),(F,0))
  ELSE liemat:=MAT((1/G,0),(F,G));
  IF (F=0 AND G=0) THEN <>
  ELSE <>
END;

algebraic procedure lie3(ff);
BEGIN
      MATRIX liemat(3,3),l_f(3,3);
      ARRAY l_jj(3);
  l_f:=ff;
  FOR N:=1:3 DO
      l_jj(N):=l_f(1,N)*(-l_f(2,1)-l_f(3,2))+
            l_f(2,N)*(l_f(1,1)-l_f(3,3))+
            l_f(3,N)*(l_f(1,2)+l_f(2,3));
  IF NOT(l_jj(1)=0 AND l_jj(2)=0 AND l_jj(3)=0) THEN
     <>;
    IF l_f=MAT((0,0,0),(0,0,0),(0,0,0)) THEN
    <> ELSE
      IF DET(l_f) NEQ 0 THEN com3(ff) ELSE
        IF independ(1,2,ff)=1 THEN com2(ff,1,2) ELSE
         IF independ(1,3,ff)=1 THEN com2(ff,1,3) ELSE
          IF independ(2,3,ff)=1 THEN com2(ff,2,3) ELSE
           com1(ff);
CLEAR l_jj,l_f
END;


algebraic procedure independ(I,J,F0);
BEGIN MATRIX F1(3,3);
  F1:=F0;
  IF (F1(I,1)*F1(J,2)-F1(I,2)*F1(J,1)=0 AND
      F1(I,2)*F1(J,3)-F1(I,3)*F1(J,2)=0 AND
      F1(I,1)*F1(J,3)-F1(I,3)*F1(J,1)=0) THEN RETURN 0
  ELSE RETURN 1
END;

algebraic procedure com1(F2);
BEGIN
      SCALAR ALPHA,AA,BB;
      INTEGER R,I,J,M,N,Z1;
      MATRIX F3(3,3);
      ARRAY l_C(3,3,3);
  F3:=F2;
  FOR M:=3 STEP -1 UNTIL 1 DO
   FOR N:=3 STEP -1 UNTIL 1 DO
   IF F3(M,N) NEQ 0 THEN I:=M;
  IF I=1 THEN <> ELSE
   IF I=2 THEN <> ELSE <>;
  FOR K:=1:3 DO
   <>;
  Z1:=0;
  FOR U:=3 STEP -1 UNTIL 1 DO
   FOR V:=3 STEP -1 UNTIL 1 DO
   IF l_C(I,J,1)*l_C(V,1,U)+l_C(I,J,2)*l_C(V,2,U)+
   l_C(I,J,3)*l_C(V,3,U) NEQ 0
  THEN <>;
  IF Z1=0 THEN
    <> ELSE
    <>>>;
      AA:=l_C(N,R,M)/(ALPHA*l_C(I,J,M));
      BB:=(l_C(I,J,1)*l_C(R,1,M)+l_C(I,J,2)*l_C(R,2,M)+
           l_C(I,J,3)*l_C(R,3,M))/l_C(I,J,M);
      IF AA=0 THEN liemat:=MAT((1,0,0),(-BB,1,0),(0,0,1))*A1 ELSE
        liemat:=MAT((1,0,0),(BB/AA,-1/AA,1),(0,0,1))*A1;
      if symbolic !*tr_lie then
      WRITE "[X,Z]=Z";lie_class:={liealg(3),comtab(2)}>>;
  CLEAR A1,A2,A3,l_C,F3
END;

algebraic procedure com2(F2,M,N);
BEGIN SCALAR Z1,ALPHA,ALPHA1,ALPHA2,BETA,BETA1,BETA2;
      MATRIX F3(3,3);
  F3:=F2;
  A1:=MAT((F3(M,1),F3(M,2),F3(M,3)),
          (F3(N,1),F3(N,2),F3(N,3)),(0,0,0));
  A1(3,1):=1;Z1:=DET(A1);
  IF Z1 NEQ 0 THEN
   <>
   ELSE
   <>
   ELSE
   <>>>;
  IF (ALPHA2=0 AND BETA1=0 AND ALPHA1=BETA2) THEN
   <> ELSE
   <> ELSE
      IF BETA1 NEQ 0 THEN
       <> ELSE
        <>;
     IF ALPHA=0 THEN
      <0 then lie_class:={liealg(3),comtab(4)} else
                       lie_class:={liealg(3),comtab(5)}>>
                 ELSE
      <>>>;
  CLEAR A1,A2,F3
END;

algebraic procedure com3(F2);
BEGIN MATRIX l_K(3,3),F3(3,3);
  F3:=F2;
  l_K(1,1):=F3(1,2)**2+2*F3(1,3)*F3(2,2)+F3(2,3)**2;
  l_K(1,2):=-F3(1,1)*F3(1,2)+F3(1,3)*F3(3,2)-
           F3(2,1)*F3(1,3)+F3(2,3)*F3(3,3);
  l_K(1,3):=-F3(1,1)*F3(2,2)-F3(1,2)*F3(3,2)-
           F3(2,1)*F3(2,3)-F3(2,2)*F3(3,3);
  l_K(2,1):=l_K(1,2);
  l_K(2,2):=F3(1,1)**2-2*F3(1,3)*F3(3,1)+F3(3,3)**2;
  l_K(2,3):=F3(1,1)*F3(2,1)+F3(1,2)*F3(3,1)-
          F3(3,1)*F3(2,3)-F3(3,2)*F3(3,3);
  l_K(3,1):=l_K(1,3);
  l_K(3,2):=l_K(2,3);
  l_K(3,3):=F3(2,1)**2+2*F3(2,2)*F3(3,1)+F3(3,2)**2;
  IF NOT(NUMBERP(l_K(1,1)) AND
   NUMBERP(l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1)) AND
         NUMBERP(DET(l_K))) THEN
  <0 and ",
     l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1),">0 and ",
      -DET(l_K),">0 ? (y/n) and press ";
    HE:=SYMBOLIC READ();
    IF HE=y THEN so3(F2) ELSE so21(F2)>> ELSE
  IF (-l_K(1,1)>0 AND l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1)>0 AND
      -DET(l_K)>0) THEN so3(F2) ELSE so21(F2);
  CLEAR l_K,F3
END;

algebraic procedure so3(F4);
BEGIN SCALAR S,TT,Q,R,ALPHA;
      MATRIX F5(3,3);
  F5:=F4;
  S:=F5(2,2)/ABS(F5(2,2));
  TT:=ABS(F5(1,2)**2+F5(1,3)*F5(2,2));
  R:=F5(1,1)-F5(1,2)*F5(2,1)/F5(2,2);
  ALPHA:=TT*(-R*R-((F5(2,1)/F5(2,2))**2+F5(3,1)/F5(2,2))*TT);
  Q:=1/SQRT(ALPHA);
  liemat(1,1):=1/(S*SQRT(TT));
  liemat(1,2):=0;
  liemat(1,3):=0;
  liemat(2,1):=Q*R;
  liemat(2,2):=0;
  liemat(2,3):=-Q*TT/F5(2,2);
  liemat(3,1):=-Q*S*SQRT(TT)*F5(2,1)/F5(2,2);
  liemat(3,2):=-Q*S*SQRT(TT);
  liemat(3,3):=Q*S*SQRT(TT)*F5(1,2)/F5(2,2);
  if symbolic !*tr_lie then
  WRITE "[X,Y]=Z, [X,Z]=-Y, [Y,Z]=X";lie_class:={liealg(3),comtab(7)};
  CLEAR F5;
END;

algebraic procedure so21(F4);
BEGIN SCALAR GAM,EPS,S,TT,Q,R,ALPHA;
      MATRIX l_G(3,3),F5(3,3);
  F5:=F4;
  liemat:=MAT((1,0,0),(0,1,0),(0,0,1));
  IF F5(2,2)=0 THEN
   IF F5(1,3) NEQ 0 THEN <> ELSE
    IF F5(3,1) NEQ 0 THEN <> ELSE
      <>;
  IF F5(1,2)**2+F5(1,3)*F5(2,2)=0 THEN
   <> ELSE
      <>>>;
  IF NOT(NUMBERP(F5(1,2)**2+F5(1,3)*F5(2,2))) THEN
 <";
    HE:=SYMBOLIC READ();
    IF HE=y THEN
    <> ELSE
   <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN
       <> ELSE
       <>>> ELSE
     IF ALPHA>0 THEN
      <> ELSE
      <>>>>> ELSE
  IF F5(1,2)**2+F5(1,3)*F5(2,2)<0 THEN
   <> ELSE
   <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN
       <> ELSE
       <>>> ELSE
     IF ALPHA>0 THEN
      <> ELSE
      <>>>;
  if symbolic !*tr_lie then
  WRITE "[X,Y]=Z, [X,Z]=Y, [Y,Z]=X";lie_class:={liealg(3),comtab(8)};
  CLEAR l_G,F5
END;

algebraic procedure lie4();
BEGIN
     SCALAR LAM,JAC1,JAC2,JAC3,JAC4;
     INTEGER P1,M1,M2,M3,DIML1;
     MATRIX l_F(6,4);
     ARRAY ORDV(12);
 ORDV(1):=ORDV(3):=ORDV(7):=1;ORDV(2):=ORDV(5):=ORDV(9):=2;
 ORDV(4):=ORDV(6):=ORDV(11):=3;ORDV(8):=ORDV(10):=ORDV(12):=4;
 FOR I:=1:4 DO
  <>;
 FOR S:=1:4 DO
 <>;
 IF (JAC1 NEQ 0 OR JAC2 NEQ 0 OR JAC3 NEQ 0 OR JAC4 NEQ 0 )THEN
  <>;
 M1:=0;
 FOR S:=1:6 DO
  FOR TT:=1:4 DO
   IF l_F(S,TT) NEQ 0 THEN <>;
 IF M1=0 THEN DIML1:=0 ELSE
  IF M1=6 THEN DIML1:=1 ELSE
  <>>>;
       IF M2=0 THEN DIML1:=1 ELSE
     IF M2=6 THEN DIML1:=2 ELSE
     <>;
       IF M3=0 THEN DIML1:=2 ELSE DIML1:=3>>>>;
   IF DIML1=0 THEN
    <> ELSE
    IF DIML1=3 THEN
    com43(ORDV(2*M1-1),ORDV(2*M1),ORDV(2*M2-1),ORDV(2*M2),
            ORDV(2*M3-1),ORDV(2*M3)) ELSE
      IF DIML1=1 THEN
       com41(ORDV(2*M1-1),ORDV(2*M1),P1) ELSE
        com42(ORDV(2*M1-1),ORDV(2*M1),ORDV(2*M2-1),ORDV(2*M2));
 CLEAR ORDV,l_F
END;

algebraic procedure com41(I1,J1,P1);
BEGIN SCALAR Y1,Y2,Y3,BETA1,BETA2,BETA3,BETA4,BETA5,BETA6;
      MATRIX liemat(4,4);
 FOR I:=1:4 DO liemat(1,I):=CC(I1,J1,I);
 IF P1=1 THEN <> ELSE
  IF P1=2 THEN <> ELSE
   IF P1=3 THEN <> ELSE
    <>;
 liemat(2,Y1):=liemat(3,Y2):=liemat(4,Y3):=1;
 BETA1:=(FOR L:=1:4 SUM CC(I1,J1,L)*CC(L,Y1,P1))/CC(I1,J1,P1);
 BETA2:=(FOR L:=1:4 SUM CC(I1,J1,L)*CC(L,Y2,P1))/CC(I1,J1,P1);
 BETA3:=CC(Y1,Y2,P1)/CC(I1,J1,P1);
 BETA4:=(FOR L:=1:4 SUM CC(I1,J1,L)*CC(L,Y3,P1))/CC(I1,J1,P1);
 BETA5:=CC(Y1,Y3,P1)/CC(I1,J1,P1);
 BETA6:=CC(Y2,Y3,P1)/CC(I1,J1,P1);
 IF (BETA1=0 AND BETA2=0 AND BETA3=0 AND BETA4=0 AND BETA5=0) THEN
  <> ELSE
  IF (BETA1=0 AND BETA2=0 AND BETA3=0) THEN
   <>;
 IF (BETA1=0 AND BETA2=0) THEN
  <> ELSE
  IF BETA1=0 THEN
   <> ELSE
    <>;
 IF (BETA1=0 AND BETA2=0) THEN
  <> ELSE
  <>
END;


algebraic procedure com42(I1,J1,I2,J2);
BEGIN SCALAR D,D1,D2,D3,D4,A1,A2,A3,A4,A5,B1,B2,B3,B4,B5;
      MATRIX liemat(4,4);
      ARRAY SOL(1,4);
 FOR I:=1:4 DO <>;
 liemat(3,1):=liemat(4,2):=1;IF (D:=DET(liemat)) NEQ 0 THEN
  <> ELSE
  <> ELSE
   <> ELSE
    <> ELSE
     <> ELSE
      <>
  >>>>>>>>;
 A1:=FOR R:=1:4 SUM ( CC(I1,J1,R)*CC(R,D1,D3)*CC(I2,J2,D4)-
                      CC(I1,J1,R)*CC(R,D1,D4)*CC(I2,J2,D3))/D;
 B1:=FOR R:=1:4 SUM (-CC(I1,J1,R)*CC(R,D1,D3)*CC(I1,J1,D4)+
                      CC(I1,J1,R)*CC(R,D1,D4)*CC(I1,J1,D3))/D;
 A2:=FOR R:=1:4 SUM ( CC(I2,J2,R)*CC(R,D1,D3)*CC(I2,J2,D4)-
                      CC(I2,J2,R)*CC(R,D1,D4)*CC(I2,J2,D3))/D;
 B2:=FOR R:=1:4 SUM (-CC(I2,J2,R)*CC(R,D1,D3)*CC(I1,J1,D4)+
                      CC(I2,J2,R)*CC(R,D1,D4)*CC(I1,J1,D3))/D;
 A3:=FOR R:=1:4 SUM ( CC(I1,J1,R)*CC(R,D2,D3)*CC(I2,J2,D4)-
                      CC(I1,J1,R)*CC(R,D2,D4)*CC(I2,J2,D3))/D;
 B3:=FOR R:=1:4 SUM (-CC(I1,J1,R)*CC(R,D2,D3)*CC(I1,J1,D4)+
                      CC(I1,J1,R)*CC(R,D2,D4)*CC(I1,J1,D3))/D;
 A4:=FOR R:=1:4 SUM ( CC(I2,J2,R)*CC(R,D2,D3)*CC(I2,J2,D4)-
                      CC(I2,J2,R)*CC(R,D2,D4)*CC(I2,J2,D3))/D;
 B4:=FOR R:=1:4 SUM (-CC(I2,J2,R)*CC(R,D2,D3)*CC(I1,J1,D4)+
                      CC(I2,J2,R)*CC(R,D2,D4)*CC(I1,J1,D3))/D;
 A5:=( CC(D1,D2,D3)*CC(I2,J2,D4)-CC(D1,D2,D4)*CC(I2,J2,D3))/D;
 B5:=(-CC(D1,D2,D3)*CC(I1,J1,D4)+CC(D1,D2,D4)*CC(I1,J1,D3))/D;
 findcentre(A1,A2,A3,A4,A5,B1,B2,B3,B4,B5);
   IF NOTTRIV=0 THEN trivcent(A1,A2,A3,A4,A5,B1,B2,B3,B4,B5)
  ELSE
  IF (SOL(1,3)=0 AND SOL(1,4)=0) THEN
   IF SOL(1,1)=0 THEN
   <> ELSE
   <> ELSE
  IF DET(MAT((1,0,0,0),(0,1,0,0),
        (SOL(1,1),SOL(1,2),SOL(1,3),SOL(1,4)),(0,0,0,1)))=0 THEN
  <> ELSE
  <>;
 CLEAR SOL,NOTTRIV
END;

algebraic procedure findcentre(A1,A2,A3,A4,A5,B1,B2,B3,B4,B5);
BEGIN INTEGER FLAG;
      SCALAR HELP;
 NOTTRIV:=0;FLAG:=0;
 CENT:=MAT((A1,A2,0,-A5),(A3,A4,A5,0),(B1,B2,0,-B5),
           (B3,B4,B5,0),(0,0,A1,A3),(0,0,A2,A4),
           (0,0,B1,B3),(0,0,B2,B4));
 FOR I:=1:4 DO
  IF (CENT(I,1) NEQ 0 AND FLAG=0) THEN
  <>>>;
 IF FLAG=0 THEN <> ELSE
 <>;
   FLAG:=0;
   FOR I:=2:4 DO
    IF (CENT(I,2) NEQ 0 AND FLAG=0) THEN
    <>>>;
   IF FLAG=0 THEN <> ELSE
   <>;
     FLAG:=0;
     FOR I:=3:8 DO
      IF (CENT(I,3) NEQ 0 AND FLAG=0) THEN
      <>>>;
     IF FLAG=0 THEN <> ELSE
     <>;
       FLAG:=0;
       FOR I:=4:8 DO
        IF (CENT(I,4) NEQ 0 AND FLAG=0) THEN
        <>;
       IF FLAG=0 THEN <>
  >>>>>>;
 CLEAR CENT
END;

algebraic procedure centincom(A,C,E,B,D,F);
BEGIN SCALAR V1,W1,V2,W2;
 IF C=0 THEN IF D=0 THEN
   <> ELSE
     <> ELSE
  <>;
 IF W1=0 THEN
  <> ELSE
  <>
END;

algebraic procedure centoutcom(A,C,B,D);
BEGIN INTEGER FLAG;
      SCALAR ALPHA,BETA;
 FLAG:=0;
 IF C NEQ 0 THEN
 <> ELSE
  IF B NEQ 0 THEN
   <> ELSE
   IF A NEQ D THEN
    <> ELSE
      <>;
 IF FLAG=1 THEN
  <> ELSE
  IF ALPHA=0 THEN
   <0 then lie_class:={liealg(4),comtab(11)} else
                    lie_class:={liealg(4),comtab(8)}>> ELSE
    <>
END;

algebraic procedure trivcent(A1,A2,A3,A4,A5,B1,B2,B3,B4,B5);
BEGIN INTEGER FLAG;
      SCALAR HE,HELP,ALPHA,BETA,C1,C2,C3,C4,C5,
             D1,D2,D3,D4,D5,P,E1,E2,E3,E4,E5,E6;
 IF (A1*B2-A2*B1)=0 THEN
  IF (A3*B4-A4*B3)=0 THEN
   <> ELSE
   <>;
 IF A2 NEQ 0 THEN <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN FLAG:=2 ELSE FLAG:=3>> ELSE
     IF BETA>0 THEN FLAG:=2 ELSE FLAG:=3>> ELSE
   <>>> ELSE
  IF B1 NEQ 0 THEN <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN FLAG:=2 ELSE FLAG:=3>> ELSE
      IF BETA>0 THEN FLAG:=2 ELSE FLAG:=3>> ELSE
    <>>> ELSE
   IF A1 NEQ B2 THEN <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN FLAG:=2 ELSE FLAG:=3>> ELSE
       IF BETA>0 THEN FLAG:=2 ELSE FLAG:=3>> ELSE
     <>>> ELSE
     <>;
 liemat:=MAT((C1,C2,0,0),(C3,C4,0,0),(0,0,C5,0),(0,0,0,1))*liemat;
 E1:=D1*(C1*A3+C2*A4)+D3*(C1*B3+C2*B4);
 E2:=D2*(C1*A3+C2*A4)+D4*(C1*B3+C2*B4);
 E3:=D1*(C3*A3+C4*A4)+D3*(C3*B3+C4*B4);
 E4:=D2*(C3*A3+C4*A4)+D4*(C3*B3+C4*B4);
 E5:=C5*A5*D1+C5*B5*D3;
 E6:=C5*A5*D2+C5*B5*D4;
 IF FLAG=4 THEN
  <> ELSE
  IF FLAG=1 THEN
   IF (E1+E4=0) THEN
    <> ELSE
    <>;
 IF (FLAG=1 OR FLAG=4) THEN
  IF A1*B2-A2*B1=0 THEN
   IF B1=0 THEN
    <> ELSE
    <> ELSE
   <> ELSE
       IF B1 NEQ 0 THEN
        <> ELSE
        <>;
     IF NOT(NUMBERP(BETA)) THEN
     <0 ? (y/n) and press ";
       HE:=SYMBOLIC READ();
       IF HE=y THEN FLAG:=2 ELSE FLAG:=3>> ELSE
     IF BETA>0 THEN FLAG:=2 ELSE FLAG:=3;
     liemat:=MAT((C1,C2,0,0),(C3,C4,0,0),(0,0,C5,0),(0,0,0,1))*liemat;
     E1:=D1*(C1*A3+C2*A4)+D3*(C1*B3+C2*B4);
     E2:=D2*(C1*A3+C2*A4)+D4*(C1*B3+C2*B4);
     E3:=D1*(C3*A3+C4*A4)+D3*(C3*B3+C4*B4);
     E4:=D2*(C3*A3+C4*A4)+D4*(C3*B3+C4*B4);
     E5:=C5*A5*D1+C5*B5*D3;
     E6:=C5*A5*D2+C5*B5*D4>>;
 IF FLAG=2 THEN
  <> ELSE
  IF FLAG=3 THEN
   <> ELSE
  <>;
END;

algebraic procedure com43(I1,J1,I2,J2,I3,J3);
BEGIN INTEGER LL;
      MATRIX liemat(4,4),BB(4,4),FF(3,3);
      ARRAY l_Z(4,4,3);
 FOR I:=1:4 DO
  <>;
 liemat(4,1):=1;IF DET(liemat) NEQ 0 THEN LL:=1 ELSE
  FOR J:=2:4 DO <>>>;
 BB:=1/liemat;
 FOR I:=1:3 DO
  <>;
 FOR I:=1:3 DO
  <>;
 LL:=0;
 FOR I:=1:3 DO FOR J:=1:3 DO
  IF FF(I,J) NEQ 0 THEN <>;
 IF LL=0 THEN comcom0() ELSE
  IF DET(FF)=0 THEN comcom1() ELSE comcom3();
 CLEAR BB,FF,l_Z
END;

algebraic procedure comcom0();
BEGIN SCALAR HE,A1,B1,C1,A2,B2,C2,A3,B3,C3,AA1,BB1,CC1,
             AA2,BB2,CC2,AL1,BE1,GA1,AL2,BE2,GA2,R,S,P,Q;
 A1:=l_Z(1,4,1);B1:=l_Z(1,4,2);C1:=l_Z(1,4,3);
 A2:=l_Z(2,4,1);B2:=l_Z(2,4,2);C2:=l_Z(2,4,3);
 A3:=l_Z(3,4,1);B3:=l_Z(3,4,2);C3:=l_Z(3,4,3);
 IF (A3=0 AND B3=0) THEN
  <> ELSE
  <> ELSE
   <>;
  <>;
  IF (BB1=0 AND AA1=BB2 AND CC2 NEQ 0) THEN
   <> ELSE
    IF (BB1=0 AND AA1 NEQ BB2 AND CC2 NEQ 0) THEN
     <>ELSE
     IF(BB1=0 AND CC2=0) THEN
      <>
     ELSE
      <>>>;
 IF GA2 NEQ 0 THEN
 <>
  ELSE <>;
 IF (AA2=0 AND AA1-BB1-BB2=0 AND -AA1-BB1+BB2=0 AND CC2=0)
  THEN c0111(AA1,AA1) ELSE
  <> ELSE
      IF (-AA1-BB1+BB2) NEQ 0 THEN
       <> ELSE
      <>;
    liemat:=MAT((1,-AA1/AA2,AA1*CC2/AA2,0),(0,1,0,0),(0,0,1,0),
            (0,0,0,1))*liemat;
    BE1:=BB1-AA1*BB2/AA2;
    AL2:=AA2;BE2:=AA1+BB2;GA2:=CC2-AA1*CC2;
    liemat:=MAT((1,0,0,0),(-BE2,BE1,0,0),(0,0,1,0),(0,0,0,1))*liemat;
    AA1:=BE2; AA2:=AL2*BE1;CC2:=GA2*BE1;
    IF (CC2 NEQ 0 AND AA2=(1-AA1)) THEN
     <>
        ELSE <>>> ELSE
     <> ELSE
        <";
            HE:=SYMBOLIC READ();
            IF HE=y THEN
            <>
            ELSE
          <>>>>> ELSE
          IF R<0 THEN
           <>
            ELSE
          <>>>
     >>>>
 END;

algebraic procedure c0111(MY,NY);
BEGIN
 liemat:=MAT((0,0,1,0),(1,0,0,0),(0,1,0,0),(0,0,0,1))*liemat;
 if symbolic !*tr_lie then
 WRITE "[W,Z]=W, [X,Z]=",MY,"X, [Y,Z]=",NY,"Y";
 lie_class:={liealg(4),comtab(13),MY,NY}
END;

ALGEBRAIC PROCEDURE COMCOM1();
BEGIN INTEGER II;
      SCALAR HE,A1,A2,A3,B2,B3,C2,C3,HELP;
      MATRIX A11(4,4),A22(4,4),A33(4,4),CCC(3,3);
 HELP:=0;
 FOR M:=1:3 DO FOR N:=1:3 DO
  IF FF(M,N) NEQ 0 THEN <>;
  A11:=MAT((1,0,0,0),(0,1,0,0),(FF(II,1),FF(II,2),FF(II,3),0),
           (0,0,0,1));
  A22:=MAT((1,0,0,0),(0,0,1,0),(FF(II,1),FF(II,2),FF(II,3),0),
           (0,0,0,1));
  A33:=MAT((0,1,0,0),(0,0,1,0),(FF(II,1),FF(II,2),FF(II,3),0),
           (0,0,0,1));
 IF DET(A11) NEQ 0 THEN liemat:=A11*liemat ELSE
  IF DET(A22) NEQ 0 THEN liemat:=A22*liemat ELSE liemat:=A33*liemat;
 liemat:=MAT((0,0,1,0),(1,0,0,0),(0,1,0,0),(0,0,0,1))*liemat;
 A11:=1/liemat;
 FOR M:=1:3 DO FOR N:=1:3 DO
 CCC(M,N):=FOR I:=1:4 SUM FOR J:=1:4 SUM FOR K:=1:4 SUM
  liemat(M,I)*liemat(4,J)*CC(I,J,K)*A11(K,N);
 A1:=CCC(1,1);A2:=CCC(2,1);A3:=CCC(3,1);B2:=CCC(2,2);
 B3:=CCC(3,2);C2:=CCC(2,3);C3:=CCC(3,3);
 IF A1=0 THEN
  <> ELSE
      <>;
    HELP:=B2*B2+C2*B3;C3:=SQRT(ABS(HELP));
    liemat:=MAT((C2/C3,0,0,0),(0,1,0,0),(0,B2/C3,C2/C3,0),
            (0,A3*C3/HELP,-A2*C3/HELP,C3/HELP))*liemat;
    if symbolic !*tr_lie then
    WRITE "[X,Y]=W, [X,Z]=",HELP/ABS(HELP),"Y, [Y,Z]=X";
    if HELP>0 then lie_class:={liealg(4),comtab(19)} else
                   lie_class:={liealg(4),comtab(20)}>> ELSE
  <> ELSE
       <";
              HE:=SYMBOLIC READ();
              IF HE=y THEN A3:=-A3>> ELSE
            IF A1<0 THEN A3:=-A3;
            liemat:=MAT((1,0,0,0),(0,1,0,0),(0,1,1,0),(0,0,0,1))*liemat;
            B2:=1-A3;C2:=A3;C3:=A3+1>> ELSE
          <";
              HE:=SYMBOLIC READ();
              IF HE=y THEN
              liemat:=MAT((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*
              liemat>> ELSE
            IF A1<0 THEN
            liemat:=MAT((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))
                       *liemat;
            if symbolic !*tr_lie then
            WRITE "[W,Z]=2W, [X,Y]=W, [X,Z]=X-",A3,"Y, ",
           "[Y,Z]=",A3,"X+Y";lie_class:={liealg(4),comtab(17),A3}>>>>>>;
    IF (HELP NEQ 1) THEN
     IF (C2=0 OR B2 NEQ C3) THEN
     <";
              HE:=SYMBOLIC READ();
              IF HE=y THEN
          liemat:=MAT((-1,0,0,0),(0,0,1,0),(0,1,0,0),(0,0,0,1))*liemat;
              HELP:=B2;B2:=C3;C3:=HELP>> ELSE
      IF B2<1 THEN
        <>;
        if symbolic !*tr_lie then
        WRITE "[W,Z]=2W, [X,Y]=W, [X,Z]=",B2,"X, [Y,Z]=",C3,"Y";
        lie_class:={liealg(4),comtab(16),B2-1}>> ELSE
      <";
              HE:=SYMBOLIC READ();
              IF HE=y THEN
              liemat:=MAT((-1,0,0,0),(0,1,0,0),(0,0,-1,0),(0,0,0,1))*
              liemat>> ELSE
        IF C2<0 THEN
         liemat:=MAT((-1,0,0,0),(0,1,0,0),(0,0,-1,0),(0,0,0,1))*liemat;
        if symbolic !*tr_lie then
        WRITE "[W,Z]=2W, [X,Y]=W, [X,Z]=X+Y, [Y,Z]=Y";
        lie_class:={liealg(4),comtab(18)}>>>>;
 CLEAR A11,A22,A33,CCC
END;

algebraic procedure comcom3();
BEGIN INTEGER HELP;
      SCALAR HE,AL,BE,GA;
      MATRIX l_K(3,3),l_A(3,3);
 HELP:=0;
 l_K(1,1):=FF(1,2)**2+2*FF(1,3)*FF(2,2)+FF(2,3)**2;
 l_K(1,2):=-FF(1,1)*FF(1,2)+FF(1,3)*FF(3,2)-
          FF(2,1)*FF(1,3)+FF(2,3)*FF(3,3);
 l_K(1,3):=-FF(1,1)*FF(2,2)-FF(1,2)*FF(3,2)-
          FF(2,1)*FF(2,3)-FF(2,2)*FF(3,3);
 l_K(2,1):=l_K(1,2);
 l_K(2,2):=FF(1,1)**2-2*FF(1,3)*FF(3,1)+FF(3,3)**2;
 l_K(2,3):=FF(1,1)*FF(2,1)+FF(1,2)*FF(3,1)-
         FF(3,1)*FF(2,3)-FF(3,2)*FF(3,3);
 l_K(3,1):=l_K(1,3);l_K(3,2):=l_K(2,3);
 l_K(3,3):=FF(2,1)**2+2*FF(2,2)*FF(3,1)+FF(3,2)**2;
 IF NOT(NUMBERP(l_K(1,1)) AND
  NUMBERP(l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1)) AND
        NUMBERP(DET(l_K))) THEN
 <0 and ",
      l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1),">0 and ",
     -DET(l_K),">0 ? (y/n) and press ";
   HE:=SYMBOLIC READ();
   IF HE=y THEN <> ELSE lie4so21()>> ELSE
 IF (-l_K(1,1)>0 AND l_K(1,1)*l_K(2,2)-l_K(1,2)*l_K(2,1)>0 AND
     -DET(l_K)>0) THEN
  <> ELSE lie4so21();
 liemat:=MAT((l_A(1,1),l_A(1,2),l_A(1,3),0),(l_A(2,1),l_A(2,2),
          l_A(2,3),0), (l_A(3,1),l_A(3,2),l_A(3,3),0),(0,0,0,1))*liemat;
 BB:=1/liemat;
 AL:=FOR J:=1:4 SUM FOR K:=1:4 SUM FOR L:=1:4 SUM
         liemat(1,J)*liemat(4,K)*CC(J,K,L)*BB(L,2);
 BE:=FOR J:=1:4 SUM FOR K:=1:4 SUM FOR L:=1:4 SUM
         liemat(1,J)*liemat(4,K)*CC(J,K,L)*BB(L,3);
 GA:=FOR J:=1:4 SUM FOR K:=1:4 SUM FOR L:=1:4 SUM
         liemat(2,J)*liemat(4,K)*CC(J,K,L)*BB(L,3);
 IF HELP=1 THEN
  liemat:=MAT((1,0,0,0),(0,1,0,0),(0,0,1,0),(GA,-BE,AL,1))*liemat ELSE
  liemat:=MAT((1,0,0,0),(0,1,0,0),(0,0,1,0),(GA,-BE,-AL,1))*liemat;
 IF HELP=1 THEN
  <> ELSE
  <>;
 CLEAR l_K,l_A
END;

algebraic procedure lie4so3();
BEGIN SCALAR S,TT,Q,R,ALPHA;
 S:=FF(2,2)/ABS(FF(2,2));
 TT:=ABS(FF(1,2)**2+FF(1,3)*FF(2,2));
 R:=FF(1,1)-FF(1,2)*FF(2,1)/FF(2,2);
 ALPHA:=TT*(-R*R-((FF(2,1)/FF(2,2))**2+FF(3,1)/FF(2,2))*TT);
 Q:=1/SQRT(ALPHA);
 l_A(1,1):=1/(S*SQRT(TT));l_A(1,2):=l_A(1,3):=l_A(2,2):=0;l_A(2,1):=Q*R;
 l_A(2,3):=-Q*TT/FF(2,2);l_A(3,1):=-Q*S*SQRT(TT)*FF(2,1)/FF(2,2);
 l_A(3,2):=-Q*S*SQRT(TT);l_A(3,3):=Q*S*SQRT(TT)*FF(1,2)/FF(2,2)
END;

algebraic procedure lie4so21();
BEGIN SCALAR GAM,EPS,S,TT,Q,R,ALPHA;
      MATRIX l_G(3,3);
 l_A:=MAT((1,0,0),(0,1,0),(0,0,1));
 IF FF(2,2)=0 THEN
  IF FF(1,3) NEQ 0 THEN <>
    ELSE
   IF FF(3,1) NEQ 0 THEN <> ELSE
                         <>;
 IF FF(1,2)**2+FF(1,3)*FF(2,2)=0 THEN
  <> ELSE
   <>>>;
 IF NOT(NUMBERP(FF(1,2)**2+FF(1,3)*FF(2,2))) THEN
 <";
   HE:=SYMBOLIC READ();
   IF HE=y THEN
   <> ELSE
  <0 ? (y/n) and press ";
    HE:=SYMBOLIC READ();
    IF HE =y THEN
    <> ELSE
   <>>> ELSE
  IF ALPHA>0 THEN
   <> ELSE
   <>
>>>> ELSE
 IF FF(1,2)**2+FF(1,3)*FF(2,2)<0 THEN
  <> ELSE
  <0 ? (y/n) and press ";
    HE:=SYMBOLIC READ();
    IF HE =y THEN
    <> ELSE
   <>>> ELSE
  IF ALPHA>0 THEN
   <> ELSE
   <>>>;
 CLEAR l_G
END;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/pf.rlg0000644000175000017500000000454411527635055022575 0ustar  giovannigiovanniFri Feb 18 21:27:26 2011 run on win32
% Tests of the partial fraction module.

% Author: Anthony C. Hearn

off exp;



pf(2/((x+1)^2*(x+2)),x);


    2      - 2       2
{-------,-------,----------}
  x + 2   x + 1          2
                  (x + 1)


pf(x/((x+1)^2*(x+2)^2*(x+3)),x);


     - 3
{-----------,
  4*(x + 3)

   - 1
 -------,
  x + 2

     - 2
 ----------,
         2
  (x + 2)

      7
 -----------,
  4*(x + 1)

      - 1
 ------------}
           2
  2*(x + 1)


pf(x/(x^2-2x-3),x);


      1           3
{-----------,-----------}
  4*(x + 1)   4*(x - 3)


pf((10x^2-11x-6)/(x^3-x^2-2x),x);


    5       2     3
{-------,-------,---}
  x + 1   x - 2   x


pf(x^2/((x+1)*(x^2+1)),x);


    x - 1          1
{------------,-----------}
      2        2*(x + 1)
  2*(x  + 1)


pf((2x^6-11x^5+37x^4-94x^3+212x^2-471x+661)
 /(x^7-5x^6+5x^5-25x^4+115x^3-63x^2+135x-675),x);


     x - 3
{--------------,
   2
  x  + 2*x + 5

       x - 3
 -----------------,
    2           2
  (x  + 2*x + 5)

    1
 -------,
  x - 3

     1
 ----------,
         2
  (x - 3)

     1
 ----------}
         3
  (x - 3)


% A harder example.

pf(((2*w**2+2*h**2*l**2*t**2+2*h**2*l**2*qst**2)*z**2-8*h**2*l**2*qst
     *t*z+2*w**2+2*h**2*l**2*t**2+2*h**2*l**2*qst**2)/((w**2+h**4*l**2)
     *((w**2+l**2*t**4+2*l**2*qst**2*t**2+l**2*qst**4)*z**4+(-8*l**2
     *qst*t**3-8*l**2*qst**3*t)*z**3+(2*w**2+2*l**2*t**4+20*l**2*
     qst**2*t**2+2*l**2*qst**4)*z**2+(-8*l**2*qst*t**3-8*l**2*qst**3
     *t)*z+w**2+l**2*t**4+2*l**2*qst**2*t**2+l**2*qst**4))
   -2*h**2/((w**2+h**4*l**2)*((t**2+qst**2+h**2)*z**2-4*qst*t*z+t**2
      +qst**2+h**2)),z);


          2    2    2                    2  2     2       2
{(2*(((qst  + t )*(z  + 1) - 4*qst*t*z)*h *l  + (z  + 1)*w ))/(((

              4    4    4      2              2    2    2
          (qst  + t )*(z  + 2*z  + 1) - 8*(qst  + t )*(z  + 1)*qst*t*z

                 4       2         2  2   2     4      2       2    4  2    2
           + 2*(z  + 10*z  + 1)*qst *t )*l  + (z  + 2*z  + 1)*w )*(h *l  + w )),

                                   2
                              - 2*h
 ---------------------------------------------------------------}
       2    2    2                      2       2    4  2    2
  ((qst  + t )*(z  + 1) - 4*qst*t*z + (z  + 1)*h )*(h *l  + w )


end;


Time for test: 15 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 0 3 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/changevr.tst0000644000175000017500000001343711526203062024000 0ustar  giovannigiovanni%*********************************************************************;
%         This is a test file    for  the  CHANGEVAR package.         ;
%         Make sure that before you attempt to run it the             ;
%         MATRIX package and CHANGEVAR is loaded.                     ;
%*********************************************************************;
algebraic;
%*********************************************************************;
% ON DISPJACOBIAN;   % To get the Jacobians printed, remove the...    ;
%                      ... percentage sign before the word ON         ;
%*********************************************************************;
%                                                                     ;
%               *** First test problem ***                            ;
%                                                                     ;
% Here are two  Euler type of differential equations,                 ;
%                                                                     ;
%         3             2                                             ;
%      2 x  y'''  +  3 x  y''  -  y  =  0                             ;
%                                                                     ;
%                                                                     ;
%          2                                                          ;
%      5 x  y''  -   x y' + 7 y  =  0                                 ;
%                                                                     ;
%                                                                     ;
% An Euler equation can be converted into a (linear) equation with    ;
% constant coefficients by making change of independent variable:     ;
%                                                                     ;
%                         u                                           ;
%                    x = e                                            ;
%                                                                     ;
% The  resulting equations will be                                    ;
%                                                                     ;
%                                                                     ;
%      2 y'''  -  3 y''  +  y' -  y  =  0                             ;
%                                                                     ;
% and                                                                 ;
%                                                                     ;
%      5  y''  -  6 y' + 7 y  =  0                                    ;
%                                                                     ;
%                                                                     ;
% Where, now (prime) denotes differentiation with respect to the new  ;
% independent variable: u                                             ;
% How this change of variable is done using CHANGEVAR follows.        ;
%                                                                     ;
%*********************************************************************;

operator y;

changevar(y, u, x=e**u, { 2*x**3*df(y(x),x,3)+3*x**2*df(y(x),x,2)-y(x),
                          5*x**2*df(y(x),x,2)-x*df(y(x),x)+7*y(x) } ) ;

%*********************************************************************;
%               *** Second test problem ***                           ;
%                                                                     ;
% Now, the problem is to obtain the polar coordinate form of Laplace's;
% equation:                                                           ;
%                                                                     ;
%          2              2                                           ;
%         d  u           d  u                                         ;
%        ------    +    ------    =    0                              ;
%            2              2                                         ;
%         d x            d y                                          ;
%                                                                     ;
% (The differentiations are partial)                                  ;
%                                                                     ;
% For polar coordinates the change of variables are :                 ;
%                                                                     ;
%        x = r cos(theta) ,    y = r sin(theta)                       ;
%                                                                     ;
% As known, the result is :                                           ;
%                                                                     ;
%                                                                     ;
%          2                                     2                    ;
%         d  u         1    d  u         1      d  u                  ;
%        ------   +   ---  ------   +   ---  ----------   =   0       ;
%            2         r    d r           2          2                ;
%         d r                            r    d theta                 ;
%                                                                     ;
% How this change of variable is done using CHANGEVAR follows.        ;
%                                                                     ;
%                              2       2                              ;
% (To get rid of the boring sin  + cos   terms we introduce a LET     ;
%  statement)                                                         ;
%                                                                     ;
%*********************************************************************;

operator u;

let sin theta**2 = 1 - cos theta**2 ;

changevar(u, { r , theta }, { x=r*cos theta, y=r*sin theta },
          df(u(x,y),x,2)+df(u(x,y),y,2) ) ;

end;  % End of test programs for CHANGEVAR ;
mathpiper-0.81f+svn4469+dfsg3/src/packages/misc/compact.tex0000644000175000017500000001000111526203062023577 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{COMPACT: Reduction of a Polynomial in the Presence of Side Relations}
\date{}
\author{Anthony C. Hearn\\ RAND\\
Santa Monica CA 90407-2138\\
Email: hearn@rand.org}
\begin{document}
\maketitle

\index{COMPACT package} \index{side relations} \index{relations ! side}
{COMPACT} is a package of functions for the reduction of a polynomial in
the presence of side relations.  The package defines one operator {COMPACT}
\index{COMPACT operator}
whose syntax is:

\begin{quote}
\k{COMPACT}(\s{expression}, \s{list}):\s{expression}
\end{quote}

\s{expression} can be any well-formed algebraic expression, and
\s{list} an expression whose value is a list
of either expressions or equations.  For example

\begin{verbatim}
    compact(x**2+y**3*x-5y,{x+y-z,x-y-z1});
    compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5,
            {cos(x)**2+sin(x)**2=1});
    let y = {cos(x)**2+sin(x)**2-1};
    compact(sin(x)**10*cos(x)**3+sin(x)**8*cos(x)**5,y);
\end{verbatim}

{COMPACT} applies the relations to the expression so that an equivalent
expression results with as few terms as possible.  The method used is
briefly as follows:

\begin{enumerate}
\item Side relations are applied separately to numerator and denominator, so
that the problem is reduced to the reduction of a polynomial with respect to
a set of polynomial side relations.

\item Reduction is performed sequentially, so that the problem is reduced
further to the reduction of a polynomial with respect to a single
polynomial relation.

\item The polynomial being reduced is reordered so that the variables
(kernels) occurring in the side relation have least precedence.

\item Each coefficient of the remaining kernels (which now only contain
the kernels
in the side relation) is reduced with respect to that side relation.

\item A polynomial quotient/remainder calculation is performed on the
coefficient.  The remainder is
used instead of the original if it has fewer terms.

\item The remaining expression is reduced with respect to the side relation
using a ``nearest neighbor'' approach.
\end{enumerate}

As with the traveling salesman problem, a nearest neighbor approach to
reduction does not necessarily achieve an optimal result.  In most cases
it will be within a factor of two from the optimal result, but in extreme
cases it may be much further away.

Another source of sub-optimal results is that the given expression
is reduced sequentially with respect to the side relations.  So for
example in the case

\begin{verbatim}
        compact((a+b+c)*(a-b-c)*(-a+b-c)*(-a-b+c),
                {x1=a+b+c,x2=a-b-c,x3=-a+b-c,x4=-a-b+c})
\end{verbatim}

the expression is actually $x_{1}x_{2}x_{3}x_{4}$, but any given relation
cannot reduce the size of the expanded form
$a^{4}-2a^{2}b^{2}-2a^{2}c^{2}+b^{4}-2b^{2}c^{2}+c^{4}$
of the original expression, and so the final result is far from optimal.

The only other program we have heard about that considers the compaction
problem is that of Hornfeldt~\cite{Hornfeldt:82}.
However, Hornfeldt reorders expressions so that the kernels in a side
relation have highest order.  Consequently, their coefficients are
polynomials rather than integers or other constants as in our approach.
Furthermore, it is not clear just how general Hornfeldt's approach is from
his description, since he only talks about sine and cosine substitutions.

There are a number of projects that this work immediately suggests.  For
example:

\begin{enumerate}
\item How does one do the reduction with the side relations in parallel?
The above example shows this is necessary for an optimal solution.

\item Should one reduce the side relations to a Groebner or other basis
before doing any reduction?

\item Should one check for the consistency of the basis?

\item How does one do factorization and gcds on a polynomial whose
variables are related by a set of side relations?
\end{enumerate}

The author would be interested in hearing from anyone wishing to work with
him on any of these problems.
\bibliography{compact}
\bibliographystyle{plain}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/micropackage.map0000644000175000017500000002410011570371030023625 0ustar  giovannigiovanni% This is a copy of ".../trunk/packages/package.map" but has a number of
% lines commented out with the result that the Java build (if it uses this
% file) will build a micro-Reduce with only a selection of the main set of
% packages. This capability will be useful because of the reduction in the
% size of the image file.

% After making a selection here it will be necessary to do a careful evaluation and
% run proper tests to assure oneself that any omitted packages are not in
% fact prerequisites for things then included.

(
 (support       "support"     core                               psl)
 (rlisp         "rlisp"       core                           csl psl)
 (alg           "alg"         core      test                 csl psl)
 (poly          "poly"        core      test                 csl psl)
 (polydiv       "poly"        core      test                 csl psl)
 (arith         "arith"       core      test                 csl psl)
 (mathpr        "mathpr"      core                           csl psl)
 (ezgcd         "factor"      core                           csl psl)
 (factor        "factor"      core      test                 csl psl)
%(hephys        "hephys"      core                           csl psl)
 (int           "int"         core      test                 csl psl)
%% (matrix        "matrix"      core      test                 csl psl)
%(rlisp88       "rlisp88"     core                           csl psl)
%(rprint        "rprint"      core                           csl psl)
%(fmprint       "rprint"      core                           csl psl)
%(pretty        "rprint"      core                           csl psl)
 (solve         "solve"       core      test                 csl psl)
%(desir         "solve"       core      test                 csl psl)
%% (ineq          "solve"       core      test                 csl psl)
 (modsr         "solve"       core      test                 csl psl)
%% (rsolve        "solve"       core      test                 csl psl)
 (algint        "algint"      core      test                 csl psl)
%% (arnum         "arnum"       core      test                 csl psl)
%% (assist        "assist"      core      test                 csl psl)
%% (dummy         "assist"      core      test                 csl psl)
%(cantens       "assist"      core      test                 csl psl)
%(atensor       "atensor"     core      test                 csl psl)
%(avector       "avector"     core      test                 csl psl)
%(invbase       "invbase"     core      test                 csl psl)
%% (misc          "misc"        core                           csl psl)
%% (boolean       "misc"        core      test                 csl psl)
%(cedit         "misc"        core                           csl psl)
%(rcref         "misc"        core                           csl psl)
%(ftr           "misc"        core                           csl psl)
 (reset         "misc"        core                           csl psl)
%(cali          "cali"        core      test                 csl psl)
%(camal         "camal"       core      test                 csl psl)
%% (changevr      "misc"        core      test                 csl psl)
 (compact       "misc"        core      test                 csl psl)
%% (dfpart        "misc"        core      test                 csl psl)
%(lie           "misc"        core      test                 csl psl)
%% (assert        "assert"                test                 csl psl)
%% (odesolve      "odesolve"    noncore   test                 csl psl)
%% (pf            "misc"                  test                 csl psl)
%(cvit          "hephys"                test                 csl psl)
%(noncom2       "hephys"                                     csl psl)
%(physop        "hephys"                test                 csl psl)
%(crack         "crack"                 test                 csl psl)
%(liepde        "crack"                 test                 csl psl)
%(applysym      "crack"                 test                 csl psl)
%(conlaw        "crack"                 test                 csl psl)
%(excalc        "excalc"                test                 csl psl)
%(gentran       "gentran"               test                 csl psl)
%(fide1         "fide"                                       csl psl)
%(fide          "fide"                  test                 csl psl)
 (numeric       "numeric"               test                 csl psl)
%% (randpoly      "misc"                  test                 csl psl)
%(reacteqn      "misc"                  test                 csl psl)
 (roots         "roots"                 test                 csl psl)
%(rlfi          "misc"                  test                 csl psl)
 (roots2        "roots"                                      csl psl)
%% (sets          "misc"                  test                 csl psl)
%(xideal        "xideal"                test                 csl psl)
%(eds           "eds"                   test                 csl psl)
%(dipoly        "dipoly"                                     csl psl)
%(groebner      "groebner"              test                 csl psl)
%(groebnr2      "groebner"                                   csl psl)
%(ideals        "groebner"              test                 csl psl)
%% (linalg        "linalg"                test                 csl psl)
%(ncpoly        "ncpoly"                test                 csl psl)
%% (normform      "normform"              test                 csl psl)
%(orthovec      "orthovec"              test                 csl psl)
%(plot          "plot"                                       csl psl)
%(gnuplot       "plot"                                       csl psl)
%(laplace       "laplace"               test                 csl psl)
%(pm            "pm"                    test                 csl psl)
%(qsum          "qsum"                  test                 csl psl)
%(scope         "scope"                 test                 csl psl)
%(sparse        "sparse"                test                 csl psl)
%(spde          "spde"                  test                 csl psl)
%% (specfn        "specfn"                test                 csl psl)
%% (specfn2       "specfn"                                     csl psl)
%% (specfaux      "specfn"                                     csl psl)
%% (specbess      "specfn"                                     csl psl)
%% (sfgamma       "specfn"                                     csl psl)
%% (tps           "tps"                   test                 csl psl)
%% (limits        "misc"                  test                 csl psl)
%% (defint        "defint"                test                 csl psl)
%% (fps           "specfn"                test                 csl psl)
%% (trigint       "trigint"               test                 csl psl)
%% (ratint        "ratint"                test                 csl psl)
%% (mathml        "mathml"                test                 csl psl)
%(mathmlom      "mathml"                test                 csl psl)
%(rltools       "redlog/rltools"                             csl psl)
%(redlog        "redlog/rl"             test                 csl psl)
%(cgb           "cgb"                   test                 csl psl)
%(cl            "redlog/cl"                                  csl psl)
%(ofsf          "redlog/ofsf"           test                 csl psl)
%(dvfsf         "redlog/dvfsf"                               csl psl)
%(acfsf         "redlog/acfsf"                               csl psl)
%(dcfsf         "redlog/dcfsf"                               csl psl)
%% (geometry      "geometry"                                   csl psl)
%(ibalp         "redlog/ibalp"          test                 csl psl)
%(pasf          "redlog/pasf"           test                 csl psl)
%(qqe           "redlog/qqe"                                 csl psl)
%(qqe_ofsf      "redlog/qqe_ofsf"       test                 csl psl)
%(mri           "redlog/mri"                                 csl psl)
%(mri_ofsf      "redlog/mri"                                 csl psl)
%(mri_pasf      "redlog/mri"                                 csl psl)
%(redfront      "redfront"                                   csl psl)
%(reduce4       "reduce4"                                    csl psl)
%(tables        "reduce4"                                    csl psl)
%(talp          "redlog/talp"                                csl psl)
%(v3tools       "crack"                                      csl psl)
%% (sum           "sum"                   test                 csl psl)
%% (zeilberg      "sum"                   test                 csl psl)
%(symaux        "symmetry"                                   csl psl)
%(symmetry      "symmetry"              test                 csl psl)
%% (taylor        "taylor"                test                 csl psl)
%% (mrvlimit      "mrvlimit"              test                 csl psl)
%% (residue       "residue"               test                 csl psl)
%(susy2         "susy2"                 test                 csl psl)
%(tri           "tri"                   test                 csl psl)
%% (trigsimp      "trigsimp"              test                 csl psl)
%(xcolor        "xcolor"                test                 csl psl)
%% (wu            "wu"                    test                 csl psl)
%(ztrans        "ztrans"                test                 csl psl)
%% (geoprover     "geometry"              test                 csl psl)
%% (rataprx       "rataprx"               test                 csl psl)
%(rtrace        "rtrace"                                     csl psl)
 (tmprint       "tmprint"                                    csl psl)
%(libreduce     "libreduce"                                  csl psl)
%(qepcad        "redlog/qepcad"                              csl psl)
%% (utf8          "utf8"                                       csl psl)
%(lpdo          "lpdo"                  test                 csl psl)
%(mma           "redlog/mma"                                 csl psl)
%(guardian      "guardian"              test                 csl psl)
%(cdiff         "cdiff"                 test                 csl psl)
)

% End of configuration data
mathpiper-0.81f+svn4469+dfsg3/src/packages/rd/0000755000175000017500000000000011722677357021135 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/rd/rd.red0000644000175000017500000001036211526203062022214 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: rd.red 477 2009-11-28 14:09:32Z arthurcnorman $
% ----------------------------------------------------------------------
% Copyright (c) 2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

module rd;

load!-package 'remake;

fluid '(here!* packagemap!*);

switch rd_force;

copyd('olderfaslp_orig,'olderfaslp);

procedure olderfaslp(x,y);
   !*rd_force or olderfaslp_orig(x,y);

procedure rd_init(here);
   <<
      here!* := here;
      read!-package_map concat2(here!*,"/packages/package.map");
   >>;

procedure module2!-to!-file(u,v);
   % Converts the module u in package directory v to a fully rooted file
   % name.
   if v then
      concat2(mkfil v,concat2("/",concat2(mkfil u,".red")))
   else
      concat2(mkfil u,".red");

procedure m2f(u,v);
   module2!-to!-file(u,get_path v);

procedure read!-package_map(mapfile);
   begin scalar chan;
      chan := rds open(mapfile,'input);
      packagemap!* := read();
      close rds chan;
      return packagemap!*
   end;

procedure get_path(y);
   begin scalar w;
      w := atsoc(y,packagemap!*);
      return if w then concat2(here!*,concat2("/packages/",cadr w));
   end;

procedure get_submodules(y);
   begin scalar w;
      w := get(y,'package);
      if w then return w;
      w := file!-transform(m2f(y,y),function get_submodules1);
      if w then
 	 eval w
      else
 	 put(y,'package,{y});
      return get(y,'package)
   end;

procedure get_submodules1();
   begin scalar w;
      repeat <<
	 w := xread t
      >> until eqcar(w,'create!-package);
      return w
   end;

procedure makep(y);
   begin scalar rmk,packl,sy,z;
      packl := get_submodules y;
      rmk := nil; while packl and not rmk do <<
   	 sy := car packl;
   	 packl := cdr packl;
   	 z := m2f(sy,y);
	 if 'psl memq lispsystem!* then
 	    sy := concat2("$fasl/", concat2(mkfil sy,".b"));
   	 if olderfaslp(sy,z) then rmk := t
      >>;
      return rmk
   end;

procedure rlint!-msg(y);
   <<
      terpri();
      prin2 "MAKESHMSG ";
      prin2 "Syntax-checking ";
      prin2 y;
      !#if (memq 'csl lispsystem!*)
      	 prin2t " for csl ...";
      !#else
      	 prin2t " for psl ...";
      !#endif
   >>;

procedure rlint(y);
   begin scalar z;
      off msg;
      on cref;
      for each sy in get_submodules y do <<
   	 z := m2f(sy,y);
   	 in_list1(z,t)
      >>;
      off cref;
   end;

procedure make(y);
   <<
      !#if (memq 'csl lispsystem!*)
      <<
   	 on backtrace;  % In case something goes wrong.
      	 !*savedef := nil;
	 !*native_code := nil
      >>;
      !#else
      <<
	 load!-package 'compiler;
	 errorset('(load compat),nil,nil)  % PSL compiler support.
      >>;
      !#endif
      !*argnochk := t;
      package!-remake2(y,get_path y)
   >>;

procedure up!-to!-date!-exit(y);
   <<
      terpri();
      prin2 "MAKESHVMSG ";
      prin2 y;
      prin2t " is up to date";
      bye
   >>;

endmodule;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/minipackage.map0000644000175000017500000002445711541264614023476 0ustar  giovannigiovanni% This is a copy of ".../trunk/packages/package.map" but has a number of
% lines commented out with the result that the Java build (if it uses this
% file) will build a mini-Reduce with only a selection of the main set of
% packages. This capability will be useful because of the reduction in the
% size of the image file and hence the jar package.

% The selection of what to include and what to omit here is rather a matter
% of taste and the eventual selection must be made on the basis of the needs
% of the eventual user. The sample choices here are not intended to be any
% reflection on the global value of any particular packages. Also after
% making a selection here it will be necessary to do a careful evaluation and
% run proper tests to assure oneself that any omitted packages are not in
% fact prerequisites for things then included.

(
 (support       "support"     core                               psl)
 (rlisp         "rlisp"       core                           csl psl)
 (alg           "alg"         core      test                 csl psl)
 (poly          "poly"        core      test                 csl psl)
 (polydiv       "poly"        core      test                 csl psl)
 (arith         "arith"       core      test                 csl psl)
 (mathpr        "mathpr"      core                           csl psl)
 (ezgcd         "factor"      core                           csl psl)
 (factor        "factor"      core      test                 csl psl)
%(hephys        "hephys"      core                           csl psl)
 (int           "int"         core      test                 csl psl)
 (matrix        "matrix"      core      test                 csl psl)
%(rlisp88       "rlisp88"     core                           csl psl)
%(rprint        "rprint"      core                           csl psl)
%(fmprint       "rprint"      core                           csl psl)
%(pretty        "rprint"      core                           csl psl)
 (solve         "solve"       core      test                 csl psl)
%(desir         "solve"       core      test                 csl psl)
 (ineq          "solve"       core      test                 csl psl)
 (modsr         "solve"       core      test                 csl psl)
 (rsolve        "solve"       core      test                 csl psl)
 (algint        "algint"      core      test                 csl psl)
 (arnum         "arnum"       core      test                 csl psl)
 (assist        "assist"      core      test                 csl psl)
 (dummy         "assist"      core      test                 csl psl)
%(cantens       "assist"      core      test                 csl psl)
%(atensor       "atensor"     core      test                 csl psl)
%(avector       "avector"     core      test                 csl psl)
%(invbase       "invbase"     core      test                 csl psl)
 (misc          "misc"        core                           csl psl)
 (boolean       "misc"        core      test                 csl psl)
%(cedit         "misc"        core                           csl psl)
%(rcref         "misc"        core                           csl psl)
%(ftr           "misc"        core                           csl psl)
 (reset         "misc"        core                           csl psl)
%(cali          "cali"        core      test                 csl psl)
%(camal         "camal"       core      test                 csl psl)
 (changevr      "misc"        core      test                 csl psl)
 (compact       "misc"        core      test                 csl psl)
 (dfpart        "misc"        core      test                 csl psl)
%(lie           "misc"        core      test                 csl psl)
 (assert        "assert"                test                 csl psl)
 (odesolve      "odesolve"    noncore   test                 csl psl)
 (pf            "misc"                  test                 csl psl)
%(cvit          "hephys"                test                 csl psl)
%(noncom2       "hephys"                                     csl psl)
%(physop        "hephys"                test                 csl psl)
%(crack         "crack"                 test                 csl psl)
%(liepde        "crack"                 test                 csl psl)
%(applysym      "crack"                 test                 csl psl)
%(conlaw        "crack"                 test                 csl psl)
%(excalc        "excalc"                test                 csl psl)
%(gentran       "gentran"               test                 csl psl)
%(fide1         "fide"                                       csl psl)
%(fide          "fide"                  test                 csl psl)
 (numeric       "numeric"               test                 csl psl)
 (randpoly      "misc"                  test                 csl psl)
%(reacteqn      "misc"                  test                 csl psl)
 (roots         "roots"                 test                 csl psl)
%(rlfi          "misc"                  test                 csl psl)
 (roots2        "roots"                                      csl psl)
 (sets          "misc"                  test                 csl psl)
%(xideal        "xideal"                test                 csl psl)
%(eds           "eds"                   test                 csl psl)
%(dipoly        "dipoly"                                     csl psl)
%(groebner      "groebner"              test                 csl psl)
%(groebnr2      "groebner"                                   csl psl)
%(ideals        "groebner"              test                 csl psl)
 (linalg        "linalg"                test                 csl psl)
%(ncpoly        "ncpoly"                test                 csl psl)
 (normform      "normform"              test                 csl psl)
%(orthovec      "orthovec"              test                 csl psl)
%(plot          "plot"                                       csl psl)
%(gnuplot       "plot"                                       csl psl)
%(laplace       "laplace"               test                 csl psl)
%(pm            "pm"                    test                 csl psl)
%(qsum          "qsum"                  test                 csl psl)
%(scope         "scope"                 test                 csl psl)
%(sparse        "sparse"                test                 csl psl)
%(spde          "spde"                  test                 csl psl)
 (specfn        "specfn"                test                 csl psl)
 (specfn2       "specfn"                                     csl psl)
 (specfaux      "specfn"                                     csl psl)
 (specbess      "specfn"                                     csl psl)
 (sfgamma       "specfn"                                     csl psl)
 (tps           "tps"                   test                 csl psl)
 (limits        "misc"                  test                 csl psl)
 (defint        "defint"                test                 csl psl)
 (fps           "specfn"                test                 csl psl)
 (trigint       "trigint"               test                 csl psl)
 (ratint        "ratint"                test                 csl psl)
 (mathml        "mathml"                test                 csl psl)
%(mathmlom      "mathml"                test                 csl psl)
%(rltools       "redlog/rltools"                             csl psl)
%(redlog        "redlog/rl"             test                 csl psl)
%(cgb           "cgb"                   test                 csl psl)
%(cl            "redlog/cl"                                  csl psl)
%(ofsf          "redlog/ofsf"           test                 csl psl)
%(dvfsf         "redlog/dvfsf"                               csl psl)
%(acfsf         "redlog/acfsf"                               csl psl)
%(dcfsf         "redlog/dcfsf"                               csl psl)
 (geometry      "geometry"                                   csl psl)
%(ibalp         "redlog/ibalp"          test                 csl psl)
%(pasf          "redlog/pasf"           test                 csl psl)
%(qqe           "redlog/qqe"                                 csl psl)
%(qqe_ofsf      "redlog/qqe_ofsf"       test                 csl psl)
%(mri           "redlog/mri"                                 csl psl)
%(mri_ofsf      "redlog/mri"                                 csl psl)
%(mri_pasf      "redlog/mri"                                 csl psl)
%(redfront      "redfront"                                   csl psl)
%(reduce4       "reduce4"                                    csl psl)
%(tables        "reduce4"                                    csl psl)
%(talp          "redlog/talp"                                csl psl)
%(v3tools       "crack"                                      csl psl)
 (sum           "sum"                   test                 csl psl)
 (zeilberg      "sum"                   test                 csl psl)
%(symaux        "symmetry"                                   csl psl)
%(symmetry      "symmetry"              test                 csl psl)
 (taylor        "taylor"                test                 csl psl)
 (mrvlimit      "mrvlimit"              test                 csl psl)
 (residue       "residue"               test                 csl psl)
%(susy2         "susy2"                 test                 csl psl)
%(tri           "tri"                   test                 csl psl)
 (trigsimp      "trigsimp"              test                 csl psl)
%(xcolor        "xcolor"                test                 csl psl)
 (wu            "wu"                    test                 csl psl)
%(ztrans        "ztrans"                test                 csl psl)
 (geoprover     "geometry"              test                 csl psl)
 (rataprx       "rataprx"               test                 csl psl)
%(rtrace        "rtrace"                                     csl psl)
 (tmprint       "tmprint"                                    csl psl)
%(libreduce     "libreduce"                                  csl psl)
%(qepcad        "redlog/qepcad"                              csl psl)
 (utf8          "utf8"                                       csl psl)
%(lpdo          "lpdo"                  test                 csl psl)
%(mma           "redlog/mma"                                 csl psl)
%(guardian      "guardian"              test                 csl psl)
%(cdiff         "cdiff"                 test                 csl psl)
)

% End of configuration data
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/0000755000175000017500000000000011722677362022002 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/factor/facmod.red0000644000175000017500000004211111526203062023706 0ustar  giovannigiovannimodule facmod; % Modular factorization: discover the factor count mod p.

% Authors: A. C. Norman and P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(current!-modulus
        dpoly
        dwork1
        dwork2
        known!-factors
        linear!-factors
        m!-image!-variable
        modular!-info
        null!-space!-basis
        number!-needed
        poly!-mod!-p
        poly!-vector
        safe!-flag
        split!-list
        work!-vector1
        work!-vector2);


safe!-flag:= carcheck 0; % For speed of array access - important here.
carcheck 0;              % and again for fasl purposes (in case carcheck
                         % is flagged EVAL).

symbolic procedure get!-factor!-count!-mod!-p
                              (n,poly!-mod!-p,p,x!-is!-factor);
% gets the factor count mod p from the nth image using the
% first half of Berlekamp's method;
  begin scalar old!-m,f!-count;
    old!-m:=set!-modulus p;
%    PRIN2 "prime = ";% prin2t current!-modulus;
%    PRIN2 "degree = ";% prin2t ldeg poly!-mod!-p;
%   trace!-time display!-time("Entered GET-FACTOR-COUNT after ",time());
%   wtime:=time();
    f!-count:=modular!-factor!-count();
%   trace!-time display!-time("Factor count obtained in ",time()-wtime);
    split!-list:=
      ((if x!-is!-factor then car f!-count#+1 else car f!-count) . n)
        . split!-list;
    putv(modular!-info,n,cdr f!-count);
    set!-modulus old!-m
  end;

symbolic procedure modular!-factor!-count();
  begin
    scalar poly!-vector,wvec1,wvec2,x!-to!-p,
      n,w,lin!-f!-count,null!-space!-basis;
    known!-factors:=nil;
    dpoly:=ldeg poly!-mod!-p;
    wvec1:=mkvect (2#*dpoly);
    wvec2:=mkvect (2#*dpoly);
    x!-to!-p:=mkvect dpoly;
    poly!-vector:=mkvect dpoly;
    for i:=0:dpoly do putv(poly!-vector,i,0);
    poly!-to!-vector poly!-mod!-p;
    w:=count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p);
    lin!-f!-count:=car w;
    if dpoly#<4 then return
       (if dpoly=0 then lin!-f!-count
        else lin!-f!-count#+1) .
        list(lin!-f!-count . cadr w,
             dpoly . poly!-vector,
             nil);
% When I use Berlekamp I certainly know that the polynomial
% involved has no linear factors;
%   wtime:=time();
    null!-space!-basis:=use!-berlekamp(x!-to!-p,caddr w,wvec1);
%   trace!-time display!-time("Berlekamp done in ",time()-wtime);
    n:=lin!-f!-count #+ length null!-space!-basis #+ 1;
            % there is always 1 more factor than the number of
            % null vectors we have picked up;
    return n . list(
     lin!-f!-count . cadr w,
     dpoly . poly!-vector,
     null!-space!-basis)
  end;

%**********************************************************************;
% Extraction of linear factors is done specially;

symbolic procedure count!-linear!-factors!-mod!-p(wvec1,wvec2,x!-to!-p);
% Compute gcd(x**p-x,u). It will be the product of all the
% linear factors of u mod p;
  begin scalar dx!-to!-p,lin!-f!-count,linear!-factors;
    for i:=0:dpoly do putv(wvec2,i,getv(poly!-vector,i));
    dx!-to!-p:=make!-x!-to!-p(current!-modulus,wvec1,x!-to!-p);
    for i:=0:dx!-to!-p do putv(wvec1,i,getv(x!-to!-p,i));
    if dx!-to!-p#<1 then <<
        if dx!-to!-p#<0 then putv(wvec1,0,0);
        putv(wvec1,1,modular!-minus 1);
        dx!-to!-p:=1 >>
    else <<
      putv(wvec1,1,modular!-difference(getv(wvec1,1),1));
      if dx!-to!-p=1 and getv(wvec1,1)=0 then
         if getv(wvec1,0)=0 then dx!-to!-p:=-1
         else dx!-to!-p:=0 >>;
    if dx!-to!-p#<0 then
      lin!-f!-count:=copy!-vector(wvec2,dpoly,wvec1)
    else lin!-f!-count:=gcd!-in!-vector(wvec1,dx!-to!-p,
      wvec2,dpoly);
    linear!-factors:=mkvect lin!-f!-count;
    for i:=0:lin!-f!-count do
      putv(linear!-factors,i,getv(wvec1,i));
    dpoly:=quotfail!-in!-vector(poly!-vector,dpoly,
        linear!-factors,lin!-f!-count);
    return list(lin!-f!-count,linear!-factors,dx!-to!-p)
  end;

symbolic procedure make!-x!-to!-p(p,wvec1,x!-to!-p);
  begin scalar dx!-to!-p,dw1;
    if p#>;
    dx!-to!-p:=make!-x!-to!-p(p/2,wvec1,x!-to!-p);
    dw1:=times!-in!-vector(x!-to!-p,dx!-to!-p,x!-to!-p,dx!-to!-p,wvec1);
    dw1:=remainder!-in!-vector(wvec1,dw1,poly!-vector,dpoly);
    if not(iremainder(p,2)=0) then <<
       for i:=dw1 step -1 until 0 do putv(wvec1,i#+1,getv(wvec1,i));
       putv(wvec1,0,0);
       dw1:=remainder!-in!-vector(wvec1,dw1#+1,poly!-vector,dpoly)>>;
    for i:=0:dw1 do putv(x!-to!-p,i,getv(wvec1,i));
    return dw1
  end;

symbolic procedure find!-linear!-factors!-mod!-p(p,n);
% P is a vector representing a polynomial of degree N which has
% only linear factors. Find all the factors and return a list of
% them;
  begin
    scalar root,var,w,vec1;
    if n#<1 then return nil;
    vec1:=mkvect 1;
    putv(vec1,1,1);
    root:=0;
    while (n#>1) and not (root #> current!-modulus) do <<
        w:=evaluate!-in!-vector(p,n,root);
        if w=0 then << %a factor has been found!!;
          if var=nil then
             var:=mksp(m!-image!-variable,1) . 1;
          w:=!*f2mod
            adjoin!-term(car var,cdr var,!*n2f modular!-minus root);
          known!-factors:=w . known!-factors;
          putv(vec1,0,modular!-minus root);
          n:=quotfail!-in!-vector(p,n,vec1,1) >>;
        root:=root#+1 >>;
    known!-factors:=
        vector!-to!-poly(p,n,m!-image!-variable) . known!-factors
  end;


%**********************************************************************;
% Berlekamp's algorithm part 1: find null space basis giving factor
% count;


symbolic procedure use!-berlekamp(x!-to!-p,dx!-to!-p,wvec1);
% Set up a basis for the set of remaining (nonlinear) factors
% using Berlekamp's algorithm;
  begin
    scalar berl!-m,berl!-m!-size,w,dcurrent,current!-power;
    berl!-m!-size:=dpoly#-1;
    berl!-m:=mkvect berl!-m!-size;
    for i:=0:berl!-m!-size do <<
      w:=mkvect berl!-m!-size;
      for j:=0:berl!-m!-size do putv(w,j,0); %initialize to zero;
      putv(berl!-m,i,w) >>;
% Note that column zero of the matrix (as used in the
% standard version of Berlekamp's algorithm) is not in fact
% needed and is not used here;
% I want to set up a matrix that has entries
%  x**p, x**(2*p), ... , x**((n-1)*p)
% as its columns,
% where n is the degree of poly-mod-p
% and all the entries are reduced mod poly-mod-p;
% Since I computed x**p I have taken out some linear factors,
% so reduce it further;
    dx!-to!-p:=remainder!-in!-vector(x!-to!-p,dx!-to!-p,
      poly!-vector,dpoly);
    dcurrent:=0;
    current!-power:=mkvect berl!-m!-size;
    putv(current!-power,0,1);
    for i:=1:berl!-m!-size do <<
       if current!-modulus#>dpoly then
         dcurrent:=times!-in!-vector(
            current!-power,dcurrent,
            x!-to!-p,dx!-to!-p,
            wvec1)
       else << % Multiply by shifting;
         for i:=0:current!-modulus#-1 do
           putv(wvec1,i,0);
         for i:=0:dcurrent do
           putv(wvec1,current!-modulus#+i,
             getv(current!-power,i));
         dcurrent:=dcurrent#+current!-modulus >>;
       dcurrent:=remainder!-in!-vector(
         wvec1,dcurrent,
         poly!-vector,dpoly);
       for j:=0:dcurrent do
          putv(getv(berl!-m,j),i,putv(current!-power,j,
            getv(wvec1,j)));
% also I need to subtract 1 from the diagonal of the matrix;
       putv(getv(berl!-m,i),i,
         modular!-difference(getv(getv(berl!-m,i),i),1)) >>;
%   wtime:=time();
%   print!-m("Q matrix",berl!-m,berl!-m!-size);
    w := find!-null!-space(berl!-m,berl!-m!-size);
%   trace!-time display!-time("Null space found in ",time()-wtime);
    return w
  end;


symbolic procedure find!-null!-space(berl!-m,berl!-m!-size);
% Diagonalize the matrix to find its rank and hence the number of
% factors the input polynomial had;
  begin scalar null!-space!-basis;
% find a basis for the null-space of the matrix;
    for i:=1:berl!-m!-size do
      null!-space!-basis:=
        clear!-column(i,null!-space!-basis,berl!-m,berl!-m!-size);
%    print!-m("Null vectored",berl!-m,berl!-m!-size);
    return
      tidy!-up!-null!-vectors(null!-space!-basis,berl!-m,berl!-m!-size)
  end;

symbolic procedure print!-m(m,berl!-m,berl!-m!-size);
 << prin2t m;
    for i:=0:berl!-m!-size do <<
      for j:=0:berl!-m!-size do <<
        prin2 getv(getv(berl!-m,i),j);
        ttab((4#*j)#+4) >>;
      terpri() >> >>;



symbolic procedure clear!-column(i,
                    null!-space!-basis,berl!-m,berl!-m!-size);
% Process column I of the matrix so that (if possible) it
% just has a '1' in row I and zeros elsewhere;
  begin
    scalar ii,w;
% I want to bring a non-zero pivot to the position (i,i)
% and then add multiples of row i to all other rows to make
% all but the i'th element of column i zero. First look for
% a suitable pivot;
    ii:=0;
search!-for!-pivot:
    if getv(getv(berl!-m,ii),i)=0 or
       ((ii#berl!-m!-size then
              return (i . null!-space!-basis)
          else go to search!-for!-pivot;
% Here ii references a row containing a suitable pivot element for
% column i. Permute rows in the matrix so as to bring the pivot onto
% the diagonal;
    w:=getv(berl!-m,ii);
    putv(berl!-m,ii,getv(berl!-m,i));
    putv(berl!-m,i,w);
            % swop rows ii and i ;
    w:=modular!-minus modular!-reciprocal getv(getv(berl!-m,i),i);
% w = -1/pivot, and is used in zeroing out the rest of column i;
    for row:=0:berl!-m!-size do
      if row neq i then begin
         scalar r; %process one row;
         r:=getv(getv(berl!-m,row),i);
         if not(r=0) then <<
           r:=modular!-times(r,w);
   %that is now the multiple of row i that must be added to row ii;
           for col:=i:berl!-m!-size do
             putv(getv(berl!-m,row),col,
               modular!-plus(getv(getv(berl!-m,row),col),
               modular!-times(r,getv(getv(berl!-m,i),col)))) >>
         end;
    for col:=i:berl!-m!-size do
        putv(getv(berl!-m,i),col,
           modular!-times(getv(getv(berl!-m,i),col),w));
    return null!-space!-basis
  end;


symbolic procedure tidy!-up!-null!-vectors(null!-space!-basis,
                    berl!-m,berl!-m!-size);
  begin
    scalar row!-to!-use;
    row!-to!-use:=berl!-m!-size#+1;
    null!-space!-basis:=
      for each null!-vector in null!-space!-basis collect
        build!-null!-vector(null!-vector,
            getv(berl!-m,row!-to!-use:=row!-to!-use#-1),berl!-m);
    berl!-m:=nil; % Release the store for full matrix;
%    prin2 "Null vectors: ";
%    print null!-space!-basis;
    return null!-space!-basis
  end;

symbolic procedure build!-null!-vector(n,vec1,berl!-m);
% At the end of the elimination process (the CLEAR-COLUMN loop)
% certain columns, indicated by the entries in NULL-SPACE-BASIS
% will be null vectors, save for the fact that they need a '1'
% inserted on the diagonal of the matrix. This procedure copies
% these null-vectors into some of the vectors that represented
% rows of the Berlekamp matrix;
  begin
%   putv(vec1,0,0); % Not used later!!;
    for i:=1:n#-1 do
      putv(vec1,i,getv(getv(berl!-m,i),n));
    putv(vec1,n,1);
%   for i:=n#+1:berl!-m!-size do
%     putv(vec1,i,0);
    return vec1 . n
  end;



%**********************************************************************;
% Berlekamp's algorithm part 2: retrieving the factors mod p;


symbolic procedure get!-factors!-mod!-p(n,p);
% given the modular info (for the nth image) generated by the
% previous half of Berlekamp's method we can reconstruct the
% actual factors mod p;
  begin scalar nth!-modular!-info,old!-m;
    nth!-modular!-info:=getv(modular!-info,n);
    old!-m:=set!-modulus p;
%   wtime:=time();
    putv(modular!-info,n,
      convert!-null!-vectors!-to!-factors nth!-modular!-info);
%   trace!-time display!-time("Factors constructed in ",time()-wtime);
    set!-modulus old!-m
  end;

symbolic procedure convert!-null!-vectors!-to!-factors m!-info;
% Using the null space found, complete the job
% of finding modular factors by taking gcd's of the
% modular input polynomial and variants on the
% null space generators;
  begin
    scalar number!-needed,factors,
      work!-vector1,dwork1,work!-vector2,dwork2;
    known!-factors:=nil;
%   wtime:=time();
    find!-linear!-factors!-mod!-p(cdar m!-info,caar m!-info);
%   trace!-time display!-time("Linear factors found in ",time()-wtime);
    dpoly:=caadr m!-info;
    poly!-vector:=cdadr m!-info;
    null!-space!-basis:=caddr m!-info;
    if dpoly=0 then return known!-factors; % All factors were linear;
    if null null!-space!-basis then
      return known!-factors:=
          vector!-to!-poly(poly!-vector,dpoly,m!-image!-variable) .
            known!-factors;
    number!-needed:=length null!-space!-basis;
% count showing how many more factors I need to find;
    work!-vector1:=mkvect dpoly;
    work!-vector2:=mkvect dpoly;
    factors:=list (poly!-vector . dpoly);
try!-next!-null:
    if null!-space!-basis=nil then
      errorf "RAN OUT OF NULL VECTORS TOO EARLY";
%   wtime:=time();
    factors:=try!-all!-constants(factors,
        caar null!-space!-basis,cdar null!-space!-basis);
%   trace!-time display!-time("All constants tried in ",time()-wtime);
    if number!-needed=0 then
       return known!-factors:=append!-new!-factors(factors,
            known!-factors);
    null!-space!-basis:=cdr null!-space!-basis;
    go to try!-next!-null
  end;


symbolic procedure try!-all!-constants(list!-of!-polys,v,dv);
% use gcd's of v, v+1, v+2, ... to try to split up the
% polynomials in the given list;
  begin
    scalar a,b,aa,s;
% aa is a list of factors that can not be improved using this v,
% b is a list that might be;
    aa:=nil; b:=list!-of!-polys;
    s:=0;
try!-next!-constant:
    putv(v,0,s); % Fix constant term of V to be S;
%    wtime:=time();
    a:=split!-further(b,v,dv);
%    trace!-time display!-time("Polys split further in ",time()-wtime);
    b:=cdr a; a:=car a;
    aa:=nconc(a,aa);
% Keep aa up to date as a list of polynomials that this poly
% v can not help further with;
    if b=nil then return aa; % no more progress possible here;
    if number!-needed=0 then return nconc(b,aa);
      % no more progress needed;
    s:=s#+1;
    if s#(p-1).
% This folds it onto the symmetric range (-p/2)->(p/2);
    IF NULL A THEN NIL
    ELSE IF DOMAINP A THEN
      IF A>MODULUS!/2 THEN !*n2f(A - CURRENT!-MODULUS)
      ELSE A
    ELSE ADJOIN!-TERM(LPOW A,
                      GENERAL!-MAKE!-MODULAR!-SYMMETRIC LC A,
                      GENERAL!-MAKE!-MODULAR!-SYMMETRIC RED A);

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/facstr.red0000644000175000017500000001567211526203062023753 0ustar  giovannigiovannimodule facstr;   % Reconstruction of factors.

% Author: P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Arthur C. Norman, Anthony C. Hearn.

fluid '(!*trfac
        alphavec
        bad!-case
        best!-known!-factors
        best!-set!-pointer
        current!-modulus
        degree!-bounds
        factor!-level
        factor!-trace!-list
        fhatvec
        full!-gcd
        hensel!-growth!-size
        image!-factors
        irreducible
        m!-image!-variable
        multivariate!-factors
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        predictions
        prime!-base
        reconstructing!-gcd
        target!-factor!-count
        valid!-image!-sets);

symbolic procedure reconstruct!-multivariate!-factors vset!-mod!-p;
   % Hensel construction for multivariate case.
   % Full univariate split has already been prepared (if factoring),
   % but we only need the modular factors and the true leading coeffts.
  (lambda factor!-level; begin
    scalar s,om,u0,alphavec,predictions,
      best!-factors!-mod!-p,fhatvec,w1,fvec!-mod!-p,d,degree!-bounds,
      lc!-vec;
    alphavec:=mkvect number!-of!-factors;
    best!-factors!-mod!-p:=mkvect number!-of!-factors;
    lc!-vec := mkvect number!-of!-factors;
        % This will preserve the LCs of the factors while we are working
        % mod p since they may contain numbers that are bigger than the
        % modulus.
    if not(
      (d:=max!-degree(multivariate!-input!-poly,0)) < prime!-base) then
      fvec!-mod!-p:=choose!-larger!-prime d;
    om:=set!-modulus hensel!-growth!-size;
    if null fvec!-mod!-p then <<
      fvec!-mod!-p:=mkvect number!-of!-factors;
      for i:=1:number!-of!-factors do
        putv(fvec!-mod!-p,i,reduce!-mod!-p getv(image!-factors,i))>>;
    for i:=1:number!-of!-factors do <<
      putv(alphavec,i,cdr get!-alpha getv(fvec!-mod!-p,i));
      putv(best!-factors!-mod!-p,i,
        reduce!-mod!-p getv(best!-known!-factors,i));
      putv(lc!-vec,i,lc getv(best!-known!-factors,i))>>;
         % Set up the Alphas, input factors mod p and remember to save
         % the LCs for use after finding the multivariate factors mod p.
    if not reconstructing!-gcd then <<
      s:=getv(valid!-image!-sets,best!-set!-pointer);
      vset!-mod!-p:=for each v in get!-image!-set s collect
        (car v . modular!-number cdr v)>>;
%    princ "kord* =";% print kord!*;
%    princ "order of variable substitution=";% print vset!-mod!-p;
    u0:=reduce!-mod!-p multivariate!-input!-poly;
    s := 1;
    for i := 1:number!-of!-factors do
       s := multf(s,getv(best!-known!-factors,i));
    set!-degree!-bounds(vset!-mod!-p,multivariate!-input!-poly,s);
%   wtime:=time();
    factor!-trace <<
      printstr
         "We use the Hensel Construction to grow univariate modular";
      printstr
         "factors into multivariate modular factors, which will in";
      printstr "turn be used in the later Hensel construction.  The";
      printstr "starting modular factors are:";
      printvec(" f(",number!-of!-factors,")=",best!-factors!-mod!-p);
      prin2!* "The modulus is "; printstr current!-modulus >>;
    find!-multivariate!-factors!-mod!-p(u0,
      best!-factors!-mod!-p,
      vset!-mod!-p);
    if bad!-case then <<
%     trace!-time <<
%       display!-time(" Multivariate modular factors failed in ",
%         time()-wtime);
%       wtime:=time()>>;
      target!-factor!-count:=number!-of!-factors - 1;
      if target!-factor!-count=1 then irreducible:=t;
      set!-modulus om;
      return bad!-case>>;
%   trace!-time <<
%     display!-time(" Multivariate modular factors found in ",
%       time()-wtime);
%     wtime:=time()>>;
    fhatvec:=make!-multivariate!-hatvec!-mod!-p(best!-factors!-mod!-p,
      number!-of!-factors);
    for i:=1:number!-of!-factors do
      putv(fvec!-mod!-p,i,getv(best!-factors!-mod!-p,i));
    make!-vec!-modular!-symmetric(best!-factors!-mod!-p,
      number!-of!-factors);
    for i:=1:number!-of!-factors do <<
%      w1:=getv(coefft!-vectors,i);
%      putv(best!-known!-factors,i,
%        merge!-terms(getv(best!-factors!-mod!-p,i),w1));
      putv(best!-known!-factors,i,
        force!-lc(getv(best!-factors!-mod!-p,i),getv(lc!-vec,i)));
         % Now we put back the LCs before growing the multivariate
         % factors to be correct over the integers giving the final
         % result.
      >>;
%   wtime:=time();
    w1:=hensel!-mod!-p(
      multivariate!-input!-poly,
      fvec!-mod!-p,
      best!-known!-factors,
      get!.coefft!.bound(multivariate!-input!-poly,
        total!-degree!-in!-powers(multivariate!-input!-poly,nil)),
      vset!-mod!-p,
      hensel!-growth!-size);
    if car w1='overshot then <<
%     trace!-time <<
%       display!-time(" Full factors failed in ",time()-wtime);
%       wtime:=time() >>;
      target!-factor!-count:=number!-of!-factors - 1;
      if target!-factor!-count=1 then irreducible:=t;
      set!-modulus om;
      return bad!-case:=t >>;
    if not(car w1='ok) then errorf w1;
%   trace!-time <<
%     display!-time(" Full factors found in ",time()-wtime);
%     wtime:=time() >>;
    if reconstructing!-gcd then <<
      full!-gcd:=if non!-monic then car primitive!.parts(
          list getv(cdr w1,1),m!-image!-variable,nil)
        else getv(cdr w1,1);
      set!-modulus om;
      return full!-gcd >>;
    for i:=1:getv(cdr w1,0) do
      multivariate!-factors:=getv(cdr w1,i) . multivariate!-factors;
    if non!-monic then multivariate!-factors:=
      primitive!.parts(multivariate!-factors,m!-image!-variable,nil);
    factor!-trace <<
      printstr "The full multivariate factors are:";
      for each x in multivariate!-factors do printsf x >>;
    set!-modulus om;
  end) (factor!-level*100);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/facprim.red0000644000175000017500000007513011526203062024105 0ustar  giovannigiovannimodule facprim;   % Factorize a primitive multivariate polynomial.

% Author: P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Arthur C. Norman, Anthony C. Hearn.

fluid '(!*force!-zero!-set
        !*overshoot
        !*overview
        !*trfac
        alphalist
        alphavec
        bad!-case
        best!-factor!-count
        best!-known!-factors
        best!-modulus
        best!-set!-pointer
        chosen!-prime
        current!-factor!-product
        deltam
        f!-numvec
        factor!-level
        factor!-trace!-list
        factored!-lc
        factorvec
        facvec
        fhatvec
        forbidden!-primes
        forbidden!-sets
        full!-gcd
        hensel!-growth!-size
        image!-content
        image!-factors
        image!-lc
        image!-mod!-p
        image!-poly
        image!-set
        image!-set!-modulus
        input!-leading!-coefficient
        input!-polynomial
        inverted
        inverted!-sign
        irreducible
        known!-factors
        kord!*
        m!-image!-variable
        modfvec
        modular!-info
        multivariate!-factors
        multivariate!-input!-poly
        no!-of!-best!-sets
        no!-of!-primes!-to!-try
        no!-of!-random!-sets
        non!-monic
        null!-space!-basis
        number!-of!-factors
        one!-complete!-deg!-analysis!-done
        othervars
        poly!-mod!-p
        polynomial!-to!-factor
        previous!-degree!-map
        prime!-base
        reconstructing!-gcd
        reduction!-count
        save!-zset
        split!-list
        target!-factor!-count
        true!-leading!-coeffts
        usable!-set!-found
        valid!-image!-sets
        vars!-to!-kill
        zero!-set!-tried
        zerovarset
        zset);

global '(largest!-small!-modulus);


%***********************************************************************
%
%    Primitive multivariate polynomial factorization more or less as
%    described by Paul Wang in:  Math. Comp. vol.32 no.144 oct 1978 pp.
%    1215-1231 'An Improved Multivariate Polynomial Factoring Algorithm'
%
%***********************************************************************

%-----------------------------------------------------------------------
%   This code works by using a local database of fluid variables
%   whose meaning is (hopefully) obvious.
%   they are used as follows:
%
%   global name:            set in:               comments:
%
% m!-factored!-leading!    create!.images        only set if non-numeric
%  -coefft
% m!-factored!-images      factorize!.images     vector
% m!-input!-polynomial     factorize!-primitive!
%                           -polynomial
% m!-best!-image!-pointer  choose!.best!.image
% m!-image!-factors        choose!.best!.image   vector
% m!-true!-leading!        choose!.best!.image   vector
%  -coeffts
% m!-prime                 choose!.best!.image
% irreducible              factorize!.images     predicate
% inverted                 create!.images        predicate
% m!-inverted!-sign        create!-images        +1 or -1
% non!-monic               determine!-leading!   predicate
%                           -coeffts
%                          (also reconstruct!-over!
%                           -integers)
% m!-number!-of!-factors   choose!.best!.image
% m!-image!-variable       square!.free!.factorize
%                          or factorize!-form
% m!-image!-sets           create!.images        vector
% this last contains the images of m!-input!-polynomial and the
% numbers associated with the factors of lc m!-input!-polynomial (to be
% used later) the latter existing only when the lc m!-input!-polynomial
% is non-integral. ie.:
%    m!-image!-sets=< ... , (( d . u ), a, d) , ... >   ( a vector)
% where: a = an image set (=association list);
%        d = cont(m!-input!-polynomial image wrt a);
%        u = prim.part.(same) which is non-trivial square-free
%            by choice of image set.;
%        d = vector of numbers associated with factors in lc
%            m!-input!-polynomial (these depend on a as well);
% the number of entries in m!-image!-sets is defined by the fluid
% variable, no.of.random.sets.


%***********************************************************************
% Multivariate factorization part 1. entry point for this code:
% (** NB ** the polynomial is assumed to be non-trivial, primitive and
% square free.)
%***********************************************************************

symbolic procedure factorize!-primitive!-polynomial u;
% U is primitive square free and at least linear in
% m!-image!-variable. M!-image!-variable is the variable preserved in
% the univariate images. This function determines a random set of
% integers and a prime to create a univariate modular image of u,
% factorize it and determine the leading coeffts of the factors in the
% full factorization of u. Finally the modular image factors are grown
% up to the full multivariates ones using the hensel construction.
% Result is simple list of irreducible factors.
  if not(m!-image!-variable eq mvar u) then errach "factorize variable"
   else if degree!-in!-variable(u,m!-image!-variable) = 1 then list u
   else if degree!-in!-variable(u,m!-image!-variable) = 2
    then factorize!-quadratic u
   else if fac!-univariatep u then univariate!-factorize u
   else begin scalar
    valid!-image!-sets,factored!-lc,image!-factors,prime!-base,
    one!-complete!-deg!-analysis!-done,zset,zerovarset,othervars,
    multivariate!-input!-poly,best!-set!-pointer,reduction!-count,
    true!-leading!-coeffts,number!-of!-factors,
    inverted!-sign,irreducible,inverted,vars!-to!-kill,
    forbidden!-sets,zero!-set!-tried,non!-monic,
    no!-of!-best!-sets,no!-of!-random!-sets,bad!-case,
    target!-factor!-count,modular!-info,multivariate!-factors,
    hensel!-growth!-size,alphalist,
    previous!-degree!-map,image!-set!-modulus,
    best!-known!-factors,reconstructing!-gcd,full!-gcd;
%   base!-timer:=time();
%   trace!-time display!-time(
%     " Entered multivariate primitive polynomial code after ",
%     base!-timer - base!-time);
    % Note that this code works by using a local database of fluid
    % variables that are updated by the subroutines directly called
    % here.  This allows for the relatively complicated interaction
    % between flow of data and control that occurs in the factorization
    % algorithm.
    factor!-trace <<
      printstr "From now on we shall refer to this polynomial as U.";
      printstr
         "We now create an image of U by picking suitable values ";
      printstr "for all but one of the variables in U.";
      prin2!* "The variable preserved in the image is ";
      prinvar m!-image!-variable; terpri!*(nil) >>;
    initialize!-fluids u;
            % set up the fluids to start things off.
%   w!-time:=time();
tryagain:
    get!-some!-random!-sets();
    choose!-the!-best!-set();
%     trace!-time <<
%       display!-time("Modular factoring and best set chosen in ",
%         time()-w!-time);
%       w!-time:=time() >>;
      if irreducible then return list u
      else if bad!-case then <<
        if !*overshoot then prin2t "Bad image sets - loop";
        bad!-case:=nil; goto tryagain >>;
    reconstruct!-image!-factors!-over!-integers();
%     trace!-time <<
%       display!-time("Image factors reconstructed in ",time()-w!-time);
%       w!-time:=time() >>;
      if irreducible then return list u
      else if bad!-case then <<
        if !*overshoot then prin2t "Bad image factors - loop";
        bad!-case:=nil; goto tryagain >>;
    determine!.leading!.coeffts();
%     trace!-time <<
%       display!-time("Leading coefficients distributed in ",
%         time()-w!-time);
%       w!-time:=time() >>;
      if irreducible then
        return list u
      else if bad!-case then <<
        if !*overshoot then prin2t "Bad split shown by LC distribution";
        bad!-case:=nil; goto tryagain >>;
    if determine!-more!-coeffts()='done then <<
%     trace!-time <<
%       display!-time("All the coefficients distributed in ",
%         time()-w!-time);
%       w!-time:=time() >>;
      return check!-inverted multivariate!-factors >>;
%   trace!-time <<
%     display!-time("More coefficients distributed in ",
%       time()-w!-time);
%     w!-time:=time() >>;
    reconstruct!-multivariate!-factors(nil);
      if bad!-case and not irreducible then <<
        if !*overshoot then prin2t "Multivariate overshoot - restart";
         bad!-case:=nil; goto tryagain >>;
%     trace!-time
%       display!-time("Multivariate factors reconstructed in ",
%         time()-w!-time);
      if irreducible then return list u;
    return check!-inverted multivariate!-factors
   end;

symbolic procedure check!-inverted multi!-faclist;
  begin scalar inv!.sign,l;
    if inverted then <<
      inv!.sign:=1;
      multi!-faclist:=
        for each x in multi!-faclist collect <<
        l:=invert!.poly(x,m!-image!-variable);
        inv!.sign:=(car l) * inv!.sign;
        cdr l >>;
      if not(inv!.sign=inverted!-sign) then
        errorf list("INVERSION HAS LOST A SIGN",inv!.sign) >>;
      return multivariate!-factors:=multi!-faclist end;

symbolic procedure getcof(p, v, n);
% Get coeff of v^n in p.
% I bet this exists somewhere under a different name....
  if domainp p then if n=0 then p else nil
  else if mvar p = v then
    if ldeg p=n then lc p
    else getcof(red p, v, n)
  else addf(multf((lpow p .* 1) .+ nil, getcof(lc p, v, n)),
            getcof(red p, v, n));

symbolic procedure factorize!-quadratic u;
% U is a primitive square-free quadratic. It factors if and only if
% its discriminant is a perfect square.
  begin scalar a, b, c, discr, f1, f2, x;
% I am unreasonably cautious here - I THINK that the image variable
% should be the main var here, but in case things have got themselves
% reordered & to make myself bomb proof against future changes I will
% not assume same.
    a := getcof(u, m!-image!-variable, 2);
    b := getcof(u, m!-image!-variable, 1);
    c := getcof(u, m!-image!-variable, 0);
    if dmode!* = '!:mod!: and current!-modulus = 2 then % problems
       if b=1 and c=1 then return list u; % Irreducible.
    discr := addf(multf(b, b), multf(a, multf(-4, c)));
    discr := sqrtf2 discr;
    if discr=-1 then return list u; % Irreducible.
    x := addf(multf(a, multf(2, !*k2f m!-image!-variable)), b);
    f1 := addf(x, discr);
    f2 := addf(x, negf discr);
    f1 := quotf(f1,
               cdr contents!-with!-respect!-to(f1, m!-image!-variable));
    f2 := quotf(f2,
               cdr contents!-with!-respect!-to(f2, m!-image!-variable));
    return list(f1, f2)
  end;

symbolic procedure sqrtd2 d;
% Square root of domain element or -1 if it does not have an exact one.
% Possibly needs upgrades to deal with non-integer domains, e.g. in
% modular arithmetic just half of all values have square roots (= are
% quadratic residues), but finding the roots is (I think) HARD.  In
% floating point it could be taken that all positive values have square
% roots.  Anyway somebody can adjust this as necessary and I think that
% SQRTF2 will then behave properly...
  if d=nil then nil
  else if not fixp d or d<0 then -1
  else begin
    scalar q, r, rold;
    q := pmam!-sqrt d;        % Works even if D is really huge.
    r := q*q-d;
    repeat <<
      rold := abs r;
      q := q - (r+q)/(2*q);   % / truncates, so this rounds to nearest
      r := q*q-d >> until abs r >= rold;
    if r=0 then return q
    else return -1
  end;

symbolic procedure pmam!-sqrt n;
   % Find the square root of n and return integer part + 1.  N is fixed
   % pt on input.  As it may be very large, i.e. > largest allowed
   % floating pt number, it is scaled appropriately.
   begin scalar s,ten!*!*6,ten!*!*12,ten!*!*14;
      s:=0;
      ten!*!*6:=10**6;
      ten!*!*12:=ten!*!*6**2;
      ten!*!*14:=100*ten!*!*12;
      while n>ten!*!*14 do << s:=iadd1 s; n:=1+n/ten!*!*12 >>;
      return (fix sqrt float n + 1)*10**(6*s)
   end;

symbolic procedure sqrtf2 p;
% Return square root of the polynomial P if there is an exact one,
% else returns -1 to indicate failure.
  if domainp p then sqrtd2 p
   else begin
    scalar v, d, qlc, q, r, w;
    if not evenp (d := ldeg p) or
       (qlc := sqrtf2 lc p) = -1 then return -1;
    d := d/2;
    v := mvar p;
    q := (mksp(v, d) .* qlc) .+ nil;      % First approx to sqrt(P)
    r := multf(2, q);
    p := red p;                           % Residue
    while not domainp p and
          mvar p = v and
          ldeg p >= d and
          (w := quotf(lt p .+ nil, r)) neq nil do
        <<  p := addf(p, multf(negf w, addf(multf(2, q), w)));
            q := addf(q, w) >>;
    if null p then return q else return -1
  end;

symbolic procedure initialize!-fluids u;
% Set up the fluids to be used in factoring primitive poly.
  begin scalar w,w1;
    if !*force!-zero!-set then <<
      no!-of!-random!-sets:=1;
      no!-of!-best!-sets:=1 >>
    else <<
      no!-of!-random!-sets:=9;
      % we generate this many and calculate their factor counts.
      no!-of!-best!-sets:=5;
            % we find the modular factors of this many.
      >>;
    image!-set!-modulus:=5;
    vars!-to!-kill:=variables!-to!-kill lc u;
    multivariate!-input!-poly:=u;
    no!-of!-primes!-to!-try := 5;
    target!-factor!-count:=degree!-in!-variable(u,m!-image!-variable);
    if not domainp lc multivariate!-input!-poly then
      if domainp (w:=
        trailing!.coefft(multivariate!-input!-poly,
                         m!-image!-variable)) then
    << inverted:=t;
        % note that we are 'inverting' the poly m!-input!-polynomial.
      w1:=invert!.poly(multivariate!-input!-poly,m!-image!-variable);
      multivariate!-input!-poly:=cdr w1;
      inverted!-sign:=car w1;
            % to ease the lc problem, m!-input!-polynomial <- poly
            % produced by taking numerator of (m!-input!-polynomial
            % with 1/m!-image!-variable substituted for
            % m!-image!-variable).
            % m!-inverted!-sign is -1 if we have inverted the sign of
            % the resulting poly to keep it +ve, else +1.
      factor!-trace <<
        prin2!* "The trailing coefficient of U wrt ";
        prinvar m!-image!-variable; prin2!* "(="; prin2!* w;
        printstr ") is purely numeric so we 'invert' U to give: ";
        prin2!* "  U <- "; printsf multivariate!-input!-poly;
        printstr "This simplifies any problems with the leading ";
        printstr "coefficient of U." >>
    >>
    else <<
%     trace!-time prin2t "Factoring the leading coefficient:";
%     wtime:=time();
      factored!-lc:=
        factorize!-form!-recursion lc multivariate!-input!-poly;
%     trace!-time display!-time("Leading coefficient factored in ",
%       time()-wtime);
            % factorize the lc of m!-input!-polynomial completely.
      factor!-trace <<
        printstr
           "The leading coefficient of U is non-trivial so we must ";
        printstr "factor it before we can decide how it is distributed";
        printstr "over the leading coefficients of the factors of U.";
        printstr "So the factors of this leading coefficient are:";
        fac!-printfactors factored!-lc >>
    >>;
   make!-zerovarset vars!-to!-kill;
            % Sets ZEROVARSET and OTHERVARS.
   if null zerovarset then zero!-set!-tried:=t
   else <<
    zset:=make!-zeroset!-list length zerovarset;
    save!-zset:=zset >>
  end;

symbolic procedure variables!-to!-kill lc!-u;
% Picks out all the variables in u except var. Also checks to see if
% any of these divide lc u: if they do they are dotted with t otherwise
% dotted with nil. result is list of these dotted pairs.
  for each w in cdr kord!* collect
    if (domainp lc!-u) or didntgo quotf(lc!-u,!*k2f w) then
       (w . nil) else (w . t);


%***********************************************************************
% Multivariate factorization part 2. Creating image sets and picking
%  the best one.

fluid '(usable!-set!-found);

symbolic procedure get!-some!-random!-sets();
% here we create a number of random sets to make the input
% poly univariate by killing all but 1 of the variables. at
% the same time we pick a random prime to reduce this image
% poly mod p.
  begin scalar image!-set,chosen!-prime,image!-lc,image!-mod!-p,
        image!-content,image!-poly,f!-numvec,forbidden!-primes,i,j,
        usable!-set!-found;
    valid!-image!-sets:=mkvect no!-of!-random!-sets;
    i:=0;
    while i < no!-of!-random!-sets do <<
%     wtime:=time();
      generate!-an!-image!-set!-with!-prime(
        if i>;
%     trace!-time
%       display!-time("  More sets factored mod p in ",time()-wtime);
      split!-list:=reversip w;
%     wtime:=time();
      check!-degree!-sets(no!-of!-random!-sets - no!-of!-best!-sets,t);
            % best!-set!-pointer hopefully points at the best image.
%     trace!-time
%       display!-time("  More degree sets analysed in ",time()-wtime)
    >>;
    one!-complete!-deg!-analysis!-done:=t;
    factor!-trace <<
      w:=getv(valid!-image!-sets,best!-set!-pointer);
      prin2!* "The chosen image set is:  ";
      for each x in get!-image!-set w do <<
        prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* "; " >>;
      terpri!*(nil);
      prin2!* "and chosen prime is "; printstr get!-chosen!-prime w;
      printstr "Image polynomial (made primitive) = ";
      printsf get!-image!-poly w;
      if not(get!-image!-content w=1) then <<
        prin2!* " with (extracted) content of ";
        printsf get!-image!-content w >>;
      prin2!* "The image polynomial mod "; prin2!* get!-chosen!-prime w;
      printstr ", made monic, is:";
      printsf get!-image!-mod!-p w;
      printstr "and factors of the primitive image mod this prime are:";
      for each x in getv(modular!-info,best!-set!-pointer)
         do printsf x;
      if (fnum:=get!-f!-numvec w) and not !*overview then <<
        printstr "The numeric images of each (square-free) factor of";
        printstr "the leading coefficient of the polynomial are as";
        prin2!* "follows (in order):";
        prin2!* "  ";
        for i:=1:length cdr factored!-lc do <<
          prin2!* getv(fnum,i); prin2!* "; " >>;
        terpri!*(nil) >>
      >>
  end;


%***********************************************************************
% Multivariate factorization part 3. Reconstruction of the
% chosen image over the integers.


symbolic procedure reconstruct!-image!-factors!-over!-integers();
% The Hensel construction from modular case to univariate
% over the integers.
  begin scalar best!-modulus,best!-factor!-count,input!-polynomial,
    input!-leading!-coefficient,best!-known!-factors,s,w,i,
    x!-is!-factor,x!-factor;
    s:=getv(valid!-image!-sets,best!-set!-pointer);
    best!-known!-factors:=getv(modular!-info,best!-set!-pointer);
    best!-modulus:=get!-chosen!-prime s;
    best!-factor!-count:=length best!-known!-factors;
    input!-polynomial:=get!-image!-poly s;
    if ldeg input!-polynomial=1 then
      if not(x!-is!-factor:=not numberp get!-image!-content s) then
        errorf list("Trying to factor a linear image poly: ",
          input!-polynomial)
      else begin scalar brecip,ww,om,x!-mod!-p;
        number!-of!-factors:=2;
        prime!-base:=best!-modulus;
        x!-factor:=!*k2f m!-image!-variable;
        putv(valid!-image!-sets,best!-set!-pointer,
          put!-image!-poly!-and!-content(s,lc get!-image!-content s,
            multf(x!-factor,get!-image!-poly s)));
        om:=set!-modulus best!-modulus;
        brecip:=modular!-reciprocal
          red (ww:=reduce!-mod!-p input!-polynomial);
        x!-mod!-p:=!*f2mod x!-factor;
        alphalist:=list(
          (x!-mod!-p . brecip),
          (ww . modular!-minus modular!-times(brecip,lc ww)));
        do!-quadratic!-growth(list(x!-factor,input!-polynomial),
          list(x!-mod!-p,ww),best!-modulus);
        w:=list input!-polynomial; % All factors apart from X-FACTOR.
        set!-modulus om
      end
    else <<
      input!-leading!-coefficient:=lc input!-polynomial;
      factor!-trace <<
        printstr
           "Next we use the Hensel Construction to grow these modular";
      printstr "factors into factors over the integers." >>;
      w:=reconstruct!.over!.integers();
      if irreducible then return t;
      if (x!-is!-factor:=not numberp get!-image!-content s) then <<
        number!-of!-factors:=length w + 1;
        x!-factor:=!*k2f m!-image!-variable;
        putv(valid!-image!-sets,best!-set!-pointer,
          put!-image!-poly!-and!-content(s,lc get!-image!-content s,
            multf(x!-factor,get!-image!-poly s)));
        fix!-alphas() >>
      else number!-of!-factors:=length w;
      if number!-of!-factors=1 then return irreducible:=t >>;
    if number!-of!-factors>target!-factor!-count then
      return bad!-case:=list get!-image!-set s;
    image!-factors:=mkvect number!-of!-factors;
    i:=1;
    factor!-trace
      printstr "The full factors of the image polynomial are:";
    for each im!-factor in w do <<
      putv(image!-factors,i,im!-factor);
      factor!-trace printsf im!-factor;
      i:=iadd1 i >>;
   if x!-is!-factor then <<
     putv(image!-factors,i,x!-factor);
     factor!-trace <<
       printsf x!-factor;
       printsf get!-image!-content
         getv(valid!-image!-sets,best!-set!-pointer) >> >>
  end;

symbolic procedure do!-quadratic!-growth(flist,modflist,p);
  begin scalar fhatvec,alphavec,factorvec,modfvec,facvec,
    current!-factor!-product,i,deltam,m;
    fhatvec:=mkvect number!-of!-factors;
    alphavec:=mkvect number!-of!-factors;
    factorvec:=mkvect number!-of!-factors;
    modfvec:=mkvect number!-of!-factors;
    facvec:=mkvect number!-of!-factors;
    current!-factor!-product:=1;
    i:=0;
    for each ff in flist do <<
      putv(factorvec,i:=iadd1 i,ff);
      current!-factor!-product:=multf(ff,current!-factor!-product) >>;
    i:=0;
    for each modff in modflist do <<
      putv(modfvec,i:=iadd1 i,modff);
      putv(alphavec,i,cdr get!-alpha modff) >>;
    deltam:=p;
    m:=deltam*deltam;
    while m>;
    hensel!-growth!-size:=deltam;
    alphalist:=nil;
    for j:=1:number!-of!-factors do
      alphalist:=(reduce!-mod!-p getv(factorvec,j) . getv(alphavec,j))
        . alphalist
  end;

symbolic procedure fix!-alphas();
% We extracted a factor x (where x is the image variable)
% before any alphas were calculated, we now need to put
% back this factor and its coresponding alpha which incidently
% will change the other alphas.
  begin scalar om,f1,x!-factor,a,arecip,b;
    om:=set!-modulus hensel!-growth!-size;
    f1:=reduce!-mod!-p input!-polynomial;
    x!-factor:=!*f2mod !*k2f m!-image!-variable;
    arecip:=modular!-reciprocal
      (a:=evaluate!-mod!-p(f1,m!-image!-variable,0));
    b:=times!-mod!-p(modular!-minus arecip,
      quotfail!-mod!-p(difference!-mod!-p(f1,a),x!-factor));
    alphalist:=(x!-factor . arecip) .
      (for each aa in alphalist collect
        ((car aa) . remainder!-mod!-p(times!-mod!-p(b,cdr aa),car aa)));
    set!-modulus om
  end;


%***********************************************************************
% Multivariate factorization part 4. Determining the leading
%  coefficients.

symbolic procedure determine!.leading!.coeffts();
% This function determines the leading coeffts to all but a constant
% factor which is spread over all of the factors before reconstruction.
  begin scalar delta,c,s;
    s:=getv(valid!-image!-sets,best!-set!-pointer);
    delta:=get!-image!-content s;
            % cont(the m!-input!-polynomial image).
    if not domainp lc multivariate!-input!-poly then
    << true!-leading!-coeffts:=
      distribute!.lc(number!-of!-factors,image!-factors,s,
        factored!-lc);
       if bad!-case then <<
         bad!-case:=list get!-image!-set s;
         target!-factor!-count:=number!-of!-factors - 1;
         if target!-factor!-count=1 then irreducible:=t;
         return bad!-case >>;
       delta:=car true!-leading!-coeffts;
       true!-leading!-coeffts:=cdr true!-leading!-coeffts;
            % if the lc problem exists then use Wang's algorithm to
            % distribute it over the factors.
       if not !*overview then factor!-trace <<
         printstr "We now determine the leading coefficients of the ";
         printstr "factors of U by using the factors of the leading";
         printstr "coefficient of U and their (square-free) images";
         printstr "referred to earlier:";
         for i:=1:number!-of!-factors do <<
           prinsf getv(image!-factors,i);
           prin2!* " with l.c.: ";
           printsf getv(true!-leading!-coeffts,i)
         >> >>;
       if not onep delta then factor!-trace <<
         if !*overview then
        << printstr
              "In determining the leading coefficients of the factors";
           prin2!* "of U, " >>;
         prin2!* "We have an integer factor, ";
         prin2!* delta;
         printstr ", left over that we ";
         printstr "cannot yet distribute correctly." >>
      >>
    else <<
      true!-leading!-coeffts:=mkvect number!-of!-factors;
      for i:=1:number!-of!-factors do
        putv(true!-leading!-coeffts,i,lc getv(image!-factors,i));
      if not onep delta then
        factor!-trace <<
          prin2!* "U has a leading coefficient = ";
          prin2!* delta;
          printstr " which we cannot ";
          printstr "yet distribute correctly over the image factors." >>
      >>;
    if not onep delta then
    << for i:=1:number!-of!-factors do
       << putv(image!-factors,i,multf(delta,getv(image!-factors,i)));
          putv(true!-leading!-coeffts,i,
            multf(delta,getv(true!-leading!-coeffts,i)))
       >>;
       divide!-all!-alphas delta;
       c:=expt(delta,isub1 number!-of!-factors);
       multivariate!-input!-poly:=multf(c,multivariate!-input!-poly);
       non!-monic:=t;
       factor!-trace <<
         printstr "(a) We multiply each of the image factors by the ";
         printstr "absolute value of this constant and multiply";
         prin2!* "U by ";
         if not(number!-of!-factors=2) then
           << prin2!* delta; prin2!* "**";
             prin2!* isub1 number!-of!-factors >>
         else prin2!* delta;
         printstr " giving new image factors";
         printstr "as follows: ";
         for i:=1:number!-of!-factors do
           printsf getv(image!-factors,i)
       >>
    >>;
            % If necessary, fiddle the remaining integer part of the
            % lc of m!-input!-polynomial.
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/degsets.red0000644000175000017500000001274311526203062024123 0ustar  giovannigiovannimodule degsets;   % Degree set processing.

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trallfac
        !*trfac
        bad!-case
        best!-set!-pointer
        dpoly
        factor!-level
        factor!-trace!-list
        factored!-lc
        irreducible
        modular!-info
        one!-complete!-deg!-analysis!-done
        previous!-degree!-map
        split!-list
        valid!-image!-sets);

symbolic procedure check!-degree!-sets(n,multivariate!-case);
% MODULAR!-INFO (vector of size N) contains the modular factors now.
  begin scalar degree!-sets,w,x!-is!-factor,degs;
    w:=split!-list;
    for i:=1:n do <<
      if multivariate!-case then
        x!-is!-factor:=not numberp get!-image!-content
          getv(valid!-image!-sets,cdar w);
      degs:=for each v in getv(modular!-info,cdar w) collect ldeg v;
      degree!-sets:=
        (if x!-is!-factor then 1 . degs else degs)
              . degree!-sets;
      w:=cdr w >>;
    check!-degree!-sets!-1 degree!-sets;
    best!-set!-pointer:=cdar split!-list;
    if multivariate!-case and factored!-lc then <<
      while null(w:=get!-f!-numvec
           getv(valid!-image!-sets,best!-set!-pointer))
       and (split!-list:=cdr split!-list) do
        best!-set!-pointer:=cdar split!-list;
      if null w then bad!-case:=t >>;
            % make sure the set is ok for distributing the
            % leading coefft where necessary;
  end;

symbolic procedure check!-degree!-sets!-1 l;
  % L is a list of degree sets. Try to discover if the entries
  % in it are consistent, or if they imply that some of the
  % modular splittings were 'false'.
  begin scalar i,degree!-map,degree!-map1,dpoly,
               plausible!-split!-found,target!-count;
    factor!-trace <<
       prin2t "Degree sets are:";
       for each s in l do <<
          prin2 "     ";
          for each n in s do <<
             prin2 " "; prin2 n >>;
          terpri() >> >>;
    dpoly:=sum!-list car l;
    target!-count:=length car l;
    for each s in cdr l do
        target!-count:=min(target!-count,length s);
    % This used to be IMIN, but since it was the only use, it was
    % eliminated.
    if null previous!-degree!-map then <<
      degree!-map:=mkvect dpoly;
    % To begin with all degrees of factors may be possible;
      for i:=0:dpoly do putv(degree!-map,i,t) >>
    else <<
      factor!-trace "Refine an existing degree map";
      degree!-map:=previous!-degree!-map >>;
    degree!-map1:=mkvect dpoly;
    for each s in l do <<
    % For each degree set S I will collect in DEGREE-MAP1 a
    % bitmap showing what degree factors would be consistent
    % with that set. By ANDing together all these maps
    % (into DEGREE-MAP) I find what degrees for factors are
    % consistent with the whole of the information I have.
      for i:=0:dpoly do putv(degree!-map1,i,nil);
      putv(degree!-map1,0,t);
      putv(degree!-map1,dpoly,t);
      for each d in s do for i:=dpoly#-d#-1 step -1 until 0 do
        if getv(degree!-map1,i) then
           putv(degree!-map1,i#+d,t);
      for i:=0:dpoly do
        putv(degree!-map,i,getv(degree!-map,i) and
             getv(degree!-map1,i)) >>;
    factor!-trace <<
        prin2t "Possible degrees for factors are: ";
        for i:=1:dpoly#-1 do
          if getv(degree!-map,i) then << prin2 i; prin2 " " >>;
        terpri() >>;
    i:=dpoly#-1;
    while i#>0 do if getv(degree!-map,i) then i:=-1
                 else i:=i#-1;
    if i=0 then <<
       factor!-trace
          prin2t "Degree analysis proves polynomial irreducible";
       return irreducible:=t >>;
    for each s in l do if length s=target!-count then begin
      % Sets with too many factors are not plausible anyway.
      i:=s;
      while i and getv(degree!-map,car i) do i:=cdr i;
      % If I drop through with I null it was because the set was
      % consistent, otherwise it represented a false split;
      if null i then plausible!-split!-found:=t end;
    previous!-degree!-map:=degree!-map;
    if plausible!-split!-found or one!-complete!-deg!-analysis!-done
      then return nil;
%    PRINTC "Going to try getting some more images";
    return bad!-case:=t
  end;

symbolic procedure sum!-list l;
   if null cdr l then car l else car l #+ sum!-list cdr l;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/mhensfns.red0000644000175000017500000003602111526203062024301 0ustar  giovannigiovannimodule mhensfns;

% Authors: A. C. Norman and P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trfac
        alphalist
        current!-modulus
        degree!-bounds
        delfvec
        factor!-level
        factor!-trace!-list
        forbidden!-primes
        hensel!-growth!-size
        image!-factors
        max!-unknowns
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        number!-of!-unknowns
        polyzero
%       pt
        prime!-base);


%**********************************************************************;
%    This section contains some of the functions used in
%    the multivariate hensel growth. (ie they are called from
%    section MULTIHEN or function RECONSTRUCT-MULTIVARIATE-FACTORS). ;



symbolic procedure set!-degree!-bounds(v, p1, p2);
  degree!-bounds:=for each var in v collect
    (car var . max(degree!-in!-variable(p1, car var),
           degree!-in!-variable(p2, car var)));

symbolic procedure get!-degree!-bound v;
  begin scalar w;
    w:=atsoc(v,degree!-bounds);
    if null w then errorf(list("Degree bound not found for ",
        v," in ",degree!-bounds));
    return cdr w
  end;

symbolic procedure choose!-larger!-prime n;
% our prime base in the multivariate hensel must be greater than n so
% this sets a new prime to be that (previous one was found to be no
% good). We also set up various fluids e.g. the Alphas;
% the primes we can choose are < 2**24 so if n is bigger
% we collapse;
  if n > 2**24-1 then
    errorf list("CANNOT CHOOSE PRIME > GIVEN NUMBER:",n)
  else begin scalar p,flist!-mod!-p,k,fvec!-mod!-p,forbidden!-primes;
trynewprime:
    if p then forbidden!-primes:=p . forbidden!-primes;
    p:=random!-prime();
            % this chooses a word-size prime (currently 24 bits);
    set!-modulus p;
    if not(p>n) or member(p,forbidden!-primes) or
      polyzerop reduce!-mod!-p lc multivariate!-input!-poly then
       goto trynewprime;
    for i:=1:number!-of!-factors do
      flist!-mod!-p:=(reduce!-mod!-p getv(image!-factors,i) .
                       flist!-mod!-p);
    alphalist:=alphas(number!-of!-factors,flist!-mod!-p,1);
    if alphalist='factors! not! coprime then goto trynewprime;
    hensel!-growth!-size:=p;
    prime!-base:=p;
    factor!-trace <<
      prin2!* "New prime chosen: ";
      printstr hensel!-growth!-size >>;
    k:=number!-of!-factors;
    fvec!-mod!-p:=mkvect k;
    for each w in flist!-mod!-p do <<
      putv(fvec!-mod!-p,k,w); k:=isub1 k >>;
    return fvec!-mod!-p
  end;

symbolic procedure binomial!-coefft!-mod!-p(n,r);
  if n>;
    return !*n2f n!-c!-r
  end;

symbolic procedure make!-multivariate!-hatvec!-mod!-p(bvec,n);
% makes a vector whose ith elt is product over j [ BVEC(j) ] / BVEC(i);
% NB. we must NOT actually do the division here as we are likely
% to be working mod p**n (some n > 1) and the division can involve
% a division by p.;
  begin scalar bhatvec,r;
    bhatvec:=mkvect n;
    for i:=1:n do <<
      r:=1;
      for j:=1:n do if not(j=i) then r:=times!-mod!-p(r,getv(bvec,j));
      putv(bhatvec,i,r) >>;
    return bhatvec
  end;

symbolic procedure max!-degree!-in!-var(fvec,v);
  begin scalar r,d;
    r:=0;
    for i:=1:number!-of!-factors do
      if r<(d:=degree!-in!-variable(getv(fvec,i),v)) then r:=d;
    return r
  end;

symbolic procedure make!-growth!-factor pt;
% pt is of form (v . n) where v is a variable. we make the s.f. v-n;
  if cdr pt=0 then !*f2mod !*k2f car pt
  else plus!-mod!-p(!*f2mod !*k2f car pt,modular!-minus cdr pt);

symbolic procedure terms!-done!-mod!-p(fvec,delfvec,delfactor);
% calculate the terms introduced by the corrections in DELFVEC;
  begin scalar flist,delflist;
    for i:=1:number!-of!-factors do <<
      flist:=getv(fvec,i) . flist;
      delflist:=getv(delfvec,i) . delflist >>;
    return terms!-done1!-mod!-p(number!-of!-factors,flist,delflist,
      number!-of!-factors,delfactor)
  end;

symbolic procedure terms!-done1!-mod!-p(n,flist,delflist,r,m);
  if n=1 then (car flist) . (car delflist)
  else begin scalar k,i,f1,f2,delf1,delf2;
    k:=n/2; i:=1;
    for each f in flist do
    << if i>k then f2:=(f . f2)
       else f1:=(f . f1);
       i:=i+1 >>;
    i:=1;
    for each delf in delflist do
    << if i>k then delf2:=(delf . delf2)
       else delf1:=(delf . delf1);
       i:=i+1 >>;
    f1:=terms!-done1!-mod!-p(k,f1,delf1,r,m);
    delf1:=cdr f1; f1:=car f1;
    f2:=terms!-done1!-mod!-p(n-k,f2,delf2,r,m);
    delf2:=cdr f2; f2:=car f2;
    delf1:=
      plus!-mod!-p(plus!-mod!-p(
        times!-mod!-p(f1,delf2),
        times!-mod!-p(f2,delf1)),
        times!-mod!-p(times!-mod!-p(delf1,m),delf2));
    if n=r then return delf1;
    return (times!-mod!-p(f1,f2) . delf1)
  end;

symbolic procedure primitive!.parts(flist,var,univariate!-inputs);
% finds the prim.part of each factor in flist wrt variable var;
% Note that FLIST may contain univariate or multivariate S.F.s
% (according to UNIVARIATE!-INPUTS) - in the former case we correct the
% ALPHALIST if necessary;
  begin scalar c,primf;
    if null var then
      errorf "Must take primitive parts wrt some non-null variable";
    if non!-monic then
      factor!-trace <<
        printstr "Because we multiplied the original primitive";
        printstr "polynomial by a multiple of its leading coefficient";
        printstr "(see (a) above), the factors we have now are not";
        printstr "necessarily primitive. However the required factors";
        printstr "are merely their primitive parts." >>;
    return for each fw in flist collect
    << if not depends!-on!-var(fw,var) then
            errorf list("WRONG VARIABLE",var,fw);
       c:=comfac fw;
       if car c then errorf(list(
         "FACTOR DIVISIBLE BY MAIN VARIABLE:",fw,car c));
       primf:=quotfail(fw,cdr c);
       if not(cdr c=1) and univariate!-inputs then
         multiply!-alphas(cdr c,fw,primf);
       primf >>
  end;


symbolic procedure make!-predicted!-forms(pfs,v);
% PFS is a vector of S.F.s which represents the sparsity of
% the associated polynomials wrt V. Here PFS is adjusted to a
% suitable form for handling this sparsity. ie. we record the
% degrees of V in a vector for each poly in PFS. Each
% monomial (in V) represents an unknown (its coefft) in the predicted
% form of the associated poly. We count the maximum no of unknowns for
% each poly and return the maximum of these;
  begin scalar l,n,pvec,j,w;
    max!-unknowns:=0;
    for i:=1:number!-of!-factors do <<
      w:=getv(pfs,i);  % get the ith poly;
      l:=sort(spreadvar(w,v,nil),function lessp);
            % Pick out the monomials in V from this poly and order
            % them in increasing degree;
      n:=iadd1 length l; % no of unknowns in predicted poly - we add
                         % one for the constant term;
      number!-of!-unknowns:=(n . i) . number!-of!-unknowns;
      if max!-unknowns>;
    number!-of!-unknowns:=sort(number!-of!-unknowns,function lesspcar);
    return max!-unknowns
  end;

symbolic procedure make!-correction!-vectors(bfs,n);
% set up space for the vector of vectors to hold the correction
% terms as we generate them by the function SOLVE-FOR-CORRECTIONS.
% Also put in the starting values;
  begin scalar cvs,cv;
    cvs:=mkvect number!-of!-factors;
    for i:=1:number!-of!-factors do <<
      cv:=mkvect n;
            % each CV will hold the corrections for the ith factor;
            % the no of corrections we put in here depends on the
            % maximum no of unknowns we have in the predicted
            % forms, giving a set of soluble linear systems (hopefully);
      putv(cv,1,getv(bfs,i));
            % put in the first 'corrections';
      putv(cvs,i,cv) >>;
    return cvs
  end;

symbolic procedure construct!-soln!-matrices(pfs,val);
% Here we construct the matrices - one for each linear system
% we will have to solve to see if our predicted forms of the
% answer are correct. Each matrix is a vector of row-vectors
% - the ijth elt is in jth slot of ith row-vector (ie zero slots
% are not used here);
  begin scalar soln!-matrix,resvec,n,pv;
    resvec:=mkvect number!-of!-factors;
    for i:=1:number!-of!-factors do <<
      pv:=getv(pfs,i);
      soln!-matrix:=mkvect(n:=iadd1 getv(pv,0));
      construct!-ith!-matrix(soln!-matrix,pv,n,val);
      putv(resvec,i,soln!-matrix) >>;
    return resvec
  end;

symbolic procedure construct!-ith!-matrix(sm,pv,n,val);
  begin scalar mv;
    mv:=mkvect n;  %  this will be the first row;
    putv(mv,1,1);  % the first column represents the constant term;
    for j:=2:n do putv(mv,j,modular!-expt(val,getv(pv,isub1 j)));
            % first row is straight substitution;
    putv(sm,1,mv);
            % now for the rest of the rows:   ;
    for j:=2:n do <<
      mv:=mkvect n;
      putv(mv,1,0);
      construct!-matrix!-row(mv,isub1 j,pv,n,val);
      putv(sm,j,mv) >>
  end;

symbolic procedure construct!-matrix!-row(mrow,j,pv,n,val);
  begin scalar d;
    for k:=2:n do <<
      d:=getv(pv,isub1 k);  % degree representing the monomial;
      if d> >>
  end;

symbolic procedure print!-linear!-systems(soln!-m,correction!-v,
                                              predicted!-f,v);
<<
  for i:=1:number!-of!-factors do
    print!-linear!-system(i,soln!-m,correction!-v,predicted!-f,v);
  terpri!*(nil) >>;

symbolic procedure print!-linear!-system(i,soln!-m,correction!-v,
                                              predicted!-f,v);
  begin scalar pv,sm,cv,mr,n,tt;
    terpri!*(t);
    prin2!* " i = "; printstr i;
    terpri!*(nil);
    sm:=getv(soln!-m,i);
    cv:=getv(correction!-v,i);
      pv:=getv(predicted!-f,i);
      n:=iadd1 getv(pv,0);
      for j:=1:n do << % for each row in matrix ... ;
        prin2!* "(  ";
        tt:=2;
        mr:=getv(sm,j);  % matrix row;
      for k:=1:n do << % for each elt in row ... ;
          prin2!* getv(mr,k);
          ttab!* (tt:=tt+10) >>;
        prin2!* ")  ( [";
        if j=1 then prin2!* 1
        else prinsf adjoin!-term(mksp(v,getv(pv,isub1 j)),1,polyzero);
      prin2!* "]";
      ttab!* (tt:=tt+10);
      prin2!* " )";
      if j=(n/2) then prin2!* "  =  (  " else prin2!* "     (  ";
      prinsf getv(cv,j);
      ttab!* (tt:=tt+30); printstr ")";
      if not(j=n) then <<
        tt:=2;
        prin2!* "(";
        ttab!* (tt:=tt+n*10);
        prin2!* ")  (";
        ttab!* (tt:=tt+10);
        prin2!* " )     (";
        ttab!* (tt:=tt+30);
        printstr ")" >> >>;
    terpri!*(t)
  end;

symbolic procedure try!-prediction(sm,cv,pv,n,i,poly,v,ff,ffhat);
  begin scalar w,ffi,fhati;
    sm:=getv(sm,i);
    cv:=getv(cv,i);
    pv:=getv(pv,i);
    if not(n=iadd1 getv(pv,0)) then
      errorf list("Predicted unknowns gone wrong? ",n,iadd1 getv(pv,0));
    if null getm2(sm,1,0) then <<
      w:=lu!-factorize!-mod!-p(sm,n);
      if w='singular then <<
        factor!-trace <<
          prin2!* "Prediction for ";
          prin2!* if null ff then 'f else 'a;
          prin2!* "("; prin2!* i;
          printstr ") failed due to singular matrix." >>;
        return (w . i) >> >>;
    back!-substitute(sm,cv,n);
    w:=
      if null ff then try!-factor(poly,cv,pv,n,v)
      else <<
        ffi := getv(ff,i);
        fhati := getv(ffhat,i); % The unfolding here is to get round
                                % a bug in the PSL compiler 12/9/82. It
                                % will be tidied back up as soon as
                                % possible;
        try!-alpha(poly,cv,pv,n,v,ffi,fhati) >>;
    if w='bad!-prediction then <<
      factor!-trace <<
        prin2!* "Prediction for ";
        prin2!* if null ff then 'f else 'a;
        prin2!* "("; prin2!* i;
        printstr ") was an inadequate guess." >>;
      return (w . i) >>;
    factor!-trace <<
      prin2!* "Prediction for ";
      prin2!* if null ff then 'f else 'a;
      prin2!* "("; prin2!* i; prin2!* ") worked: ";
      printsf car w >>;
    return (i . w)
  end;

symbolic procedure try!-factor(poly,testv,predictedf,n,v);
  begin scalar r,w;
    r:=getv(testv,1);
    for j:=2:n do <<
      w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1,
                              polyzero);
      r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>;
    w:=quotient!-mod!-p(poly,r);
    if didntgo w or
      not polyzerop difference!-mod!-p(poly,times!-mod!-p(w,r)) then
      return 'bad!-prediction
    else return list(r,w)
  end;

symbolic procedure try!-alpha(poly,testv,predictedf,n,v,fi,fhati);
  begin scalar r,w,wr;
    r:=getv(testv,1);
    for j:=2:n do <<
      w:=!*f2mod adjoin!-term(mksp(v,getv(predictedf,isub1 j)),1,
                              polyzero);
      r:=plus!-mod!-p(r,times!-mod!-p(w,getv(testv,j))) >>;
    if polyzerop
      (wr:=difference!-mod!-p(poly,times!-mod!-p(r,fhati))) then
      return list (r,wr);
    w:=quotient!-mod!-p(wr,fi);
    if didntgo w or
      not polyzerop difference!-mod!-p(wr,times!-mod!-p(w,fi)) then
      return 'bad!-prediction
    else return list(r,wr)
  end;



endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/factor.red0000644000175000017500000001213611526203062023737 0ustar  giovannigiovannimodule factor;  % Header for factorizer.

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(factor bigmodp degsets facprim facmod facuni % factrr
                  imageset pfactor vecpoly pfacmult),
                nil);

% Other packages needed.

load!-package 'ezgcd;

for each j in get('factor,'package)
    do put(j,'compiletime,'(setq !*fastfor t));

fluid '(!*ifactor !*overview !*trallfac !*trfac factor!-level
        factor!-trace!-list posn!*);

global '(spare!*);

switch ifactor,overview,trallfac,trfac;

comment This factorizer should be used with a system dependent file
containing a setting of the variable LARGEST!-SMALL!-MODULUS. If at all
possible the integer arithmetic operations used here should be mapped
onto corresponding ones available in the underlying Lisp implementation,
and the support for modular arithmetic (perhaps based on these integer
arithmetic operations) should be reviewed.  This file provides
placeholder definitions of functions that are used on some
implementations to support block compilation, car/cdr access checks and
the like.  The front-end files on the systems that can use these
features will disable the definitions given here by use of a 'LOSE flag;

deflist('((minus!-one -1)),'newnam);   % So that it EVALs properly.

symbolic smacro procedure carcheck u; nil;

% symbolic smacro procedure irecip u; 1/u;

% symbolic smacro procedure isdomain u; domainp u;

% symbolic smacro procedure readgctime; gctime();

% symbolic smacro procedure readtime; time()-gctime();

% symbolic smacro procedure ttab n; spaces(n-posn());


%   ***** The remainder of this module used to be in FLUIDS.

% Macro definitions for functions that create and access reduce-type
% datastructures.

% smacro procedure polyzerop u; null u;

smacro procedure didntgo q; null q;

% smacro procedure depends!-on!-var(a,v);
%   (lambda !#!#a; (not domainp !#!#a) and (mvar !#!#a=v)) a;

% smacro procedure l!-numeric!-c(a,vlist); lnc a;

% Macro definitions for use in Berlekamp's algorithm.

% Smacros used in linear equation package.

% smacro procedure getm2(a,i,j);
%    % Store by rows, to ease pivoting process.
%    getv(getv(a,i),j);

% smacro procedure putm2(a,i,j,v);
%    putv(getv(a,i),j,v);

smacro procedure !*f2mod u; u;

smacro procedure !*mod2f u; u;

%%%smacro procedure adjoin!-term (p,c,r);
%%%  (lambda !#c!#; % Lambda binding prevents repeated evaluation of C.
%%%    if null !#c!# then r else (p .* !#c!#) .+ r) c;

symbolic smacro procedure get!-f!-numvec s; cadr cddr cdddr s;

% !*overshoot:=nil; % Default not to show overshoot occurring.

% reconstructing!-gcd:=nil;  % This is primarily a factorizer!

symbolic procedure ttab!* n;
<(linelength nil - spare!*) then n:=0;
  if posn!* > n then terpri!*(nil);
  while not(posn!*=n) do prin2!* '!  >>;

smacro procedure printstr l; << prin2!* l; terpri!*(nil) >>;

smacro procedure printvar v; printstr v;

smacro procedure prinvar v; prin2!* v;

% smacro procedure display!-time(str,mt);
% Displays the string str followed by time mt (millisecs).
%  << prin2 str; prin2 mt; prin2t " millisecs." >>;

% trace control package.

% smacro procedure trace!-time action; if !*timings then action;

smacro procedure new!-level(n,c); (lambda factor!-level; c) n;

symbolic procedure set!-trace!-factor(n,file);
    factor!-trace!-list:=(n . (if file=nil then nil
                               else open(mkfil file,'output))) .
                                                factor!-trace!-list;

symbolic procedure clear!-trace!-factor n;
  begin
    scalar w;
    w := assoc(n,factor!-trace!-list);
    if w then <<
       if cdr w then close cdr w;
       factor!-trace!-list:=delasc(n,factor!-trace!-list) >>;
    return nil
  end;

symbolic procedure close!-trace!-files();
 << while factor!-trace!-list
       do clear!-trace!-factor(caar factor!-trace!-list);
    nil >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/coeffts.red0000644000175000017500000002443711526203062024121 0ustar  giovannigiovannimodule coeffts;

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trfac
        alphalist
        best!-known!-factor!-list
        best!-known!-factors
        coefft!-vectors
        deg!-of!-unknown
        difference!-for!-unknown
        divisor!-for!-unknown
        factor!-level
        factor!-trace!-list
        full!-gcd
        hensel!-growth!-size
        image!-factors
        m!-image!-variable
        multivariate!-factors
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        polyzero
        reconstructing!-gcd
        true!-leading!-coeffts
        unknown
        unknowns!-list);


%**********************************************************************;
%  Code for trying to determine more multivariate coefficients
%  by inspection before using multivariate hensel construction.


symbolic procedure determine!-more!-coeffts();
% ...
  begin scalar unknowns!-list,uv,r,w,best!-known!-factor!-list;
    best!-known!-factors:=mkvect number!-of!-factors;
    uv:=mkvect number!-of!-factors;
    for i:=number!-of!-factors step -1 until 1 do
      putv(uv,i,convert!-factor!-to!-termvector(
        getv(image!-factors,i),getv(true!-leading!-coeffts,i)));
    r:=red multivariate!-input!-poly;
            % we know all about the leading coeffts;
    if not depends!-on!-var(r,m!-image!-variable)
      or null(w:=try!-first!-coefft(
              ldeg r,lc r,unknowns!-list,uv)) then <<
      for i:=1:number!-of!-factors do
        putv(best!-known!-factors,i,force!-lc(
          getv(image!-factors,i),getv(true!-leading!-coeffts,i)));
      coefft!-vectors:=uv;
      return nil >>;
    factor!-trace <<
      printstr
         "By exploiting any sparsity wrt the main variable in the";
      printstr "factors, we can try guessing some of the multivariate";
      printstr "coefficients." >>;
    try!-other!-coeffts(r,unknowns!-list,uv);
    w:=convert!-and!-trial!-divide uv;
%   trace!-time
%     if full!-gcd then prin2t "Possible gcd found"
%     else prin2t "Have found some coefficients";
    return set!-up!-globals(uv,w)
  end;

symbolic procedure convert!-factor!-to!-termvector(u,tlc);
% ...
  begin scalar termlist,res,n,slist;
    termlist:=(ldeg u . tlc) . list!-terms!-in!-factor red u;
    res:=mkvect (n:=length termlist);
    for i:=1:n do <<
      slist:=(caar termlist . i) . slist;
      putv(res,i,car termlist);
      termlist:=cdr termlist >>;
    putv(res,0,(n . (n #- 1)));
    unknowns!-list:=(reversip slist) . unknowns!-list;
    return res
  end;

symbolic procedure try!-first!-coefft(n,c,slist,uv);
% ...
  begin scalar combns,unknown,w,l,d,v,m;
    combns:=get!-term(n,slist);
    if (combns='no) or not null cdr combns then return nil;
    l:=car combns;
    for i:=1:number!-of!-factors do <<
      w:=getv(getv(uv,i),car l);    % degree . coefft ;
      if null cdr w then <<
         if unknown then <>
          else <>>>
      else <<
        c:=quotf(c,cdr w);
        if didntgo c then i := number!-of!-factors+1>>;
      l:=cdr l >>;
    if didntgo c then return nil;
    putv(v:=getv(uv,car unknown),cdr unknown,(d . c));
    m:=getv(v,0);
    putv(v,0,(car m . (cdr m #- 1)));
    if cdr m = 1 and factors!-complete uv then return 'complete;
    return c
  end;

symbolic procedure solve!-next!-coefft(n,c,slist,uv);
% ...
  begin scalar combns,w,unknown,deg!-of!-unknown,divisor!-for!-unknown,
    difference!-for!-unknown,v;
    difference!-for!-unknown:=polyzero;
    divisor!-for!-unknown:=polyzero;
    combns:=get!-term(n,slist);
    if combns='no then return 'nogood;
    while combns do <<
      w:=split!-term!-list(car combns,uv);
      if w='nogood then combns := nil else combns:=cdr combns >>;
    if w='nogood then return w;
    if null unknown then return;
    w:=quotf(addf(c,negf difference!-for!-unknown),
             divisor!-for!-unknown);
    if didntgo w then return 'nogood;
    putv(v:=getv(uv,car unknown),cdr unknown,(deg!-of!-unknown . w));
    n:=getv(v,0);
    putv(v,0,(car n . (cdr n #- 1)));
    if cdr n = 1 and factors!-complete uv then return 'complete;
    return w
  end;

symbolic procedure split!-term!-list(term!-combn,uv);
% ...
  begin scalar a,v,w;
    a:=1;
    for i:=1:number!-of!-factors do <<
      w:=getv(getv(uv,i),car term!-combn);  % degree . coefft ;
      if null cdr w then
        if v or (unknown and not((i.car term!-combn)=unknown)) then
          <>
        else <<
          unknown:=(i . car term!-combn);
          deg!-of!-unknown:=car w;
          v:=unknown >>
      else a:=multf(a,cdr w);
      if not(v eq 'nogood) then term!-combn:=cdr term!-combn >>;
    if v='nogood then return v;
    if v then divisor!-for!-unknown:=addf(divisor!-for!-unknown,a)
    else difference!-for!-unknown:=addf(difference!-for!-unknown,a);
    return 'ok
  end;

symbolic procedure factors!-complete uv;
% ...
  begin scalar factor!-not!-done,r;
    r:=t;
    for i:=1:number!-of!-factors do
      if not(cdr getv(getv(uv,i),0)=0) then
        if factor!-not!-done then <>
        else factor!-not!-done:=t;
    return r
  end;

symbolic procedure convert!-and!-trial!-divide uv;
% ...
  begin scalar w,r,fdone!-product!-mod!-p,om;
    om:=set!-modulus hensel!-growth!-size;
    fdone!-product!-mod!-p:=1;
    for i:=1:number!-of!-factors do <<
      w:=getv(uv,i);
      w:= if (cdr getv(w,0))=0 then termvector2sf w
        else merge!-terms(getv(image!-factors,i),w);
      r:=quotf(multivariate!-input!-poly,w);
      if didntgo r then best!-known!-factor!-list:=
        ((i . w) . best!-known!-factor!-list)
      else if reconstructing!-gcd and i=1
       then <>
      else <<
        multivariate!-factors:=w . multivariate!-factors;
        fdone!-product!-mod!-p:=times!-mod!-p(
          reduce!-mod!-p getv(image!-factors,i),
          fdone!-product!-mod!-p);
        multivariate!-input!-poly:=r >> >>;
    if full!-gcd then return;
    if null best!-known!-factor!-list then multivariate!-factors:=
      primitive!.parts(multivariate!-factors,m!-image!-variable,nil)
    else if null cdr best!-known!-factor!-list then <<
      if reconstructing!-gcd then
        if not(caar best!-known!-factor!-list=1) then
          errorf("gcd is jiggered in determining other coeffts")
        else full!-gcd:=if non!-monic then car primitive!.parts(
          list multivariate!-input!-poly,
          m!-image!-variable,nil)
          else multivariate!-input!-poly
      else multivariate!-factors:=primitive!.parts(
        multivariate!-input!-poly . multivariate!-factors,
        m!-image!-variable,nil);
      best!-known!-factor!-list:=nil >>;
    factor!-trace <<
      if null best!-known!-factor!-list then
        printstr
           "We have completely determined all the factors this way"
      else if multivariate!-factors then <<
        prin2!* "We have completely determined the following factor";
        printstr if (length multivariate!-factors)=1 then ":" else "s:";
        for each ww in multivariate!-factors do printsf ww >> >>;
    set!-modulus om;
    return fdone!-product!-mod!-p
  end;

symbolic procedure set!-up!-globals(uv,f!-product);
  if null best!-known!-factor!-list or full!-gcd then 'done
  else begin scalar i,r,n,k,flist!-mod!-p,imf,om,savek;
    n:=length best!-known!-factor!-list;
    best!-known!-factors:=mkvect n;
    coefft!-vectors:=mkvect n;
    r:=mkvect n;
    k:=if reconstructing!-gcd then 1 else 0;
    om:=set!-modulus hensel!-growth!-size;
    for each w in best!-known!-factor!-list do <<
      i:=car w; w:=cdr w;
      if reconstructing!-gcd and i=1 then << savek:=k; k:=1 >>
      else k:=k #+ 1;
            % in case we are reconstructing gcd we had better know
            % which is the gcd and which the cofactor - so don't move
            % move the gcd from elt one;
      putv(r,k,imf:=getv(image!-factors,i));
      flist!-mod!-p:=(reduce!-mod!-p imf) . flist!-mod!-p;
      putv(best!-known!-factors,k,w);
      putv(coefft!-vectors,k,getv(uv,i));
      if reconstructing!-gcd and k=1 then k:=savek;
            % restore k if necessary;
      >>;
    if not(n=number!-of!-factors) then <<
      alphalist:=for each modf in flist!-mod!-p collect
        (modf . remainder!-mod!-p(times!-mod!-p(f!-product,
          cdr get!-alpha modf),modf));
      number!-of!-factors:=n >>;
    set!-modulus om;
    image!-factors:=r;
    return 'need! to! reconstruct
  end;

symbolic procedure get!-term(n,l);
% ...
  if n#<0 then 'no
  else if null cdr l then get!-term!-n(n,car l)
  else begin scalar w,res;
    for each fterm in car l do <<
      w:=get!-term(n#-car fterm,cdr l);
      if not(w='no) then res:=
        append(for each v in w collect (cdr fterm . v),res) >>;
    return if null res then 'no else res
  end;

symbolic procedure get!-term!-n(n,u);
  if null u or n #> caar u then 'no
  else if caar u = n then list(cdar u . nil)
  else get!-term!-n(n,cdr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/linmodp.red0000644000175000017500000000652211526203062024125 0ustar  giovannigiovannimodule linmodp;  % Routines for solving linear equations mod p.

% Authors: A. C. Norman and P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(prime!-base);

symbolic procedure lu!-factorize!-mod!-p(a,n);
   % A is a matrix of size N*N. Overwrite it with its LU factorization.
   begin scalar w;
    for i:=1:n do begin
     scalar ii,pivot;
     if w eq 'singular then return nil;
     ii:=i;
     while n>=ii and ((pivot:=getm2(a,ii,i))=0
        or iremainder(pivot,prime!-base)=0) do ii := ii+1;
     if ii>n then return(w := 'singular);
     if not(ii=i) then begin
         scalar temp;
         temp:=getv(a,i);
         putv(a,i,getv(a,ii));
         putv(a,ii,temp) end;
     putm2(a,i,0,ii); % Remember pivoting information;
     pivot:=modular!-reciprocal pivot;
     putm2(a,i,i,pivot);
     for j:=i+1:n do
       putm2(a,i,j,modular!-times(pivot,getm2(a,i,j)));
     for ii:=i+1:n do begin
        scalar multiple;
        multiple:=getm2(a,ii,i);
        for j:=i+1:n do
           putm2(a,ii,j,modular!-difference(getm2(a,ii,j),
             modular!-times(multiple,getm2(a,i,j)))) end end;
     return w
   end;

symbolic procedure back!-substitute(a,v,n);
   % A is an N*N matrix as produced by LU-FACTORIZE-MOD-P, and V is a
   % vector of length N. Overwrite V with solution to linear equations.
   begin
     for i:=1:n do
         begin scalar ii;
            ii:=getm2(a,i,0); % Pivot control;
            if ii neq i
              then begin scalar temp;
                      temp:=getv(v,i);
                      putv(v,i,getv(v,ii));
                      putv(v,ii,temp)
                   end
         end;
     for i:=1:n do begin
         putv(v,i,times!-mod!-p(!*n2f getm2(a,i,i),getv(v,i)));
         for ii:=i+1:n do
            putv(v,ii,difference!-mod!-p(getv(v,ii),
               times!-mod!-p(getv(v,i),!*n2f getm2(a,ii,i)))) end;
             % Now do the actual back substitution;
     for i:=n-1 step -1 until 1 do
       for j:=i+1:n do
         putv(v,i,difference!-mod!-p(getv(v,i),
           times!-mod!-p(!*n2f getm2(a,i,j),getv(v,j))));
     return v
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/alphas.red0000644000175000017500000000637111526203062023735 0ustar  giovannigiovannimodule alphas;

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(alphalist current!-modulus hensel!-growth!-size
        number!-of!-factors);


%********************************************************************;
%
% This section contains access and update functions for the alphas.


symbolic procedure get!-alpha poly;
% Gets the poly and its associated alpha from the current alphalist
% if poly is not on the alphalist then we force an error.
  begin scalar w;
    w:=assoc!-alpha(poly,alphalist);
    if null w then errorf list("Alpha not found for ",poly," in ",
        alphalist);
    return w
  end;

symbolic procedure divide!-all!-alphas n;
% Multiply the factors by n mod p and alter the alphas accordingly.
  begin scalar om,m,nn;
    om:=set!-modulus hensel!-growth!-size;
    nn:=modular!-number n;
    m:=modular!-expt(
          modular!-reciprocal nn,
          number!-of!-factors #- 1);
    alphalist:=for each a in alphalist collect
      (times!-mod!-p(nn,car a) . times!-mod!-p(m,cdr a));
    set!-modulus om
  end;

symbolic procedure multiply!-alphas(n,oldpoly,newpoly);
% Multiply all the alphas except the one associated with oldpoly
% by n mod p. also replace oldpoly by newpoly in the alphalist.
  begin scalar om,faca;
    om:=set!-modulus hensel!-growth!-size;
    n:=modular!-number n;
    oldpoly:=reduce!-mod!-p oldpoly;
    faca:=get!-alpha oldpoly;
    alphalist:=delete(faca,alphalist);
    alphalist:=for each a in alphalist collect
      car a . times!-mod!-p(cdr a,n);
    alphalist:=(reduce!-mod!-p newpoly . cdr faca) . alphalist;
    set!-modulus om
  end;

symbolic procedure multiply!-alphas!-recip(n,oldpoly,newpoly);
% Multiply all the alphas except the one associated with oldpoly
% by the reciprocal mod p of n. also replace oldpoly by newpoly.
  begin scalar om,w;
    om:=set!-modulus hensel!-growth!-size;
    n:=modular!-reciprocal modular!-number n;
    w:=multiply!-alphas(n,oldpoly,newpoly);
    set!-modulus om;
    return w
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/facmisc.red0000644000175000017500000003047511526203062024074 0ustar  giovannigiovannimodule facmisc;  % Miscellaneous routines used from several sections.

% Authors: A. C. Norman and P. M. A. Moore, 1979.

fluid '(current!-modulus
        image!-set!-modulus
        modulus!/2
        othervars
        polyzero
%       pt
        save!-zset
        zerovarset);

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(largest!-small!-modulus pseudo!-primes teeny!-primes);


% (1) Investigate variables in polynomial.

symbolic procedure multivariatep(a,v);
    if domainp a then nil
    else if not(mvar a eq v) then t
    else if multivariatep(lc a,v) then t
    else multivariatep(red a,v);

symbolic procedure variables!-in!-form a;
% collect variables that occur in the form a;
    variables!.in!.form(a,nil);

symbolic procedure get!.coefft!.bound(poly,degbd);
% Calculates a coefft bound for the factors of poly.  This simple
% bound is that suggested by Paul Wang and Linda p. Rothschild in
% Math. Comp. Vol 29 July 75, p.940, due to Gel'fond.
% Note that for tiny polynomials the bound is forced up to be
% larger than any prime that will get used in the mod-p splitting;
  max(get!-height poly * fixexpfloat sumof degbd,110);

symbolic procedure sumof degbd;
  if null degbd then 0 else cdar degbd + sumof cdr degbd;

symbolic procedure fixexpfloat n;
   % Compute exponential function e**n for potentially large N,
   % rounding result up somewhat. Note that exp(10)=22027 or so,
   % so if the basic floating point exponential function is accurate
   % to 6 or so digits we are protected here against roundoff.
   % This could be replaced by ceiling exp n, but is written this
   % way to avoid floating point overflow.
%  if n>10 then (fixexpfloat(n2)*fixexpfloat(n-n2) where n2 = n/2)
%   else 1+fix exp n;
   if n>10 then 22027*fixexpfloat(n-10) else ceiling exp float n;

% (2) Minor variations on ordinary algebraic operations.

symbolic procedure quotfail(a,b);
% version of quotf that fails if the division does;
  if polyzerop a then polyzero
  else begin scalar w;
    w:=quotf(a,b);
    if didntgo w then errorf list("UNEXPECTED DIVISION FAILURE",a,b)
    else return w
  end;

symbolic procedure quotfail1(a,b,msg);
% version of quotf that fails if the division does, and gives
% custom message;
  if polyzerop a then polyzero
  else begin scalar w;
    w:=quotf(a,b);
    if didntgo w then errorf msg
    else return w
  end;


% (3) pseudo-random prime numbers - small and large.

symbolic procedure set!-teeny!-primes();
  begin scalar i;
    i:=-1;
    teeny!-primes:=mkvect 9;
    putv(teeny!-primes,i:=iadd1 i,3);
    putv(teeny!-primes,i:=iadd1 i,5);
    putv(teeny!-primes,i:=iadd1 i,7);
    putv(teeny!-primes,i:=iadd1 i,11);
    putv(teeny!-primes,i:=iadd1 i,13);
    putv(teeny!-primes,i:=iadd1 i,17);
    putv(teeny!-primes,i:=iadd1 i,19);
    putv(teeny!-primes,i:=iadd1 i,23);
    putv(teeny!-primes,i:=iadd1 i,29);
    putv(teeny!-primes,i:=iadd1 i,31)
  end;

set!-teeny!-primes();

symbolic procedure random!-small!-prime();
  begin
    scalar p;
    repeat <>
       until primep p;
    return p
  end;

symbolic procedure small!-random!-number();
% Returns a smallish number from a distribution strongly favouring
% smaller numbers;
  begin scalar w;
% The next lines generate a random value in the range 0 to 1000000.
    w := remainder(next!-random!-number(), 1000);
    w := remainder(next!-random!-number(),1000) + 1000*w;
    if w < 0 then w := w + 1000000;
    w:=1.0+1.5*float w/1000000.0;  % 1.0 to 2.5
    w:=times(w,w);                 % In range 1.0 to 6.25
    return fix exp w;              % Should be in range 3 to 518,
                                   % < 21 about half the time;
  end;

% symbolic procedure fac!-exp u;
%    % Simple exp routine.  Assumes that Lisp has a routine for
%    % exponentiation of floats by integers.  Relative accuracy 4.e-5.
%    begin scalar x; integer n;
%      n := fix u;
%      if (x := (u - float n)) > 0.5 then <>;
%      u := ee***n;
%      return u*((x+6.0)*x+12.0)/((x-6.0)*x+12.0)
%    end;

symbolic procedure random!-teeny!-prime l;
% get one of the first 10 primes at random providing it is
% not in the list L or that L says we have tried them all;
  if l='all or (length l = 10) then nil
  else begin scalar p;
    repeat
       p:=getv(teeny!-primes,remainder(next!-random!-number(),10))
    until not member(p,l);
    return p
  end;

% symbolic procedure primep n;
% Test if prime. Only for use on small integers.
%    n=2 or
%    (n>2 and not evenp n and primetest(n,3));

% symbolic procedure primetest(n,trial);
%    if igreaterp(itimes(trial,trial),n) then t
%    else if iremainder(n,trial)=0 then nil
%    else primetest(n,iplus2(trial,2));


% PSEUDO-PRIMES will be a list of all composite numbers which are
% less than 2^24 and where 2926^(n-1) = 3315^(n-1) = 1 mod n.

pseudo!-primes:=mkvect 87;

begin
  scalar i,l;
  i:=0;
  l:= '(2047     4033     33227    38503    56033
        137149   145351   146611   188191   226801
        252601   294409   328021   399001   410041
        488881   512461   556421   597871   636641
        665281   722261   742813   873181   950797
        1047619  1084201  1141141  1152271  1193221
        1373653  1398101  1461241  1584133  1615681
        1627921  1755001  1857241  1909001  2327041
        2508013  3057601  3363121  3542533  3581761
        3828001  4069297  4209661  4335241  4510507
        4588033  4650049  4877641  5049001  5148001
        5176153  5444489  5481451  5892511  5968873
        6186403  6189121  6733693  6868261  6955541
        7398151  7519441  8086231  8134561  8140513
        8333333  8725753  8927101  9439201  9494101
        10024561 10185841 10267951 10606681 11972017
        13390081 14063281 14469841 14676481 14913991
        15247621 15829633 16253551);
    while l do <<
       putv(pseudo!-primes,i,car l);
       i:=i+1;
       l:=cdr l >>
  end;

symbolic procedure random!-prime();
  begin
% I want a random prime that is smaller than largest-small-modulus.
% I do this by generating random odd integers in the range lsm/2 to
% lsm and filtering them for primality. Prime testing is done using
% a Fermat test followed by lookup in an exception table that was
% laboriously precomputed. This process should be distinctly faster
% than trial-division testing of candidate primes, but the exception
% table is tedious to compute, so I limit lsm to 2**24 here. This is
% both the value that Cambridge Lisp can support directly, an indication
% of how large an exception table I computed using 48 hours of CPU time
% and large enough that primes selected this way will hardly ever
% be unlucky just through being too small.
    scalar p,w,oldmod,lsm, lsm2;
    lsm := largest!-small!-modulus;
    if lsm > 2**24 then lsm := 2**24;
    lsm2 := lsm/2;
    % W will become 1 when P is prime;
    oldmod := current!-modulus;
    while not (w=1) do <<
      p := remainder(next!-random!-number(), lsm);
      if p < lsm2 then p := p + lsm2;
      if evenp p then p := p + 1;
      set!-modulus p;
      w:=modular!-expt(modular!-number 2926,isub1 p);
      if w=1
         and (modular!-expt(modular!-number 3315,isub1 p) neq 1
                 or pseudo!-prime!-p p)
        then w:=0>>;
    set!-modulus oldmod;
    return p
  end;

symbolic procedure pseudo!-prime!-p n;
  begin
    scalar low,mid,high,v;
    low:=0;
    high:=87; % Size of vector of pseudo-primes;
    while not (high=low) do << % Binary search in table;
      mid:=iquotient(iplus2(iadd1 high,low),2);
         % Mid point of (low,high);
      v:=getv(pseudo!-primes,mid);
      if igreaterp(v,n) then high:=isub1 mid else low:=mid >>;
    return (getv(pseudo!-primes,low)=n)
  end;


% (4) useful routines for vectors.

symbolic procedure form!-sum!-and!-product!-mod!-p(avec,fvec,r);
% sum over i (avec(i) * fvec(i));
  begin scalar s;
    s:=polyzero;
    for i:=1:r do
      s:=plus!-mod!-p(times!-mod!-p(getv(avec,i),getv(fvec,i)),
        s);
    return s
  end;

symbolic procedure form!-sum!-and!-product!-mod!-m(avec,fvec,r);
% Same as above but AVEC holds alphas mod p and want to work
% mod m (m > p) so minor difference to change AVEC to AVEC mod m;
  begin scalar s;
    s:=polyzero;
    for i:=1:r do
      s:=plus!-mod!-p(times!-mod!-p(
        !*f2mod !*mod2f getv(avec,i),getv(fvec,i)),s);
    return s
  end;

symbolic procedure reduce!-vec!-by!-one!-var!-mod!-p(v,pt,n);
% Substitute for the given variable in all elements creating a
% new vector for the result. (All arithmetic is mod p).
  begin scalar newv;
    newv:=mkvect n;
    for i:=1:n do
      putv(newv,i,evaluate!-mod!-p(getv(v,i),car pt,cdr pt));
    return newv
  end;

symbolic procedure make!-bivariate!-vec!-mod!-p(v,imset,var,n);
  begin scalar newv;
    newv:=mkvect n;
    for i:=1:n do
      putv(newv,i,make!-bivariate!-mod!-p(getv(v,i),imset,var));
    return newv
  end;

symbolic procedure times!-vector!-mod!-p(v,n);
% product of all the elements in the vector mod p;
  begin scalar w;
    w:=1;
    for i:=1:n do w:=times!-mod!-p(getv(v,i),w);
    return w
  end;

symbolic procedure make!-vec!-modular!-symmetric(v,n);
% fold each elt of V which is current a modular poly in the
% range 0->(p-1) onto the symmetric range (-p/2)->(p/2);
  for i:=1:n do putv(v,i,make!-modular!-symmetric getv(v,i));

% (5) Combinatorial fns used in finding values for the variables.


symbolic procedure make!-zerovarset vlist;
% vlist is a list of pairs (v . tag) where v is a variable name and
% tag is a boolean tag. The procedure splits the list into two
% according to the tags: Zerovarset is set to a list of variables
% whose tag is false and othervars contains the rest;
  for each w in vlist do
    if cdr w then othervars:= car w . othervars
    else zerovarset:= car w . zerovarset;

symbolic procedure make!-zeroset!-list n;
% Produces a list of lists each of length n with all combinations of
% ones and zeroes;
  begin scalar w;
    for k:=0:n do w:=append(w,kcombns(k,n));
    return w
  end;

symbolic procedure kcombns(k,m);
% produces a list of all combinations of ones and zeroes with k ones
% in each;
  if k=0 or k=m then begin scalar w;
    if k=m then k:=1;
    for i:=1:m do w:=k.w;
    return list w
    end
  else if k=1 or k=isub1 m then <<
    if k=isub1 m then k:=0;
    list!-with!-one!-a(k,1 #- k,m) >>
  else append(
    for each x in kcombns(isub1 k,isub1 m) collect (1 . x),
    for each x in kcombns(k,isub1 m) collect (0 . x) );

symbolic procedure list!-with!-one!-a(a,b,m);
% Creates list of all lists with one a and m-1 b's in;
  begin scalar w,x,r;
    for i:=1:isub1 m do w:=b . w;
    r:=list(a . w);
    for i:=1:isub1 m do <<
      x:=(car w) . x; w:=cdr w;
      r:=append(x,(a . w)) . r >>;
    return r
  end;

symbolic procedure make!-next!-zset l;
  begin scalar k,w;
    image!-set!-modulus:=iadd1 image!-set!-modulus;
    set!-modulus image!-set!-modulus;
    w:=for each ll in cdr l collect
      for each n in ll collect
        if n=0 then n
        else <<
          k:=modular!-number next!-random!-number();
          while (zerop k) or (onep k) do
            k:=modular!-number next!-random!-number();
          if k>modulus!/2 then k:=k-current!-modulus;
           k >>;
    save!-zset:=nil;
    return w
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/multihen.red0000644000175000017500000006062211526203062024311 0ustar  giovannigiovannimodule multihen;   %  Hensel construction for the multivariate case.
                   %  (This version is highly recursive.)

% Authors: A. C. Norman and P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*overshoot
        !*trfac
        alphavec
        bad!-case
        factor!-level
        factor!-trace!-list
        fhatvec
        hensel!-growth!-size
        max!-unknowns
        number!-of!-factors
        number!-of!-unknowns
        predictions);


symbolic procedure find!-multivariate!-factors!-mod!-p(poly,
    best!-factors,variable!-set);
    % All arithmetic is done mod p, best-factors is overwritten.
    if null variable!-set then best!-factors
    else (lambda factor!-level; begin
    scalar growth!-factor,b0s,res,v,
           bhat0s,w,degbd,first!-time,redpoly,
           predicted!-forms,number!-of!-unknowns,solve!-count,
           correction!-vectors,soln!-matrices,max!-unknowns,
           unknowns!-count!-list,poly!-remaining,
           prediction!-results,one!-prediction!-failed;
    v:=car variable!-set;
    degbd:=get!-degree!-bound car v;
    first!-time:=t;
    growth!-factor:=make!-growth!-factor v;
    poly!-remaining:=poly;
    prediction!-results:=mkvect number!-of!-factors;
    find!-msg1(best!-factors,growth!-factor,poly);
    b0s:=reduce!-vec!-by!-one!-var!-mod!-p(best!-factors,
                    v,number!-of!-factors);
            % The above made a copy of the vector.
    for i:=1:number!-of!-factors do
      putv(best!-factors,i,
        difference!-mod!-p(getv(best!-factors,i),getv(b0s,i)));
    redpoly:=evaluate!-mod!-p(poly,car v,cdr v);
    find!-msg2(v,variable!-set);
    find!-multivariate!-factors!-mod!-p(redpoly,b0s,cdr variable!-set);
            % answers in b0s.
    if bad!-case then return;
    for i:=1:number!-of!-factors do
      putv(best!-factors,i,
        plus!-mod!-p(getv(b0s,i),getv(best!-factors,i)));
    find!-msg3(best!-factors,v);
    res:=diff!-over!-k!-mod!-p(
        difference!-mod!-p(poly,
          times!-vector!-mod!-p(best!-factors,number!-of!-factors)),
        1,car v);
            % RES is the residue and must eventually be reduced to zero.
    factor!-trace << printsf res; terpri!*(nil) >>;
    if not polyzerop res and
      cdr variable!-set and not zerop cdr v then <<
      predicted!-forms:=make!-bivariate!-vec!-mod!-p(best!-factors,
        cdr variable!-set,car v,number!-of!-factors);
      find!-multivariate!-factors!-mod!-p(
        make!-bivariate!-mod!-p(poly,cdr variable!-set,car v),
        predicted!-forms,list v);
            % Answers in PREDICTED!-FORMS.
      find!-msg4(predicted!-forms,v);
      make!-predicted!-forms(predicted!-forms,car v);
            % Sets max!-unknowns and number!-of!-unknowns.
      find!-msg5();
      unknowns!-count!-list:=number!-of!-unknowns;
      while unknowns!-count!-list and
         (car (w:=car unknowns!-count!-list))=1 do
        begin scalar i,r;
          unknowns!-count!-list:=cdr unknowns!-count!-list;
          i:=cdr w;
          w:=quotient!-mod!-p(poly!-remaining,r:=getv(best!-factors,i));
          if didntgo w or
            not polyzerop difference!-mod!-p(poly!-remaining,
            times!-mod!-p(w,r)) then
            if one!-prediction!-failed then <<
              factor!-trace printstr "Predictions are no good";
              max!-unknowns:=nil >>
            else <<
              factor!-trace <<
                prin2!* "Guess for f(";
                prin2!* i;
                printstr ") was bad." >>;
              one!-prediction!-failed:=i >>
          else <<
            putv(prediction!-results,i,r);
            factor!-trace <<
              prin2!* "Prediction for f("; prin2!* i;
              prin2!* ") worked: ";
              printsf r >>;
            poly!-remaining:=w >>
        end;
      w:=length unknowns!-count!-list;
      if w=1 and not one!-prediction!-failed then <<
        putv(best!-factors,cdar unknowns!-count!-list,poly!-remaining);
        go to exit >>
      else if w=0 and one!-prediction!-failed then <<
        putv(best!-factors,one!-prediction!-failed,poly!-remaining);
        go to exit >>;
      solve!-count:=1;
      if max!-unknowns then
        correction!-vectors:=
           make!-correction!-vectors(best!-factors,max!-unknowns) >>;
    bhat0s:=make!-multivariate!-hatvec!-mod!-p(b0s,number!-of!-factors);
    return multihen1(list(res,
                             growth!-factor,
                             first!-time,
                             bhat0s,
                             b0s,
                             variable!-set,
                             solve!-count,
                             correction!-vectors,
                             unknowns!-count!-list,
                             best!-factors,
                             v,
                             degbd,
                             soln!-matrices,
                             predicted!-forms,
                             poly!-remaining,
                             prediction!-results,
                             one!-prediction!-failed),
                             nil);
exit:
      multihen!-exit(first!-time,best!-factors,nil);
  end) (factor!-level+1);

symbolic procedure multihen1(u,zz);
   begin scalar res,test!-prediction,growth!-factor,first!-time,hat0s,
            x0s,variable!-set,solve!-count,correction!-vectors,
            unknowns!-count!-list,correction!-factor,frvec,v,
            degbd,soln!-matrices,predicted!-forms,poly!-remaining,
            fvec,previous!-prediction!-holds,
            prediction!-results,one!-prediction!-failed,
            bool,d,x1,k,kk,substres,w;
      res := car u; u := cdr u;
      growth!-factor := car u; u := cdr u;
      first!-time := car u; u := cdr u;
      hat0s := car u; u := cdr u;
      x0s := car u; u := cdr u;
      variable!-set := car u; u := cdr u;
      solve!-count := car u; u := cdr u;
      correction!-vectors := car u; u := cdr u;
      unknowns!-count!-list := car u; u := cdr u;
      frvec := car u; u := cdr u;
      v := car u; u := cdr u;
      degbd := car u; u := cdr u;
      soln!-matrices := car u; u := cdr u;
      predicted!-forms := car u; u := cdr u;
      poly!-remaining := car u; u := cdr u;
      prediction!-results := car u; u := cdr u;
      if zz then <>;
      one!-prediction!-failed := car u;
      correction!-factor:=growth!-factor;
            % Next power of growth-factor we are adding to the factors.
      x1:=mkvect number!-of!-factors;
      k:=1;
      kk:=0;
temploop:
    bool := nil;
    while not bool and not polyzerop res and (null max!-unknowns
                      or null test!-prediction) do
      if k>degbd then <<
        factor!-trace <<
          prin2!* "We have overshot the degree bound for ";
          printvar car v >>;
        if !*overshoot then
          prin2t "Multivariate degree bound overshoot -> restart";
        bad!-case:= bool := t >>
      else
        if polyzerop(substres:=evaluate!-mod!-p(res,car v,cdr v))
         then <<
          k:=iadd1 k;
          res:=diff!-over!-k!-mod!-p(res,k,car v);
          correction!-factor:=
            times!-mod!-p(correction!-factor,growth!-factor) >>
      else begin
        multihen!-msg(growth!-factor,first!-time,k,kk,substres,zz);
        if null zz
          then <>;
        solve!-for!-corrections(substres,hat0s,x0s,x1,
                                cdr variable!-set);
            % Answers left in x1.
        if bad!-case then return (bool := t);
        if max!-unknowns then <<
          solve!-count:=iadd1 solve!-count;
          for i:=1:number!-of!-factors do
            putv(getv(correction!-vectors,i),solve!-count,getv(x1,i));
          if solve!-count=caar unknowns!-count!-list then
            test!-prediction:=t >>;
        if zz then
           for i:=1:number!-of!-factors do
             putv(frvec,i,plus!-mod!-p(getv(frvec,i),times!-mod!-p(
                  getv(x1,i),correction!-factor)));
        factor!-trace <<
          printstr "   Giving:";
          if null zz then
          printvec("     f(",number!-of!-factors,",1) = ",x1)
           else <<
          printvec("     a(",number!-of!-factors,",1) = ",x1);
          printstr "   New a's are now:";
          printvec("     a(",number!-of!-factors,") = ",frvec) >>>>;
         d:=times!-mod!-p(correction!-factor,
              if zz then form!-sum!-and!-product!-mod!-p(x1,fhatvec,
                number!-of!-factors)
               else terms!-done!-mod!-p(frvec,x1,correction!-factor));
        if degree!-in!-variable(d,car v)>degbd then <<
          factor!-trace <<
            prin2!* "We have overshot the degree bound for ";
            printvar car v >>;
          if !*overshoot then
            prin2t "Multivariate degree bound overshoot -> restart";
          bad!-case:=t;
          return (bool := t)>>;
        d:=diff!-k!-times!-mod!-p(d,k,car v);
        if null zz then
           for i:=1:number!-of!-factors do
             putv(frvec,i,
               plus!-mod!-p(getv(frvec,i),
                 times!-mod!-p(getv(x1,i),correction!-factor)));
        k:=iadd1 k;
        res:=diff!-over!-k!-mod!-p(difference!-mod!-p(res,d),k,car v);
        factor!-trace <<
           if null zz then <>;
        correction!-factor:=
          times!-mod!-p(correction!-factor,growth!-factor) end;
    if not polyzerop res and not bad!-case then <<
      if null zz or null soln!-matrices then
        soln!-matrices
           := construct!-soln!-matrices(predicted!-forms,cdr v);
      factor!-trace <<
        if null zz then <<
        printstr "We use the results from the Hensel growth to";
        printstr "produce a set of linear equations to solve";
        printstr "for coefficients in the relevant factors:" >>
         else <<
        printstr "The Hensel growth so far allows us to test some of";
        printstr "our predictions:" >>>>;
      bool := nil;
      while not bool and unknowns!-count!-list and
        (car (w:=car unknowns!-count!-list))=solve!-count do <<
        unknowns!-count!-list:=cdr unknowns!-count!-list;
        factor!-trace
          print!-linear!-system(cdr w,soln!-matrices,
            correction!-vectors,predicted!-forms,car v);
        w:=try!-prediction(soln!-matrices,correction!-vectors,
          predicted!-forms,car w,cdr w,poly!-remaining,car v,
          if zz then fvec else nil,
          if zz then fhatvec else nil);
        if car w='singular or car w='bad!-prediction then
          if one!-prediction!-failed then <<
            factor!-trace printstr "Predictions were no help.";
            max!-unknowns:=nil;
            bool := t>>
          else if null zz then one!-prediction!-failed:=cdr w
          else <<
            if previous!-prediction!-holds then <<
              predictions:=delasc(car v,predictions);
              previous!-prediction!-holds:=nil >>;
            one!-prediction!-failed:=cdr w >>
        else <<
          putv(prediction!-results,car w,cadr w);
          poly!-remaining:=caddr w >> >>;
      if null max!-unknowns then <<
        if zz and previous!-prediction!-holds then
          predictions:=delasc(car v,predictions);
        goto temploop >>;
      w:=length unknowns!-count!-list;
      if w>1 or (w=1 and one!-prediction!-failed) then <<
        test!-prediction:=nil;
        goto temploop >>;
      if w=1 or one!-prediction!-failed then <<
        w:=if one!-prediction!-failed then one!-prediction!-failed
           else cdar unknowns!-count!-list;
        putv(prediction!-results,w,
             if null zz then poly!-remaining
              else quotfail!-mod!-p(poly!-remaining,
                                    getv(fhatvec,w)))>>;
      for i:=1:number!-of!-factors do
          putv(frvec,i,getv(prediction!-results,i));
      if (not previous!-prediction!-holds or null zz)
         and not one!-prediction!-failed then
        predictions:=
          (car v .
            list(soln!-matrices,predicted!-forms,max!-unknowns,
              number!-of!-unknowns))
          . predictions >>;
      multihen!-exit(first!-time,frvec,zz)
   end;

symbolic
   procedure multihen!-msg(growth!-factor,first!-time,k,kk,substres,zz);
        factor!-trace <<
          prin2!* "Hensel Step "; printstr (kk:=kk #+ 1);
          prin2!* "-------------";
          if kk>10 then printstr "-" else terpri!*(t);
          prin2!* "Next corrections are for (";
          prinsf growth!-factor;
          if not (k=1) then <<
            prin2!* ") ** ";
            prin2!* k >> else prin2!* '!);
          printstr ". To find these we solve:";
          if zz then prin2!* "     sum over i [ a(i,1)*fhat(i,0) ] = "
           else prin2!* "     sum over i [ f(i,1)*fhat(i,0) ] = ";
          prinsf substres;
          prin2!* " mod ";
          prin2!* hensel!-growth!-size;
          if zz then printstr " for a(i,1). "
           else printstr " for f(i,1), ";
          if null zz and first!-time then <<
            prin2!*
               "       where fhat(i,0) = product over j [ f(j,0) ]";
            prin2!* " / f(i,0) mod ";
            printstr hensel!-growth!-size >>;
          terpri!*(nil)
        >>;

symbolic procedure multihen!-exit(first!-time,frvec,zz);
      factor!-trace <<
      if not bad!-case then
        if first!-time then
          if zz then printstr "But these a's are already correct."
           else printstr "Therefore these factors are already correct."
        else <<
          if zz then <>;

symbolic procedure find!-msg1(best!-factors,growth!-factor,poly);
    factor!-trace <<
      printstr "Want f(i) s.t.";
      prin2!* "  product over i [ f(i) ] = ";
      prinsf poly;
      prin2!* " mod ";
      printstr hensel!-growth!-size;
      terpri!*(nil);
      printstr "We know f(i) as follows:";
      printvec("  f(",number!-of!-factors,") = ",best!-factors);
      prin2!* " and we shall put in powers of ";
      prinsf growth!-factor;
      printstr " to find them fully."
    >>;

symbolic procedure find!-msg2(v,variable!-set);
    factor!-trace <<
      prin2!*
         "First solve the problem in one less variable by putting ";
      prinvar car v; prin2!* "="; printstr cdr v;
      if cdr variable!-set then <<
        prin2!* "and growing wrt ";
        printvar caadr variable!-set
        >>;
      terpri!*(nil)
    >>;

symbolic procedure find!-msg3(best!-factors,v);
    factor!-trace <<
      prin2!* "After putting back any knowledge of ";
      prinvar car v;
      printstr ", we have the";
      printstr "factors so far as:";
      printvec("  f(",number!-of!-factors,") = ",best!-factors);
      printstr "Subtracting the product of these from the polynomial";
      prin2!* "and differentiating wrt "; prinvar car v;
      printstr " gives a residue:"
    >>;

symbolic procedure find!-msg4(predicted!-forms,v);
      factor!-trace <<
        printstr "To help reduce the number of Hensel steps we try";
        prin2!* "predicting how many terms each factor will have wrt ";
        prinvar car v; printstr ".";
        printstr
          "Predictions are based on the bivariate factors :";
        printvec("     f(",number!-of!-factors,") = ",predicted!-forms)
        >>;

symbolic procedure find!-msg5;
      factor!-trace <<
        terpri!*(nil);
        printstr "We predict :";
        for each w in number!-of!-unknowns do <<
          prin2!* car w;
          prin2!* " terms in f("; prin2!* cdr w; printstr '!) >>;
        if (caar number!-of!-unknowns)=1 then <<
          prin2!* "Since we predict only one term for f(";
          prin2!* cdar number!-of!-unknowns;
          printstr "), we can try";
          printstr "dividing it out now:" >>
        else <<
          prin2!* "So we shall do at least ";
          prin2!* isub1 caar number!-of!-unknowns;
          prin2!* " Hensel step";
          if (caar number!-of!-unknowns)=2 then printstr "."
          else printstr "s." >>;
        terpri!*(nil) >>;

symbolic procedure solve!-for!-corrections(c,fhatvec,fvec,resvec,vset);
% ....;
  if null vset then
    for i:=1:number!-of!-factors do
      putv(resvec,i,
        remainder!-mod!-p(
          times!-mod!-p(c,getv(alphavec,i)),
          getv(fvec,i)))
  else (lambda factor!-level; begin
    scalar residue,growth!-factor,f0s,fhat0s,v,
      degbd,first!-time,redc,
      predicted!-forms,max!-unknowns,solve!-count,number!-of!-unknowns,
      correction!-vectors,soln!-matrices,w,previous!-prediction!-holds,
      unknowns!-count!-list,poly!-remaining,
      prediction!-results,one!-prediction!-failed;
    v:=car vset;
    degbd:=get!-degree!-bound car v;
    first!-time:=t;
    growth!-factor:=make!-growth!-factor v;
    poly!-remaining:=c;
    prediction!-results:=mkvect number!-of!-factors;
    redc:=evaluate!-mod!-p(c,car v,cdr v);
    solve!-msg1(c,fvec,v);
    solve!-for!-corrections(redc,
      fhat0s:=reduce!-vec!-by!-one!-var!-mod!-p(
        fhatvec,v,number!-of!-factors),
      f0s:=reduce!-vec!-by!-one!-var!-mod!-p(
        fvec,v,number!-of!-factors),
      resvec,
      cdr vset); % Results left in RESVEC.
    if bad!-case then return;
    solve!-msg2(resvec,v);
    residue:=diff!-over!-k!-mod!-p(difference!-mod!-p(c,
          form!-sum!-and!-product!-mod!-p(resvec,fhatvec,
            number!-of!-factors)),1,car v);
    factor!-trace <<
      printsf residue;
      prin2!* " Now we shall put in the powers of ";
      prinsf growth!-factor;
      printstr " to find the a's fully."
    >>;
    if not polyzerop residue and not zerop cdr v then <<
      w:=atsoc(car v,predictions);
      if w then <<
        previous!-prediction!-holds:=t;
        factor!-trace <<
          printstr
             "We shall use the previous prediction for the form of";
          prin2!* "polynomials wrt "; printvar car v >>;
        w:=cdr w;
        soln!-matrices:=car w;
        predicted!-forms:=cadr w;
        max!-unknowns:=caddr w;
        number!-of!-unknowns:=cadr cddr w >>
      else <<
        factor!-trace <<
     printstr
        "We shall use a new prediction for the form of polynomials ";
        prin2!* "wrt "; printvar car v >>;
        predicted!-forms:=mkvect number!-of!-factors;
        for i:=1:number!-of!-factors do
          putv(predicted!-forms,i,getv(fvec,i));
            % Make a copy of the factors in a vector we shall overwrite.
        make!-predicted!-forms(predicted!-forms,car v);
            % Sets max!-unknowns and number!-of!-unknowns.
        >>;
      solve!-msg3();
      unknowns!-count!-list:=number!-of!-unknowns;
      while unknowns!-count!-list and
         (car (w:=car unknowns!-count!-list))=1 do
        begin scalar i,r,wr,fi;
          unknowns!-count!-list:=cdr unknowns!-count!-list;
          i:=cdr w;
          w:=quotient!-mod!-p(
            wr:=difference!-mod!-p(poly!-remaining,
              times!-mod!-p(r:=getv(resvec,i),getv(fhatvec,i))),
            fi:=getv(fvec,i));
          if didntgo w or not polyzerop
            difference!-mod!-p(wr,times!-mod!-p(w,fi)) then
            if one!-prediction!-failed then <<
              factor!-trace printstr "Predictions are no good.";
              max!-unknowns:=nil >>
            else <<
              factor!-trace <<
                prin2!* "Guess for a(";
                prin2!* i;
                printstr ") was bad." >>;
              one!-prediction!-failed:=i >>
          else <<
            putv(prediction!-results,i,r);
            factor!-trace <<
              prin2!* "Prediction for a("; prin2!* i;
              prin2!* ") worked: ";
              printsf r >>;
            poly!-remaining:=wr >>
        end;
      w:=length unknowns!-count!-list;
      if w=1 and not one!-prediction!-failed then <<
        putv(resvec,cdar unknowns!-count!-list,
          quotfail!-mod!-p(poly!-remaining,getv(fhatvec,
            cdar unknowns!-count!-list)));
        go to exit >>
      else if w=0 and one!-prediction!-failed and max!-unknowns then <<
        putv(resvec,one!-prediction!-failed,
          quotfail!-mod!-p(poly!-remaining,getv(fhatvec,
            one!-prediction!-failed)));
        go to exit >>;
      solve!-count:=1;
      if max!-unknowns then
        correction!-vectors:=
           make!-correction!-vectors(resvec,max!-unknowns) >>;
    if not polyzerop residue then first!-time:=nil;
    return multihen1(list(residue,
                            growth!-factor,
                            first!-time,
                            fhat0s,
                            f0s,
                            vset,
                            solve!-count,
                            correction!-vectors,
                            unknowns!-count!-list,
                            resvec,
                            v,
                            degbd,
                            soln!-matrices,
                            predicted!-forms,
                            poly!-remaining,
                            prediction!-results,
                            fvec,
                            previous!-prediction!-holds,
                            one!-prediction!-failed),
                            t);
exit:
      multihen!-exit(first!-time,resvec,t);
  end) (factor!-level+1);

symbolic procedure solve!-msg1(c,fvec,v);
    factor!-trace <<
      printstr "Want a(i) s.t.";
      prin2!* "(*)  sum over i [ a(i)*fhat(i) ] = ";
      prinsf c;
      prin2!* " mod ";
      printstr hensel!-growth!-size;
      prin2!* "    where fhat(i) = product over j [ f(j) ]";
      prin2!* " / f(i) mod ";
      printstr hensel!-growth!-size;
      printstr "    and";
      printvec("      f(",number!-of!-factors,") = ",fvec);
      terpri!*(nil);
      prin2!*
         "First solve the problem in one less variable by putting ";
      prinvar car v; prin2!* '!=; printstr cdr v;
      terpri!*(nil)
    >>;

symbolic procedure solve!-msg2(resvec,v);
    factor!-trace <<
      printstr "Giving:";
      printvec("  a(",number!-of!-factors,",0) = ",resvec);
      printstr "Subtracting the contributions these give in (*) from";
      prin2!* "the R.H.S. of (*) ";
      prin2!* "and differentiating wrt "; prinvar car v;
      printstr " gives a residue:"
    >>;

symbolic procedure solve!-msg3;
      factor!-trace <<
        terpri!*(nil);
        printstr "We predict :";
        for each w in number!-of!-unknowns do <<
          prin2!* car w;
          prin2!* " terms in a("; prin2!* cdr w; printstr '!) >>;
        if (caar number!-of!-unknowns)=1 then <<
          prin2!* "Since we predict only one term for a(";
          prin2!* cdar number!-of!-unknowns;
          printstr "), we can test it right away:" >>
        else <<
          prin2!* "So we shall do at least ";
          prin2!* isub1 caar number!-of!-unknowns;
          prin2!* " Hensel step";
          if (caar number!-of!-unknowns)=2 then printstr "."
          else printstr "s." >>;
        terpri!*(nil) >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/interfac.red0000644000175000017500000003210711526203062024254 0ustar  giovannigiovannimodule interfac;

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn.

fluid '(m!-image!-variable
        poly!-vector
        polyzero
        unknowns!-list
        varlist);


%**********************************************************************;
%
% Routines that are specific to REDUCE.
%  These are either routines that are not needed in the HASH system
%  (which is the other algebra system that this factorizer
%  can be plugged into) or routines that are specifically
%  redefined in the HASH system.


%---------------------------------------------------------------------;
% The following would normally live in section:  ALPHAS
%---------------------------------------------------------------------;

symbolic procedure assoc!-alpha(poly,alist);  assoc(poly,alist);


%---------------------------------------------------------------------;
% The following would normally live in section:  COEFFTS
%---------------------------------------------------------------------;

symbolic procedure termvector2sf v;
  begin scalar r,w;
    for i:=car getv(v,0) step -1 until 1 do <<
      w:=getv(v,i);
            % degree . coefft;
      r:=if car w=0 then cdr w else
        (mksp(m!-image!-variable,car w) .* cdr w) .+ r
    >>;
    return r
  end;

symbolic procedure force!-lc(a,n);
% force polynomial a to have leading coefficient as specified;
    (lpow a .* n) .+ red a;

symbolic procedure merge!-terms(u,v);
  merge!-terms1(1,u,v,car getv(v,0));

symbolic procedure merge!-terms1(i,u,v,n);
  if i#>n then u
  else begin scalar a,b;
    a:=getv(v,i);
    if domainp u or not(mvar u=m!-image!-variable) then
      if not(car a=0) then errorf list("MERGING COEFFTS FAILED",u,a)
      else if cdr a then return cdr a
      else return u;
    b:=lt u;
    if tdeg b=car a then return
      (if cdr a then tpow b .* cdr a else b) .+
        merge!-terms1(i #+ 1,red u,v,n)
    else if tdeg b #> car a then return b .+ merge!-terms1(i,red u,v,n)
    else errorf list("MERGING COEFFTS FAILED ",u,a)
  end;

symbolic procedure list!-terms!-in!-factor u;
% ...;
  if domainp u then list (0 . nil)
  else (ldeg u . nil) . list!-terms!-in!-factor red u;

symbolic procedure try!-other!-coeffts(r,unknowns!-list,uv);
  begin scalar ldeg!-r,lc!-r,w;
    while not domainp r and (r:=red r) and not(w='complete) do <<
      if not depends!-on!-var(r,m!-image!-variable) then
        << ldeg!-r:=0; lc!-r:=r >>
      else << ldeg!-r:=ldeg r; lc!-r:=lc r >>;
      w:=solve!-next!-coefft(ldeg!-r,lc!-r,unknowns!-list,uv) >>
  end;


%---------------------------------------------------------------------;
% The following would normally live in section:  FACMISC
%---------------------------------------------------------------------;

symbolic procedure derivative!-wrt!-main!-variable(p,var);
% partial derivative of the polynomial p with respect to
% its main variable, var;
    if domainp p or (mvar p neq var) then nil
    else
     begin
      scalar degree;
      degree:=ldeg p;
      if degree=1 then return lc p; %degree one term is special;
      return (mksp(mvar p,degree-1) .* multf(degree,lc p)) .+
        derivative!-wrt!-main!-variable(red p,var)
     end;

symbolic procedure fac!-univariatep u;
% tests to see if u is univariate;
  domainp u or not multivariatep(u,mvar u);

symbolic procedure variables!.in!.form(a,sofar);
    if domainp a then sofar
    else <<
      if not memq(mvar a,sofar) then
        sofar:=mvar a . sofar;
      variables!.in!.form(red a,
        variables!.in!.form(lc a,sofar)) >>;


symbolic procedure degree!-in!-variable(p,v);
% returns the degree of the polynomial p in the
% variable v;
    if domainp p then 0
    else if lc p=0
     then errorf "Polynomial with a zero coefficient found"
    else if v=mvar p then ldeg p
    else max(degree!-in!-variable(lc p,v),
      degree!-in!-variable(red p,v));

symbolic procedure get!-height poly;
% find height (max coefft) of given poly;
  if null poly then 0
  else if numberp poly then abs poly
  else max(get!-height lc poly,get!-height red poly);


symbolic procedure poly!-minusp a;
    if a=nil then nil
    else if domainp a then minusp a
    else poly!-minusp lc a;

symbolic procedure poly!-abs a;
    if poly!-minusp a then negf a
    else a;

symbolic procedure fac!-printfactors l;
% procedure to print the result of factorize!-form;
% ie. l is of the form: (c . f)
%  where c is the numeric content (may be 1)
%  and f is of the form: ( (f1 . e1) (f2 . e2) ... (fn . en) )
%    where the fi's are s.f.s and ei's are numbers;
<< terpri();
  if not (car l = 1) then printsf car l;
  for each item in cdr l do
    printsf !*p2f mksp(prepf car item,cdr item) >>;


%---------------------------------------------------------------------;
% The following would normally live in section:  FACPRIM
%---------------------------------------------------------------------;

symbolic procedure invert!.poly(u,var);
% u is a non-trivial primitive square free multivariate polynomial.
% assuming var is the top-level variable in u, this effectively
% reverses the position of the coeffts: ie
%   a(n)*var**n + a(n-1)*var**(n-1) + ... + a(0)
% becomes:
%   a(0)*var**n + a(1)*var**(n-1) + ... + a(n) .               ;
  begin scalar w,invert!-sign;
    w:=invert!.poly1(red u,ldeg u,lc u,var);
    if poly!-minusp lc w then <<
      w:=negf w;
      invert!-sign:=-1 >>
    else invert!-sign:=1;
    return invert!-sign . w
  end;

symbolic procedure invert!.poly1(u,d,v,var);
% d is the degree of the poly we wish to invert.
% assume d > ldeg u always, and that v is never nil;
  if (domainp u) or not (mvar u=var) then
    (var to d) .* u .+ v
  else invert!.poly1(red u,d,(var to (d-ldeg u)) .* (lc u) .+ v,var);


symbolic procedure trailing!.coefft(u,var);
% u is multivariate poly with var as the top-level variable. we find
% the trailing coefft - ie the constant wrt var in u;
  if domainp u then u
  else if mvar u=var then trailing!.coefft(red u,var)
  else u;


%---------------------------------------------------------------------;
% The following would normally live in section:  IMAGESET
%---------------------------------------------------------------------;

symbolic procedure make!-image!-lc!-list(u,imset);
  reversip make!-image!-lc!-list1(u,imset,
    for each x in imset collect car x);

symbolic procedure make!-image!-lc!-list1(u,imset,varlist);
% If IMSET=((x1 . a1, x2 . a2, ... , xn . an)) (ordered) where xj is
% the variable and aj its value, then this fn creates n images of U wrt
% sets S(i) where S(i)= ((x1 . a1), ... , (xi . ai)). The result is an
% ordered list of pairs: (u(i) . X(i+1)) where u(i)= U wrt S(i) and
% X(i) = (xi, ... , xn) and X(n+1) = NIL.  VARLIST = X(1).
% (Note. the variables tagged to u(i) should be all those
% appearing in u(i) unless it is degenerate). The returned list is
% ordered with u(1) first and ending with the number u(n);
  if null imset then nil
  else if domainp u then list(!*d2n u . cdr varlist)
  else if mvar u=caar imset then
    begin scalar w;
      w:=horner!-rule!-for!-one!-var(
        u,caar imset,cdar imset,polyzero,ldeg u) . cdr varlist;
      return
        if polyzerop car w then list (0 . cdr w)
        else (w . make!-image!-lc!-list1(car w,cdr imset,cdr varlist))
    end
  else make!-image!-lc!-list1(u,cdr imset,cdr varlist);

symbolic procedure horner!-rule!-for!-one!-var(u,x,val,c,degg);
  if domainp u or not(mvar u=x)
    then if zerop val then u else addf(u,multf(c,!*n2f(val**degg)))
  else begin scalar newdeg;
    newdeg:=ldeg u;
    return horner!-rule!-for!-one!-var(red u,x,val,
       if zerop val then lc u
        else addf(lc u,
                  multf(c,!*n2f(val**(idifference(degg,newdeg))))),
                            newdeg)
  end;

symbolic procedure make!-image(u,imset);
% finds image of u wrt image set, imset, (=association list);
  if domainp u then u
  else if mvar u=m!-image!-variable then
    adjoin!-term(lpow u,!*n2f evaluate!-in!-order(lc u,imset),
                        make!-image(red u,imset))
  else !*n2f evaluate!-in!-order(u,imset);

symbolic procedure evaluate!-in!-order(u,imset);
% makes an image of u wrt imageset, imset, using horner's rule. result
% should be purely numeric;
  if domainp u then !*d2n u
  else if mvar u=caar imset then
    horner!-rule(evaluate!-in!-order(lc u,cdr imset),
      ldeg u,red u,imset)
  else evaluate!-in!-order(u,cdr imset);

symbolic procedure horner!-rule(c,degg,a,vset);
% c is running total and a is what is left;
  if domainp a
    then if zerop cdar vset then !*d2n a
          else (!*d2n a)+c*((cdar vset)**degg)
  else if not(mvar a=caar vset)
   then if zerop cdar vset then evaluate!-in!-order(a,cdr vset)
         else evaluate!-in!-order(a,cdr vset)+c*((cdar vset)**degg)
  else begin scalar newdeg;
    newdeg:=ldeg a;
    return horner!-rule(if zerop cdar vset
                          then evaluate!-in!-order(lc a,cdr vset)
                         else evaluate!-in!-order(lc a,cdr vset)
      +c*((cdar vset)**(idifference(degg,newdeg))),newdeg,red a,vset)
  end;


%---------------------------------------------------------------------;
% The following would normally live in section:  MHENSFNS
%---------------------------------------------------------------------;

symbolic procedure max!-degree(u,n);
% finds maximum degree of any single variable in U (n is max so far);
  if domainp u then n
  else if igreaterp(n,ldeg u) then
    max!-degree(red u,max!-degree(lc u,n))
  else max!-degree(red u,max!-degree(lc u,ldeg u));

symbolic procedure diff!-over!-k!-mod!-p(u,k,v);
% derivative of u wrt v divided by k (=number);
  if domainp u then nil
  else if mvar u = v then
    if ldeg u = 1 then quotient!-mod!-p(lc u,modular!-number k)
    else adjoin!-term(mksp(v,isub1 ldeg u),
      quotient!-mod!-p(
        times!-mod!-p(modular!-number ldeg u,lc u),
        modular!-number k),
      diff!-over!-k!-mod!-p(red u,k,v))
  else adjoin!-term(lpow u,
    diff!-over!-k!-mod!-p(lc u,k,v),
    diff!-over!-k!-mod!-p(red u,k,v));

symbolic procedure diff!-k!-times!-mod!-p(u,k,v);
% differentiates u k times wrt v and divides by (k!) ie. for each term
% a*v**n we get [n k]*a*v**(n-k) if n>=k and nil if n>;


%---------------------------------------------------------------------;
% The following would normally live in section:  UNIHENS
%---------------------------------------------------------------------;

symbolic procedure root!-squares(u,sofar);
  if null u then pmam!-sqrt sofar
  else if domainp u then pmam!-sqrt(sofar+(u*u))
  else root!-squares(red u,sofar+(lc u * lc u));

%---------------------------------------------------------------------;
% The following would normally live in section:  VECPOLY
%---------------------------------------------------------------------;

symbolic procedure poly!-to!-vector p;
% spread the given univariate polynomial out into POLY-VECTOR;
    if domainp p then putv(poly!-vector,0,!*d2n p)
    else <<
      putv(poly!-vector,ldeg p,lc p);
      poly!-to!-vector red p >>;

symbolic procedure vector!-to!-poly(p,d,v);
% Convert the vector P into a polynomial of degree D in variable V;
  begin
    scalar r;
    if d#<0 then return nil;
    r:=!*n2f getv(p,0);
    for i:=1:d do
      if getv(p,i) neq 0 then r:=((v to i) .* getv(p,i)) .+ r;
    return r
  end;



endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/ezgcdf.red0000644000175000017500000010424411526203062023725 0ustar  giovannigiovannimodule ezgcdf; % Polynomial GCD algorithms.

% Author: A. C. Norman, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*exp
        !*gcd
        !*heugcd
        !*overview
        !*trfac
        alphalist
        bad!-case
        best!-known!-factors
        current!-modulus
        dmode!*
        factor!-level
        factor!-trace!-list
        full!-gcd
        hensel!-growth!-size
        image!-factors
        image!-set
        irreducible
        kord!*
        m!-image!-variable
        multivariate!-factors
        multivariate!-input!-poly
        non!-monic
        no!-of!-primes!-to!-try
        number!-of!-factors
        prime!-base
        reconstructing!-gcd
        reduced!-degree!-lclst
        reduction!-count
        target!-factor!-count
        true!-leading!-coeffts
        unlucky!-case);

global '(erfg!*);

symbolic procedure ezgcdf(u,v);
   % Entry point for REDUCE call in GCDF. We have to make sure that
   % the kernel order is correct if an error occurs in ezgcdf1.
   begin scalar erfgx,kordx,x;
      erfgx := erfg!*;
      kordx := kord!*;
      x := errorset2{'ezgcdf1,mkquote u,mkquote v};
      if null errorp x then return first x;
      % If ezgcdf fails, erfg!* can be set to t,
      % (e.g., in invlap(c/(p^3/8-9p^2/4+27/2*p-27)^2,p,t)), and
      % the kernel order not properly reset.
      erfg!* := erfgx;
      setkorder kordx;
      return gcdf1(u,v)
   end;

symbolic procedure ezgcdf1(u,v);
   % Entry point for REDUCE call in GCDF.
   poly!-abs gcdlist list(u,v) where factor!-level=0;

%symbolic procedure simpezgcd u;
% calculate the gcd of the polynomials given as arguments;
%  begin
%    scalar factor!-level,w;
%    factor!-level:=0;
%    u := for each p in u collect <<
%        w := simp!* p;
%        if (denr w neq 1) then
%           rederr "EZGCD requires polynomial arguments";
%        numr w >>;
%    return (poly!-abs gcdlist u) ./ 1
%  end;

%put('ezgcd,'simpfn,'simpezgcd);

symbolic procedure simpnprimitive p;
% Remove any simple numeric factors from the expression P;
  begin
    scalar np,dp;
    if atom p or not atom cdr p then
       rerror(ezgcd,2,"NPRIMITIVE requires just one argument");
    p := simp!* car p;
    if polyzerop(numr p) then return nil ./ 1;
    np := quotfail(numr p,numeric!-content numr p);
    dp := quotfail(denr p,numeric!-content denr p);
    return (np ./ dp)
  end;

put('nprimitive,'simpfn,'simpnprimitive);


symbolic procedure poly!-gcd(u,v);
   % U and V are standard forms.
   % Value is the gcd of U and V.
   begin scalar !*exp,z;
        if polyzerop u then return poly!-abs v
         else if polyzerop v then return poly!-abs u
         else if u=1 or v=1 then return 1;
        !*exp := t;
        % The case of one argument exactly dividing the other is
        % detected specially here because it is perhaps a fairly
        % common circumstance.
        if quotf1(u,v) then z := v
         else if quotf1(v,u) then z := u
         else if !*gcd then z := gcdlist list(u,v)
         else z := 1;
        return poly!-abs z
   end;

% moved('gcdf,'poly!-gcd);

symbolic procedure ezgcd!-comfac p;
  %P is a standard form
  %CAR of result is lowest common power of leading kernel in
  %every term in P (or NIL). CDR is gcd of all coefficients of
  %powers of leading kernel;
  if domainp p then nil . poly!-abs p
  else if null red p then lpow p . poly!-abs lc p
  else begin
    scalar power,coeflist,var;
    % POWER will be the first part of the answer returned,
    % COEFLIST will collect a list of all coefs in the polynomial
    % P viewed as a poly in its main variable,
    % VAR is the main variable concerned;
    var := mvar p;
    while mvar p=var and not domainp red p do <<
      coeflist := lc p . coeflist;
      p:=red p >>;
    if mvar p=var then <<
      coeflist := lc p . coeflist;
      if null red p then power := lpow p
      else coeflist := red p . coeflist >>
    else coeflist := p . coeflist;
    return power . gcdlist coeflist
  end;

symbolic procedure gcd!-with!-number(n,a);
% n is a number, a is a polynomial - return their gcd, given that
% n is non-zero;
    if n=1 or not atom n or flagp(dmode!*,'field) then 1
    else if domainp a
     then if a=nil then abs n
           else if not atom a then 1
           else gcddd(n,a)
    else gcd!-with!-number(gcd!-with!-number(n,lc a),red a);

% moved('gcdfd,'gcd!-with!-number);


symbolic procedure contents!-with!-respect!-to(p,v);
    if domainp p then nil . poly!-abs p
    else if mvar p=v then ezgcd!-comfac p
    else begin
      scalar w,y;
      y := updkorder v;
      w := ezgcd!-comfac reorder p;
      setkorder y;
      return w
    end;

symbolic procedure numeric!-content form;
% Find numeric content of non-zero polynomial.
   if domainp form then absf form
   else if null red form then numeric!-content lc form
   else begin
     scalar g1;
     g1 := numeric!-content lc form;
     if not (g1=1) then g1 := gcddd(g1,numeric!-content red form);
     return g1
   end;

symbolic procedure gcdlist l;
% Return the GCD of all the polynomials in the list L.
%
% First find all variables mentioned in the polynomials in L,
% and remove monomial content from them all. If in the process
% a constant poly is found, take special action. If then there
% is some variable that is mentioned in all the polys in L, and
% which occurs only linearly in one of them establish that as
% main variable and proceed to GCDLIST3 (which will take
% a special case exit). Otherwise, if there are any variables that
% do not occur in all the polys in L they can not occur in the GCD,
% so take coefficients with respect to them to get a longer list of
% smaller polynomials - restart. Finally we have a set of polys
% all involving exactly the same set of variables;
  if null l then nil
  else if null cdr l then poly!-abs car l
  else if domainp car l then gcdld(cdr l,car l)
  else begin
    scalar l1,gcont,x;
    % Copy L to L1, but on the way detect any domain elements
    % and deal with them specially;
    while not null l do <<
        if null car l then l := cdr l
        else if domainp car l then <<
          l1 := list list gcdld(cdr l,gcdld(mapcarcar l1,car l));
          l := nil >>
        else <<
          l1 := (car l . powers1 car l) . l1;
          l := cdr l >> >>;
    if null l1 then return nil
    else if null cdr l1 then return poly!-abs caar l1;
    % Now L1 is a list where each polynomial is paired with information
    % about the powers of variables in it;
    gcont := nil; % Compute monomial content on things in L;
    x := nil; % First time round flag;
    l := for each p in l1 collect begin
        scalar gcont1,gcont2,w;
        % Set GCONT1 to least power information, and W to power
        % difference;
        w := for each y in cdr p
                collect << gcont1 := (car y . cddr y) . gcont1;
                           car y . (cadr y-cddr y) >>;
        % Now get the monomial content as a standard form (in GCONT2);
        gcont2 := numeric!-content car p;
        if null x then << gcont := gcont1; x := gcont2 >>
        else << gcont := vintersection(gcont,gcont1);
                   % Accumulate monomial gcd;
                x := gcddd(x,gcont2) >>;
        for each q in gcont1 do if not(cdr q=0) then
            gcont2 := multf(gcont2,!*p2f mksp(car q,cdr q));
        return quotfail1(car p,gcont2,"Term content division failed")
                  . w
        end;
    % Here X is the numeric part of the final GCD.
    for each q in gcont do x := multf(x,!*p2f mksp(car q,cdr q));
%   trace!-time <<
%     prin2!* "Term gcd = ";
%     printsf x >>;
    return poly!-abs multf(x,gcdlist1 l)
  end;


symbolic procedure gcdlist1 l;
% Items in L are monomial-primitive, and paired with power information.
% Find out what variables are common to all polynomials in L and
% remove all others;
  begin
    scalar unionv,intersectionv,vord,x,l1,reduction!-count;
    unionv := intersectionv := cdar l;
    for each p in cdr l do <<
       unionv := vunion(unionv,cdr p);
       intersectionv := vintersection(intersectionv,cdr p) >>;
    if null intersectionv then return 1;
    for each v in intersectionv do
       unionv := vdelete(v,unionv);
    % Now UNIONV is list of those variables mentioned that
    % are not common to all polynomials;
    intersectionv := sort(intersectionv,function lesspcdr);
    if cdar intersectionv=1 then <<
       % I have found something that is linear in one of its variables;
       vord := mapcarcar append(intersectionv,unionv);
       l1 := setkorder vord;
%      trace!-time <<
%        prin2 "Selecting "; prin2 caar intersectionv;
%        prin2t " as main because some poly is linear in it" >>;
       x := gcdlist3(for each p in l collect reorder car p,nil,vord);
       setkorder l1;
       return reorder x >>
    else if null unionv then return gcdlist2(l,intersectionv);
%   trace!-time <<
%     prin2 "The variables "; prin2 unionv; prin2t " can be removed" >>;
    vord := setkorder mapcarcar append(unionv,intersectionv);
    l1 := nil;
    for each p in l do
        l1:=split!-wrt!-variables(reorder car p,mapcarcar unionv,l1);
    setkorder vord;
    return gcdlist1(for each p in l1 collect
      (reorder p . total!-degree!-in!-powers(p,nil)))
  end;


symbolic procedure gcdlist2(l,vars);
% Here all the variables in VARS are used in every polynomial
% in L. Select a good variable ordering;
  begin
    scalar x,x1,gg,lmodp,onestep,vord,oldmod,image!-set,gcdpow,
           unlucky!-case;
% In the univariate case I do not need to think very hard about
% the selection of a main variable!! ;
    if null cdr vars
      then return if !*heugcd and (x := heu!-gcd!-list(mapcarcar l))
                    then x
                   else gcdlist3(mapcarcar l,nil,list caar vars);
    oldmod := set!-modulus nil;
% If some variable appears at most to degree two in some pair of the
% polynomials then that will do as a main variable.  Note that this is
% not so useful if the two polynomials happen to be duplicates of each
% other, but still... ;

    vars := mapcarcar sort(vars,function greaterpcdr);
% Vars is now arranged with the variable that appears to highest
% degree anywhere in L first, and the rest in descending order;
    l := for each p in l collect car p .
      sort(cdr p,function lesspcdr);
    l := sort(l,function lesspcdadr);
% Each list of degree information in L is sorted with lowest degree
% vars first, and the polynomial with the lowest degree variable
% of all will come first;
    x := intersection(deg2vars(cdar l),deg2vars(cdadr l));
    if not null x then <<
%      trace!-time << prin2 "Two inputs are at worst quadratic in ";
%                     prin2t car x >>;
      go to x!-to!-top >>;   % Here I have found two polys with a common
                             % variable that they are quadratic in;
% Now generate modular images of the gcd to guess its degree wrt
% all possible variables;

% If either (a) modular gcd=1 or (b) modular gcd can be computed with
% just 1 reduction step, use that information to choose a main variable;
try!-again:  % Modular images may be degenerate;
    set!-modulus random!-prime();
    unlucky!-case := nil;
    image!-set := for each v in vars
                   collect (v . modular!-number next!-random!-number());
%   trace!-time <<
%     prin2 "Select variable ordering using P=";
%     prin2 current!-modulus;
%     prin2 " and substitutions from ";
%     prin2t image!-set >>;
    x1 := vars;
try!-vars:
    if null x1 then go to images!-tried;
    lmodp := for each p in l collect make!-image!-mod!-p(car p,car x1);
    if unlucky!-case then go to try!-again;
    lmodp := sort(lmodp,function lesspdeg);
    gg := gcdlist!-mod!-p(car lmodp,cdr lmodp);
    if domainp gg or (reduction!-count<2 and (onestep:=t)) then <<
%          trace!-time << prin2 "Select "; prin2t car x1 >>;
           x := list car x1; go to x!-to!-top >>;
    gcdpow := (car x1 . ldeg gg) . gcdpow;
    x1 := cdr x1;
    go to try!-vars;
images!-tried:
  % In default of anything better to do, use image variable such that
  % degree of gcd wrt it is as large as possible;
    vord := mapcarcar sort(gcdpow,function greaterpcdr);
%   trace!-time << prin2 "Select order by degrees: ";
%                  prin2t gcdpow >>;
    go to order!-chosen;

x!-to!-top:
    for each v in x do vars := delete(v,vars);
    vord := append(x,vars);
order!-chosen:
%   trace!-time << prin2 "Selected Var order = "; prin2t vord >>;
    set!-modulus oldmod;
    vars := setkorder vord;
    x := gcdlist3(for each p in l collect reorder car p,onestep,vord);
    setkorder vars;
    return reorder x
  end;

symbolic procedure gcdlist!-mod!-p(gg,l);
   if null l then gg
   else if gg=1 then 1
   else gcdlist!-mod!-p(gcd!-mod!-p(gg,car l),cdr l);

symbolic procedure deg2vars l;
    if null l then nil
    else if cdar l>2 then nil
    else caar l . deg2vars cdr l;

symbolic procedure vdelete(a,b);
    if null b then nil
    else if car a=caar b then cdr b
    else car b . vdelete(a,cdr b);

symbolic procedure vintersection(a,b);
  begin
    scalar c;
    return if null a then nil
    else if null (c:=assoc(caar a,b)) then vintersection(cdr a,b)
    else if cdar a>cdr c then
      if cdr c=0 then vintersection(cdr a,b)
      else c . vintersection(cdr a,b)
    else if cdar a=0 then vintersection(cdr a,b)
    else car a . vintersection(cdr a,b)
  end;


symbolic procedure vunion(a,b);
  begin
    scalar c;
    return if null a then b
    else if null (c:=assoc(caar a,b)) then car a . vunion(cdr a,b)
    else if cdar a>cdr c then car a . vunion(cdr a,delete(c,b))
    else c . vunion(cdr a,delete(c,b))
  end;


symbolic procedure mapcarcar l;
    for each x in l collect car x;


symbolic procedure gcdld(l,n);
% GCD of the domain element N and all the polys in L;
    if n=1 or n=-1 then 1
    else if l=nil then abs n
    else if car l=nil then gcdld(cdr l,n)
    else gcdld(cdr l,gcd!-with!-number(n,car l));

symbolic procedure split!-wrt!-variables(p,vl,l);
% Push all the coeffs in P wrt variables in VL onto the list L
% Stop if 1 is found as a coeff;
    if p=nil then l
    else if not null l and car l=1 then l
    else if domainp p then abs p . l
    else if member(mvar p,vl) then
        split!-wrt!-variables(red p,vl,split!-wrt!-variables(lc p,vl,l))
    else p . l;

symbolic procedure gcdlist3(l,onestep,vlist);
   % GCD of the nontrivial polys in the list L given that they all
   % involve all the variables that any of them mention,
   % and they are all monomial-primitive.
   % ONESTEP is true if it is predicted that only one PRS step
   % will be needed to compute the gcd - if so try that PRS step.
  begin
    scalar unlucky!-case,image!-set,gg,gcont,l1,w,w1,w2,
           reduced!-degree!-lclst,p1,p2;
    % Make all the polys primitive;
    l1:=for each p in l collect p . ezgcd!-comfac p;
    l:=for each c in l1 collect
        quotfail1(car c,comfac!-to!-poly cdr c,
                  "Content divison in GCDLIST3 failed");
    % All polys in L are now primitive.
    % Because all polys were monomial-primitive, there should
    % be no power of V to go in the result.
    gcont:=gcdlist for each c in l1 collect cddr c;
    if domainp gcont then if not(gcont=1)
      then errorf "GCONT has numeric part";
    % GCD of contents complete now;
    % Now I will remove duplicates from the list;
%   trace!-time <<
%      prin2t "GCDLIST3 on the polynomials";
%      for each p in l do print p >>;
    l := sort(for each p in l collect poly!-abs p,function ordp);
    w := nil;
    while l do <<
       w := car l . w;
       repeat l := cdr l until null l or not(car w = car l)>>;
    l := reversip w;
    w := nil;
%   trace!-time <<
%      prin2t "Made positive, with duplicates removed...";
%      for each p in l do print p >>;
    if null cdr l then return multf(gcont,car l);
       % That left just one poly;
    if domainp (gg:=car (l:=sort(l,function degree!-order))) then
      return gcont;
         % Primitive part of one poly is a constant (must be +/-1);
    if ldeg gg=1 then <<
    % True gcd is either GG or 1;
       if division!-test(gg,l) then return multf(poly!-abs gg,gcont)
       else return gcont >>;
    % All polys are now primitive and nontrivial. Use a modular
    % method to extract GCD;
    if onestep then <<
       % Try to take gcd in just one pseudoremainder step, because some
       % previous modular test suggests it may be possible;
       p1 := poly!-abs car l; p2 := poly!-abs cadr l;
       % Because polynomials are primitive and they have been normalised
       % wrt sign the only way that just one PRS step could lead to zero
       % would be if the two polys are identical.  In which case that
       % should be the GCD. Note that because I got to gcdlist3 at all
       % both polys should use (all of) the same set of variables, and
       % in particular should have the same main variable.
       if p1=p2 then <<
             if division!-test(p1,cddr l) then return multf(p1,gcont)>>
       else <<
%      trace!-time prin2t "Just one pseudoremainder step needed?";
       gg := poly!-gcd(lc p1,lc p2);
       w1 := multf(red p1, quotfail1(lc p2, gg,
        "Division failure when just one pseudoremainder step needed"));
       w2 := multf(red p2,negf quotfail1(lc p1, gg,
        "Division failure when just one pseudoremainder step needed"));
       w := ldeg p1 - ldeg p2;
       if w > 0 then w2 := multf(w2, (mksp(mvar p2, w) .* 1) .+ nil)
       else if w < 0
        then w1 := multf(w1, (mksp(mvar p1, -w) .* 1) .+ nil);
       gg := ezgcd!-pp addf(w1, w2);
%      trace!-time printsf gg;
       if division!-test(gg,l) then return multf(gg,gcont) >>>>;
       return gcdlist31(l,vlist,gcont,gg,l1)
   end;

symbolic procedure gcdlist31(l,vlist,gcont,gg,l1);
   begin scalar cofactor,lcg,old!-modulus,prime,w,w1,zeros!-list;
    old!-modulus:=set!-modulus nil; %Remember modulus;
    lcg:=for each poly in l collect lc poly;
%    trace!-time << prin2t "L.C.S OF L ARE:";
%      for each lcpoly in lcg do printsf lcpoly >>;
    lcg:=gcdlist lcg;
%    trace!-time << prin2!* "LCG (=GCD OF THESE) = ";
%      printsf lcg >>;
try!-again:
    unlucky!-case:=nil;
    image!-set:=nil;
    set!-modulus(prime:=random!-prime());
    % Produce random univariate modular images of all the
    % polynomials;
    w:=l;
    if not zeros!-list then <<
      image!-set:=
         zeros!-list:=try!-max!-zeros!-for!-image!-set(w,vlist);
%     trace!-time << prin2t image!-set;
%       prin2 " Zeros-list = ";
%       prin2t zeros!-list >>
      >>;
%   trace!-time prin2t list("IMAGE SET",image!-set);
    gg:=make!-image!-mod!-p(car w,car vlist);
%   trace!-time prin2t list("IMAGE SET",image!-set," GG",gg);
    if unlucky!-case then <<
%     trace!-time << prin2t "Unlucky case, try again";
%       print image!-set >>;
      go to try!-again >>;
    l1:=list(car w . gg);
make!-images:
    if null (w:=cdr w) then go to images!-created!-successfully;
    l1:=(car w . make!-image!-mod!-p(car w,car vlist)) . l1;
    if unlucky!-case then <<
%    trace!-time << prin2t "UNLUCKY AGAIN...";
%      prin2t l1;
%      print image!-set >>;
      go to try!-again >>;
    gg:=gcd!-mod!-p(gg,cdar l1);
    if domainp gg then <<
      set!-modulus old!-modulus;
%     trace!-time print "Primitive parts are coprime";
      return gcont >>;
    go to make!-images;
images!-created!-successfully:
    l1:=reversip l1; % Put back in order with smallest first;
    % If degree of gcd seems to be same as that of smallest item
    % in input list, that item should be the gcd;
    if ldeg gg=ldeg car l then <<
        gg:=poly!-abs car l;
%       trace!-time <<
%         prin2!* "Probable GCD = ";
%         printsf gg >>;
        go to result >>
    else if (ldeg car l=add1 ldeg gg) and
            (ldeg car l=ldeg cadr l) then <<
    % Here it seems that I have just one pseudoremainder step to
    % perform, so I might as well do it;
%       trace!-time <<
%          prin2t "Just one pseudoremainder step needed"
%          >>;
        gg := poly!-gcd(lc car l,lc cadr l);
        gg := ezgcd!-pp addf(multf(red car l,
            quotfail1(lc cadr l,gg,
         "Division failure when just one pseudoremainder step needed")),
         multf(red cadr l,negf quotfail1(lc car l,gg,
         "Divison failure when just one pseudoremainder step needed")));
%       trace!-time printsf gg;
        go to result >>;
    w:=l1;
find!-good!-cofactor:
    if null w then go to special!-case; % No good cofactor available;
    if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(cdar w,gg))
      then go to good!-cofactor!-found;
    w:=cdr w;
    go to find!-good!-cofactor;
good!-cofactor!-found:
    cofactor:=monic!-mod!-p cofactor;
%   trace!-time prin2t "*** Good cofactor found";
    w:=caar w;
%    trace!-time << prin2!* "W= ";
%      printsf w;
%      prin2!* "GG= ";
%      printsf gg;
%      prin2!* "COFACTOR= ";
%      printsf cofactor >>;
    image!-set:=sort(image!-set,function ordopcar);
%    trace!-time << prin2 "IMAGE-SET = ";
%      prin2t image!-set;
%      prin2 "PRIME= ";   prin2t prime;
%      prin2t "L (=POLYLIST) IS:";
%      for each ll in l do printsf ll >>;
    gg:=reconstruct!-gcd(w,gg,cofactor,prime,image!-set,lcg);
    if gg='nogood then go to try!-again;
    go to result;
special!-case: % Here I have to do the first step of a PRS method;
%   trace!-time << prin2t "*** SPECIAL CASE IN GCD ***";
%     prin2t l;
%     prin2t "----->";
%     prin2t gg >>;
    reduced!-degree!-lclst:=nil;
try!-reduced!-degree!-again:
%   trace!-time << prin2t "L1 =";
%     for each ell in l1 do print ell >>;
    w1:=reduced!-degree(caadr l1,caar l1);
    w:=car w1; w1:=cdr w1;
    if not domainp w and
       (domainp w1 or ldeg w neq ldeg w1) then go to try!-again;
%   trace!-time << prin2 "REDUCED!-DEGREE = "; printsf w;
%     prin2 " and its image = "; printsf w1 >>;
            % reduce the degree of the 2nd poly using the 1st. Result is
            % a pair : (new poly . image new poly);
    if domainp w and not null w then <<
      set!-modulus old!-modulus; return gcont >>;
            % we're done as they're coprime;
    if w and ldeg w = ldeg gg then <<
      gg:=w; go to result >>;
            % possible gcd;
    if null w then <<
            % the first poly divided the second one;
      l1:=(car l1 . cddr l1);  % discard second poly;
      if null cdr l1 then <<
         gg := poly!-abs caar l1;
         go to result >>;
      go to try!-reduced!-degree!-again >>;
            % haven't made progress yet so repeat with new polys;
    if ldeg w<=ldeg gg then <<
       gg := poly!-abs w;
       go to result >>
    else if domainp gcd!-mod!-p(gg,cofactor:=quotient!-mod!-p(w1,gg))
     then <<
       w := list list w;
       go to good!-cofactor!-found >>;
    l1:= if ldeg w <= ldeg caar l1 then
      ((w . w1) . (car l1 . cddr l1))
      else (car l1 . ((w . w1) . cddr l1));
            % replace first two polys by the reduced poly and the first
            % poly ordering according to degree;
    go to try!-reduced!-degree!-again;
            % need to repeat as we still haven't found a good cofactor;
result: % Here GG holds a tentative gcd for the primitive parts of
        % all input polys, and GCONT holds a proper one for the content;
    if division!-test(gg,l) then <<
      set!-modulus old!-modulus;
      return multf(gg,gcont) >>;
%   trace!-time prin2t list("Trial division by ",gg," failed");
    go to try!-again
  end;

symbolic procedure make!-a!-list!-of!-variables l;
  begin scalar vlist;
    for each ll in l do vlist:=variables!.in!.form(ll,vlist);
    return make!-order!-consistent(vlist,kord!*)
  end;

symbolic procedure make!-order!-consistent(l,m);
% L is a subset of M. Make its order consistent with that
% of M;
    if null l then nil
    else if null m then errorf("Variable missing from KORD*")
    else if car m member l then car m .
       make!-order!-consistent(delete(car m,l),cdr m)
    else make!-order!-consistent(l,cdr m);

symbolic procedure try!-max!-zeros!-for!-image!-set(l,vlist);
  if null vlist then error(50,"VLIST NOT SET IN TRY-MAX-ZEROS-...")
  else begin scalar z;
    z:=for each v in cdr vlist collect
      if domainp lc car l or null quotf(lc car l,!*k2f v) then
        (v . 0) else (v . modular!-number next!-random!-number());
    for each ff in cdr l do
      z:=for each w in z collect
        if zerop cdr w then
          if domainp lc ff or null quotf(lc ff,!*k2f car w) then w
          else (car w . modular!-number next!-random!-number())
        else w;
    return z
  end;

symbolic procedure
   reconstruct!-gcd(full!-poly,gg,cofactor,p,imset,lcg);
  if null addf(full!-poly,negf multf(gg,cofactor)) then gg
  else (lambda factor!-level;
    begin scalar number!-of!-factors,image!-factors,
    true!-leading!-coeffts,multivariate!-input!-poly,
    no!-of!-primes!-to!-try,
    irreducible,non!-monic,bad!-case,target!-factor!-count,
    multivariate!-factors,hensel!-growth!-size,alphalist,
    best!-known!-factors,prime!-base,
    m!-image!-variable, reconstructing!-gcd,full!-gcd;
    if not(current!-modulus=p) then
      errorf("GCDLIST HAS NOT RESTORED THE MODULUS");
            % *WARNING* GCDLIST does not restore the modulus so
              % I had better reset it here!  ;
    if poly!-minusp lcg then error(50,list("Negative GCD: ",lcg));
    full!-poly:=poly!-abs full!-poly;
    initialise!-hensel!-fluids(full!-poly,gg,cofactor,p,lcg);
%    trace!-time << prin2t "TRUE LEADING COEFFTS ARE:";
%      for i:=1:2 do <<
%        printsf getv(image!-factors,i);
%        prin2!* " WITH L.C.:";
%        printsf getv(true!-leading!-coeffts,i) >> >>;
    if determine!-more!-coeffts()='done then
      return full!-gcd;
    if null alphalist then alphalist:=alphas(2,
      list(getv(image!-factors,1),getv(image!-factors,2)),1);
    if alphalist='factors! not! coprime then
      errorf list("image factors not coprime?",image!-factors);
    if not !*overview then factor!-trace <<
      printstr
         "The following modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(2)*f(1) + a(1)*f(2) = 1 mod ";
      printstr hensel!-growth!-size;
      terpri();
      printstr "  where degree of a(1) < degree of f(1),";
      printstr "    and degree of a(2) < degree of f(2),";
      printstr "    and";
      for i:=1:2 do <<
        prin2!* "    a("; prin2!* i; prin2!* ")=";
        printsf cdr get!-alpha getv(image!-factors,i);
        prin2!* "and f("; prin2!* i; prin2!* ")=";
        printsf getv(image!-factors,i);
        terpri!* t >>
    >>;
    reconstruct!-multivariate!-factors(
      for each v in imset collect (car v . modular!-number cdr v));
    if irreducible or bad!-case then return 'nogood
    else return full!-gcd
  end) (factor!-level+1) ;

symbolic procedure initialise!-hensel!-fluids(fpoly,fac1,fac2,p,lcf1);
% ... ;
  begin scalar lc1!-image,lc2!-image;
    reconstructing!-gcd:=t;
    multivariate!-input!-poly:=multf(fpoly,lcf1);
    no!-of!-primes!-to!-try := 5;
    prime!-base:=hensel!-growth!-size:=p;
    number!-of!-factors:=2;
    lc1!-image:=make!-numeric!-image!-mod!-p lcf1;
    lc2!-image:=make!-numeric!-image!-mod!-p lc fpoly;
% Neither of the above leading coefficients will vanish;
    fac1:=times!-mod!-p(lc1!-image,fac1);
    fac2:=times!-mod!-p(lc2!-image,fac2);
    image!-factors:=mkvect 2;
    true!-leading!-coeffts:=mkvect 2;
    putv(image!-factors,1,fac1);
    putv(image!-factors,2,fac2);
    putv(true!-leading!-coeffts,1,lcf1);
    putv(true!-leading!-coeffts,2,lc fpoly);
    % If the GCD is going to be monic, we know the lc
    % of both cofactors exactly;
    non!-monic:=not(lcf1=1);
    m!-image!-variable:=mvar fpoly
  end;

symbolic procedure division!-test(gg,l);
% Predicate to test if GG divides all the polynomials in the list L;
    if null l then t
    else if null quotf(car l,gg) then nil
    else division!-test(gg,cdr l);



symbolic procedure degree!-order(a,b);
% Order standard forms using their degrees wrt main vars;
    if domainp a then t
    else if domainp b then nil
    else ldeg a>
    else w := cdr w;
    return modular!-expt(w,n)
  end;

symbolic procedure make!-numeric!-image!-mod!-p p;
% Make a modular image of P;
  if domainp p then
     if p=nil then 0
     else modular!-number p
    else modular!-plus(
      modular!-times(image!-of!-power(mvar p,ldeg p),
                    make!-numeric!-image!-mod!-p lc p),
      make!-numeric!-image!-mod!-p red p);


symbolic procedure total!-degree!-in!-powers(form,powlst);
% Returns a list where each variable mentioned in FORM is paired
% with the maximum degree it has. POWLST collects the list, and should
% normally be NIL on initial entry;
  if null form or domainp form then powlst
  else begin scalar x;
    if (x := atsoc(mvar form,powlst))
      then ldeg form>cdr x and rplacd(x,ldeg form)
    else powlst := (mvar form . ldeg form) . powlst;
    return total!-degree!-in!-powers(red form,
      total!-degree!-in!-powers(lc form,powlst))
  end;


symbolic procedure powers1 form;
% For each variable V in FORM collect (V . (MAX . MIN)) where
% MAX and MIN are limits to the degrees V has in FORM;
  powers2(form,powers3(form,nil),nil);

symbolic procedure powers3(form,l);
% Start of POWERS1 by collecting power information for
% the leading monomial in FORM;
    if domainp form then l
    else powers3(lc form,(mvar form . (ldeg form . ldeg form)) . l);

symbolic procedure powers2(form,powlst,thismonomial);
    if domainp form then
        if null form then powlst else powers4(thismonomial,powlst)
    else powers2(lc form,
                 powers2(red form,powlst,thismonomial),
                 lpow form . thismonomial);

symbolic procedure powers4(new,old);
% Merge information from new monomial into old information,
% updating MAX and MIN details;
  if null new then for each v in old collect (car v . (cadr v . 0))
  else if null old then for each v in new collect (car v . (cdr v . 0))
  else if caar new=caar old then <<
    % variables match - do MAX and MIN on degree information;
    if cdar new>cadar old then rplaca(cdar old,cdar new);
    if cdar new>
  else if ordop(caar new,caar old) then <<
    rplacd(cdar old,0); % Some variable not mentioned in new monomial;
    rplacd(old,powers4(new,cdr old)) >>
  else (caar new . (cdar new  . 0)) . powers4(cdr new,old);


symbolic procedure ezgcd!-pp u;
   %returns the primitive part of the polynomial U wrt leading var;
   quotf1(u,comfac!-to!-poly ezgcd!-comfac u);

symbolic procedure ezgcd!-sqfrf p;
   %P is a primitive standard form;
   %value is a list of square free factors;
  begin
    scalar pdash,p1,d,v;
    pdash := diff(p,v := mvar p);
    d := poly!-gcd(p,pdash); % p2*p3**2*p4**3*... ;
    if domainp d then return list p;
    p := quotfail1(p,d,"GCD division in FACTOR-SQFRF failed");
    p1 := poly!-gcd(p,
       addf(quotfail1(pdash,d,"GCD division in FACTOR-SQFRF failed"),
            negf diff(p,v)));
    return p1 . ezgcd!-sqfrf d
  end;

symbolic procedure reduced!-degree(u,v);
   %U and V are primitive polynomials in the main variable VAR;
   %result is pair: (reduced poly of U by V . its image) where by
   % reduced I mean using V to kill the leading term of U;
   begin scalar var,w,x;
%   trace!-time << prin2t "ARGS FOR REDUCED!-DEGREE ARE:";
%    printsf u;  printsf v >>;
    if u=v or quotf1(u,v) then return (nil . nil)
    else if ldeg v=1 then return (1 . 1);
%   trace!-time prin2t "CASE NON-TRIVIAL SO TAKE A REDUCED!-DEGREE:";
    var := mvar u;
    if ldeg u=ldeg v then x := negf lc u
    else x:=(mksp(var,ldeg u - ldeg v) .* negf lc u) .+ nil;
    w:=addf(multf(lc v,u),multf(x,v));
%   trace!-time printsf w;
    if degr(w,var)=0 then return (1 . 1);
%   trace!-time << prin2 "REDUCED!-DEGREE-LCLST = ";
%     print reduced!-degree!-lclst >>;
    reduced!-degree!-lclst := addlc(v,reduced!-degree!-lclst);
%   trace!-time << prin2 "REDUCED!-DEGREE-LCLST = ";
%     print reduced!-degree!-lclst >>;
    if x := quotf1(w,lc w) then w := x
    else for each y in reduced!-degree!-lclst do
      while (x := quotf1(w,y)) do w := x;
    u := v; v := ezgcd!-pp w;
%   trace!-time << prin2t "U AND V ARE NOW:";
%     printsf u; printsf v >>;
    if degr(v,var)=0 then return (1 . 1)
    else return (v . make!-univariate!-image!-mod!-p(v,var))
  end;


% moved('comfac,'ezgcd!-comfac);

% moved('pp,'ezgcd!-pp);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/pfactor.red0000644000175000017500000001526011526203062024120 0ustar  giovannigiovannimodule pfactor;  % Factorization of polynomials modulo p.

% Author: A. C. Norman, 1978.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*balanced_mod
        !*gcd
        current!-modulus
        m!-image!-variable
        modular!-info
        modulus!/2
        user!-prime);

global '(largest!-small!-modulus);

symbolic procedure pfactor(q,p);
   % Q is a standard form. Factorize and return the factors mod p.
   begin scalar user!-prime,current!-modulus,modulus!/2,r,x;
%   set!-time();
    if not numberp p then typerr(p,"number")
     else if not primep p then typerr(p,"prime")
     else if p>largest!-small!-modulus
      then rederr {p,"too large a modulus for factorization"};
    user!-prime:=p;
    set!-modulus p;
    if domainp q or null reduce!-mod!-p lc q then
       prin2t "*** Degenerate case in modular factorization";
    if not (length variables!-in!-form q=1) then
   %%    rerror(factor,1,"Multivariate input to modular factorization");
       return fctrfkronm q;
    r:=reduce!-mod!-p q;
%   lncoeff := lc r;
    x := lnc r;
    r :=monic!-mod!-p r;
%   print!-time "About to call FACTOR-FORM-MOD-P";
    r:=errorset!*(list('factor!-form!-mod!-p,mkquote r),t);
%   print!-time "FACTOR-FORM-MOD-P returned";
    if not errorp r
      then return x . for each j in car r
                          collect mod!-adjust car j . cdr j;
    prin2t "****** FACTORIZATION FAILED******";
    return list(1,prepf q)   % 1 needed by factorize.
  end;

symbolic procedure mod!-adjust u;
   % Make sure any modular numbers in u are in the right range.
   if null !*balanced_mod then u else mod!-adjust1 u;

symbolic procedure mod!-adjust1 u;
   if domainp u
     then if fixp u then !*modular2f u
           else if eqcar(u,'!:mod!:) then !*modular2f cdr u
           else typerr(u,"modular number")
    else lpow u .* mod!-adjust1 lc u .+ mod!-adjust1 red u;


symbolic procedure factor!-form!-mod!-p p;
% input:
% p is a reduce standard form that is to be factorized
% mod prime;
% result:
% ((p1 . x1) (p2 . x2) .. (pn . xn))
% where p are standard forms and x are integers,
% and p= product p**x;
    sort!-factors factorize!-by!-square!-free!-mod!-p p;

symbolic procedure factorize!-by!-square!-free!-mod!-p p;
    if p=1 then nil
    else if domainp p then (p . 1) . nil
    else
     begin
      scalar dp,v;
      v:=(mksp(mvar p,1).* 1) .+ nil;
      dp:=0;
      while evaluate!-mod!-p(p,mvar v,0)=0 do <<
        p:=quotfail!-mod!-p(p,v);
        dp:=dp+1 >>;
      if dp>0 then return ((v . dp) .
        factorize!-by!-square!-free!-mod!-p p);
      dp:=derivative!-mod!-p p;
      if dp=nil then <<
%here p is a something to the power current!-modulus;
        p:=divide!-exponents!-by!-p(p,current!-modulus);
        p:=factorize!-by!-square!-free!-mod!-p p;
        return multiply!-multiplicities(p,current!-modulus) >>;
      dp:=gcd!-mod!-p(p,dp);
      if dp=1 then return factorize!-pp!-mod!-p p;
%now p is not square-free;
      p:=quotfail!-mod!-p(p,dp);
%factorize p and dp separately;
      p:=factorize!-pp!-mod!-p p;
      dp:=factorize!-by!-square!-free!-mod!-p dp;
% i feel that this scheme is slightly clumsy, but
% square-free decomposition mod p is not as straightforward
% as square free decomposition over the integers, and pfactor
% is probably not going to be slowed down too badly by
% this;
      return mergefactors(p,dp)
   end;




%**********************************************************************;
% code to factorize primitive square-free polynomials mod p;



symbolic procedure divide!-exponents!-by!-p(p,n);
    if domainp p then p
    else (mksp(mvar p,exactquotient(ldeg p,n)) .* lc p) .+
       divide!-exponents!-by!-p(red p,n);

symbolic procedure exactquotient(a,b);
  begin
    scalar w;
    w:=divide(a,b);
    if cdr w=0 then return car w;
    error(50,list("Inexact division",list(a,b,w)))
  end;


symbolic procedure multiply!-multiplicities(l,n);
    if null l then nil
    else (caar l . (n*cdar l)) .
        multiply!-multiplicities(cdr l,n);


symbolic procedure mergefactors(a,b);
% a and b are lists of factors (with multiplicities),
% merge them so that no factor occurs more than once in
% the result;
    if null a then b
    else mergefactors(cdr a,addfactor(car a,b));

symbolic procedure addfactor(a,b);
%add factor a into list b;
    if null b then list a
    else if car a=caar b then
      (car a . (cdr a + cdar b)) . cdr b
    else car b . addfactor(a,cdr b);

symbolic procedure factorize!-pp!-mod!-p p;
%input a primitive square-free polynomial p,
% output a list of irreducible factors of p;
  begin
    scalar vars;
    if p=1 then return nil
    else if domainp p then return (p . 1) . nil;
% now I am certain that p is not degenerate;
%   print!-time "primitive square-free case detected";
    vars:=variables!-in!-form p;
    if length vars=1 then return unifac!-mod!-p p;
    errorf "SHAMBLED IN PFACTOR - MULTIVARIATE CASE RESURFACED"
  end;

symbolic procedure unifac!-mod!-p p;
%input p a primitive square-free univariate polynomial
%output a list of the factors of p over z mod p;
  begin
    scalar modular!-info,m!-image!-variable;
    if domainp p then return nil
    else if ldeg p=1 then return (p . 1) . nil;
    modular!-info:=mkvect 1;
    m!-image!-variable:=mvar p;
    get!-factor!-count!-mod!-p(1,p,user!-prime,nil);
%   print!-time "Factor counts obtained";
    get!-factors!-mod!-p(1,user!-prime);
%   print!-time "Actual factors extracted";
    return for each z in getv(modular!-info,1) collect (z . 1)
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/vecpoly.red0000644000175000017500000001170211526203062024140 0ustar  giovannigiovanniMODULE VECPOLY;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


FLUID '(CURRENT!-MODULUS SAFE!-FLAG);


%**********************************************************************;
% Routines for working with modular univariate polynomials
% stored as vectors. Used to avoid unwarranted storage management
% in the mod-p factorization process;


SAFE!-FLAG:=CARCHECK 0;


SYMBOLIC PROCEDURE COPY!-VECTOR(A,DA,B);
% Copy A into B;
 << FOR I:=0:DA DO
      PUTV(B,I,GETV(A,I));
    DA >>;

SYMBOLIC PROCEDURE TIMES!-IN!-VECTOR(A,DA,B,DB,C);
% Put the product of A and B into C and return its degree.
% C must not overlap with either A or B;
  BEGIN
    SCALAR DC,IC,W;
    IF DA#<0 OR DB#<0 THEN RETURN MINUS!-ONE;
    DC:=DA#+DB;
    FOR I:=0:DC DO PUTV(C,I,0);
    FOR IA:=0:DA DO <<
      W:=GETV(A,IA);
      FOR IB:=0:DB DO <<
        IC:=IA#+IB;
        PUTV(C,IC,MODULAR!-PLUS(GETV(C,IC),
          MODULAR!-TIMES(W,GETV(B,IB)))) >> >>;
    RETURN DC
  END;


SYMBOLIC PROCEDURE QUOTFAIL!-IN!-VECTOR(A,DA,B,DB);
% Overwrite A with (A/B) and return degree of result.
% The quotient must be exact;
    IF DA#<0 THEN DA
    ELSE IF DB#<0 THEN ERRORF "Attempt to divide by zero"
    ELSE IF DA#>;
    RETURN DA
  END;

SYMBOLIC PROCEDURE EVALUATE!-IN!-VECTOR(A,DA,N);
% Evaluate A at N;
  BEGIN
    SCALAR R;
    R:=GETV(A,DA);
    FOR I:=DA#-1 STEP -1 UNTIL 0 DO
      R:=MODULAR!-PLUS(GETV(A,I),
        MODULAR!-TIMES(R,N));
    RETURN R
  END;

SYMBOLIC PROCEDURE GCD!-IN!-VECTOR(A,DA,B,DB);
% Overwrite A with the gcd of A and B. On input A and B are
% vectors of coefficients, representing polynomials
% of degrees DA and DB. Return DG, the degree of the gcd;
  BEGIN
    SCALAR W;
    IF DA=0 OR DB=0 THEN << PUTV(A,0,1); RETURN 0 >>
    ELSE IF DA#<0 OR DB#<0 THEN ERRORF "GCD WITH ZERO NOT ALLOWED";
TOP:
% Reduce the degree of A;
    DA:=REMAINDER!-IN!-VECTOR(A,DA,B,DB);
    IF DA=0 THEN << PUTV(A,0,1); RETURN 0 >>
    ELSE IF DA=MINUS!-ONE THEN <<
      W:=MODULAR!-RECIPROCAL GETV(B,DB);
      FOR I:=0:DB DO PUTV(A,I,MODULAR!-TIMES(GETV(B,I),W));
      RETURN DB >>;
% Now reduce degree of B;
    DB:=REMAINDER!-IN!-VECTOR(B,DB,A,DA);
    IF DB=0 THEN << PUTV(A,0,1); RETURN 0 >>
    ELSE IF DB=MINUS!-ONE THEN <<
      W:=MODULAR!-RECIPROCAL GETV(A,DA);
      IF NOT (W=1) THEN
        FOR I:=0:DA DO PUTV(A,I,MODULAR!-TIMES(GETV(A,I),W));
      RETURN DA >>;
    GO TO TOP
  END;



CARCHECK SAFE!-FLAG;


ENDMODULE;


END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/pfacmult.red0000644000175000017500000001127211526203062024274 0ustar  giovannigiovannimodule pfacmult; % multivariate modular factorization.

% Author: Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Reduction of multivariate modular factorization to univariate
% factorization by Kroneckers map.
% See Kaltofen: Factorization of Polynomials, in: Buchberger,
% Collins, Loos: Computer Algebra, Springer, 1982.

% This module should be removed as soon as a multivariate modular
% factorizer based on Hensel lifting has been written.

fluid '(!*trfac);

symbolic procedure fctrfkronm f;
  begin scalar sub,tra,k,x,xx,x0,y,z,r,q,f0,fl,fs,dmode!*;
       integer d,d0;
    k:=kernels f;
    dmode!*:='!:mod!:;
    for each z in decomposedegr(f,for each x in k collect (x. 0))
         do if cdr z >d then d:=cdr z;
    d:=d+1; d0:=d; x0:=car k;
    for each x in cdr k do
    <>;
    fs:=numr subf(f,sub);
    if !*trfac then
     <>;
    fl:=decomposefctrf fs;
    if null cdr fl then return {1,f.1};
    f0:=numr resimp (f ./ 1);
    for each fc in fl do if not domainp f0 then
    <>;
     if (q:=quotf(f0,y)) then
        <>>>;
    if null r then return {1,f. 1};
    if domainp f0 then return (f0 .r);
    if !*trfac then
    <>;
    fl := fctrfkronm f0;
    if !*trfac then
    <> >>;
    x := car fl; xx := cdr fl;
    if null cdr xx and cdar xx = 1 and fctrfmk4 x then
    <> >> >>;
    for each fc in xx do
    <>;
        f0:=quotf(f0,y);
        if(z:=assoc(y,r)) then cdr z:=cdr z+cdr fc
                   else r:=(y. cdr fc).r>>;
    x := quotf(x, f0);
    return x . r
  end;

symbolic procedure fctrfmk1(f,tra);
  % Kronecker backtransform.
   if domainp f then f else
      addf(multf(lc f,fctrfmk2(mvar f,ldeg f,tra)),fctrfmk1(red f,tra));

symbolic procedure fctrfmk2(x,n,tra);
  if n=0 then 1 else
  if null tra then x.**n .* 1 .+ nil else
  if n>=cdar tra then multf(caar tra .** (n/cdar tra) .* 1 .+nil,
            fctrfmk2(x,remainder(n,cdar tra),cdr tra))
   else fctrfmk2(x,n,cdr tra);

symbolic procedure fctrfmk3 f;
% Extract the leading coefficient.
  if domainp f then (if fctrfmk4 f then nil else f) else fctrfmk3 lc f;

symbolic procedure fctrfmk4 u;
% Test u=1 in modular mode;
    numberp u and u = 1 or
      not atom u and car u = '!:mod!: and modonep!: u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/facuni.red0000644000175000017500000003136011526203062023726 0ustar  giovannigiovannimodule facuni;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*force!-prime
        !*trfac
        alphalist
        bad!-case
        best!-factor!-count
        best!-known!-factors
        best!-modulus
        best!-set!-pointer
        chosen!-prime
        factor!-level
        factor!-trace!-list
        forbidden!-primes
        hensel!-growth!-size
        input!-leading!-coefficient
        input!-polynomial
        irreducible
        known!-factors
        m!-image!-variable
        modular!-info
        no!-of!-best!-primes
        no!-of!-random!-primes
        non!-monic
        null!-space!-basis
        number!-of!-factors
        one!-complete!-deg!-analysis!-done
        poly!-mod!-p
        previous!-degree!-map
        reduction!-count
        split!-list
        target!-factor!-count
        univariate!-factors
        univariate!-input!-poly
        valid!-primes);


symbolic procedure univariate!-factorize poly;
% input poly a primitive square-free univariate polynomial at least
% quadratic and with +ve lc.  output is a list of the factors of poly
% over the integers ;
  if testx!*!*n!+1 poly then
    factorizex!*!*n!+1(m!-image!-variable,ldeg poly,1)
  else if testx!*!*n!-1 poly then
    factorizex!*!*n!-1(m!-image!-variable,ldeg poly,1)
  else univariate!-factorize1 poly;

symbolic procedure univariate!-factorize1 poly;
  begin scalar
    valid!-primes,univariate!-input!-poly,best!-set!-pointer,
    number!-of!-factors,irreducible,forbidden!-primes,
    no!-of!-best!-primes,no!-of!-random!-primes,bad!-case,
    target!-factor!-count,modular!-info,univariate!-factors,
    hensel!-growth!-size,alphalist,previous!-degree!-map,
    one!-complete!-deg!-analysis!-done,reduction!-count,
    multivariate!-input!-poly;
%note that this code works by using a local database of
%fluid variables that are updated by the subroutines directly
%called here. this allows for the relativly complicated
%interaction between flow of data and control that occurs in
%the factorization algorithm;
    factor!-trace <<
      prin2!* "Univariate polynomial="; printsf poly;
      printstr
         "The polynomial is univariate, primitive and square-free";
      printstr "so we can treat it slightly more specifically. We";
      printstr "factorise mod several primes,then pick the best one";
      printstr "to use in the Hensel construction." >>;
    initialize!-univariate!-fluids poly;
            % set up the fluids to start things off;
tryagain:
    get!-some!-random!-primes();
    choose!-the!-best!-prime();
      if irreducible then <<
        univariate!-factors:=list univariate!-input!-poly;
        goto exit >>
      else if bad!-case then <<
        bad!-case:=nil; goto tryagain >>;
    reconstruct!-factors!-over!-integers();
      if irreducible then <<
        univariate!-factors:=list univariate!-input!-poly;
        goto exit >>;
exit:
    factor!-trace <<
      printstr "The univariate factors are:";
      for each ff in univariate!-factors do printsf ff >>;
    return univariate!-factors
   end;


%**********************************************************************
% univariate factorization part 1. initialization and setting fluids;


symbolic procedure initialize!-univariate!-fluids u;
% Set up the fluids to be used in factoring primitive poly;
  begin
    if !*force!-prime then <<
      no!-of!-random!-primes:=1;
      no!-of!-best!-primes:=1 >>
    else <<
      no!-of!-random!-primes:=5;
            % we generate this many modular images and calculate
            % their factor counts;
      no!-of!-best!-primes:=3;
            % we find the modular factors of this many;
      >>;
    univariate!-input!-poly:=u;
    target!-factor!-count:=ldeg u
  end;


%**********************************************************************;
% univariate factorization part 2. creating modular images and picking
%  the best one;


symbolic procedure get!-some!-random!-primes();
% here we create a number of random primes to reduce the input mod p;
  begin scalar chosen!-prime,poly!-mod!-p,i;
    valid!-primes:=mkvect no!-of!-random!-primes;
    i:=0;
    while i < no!-of!-random!-primes do <<
      poly!-mod!-p:=
        find!-a!-valid!-prime(lc univariate!-input!-poly,
                    univariate!-input!-poly,nil);
      if not(poly!-mod!-p='not!-square!-free) then <<
        i:=iadd1 i;
        putv(valid!-primes,i,chosen!-prime . poly!-mod!-p);
        forbidden!-primes:=chosen!-prime . forbidden!-primes
        >>
      >>
  end;

symbolic procedure choose!-the!-best!-prime();
% given several random primes we now choose the best by factoring
% the poly mod its chosen prime and taking one with the
% lowest factor count as the best for hensel growth;
  begin scalar split!-list,poly!-mod!-p,null!-space!-basis,
               known!-factors,w,n;
    modular!-info:=mkvect no!-of!-random!-primes;
    for i:=1:no!-of!-random!-primes do <<
      w:=getv(valid!-primes,i);
      get!-factor!-count!-mod!-p(i,cdr w,car w,nil) >>;
    split!-list:=sort(split!-list,function lessppair);
            % this now contains a list of pairs (m . n) where
            % m is the no: of factors in set no: n. the list
            % is sorted with best split (smallest m) first;
    if caar split!-list = 1 then <<
      irreducible:=t; return nil >>;
    w:=split!-list;
    for i:=1:no!-of!-best!-primes do <<
      n:=cdar w;
      get!-factors!-mod!-p(n,car getv(valid!-primes,n));
      w:=cdr w >>;
            % pick the best few of these and find out their
            % factors mod p;
    split!-list:=delete(w,split!-list);
            % throw away the other sets;
    check!-degree!-sets(no!-of!-best!-primes,nil);
            % the best set is pointed at by best!-set!-pointer;
    one!-complete!-deg!-analysis!-done:=t;
    factor!-trace <<
      w:=getv(valid!-primes,best!-set!-pointer);
      prin2!* "The chosen prime is "; printstr car w;
      prin2!* "The polynomial mod "; prin2!* car w;
      printstr ", made monic, is:";
      printsf cdr w;
      printstr "and the factors of this modular polynomial are:";
      for each x in getv(modular!-info,best!-set!-pointer)
         do printsf x;
      >>
  end;



%**********************************************************************;
% univariate factorization part 3. reconstruction of the
% chosen image over the integers;


symbolic procedure reconstruct!-factors!-over!-integers();
% the hensel construction from modular case to univariate
% over the integers;
  begin scalar best!-modulus,best!-factor!-count,input!-polynomial,
    input!-leading!-coefficient,best!-known!-factors,s;
    s:=getv(valid!-primes,best!-set!-pointer);
    best!-known!-factors:=getv(modular!-info,best!-set!-pointer);
    input!-leading!-coefficient:=lc univariate!-input!-poly;
    best!-modulus:=car s;
    best!-factor!-count:=length best!-known!-factors;
    input!-polynomial:=univariate!-input!-poly;
    univariate!-factors:=reconstruct!.over!.integers();
    if irreducible then return t;
    number!-of!-factors:=length univariate!-factors;
    if number!-of!-factors=1 then return irreducible:=t
  end;


symbolic procedure reconstruct!.over!.integers();
  begin scalar w,lclist,non!-monic;
    set!-modulus best!-modulus;
    for i:=1:best!-factor!-count do
      lclist:=input!-leading!-coefficient . lclist;
    if not (input!-leading!-coefficient=1) then <<
      best!-known!-factors:=
        for each ff in best!-known!-factors collect
          multf(input!-leading!-coefficient,!*mod2f ff);
      non!-monic:=t;
      factor!-trace <<
        printstr
           "(a) Now the polynomial is not monic so we multiply each";
        printstr
           "of the modular factors, f(i), by the absolute value of";
        prin2!* "the leading coefficient: ";
        prin2!* input!-leading!-coefficient; printstr '!.;
        printstr "To bring the polynomial into agreement with this, we";
        prin2!* "multiply it by ";
        if best!-factor!-count > 2 then
          << prin2!* input!-leading!-coefficient; prin2!* "**";
            printstr isub1 best!-factor!-count >>
        else printstr input!-leading!-coefficient >> >>;
    w:=uhensel!.extend(input!-polynomial,
      best!-known!-factors,lclist,best!-modulus);
    if irreducible then return t;
    if car w ='ok then return cdr w
    else errorf w
  end;


% Now some special treatment for cyclotomic polynomials;

symbolic procedure testx!*!*n!+1 u;
  not domainp u and (
    lc u=1 and
    red u = 1);


symbolic procedure testx!*!*n!-1 u;
  not domainp u and (
    lc u=1 and
    red u = -1);


symbolic procedure factorizex!*!*n!+1(var,degree,vorder);
% Deliver factors of (VAR**VORDER)**DEGREE+1 given that it is
% appropriate to treat VAR**VORDER as a kernel;
  if evenp degree then factorizex!*!*n!+1(var,degree/2,2*vorder)
  else begin
    scalar w;
    w := factorizex!*!*n!-1(var,degree,vorder);
    w := negf car w . cdr w;
    return for each p in w collect negate!-variable(var,2*vorder,p)
  end;

symbolic procedure negate!-variable(var,vorder,p);
% VAR**(VORDER/2) -> -VAR**(VORDER/2) in the polynomial P;
  if domainp p then p
  else if mvar p=var then
    if remainder(ldeg p,vorder)=0 then
            lt p .+ negate!-variable(var,vorder,red p)
    else (lpow p .* negf lc p) .+ negate!-variable(var,vorder,red p)
  else (lpow p .* negate!-variable(var,vorder,lc p)) .+
        negate!-variable(var,vorder,red p);


symbolic procedure integer!-factors n;
% Return integer factors of N, with attached multiplicities. Assumes
% that N is fairly small;
  begin
    scalar l,q,m,w;
% L is list of results generated so far, Q is current test divisor,
% and M is associated multiplicity;
    if n=1 then return '((1 . 1));
    q := 2; m := 0;
    % Test divide by 2,3,5,7,9,11,13,...
top:
    w := divide(n,q);
    while cdr w=0 do << n := car w; w := divide(n,q); m := m+1 >>;
    if not(m=0) then l := (q . m) . l;
    if q>car w then <<
      if not(n=1) then l := (n . 1) . l;
      return reversip l >>;
%   q := ilogor(1,iadd1 q);
    q := iadd1 q;
    if q #> 3 then q := iadd1 q;
    m := 0;
    go to top
  end;


symbolic procedure factored!-divisors fl;
% FL is an association list of primes and exponents. Return a list
% of all subsets of this list, i.e. of numbers dividing the
% original integer. Exclude '1' from the list;
  if null fl then nil
  else begin
    scalar l,w;
    w := factored!-divisors cdr fl;
    l := w;
    for i := 1:cdar fl do <<
      l := list (caar fl . i) . l;
      for each p in w do
        l := ((caar fl . i) . p) . l >>;
    return l
  end;

symbolic procedure factorizex!*!*n!-1(var,degree,vorder);
  if evenp degree then append(factorizex!*!*n!+1(var,degree/2,vorder),
                              factorizex!*!*n!-1(var,degree/2,vorder))
  else if degree=1 then list((mksp(var,vorder) .* 1) .+ (-1))
  else begin
    scalar facdeg;
    facdeg := '((1 . 1)) . factored!-divisors integer!-factors degree;
    return for each fl in facdeg
       collect cyclotomic!-polynomial(var,fl,vorder)
  end;

symbolic procedure cyclotomic!-polynomial(var,fl,vorder);
% Create Psi(var**order)
% where degree is given by the association list of primes and
% multiplicities FL;
  if not(cdar fl=1) then
    cyclotomic!-polynomial(var,(caar fl . sub1 cdar fl) . cdr fl,
                           vorder*caar fl)
  else if cdr fl=nil then
     if caar fl=1 then (mksp(var,vorder) .* 1) .+ (-1)
     else quotfail((mksp(var,vorder*caar fl) .* 1) .+ (-1),
                   (mksp(var,vorder) .* 1) .+ (-1))
  else quotfail(cyclotomic!-polynomial(var,cdr fl,vorder*caar fl),
                cyclotomic!-polynomial(var,cdr fl,vorder));



endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/unihens.red0000644000175000017500000012214411526203062024133 0ustar  giovannigiovannimodule unihens;  % Univariate case of Hensel code with quadratic growth.

% Author: P. M. A. Moore, 1979.
% Modifications by J.H. Davenport 1988 following a 1985 draft by Abbott,
% Bradford and Davenport.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*linear
        !*overshoot
        !*overview
        !*trfac
        alphalist
        alphavec
        coefftbd
        current!-factor!-product
        current!-modulus
        delfvec
        deltam
        factor!-level
        factor!-trace!-list
        factors!-done
        factorvec
        facvec
        fhatvec
        hensel!-growth!-size
        hensel!-poly
        irreducible
        m!-image!-variable
        modfvec
        multivariate!-input!-poly
        non!-monic
        number!-of!-factors
        polyzero
        prime!-base
        reconstructing!-gcd);

global '(largest!-small!-modulus);


symbolic procedure uhensel!.extend(poly,best!-flist,lclist,p);
% Extend poly=product(factors in best!-flist) mod p even if poly is
% non-monic.  Return a list (ok. list of factors) if factors can be
% extended to be correct over the integers, otherwise return a list
% (failed  ).
  begin scalar w,k,old!-modulus,alphavec,modular!-flist,factorvec,
        modfvec,coefftbd,fcount,fhatvec,deltam,mod!-symm!-flist,
        current!-factor!-product,facvec,factors!-done,hensel!-poly;
    prime!-base:=p;
    old!-modulus:=set!-modulus p;
%   timer:=readtime();
    number!-of!-factors:=length best!-flist;
    w:=expt(lc poly,number!-of!-factors -1);
    if lc poly < 0 then errorf list("LC SHOULD NOT BE -VE",poly);
    coefftbd:=max(110,p+1,lc poly*get!-coefft!-bound(poly,ldeg poly));
    poly:=multf(poly,w);
    modular!-flist:=for each ff in best!-flist collect
      reduce!-mod!-p ff;
            % Modular factors have been multiplied by a constant to
            % fix the l.c.'s, so they may be out of range - this
            % fixes that.
      if not(w=1) then factor!-trace <<
        prin2!* "Altered univariate polynomial: "; printsf poly >>;
          % Make sure the leading coefft will not cause trouble
          % in the hensel construction.
    mod!-symm!-flist:=for each ff in modular!-flist collect
      make!-modular!-symmetric ff;
    if not !*overview then factor!-trace <<
      prin2!* "The factors mod "; prin2!* p;
      printstr " to start from are:";
      fcount:=1;
      for each ff in mod!-symm!-flist do <<
        prin2!* "   f("; prin2!* fcount; prin2!* ")=";
        printsf ff; fcount:=iadd1 fcount >>;
      terpri!*(nil) >>;
    alphalist:=alphas(number!-of!-factors,modular!-flist,1);
            % 'magic' polynomials associated with the image factors.
    if not !*overview then factor!-trace <<
      printstr
         "The following modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(1)*h(1) + ... + a(";
      prin2!* number!-of!-factors;
      prin2!* ")*h("; prin2!* number!-of!-factors;
      prin2!* ") = 1 mod "; printstr p;
      terpri();
      printstr "  where h(i)=(product of all f(j) [see below])/f(i)";
      printstr "    and degree of a(i) < degree of f(i).";
      fcount:=1;
      for each a in modular!-flist do <<
        prin2!* "   a("; prin2!* fcount; prin2!* ")=";
        printsf cdr get!-alpha a;
        prin2!* "   f("; prin2!* fcount; prin2!* ")=";
        printsf a;
        fcount:=iadd1 fcount >>
    >>;
    k:=0;
    factorvec:=mkvect number!-of!-factors;
    modfvec:=mkvect number!-of!-factors;
    alphavec:=mkvect number!-of!-factors;
    for each modsymmf in mod!-symm!-flist do
      << putv(factorvec,k:=k+1,force!-lc(modsymmf,car lclist));
         lclist:=cdr lclist
      >>;
    k:=0;
    for each modfactor in modular!-flist do
         << putv(modfvec,k:=k+1,modfactor);
         putv(alphavec,k,cdr get!-alpha modfactor);
         >>;
            % best!-fvec is now a vector of factors of poly correct
            % mod p with true l.c.s forced in.
    fhatvec:=mkvect number!-of!-factors;
    w:=hensel!-mod!-p(poly,modfvec,factorvec,coefftbd,nil,p);
    if car w='overshot then w := uhensel!.extend1(poly,w)
     else w := uhensel!.extend2 w;
   set!-modulus old!-modulus;
    if irreducible then <<
      factor!-trace
         printstr "Two factors and overshooting means irreducible";
      return t >>;
    factor!-trace begin scalar k;
      k:=0;
      printstr "Univariate factors, possibly with adjusted leading";
      printstr "coefficients, are:";
      for each ww in cdr w do <<
        prin2!* " f("; prin2!* (k:=k #+ 1);
        prin2!* ")="; printsf ww >>
    end;
    return if non!-monic then
        (car w . primitive!.parts(cdr w,m!-image!-variable,t))
      else w
  end;

symbolic procedure uhensel!.extend1(poly,w);
      begin scalar oklist,badlist,m,r,ff,om,pol;
        m:=cadr w; % the modulus.
        r:=getv(factorvec,0); % the number of factors.
        if r=2 then return (irreducible:=t);
        if factors!-done then <<
          poly:=hensel!-poly;
          for each ww in factors!-done do
            poly:=multf(poly,ww) >>;
        pol:=poly;
        om:=set!-modulus hensel!-growth!-size;
        alphalist:=nil;
        for i:=r step -1 until 1 do
          alphalist:=
             (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                      . alphalist;
        set!-modulus om;
            % bring alphalist up to date.
        for i:=1:r do <<
          ff:=getv(factorvec,i);
          if not didntgo(w:=quotf(pol,ff)) then
          << oklist:=ff . oklist; pol:=w>>
          else badlist:=(i . ff) . badlist >>;
        if null badlist then w:='ok . oklist
        else <<
          if not !*overview then factor!-trace <<
            printstr "Overshot factors are:";
            for each f in badlist do <<
              prin2!* " f("; prin2!* car f; prin2!* ")=";
              printsf cdr f >>
          >>;
          w:=try!.combining(badlist,pol,m,nil);
          if car w='one! bad! factor then begin scalar x;
            w:=append(oklist,cdr w);
            x:=1;
            for each v in w do x:=multf(x,v);
            w:='ok . (quotfail(pol,x) . w)
          end
          else w:='ok . append(oklist,w) >>;
        if (not !*linear) and multivariate!-input!-poly then <<
          poly:=1;
          number!-of!-factors:=0;
          for each facc in cdr w do <<
            poly:=multf(poly,facc);
            number!-of!-factors:=1 #+ number!-of!-factors >>;
            % make sure poly is the product of the factors we have,
            % we recalculate it this way because we may have the wrong
            % lc in old value of poly.
          reset!-quadratic!-step!-fluids(poly,cdr w,
                                         number!-of!-factors);
          if m=deltam then errorf list("Coefft bound < prime ?",
              coefftbd,m);
          m:=deltam*deltam;
          while m>;
          hensel!-growth!-size:=deltam;
          om:=set!-modulus hensel!-growth!-size;
          alphalist:=nil;
          for i:=number!-of!-factors step -1 until 1 do
            alphalist:=
              (reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                      . alphalist;
          set!-modulus om >>;
         return w
      end;

symbolic procedure uhensel!.extend2 w;
   begin scalar r,faclist,om;
      r:=getv(factorvec,0); % no of factors.
      om:=set!-modulus hensel!-growth!-size;
      alphalist:=nil;
      for i:=r step -1 until 1 do
        alphalist:=(reduce!-mod!-p getv(factorvec,i) . getv(alphavec,i))
                    . alphalist;
      set!-modulus om;
            % bring alphalist up to date.
      for i:=r step -1 until 1 do
        faclist:=getv(factorvec,i) . faclist;
      return (car w . faclist)
    end;

symbolic procedure get!-coefft!-bound(poly,ddeg);
% This uses Mignotte's bound which is minimal I believe.
% NB. poly had better be univariate as bound only valid for this.
  binomial!-coefft(ddeg/2,ddeg/4) * root!-squares(poly,0);

symbolic procedure binomial!-coefft(n,r);
  if n>;
    i:=0;
    alphazeros:=mkvect n;
    wvec:=mkvect n;
    for each modfthing in modflist do <<
      putv(modfvec,i:=iadd1 i,modfthing);
      putv(alphavec,i,!*f2mod(alpha:=cdr get!-alpha modfthing));
      putv(alphazeros,i,alpha);
      putv(wvec,i,alpha);
      putv(fhatvec,i,car fhatlist);
      fhatlist:=cdr fhatlist >>;
    gg:=gamma;
    ppow:=prime!-base;
    while ppow>;
      ppow:=ppow*prime!-base >>;
    set!-modulus m;
    i:=0;
    return (for each fthing in mflist collect
      (fthing . !*f2mod getv(alphavec,i:=iadd1 i)))
  end;

symbolic procedure alphas(n,flist,gamma);
% Finds alpha,beta,delta,... wrt factors f(i) in flist s.t.
%  alpha*g(1) + beta*g(2) + delta*g(3) + ... = gamma mod p,
% where g(i)=product(all the f(j) except f(i) itself).
% (cf. xgcd!-mod!-p below). n is number of factors in flist.
  if n=1 then list(car flist . gamma)
  else begin scalar k,w,f1,f2,i,gamma1,gamma2;
    k:=n/2;
    f1:=1; f2:=1;
    i:=1;
    for each f in flist do
    << if i>k then f2:=times!-mod!-p(f,f2)
       else f1:=times!-mod!-p(f,f1);
       i:=i+1 >>;
    w:=xgcd!-mod!-p(f1,f2,1,polyzero,polyzero,1);
    if atom w then
      return 'factors! not! coprime;
    gamma1:=remainder!-mod!-p(times!-mod!-p(cdr w,gamma),f1);
    gamma2:=remainder!-mod!-p(times!-mod!-p(car w,gamma),f2);
    i:=1; f1:=nil; f2:=nil;
    for each f in flist do
    << if i>k then f2:=f . f2
       else f1:=f . f1;
       i:=i+1 >>;
    return append(
      alphas(k,f1,gamma1),
      alphas(n-k,f2,gamma2))
  end;

symbolic procedure xgcd!-mod!-p(a,b,x1,y1,x2,y2);
% Finds alpha and beta s.t. alpha*a+beta*b=1.
% Returns alpha . beta or nil if a and b are not coprime.
    if null b then nil
    else if domainp b then begin
        b:=modular!-reciprocal b;
        x2:=multiply!-by!-constant!-mod!-p(x2,b);
        y2:=multiply!-by!-constant!-mod!-p(y2,b);
        return x2 . y2 end
    else begin scalar q;
        q:=quotient!-mod!-p(a,b); % Truncated quotient here.
        return xgcd!-mod!-p(b,difference!-mod!-p(a,times!-mod!-p(b,q)),
            x2,y2,
            difference!-mod!-p(x1,times!-mod!-p(x2,q)),
            difference!-mod!-p(y1,times!-mod!-p(y2,q)))
        end;

symbolic procedure hensel!-mod!-p(poly,mvec,fvec,cbd,vset,p);
% Hensel construction building up in powers of p.
% Given that poly=product(factors in factorvec) mod p, find the full
% factors over the integers.  Mvec contains the univariate factors mod p
% while fvec contains our best knowledge of the factors to date.
% Fvec includes leading coeffts (and in multivariate case possibly other
% coeffts) of the factors. return a list whose first element is a flag
% with one of the following values:
%  ok        construction worked, the cdr of the result is a list of
%            the correct factors.
%  failed    inputs must have been incorrect
%  overshot  factors are correct mod some power of p (say p**m),
%            but are not correct over the integers.
%            result is (overshot,p**m,list of factors so far).
  begin scalar w,u0,delfvec,old!.mod,res,m;
    u0:=initialize!-hensel(number!-of!-factors,p,poly,mvec,fvec,cbd);
            % u0 contains the product (over integers) of factors mod p.
    m := p;
    old!.mod := set!-modulus nil;
    if number!-of!-factors=1
      then <>;
            % only one factor to grow! but need to go this deep to
            % construct the alphas and set things up for the
            % multivariate growth which may follow.
    hensel!-msg1(p,u0);
    old!.mod:=set!-modulus p;
    res:=addf(hensel!-poly,negf u0);
            % calculate the residue. from now on this is always
            % kept in res.
    m:=p;
            % measure of how far we have built up factors - at this
            % stage we know the constant terms mod p in the factors.
   a: if polyzerop res then return hensel!-exit(m,old!.mod,p,vset,w);
      if (m/2)>coefftbd then
        <<
            % we started with a false split of the image so some
            % of the factors we have built up must amalgamate in
            % the complete factorization.
          if !*overshoot then <<
            prin2 if null vset then "Univariate " else "Multivariate ";
            prin2t "coefft bound overshoot" >>;
          if not !*overview then
        factor!-trace printstr "We have overshot the coefficient bound";
          return hensel!-exit(m,old!.mod,p,vset,'overshot)>>;
      res:=quotfail(res,deltam);
            % next term in residue.
      if not !*overview then factor!-trace <<
        prin2!* "Residue divided by "; prin2!* m; prin2!* " is ";
        printsf res >>;
      if (not !*linear) and null vset
        and m<=largest!-small!-modulus and m>p then
        quadratic!-step(m,number!-of!-factors);
      w:=reduce!-mod!-p res;
      if not !*overview then factor!-trace <<
          prin2!* "Next term in residue to kill is:";
          prinsf w; prin2!* " which is of size ";
          printsf (deltam*m);
          >>;
      solve!-for!-corrections(w,fhatvec,modfvec,delfvec,vset);
            % delfvec is vector of next correction terms to factors.
      make!-vec!-modular!-symmetric(delfvec,number!-of!-factors);
      if not !*overview then factor!-trace <<
        printstr "Correction terms are:";
        w:=1;
        for i:=1:number!-of!-factors do <<
          prin2!* "  To f("; prin2!* w; prin2!* "): ";
          printsf multf(m,getv(delfvec,i));
          w:=iadd1 w >>;
      >>;
      w:=terms!-done(factorvec,delfvec,m);
      res:=addf(res,negf w);
            % subtract out the terms generated by these corrections
            % from the residue.
      current!-factor!-product:=
         addf(current!-factor!-product,multf(m,w));
            % add in the correction terms to give new factor product.
      for i:=1:number!-of!-factors do
        putv(factorvec,i,
          addf(getv(factorvec,i),multf(getv(delfvec,i),m)));
            % add the corrections into the factors.
      if not !*overview then factor!-trace <<
        printstr "   giving new factors as:";
        w:=1;
        for i:=1:number!-of!-factors do <<
          prin2!* " f("; prin2!* w; prin2!* ")=";
          printsf getv(factorvec,i); w:=iadd1 w >>
        >>;
      m:=m*deltam;
      if not polyzerop res and null vset and
        not reconstructing!-gcd then
        begin scalar j,u,fac;
          j:=0;
          while (j:=j #+ 1)<=number!-of!-factors do
%            IF NULL GETV(DELFVEC,J) AND
            % - Try dividing out every time for now.
            if not didntgo
              (u:=quotf(hensel!-poly,fac:=getv(factorvec,j))) then <<
              hensel!-poly:=u;
              res:=adjust!-growth(fac,j,m);
              j:=number!-of!-factors >>
        end;
      go to a
  end;

symbolic procedure hensel!-exit(m,old!.mod,p,vset,w);
   begin
    if factors!-done then <<
      if not(w='overshot) then m:=p*p;
      set!-hensel!-fluids!-back p >>;
    if (not (w='overshot)) and null vset
      and (not !*linear) and multivariate!-input!-poly then
      while m>;
            % set up the alphas etc so that multivariate growth can
            % use a Hensel growth size of about word size.
    set!-modulus old!.mod;
            % reset the old modulus.
    hensel!-growth!-size:=deltam;
    putv(factorvec,0,number!-of!-factors);
    return
      if w='overshot then list('overshot,m,factorvec)
      else 'ok . factorvec
  end;

symbolic procedure hensel!-msg1(p,u0);
   begin scalar w;
    factor!-trace <<
      printstr
         "We are now ready to use the Hensel construction to grow";
      prin2!* "in powers of "; printstr current!-modulus;
      if not !*overview then <>;
      prin2!* "Initial factors mod "; prin2!* p;
      printstr " with some correct coefficients:";
      w:=1;
      for i:=1:number!-of!-factors do <<
        prin2!* " f("; prin2!* w; prin2!* ")=";
        printsf getv(factorvec,i); w:=iadd1 w >>;
      if not !*overview then << prin2!* "Coefficient bound = ";
        prin2!* coefftbd;
      terpri!*(nil);
      prin2!* "The product of factors over the integers is ";
      printsf u0;
      printstr "In each step below, the residue is U - (product of the";
      printstr
         "factors as far as we know them). The correction to each";
      printstr "factor, f(i), is (a(i)*v) mod f0(i) where f0(i) is";
      prin2!* "f(i) mod "; prin2!* p;
      printstr "(ie. the f(i) used in calculating the a(i))"
      >>>>
   end;

symbolic procedure initialize!-hensel(r,p,poly,mvec,fvec,cbd);
% Set up the vectors and initialize the fluids.
  begin scalar u0;
    delfvec:=mkvect r;
    facvec:=mkvect r;
    hensel!-poly:=poly;
    modfvec:=mvec;
    factorvec:=fvec;
    coefftbd:=cbd;
    factors!-done:=nil;
    deltam:=p;
    u0:=1;
    for i:=1:r do u0:=multf(getv(factorvec,i),u0);
    current!-factor!-product:=u0;
    return u0
  end;

% symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n);
%   begin scalar i,om,modf;
%     current!-factor!-product:=poly;
%     om:=set!-modulus hensel!-growth!-size;
%     i:=0;
%     for each fac in faclist do <<
%       putv(factorvec,i:=iadd1 i,fac);
%       putv(modfvec,i,modf:=reduce!-mod!-p fac);
%       putv(alphavec,i,cdr get!-alpha modf) >>;
%      for i:=1:n do <<
%        prin2 "F("; % prin2 i; % prin2 ") = ";
%        printsf getv(factorvec,i);
%        prin2 "F("; % prin2 i; % prin2 ") MOD P = ";
%        printsf getv(modfvec,i);
%        prin2 "A("; % prin2 i; % prin2 ") = ";
%        printsf getv(alphavec,i) >>;
%     set!-modulus om
%   end;

symbolic procedure reset!-quadratic!-step!-fluids(poly,faclist,n);
  begin scalar i,om,facpairlist,cfp!-mod!-p,fhatlist;
    current!-factor!-product:=poly;
    om:=set!-modulus hensel!-growth!-size;
    cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product;
    i:=0;
    facpairlist:=for each fac in faclist collect <<
      i:= i #+ 1;
      (fac . reduce!-mod!-p fac) >>;
    fhatlist:=for each facc in facpairlist collect
      quotfail!-mod!-p(cfp!-mod!-p,cdr facc);
    if factors!-done then alphalist:=
      find!-alphas!-in!-a!-ring(i,
        for each facpr in facpairlist collect cdr facpr,
        fhatlist,1);
          % a bug has surfaced such that the alphas get out of step.
          % In this case so recalculate them to stop the error for now.
    i:=0;
    for each facpair in facpairlist do <<
      putv(factorvec,i:=iadd1 i,car facpair);
      putv(modfvec,i,cdr facpair);
      putv(alphavec,i,cdr get!-alpha cdr facpair) >>;
%      for i:=1:n do <<
%        prin2 "f("; % prin2 i; % prin2 ") = ";
%        printsf getv(factorvec,i);
%        prin2 "f("; % prin2 i; % prin2 ") mod p = ";
%        printsf getv(modfvec,i);
%        prin2 "a("; % prin2 i; % prin2 ") = ";
%        printsf getv(alphavec,i) >>;
    set!-modulus om
  end;

symbolic procedure quadratic!-step(m,r);
% Code for adjusting the hensel variables to take quadratic steps in
% the growing process.
  begin scalar w,s,cfp!-mod!-p;
    set!-modulus m;
    cfp!-mod!-p:=reduce!-mod!-p current!-factor!-product;
    for i:=1:r do putv(facvec,i,reduce!-mod!-p getv(factorvec,i));
    for i:=1:r do putv(fhatvec,i,
      quotfail!-mod!-p(cfp!-mod!-p,getv(facvec,i)));
    w:=form!-sum!-and!-product!-mod!-m(alphavec,fhatvec,r);
    w:=!*mod2f plus!-mod!-p(1,minus!-mod!-p w);
    s:=quotfail(w,deltam);
    set!-modulus deltam;
    s:=!*f2mod s;
            % Boxes S up to look like a poly mod deltam.
    for i:=1:r do <<
      w:=remainder!-mod!-p(times!-mod!-p(s,getv(alphavec,i)),
        getv(modfvec,i));
      putv(alphavec,i,
        addf(!*mod2f getv(alphavec,i),multf(!*mod2f w,deltam))) >>;
    s:=modfvec;
    modfvec:=facvec;
    facvec:=s;
    deltam:=m;
            % this is our new growth rate.
    set!-modulus deltam;
    for i:=1:r do <<
      putv(facvec,i,"RUBBISH");
            % we will want to overwrite facvec next time so we
            % had better point it to the old (no longer needed)
            % modvec. Also mark it as containing rubbish for safety.
      putv(alphavec,i,!*f2mod getv(alphavec,i)) >>;
            % Make sure the alphas are boxed up as being mod new deltam.
    if not !*overview then factor!-trace <<
      printstr "The new modular polynomials are chosen such that:";
      terpri();
      prin2!* "   a(1)*h(1) + ... + a(";
      prin2!* r;
      prin2!* ")*h("; prin2!* r;
      prin2!* ") = 1 mod "; printstr m;
      terpri();
      printstr "  where h(i)=(product of all f(j) [see below])/f(i)";
      printstr "    and degree of a(i) < degree of f(i).";
      for i:=1:r do <<
        prin2!* "  a("; prin2!* i; prin2!* ")=";
        printsf getv(alphavec,i);
        prin2!* "   f("; prin2!* i; prin2!* ")=";
        printsf getv(modfvec,i) >>
    >>
  end;

symbolic procedure terms!-done(fvec,delfvec,m);
  begin scalar flist,delflist;
    for i:=1:number!-of!-factors do <<
      flist:=getv(fvec,i) . flist;
      delflist:=getv(delfvec,i) . delflist >>;
    return terms!.done(number!-of!-factors,flist,delflist,
                                 number!-of!-factors,m)
  end;

symbolic procedure terms!.done(n,flist,delflist,r,m);
  if n=1 then (car flist) . (car delflist)
  else begin scalar k,i,f1,f2,delf1,delf2;
    k:=n/2; i:=1;
    for each f in flist do
    << if i>k then f2:=(f . f2)
       else f1:=(f . f1);
       i:=i+1 >>;
    i:=1;
    for each delf in delflist do
    << if i>k then delf2:=(delf . delf2)
       else delf1:=(delf . delf1);
       i:=i+1 >>;
    f1:=terms!.done(k,f1,delf1,r,m);
    delf1:=cdr f1; f1:=car f1;
    f2:=terms!.done(n-k,f2,delf2,r,m);
    delf2:=cdr f2; f2:=car f2;
    delf1:=
      addf(addf(
        multf(f1,delf2),
        multf(f2,delf1)),
        multf(multf(delf1,m),delf2));
    if n=r then return delf1;
    return (multf(f1,f2) . delf1)
  end;

symbolic procedure try!.combining(l,poly,m,sofar);
  try!.combining1(l,poly,m,sofar,2);

% The following code is not optimal. If we find a combination of k
% factors, we will re-rty all the previous combinations of k factors
% already tried.
% This is not frightfully serious, since in practice most such
% combinations will have had something in common with the set found, and
% so won't re-appear.  This is definitely better than the previous
% version, which re-tried all combinations.  JHD 14.1.88.

symbolic procedure try!.combining1(l,poly,m,sofar,k);
% l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly
% but no f(i) divides poly over the integers.  We find the combinations
% of the f(i) that yield the true factors of poly over the integers.
% Sofar is a list of these factors found so far.
% start combining them K at a time
  if poly=1 then
    if null l then sofar
    else errorf(list("TOO MANY BAD FACTORS:",l))
  else begin scalar n,res,ff,v,w,w1,combined!.factors,ll,lcfinv,oldmod;
    n:=length l;
    if n=1 then
      if ldeg car l > (ldeg poly)/2 then
        return ('one! bad! factor . sofar)
      else errorf(list("ONE BAD FACTOR DOES NOT FIT:",l));
    if n=2 or n=3 then <<
      w:=lc cdar l; % The LC of all the factors is the same.
      while not (w=lc poly) do poly:=quotfail(poly,w);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors.
      if not !*overview then factor!-trace <<
        printstr "We combine:";
         for each lf in l do printsf cdr lf;
         prin2!* " mod "; prin2!* m;
         printstr " to give correct factor:";
         printsf poly >>;
       combine!.alphas(l,t);
       return (poly . sofar) >>;
    ll:=for each ff in l collect (cdr ff . car ff);
%    K := 2; % K is now an argument
    oldmod := set!-general!-modulus m;
    lcfinv := general!-modular!-reciprocal lc cdar l;
    set!-general!-modulus oldmod;
  loop1:
      if k > n/2 then go to exit;
      w:=koutof(k,if 2*k=n then cdr l else l,nil);
                   % We needn't try a combination and its complement
      while w and
            (v:=factor!-trialdiv(poly,car w,m,ll,lcfinv))='didntgo do
      << w:=cdr w;
        while w and
            ((car w = '!*lazyadjoin) or (car w = '!*lazykoutof)) do
          if car w= '!*lazyadjoin then
            w:=lazy!-adjoin(cadr w,caddr w,cadr cddr w)
          else w:=koutof(cadr w,caddr w,cadr cddr w)
        >>;
      if not(v='didntgo) then <<
        ff:=car v; v:=cdr v;
        if not !*overview then factor!-trace <<
          printstr "We combine:";
           for each a in car w do printsf a;
         prin2!* " mod "; prin2!* m;
         printstr " to give correct factor:";
         printsf ff >>;
       for each a in car w do <<
         w1:=l;
         while not (a = cdar w1) do w1:=cdr w1;
         combined!.factors:=car w1 . combined!.factors;
         l:=delete(car w1,l) >>;
       combine!.alphas(combined!.factors,t);
%      Now combine the rest, starting with k-tuples
       res:=try!.combining1(l,v,m,ff . sofar,k);
       go to exit>>;
    k := k + 1;
    go to loop1;
  exit:
    if res then return res
    else <<
      w:=lc cdar l; % The LC of all the factors is the same.
      while not (w=lc poly) do poly:=quotfail(poly,w);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors.
      if not !*overview then factor!-trace <<
        printstr "We combine:";
          for each ff in l do printsf cdr ff;
          prin2!* " mod "; prin2!* m;
          printstr " to give correct factor:";
          printsf poly >>;
      combine!.alphas(l,t);
      return (poly . sofar) >>
  end;

symbolic procedure koutof(k,l,sofar);
% Produces all permutations of length k from list l accumulating them
% in sofar as we go.  We use lazy evaluation in that this results in
% a permutation dotted with:
%   ( '!*lazy . (argument for eval) )
%  except when k=1 when the permutations are explicitly given.
  if k=1 then append(
    for each f in l collect list cdr f,sofar)
  else if k>length l then sofar
  else <<
    while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do
      if car l='!*lazyadjoin then
        l := lazy!-adjoin(cadr l,caddr l,cadr cddr l)
      else l := koutof(cadr l,caddr l,cadr cddr l);
    if k=length l then
      (for each ll in l collect cdr ll ) . sofar
    else koutof(k,cdr l,
      list('!*lazyadjoin,cdar l,
        list('!*lazykoutof,(k-1),cdr l,nil),
         sofar)) >>;

symbolic procedure lazy!-adjoin(item,l,tail);
% Dots item with each element in l using lazy evaluation on l.
% If l is null tail results.
 << while eqcar(l,'!*lazyadjoin) or eqcar(l,'!*lazykoutof) do
      if car l ='!*lazyadjoin then
        l:=lazy!-adjoin(cadr l,caddr l,cadr cddr l)
      else l:=koutof(cadr l,caddr l,cadr cddr l);
    if null l then tail
    else (item . car l) .
     if null cdr l then tail
     else list('!*lazyadjoin,item,cdr l,tail) >>;

symbolic procedure factor!-trialdiv(poly,flist,m,llist,lcfinv);
% Combines the factors in FLIST mod M and test divides the result
% into POLY (over integers) to see if it goes. If it doesn't
% then DIDNTGO is returned, else the pair (D . Q) is
% returned where Q is the quotient obtained and D is the product
% of the factors mod M;
% Abbott,J.A., Bradford,R.J. & Davenport,J.H.,
% A Remark on Factorisation.
% SIGSAM Bulletin 19(1985) 2, pp. 31-33, 37.
  if polyzerop poly then errorf "Test dividing into zero?"
  else begin scalar d,q,tcpoly,tcoeff,x,oldmod,w,poly1,try1;
    factor!-trace <<
      prin2!* "We combine factors ";
      for each ff in flist do <<
        w:=assoc(ff,llist);
        prin2!* "f(";
        prin2!* cdr w;
        prin2!* "), " >> ;
      prin2!* "and try dividing : " >>;
    x := mvar poly;
    tcpoly :=trailing!.coefft(poly,x);
    tcoeff := trailing!.coefft(car flist,x);
    oldmod := set!-general!-modulus m;
    for each fac in cdr flist do
      tcoeff := general!-modular!-times(
                  general!-modular!-times(tcoeff,lcfinv),
                                        trailing!.coefft(fac,x));
    if not zerop remainder(tcpoly,
              w:=general!-make!-modular!-symmetric tcoeff) then <<
      factor!-trace printstr " it didn't go (tc test)";
      set!-general!-modulus oldmod;
%      if not(w = trailing!.coefft(car COMBINE(FLIST,M,LLIST,lcfinv),x))
%             then <<
%         printstr "incompatibility: we have";
%         prin2!* w;
%         printstr "which should be the trailing coefficient of:";
%         prin2!* car combine(flist,m,llist,lcfinv) >>;
      return 'didntgo >>;
  % it has passed the tc test - now try evaluating at 1;
    poly1 := eval!-at!-1 poly;
    try1 := eval!-at!-1 car flist;
    for each fac in cdr flist do
      try1 := general!-modular!-times(
                general!-modular!-times(try1,lcfinv),eval!-at!-1 fac);
    if (zerop try1 and not zerop poly1) or
       not zerop remainder(poly1,general!-make!-modular!-symmetric try1)
         then <<
          factor!-trace printstr " it didn't go (test at 1)";
          set!-general!-modulus oldmod;
          return 'didntgo >>;
  % it has passed both tests - work out longhand;
    set!-general!-modulus oldmod;
    d:=combine(flist,m,llist,lcfinv);
    if didntgo(q:=quotf(poly,car d)) then <<
      factor!-trace printstr " it didn't go (division fail)";
      return 'didntgo >>
    else <<
      factor!-trace printstr " it worked !";
      return (car d . quotf(q,cdr d)) >>
  end;

symbolic procedure eval!-at!-1 f;
  % f a univariate standard form over Z with f(0) neq 0;
  % return the integer f(1);
  if atom f then f else (lc f) + eval!-at!-1(red f);

symbolic procedure combine(flist,m,l,lcfinv);
% Multiply factors in flist mod m.
% L is a list of the factors for use in FACTOR!-TRACE.
  begin scalar om,res,lcf,lcfprod;
    lcf := lc car flist; % all leading coeffts should be the same.
    lcfprod := 1;
% This is one of only two places in the entire factorizer where
% it is ever necessary to use a modulus larger than word-size.
    if m>largest!-small!-modulus then <<
      om:=set!-general!-modulus m;
%      lcfinv := general!-modular!-reciprocal lcf; Done once and for all
      res:=general!-reduce!-mod!-p car flist;
      for each ff in cdr flist do <<
        if not(lcf=lc ff) then errorf "BAD LC IN FLIST";
        res:=general!-times!-mod!-p(
            general!-times!-mod!-p(lcfinv,
                general!-reduce!-mod!-p ff),res);
        lcfprod := lcfprod*lcf >>;
      res:=general!-make!-modular!-symmetric res;
      set!-modulus om;
      return (res . lcfprod) >>
    else <<
      om:=set!-modulus m;
      lcfinv := modular!-reciprocal lcf;
      res:=reduce!-mod!-p car flist;
      for each ff in cdr flist do <<
        if not(lcf=lc ff) then errorf "BAD LC IN FLIST";
        res:=times!-mod!-p(times!-mod!-p(lcfinv,reduce!-mod!-p ff),res);
        lcfprod := lcfprod*lcf >>;
      res:=make!-modular!-symmetric res;
      set!-modulus om;
      return (res . lcfprod) >>
  end;

symbolic procedure combine!.alphas(flist,fixlcs);
% Combine the alphas associated with each of these factors to
% give the one alpha for their combination.
  begin scalar f1,a1,ff,aa,oldm,lcfac,lcfinv,saveflist;
    oldm:=set!-modulus hensel!-growth!-size;
    flist:=for each fac in flist collect <<
      saveflist:= (reduce!-mod!-p cdr fac) . saveflist;
      (car fac) . car saveflist >>;
    if fixlcs then <<
        lcfinv:=modular!-reciprocal lc cdar flist;
        lcfac:=modular!-expt(lc cdar flist,sub1 length flist)
      >>
      else << lcfinv:=1; lcfac:=1 >>;
            % If FIXLCS is set then we have combined n factors
            % (each with the same l.c.) to give one and we only need one
            % l.c. in the result, we have divided the combination by
            % lc**(n-1) and we must be sure to do the same for the
            % alphas.
    ff:=cdar flist;
    aa:=cdr get!-alpha ff;
    flist:=cdr flist;
    while flist do <<
      f1:=cdar flist;
      a1:=cdr get!-alpha f1;
      flist:=cdr flist;
      aa:=plus!-mod!-p(times!-mod!-p(aa,f1),times!-mod!-p(a1,ff));
      ff:=times!-mod!-p(ff,f1)
    >>;
    for each a in alphalist do
      if not member(car a,saveflist) then
        flist:=(car a . times!-mod!-p(cdr a,lcfac)) . flist;
    alphalist:=(quotient!-mod!-p(ff, lcfac) . aa) . flist;
    set!-modulus oldm
  end;

% The following code is for dividing out factors in the middle
% of the Hensel construction and adjusting all the associated
% variables that go with it.


symbolic procedure adjust!-growth(facdone,k,m);
% One factor (at least) divides out so we can reconfigure the
% problem for Hensel constrn giving a smaller growth and hopefully
% reducing the coefficient bound considerably.
  begin scalar w,u,bound!-scale,modflist,factorlist,fhatlist,
        modfdone,b;
    factorlist:=vec2list!-without!-k(factorvec,k);
    modflist:=vec2list!-without!-k(modfvec,k);
    fhatlist:=vec2list!-without!-k(fhatvec,k);
    w:=number!-of!-factors;
    modfdone:=getv(modfvec,k);
top:
    factors!-done:=facdone . factors!-done;
    if (number!-of!-factors:=number!-of!-factors #- 1)=1 then <<
      factors!-done:=hensel!-poly . factors!-done;
      number!-of!-factors:=0;
      hensel!-poly:=1;
      if not !*overview then factor!-trace <<
        printstr "    All factors found:";
        for each fd in factors!-done do printsf fd >>;
      return polyzero >>;
    fhatlist:=for each fhat in fhatlist collect
      quotfail!-mod!-p(if null fhat then polyzero else fhat,modfdone);
    u:=comfac facdone;  % Take contents and prim. parts.
    if car u then
      errorf(list("Factor divisible by main variable: ",facdone,car u));
    facdone:=quotfail(facdone,cdr u);
    bound!-scale:=cdr u;
    if not((b:=lc facdone)=1) then begin scalar b!-inv,old!-m;
      hensel!-poly:=quotfail(hensel!-poly,b**number!-of!-factors);
      b!-inv:=modular!-reciprocal modular!-number b;
      modflist:=for each modf in modflist collect
        times!-mod!-p(b!-inv,modf);
% This is one of only two places in the entire factorizer where
% it is ever necessary to use a modulus larger than word-size.
      if m>largest!-small!-modulus then <<
        old!-m:=set!-general!-modulus m;
        factorlist:=for each facc in factorlist collect
          adjoin!-term(lpow facc,quotfail(lc facc,b),
            general!-make!-modular!-symmetric(
              general!-times!-mod!-p(
            general!-modular!-reciprocal general!-modular!-number b,
                            general!-reduce!-mod!-p red facc))) >>
      else <<
        old!-m:=set!-modulus m;
        factorlist:=for each facc in factorlist collect
          adjoin!-term(lpow facc,quotfail(lc facc,b),
            make!-modular!-symmetric(
              times!-mod!-p(modular!-reciprocal modular!-number b,
                            reduce!-mod!-p red facc))) >>;
            % We must be careful not to destroy the information
            % that we have about the leading coefft.
      set!-modulus old!-m;
      fhatlist:=for each fhat in fhatlist collect
        times!-mod!-p(
          modular!-expt(b!-inv,number!-of!-factors #- 1),fhat)
    end;
try!-another!-factor:
    if (w:=w #- 1)>0 then
      if not didntgo
        (u:=quotf(hensel!-poly,facdone:=car factorlist)) then <<
        hensel!-poly:=u;
        factorlist:=cdr factorlist;
        modfdone:=car modflist;
        modflist:=cdr modflist;
        fhatlist:=cdr fhatlist;
        goto top >>
      else <<
        factorlist:=append(cdr factorlist,list car factorlist);
        modflist:=append(cdr modflist,list car modflist);
        fhatlist:=append(cdr fhatlist,list car fhatlist);
        goto try!-another!-factor >>;
    set!-fluids!-for!-newhensel(factorlist,fhatlist,modflist);
    bound!-scale:=
      bound!-scale * get!-coefft!-bound(
        quotfail(hensel!-poly,bound!-scale**(number!-of!-factors #- 1)),
        ldeg hensel!-poly);
    % We expect the new coefficient bound to be smaller, but on
    % dividing out a factor our polynomial's height may have grown
    % more than enough to compensate in the bound formula for
    % the drop in degree. Anyway, the bound we computed last time
    % will still be valid, so let's stick with the smaller.
    if bound!-scale < coefftbd then coefftbd := bound!-scale;
    w:=quotfail(addf(hensel!-poly,negf current!-factor!-product),
          m/deltam);
    if not !*overview then factor!-trace <<
      printstr "    Factors found to be correct:";
      for each fd in factors!-done do
        printsf fd;
      printstr "Remaining factors are:";
      printvec("    f(",number!-of!-factors,") = ",factorvec);
      prin2!* "New coefficient bound is "; printstr coefftbd;
      prin2!* " and the residue is now "; printsf w >>;
    return w
  end;

symbolic procedure vec2list!-without!-k(v,k);
% Turn a vector into a list leaving out Kth element.
  begin scalar w;
    for i:=1:number!-of!-factors do
      if not(i=k) then w:=getv(v,i) . w;
    return w
  end;

symbolic procedure set!-fluids!-for!-newhensel(flist,fhatlist,modflist);
<< current!-factor!-product:=1;
  alphalist:=
    find!-alphas!-in!-a!-ring(number!-of!-factors,modflist,fhatlist,1);
  for i:=number!-of!-factors step -1 until 1 do <<
    putv(factorvec,i,car flist);
    putv(modfvec,i,car modflist);
    putv(fhatvec,i,car fhatlist);
    putv(alphavec,i,cdr get!-alpha car modflist);
    current!-factor!-product:=multf(car flist,current!-factor!-product);
    flist:=cdr flist;
    modflist:=cdr modflist;
    fhatlist:=cdr fhatlist >>
>>;

symbolic procedure set!-hensel!-fluids!-back p;
% After the Hensel growth we must be careful to set back any fluids
% that have been changed when we divided out a factor in the middle
% of growing.  Since calculating the alphas involves modular division
% we cannot do it mod DELTAM which is generally a non-trivial power of
% P (prime). So we calculate them mod P and if necessary we can do a
% few quadratic growth steps later.
  begin scalar n,fd,modflist,fullf,modf;
    set!-modulus p;
    deltam:=p;
    n:=number!-of!-factors #+ length (fd:=factors!-done);
    current!-factor!-product:=hensel!-poly;
    for i:=(number!-of!-factors #+ 1):n do <<
      putv(factorvec,i,fullf:=car fd);
      putv(modfvec,i,modf:=reduce!-mod!-p fullf);
      current!-factor!-product:=multf(fullf,current!-factor!-product);
      modflist:=modf . modflist;
      fd:=cdr fd >>;
    for i:=1:number!-of!-factors do <<
      modf:=reduce!-mod!-p !*mod2f getv(modfvec,i);
            % need to 'unbox' a modpoly before reducing it mod p as we
            % know that the input modpoly is wrt a larger modulus
            % (otherwise this would be a stupid thing to do anyway!)
            % and so we are just pretending it is a full poly.
      modflist:=modf . modflist;
      putv(modfvec,i,modf) >>;
    alphalist:=alphas(n,modflist,1);
    for i:=1:n do putv(alphavec,i,cdr get!-alpha getv(modfvec,i));
    number!-of!-factors:=n
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/imageset.red0000644000175000017500000005161411526203062024263 0ustar  giovannigiovannimodule imageset;

% Authors: A. C. Norman and P. M. A. Moore, 1979;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*force!-prime
        !*force!-zero!-set
        !*trfac
        bad!-case
        chosen!-prime
        current!-modulus
        f!-numvec
        factor!-level
        factor!-trace!-list
        factor!-x
        factored!-lc
        forbidden!-primes
        forbidden!-sets
        image!-content
        image!-lc
        image!-mod!-p
        image!-poly
        image!-set
        image!-set!-modulus
        kord!*
        m!-image!-variable
        modulus!/2
        multivariate!-input!-poly
        no!-of!-primes!-to!-try
        othervars
        polyzero
        save!-zset
        usable!-set!-found
        vars!-to!-kill
        zero!-set!-tried
        zerovarset
        zset);


%*******************************************************************;
%
%      this section deals with the image sets used in
%      factorising multivariate polynomials according
%      to wang's theories.
%       ref:  math. comp. vol.32 no.144 oct 1978 pp 1217-1220
%        'an improved multivariate polynomial factoring algorithm'
%
%*******************************************************************;


%*******************************************************************;
%    first we have routines for generating the sets
%*******************************************************************;


symbolic procedure generate!-an!-image!-set!-with!-prime
                      good!-set!-needed;
% given a multivariate poly (in a fluid) we generate an image set
% to make it univariate and also a random prime to use in the
% modular factorization. these numbers are random except that
% we will not allow anything in forbidden!-sets or forbidden!-primes;
  begin scalar currently!-forbidden!-sets,u;
    u:=multivariate!-input!-poly;
            % a bit of a handful to type otherwise!!!!   ;
    image!-set:=nil;
    currently!-forbidden!-sets:=forbidden!-sets;
tryanotherset:
    if image!-set then
      currently!-forbidden!-sets:=image!-set .
                                currently!-forbidden!-sets;
%   wtime:=time();
    image!-set:=get!-new!-set currently!-forbidden!-sets;
%           princ "Trying imageset= ";
%           prin2t image!-set;
%   trace!-time <<
%     display!-time("    New image set found in ",time()-wtime);
%     wtime:=time() >>;
    image!-lc:=make!-image!-lc!-list(lc u,image!-set);
            % list of image lc's wrt different variables in IMAGE-SET;
%    princ "Image set to try is:";% prin2t image!-set;
%    prin2!* "L.C. of poly is:";% printsf lc u;
%    prin2t "Image l.c.s with variables substituted on order:";
%    for each imlc in image!-lc do printsf imlc;
%   trace!-time
%     display!-time("    Image of lc made in ",time()-wtime);
    if (caar image!-lc)=0 then goto tryanotherset;
%   wtime:=time();
    image!-poly:=make!-image(u,image!-set);
%   trace!-time <<
%     display!-time("    Image poly made in ",time()-wtime);
%     wtime:=time() >>;
    image!-content:=get!.content image!-poly;
            % note: the content contains the image variable if it
            % is a factor of the image poly;
%   trace!-time
%     display!-time("    Content found in ",time()-wtime);
    image!-poly:=quotfail(image!-poly,image!-content);
            % make sure the image polynomial is primitive which includes
            % making the leading coefft positive (-ve content if
            % necessary).
            % If the image polynomial was of the form k*v^2 where v is
            % the image variable then GET.CONTENT will have taken out
            % one v and the k leaving the polynomial v here.
            % Divisibility by v here thus indicates that the image was
            % not square free, and so we will not be able to find a
            % sensible prime to use.
    if not didntgo quotf(image!-poly,!*k2f m!-image!-variable) then
        go to tryanotherset;
%   wtime:=time();
    image!-mod!-p:=find!-a!-valid!-prime(image!-lc,image!-poly,
      not numberp image!-content);
    if image!-mod!-p='not!-square!-free then goto tryanotherset;
%   trace!-time <<
%     display!-time("    Prime and image mod p found in ",time()-wtime);
%     wtime:=time() >>;
    if factored!-lc then
      if f!-numvec:=unique!-f!-nos(factored!-lc,image!-content,
          image!-set) then usable!-set!-found:=t
%       trace!-time
%         display!-time("    Nos for lc found in ",time()-wtime) >>
      else <<
%       trace!-time display!-time("    Nos for lc failed in ",
%           time()-wtime);
        if (not usable!-set!-found) and good!-set!-needed then
          goto tryanotherset >>
  end;


symbolic procedure get!-new!-set forbidden!-s;
% associate each variable in vars-to-kill with a random no. mod
% image-set-modulus. If the boolean tagged with a variable is true then
% a value of 1 or 0 is no good and so rejected, however all other
% variables can take these values so they are tried exhaustively before
% using truly random values. sets in forbidden!-s not allowed;
  begin scalar old!.m,alist,n,nextzset,w;
    if zero!-set!-tried then <<
      if !*force!-zero!-set then
        errorf "Zero set tried - possibly it was invalid";
      image!-set!-modulus:=iadd1 image!-set!-modulus;
      old!.m:=set!-modulus image!-set!-modulus;
      alist:=for each v in vars!-to!-kill collect
      << n:=modular!-number next!-random!-number();
         if n>modulus!/2 then n:=n-current!-modulus;
         if cdr v then <<
           while n=0
              or n=1
              or (n = (isub1 current!-modulus)) do
             n:=modular!-number next!-random!-number();
           if n>modulus!/2 then n:=n-current!-modulus >>;
         car v . n >> >>
    else <<
      old!.m:=set!-modulus image!-set!-modulus;
      nextzset:=car zset;
      alist:=for each zv in zerovarset collect <<
        w:=zv . car nextzset;
        nextzset:=cdr nextzset;
        w >>;
      if othervars then alist:=
        append(alist,for each v in othervars collect <<
          n:=modular!-number next!-random!-number();
          while n=0
             or n=1
             or (n = (isub1 current!-modulus)) do
            n:=modular!-number next!-random!-number();
          if n>modulus!/2 then n:=n-current!-modulus;
          v . n >>);
      if null(zset:=cdr zset) then
        if null save!-zset then zero!-set!-tried:=t
        else zset:=make!-next!-zset save!-zset;
      alist:=for each v in cdr kord!* collect atsoc(v,alist);
            % Puts the variables in alist in the right order;
      >>;
    set!-modulus old!.m;
    return if member(alist,forbidden!-s) then
        get!-new!-set forbidden!-s
      else alist
  end;


%**********************************************************************
% now given an image/univariate polynomial find a suitable random prime;


symbolic procedure find!-a!-valid!-prime(lc!-u,u,factor!-x);
% finds a suitable random prime for reducing a poly mod p.
% u is the image/univariate poly. we are not allowed to use
% any of the primes in forbidden!-primes (fluid).
% lc!-u is either numeric or (in the multivariate case) a list of
% images of the lc;
  begin scalar currently!-forbidden!-primes,res,prime!-count,v,w;
    if factor!-x then u:=multf(u,v:=!*k2f m!-image!-variable);
    chosen!-prime:=nil;
    currently!-forbidden!-primes:=forbidden!-primes;
    prime!-count:=1;
tryanotherprime:
    if chosen!-prime then
      currently!-forbidden!-primes:=chosen!-prime .
                                 currently!-forbidden!-primes;
    chosen!-prime:=get!-new!-prime currently!-forbidden!-primes;
    set!-modulus chosen!-prime;
    if not atom lc!-u then <<
      w:=lc!-u;
      while w and
           ((domainp caar w and not(modular!-number caar w = 0))
              or not (domainp caar w or modular!-number lnc caar w=0))
            do w:=cdr w;
      if w then goto tryanotherprime >>
    else if modular!-number lc!-u=0 then goto tryanotherprime;
    res:=monic!-mod!-p reduce!-mod!-p u;
    if not square!-free!-mod!-p res then
      if multivariate!-input!-poly
         and (prime!-count:=prime!-count+1)>no!-of!-primes!-to!-try
        then <>;
          if onep q then <>
            % if q=1 here then we have failed the condition so exit;
          >>;
      if null lc!.image!.vec then i := k+1 else putv(d,i,q);
            % else q is the ith number we want;
   >>;
    return lc!.image!.vec
  end;

symbolic procedure get!.content u;
% u is a univariate square free poly. gets the content of u (=integer);
% if lc u is negative then the minus sign is pulled out as well;
% nb. the content includes the variable if it is a factor of u;
  begin scalar c;
    c:=if poly!-minusp u then -(numeric!-content u)
       else numeric!-content u;
    if not didntgo quotf(u,!*k2f m!-image!-variable) then
      c:=adjoin!-term(mksp(m!-image!-variable,1),c,polyzero);
    return c
  end;


%********************************************************************;
%    finally we have the routines that use the numbers generated
%    by unique.f.nos to determine the true leading coeffts in
%    the multivariate factorization we are doing and which image
%    factors will grow up to have which true leading coefft.
%********************************************************************;




symbolic procedure distribute!.lc(r,im!.factors,s,v);
% v is the factored lc of a poly, say u, whose image factors (r of
% them) are in the vector im.factors. s is a list containing the
% image information including the image set, the image poly etc.
%  this uses wang's ideas for distributing the factors in v over
% those in im.factors. result is (delta . vector of the lc's of
% the full factors of u) , where delta is the remaining integer part
% of the lc that we have been unable to distribute.             ;
  (lambda factor!-level;
  begin scalar k,delta,div!.count,q,uf,i,d,max!.mult,f,numvec,
               dvec,wvec,dtwid,w;
    delta:=get!-image!-content s;
            % the content of the u image poly;
    dist!.lc!.msg1(delta,im!.factors,r,s,v);
    v:=cdr v;
            % we are not interested in the numeric factors of v;
    k:=length v;
            % number of things to distribute;
    numvec:=get!-f!-numvec s;
            % nos. associated with factors in v;
    dvec:=mkvect r;
    wvec:=mkvect r;
    for j:=1:r do <<
      putv(dvec,j,1);
      putv(wvec,j,delta*lc getv(im!.factors,j)) >>;
            % result lc's will go into dvec which we initialize to 1's;
            % wvec is a work vector that we use in the division process
            % below;
    v:=reverse v;
    for j:=k step -1 until 1 do
    << % (for each factor in v, call it f(j) );
      f:=caar v;
            % f(j) itself;
      max!.mult:=cdar v;
            % multiplicity of f(j) in v (=lc u);
      v:=cdr v;
      d:=getv(numvec,j);
            % number associated with f(j);
      i:=1; % we trial divide d into lc of each image
            % factor starting with 1st;
      div!.count:=0;
            % no. of d's that have been distributed;
      factor!-trace <<
        prin2!* "f("; prin2!* j; prin2!* ")= "; printsf f;
        prin2!* "There are "; prin2!* max!.mult;
        printstr " of these in the leading coefficient.";
        prin2!* "The absolute value of the image of f("; prin2!* j;
        prin2!* ")= "; printstr d >>;
      while ilessp(div!.count,max!.mult)
        and not igreaterp(i,r) do
      << q:=divide(getv(wvec,i),d);
            % first trial division;
        factor!-trace <<
          prin2!* "  Trial divide into ";
          prin2!* getv(wvec,i); printstr " :" >>;
        while (zerop cdr q) and ilessp(div!.count,max!.mult) do
        << putv(dvec,i,multf(getv(dvec,i),f));
            % f(j) belongs in lc of ith factor;
          factor!-trace <<
            prin2!* "    It goes so an f("; prin2!* j;
            prin2!* ") belongs in ";
            printsf getv(im!.factors,i);
            printstr "  Try again..." >>;
          div!.count:=iadd1 div!.count;
            % another d done;
          putv(wvec,i,car q);
            % save the quotient for next factor to distribute;
          q:=divide(car q,d);
            % try again;
        >>;
        i:=iadd1 i;
            % as many d's as possible have gone into that
            % factor so now try next factor;
        factor!-trace
           <>>>;
            % at this point the whole of f(j) should have been
            % distributed by dividing d the maximum no. of times
            % (= max!.mult), otherwise we have an extraneous factor;
      if ilessp(div!.count,max!.mult) then
        <>
    >>;
    if bad!-case then return;
    dist!.lc!.msg2(dvec,im!.factors,r);
    if onep delta then
    << for j:=1:r do <<
         w:=lc getv(im!.factors,j) /
          evaluate!-in!-order(getv(dvec,j),get!-image!-set s);
         if w<0 then begin
           scalar oldpoly;
           delta:= -delta;
           oldpoly:=getv(im!.factors,j);
           putv(im!.factors,j,negf oldpoly);
            % to keep the leading coefficients positive we negate the
            % image factors when necessary;
           multiply!-alphas(-1,oldpoly,getv(im!.factors,j));
            % remember to fix the alphas as well;
         end;
         putv(dvec,j,multf(abs w,getv(dvec,j))) >>;
      dist!.lc!.msg3(dvec,im!.factors,r);
      return (delta . dvec)
    >>;
      % if delta=1 then we know the true lc's exactly so put in their
      % integer contents and return with result.
      % otherwise try spreading delta out over the factors:      ;
    dist!.lc!.msg4 delta;
    for j:=1:r do
    << dtwid:=evaluate!-in!-order(getv(dvec,j),get!-image!-set s);
       uf:=getv(im!.factors,j);
       d:=gcddd(lc uf,dtwid);
       putv(dvec,j,multf(lc uf/d,getv(dvec,j)));
       putv(im!.factors,j,multf(dtwid/d,uf));
            % have to fiddle the image factors by an integer multiple;
       multiply!-alphas!-recip(dtwid/d,uf,getv(im!.factors,j));
            % fix the alphas;
       delta:=delta/(dtwid/d)
    >>;
    % Now we've done all we can to distribute delta so we return with
    % what's left:
    if delta<=0 then <<
      factor!-trace <<
         prin2!* "FINAL DELTA IS -VE IN DISTRIBUTE!.LC";
         printstr delta >>;
      delta := 1 >>;
    factor!-trace <<
      printstr "     Finally we have:";
      for j:=1:r do <<
        prinsf getv(im!.factors,j);
        prin2!* " with l.c. ";
        printsf getv(dvec,j) >> >>;
    return (delta . dvec)
  end) (factor!-level * 10);

symbolic procedure dist!.lc!.msg1(delta,im!.factors,r,s,v);
    factor!-trace <<
      terpri(); terpri();
      printstr "We have a polynomial whose image factors (call";
      printstr "them the IM-factors) are:";
      prin2!* delta; printstr " (= numeric content, delta)";
      printvec(" f(",r,")= ",im!.factors);
      prin2!* "  wrt the image set: ";
      for each x in get!-image!-set s do <<
        prinvar car x; prin2!* "="; prin2!* cdr x; prin2!* ";" >>;
      terpri!*(nil);
      printstr "We also have its true multivariate leading";
      printstr "coefficient whose factors (call these the";
      printstr "LC-factors) are:";
      fac!-printfactors v;
      printstr "We want to determine how these LC-factors are";
      printstr "distributed over the leading coefficients of each";
      printstr "IM-factor.  This enables us to feed the resulting";
      printstr "image factors into a multivariate Hensel";
      printstr "construction.";
      printstr "We distribute each LC-factor in turn by dividing";
      printstr "its image into delta times the leading coefficient";
      printstr "of each IM-factor until it finds one that it";
      printstr "divides exactly. The image set is chosen such that";
      printstr "this will only happen for the IM-factors to which";
      printstr "this LC-factor belongs - (there may be more than";
      printstr "one if the LC-factor occurs several times in the";
      printstr "leading coefficient of the original polynomial).";
      printstr "This choice also requires that we distribute the";
      printstr "LC-factors in a specific order:"
      >>;

symbolic procedure dist!.lc!.msg2(dvec,im!.factors,r);
    factor!-trace <<
      printstr "The leading coefficients are now correct to within an";
      printstr "integer factor and are as follows:";
      for j:=1:r do <<
        prinsf getv(im!.factors,j);
        prin2!* " with l.c. ";
        printsf getv(dvec,j) >> >>;

symbolic procedure dist!.lc!.msg3(dvec,im!.factors,r);
      factor!-trace <<
        printstr "Since delta=1, we have no non-trivial content of the";
        printstr
          "image to deal with so we know the true leading coefficients";
        printstr
          "exactly.  We fix the signs of the IM-factors to match those";
        printstr "of their true leading coefficients:";
        for j:=1:r do <<
          prinsf getv(im!.factors,j);
          prin2!* " with l.c. ";
          printsf getv(dvec,j) >> >>;

symbolic procedure dist!.lc!.msg4 delta;
    factor!-trace <<
      prin2!* " Here delta is not 1 meaning that we have a content, ";
      printstr delta;
      printstr "of the image to distribute among the factors somehow.";
      printstr "For each IM-factor we can divide its leading";
      printstr "coefficient by the image of its determined leading";
      printstr "coefficient and see if there is a non-trivial result.";
      printstr "This will indicate a factor of delta belonging to this";
      printstr "IM-factor's leading coefficient." >>;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/ezgcd.red0000644000175000017500000000724011526203062023555 0ustar  giovannigiovannimodule ezgcd;  % Header module for ezgcd package.

% Authors: A. C. Norman and P. M. A. Moore.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(ezgcd alphas coeffts ezgcdf facmisc facstr interfac
                  linmodp mhensfns modpoly multihen unihens),
                '(factor));

fluid '(!*trallfac !*trfac factor!-level factor!-trace!-list);

factor!-level:=0;  % start with a numeric value.

symbolic procedure !*d2n a; if null a then 0 else a;

symbolic procedure adjoin!-term (p,c,r);
   if null c then r else (p .* c) .+ r;

symbolic smacro procedure ttab n; spaces(n-posn());

symbolic smacro procedure polyzerop u; null u;

symbolic smacro procedure didntgo q; null q;

symbolic smacro procedure depends!-on!-var(a,v);
  (lambda !#!#a; (not domainp !#!#a) and (mvar !#!#a=v)) a;

symbolic procedure errorf u;
   rerror(ezgcd,1,list("Factorizer error:",u));

smacro procedure printstr l; << prin2!* l; terpri!*(nil) >>;

smacro procedure printvar v; printstr v;

smacro procedure prinvar v; prin2!* v;

symbolic smacro procedure factor!-trace action;
   begin scalar stream;
      if !*trallfac or (!*trfac and factor!-level = 1)
        then stream := nil . nil
       else stream := assoc(factor!-level,factor!-trace!-list);
      if stream then <>
   end;

symbolic smacro procedure getm2(a,i,j);
   % Store by rows, to ease pivoting process.
   getv(getv(a,i),j);

symbolic smacro procedure putm2(a,i,j,v);
   putv(getv(a,i),j,v);

symbolic smacro procedure !*f2mod u; u;

symbolic smacro procedure !*mod2f u; u;

% A load of access smacros for image sets follow:

symbolic smacro procedure get!-image!-set s; car s;

symbolic smacro procedure get!-chosen!-prime s; cadr s;

symbolic smacro procedure get!-image!-lc s; caddr s;

symbolic smacro procedure get!-image!-mod!-p s; cadr cddr s;

symbolic smacro procedure get!-image!-content s; cadr cdr cddr s;

symbolic smacro procedure get!-image!-poly s; cadr cddr cddr s;

symbolic smacro procedure get!-f!-numvec s; cadr cddr cdddr s;

symbolic smacro procedure put!-image!-poly!-and!-content
   (s,imcont,impol);
  list(get!-image!-set s,
       get!-chosen!-prime s,
       get!-image!-lc s,
       get!-image!-mod!-p s,
       imcont,
       impol,
       get!-f!-numvec s);

symbolic procedure printvec(str1,n,str2,v);
<< for i:=1:n do <<
    prin2!* str1;
    prin2!* i;
    prin2!* str2;
    printsf getv(v,i) >>;
   terpri!*(nil) >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/factor.tst0000644000175000017500000001177311526203062024005 0ustar  giovannigiovannicomment factorizer test file;

array a(20);

factorize(x**2-1);   % To make sure factorizer is loaded.

algebraic procedure test(prob,nfac);
  begin integer m; scalar p,q,r;
    scalar basetime;
    p := for i:=1:nfac product a(i);
    Write "Problem number ",prob;
    symbolic (basetime := time());
    r := factorize p;
    symbolic (basetime := time() - basetime);
    q := for each j in r product first j^second j;
    m := for each j in r sum second j;
    if m=nfac and p=q then return ok;
    write "This example failed:";
    write r
  end;

% Wang test case 1;
 
a(1) := x*y+z+10$
a(2) := x*z+y+30$
a(3) := x+y*z+20$
test(1,3);
 
% Wang test case 2;

a(1) := x**3*z+x**3*y+z-11$
a(2) := x**2*z**2+x**2*y**2+y+90$
test(2,2);

 
% Wang test case 3;

a(1) := x**3*y**2+x*z**4+x+z$
a(2) := x**3+x*y*z+y**2+y*z**3$
test(3,2);

 
% Wang test case 4;

a(1) := x**2*z+y**4*z**2+5$
a(2) := x*y**3+z**2$
a(3) := -x**3*y+z**2+3$
a(4) := x**3*y**4+z**2$
test(4,4);

 
% Wang test case 5;
 
a(1) := 3*u**2*x**3*y**4*z+x*z**2+y**2*z**2+19*y**2$
a(2) := u**2*y**4*z**2+x**2*z+5$
a(3) := u**2+x**3*y**4+z**2$
test(5,3);

 
% Wang test case 6;
 
a(1) := w**4*x**5*y**6-w**4*z**3+w**2*x**3*y+x*y**2*z**2$
a(2) := w**4*z**6-w**3*x**3*y-w**2*x**2*y**2*z**2+x**5*z
           -x**4*y**2+y**2*z**3$
a(3) := -x**5*z**3+x**2*y**3+y*z$
test(6,3);

 
% Wang test case 7;

a(1) := x+y+z-2$
a(2) := x+y+z-2$
a(3) := x+y+z-3$
a(4) := x+y+z-3$
a(5) := x+y+z-3$
test(7,5);

 
% Wang test case 8;

a(1) := -z**31-w**12*z**20+y**18-y**14+x**2*y**2+x**21+w**2$
a(2) := -15*y**2*z**16+29*w**4*x**12*z**3+21*x**3*z**2+3*w**15*y**20$

% Commented out, since it can take a long time.

% TEST(8,2);
 
 
 
% Wang test case 9;
 
a(1) := 18*u**2*w**3*x*z**2+10*u**2*w*x*y**3+15*u*z**2+6*w**2*y**3*z**2$
a(2) := x$
a(3) := 25*u**2*w**3*y*z**4+32*u**2*w**4*y**4*z**3-
        48*u**2*x**2*y**3*z**3-2*u**2*w*x**2*y**2+44*u*w*x*y**4*z**4-
        8*u*w*x**3*z**4+4*w**2*x+11*w**2*x**3*y+12*y**3*z**2$
a(4) := z$
a(5) := z$
a(6) := u$
a(7) := u$
a(8) := u$
a(9) := u$
test(9,9);


 
% Wang test case 10;

a(1) := 31*u**2*x*z+35*w**2*y**2+40*w*x**2+6*x*y$
a(2) := 42*u**2*w**2*y**2+47*u**2*w**2*z+22*u**2*w**2+9*u**2*w*x**2+21
        *u**2*w*x*y*z+37*u**2*y**2*z+u**2*w**2*x*y**2*z**2+8*u**2*w**2
        *z**2+24*u**2*w*x*y**2*z**2+24*u**2*x**2*y*z**2+12*u**2*x*y**2
        *z**2+13*u*w**2*x**2*y**2+27*u*w**2*x**2*y+39*u*w*x*z+43*u*
        x**2*y+44*u*w**2* z**2+37*w**2*x*y+29*w**2*y**2+31*w**2*y*z**2
        +12*w*x**2*y*z+43*w*x*y*z**2+22*x*y**2+23*x*y*z+24*x*y+41*y**2
        *z$
test(10,2);

 
 
% Wang test case 11;

a(1) := -36*u**2*w**3*x*y*z**3-31*u**2*w**3*y**2+20*u**2*w**2*x**2*y**2
        *z**2-36*u**2*w*x*y**3*z+46*u**2*w*x+9*u**2*y**2-36*u*w**2*y**3
        +9*u*w*y**3-5*u*w*x**2*y**3+48*u*w*x**3*y**2*z+23*u*w*x**3*y**2
        -43*u*x**3*y**3*z**3-46*u*x**3*y**2+29*w**3*x*y**3*z**2-
        14*w**3*x**3*y**3*z**2-45*x**3-8*x*y**2$
a(2) := 13*u**3*w**2*x*y*z**3-4*u*x*y**2-w**3*z**3-47*x*y$
a(3) := x$
a(4) := y$
test(11,4);

 
 
 
% Wang test case 12; 
a(1) := x+y+z-3$
a(2) := x+y+z-3$
a(3) := x+y+z-3$
test(12,3);



 
% Wang test case 13;

a(1) := 2*w*z+45*x**3-9*y**3-y**2+3*z**3$
a(2) := w**2*z**3-w**2+47*x*y$
test(13,2);


 
 
% Wang test case 14;

a(1) := 18*x**4*y**5+41*x**4*y**2-37*x**4+26*x**3*y**4+38*x**2*y**4-29*
        x**2*y**3-22*y**5$
a(2) := 33*x**5*y**6-22*x**4+35*x**3*y+11*y**2$
test(14,2);

 
 
 
% Wang test case 15;

a(1) := 12*w**2*x*y*z**3-w**2*z**3+w**2-29*x-3*x*y**2$
a(2) := 14*w**2*y**2+2*w*z+18*x**3*y-8*x*y**2-y**2+3*z**3$
a(3) := z$
a(4) := z$
a(5) := y$
a(6) := y$
a(7) := y$
a(8) := x$
a(9) := x$
a(10) := x$
a(11) := x$
a(12) := x$
a(13) := x$
test(15,13);


% Test 16 - the 40th degree polynomial that comes from
% SIGSAM problem number 7;

a(1) := 8192*y**10+20480*y**9+58368*y**8-161792*y**7+198656*y**6+
        199680*y**5-414848*y**4-4160*y**3+171816*y**2-48556*y+469$
a(2) := 8192*y**10+12288*y**9+66560*y**8-22528*y**7-138240*y**6+
        572928*y**5-90496*y**4-356032*y**3+113032*y**2+23420*y-8179$
a(3) := 4096*y**10+8192*y**9+1600*y**8-20608*y**7+20032*y**6+87360*y**5-
        105904*y**4+18544*y**3+11888*y**2-3416*y+1$
a(4) := 4096*y**10+8192*y**9-3008*y**8-30848*y**7+21056*y**6+146496*
        y**5-221360*y**4+1232*y**3+144464*y**2-78488*y+11993$
test(16,4);

% Test 17 - taken from Erich Kaltofen's thesis. This polynomial
% splits mod all possible primes p;

a(1) := x**25-25*x**20-3500*x**15-57500*x**10+21875*x**5-3125$
test(17,1);

% Test 18 - another 'hard-to-factorize' univariate;

a(1) := x**18+9*x**17+45*x**16+126*x**15+189*x**14+27*x**13-
        540*x**12-1215*x**11+1377*x**10+15444*x**9+46899*x**8+
        90153*x**7+133893*x**6+125388*x**5+29160*x**4-
        32076*x**3+26244*x**2-8748*x+2916$
test(18,1);

% Test 19 - another example chosen to lead to false splits mod p;

a(1) := x**16+4*x**12-16*x**11+80*x**9+2*x**8+160*x**7+
        128*x**6-160*x**5+28*x**4-48*x**3+128*x**2-16*x+1$
a(2) := x**16+4*x**12+16*x**11-80*x**9+2*x**8-160*x**7+
        128*x**6+160*x**5+28*x**4+48*x**3+128*x**2+16*x+1$
test(19,2);

 
% End of all tests;
 
 
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/factor/modpoly.red0000644000175000017500000003354411526203062024152 0ustar  giovannigiovannimodule modpoly;   % Routines for performing arithmetic on multivariate
                  % polynomials with coefficients that are modular
                  % numbers as defined by modular!-plus etc.

% Authors: A. C. Norman and P. M. A. Moore, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(current!-modulus
        exact!-quotient!-flag
        m!-image!-variable
        modulus!/2
        reduction!-count);

% Note that the datastructure used is the same as that used in
% REDUCE except that it is assumed that domain elements are atomic.

symbolic smacro procedure comes!-before(p1,p2);
   % Similar to the REDUCE function ORDPP, but does not cater for non-
   % commutative terms and assumes that exponents are small integers.
    (car p1=car p2 and igreaterp(cdr p1,cdr p2)) or
       (not(car p1=car p2) and ordop(car p1,car p2));

symbolic procedure plus!-mod!-p(a,b);
   % form the sum of the two polynomials a and b working over the
   % ground domain defined by the routines % modular!-plus,
   % modular!-times etc. the inputs to this % routine are assumed to
   % have coefficients already in the required domain.
   if null a then b
   else if null b then a
   else if domainp a then
      if domainp b then !*n2f modular!-plus(a,b)
      else (lt b) .+ plus!-mod!-p(a,red b)
   else if domainp b then (lt a) .+ plus!-mod!-p(red a,b)
   else if lpow a = lpow b then
      adjoin!-term(lpow a,
         plus!-mod!-p(lc a,lc b),plus!-mod!-p(red a,red b))
   else if comes!-before(lpow a,lpow b) then
         (lt a) .+ plus!-mod!-p(red a,b)
   else (lt b) .+ plus!-mod!-p(a,red b);

symbolic procedure times!-mod!-p(a,b);
   if (null a) or (null b) then nil
   else if domainp a then multiply!-by!-constant!-mod!-p(b,a)
   else if domainp b then multiply!-by!-constant!-mod!-p(a,b)
   else if mvar a=mvar b then plus!-mod!-p(
     plus!-mod!-p(times!-term!-mod!-p(lt a,b),
                  times!-term!-mod!-p(lt b,red a)),
     times!-mod!-p(red a,red b))
   else if ordop(mvar a,mvar b) then
     adjoin!-term(lpow a,times!-mod!-p(lc a,b),times!-mod!-p(red a,b))
   else adjoin!-term(lpow b,
        times!-mod!-p(a,lc b),times!-mod!-p(a,red b));

symbolic procedure times!-term!-mod!-p(term,b);
   % Multiply the given polynomial by the given term.
    if null b then nil
    else if domainp b then
        adjoin!-term(tpow term,
            multiply!-by!-constant!-mod!-p(tc term,b),nil)
    else if tvar term=mvar b then
         adjoin!-term(mksp(tvar term,iplus2(tdeg term,ldeg b)),
                      times!-mod!-p(tc term,lc b),
                      times!-term!-mod!-p(term,red b))
    else if ordop(tvar term,mvar b) then
      adjoin!-term(tpow term,times!-mod!-p(tc term,b),nil)
    else adjoin!-term(lpow b,
      times!-term!-mod!-p(term,lc b),
      times!-term!-mod!-p(term,red b));

symbolic procedure difference!-mod!-p(a,b);
   plus!-mod!-p(a,minus!-mod!-p b);

symbolic procedure minus!-mod!-p a;
   if null a then nil
   else if domainp a then modular!-minus a
   else (lpow a .* minus!-mod!-p lc a) .+ minus!-mod!-p red a;


symbolic procedure reduce!-mod!-p a;
   % Converts a multivariate poly from normal into modular polynomial.
    if null a then nil
    else if domainp a then !*n2f modular!-number a
    else adjoin!-term(lpow a,reduce!-mod!-p lc a,reduce!-mod!-p red a);

symbolic procedure monic!-mod!-p a;
   % This procedure can only cope with polys that have a numeric
   % leading coeff.
   if a=nil then nil
   else if domainp a then 1
   else if lc a = 1 then a
   else if not domainp lc a then
       errorf "LC NOT NUMERIC IN MONIC-MOD-P"
   else multiply!-by!-constant!-mod!-p(a,
     modular!-reciprocal lc a);

symbolic procedure quotfail!-mod!-p(a,b);
   % Form quotient A/B, but complain if the division is not exact.
  begin scalar c;
    exact!-quotient!-flag:=t;
    c:=quotient!-mod!-p(a,b);
    if exact!-quotient!-flag then return c
    else errorf "QUOTIENT NOT EXACT (MOD P)"
  end;

symbolic procedure quotient!-mod!-p(a,b);
   % Truncated quotient of a by b.
    if null b then errorf "B=0 IN QUOTIENT-MOD-P"
    else if domainp b then begin
        scalar r;
        r := safe!-modular!-reciprocal b;
        if null b then return exact!-quotient!-flag:=nil
        else return multiply!-by!-constant!-mod!-p(a, r)
    end
    else if a=nil then nil
    else if domainp a then exact!-quotient!-flag:=nil
    else if mvar a=mvar b then xquotient!-mod!-p(a,b,mvar b)
    else if ordop(mvar a,mvar b) then
       adjoin!-term(lpow a,
          quotient!-mod!-p(lc a,b),
          quotient!-mod!-p(red a,b))
    else exact!-quotient!-flag:=nil;


symbolic procedure xquotient!-mod!-p(a,b,v);
   % Truncated quotient a/b given that b is nontrivial.
    if a=nil then nil
    else if (domainp a) or (not(mvar a=v)) or
      ilessp(ldeg a,ldeg b) then exact!-quotient!-flag:=nil
    else if ldeg a = ldeg b then begin scalar w;
      w:=quotient!-mod!-p(lc a,lc b);
      if w = nil or
         difference!-mod!-p(a,times!-mod!-p(w,b)) then
        exact!-quotient!-flag:=nil;
      return w
      end
    else begin scalar term;
      term:=mksp(mvar a,idifference(ldeg a,ldeg b)) .*
        quotient!-mod!-p(lc a,lc b);
   % That is the leading term of the quotient.  Now subtract term*b from
   % a.
      a:=plus!-mod!-p(red a,
                      times!-term!-mod!-p(negate!-term term,red b));
   % or a:=a-b*term given leading terms must cancel.
      return term .+ xquotient!-mod!-p(a,b,v)
    end;

symbolic procedure negate!-term term;
   % Negate a term.
    tpow term .* minus!-mod!-p tc term;


symbolic procedure remainder!-mod!-p(a,b);
   % Remainder when a is divided by b.
    if null b then errorf "B=0 IN REMAINDER-MOD-P"
    else if domainp b then nil
    else if domainp a then a
    else xremainder!-mod!-p(a,b,mvar b);


symbolic procedure xremainder!-mod!-p(a,b,v);
   % Remainder when the modular polynomial a is divided by b, given that
   % b is non degenerate.
   if (domainp a) or (not(mvar a=v)) or ilessp(ldeg a,ldeg b) then a
   else begin
    scalar q,w;
    q:=quotient!-mod!-p(minus!-mod!-p lc a,lc b);
   % compute -lc of quotient.
    w:=idifference(ldeg a,ldeg b); %ldeg of quotient;
    if w=0 then a:=plus!-mod!-p(red a,
      multiply!-by!-constant!-mod!-p(red b,q))
    else
      a:=plus!-mod!-p(red a,times!-term!-mod!-p(
            mksp(mvar b,w) .* q,red b));
   % The above lines of code use red a and red b because by construc-
   % tion the leading terms of the required % answers will cancel out.
     return xremainder!-mod!-p(a,b,v)
   end;

symbolic procedure multiply!-by!-constant!-mod!-p(a,n);
   % Multiply the polynomial a by the constant n.
   if null a then nil
   else if n=1 then a
   else if domainp a then !*n2f modular!-times(a,n)
   else adjoin!-term(lpow a,multiply!-by!-constant!-mod!-p(lc a,n),
     multiply!-by!-constant!-mod!-p(red a,n));

symbolic procedure gcd!-mod!-p(a,b);
   % Return the monic gcd of the two modular univariate polynomials a
   % and b.  Set REDUCTION-COUNT to the number of steps taken in the
   % process.
 << reduction!-count := 0;
    if null a then monic!-mod!-p b
    else if null b then monic!-mod!-p a
    else if domainp a then 1
    else if domainp b then 1
    else if igreaterp(ldeg a,ldeg b) then
      ordered!-gcd!-mod!-p(a,b)
    else ordered!-gcd!-mod!-p(b,a) >>;

symbolic procedure ordered!-gcd!-mod!-p(a,b);
   % As above, but deg a > deg b.
  begin scalar steps;
    steps := 0;
top:
    a := reduce!-degree!-mod!-p(a,b);
    if null a then return monic!-mod!-p b;
    steps := steps + 1;
    if domainp a then <<
        reduction!-count := reduction!-count+steps;
        return 1 >>
    else if ldeg a>
    else begin scalar newdeg;
      newdeg:=ldeg a;
      return horner!-rule!-mod!-p(if null n or zerop n then lc a
                                   else plus!-mod!-p(lc a,
         times!-mod!-p(v,expt!-mod!-p(n,idifference(degg,newdeg)))),
       newdeg,red a,n,var)
    end;

symbolic procedure expt!-mod!-p(a,n);
   % a**n.
    if n=0 then 1
    else if n=1 then a
    else begin scalar w,x;
     w:=divide(n,2);
     x:=expt!-mod!-p(a,car w);
     x:=times!-mod!-p(x,x);
     if not (cdr w = 0) then x:=times!-mod!-p(x,a);
     return x
    end;

symbolic procedure make!-bivariate!-mod!-p(u,imset,v);
   % Substitute into U for all variables in IMSET which should result in
   % a bivariate poly. One variable is M-IMAGE-VARIABLE and V is the
   % other U is modular multivariate with these two variables at top 2
   % levels - V at 2nd level.
  if domainp u then u
  else if mvar u = m!-image!-variable then
    adjoin!-term(lpow u,make!-univariate!-mod!-p(lc u,imset,v),
      make!-bivariate!-mod!-p(red u,imset,v))
  else make!-univariate!-mod!-p(u,imset,v);

symbolic procedure make!-univariate!-mod!-p(u,imset,v);
   % Substitute into U for all variables in IMSET giving a univariate
   % poly in V. U is modular multivariate with V at top level.
  if domainp u then u
  else if mvar u = v then
    adjoin!-term(lpow u,!*n2f evaluate!-in!-order!-mod!-p(lc u,imset),
      make!-univariate!-mod!-p(red u,imset,v))
  else !*n2f evaluate!-in!-order!-mod!-p(u,imset);

symbolic procedure evaluate!-in!-order!-mod!-p(u,imset);
   % Makes an image of u wrt imageset, imset, using Horner's rule.
   % Result should be purely numeric (and modular).
  if domainp u then !*d2n u
   else if mvar u=caar imset then
    horner!-rule!-in!-order!-mod!-p(
      evaluate!-in!-order!-mod!-p(lc u,cdr imset),ldeg u,red u,imset)
   else evaluate!-in!-order!-mod!-p(u,cdr imset);

symbolic procedure horner!-rule!-in!-order!-mod!-p(c,degg,a,vset);
   % C is running total and a is what is left.
  if domainp a then modular!-plus(!*d2n a,
    modular!-times(c,modular!-expt(cdar vset,degg)))
  else if not(mvar a=caar vset) then
    modular!-plus(
      evaluate!-in!-order!-mod!-p(a,cdr vset),
      modular!-times(c,modular!-expt(cdar vset,degg)))
  else begin scalar newdeg;
    newdeg:=ldeg a;
    return horner!-rule!-in!-order!-mod!-p(
      modular!-plus(
        evaluate!-in!-order!-mod!-p(lc a,cdr vset),
        modular!-times(c,
          modular!-expt(cdar vset,(idifference(degg,newdeg))))),
      newdeg,red a,vset)
  end;

symbolic procedure make!-modular!-symmetric a;
   % Input is a multivariate MODULAR poly A with nos in range 0->(p-1).
   % This folds it onto the symmetric range (-p/2)->(p/2).
    if null a then nil
    else if domainp a then
      if a>modulus!/2 then !*n2f(a - current!-modulus)
      else a
    else adjoin!-term(lpow a,make!-modular!-symmetric lc a,
      make!-modular!-symmetric red a);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/0000755000175000017500000000000011722677362021601 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/camal/makefour.red0000644000175000017500000002016411526203062024071 0ustar  giovannigiovannimodule makefour;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% User interface; all rather iffy at present

symbolic procedure harmonicp u; get(u, 'fourier!-angle);

symbolic procedure harmonic u;
<<
    for each x in u do if not(get(x, 'fourier!-angle)) then <<
        if (next!-angle!* > 7) then rerror(fourier,3,"Too many angles");
        put(x, 'fourier!-angle, next!-angle!*);
        putv!.unsafe(fourier!-name!*, next!-angle!*, x);
        next!-angle!* := next!-angle!* #+ 1;
      >>
>>;

put('harmonic, 'stat, 'rlis);

symbolic procedure simpfourier u;
%% Handle the form fourier(...)  with treating sin and cos as special
begin
  if not(length u = 1) then
        rerror(fourier,1,"Argument should be single expression");
  return simpfourier1 prepsq simp!* car u;;
end;

symbolic procedure simpfourier1 u;
begin scalar ff;
  if atom u then <<
        if harmonicp u
          then rerror(fourier,2,"Secular angle not allowed");
        return (!*sq2fourier simp u) . 1;
  >>
  else if eqcar(u, '!:fs!:) then return u
  else if (ff := get(car u, 'simpfour)) then return apply1(ff, cdr u)
  else <<
    rerror(fourier,4,"Unknown function" . car u);
    return (!*sq2fourier u) . 1;
  >>
end;

put('fourier, 'simpfn, 'simpfourier);

symbolic procedure simpfouriersin u;
% Creation of a simple angle expression and function
begin scalar ans, vv;
  u := car u;
  if atom u then
        if harmonicp u then <<
              ans:=mkvect 3;
              fs!:set!-coeff(ans,(1 . 1));
              fs!:set!-fn(ans,'sin);
              vv := mkvect 7;
              for i:=0:7 do putv!.unsafe(vv,i,0);
              putv!.unsafe(vv, get(u, 'fourier!-angle), 1);
              fs!:set!-angle(ans,vv);
              fs!:set!-next(ans,nil);
              return (get('fourier,'tag) . ans) . 1 >>
        else return !*sq2fourier(simp list('sin, u)) . 1;
  if angle!-expression!-p u then <<
      ans:=mkvect 3;
      fs!:set!-coeff(ans,(1 . 1));
      fs!:set!-fn(ans,'sin);
      vv := mkvect 7;
      for i:=0:7 do putv!.unsafe(vv,i,0);
      compile!-angle!-expression(u,vv);
      fs!:set!-angle(ans,vv);
      fs!:set!-next(ans,nil);
      return (get('fourier,'tag) . ans) . 1 >>;
  rerror(fourier,99,"Not finished yet");
end;

put('sin, 'simpfour, 'simpfouriersin);

symbolic procedure simpfouriercos u;
% Creation of a simple angle expression and function
begin scalar ans, vv;
  u := car u;
  if atom u then
        if harmonicp u then <<
              ans:=mkvect 3;
              fs!:set!-coeff(ans,(1 . 1));
              fs!:set!-fn(ans,'cos);
              vv := mkvect 7;
              for i:=0:7 do putv!.unsafe(vv,i,0);
              putv!.unsafe(vv, get(u, 'fourier!-angle), 1);
              fs!:set!-angle(ans,vv);
              fs!:set!-next(ans,nil);
              return (get('fourier,'tag) . ans) . 1 >>
        else return !*sq2fourier(simp list('cos, u)) . 1;
  if angle!-expression!-p u then <<
      ans:=mkvect 3;
      fs!:set!-coeff(ans,(1 . 1));
      fs!:set!-fn(ans,'cos);
      vv := mkvect 7;
      for i:=0:7 do putv!.unsafe(vv,i,0);
      compile!-angle!-expression(u,vv);
      fs!:set!-angle(ans,vv);
      fs!:set!-next(ans,nil);
      return (get('fourier,'tag) . ans) . 1 >>;
  rerror(fourier,99,"Not finished yet");
end;

put('cos, 'simpfour, 'simpfouriercos);

%% Is the prefix expression u a sum of angles??

symbolic procedure angle!-expression!-p u;
if atom u and harmonicp u then t
else if eqcar(u,'plus) or eqcar(u,'difference) then
    angle!-expression!-p cadr u and angle!-expression!-p caddr u
else if eqcar(u,'minus) then angle!-expression!-p cadr u
else if eqcar(u,'times) then
  if numberp cadr u then angle!-expression!-p caddr u
  else angle!-expression!-p cadr u and numberp caddr u
else nil;

%% We know that u is a sum of angles, so create vector of coefficients.

symbolic procedure compile!-angle!-expression(u,v);
if atom u and harmonicp u then
    putv!.unsafe(v, get(u, 'fourier!-angle),
                 1+getv!.unsafe(v, get(u, 'fourier!-angle)))
else if eqcar(u,'plus) then <<
        u := cdr u;
        while u do <<
            compile!-angle!-expression(car u,v);
            u := cdr u
        >>;
        v  >>
else if eqcar(u,'difference) then begin scalar vv;
    compile!-angle!-expression(cadr u,v);
    vv := mkvect 7;
    for i:=0:7 do putv!.unsafe(vv,i,0);
    compile!-angle!-expression(caddr u,vv);
    for i:=0:7 do putv!.unsafe(v,i,getv!.unsafe(v,i)
                                   - getv!.unsafe(vv,i));
    return v
  end
else if eqcar(u,'minus) then
  begin scalar vv;
        vv := mkvect 7;
        for i:=0:7 do putv!.unsafe(vv,i,0);
        compile!-angle!-expression(cadr u,vv);
        for i:=0:7 do putv!.unsafe(v,i,getv!.unsafe(v,i)
                                       - getv!.unsafe(vv,i));
        return v;
  end
else if eqcar(u,'times) then
  if numberp cadr u then begin scalar vv;
      vv := mkvect 7;
      for i:=0:7 do putv!.unsafe(vv,i,0);
      compile!-angle!-expression(caddr u,vv);
      for i:=0:7 do putv!.unsafe(v, i,
                        cadr u*getv!.unsafe(vv, i) + getv!.unsafe(v,i))
  end
  else begin scalar vv;
      vv := mkvect 7;
      for i:=0:7 do putv!.unsafe(vv,i,0);
      compile!-angle!-expression(cadr u,vv);
      for i:=0:7 do putv!.unsafe(v, i,
                      caddr u * getv!.unsafe(vv, i) + getv!.unsafe(v,i))
  end
else nil;

symbolic procedure simpfouriertimes(u);
begin scalar z;
     z := car simpfourier1 car u;
     u := cdr u;
  a: if null u then return z ./ 1;
     z := fs!:times!:(car simpfourier1 car u,z);
     u := cdr u;
     go to a
   end;

put('times, 'simpfour, 'simpfouriertimes);

symbolic procedure simpfourierexpt(u);
  fs!:expt!:(car simpfourier1 car u, cadr u) . 1;

put('expt, 'simpfour, 'simpfourierexpt);

symbolic procedure simpfourierplus(u);
begin scalar z;
     z := car simpfourier1 car u;
     u := cdr u;
  a: if null u then return z ./ 1;
     z := fs!:plus!:(car simpfourier1 car u,z);
     u := cdr u;
     go to a
   end;

put('plus, 'simpfour, 'simpfourierplus);

symbolic procedure simpfourierdifference(u);
  fs!:difference!:(car simpfourier1 car u, car simpfourier1 cadr u)
     ./ 1;

put('difference, 'simpfour, 'simpfourierdifference);

symbolic procedure simpfourierminus(u);
  fs!:negate!:(car simpfourier1 car u) . 1;

put('minus, 'simpfour, 'simpfourierminus);

symbolic procedure simpfourierquot(u);
begin scalar v;
  v := simp!* cadr u;
  v := cdr v . car v;
  return fs!:times!:(car simpfourier1 car u, !*sq2fourier v) ./ 1
end;

put('quotient, 'simpfour, 'simpfourierquot);

symbolic procedure simphsin u;
begin
  if not(length u = 1) then
        rerror(fourier,5,"Argument should be single expression");
  return simpfouriersin list(u := prepsq simp!* car u)
end;

put('hsin, 'simpfn, 'simphsin);

symbolic procedure simphcos u;
begin
  if not(length u = 1) then
        rerror(fourier,6,"Argument should be single expression");
  return simpfouriercos list(u := prepsq simp!* car u)
end;

put('hcos, 'simpfn, 'simphcos);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/fourdom.red0000644000175000017500000002314611526203062023736 0ustar  giovannigiovannimodule fourdom; % Domain definitions for angles and fourier series

% Author: John Fitch 1991.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(domainlist!*);

domainlist!*:=union('(!:fs!:),domainlist!*);

put('fourier,'tag,'!:fs!:);
put('!:fs!:,'dname,'fourier);
flag('(!:fs!:),'field); %% Should be ring really
put('!:fs!:,'i2d,'i2fourier);
put('!:fs!:,'minusp,'fs!:minusp!:);
put('!:fs!:,'plus,'fs!:plus!:);
put('!:fs!:,'times,'fs!:times!:);
put('!:fs!:, 'expt,'fs!:expt!:);
put('!:fs!:,'difference,'fs!:difference!:);
put('!:fs!:,'quotient,'fs!:quotient!:);
put('!:fs!:, 'divide, 'fs!:divide!:);
put('!:fs!:, 'gcd, 'fs!:gcd!:);
put('!:fs!:,'zerop,'fs!:zerop!:);
put('!:fs!:,'onep,'fs!:onep!:);
put('!:fs!:,'prepfn,'fs!:prepfn!:);
put('!:fs!:,'specprn,'fs!:prin!:);
put('!:fs!:,'prifn,'fs!:prin!:);
put('!:fs!:,'intequivfn,'fs!:intequiv!:);
flag('(!:fs!:),'ratmode);
% conversion functions

put('!:fs!:,'!:mod!:,mkdmoderr('!:fs!:,'!:mod!:));
% put('!:fs!:,'!:gi!:,mkdmoderr('!:fs!:,'!:gi!:));
% put('!:fs!:,'!:rn!:,mkdmoderr('!:fs!:,'!:rn!:));
put('!:rn!:,'!:fs!:,'!*d2fourier);
put('!:ft!:,'!:fs!:,'cdr);
put('!:gi!:,'!:fs!:,'!*d2fourier);
put('!:gf!:,'!:fs!:,'!*d2fourier);

put('expt, '!:fs!:, 'fs!:expt!:);

% Conversion functions

symbolic procedure i2fourier u;
  if dmode!*='!:fs!: then !*d2fourier u else u;

symbolic procedure !*d2fourier u;
if null u then nil else
begin scalar fourier;
      fourier:=mkvect 3;
      fs!:set!-coeff(fourier,(u . 1));
      fs!:set!-fn(fourier,'cos);
      fs!:set!-angle(fourier,fs!:make!-nullangle());
      fs!:set!-next(fourier,nil);
     return get('fourier,'tag) . fourier
end;

symbolic procedure !*sq2fourier u;
if null car u then nil else
begin scalar fourier;
      fourier:=mkvect 3;
      fs!:set!-coeff(fourier,u);
      fs!:set!-fn(fourier,'cos);
      fs!:set!-angle(fourier,fs!:make!-nullangle());
      fs!:set!-next(fourier,nil);
     return get('fourier,'tag) . fourier
end;

symbolic procedure fs!:minusp!:(x); fs!:minusp cdr x;

symbolic procedure fs!:minusp x;
if null x then nil else
   if null fs!:next x then minusf car fs!:coeff x
   else fs!:minusp fs!:next x;

%% Basic algebraic operations

symbolic procedure fs!:times!:(x,y);
% This function seems to be called with numeric values as well
   if null x then nil else if null y then nil
   else if numberp y
    then get('fourier,'tag) . fs!:timescoeff(y ./ 1, cdr x)
   else if numberp x
    then get('fourier,'tag) . fs!:timescoeff(x ./ 1, cdr y)
   else if not eqcar(x, get('fourier,'tag)) then
        get('fourier,'tag) . fs!:timescoeff(x,cdr y)
   else if not eqcar(y, get('fourier,'tag)) then
        get('fourier,'tag) . fs!:timescoeff(y,cdr x)
   else get('fourier,'tag) . fs!:times(cdr x, cdr y);

symbolic procedure fs!:timescoeff(x, y);
if null y then nil
   else begin scalar ans, coeff;
      coeff := multsq(x,fs!:coeff y);
      if coeff = '(nil . 1) then <<
        print "zero in times";
        return fs!:timescoeff(x, fs!:next y) >>;
      ans := mkvect 3;
      fs!:set!-coeff(ans,coeff);
      fs!:set!-fn(ans,fs!:fn y);
      fs!:set!-angle(ans,fs!:angle y);
      fs!:set!-next(ans, fs!:timescoeff(x, fs!:next y));
      return ans
   end;

symbolic procedure fs!:times(x,y);
if null x then nil else if null y then nil else
begin scalar ans;
        ans := fs!:timesterm(x, y);
        return fs!:plus(ans, fs!:times(fs!:next  x, y));
end;

symbolic procedure fs!:timesterm(x,y);
% Treat x as a term and y as a tree
if null y then nil else if null x then nil else
begin scalar ans;
        ans := fs!:timestermterm(x,y);
        return fs!:plus(ans, fs!:timesterm(x, fs!:next y));
end;

symbolic procedure fs!:timestermterm(x,y);
% x and y are terms.  Generate the two answer terms.
begin scalar sum, diff, ans, xv, yv, coeff;
        sum := mkvect 7;
        xv := fs!:angle x;
        yv := fs!:angle y;
        for i:=0:7 do putv!.unsafe(sum,i,
                                 getv!.unsafe(xv,i)+getv!.unsafe(yv,i));
        diff := mkvect 7;
        for i:=0:7 do putv!.unsafe(diff,i,
                                 getv!.unsafe(xv,i)-getv!.unsafe(yv,i));
        coeff := multsq(fs!:coeff x, fs!:coeff y);
        coeff := multsq(coeff, '(1 . 2));
        if null car coeff then return nil;
        if fs!:fn x = 'sin then
            if fs!:fn y = 'sin then
                % sin x*sin y => [-cos(x+y)+cos(x-y)]/2
                return fs!:plus(make!-term('cos, sum, negsq coeff),
                                make!-term('cos,diff, coeff))
            else % fs!:fn y = 'cos
                % sin x * cos y => [sin(x+y)+sin(x-y)]/2
                return fs!:plus(make!-term('sin, sum, coeff),
                                make!-term('sin, diff,coeff))
        else % fs!:fn x='cos
            if fs!:fn y = 'sin then
                % cos x*sin y => [sin(x+y)-sin(x-y)]/2
                return fs!:plus(make!-term('sin, sum, coeff),
                                make!-term('sin,diff, negsq coeff))
            else % fs!:fn y = 'cos
                % cos x * cos y => [cos(x+y)+cos(x-y)]/2
                return fs!:plus(make!-term('cos, sum, coeff),
                                make!-term('cos, diff,coeff))

end;

symbolic procedure fs!:expt!:(x,n);
begin scalar ans, xx;
    ans := cdr !*d2fourier 1;
    x := cdr x;
    for i:=1:n do ans := fs!:times(ans,x);
    return get('fourier,'tag) . ans;
end;

symbolic procedure make!-term(fn, ang, coeff);
begin scalar fourier, sign, i;
      sign := 0;
      i:=0;
top:  if getv!.unsafe(ang,i)<0 then sign := -1
      else if getv!.unsafe(ang,i)>0 then sign := 1
      else if i=7 then <<
        if fn ='sin then return nil >>
      else << i := i #+ 1; goto top >>;
      fourier:=mkvect 3;
      if sign = 1 or fn = 'cos then fs!:set!-coeff(fourier,coeff)
      else fs!:set!-coeff(fourier, multsq('(-1 . 1), coeff));
      fs!:set!-fn(fourier,fn);
      if sign = -1 then << sign := mkvect 7;
        for i:=0:7 do putv!.unsafe(sign,i,-getv!.unsafe(ang,i));
        ang := sign
      >>;
      fs!:set!-angle(fourier,ang);
      fs!:set!-next(fourier,nil);
     return fourier
end;

symbolic procedure fs!:quotient!:(x,y);
if numberp y then fs!:times!:(x, !*sq2fourier (1 ./ y))
else rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:divide!:(x,y);
rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:gcd!:(x,y);
rerror(fourier, 98, "Unimplemented");

symbolic procedure fs!:difference!:(x,y);
   fs!:plus!:(x, fs!:negate!: y);

symbolic procedure fs!:negate!: x;
  get('fourier,'tag) . fs!:negate cdr x;

symbolic procedure fs!:negate x;
   if null x then nil
   else begin scalar ans;
      ans := mkvect 3;
      fs!:set!-coeff(ans,negsq fs!:coeff x);
      fs!:set!-fn(ans,fs!:fn x);
      fs!:set!-angle(ans,fs!:angle x);
      fs!:set!-next(ans, fs!:negate fs!:next x);
      return ans
   end;

symbolic procedure fs!:zerop!:(u);
  null u or
  (not numberp u and
   null cdr u or
   (null fs!:next cdr u and
   ((numberp v and zerop v) where v=fs!:coeff cdr u)));

symbolic procedure fs!:onep!:(u); fs!:onep cdr u;

symbolic procedure fs!:onep u;
  null fs!:next u and
  onep fs!:coeff u and fs!:null!-angle u and fs!:fn(u) = 'cos;

symbolic procedure fs!:prepfn!:(x); x;

symbolic procedure simpfs u; u;

put('!:fs!:,'simpfn,'simpfs);

%% PRINTING FUNCTIONS

%% We have all the usual problems of unit coefficients, and zero angles

smacro procedure zeroterm x; fs!:coeff x = '(nil  . 1);

symbolic procedure fs!:prin!:(x);
  << prin2!* "["; fs!:prin cdr x; prin2!* "]" >>;

symbolic procedure fs!:prin x;
   if null x then prin2!* " 0 " else <<
   while x do <<
     fs!:prin1 x;
     x := fs!:next x;
     if x then prin2!* " + "
   >>
>>;

symbolic procedure fs!:prin1 x;
begin scalar first, u, v;
   first := t;
   if not(fs!:coeff x = '(1 . 1)) then <<
      prin2!* "("; sqprint fs!:coeff x;
      prin2!* ")" >>;
   if not(fs!:null!-angle x) then <<
     prin2!* fs!:fn x;
     prin2!* "[";
     u := fs!:angle x;
     for i:=0:7 do
         if not((v := getv!.unsafe(u,i)) = 0) then <<
            if v<0 then << first := t; prin2!* "-"; v := -v >>;
            if not first then prin2!* "+";
            if not(v=1) then prin2!* v;
            first := nil;
            prin2!* getv!.unsafe(fourier!-name!*, i)
     >>;
     prin2!* "]"
  >>
  else if fs!:coeff x = '(1 . 1) then prin2!* "1"
end;

symbolic procedure fs!:intequiv!:(u);
   null fs!:next x and
   fs!:null!-angle x and
   fs!:fn(x) = 'cos and
   fixp car fs!:coeff x and
   cdr fs!:coeff x = 1
        where x = cdr u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/hsub.red0000644000175000017500000001113711526203062023221 0ustar  giovannigiovannimodule hsub;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% Harmonic substitution: the CAMAL HSUB operation, as well as other
%% substitutions.

fluid '(!*trharm);
switch trham;

symbolic procedure hsub1(x,u,v,A,n);
%% Substitute v+A for u in x to order n
begin scalar ans, c, tmp, fs!:zero!-generated;
%%    fs!:zero!-generated := 0;
    ans := fs!:subang(x, u, v);
%    c := ensure!-fourier A;
    c := car A;
    if c then c := cdr c;
    A := c;
    if !*trham
      then << print "A"; if null A then print 0 else fs!:prin A >>;
    for i:=1:n do <<
        if !*trham then << print "i="; print i >>;
        x := hdiff(x, u);
        if !*trham then << prin2!* "df(x,u,i)="; fs!:prin x; terpri!* t;
                prin2!* "A^i ="; fs!:prin c; terpri!* t >>;
        c := fs!:times(cdr !*sq2fourier (1 ./ i), c);
        if !*trham
          then << prin2!* "A^i/fact(i) ="; fs!:prin c; terpri!* t>>;
        tmp := fs!:times(fs!:subang(x, u, v), c);
        if !*trham then <<
            prin2!* "f'(0)*A^i/fact i = "; fs!:prin tmp; terpri!* t>>;
        ans := fs!:plus(ans, tmp);
        if !*trham
          then << prin2!* "partial sum ="; fs!:prin ans; terpri!* t>>;
        if not(i=n) then c := fs!:times(c,A);
    >>;
    return ans
end;

symbolic procedure fs!:subang(x, u, v);
if null x then nil
else begin scalar vv, n;
    vv := mkvect 7;
    n := getv!.unsafe(fs!:angle x, u);
    for i:=0:7 do if i = u then putv!.unsafe(vv, i, n*getv!.unsafe(v,i))
        else putv!.unsafe(vv, i,
                getv!.unsafe(fs!:angle x,i) + n*getv!.unsafe(v,i));
    return fs!:plus(fs!:subang(fs!:next x, u, v),
                    make!-term(fs!:fn x, vv, fs!:coeff x));
end;

symbolic procedure fs!:sub(x,u);
if null x then nil else
begin scalar ans;
    ans := aeval prepsq fs!:coeff x;
    if not fixp ans then ans := subsq(cadr ans, u)
    else ans := fs!:coeff x;
    if eqcar(numr ans, '!:fs!:) then ans := cdar ans
        else ans := cdr !*sq2fourier ans;
    ans := fs!:times(make!-term(fs!:fn x, fs!:angle x, 1 ./ 1), ans);
    return fs!:plus(fs!:sub(fs!:next x, u), ans);
end;

symbolic procedure simphsub uu;
begin scalar x, u, v, vv, A, n, dmode!*;
    dmode!* := '!:fs!:;
    if (length uu = 5) then <<
        x := car uu; uu := cdr uu;
        u := car uu; uu := cdr uu;
        v := car uu; uu := cdr uu;
        A := car uu; uu := cdr uu;
        n := car uu
    >>
    else if (length uu = 3) then <<
        x := car uu; uu := cdr uu;
        u := car uu; uu := cdr uu;
        v := car uu; uu := cdr uu;
        if not harmonicp u then <<
            A := ( ((get('fourier, 'tag) .
                         fs!:sub(cdar simp x, list(u . v))) ./ 1)
            )  where wtl!*=delasc(u,wtl!*);
            return A;
        >>;
        A := 0;
        n := 0
    >>;
    if not harmonicp u then
        rerror(fourier, 7, "Not an angle in HSUB");
    x := cdar simp x;
    if not angle!-expression!-p v then
        rerror(fourier, 8, "Not an angle expression in HSUB");
    vv := mkvect 7;
    for i:=0:7 do putv!.unsafe(vv,i,0);
    compile!-angle!-expression(v, vv);
    A := simp!* A;
    n := simp!* n;
    if null car n then n := 0 ./ 1
    else if not(fixp car n and cdr n = 1)  then
        rerror(fourier, 9, "Non integer expansion in HSUB");
    n := car n;
    return (get('fourier, 'tag) .
           hsub1(x,get(u,'fourier!-angle),vv,A,n)) ./ 1;
end;

put('hsub, 'simpfn, 'simphsub);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/camal.tex0000644000175000017500000006615511526203062023375 0ustar  giovannigiovanni\documentstyle[11pt]{article}
\title{REDUCE Meets CAMAL}
\author{J. P. Fitch \\
School of Mathematical Sciences\\
University of Bath\\
BATH, BA2 7AY, United Kingdom}
\def\today{}
\begin{document}\maketitle

\begin{abstract}
{\em It is generally accepted that special purpose algebraic systems
are more efficient than general purpose ones, but as machines get
faster this does not matter.  An experiment has been performed to see
if using the ideas of the special purpose algebra system CAMAL(F) it
is possible to make the general purpose system REDUCE perform
calculations in celestial mechanics as efficiently as CAMAL did twenty
years ago.  To this end a prototype Fourier module is created for
REDUCE, and it is tested on some small and medium-sized problems taken
from the CAMAL test suite. The largest calculation is the
determination of the Lunar Disturbing Function to the sixth order.  An
assessment is made as to the progress, or lack of it, which computer
algebra has made, and how efficiently we are using modern hardware.
}
\end{abstract}

\section{Introduction}

A number of years ago there emerged the divide between general-purpose
algebra systems and special purpose one.  Here we investigate how far
the improvements in software and more predominantly hardware have
enabled the general systems to perform as well as the earlier special
ones.  It is similar in some respects to the Possion program for
MACSYMA \cite{Fateman} which was written in response to a similar
challenge.

The particular subject for investigation is the Fourier series
manipulator which had its origins in the Cambridge University
Institute for Theoretical Astronomy, and later became the F subsystem
of CAMAL \cite{Barton67b,CAMALF}.  In the late 1960s this system was
used for both the Delaunay Lunar Theory \cite{Delaunay,Barton67a} and
the Hill Lunar Theory \cite{Bourne}, as well as other related
calculations.  Its particular area of application had a number of
peculiar operations on which the general speed depended.  These are
outlined below in the section describing how CAMAL worked.  There have
been a number of subsequent special systems for celestial mechanics,
but these tend to be restricted to the group of the originator.

The main body of the paper describes an experiment to create within
the REDUCE system a sub-system for the efficient manipulation of
Fourier series.  This prototype program is then assessed against both
the normal (general) REDUCE and the extant CAMAL results.  The tests
are run on a number of small problems typical of those for which CAMAL
was used, and one medium-sized problem, the calculation of the Lunar
Disturbing Function.  The mathematical background to this problem is
also presented for completeness.  It is important as a problem as it
is the first stage in the development of a Delaunay Lunar Theory.

The paper ends with an assessment of how close the performance of a
modern REDUCE on modern equipment is to the (almost) defunct CAMAL of
eighteen years ago.

\section{How CAMAL Worked}

The Cambridge Algebra System was initially written in assembler for
the Titan computer, but later was rewritten a number of times, and
matured in BCPL, a version which was ported to IBM mainframes and a
number of microcomputers.  In this section a brief review of the main
data structures and special algorithms is presented.

\subsection{CAMAL Data Structures}

CAMAL is a hierarchical system, with the representation of polynomials
being completely independent of the representations of the angular
parts.  

The angular part had to represent a polynomial coefficient, either a
sine or cosine function and a linear sum of angles.  In the problems
for which CAMAL was designed there are 6 angles only, and so the
design restricted the number, initially to six on the 24 bit-halfword
TITAN, and later to eight angles on the 32-bit IBM 370, each with
fixed names (usually u through z).  All that is needed is to remember
the coefficients of the linear sum.  As typical problems are
perturbations, it was reasonable to restrict the coefficients to small
integers, as could be represented in a byte with a guard bit.  This
allowed the representation to pack everything into four words.
\begin{verbatim}
    [ NextTerm, Coefficient, Angles0-3, Angles4-7 ]
\end{verbatim}
The function was coded by a single bit in the {\tt Coefficient} field.  This
gives a particularly compact representation.  For example the Fourier
term $\sin(u-2v+w-3x)$ would be represented as
\begin{verbatim}
    [ NULL, "1"|0x1, 0x017e017d, 0x00000000 ]
or
    [ NULL, "1"|0x1, 1:-2:1:-3, 0:0:0:0 ]
\end{verbatim}
where {\tt "1"} is a pointer to the representation of the polynomial
1.  In all this representation of the term took 48 bytes.  As the
complexity of a term increased the store requirements to no grow much;
the expression $(7/4) a e^3 f^5 \cos(u-2v+3w-4x+5y+6z)$ also takes 48
bytes.  There is a canonicalisation operation to ensure that the
leading angle is positive, and $\sin(0)$ gets removed.  It should be
noted that $\cos(0)$ is a valid and necessary representation.

The polynomial part was similarly represented, as a chain of terms
with packed exponents for a fixed number of variables.  There is no
particular significance in this except that the terms were held in
{\em increasing} total order, rather than the decreasing order which
is normal in general purpose systems.  This had a number of important
effects on the efficiency of polynomial multiplication in the presence
of a truncation to a certain order.  We will return to this point
later.  Full details of the representation can be found in
\cite{LectureNotes}.

The space administration system was based on explicit return rather
than garbage collection.  This meant that the system was sometimes
harder to write, but it did mean that much attention was focussed on
efficient reuse of space.  It was possible for the user to assist in
this by marking when an expression was needed no longer, and the
compiler then arranged to recycle the space as part of the actual
operation.  This degree of control was another assistance in running
of large problems on relatively small machines.

\subsection{Automatic Linearisation}

In order to maintain Fourier series in a canonical form it is
necessary to apply the transformations for linearising products of
sine and cosines.  These will be familiar to readers of the REDUCE
test program as
\begin{eqnarray}
\cos \theta \cos \phi & \Rightarrow & 
                (\cos(\theta+\phi)+\cos(\theta-\phi))/2, \\
\cos \theta \sin \phi & \Rightarrow & 
                (\sin(\theta+\phi)-\sin(\theta-\phi))/2, \\
\sin \theta \sin \phi & \Rightarrow & 
                (\cos(\theta-\phi)-\cos(\theta+\phi))/2, \\
\cos^2 \theta & \Rightarrow & (1+\cos(2\theta))/2,      \\
\sin^2 \theta & \Rightarrow & (1-\cos(2\theta))/2.
\end{eqnarray}
In CAMAL these transformations are coded directly into the
multiplication routines, and no action is necessary on the part of the
user to invoke them.  Of course they cannot be turned off either.

\subsection{Differentiation and Integration}

The differentiation of a Fourier series with respect to an angle is
particularly simple.  The integration of a Fourier series is a little
more interesting.  The terms like $\cos(n u + \ldots)$ are easily
integrated with respect to $u$, but the treatment of terms independent
of the angle would normally introduce a secular term.  By convention
in Fourier series these secular terms are ignored, and the constant of
integration is taken as just the terms independent of the angle in the
integrand.  This is equivalent to the substitution rules
\begin{eqnarray*}
\sin(n \theta) & \Rightarrow & -(1/n) \cos(n \theta) \\
\cos(n \theta) & \Rightarrow & (1/n) \sin(n \theta)
\end{eqnarray*}

In CAMAL these operations were coded directly, and independently of
the differentiation and integration of the polynomial coefficients.

\subsection{Harmonic Substitution}

An operation which is of great importance in Fourier operations is the
{\em harmonic substitution}.  This is the substitution of the sum of
some angles and a general expression for an angle.  In order to
preserve the format, the mechanism uses the translations
\begin{eqnarray*}
\sin(\theta + A) & \Rightarrow & \sin(\theta) \cos(A) + 
                                 \cos(\theta) \sin(A) \\
\cos(\theta + A) & \Rightarrow & \cos(\theta) \cos(A) -
                                 \sin(\theta) \sin(A) \\
\end{eqnarray*}
and then assuming that the value $A$ is small it can be replaced by
its expansion:
\begin{eqnarray*}
\sin(\theta + A) & \Rightarrow & \sin(\theta) \{1 - A^2/2! + A^4/4!\ldots\} +\\
                 &             & \cos(\theta) \{A - A^3/3! + A^5/5!\ldots\} \\
\cos(\theta + A) & \Rightarrow & \cos(\theta) \{1 - A^2/2! + A^4/4!\ldots\} -\\
                 &             & \sin(\theta) \{A - A^3/3! + A^5/5! \ldots\} \\
\end{eqnarray*}
If a truncation is set for large powers of the polynomial variables
then the series will terminate.  In CAMAL the {\tt HSUB} operation
took five arguments; the original expression, the angle for which
there is a substitution, the new angular part, the expression part
($A$ in the above), and the number of terms required.

The actual coding of the operation was not as expressed above, but by
the use of Taylor's theorem.  As has been noted above the
differentiation of a harmonic series is particularly easy.

\subsection{Truncation of Series}

The main use of Fourier series systems is in generating perturbation
expansions, and this implies that the calculations are performed to
some degree of the small quantities.  In the original CAMAL all
variables were assumed to be equally small (a restriction removed in
later versions).  By maintaining polynomials in increasing maximum
order it is possible to truncate the multiplication of two
polynomials.  Assume that we are multiplying the two polynomials
\begin{eqnarray*}
        A = a_0 + a_1 + a_2 + \ldots \\
        B = b_0 + b_1 + b_2 + \ldots
\end{eqnarray*}
If we are generating the partial answer
\[
        a_i (b_0 + b_1 + b_2 + \ldots)
\]
then if for some $j$ the product $a_i b_j$ vanishes, then so will all
products $a_i b_k$ for $k>j$.  This means that the later terms need
not be generated.  In the product of $1+x+x^2+x^3+\ldots+x^{10}$ and
$1+y+y^2+y^3+\ldots+y^10$ to a total order of 10 instead of generating
100 term products only 55 are needed.  The ordering can also make the
merging of the new terms into the answer easier.

\section{Towards a CAMAL Module}

For the purposes of this work it was necessary to reproduce as many of
the ideas of CAMAL as feasible within the REDUCE framework and
philosophy.  It was not intended at this stage to produce a complete
product, and so for simplicity a number of compromises were made with
the ``no restrictions'' principle in REDUCE and the space and time
efficiency of CAMAL.  This section describes the basic design
decisions. 

\subsection{Data Structures}

In a fashion similar to CAMAL a two level data representation is used.
The coefficients are the standard quotients of REDUCE, and their
representation need not concern us further.  The angular part is
similar to that of CAMAL, but the ability to pack angle multipliers
and use a single bit for the function are not readily available in
Standard LISP, so instead a longer vector is used.  Two versions were
written.  One used a balanced tree rather than a linear list for the
Fourier terms, this being a feature of CAMAL which was considered but
never coded.  The other uses a simple linear representation for sums.
The angle multipliers are held in a separate vector in order to allow
for future flexibility.  This leads to a representation as a vector of
length 6 or 4;
\begin{verbatim}
Version1:  [ BalanceBits, Coeff, Function, Angles, LeftTree, RightTree ]
Version2:  [ Coeff, Function, Angles, Next ]
\end{verbatim}
where the {\tt Angles} field is a vector of length 8, for the
multipliers.  It was decided to forego packing as for portability we
do not know how many to pack into a small integer.  The tree system
used is AVL, which needs 2 bits to maintain balance information, but
these are coded as a complete integer field in the vector.  We can
expect the improvements implicit in a binary tree to be advantageous
for large expressions, but the additional overhead may reduce its
utility for smaller expressions.

A separate vector is kept relating the position of an angle to its
print name, and on the property list of each angle the allocation of
its position is kept.  So long as the user declares which variables
are to be treated as angles this mechanism gives flexibility which was
lacking in CAMAL.

\subsection{Linearisation}

As in the CAMAL system the linearisation of products of sines and
cosines is done not by pattern matching but by direct calculation at
the heart of the product function, where the transformations (1)
through (3) are made in the product of terms function.  A side effect
of this is that there are no simple relations which can be used from
within the Fourier multiplication, and so a full addition of partial
products is required.  There is no need to apply linearisations
elsewhere as a special case.  Addition, differentiation and
integration cannot generate such products, and where they can occur in
substitution the natural algorithm uses the internal multiplication
function anyway.

\subsection{Substitution}

Substitution is the main operation of Fourier series.  It is useful to
consider three different cases of substitutions.
\begin{enumerate}
\item Angle Expression for Angle:
\item Angle Expression + Fourier Expression for Angle:
\item Fourier Expression for Polynomial Variable.
\end{enumerate}

The first of these is straightforward, and does not require any
further comment.  The second substitution requires a little more care,
but is not significantly difficult to implement.  The method follows
the algorithm used in CAMAL, using TAYLOR series.  Indeed this is the
main special case for substitution.

The problem is the last case.  Typically many variables used in a
Fourier series program have had a WEIGHT assigned to them.  This means
that substitution must take account of any possible WEIGHTs for
variables.  The standard code in REDUCE does this in effect by
translating the expression to prefix form, and recalculating the value.
A Fourier series has a large number of coefficients, and so this
operations are repeated rather too often.  At present this is the
largest problem area with the internal code, as will be seen in the
discussion of the Disturbing Function calculation.

\section{Integration with REDUCE}

The Fourier module needs to be seen as part of REDUCE rather than as a
separate language.  This can be seen as having internal and external
parts.

\subsection{Internal Interface}

The Fourier expressions need to co-exist with the normal REDUCE syntax
and semantics.  The prototype version does this by (ab)using the
module method, based in part on the TPS code \cite{Barnes}.  Of course
Fourier series are not constant, and so are not really domain
elements.  However by asserting that Fourier series form a ring of
constants REDUCE can arrange to direct basic operations to the Fourier
code for addition, subtraction, multiplication and the like.

The main interface which needs to be provided is a simplification
function for Fourier expressions.  This needs to provide compilation
for linear sums of angles, as well as constructing sine and cosine
functions, and creating canonical forms.

\subsection{User Interface}

The creation of {\tt HDIFF} and {\tt HINT} functions for
differentiation disguises this.  An unsatisfactory aspect of the
interface is that the tokens {\tt SIN} and {\tt COS} are already in
use.  The prototype uses the operator form
\begin{verbatim}
        fourier sin(u)
\end{verbatim}
to introduce harmonically represented sine functions.  An alternative of
using the tokens {\tt F\_SIN} and {\tt F\_COS} is also available.  

It is necessary to declare the names of the angles, which is achieved
with the declaration 
\begin{verbatim}
        harmonic theta, phi;
\end{verbatim}

At present there is no protection against using a variable as both an
angle and a polynomial varaible.  This will nooed to be done in a
user-oriented version.

\section{The Simple Experiments}

The REDUCE test file contains a simple example of a Fourier
calculation, determining the value of $(a_1 \cos({wt}) + a_3
\cos(3{wt}) + b_1 \sin({wt}) + b_3 \sin(3{wt}))^3$.  For the purposes
of this system this is too trivial to do more than confirm the correct
answers. 

The simplest non-trivial calculation for a Fourier series manipulator
is to solve Kepler's equation for the eccentric anomoly E in terms of
the mean anomoly u, and the eccentricity of an orbit e, considered as a
small quantity
\[
        E = u + e \sin E
\]
The solution procedes by repeated approximation.  Clearly the initial
approximation is $E_0 = u$.  The $n^{th}$ approximation can be written
as $u + A_n$, and so $A_n$ can be calculated by
\[
        A_k = e \sin (u + A_{k-1})
\]
This is of course precisely the case for which the HSUB operation is
designed, and so in order to calculate $E_n - u$ all one requires is
the code
\begin{verbatim}
        bige := fourier 0;
        for k:=1:n do <<
          wtlevel k;
          bige:=fourier e * hsub(fourier(sin u), u, u, bige, k);
        >>;
        write "Kepler Eqn solution:", bige$
\end{verbatim}

It is possible to create a regular REDUCE program to simulate this (as
is done for example in Barton and Fitch\cite{Barton72}, page 254).
Comparing these two programs indicates substantial advantages to the
Fourier module, as could be expected.
\medskip
\begin{center}
\begin{tabular}{ | c | l l |}
\multicolumn{3}{c}{\bf Solving Kepler's Equation} \\
\hline
Order   &       REDUCE  &       Fourier Module \\
5       &       9.16    &       2.48    \\
6       &       17.40   &       4.56    \\
7       &       33.48   &       8.06    \\
8       &       62.76   &       13.54   \\
9       &       116.06  &       21.84   \\
10      &       212.12  &       34.54   \\
11      &       381.78  &       53.94   \\
12      &       692.56  &       82.96   \\
13      &       1247.54 &       125.86  \\
14      &       2298.08 &       187.20  \\
15      &       4176.04 &       275.60  \\
16      &       7504.80 &       398.62  \\
17      &       13459.80        &       569.26  \\
18      &       ***     &       800.00  \\
19      &       ***     &       1116.92 \\
20      &       ***     &       1536.40 \\
\hline
\end{tabular}
\end{center}
\medskip
These results were with the linear representation of Fourier series.
The tree representation was slightly slower.  The ten-fold speed-up
for the 13th order is most satisfactory.

\section{A Medium-Sized Problem}

Fourier series manipulators are primarily designed for large-scale
calculations, but for the demonstration purposes of this project a
medium problem is considered.  The first stage in calculating the
orbit of the Moon using the Delaunay theory (of perturbed elliptic
motion for the restricted 3-body problem) is to calculate the energy
of the Moon's motion about the Earth --- the Hamiltonian of the
system.   This is the calculation we use for comparisons.

\subsection{Mathematical Background}

The full calculation is described in detail in \cite{Brown}, but a
brief description is given here for completeness, and to grasp the
extent of the calculation.

Referring to the figure 1 which gives the cordinate system, the basic
equations are 
\begin{eqnarray}
S  & = & (1-\gamma ^2)\cos(f + g +h -f' -g' -h')
+ \gamma ^2 cos(f + g -h +f' +g' +h') \\
r & = & a (1 - e \cos E) \\
l & = & E - e \sin E \\
a & = & r {{\bf d} E} \over {{\bf d} l} \\
r ^2 {{\bf d} f} \over {{\bf d} l} & = & a^2 (1 - e^2)^{1 \over 2}\\
R & = & m' {a^2 \over {a'} ^3} {{a'}\over {r
'}} \left \{ \left ({r \over a}\right )^2
\left ({{a'} \over {r'}}\right )^2 P_2(S) +
\left ({a \over {a'}}\right )\left
({r \over a}\right )^3 \left ({{a'} \over {r'}}\right )^3 P_3(S)
+ \ldots \right \}
\end{eqnarray}

There are similar equations to (7) to (10) for the quantities $r'$,
$a'$, $e'$, $l'$, $E'$ and $f'$ which refer to the position of the Sun
rather than the Moon.  The problem is to calculate the expression $R$
as an expansion in terms of the quantities $e$, $e'$, $\gamma$,
$a/a'$, $l$, $g$, $h$, $l'$, $g'$ and $h'$.  The first three
quantities are small quantities of the first order, and $a/a'$ is of
second order.

The steps required are
\begin{enumerate}
\item Solve the Kepler equation (8)
\item Substiture into (7) to give $r/a$ in terms of $e$ and $l$.
\item Calculate $a/r$ from (9) and $f$ from (10)
\item Substitute for $f$ and $f'$ into $S$ using (6)
\item Calculate $R$ from $S$, $a'/r'$ and $r/a$
\end{enumerate}

The program is given in the Appendix.

\subsection{Results}

The Lunar Disturbing function was calculated by a direct coding of the
previous sections' mathematics.  The program was taken from Barton
and Fitch \cite{Barton72} with just small changes to generalise it for
any order, and to make it acceptable for Reduce3.4.  The Fourier
program followed the same pattern, but obviously used the {\tt HSUB}
operation as appropriate and the harmonic integration.  It is very
similar to the CAMAL program in \cite{Barton72}.   

The disturbing function was calculated to orders 2, 4 and 6 using
Cambridge LISP on an HLH Orion 1/05 (Intergraph Clipper), with the
three programs $\alpha$) Reduce3.4, $\beta$) Reduce3.4 + Camal Linear
Module and $\gamma$) Reduce3.4 + Camal AVL Module.  The timings for
CPU seconds (excluding garbage collection time) are summarised the
following table:
\medskip
\begin{center}
\begin{tabular}{ | c || l | l | l |}
\hline
Order of DDF    & Reduce        & Camal Linear  & Camal Tree \\
\hline
2       &       23.68   &       11.22   &       12.9    \\
4       &       429.44  &       213.56  &       260.64  \\
6       &       $>$7500 &       3084.62 &       3445.54 \\
\hline
%%% Linear n=4 138.72 (4Mb + unsafe vector access + recurrance)
%%% Linear n=6 1870.10 (4Mb + unsafe vector access + recurrance)
\end{tabular}
\end{center}
\medskip

If these numbers are normalised so REDUCE calculating the DDF is 100
units for each order the table becomes
\medskip
\begin{center}
\begin{tabular}{ | c || l | l | l |}
\hline
Order of DDF    & Reduce        & Camal Linear  & Camal Tree \\ \hline
2       &       100     &       47.38   &       54.48   \\
4       &       100     &       49.73   &       60.69   \\
6       &       100     &       $<$41.13        &       $<$45.94 \\
\hline
\end{tabular}
\end{center}
\medskip

From this we conclude that a doubling of speed is about correct, and
although the balanced tree system is slower as the problem size
increases the gap between it and the simpler linear system is
narrowing. 

It is disappointing that the ratio is not better, nor the absolute
time less.  It is worth noting in this context that Jefferys claimed
that the sixth order DDF took 30s on a CDC6600 with TRIGMAN in 1970
\cite{Jefferys}, and Barton and Fitch took about 1s for the second
order DDF on TITAN with CAMAL \cite{Barton72}.  A closer look at the
relative times for individual sections of the program shows that the
substitution case of replacing a polynomial variable by a Fourier
series is only marginally faster than the simple REDUCE program.  In
the DDF program this operation is only used once in a major form,
substituting into the Legendre polynomials, which have been previously
calculated by Rodrigues formula.  This suggests that we replace this
with the recurrence relationship.

Making this change actually slows down the normal REDUCE by a small
amount but makes a significant change to the Fourier module; it
reduces the run time for the 6th order DDF from 3084.62s to 2002.02s.
This gives some indication of the problems with benchmarks.  What is
clear is that the current implementation of substitution of a Fourier
series for a polynomial variable is inadequate.

\section{Conclusion}

The Fourier module is far from complete.  The operations necessary for
the solution of Duffing's and Hill's equations are not yet written,
although they should not cause much problem.  The main defficiency is
the treatment of series truncation; at present it relies on the REDUCE
WTLEVEL mechanism, and this seems too coarse for efficient truncation.
It would be possible to re-write the polynomial manipulator as well,
while retaining the REDUCE syntax, but that seems rather more than one
would hope.

The real failure so far is the large time lag between the REDUCE-based
system on a modern workstation against a mainframe of 25 years ago
running a special system.  The CAMAL Disturbing function program could
calculate the tenth order with a maximum of 32K words (about
192Kbytes) whereas this system failed to calculate the eigth order in
4Mbytes (taking 2000s before failing).  I have in my archives the
output from the standard CAMAL test suite, which includes a sixth
order DDF on an IBM 370/165 run on 2 June 1978, taking 22.50s and
using a maximum of 15459 words of memory for heap --- or about
62Kbytes.  A rough estimate is that the Orion 1/05 is comparable in
speed to the 360/165, but with more real memory and virtual memory.

However, a simple Fourier manipulator has been created for REDUCE which
performs between twice and three times the speed of REDUCE using
pattern matching.  It has been shown that this system is capable of
performing the calculations of celestial mechanics, but it still
seriously lags behind the efficiency of the specialist systems of
twenty years before.  It is perhaps fortunate that it was not been
possible to compare it with a modern specialist system.

There is still work to do to provide a convenient user interface, but
it is intended to develop the system in this direction.  It would be
pleasant to have again a system of the efficiency of CAMAL(F).

I would like to thank Codemist Ltd for the provision of computing
resources for this project, and David Barton who taught be so much
about Fourier series and celstial mechanics.  Thank are also due to
the National Health Service, without whom this work and paper could not
have been produced.

\section*{Appendix: The DDF Function}
\begin{verbatim}
array p(n/2+2);
harmonic u,v,w,x,y,z;
weight e=1, b=1, d=1, a=1;

%% Generate Legendre Polynomials to sufficient order
for i:=2:n/2+2 do <<
  p(i):=(h*h-1)^i;
  for j:=1:i do p(i):=df(p(i),h)/(2j)
>>;

%%%%%%%%%%%%%%%% Step1: Solve Kepler equation
bige := fourier 0;
for k:=1:n do <<
  wtlevel k;
  bige:=fourier e * hsub(fourier(sin u), u, u, bige, k);
>>;

%% Ensure we do not calculate things of too high an order
wtlevel n;

%%%%%%%%%%%%%%%% Step 2: Calculate r/a in terms of e and l
dd:=-e*e; hh:=3/2; j:=1; cc := 1;
for i:=1:n/2 do <<
  j:=i*j; hh:=hh-1; cc:=cc+hh*(dd^i)/j
>>;
bb:=hsub(fourier(1-e*cos u), u, u, bige, n);
aa:=fourier 1+hdiff(bige,u); ff:=hint(aa*aa*fourier cc,u);

%%%%%%%%%%%%%%%% Step 3: a/r and f
uu := hsub(bb,u,v); uu:=hsub(uu,e,b);
vv := hsub(aa,u,v); vv:=hsub(vv,e,b);
ww := hsub(ff,u,v); ww:=hsub(ww,e,b);

%%%%%%%%%%%%%%%% Step 4: Substitute f and f' into S
yy:=ff-ww; zz:=ff+ww;
xx:=hsub(fourier((1-d*d)*cos(u)),u,u-v+w-x-y+z,yy,n)+
    hsub(fourier(d*d*cos(v)),v,u+v+w+x+y-z,zz,n);

%%%%%%%%%%%%%%%% Step 5: Calculate R
zz:=bb*vv; yy:=zz*zz*vv;

on fourier;
for i := 2:n/2+2 do <<
  wtlevel n+4-2i; p(i) := hsub(p(i), h, xx) >>;

wtlevel n;
for i:=n/2+2 step -1 until 3 do
    p(n/2+2):=fourier(a*a)*zz*p(n/2+2)+p(i-1);
yy*p(n/2+2);

\end{verbatim}
\newpage
\bibliographystyle{plain}
\bibliography{camal}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/camal.tst0000644000175000017500000000231511526203062023373 0ustar  giovannigiovannin := 4;

on rational, rat;
off allfac;

array p(n/2+2);

harmonic u,v,w,x,y,z;

weight e=1, b=1, d=1, a=1;

%% Step1: Solve Kepler equation
bige := fourier 0;
for k:=1:n do <<
  wtlevel k;
  bige:=fourier e * hsub(fourier(sin u), u, u, bige, k);
>>;
write "Kepler Eqn solution:", bige$

%% Ensure we do not calculate things of too high an order
wtlevel n;

%% Step 2: Calculate r/a in terms of e and l
dd:=-e*e; hh:=3/2; j:=1; cc := 1;
for i:=1:n/2 do <<
  j:=i*j; hh:=hh-1; cc:=cc+hh*(dd^i)/j
>>;

bb:=hsub(fourier(1-e*cos u), u, u, bige, n);
aa:=fourier 1+hdiff(bige,u); ff:=hint(aa*aa*fourier cc,u);


%% Step 3: a/r and f
uu := hsub(bb,u,v); uu:=hsub(uu,e,b);
vv := hsub(aa,u,v); vv:=hsub(vv,e,b);
ww := hsub(ff,u,v); ww:=hsub(ww,e,b);

%% Step 4: Substitute f and f' into S
yy:=ff-ww; zz:=ff+ww;
xx:=hsub(fourier((1-d*d)*cos(u)),u,u-v+w-x-y+z,yy,n)+
    hsub(fourier(d*d*cos(v)),v,u+v+w+x+y-z,zz,n);

%% Step 5: Calculate R
zz:=bb*vv; yy:=zz*zz*vv;

on fourier;

p(0):= fourier 1; p(1) := xx;
for i := 2:n/2+2 do <<
  wtlevel n+4-2i;
  p(i) := fourier ((2*i-1)/i)*xx*p(i-1) - fourier ((i-1)/i)*p(i-2);
>>;

wtlevel n;
for i:=n/2+2 step -1 until 3 do p(n/2+2):=fourier(a*a)*zz*p(n/2+2)+p(i-1);

yy*p(n/2+2);

showtime;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/camal.rlg0000644000175000017500000011147211527635055023366 0ustar  giovannigiovanniFri Feb 18 21:27:24 2011 run on win32
n := 4;


n := 4


on rational, rat;


off allfac;



array p(n/2+2);



harmonic u,v,w,x,y,z;



weight e=1, b=1, d=1, a=1;


{}


%% Step1: Solve Kepler equation
bige := fourier 0;


bige := 0

for k:=1:n do <<
  wtlevel k;
  bige:=fourier e * hsub(fourier(sin u), u, u, bige, k);
>>;


write "Kepler Eqn solution:", bige$


                             1   4                3   3             1   4
Kepler Eqn solution: - [( - ---*e )sin[4u] + ( - ---*e )sin[3u] + (---*e
                             3                    8                 6

    1   2             1   3
 - ---*e )sin[2u] + (---*e  - e)sin[u]]
    2                 8


%% Ensure we do not calculate things of too high an order
wtlevel n;


4


%% Step 2: Calculate r/a in terms of e and l
dd:=-e*e;


          2
dd :=  - e
 hh:=3/2;


       3
hh := ---
       2
 j:=1;


j := 1
 cc := 1;


cc := 1

for i:=1:n/2 do <<
  j:=i*j; hh:=hh-1; cc:=cc+hh*(dd^i)/j
>>;



bb:=hsub(fourier(1-e*cos u), u, u, bige, n);


            1   4                3   3             1   4    1   2
bb := [( - ---*e )cos[4u] + ( - ---*e )cos[3u] + (---*e  - ---*e )cos[2u] + (
            3                    8                 3        2

       3   3                1   2
      ---*e  - e)cos[u] + (---*e  + 1)]
       8                    2

aa:=fourier 1+hdiff(bige,u);


         4   4             9   3                1   4    2                1   3
aa := [(---*e )cos[4u] + (---*e )cos[3u] + ( - ---*e  + e )cos[2u] + ( - ---*e
         3                 8                    3                         8

       + e)cos[u] + 1]
 ff:=hint(aa*aa*fourier cc,u);


               103   4                13   3             11   4    5   2
ff :=  - [( - -----*e )sin[4u] + ( - ----*e )sin[3u] + (----*e  - ---*e )sin[2u]
               96                     12                 24        4

           1   3                  1   4
       + (---*e  - 2*e)sin[u] + (---*e  - 1)]
           4                      8



%% Step 3: a/r and f
uu := hsub(bb,u,v);


            1   4                3   3             1   4    1   2
uu := [( - ---*e )cos[4v] + ( - ---*e )cos[3v] + (---*e  - ---*e )cos[2v] + (
            3                    8                 3        2

       3   3                1   2
      ---*e  - e)cos[v] + (---*e  + 1)]
       8                    2
 uu:=hsub(uu,e,b);


            1   4                3   3             1   4    1   2
uu := [( - ---*b )cos[4v] + ( - ---*b )cos[3v] + (---*b  - ---*b )cos[2v] + (
            3                    8                 3        2

       3   3                1   2
      ---*b  - b)cos[v] + (---*b  + 1)]
       8                    2

vv := hsub(aa,u,v);


         4   4             9   3                1   4    2                1   3
vv := [(---*e )cos[4v] + (---*e )cos[3v] + ( - ---*e  + e )cos[2v] + ( - ---*e
         3                 8                    3                         8

       + e)cos[v] + 1]
 vv:=hsub(vv,e,b);


         4   4             9   3                1   4    2                1   3
vv := [(---*b )cos[4v] + (---*b )cos[3v] + ( - ---*b  + b )cos[2v] + ( - ---*b
         3                 8                    3                         8

       + b)cos[v] + 1]

ww := hsub(ff,u,v);


               103   4                13   3             11   4    5   2
ww :=  - [( - -----*e )sin[4v] + ( - ----*e )sin[3v] + (----*e  - ---*e )sin[2v]
               96                     12                 24        4

           1   3                  1   4
       + (---*e  - 2*e)sin[v] + (---*e  - 1)]
           4                      8
 ww:=hsub(ww,e,b);


               103   4                13   3             11   4    5   2
ww :=  - [( - -----*b )sin[4v] + ( - ----*b )sin[3v] + (----*b  - ---*b )sin[2v]
               96                     12                 24        4

           1   3                  1   4
       + (---*b  - 2*b)sin[v] + (---*b  - 1)]
           4                      8


%% Step 4: Substitute f and f' into S
yy:=ff-ww;


         103   4             13   3                11   4    5   2
yy := [(-----*e )sin[4u] + (----*e )sin[3u] + ( - ----*e  + ---*e )sin[2u] + (
         96                  12                    24        4

          1   3                     103   4                13   3
       - ---*e  + 2*e)sin[u] + ( - -----*b )sin[4v] + ( - ----*b )sin[3v] + (
          4                         96                     12

       11   4    5   2             1   3                  1   4    1   4
      ----*b  - ---*b )sin[2v] + (---*b  - 2*b)sin[v] + (---*b  - ---*e )]
       24        4                 4                      8        8
 zz:=ff+ww;


               103   4                13   3             11   4    5   2
zz :=  - [( - -----*e )sin[4u] + ( - ----*e )sin[3u] + (----*e  - ---*e )sin[2u]
               96                     12                 24        4

           1   3                     103   4                13   3
       + (---*e  - 2*e)sin[u] + ( - -----*b )sin[4v] + ( - ----*b )sin[3v] + (
           4                         96                     12

       11   4    5   2             1   3                  1   4    1   4
      ----*b  - ---*b )sin[2v] + (---*b  - 2*b)sin[v] + (---*b  + ---*e  - 2)]
       24        4                 4                      8        8

xx:=hsub(fourier((1-d*d)*cos(u)),u,u-v+w-x-y+z,yy,n)+
    hsub(fourier(d*d*cos(v)),v,u+v+w+x+y-z,zz,n);


               625   4                       4     3
xx :=  - [( - -----*e )cos[5u-v+w-x-y+z] + (---*b*e )cos[4u+w-x-y+z] + (
               384                           3

          4   3                          4     3                        9   2  2
       - ---*e )cos[4u-v+w-x-y+z] + ( - ---*b*e )cos[4u-2v+w-x-y+z] + (---*d *e
          3                              3                              8

                             17   2  2                       9    2  2
      )cos[3u+v+w+x+y-z] + (----*d *e )sin[3u+v+w+x+y-z] + (----*b *e )cos[3u+v+
                             12                              64

                    9    4                       9     2
      w-x-y+z] + (-----*e )cos[3u+v-w+x+y-z] + (---*b*e )cos[3u+w-x-y+z] + (
                   128                           8

       9   2  2    9   2  2    27   4    9   2                          9     2
      ---*b *e  + ---*d *e  + ----*e  - ---*e )cos[3u-v+w-x-y+z] + ( - ---*b*e )
       8           8           16        8                              8

                                81   2  2                          2
      cos[3u-2v+w-x-y+z] + ( - ----*b *e )cos[3u-3v+w-x-y+z] + (b*d *e)cos[2u+2v
                                64

                        2                          1    3
      +w+x+y-z] + (2*b*d *e)sin[2u+2v+w+x+y-z] + (----*b *e)cos[2u+2v+w-x-y+z]
                                                   12

           1      3                        2                         2   2
       + (----*b*e )cos[2u+2v-w+x+y-z] + (d *e)cos[2u+v+w+x+y-z] + (---*d *e)sin
           12                                                        3

                         1   2                         1    3
      [2u+v+w+x+y-z] + (---*b *e)cos[2u+v+w-x-y+z] + (----*e )cos[2u+v-w+x+y-z]
                         8                             12

                2                              2                            2
       + ( - b*d *e)cos[2u+w+x+y-z] + ( - 2*b*d *e)sin[2u+w+x+y-z] + ( - b*d *e

          5     3                              1      3                     2
       - ---*b*e  + b*e)cos[2u+w-x-y+z] + ( - ----*b*e )cos[2u-w+x+y-z] + (b *e
          4                                    12

          2      5   3                           5   3        2      5     3
       + d *e + ---*e  - e)cos[2u-v+w-x-y+z] + (---*b *e + b*d *e + ---*b*e
                 4                               4                   4

                                       9   2                             4   3
       - b*e)cos[2u-2v+w-x-y+z] + ( - ---*b *e)cos[2u-3v+w-x-y+z] + ( - ---*b *e
                                       8                                 3

                              9   2  2                       17   2  2
      )cos[2u-4v+w-x-y+z] + (---*b *d )cos[u+3v+w+x+y-z] + (----*b *d )sin[u+3v+
                              8                              12

                    9    4                       9    2  2
      w+x+y-z] + (-----*b )cos[u+3v+w-x-y+z] + (----*b *e )cos[u+3v-w+x+y-z] + (
                   128                           64

         2                       2     2                       1    3
      b*d )cos[u+2v+w+x+y-z] + (---*b*d )sin[u+2v+w+x+y-z] + (----*b )cos[u+2v+w
                                 3                             12

                  1     2                          2  2    2  2    1   2
      -x-y+z] + (---*b*e )cos[u+2v-w+x+y-z] + ( - b *d  - d *e  + ---*d )cos[u+v
                  8                                                3

                         2  2      2  2    2   2                         1    4
      +w+x+y-z] + ( - 2*b *d  - 2*d *e  + ---*d )sin[u+v+w+x+y-z] + ( - ----*b
                                           3                             48

          1   2  2    1   2  2    1   2                         1   2  2
       - ---*b *d  - ---*b *e  + ---*b )cos[u+v+w-x-y+z] + ( - ---*b *e
          8           8           8                             8

          1   2  2    1    4    1   2                           2
       - ---*d *e  - ----*e  + ---*e )cos[u+v-w+x+y-z] + ( - b*d )cos[u+w+x+y-z]
          8           48        8

              2     2                         2      2
       + ( - ---*b*d )sin[u+w+x+y-z] + ( - b*d  - b*e  + b)cos[u+w-x-y+z] + (
              3

          1     2                       1   2  2                      7    2  2
       - ---*b*e )cos[u-w+x+y-z] + ( - ---*b *d )cos[u-v+w+x+y-z] + (----*b *d )
          8                             8                             12

                              7    4    2  2    2  2    2    2  2    2    7    4
      sin[u-v+w+x+y-z] + ( - ----*b  - b *d  - b *e  + b  - d *e  + d  - ----*e
                              64                                          64

          2                          1   4    1   4
       + e  - 1)cos[u-v+w-x-y+z] + (---*b  - ---*e )sin[u-v+w-x-y+z] + (
                                     8        8

          1    2  2                         1   2  2
       - ----*b *e )cos[u-v-w+x+y-z] + ( - ---*d *e )cos[u-v-w-x-y+z] + (
          64                                8

          7    2  2                      5   3      2      2
       - ----*d *e )sin[u-v-w-x-y+z] + (---*b  + b*d  + b*e  - b)cos[u-2v+w-x-y+
          12                             4

             27   4    9   2  2    9   2  2    9   2
      z] + (----*b  + ---*b *d  + ---*b *e  - ---*b )cos[u-3v+w-x-y+z] + (
             16        8           8           8

          4   3                          625   4                       4   3
       - ---*b )cos[u-4v+w-x-y+z] + ( - -----*b )cos[u-5v+w-x-y+z] + (---*b *e)
          3                              384                           3

                          9   2                            2
      cos[4v-w+x+y-z] + (---*b *e)cos[3v-w+x+y-z] + ( - b*d *e)cos[2v+w+x+y-z]
                          8

                  2                          1    3
       + ( - 2*b*d *e)sin[2v+w+x+y-z] + ( - ----*b *e)cos[2v+w-x-y+z] + (
                                             12

          5   3        2                                2
       - ---*b *e - b*d *e + b*e)cos[2v-w+x+y-z] + ( - d *e)cos[v+w+x+y-z] + (
          4

          2   2                         1   2                         2      2
       - ---*d *e)sin[v+w+x+y-z] + ( - ---*b *e)cos[v+w-x-y+z] + ( - b *e - d *e
          3                             8

                                2                        2
       + e)cos[v-w+x+y-z] + (b*d *e)cos[w+x+y-z] + (2*b*d *e)sin[w+x+y-z] + (

         2
      b*d *e - b*e)cos[w-x-y+z]]


%% Step 5: Calculate R
zz:=bb*vv;


            1   4                3      3                  3   3
zz := [( - ---*e )cos[4u] + ( - ----*b*e )cos[3u+v] + ( - ---*e )cos[3u] + (
            3                    16                        8

          3      3                  1   2  2                   1     2
       - ----*b*e )cos[3u-v] + ( - ---*b *e )cos[2u+2v] + ( - ---*b*e )cos[2u+v]
          16                        4                          4

           1   4    1   2                1     2                  1   2  2
       + (---*e  - ---*e )cos[2u] + ( - ---*b*e )cos[2u-v] + ( - ---*b *e )cos[2
           3        2                    4                        4

                   9    3                    1   2                 1    3
      u-2v] + ( - ----*b *e)cos[u+3v] + ( - ---*b *e)cos[u+2v] + (----*b *e
                   16                        2                     16

          3      3    1                   3   3                1    3
       + ----*b*e  - ---*b*e)cos[u+v] + (---*e  - e)cos[u] + (----*b *e
          16          2                   8                    16

          3      3    1                      1   2                    9    3
       + ----*b*e  - ---*b*e)cos[u-v] + ( - ---*b *e)cos[u-2v] + ( - ----*b *e)
          16          2                      2                        16

                    4   4             9   3                1   4    1   2  2
      cos[u-3v] + (---*b )cos[4v] + (---*b )cos[3v] + ( - ---*b  + ---*b *e
                    3                 8                    3        2

          2                1   3    1     2                1   2
       + b )cos[2v] + ( - ---*b  + ---*b*e  + b)cos[v] + (---*e  + 1)]
                           8        2                      2
 yy:=zz*zz*vv;


            1   4                3     3                  1   3
yy := [( - ---*e )cos[4u] + ( - ---*b*e )cos[3u+v] + ( - ---*e )cos[3u] + (
            6                    8                        4

          3     3                  9   2  2                   3     2
       - ---*b*e )cos[3u-v] + ( - ---*b *e )cos[2u+2v] + ( - ---*b*e )cos[2u+v]
          8                        8                          4

              3   2  2    1   4    1   2                3     2
       + ( - ---*b *e  + ---*e  - ---*e )cos[2u] + ( - ---*b*e )cos[2u-v] + (
              4           6        2                    4

          9   2  2                   53   3                    9   2
       - ---*b *e )cos[2u-2v] + ( - ----*b *e)cos[u+3v] + ( - ---*b *e)cos[u+2v]
          8                          8                         2

              27   3      3     3                           2      1   3
       + ( - ----*b *e + ---*b*e  - 3*b*e)cos[u+v] + ( - 3*b *e + ---*e  - 2*e)
              8           8                                        4

                    27   3      3     3                         9   2
      cos[u] + ( - ----*b *e + ---*b*e  - 3*b*e)cos[u-v] + ( - ---*b *e)cos[u-2v
                    8           8                               2

               53   3                 77   4             53   3
      ] + ( - ----*b *e)cos[u-3v] + (----*b )cos[4v] + (----*b )cos[3v] + (
               8                      8                  8

       7   4    27   2  2    9   2             27   3    9     2
      ---*b  + ----*b *e  + ---*b )cos[2v] + (----*b  + ---*b*e  + 3*b)cos[v] + 
       2        4            2                 8         2

        15   4    9   2  2    3   2    3   2
      (----*b  + ---*b *e  + ---*b  + ---*e  + 1)]
        8         4           2        2


on fourier;


*** Domain mode rational changed to fourier 


p(0):= fourier 1;


p(0) := [1]
 p(1) := xx;


                 625   4                       4     3
p(1) :=  - [( - -----*e )cos[5u-v+w-x-y+z] + (---*b*e )cos[4u+w-x-y+z] + (
                 384                           3

            4   3                          4     3                        9   2
         - ---*e )cos[4u-v+w-x-y+z] + ( - ---*b*e )cos[4u-2v+w-x-y+z] + (---*d
            3                              3                              8

          2                       17   2  2                       9    2  2
        *e )cos[3u+v+w+x+y-z] + (----*d *e )sin[3u+v+w+x+y-z] + (----*b *e )cos[
                                  12                              64
                           9    4                       9     2
        3u+v+w-x-y+z] + (-----*e )cos[3u+v-w+x+y-z] + (---*b*e )cos[3u+w-x-y+z]
                          128                           8

             9   2  2    9   2  2    27   4    9   2
         + (---*b *e  + ---*d *e  + ----*e  - ---*e )cos[3u-v+w-x-y+z] + (
             8           8           16        8

            9     2                           81   2  2
         - ---*b*e )cos[3u-2v+w-x-y+z] + ( - ----*b *e )cos[3u-3v+w-x-y+z] + (b
            8                                 64

          2                              2                          1    3
        *d *e)cos[2u+2v+w+x+y-z] + (2*b*d *e)sin[2u+2v+w+x+y-z] + (----*b *e)cos
                                                                    12

                            1      3                        2
        [2u+2v+w-x-y+z] + (----*b*e )cos[2u+2v-w+x+y-z] + (d *e)cos[2u+v+w+x+y-z
                            12

              2   2                         1   2                         1    3
        ] + (---*d *e)sin[2u+v+w+x+y-z] + (---*b *e)cos[2u+v+w-x-y+z] + (----*e
              3                             8                             12

                                    2                              2
        )cos[2u+v-w+x+y-z] + ( - b*d *e)cos[2u+w+x+y-z] + ( - 2*b*d *e)sin[2u+w+

                        2      5     3                              1      3
        x+y-z] + ( - b*d *e - ---*b*e  + b*e)cos[2u+w-x-y+z] + ( - ----*b*e )cos
                               4                                    12

                         2      2      5   3                           5   3
        [2u-w+x+y-z] + (b *e + d *e + ---*e  - e)cos[2u-v+w-x-y+z] + (---*b *e
                                       4                               4

              2      5     3                                 9   2
         + b*d *e + ---*b*e  - b*e)cos[2u-2v+w-x-y+z] + ( - ---*b *e)cos[2u-3v+w
                     4                                       8

                       4   3                          9   2  2
        -x-y+z] + ( - ---*b *e)cos[2u-4v+w-x-y+z] + (---*b *d )cos[u+3v+w+x+y-z]
                       3                              8

             17   2  2                        9    4                       9
         + (----*b *d )sin[u+3v+w+x+y-z] + (-----*b )cos[u+3v+w-x-y+z] + (----
             12                              128                           64

          2  2                         2                       2     2
        *b *e )cos[u+3v-w+x+y-z] + (b*d )cos[u+2v+w+x+y-z] + (---*b*d )sin[u+2v+
                                                               3

                     1    3                       1     2
        w+x+y-z] + (----*b )cos[u+2v+w-x-y+z] + (---*b*e )cos[u+2v-w+x+y-z] + (
                     12                           8

            2  2    2  2    1   2                           2  2      2  2
         - b *d  - d *e  + ---*d )cos[u+v+w+x+y-z] + ( - 2*b *d  - 2*d *e
                            3

            2   2                         1    4    1   2  2    1   2  2
         + ---*d )sin[u+v+w+x+y-z] + ( - ----*b  - ---*b *d  - ---*b *e
            3                             48        8           8

            1   2                         1   2  2    1   2  2    1    4
         + ---*b )cos[u+v+w-x-y+z] + ( - ---*b *e  - ---*d *e  - ----*e
            8                             8           8           48

            1   2                           2                       2     2
         + ---*e )cos[u+v-w+x+y-z] + ( - b*d )cos[u+w+x+y-z] + ( - ---*b*d )sin[
            8                                                       3

                            2      2                           1     2
        u+w+x+y-z] + ( - b*d  - b*e  + b)cos[u+w-x-y+z] + ( - ---*b*e )cos[u-w+x
                                                               8

                     1   2  2                      7    2  2
        +y-z] + ( - ---*b *d )cos[u-v+w+x+y-z] + (----*b *d )sin[u-v+w+x+y-z] + 
                     8                             12

             7    4    2  2    2  2    2    2  2    2    7    4    2
        ( - ----*b  - b *d  - b *e  + b  - d *e  + d  - ----*e  + e  - 1)cos[u-v
             64                                          64

                      1   4    1   4                         1    2  2
        +w-x-y+z] + (---*b  - ---*e )sin[u-v+w-x-y+z] + ( - ----*b *e )cos[u-v-w
                      8        8                             64

                       1   2  2                         7    2  2
        +x+y-z] + ( - ---*d *e )cos[u-v-w-x-y+z] + ( - ----*d *e )sin[u-v-w-x-y+
                       8                                12

               5   3      2      2                           27   4    9   2  2
        z] + (---*b  + b*d  + b*e  - b)cos[u-2v+w-x-y+z] + (----*b  + ---*b *d
               4                                             16        8

            9   2  2    9   2                          4   3
         + ---*b *e  - ---*b )cos[u-3v+w-x-y+z] + ( - ---*b )cos[u-4v+w-x-y+z]
            8           8                              3

                625   4                       4   3                       9   2
         + ( - -----*b )cos[u-5v+w-x-y+z] + (---*b *e)cos[4v-w+x+y-z] + (---*b
                384                           3                           8

                                    2                              2
        *e)cos[3v-w+x+y-z] + ( - b*d *e)cos[2v+w+x+y-z] + ( - 2*b*d *e)sin[2v+w+

                      1    3                          5   3        2
        x+y-z] + ( - ----*b *e)cos[2v+w-x-y+z] + ( - ---*b *e - b*d *e + b*e)cos
                      12                              4

                            2                         2   2
        [2v-w+x+y-z] + ( - d *e)cos[v+w+x+y-z] + ( - ---*d *e)sin[v+w+x+y-z] + (
                                                      3

            1   2                         2      2                            2
         - ---*b *e)cos[v+w-x-y+z] + ( - b *e - d *e + e)cos[v-w+x+y-z] + (b*d
            8

                                2                      2
        *e)cos[w+x+y-z] + (2*b*d *e)sin[w+x+y-z] + (b*d *e - b*e)cos[w-x-y+z]]

for i := 2:n/2+2 do <<
  wtlevel n+4-2i;
  p(i) := fourier ((2*i-1)/i)*xx*p(i-1) - fourier ((i-1)/i)*p(i-2);
>>;



wtlevel n;


0

for i:=n/2+2 step -1 until 3 do p(n/2+2):=fourier(a*a)*zz*p(n/2+2)+p(i-1);



yy*p(n/2+2);


   27   4                               25     3                           25
[(----*e )cos[6u-2v+2w-2x-2y+2z] + ( - ----*b*e )cos[5u-v+2w-2x-2y+2z] + (----
   32                                   64                                 32

  3                            75   2  2                            175     3
*e )cos[5u-2v+2w-2x-2y+2z] + (----*a *e )cos[5u-3v+3w-3x-3y+3z] + (-----*b*e )
                               64                                   64

                              13   2  2                     2  2
cos[5u-3v+2w-2x-2y+2z] + ( - ----*d *e )cos[4u+2w] + ( - 2*d *e )sin[4u+2w] + (
                              8

    1    4                3     2                              15   2
 - ----*e )cos[4u] + ( - ---*b*e )cos[4u-v+2w-2x-2y+2z] + ( - ----*a *b*e)cos[4u
    24                    8                                    16

                        15   2  2    3   2  2    15   4    3   2
-2v+3w-3x-3y+3z] + ( - ----*b *e  - ---*d *e  - ----*e  + ---*e )cos[4u-2v+2w-2x
                        8            2           8         4

            15   2                              21     2
-2y+2z] + (----*a *e)cos[4u-3v+3w-3x-3y+3z] + (----*b*e )cos[4u-3v+2w-2x-2y+2z]
            16                                  8

     35   4                            75   2                                51
 + (----*a )cos[4u-4v+4w-4x-4y+4z] + (----*a *b*e)cos[4u-4v+3w-3x-3y+3z] + (----
     64                                16                                    8

  2  2                               9     2                       7     2
*b *e )cos[4u-4v+2w-2x-2y+2z] + ( - ---*b*d *e)cos[3u+v+2w] + ( - ---*b*d *e)sin
                                     4                             2

              1    3                                3      3
[3u+v+2w] + (----*b *e)cos[3u+v+2w-2x-2y+2z] + ( - ----*b*e )cos[3u+v] + (
              64                                    32

    3   2                     2                     1    3
 - ---*d *e)cos[3u+2w] + ( - d *e)sin[3u+2w] + ( - ----*e )cos[3u] + (
    2                                               16

    5   2  2                           5   2  2                        5    2  2
 - ---*a *d )cos[3u-v+3w-x-y+z] + ( - ---*a *d )sin[3u-v+3w-x-y+z] + (----*a *b
    8                                  4                               64

                              9     2                    1     2
)cos[3u-v+3w-3x-3y+3z] + ( - ---*b*d *e)cos[3u-v+2w] + (---*b*d *e)sin[3u-v+2w]
                              4                          2

     3    3      3     2      57     3    3
 + (----*b *e + ---*b*d *e + ----*b*e  - ---*b*e)cos[3u-v+2w-2x-2y+2z] + (
     64          4            64          8

    9    2  2                          3      3                  5   2
 - ----*a *e )cos[3u-v+w-x-y+z] + ( - ----*b*e )cos[3u-v] + ( - ---*a *b)cos[3u-
    64                                 32                        8
                       15   2      3   2      57   3    3
2v+3w-3x-3y+3z] + ( - ----*b *e - ---*d *e - ----*e  + ---*e)cos[3u-2v+2w-2x-2y+
                       8           2          32        4
           15   2  2    15   2  2    15   2  2    5   2
2z] + ( - ----*a *b  - ----*a *d  - ----*a *e  + ---*a )cos[3u-3v+3w-3x-3y+3z]
           4            8            4            8

        369   3      21     2      399     3    21
 + ( - -----*b *e - ----*b*d *e - -----*b*e  + ----*b*e)cos[3u-3v+2w-2x-2y+2z]
        64           4             64           8

     25   2                              51   2
 + (----*a *b)cos[3u-4v+3w-3x-3y+3z] + (----*b *e)cos[3u-4v+2w-2x-2y+2z] + (
     8                                   8

 635   2  2                            845   3
-----*a *b )cos[3u-5v+3w-3x-3y+3z] + (-----*b *e)cos[3u-5v+2w-2x-2y+2z] + (
 64                                    64

    1   4                            1   4
 - ---*d )cos[2u+2v+2w+2x+2y-2z] + (---*d )sin[2u+2v+2w+2x+2y-2z] + (
    4                                3

    11   2  2                      13   2  2                   1    4
 - ----*b *d )cos[2u+2v+2w] + ( - ----*b *d )sin[2u+2v+2w] + (----*b )cos[2u+2v+
    4                              4                           32
                 2  2                            3   2  2
2w-2x-2y+2z] + (d *e )cos[2u+2v+2x+2y-2z] + ( - ---*d *e )sin[2u+2v+2x+2y-2z] + 
                                                 4

     9    2  2                   3    4                               7     2
( - ----*b *e )cos[2u+2v] + ( - ----*e )cos[2u+2v-2w+2x+2y-2z] + ( - ---*b*d )
     32                          64                                   4

                    3     2                  1    3
cos[2u+v+2w] + ( - ---*b*d )sin[2u+v+2w] + (----*b )cos[2u+v+2w-2x-2y+2z] + (
                    2                        64

    3      2                  7   2  2    1   4    17   2  2    1   2
 - ----*b*e )cos[2u+v] + ( - ---*b *d  + ---*d  + ----*d *e  - ---*d )cos[2u+2w]
    16                        4           2        4            2

     1   2  2    4    9   2  2    2                   3    2
 + (---*b *d  + d  + ---*d *e  - d )sin[2u+2w] + ( - ----*a *b*e)cos[2u+w-x-y+z]
     2                2                               16

        3    2  2    3   2  2    1    4    1   2             1     2
 + ( - ----*b *e  + ---*d *e  + ----*e  - ---*e )cos[2u] + (---*b*d )cos[2u-v+2w
        16           4           24        8                 4

         3     2                  3    3    3     2    15     2    3
] + ( - ---*b*d )sin[2u-v+2w] + (----*b  + ---*b*d  + ----*b*e  - ---*b)cos[2u-v
         2                        64        4          16          8

                     3    2                            3      2
+2w-2x-2y+2z] + ( - ----*a *e)cos[2u-v+w-x-y+z] + ( - ----*b*e )cos[2u-v] + (
                     16                                16

 45   2                                3   2  2                      13   2  2
----*a *b*e)cos[2u-2v+3w-3x-3y+3z] + (---*b *d )cos[2u-2v+2w] + ( - ----*b *d )
 16                                    2                             4

                  5    4    39   4    15   2  2    75   2  2    15   2    3   4
sin[2u-2v+2w] + (----*a  + ----*b  + ----*b *d  + ----*b *e  - ----*b  + ---*d
                  16        64        4            16           8         4

                     15   2  2    3   2    69   4    15   2    3
                  + ----*d *e  - ---*d  + ----*e  - ----*e  + ---)cos[2u-2v+2w-2
                     4            2        64        8         4

                3    4    3    4                               9    2
x-2y+2z] + ( - ----*b  + ----*e )sin[2u-2v+2w-2x-2y+2z] + ( - ----*a *b*e)cos[2u
                16        16                                   16

                    9    2  2                1   2  2                         3
-2v+w-x-y+z] + ( - ----*b *e )cos[2u-2v] + (---*d *e )cos[2u-2v-2x-2y+2z] + (---
                    32                       4                                4

  2  2                            45   2                                 369   3
*d *e )sin[2u-2v-2x-2y+2z] + ( - ----*a *e)cos[2u-3v+3w-3x-3y+3z] + ( - -----*b
                                  16                                     64

    21     2    105     2    21                                  225   2
 - ----*b*d  - -----*b*e  + ----*b)cos[2u-3v+2w-2x-2y+2z] + ( - -----*a *b*e)cos
    4           16           8                                   16

                           115   4    51   2  2    255   2  2    51   2
[2u-4v+3w-3x-3y+3z] + ( - -----*b  - ----*b *d  - -----*b *e  + ----*b )cos[2u-4
                            8         4            16            8

                   845   3                            1599   4
v+2w-2x-2y+2z] + (-----*b )cos[2u-5v+2w-2x-2y+2z] + (------*b )cos[2u-6v+2w-2x-2
                   64                                  64

          1     2                          3     2
y+2z] + (---*b*d *e)cos[u+3v+2x+2y-2z] + (---*b*d *e)sin[u+3v+2x+2y-2z] + (
          4                                2

    53   3                    49     3                              1   2
 - ----*b *e)cos[u+3v] + ( - ----*b*e )cos[u+3v-2w+2x+2y-2z] + ( - ---*d *e)cos[
    32                        64                                    2

                   2                             9   2                    7    3
u+2v+2x+2y-2z] + (d *e)sin[u+2v+2x+2y-2z] + ( - ---*b *e)cos[u+2v] + ( - ----*e
                                                 8                        32

                           23     2                   13     2
)cos[u+2v-2w+2x+2y-2z] + (----*b*d *e)cos[u+v+2w] + (----*b*d *e)sin[u+v+2w] + (
                           4                          2

    3    3                               3   2  2
 - ----*b *e)cos[u+v+2w-2x-2y+2z] + ( - ---*a *d )cos[u+v+w+x+y-z] + (
    64                                   4

    3   2  2                      33   2  2                         7     2
 - ---*a *d )sin[u+v+w+x+y-z] + (----*a *b )cos[u+v+w-x-y+z] + ( - ---*b*d *e)
    2                             64                                4

                      3     2                            27   3      9     2
cos[u+v+2x+2y-2z] + (---*b*d *e)sin[u+v+2x+2y-2z] + ( - ----*b *e + ---*b*d *e
                      2                                  32          2

    3      3    3                   33   2  2                      7      3
 + ----*b*e  - ---*b*e)cos[u+v] + (----*a *e )cos[u+v-w+x+y-z] + (----*b*e )cos[
    32          4                   64                             64

                     5   2                   2                 3   2
u+v-2w+2x+2y-2z] + (---*d *e)cos[u+2w] + (3*d *e)sin[u+2w] + (---*a *b)cos[u+w-x
                     2                                         8

             3   2        2      1    3    1               7     2
-y+z] + ( - ---*b *e + 3*d *e + ----*e  - ---*e)cos[u] + (---*b*d *e)cos[u-v+2w]
             4                   16        2               4

     5     2                      9    3      9     2      39     3    9
 + (---*b*d *e)sin[u-v+2w] + ( - ----*b *e - ---*b*d *e - ----*b*e  + ---*b*e)
     2                            64          4            64          8

                         3   2  2    33   2  2    3   2  2    3   2
cos[u-v+2w-2x-2y+2z] + (---*a *b  - ----*a *d  + ---*a *e  + ---*a )cos[u-v+w-x-
                         4           8            4           8

            27   3      9     2      3      3    3
y+z] + ( - ----*b *e + ---*b*d *e + ----*b*e  - ---*b*e)cos[u-v] + (
            32          2            32          4

    3     2                         5     2                         45   2
 - ---*b*d *e)cos[u-v-2x-2y+2z] + (---*b*d *e)sin[u-v-2x-2y+2z] + (----*b *e
    4                               2                               8

    9   2      39   3    9                              9   2
 + ---*d *e + ----*e  - ---*e)cos[u-2v+2w-2x-2y+2z] + (---*a *b)cos[u-2v+w-x-y+z
    2          32        4                              8

         9   2                 3   2                             2
] + ( - ---*b *e)cos[u-2v] + (---*d *e)cos[u-2v-2x-2y+2z] + ( - d *e)sin[u-2v-2x
         8                     2

            285   2  2                           1107   3      63     2
-2y+2z] + (-----*a *e )cos[u-3v+3w-3x-3y+3z] + (------*b *e + ----*b*d *e
            64                                    64           4

    273     3    63                                159   2  2
 + -----*b*e  - ----*b*e)cos[u-3v+2w-2x-2y+2z] + (-----*a *b )cos[u-3v+w-x-y+z]
    64           8                                 64

        5   2  2                          5   2  2
 + ( - ---*a *d )cos[u-3v+w-3x-3y+3z] + (---*a *d )sin[u-3v+w-3x-3y+3z] + (
        8                                 4

    53   3                 21     2                             11     2
 - ----*b *e)cos[u-3v] + (----*b*d *e)cos[u-3v-2x-2y+2z] + ( - ----*b*d *e)sin[u
    32                     4                                    2

                     153   2                                2535   3
-3v-2x-2y+2z] + ( - -----*b *e)cos[u-4v+2w-2x-2y+2z] + ( - ------*b *e)cos[u-5v+
                      8                                      64
                    63   2  2                         19   2  2
2w-2x-2y+2z] + ( - ----*b *d )cos[4v+2x+2y-2z] + ( - ----*b *d )sin[4v+2x+2y-2z]
                    8                                 2

     77   4             255   2  2                            11     2
 + (----*b )cos[4v] + (-----*b *e )cos[4v-2w+2x+2y-2z] + ( - ----*b*d )cos[3v+2x
     32                 16                                    4

               7     2                      53   3             105     2
+2y-2z] + ( - ---*b*d )sin[3v+2x+2y-2z] + (----*b )cos[3v] + (-----*b*e )cos[3v-
               2                            32                 16
                 17   2  2    1   4    7   2  2    1   2
2w+2x+2y-2z] + (----*b *d  + ---*d  - ---*d *e  - ---*d )cos[2v+2x+2y-2z] + (
                 4            2        4           2

 9   2  2    4    1   2  2    2                      7   4    27   2  2
---*b *d  + d  + ---*d *e  - d )sin[2v+2x+2y-2z] + (---*b  - ----*b *d
 2                2                                  8        4

    27   2  2    9   2                45   2
 + ----*b *e  + ---*b )cos[2v] + ( - ----*a *b*e)cos[2v-w+x+y-z] + (
    16           8                    16

    75   2  2    15   2  2    15   2                         5     2
 - ----*b *e  - ----*d *e  + ----*e )cos[2v-2w+2x+2y-2z] + (---*b*d )cos[v+2x+2y
    16           4            8                              4

         1     2                     27   3    9     2    9     2    3
-2z] + (---*b*d )sin[v+2x+2y-2z] + (----*b  - ---*b*d  + ---*b*e  + ---*b)cos[v]
         2                           32        2          8          4

        15   2                         15     2
 + ( - ----*a *e)cos[v-w+x+y-z] + ( - ----*b*e )cos[v-2w+2x+2y-2z] + (
        16                             16

    25   2  2                7   2  2                15   2
 - ----*d *e )cos[2w] + ( - ---*d *e )sin[2w] + ( - ----*a *b*e)cos[w-x-y+z] + (
    8                        2                       16

 5   2  2                      2  2                   9    4    15   4
---*b *d )cos[2x+2y-2z] + ( - b *d )sin[2x+2y-2z] + (----*a  + ----*b
 8                                                    64        32

    9   2  2    9    2  2    3   2    7   4    9   2  2    3   2    3   2    1
 - ---*b *d  + ----*b *e  + ---*b  + ---*d  - ---*d *e  - ---*d  + ---*e  + ---)
    4           16           8        6        4           2        8        4

]


showtime;


Time: 62 ms


end;


Time for test: 62 ms
@@@@@ Resources used: (0 0 39 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/camal.bib0000644000175000017500000000523111526203062023315 0ustar  giovannigiovanni% Bibliography entry for camal.tex.

@InProceedings{Barnes,
  author =      "A. Barnes and J. A. Padget",
  title =       "Univariate Power Series Expansions in {Reduce}",
  booktitle =   "Proceedings of ISSAC'90",
  year =        "1990",
  editor =      "S. Watanabe and M. Nagata",
  pages =       "82--7",
  organization =        "ACM",
  publisher =   "Addison-Wesley"
}

@Article{Barton67a,
  author =      "D. Barton",
  title =       "",
  journal =     "Astronomical Journal",
  year =        "1967",
  volume =      "72",
  pages =       "1281--7"
}

@Article{Barton67b,
  author =      "D. Barton",
  title =       "A scheme for manipulative algebra on a computer",
  journal =     "Computer Journal",
  year =        "1967",
  volume =      "9",
  pages =       "340--4"
}

@Article{Barton72,
  author =      "D. Barton and J. P. Fitch",
  title =       "The Application of Symbolic Algebra System to Physics",
  journal =     "Reports on Progress in Physics",
  year =        "1972",
  volume =      "35",
  pages =       "235--314"
}

@ARTICLE{Bourne,
        AUTHOR = {Stephen R. Bourne},
        TITLE = {Literal expressions for the co-ordinates of the moon.
                {I}. The first degree terms},
        JOURNAL = {Celestial Mechanics},
        VOLUME = {6},
        PAGES = {167--186},
        YEAR = {1972},
        GENERATED = {Mon Oct 23 19:42:01 GMT 1989 on fino}
}

@Book{Brown,
  author =      "E. W. Brown",
  title =       "An Introductory Treatise on the Lunar Theory",
  publisher =   "Cambridge University Press",
  year =        "1896"
}

@Manual{CAMALF,
  title =       "{CAMAL} {User's} {Manual}",
  author =      "J. P. Fitch",
  organization =        "University of Cambridge Computer Laboratory",
  edition =     "2nd",
  year =        "1983"
}

@Book{Delaunay,
  author =      "C. Delaunay",
  title =       "Th\'eorie du Mouvement de la Lune",
  publisher =   "Mallet-Bachelier",
  year =        "1860",
  series =      "(Extraits des M\'em. Acad. Sci.)",
  address =     "Paris"
}

@Article{Fateman,
  author = 	 {Richard J. Fateman},
  title = 	 {On the Multiplication of Poisson Series},
  journal = 	 {Celestial Mechanics},
  year = 	 {1974},
  OPTkey = 	 {},
  volume =	 {10},
  number =	 {2},
  month =	 {October},
  pages =	 {243--249}
}

@Article{Jefferys,
  author =      "W. H. Jeffereys",
  title =       "",
  journal =     "Celestial Mechanics",
  year =        "1970",
  volume =      "2",
  pages =       "474--80"
}
@Article{LectureNotes,
  author =      "J. P. Fitch",
  title =       "Syllabus for Algebraic Manipulation Lectures in Cambridge",
  journal =     "SIGSAM Bulletin",
  year =        "1975",
  volume =      "32",
  pages =       "15"
}


mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/camal.red0000644000175000017500000000624311526203062023337 0ustar  giovannigiovannimodule camal;  % Package for calculations in celestial mechanics.

% Author: John P. Fitch 

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(camal fourdom fourplus makefour hsub hdiff),
                '(contrib camal));

%% This section is to define macros and simple functions to handle the
%% data structures for harmonic forms.
%% The structure is a vector:
%% Coeff | FN | Angle | Next
%
%% This version only allows 8 angles.  Consider extending this later.

switch fourier;

%% A vector and counter to record link between angle names and index

global '(next!-angle!* fourier!-name!*);
next!-angle!* := 0;
if vectorp fourier!-name!* then <<
        for i :=0:7 do remprop(getv(fourier!-name!*, i),'fourier!-angle)
>>;
fourier!-name!* := mkvect 7;

%% For non Cambridge LISP add
smacro procedure putv!.unsafe(x,y,z); putv(x,y,z);
smacro procedure getv!.unsafe(x,y); getv(x,y);

%% Data abtraction says that we should define macros for access to
%% the parts of the Fourier structure

smacro procedure fs!:set!-next(f,p); putv!.unsafe(f, 3, p);

smacro procedure fs!:next(f); getv!.unsafe(f,3);

smacro procedure fs!:set!-coeff(f,p); putv!.unsafe(f, 0, p);

smacro procedure fs!:coeff(f); getv!.unsafe(f, 0);

smacro procedure fs!:set!-fn(f,p); putv!.unsafe(f, 1, p);

smacro procedure fs!:fn(f); getv!.unsafe(f, 1);

smacro procedure fs!:set!-angle(f,p); putv!.unsafe(f, 2, p);

smacro procedure fs!:angle(f); getv!.unsafe(f, 2);

%% Some support functions for angle expressions

symbolic procedure fs!:make!-nullangle();
begin scalar ans;
    ans := mkvect 7;
    for i:=0:7 do putv!.unsafe(ans,i,0);
    return ans;
end;

symbolic procedure fs!:null!-angle!: u;
  fs!:null!-angle cdr u;

symbolic procedure fs!:null!-angle u;
begin scalar ans, i, x;
    x := fs!:angle u;
    ans := t;
    i := 0;
top:
    if not(getv!.unsafe(x,i)=0) then return nil;
    i := i+1;
    if (i<8) then go to top;
    return ans;
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/fourplus.red0000644000175000017500000000661311526203062024142 0ustar  giovannigiovannimodule fourplus;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% ARITHMETIC

%% Addition of Fourier expressionsis really a merge operation

symbolic procedure fs!:plus!:(x,y);
 %% Top level addition of two fourier series
    if fs!:zerop!: y then x
    else if fs!:zerop!: x then y
    else get('fourier,'tag)
            . fs!:plus(copy!-tree cdr x, copy!-tree cdr y);

% I cannot rely on the CAMAL selective copy, so I take the coward's way
% out.
symbolic procedure copy!-tree x;
   if null x then nil
   else begin scalar ans;
      ans := mkvect 3;
      fs!:set!-coeff(ans,fs!:coeff x);
      fs!:set!-fn(ans,fs!:fn x);
      fs!:set!-angle(ans,fs!:angle x);
      fs!:set!-next(ans, copy!-tree fs!:next x);
      return ans
   end;

symbolic procedure fs!:plus(x, y);
  %% The real addition.  x is a new tree to which y must be merged.
  if null y then x
  else if null x then y
  else if fs!:fn x = fs!:fn y
     and angles!-equal(fs!:angle x, fs!:angle y) then
        begin scalar coef;
            coef := addsq(fs!:coeff x, fs!:coeff y);
        % Really I should deal with the zero case here
            if null car coef
              then return fs!:plus(fs!:next x, fs!:next y);
            fs!:set!-coeff(x, coef);
            fs!:set!-next(x, fs!:plus(fs!:next x, fs!:next y));
            return x
        end
    else if fs!:angle!-order(x, y) then <<
          fs!:set!-next(x, fs!:plus(fs!:next x, y));
          x >>
    else <<
          fs!:set!-next(y, fs!:plus(fs!:next y,x));
          y >>;

symbolic procedure angles!-equal(x, y);
% Are all angles the same?
begin scalar i;
    i := 0;
top:
    if not(getv!.unsafe(x,i)=getv!.unsafe(y,i)) then return nil;
    i := i+1;
    if (i<8) then go to top;
    return t;
end;

symbolic procedure fs!:angle!-order(x, y);
% Ordering function for angle expressions, also taking account of angle.
begin scalar ans, i, xx, yy;
    i := 0;
    xx := fs!:angle x;
    yy := fs!:angle y;
top:
    ans := (getv!.unsafe(xx,i)-getv!.unsafe(yy,i));
    if not(ans = 0) then return ans>0;
    i := i+1;
    if (i<8) then go to top;
    return
      if fs!:fn x = fs!:fn y then nil
       else if fs!:fn x = 'sin then nil else t;
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/camal/hdiff.red0000644000175000017500000001001211526203062023327 0ustar  giovannigiovannimodule hdiff;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%% Harmonic differentiation and Integration.

symbolic procedure hdiff(x, u);
if null x then nil
    else fs!:plus(hdiff(fs!:next x,u), hdiffterm(x,u));

symbolic procedure hdiffterm(x, u);
begin scalar n;
   n := getv!.unsafe(fs!:angle x, u);
   if n = 0 then return nil;
   n := multsq( n . 1, fs!:coeff x);
   if fs!:fn x = 'cos then return make!-term('sin, fs!:angle x, negsq n)
   else                    return make!-term('cos, fs!:angle x, n)
end;

symbolic procedure hdiff1(x, u);
if null x then nil
else begin scalar ans, aaa;
        ans := diffsq(fs!:coeff x, u);
        if ans then <<
            aaa := mkvect 3;
            fs!:set!-coeff(aaa, ans);
            fs!:set!-fn(aaa, fs!:fn x);
            fs!:set!-angle(aaa,fs!:angle x);
            fs!:set!-next(aaa, hdiff1(fs!:next x, u));
            return aaa >>
        else return hdiff1(fs!:next x, u)
end;

symbolic procedure simphdiff uu;
begin scalar x, u;
    if not (length uu = 2) then
        rerror(fourier, 10, "Improper number of arguments to HDIFF");
    x := car uu; uu := cdr uu;
    u := car uu;
    x := simp x;
    if not eqcar(car x, '!:fs!:) then x := !*sq2fourier x ./ 1;
    if not harmonicp u then
        return (get('fourier, 'tag) . hdiff1(cdar x, u)) ./ 1;
    x := hdiff(cdar x,get(u,'fourier!-angle));
    if null x then return nil ./ 1;
    return (get('fourier, 'tag) . x) ./ 1
end;

put('hdiff, 'simpfn, 'simphdiff);

symbolic procedure hint(x, u);
if null x then nil
%% Bind fs!:zero!-generated ??
    else fs!:plus(hint(fs!:next x,u), hintterm(x,u));

symbolic procedure hintterm(x, u);
begin scalar n;
   n := getv!.unsafe(fs!:angle x, u);
   if n = 0 then return make!-term(fs!:fn x, fs!:angle x, fs!:coeff x);
   n := multsq( 1 ./ n, fs!:coeff x);
   if fs!:fn x = 'cos then return make!-term('sin, fs!:angle x, n)
   else                    return make!-term('cos, fs!:angle x, negsq n)
end;

symbolic procedure hint1(x , u);
if null x then nil
else begin scalar aaa;
        aaa := mkvect 3;
        fs!:set!-coeff(aaa, simpint list(prepsq fs!:coeff x, u));
        fs!:set!-fn(aaa, fs!:fn x);
        fs!:set!-angle(aaa,fs!:angle x);
        fs!:set!-next(aaa, hint1(fs!:next x, u));
        return aaa
end;

symbolic procedure simphint uu;
begin scalar x, u;
    if not (length uu = 2) then
        rerror(fourier, 11, "Improper number of arguments to HINT");
    x := car uu; uu := cdr uu;
    u := car uu;
    x := simp x;
    if not eqcar(car x, '!:fs!:) then x := !*sq2fourier x ./ 1;
    if not harmonicp u then
        return (get('fourier, 'tag) . hint1(cdar x, u)) ./ 1;
    x := hint(cdar x,get(u,'fourier!-angle));
    if null x then return nil ./ 1;
    return (get('fourier, 'tag) . x) ./ 1
end;

put('hint, 'simpfn, 'simphint);

initdmode 'fourier;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/LICENSE0000644000175000017500000000244411526203062021515 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/0000755000175000017500000000000011722677357022036 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/xcolor.tex0000644000175000017500000000462311526203062024047 0ustar  giovannigiovanni\documentclass{article}

\usepackage[dvipdfm]{graphicx}
\usepackage[dvipdfm]{color}
\usepackage[dvipdfm]{hyperref}

\title{Program \char`\"{}xCOLOR\char`\"{}. User's Manual.}
\author{A.Kryukov \\
	Institute for Nuclear Physics \\
	Moscow State University \\
	119899, Moscow, RUSSIA \\
 	E-mail: kryukov@npi.msu.su \\
	Phone/Fax: (095) 939-0397}
\date{}

\setlength{\parindent}{0cm}

\begin{document}

\maketitle

\begin{abstract}
Program \char`\"{}xCOLOR\char`\"{} is intended for calculation the colour
factor in non-abelian gauge field theories. It is 
realized Cvitanovich algorithm {[}1{]}. In comparision with
\char`\"{}COLOR\char`\"{} program {[}2{]} it was made many improvements.
The package was writen by symbolic mode. This version is
faster then {[}2{]} more then 10 times.
\end{abstract} 

\ \\
After load the program by the following command \quad {\tt load xcolor}; \\
user can be able to use the next additional commands and operators. 

\subsubsection*{Command SUdim.}

Format: {\tt SUdim }; \\
\ \\
Set the order of SU group. \\
\ \\
The default value is 3, i.e. SU(3). 

\subsubsection*{Command SpTT.}

Format: {\tt SpTT }; \\
\ \\
Set the normalization coefficient A: Sp(TiTj) = A{*}Delta(i,j).
Default value is 1/2. 

\subsubsection*{Operator QG.}

Format: {\tt QG(inQuark,outQuark,Gluon)} \\
\ \\
Describe the quark-gluon vertex. Parameters may be any identifiers.
First and second of then must be in- and out- quarks correspondently.
Third one is a gluon. 

\subsubsection*{Operator G3.}

Format: {\tt G3(Gluon1,Gluon2,Gluon3)} \\
\ \\
Describe the three-gluon vertex. Parameters may be any identifiers.
The order of gluons must be clock. \\
\ \\
In terms of QG and G3 operators you input diagram in \char`\"{}color\char`\"{}
space as a product of these operators. For example. 

\begin{verbatim}


 Diagram:                       REDUCE expression:

            e1

         ---->---
        /        \
       |    e2    |
     v1*..........*v2  <===>  QG(e3,e1,e2)*QG(e1,e3,e2)
       |          |
        \   e3   /
         ----<---


Here: --->--- quark

      ....... gluon

\end{verbatim}

More detail see {[}2{]}. \\
\ \\
\ \\
\underline{References.} \\ 
\ \\
{[}1{]} P.Cvitanovic, Phys. Rev. D14(1976), p.1536.

{[}2{]} A.Kryukov \& A.Rodionov, Comp. Phys. Comm., 48(1988), pp.327-334.\\
\ \\
\ \\
\ \\
Please send any remarks to my address above! \\
\ \\
\ \\
Good luck!

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/xcolor.tst0000644000175000017500000002240111526203062024053 0ustar  giovannigiovanni%----------------------------------------------------------------------
% File:      xcolor.tst
% Purpose:   Tests for xcolor package.
% Author:    A.Kryukov
% E-address: kryukov@npi.msu.su
% Vertion:   2.2.1
% Release:   Aug. 17, 1994
%----------------------------------------------------------------------
% Revision:  14/03/91  Start
%            17/08/94  C0a,C0b,C0c,C0d
%----------------------------------------------------------------------

%load xcolor$
%in "xcolor.red"$

% on time$

SUdim n$        % Set the order of the SU(n) group, i.e. SU(n).
                % n=3 is a default value.

spTT 1/2$       % Set the normalization coefficient A:
		%     Sp(TiTj) = A*Delta(i,j)
                % A=1/2 is a default value.

                % QG(inQuark,outQuark,gluon) - quark-gluon vertex.
                % G3(gluon1,gluon2,gluon3)   - three-gluon vertex.

%----------------------------------------------------------------------
%               Run time (ms) without GC, compiled vertion.
%----------------------------------------------------------------------
% Test   | SUN3/60 |i386SX-25|DEC APX   |HP 735    |
%        |         |RAM=2M   |3000/128MB|          |
%        |         |         |R=20MB    |R=8MB     |
%----------------------------------------------------------------------
% c1     | 323     | 2800    |34        |40        |
% c2     | 102     | 170     |0         |0         |
% c3     | 102     | 160     |0         |10        |
%----------------------------------------------------------------------
% c4a    | 323     | 1270    |17        |20        |
% c4b    | 51      | 110     |-         |10        |
% c4c    | 135     | 160     |17        |0         |
%----------------------------------------------------------------------
% c0a    |         |         |17        |20        |
% c0b    |         |         |0         |0         |
% c0c    |         |         |17        |20        |
% c0d    |         |         |17        |0         |
%----------------------------------------------------------------------
% cz     | 187     | 990     |0         |10        |
% c0     | 374     | 330     |          |20        |
%----------------------------------------------------------------------
% c91    | 255     | 1480    |17        |10        |
% c92    | 323     | 1480    |17        |20        |
% c93    | 2397    | 2970    |68        |130       |
% c94    | 18411   | 35838   |495       |750       |
% c95    | 139009  | 262956  |3485      |5670      |
%----------------------------------------------------------------------

%----------------------------------------------------------------------
% Test 1. See test run in: A.Kryukov & A.Rodionov
%               Program "COLOR" for computing the group-theoretical
%               weight of Feynman diagrams in non-abelian theories.
%               Comp. Phys. Comm., 48(1988), 327-334.
%----------------------------------------------------------------------

%----------------------------------------------------------------------
%         1     4                  1  4                  1
% c1.   --*--<--*--     c2.   --<--*--*--     c3.   --<--*--<--
%      |  :     :  |         |     :  :  |         |     :     |
%      |  :     :  |         |     :  :  |         |     *4    |
%      |  :     :  |         |   ..:..   |         |    : :    |
%      |  :     :  |         |  :  :     |         |   :   :   |
%       --*-->--*--           --*--*-->--           ---*->-*---
%         2     3               2  3                   2   3
%----------------------------------------------------------------------
%
%         4      2
%        N  - 2*N  + 1
% C1 := ---------------
%             4*N
%
%
%            2
%         - N  + 1
% C2 := -----------
%           4*N
%
%
%            2
%        N*(N  - 1)
% C3 := ------------
%            4
%
%----------------------------------------------------------------------

c1 := QG(e4,e1,e5)*QG(e1,e2,e5)*QG(e2,e3,e6)*QG(e3,e4,e6);
c2 := QG(e4,e1,e5)*QG(e1,e2,e6)*QG(e2,e3,e5)*QG(e3,e4,e6);
c3 := QG(e3,e1,e4)*QG(e1,e2,e5)*QG(e2,e3,e6)*G3(e4,e6,e5);

%----------------------------------------------------------------------
%
% c4a. --*--<--*--      c4b. --*--<--*--      c4c. --*--<--*--
%     |  :     :  |         |  :     :  |         |  :     :  |
%     |   ..*..   |         |  :     :  |         |  *...  :  |
%     |     :     |         |  *.....*  |         |  :   : :  |
%     |   ..*..   |         |  :     :  |         |  *...:.   |
%     |  :     :  |         |  :     :  |         |  :   :    |
%      --*-->--*--           --*-->--*--           --*---*->--
%
%----------------------------------------------------------------------
%
%          2   2
%         N *(N  - 1)
% C4A := -------------
%              8
%
%
%          2   2
%         N *(N  - 1)
% C4B := -------------
%              8
%
%
% C4C := 0
%
%----------------------------------------------------------------------

c4a := QG(e4,e1,e7)*QG(e1,e2,e9)*QG(e2,e3,e8)*QG(e3,e4,e5)
      *G3(e5,e6,e7)*G3(e6,e8,e9);
c4b := c4a;
c4c := QG(e4,e1,e7)*QG(e1,e2,e9)*QG(e2,e3,e5)*QG(e3,e4,e8)
      *G3(e5,e6,e7)*G3(e6,e8,e9);

%----------------------------------------------------------------------
% Test 2.
%----------------------------------------------------------------------
%        ......1......
%       :             :
%       :    3   6    :
%      1*.3..*-6-*..4.*2
%       :    |   |    :  = N^2*(N^2-1)/8
% C0a:  2    V   |    5
%       :    |   |    :
%       :    7   9    :
%       :    |   |    :
%        ....*-8-*....
%            4   5
%
%        ......1......
%       :             :
%       :    3   6    :
%      1*.3..*-6-*..4.*2
%       :    |   |    :  = 0
% C0b:  2    V   |    5
%       :    |   |    :
%       :     \ /     :
%       :      X      :
%       :     / \
%       :    7   9    :
%       :    |   |    :
%        ....*-8-*....
%            4   5
%
%-------------------------------------------------------

C0a :=  g3(e1,e3,e2)*g3(e1,e5,e4)
       *qg(e6,e7,e3)*qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e9,e6,e4);

C0b :=  g3(e1,e3,e2)*g3(e1,e5,e4)
       *qg(e6,e9,e3)*qg(e9,e8,e5)*qg(e8,e7,e2)*qg(e7,e6,e4);

%--------------------------------------------------------
%
%        ......1......
%       :             :
%       :    3        :
%      1*.3..*-6--   -*2
%       :    |    \ / |  = (N^2-1)/8
% C0c:  2    V     X  V
%       :    |    / \ 4
%       :    |   |   -*6
%       :    7   9    :
%       :    |   |    5
%        ....*-8-*....
%            4   5
%
%        ......1......
%       :             :
%       :    3        :
%      1*.3..*-6------*2
%       :    |        |  = -(N^2-1)^2/8
% C0d:  2    V        A
%       :    |        4
%       :    |   |----*6
%       :    7   9    :
%       :    |   |    5
%        ....*-8-*....
%            4   5
%
%----------------------------------------------------------------------

C0c := g3(e1,e3,e2)*qg(e9,e4,e1)*qg(e6,e7,e3)
      *qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e4,e6,e5);

C0d := g3(e1,e3,e2)*qg(e4,e6,e1)*qg(e6,e7,e3)
      *qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e9,e4,e5);

%----------------------------------------------------------------------
%            1                     1
% cz.   .....*.....     c0.   .....*.....
%      :     :     :         :     :e2   :
%      :     :     :         :e3   *4    :e1
%      :     :     :         :    : :    :
%      :     :     :         :   :e4 :e6 :
%       .....*.....           ...*...*...
%            2                   2e5 3
%----------------------------------------------------------------------
%
%           2
% CZ := N*(N  - 1)
%
%
%        2   2
%       N *(N  - 1)
% C0 := -----------
%            2
%
%----------------------------------------------------------------------

cz := G3(e1,e2,e3)*G3(e1,e3,e2);
c0 := G3(e1,e2,e3)*G3(e3,e4,e5)*G3(e5,e6,e1)*G3(e2,e6,e4);

%$END$
%----------------------------------------------------------------------
% Test 3.
%----------------------------------------------------------------------

%----------------------------------------------------------------------
%
%                 1
% c9n.   .....*.......*.....
%       :     :   2   :     :
%       :     *.......*     :
%       :     :       :     :
%       :     :  ...  :     :
%       :     :       :     :
%       :     :   n   :     :
%        .....*.......*.....
%
%----------------------------------------------------------------------
%
% C91 := 0
%
%
%         2   2
% C92 := N *(N  - 1)
%
%
%          3   2
%         N *(N  - 1)
% C93 := -------------
%              4
%
%
%          2   4       2
%         N *(N  + 11*N  - 12)
% C94 := ----------------------
%                  8
%
%
%          3   4       2
%         N *(N  + 15*N  - 16)
% C95 := ----------------------
%                  16
%
%----------------------------------------------------------------------

c91 := G3(e3,e1,e1)*G3(e3,e2,e2);
c92 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e1,e4)*G3(e6,e5,e2);
c93 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e1,e7)*G3(e9,e8,e2);
c94 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e10,e7)*G3(e9,e8,e11)*G3(e12,e1,e10)*G3(e12,e11,e2);
c95 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e10,e7)*G3(e9,e8,e11)*G3(e12,e13,e10)*G3(e12,e11,e14)
      *G3(e15,e1,e13)*G3(e15,e14,e2);

%----------------------------------------------------------------------
$END$ % xColor tests
%----------------------------------------------------------------------
mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/xcolor.rlg0000644000175000017500000002443411527635055024051 0ustar  giovannigiovanniFri Feb 18 21:28:55 2011 run on win32
%----------------------------------------------------------------------
% File:      xcolor.tst
% Purpose:   Tests for xcolor package.
% Author:    A.Kryukov
% E-address: kryukov@npi.msu.su
% Vertion:   2.2.1
% Release:   Aug. 17, 1994
%----------------------------------------------------------------------
% Revision:  14/03/91  Start
%            17/08/94  C0a,C0b,C0c,C0d
%----------------------------------------------------------------------

%load xcolor$
%in "xcolor.red"$

% on time$

SUdim n$

        % Set the order of the SU(n) group, i.e. SU(n).
                % n=3 is a default value.

spTT 1/2$

       % Set the normalization coefficient A:
		%     Sp(TiTj) = A*Delta(i,j)
                % A=1/2 is a default value.

                % QG(inQuark,outQuark,gluon) - quark-gluon vertex.
                % G3(gluon1,gluon2,gluon3)   - three-gluon vertex.

%----------------------------------------------------------------------
%               Run time (ms) without GC, compiled vertion.
%----------------------------------------------------------------------
% Test   | SUN3/60 |i386SX-25|DEC APX   |HP 735    |
%        |         |RAM=2M   |3000/128MB|          |
%        |         |         |R=20MB    |R=8MB     |
%----------------------------------------------------------------------
% c1     | 323     | 2800    |34        |40        |
% c2     | 102     | 170     |0         |0         |
% c3     | 102     | 160     |0         |10        |
%----------------------------------------------------------------------
% c4a    | 323     | 1270    |17        |20        |
% c4b    | 51      | 110     |-         |10        |
% c4c    | 135     | 160     |17        |0         |
%----------------------------------------------------------------------
% c0a    |         |         |17        |20        |
% c0b    |         |         |0         |0         |
% c0c    |         |         |17        |20        |
% c0d    |         |         |17        |0         |
%----------------------------------------------------------------------
% cz     | 187     | 990     |0         |10        |
% c0     | 374     | 330     |          |20        |
%----------------------------------------------------------------------
% c91    | 255     | 1480    |17        |10        |
% c92    | 323     | 1480    |17        |20        |
% c93    | 2397    | 2970    |68        |130       |
% c94    | 18411   | 35838   |495       |750       |
% c95    | 139009  | 262956  |3485      |5670      |
%----------------------------------------------------------------------

%----------------------------------------------------------------------
% Test 1. See test run in: A.Kryukov & A.Rodionov
%               Program "COLOR" for computing the group-theoretical
%               weight of Feynman diagrams in non-abelian theories.
%               Comp. Phys. Comm., 48(1988), 327-334.
%----------------------------------------------------------------------

%----------------------------------------------------------------------
%         1     4                  1  4                  1
% c1.   --*--<--*--     c2.   --<--*--*--     c3.   --<--*--<--
%      |  :     :  |         |     :  :  |         |     :     |
%      |  :     :  |         |     :  :  |         |     *4    |
%      |  :     :  |         |   ..:..   |         |    : :    |
%      |  :     :  |         |  :  :     |         |   :   :   |
%       --*-->--*--           --*--*-->--           ---*->-*---
%         2     3               2  3                   2   3
%----------------------------------------------------------------------
%
%         4      2
%        N  - 2*N  + 1
% C1 := ---------------
%             4*N
%
%
%            2
%         - N  + 1
% C2 := -----------
%           4*N
%
%
%            2
%        N*(N  - 1)
% C3 := ------------
%            4
%
%----------------------------------------------------------------------

c1 := QG(e4,e1,e5)*QG(e1,e2,e5)*QG(e2,e3,e6)*QG(e3,e4,e6);


        4      2
       n  - 2*n  + 1
c1 := ---------------
            4*n

c2 := QG(e4,e1,e5)*QG(e1,e2,e6)*QG(e2,e3,e5)*QG(e3,e4,e6);


           2
        - n  + 1
c2 := -----------
          4*n

c3 := QG(e3,e1,e4)*QG(e1,e2,e5)*QG(e2,e3,e6)*G3(e4,e6,e5);


           2
       n*(n  - 1)
c3 := ------------
           4


%----------------------------------------------------------------------
%
% c4a. --*--<--*--      c4b. --*--<--*--      c4c. --*--<--*--
%     |  :     :  |         |  :     :  |         |  :     :  |
%     |   ..*..   |         |  :     :  |         |  *...  :  |
%     |     :     |         |  *.....*  |         |  :   : :  |
%     |   ..*..   |         |  :     :  |         |  *...:.   |
%     |  :     :  |         |  :     :  |         |  :   :    |
%      --*-->--*--           --*-->--*--           --*---*->--
%
%----------------------------------------------------------------------
%
%          2   2
%         N *(N  - 1)
% C4A := -------------
%              8
%
%
%          2   2
%         N *(N  - 1)
% C4B := -------------
%              8
%
%
% C4C := 0
%
%----------------------------------------------------------------------

c4a := QG(e4,e1,e7)*QG(e1,e2,e9)*QG(e2,e3,e8)*QG(e3,e4,e5)
      *G3(e5,e6,e7)*G3(e6,e8,e9);


         2   2
        n *(n  - 1)
c4a := -------------
             8

c4b := c4a;


         2   2
        n *(n  - 1)
c4b := -------------
             8

c4c := QG(e4,e1,e7)*QG(e1,e2,e9)*QG(e2,e3,e5)*QG(e3,e4,e8)
      *G3(e5,e6,e7)*G3(e6,e8,e9);


c4c := 0


%----------------------------------------------------------------------
% Test 2.
%----------------------------------------------------------------------
%        ......1......
%       :             :
%       :    3   6    :
%      1*.3..*-6-*..4.*2
%       :    |   |    :  = N^2*(N^2-1)/8
% C0a:  2    V   |    5
%       :    |   |    :
%       :    7   9    :
%       :    |   |    :
%        ....*-8-*....
%            4   5
%
%        ......1......
%       :             :
%       :    3   6    :
%      1*.3..*-6-*..4.*2
%       :    |   |    :  = 0
% C0b:  2    V   |    5
%       :    |   |    :
%       :     \ /     :
%       :      X      :
%       :     / \
%       :    7   9    :
%       :    |   |    :
%        ....*-8-*....
%            4   5
%
%-------------------------------------------------------

C0a :=  g3(e1,e3,e2)*g3(e1,e5,e4)
       *qg(e6,e7,e3)*qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e9,e6,e4);


         2   2
        n *(n  - 1)
c0a := -------------
             8


C0b :=  g3(e1,e3,e2)*g3(e1,e5,e4)
       *qg(e6,e9,e3)*qg(e9,e8,e5)*qg(e8,e7,e2)*qg(e7,e6,e4);


c0b := 0


%--------------------------------------------------------
%
%        ......1......
%       :             :
%       :    3        :
%      1*.3..*-6--   -*2
%       :    |    \ / |  = (N^2-1)/8
% C0c:  2    V     X  V
%       :    |    / \ 4
%       :    |   |   -*6
%       :    7   9    :
%       :    |   |    5
%        ....*-8-*....
%            4   5
%
%        ......1......
%       :             :
%       :    3        :
%      1*.3..*-6------*2
%       :    |        |  = -(N^2-1)^2/8
% C0d:  2    V        A
%       :    |        4
%       :    |   |----*6
%       :    7   9    :
%       :    |   |    5
%        ....*-8-*....
%            4   5
%
%----------------------------------------------------------------------

C0c := g3(e1,e3,e2)*qg(e9,e4,e1)*qg(e6,e7,e3)
      *qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e4,e6,e5);


         2
        n  - 1
c0c := --------
          8


C0d := g3(e1,e3,e2)*qg(e4,e6,e1)*qg(e6,e7,e3)
      *qg(e7,e8,e2)*qg(e8,e9,e5)*qg(e9,e4,e5);


            4      2
         - n  + 2*n  - 1
c0d := ------------------
               8


%----------------------------------------------------------------------
%            1                     1
% cz.   .....*.....     c0.   .....*.....
%      :     :     :         :     :e2   :
%      :     :     :         :e3   *4    :e1
%      :     :     :         :    : :    :
%      :     :     :         :   :e4 :e6 :
%       .....*.....           ...*...*...
%            2                   2e5 3
%----------------------------------------------------------------------
%
%           2
% CZ := N*(N  - 1)
%
%
%        2   2
%       N *(N  - 1)
% C0 := -----------
%            2
%
%----------------------------------------------------------------------

cz := G3(e1,e2,e3)*G3(e1,e3,e2);


          2
cz := n*(n  - 1)

c0 := G3(e1,e2,e3)*G3(e3,e4,e5)*G3(e5,e6,e1)*G3(e2,e6,e4);


        2   2
       n *(n  - 1)
c0 := -------------
            2


%$END$
%----------------------------------------------------------------------
% Test 3.
%----------------------------------------------------------------------

%----------------------------------------------------------------------
%
%                 1
% c9n.   .....*.......*.....
%       :     :   2   :     :
%       :     *.......*     :
%       :     :       :     :
%       :     :  ...  :     :
%       :     :       :     :
%       :     :   n   :     :
%        .....*.......*.....
%
%----------------------------------------------------------------------
%
% C91 := 0
%
%
%         2   2
% C92 := N *(N  - 1)
%
%
%          3   2
%         N *(N  - 1)
% C93 := -------------
%              4
%
%
%          2   4       2
%         N *(N  + 11*N  - 12)
% C94 := ----------------------
%                  8
%
%
%          3   4       2
%         N *(N  + 15*N  - 16)
% C95 := ----------------------
%                  16
%
%----------------------------------------------------------------------

c91 := G3(e3,e1,e1)*G3(e3,e2,e2);


c91 := 0

c92 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e1,e4)*G3(e6,e5,e2);


        2   2
c92 := n *(n  - 1)

c93 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e1,e7)*G3(e9,e8,e2);


         3   2
        n *(n  - 1)
c93 := -------------
             4

c94 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e10,e7)*G3(e9,e8,e11)*G3(e12,e1,e10)*G3(e12,e11,e2);


         2   4       2
        n *(n  + 11*n  - 12)
c94 := ----------------------
                 8

c95 := G3(e3,e4,e1)*G3(e3,e2,e5)*G3(e6,e7,e4)*G3(e6,e5,e8)
      *G3(e9,e10,e7)*G3(e9,e8,e11)*G3(e12,e13,e10)*G3(e12,e11,e14)
      *G3(e15,e1,e13)*G3(e15,e14,e2);


         3   4       2
        n *(n  + 15*n  - 16)
c95 := ----------------------
                 16


%----------------------------------------------------------------------
$

END$


Time for test: 31 ms
@@@@@ Resources used: (0 0 20 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/xcolor.txt0000644000175000017500000000500111526203062024055 0ustar  giovannigiovanni
                   Program "xCOLOR". User's Manual.
                   --------------------------------

                             A.Kryukov

                   Institute for Nuclear Physics
                      Moscow State University
                      119899, Moscow, RUSSIA
                    E-mail: kryukov@npi.msu.su
                    Phone/Fax: (095) 939-0397


                             Abstract

       Program "xCOLOR" is intended for calculation the colour
       factor  in  non-abelian  gauge  field  theories.  It is 
       realized Cvitanovich algorithm [1]. In comparision with
       "COLOR" program [2] it was  made many improvements. The
       package was  writen by  symbolic mode.  This version is
       faster then [2] more then 10 times.



  After load the program by the following command

          load xcolor;

user can be able to use the next additional commands and operators.

Command SUdim.
--------------

Format:  SUdim ;

Set the order of SU group.
The default value is 3, i.e. SU(3).

Command SpTT.
-------------

Format:  SpTT ;

Set the normalization coefficient A: Sp(TiTj) = A*Delta(i,j).
Default value is 1/2.

Operator QG.
------------

Format:  QG(inQuark,outQuark,Gluon)

Describe the quark-gluon vertex. Parameters may be any identifiers.
First and second of then must be in- and out- quarks correspondently.
Third one is a gluon.

Operator G3.
------------

Format:  G3(Gluon1,Gluon2,Gluon3)

Describe the three-gluon vertex. Parameters may be any identifiers.
The order of gluons must be clock.

   In terms of QG and G3 operators you input diagram in "color" space as
a product of these operators. For example.

            Diagram:                    REDUCE expression:

                e1
            ---->---
           /        \
          |     e2   |
        v1*..........*v2    <===>   QG(e3,e1,e2)*QG(e1,e3,e2)
          |          |
           \    e3  /
            ----<---

Here:  --->---     quark
       .......     gluon

More detail see [2].




                      References.
                      -----------

[1] P.Cvitanovic, Phys. Rev. D14(1976), p.1536.
[2] A.Kryukov & A.Rodionov, Comp. Phys. Comm., 48(1988), pp.327-334.

   Any remarks send to

                             A.Kryukov

                   Institute for Nuclear Physics
                      Moscow State University
                      119899, Moscow, RUSSIA
                    E-mail: kryukov@npi.msu.su
                    Phone/Fax: (095) 939-0397


   Good luck!

mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/xcolor.red0000644000175000017500000005317611526203062024030 0ustar  giovannigiovannimodule xColor;

%----------------------------------------------------------------------
% File:      xcolor.red
% Purpose:   Evaluation of colour factor for SU(n) gauge group
% Author:    A.Kryukov
% E-address: kryukov@npi.msu.su
% Vertion:   4.2.1
% Release:   Aug. 17, 1994
%----------------------------------------------------------------------
% Revision: 10/03/91  Start
%           17/08/94  RemoveG2
%           11/03/91  Split3GV
%           11/03/91  Exist3GV, ExistQGV
%           12/03/91  Put's and so on
%           14/03/91  CError
%           15/03/91  ChkCG
%           19/03/91  Color1
%           19/03/91  ZCoefP
%           17/08/94  RemoveG1
%----------------------------------------------------------------------

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%----------------------------------------------------------------------
%                         xColor package.
%----------------------------------------------------------------------

  imports AddSQ,MultSQ,NegSQ,QuotSQ,ExptSQ$
  exports Color0$

create!-package('(xcolor cface),'(contrib physics));

%----------------------------------------------------------------------
%
% Structure definitions.
% ----------------------
%
% c-grpah ::= (v1 v2 ...), where vK - vertex.
% c0-graph::= (sq . c-graph), where sq - standard quotient.
% vertex  ::= (vtype e1 e2 e3), where eI is name of corresponding edge.
% vtype   ::= G3|QG|QX, G3 - three gluon vertex type,
%                       QG - quark-gluon vertex type,
%                       GX - quark-gluon vertex type with free gluon
%                            (not yet implemented).
% If vtype = G3 then e1,e2,e3 are gluons.Its order is clock.
% If vtype = QG then e1 is in-quark, e2 is out-quark and e3 is a gluon.
%----------------------------------------------------------------------
%
% Example:
% --------
%             e1
%        ----->------
%       /            \
%       |     e2     |
%    v1 *............* v2  <=> c0=((1 . 1) (QG e3 e1 e2) (QG e1 e3 e2))
%       |            |
%       \     e3     /
%        ----->------
%
% Here: ----->----- quark,
%       ........... gluon.
%----------------------------------------------------------------------
%
%                   Transformation rules.
%                   ---------------------
%        (see: A.Kryukov & A.Rodionov
%              Program "COLOR" for computing the group-theoretic
%              weight of Feynman diagrams in non-abelian gauge theories.
%              Comp. Phys. Comm., 48(1988),327-334)
%
%        :                  (       :                    :        )
%        :            1     (       :                    :        )
%        :         = ---    (       *         -          *        )  (9)
%        :            A     (      / \                  / \       )
%   .....*.....             ( ....*-<-*....        ....*->-*....  )
%
%   --<--*--<--             ( -<--     --<-            --<--      )
%        :                  (     \   /          1                )
%        :         =  A     (      | |        - ---               ) (10)
%        :                  (     /   \          n                )
%   --<--*--<--             ( -<--     --<-            --<--      )
%
% Here: n - order of SU(n) group,
%       A - normalization factor. Sp(TiTj) = A*Delta(i,j).           (3)
%
%----------------------------------------------------------------------

%----------------------- Selector/Constructor -------------------------

symbolic smacro procedure GetCoef g0$ car g0$
symbolic smacro procedure GetVL g0$ cdr g0$

symbolic smacro procedure PutCoef(g0,c)$ rplacA(g0,c)$
symbolic smacro procedure PutVL(g0,vl)$ rplacD(g0,vl)$

symbolic smacro procedure GetTV v$ car v$
symbolic smacro procedure GetE1 v$ cadr v$
symbolic smacro procedure GetE2 v$ caddr v$
symbolic smacro procedure GetE3 v$ cadddr v$
symbolic smacro procedure GetInQ v$ GetE1 v$
symbolic smacro procedure GetOutQ v$ GetE2 v$

symbolic smacro procedure PutTV(v,tv)$ rplacA(v,tv)$
symbolic smacro procedure PutE1(v,e)$ rplacA(cdr v,e)$
symbolic smacro procedure PutE2(v,e)$ rplacA(cddr v,e)$
symbolic smacro procedure PutE3(v,e)$ rplacA(cdddr v,e)$
symbolic smacro procedure PutInQ(v,e)$ PutE1(v,e)$
symbolic smacro procedure PutOutQ(v,e)$ PutE2(v,e)$

symbolic smacro procedure MkG0(c,g0)$ c . g0$

symbolic smacro procedure ChkTV(v,tv)$ GetTV v eq tv$
symbolic smacro procedure QGVp v$ ChkTV(v,'QG)$
symbolic smacro procedure G3Vp v$ ChkTV(v,'G3)$

symbolic smacro procedure ZCoefP g0$ null numr GetCoef g0$

symbolic smacro procedure MkCopyG0 g0$
  %--------------------------------------------------------------------
  % Make a copy of structure g0 without copying coeffitient.
  %--------------------------------------------------------------------
  GetCoef g0 . MkCopy GetVL g0$

symbolic smacro procedure ChkHP v$
  %--------------------------------------------------------------------
  % Check headpole.
  %--------------------------------------------------------------------
  %            -->--                     ........
  %           /     \                   :        :
  %          |       |                  :        :
  %   .......*v      | = 0,     ........*v       : = 0
  %          |       |                  :        :
  %           \     /                   :        :
  %            --<--                     ........
  %--------------------------------------------------------------------
  GetE1 v eq GetE2 v or GetE1 v eq GetE3 v or GetE2 v eq GetE3 v$

%----------------------------- Debug ----------------------------------

%symbolic smacro procedure DMessage x$
%  << prin2 "====>"$ print x >>$

%----------------------------- Others ---------------------------------

symbolic procedure CError u$
  %--------------------------------------------------------------------
  % Output error message and interupt evaluation.
  %--------------------------------------------------------------------
  << terpri!* t$
     for each x in "***** xCOLOR:" . u do <<
       prin2!* " "$
       varpri(x,x,nil)
    >>$
    terpri!* t$
    Error1()
  >>$

symbolic procedure RemoveV(g0,v)$
  %--------------------------------------------------------------------
  % Remove vertex v from g0.
  % g0 is modified.
  %--------------------------------------------------------------------
  if null g0 then CError list("Vertex",v,"is absent.")
  else if cadr g0 eq v then rplacD(g0,cddr g0)
  else RemoveV(cdr g0,v)$

symbolic smacro procedure ExistQGV g0$
  %--------------------------------------------------------------------
  % Find quark-gluon vertex in g0.
  % Return quark-gluon vertex or nil.
  %--------------------------------------------------------------------
  assoc('QG,GetVL g0)$

symbolic smacro procedure Exist3GV g0$
  %--------------------------------------------------------------------
  % Find three-gluon vertex in g0.
  % Return three-gluon vertex or nil.
  %--------------------------------------------------------------------
  assoc('G3,GetVL g0)$

symbolic procedure MkCopy u$
  %--------------------------------------------------------------------
  % Make a copy of any structures.
  %--------------------------------------------------------------------
  if atom u then u else MkCopy car u . MkCopy cdr u$

symbolic smacro procedure RevV(v,e)$
  %--------------------------------------------------------------------
  % Revolve v such that e become the first edge.
  % v is modified.
  %--------------------------------------------------------------------
  if null G3Vp v or null memq(e,cdr v)
    then CError list("Edge",e,"is absent in vertex",v)
  else RevV0(v,e)$

symbolic procedure RevV0(v,e)$
  %--------------------------------------------------------------------
  % Revolve v such that e become the first edge.
  % v is modified.
  %--------------------------------------------------------------------
  if GetE1 v eq e then v
  else begin scalar w$
         w := GetE1 v$
         PutE1(v,GetE2 v)$
         PutE2(v,GetE3 v)$
         PutE3(v,w)$
         return RevV0(v,e)$
       end$ % RevV0

%------------------------ Global/Fluid --------------------------------

global '(SU_order Spur_TT n!*!*2!-1)$

SU_order := '(3 . 1)$        % default value
Spur_TT  := '(1 . 2)$        % default value
n!*!*2!-1:= '(8 . 1)$        % default value

%----------------------------------------------------------------------

symbolic procedure Color0 g0$
  %--------------------------------------------------------------------
  % g0 - c-graph.
  % Return colour factor (s.q.).
  %--------------------------------------------------------------------
  if ChkCG g0 then
    MultSQ(AFactor g0,Color1(MkG0(1 ./ 1,MkCopy g0),nil,nil ./ 1))
  else CError list "This is impossible!"$

symbolic procedure ChkCG g0$
  %--------------------------------------------------------------------
  % Check structure g0.
  % Return t if g0 is ok else output message and interupt program.
  %--------------------------------------------------------------------
  begin scalar x,u,vl,z$
    vl := g0$
    while vl do <<
      x := car vl$
      if GetTV x eq 'QG then <<
          if (z:=assoc(GetInQ x,u)) then
            if cdr z eq 'OutQ then rplacD(z,'ok)
            else CError
               list(car z,"can not use as in-quark in vertex",x)
          else u:=(GetInQ x . 'InQ) . u$
          if (z:=assoc(GetOutQ x,u)) then
            if cdr z eq 'InQ then rplacD(z,'ok)
            else CError
               list(car z,"can not use as out-quark in vertex",x)
          else u:=(GetOutQ x . 'OutQ) . u$
          if (z:=assoc(GetE3 x,u)) then
            if cdr z eq 'Gluon then rplacD(z,'ok)
            else CError list(car z,"can not use as gluon in vertex",x)
          else u:=(GetE3 x . 'Gluon) . u$
        >>
      else if GetTV x eq 'G3 then <<
          if (z:=assoc(GetE1 x,u)) then
            if cdr z eq 'Gluon then rplacD(z,'ok)
            else CError list(car z,"can not use as gluon in vertex",x)
          else u:=(GetE1 x . 'Gluon) . u$
          if (z:=assoc(GetE2 x,u)) then
            if cdr z eq 'Gluon then rplacD(z,'ok)
            else CError list(car z,"can not use as gluon in vertex",x)
          else u:=(GetE2 x . 'Gluon) . u$
          if (z:=assoc(GetE3 x,u)) then
            if cdr z eq 'Gluon then rplacD(z,'ok)
            else CError list(car z,"can not use as gluon in vertex",x)
          else u:=(GetE3 x . 'Gluon) . u$
        >>
      else CError list("Invalid type of vertex",x)$
      vl := cdr vl$
    >>$
    while u do <<
      X := car u$
      if null(cdr x eq 'ok) then
        CError list(car x,"is a free particle. Not yet implemented.")
      else if null idp car x then
        CError list(car x,"invalid as a name of particle.")
      else u:=cdr u$
    >>$
    return t$  % o.k.
  end$ % ChkCG

symbolic procedure AFactor g0$
  %--------------------------------------------------------------------
  % Calculate A-factor of g0:
  % A**(+-)/2
  % Return A-factor (s.q.).
  %--------------------------------------------------------------------
  begin scalar n$
    n := 0$
    for each x in g0 do if QGVp x or G3Vp x then n := n + 1$
    if remainder(n,2) neq 0 then
      CError list("Invalid structure of c0-graph.",
        if null g0 then nil
        else if null cdr g0 then car g0
        else 'times . g0)$
    return ExptSQ(Spur_TT,n/2)$
  end$ % AFactor

%symbolic procedure Color1(g0,st,result)$ Color2(g0,st,result)$

symbolic procedure Color1(g0,st,result)$
  %--------------------------------------------------------------------
  % g0 - c0-graph,
  % st - stack for still uncalculated graphs,
  % Return results - colour factor (s.q.).
  %--------------------------------------------------------------------
  if ZCoefP g0 or null GetVL g0 then
    if null st then AddSQ(GetCoef g0,result)
    else Color1(car st,cdr st,AddSQ(GetCoef g0,result))
  else begin scalar v$
%
%  Patch from 15/08/93
%
%   if (v:=Exist3GV g0) then <<
%        if ChkHP v then return Color1((nil ./ 1) . nil,st,result)$
%        g0 := Split3GV(g0,v)$
%        return Color1(car g0,cdr g0 . st,result)
%     >>
    if (v:=ExistQGV g0) then <<
        if ChkHP v then return Color1((nil ./ 1) . nil,st,result)$
        g0 := RemoveG(g0,v)$
        return
          Color1(car g0
                ,if cdr g0 then (cdr g0 . st) else st
                ,result
                )
      >>
    else if (v:=Exist3GV g0) then <<
         if ChkHP v then return Color1((nil ./ 1) . nil,st,result)$
         g0 := Split3GV(g0,v)$
         return Color1(car g0,cdr g0 . st,result)
      >>
    else CError list("Invalid structure of c0-graph."
           ,if null g0 then nil
            else if null cdr g0 then car g0
            else 'times . g0
                    )$
  end$ % Color1

symbolic procedure RemoveG(g0,v1)$
  %--------------------------------------------------------------------
  % Remove gluon which containe in quark-gluon vertex(v1).
  % Return pair (g1.g2), where g1 and g2 are graphs.
  %--------------------------------------------------------------------
  begin scalar v2$
    v2 := FindE(GetVL g0,GetE3 v1)$
    if car v2 eq v1 then v2 := FindE(cdr v2,GetE3 v1)$
    if null v2 then CError list("Free edge",GetE3 v1,"in vertex",v1)$
    v2 := car v2$
    if ChkHP v2 then return (((nil ./ 1) . nil) . nil)$
    if QGVp v2 then return RemoveG1(g0,v1,v2)
    else if G3Vp v2 then return RemoveG2(g0,v1,v2)
    else CError list("Invalid type of vertex",v1)$
  end$ % RemoveG

symbolic procedure FindE(vl,e)$
  %--------------------------------------------------------------------
  % Find vertex included edge e in vertex list vl.
  % Return vertex list started by vertex included e or nil.
  %--------------------------------------------------------------------
  if null vl then nil
  else if memq(e,cdar vl) then vl
  else FindE(cdr vl,e)$

symbolic procedure RemoveG1(g0,v1,v2)$
  %--------------------------------------------------------------------
  % Remove gluon between two quark-gluon verticies v1 and v2.
  % Return pair (g1.g2), where g1 and g2 are graphs.
  %--------------------------------------------------------------------
  begin scalar v3,v6,g1,w$
    RemoveV(g0,v1)$
    RemoveV(g0,v2)$
    %------------------------------------------------------------------
    %      --<--
    %     /     \
    %    |       |
    %  v1*.......*v2  =  n**2-1
    %    |       |
    %     \     /
    %      -->--
    %------------------------------------------------------------------
    %DMessage "2. 3j-symbol?"$
    if GetInQ v1 eq GetOutQ v2 and GetOutQ v1 eq GetInQ v2 then
      return (MkG0(MultSQ(n!*!*2!-1,GetCoef g0),GetVL g0) . nil)$
    %------------------------------------------------------------------
    %           v1
    %  v3--<----*--<--                    v3--<----
    %           :     \                            \
    %           :      |                            |
    %           :      |  =  (n**2-1)/n             |
    %           :      |                            |
    %           :     /                            /
    %  v5-->----*-->--                    v5-->----
    %           v2
    %------------------------------------------------------------------
    %DMessage "3. Arc.?"$
    v3 := FindE(GetVL g0,GetOutQ v1)$
    if GetInQ v1 eq GetOutQ v2 then <<
        if v3 then PutInQ(car v3,GetInQ v2)
        else CError list("Free edge",GetOutQ v1,"in vertex",v1)$
        return
          (MkG0(MultSQ(QuotSQ(n!*!*2!-1,SU_order),GetCoef g0),GetVL g0)
          . nil
          )$
      >>$
    v6 := FindE(GetVL g0,GetOutQ v2)$
    if GetOutQ v1 eq GetInQ v2 then <<
        if v6 then PutInQ(car v6,GetInQ v1)
        else CError list("Free edge",GetOutQ v2,"in vertex",v2)$
      return
        (MkG0(MultSQ(QuotSQ(n!*!*2!-1,SU_order),GetCoef g0),GetVL g0)
        . nil
        )$
      >>$
    %------------------------------------------------------------------
    %           v1
    %  v3--<--*--<--     v3--<--     --<--v4         v3--<--v4
    %         :                 \   /
    %         :                  | |             1
    %         :       =          | |          - ---            (10')
    %         :                  | |             n
    %         :                 /   \
    %  v5-->--*-->--     v5-->--     -->--v6         v5-->--v6
    %         v2
    %                            (a)                    (b)
    %------------------------------------------------------------------
    %DMessage "4. Common case."$
    if null v3 or null v6 then
      CError list("Invalid structure of c-graph"
                 ,if null g0 then nil
                  else if null cdr g0 then car g0
                  else 'times . g0
                 )$
    v3 := car v3$
    v6 := car v6$
    PutInQ(v3,GetInQ v2)$
    PutInQ(v6,GetInQ v1)$
    %------------------------------------------------------------------
    % Diagram (b)
    %------------------------------------------------------------------
    g1 := MkCopyG0 g0$
    w := GetVL g1$
    v3 := car member(v3,w)$
    v6 := car member(v6,w)$
    PutInQ(v3,GetInQ v1)$
    PutInQ(v6,GetInQ v2)$
    %------------------------------------------------------------------
    return
      (g0 . MkG0(MultSQ(QuotSQ(('-1 ./ 1),SU_order),GetCoef g1),w))$
  end$

symbolic procedure RemoveG2(g0,v1,v2)$
  %--------------------------------------------------------------------
  % Remove gluon between quark-gluon(v1) and three-gluon(v2) verticies.
  % Return pair (g1.g2), where g1 and g2 are graphs.
  %--------------------------------------------------------------------
  begin scalar g1,z,u1,u2$
    v2 := RevV(v2,GetE3 v1)$
    PutTV(v2,'QG)$
    g1 := MkCopyG0 g0$
    u1 := car member(v1,g1)$
    u2 := car member(v2,g1)$
    %------------------------------------------------------------------
    %      2  v2 3              3   v2 3               3   v2 3
    %  v6.....*.....v5       v6..   *......v5      v6...   *.....v5
    %         :                  .  |\                  . /|
    %         :1         =        . | \2       -         . |1
    %         :                    .|  \                / .|
    %  v4-->--*-->--v3       v4-->--*   ->-v3      v4->-   *--->-v3
    %         v1                 1  v1                     v1  2
    %
    %                              (a)                    (b)
    %------------------------------------------------------------------
    %DMessage "2. Common case."$
    z := GetE2 v1$
    PutE2(v1,GetE3 v1)$
    PutE3(v1,GetE2 v2)$
    PutE2(v2,z)$
    %------------------------------------------------------------------
    % Diagram (b)
    %------------------------------------------------------------------
    z := GetE1 u1$
    PutE1(u1,GetE3 u1)$
    PutE3(u1,GetE2 u2)$
    PutE2(u2,GetE1 u2)$
    PutE1(u2,z)$
    %------------------------------------------------------------------
    return (g0 . MkG0(NegSQ GetCoef g1,GetVL g1))$
  end$ % RemoveG2

symbolic procedure Split3GV(g0,v1)$
  %--------------------------------------------------------------------
  % Split three-gluon verticies v1 onto three quark-gluon verticies.
  % g0 is modified.
  % Return (g1 . g2), where g1 and g2 are graphs.
  %--------------------------------------------------------------------
  begin scalar v5,v6,g1,z$
    %------------------------------------------------------------------
    %         v2                   v2                  v2
    %         :                    :                   :
    %         :                    :                   :
    %         :          =         *v6       -         *v6        (9')
    %         :                   / \                 / \
    %  v4.....*.....v3       ....*-<-*....       ....*->-*....
    %         v1                 v1  v5              v1  v5
    %
    %                             (a)                 (b)
    %------------------------------------------------------------------
    v5 := list('QG,GenSym(),GenSym(),GetE2 v1)$
    v6 := list('QG,GenSym(),GetInQ v5,GetE1 v1)$
    PutTV(v1,'QG)$
    PutE1(v1,GetOutQ v5)$
    PutE2(v1,GetInQ v6)$
    PutVL(g0,v5 . v6 . GetVL g0)$
    %------------------------------------------------------------------
    % Diagram (b)
    %------------------------------------------------------------------
    g1 := MkCopyG0 g0$
    v1 := car member(v1,GetVL g1)$
    v5 := car member(v5,GetVL g1)$
    v6 := car member(v6,GetVL g1)$
    z := GetInQ v1$
    PutE1(v1,GetOutQ v1)$
    PutE2(v1,z)$
    z := GetInQ v5$
    PutE1(v5,GetOutQ v5)$
    PutE2(v5,z)$
    z := GetInQ v6$
    PutE1(v6,GetOutQ v6)$
    PutE2(v6,z)$
    %------------------------------------------------------------------
    return (g0 . MkG0(NegSQ GetCoef g1,GetVL g1))$
  end$ % Split3GV

%----------------------------------------------------------------------
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/xcolor/cface.red0000644000175000017500000001203311526203062023546 0ustar  giovannigiovannimodule CFace;
  imports Color0$
  exports simpQG,simpG3,simpCGparh$
%----------------------------------------------------------------------
% Purpose:   Interface between REDUCE and xColor module.
% Author:    A.Kryukov
% E-address: kryukov@npi.msu.su
% Vertion:   1.5.1
% Release:   Dec. 17, 1993
%----------------------------------------------------------------------
% Revision: 13/03/91  SUdim
%           15/03/91  simpCGraph
%           15/03/91  simCGraph1
%----------------------------------------------------------------------

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%------------------------ Global/Fluid --------------------------------

global '(SU_order Spur_TT n!*!*2!-1)$

SU_order := '(3 . 1)$        % default value
Spur_TT  := '(1 . 2)$        % default value
n!*!*2!-1:= '(8 . 1)$        % default value

%----------------------------------------------------------------------

symbolic procedure SUdim u$
  %--------------------------------------------------------------------
  % Set order of SU group.
  %--------------------------------------------------------------------
  << SU_order := simp car u$
     n!*!*2!-1 := AddSQ(MultSQ(SU_order,SU_order),('-1 ./ 1))$
  >>$

symbolic procedure SpTT u$
  %--------------------------------------------------------------------
  % Set value of A: Sp(TiTj) = A*Delta(i,j).
  %--------------------------------------------------------------------
  << Spur_TT := simp car u$ >>$

rlistat '(SUdim SpTT)$

%--------------- Set simpFunction for QG and G3 operators -------------

symbolic procedure simpQG u$ simpCV(u,'QG)$
symbolic procedure simpG3 u$ simpCV(u,'G3)$

put('QG,'simpfn,'simpQG)$
put('G3,'simpfn,'simpG3)$

symbolic procedure simpCV(u,x)$
  %--------------------------------------------------------------------
  % u is a kernel.
  % Add to mul!* simpCGraph function.
  % return u (s.q.)
  %--------------------------------------------------------------------
  if length u neq 3 then
    CError list("Invalid number of edges in vertex",u)
  else << if not ('simpCGraph memq mul!*) then
            mul!* := aconc!*(mul!*,'simpCGraph)$
          !*k2q(x . u)
       >>$

symbolic procedure simpCGraph u$
  %--------------------------------------------------------------------
  % u is a s.q..
  % Simplified u and return one (s.q.).
  %--------------------------------------------------------------------
  if null numr u or numberp numr u or red numr u then u
  else begin
         SU_order := simp list('!*SQ,SU_order,nil)$
         n!*!*2!-1 := AddSQ(MultSQ(SU_order,SU_order),('-1 ./ 1))$
         Spur_TT := simp list('!*SQ,Spur_TT,nil)$
         return QuotSQ(simpCGraph1(numr u,nil,1),!*f2q denr u)$
       end$ % simpCGraph

symbolic procedure simpCGraph1(u,v,w)$
  %--------------------------------------------------------------------
  % u is a s.f..
  % Seperate u on two part:
  %   1) v is a list of QG and G3 oerators$
  %   2) w is other (s.f.).
  % Return *w  (s.q.).
  %--------------------------------------------------------------------
  if numberp u or red u then
    if v then MultSQ(Color0 v,MultF(u,w) ./ 1) else MultF(u,w) ./ 1
  else if null atom mvar u and car mvar u eq 'QG then
         if ldeg u = 1 then simpCGraph1(lc u,mvar u . v,w)
         else CError list("Vertex",list('!*SQ,u ./ 1,t)
                         ,"can not be multiply by itself."
                         )
  else if null atom mvar u and car mvar u eq 'G3 then
         if ldeg u = 1 then simpCGraph1(lc u,mvar u . v,w)
         else if ldeg u = 2 then simpCGraph1(lc u,mvar u . mvar u . v,w)
         else CError list("Vertex",list('!*SQ,u ./ 1,t),
                      "can not be multiplied by itself more then twice."
                         )
  else simpCGraph1(lc u,v,MultF(!*p2f lpow u,w))$

%----------------------------------------------------------------------
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/0000755000175000017500000000000011722677357021676 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/roots/multroot.red0000644000175000017500000005633611526203062024250 0ustar  giovannigiovannimodule multroot;  % Code for solving polynomial sets solvable by
                  % backsubstitution.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1994,1995.  Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment  modules allroot, bfauxil, bfdoer, bfdoer2, complxp, rootaux and
         realroot needed also;


fluid '(rterr!! mrerr!! rootacc!#!#);

switch fullprecision,compxroots;

put ('multroot,'psopfn,'multroot1);

symbolic procedure multroot1 u;
  if length u neq 2 then rederr
  "2 args required: pr=desired precision, pl=polynomial list"
  else multroot0(car u,cadr u);

symbolic procedure multroot0(pr,pl);
  begin scalar v,ans,pr1,c,r,rterr!!,ra;
    !*protfg := t; pr1 := precision 0; r := !*rounded; c := !*complex;
    ra := rootacc!#!#;
  v := errorset!*({'multroot2,{'multroot01,mkquote pr,mkquote pl}},nil);
    !*protfg := nil; rootacc!#!# := ra;
    return if errorp v then
      <> where !*msg=nil);
           (if rterr!! then lprim
"for some root value(s), a variable depends on an arbitrary variable"
              else if mrerr!! then lprim mrerr!!) where !*msg=t;
        mk!*sq mksq({'multroot,pr,reval pl},1)>>
      else (<> where !*msg=nil) end;

share npoly!*,pr!*,pl!*;

algebraic procedure multroot01(pr,pl);
comment
pl is a list of n polynomials in a tree containing branches each one of
which contains one univariate polynomial, one bivariate polynomial, ...
one n-variable polynomial in which each successive polynomial adds one
additional variable.  These branches may branch, so that one variable
gives rise to several branches.  These polynomials are the standard
Groebner output.  All polynomials are real with integer coefficients.
pr is the desired minimum precision of the solution set for real roots.
This program will go through each branch by solving p_1 for the first
variable, then will test each succeeding polynomial for the precision of
each additional variable, returning to the initial solution at higher
precision when necessary, until the last polynomial's solution has been
obtained at precision >= pr.  The solutions are collected in the
variable solns!*.  They are then combined into the final output form by
the function combinesolns();
   begin scalar n,links,path,paths,fl,fl1,var,rts,solns; integer maxv;
     npoly!* := n := length pl - 1;
    % 0..n will be the indices of arrays.
     clear vll!#,vll2!#,varbl!#,poln!#,rtlst!#,derv!#,pra!#,fxer!#;
     array vll!#(n),vll2!#(n);
     pl!* := pl;
     pl := pl!* := reval cleardenr pl!*;
    % vll!# will be an array of {list of variables}
     for j := 0:n do vll!# j := getvars part(pl,j+1);
    % vll!# will be a useful tool for finding and tracing trees.
    % Trees might possibly be totally independent if there are more
    % than one of the vll!#(j) of length 1, or else trees might branch
    % if there is more than one way of extending the variable lists from
    % a given node.  The tree following algorithm must allow for any of
    % these.  It will be easiest to have a tree algorithm which simply
    % enumerates branches as a list of the j values which span the total
    % branch from root to tip.
     links := findlinks n;
     paths := links2paths links;
    % if paths = nil then multroot fails.
     lisp(mrerr!! := nil);
     if not paths then lisp(mrerr!! :=
       "multroot fails because no univariate polynomial was given.");
     lisp(if mrerr!! then rederr "1");
     fl := nil;
     for j := 0:n do
       <>;
     if fl = t then lisp(mrerr!! :=
       "multroot failure: at least one polynomial has no single base.");
     lisp(if mrerr!! then rederr "2");
    % In multroot2, we solve for real roots under the condition that
    % the precision of each root >= pr;
     array varbl!#(n),poln!#(n),rtlst!#(n),derv!#(n),pra!#(n),fxer!#(n);
    % these arrays are used in solvepath, but we don't want them to be
    % redefined for different paths.  Maximum index will be <=n, but we
    % will be careful not to go out of bounds.
     vlist!* := rlist!* := solns!* := {};
     pr!* := pr;
     return paths end;

symbolic operator subsetp,algunion,cleardenr;

symbolic procedure cleardenr pl;
   begin scalar plo;
     for each pol in cdr pl do
        plo := (if eqcar(pol,'quotient) then cadr pol else pol) . plo;
     return 'list . reversip plo end;

symbolic procedure algunion(a,b); 'list . union(cdr a,cdr b);

algebraic procedure findlinks n;
   begin scalar links,fl,fl1,var;
     links := {};
    % we have in vll!# an array of lists of variables.  If they can form
    % a strict hierarchy, we have no problem in solving the polynomials.
    % But if they don't, we have to form an artificial hierarchy by
    % augmenting the lists.
     for m := 1:n do
       if m=1 then for j := 0:n do vll2!# j :=
         if length(fl := vll!# j)=1 then
           if not var then var := fl else vll!# j := append(fl,var)
           else fl
         else for k := 1:2 do
           for j := 0:n do
             if length(fl := vll!# j)=m then vll2!# j :=
               if length var>;
         if fl1=t then
         <> >> >> >>
      until not fl ;
    return links end;

algebraic procedure multroot2 paths;
  begin scalar path,lfp,fl,soln1,soln2,pr0,nlst;
 lp: path := first paths; paths := rest paths;
     lfp := last path; fl := nil;
     for each path2 in paths do if last path2 = lfp then fl := t;
     if fl then <>;
    % this is the place where it is reasonable to eliminate spurious
    % real or imaginary parts of complex roots.
     soln1 := solvepath path;
     if lisp !*compxroots and (nlst := spurival soln1) neq {} then
       <>;
     if not member(v0!*,vlist!*) then
       % here we save the initial roots or realroots answers so they
       % won't be computed redundantly.
       <>;
     if soln1={} then <>;
     solns!* := append(solns!*,{soln1});
     if paths neq {} then go to lp;
 cl: clear vll!#,vll2!#,varbl!#,poln!#,rtlst!#,derv!#,pra!#,fxer!#;
     return if fl then {} else combinesolns() end;

algebraic procedure combinesolns();
comment
 We have all of the separate solutions in solns!* and a list of the
independent variables in vlist!* and the root values of the base
variables in the list rlist!*.  So we can use this information to
combine the separate solutions into an outer product of all solutions.
In doing this, we will first combine all terms with the same base
variable, then combine all of those outer products into one grand
product.  Finally, we sort the variables into standard order and sort
the values into order by the real part of the first variable.$
  begin scalar vlist,rlist,prod,solns,var,rts,grandprod;
     vlist := vlist!*; rlist := rlist!*; grandprod := {};
lp2: var := first vlist; vlist := rest vlist;
     rts := first rlist; rlist := rest rlist;
     prod := {}; solns := solns!*;
     if rts neq {} and solns neq {{}} then
       for each soln1 in solns do
         if isvar(first soln1,var)
           then prod := if prod = {} then soln1
             else outcombine1(rts,prod,soln1);
     grandprod := if grandprod = {} then prod
        else outcombine2(grandprod,prod);
     if vlist neq {} then go to lp2;
     grandsoln!* := grandprod;
     sortvars();
     screensolns1();
     return sortvals();
     end;

symbolic operator screensolns1;

symbolic procedure screensolns1();
   begin scalar inlist,outlist,termout,vr,vr1,vl,vl1,fl;
     inlist := reversip cdr algebraic varsortsolns!*;
     for each rts in inlist do
       <>
%              else if vl1 neq vl then fl := t>>;
               else if algebraic lisp {'difference,vl1,vl} neq 0
                then fl := t>>;
        if not fl then outlist := ('list.reversip termout).outlist>>;
      return algebraic varsortsolns!* := ('list . outlist) end;

algebraic procedure solvepath path;
   begin scalar
    n,vl,vlll,m,s,rts0,fl,fl1,b,tst,f,ff,pr1,prf,strt,dfx,rtl,rt1,!*msg,
    zz,r,c;
     n := length path;
     if (r := lisp !*rounded) then off rounded;
     if (c := lisp !*complex) then off complex;
    % now we assemble the polynomial tree which represents this path.
     vl := for j := 1:n collect part(pl!*,part(path,j)+1);
    % we now have ordered the polynomials in order of the number of
    % variables.
     vlll := for j := 1:n collect vll!# part(path,j);
    % and have now ordered the variable list in increasing number of
    % variables, so that vlll correctly lists the variables in the
    % reordered list vl;
    % Now we solve for real roots under the condition that the precision
    % of each root >= pr!*;
     n := n-1; % this is done because arrays will have indices 0..n.
     pra!#(0) := pr!*+10; on rounded;
     for j := 1:n do pra!#(j) := pr!*;
    % a starting point: this may have to be increased if necessary.
     v0!* := varbl!#(0) := first first vlll;  strt := t;
str: precision pra!#(0);
     rts0 := if strt and member(v0!*,vlist!*)
       then (r0!* := part(rlist!*,membno(v0!*,vlist!*)))
       else if lisp !*compxroots then roots first vl
         else realroots first vl;
     r0!* := rts0;
     rtlst!#(0) := for each rt in rts0 collect {rt};
     m := 0; strt := nil;
nxt: fl := fl1 := b := 0;
     if (m := m+1) > n then <>;
     poln!#(m) := part(vl,m+1);
     rtl := {};
     for each rt in rtlst!#(m-1) do
       <>);
         if rt1 neq {} then rtl := append(rtl,rt1)>>;
     rtlst!#(m) := rtl;
     s := length rtlst!#(m);
     varbl!#(m) := elim(part(vlll,m),part(vlll,m+1));
     derv!#(m) :=
       {-(df(poln!#(m),varbl!#(0))+
         if m<2 then 0 else for j := 1:(m-1) sum
           (df(poln!#(m),varbl!#(j))*first derv!#(j)/second derv!#(j)))
        ,df(poln!#(m),varbl!#(m))};
lp1: if (b := b+1) > s then
       < 0 then
          <pra!#(j) then
                 <> >> >>;
         if prf then go to str else go to nxt>>
       else
         <10.0^-pr!*
             then fl1 := tst;
           if fl1 > fl then fl := fl1;
           go to lp1>>;
ret: if r then on rounded; if c then on complex;
     if not lisp !*fullprecision then go to rt2;
     precision pra!#(0); return
       if m=0 then rtlst!#(0)
       else for each rtl in rtlst!#(m) collect
         for j := 0:m collect roundroot(part(rtl,j+1),pra!#(j));
rt2: precision pr!*;
     return rtlst!#(m)
     end;

algebraic procedure testsub(lst,quotlst,m);
 % this substitutes the variable value list lst into the derivative
 % quotient quotlst, but avoids 0/0 errors.  For the purposes to which
 % we are putting testsub, infinity is replaced by 1.
  begin scalar nmr,dnr,dnv;
    nmr := first quotlst; dnr := second quotlst;
    ex!! := algebraic nmr/algebraic dnr;
    nmr := num ex!!; dnr := den ex!!;
    while (dnv := sub(lst,dnr))=0 do if sub(lst,nmr)=0 then
      <>
          else (<> where !*msg=t) >>
      else (<> where !*msg=t);
    return sub(lst,nmr)/dnv end;

symbolic procedure sortvals1(a,b);
   begin scalar c,d; a := cdr a; b := cdr b;
    % since some variables (and hence their values) may not occur...
 lp: if not a or not b then return nil;
     c := caddar a; d := caddar b;
     algebraic (c := repart c); algebraic (d := repart d);
     algebraic if c < d then return t else if c = d then go to tst;
     return nil;
tst: if (a := cdr a) then <> end;

algebraic procedure getvars p;
   begin scalar vl,v,v1,lt,c,!*msg;
     c := lisp !*complex; if not c then on complex;
     vl := {};
lp1: if numberp(v := mainvar p) then go to ret
        else if not member(v,vl) then vl := v . vl;
     lt := lcof(p,v); p := reduct(p,v);
lp2: if numberp(v1 := mainvar lt) then goto lp1
        else if not member(v1,vl) then vl := v1 . vl;
     lt := lcof(lt,v1); go to lp2;
ret: if not c then off complex;
     return reverse vl end;

symbolic operator spurival,spurifix;
share val!$,val2!$,eps!$,pr!*;

symbolic procedure spurival vals;
  % produces a list of flattened index of suspicious terms (starting at
  % 1) or {}.  spurifix then checks the indexed items and trims spurious
  % values.
   begin scalar fl,r,c,!*msg; integer m; eps!$ := 10.0^-pr!*;
     r := !*rounded; c := !*complex; on rounded; off complex;
     for each rlst in cdr vals do for each val in cdr rlst do
        <>;
     if not r then off rounded; if c then on complex;
     return 'list . reversip fl end;

algebraic procedure testval1 val;
  begin scalar rl,im;
    rl := abs repart val; im := abs impart val;
    if rl>0 and im>0 and im>;
      eq1 := car lst1; eq2 := car lst2; m := m+1;
      lst1 := cdr lst1; lst2 := cdr lst2;
      if not m0 or m>;
      if not ndx then m0 := nil else
         <>;
      eq1 := eq1;
      val!$ := prepsq simp!* (val1 := caddr eq1);
      val2!$ := prepsq simp!* (val2 := caddr eq2);
      tri := algebraic testval2(val!$,val2!$);
      if tri=aeval 'failed then
        <<((lprim
             "match failed! root stripping aborted: raw roots returned")
             where !*msg=t); soln3 := sol0; go to ret>>;
      eq3 := if tri=0 then eq1
         else {'equal,cadr eq1,
                if freeof(car(val1 := cdr val1),'i)
                  then if tri=1 then cadr val1 else car val1
                  else if tri=1 then car val1 else cadr val1};
      lst3 := eq3 . lst3; go to lp2;
 ret: if not r then off rounded; if c then on complex;
      return soln3 end;

algebraic procedure testval2(a,b);
   begin scalar rl1,rl2,im1,im2;
      rl1 := abs repart a; rl2 := abs repart b; im1 := abs impart a;
      im2 := abs impart b;
      return if rl1=rl2 then if im1=im2 then 0 else 2
                else if im1=im2 then 1 else failed end;

%%end;    %this is the end of the changed or added functions

symbolic procedure isvar(x,var);
  (if eqcar(x,'list) then cadadr x else cadr x)=var;

symbolic operator isvar;

algebraic procedure outcombine1(rts,p1,p2);
 % here p1 is an outerproduct, and p2 is another outerproduct with
 % the same first variable. from the two, we form a single outerproduct
 % by forming all lists with the first variable appearing only once.
 % rts is the root list for the base variable.  A complication is caused
 % by the possibility that one of more root values may be missing from
 % p1, p2, or both.
  begin scalar prod,p1strt,p1end,p2strt,p2end;
     prod := {};
     for each rt in rts do
   < 0 and p2strt > 0 then
       for n1 := p1strt:p1end do for n2 := p2strt:p2end do
         prod := append(prod,{append(part(p1,n1),rest part(p2,n2))})>>;
     return prod end;

symbolic procedure findvals(p,rt);
   begin scalar val,pp,pp1; integer n,b,e;
     val := algebraic lisp caddr rt; pp := cdr p;
 lp: pp1 := car pp; pp := cdr pp; n := n+1;
%    if algebraic lisp caddr cadr pp1 = val then
     if algebraic lisp {'difference,caddr cadr pp1,val} = 0 then
       <>;
     if pp then go to lp;
     return 'list . {b,e} end;

symbolic operator findvals;

algebraic procedure outcombine2(p1,p2);
   begin scalar prod;
      prod := {};
      for each r1 in p1 do for each r2 in p2 do
         prod := append(prod,{append(r1,r2)});
      return prod end;

symbolic procedure sortvars();
   algebraic varsortsolns!* :=
     'list . for each rts in cdr algebraic grandsoln!*
       collect 'list . sort(cdr rts,
         function (lambda(a,b); ordop(cadr a,cadr b)));

symbolic operator sortvars;

symbolic procedure sortvals();
   algebraic sortvals!* := 'list . sort(cdr algebraic varsortsolns!*,
     function sortvals1);

symbolic operator sortvals;

algebraic procedure cabs x;
  if lisp !*compxroots then sqrt((repart x)^2 + (impart x)^2) else x;

algebraic procedure membno(n,l);
   if n=first l then 1
     else if rest l = 0 then 0 else 1 + membno(n,rest l);

algebraic procedure getpaths n;
  % this is used to call links2paths for testing purposes only.
   begin scalar links; links := {};
     for j := 0:n do for k := 0:n do
        if j neq k and subset1(vll!# j,vll!# k) then
        links := append(links,{{j,k}});
     return links2paths links end;

algebraic procedure links2paths links;
  begin scalar paths,paths2,bases,fl,fl2;
     paths := paths2 := {}; bases := root npoly!*;
    % multroot will not work if there are no bases;
     if bases = {} then return nil;
    % extend from bases if possible.
     for each base in bases do
       <>;
         if not fl then paths := append(paths,{{base}})>>;
    % now extend each path in paths2 if possible.  When fully
    % extended, add path to paths.
ext: fl2 := nil;
     for each path in paths2 do
       <>;
        if not fl then paths := append(paths,{path});
        paths2 := delete(path,paths2)>>;
     if fl2 then go to ext;
     return paths end;

symbolic operator delete;

algebraic procedure last x; first reverse x;

symbolic procedure subset1(a,b);
   length b-length a=1 and subsetp(a,b);

symbolic operator subset1;

algebraic procedure root n;
   begin scalar trrt; trrt := {};
     for j := 0:n do if length vll!# j=1 then trrt := append(trrt,{j});
     return trrt end;

algebraic procedure pfx(pr,fl);
   begin scalar prf,f,ff;
     prf := fl*10.0^pr; ff := 1.0; f := 0;
     while prf*ff>1.0 do <>;
     return f end;

symbolic procedure roundroot(a,p);
<
>;

symbolic operator roundroot;

algebraic procedure elim(a,b);
  % compares list b with list a (whose length is shorter by 1) and
  % returns the unmatched member.
   begin scalar x;
     for each el in b do if not member(el,a) then x := el;
     return x end;

algebraic procedure combinerts(r0,r1);
   begin scalar xout; xout := {};
     return if r1 = {} then {} else
       <> end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/roots2.red0000644000175000017500000000527111526203062023603 0ustar  giovannigiovannimodule roots2; % Header module for roots2 package.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment
  Revisions:
  30 March 95  Mod 1.96 adds to multroot the capability of solving
                polynomial trees which are determinate but whose
                structure may lack a stairstep pattern of variables,
                or may contain more polynomials than variables.
                Polynomials can now have denominators, which are
                ignored since only the numerators are used.
                  Spurious small real or imaginary parts of complex
                roots, which can arise due to numeric substitution, are
                now detected and eliminated.  However, vital small real
                or imaginary parts are retained (as in the roots
                program.)
                  Error handling is improved.  Each error now returns
                an error message and then multroot(pr,pl) where pr is
                the precision of answers and pl is the equivalent
                polynomial tree whose processing failed. ;

create!-package ('(roots2 realroot nrstroot multroot),
                 '(contrib roots));

symbolic procedure realroots u; nil; % to fool loader.

% Other packages needed.
load_package roots;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/rootaux.red0000644000175000017500000001732511526203062024057 0ustar  giovannigiovannimodule rootaux; % Support for allroot, previously in realroot.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!!nfpd max!-acc!-incr lm!#);

max!-acc!-incr := 8;

fluid '(!*xn !1rp acc!# ss!# rootacc!#!# rprec!# cpxt!# pfactor!# prx!#
  nrst!$ intv!# rlrt!# lims!# pnn!# rr!# !*strm !*xnlist sh!#
  !*nosturm);

fluid '(!*compxroots !*bftag !*roundbf !*msg);

symbolic procedure accupr1(y,p);
 % if acc!# is insufficient to separate this root from roots of
 % other factors of !1rp, increase accuracy.
   <acc!# do
          <>;
     y . (acc!#+ss!#)>> where acr=acc!#;

symbolic procedure uniroots(p,rrts);
   <>
         where !*bftag=t,!*roundbf=t,rprec!#=rprec!#)
     else uniroot0(p,rrts)>> where !*msg=nil;

symbolic procedure uniroot0(p,rrts);
   begin
    scalar c,lim,n,p1,pp,q,r,r1,rr,x,cp,m,cpxt!#,pfactor!#,acc,s,
       prx!#,m1,nrst!$,intv!#,rlrt!#,rrc;
    integer ss!#;
      p := cdr(c := ckpzro p);
      if (c := car c) then c := {({(caaar c) . 6}. cdar c)};
     % lims!# code is applicable only when realroots is called.
      if lims!# then if not cdr lims!# or
         <=0 else car r>0)
           or r1 neq 'infty and
              (if xclp r1 then cadr r1<=0 else car r1<0)>>
            then c := nil;
      if atom p then
        <>;
      if cpxp p then cpxt!# := t;
      m := powerchk p; % top level powergcd factoring.
      p := if !*nosturm and rrts neq 0 then {(!1rp := p) . 1}
         else gfsqfrf p;
      automod !1rp; n := pnn!#;
      p1 := !1rp; % save original one-factor polynomial.
      if length p>1 then pfactor!# := prx!# := n;
      if m then
         <
>;
      lim := acc!#+max!-acc!-incr;
      q := p; r1 := nil; r := c; acc := acc!#;
loop: pp := automod car(x := car q); cp := nil;
      if cpxp pp then
         <>;
     % first find the real roots and complex pairs, if any.
 mod: pp := automod pp;
     % powerchk may succeed after sqfrf or csep succeeds.
      if (m1 := powerchk pp) then <>;
      if not m and not m1 then
         <>;
      rr := if m1 then
         rtpass2(m1,rtpass1(pp,m1,rrts,if m then m1*m else m1),
           rrts,p1,acc,m)
            else rtpass1(pp,m,rrts,m);
      if m then rr := rtpass2(m,rr,rrts,p1,acc,nil);
 col: rrc := for each y in rr collect car y;
     % the following test should never succeed!
      for each y in rrc do if member(y,r1) then rooterr y;
      r1 := append(r1,rrc);
      r := append(r,list(rr . cdr x));
 cpr: if cp and rrts>0 then
     % now find roots of cp, which has only complex roots.
         <>;
      if (q := cdr q) and not domainp caar q then go to loop;
 ret: return outecho r end;

symbolic procedure rtpass1(pp,m,rrts,m2);
   doroots(pp,rrts,nil) where lims!#=limadj m2,ss!#=ceillog m;

symbolic procedure rtpass2(m,rr,rrts,p1,acc,m2);
   begin scalar pp,s; s := ceillog m;
      return for each y in rr join
         (<>
           where !1rp=p1,acc!#=max(acc,cdr y-s),rr!#=1,
             ss!#=0,pfactor!#=(pfactor!# or cdr y-s>acc),
             lims!#=limadj m2) end;

symbolic procedure doroots(pp,r,s);
   if r=0 then rtsreal(pp,s) else allroots(pp,s);

symbolic procedure rooterr y;
   lprim list(y,"is false repeated root.  Send input to S. L. Kameny")
    where !*msg=t;

symbolic procedure schinf z;
   begin scalar v,v1; integer r;
      v := schinf1(car !*strm,z := sgn z);
      if v=0 then return schplus realrat z;
      for each p in cdr !*strm do
         <>;
      return r end;

symbolic procedure schplus z; sch ratplus(z,offsetr(caar !*strm,z));

symbolic procedure schinf1(p,z);
   if z=0 then car lastpair p else (z**car p)*sgn cadr p;

symbolic procedure bfnewton (p,p1,nx,ri,kmax);
   begin scalar ri,px,pf,pf0,x0,xe,k,xk,xr,lp; integer m;
      !*xnlist := nil; lm!# := 0;
      lm!# := nwterrfx(caar lastpair p,nil);
      gfstorval(pf0 := bfabs(px := rlval(p,nx)),nx);
      if bfzp pf0 then <>;
newt: x0 := nx; if bfzp(xe := rlval(p1,nx)) then go to ret1;
      nx := bfplus(nx,xe := bfminus bfdivide(px,xe));
      px := rlval(p,nx);
     % if realroot case, check range of nx.
      if not ri then go to tst2;
      if ratleqp(car ri,xr := realrat nx) and ratleqp(xr,cdr ri)
         then go to tst;
     % fall through if nx out of range.
      nx := tighten(ri,p,bfabs px,sh!#);
      if null !*xnlist then go to ret2;
      movebds(ri,xr := ratmean(car ri,cdr ri),sh!#);
      px := rlval(p,nx := r2flbf xr);
      lp := k := xk := pf := nil; go to newt;
 tst: movebds(ri,xr,sh!#);
      if bdstest ri then go to ret;
     % test for start of loop unless already in loop.
tst2: pf0 := pf; pf := bfabs px;
      if (not lp) and pf0 and bfleqp(pf0,pf) then
          <>;
      trmsg2 (if lp then 'loop else 'nwt,nx,px);
      if bfzp pf then <>;
      if bfeqp(nx,x0) then <>;
      gfstorval(pf,nx);
     % next line initializes or updates loop variables.
      if k then <>
         else if lp then <>;
      if k=kmax then
         <>;
      nwterr(m := m+1); go to newt;
ret3: nx := gfgetmin(); trmsg7(nx);goto ret;
ret2: if nx then go to ret;
ret1: trmsg10 'nwt;
 ret: !*xnlist := nil; return nx end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/roots.red0000644000175000017500000002063611526203062023523 0ustar  giovannigiovannimodule roots;  % Header module for roots package.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment
  Revisions:
  30 March 95   Mod 1.96 adds the additional capability of solving
                 polynomials by automatically reversing the powers and
                 finding inverse roots first when direct root finding
                 fails to converge.  Examples that caused aborts in the
                 previous versions are now solved.

   2 March 94.  Mod 1.95 adds multroot, a program to solve a nest of
                 polynomials composed of one or more unary polynomials
                 solved by roots or realroots, with others solved by
                 back-substitution.  Multroot can be called directly, or
                 it is called automatically if roots or realroots is
                 given as argument a list of polynomials.

    15 Nov 93.  Error in reporting real roots in the variable rootsreal
                 corrected (in function ALLOUT).

    28 May 93.  Mod 1.94 is adapted to use the binary bigfloats of
                 Reduce 3.5 and later versions.  It will not work with
                 previous versions.  Handling of rational limits in real
                 roots functions corrected.  Allroots is strengthened to
                 handle polynomials with extremely close large roots.
                 Rounding of extremely close roots by realroots made
                 more precise.  Polynomials directly input are evaluated
                 exactly whenever possible, and with rounded evaluation
                 done only when necessary.  Some minor bugs in handling
                 polynomial inputs and limit inputs into real roots
                 functions corrected.  Rounding of complex roots changed
                 to round real and imaginary parts independently.  Root
                 reordering standardizes root order output from
                 allroots.

    9 July 92.  Mod 1.93 improves polynomial handling by using big
                 float for polynomials which the system floating point
                 representation cannot handle.  Also, it derives
                 floating point polynomials from bigfloat versions,
                 never the reverse order (which could induce errors).
                 Improved ability to handle almost degenerate complex
                 polynomials and to find difficult roots more rapidly.
                 Firstroot function now uses allroots.  Dynamic
                 adjustment of maximum iteration limits added to avoid
                 aborts on difficult examples.

    10 Oct 90.  Mod 1.92 uses exact arithmetic in bigfloat polynomial
                 evaluation and all polynomial deflations.  Extremely
                 small real or complex parts of roots can be handled.
                 Polynomials with non-unit initial coefficients and
                 almost degenerate polynomials which require high
                 precision calculations cause no trouble.  REDUCE 3.4
                 required.

    16 May 90.  Mod 1.91 adds capability for handling enormous or
                 infinitesimal coefficients, and uses powergcd logic to
                 speed up root finding when powers are all multiples of
                 a power.  Root separation is improved in difficult
                 cases in which close roots occur on different square-
                 free factors and on real and complex factors.  Better
                 starting points for iteration are found in cases where
                 one or more derivatives vanish at usual initial points.

    11 Feb 90.  Mod 1.90 avoids floating point overflows under extreme
                 conditions.  Files are reorganized to be compatible
                 with REDUCE 3.3 and also be operable under the ROUNDED
                 domain logic being developed for REDUCE 3.4.

     8 Oct 89.  Mod 1.89 avoids floating point under- and overflows
                 which could occur in SLISP.

    21 Aug 89.  Mod 1.88 contains improved precision and accuracy
                 logic and a RATROOT switch for obtaining root output
                 in rational format.  Roots are individually output to
                 the accuracy required to separate them.

    19 Jun 89.  Corrected sign change count error in procedures SCH and
                 SCHINF in isoroots module.
;

create!-package('(roots bfdoer bfdoer2 complxp allroot rootaux),
                '(contrib roots));

exports bfabs, bfnump, bfrlmult, bfsiz, ceillog, cpxp, getprec, im2gf,
        minprec, mkxcl, ncpxp, pmsg, rl2gf, roots, setflbf, setprec,
        trmsg1, trmsg10, trmsg11, trmsg12, trmsg13, trmsg2,
        trmsg3, trmsg4, trmsg6, trmsg7, trmsg8, xclp;

imports abs!:, bfloat, bfp!:, ceiling, cflot, eqcar, log10, preci!:,
        precision, precision1, timbf, trmsg10a, trmsg11a, trmsg12a,
        trmsg13a, trmsg1a, trmsg2a, trmsg3a, trmsg4a, trmsg6a,
        trmsg7a, trmsg8a;

% load!-package 'arith;   % For bootstrapping purposes.

global '(roots!-mod); roots!-mod := "Mod 1.96, 30 March 1995.";

fluid '(!*bftag !:prec!: !*rootmsg !*trroot);

global '(!!nfpd bfz!*);

symbolic procedure roots u; nil;   % To fool loader.

symbolic procedure minprec; if !*bftag then !:prec!: else !!nfpd;

symbolic smacro procedure getprec(); 2+precision 0;
symbolic smacro procedure setprec p; precision1(p-2,t);

symbolic smacro procedure bfsiz p; preci!: bfloat p;

symbolic smacro procedure bfnump p; numberp p or bfp!: p;

symbolic smacro procedure bfrlmult(r,u);
   if atom u then r*u else timbf(bfloat r,u);

symbolic smacro procedure bfabs u; if atom u then abs u else abs!: u;

symbolic smacro procedure rl2gf u;
   if !*bftag then (bfloat u) . bfz!* else (cflot u) . 0.0;

symbolic smacro procedure im2gf u;
   if !*bftag then bfz!* . (bfloat u) else 0.0 . (cflot u);

symbolic smacro procedure xclp a; eqcar(a,'list);

symbolic smacro procedure mkxcl a; if xclp a then a else 'list . a;

symbolic smacro procedure ncpxp p; bfnump p or bfnump cdar p;

symbolic smacro procedure cpxp p; not ncpxp p;

symbolic smacro procedure pmsg a;
   if !*rootmsg and !*trroot then <>;

symbolic smacro procedure ceillog m; ceiling log10 float m;

symbolic smacro procedure setflbf b; !*bftag := b;

symbolic smacro procedure trmsg1 (a, nx);
  if !*trroot then trmsg1a (a, nx);

symbolic smacro procedure trmsg2 (a, xn, px);
  if !*trroot then trmsg2a (a, xn, px);

symbolic smacro procedure trmsg3 (a, xn);
  if !*trroot then trmsg3a (a, xn);

symbolic smacro procedure trmsg4 req;
  if !*trroot then trmsg4a req;

symbolic smacro procedure trmsg6 (k, xn, px);
  if !*trroot then trmsg6a (k, xn, px);

symbolic smacro procedure trmsg7 xn;
  if !*trroot then trmsg7a xn;

symbolic smacro procedure trmsg8;
  if !*trroot then trmsg8a();

symbolic smacro procedure trmsg10 a;
  if !*trroot or !*rootmsg then trmsg10a a;

symbolic smacro procedure trmsg11 (xn, n);
  if !*trroot then trmsg11a (xn, n);

symbolic smacro procedure trmsg12 z;
  if !*trroot then trmsg12a z;

symbolic smacro procedure trmsg13(n,xn,px);
   if !*trroot then trmsg13a(n,xn,px);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/roots.rlg0000644000175000017500000027055111527635055023554 0ustar  giovannigiovanniFri Feb 18 21:27:52 2011 run on win32
% Tests of the root finding package.

% Author: Stanley L. Kameny (stan_kameny@rand.org)

comment  Addition for roots mod 1.95.  The function multroot has been
  added to the roots package in mod 1.95.  This provides the capability
  to solve a nest of n polynomials in n variables, provided that each
  polynomial either is univariate or introduces a new variable to the
  set.  The solutions can be either real solutions only, or complex
  solutions.  All solutions to the new examples, problems 117) and
  subsequent, are correct to all digits shown.  As in the prior examples,
  root order and values should agree exactly with that given here.

comment  This test file works only with Reduce version 3.5 and later
  and contains examples all of which are solved by roots mod 1.94.
  Answers are rounded to the value given by rootacc (default = 6)
  unless higher accuracy is needed to separate roots.  Format may differ 
  from that given here, but root order and values should agree exactly.
  (Although the function ROOTS may obtain the roots in a different order,
  they are sorted into a standard order in mod 1.94 and later.)
         In the following, problems 20) and 82) are time consuming and
  have been commented out to speed up the test.
         The hard examples 111) through 115) almost double the test time
  but are necessary to test some logical paths.
         A new "hardest" example has been added as example 116).  It is
  commented out, since it is time consuming, but it is solved by roots
  mod 1.94.  The time needed to run the three commented-out examples is
  almost exactly equal to the time for the rest of the test.  Users of
  fast computers can uncomment the lines marked with %**%.  The three
  examples by themselves are contained in the test file rootsxtr.tst.

         When answers are produced which require precision increase for
  printing out or input of roots, roots functions cause precision
  increase to occur.  If the precision is already higher than the 
  default value, a message is printed out warning of the the precision 
  normally needed for input of those values.$


realroots x;


{x=0}
   % To load roots package.

write "This is Roots Package test ", symbolic roots!-mod$


This is Roots Package test Mod 1.96, 30 March 1995.



% Simple root finding.

% 1) multiple real and imaginary roots plus two real roots.
zz:= (x-3)**2*(100x**2+113)**2*(1000000x-10000111)*(x-1);


                   8                 7                 6                  5
zz := 10000000000*x  - 170001110000*x  + 872607770000*x  - 1974219158600*x

                        4                  3                  2
       + 2833796550200*x  - 3810512046359*x  + 3119397498913*x

       - 2030292260385*x + 1149222756231
 roots zz;


{x=1.06301*i,

 x=1.06301*i,

 x= - 1.06301*i,

 x= - 1.06301*i,

 x=3.0,

 x=3.0,

 x=1,

 x=10.0001}

%{x=1.06301*i,x=1.06301*i,x=-1.06301*i,x=-1.06301*i,
%x=3.0,x=3.0,x=1,x=10.0001} (rootacc caused rounding to 6 places)

% Accuracy is increased whenever necessary to separate distinct roots.

% 2) accuracy increase to 7 required for two roots.
zz:=(x**2+1)*(x-2)*(1000000x-2000001);


               4            3            2
zz := 1000000*x  - 4000001*x  + 5000002*x  - 4000001*x + 4000002
 roots zz;


{x=i,

 x= - i,

 x=2.0,

 x=2.000001}

%{x=i,x= -i,x=2.0,x=2.000001}

% 3) accuracy increase to 8 required.
zz:= (x-3)*(10000000x-30000001);


                2
zz := 10000000*x  - 60000001*x + 90000003
 roots zz;


{x=3.0,x=3.0000001}

%{x=3.0,x=3.0000001}

% 4) accuracy increase required here to separate repeated root from
% simple root.
zz := (x-3)*(1000000x-3000001)*(x-3)*(1000000x-3241234);


                       4                  3                   2
zz := 2*(500000000000*x  - 6120617500000*x  + 28085557620617*x

          - 57256673223702*x + 43756673585553)
 roots zz;


{x=3.0,

 x=3.0,

 x=3.000001,

 x=3.24123}

%{x=3.0,x=3.0,x=3.000001,x=3.24123}

% other simple examples

% 5) five real roots with widely different spacing.
zz:= (x-1)*(10x-11)*(x-1000)*(x-1001)*(x-100000);


          5            4               3                  2
zz := 10*x  - 1020031*x  + 2013152032*x  - 1005224243011*x  + 2104312111000*x

       - 1101100000000
 roots zz;


{x=1,

 x=1.1,

 x=1000.0,

 x=1001.0,

 x=1.0e+5}

%{x=1,x=1.1,x=1000.0,x=1001.0,x=1.0E+5}

% 6) a cluster of 5 roots in complex plane in vicinity of x=1.
zz:= (x-1)*(10000x**2-20000x+10001)*(10000x**2-20000x+9999);


                 5              4               3               2
zz := 100000000*x  - 500000000*x  + 1000000000*x  - 1000000000*x  + 499999999*x

       - 99999999
 roots zz;


{x=0.99,

 x=1,

 x=1 + 0.01*i,

 x=1 - 0.01*i,

 x=1.01}

%{x=0.99,x=1,x=1 + 0.01*i,x=1 - 0.01*i,x=1.01}

% 7) four closely spaced real roots.
zz := (x-1)*(100x-101)*(100x-102)*(100x-103);


                 4            3            2
zz := 2*(500000*x  - 2030000*x  + 3090550*x  - 2091103*x + 530553)
 roots zz;


{x=1,

 x=1.01,

 x=1.02,

 x=1.03}

%{x=1,x=1.01,x=1.02,x=1.03}

% 8) five closely spaced roots, 3 real + 1 complex pair.
zz := (x-1)*(100x-101)*(100x-102)*(100x**2-200x+101);


                 5            4            3            2
zz := 2*(500000*x  - 2515000*x  + 5065100*x  - 5105450*x  + 2575601*x - 520251)
 roots zz;


{x=1,

 x=1 + 0.1*i,

 x=1 - 0.1*i,

 x=1.01,

 x=1.02}

%{x=1,x=1 + 0.1*i,x=1 - 0.1*i,x=1.01,x=1.02}

% 9) symmetric cluster of 5 roots, 3 real + 1 complex pair.
zz := (x-2)*(10000x**2-40000x+40001)*(10000x**2-40000x+39999);


                 5               4               3               2
zz := 100000000*x  - 1000000000*x  + 4000000000*x  - 8000000000*x

       + 7999999999*x - 3199999998
 roots zz;


{x=1.99,

 x=2.0,

 x=2.0 + 0.01*i,

 x=2.0 - 0.01*i,

 x=2.01}

%{x=1.99,x=2.0,x=2.0 + 0.01*i,x=2.0 - 0.01*i,x=2.01}

% 10) closely spaced real and complex pair.
ss:= (x-2)*(100000000x**2-400000000x+400000001);


                 3              2
ss := 100000000*x  - 600000000*x  + 1200000001*x - 800000002
 roots ss;


{x=2.0,x=2.0 + 0.0001*i,x=2.0 - 0.0001*i}

%{x=2.0,x=2.0 + 0.0001*i,x=2.0 - 0.0001*i}

% 11) Zero roots and multiple roots cause no problem.
% Multiple roots are shown when the switch multiroot is on
%(normally on.)
zz:= x*(x-1)**2*(x-4)**3*(x**2+1);


          7       6       5        4        3        2
zz := x*(x  - 14*x  + 74*x  - 186*x  + 249*x  - 236*x  + 176*x - 64)
 roots zz;


{x=0,

 x=4.0,

 x=4.0,

 x=4.0,

 x=1,

 x=1,

 x=i,

 x= - i}

%{x=0,x=4.0,x=4.0,x=4.0,x=1,x=1,x=i,x= - i}

% 12) nearestroot will find a single root "near" a value, real or
% complex.
nearestroot(zz,2i);


{x=i}

%{x=i}

% More difficult examples.

% Three examples in which root scaling is needed in the complex
% iteration process.

% 13) nine roots, 3 real and 3 complex pairs.
zz:= x**9-45x-2;


       9
zz := x  - 45*x - 2
 roots zz;


{x= - 1.60371,

 x= - 1.13237 + 1.13805*i,

 x= - 1.13237 - 1.13805*i,

 x= - 0.0444444,

 x=0.00555357 + 1.60944*i,

 x=0.00555357 - 1.60944*i,

 x=1.14348 + 1.13804*i,

 x=1.14348 - 1.13804*i,

 x=1.61483}

%{x= - 1.60371,x=-1.13237 + 1.13805*i,x=-1.13237 - 1.13805*i,
% x= - 0.0444444,x=0.00555357 + 1.60944*i,x=0.00555357 - 1.60944*i,
% x=1.14348 + 1.13804*i,x=1.14348 - 1.13804*i,x=1.61483}


comment  In the next two examples, there are complex roots with
  extremely  small real parts (new capability in Mod 1.91.);


% 14) nine roots, 1 real and 4 complex pairs.
zz:= x**9-9999x**2-0.01;


            9           2
       100*x  - 999900*x  - 1
zz := ------------------------
                100
 roots zz;


{x= - 3.3584 + 1.61732*i,

 x= - 3.3584 - 1.61732*i,

 x= - 0.829456 + 3.63408*i,

 x= - 0.829456 - 3.63408*i,

 x=5.0025e-29 + 0.00100005*i,

 x=5.0025e-29 - 0.00100005*i,

 x=2.32408 + 2.91431*i,

 x=2.32408 - 2.91431*i,

 x=3.72754}

%{x=-3.3584 + 1.61732*i,x=-3.3584 - 1.61732*i,
% x=-0.829456 + 3.63408*i,x=-0.829456 - 3.63408*i,
% x=5.0025E-29 + 0.00100005*i,x=5.0025E-29 - 0.00100005*i,
% x=2.32408 + 2.91431*i,x=2.32408 - 2.91431*i,x=3.72754}

comment  Rootacc 7 produces 7 place accuracy.  Answers will print in
  bigfloat format if floating point print >6 digits is not implemented.;


% 15) nine roots, 1 real and 4 complex pairs.
rootacc 7;


7
 zz:= x**9-500x**2-0.001;


             9           2
       1000*x  - 500000*x  - 1
zz := -------------------------
                1000
 roots zz;


{x= - 2.189157 + 1.054242*i,

 x= - 2.189157 - 1.054242*i,

 x= - 0.5406772 + 2.368861*i,

 x= - 0.5406772 - 2.368861*i,

 x=1.6e-26 + 0.001414214*i,

 x=1.6e-26 - 0.001414214*i,

 x=1.514944 + 1.899679*i,

 x=1.514944 - 1.899679*i,

 x=2.429781}

%{x=-2.189157 + 1.054242*i,x=-2.189157 - 1.054242*i,
% x=-0.5406772 + 2.368861*i,x=-0.5406772 - 2.368861*i,
% x=1.6E-26 + 0.001414214*i,x=1.6E-26 - 0.001414214*i,
% x=1.514944 + 1.899679*i,x=1.514944 - 1.899679*i,x=2.429781}

% the famous Wilkinson "ill-conditioned" polynomial and its family.

% 16) W(6) four real roots plus one complex pair.
zz:= 10000*(for j:=1:6 product(x+j))+27x**5;


             6           5            4            3             2
zz := 10000*x  + 210027*x  + 1750000*x  + 7350000*x  + 16240000*x  + 17640000*x

       + 7200000
 roots zz;


{x= - 6.143833,

 x= - 4.452438 + 0.02123455*i,

 x= - 4.452438 - 0.02123455*i,

 x= - 2.950367,

 x= - 2.003647,

 x= - 0.9999775}

%{x= - 6.143833,x=-4.452438 + 0.02123455*i,x=-4.452438 - 0.02123455*i,
% x= - 2.950367,x= - 2.003647,x= - 0.9999775}

% 17) W(8) 4 real roots plus 2 complex pairs.
zz:= 1000*(for j:=1:8 product(x+j))+2x**7;


              8          7           6            5             4             3
zz := 2*(500*x  + 18001*x  + 273000*x  + 2268000*x  + 11224500*x  + 33642000*x

                      2
          + 59062000*x  + 54792000*x + 20160000)
 roots zz;


{x= - 8.437546,

 x= - 6.494828 + 1.015417*i,

 x= - 6.494828 - 1.015417*i,

 x= - 4.295858 + 0.2815097*i,

 x= - 4.295858 - 0.2815097*i,

 x= - 2.982725,

 x= - 2.000356,

 x= - 0.9999996}

%{x= - 8.437546,x=-6.494828 + 1.015417*i,x=-6.494828 - 1.015417*i,
% x=-4.295858 + 0.2815097*i,x=-4.295858 - 0.2815097*i,
% x= - 2.982725,x= - 2.000356,x= - 0.9999996}

% 18) W(10) 6 real roots plus 2 complex pairs.
zz:=1000*(for j:= 1:10 product (x+j))+x**9;


            10          9            8             7              6
zz := 1000*x   + 55001*x  + 1320000*x  + 18150000*x  + 157773000*x

                    5               4               3                2
       + 902055000*x  + 3416930000*x  + 8409500000*x  + 12753576000*x

       + 10628640000*x + 3628800000
 roots zz;


{x= - 10.80988,

 x= - 8.70405 + 1.691061*i,

 x= - 8.70405 - 1.691061*i,

 x= - 6.046279 + 1.134321*i,

 x= - 6.046279 - 1.134321*i,

 x= - 4.616444,

 x= - 4.075943,

 x= - 2.998063,

 x= - 2.000013,

 x= - 1}

%{x= - 10.80988,x=-8.70405 + 1.691061*i,x=-8.70405 - 1.691061*i,
% x=-6.046279 + 1.134321*i,x=-6.046279 - 1.134321*i,x= - 4.616444,
% x= - 4.075943,x= - 2.998063,x= - 2.000013,x= - 1}

% 19) W(12) 6 real roots plus 3 complex pairs.
zz:= 10000*(for j:=1:12 product(x+j))+4x**11;


               12           11            10              9               8
zz := 4*(2500*x   + 195001*x   + 6792500*x   + 139425000*x  + 1873657500*x

                         7                 6                 5
          + 17316585000*x  + 112475577500*x  + 515175375000*x

                           4                  3                  2
          + 1643017090000*x  + 3535037220000*x  + 4828898880000*x

          + 3716107200000*x + 1197504000000)
 roots zz;


{x= - 13.1895,

 x= - 11.02192 + 2.23956*i,

 x= - 11.02192 - 2.23956*i,

 x= - 7.953917 + 1.948001*i,

 x= - 7.953917 - 1.948001*i,

 x= - 5.985629 + 0.8094247*i,

 x= - 5.985629 - 0.8094247*i,

 x= - 4.880956,

 x= - 4.007117,

 x= - 2.999902,

 x= - 2.0,

 x= - 1}

%{x= - 13.1895,x=-11.02192 + 2.23956*i,x=-11.02192 - 2.23956*i,
% x=-7.953917 + 1.948001*i,x=-7.953917 - 1.948001*i,
% x=-5.985629 + 0.8094247*i,x=-5.985629 - 0.8094247*i,
% x= - 4.880956,x= - 4.007117,x= - 2.999902,x= - 2.0,x= - 1}

% 20) W(20) 10 real roots plus 5 complex pairs. (The original problem)
% This example is commented out, since it takes significant time without
% being particularly difficult or checking out new paths:
%**%  zz:= x**19+10**7*for j:=1:20 product (x+j); roots zz;
%{x= - 20.78881,x=-19.45964 + 1.874357*i,x=-19.45964 - 1.874357*i,
% x=-16.72504 + 2.731577*i,x=-16.72504 - 2.731577*i,
% x=-14.01105 + 2.449466*i,x=-14.01105 - 2.449466*i,
% x=-11.82101 + 1.598621*i,x=-11.82101 - 1.598621*i,
% x=-10.12155 + 0.6012977*i,x=-10.12155 - 0.6012977*i,
% x= - 8.928803,x= - 8.006075,x= - 6.999746,x= - 6.000006,
% x= - 5.0,x= - 4.0,x= - 3.0,x= - 2.0,x= - 1}

rootacc 6;


6

% 21)  Finding one of a cluster of 8 roots.
zz:= (10**16*(x-1)**8-1);


                         8                      7                       6
zz := 10000000000000000*x  - 80000000000000000*x  + 280000000000000000*x

                             5                       4                       3
       - 560000000000000000*x  + 700000000000000000*x  - 560000000000000000*x

                             2
       + 280000000000000000*x  - 80000000000000000*x + 9999999999999999
 nearestroot(zz,2);


{x=1.01}

%{x=1.01}

% 22)  Six real roots spaced 0.01 apart.
c := 100;


c := 100
 zz:= (x-1)*for i:=1:5 product (c*x-(c+i));


                     6               5               4               3
zz := 40*(250000000*x  - 1537500000*x  + 3939625000*x  - 5383556250*x

                         2
           + 4137919435*x  - 1696170123*x + 289681938)
 roots zz;


{x=1,

 x=1.01,

 x=1.02,

 x=1.03,

 x=1.04,

 x=1.05}

%{x=1,x=1.01,x=1.02,x=1.03,x=1.04,x=1.05}

% 23)  Six real roots spaced 0.001 apart.
c := 1000;


c := 1000
 zz:= (x-1)*for i:=1:5 product (c*x-(c+i));


                          6                    5                    4
zz := 40*(25000000000000*x  - 150375000000000*x  + 376877125000000*x

                              3                    2
           - 503758505625000*x  + 378762766881850*x  - 151883516888703*x

           + 25377130631853)
 roots zz;


{x=1,

 x=1.001,

 x=1.002,

 x=1.003,

 x=1.004,

 x=1.005}

%{x=1,x=1.001,x=1.002,x=1.003,x=1.004,x=1.005}

% 24)  Five real roots spaced 0.0001 apart.
c := 10000;


c := 10000
 zz:= (x-1)*for i:=1:4 product (c*x-(c+i));


                           5                     4                      3
zz := 8*(1250000000000000*x  - 6251250000000000*x  + 12505000437500000*x

                               2
          - 12507501312562500*x  + 6255001312625003*x - 1251250437562503)
 roots zz;


{x=1,

 x=1.0001,

 x=1.0002,

 x=1.0003,

 x=1.0004}

%{x=1,x=1.0001,x=1.0002,x=1.0003,x=1.0004}

% 25)  A cluster of 9 roots, 5 real, 2 complex pairs; spacing 0.1.
zz:= (x-1)*(10**8*(x-1)**8-1);


                 9              8               7               6
zz := 100000000*x  - 900000000*x  + 3600000000*x  - 8400000000*x

                      5                4               3               2
       + 12600000000*x  - 12600000000*x  + 8400000000*x  - 3600000000*x

       + 899999999*x - 99999999
 roots zz;


{x=0.9,

 x=0.929289 + 0.0707107*i,

 x=0.929289 - 0.0707107*i,

 x=1,

 x=1 + 0.1*i,

 x=1 - 0.1*i,

 x=1.07071 + 0.0707107*i,

 x=1.07071 - 0.0707107*i,

 x=1.1}

%{x=0.9,x=0.929289 + 0.0707107*i,x=0.929289 - 0.0707107*i,
% x=1,x=1 + 0.1*i,x=1 - 0.1*i,
% x=1.07071 + 0.0707107*i,x=1.07071 - 0.0707107*i,x=1.1}

% 26)  Same, but with spacing 0.01.
zz:= (x-1)*(10**16*(x-1)**8-1);


                         9                      8                       7
zz := 10000000000000000*x  - 90000000000000000*x  + 360000000000000000*x

                             6                        5                        4
       - 840000000000000000*x  + 1260000000000000000*x  - 1260000000000000000*x

                             3                       2
       + 840000000000000000*x  - 360000000000000000*x  + 89999999999999999*x

       - 9999999999999999
 roots zz;


{x=0.99,

 x=0.992929 + 0.00707107*i,

 x=0.992929 - 0.00707107*i,

 x=1,

 x=1 + 0.01*i,

 x=1 - 0.01*i,

 x=1.00707 + 0.00707107*i,

 x=1.00707 - 0.00707107*i,

 x=1.01}

%{x=0.99,x=0.992929 + 0.00707107*i,x=0.992929 - 0.00707107*i,
% x=1,x=1 + 0.01*i,x=1 - 0.01*i,
% x=1.00707 + 0.00707107*i,x=1.00707 - 0.00707107*i,x=1.01}

% 27)  Spacing reduced to 0.001.
zz:= (x-1)*(10**24*(x-1)**8-1);


                                 9                              8
zz := 1000000000000000000000000*x  - 9000000000000000000000000*x

                                     7                               6
       + 36000000000000000000000000*x  - 84000000000000000000000000*x

                                      5                                4
       + 126000000000000000000000000*x  - 126000000000000000000000000*x

                                     3                               2
       + 84000000000000000000000000*x  - 36000000000000000000000000*x

       + 8999999999999999999999999*x - 999999999999999999999999
 roots zz;


{x=0.999,

 x=0.999293 + 0.000707107*i,

 x=0.999293 - 0.000707107*i,

 x=1,

 x=1 + 0.001*i,

 x=1 - 0.001*i,

 x=1.00071 + 0.000707107*i,

 x=1.00071 - 0.000707107*i,

 x=1.001}

%{x=0.999,x=0.999293 + 0.000707107*i,x=0.999293 - 0.000707107*i,
% x=1,x=1 + 0.001*i,x=1 - 0.001*i,
% x=1.00071 + 0.000707107*i,x=1.00071 - 0.000707107*i,x=1.001}

% 28)  Eight roots divided into two clusters.
zz:= (10**8*(x-1)**4-1)*(10**8*(x+1)**4-1);


                         8                      6                      4
zz := 10000000000000000*x  - 40000000000000000*x  + 59999999800000000*x

                            2
       - 40000001200000000*x  + 9999999800000001
 roots zz;


{x= - 0.99,

 x=0.99,

 x= - 1 - 0.01*i,

 x=1 + 0.01*i,

 x= - 1 + 0.01*i,

 x=1 - 0.01*i,

 x= - 1.01,

 x=1.01}

%{x= - 0.99,x=0.99, x=-1 - 0.01*i,x=1 + 0.01*i,
% x=-1 + 0.01*i,x=1 - 0.01*i,x= - 1.01,x=1.01}

% 29)  A cluster of 8 roots in a different configuration.
zz:= (10**8*(x-1)**4-1)*(10**8*(100x-102)**4-1);


                                 8                              7
zz := 1000000000000000000000000*x  - 8080000000000000000000000*x

                                     6                               5
       + 28562400000000000000000000*x  - 57694432000000000000000000*x

                                     4                               3
       + 72836160149999999900000000*x  - 58848320599199999600000000*x

                                     2
       + 29716320897575999400000000*x  - 8574560597551679600000000*x

       + 1082432149175678300000001
 roots zz;


{x=0.99,

 x=1 + 0.01*i,

 x=1 - 0.01*i,

 x=1.01,

 x=1.0199,

 x=1.02 + 0.0001*i,

 x=1.02 - 0.0001*i,

 x=1.0201}

%{x=0.99,x=1 + 0.01*i,x=1 - 0.01*i,x=1.01,
% x=1.0199,x=1.02 + 0.0001*i,x=1.02 - 0.0001*i,x=1.0201}

% 30)  A cluster of 8 complex roots.
zz:= ((10x-1)**4+1)*((10x+1)**4+1);


                   8            6          4        2
zz := 4*(25000000*x  - 1000000*x  + 20000*x  + 200*x  + 1)
 roots zz;


{x= - 0.0292893 - 0.0707107*i,

 x=0.0292893 + 0.0707107*i,

 x= - 0.0292893 + 0.0707107*i,

 x=0.0292893 - 0.0707107*i,

 x= - 0.170711 - 0.0707107*i,

 x=0.170711 + 0.0707107*i,

 x= - 0.170711 + 0.0707107*i,

 x=0.170711 - 0.0707107*i}

%{x=-0.0292893 - 0.0707107*i,x=0.0292893 + 0.0707107*i,
% x=-0.0292893 + 0.0707107*i,x=0.0292893 - 0.0707107*i,
% x=-0.170711 - 0.0707107*i,x=0.170711 + 0.0707107*i,
% x=-0.170711 + 0.0707107*i,x=0.170711 - 0.0707107*i}

comment  In these examples, accuracy increase is required to separate a
  repeated root from a simple root.;


% 31)  Using allroots;
zz:= (x-4)*(x-3)**2*(1000000x-3000001);


               4             3             2
zz := 1000000*x  - 13000001*x  + 63000010*x  - 135000033*x + 108000036
 roots zz;


{x=3.0,

 x=3.0,

 x=3.000001,

 x=4.0}

%{x=3.0,x=3.0,x=3.000001,x=4.0}

% 32)  Using realroots;
realroots zz;


{x=3.0,

 x=3.0,

 x=3.000001,

 x=4.0}

%{x=3.0,x=3.0,x=3.000001,x=4.0}

comment  Tests of new capabilities in mod 1.87 for handling complex
  polynomials and polynomials with very small imaginary parts or very
  small real roots. A few real examples are shown, just to demonstrate
  that these still work.;


% 33) A trivial complex case (but degrees 1 and 2 are special cases);
zz:= x-i;


zz :=  - i + x
 roots zz;


{x=i}

%{x=i}

% 34) Real case.
zz:= y-7;


zz := y - 7
 roots zz;


{y=7.0}

%{y=7.0}

% 35) Roots with small imaginary parts (new capability);
zz := 10**16*(x**2-2x+1)+1;


                         2
zz := 10000000000000000*x  - 20000000000000000*x + 10000000000000001
 roots zz;


{x=1 + 0.00000001*i,x=1 - 0.00000001*i}

%{x=1 + 0.00000001*i,x=1 - 0.00000001*i}

% 36) One real, one complex root.
zz:=(x-9)*(x-5i-7);


                         2
zz :=  - 5*i*x + 45*i + x  - 16*x + 63
 roots zz;


{x=9.0,x=7.0 + 5.0*i}

%{x=9.0,x=7.0 + 5.0*i}

% 37) Three real roots.
zz:= (x-1)*(x-2)*(x-3);


       3      2
zz := x  - 6*x  + 11*x - 6
 roots zz;


{x=1,x=2.0,x=3.0}

%{x=1,x=2.0,x=3.0}

% 38) 2 real + 1 imaginary root.
zz:=(x**2-8)*(x-5i);


              2           3
zz :=  - 5*i*x  + 40*i + x  - 8*x
 roots zz;


{x= - 2.82843,x=2.82843,x=5.0*i}

%{x= - 2.82843,x=2.82843,x=5.0*i}

% 39) 2 complex roots.
zz:= (x-1-2i)*(x+2+3i);


                   2
zz := i*x - 7*i + x  + x + 4
 roots zz;


{x= - 2.0 - 3.0*i,x=1 + 2.0*i}

%{x=-2.0 - 3.0*i,x=1 + 2.0*i}

% 40) 2 irrational complex roots.
zz:= x**2+(3+2i)*x+7i;


                     2
zz := 2*i*x + 7*i + x  + 3*x
 roots zz;


{x= - 3.14936 + 0.212593*i,x=0.149358 - 2.21259*i}

%{x=-3.14936 + 0.21259*i,x=0.149358 - 2.21259*i}

% 41) 2 complex roots of very different magnitudes with small imaginary
% parts.
zz:= x**2+(1000000000+12i)*x-1000000000;


                2
zz := 12*i*x + x  + 1000000000*x - 1000000000
 roots zz;


{x= - 1.0e+9 - 12.0*i,x=1 - 0.000000012*i}

%{x=-1.0E+9 - 12.0*i,x=1 - 0.000000012*i}

% 42) Multiple real and complex roots cause no difficulty, provided
% that input is given in integer or rational form, (or if in decimal
% fraction format, with switch rounded off  or adjprec on and
% coefficients input explicitly,) so that polynomial is stored exactly.
zz :=(x**2-2i*x+5)**3*(x-2i)*(x-11/10)**2;


                 8           7           6            5            4
zz := ( - 800*i*x  + 1760*i*x  - 6768*i*x  + 12760*i*x  - 25018*i*x

                   3            2                              9        8
        + 39600*i*x  - 46780*i*x  + 55000*i*x - 30250*i + 100*x  - 220*x

               7         6         5          4          3          2
        - 779*x  + 1980*x  - 9989*x  + 19580*x  - 28269*x  + 38500*x  - 21175*x)

      /100
 roots zz;


{x= - 1.44949*i,

 x= - 1.44949*i,

 x= - 1.44949*i,

 x=3.44949*i,

 x=3.44949*i,

 x=3.44949*i,

 x=1.1,

 x=1.1,

 x=2.0*i}

%{x=-1.44949*i, x=-1.44949*i, x=-1.44949*i,
% x=3.44949*i, x=3.44949*i, x=3.44949*i, x=1.1, x=1.1, x=2.0*i}

% 42a) would have failed in roots Mod 1.93 and previously (bug)
realroots zz;


{x=1.1,x=1.1}

%{x=1.1,x=1.1}

% 43) 2 real, 2 complex roots.
zz:= (x**2-4)*(x**2+3i*x+5i);


           3        2                    4      2
zz := 3*i*x  + 5*i*x  - 12*i*x - 20*i + x  - 4*x
 roots zz;


{x= - 2.0,

 x=2.0,

 x= - 1.2714 + 0.466333*i,

 x=1.2714 - 3.46633*i}

%{x= - 2.0,x=2.0,x=-1.2714 + 0.466333*i,x=1.2714 - 3.46633*i}

% 44) 4 complex roots.
zz:= x**4+(0.000001i)*x-16;


                      4
       i*x + 1000000*x  - 16000000
zz := -----------------------------
                 1000000
 roots zz;


{x= - 2.0 - 0.0000000625*i,

 x= - 2.0*i,

 x=2.0*i,

 x=2.0 - 0.0000000625*i}

%{x=-2.0 - 0.0000000625*i,x=-2.0*i,x=2.0*i,x=2.0 - 0.0000000625*i}

% 45) 2 real, 2 complex roots.
zz:= (x**2-4)*(x**2+2i*x+8);


           3            4      2
zz := 2*i*x  - 8*i*x + x  + 4*x  - 32
 roots zz;


{x= - 2.0,

 x=2.0,

 x= - 4.0*i,

 x=2.0*i}

%{x= - 2.0,x=2.0,x=-4.0*i,x=2.0*i}

% 46) Using realroots to find only real roots.
realroots zz;


{x= - 2.0,x=2.0}

%{x= - 2.0,x=2.0}

% 47) Same example, applying nearestroot to find a single root.
zz:= (x**2-4)*(x**2+2i*x+8);


           3            4      2
zz := 2*i*x  - 8*i*x + x  + 4*x  - 32
 nearestroot(zz,1);


{x=2.0}

%{x=2.0}

% 48) Same example, but focusing on imaginary point.
nearestroot(zz,i);


{x=2.0*i}

%{x=2.0*i}

% 49) The seed parameter can be complex also.
nearestroot(zz,1+i);


{x=2.0*i}

%{x=2.0*i}

% 50) One more nearestroot example.  Nearest root to real point may be
% complex.
zz:= (x**2-4)*(x**2-i);


            2          4      2
zz :=  - i*x  + 4*i + x  - 4*x
 roots zz;


{x= - 2.0,

 x=2.0,

 x= - 0.707107 - 0.707107*i,

 x=0.707107 + 0.707107*i}

%{x= - 2.0,x=2.0,x=-0.707107 - 0.707107*i,x=0.707107 + 0.707107*i}

nearestroot (zz,1);


{x=0.707107 + 0.707107*i}

%{X=0.707107 + 0.707107*i}

% 51) 1 real root plus 5 complex roots.
zz:=(x**3-3i*x**2-5x+9)*(x**3-8);


              5         2    6      4    3
zz :=  - 3*i*x  + 24*i*x  + x  - 5*x  + x  + 40*x - 72
 roots zz;


{x= - 1 + 1.73205*i,

 x= - 1 - 1.73205*i,

 x=2.0,

 x= - 2.41613 + 1.19385*i,

 x=0.981383 - 0.646597*i,

 x=1.43475 + 2.45274*i}

%{x=-1 + 1.73205*i,x=-1 - 1.73205*i,x=2.0,
% x=-2.41613 + 1.19385*i,x=0.981383 - 0.646597*i,x=1.43475 + 2.45274*i}

nearestroot(zz,1);


{x=0.981383 + 0.646597*i}

%{x=0.981383 - 0.646597*i}

% 52) roots can be computed to any accuracy desired, eg.  (note that the
% imaginary part of the second root is truncated because of its size,
% and that the imaginary part of a complex root is never polished away,
% even if it is smaller than the accuracy would require.)
zz := x**3+10**(-20)*i*x**2+8;


          2                          3
       i*x  + 100000000000000000000*x  + 800000000000000000000
zz := ---------------------------------------------------------
                        100000000000000000000
 rootacc 12;


12
 roots zz;


{x= - 2.0 - 3.33333333333e-21*i,x=1 - 1.73205080757*i,x=1 + 1.73205080757*i}
 rootacc 6;


6

%{x=-2.0 - 3.33333333333E-21*i,x=1 - 1.73205080757*i,
% x=1 + 1.73205080757*i}

% 53) Precision of 12 required to find small imaginary root,
% but standard accuracy can be used.
zz := x**2+123456789i*x+1;


                       2
zz := 123456789*i*x + x  + 1
 roots zz;


{x= - 1.23457e+8*i,x=0.0000000081*i}

%{x=-1.23457E+8*i,x=0.0000000081*i}

% 54) Small real root is found with root 10*18 times larger(new).
zz := (x+1)*(x**2+123456789*x+1);


       3              2
zz := x  + 123456790*x  + 123456790*x + 1
 roots zz;


{x= - 1.23457e+8,x= - 1,x= - 0.0000000081}

%{x= - 1.23457E+8,x= - 1,x= - 0.0000000081}

% 55) 2 complex, 3 real irrational roots.
ss := (45*x**2+(-10i+12)*x-10i)*(x**3-5x**2+1);


               4         3         2                       5        4       3
ss :=  - 10*i*x  + 40*i*x  + 50*i*x  - 10*i*x - 10*i + 45*x  - 213*x  - 60*x

             2
       + 45*x  + 12*x
 roots ss;


{x= - 0.429174,

 x=0.469832,

 x=4.95934,

 x= - 0.448056 - 0.19486*i,

 x=0.18139 + 0.417083*i}

%{x= - 0.429174,x=0.469832,x=4.95934,
% x=-0.448056 - 0.19486*i,x=0.18139 + 0.417083*i}

% 56) Complex polynomial with floating coefficients.
zz := x**2+1.2i*x+2.3i+6.7;


                           2
       12*i*x + 23*i + 10*x  + 67
zz := ----------------------------
                   10
 roots zz;


{x= - 0.427317 + 2.09121*i,x=0.427317 - 3.29121*i}

%{x=-0.427317 + 2.09121*i,x=0.427317 - 3.29121*i}

% 56a) multiple roots will be found if coefficients read in exactly.
% Exact read-in will occur unless dmode is rounded or complex-rounded.
zz := x**3 + (1.09 - 2.4*i)*x**2 + (-1.44 - 2.616*i)*x + -1.5696;


                  2                    3         2
        - 6000*i*x  - 6540*i*x + 2500*x  + 2725*x  - 3600*x - 3924
zz := -------------------------------------------------------------
                                  2500

roots zz;


{x=1.2*i,x=1.2*i,x= - 1.09}

%{x=1.2*i,x=1.2*i,x= - 1.09}

% 57) Realroots, isolater and rlrootno accept 1, 2 or 3 arguments: (new)
zz:= for j:=-1:3 product (x-j);


          4      3      2
zz := x*(x  - 5*x  + 5*x  + 5*x - 6)
 rlrootno zz;


5

% 5

realroots zz;


{x=0,

 x= - 1,

 x=1,

 x=2.0,

 x=3.0}

%{x=0,x= -1,x=1,x=2.0,x=3.0}

rlrootno(zz,positive);


3
 %positive selects positive, excluding 0.
% 3

rlrootno(zz,negative);


1
 %negative selects negative, excluding 0.
% 1

realroots(zz,positive);


{x=1,x=2.0,x=3.0}

%{x=1,x=2.0,x=3.0}

rlrootno(zz,-1.5,2);


4
 %the format with 3 arguments selects a range.
% 4

realroots(zz,-1.5,2);


{x=0,x= - 1,x=1,x=2.0}
 %the range is inclusive, except that:
%{x=0,x= - 1,x=1,x=2.0}

% A specific limit b may be excluded by using   exclude b.  Also, the
% limits infinity and -infinity can be specified.

realroots(zz,exclude 0,infinity);


{x=1,x=2.0,x=3.0}

% equivalent to realroots(zz,positive).
%{x=1,x=2.0,x=3.0}

rlrootno(zz,-infinity,exclude 0);


1
 % equivalent to rlrootno(zz,negative).
% 1

rlrootno(zz,-infinity,0);


2

% 2

rlrootno(zz,infinity,-infinity);


5

%equivalent to rlrootno zz; (order of limits does not matter.)
% 5

realroots(zz,1,infinity);


{x=1,x=2.0,x=3.0}
 % finds all real roots >= 1.
%{x=1,x=2.0,x=3.0}

realroots(zz,1,positive);


{x=2.0,x=3.0}
 % finds all real roots > 1.
%{x=2.0,x=3.0}

% 57a) Bug corrected in mod 1.94.  (handling of rational limits)
zz := (x-1/3)*(x-1/5)*(x-1/7)*(x-1/11);


             4        3        2
       1155*x  - 886*x  + 236*x  - 26*x + 1
zz := --------------------------------------
                       1155

realroots(zz,1/11,exclude(1/3));


{x=0.0909091,x=0.142857,x=0.2}

%{x=0.0909091,x=0.142857,x=0.2}

realroots(zz,exclude(1/11),1/3);


{x=0.142857,x=0.2,x=0.333333}

%{x=0.142857,x=0.2,x=0.333333}

% New capabilities added in mod 1.88.

% 58) 3 complex roots, with two separated by very small real difference.
zz :=(x+i)*(x+10**8i)*(x+10**8i+1);


                   2                                          3    2
zz := 200000001*i*x  + 100000001*i*x - 10000000000000000*i + x  + x

       - 10000000200000000*x - 100000000
 roots zz;


{x= - 1 - 1.0e+8*i,x= - 1.0e+8*i,x= - i}

%{x=-1 - 1.0E+8*i,x=-1.0E+8*i,x= - i}

% 59) Real polynomial with two complex roots separated by very small
% imaginary part.
zz:= (10**14x+123456789000000+i)*(10**14x+123456789000000-i);


                                     2
zz := 10000000000000000000000000000*x  + 24691357800000000000000000000*x

       + 15241578750190521000000000001
 roots zz;


{x= - 1.23457 + 1.0e-14*i,x= - 1.23457 - 1.0e-14*i}

%{x=-1.23457 + 1.0E-14*i,x=-1.23457 - 1.0E-14*i}

% 60) Real polynomial with two roots extremely close together.
zz:= (x+2)*(10**10x+12345678901)*(10**10x+12345678900);


                                3                        2
zz := 100*(1000000000000000000*x  + 4469135780100000000*x

            + 6462429435342508889*x + 3048315750285017778)
 roots zz;


{x= - 2.0,x= - 1.2345678901,x= - 1.23456789}

%{x= - 2.0,x= - 1.2345678901,x= - 1.23456789}

% 61) Real polynomial with multiple root extremely close to simple root.
zz:= (x-12345678/10000000)*(x-12345679/10000000)**2;


                              3                           2
zz := (500000000000000000000*x  - 1851851800000000000000*x

        + 2286236726108825000000*x - 940838132549050755399)/500000000000000000\
      000
 roots zz;


{x=1.2345679,x=1.2345679,x=1.2345678}

%{x=1.2345679,x=1.2345679,x=1.2345678}

% 62) Similar problem using realroots.
zz:=(x-2**30/10**8)**2*(x-(2**30+1)/10**8);


                           3                         2
zz := (610351562500000000*x  - 19660800006103515625*x  + 211106232664064000000*x

        - 755578637962830675968)/610351562500000000
 realroots zz;


{x=10.73741824,x=10.73741824,x=10.73741825}

%{x=10.73741824,x=10.73741824,x=10.73741825}

% 63) Three complex roots with small real separation between two.
zz:= (x-i)*(x-1-10**8i)*(x-2-10**8i);


                      2                                         3      2
zz :=  - 200000001*i*x  + 300000003*i*x + 9999999999999998*i + x  - 3*x

       - 10000000199999998*x + 300000000
 roots zz;


{x=i,x=1 + 1.0e+8*i,x=2.0 + 1.0e+8*i}

%{x=i,x=1 + 1.0E+8*i,x=2.0 + 1.0E+8*i}

% 64) Use of nearestroot to isolate one of the close roots.
nearestroot(zz,10**8i+99/100);


{x=1 + 1.0e+8*i}

%{x=1 + 1.0E+8*i}

% 65) Slightly more complicated example with close complex roots.
zz:= (x-i)*(10**8x-1234-10**12i)*(10**8x-1233-10**12i);


                                     2
zz := 2*( - 100005000000000000000*i*x  + 1233623350000000*i*x

                                                           3                 2
          + 499999999999999999239239*i + 5000000000000000*x  - 123350000000*x

          - 500099999999999999239239*x + 1233500000000000)
 roots zz;


{x=i,x=0.00001233 + 10000.0*i,x=0.00001234 + 10000.0*i}

%{x=i,x=0.00001233 + 10000.0*i,x=0.00001234 + 10000.0*i}

% 66) Four closely spaced real roots with varying spacings.
zz:= (x-1+1/10**7)*(x-1+1/10**8)*(x-1)*(x-1-1/10**7);


                                4                            3
zz := (10000000000000000000000*x  - 39999999900000000000000*x

                                   2
        + 59999999699999900000000*x  - 39999999699999800000001*x

        + 9999999899999900000001)/10000000000000000000000
 roots zz;


{x=0.9999999,

 x=0.99999999,

 x=1,

 x=1.0000001}

%{x=0.9999999,x=0.99999999,x=1,x=1.0000001}

% 67) Complex pair plus two close real roots.
zz:= (x**2+1)*(x-12345678/10000000)*(x-12345679/10000000);


                       4                    3                    2
zz := (50000000000000*x  - 123456785000000*x  + 126207888812681*x

        - 123456785000000*x + 76207888812681)/50000000000000
 roots zz;


{x=i,

 x= - i,

 x=1.2345678,

 x=1.2345679}

%{x=i,x= - i,x=1.2345678,x=1.2345679}

% 68) Same problem using realroots to find only real roots.
realroots zz;


{x=1.2345678,x=1.2345679}

%{x=1.2345678,x=1.2345679}

% The switch ratroot causes output to be given in rational form.
% 69) Two complex roots with output in rational form.
on ratroot,complex;

 zz:=x**2-(5i+1)*x+1;


       2
zz := x  - (1 + 5*i)*x + 1
 sss:= roots zz;


           346859 - 1863580*i     482657 + 2593180*i
sss := {x=--------------------,x=--------------------}
                10000000                500000
 

%           346859 - 1863580*i     482657 + 2593180*i
%sss := {x=--------------------,x=--------------------}
%                10000000                500000

% With roots in rational form, mkpoly can be used to reconstruct a
% polynomial.
zz1 := mkpoly sss;


                      2
zz1 := 5000000000000*x  - (4999999500000 + 25000010000000*i)*x

        + 5000012308763 - 2110440*i


%                      2
%zz1 := 5000000000000*x  - (4999999500000 + 25000010000000*i)*x
%
%        + 5000012308763 - 2110440*i

% Finding the roots of the new polynomial zz1.
rr:= roots zz1;


          346859 - 1863580*i     482657 + 2593180*i
rr := {x=--------------------,x=--------------------}
               10000000                500000
 

%          346859 - 1863580*i     482657 + 2593180*i
%rr := {x=--------------------,x=--------------------}
%               10000000                500000

% The roots are stable to the extent that rr=ss, although zz1 and
% zz may differ.

zz1 - zz;


               2
4999999999999*x  - (4999999499999 + 25000009999995*i)*x

 + 5000012308762 - 2110440*i


%               2
%4999999999999*x  - (4999999499999 + 25000009999995*i)*x
%
% + 5000012308762 - 2110440*i

% 70) Same type of problem in which roots are found exactly.
zz:=(x-10**8+i)*(x-10**8-i)*(x-10**8+3i/2)*(x-i);


          4                    3                      2
zz := (2*x  - (600000000 - i)*x  + 60000000000000005*x

        - (2000000000000000800000000 + 29999999999999999*i)*x

        + 30000000000000003 + 2000000000000000200000000*i)/2
 rr := roots zz;


rr := {x=100000000 + i,

       x=100000000 - i,

       x=i,

          200000000 - 3*i
       x=-----------------}
                 2


%          4                    3                      2
%zz := (2*x  - (600000000 - i)*x  + 60000000000000005*x
%
%        - (2000000000000000800000000 + 29999999999999999*i)*x
%
%        + (30000000000000003 + 2000000000000000200000000*i))/2

%rr := {x=100000000 + i,x=100000000 - i,x=i,
%
%          200000000 - 3*i
%       x=-----------------}
%                 2

% Reconstructing a polynomial from the roots.
ss := mkpoly rr;


         4                    3                      2
ss := 2*x  - (600000000 - i)*x  + 60000000000000005*x

       - (2000000000000000800000000 + 29999999999999999*i)*x + 30000000000000003

       + 2000000000000000200000000*i


%         4                    3                      2
%ss := 2*x  - (600000000 - i)*x  + 60000000000000005*x
%
%       - (2000000000000000800000000 + 29999999999999999*i)*x
%
%       + (30000000000000003 + 2000000000000000200000000*i)

% In this case, the same polynomial is obtained.
ss - num zz;


0

% 0

% 71) Finding one of the complex roots using nearestroot.
nearestroot(zz,10**8-2i);


    200000000 - 3*i
{x=-----------------}
           2
 

%    200000000 - 3*I
%{x=-----------------}
%           2

% Finding the other complex root using nearestroot.
nearestroot(zz,10**8+2i);


{x=100000000 + i}

%{x=100000000 + I}

% 72) A realroots problem which requires accuracy increase to avoid
% confusion of two roots.
zz:=(x+1)*(10000000x-19999999)*(1000000x-2000001)*(x-2);


                      4                   3                   2
zz := 10000000000000*x  - 50000009000000*x  + 60000026999999*x

       + 40000000000001*x - 80000035999998

realroots zz;


{x= - 1,

    19999999
 x=----------,
    10000000

 x=2,

    2000001
 x=---------}
    1000000
 

%          19999999         2000001
% {x=-1,x=----------,x=2,x=---------}
%          10000000         1000000

% 73) Without the accuracy increase, this example would produce the
% obviously incorrect answer 2.
realroots(zz,3/2,exclude 2);


    19999999
{x=----------}
    10000000
 

%     19999999
% {x=----------}
%     10000000

% Rlrootno also gives the correct answer in this case.
rlrootno(zz,3/2,exclude 2);


1

% 1

% 74) Roots works equally well in this problem.
rr := roots zz;


rr := {x= - 1,

          19999999
       x=----------,
          10000000

       x=2,

          2000001
       x=---------}
          1000000

%                 19999999        2000001
%rr := {x= - 1,x=----------,x=2,x=---------}
%                 10000000        1000000

% 75) The function getroot is convenient for obtaining the value of a
% root.
rr1 := getroot(1,rr);


rr1 := -1


%         19999999
% rr1 := ----------
%         10000000

% 76) For example, the value can be used as an argument to nearestroot.
nearestroot(zz,rr1);


{x= - 1}
 

%     19999999
% {x=----------}
%     10000000


comment  New capabilities added to Mod 1.90 for avoiding floating point
  exceptions and exceeding iteration limits.;


% 77) This and the next example would previously have aborted because
%of exceeding iteration limits:
off ratroot;

 zz := x**16 - 900x**15 -2;


       16        15
zz := x   - 900*x   - 2
 roots zz;


{x= - 0.665423,

 x= - 0.607902 + 0.270641*i,

 x= - 0.607902 - 0.270641*i,

 x= - 0.44528 + 0.494497*i,

 x= - 0.44528 - 0.494497*i,

 x= - 0.205664 + 0.632867*i,

 x= - 0.205664 - 0.632867*i,

 x=0.069527 + 0.661817*i,

 x=0.069527 - 0.661817*i,

 x=0.332711 + 0.57633*i,

 x=0.332711 - 0.57633*i,

 x=0.538375 + 0.391176*i,

 x=0.538375 - 0.391176*i,

 x=0.650944 + 0.138369*i,

 x=0.650944 - 0.138369*i,

 x=900.0}

%{x= - 0.665423,x=-0.607902 + 0.270641*i,x=-0.607902 - 0.270641*i,
% x=-0.44528 + 0.494497*i, x=-0.44528 - 0.494497*i,
% x=-0.205664 + 0.632867*i,x=-0.205664 - 0.632867*i,
% x=0.069527 + 0.661817*i,x=0.069527 - 0.661817*i,
% x=0.332711 + 0.57633*i,x=0.332711 - 0.57633*i,
% x=0.538375 + 0.391176*i,x=0.538375 - 0.391176*i,
% x=0.650944 + 0.138369*i,x=0.650944 - 0.138369*i,x=900.0}

% 78) a still harder example.
zz := x**30 - 900x**29 - 2;


       30        29
zz := x   - 900*x   - 2
 roots zz;


{x= - 0.810021,

 x= - 0.791085 + 0.174125*i,

 x= - 0.791085 - 0.174125*i,

 x= - 0.735162 + 0.340111*i,

 x= - 0.735162 - 0.340111*i,

 x= - 0.644866 + 0.490195*i,

 x= - 0.644866 - 0.490195*i,

 x= - 0.524417 + 0.617362*i,

 x= - 0.524417 - 0.617362*i,

 x= - 0.379447 + 0.715665*i,

 x= - 0.379447 - 0.715665*i,

 x= - 0.216732 + 0.780507*i,

 x= - 0.216732 - 0.780507*i,

 x= - 0.04388 + 0.808856*i,

 x= - 0.04388 - 0.808856*i,

 x=0.131027 + 0.799383*i,

 x=0.131027 - 0.799383*i,

 x=0.299811 + 0.752532*i,

 x=0.299811 - 0.752532*i,

 x=0.454578 + 0.67049*i,

 x=0.454578 - 0.67049*i,

 x=0.588091 + 0.557094*i,

 x=0.588091 - 0.557094*i,

 x=0.694106 + 0.417645*i,

 x=0.694106 - 0.417645*i,

 x=0.767663 + 0.258664*i,

 x=0.767663 - 0.258664*i,

 x=0.805322 + 0.0875868*i,

 x=0.805322 - 0.0875868*i,

 x=900.0}

%{x= - 0.810021,x=-0.791085 + 0.174125*i,x=-0.791085 - 0.174125*i,
% x=-0.735162 + 0.340111*i,x=-0.735162 - 0.340111*i,
% x=-0.644866 + 0.490195*i,x=-0.644866 - 0.490195*i,
% x=-0.524417 + 0.617362*i,x=-0.524417 - 0.617362*i,
% x=-0.379447 + 0.715665*i,x=-0.379447 - 0.715665*i,
% x=-0.216732 + 0.780507*i,x=-0.216732 - 0.780507*i,
% x=-0.04388 + 0.808856*i,x=-0.04388 - 0.808856*i,
% x=0.131027 + 0.799383*i,x=0.131027 - 0.799383*i,
% x=0.299811 + 0.752532*i,x=0.299811 - 0.752532*i,
% x=0.454578 + 0.67049*i,x=0.454578 - 0.67049*i,
% x=0.588091 + 0.557094*i,x=0.588091 - 0.557094*i,
% x=0.694106 + 0.417645*i,x=0.694106 - 0.417645*i,
% x=0.767663 + 0.258664*i,x=0.767663 - 0.258664*i,
% x=0.805322 + 0.0875868*i,x=0.805322 - 0.0875868*i,x=900.0}

% 79) this deceptively simple example previously caused floating point
% overflows on some systems:
aa := x**6 - 4*x**3 + 2;


       6      3
aa := x  - 4*x  + 2
 realroots aa;


{x=0.836719,x=1.50579}

%{x=0.836719,x=1.50579}

% 80) a harder problem, which would have failed on almost all systems:
rr := x**16 - 90000x**15 - x**2 -2;


       16          15    2
rr := x   - 90000*x   - x  - 2
 realroots rr;


{x= - 0.493299,x=90000.0}

%{x= - 0.493299,x=90000.0}

% 81) this example would have failed because of floating point
% exceptions on almost all computer systems.
rr := x**30 - 9*10**10*x**29 - 2;


       30                29
rr := x   - 90000000000*x   - 2
  realroots rr;


{x= - 0.429188,x=9.0e+10}

%{x= - 0.429188,x=9.0E+10}

% 82) a test of allroot on this example.
% This example is commented out because it takes significant time
% without breaking new ground.
%**% roots  rr;
%{x= - 0.429188,
% x=-0.419154 + 0.092263*i,x=-0.419154 - 0.092263*i,
% x=-0.389521 + 0.180211*i,x=-0.389521 - 0.180211*i,
% x=-0.341674 + 0.259734*i,x=-0.341674 - 0.259734*i,
% x=-0.277851 + 0.327111*i,x=-0.277851 - 0.327111*i,
% x=-0.201035 + 0.379193*i,x=-0.201035 - 0.379193*i,
% x=-0.11482 + 0.413544*i,x=-0.11482 - 0.413544*i,
% x=-0.0232358 + 0.428559*i,x=-0.0232358 - 0.428559*i,
% x=0.0694349 + 0.423534*i,x=0.0694349 - 0.423534*i,
% x=0.158859 + 0.398706*i,x=0.158859 - 0.398706*i,
% x=0.240855 + 0.355234*i,x=0.240855 - 0.355234*i,
% x=0.311589 + 0.295153*i,x=0.311589 - 0.295153*i,
% x=0.367753 + 0.22127*i,x=0.367753 - 0.22127*i,
% x=0.406722 + 0.13704*i,x=0.406722 - 0.13704*i,
% x=0.426672 + 0.0464034*i,x=0.426672 - 0.0464034*i,x=9.0E+10}

% 83) test of starting point for iteration: no convergence if good
% real starting point is not found.
zz := x**30 -9*10**12x**29 -2;


       30                  29
zz := x   - 9000000000000*x   - 2
 firstroot zz;


{x= - 0.36617}

%{x= - 0.36617}

% 84) a case in which there are no real roots and good imaginary
% starting point must be used or roots cannot be found.
zz:= 9x**16 - x**5 +1;


         16    5
zz := 9*x   - x  + 1
 roots zz;


{x= - 0.866594 + 0.193562*i,

 x= - 0.866594 - 0.193562*i,

 x= - 0.697397 + 0.473355*i,

 x= - 0.697397 - 0.473355*i,

 x= - 0.510014 + 0.716449*i,

 x= - 0.510014 - 0.716449*i,

 x= - 0.161318 + 0.87905*i,

 x= - 0.161318 - 0.87905*i,

 x=0.182294 + 0.828368*i,

 x=0.182294 - 0.828368*i,

 x=0.459373 + 0.737443*i,

 x=0.459373 - 0.737443*i,

 x=0.748039 + 0.494348*i,

 x=0.748039 - 0.494348*i,

 x=0.845617 + 0.142879*i,

 x=0.845617 - 0.142879*i}

%{x=-0.866594 + 0.193562*i,x=-0.866594 - 0.193562*i,
% x=-0.697397 + 0.473355*i,x=-0.697397 - 0.473355*i,
% x=-0.510014 + 0.716449*i,x=-0.510014 - 0.716449*i,
% x=-0.161318 + 0.87905*i,x=-0.161318 - 0.87905*i,
% x=0.182294 + 0.828368*i,x=0.182294 - 0.828368*i,
% x=0.459373 + 0.737443*i,x=0.459373 - 0.737443*i,
% x=0.748039 + 0.494348*i,x=0.748039 - 0.494348*i,
% x=0.845617 + 0.142879*i,x=0.845617 - 0.142879*i}

% 85) five complex roots.
zz := x**5 - x**3 + i;


       5    3
zz := x  - x  + i
 roots zz;


{x= - 1.16695 - 0.217853*i,

 x= - 0.664702 + 0.636663*i,

 x= - 0.83762*i,

 x=0.664702 + 0.636663*i,

 x=1.16695 - 0.217853*i}

%{x=-1.16695 - 0.217853*i,x=-0.664702 + 0.636663*i,x=-0.83762*i,
% x=0.664702 + 0.636663*i,x=1.16695 - 0.217853*i}

% Additional capabilities in Mod 1.91.

% 86) handling of polynomial with huge or infinitesimal coefficients.
precision reset;


12

on rounded;


*** Domain mode complex changed to complex-rounded 
 precision reset;


12

% so that the system will start this example in floating point.  Rounded
% is on so that the polynomial won't fill the page!
zz:= 1.0e-500x**3+x**2+x;


*** ROUNDBF turned on to increase accuracy 

                   2
zz := x*(1.0e-500*x  + x + 1)

roots zz;


{x=0,x= - 1.0e+500,x= - 1}
 off rounded;


*** Domain mode complex-rounded changed to complex 
 % rounded not normally needed for roots.
%{x=0,x= - 1.0E+500,x= - 1}
off roundbf;



comment  Switch roundbf will have been turned on in the last example in
  most computer systems.  This will inhibit the use of hardware floating
  point unless roundbf is turned off.

  Polynomials which make use of powergcd substitution and cascaded
  solutions.

  Uncomplicated cases.;


switch powergcd;

 % introduced here to verify that same answers are
% obtained with and without employing powergcd strategy.  Roots are
% found faster for applicable cases when !*powergcd=t (default state.)

% 87) powergcd done at the top level.
zz := x**12-5x**9+1;


       12      9
zz := x   - 5*x  + 1
 roots zz;


{x= - 0.783212 + 0.276071*i,

 x=0.152522 - 0.816316*i,

 x=0.63069 + 0.540246*i,

 x= - 0.783212 - 0.276071*i,

 x=0.152522 + 0.816316*i,

 x=0.63069 - 0.540246*i,

 x= - 0.424222 + 0.734774*i,

 x= - 0.424222 - 0.734774*i,

 x=0.848444,

 x= - 0.85453 + 1.48009*i,

 x= - 0.85453 - 1.48009*i,

 x=1.70906}

%{x=-0.783212 + 0.276071*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=-0.783212 - 0.276071*i,
% x=0.152522 + 0.816316*i,x=0.63069 - 0.540246*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,x=0.848444,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,x=1.70906}

off powergcd;

 roots zz;


{x= - 0.85453 + 1.48009*i,

 x= - 0.85453 - 1.48009*i,

 x= - 0.783212 + 0.276071*i,

 x= - 0.783212 - 0.276071*i,

 x= - 0.424222 + 0.734774*i,

 x= - 0.424222 - 0.734774*i,

 x=0.152522 + 0.816316*i,

 x=0.152522 - 0.816316*i,

 x=0.63069 + 0.540246*i,

 x=0.63069 - 0.540246*i,

 x=0.848444,

 x=1.70906}
 on powergcd;


%{x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,
% x=-0.783212 + 0.276071*i,x=-0.783212 - 0.276071*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,
% x=0.152522 + 0.816316*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=0.63069 - 0.540246*i,x=0.848444,x=1.70906}

% 88) powergcd done after square free factoring.
zz := (x-1)**2*zz;


       14      13    12      11       10      9    2
zz := x   - 2*x   + x   - 5*x   + 10*x   - 5*x  + x  - 2*x + 1
 roots zz;


{x=1,

 x=1,

 x= - 0.783212 + 0.276071*i,

 x=0.152522 - 0.816316*i,

 x=0.63069 + 0.540246*i,

 x= - 0.783212 - 0.276071*i,

 x=0.152522 + 0.816316*i,

 x=0.63069 - 0.540246*i,

 x= - 0.424222 + 0.734774*i,

 x= - 0.424222 - 0.734774*i,

 x=0.848444,

 x= - 0.85453 + 1.48009*i,

 x= - 0.85453 - 1.48009*i,

 x=1.70906}

%{x=1,x=1,
% x=-0.783212 + 0.276071*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=-0.783212 - 0.276071*i,
% x=0.152522 + 0.816316*i,x=0.63069 - 0.540246*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,x=0.848444,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,x=1.70906}

off powergcd;

 roots zz;


{x=1,

 x=1,

 x= - 0.85453 + 1.48009*i,

 x= - 0.85453 - 1.48009*i,

 x= - 0.783212 + 0.276071*i,

 x= - 0.783212 - 0.276071*i,

 x= - 0.424222 + 0.734774*i,

 x= - 0.424222 - 0.734774*i,

 x=0.152522 + 0.816316*i,

 x=0.152522 - 0.816316*i,

 x=0.63069 + 0.540246*i,

 x=0.63069 - 0.540246*i,

 x=0.848444,

 x=1.70906}
 on powergcd;


%{x=1,x=1,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,
% x=-0.783212 + 0.276071*i,x=-0.783212 - 0.276071*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,
% x=0.152522 + 0.816316*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=0.63069 - 0.540246*i,
% x=0.848444,x=1.70906}

% 89) powergcd done after separation into real and complex polynomial.
zz := x**5-i*x**4+x**3-i*x**2+x-i;


       5      4    3      2
zz := x  - i*x  + x  - i*x  + x - i
 roots zz;


{x= - 0.5 - 0.866025*i,

 x=0.5 + 0.866025*i,

 x= - 0.5 + 0.866025*i,

 x=0.5 - 0.866025*i,

 x=i}

%{x=-0.5 - 0.866025*i,x=0.5 + 0.866025*i,
% x=-0.5 + 0.866025*i,x=0.5 - 0.866025*i,x=i}

off powergcd;

 roots zz;


{x= - 0.5 + 0.866025*i,

 x= - 0.5 - 0.866025*i,

 x=0.5 + 0.866025*i,

 x=0.5 - 0.866025*i,

 x=i}
 on powergcd;


%{x=-0.5 + 0.866025*i,x=-0.5 - 0.866025*i,
% x=0.5 + 0.866025*i,x=0.5 - 0.866025*i,x=i}

% Cases where root separation requires accuracy and/or precision
% increase.  In some examples we get excess accuracy, but it is hard
% avoid this and still get all roots separated.

% 90) accuracy increase required to separate close roots;
let x=y**2;


zz:= (x-3)*(100000000x-300000001);


                 4              2
zz := 100000000*y  - 600000001*y  + 900000003
 roots zz;


{y= - 1.732050808,

 y=1.732050808,

 y= - 1.73205081,

 y=1.73205081}

%{y= - 1.732050808,y=1.732050808,y= - 1.73205081,y=1.73205081}

off powergcd;

 roots zz;


{y= - 1.73205081,

 y= - 1.732050808,

 y=1.732050808,

 y=1.73205081}
  on powergcd;


%{y= - 1.73205081,y= - 1.732050808,y=1.732050808,y=1.73205081}

% 91) roots to be separated are on different square free factors.
zz:= (x-3)**2*(10000000x-30000001);


                6             4              2
zz := 10000000*y  - 90000001*y  + 270000006*y  - 270000009
 roots zz;


{y= - 1.73205081,

 y= - 1.73205081,

 y=1.73205081,

 y=1.73205081,

 y= - 1.73205084,

 y=1.73205084}

%{y= - 1.73205081,y= - 1.73205081,y=1.73205081,y=1.73205081,
% y= - 1.73205084,y=1.73205084}

off powergcd;

 roots zz;


{y= - 1.73205081,

 y= - 1.73205081,

 y=1.73205081,

 y=1.73205081,

 y= - 1.73205084,

 y=1.73205084}
  on powergcd;


%{y= - 1.73205081,y= - 1.73205081,y=1.73205081,y=1.73205081,
% y= - 1.73205084,y=1.73205084}

% 91a) A new capability for nearestroot:
nearestroot(zz,1.800000000001);


*** precision increased to 13 

{y=1.732050836436}
 % should find the root to 13 places.
%{y=1.732050836436}

% 92) roots must be separated in the complex polynomial factor only.
zz :=(y+1)*(x+10**8i)*(x+10**8i+1);


       5    4                      3                      2
zz := y  + y  + (1 + 200000000*i)*y  + (1 + 200000000*i)*y

       - (10000000000000000 - 100000000*i)*y - (10000000000000000 - 100000000*i)
 roots zz;


{y= - 1,

 y= - 7071.067777 + 7071.067847*i,

 y=7071.067777 - 7071.067847*i,

 y= - 7071.067812 + 7071.067812*i,

 y=7071.067812 - 7071.067812*i}

%{y= - 1,
% y=-7071.067777 + 7071.067847*i,y=7071.067777 - 7071.067847*i,
% y=-7071.067812 + 7071.067812*i,y=7071.067812 - 7071.067812*i}

% 93)
zz := (x-2)**2*(1000000x-2000001)*(y-1);


               7            6            5            4             3
zz := 1000000*y  - 1000000*y  - 6000001*y  + 6000001*y  + 12000004*y

                   2
       - 12000004*y  - 8000004*y + 8000004
 roots zz;


{y= - 1.4142136,

 y= - 1.4142136,

 y=1.4142136,

 y=1.4142136,

 y= - 1.4142139,

 y=1,

 y=1.4142139}

%{y= - 1.4142136,y= - 1.4142136,y=1.4142136,y=1.4142136,
% y= - 1.4142139,y=1,y=1.4142139}

% 94)
zz := (x-2)*(10000000x-20000001);


                4             2
zz := 10000000*y  - 40000001*y  + 40000002
 roots zz;


{y= - 1.41421356,

 y=1.41421356,

 y= - 1.4142136,

 y=1.4142136}

%{y= - 1.41421356 ,y=1.41421356 ,y= - 1.4142136,y=1.4142136}

% 95)
zz := (x-3)*(10000000x-30000001);


                4             2
zz := 10000000*y  - 60000001*y  + 90000003
 roots zz;


{y= - 1.73205081,

 y=1.73205081,

 y= - 1.73205084,

 y=1.73205084}

%{y= - 1.73205081 ,y=1.73205081 ,y= - 1.73205084 ,y=1.73205084}

% 96)
zz := (x-9)**2*(1000000x-9000001);


               6             4              2
zz := 1000000*y  - 27000001*y  + 243000018*y  - 729000081
 roots zz;


{y= - 3.0,

 y= - 3.0,

 y=3.0,

 y=3.0,

 y= - 3.00000017,

 y=3.00000017}

%{y= - 3.0,y= - 3.0,y=3.0,y=3.0,y= - 3.00000017,y=3.00000017}

% 97)
zz := (x-3)**2*(1000000x-3000001);


               6            4             2
zz := 1000000*y  - 9000001*y  + 27000006*y  - 27000009
 roots zz;


{y= - 1.7320508,

 y= - 1.7320508,

 y=1.7320508,

 y=1.7320508,

 y= - 1.7320511,

 y=1.7320511}

%{y= - 1.7320508,y= - 1.7320508,y=1.7320508,y=1.7320508,
% y= - 1.7320511,y=1.7320511}

% 98) the accuracy of the root sqrt 5 depends upon another close root.
% Although one of the factors is given in decimal notation, it is not
% necessary to turn rounded on.
rootacc 10;


10
 % using rootacc to specify the minumum desired accuracy.
zz := (y^2-5)*(y-2.2360679775);


                  3              2
       400000000*y  - 894427191*y  - 2000000000*y + 4472135955
zz := ---------------------------------------------------------
                              400000000

% in this case, adding one place to the root near sqrt 5 causes a
% required increase of 4 places in accuracy of the root at sqrt 5.
roots zz;


*** precision increased to 14 

{y= - 2.236067977,y=2.2360679774998,y=2.2360679775}

%{y= - 2.236067977,y=2.2360679774998,y=2.2360679775}

realroots zz;


{y= - 2.236067977,y=2.2360679774998,y=2.2360679775}
 % should get the same answer from realroots.
%{y= - 2.2360679775,y=2.2360679774998,y=2.2360679775}


% 99) The same thing also happens when the root near sqrt 5 is on a
% different square-free factor.
zz := (y^2-5)^2*(y-2.2360679775);


                  5              4               3               2
zz := (400000000*y  - 894427191*y  - 4000000000*y  + 8944271910*y

        + 10000000000*y - 22360679775)/400000000

roots zz;


{y= - 2.236067977,

 y= - 2.236067977,

 y=2.2360679774998,

 y=2.2360679774998,

 y=2.2360679775}

%{y= - 2.236067977,y= - 2.236067977,y=2.2360679774998,
% y=2.2360679774998,y=2.2360679775}

realroots zz;


{y= - 2.236067977,

 y= - 2.236067977,

 y=2.2360679774998,

 y=2.2360679774998,

 y=2.2360679775}
 % realroots handles this case also.
%{y= - 2.236067977,y= - 2.236067977,y=2.2360679774998,y=2.2360679774998,
% y=2.2360679775}

% 100)
rootacc 6;


6

zz := (y-i)*(x-2)*(1000000x-2000001);


zz := 

         5              4            3              2
1000000*y  - 1000000*i*y  - 4000001*y  + 4000001*i*y  + 4000002*y - 4000002*i
 roots zz;


{y= - 1.4142136,

 y=1.4142136,

 y= - 1.4142139,

 y=1.4142139,

 y=i}

%{y= - 1.4142136,y=1.4142136,y= - 1.4142139,y=1.4142139,y=i}

% 101) this example requires accuracy 15.
zz:= (y-2)*(100000000000000y-200000000000001);


                       2
zz := 100000000000000*y  - 400000000000001*y + 400000000000002

roots zz;


*** precision increased to 15 

{y=2.0,y=2.00000000000001}

%{y=2.0,y=2.00000000000001}

% 102) still higher precision needed.
zz:= (y-2)*(10000000000000000000y-20000000000000000001);


                            2
zz := 10000000000000000000*y  - 40000000000000000001*y + 40000000000000000002
 roots zz;


*** precision increased to 20 

{y=2.0,y=2.0000000000000000001}

%{y=2.0,y=2.0000000000000000001}

% 103) increase in precision required for substituted polynomial.
zz:= (x-2)*(10000000000x-20000000001);


                   4                2
zz := 10000000000*y  - 40000000001*y  + 40000000002
 roots zz;


{y= - 1.41421356237,

 y=1.41421356237,

 y= - 1.41421356241,

 y=1.41421356241}

%{y= - 1.41421356237,y=1.41421356237,y= - 1.41421356241,y=1.41421356241}

% 104) still higher precision required for substituted polynomial.
zz:= (x-2)*(100000000000000x-200000000000001);


                       4                    2
zz := 100000000000000*y  - 400000000000001*y  + 400000000000002
 roots zz;


*** input of these values may require precision >=  16 

{y= - 1.414213562373095,

 y=1.414213562373095,

 y= - 1.414213562373099,

 y=1.414213562373099}

%{y= - 1.414213562373095,y=1.414213562373095,
% y= - 1.414213562373099,y=1.414213562373099}

% 105) accuracy must be increased to separate root of complex factor
% from root of real factor.
zz:=(9y-10)*(y-2)*(9y-10-9i/100000000);


                   3                         2
zz := (8100000000*y  - (34200000000 + 81*i)*y  + (46000000000 + 252*i)*y

        - (20000000000 + 180*i))/100000000
 roots zz;


{y=1.111111111,y=2.0,y=1.111111111 + 0.00000001*i}

%{y=1.111111111,y=2.0,y=1.111111111 + 0.00000001*i}

% 106) realroots does the same accuracy increase for real root based
% upon the presence of a close complex root in the same polynomial.
% The reason for this might not be obvious unless roots is called.
realroots zz;


{y=1.111111111,y=2.0}

%{y=1.111111111,y=2.0}

% 107) realroots now uses powergcd logic whenever it is applicable.
zz := (x-1)*(x-2)*(x-3);


       6      4       2
zz := y  - 6*y  + 11*y  - 6
  realroots zz;


{y= - 1,

 y=1,

 y= - 1.41421,

 y=1.41421,

 y= - 1.73205,

 y=1.73205}

%{y= - 1,y=1,y= - 1.41421,y=1.41421,y= - 1.73205,y=1.73205}

realroots(zz,exclude 1,2);


{y=1.41421,y=1.73205}

%{y=1.41421,y=1.73205}

% 108) root of degree 1 polynomial factor must be evaluated at
% precision 18 and accuracy 10 in order to separate it from a root of
% another real factor.
clear x;

 zz:=(9x-10)**2*(9x-10-9/100000000)*(x-2);


                    4                 3                 2
zz := (72900000000*x  - 388800000729*x  + 756000003078*x  - 640000004140*x

        + 200000001800)/100000000
 roots zz;


{x=1.111111111,

 x=1.111111111,

 x=1.111111121,

 x=2.0}

%{x=1.111111111,x=1.111111111,x=1.111111121,x=2.0}

nearestroot(zz,1);


{x=1.111111111}

%{x=1.111111111}

nearestroot(zz,1.5);


{x=1.111111121}

%{x=1.111111121}

nearestroot(zz,1.65);


{x=2.0}

%{x=2.0}

% 108a) new cability in mod 1.94.
realroots zz;


{x=1.111111111,

 x=1.111111111,

 x=1.111111121,

 x=2.0}

%{x=1.111111111,x=1.111111111,x=1.111111121,x=2.0}

% 109) in this example, precision >=40 is used and two roots need to be
% found to accuracy 16 and two to accuracy 14.
zz := (9x-10)*(7x-8)*(9x-10-9/10**12)*(7x-8-7/10**14);


                                       4                                    3
zz := (396900000000000000000000000000*x  - 1789200000000400869000000000000*x

                                           2
        + 3024400000001361556000000003969*x  - 2272000000001541380000000008946*x

        + 640000000000581600000000005040)/100000000000000000000000000
 roots zz;


*** input of these values may require precision >=  16 

{x=1.1111111111111,

 x=1.1111111111121,

 x=1.142857142857143,

 x=1.142857142857153}

%{x=1.1111111111111,x=1.1111111111121,
% x=1.142857142857143,x=1.142857142857153}

% 110) very small real or imaginary parts of roots require high
% precision or exact computations, or they will be lost or incorrectly
% found.
zz := 1000000*r**18 + 250000000000*r**4 - 1000000*r**2 + 1;


               18                 4            2
zz := 1000000*r   + 250000000000*r  - 1000000*r  + 1
 roots zz;


{r=2.42978*i,

 r= - 2.42978*i,

 r= - 1.05424 - 2.18916*i,

 r=1.05424 + 2.18916*i,

 r= - 1.05424 + 2.18916*i,

 r=1.05424 - 2.18916*i,

 r= - 0.00141421 - 1.6e-26*i,

 r=0.00141421 + 1.6e-26*i,

 r= - 0.00141421 + 1.6e-26*i,

 r=0.00141421 - 1.6e-26*i,

 r= - 1.89968 - 1.51494*i,

 r=1.89968 + 1.51494*i,

 r= - 1.89968 + 1.51494*i,

 r=1.89968 - 1.51494*i,

 r= - 2.36886 - 0.540677*i,

 r=2.36886 + 0.540677*i,

 r= - 2.36886 + 0.540677*i,

 r=2.36886 - 0.540677*i}

%{r=2.42978*i,r=-2.42978*i,
% r=-1.05424 - 2.18916*i,r=1.05424 + 2.18916*i,
% r=-1.05424 + 2.18916*i,r=1.05424 - 2.18916*i,
% r=-0.00141421 - 1.6E-26*i,r=0.00141421 + 1.6E-26*i,
% r=-0.00141421 + 1.6E-26*i,r=0.00141421 - 1.6E-26*i,
% r=-1.89968 - 1.51494*i,r=1.89968 + 1.51494*i,
% r=-1.89968 + 1.51494*i,r=1.89968 - 1.51494*i,
% r=-2.36886 - 0.540677*i,r=2.36886 + 0.540677*i,
% r=-2.36886 + 0.540677*i,r=2.36886 - 0.540677*i}


comment  These five examples are very difficult root finding problems
  for automatic root finding (not employing problem-specific
  procedures.) They require extremely high precision and high accuracy
  to separate almost multiple roots (multiplicity broken by a small high
  order perturbation.)  The examples are roughly in ascending order of
  difficulty.;


% 111) Two simple complex roots with extremely small real separation.
c := 10^-6;


         1
c := ---------
      1000000

zz:=(x-3c^2)^2+i*c*x^7;


zz := 

                        7                              2
 1000000000000000000*i*x  + 1000000000000000000000000*x  - 6000000000000*x + 9
-------------------------------------------------------------------------------
                           1000000000000000000000000
 roots zz;


*** precision increased to 33 

{x= - 15.0732 + 4.89759*i,

 x= - 9.31577 - 12.8221*i,

 x= - 1.2e-12 + 15.8489*i,

 x=2.99999999999999999999999999999997e-12

    + 3.3068111527572904325663335008527e-44*i,

 x=3.00000000000000000000000000000003e-12

    - 3.30681115275729043256633350085321e-44*i,

 x=9.31577 - 12.8221*i,

 x=15.0732 + 4.89759*i}

%{x=-15.0732 + 4.89759*i,x=-9.31577 - 12.8221*i,x=-1.2E-12 + 15.8489*i,
% x=2.99999999999999999999999999999997E-12
%    + 3.3068111527572904325663335008527E-44*i,
% x=3.00000000000000000000000000000003E-12
%    - 3.30681115275729043256633350085321E-44*i,
% x=9.31577 - 12.8221*i,x=15.0732 + 4.89759*i}

% 112) Four simple complex roots in two close sets.
c := 10^-4;


        1
c := -------
      10000

zz:=(x^2-3c^2)^2+i*c^2*x^9;


                    9                      4              2
       100000000*i*x  + 10000000000000000*x  - 600000000*x  + 9
zz := ----------------------------------------------------------
                          10000000000000000
 roots zz;


*** input of these values may require precision >=  15 

{x= - 37.8622 + 12.3022*i,

 x= - 23.4002 - 32.2075*i,

 x= - 0.00017320508075689 - 2.41778234660324e-18*i,

 x= - 0.000173205080756885 + 2.4177823466027e-18*i,

 x=39.8107*i,

 x=0.000173205080756885 + 2.4177823466027e-18*i,

 x=0.00017320508075689 - 2.41778234660324e-18*i,

 x=23.4002 - 32.2075*i,

 x=37.8622 + 12.3022*i}

%{x=-37.8622 + 12.3022*i,x=-23.4002 - 32.2075*i,
% x=-0.00017320508075689 - 2.41778234660324E-18*i,
% x=-0.000173205080756885 + 2.4177823466027E-18*i,
% x=39.8107*i,
% x=0.000173205080756885 + 2.4177823466027E-18*i,
% x=0.00017320508075689 - 2.41778234660324E-18*i,
% x=23.4002 - 32.2075*i,x=37.8622 + 12.3022*i}

% 113) Same example, but with higher minimum root accuracy specified.
rootacc 20;


20

roots zz;


{x= - 37.862241873586290526 + 12.302188128448775345*i,

 x= - 23.400152368145827118 - 32.207546656274351069*i,

 x= - 0.00017320508075689014714 - 2.417782346603239319e-18*i,

 x= - 0.00017320508075688531157 + 2.417782346602699319e-18*i,

 x=39.810717055651151449*i,

 x=0.00017320508075688531157 + 2.417782346602699319e-18*i,

 x=0.00017320508075689014714 - 2.417782346603239319e-18*i,

 x=23.400152368145827118 - 32.207546656274351069*i,

 x=37.862241873586290526 + 12.302188128448775345*i}

%{x=-37.862241873586290526 + 12.302188128448775345*i,
% x=-23.400152368145827118 - 32.207546656274351069*i,
% x=-0.00017320508075689014714 - 2.417782346603239319E-18*i,
% x=-0.00017320508075688531157 + 2.417782346602699319E-18*i,
% x=39.810717055651151449*i,
% x=0.00017320508075688531157 + 2.417782346602699319E-18*i,
% x=0.00017320508075689014714 - 2.417782346603239319E-18*i,
% x=23.400152368145827118 - 32.207546656274351069*i,
% x=37.862241873586290526 + 12.302188128448775345*i}

precision reset;


33

% This resets precision and rootacc to nominal.

% 114) Two extremely close real roots plus a complex pair with extremely
% small imaginary part.
c := 10^6;


c := 1000000

zz:=(c^2*x^2-3)^2+c^2*x^9;


                     9                              4                  2
zz := 1000000000000*x  + 1000000000000000000000000*x  - 6000000000000*x  + 9
 roots zz;


*** precision increased to 22 

{x= - 251.189,

 x= - 77.6216 + 238.895*i,

 x= - 77.6216 - 238.895*i,

 x= - 0.000001732050807568877293531,

 x= - 0.000001732050807568877293524,

 x=0.00000173205 + 3.41926e-27*i,

 x=0.00000173205 - 3.41926e-27*i,

 x=203.216 + 147.645*i,

 x=203.216 - 147.645*i}

%{x= - 251.189,x=-77.6216 + 238.895*i,x=-77.6216 - 238.895*i,
% x= - 0.000001732050807568877293531,
% x= - 0.000001732050807568877293524,
% x=0.00000173205 + 3.41926E-27*i,x=0.00000173205 - 3.41926E-27*i,
% x=203.216 + 147.645*i,x=203.216 - 147.645*i}

% 114a) this example is a critical test for realroots as well.
realroots zz;


{x= - 251.189,x= - 0.000001732050807568877293531,x

 = - 0.000001732050807568877293524}

%{x= - 251.189,x= - 0.000001732050807568877293531,
% x= - 0.000001732050807568877293524}

% 115) Four simple complex roots in two extremely close sets.
c := 10^6;


c := 1000000

zz:=(c^2*x^2-3)^2+i*c^2*x^9;


                       9                              4                  2
zz := 1000000000000*i*x  + 1000000000000000000000000*x  - 6000000000000*x  + 9
 roots zz;


{x= - 238.895 + 77.6216*i,

 x= - 147.645 - 203.216*i,

 x= - 0.00000173205080756887729353 - 2.417782346602969319022e-27*i,

 x= - 0.000001732050807568877293525 + 2.417782346602969318968e-27*i,

 x=251.189*i,

 x=0.000001732050807568877293525 + 2.417782346602969318968e-27*i,

 x=0.00000173205080756887729353 - 2.417782346602969319022e-27*i,

 x=147.645 - 203.216*i,

 x=238.895 + 77.6216*i}

%{x=-238.895 + 77.6216*i,x=-147.645 - 203.216*i,
% x=-0.00000173205080756887729353 - 2.417782346602969319022E-27*i,
% x=-0.000001732050807568877293525 + 2.417782346602969318968E-27*i,
% x=251.189*i,
% x=0.000001732050807568877293525 + 2.417782346602969318968E-27*i,
% x=0.00000173205080756887729353 - 2.417782346602969319022E-27*i,
% x=147.645 - 203.216*i,x=238.895 + 77.6216*i}


% 116) A new "hardest example" type.  This polynomial has two sets of
% extremely close real roots and two sets of extremely close conjugate
% complex roots, both large and small, with the maximum accuracy and
% precision required for the largest roots.  Three restarts are
% required, at progressively higher precision, to find all roots.
 % (to run this example, uncomment the following two lines.)
%**% zz1:= (10^12x^2-sqrt 2)^2+x^7$ zz2:= (10^12x^2+sqrt 2)^2+x^7$
%**% zzzz := zz1*zz2$ roots zzzz;
%{x= - 1.00000000000000000000000000009E+8,
% x= - 9.99999999999999999999999999906E+7,
% x= - 0.0000011892071150027210667183,
% x= - 0.0000011892071150027210667167,
% x=-5.4525386633262882960501E-28 + 0.000001189207115002721066718*i,
% x=-5.4525386633262882960501E-28 - 0.000001189207115002721066718*i,
% x=5.4525386633262882960201E-28 + 0.000001189207115002721066717*i,
% x=5.4525386633262882960201E-28 - 0.000001189207115002721066717*i,
% x=0.00000118921 + 7.71105E-28*i,
% x=0.00000118921 - 7.71105E-28*i,
% x=4.99999999999999999999999999953E+7
%    + 8.66025403784438646763723170835E+7*i,
% x=4.99999999999999999999999999953E+7
%    - 8.66025403784438646763723170835E+7*i,
% x=5.00000000000000000000000000047E+7
%    + 8.66025403784438646763723170671E+7*i,
% x=5.00000000000000000000000000047E+7
%    - 8.66025403784438646763723170671E+7*i}

% Realroots strategy on this example is different, but determining the
% necessary precision and accuracy is tricky.
%**% realroots zzzz;
%{x= - 1.00000000000000000000000000009E+8,
% x= - 9.9999999999999999999999999991E+7,
% x= - 0.0000011892071150027210667183,
% x= - 0.0000011892071150027210667167}

% 117) multroot examples.  Multroot can be called directly, or it can be
% called by giving roots or realroots a list of polynomials as argument.
% Here, multroot is called directly.  Realroots is used unless the switch
% compxroots is on.  In this example, p1 must be computed at accuracy 33
% in order to yield an accuracy of 20 for p2.
res :=          % Structure is {eq1(p1,p2),eq2(p1)}
{ - 65193331905902035840886401184447471772856493442267717*P1**13
- 1664429561324832520726401259146912155464247056480012434*P1**12
- 6261475374084274810766056740641579522309310708502887990*P1**11
+ 58050875148721867394302891225676265051604299348469583622*P1**10
- 25149162547648105419319267662238682603649922079217227285*P1**9
- 440495842372965561251919788209759089436362766115660350108*P1**8
+ 1031835865631194068430476093579502290454870220388968336688*P1**7
- 176560168441303582471783015188457142709772508915411137856*P1**6
- 3394297397883799767380936436924078166849454318674637153232*P1**5
+ 8572159983028240622274769676964404195355003175115163884096*P1**4
- 11689989317682872105592244166702248132836279639925035950656*P1**3
+ 9646776768609439752430866001814626337809195004192011294976*P1**2
- 4455646388442119339178004445898515058096390082146233345536*P1
+ 4709370575236909034773453200518274143851133066819671040*P2
+ 886058257542744466307567014351806947093655767531394713600,
53271*P1**14 + 1393662*P1**13 + 6077030*P1**12 - 41382626*P1**11
+ 6240255*P1**10 + 313751524*P1**9 - 698694844*P1**8
+ 134987928*P1**7 + 2322386256*P1**6 - 6102636608*P1**5
+ 8722164608*P1**4 - 7907887488*P1**3 + 4508378368*P1**2
- 1477342720*P1 + 213248000}$


multroot(20,res);


{{p1= - 16.330244199212269912,p2= - 12.905402440394357204},{p1

    = - 13.071850241794867852,p2= - 20.369934278813005573}}

%{{p1= - 16.330244199212269912,p2= - 12.905402440394357204},{p1
%    = - 13.071850241794867852,p2= - 20.369934278813005573}}

% 118)  structure is {p1(x1,x3,x4),p2(x2,x4),p3(x2,x3,x4),p4(x4)}
h := {36439926476029643745*x1 + 36439926476029643745*x3
- 966689910765785535050240000*x4**17
+ 2589213991952971388822784000*x4**16
- 1455736281904024746728256000*x4**15
- 1114734065976529083327407360*x4**14
+ 720240539282202478990426752*x4**13
+ 419779761544955697624679296*x4**12
- 168749980172837712266699840*x4**11
+ 290913179471491189688854560*x4**10 - 432958804125555395247740688*x4**9 
+ 10386593827154614897599504*x4**8 + 155547361883654478618679440*x4**7
- 31113996003728470659075480*x4**6 - 41175755320900503555096780*x4**5
+ 33003268068791208924709740*x4**4 - 6778828915691466390091200*x4**3
- 1496167017611703417373950*x4**2 + 149688116448660711183825*x4
+ 138148004064999041884935,
- 36439926476029643745*x2 - 784034192593211415232000000*x4**17
+ 2099814921874128508369920000*x4**16
- 1180307545285783973854272000*x4**15
- 904159020650675303719168000*x4**14
+ 583907514538684395627559680*x4**13
+ 340458856280381353403249664*x4**12
- 136785894094420325707236352*x4**11
+ 235962131906791901454310848*x4**10
- 351090033711917923140908256*x4**9 + 8379974606095284871931520*x4**8
+ 126131069262992237456374584*x4**7 -25220359028157888406315896*x4**6
- 33393008746801847984243640*x4**5 + 26761347051713933045852160*x4**4
- 5495296446381334401240210*x4**3 - 1213098761225775782417310*x4**2
+ 121243165959568584810870*x4 + 112046752277725240396125,
145759705904118574980*x3**2 - 3866759643063142140200960000*x3*x4**17
+ 10356855967811885555291136000*x3*x4**16
- 5822945127616098986913024000*x3*x4**15
- 4458936263906116333309629440*x3*x4**14
+ 2880962157128809915961707008*x3*x4**13
+ 1679119046179822790498717184*x3*x4**12
- 674999920691350849066799360*x3*x4**11
+ 1163652717885964758755418240*x3*x4**10
- 1731835216502221580990962752*x3*x4**9
+ 41546375308618459590398016*x3*x4**8
+ 622189447534617914474717760*x3*x4**7
- 124455984014913882636301920*x3*x4**6
- 164703021283602014220387120*x3*x4**5
+ 132013072275164835698838960*x3*x4**4
- 27115315662765865560364800*x3*x4**3
- 5984668070446813669495800*x3*x4**2 + 598752465794642844735300*x3*x4
+ 552592016259996167539740*x3 + 3550270013715070172487680000*x4**17
- 9573649159583488469933568000*x4**16
+ 5464438450196473162575360000*x4**15
+ 4096921924516221821604523520*x4**14
- 2717026023466705910519606784*x4**13
- 1554544907157405816469959168*x4**12
+ 636859360057972319632500992*x4**11
- 1065163663567422851531986944*x4**10
+ 1612243029585251439302638656*x4**9
- 48252032958282805311135168*x4**8 - 579133322758350220074700320*x4**7
+ 117976179842506552019678280*x4**6 + 152287445048713077301910400*x4**5 
- 123053170142513516618082960*x4**4 + 25533441675517563881962200*x4**3
+ 5583415080801636858130200*x4**2 - 574247940288215661001800*x4
- 518304795930023609925945,
- 5120000*x4**18 + 18432000*x4**17 - 20352000*x4**16 + 1208320*x4**15
+ 9255936*x4**14 - 1296384*x4**13 - 2943488*x4**12 + 2365440*x4**11
- 3712896*x4**10 + 2169600*x4**9 + 772560*x4**8 - 924480*x4**7
- 66000*x4**6 + 375840*x4**5 - 197100*x4**4 + 25200*x4**3 + 8100*x4**2
- 675}$


multroot(20,h);


{{x1= - 0.12444800707566022364,x2=0.40264591905223704246,x3

  =0.70281784593572688134,x4=0.92049796029182926078},

 {x1= - 0.12444800707566022364,x2=0.92049796029182926078,x3

  =0.70281784593572688134,x4=0.40264591905223704246},

 {x1=0.22075230018295426413,x2=0.48100256896929398759,x3=0.74057635603986743051,

  x4=0.93049526909398804249},

 {x1=0.22075230018295426413,x2=0.93049526909398804249,x3=0.74057635603986743051,

  x4=0.48100256896929398759},

 {x1=0.70281784593572688134,x2=0.40264591905223704246,x3

  = - 0.12444800707566022364,x4=0.92049796029182926078},

 {x1=0.70281784593572688134,x2=0.92049796029182926078,x3

  = - 0.12444800707566022364,x4=0.40264591905223704246},

 {x1=0.74057635603986743051,x2=0.48100256896929398759,x3=0.22075230018295426413,

  x4=0.93049526909398804249},

 {x1=0.74057635603986743051,x2=0.93049526909398804249,x3=0.22075230018295426413,

  x4=0.48100256896929398759}}

%{{x1= - 0.12444800707566022364,x2=0.40264591905223704246,x3
%  =0.70281784593572688134,x4=0.92049796029182926078},
% {x1= - 0.12444800707566022364,x2=0.92049796029182926078,x3
%  =0.70281784593572688134,x4=0.40264591905223704246},
% {x1=0.22075230018295426413,x2=0.48100256896929398759,x3
%  =0.74057635603986743051,x4=0.93049526909398804249},
% {x1=0.22075230018295426413,x2=0.93049526909398804249,x3
%  =0.74057635603986743051,x4=0.48100256896929398759},
% {x1=0.70281784593572688134,x2=0.40264591905223704246,x3
%  = - 0.12444800707566022364,x4=0.92049796029182926078},
% {x1=0.70281784593572688134,x2=0.92049796029182926078,x3
%  = - 0.12444800707566022364,x4=0.40264591905223704246},
% {x1=0.74057635603986743051,x2=0.48100256896929398759,x3
%  =0.22075230018295426413,x4=0.93049526909398804249},
% {x1=0.74057635603986743051,x2=0.93049526909398804249,x3
%  =0.22075230018295426413,x4=0.48100256896929398759}}

% System precision will have been set to 20 in the two previous
% examples.  In the following examples, the roots will be given to
% accuracy 12, because rootacc 12; was input.  If rootacc had not been
% input, the roots would be given at system precision, which could
% different answers on different systems if precision had been reset,
% or else it would have been 20 because of example 118).

rootacc 12;


12


% 119)
ss := {x^2-2,y^2-x^2,z^2-x-y};


        2         2    2             2
ss := {x  - 2, - x  + y , - x - y + z }
 % structure is {p1(x),p2(x,y),p3(x,y,z)}
realroots ss;


{{x= - 1.41421356237,y=1.41421356237,z=0},

 {x= - 1.41421356237,y=1.41421356237,z=0},

 {x=1.41421356237,y= - 1.41421356237,z=0},

 {x=1.41421356237,y= - 1.41421356237,z=0},

 {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},

 {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

%{{x= - 1.41421356237,y=1.41421356237,z=0},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},
% {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

roots ss;


{{x= - 1.41421356237,y= - 1.41421356237,z=1.68179283051*i},

 {x= - 1.41421356237,y= - 1.41421356237,z= - 1.68179283051*i},

 {x= - 1.41421356237,y=1.41421356237,z=0},

 {x= - 1.41421356237,y=1.41421356237,z=0},

 {x=1.41421356237,y= - 1.41421356237,z=0},

 {x=1.41421356237,y= - 1.41421356237,z=0},

 {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},

 {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

%{{x= - 1.41421356237,y= - 1.41421356237,z=1.68179283051*i},
% {x= - 1.41421356237,y= - 1.41421356237,z= - 1.68179283051*i},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},
% {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

% 120)
realroots {x^5-45x+2,y^2-x+1};


{{x=2.57878769906,y= - 1.25649818904},{x=2.57878769906,y=1.25649818904}}

%{{x=2.57878769906,y= - 1.25649818904},{x=2.57878769906,y
%    =1.25649818904}}

realroots {x^5-45x+2,y^2-x-1};


{{x=0.0444444482981,y= - 1.02198064967},

 {x=0.0444444482981,y=1.02198064967},

 {x=2.57878769906,y= - 1.89176840524},

 {x=2.57878769906,y=1.89176840524}}

%{{x=0.0444444482981,y= - 1.02198064967},
% {x=0.0444444482981,y=1.02198064967},
% {x=2.57878769906,y= - 1.89176840524},
% {x=2.57878769906,y=1.89176840524}}

% 121)
realroots {x^2-2,y^2+x^2};


{}

% {}

roots {x^2+2,y^2-x^2};


{{x=1.41421356237*i,y=1.41421356237*i},

 {x=1.41421356237*i,y= - 1.41421356237*i},

 {x= - 1.41421356237*i,y=1.41421356237*i},

 {x= - 1.41421356237*i,y= - 1.41421356237*i}}

%{{x=1.41421356237*i,y=1.41421356237*i},
% {x=1.41421356237*i,y= - 1.41421356237*i},
% {x= - 1.41421356237*i,y=1.41421356237*i},
% {x= - 1.41421356237*i,y= - 1.41421356237*i}}

% 122)
roots {x^2-y^2,x^2+y^2+3};


*** multroot fails because no univariate polynomial was given. 

              2    2  2    2
multroot(12,{x  - y ,x  + y  + 3})

%multroot fails because no univariate polynomial was given.
%multroot(12,{x**2 - y**2,x**2 + y**2 + 3})$

% 122a)
roots{x^2+y^2,x^2-y^2-z,z^2-z-1};


*** multroot failure: at least one polynomial has no single base. 

              2    2  2    2      2
multroot(12,{x  + y ,x  - y  - z,z  - z - 1})

%*** multroot failure: at least one polynomial has no single base.
%multroot(12,{x**2 + y**2,(x**2 - y**2) - z,(z**2 - z) - 1})$

% 123)
roots {x^2-2,y^2+3,x+z-2,y-z+2};


{}

%{}

% 124)
zz := {x^5-5x+3,x^2+y^2,x^3+z^3};


        5            2    2  3    3
zz := {x  - 5*x + 3,x  + y ,x  + z }

realroots zz;


{}

%{}

realroots {x^5-5x+3,x^2-y^2,x^3+z^3};


{{x= - 1.61803398875,y= - 1.61803398875,z=1.61803398875},

 {x= - 1.61803398875,y=1.61803398875,z=1.61803398875},

 {x=0.61803398875,y= - 0.61803398875,z= - 0.61803398875},

 {x=0.61803398875,y=0.61803398875,z= - 0.61803398875},

 {x=1.27568220365,y= - 1.27568220365,z= - 1.27568220365},

 {x=1.27568220365,y=1.27568220365,z= - 1.27568220365}}

%{{x= - 1.61803398875,y= - 1.61803398875,z=1.61803398875},
% {x= - 1.61803398875,y=1.61803398875,z=1.61803398875},
% {x=0.61803398875,y= - 0.61803398875,z= - 0.61803398875},
% {x=0.61803398875,y=0.61803398875,z= - 0.61803398875},
% {x=1.27568220365,y= - 1.27568220365,z= - 1.27568220365},
% {x=1.27568220365,y=1.27568220365,z= - 1.27568220365}}

% These show previous capability
%------------------------------------------------------------------
% These are new capability

% 125)
roots{x**2 - x - y,x*y - 2*y,y**2 - 2*y};


{{x=0,y=0},{x=1,y=0},{x=2.0,y=2.0}}

%{{x=0,y=0},{x=1,y=0},{x=2.0,y=2.0}}

% 126)
roots({x^2-9,y^3-27,x*y+9});


{{x= - 3.0,y=3.0}}

%{{x= - 3.0,y=3.0}}

% 127)
multroot(12,{y^2-z,y*z,z*(z-1)});


{{y=0,z=0},{y=0,z=0}}

%{{y=0,z=0},{y=0,z=0}}

% 127a)
multroot(12,{y^2-z,y*z,z*(z-1),x^2-x-y});


{{x=0,y=0,z=0},

 {x=0,y=0,z=0},

 {x=1,y=0,z=0},

 {x=1,y=0,z=0}}

%{{x=0,y=0,z=0},
% {x=0,y=0,z=0},
% {x=1,y=0,z=0},
% {x=1,y=0,z=0}}

% 128)
roots{y*z,z*(z-1)};


{{z=0},{y=0,z=1}}

%{{z=0},{y=0,z=1}}

% 129)
zzl := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z+1};


            2
zzl := {z*(z  - 3*z + 2),

         2  2      2        2
        y *z  - 2*y *z + y*z  - y*z + z + 1}

roots zzl;


{{y= - 1.5,z=2.0},{y= - 1.41421356237,z=1},{y=1.41421356237,z=1}}

%{{y= - 1.5,z=2.0},
% {y= - 1.41421356237,z=1},
% {y=1.41421356237,z=1}}

% 129a)
zzla := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z+1,x^2-x-y};


             2
zzla := {z*(z  - 3*z + 2),

          2  2      2        2
         y *z  - 2*y *z + y*z  - y*z + z + 1,

          2
         x  - x - y}

roots zzla;


{{x= - 0.790044015673,y=1.41421356237,z=1},

 {x=0.5 + 1.11803398875*i,y= - 1.5,z=2.0},

 {x=0.5 - 1.11803398875*i,y= - 1.5,z=2.0},

 {x=0.5 + 1.07898728555*i,y= - 1.41421356237,z=1},

 {x=0.5 - 1.07898728555*i,y= - 1.41421356237,z=1},

 {x=1.79004401567,y=1.41421356237,z=1}}

%{{x= - 0.790044015673,y=1.41421356237,z=1},
% {x=0.5 + 1.11803398875*i,y= - 1.5,z=2.0},
% {x=0.5 - 1.11803398875*i,y= - 1.5,z=2.0},
% {x=0.5 + 1.07898728555*i,y= - 1.41421356237,z=1},
% {x=0.5 - 1.07898728555*i,y= - 1.41421356237,z=1},
% {x=1.79004401567,y=1.41421356237,z=1}}

% 130)
zzl0 := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z};


             2
zzl0 := {z*(z  - 3*z + 2),

             2        2
         z*(y *z - 2*y  + y*z - y + 1)}

roots zzl0;


{{y=-1,z=1},{y=-1,z=2.0},{z=0},{y=1,z=1}}

%{{y=-1,z=1},{y=-1,z=2.0},{z=0},{y=1,z=1}}

% 131)
zzl3a := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z,x^2+y*x*z+z};


              2
zzl3a := {z*(z  - 3*z + 2),

              2        2
          z*(y *z - 2*y  + y*z - y + 1),

           2
          x  + x*y*z + z}

roots zzl3a;


{{x= - 0.5 + 0.866025403784*i,y=1,z=1},

 {x= - 0.5 - 0.866025403784*i,y=1,z=1},

 {x=0,z=0},

 {x=0,z=0},

 {x=0.5 + 0.866025403784*i,y=-1,z=1},

 {x=0.5 - 0.866025403784*i,y=-1,z=1},

 {x=1 + i,y=-1,z=2.0},

 {x=1 - i,y=-1,z=2.0}}

%{{x=0.866025403784*i - 0.5,y=1,z=1},
% {x= - 0.866025403784*i - 0.5,y=1,z=1},
% {x=0,z=0},
% {x=0,z=0},
% {x=0.866025403784*i + 0.5,y=-1,z=1},
% {x= - 0.866025403784*i + 0.5,y=-1,z=1},
% {x=i + 1,y=-1,z=2.0},
% {x= - i + 1,y=-1,z=2.0}}$

% 132)
zzl3c := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z,x^2+y*x+z};


              2
zzl3c := {z*(z  - 3*z + 2),

              2        2
          z*(y *z - 2*y  + y*z - y + 1),

           2
          x  + x*y + z}

roots zzl3c;


*** for some root value(s), a variable depends on an arbitrary variable 

              3      2
multroot(12,{z  - 3*z  + 2*z,

              2  2      2        2
             y *z  - 2*y *z + y*z  - y*z + z,

              2
             x  + x*y + z})

%*** for some root value, a variable dependends on an arbitrary variable
%multroot(12,{z**3 - 3*z**2 + 2*z,y**2*z**2 - 2*y**2*z + y*z**2 - y*z + z,
% x**2 + x*y + z})$

% 133)
xyz := {x^2-x-2,y^2+y,x^3+y^3+z+5};


         2                    3    3
xyz := {x  - x - 2,y*(y + 1),x  + y  + z + 5}

roots xyz;


{{x=-1,y=-1,z= - 3.0},

 {x=-1,y=0,z= - 4.0},

 {x=2.0,y=-1,z= - 12.0},

 {x=2.0,y=0,z= - 13.0}}

%{{x=-1,y=-1,z= - 3.0},
% {x=-1,y=0,z= - 4.0},
% {x=2.0,y=-1,z= - 12.0},
% {x=2.0,y=0,z= - 13.0}}

% 134) here, we had to eliminate a spurious imaginary part of z.
axyz := {a-1,a+x^2-x-2,a+y^2+y,a+x^3+y^3+z+5};


axyz := {a - 1,

              2
         a + x  - x - 2,

              2
         a + y  + y,

              3    3
         a + x  + y  + z + 5}

roots axyz;


{{a=1,x= - 0.61803398875,y= - 0.5 + 0.866025403784*i,z= - 6.7639320225},

 {a=1,x= - 0.61803398875,y= - 0.5 - 0.866025403784*i,z= - 6.7639320225},

 {a=1,x=1.61803398875,y= - 0.5 + 0.866025403784*i,z= - 11.2360679775},

 {a=1,x=1.61803398875,y= - 0.5 - 0.866025403784*i,z= - 11.2360679775}}

%{{a=1,x= - 0.61803398875,y= - 0.5 + 0.866025403784*i,z= - 6.7639320225},
% {a=1,x= - 0.61803398875,y= - 0.5 - 0.866025403784*i,z= - 6.7639320225},
% {a=1,x=1.61803398875,y= - 0.5 + 0.866025403784*i,z= - 11.2360679775},
% {a=1,x=1.61803398875,y= - 0.5 - 0.866025403784*i,z= - 11.2360679775}}

% 134a) here, we had to eliminate a spurious real part of x.
roots{y^4+y^3+y^2+y+1,x^2+3*y^5+2};


{{x=2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},

 {x= - 2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},

 {x= - 2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},

 {x=2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},

 {x= - 2.2360679775*i,y=0.309016994375 + 0.951056516295*i},

 {x=2.2360679775*i,y=0.309016994375 + 0.951056516295*i},

 {x=2.2360679775*i,y=0.309016994375 - 0.951056516295*i},

 {x= - 2.2360679775*i,y=0.309016994375 - 0.951056516295*i}}

%{{x=2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},
% {x=-2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},
% {x=-2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},
% {x=2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},
% {x=-2.2360679775*i,y=0.309016994375 + 0.951056516295*i},
% {x=2.2360679775*i,y=0.309016994375 + 0.951056516295*i},
% {x=2.2360679775*i,y=0.309016994375 - 0.951056516295*i},
% {x=-2.2360679775*i,y=0.309016994375 - 0.951056516295*i}}

% 135)
axyz2 := {a-1,a-1+x^2-x-2,a-1+y^2+y,x^3+y^3+z+5};


axyz2 := {a - 1,

               2
          a + x  - x - 3,

               2
          a + y  + y - 1,

           3    3
          x  + y  + z + 5}

roots axyz2;


{{a=1,x=-1,y=-1,z= - 3.0},

 {a=1,x=-1,y=0,z= - 4.0},

 {a=1,x=2.0,y=-1,z= - 12.0},

 {a=1,x=2.0,y=0,z= - 13.0}}

%{{a=1,x=-1,y=-1,z= - 3.0},
% {a=1,x=-1,y=0,z= - 4.0},
% {a=1,x=2.0,y=-1,z= - 12.0},
% {a=1,x=2.0,y=0,z= - 13.0}}

zyxa2 := reverse axyz2;


           3    3
zyxa2 := {x  + y  + z + 5,

               2
          a + y  + y - 1,

               2
          a + x  - x - 3,

          a - 1}

roots zyxa2;


{{a=1,x=-1,y=-1,z= - 3.0},

 {a=1,x=-1,y=0,z= - 4.0},

 {a=1,x=2.0,y=-1,z= - 12.0},

 {a=1,x=2.0,y=0,z= - 13.0}}

% (same as above)

% 137)
rsxuv := {u^2+u*r+s*x*v,s+r^2,x-r-2,r+v,v^2-v-6};


                         2
rsxuv := {r*u + s*v*x + u ,

           2
          r  + s,

           - r + x - 2,

          r + v,

           2
          v  - v - 6}

roots rsxuv;


{{r= - 3.0,s= - 9.0,u=1.5 + 4.97493718553*i,v=3.0,x=-1},

 {r= - 3.0,s= - 9.0,u=1.5 - 4.97493718553*i,v=3.0,x=-1},

 {r=2.0,s= - 4.0,u= - 1 + 5.56776436283*i,v= - 2.0,x=4.0},

 {r=2.0,

  s= - 4.0,

  u= - 1 - 5.56776436283*i,

  v= - 2.0,

  x=4.0}}

%{{r= - 3.0,s= - 9.0,u=1.5 + 4.97493718553*i,v=3.0,x=-1},
% {r= - 3.0,s= - 9.0,u=1.5 - 4.97493718553*i,v=3.0,x=-1},
% {r=2.0,s= - 4.0,u= - 1 + 5.56776436283*i,v= - 2.0,x=4.0},
% {r=2.0,s= - 4.0,u= - 1 - 5.56776436283*i,v= - 2.0,x=4.0}}

% 138)
rsxuv2 := {u^2+u*r+s*x,s+r,x-r-2,r+v,v^2-v-6};


                        2
rsxuv2 := {r*u + s*x + u ,

           r + s,

            - r + x - 2,

           r + v,

            2
           v  - v - 6}

roots rsxuv2;


{{r= - 3.0,s=3.0,u= - 0.791287847478,v=3.0,x=-1},

 {r= - 3.0,s=3.0,u=3.79128784748,v=3.0,x=-1},

 {r=2.0,s= - 2.0,u= - 4.0,v= - 2.0,x=4.0},

 {r=2.0,s= - 2.0,u=2.0,v= - 2.0,x=4.0}}

%{{r= - 3.0,s=3.0,u= - 0.791287847478,v=3.0,x=-1},
% {r= - 3.0,s=3.0,u=3.79128784748,v=3.0,x=-1},
% {r=2.0,s= - 2.0,u= - 4.0,v= - 2.0,x=4.0},
% {r=2.0,s= - 2.0,u=2.0,v= - 2.0,x=4.0}}

% 139) combining both types of capabilities.
axyz3 := {a-1,a-1+x^2-x-2,a-1+y^2+y,x^3+y^3+z+5,y^2-x^2};


axyz3 := {a - 1,

               2
          a + x  - x - 3,

               2
          a + y  + y - 1,

           3    3
          x  + y  + z + 5,

              2    2
           - x  + y }

roots axyz3;


{{a=1,x=-1,y=-1,z= - 3.0}}

%{{a=1,x=-1,y=-1,z= - 3.0}}

% 140) spurious real and imag. parts had to be eliminated from z and y.
ayz := {a^2+a+1,z^2+a^3+3,y^3-z^2};


         2          3    2      3    2
ayz := {a  + a + 1,a  + z  + 3,y  - z }

roots ayz;


{{a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z=2.0*i},

 {a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z= - 2.0*i},

 {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z= - 2.0*i},

 {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z=2.0*i},

 {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i},

 {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},

 {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z= - 2.0*i},

 {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z= - 2.0*i},

 {a= - 0.5 - 0.866025403784*i,

  y=0.793700525984 - 1.374729637*i,

  z= - 2.0*i},

 {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z= - 2.0*i},

 {a= - 0.5 - 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},

 {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i}}

%{{a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=-2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i}}

% 141) some small real or imaginary parts are not spurious; they are kept.
zz:= {x**9-9999x**2-0.01,y^2+y-x};


             9           2
        100*x  - 999900*x  - 1          2
zz := {------------------------, - x + y  + y}
                 100

roots zz;


{{x= - 3.35839794887 + 1.61731917877*i,y= - 0.944735689647 - 1.81829254591*i},

 {x= - 3.35839794887 - 1.61731917877*i,y= - 0.944735689647 + 1.81829254591*i},

 {x= - 3.35839794887 + 1.61731917877*i,y= - 0.0552643103532 + 1.81829254591*i},

 {x= - 3.35839794887 - 1.61731917877*i,y= - 0.0552643103532 - 1.81829254591*i},

 {x= - 0.829455794538 + 3.6340832074*i,y= - 1.74509731832 - 1.45935709359*i},

 {x= - 0.829455794538 - 3.6340832074*i,y= - 1.74509731832 + 1.45935709359*i},

 {x= - 0.829455794538 + 3.6340832074*i,y=0.745097318317 + 1.45935709359*i},

 {x= - 0.829455794538 - 3.6340832074*i,y=0.745097318317 - 1.45935709359*i},

 {x=5.00250075018e-29 + 0.00100005000375*i,y

  = - 1.0000010001 - 0.00100004800346*i},

 {x=5.00250075018e-29 - 0.00100005000375*i,y

  = - 1.0000010001 + 0.00100004800346*i},

 {x=5.00250075018e-29 + 0.00100005000375*i,y

  =0.00000100009500904 + 0.00100004800346*i},

 {x=5.00250075018e-29 - 0.00100005000375*i,y

  =0.00000100009500904 - 0.00100004800346*i},

 {x=2.3240834909 + 2.91430845907*i,y= - 2.29755558063 - 0.810630973104*i},

 {x=2.3240834909 - 2.91430845907*i,y= - 2.29755558063 + 0.810630973104*i},

 {x=2.3240834909 + 2.91430845907*i,y=1.29755558063 + 0.810630973104*i},

 {x=2.3240834909 - 2.91430845907*i,y=1.29755558063 - 0.810630973104*i},

 {x=3.72754050502,y= - 2.49437722235},

 {x=3.72754050502,y=1.49437722235}}

%{{x= - 3.35839794887 + 1.61731917877*i,y= - 0.944735689647 -
%  1.81829254591*i},
% {x= - 3.35839794887 - 1.61731917877*i,y= - 0.944735689647 +
%  1.81829254591*i},
% {x= - 3.35839794887 + 1.61731917877*i,y= - 0.0552643103532 +
%  1.81829254591*i},
% {x= - 3.35839794887 - 1.61731917877*i,y= - 0.0552643103532 -
%  1.81829254591*i},
% {x= - 0.829455794538 + 3.6340832074*i,y= - 1.74509731832 -
%  1.45935709359*i},
% {x= - 0.829455794538 - 3.6340832074*i,y= - 1.74509731832 +
%  1.45935709359*i},
% {x= - 0.829455794538 + 3.6340832074*i,y=0.745097318317 +
%  1.45935709359*i},
% {x= - 0.829455794538 - 3.6340832074*i,y=0.745097318317 -
%  1.45935709359*i},
% {x=5.00250075018E-29 + 0.00100005000375*i,y= - 1.0000010001 -
%  0.00100004800346*i},
% {x=5.00250075018E-29 - 0.00100005000375*i,y= - 1.0000010001 +
%  0.00100004800346*i},
% {x=5.00250075018E-29 + 0.00100005000375*i,y=0.00000100009500904 +
%  0.00100004800346*i},
% {x=5.00250075018E-29 - 0.00100005000375*i,y=0.00000100009500904 -
%  0.00100004800346*i},
% {x=2.3240834909 + 2.91430845907*i,y= - 2.29755558063 -
%  0.810630973104*i},
% {x=2.3240834909 - 2.91430845907*i,y= - 2.29755558063 +
%  0.810630973104*i},
% {x=2.3240834909 + 2.91430845907*i,y=1.29755558063 + 0.810630973104*i},
% {x=2.3240834909 - 2.91430845907*i,y=1.29755558063 - 0.810630973104*i},
% {x=3.72754050502,y= - 2.49437722235},
% {x=3.72754050502,y=1.49437722235}}$

% 142) if quotient, only numerator is used as polynomial, so this works.
vv := {x+1+1/x,y^2-x^3};


         2
        x  + x + 1      3    2
vv := {------------, - x  + y }
            x

roots vv;


{{x= - 0.5 + 0.866025403784*i,y=-1},

 {x= - 0.5 - 0.866025403784*i,y=-1},

 {x= - 0.5 + 0.866025403784*i,y=1},

 {x= - 0.5 - 0.866025403784*i,y=1}}

%{{x= - 0.5 + 0.866025403784*i,y=-1},{x= - 0.5 - 0.866025403784*i,y=-1},
% {x= - 0.5 + 0.866025403784*i,y=1},{x= - 0.5 - 0.866025403784*i,y=1}}

% 143) and this also works.
ii := {x^2-2x+3/r,r^3-5};


           2
        r*x  - 2*r*x + 3   3
ii := {------------------,r  - 5}
               r

roots ii;


{{r= - 0.854987973338 + 1.48088260968*i,x= - 0.464963274745 - 0.518567329174*i},

 {r= - 0.854987973338 - 1.48088260968*i,x= - 0.464963274745 + 0.518567329174*i},

 {r= - 0.854987973338 + 1.48088260968*i,x=2.46496327474 + 0.518567329174*i},

 {r= - 0.854987973338 - 1.48088260968*i,x=2.46496327474 - 0.518567329174*i},

 {r=1.70997594668,x=1 + 0.868568156754*i},

 {r=1.70997594668,x=1 - 0.868568156754*i}}

%{{r= - 0.854987973338 + 1.48088260968*i,x= - 0.464963274745 -
%  0.518567329174*i},
% {r= - 0.854987973338 - 1.48088260968*i,x= - 0.464963274745 +
%  0.518567329174*i},
% {r= - 0.854987973338 + 1.48088260968*i,x=2.46496327474 +
%  0.518567329174*i},
% {r= - 0.854987973338 - 1.48088260968*i,x=2.46496327474 -
%  0.518567329174*i},
% {r=1.70997594668,x=1 + 0.868568156754*i},
% {r=1.70997594668,x=1 - 0.868568156754*i}}

% 144)
bb := {y+x+3,x^2+r+s-3,x^3+r+s-7,r^2-r,s^2+3s+2};


bb := {x + y + 3,

                2
       r + s + x  - 3,

                3
       r + s + x  - 7,

       r*(r - 1),

        2
       s  + 3*s + 2}

roots bb;


{{r=0,s=-1,x=2.0,y= - 5.0},

 {r=1,s= - 2.0,x=2.0,y= - 5.0}}

%{{r=0,s=-1,x=2.0,y= - 5.0},{r=1,s= - 2.0,x=2.0,y= - 5.0}}

end;


Time for test: 998 ms, plus GC time: 109 ms
@@@@@ Resources used: (2 24 281 3)
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/roots.tst0000644000175000017500000014572711526203062023574 0ustar  giovannigiovanni% Tests of the root finding package.

% Author: Stanley L. Kameny (stan_kameny@rand.org)

comment  Addition for roots mod 1.95.  The function multroot has been
  added to the roots package in mod 1.95.  This provides the capability
  to solve a nest of n polynomials in n variables, provided that each
  polynomial either is univariate or introduces a new variable to the
  set.  The solutions can be either real solutions only, or complex
  solutions.  All solutions to the new examples, problems 117) and
  subsequent, are correct to all digits shown.  As in the prior examples,
  root order and values should agree exactly with that given here.

comment  This test file works only with Reduce version 3.5 and later
  and contains examples all of which are solved by roots mod 1.94.
  Answers are rounded to the value given by rootacc (default = 6)
  unless higher accuracy is needed to separate roots.  Format may differ 
  from that given here, but root order and values should agree exactly.
  (Although the function ROOTS may obtain the roots in a different order,
  they are sorted into a standard order in mod 1.94 and later.)
         In the following, problems 20) and 82) are time consuming and
  have been commented out to speed up the test.
         The hard examples 111) through 115) almost double the test time
  but are necessary to test some logical paths.
         A new "hardest" example has been added as example 116).  It is
  commented out, since it is time consuming, but it is solved by roots
  mod 1.94.  The time needed to run the three commented-out examples is
  almost exactly equal to the time for the rest of the test.  Users of
  fast computers can uncomment the lines marked with %**%.  The three
  examples by themselves are contained in the test file rootsxtr.tst.

         When answers are produced which require precision increase for
  printing out or input of roots, roots functions cause precision
  increase to occur.  If the precision is already higher than the 
  default value, a message is printed out warning of the the precision 
  normally needed for input of those values.$

realroots x;   % To load roots package.

write "This is Roots Package test ", symbolic roots!-mod$


% Simple root finding.

% 1) multiple real and imaginary roots plus two real roots.
zz:= (x-3)**2*(100x**2+113)**2*(1000000x-10000111)*(x-1); roots zz;
%{x=1.06301*i,x=1.06301*i,x=-1.06301*i,x=-1.06301*i,
%x=3.0,x=3.0,x=1,x=10.0001} (rootacc caused rounding to 6 places)

% Accuracy is increased whenever necessary to separate distinct roots.

% 2) accuracy increase to 7 required for two roots.
zz:=(x**2+1)*(x-2)*(1000000x-2000001); roots zz;
%{x=i,x= -i,x=2.0,x=2.000001}

% 3) accuracy increase to 8 required.
zz:= (x-3)*(10000000x-30000001); roots zz;
%{x=3.0,x=3.0000001}

% 4) accuracy increase required here to separate repeated root from
% simple root.
zz := (x-3)*(1000000x-3000001)*(x-3)*(1000000x-3241234); roots zz;
%{x=3.0,x=3.0,x=3.000001,x=3.24123}

% other simple examples

% 5) five real roots with widely different spacing.
zz:= (x-1)*(10x-11)*(x-1000)*(x-1001)*(x-100000); roots zz;
%{x=1,x=1.1,x=1000.0,x=1001.0,x=1.0E+5}

% 6) a cluster of 5 roots in complex plane in vicinity of x=1.
zz:= (x-1)*(10000x**2-20000x+10001)*(10000x**2-20000x+9999); roots zz;
%{x=0.99,x=1,x=1 + 0.01*i,x=1 - 0.01*i,x=1.01}

% 7) four closely spaced real roots.
zz := (x-1)*(100x-101)*(100x-102)*(100x-103); roots zz;
%{x=1,x=1.01,x=1.02,x=1.03}

% 8) five closely spaced roots, 3 real + 1 complex pair.
zz := (x-1)*(100x-101)*(100x-102)*(100x**2-200x+101); roots zz;
%{x=1,x=1 + 0.1*i,x=1 - 0.1*i,x=1.01,x=1.02}

% 9) symmetric cluster of 5 roots, 3 real + 1 complex pair.
zz := (x-2)*(10000x**2-40000x+40001)*(10000x**2-40000x+39999); roots zz;
%{x=1.99,x=2.0,x=2.0 + 0.01*i,x=2.0 - 0.01*i,x=2.01}

% 10) closely spaced real and complex pair.
ss:= (x-2)*(100000000x**2-400000000x+400000001); roots ss;
%{x=2.0,x=2.0 + 0.0001*i,x=2.0 - 0.0001*i}

% 11) Zero roots and multiple roots cause no problem.
% Multiple roots are shown when the switch multiroot is on
%(normally on.)
zz:= x*(x-1)**2*(x-4)**3*(x**2+1); roots zz;
%{x=0,x=4.0,x=4.0,x=4.0,x=1,x=1,x=i,x= - i}

% 12) nearestroot will find a single root "near" a value, real or
% complex.
nearestroot(zz,2i);
%{x=i}

% More difficult examples.

% Three examples in which root scaling is needed in the complex
% iteration process.

% 13) nine roots, 3 real and 3 complex pairs.
zz:= x**9-45x-2; roots zz;
%{x= - 1.60371,x=-1.13237 + 1.13805*i,x=-1.13237 - 1.13805*i,
% x= - 0.0444444,x=0.00555357 + 1.60944*i,x=0.00555357 - 1.60944*i,
% x=1.14348 + 1.13804*i,x=1.14348 - 1.13804*i,x=1.61483}


comment  In the next two examples, there are complex roots with
  extremely  small real parts (new capability in Mod 1.91.);

% 14) nine roots, 1 real and 4 complex pairs.
zz:= x**9-9999x**2-0.01; roots zz;
%{x=-3.3584 + 1.61732*i,x=-3.3584 - 1.61732*i,
% x=-0.829456 + 3.63408*i,x=-0.829456 - 3.63408*i,
% x=5.0025E-29 + 0.00100005*i,x=5.0025E-29 - 0.00100005*i,
% x=2.32408 + 2.91431*i,x=2.32408 - 2.91431*i,x=3.72754}

comment  Rootacc 7 produces 7 place accuracy.  Answers will print in
  bigfloat format if floating point print >6 digits is not implemented.;

% 15) nine roots, 1 real and 4 complex pairs.
rootacc 7; zz:= x**9-500x**2-0.001; roots zz;
%{x=-2.189157 + 1.054242*i,x=-2.189157 - 1.054242*i,
% x=-0.5406772 + 2.368861*i,x=-0.5406772 - 2.368861*i,
% x=1.6E-26 + 0.001414214*i,x=1.6E-26 - 0.001414214*i,
% x=1.514944 + 1.899679*i,x=1.514944 - 1.899679*i,x=2.429781}

% the famous Wilkinson "ill-conditioned" polynomial and its family.

% 16) W(6) four real roots plus one complex pair.
zz:= 10000*(for j:=1:6 product(x+j))+27x**5; roots zz;
%{x= - 6.143833,x=-4.452438 + 0.02123455*i,x=-4.452438 - 0.02123455*i,
% x= - 2.950367,x= - 2.003647,x= - 0.9999775}

% 17) W(8) 4 real roots plus 2 complex pairs.
zz:= 1000*(for j:=1:8 product(x+j))+2x**7; roots zz;
%{x= - 8.437546,x=-6.494828 + 1.015417*i,x=-6.494828 - 1.015417*i,
% x=-4.295858 + 0.2815097*i,x=-4.295858 - 0.2815097*i,
% x= - 2.982725,x= - 2.000356,x= - 0.9999996}

% 18) W(10) 6 real roots plus 2 complex pairs.
zz:=1000*(for j:= 1:10 product (x+j))+x**9; roots zz;
%{x= - 10.80988,x=-8.70405 + 1.691061*i,x=-8.70405 - 1.691061*i,
% x=-6.046279 + 1.134321*i,x=-6.046279 - 1.134321*i,x= - 4.616444,
% x= - 4.075943,x= - 2.998063,x= - 2.000013,x= - 1}

% 19) W(12) 6 real roots plus 3 complex pairs.
zz:= 10000*(for j:=1:12 product(x+j))+4x**11; roots zz;
%{x= - 13.1895,x=-11.02192 + 2.23956*i,x=-11.02192 - 2.23956*i,
% x=-7.953917 + 1.948001*i,x=-7.953917 - 1.948001*i,
% x=-5.985629 + 0.8094247*i,x=-5.985629 - 0.8094247*i,
% x= - 4.880956,x= - 4.007117,x= - 2.999902,x= - 2.0,x= - 1}

% 20) W(20) 10 real roots plus 5 complex pairs. (The original problem)
% This example is commented out, since it takes significant time without
% being particularly difficult or checking out new paths:
%**%  zz:= x**19+10**7*for j:=1:20 product (x+j); roots zz;
%{x= - 20.78881,x=-19.45964 + 1.874357*i,x=-19.45964 - 1.874357*i,
% x=-16.72504 + 2.731577*i,x=-16.72504 - 2.731577*i,
% x=-14.01105 + 2.449466*i,x=-14.01105 - 2.449466*i,
% x=-11.82101 + 1.598621*i,x=-11.82101 - 1.598621*i,
% x=-10.12155 + 0.6012977*i,x=-10.12155 - 0.6012977*i,
% x= - 8.928803,x= - 8.006075,x= - 6.999746,x= - 6.000006,
% x= - 5.0,x= - 4.0,x= - 3.0,x= - 2.0,x= - 1}

rootacc 6;
% 21)  Finding one of a cluster of 8 roots.
zz:= (10**16*(x-1)**8-1); nearestroot(zz,2);
%{x=1.01}

% 22)  Six real roots spaced 0.01 apart.
c := 100; zz:= (x-1)*for i:=1:5 product (c*x-(c+i)); roots zz;
%{x=1,x=1.01,x=1.02,x=1.03,x=1.04,x=1.05}

% 23)  Six real roots spaced 0.001 apart.
c := 1000; zz:= (x-1)*for i:=1:5 product (c*x-(c+i)); roots zz;
%{x=1,x=1.001,x=1.002,x=1.003,x=1.004,x=1.005}

% 24)  Five real roots spaced 0.0001 apart.
c := 10000; zz:= (x-1)*for i:=1:4 product (c*x-(c+i)); roots zz;
%{x=1,x=1.0001,x=1.0002,x=1.0003,x=1.0004}

% 25)  A cluster of 9 roots, 5 real, 2 complex pairs; spacing 0.1.
zz:= (x-1)*(10**8*(x-1)**8-1); roots zz;
%{x=0.9,x=0.929289 + 0.0707107*i,x=0.929289 - 0.0707107*i,
% x=1,x=1 + 0.1*i,x=1 - 0.1*i,
% x=1.07071 + 0.0707107*i,x=1.07071 - 0.0707107*i,x=1.1}

% 26)  Same, but with spacing 0.01.
zz:= (x-1)*(10**16*(x-1)**8-1); roots zz;
%{x=0.99,x=0.992929 + 0.00707107*i,x=0.992929 - 0.00707107*i,
% x=1,x=1 + 0.01*i,x=1 - 0.01*i,
% x=1.00707 + 0.00707107*i,x=1.00707 - 0.00707107*i,x=1.01}

% 27)  Spacing reduced to 0.001.
zz:= (x-1)*(10**24*(x-1)**8-1); roots zz;
%{x=0.999,x=0.999293 + 0.000707107*i,x=0.999293 - 0.000707107*i,
% x=1,x=1 + 0.001*i,x=1 - 0.001*i,
% x=1.00071 + 0.000707107*i,x=1.00071 - 0.000707107*i,x=1.001}

% 28)  Eight roots divided into two clusters.
zz:= (10**8*(x-1)**4-1)*(10**8*(x+1)**4-1); roots zz;
%{x= - 0.99,x=0.99, x=-1 - 0.01*i,x=1 + 0.01*i,
% x=-1 + 0.01*i,x=1 - 0.01*i,x= - 1.01,x=1.01}

% 29)  A cluster of 8 roots in a different configuration.
zz:= (10**8*(x-1)**4-1)*(10**8*(100x-102)**4-1); roots zz;
%{x=0.99,x=1 + 0.01*i,x=1 - 0.01*i,x=1.01,
% x=1.0199,x=1.02 + 0.0001*i,x=1.02 - 0.0001*i,x=1.0201}

% 30)  A cluster of 8 complex roots.
zz:= ((10x-1)**4+1)*((10x+1)**4+1); roots zz;
%{x=-0.0292893 - 0.0707107*i,x=0.0292893 + 0.0707107*i,
% x=-0.0292893 + 0.0707107*i,x=0.0292893 - 0.0707107*i,
% x=-0.170711 - 0.0707107*i,x=0.170711 + 0.0707107*i,
% x=-0.170711 + 0.0707107*i,x=0.170711 - 0.0707107*i}

comment  In these examples, accuracy increase is required to separate a
  repeated root from a simple root.;

% 31)  Using allroots;
zz:= (x-4)*(x-3)**2*(1000000x-3000001); roots zz;
%{x=3.0,x=3.0,x=3.000001,x=4.0}

% 32)  Using realroots;
realroots zz;
%{x=3.0,x=3.0,x=3.000001,x=4.0}

comment  Tests of new capabilities in mod 1.87 for handling complex
  polynomials and polynomials with very small imaginary parts or very
  small real roots. A few real examples are shown, just to demonstrate
  that these still work.;

% 33) A trivial complex case (but degrees 1 and 2 are special cases);
zz:= x-i; roots zz;
%{x=i}

% 34) Real case.
zz:= y-7; roots zz;
%{y=7.0}

% 35) Roots with small imaginary parts (new capability);
zz := 10**16*(x**2-2x+1)+1; roots zz;
%{x=1 + 0.00000001*i,x=1 - 0.00000001*i}

% 36) One real, one complex root.
zz:=(x-9)*(x-5i-7); roots zz;
%{x=9.0,x=7.0 + 5.0*i}

% 37) Three real roots.
zz:= (x-1)*(x-2)*(x-3); roots zz;
%{x=1,x=2.0,x=3.0}

% 38) 2 real + 1 imaginary root.
zz:=(x**2-8)*(x-5i); roots zz;
%{x= - 2.82843,x=2.82843,x=5.0*i}

% 39) 2 complex roots.
zz:= (x-1-2i)*(x+2+3i); roots zz;
%{x=-2.0 - 3.0*i,x=1 + 2.0*i}

% 40) 2 irrational complex roots.
zz:= x**2+(3+2i)*x+7i; roots zz;
%{x=-3.14936 + 0.21259*i,x=0.149358 - 2.21259*i}

% 41) 2 complex roots of very different magnitudes with small imaginary
% parts.
zz:= x**2+(1000000000+12i)*x-1000000000; roots zz;
%{x=-1.0E+9 - 12.0*i,x=1 - 0.000000012*i}

% 42) Multiple real and complex roots cause no difficulty, provided
% that input is given in integer or rational form, (or if in decimal
% fraction format, with switch rounded off  or adjprec on and
% coefficients input explicitly,) so that polynomial is stored exactly.
zz :=(x**2-2i*x+5)**3*(x-2i)*(x-11/10)**2; roots zz;
%{x=-1.44949*i, x=-1.44949*i, x=-1.44949*i,
% x=3.44949*i, x=3.44949*i, x=3.44949*i, x=1.1, x=1.1, x=2.0*i}

% 42a) would have failed in roots Mod 1.93 and previously (bug)
realroots zz;
%{x=1.1,x=1.1}

% 43) 2 real, 2 complex roots.
zz:= (x**2-4)*(x**2+3i*x+5i); roots zz;
%{x= - 2.0,x=2.0,x=-1.2714 + 0.466333*i,x=1.2714 - 3.46633*i}

% 44) 4 complex roots.
zz:= x**4+(0.000001i)*x-16; roots zz;
%{x=-2.0 - 0.0000000625*i,x=-2.0*i,x=2.0*i,x=2.0 - 0.0000000625*i}

% 45) 2 real, 2 complex roots.
zz:= (x**2-4)*(x**2+2i*x+8); roots zz;
%{x= - 2.0,x=2.0,x=-4.0*i,x=2.0*i}

% 46) Using realroots to find only real roots.
realroots zz;
%{x= - 2.0,x=2.0}

% 47) Same example, applying nearestroot to find a single root.
zz:= (x**2-4)*(x**2+2i*x+8); nearestroot(zz,1);
%{x=2.0}

% 48) Same example, but focusing on imaginary point.
nearestroot(zz,i);
%{x=2.0*i}

% 49) The seed parameter can be complex also.
nearestroot(zz,1+i);
%{x=2.0*i}

% 50) One more nearestroot example.  Nearest root to real point may be
% complex.
zz:= (x**2-4)*(x**2-i); roots zz;
%{x= - 2.0,x=2.0,x=-0.707107 - 0.707107*i,x=0.707107 + 0.707107*i}

nearestroot (zz,1);
%{X=0.707107 + 0.707107*i}

% 51) 1 real root plus 5 complex roots.
zz:=(x**3-3i*x**2-5x+9)*(x**3-8); roots zz;
%{x=-1 + 1.73205*i,x=-1 - 1.73205*i,x=2.0,
% x=-2.41613 + 1.19385*i,x=0.981383 - 0.646597*i,x=1.43475 + 2.45274*i}

nearestroot(zz,1);
%{x=0.981383 - 0.646597*i}

% 52) roots can be computed to any accuracy desired, eg.  (note that the
% imaginary part of the second root is truncated because of its size,
% and that the imaginary part of a complex root is never polished away,
% even if it is smaller than the accuracy would require.)
zz := x**3+10**(-20)*i*x**2+8; rootacc 12; roots zz; rootacc 6;
%{x=-2.0 - 3.33333333333E-21*i,x=1 - 1.73205080757*i,
% x=1 + 1.73205080757*i}

% 53) Precision of 12 required to find small imaginary root,
% but standard accuracy can be used.
zz := x**2+123456789i*x+1; roots zz;
%{x=-1.23457E+8*i,x=0.0000000081*i}

% 54) Small real root is found with root 10*18 times larger(new).
zz := (x+1)*(x**2+123456789*x+1); roots zz;
%{x= - 1.23457E+8,x= - 1,x= - 0.0000000081}

% 55) 2 complex, 3 real irrational roots.
ss := (45*x**2+(-10i+12)*x-10i)*(x**3-5x**2+1); roots ss;
%{x= - 0.429174,x=0.469832,x=4.95934,
% x=-0.448056 - 0.19486*i,x=0.18139 + 0.417083*i}

% 56) Complex polynomial with floating coefficients.
zz := x**2+1.2i*x+2.3i+6.7; roots zz;
%{x=-0.427317 + 2.09121*i,x=0.427317 - 3.29121*i}

% 56a) multiple roots will be found if coefficients read in exactly.
% Exact read-in will occur unless dmode is rounded or complex-rounded.
zz := x**3 + (1.09 - 2.4*i)*x**2 + (-1.44 - 2.616*i)*x + -1.5696;
roots zz;
%{x=1.2*i,x=1.2*i,x= - 1.09}

% 57) Realroots, isolater and rlrootno accept 1, 2 or 3 arguments: (new)
zz:= for j:=-1:3 product (x-j); rlrootno zz;
% 5

realroots zz;
%{x=0,x= -1,x=1,x=2.0,x=3.0}

rlrootno(zz,positive); %positive selects positive, excluding 0.
% 3

rlrootno(zz,negative); %negative selects negative, excluding 0.
% 1

realroots(zz,positive);
%{x=1,x=2.0,x=3.0}

rlrootno(zz,-1.5,2); %the format with 3 arguments selects a range.
% 4

realroots(zz,-1.5,2); %the range is inclusive, except that:
%{x=0,x= - 1,x=1,x=2.0}

% A specific limit b may be excluded by using   exclude b.  Also, the
% limits infinity and -infinity can be specified.

realroots(zz,exclude 0,infinity);
% equivalent to realroots(zz,positive).
%{x=1,x=2.0,x=3.0}

rlrootno(zz,-infinity,exclude 0); % equivalent to rlrootno(zz,negative).
% 1

rlrootno(zz,-infinity,0);
% 2

rlrootno(zz,infinity,-infinity);
%equivalent to rlrootno zz; (order of limits does not matter.)
% 5

realroots(zz,1,infinity); % finds all real roots >= 1.
%{x=1,x=2.0,x=3.0}

realroots(zz,1,positive); % finds all real roots > 1.
%{x=2.0,x=3.0}

% 57a) Bug corrected in mod 1.94.  (handling of rational limits)
zz := (x-1/3)*(x-1/5)*(x-1/7)*(x-1/11);
realroots(zz,1/11,exclude(1/3));
%{x=0.0909091,x=0.142857,x=0.2}

realroots(zz,exclude(1/11),1/3);
%{x=0.142857,x=0.2,x=0.333333}

% New capabilities added in mod 1.88.

% 58) 3 complex roots, with two separated by very small real difference.
zz :=(x+i)*(x+10**8i)*(x+10**8i+1); roots zz;
%{x=-1 - 1.0E+8*i,x=-1.0E+8*i,x= - i}

% 59) Real polynomial with two complex roots separated by very small
% imaginary part.
zz:= (10**14x+123456789000000+i)*(10**14x+123456789000000-i); roots zz;
%{x=-1.23457 + 1.0E-14*i,x=-1.23457 - 1.0E-14*i}

% 60) Real polynomial with two roots extremely close together.
zz:= (x+2)*(10**10x+12345678901)*(10**10x+12345678900); roots zz;
%{x= - 2.0,x= - 1.2345678901,x= - 1.23456789}

% 61) Real polynomial with multiple root extremely close to simple root.
zz:= (x-12345678/10000000)*(x-12345679/10000000)**2; roots zz;
%{x=1.2345679,x=1.2345679,x=1.2345678}

% 62) Similar problem using realroots.
zz:=(x-2**30/10**8)**2*(x-(2**30+1)/10**8); realroots zz;
%{x=10.73741824,x=10.73741824,x=10.73741825}

% 63) Three complex roots with small real separation between two.
zz:= (x-i)*(x-1-10**8i)*(x-2-10**8i); roots zz;
%{x=i,x=1 + 1.0E+8*i,x=2.0 + 1.0E+8*i}

% 64) Use of nearestroot to isolate one of the close roots.
nearestroot(zz,10**8i+99/100);
%{x=1 + 1.0E+8*i}

% 65) Slightly more complicated example with close complex roots.
zz:= (x-i)*(10**8x-1234-10**12i)*(10**8x-1233-10**12i); roots zz;
%{x=i,x=0.00001233 + 10000.0*i,x=0.00001234 + 10000.0*i}

% 66) Four closely spaced real roots with varying spacings.
zz:= (x-1+1/10**7)*(x-1+1/10**8)*(x-1)*(x-1-1/10**7); roots zz;
%{x=0.9999999,x=0.99999999,x=1,x=1.0000001}

% 67) Complex pair plus two close real roots.
zz:= (x**2+1)*(x-12345678/10000000)*(x-12345679/10000000); roots zz;
%{x=i,x= - i,x=1.2345678,x=1.2345679}

% 68) Same problem using realroots to find only real roots.
realroots zz;
%{x=1.2345678,x=1.2345679}

% The switch ratroot causes output to be given in rational form.
% 69) Two complex roots with output in rational form.
on ratroot,complex; zz:=x**2-(5i+1)*x+1; sss:= roots zz; 

%           346859 - 1863580*i     482657 + 2593180*i
%sss := {x=--------------------,x=--------------------}
%                10000000                500000

% With roots in rational form, mkpoly can be used to reconstruct a
% polynomial.
zz1 := mkpoly sss;

%                      2
%zz1 := 5000000000000*x  - (4999999500000 + 25000010000000*i)*x
%
%        + 5000012308763 - 2110440*i

% Finding the roots of the new polynomial zz1.
rr:= roots zz1; 

%          346859 - 1863580*i     482657 + 2593180*i
%rr := {x=--------------------,x=--------------------}
%               10000000                500000

% The roots are stable to the extent that rr=ss, although zz1 and
% zz may differ.

zz1 - zz;

%               2
%4999999999999*x  - (4999999499999 + 25000009999995*i)*x
%
% + 5000012308762 - 2110440*i

% 70) Same type of problem in which roots are found exactly.
zz:=(x-10**8+i)*(x-10**8-i)*(x-10**8+3i/2)*(x-i); rr := roots zz;

%          4                    3                      2
%zz := (2*x  - (600000000 - i)*x  + 60000000000000005*x
%
%        - (2000000000000000800000000 + 29999999999999999*i)*x
%
%        + (30000000000000003 + 2000000000000000200000000*i))/2

%rr := {x=100000000 + i,x=100000000 - i,x=i,
%
%          200000000 - 3*i
%       x=-----------------}
%                 2

% Reconstructing a polynomial from the roots.
ss := mkpoly rr;

%         4                    3                      2
%ss := 2*x  - (600000000 - i)*x  + 60000000000000005*x
%
%       - (2000000000000000800000000 + 29999999999999999*i)*x
%
%       + (30000000000000003 + 2000000000000000200000000*i)

% In this case, the same polynomial is obtained.
ss - num zz;
% 0

% 71) Finding one of the complex roots using nearestroot.
nearestroot(zz,10**8-2i); 

%    200000000 - 3*I
%{x=-----------------}
%           2

% Finding the other complex root using nearestroot.
nearestroot(zz,10**8+2i);
%{x=100000000 + I}

% 72) A realroots problem which requires accuracy increase to avoid
% confusion of two roots.
zz:=(x+1)*(10000000x-19999999)*(1000000x-2000001)*(x-2);
realroots zz; 

%          19999999         2000001
% {x=-1,x=----------,x=2,x=---------}
%          10000000         1000000

% 73) Without the accuracy increase, this example would produce the
% obviously incorrect answer 2.
realroots(zz,3/2,exclude 2); 

%     19999999
% {x=----------}
%     10000000

% Rlrootno also gives the correct answer in this case.
rlrootno(zz,3/2,exclude 2);
% 1

% 74) Roots works equally well in this problem.
rr := roots zz;
%                 19999999        2000001
%rr := {x= - 1,x=----------,x=2,x=---------}
%                 10000000        1000000

% 75) The function getroot is convenient for obtaining the value of a
% root.
rr1 := getroot(1,rr);

%         19999999
% rr1 := ----------
%         10000000

% 76) For example, the value can be used as an argument to nearestroot.
nearestroot(zz,rr1); 

%     19999999
% {x=----------}
%     10000000


comment  New capabilities added to Mod 1.90 for avoiding floating point
  exceptions and exceeding iteration limits.;

% 77) This and the next example would previously have aborted because
%of exceeding iteration limits:
off ratroot; zz := x**16 - 900x**15 -2; roots zz;
%{x= - 0.665423,x=-0.607902 + 0.270641*i,x=-0.607902 - 0.270641*i,
% x=-0.44528 + 0.494497*i, x=-0.44528 - 0.494497*i,
% x=-0.205664 + 0.632867*i,x=-0.205664 - 0.632867*i,
% x=0.069527 + 0.661817*i,x=0.069527 - 0.661817*i,
% x=0.332711 + 0.57633*i,x=0.332711 - 0.57633*i,
% x=0.538375 + 0.391176*i,x=0.538375 - 0.391176*i,
% x=0.650944 + 0.138369*i,x=0.650944 - 0.138369*i,x=900.0}

% 78) a still harder example.
zz := x**30 - 900x**29 - 2; roots zz;
%{x= - 0.810021,x=-0.791085 + 0.174125*i,x=-0.791085 - 0.174125*i,
% x=-0.735162 + 0.340111*i,x=-0.735162 - 0.340111*i,
% x=-0.644866 + 0.490195*i,x=-0.644866 - 0.490195*i,
% x=-0.524417 + 0.617362*i,x=-0.524417 - 0.617362*i,
% x=-0.379447 + 0.715665*i,x=-0.379447 - 0.715665*i,
% x=-0.216732 + 0.780507*i,x=-0.216732 - 0.780507*i,
% x=-0.04388 + 0.808856*i,x=-0.04388 - 0.808856*i,
% x=0.131027 + 0.799383*i,x=0.131027 - 0.799383*i,
% x=0.299811 + 0.752532*i,x=0.299811 - 0.752532*i,
% x=0.454578 + 0.67049*i,x=0.454578 - 0.67049*i,
% x=0.588091 + 0.557094*i,x=0.588091 - 0.557094*i,
% x=0.694106 + 0.417645*i,x=0.694106 - 0.417645*i,
% x=0.767663 + 0.258664*i,x=0.767663 - 0.258664*i,
% x=0.805322 + 0.0875868*i,x=0.805322 - 0.0875868*i,x=900.0}

% 79) this deceptively simple example previously caused floating point
% overflows on some systems:
aa := x**6 - 4*x**3 + 2; realroots aa;
%{x=0.836719,x=1.50579}

% 80) a harder problem, which would have failed on almost all systems:
rr := x**16 - 90000x**15 - x**2 -2; realroots rr;
%{x= - 0.493299,x=90000.0}

% 81) this example would have failed because of floating point
% exceptions on almost all computer systems.
rr := x**30 - 9*10**10*x**29 - 2;  realroots rr;
%{x= - 0.429188,x=9.0E+10}

% 82) a test of allroot on this example.
% This example is commented out because it takes significant time
% without breaking new ground.
%**% roots  rr;
%{x= - 0.429188,
% x=-0.419154 + 0.092263*i,x=-0.419154 - 0.092263*i,
% x=-0.389521 + 0.180211*i,x=-0.389521 - 0.180211*i,
% x=-0.341674 + 0.259734*i,x=-0.341674 - 0.259734*i,
% x=-0.277851 + 0.327111*i,x=-0.277851 - 0.327111*i,
% x=-0.201035 + 0.379193*i,x=-0.201035 - 0.379193*i,
% x=-0.11482 + 0.413544*i,x=-0.11482 - 0.413544*i,
% x=-0.0232358 + 0.428559*i,x=-0.0232358 - 0.428559*i,
% x=0.0694349 + 0.423534*i,x=0.0694349 - 0.423534*i,
% x=0.158859 + 0.398706*i,x=0.158859 - 0.398706*i,
% x=0.240855 + 0.355234*i,x=0.240855 - 0.355234*i,
% x=0.311589 + 0.295153*i,x=0.311589 - 0.295153*i,
% x=0.367753 + 0.22127*i,x=0.367753 - 0.22127*i,
% x=0.406722 + 0.13704*i,x=0.406722 - 0.13704*i,
% x=0.426672 + 0.0464034*i,x=0.426672 - 0.0464034*i,x=9.0E+10}

% 83) test of starting point for iteration: no convergence if good
% real starting point is not found.
zz := x**30 -9*10**12x**29 -2; firstroot zz;
%{x= - 0.36617}

% 84) a case in which there are no real roots and good imaginary
% starting point must be used or roots cannot be found.
zz:= 9x**16 - x**5 +1; roots zz;
%{x=-0.866594 + 0.193562*i,x=-0.866594 - 0.193562*i,
% x=-0.697397 + 0.473355*i,x=-0.697397 - 0.473355*i,
% x=-0.510014 + 0.716449*i,x=-0.510014 - 0.716449*i,
% x=-0.161318 + 0.87905*i,x=-0.161318 - 0.87905*i,
% x=0.182294 + 0.828368*i,x=0.182294 - 0.828368*i,
% x=0.459373 + 0.737443*i,x=0.459373 - 0.737443*i,
% x=0.748039 + 0.494348*i,x=0.748039 - 0.494348*i,
% x=0.845617 + 0.142879*i,x=0.845617 - 0.142879*i}

% 85) five complex roots.
zz := x**5 - x**3 + i; roots zz;
%{x=-1.16695 - 0.217853*i,x=-0.664702 + 0.636663*i,x=-0.83762*i,
% x=0.664702 + 0.636663*i,x=1.16695 - 0.217853*i}

% Additional capabilities in Mod 1.91.

% 86) handling of polynomial with huge or infinitesimal coefficients.
precision reset;
on rounded; precision reset;
% so that the system will start this example in floating point.  Rounded
% is on so that the polynomial won't fill the page!
zz:= 1.0e-500x**3+x**2+x;
roots zz; off rounded; % rounded not normally needed for roots.
%{x=0,x= - 1.0E+500,x= - 1}
off roundbf;

comment  Switch roundbf will have been turned on in the last example in
  most computer systems.  This will inhibit the use of hardware floating
  point unless roundbf is turned off.

  Polynomials which make use of powergcd substitution and cascaded
  solutions.

  Uncomplicated cases.;

switch powergcd; % introduced here to verify that same answers are
% obtained with and without employing powergcd strategy.  Roots are
% found faster for applicable cases when !*powergcd=t (default state.)

% 87) powergcd done at the top level.
zz := x**12-5x**9+1; roots zz;
%{x=-0.783212 + 0.276071*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=-0.783212 - 0.276071*i,
% x=0.152522 + 0.816316*i,x=0.63069 - 0.540246*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,x=0.848444,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,x=1.70906}

off powergcd; roots zz; on powergcd;
%{x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,
% x=-0.783212 + 0.276071*i,x=-0.783212 - 0.276071*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,
% x=0.152522 + 0.816316*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=0.63069 - 0.540246*i,x=0.848444,x=1.70906}

% 88) powergcd done after square free factoring.
zz := (x-1)**2*zz; roots zz;
%{x=1,x=1,
% x=-0.783212 + 0.276071*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=-0.783212 - 0.276071*i,
% x=0.152522 + 0.816316*i,x=0.63069 - 0.540246*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,x=0.848444,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,x=1.70906}

off powergcd; roots zz; on powergcd;
%{x=1,x=1,
% x=-0.85453 + 1.48009*i,x=-0.85453 - 1.48009*i,
% x=-0.783212 + 0.276071*i,x=-0.783212 - 0.276071*i,
% x=-0.424222 + 0.734774*i,x=-0.424222 - 0.734774*i,
% x=0.152522 + 0.816316*i,x=0.152522 - 0.816316*i,
% x=0.63069 + 0.540246*i,x=0.63069 - 0.540246*i,
% x=0.848444,x=1.70906}

% 89) powergcd done after separation into real and complex polynomial.
zz := x**5-i*x**4+x**3-i*x**2+x-i; roots zz;
%{x=-0.5 - 0.866025*i,x=0.5 + 0.866025*i,
% x=-0.5 + 0.866025*i,x=0.5 - 0.866025*i,x=i}

off powergcd; roots zz; on powergcd;
%{x=-0.5 + 0.866025*i,x=-0.5 - 0.866025*i,
% x=0.5 + 0.866025*i,x=0.5 - 0.866025*i,x=i}

% Cases where root separation requires accuracy and/or precision
% increase.  In some examples we get excess accuracy, but it is hard
% avoid this and still get all roots separated.

% 90) accuracy increase required to separate close roots;
let x=y**2;
zz:= (x-3)*(100000000x-300000001); roots zz;
%{y= - 1.732050808,y=1.732050808,y= - 1.73205081,y=1.73205081}

off powergcd; roots zz;  on powergcd;
%{y= - 1.73205081,y= - 1.732050808,y=1.732050808,y=1.73205081}

% 91) roots to be separated are on different square free factors.
zz:= (x-3)**2*(10000000x-30000001); roots zz;
%{y= - 1.73205081,y= - 1.73205081,y=1.73205081,y=1.73205081,
% y= - 1.73205084,y=1.73205084}

off powergcd; roots zz;  on powergcd;
%{y= - 1.73205081,y= - 1.73205081,y=1.73205081,y=1.73205081,
% y= - 1.73205084,y=1.73205084}

% 91a) A new capability for nearestroot:
nearestroot(zz,1.800000000001); % should find the root to 13 places.
%{y=1.732050836436}

% 92) roots must be separated in the complex polynomial factor only.
zz :=(y+1)*(x+10**8i)*(x+10**8i+1); roots zz;
%{y= - 1,
% y=-7071.067777 + 7071.067847*i,y=7071.067777 - 7071.067847*i,
% y=-7071.067812 + 7071.067812*i,y=7071.067812 - 7071.067812*i}

% 93)
zz := (x-2)**2*(1000000x-2000001)*(y-1); roots zz;
%{y= - 1.4142136,y= - 1.4142136,y=1.4142136,y=1.4142136,
% y= - 1.4142139,y=1,y=1.4142139}

% 94)
zz := (x-2)*(10000000x-20000001); roots zz;
%{y= - 1.41421356 ,y=1.41421356 ,y= - 1.4142136,y=1.4142136}

% 95)
zz := (x-3)*(10000000x-30000001); roots zz;
%{y= - 1.73205081 ,y=1.73205081 ,y= - 1.73205084 ,y=1.73205084}

% 96)
zz := (x-9)**2*(1000000x-9000001); roots zz;
%{y= - 3.0,y= - 3.0,y=3.0,y=3.0,y= - 3.00000017,y=3.00000017}

% 97)
zz := (x-3)**2*(1000000x-3000001); roots zz;
%{y= - 1.7320508,y= - 1.7320508,y=1.7320508,y=1.7320508,
% y= - 1.7320511,y=1.7320511}

% 98) the accuracy of the root sqrt 5 depends upon another close root.
% Although one of the factors is given in decimal notation, it is not
% necessary to turn rounded on.
rootacc 10; % using rootacc to specify the minumum desired accuracy.
zz := (y^2-5)*(y-2.2360679775);
% in this case, adding one place to the root near sqrt 5 causes a
% required increase of 4 places in accuracy of the root at sqrt 5.
roots zz;
%{y= - 2.236067977,y=2.2360679774998,y=2.2360679775}

realroots zz; % should get the same answer from realroots.
%{y= - 2.2360679775,y=2.2360679774998,y=2.2360679775}


% 99) The same thing also happens when the root near sqrt 5 is on a
% different square-free factor.
zz := (y^2-5)^2*(y-2.2360679775);
roots zz;
%{y= - 2.236067977,y= - 2.236067977,y=2.2360679774998,
% y=2.2360679774998,y=2.2360679775}

realroots zz; % realroots handles this case also.
%{y= - 2.236067977,y= - 2.236067977,y=2.2360679774998,y=2.2360679774998,
% y=2.2360679775}

% 100)
rootacc 6;
zz := (y-i)*(x-2)*(1000000x-2000001); roots zz;
%{y= - 1.4142136,y=1.4142136,y= - 1.4142139,y=1.4142139,y=i}

% 101) this example requires accuracy 15.
zz:= (y-2)*(100000000000000y-200000000000001);
roots zz;
%{y=2.0,y=2.00000000000001}

% 102) still higher precision needed.
zz:= (y-2)*(10000000000000000000y-20000000000000000001); roots zz;
%{y=2.0,y=2.0000000000000000001}

% 103) increase in precision required for substituted polynomial.
zz:= (x-2)*(10000000000x-20000000001); roots zz;
%{y= - 1.41421356237,y=1.41421356237,y= - 1.41421356241,y=1.41421356241}

% 104) still higher precision required for substituted polynomial.
zz:= (x-2)*(100000000000000x-200000000000001); roots zz;
%{y= - 1.414213562373095,y=1.414213562373095,
% y= - 1.414213562373099,y=1.414213562373099}

% 105) accuracy must be increased to separate root of complex factor
% from root of real factor.
zz:=(9y-10)*(y-2)*(9y-10-9i/100000000); roots zz;
%{y=1.111111111,y=2.0,y=1.111111111 + 0.00000001*i}

% 106) realroots does the same accuracy increase for real root based
% upon the presence of a close complex root in the same polynomial.
% The reason for this might not be obvious unless roots is called.
realroots zz;
%{y=1.111111111,y=2.0}

% 107) realroots now uses powergcd logic whenever it is applicable.
zz := (x-1)*(x-2)*(x-3);  realroots zz;
%{y= - 1,y=1,y= - 1.41421,y=1.41421,y= - 1.73205,y=1.73205}

realroots(zz,exclude 1,2);
%{y=1.41421,y=1.73205}

% 108) root of degree 1 polynomial factor must be evaluated at
% precision 18 and accuracy 10 in order to separate it from a root of
% another real factor.
clear x; zz:=(9x-10)**2*(9x-10-9/100000000)*(x-2); roots zz;
%{x=1.111111111,x=1.111111111,x=1.111111121,x=2.0}

nearestroot(zz,1);
%{x=1.111111111}

nearestroot(zz,1.5);
%{x=1.111111121}

nearestroot(zz,1.65);
%{x=2.0}

% 108a) new cability in mod 1.94.
realroots zz;
%{x=1.111111111,x=1.111111111,x=1.111111121,x=2.0}

% 109) in this example, precision >=40 is used and two roots need to be
% found to accuracy 16 and two to accuracy 14.
zz := (9x-10)*(7x-8)*(9x-10-9/10**12)*(7x-8-7/10**14); roots zz;
%{x=1.1111111111111,x=1.1111111111121,
% x=1.142857142857143,x=1.142857142857153}

% 110) very small real or imaginary parts of roots require high
% precision or exact computations, or they will be lost or incorrectly
% found.
zz := 1000000*r**18 + 250000000000*r**4 - 1000000*r**2 + 1; roots zz;
%{r=2.42978*i,r=-2.42978*i,
% r=-1.05424 - 2.18916*i,r=1.05424 + 2.18916*i,
% r=-1.05424 + 2.18916*i,r=1.05424 - 2.18916*i,
% r=-0.00141421 - 1.6E-26*i,r=0.00141421 + 1.6E-26*i,
% r=-0.00141421 + 1.6E-26*i,r=0.00141421 - 1.6E-26*i,
% r=-1.89968 - 1.51494*i,r=1.89968 + 1.51494*i,
% r=-1.89968 + 1.51494*i,r=1.89968 - 1.51494*i,
% r=-2.36886 - 0.540677*i,r=2.36886 + 0.540677*i,
% r=-2.36886 + 0.540677*i,r=2.36886 - 0.540677*i}


comment  These five examples are very difficult root finding problems
  for automatic root finding (not employing problem-specific
  procedures.) They require extremely high precision and high accuracy
  to separate almost multiple roots (multiplicity broken by a small high
  order perturbation.)  The examples are roughly in ascending order of
  difficulty.;

% 111) Two simple complex roots with extremely small real separation.
c := 10^-6;
zz:=(x-3c^2)^2+i*c*x^7; roots zz;
%{x=-15.0732 + 4.89759*i,x=-9.31577 - 12.8221*i,x=-1.2E-12 + 15.8489*i,
% x=2.99999999999999999999999999999997E-12
%    + 3.3068111527572904325663335008527E-44*i,
% x=3.00000000000000000000000000000003E-12
%    - 3.30681115275729043256633350085321E-44*i,
% x=9.31577 - 12.8221*i,x=15.0732 + 4.89759*i}

% 112) Four simple complex roots in two close sets.
c := 10^-4;
zz:=(x^2-3c^2)^2+i*c^2*x^9; roots zz;
%{x=-37.8622 + 12.3022*i,x=-23.4002 - 32.2075*i,
% x=-0.00017320508075689 - 2.41778234660324E-18*i,
% x=-0.000173205080756885 + 2.4177823466027E-18*i,
% x=39.8107*i,
% x=0.000173205080756885 + 2.4177823466027E-18*i,
% x=0.00017320508075689 - 2.41778234660324E-18*i,
% x=23.4002 - 32.2075*i,x=37.8622 + 12.3022*i}

% 113) Same example, but with higher minimum root accuracy specified.
rootacc 20;
roots zz;
%{x=-37.862241873586290526 + 12.302188128448775345*i,
% x=-23.400152368145827118 - 32.207546656274351069*i,
% x=-0.00017320508075689014714 - 2.417782346603239319E-18*i,
% x=-0.00017320508075688531157 + 2.417782346602699319E-18*i,
% x=39.810717055651151449*i,
% x=0.00017320508075688531157 + 2.417782346602699319E-18*i,
% x=0.00017320508075689014714 - 2.417782346603239319E-18*i,
% x=23.400152368145827118 - 32.207546656274351069*i,
% x=37.862241873586290526 + 12.302188128448775345*i}

precision reset;
% This resets precision and rootacc to nominal.

% 114) Two extremely close real roots plus a complex pair with extremely
% small imaginary part.
c := 10^6;
zz:=(c^2*x^2-3)^2+c^2*x^9; roots zz;
%{x= - 251.189,x=-77.6216 + 238.895*i,x=-77.6216 - 238.895*i,
% x= - 0.000001732050807568877293531,
% x= - 0.000001732050807568877293524,
% x=0.00000173205 + 3.41926E-27*i,x=0.00000173205 - 3.41926E-27*i,
% x=203.216 + 147.645*i,x=203.216 - 147.645*i}

% 114a) this example is a critical test for realroots as well.
realroots zz;
%{x= - 251.189,x= - 0.000001732050807568877293531,
% x= - 0.000001732050807568877293524}

% 115) Four simple complex roots in two extremely close sets.
c := 10^6;
zz:=(c^2*x^2-3)^2+i*c^2*x^9; roots zz;
%{x=-238.895 + 77.6216*i,x=-147.645 - 203.216*i,
% x=-0.00000173205080756887729353 - 2.417782346602969319022E-27*i,
% x=-0.000001732050807568877293525 + 2.417782346602969318968E-27*i,
% x=251.189*i,
% x=0.000001732050807568877293525 + 2.417782346602969318968E-27*i,
% x=0.00000173205080756887729353 - 2.417782346602969319022E-27*i,
% x=147.645 - 203.216*i,x=238.895 + 77.6216*i}


% 116) A new "hardest example" type.  This polynomial has two sets of
% extremely close real roots and two sets of extremely close conjugate
% complex roots, both large and small, with the maximum accuracy and
% precision required for the largest roots.  Three restarts are
% required, at progressively higher precision, to find all roots.
 % (to run this example, uncomment the following two lines.)
%**% zz1:= (10^12x^2-sqrt 2)^2+x^7$ zz2:= (10^12x^2+sqrt 2)^2+x^7$
%**% zzzz := zz1*zz2$ roots zzzz;
%{x= - 1.00000000000000000000000000009E+8,
% x= - 9.99999999999999999999999999906E+7,
% x= - 0.0000011892071150027210667183,
% x= - 0.0000011892071150027210667167,
% x=-5.4525386633262882960501E-28 + 0.000001189207115002721066718*i,
% x=-5.4525386633262882960501E-28 - 0.000001189207115002721066718*i,
% x=5.4525386633262882960201E-28 + 0.000001189207115002721066717*i,
% x=5.4525386633262882960201E-28 - 0.000001189207115002721066717*i,
% x=0.00000118921 + 7.71105E-28*i,
% x=0.00000118921 - 7.71105E-28*i,
% x=4.99999999999999999999999999953E+7
%    + 8.66025403784438646763723170835E+7*i,
% x=4.99999999999999999999999999953E+7
%    - 8.66025403784438646763723170835E+7*i,
% x=5.00000000000000000000000000047E+7
%    + 8.66025403784438646763723170671E+7*i,
% x=5.00000000000000000000000000047E+7
%    - 8.66025403784438646763723170671E+7*i}

% Realroots strategy on this example is different, but determining the
% necessary precision and accuracy is tricky.
%**% realroots zzzz;
%{x= - 1.00000000000000000000000000009E+8,
% x= - 9.9999999999999999999999999991E+7,
% x= - 0.0000011892071150027210667183,
% x= - 0.0000011892071150027210667167}

% 117) multroot examples.  Multroot can be called directly, or it can be
% called by giving roots or realroots a list of polynomials as argument.
% Here, multroot is called directly.  Realroots is used unless the switch
% compxroots is on.  In this example, p1 must be computed at accuracy 33
% in order to yield an accuracy of 20 for p2.
res :=          % Structure is {eq1(p1,p2),eq2(p1)}
{ - 65193331905902035840886401184447471772856493442267717*P1**13
- 1664429561324832520726401259146912155464247056480012434*P1**12
- 6261475374084274810766056740641579522309310708502887990*P1**11
+ 58050875148721867394302891225676265051604299348469583622*P1**10
- 25149162547648105419319267662238682603649922079217227285*P1**9
- 440495842372965561251919788209759089436362766115660350108*P1**8
+ 1031835865631194068430476093579502290454870220388968336688*P1**7
- 176560168441303582471783015188457142709772508915411137856*P1**6
- 3394297397883799767380936436924078166849454318674637153232*P1**5
+ 8572159983028240622274769676964404195355003175115163884096*P1**4
- 11689989317682872105592244166702248132836279639925035950656*P1**3
+ 9646776768609439752430866001814626337809195004192011294976*P1**2
- 4455646388442119339178004445898515058096390082146233345536*P1
+ 4709370575236909034773453200518274143851133066819671040*P2
+ 886058257542744466307567014351806947093655767531394713600,
53271*P1**14 + 1393662*P1**13 + 6077030*P1**12 - 41382626*P1**11
+ 6240255*P1**10 + 313751524*P1**9 - 698694844*P1**8
+ 134987928*P1**7 + 2322386256*P1**6 - 6102636608*P1**5
+ 8722164608*P1**4 - 7907887488*P1**3 + 4508378368*P1**2
- 1477342720*P1 + 213248000}$
multroot(20,res);
%{{p1= - 16.330244199212269912,p2= - 12.905402440394357204},{p1
%    = - 13.071850241794867852,p2= - 20.369934278813005573}}

% 118)  structure is {p1(x1,x3,x4),p2(x2,x4),p3(x2,x3,x4),p4(x4)}
h := {36439926476029643745*x1 + 36439926476029643745*x3
- 966689910765785535050240000*x4**17
+ 2589213991952971388822784000*x4**16
- 1455736281904024746728256000*x4**15
- 1114734065976529083327407360*x4**14
+ 720240539282202478990426752*x4**13
+ 419779761544955697624679296*x4**12
- 168749980172837712266699840*x4**11
+ 290913179471491189688854560*x4**10 - 432958804125555395247740688*x4**9 
+ 10386593827154614897599504*x4**8 + 155547361883654478618679440*x4**7
- 31113996003728470659075480*x4**6 - 41175755320900503555096780*x4**5
+ 33003268068791208924709740*x4**4 - 6778828915691466390091200*x4**3
- 1496167017611703417373950*x4**2 + 149688116448660711183825*x4
+ 138148004064999041884935,
- 36439926476029643745*x2 - 784034192593211415232000000*x4**17
+ 2099814921874128508369920000*x4**16
- 1180307545285783973854272000*x4**15
- 904159020650675303719168000*x4**14
+ 583907514538684395627559680*x4**13
+ 340458856280381353403249664*x4**12
- 136785894094420325707236352*x4**11
+ 235962131906791901454310848*x4**10
- 351090033711917923140908256*x4**9 + 8379974606095284871931520*x4**8
+ 126131069262992237456374584*x4**7 -25220359028157888406315896*x4**6
- 33393008746801847984243640*x4**5 + 26761347051713933045852160*x4**4
- 5495296446381334401240210*x4**3 - 1213098761225775782417310*x4**2
+ 121243165959568584810870*x4 + 112046752277725240396125,
145759705904118574980*x3**2 - 3866759643063142140200960000*x3*x4**17
+ 10356855967811885555291136000*x3*x4**16
- 5822945127616098986913024000*x3*x4**15
- 4458936263906116333309629440*x3*x4**14
+ 2880962157128809915961707008*x3*x4**13
+ 1679119046179822790498717184*x3*x4**12
- 674999920691350849066799360*x3*x4**11
+ 1163652717885964758755418240*x3*x4**10
- 1731835216502221580990962752*x3*x4**9
+ 41546375308618459590398016*x3*x4**8
+ 622189447534617914474717760*x3*x4**7
- 124455984014913882636301920*x3*x4**6
- 164703021283602014220387120*x3*x4**5
+ 132013072275164835698838960*x3*x4**4
- 27115315662765865560364800*x3*x4**3
- 5984668070446813669495800*x3*x4**2 + 598752465794642844735300*x3*x4
+ 552592016259996167539740*x3 + 3550270013715070172487680000*x4**17
- 9573649159583488469933568000*x4**16
+ 5464438450196473162575360000*x4**15
+ 4096921924516221821604523520*x4**14
- 2717026023466705910519606784*x4**13
- 1554544907157405816469959168*x4**12
+ 636859360057972319632500992*x4**11
- 1065163663567422851531986944*x4**10
+ 1612243029585251439302638656*x4**9
- 48252032958282805311135168*x4**8 - 579133322758350220074700320*x4**7
+ 117976179842506552019678280*x4**6 + 152287445048713077301910400*x4**5 
- 123053170142513516618082960*x4**4 + 25533441675517563881962200*x4**3
+ 5583415080801636858130200*x4**2 - 574247940288215661001800*x4
- 518304795930023609925945,
- 5120000*x4**18 + 18432000*x4**17 - 20352000*x4**16 + 1208320*x4**15
+ 9255936*x4**14 - 1296384*x4**13 - 2943488*x4**12 + 2365440*x4**11
- 3712896*x4**10 + 2169600*x4**9 + 772560*x4**8 - 924480*x4**7
- 66000*x4**6 + 375840*x4**5 - 197100*x4**4 + 25200*x4**3 + 8100*x4**2
- 675}$
multroot(20,h);
%{{x1= - 0.12444800707566022364,x2=0.40264591905223704246,x3
%  =0.70281784593572688134,x4=0.92049796029182926078},
% {x1= - 0.12444800707566022364,x2=0.92049796029182926078,x3
%  =0.70281784593572688134,x4=0.40264591905223704246},
% {x1=0.22075230018295426413,x2=0.48100256896929398759,x3
%  =0.74057635603986743051,x4=0.93049526909398804249},
% {x1=0.22075230018295426413,x2=0.93049526909398804249,x3
%  =0.74057635603986743051,x4=0.48100256896929398759},
% {x1=0.70281784593572688134,x2=0.40264591905223704246,x3
%  = - 0.12444800707566022364,x4=0.92049796029182926078},
% {x1=0.70281784593572688134,x2=0.92049796029182926078,x3
%  = - 0.12444800707566022364,x4=0.40264591905223704246},
% {x1=0.74057635603986743051,x2=0.48100256896929398759,x3
%  =0.22075230018295426413,x4=0.93049526909398804249},
% {x1=0.74057635603986743051,x2=0.93049526909398804249,x3
%  =0.22075230018295426413,x4=0.48100256896929398759}}

% System precision will have been set to 20 in the two previous
% examples.  In the following examples, the roots will be given to
% accuracy 12, because rootacc 12; was input.  If rootacc had not been
% input, the roots would be given at system precision, which could
% different answers on different systems if precision had been reset,
% or else it would have been 20 because of example 118).

rootacc 12;

% 119)
ss := {x^2-2,y^2-x^2,z^2-x-y}; % structure is {p1(x),p2(x,y),p3(x,y,z)}
realroots ss;
%{{x= - 1.41421356237,y=1.41421356237,z=0},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},
% {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

roots ss;
%{{x= - 1.41421356237,y= - 1.41421356237,z=1.68179283051*i},
% {x= - 1.41421356237,y= - 1.41421356237,z= - 1.68179283051*i},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x= - 1.41421356237,y=1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y= - 1.41421356237,z=0},
% {x=1.41421356237,y=1.41421356237,z= - 1.68179283051},
% {x=1.41421356237,y=1.41421356237,z=1.68179283051}}

% 120)
realroots {x^5-45x+2,y^2-x+1};
%{{x=2.57878769906,y= - 1.25649818904},{x=2.57878769906,y
%    =1.25649818904}}

realroots {x^5-45x+2,y^2-x-1};
%{{x=0.0444444482981,y= - 1.02198064967},
% {x=0.0444444482981,y=1.02198064967},
% {x=2.57878769906,y= - 1.89176840524},
% {x=2.57878769906,y=1.89176840524}}

% 121)
realroots {x^2-2,y^2+x^2};
% {}

roots {x^2+2,y^2-x^2};
%{{x=1.41421356237*i,y=1.41421356237*i},
% {x=1.41421356237*i,y= - 1.41421356237*i},
% {x= - 1.41421356237*i,y=1.41421356237*i},
% {x= - 1.41421356237*i,y= - 1.41421356237*i}}

% 122)
roots {x^2-y^2,x^2+y^2+3};
%multroot fails because no univariate polynomial was given.
%multroot(12,{x**2 - y**2,x**2 + y**2 + 3})$

% 122a)
roots{x^2+y^2,x^2-y^2-z,z^2-z-1};
%*** multroot failure: at least one polynomial has no single base.
%multroot(12,{x**2 + y**2,(x**2 - y**2) - z,(z**2 - z) - 1})$

% 123)
roots {x^2-2,y^2+3,x+z-2,y-z+2};
%{}

% 124)
zz := {x^5-5x+3,x^2+y^2,x^3+z^3};
realroots zz;
%{}

realroots {x^5-5x+3,x^2-y^2,x^3+z^3};
%{{x= - 1.61803398875,y= - 1.61803398875,z=1.61803398875},
% {x= - 1.61803398875,y=1.61803398875,z=1.61803398875},
% {x=0.61803398875,y= - 0.61803398875,z= - 0.61803398875},
% {x=0.61803398875,y=0.61803398875,z= - 0.61803398875},
% {x=1.27568220365,y= - 1.27568220365,z= - 1.27568220365},
% {x=1.27568220365,y=1.27568220365,z= - 1.27568220365}}

% These show previous capability
%------------------------------------------------------------------
% These are new capability

% 125)
roots{x**2 - x - y,x*y - 2*y,y**2 - 2*y};
%{{x=0,y=0},{x=1,y=0},{x=2.0,y=2.0}}

% 126)
roots({x^2-9,y^3-27,x*y+9});
%{{x= - 3.0,y=3.0}}

% 127)
multroot(12,{y^2-z,y*z,z*(z-1)});
%{{y=0,z=0},{y=0,z=0}}

% 127a)
multroot(12,{y^2-z,y*z,z*(z-1),x^2-x-y});
%{{x=0,y=0,z=0},
% {x=0,y=0,z=0},
% {x=1,y=0,z=0},
% {x=1,y=0,z=0}}

% 128)
roots{y*z,z*(z-1)};
%{{z=0},{y=0,z=1}}

% 129)
zzl := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z+1};
roots zzl;
%{{y= - 1.5,z=2.0},
% {y= - 1.41421356237,z=1},
% {y=1.41421356237,z=1}}

% 129a)
zzla := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z+1,x^2-x-y};
roots zzla;
%{{x= - 0.790044015673,y=1.41421356237,z=1},
% {x=0.5 + 1.11803398875*i,y= - 1.5,z=2.0},
% {x=0.5 - 1.11803398875*i,y= - 1.5,z=2.0},
% {x=0.5 + 1.07898728555*i,y= - 1.41421356237,z=1},
% {x=0.5 - 1.07898728555*i,y= - 1.41421356237,z=1},
% {x=1.79004401567,y=1.41421356237,z=1}}

% 130)
zzl0 := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z};
roots zzl0;
%{{y=-1,z=1},{y=-1,z=2.0},{z=0},{y=1,z=1}}

% 131)
zzl3a := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z,x^2+y*x*z+z};
roots zzl3a;
%{{x=0.866025403784*i - 0.5,y=1,z=1},
% {x= - 0.866025403784*i - 0.5,y=1,z=1},
% {x=0,z=0},
% {x=0,z=0},
% {x=0.866025403784*i + 0.5,y=-1,z=1},
% {x= - 0.866025403784*i + 0.5,y=-1,z=1},
% {x=i + 1,y=-1,z=2.0},
% {x= - i + 1,y=-1,z=2.0}}$

% 132)
zzl3c := {z*(z-1)*(z-2),(z-2)*z*y^2+(z-1)*z*y+z,x^2+y*x+z};
roots zzl3c;
%*** for some root value, a variable dependends on an arbitrary variable
%multroot(12,{z**3 - 3*z**2 + 2*z,y**2*z**2 - 2*y**2*z + y*z**2 - y*z + z,
% x**2 + x*y + z})$

% 133)
xyz := {x^2-x-2,y^2+y,x^3+y^3+z+5};
roots xyz;
%{{x=-1,y=-1,z= - 3.0},
% {x=-1,y=0,z= - 4.0},
% {x=2.0,y=-1,z= - 12.0},
% {x=2.0,y=0,z= - 13.0}}

% 134) here, we had to eliminate a spurious imaginary part of z.
axyz := {a-1,a+x^2-x-2,a+y^2+y,a+x^3+y^3+z+5};
roots axyz;
%{{a=1,x= - 0.61803398875,y= - 0.5 + 0.866025403784*i,z= - 6.7639320225},
% {a=1,x= - 0.61803398875,y= - 0.5 - 0.866025403784*i,z= - 6.7639320225},
% {a=1,x=1.61803398875,y= - 0.5 + 0.866025403784*i,z= - 11.2360679775},
% {a=1,x=1.61803398875,y= - 0.5 - 0.866025403784*i,z= - 11.2360679775}}

% 134a) here, we had to eliminate a spurious real part of x.
roots{y^4+y^3+y^2+y+1,x^2+3*y^5+2};
%{{x=2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},
% {x=-2.2360679775*i,y= - 0.809016994375 + 0.587785252292*i},
% {x=-2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},
% {x=2.2360679775*i,y= - 0.809016994375 - 0.587785252292*i},
% {x=-2.2360679775*i,y=0.309016994375 + 0.951056516295*i},
% {x=2.2360679775*i,y=0.309016994375 + 0.951056516295*i},
% {x=2.2360679775*i,y=0.309016994375 - 0.951056516295*i},
% {x=-2.2360679775*i,y=0.309016994375 - 0.951056516295*i}}

% 135)
axyz2 := {a-1,a-1+x^2-x-2,a-1+y^2+y,x^3+y^3+z+5};
roots axyz2;
%{{a=1,x=-1,y=-1,z= - 3.0},
% {a=1,x=-1,y=0,z= - 4.0},
% {a=1,x=2.0,y=-1,z= - 12.0},
% {a=1,x=2.0,y=0,z= - 13.0}}

zyxa2 := reverse axyz2;
roots zyxa2;
% (same as above)

% 137)
rsxuv := {u^2+u*r+s*x*v,s+r^2,x-r-2,r+v,v^2-v-6};
roots rsxuv;
%{{r= - 3.0,s= - 9.0,u=1.5 + 4.97493718553*i,v=3.0,x=-1},
% {r= - 3.0,s= - 9.0,u=1.5 - 4.97493718553*i,v=3.0,x=-1},
% {r=2.0,s= - 4.0,u= - 1 + 5.56776436283*i,v= - 2.0,x=4.0},
% {r=2.0,s= - 4.0,u= - 1 - 5.56776436283*i,v= - 2.0,x=4.0}}

% 138)
rsxuv2 := {u^2+u*r+s*x,s+r,x-r-2,r+v,v^2-v-6};
roots rsxuv2;
%{{r= - 3.0,s=3.0,u= - 0.791287847478,v=3.0,x=-1},
% {r= - 3.0,s=3.0,u=3.79128784748,v=3.0,x=-1},
% {r=2.0,s= - 2.0,u= - 4.0,v= - 2.0,x=4.0},
% {r=2.0,s= - 2.0,u=2.0,v= - 2.0,x=4.0}}

% 139) combining both types of capabilities.
axyz3 := {a-1,a-1+x^2-x-2,a-1+y^2+y,x^3+y^3+z+5,y^2-x^2};
roots axyz3;
%{{a=1,x=-1,y=-1,z= - 3.0}}

% 140) spurious real and imag. parts had to be eliminated from z and y.
ayz := {a^2+a+1,z^2+a^3+3,y^3-z^2};
roots ayz;
%{{a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y= - 1.58740105197,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y= - 1.58740105197,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=-2.0*i},
% {a= - 0.5 + 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=-2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 - 1.374729637*i,z=2.0*i},
% {a= - 0.5 - 0.866025403784*i,y=0.793700525984 + 1.374729637*i,z=2.0*i}}

% 141) some small real or imaginary parts are not spurious; they are kept.
zz:= {x**9-9999x**2-0.01,y^2+y-x};
roots zz;
%{{x= - 3.35839794887 + 1.61731917877*i,y= - 0.944735689647 -
%  1.81829254591*i},
% {x= - 3.35839794887 - 1.61731917877*i,y= - 0.944735689647 +
%  1.81829254591*i},
% {x= - 3.35839794887 + 1.61731917877*i,y= - 0.0552643103532 +
%  1.81829254591*i},
% {x= - 3.35839794887 - 1.61731917877*i,y= - 0.0552643103532 -
%  1.81829254591*i},
% {x= - 0.829455794538 + 3.6340832074*i,y= - 1.74509731832 -
%  1.45935709359*i},
% {x= - 0.829455794538 - 3.6340832074*i,y= - 1.74509731832 +
%  1.45935709359*i},
% {x= - 0.829455794538 + 3.6340832074*i,y=0.745097318317 +
%  1.45935709359*i},
% {x= - 0.829455794538 - 3.6340832074*i,y=0.745097318317 -
%  1.45935709359*i},
% {x=5.00250075018E-29 + 0.00100005000375*i,y= - 1.0000010001 -
%  0.00100004800346*i},
% {x=5.00250075018E-29 - 0.00100005000375*i,y= - 1.0000010001 +
%  0.00100004800346*i},
% {x=5.00250075018E-29 + 0.00100005000375*i,y=0.00000100009500904 +
%  0.00100004800346*i},
% {x=5.00250075018E-29 - 0.00100005000375*i,y=0.00000100009500904 -
%  0.00100004800346*i},
% {x=2.3240834909 + 2.91430845907*i,y= - 2.29755558063 -
%  0.810630973104*i},
% {x=2.3240834909 - 2.91430845907*i,y= - 2.29755558063 +
%  0.810630973104*i},
% {x=2.3240834909 + 2.91430845907*i,y=1.29755558063 + 0.810630973104*i},
% {x=2.3240834909 - 2.91430845907*i,y=1.29755558063 - 0.810630973104*i},
% {x=3.72754050502,y= - 2.49437722235},
% {x=3.72754050502,y=1.49437722235}}$

% 142) if quotient, only numerator is used as polynomial, so this works.
vv := {x+1+1/x,y^2-x^3};
roots vv;
%{{x= - 0.5 + 0.866025403784*i,y=-1},{x= - 0.5 - 0.866025403784*i,y=-1},
% {x= - 0.5 + 0.866025403784*i,y=1},{x= - 0.5 - 0.866025403784*i,y=1}}

% 143) and this also works.
ii := {x^2-2x+3/r,r^3-5};
roots ii;
%{{r= - 0.854987973338 + 1.48088260968*i,x= - 0.464963274745 -
%  0.518567329174*i},
% {r= - 0.854987973338 - 1.48088260968*i,x= - 0.464963274745 +
%  0.518567329174*i},
% {r= - 0.854987973338 + 1.48088260968*i,x=2.46496327474 +
%  0.518567329174*i},
% {r= - 0.854987973338 - 1.48088260968*i,x=2.46496327474 -
%  0.518567329174*i},
% {r=1.70997594668,x=1 + 0.868568156754*i},
% {r=1.70997594668,x=1 - 0.868568156754*i}}

% 144)
bb := {y+x+3,x^2+r+s-3,x^3+r+s-7,r^2-r,s^2+3s+2};
roots bb;
%{{r=0,s=-1,x=2.0,y= - 5.0},{r=1,s= - 2.0,x=2.0,y= - 5.0}}

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/allroot.red0000644000175000017500000005160011526203062024024 0ustar  giovannigiovannimodule allroot; % Routines for solving real polynomials by iteration.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment   modules bfauxil, bfdoer, bfdoer2, complxp, rootaux, realroot,
 nrstroot and multroot needed also;

exports accuroot, allroots, gfnewton, gfrootfind, sizatom;

imports !!mfefix, a2gf, accupr, allout, automod, bfabs, bfdivide,
        bfeqp, bfleqp, bflessp, bfloat, bfloatem, bfmax, bfnewton,
        bfnump, bfnzp, bfp!:, bfprim, bfrlmult, bfrndem, bfsqrt,
        bftimes, bfzp, ceillog, cexpand, ckacc, ckpzro, cpxp, csep,
        cvt5, decimal2internal, deflate1, deflate1c, deflate2, divbf,
        domainp, dsply, ep!:, errorp, errorset!*, geq, getprec, gf2bf,
        gf2flt, gfdiff, gfdiffer, gfdot, gfeqp, gfexit, gfgetmin,
        gfim, gfminus, gfnewtset, gfplus, gfquotient, gfrl, gfrlmult,
        gfrootset, gfrsq, gfrtrnd, gfshift, gfsqfrf, gfsqfrf1, gfsqrt,
        gfstorval, gftimes, gfval, gfzerop, im2gf, lastpair,
        leq, lprim, minbnd1, minprec, mkquote, ncpxp, nwterr,
        nwterrfx, orgshift, pbfprint, pconstr, pflupd, pmsg, powerchk,
        rerror, restorefl, rl2gf, rlrtno, rlval, rootrnd, round!:mt,
        rrpwr, rxgfc, rxgfrl, rxrl, seteps, setflbf, setprec, smpart,
        sqrt, timbf, trmsg1, trmsg10, trmsg11, trmsg12, trmsg13,
        trmsg2, trmsg4, trmsg6, trmsg7, trmsg8, trmsg9, unshift,
        xnshift, xnsiz, xoshift;

fluid '(!*trroot !*bftag !*rootmsg !*multiroot !*powergcd !*hardtst
 !*nosturm !2loop !*noinvert);
switch trroot,rootmsg,multiroot,nosturm;
fluid '(!*xnlist !*pfsav !*xmax !*xmax2 !*gfp pgcd!# allrl!#);
fluid '(!*pcmp prec!# acc!# sprec!# !*xn eps!# accm!# !*xobf froot!#);
fluid '(nwmax!# lgmax!# !*xo !*keepimp !1rp !*zx1 !*mb tht!# prm!#
 !*bfsh !*strm mltr!# emsg!# lims!# incmsg!$ cpxt!# sh!# pfl!# acfl!#
 pfactor!# rprec!# rr!# ss!# prx!# nrst!$ !*xd !*zp intv!# pnn!#);
global '(bfone!* bfhalf!* bfz!* cpval!# polnix!$ polrem!$ lm!#);
nwmax!# := 200; lgmax!# := 100;
!*multiroot := !*powergcd := t;

symbolic procedure gfrootfind(p,nx);
% p is expected to be in the form returned by gfform, and
% nx should be in the form (rl . im).  returns nx in form (rl . im).
   begin scalar p1,p2,px,x1,x2,x3,x0,xd,nx,n1,gfqt,xz,rsc,njp,lgerr,
     pf,xn2,t1,t2,!*pfsav,pf0,pf1,pfn,lp,xlim,fg,fg2,ip,ip0,nxl2;
      integer n,r,m,ni; lm!# := 0;
      !*xnlist := emsg!# := !*xd := nil; pmsg pbfprint p; trmsg8();
      !*pcmp := cpxp p;
      if caar p>0 then
    <>;
      if (n := caar lastpair p)=1 then
         <
>;
      if nx and bfp!: car nx and not !*bftag then
         <
>;
      !*xo := rl2gf 0; seteps();
      lm!# := 2*nwterrfx(n,nil);
      if n<3 or !*hardtst or not xoshift(p,nx) then gfshift nil
         else <
>;
      nx := if not nx then rl2gf 0 else xnshift nx;
      p1 := gfdiff p;
      if gfzerop nx then xz := t;
      px := gfval(p,nx); bfmax p; !*zp := 0;
strt: pf := gfrsq px; trmsg13(n,nx,px);
      if bfzp pf then <>;
      x1 := gfval(p1,nx);
    % avoid bad starting point using minbnd1 for offset.
      if (!*zx1 := not !*mb and bfnzp gfrsq x1) then go to st2;
      !*mb := x2 := nil; x1 := bfrlmult(2.0,minbnd1(p,nx));
      if !*keepimp then
         <>
       else
         <>;
      if bflessp(gfrsq(p2 := gfval(p,x2)),gfrsq px) then
         <>;
 st1: xz := nil; go to strt;
 st2: n1 := n-1; p2 := gfdiff p1; xlim := bfrlmult(100.0,!*xmax2);
      ip := bfnzp gfim nx; nxl2 := {nx};
 lag: x3 := gfval(p2,nx);
      if not fg or bfzp gfrsq x1 then <>;
      gfqt := gfquotient(px,x1);
    % if newton is good enough, do it: it's cheaper.
      xn2 := gftimes(gftimes(gfqt,gfqt),
          gfrlmult(0.5,gfquotient(x3,x1)));
      t1 := bfabs gfdot(nx,xn2);
      t2 := bfabs bfrlmult(0.002,gfdot(nx,gfqt));
      pmsg if bfnzp t2 then gf2flt bfdivide(t1,t2) else "nwt_del->0";
      if bflessp(t1,t2) then go to ret;
lag0: x2 := gfrlmult(n1,
         gfdiffer(gfrlmult(n1,gftimes(x1,x1)),
           gfrlmult(n,gftimes(px,x3))));
      x2 := gfsqrt x2;
      x0 := nx; xd := gfplus(x1,x2); x2 := gfdiffer(x1,x2);
    % determine correct sign of x2 for Laguerre iteration.
      if bflessp(gfrsq xd,gfrsq x2) then xd := x2;
      if bfzp(x2 := gfrsq xd) then
         <>;
      if bflessp(bftimes(xlim,x2),bfrlmult(n*n,gfrsq px))
         then <>;
      xd := gfrlmult(-n,gfquotient(px,xd)); nx := gfplus(x0,xd);
    % constrain iteration to circle of radius !*xmax=maxbound p,
    % by scaling root to radius !*xmax/2.
      if bflessp(xn2 := gfrsq nx,!*xmax2) then go to lag2;
lag1: if rsc then go to lag2;
      pf1 := pf0 := fg2 := !*pfsav := !*xnlist := nil;
      if lp then
         <>;
           nx := if xz then rl2gf bfrlmult(0.5,!*xmax) else
              <>; rsc := t>>
      else if bflessp(xlim,xn2) then lp := t;
      pf := gfrsq(px := gfval(p,nx)); go to lag3;
lag2: if !*xnlist then
         for each y in !*xnlist do if nx=cdr y then njp := t;
      pf := gfrsq(px := gfval(p,nx));
    % test for minimum in envelope of pf, but not on first iter.
      if not fg then fg := t else <>;
    % if root has just turned complex, allow to settle.
      ip0 := ip; ip := bfnzp gfim nx;
      if ip and not ip0 then
         <>;
      pfn := pflupd pf;
      if pf1 then
         <> else
            <> >>;
      if xz then xz := nil else gfstorval(pf,nx);
      pmsg mapcar(!*pfsav,function gf2flt);
lag3: trmsg2('lag,nx,px); r := r+1; ni := ni+1;
      if (xd := gfexit(pf,nx,x0,'lag))=t then go to ret0
        % m logic delays this exit to allow settling.
         else if xd and (m := m+1) > 5
         then
            <2 then <> >>
         else if njp then go to newt;
      if not xd then m := 0;
     % this logic looks for loops of length 2 or lag limit exceeded.
      if ni>5 and gfeqp(car nxl2,nx) or (lgerr := (r>lgmax!#+lm!#)) then
        <> else
        if length(nxl2 := nconc(nxl2,{nx})) > 2 then nxl2 := cdr nxl2;
      x1 := gfval(p1,nx); go to lag;
ret1: nx := unshift nx; go to ret2;
newt: nx := gfgetmin();
 ret: return gfnewt2(p,p1,nx,4);
ret0: nx := unshift nx;
ret2: !*xnlist := nil; dsply nx; return !*xn := nx end;

symbolic procedure pshift p;
   orgshift(p,if cpxp p then !*xo else gfrl !*xo);

symbolic procedure gfnewton(p,nx,k);
   <
>;

symbolic procedure gfnewt2(p,p1,nx,kmax);
   begin scalar pf0,pf,k,xk,loop,x0,x1,xd,px,rl; integer m,tht!#;
      !*xnlist := emsg!# := !*xd := nil; pmsg pbfprint p; trmsg8();
      if (rl := bfzp gfim nx) and ncpxp p then
         <>;
      seteps(); !*zp := lm!# := 0;
      lm!# := nwterrfx(caar lastpair p,t);
      if gfzerop(px := gfval(p,nx)) then
         <>;
      gfstorval(gfrsq px,nx);
 ne0: x0 := nx;
      if gfzerop(x1 := gfval(p1,nx)) then
         <>;
      nx := gfdiffer(nx,gfquotient(px,x1)); pf0 := pf;
      for each y in !*xnlist do if nx=cdr y then loop := t;
      gfstorval(pf := gfrsq(px := gfval(p,nx)),nx);
      pmsg list gf2flt pf;
    % test for loop, but not on first iteration.
      if pf0 and bfleqp(pf0,pf) then
         <> >>;
      trmsg2(if loop then 'loop else 'nwt,nx,px);
      if (xd := gfexit(pf,nx,x0,'nwt)) then
            <0 then <> >>;
      if not loop then go to nlp;
    % next section updates loop variables.
      if k then <>
         else <>;
      if k>=kmax then
         <>;
 nlp: nwterr(m := m+1); go to ne0;
 ret: nx := gfgetmin();trmsg7 nx;
ret1: nx := unshift nx;
ret2: !*xnlist := nil; dsply nx; return !*xn := nx end;

symbolic procedure accuroot(y,p,xo);  % p,xo,!*xn all bfloat
   begin scalar rprec,b,c,n,rl,x,pr0,ps,y0;
      ps := getprec(); rl := bfnump (y0 := y := gf2bf y); b := !*bftag;
      pr0 := minprec();
      !*xo := xo; !*bftag := t;
      if (n := caar lastpair p)<2 then
         <>;
      x := if rl then gfrl xnshift (y := rl2gf y) else xnshift y;
      if not(rprec := prreq(p,x,rl)) then <>;
      if not (allrl!# or rl) and (bfzp gfim y or bfzp gfrl y)
         then !*xd := 1;
      if rprec<=pr0 then
         <>;
      setprec rprec;
 bfp: y := if not rl and
            (rprec>=2*pr0 or bfzp gfim y or bfzp gfrl y)
         or !*xd then gfrootfind(p,y) else
            <>;
      if !*xd then <>;
 ret: if acfl!# then
         <>;
      prec!# := getprec();
      if rl or n<2 or not (c := smpart y) then go to r2;
      setprec(prec!# + 1);
      x := gfnewton(p,y := gf2bf !*xn,0);
      y := !*xn :=
         if c=t then
           if not !*pcmp and cvt5(gfrl y,gfrl x)
              and not cvt5(gfim y,gfim x)
             then rl2gf gfrl y else y
         else if cvt5(gfim y,gfim x) and not cvt5(gfrl y,gfrl x)
              then im2gf gfim y else y;
  r2: setprec ps;
      if not rl and
         (bfzp gfrl y and bfnzp gfrl y0
            or bfzp gfim y and bfnzp gfim y0)
        then acc!# := max(acc!#,accupr(p,if pgcd!# then p else !1rp,y));
  r3: y := if rl then rootrnd gfrl y else gfrtrnd y;
      trmsg12 y;
      setflbf b; !*xn := gf2bf !*xn;
      return y end;

symbolic procedure prreq(p,x,rl);
  % find required precision to find root at x in polynomial p.
   begin scalar p1,x1,rx;
      p1 := gfdiff pshift p;
      if rl and ncpxp p then
         <>
      else
         <>;
      return if bfzp x1 then nil else
        <> end;

symbolic procedure sizatom u;
   begin scalar c,x; c := !*complex; on complex;
     x := prepsq simp!* u;
     if not c then off complex;
     if x neq u then return x
       else rerror(roots,8,"non-numeric value") end;

symbolic procedure dsplyrtno m;
   (<< write "rootno. ",m; wrs n>> where n=wrs nil);

symbolic procedure allroots(p,p0); % p is always bfloated at this call.
Comment   With modifications for nosturm and offset iteration and root
    inversion.$
  % do the actual work of finding roots of p in appropriate environment.
   begin scalar q,n,n0,c,cc,cprq,rln,cpn,qf,ac,y,er,rl,z,mb,inc,prec,xo,
        pf,xof,qbf,sprec,b,red,sw,pfl!#,acfl,acfl!#,!*msg,prq,allrl!#,
        invp,invtd!*,pinv,!1rpinv,!1rp0,nmfg,p00,zi;
        integer req,npi,accm!#,prec!#,r15n,prm!#,k,rtn,invpb;
      prec := getprec(); polrem!$ := polnix!$ := nil; !*msg := t;
      ac := acc!#; n0 := caar lastpair p; pgcd!# := red := not p0;
      b := !*bftag; sprec := minprec(); invpb := n0/2;
      !*pcmp := cpxp p;
      if !*nosturm then req := nil else
         <0 then trmsg4 req>>;
     % req = .
     % rtn is the number of separate root computations - 1 = max number
     % of restarts required.
      rtn := (if !*pcmp or !*nosturm then n0 else (n0+req)/2) - 1;
     % save original values of p and !1rp.
      p00 := p; !1rp0 := !1rp;
     %don't bother with inv mechanism if n0<11 unless !*noinvert="test".
      if !*noinvert="test" or n0>10 and not !*noinvert then
         <> >>;
      go to st0;
 tlp: if invtd!* then go to abrt else % prevents looping through tlp.
         <>;
 inv: k := 0;
      if not pinv then
         <>;
     % toggle {p,!1rp,invp} from {p00,!1rp0,nil} to {pinv,!1rpinv,t}.
     % the first time only that invp is turned on, increase sprec.
      if (invp := not invp) then
         <
>
         else <
>;
     % increase precision the first time thru inv: when nmfb is off.
      if not nmfg and invpb neq 0 then
         <>;
strt: if prq and (k := k+1)>rtn then go to abrt; mb := nil;
      if (!*rootmsg or !*rootmsg) and not nmfg then
     (<>
       where ch=wrs nil);
 st0: n := n0; !*gfp := qbf := p; c := cc := pf := prq := nil;
      if not !*nosturm then
         <>;
      rln := cpn := prm!# := 0;
root: qf := mb := !*mb := nmfg := nil;
      if not !*nosturm then allrl!# := cpn = cprq;
      if b then <>;
      q := if errorp(q := errorset!*({'cflotem,mkquote qbf},nil))
         then <> else (qf := car q);
  r0: acc!# := ac; if not !*nosturm then !*keepimp := req-rln=0;
  r1: if !*rootmsg then dsplyrtno(1+n0-n);
      y := gfrootset(q,nil,b);
      if !2loop then <>;
      r15n := 0;
      acfl := acfl!# := pfl!# := nil;
      if n=n0 then
         <> >>;
      if not y then <>;
      if not (y := ckacc(qbf,if red then p0 else !1rp,gf2bf !*xn))
         then <>;
      if princreq(n,bfzp gfim y,sprec) then
        <2 then sw := sw+n0; go to fl>>;
 r15: if(r15n := r15n+1)>3 then go to abrt;
      if invp or n0>2 and n0>n then
         < ";
                    print_the_number gf2bf y; terpri()>>;
           y := if not pf or bfp!: car !*xn
             then gfnewtset(n0,p0,!*xn,xo,b)
             else gfnewtset(n0,pf,!*xn,xof,b);
           if not y then <> >>;
      if acfl then
         <>;
      if !*trroot
       then < ";print_the_number gf2bf y; terpri()>>;
      if gfzerop y then <>;
      if not (y := accuroot(!*xn,p0,xo)) then
            <>;
      rl := bfzp gfim y;
      if princreq(n,rl,sprec) then
        <3 then sw := sw+2; go to fl>>;
  r2: if not !*nosturm then
         (if rl then
            <req then
               <> >>
            else if cpn+1>cprq then
               <>);
      z := gf2bf(if rl then gfrl !*xn else !*xn); % set by lag or nwt.
      if not rl and not !*pcmp then
       <>;
      if c and member(y,c) then
         <>;
      if rl then rln := rln+1 else cpn := cpn+1;
      c := y . c; %mb := nil;
  Comment  If we are using the inverse polynomial, then we need to
    find roots at increased accuracy and precision, to allow for loss of
    accuracy in taking the inverse.  Gfrootfind always provides that
    additional accuracy in the unrounded root z (which is used for
    deflation), so it is a simple matter to invert the root before
    rounding.  When the rounding is done, using gfrtrnd, the binary
    bigfloat result is the output of gfrtrnd, and the decimal equivalent
is
    returned as the value of the global variable cpval!#. $
      if invp then
         <>;
      if not (rl or red or !*pcmp) then
         cpval!# := (car cpval!#) . (abs cadr cpval!#) . cddr cpval!#;
      cc := ((if red then if invp then zi else z else mkdn cpval!#)
                  . acc!#) . cc;
     % the output list cc will be either z or :dn: objects, so
     % output functions will have to be clever!
     % c is rounded roots list used in testing for equal roots.
      if !*trroot then terpri();
     % firstroot computes first root found only. It could be wrong.
      if froot!# then goto ret;
    % new logic does all deflation in bfloat for greater accuracy.
      z := gf2bf z; q := bfloatem q;
      if (rl or !*pcmp) and (n := n-1)>0 and
         (q := cdr(if rl then deflate1(q,z) else deflate1c(q,z)))
         or (n := n-2)>0 and (q := deflate2(q,z)) then
            <>;
 ret: setprec max(prec,(acc!# := ac)+2);
      setflbf b; return cexpand cc;
incr: lprim incmsg!$; polnix!$ := q;
      if mb then go to tlp
         else if !*zx1 then
            <>;
inc0: if (npi := npi+1)<=3 then go to inc1;
abrt: lprim list("root finding aborted. Deflate degree = ",n);
      lprim list("poly = ",q); terpri();
      if n0>n then polrem!$ := q; go to ret;
inc1: inc := max(n0,sprec/2);
      setprec(sprec := max(sprec+inc,2+2*acc!#)); trmsg9 sprec;
      if b then go to strt;
  fl: p := p0; xo := !*xo := gf2bf xo;
      b := !*bftag := t; !1rp := bfloatem !1rp;
      if er then <>;
      acfl := t;
      if sw then
     % precision has increased: backup point depends on n.
         <> >>;
      go to strt end;

symbolic procedure princreq(n,rl,sprec);
   (n>2 or (rl or !*pcmp) and n>1) and min(prec!#,2*(accm!#+1))>sprec;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/roots.tex0000644000175000017500000004051111526203062023543 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{The REDUCE Root Finding Package \\ Mod 1.94, 28 May 1993}
\date{}
\author {Stanley L. Kameny \\ E-mail: valley!stan@rand.org}
\begin{document}
\maketitle
\index{root finding} \index{ROOTS package}

\section{Introduction}

The root finding package is designed so that it can be used as an
independent package, or it can be integrated with and called by {\tt
SOLVE}. \index{SOLVE package ! with ROOTS package} This document describes
the package in its independent use.  It can be used to find some or all of
the roots of univariate polynomials with real or complex coefficients, to
the accuracy specified by the user.

\section{Root Finding Strategies}

For all polynomials handled by the root finding package, strategies of
factoring are employed where possible to reduce the amount of required
work.  These include square-free factoring and separation of complex
polynomials into a product of a polynomial with real coefficients and one
with complex coefficients.  Whenever these succeed, the resulting smaller
polynomials are solved separately, except that the root accuracy takes
into account the possibility of close roots on different branches.  One
other strategy used where applicable is the powergcd method of reducing
the powers of the initial polynomial by a common factor, and deriving the
roots in two stages, as roots of the reduced power polynomial.  Again
here, the possibility of close roots on different branches is taken into
account.

\section{Top Level Functions}

The top level functions can be called either as symbolic operators from
algebraic mode, or they can be called directly from symbolic mode with
symbolic mode arguments.  Outputs are expressed in forms that print out
correctly in algebraic mode.


\subsection{Functions that refer to real roots only}

Three top level functions refer only to real roots.  Each of these
functions can receive 1, 2 or 3 arguments.

The first argument is the polynomial p, that can be complex and can
have multiple or zero roots.  If arg2 and arg3 are not present, all real
roots are found.  If the additional arguments are present, they restrict
the region of consideration.
                                                    
\begin{itemize}
\item If arguments are (p,arg2) then
Arg2 must be POSITIVE or NEGATIVE.  If arg2=NEGATIVE then only
negative roots of p are included; if arg2=POSITIVE then only positive
roots of p are included. Zero roots are excluded.

\item If arguments are (p,arg2,arg3) then
\ttindex{EXCLUDE} \ttindex{POSITIVE} \ttindex{NEGATIVE} \ttindex{INFINITY}
Arg2 and Arg3 must be r (a real number) or  EXCLUDE r,  or a member of
the list POSITIVE, NEGATIVE, INFINITY, -INFINITY.  EXCLUDE r causes the
value r to be excluded from the region.  The order of the sequence
arg2, arg3 is unimportant.  Assuming that arg2 $\leq$ arg3 when both are
numeric, then

\begin{tabular}{l c l}
\{-INFINITY,INFINITY\} & is equivalent to & \{\} represents all roots; \\
\{arg2,NEGATIVE\} & represents & $-\infty < r < arg2$; \\
\{arg2,POSITIVE\} & represents & $arg2 < r < \infty$;
\end{tabular}

In each of the following, replacing an {\em arg} with EXCLUDE {\em arg}
converts the corresponding inclusive $\leq$ to the exclusive $<$

\begin{tabular}{l c l}
\{arg2,-INFINITY\} & represents & $-\infty < r \leq arg2$; \\
\{arg2,INFINITY\} & represents & $arg2 \leq r < \infty$; \\
\{arg2,arg3\} & represents & $arg2 \leq r \leq arg3$;
\end{tabular}

\item If zero is in the interval the zero root is included.
\end{itemize}

\begin{description}
\ttindex{REALROOTS} \index{Sturm Sequences}
\item[REALROOTS] This function finds the real roots of the polynomial p,
using the REALROOT package to isolate real roots by the method of Sturm
sequences, then polishing the root to the desired accuracy.  Precision
of computation is guaranteed to be sufficient to separate all real roots
in the specified region.  (cf. MULTIROOT for treatment of multiple
roots.)

\ttindex{ISOLATER}
\item[ISOLATER] This function produces a list of rational intervals, each
containing a single real root of the polynomial p, within the specified
region, but does not find the roots.

\ttindex{RLROOTNO}
\item[RLROOTNO] This function computes the number of real roots of p in
the specified region, but does not find the roots.
\end{description}

\subsection{Functions that return both real and complex roots}

\begin{description}
\ttindex{ROOTS}
\item[ROOTS p;] This is the main top level function of the roots package.
It will find all roots, real and complex, of the polynomial p to an
accuracy that is sufficient to separate them and which is a minimum of 6
decimal places.  The value returned by ROOTS is a
list of equations for all roots.  In addition, ROOTS stores separate lists
of real roots and complex roots in the global variables ROOTSREAL and
ROOTSCOMPLEX. \ttindex{ROOTSREAL} \ttindex{ROOTSCOMPLEX}

The order of root discovery by ROOTS is highly variable from system to
system, depending upon very subtle arithmetic differences during the
computation.  In order to make it easier to compare results obtained on
different computers, the output of ROOTS is sorted into a standard order:
a root with smaller real part precedes a root with larger real part; roots
with identical real parts are sorted so that larger imaginary part
precedes smaller imaginary part. (This is done so that for complex pairs,
the positive imaginary part is seen first.)

However, when a polynomial has been factored (by square-free factoring or
by separation into real and complex factors) then the root sorting is
applied to each factor separately.  This makes the final resulting order
less obvious.  However it is consistent from system to system.

\ttindex{ROOTS\_AT\_PREC}
\item[ROOTS\_AT\_PREC p;] Same as ROOTS except that roots values are
returned to a minimum of the number of decimal places equal to the current
system precision.

\ttindex{ROOT\_VAL}
\item[ROOT\_VAL p;] Same as ROOTS\_AT\_PREC, except that instead of
returning a list of equations for the roots, a list of the root value is
returned.  This is the function that SOLVE calls.

\ttindex{NEARESTROOT}
\item[NEARESTROOT(p,s);] This top level function uses an iterative method
to find the root to which the method converges given the initial starting
origin s, which can be complex.  If there are several roots in the
vicinity of s and s is not significantly closer to one root than it is to
all others, the convergence could arrive at a root that is not truly the
nearest root.  This function should therefore be used only when the user
is certain that there is only one root in the immediate vicinity of the
starting point s.

\ttindex{FIRSTROOT}
\item[FIRSTROOT p;] ROOTS is called, but only the first root determined by
ROOTS is computed.  Note that this is not in general the first root that
would be listed in ROOTS output, since the ROOTS outputs are sorted into
a canonical order.  Also, in some difficult root finding cases, the first
root computed might be incorrect.
\end{description}


\subsection{Other top level functions}

\begin{description}
\ttindex{GETROOT} \ttindex{ROOTS} \ttindex{REALROOTS} \ttindex{NEARESTROOTS}
\item[GETROOT(n,rr);] If rr has the form of the output of ROOTS, REALROOTS,
or NEARESTROOTS; GETROOT returns the rational, real, or complex value of
the root equation.  An error occurs if $n<1$ or $n>$ the number of roots in
rr.

\ttindex{MKPOLY}
\item[MKPOLY rr;] This function can be used to reconstruct a polynomial
whose root equation list is rr and whose denominator is 1.  Thus one can
verify that if $rr := ROOTS~p$, and $rr1 := ROOTS~MKPOLY~rr$, then
$rr1 = rr$. (This will be true if {\tt MULTIROOT} and {\tt RATROOT} are ON,
and {\tt ROUNDED} is off.)
However, $MKPOLY~rr - NUM~p = 0$ will be true if and only if all roots of p
have been computed exactly.

\end{description}

\subsection{Functions available for diagnostic or instructional use only}

\begin{description}
\ttindex{GFNEWT}
\item[GFNEWT(p,r,cpx);] This function will do a single pass through the
function GFNEWTON for polynomial p and root r.  If cpx=T, then any
complex part of the root will be kept, no matter how small.

\ttindex{GFROOT}
\item[GFROOT(p,r,cpx);] This function will do a single pass through the
function GFROOTFIND for polynomial p and root r.  If cpx=T, then any
complex part of the root will be kept, no matter how small.
\end{description}
\section{Switches Used in Input}

The input of polynomials in algebraic mode is sensitive to the switches
{\tt COMPLEX}, {\tt ROUNDED}, and {\tt ADJPREC}.  The correct choice of
input method is important since incorrect choices will result in
undesirable truncation or rounding of the input coefficients.

Truncation or rounding may occur if {\tt ROUNDED} is on and
one of the following is true:

\begin{enumerate}
\item a coefficient is entered in floating point form or rational form.
\item {\tt COMPLEX} is on and a coefficient is imaginary or complex.
\end{enumerate}

Therefore, to avoid undesirable truncation or rounding, then:

\begin{enumerate}
\item {\tt ROUNDED} should be off and input should be
in integer or rational form; or
\item {\tt ROUNDED} can be on if it is acceptable to truncate or round
input to the current value of system precision; or both {\tt ROUNDED} and
{\tt ADJPREC} can be on, in which case system precision will be adjusted
to accommodate the largest coefficient which is input; or \item if the
input contains complex coefficients with very different magnitude for the
real and imaginary parts, then all three switches {\tt ROUNDED}, {\tt
ADJPREC} and {\tt COMPLEX} must be on.
\end{enumerate}

\begin{description}
\item[integer and complex modes] (off {\tt ROUNDED}) any real
polynomial can be input using integer coefficients of any size; integer or
rational coefficients can be used to input any real or complex polynomial,
independent of the setting of the switch {\tt COMPLEX}.  These are the most
versatile input modes, since any real or complex polynomial can be input
exactly.

\item[modes rounded and complex-rounded] (on {\tt ROUNDED}) polynomials can be 
input using
integer coefficients of any size.  Floating point coefficients will be
truncated or rounded, to a size dependent upon the system.  If complex
is on, real coefficients can be input to any precision using integer
form, but coefficients of imaginary parts of complex coefficients will
be rounded or truncated.
\end{description}

\section{Internal and Output Use of Switches}

The REDUCE arithmetic mode switches {\tt ROUNDED} and {\tt COMPLEX}
control the behavior of the root finding package.
These switches are returned in the same state in which they were set
initially, (barring catastrophic error).

\begin{description}
\ttindex{COMPLEX}
\item[COMPLEX] The root finding package controls the switch {\tt COMPLEX}
internally, turning the switch on if it is processing a complex
polynomial.
For a polynomial with real coefficients, the
\ttindex{NEARESTROOT}
starting point argument for NEARESTROOT can be given in algebraic mode in
complex form as rl + im * I and will be handled correctly, independent of
the setting of the switch {\tt COMPLEX.} Complex roots will be computed
and printed correctly regardless of the setting of the switch {\tt
COMPLEX}.  However, if {\tt COMPLEX} is off, the imaginary part will print
out ahead of the real part, while the reverse order will be obtained if
COMPLEX is on.

\ttindex{ROUNDED}
\item[ROUNDED] The
root finding package performs computations using the arithmetic mode that
is required at the time, which may be integer, Gaussian integer, rounded,
or complex rounded.  The switch {\tt BFTAG} is used internally to govern
the mode of computation and precision is adjusted whenever necessary.  The
initial position of switches {\tt ROUNDED} and {\tt COMPLEX} are ignored.
At output, these switches will emerge in their initial positions.
\end{description}

\section{Root Package Switches}

Note: switches {\tt AUTOMODE}, {\tt ISOROOT} and {\tt ACCROOT}, present in
earlier versions, have been eliminated.

\begin{description}
\ttindex{RATROOT}
\item[RATROOT] (Default OFF) If {\tt RATROOT} is on all root equations are
output in rational form.  Assuming that the mode is {\tt COMPLEX} (i.e.
{\tt ROUNDED} is off,) the root equations are
guaranteed to be able to be input into REDUCE without truncation or
rounding errors. (Cf. the function MKPOLY described above.)

\ttindex{MULTIROOT}
\item[MULTIROOT] (Default ON) Whenever the polynomial has complex
coefficients or has real coefficients and has multiple roots, as
\ttindex{SQFRF} determined by the Sturm function, the function {\tt SQFRF}
is called automatically to factor the polynomial into square-free factors.
If {\tt MULTIROOT} is on, the multiplicity of the roots will be indicated
in the output of ROOTS or REALROOTS by printing the root output
repeatedly, according to its multiplicity.  If {\tt MULTIROOT} is off,
each root will be printed once, and all roots should be normally be
distinct. (Two identical roots should not appear.  If the initial
precision of the computation or the accuracy of the output was
insufficient to separate two closely-spaced roots, the program attempts to
increase accuracy and/or precision if it detects equal roots.  If,
however, the initial accuracy specified was too low, and it was not
possible to separate the roots, the program will abort.)

\index{tracing ! ROOTS package}
\ttindex{TRROOT}
\item[TRROOT] (Default OFF) If switch {\tt TRROOT} is on, trace messages
are printed out during the course of root determination, to show the
progress of solution.

\ttindex{ROOTMSG} \item[ROOTMSG] (Default OFF) If switch
{\tt ROOTMSG} is on in addition to switch {\tt TRROOT,} additional
messages are printed out to aid in following the progress of Laguerre and
Newton complex iteration.  These messages are intended for debugging use
primarily.


\end{description}


\section{Operational Parameters and Parameter Setting.}

\begin{description}                 
\ttindex{ROOTACC\#}
\item[ROOTACC\#] (Default 6) This parameter can be set using the function
ROOTACC n; which causes {\tt ROOTACC\#} to be set to MAX(n,6).  If {\tt
ACCROOT} is on, roots will be determined to a minimum of {\tt ROOT\-ACC\#}
significant places. (If roots are closely spaced, a higher number of
significant places is computed where needed.)

\ttindex{system precision}
\item[system precision] The roots package, during its operation, will
change the value of system precision but will restore the original value
of system precision at termination except that the value of system
precision is increased if necessary to allow the full roots output to be
printed.

\ttindex{PRECISION}
\item[PRECISION n;] If the user sets system precision, using the command
PRECISION n; then the effect is to increase the system precision to n, and
to have the same effect on ROOTS as ROOTACC n; ie. roots will now be
printed with minimum accuracy n.  The original conditions can then be
restored by using the command PRECISION RESET; or PRECISION NIL;.

\ttindex{ROOTPREC}
\item[ROOTPREC n;] The roots package normally sets the computation mode and
precision automatically.  However, if ROOTPREC n; is
called and $n$ is greater than the initial system precision then all root
computation will be done initially using a minimum system precision n.
Automatic operation can be restored by input of ROOTPREC 0;.
\end{description}


\section{Avoiding truncation of polynomials on input}

The roots package will not internally truncate polynomials.  However, it
is possible that a polynomial can be truncated by input reading functions
of the embedding lisp system, particularly when input is given in floating
point (rounded) format.

To avoid any difficulties, input can be done in integer or Gaussian
integer format, or mixed, with integers or rationals used to represent
quantities of high precision. There are many examples of this in the
test package.  It is usually best to let the roots package
determine the precision needed to compute roots.

The number of digits that can be safely represented in floating point in
the lisp system are contained in the global variable {\tt !!NFPD}.
Similarly, the maximum number of significant figures in floating point
output are contained in the global variable {\tt !!FLIM}.  The roots
package computes these values, which are needed to control the logic of
the program. \ttindex{"!"!FLIM} \ttindex{"!"!NFPD}

The values of intermediate root iterations (that are printed when {\tt
TRROOT} is on) are given in bigfloat format even when the actual values
are computed in floating point.  This avoids intrusive rounding of root
printout.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/realroot.red0000644000175000017500000003657711526203062024217 0ustar  giovannigiovannimodule realroot; % Routines for finding real roots of polynomials,
                 % using Sturm series, together with iteration.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment   modules bfauxil, bfdoer, bfdoer2, complxp, allroot and rootaux
 needed also;

exports accupr1, bfnewton, isolatep, schinf, schplus, sgn1, sturm,
        sturm0, uniroots;

imports !!mfefix, abs!:, accupr, accuroot, allroots, automod, bdstest,
        bfabs, bfdivide, bfeqp, bfleqp, bfloat, bfloatem, bfmax,
        bfminus, bfminusp, bfplus, bfrlmult, bfsgn, bfsqrt, bfzp,
        ceillog, ckpzro, cpxp, csep, difbf, divbf,
        domainp, dsply, eqcar, equal!:, errach, geq, getprec, gfdiff,
        gffinitr, gfgetmin, gfrl, gfrootfind, gfsqfrf, gfstorval,
        greaterp!:, lastpair, leq, lprim, minbnd1, minprec, mk!*sq,
        multroot,
        neq, nwterr, nwterrfx, outecho, pconstr, plubf, powerchk,
        r2bf, r2flbf, ratdif, ratleqp, ratlessp, ratmax, ratmean,
        ratmin, ratminus, ratplus, realrat, rerror, rl2gf, rlval,
        round!:mt, sch, schnok, setprec, sgn, stuffr, sturm1, timbf,
        trmsg1, trmsg10, trmsg2, trmsg3, trmsg4, trmsg6, trmsg7,
        trmsg8, xclp;


global '(!!nfpd !!flim bfhalf!* max!-acc!-incr bfone!* rlval!#);

fluid '(!*gfp !*xnlist !*intp tht!# !*strm lims!# mltr!# pfactor!#
 prec!# !*rvar acc!# !*xo !1rp accm!# !*xn intv!# sh!# rprec!# rlrt!#
 prm!# pfl!# acfl!# pgcd!#);

fluid '(!*trroot !*bftag !*compxroots !*msg);

flag('(positive negative infinity),'reserved);
global '(limlst!# lm!#);
limlst!# := '(positive negative infinity (minus infinity));

symbolic procedure isolatep p;
   begin scalar n,q,zr,a,b,c,ril,va,vb,vc,v0,w,elem,l,u,i,j,lr,ur,
         xcli,xclj,ol,ou;
      if null sturm p or schinf(-1)-schinf 1=0 then go to ret;
    % limits +/-1.0001*maxbound p to give working room for rootfind.
      n := car(q := car !*strm);
      l := ratminus(u := realrat bfrlmult(1.0001,bfmax p));
      if (zr := l=u) and (lr := l) and not lims!# then go to zrt;
      if lims!# then
         <>;
                   l := ratmax(l,i)>>;
              if j eq 'infty then xclj := t else
                 <>;
                   u := ratmin(u,j)>>;
              if zr then if ratlessp(u,l) then go to ret
                 else go to zrt;
              if sgn1(q,l)=0 then       % root at l.
                 <
    >;
              if l neq u and sgn1(q,u)=0 then  % root at u.
                 <> >>
           else if zr then go to ret else
              <> >>;  % positive roots.;
      n := (va := sch l+if lr then 1 else 0)-(vb := sch u);
      trmsg4(n);
      if n=0 then go to ret;
      if n=1 then ril := list list(l,u)
         else for j:=1:n do ril := nil . ril;
      v0 := vb+n-1;
      if lr then
         <>;
      if ur then
         <>;
      w := list list(l,u,va,vb);
      if n>1 then while w do
        <>;
               if va > vc+1 then w := list(a,c,va,vc) . w;
               if vb = vc-1 then <>;
               if vb < vc-1 then w := list(c,b,vc,vb) . w>> >>;
      ril := for each i in ril collect (car i) . cadr i;
 ret: return ril;
 zrt: return list (lr . lr) end;

symbolic procedure stuffrt(a,b,c,m,v0,va,vb,w,ril);
   begin scalar vcm,vcp;  % stuff root and update work.
      vcm := 1+(vcp := sch ratplus(c,m));
      stuffr(v0-vcp,list(c,c),ril);
      if va = vcm+1 then stuffr(v0-vcm,list(a,ratdif(c,m)),ril);
      if va > vcm+1 then w := list(a,ratdif(c,m),va,vcm) . w;
      if vb = vcp-1 then stuffr(v0-vb,list(ratplus(c,m),b),ril);
      if vb < vcp-1 then w := list(ratplus(c,m),b,vcp,vb) . w;
      return w end;

symbolic procedure offsetr(n,r);
   realrat if n=1 then 1 else minbnd1(!*gfp,mk!*sq r);

symbolic procedure sturm p;
   <>;
     if not atom p then sturm1(!*gfp := p)>>;

put('sturm,'psopfn,'sturm0);

symbolic procedure sturm0 p;
   <
    >;

symbolic procedure sgn1(p,r); if atom p then sgn p else
 % Evaluate sign of one sturm polynomial for rational r=(u . d)
   begin scalar m,c,u,d; u := car r; d := cdr r;
      c := 0; m := 1; p := cdr p;
      repeat <> until null(p := cdr p);
      return sgn c end;

symbolic procedure r2flimbf x;
   if acc!#<=!!flim then r2flbf x else r2bf x;

symbolic procedure rootfind(p,i);
  % finds real roots in either float or bigfloat modes.
  % p is in gfform. i is a pointer to a rational interval pair;
   begin scalar p1,p2,px,x1,x2,x3,x0,nx,xr,fg,n,s,sh;
      scalar xd,xe,qt,xnlist,pf,pf0; integer m,tht!#;
      n := caar lastpair p; !*xnlist := nil;
      if car i=cdr i then
         <>;
      xr := ratmean(car i,cdr i);
      if !*trroot then
         <>; trmsg8();
      if ratlessp(cdr i,car i) then
         errach "lx > hx ***error in roots package";
      movebds(i,xr,sh!# := sh := sgn1(!*intp,cdr i));
      p2 := gfdiff(p1 := gfdiff p);
lag0: if bndtst (px := rlval(p,nx := r2flbf xr)) then go to tht
         else if bfzp px then go to lg4;
 lag: % check for proper slope at nx.
      if bndtst (x1 := rlval(p1,nx))
         or (s := bfsgn x1) neq sh then go to tht;
     % if lag not converging, go to newt.
      pf := bfabs px; if pf0 and bfleqp(pf0,pf) then go to newt;
      gfstorval(pf,nx); x1 := bfabs x1;
      if bndtst (x3 := rlval(p2,nx)) then go to tht;
   % bigfloat computations: is newton cheaper?
      if fg and
         <>
              then go to newt;
    % check whether laguerre iteration will work.
      x2 := difbf(bfrlmult(n-1.0,timbf(x1,x1)),
           bfrlmult(n,timbf(px,x3)));
      if bfminusp x2 then go to tht;
   % nx has met all tests, so continue.
      x0 := nx;
      xd := divbf(bfrlmult(-n*s,px),
         plubf(x1,bfsqrt(bfrlmult(n-1,x2))));
      nx := plubf(x0,xd);
 lg3: fg := t;
      if ratlessp(xr := realrat nx,car i) or ratlessp(cdr i,xr)
         then go to tht;
      if bndtst (px := rlval(p,nx)) then go to tht;
      movebds(i,xr,sh); trmsg2 ('lag,nx,px);
      if bdstest i then go to ret;
      if bfzp px then go to lg4;
      if bfeqp(nx,x0) then <>;
      if xnlist and member(nx,xnlist) then go to newt;
      xnlist := nx . xnlist; pf0 := pf;
      if(m := m+1)<10 or
        <>
            then go to lag;
 tht: nx := tighten(i,p,pf,sh); m := 0;
      if !*xnlist then
         <>;
 lg4: trmsg1('lag,nx);
 ret: !*xnlist := nil; if not nx then trmsg10 'lag; go to ret2;
newt: nx := bfnewton(p,p1,gfgetmin(),i,4);
ret2: !*xn := rl2gf nx; return nx end;

global '(tentothetenth!*!*);

tentothetenth!*!* := normbf i2bf!: 10000000000;

symbolic procedure bndtst x;
  greaterp!: (abs!: x, tentothetenth!*!*);

symbolic procedure movebds(i,xr,sh);
   if sgn1(!*intp,xr)=sh then rplacd(i,xr) else rplaca(i,xr);

symbolic procedure tighten(i,p,pf,sh);
   begin scalar j,x0,nx,px,sn,x;
      nx := car i;
tht0: j := 4;
tht1: x0 := nx; nx := ratmean(car i,cdr i);
      if (sn := sgn1(!*intp,nx))=0 then
         <>;
      if 0=car ratdif(nx,x0) then
         <>;
      if sn=sh then rplacd(i,nx) else rplaca(i,nx);
      if (sn := bdstest i) then <>;
      if (j := j-1)>0 then go to tht1;
      if bndtst (px := rlval(p,x := r2flbf nx)) then
         <>;
      gfstorval(bfabs px,x);
      trmsg2('tht,x,px);
      if bfzp px then go to ret
         else if pf and bfleqp(pf,bfabs px) then go to tht0
         else return x;
 ret: !*xnlist := nil; return x end;

symbolic procedure rtsreal(p,s);
 % Finds real roots of univariate square-free real polynomial p, using
 % sturm series, isolater and rootfind.
   begin scalar acr,acs,n,q,r,x,y,!*strm,pr,apr,!*bftag,pfl!#,
        acfl!#,xout,x1;
      integer accn,accn1,accm!#,prec!#,prm!#; pr := getprec();
      !*bftag := rlrt!# := t; pgcd!# := not s;
      r := isolatep p; % r is a list of rational number pairs.
      if null r then go to ret;
      if (n := caar lastpair p)>1 then go to gr1;
      y := rootrnd gfrl gfrootfind(p,nil);
      if pfactor!# then
        <>;
     % note that rlval!# was set by the last operation of rootrnd.
      xout := {if s then (mkdn rlval!#) . acc!#
                 else if pfactor!# then y
                   else y . acc!# % this can't happen
                };
      if !*trroot then terpri(); go to ret;
 gr1: !*xo := rl2gf 0;
      q := r; acs := acc!#;
 lag: % increase accuracy for this root and the next root if current
      % accuracy is not sufficient for the interroot interval.
      if cdr q then  % no test if this is the last real root.
        <>;
      acc!# := max(acs,accn,accn1);
      accn := if accn1>acs then accn1 else 0;
      setprec max(rprec!#,acc!#+2);
      y := rootfind(p,intv!# := car q); apr := t;
      if null y then rerror(roots,8,"Realroots abort");
 acc: y := accuroot(gfrl !*xn,p,!*xo);
     % if acc!# is insufficient for this root, for any reason,
     % increase accuracy and tighten.
      if apr then
        <acc!# then acc!# := acr
            else if acr<=acc!# then <>;
          go to acc>>;
      xout := ((x1 := if s then mkdn rlval!# else y) . acc!#) . xout;
     % x is root list. Check for equal roots should fail!
      if x and x1=car x then rooterr x1;
      x := x1 . x;
      dsply y;
      acc!# := acs;
      if (q := cdr q) then <>;
 ret: setprec pr; return reverse xout end;

symbolic procedure lval x; if xclp x then cdr x else x;

symbolic procedure lpwr(l,m);
   if eqcar(l,'list) then 'list . lpwr(cdr l,m)
   else if atom l then l else ((car l)**m) . ((cdr l)**m);

symbolic procedure schnok r;
  %true if precision is inadequate to separate two adjacent real roots.
   (l neq h and (sch l neq sch r2flbf2r l or sch h neq sch r2flbf2r h))
   where l=caar r,h=cdar r;

symbolic procedure limchk x;
   <>>>;

symbolic procedure limchk1 y;
 if errorp(y := errorset!*({'a2rat,mkquote y},nil))
    then rerror(roots,5,"Real root function limits must be real")
 else car y;

symbolic procedure limchk2(a,b);
 <>
   where l = cddr limlst!#;

symbolic procedure limerr;
   rerror(roots,6,"Illegal region specification");

symbolic procedure ratv a; if xclp a then cdr a else a;

symbolic procedure a2rat x;
   if numberp x then x . 1
   else if atom x then limerr()
   else if eqcar(x,'quotient) then
     ((if numberp n then n
       else if eqcar(n,'minus) then - cadr n
       else rerror(roots,10,"illegal limit")) where n=cadr x) . caddr x
   else if car x eq '!:rn!: then cdr x
   else
    ((if car x memq domainlist!* and y then cdr(apply1(y,x))
       else limerr())
    where y=get(car x,'!:rn!:));

symbolic procedure rlrootno a;
   <>;

put('rlrootno,'psopfn,'rlrootno);

symbolic procedure realroots a;
   <>;

put('realroots,'psopfn,'realroots);

symbolic procedure isolater p;
   <>;

put('isolater,'psopfn,'isolater);

symbolic procedure mkratl l; for each a in l collect
   if member(a,limlst!#) then a else
   if eqcar(a,'list) then
      if member(a := cadr a,limlst!#) then a else mkxcl a
      else a;

symbolic procedure exclude x; {'list, x};

symbolic operator exclude;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/bfdoer.red0000644000175000017500000004523411526203062023617 0ustar  giovannigiovannimodule bfdoer; % routines for doing bfloat arithmetic, mixed float
               % and bf arithmetic, gf and gbf arithmetic, rational
               % arithmetic and fast polynomial manipulations and form
               % conversion.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment  support for allroot and realroot modules;

exports bfeqp, bfleqp, bfloatem, bfmin, bfsgn, cflotem,
        ckacc, deflate2, firstroot, gfconj, gfdiff, gfeqp, gfexit,
        gfnewt, gfnewtset, gfplusn, gfrlmult, gfroot, gfrootset,
        gftimesn, gfval, gtag, gzero, intdiff, isolater, listecho,
        maxbnd1, maxbound, minbnd1, minbound, mkratl, ncoeffs,
        nearestroot, powerchk, primp, primpn, r2flbf, ratdif,
        ratleqp, ratlessp, ratmax, ratmean, ratmin, ratminus, ratplus,
        realroots, rlrootno, rlrtno, rlval, root_val, rtreorder, sch,
        simpgi, univar, ungfform, unshift, xnshift;

imports a2gf, abs!:, accupr, accupr1, accuroot, automod, bf2flr, bfabs,
        bfinverse, bfloat, bfminus, bfnump, bfnzp, bfp!:, bfrlmult,
        bfsqrt, bfzp, cflot, ckprec, cpxp, cvt2, cvt5, difference!:,
        divbf, domainp, ep!:, eqcar, equal!:, errorp, errorset!*, exp,
        exptbf, gbfmult, gcdn, getprec, gf2bf, gfdiffer, gffinit,
        gffmult, gffplus, gfftimes, gfim, gfnewton, gfplus, gfrl,
        gfrsq, gfrtrnd, gftimes, gfzerop, grpbf, im2gf, infinityp,
        invbf, invpoly, isolatep, lastpair, leadatom, leq, lessp!:,
        limchk, log, make!:ibf, min!:, minus!:, minusp!:, mk!*sq,
        mkquote, mkxcl, msd!:, mt!:, ncpxp, neq, nrstroot, numr, off,
        on, orgshift, outmode, over, plubf, plus!:, preci!:, precision,
        r2bf, r2fl, realrat, rerror, restorefl, rl2gf, rlrtno2, rndpwr,
        rootrnd, roots, schinf, schplus, setflbf, setprec, sgn, sgn1,
        simp!*, sturm1, timbf, times!:, trmsg1, trmsg12, trmsg13,
        trmsg3, uniroots, univariatep;


fluid '(!*bftag !*pcmp !*rvar !*strm lims!# mltr!# emsg!# !*xo !*gfp
        !*powergcd pfl!# acfl!# accm!# froot!# !*backtrace);

fluid '(acc!# sprec!# pfactor!# rr!# ss!# !*xn !*zp !*xobf !*noeqns
        !*msg rootacc!# rootacc!#!#);

fluid '(iniprec!#);

global '(bfz!* bfone!* bfhalf!* bftwo!* prd!% log2 bfee!* !!ee);

bfee!* := bfloat !!ee;

symbolic smacro procedure dnp x; eqcar(x,'!:dn!:);

symbolic procedure bfleqp(a,b); if atom a then a<=b else not grpbf(a,b);

symbolic procedure bfeqp(a,b); if atom a then a=b else
   ((zerop ma and zerop mb or ep!: a=ep!: b and ma=mb)
    where ma=mt!: a,mb=mt!: b);

symbolic procedure bfsgn u;
   if atom u then sgn u else sgn mt!: u;

symbolic procedure bfmin(u,v);
   if atom u then min(u,v) else min!:(u,v);

symbolic procedure gfconj u; (car u) . (bfminus cdr u);

symbolic procedure gfrlmult(r,u); % multiplies real*gf or real*gbf.
   if atom car u then gffmult(r,u) else gbfmult(bfloat r,u);

symbolic procedure gfeqp(u,v); gfzerop gfdiffer(u,v);

symbolic procedure ncoeffs p;
    begin scalar n,q; integer d;
          for each i in p do
             <>;
               d := d+1; q := (cdr i) . q>>;
          return n . q end;

symbolic procedure rlval(p,r);
 % evaluate real polynomial for floating or bigfloat value.
   if atom p or atom car p then p
      else if bfzp r then (if caar p=0 then cdar p else r2flbf 0) else
   begin scalar c,bf; bf := bfp!: r;
         c := car (p := cdr ncoeffs p);
         for each i in cdr p do
            <>;
         return if bf then rndpwr c else c end;

symbolic smacro procedure sqr!: a; times!:(a,a);

symbolic procedure deflate2 (p,u);
 % deflate real bf polynomial by one pair of gbf roots.
 % no rounding is done.
    begin scalar q,n,b,c,f,g,h,j;
       b := times!:(bftwo!*,gfrl u);
       c := minus!: plus!:(sqr!: gfrl u,sqr!: gfim u);
       g := h := bfz!*; n := car(p := ncoeffs p)-1; p := cdr p;
       while n>0 do
          <>;
       return q end;

symbolic procedure primp p; if atom p then sgn p else
   begin integer d;
         for each y in p do d := gcdn(d,cdr y);
         return for each y in p collect (car y).(cdr y/d) end;

symbolic procedure primpn p;
   begin scalar n,g; n := car p; p := cdr p; g := 0;
         while p and car p=0 do <
    >;
         if n<0 then return 0 else if n=0 then return sgn car p;
         for each y in p do g := gcdn(y,g);
         return n . for each y in p collect y/g end;

symbolic procedure r2flbf u; if !*bftag then r2bf u else r2fl u;
 % translate any real number object to float or bigfloat.

symbolic procedure intdiff p;
   <>;

symbolic procedure ratminus r; (-car r) . (cdr r);

symbolic procedure ratdif(r,s); ratplusm(r,ratminus s,nil);

symbolic procedure ratplus(r,s); ratplusm(r,s,nil);

symbolic procedure ratmean(r,s); ratplusm(r,s,t);

symbolic procedure ratplusm(r,s,m);
 % computes sum or mean of two realrats.
   begin scalar ra,rd,sa,sd,a,d,g;
         ra := car r; rd := cdr r; sa := car s; sd := cdr s;
         if rd=sd then <> else
         <>;
         if m then d := d+d;
         if a=0 then return (0 . 1);
         g := gcdn(a,d); return (a/g) . (d/g) end;

symbolic procedure ratmin(a,b); if ratlessp(a,b) then a else b;

symbolic procedure ratmax(a,b); if ratlessp(a,b) then b else a;

symbolic procedure ratlessp(a,b); car ratdif(a,b)<0;

symbolic procedure ratleqp(a,b); car ratdif(a,b)<=0;

symbolic procedure listecho(l,n); if n<2 then l else
   begin scalar c; for each x in l do
         <>; return c end;

symbolic procedure bfloatem p; if p then
   (<>
   where cp=cpxp p);

symbolic procedure cflotem p;
   <>
   where cp=cpxp p;

symbolic procedure gfdiff p;
 % differentiates the gfform of real or complex polynomial.
   <>;

symbolic procedure gfval(p,x);
   <
     infinity") else p>>;

symbolic smacro procedure rndpwrxc(x,c);
   if atom gfrl x then c else (rndpwr gfrl c) . rndpwr gfim c;

symbolic procedure gfrval(p,x);
 % evaluate real polynomial for gf or gbf value x.
   if gfzerop x then rl2gf(if caar p=0 then cdar p else 0)
   else if bfzp gfim x then rl2gf rlval(p,gfrl x) else
   begin scalar c;
         c := rl2gf car (p := cdr ncoeffs p);
         for each i in cdr p do
            <>;
         return rndpwrxc(x,c) end;

symbolic procedure gfcval(p,x);
 % evaluate complex polynomial for gf or gbf value x.
   if gfzerop x then (if caar p=0 then cdar p else rl2gf 0) else
   begin scalar c;
         c := car (p := cdr ncoeffs p);
         for each i in cdr p do
            <>;
         return rndpwrxc(x,c) end;

symbolic procedure bfplusn(u,v); if atom u then u+v else plus!:(u,v);

symbolic procedure gfplusn(u,v);
   if atom gfrl u then gffplus(u,v) else
     (plus!:(gfrl u,gfrl v)) . plus!:(gfim u,gfim v);

symbolic procedure gftimesn(u,v);
   if atom gfrl u then gfftimes(u,v) else
     begin scalar ru,iu,rv,iv;
        ru := gfrl u; iu := gfim u; rv := gfrl v; iv := gfim v;
        return (difference!:(times!:(ru,rv),times!:(iu,iv))) .
           plus!:(times!:(ru,iv),times!:(iu,rv)) end;

symbolic procedure minbound (p,o);
 % estimate min root distance from origin o for polynomial p.
   <
    > where bf=!*bftag,acc!#=6;

symbolic operator maxbound,minbound;

symbolic procedure maxbound p;
  <
    >;

symbolic procedure maxbnd1 p;
 % maxbound of roots of real or complex float polynomial,
 % in floating point avoiding under/ and over/ flows.
   begin scalar nc,bf,m,pr;
      bf := !*bftag; pr := getprec();
      if atom (p:= gffinit p) then return nil;
      setprec 8; p := bfloatrd p;
      nc := ncpxp p; p := reverse p;
      !*bftag := bf;
      m := bfrlmult(2,maxbdbf(p,nc));
      setprec pr;
      return m end;

symbolic procedure minbnd1(p,org);
   begin scalar b,c; b := !*bftag;
         setflbf bfp!: if not bfnump(c := cdar p) then car c else c;
         org := a2gf org;
         if ncpxp p then if bfzp gfim org then org := gfrl org else
            p := for each r in p collect (car r) . rl2gf cdr r;
         p := bfinverse maxbnd1 invpoly orgshift(p,org);
         setflbf b; return p end;

symbolic procedure maxbdbf(p,nc);
   begin scalar an,al,m,mm,n;
   % selection of critical term uses bfloat arithmetic; final
   % computation uses float.
      n := car (an := car p);
      an := if nc then bfabs cdr an else bfsqrt gfrsq cdr an;
      while (p := cdr p) do
       <m then m := mm>>;
      m := fl2bfexp m;
      return m end;

symbolic procedure bfloatrd p;
   <>
   where cp=cpxp p;

symbolic procedure logrtn(x,n);
  % floating log of x**(1/n) using bfloat logic as boost.
  (y/n) where y=log(m/2.0**p)+(p+ep!: x)*log2
        where p=msd!: m-1 where m=mt!: x;

symbolic procedure fl2bfexp m; if !*bftag then expfl2bf m else exp m;

symbolic procedure expfl2bf m; if m<0 then invbf expfl2bf(-m) else
   exptbf(bfee!*,mi,bfloat exp mf) where mf=m-mi where mi=fix m;

symbolic procedure ungfform p;
   begin scalar r;
      if caar p=0 then <>;
      for each i in p do
        if bfnzp cdr i then r := (((!*rvar or 'x) . car i) . cdr i) . r;
      return r end;

symbolic procedure gtag c; if fixp c then '!:gi!: else '!:cr!:;

symbolic procedure gzero c;
   if fixp c then 0 else if floatp c then 0.0 else bfz!*;

symbolic procedure simpgi u; ('!:gi!: . u) ./ 1;

put('!:gi!:,'simpfn,'simpgi);

symbolic procedure rlrtno p;
   <>;

symbolic procedure roots p;
   <> where froot!#=nil;

symbolic procedure firstroot p;
   <> where froot!#=t;

symbolic procedure root_val x;
  % Produces list of root values at system precision (or greater if
  % required to separate roots.)
   roots x
      where rootacc!#!#=p,iniprec!#=p where !*msg=nil,p=precision 0;

for each n in '(roots firstroot root_val) do put(n,'psopfn,n);

symbolic procedure outril p;
   'list . for each i in p collect 'list . {mk!*sq car i,mk!*sq cdr i};

symbolic procedure gfrootset(p,r,b);
 if errorp
   (r := errorset!*({'gfrootfind,mkquote p,mkquote r},!*backtrace))
    then gfsetmsg(r,b,'gfrootfind) else car r;

symbolic procedure gfsetmsg(r,b,n);
   if (r := emsg!#) then <>
   else if b
    then rerror(roots,2,list(n,": error in bfloat computation"))
   else nil;

symbolic procedure sch z;
   begin scalar v,v1; integer r;
         v := sgn1(car !*strm,z);
         if v=0 and mltr!# then return schplus z;
         for each q in cdr !*strm do
            <>;
         return r end;

symbolic procedure gfnewtset(n,p,y,xo,b);
   begin scalar y1,b;
      if (b := !*bftag) then go to ret;
      if not atom car y then go to mbf;
      if not errorp (y1 := errorset!*
        ({'gfns1,n,mkquote p,mkquote y,mkquote xo},!*backtrace))
         then return car y1;
 mbf: gfsetmsg(y1,b,'gfnewton);
      p := !*gfp; !*xo := xo := gf2bf xo; y := gf2bf y; !*bftag := t;
 ret: y := gfns1(n,p,y,xo); !*bftag := b; return y end;

symbolic procedure gfns1(n,p,y,xo);
  <>;

symbolic procedure gfnewt args;
   nrstroot(gffinit p,r,if cpx then 0 else t)
    where rootacc!#!#=pr,rprec!#=pr
    where p=car args,r=cadr args,cpx=caddr args,pr=precision 0;
   % direct call to gfnewton. If cpx then retain imaginary part, no
   % matter how small (but either p or r must be complex).

symbolic procedure gfroot args;
   nrstroot(gffinit p,r,list if cpx then 0 else t)
    where rootacc!#!#=pr,rprec!#=pr
    where p=car args,r=cadr args,cpx=caddr args,pr=precision 0;
   % direct call to gfrootfind. If cpx then retain imaginary part, no
   % matter how small (but precision will have to be high enough).

symbolic(for each n in '(gfnewt gfroot) do put(n,'psopfn,n));

symbolic procedure univar y;
   (if domainp (y := numr p) then 0 else
    if univariatep y or
       <> or
       <> then y)
    where p=simp!* y,!*msg=nil;

symbolic procedure ckacc(q,p,r);   % p,q,r,!*xo,!*xn all bfloat
   if not(r and caar lastpair p>1 and (rr!#>1 or pfactor!#)) then r
   else if caar lastpair q=1 then
      <> else
   begin scalar ac,rl,s,nx; rl := bfzp gfim r;
      r := <>;
loop: ac := accupr(q,p,r);
      if pfl!# then
         <0 then
              <>;
           acc!# := ac;
           r := if rl then rootrnd gfrl r else gfrtrnd r;
           trmsg12 r;
           return r>>
      else if ac>acc!# then <>;
      if s or ss!#=0 then return r;
      s := t; acc!# := acc!# + ss!#:
 gfr: nx := r; r := <>;
      if gfeqp(nx,r)
         or s and not(rl and not(rl := bfzp gfim r))
         then return r else go to loop end;

symbolic procedure gfadjust x; if !*pcmp or not !*bftag
   or not lessp!:(abs!: gfrl x,sprec!#) then x else im2gf gfim x;

symbolic procedure xnshift x;
   if gfzerop !*xo then x else gfadjust gfdiffer(x,!*xo);

symbolic procedure unshift x;
   if gfzerop !*xo then x else gfadjust gfplus(x,!*xo);

symbolic procedure gfexit(pf,nx,x0,m);
 if bfzp pf then <>
   else if gfeqp(unshift nx,unshift x0) then <> else
   begin scalar rl,r1,r0,im,i1,i0;
      r1 := bfloat(rl := gfrl(nx := unshift nx));
      i1 := bfloat(im := gfim nx);
      r0 := bfloat gfrl(x0 := unshift x0); i0 := bfloat gfim x0;
     return
       if eqprts(r1,r0) then
          if mt!: i1*mt!: i0<0 then rl2gf rl
          else if cvt2(i1,i0) then zptst rl2gf rl else nil
       else if eqprts(i1,i0) then
          if mt!: r1*mt!: r0<0 then im2gf im
          else if cvt2(r1,r0) then zptst im2gf im else nil
       else <>  end;

symbolic procedure zptst x;
   if !*zp>4 then x else <>;

symbolic procedure eqprts(a,b); bfnzp a and (equal!:(a,b) or cvt5(a,b));

symbolic procedure powerchk p;
  % reduce degree of polynomial if powergcd > 1.
   <2 then
        for each x in cdr p do g := gcdn(g,car x);
     if g>1 then g . for each x in p collect (car x/g) . cdr x>>
   where g=0; % returns (powergcd . ) or nil.

symbolic procedure rtreorder cc; if cc then
   if dnp caar cc or not bfnump caar cc and dnp caaar cc then
    (<> where p=0)
   else sort(cc,function bfnafterp);

symbolic procedure bfnafterp(a,b);
  (if bfnump ca then
     if bfnump cb then rd!:minusp rd!:difference(cb,ca)
     else ((if rd!:zerop d then rd!:minusp cdr cb else rd!:minusp d)
           where d=rd!:difference(car cb,ca))
   else if bfnump cb then
     ((if rd!:zerop d then not rd!:minusp cdr ca else rd!:minusp d)
      where d=rd!:difference(cb,car ca))
   else
   ((if rd!:zerop d then rd!:minusp rd!:difference(cdr cb,cdr ca)
     else rd!:minusp d) where d=rd!:difference(car cb,car ca)))
  where ca=car a,cb=car b;

symbolic procedure dnafterp(a,b);
  (if dnp ca then
     if dnp cb then dnafterp1(ca,cb)
     else if dnequal(ca,car cb) then mt!: cdr cb<0
       else dnafterp1(ca,car cb)
   else if dnp cb then
     if dnequal(car ca,cb) then mt!: cdr ca>0 else dnafterp1(car ca,cb)
   else
   ((if dnequal(cca,ccb) then dnafterp1(cdr ca,cdr cb)
     else dnafterp1(cca,ccb))
    where cca=car ca,ccb=car cb))
  where ca=car a,cb=car b;

symbolic procedure dnequal(a,b);
   mt!: a=0 and mt!: b=0 or ep!: a=ep!: b and mt!: a=mt!: b;

symbolic procedure dnafterp1(a,b);
   if ep!: a=ep!: b then mt!: a>mt!: b else
     ((if d=0 then ma>mb else
         if d>prd!% then ma>0
         else if d<-prd!% then mb<0
         else if d>0 then ma*10**d>mb
         else ma>mb*10**-d)
       where d=ep!: a - ep!: b, ma=mt!: a, mb=mt!: b);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/bfdoer2.red0000644000175000017500000004774411526203062023711 0ustar  giovannigiovannimodule bfdoer2; % routines for doing bfloat arithmetic, mixed float
                % and bf arithmetic, gf and gbf arithmetic, rational
                % arithmetic and fast polynomial manipulations and form
                % conversion, part 2.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment  support for allroot and realroot modules;

exports allout, automod, bfixup, bfmax, cexpand, ckprec, ckpzro, csize,
        ftout, gf2flt, gffinit, gfrtrnd, gfsimp, gfsqfrf, mkdn,
        n2gf, nbfout, nwterr, nwterrfx, outecho, outmode, pbfprint,
        pconstr, pflupd, restorefl, rootprec, rootrnd, seteps, smpart,
        stuffr, trmsg10a, trmsg11a, trmsg12a, trmsg13a, trmsg1a,
        trmsg2a, trmsg3a, trmsg4a, trmsg6a, trmsg7a, trmsg8a, trmsg9,
        trmsg17, xnsiz;

imports !*crn2cr, !*f2q, abs!:, bfloat, bfloatem, bfmin, bfminus,
        bfnump, bfnzp, bfp!:, bfplus, bfprin0, bfrndem, bfsiz, bftimes,
        bfzp, calcprec, ceiling, ceillog, cflot, conv2gi2, conv2gid,
        cpxp, crp, divbf, dmconv0, dmconv1, domainp, ep!:, eqcar,
        errorp, errorset!*, find!!nfpd, floor, getprec, gf2bf, gf2fl,
        gfconj, gffinitr, gfim, gfminus, gfrl, gzero, i2bf!:, lastpair,
        lessp!:, lispeval, listecho, log10, lprim, make!:ibf, make!:rd,
        maxbnd1, minprec, mk!*sq, mkgirat, mkinteg, mkquote, mt!:,
        mvar, neq, normbf, numr, off, on, p1rmult, pmsg, preci!:,
        precision, precmsg, r2bf, rdp, rerror, reversip, rl2gf,
        round!:mt, rtreorder, setflbf, setprec, simp!*, sizatom, sqfrf,
        sqrt, tagim, tagrl, times!:, ungffc, ungfform, univar, unshift;

fluid '(!*trroot !*rootmsg !*multiroot !*roundbf !:bprec!: !*complex
  !*msg !*bftag !*sqfree !*ratroot !*nosqfr rootacc!# iniprec!#);
switch trroot,rootmsg,multiroot,ratroot;
global '(!!nfpd !!nbfpd !!flim bfz!* log2of10 rlval!# cpval!#);
global '(!!shbinfl rootsreal rootscomplex den!* lm!# !!flprec);
flag('(rootsreal rootscomplex),'share);
fluid '(!*pfsav pr!# acc!# bfl!# emsg!# eps!# rootacc!#!#);
fluid '(!*xmax !*xmax2 !*rvar nwmax!# lgmax!# nozro!# !1rp);
fluid '(!*xo !*exp !*pcmp !*multrt lgmax!# nwmax!# rnd!# rndl!#);
fluid '(!*keepimp sqf!# exp!# sprec!# rprec!# !*bfsh incmsg!$
  cpx!# pfactor!# rr!# pnn!# nn!# prx!# rlrt!# !*noeqns);

global '(!*rootorder); symbolic (!*rootorder := t);

symbolic procedure gf2flt a;
  % force into float format, except if !shbinfl or float error.
   if !*roundbf or !!shbinfl then a else
      <<(if errorp gx then a else car gx)
         where gx=errorset!*(list('gf2fl,mkquote a),nil)>>;

symbolic procedure gfbfxn nx;
 gf2bf if !*bfsh then
      if bfnump nx then bfplus(nx,gfrl !*xo) else gfrl unshift nx
   else if bfnump nx then nx else unshift nx;

symbolic procedure print_the_number xn;
  if atom xn then write xn
   else if numberp car xn then <=0 then write "+";
                              write cdr xn;
                              write "*I" >>
   else if rdp xn then bfprin0a xn
    else <= 0 then write "+";
           bfprin0a cdr xn;
           write "*I" >>;

symbolic procedure bfprin0a u;
  bfprin0 u where !*nat = nil;

symbolic procedure trmsg1a (a,nx);
   if !*trroot then <<
     write a,",px=0 => ";
     print_the_number gfbfxn nx;
     terpri()
   >>;

symbolic procedure trmsg2a (a,xn,px);
   if !*trroot then <<
     write a," -> xn=";
     print_the_number gfbfxn xn;
     trmsg5(xn,px)
   >>;

symbolic procedure trmsg3a (a,xn);
   if !*trroot then <<
     write a,",xn=x0 => ";
     print_the_number gfbfxn xn;
     terpri()
   >>;

symbolic procedure trmsg4a req; if !*trroot then
   <"; print_the_number gfbfxn xn;
        trmsg5(xn,px)>>;

symbolic procedure trmsg7a xn;
   if !*trroot
    then <>;

symbolic procedure trmsg11a (xn,n);
   if !*trroot
     then < "; print_the_number gfbfxn xn; terpri()>>;

symbolic procedure trmsg12a z;
   if !*trroot then <";
                      print_the_number outtrim z; terpri()>>;

symbolic procedure trmsg13a(n,xn,px);
   if !*trroot
     then <nwmax!#+lm!# then
    <>;

symbolic procedure nwterrfx(n,cp);
  if n<3 then 0 else
   fix((n-2)*sqrt max(0,0-15+minprec())*if cp then 4 else 1);

symbolic procedure seteps;
 eps!# := make!:ibf(1,-(if !*bftag then !:bprec!: else !!nbfpd));

symbolic procedure pconstr(m,r);
 % set !*bftag and return equivalent of x^m-r in bfloat form.
  bfloatem prxflot(if prx!# then max(prx!#,ac) else ac,
   {0 . if rl then bfminus if bfnump r then r else car r else gfminus r,
         m . if rl then 1.0 else rl2gf 1.0})
   where rl=(bfnump r or bfzp cdr r),ac=acc!#+2+ceillog m;

symbolic procedure prxflot(pr,p);
   <!!nfpd) then pr else !!nfpd);
     bfrndem bfloatem p>>;

symbolic procedure smpart y;
   (if mt!: a>0 and mt!: b>0 then
      (if lessp!:(b,times!:(a,c)) then t
       else if lessp!:(a,times!:(b,c)) then 0))
    where a=abs!: round!:mt(gfrl y,20),b=abs!: round!:mt(gfim y,20),
       c := make!:ibf (1, -!:bprec!:);

symbolic procedure stuffr(n,v,ar);
 <0 do <>; rplaca(pt,v); ar>>
   where pt=ar;

symbolic procedure n2gf p; if atom p then p else
   begin scalar f,n; n := car p;
       for each y in cdr p do
          <>;
       return f end;

symbolic procedure pbfprint x;
   begin scalar n,d,c;
     if not (atom(d := cdar x) or bfp!: d) then
        <>
            else if atom car p then p := nil
            else if (n:= caar p)>0 then go to zrt;
         go to ret;
    zrt: c := list(list 0 . n); % eliminate and solve for zero roots.
       % if there are no other roots, we're done.
         if not p or null cdr p then <
    >;
       % otherwise, reduce polynomial degree.
         p := for each j in p collect (car j-n) . cdr j;
    ret: nozro!# := t; return c . p end;

symbolic procedure ckprec p;
   <> where !*msg=nil;
     sqf!# := !*sqfree; exp!# := !*exp; !*sqfree := !*exp := t;
    % simp!* is called on p in univar only.  Result is not dependent on
    % system precision unless p must be evaluated with rounded on.
     if null(p := univar p) then
       <>;
     if !*rounded then msgpri(nil,
      "Polynomial simplified in ROUNDED mode at precision",precision 0,
      ":       root locations depend on system precision.",nil)
       where !*msg=t;
    % next line corrected so internal precision is correct at start.
     setprec max(rprec!# or (!!nfpd+2),acc!#+2); p>>;

symbolic procedure restorefl;
   <>
      where !*msg=nil;
     nozro!# := pr!# := sqf!# := exp!# := cpx!# := rnd!# :=
       rndl!# :=  nil>>;

symbolic procedure mkequal l;
  'list . (for each y in l collect {'equal,!*rvar or 'x,outmode y});

symbolic procedure outmode j;
   if null j then j
   else if bfnump j and bfzp j then 0 else if fixp j then j
   else mk!*sq if !*ratroot then mkgirat j else !*f2q
      if floatp j then make!:rd j
       else if eqcar(j,'!:dn!:) then decimal2internal(cadr j,cddr j)
       else if domainp j then j
       else if eqcar(car j,'!:dn!:) then
         '!:cr!: . (cdr decimal2internal(cadar j,cddar j)) .
                   cdr decimal2internal(caddr j,cdddr j)
       else '!:cr!: . if bfp!: car j then (cdar j) . cddr j else j;

symbolic procedure allout c;
   begin scalar rl,cmp; integer a;
      c := for each j in c collect car j;
      if c and not !*ratroot and
       ((pairp r and (not bfnump r and car r eq '!:dn!:
           or not bfnump car r and caar r eq '!:dn!:)) where r=car c)
        then for each j in c do a := max(a,rrsiz j);
      restorefl(); % precision has been restored to initial value.
      for each x in c do
         if atom x or eqcar(x,'!:dn!:) then rl := x . rl
            else cmp := x . cmp;
      !*msg := t;
   % Increase system precision if too low to print out all roots.
      precmsg a;
   % If system precision is already high, warn about inputting values.
      if amax(rootacc!#!# or 6,!!flprec)
       then msgpri(nil,
        "input of these values may require precision >= ",a,nil,nil);
       !*msg := nil;
      % the following change improves roots, solve interface.
      c := if !*noeqns then
         <>
         else
           <>;
      return c end;

symbolic procedure rrsiz u;
  % determine precision needed for printing results.
   if numberp u then length explode abs u
   else if u eq 'i then 0
   else if atom u then rrsiz sizatom u
   else if eqcar(u,'minus) then rrsiz cadr u else
     ((if not atom y then
         if eqcar(y,'!:dn!:) then max(rrsiz car u,rrsiz cdr u)
         else rerror(roots,7,"unknown structure")
       else if y memq '(plus difference) then
         begin integer r;
           for each n in cdr u do r := max(r,rrsiz n);
           return r end
       else if y memq '(times quotient) then
         for each n in cdr u sum rrsiz n
       else if y eq '!:dn!: then length explode abs car normdec cdr u
       else rerror(roots,7,"unknown structure")) where y=car u);

symbolic procedure outecho r;
   allout for each c in r join
      listecho(car c,if !*multiroot then cdr c else 1);

symbolic procedure find!!flim;
   <>
       until explode(1.0+n)=explode 1.0; !!flim>> where n=1.0;

symbolic procedure xnsiz x;
  ceiling (xnsiz1 x / log2of10);

symbolic procedure xnsiz1 x;
   if bfnump x then bfsiz x
   else if bfzp gfim x then bfsiz gfrl x
   else if bfzp gfrl x then bfsiz gfim x else
   <>;

symbolic procedure outtrim j;
   if !*roundbf or acc!#>!!flim then gf2bf j else
     ((if errorp d then gf2bf j else car d)
       where d=errorset!*({'gf2fl,mkquote j},nil));

symbolic procedure bfmax p;
  <>;

symbolic procedure nbfout x; bfloat ftout x;

symbolic procedure bfixup x; if !*bftag then gf2bf x else gf2fl x;

symbolic procedure ftout x;
   if atom x then cflot x
   else if rdp x then cdr x else x;

find!!flim();

symbolic procedure cexpand cc;
   begin scalar c;
      if !*rootorder then cc := rtreorder cc;
      for each r in cc do
         <>;
      return c end;

symbolic procedure cdnconj u;
  (car u) . (cadr u . ((minus caddr u) . cdddr u));

symbolic procedure mkdn u;
 if atom car u then '!:dn!: . normdec u else (mkdn car u) . mkdn cdr u;

symbolic procedure normdec x;
   begin scalar mt,s;integer ep;
      if (mt := car x)=0 then go to ret;
      if mt<0 then <>;
      ep := cdr x;
      mt := reversip explode mt;
      while car mt eq '!0 do <>;
      mt := compress reversip mt;
      if s then mt := -mt;
 ret: return mt . ep end;

symbolic procedure rootrnd y; rtrnda(y,acc!#);

symbolic procedure rtrnda(r,a);
  if bfzp r then <> else
  ((decimal2internal(car (rlval!# := u),cdr u))
   where u=round!:dec1(r,a));

symbolic procedure gfrtrnd y;
   (begin scalar rl,rld,im; y := cdr y;
      rl := rtrnda(a,acc!#); rld := rlval!#;
      im := rtrnda(y,acc!#);
      cpval!# := if car rlval!# = 0 then rld else rld . rlval!#;
      return rl . im end)
    where a=car y;

symbolic procedure gfsqfrf p;
   begin scalar m,cp,q,dmd;
      if caar lastpair p=1 or !*nosqfr then go to nof;
      cp := cpxp(q := mkinteg p);
      dmd := dmode!*; if !*complex then dmd := get(dmd,'realtype);
      m := !*msg; off msg;
      if dmd then lispeval {'off,mkquote list(dmd := get(dmd,'dname))};
      q := sqfrf if cp then ungffc q else ungfform q;
      if dmd then lispeval {'on,mkquote list dmd}; if m then on msg;
      if cdr q then pfactor!# := t else if cdar q=1 then go to nof;
      !1rp := p1rmult q; return q;
 nof: q := list(p . 1); !1rp := p; return q end;

symbolic procedure automod p; % p is always returned in bfloat form.
   if bfnump (p := gffinit p) then p else
   begin integer n,s,s2; scalar a,d,m,nl,pr,nc,dd; rr!# := 0;
      if null cdr p then <>;
    % determine precision of calculation and set mode.
    % first find minimum precision for normalizing p.
      m := car(d := car lastpair(p := bfloatem p)); d := cdr d;
      for each c in cdr reverse p do n := max(n,xnsiz cdr c);
      pr := getprec();
      setprec(if (nc := bfnump d) and abs mt!: d=1
         or not nc and
            ((a := mt!: car d)=0 and abs(dd := mt!: cdr d)=1 or
              dd=0 and abs a=1) then n else 2+max(n,xnsiz d));
      n := 0;
    % now calculate necessary precision for gfrootfind.
  nl := for each c in cdr reverse p collect xnsiz cdr c;
      for each c in nl do
         <>;
      n := calcprec(m,nn!# := n,rr!#,float s/rr!#,
         if n>1 then float s2/(2*n*(n-1)) else 0);
      if rprec!# then n := max(n,rprec!#);
      pnn!# := n;
      if n>!!nfpd or !*roundbf then go to bfl;
      setflbf nil; setprec pr;
 cfl: if errorp errorset!*({'cflotem,mkquote p},nil)
         then go to bfl else return p;
 sel: if not !*bftag then go to cfl;
 bfl: setflbf t; setprec n; return p end;

symbolic procedure gffinit p;
   if not domainp p and numberp caar p then p
   else if numberp p
      or not atom p and member(car p,domainlist!*) then 0
   else
     begin scalar !*msg,cp;
       cp := !*complex; on complex;
       p := gfform p;
       if not cp then off complex; return reformup p end;

symbolic procedure clrdenom p; % convert p to integer polynomial.
   <>;

symbolic procedure gfform p;
   if domainp p then 0 else if atom caar p then p else
   begin scalar q; !*rvar := mvar p; p := clrdenom p;
loop: if cdar p then q := ((cdaar p) . gfsimp cdar p). q;
      if null (p := cdr p) then return q
      else if domainp p then <>
      else go to loop end;

symbolic procedure gfsimp u;
 % strip domain tags and strip zero im part but restore :bf: if needed.
   if bfnump u or rdp u then u
    else if eqcar(u,'!:rn!:) then r2bf cdr u
    else
      <>;

symbolic procedure reformup q; if domainp q then q else
  % returned q will be bfloat.
   begin scalar c,fg,d; integer n;
      for each v in q do  % check for complex, float, bfloat.
         <> >>;
       % make coefficients homogeneous in type and assure
       % adequate precision;
       % convert coefficients to all real or all complex.
      if fg then
         <>;
           d := q;
           repeat if bfnzp cadar d then fg := nil
                 until not fg or null(d := cdr d);
           if fg then
              q := for each v in q collect (car v) . cddr v>>;
      if bfp!: c or n>!!nfpd then <>
         else if floatp c then <>;
      if n+2>getprec() then setprec(n+2);
      return q end;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/complxp.red0000644000175000017500000004364711526203062024046 0ustar  giovannigiovannimodule complxp; % Support for complex polynomial solution.

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment   support for modules allroot and realroot;

exports a2gf, a2rat, accupr, bdstest, bfprim, bfrndem, calcprec, csep,
        cvt2, cvt5, deflate1, deflate1c, dsply, getroot, gffinitr,
        gfgetmin, gfshift, gfstorval, invpoly, leadatom, limchk,
        mkgirat, mkinteg, mkpoly, orgshift, p1rmult, rlrtno2, rrpwr,
        rxgfc, rxgfrl, rxrl, schnok, sturm1, ungffc, xoshift;

imports !!mfefix, !*f2q, abs!:, ashift, automod, bfabs, bfdivide,
        bfixup, bflessp, bfloat, bfloatem, bfnump, bfnzp, bfsqrt,
        bfzp, ceiling, ceillog, cflot, cflotem, cpxp,
        decimal2internal, deflate2, denr, divbf, divide!:, domainp,
        ep!:, eqcar, equal!:, errorp, errorset!*, floor, ftout, gcdn,
        geq, gf2bf, gffinit, gfim, gfplus, gfplusn, gfquotient, gfrsq,
        gfrtrnd, gfsimp, gftimes, gftimesn, gfval, gfzerop,
        greaterp!:, gtag, hypot, intdiff, lastpair, lcm, lessp!:, log,
        make!:ibf, minbnd1, minus!:, mk!*sq, mkquote, mkratl, mkxcl,
        mt!:, n2gf, ncoeffs, ncpxp, neq, num, numr, plubf, plus!:,
        pmsg, preci!:, prepsq, primp, primpn, r2bf, r2flbf, ratlessp,
        realrat, rerror, reval, reversip, rl2gf, rndpwr,
        rootrnd, round!:mt, sch, schinf, sgn, sgn1, simp!*, sqrt,
        sturm, timbf, times!:, typerr, xclp;


fluid '(acc!# !*intp !*multrt !*strm sprec!# !*xo !*rvar rootacc!#!#);
fluid '(!*bftag !*rootmsg lims!# pfactor!# !*xnlist accm!# pflt!#);
global '(limlst!# bfone!*);

symbolic procedure rxgfrl(p,x);
   <>;
     bfsqrt gfrsq c>>
    where c=rl2gf bfabs car(p := cdr ncoeffs p);

symbolic procedure rxgfc(p,x);
   <>;
     bfsqrt gfrsq c>>
   where c=gfabs car(p := cdr ncoeffs p);

symbolic procedure gfabs x; (bfabs car x) . bfabs cdr x;

symbolic procedure gfabstim(b,c);
 <<(plubf(timbf(ba,ca),timbf(bd,cd))).plubf(timbf(ba,cd),timbf(bd,ca))>>
 where ba=car b,bd=cdr b,ca=car c,cd=cdr c;

symbolic procedure rxrl(p,r);
   <>;
     c>>
   where c=bfabs car(p := cdr ncoeffs p);

symbolic procedure csep p;
   %separate gfform p into real p and im whose roots are all complex.
   <
    >;
        (n2gf g) . p>>
 where g=gfgcd(primcoef fillz for each s in p collect (car s) . cadr s,
          primcoef fillz for each s in p collect (car s) . cddr s))>>;

symbolic procedure fillz p; if atom p then p else
   for each c in ncoeffs p collect if null c then 0 else c;

symbolic procedure primcoef p; if atom p then p else
   %trim leading and trailing zero coeffs, and make prim.
   begin integer d;
      p := reverse cdr p;
      while p and car p=0 do p := cdr p; if null p then return 0;
      p := reverse p; while p and car p=0 do p := cdr p;
      if null cdr p then return 1;
      for each c in p do d := gcdn(d,c);
      return
       (((length p-1) . for each c in p collect s*c/d)
        where s=sgn car p) end;

symbolic procedure gfgcd(p,q); if atom p or atom q then 1 else
   if car q>car p then gfgcdr(q,p) else gfgcdr(p,q);

symbolic procedure gfgcdr(p1,p2);
   <>
   where r=pqrem(p1,p2);

symbolic procedure pqrem(p1,p2);
    %primitive pseudoremainder of p1,p2 in intcoeff form.
    begin scalar a,g,n,n2,m,m1,m2;
       n := car p1-(n2 := car p2); p1 := cdr p1;
       p2 := cdr p2; m2 := car p2;
   lp: g := gcdn(m1 := car p1,m2);
       m1 := m2/g;
       a := p1 := for each y in p1 collect y*m1; m := car a/m2;
       for each y in p2 do
          <>;
       p1 := cdr p1; if (n := n-1)>=0 then go to lp;
       return primcoef ((length p1-1) . p1) end;

symbolic procedure negprem(p1,p2);
   %computes the negative pseudoremainder of p1,p2 in fillz form.
   begin scalar a,g,n,n2,m,m1,m2;
      n := car p1-(n2 := car p2); p1 := cdr p1;
      p2 := cdr p2; m2 := car p2;
  lp: g := gcdn(m1 := car p1,m2); m1 := abs(m2/g);
      p1 := for each y in p1 collect y*m1; a := p1; m := car a/m2;
      for each y in p2 do <>;
      p1 := cdr p1; if (n := n-1)>=0 then go to lp;
      return primpn((n2-1) . for each y in p1 collect -y) end;

symbolic procedure gfcpquo(p,q);
 %quotient of gi poly p and integer poly q, a factor in fillz form.
   begin scalar n,c,a,d,f,z,pp; z := 0 . 0;
      n := car(p := ncoeffs p)-car q;
      pp := for each r in cdr p collect if r then r else z;
      c := car(q := cdr q);
loop: a := (caar pp)/c; d := (cdar pp)/c;
      if a neq 0 or d neq 0 then f := (n.(a . d)) . f;
      if (n := n-1)<0 then return f;
      p := pp;
      for each r in q do
         <>;
      pp := cdr pp; go to loop end;

symbolic procedure deflate1(p,r);
 %fast rem . quotient function for real polynomial with real r.
 %all arithmetic is bf with no rounding.
   begin scalar q,n,c;
      n := car(p := ncoeffs p); p := cdr p; c := car p;
      for each i in cdr p do
         <>;
      return c . q end;

symbolic procedure deflate1c(p,r);
 %rem . quotient function for complex polynomial, with complex r.
 %all arithmetic is bf with no rounding.
   begin scalar q,n,c;
      n := car(p := ncoeffs p); p := cdr p; c := car p;
      for each j in cdr p do
         <>;
      return c . q end;

symbolic smacro procedure rl2gfc x;
   x . if atom x then 0.0 else bfz!*;

symbolic procedure accupr(p,q,r);
   begin scalar cq,cp,rl,!*bftag,s; integer ac;
      if caar lastpair q<2 then return 1; !*bftag := t;
      r := gf2bf r; cq := cpxp (q := bfloatem q); cp := cpxp p;
      rl := bfnump r or bfzp gfim r and (r := car r);
      q := % deflate root r or complex pair but do not round.
       if rl then cdr if cq then deflate1c(q,rl2gf r) else deflate1(q,r)
       else if not cq then deflate2(q,r)
       else cdr
         if cp then deflate1c(q,r)
         else deflate1c(cdr deflate1c(q,r),(car r) . minus!: cdr r);
      if caar q>0 then <>;
      if rl then r := rl2gfc r;
      p := bfsqrt bfloat gfrsq r;
     % decimal computation proved to be more precise in critical cases.
      p := round!:dec1(p,acc!#+2);
      p := 1 + cdr p + length explode abs car p;
loop: s := if caar lastpair q>1 then bfloat minbnd1(q,r) else
         bfsqrt gfrsq gfplus(r,
           <>);
     % decimal computation used here also for precision.
      s := round!:dec1(s,acc!#+2);
      ac := max(ac,rootacc!#,p-cdr s-length explode abs car s);
     % repeat minbnd1 test for conj r only if r is a complex pair and
     % q is complex.
      if cq and not rl and not cp then
         <>;
 ret: if rootacc!#!# then ac := max(ac,rootacc!#!#);
      accm!# := max(ac,accm!#); return ac end;

symbolic procedure orgshift(p,org);
   %shifts origin of real or complex polynomial to origin org,
   %with p and org of the same form.
   begin scalar s,cp; integer n;
      if gfzerop(if (cp := cpxp p) then org else rl2gf org)
         then return p;
      org := gf2bf org;
      if numberp leadatom cdar p then p := bfloatem p;
      if cp then while p do
         <
    >
         else while p do
            <
    >;
       return reversip if pflt!# then cflotem s else bfrndem s end;

symbolic procedure bfrndem s;
   (for each c in s collect (car c) .
      if cp then (rndpwr cadr c) . rndpwr cddr c else rndpwr cdr c)
   where cp=cpxp s;

symbolic procedure r2flbf2r x; realrat r2flbf x;

symbolic procedure bfprim p;
   <>
   where d=cdar lastpair p;

symbolic procedure primpc p;
   %make complex p primitive.
   begin integer d;
      for each y in p do d := gcdn(cadr y,gcdn(d,cddr y));
      return for each y in p collect
         (car y) . ((cadr y/d) . (cddr y/d)) end;

symbolic procedure ungffc p;
   begin scalar r,c;
      c := gtag cadar p;
      if caar p=0 then
         <>;
      for each i in p do
         if not gfzerop cdr i then r := ((!*rvar.car i).(c.cdr i)).r;
      return r end;

%symbolic procedure iscale(d,y); mt!: y*2**(d+ep!: y);
symbolic procedure iscale(d,y); ashift(mt!: y,d+ep!: y);

symbolic procedure mkinteg p;
  %converts a polynomial in gfform to the smallest exactly equivalent
  %polynomial with integral coefficients.
   (begin integer m;
       p := bfloatem p; %convert to bfloat.
      % then work with powers of 2 to convert to integer.
       for each y in p do m := if nc then max(m,-ep!: cdr y) else
          max(m,-ep!: cadr y,-ep!: cddr y);
       p := for each y in p collect (car y) .
          if nc then iscale(m,cdr y) else
             (iscale(m,cadr y)) . iscale(m,cddr y);
       return if nc then primp p else primpc p end)
    where nc=ncpxp p;

symbolic procedure mkgirat j;
   %convert a gf complex into the equivalent gi rational form.
   begin scalar ra,rd,ia,id,ro,io;
      if eqcar(j,'!:dn!:) then
        <0 then ra := 10^ro;
          return mkrn(ra,rd) ./ 1>>
      else if pairp j and eqcar(car j,'!:dn!:) then
        <0 then ra := 10^ro;
          ia := caddr j; io := cdddr j; id := 1;
          if io<0 then id := 10^(-io) else if io>0 then ia := 10^io;
          ra := car(rd := cdr mkrn(ra,rd)); rd := cdr rd;
          ia := car(id := cdr mkrn(ia,id)); id := cdr id;
          go to lcm>>;
      if bfnump(j := gf2bf j) then return cdr !*rd2rn rootrnd bfloat j;
      j := gfrtrnd gf2bf j;
      ra := car(rd := cdr !*rd2rn car j); rd := cdr rd;
      ia := car(id := cdr !*rd2rn cdr j); id := cdr id;
 lcm: j := id/gcdn(id,rd)*rd; ro := j/rd; io := j/id;
      return ('!:gi!: . ((ra*ro) . (ia*io))) . j end;

symbolic procedure mkpoly rtl;
  if eqcar (rtl, 'list) then num mkpoly1 cdr rtl
   else typerr(if eqcar(rtl,'!*sq) then prepsq cadr rtl else rtl,
               "list");

symbolic procedure mkpoly1 r;
   if null cdr r then mkdiffer car r
      else 'times . list(mkdiffer car r,mkpoly1 cdr r);

symbolic procedure getroot(n,r);
   if (n := fix n)<1 or n>length(r := cdr r) then
      rerror(roots,4,"n out of range") else
      <0 do r := cdr r; caddar r>>;

symbolic procedure mkdiffer r; 'difference . cdr r;

symbolic operator mkpoly,getroot;

symbolic procedure a2gf x;
   %convert any interpretable input value to gf form.
   bfixup if bfnump x then rl2gf x
      else if not atom x and bfnump car x
         then (r2flbf car x) .  r2flbf cdr x else
      <<(if errorp y or null(y := car y)
         then error(0,list(x,"is illegal as root parameter")) else y)
      where y=errorset!*(list('a2gf1,mkquote x),nil)>>;

symbolic procedure a2gf1 x;
   <>
    where d = simp!* x;

symbolic procedure gi2gf x; (bfloat cadr x) . bfloat cddr x;

symbolic procedure gfquotbf(rl,im,d);
   (if rl then quotbf(rl,d) else bfz!*) . quotbf(im,d);

symbolic procedure quotbf(n,d);
   <>
     else n := ftout n;  divbf(bfloat n,bfloat d)>>;

symbolic procedure sturm1 p;
   %produces the sturm sequence as a list of ncoeff's
   begin scalar b,c,s;
      b := fillz primp intdiff (p := mkinteg p);
      s := list(b,p := !*intp := fillz p);
      if not atom b then repeat
         <> until atom c;
      !*multrt := c=0;
      return !*strm := reverse s end;

symbolic procedure gfshift p;
   begin scalar pr,n,org; sprec!# := make!:ibf (3,1-!:bprec!:);
      !*xo := rl2gf 0; if null p then return !*xo;
      n := car (pr := ncoeffs bfprim p); if n>1 then pr := caddr pr;
      if pr then if cpxp p
         then !*xo := org := gfquotient(pr,rl2gf(-n))
         else !*xo := rl2gf(org :=bfdivide(pr,r2flbf(-n)));
      if null pr then return p;
      return orgshift(p,org) where pflt!#=null !*bftag end;

symbolic procedure p1rmult p; automod numr simp!* p1rmult1 p;

symbolic procedure p1rmult1 p;
   if atom p then nil
   else if atom cdr p then reval mk!*sq !*f2q caar p
   else {'times,p1rmult1 list car p,p1rmult1 cdr p};

symbolic procedure xoshift(p,nx);
   begin scalar n,org,pr,cp,orgc,a,b;
     % shift if abs p(mean) < p(origin).
      n := car (pr := ncoeffs bfprim p); if n>1 then pr := caddr pr;
      if null pr then return nil;
      org := if (cp := cpxp p) then gfquotient(pr,rl2gf(-n))
         else bfdivide(pr,r2flbf(-n));
      orgc := if cp then org else rl2gf org;
      if errorp(b := errorset!*(
            {'gfrsq,{'gfval,mkquote p,mkquote orgc}},nil))
         then return bflessp(gfrsq gf2bf orgc,bfone!*)
        else b := car b;
      a := gfrsq gfval(p,rl2gf 0);
      pmsg list("a=",a," b=",b);
      return not bflessp(a,b) end;

symbolic procedure gffinitr p;
   %do gffinit p but restore *bftag.
   (gffinit p) where !*bftag = !*bftag;

symbolic procedure invpoly p;
   %remove zero roots of p and reverse coefficients of p.
   <
    >;

symbolic procedure bdstest i;
   begin scalar y;
      if equal!:(rootrnd r2bf car i,y := rootrnd r2bf cdr i)
         then return y end;

symbolic procedure rlrtno2 p;
  if null sturm p then 0
  else if null lims!# then schinf(-1)-schinf 1 else
  begin scalar a,b; a := car lims!#;
    if null cdr lims!# then
       return if a<0 then schinf(-1)-schinf 0-adjst realrat 0
          else schinf 0-schinf 1;
    return if (b := cadr lims!#)='infty then schxa a-schinf 1
       else if a='minfty then schinf(-1)-schxb b
       else schxa a-schxb b end;

symbolic procedure schxa a; if xclp a then sch cdr a else sch a+adjst a;

symbolic procedure schxb b;
   if xclp b then sch cdr b+adjst cdr b else sch b;

symbolic procedure adjst l; if sgn1(car !*strm,l)=0 then 1 else 0;

symbolic procedure limadj m;
   if not m then lims!#
   else if length lims!#<2 then
      if remainder(m,2)=0 then list 1 else nil else
   ((if ratlessp(lval b,lval a) then list(b,a) else list(a,b))
    where a=lpwr(car lims!#,m),b=lpwr(cadr lims!#,m));

symbolic procedure gfstorval(pf,xn); !*xnlist := (pf . xn) . !*xnlist;

symbolic procedure gfgetmin;
   begin scalar y,nx,l; l := !*xnlist; nx := car (y := car l);
      for each x in cdr l do
         if bflessp(car x,nx) then nx := car (y := x);
      return cdr y end;

symbolic procedure calcprec(m,n,r,av,s2);
   begin integer p;
     p := if m<2 then 1+max(acc!#,n)
       else max(acc!#+1,n+1+ceillog m +
         if r=1 then 0 else
           max(if s2>2.2 or s2<1.0 then 0 else if s2>1.7 then 2 else 3,
             if m>3 and 1.5*av>n+1 then
                 fix(0.7*max(acc!#,7)*log float m+0.5) else 0));
    pmsg list("m=",m," n=",n," a=",acc!#," r=",r," av=",av,
      " s2=",s2,"->",p);
    return p end;

symbolic procedure rrpwr(r,m);
   <0 do rr := gftimes(rr,r); rr>>
   where rr=(r := a2gf r);

symbolic procedure cvt2(a,b); mt!: a neq 0 and mt!: b neq 0 and
   <>;

symbolic procedure dsply nx; if !*rootmsg then
   << << write "  prec is ",2+precision 0; terpri();
   print_the_number nx; terpri(); wrs n>> where n=wrs nil>>;

symbolic procedure leadatom x; if atom x then x else leadatom car x;

symbolic procedure cvt5(a,b); equal!:(round!:mt(a,20),round!:mt(b,20));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/roots/nrstroot.red0000644000175000017500000001472411526203062024250 0ustar  giovannigiovannimodule nrstroot; % Routines for finding the root of a polynomial which
 % is nearest to a given value (providing the root is sufficiently
 % close.)

% Author: Stanley L. Kameny .

% Version and Date:  Mod 1.96, 30 March 1995.

% Copyright (c) 1988,1989,1990,1991,1992,1993,1994,1995.
% Stanley L. Kameny.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment   modules bfdoer, bfdoer2, complxp, allroot, and rootaux of
roots.red needed also;

global '(bfz!* cpval!#);

fluid '(!*msg !*multiroot cpxt!# pfactor!# nrst!$ intv!# pfl!# !*bftag
 ss!# accm!# prm!# prec!# !*mb !*gfp !*keepimp !*xo nrst!$ pnn!# pfx!#
 !1rp !*complex !*resimp pgcd!# !*xn !*xobf prec!# !*hardtst acc!# rr!#
 prx!#);

symbolic procedure nearestroot args; % args = (p,rr)
 % finds root nearest to rr, unless accuroot abort occurs.  rr may be
 % real or complex. p can have zero root or multiple roots.  Most useful
 % for refining the value of a known root, by setting rootacc before
 % calling nearestroot.
  nrstroot(p,rr,nil) where p=car args,rr=cadr args;

put('nearestroot,'psopfn,'nearestroot);

symbolic procedure nrstroot(p,rr,trib);
   begin
      scalar x,c,d,dx,xm,r,cp,n,m,s,p1,prx!#,acc,pp,m1,!*msg,
        !*multiroot,cpxt!#,pfactor!#,nrst!$,intv!#,pfl!#,acfl!#,!*bftag;
      integer ss!#,accm!#,prm!#,prec!#;
      !!mfefix();
      p := cdr(c := ckpzro p); c := car c; !*mb := nil;
      if atom p then <>;
      if null rr then rr := 0;
      if trib then
        <>
           else % test branch that goes through gfrootfind only
             <> >>;
      r := a2gf rr; acc := acc!# := max(acc!#,rr2acc rr);
      if c then if gfzerop r then <> else
         <>;
      m := powerchk p; nrst!$ := t;
      p := gfsqfrf p; automod !1rp; n := pnn!#; p1 := bfloatem !1rp;
      if length p>1 then pfactor!# := prx!# := n;
      if cpxp p then cpxt!# := t;
      if m then
         <
    >;
loop: pp := automod car(x := car p); cp := nil;
      if cpxp pp then
         <>;
 mod: pp := automod pp; r := gf2bf r;
     % powerchk may succeed after sqfrf or csep succeeds.
      if (m1 := powerchk pp) then <>;
      if not m and not m1 then
         <>;
      x := if m1 then
         nrpass2(m1,nrpass1(pp,r,if m then m1*m else m1),r,p1,acc)
            else nrpass1(pp,r,m);
      if m then x := nrpass2(m,x,r,p1,acc);
     % however we get to the next line, cpval!# has been set.
 col: x := cdr x;
      dx := gfrsq gfdiffer(if bfnump x then (x := x . bfz!*) else x,
         gf2bf r);
      if not d or d and bfleqp(dx,d) then
        <>;
 cpr: if cp then <>;
      if (p := cdr p) and not domainp caar p then go to loop;
      c := xm;
 ret: return allout if c then {(c . acc!#)} else nil end;

symbolic procedure rr2acc rr;
  (begin scalar !*msg,c;
    c := !*complex; on complex;
    for each n in rr2nl rr do form1(n,nil,'algebraic);
    (simp!* rr) where !*resimp=t;
    if not c then off complex;
    pr := precision pr; return pr end)
    where pr=precision 6;

symbolic procedure rr2nl rr; rr2nl1(rr,nil);

symbolic procedure rr2nl1(rr,nl);
   if numberp rr then {'!:int!:,rr} . nl
     else if atom rr then nl
     else if car rr eq '!:dn!: then {'!:int!:,cadr rr} . nl
     else rr2nl1(car rr,rr2nl1(cdr rr,nl));

symbolic procedure nrstrt0(q,r,p1);
   begin scalar rr,x,b,pr,ps,p2,qf; pmsg pbfprint q; b := !*bftag;
      ps := getprec(); pr := minprec(); pgcd!# := not p1;
      p2 := gfzerop(rr := a2gf r); !*gfp := qf := q;
      if b then go to r2;
      if errorp(q := errorset!*({'cflotem,mkquote qf},nil))
        or errorp(r := errorset!*({'gf2fl,mkquote rr},nil))
         then go to r1 else <>;
      if (x := gfrootset(q,r,b)) then
         <>;
  r1: q := qf; b := !*bftag := t; r := gf2bf rr;
  r2: x := gfrootfind(q,r); !*xobf := !*xo := gf2bf !*xo;
  r3: if not !*hardtst then x := ckacc(q,if p1 then p1 else q,!*xn);
      x := accuroot(
      if bfzp gfim r then (car !*xn) . bfabs cdr !*xn else !*xn,q,!*xo);
      if prec!#>;
      setprec(pr := prec!#);
      if not !*bftag then b := !*bftag := t;
      if p2 then go to r2 else <> end;

symbolic procedure nrpass1(pp,rr,m);
   nrstrt0(pp,rrpwr(rr,m),nil) where ss!#=ceillog m;

symbolic procedure nrpass2(m,x,rr,p1,acc);
   begin scalar s; s := ceillog m;
      return (nrstrt0(pconstr(m,cdr x),rr,p1)
         where acc!#=max(acc,car x-s),rr!#=1,
            ss!#=0,pfactor!#=(pfactor!# or car x-s>acc)) end;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/0000755000175000017500000000000011722677361022023 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/hephys.red0000644000175000017500000006100611526203062024003 0ustar  giovannigiovannimodule hephys;   % Support for high energy physics calculations.

% Author: Anthony C. Hearn.

% Generalizations for n dimensional vector and gamma algebra by
% Gastmans, Van Proeyen and Verbaeten, University of Leuven, Belgium.

% Copyright (c) 1991 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(hephys),'(appl));

fluid '(!*nospurp !*sub2 ncmp!* ndims!*);

global '(defindices!* indices!* mul!* ndim!*);

defindices!* := nil; % Deferred indices in N dim calculations.

indices!* := nil; % List of indices in High Energy Physics
                  % tensor expressions.
ndim!* := 4;      % Number of dimensions in gamma algebra.

% *********************** SOME DECLARATIONS *************************

deflist ('((cons simpdot)),'simpfn);

flag('(cons),'symmetric);   % Since CONS is used in algebraic mode
                            % only for High Energy Physics expressions.

put('vector,'stat,'rlis);

% put('vector,'formfn,'formvector);

%symbolic procedure formvector(u,vars,mode);
%   if mode eq 'algebraic
%     then list('vector1,'list . formlis(cdr u,vars,'algebraic))
%    else u;

symbolic procedure vector u; vector1 u;

symbolic procedure vector1 u;
   for each x in u do
      begin scalar y;
         if not idp x or (y := gettype x) and y neq 'hvector
           then typerr(if y then {y,x} else x,"high energy vector")
          else put(x,'rtype,'hvector)
      end;

put('hvector,'fn,'vecfn);

put('hvector,'evfn,'veval);

put('g,'simpfn,'simpgamma);

noncom g;

symbolic procedure index u;
   begin vector1 u; rmsubs(); indices!* := union(indices!*,u) end;

symbolic procedure remind u;
   begin indices!* := setdiff(indices!*,u) end;

symbolic procedure mass u;
   if null car u then rerror(hephys,1,"No arguments to MASS")
    else <>;

symbolic procedure getmas u;
   (if x then x else rerror(hephys,2,list(u,"has no mass")))
    where x=get(u,'mass);

symbolic procedure vecdim u;
   begin ndim!* := car u end;

symbolic procedure mshell u;
   begin scalar x,z;
    a:  if null u then return let0 z;
        x := getmas car u;
        z := list('equal,list('cons,car u,car u),list('expt,x,2)) . z;
        u := cdr u;
        go to a
   end;

symbolic procedure nospur u;
   <>;

symbolic procedure spur u;
   <>;

rlistat '(vecdim index mass mshell remind nospur spur vector);


% ******** FUNCTIONS FOR SIMPLIFYING HIGH ENERGY EXPRESSIONS *********

symbolic procedure veval(u,v);
   begin scalar z;
      for each x in nssimp(u,'hvector) do
       <>;
      return replus z
   end;

symbolic procedure vmult u;
   begin scalar z;
        z := list list(1 . 1);
    a:  if null u then return z;
        z := vmult1(nssimp(car u,'hvector),z);
        if null z then return;
        u := cdr u;
        go to a
   end;

symbolic procedure vmult1(u,v);
   begin scalar z;
        if null v then return;
    a:  if null u then return z
         else if cddar u
          then msgpri("Redundant vector in",cdar u,nil,nil,t);
        z := nconc!*(z,for each j in v collect
                          multsq(car j,caar u) . append(cdr j,cdar u));
        u := cdr u;
        go to a
   end;

symbolic procedure simpdot u;
   mkvarg(u,function dotord);

symbolic procedure dotord u;
   <>;

symbolic procedure mkvarg(u,v);
   begin scalar z;
        u := vmult u;
        z := nil ./ 1;
    a:  if null u then return z;
        z := addsq(multsq(apply1(v,cdar u),caar u),z);
        u := cdr u;
        go to a
   end;

symbolic procedure simpgamma u;
   if null u or null cdr u
       then rerror(hephys,5,"Missing arguments for G operator")
    else begin scalar z;
        if not ('isimpq memq mul!*) then mul!*:= aconc!*(mul!*,'isimpq);
        ncmp!* := t;
        z := nil ./ 1;
        for each j in vmult cdr u do
           z := addsq(multsq(mksq('g . car u . cdr j,1),car j),z);
        return z
   end;

symbolic procedure simpeps u;
   mkvarg(u,function epsord);

symbolic procedure epsord u;
   if repeats u then nil ./ 1 else mkepsq u;

symbolic procedure mkepsk u;
   % U is of the form (v1 v2 v3 v4).
   % Value is  . .
   begin scalar x;
        if xnp(u,indices!*) and not('isimpq memq mul!*)
          then mul!* := aconc!*(mul!*,'isimpq);
        x := ordn u;
        u := permp(x,u);
        return u . ('eps . x)
   end;

symbolic procedure mkepsq u;
   (lambda x; (lambda y; if null car x then negsq y else y)
                 mksq(cdr x,1))
        mkepsk u;


% ** FUNCTIONS FOR SIMPLIFYING VECTOR AND GAMMA MATRIX EXPRESSIONS **

symbolic smacro procedure mkg(u,l);
   % Value is the standard form for G(L,U).
   mksf('g . l . u);

symbolic smacro procedure mka l;
   % Value is the standard form for G(L,A).
   mksf list('g,l,'a);

symbolic smacro procedure mkgamf(u,l);
   mksf('g . (l . u));

symbolic procedure mkg1(u,l);
   if not flagp(l,'nospur) then mkg(u,l) else mkgamf(u,l);

symbolic smacro procedure mkpf(u,v);
   multpf(u,v);

symbolic procedure mkf(u,v);
   multf(u,v);

symbolic procedure multd!*(u,v);
   if u=1 then v else multd(u,v);     % onep

symbolic smacro procedure addfs(u,v);
   addf(u,v);

symbolic smacro procedure multfs(u,v);
   % U and V are pseudo standard forms.
   % Value is pseudo standard form for U*V.
   multf(u,v);

put('rcons,'cleanupfn,'isimpa);

symbolic procedure isimpa(u,v);
   if eqcar(u,'list) then u else !*q2a1(isimpq simp u,v);

symbolic procedure isimpq u;
   begin scalar ndims!*;
      ndims!* := simp ndim!*;
      if denr ndims!* neq 1
        then <>
       else ndims!* := numr ndims!*;
   a: u := isimp1(numr u,indices!*,nil,nil,nil) ./ denr u;
      if defindices!*
        then <>
       else if null !*sub2 then return u
       else return resimp u
   end;

symbolic procedure isimp1(u,i,v,w,x);
   if null u then nil
    else if domainp u
       then if x then multd(u,spur0(car x,i,v,w,cdr x))
             else if v
              then rerror(hephys,6,"Unmatched index" . mapovercar v)
             else if w then multfs(emult w,isimp1(u,i,v,nil,x))
             else u
    else addfs(isimp2(car u,i,v,w,x),isimp1(cdr u,i,v,w,x));

symbolic procedure isimp2(u,i,v,w,x);
   begin scalar z;
        if atom (z := caar u) then go to a
         else if car z eq 'cons and xnp(cdr z,i)
            then return dotsum(u,i,v,w,x)
         else if car z eq 'g
          then go to b
         else if car z eq 'eps then return esum(u,i,v,w,x);
    a:  return mkpf(car u,isimp1(cdr u,i,v,w,x));
    b:  z := gadd(appn(cddr z,cdar u),x,cadr z);
        return isimp1(multd!*(nb car z,cdr u),i,v,w,cdr z)
   end;

symbolic procedure nb u;
   if u then 1 else -1;

symbolic smacro procedure mkdot(u,v);
   % Returns a standard form for U . V.
   mksf('cons . ord2(u,v));

symbolic procedure dotsum(u,i,v,w,x);
   begin scalar i1,n,u1,u2,v1,y,z,z1;
        n := cdar u;
        if not (car (u1 := cdaar u) member i) then u1 := reverse u1;
        u2 := cadr u1;
        u1 := car u1;
        v1 := cdr u;
        if n=2 then go to h
         else if n neq 1 then typerr(n,"index power");
    a:  if u1 member i then go to a1
         else if null (z := mkdot(u1,u2)) then return nil
         else return mkf(z,isimp1(v1,i1,v,w,x));
    a1: i1 := delete(u1,i);
        if u1 eq u2 then return multf(ndims!*,isimp1(v1,i1,v,w,x))
         else if not (z := bassoc(u1,v)) then go to c
         else if u2 member i then go to d;
        if u1 eq car z then u1 := cdr z else u1 := car z;
        go to e;
    c:  if z := memlis(u1,x)
            then return isimp1(v1,
                              i1,
                              v,
                              w,
                              subst(u2,u1,z) . delete(z,x))
         else if z := memlis(u1,w)
            then return esum((('eps . subst(u2,u1,z)) . 1) . v1,
                             i1,
                             v,
                             delete(z,w),
                             x)
         else if u2 member i and null y then go to g;
        return isimp1(v1,i,(u1 . u2) . v,w,x);
    d:  z1 := u1;
        u1 := u2;
        if  z1 eq car z then u2 := cdr z else u2 := car z;
    e:  i := i1;
        v := delete(z,v);
        go to a;
    g:  y := t;
        z := u1;
        u1 := u2;
        u2 := z;
        go to a1;
    h:  if u1 eq u2 then rerror(hephys,7,
                                "2 invalid as repeated index power");
        i := i1 := delete(u1,i);
        u1 := u2;
        go to a
   end;

symbolic procedure mksf u;
   % U is a non-unique kernel.
   % Value is a (possibly substituted) standard form for U.
   begin scalar x;
        x := mksq(u,1);
        if denr x=1 then return numr x;
        !*sub2 := t;
        return !*p2f mksp(u,1)
   end;


% ********* FUNCTIONS FOR SIMPLIFYING DIRAC GAMMA MATRICES **********

symbolic procedure gadd(u,v,l);
   begin scalar w,x; integer n;
        n := 0;                 % Number of gamma5 interchanges.
        if not (x := atsoc(l,v)) then go to a;
        v := delete(x,v);
        w := cddr x;            % List being built.
        x := cadr x;            % True if gamma5 remains.
    a:  if null u then return (evenp n . (l . x . w) . v)
         else if car u eq 'a then go to c
         else w := car u . w;
    b:  u := cdr u;
        go to a;
    c: if ndims!* neq 4
         then rerror(hephys,8,"Gamma5 not allowed unless vecdim is 4");
       x := not x;
        n := length w + n;
        go to b
   end;


% ***** FUNCTIONS FOR COMPUTING TRACES OF DIRAC GAMMA MATRICES *******

symbolic procedure spur0(u,i,v1,v2,v3);
   begin scalar l,w,i1,kahp,n,z;
      l := car u;
      n := 1;
      z := cadr u;
      u := reverse cddr u;
      if z then u := 'a . u; % Gamma5 remains.
      if null u then go to end1
       else if null flagp(l,'nospur)
        then if car u eq 'a and (length u<5 or hevenp u)
                  or not(car u eq 'a) and not hevenp u
               then return nil
              else if null i then <>;
    a:
      if null u then go to end1
       else if car u member i
        then if car u member cdr u
               then <>;
                      kahp := t;
                      i1 := car u . i1;
                      go to a1>>
              else if car u member i1 then go to a1
              else if z := bassoc(car u,v1)
               then <>
              else if z := memlis(car u,v2)
               then return if flagp(l,'nospur)
                                and null v1
                                and null v3
                                and null cdr v2
                             then mkf(mkgamf(append(reverse w,u),l),
                                      multfs(n,mkepsf z))
                            else multd!*(n,
                                         isimp1(spur0(
           l . (nil . append(reverse u,w)),nil,nil,delete(z,v2),v3),
                                                i,v1,list z,nil))
              else if z := memlis(car u,v3)
               then if ndims!*=4
                      then return spur0i(u,delete(car u,i),v1,v2,
                                         delete(z,v3),l,n,w,z)
                     else <>
              else rerror(hephys,9,list("Unmatched index",car u));
    a1:
      w := car u . w;
      u := cdr u;
      go to a;
    end1:
      if kahp
        then if ndims!*=4
               then <>
              else z := spurdim(w,i,l,nil,1)
       else z := spurr(w,l,nil,1);
      return if null z then nil
              else if get('eps,'klist) and not flagp(l,'nospur)
               then isimp1(multfs(n,z),i,v1,v2,v3)
              else multfs(z,isimp1(n,i,v1,v2,v3))
   end;

symbolic procedure spur0i(u,i,v1,v2,v3,l,n,w,z);
   begin scalar kahp,i1;
      if flagp(l,'nospur) and flagp(car z,'nospur)
        then rerror(hephys,10,
                    "NOSPUR on more than one line not implemented")
       else if flagp(car z,'nospur) then kahp := car z;
      z := cdr z;
      i1 := car z;
      z := reverse cdr z;
      if i1 then z := 'a . z;
      i1 := nil;
      <>;
        z := cdr z;
        u := cdr u;
        if flagp(l,'nospur)
          then <>;
        w := reverse w;
        if null ((null u or not eqcar(w,'a)) and (u := append(u,w)))
          then <>
   end;

symbolic procedure spurdim(u,i,l,v,n);
   begin scalar w,x,y,z,z1; integer m;
    a:  if null u
          then return if null v then n
                else if flagp(l,'nospur) then multfs(n,mkgamf(v,l))
                else multfs(n,sprgen v)
         else if not(car u memq cdr u)
          then <>;
        x := car u;
        y := cdr u;
        w := y;
        m := 1;
    b:  if x memq i then go to d
         else if not(x eq car w) then go to c
         else if null(w := mkdot(x,x)) then return z;
        if x memq i then w := ndims!*;
        return addfs(mkf(w,spurdim(delete(x,y),i,l,v,n)),z);
    c:  z1 := mkdot(x,car w);
        if car w memq i
          then z := addfs(spurdim(subst(x,car w,remove(y,m)),
                                  i,l,v,2*n),z)
         else if z1
          then z := addfs(mkf(z1,spurdim(remove(y,m),i,l,v,2*n)),z);
        w := cdr w;
        n := -n;
        m := m+1;
        go to b;
   d:   while not(x eq car w) do
         <>;
        return addfs(mkf(ndims!*,spurdim(delete(x,y),i,l,v,n)),z)
   end;

symbolic procedure appn(u,n);
   if n=1 then u else append(u,appn(u,n-1));

symbolic procedure other(u,v);
   if u eq car v then cdr v else car v;

symbolic procedure kahane(u,i,l);
   % The Kahane algorithm for Dirac matrix string reduction.
   % Ref: Kahane, J., Journ. Math. Phys. 9 (1968) 1732-1738.
   begin scalar p,r,v,w,x,y,z; integer k,m;
        k := 0;
%   mark:
        if eqcar(u,'a) then go to a1;
    a:  p := not p;             % Vector parity.
        if null u then go to d else if car u member i then go to c;
    a1: w := aconc!*(w,car u);
    b:  u := cdr u;
        go to a;
    c:  y := car u . p;
        z := (x . (y . w)) . z;
        x := y;
        w := nil;
        k := k+1;
        go to b;
    d:  z := (nil . (x . w)) . z;
        % Beware ... end of string has opposite convention.
%   pass2:
        m := 1;
    l1: if null z then go to l9;
        u := caar z;
        x := cadar z;
        w := cddar z;
        z := cdr z;
        m := m+1;
        if null u then go to l2
         else if (car u eq car x) and exc(x,cdr u) then go to l7;
        w := reverse w;
        r := t;
    l2: p := not exc(x,r);
        x := car x;
        y := nil;
    l3: if null z
          then rerror(hephys,11,"Unmatched index" .
                           if y then if not atom cadar y then cadar y
                                   else if not atom caar y then caar y
                                      else nil
                             else nil)
          else if (x eq car (i := cadar z)) and not exc(i,p)
           then go to l5
          else if (x eq car (i := caar z)) and exc(i,p) then go to l4;
        y := car z . y;
        z := cdr z;
        go to l3;
    l4: x := cadar z;
        w := appr(cddar z,w);
        r := t;
        go to l6;
    l5: x := caar z;
        w := append(cddar z,w);
        r := nil;
    l6: z := appr(y,cdr z);
        if null x then go to l8
         else if not eqcar(u,car x) then go to l2;
    l7: if w and cdr u then w := aconc!*(cdr w,car w);
        v := multfs(brace(w,l,nil),v);  % v := ('brace . l . w) . v;
        go to l1;
    l8: v := mkg(w,l);                  % v := list('g . l . w);
        z := reverse z;
        k := k/2;
        go to l1;
    l9: u := 2**k;
        if not evenp(k-m) then u := - u;
        return multd!*(u,v)             % return 'times . u . v;
   end;

symbolic procedure appr(u,v);
   if null u then v else appr(cdr u,car u . v);

symbolic procedure exc(u,v);
   if null cdr u then v else not v;

symbolic procedure brace(u,l,i);
   if null u then 2
    else if xnp(i,u) or flagp(l,'nospur)
     then addf(mkg1(u,l),mkg1(reverse u,l))
    else if car u eq 'a
       then if hevenp u then addfs(mkg(u,l),
                                 negf mkg('a . reverse cdr u,l))
             else mkf(mka l,spr2(cdr u,l,2,nil))
    else if hevenp u then spr2(u,l,2,nil)
    else spr1(u,l,2,nil);

symbolic procedure spr1(u,l,n,b);
   if null u then nil
    else if null cdr u then multd!*(n,mkg1(u,l))
    else begin scalar m,x,z;
               x := u;
               m := 1;
          a:   if null x then return z;
               z:= addfs(mkf(mkg1(list car x,l),
                              if null b then spurr(remove(u,m),l,nil,n)
                               else spr1(remove(u,m),l,n,nil)),
                         z);
               x := cdr x;
               n :=  - n;
               m := m+1;
               go to a
    end;

symbolic procedure spr2(u,l,n,b);
   if null cddr u and null b then multd!*(n,mkdot(car u,cadr u))
    else (lambda x; if b then addfs(spr1(u,l,n,b),x) else x)
       addfs(spurr(u,l,nil,n),
             mkf(mka l,spurr(append(u,list 'a),l,nil,n)));

symbolic procedure hevenp u;
   null u or not hevenp cdr u;

symbolic procedure bassoc(u,v);
   if null v then nil
    else if u eq caar v or u eq cdar v then car v
    else bassoc(u,cdr v);

symbolic procedure memlis(u,v);
   if null v then nil
    else if u member car v then car v
    else memlis(u,cdr v);

symbolic procedure spurr(u,l,v,n);
   begin scalar w,x,y,z,z1; integer m;
    a:  if null u then go to b
         else if car u member cdr u then go to g;
        v := car u . v;
        u := cdr u;
        go to a;
    b:  return if null v then n
         else if flagp(l,'nospur) then multd!*(n,mkgamf(v,l))
         else multd!*(n,sprgen v);
    g:  x := car u;
        y := cdr u;
        w := y;
        m := 1;
    h:  if not(x eq car w) then go to h1
         else if null(w:= mkdot(x,x)) then return z
         else return addfs(mkf(w,spurr(delete(x,y),l,v,n)),z);
    h1: z1 := mkdot(x,car w);
        if z1 then z:= addfs(mkf(z1,spurr(remove(y,m),l,v,2*n)),z);
        w := cdr w;
        n :=  - n;
        m := m+1;
        go to h
   end;

symbolic procedure sprgen v;
   begin scalar x,y,z;
        if not (car v eq 'a) then return sprgen1(v,t)
         else if null (x := comb(v := cdr v,4)) then return nil
         else if null cdr x then go to e;
    c:  if null x then return multpf('i to 1,z);
        y := mkepsf car x;
        if asign(car x,v,1)=-1 then y := negf y;
        z := addf(multf(y,sprgen1(setdiff(v,car x),t)),z);
    d:  x := cdr x;
        go to c;
    e:  z := mkepsf car x;
        go to d
   end;

symbolic procedure asign(u,v,n);
   if null u then n else asign(cdr u,v,asign1(car u,v,-1)*n);

symbolic procedure asign1(u,v,n);
   if u eq car v then n else asign1(u,cdr v,-n);

symbolic procedure sprgen1(u,b);
   if null u then nil
    else if null cddr u then (lambda x; if b then x else negf x)
                                mkdot(car u,cadr u)
    else begin scalar w,x,y,z;
               x := car u;
               u := cdr u;
               y := u;
          a:   if null u then return z
                else if null(w:= mkdot(x,car u)) then go to c;
               z := addf(multf(w,sprgen1(delete(car u,y),b)),z);
          c:   b := not b;
               u := cdr u;
               go to a
    end;

% ****************** FUNCTIONS FOR EPSILON ALGEBRA ******************


put('eps,'simpfn,'simpeps);

symbolic procedure mkepsf u;
   (lambda x; (lambda y; if null car x then negf y else y) mksf cdr x)
        mkepsk u;

symbolic procedure esum(u,i,v,w,x);
   begin scalar y,z,z1;
      z := car u;
      u := cdr u;
      if cdr z neq 1
       then u := multf(exptf(mkepsf cdar z,cdr z-1),u);
      z := cdar z;
  a:  if repeats z then return nil;
  b:  if null z then return isimp1(u,i,v,reverse y . w,x)
       else if car z member i
        then <>
                else if z1 := memlis(car z,w)
                 then <>>>;
      y := car z . y;
      z := cdr z;
      go to b
   end;

symbolic procedure emult u;
   if null cdr u then mkepsf car u
    else if null cddr u then emult1(car u,cadr u,nil)
    else multfs(emult1(car u,cadr u,nil),emult cddr u);

symbolic procedure emult1(u,v,i);
   (lambda (x,y);
         (lambda (m,n);
               if m=4 then 24*n
                else if m=3 then multd(6*n,mkdot(car x,car y))
                else multd!*(n*(if m = 0 then 1 else m),
                           car detq maplist(x,
                             function (lambda k;
                               maplist(y,
                                 function (lambda j;
                                   mkdot(car k,car j) . 1))))))
            (length i,
             (lambda j; nb if permp(u,append(i,x)) then not j else j)
                permp(v,append(i,y))))
      (setdiff(u,i),setdiff(v,i));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/intfierz.red0000644000175000017500000001604511526203062024340 0ustar  giovannigiovannimodule intfierz; % Interface with Rodionov-Fierzing Routine.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


  exports  calc_map_tar,calc_den_tar,pre!-calc!-map_ $
  imports    mk!-numr,map_!-to!-strand $

lisp$

%----------- DELETING VERTS WITH _0'S ------------------------------$

%symbolic procedure sort!-map_(map_,tadepoles,deltas,s)$
%if null map_ then list(s,tadepoles,deltas)
%else
%  begin
%     scalar vert,edges$
%            vert:=incident1('!_0,car map_,'ll)$
%   return
%       if null vert then sort!-map_(cdr map_,tadepoles,deltas,
%                                                car map_ . s)
%       else if car vert = cadr vert then
%                sort!-map_(cdr map_,caar vert . tadepoles,deltas,s)
%            else sort!-map_(cdr map_,tadepoles,list('cons,caar vert,
%                                    caadr vert) . deltas,s)
% end$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%% modified 17.09.90 A.Taranov %%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure sort!-map_(map_,tadepoles,deltas,poles,s)$
% tadepoles are verts with 1 0_ edge and contracted others
% deltas are verts with 1 0_ edge
% poles are verts with at list 2 0_ edges
if null map_ then list(s,tadepoles,deltas,poles)
else
  begin
  scalar vert,tdp$
    vert:=incident1('!_0,car map_,'ll)$
    if null vert then tdp:=tadepolep car map_
    else %%%% vertex contain !_0 edge
      return
        if (caar vert = '!_0) then
          sort!-map_(cdr map_,tadepoles,deltas,caadr vert . poles,s)
        else if (caadr vert = '!_0) then
             sort!-map_(cdr map_,tadepoles,deltas,caar vert . poles,s)
             else if car vert = cadr vert then
                    sort!-map_(cdr map_,caar vert . tadepoles,deltas,
                                poles,s)
                  else sort!-map_(cdr map_,tadepoles,list('cons,
                                   caar vert,caadr vert) . deltas,poles,
                                   s)$
   %%%%% here car Map_  was checked to be a real tadpole
   return
     if null tdp then sort!-map_(cdr map_,tadepoles,deltas,
                                        poles,car map_ . s)
     else sort!-map_(cdr map_,cadr tdp . tadepoles,deltas,
                      caar tdp . poles,s)
 end$

symbolic procedure tadepolep vrt;   %%%%%% 17.09.90
% return edge1 . edge2 if vrt is tadpole,
% NIL otherwise.
% edge1 correspond to 'pole', edge2 - to 'loop' of a tadpole.
if car vrt = cadr vrt then caddr vrt . car vrt
else if car vrt = caddr vrt then cadr vrt . car vrt
     else if cadr vrt = caddr vrt then car vrt . cadr vrt
          else nil;

symbolic procedure del!-tades(tades,edges)$
if null tades then edges
else del!-tades(cdr tades,delete(car tades,edges))$

symbolic procedure del!-deltas(deltas,edges)$
if null cdr deltas then edges
else del!-deltas(cdr deltas,del!-tades(cdar deltas,edges))$

%--------------- EVALUATING MAP_S -----------------------------------$

symbolic procedure pre!-calc!-map_(map_,edges)$
% : (STRAND NEWMAP_ TADEPOLES DELTAS)$
begin
  scalar strand,w$
         w:=sort!-map_(map_,nil,list 1,nil,nil)$

%        delete from edge list deltas,poles and tades
         edges:=del!-deltas(caddr w,
                    del!-tades(cadr w,delete('!_0,edges)))$
         strand:= if car w then map_!-to!-strand(edges,car w)
                  else nil$
    return strand . w
end$


symbolic procedure calc_map_tar(gstrand,alst)$
% THIRD  VERSION.$
begin
 scalar poles,edges,strand,deltas,tades,map_$
        strand:=car gstrand$
        map_:=cadr gstrand$
        tades:=caddr gstrand     $
        deltas:=car cdddr gstrand $
        poles:= car cddddr gstrand $
 if ev!-poles(poles,alst) then   return 0;   %%%%% result is zero
 return constimes list(constimes deltas,
                      constimes ev!-tades(tades,alst),
                     (if null map_ then 1
                      else strand!-alg!-top(strand,map_,alst)))
end$

symbolic procedure ev!-poles(poles,alst)$ %%% 10.09.90
 if null poles then nil
 else if getedge(car poles,alst) = 0 then ev!-poles(cdr poles,alst)
      else poles$


symbolic procedure ev!-deltas(deltas)$
  if null deltas then list 1
  else ('cons . car deltas) . ev!-deltas(cdr deltas)$

symbolic procedure ev!-tades(tades,alst)$
  if null tades then list 1
  else binc(ndim!*,getedge(car tades,alst))
                                        . ev!-tades(cdr tades,alst)$

%------------------------ DENOMINATOR CALCULATION -------------------$

symbolic        procedure ev!-edgeloop(edge,alst)$
% EVALUATES LOOP OF 'EDGE' COLORED VIA 'ALST'$
binc(ndim!*,getedge(s!-edge!-name edge,alst) )$

symbolic procedure ev!-denom2(vert,alst)$
% EVALUATES DENOM FOR PROPAGATOR$
ev!-edgeloop(car vert,alst)$

symbolic procedure ev!-denom3(vert,alst)$
% EVALUATES DENOM FOR 3 - VERTEX$
begin
    scalar e1,e2,e3,lines,sign,!3j,numr$
    e1:=getedge(s!-edge!-name car vert,alst)$
    e2:=getedge(s!-edge!-name cadr vert,alst)$
    e3:=getedge(s!-edge!-name caddr vert,alst)$
    lines:=(e1+e2+e3)/2$
    e1:=lines-e1$
    e2:=lines-e2$
    e3:=lines-e3$
    sign:=(-1)**(e1*e2+e1*e3+e2*e3)$
    numr:=mk!-numr(ndim!*,0,lines)$
    numr:=(if numr then (constimes numr)
           else 1)$
    !3j:=listquotient(numr,
                   factorial(e1)*factorial(e2)*factorial(e3)*sign)$
 return !3j
end$

symbolic procedure binc(n,p)$
% BINOMIAL COEFF C(N,P)$
if 0 = p then 1 else
listquotient(constimes mk!-numr(n,0,p),factorial p)$

symbolic procedure calc_den_tar(den_,alst)$
(lambda u$  if null u then 1
            else if null cdr u then car u
                 else constimes u           )
                                            denlist(den_,alst)$

symbolic procedure denlist(den_,alst)$
if null den_ then nil
else if length car den_ = 2 then
                   ev!-denom2(car den_,alst) . denlist(cdr den_,alst)
     else ev!-denom3(car den_,alst) . denlist(cdr den_,alst)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/physop.tst0000644000175000017500000000507511526203062024071 0ustar  giovannigiovanniCOMMENT
        test file for the PHYSOP package;
% load_package physop;  % Load a compiled version of the physop package.
% showtime;
linelength(72)$
% Example 1: Quantum Mechanics of a Dirac particle in an external
%                      electromagnetic field
VECOP P,A,K;
SCALOP M;
NONCOM P,A;
PHYSINDEX J,L;
oporder M,K,A,P;

% we have to set off allfac here since otherwise there appear
% spurious negative powers in the printed output
 off allfac;
FOR ALL J,L LET COMM(P(J),A(L))=K(J)*A(L);
H:= COMMUTE(P**2/(2*M),E/(4*M**2)*(P DOT A));
% showtime;
%assign the corresponding value to the adjoint of H
H!+ := adj H;
% showtime;
% note the ordering of operators in the result!
% enhance the readability of the output
 on allfac;
ON CONTRACT;
H;
% showtime;
% Example 2: Virasoro Algebra from Conformal Field Theory


operator  del;  % this is just a definition of a delta function
for all n such that numberp n let del(n) =
     if n=0 then 1
     else 0;

scalop l;
noncom l,l;
state bra,ket;
% commutation relation of the operator l;
for all n,m let comm(l(n),l(m)) =
      (m-n)*l(n+m)+c/12*(m**3-m)*del(n+m)*unit; %modified 1.1

for all n let l!+(n) = l(-n);


% relation for the states
for all h let bra!+(h) = ket(h);
for all p,q let bra(q) | ket(p) = del(p-q);

for all r,h such that r < 0 or (r <2 and h=0) let
             l(r) | ket(h) = 0;

for all r,h such that r > 0 or (r  > -2 and h = 0) let
             bra(h) | l(r) = 0;

% define a procedure to calculate V.E.V.
procedure Vak(X);
bra(0) | X | ket(0);

% and now some calculations;
MA:= adj(l(3)*l(5))*l(3)*l(5);  %modified 1.1
% showtime;

% here is the VEV of m
vak(Ma);
% showtime;
% and now calculate another matrix element

matel := bra(1) | ma  | ket(1);  %modified 1.1
% showtime;
% this evaluation is incomplete so supply the missing relation
for all h let l(0) | ket(h) = h*ket(h);
% and reevaluate matel
matel := matel;
% showtime;


% Example 4: some manipulations with gamma matrices to demonstrate
%            the use of commutators and anticommutators


off allfac;
vecop gamma,q;
tensop sigma(2);
antisymmetric sigma;
noncom gamma,gamma;
noncom sigma,gamma;
physindex mu,nu;
operator delta;
for all mu,nu let anticomm(gamma(mu),gamma(nu))=2*delta(mu,nu)*unit,
                  comm(gamma(mu),gamma(nu))=2*I*sigma(mu,nu);

oporder p,q,gamma,sigma;
off allfac;
on anticom;
(gamma dot p)*(gamma dot q);
% showtime;

off anticom;
(gamma dot p)*(gamma dot q);
% showtime;

commute((gamma dot p),(gamma dot q));
% showtime;
anticommute((gamma dot p),(gamma dot q));
on anticom;
anticommute((gamma dot p),(gamma dot q));
% showtime;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/physop.rlg0000644000175000017500000001166111527635055024055 0ustar  giovannigiovanniFri Feb 18 21:27:26 2011 run on win32
COMMENT
        test file for the PHYSOP package;

% load_package physop;  % Load a compiled version of the physop package.
% showtime;
linelength(72)$


% Example 1: Quantum Mechanics of a Dirac particle in an external
%                      electromagnetic field
VECOP P,A,K;


SCALOP M;


NONCOM P,A;


PHYSINDEX J,L;


oporder M,K,A,P;



% we have to set off allfac here since otherwise there appear
% spurious negative powers in the printed output
 off allfac;


FOR ALL J,L LET COMM(P(J),A(L))=K(J)*A(L);


H:= COMMUTE(P**2/(2*M),E/(4*M**2)*(P DOT A));


            -1    -1    -1
h := (2*e*(m  )*(m  )*(m  )*k(idx1)*a(idx2)*p(idx1)*p(idx2)

             -1    -1    -1
       + e*(m  )*(m  )*(m  )*k(idx1)*k(idx1)*a(idx2)*p(idx2)

             -1    -1    -1
       + e*(m  )*(m  )*(m  )*k(idx1)*k(idx1)*k(idx2)*a(idx2)

               -1    -1    -1
       + 2*e*(m  )*(m  )*(m  )*k(idx1)*k(idx2)*a(idx2)*p(idx1))/8

% showtime;
%assign the corresponding value to the adjoint of H
H!+ := adj H;


  +                +          +          +          +      -1      -1
(h ) := (e*(a(idx2) )*(k(idx1) )*(k(idx1) )*(k(idx2) )*(m!+  )*(m!+  )

              -1                +          +          +          +
         *(m!+  ) + 2*e*(p(idx1) )*(a(idx2) )*(k(idx1) )*(k(idx2) )

              -1      -1      -1                +          +          +
         *(m!+  )*(m!+  )*(m!+  ) + 2*e*(p(idx1) )*(p(idx2) )*(a(idx2) )

                  +      -1      -1      -1              +          +
         *(k(idx1) )*(m!+  )*(m!+  )*(m!+  ) + e*(p(idx2) )*(a(idx2) )

                  +          +      -1      -1      -1
         *(k(idx1) )*(k(idx1) )*(m!+  )*(m!+  )*(m!+  ))/8

% showtime;
% note the ordering of operators in the result!
% enhance the readability of the output
 on allfac;


ON CONTRACT;


H;


       3
(e*m!-1

                                            2            2
 *(2*a dot p*k dot p + 2*k dot a*k dot p + k *a dot p + k *k dot a))/8

% showtime;
% Example 2: Virasoro Algebra from Conformal Field Theory


operator  del;

  % this is just a definition of a delta function
for all n such that numberp n let del(n) =
     if n=0 then 1
     else 0;



scalop l;


noncom l,l;


state bra,ket;


% commutation relation of the operator l;
for all n,m let comm(l(n),l(m)) =
      (m-n)*l(n+m)+c/12*(m**3-m)*del(n+m)*unit;

 %modified 1.1

for all n let l!+(n) = l(-n);




% relation for the states
for all h let bra!+(h) = ket(h);


for all p,q let bra(q) | ket(p) = del(p-q);



for all r,h such that r < 0 or (r <2 and h=0) let
             l(r) | ket(h) = 0;



for all r,h such that r > 0 or (r  > -2 and h = 0) let
             bra(h) | l(r) = 0;



% define a procedure to calculate V.E.V.
procedure Vak(X);
bra(0) | X | ket(0);


vak


% and now some calculations;
MA:= adj(l(3)*l(5))*l(3)*l(5);


ma := 2*l(8)*l(-3)*l(-5) + 4*l(8)*l(-8) + l(5)*l(3)*l(-3)*l(-5)

       + 2*l(5)*l(3)*l(-8) + 6*l(5)*l(0)*l(-5) + 8*l(5)*l(-2)*l(-3)

       + 60*l(5)*l(-5) + 8*l(3)*l(2)*l(-5) + 10*l(3)*l(0)*l(-3)

                                                 2
       + 112*l(3)*l(-3) + 64*l(2)*l(-2) + 60*l(0)  + 556*l(0)

             2
       + 20*c *unit + 2*c*l(5)*l(-5) + 10*c*l(3)*l(-3) + 80*c*l(0)

       + 332*c*unit
  %modified 1.1
% showtime;

% here is the VEV of m
vak(Ma);


4*c*(5*c + 83)

% showtime;
% and now calculate another matrix element

matel := bra(1) | ma  | ket(1);

        *************** WARNING: ***************
Evaluation incomplete due to missing elementary relations

matel := bra(1) | (l(0) | 556*ket(1)) + bra(1) | (l(0) | 80*c*ket(1))

                                                   2
          + bra(1) | (l(0)*l(0) | 60*ket(1)) + 20*c  + 332*c
  %modified 1.1
% showtime;
% this evaluation is incomplete so supply the missing relation
for all h let l(0) | ket(h) = h*ket(h);


% and reevaluate matel
matel := matel;


               2
matel := 4*(5*c  + 103*c + 154)

% showtime;


% Example 4: some manipulations with gamma matrices to demonstrate
%            the use of commutators and anticommutators


off allfac;


vecop gamma,q;


tensop sigma(2);


antisymmetric sigma;


noncom gamma,gamma;


noncom sigma,gamma;


physindex mu,nu;


operator delta;


for all mu,nu let anticomm(gamma(mu),gamma(nu))=2*delta(mu,nu)*unit,
                  comm(gamma(mu),gamma(nu))=2*I*sigma(mu,nu);



oporder p,q,gamma,sigma;


off allfac;


on anticom;


(gamma dot p)*(gamma dot q);


p(idx4)*q(idx5)*gamma(idx4)*gamma(idx5)

% showtime;

off anticom;


(gamma dot p)*(gamma dot q);


p(idx6)*q(idx7)*gamma(idx6)*gamma(idx7)

% showtime;

commute((gamma dot p),(gamma dot q));


2*i*p(idx8)*q(idx9)*sigma(idx8,idx9)

% showtime;
anticommute((gamma dot p),(gamma dot q));


2*p(idx10)*q(idx11)*gamma(idx10)*gamma(idx11)

 - 2*i*p(idx10)*q(idx11)*sigma(idx10,idx11)

on anticom;


anticommute((gamma dot p),(gamma dot q));


2*delta(idx13,idx12)*p(idx12)*q(idx13)

% showtime;

end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 11 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/map2strn.red0000644000175000017500000002152611526203062024254 0ustar  giovannigiovannimodule map2strn;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%************* TRANSFORMATION OF MAP TO STRAND **********************$
%                                                                    $
%                       25.11.87                                     $
%                                                                    $
%********************************************************************$

  exports    color!-strand,contract!-strand $
  imports  nil$

%---------------- utility added 09.06.90 ---------------------------
symbolic procedure constimes u;
% u=list of terms
% inspect u, delete all 1's
% and form smar product   $
 cstimes(u,nil)$

symbolic procedure cstimes(u,s);
if null u then
  if null s then 1
  else if null cdr s then car s
       else 'times . s
else if car u = 1 then cstimes(cdr u,s)
     else cstimes(cdr u,car u . s)$

symbolic procedure consrecip u;
% do same as consTimes
if or(car u = 1,car u = -1) then car u
else 'recip . u$

symbolic procedure listquotient(u,v)$
% the same !!!
if v=1 then u
else
  if v = u then 1
  else list('quotient,u,v)$

symbolic procedure consplus u;
% u=list of terms
% inspect u, delete all 0's
% and form smar sum   $
 csplus(u,nil)$

symbolic procedure csplus(u,s);
if null u then
  if null s then 0
  else if null cdr s then car s
       else 'plus . s
else if car u = 0 then csplus(cdr u,s)
     else csplus(cdr u,car u . s)$

%--------------------------------------------------------------------



%---------------- CONVERTING OF MAP TO STRAND DIAGRAM ---------------$

symbolic procedure map_!-to!-strand(edges,map_)$
%.....................................................................
% ACTION: CONVERTS "MAP_" WITH "EDGES" INTO STRAND DIAGRAM.
% STRAND ::= ,
% STRAND VERTEX ::=  . ( ),
% ROAD ::=  . .
% LIST1,2 CORRESPOND TO OPPOSITE SIDES OF STRAND VERTEX.
% ROADS LISTED CLOCKWISE.
%....................................................................$
if null edges then nil
else mk!-strand!-vertex(car edges,map_) .
                                map_!-to!-strand(cdr edges,map_)$

%YMBOLIC PROCEDURE MAP_!-TO!-STRAND(EDGES,MAP_)$
%F NULL EDGES THEN NIL
%LSE (LAMBDA SVERT$ IF SVERT THEN SVERT .
%                               MAP_!-TO!-STRAND(CDR EDGES,MAP_)
%                   ELSE MAP_!-TO!-STRAND(CDR EDGES,MAP_) )
%          MK!-STRAND!-VERTEX(CAR EDGES,MAP_)$

symbolic procedure mk!-strand!-vertex(edge,map_)$
begin
  scalar vert1,vert2,tail$
         tail:=incident(edge,map_,1)$
         vert1:=car tail$
         tail:=incident(edge,cdr tail,add1 cdar vert1)$
         vert2:= if null tail then mk!-external!-leg edge
                 else car tail$
   return %F NULL VERT2 THEN NIL
               mk!-strand!-vertex2(edge,vert1,vert2)
end$

symbolic procedure incident(edge,map_,vertno)$
if null map_ then nil
else (lambda z$ if z then  z . cdr map_
                else incident(edge,cdr map_,add1 vertno) )
             incident1(              edge,car map_,vertno)$

symbolic procedure incident1(edname,vertex,vertno)$
if eq(edname,s!-edge!-name car vertex) then
             mk!-road!-name(cadr vertex,caddr vertex,vertno)
else if eq(edname,s!-edge!-name cadr vertex) then
         mk!-road!-name(caddr vertex,car vertex,vertno)
     else if eq(edname,s!-edge!-name caddr vertex) then
                 mk!-road!-name(car vertex,cadr vertex,vertno)
          else nil$

symbolic procedure mk!-strand!-vertex2(edge,vert1,vert2)$
list(edge,   vert1,             vert2)$

%------------------ COLOURING OF ROADS IN STRAND --------------------$

symbolic procedure color!-strand(alst,map_,count)$
%.....................................................................
% ACTION: GENERATE REC. ALIST COLORING STRAND, CORRESPONDING TO "MAP_".
% COLORING OF STRAND INDUCED BY "MAP_" COLORING, DEFINED BY ALIST
% "ALST". "COUNT" COUNTS MAP_ VERTICES. INITIALLY IS 1.
% REC.ALIST::= ( ... <(ATOM1 . COL1 ATOM2 . COL2 ...) . NUMBER> ... )
% WHERE COL1 IS COLOR OF ROAD=ATOM1 . NUMBER.
%....................................................................$
if null map_ then nil
else  (color!-roads(alst,car map_) . count) .
                          color!-strand(alst,cdr map_,add1 count)$

symbolic procedure color!-roads(alst,vertex)$
begin
    scalar e1,e2,e3,lines$
    e1:=getedge(s!-edge!-name car vertex,alst)$
    e2:=getedge(s!-edge!-name cadr vertex,alst)$
    e3:=getedge(s!-edge!-name caddr vertex,alst)$
    lines:=(e1+e2+e3)/2$
    e1:=lines-e1$
    e2:=lines-e2$
    e3:=lines-e3$
  return list(
               s!-edge!-name car vertex . e1,
               s!-edge!-name cadr vertex . e2,
               s!-edge!-name caddr vertex . e3)
end$

symbolic procedure zero!-roads l$
%---------------------------------------------------------------------
% L IS OUTPUT OF COLOR!-STRAND
%--------------------------------------------------------------------$
if null l then nil
else (lambda z$ if z then z . zero!-roads cdr l
                else zero!-roads cdr l)
              z!-roads car l$

symbolic procedure z!-roads y$
(lambda w$  w and (car w . cdr y))
    ( if (0=cdr caar y)then caar y
      else if  (0=cdr cadar y) then cadar y
           else if (0=cdr caddar y) then caddar y
                else nil)$

%------------------- CONTRACTION OF STRAND --------------------------$

symbolic procedure deletez1(strand,alst)$
%.....................................................................
% ACTION: DELETES FROM "STRAND" VERTICES WITH NAMES HAVING 0-COLOR
% VIA MAP_-COLORING ALIST "ALST".
%....................................................................$
if null strand then nil
else if 0 = cdr assoc(caar strand,alst) then
                          deletez1(cdr strand,alst)
     else car strand . deletez1(cdr strand,alst)$

symbolic procedure contract!-strand(strand,slst)$
%.....................................................................
% ACTION: CONTRACTS "STRAND".
% "SLST" IS REC. ALIST COLORING "STRAND"
%....................................................................$
contr!-strand(strand,zero!-roads slst)$

symbolic procedure contr!-strand(strand,zlst)$
if null zlst then strand
else contr!-strand(contr1!-strand(strand,car zlst),cdr zlst)$

symbolic procedure contr1!-strand(strand,rname)$
contr2!-strand(strand,rname,nil,nil)$

symbolic procedure contr2!-strand(st,rname,rand,flag_)$
if null st then rand
else (lambda z$
          if z then
            if member(car z,cdr z) then sappend(st,rand)  % 16.12 ****$
            else
                if null flag_ then
                  contr2!-strand(contr2(z,cdr st,rand),rname,nil,t)
                else contr2(z,cdr st,rand)
          else contr2!-strand(cdr st,rname,car st . rand,nil)  )
      contrsp(car st,rname)$

symbolic procedure contrsp(svertex,rname)$
contrsp2(cadr svertex,caddr svertex,rname)
                or
contrsp2(caddr svertex,cadr svertex,rname)$

symbolic procedure contrsp2(l1,l2,rname)$
if 2 = length l1 then
 if rname = car l1 then (cadr l1) . l2
 else if rname = cadr l1 then (car l1) . l2
else nil$

symbolic procedure contr2(single,st,rand)$
if null st then contr(single,rand)
else if null rand then contr(single,st)
     else split!-road(single,car st) . contr2(single,cdr st,rand)$

symbolic procedure contr(single,strand)$
if null strand then nil
else split!-road(single,car strand) . contr(single,cdr strand)$

symbolic procedure split!-road(single,svertex)$
list(car svertex,
sroad(car single,cdr single,cadr svertex),
             sroad(car single,cdr single,caddr svertex))$

symbolic procedure sroad(line_,lines,lst)$
if null lst then nil
else if line_ = car lst then sappend(lines,cdr lst)
     else car lst . sroad(line_,lines,cdr lst)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/cvit.rlg0000644000175000017500000001346511527635055023504 0ustar  giovannigiovanniFri Feb 18 21:27:26 2011 run on win32
% Tests of Cvitanovic Package.


% COPYRIGHT (C) 1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE UNIV.
% CVITBUBLE  TEST OF CVITANOVIC PACKAGE
% AUTHOR     A. KRYUKOV, ARODIONOV, A.TARANOV
% VERSION    1.1
% RELEASE    18-SEP-90

index j1,j2,j3,j4,j5,j6,j7,j8,j9,j0;


vecdim n$



%       Tests of the weels with buble
%       (Use notation from SIGSAM Bull, 1989, v.23, no.4, pp.15-24)

g(l,j1,j2,j2,j1);


 2
n


g(l,j1,j2)*g(l1,j3,j1,j2,j3);


 2
n

g(l,j1,j2)*g(l1,j3,j1,j3,j2);


n*( - n + 2)

g(l,j1,j2)*g(l1,j3,j3,j2,j1);


 2
n


g(l,j1,j2,j3,j4)*g(l1,j1,j2,j3,j4);


n*(3*n - 2)

g(l,j1,j2)*g(l1,j3,j4,j1,j2,j4,j3);


 3
n

g(l,j1,j2,j3,j4)*g(l1,j1,j4,j2,j3);


n*( - n + 2)

g(l,j1,j2)*g(l1,j3,j4,j1,j4,j3,j2);


    2
n*(n  - 4*n + 4)


g(l,j1,j2)*g(l1,j3,j4,j5,j1,j2,j3,j4,j5);


 2      2
n *( - n  + 6*n - 4)

g(l,j1,j2,j3,j4)*g(l1,j5,j1,j2,j3,j5,j4);


         2
n*( - 3*n  + 8*n - 4)

g(l,j1,j2,j3,j4,j5,j1)*g(l1,j2,j5,j3,j4);


 2
n *( - n + 2)

g(l,j1,j2,j3,j4,j5,j1,j2,j5)*g(l1,j4,j3);


 2      2
n *( - n  + 6*n - 4)


g(l,j1,j2)*g(l1,j3,j4,j5,j6,j1,j2,j3,j4,j5,j6);


 2   3       2
n *(n  - 12*n  + 28*n - 16)

g(l,j1,j2,j3,j4)*g(l1,j5,j6,j1,j2,j3,j4,j6,j5);


 3
n *(3*n - 2)

g(l,j1,j2,j3,j4,j5,j6)*g(l1,j1,j2,j4,j3,j6,j5);


      2
n*(7*n  - 22*n + 16)

g(l,j1,j2,j3,j4,j5,j6,j1,j2)*g(l1,j6,j3,j4,j5);


 2        2
n *( - 3*n  + 8*n - 4)

g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5)*g(l1,j6,j7);


 2   4       3        2
n *(n  - 20*n  + 100*n  - 160*n + 80)

g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3)*g(l1,j4,j5,j7,j6);


 2   3      2
n *(n  - 8*n  + 16*n - 8)

g(l,j1,j2,j3,j4,j5,j6,j7,j2)*g(l1,j1,j3,j4,j5,j6,j7);


          3       2
n*( - 15*n  + 60*n  - 76*n + 32)



% COPYRIGHT (C) 1988,1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE U.
% CVITEST   Test of CVITANOVIC PACKAGE
% AUTHOR    A. KRYUKOV, A.RODIONOV, A.TARANOV
% VERSION   1.2
% RELEASE   11-MAR-90

%
%     Test for trace of Dirac matrices.
%
%     All tests are the lattices with difference lines
%     (Use notation from SIGSAM Bull, 1989, v.4,no.23, pp.15-24)

index m1,m2,m3,m4,m5,m6,m7,m8,m9,m0;


index n1,n2,n3,n4,n5,n6,n7,n8,n9,n0;



vecdim n;



 g(l,n1,n1);


n

 g(l,n1,m1,n1,m1);


n*( - n + 2)


 g(l,n1,n2,n2,n1);


 2
n

 g(l,n1,n2,m1,n2,n1,m1);


    2
n*(n  - 4*n + 4)

 g(l,n1,n2,m1,m2,n2,n1,m2,m1);


    3      2
n*(n  - 8*n  + 24*n - 16)


 g(l,n1,n2,n3,n3,n2,n1);


 3
n

 g(l,n1,n2,n3,m1,n3,n2,n1,m1);


       3      2
n*( - n  + 6*n  - 12*n + 8)

 g(l,n1,n2,n3,m1,m2,n3,n2,n1,m2,m1);


    4       3       2
n*(n  - 12*n  + 60*n  - 112*n + 64)

 g(l,n1,n2,n3,m1,m2,m3,n3,n2,n1,m3,m2,m1);


       5       4        3        2
n*( - n  + 18*n  - 144*n  + 528*n  - 816*n + 416)

 g(l,n1,n2,n3,m1,n3,n1,n2,m1);


    3      2
n*(n  - 8*n  + 16*n - 8)

 g(l,n1,n2,n3,m1,m2,n3,n1,n2,m1,m2);


    4       3       2
n*(n  - 16*n  + 72*n  - 120*n + 64)

 g(l,n1,n2,n3,m1,m2,m3,n2,n3,n1,m3,m1,m2);


       5       4        3        2
n*( - n  + 22*n  - 172*n  + 584*n  - 848*n + 416)



% COPYRIGHT (C) 1988,1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE U.
% CVITWEEL  TEST OF CVITANOVIC PACKAGE
% AUTHOR    A. KRYUKOV, ARODIONOV, A.TARANOV
% VERSION   1.2
% RELEASE   11-MAR-90

index j1,j2,j3,j4,j5,j6,j7,j8,j9,j0;


vecdim n$



%       Test of CVITANOVIC PACKAGE
%
%       All tests are the weels with defferent spoke
%       (Use notation from SIGSAM Bull, 1989, v.23, no.4, pp.15-24)

g(l,j1,j2,j2,j1);


 2
n


g(l,j1,j2,j3,j1,j2,j3);


       2
n*( - n  + 6*n - 4)

g(l,j1,j2,j3,j1,j3,j2);


    2
n*(n  - 4*n + 4)

g(l,j1,j2,j3,j3,j2,j1);


 3
n


g(l,j1,j2,j3,j4,j1,j2,j3,j4);


    3       2
n*(n  - 12*n  + 28*n - 16)

g(l,j1,j2,j3,j4,j1,j2,j4,j3);


       3       2
n*( - n  + 10*n  - 24*n + 16)

g(l,j1,j2,j3,j4,j1,j4,j2,j3);


    3      2
n*(n  - 8*n  + 16*n - 8)

g(l,j1,j2,j3,j4,j1,j4,j3,j2);


       3      2
n*( - n  + 6*n  - 12*n + 8)


g(l,j1,j2,j3,j4,j5,j1,j2,j3,j4,j5);


    4       3        2
n*(n  - 20*n  + 100*n  - 160*n + 80)

g(l,j1,j2,j3,j4,j5,j1,j2,j3,j5,j4);


       4       3       2
n*( - n  + 18*n  - 88*n  + 152*n - 80)

g(l,j1,j2,j3,j4,j5,j1,j2,j5,j3,j4);


    4       3       2
n*(n  - 16*n  + 72*n  - 120*n + 64)

g(l,j1,j2,j3,j4,j5,j1,j2,j5,j4,j3);


       4       3       2
n*( - n  + 14*n  - 60*n  + 112*n - 64)


g(l,j1,j2,j3,j4,j5,j6,j1,j2,j3,j4,j5,j6);


       5       4        3        2
n*( - n  + 30*n  - 260*n  + 840*n  - 1120*n + 512)

g(l,j1,j2,j3,j4,j5,j6,j1,j2,j3,j4,j6,j5);


    5       4        3        2
n*(n  - 28*n  + 236*n  - 784*n  + 1088*n - 512)

g(l,j1,j2,j3,j4,j5,j6,j1,j2,j4,j3,j6,j5);


       5       4        3        2
n*( - n  + 26*n  - 216*n  + 736*n  - 1056*n + 512)

g(l,j1,j2,j3,j4,j5,j6,j1,j2,j6,j3,j4,j5);


    5       4        3        2
n*(n  - 24*n  + 176*n  - 536*n  + 704*n - 320)

g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5,j6,j7);


       6       5        4         3         2
n*( - n  + 42*n  - 560*n  + 3080*n  - 7840*n  + 9184*n - 3904)

g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5,j7,j6);


    6       5        4         3         2
n*(n  - 40*n  + 520*n  - 2880*n  + 7520*n  - 9024*n + 3904)

g(l,j1,j2,j3,j4,j5,j6,j7,j2,j1,j3,j4,j5,j6,j7);


    6       5        4         3         2
n*(n  - 40*n  + 520*n  - 2880*n  + 7520*n  - 9024*n + 3904)


%  Test of example that calculated incorrectly in earlier package.

index ix,iy,iz;


mass p1=mm, p2=mm, p3=mm, p4=mm, k1=0;

 
mshell p1,p2,p3,p4,k1;


vector q1,q2;

 
operator ga,gb;


for all p let ga(p)=g(la,p) + mm,
              gb(p)=g(lb,p) + mm;


xx := g(la,ix)*g(la,iy)*(g(lb,ix)*gb(p1)*g(lb,iy)*gb(q2) +
                      gb(p3)*g(lb,ix)*g(lb,iy));


                               2
xx :=  - p1.q2*n + 2*p1.q2 + mm *n + mm*n

let q1=p1-k1, q2=p3+k1;



xx;


                                             2
 - k1.p1*n + 2*k1.p1 - p1.p3*n + 2*p1.p3 + mm *n + mm*n


end;


Time for test: 31 ms
@@@@@ Resources used: (0 0 13 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/cvit.tex0000644000175000017500000003646711526203062023513 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{CVIT - Program for fast calculation of Dirac's $\gamma$-matrices
traces}
\date{(Version: 1.2. Release: March, 11, 1990)}
\author{V. Ilyin, A. Kryukov, A. Rodionov and A. Taranov \\
Institute for Nuclear Physics \\
Moscow State University  \\
Moscow, 119899 USSR  \\
Phone 939-58-92  \\
Telex 411483 MGU SU  \\
Fax (011)7095-939-01-26}

\begin{document}
\maketitle
\section*{Abstract}

In modern high energy physics the calculation of Feynman diagrams are
still very important. One of the difficulties of these calculations
are trace calculations. So the calculation of traces of Dirac's
$\gamma$-matrices were one of first task of computer algebra systems.
All available algorithms are based on the fact that gamma-matrices
constitute a basis of a Clifford algebra:
\begin{verbatim}
           {Gm,Gn} = 2gmn.
\end{verbatim}

We present the implementation of an alternative algorithm based on
treating of gamma-matrices as 3-j symbols (details may be found in
[1,2]).

The program consists of 5 modules described below.

\newpage
\begin{verbatim}

                    MODULES CROSS REFERENCES
   +--------+
   | REDUCE |
   |________|                  |ISIMP1
    ISIMP2|         +-----------------------+
          +--->-----| RED_TO_CVIT_INTERFACE |
                    |_______________________|
                 CALC_SPUR|          |REPLACE_BY_VECTOR
                          |          |REPLACE_BY_VECTORP
                          |          |GAMMA5P
                          ^          V
                         +--------------+
                         | CVITMAPPING  |
                         |______________|
                                ^
                                |PRE-CALC-MAP
                                |CALC_MAP_TAR
                                |CALC_DENTAR
                                |
                         +-------------+
                         | INTERFIERZ  |
                         |_____________|
                            |         |MK-NUMR
                            |         |STRAND-ALG-TOP
                            |         ^
               MAP-TO-STRAND|    +------------+
                   INCIDENT1|    | EVAL-MAPS  |
                            |    |____________|
                            ^               |DELETEZ1
                            |               |CONTRACT-STRAND
                  +----------------+        |COLOR-STRAND
                  | MAP-TO-STRAND  |---->---+
                  |________________|


      Requires of REDUCE version: 3.2, 3.3.

\end{verbatim}


\section*{Module RED\_TO\_CVIT\_INTERFACE}

\begin{center}
Author: A.P.Kryukov \\
Purpose:interface REDUCE and CVIT package
\end{center}

RED\_TO\_CVIT\_INTERFACE module is intended for connection of REDUCE
with main module of CVIT package. The main idea is to preserve
standard REDUCE syntax for high energy calculations.  For realization
of this we redefine {\ SYMBOLIC PROCEDURE ISIMP1} from HEPhys module of
REDUCE system.

After loading CVIT package user may use switch CVIT which is {\tt ON} by
default.  If switch CVIT is {\tt OFF} then calculations of Diracs matrices
traces are performed using standard REDUCE facilities. If CVIT switch
is {\tt ON} then CVIT package will be active.

{\tt RED\_TO\_CVIT\_INTERFACE} module performs some primitive simplification
and control input data independently.  For example it remove $G_mG_m$,
check parity of the number of Dirac matrices in each trace {\em etc}.
There is one principal restriction concerning G5-matrix. There are no
closed form for trace in non-integer dimension case when trace include
G5-matrix.  The next restriction is that if the space-time dimension
is integer then it must be even (2,4,6,...).  If these and other
restrictions are violated then the user get corresponding error
message. List of messages is included.

\begin{center}
\begin{verbatim}
                  LIST OF IMPORTED FUNCTIONS
-------------------------------------------------
 Function              From module
-------------------------------------------------
 ISIMP2                HEPhys
 CALC_SPUR             CVITMAPPING
-------------------------------------------------
\end{verbatim}

\begin{verbatim}
                  LIST OF EXPORTED FUNCTION
-------------------------------------------------
 Function              To module
-------------------------------------------------
 ISIMP1                HEPhys (redefine)
 REPLACE_BY_VECTOR     EVAL_MAP
 REPLACE_BY_VECTORP    EVAL__MAP
 GAMMA5P               CVITMAPPING, EVAL_MAP
-------------------------------------------------
\end{verbatim}
\end{center}



\section*{Module CVITMAPPING}

\begin{center}
Author: A.Ya.Rodionov \\
Purpose: graphs reduction
\end{center}

CVITMAPPING module is intended for diagrams calculation according to
Cvitanovic - Kennedy algorithm. The top function of this module
CALC\_SPUR is called from RED\_TO\_CVIT\_INTERFACE interface module.
The main idea of the algorithm consists in diagram simplification
according to rules (1.9') and (1.14) from [1].  The input data - trace
of Diracs gamma matrices (G-matrices) has a form of a list of
identifiers lists with cyclic order. Some of identifiers may be
identical.  In this case we assume summation over dummy indices. So
trace Sp(GbGr).Sp(GwGbGcGwGcGr) is represented as list ((b r) (w b c w
c r)).

The first step is to transform the input data to ``map'' structure and
then to reduce the map to a ``simple'' one. This transformation is made
by function TRANSFORM\_MAP\_ (top function). Transformation is made in
three steps. At the first step the input data are transformed to the
internal form - a map (by function PREPARE\_MAP\_). At the second step
a map is subjected to Fierz transformations (1.14) (function
MK\_SIMPLE\_MAP\_). At this step of optimization can be maid (if
switch CVITOP is on) by function MK\_FIRZ\_OP.  In this case Fierzing
starts with linked vertices with minimal distance (number of vertices)
between them.  After Fierz transformations map is further reduced by
vertex simplification routine MK\_SIMPLE\_VERTEX using (1.9').
Vertices reduced to primitive ones, that is to vertices with three or
less edges.  This is the last (third) step in transformation from
input to internal data.

The next step is optional.  If switch CVITBTR is on factorisation of
bubble (function FIND\_BUBBLES1) and triangle (function
FIND\_TRIANGLES1) submaps is made.  This factorisation is very
efficient for ``wheel'' diagrams and unnecessary for ``lattice'' diagrams.
Factorisation is made recursively by substituting composed edges for
bubbles and composed vertices for triangles.  So check (function
SORT\_ATLAS) must be done to test possibility of future marking
procedure.  If the check fails then a new attempt to reorganize atlas
(so we call complicated structure witch consists of MAP, COEFFicient
and DENOMinator) is made. This cause backtracking (but very seldom).
Backtracking can be traced by turning on switch CVITRACE. FIND\_BUBLTR
is the top function of this program's branch.

Then atlases must be prepared (top function WORLD\_FROM\_ATLAS) for
final algebraic calculations.  The resulted object called ``world''
consists of edges names list (EDGELIST), their marking variants
(VARIANTS) and WORLD1 structure. WORLD1 structure differs from WORLD
structure in one point.  It contains MAP2 structure instead of MAP
structure. MAP2 is very complicated structure and consist of VARIANTS,
marking plan and GSTRAND.  (GSTRAND constructed by PRE!-CALC!-MAP\_
from INTERFIERZ module.)  By marking we understand marking of edges
with numbers according to Cvitanovic - Kennedy algorithm.

The last step is performed by function CALC\_WORLD. At this step
algebraic calculations are done.  Two functions CALC\_MAP\_TAR and
CALC\_DENTAR from INTERFIERZ module make algebraic expressions in the
prefix form. This expressions are further simplified by function
{\tt REVAL}.  This is the REDUCE system general function for algebraic
expressions simplification. {\tt REVAL} and {\tt SIMP!*} are the only REDUCE
functions used in this module.

There are also some functions for printing several internal
structures: PRINT\_ATLAS, PRINT\_VERTEX, PRINT\_EDGE, PRINT\_COEFF,
PRINT\_DENOM.  This functions can be used for debugging.

If an error occur in module CVITMAPPING the error message ``ERROR IN
MAP CREATING ROUTINES'' is displayed.  Error has number 55.  The switch
CVITERROR allows to give full information about error: name of
function where error occurs and names and values of function's
arguments. If CVITERROR switch is on and backtracking fails message
about error in SORT\_ATLAS function is printed.  The result of
computation however will be correct because in this case factorized
structure is not used. This happens extremely seldom.


\begin{verbatim}
                  List of imported function
-------------------------------------------------
 function              from module
-------------------------------------------------
 REVAL                 REDUCE
 SIMP!*                REDUCE
 CALC_MAP_TAR          INTERFIERZ
 CALC_DENTAR           INTERFIERZ
 PRE!-CALC!-MAP_       INTERFIERZ
 GAMMA5P               RED_TO_CVIT_INTERFACE
-------------------------------------------------
\end{verbatim}

\begin{verbatim}
                  List of exported function
-------------------------------------------------
 function              to module
-------------------------------------------------
 CALC_SPUR             REDUCE - CVIT interface
-------------------------------------------------
\end{verbatim}

\begin{verbatim}
                        Data structure
 WORLD     ::=  (EDGELIST,VARIANTS,WORLD1)
 WORLD1    ::=  (MAP2,COEFF,DENOM)
 MAP2      ::=  (MAPS,VARIANTS,PLAN)
 MAPS      ::=  (EDGEPAIR . GSTRAND)
 MAP1      ::=  (EDGEPAIR . MAP)
 MAP       ::=  list of VERTICES (unordered)
 EDGEPAIR  ::=  (OLDEDGELIST . NEWEDGELIST)
 COEFF     ::=  list of WORLDS (unordered)
 ATLAS     ::=  (MAP,COEFF,DENOM)
 GSTRAND   ::=  (STRAND*,MAP,TADPOLES,DELTAS)
 VERTEX    ::=  list of EDGEs (with cyclic order)
 EDGE      ::=  (NAME,PROPERTY,TYPE)
 NAME      ::=  ATOM
 PROPERTY  ::=  (FIRSTPAIR . SECONDPAIR)
 TYPE      ::=  T or NIL
 ------------------------------------------------
 *Define in module MAP!-TO!-STRAND.

\end{verbatim}

\section*{Modules INTERFIERZ, EVAL\_MAPS, AND MAP-TO-STRAND.}

\begin{center}
Author: A.Taranov \\
Purpose: evaluate single Map
\end{center}

Module INTERFIERZ exports to module CVITMAPPING three functions:
PRE-CALC-MAP\_, CALC-MAP\_TAR, CALC-DENTAR.

Function PRE-CALC-MAP\_ is used for preliminary processing of a map. It
returns a list of the form (STRAND NEWMAP TADEPOLES DELTAS) where
STRAND is strand structure described in MAP-TO-STRAND module.  NEWMAP
is a map structure without ``tadepoles'' and ``deltas''.  ``Tadepole'' is a
loop connected with map with only one line (edge). ``Delta'' is a single
line disconnected from a map.  TADEPOLES is a list of ``tadepole''
submaps.  DELTAS is a list (CONS E1 E2) where E1 and E2 are

Function CALC\_MAP\_TAR takes a list of the same form as returned by
PRE-CALC-MAP\_, a-list, of the form (...  edge . weight ...  )  and
returns a prefix form of algebraic expression corresponding to the map
numerator.

Function CALC-DENTAR returns a prefix form of algebraic expression
corresponding to the map denominator.

Module EVAL-MAP exports to module INTERFIERZ functions MK-NUMR and
STRAND-ALG-TOP.

Function MK-NUMR returns a prefix form for some combinatorial
coefficient (Pohgammer symbol).

Function STRAND-ALG-TOP performs an actual computation of a prefix
form of algebraic expression corresponding to the map numerator. This
computation is based on a ``strand'' structure constructed from the
``map'' structure.

Module MAP-TO-STRAND exports functions MAP-TO-STRAND, INCIDENT1 to
module INTERFIERZ and functions DELETEZ1, CONTRACT-STRAND,
COLOR-STRAND to module EVAL-MAPS.

Function INCIDENT1 is a selector in ``strand'' structure.  DELETEZ1
performs auxiliary optimization of ``strand''.  MAP-TO-STRAND transforms
``map'' to ``strand'' structure.  The latter is describe in program
module.

CONTRACT-STRAND do strand vertex simplifications of ``strand'' and
COLOR-STRAND finishes strand generation.

\begin{verbatim}

            Description of STRAND  data structure.
 STRAND ::=
 VERTEX ::= . ( )
 ROAD   ::= . NUMBER
 NAME   ::=NUMBER
\end{verbatim}


\subsection*{ LIST OF MESSAGES}

\begin{itemize} 

\item{CALC\_SPUR: $<$vecdim$>$ IS NOT EVEN SPACE-TIME DIMENSION}
 The dimension of space-time $<$vecdim$ $is integer but not
even. Only even numeric dimensions are allowed.

\item{NOSPUR NOT YET IMPLEMENTED}
 Attempt to calculate trace when NOSPUR switch is on.  This facility
is not implemented now.

\item{G5 INVALID FOR VECDIM NEQ 4}
 Attempt to calculate trace with gamma5-matrix for space-time
dimension not equal to 4.

\item{CALC\_SPUR: $<$expr$>$ HAS NON-UNIT DENOMINATOR}
The  has non-unit denominator.

\item{THREE INDICES HAVE NAME $<$name$>$}
 There are three indices with equal names in evaluated expression.

\end{itemize}

\begin{verbatim}
                  List of switches
------------------------------------------------------------
 switch           default    comment
------------------------------------------------------------
 CVIT             ON         If it is on then use Kennedy-
                             Cvitanovic algorithm else use
                             standard facilities.
 CVITOP           OFF        Fierz optimization switch
 CVITBTR          ON         Bubbles and triangles
                             factorisation switch
 CVITRACE         OFF        Backtracking tracing switch
------------------------------------------------------------
\end{verbatim}


\begin{verbatim}
                 Functions cross references*.

CALC_SPUR
 |
 +-->SIMP!* (REDUCE)
     |
     +-->CALC_SPUR0
         |
         |--->TRANSFORM_MAP_
         |    |
         |    |--->MK_SIMPLE_VERTEX
         |    +--->MK_SIMPLE_MAP_
         |         |
         |         +--->MK_SIMPLE_MAP_1
         |              |
         |              +--->MK_FIERS_OP
         |
         |--->WORLD_FROM_ATLAS
         |    |
         |    +--->CONSTR_WORLDS
         |         |
         |         +---->MK_WORLD1
         |               |
         |               +--->MAP_2_FROM_MAP_1
         |                    |
         |                    |--->MARK_EDGES
         |                    +--->MAP_1_TO_STRAND
         |                         |
         |                         +-->PRE!-CALC!-MAP_
         |                             (INTERFIRZ)
         |
         |--->CALC_WORLD
         |    |
         |    |--->CALC!-MAP_TAR (INTERFIRZ)
         |    |--->CALC!-DENTAR (INTERFIRZ)
         |    +--->REVAL (REDUCE)
         |
         +--->FIND_BUBLTR
              |
              +--->FIND_BUBLTR0
                   |
                   |--->SORT_ATLAS
                   +--->FIND_BUBLTR1
                        |
                        |--->FIND_BUBLES1
                        +--->FIND_TRIANGLES1
*Unmarked functions are from CVITMPPING module.

\end{verbatim}


\section*{References}

\begin{itemize}

\item{1.}
Ilyin V.A., Kryukov A.P., Rodionov A.Ya., Taranov A.Yu.
Fast algorithm for calculation of Diracs gamma-matrices
traces. SIGSAM Bull., 1989, v.23, no.4, pp.15-24.

\item{2.}
Kennedy A.D. Phys.Rev., 1982, D26, p.1936.
\end{itemize}

\section*{Keywords}

REDUCE, GAMMA-MATRIX,  TRACE, SPACE-TIME  DIMENSION, HIGH  ENERGY PHYSICS.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/cvit.red0000644000175000017500000002221311526203062023445 0ustar  giovannigiovannimodule cvit;   % Header module for CVIT package.

% Authors:  A.Kryukov, A.Rodionov, A.Taranov.

% Copyright (C) 1988,1990, Institute of Nuclear Physics, Moscow State
%                          University.
% VERSION   2.1
% RELEASE   11-MAR-90

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% 07.06.90 all MAP replaced by MAP_   RT
% 08.06.90 SOME MACROS FROM CVITMAP FILE ADDED to section IV RT
% 10.06.90 SOME MACROS FROM CVITMAP FILE ADDED  RT

% Modifications for Reduce 3.4.1 by John Fitch.

create!-package('(cvit red2cvit map2strn evalmaps intfierz cvitmap),
                '(contrib physics));

% The High Energy Physics package must be loaded first.

load_package hephys;

% These fluids and globals have been moved here for cleaner compilation.

  fluid  '(!*msg ndims!* dindices!*)$
  global '(windices!* indices!* !*cvit gamma5!* !*g5cvit)$
  if null windices!*
    then windices!*:=
            '(nil !_f0 !_f1 !_f2 !_f3 !_f4 !_f5 !_f6 !_f7 !_f8 !_f9)$

  if null gamma5!*
    then gamma5!*:=
            '(nil !_a0 !_a1 !_a2 !_a3 !_a4 !_a5 !_a6 !_a7 !_a8 !_a9)$

%GGGGGGGGGGGGGGGGGGGGGGGGG GLOBALS & FLUIDS FFFFFFFFFFFFFFFFFFFFFFFFF$


 global '( !_0edge)$

 fluid '( new_edge_list old_edge_list )$

      % NEW_EDGE_LIST - LIST OF CREATED EDGES$
      % OLD_EDGE_LIST - LIST OF INITIAL EDGES$

 fluid '(n_edge)$

      % N_EDGE - NUMBER OF CREATED EDGES$

% The following smacros need only be present during compilation.

  %************ SECTION I ************************************

  smacro   procedure hvectorp x$
     get(x,'rtype) eq 'hvector$

  smacro   procedure windexp x$
     x memq car windices!*$

  smacro   procedure replace_by_indexp v$
     get(v,'replace_by_index)$

  smacro   procedure indexp i$
     i memq indices!*$

  smacro   procedure replace_by_vectorp i$
     get(i,'replace_by_vector)$

  smacro   procedure replace_by_vector i$
     get(i,'replace_by_vector) or i$

  smacro   procedure gamma5p x$
     memq(x,car gamma5!*)$

  smacro   procedure nospurp x$
     flagp(x,'nospur)$

  smacro   procedure clear_gamma5()$
     gamma5!* := nil . append(reverse car gamma5!*,cdr gamma5!*)$

%********************* SECTION II **************************

symbolic smacro procedure p_empty_map_ map_$
% IS MAP_ EMPTY ? $
    null map_$

symbolic smacro procedure p_empty_vertex vertex$
% IS VERTEX EMPTY ? $
    null vertex$

%++++++++++++++++++++++++++ SELECTORS +++++++++++++++++++++++++++++++$

symbolic smacro procedure s_vertex_first map_$
% SELECT FIRST VERTEX IN MAP_ $
  car map_$

symbolic smacro procedure s_map__rest map_$
% SELECT TAIL OF MAP_ $
  cdr map_$

symbolic smacro procedure s_vertex_second map_$
% SELECT SECOND VERTEX IN MAP_ $
  s_vertex_first s_map__rest map_$

symbolic smacro procedure first_edge vertex$
% SELECT FIRST EDGE IN VERTEX $
  car vertex$

symbolic smacro procedure s_vertex_rest vertex$
% SELECT TAIL OF VERTEX $
  cdr vertex$

symbolic smacro procedure second_edge vertex$
% SELECT SECOND EDGE IN VERTEX $
  first_edge s_vertex_rest vertex$

symbolic smacro procedure s_edge_name edge$
% SELECT EDGE'S NAME $
  car edge$

symbolic smacro procedure s_edge_prop_ edge$
% SELECT PROP_ERTY OF AN EDGE (NAMES OF PARENTS OR NUMBERS)$
  cadr edge$

symbolic smacro procedure s_edge_type edge$
% SELEC TYPE (PARITY) OF AN EDGE$
  caddr edge$

%?????????????????????? CONSTRUCTORS ??????????????????????????????$

symbolic smacro procedure add_vertex (vertex,map_)$
% ADD VERTEX TO MAP_ $
  vertex . map_ $

symbolic smacro procedure add_edge (edge,vertex)$
% ADD EDGE TO VERTEX$
  edge . vertex$

symbolic smacro procedure append_map_s (map_1,map_2)$
% APPEND TWO MAP_S  $
  append(map_1,map_2)$

symbolic smacro procedure conc_map_s (map_1,map_2)$
% APPEND TWO MAP_S  $
 nconc(map_1,map_2)$

symbolic smacro procedure conc_vertex (vertex1,vertex2)$
% APPEND TWO VERTICES
 nconc(vertex1,vertex2)$

symbolic smacro procedure mk_name1 name$
 explode name$

symbolic smacro procedure mk_edge_prop_ (prop_1,prop_2)$
 prop_1 . prop_2 $

symbolic smacro procedure mk_edge_type (typ1,typ2)$
% DEFINED EDGE <=> TYPE T,
% UNDEFINED EDGE <=> TYPE NIL$
    typ1 and  typ2 $

symbolic smacro procedure mk_edge (name,prop_,type)$
% MAKE UP NEW EDGE $
 list(name,prop_,type)$

symbolic smacro procedure mk_edge3_vertex (edge1,edge2,edge3)$
% MAKES PRIMITIVE VERTEX  $
  list(edge1,edge2,edge3)$

symbolic smacro procedure mk_empty_map_ ()$
% GENERATE EMPTY MAP_ $
  nil $

symbolic smacro procedure mk_empty_vertex ()$
% GENERATE EMPTY VERTEX $
  nil $

symbolic smacro procedure mk_vertex1_map_ vertex1$
% MAKE MAP_ OF ONE VERTEX $
  list(vertex1)$

symbolic smacro procedure mk_vertex2_map_ (vertex1,vertex2)$
% MAKE MAP_ OF TWO VERTICES $
  list(vertex1,vertex2)$

symbolic smacro procedure mk_edge2_vertex (edge1,edge2)$
%MAKES VERTEX FROM TWO EDGES$
  list(edge1,edge2)$

 symbolic smacro procedure conc_vertex (vertex1,vertex2)$
  nconc(vertex1,vertex2)$

symbolic smacro procedure cycl_map_ map_$
% MAKES CYCLIC PERMUTATION OF MAP_$
    append(cdr map_,list car map_)$

symbolic smacro procedure cycl_vertex vertex$
% MAKES CYCLIC PERMUTATION OF VERTEX$
    append(cdr vertex,list car vertex)$

symbolic smacro procedure mk_world (actedges,world1)$
  list(actedges,list nil,world1)$

%====================== PREDICATES (CONTINUE) =====================$

symbolic smacro procedure p_member_edge (edge,vertex)$
% IS EDGE (WITH THE SAME NAME) CONTAINS IN VERTEX ?$
  assoc(s_edge_name edge,vertex)$

symbolic smacro procedure equal_edges (edge1,edge2)$
% IF EDGES HAVE THE SAME NAMES ? $
  eq   ( s_edge_name edge1, s_edge_name edge2)$

symbolic smacro procedure single_no_parents edges$
 length edges = 1 $

symbolic smacro procedure resto_map__order map_$
% REVERSE (BETTER REVERSIP) MAP_ $
  reverse map_$

symbolic smacro procedure map__length map_$
% NUMBER OF VERTICES IN MAP_$$
  length map_$

symbolic smacro procedure vertex_length vertex$
% NUMBER OF EDGES IN VERTEX $
  length vertex$

symbolic smacro procedure prepare_map_ map_$
 for each x in map_
  collect mk_old_edge x$

symbolic smacro procedure p_vertex_prim vertex$
% IS VERTEX PRIMITIVE ? $
  vertex_length (vertex) <= 3 $

  %************ SECTION III ************************************

symbolic smacro procedure s!-edge!-name edge$ car edge$

symbolic smacro procedure sappend(x,y)$ append(x,y)$

symbolic smacro procedure sreverse y $ reverse   y$

symbolic smacro procedure getedge(x,y)$ cdr assoc(x,y)$

symbolic smacro procedure mk!-road!-name(x,y,n)$
list(car x . n,car y . n)$

symbolic smacro procedure mk!-external!-leg edge$
%< FLAG(LIST EDGE,'EXTRNL)$
list(    edge . 0)   $

symbolic smacro procedure index!-in(ind,l)$
if atom ind then nil
else member(ind,l)$

  %************ SECTION IV ************************************

symbolic smacro procedure reverse_map_ map_$
  reverse map_$

symbolic smacro procedure mk_edge1_vertex edge$
 list edge$

symbolic smacro procedure mk_edges_vertex edges$
  edges$

symbolic smacro procedure reversip_vertex vertex$
  reversip vertex$

symbolic smacro procedure append_vertex (vertex1,vertex2)$
   append(vertex1,vertex2)$

%symbolic smacro procedure conc_vertex (vertex1,vertex2)$
% nconc(vertex1,vertex2)$

symbolic smacro procedure mk_edge4_vertex (edge1,edge2,edge3,edge4)$
  list(edge1,edge2,edge3,edge4)$

symbolic smacro procedure p_old_edge edge$
 assoc(s_edge_name edge,old_edge_list )$


symbolic smacro procedure s_atlas_map_ atlas$
 car atlas$

symbolic smacro procedure s_atlas_coeff atlas$
 cadr atlas$

symbolic smacro procedure s_atlas_den_om atlas$
 caddr atlas$

symbolic smacro procedure mk_atlas (map_,atlases,den_om)$
 list(map_,atlases,den_om)$

symbolic smacro procedure vertex_edges edge$
  edge$

symbolic smacro procedure s_coeff_world1 world1$
 cadr world1 $

symbolic smacro procedure s_edgelist_world world$
 car world$

symbolic smacro procedure s_world1 world$
 caddr world $


symbolic smacro procedure s_world_var world$
 cadr world$

symbolic smacro procedure s_world_atlas world$
  caddr world$

symbolic smacro procedure s_world_edges world$
 car world$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/noncom2.red0000644000175000017500000006523011526203062024061 0ustar  giovannigiovannimodule noncom2;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                        N O N C O M 2                             %
%                                                                  %
%                     A Package to redefine                        %
%                   noncommutativity in REDUCE                     %
%                                                                  %
%  Author:                Mathias Warns                            %
%                       Physics Institute                          %
%                       University of Bonn                         %
%                         Nussallee 12                             %
%                     D-5300 BONN 1 (F.R.G.)                       %
%                                          %
%                                                                  %
%  Version:                 2.5 06 Jan 92                          %
%                                                                  %
%                                                                  %
% Designed for: REDUCE version 3.3 / 3.4                           %
% Tested on   : - IBM 3081/3084/9000-620  VM/CMS MVS/XA            %
%                  SLISP   implementation of REDUCE                %
%                  PSL/370 implementation of REDUCE                %
%               - Intel 386/486 AT compatible                      %
%                  PSL implementation of REDUCE                    %
%                                                                  %
%             Copyright (c) Mathias Warns 1990 - 1992              %
%                                                                  %
%                                                                  %
% This file has been re-released under the BSD license by          %
% A C Hearn under powers granted to him by the original author     %
% when this package was contributed for use in a commercial        %
% edition of Reduce.                                               %
%                                                                  %
% ****      Summary of changes since version 1.0          ****     %
%                                                                  %
%   - Various small bugs have been corrected in the utility        %
%     functions                                                    %
%   - The sloppy use of CAR on atoms allowed in SLISP systems has  %
%     been removed                                                 %
%   - The pattern matching routine SUBS3TNC has been entirely      %
%      recoded for greater efficiency and is now used for ALL      %
%      terms (not only for the noncommuting cases)                 %
%      Procedures SUBLIST, LOCATE!_N and MTCHP1!*  added           %
%   - Enhanced tracing utilities added                             %
%   - NONCOMP has been changed to NONCOMP!* since the former       %
%     cannot be redefined on some systems                          %
% 2.0 100691 mw :                                                  %
%     - deleting functions recoded                                 %
%     - append replaced by nconc everywhere                        %
%     - switch MYMATCH added to choose between pattern matchers    %
%     - procedures NONCOM and NONCOMMUTING modified                %
% 2.5 210891 mw                                                    %
%   - Bug in SUBSTNC corrected  and enhanced                       %
%   - procedure ZERLEG added for much faster handling of s. t.     %
%   - procedure !*SUBS3TNC modfified accordingly                   %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

create!-package('(noncom2),'(contrib physics));

%------------------------------------------------------------------
% this package relies on modified standard REDUCE routines         %
% and is therefore version dependent                               %
%-------------------------------------------------------------------
fluid '(!*nosq !*mymatch frlis!* ncmp!* subfg!* wtl!*);
!*nosq := t;
switch mymatch;
!*mymatch := t; %this is the default
%------------------------------%
%   general utility functions  %
%------------------------------%
symbolic procedure trwrite u;
begin  scalar x;
if not flagp(car u,'tracing) then return nil;
write "**in procedure: ", car u; terpri();
for each x in cdr u do write x;
terpri();
end;

symbolic procedure funtrace u;
for each x in u do flag(list(x),'tracing);

deflist('((trwrite rlis) (funtrace rlis)),'stat);

symbolic procedure pnth!*(u,n); % slightly modified from pnth
   if null u then nil
    else if n=1 then u
    else pnth!*(cdr u,n-1);

symbolic procedure nth!*(u,n);
if length(u) < n then nil
else car pnth!*(u,n);

symbolic procedure revassoc(u,v); % added 140791 mw
% revesre of assoc
% checks the a-list v for a pair whose CDR is u
begin scalar x;
if not listp v then rederr "invalid argument to revassoc";
a: if null v then return;
   x := car v;
   v := cdr v;
   if (pairp x)  and (cdr x = u) then return car x;
   go to a;
end;

symbolic procedure kernelp u;  %new
% checks if an algebraic expression is a kernel
if null u or domain!*p u then nil
else if idp u then t
else if listp u and idp car u and not (car u memq
'(!*sq set setq plus minus difference times quotient))
 then t
else nil;

symbolic procedure spp u;  %new
% checks if u is a standard power
pairp u and kernelp car u;

symbolic procedure stp u;  %new
% checks if u is a s.t.
pairp u and spp car u;

symbolic procedure sfp2 u; %new
% checks if u if a s.f.
% sfp seems to be ill defined
pairp u and stp car u;

symbolic procedure tstp u; %new
% checks if u is a "true" standard term, i.e. a product term
stp u and (car !*f2a !*t2f u neq 'plus);

symbolic procedure !*!*a2f u;  %new
%converts u without call of subs2
begin scalar flg,res;
flg := subfg!*; subfg!* := nil;
res := !*a2f u;
subfg!* := flg;
return res
end;

symbolic procedure !*!*a2q u;  %new
%converts an algebraic expression into a s.q. using !*!*a2f
if car u eq 'quotient  then !*!*a2f cadr u . !*!*a2f caddr u
else  !*f2q !*!*a2f u;

symbolic procedure !*a2q u;  %new
%converts an algebraic expression into a s.q. using !*a2f
if (not atom u and car u eq 'quotient) then
        !*a2f cadr u . !*a2f caddr u
else  !*f2q !*a2f u;

symbolic procedure atsoc2(u,v);
% same as atsoc but looks for the caar part
begin scalar res;
for each x in v do
if (not atom car x and caar x eq u) then res:= x;
return res
end;

symbolic procedure sublist(u,v);
% u and v are lists of sp
% checks if all elements of u are included in v in the right order
% return a sublist of containing the elements of u + the rest of v
begin scalar x,z,y,w,reslist,n,u1;
if not (listp u and listp v) then
    rederr " invalid arguments to sublist";
%initialization
if null u or null v or not (V:= member(car u,v)) then return;
a : if null u then return nconc(reslist,append(u1,v));
    z:= v;
    x := car u;
    u := cdr u;
    if not (v:= member(x,z)) then return;
    v := cdr v;
    n:= length(z) - length(v) - 1;
    z := for k:= 1 : n collect nth(z,k);
    trwrite(sublist,"z= ",z," v= ",v," x= ",x);
a0: if null z then
    <<
       u1 := nconc(u1,list(x));
       go to a;
    >>;
    w := car z;
    z := cdr z;
    if noncommuting!_splist(w,u1) then go to a1
    else reslist := nconc(reslist,list(w));
    go to a0;
a1:
    z := reverse (w . z);
    if noncommutingsp(car z,x) then return;
    v := (car z) . v;
    z := reverse cdr  z;
    go to a0;
end;

symbolic procedure deleteall(x,u); %2.1
% deletes all occurrences of x in u
begin scalar y,res;
a: if null u then return res;
y:=  car u;
u := cdr u;
if not (y = x) then  res:= nconc(res,list(y));
go to a
end;

symbolic procedure deletemult(x,u);  %2.1
% deletes multiples occurences of x in u
% keeping only one left
begin scalar y,n;
if null (y:= cdr member(x,u)) then return u;
n:=length(u)-length(y);
return nconc(for k:=1 :n collect nth(u,k),deleteall(x,y));
end;

symbolic procedure deletemult!* u;
% deletes all multiple occurences of elements in u
begin scalar x;
if null u then return u;
x:=list(car u);
u := cdr u;
for each y in u do
if not member(y,x) then nconc(x,list(y));
return x
end;

symbolic procedure listofvarnames u; %new
% u is a list of s.p.
%  returns list of vars in u
% we keep nil as  placeholder for numbers in u
if not listp u then rederr "invalid argument to listofvarnames"
else for each x in u collect if domain!*p x then (nil . 'free)
                             else if atom x then (nil . 'free)
                             else if idp car x then ((car x) . 'free)
                             else if idp caar x then ((caar x) . 'free);



symbolic procedure replsublist(u,v,w); %new
% v and w are p-lists
% u is anything
% replaces the sublist v in w by u
begin scalar n,x,res;
if not (x:= sublist(v,w)) then return w;
n:= length(w)-length(x);
% trwrite "n= ",n," x= ",x;
% u := if listp u then u else list(u);
% trwrite "u= ",u,listp u;
res := if zerop n then nil
       else for k:= 1 :n  collect nth(w,k);
res := if null res then u else nconc(res,u);
% trwrite "res= ",res;
return if (length(v) = length(x)) then res
       else  nconc(res,pnth(x,length(v)+1))
end;

symbolic procedure locate!_n(x,lst,n);
% returns the position of the n-th occurence of x in lst
% nil if not succesful
begin scalar n2,lst2,ntot;
if null lst then return nil;
lst2 := lst;
ntot:= 0;
a: if n = 0 then return ntot;
   n2:= locate_member(x,lst2);
%   trwrite "n2=",n2," lst2= ",lst2;
   if null n2 then return nil;
   lst2 := cdr pnth(lst2,n2);
   ntot := ntot+n2;
   n:= n-1;
   go to a;
end;


symbolic procedure term2listpows u;  %new
% u is a  s.t. containing only products
% return a list of the s.p. of u
begin
trwrite(term2listpows,"u= ",u);
return
if null u then u
else if atom u then list u
else if domain!*p cdr u then car u . list cdr u
else car u . term2listpows cadr u;
end;

symbolic procedure listprod2term u; %new
%  u is a list of product terms (numbers,s.p.,s.t.,s.f.)
% value is the s.q. obtained by multiplying all the terms together
begin scalar x,res;
if not listp u then rederr "invalid argument to listprod2term";
if null u then return u;
res:= car u;
res :=  if domain!*p res then !*d2q res
        else if spp res then  !*p2q res else if stp res then !*t2q res
        else if sfp2 res then  res . 1 else res;
% trwrite "res= ",res;
u :=cdr u;
a: if null u then return  res;
x := car u;
x := if domain!*p x then !*d2q x
     else if spp x then !*p2q x else if stp x then !*t2q x
     else if sfp2 x then x . 1 else x;
u := cdr u;
res := multsq(res,x);
go to a;
end;

% this routine gives the position of an object in a list. the first
% object is numbered 1. returns nil if the object can't be found.

symbolic procedure locate_member(u,v);
  if not member(u,v) then nil
  else if u=car v then 1
  else 1+locate_member(u,cdr v);

global '(domainlist!*);
symbolic procedure domain!*p u;
% this is a much more precise domain checker than domainp
null u or numberp u or (not atom u and memq(car u,domainlist!*));

%------------------------------------------------%
% new defintions of noncom and testing functions %
%------------------------------------------------%

% clear previous definitions of noncom
remflag('(noncom),'flagop);
remprop('noncom,'stat);

symbolic procedure noncomp2 u; % changed
% u is a kernel checks for noncom flag
if atom u then flagp(u,'noncom)
else flagpcar(u,'noncom);

symbolic procedure noncom u; %new
begin scalar y,liste;
if not listp u  then rederr(u, "invalid argument to noncom");
for each x in u do <<
 if not idp x then rederr(x, "invalid argument to noncom");
 noncom1 x;
 liste:=get(x,'noncommutes);
 y := delete(x,u);
 put(x,'noncommutes,deletemult!* nconc(liste,y));
% the following is needed for the physop package  added  2.1 140891 mw
 if (get(x,'rtype) = 'physop) then
 <<
     noncom1 adjp x;
     liste:=get(adjp x,'noncommutes);
     y := delete(adjp x,for each j in u collect adjp j);
     put(adjp x,'noncommutes,deletemult!* nconc(liste,y));
     noncom1 invp x;
     liste:=get(invp x,'noncommutes);
     y := delete(invp x,for each j in u collect invp j);
     put(invp x,'noncommutes,deletemult!* nconc(liste,y));
   >>;
 >>;
 return nil
 end;
deflist('((noncom rlis)),'stat);

symbolic procedure noncommuting(u,v);  % modifed 2.1 140891 mw
% u and v are two kernels
% checks for noncommuting
begin scalar list,res;
u := if atom u then u else car u;
v := if atom v then v else car v;
  if not (noncomp2 u and noncomp2 v) then nil
  else <<
       list :=get(u,'noncommutes);
       res:=member(v,list);
             >>;
return res
end;

symbolic procedure noncommutingterm u;  %new
% u is a standard term
% checks if there are some noncommuting products in u
begin scalar x,y;
if null u or domain!*p u or spp u then return nil;
x := tvar u;  % <-- term variable
u := cdr u;  % <-- tc (s.f.)
a: if null u or domain!*p u then return nil;
   y := car u;  % <-- lt
   if noncommutingf(x,list(y)) or noncommutingterm y then return t;
   u := cdr u;
   go to a
end;

symbolic  procedure noncommutingf(x,u); % new
  % x is a kernel, u  is a standard form
  % checks for noncommuting
    if domain!*p u then nil
    else noncommuting(x, mvar u) or noncommutingf(x, lc u)
         or noncommutingf(x, red u);

symbolic procedure noncommutingsp(u,v);
% u and v are sp or numbers
if null u or null v or numberp u or numberp v then nil
else noncommuting(car u,car v);

symbolic procedure noncommuting!_splist(u,v);
% u is a sp, v is a list of sp
% checks if u commutes with all elements of v
if null v or null u then nil
else noncommutingsp(u,car v) or noncommuting!_splist(u,cdr v);



%--------------------------------------------%
% procedures for ordering of expressions     %
%--------------------------------------------%


symbolic procedure ordp(u,v); % modified
   %returns true if u ordered ahead or equal to v, nil otherwise.
   %an expression with more structure at a given level is ordered
   % behind (and not ahead) of one with less;
   % ordering of numbers is left as default
   if null u then t
   else if null v then nil
   else if atom u then
           if atom v then
              if numberp u then
                  if numberp v then not(u < v)
                  else t
              else if numberp v then nil
                   else orderp(u,v)
           else t
    else if atom v then nil
    else if car u=car v then ordp(cdr u,cdr v)
    else ordp(car u,car v);

symbolic procedure reordop(u,v);  %changed
% modilfied so that every commuting op is ordered ahead
% of every noncommuting op
   if noncommuting(u,v) then t
   else if noncomp2 u and not noncomp2 v then nil
   else if noncomp2 v and not noncomp2 u then t
   else ordop(u,v);


%--------------------------------------------------%
% procedures for handling noncommutative           %
% terms in pattern matching                        %
%--------------------------------------------------%
% we have to modify subs3f1 since the handling of noncom mvars
% in subs3t is not correct  so we must prevent the system from
% calling this procedure

symbolic procedure subs3f1(u,l,bool); %modified
   %u is a standard form.
   %l is a list of possible matches.
   %bool is a boolean variable which is true if we are at top level.
   %value is a standard quotient with all product substitutions made;
   begin scalar x,z;
        z := nil ./ 1;
    a:  if null u then return z
         else if domainp u then return addsq(z,u ./ 1)
         else if bool and domainp lc u then go to c;
 %      the following line has been changed  2.1
        x :=  if !*mymatch then !*subs3tnc(lt u,l)
              else subs3t(lt u,l);
 %      x := if noncommutingterm lt u then !*subs3tnc(lt u,l)
 %          else subs3t(lt u,l);
        if not bool                             %not top level;
         or not mchfg!* then go to b;           %no replacement made;
        mchfg!* := nil;
        if numr x = u and denr x = 1 then <>
         % also shows no replacement made (sometimes true with non
         % commuting expressions)
         else if null !*resubs then go to b
         else if !*sub2 or powlis1!* then x := subs2q x;
           %make another pass;
        x := subs3q x;
    b:  z := addsq(z,x);
        u := cdr u;
        go to a;
    c:  x := list lt u ./ 1;
        go to b
   end;


symbolic procedure !*subs3tnc(u,v); %new 2.2
% header procedure for subs3tnc
% u is a standard term, v a list of matching templates
% call subs3tnc on every product term of u and return a s.q.
% if u not standard term
begin scalar x,y,res,mchfg;
trwrite('subs3tnc,"before mchfg!*= ",mchfg!*);
if domain!*p u then return !*d2q u;
if kernelp u then return !*k2q u;
if spp u then return !*p2q u;
y := zerleg u; % transform u in a list of true s.t.
trwrite('!*subs3tnc," y= ",y);
res := (nil . 1);
a: if null y then << mchfg!* := mchfg; return res >>;
   x := car y;
   y := cdr y;
   res := addsq(res,subs3tnc(x,v));
   if mchfg!* then <>;
   trwrite('!*subs3tnc,"res= ",res);
go to a
end;

symbolic procedure zerleg u; % new 2.2
% u is a s. t.
% value is a list of termlists
% each termlist contains the s. p. of a true s. t. of u
begin scalar x,res;
if null u then return u;
if domain!*p u then return list u;
x:= car u;   % <--  lpow
u := cdr u;  % <-- lc
if null u then return list(list(x));
if domain!*p u then return list(list(x,u));
res := zerleg(car u);
res := for each j in res collect (x . j);
if null cdr u then return res
else return append(res,zerleg(x . cdr u));
end;

symbolic procedure subs3tnc(termlist,v);  %new
% new version including more general templates
% u is a list of s.p. from a product term in s. t. form (2.2),
% v a list of matching templates.
% value is the s.t. modified by relevant substitutions
% (eg a s.q. in general case)
begin scalar termlist2,templ,temp,tempsp,tempvar,freetemp,rhs,
        lhs,bool,boolp,matchinglist,x,y,z,z1,w,w1,termlist3,na,ka,n,k,
        prevterml2,nabs; % added 2.2
% return trivial cases removed 2.2
% if domain!*p u then return !*d2q u;
% build a list of s.p. in u
% termlist := term2listpows u;  %this line replaced by argument 2.2
% trwrite(subs3tnc, "termlist= ",termlist);
  mchfg!* := nil;
% this is the main loop scanning each template
% terminating if no match found
a: if null v then return listprod2term termlist;  %changed 2.2
% these are the variable names in termlist  moved here 2.2
  termlist2:= listofvarnames termlist;
% select a template
    templ := car v;
    v := cdr v;
%   trwrite(subs3tnc," templ= ",templ," v= ",v);
% rhs is an algebraic expression
    rhs := nth(templ,3);
% boolean  expression to be satisfied by the matching args
    bool := cdadr templ;
% flag to indicate if exact power matching required
    boolp := caadr templ;
    trwrite(subs3tnc, "bool= ",bool," boolp= ",boolp);
% lhs of templ is already a list of s.p.
    lhs := car templ;
    temp := nil; freetemp := nil; % initialization
% first we separate the lhs in a list of free  and of nonfree
% variables
    for each x in reverse lhs do
       if memq(car x,frlis!*) then freetemp := x . freetemp
       else temp := x . temp;
    lhs := nil; % will be rebuilt later on
    trwrite(subs3tnc, "temp= ",temp,"freetemp= ",freetemp);
    if null temp then go to b;
% we allow nonexact power matching only in the case of 2 sp in lhs
    boolp := if length(temp) = 2 then boolp
              else t;
    k := 1; % counter for number of terms in lhs
    na:= 1;
    nabs := 0;  % added 2.2
    z1 := nil;
    matchinglist := nil;
a1: if (k > length(temp)) then go to b;
aa: if (k < na) then go to a;
    tempsp := nth(temp,k);
    tempvar := if idp car tempsp then car tempsp
               else caar tempsp;
a2: n:= locate_member((tempvar . 'free),termlist2);
    if numberp n then go to ab;
    k := k-1;
    z1 := nil;
    lhs := if null lhs then lhs
           else cdr lhs;
% 2.2 two lines added 210891 mw
    termlist2 := prevterml2;
    nabs := length(termlist) - length(termlist2); % update nabs
    go to aa;
ab: % mark tempvar as being used in the pattern matching process
    termlist2 :=nconc(for k:=1 :(n-1) collect nth(termlist2,k),
                       ((tempvar . 'used) . pnth(termlist2,n+1)));
%   trwrite(subs3tnc, "termlist2= ",termlist2);
    x:= nth(termlist,n+nabs); %2.2 modified to get the absolute position
    z:= mtchp1!*(x,tempsp,boolp,bool,z1);
    if null cdr z then go to a2;
    if car z then
    <<
        if not sublist(car z ,matchinglist) then
           matchinglist:= nconc(matchinglist,car z);
        trwrite(subs3tnc, "matchinglist= ",matchinglist);
% do the substitutions of car z in temp and bool
        for each y in car z do
        <<
           bool := subst(cdr y,car y,bool);
           temp := subst(cdr y,car y,temp)
        >>;
    >>;
    lhs := x . lhs;
    trwrite(subs3tnc, "lhs= ",lhs);
    z1:= cdr z;
    na:= k;
    k:= k + 1;
% 2.2: 3 lines added 210891 mw
    prevterml2 := termlist2;
    termlist2 := pnth!*(termlist2,n+1);
    nabs := nabs + n;  %update the absolute position counter
    go to a1;
b:  if not sublist(car z1,matchinglist) then
       matchinglist:= nconc(matchinglist,car z1);
%  special hack for nonexact power matching
    if (length(lhs) = 2) then
    <<
       x := cadr lhs; % this is the first term !
       y := nth(temp,1);
       if ((na:= cdr y) neq (ka := cdr x))  then
       <<
           termlist := replsublist(list(car x .** (ka - na),
                                        car x .** na),
                                   list(car x .** ka),termlist);
            w := list(car x . na);
       >>
       else w:= list(x);
       x:= car lhs;  % this is the second term
       y := nth(temp,2);
       if (na:= cdr y) neq (ka := cdr x) then
       <<
          termlist := replsublist(list(car x .** na,
                                       car x .** (ka - na)),
                                  list(car x .** ka),termlist);
          lhs := (car x . na) . w;
       >>
       else lhs := x . w;
    >>;
% from here on in principle all the terms in lhs are matched
    lhs := reverse lhs;
% cross check
    if null (termlist3 := sublist(lhs,termlist)) then go to a;
    n := length(termlist)-length(termlist3);
%   trwrite(subs3tnc, "n= ",n);
% rebuild the termlist after rearrangement
    termlist := nconc(for k := 1 : n collect nth(termlist,k),
                       termlist3);
    na := length(freetemp);
    if (na = 0) then go to d;
    freetemp := reverse freetemp;
%  recalculation  of n is necessary because lhs do not sit
% in front of termlist3
    n:= length(termlist) - length(member(car lhs,termlist));
% match the free variable(s) to be placed in front
    if (n < na) then go to a;
% take all the terms in front in this case
    if (na = 1) and (cdar freetemp = 1) then
    <<
        lhs := termlist;
        matchinglist:= nconc(matchinglist,list(caar freetemp .
                       !*q2a listprod2term nconc(
                       for k:=1 :n collect nth(termlist,k),
                       for k:= (length(lhs)+1) : length(termlist3)
                           collect nth(termlist3,k))));
    >>
    else for k:=1 :na do
    <<
        x := nth(termlist,n-k+1);
        y := nth(freetemp,k);
        z:= mtchp1(x,y,boolp,bool);
        if not sublist(car z ,matchinglist) then
              matchinglist:= nconc(matchinglist,car z);
        for each w in car z do
            y:= subst(cdr w,car w,y);
        lhs := y . lhs;
        if (na:= cdr y) neq (ka := cdr x) then
        <<
           termlist := replsublist(list(car x .** (ka - na),
                          car x .** na),list(car x .** ka),termlist);
           n:= n+1;
        >>
    >>;
d:
  trwrite(subs3tnc,"lhs= ",lhs);
  trwrite(susb3tnc," termlist= ",termlist);
% trwrite(subs3tnc,"matchinglist= ",matchinglist);
% replace the free variables in the rhs
  for each x in matchinglist do
             rhs:= subst(cdr x, car x,rhs);
% trwrite(subs3tnc," rhs= ",rhs);
% and finally we replace the lhs in u by the rhs
% for this we have to replace in the termlist the s.p. of lhs by
% the rhs  converted to a standard quotient
  rhs := list(simp rhs);
  trwrite(subs3tnc," rhs= ",rhs);
  termlist:= replsublist(rhs,lhs,termlist);
  trwrite(subs3tnc, "resulting termlist = ",termlist);
  mchfg!* := t;
  return listprod2term termlist
  end;


symbolic  procedure mtchp1!*(u,v,boolp,bool,z);
% u is a sp, v is  a sp to be matched against x
% boolp is a flg (t if exact power matching required)
%  bool is a boolean expr to be satisfied during matching
% z is a list of possible matchings for the free variables in y
% returns a list of matching pair lists first is that element of z
% which leads to a succesful matching  or nil
begin scalar temp1,bool1,x,z1;
   if null z then return nconc(list(nil),mtchp2(u,v,boolp,bool));
a: if null z then return list(nil);
   x:= car z;
   z:= cdr z;
 % trwrite "x= ",x," z= ",z;
   temp1:= v;
   bool1 := bool;
   for each  w in x do
   <<
      temp1:= subst(cdr w,car w, temp1);
      bool1 := subst(cdr w,car w,bool1);
   >>;
   if (z1:=mtchp2(u,temp1,boolp,bool1)) then return x . z1;
   go to a;
   end;

symbolic procedure mtchp2(u,v,boolp,bool);
% does the same job as mtchp1 but more accurately
% since mtchp1 does not check bool at all
begin scalar z,x,reslist,bool1,bool2;
z := reverse mtchp1(u,v,boolp,bool);
if (bool = t) then return z;
a: if null z then return reslist;
   x := car z;
   z := cdr z;
   bool1 := bool;
   for each w in x do bool1 := subst(cdr w,car w,bool1);
   bool2:= bool1;
% trick used here to check for remaining free variables in bool
   for each w in frlis!* do bool2:=subst(nil,w, bool2);
   trwrite(mtchp2, "bool1= ",bool1," bool2= ",bool2);
   if ((bool2 = bool1) and null eval bool1) then return nil
   else reslist := x . reslist;
   go to a
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/physop.tex0000644000175000017500000007164511526203062024065 0ustar  giovannigiovanni\documentstyle[11pt,reduce,makeidx]{article}
\makeindex
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following definitions should be commented out by those
% wishing to use MakeIndeX
\def\indexentry#1#2{{\tt #1} \dotfill\ #2\newline}
\renewcommand{\printindex}{\noindent \@input{\jobname.idx}}
%%%%%%% end of definitions %%%%%%%%%%%%%%%%%%%%%

\title{PHYSOP \\ A Package for Operator Calculus in Quantum Theory}
\author{User's Manual \\  Version 1.5  \\ January 1992}
\date{Mathias Warns \\
Physikalisches Institut der Universit\"at Bonn  \\
Endenicher Allee 11--13 \\
D--5300 BONN 1 \\
Germany \\*[2\parskip]
Tel: (++49) 228 733724 \\
Fax: (++49) 228 737869 \\
e--mail: UNP008@DBNRHRZ1.bitnet}

\begin{document}
\maketitle
\section{Introduction}
The package PHYSOP has been designed to meet the requirements of
theoretical physicists looking for a
computer algebra tool to perform complicated calculations
in quantum theory
with expressions containing operators. These operations
consist mainly in the calculation of commutators between operator
expressions and in the evaluations of operator matrix elements
in some abstract space. Since the capabilities
of the current \REDUCE\ release  to deal with complex
expressions containing noncommutative operators are rather restricted,
the first step was to enhance these possibilities in order to
achieve a better  usability of \REDUCE\ for these kind of calculations.
This has led to the development of a first package called
NONCOM2 which is described in section 2. For more complicated
expressions involving both scalar quantities and operators
the need for an additional data type has emerged in order to make a
clear separation between the various objects present in the calculation.
The implementation of this  new \REDUCE\ data type is realized by the
PHYSOP (for PHYSical OPerator) package described in section 3.

\section{The NONCOM2 Package}

The package NONCOM2  redefines some standard \REDUCE\ routines
in order to modify the way noncommutative operators are handled by the
system. In standard \REDUCE\ declaring an operator to be noncommutative
using the \f{NONCOM} statement puts a global flag on the
operator. This flag is checked when the system has to decide
whether or not two operators commute during the manipulation of an
expression.

The NONCOM2 package redefines the \f{NONCOM} \index{NONCOM} statement in
a way more suitable for calculations in physics. Operators have now to
be declared noncommutative pairwise, i.e. coding: \\

\begin{framedverbatim}
NONCOM A,B;
\end{framedverbatim}
declares the operators \f{A} and \f{B} to be noncommutative but allows them
to commute with any other (noncommutative or not) operator present in
the expression. In a similar way if one wants e.g.\ \f{A(X)} and
 \f{A(Y)} not to commute, one has now to code: \\

\begin{framedverbatim}
 NONCOM A,A;
\end{framedverbatim}
Each operator gets a new property list containing the
operators with which it does not commute.
A final example should make
the use of the redefined \f{NONCOM} statement clear: \\

\begin{framedverbatim}
NONCOM A,B,C;
\end{framedverbatim}
declares \f{A}  to be noncommutative with \f{B} and \f{C},
\f{B} to be noncommutative
with \f{A} and \f{C} and \f{C} to be noncommutative
with \f{A} and \f{B}.
Note that after these declaration
e.g.\ \f{A(X)} and \f{A(Y)}
are still commuting kernels.

Finally to keep the compatibility with standard \REDUCE\, declaring a
\underline{single} identifier using the \f{NONCOM} statement has the same
effect as in
standard \REDUCE\, i.e., the identifier is flagged with the \f{NONCOM} tag.

From the user's point of view there are no other
new commands implemented by the package. Commutation
relations have to be declared in the standard way as described in
the manual i.e.\ using
\f{LET} statements. The package itself consists of several redefined
standard
\REDUCE\ routines to handle the new definition of noncommutativity in
multiplications and pattern matching processes.

{\bf CAVEAT: } Due to its nature, the package is highly version
dependent. The current version has been designed for the 3.3  and 3.4
releases
of \REDUCE\ and may not work with previous versions. Some different
(but still correct) results may occur by using this package in
conjunction with
LET statements since part of the pattern matching routines have been
redesigned. The package has been designed to bridge a deficiency of the
current \REDUCE\ version concerning the notion of noncommutativity
 and it is the author's hope that it will be made  obsolete
by a future release of \REDUCE.

\section{The PHYSOP package}

The package PHYSOP implements a new \REDUCE\ data type to perform
calculations with physical operators. The noncommutativity of
operators is
implemented using the NONCOM2 package so this file should be loaded
prior to the use of PHYSOP\footnote{To build a fast
loading version of PHYSOP the NONCOM2
source code should be read in prior to the PHYSOP
code}.
In the following the new commands  implemented by the package
are described.  Beside these additional commands,
the full set of standard \REDUCE\ instructions remains
available for performing  any other calculation.

\subsection{Type declaration commands}

The new \REDUCE\ data type PHYSOP implemented by the package allows the
definition of a new kind of operators (i.e. kernels carrying
an arbitrary
number of arguments). Throughout this manual, the name
``operator''
will refer, unless explicitly stated otherwise, to this new data type.
This data type is in turn
divided into 5 subtypes. For each of this subtype, a declaration command
has been defined:
\begin{description}
\item[\f{SCALOP A;} ] \index{SCALOP} declares \f{A} to be a scalar
operator. This operator may
carry an arbitrary number of arguments i.e.\ after the
declaration: \f{ SCALOP A; }
all kernels of the form e.g.\
\f{A(J), A(1,N), A(N,L,M)}
are recognized by the system as being scalar operators.

\item[\f{VECOP V;} ] \index{VECOP} declares \f{V} to be a vector operator.
As for scalar operators, the vector operators may carry an arbitrary
number of arguments. For example \f{V(3)} can be used to represent
the vector operator $\vec{V}_{3}$. Note that the dimension of space
in which this operator lives is \underline{arbitrary}.
One can however address a specific component of the
vector operator by using a special index declared as \f{PHYSINDEX} (see
below). This index must then be the first in the argument list
of the vector operator.

\item[\f{TENSOP C(3);} ]  \index{TENSOP}
declares \f{C} to be a tensor operator of rank 3. Tensor operators
of any fixed integer rank larger than 1 can be declared.
Again this operator may carry an arbitrary number of arguments
and the space dimension is not fixed.
The tensor
components can be addressed by using  special \f{PHYSINDEX} indices
(see below) which have to be placed in front of all other
arguments in the argument list.


\item[\f{STATE U;} ] \index{STATE} declares \f{U} to be a state, i.e.\ an
object on
which operators have a certain action.  The state  U can also carry an
arbitrary number of arguments.

\item[\f{PHYSINDEX X;} ] \index{PHYSINDEX} declares \f{X} to be a special
index which will be used
to address components of vector and tensor operators.
\end{description}

It is very important to understand precisely the way how the type
declaration commands work in order to avoid type mismatch errors when
using the PHYSOP package. The following examples should illustrate the
way the program interprets type declarations.
Assume that the declarations listed above have
been typed in by the user, then:
\begin{description}
\item[$\bullet$] \f{A,A(1,N),A(N,M,K)} are SCALAR operators.
\item[$\bullet$] \f{V,V(3),V(N,M)} are VECTOR operators.
\item[$\bullet$] \f{C, C(5),C(Y,Z)} are TENSOR operators of
rank 3.
\item[$\bullet$] \f{U,U(P),U(N,L,M)} are  STATES.
\item[BUT:] \f{V(X),V(X,3),V(X,N,M)} are all \underline{scalar}
operators
since the \underline{special index} \f{X}  addresses a
specific component
of the vector operator (which is a scalar operator). Accordingly,
\f{C(X,X,X)} is  also a \underline{scalar} operator because
the diagonal component $C_{xxx}$
of the tensor operator \f{C} is meant here
(C has rank 3 so 3 special indices must be used for the components).
\end{description}

In view of these examples, every time the following text
refers to \underline{scalar} operators,
it should be understood that this means not only operators defined by
the
\f{SCALOP} statement but also components of vector and tensor operators.
Depending on the situation, in some case when dealing only with the
components of vector or tensor operators it may be preferable to use
an operator declared with \f{SCALOP} rather than addressing  the
components using several special indices (throughout the
manual,
indices declared with the \f{PHYSINDEX} command are referred to as special
indices).

Another important feature of the system  is that
for each operator declared using the statements described above, the
system generates 2 additional operators of the same type:
the \underline{adjoint} and the \underline{inverse} operator.
These operators are accessible to the user for subsequent calculations
without any new declaration.  The syntax is as following:

If \f{A} has been declared to be an operator (scalar, vector or tensor)
the \underline{adjoint} operator is denoted \f{A!+} and the
\underline{inverse}
operator is denoted \f{A!-1} (an inverse adjoint operator \f{A!+!-1}
is also generated).
The exclamation marks do not appear
when these operators are printed out by \REDUCE\ (except when the switch
\f{NAT} is set to off)
but have to be typed in when these operators are used in an input
expression.
An adjoint (but \underline{no} inverse)  state  is also
generated  for every state defined by the user.
One may consider these generated operators as ''placeholders'' which
means that these operators are considered by default as
being completely independent of the original operator.
Especially if some value is assigned to the original operator,
this value is \underline{not} automatically assigned to the
generated operators. The user must code additional assignement
statements in order to get the corresponding values.

Exceptions from these rules are (i) that inverse operators are
\underline{always} ordered at the same place as the original operators
and (ii) that  the expressions \f{A!-1*A}
and \f{A*A!-1} are replaced\footnote{This may not always occur in
intermediate steps of a calculation  due to efficiency reasons.}
by the unit operator \f{UNIT} \index{UNIT}.
This operator is defined
as a scalar operator during the initialization of the PHYSOP package.
It should be used to indicate
the type of an operator expression whenever no other PHYSOP
occur in it. For example, the following sequence: \\

\begin{framedverbatim}
SCALOP A;
A:= 5;
\end{framedverbatim}
leads to a type mismatch error and should be replaced by: \\

\begin{framedverbatim}
SCALOP A;
A:=5*UNIT;
\end{framedverbatim}
The operator \f{UNIT} is a reserved variable of the system and should
not be used for other purposes.

All other kernels  (including standard \REDUCE\ operators)
occurring in expressions are treated as ordinary scalar variables
without any PHYSOP type (referred to as \underline{scalars} in the
following).
Assignement statements are checked to ensure correct operator
type assignement on both sides leading to an error if a type
mismatch occurs. However an assignement statement of the form
\f{A:= 0} or \f{LET A = 0} is \underline{always} valid regardless of the
type of \f{A}.

Finally a command \f{CLEARPHYSOP} \index{CLEARPHYSOP}
has been defined to remove
the PHYSOP type from an identifier in order to use it for subsequent
calculations (e.g. as an ordinary \REDUCE\ operator). However it should be
remembered that \underline{no}
substitution rule is cleared by this function. It
is therefore left to the user's responsibility to clear previously all
substitution rules involving the identifier from which the PHYSOP type
is removed.

Users should be very careful when defining procedures or statements of
the type \f{FOR ALL ... LET ...} that the PHYSOP type of all identifiers
occurring in such expressions is unambigously fixed. The type analysing
procedure is rather restrictive and will print out a ''PHYSOP type
conflict'' error message if such ambiguities occur.

\subsection{Ordering of operators in an expression}

The ordering of kernels in an expression is performed according to
the following rules: \\
1. \underline{Scalars} are always ordered ahead of
PHYSOP \underline{operators} in an expression.
The \REDUCE\ statement \f{KORDER} \index{KORDER} can be used to control the
ordering of scalars but has \underline{no}
effect on the ordering of operators.

2. The default ordering of \underline{operators} follows the
order in which they have been declared (and \underline{not}
the alphabetical one).
This ordering scheme can be changed using the command \f{OPORDER}.
\index{OPORDER}
Its syntax is similar to the \f{KORDER} statement, i.e.\ coding:
\f{OPORDER A,V,F;}
means that all occurrences of the operator \f{A} are ordered ahead of
those of \f{V} etc. It is also possible to include operators
carrying
indices (both normal and special ones) in the argument list of
\f{OPORDER}. However including objects  \underline{not}
defined as operators (i.e. scalars or indices) in the argument list
of the \f{OPORDER} command leads to an error.

3. Adjoint operators are placed by the declaration commands just
after the original operators on the \f{OPORDER} list. Changing the
place of an operator on this list means \underline{not} that the
adjoint operator is moved accordingly. This adjoint operator can
be moved freely  by including it in the argument list of the
\f{OPORDER} command.

\subsection{Arithmetic operations on operators}

The following arithmetic operations are possible with
operator expressions: \\

1. Multiplication or division of an operator by a scalar.

2. Addition and subtraction of operators of the \underline{same} type.

3. Multiplication of operators is only defined between two
\underline{scalar} operators.

4. The scalar product of two VECTOR operators is implemented with
a new function \f{DOT} \index{DOT}. The system expands the product of
two vector operators into an ordinary product of the components of these
operators by inserting a special index generated by the program.
To give an example, if one codes: \\

\begin{framedverbatim}
VECOP V,W;
V DOT W;
\end{framedverbatim}
the system will transform the product into: \\

\begin{framedverbatim}
V(IDX1) * W(IDX1)
\end{framedverbatim}
where \f{IDX1} is a \f{PHYSINDEX} generated by the system (called a DUMMY
INDEX in the following) to express the summation over the components.
The identifiers \f{IDXn} (\f{n} is
a nonzero integer) are
reserved variables for this purpose and should not be used for other
applications. The arithmetic operator
\f{DOT} can be used both in infix and prefix form with two arguments.

5. Operators (but not states) can only be raised to an
\underline{integer} power. The system expands this power
expression into a product of the corresponding number of terms
inserting dummy indices if necessary. The following examples explain
the transformations occurring on power expressions (system output
is indicated with an \f{-->}): \\

\begin{framedverbatim}
SCALOP A; A**2;
- --> A*A
VECOP V; V**4;
- --> V(IDX1)*V(IDX1)*V(IDX2)*V(IDX2)
TENSOP C(2); C**2;
- --> C(IDX3,IDX4)*C(IDX3,IDX4)
\end{framedverbatim}
Note in particular the way how the system interprets powers of
tensor operators which is different from the notation used in matrix
algebra.

6. Quotients of operators are only defined between
\underline{scalar} operator expressions.
The system transforms the quotient of 2 scalar operators into the
product of the first operator times the inverse of the second one.
Example\footnote{This shows how inverse operators are printed out when
the switch \f{NAT} is on}: \\

\begin{framedverbatim}
SCALOP A,B;   A / B;
       -1
 --> (B  )*A
\end{framedverbatim}

7. Combining the  last 2 rules explains the way how the system
handles negative powers of operators: \\

\noindent
\begin{framedverbatim}
SCALOP B;
B**(-3);
       -1    -1    -1
 --> (B  )*(B  )*(B  )
\end{framedverbatim}


The method of inserting dummy indices and expanding powers of
operators has been chosen to facilitate the handling of
complicated operator
expressions and particularly their application  on states
(see section 3.4.3). However it may be useful to get rid of these
dummy indices in order to enhance the readability of the
system's final output.
For this purpose the switch \f{CONTRACT} \index{CONTRACT} has to
be turned on (\f{CONTRACT} is normally set to \f{OFF}).
The system in this case contracts over dummy indices reinserting the
\f{DOT} operator and reassembling the expanded powers.  However due to
the predefined operator ordering the system may not remove all the
dummy indices introduced previously.

\subsection{Special functions}

\subsubsection{Commutation relations}

If 2 PHYSOPs have been declared noncommutative using the (redefined)
\f{NONCOM} statement, it is possible to introduce in the environment
\underline{elementary} (anti-) commutation relations between them. For
this purpose,
2 \underline{scalar} operators \f{COMM} \index{COMM} and
\f{ANTICOMM} \index{ANTICOMM} are available.
These operators are used in conjunction with \f{LET} statements.
Example: \\

\begin{framedverbatim}
SCALOP A,B,C,D;
LET COMM(A,B)=C;
FOR ALL N,M LET ANTICOMM(A(N),B(M))=D;
VECOP U,V,W; PHYSINDEX X,Y,Z;
FOR ALL X,Y LET COMM(V(X),W(Y))=U(Z);
\end{framedverbatim}

Note that if special indices are used as dummy variables in
\f{FOR ALL ... LET} constructs then these indices should  have been
declared previously using the \f{PHYSINDEX} command.

Every time the system
encounters a product term involving 2
noncommutative operators which have to be reordered on account of the
given operator ordering, the list of available (anti-) commutators is
checked in the following way: First the system looks for a
\underline{commutation} relation which matches the  product term. If it
fails then the defined \underline{anticommutation} relations are
checked. If there is no successful match the product term
 \f{A*B} is replaced by: \\

\begin{framedverbatim}
A*B;
 --> COMM(A,B) + B*A
\end{framedverbatim}
so that the user may introduce the commutation relation later on.

The user may want to force the system to look for
\underline{anticommutators} only; for this purpose a switch \f{ANTICOM}
\index{ANTICOM}
is defined which has to be turned on ( \f{ANTICOM} is normally set to
\f{OFF}). In this case, the above example is replaced by: \\

\begin{framedverbatim}
ON ANTICOM;
A*B;
 -->  ANTICOMM(A,B) - B*A
\end{framedverbatim}

Once the operator ordering has been fixed (in the example above \f{B}
has to be ordered ahead of \f{A}),
there is \underline{no way} to prevent the
system from introducing (anti-)commutators  every time it encounters
a product whose terms are not in the right order. On the other hand,
simply by changing the \f{OPORDER} statement  and reevaluating the
expression one can change  the operator ordering
\underline{without}
the need to introduce new commutation relations.
Consider the following example: \\

\begin{framedverbatim}
SCALOP A,B,C;   NONCOM A,B;   OPORDER B,A;
LET COMM(A,B)=C;
A*B;
- -->  B*A + C;
OPORDER A,B;
 B*A;
- --> A*B - C;
\end{framedverbatim}

The functions \f{COMM} and \f{ANTICOMM} should only be used  to
define
elementary (anti-) commutation relations between single operators.
For the calculation of (anti-) commutators between complex
operator
expressions, the functions \f{COMMUTE} \index{COMMUTE} and
\f{ANTICOMMUTE} \index{ANTICOMMUTE} have been defined.
Example (is included as example 1 in the test file): \\

\begin{framedverbatim}
VECOP P,A,K;
PHYSINDEX X,Y;
FOR ALL X,Y LET COMM(P(X),A(Y))=K(X)*A(Y);
COMMUTE(P**2,P DOT A);
\end{framedverbatim}

\subsubsection{Adjoint expressions}

As has been already mentioned, for each operator and state defined
using the declaration commands quoted in section 3.1, the system
generates automatically the corresponding adjoint operator. For the
calculation of the adjoint representation of a complicated
operator expression, a function  \f{ADJ} \index{ADJ} has been defined.
Example\footnote{This shows how adjoint operators are printed out
when the switch \f{NAT} is on}: \\

\begin{framedverbatim}
SCALOP A,B;
ADJ(A*B);
       +    +
 --> (B )*(A )
\end{framedverbatim}

\subsubsection{Application of operators on states}

For this purpose, a function \f{OPAPPLY} \index{OPAPPLY} has been
defined.
It has 2 arguments and is used in the following combinations: \\

{\bf (i)}  \f{LET OPAPPLY(}{\it operator, state}\f{) =} {\it state};
This is to define a elementary
action of an operator on a state in analogy to the way
elementary commutation relations are introduced to the system.
Example: \\

\begin{framedverbatim}
SCALOP A; STATE U;
FOR ALL N,P LET OPAPPLY((A(N),U(P))= EXP(I*N*P)*U(P);
\end{framedverbatim}

{\bf (ii)} \f{LET OPAPPLY(}{\it state, state}\f{) =} {\it scalar exp.};
This form is to define scalar products between states and normalization
conditions.
Example:  \\

\begin{framedverbatim}
STATE U;
FOR ALL N,M LET OPAPPLY(U(N),U(M)) = IF N=M THEN 1 ELSE 0;
\end{framedverbatim}

{\bf (iii)} {\it state} \f{:= OPAPPLY(}{\it operator expression, state});
 In this way, the action of an operator expression on a given state
is calculated using elementary relations defined as explained in {\bf
(i)}. The result may be assigned to a different state vector.

{\bf (iv)} \f{OPAPPLY(}{\it state}\f{, OPAPPLY(}{\it operator expression,
state}\f{))}; This is the way how to calculate matrix elements of
operator
expressions. The system proceeds in the following way: first the
rightmost operator is applied on the right state, which means that the
system tries
to find an elementary relation which match the application of the
operator on the state. If it fails
the system tries to apply the leftmost operator of the expression on the
left state using the adjoint representations. If this fails also,
the system prints out a warning message and stops the evaluation.
Otherwise the next operator occuring in the expression is
taken and so on until the complete expression is applied.  Then the
system
looks for a relation expressing the scalar product of the two
resulting states and prints out the final result. An example of such
a calculation is given in the test file.

The infix version of the \f{OPAPPLY} function is the vertical bar $\mid$
. It is \underline{right} associative and placed in the precedence
list just above the minus ($-$) operator.
Some of the \REDUCE\ implementation may not work with this character,
the prefix form should then be used instead\footnote{The source code
can also be modified to choose another special character for the
function}.

\section{Known problems in the current release of PHYSOP}

\indent {\bf (i)} Some spurious negative powers  of operators
may appear
in the result of a calculation using the PHYSOP package. This is a
purely ''cosmetic'' effect which is due to an additional
factorization of the expression in the output printing routines of
\REDUCE. Setting off the \REDUCE\ switch \f{ALLFAC}  (\f{ALLFAC} is normally
on)
should make these
terms disappear and print out the correct result (see example 1
in the test file).

{\bf (ii)} The current release of the PHYSOP package is not optimized
w.r.t. computation speed. Users should be aware that the evaluation
of complicated expressions involving a lot of commutation relations
requires a significant amount of CPU time \underline{and} memory.
Therefore the use of PHYSOP on small machines is rather limited. A
minimal hardware configuration should include at least 4 MB of
memory and a reasonably fast CPU (type Intel 80386 or equiv.).

{\bf (iii)} Slightly different ordering of operators (especially with
multiple occurrences of the same operator with different indices)
may appear in some calculations
due to the internal ordering of atoms in the underlying LISP system
(see last example in the test file). This cannot be entirely avoided
by the package but does not affect the correctness  of the results.

\section{Compilation of the packages}
To build a fast loading module of the NONCOM2 package, enter the
following commands after starting the \REDUCE\ system: \\

\begin{framedverbatim}
  faslout "noncom2";
   in "noncom2.red";
  faslend;
\end{framedverbatim}
To build a fast loading module of the PHYSOP package, enter the
following commands after starting the \REDUCE\ system: \\

\begin{framedverbatim}
  faslout "physop";
   in "noncom2.red";
   in "physop.red";
  faslend;
\end{framedverbatim}
Input and output file specifications may change according to the
underlying operating system. \\
On PSL--based systems, a spurious message: \\

\begin{framedverbatim}
*** unknown function PHYSOP!*SQ called from compiled code
\end{framedverbatim}
may appear during the compilation of the PHYSOP package. This warning
has no effect on the functionality of the package.

\section{Final remarks}
The package PHYSOP has been presented by
the author at the IV inter. Conference on Computer Algebra in Physical
Research, Dubna (USSR) 1990 (see M. Warns, {\it
Software Extensions of \REDUCE\ for Operator Calculus in Quantum Theory},
Proc.\ of the IV inter.\ Conf.\ on Computer Algebra in Physical
Research, Dubna 1990, to appear). It has been developed with the aim in
mind to perform calculations of the type exemplified in the test file
included in the distribution of this package.
However it should
also be useful in some other domains like e.g.\ the calculations of
complicated Feynman diagrams in QCD  which could not be  performed using
the HEPHYS package. The author is  therefore grateful for any
suggestion
to improve or extend the usability of the package. Users should not
hesitate to contact the author for additional help and explanations on
how to use
this package. Some bugs may also
appear which have not been discovered during the tests performed
prior to the release of this version. Please send in this case to the
author  a short
input and output listing  displaying the encountered problem.

\section*{Acknowledgements}
The main ideas for the implementation of a new data type in the \REDUCE\
environnement have been taken from the VECTOR package developed by
Dr.\ David Harper (D. Harper, Comp.\ Phys.\ Comm.\ {\bf 54} (1989)
295).
Useful discussions with  Dr.\ Eberhard Schr\"ufer  and
Prof.\ John Fitch are also gratefully acknowledged.

\appendix

\section{List of error and warning messages}
In the following the error (E) and warning (W) messages specific to the
PHYSOP package are listed.
\begin{description}
\item[\f{cannot declare} {\it x}\f{ as }{\it data type}] (W):
 An attempt has been made to declare an
object {\it x} which cannot be used as a PHYSOP operator of the
required type. The declaration command is ignored.

\item [{\it x} \f{already defined as} {\it data type}] (W): The object
{\it x} has already been declared using a \REDUCE\ type declaration
command and can therefore not be used as a PHYSOP operator.
The declaration command is ignored.

\item [{\it x} \f{already declared as} {\it data type}] (W): The object
\f{x} has already been declared with a PHYSOP declaration command.
The declaration command is ignored.

\item[{\it x} \f{is not a PHYSOP}] (E): An invalid argument has been
included in an \f{OPORDER} command. Check the arguments.

\item[\f{invalid argument(s) to }{\it function}] (E): A
function implemented by the PHYSOP package has been called with an
invalid argument. Check type of arguments.


\item[\f{Type conflict in }{\it operation}] (E): A PHYSOP type conflict
has occured during an arithmetic operation. Check the arguments.

\item [\f{invalid call of }{\it function} \f{with args:} {\it arguments}]
(E): A function
of the PHYSOP package has been declared with invalid argument(s). Check
the argument list.

\item[\f{type mismatch in} {\it expression}] (E): A type mismatch has
been detected in an expression.  Check the corresponding expression.

\item[\f{type mismatch in} {\it assignement}] (E): A type
mismatch has been detected in an assignment or in a \f{LET}
statement. Check the listed statement.

\item[\f{PHYSOP type conflict in} {\it expr}] (E): A ambiguity has been
detected during the type analysis of the expression. Check the
expression.

\item[\f{operators in exponent cannot be handled}] (E): An operator has
occurred in the exponent of an expression.

\item[\f{cannot raise a state to a power}] (E): states cannot be
exponentiated by the system.

\item[\f{invalid quotient}] (E): An invalid denominator has occurred in a
quotient. Check the expression.

\item[\f{physops of different types cannot be commuted}] (E): An invalid
operator has occurred in a call of the \f{COMMUTE}/\f{ANTICOMMUTE} function.

\item[\f{commutators only implemented between scalar operators}] (E):
An invalid operator has occurred in the call of the
\f{COMMUTE}/\f{ANTICOMMUTE} function.

\item[\f{evaluation incomplete due to missing elementary relations}] (W):
\\
The system has not found all
the elementary commutators or application relations necessary to
calculate or reorder the input expression. The result may however be
used for further calculations.
\end{description}

\section{List of available commands}
\printindex
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/evalmaps.red0000644000175000017500000002370211526203062024314 0ustar  giovannigiovannimodule evalmaps;  % Interaction with alg mode: variant without nonlocs;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


  exports    strand!-alg!-top $
  imports    color!-strand,contract!-strand $

%------------------ AUXILIARY ROUTINES -----------------------------$

symbolic procedure permpl(u,v)$
if null u then t
else if car u = car v then permpl(cdr u,cdr v)
     else not permpl(cdr u,l!-subst1(car v,car u,cdr v))$

symbolic procedure repeatsp u$
if null u then nil
else (member(car u,cdr u) or repeatsp cdr u )$

symbolic procedure l!-subst1(new,old,l)$
if null l then nil
else if old = car l then new . cdr l
     else (car l) . l!-subst1(new,old,cdr l)$

%-------------------FORMING ANTISYMMETRIHERS -----------------------$

symbolic procedure propagator(u,v)$
if null u then      1
else if (repeatsp u) or (repeatsp v) then 0
     else 'plus . propag(u,permutations v,v)$

symbolic procedure propag(u,l,v)$
if null l then      nil
else (if permpl(v,car l) then 'times . prpg(u,car l)
      else list('minus,'times . prpg(u,car l) ) ) . propag(u,cdr l,v)$

symbolic procedure prpg(u,v)$
if null u then nil
else list('cons,car u,car v) . prpg(cdr u,cdr v)$

symbolic procedure line(x,y)$
propagator(cdr x,cdr y)$

%------------------ INTERFACE  WITH CVIT3 ---------------------------$

symbolic procedure strand!-alg!-top(strand,map_,edlst)$
begin
  scalar rlst$
      strand:=deletez1(strand,edlst)$
      rlst:=color!-strand(edlst,map_,1)$
      strand:=contract!-strand(strand,rlst) $
 %RINT STRAND$ TERPRI()$
 %RINT RLST$ TERPRI()$
 %RINT EDLST$ TERPRI()$
 return dstr!-to!-alg(strand,rlst,nil)
%ATHPRINT REVAL(W)$ RETURN W
end$


symbolic procedure mktails(side,rlst,dump)$
begin
  scalar pntr,newdump,w,z$
    if null side then return nil . dump$
    pntr:=side$
    newdump:=dump$
 while pntr do  <<  w:=mktails1(car pntr,rlst,newdump)$
                    newdump:=cdr w$
                    z:=sappend(car w,z)$
                    pntr:=cdr pntr >>$
    return z . newdump
end$

symbolic procedure mktails1(rname,rlst,dump)$
begin
 scalar color,prename,z$
       color:=getroad(rname,rlst)$
     if 0 = color then return nil . dump$
     if 0 = cdr rname then
      return (list replace_by_vector car rname) . dump$
 %   IF FREEIND CAR RNAME THEN RETURN (LIST CAR RNAME) . DUMP$
       z:=assoc(rname,dump)$
     if z then return
                if null cddr z then  cdr z . dump
                else (sreverse cdr z) . dump$
  %    PRENAME:=APPEND(EXPLODE CAR RNAME,EXPLODE CDR RNAME)$
       prename:=rname$
       z:= mkinds(prename,color)$
   return z . ((rname . z) . dump)
end$

symbolic procedure mkinds(prename,color)$
if color = 0 then nil
else
     begin
         scalar indx$
    %     INDX:=INTERN COMPRESS APPEND(PRENAME,EXPLODE COLOR)$
          indx:=                       prename . color $
       return indx . mkinds(prename,sub1 color)
     end$

symbolic procedure getroad(rname,rlst)$
if null rlst then 1 % ******EXT LEG IS ALWAYS SUPPOSET TO BE SIMPLE $
else if cdr rname = cdar rlst then
              cdr qassoc(car rname,caar rlst)
     else getroad(rname,cdr rlst) $


symbolic procedure qassoc(atm,alst)$
if null alst then nil
else if eq(atm,caar alst) then car alst
     else qassoc(atm,cdr alst)$

%------------- INTERACTION WITH RODIONOV ---------------------------$

symbolic procedure from!-rodionov x$
begin scalar strand,edges,edgelsts,map_,w$
    edges:=car x$
    map_:=cadr x$
    edgelsts:=cddr x$
    strand := map_!-to!-strand(edges,map_)$
    w:= for each edlst in edgelsts collect
             strand!-alg!-top(strand,map_,edlst)$
    return reval('plus . w )
end$

symbolic procedure top1 x$
mathprint from!-rodionov to_taranov x$

%----------------------- COMBINATORIAL COEFFITIENTS -----------------$

symbolic procedure f!^(n,m)$
if n>$
  return
       ( if sign then
              if null cdr coeff then (-1)
              else 'minus . list(constimes coeff)
        else if null cdr coeff then 1
             else constimes coeff ) . dump
end$

symbolic procedure dpropagator(l1,l2,dump)$
(lambda z$
     if z=0       then z
     else if z=1 then nil . dump
          else  for each trm in cdr z collect
                             mod!-index(trm,dump) )
   propagator(l1,l2)$

symbolic procedure dvertex!-to!-projector(svert,rlst,dump)$
begin
  scalar l1,l2,coeff,w$
       l1:=mktails(cadr svert,rlst,dump)$
       if repeatsp car l1 then return 0$
       l2:= mktails(caddr svert,rlst,cdr l1)$
       if repeatsp car l2 then return 0$
       dump:=cdr l2$
       w:=prop!-simp(car l1,sreverse car l2)$
       coeff:=mk!-contract!-coeff w$
 return coeff . dpropagator(cadr w,cddr w,dump)
end$

%SYMBOLIC PROCEDURE DSTR!-TO!-ALG(STRAND,RLST,DUMP)$
%IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
%ELSE
%  BEGIN
%    SCALAR VRTX$
%      VRTX:=DVERTEX!-TO!-PROJECTOR(CAR STRAND,RLST,DUMP)$
%      IF 0=VRTX THEN RETURN 0$
%      IF NULL CADR VRTX THEN RETURN
%      LIST('TIMES,CAR VRTX,DSTR!-TO!-ALG(CDR STRAND,RLST,CDDR VRTX))$
%
% RETURN LIST('TIMES,CAR VRTX,
%        'PLUS . (FOR EACH TRM IN CDR VRTX COLLECT
%      LIST('TIMES,CAR TRM,DSTR!-TO!-ALG(CDR STRAND,RLST,CDR TRM))) )

%===MODYFIED 4.07.89

remflag('(dstr!-to!-alg),'lose)$

symbolic procedure dstr!-to!-alg(strand,rlst,dump)$
%IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
if null strand then consrecip list(mk!-coeff1(dump,rlst))
else
  begin
    scalar vrtx$
      vrtx:=dvertex!-to!-projector(car strand,rlst,dump)$
      if 0=vrtx then return 0$
      if null cadr vrtx then return
         if 1 = car(vrtx) then
                           dstr!-to!-alg(cdr strand,rlst,cddr vrtx)
         else
           cvitimes2(car vrtx,
                     dstr!-to!-alg(cdr strand,rlst,cddr vrtx))$


      return
        cvitimes2(car vrtx,
                  consplus (for each trm in cdr vrtx collect
                            cvitimes2(car trm,
                                      dstr!-to!-alg(cdr strand,rlst,
                                                    cdr trm))))$
end$

flag('(dstr!-to!-alg),'lose)$

symbolic procedure cvitimes2(x,y)$
if (x=0) or (y=0) then 0
else if x = 1 then y
     else if y = 1 then x
          else list('times,x,y)$


symbolic procedure free dlt$
(freeind cadr dlt) and (freeind caddr dlt)$

symbolic procedure freeind ind$
atom ind $
%       AND
%LAGP(IND,'EXTRNL)$

symbolic procedure mod!-dump(l,dump)$
if not freeind car l then mod!-dump1(cadr l,car l,dump)
else mod!-dump1(car l,cadr l,dump)$

symbolic procedure mod!-dump1(new,old,dump)$
if null dump then nil
else ( (caar dump) . l!-subst(new,old,cdar dump) ) .
                    mod!-dump1(new,old,cdr dump)$

symbolic procedure l!-subst(new,old,l)$
if null l then nil
else if old = car l then new . l!-subst(new,old,cdr l)
     else car l . l!-subst(new,old,cdr l) $

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/cvitmap.red0000644000175000017500000023536611526203062024162 0ustar  giovannigiovannimodule cvitmap;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


  exports calc_spur$
  imports simp!*,reval,calc_map_tar ,calc_den_tar,spaces$

% SIMP!* AND REVAL REDUCE SYSTEM GENERAL FUNCTIONS FOR
% EVALUATING ALGEBRAIC EXPRESSIONS.

%*********************************************************************
%                                                                    *
%                        FOR CVITANOVIC GAMMA MATRICES               *
%                                CALCULATIONS                        *
%                                                                    *
%                                                                    *
%                       18.03.88  10.06.90  15.06.90 31.08.90        *
%                       01.09.90  11.09.90  14.09.90                 *
%********************************************************************$
 lisp$
 % 07.06.90 all MAP was replaced by MAP_
 % 07.06.90 all DEN was replaced by DEN_
 % 07.06.90 all PROP was replaced by PROP_
 % SOME FUNCTIONS WAS MOVED TO SMACRO SECTION  08.06.90 10.06.90

%**********************************************************************
%                                                                     *
%                      _DATA_STRUCTURE                                *
%                                                                     *
%    WORLD::=(EDGELIST,VARIANTS,WORLD1)                               *
%    WORLD1::=(MAP_2,COEFF,DEN_OM)                                    *
%    MAP_2::=(MAP_S,VARIANTS,PLAN)                                    *
%    MAP_S::=(EDGEPAIR . GSTRAND)                                     *
%    MAP_1::=(EDGEPAIR . MAP_)                                        *
%    EDGEPAIR::=(OLDEDGELIST . NEWEDGELIST)                           *
%    COEFF::=LIST OF WORLDS (UNORDERED)                               *
%    ATLAS::=(MAP_,COEFF,DEN_OM)                                      *
%    MAP_::=LIST OF VERTICES (UNORDERED)                              *
%    VERTEX::=LIST OF EDGES (CYCLIC ORDER)                            *
%    VERTEX::=(NAME,PROP_ERTY,TYPE)                                   *
%    NAME::=ATOM                                                      *
%    PROP_ERTY::= (FIRSTPARENT . SECONDPARENT)                        *
%    TYPE::=T OR NIL                                                  *
%                                                                     *
%*********************************************************************$

%========================== PREDICATES =============================$


symbolic procedure is_indexp x$  % 01.09.90 RT
    (lambda z$
       z and cdr z)
     assoc(s_edge_name x,dindices!*)$

symbolic procedure mk_edge_name (name1,name2)$
% GENERATE NEW EDGE NAME $
<< n_edge := n_edge +1$
%INTERN COMPRESS APPEND(MK_NAME1 NAME1,
        compress append(mk_name1 name1,
                        append ( mk_name1 n_edge ,
                                 mk_name1 name2)) >> $

symbolic procedure new_edge (fedge,sedge)$
% GENERATE NEW EDGE $
begin
 scalar s$
 s:=
 mk_edge ( mk_edge_name ( s_edge_name fedge,
                          s_edge_name sedge),
            mk_edge_prop_ ( s_edge_name fedge,
                            s_edge_name sedge),
            mk_edge_type ( nil,
                           nil))$
 %          MK_EDGE_TYPE ( S_EDGE_TYPE FEDGE,
 %                         S_EDGE_TYPE SEDGE))$
 new_edge_list := s . new_edge_list $
 return s
 end$

symbolic procedure delete_vertex (vertex,map_)$
%DELETS VERTEX FROM MAP_$
if p_empty_map_ map_ then mk_empty_map_ ()
else
  if p_eq_vertex (vertex,s_vertex_first map_)
    then s_map__rest map_
  else
    add_vertex (s_vertex_first map_,
                 delete_vertex (vertex,s_map__rest map_))$

%====================== PREDICATES (CONTINUE) =====================$

symbolic procedure p_eq_vertex (vertex1,vertex2)$
% VERTICES ARE EQ IF THEY HAVE EQUAL NUMBER OF EDGES
% IN THE SAME ORDER WITH EQUAL _NAMES $
if p_empty_vertex vertex1 then p_empty_vertex vertex2
else
 if p_empty_vertex vertex2 then nil
 else
   if equal_edges (first_edge vertex1,
                    first_edge vertex2)
      then p_eq_vertex (s_vertex_rest vertex1,
                          s_vertex_rest vertex2)
   else nil$

%::::::::::::::::::::::: SOME ROUTINES :::::::::::::::::::::::::::::$

symbolic procedure mk_old_edge x$
 begin
  scalar s$
  s:=assoc(x,old_edge_list )$
  if s then return s$
  s:=mk_edge ( x,
                if not gamma5p x
                   then  mk_edge_prop_ (1,1)           %10.06.90 RT
                else     mk_edge_prop_ (ndim!*,ndim!*),
                mk_edge_type (t,t))$
 old_edge_list :=cons(s,old_edge_list )$
 return s
 end$

symbolic procedure change_name (name,edge)$
% CHANGES EDGE'S NAME $
mk_edge (name,
          s_edge_prop_ edge,
          s_edge_type edge )$

%======================= PREDICATES (CONTINUE) ================== $

symbolic procedure is_tadpole vertex$    %11.09.90 RT
% RETURNS T IF THERE IS ONLY ONE EXTERNAL LEG
    is_tadpolen(vertex) < 2$

symbolic procedure is_tadpolen vertex$    %11.09.90 RT
% RETURNS NUMBER OF EXTERNAL LEGS
  vertex_length diff_legs(vertex,mk_empty_vertex())$

symbolic procedure diff_legs(vertex,vertex1)$  %11.09.90 RT
% RETURNS LIST OF EXTERNAL LEGS
  if p_empty_vertex vertex then vertex1
  else  if p_member_edge(first_edge vertex,
                          s_vertex_rest vertex)
                      or
           p_member_edge(first_edge vertex,
                           vertex1)
           then diff_legs(s_vertex_rest vertex,vertex1)
         else  diff_legs(s_vertex_rest vertex,
                   add_edge(first_edge vertex,vertex1))$


symbolic procedure is_buble (vertex1,vertex2)$
% RETURNS NIL IF VERTEX1 AND VERTEX2 DOES NOT FORMED A BUBLE,
% OR N . MAP_ ,WHERE N IS A NUMBER OF EXTERNAL LINES ( 0 OR 2 ),
% MAP_ IS A MAP_ CONTAINING THIS BUBLE $
%NOT(IS_TADPOLE VERTEX1) AND NOT(IS_TADPOLE VERTEX2) AND  %14.09.90 RT
(lambda z$ if z >= 2 then nil
           else (2*z) . mk_vertex2_map_ (vertex1,vertex2))
vertex_length ( diff_vertex (vertex1,vertex2))$

%^^^^^^^^^^^^^^^^^^^^^^^ MAIN PROGRAM ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^$

symbolic procedure transform_map_ map_$
% GENERATE SIMPLE MAP_ (ONLY PRIMITIVE VERTICES) FROM INITIAL ONE$
begin
 scalar n_edge$
 n_edge := 0$
 new_edge_list :=nil$
 old_edge_list :=nil$
return
mk_simple_map_
(for each vertex in map_ collect
   prepare_map_ vertex)$
end$


%,,,,,,,,,,,,,,,,,,,,,RODIONOV & TARANOV INTERFACE ,,,,,,,,,,,,,,,$

global '(bubltr freemap_)$

symbolic procedure to_taranov map_$
% MAP_ IS INITIAL MAP_,
% RETURNS (FULL LIST OF EDGES (INITIAL AND GENERATED) .
%         (MAP_ OF PRIMITIVE VERTICES )  .
%         (LIST OF ALL POSSIBLE ENUMERATION OF MAP_'S EDGES) $
begin
  scalar new_edge_list ,old_edge_list ,full_edge_list ,
         new_map_ ,free_map_ ,marks ,variants ,alst ,bubles$
  new_map_ :=transform_map_ map_$
  free_map_ :=find_bubltr new_map_ $
  bubles:=car free_map_ $
  bubltr:=bubles $
  free_map_ := cdr free_map_ $
  freemap_:=free_map_ $
  full_edge_list := for each edge in old_edge_list collect
                          s_edge_name edge $
  alst:=nconc(for each x in full_edge_list collect (x . 1) ,
              list('!_0 . 0) ) $                   %ADD EMPTY EDGE $
  marks:=set_mark (new_edge_list ,
                   nil,
                   buble_proves bubles,
                   new_map_ ,
                   add_tadpoles (bubles,alst))$
 variants:=edge_bind (marks,alst)$
  full_edge_list :=nconc (for each edge in new_edge_list collect
                              s_edge_name edge,
                          full_edge_list )$
return full_edge_list .
       new_map_ .
       variants
end$


 % TEST TEST TEST  TEST TEST TEST TEST TEST TEST TEST $
 % TO_TARANOV '((A B C C B A)) $


%END$    %cvit2.red
%********************************************************************
%                     NOW WE MARKED THE MAP_                        *
%*******************************************************************$

                  % 09.03.88  $
lisp$

global '(ndim!* )$

%ERROERRORERRORERRORERROR ERROR ROUTINES ERRORERRORERRORERRORERROR $

global '(!*cviterror)$

flag('(cviterror),'switch)$

!*cviterror:=t$           % IF T THEN ERROR MESSAGES WILL BE PRINTED$

% The FEXPR for set_error has been re-written by JPff
%%%  symbolic fexpr procedure set_error u$
%%%  if !*cviterror then set_error0 (u,alst)
%%%  else
%%%     error(55,"ERROR IN MAP_ CREATING ROUTINES")  $
symbolic macro procedure set_error u$
   list('set_error_real,mkquote cadr u,cons('list,cddr u))$

symbolic procedure set_error_real (u,v)$
<<
   if !*cviterror then <<
     prin2 "Function: "$
     prin2 car u$
     prin2 " Arguments: "$
     if v then for each x in v do <<
        prin2 x$ prin2 " IS " $
        prin2 x$
        terpri()  >>;
    >>;
    error(55,"Error in MAP_ creating routines")
>>$

%ERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERE$

symbolic procedure mark_edges (newedges,oldedges,map_)$
  mk_proves (map_,oldedges) .
  set_mark (newedges,nil,nil,map_,
             for each x in oldedges collect (s_edge_name x .
                                             car s_edge_prop_ x ) ) $

symbolic procedure mk_proves (map_,oldedges)$
if p_empty_map_ map_ then nil
else
  if defined_vertex (s_vertex_first map_,oldedges) then
      s_vertex_first map_ .
      mk_proves (s_map__rest map_,oldedges)
  else
      mk_proves (s_map__rest map_,oldedges)$

symbolic procedure defined_vertex (vertex,oldedges)$
if p_empty_vertex vertex then t
else
 memq_edgelist (first_edge vertex,oldedges)
                and
 defined_vertex (s_vertex_rest vertex,oldedges)$

symbolic procedure set_mark (edges,notdef,toprove,map_,blst)$
% EDGES - LIST OF NEW EDGES CREATED WHILE MAKING A MAP_,
% NOTDEF - LIST OF EDGES WHICH CANNOT BE FULLY IDEN_TIFY,
% TOPROVE - LIST OF VERTICES FOR CHECKING TRIANGLE RULE,
% MAP_ - MAP_ CREATED EARLIER,
% BLST - ALIST OF BINDED EDGES$
if null edges then
    if notdef or toprove then          % 15.06.90 RT
                 set_error_real('set_mark,
                                list(edges,notdef,toprove,map_,blst))
    else nil
else
  (lambda z$
      if z then                  %THE EDGE IS FULLY DEFINED$
         set_prove (append(notdef,            %RESTOR LIST OF EDGES$
                            cdr edges),
                     car edges,
                     append(new_prove (car edges,    %ADD CHECKS$
                                        map_),
                            toprove),
                     map_,
                     (s_edge_name car edges . 0) .
                     blst)
     else
         set_mark (cdr edges,                   %TRY NEXT$
                    car edges . notdef,         % ADD NOT DEF. LIST$
                    toprove,
                    map_,
                    blst))
    ( assoc(caadar edges,blst)          %CHECK IF BOTH PARENT IS $
             and                        %ALREADY DEFINED         $
      assoc(cdadar edges,blst) ) $

symbolic procedure new_prove (edge,map_)$
% RETURNS NEW VERTEX FOR TRIANGLE RULE CHECKING LIST$
if null map_ then nil
else
  (lambda z$  if z then list z
              else new_prove (edge,cdr map_))
   new_provev (edge,car map_) $

 symbolic procedure new_provev (edge,vertex)$
 % CAN THIS VERTEX BE UTILIZED FOR CHECKING ? $
 if not member(edge,vertex) then nil
 else
  if (assoc(caadr edge,vertex)
           and
      assoc(cdadr edge,vertex))
    then nil
  else vertex $

symbolic procedure is_son (edge,vertex)$
 assoc(car s_edge_prop_ edge,vertex)$

symbolic procedure not_parents (edge,proves)$
if null proves then nil
else
  if is_son (edge,car proves)
     then cdr proves
  else car proves . not_parents (edge,cdr proves)$

symbolic procedure set_prove (edges,edge,toprove,map_,blst)$
% RETURNS A PAIR (EDGE . (LIST FOF VERICES FOR TRIANGLE RULE TEST))$
(lambda z$
   (edge . not_parents (edge,car z)) .
    set_mark (edges,nil,cdr z,map_,blst))
  find_proved (toprove,nil,nil,blst)$

symbolic procedure find_proved (toprove,proved,unproved,blst)$
% RETURNS A PAIR ((LIST OF ALREADY DEFINED VERTICES) .
%                 (LIST OF NOT YET DEFINED EDGES) ) $
if null toprove then proved . unproved
else
  if is_proved (car toprove,blst) then
                   find_proved (cdr toprove,
                                 car toprove . proved,
                                  unproved,
                                  blst)
  else             find_proved (cdr toprove,
                                 proved,
                                 car toprove . unproved,
                                 blst) $

symbolic procedure is_proved (vertex,blst)$
 if null vertex then t
 else if assoc(caar vertex,blst) then is_proved (cdr vertex,blst)
      else nil $

%@@@@@@@@@@@@@@@@@@@@@@@ NOW GENERATES ALL POSSIBLE NUMBERS @@@@@@@@$

symbolic procedure mk_binding (provedge,blst)$
 can_be_proved (car provedge,blst)
             and
 edge_bind (cdr provedge,blst)$

symbolic procedure edge_bind (edgelist,blst)$
if null edgelist then list blst
else
 begin
   scalar defedge,prop_,p,emin,emax,s,proves,i$
% DEFEDGE - EDGE WITH DEFINED RANG,
% PROP_ - ITS PROP_ERTY: (NUM1 . NUM2),
% P - ITS NAME,
% EMIN AND EMAX - RANGE OF P,
% S - TO STORE RESULTS,
% PROVES - CHECKS OF TRIANGLE LAW$
  defedge:=car edgelist$
  proves:=cdr defedge$
  defedge:=car defedge$
  edgelist:=cdr edgelist$
  p:=s_edge_name defedge$
  prop_:=s_edge_prop_ defedge$
  emin:=assoc(car prop_,blst)$
  emax:=assoc(cdr prop_,blst)$
 if null emin or null emax
   then set_error_real ('edge_bind,list(prop_,blst))$
 prop_:=(cdr emin) . (cdr emax)$
  emin:=abs((car prop_)-(cdr prop_))$
  emax:=(car prop_)+(cdr prop_)$
 if numberp ndim!* then              %NUMERICAL DIMENSIONAL$
    << emax:=min(emax,ndim!*)$
       if emin > ndim!* then return nil >> $
 i:=emin$
loop:
       if i > emax then return s$
       if can_be_proved (proves,(p . i) . blst)
         then s:=append(edge_bind (edgelist,
                                    (p . i) . blst),
                        s) $
       i:=i+2$
 go loop
end$

symbolic procedure can_be_proved (proves,blst)$
if null proves then t
else if can_be_p (car proves,blst) then
        can_be_proved (cdr proves,blst)
     else nil$

symbolic procedure can_be_p (vertex,blst)$
%CHECKS TRIANGLE RULE$
begin
  scalar i,j,k$
  i:=assoc(car car   vertex,blst)$
  j:=assoc(car cadr  vertex,blst)$
  k:=assoc(car caddr vertex,blst)$
  if null i or null j or null k then set_error_real('can_be_proved,
                                                     list(vertex,%%edge,
                                                     blst))$
  i:=cdr i$
  j:=cdr j$
  k:=cdr k$
  if numberp ndim!* and (i+j+k) > (2*ndim!*) then
    return nil $                           %SINCE S+T+U (i+j)
         then nil
        else t
end$

%END$  %cvit4.red
%OOOOOOOOOOOOOOOOOOOOOOOOO ROUTINES TO SELECT BUBLES OOOOOOOOOOOOOOOO$

lisp$                                   %24.05.88$

symbolic procedure find_bubles atlas$
 find_bubles1 (atlas,old_edge_list )$

symbolic procedure find_bubles_coeff (atlaslist,edgelist,bubles)$
%F NULL BUBLES THEN NIL . ATLASLIST
%LSE
 find_bubles1_coeff (atlaslist,nil,edgelist,bubles)$

symbolic procedure find_bubles1_coeff (atlaslist,passed,edgelist,
                                                          bubles)$
if null atlaslist then bubles . passed
else
 (lambda z$             %Z - PAIR = (BUBLES . REDUCED MAP_)
    find_bubles1_coeff (cdr atlaslist,
                          cdr z . passed,
                          edgelist,
                          if null car z then bubles else
                          car z . bubles) )
  find_bubles1 (car atlaslist,edgelist) $

symbolic procedure mk_atlaslist (map_,coeff,den_om)$
 list mk_atlas (map_,coeff,den_om)$

symbolic procedure find_bubles1 (atlas,edgelist)$
  select_bubles (nil,
                 s_atlas_map_ atlas,
                 nil,
                 s_atlas_coeff atlas,
                 s_atlas_den_om atlas,
                 edgelist)$

symbolic procedure select_bubles(bubles,map_,passed,coeff,den_om,al)$
% RETURNS (LIST OF BUBLES ) . ATLAS,
% WHERE BUBLES ARE TWO OR ONE VERTICES MAP_S $
if p_empty_map_  map_ then
             (lambda x$
                     car x .
                           mk_atlas (passed,cdr x,den_om))
              find_bubles_coeff (coeff,
                                 union_edges (map__edges passed,
                                              al),
                                 bubles)
else
 if (map__length map_ + map__length passed) < 3 then
         select_bubles (bubles,
                        mk_empty_map_ (),
                        append_map_s(map_,
                                     passed),
                        coeff,
                        den_om,
                        al)
 else
  (lambda z$                          % Z IS NIL OR A PAIR
                                      % N . MAP_ ,WHERE
                                      % N - NUMBER OF FREE EDGES$
     if z then                                      %A BUBLE IS FIND$
      (lambda d$
       (lambda bool$              %BOOL=T IFF ALL EDGES CAN BE DEFINED$
      if car z = 0 then                             %NO EXTERNAL LINES$
       if bool then
        select_bubles ( z . bubles,
                         mk_empty_map_ (),
                         cdr z,
                         mk_atlaslist ( conc_map_s (passed,
                                                    delete_vertex (
                                                      s_vertex_second
                                                                cdr z,
                                                      s_map__rest
                                                                map_)),
                                         coeff,
                                         den_om),
                         nil,
                         al)
       else
        select_bubles ( z . bubles,               %ADD BUBLE$
                         delete_vertex (s_vertex_second cdr z,
                                         s_map__rest map_),
                         passed,
                         try_sub_atlas (mk_atlas (cdr z,
                                                  nil,
                                                  nil),
                                        coeff),
                         den_om,
                         al)
      else
       if not p_old_vertex d then
        if bool then
        select_bubles (z . bubles,
                        mk_empty_map_ (),
                        cdr z,
                        mk_atlaslist (conc_map_s (passed,
                                                  buble_vertex (
                                                    cdr z,
                                                    delete_vertex (
                                                     s_vertex_second
                                                        cdr z,
                                                     s_map__rest
                                                        map_ ),
                                                     al)),
                                       coeff,
                                       den_om),
                         list d,
                         al)
        else
        select_bubles ( z . bubles,               %ADD NEW BUBLE$
                        buble_vertex (cdr z,      %RENAME EDGES $
                             conc_map_s (passed,
                             delete_vertex (s_vertex_second cdr z,
                                            s_map__rest map_)),
                                        al),
                         mk_empty_map_ (),
                         try_sub_atlas (mk_atlas (cdr z,nil,list d),
                                        coeff),
                         den_om,
                         al)
       else
        if bool then
        select_bubles (z . bubles,
                        mk_empty_map_ (),
                        ren_vertmap_ (d,cdr z),
                        mk_atlaslist (
                          conc_map_s (
                            passed,
                            add_vertex (add_edge (!_0edge ,d),
                                        delete_vertex (
                                            s_vertex_second cdr z,
                                            s_map__rest map_ ))),
                          coeff,
                          den_om),
                        list ren_vertices (d,d),
                        al)
        else
        select_bubles (z . bubles,
                        add_vertex (add_edge (!_0edge ,d),
                                    delete_vertex(s_vertex_second cdr z,
                                                  s_map__rest map_)
                                    ),
                        passed,
                        try_sub_atlas (mk_atlas (ren_vertmap_
                                                    (d,cdr z),
                                                 nil,
                                                 list
                                                 ren_vertices (d,d)
                                                 ),
                                        coeff),
                        den_om,
                        al )
                                     )
   %      ALL_DEFINED (CDR Z,AL))
          t                           )
        delta_edges cdr z
     else
        select_bubles (bubles,
                       s_map__rest map_,
                       add_vertex (s_vertex_first map_,passed),
                       coeff,
                       den_om,
                       al )
                                )
   find_buble (s_vertex_first map_,
               s_map__rest map_ ) $

symbolic procedure p_old_vertex vertex$
% RETURNS T IFF ALL EDGES OF VERTEX ARE OLD OR VERTEX IS EMPTY ONE$
if p_empty_vertex vertex then t
else p_old_edge first_edge vertex
             and
     p_old_vertex s_vertex_rest vertex$

symbolic procedure renames_edges (vertex,al)$
rename_edges_par (first_edge vertex,
                    second_edge vertex,
                    al)$

symbolic procedure rename_edges_par (vertex1,vertex2,al)$
% Here VERTEX1 and VERTEX2 are edges!
if   defined_edge (vertex1,al)
     and not p_old_edge(vertex2)  then        % 14.09.90 RT
       replace_edge (vertex2,vertex1,new_edge_list )
else
  if defined_edge (vertex2,al)
     and not p_old_edge(vertex1)  then        % 14.09.90 RT
       replace_edge (vertex1,vertex2,new_edge_list )
  else
    if  p_old_edge (vertex1)
        and not p_old_edge(vertex2)  then        % 14.09.90 RT
         replace_edge (vertex2,vertex1,new_edge_list )
    else
      if p_old_edge (vertex2)
         and not p_old_edge(vertex1)  then        % 14.09.90 RT
          replace_edge (vertex1,vertex2,new_edge_list )
      else rename_edges (vertex1,vertex2)$

symbolic procedure buble_vertex (map_2,map_,al)$
if p_empty_map_ map_2 then mk_empty_map_ ()
else
  << renames_edges (delta_edges map_2,al)$
     map_ >> $

symbolic procedure delta_edges map_2$
% MAP_2 - MAP_ OF TWO VERTICES $
mk_edge2_vertex (
                   first_edge
                               diff_vertex (s_vertex_first map_2,
                                            s_vertex_second map_2),
                   first_edge
                               diff_vertex (s_vertex_second map_2,
                                            s_vertex_first map_2 )
                  )$

symbolic procedure delta_names map_2$
% MAP_2 - MAP_ OF TWO VERTICES $
(lambda z$
     s_edge_name first_edge car z .
     s_edge_name first_edge cdr z  )
 (diff_vertex (s_vertex_first map_2,
               s_vertex_second map_2) .
  diff_vertex (s_vertex_second map_2,
               s_vertex_first map_2) ) $

symbolic procedure old_rename_edges (names,map_)$
if p_empty_map_ map_ then mk_empty_map_ ()
else add_vertex (ren_edge (names,s_vertex_first map_),
                 old_rename_edges (names,
                                s_map__rest map_) ) $

symbolic procedure ren_vertmap_ (vertex1,map_)$
% VERTEX1 MUST BE TWO EDGE VERTEX,
% EDGES OF VERTEX2 TO BE RENAME$
if vertex_length vertex1 neq 2 then set_error_real ('ren_vertmap_  ,
                                                     list(vertex1,map_))
else old_rename_edges (s_edge_name first_edge vertex1 .
                       s_edge_name second_edge vertex1,
                       map_)$

symbolic procedure ren_vertices (vertex1,vertex2)$
% VERTEX1 MUST BE TWO EDGE VERTEX,
% EDGES OF VERTEX2 TO BE RENAME$
if vertex_length vertex1 neq 2
  then set_error_real ('ren_vertices,list(vertex1,vertex2))
else ren_edge (s_edge_name first_edge vertex1 .
               s_edge_name second_edge vertex1,
               vertex2)$

symbolic procedure ren_edge (names,vertex)$
% NAMES IS NAME1 . NAME2,
% CHANGE NAME1 TO NAME2$
if null assoc(car names,vertex) then vertex  %NO SUCH EDGES IN VERTEX$
else ren_edge1 (names,vertex)$

symbolic procedure ren_edge1 (names,vertex)$
if p_empty_vertex vertex then mk_empty_vertex ()
else if car names =s_edge_name first_edge vertex then
        add_edge ( change_name (cdr names,first_edge vertex),
                   ren_edge1 (names ,s_vertex_rest vertex))
     else
        add_edge ( first_edge vertex,
                   ren_edge1 (names,s_vertex_rest vertex))$

symbolic procedure find_buble (vertex,map_)$
if p_empty_map_ map_ then mk_empty_map_ ()
else
  is_buble (vertex,s_vertex_first map_)
  or
  find_buble (vertex,s_map__rest map_) $

symbolic procedure diff_vertex (vertex1,vertex2)$
if p_empty_vertex vertex1 then mk_empty_vertex ()
else
  if p_member_edge (first_edge vertex1,vertex2)
                    and
      not equal_edges (first_edge vertex1,!_0edge )
     then diff_vertex (s_vertex_rest vertex1,vertex2)
  else
    add_edge (first_edge vertex1,
              diff_vertex (s_vertex_rest vertex1,vertex2)) $

%SSSSSSSSSSSSSSSSSSSSSSSSSS NOW MAKES PROVES FROM BUBLE PPPPPPPPPPPPPP$

global '(!_0edge )$

!_0edge :=mk_edge ('!_0 ,
                   mk_edge_prop_ (0,0),
                   mk_edge_type (t,t)) $

symbolic procedure buble_proves bubles$
if null bubles then nil
else
  if caar bubles = 0                           %NO EXTERNAL LINES $
    then buble_proves cdr bubles
  else if caar bubles = 2 then
       mk_edge3_vertex (
                          first_edge diff_vertex (
                                      s_vertex_first cdar bubles,
                                      s_vertex_second cdar bubles),
                          first_edge diff_vertex (
                                      s_vertex_second cdar bubles,
                                      s_vertex_first cdar bubles),
                          !_0edge ) .
                                      buble_proves cdr bubles
        else
         if caar bubles = 3 then
               car cdar bubles .
                                 buble_proves cdr bubles
         else buble_proves cdr bubles $


symbolic procedure try_sub_atlas (atlas,atlaslist)$
if null atlaslist then list atlas
else
  if sub_map__p (s_atlas_map_ atlas,
                 s_atlas_den_om car atlaslist)
   then try_sub_atlas (mk_sub_atlas (atlas,car atlaslist),
%  THEN TRY_SUB_ATLAS (MK_SUB_ATLAS (CAR ATLASLIST,
%                                        ATLAS        ),
                         cdr atlaslist)
  else  car atlaslist .
        try_sub_atlas (atlas,cdr atlaslist)$

symbolic procedure sub_map__p (map_1,den_)$
%MAP_1 AND DEN_  HAVE COMMON VERTEX (DEN_ - DEN_OMINATOR)$
if p_empty_map_ map_1 then nil
else  sub_vertex_map_ (s_vertex_first map_1,den_)
                    or
      sub_map__p (s_map__rest map_1,den_)$

symbolic procedure sub_vertex_map_ (vertex,den_)$
if null den_ then nil
else p_common_den_ (vertex,car den_)
                  or
     sub_vertex_map_ (vertex,cdr den_)$

symbolic procedure  p_common_den_ (vertex,vertexd)$
(lambda n$
    if n = 3 then                                %TRIANGLE
             p_eq_vertex (vertex,vertexd)

    else
      if n = 2 then                              %KRONEKER
             p_member_edge (first_edge vertexd,vertex)
      else nil )
  vertex_length vertexd $

symbolic procedure mk_sub_atlas (atlas1,atlas2)$
 mk_atlas (s_atlas_map_ atlas1,
           atlas2 . s_atlas_coeff atlas1,
           s_atlas_den_om atlas1)$

symbolic procedure all_defined (map_,al)$
 all_defined_map_ (map_,
                   defined_append(map__edges map_,al))$

symbolic procedure all_defined_map_ (map_,al)$
 al1_defined_map_ (map_,mk_empty_map_ (),al)$

symbolic procedure al1_defined_map_ (map_,passed,al)$
% T IF ALL EDGES IN MAP_ CAN BE DEFINED $
if p_empty_map_ map_ then
 if p_empty_map_ passed then t
 else nil
else
 if all_defined_vertex (s_vertex_first map_,al) then
     al1_defined_map_ (conc_map_s(passed,s_map__rest map_),
                       mk_empty_map_ (),
                       append(vertex_edges s_vertex_first map_ ,al))
 else
     al1_defined_map_ (s_map__rest map_,
                       add_vertex (s_vertex_first map_,passed),
                       al)$

symbolic procedure all_defined_vertex (vertex,al)$
 al1_defined_vertex (vertex,mk_empty_vertex (),
                            mk_empty_vertex (),al)$

symbolic procedure al1_defined_vertex (vertex,passed,defined,al)$
% T IF ALL EDGES IN VERTEX CAN BE DEFINED $
if p_empty_vertex vertex then
 if p_empty_vertex passed then t
 else re_parents (passed,defined)
else
  if defined_edge (first_edge vertex,al)
                    then
     al1_defined_vertex (conc_vertex(passed,s_vertex_rest vertex),
                         mk_empty_vertex (),
                         add_edge (first_edge vertex,defined),
                         first_edge vertex . al)
  else
     al1_defined_vertex (s_vertex_rest vertex,
                         add_vertex (first_edge vertex,passed),
                         defined,
                         al)$

symbolic procedure re_parents (passed,defined)$
%TRY TO MAKE NEW PARENTS
if vertex_length passed = 1 and vertex_length defined = 2
  then make_new_parents (first_edge passed,defined)
else nil$

symbolic procedure make_new_parents (edge,vertex)$
%VERTEX CONSISTS OF TWO EDGES
 add_parents0 (edge,
               s_edge_name first_edge vertex .
               s_edge_name second_edge vertex ,
               t)$


%^.^.^.^.^.^.^.^.^.^.^.^.^.^.^..^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^
%          13.05.88


symbolic procedure p_def_edge edge$
 s_edge_type edge$
%P_OLD_EDGE EDGE$

symbolic procedure defined_edge (edge,al)$
  p_old_edge edge
      or
 defined_all_edge (all_edge (s_edge_name edge,new_edge_list ),
                   nil,
                   al) $

symbolic procedure all_edge (edgename,edgelist)$
if null edgelist then nil
else
  if edgename eq s_edge_name car edgelist then
                 car edgelist . all_edge (edgename,cdr edgelist)
  else all_edge (edgename,cdr edgelist)$

symbolic procedure def_edge (edge,al)$
(lambda z$
          assoc(car z,al) and assoc(cdr z,al))
 s_edge_prop_ edge$

symbolic procedure defined_all_edge (edgelist,passed,al)$
if null edgelist then nil
else
  if def_edge (car edgelist,al) then
    if p_def_edge car edgelist then t  %REPLACE WAS ALREADY DONE
    else  rep_edge_prop_ (nconc(passed,edgelist),
                          s_edge_prop_ car edgelist . list t)
  else defined_all_edge (cdr edgelist,
                         car edgelist . passed,
                         al)$

symbolic procedure rep_edge_prop_ (edgelist,prop_)$
if null edgelist then t
else << rplacd(car edgelist,prop_)$           %CHANGE EDGE PARENTS
        rep_edge_prop_ (cdr edgelist,prop_) >> $



%END$  %cvit6.red
%<><><><><><><><><><><> ROUTINES FOR SELECTING TRIANGLES <><><><><><>$
                            %24.05.88$

global '(!*cvitbtr !*cviterror)$

flag('(cvitbtr),'switch)$

!*cvitbtr:=t$           %IF T THEN BUBLES AND TRIANGLES  WILL BE
                        %     FACTORIZED

!*cviterror:=t$         %IF T THEN ERROR MESSAGES WILL BE PRINTED

symbolic procedure find_triangles atlas$
 find_triangles1 (atlas,old_edge_list)$

symbolic procedure find_triangles1 (atlas,al)$
 select_triangles (nil,
                   s_atlas_map_ atlas,
                   nil,
                   s_atlas_coeff atlas,
                   s_atlas_den_om atlas,
                   al)$

symbolic procedure find_triangl_coeff (atlaslist,edgelist,triangles)$
 find_triangle_coeff (atlaslist,nil,edgelist,triangles)$

symbolic procedure find_triangle_coeff(atlaslist,passed,edgelist,
                                         triangles)$
if null atlaslist then triangles . passed
else
 (lambda z$                 % Z - PAIR= (TRIANGLES . REDUCED MAP_)
     find_triangle_coeff (cdr atlaslist,
                          cdr z . passed,
                          edgelist,
                          if null car z then triangles
                          else car z . triangles))
  find_triangles1 (car atlaslist,edgelist)$

symbolic procedure select_triangles (triangles,map_,passed,
                                      coeff,den_om,al)$
%RETURNS A PAIR OF THE FORM ( (LIST OF TRIANGLES) . (ATL.WITHOUT TR.))$
if p_empty_map_ map_ then                       %No triangles found.
      (lambda x$
              car x .
              mk_atlas (passed,cdr x,den_om))
      find_triangl_coeff (coeff,
                          union_edges (map__edges passed,al),
                          triangles)
else
 if (map__length map_ + map__length passed) < 4 then
    select_triangles (triangles,
                      mk_empty_map_ (),
                      append_map_s (map_,passed),
                      coeff,
                      den_om,
                      al)
 else
 (lambda z$
    if z then                                    %TRIANGLE IS FOUND$
     (lambda trn$                                %TRN - NEW VERTEX $
     %IF ALL_DEFINED (CDDR Z,AL) THEN
      if t then
         select_triangles (
             z . triangles,
             mk_empty_map_ (),
             add_vertex (trn,cddr z),
             mk_atlaslist (
                  conc_map_s (
                      mk_vertex1_map_  trn,
                      conc_map_s (passed,delete_map_s (cddr z,map_))
                             ),
                  coeff,
%                 TRN . DEN_OM    ),
                  den_om    ),
%            NIL,
             list trn,
             al             )
       else
       select_triangles ( z . triangles,       %ADD NEW TRIANGLE $
 %     SELECT_TRIANGLES ( CDDR Z . TRIANGLES,  %ADD NEW TRIANGLE$
                           conc_map_s (mk_vertex1_map_
                                       trn,     %ADD NEW VERTEX$
                                       conc_map_s (passed,
                                                   delete_map_s(cddr z,
                                                                map_)
                                                  )
                                      ),
                          mk_empty_map_ (),
                          try_sub_atlas (
                              mk_atlas (add_vertex (trn,cddr z),
                                        nil,
                                        list trn),
                              coeff       ),
                          den_om,
                          al
                         )
                   )
      sk_vertextr z
    else
       select_triangles (triangles,
                         s_map__rest map_,
                         add_vertex (s_vertex_first map_,passed),
                         coeff,
                         den_om,
                         al
                         ) )
reduce_triangle
 find_triangle (s_vertex_first map_,
                s_map__rest map_) $

symbolic procedure vertex_neighbour (vertex,map_)$
%RETURNS A MAP_ OF VERTEX NEIGHBOURS $
if p_empty_vertex vertex
           or
   p_empty_map_ map_ then mk_empty_map_ ()
else
  (lambda z$             %Z - NIL OR A PAIR (EDGE . ADJACENT EDGE )$
     if z then
        add_vertex (cdr z,
                     vertex_neighbour (delete_edge (car z,vertex),
                                       delete_vertex (cdr z,map_)))
     else
        vertex_neighbour (vertex,s_map__rest map_))
   is_neighbour (vertex,
                  s_vertex_first map_)$

symbolic procedure delete_map_s (map_1,map_2)$
if p_empty_map_ map_1 then map_2
else delete_map_s (s_map__rest map_1,
                   delete_vertex (s_vertex_first map_1,map_2) ) $

symbolic procedure delete_edge (edge,vertex)$
%DELETES EDGE FROM VERTEX $
if p_empty_vertex vertex then mk_empty_vertex ()
else
  if equal_edges (edge,first_edge vertex)
   then s_vertex_rest vertex
  else
    add_edge (first_edge vertex,
               delete_edge (edge,
                            s_vertex_rest vertex ) ) $

symbolic procedure is_neighbourp (vertex1,vertex2)$
% ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
if p_empty_vertex vertex1 then nil         % NIL IF NOT NEIGHBOURS$
else
     p_member_edge (first_edge vertex1,vertex2)
                    or
     is_neighbourp (s_vertex_rest vertex1,vertex2)$

symbolic procedure is_neighbour (vertex1,vertex2)$
% ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
% IF THEY ARE THEN RETURN A PAIR: (ADJ.EDGE . VERTEX2)$
if p_empty_vertex vertex1 then nil         % NIL IF NOT NEIGHBOURS$
else
  (lambda z$
     if z then                   %FIRTS VERTEX IS ADJACENT TO VERTEX2$
          first_edge vertex1 . vertex2
     else is_neighbour (s_vertex_rest vertex1,
                         vertex2 ) )
   p_member_edge (first_edge vertex1,
                    vertex2)$

symbolic procedure find_triangle (vertex,map_)$
%FINDS TRIANGLE WICH INCLUDES THE VERTEX.
%RETURNS MAP_ OF THREE VERTICES (TRIANGLE) OR NIL $
(lambda z$               %Z - MAP_ OF VERTICES WICH ARE NEIGHBOURS
                         %  OF VERTEX OR (IF NO NEIGHBOURS) EMPTY MAP_$
   if map__length z neq 2 then nil
   else add_vertex (vertex,z) )
 is_closed vertex_neighbour (vertex,map_)$

symbolic procedure is_closed map_$
if p_empty_map_ map_   or
   p_empty_map_ s_map__rest map_ then mk_empty_map_ ()
else
    two_neighbour (s_vertex_first map_,
                    s_map__rest map_)
             or
    is_closed s_map__rest map_$

symbolic procedure two_neighbour (vertex,map_)$
% HAS VERTEX A NEIGHBOUR IN THE MAP_ ? $
if p_empty_map_ map_ then nil
else
 if is_neighbourp (vertex,s_vertex_first map_)
    then mk_vertex2_map_ (vertex,s_vertex_first map_)
 else two_neighbour (vertex,s_map__rest map_)$

symbolic procedure mk_vertextr map_$
%MAKES VERTEX FROM TRIANGLE MAP_$
if map__length map_ neq 3 then set_error_real ('mk_vertextr ,list(map_))
else
    mk_vertextr3 (map_,3)$

symbolic procedure add_edge1(edge,vertex)$ % 14.09.90 RT
 if null edge then vertex
 else add_edge(edge,vertex)$

symbolic procedure mk_vertextr3 (map_,n)$
if n <= 0 then mk_empty_map_ ()
else
  add_edge1 (take_edge (s_vertex_first map_,
                         s_map__rest map_),
             mk_vertextr3 (cycl_map_ map_,n-1)) $

symbolic procedure take_edge (vertex,map_)$
if p_empty_vertex vertex then nil    %14.09.90 RT
% SET_ERROR ('TAKE_EDGE ,VERTEX,MAP_)    % 14.09.90  RT
else
%  IF P_EMPTY_VERTEX S_VERTEX_REST VERTEX THEN FIRST_EDGE VERTEX
%  ELSE                                     % 14.09.90 RT
    if contain_edge (first_edge vertex,map_)
                 and
       not equal_edges (first_edge vertex,!_0edge )
     then take_edge (s_vertex_rest vertex,map_)
    else first_edge vertex$

symbolic procedure contain_edge (edge,map_)$
% IS THERE A VERTEX IN THE MAP_ CONTAINING THE EDGE? $
if p_empty_map_ map_ then nil
else
    p_member_edge (edge,s_vertex_first map_)
                    or
    contain_edge (edge,s_map__rest map_) $

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,SORTING AFTER FACTORIZATION ,,,,,,,,,,,$
%      19.05.88 $

symbolic procedure find_bubltr atlas$
if null !*cvitbtr then atlas else
begin
 scalar s$
 s:=errorset(list('find_bubltr0 ,mkquote atlas),
             !*cviterror,
             !*backtrace)$
 return
     if atom s then atlas
     else car s
 end$

symbolic procedure find_bubltr0 atlas$
%(LAMBDA Z$
%    IF CAR Z THEN  SORT_ATLAS CDR Z  %FACTORIZATION HAPPENED
%    ELSE CDR Z)
 sort_atlas cdr
  find_bubltr1 (atlas,old_edge_list )$

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$

symbolic procedure find_bubltr1 (atlas,al)$
%FINDS BOTH BUBLES AND TRIANGLES IN ATLAS$
begin
 scalar s,c,bubles$
 s:=find_bubles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
loop:
 s:=find_triangles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
 if null c then return bubles . atlas$
 s:=find_bubles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
 if null c then return bubles . atlas$
 go loop
end$

symbolic procedure reduce_triangle triangle$
% RETURN (N . VERTEX . TRIANGLE) OR NIL,
% N - NUMBER OF EXTERNAL EDGES$
if null triangle then nil
else
  begin
    scalar extedges,vertex,n$
    %EXTEDGES - LIST OF EXTERNAL EDGES,
    % N - NUMBER OF EXTERNAL EDGES,
    %VERTEX - NEW VERTEX,MADE FROM TRIANGLE$
      vertex:=mk_vertextr triangle$
      extedges:=ext_edges vertex$
      n:=length extedges$
  return
         if n = 1 then nil            % 14.09.90    RT
         else                         % 14.09.90    RT
             n . vertex . triangle
end$

symbolic procedure sk_vertextr z$
% Z IS (N . VERTEX . TRIANGLE) $
if car z = 1 then mk_empty_vertex ()
else
 if car z = 3 then cadr z
 else set_error_real ('sk_vertextr,list z) $

symbolic procedure ext_edges vertex$
%SELECT EXTERNAL EDGES IN VERTEX $
if p_empty_vertex vertex then nil
else
  if p_member_edge (first_edge vertex,s_vertex_rest vertex)
                         or
     equal_edges (first_edge vertex,!_0edge )
   then ext_edges delete_edge (first_edge vertex,
                                 s_vertex_rest vertex)
  else first_edge vertex .
                           ext_edges s_vertex_rest vertex $

symbolic procedure ext_edges_map_ map_$
%SELECT EXTERNAL EDGES OF MAP_$
if p_empty_map_ map_ then nil
else
  ext_map__ver (ext_edges s_vertex_first map_,
                 ext_edges_map_ s_map__rest map_)$

symbolic procedure ext_map__ver (vlist,mlist)$
if null vlist then mlist
else
  if memq(car vlist,mlist) then
       ext_map__ver (cdr vlist,
                      delete(car vlist,mlist))
  else ext_map__ver (cdr vlist,car vlist . mlist)$

symbolic procedure add_tadpoles (bubles,alst)$
if null bubles then alst
else
  if caar bubles = 1 then
       add_tadpoles (cdr bubles,
                      cons(cons(car mk_vertextr cadr car bubles,
                                0),
                           alst))
   else add_tadpoles (cdr bubles,alst)$


%END$  %cvit8.red
%::::::::::::::::::::::: ATLAS SORTING ROUTINES ********************** $
% 13.06.88$

lisp$

global '(!*cvitrace)$

!*cvitrace:=nil$  %IF T THEN TRACE BACTRAKING WHILE ATLAS SORTING$

 flag('(cvitrace),'switch)$

symbolic procedure sort_atlas atlas$
%TOP LEVEL PROCEDURE
if null atlas then atlas
else
 (lambda z$
   if z then z        %ATLAS FULLY SORTED
   else set_error_real ('sort_atlas ,list atlas))
  sort_atlas1 atlas $

symbolic procedure sort_atlas1 atlas$
(lambda z$
   if z then z          %ATLAS FULLY SORTED
   else
     if !*cviterror then print_atlas_sort (atlas,nil)
     else nil )
 atlas_sort (atlas,old_edge_list )$

symbolic procedure print_atlas_sort (atlas,edgelist)$
<< print "Atlas not sorted "$
   print_atlas atlas$
   if edgelist then
      << print "Defined edges: "$
         for each edge in edgelist do print edge >> $
   nil >> $

symbolic procedure atlas_sort (atlas,edgelist)$
begin
  scalar z,newedges$
 newedges:=store_edges new_edge_list$
 z:=
 errorset(list('atlas_sort1 ,mkquote atlas,mkquote edgelist),
          !*cvitrace,
          !*backtrace)$
 return
 if atom z then        %ATLAS NOT SORTED
 << restor_edges (newedges,new_edge_list)$  %RESTORE EDGES PARENTS
    if !*cvitrace then print_atlas_sort (atlas,edgelist)
    else nil >>
 else car z
end$

symbolic procedure store_edges edgelist$
for each edge in edgelist collect
      (car edge . cdr edge)$

symbolic procedure restor_edges (edgelist,newedgelist)$
if null edgelist then
 if newedgelist
   then set_error_real ('restor_edges ,list(edgelist,newedgelist))
 else nil
else
 if null newedgelist then
           set_error_real ('restor_edges ,list(edgelist,newedgelist))
 else
  if s_edge_name car edgelist = s_edge_name car newedgelist then
      << rplacd(car newedgelist,cdar edgelist)$
         car newedgelist . restor_edges (cdr edgelist,
                                          cdr newedgelist) >>
  else
    set_error_real ('restor_edges ,list(edgelist,newedgelist))$

symbolic procedure defined_atlas (atlas,edgelist)$
(lambda edges$
    defined_edges (edges,
%                   DEFINED_APPEND(EDGES,EDGELIST)))
                    edgelist))
 atlas_edges atlas$

symbolic procedure defined_append (edges,edgelist)$
 if null edges then edgelist
 else if defined_edge (car edges,edgelist) then
          car edges . defined_append (cdr edges,edgelist)
      else defined_append (cdr edges,edgelist) $

symbolic procedure defined_edges (edges,edgelist)$
if null edges then t
else
  if defined_edge (car edges,edgelist)
              then
     defined_edges (cdr edges,car edges . edgelist)
  else definedl_edges (cdr edges,list car edges,edgelist)$

symbolic procedure definedl_edges (edges,passed,edgelist)$
if null edges then null passed
else
 if defined_edge (car edges,edgelist) then
    defined_edges (nconc(passed,cdr edges),car edges . edgelist)
 else definedl_edges (cdr edges,car edges . passed,edgelist)$

symbolic procedure atlas_sort1 (atlas,edgelist)$
if all_defined (s_atlas_map_ atlas,edgelist) then
     mk_atlas (s_atlas_map_ atlas,
                coeff_sortl( s_atlas_coeff atlas,
                              nil,
                              nconc( map__edges s_atlas_map_ atlas,
                                     edgelist)),
                s_atlas_den_om atlas)
else coeff_sort (coeff_ordn (s_atlas_coeff atlas,edgelist),
%LSE COEFF_SORT (S_ATLAS_COEFF ATLAS,
                  mk_atlaslist (s_atlas_map_ atlas,
                                 nil,
                                 s_atlas_den_om atlas),
                  edgelist)$

symbolic procedure coeff_sortl (atlaslist,passed,edgelist)$
 coeff_sortl1 (coeff_ordn (atlaslist,edgelist),passed,edgelist)$

symbolic procedure coeff_sort (atlaslist,passed,edgelist)$
if atlaslist then
  (lambda z$                   %Z - NIL OR SORDET ATLAS
      if z then                %FIRST ATLAS ALREADY DEFINED
         mk_atlas (s_atlas_map_ z,
                    coeff_sortl (append(s_atlas_coeff z,
                                        append(cdr atlaslist,passed)),
                                  nil,
                                  nconc(map__edges s_atlas_map_ z,
                                        edgelist)),
                    s_atlas_den_om z)
      else
          coeff_sort (cdr atlaslist,
                       car atlaslist . passed,
                       edgelist))
  atlas_sort (car atlaslist,edgelist)
else coeff_sort_f (passed,nil,edgelist)$

symbolic procedure coeff_sort_f (passed,farewell,edgelist)$
if null passed then
  if null farewell then nil
  else error(51,nil)
else
 if s_atlas_coeff car passed then          %NOT EMPTY COEFF
   coeff_sort (append(
                   s_atlas_coeff car passed,
                   mk_atlas (s_atlas_map_ car passed,
                              nil,
                              s_atlas_den_om car passed) .
                     append(cdr passed,farewell)),
                nil,
                edgelist)
 else coeff_sort_f (cdr passed,
                      car passed . farewell,
                      edgelist) $

%.......... 31.05.88 ::::::::::: $

symbolic procedure coeff_ordn (atlaslist,edgelist)$
for each satlas in
 coeff_ordn1 (mk_spec_atlaslist (atlaslist,edgelist),nil)
collect cdr satlas$

symbolic procedure mk_spec_atlaslist (atlaslist,edgelist)$
 for each atlas in atlaslist collect mk_spec_atlas (atlas,edgelist)$

symbolic procedure mk_spec_atlas (atlas,edgelist)$
%RETURN PAIR (PAIR1 . ATLAS)
%WHERE PAIR1 IS A PAIR - EDGES . PARENTS
%WHERE EDGES - ALL EDGES OF ATLAS
%WHERE PARENTS-THOSE PARENTS OF EDGES WICH NOT CONTAITED IN EDGELIST
(lambda edges$
(edges . diff_edges (edges_parents edges,edgelist)) . atlas)
 atlas_edges atlas$

symbolic procedure edges_parents edgelist$
if null edgelist then nil
else
  (lambda z$
     append(z ,edges_parents cdr edgelist))
   edge_new_parents car edgelist$

symbolic procedure edge_new_parents edge$
% SELECT EDGE PARENTS FROM NEW_EDGE_LIST$
if p_old_edge edge then nil else
(lambda names$
  edge_new_parent list(car names,cdr names))
 s_edge_prop_ edge$

symbolic procedure edge_new_parent namelist$
if null namelist then nil
else
 (lambda z$
    if z then z . edge_new_parent cdr namelist
    else edge_new_parent cdr namelist)
  assoc(car namelist,new_edge_list) $

symbolic procedure diff_edges (edgelist1,edgelist2)$
if null edgelist1 then nil
else
 if p_member_edge (car edgelist1,edgelist2) then
    diff_edges (cdr edgelist1,edgelist2)
 else  car edgelist1 .
       diff_edges (cdr edgelist1,edgelist2)$

symbolic procedure coeff_ordn1 (satlaslist,passed)$
if null satlaslist then passed
else
%IF NULL CAAR SATLASLIST THEN     %ATLAS HAS NO UNDEFINED
%      COEFF_ORDN1 (CDR SATLASLIST,CAR SATLASLIST . PASSED)
%ELSE
 (lambda z$                    % Z - NIL OR SATLASLIST
   if z then                   % SUBATLAS FINED AND ADDED$
        coeff_ordn1 (z,passed)
   else coeff_ordn1 (cdr satlaslist,car satlaslist . passed) )
  p_subsatlaslist (car satlaslist,cdr satlaslist,nil)$

symbolic procedure p_subsatlaslist (satlas,satlaslist,passed)$
if null satlaslist then nil
else
 if or_subsatlas(satlas,car satlaslist) then
            embed_satlases (satlas,car satlaslist) .
            nconc(passed,cdr satlaslist)
 else p_subsatlaslist (satlas,
                       cdr satlaslist,
                       car satlaslist . passed)$

symbolic procedure or_subsatlas (satlas1,satlas2)$
  p_subsatlas (satlas1,satlas2)
             or
  p_subsatlas (satlas2,satlas1) $

symbolic procedure p_subsatlas (satlas1,satlas2)$
 p_subedgelist (caar satlas1,caar satlas2)
               or
 p_inbothlists (cdar satlas1,caar satlas2) $

symbolic procedure p_inbothlists (edgelist1,edgelist2)$
if null edgelist1 then nil
else p_member_edge (car edgelist1,edgelist2)
                 or
     p_inbothlists (cdr edgelist1,edgelist2)$

symbolic procedure p_subedgelist (edgelist1,edgelist2)$
 if null edgelist1 then t
 else
   p_member_edge (car edgelist1,edgelist2)
              and
   p_subedgelist (cdr edgelist1,edgelist2)$

symbolic procedure embed_satlases (satlas1,satlas2)$
 if p_subsatlas (satlas1,satlas2) then embed_satlas (satlas1,satlas2)
 else
 if p_subsatlas (satlas2,satlas1) then embed_satlas (satlas2,satlas1)
 else set_error_real ('embed_satlases,list(satlas1,satlas2)) $

symbolic procedure embed_satlas (satlas1,satlas2)$
 car satlas2 . embed_atlas (cdr satlas1,cdr satlas2)$

symbolic procedure embed_atlas (atlas1,atlas2)$
%EMBED ATLAS1 INTO ATLAS2
 mk_atlas (s_atlas_map_ atlas2,
            atlas1 . s_atlas_coeff atlas2,
            s_atlas_den_om atlas2)$

symbolic procedure coeff_sortl1 (atlaslist,passed,edgelist)$
if null atlaslist then
 if null passed then nil
 else list coeff_sort_f (passed,nil,edgelist)
else
(lambda z$
 if z then      %ATLAS SORTED
      z . coeff_sortl1 (cdr atlaslist,passed,edgelist)
 else coeff_sortl1 (cdr atlaslist,car atlaslist . passed,edgelist))
 atlas_sort (car atlaslist,edgelist)$

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$


%END$  %cvit82.red
%:*:*:*:*:*:*:*:*:*:*:*:* FACTORIZATION OF MAP_S :*:*:*:*:*:*:*:*:*:$
% 19.05.88 $
lisp$

symbolic procedure renamel_edges edges$
if not equal_edges (car edges,cadr edges) then
  rename_edges (car edges ,cadr edges)$

symbolic procedure map__vertex_first map_$
  mk_vertex1_map_
                  s_vertex_first map_$

symbolic procedure  both_empty_map_s (map_1,map_2)$
 p_empty_map_ map_1
      and
 p_empty_map_ map_2 $

symbolic procedure has_parents edge$
 (lambda z$
           car z neq '!? and
           cdr z neq '!?    )
  s_edge_prop_ edge $

symbolic procedure less_edge (edge1,edge2,edgelist)$
% EDGE1 < EDGE2 IFF EDGE1 WAS CREATED EARLIER$
 less_edge_name (s_edge_name edge1,
                 s_edge_name edge2,
                 edgelist)$

symbolic procedure less_edge_name (name1,name2,edgelist)$
if null edgelist then set_error_real ('less_edge_name ,
                                      list(name1,name2,edgelist))
else
  if name1 eq s_edge_name car edgelist then nil
  else
    if name2 eq s_edge_name car edgelist then t
    else less_edge_name (name1,name2,cdr edgelist)$

symbolic procedure rename_edges (edge1,edge2)$
if p_old_edge edge1 then
 %IF P_OLD_EDGE EDGE2 THEN OLD_EDGE_LIST
  if p_old_edge edge2 then replace_old_edge (edge1,edge2)
  else replace_edge (edge2,edge1,new_edge_list )
else
  if p_old_edge edge2 then replace_edge (edge1,edge2,
                                         new_edge_list )
  else
    if has_parents edge1 then
      if has_parents edge2 then replace_new_edge (edge1,edge2)
      else replace_edge (edge2,edge1,new_edge_list )
    else
      if has_parents edge2 then
           replace_edge (edge1,edge2,new_edge_list )
      else replace_new_edge (edge1,edge2)$

symbolic procedure replace_new_edge (edge1,edge2)$
 replace_o_edge (edge1,edge2,new_edge_list )$

symbolic procedure replace_old_edge (edge1,edge2)$
% 31.08.90 RT
if is_indexp edge1 then
 if is_indexp edge2 then
     replace_o_edge (edge1,edge2,old_edge_list )
 else  replace_edge (edge1,edge2,old_edge_list)
else
  if is_indexp edge2 then
       replace_edge (edge2,edge1,old_edge_list)
  else
      replace_o_edge (edge1,edge2,old_edge_list )$

symbolic procedure replace_o_edge (edge1,edge2,edgelist)$
if less_edge (edge1,edge2,edgelist) then
              replace_edge (edge2,edge1,edgelist)
else          replace_edge (edge1,edge2,edgelist)$

symbolic procedure copy_edge edge$
 car edge . cadr edge . caddr edge . nil $


symbolic procedure replace_edge2 (oldedge,newedge)$
<< rplaca(oldedge,car newedge)$
   rplacd(oldedge,cdr newedge) >> $

symbolic procedure replace_edge (oldedge,newedge,edgelist)$
 replace1_edge (copy_edge oldedge,newedge,edgelist)$

symbolic procedure replace1_edge (oldedge,newedge,edgelist)$
if null edgelist then nil
else
  <<  if equal_edges (oldedge,car edgelist) then
                         replace_edge2 (car edgelist,newedge)$
      replace1_parents (oldedge,newedge,car edgelist)$
      replace1_edge (oldedge,newedge,cdr edgelist) >> $

symbolic procedure replace1_parents (oldedge,newedge,edge)$
 replace2_parents (s_edge_name oldedge,
                   s_edge_name newedge,
                   s_edge_prop_ edge)$

symbolic procedure replace2_parents (oldname,newname,edgeprop_)$
 << if oldname = car edgeprop_ then rplaca(edgeprop_,newname)$
    if oldname = cdr edgeprop_ then rplacd(edgeprop_,newname) >> $

symbolic procedure mk_simple_map_ inmap_$
  mk_simple_map_1 (inmap_,mk_empty_map_ (),nil,nil)$

symbolic procedure both_old edges$
 p_old_edge  car edges
        and
 p_old_edge cadr edges$

symbolic procedure both_vectors edges$   % 31.08.90 RT
 not is_indexp car edges
        and
 not is_indexp cadr edges$

symbolic procedure old_renamel_edv (vertex,edges)$
% RENAMES EDGES IN VERTEX$
 ren_edge (s_edge_name car edges .
           s_edge_name cadr edges,vertex)$

symbolic procedure mk1_simple_map_ map_d$
%MAP_D IS A PAIR (MAP_.DEN_OM)$
mk_simple_map_1 (car map_d,mk_empty_map_ (),list cdr map_d,nil)$

symbolic procedure mk_simple_map_1 (inmap_,outmap_,den_om,coeff)$
if p_empty_map_ inmap_ then <<
 %        FIND_BUBLTR
        outmap_ := mk_parents_map_ outmap_;
        mk_atlas  (outmap_ ,
                   if null coeff then nil
                    else for each map_ in coeff
                             collect mk1_simple_map_ map_,
                   den_om) >>
else
(lambda edges$
 (lambda n$
  if p_vertex_prim s_vertex_first inmap_ then
   if n=2 then                 % VERTEX=(A,B)=DELTA(A,B)  $
    if both_old edges and both_vectors edges then   % 31.08.90
          mk_simple_map_1 (s_map__rest inmap_,
                           add_vertex (s_vertex_first inmap_,outmap_),
                           den_om,
                           coeff)
    else
     << renamel_edges edges$
        if both_empty_map_s (s_map__rest inmap_,outmap_) then
          mk_simple_map_1 (s_map__rest inmap_,
                           add_vertex (s_vertex_first inmap_,outmap_),
                           den_om,
                           coeff)
        else
           mk_simple_map_1 (s_map__rest inmap_,
                            outmap_,
                            den_om,
                            coeff )
     >>
   else
      mk_simple_map_1 ( s_map__rest inmap_,
                        add_vertex ( s_vertex_first inmap_,outmap_),
                        den_om,
                        coeff)
  else
   if n=2  then
    if both_old edges  and both_vectors edges then  %11.09.90 RT
        mk_simple_map_1 (add_vertex (mk_edges_vertex edges,
                                     s_map__rest inmap_),
                          outmap_,
                          den_om,
                          (mk_vertex1_map_ (
                           old_renamel_edv(s_vertex_first inmap_,edges))
                         . old_renamel_edv(mk_edges_vertex edges,edges))
                         . coeff  )
    else
     << renamel_edges edges$
        mk_simple_map_1 (s_map__rest inmap_,
                         outmap_,
                         den_om,
                         (map__vertex_first inmap_ . edges) . coeff)
      >>
   else
   if n=3  and
     ((map__length (inmap_) + map__length (outmap_)) > 2 )
    then
     (lambda v$
     mk_simple_map_1 (add_vertex (v,s_map__rest inmap_),
                      outmap_,
                      den_om,
                      (add_vertex (v,map__vertex_first inmap_) . v)
                        . coeff))
      mk_edges_vertex edges
   else
    if
      (lambda k$
           k > 4 and
           n < k )              %NOT ALL LINES EXTERNAL $
           vertex_length s_vertex_first inmap_
    then
    (lambda firz$
    mk_simple_map_1 (append_map_s (firz,s_map__rest inmap_),
                     outmap_,
                     den_om,
                     coeff) )
     (mk_firz_op s_vertex_first inmap_)        %26.04.88
  else if t then
    mk_simple_map_1 (s_map__rest inmap_,
                     add_vertex (s_vertex_first inmap_,outmap_),
                     den_om,
                     coeff)
    else
    mk_simple_map_1 (append_map_s (mk_simple_vertex
                                   s_vertex_first inmap_,
                                   s_map__rest inmap_),
                      outmap_,
                      den_om,
                      coeff)  )
  length edges)
(ext_edges s_vertex_first inmap_) $


% ?^?^?^?^?^?^?^?^?^?^?^?^? FIERZ OPTIMIZATION ?^?^?^?^?^?^?^?^?^?^?^?$
%       13.05.88$


global '(!*cvitop)$

flag('(cvitop),'switch)$

symbolic procedure mk_firz_op vertex$
if null !*cvitop then mk_firz vertex
else firz_op vertex$

symbolic procedure firz_op vertex$
mk_firz find_cycle (optimal_edge vertex,
                    vertex,
                    mk_empty_vertex ())$

symbolic procedure find_cycle (edge,vertex,passed)$
if equal_edges (edge,first_edge vertex) then
   append_vertex (vertex,reversip_vertex passed)
else find_cycle (edge,
                 s_vertex_rest vertex,
                 add_edge (first_edge vertex,passed))$

symbolic procedure optimal_edge vertex$
optimal1_edge
 internal_edges (vertex,mk_empty_vertex ())$

symbolic procedure internal_edges (vertex1,vertex2)$
if p_empty_vertex vertex1 then vertex2
else
  if p_member_edge (first_edge vertex1,s_vertex_rest vertex1)
            or
     p_member_edge (first_edge vertex1,vertex2)
   then internal_edges (s_vertex_rest vertex1,
                        add_edge (first_edge vertex1,vertex2))
  else  internal_edges (s_vertex_rest vertex1,vertex2)$

symbolic procedure optimal1_edge vertex$
% VERTEX CONTAINS ONLY PAIRED EDGES
(lambda (l,z)$
   opt_edge (z,
             edge_distance (z,vertex,l),
             s_vertex_rest vertex,
             add_edge (z,mk_empty_vertex ()),
             l))
(vertex_length vertex,
 first_edge vertex)$

symbolic procedure edge_distance (edge,vertex,l)$
% L - FULL VERTEX LENGTH
(lambda n$
     min(n,l - n - 2))
 edge_dist (edge,s_vertex_rest vertex)$

symbolic procedure edge_dist (edge,vertex)$
if equal_edges (edge,first_edge vertex) then 0
else add1 edge_dist (edge,s_vertex_rest vertex)$

symbolic procedure opt_edge (edge,distance,vertex,passed,n)$
% N - FULL VERTEX LENGTH
if distance = 0 or p_empty_vertex vertex then edge
else
(lambda firstedge$
   if p_member_edge (firstedge,passed) then
              opt_edge (edge,
                        distance,
                        s_vertex_rest vertex,
                        passed,
                        n)
   else
 (lambda dist$
    if dist < distance then
              opt_edge (firstedge,
                        dist,
                        s_vertex_rest vertex,
                        add_edge (firstedge,passed),
                        n)
     else     opt_edge (edge,
                        distance,
                        s_vertex_rest vertex,
                        add_edge (firstedge,passed),
                        n))
  edge_distance (firstedge,vertex,n))
first_edge vertex $



% END OF OPTIMIZATION PART  $

symbolic procedure mk_firz vertex$
% VERTEX=(A1,...,AM,Z,B1,...,BN,Z,C1,...,CK)
% RETURNS UNION MAP_ WHERE
% MAP_ =MAP_1 & MAP_2  WHERE
% MAP_1=((B1,...,BN,X)(Y,C1,...,CK,A1,...,AM)),
% MAP_2=((Z,X,Z,Y)) $
   mk_firz1 (vertex,mk_empty_vertex ())$

symbolic procedure mk_firz1 (vertex1,vertex2)$
if p_empty_vertex vertex1 then reversip_vertex vertex2
else
  (lambda z$
      if z then                   %FIRST EDGE CONTAINS TWICE$
         mk_firz2 (first_edge vertex1,
                   car z,
                   append_vertex (cdr z,reversip_vertex vertex2))
      else
         mk_firz1 (s_vertex_rest vertex1,
                   add_edge (first_edge vertex1,vertex2) ) )
   mp_member_edge (first_edge vertex1,
                     s_vertex_rest vertex1)$

symbolic procedure mk_firz2 (edge,vertex1,vertex2)$
%RETURNS MAP_ =MAP_1 & MAP_2 ,
%VERTEX1=(B1,...,BN),
%VERTEX2=(C1,...,CK,A1,...,AM)  $
(lambda (nedge,nedg1)$
 append_map_s (
  mk_coeff2 (edge,nedge,nedg1),
  mk_vertex2_map_ (conc_vertex (vertex1,mk_edge1_vertex nedge),
                   add_edge (nedg1,vertex2))
               ))
(mk_nedge (),
 mk_nedge ()) $

symbolic procedure mk_coeff2 (edge,nedge,nedg1)$
 mk_vertex1_map_ mk_edge4_vertex (edge,nedge,edge,nedg1)$

symbolic procedure mk_nedge $
(lambda edge$
   new_edge (edge,edge))
 mk_edge ('!?,'!? . '!?,nil) $

symbolic procedure mp_member_edge (edge,vertex)$
% RETURNS NIL OR PAIR.
% IF VERTEX=(A1,...,AM,EDGE,...,B1,...,BN) THEN
% PAIR= (A1,...,AM) . (B1,...,BM) $
  mp_member1_edge (edge,vertex,mk_empty_vertex ())$

symbolic procedure mp_member1_edge (edge,vertex,tail)$
if p_empty_vertex vertex then nil
else
 if
  equal_edges (edge,first_edge vertex) then
           reversip_vertex tail .
           s_vertex_rest vertex
 else mp_member1_edge (edge,
                       s_vertex_rest vertex,
                       add_edge (first_edge vertex,tail) ) $


%END$  %cvit10.red
% ()()()()()()()()()()()()()() PRINTING ATLAS AND MAP_ ROUTINES ()()().
lisp$             %30.01.87$

fluid '(ntab!*)$

symbolic procedure print_atlas atlas$
begin
  scalar ntab!*$
  ntab!*:=0$
  prin2_atlas atlas$
end$

symbolic procedure prin2_atlas atlas$
if null atlas then nil
else
    << print_map_ s_atlas_map_ atlas$
       print_den_om s_atlas_den_om atlas$
       print_coeff s_atlas_coeff atlas
     >> $

symbolic procedure print_map_ map_$
 << pttab ntab!*$
    prin2 "Map_ is: ("$
    prin2_map_ map_$
    prin2 " )"$
    terpri()  >> $

symbolic procedure prin2_map_ map_$
if p_empty_map_ map_ then nil
else
    << print_vertex s_vertex_first map_$
       prin2_map_ s_map__rest map_ >> $

symbolic procedure print_vertex vertex$
 <<
    prin2 "( "$
    prin2_vertex vertex$
    prin2 ")"      >> $

symbolic procedure prin2_vertex vertex$
if p_empty_vertex vertex then nil
else
    << print_edge first_edge vertex$
       prin2_vertex s_vertex_rest vertex >> $

symbolic procedure print_edge edge$
 << prin2_edge edge$
    prin2 " "    >> $

symbolic procedure prin2_edge edge$
 prin2 s_edge_name edge $

symbolic procedure pttab n$
  << spaces n $   % TTAB N$         % 07.06.90
     prin2 n$
     prin2 ":" >> $

symbolic procedure print_coeff coeff$
 << ntab!*:=ntab!*+1$
    prin2_coeff coeff$
    ntab!*:=ntab!*-1    >> $

symbolic procedure prin2_coeff atlases$
if null atlases then nil
else << prin2_atlas car atlases$
        prin2_coeff cdr atlases >> $

symbolic procedure print_den_om den_list$
 << pttab ntab!*$
    prin2 "DEN_OM is: "$
    if null den_list then prin2 nil
    else prin2_map_ den_list $
    terpri() >> $

unfluid '(ntab!*)$

symbolic procedure print_old_edges ()$
   print_edge_list old_edge_list $

symbolic procedure print_new_edges ()$
   print_edge_list new_edge_list $

symbolic procedure print_edge_list edgelist$
if null edgelist then nil
else << print car edgelist$
        print_edge_list cdr edgelist >> $


%END$  %cvit12.red
%---------------------- MAKES PARENTS AFTER FIERZING ----------------$

          %24.05.88$
 lisp$


symbolic procedure mk_simpl_map_ map_$
  mk_simpl_map_1 (map_,mk_empty_map_ ())$

symbolic procedure mk_simpl_map_1 (inmap_,outmap_)$
if p_empty_map_ inmap_ then resto_map__order outmap_
else
  if p_vertex_prim s_vertex_first inmap_ then
      mk_simpl_map_1 ( s_map__rest inmap_,
                       add_vertex(mk_parents_prim s_vertex_first inmap_,
                                   outmap_))
  else
    mk_simpl_map_1 (append_map_s(mk_simple_vertex s_vertex_first inmap_,
                                  s_map__rest inmap_),
                    outmap_)$

symbolic procedure mk_simple_vertex vertex$
 % VERTEX => MAP_ $
begin
 scalar nedge,fedge,sedge$
 fedge:=first_edge vertex$
 sedge:=second_edge vertex$
 if not has_parents fedge or not has_parents sedge then
    return mk_simple_vertex cycl_vertex vertex$
 nedge:=new_edge (fedge,sedge)$
 vertex:=s_vertex_rest
         s_vertex_rest vertex$
 return
     mk_vertex2_map_ ( mk_edge3_vertex (nedge,fedge,sedge),
                       add_edge (nedge,vertex))
end$

symbolic procedure mk_parents_map_ map_$
%MAKES PARENTS FOR ALL EDGES IN MAP_.
%THIS CAN BE DONE BECAUSE NEW EDGES NEVER CREATE CYCLES$
 standard_map_
 mk_simpl_map_
 mk_parents1_map_ (map_,mk_empty_map_ (),mk_empty_map_ ())$

symbolic procedure standard_map_ map_$
if p_empty_map_ map_ then mk_empty_map_ ()
else
 if vertex_length s_vertex_first map_ > 2 then
    add_vertex (s_vertex_first map_,
                standard_map_ s_map__rest map_)
 else standard_map_ add_vertex (add_0_edge s_vertex_first map_,
                                s_map__rest map_)$

symbolic procedure add_0_edge vertex$
%ADDS SPECIAL VERTEX$
add_edge (!_0edge ,vertex)$

symbolic procedure mk_parents1_map_ (inmap_,outmap_,passed)$
if p_empty_map_ inmap_ then
 if p_empty_map_ passed then outmap_     %ALL EDGES HAVE PARENTS$
 else mk_parents1_map_ (passed,outmap_,mk_empty_map_ ())
else
 (lambda edges$
   if null edges then        %IN FIRST VERTEX ALL EDGES HAVE PARENTS$
      mk_parents1_map_ (s_map__rest inmap_,
                        add_vertex (s_vertex_first inmap_,outmap_),
                        passed)
   else
    if single_no_parents edges then   %ONLY ONE EDGE IN THE VERTEX$
                                        %HAS NO PARENTS$
       mk_parents1_map_ (s_map__rest inmap_,
                         append_map_s (mk_parents_vertex
                                          s_vertex_first inmap_,
                                       outmap_),
                         passed)
    else
       mk_parents1_map_ (s_map__rest inmap_,
                         outmap_,
                         add_vertex (s_vertex_first inmap_,passed)))
  s_noparents s_vertex_first inmap_ $

symbolic procedure s_noparents vertex$
%SELECTS EDGES WITHOUT PARENTS IN VERTEX$
if p_empty_vertex vertex then nil
else
 if has_parents first_edge vertex then
         s_noparents s_vertex_rest vertex
 else
     first_edge vertex .
     s_noparents s_vertex_rest vertex$

symbolic procedure mk_parents_vertex vertex$
%MAKES PARENTS FOR THE SINGLE EDGE WITHOUT PARENTS IN VERTEX,
% (VERTEX HAS ONLY ONE EDGE WITHOUT PARENTS ^)       $
 mk_simpl_map_ mk_vertex1_map_ vertex$

symbolic procedure mk_parents_prim pvertex$
% CREATES PARENTS FOR THE ONLY EDGE WITHOUT PARENTS IN PRIMITIVE
% (THREE EDGES) VERTEX $
if vertex_length pvertex neq 3 then pvertex
else
  (lambda edges$
     if null edges then pvertex
     else
        << mk_edge_parents (pvertex,car edges)$
           pvertex >> )
   s_noparents pvertex$

symbolic procedure mk_edge_parents (vertex,edge)$
 mk_edge1_parents (delete_edge (edge,vertex),edge)$

symbolic procedure mk_edge1_parents (vertex2,edge)$
 add_parents (edge,
              mk_edge_prop_ (
                             s_edge_name first_edge vertex2,
                             s_edge_name second_edge vertex2))$

symbolic procedure add_parents (edge,names)$
  add_parents0(edge,names,nil)$

symbolic procedure add_parents0 (edge,names,bool)$
 addl_parents (new_edge_list,edge,names . list bool)$

symbolic procedure addl_parents (edgelist,edge,names)$
% NAMES IS A PAIR NAME1 . NAME2 $
if null edgelist then nil
else
(if equal_edges (car edgelist,edge) then
    rep_parents (car edgelist,names)
 else car edgelist) .
                      addl_parents (cdr edgelist,edge,names) $

symbolic procedure rep_parents (edge,names)$
 << rplacd(edge,names)$
    edge >> $

%END$  %cvit14.red
%EEEEEEEEEEEEEEEEEEEEEEEEE SELECT ALL EDGES %%%%%%%%%%%%%%%%%%%%%%%%% $

                       % 07.06.88$

lisp$

symbolic procedure atlas_edges atlas$
union_edges (
 union_edges (map__edges s_atlas_map_ atlas,
              den__edges s_atlas_den_om atlas),
 coeff_edges s_atlas_coeff atlas)$

symbolic procedure den__edges den_om$
 map__edges den_om$

symbolic procedure coeff_edges atlaslist$
 if null atlaslist then nil
 else union_edges (atlas_edges car atlaslist,
                   coeff_edges cdr atlaslist) $

symbolic procedure map__edges map_$
 if p_empty_map_ map_ then nil
 else union_edges (vertex_edges s_vertex_first map_,
                   map__edges s_map__rest map_)$

symbolic procedure union_edges (newlist,oldlist)$
if null newlist then oldlist
else union_edges (cdr newlist,
                  union_edge (car newlist,oldlist))$

symbolic procedure union_edge (edge,edgelist)$
 if memq_edgelist (edge,edgelist) then edgelist
 else edge . edgelist$

symbolic procedure memq_edgelist (edge,edgelist)$
 assoc(s_edge_name edge,
       edgelist)$

symbolic procedure exclude_edges (edgelist,exclude)$
% EXCLUDE IS A LIST OF EDGES TO BE EXCLUDED FROM EDGELIST$
 if null edgelist then nil
 else
   if memq_edgelist (car edgelist,exclude) then
           exclude_edges (cdr edgelist,exclude)
   else car edgelist .
           exclude_edges (cdr edgelist,exclude)  $


symbolic procedure constr_worlds (atlas,edgelist)$
(lambda edges$
   actual_edges_world (
      mk_world1 (actual_edges_map_ (edges,
                                    edgelist,
                                    s_atlas_map_ atlas),
                  constr_coeff (s_atlas_coeff atlas,
                                union_edges (edges,edgelist)),
                  s_atlas_den_om atlas
                  )
               ) )
union_edges(
  den__edges s_atlas_den_om atlas,
  map__edges s_atlas_map_ atlas)$

symbolic procedure constr_coeff (atlases,edgelist)$
 if null atlases then nil
 else
      constr_worlds (car atlases,edgelist) .
      constr_coeff (cdr atlases,edgelist)$

symbolic procedure actual_edges_map_ (edges,edgelist,map_)$
 actedge_map_ (edges,edgelist,list_of_parents(edges,edgelist),nil)
%ACTEDGE_MAP_ (EDGES,EDGELIST,NIL,NIL)
  . map_$

symbolic procedure list_of_parents (edges,edgelist)$
if null edges then nil
else append(list_of_parent (car edges,edgelist),
            list_of_parents (cdr edges,edgelist))$

symbolic procedure list_of_parent (edge,edgelist)$
if p_old_edge edge or memq_edgelist (edge,edgelist) then nil
               %IF EDGE IS DEF. THEN NO NEED IN ITS PARENTS
else
begin$
 scalar pr1,pr2,p,s$
 p:=s_edge_prop_ edge$
 pr1:=assoc(car p,edgelist)$
 if pr1 then s:=pr1 . s$
 pr2:=assoc(cdr p,edgelist)$
 if pr2 then s:=pr2 . s$
%IF NULL PR1 OR NULL PR2 THEN
% SET_ERROR (LIST_OF_PARENTS ,EDGE,EDGELIST)$
 return  s
end$

symbolic procedure actedge_map_ (edges,edgelist,old,new)$
if null edges then old . new
else
  if memq_edgelist (car edges,edgelist) then
       actedge_map_ (cdr edges,edgelist,car edges . old,new)
  else actedge_map_ (cdr edges,edgelist,old,car edges . new) $

symbolic procedure actual_edges_world world1$
 mk_world (actual_world (s_actual_world1 world1,
                         s_actual_coeff s_coeff_world1 world1),
            world1)$

symbolic procedure mk_world1 (edges!-map_,coeff,den_om)$
 mk_atlas (map_2_from_map_1 edges!-map_,coeff,den_om)$

symbolic procedure map_2_from_map_1 map_1$
 list(map_1_to_strand1 map_1,
      list nil,
      mark_edges (cdar map_1,
                % UNION_EDGES(OLD_EDGE_LIST,CAAR MAP_1),
                  caar map_1,
                  cdr map_1))$

symbolic procedure map_1_to_strand1 map_1$
car map_1 .
pre!-calc!-map_ (cdr map_1,
                 names_edgepair map__edges cdr map_1)$

symbolic procedure names_edgepair edgepair$
%NCONC(FOR EACH EDGE IN CAR EDGEPAIR COLLECT S_EDGE_NAME EDGE,
%      FOR EACH EDGE IN CDR EDGEPAIR COLLECT S_EDGE_NAME EDGE)$
       for each edge in edgepair collect s_edge_name edge $

symbolic procedure s_actual_world1 world1$
%RETURNS PAIR: OLDEDGES . NEWEDGES $
caar s_atlas_map_ world1$

symbolic procedure actual_world (map_edges,coeffedges)$
%MAP_EDGES IS A PAIR OLD . NEW,
%COEFFEDGES IS LIST OF ACTUAL EDGES OF COEEF.$
 union_edges (car map_edges,
              exclude_edges (coeffedges,cdr map_edges)) $

symbolic procedure s_actual_coeff worldlist$
if null worldlist then nil
else union_edges (s_edgelist_world car worldlist,
                  s_actual_coeff cdr worldlist) $

symbolic procedure world_from_atlas atlas$
%TOP LEVEL PROCEDURE$
 constr_worlds (atlas,old_edge_list )$


%END$  %cvit16.red
%^^^^^^^^^^^^^^^^^^^^^^^^^^ CALCULATION OF WORLDS ^^^^^^^^^^^^^^^^^^^ $
           %26.03.88$
lisp$

symbolic procedure s_world_names world$
for each edge in s_world_edges world
  collect s_edge_name edge$

symbolic procedure calc_world (world,alst)$
% ALST LIST OF VALUES OF EXTERNAL EDGES: (... (EDGNAME . NUMBER) ...)$
begin
  scalar s,v$
  alst:=actual_alst (alst,                   %SELECT ONLY THOSE
                     s_world_names world)$    %EDGES WICH ARE IN WORLD
  v:=s_world_var world $                      %SELECT DATA BASE
  s:=assoc(alst,cdr v)$                       %CALC. PREVIOSLY?
  if s then return cdr s$                     %PREV. RESULT$
  s:=reval
     calc_atlas (s_world_atlas world,alst)$   %REAL CALCULATION
  nconc (v,list(alst . s))$                   %MODIFY DATA BASE
  return s
end$

symbolic procedure actual_alst (alst,namelist)$
if null alst then nil
else
  if memq(caar alst,namelist) then
     car alst . actual_alst (cdr alst,namelist)
  else actual_alst (cdr alst,namelist)$

symbolic procedure calc_atlas (atlas,alst)$
        calc_map_2d (s_atlas_map_ atlas,
                     s_atlas_den_om atlas,
                     s_atlas_coeff atlas,
                     alst) $

symbolic procedure calc_coeff (worldlist,alst)$
if null worldlist then list 1
else
 (lambda x$
      if x=0 then list 0
      else x . calc_coeff (cdr worldlist,alst))
  calc_world (car worldlist,alst)$

symbolic procedure calc_map_2d (map_2,den_om,coeff,alst)$
coeff_calc (mk_names_map_2 caar map_2 .
                          cdar map_2 .
                          cadr map_2 .
                          den_om     ,
            coeff,
            mk_binding (caddr map_2,alst)) $

symbolic procedure mk_names_map_2 edgespair$
% EDGESPAIR IS PAIR OF LISTS OF EDGES
%   EDGELISTOLD . EDGELISTNEW         $
for each edge in append(car edgespair,cdr edgespair)
    collect s_edge_name edge$

symbolic procedure calc_coeffmap_ (s,coeff,alst)$
(lambda z$
    if z = 0 then 0
    else 'times . (z . calc_coeff (coeff,alst)))
 calc_map_ (s,alst)$

symbolic procedure calc_map_ (mvd,alst)$
begin
  scalar map_,v,names,s,den_om,al,d$
  names:=car mvd$                               %NAMES OF ALL EDGES
  map_:=cadr mvd$                               %SELECT MAP_
  v:=caddr mvd$                                 %SELECT DATA BASE
  den_om:=cdddr mvd$                            %SELECT DEN_OMINATOR
  al:=actual_alst (alst,names)$                 %ACTUAL ALIST
  if null al and names then return 0$           %NO VARIANTS OF
                                                %COLOURING
  s:=assoc(al,cdr v)$                           %PREV.CALCULATED?
  if s then  s:=cdr s                           %YES, TAKE IT
  else <<                                       %ELSE
       s:=reval calc_map_tar (map_,al)$         %REAL CALCULATION
       nconc(v,list(al . s))                    %MODIFY DATA BASE
       >>  $
  d:=calc_den_tar (den_om,alst)$                %CALC. DEN_OMINATOR
  return
        if d = 1 then s
        else list('quotient,s,d)                % 09.06.90 RT
end$

%SYMBOLIC PROCEDURE CALC_MAP_TAR (MAP_,BINDING)$
%1$

%SYMBOLIC PROCEDURE CALC_DEN_TAR (DEN_OMINATOR,BINDING)$
%1$

symbolic procedure coeff_calc (s,coeff,binding)$
%S IS EDGENAMES . MAP_ . DATABASE . DEN_OMINATOR $
 reval
     ('plus . coeff1_calc (s,coeff,binding))$

symbolic procedure coeff1_calc (s,coeff,binding)$
if null binding then list 0
else calc_coeffmap_ (s,coeff,car binding) .
     coeff1_calc (s,coeff,cdr binding) $

%TOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOP$

symbolic procedure calc_spur0 u$
begin
 scalar s$
 if null u then return u$
 s:=transform_map_ u$
 old_edge_list := !_0edge . old_edge_list $
 s:=find_bubltr s$
 return
        calc_world (world_from_atlas s,
                     for each edge in old_edge_list
                         collect s_edge_name edge .
                                 car s_edge_prop_ edge )
end$

symbolic procedure calc_spur u$
 simp!* calc_spur0 u$                %FOR KRYUKOV NEEDS$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/cvit.tst0000644000175000017500000000655311526203062023516 0ustar  giovannigiovanni% Tests of Cvitanovic Package.


% COPYRIGHT (C) 1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE UNIV.
% CVITBUBLE  TEST OF CVITANOVIC PACKAGE
% AUTHOR     A. KRYUKOV, ARODIONOV, A.TARANOV
% VERSION    1.1
% RELEASE    18-SEP-90

index j1,j2,j3,j4,j5,j6,j7,j8,j9,j0;
vecdim n$

%       Tests of the weels with buble
%       (Use notation from SIGSAM Bull, 1989, v.23, no.4, pp.15-24)

g(l,j1,j2,j2,j1);

g(l,j1,j2)*g(l1,j3,j1,j2,j3);
g(l,j1,j2)*g(l1,j3,j1,j3,j2);
g(l,j1,j2)*g(l1,j3,j3,j2,j1);

g(l,j1,j2,j3,j4)*g(l1,j1,j2,j3,j4);
g(l,j1,j2)*g(l1,j3,j4,j1,j2,j4,j3);
g(l,j1,j2,j3,j4)*g(l1,j1,j4,j2,j3);
g(l,j1,j2)*g(l1,j3,j4,j1,j4,j3,j2);

g(l,j1,j2)*g(l1,j3,j4,j5,j1,j2,j3,j4,j5);
g(l,j1,j2,j3,j4)*g(l1,j5,j1,j2,j3,j5,j4);
g(l,j1,j2,j3,j4,j5,j1)*g(l1,j2,j5,j3,j4);
g(l,j1,j2,j3,j4,j5,j1,j2,j5)*g(l1,j4,j3);

g(l,j1,j2)*g(l1,j3,j4,j5,j6,j1,j2,j3,j4,j5,j6);
g(l,j1,j2,j3,j4)*g(l1,j5,j6,j1,j2,j3,j4,j6,j5);
g(l,j1,j2,j3,j4,j5,j6)*g(l1,j1,j2,j4,j3,j6,j5);
g(l,j1,j2,j3,j4,j5,j6,j1,j2)*g(l1,j6,j3,j4,j5);
g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5)*g(l1,j6,j7);
g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3)*g(l1,j4,j5,j7,j6);
g(l,j1,j2,j3,j4,j5,j6,j7,j2)*g(l1,j1,j3,j4,j5,j6,j7);


% COPYRIGHT (C) 1988,1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE U.
% CVITEST   Test of CVITANOVIC PACKAGE
% AUTHOR    A. KRYUKOV, A.RODIONOV, A.TARANOV
% VERSION   1.2
% RELEASE   11-MAR-90

%
%     Test for trace of Dirac matrices.
%
%     All tests are the lattices with difference lines
%     (Use notation from SIGSAM Bull, 1989, v.4,no.23, pp.15-24)

index m1,m2,m3,m4,m5,m6,m7,m8,m9,m0;
index n1,n2,n3,n4,n5,n6,n7,n8,n9,n0;

vecdim n;

 g(l,n1,n1);
 g(l,n1,m1,n1,m1);

 g(l,n1,n2,n2,n1);
 g(l,n1,n2,m1,n2,n1,m1);
 g(l,n1,n2,m1,m2,n2,n1,m2,m1);

 g(l,n1,n2,n3,n3,n2,n1);
 g(l,n1,n2,n3,m1,n3,n2,n1,m1);
 g(l,n1,n2,n3,m1,m2,n3,n2,n1,m2,m1);
 g(l,n1,n2,n3,m1,m2,m3,n3,n2,n1,m3,m2,m1);
 g(l,n1,n2,n3,m1,n3,n1,n2,m1);
 g(l,n1,n2,n3,m1,m2,n3,n1,n2,m1,m2);
 g(l,n1,n2,n3,m1,m2,m3,n2,n3,n1,m3,m1,m2);


% COPYRIGHT (C) 1988,1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE U.
% CVITWEEL  TEST OF CVITANOVIC PACKAGE
% AUTHOR    A. KRYUKOV, ARODIONOV, A.TARANOV
% VERSION   1.2
% RELEASE   11-MAR-90

index j1,j2,j3,j4,j5,j6,j7,j8,j9,j0;
vecdim n$

%       Test of CVITANOVIC PACKAGE
%
%       All tests are the weels with defferent spoke
%       (Use notation from SIGSAM Bull, 1989, v.23, no.4, pp.15-24)

g(l,j1,j2,j2,j1);

g(l,j1,j2,j3,j1,j2,j3);
g(l,j1,j2,j3,j1,j3,j2);
g(l,j1,j2,j3,j3,j2,j1);

g(l,j1,j2,j3,j4,j1,j2,j3,j4);
g(l,j1,j2,j3,j4,j1,j2,j4,j3);
g(l,j1,j2,j3,j4,j1,j4,j2,j3);
g(l,j1,j2,j3,j4,j1,j4,j3,j2);

g(l,j1,j2,j3,j4,j5,j1,j2,j3,j4,j5);
g(l,j1,j2,j3,j4,j5,j1,j2,j3,j5,j4);
g(l,j1,j2,j3,j4,j5,j1,j2,j5,j3,j4);
g(l,j1,j2,j3,j4,j5,j1,j2,j5,j4,j3);

g(l,j1,j2,j3,j4,j5,j6,j1,j2,j3,j4,j5,j6);
g(l,j1,j2,j3,j4,j5,j6,j1,j2,j3,j4,j6,j5);
g(l,j1,j2,j3,j4,j5,j6,j1,j2,j4,j3,j6,j5);
g(l,j1,j2,j3,j4,j5,j6,j1,j2,j6,j3,j4,j5);
g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5,j6,j7);
g(l,j1,j2,j3,j4,j5,j6,j7,j1,j2,j3,j4,j5,j7,j6);
g(l,j1,j2,j3,j4,j5,j6,j7,j2,j1,j3,j4,j5,j6,j7);

%  Test of example that calculated incorrectly in earlier package.

index ix,iy,iz;
mass p1=mm, p2=mm, p3=mm, p4=mm, k1=0; 
mshell p1,p2,p3,p4,k1;
vector q1,q2; 
operator ga,gb;
for all p let ga(p)=g(la,p) + mm,
              gb(p)=g(lb,p) + mm;
xx := g(la,ix)*g(la,iy)*(g(lb,ix)*gb(p1)*g(lb,iy)*gb(q2) +
                      gb(p3)*g(lb,ix)*g(lb,iy));
let q1=p1-k1, q2=p3+k1;

xx;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/red2cvit.red0000644000175000017500000002516511526203062024233 0ustar  giovannigiovannimodule red2cvit;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% COPYRIGHT (C) 1988,1990,INSTITUTE OF NUCLEAR PHYSICS,MOSCOW STATE
%                          UNIV.
% PURPOSE   INTERFACE BETWEEN REDUCE AND CVITANOVICH ALGORITHM.
% AUTHOR    A.KRYUKOV
% VERSION   2.1
% RELEASE   11-MAR-90

  exports isimp1,replace_by_vector,replace_by_vectorp,gamma5p$
  imports calc_spur,isimp2$

  switch cvit$               % CVITANOVICH ALGORITHM SWITCH
  !*cvit := t$               % DEFAULT ON

  %************ ISIMP1 REDEFINITION ************************

  remflag('(isimp1),'lose)$

  symbolic procedure isimp1(u,i,v,w,x)$
     if null u then nil
      else if domainp u
         then if x then multd(u,if !*cvit
                                  then calc_spurx (i,v,w,x)
                                  else spur0 (car x,i,v,w,cdr x)
                             )
               else if v then multd(u,index_simp (1,i,v,w))
               else if w then multfs(emult w,isimp1(u,i,v,nil,nil))
               else u
      else addfs(isimp2(car u,i,v,w,x),isimp1(cdr u,i,v,w,x))$

  flag('(isimp1),'lose)$

  %************* INDEX_SIMP *******************************

  symbolic procedure index_simp (u,i,v,w)$
     if v then index_simp (multf(mksprod(caar v,cdar v),u),
                           update_index (i,car v),cdr v,w)
       else isimp1(u,i,nil,w,nil)$

  symbolic procedure mksprod(x,y)$
     mkdot(if indexp x then replace_by_vector x else x,
           if indexp y then replace_by_vector y else y)$

  symbolic procedure update_index (i,v)$
     % I  - LIST OF UNMATCH INDICES
     % V  - PAIR: (I/V . I/V)
     % VALUE - UPDATE LIST OF INDICES
     delete(cdr v,delete(car v,i))$

  %************ CALC_SPURX - MAIN PROCEDURE ***************

  symbolic procedure calc_spurx (i,v,w,x)$
     % I - LIST OF INDICES
     % V - LIST OF SCALAR PRODUCT:( . )
     % W - EPS-EXPR
     % X - LIST OF SPURS
     % VALUE - CALCULATED SPUR(S.F.)
     begin scalar u,         % SPUR: (LNAME G5SWITCH I/V I/V ... )
                  x1,        % (UN ... U1)
                  dindices!*,% A-LIST OF DUMMY INDICES: (I . NIL/T)
                  c$          % COEFFICIENT GENERATIED BY GX*GX
           if numberp ndims!* and null evenp ndims!*
             then cviterr list('calc_spur,":",ndims!*,
                     "is not even dimension of G-matrix space")$
           c := 1$            % INITIAL VALUE
           while x
             do << if nospurp caar x
                     then cviterr list "Nospur not yet implemented"$
                   u := cdar x$
                   x := cdr x$
                   if car u
                     then if evenp ndims!*
                            then u := next_gamma5() . reverse cdr u
                            else cviterr
                                   {"G5 invalid for non even dimension"}
                     else u := reverse cdr u$
                   if null u then nil                 % SP()
                     else if null evenp
                        length(if gamma5p car u and cdr u then cdr u
                                else u)
                            then x := c := nil        % ODD - VALUE=0
                     else << u := remove_gx!*gx u$
                             c := multf(car u,c)$
                             u := replace_vector(cdr u,i,v,w)$
                             i := cadr u$
                             v := caddr u$
                             w := cadddr u$
                             if u then x1 := car u . x1
                          >>
                >>$
           x1 := if null c then nil ./ 1         % ZERO
                   else if x1 then multsq(c ./ 1,calc_spur x1)
                   else c ./ 1$
           if denr x1 neq 1 then cviterr list('calc_spurx,":",x1,
                                    "has non unit denominator")$
           clear_windices ()$
           clear_gamma5 ()$
           return isimp1(numr x1,i,v,w,nil)
     end$

  symbolic procedure third_eq_indexp i$
     begin scalar z$
           if null(z := assoc(i,dindices!*))
             then dindices!* := (i . nil) . dindices!*
             else if null cdr z
                    then dindices!* := (i . t) . delete(z,dindices!*)$
           return if z then cdr z else nil
     end$

  symbolic procedure replace_vector(u,i,v,w)$
     % U  - SPUR (INVERSE)
     % I  - LIST OF UNMATCH INDICES
     % V  - A-LIST OF SCALAR PRODUCT
     % W  - EPS-EXPRESION
     % VALUE - LIST(U,UPDATE I,UPDATE V,UPDATE W)
     begin scalar z,y,x,    % WORK VARIABLES
                  u1$        % SPUR WITHOUT VECTOR
           while u
             do << z := car u$
                   u := cdr u$
                   if indexp z
                     then << % REMOVE DUMMY INDICES
                             while (y := bassoc(z,v))
                               do << i := delete(z,i)$
                                     v := delete(y,v)$
%                                    W := ....
                                     x := if z eq car y then cdr y
                                            else car y$
                                     if indexp x then z := x
                                       else if gamma5p x
                                         then cviterr
                                            list "G5 bad structure"
                                       else replace_by_index (x,z)
                                  >>$
                             u1 := z . u1
                          >>
                     else if gamma5p z then u1 := z . u1
                     else << z := replace_by_index (z,next_windex())$
                             u1 := z . u1
                          >>
                >>$
           return list(reverse u1,i,v,w)
     end$

  symbolic procedure replace_by_index (v,y)$
     begin scalar z$
           if (z := replace_by_vectorp y) eq v
             then cviterr list('replace_by_index,":",y,
                              "is already defined for vector",z)$
           put(y,'replace_by_vector ,v)$
           return y
     end$

  symbolic procedure remove_gx!*gx u$
     begin scalar x,c$
           integer l,l1$
           c := 1$
           l1 := l := length u$
           u := for each z in u                  % MAKE COPY
                  collect << if indexp z then
                               if third_eq_indexp z
                                 then cviterr
                                       list("Three indices have name",z)
                                 else nil
                               else if null hvectorp z then
                                      if cvitdeclp(z,'vector)
                                         then vector1 list z
                                         else cviterr nil
                               else nil$
                             z
                          >>$
           if l < 2 then return u$
           x := u$
           while cdr x do x := cdr x$
           rplacd(x,u)$                          % MAKE CYCLE
           while l1 > 0
             do if car u eq cadr u               % EQUAL ?
                  then << c := multf(if indexp car u then ndims!*
                                       else mkdot(car u,car u)
                                    ,c)$
                          rplaca(u,caddr u)$    % YES - DELETE
                          rplacd(u,cdddr u)$
                          l1 := l := l - 2
                       >>
                  else << u := cdr u$            % NO - CHECK NEXT PAIR
                          l1 := l1 - 1
                       >>$
           x := cdr u$
           rplacd(u,nil)$                        % CUT CYCLE
           return (c . if cdr x and car x eq cadr x then nil else x)
     end$

  %************* ERROR,MESSAGE *****************************

  symbolic procedure cviterr u$
     << clear_windices()$
        clear_gamma5()$
        if u then rederr u else error(0,nil) >>$

  symbolic procedure cvitdeclp(u,v)$
     if null !*msg then nil
       else if terminalp()
              then yesp list("Declare",u,v,"?")
       else << lprim list(u,"Declare",v)$ t >>$

  %*********** WORK INDICES & VECTOR ***********************

  symbolic procedure clear_windices ()$
     while car windices!*
       do begin scalar z$
             z := caar windices!*$
             windices!* := cdar windices!* . z . cdr windices!*$
             remprop(z,'replace_by_vector)$
             indices!* := delete(z,indices!*)$
          end$

  symbolic procedure next_windex()$
     begin scalar i$
           windices!* := if null cdr windices!*
                           then (intern gensym() . car windices!*) .
                                cdr windices!*
                           else (cadr windices!* . car windices!*) .
                                cddr windices!*$
           i := caar windices!*$
           vector1 list i$
           indices!* := i . indices!*$
           return i
     end$

  symbolic procedure next_gamma5()$
     begin scalar v$
           cviterr list "GAMMA5 is not yet implemented. use OFF CVIT";
           gamma5!* := if null cdr gamma5!*
                           then (intern gensym() . car gamma5!*) .
                                cdr gamma5!*
                           else (cadr gamma5!* . car gamma5!*) .
                                cddr gamma5!*$
           v := list caar gamma5!*$
           vector1 v$
           return car v
     end$

  %************ END ****************************************

%prin2t "_Cvitanovich_algorithm_is_ready"$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/hephys/physop.red0000644000175000017500000026076511526203062024042 0ustar  giovannigiovannimodule physop;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                  %
%                      P H Y S O P                                 %
%                                                                  %
%           A Package for Operator Calculus                        %
%                      in Physics                                  %
%                                                                  %
%  Author:            Mathias Warns                                %
%                   Physics Institute                              %
%                   University of Bonn                             %
%                     Nussallee 12                                 %
%                 D-5300 BONN 1 (F.R.G.)                           %
%                                          %
%                                                                  %
%  Version:           1.5  06 Jan 1992                             %
%                                                                  %
% Designed for: REDUCE version 3.4                                 %
% Tested on   : - Intel 386/486  AT compatible computers           %
%                  PSL implementation of REDUCE 3.4                %
%               - IBM 3084/9000-620 MVS/XA                         %
%                  PSL implementation of REDUCE 3.4                %
%                                                                  %
% CAUTION: (i)  The NONCOM2 package is needed to run this package  %
%          (ii) This package cannot be used simultaneously with    %
%               packages modifying the standard GETRTYPE procedure %
%                                                                  %
%             Copyright (c) Mathias Warns 1990 - 1992              %
%                                                                  %
% This file has been re-released under the BSD license by          %
% A C Hearn under powers granted to him by the original author     %
% when this package was contributed for use in a commercial        %
% edition of Reduce.                                               %
%                                                                  %
%                                                                  %
%      *** Revision history since issue of Version 0.99 ***        %
%                                                                  %
% - sloppy use of CAR on atoms corrected in various procedures     %
% - MUL and TSTACK added in PHYSOPTIMES                            %
% - Bug in CLEARPHYSOP corrected                                   %
% - ordering procedures recoded for greater  efficiency            %
% - handling of PROG expressions included via                      %
%     procedure PHYSOPPROG                                         %
% - procedures PHYSOPTIMES and MULTOPOP!* modified                 %
% - extended error handling inclued  via REDERR2                   %
% - PHYSOPTYPELET  recoded                                         %
% - PHYSOPCONTRACT modified for new pattern natcher                %
% - EQ changed to = in MULTF and MULTFNC                           %
% - PHYSOPCOMMUTE/PHYSOPANTICOMMUTE  and COMM2 corrected           %
% - Handling of SUB and output printing adapted to 3.4             %
%                                                                  %
% 1.1 130791 mw                                                    %
% - Modifications for greater efficiency in procedures ORDOP,      %
%   ISANINDEX and ISAVARINDEX                                      %
% - PHYSOP2SQ slightly modified for greater efficiency             %
% - Procedure  COLLECTPHYSTYPE added                               %
% - handling of inverse and adjoint operators modified             %
%   procedures INV and ADJ2  modified                              %
%   procedures INVP and ADJP recoded                               %
% - procedures GETPHYSTYPE!*SQ and GETPHYSTYPESF added for greater %
%   efficiency in type checking of !*SQ expressions                %
% - procedure GETPHYTYPE modified accordingly                      %
% - SIMP!* changed to SUBS2 in procedure PHYSOPSUBS                %
% - Bug in EXPTEXPAND and PHYSOPEXPT corrected                     %
% - PHYSOPORDCHK and PHYSOPSIMP slightly enhanced                  %
% - PHYSOPTYPELET enhanced  (COND treatment)                       %
% - phystypefn for PLUS and DIFFERENCE changed to GETPHYSTYPEALL   %
% - GETPHYSTYPEALL  added                                          %
% - GETPHYSTYPETIMES modified                                      %
% 1.2 190891 mw                                                    %
% - implementation of property PHYSOPNAME for PHYSOPs              %
% - procedures SCALOP,VECOP,TENSOP,STATE,INV,ADJ2,INVADJ modified  %
% - procedure ORDOP recoded, NCMPCHK and PHYSOPMEMBER modified     %
% - procedure PHYSOPSM!* enhanced                                  %
% 1.3  test implementation of a new ordering scheme 260891 mw      %
% - Procedure OPNUM!* and RESET!_OPNUMS added                      %
% - procedure ORDOP recoded                                        %
% - procedure SCALOP,VECOP,TENSOP,STATE,OPORDER modified           %
% - procedure !*XADD added                                         %
% - procedure PHYSOPSIMP corrected                                 %
% 1.4 181291 mw                                                    %
% - bug in procedures SCALOPP, PHYSOPSIMP and TENSOP corrected     %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

create!-package('(physop),'(contrib physics));

%-------------------------------------------------------%
% This part has to be modified by the user if required  %
%-------------------------------------------------------%
% input the NONCOM2 package here  for a compiled version
% input noncom2;

load!-package 'noncom2;

% Modify the infix character for the OPAPPLY function if needed

newtok'((|) opapply);
flag('(opapply), 'spaced);

%-------------------------------------------------------%
% E N D of user modifiable part                         %
%-------------------------------------------------------%


%****************  the following is needed for REDUCE 3.4 *************
fluid '(!*nosq);  % controls proper use of !*q2a
!*nosq := t;
% **************  end of 3.4 modifications **************************

fluid '(frlis!* obrkp!*);

newtok '((d o t) dot);
flag ('(dot), 'spaced);

% define some global variables from REDUCE needed in the package
fluid '(alglist!* subfg!* wtl!*);
Global '(tstack!* mul!*);
% ---define global variables needed for the package---
FLuid '(oporder!* defoporder!* physopindices!* physopvarind!*);
Fluid '(physoplist!*);
Global '(specoplist!*);
% define global flags
fluid '(!*anticom !*anticommchk !*contract !*contract2 !*hardstop);
fluid '(!*indflg indcnt!* !*ncmp ncmp!*);
indcnt!* := 0;
% additional flag needed for contraction
 !*contract2 := nil;
% flag indicating that one elementary comm or opapply has not
% been found --> print warning message
 !*hardstop := nil;

% this are algebraic mode switches
switch contract;
switch anticom;

% reserved operators and variables;
% idx is the basic identifier for system created indices
Global '(idx);


% ----- link new data type PHYSOP in REDUCE ------

% physop is the new datatype containing all subtypes
put('physop,'name,'physop);     %datatype name
put('physop,'evfn,'!*physopsm!*);  % basic simplification routine
put('physop,'typeletfn,'physoptypelet); % routine for type assignements

% Note: we need to make gamma a regular id.

remprop('gamma,'simpfn);  remflag('(gamma),'full);

% ----RLISP procedures which have been modified -----
% procedure for extended error handling
symbolic procedure rederr2(u,v);
begin
msgpri("Error in procedure ",u, ": ", nil,nil);
rederr v
end ;

% procedures multf and multfnc have to be redefined to avoid
% contraction of terms after exptexpand

% The following is an updated version by E.S. and is similiar to what we have
% implemented in the sstools package.

symbolic procedure multfnc(u,v);
   % Returns canonical product of U and V, with both main vars non-
   % commutative.
   begin scalar x,y;
      x := multf(lc u,!*t2f lt v);
      if null x then nil
       else if not domainp x and mvar x eq mvar u and 
%               ((not noncomp2 mvar x) or !*contract2)
                ((not physopp mvar x) or !*contract2)
        then x := addf(if null (y := mkspm(mvar u,ldeg u+ldeg x))
                         then nil
                        else if y = 1 then lc x
                        else !*t2f(y .* lc x),
                       multf(!*p2f lpow u,red x))
       else if noncomp2 mvar u 
               then if null noncommuting(mvar u,mvar x) and null ordop(mvar u,mvar x)
                       then if null(y := multf(!*p2f lpow u,lc x))
                              then x := multf(!*p2f lpow u,red x)
                             else x := addf(!*t2f(lpow x .* y),
                                            multf(!*p2f lpow u,red x))
                     else x := !*t2f(lpow u .* x)
       else x := multf(!*p2f lpow u,x) where !*!*processed=t;
      return addf(x,addf(multf(red u,v),multf(!*t2f lt u,red v)))
   end;

%% This function could be further cleaned up. E.S.

symbolic procedure multf(u,v); % changed
   %U and V are standard forms.
   %Value is standard form for U*V;
   begin scalar x,y;
    a:  if null u or null v then return nil
         else if u=1 then return v     % ONEP
         else if v=1 then return u     % ONEP
         else if domainp u then return multd(u,v)
         else if domainp v then return multd(v,u)
         else if not(!*exp or ncmp!* or wtl!* or x)
          then <>;
        x := mvar u;
        y := mvar v;
%       if (ncmp := noncomp y) and noncomp x then return multfnc(u,v)
        if noncomp2f v and (noncomp2 x or null !*!*processed) then return multfnc(u,v)
%       if noncommuting(x,y) and null !*!*processed then return multfnc(u,v)
%    we have to put this clause here to prevent evaluation in case
%    of equal main vars
        else if %noncommutingf(y, lc u) or  %noncommutingf shouldn't be necessary.
                (ordop(x,y) and (x neq y))
          then << x := multf(lc u,v);
                 y := multf(red u,v);
                 return if null x then y else lpow u .* x .+ y>>
         else if x = y and (not physopp x or !*contract2)
         % two forms have the same mvars
         % switch contract added here to inhibit power contraction
         % if not wanted (used by PHYSOP)
          then << x := mkspm(x,ldeg u+ldeg v);
          y := addf(multf(red u,v),multf(!*t2f lt u,red v));
                 return if null x or null(u := multf(lc u,lc v))
                    then <>
                   else if x=1 then addf(u,y)
                   else if null !*mcd then addf(!*t2f(x .* u),y)
                   else x .* u .+ y>>;
        x := multf(u,lc v);
        y := multf(u,red v);
       return if null x then y else lpow v .* x .+ y
   end;

symbolic procedure noncomp2f u;
 if domainp u then nil
  else noncomp2 mvar u or noncomp2f lc u or noncomp2f red u;

symbolic procedure opmtch!* u;
% same as opmtch but turns subfg!* on
begin scalar x,flg;
flg:= subfg!*; subfg!* := t;x:= opmtch u; subfg!* := flg;
return x
end;

symbolic procedure reval3 u;
% this is just a redefinition of reval2(u,nil)
% which call simp instead of simp!*
% it saves at lot of writing in some procedures
mk!*sq x where x := simp u;

%  ---- procedure related to ordering of physops in epxr -------

symbolic procedure oporder u;
% define a new oporder list
begin
if not listp u then rederr2('oporder, "invalid argument to oporder");
if (u = '(nil)) then oporder!* := defoporder!*  % default list
else for each x in reverse u do <<
         if not physopp x then rederr2('oporder,
         list(x," is not a PHYSOP"));
         oporder!* := nconc(list(x),physopdelete(x,oporder!*)) >>; %1.01
% write "oporder!* set to: ",oporder!*;terpri();
         reset!_opnums(); %1.03
rmsubs()
end;
rlistat '(oporder);

symbolic procedure physopdelete(u,v);
% u is a physop, v is a list of physops
% deletes u from v
if atom u then delete(u,v)
else
delete(u,delete(car u,delete(removeindices(u,collectindices u),v)));

symbolic procedure opnum!* u; % new 1.03
begin scalar op,arglist;
if not idp u then u := removeindices(u,collectindices u);
if idp u then op := u
else << op := car u; arglist := cdr u;>>;
return
  if null (u:= assoc(arglist,get(op,'opnum))) then
       cdr  assoc(nil,get(op,'opnum))
  else cdr u
end;

symbolic procedure reset!_opnums();
begin scalar x,lst,n,op,arglist;
lst := oporder!*;
n := 1;
a: if null lst then return;
   x := car lst;   lst := cdr lst;
   if idp x then <>
   else <>;
  put(op,'opnum,!*xadd((arglist . n),get(op,'opnum)));
  n:= n+1;
  go to a
end;

symbolic procedure !*xadd(u,v); % new 1.03
% u is assignement , v is a table
% returns updated table
begin scalar x;
x := v;
while x and not (car u = caar x) do x := cdr x;
if x then v := delete(car x,v);
v := u . v;
return v
end;


symbolic procedure ordop(u,v);
% recoded ordering procedure of operators
% checks new list oporder!*  for physops or calls ordop2
% default is to put anything ahead of physops
% we use !*physopp instead of physopp in order to use
% ordop even if we hide the physop rtype
begin scalar x,y,z,nx,ny;
% this are the trivial cases
if not (!*physopp u and !*physopp v) then return
       if !*physopp u then nil
       else if !*physopp v then t
            else ordop2(u,v);
% now come the cases with 2 physops
% following section modified 1.02
if idp u then x:= get(u,'physopname)
else
<<
   x:=get(car u,'physopname);
   x:= x . cdr u;
   u := car u;
>>;
if  member(u,specoplist!*) then return t;
if idp v then y:= get(v,'physopname)
else
<<
   y:= get(car v, 'physopname);
   y := y . cdr v;
   v := car v;
>>;
if member(v,specoplist!*) then return t;
% end of modifications 1.02
% from here it is 1.03
nx := opnum!* x;
ny := opnum!* y;
return
if nx < ny then t
else if nx > ny then nil
     else if idp x then t
          else if idp y then nil
               else ordop(cdr x, cdr y);
end;

symbolic procedure ordop2(u,v);
% this is nothing but the standard ordop procedure
   begin scalar x;
        x := kord!*;
    a:  if null x then return ordp(u,v)
         else if u eq car x then return t
         else if v eq car x then return;
        x := cdr x;
        go to a
   end;

% obsolete in 1.03
%symbolic procedure physopmember(u,v); % 1.02 order modified
% u is a physop, v is a list
% return part of v starting with u
%member(u,v) or ((not atom u) and (member(car u,v)
% or member(removeindices(u,collectindices u),v)));


symbolic procedure physopordchk(u,v);  % new version 080591
% u and v are physopexpr
% builds up a list of physops of u and v
% checks if there is a pair of wrong ordered noncommuting operators
% in these lists
begin scalar x,y,z,oplist,lst;
x := deletemult!* !*collectphysops u;  %1.01
y := deletemult!* !*collectphysops v; % 1.01
return
if null x then t
else if null y then nil
else if member('unit,x) or member('unit,y) then nil %further eval needed
else physopordchk!*(x,y);
end;

symbolic procedure ncmpchk(x,y); % order changed 1.02
% x and y are physops
% checks for correct ordering in noncommuting case
(not noncommuting(x,y)) or ordop(x,y);

symbolic procedure  physopordchk!*(u,v);
% u and v are lists of physops
% checks if there is a pair of wrong ordered noncommuting operators
% in this list
begin scalar x,y,lst;
x:= car u;  u := cdr U;
if null u then
    if null cdr v then
        return (ncmpchk(x,car v) and not (invp x = car v))
    else
         <<
            lst := for each y in v collect ncmpchk(x,y);
            if member(nil,lst) then return nil
            else return t
         >>
else return (physopordchk!*(list(x),v) and physopordchk!*(u,v));
end;

% ---general testing functions for PHYSOP expressions----

symbolic procedure physopp u;
if atom u then (idp u and (get(u,'rtype) eq 'physop))
else (idp car u and (get(car u,'rtype) eq 'physop));

% slightly more general

symbolic procedure !*physopp u;
% used to determine physops when physop rtype is hidden
if atom u then (idp u and get(u,'phystype))
else (idp car u and get(car u,'phystype));


symbolic procedure physopp!* u;
 physopp u or (not atom u and (flagp(car u,'physopfn) or
(flagp(car u,'physoparith) and
hasonephysop  cdr u) or (flagp(car u,'physopmapping) and
hasonephysop cdr u)));

symbolic procedure !*physopp!* u;
physopp!* u or getphystype u;

symbolic  procedure hasonephysop u;
if null u then nil
else (physopp!* car u) or hasonephysop cdr u;

symbolic  procedure areallphysops u;
if null u then nil
else if null cdr u then !*physopp!* car u
else (!*physopp!* car u) and areallphysops cdr u;

% *****defining functions for different data subtypes******

% scalar operator
symbolic procedure scalop u;
begin scalar y;
for each x in u do
if not idp x then
  msgpri("cannot declare",x,"a scalar operator",nil,nil)
else if physopp x then
  msgpri(x,"already declared as",get(x,'phystype),nil,nil)
else <>;
     >>;
return nil
end;

symbolic procedure scalopp u;
(idp u  and get(u,'phystype) = 'scalar)  or (not atom u and (
(get(car u,'phystype) = 'scalar) or
((get(car u,'phystype) = 'vector) and isanindex cadr u)
or ((get(car u,'phystype) = 'tensor)  and
     (length(cdr u)  >= get(car u,'tensdimen)) and
 areallindices(for k:=1 :get(car u,'tensdimen) collect nth(cdr u,k)))));

symbolic procedure vecop u;
begin scalar y;
for each x in u do
if not idp x then
   msgpri("cannot declare",x,"a vector operator",nil,nil)
else if physopp x then
   msgpri(x,"already declared as",get(x,'phystype),nil,nil)
else <>;
     >>;
return nil
end;

symbolic  procedure vecopp u;
(idp u and (get(u,'phystype) = 'vector)) or (not atom u and
((get(car u,'phystype) ='vector) and not isanindex cadr u));

symbolic procedure tensop u;
begin scalar y,n;
% write "car u=",car u;terpri();
for each x in u do
<<
  if idp x  or not numberp cadr x then
    msgpri("Tensor operator",x,"declared without dimension",nil,nil)
  else
  <<
     n:= cadr x; x:= car x;
     if not idp x then
          msgpri("cannot declare",x,"a tensor operator",nil,nil)
     else if physopp x then
          msgpri(x,"already declared as",get(x,'phystype),nil,nil)
     else
     <<
        y :=gettype x;
        if y memq '(matrix operator array procedure) then
            msgpri(x,"already defined as",y,nil,nil)
        else
        <<
            put(x,'rtype,'physop);
            put(x,'phystype,'tensor);
            put(x,'psimpfn,'physopsimp);
            put(x,'physopname,x); % 1.02
            put(x,'tensdimen,n);
            defoporder!* := nconc(defoporder!*,list(x));
            oporder!* := nconc(oporder!*,list(x));
            physoplist!* := nconc(physoplist!*,list(x));
            invphysop x; adj2 x; invadj x; %1.01
            reset!_opnums();
        >>
     >>
  >>
>>;
return nil
end;

symbolic  procedure tensopp u;
(idp u and (get(u,'phystype) = 'tensor)) or (not atom u and
((get(car u,'phystype) ='tensor) and not isanindex cadr u));

symbolic procedure state u;
begin scalar y;
for each x in u do
if not idp x then msgpri("cannot declare",x,"a state",nil,nil)
else if physopp x then
        msgpri(x,"already declared as",get(x,'phystype),nil,nil)
else <>
     >>;
return nil
end;

symbolic  procedure statep u;
(idp u and get(u,'phystype) = 'state) or (not atom u and
   (idp car u and get(car u,'phystype) = 'state));

symbolic  procedure statep!* u;
% slightly more general since state may be hidden in another operator
(getphystype u = 'state);


% some procedures for vecop and tensop indices

symbolic procedure physindex u;
begin scalar y;
for each x in u do <<
if not idp x then msgpri("cannot declare",x,"an index",nil,nil)
else if physopp x then
        msgpri(x,"already declared as",get(x,'phystype),nil,nil)
else <>
     >>;
return nil
end;

symbolic procedure physindexp u;
% boolean function to test if an id is a physindex
% in algebraic mode
if idp u and  isanindex u then t
else if idlistp u and areallindices u then t
else nil;

flag ('(physindexp),'opfn);
flag ('(physindexp),'boolean);

deflist('((scalop rlis) (vecop rlis) (tensop  rlis)
          (state rlis) (physindex rlis)),'stat);


symbolic procedure isanindex u;  %recoded 1.01
idp u and (memq(u,physopindices!*) or member(u,physopvarind!*)
           or (memq(u,frlis!*) and member(revassoc(u,frasc!*),
               physopindices!*)));

symbolic  procedure isavarindex u; % recoded 1.01
member(u,physopvarind!*);


symbolic  procedure areallindices u;
isanindex car u and (null cdr u or areallindices cdr u);


symbolic procedure putanewindex u;
% makes a new index available to the system
begin scalar indx;
indx := u;
if isanindex indx then nil
else if (not atom indx)  or getrtype indx then
             rederr2('putanewindex,list(indx,"is not an  index"))
     else physopindices!* := nconc(physopindices!*,list(indx));
return nil
end;

symbolic procedure putanewindex!* u;
% used by ISANINDEX to recognize unresolved IDXn indices
begin scalar x;
if not idp u then return;
x:= explode u;
if length(x) < 4 then return;
x := for j:= 1 : 3 collect nth(x,j);
if not(x='(I D X ) or x='(!i !d !x)) then return; % check both cases.
physopindices!* := nconc(physopindices!*,list(u));
return t
end;

symbolic procedure makeanewindex();
% generates a new index
begin scalar x,n;
n:=0;
a: n:=n+1;
  x:= mkid('idx,n);
  if isanindex x then go to a
  else putanewindex x;
return x
end;

symbolic procedure makeanewvarindex();
% generates a new variable index
% for patterm matching
% physopvarind!* keeps var indices to avoid inflation
begin scalar x,y,n;
n:=0;
   y:= makeanewindex();
   x := intern compress append(explode '!=,explode y);
   nconc(frlis!*,list(x));
   physopvarind!*:= nconc(physopvarind!*,list(x));
   frasc!* := nconc(frasc!*,list((y . x)));
return x
end;

symbolic procedure getvarindex n;
begin scalar ilen;
if not numberp n then rederr2 ('getvarindex,
"invalid argument to getvarindex");
ilen := length(physopvarind!*);
return
if n > ilen then makeanewvarindex()
else nth(physopvarind!*,n);
end;

symbolic procedure transformvarindex u;
% u is a free index
% looks for the corresponding index on the frasc
% or creates a new one
begin scalar x;
x := explode u;
if length(x) < 3 or not(nth(x,2) eq '=) then return u;
x := intern compress pnth(x,3);
putanewindex x;
if not atsoc(x,frasc!*) then
   frasc!* := nconc(frasc!*,list((x . u)));
return x
end;

symbolic procedure insertindices(u,x);
% u is a vecopp or tensopp
% x is an index or a list of indices
if (idp x and not isanindex x) or (idlistp x and not areallindices x)
   then rederr2('insertindices, "invalid indices to insertindex")
else if vecopp u then if idp u then list(u,x)
                 else car u . ( x . cdr u)
     else if tensopp u then if idp u then u . x
                            else car u . nconc(x,cdr u)
% do not insert any index in states or scalops
          else u;

symbolic procedure insertfreeindices(u,flg);
% procedure to transform vecop and tensop into scalops
% by inserting free indices taken from the varindlist
% flg is set to t if variable indices are requested
begin scalar n,x;
if vecopp u then <>
else if tensopp u then <>
     else rederr2('insertfreeindices,
      "invalid argument to insertfreeindices");
end;

symbolic procedure collectindices u;
% makes a list of all indices in a.e. u
begin scalar v,x;
if atom u then
  if isanindex u then return list(u)
  else return nil;
a: v := car u;
   u := cdr u;
   x :=nconc(x,collectindices v);
   if null u then return x;
   go to a
end;

symbolic procedure removeindices(u,x);
% u is physop (scalop) containing  physindices
% x is an index or a list of indices
begin scalar op;
 trwrite('removeindices,"u= ",u," x= ",x);
if null x or idp u or not !*physopp u then return u;
if (idp x and not isanindex x) or (idlistp x and not areallindices x)
   then rederr2('removeindices, "invalid arguments to removeindices");
op:=car u;u := cdr u;
if null u then return op;
if idp x then u := delete(x,u)
else for each y in x do u:= delete(y,u);
return if null u then op else op . u
end;

symbolic procedure deadindices u;
% checks an a.e. u to see if there are dead indices
% i.e. indices appearing twice or more
%returns the list of dead indices in u
begin scalar x,res;
if null u or atom u then return nil;
x := collectindices u;
for each y in x do
if memq(y,memq(y,x)) then res :=nconc(res,list(y));
return res
end;

symbolic procedure collectphysops u;
% makes a list of all physops in a.e. u
begin scalar v,x;
if atom u then
  if physopp u then return list(u)
  else return nil
else if physopp u then return list(removeindices(u,collectindices u));
a: v := car u;
   u := cdr u;
   x :=nconc(x,collectphysops v);
   if null u then return x;
   go to a
end;

symbolic procedure !*collectphysops u;
% makes a list of all physops in a.e. u
% with ALL indices
begin scalar v,x;
if physopp u then return list(u);
if atom u then return nil;
a: v := car u;
   u := cdr u;
   x :=nconc(x,!*collectphysops v);
   if null u then return x;
   go to a
end;

symbolic procedure collectphysops!* u;
begin scalar x;
x:= for each y in collectphysops u collect if idp y then y
                                           else car y;
return x
end;

symbolic procedure collectphystype u; % new 1.01
% makes a list of all physops in u
% with ALL indices
if physopp u then list(getphystype u)
else if atom u then nil
else   deletemult!* (for each v in u collect getphystype v);

% ----  PHYSOP procedures for type check and assignement ----

% modify the REDUCE GETRTYPE routine to get control over PHYSOP
% expressions

symbolic procedure getrtype u; %modified
   % Returns overall algebraic type of u (or NIL if expression is a
   % scalar). Analysis is incomplete for efficiency reasons.
   % Type conflicts will later be resolved when expression is evaluated.
   begin scalar x,y;
    return
    if atom u
      then if not idp u then nil
            else if flagp(u,'share) then getrtype eval u
            else if x := get(u,'rtype)
                    then if y := get(x,'rtypefn) then apply1(y,nil)
                          else x
                  else nil
     else if not idp car u then nil
     else if physopp!* u then 'physop  % added
     else if (x := get(car u,'rtype)) and (x := get(x,'rtypefn))
      then apply1(x, cdr u)
     else if x := get(car u,'rtypefn) then apply1(x, cdr u)
     else nil
   end;

symbolic procedure getrtypecadr u;
not atom u and getrtype cadr u;

symbolic procedure getnewtype u;
not atom u and get(car u,'newtype);

symbolic procedure getphystype u;
% to get the type of a PHYSOP object
begin scalar x;
return
if physopp u then
   if scalopp u then  'scalar
   else if vecopp u then 'vector
        else if tensopp u then 'tensor
             else if statep u then  'state
                  else nil
else if atom u then nil
% following line suppressed 1.01
%    else if car u = '!*sq then return getphystype physopaeval u
          else if (x:=get(car u,'phystype)) then x
               else if (x:=get(car u,'phystypefn)) then
                        apply1(x,cdr u)
                             % from here it is 1.01
                    else if null (x := collectphystype u)         % 1.01
                             then nil
                         else if null cdr x then car x
                              else if member('state,x) then 'state
                                   else rederr2('getphystype,list(
                                          "PHYSOP type conflict in",u));
end;

symbolic procedure getphystypecar u;
 not atom u and getphystype car u;

symbolic procedure getphystypeor u;
not atom u and (getphystype car u or getphystypeor cdr u);

symbolic procedure getphystypeall args;  % new 1.01
begin scalar x;
 if null  (x := collectphystype deleteall(0,args)) then
        return nil
 else if cdr x then
          rederr2('getphystypeall,
              list("PHYSOP type mismatch in",args))
      else return car x
end;

% ***** dirty trick *****
% we introduce a rtypefn for !*sq expressions to get
% proper type checking in assignements
symbolic procedure physop!*sq U;
% u is a !*sq expressions
% checks if u contains physops
begin scalar x;
x:= !*collectphysops !*q2a car u;
return
if null x then nil
else 'physop
end;

deflist('((!*sq physop!*sq)), 'rtypefn);

% 1.01 we add also a phystypefn for !*sq

symbolic procedure getphystype!*sq u;  % new 1.01
getphystypesf caar u;

deflist('((!*sq getphystype!*sq)), 'phystypefn);

symbolic procedure getphystypesf u; % new 1.01
% u is a s.f.
% returns the phystype of u
if null u or domain!*p u then nil
else getphystype mvar u or getphystypesf lc u;

%-----end of 1.01 modifications -----------------

% we have also to modify the simp!*sq routine since
% there is no type checking included
symbolic procedure physopsimp!*sq u;
if cadr u then car u
else if physop!*sq u then physop2sq physopsm!* !*q2a car u
     else resimp car u;

put('!*sq,'simpfn,'physopsimp!*sq);
% ***** end of dirty trick ******

% ----PHYSOP evaluation and simplification procedures----

symbolic procedure !*physopsm!* (u,v);
% u is the PHYSOP expression to simplify
begin scalar x,contractflg;
% if contract is set to on we keep its value at the top level
% (first call to physopsm) and set it to nil;
contractflg:=!*contract;!*contract := nil;
!*hardstop := nil;
if physopp u then
    if (x:= get(u,'rvalue)) then u := physopaeval x
    else if idp u then return u
         else if x:=get(car u,'psimpfn) then u:= apply1(x,u)
         else return physopsimp u;
u:= physopsm!* u;
if !*hardstop then <<
  write "        *************** WARNING: ***************";terpri();
  write "Evaluation incomplete due to missing elementary relations";
  terpri();
   return u>>;
% the next step is to do substitutions if there are someones on
% the matching lists
if !*match or powlis1!* then <<
u := physopsubs u;
% now eval u with the substitutions
u := physopsim!* u; >>;
if not contractflg then return u
else <<
!*contract:=contractflg;
 return physopcontract u >>
end;

symbolic procedure physopsim!* u;
if !*physopp!* u then physopsm!* u else u;

symbolic  procedure physop2sq u; %modified 1.01
% u is a physop expr
% returns standard quotient of evaluated u
begin scalar x;
return
if physopp u then if (x:= get(u,'rvalue)) then physop2sq x
                       else if idp u then !*k2q u
                       else if (x:= get(car u,'psimpfn)) then
                              if physopp (x:=apply1(x,u)) then
                                 !*k2q x
                              else cadr physopsm!* x
                       else if get(car u,'opmtch) and
                               (x:= opmtch!* u) then physop2sq x
                       else !*k2q u
 else if atom u then simp u % added 1.01
     else if car u eq '!*sq then cadr u
          else if null getphystype u then simp u % moved from top 1.01
               else physop2sq physopsm!* u
end;

symbolic procedure physopsm!* u;
% basic simplification routine
 begin scalar oper,args,y,v,physopflg;
 % the following is 1.02
 if (null u or numberp u) then v := u
 else if physopp u then v:= if (y:= get(u,'rvalue)) then physopaeval y
                       else if idp u then u
                       else if (y:=get(car u,'psimpfn)) then
                               apply1(y,u)
                       else if get(car u,'opmtch) and
                               (y:=opmtch!* u) then y
                       else u
 else if atom u then v := aeval u
 else <<
   oper := car u;
   args := cdr u;
   if y:= get(oper,'physopfunction) then
   % this is a function which may also have normal scalar arguments
   % eg TIMES so we must check if args contain PHYSOP objects
   % or if it is an already evaluated expression of physops
        if flagp(oper,'physoparith) then
            if hasonephysop args then v:= apply(y,list args)
            else  v := reval3 (oper . args)
        else if flagp(oper,'physopfn) then
                if areallphysops args then v:= apply(y,list args)
                else
                rederr2('physopsm!*,
                list("invalid call of ",oper," with args: ",args))
        else rederr2('physopsm!*,list(oper,
            " has been flagged Physopfunction"," but is not defined"))
% this is for fns having a physop argument and no evaluation procedure
   else if flagp(oper,'physopmapping) and !*physopp!* args then
                v := mk!*sq !*k2q (oper . args)
%   special hack for handling of PROG constructs
   else if oper = 'PROG then v := physopprog args
        else  v := aeval  u
      >>;
  return v
end;

symbolic procedure physopsubs u;
% general substitution routine for physop expressions
% corresponds to subs2
% u is a !*sq
% result is u in a.e. form with all substitutions of
% !*MATCH and POWLIS1!* applied
% we use a quite dirty trick here which allows to use
% the pattern matcher of standard REDUCE by hiding the
% PHYSOP rtype temporarily
begin scalar ulist,kord,alglist!*;
% step 1: convert u back to an a.e.
% u := physopaeval u; % 1.01 this line replaced
  u := physop2sq u;
% step 2: transform all physops on physoplist in normal ops
  for each x in physoplist!* do << remprop(x,'rtype);
                                  put(x,'simpfn,'simpiden)>>;
  % since we need it here as a prefix op
  remflag('(dot),'physopfn);
  put('dot,'simpfn,'simpiden);
% step 3: call simp!* on u
% u := simp!* u; % 1.01 this line replaced
 u := subs2 u;
% step 4: transform u back in an a.e.
  u := !*q2a u;
% step 5: transform ops in physoplist back to physops
  for each x in physoplist!* do <>;
  remprop('dot,'simpfn);
  flag('(dot),'physopfn);
% final step return u
return u
end;

symbolic procedure physopaeval u;
% transformation of physop expression in a.e.
begin scalar x;
return
if physopp u then
   if (x:=get(u,'rvalue)) then
       if car x eq '!*sq then !*q2a cadr x
       else x
   else if atom u then u
   else if (x:= get(car u,'psimpfn)) then apply1(x,u)
   else if get(car u,'opmtch) and (x:= opmtch!* u)  then x
       else  u
else if (not atom u) and car u eq '!*sq then !*q2a cadr u
     else u
end;

symbolic procedure physopcontract u;
% procedure to contract over dead indices
begin scalar x,x1,w,y,z,ulist,veclist,tenslist,oldmatch,oldpowers,
             alglist!*,ncmplist;
u := physopaeval u;
if physopp u then return mk!*sq physop2sq u
else if not getphystype u then return aeval u;
% now came the tricky cases
!*contract2 := t;
% step1 : collect all physops in u
 ulist := collectphysops u;
 veclist := for each x in ulist collect if vecopp x then  x else nil;
 tenslist := for each x in ulist collect if tensopp x then x else nil;
 veclist:= deletemult!* deleteall(nil,veclist);
 tenslist:=deletemult!* deleteall(nil,tenslist);
% step2: we now modify powlis1!* and !*match
  oldmatch := !*match; !*match := nil;
  oldpowers := powlis1!*; powlis1!* := nil;
% step3: transform all physops on physoplist in normal ops
for each x in physoplist!* do
<<
   remprop(x,'rtype);
   put(x,'simpfn,'simpiden);
   if noncomp!* x then ncmplist := x . ncmplist;
>>;
% we have to declare the ops in the specoplist as noncom to avoid
% spurious simplifications  during contraction
remflag('(dot opapply),'physopfn); % needed here as a normal op
flag(specoplist!*,'noncom);
!*ncmp := t;
for each x in specoplist!* do
<<
   put(x,'simpfn,'simpiden);
   put(x,'noncommutes,ncmplist)
>>;
% step4: put new matching for each vecop on the list
  y := getvarindex(1);
  frlis!* := nconc(frlis!*,list('!=nv));
  frasc!* := nconc(frasc!*,list('nv . '!=nv));
  for each x in veclist do <<
     let2(list('expt,insertindices(x,transformvarindex y),'nv),
           list('expt,x,'nv),nil,t);
      x1:=delete(x,veclist);
     for each w in x1 do
       << z := list(list((insertindices(x,y) . 1),
            (insertindices(w,y) . 1)),(nil . t),
            list('dot,x,w),nil);
       !*match :=append(list(z),!*match) >>
  >>;
% step4: put new matching for each tensop on the list
  frlis!* := nconc(frlis!*,list('!=nt));
  frasc!* := nconc(frasc!*,list('nt . '!=nt));
  for each x in tenslist do
     let2(list('expt,insertfreeindices(x,t),'nt),
           list('expt,x,'nt),nil,t);
% step 6: call simp on u
u := simp!* u;
% step 7: restore previous settings
powlis1!* := oldpowers;!*match := oldmatch;
for each x in physoplist!* do
<<
   remprop(x,'simpfn);
   put(x,'rtype,'physop)
>>;
flag('(dot opapply),'physopfn);
remflag(specoplist!*,'noncom);
for each x in specoplist!* do
<<
   remprop(x,'noncommutes);
   remprop(x,'simpfn)
>>;
!*contract2 := nil;
return mk!*sq u
end;

symbolic procedure physopsimp u;  % 1 line deleted 1.03
% procedure to simplify the arguments of a physop
% inspired from SIMPIDEN
begin scalar opname,w,x,y,flg;
if idp u then return u;
opname := car u;
x := for each j in cdr u collect
         if idp j and (isanindex j or isavarindex j) then j %added 1.01
         else physopsm!* j;
u := opname . for each j in x collect
                if eqcar(j,'!*sq) then prepsqxx cadr J
                else j;
if x := opmtch!* u then return x;
% special hack introduced here to check for
% symmetric and antisymmetric tensor operators
if scalopp u and tensopp opname then
 << y := get(opname,'tensdimen);
% x is the list of physopsindices
    x:= for k:=1 :y collect nth(cdr u,k);
% y contains the remaining indices
    if length(cdr u) > y then y := pnth(cdr u,y+1)
    else y := nil;
    if flagp(opname,'symmetric) then u:= opname . ordn x
    else if flagp(opname,'antisymmetric) then
           << if repeats x then return 0
              else if not permp(w := ordn x, x) then flg := t;
              x := w;
              u := opname . x >>
         else u := opname . x;
    if y then  u:= append(u,y);
    return if flg then list('minus,u)  else u
 >>
% special hack to introduce unrecognized IDXn indices
 else if vecopp u then << if listp u then putanewindex!* cadr u;
                          return u >>
      else if tensopp u then << if listp u then
                                     for j:= 1 : length(cdr u) do
                                    putanewindex!* nth(cdr u,j);
                                return u >>
           else return u
end;
% ---- different procedures for arithmetic in phsyop expressions ----

flag('(quotient times expt difference minus plus opapply),'physoparith);
flag('(adj recip dot commute anticommute),'physopfn);
flag ('(sub),'physoparith);
flag('(sin cos tan asin acos atan sqrt int df log exp sinh cosh tanh),
      'physopmapping);
% the following is needed for correct type checking 101290 mw

symbolic procedure checkphysopmap u;
% checks an expression u for unresolved physopmapping  operators
begin scalar x;
a: if null u or domain!*p u or atom u or null cdr u then return nil;
   x:= car u; u:= cdr u;
   if listp x and flagp(car x,'physopmapping) and hasonephysop cdr x
         then return t;
   go to a;
end;

symbolic procedure physopfn(oper,proc);
begin
put(oper,'physopfunction,proc);
end;

physopfn('difference,'physopdiff);

symbolic procedure physopdiff args;
 begin scalar lht,rht,lhtype,rhtype;
 lht := physopsim!* car args;
 for each v in cdr args do  <<
   rht := physopsim!* v;
   lhtype := getphystype lht;
   rhtype :=  getphystype rht;
   if (rhtype and lhtype) and not(lhtype eq rhtype) then
        rederr2('physopdiff,"type mismatch in diff");
   lht :=
       mk!*sq addsq(physop2sq lht,negsq(physop2sq rht))
 >>;
 return lht
end;

put('difference,'phystypefn,'getphystypeall);  % changed 1.01

physopfn('minus,'physopminus);

symbolic procedure physopminus arg;
begin scalar rht,rhtype;
 rht := physopsim!* car arg;
 rht :=
     mk!*sq negsq(physop2sq rht);
return rht
end;

put('minus,'phystypefn,'getphystypecar);

physopfn('plus,'physopplus);

symbolic procedure physopplus args;
 begin scalar lht,rht,lhtype,rhtype;
 lht := physopsim!* car args;
 for each v in cdr args do  <<
   rht := physopsim!* v;
   lhtype := getphystype lht;
   rhtype := getphystype rht;
   if (rhtype and lhtype) and  not (lhtype eq rhtype) then
        rederr2 ('physopplus,"type mismatch in plus ");
   lht :=
      mk!*sq addsq(physop2sq lht,physop2sq rht)
 >>;
 return lht
end;

put('plus,'phystypefn,'getphystypeall);  % changed 1.01

physopfn('times,'physoptimes);

symbolic procedure physoptimes args;
 begin scalar lht, rht,lhtype,rhtype,x,mul;
 if (tstack!* = 0) and mul!* then << mul:= mul!*; mul!* := nil; >>;
 tstack!* := tstack!* + 1;
 lht := physopsim!* car args;
 for each v in cdr args do  <<
   rht :=physopsim!* v;
   lhtype := getphystype  lht;
   rhtype := getphystype  rht;
if not lhtype then
   if not rhtype then lht := mk!*sq multsq(physop2sq lht,physop2sq rht)
    else if zerop lht then lht := mk!*sq (nil . 1)
         else if onep lht then lht:= mk!*sq physop2sq rht
              else lht:= mk!*sq  multsq(physop2sq lht,physop2sq rht)
else if not rhtype then lht:=
        if zerop rht then mk!*sq (nil . 1)
        else if onep rht then mk!*sq physop2sq lht
             else mk!*sq multsq(physop2sq rht,physop2sq lht)
else if physopordchk(physopaeval lht,physopaeval rht)
             and (lhtype = rhtype) and (lhtype = 'scalar)
        then lht := mk!*sq multsq(physop2sq lht,physop2sq rht)
     else  lht:= multopop!*(lht,rht)
 >>;
b: if null mul!* or tstack!* > 1 then go to c;
   lht := apply1(car mul!*,lht);
   mul!* := cdr mul!*;
   go to b;
c: tstack!* := tstack!* - 1;
   if tstack!* = 0  then mul!* := mul;
   return lht
end;

put('times,'phystypefn,'getphystypetimes);

symbolic procedure getphystypetimes args;  % modified 1.01
begin scalar x;
 if null  (x := deleteall(nil,collectphystype args)) then
        return nil
 else if null cdr x then   return car x
      else rederr2('getphystypetimes,
              list("PHYSOP type mismatch in",args))
end;

symbolic procedure multopop!*(u,v);
% u and v are physop exprs in a.e. form
% value is the product of u and v + commutators if needed
begin scalar x,y,u1,v1,stac!*,res;
% if there is no need for additional computations of commutators
% return the product as a standard quotient
u1:= physopaeval u;
v1:= physopaeval v;
if physopp u1 and physopp v1 then res := multopop(u1,v1)
else if physopp v1 then
         if car u1 memq '(plus difference minus) then <<
              x:= for each y in cdr u1 collect physoptimes list(y,v);
              res:= reval3 (car u1 . x) >>
         else if car u1 eq 'times then <<
                  stac!*:= reverse cdr u1; % begin with the last el
                  y:= v;
                  while stac!* do <<
                  x := car stac!*;
                  y := physoptimes list(x,y);
                  stac!* := cdr stac!*;
                                  >>;
                  res:= y >>
                  else if car u1 eq 'quotient then res:= mk!*sq
            quotsq(physop2sq physoptimes list(cadr u1,v),
                   physop2sq caddr u1)
                       else res:= physoptimes list(u1,v1)
     else if car v1 memq '(plus difference minus) then <<
             x:= for each y in cdr v1 collect physoptimes list(u,y);
             res:= reval3 (car v1 . x) >>
             else if car v1 eq 'times then <<
                  stac!*:= cdr v1;
                  y:= u;
                  while stac!* do <<
                  x := car stac!*;
                  y := physoptimes list(y,x);
                  stac!* := cdr stac!*;
 %                write "y= ",y," stac= ",stac!*;terpri();
                                  >>;
                  res:= y >>
                  else if car v1 eq 'quotient then res:= mk!*sq
                          quotsq(physop2sq physoptimes list(u,cadr v1),
                             physop2sq caddr v1)
                       else res:= physoptimes list(u1,v1);
return res
end;

symbolic procedure multopop(u,v);
% u and v are physops  (kernels)
% value is the product of physops + commutators if necessary
begin scalar res,x,ltype,rtype;
ltype := getphystype u;
rtype := getphystype v;
if ltype neq rtype then
       rederr2('multopop,"type conflict in TIMES")
 else if (invp u = v) then res := mk!*sq !*k2q 'unit
 else if u = 'unit then res := mk!*sq !*k2q  v
 else if v = 'unit then res := mk!*sq !*k2q u
 else if ordop(u,v) then
              res :=  mk!*sq !*f2q multfnc(!*k2f u,!*k2f v)
 else if noncommuting(u,v) then <>
 else  res := mk!*sq !*f2q multfnc(!*k2f v,!*k2f u);
return res
end;

physopfn('expt,'physopexpt);

symbolic procedure physopexpt args;
 begin scalar n1,n2,lht,rht,lhtype,rhtype,x,y,z;
% we have to add a special bootstrap to avoid too much simplification
% in case of dot products raise to a power
 lht := physopsm!* car args;
 rht := physopsm!* cadr args;
 lhtype := physopp  lht ;
 rhtype := physopp  rht;
 if rhtype then
     rederr2('physopexpt,"operators in the exponent cannot be handled");
 if not getphystype lht then lht := reval3 list('expt,lht,rht);
 if not lhtype then
    if numberp rht then <<
            n1 := car divide(rht,2);
            n2 := cdr divide(rht,2);
            lhtype := getphystype lht;
       if (lhtype and zerop rht) then lht := mk!*sq !*k2q 'unit %1.01
       else if lhtype = 'vector then <<
            x:= for k:= 1 : n1 collect physopdot list(lht,lht);
            if onep n1 then x := 1 . x;
            lht:= if zerop n2 then physoptimes x
                  else physoptimes append(x,list(lht));>>
       else if lhtype  = 'tensor then <<
            x:= for k:= 1 : n1 collect physoptens list(lht,lht);
            if onep n1 then x := 1 . x;
            lht:= if zerop n2 then physoptimes x
                  else physoptimes append(x,list(lht));>>
       else if lhtype = 'state then
         rederr2('physopexpt,
         "expressions involving states cannot be exponentiated")
       else << lht := physopaeval lht;
               x := deletemult!* collectindices lht;
               z := lht;
               for k :=2 :rht do <<
                for each x1 in x do
                    if isavarindex x1 then
                       lht:= subst(makeanewvarindex(),x1,lht)
                    else lht:=subst(makeanewindex(),x1,lht);
                y := append(y,list(lht));
                lht := z; >>;
               lht := physoptimes (z . y); >>;
       >>
    else lht := mk!*sq simpx1(physopaeval lht,physopaeval rht,1)
else if lht = 'unit then lht := mk!*sq !*k2q 'unit
     else if numberp rht  then  lht := exptexpand(lht,rht)
          else  lht := mk!*sq !*P2q (lht . physopaeval rht); %0.99c
return lht
end;

put('expt,'phystypefn,'getphystypeexpt);

symbolic  procedure getphystypeexpt args;  % recoeded 0.99c
begin scalar x;
x := getphystypecar args;
return
    if null x then nil
    else if numberp cadr args and evenp cadr args then 'scalar
    else x;
end;

symbolic procedure exptexpand(u,n);
begin scalar bool,x,y,v,n1,n2,res,flg;
if not numberp n then
rederr2('exptexpand,list("invalid argument ",n," to EXPT"));
if zerop n then return mk!*sq !*k2q 'unit; %1.01
bool := if n < 0 then t else nil;
n := if bool then abs(n) else n;
n1 := car divide(n,2);
n2 := cdr divide(n,2);
if zerop n1 then return mk!*sq !*k2q
            if bool then invp u else u;
res := (1 . 1);
for k := 1 : n1 do <<
  if scalopp u then
     if bool then x := multf(!*k2f invp u, !*k2f invp u) . 1
     else x := multf(!*k2f u, !*k2f u) . 1
%    if bool then  x:= list(list((invp u . 1),((invp u . 1) . 1))) . 1
%    else x:= list(list((u . 1),((u . 1) . 1))) . 1
  else if vecopp u then
          if bool then x:= quotsq((1 . 1),physop2sq physopdot list(u,u))
          else  x:= physop2sq physopdot list(u,u)
  else if tensopp u then <<
          if bool then x:= quotsq((1 . 1),
                           physop2sq physoptens list(u,u))
          else  x:= physop2sq physoptens list(u,u) >>
       else  rederr2('exptexpand, "cannot raise a state to a power");
res := multsq(res,x)
>>;
b:
if zerop n2 then return mk!*sq res;
u:= if bool then invp u else u;
return mk!*sq multsq(res,!*k2q u)
end;


physopfn('quotient,'physopquotient);

symbolic  procedure physopquotient args;
 begin scalar lht, rht,y,lhtype,rhtype;
 lht := physopsim!*  car args;
 rht := physopsim!* cadr args;
 lhtype := getphystype car args;
 rhtype := getphystype cadr args;
 if rhtype memq '(vector state tensor) then
      rederr2('physopquotient, "invalid quotient")
 else if not rhtype then return
       mk!*sq quotsq(physop2sq lht,physop2sq rht);
   lhtype := physopp  lht;
   rht := physopaeval rht;
   rhtype := physopp  rht;
if rhtype then
   if not lhtype then  lht:= mk!*sq multsq(physop2sq lht,!*k2q invp rht)
   else lht:= physoptimes list(lht,invp rht)
else if car rht eq 'times and null deadindices rht then
           << rht := reverse cdr rht;
              rht := for each  x in rht collect
                     physopquotient list(1,x);
              lht := physoptimes append(list(lht),rht) >>
     else lht:= mk!*sq quotsq(physop2sq lht,physop2sq rht);
return lht
end;

put('quotient,'phystypefn,'getphystypeor);

physopfn('recip,'physoprecip);

symbolic procedure physoprecip args;
physopquotient list(1,args);

put('recip,'phystypefn,'getphystypecar);

symbolic procedure invphysop u;
% inverse of physops
begin scalar x,y;
if not physopp u then rederr2('invphysop,"invalid argument to INVERSE");
if u = 'unit then return u;
 y:= if idp u then u else car u;
x := reversip explode y;
x := intern compress nconc(reversip x,list('!!,'!-,'!1));
put(y,'inverse,x); % 1.01
put(x,'inverse,y); % 1.01
put(x,'physopname,y); % 1.02
if not physopp x then << put(x,'rtype,'physop);
                         put(x,'phystype,get(y,'phystype));
                         put(x,'psimpfn,'physopsimp);
                         put(x,'tensdimen,get(y,'tensdimen));
                         physoplist!* := nconc(physoplist!*,list(x));
                      >>;
if idp u then return x
else return nconc(list(x),cdr u)
end;

symbolic procedure invp u; % recoded 1.01
% special cases
if u = 'unit then u
else if atom u then get(u,'inverse)
else if member(car u,'(comm anticomm)) then
     list('quotient,1,u)
else get(car u,'inverse) . cdr u;

physopfn('sub,'physopsub); %subcommand;


% ********* redefinition of SUB handling is necessary in 3.4 **********
remprop('sub,'physopfunction);
put('sub,'physopfunction,'subeval);
put('physop,'subfn,'physopsub);

symbolic procedure physopsub(u,v); %redefined
% u is a list of substitutions  as an a--list
% v is a simplified physop  in prefix form
begin  scalar res;
if null u or null v then return v;
v := physopaeval v;
for each x in u do  v := subst(cdr x,car x,v);
return physopsm!* V
end;
% *********** end of 3.4 modifications ******************

symbolic procedure physopprog u;
% procedure to handle prog expressions (i.e. loops) containing physops
begin scalar x;
% we use basically the same trick as in physopsubs
% step 1: transform all physops on physoplist in normal ops
  for each x in physoplist!* do <>;
% step 2: call normal prog on u
   u := aeval ('prog . u);
% step 3: transform u back in an a.e.
  u := physopaeval u;
% step 4: transform ops in physoplist back to physops
  for each x in physoplist!* do <>;
% final step return u
  return physopsm!* u
end;

% ******   procedures for physopfns  ***********

physopfn('dot,'physopdot);
infix dot;
precedence dot,*;
symbolic procedure  physopdot args;
begin scalar lht,rht,lhtype,rhtype,x,n,res;
lht :=  physopaeval physopsim!*  car args;
rht := physopaeval physopsim!* cadr args;
lhtype := getphystype lht;
rhtype := getphystype rht;
if not( (lhtype and rhtype) and (lhtype eq 'vector) ) then
   rederr2 ('physopdot,"invalid arguments to dotproduct");
lhtype := physopp lht;
rhtype := physopp rht;
if rhtype then
  if lhtype then << if !*indflg then<<
                           lht := insertfreeindices(lht,nil);
                           rht := insertfreeindices(rht,nil);
                           indcnt!* := indcnt!* + 1; >>
                    else <>;
                    res := physoptimes list(lht,rht)>>
     else <<
  if car lht eq 'minus then
        res := mk!*sq negsq(physop2sq physopdot list(cadr lht,rht))
    else if car lht eq 'difference then res := mk!*sq addsq(
        physop2sq physopdot list(cadr lht,rht),negsq(physop2sq
                           physopdot list(caddr lht,rht)))
     else if car lht eq 'plus then <<
       x := for each y in cdr lht collect physopdot list(y,rht);
       res := reval3 append(list('plus),x)  >>
     else if car lht  eq 'quotient then <<
             if not vecopp cadr lht  then
               rederr2('physopdot,"argument to DOT")
              else res := mk!*sq quotsq(physop2sq
                physopdot list(cadr lht,rht),physop2sq caddr lht) >>
     else if car lht  eq 'times then <<
        for each y in cdr lht do
           if getphystype y  eq 'vector then x:=y;
        lht :=delete(x,cdr lht);
        res := physoptimes
        nconc(lht,list(physopdot list(x,rht))) >>
     else rederr2('physopdot, "invalid arguments to DOT") >>;
if not rhtype then <<
  if car rht eq 'minus then
        res := mk!*sq negsq(physop2sq physopdot list(lht,cadr rht))
    else if car rht eq 'difference then res := mk!*sq addsq(
        physop2sq physopdot list(lht,cadr rht),negsq(physop2sq
                           physopdot list(lht, caddr rht)))
     else if car rht eq 'plus then <<
       x := for each y in cdr rht collect physopdot list(lht,y);
       res := reval3 append(list('plus),x)  >>
     else if car rht  eq 'quotient then <<
             if not vecopp cadr rht  then
      rederr2 ('physopdot,"invalid argument to DOT")
              else res := mk!*sq quotsq(physop2sq physopdot
                    list(lht,cadr rht),physop2sq caddr rht)  >>
     else if car rht  eq 'times then <<
        for each y in cdr rht do if getphystype y  eq 'vector then x:=y;
        rht :=delete(x,cdr rht);
        res := physoptimes
               nconc(rht,list(physopdot list(lht,x))) >>
     else rederr2 ('physopdot,"invalid arguments to DOT") >>;
return res
end;

put('dot,'phystype,'scalar);

symbolic procedure  physoptens args;
% procedure for products of tensor expressions
begin scalar lht,rht,lhtype,rhtype,x,n,res;
lht :=  physopaeval physopsim!*  car args;
rht := physopaeval physopsim!* cadr args;
lhtype := getphystype lht;
rhtype := getphystype rht;
if not( (lhtype and rhtype) and (lhtype eq 'tensor) ) then
   rederr2 ('physoptens,"invalid arguments to tensproduct");
lhtype := physopp lht;
rhtype := physopp rht;
if rhtype then
  if lhtype then << n:= get(lht,'tensdimen);
                    if (n neq get(rht,'tensdimen)) then
                    rederr2('physoptens,
               "tensors must have the same dimension to be multiplied");
                    if !*indflg then<<
                           lht := insertfreeindices(lht,nil);
                           rht := insertfreeindices(rht,nil);
                           indcnt!* := indcnt!* + n;  >>
                    else <>;
                    res := physoptimes list(lht,rht)>>
     else <<
  if car lht eq 'minus then
        res := mk!*sq negsq(physop2sq physoptens list(cadr lht,rht))
    else if car lht eq 'difference then res := mk!*sq addsq(
        physop2sq physoptens list(cadr lht,rht),negsq(physop2sq
                           physoptens list(caddr lht,rht)))
     else if car lht eq 'plus then <<
       x := for each y in cdr lht collect physoptens list(y,rht);
       res := reval3 append(list('plus),x)  >>
     else if car lht  eq 'quotient then <<
             if not tensopp cadr lht  then
               rederr2 ('physoptens,"invalid argument to TENS")
              else res := mk!*sq quotsq(physop2sq
                physoptens list(cadr lht,rht),physop2sq caddr lht) >>
     else if car lht  eq 'times then <<
        for each y in cdr lht do
           if getphystype y  eq 'tensor then x:=y;
        lht :=delete(x,cdr lht);
        res := physoptimes
        nconc(lht,list(physoptens list(x,rht))) >>
     else rederr2('physoptens, "invalid arguments to TENS") >>;
if not rhtype then <<
  if car rht eq 'minus then
        res := mk!*sq negsq(physop2sq physoptens list(lht,cadr rht))
    else if car rht eq 'difference then res := mk!*sq addsq(
        physop2sq physoptens list(lht,cadr rht),negsq(physop2sq
                           physoptens list(lht, caddr rht)))
     else if car rht eq 'plus then <<
       x := for each y in cdr rht collect physoptens list(lht,y);
       res := reval3 append(list('plus),x)  >>
     else if car rht  eq 'quotient then <<
             if not tensopp cadr rht  then
      rederr2 ('physoptens,"invalid argument to TENS")
              else res := mk!*sq quotsq(physop2sq physoptens
                    list(lht,cadr rht),physop2sq caddr rht)  >>
     else if car rht  eq 'times then <<
        for each y in cdr rht do if getphystype y  eq 'tensor then x:=y;
        rht :=delete(x,cdr rht);
        res := physoptimes
               nconc(rht,list(physoptens list(lht,x))) >>
     else rederr2('physoptens, "invalid arguments to TENS") >>;
return res
end;

put('tens,'phystype,'scalar);


% -------- procedures for commutator handling -------------

symbolic procedure comm2(u,v);
% general procedure for getting commutators
begin scalar x,utype,vtype,y,z,z1,res;
if not (physopp u and physopp v) then rederr2('comm2,
                       "invalid arguments to COMM");
utype := getphystype u;
vtype := getphystype v;
if not (utype eq 'scalar) and (vtype eq 'scalar) then
rederr2('comm2, "comm2 can only handle scalar operators");
!*anticommchk:= nil;
if not noncommuting(u,v) then return
  if !*anticom then mk!*sq !*f2q multf(!*n2f 2,multfnc(!*k2f v,!*k2f u))
  else mk!*sq (nil . 1);
x := list(u,v);
z := opmtch!* ('comm . x);
if  null z then z:= if (y:= opmtch!* ('comm . reverse x)) then
                        physopsim!* list('minus,y)
                    else nil;
if z and null !*anticom then res:=  physopsim!* z
else << z1 := opmtch!* ('anticomm . x);
        if null z1 then
        z1 :=  if (y:=opmtch!* ('anticomm . reverse x)) then y
               else nil;
        if z1 then << !*anticommchk := T;
                      res:=  physopsim!* z1>>
     >>;
if null res then
   << !*hardstop:= T;
      if null !*anticom then res := mk!*sq !*k2q ('comm . x)
      else << !*anticommchk := T;
              res := mk!*sq !*k2q ('anticomm . x) >>
>>;
return res
end;

physopfn('commute,'physopcommute);

symbolic procedure physopcommute args;
begin scalar lht,rht,lhtype,rhtype,x,n,res,flg;
lht :=  physopaeval  physopsim!*  car args;
rht := physopaeval  physopsim!* cadr args;
lhtype := getphystype lht;
rhtype := getphystype rht;
if not (lhtype and rhtype) then return mk!*sq !*d2q 0
else if not(rhtype = lhtype) then
  rederr2('physopcommute,
   "physops of different types cannot be commuted")
else if not(lhtype eq 'scalar) then
 rederr2 ('physopcommute,
 "commutators only implemented for scalar physop expressions");
% flg := !*anticom; !*anticom := nil;
lhtype := physopp lht;
rhtype := physopp rht;
% write "lht= ",lht," rht= ",rht;terpri();
if rhtype then
   if lhtype then << res := comm2(lht,rht);
                     if !*anticommchk then
                         res := physopdiff list(res,
                                physoptimes list(2,rht,lht)); >>
   else res := mk!*sq negsq(physop2sq physopcommute list(rht,lht))
else <<
if car rht eq 'minus then res:= mk!*sq negsq(physop2sq
    physopcommute list(lht, cadr rht));
if car rht eq 'difference then  res := mk!*sq addsq(
     physop2sq physopcommute list(lht,cadr rht),negsq(physop2sq
            physopcommute list(lht,caddr rht)));
if car rht  eq 'plus then <<
                  x:= for each y in cdr rht collect
                      physopcommute list(lht,y);
                  res:= reval3 append(list('plus),x) >>;
if car rht memq '(expt dot commute) then
               res := physopcommute list(lht,physopsim!* rht);
if car rht eq 'quotient then
   if physopp caddr rht then
       res:= physopcommute list(lht,physopsim!* rht)
    else
   res := mk!*sq quotsq(physop2sq physopcommute list(lht,cadr rht),
          physop2sq caddr rht);
if car rht eq 'times then <<
   n := length cdr rht;
   if (n = 2) then res := reval3 list('plus, physopsim!*
        list('times,cadr rht,physopcommute list(lht, caddr rht)),
  physopsim!* list('times,physopcommute list(lht, cadr rht),caddr rht))
   else res := reval3 list('plus, physopsim!*
        list('times,cadr rht,physopcommute list(lht,
           append('(times),cddr rht))), physopsim!* append(
          list('times,physopcommute list(lht, cadr rht)), cddr rht)) >>
     >>;
% !*anticom := flg;
return res
end;

put('commute,'phystype,'scalar);

physopfn('anticommute,'physopanticommute);

symbolic procedure physopanticommute args;
begin scalar lht,rht,lhtype,rhtype,x,n,res,flg;
lht :=  physopaeval  physopsim!*  car args;
rht := physopaeval  physopsim!* cadr args;
lhtype := getphystype lht;
rhtype := getphystype rht;
if not (lhtype and rhtype) then
     return mk!*sq aeval list('plus,list('times,lht,rht),
                               list('times,rht,lht))
else if not(rhtype = lhtype) then
  rederr2('physopanticommute,
   "physops of different types cannot be commuted")
else if not(lhtype eq 'scalar) then
 rederr2 ('physopanticommute,
 "commutators only implemented for scalar physop expressions");
% flg := !*anticom;!*anticom :=t;
lhtype := physopp lht;
rhtype := physopp rht;
% write "lht= ",lht," rht= ",rht;terpri();
if rhtype then
   if lhtype then
   <<
      x := comm2(lht,rht);
      if null !*anticommchk then
         If !*hardstop then res := mk!*sq !*k2q list('anticomm,lht,rht)
         else res := reval3 list('plus,x,physoptimes list(2,rht,lht))
      else res := x;
   >>
   else res := physopsim!* physopanticommute list(rht,lht)
else <<
if car rht eq 'minus then res:= mk!*sq negsq(physop2sq
    physopanticommute list(lht, cadr rht));
if car rht eq 'difference then mk!*sq addsq(physop2sq
     physopanticommute list(lht,cadr rht),negsq(physop2sq
     physopanticommute list(lht,caddr rht)));
if car rht  eq 'plus then <<
                  x:= for each y in cdr rht collect
                      physopanticommute list(lht,y);
                  res:= reval3 append(list('plus),x) >>
else res := physopplus list(physoptimes list(lht,rht),
                             physoptimes list(rht,lht));
     >>;
% !*anticom := flg;
return res
end;

put('anticommute,'phystype,'scalar);

symbolic procedure commsimp u;
% procedure to simplify the arguments of COMM or ANTICOMM
% if they are not simple physops
begin scalar opname,x,y,flg,res;
opname := car u;
x := physopsim!* cadr u;
y := physopsim!* caddr u;
% write "op= ",opname," x= ",x," y= ",y;terpri();
flg := !*anticom;
if opname = 'anticomm then !*anticom := t;
res := if physopp x and physopp y then physopaeval comm2(x,y)
       else if opname eq 'comm then list('commute,physopaeval x,
                                            physopaeval y)
            else list('anticommute,physopaeval x,physopaeval y);
!*anticom := flg;
return res
end;

% -------------- application of ops on states ----------------


physopfn('opapply,'physopapply);

infix opapply;
precedence opapply,-;

symbolic procedure physopapply args; % changed 0.99b
begin scalar lhtype,rhtype,wave,op,wavefct,res,x,y,flg;
lhtype := statep!* car args;
rhtype := statep!* cadr args;
if rhtype  and lhtype  then
   return statemult(car args,cadr args)
else if rhtype then
         <>
else if lhtype then
        <>
% a previous application of physopapply may have annihilated the
% state
else  if zerop car args or zerop cadr args then return mk!*sq (nil . 1)
else rederr2('opapply, "invalid arguments to opapply");
if null getphystype op then
     res:= mk!*sq multsq(physop2sq op,physop2sq wave)
else if not physopp op then
        if car op eq 'minus then
          res := mk!*sq negsq(physop2sq physopapply list(cadr op,wave))
        else if car op memq '(plus difference) then <<
               for each y in cdr op do <<
                  res:= nconc(res,list(physopapply list(y,wave)));
                  if !*hardstop then flg:= t;
                  !*hardstop := nil;>>;
               if flg then !*hardstop := t;
               res := reval3 ((car op) . res)  >>
        else if car op memq '(dot commute anticommute expt) then
                   res := physopapply list(physopsim!* op,wave)
        else if car op eq 'quotient then
                if physopp caddr op then
                    res := physopapply list(physopsim!* op,wave)
                else res := mk!*sq quotsq(physop2sq
                   physopapply list(cadr op,wave),physop2sq caddr op)
        else if car op eq 'times then
               <>;
                       if !*hardstop then
                          if null op then res := wave
                          else << x:= physopaeval wave;
                                  op := 'times . reverse op;
                                  while x do
                                    << y := car x; x := cdr x;
                                       if listp y and
                                       (y := assoc('opapply,y)) then
                                         << wavefct := list('opapply,
                                             nconc(op,list(cadr y)),
                                               caddr y);
                                        wave := subst(wavefct,y,wave);
                                         >>;
                                    >>;
                                  res := wave;
                               >>
                       else res := wave;
                >>
             else rederr2('opapply, "invalid operator to opapply")
% special hack here for unit operator  0.99c
else if op = 'unit then res := mk!*sq physop2sq wave
else if physopp wave or
        (flagp(car wave,'physopmapping) and statep!* cdr wave) then
             <>
               else  res := mk!*sq physop2sq x;
             >>
     else << x := wave; wave := nil;
             while x do <<
                 wavefct := car x; x := cdr x;
                 if statep!*  wavefct then wave := nconc(wave,
                     list(physopaeval physopapply list(op,wavefct)))
                 else wave := nconc(wave,list(wavefct));
                 if !*hardstop then flg := t;
                  !*hardstop := nil >>;
             if flg then !*hardstop := t;
             res := mk!*sq physop2sq wave;
          >>;
return res
end;

put('opapply,'phystypefn,'getphystypestate);

symbolic procedure getphystypestate  args;
if statep!* car args and statep!* cadr args then nil
else 'state;

symbolic procedure statemult(u,v); % recoded 0.99c
% u and v are states
% returns product of these
begin scalar x,y,res,flg;
if not (statep!* u or statep!* v) then
      rederr2 ('statemult,"invalid args to statemult");
if (not atom u and car v eq 'opapply) then
             return expectval(u,cadr v,caddr v);
if (not atom u and car u eq 'opapply) then
        return expectval(cadr u,caddr u,v);
u := physopaeval physopsim!* u;
v := physopaeval physopsim!* v;
if physopp u then
   if physopp v then
   <<
      x := opmtch!* list('opapply,u,v);
      if x then  res := physop2sq aeval x
      else
      <<
         x:= opmtch!* list('opapply,v,u);
         if null x then
         <<
             !*hardstop := t;
             res:= !*k2q list('opapply,u,v)
         >>
         else  res := physop2sq aeval compconj x
      >>;
     >>
   else
   <<
       x := deletemult!* !*collectphysops v;
       for each y in x do
       <<
          v := subst(physopaeval statemult(u,y),y,v);
          if !*hardstop then flg := t;
          !*hardstop := nil;
       >>;
       if flg then !*hardstop := t;
       res := physop2sq v;
   >>
else
<<
    x := deletemult!* !*collectphysops u;
    for each y in x do
    <<
        u := subst(physopaeval statemult(y,v),y,u);
        if !*hardstop then flg := t;
        !*hardstop := nil;
    >>;
    if flg then !*hardstop := t;
    res := physop2sq u;
>>;
return mk!*sq res
end;

symbolic procedure expectval(u,op,v);
% u and v are states
% calculates the expectation value < u ! op ! v >
% tries to apply op first on v, then on u
% PHYSOPAPPLY is used rather than STATEMULT to multiply
% resulting states together because of more general definition
begin scalar x,y,z,flg,res;
op := physopaeval physopsim!* op;
if null getphystype op then
   return mk!*sq multsq(physop2sq op,physop2sq physopapply list(u,v));
if physopp op then
   <>
     else res:= physopapply list(u,x)
   >>
else if car op eq 'minus then
      res := mk!*sq negsq(physop2sq expectval(u,cadr op,v))
else if car op eq 'quotient then
      if physopp caddr op then res := expectval(u,physopsm!* op,v)
      else res := mk!*sq quotsq(physop2sq expectval(u,cadr op,v),
      physop2sq caddr op)
else if car op memq '(dot commute anticommute expt) then
        res := expectval (u,physopsm!* op,v)
else if car op memq '(plus difference) then
   << for each y in cdr op do
          << x:=nconc(x,list(expectval(u,y,v)));
             if !*hardstop then flg:= !*hardstop ;
             !*hardstop := nil >>;
      if flg then !*hardstop := t;
      res :=  reval3 ((car op) . x);
   >>
else if car op eq 'times then
   << x := physopapply list(op,v);
      if not !*hardstop then return physopapply list(u,x);
      x := cdr op;
      while (x and !*hardstop and not flg) do
      << y:=car x; x := cdr x;
         if not getphystype y then << v:= physopapply list(y,v);
                                       y := v;>>
         else << !*hardstop := nil;
                 z:= physopapply list(u,y);
                 if !*hardstop then
                    << flg := T; x := y . x;
                       y := if null cdr x then list('opapply,car x,
                               physopaeval v)
                            else list('opapply,('times . x),
                               physopaeval v); >>
                 else << u:= z;
                         y:= if null x then v
                             else if null cdr x then
                         physopapply list(car x, physopaeval v)
                                  else physopapply
                           list(('times . x),physopaeval v) >>
              >>
      >>;
     res := if !*hardstop then mk!*sq !*k2q list('opapply,
                 physopaeval u,physopaeval y)
            else physopapply list(u,y);
   >>
else rederr2('expectval, "invalid args to expectval");
return res
end;


symbolic procedure compconj u;
% dirty and trivial implementation of
% complex conjugation of everything (hopefully);
% not yet tested for arrays
begin scalar x;
   if null u or numberp u then return u
   else if idp u and (x:=get(u,'rvalue)) then <<
   x:=subst(list('minus,'I),'I,x);
   put(u,'rvalue,x); return u >>
   else return subst(list('minus,'I),'I,u)
end;

 % --------------  adjoint of operators ---------------------
physopfn('adj, 'physopadj);

symbolic procedure  physopadj arg;
begin scalar rht,rhtype,x,n,res;
rht :=  physopaeval physopsim!* car arg;
rhtype := physopp rht;
if rhtype then return mk!*sq !*k2q physopsm!* adjp rht
else <<
  if not getphystype rht then res := aeval compconj rht
  else if car rht eq 'minus then
        res := mk!*sq negsq(physop2sq physopadj list(cadr rht))
  else if car rht eq 'difference then res := mk!*sq addsq(
        physop2sq physopadj list(cadr rht),negsq(physop2sq
                           physopadj list(caddr rht)))
  else if car rht eq 'plus then <<
     x := for each y in cdr rht collect physopadj list(y);
     res := reval3 ('plus . x)  >>
  else if car rht  eq 'quotient then <<
       if not getphystype cadr rht then
          rederr2('physopadj, "invalid argument to ADJ")
       else res := mk!*sq quotsq(physop2sq
            physopadj list(cadr rht),physop2sq caddr rht)  >>
  else if car rht  eq 'times  then <<
      x:= for each y in cdr rht collect physopadj list(y);
      res := physoptimes reverse x >>
  else if flagp(car rht,'physopmapping) then
       res := mk!*sq !*k2q list(car rht, physopaeval physopadj cdr rht)
  else  res :=physopadj list(physopsim!* rht) >>;
return res
end;

Put('adj,'phystypefn,'getphystypecar);

symbolic procedure adj2 u;
begin scalar x,y;
if not physopp u then rederr2('adj2, "invalid argument to adj2");
if u = 'unit then return u;
y:= if idp u then u else car u;
x := reverse explode y;
x := intern compress nconc(reverse x,list('!!,'!+));
put(y,'adjoint,x); %1.01
put(x,'adjoint,y); %1.01
put(x,'physopname,x); % 1.02
if not physopp x then << put(x,'rtype,'physop);
                         put(x,'phystype,get(y,'phystype));
                         put(x,'psimpfn,'physopsimp);
                         put(x,'tensdimen,get(y,'tensdimen));
              defoporder!* := nconc(defoporder!*,list(x));
              oporder!* := nconc(oporder!*,list(x));
              physoplist!* := nconc(physoplist!*,list(x));
                       >>;
if idp u then return x
else return x . cdr u
end;

symbolic procedure invadj u;  %new 1.01
% create the inverse adjoint op
begin scalar x,y;
if not physopp u then rederr2('invadj, "invalid argument to invadj");
if u = 'unit then return u;
y:= if idp u then u else car u;
x := reverse explode y;
x := intern compress nconc(reverse x,list('!!,'!+,'!!,'!-,'!1));
put(x,'adjoint,get(y,'inverse));
put(x,'inverse,get(y,'adjoint));
put(get(y,'inverse),'adjoint,x);
put(get(y,'adjoint),'inverse,x);
put(x,'physopname,get(y,'adjoint)); % 1.02
if not physopp x then << put(x,'rtype,'physop);
                         put(x,'phystype,get(y,'phystype));
                         put(x,'psimpfn,'physopsimp);
                         put(x,'tensdimen,get(y,'tensdimen));
              physoplist!* := nconc(physoplist!*,list(x));
                       >>;
if idp u then return x
else return x . cdr u
end;

symbolic procedure adjp u;  %recoded 1.01
% special cases
if u = 'unit then  u
else if atom u then get(u,'adjoint)
else if (car u = 'comm) then
       list('comm,adjp caddr u,adjp cadr u)
else if (car u = 'anticomm) then
     list('anticomm,adjp cadr u,adjp caddr u)
else get(car u,'adjoint) . cdr u;

% --- end of arithmetic routines ---------------------

% ---- procedure for handling let assignements ------

symbolic procedure physoptypelet(u,v,ltype,b,rtype);
% modified version of original typelet
% General function for setting up rules for PHYSOP expressions.
% LTYPE is the type of the left hand side U, RTYPE, that of RHS V.
% B is a flag that is true if this is an update, nil for a removal.
% updated 101290 mw
%do not check physop type in prog exprs on the rhs
begin scalar x,y,n,u1,v1,z,contract;
 if not physopp u and getphystype u then goto c; % physop expr
 u1 := if atom u then u else car u;
 if ltype then
          if rtype = ltype then go to a
          ELSE IF NULL B OR ZEROP V OR (LISTP V AND ((CAR V = 'PROG)
                                           OR (CAR V = 'COND))) %1.01
                  or ((not atom u) and (car u = 'opapply)) then
                      return physopset(u,v,b)
               else rederr2('physoptypelet,
                     list("physop type mismatch in assignement ",
                               u," := ",v))
 else if null (x:= getphystype v) then return physopset(u,v,b)
 else << if x = 'scalar then scalop u1;
         if x = 'vector then vecop u1;
         if x = 'state then state u1;
         if x = 'tensor then tensop list(u1,get(v,'tensdimen));
         ltype := rtype >>;
A: if b and (not atom u or flagp(u,'used!*)) then rmsubs();
% perform the assignement
   physopset(u,v,b);
% phystype checking added 1.01
   if b and (getphystype u neq getphystype v) then
               rederr2('physoptypelet,
                     list("physop type mismatch in assignement ",
                               u," <=> ",v));
% special hack for commutators here
      if (not atom u) and (car u = 'comm) then
       physopset(list('comm,adjp caddr u,adjp cadr u),list('adj,v),b);
      if (not atom u) and (car u = 'anticomm) then
       physopset(list(car u,adjp cadr u,adjp caddr u),list('adj,v),b);
   if null (x := getphystype u)  or (x = 'state) or (x = 'scalar)
           then return;
% we have here to add additional scalar let rules for vector
% and tensor operators with arbitrary indices
   u1:=u;v1:=v;
   if (x eq 'vector)  or (x eq 'tensor) then
           << x := collectphysops u;
              for each z in x do
                u1:= subst(insertfreeindices(z,nil),z,u1);
              x := collectphysops v;
              for each z in x do
                  v1:= subst(insertfreeindices(z,nil),z,v1) >>;
   physoptypelet(u1,v1,ltype,b,rtype);
   return;
C:
% this is for more complicated let rules involving more than
% one term on the lhs
% special hack here to handle let rules involving elementary
% OPAPPLY relations
   if car u = 'opapply then  return physopset(u,v,b);
% step 1: do all physop simplifications on lhs
%  we set indflg!* for dot product simplifications on the lhs
   !*indflg:= T; indcnt!* := 0;
   contract := !*contract2; !*contract2 := T;
   u := physopsm!* u;
   !*indflg := nil; indcnt!* := 0; !*contract2 := contract;
% check correct phystype
   x := getphystype u;
   y := getphystype v;
   if b and ((not (y or zerop v)) or (y and (x neq y))) then
              rederr2 ('physoptypelet,"phystype mismatch in LET");
% step 2 : transform back in ae
   u := physopaeval u;
%  write "u= ",u; terpri();
% ab hier neu
% step3 : do some modifications in case of a sum or difference on the lh
   if car u = 'PLUS then
   <<
      u1 := cddr u;
      u := cadr u;
      v := list('plus,v);
      for each x in u1 do
      <<
         x := list('minus,x);
         v := append(v,list(x));
      >>;
   >>;
   if car u = 'DIFFERENCE then
   <<
       u1:= cddr u;
       u:= cadr u;
       v := append(list('plus,v),list(u1));
   >>;
   if car U = 'MINUS then
   <<
       u := cadr u;
       v := list('minus,v);
   >>;
% step 4: add the rule to the corresponding list
% expression may still contain quotients and expt
   if car u ='EXPT then
   <<
       u := cadr u . caddr u;
       powlis1!* :=  xadd!*(u .
                            list(nil . (if mcond!* then mcond!* else t),
                                  v,nil), powlis1!*,b)
   >>
   else if car u = 'quotient then
   <<
       v:= list('times,v,caddr u);
       physoptypelet(cadr u,v,ltype,b,rtype);
   >>
   else   % car u = times
   <<
       u1 := nil;
       for each x in cdr u do
       <<
           if car x= 'expt then
              u1 := append(u1,list(cadr x . caddr x))
           else if car x = 'quotient then
           <<
              v:= list('times,v,caddr x);
              u1 := append(u1,
                           list(if cadr x = 'expt then
                                   (caddr x . cadddr x)
                                else (cadr x . 1)));
           >>
           else u1 := append(u1,list(x . 1));
       >>;
       !*match := xadd!*(u1 . list(nil .
                                   (if mcond!* then mcond!* else t),
                                 v,nil), !*match,b);
   >>;
   return;
   end;

symbolic procedure physopset(u,v,b);
% assignement procedure for physops
% special hack for assignement of unresolved physop expressions
begin
   if not atom u  then put(car u,'opmtch,xadd!*(cdr u .
                        list(nil . (if mcond!* then mcond!* else t),
                         v,nil), get(car u,'opmtch),b))
   else if b then
           if physopp u then put(u,'rvalue,physopsim!* v)
           else put(u,'avalue,list('scalar,
                    list('!*sq,cadr physopsim!* v,not !*hardstop)))
        else if not member(u,specoplist!*) then
                << remprop(u,'rvalue);
                   remprop(u,'opmtch);
                  >>;
   !*hardstop := nil;
end;

  symbolic procedure clearphysop u;
% to remove physop type from an id
  begin scalar y;
 for each x in u do <<
   if not (physopp x and idp x) then rederr2('clearphysop,
             list("invalid argument ",x," to CLEARPHYSOP"));
   y := invp x;
   remprop(y,'rtype);
   remprop(y,'tensdimen);
   remprop(y,'phystype);
   remprop(y,'psimpfn);
   remprop(y,'inverse); %1.01
   remprop(y,'adjoint);  %1.01
   remprop(y,'rvalue);  % 1.01
   oporder!* := delete(y,oporder!*);
   defoporder!* := delete(y,defoporder!*);
   physoplist!* := delete(y,physoplist!*);
   y:= adjp x;
   remprop(y,'rtype);
   remprop(y,'tensdimen);
   remprop(y,'phystype);
   remprop(y,'psimpfn);
   remprop(y,'inverse); %1.01
   remprop(y,'adjoint);  %1.01
   remprop(y,'rvalue);  % 1.01
   oporder!* := delete(y,oporder!*);
   defoporder!* := delete(y,defoporder!*);
   physoplist!* := delete(y,physoplist!*);
  remprop(x,'rtype);
  remprop(x,'tensdimen);
  remprop(x,'phystype);
  remprop(x,'psimpfn);
   remprop(x,'inverse); %1.01
   remprop(x,'adjoint);  %1.01
   remprop(x,'rvalue);  % 1.01
  oporder!* := delete(x,oporder!*);
  defoporder!* := delete(x,defoporder!*);
  physoplist!* := delete(x,physoplist!*);
   >>;
return nil
end;

 Rlistat '(clearphysop);

%------ procedures for printing out physops correctly ---------

% we modify the standard MAPRINT routine to get control
% over the printing of PHYSOPs


%**** This section had to be modified for 3.4  **********************
symbolic procedure physoppri u; % modified 3.4
begin scalar x,y,z,x1;
x :=  if idp u then u else car u;
y := if idp u then nil else cdr u;
trwrite(physoppri,"x= ",x," y= ",y,"nat= ",!*nat," contract= ",
        !*contract);
if !*nat and not !*contract then go to a;
% transform the physop name in a string in order not to loose the
% special characters
x:= compress append('!" . explode x,list('!"));
 prin2!* x;
 if y then << prin2!* "(";
              obrkp!* := nil;
              inprint('!*comma!*,0,y);
              obrkp!* := t;
              prin2!* ")"  >>;
 return u;
a:
x := reverse explode x;
if length(x) > 2 then
   if cadr x = '!- then <>
   else if car x = '!+ then << z:='!+;
                               x:= compress reverse pnth(x,3); >>
        else x := compress reverse x
else x := compress reverse x;
x:= compress append('!" . explode x,list('!"));
x1 := if y then  x . y else x;
trwrite(physoppri,"x= ",x," z= ",z," x1= ",x1);
% if z then exptpri(get('expt,'infix),list(x1,z))
% the following is 3.4
if z then  exptpri(list('expt,x1,z),get('expt,'infix))
else << prin2!* x;
        if y then << prin2!* "(";
                     obrkp!* := nil;
                     inprint('!*comma!*,0,y);
                     obrkp!* := t;
                     prin2!* ")"  >>
     >>;
return u
end;



symbolic procedure maprint(l,p!*!*); %3.4 version
   begin scalar p,x,y;
        p := p!*!*;     % p!*!* needed for (expt a (quotient ...)) case.
        if null l then return nil
         else if physopp l then return apply1('physoppri,l)
         else if atom l
          then <>;
                 return l >>
         else if stringp l then return prin2!* l
         else if not atom car l then maprint(car l,p)
         else if ((x := get(car l,'pprifn)) and
                   not(apply2(x,l,p) eq 'failed)) or
                 ((x := get(car l,'prifn)) and
                   not(apply1(x,l) eq 'failed))
          then return l
         else if x := get(car l,'infix) then <<
           p := not(x>p);
           if p then <<
             y := orig!*;
             prin2!* "(";
             orig!* := if posn!*<18 then posn!* else orig!*+3 >>;
% (expt a b) was dealt with using a pprifn sometime earlier than this
           inprint(car l,x,cdr l);
           if p then <<
              prin2!* ")";
              orig!* := y >>;
           return l >>
         else prin2!* car l;
        prin2!* "(";
        obrkp!* := nil;
        y := orig!*;
        orig!* := if posn!*<18 then posn!* else orig!*+3;
        if cdr l then inprint('!*comma!*,0,cdr l);
        obrkp!* := t;
        orig!* := y;
        prin2!* ")";
        return l
    end;

%  ******* end of 3.4 modifications  ********************
% ------- end of module printout  -------------------------

% ------------- some default declarations -------------------
% this list contains operators which when appearing in expressions
% have unknown properties  (unresolved expressions)
specoplist!* := list('dot,'comm,'anticomm,'opapply);
% unit,comm and anticomm operators
put('comm,'rtype,'physop);
put('comm,'phystype,'scalar);
put('comm,'psimpfn,'commsimp);
put('anticomm,'rtype,'physop);
put('anticomm,'phystype,'scalar);
put('anticomm,'psimpfn,'commsimp);
physoplist!* := list('comm,'anticomm);
scalop 'unit;
flag ('(unit comm anticomm opapply),'reserved);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/0000755000175000017500000000000011722677357022203 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/basis.red0000644000175000017500000001227211526203062023760 0ustar  giovannigiovanni%----------------------------------------------------------------
%       File:           basis.red
%       Purpose:        Build the triangle form of basis
%       Copyright:      (C) 1990-1996, A.Kryukov, kryukov@theory.npi.msu.su
%       Version:        2.21    Mar. 25, 1996
%----------------------------------------------------------------
%       Revision:       27/11/90        insertv
%                       26/11/90        SieveV
%                       05/03/91        AppS
%                       Nov. 12, 1993     updatev
%                       Mar. 25, 1996   sieved_pv0, reduce_pv0
%----------------------------------------------------------------

lisp <<
  if null getd 'mkunitp then in "perm.red"$
  if null getd 'pv_add then in "pvector.red"$
>>$

module basis$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%===================================
% basis ::= (v1 v2 ...)
%===================================
global '(!*basis)$

procedure sieve_pv(v,b)$
  sieve_pv0(v,b,t)$

procedure sieve_pv0(v,b,norm)$
  %---------------------------
  % v - vector.
  % b - basis.
  % norm=t -> normalized vector
  % return sieved vector.
  %---------------------------
  if null v then nil
  else <<
    while b and cdaar b > cdar v do b:=cdr b$
    while v and b do <<          % reduce v.
      v:=reduce_pv0(v,car b,norm)$
      b:=cdr b$
    >>$
    v
  >>$

procedure reduce_pv(v,q)$
  reduce_pv0(v,q,t)$

global '(pv_den)$

procedure reduce_pv0(v,q,norm)$
  %---------------------------
  % v is reduced by q.
  % norm=t -> normalized vector
  % return reduced v.
  %---------------------------
  if null q then v
  else if null v then nil
  else begin scalar w,k$
      w:=v$
      while w and q and (cdar w > cdar q)
         do w := cdr w$  % find needed component.
      if w and q and (cdar q = cdar w) then <<
        k:=lcm(caar w,caar q)$                % Least Common Multiplier.
        v:=pv_add(pv_multc(v,k/caar w),pv_multc(q,-k/caar q))$
%        if v then v:=pv_renorm v$
        if null norm then pv_den:=pv_den*k/caar w       % +AK 26/03/96
        else pv_den:=1$                                 % +AK 28/03/96
      >>$
      return v$
 end$

%------------------- Insert new vector ----------------

symbolic procedure insert_pv(pv,bl)$
  % pv - pvector
  % bl - original basis list
  % (r.v.) - new basis list
  (if null x then bl
   else insert_pv1(pv_renorm x,bl,nil)
  ) where x=sieve_pv(pv,bl)$

symbolic procedure insert_pv1(pv,bl,bl1)$
  % pv - pvector
  % bl,bl1(r.v.) - basis list
  if null bl then if null pv then reversip bl1
                  else reversip(pv . bl1)
  else if null pv then insert_pv1(nil,cdr bl,car bl . bl1)
  else if cdaar bl > cdar pv
    then insert_pv1(pv,cdr bl,pv_renorm reduce_pv(car bl,pv) . bl1)
  else insert_pv1(nil,bl,pv . bl1)$


procedure insert_pv_(v,b)$
  % v - vector.
  % b - basis (midified.).
  % return updatev basis.
  if null v then b
  else if null b then list v
  % bug: if .. then ..  if .. then .. else ..
  else begin scalar b1,w$
    v:=pv_renorm sieve_pv(v,b);
    if null v then return b$
    b1:=b$
    while cdr b1 and cdaar b1 > cdar v do <<          % reduce car b1.
      rplacA(b1,pv_renorm reduce_pv(car b1,v))$
      b1:=cdr b1$
    >>$
    if cdaar b1 > cdar v then <<
      rplacA(b1,pv_renorm reduce_pv(car b1,v))$
      rplacD(b1,v . cdr b1)$                             % insert after.
    >> else <<                                                    % insert before.
      w:=car b1 . cdr b1;
      rplacD(rplacA(b1,v),w)$
    >>$
    return b$
 end$

remprop('basis,'stat)$

symbolic procedure update_pv(v,b)$
  % v - vector (modified)$
  % b - basis (modified)$
  % return updatevd vector v.
  if null v then nil
  else begin scalar r,w$
    if null(car b eq '!*basis)
      then rederr list('updatev,": 2-nd arg. is not a basis.")$
    r:=v$
    while v do <<
      w:=member(cdar v,cdr b)$
      if w then rplacD(car v,car w)
      else rplacD(b,cdar v . cdr b)$
      v:=cdr v$
    >>$
    return r$
  end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/pvector.red0000644000175000017500000001750011526203062024340 0ustar  giovannigiovanni%===============================================================
%       File:           pvector.red
%       Purpose:        Vector arithmetic.
%       Version:        3.01    Nov. 14, 1993
%---------------------------------------------------------------
%       Revision        26/11/90        PermGT
%                       05/03/91        UpDate
%                       Nov. 01, 1993     General revisions.
%                       Nov. 14, 1993     Domain introduction
%===============================================================

lisp <<
  if null getd 'mkunitp then in "perm.red"$
>>$


module pvector$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%       p-vector is a list of b-vectors.
%       b-vector is a  . .
%       coeff - integer.

%---------------------- Main procedures -------------------

symbolic procedure pv_simp v$
  (('!:pv . list(1 . car v)) ./ 1)$

put('pv,'simpfn,'pv_simp)$

global '(domainlist!*)$

switch pvector$

domainlist!*:=union('(!:pv),domainlist!*)$
put('pvector,'tag,'!:pv)$
put('!:pv,'dname,'pvector)$
%flag('(!:pv),'field)$          % !:pv is not a field!
put('!:pv,'minus,'pv_minus)$
put('!:pv,'minusp,'pv_minusp)$
put('!:pv,'plus,'pv_plus)$
put('!:pv,'times,'pv_times)$    % v*c
put('!:pv,'difference,'pv_difference)$
put('!:pv,'zerop,'pv_zerop)$
put('!:pv,'onep,'pv_onep)$
put('!:pv,'prepfn,'pv_prep)$
put('!:pv,'prifn,'pv_pri)$
put('!:pv,'intequivfn,'pv_intequiv)$
put('!:pv,'i2d,'i2pvector)$
put('!:pv,'expt,'pv_expt)$
put('!:pv,'quotient,'pv_quotient)$
put('!:pv,'divide,'pv_divide)$
put('!:pv,'gcd,'pv_gcd)$

flag('(!:pv),'pvmode)$

symbolic procedure pv_minus u$
  car u . pv_neg cdr u$

symbolic procedure pv_minusp u$ nil$

symbolic procedure pv_plus(u,v)$
%  if abs(cdadr u - cdadr v)>100       % incorrect test!
%    then rederr list('pv_plus,"*** Differ order of permutations:",u,v)
%  else
   if atom cdr u and atom cdr v then car u . (cdr u + cdr v)
   else if atom cdr u
    then rederr list('pv_plus,"*** pvector can't be added to:",cdr u)
   else if atom cdr v then pv_plus(v,u)
   else car u . pv_add(cdr u,cdr v)$

symbolic procedure pv_times(u,v)$
  % u,v - (!:pv . pvlist)
  if pv_intequiv u then pv_times(v,u)
  else if atom cdr v then car u . pv_multc(cdr u,cdr v)
  else car u . pv_times1(cdr u,cdr v,nil)$
%  else rederr {'pv_times,"*** pvector can't be multiplied by: ",cdr v}$

symbolic procedure pv_times1(u,v,w)$
  % u,v,w - pvlist::=((c1 . p1) ...)
  if null u then w
  else pv_times1(cdr u,v,pv_times2(car u,v,w))$

symbolic procedure pv_times2(x,v,w)$
  % x - (c . p)
  % v,w - pvlist::=((c1 . p1) ...)
  if null v then w
  else pv_times2(x,cdr v
                ,pv_add(list pv_times3(x,car v),w)
                )$

symbolic procedure pv_times3(x,y)$
  % x,y - (c . p)
  (car x * car y) . pappend(cdr x,cdr y)$

symbolic procedure pv_difference(u,v)$
  pv_plus(u,pv_minus v)$

symbolic procedure pv_zerop(u)$
  null cdr u$

symbolic procedure pv_onep u$ nil$

symbolic procedure pv_prep u$ u$

symbolic procedure pv_pri(u)$
  begin scalar notfirst$
    for each x in cdr u do <<
      if notfirst and car x > 0 then prin2!* " + "
      else notfirst:=t$
      if null(car x = 1) then << prin2!* car x$ prin2!* "*" >>$
      prin2!* 'pv$ prin2!* '!($ prin2!* cdr x$ prin2!* '!)$
    >>$
  end$

symbolic procedure pv_intequiv u$
  if atom cdr u then cdr u else nil$

symbolic procedure i2pvector n$
  '!:pv . n$

symbolic procedure pv_expt(u,n)$
  if n=1 then u
  else rederr list('pv_expt,"*** Can't powered pvector")$

symbolic procedure pv_quotient(u,c)$
  if pv_intequiv c and cdr c = 1 then u
  else rederr list('pv_quotient,"*** pvector can't be divided by: ",c)$

symbolic procedure pv_divide(u,v)$
  rederr list('pv_divide,"*** Can't divide pvector by pvector")$

symbolic procedure pv_gcd(u,v)$ car u . 1$

%-------------------------------------------------------

initdmode 'pvector$

symbolic procedure pv_add(v1,v2)$
 %       v1,v2   - pvectors.
 %       Return v1+v2.
 if null v1 then v2
 else if null v2 then v1
 else begin scalar r,h$
     while v1 or v2 do
       if v1 and v2 and cdar v1 = cdar v2 then <<
           h:=caar v1 + caar v2$
           if null(h = 0) then r:=(h . cdar v1) . r$
           v1:=cdr v1$
           v2:=cdr v2$
         >>
       else if (v1 and null v2) or (v1 and v2 and cdar v1 > cdar v2)
              then << r:=(car v1 . r)$ v1:=cdr v1 >>
       else << r:=(car v2 . r)$ v2:=cdr v2 >>$
     return reversip r$
 end$

symbolic procedure pv_neg v1$
   %       v1     - pvector$
   %       Return - v1.
   begin scalar r$
     while v1 do <<
       r:= ((-caar v1) . cdar v1) . r$
       v1:=cdr v1$
     >>$
     return reversip r$
 end$

symbolic procedure pv_multc(v,c)$
 if c=0 or null v then nil
 else if c=1 then v
 else begin scalar r$
     while v do <<
       if null(caar v = 0) then r:=((c*caar v) . cdar v) . r$
       v:=cdr v$
     >>$
     return reversip r$
 end$

%-------------------- Sorting ... -----------------------

symbolic procedure pv_sort v$
  if null v then nil
  else pv_sort1(cdr v,list car v)$

symbolic procedure pv_sort1(v,v1)$
 if null v then reversip v1
 else if cdar v < cdar v1 then pv_sort1(cdr v,car v . v1)
 else pv_sort1(cdr v,pv_sort2(car v,v1))$

symbolic procedure pv_sort2(x,v1)$
  << pv_sort2a(x,v1); v1 >>$

symbolic procedure pv_sort2a(x,v1)$
  if null cdr v1
    then if cdr x > cdar v1 then rplacd(v1,list x)
         else (lambda w; rplacd(rplaca(v1,x),w)) (car v1 . cdr v1)
  else if cdr x > cdar v1 then pv_sort2a(x,cdr v1)
  else (lambda w; rplacd(rplaca(v1,x),w)) (car v1 . cdr v1)$


%------------------- pv_renorm -------------------------------

symbolic procedure pv_compress v$
  begin scalar u$
    while v do <<
      if null(caar v = 0) then u:=car v . u$
      v:=cdr v$
    >>$
    return reversip u$
  end$

symbolic procedure pv_renorm v$    % not v modified.
 if null v then nil
 else begin scalar r,k$
    while v and caar v = 0 do v:=cdr v$
    if null v then return nil$
    if caar v < 0 then v:=pv_neg v$
    k:=caar v$
    r:=cdr v$
    while r and k neq 1 do <<
      k:=gcdf!*(k,caar r)$
      r:=cdr r$
    >>$
    r:=nil$
    for each x in v do
      if null(car x = 0)
        then r:=(if k=1 then x else ((car x/k) . cdr x)) . r$
    return reversip r$
 end$

 %---------------------------------------------------------------

symbolic procedure pappl_pv(p,v)$
  pv_sort for each x in v collect (car x . pappl0(p,cdr x))$

symbolic procedure pv_applp(v,p)$
  pv_sort for each x in v collect (car x . pappl0(cdr x,p))$

symbolic procedure pv_upright(v,d)$
  for each x in v collect (car x . pupright(cdr x,d))$

symbolic procedure vupleft(v,d)$
  for each x in v collect (car x . pupleft(cdr x,d))$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/dummy1.red0000644000175000017500000001117211526203062024071 0ustar  giovannigiovanni%======================================================
%       Name:           dummy.red - dummy indecies package
%       Author:         A.Kryukov (kryukov@npi.msu.su)
%       Copyright:      (C), 1993, A.Kryukov
%       Version:        2.10
%       Release:        Nov. 17, 1993
%======================================================

module dummy1$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*basis)$

symbolic procedure cross(s1,s2)$ cross1(s1,s2,nil)$

symbolic procedure cross1(s1,s2,w)$
  if null s1 then w
  else if car s1 memq s2
    then cross1(cdr s1,delete(car s1,s2),car s1 . w)
  else cross1(cdr s1,s2,w)$

symbolic procedure suppl(s1,s2)$ suppl1(s1,s2,nil)$

symbolic procedure suppl1(s1,s2,w)$
  if null s1 then w
  else if null(car s1 memq s2) then suppl1(cdr s1,s2,car s1 .w)
  else suppl1(cdr s1,delete(car s1,s2),w)$

symbolic procedure suppl2(s1,s2,w)$
  if null s1 then (s2 . w)
  else if null(car s1 memq s2) then suppl1(cdr s1,s2,car s1 .w)
  else suppl1(cdr s1,delete(car s1,s2),w)$

symbolic procedure tn_equal(tn1,tn2)$
  % tn1,tn2 - tname::=(id1 id2 ...)
  (car x and cdr x) where x=suppl2(tn1,tn2,nil)$

symbolic procedure th_equal(th1,th2)$
  % th1,th2 - theader::=(tname . ilist . dlist)
  if tn_equal(car th1,car th2) then il_equal(cadr th1,cadr th2)
  else nil$

symbolic procedure il_equal(il1,il2)$
  il_equal1(il2,suppl(il1,il2),nil)$

symbolic procedure il_equal1(il,dl,w)$
  % il,w - ilist
  % dl - dlist
  if null il then reversip w
  else if null get(car il,'dummy) then il_equal1(cdr il,dl,car il . w)
  else ((if null cdr x
           then (il_equal1(cdr il,cdr dl,car dl . w)
                where z=rplacd(rplaca(x,car get(car dl,'dummy)),t)
                )
         else (il_equal1(cdr il,delete(z,dl),z . w)
              where z=dfind(car x,dl)
              )
        ) where x=get(car il,'dummy)
       )$

symbolic procedure dfind(di,dl)$
  if null dl then nil
  else if di eq get(car dl,'dummy) then car dl
  else dfind(di,cdr dl)$

symbolic procedure il_simp(il)$ il_simp1(il,nil)$

symbolic procedure il_simp1(il,w)$
  if null il then reversip w
  else if car il memq cdr il
    then il_simp1(di_subst(car il . di_new car il,cdr il)
                 ,di_new car il . w
                 )
  else il_simp1(cdr il, car il . w)$

symbolic procedure di_subst(x,il)$ di_subst1(x,il,nil)$

symbolic procedure di_subst1(x,il,w)$
  if null il then reversip w
  else if car x eq car il then di_subst1(x,cdr il,cdr x . w)
  else di_subst1(x,cdr il,car il . w)$

global '(d_number)$
if null d_number then d_number:=0$

symbolic procedure di_new(x)$
  begin scalar z$
    d_number:=d_number + 1$
    z:=mkid('!_,d_number)$
    put(z,'dummy,list x)$
    return z$
  end$

global '(!*dummypri !*windexpri)$
switch dummypri,windexpri$

symbolic procedure di_restore il$ di_restore1(il,nil)$

symbolic procedure di_restore1(il,w)$
  if null il then reversip w
  else ((if null x
           then ((if null y then di_restore1(cdr il,car il . w)
                  else di_restore1(cdr il
                         ,(if !*windexpri then mkid(car y,car il)
                           else car y
                          ) . w
                                  )
                 ) where y = get(car il,'windex)
                )
         else di_restore1(cdr il
                ,(if !*dummypri then mkid(car x,car il) else car x) . w
                         )
        ) where x=get(car il,'dummy)
       )$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/atensor.tst0000644000175000017500000000776611526203062024406 0ustar  giovannigiovanni%*********************************************************************
%                          ATENSOR  TEST  RUN.
%
%                       V.A.Ilyin & A.P.Kryukov
%                  E-mail:   ilyin@theory.npi.msu.su
%                          kryukov@theory.npi.msu.su
%
%                Nucl. Phys. Inst., Moscow State Univ. 
%                        119899 Moscow, RUSSIA
%*********************************************************************

% First of all we have to load the ATENSOR program using the one of the
% following command:
%       1) in "atensor.red"$         % If we load source code
%       2) load atensor$             % If we load binary (compiled) code.
load atensor;

% To control of total execution time clear timer:
showtime;

% Switch on the switch TIME to control of executing time 
% for each statement.
%on time$

% Let us introduce the antisymmetric tensor of the second order.
tensor a2;

% The antisymmetric property can be expressed as:
tsym a2(i,j)+a2(j,i);

% The K-basis that span K subspace is:
kbasis a2;

% Let us input very simple example:
a2(k,k);

% By the way the next two expressions looks like different ones:
a2(i,j);
a2(j,i);

% But the difference of them has a correct value:
a2(j,i)-a2(i,j);

% Next examples. For this purpose we introduce 3 abstract 
% vectors - v1,v2,v3:
tensor v1,v2,v3;

% The following expression equal zero:
a2(i,j)*v1(i)*v1(j);
% It is interest that the result is consequence of the equivalence 
% of the name of tensors.

% While the next one - not:
a2(i,j)*v1(i)*v2(j);

% Well. Let us introduce the symmetric tensor of the second order.
tensor s2;
tsym s2(i,j)-s2(j,i);

% Their K-basis look like for a2 excepted sign:
kbasis s2;

% Of course the contraction symmetric  and antisymmetric tensors 
% equal zero:
a2(i,j)*s2(i,j);

% By the way, the next example not so trivial for computer...
a2(i,j)*a2(j,k)*a2(k,i);

% Much more interesting examples we can demonstrate with the
% the tensor higher order. For example full antisymmetric tensor
% of the third order:
tensor a3;

% The antisymmetric property we can introduce through the 
% permutation of the two first indices: 
tsym a3(i,j,k)+a3(j,i,k);

% And the cyclic permutation all of them:
tsym a3(i,j,k)-a3(j,k,i);

% The K basis of a3 consist of 5 vectors:
kbasis a3;

% In the beginning some very simple examples:
a3(i,k,i);
a3(i,j,k)*s2(i,j);

% The full symmetric tensor of the third order may be introduce
% by the similar way: 
tensor s3;
tsym s3(i,j,k)-s3(j,i,k);
tsym s3(i,j,k)-s3(j,k,i);
kbasis s3;

% The next examples demonstrate some calculation with them:
s3(i,j,k)-s3(i,k,j);
s3(i,j,k)*a2(i,j);
a3(i,j,k)*s2(i,j);
s3(i,j,k)*a3(i,j,k);


% Now we consider very important physical case - Rieman tensor:
tensor ri;

% It has the antisymmetric property with respect to the permutation
% of the first two indices:
tsym ri(i,j,k,l) + ri(j,i,k,l);

% It has the antisymmetric property with respect to the permutation
% of the second two indices:
tsym ri(i,j,k,l) + ri(i,j,l,k);

% And the triple term identity with cyclic permutation the 
% third of them:
tsym ri(i,j,k,l) + ri(i,k,l,j) + ri(i,l,j,k);

% The corresponding K basis consist of 22(!) vectors:
kbasis ri;

% So we get the answer for any expressions with 3 and more terms of 
% Rieman tensors with not more then 2 terms. For example:
ri(i,j,k,l)+ri(j,k,l,i)+ri(k,l,i,j)+ri(l,i,j,k); 

% This three identities leads us to very important symmetry property with
% respect to exchange of pairs indices:
ri(i,j,k,l)-ri(k,l,i,j);

% Let us start with simple example:
ri(m,n,m,n)-ri(m,n,n,m);

% Much more complicated example is:
a2(m,n)*ri(m,n,c,d) + a2(k,l)*ri(c,d,l,k);
% The answer is trivial but not so simple to obtain one.

% The dimension of the full space is 6! = 720.
% The K basis consists of 690 vectors (to reduce output we 
% commented the last statement):
%kbasis ri(a2);

% One else nontrivial examples with Riemann tensors:
(ri(i,j,k,l)-ri(i,k,j,l))*a2(i,j);

%***************** END OF TEST RUN ************************
% The total execution time is:
showtime;

$END$


mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/atensor.red0000644000175000017500000000331511526203062024330 0ustar  giovannigiovannimodule atensor; % Header module for atensor package.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%======================================================
%       Author:         A.Kryukov (kryukov@theory.npi.msu.su)
%       Copyright:      (C), 1993-1996, A.Kryukov
%       Version:        2.32
%======================================================

create!-package(
   '(atensor perm1 pvector basis dummy1 dummy2 tensor1 tensor tensorio),
   '(contrib atensor));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/dummy2.red0000644000175000017500000002001511526203062024066 0ustar  giovannigiovanni%======================================================
%       Name:           dummy2.red - dummy indices package
%       Author:         A.Kryukov (kryukov@npi.msu.su)
%       Copyright:      (C), 1993, A.Kryukov
%------------------------------------------------------
%       Version:        2.34
%       Release:        Dec. 15, 1993
%                       Mar. 24, 1996 mk_ddsym1
%======================================================

module dummy2$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*basis); fluid '(!*debug)$

symbolic procedure adddummy(tt)$
  % tt - tensor::=(!:tensor . ((th1 . pv1) ...)))
  % (r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...)
  adddummy0(cdr tt,!*basis)$

symbolic procedure adddummy0(tt,b)$
  % tt - ((th1 . pv1) ...)
  % b(r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...)
  if null tt then reversip b
  else adddummy0(cdr tt,adddummy0b(mk_dsym0 car tt,b))$

symbolic procedure adddummy0b(u,b)$
  % u - (th . (pv1 pv2 ...))
  %b,b1(r.v.) - basis
  if null cdr u then b
  else adddummy0b(car u . cddr u,adddummy0a(car u . cadr u,b,nil))$

symbolic procedure adddummy0a(t1,b,b1)$
  % t1 - (th . pv)
  % b,b1(r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...)
  if null b then if null t1 then reversip b1
                 else reversip(adddummy1(t1
                                 ,gperm length cadar t1
                                 ,nil
                               ) . b1
                      )
  else if null t1 then adddummy0a(nil,cdr b,car b . b1)
%  else if th_match(car t1,caar b) then adddummy0a(nil,b,b1)
  else if th_match0(car t1,caar b)
    then adddummy0a(nil,cdr b,adddummy1(t1
                                ,gperm length cadar t1
                                ,car t1 . cdar b
                              ) . b1
                   )
  else adddummy0a(t1,cdr b,car b . b1)$

symbolic procedure adddummy1(t1,plist,b)$
  << if !*debug
        then << terpri()$
                write " DEBUG: adddummy1"$
                terpri()$
                t_pri1('!:tensor . list(t1),t)$
                terpri()$
                for each z in cdr x
                do t_pri1('!:tensor . list(car x . z),t)$
                write " DEBUG=",length cdr x$ terpri()$
                         >>$
     x
  >>  where x=adddummy1a(t1,plist,b)$

symbolic procedure adddummy1a(t1,plist,b)$
  % t1 - (th . pv)
  % plist - (p1 p2 ...)
  % b,w(r.v.) - (th1 . (pv1 pv2 ...))
  if null plist then b
  else adddummy1a(t1
         ,cdr plist
         ,(if null b then car t1 else car b)
          . insert_pv(pappl_pv(car plist,cdr t1)
              ,if null b then b else cdr b
            )
       )$

symbolic procedure mk_dsym0 t1$
  car t1 . append(cdr mk_dsym t1,cdr mk_ddsym t1)$

symbolic procedure mk_dsym(t1)$
  % t1 - (th . pv)
  car t1 . mk_dsym1(cdr t1
             ,nil
             ,mk_flips(cadar t1,dl_get cadar t1,nil)
           )$

symbolic procedure mk_dsym1(pv1,pv2,fs)$
  % pv1,pv2(r.v.) - pvector
  % fs - permutation list
  if null fs then pv2
  else mk_dsym1(pv1
         ,pv_add(pv1,pv_neg pv_applp(pv1,car fs)) . pv2
%         ,pv_add(pv1,pv_neg pappl_pv(car fs,pv1)) . pv2
         ,cdr fs
       )$

symbolic procedure dl_get(il)$ dl_get2(il,nil)$

symbolic procedure dl_get2(il,d_alst)$
  if null il then d_alst
  else if get(car il,'dummy)
    then dl_get2(cdr il,di_insert(car il,d_alst,nil))
  else dl_get2(cdr il,d_alst)$

symbolic procedure eqdummy(x,y)$
  x and car get(x,'dummy) eq car get(y,'dummy)$

symbolic procedure di_insert(di,d_alst1,d_alst2)$
  if null d_alst1 then if di then ((di . nil) . d_alst2)
                       else d_alst2
  else if eqdummy(di,caar d_alst1)
    then di_insert(nil,cdr d_alst1,(caar d_alst1 . di) . d_alst2)
  else di_insert(di,cdr d_alst1,car d_alst1 . d_alst2)$

symbolic procedure il_update(il,d_alst)$
  il_update1(il,d_alst,nil)$

symbolic procedure il_update1(il,d_alst,il1)$
  if null il then reversip il1
  else ((if null y then il_update1(cdr il,d_alst,car il . il1)
          else ((if x
                   then il_update1(cdr il,delete(x,d_alst),cdr x . il1)
                 else begin scalar z,u$
                        z:=di_next(d_alst)$
                        u:=car z$
                        rplaca(z,y)$
                        return il_update1(cdr il,d_alst,u . il1
                               )$
                      end
                ) where x=assoc(y,d_alst)
               )
        ) where y=get(car il,'dummy)
       )$

symbolic procedure di_next(dl)$
  if null dl then rederr list('di_next,"+++ Can't find next dummy")
  else if get(caar dl,'dummy) then car dl
  else di_next(cdr dl)$

symbolic procedure mk_flips(il,dl,fs)$
  if null dl then reversip fs
  else mk_flips(il,cdr dl,mk_flip(il,car dl) . fs)$

symbolic procedure mk_flip(il,x)$
  pfind(il,mk_flip1(il,x,nil))$

symbolic procedure mk_flip1(il,x,w)$
  if null il then reverse w
  else if car x eq car il
    then mk_flip1(cdr il,(cdr x . car x),cdr x . w)
  else mk_flip1(cdr il,x,car il . w)$

symbolic procedure mk_flip_(il,di)$
  begin scalar il1,il2,w,w1,ok,x$
    w:=il$
    while w and null ok do if null car w eq caar di
                 then << il1:=car w . il1$ w:=cdr w >>
               else ok:=t$
    if null w then rederr 1;
    il1:=car w . il1$
    il2:=il1$
    w:=cdr w$
    ok:=nil$
    while w do if null car w eq cdar di
                 then << il2:=car w . il2$ w:=cdr w >>
               else ok:=t$
    if null w then rederr 2;
    il2:=car w . il2$
    w:=cdr w$
    w1:=il2$
    while w do << w1:=car w . w1$ w:=cdr w >>$
    x:=car il1$
    rplaca(il1,car il2)$
    rplaca(il2,x)$
    return pfind(il,reversip w)$
  end$

%++++++++++++++++++++++++++++++++++

symbolic procedure mk_ddsym(t1)$
  % t1 - (th . pv)
  % r.v. - (th . (pv1 pv2 ...))
  car t1 . mk_ddsym1(cdr t1
             ,nil
             ,mk_fflips(cadar t1,dl_get cadar t1,nil)
           )$

symbolic procedure mk_ddsym1(pv,pvs,fs)$
  if null fs then pvs
  else mk_ddsym1(pv
%         ,pv_add(pv,pv_neg pappl_pv(car fs,pv)) . pvs % -A.K. 24.03.96
         ,pv_add(pv,pv_neg pv_applp(pv,car fs)) . pvs  % +A.K. 24.03.96
         ,cdr fs
       )$

symbolic procedure mk_fflips(il,dl,fs)$
  if null dl then fs
  else mk_fflips(il,cdr dl,mk_fflips1(il,car dl,cdr dl,fs))$

symbolic procedure mk_fflips1(il,dp,dl,fs)$
  if null dl then fs
  else mk_fflips1(il,dp,cdr dl,mk_fflip1(il,dp,car dl) . fs)$

symbolic procedure mk_fflip1(il,dp1,dp2)$
  pfind(il,mk_fflip2(il,dp1,dp2,nil))$

symbolic procedure mk_fflip2(il,dp1,dp2,il1)$
  % dp1,dp2 - (di1 . di2) - contracted indecies
  if null il then reverse il1
  else ((if null(x=get(car dp1,'dummy)) and null(x=get(car dp2,'dummy))
           then mk_fflip2(cdr il,dp1,dp2,car il . il1)
         else if x=get(car dp2,'dummy)
           then mk_fflip2(il,dp2,dp1,il1)
         else mk_fflip2(cdr il,dp1,cdr dp2 . car dp2,car dp2 . il1)
        ) where x=get(car il,'dummy)
       )$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/tensorio.red0000644000175000017500000001232711526203062024522 0ustar  giovannigiovanni%======================================================
%       Name:           tio.red - tensor user interface
%       Author:         A.Kryukov (kryukov@npi.msu.su)
%       Copyright:      (C), 1993i-1995, A.Kryukov
%       Version:        1.35
%       Release:        Apr., 17, 1995
%------------------------------------------------------
%       Modified:       Apr., 17, 1995   tsym2
%                       Apr., 24, 1996   tclear0
%======================================================

module tensorio$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%=====================================================
%       blist::=((th . pv_list) ...)
%       pv_list::= (pv1 pv2 ...)
%=====================================================

smacro procedure tname th$ car th$
smacro procedure ilist th$ cadr th$
smacro procedure dlist th$ cddr th$
smacro procedure mkth(tn,il,dl)$ list tn . il . id$
smacro procedure mkth0(tn,il,dl)$  tn . il . dl$

smacro procedure thead ten$ car ten$
smacro procedure pvect ten$ cdr ten$
smacro procedure mkten0(th,pv)$ th . pv$
smacro procedure mkten(th,pv)$ '!:tensor . list(th . pv)$

symbolic procedure bassoc(th,bl)$
  if null bl then nil
  else if th_match(th,caar bl) then bl
  else bassoc(th,cdr bl)$

global '(!*basis,tensors!*)$

remprop('tensor,'stat)$
remprop('tsym,'stat)$
remprop('tclear,'stat)$

symbolic procedure tensor u$
    for each x in u do
      if null(x memq tensors!*) then <<
        put(x,'!:tensor,99)$            % undefine rank
        put(x,'simpfn,'t_simp)$
        flag(list x,'full)$
        tensors!* := x . tensors!*$
      >>
      else write "+++ ",x," is already declared as tensor."$

symbolic procedure tclear u$
  tclear0(if car u eq 'all then tensors!* else u)$

symbolic procedure tclear0 u$
  for each x in u do
    if x memq tensors!* then
      begin scalar bs,bs1$
        tensors!* := delete(x,tensors!*)$
        remprop(x,'!:tensor)$
        remflag(x,'full)$
        bs:=!*basis$
        while bs do <<
          if null(x memq caaar bs) then bs1:=car bs . bs1$
          bs:=cdr bs$
        >>$
        !*basis:=reversip bs1$
      end
    else << write "+++ ",x," is not a tensor."$ terpri() >>$

symbolic procedure tsym u$
  % u is a list of symmetry identities.
  % return nil.
  % Out side eff.: add identities to basis list in !*basis.
  begin scalar b$
    b:=!*basis$
    !*basis:=nil$
    !*basis:=tsym1(u,b)$
  end$

symbolic procedure tsym1(u,b)$
  % u is a list of symmetry identities.
  % b is a basis list (returned value).
  % return new basis list.
  if null u then b
  else tsym1(cdr u,tsym2(cdr numr simp!* car u,b,nil))$

symbolic procedure tsym2(tt,b,b1)$
  % tt is a tensor identity
  % b is old basis
  % b1 is new basis (returned value)
  if cdr tt then rederr list('tsym2,"*** Invalid identity:",tt)
  else if null b
    then (caar tt . tsym4(gperm length cadaar tt,car tt,nil))
         . reversip b1
  else if th_match0(caar tt,caar b)
         then (caar b . tsym4(gperm length cadaar tt,car tt,cdar b))
              . append(cdr b,b1)
  else tsym2(tt,cdr b,car b . b1)$

symbolic procedure tsym4(ps,x,b0)$
 if null ps then b0
 else tsym4(cdr ps,x
           ,insert_pv(pv_renorm sieve_pv(pv_applp(cdr x,car ps),b0),b0)
           )$

put('tensor,'stat,'rlis)$
put('tsym,'stat,'rlis)$
put('tclear,'stat,'rlis)$

symbolic procedure kbasis x$
  for each z in x do basis1 z$

global '(!*dummypri)$
switch dummypri$

symbolic procedure basis1 x$
  begin scalar b$
    if idp x then x:=list x;
    if atom x or null get(car x,'!:tensor)
      then rederr list('basis1,"*** Invalid as tensor:",x);
    b:=!*basis$
    while b do <<
      if tnequal(x,caaar b)
        then << for each z in cdar b do
                  t_pri1('!:tensor . list(caar b . z),t)$
                write length cdar b$ terpri()$
             >>$
      b:=cdr b$
    >>$
  end$

symbolic procedure tnequal(tn1,tn2)$
  if atom tn1 then tn1 eq tn2
  else (lambda x$ if x neq tn2 then tnequal(cdr tn1,x)
                  else nil) delete(car tn1,tn2)$

put('kbasis,'stat,'rlis)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/tensor1.red0000644000175000017500000002504611526203062024255 0ustar  giovannigiovanni%======================================================
%       Name:           tensor1.red - tensor continuation
%       Author:         A.Kryukov (kryukov@theory.npi.msu.su)
%       Copyright:      (C), 1993-1996, A.Kryukov
%       Version:        2.22 Apr. 02, 1996
%------------------------------------------------------
%       Release:        Dec. 15, 1993
%                       Mar. 25, 1996     sieve_t2
%                       Apr. 02, 1996     t_add2
%======================================================

module tensor1$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*basis)$
global '(pv_den)$

symbolic procedure th2pe(th,v)$
  % th - tensor header
  % th::=(tname ...) . (i ...) . (d ...)
  % v  - vector
  % return prefix expression
  begin scalar pe,r,i,il,tt,tt1$
    % tt,tt1 - tensor term
    while v do <<
      il:=pappl(cdar v,di_restore cadr th)$
      tt1:=nil$
      for each x in car th do <<
        r:=get(x,'!:tensor)$
        tt:=list x$
        for i:=1:r do << tt:=car il . tt$ il:=cdr il >>$
        tt1:=reversip tt . tt1$
      >>$ % for each
      tt1:=reversip tt1$
      if null(caar v = 1) then tt1:=caar v . tt1$
      if tt1 and cdr tt1 then tt1:='times . tt1$
      if tt1 and null cdr tt1 then tt1:=car tt1$
      pe:=tt1 . pe$
      v:=cdr v$
    >>$ % while v
    pe:=reversip pe$
    if pe and cdr pe then pe:='plus . pe
    else if pe then pe:=car pe$
    return pe$
  end$

symbolic procedure t_pri1(tt,sw)$
  % tt - tensor expression
  % tt::=!:tensor . ((th . v) ...)
  begin scalar pe,den$                                 %mod AK 28/03/96
    tt:=cdr tt$
    den:=cddr caar tt$                                 %+   AK 28/03/96
    while tt do <<
      pe:=th2pe(caar tt,cdar tt) . pe$
      tt:=cdr tt$
    >>$
    if pe and cdr pe then pe:='plus . reversip pe
    else if pe then pe:=car pe$
    if not(den = 1) then pe:='quotient . pe . list den$%+   AK 28/03/96
%    terpri()$ print list(">>>>>> t_pri1: pe=",pe)$ terpri()$
    assgnpri(pe,nil,sw)$                               % WN 10.4.96
  end$

symbolic procedure pappl_t(p,tt)$
  for each x in tt collect
    (caar x . pappl(p,cadar x) . cddar x) . pappl_pv(p,cdr x)$

symbolic procedure t_add(t1,t2)$
  if null cdr t1 then t2
  else if null cdr t2 then t1
  else if th_match(cadr t1,cadr t2)
       then sieve_t(t_add2(t1,t2),!*basis)
  else t_addf(t1,t2)$

symbolic procedure sieve_t(tt,bs)$
  % tt:=(!:tensor . (ten1 ten2 ...))
  car tt . sieve_t0(cdr tt,nil,bs)$                    % -AK 250396
%  ((car tt . car x) . cdr x)                            % +AK 250396
%  where x=sieve_t0(cdr tt,nil,bs)$                      % +AK 250396

symbolic procedure sieve_t0(u,v,bs)$      % July 13, 1994
  % u::=(ten1 ten2 ...)
  % v - sieved tensor (r.v.)
  if null u then reversip v
  else sieve_t0(cdr u
               ,((if cdr x then x . v else v)           % -AK 250396
%               ,((if cdr x then (x.pv_den) . v else v)   % +AK 250396
                 where x=sieve_t2(car u,bs)
                )
               ,bs
               )$

symbolic procedure sieve_t1(tt,bs)$
  % tt::=(th . pv)
  begin scalar bs$
    bs:=!*basis$
    while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
    if bs then return car tt . sieve_pv(cdr tt,cdar bs)$
    if dl_get(cadar tt) then <<
      !*basis:=append(adddummy('!:tensor . list tt),!*basis)$
      bs:=!*basis$
      while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
      if bs then return car tt . sieve_pv(cdr tt,cdar bs)$
    >>$
    return tt$
  end$

%symbolic procedure sieve_t2(tt,bs1)$     % Jul 13, 1994
%  % tt::=(th . pv)
%  begin scalar bs$
%    bs:=bs1$
%    if dl_get(cadar tt) then bs:=append(adddummy0(list tt,bs),bs)$
%    while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
%    if bs then tt := car tt . sieve_pv(cdr tt,cdar bs)$
%    return tt$
%  end$

symbolic procedure sieve_t2(tt,bs1)$      % Mar. 25, 1996
  % tt::=(th . pv)
  begin scalar bs,tt1$
    bs:=bs1$
    if dl_get(cadar tt) then bs:=append(adddummy0(list tt,bs),bs)$
    while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
    tt1:=tt$
    pv_den:=1$
    if bs then tt := car tt . sieve_pv0(cdr tt,cdar bs,nil)$
    rplacd(cdar tt,cddar tt * pv_den)$              % + AK 28/03/96
    if !*debug then
      << terpri()$
         write " DEBUG: sieve_t2"$
         terpri()$
         t_pri1('!:tensor.list tt1,t);
         if bs then
           for each z in cdar bs
           do t_pri1('!:tensor.list(caar bs.z),t);
         terpri()$
         t_pri1('!:tensor.list tt,t);
         terpri()$
      >>$
    return tt$
  end$

symbolic procedure t_addf(t1,t2)$
  if ordp(cadr t1,cadr t2)
%    then ( t1 .+ (t2 .+ nil) )
    then ( ((t1 .** 1) .* 1) .+ ( ((t2 .** 1 ) .* 1) .+ nil) )
  else t_addf(t2,t1)$

symbolic procedure t_add2(tx1,tx2)$
  begin scalar w$
    w:=il_update(cadar tx2,dl_get cadar tx1)$
    w:=pfind(w,cadar tx1)$
%    w:=for each x in cdr tx2 collect car x . pappl0(w,cdr x)$
        % - AK 02/04/96
    w:=for each x in cdr tx2 collect car x . pappl0(cdr x,w)$
        % + AK 02/04/96
    return car tx1 . pv_add(cdr tx1,w)$
  end$

symbolic procedure t_match(t1,t2)$ th_match(car t1,car t2)$

symbolic procedure th_match(th1,th2)$
  th_match0(th1,th2) and
  (length dl_get cadr th1 = length dl_get cadr th2)$

symbolic procedure th_match0(th1,th2)$
  (car th1 = car th2) and (length cadr th1 = length cadr th2)$

symbolic procedure th_match_(th1,th2)$
  if car th1 = car th2 and th_match1(cadr th1,cadr th2)
    then pfind(cadr th1,cadr th2)
  else nil$

symbolic procedure th_match1(il1,il2)$
  if null il1 then null il2
  else if null(il2 = (il2:=delete(car il1,il2)))
         then th_match1(cdr il1,il2)
  else nil$

symbolic procedure t_neg te$
  if numberp car te then list(-car te)
  else for each x in te collect car x . pv_neg cdr x$

symbolic procedure t_mult(te1,te2)$
  if null te1 then te2
  else if numberp car te1 then c_mult(car te1,te2)
  else if numberp car te2 then c_mult(car te2,te1)
  else t_mult(cdr te1,t_mult1(car te1,te2))$

symbolic procedure t_mult1(te1,te)$
  for each x in te collect t_mult2(te1,x)$

symbolic procedure t_mult2(tt1,tt2)$
  begin scalar tt$
    if cddr tt1 or cddr tt2
      then  rederr list('t_mult2," *** Must be tterms: ",tt1,tt2)$
    tt:=tt1$
    tt1:=t_upright(tt1,car tt2)$
    tt2:=t_upleft(tt2,car tt)$
    return (car tt1 . pv_multc(caadr tt1,cdr tt2))$
  end$

symbolic procedure c_mult(c,te)$
  if null te then nil
  else if numberp car te then list(c*car te)
  else for each x in te collect car x . pv_multc(c,cdr x)$

symbolic procedure t_upright(tt,th)$
  begin scalar th1,tt1$
    th1:=car tt$
    th1:=append(car th1,car th) . append(cadr th1,cadr th)
       . append(cddr th1,cddr th)$
    return (th1 . pv_upright(cdr tt,length cadr th))$
  end$

symbolic procedure t_upleft(tt,th)$
  begin scalar th1,tt1$
    th1:=car tt$
    th1:=append(car th,car th1) . append(cadr th,cadr th1)
       . append(cddr th,cddr th1)$
    return (th1 . pv_upleft(cdr tt,length cadr th))$
  end$

global '(!*debug_times)$
switch debug_times$

symbolic procedure b_expand(u,v)$
  (if !*debug_times then !*basis else !*basis := x
  ) where x = b_expand1(cadr u,cadr v,!*basis,!*basis)$

symbolic procedure b_expand1(t1,t2,bs,bs1)$       % Jul 13, 1994
  % t1,t2 - (th . pv)
  % bs,bs1(r.v.) - (b1 b2 ...) where b::=(th . (pv1 pv2 ...))
  if null bs then reversip bs1
  else if th_match0(car t1,caar bs)
    then b_expand1(t1,t2,cdr bs,b_expand2(car bs,t2,bs1))
  else if th_match0(car t2,caar bs)
    then b_expand1(t1,t2,cdr bs,b_expand2(car bs,t1,bs1))
  else b_expand1(t1,t2,cdr bs,bs1)$

symbolic procedure b_expand2(b,t1,bs)$
  % t1 - (th . pv)
  % b - (th . (pv1 pv2 ...))
  % bs(r.v.) - (b1 b2 ...)
%  b_expand2a(car b,cdr b,t1,nil,bs)$
  b_expand2b(car b,cdr b,t1,bs)$

symbolic procedure b_expand2b(th,b,t1,bs)$
  % t1 - (th . pv)
  % b - (th . (pv1 pv2 ...))
  % bs(r.v.) - (b1 b2 ...)
  if null b then bs
  else b_expand2b(th
         ,cdr b
         ,t1
         ,tsym2(list t_prod(th . car b,t1),bs,nil)
                 )$

symbolic procedure b_expand2a(th,b,t1,b1,bs)$
  % t1 - (th . pv)
  % b - (th . (pv1 pv2 ...))
  % bs(r.v.) - (b1 b2 ...)
  if null b then b_join(caar b1 . b_expand3(b1,nil),bs)
  else b_expand2a(th,cdr b,t1,t_prod(th . car b,t1) . b1,bs)$

symbolic procedure b_expand3(b,b1)$
  if null b then b1
  else b_expand3(cdr b,cdar b . b1)$

symbolic procedure b_join(b,bs)$ b_join1(b,bs,nil)$

symbolic procedure b_join1(b,bs,bs1)$
  if null bs then reversip(if b then b . bs1 else bs1)
  else if b and th_match(car b,caar bs)
    then b_join1(nil,cdr bs,(car b . b_join2(cdr b,cdar bs)) . bs1)
  else b_join1(b,cdr bs,car bs . bs1)$

symbolic procedure b_join2(b1,b2)$
  if null b1 then b2
  else b_join2(cdr b1,insert_pv(car b1,b2))$

symbolic procedure t_prod(t1,t2)$
  % t1,t2 - tensors::=(th . pv)
  % r.v.  - direct product of t1 and t2
  if null ordp(caar t1,caar t2) then t_prod(t2,t1)
  else (append(caar t1,caar t2)
       . il_join(cadar t1,cadar t2)
       . append(cddar t1,cddar t2)
       ) . cdr pv_times('!:pv . cdr t1,'!:pv . cdr t2)$

symbolic procedure il_join(l1,l2)$
  if null l1 then l2
  else if memq(car l1,l2) then wi_new(car l1) . il_join(cdr l1,l2)
  else car l1 . il_join(cdr l1,l2)$

global '(wi_number)$
wi_number:=0$

symbolic procedure wi_new(x)$
  begin scalar z$
    wi_number := wi_number + 1$
    z := intern mkid('!:,wi_number)$   %++++++ intern ?!
    put(z,'windex,list x)$
    return z$
  end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/tensor.red0000644000175000017500000003215311526203062024171 0ustar  giovannigiovanni
%======================================================
%       Name:           tensor - tensor arithmetics
%       Author:         A.Kryukov (kryukov@npi.msu.su)
%       Copyright:      (C), 1993-1996, A.Kryukov
%       Version:        2.02    28/03/96
%------------------------------------------------------
%       Release:        Nov. 13, 1993     th_match, th_match1
%                       Jul. 13, 1994     symmetry generated by multiplication.
%                       Mar. 28, 1996     t_gcd, t_prep, t_times4
%======================================================

module tensor$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*debug)$
switch debug$

%=================================================
%       tensor::=(!:tensor . ((th1 . pv1) (th2 . pv2) ...))
%       th::=(tn . il . dl)
%       tn::=(id1 id2 ...)
%==================================================

global '(!*basis)$

symbolic procedure t_simp v$
  begin scalar x;
     if !*debug then << terpri()$ print list('t_simp . v) >>$
     if (x:=get(car v,'!:tensor))=99
       then put(car v,'!:tensor,length cdr v)
     else if null(x = length cdr v)
       then rederr list('t_simp,"*** Invalid number of indices:",v)$
%    v:='!:tensor . list((list car v . il_simp cdr v . nil)
         % -AK 28/03/96
     v:='!:tensor . list((list car v . il_simp cdr v . 1)
         % +AK 28/03/96
                        . list(1 . mkunitp length cdr v)
                        )$
     return (((if cdr z then z else nil)
             where z=sieve_t(v,!*basis)) ./ 1
            )$
  end$

global '(domainlist!*)$

switch tensor$

domainlist!*:=union('(!:tensor),domainlist!*)$
put('tensor,'tag,'!:tensor)$
put('!:tensor,'dname,'tensor)$
%flag('(!:tensor),'field)$              % !:tensor is not a field!
put('!:tensor,'minus,'t_minus)$
put('!:tensor,'minusp,'t_minusp)$
put('!:tensor,'plus,'t_plus)$
put('!:tensor,'times,'t_times)$ % v*c
put('!:tensor,'difference,'t_difference)$
put('!:tensor,'zerop,'t_zerop)$
put('!:tensor,'onep,'t_onep)$
put('!:tensor,'prepfn,'t_prep)$
put('!:tensor,'prifn,'t_pri)$
put('!:tensor,'intequivfn,'t_intequiv)$
put('!:tensor,'i2d,'i2tensor)$
put('!:tensor,'expt,'t_expt)$
put('!:tensor,'quotient,'t_quotient)$
put('!:tensor,'divide,'t_divide)$
put('!:tensor,'gcd,'t_gcd)$

flag('(!:tensor),'tmode)$

symbolic procedure t_minus u$
  if atom cdr u then -cdr u
  else sieve_t(car u . t_minus1(cdr u,nil),!*basis)$

symbolic procedure t_minus1(u,v)$
  if null u then reversip v
  else t_minus1(cdr u,(caar u . pv_neg cdar u) . v)$

symbolic procedure t_minusp u$ nil$

symbolic procedure t_plus(u,v)$
  if atom cdr u
    then rederr list('t_plus,"*** Tensor can't be added to:",cdr u)
  else if atom cdr v then t_plus(v,u)
  else sieve_t(car u . t_plus1(cdr u,cdr v),!*basis)$

symbolic procedure t_plus1(u,v)$
  if null u then v
  else if null v then u
  else t_plus1(cdr u,t_plus2(car u,v,nil))$

symbolic procedure t_plus2(x,v,w)$
  if null v then reversip(x . w)
  else if th_match(car x,caar v)
    then append(cdr v, reversip(t_add2(x,car v) . w))
  else t_plus2(x,cdr v, car v . w)$

symbolic procedure t_times(u,v)$
  % u,v - tensor::=(!:tensor . tlist)
  if t_intequiv u then t_times(v,u)
  else if atom cdr v then car u . t_timesc(cdr u,cdr v,nil)
  else (sieve_t(x,!*basis)
        where x=car u . t_times1(cdr u,cdr v,nil)
%             ,y=b_expand(u,v)
       )$

symbolic procedure t_timesc(tt,c,w)$
  % tt,w - tlist::=((th1 . pv1) ...)
  % c - integer
  if null tt then reversip w
  else t_timesc(cdr tt
               ,c
               ,(caar tt . pv_multc(cdar tt,c)) . w
               )$

symbolic procedure t_times1(u,v,w)$
  % u,v,w - tlist::=((th1 . pv1) ...)
  if null u then reversip w
  else t_times1(cdr u,v,t_times2(v,car u,w))$

symbolic procedure t_times2(v,x,w)$
  % u,w - tlist::=((th1 . pv1) ...)
  % x - (th . pv)
  if null v then w
%  else t_times2(cdr v,x,t_plus2(t_times3(car v,x),w,nil))$
  else t_times2(cdr v,x,t_plus2(t_times4(car v,x),w,nil))$

symbolic procedure t_times3(y,x)$
  % x,y - (th . pv)
  if null ordp(caar y,caar x) then t_times3(x,y)
  else (append(caar y,caar x)
       . il_simp append(cadar y,cadar x)
       . append(cddar y,cddar x)
       ) . cdr pv_times('!:pv . cdr y,'!:pv . cdr x)$

symbolic procedure t_times4(x,y)$                % mod. AK 28/03/96
  % x,y - (th . pv)
  % return product of x by y.
  % side effect: the !*basis will be updated by symmetry properties
  %              generate by multiplication.
  begin scalar tf1,tf2,z,den$
    den := cddar x * cddar y$                     % + AK 28/03/96
    tf1 := t_split(x)$
    tf2 := t_split(y)$
    z   := t_fuse(tf1,tf2)$
    rplacd(cdar z,den)$                           % + AK 28/03/96
    return z$
  end$

symbolic procedure t_split(x)$
  % x - (th . pv)
  % r.v. - list of tensor factors: (tf1 ...)
  %        where tf - (th . pv) and th is a simple tname, i.e. (id)
  if null cdaar x then list x
  else (t_split1(caar x,pappl(p,cadar x)
                ,unpkpv pappl_pv(p,cdr x),nil
                )
        where p = prev(cdadr x)
       )$

symbolic procedure t_split1(tn,il,pv,tfl)$
  % tfl (r.v.) - list of tfactors.
  if null tn then reversip tfl
  else if cdr pv then rederr list('t_split1,": too long pvector ",pv)
  else (
        (t_split1(cdr tn,cdr ils,list(caar pv . cdr pvs),
                 ((list car tn . list car ils)
                 . list(1 . p_rescale car pvs)
                 ) . tfl
                )
          where ils = l_split(il,n,nil),
                pvs = l_split(cdar pv,n,nil)
        ) where n = get(car tn,'!:tensor)
       )$

symbolic procedure pv_rescale(pv)$ pv_rescale1(pv,nil)$

symbolic procedure pv_rescale1(pv,pv1)$
  if null pv then reversip pv1
  else pv_rescale1(cdr pv,(caar pv . p_rescale cdar pv). pv1)$

symbolic procedure p_rescale p$
  (for each x in p collect (x-n)) where n = car p - 1$

symbolic procedure l_split(lst,n,lst1)$
  % Split list lst into two lists where first one contain n items.
  % (r.v.) - (lst1 . lst_rest)
  if n<=0 then (reversip lst1) . lst
  else l_split(cdr lst,n-1,car lst . lst1)$

symbolic procedure unpkpv(pv)$
  unpkpv1(pv,nil)$

symbolic procedure unpkpv1(pv,upv)$
  if null pv then reversip upv
  else unpkpv1(cdr pv,(caar pv . unpkp cdar pv) . upv)$

symbolic procedure t_fuse(tf1,tf2)$
  % tf1, tf2 - list of tensor factors
  % r.v. - the result of "multiplication" of them with order.
  t_fuse1(reversip tf1,reversip tf2,nil)$

symbolic procedure t_fuse1(tf1,tf2,tf3)$
  % r.v. - tf3 - total ordered tensor factor list.
  (if null tf1 then t_fuse2(reversip append(reversip tf2,tf3),nil)
   else if null tf2 then t_fuse2(reversip append(reversip tf1,tf3),nil)
   else if null ordp(caaar tf1,caaar tf2)
          then t_fuse1(cdr tf1,tf2,car tf1 . tf3)
   else t_fuse1(tf1,cdr tf2,car tf2 . tf3)
  )
%   where x=if tf1 and tf3 and caaar tf1 = caaar tf3
%              then addmultsym(car tf1,car tf3)
%            else if tf2 and tf3 and caaar tf2 = caaar tf3
%              then addmultsym(car tf2,car tf3)
%            else if tf3
%             then !*basis:=b_expand1(if tf1 then car tf1 else car tf2
%                                          ,car tf3,!*basis,!*basis
%                                          )
%            else nil
  $

symbolic procedure t_fuse2(tf,te)$
  if null tf then te
  else t_fuse2(cdr tf,t_fuse3(car tf,te))$

symbolic procedure t_fuse3(t1,t2)$
  % t1,t2 - tensors
  % r.v.  - it's product.
  % side effect: !*basis will be updated.
  if null t2 then pkt t1
  else if null caar t1 then pkt t2
  else ((( ((caaar t1 . caar t2)
           .il_simp append(cadar t1,cadar t2)
           .nil
           )
         . cdr pv_times('!:pv . cdr t1,'!:pv . cdr t2)
         )
         where x=addmultsym(t1,t2)
        )
        where zz = b_expand(list('!:tensor,t1),list('!:tensor,t2))
                                                  %  Aug. 06, 1994
       )$

symbolic procedure addmultsym(t1,t2)$             % AK, Nov. 20, 1994
  addmsym(t1,t2,caar t1,caar t2)$

symbolic procedure addmsym(t1,t2,k1,k2)$
  % t1,t2 - tensors the product of them generate new symmtries.
  % k1,k2 - current name of t1,t2.
  if null k2 then !*basis:=b_expand1(t1,t2,!*basis,!*basis)
  else if null k1 then addmsym(t1,t2,caar t1,cdr k2)
  else if null(car k1 eq car k2) then addmsym(t1,t2,cdr k1,k2)
  else (addmsym(t1,t2,cdr k1,k2)
          where zz:=addmsym0(t1,t2,msymperm0(car t1,car t2,k1,k2))
       )$

symbolic procedure addmsym0(t1,t2,pz)$
  (addmultsym1(th . cdr pv_difference(z,'!:pv . pappl_pv(car pz,cdr z)))
  )where th = ((caaar t1 . caar t2) . cdr pz . nil),
           z = pv_times('!:pv . cdr t1,'!:pv . cdr t2)$

symbolic procedure msymperm0(th1,th2,k1,k2)$
  begin scalar il1,il2,n0,nam1,nam2,w1,w2,zl$
    nam1:=car th1$
    nam2:=car th2$
    il1:=cadr th1$
    il2:=cadr th2$
    n0:=length il1$
    il2:=il_simp append(il1,il2)$
    zl:=il2$
    il1:=nil$
    for i:=1:n0 do << il1:=car il2 . il1$ il2:=cdr il2 >>$
    il1:=reversip il1$
    w1:=nil$
    while null(nam1 eq k1) do <<
      n0:=get(car nam1,'!:tensor)$
      for i:=1:n0 do << w1:=car il1 . w1$ il1:=cdr il1 >>$
      nam1:=cdr nam1$
    >>$
    w2:=nil$
    while null(nam2 eq k2) do <<
      n0:=get(car nam2,'!:tensor)$
      for i:=1:n0 do << w2:=car il2 . w2$ il2:=cdr il2 >>$
      nam2:=cdr nam2$
    >>$
    n0:=get(car nam1,'!:tensor)$
    for i:=1:n0 do <<
      w1:=car il2 . w1$
      w2:=car il1 . w2$
      il1:=cdr il1$
      il2:=cdr il2$
    >>$
    w1:=append(reversip w1,il1)$
    w2:=append(reversip w2,il2)$
    return pfind(append(w1,w2),zl) . zl$
  end$

symbolic procedure addmultsym_(t1,t2)$ nil$

symbolic procedure addmultsym__(t1,t2)$
  if caaar t1 neq caaar t2
    then !*basis:=b_expand1(t1,t2,!*basis,!*basis)
  else((addmultsym1(th .
                    cdr pv_difference(z,'!:pv . pappl_pv(car pz,cdr z)))
       )where th = ((caaar t1 . caar t2) . cdr pz . nil),
              z = pv_times('!:pv . cdr t1,'!:pv . cdr t2)
      )where pz = msymperm(cadar t1,cadar t2)
%            ,zz = b_expand1(t1,t2,!*basis,!*basis)     %  Aug. 06, 1994
  $

symbolic procedure msymperm(il1,il2)$
  begin scalar zl,w,k;
    k:=length il1;
    zl:=il_simp append(il1,il2)$
    il2:=zl;
    for i:=1:k do << w:=car il2 . w; il2:=cdr il2>>;
    il1:=reversip w;
    w:=nil;
    for i:=1:k do << w:=car il2 . w; il2:=cdr il2>>;
    w:=reversip w;
    return pfind(append(w,append(il1,il2)),zl) . zl;
  end$

symbolic procedure addmultsym2(t1,t2,bs)$
  if null bs then nil
  else if null th_match0(car t2,caar bs)
         then addmultsym2(t1,t2,cdr bs)
  else rederr list "b_xpand?"$

symbolic procedure addmultsym1(te)$
  !*basis:=tsym2(list te,!*basis,nil)$

symbolic procedure pkt(t1)$ car t1 . pkpv(cdr t1,nil)$

symbolic procedure pkpv(pv,ppv)$
  if null pv then reversip ppv
  else pkpv(cdr pv,(caar pv . pkp cdar pv) . ppv)$

symbolic procedure t_difference(u,v)$
  t_plus(u,t_minus v)$

symbolic procedure t_zerop(u)$ null cdr u$

symbolic procedure t_onep u$ cdr u = 1$

symbolic procedure t_prep u$                         % mod. AK 28/03/96
  (if not(cddr caadr u = 1) then 'quotient . x . list cddr caadr u
   else x)
  where x=t_prep1(cdr u,nil)$

symbolic procedure t_prep1(u,v)$
  if null u
    then if null v then nil
         else if cdr v then 'plus . reversip v
         else car v
  else t_prep1(cdr u,th2pe(caar u,cdar u) . v)$

%symbolic procedure t_prep u$ th2pe(cadr u,cddr u)$

symbolic procedure t_pri(u)$ t_pri1(u,nil)$

symbolic procedure t_intequiv u$
  atom cdr u$

symbolic procedure i2tensor n$
  '!:tensor . n$

symbolic procedure t_expt(u,n)$
  if n=1 then u
  else if atom cdr u then cdr u^n
  else rederr list('t_expt,"*** Can't powered tensor")$

symbolic procedure t_quotient(u,c)$
  if t_intequiv c and cdr c = 1 then u
  else rederr list('t_quotient,"*** Tensor can't be divided by: ",c)$

symbolic procedure t_divide(u,v)$
  rederr list('t_divide,"*** Can't divide tensor by tensor")$

symbolic procedure t_gcd(u,v)$                   % AK 28/03/96
  if atom cdr v then 1
  else rederr list('t_gcd,"*** Can't find gcd of two tensors")$

initdmode 'tensor$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/perm1.red0000644000175000017500000001617011526203062023704 0ustar  giovannigiovanni%======================================================
%       Name:           PERM1 - permutation package
%       Author:         A.Kryukov (kryukov@theory.npi.msu.su)
%       Copyright:      (C), 1993-1996, A.Kryukov
%       Version:        2.32
%       Release:        Nov. 12, 1993
%                       Mar. 28, 1996     PFIND: add error msg.
%======================================================

module perm1$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*ppacked)$
!*ppacked:=t$

%-------------------------------------------------------
%       Generator of permutations.
%       Version 1.2.1   Nov. 18, 1994
%
%-------------------------------------------------------

procedure GPerm n$        % order of symmetric group.
  %       Return all pertmutation of S(n).
  begin scalar l$
%    if n>9 then rederr list('GPerm,": ",n," is too high order (<=9).")$
    while n>0 do << l:=n . l$ n:=n-1 >>$
    return for each x in GPerm0 l collect pkp x$
end$

 procedure GPerm0(OLst)$
   %       OLst    - list of objects.
   %       Return  - list of permutation of these objects.
   if null OLst then nil
   else GPerm3(cdr OLst,list list car OLst)$

 procedure GPerm3(OList,Res)$
   %       OList   - list of objects,
   %       Res     - list of perm. of objects.
   if null OList then Res
   else GPerm3(cdr OList,GPerm2(Res,car OList,nil))$

 procedure GPerm2(PLst,Obj,Res)$
   %       Obj     - object,
   %       PLst    - permutation list,
   %       Res     - list of perm. included Obj.
   if null PLst then Res
   else GPerm2(cdr PLst,Obj,GPerm1(Rev(car PLst,nil),Obj,nil,Res))$

 procedure GPerm1(L,Obj,R,Res)$
   %       Obj     - object,
   %    L,R     - left(reverse form) and right(direct form) part of
   %                 permutation.
   %       Res     - list of permutation.
   if null L then (Obj . R) . Res
   else GPerm1(cdr L,Obj,car L . R,Rev(L,Obj . R) . Res)$

 procedure Rev(Lst,RLst)$
   if null Lst then RLst
   else Rev(cdr Lst, car Lst . RLst)$

%-------------------------------------------------------

symbolic procedure mkunitp k$
  begin scalar p$
    for i:=1:k do p:=i . p$
    return pkp reversip p$
  end$

symbolic procedure pfind(l1,l2)$
  % l1,l2 - (paked) lists of indices.
  begin scalar p,z$
        integer m$
    l1:=unpkp l1$
    l2:=unpkp l2$
    m:=length l2 + 1$
    l2:=for each x in l2 collect x$
    for each x in l1 do <<
      z:=member(x,l2)$
      if null z
        then rederr list("PFIND: No index",x,"in",l2)$ %+ AK 28/03/96
      p:=(m - length z) . p$
      rplaca(z,'nil!*)$
    >>$
    return pkp reversip p$
  end$

symbolic procedure prev(f)$
  begin scalar p,w$
        integer i,j,l$
    f:=unpkp f$
    l:=length f$
    for i:=1:l do <<
      w:=f$
      j:=1$
      while not(car w = i) do << j:=j+1$ w:=cdr w >>$
      p:=j . p$
    >>$
    return pkp reversip p$
  end$

symbolic procedure psign(f)$
  begin integer s,i,j,n,k$
    scalar new0,new,wnew,f0,wf$
    s:=1$
    f:=unpkp f$
    n:=length f$
    f0:=f$
    new0:=for each x in f collect t$
    new:=new0$
    for i:=1:n do <<
      if car new then                  % find cycle contained i
        << j:=car f$
           while not(j = i) do <<
             wnew:=new0$
             wf:=f0$
             for k:=1:j-1 do << wnew:=cdr wnew$ wf:=cdr wf >>$
             rplaca(wnew,nil)$
             s:=-s$
             j:=car wf$
           >>$
        >>$
      new:=cdr new$
      f:=cdr f$
    >>$ % for i
    return s$
  end$

symbolic procedure pmult(f,g)$
  begin scalar p,w,ok$
        integer i$
    f:=unpkp f$
    g:=unpkp g$
    while g do <<
      w:=f$
      for i:=1:(car g - 1) do w:=cdr w$
      p:=car w . p$
      g:=cdr g$
    >>$
    return pkp reversip p$
  end$

symbolic procedure pappl(p,l)$
  begin scalar l1,w$
        integer i$
    p:=unpkp p$
    while p do <<
      w:=l$
      for i:=1:(car p - 1) do w:=cdr w$
      l1:=car w . l1$
      p:=cdr p$
    >>$
    return reversip l1$
  end$

symbolic procedure pappl0(p1,p2)$
  pkp pappl(p1,unpkp p2)$

symbolic procedure pupright(p,d)$
  begin scalar w,i,k$
     p:=unpkp p$
     k:=(length p + 1)$
     d:=k+d-1$
     for i:=k:d do w:=i . w$
     return pkp append(p,reversip w)$
  end$

symbolic procedure pupleft(p,d)$
  begin scalar w,i$
     p:=unpkp p$
     p:=for each x in p collect (x+d)$
     for i:=1:d do w:=i . w$
     return pkp append(reversip w,p)$
  end$

symbolic procedure pappend(p1,p2)$
  begin scalar l;
    p1:=unpkp p1;
    l:=length p1;
    p2:=unpkp p2;
    p2:=for each x in p2 collect (x + l)$
    return pkp append(p1,p2)$
  end$

%--------------------------------------------------------

global '(diglist!*)$
diglist!*:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
             (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0))$

symbolic procedure dssoc(x,u)$
  if null u then nil
  else if x=cdar u then car u
  else dssoc(x,cdr u)$

%symbolic procedure hugerank()$ 3$

symbolic procedure pkp p$
  begin scalar w,huge,z$
    if atom p or null !*ppacked then return p$
    huge:=(length p >= 10)$
    for each x in p do
      if huge then <<
        if x<10 then w := car dssoc(x,diglist!*) . '!0 . w
        else << z:=divide(x,10)$
                w := car dssoc(car z,diglist!*) . w$
                w := car dssoc(cdr z,diglist!*) . w$
              >>$
      >>
      else w:=car dssoc(x,diglist!*) . w$

    return compress reversip w$
  end$

symbolic procedure unpkp p$
  begin scalar w,huge,z$
    if null atom p then return p$
    p:=explode p$
    huge:=(length p >=10)$
    if huge and null evenp length p then p := '!0 . p$
    while p do <<
      if huge then <<
          z:=cdr assoc(car p,diglist!*)$
          p:=cdr p$
          w:= (z*10+cdr assoc(car p,diglist!*)) . w$
        >>
      else w:=cdr assoc(car p,diglist!*) . w$
      p:=cdr p$
    >>$
    return reversip w$
  end$

symbolic procedure porder p $
  length unpkp p$

symbolic procedure hugep p$
  <<
     p:=unpkp p$
     if length p >= 10 then list p else nil
  >>$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/atensor.ps0000644000175000017500000110016511526203062024202 0ustar  giovannigiovanni%!PS-Adobe-2.0
%%Creator: dvipsk 5.58e Copyright 1986, 1994 Radical Eye Software
%%Title: at4cpc7g.dvi
%%Pages: 21
%%PageOrder: Ascend
%%BoundingBox: 0 0 596 842
%%EndComments
%DVIPSCommandLine: dvips at4cpc7g.dvi
%DVIPSParameters: dpi=300, comments removed
%DVIPSSource:  TeX output 1996.04.10:1440
%%BeginProcSet: tex.pro
/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
ifelse}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
a}B /bos{/SS save N}B /eos{SS restore}B end
%%EndProcSet
TeXDict begin 39158280 55380996 1000 300 300 (at4cpc7g.dvi)
@start /Fa 72 123 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F870000000000070F8
F8F870051C779B18>33 D<4010E038F078E038E038E038E038E038E038E038E038E038E0
3860300D0E7B9C18>I<00C00001C00001C00001C00003F0000FFC003FFE007DCF0071C7
00E1C380E1C780E1C780E1C780F1C00079C0003DC0001FE0000FF80003FC0001DE0001CF
0001C70061C380F1C380F1C380E1C380E1C70071C70079DE003FFE001FF80007E00001C0
0001C00001C00000C00011247D9F18>36 D<3803007C07807C0780EE0F80EE0F00EE0F00
EE1F00EE1E00EE1E00EE3E007C3C007C3C00387C0000780000780000F80000F00001F000
01E00001E00003E00003C00003C00007C0000783800787C00F87C00F0EE00F0EE01F0EE0
1E0EE01E0EE03E0EE03C07C03C07C018038013247E9F18>I<01C00007E0000FF0000E70
001C38001C38001C38001C38001C73F01C73F01CE3F00FE3800FC7000F87000F07001F0E
003F0E007B8E0073DC00E1DC00E0F800E0F800E07070E0787070FC707FFFE03FCFE00F03
C0141C7F9B18>I<007000F001E003C007800F001E001C00380038007000700070007000
E000E000E000E000E000E000E000E0007000700070007000380038001C001E000F000780
03C001F000F000700C24799F18>40 D<6000F00078003C001E000F000780038001C001C0
00E000E000E000E00070007000700070007000700070007000E000E000E000E001C001C0
038007800F001E003C007800F00060000C247C9F18>I<01C00001C00001C00001C000C1
C180F1C780F9CF807FFF001FFC0007F00007F0001FFC007FFF00F9CF80F1C780C1C18001
C00001C00001C00001C00011147D9718>I<00600000F00000F00000F00000F00000F000
00F00000F0007FFFC0FFFFE0FFFFE07FFFC000F00000F00000F00000F00000F00000F000
00F00000600013147E9718>I<1C3E7E7F3F1F070E1E7CF860080C788518>I<7FFF00FFFF
80FFFF807FFF0011047D8F18>I<3078FCFC78300606778518>I<01F00007FC000FFE001F
1F001C07003803807803C07001C07001C0E000E0E000E0E000E0E000E0E000E0E000E0E0
00E0E000E0E000E0F001E07001C07001C07803C03803801C07001F1F000FFE0007FC0001
F000131C7E9B18>48 D<01800380038007800F803F80FF80FB8043800380038003800380
0380038003800380038003800380038003800380038003807FFCFFFE7FFC0F1C7B9B18>
I<03F0000FFE003FFF007C0F807003C0E001C0F000E0F000E06000E00000E00000E00001
C00001C00003C0000780000F00001E00003C0000780000F00001E00007C0000F80001E00
E03C00E07FFFE0FFFFE07FFFE0131C7E9B18>I<07F8001FFE003FFF007807807803C078
01C03001C00001C00003C0000380000F0003FF0003FE0003FF000007800003C00001C000
00E00000E00000E0F000E0F000E0F001C0F003C07C07803FFF001FFE0003F800131C7E9B
18>I<001F00003F0000770000770000E70001E70001C7000387000787000707000E0700
1E07003C0700380700780700F00700FFFFF8FFFFF8FFFFF8000700000700000700000700
000700000700007FF000FFF8007FF0151C7F9B18>I<1FFF803FFF803FFF803800003800
003800003800003800003800003800003800003BF8003FFE003FFF003C07801803C00001
C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001FFC0003F000131C
7E9B18>I<007E0001FF0007FF800F83C01E03C01C03C0380180380000700000700000E1
F800E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000E07000E07000E038
01C03C03C01E07800FFF0007FE0001F800131C7E9B18>II<03F8000FFE001FFF003E0F803803807001C07001C07001C07001
C03803803C07801FFF0007FC000FFE001F1F003C07807001C0F001E0E000E0E000E0E000
E0E000E07001C07803C03E0F801FFF000FFE0003F800131C7E9B18>I<03F0000FFC001F
FE003C0F00780780700380E001C0E001C0E001C0E001E0E001E07001E07803E03C0FE01F
FFE00FFEE003F0E00000E00001C00001C00001C0300380780780780F00783E003FFC001F
F00007C000131C7E9B18>I<3078FCFC783000000000000000003078FCFC783006147793
18>I<183C7E7E3C180000000000000000183C7E7E3E1E0E1C3C78F060071A789318>I<7F
FFC0FFFFE0FFFFE0FFFFE0000000000000000000000000FFFFE0FFFFE0FFFFE07FFFC013
0C7E9318>61 D<007C0001FE0007FF000F87801E03C03C1DC0387FC070FFE071E3E071C1
E0E1C1E0E380E0E380E0E380E0E380E0E380E0E380E0E1C1C071C1C071E3C070FF80387F
003C1C001E00E00F83E007FFC001FF80007E00131C7E9B18>64 D<00700000F80000F800
00D80000D80001DC0001DC0001DC00018C00038E00038E00038E00038E00030600070700
0707000707000707000FFF800FFF800FFF800E03800E03801C01C01C01C07F07F0FF8FF8
7F07F0151C7F9B18>II<00F8E003FEE007
FFE00F07E01E03E03C01E03800E07000E07000E0700000E00000E00000E00000E00000E0
0000E00000E00000E000007000007000E07000E03800E03C00E01E01C00F07C007FF8003
FE0000F800131C7E9B18>I<7FF800FFFE007FFF001C0F801C03C01C03C01C01E01C00E0
1C00E01C00F01C00701C00701C00701C00701C00701C00701C00701C00701C00F01C00E0
1C00E01C01E01C01C01C03C01C0F807FFF00FFFE007FF800141C7F9B18>III<01F1C0
03FDC00FFFC01F0FC01C03C03803C03801C07001C07001C0700000E00000E00000E00000
E00000E00000E00FF0E01FF0E00FF07001C07001C07003C03803C03803C01C07C01F0FC0
0FFFC003FDC001F1C0141C7E9B18>I<7FFF00FFFF807FFF0001C00001C00001C00001C0
0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0
0001C00001C00001C00001C00001C00001C0007FFF00FFFF807FFF00111C7D9B18>73
D<7F07F0FF87F87F07F01C03C01C07801C07001C0E001C1E001C3C001C38001C70001CF0
001DF0001DF0001FB8001FB8001F1C001E1C001C0E001C0E001C07001C07001C03801C03
801C01C07F03F0FF87F87F03F0151C7F9B18>75 D<7FE000FFE0007FE0000E00000E0000
0E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0000
0E00000E00000E00000E00700E00700E00700E00700E00707FFFF0FFFFF07FFFF0141C7F
9B18>II<7E07F0FF0FF87F07F01D81C01D
81C01D81C01DC1C01CC1C01CC1C01CE1C01CE1C01CE1C01C61C01C71C01C71C01C31C01C
39C01C39C01C39C01C19C01C19C01C1DC01C0DC01C0DC01C0DC07F07C0FF87C07F03C015
1C7F9B18>I<0FF8003FFE007FFF00780F00700700F00780E00380E00380E00380E00380
E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380E00380
F00780700700780F007FFF003FFE000FF800111C7D9B18>II<7FF800FFFE007FFF001C0F801C03801C03C01C01C01C01C01C01C01C
03C01C03801C0F801FFF001FFE001FFE001C0F001C07001C03801C03801C03801C03801C
03801C039C1C039C1C039C7F01F8FF81F87F00F0161C7F9B18>82
D<03F3801FFF803FFF807C0F80700780E00380E00380E00380E000007000007800003F00
001FF00007FE0000FF00000F800003C00001C00000E00000E06000E0E000E0E001E0F001
C0F80780FFFF80FFFE00E7F800131C7E9B18>I<7FFFF8FFFFF8FFFFF8E07038E07038E0
7038E0703800700000700000700000700000700000700000700000700000700000700000
700000700000700000700000700000700000700000700007FF0007FF0007FF00151C7F9B
18>IIII<1FE0003FF8007FFC00781E00
300E0000070000070000FF0007FF001FFF007F0700780700E00700E00700E00700F00F00
781F003FFFF01FFBF007E1F014147D9318>97 D<7E0000FE00007E00000E00000E00000E
00000E00000E00000E3E000EFF800FFFC00FC1E00F80E00F00700E00700E00380E00380E
00380E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF80063E00151C809B
18>I<01FE0007FF001FFF803E0780380300700000700000E00000E00000E00000E00000
E00000E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F
80003F80001F8000038000038000038000038000038003E3800FFB801FFF803C1F80380F
80700780700380E00380E00380E00380E00380E00380E00380700780700780380F803C1F
801FFFF00FFBF803E3F0151C7E9B18>I<01F00007FC001FFE003E0F0038078070038070
0380E001C0E001C0FFFFC0FFFFC0FFFFC0E000007000007001C03801C03E03C01FFF8007
FF0001FC0012147D9318>I<001F80007FC000FFE000E1E001C0C001C00001C00001C000
7FFFC0FFFFC0FFFFC001C00001C00001C00001C00001C00001C00001C00001C00001C000
01C00001C00001C00001C00001C0007FFF007FFF007FFF00131C7F9B18>I<01E1F007FF
F80FFFF81E1E301C0E003807003807003807003807003807001C0E001E1E001FFC001FF8
0039E0003800001C00001FFE001FFFC03FFFE07801F0700070E00038E00038E00038E000
387800F07E03F01FFFC00FFF8001FC00151F7F9318>I<7E0000FE00007E00000E00000E
00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E00E00E00E
00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC17
1C809B18>I<03800007C00007C00007C0000380000000000000000000000000007FC000
FFC0007FC00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000
01C00001C00001C00001C000FFFF00FFFF80FFFF00111D7C9C18>I<0038007C007C007C
003800000000000000000FFC1FFC0FFC001C001C001C001C001C001C001C001C001C001C
001C001C001C001C001C001C001C001C001C001C001C001C6038F078FFF07FE03F800E27
7E9C18>II<7FE000FFE0007FE00000E000
00E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000
00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0
131C7E9B18>I<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C
1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C
1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C00F80
E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE001FFF003E0F803803807001C070
01C0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F801FFF000F
FE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1E00F80E00F00700E00700E0038
0E00380E00380E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF800E3E00
0E00000E00000E00000E00000E00000E00000E00007FC000FFE0007FC000151E809318>
I<01E38007FB801FFF803E1F80380F80700780700780E00380E00380E00380E00380E003
80E00380700780700780380F803C1F801FFF800FFB8003E3800003800003800003800003
80000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF07FBFF803
F87803F03003E00003C00003C00003800003800003800003800003800003800003800003
80000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E00700
E00700E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F80F00
FFFF00FFFC00E7F00011147D9318>I<0180000380000380000380000380007FFFC0FFFF
C0FFFFC00380000380000380000380000380000380000380000380000380000380400380
E00380E00380E001C1C001FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07E00E
00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8FF0FF8FF87F8FF01E03C00E0380
0E03800E0380070700070700070700038E00038E00038E00038E0001DC0001DC0001DC00
00F80000F80000700015147F9318>II<7F8FF07F9FF07F8FF0070700078E00039E0001DC0001F80000
F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF87F8FF015
147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E0380070380070700070700038700
038600038E0001CE0001CE0000CC0000CC0000DC00007800007800007800007000007000
00700000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I<3FFFF07FFF
F07FFFF07001E07003C0700780000F00001E00003C0000F80001F00003C0000780000F00
701E00703C0070780070FFFFF0FFFFF0FFFFF014147F9318>I E
/Fb 18 90 df<000000060000000006000000000E000000001E000000001E000000003E
000000003E000000007E00000000BE00000000BF000000013F000000011F000000021F00
0000041F000000041F000000081F000000081F000000101F000000201F000000201F8000
00401F800000400F800000800F800001000F800001000F800002000F800002000F800007
FFFF80000FFFFF800008000FC000100007C000300007C000200007C000400007C0004000
07C000800007C001800007C001000007C003000007C00F80000FE0FFE000FFFFFFE000FF
FE282A7EA92C>65 D<003FFFFFE000003FFFFFF8000001F8007C000001F0003E000001F0
001F000001F0000F000001F0000F800003E0000F800003E0000F800003E0000F800003E0
000F800007C0000F000007C0001F000007C0001E000007C0003E00000F80007C00000F80
00F800000F8003E000000F800F8000001FFFFE0000001F0007C000001F0001E000001F00
00F000003E0000F800003E00007800003E00007C00003E00007C00007C00007C00007C00
007C00007C00007C00007C00007C0000F80000F80000F80000F80000F80001F00000F800
03E00001F00003E00001F0000FC00001F0001F000003F000FE00007FFFFFF80000FFFFFF
C0000029297EA82C>I<000003FC008000001FFF008000007E0381800001F00043800007
C0002700000F00001F00001E00001F00003C00000F00007800000E0000F000000E0001E0
0000060003C00000060007C0000004000780000004000F80000004001F00000004001F00
000000003E00000000003E00000000003E00000000007C00000000007C00000000007C00
000000007C00000000007C0000000000F80000000000F80000000000F80000000000F800
000040007800000040007800000040007800000080007C00000080003C00000100003C00
000200001E00000200001E00000C00000F000018000007800030000003E000C0000001F8
07800000007FFE000000000FF0000000292B7EA92A>I<003FFFFFE000003FFFFFFC0000
01F8007E000001F0000F000001F00007800001F00003C00001F00001E00003E00001E000
03E00000F00003E00000F00003E00000F00007C00000F80007C00000F80007C00000F800
07C00000F8000F800000F8000F800000F8000F800000F8000F800000F8001F000001F000
1F000001F0001F000001F0001F000001F0003E000003E0003E000003E0003E000003C000
3E000007C0007C00000780007C00000F80007C00000F00007C00001E0000F800001E0000
F800003C0000F80000780000F80000F00001F00001E00001F00007C00001F0001F000003
F000FC00007FFFFFF00000FFFFFF8000002D297EA831>I<003FFFFFFFC0003FFFFFFFC0
0001F8000FC00001F00003C00001F00001C00001F00000C00001F00000C00003E0000080
0003E00000800003E00000800003E00000800007C00000800007C00400800007C0040080
0007C0040000000F80080000000F80080000000F80180000000F80780000001FFFF00000
001FFFF00000001F00700000001F00300000003E00200000003E00200000003E00200200
003E00200400007C00400400007C00000400007C00000800007C0000080000F800001800
00F80000100000F80000300000F80000200001F00000600001F00000E00001F00003C000
03F0001FC0007FFFFFFFC000FFFFFFFF80002A297EA82B>I<003FFFE0FFFF80003FFFE0
FFFF800001F80007E0000001F00007C0000001F00007C0000001F00007C0000001F00007
C0000003E0000F80000003E0000F80000003E0000F80000003E0000F80000007C0001F00
000007C0001F00000007C0001F00000007C0001F0000000F80003E0000000F80003E0000
000F80003E0000000F80003E0000001FFFFFFC0000001FFFFFFC0000001F00007C000000
1F00007C0000003E0000F80000003E0000F80000003E0000F80000003E0000F80000007C
0001F00000007C0001F00000007C0001F00000007C0001F0000000F80003E0000000F800
03E0000000F80003E0000000F80003E0000001F00007C0000001F00007C0000001F00007
C0000003F0000FC000007FFF81FFFE0000FFFF83FFFE000031297EA830>72
D<003FFFE0003FFFE00001F8000001F0000001F0000001F0000001F0000003E0000003E0
000003E0000003E0000007C0000007C0000007C0000007C000000F8000000F8000000F80
00000F8000001F0000001F0000001F0000001F0000003E0000003E0000003E0000003E00
00007C0000007C0000007C0000007C000000F8000000F8000000F8000000F8000001F000
0001F0000001F0000003F00000FFFF8000FFFF80001B297EA81A>I<003FFFE003FFC000
3FFFE003FF800001F80000FC000001F00000E0000001F0000080000001F0000100000001
F0000200000003E0000800000003E0001000000003E0002000000003E0004000000007C0
010000000007C0020000000007C0040000000007C008000000000F8020000000000F8070
000000000F80F0000000000F81F0000000001F04F8000000001F08F8000000001F10FC00
0000001F407C000000003E807C000000003F003E000000003E003E000000003E003F0000
00007C001F000000007C001F000000007C001F800000007C000F80000000F8000FC00000
00F80007C0000000F80007C0000000F80007E0000001F00003E0000001F00003F0000001
F00003F0000003F00003F800007FFF803FFF8000FFFF803FFF800032297EA832>75
D<003FFFF000003FFFF0000001F800000001F000000001F000000001F000000001F00000
0003E000000003E000000003E000000003E000000007C000000007C000000007C0000000
07C00000000F800000000F800000000F800000000F800000001F000000001F000000001F
000000001F000000003E000000003E000000003E000000003E000010007C000020007C00
0020007C000040007C00004000F80000C000F800008000F800018000F800030001F00007
0001F0000F0001F0003E0003F000FE007FFFFFFE00FFFFFFFC0024297EA828>I<003FF8
000001FFE0003FF8000001FFE00001F8000002F800000178000003F000000178000005F0
00000178000009F00000013C000009F00000023C000013E00000023C000023E00000023C
000023E00000023C000043E00000043C000047C00000043C000087C00000043C000107C0
0000041E000107C00000081E00020F800000081E00040F800000081E00040F800000081E
00080F800000101E00081F000000101E00101F000000100F00201F000000100F00201F00
0000200F00403E000000200F00803E000000200F00803E000000200F01003E000000400F
02007C000000400F02007C000000400784007C000000400784007C00000080078800F800
000080079000F800000080079000F80000008007A000F80000010007C001F00000010007
C001F000000300038001F000000780038003F000007FF803007FFF8000FFF80200FFFF80
003B297EA839>I<003FF8000FFF80003FFC000FFF800000FC0000F80000017E00006000
00013E0000400000013E0000400000011F0000400000021F0000800000021F8000800000
020F8000800000020F80008000000407C0010000000407C0010000000407E00100000004
03E0010000000803E0020000000801F0020000000801F0020000000801F8020000001000
F8040000001000F80400000010007C0400000010007C0400000020007E0800000020003E
0800000020003E0800000020001F0800000040001F1000000040001F9000000040000F90
00000040000F90000000800007E0000000800007E0000000800007E0000000800003E000
0001000003C0000001000001C0000003000001C0000007800001C000007FF80000800000
FFF8000080000031297EA82F>I<000003FC000000001C0780000000F001C0000001C000
F000000700007800000E00003C00003C00001C00007800001E0000F000000E0001E00000
0F0001E000000F0003C000000F00078000000F80078000000F800F0000000F801F000000
0F801F0000000F803E0000000F803E0000000F803E0000000F807C0000001F007C000000
1F007C0000001F007C0000001F007C0000003E00F80000003E00F80000007C00F8000000
7C00F80000007800F8000000F80078000001F00078000001E0007C000003E0007C000003
C0003C00000780003C00000F00001E00001E00000E00003C00000F0000700000078001E0
000001C00780000000F01E000000001FF0000000292B7EA92D>I<003FFFFFE000003FFF
FFF8000001F8007E000001F0001F000001F0000F000001F00007800001F00007800003E0
0007C00003E00007C00003E00007C00003E00007C00007C0000F800007C0000F800007C0
000F000007C0001F00000F80001E00000F80003C00000F80007800000F8001F000001F00
07C000001FFFFE0000001F00000000001F00000000003E00000000003E00000000003E00
000000003E00000000007C00000000007C00000000007C00000000007C0000000000F800
00000000F80000000000F80000000000F80000000001F00000000001F00000000001F000
00000003F0000000007FFF80000000FFFF800000002A297EA826>I<003FFFFF8000003F
FFFFE0000001F801F8000001F0003C000001F0001E000001F0001F000001F0000F000003
E0000F800003E0000F800003E0000F800003E0000F800007C0001F000007C0001F000007
C0001E000007C0003E00000F80007C00000F80007800000F8001E000000F8003C000001F
001E0000001FFFF00000001F003C0000001F000F0000003E000F8000003E0007C000003E
0007C000003E0007C000007C0007C000007C0007C000007C0007C000007C0007C00000F8
000F800000F8000F800000F8000F800000F8000F800001F0000F008001F0000F008001F0
000F008003F0000F01007FFF80070200FFFF8003840000000000F800292A7EA82D>82
D<00003F80400000FFE0400003C078C000070019C0000E000F8000180007800038000380
0070000380006000030000E000030000E000030000E000030001E000020001E000020001
F000000000F000000000F800000000FF000000007FF00000003FFF0000001FFF8000000F
FFE0000001FFE00000001FF000000003F800000000F80000000078000000007800000000
3800100000380010000038001000003800300000700030000070003000006000300000E0
00700001C00078000180007C0007000066000E0000C3C03C0000C0FFF00000803FC00000
222B7DA924>I<0FFFFFFFFE0FFFFFFFFE1F801F003E1C003E000E18003E000C30003E00
0430003E000420007C000420007C000440007C000C40007C00084000F800088000F80008
8000F800080000F800000001F000000001F000000001F000000001F000000003E0000000
03E000000003E000000003E000000007C000000007C000000007C000000007C00000000F
800000000F800000000F800000000F800000001F000000001F000000001F000000001F00
0000003E000000003E000000003E000000007E0000007FFFFC00007FFFFC000027297FA8
22>I<7FFFC01FFF7FFFC01FFF03F00001F003E00000C003E000008003E000008003E000
008007C000010007C000010007C000010007C00001000F800002000F800002000F800002
000F800002001F000004001F000004001F000004001F000004003E000008003E00000800
3E000008003E000008007C000010007C000010007C000010007C00001000F800002000F8
00002000F800002000F800004000F800004000F800008000F80000800078000100007800
02000078000400003C001800001E003000000F81E0000007FF80000000FE000000282A7C
A828>I<7FFF0000FFE0FFFF0001FFC007F000003E0003F00000300003F00000200001F0
0000400001F80000800001F80001000000F80003000000FC0002000000FC00040000007C
00080000007E00100000007E00200000003E00600000003F00400000003F00800000001F
01000000001F82000000001F84000000000F88000000000FD8000000000FD00000000007
E00000000007C00000000007C0000000000780000000000F80000000000F80000000000F
80000000000F00000000001F00000000001F00000000001F00000000001E00000000003E
00000000003E00000000003E00000000007E000000000FFFF00000001FFFF00000002B29
7FA822>89 D E /Fc 7 111 df<07C01FF03C78783C783CF83EF83EF83EF83EF83EF83E
F83EF83EF83EF83EF83E783C783C3C781FF007C00F157E9414>48
D68
D73 D75 D77 D<07F1801FFF80381F8070
0780F00780F00380F80380FE0000FFF0007FFC007FFE003FFF000FFF8003FFC0001FC000
07C0E003C0E003C0E00380F00380FC0700FFFE00C7F80012177E9617>83
D110 D E /Fd 47 122 df<3C0078007F00FE00FF
81FF00FF81FF00FFC1FF80FFC1FF80FFC1FF807FC0FF803EC07D8000C0018000C0018001
8003000180030001800300030006000300060006000C000E001C001C0038003800700030
00600019157EA923>34 D45
D<1C007F007F00FF80FF80FF807F007F001C0009097B8813>I<003F800001FFF00007E0
FC000FC07E001F803F001F001F003F001F803E000F807E000FC07E000FC07E000FC07E00
0FC0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE0FE00
0FE0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE0FE000FE07E000FC07E000FC07E00
0FC07E000FC03F001F803F001F801F001F001F803F000FC07E0007E0FC0001FFF000003F
80001B277DA622>48 D<000E00001E00007E0007FE00FFFE00FFFE00F8FE0000FE0000FE
0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622>I<00FF800007FFF0000FFF
FC001E03FE003800FF807C003F80FE003FC0FF001FC0FF001FE0FF000FE0FF000FE07E00
0FE03C001FE000001FE000001FC000001FC000003F8000003F0000007E000000FC000000
F8000001F0000003E00000078000000F0000001E0000003C00E0007000E000E000E001C0
01C0038001C0060001C00FFFFFC01FFFFFC03FFFFFC07FFFFFC0FFFFFF80FFFFFF80FFFF
FF801B277DA622>I<007F800003FFF00007FFFC000F80FE001F007F003F807F003F803F
803F803F803F803F801F803F801F003F8000007F0000007F0000007E000000FC000001F8
000007F00000FFC00000FFC0000001F80000007E0000003F0000003F8000001FC000001F
C000001FE000001FE03C001FE07E001FE0FF001FE0FF001FE0FF001FC0FF003FC0FE003F
807C007F003F00FE001FFFFC0007FFF00000FF80001B277DA622>I<00000E0000001E00
00003E0000007E000000FE000000FE000001FE000003FE0000077E00000E7E00000E7E00
001C7E0000387E0000707E0000E07E0000E07E0001C07E0003807E0007007E000E007E00
0E007E001C007E0038007E0070007E00E0007E00FFFFFFF8FFFFFFF8FFFFFFF80000FE00
0000FE000000FE000000FE000000FE000000FE000000FE000000FE00007FFFF8007FFFF8
007FFFF81D277EA622>I<180003001F801F001FFFFE001FFFFC001FFFF8001FFFF0001F
FFC0001FFF00001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C
7FC0001DFFF8001F80FC001E003F0008003F0000001F8000001FC000001FC000001FE000
001FE018001FE07C001FE0FE001FE0FE001FE0FE001FE0FE001FC0FC001FC078003F8078
003F803C007F001F01FE000FFFFC0003FFF00000FF80001B277DA622>I<0007F800003F
FE0000FFFF0001FC078003F00FC007C01FC00F801FC01F801FC01F001FC03F000F803F00
00007E0000007E0000007E000000FE020000FE1FF000FE3FFC00FE603E00FE801F00FF80
1F80FF000FC0FF000FC0FE000FE0FE000FE0FE000FE0FE000FE07E000FE07E000FE07E00
0FE07E000FE03E000FE03F000FC01F000FC01F001F800F801F0007E07E0003FFFC0001FF
F800003FC0001B277DA622>I<380000003E0000003FFFFFF03FFFFFF03FFFFFF07FFFFF
E07FFFFFC07FFFFF807FFFFF0070000E0070000E0070001C00E0003800E0007000E000E0
000001E0000001C000000380000007800000070000000F0000001F0000001E0000003E00
00003E0000007E0000007C0000007C000000FC000000FC000000FC000000FC000001FC00
0001FC000001FC000001FC000001FC000001FC000001FC000000F80000007000001C297C
A822>I<003FC00001FFF00003FFFC0007C07E000F003F001E001F001E000F803E000F80
3E000F803F000F803F800F803FC00F803FF01F001FFC1E001FFE3C000FFFF8000FFFE000
07FFF80001FFFC0001FFFE0007FFFF000F0FFF801E03FFC03E01FFC07C007FE07C001FE0
F8000FE0F80007E0F80003E0F80003E0F80003E0F80003C07C0003C07E0007803F000F00
1FC03F000FFFFC0003FFF800007FC0001B277DA622>I<00000780000000000780000000
000FC0000000000FC0000000000FC0000000001FE0000000001FE0000000003FF0000000
003FF0000000003FF00000000077F80000000077F800000000F7FC00000000E3FC000000
00E3FC00000001C1FE00000001C1FE00000003C1FF0000000380FF0000000380FF000000
07007F80000007007F8000000F007FC000000E003FC000000E003FC000001C001FE00000
1C001FE000003FFFFFF000003FFFFFF000003FFFFFF00000700007F80000700007F80000
F00007FC0000E00003FC0000E00003FC0001C00001FE0001C00001FE0003C00001FF00FF
FE003FFFFCFFFE003FFFFCFFFE003FFFFC2E297EA833>65 D<00007FE0030007FFFC0700
1FFFFF0F007FF00F9F00FF0001FF01FC0000FF03F800007F07F000003F0FE000001F1FC0
00001F1FC000000F3F8000000F3F800000077F800000077F800000077F00000000FF0000
0000FF00000000FF00000000FF00000000FF00000000FF00000000FF00000000FF000000
00FF000000007F000000007F800000007F800000073F800000073F800000071FC0000007
1FC000000E0FE000000E07F000001C03F800003C01FC00007800FF0001F0007FF007C000
1FFFFF800007FFFE0000007FF00028297CA831>67 DII<00007FE003000007FFFC0700001FFFFF0F
00007FF00F9F0000FF0001FF0001FC0000FF0003F800007F0007F000003F000FE000001F
001FC000001F001FC000000F003F8000000F003F80000007007F80000007007F80000007
007F0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
00FF0000000000FF0000000000FF0000000000FF0000FFFFF87F0000FFFFF87F8000FFFF
F87F800000FF003F800000FF003F800000FF001FC00000FF001FC00000FF000FE00000FF
0007F00000FF0003F80000FF0001FC0000FF0000FF0001FF00007FF007FF00001FFFFF9F
000007FFFE0F0000007FF003002D297CA835>71 D73 D75 D80 D82 D<00FF00C003FFE1C00FFFF9C01F80FFC03F003FC03E000FC07C0007
C07C0007C0FC0003C0FC0003C0FC0001C0FE0001C0FE0001C0FF000000FFC000007FFC00
007FFFE0003FFFF8001FFFFE001FFFFF0007FFFF8003FFFFC000FFFFC0000FFFE000007F
E000001FF000000FF0000007F0E00003F0E00003F0E00003F0E00003F0F00003E0F00003
E0F80007E0FC0007C0FF000F80FFE01F80E3FFFF00E1FFFC00C01FF0001C297CA825>I<
7FFFFFFFFF807FFFFFFFFF807FFFFFFFFF807F807F807F807C007F800F8078007F800780
78007F80078070007F800380F0007F8003C0F0007F8003C0E0007F8001C0E0007F8001C0
E0007F8001C0E0007F8001C0E0007F8001C000007F80000000007F80000000007F800000
00007F80000000007F80000000007F80000000007F80000000007F80000000007F800000
00007F80000000007F80000000007F80000000007F80000000007F80000000007F800000
00007F80000000007F80000000007F80000000007F80000000007F80000000007F800000
00007F80000000FFFFFFC00000FFFFFFC00000FFFFFFC0002A287EA72F>II87 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F
003F803F801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F
801F803F803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF
803F839FFC1FFE0FFC03F803FC1E1B7E9A21>97 DI<003FF00001FFFC0003F03E000FC07F001F807F00
3F007F003F007F007F003E007E0000007E000000FE000000FE000000FE000000FE000000
FE000000FE000000FE0000007E0000007E0000007F0000003F0003803F8003801F800700
0FE00E0003F83C0001FFF800003FC000191B7E9A1E>I<00007FF000007FF000007FF000
0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
0007F0000007F0000007F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F
0007F07E0007F07E0007F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE
0007F0FE0007F0FE0007F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007
E07FFF01FFE7FF007F87FF202A7EA925>I<003FC00001FFF00003E07C000F803E001F80
1F001F001F003F000F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFF
FFC0FE000000FE000000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80
038007C0070003F01E0000FFFC00003FE0001A1B7E9A1F>I<0007F8003FFC007E3E01FC
7F03F87F03F07F07F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFF
C0FFFFC0FFFFC007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0
0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF
807FFF807FFF80182A7EA915>I<007F80F001FFE3F807C0FE1C0F807C7C1F003E7C1F00
3E103F003F003F003F003F003F003F003F003F003F003F003F001F003E001F003E000F80
7C0007C0F80005FFE0000C7F8000180000001C0000001C0000001E0000001FFFF8001FFF
FF000FFFFFC007FFFFE003FFFFF00FFFFFF03E0007F07C0001F8F80000F8F80000F8F800
00F8F80000F87C0001F07C0001F03F0007E00FC01F8007FFFF00007FF0001E287E9A22>
II<07000F80
1FC03FE03FE03FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE0
0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
0FE00FE0FFFEFFFEFFFE0F2B7EAA12>I107 DIII<003FE00001FFFC0003F07E000FC01F80
1F800FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8
FE0003F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E0
1F800FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22>II114
D<03FE300FFFF03E03F07800F07000F0F00070F00070F80070FE0000FFE0007FFF007FFF
C03FFFE01FFFF007FFF800FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC00
70FF01E0E7FFC0C1FF00161B7E9A1B>I<00700000700000700000700000F00000F00000
F00001F00003F00003F00007F0001FFFE0FFFFE0FFFFE007F00007F00007F00007F00007
F00007F00007F00007F00007F00007F00007F00007F00007F00007F07007F07007F07007
F07007F07007F07007F07003F0E001F8C000FFC0003F0014267FA51A>I
III121 D E /Fe 1 111 df<1C7C003EFE006F8E00CF0E
00CE0E000E0E000E0E001C1C001C1CC01C38C01C3980381F00180E00120D808C15>110
D E /Ff 6 110 df<07FFFC0FFFFE1FFFFC3FFFF870C600C0C60000C60001C600018E00
038E00038E00038E00070F00070F000F0F000F0F801E07800C070017127F9118>25
D<01FFE7FF8003FFE7FF80003C00F000003C00F000003C00F000003C00F000007801E000
007801E000007801E000007801E00000F003C00000F003C00000FFFFC00000FFFFC00001
E007800001E007800001E007800001E007800003C00F000003C00F000003C00F000003C0
0F000007801E000007801E000007801E000007801E0000FFF3FFE000FFF3FFC000211C7E
9B23>72 D<01FF0001FF03FF0003FF003F0003E0003F0007E0003F000DE0003F000DE000
67801BC00067801BC000678033C000678063C000C780678000C780C78000C780C78000C7
8187800187830F000187830F000187860F000183C60F000303CC1E000303CC1E000303D8
1E000303F01E000603F03C000603E03C000603E03C000E03C03C00FFE387FFC0FFC387FF
80281C7E9B28>77 D<000FC3003FF700F03E01C01E01800E03800E07000C07000C070000
07800007C00007FC0003FF8001FFC000FFE0001FF00001F00000F0000070000070300070
3000607000E07000C07801807E0700EFFE00C3F800181C7E9B19>83
D<0FE0001FE00003E00003C00003C00003C00003C0000780000780000780000780000F3F
000F7F800FC3C00F83C01F03C01E03C01E03C01E03C03C07803C07803C07803C0F08780F
18780F18781E30781E70F00FE0600780151D7F9C18>104 D<1E0FC1F8003F1FE3FC0067
B0F61E0063E0FC1E00C7C0F81E00C780F01E000780F01E000780F01E000F01E03C000F01
E03C000F01E03C000F01E078401E03C078C01E03C078C01E03C0F1801E03C0F3803C0780
7F001803003C0022127F9124>109 D E /Fg 5 51 df0
D<60F0F06004047D890A>I<0F801FC0306060306030C018C018C018C018603060303060
1FC00F800D0E7E8E12>14 D<060F0F0E1E1E1C3C383830707060E0C04008117F910A>48
D<01FF8007FF800E0000180000300000600000600000600000C00000C00000FFFF80FFFF
80C00000C000006000006000006000003000001800000E000007FF8001FF8011167D9218
>50 D E /Fh 8 57 df<06001E00FE00EE000E000E000E000E000E000E000E000E000E00
0E000E000E000E007FE07FE00B137E9211>49 D<1F007FC0F9E0F8E0F8F07070007000F0
00E001C001C0038006000C30183030707FE0FFE0FFE00C137E9211>I<0FC03FE0387078
7878383878007000F00FC00FC000700038703CF83CF83CF83870783FF01FC00E137F9211
>I<00E001E001E003E007E00EE01CE018E030E070E0E0E0FFFCFFFC00E000E000E000E0
07FC07FC0E137F9211>I<60607FE07FC07F006000600060006F007FC071E060E000F000
F070F0F0F0F0E0E1C07F801F000C137E9211>I<03E00FF01C38387870787030E000E7E0
EFF0F038F01CE01CE01CE01C601C701838301FE007C00E137F9211>I<60007FFC7FFC7F
F8E030C060C0C000C001800300070007000E000E000E001E001E001E001E000C000E147E
9311>I<0FC01FE038707038703878387E703FE01FC01FF03BF870FCE03CE01CE01CE018
78383FF00FC00E137F9211>I E /Fi 4 89 df<0000700001F00003E0000780000F0000
1E00003C0000780000780000F00000F00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00001E00001
E00001C00003C0000780000700000E00003C0000700000E000007000003C00000E000007
000007800003C00001C00001E00001E00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000
F000007800007800003C00001E00000F000007800003E00001F000007014637B811F>26
DI80 D88
D E /Fj 3 111 df<06070600000000387CCEDC1C38383B767E3C08127F910B>105
D<3C78F0007FFDFC00CF8F1C00CF0E1C000E0E1C001C1C38001C1C38001C1C39801C1C73
0038387F0018183C00190B7F8A1B>109 D<3CF0007FFC00CF1C00CE1C000E1C001C3800
1C38001C39801C7300387F00183C00110B7F8A13>I E /Fk 2 51
df<0C007C00FC009C001C001C001C001C001C001C001C001C001C001C00FF80FF800910
7E8F0F>49 D<1F007F80C3C0E1E0E0E000E001E001C0038007000E00186030607FC0FFC0
FFC00B107F8F0F>I E /Fl 17 104 df0
D<70F8F8F87005057C8E0E>I<00C00000C00000C00000C00000C000C0C0C0F0C3C038C7
000EDC0003F00000C00003F0000EDC0038C700F0C3C0C0C0C000C00000C00000C00000C0
0000C00012157D9619>3 D<000FF00000708E0001808180020080400400802008008010
100080081000800820008004200080044000800240008002400080028000800180008001
80008001FFFFFFFF80008001800080018000800180008001400080024000800240008002
200080042000800410008008100080080800801004008020020080400180818000708E00
000FF00020227D9C27>8 D<03F0000FFC001C0E00300300600180600180C000C0C000C0
C000C0C000C0C000C0C000C0C000C0C000C06001806001803003001C0E000FFC0003F000
12147D9519>14 D<03F0000FFC001FFE003FFF007FFF807FFF80FFFFC0FFFFC0FFFFC0FF
FFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803FFF001FFE000FFC0003F00012147D95
19>I17 D21 D<00000000600000000000300000000000300000000000180000
0000001800000000000C00000000000600000000000380FFFFFFFFFFE0FFFFFFFFFFC000
0000000380000000000600000000000C0000000000180000000000180000000000300000
00000030000000000060002B127D9432>33 D<01800000C0000300000060000300000060
000600000030000600000030000C0000001800180000000C00700000000700FFFFFFFFFF
C0FFFFFFFFFF80700000000700180000000C000C00000018000600000030000600000030
0003000000600003000000600001800000C0002A127C9432>36 D<001FFF007FFF01E000
0380000600000C0000180000300000300000600000600000600000C00000C00000FFFFFF
FFFFFFC00000C000006000006000006000003000003000001800000C0000060000038000
01E000007FFF001FFF181E7C9A21>50 D<7FF8007FFE000007800001C000006000003000
001800000C00000C000006000006000006000003000003FFFFFFFFFFFF00000300000300
000600000600000600000C00000C0000180000300000600001C00007807FFE007FF80018
1E7C9A21>I<00000300000300000600000600000C00000C000018000018000030000030
0000600000600000C00000C00000C0000180000180000300000300000600000600000C00
000C0000180000180000300000300000600000600000C00000C000018000018000030000
0300000300000600000600000C00000C0000180000180000300000300000600000600000
C00000400000183079A300>54 D<40000010C00000306000006060000060600000603000
00C0300000C0300000C018000180180001800C0003000C0003000C00030007FFFE0007FF
FE0003000C0003000C0003000C0001801800018018000180180000C0300000C030000060
600000606000006060000030C0000030C000001980000019800000198000000F0000000F
0000000F000000060000000600001C2480A21D>56 D<007F800001FFE000078078000E00
1C0018000600300003006000018060000180C00000C0C00000C0C00000C0C00000C0C000
00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C04000
00401A1F7D9D21>92 D<000F0038007000E001C001C001C001C001C001C001C001C001C0
01C001C001C001C001C001C001C001C0038007001E00F0001E000700038001C001C001C0
01C001C001C001C001C001C001C001C001C001C001C001C001C001C000E000700038000F
10317CA419>102 DI E /Fm 14 62 df<60F0F0F0F0F0F0F0706060606060600000000060F0F060
04177D960A>33 D<0180030006000C001C001800380030007000700060006000E000E000
E000E000E000E000E000E000E000E00060006000700070003000380018001C000C000600
0300018009227E980E>40 DI<003000003000003000003000003000003000003000
003000003000003000003000FFFFFCFFFFFC003000003000003000003000003000003000
00300000300000300000300000300016187E931B>43 D<07C01FF03C78783C701C701CF0
1EF01EF01EF01EF01EF01EF01EF01EF01E701C701C783C3C781FF007C00F157F9412>48
D<03000F00FF00F700070007000700070007000700070007000700070007000700070007
0007007FF07FF00C157E9412>I<1F803FE071F0F8F0F878F87870780078007800F000E0
01C0038007000E000C18181830387FF0FFF0FFF00D157E9412>I<0FC01FF03078783C78
3C783C103C007800F007E007E00078003C001E701EF81EF81EF83C70383FF00FC00F157F
9412>I<007000F000F001F003F0077006700E701C70187030707070E070FFFEFFFE0070
00700070007003FE03FE0F157F9412>I<60307FF07FE07F8060006000600060006F807F
C070E06070007800786078F078F078F07060E03FC01F000D157E9412>I<01F007F80E1C
1C3C383C70187000F080F7F0FFF8F81CF81CF01EF01EF01E701E701E381C3C381FF007C0
0F157F9412>I<60007FFE7FFE7FFCE018C018C030006000C00180018003800300070007
0007000F000F000F000F000F0006000F167E9512>I<07C01FF03838701C701C701C7C1C
3F383FF00FE01FF83DFC70FCE03EE00EE00EE00E700C78383FF00FC00F157F9412>I61
D E /Fn 37 123 df<00000FF000003FFC0000F00E0001C01E0001C01E0003C01C000380
00000780000007800000078000000F0000000F0000000F0000000F000001FFFFF001FFFF
F0001E00F0001E01E0001E01E0001E01E0001E01E0003C03C0003C03C0003C03C0003C03
C0003C078000780780007807880078078C00780F1800780F1800F00F1800F0073000F007
E000F001C000E0000001E0000001E0000001C0000001C0000073C00000F3800000F30000
007E0000003C0000001F2D82A21B>12 D<00000FF01FF000003FF87FFC00007079E00E00
00E07B801E0001C033801E0003C007801C0003C00F00000003C00F00000007800F000000
07800F00000007801E00000007801E00000007801E0000000F001E000001FFFFFFFFF001
FFFFFFFFF0000F003C00F0000F003C01E0001E003C01E0001E003C01E0001E007801E000
1E007803C0001E007803C0003C007803C0003C007803C0003C00F00780003C00F0078000
3C00F00788007800F0078C007800F00F18007801E00F18007801E00F18007801E0073000
F001E007E000F001E001C000F003C0000000F003C0000000E003C0000001E00380000001
C00780000071C707000000F18F0E000000F38F1C0000007F07F80000003C03F00000002F
2D82A22B>14 D<0000C0000180000300000600000C0000180000380000700000E00000E0
0001C0000380000380000700000700000F00000E00001E00001C00001C00003C00003800
00380000780000780000700000700000F00000F00000F00000E00000E00000E00000E000
00E00000E00000E00000E00000E00000E00000E00000E00000E000006000007000007000
003000003800001800000C0000123279A414>40 D<000C00000600000700000300000380
0003800001800001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0
0001C00001C00001C00003C00003C00003C0000380000380000780000780000700000700
000F00000E00000E00001E00001C00003C0000380000380000700000700000E00001C000
01C0000380000700000600000C0000180000300000600000C00000123280A414>I<0E1E
3F3E3E1E06060C0C18383060C08008107D850F>44 D<7FF87FF8FFF07FF00D047D8B11>
I<387CFCFCF87006067B850F>I<0000300000780000780000F00000F00000F00000E000
01E00001E00001C00003C00003C0000380000780000700000F00000E00001E00001C0000
38000038000070C00061E000E3C001C3C00383C00303C00607800C07801F87807FE780E0
7F00401FF0000FC0000F00001E00001E00001E00001E00003C00003C00003C0000180015
2B7EA019>52 D<007C0001FE000387000603800C03801803801803803003806003806007
80600700E00F00F03E00F07C00E0F80003F00007E0000F80000F00001E00001C30001C70
001CE0001FC0000F80000000000000000000000000000000001C00003E00007E00007E00
007C0000380000112477A319>63 D<00FFFFF00000FFFFFC00000F003E00000F000F0000
1E000780001E000780001E0003C0001E0003C0003C0003C0003C0003E0003C0003E0003C
0003E000780003E000780003E000780003E000780003E000F00007C000F00007C000F000
07C000F00007C001E0000F8001E0000F8001E0000F0001E0001F0003C0001E0003C0003C
0003C0007C0003C0007800078000F000078001E000078007800007801F0000FFFFFC0000
FFFFF0000023227DA125>68 D<00FFF800FFF8000F00000F00001E00001E00001E00001E
00003C00003C00003C00003C0000780000780000780000780000F00000F00000F00000F0
0001E00001E00001E00001E00003C00003C00003C00003C0000780000780000780000780
00FFF800FFF80015227DA113>73 D<0001F060000FFCC0001E0FC0003807C0007003C000
E0038000C0038001C0038001C00380038003000380030003C0000003C0000003E0000001
F8000001FF000000FFE000007FF000001FF8000003FC0000007C0000003C0000001E0000
001E0000001E0030001C0030001C0030001C00300018007000380070007000780060007C
01C000EF038000C7FF000081FC00001B247DA21B>83 D<0078C001FDE00387E00707C00E
03C01C03C03C03C0380780780780780780780780F00F00F00F00F00F10F00F18F01E3070
1E30703E3038EE601FCFC00F038015157B9419>97 D<03E03FC03FC003C003C007800780
078007800F000F000F000F001E001E781FFC1F8E3E0E3C0F3C073C0F780F780F780F780F
F01EF01EF01EF03CF0387078707070E03FC00F0010237BA216>I<007E0001FF0003C380
0703800E07801C07803C0000380000780000780000780000F00000F00000F00000F00000
F00100700300700E00383C001FF0000FC00011157B9416>I<00003E0003FC0003FC0000
3C00003C0000780000780000780000780000F00000F00000F00000F00001E00079E001FD
E00387E00707C00E03C01C03C03C03C0380780780780780780780780F00F00F00F00F00F
10F00F18F01E30701E30703E3038EE601FCFC00F038017237BA219>I<00F803FC0F0E1E
063C063806780CF038FFF0FF80F000E000E000E000E000E002E006701C70783FE00F800F
157A9416>I<00003C0000FF0001CF0001CF0003C6000380000780000780000780000780
000F00000F00000F00000F0001FFF801FFF8001E00001E00001E00001E00001E00003C00
003C00003C00003C00003C0000780000780000780000780000780000F00000F00000F000
00F00000E00001E00001E00001C00001C00073C000F38000F300007E00003C0000182D82
A20F>I<001E30003F7800F1F801C0F001C0F00380F00780F00701E00F01E00F01E00F01
E01E03C01E03C01E03C01E03C01E07800E07800E0F800E1F8007FF0001EF00000F00000F
00001E00001E00001E00703C00F03800F0F0007FE0003F8000151F7E9416>I<00F8000F
F0000FF00000F00000F00001E00001E00001E00001E00003C00003C00003C00003C00007
8000078F8007BFC007F1E00FC0F00F80F00F00F00F00F01E01E01E01E01E01E01E01E03C
03C03C03C03C03C43C078678078C780F0C780F18780738F007F06001C017237DA219>I<
006000F000E000E0000000000000000000000000000000000F001F8033C063C0C3C0C780
C78007800F000F000F001E001E001E203C303C60786078C039C03F800E000C217CA00F>
I<00F8000FF0000FF00000F00000F00001E00001E00001E00001E00003C00003C00003C0
0003C0000780000781E00783F00786300F08700F10F00F20F00F40601F80001F80001FE0
001EF0003C78003C7C003C3C203C3C307878607878607878407838C0F01F80600F001423
7DA216>107 D<01F01FE01FE001E001E003C003C003C003C007800780078007800F000F
000F000F001E001E001E001E003C003C003C003C007800780079007980F300F300F30073
007E001C000C237CA20C>I<1E07E03E003F1FF0FF0067B879C78067E03F03C0C7C03E03
C0C7803C03C0C7803C03C00F007807800F007807800F007807800F007807801E00F00F00
1E00F00F001E00F00F101E00F01E183C01E01E303C01E03C303C01E03C603C01E01CE078
03C01FC0300180070025157C9428>I<1E07C03F1FE067B8F067E078C7C078C78078C780
780F00F00F00F00F00F00F00F01E01E01E01E01E01E21E03C33C03C63C07863C078C3C03
9C7803F83000E018157C941B>I<007E0001FF0003C3800701C00E01C01C01E03C01E03C
01E07801E07801E07801E0F003C0F003C0F00380F00780700700700E00701C003838001F
F00007C00013157B9419>I<01E0F003F3FC067F1E067C0E0C7C0F0C780F0C780F00F00F
00F00F00F00F00F00F01E01E01E01E01E01E01E03C03C03803E07803E07003F1E007BF80
079F000780000780000F00000F00000F00000F00001E00001E0000FFE000FFE000181F80
9419>I<00F0C001F9C0078FC00E07800E07801C07803C0780380F00780F00780F00780F
00F01E00F01E00F01E00F01E00F03C00703C00707C0070FC003FF8000F78000078000078
0000F00000F00000F00000F00001E00001E0001FFE001FFE00121F7B9416>I<1E0F803F
3FC067F0E067E0E0C7C1E0C781E0C780C00F00000F00000F00000F00001E00001E00001E
00001E00003C00003C00003C00003C000078000030000013157C9415>I<007C0001FF00
0383800703800E07800E07800E02000F80000FF8000FFC0007FE0001FF00001F00000F00
700F00F00E00F00E00E01C007038003FF0001FC00011157D9414>I<00E001E001E001E0
01E003C003C003C003C00780FFF8FFF807800F000F000F000F001E001E001E001E003C00
3C003C103C1878307830786038C03F800F000D1F7C9E10>I<0F00301F807833C07863C0
F0C3C0F0C780F0C780F00781E00F01E00F01E00F01E01E03C01E03C01E03C41E03C61E07
8C1E078C1E0F8C0E1B980FF3F003E0E017157C941A>I<0F01C01F83E033C3E063C1E0C3
C0E0C780E0C780E00780C00F00C00F00C00F00C01E01801E01801E01801E03001E03001E
06001E04000F1C0007F80003E00013157C9416>I<0F0060701F80F0F833C0F0F863C1E0
78C3C1E038C781E038C781E0380783C0300F03C0300F03C0300F03C0301E0780601E0780
601E0780601E0780C01E0780C01E0781801E0F81800F1BC30007F9FE0003E0F8001D157C
9420>I<03C3C00FE7E0187C30307C707078F06078F060786000F00000F00000F00000F0
0001E00001E00001E02071E030F3C060F3C060E3C0C0E7E3807CFF00383C0014157D9416
>I<0F00301F807833C07863C0F0C3C0F0C780F0C780F00781E00F01E00F01E00F01E01E
03C01E03C01E03C01E03C01E07801E07801E0F800E1F800FFF0003EF00000F00000F0000
1E00301E00783C0078380070700061E0003FC0001F0000151F7C9418>I<00F03003F870
07FEE007FFC00C07800C0300000600000C0000180000300000600000C000018000030040
0600600C00C01F03C03FFF8079FF0060FE00C0380014157E9414>I
E /Fo 22 86 df45 D<00700001F0000FF000FF
F000FFF000F3F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003
F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F000FFFF80FF
FF80FFFF80111D7C9C1A>49 D<07F0001FFE003FFF007C7F80FE3FC0FE1FC0FE1FE0FE0F
E07C0FE0380FE0001FE0001FC0001F80003F00003E00007C0000F80000F00001C0000380
E00700E00E00E01C01E01FFFE03FFFC07FFFC0FFFFC0FFFFC0FFFFC0131D7D9C1A>I<01
FC0007FF000FFF801E1FC03F0FE03F0FE03F0FE03F0FE01E0FE0001FC0001F80003F0001
FE0001FC00000F80000FE00007F00007F00007F83807F87C07F8FE07F8FE07F8FE07F0FC
0FF07C0FE03FFFC01FFF0003FC00151D7E9C1A>I<0003C00003C00007C0000FC0001FC0
003FC0003FC00077C000E7C001C7C00387C00707C00707C00E07C01C07C03807C07007C0
F007C0FFFFFEFFFFFEFFFFFE000FC0000FC0000FC0000FC0000FC001FFFE01FFFE01FFFE
171D7F9C1A>I<7000007FFFF87FFFF87FFFF87FFFF07FFFE0FFFFC0F003C0E00780E00F
00E01E00003C00003C0000780000780000F80000F80001F00001F00001F00001F00003F0
0003F00003F00003F00003F00003F00003F00003F00001E000151E7D9D1A>55
D<01FC0007FF000FFF801F07C01E07E03E03E03E03E03F03E03F83E03FE3C03FF7C01FFF
800FFF000FFFC007FFE01FFFE03E7FF07C1FF87807F8F803F8F800F8F800F8F800F8F800
F07C01F03F03E03FFFC00FFF8003FC00151D7E9C1A>I<01FC0007FF001FFF803F07C07E
03E07E03E0FE03F0FE03F0FE03F0FE03F8FE03F8FE03F8FE03F87E07F87E07F83E07F81F
FFF807FBF80043F80003F03C03F07E03F07E07E07E07E07E0FC03C1F803FFF001FFC0007
F000151D7E9C1A>I<3C7EFFFFFFFF7E3C000000003C7EFFFFFFFF7E3C08147D930F>I66 D68 DI73 D75 DI78 D<001FF80000FFFF0001F81F8007F00FE00FE007F01FC003F81F
8001F83F8001FC7F8001FE7F0000FE7F0000FEFF0000FFFF0000FFFF0000FFFF0000FFFF
0000FFFF0000FFFF0000FFFF0000FFFF0000FF7F0000FE7F0000FE7F8001FE3F8001FC3F
8001FC1FC003F80FE007F007F00FE001F81F8000FFFF00001FF800201F7D9E27>II82 D<03FC180FFF381FFFF83E03F87C00F8780078F80078F80038F80038FC0000FF00
00FFF8007FFF007FFFC03FFFE01FFFF00FFFF803FFF8001FFC0001FC0000FC00007CE000
7CE0007CE0007CF00078F800F8FE01F0FFFFE0E7FFC0C1FF00161F7D9E1D>I<7FFFFFFC
7FFFFFFC7FFFFFFC7E0FE0FC780FE03C700FE01CF00FE01EF00FE01EE00FE00EE00FE00E
E00FE00EE00FE00E000FE000000FE000000FE000000FE000000FE000000FE000000FE000
000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE00007FFFFC0
07FFFFC007FFFFC01F1E7E9D24>II
E /Fp 28 119 df<000FF000007FFC0001FC1E0003F03E0007E07F000FC07F000FC07F00
0FC07F000FC03E000FC008000FC000000FC000000FC00000FFFFFF00FFFFFF00FFFFFF00
0FC03F000FC03F000FC03F000FC03F000FC03F000FC03F000FC03F000FC03F000FC03F00
0FC03F000FC03F000FC03F000FC03F000FC03F000FC03F000FC03F007FF0FFE07FF0FFE0
7FF0FFE01B237FA21F>12 D45
D68
D73 D75
DI<
0007FC0000003FFF800000FE0FE00003F803F80007E000FC000FE000FE001FC0007F001F
80003F003F80003F803F80003F807F80003FC07F00001FC07F00001FC0FF00001FE0FF00
001FE0FF00001FE0FF00001FE0FF00001FE0FF00001FE0FF00001FE0FF00001FE0FF0000
1FE07F00001FC07F00001FC07F80003FC03F80003F803F81F03F801FC3F87F000FE70CFE
0007E606FC0003FE07F80000FF0FE000003FFF80000007FF8020000003C020000003E060
000003FFE0000003FFE0000001FFC0000001FFC0000000FFC0000000FF800000007F0000
00001E00232C7DA12A>81 DI<01FC0C07FF9C1FFFFC3F03FC7C00FC78007C78003CF8001CF8001C
F8001CFC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FF
00007F00003F00001FE0001FE0001FE0001FF0001EF0003EFC003CFF00FCFFFFF8E7FFE0
C0FF8018227DA11F>I87 D<07FC001FFF803E0FC07F07E07F03E07F03F03E03F01C03F00003F000FFF007FF
F01FE3F03F83F07F03F0FE03F0FE03F0FE03F0FE03F07E07F07F1DFF1FF8FF07E07F1816
7E951B>97 DI<00FF0007FFC00FC3E01F07F03F07F07E07F07E03E07E01C0FE0000
FE0000FE0000FE0000FE0000FE00007E00007E00007F00003F00701F80E00FE1E007FFC0
00FE0014167E9519>I<0003FE000003FE000003FE0000007E0000007E0000007E000000
7E0000007E0000007E0000007E0000007E0000007E0000007E0001FE7E0007FFFE000FC1
FE001F00FE003F007E007E007E007E007E00FE007E00FE007E00FE007E00FE007E00FE00
7E00FE007E00FE007E00FE007E007E007E007E007E003F007E001F00FE000F83FFC007FF
7FC001FC7FC01A237EA21F>I<00FE0007FF800F87C01F03E03F01F07E01F07E01F8FE01
F8FE01F8FFFFF8FFFFF8FE0000FE0000FE00007E00007E00007F00003F00381F80700FE0
F003FFC000FF0015167E951A>I<001F8000FFE001F3E003E7F007E7F00FC7F00FC7F00F
C3E00FC0000FC0000FC0000FC0000FC000FFFC00FFFC00FFFC000FC0000FC0000FC0000F
C0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000F
C0007FFC007FFC007FFC0014237FA211>I104 D<1E003F007F807F807F807F803F
001E00000000000000000000000000FF80FF80FF801F801F801F801F801F801F801F801F
801F801F801F801F801F801F801F801F80FFF0FFF0FFF00C247FA30F>I108
D110 D<00FE0007FFC00F83E01F
01F03E00F87E00FC7E00FC7E00FCFE00FEFE00FEFE00FEFE00FEFE00FEFE00FEFE00FE7E
00FC7E00FC3F01F81F01F00F83E007FFC000FE0017167E951C>II<00FE070007FF8F000FC1DF001F80FF003F00
7F007F003F007F003F007E003F00FE003F00FE003F00FE003F00FE003F00FE003F00FE00
3F00FE003F007F003F007F003F003F007F001F80FF000FC1FF0007FFBF0000FC3F000000
3F0000003F0000003F0000003F0000003F0000003F0000003F000001FFE00001FFE00001
FFE01B207E951E>II<07F3001FFF00781F00700F00F00700F00700F80000FF0000FFF0
007FFC003FFE001FFF0007FF00003F80E00F80E00780F00780F00780F80700FC1E00FFFC
00C7F00011167E9516>I<01C00001C00001C00001C00003C00003C00003C00007C00007
C0000FC0003FFF00FFFF00FFFF000FC0000FC0000FC0000FC0000FC0000FC0000FC0000F
C0000FC0000FC0000FC3800FC3800FC3800FC3800FC3800FC30007E70003FE0000FC0011
207F9F16>III E /Fq 36 119 df<003F000000FFC00003C1E060
0700F0C00E00F0C01E0078C03C0079803C00798078007B0078007B0078007E00F0007E00
F0007C00F0007800F0007800700078007000F8003803BC403C0F3CE01FFC1FC007E00F00
1B157E941F>11 D<00C00C0001E01E0001E01E0003C03C0003C03C0003C03C0003C03C00
078078000780780007807800078078000F00F0000F00F0000F00F0800F00F0C01F01E180
1F01E1801F03E1001F86E3003FFCFE003DF03C003C0000003C0000007800000078000000
7800000078000000F0000000F0000000F0000000F0000000E00000001A207F941D>22
D<07FFFF800FFFFFC01FFFFF803FFFFF8070318000E0618000C06180000061800000E380
0000C3800001C3800001C3800001C3800003838000038380000783C0000703C0000F03C0
000F03E0000E01E0000E01C0001A157F941C>25 D<78FCFCFCFC7806067C850E>58
D<78FCFCFEFE7E0606060C0C1C1830706007107C850E>I<0000001800000078000001E0
0000078000001E00000078000003E000000F8000003C000000F0000003C000000F000000
3C000000F0000000F00000003C0000000F00000003C0000000F00000003C0000000F8000
0003E0000000780000001E0000000780000001E000000078000000181D1C7C9926>I<00
0180000180000380000300000300000700000600000600000E00000C00000C00001C0000
180000180000180000380000300000300000700000600000600000E00000C00000C00001
C0000180000180000380000300000300000700000600000600000E00000C00000C00000C
00001C0000180000180000380000300000300000700000600000600000E00000C00000C0
000011317DA418>II<000001C000000001C000000003C00000
0003C000000007C00000000FC00000000FC00000001FC00000001FE000000037E0000000
33E000000063E0000000C3E0000000C3E000000183E000000183E000000303E000000703
E000000603E000000C03F000000C03F000001801F000003801F000003FFFF000007FFFF0
00006001F00000C001F00000C001F000018001F000030001F000030001F000070001F800
1F0001F800FFC01FFF80FFC01FFF8021237EA225>65 D<007FFFFFC000FFFFFFC00007C0
07C00007C003C0000F8001C0000F8001C0000F800180000F800180001F000180001F0001
80001F018180001F018180003E030000003E030000003E070000003E0F0000007FFE0000
007FFE0000007C0E0000007C0E000000F80C000000F80C000000F80C000000F80C000001
F000000001F000000001F000000001F000000003E000000003E000000003E000000007E0
0000007FFF000000FFFF00000022227EA120>70 D<007FFE3FFF00FFFE7FFF0007C003E0
0007C003E0000F8007C0000F8007C0000F8007C0000F8007C0001F000F80001F000F8000
1F000F80001F000F80003E001F00003E001F00003E001F00003FFFFF00007FFFFE00007C
003E00007C003E00007C003E0000F8007C0000F8007C0000F8007C0000F8007C0001F000
F80001F000F80001F000F80001F000F80003E001F00003E001F00003E001F00007E003F0
007FFE3FFF00FFFE7FFF0028227EA128>72 D<007FFE07FF00FFFE07FF0007C001F00007
C001C0000F800380000F800700000F800C00000F801800001F003000001F006000001F01
C000001F038000003E060000003E0E0000003E1E0000003E3F0000007CFF0000007DDF00
00007F0F8000007E0F800000FC0FC00000F807C00000F807C00000F807E00001F003E000
01F003E00001F003F00001F001F00003E001F00003E001F80003E000F80007E001FC007F
FE0FFF80FFFE0FFF8028227EA129>75 D<007FFF0000FFFF000007C0000007C000000F80
00000F8000000F8000000F8000001F0000001F0000001F0000001F0000003E0000003E00
00003E0000003E0000007C0000007C0000007C0000007C000000F8000000F8003000F800
3000F8006001F0006001F0006001F000C001F000C003E001C003E0038003E0078007E01F
807FFFFF00FFFFFF001C227EA121>I<007FF00007FF00FFF00007FF0007F0000FE00007
F0001BE0000DF0001FC0000DF00037C0000DF00037C0000DF00067C00019F000CF800019
F000CF800019F0018F800018F8018F800030F8031F000030F8031F000030F8061F000030
F80C1F000060F80C3E000060F8183E000060F8183E000060F8303E0000C0F8607C0000C0
F8607C0000C0F8C07C0000C07CC07C0001807D80F80001807F00F80001807F00F8000180
7E00F80003007E01F00003007C01F00003007C01F0000F807803F0007FF0703FFF00FFF0
707FFF0030227EA12F>I<007FFFE00000FFFFFC000007C03E000007C00F00000F800F80
000F800780000F800780000F800780001F000F80001F000F80001F000F80001F001F0000
3E001E00003E003C00003E007800003E01F000007FFFC000007FFF8000007C07C000007C
03E00000F801E00000F801F00000F801F00000F801F00001F003E00001F003E00001F003
E00001F003E00003E007C00003E007C0C003E007C0C007E003C1807FFE03E380FFFE01FF
000000007C0022237EA125>82 D<0003F030000FFC60001E0EE0003803E0007003E000E0
01C000C001C001C001C001C001C00380018003C0018003C0000003C0000003E0000003FC
000001FF800001FFF00000FFF800003FFC000007FC0000007C0000003E0000001E000000
1E0000001E0030001C0030001C0030001C00300018007000380070007000780060007C00
C000EF038000C7FF000081FC00001C247DA21E>I<1FFFFFFE1FFFFFFE1F01F01E3C01F0
0E3803E00E3003E00E7003E00C6003E00C6007C00CC007C00CC007C00CC007C00C000F80
00000F8000000F8000000F8000001F0000001F0000001F0000001F0000003E0000003E00
00003E0000003E0000007C0000007C0000007C0000007C000000F8000000F8000000F800
0001F800007FFFE000FFFFE0001F227EA11D>I86 D89 D<0078C001FDE00387E00707C00E03C0
1C03C03C03C0380780780780780780780780F00F00F00F00F00F08F00F0CF01E18701E18
703E1038EE301FCFE00F03C016157E941A>97 D<00003E0003FC0003FC00003C00003C00
00780000780000780000780000F00000F00000F00000F00001E00079E001FDE00387E007
07C00E03C01C03C03C03C0380780780780780780780780F00F00F00F00F00F08F00F0CF0
1E18701E18703E1038EE301FCFE00F03C017237EA219>100 D<007C0003FF000783800E
01801C0180380180780300701E00FFFC00FFE000F00000E00000E00000E00000E00000E0
0080F00180700700381E001FF8000FE00011157D9417>I<000F8C003FDE0070FE00E07C
01C03C03803C07803C0700780F00780F00780F00781E00F01E00F01E00F01E00F01E01E0
0E01E00E03E0070FE003FFC001F3C00003C00003C0000780000780380780780F00F81E00
F83C007FF8003FC000171F809417>103 D<00F8000FF0000FF00000F00000F00001E000
01E00001E00001E00003C00003C00003C00003C000078000078F8007BFC007F1E00FC0F0
0F80F00F00F00F00F01E01E01E01E01E01E01E01E03C03C03C03C03C07823C0783780786
780F06780F0C780718F007F06001E018237EA21C>I<007000F800F800F000E000000000
0000000000000000000000000F001F8033C061C0C3C0C3C0C3C00780078007800F000F00
1E001E101E183C303C303C603CE01FC00F000D227FA111>I<0000600000F00001F00001
F00000E0000000000000000000000000000000000000000000000000001E00007F8000E3
C001C3C00183C00303C00303C0000780000780000780000780000F00000F00000F00000F
00001E00001E00001E00001E00003C00003C00003C00003C0000780000780038780078F0
00F9E000FBC0007F80003E0000142C81A114>I<00F8000FF0000FF00000F00000F00001
E00001E00001E00001E00003C00003C00003C00003C0000780000780F00781F807830C0F
0E3C0F187C0F307C0F60781FC0301FC0001FF8001E7C003C1E003C1F003C0F083C0F0C78
1E18781E18781E30780E30F007E06003C016237EA219>I<01F01FE01FE001E001E003C0
03C003C003C007800780078007800F000F000F000F001E001E001E001E003C003C003C00
3C0078007800788078C0F180F180F18073007F001E000C237EA20F>I<1E03F01F803F8F
F87FC063DC3CE1E063F01F80F0C3E01F00F0C3C01E00F0C3C01E00F007803C01E007803C
01E007803C01E007803C01E00F007803C00F007803C00F007807820F007807831E00F007
861E00F00F061E00F00F0C1E00F007183C01E007F01800C001E028157F942B>I<1E03E0
003F8FF00063DC780063F03C00C3E03C00C3C03C00C3C03C000780780007807800078078
00078078000F00F0000F00F0000F01E0800F01E0C01E01E1801E03C1801E03C3001E01C6
003C01FC00180078001A157F941D>I<03C0F007F3FC0C7F1E0C7C0E187C0F18780F1878
0F00F00F00F00F00F00F00F00F01E01E01E01E01E01E01E03C03C03803E07803E07003F1
E007BF80079F000780000780000F00000F00000F00000F00001E00001E0000FFE000FFE0
00181F819418>112 D<1E07803F9FC063F8E063E1E0C3E3E0C3C3E0C3C3C00781800780
000780000780000F00000F00000F00000F00001E00001E00001E00001E00003C00001800
0013157F9416>114 D<007E0000FF0001C38003838007078007078007020007C00007FC
0007FE0003FF0001FF80001F80300780780780F80700F80700F00E00701C003FF8000FE0
0011157E9417>I<00E001E001E001E001E003C003C003C003C00780FFFCFFFC07800F00
0F000F000F001E001E001E001E003C003C003C083C0C78187838783038E03FC00F000E1F
7F9E12>I<0F8018001FC03C0031E03C0061E07800E1E07800C1E07800C3C0780003C0F0
000780F0000780F0000780F0000F01E0000F01E0000F01E1000F01E1800F03C3000F03C3
000F07C200070DC60007F9FC0001F0780019157F941C>I<0F80601FC0F031E0F861E078
E1E038C1E038C3C03803C0300780300780300780300F00600F00600F00C00F00C00F0180
0F01800F030007860003FC0001F80015157F9418>I E /Fr 75 127
df<000FC1F0003FF7F800F87E3C01E0FC7C03C0FC7C03C0F83807807800078078000780
78000780780007807800078078000780780007807800FFFFFFC0FFFFFFC0078078000780
780007807800078078000780780007807800078078000780780007807800078078000780
78000780780007807800078078000780780007807800078078007FE1FFC07FE1FFC01E23
80A21C>11 D<000FC000003FE00000F8700001E0780003C0F80003C0F8000780F8000780
7000078000000780000007800000078000000780000007800000FFFFF800FFFFF8000780
F80007807800078078000780780007807800078078000780780007807800078078000780
7800078078000780780007807800078078000780780007807800078078007FE1FF807FE1
FF80192380A21B>I<0007E03F00003FF1FF8000F83FC1C001E03F01E003C07E03E003C0
7E03E007807C03E007803C01C007803C000007803C000007803C000007803C000007803C
000007803C0000FFFFFFFFE0FFFFFFFFE007803C03E007803C01E007803C01E007803C01
E007803C01E007803C01E007803C01E007803C01E007803C01E007803C01E007803C01E0
07803C01E007803C01E007803C01E007803C01E007803C01E007803C01E07FF1FF8FFE7F
F1FF8FFE272380A229>14 D<78FCFCFCFCFCFCFC78787878787878787878783030303030
30000000000078FCFCFCFC7806247CA30E>33 D<781E00FC3F00FC3F00FE3F80FE3F807E
1F800601800601800601800C03000C03001C0700180600300C00701C0060180011107EA2
18>I<78FCFCFEFE7E0606060C0C1C1830706007107CA20E>39 D<0030006000C0018003
80070006000E000E001C001C003800380038007800700070007000F000F000F000F000F0
00F000F000F000F000F000F000F000F000F00070007000700078003800380038001C001C
000E000E00060007000380018000C0006000300C327DA413>II<78FCFCFEFE7E0606060C0C
1C1830706007107C850E>44 DI<78FCFCFCFC7806067C85
0E>I<01F00007FC000F1E001E0F003C07803803807803C07803C07803C07803C0F803E0
F803E0F803E0F803E0F803E0F803E0F803E0F803E0F803E0F803E0F803E0F803E0F803E0
F803E07803C07803C07803C07803C03C07803C07801E0F000F1E0007FC0001F00013227E
A018>48 D<00C001C007C0FFC0FBC003C003C003C003C003C003C003C003C003C003C003
C003C003C003C003C003C003C003C003C003C003C003C003C003C003C003C0FFFFFFFF10
217CA018>I<03F0000FFC001C3F00300F806007806007C0F803C0FC03E0FC03E0FC03E0
7803E03003E00003E00007C00007C0000780000F00001F00001E00003C0000780000F000
00E0000180000380600700600E00601C00E01800C03FFFC07FFFC0FFFFC0FFFFC013217E
A018>I<03F0000FFC001C1F00380F803807807C07C07C07C07C07C03C07C01807C00007
80000F80000F00001E00003C0003F80003F800001E00000F000007800007C00003C00003
E03003E07803E0FC03E0FC03E0FC03C0F803C06007803007801C1F000FFC0003F0001322
7EA018>I<000700000700000F00001F00001F00003F00003F00006F0000EF0000CF0001
8F00018F00030F00070F00060F000C0F001C0F00180F00380F00300F00600F00E00F00FF
FFF8FFFFF8000F00000F00000F00000F00000F00000F00000F0001FFF801FFF815217FA0
18>I<1000801C07801FFF001FFE001FFC001FF000180000180000180000180000180000
18000019F8001BFC001F0F001C07001807801803C00003C00003E00003E00003E00003E0
7803E0F803E0F803E0F803C0F003C06007C0600780300F001C1E000FFC0003F00013227E
A018>I<007E0001FF0003C3800701C00E03C01E07C01C07C03C03803C00007800007800
00780000F9FC00FBFE00FE0700FC0780FC03C0FC03C0F803C0F803E0F803E0F803E0F803
E0F803E07803E07803E07803E03803C03C03C01C07801E07000F0E0007FC0001F0001322
7EA018>I<6000007000007FFFE07FFFE07FFFC07FFFC0600180E00300C00300C00600C0
0C00000C0000180000380000300000700000600000E00000E00001E00001E00001C00003
C00003C00003C00003C00003C00007C00007C00007C00007C00007C00007C00007C00003
800013237DA118>I<01F00007FC000E0F001807803803803001C07001C07001C07001C0
7801C07C03803E03803F87001FEE000FFC0007FC0003FE000FFF001C7F80381FC0700FC0
7003E0E001E0E001E0E000E0E000E0E000E0E000C07001C07001803803801E0F000FFC00
03F00013227EA018>I<01F00007FC000E0E001C07003C0780780380780380F803C0F803
C0F803C0F803E0F803E0F803E0F803E0F803E07803E07807E07807E03C07E01C0FE00FFB
E007F3E00003C00003C00003C00007803807807C07007C0F00780E00301C003838001FF0
0007C00013227EA018>I<78FCFCFCFC7800000000000000000078FCFCFCFC7806157C94
0E>I<78FCFCFCFC7800000000000000000070F8FCFCFC7C0C0C0C1C181830306040061F
7C940E>I61 D<000180000003C0000003C0
000003C0000007E0000007E0000007E000000FF000000DF000000DF000001DF8000018F8
000018F8000038FC0000307C0000307C0000607E0000603E0000603E0000C03F0000C01F
0000C01F0001801F8001FFFF8001FFFF80030007C0030007C0030007C0060003E0060003
E0060003E00E0001F01F0003F0FFC01FFFFFC01FFF20237EA225>65
D<000FE010003FF83000F81C7001E0067003C003F0078001F00F0000F01E0000F03E0000
703C0000707C0000707C0000307800003078000030F8000030F8000000F8000000F80000
00F8000000F8000000F8000000F800000078000030780000307C0000307C0000303C0000
603E0000601E0000600F0000C0078000C003C0018001E0030000F80E00003FF800000FE0
001C247DA223>67 DIII<0007F008003FFC1800FC0E3801E0033803C001F8078000F80F0000781E00
00781E0000383C0000383C0000387C0000187800001878000018F8000018F8000000F800
0000F8000000F8000000F8000000F8000000F8003FFF78003FFF7C0000F87C0000F83C00
00F83C0000F81E0000F81E0000F80F0000F8078000F803C001F801F003B800FC0718003F
FC080007F00020247DA226>III76 DII<000FE000007FFC0000F83E0003E00F80078003C00F0001E00F
0001E01E0000F03E0000F83C0000787C00007C7C00007C7800003C7800003CF800003EF8
00003EF800003EF800003EF800003EF800003EF800003EF800003EF800003E7C00007C7C
00007C7C00007C3C0000783E0000F81E0000F00F0001E00F8003E007C007C003E00F8000
F83E00007FFC00000FE0001F247DA226>II82 D<03F0200FFC601E0EE03803E07801E070
01E07000E0F000E0F00060F00060F00060F80000F800007E00007FC0003FFC001FFF000F
FF8007FFC000FFC0000FE00003E00001F00001F00000F0C000F0C000F0C000F0C000F0E0
00E0E001E0F001C0F803C0EF0780C7FF0081FC0014247DA21B>I<7FFFFFF87FFFFFF87C
07C0F87007C0386007C0186007C018E007C01CE007C00CC007C00CC007C00CC007C00CC0
07C00C0007C0000007C0000007C0000007C0000007C0000007C0000007C0000007C00000
07C0000007C0000007C0000007C0000007C0000007C0000007C0000007C0000007C00000
07C0000007C0000007C00003FFFF8003FFFF801E227EA123>II87
D89
D91 D93 D<0C1C1830706060C0C0C0FCFEFE7E7E3C07107DA20E>96
D<1FE0003FF8007C3C007C1E007C0F00380F00000F00000F0003FF000FFF003F0F007C0F
007C0F00F80F00F80F18F80F18F80F18781F187C3FB83FE7F00F83C015157E9418>I<0F
0000FF0000FF00001F00000F00000F00000F00000F00000F00000F00000F00000F00000F
00000F00000F1F800F7FE00FE1F00F80780F00780F003C0F003C0F003E0F003E0F003E0F
003E0F003E0F003E0F003E0F003C0F003C0F00780F80F00EE1F00E7FC00C1F0017237FA2
1B>I<01FE0007FF000F0F801E0F803C0F807C0700780000F80000F80000F80000F80000
F80000F80000F800007C00007C00C03C00C01E01800F830007FE0001F80012157E9416>
I<0001E0001FE0001FE00003E00001E00001E00001E00001E00001E00001E00001E00001
E00001E00001E003F1E007FDE01F07E03E03E03C01E07801E07801E0F801E0F801E0F801
E0F801E0F801E0F801E0F801E07801E07801E03C01E03C03E01F0FF00FFDFE03F1FE1723
7EA21B>I<01FC0007FF000F0F801E07C03C03C07C03E07801E0FFFFE0FFFFE0F80000F8
0000F80000F80000F800007800007C00603C00601E00C00F838007FF0000FC0013157F94
16>I<001E00007F0001E78001CF8003CF80078700078000078000078000078000078000
078000078000078000FFF800FFF800078000078000078000078000078000078000078000
0780000780000780000780000780000780000780000780000780000780007FFC007FFC00
112380A20F>I<0000F003F1F80FFFB81E1E383C0F303C0F007C0F807C0F807C0F807C0F
803C0F003C0F001E1E001FFC0033F0003000003000003800003FFE003FFFC01FFFE03FFF
F07801F0700078E00038E00038E00038E000387000703800E01E03C00FFF8001FC001521
7F9518>I<0F0000FF0000FF00001F00000F00000F00000F00000F00000F00000F00000F
00000F00000F00000F00000F1F800F7FC00FE1E00FC0F00F80F00F00F00F00F00F00F00F
00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F0FFF3FFFF
F3FF18237FA21B>I<1E003F003F003F003F001E0000000000000000000000000000000F
00FF00FF001F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
00FFE0FFE00B2280A10D>I<00F001F801F801F801F800F0000000000000000000000000
0000007807F807F800F80078007800780078007800780078007800780078007800780078
007800780078007800780078007800787078F870F8F0F9E07FC01F000D2C83A10F>I<0F
0000FF0000FF00001F00000F00000F00000F00000F00000F00000F00000F00000F00000F
00000F00000F0FFC0F0FFC0F03E00F03800F07000F0E000F1C000F38000F78000FFC000F
BE000F1E000F1F000F0F800F07800F07C00F03C00F03E00F03F0FFE7FEFFE7FE17237FA2
1A>I<0F00FF00FF001F000F000F000F000F000F000F000F000F000F000F000F000F000F
000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FF
F00C2380A20D>I<0F0FC07E00FF3FE1FF00FFE0F707801FC07E03C00F807C03C00F0078
03C00F007803C00F007803C00F007803C00F007803C00F007803C00F007803C00F007803
C00F007803C00F007803C00F007803C00F007803C00F007803C00F007803C0FFF3FF9FFC
FFF3FF9FFC26157F9429>I<0F1F80FF7FC0FFE1E01FC0F00F80F00F00F00F00F00F00F0
0F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F0FFF3FF
FFF3FF18157F941B>I<01FC0007FF000F07801E03C03C01E07800F07800F0F800F8F800
F8F800F8F800F8F800F8F800F8F800F87800F07C01F03C01E01E03C00F078007FF0001FC
0015157F9418>I<0F1F80FF7FE0FFE1F00F80F80F00780F007C0F007C0F003E0F003E0F
003E0F003E0F003E0F003E0F003E0F007C0F007C0F00780F80F00FE1F00F7FC00F1F000F
00000F00000F00000F00000F00000F00000F00000F0000FFF000FFF000171F7F941B>I<
01F06007FCE00F0EE01E03E03C03E07C01E07C01E0F801E0F801E0F801E0F801E0F801E0
F801E0F801E07C01E07C01E03C03E03E03E01F0FE00FFDE003F1E00001E00001E00001E0
0001E00001E00001E00001E00001E0001FFE001FFE171F7E941A>I<0F7CFFFEFFDF1F9F
0F9F0F0E0F000F000F000F000F000F000F000F000F000F000F000F000F00FFF8FFF81015
7F9413>I<0FC83FF870786018E018E018F000FC007FC03FE01FF00FF8007CC03CC01CE0
1CE01CF018F838DFF08FC00E157E9413>I<03000300030003000700070007000F001F00
3F00FFF8FFF80F000F000F000F000F000F000F000F000F000F000F0C0F0C0F0C0F0C0F0C
0F0C079803F001E00E1F7F9E13>I<0F00F0FF0FF0FF0FF01F01F00F00F00F00F00F00F0
0F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F01F00F01F00787F8
03FEFF01F8FF18157F941B>III<7FE3FF007FE3
FF0007C1F00003C0E00003E1C00001E3800000F3000000FF0000007E0000003C0000003E
0000003E0000007F00000067800000C7C00001C3C0000181E0000381F0000F81F800FFC3
FF80FFC3FF80191580941A>II<3FFFC03FFFC03C0780380F00301F00703E00603C0060780060F80001F00001
E00003E0C007C0C00780C00F00C01F01C03E01803C0380780780FFFF80FFFF8012157F94
16>III<1E04
3FDE7FFCF7F840F00F057CA018>126 D E /Fs 11 107 df0 D<70F8F8F87005057C8D0D>I<01800180018001800180C183F18F399C0FF003C0
03C00FF0399CF18FC1830180018001800180018010147D9417>3
D<03C00FF01C38300C60066006C003C003C003C003C003C00360066006300C1C380FF003
C010127D9317>14 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7F
FE3FFC1FF80FF003C010127D9317>I<000000C0000003C000000F0000003C000000F000
0003C00000070000001C00000078000001E00000078000001E00000078000000E0000000
780000001E0000000780000001E0000000780000001C0000000700000003C0000000F000
00003C0000000F00000003C0000000C00000000000000000000000000000000000000000
00000000000000007FFFFF80FFFFFFC01A247C9C23>20 D<000000040000000002000000
0002000000000100000000008000000000400000000020FFFFFFFFFCFFFFFFFFFC000000
002000000000400000000080000000010000000002000000000200000000040026107D92
2D>33 D<0000020000000003000000000300000000018000000000C000000000C0000000
0060007FFFFFF000FFFFFFFC000000000E00000000038000000001F0000000007C000000
00F000000003C000000007000000000C00FFFFFFF8007FFFFFF0000000006000000000C0
0000000180000000018000000003000000000300000000020000261A7D972D>41
D<003FF800FFF803C0000700000C0000180000300000300000600000600000C00000C000
00C00000FFFFF8FFFFF8C00000C00000C000006000006000003000003000001800000C00
0007000003C00000FFF8003FF8151C7C981E>50 D<400001C00003600006600006600006
30000C30000C30000C1800181800181800180FFFF00FFFF00C0030060060060060060060
0300C00300C001818001818001818000C30000C30000C300006600006600006600003C00
003C00003C000018000018001821809F19>56 D
106 D E /Ft 27 116 df<03E0000FF8601C3C60381CC0780EC0F00EC0F00F80F00F00E0
0F00E00E00E01F007077203FE7E01F83C0130E7F8D17>11 D<000F80003FC00070E000C0
600180600300E00700E00600E00601C00C3F800C7F800C3FC00C01C01801E01801E01801
E01801E03803C03803C03803803C07006FFE0063F800604000600000C00000C00000C000
00C00000131D809614>I<0C0E001C3F001C7F001CC6003B80003FC0003FF00038780070
38007038C07038C0703980E01F00600E00120E7F8D14>20 D<1E00001F80000380000380
0003C00001C00001E00000E00000E00000F00000700000700000780000F80001FC00039C
00071C000E1E001C0E00380E00700F00E00700C0038011177E9615>I<0601800E03800E
03800E03801C07001C07001C07001C0700380E00380E60381E603C3E407FEFC077C78070
0000700000E00000E00000E00000C0000013147F8D15>I<7C0180FC03801C03801C0700
380700380E00380E00381C0070780070F00073C0007F8000FE0000F00000110E7F8D11>
I<0FFFE01FFFF03FFFE0718C00C18C00019C00039C00031C00031C00071C00071C000E1E
000E0E000C0C00140E808D14>25 D<60F0F06004047D830A>58 D<60F0F07030307060E0
40040A7D830A>I<07FFF80007FFFE0000F00F0000F0078000F0038001E003C001E001C0
01E001C001E001C003C003C003C003C003C003C003C003C0078007800780078007800700
07800F000F001E000F001C000F0078000F01F000FFFFC000FFFF00001A177F961D>68
D<07FF07FF00F000F000F001E001E001E001E003C003C003C003C007800780078007800F
000F000F000F00FFE0FFE010177F960F>73 D<07FF0FF807FF0FF000F0078000F00E0000
F01C0001E0300001E0600001E1C00001E3800003C7800003CF800003FF800003F3C00007
C3C0000781E0000781E0000781F0000F00F0000F00F0000F0078000F007800FFE1FF00FF
C1FF001D177F961E>75 D<001FC0007FF001F07803C03C07801C0F001E1E001E1C001E3C
001E38001E78001E78001E78001E70003CF0003C7000787000787870F078F9E03D8BC01F
8F800FFE0003FC10000C10000E30000FE0000FC0000FC0000700171D7F961C>81
D<003E3000FF6001C1E00300E00700E00E00C00E00C00F00000F80000FF80007FE0003FF
0000FF80000F80000780000380300380600700700700700E00781C00FFF80087E0001417
7E9615>83 D<03CC0FFC1C3C383C7038F038F038F038E070E073E0F3F1F27FFE1E3C100E
7F8D13>97 D<7E007C001C001C001C00380038003800380077C07FE078707078E078E078
E078E078C0F0C0F0C0E0E3C07F803E000D177F960F>I<03E00FF01C7838787870F000F0
00F000E000E000E01070703FE01F800D0E7F8D0F>I<001F80001F000007000007000007
00000E00000E00000E00000E0003DC000FFC001C3C00383C00703800F03800F03800F038
00E07000E07300E0F300F1F2007FFE001E3C0011177F9612>I<1F80001F000007000007
00000700000E00000E00000E00000E00001CF8001DFE001F0E001E0E003C0E003C0E0038
0E00381C00701C00701CC07038C0703980E01F00600E0012177F9614>104
D<018003C003C00180000000000000000000001E003F0067006700C7000E000E000E001C
001CC038C039801F000E000A1780960C>I<0018003C003C001800000000000000000000
01E003F006380C38187000700070007000E000E000E000E001C001C001C071C0F380F700
FE007C000E1D80960E>I<1F801F000700070007000E000E000E000E001C1E1C3E1C671D
CF3B1E3F0C3FC039E070E070E370E370E6E07C603810177F9612>I<3F3E0E0E0E1C1C1C
1C3838383870707070E0E6E6E4FC7808177F960B>I<1C3E0F803E7FBFC067C3F1C06783
E1C0CF03C1C00F0381C00E0381C00E0383801C0703801C0703981C0707181C070730380E
03E0180601C01D0E808D1F>I<1C3E003E7F8067C380678380CF03800F03800E03800E07
001C07001C07301C0E301C0E603807C0180380140E808D15>I<0E3E001F7F0033C38033
83C06703C00703C00703C00703C00E07800E07800E07000F1E001FFC001DF0001C00001C
0000380000380000FF0000FE00001214818D12>112 D<07C00FE01CF01CF03CE03F801F
C00FE001E0F0E0F0E0E1C0FF803F000C0E7E8D10>115 D E /Fu
51 122 df<007E01FE07800E001E003C003C0078007FF87FF8F000F000F0007000700070
0038001C180FF807E00F147E9312>15 D<78FCFCFCFC7806067D850D>58
D<78FCFCFEFE7E0606060C0C18387020070F7D850D>I<000001C00000078000001E0000
0078000001E00000078000000E0000003C000000F0000003C000000F0000003C000000F0
000000F00000003C0000000F00000003C0000000F00000003C0000000E00000007800000
01E0000000780000001E0000000780000001C01A1A7C9723>I<00030003000700060006
000E000C000C001C0018001800380030003000700060006000E000C000C001C001800180
01800380030003000700060006000E000C000C001C001800180038003000300070006000
6000E000C000C000102D7DA117>II<000007000000070000000F0000001F000000
1F0000003F0000003F0000007F0000007F000000DF0000019F0000019F0000031F800003
1F8000060F8000060F80000C0F8000180F8000180F8000300F8000300F80007FFF8000FF
FF8000C00F8001800F8001800FC003000FC0030007C0060007C01F000FC0FFC0FFFCFFC0
FFFC1E207E9F22>65 D<00FFFFF000FFFFFC000F803E000F801E000F801F001F001F001F
001F001F001F001F001F003E003E003E003E003E007C003E00F8007C03E0007FFFC0007F
FFE0007C01F000F800F800F800F800F8007800F8007801F000F801F000F801F000F801F0
00F003E001F003E003E003E007C003E00F807FFFFF00FFFFF800201F7F9E22>I<0000FE
020007FF06001F818C003E00DC0078007C00F0007C01E0003803C00038078000380F8000
381F0000301F0000303E0000303E0000007C0000007C0000007C0000007C000000F80000
00F8000000F8000000F80000C0F80001807800018078000300780003003C0006003C000C
001E0018000F00300007C0E00003FF800000FE00001F217E9F21>I<00FFFFF00000FFFF
FC00000F803E00000F800F00000F800780001F000780001F0003C0001F0003C0001F0003
C0003E0003C0003E0003C0003E0003C0003E0003C0007C0007C0007C0007C0007C0007C0
007C0007C000F8000F8000F8000F8000F8000F0000F8001F0001F0001E0001F0001E0001
F0003C0001F000780003E000F00003E001E00003E003C00003E01F80007FFFFE0000FFFF
F80000221F7F9E26>I<00FFFFFF8000FFFFFF00000F800F00000F800700000F80070000
1F000300001F000300001F000300001F000600003E030600003E030600003E030000003E
070000007C0E0000007FFE0000007FFE0000007C0E000000F80C000000F80C000000F80C
060000F80C0C0001F0000C0001F0000C0001F000180001F000380003E000300003E00070
0003E000E00003E007E0007FFFFFE000FFFFFFC000211F7F9E22>I<00FFFFFF8000FFFF
FF00000F800F00000F800700000F800700001F000300001F000300001F000300001F0006
00003E030600003E030600003E030000003E070000007C0E0000007FFE0000007FFE0000
007C0E000000F80C000000F80C000000F80C000000F80C000001F000000001F000000001
F000000001F000000003E000000003E000000003E000000003E00000007FFF000000FFFF
000000211F7F9E1D>I<0000FE010003FF83000F81C6003E006E0078003E00F0003E01E0
001C03C0001C0780001C0F80001C1F0000181F0000183E0000183E0000007C0000007C00
00007C0000007C000000F8000000F800FFFCF800FFFCF80003E0F80007C0780007C07800
07C0780007C03C000F803C000F801E001F800F003F8007C0F30003FFC100007F00002021
7E9F24>I<00FFFCFFFC00FFFCFFFC000F800F80000F800F80000F800F80001F001F0000
1F001F00001F001F00001F001F00003E003E00003E003E00003E003E00003E003E00007C
007C00007FFFFC00007FFFFC00007C007C0000F800F80000F800F80000F800F80000F800
F80001F001F00001F001F00001F001F00001F001F00003E003E00003E003E00003E003E0
0003E003E0007FFE7FFE00FFFC7FFE00261F7F9E26>I<00FFFE01FFFC000F80000F8000
0F80001F00001F00001F00001F00003E00003E00003E00003E00007C00007C00007C0000
7C0000F80000F80000F80000F80001F00001F00001F00001F00003E00003E00003E00003
E000FFFE00FFFE00171F809E14>I<001FFF80003FFF800000F8000000F8000000F80000
01F0000001F0000001F0000001F0000003E0000003E0000003E0000003E0000007C00000
07C0000007C0000007C000000F8000000F8000000F8000000F8000001F0000001F00003C
1F00007C1F0000FC3E0000FC3E0000F87C0000F078000071F000003FE000001F80000019
207E9E19>I<00FFFC0FFC00FFFC1FFC000F8007E0000F800700000F800E00001F001C00
001F003000001F006000001F00C000003E038000003E070000003E0C0000003E1C000000
7C3C0000007CFE0000007DFE0000007F3E000000FE3F000000FC1F000000F81F000000F8
1F800001F00F800001F00F800001F00FC00001F007C00003E007C00003E003E00003E003
E00003E003F0007FFE3FFE00FFFE3FFE00261F7F9E27>I<00FFFE0000FFFE00000F8000
000F8000000F8000001F0000001F0000001F0000001F0000003E0000003E0000003E0000
003E0000007C0000007C0000007C0000007C000000F8000000F8000000F8006000F80060
01F000C001F000C001F0018001F0018003E0038003E0070003E00F0003E03F007FFFFE00
FFFFFE001B1F7F9E1F>I<00FFC0001FFC00FFC0001FFC000FC0003F80000FC0003F8000
0FC0006F80001BC000DF00001BC000DF000019E0019F000019E0019F000031E0033E0000
31E0063E000031E0063E000031E00C3E000061E00C7C000061E0187C000061E0307C0000
61E0307C0000C0F060F80000C0F060F80000C0F0C0F80000C0F180F8000180F181F00001
80F301F0000180F301F0000180F601F0000300FC03E00003007C03E00003007803E0000F
807803E0007FF0707FFE00FFF060FFFE002E1F7F9E2C>I<00FFC01FFC00FFC01FFC000F
E003C0000FE00180000FE001800019F003000019F003000019F803000018F803000030F8
06000030FC060000307C060000307E060000603E0C0000603E0C0000603F0C0000601F0C
0000C01F180000C00F980000C00F980000C00FD800018007F000018007F000018007F000
018003F000030003E000030001E000030001E0000F8001E0007FF000C000FFF000C00026
1F7F9E25>I<0001FC000007FF00001F07C0003C03E000F001E001E000F003C000F007C0
0078078000780F0000781F0000781E0000783E0000783E0000787C0000F87C0000F87C00
00F87C0000F8F80001F0F80001F0F80001E0F80003E0F80003C0F80007C0780007807800
0F007C001F003C003E003E007C001E00F0000F83E00007FF800001FC00001D217E9F23>
I<00FFFFE000FFFFF8000F807C000F801E000F801E001F001F001F001F001F001F001F00
1F003E003E003E003E003E003C003E0078007C00F8007C03E0007FFFC0007FFE0000F800
0000F8000000F8000000F8000001F0000001F0000001F0000001F0000003E0000003E000
0003E0000003E000007FFE0000FFFE0000201F7F9E1D>I<00FFFFC000FFFFF0000F80F8
000F803C000F803E001F003E001F003E001F003E001F003E003E007C003E007C003E00F8
003E01F0007C07C0007FFF80007FFE00007C0F0000F80F8000F8078000F807C000F807C0
01F00F8001F00F8001F00F8001F00F8003E01F0003E01F0303E01F0303E01F067FFE0F8E
FFFE07FC000001F020207F9E23>82 D<0007E080001FF180003C3B0000700F0000E00F00
01E0070001C0060003C0060003C0060003C0060007C0000007C0000007E0000003FE0000
03FFC00003FFE00001FFF000007FF000000FF0000001F8000000F8000000F0000000F000
3000F0003000F0003000E0007001E0007001C0007003C00078078000EE0F0000C7FC0000
81F8000019217D9F1C>I<0FFFFFFC1FFFFFF81E03E0781803E0383803E0183007C01830
07C0186007C0186007C030C00F8030C00F8030000F8000000F8000001F0000001F000000
1F0000001F0000003E0000003E0000003E0000003E0000007C0000007C0000007C000000
7C000000F8000000F8000000F8000001F800007FFFE0007FFFE0001E1F7F9E1B>I<7FFE
0FFE7FFE0FFE07C001E007C000C007C000C00F8001800F8001800F8001800F8001801F00
03001F0003001F0003001F0003003E0006003E0006003E0006003E0006007C000C007C00
0C007C000C007C000C00F8001800F8001800F8001800F800300078006000780060007800
C0003C0380001E0F00000FFC000003F000001F207D9E1F>I89 D<00F8C003FDE0078FC00E07C01E03C01C03C03C07807807
80780780780780F00F00F00F00F00F00F00F18F01E30701E30703E3038FE603FCFE00F03
8015147E9318>97 D<03C03FC03F800780078007800F000F000F000F001E001E001EF01F
FC3F0E3E0E3C0F3C0F780F780F780F780FF01EF01EF01EF03CF03CF038707070E03FC00F
0010207E9F14>I<007C01FE078F0F1F1E1F1C1E3C0C780078007800F000F000F000F000
F00070027007381E1FF80FE010147E9314>I<00003C0003FC0003F80000780000780000
780000F00000F00000F00000F00001E00001E000F9E003FDE0078FC00E07C01E03C01C03
C03C0780780780780780780780F00F00F00F00F00F00F00F18F01E30701E30703E3038FE
603FCFE00F038016207E9F18>I<007C01FE07870E031E033C033C06781C7FF87FC0F000
F000F000F000700070027007381E1FF807E010147E9315>I<0000F00003FC00073C0007
7C000F7C000F38000F00001E00001E00001E00001E00001E0003FFF007FFF0003C00003C
00003C0000780000780000780000780000780000F80000F00000F00000F00000F00000F0
0001E00001E00001E00001E00001C00003C00003C000738000FB8000FF0000F70000FE00
0078000016297D9F16>I<003C6000FEF001C3E00383E00701E00F01E00F03C01E03C01E
03C01E03C03C07803C07803C07803C07803C0F003C0F001C1F001C3F000FFE0003DE0000
1E00001E00003C00703C00F83C00F87800F0F000FFE0003F0000141D7F9316>I<00F000
0FF0000FE00001E00001E00001E00003C00003C00003C00003C000078000078000079F80
07BFC00FE1E00FC0E00F80F00F00F01E01E01E01E01E01E01E01E03C03C03C03C03C03C0
3C078678078C780F0C780F18780738F007F06001C017207E9F1A>I<007000F800F800F0
00E000000000000000000000000007001FC039C031E061E063C0C3C00780078007800F00
0F000F001E181E303C303C601CE01FC007000D1F7F9E10>I<0003800007C00007C00007
8000070000000000000000000000000000000000000000780000FE00018F00030F00060F
00060F000C1E00001E00001E00001E00003C00003C00003C00003C000078000078000078
0000780000F00000F00000F00000F00001E00071E000F9E000FBC000F78000FF00007C00
001228809E13>I<00F0000FF0000FE00001E00001E00001E00003C00003C00003C00003
C0000780000780000781C00787E00F0E300F18F00F31F00F61F01EC1E01F81C01F80001F
E0003DF0003C78003C78003C3C307878607878607878407838C0F01F80600F0014207E9F
18>I<01E01FE01FC003C003C003C007800780078007800F000F000F000F001E001E001E
001E003C003C003C003C007800780078007980F300F300F300F3007E001C000B207E9F0E
>I<0E03F03F003F8FF87F8033DC3DC3C063F03F81C063E01F01E063C01E01E0C7C03C03
C007803C03C007803C03C007803C03C00F007807800F007807800F007807800F00780F0C
1E00F00F181E00F01E181E00F01E301E00F00E703C01E00FE01800C0038026147F9328>
I<0E07E0003F8FF00033F8780063F0380063E03C0063C03C00C780780007807800078078
00078078000F00F0000F00F0000F00F0000F01E1801E01E3001E03C3001E03C6001E01CE
003C01FC001800700019147F931B>I<007C0001FF000383800F01C01E01C01C01E03C01
E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00701E003838001FF0
0007C00013147E9316>I<01C0F007F3FC067F1C0C7C0E0C780E0C780F18F00F00F00F00
F00F00F00F01E01E01E01E01E01E01E03C03C03803C07803E07003F1E007BFC0079F0007
80000780000F00000F00000F00000F00001E0000FFE000FFE000181D829317>I<00F0C0
03FBC0070F800E0F801C07803C07803C0F00780F00780F00780F00F01E00F01E00F01E00
F01E00F03C00F03C00707C0070FC003FF8000F780000780000780000F00000F00000F000
00F00001E0001FFE001FFE00121D7E9314>I<0E0F003FBF8033F18063E3C063C7C063C7
C0C787800787000780000780000F00000F00000F00000F00001E00001E00001E00001E00
003C000018000012147F9315>I<007C01FE0387070F070F070E0F000FF007FC07FE03FE
00FF001F780FF80EF80EF01C70383FF01FC010147E9315>I<00C001E003C003C003C003
C007800780FFF8FFF80F000F000F000F001E001E001E001E003C003C003C003C18783078
30786078C03F800F000D1C7F9B10>I<0700181FC03C39C07831E07861E07863C078C3C0
F00780F00780F00780F00F01E00F01E00F01E00F01E30F03C60F03C60F07C60F0FCC07F9
FC01F07018147F931A>I<0700C01FC1E039C1F031E0F061E0F063C070C3C06007806007
80600780600F00C00F00C00F00C00F01800F01800F03000F0200078E0003FC0001F00014
147F9316>I<07C3C00FE7E0187C603078F06079F06079F0C0F1E000F1C000F00000F000
01E00001E00039E00079E030FBC060FBC060F3C0C0E7E3807CFF00383C0014147E931A>
120 D<0700301FC07839C0F031E0F061E0F063C0F0C3C1E00781E00781E00781E00F03C0
0F03C00F03C00F03C00F07800F07800F07800F1F8007FF0001EF00000F00000F00381E00
7C1C007C3C0078780070F0003FE0001F8000151D7F9316>I E /Fv
43 123 df<003F0F8000FFFFC003E3F3E00787E3E00707C3E00F07C1C00F03C0000F03C0
000F03C0000F03C0000F03C000FFFFFC00FFFFFC000F03C0000F03C0000F03C0000F03C0
000F03C0000F03C0000F03C0000F03C0000F03C0000F03C0000F03C0000F03C0000F03C0
000F03C0007F87FC007F87FC001B1D809C18>11 D<003F0000FF8003E3800787C00707C0
0F07C00F03800F00000F00000F00000F0000FFFFC0FFFFC00F03C00F03C00F03C00F03C0
0F03C00F03C00F03C00F03C00F03C00F03C00F03C00F03C00F03C00F03C07F87F87F87F8
151D809C17>I<7070F8F8FCFCFCFC7C7C0C0C0C0C0C0C181818183030606040400E0D7F
9C15>34 D<00C00180030007000E000E001C001C003800380038007000700070007000F0
00F000F000F000F000F000F000F000F000F000F000F00070007000700070003800380038
001C001C000E000E0007000300018000C00A2A7D9E10>40 DI<70F0F8F8781818183030706040050D7D840C>44
DI<70F8F8F87005057D840C>I<07E00FF01C38381C781E70
0E700EF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00FF00F700E700E781E38
1C1C380FF007E0101B7E9A15>48 D<07E00FF01C38381C701C700EF00EF00EF00FF00FF0
0FF00F701F701F383F1FEF0FCF000F000E000E381E7C1C7C18783830F03FE00F80101B7E
9A15>57 D<70F8F8F870000000000000000070F8F8F87005127D910C>I<003F800000FF
E00003C0780007001C000C000600181E0300383F83803071C18060E0C0C061E078C061E0
78C0C3C07860C3C07860C3C07860C3C07860C3C07860C3C07860C3C0786061E0786061E0
784060E0F8C03071F8C0383FBF80181E1F000C000000070001E003C01F8000FFFE00003F
E0001B1D7E9C20>64 D<001F808000FFE18003F03B8007C00F800F0007801E0007803E00
03803C0003807C00018078000180F8000180F8000000F8000000F8000000F8000000F800
0000F8000000F8000000780001807C0001803C0001803E0003001E0003000F00060007C0
0C0003F0380000FFF000001FC000191C7E9B1E>67 DII72
DI82 D<7FFFFFC07FFFFFC0780F03C0700F01C0600F00C0E00F00E0C00F0060C00F0060
C00F0060C00F0060000F0000000F0000000F0000000F0000000F0000000F0000000F0000
000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000
03FFFC0003FFFC001B1C7F9B1E>84 DI<1FE0003FF8007C3C00
7C1E007C1E00381E00001E0007FE001FFE003C1E00781E00F01E00F01E60F01E60F03E60
787FE03FFFC00F8F8013127F9115>97 DI<03F00FF81E7C387C787C7038F000F000F000F000F000F000780078063C061E0C0F
F803E00F127F9112>I<003F80003F800007800007800007800007800007800007800007
8000078000078003E7800FFF801E1F80380780780780700780F00780F00780F00780F007
80F00780F00780700780780780380F801E1F800FF7F007E7F0141D7F9C17>I<03E00FF0
1C38381C781E700EFFFEFFFEF000F000F000F000700078063C061E0C0FF803E00F127F91
12>I<007C01FE03DF079F0F1F0F0E0F000F000F000F000F00FFE0FFE00F000F000F000F
000F000F000F000F000F000F000F000F000F000F007FF07FF0101D809C0D>I<07E3800F
FFC03C3DC0381D80781E00781E00781E00781E00381C003C3C003FF00037E00070000070
00003FF8003FFE001FFF003FFF807007C0E001C0E001C0E001C0E001C07003803C0F001F
FE0007F800121B7F9115>II<1C00
3E003E003E001C00000000000000000000000000FE00FE001E001E001E001E001E001E00
1E001E001E001E001E001E001E001E00FFC0FFC00A1D809C0B>I107 DIII<03F0000FFC001E1E00380700780780700380F003C0F003C0F003C0F003C0F003
C0F003C07003807807803807001E1E000FFC0003F00012127F9115>II114 D<1FB03FF07070E030E030F000FE007FC07FE01FF007
F80078C038C038E038F070FFE08F800D127F9110>I<06000600060006000E000E001E00
3E00FFE0FFE01E001E001E001E001E001E001E001E001E301E301E301E301E300E600FE0
03C00C1A7F9910>IIII121 D<7FFC7FFC787870F860F061E063E063C00780078C0F0C1F0C1E1C3C
187C187878FFF8FFF80E127F9112>I E /Fw 2 122 df<040004000400C460E4E03F800E
003F80E4E0C4600400040004000B0D7E8D11>3 D<0C000C000C000C000C000C00FFC0FF
C00C000C000C000C000C000C000C000C000C000C000C000C000C000C000C000C000C000C
000A1A7E9310>121 D E /Fx 84 128 df<001F83F000FFEFF801E0FE7C03C1F87C0781
F87C0F01F0380F00F0000F00F0000F00F0000F00F0000F00F0000F00F000FFFFFF80FFFF
FF800F00F0000F00F0000F00F0000F00F0000F00F0000F00F0000F00F0000F00F0000F00
F0000F00F0000F00F0000F00F0000F00F0000F00F0000F00F0000F00F000FFC3FF00FFC3
FF001E20809F1B>11 D<001F8000FFC001E0E003C0F00781F00F01F00F00E00F00000F00
000F00000F00000F0000FFFFF0FFFFF00F00F00F00F00F00F00F00F00F00F00F00F00F00
F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F0FFC3FFFFC3FF1820
809F19>I<001FB000FFF001E1F003C1F00781F00F00F00F00F00F00F00F00F00F00F00F
00F00F00F0FFFFF0FFFFF00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F
00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F0FFE7FFFFE7FF1820809F19>I<
001FC0FC00007FE7FE0001F07F070003C0FE07800780FC0F800F00F80F800F007807000F
007800000F007800000F007800000F007800000F00780000FFFFFFFF80FFFFFFFF800F00
7807800F007807800F007807800F007807800F007807800F007807800F007807800F0078
07800F007807800F007807800F007807800F007807800F007807800F007807800F007807
800F00780780FFE3FF3FF8FFE3FF3FF82520809F26>I<78FCFCFCFCFCFCFC7878787878
787878783030303030000000000078FCFCFCFC7806217DA00D>33
D<781E00FC3F00FC3F00FE3F80FE3F807E1F800601800601800601800C03000C03001806
00380E00701C00200800110F7E9F17>I<0F0000301F80007038E00060787001E0707C07
C0703FFF80F031FB80F0300700F0300600F0300E00F0301C00F030180070303800706070
007860600038C0E0001F81C0000F018000000380E0000303F000070718000E070C000C0E
0C001C0E0C00381E0600301E0600701E0600E01E0600C01E0601C01E0603801E0603000E
0C07000E0C0E00070C0C0007181C0003F0180000E01F257DA126>37
D<78FCFCFEFE7E0606060C0C18387020070F7D9F0D>39 D<006000C00180038007000600
0E001C001C003C003800380078007000700070007000F000F000F000F000F000F000F000
F000F000F000F000F00070007000700070007800380038003C001C001C000E0006000700
0380018000C000600B2E7DA112>II<000600000006000000060000000600000006000000060000000600000006
000000060000000600000006000000060000000600000006000000060000FFFFFFF0FFFF
FFF000060000000600000006000000060000000600000006000000060000000600000006
00000006000000060000000600000006000000060000000600001C207D9A23>43
D<78FCFCFEFE7E0606060C0C18387020070F7D850D>II<78
FCFCFCFC7806067D850D>I<00030003000700060006000E000C000C001C001800180038
0030003000700060006000E000C000C001C0018001800180038003000300070006000600
0E000C000C001C0018001800380030003000700060006000E000C000C000102D7DA117>
I<03F0000FFC001E1E001C0E003C0F00780780780780780780780780F807C0F807C0F807
C0F807C0F807C0F807C0F807C0F807C0F807C0F807C0F807C0F807C0F807C07807807807
807807807807803C0F001C0E001E1E000FFC0003F000121F7E9D17>I<00C001C00FC0FF
C0F3C003C003C003C003C003C003C003C003C003C003C003C003C003C003C003C003C003
C003C003C003C003C003C003C07FFF7FFF101E7D9D17>I<07F0000FFC00383E00701F00
600F80F80F80FC07C0FC07C0FC07C07807C03007C00007C0000F80000F80000F00001E00
003C0000380000700000E00001C0000380000700C00E00C00C00C01801C03FFF807FFF80
FFFF80FFFF80121E7E9D17>I<03F0000FFC001C1E00300F00780F807C0F807C0F807C0F
803C0F80000F00001F00001E00003C0003F80003F000001C00000E00000F000007800007
800007C03007C07807C0FC07C0FC07C0FC0780780F80700F003C1E001FFC0007F000121F
7E9D17>I<000E00000E00001E00003E00003E00007E00007E0000DE0001DE00019E0003
1E00071E00061E000C1E001C1E00181E00381E00301E00601E00E01E00FFFFF0FFFFF000
1E00001E00001E00001E00001E00001E0001FFE001FFE0141E7F9D17>I<3803003FFF00
3FFE003FF8003FE00030000030000030000030000030000030000031F00037FC003E1E00
3C0F003807803007800007800007C00007C00007C07807C0F807C0F807C0F80780F00780
600F00700E00383C001FF80007E000121F7E9D17>I<007C0001FE000783000F07800E0F
801C0F803C07003C0000780000780000780000F9F800FBFC00FE0E00FC0700FC0780F807
80F807C0F807C0F807C0F807C0F807C07807C07807C07807803807803C07001C0F000E1E
0007FC0001F000121F7E9D17>I<6000007FFFC07FFFC07FFF807FFF80E00300C00600C0
0600C00C0000180000300000300000600000600000E00000E00001E00001C00003C00003
C00003C00003C00003C00007C00007C00007C00007C00007C00007C00007C00003800012
1F7D9D17>I<03F0000FFC001E1E003807003007007003807003807003807803807C0700
7E07003F8E001FFC000FF80007FC0007FE001EFF00387F80701F807007C0E003C0E003C0
E001C0E001C0E001C0F001807003803807001E0E000FFC0003F000121F7E9D17>I<03F0
0007F8001E1C003C0E00380F00780700780780F80780F80780F807C0F807C0F807C0F807
C0F807C07807C0780FC0380FC01C1FC00FF7C007E7C0000780000780000780000F00380F
007C0E007C1E00781C003078001FF0000FC000121F7E9D17>I<78FCFCFCFC7800000000
0000000078FCFCFCFC7806147D930D>I<78FCFCFCFC78000000000000000070F8FCFCFC
7C0C0C0C181838306020061D7D930D>I<7FFFFFE0FFFFFFF00000000000000000000000
000000000000000000000000000000000000000000FFFFFFF07FFFFFE01C0C7D9023>61
D<0FC03FF070F86078F07CF87CF87C707C007800F801F001C00380038003000700060006
00060006000600000000000000000000000F001F801F801F801F800F000E207D9F15>63
D<0003800000038000000380000007C0000007C0000007C000000FE000000FE000000FE0
000019F0000019F0000019F0000030F8000030F8000030F8000060FC0000607C0000607C
0000E07E0000C03E0000C03E0001FFFF0001FFFF0001801F0003801F8003000F8003000F
8007000FC0070007C00F8007C0FFE07FFEFFE07FFE1F207F9F22>65
DI<001FC040007FF0C001F839C0
03C00DC0078007C00F0003C01E0003C03E0001C03C0001C07C0001C07C0000C0780000C0
F80000C0F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000
780000C07C0000C07C0000C03C0000C03E0001801E0001800F0003000780030003C00E00
01F81C00007FF000001FC0001A217D9F21>IIII<000FC020007FF86001F81CE003E006E0078003E0
0F0001E01E0001E01E0000E03C0000E07C0000E07C00006078000060F8000060F8000000
F8000000F8000000F8000000F8000000F8000000F800FFFCF800FFFC780003E07C0003E0
7C0003E03C0003E01E0003E01E0003E00F0003E0078003E003E007E001F81CE0007FF820
000FE0001E217D9F24>III<0FFFE00FFF
E0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E
00003E00003E00003E00003E00003E00003E00003E00003E00003E00783E00FC3E00FC3E
00FC3E00F83C00707C0070F8001FF0000FC00013207F9E17>IIIII<001F800000FFF00001E0780007C03E000F801F000F000F001E00
07803C0003C03C0003C07C0003E07C0003E0780001E0F80001F0F80001F0F80001F0F800
01F0F80001F0F80001F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C00
03C03E0007C01E0007800F000F000F801F0007C03E0001F0F80000FFF000001F80001C21
7D9F23>II<001F800000FFF000
01E0780007C03E000F801F000F000F001E0007803E0007C03C0003C07C0003E07C0003E0
780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0
F80001F0780001E07C0003E07C0003E03C0003C03E0F07C01E1F87800F38CF000FB0DF00
07F0FE0001F0780000FFF010001FF01000007010000078300000387000003FF000003FE0
00001FE000000FC0000007801C297D9F23>II<07E0800FF9801C1F80380F80780780700380F00380F00180F001
80F00180F80000F800007E00007FE0003FFC003FFE001FFF0007FF0000FF80000F800007
C00007C00003C0C003C0C003C0C003C0C003C0E00380F00780F80700FE0E00CFFC0081F8
0012217D9F19>I<7FFFFFE07FFFFFE07C0F81E0700F80E0600F8060600F8060E00F8070
C00F8030C00F8030C00F8030C00F8030000F8000000F8000000F8000000F8000000F8000
000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000
000F8000000F8000000F8000000F800007FFFF0007FFFF001C1F7E9E21>IIII89 D91
D<0802001C0700380E00300C00601800601800C03000C03000C03000FC3F00FE3F80FE3F
807E1F807E1F803C0F00110F7D9F17>II<07F000
1FFC003E1E003E0F003E07801C078000078000078003FF800FFF803F07807C07807C0780
F80798F80798F80798F80F987C1FF83FF3F00FC1E015147F9317>97
D<0F0000FF0000FF00000F00000F00000F00000F00000F00000F00000F00000F00000F00
000F1F800F7FC00FE1E00F80F00F00780F00780F007C0F007C0F007C0F007C0F007C0F00
7C0F007C0F00780F00780F00F80F80F00EC1E00E7FC00C1F001620809F19>I<03F00FFC
1E3E3C3E3C3E781C7800F800F800F800F800F800F80078007C003C033E031F0E0FFC03F0
10147E9314>I<0003C0003FC0003FC00003C00003C00003C00003C00003C00003C00003
C00003C00003C003E3C00FFBC01E0FC03C07C07C03C07803C07803C0F803C0F803C0F803
C0F803C0F803C0F803C07803C07803C07803C03C07C01E1FC00FFBFC03E3FC16207E9F19
>I<03F0000FFC001E1E003C0F003C0F00780F00780780F80780FFFF80FFFF80F80000F8
0000F800007800007C00003C01801E03800F070007FE0001F80011147F9314>I<003E00
00FF0003CF80078F80078F800F07000F00000F00000F00000F00000F00000F0000FFF000
FFF0000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F0000
0F00000F00000F00000F00000F0000FFF000FFF0001120809F0E>I<0000E003F1F00FFF
701E1E703C0F607C0F807C0F807C0F807C0F807C0F803C0F001E1E001FFC0033F0003000
003000003800003FFE003FFF801FFFC03FFFE07801E07000F0E00070E00070E000707000
E07801E03E07C00FFF0003FC00141F7F9417>I<0F0000FF0000FF00000F00000F00000F
00000F00000F00000F00000F00000F00000F00000F1F800F7FC00FE1E00FC0F00F80F00F
00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F
00F0FFF3FFFFF3FF1820809F19>I<1E003F003F003F003F001E00000000000000000000
000F007F007F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
00FFE0FFE00B1F809E0D>I<00F001F801F801F801F800F0000000000000000000000078
07F807F800F8007800780078007800780078007800780078007800780078007800780078
00780078007800787078F878F8F0F9E07FC03F000D28839E0E>I<0F0000FF0000FF0000
0F00000F00000F00000F00000F00000F00000F00000F00000F00000F0FF80F0FF80F07C0
0F07000F06000F0C000F18000F38000F78000FFC000FBC000F1E000F1F000F0F000F0F80
0F07C00F03C00F03E0FFE7FCFFE7FC1620809F18>I<0F00FF00FF000F000F000F000F00
0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00
0F000F000F000F000F00FFF0FFF00C20809F0D>I<0F0FC07E00FF3FE1FF00FFE0F70780
0FC07E03C00F807C03C00F007803C00F007803C00F007803C00F007803C00F007803C00F
007803C00F007803C00F007803C00F007803C00F007803C00F007803C00F007803C00F00
7803C0FFF3FF9FFCFFF3FF9FFC2614809327>I<0F1F80FF7FC0FFE1E00FC0F00F80F00F
00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F
00F0FFF3FFFFF3FF1814809319>I<01F80007FE001F0F803C03C03C03C07801E07801E0
F801F0F801F0F801F0F801F0F801F0F801F07801E07801E03C03C03C03C01F0F8007FE00
01F80014147F9317>I<0F1F80FF7FC0FFE1E00F81F00F00F80F00F80F007C0F007C0F00
7C0F007C0F007C0F007C0F007C0F00780F00F80F00F80F81F00FC3E00F7FC00F1F000F00
000F00000F00000F00000F00000F00000F0000FFF000FFF000161D809319>I<03E0C00F
F9C01F1DC03E07C07C07C07C03C07803C0F803C0F803C0F803C0F803C0F803C0F803C078
03C07C03C07C07C03E07C01E1FC00FFBC003E3C00003C00003C00003C00003C00003C000
03C00003C0003FFC003FFC161D7E9318>I<0F7CFFFEFFDF0F9F0F9F0F0E0F000F000F00
0F000F000F000F000F000F000F000F000F00FFF0FFF01014809312>I<0F903FF07070E0
30E030E030F000FF007FC03FE01FF003F80078C038C038E038E030F070DFE08F800D147E
9312>I<06000600060006000E000E001E003E00FFF8FFF81E001E001E001E001E001E00
1E001E001E001E001E181E181E181E181E180F3007E003C00D1C7F9B12>I<0F00F0FF0F
F0FF0FF00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00F00
F00F00F00F01F00F01F00707F003FEFF01F8FF1814809319>III<
7FE7FC7FE7FC0783E007838003C30001E60001EE0000FC00007800007800003C00007E00
00FE0001CF000187800387800703C00F03E0FFCFFEFFCFFE1714809318>II<3FFF3FFF381E303E703C607860F861F001E003
E007C007830F831F031E073C067C06781EFFFEFFFE10147F9314>II<7038F87CFCFCFCFCF87C70380E067C9E17>127 D E /Fy
51 122 df<00001FFC00000001FFFF00000007FFFF8000001FF80FC000007FC00FE00000
FF801FF00001FF003FF00001FF003FF00003FE003FF00003FE003FF00003FE003FF00003
FE001FE00003FE000FC00003FE0003000003FE0000000003FE0000000003FE0000000003
FE00000000FFFFFFFFF000FFFFFFFFF000FFFFFFFFF000FFFFFFFFF00003FE003FF00003
FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003
FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003
FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF00003
FE001FF00003FE001FF00003FE001FF00003FE001FF00003FE001FF0007FFFE1FFFF807F
FFE1FFFF807FFFE1FFFF807FFFE1FFFF8029327FB12D>12 D<1F003F807FC0FFE0FFE0FF
F0FFF0FFF07FF03FF01F700070007000F000E000E001E001C003C007800F001F003E003C
0018000C197BB116>39 D45 D<000FF80000007FFF000001FFFFC00003FC1FE00007F007F0000FE003F8
001FC001FC001FC001FC003FC001FE003F8000FE003F8000FE007F8000FF007F8000FF00
7F8000FF007F8000FF00FF8000FF80FF8000FF80FF8000FF80FF8000FF80FF8000FF80FF
8000FF80FF8000FF80FF8000FF80FF8000FF80FF8000FF80FF8000FF80FF8000FF80FF80
00FF80FF8000FF80FF8000FF80FF8000FF807F8000FF007F8000FF007F8000FF007F8000
FF007F8000FF003FC001FE003FC001FE001FC001FC001FE003FC000FE003F80007F007F0
0003FC1FE00001FFFFC000007FFF0000000FF80000212E7DAD28>48
D<0000E0000003E000000FE000007FE0001FFFE000FFFFE000FFFFE000FFBFE000E03FE0
00003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE0
00003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE0
00003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE0
00003FE000003FE000003FE000003FE000003FE000003FE0007FFFFFE07FFFFFE07FFFFF
E07FFFFFE01B2E7AAD28>I<003FE00001FFFC0007FFFF801FFFFFC03F81FFE07E007FF0
7F003FF8FF801FFCFFC00FFCFFC00FFEFFC007FEFFC007FEFFC007FE7F8007FE3F0007FE
000007FE000007FE00000FFC00000FFC00000FF800001FF000003FF000003FE000007FC0
0000FF800000FE000001FC000003F8000007E000000FC000001F801E003F001E007E001E
00FC003E01F0003C01E0003C03C0007C07FFFFFC0FFFFFFC1FFFFFFC3FFFFFFC7FFFFFFC
FFFFFFF8FFFFFFF8FFFFFFF8FFFFFFF81F2E7CAD28>I<000FF80000007FFF000001FFFF
C00003FFFFE00007F03FF0000FE01FF8001FF00FF8001FF00FFC001FF00FFC001FF80FFC
001FF00FFC001FF00FFC000FE00FFC0003C00FFC0000001FF80000001FF80000001FF000
00003FE00000007FC0000000FF8000003FFE0000003FF80000003FFF800000003FE00000
000FF80000000FFC00000007FE00000007FF00000003FF00000003FF80000003FF800C00
03FF803F0003FF807F8003FF80FFC003FF80FFC003FF80FFC003FF00FFC007FF00FFC007
FF00FF8007FE007F000FFC003FC03FF8001FFFFFF00007FFFFC00001FFFF0000003FF800
00212E7DAD28>I<000001F000000003F000000003F000000007F00000000FF00000001F
F00000001FF00000003FF00000007FF0000000FFF0000001FFF0000001EFF0000003CFF0
0000078FF000000F8FF000001F0FF000001E0FF000003C0FF00000780FF00000F80FF000
01F00FF00001E00FF00003C00FF00007800FF0000F800FF0000F000FF0001E000FF0003C
000FF0007C000FF000F8000FF000FFFFFFFFE0FFFFFFFFE0FFFFFFFFE0FFFFFFFFE00000
1FF00000001FF00000001FF00000001FF00000001FF00000001FF00000001FF00000001F
F000001FFFFFE0001FFFFFE0001FFFFFE0001FFFFFE0232E7EAD28>I<1C0000301FC007
F01FFFFFF01FFFFFE01FFFFFC01FFFFF801FFFFF001FFFFE001FFFF8001FFFE0001FFF00
001E0000001E0000001E0000001E0000001E0000001E0000001E0000001E0FF0001E7FFE
001FFFFF801FE03FE01F801FF01F000FF81E000FF8000007FC000007FC000007FC000007
FE000007FE0C0007FE7F0007FE7F8007FEFF8007FEFF8007FEFF8007FEFF8007FCFF800F
FC7F000FF87C001FF83E001FF03FC07FE01FFFFFC007FFFF0001FFFC00007FC0001F2E7C
AD28>I<0000FF80000007FFE000001FFFF000007FFFF80000FF80FC0003FE00FE0007FC
01FE0007F803FE000FF003FE001FF003FE001FE003FE003FE001FC003FE000F8007FE000
00007FC00000007FC00000007FC0400000FFC3FF0000FFCFFFC000FFDFFFF000FFFC07F8
00FFF803FC00FFF003FE00FFF001FE00FFE001FF00FFE001FF00FFE001FF80FFC001FF80
FFC001FF80FFC001FF80FFC001FF807FC001FF807FC001FF807FC001FF807FC001FF803F
C001FF803FC001FF003FE001FF001FE003FE000FF003FE000FF807FC0007FC0FF80003FF
FFF00000FFFFC000003FFF0000000FFC0000212E7DAD28>I<3C000000003F000000003F
FFFFFFC03FFFFFFFC03FFFFFFFC03FFFFFFFC07FFFFFFF807FFFFFFF007FFFFFFE007FFF
FFFE007FFFFFFC007C0000F800780001F000780003E000F80003C000F00007C000F0000F
8000F0001F000000003E000000007C000000007C00000000F800000001F800000001F000
000003F000000003F000000007E000000007E00000000FE00000000FE00000001FE00000
001FC00000001FC00000003FC00000003FC00000003FC00000003FC00000007FC0000000
7FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007F
C00000003F800000000E00000022307CAF28>I<000FF80000003FFF000000FFFFC00003
FFFFE00003F80FF00007E003F8000FC001F8000F8001FC001F8000FC001F8000FC001FC0
00FC001FC000FC001FE000FC001FF801FC001FFE01F8001FFF83F8000FFFC7F0000FFFFF
E00007FFFFC00007FFFF000003FFFF800001FFFFE000007FFFF00001FFFFF80007FFFFFC
000FE3FFFE001FC0FFFF003F803FFF007F801FFF807F0007FF80FF0001FF80FE0000FF80
FE00007F80FE00007F80FE00003F80FE00003F80FF00003F00FF00003F007F80007F007F
8000FE003FC001FC001FF807F8000FFFFFF00003FFFFE00000FFFF8000001FF80000212E
7DAD28>I<000FF80000007FFF000001FFFF800007FFFFE0000FF81FF0001FF007F8003F
E007FC003FE003FC007FC003FE007FC001FE00FFC001FE00FFC001FF00FFC001FF00FFC0
01FF00FFC001FF00FFC001FF80FFC001FF80FFC001FF80FFC001FF80FFC003FF807FC003
FF807FC003FF803FC007FF803FE007FF801FE00FFF800FF01FFF8007FFFDFF8001FFF9FF
80007FE1FF80000101FF00000001FF00000001FF00000001FF000F8003FE001FC003FE00
3FE003FC003FE003FC003FE007F8003FE00FF8003FC00FF0001F803FE0001F80FFC0000F
FFFF000007FFFE000001FFF80000007FC00000212E7DAD28>I<00000078000000000000
FC000000000000FC000000000001FE000000000001FE000000000001FE000000000003FF
000000000003FF000000000007FF800000000007FF800000000007FF80000000000FFFC0
000000000FFFC0000000001FFFE0000000001E7FE0000000001E7FE0000000003E7FF000
0000003C3FF0000000007C3FF800000000781FF800000000781FF800000000F81FFC0000
0000F00FFC00000001F00FFE00000001E00FFE00000001E007FE00000003E007FF000000
03C003FF00000003C003FF000000078003FF800000078001FF8000000F8001FFC000000F
FFFFFFC000000FFFFFFFC000001FFFFFFFE000001FFFFFFFE000003E00007FF000003C00
003FF000003C00003FF000007800003FF800007800001FF80000F800001FFC0000F00000
0FFC0000F000000FFC0001E000000FFE00FFFFC003FFFFFCFFFFC003FFFFFCFFFFC003FF
FFFCFFFFC003FFFFFC36317DB03D>65 DI69 D<000007FF00070000007FFFF00F0000
01FFFFFC1F00000FFFFFFE3F00001FFF003FFF00007FF8000FFF0000FFE00003FF0001FF
800001FF0003FF000000FF0007FE0000007F000FFC0000007F001FFC0000003F001FF800
00001F003FF80000001F003FF00000001F007FF00000000F007FF00000000F007FF00000
000F007FE00000000000FFE00000000000FFE00000000000FFE00000000000FFE0000000
0000FFE00000000000FFE00000000000FFE00000000000FFE00000000000FFE000000000
00FFE00000000000FFE0000FFFFFFC7FE0000FFFFFFC7FF0000FFFFFFC7FF0000FFFFFFC
7FF0000003FF003FF0000003FF003FF8000003FF001FF8000003FF001FFC000003FF000F
FC000003FF0007FE000003FF0003FF000003FF0001FF800003FF0000FFE00007FF00007F
F8000FFF00001FFF803FFF00000FFFFFFFFF000001FFFFFE3F0000007FFFF00F00000007
FF80030036317CB03F>71 D73
D76 DII<0000
0FFF0000000000FFFFF000000007FFFFFE0000001FFC03FF8000003FE0007FC000007FC0
003FE00001FF00000FF80003FE000007FC0007FE000007FE0007FC000003FE000FF80000
01FF001FF8000001FF801FF0000000FF803FF0000000FFC03FF0000000FFC03FF0000000
FFC07FE00000007FE07FE00000007FE07FE00000007FE0FFE00000007FF0FFE00000007F
F0FFE00000007FF0FFE00000007FF0FFE00000007FF0FFE00000007FF0FFE00000007FF0
FFE00000007FF0FFE00000007FF0FFE00000007FF0FFE00000007FF07FE00000007FE07F
E00000007FE07FF0000000FFE07FF0000000FFE03FF0000000FFC03FF0000000FFC01FF8
000001FF801FF8000001FF800FFC000003FF0007FC000003FE0007FE000007FE0003FF00
000FFC0001FF80001FF80000FFC0003FF000003FF000FFC000001FFC03FF80000007FFFF
FE00000000FFFFF0000000000FFF00000034317CB03D>I
I82 D<001FF8038000FFFF078003FFFFCF8007FFFFFF800FF00FFF801FC001FF803F
80007F807F00003F807F00001F807E00001F80FE00000F80FE00000F80FE00000780FF00
000780FF80000780FFC0000000FFE0000000FFFE0000007FFFE000007FFFFF00003FFFFF
E0003FFFFFF8001FFFFFFC000FFFFFFE0007FFFFFF0001FFFFFF80007FFFFFC0000FFFFF
E000007FFFE0000007FFE00000007FF00000003FF00000001FF00000000FF0F000000FF0
F0000007F0F0000007F0F0000007F0F8000007F0F8000007E0FC00000FE0FE00000FC0FF
00001FC0FFC0003F80FFFC00FF00FFFFFFFE00F9FFFFFC00F03FFFF000E003FF80002431
7CB02D>I<7FFFFFFFFFFF007FFFFFFFFFFF007FFFFFFFFFFF007FFFFFFFFFFF007FE00F
FC01FF007F000FFC007F007E000FFC003F007C000FFC001F007C000FFC000F00F8000FFC
000F80F8000FFC000F80F8000FFC000F80F0000FFC000780F0000FFC000780F0000FFC00
0780F0000FFC000780F0000FFC000780F0000FFC00078000000FFC00000000000FFC0000
0000000FFC00000000000FFC00000000000FFC00000000000FFC00000000000FFC000000
00000FFC00000000000FFC00000000000FFC00000000000FFC00000000000FFC00000000
000FFC00000000000FFC00000000000FFC00000000000FFC00000000000FFC0000000000
0FFC00000000000FFC00000000000FFC00000000000FFC00000000000FFC00000000000F
FC00000000000FFC00000000000FFC00000000000FFC000000007FFFFFFF8000007FFFFF
FF8000007FFFFFFF8000007FFFFFFF800031307DAF38>II87 D89 D<007FF0000003FFFE00000F
FFFF80001FE03FE0001FF01FF0001FF00FF8001FF00FF8001FF007FC000FE007FC0007C0
07FC00010007FC00000007FC00000007FC000003FFFC00003FFFFC0001FFE7FC0007FC07
FC001FF007FC003FE007FC007FC007FC007F8007FC00FF8007FC00FF0007FC00FF0007FC
00FF0007FC00FF000FFC00FF801FFC007FC01FFE003FE07BFFF01FFFF3FFF007FFC1FFF0
00FF007FF024207E9F27>97 D<01FC000000FFFC000000FFFC000000FFFC000000FFFC00
00000FFC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC0000
0007FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC1FE000
07FCFFFC0007FFFFFF0007FFE07FC007FF801FE007FE000FF007FC000FF807FC0007F807
FC0007FC07FC0003FC07FC0003FC07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC
0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FC07FC00
07FC07FC0007F807FC0007F807FE000FF007FE001FF007FF803FE007F7C07F8007E3FFFF
0007C0FFFC0007801FE00027327EB12D>I<000FFE00007FFFC001FFFFF003FC07F80FF0
0FF81FE00FF81FE00FF83FC00FF87FC007F07FC003E07F800080FF800000FF800000FF80
0000FF800000FF800000FF800000FF800000FF800000FF800000FF8000007FC000007FC0
00007FC0003C3FE0003C1FE0007C1FF000F80FF801F003FE07E001FFFFC0007FFF00000F
F8001E207D9F24>I<0000001FC000000FFFC000000FFFC000000FFFC000000FFFC00000
00FFC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC0000000
7FC00000007FC00000007FC00000007FC00000007FC00000007FC0000FF87FC0007FFE7F
C001FFFFFFC003FC07FFC00FF801FFC01FF000FFC01FE0007FC03FC0007FC07FC0007FC0
7FC0007FC07F80007FC0FF80007FC0FF80007FC0FF80007FC0FF80007FC0FF80007FC0FF
80007FC0FF80007FC0FF80007FC0FF80007FC0FF80007FC07F80007FC07F80007FC07FC0
007FC03FC0007FC01FE000FFC01FE001FFC00FF003FFE007FC0FFFFE01FFFF7FFE007FFC
7FFE000FF07FFE27327DB12D>I<000FFC00007FFF8001FFFFE003FC0FF00FF003F80FE0
01FC1FE001FC3FC000FE3FC000FE7FC000FE7F80007FFF80007FFF80007FFFFFFFFFFFFF
FFFFFFFFFFFFFF800000FF800000FF800000FF8000007F8000007FC000007FC000003FC0
000F3FE0000F1FE0001F0FF0003E07FC007C03FF01F800FFFFF0003FFFC00007FE002020
7E9F25>I<0000FF000007FFC0001FFFF0007FC7F000FF8FF801FF0FF801FF0FF803FE0F
F803FE0FF803FE07F003FE01C003FE000003FE000003FE000003FE000003FE000003FE00
0003FE0000FFFFFC00FFFFFC00FFFFFC00FFFFFC0003FE000003FE000003FE000003FE00
0003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE00
0003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE00
0003FE000003FE00007FFFF8007FFFF8007FFFF8007FFFF8001D327EB119>I<001FF00F
C000FFFE3FE003FFFFFFF007F83FF7F00FE00FE7F01FE00FF3F01FC007F1E03FC007F800
3FC007F8003FC007F8003FC007F8003FC007F8003FC007F8003FC007F8001FC007F0001F
E00FF0000FE00FE00007F83FC00007FFFF80000EFFFE00000E1FF000001E000000001E00
0000001F000000001F800000001FFFFF80001FFFFFF0000FFFFFFC000FFFFFFF0007FFFF
FF8007FFFFFF8007FFFFFFC01FFFFFFFC03F8000FFE07F00001FE0FE00001FE0FE00000F
E0FE00000FE0FE00000FE0FF00001FE07F00001FC07F80003FC03FC0007F801FF803FF00
07FFFFFC0001FFFFF000001FFF0000242F7E9F28>I<01FC000000FFFC000000FFFC0000
00FFFC000000FFFC0000000FFC00000007FC00000007FC00000007FC00000007FC000000
07FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007
FC00000007FC07F80007FC1FFE0007FC7FFF8007FCF07FC007FDE07FC007FF803FE007FF
003FE007FF003FE007FE003FE007FE003FE007FC003FE007FC003FE007FC003FE007FC00
3FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003F
E007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE0
FFFFE3FFFFFFFFE3FFFFFFFFE3FFFFFFFFE3FFFF28327DB12D>I<03E00007F0000FF800
1FFC001FFC001FFC001FFC001FFC000FF80007F00003E000000000000000000000000000
00000000000000000000000001FC00FFFC00FFFC00FFFC00FFFC000FFC0007FC0007FC00
07FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC00
07FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC00FFFFC0FFFFC0FFFFC0FFFFC0
12337EB216>I<01FC000000FFFC000000FFFC000000FFFC000000FFFC0000000FFC0000
0007FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC000000
07FC00000007FC00000007FC00000007FC00000007FC00000007FC03FFF807FC03FFF807
FC03FFF807FC03FFF807FC00FE0007FC01F80007FC03F00007FC07E00007FC0FC00007FC
1F800007FC7F000007FCFE000007FDFE000007FFFF000007FFFF000007FFFF800007FFFF
C00007FFFFE00007FC7FE00007F83FF00007F81FF80007F81FF80007F80FFC0007F807FE
0007F807FF0007F803FF0007F801FF8007F800FFC0FFFFC3FFFEFFFFC3FFFEFFFFC3FFFE
FFFFC3FFFE27327EB12B>107 D<01FC00FFFC00FFFC00FFFC00FFFC000FFC0007FC0007
FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007
FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007
FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007FC0007
FC0007FC0007FC00FFFFE0FFFFE0FFFFE0FFFFE013327EB116>I<01F803FC000FF000FF
F81FFF007FFC00FFF87FFFC1FFFF00FFF8F87FC3E1FF00FFF9E03FE780FF800FFBC01FEF
007F8007FB801FFE007FC007FF001FFC007FC007FE001FF8007FC007FE001FF8007FC007
FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0
007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007
FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0
007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC007FC001FF0007FC0FF
FFE3FFFF8FFFFEFFFFE3FFFF8FFFFEFFFFE3FFFF8FFFFEFFFFE3FFFF8FFFFE3F207D9F44
>I<01F807F800FFF81FFE00FFF87FFF80FFF8F07FC0FFF9E07FC00FFB803FE007FB003F
E007FF003FE007FE003FE007FE003FE007FC003FE007FC003FE007FC003FE007FC003FE0
07FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007
FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE0FFFF
E3FFFFFFFFE3FFFFFFFFE3FFFFFFFFE3FFFF28207D9F2D>I<0007FC0000007FFFC00001
FFFFF00003FC07F80007F001FC000FE000FE001FC0007F003FC0007F803FC0007F807F80
003FC07F80003FC07F80003FC0FF80003FE0FF80003FE0FF80003FE0FF80003FE0FF8000
3FE0FF80003FE0FF80003FE0FF80003FE07F80003FC07F80003FC07F80003FC03FC0007F
803FC0007F801FC0007F000FE000FE0007F001FC0003FC07F80001FFFFF000007FFFC000
0007FC000023207E9F28>I<01FC1FE000FFFCFFFC00FFFFFFFF00FFFFE07FC0FFFF803F
E007FE001FF007FC000FF807FC000FF807FC0007FC07FC0007FC07FC0007FC07FC0003FE
07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FE07FC0003FE07
FC0003FE07FC0003FE07FC0007FC07FC0007FC07FC0007F807FC000FF807FE001FF007FE
001FF007FF803FE007FFC0FF8007FFFFFF0007FCFFFC0007FC1FE00007FC00000007FC00
000007FC00000007FC00000007FC00000007FC00000007FC00000007FC00000007FC0000
0007FC000000FFFFE00000FFFFE00000FFFFE00000FFFFE00000272E7E9F2D>I<01F87E
00FFF8FF80FFF9FFE0FFFBCFE0FFFF9FF00FFF1FF007FE1FF007FE1FF007FE0FE007FE07
C007FC010007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC00
0007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC00
00FFFFF000FFFFF000FFFFF000FFFFF0001C207E9F21>114 D<00FF8E0007FFFE001FFF
FE003F00FE007E007E007C003E00FC001E00FC001E00FE001E00FF000000FFC00000FFFF
0000FFFFC0007FFFF0003FFFFC003FFFFE000FFFFF0003FFFF0000FFFF800007FF800000
FF80F0003F80F0003F80F8001F80F8001F80FC001F00FC003F00FE003F00FF80FE00FFFF
FC00F3FFF000E07F800019207D9F20>I<001E0000001E0000001E0000001E0000001E00
00003E0000003E0000003E0000007E0000007E000000FE000001FE000003FE000007FE00
001FFFFE00FFFFFE00FFFFFE00FFFFFE0003FE000003FE000003FE000003FE000003FE00
0003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE000003FE00
0003FE000003FE078003FE078003FE078003FE078003FE078003FE078003FE078003FE0F
8001FF0F0001FF9F0000FFFE00003FFC000007F000192E7FAD1F>I<01FC000FE0FFFC07
FFE0FFFC07FFE0FFFC07FFE0FFFC07FFE00FFC007FE007FC003FE007FC003FE007FC003F
E007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE0
07FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007FC003FE007
FC007FE007FC007FE007FC007FE007FC00FFE003FC01FFF003FE03BFFF01FFFF3FFF007F
FE3FFF000FF83FFF28207D9F2D>I119
DII E /Fz 56 122 df<1C0E003E1F007F3F807F3F807F3F803B1D8006
03000603000C06000C0600180C00301800603000C06000804000110F789F17>34
D<1C3E7F7F7F3B06060C0C183060C080080F769F0E>39 D<000180000300000600000C00
001C0000380000700000600000E00001C00001C0000380000380000700000700000F0000
0E00001E00001E00001C00003C00003C0000380000380000780000780000700000700000
700000700000F00000F00000F00000F00000F00000F00000700000700000700000700000
7000003000003800001800001C00000C0000112E7AA113>I<001800000C00000E000006
000007000007000003000003800003800003800003800003800003800003800003800003
80000380000780000780000780000700000700000F00000F00000E00000E00001E00001C
00001C00003C0000380000380000700000700000E00000E00001C00001C0000380000700
000600000C00001C0000380000600000C00000112E80A113>I<00380000380000700000
70001870803C63C03E67C01FFF0007FC0003F00003F0000FF8003FFE00F99F00F18F0043
8600038000038000070000070000121478A117>I<0000C0000000C0000000C0000001C0
000001800000018000000180000003800000030000000300000003000000070000000600
00FFFFFFF0FFFFFFF0000E0000000C0000000C0000000C0000001C000000180000001800
000018000000380000003000000030000000300000007000001C1C7A9823>I<0E1E3F3F
3E1E060C0C1C183060E040080F7D850E>I<7FF07FF0FFE07FE00C047D8B10>I<387CFCFC
F87006067B850E>I<000F80003FE000F0F001C0700380700380380700780F00780F0078
0E00781E00781E00703C00F03C00F03C00F03C00F07801E07801E07801E07801C07003C0
F003C0F00380F00780F00700700F00700E00701C003878001FF0000FC000151F7C9D17>
48 D<000100030007000F001E00FE07DE071E003C003C003C003C007800780078007800
F000F000F000F001E001E001E001E003C003C003C003C0FFF8FFF8101E7B9D17>I<000F
80003FC00070E000C0700180780330380638380618780C30780C30780C60780CE0780FC0
F00701E00001C0000380000700001E0000380000E00001C0000700000E00300C00301800
603000E07F81C07FFFC061FF80C07F00C03C00151F7D9D17>I<001F80007FE000E0E001
80700300780660780670780630780660F007C0F00380E00001E00001C000078000FE0000
FE00000700000700000780000780000780300780780780780780F00F00C00F00601E0060
3C007078003FE0001F8000151F7C9D17>I<0007C0001FE00038600060E000C1E001C1E0
0380C00700000F00000E00001E10001EFC001DFE003F07003E07003C07807C0780780780
780780780780700F00700F00F00F00F00E00F01E00701C0070380070380038F0001FC000
0F8000131F7B9D17>54 D<001F00007F8000E1C001C1C00380E00700E00F00E00F01E01E
01E01E01E01E01E01E01C01C03C03C03C03C07C01C07C01C0F801C1F800F778007E70000
0F00000E00001E00001C00603C00F03800F07000E0E000C3C0007F80003E0000131F7B9D
17>57 D<07000F801F801F801F000E000000000000000000000000000000000038007C00
FC00FC00F800700009147B930E>I<000007000000070000000F0000000F0000001F0000
003F0000003F0000006F0000006F000000CF000000CF0000018F0000038F0000030F0000
060F0000060F00000C0F80000C07800018078000180780003FFF80007FFF800060078000
C0078000C00780018007800180078003000780070007800F0007807FC07FF8FFC07FF81D
207E9F22>65 D<0000FE020007FF06001F818C003E00DC0078007C00F0007C01E0003803
C00038078000380F8000381F0000301F0000303E0000303E0000007C0000007C0000007C
0000007C000000F8000000F8000000F8000000F80000C0F8000180780001807800030078
0003003C0006003C000C001E0018000F00300007C0E00003FF800000FE00001F217A9F21
>67 D<01FFFF8001FFFFE0001E01F0001E0078001E003C003C003C003C001E003C001E00
3C001E0078001E0078001E0078001E0078001E00F0003E00F0003E00F0003E00F0003E01
E0007C01E0007C01E0007C01E0007803C000F003C000F003C001E003C003C0078007C007
800F8007801E0007807C00FFFFF000FFFFC0001F1F7D9E22>I<01FFFFFE01FFFFFC001E
003C001E001C001E001C003C000C003C000C003C000C003C001800780C1800780C180078
0C0000781C0000F0380000FFF80000FFF80000F0380001E0300001E0300001E0303001E0
306003C0006003C0006003C000C003C001C007800180078003800780070007801F00FFFF
FF00FFFFFE001F1F7D9E1F>I<01FFFFFC01FFFFF8001E0078001E0038001E0038003C00
18003C0018003C0018003C003000780C3000780C3000780C0000781C0000F0380000FFF8
0000FFF80000F0380001E0300001E0300001E0300001E0300003C0000003C0000003C000
0003C0000007800000078000000780000007800000FFFC0000FFF800001E1F7D9E1E>I<
01FFF001FFF0001E00001E00001E00003C00003C00003C00003C00007800007800007800
00780000F00000F00000F00000F00001E00001E00001E00001E00003C00003C00003C000
03C000078000078000078000078000FFF800FFF800141F7D9E12>73
D<01FFF07FE001FFF07FE0001E001F00001E001C00001E003000003C006000003C01C000
003C038000003C07000000780C000000781800000078300000007870000000F0F0000000
F3F8000000F778000000FC78000001F83C000001F03C000001E03C000001E01E000003C0
1E000003C01E000003C00F000003C00F000007800F000007800780000780078000078007
C000FFF83FF800FFF03FF800231F7D9E23>75 D<01FFF80001FFF800001E0000001E0000
001E0000003C0000003C0000003C0000003C000000780000007800000078000000780000
00F0000000F0000000F0000000F0000001E0000001E0000001E0018001E0018003C00300
03C0030003C0060003C0060007800E0007801C0007803C000780FC00FFFFF800FFFFF800
191F7D9E1D>I<01FF0000FFC001FF0000FFC0001F0001F800001F0001F800001F000378
0000370003F00000370006F0000037000CF0000037000CF00000670019E00000638019E0
0000638031E00000638031E00000C38063C00000C380C3C00000C380C3C00000C38183C0
0001838187800001838307800001838307800001838607800003038C0F000003038C0F00
000303980F00000301D80F00000601F01E00000601F01E00000601E01E00000E01C01E00
00FFE1C3FFE000FFC183FFC0002A1F7D9E29>I<01FF00FFE001FF00FFE0001F001E0000
1F800C00001F800C0000378018000033C018000033C018000033C018000063C030000061
E030000061E030000061E0300000C0F0600000C0F0600000C0F0600000C0786000018078
C000018078C00001803CC00001803CC00003003D800003001F800003001F800003001F80
0006000F000006000F000006000F00000E000F0000FFE0060000FFC0060000231F7D9E22
>I<0001FC000007FF00001F07C0003C03E000F001E001E000F003C000F007C000780780
00780F0000781F0000781E0000783E0000783E0000787C0000F87C0000F87C0000F87C00
00F8F80001F0F80001F0F80001E0F80003E0F80003C0F80007C07800078078000F007C00
1F003C003E003E007C001E00F0000F83E00007FF800001FC00001D217A9F23>I<01FFFF
8001FFFFE0001E01F0001E0078001E0078003C007C003C007C003C007C003C007C007800
F8007800F8007800F0007801E000F003E000F00F8000FFFF0000FFF80001E0000001E000
0001E0000001E0000003C0000003C0000003C0000003C000000780000007800000078000
0007800000FFF80000FFF000001E1F7D9E1F>I<01FFFF0001FFFFC0001E03E0001E00F0
001E00F8003C00F8003C00F8003C00F8003C00F8007801F0007801F0007803E0007807C0
00F01F0000FFFE0000FFF00000F0380001E03C0001E01C0001E01C0001E01C0003C03C00
03C03C0003C03C0003C03C0007807C0007807C1807807C1807807E30FFF83E30FFF01FE0
000007C01D207D9E21>82 D<0007E040001FF8C0003C1D8000700F8000E0078001C00780
01800300038003000380030003800300038000000380000003C0000003F8000001FF8000
01FFE000007FF000001FF0000001F8000000780000003800000038000000380030003800
300038003000300070007000700060007800E0007801C000EE078000C7FE000081F80000
1A217D9F1A>I<0FFFFFF01FFFFFE01E0781E0180780E038078060300F0060300F006060
0F0060600F00C0C01E00C0C01E00C0001E0000001E0000003C0000003C0000003C000000
3C00000078000000780000007800000078000000F0000000F0000000F0000000F0000001
E0000001E0000001E0000003E00000FFFF0000FFFF00001C1F789E21>I<7FFC3FF87FFC
3FF80780078007800300078003000F0006000F0006000F0006000F0006001E000C001E00
0C001E000C001E000C003C0018003C0018003C0018003C00180078003000780030007800
300078003000F0006000F0006000F0006000F000C000F000800070018000700300003806
00003C1C00001FF8000007E000001D20779E22>II<00F18003FBC0070F800E0F801C07803C07803C0F00780F00
780F00780F00F01E00F01E00F01E00F01E30F03C60F03C60707C6070FCC03F9F800F0F00
14147C9317>97 D<03C0003FC0003F80000780000780000780000F00000F00000F00000F
00001E00001E00001E78001FFE003F8E003E07003C07003C078078078078078078078078
0780F00F00F00F00F00F00F01E00F01C00703C0070380038F0003FE0000F800011207C9F
15>I<007E0001FF000383800F07801E07801C07003C0200780000780000780000F00000
F00000F00000F00000F00000700200700700381E001FF80007E00011147C9315>I<0000
780007F80007F00000F00000F00000F00001E00001E00001E00001E00003C00003C000F3
C003FBC0070F800E0F801C07803C07803C0F00780F00780F00780F00F01E00F01E00F01E
00F01E30F03C60F03C60707C6070FCC03F9F800F0F0015207C9F17>I<007C0001FF0007
83000F01801E01803C01803C0300780E007FFC007FE000F00000F00000F00000F0000070
00007002007807003C1E001FF80007E00011147C9315>I<0000F80001FC0003BC0007BC
000718000F00000F00000F00000F00001F00001E00001E0003FFF003FFF0001E00003C00
003C00003C00003C00003C0000780000780000780000780000780000F00000F00000F000
00F00000F00001E00001E00001E00001E00001C00003C0003380007B8000F300007E0000
3C00001629829F0E>I<003E3000FF7801E3F00381F00780F00700F00F01E01E01E01E01
E01E01E03C03C03C03C03C03C03C03C03C07801C07801C0F800E3F800FFF0003CF00000F
00000F00001E00001E00301E00783C00F0F8007FF0003F8000151D7E9315>I<00F0000F
F0000FE00001E00001E00001E00003C00003C00003C00003C000078000078000079F0007
FF800FE3C00F81C00F01E00F01E01E03C01E03C01E03C01E03C03C07803C07803C07803C
0F0C780F18780E18781E30780E70F00FE060078016207E9F17>I<006000F000F000E000
000000000000000000000000000F001F8033C033C063C063C0C780078007800F000F001E
001E001E303C603C603CC03CC01F800F000C1F7D9E0E>I<00F0000FF0000FE00001E000
01E00001E00003C00003C00003C00003C0000780000780000781E00783F00F0E300F1870
0F10F00F20F01E40E01F80001F80001FF0003CF8003C3C003C3C003C1E30783C60783C60
783C60781CC0F01F80600F0014207E9F15>107 D<01E01FE01FC003C003C003C0078007
80078007800F000F000F000F001E001E001E001E003C003C003C003C0078007800780078
C0F180F180F180F3007E003C000B207D9F0C>I<0F07C0F8001F9FE3FC0033F8F71E0063
E07C0E0063C0780F0063C0780F00C780F01E000780F01E000780F01E000780F01E000F01
E03C000F01E03C000F01E03C000F01E078601E03C078C01E03C070C01E03C0F1801E03C0
73803C07807F001803003C0023147D9325>I<0F07C01F9FE033F8F063E07063C07863C0
78C780F00780F00780F00780F00F01E00F01E00F01E00F03C31E03C61E03861E078C1E03
9C3C03F81801E018147D931A>I<007C0001FF000383800F01C01E01C01C01E03C01E078
01E07801E07801E0F003C0F003C0F003C0F00780F00700700F00701E003838001FF00007
C00013147C9317>I<01E1E003F3F8067E1C0C7C1C0C781E0C781E18F01E00F01E00F01E
00F01E01E03C01E03C01E03C01E07803C07803C07003E0E003E1C007BF80079E00078000
0780000F00000F00000F00000F00001E0000FFE000FFE000171D809317>I<0F0F001FBF
8033F1C063E1C063C3C063C3C0C783800780000780000780000F00000F00000F00000F00
001E00001E00001E00001E00003C000018000012147D9313>114
D<00FC03FE0707060F0E0F0E0E1E001FE00FF80FFC07FC01FE003E701EF01CF01CE01860
703FE01F8010147D9313>I<00C001E003C003C003C003C007800780FFF0FFF00F000F00
0F000F001E001E001E001E003C003C003C003C307860786078C079C03F801E000C1C7C9B
0F>I<0780601FC0F039C1E031E1E061C1E063C1E0C3C3C00783C00783C00783C00F0780
0F07800F07800F078C0F0F180E0F180F0F180F1F3007F7E003E3C016147D9318>I<0781
C01FC3C039C3E031E1E061C0E063C0E0C3C0C00780C00780C00780C00F01800F01800F01
800F03000F03000F06000F06000F0C0007F80001E00013147D9315>I<078060E01FC0F1
E039C1E1F031E1E0F061C1E07063C1E070C3C3C0600783C0600783C0600783C0600F0780
C00F0780C00F0780C00F0781800F0781800F0781000F0F8300071F860007FBFC0001F0F8
001C147D931E>I<07C3800FE7C0187CE03078E06079E06079E0C0F1C000F00000F00000
F00001E00001E00001E00071E060F3C0C0F3C0C0E3C180E7C3007CFE00387C0013147D93
15>I<0780301FC07839C0F031E0F061C0F063C0F0C3C1E00781E00781E00781E00F03C0
0F03C00F03C00F03C00F07800F07800F07800F1F8007FF0001EF00000F00000E00001E00
781C00783C0070780060F0003FC0001F0000151D7D9316>I E /FA
6 122 df<018001C0018001806186F99F7DBE1FF807E007E01FF87DBEF99F6186018001
8001C0018010127E9215>3 D<07E01FF8381C700E6006E007C003C003C003C003E00760
06700E381C1FF807E010107E9115>14 D<00000300000000030000000001800000000180
00000000C00000000060007FFFFFF000FFFFFFF8000000000E00000000070000000001E0
000000007800000001E0000000038000000006000000001C00FFFFFFF8007FFFFFF00000
00006000000000C000000001800000000180000000030000000003000025187E952A>41
D<001F00FF01F003E003C003C003C003C003C003C003C003C003C003C003C003C003C007
800F00FE00F800FE000F00078003C003C003C003C003C003C003C003C003C003C003C003
C003C003E001F000FF001F10297E9E15>102 D
I<0300078007800780078007800780030003007B78FFFCFFFC7B78030003000780078007
800780078007800780078007800780078007800780078007800780030003000300030003
0003000E257E9C13>121 D E /FB 35 122 df<78FCFCFEFE7A02020202040404081010
204007127B8510>44 D<78FCFCFCFC7806067B8510>46 D<007E0001C3800700E00E0070
1E00781C00383C003C3C003C38001C78001E78001E78001E78001EF8001FF8001FF8001F
F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F
78001E78001E78001E78001E7C003E3C003C3C003C1C00381E00780E00700700E001C380
007E0018297EA71D>48 D<00100000700000F0000FF000FFF000F0F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000
F00000F00000F00000F00000F00001F8007FFFE07FFFE013287CA71D>I<000FC0003FF0
00F01801C01803803C07007C0F007C0E00381E00003C00003C00003C00007C0000780000
780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC001EF8001EF8001FF8001F
F8001FF8001F78001F78001F78001F78001F3C001E3C001E1C003C1E003C0E0078070070
03C1E001FFC0007E0018297EA71D>54 D<007E0001FF800381E00600F00C00781C003818
001C38001C38001C38001C38001C3C001C3E00381F00381FC0700FE0E007F98003FF0001
FF0000FF8001FFE0031FF00E07F81C03FC3800FE30007E70001E60000FE0000FE00007E0
0007E00007E00007F0000670000E78000C3800181E00300F81E003FFC000FE0018297EA7
1D>56 D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF800
1EF8001EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E00
5F07009F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00
703E00E03C01C01803801C0F000FFE0003F80018297EA71D>I<00001000000000380000
0000380000000038000000007C000000007C000000007C00000000BE00000000BE000000
00BE000000011F000000011F000000011F000000020F800000020F800000020F80000004
07C000000407C000000C07E000000803E000000803E000001003F000001001F000001001
F000002000F800002000F800002000F800007FFFFC00007FFFFC000040007C000080003E
000080003E000080003E000100001F000100001F000300001F800200000F800200000F80
0600000FC01F80000FC0FFE000FFFEFFE000FFFE272A7EA92C>65
D73 D75 D77
DI80
D82 D<00FE010003FF83000F81E3001E0037003C001F0038000F007800070070000700F0
000300F0000300F0000300F0000100F8000100F8000100FC0000007C0000007F0000003F
E000001FFE00000FFFE00007FFF80003FFFC00007FFE000007FF0000007F0000001F8000
000F80000007C0000007C0800003C0800003C0800003C0800003C0C00003C0C0000380C0
000380E0000780F0000700F8000E00EE001C00C3C07800C1FFF000803FC0001A2B7DA921
>I85 DI<03FC00000C070000100380003C01C0003E01E0003E00F0001C
00F0000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C
00F0007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E
0C7F8007F01E001A1A7E991D>97 D<007F0001C0E00700100E00781E00F83C00F83C0070
7C0020780000F80000F80000F80000F80000F80000F80000F80000F800007800007C0000
3C00083C00081E00100E002007006001C180007E00151A7E991A>99
D<00FE000387800701C00E01E01C00E03C00F03C00F0780078780078F80078F80078FFFF
F8F80000F80000F80000F80000F800007800007800003C00083C00081E00100E00200700
4001C180007E00151A7E991A>101 D<001F000070C000E1E001C3E003C3E00381C00780
80078000078000078000078000078000078000078000078000078000FFFE00FFFE000780
000780000780000780000780000780000780000780000780000780000780000780000780
0007800007800007800007800007800007800007800007800007C000FFFE00FFFE00132A
7FA912>I<07800000FF800000FF8000000F800000078000000780000007800000078000
0007800000078000000780000007800000078000000780000007800000078000000783F8
00078C1C0007900E0007A0070007A0078007C0078007C007800780078007800780078007
800780078007800780078007800780078007800780078007800780078007800780078007
800780078007800780078007800780078007800780FFFCFFFCFFFCFFFC1E2A7FA921>
104 D<0F001F801F801F801F800F0000000000000000000000000000000000000007807F
807F800F8007800780078007800780078007800780078007800780078007800780078007
800780078007800780FFF8FFF80D297FA811>I<07800000FF800000FF8000000F800000
078000000780000007800000078000000780000007800000078000000780000007800000
07800000078000000780000007807FE007807FE007803F00078018000780300007802000
07804000078180000782000007860000078F0000079F000007AF800007C780000783C000
0783E0000781E0000781F0000780F8000780780007807C0007803C0007803E0007803F00
FFF8FFF0FFF8FFF01C2A7FA91F>107 D<0780FF80FF800F800780078007800780078007
800780078007800780078007800780078007800780078007800780078007800780078007
80078007800780078007800780078007800780078007800780FFFCFFFC0E2A7FA911>I<
0783F800FF8C1C00FF900E000FA0070007A0078007C0078007C007800780078007800780
078007800780078007800780078007800780078007800780078007800780078007800780
078007800780078007800780078007800780078007800780FFFCFFFCFFFCFFFC1E1A7F99
21>110 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001EF8001FF8
001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C1C00380E
00700700E003C3C0007E00181A7E991D>I<0783F000FF8C1C00FFB00F0007C0078007C0
03C0078003E0078001E0078001F0078001F0078000F8078000F8078000F8078000F80780
00F8078000F8078000F8078000F0078001F0078001F0078001E0078003C007C003C007C0
078007A00E0007983C000787E00007800000078000000780000007800000078000000780
000007800000078000000780000007800000FFFC0000FFFC00001D267F9921>I<0787C0
FF88E0FF91F00FA1F007C1F007C0E007C000078000078000078000078000078000078000
07800007800007800007800007800007800007800007800007800007800007C000FFFE00
FFFE00141A7F9917>114 D<07F0801C0D80300380600180600180E00080E00080F00080
F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C08001C0C001C0
C001C0E00180E00380F00300CC0E0083F800121A7E9917>I<0080000080000080000080
000180000180000180000380000380000780000F80001FFF80FFFF800780000780000780
000780000780000780000780000780000780000780000780000780000780000780400780
4007804007804007804007804007804003C08001C08000E100003E0012257FA417>I<07
800780FF80FF80FF80FF800F800F80078007800780078007800780078007800780078007
800780078007800780078007800780078007800780078007800780078007800780078007
8007800780078007800F8007800F800380178001C027C000E047FC003F87FC1E1A7F9921
>III121 D E /FC 26 124 df<00001FE0000000F018000003C0
04000007800200000F000300001E000F80003C001F80007C001F80007C001F8000F8000F
0000F800060000F800000000F800000000F800000000F800000000F800000000F8000000
00F800000000F800000000F800000000F800000000F800000000F8000000FFFFFFFF80FF
FFFFFF8000F8001F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8
000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F800
0F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F
8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F8000F80
00F8000F8000F8000F8000F8000F8000F8000F8001FC001FC03FFFC1FFFE3FFFC1FFFE27
3C7FBB2B>12 D<000000180000000000003C0000000000003C0000000000003C00000000
00007E0000000000007E0000000000007E000000000000FF000000000000FF0000000000
00FF0000000000019F8000000000019F8000000000019F8000000000030FC00000000003
0FC000000000070FE0000000000607E0000000000607E0000000000E07F0000000000C03
F0000000000C03F0000000001803F8000000001801F8000000001801F8000000003001FC
000000003000FC000000003000FC0000000060007E0000000060007E0000000060007E00
000000C0003F00000000C0003F00000001C0003F8000000180001F8000000180001F8000
000380001FC000000300000FC000000300000FC0000007FFFFFFE0000007FFFFFFE00000
06000007E000000C000007F000000C000003F000000C000003F0000018000001F8000018
000001F8000018000001F8000030000000FC000030000000FC000070000000FE00006000
00007E0000600000007E0000E00000007F0000C00000003F0001C00000003F0001E00000
003F8003E00000003F800FF80000007FC0FFFE000007FFFFFFFE000007FFFF383C7EBB3C
>65 D<000001FF00008000001FFFE0018000007F007801800001F8000E03800003E00007
0780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F80000003F
8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC00000000780
0FC000000007801F8000000003801F8000000003803F8000000003803F0000000001803F
0000000001807F0000000001807F0000000001807E0000000000007E000000000000FE00
0000000000FE000000000000FE000000000000FE000000000000FE000000000000FE0000
00000000FE000000000000FE000000000000FE000000000000FE000000000000FE000000
0000007E0000000000007E0000000000007F0000000000007F0000000001803F00000000
01803F0000000001803F8000000001801F8000000001801F8000000003000FC000000003
000FC0000000030007E0000000060007E0000000060003F0000000060001F00000000C00
00F80000001800007C0000001800003E0000003000001F0000006000000FC00001C00000
03E0000380000001F8000E000000007F007C000000001FFFF00000000001FF000000313D
7CBB39>67 DII78 D<000003FF00000000001E01E000000000
F0003C00000003C0000F000000078000078000000F000003C000003E000001F000007C00
0000F80000F80000007C0001F00000003E0001F00000003E0003E00000001F0007E00000
001F8007C00000000F800FC00000000FC00F8000000007C01F8000000007E01F80000000
07E03F0000000003F03F0000000003F03F0000000003F07F0000000003F87E0000000001
F87E0000000001F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FC
FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE
0000000001FCFE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F00
00000003F87F0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000
000007E01F8000000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000
001F8003E00000001F0001F00000003E0001F80000007E0000F80000007C00007C000000
F800003E000001F000000F000003C000000780000780000003E0001F00000000F8007C00
0000001E01E00000000003FF000000363D7CBB3E>I82 D<000FF00080007FFE018001F00F818003C001
C380070000E3800E000037801C00003F803C00001F803800000F807800000F8070000007
807000000780F000000380F000000380F000000380F000000380F000000180F800000180
F800000180FC000001807C000000007E000000003F000000003FC00000001FF00000000F
FF0000000FFFF0000003FFFE000001FFFFC00000FFFFF000003FFFFC000003FFFE000000
3FFF00000003FF000000007F800000001FC00000000FC000000007E000000003E0000000
03E000000001F0C0000001F0C0000001F0C0000000F0C0000000F0C0000000F0E0000000
F0E0000000F0E0000000E0F0000000E0F0000001E0F8000001C0F8000001C0FC00000380
FE00000780F700000700E1C0001E00E0F0003C00C07E00F000C00FFFE0008001FF000024
3D7CBB2C>I<7FFFFFFFFFFFC07FFFFFFFFFFFC07FC003FC003FC07E0001F8000FC07C00
01F80003C0780001F80001C0700001F80001C0700001F80000C0600001F80000C0600001
F80000C0E00001F80000E0E00001F80000E0C00001F8000060C00001F8000060C00001F8
000060C00001F8000060C00001F8000060C00001F8000060C00001F8000060000001F800
0000000001F8000000000001F8000000000001F8000000000001F8000000000001F80000
00000001F8000000000001F8000000000001F8000000000001F8000000000001F8000000
000001F8000000000001F8000000000001F8000000000001F8000000000001F800000000
0001F8000000000001F8000000000001F8000000000001F8000000000001F80000000000
01F8000000000001F8000000000001F8000000000001F8000000000001F8000000000001
F8000000000001F8000000000001F8000000000001F8000000000001F8000000000001F8
000000000001F8000000000001F8000000000001F8000000000001F8000000000001F800
0000000007FE0000000007FFFFFE00000007FFFFFE0000333B7DBA39>II<003F80000001C0F0000003
0038000004001C00000C001E000018000F00001C000F80003E000780003F0007C0003F00
07C0003F0007C0001E0007C000000007C000000007C000000007C00000003FC000000FE7
C000007E07C00001F007C00007E007C0000F8007C0001F0007C0003F0007C0003E0007C0
007E0007C0007C0007C060FC0007C060FC0007C060FC0007C060FC000FC060FC000FC060
7C000FC0607E0017C0603E0023E0C01F0041F18007C180FF0000FE003E0023257CA427>
97 D<0007F800003C0E0000F0018001E000C003C00060078000300F0000701F0000F81F
0001F83E0001F83E0001F87E0000F07C0000007C000000FC000000FC000000FC000000FC
000000FC000000FC000000FC000000FC000000FC0000007C0000007C0000007E0000003E
0000003E00000C1F00000C1F0000180F8000180780003003C0006001E000C000F0018000
3C0E000007F8001E257DA423>99 D<000FF00000383C0000E00F0001C00780038003C007
8001E00F0001F01F0000F01E0000F83E0000F83E0000F87C00007C7C00007C7C00007CFC
00007CFC00007CFFFFFFFCFC000000FC000000FC000000FC000000FC000000FC0000007C
0000007C0000007E0000003E0000003E00000C1E00000C1F0000180F0000180780003003
C0006001E000C000F00180003C0E000007F8001E257DA423>101
D<0000FC000003830000070380000E07C0001E0FC0003C0FC0007C0FC0007C0780007800
0000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
0000F8000000F8000000F8000000F8000000F80000FFFFFC00FFFFFC0000F8000000F800
0000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
0000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
0000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
0000F8000000F8000000F8000001FC00003FFFF0003FFFF0001A3C7FBB18>I<00000007
C0000FE01860003838207000F01E40F001E00F80F003C007806007C007C0000F8003E000
0F8003E0000F8003E0001F8003F0001F8003F0001F8003F0001F8003F0001F8003F0001F
8003F0000F8003E0000F8003E0000F8003E00007C007C00003C007800001E00F000003F0
1E00000238380000060FE00000040000000004000000000C000000000C000000000E0000
00000E000000000700000000078000000003FFFF000003FFFFF00001FFFFFC0000FFFFFE
00078000FF000E00001F801C000007C038000003C078000003C070000001E0F0000001E0
F0000001E0F0000001E0F0000001E0F0000001E078000003C038000003803C000007801E
00000F000700001C0003C0007800007803C000000FFE000024387EA527>I<038007C00F
E00FE00FE007C00380000000000000000000000000000000000000000000000000000003
E0FFE0FFE007E003E003E003E003E003E003E003E003E003E003E003E003E003E003E003
E003E003E003E003E003E003E003E003E003E003E003E003E003E003E003E007F0FFFFFF
FF10397EB815>105 D<03E000FFE000FFE00007E00003E00003E00003E00003E00003E0
0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
0007F000FFFF80FFFF80113C7EBB15>108 D<03E01FC0007F0000FFE060780181E000FF
E1803C0600F00007E2001E0800780003E4001F10007C0003E4001F10007C0003E8000F20
003C0003F0000FC0003E0003F0000FC0003E0003F0000FC0003E0003E0000F80003E0003
E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80
003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003
E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80
003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003
E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80003E0003E0000F80
003E0007F0001FC0007F00FFFF83FFFE0FFFF8FFFF83FFFE0FFFF83D257DA443>I<03E0
3FC000FFE0C0F000FFE100780007E2003C0003E4003E0003E8001E0003E8001E0003F000
1F0003F0001F0003F0001F0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F
0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F00
03E0001F0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F0003E0001F0003
E0001F0003E0001F0003E0001F0003E0001F0003E0001F0007F0003F80FFFF87FFFCFFFF
87FFFC26257DA42C>I<0007F00000003C1E000000F007800001C001C000038000E00007
8000F0000F000078001E00003C001E00003C003E00003E003E00003E007C00001F007C00
001F007C00001F00FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC0000
1F80FC00001F80FC00001F80FC00001F807C00001F007C00001F007C00001F003E00003E
003E00003E001E00003C001F00007C000F00007800078000F00003C001E00001C001C000
00F0078000003C1E00000007F0000021257DA427>I<03E03F8000FFE1C0F000FFE3003C
0007E4001E0003E8000F0003F000078003F00007C003E00003E003E00003E003E00001F0
03E00001F003E00001F803E00001F803E00000F803E00000FC03E00000FC03E00000FC03
E00000FC03E00000FC03E00000FC03E00000FC03E00000FC03E00000FC03E00000F803E0
0001F803E00001F803E00001F003E00003F003E00003E003E00007C003F00007C003F000
0F8003F8001F0003EC001E0003E600780003E181E00003E07F000003E000000003E00000
0003E000000003E000000003E000000003E000000003E000000003E000000003E0000000
03E000000003E000000003E000000003E000000003E000000007F0000000FFFF800000FF
FF80000026367DA42C>I<03E0FC00FFE10600FFE20F0007E41F8003E81F8003E81F8003
F00F0003F0060003F0000003F0000003E0000003E0000003E0000003E0000003E0000003
E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
E0000007F00000FFFFC000FFFFC00019257DA41E>114 D<00FF02000700C6000C002E00
10001E0030001E0060000E0060000E00E0000600E0000600E0000600F0000600F8000600
FC0000007F0000003FF000003FFF80001FFFE00007FFF00001FFFC00003FFE000001FE00
00003F00C0001F00C0000F80C0000780E0000380E0000380E0000380E0000380F0000300
F0000300F8000700F8000600E4000C00E2001800C1807000807F800019257DA41F>I<00
180000001800000018000000180000001800000038000000380000003800000038000000
7800000078000000F8000000F8000001F8000003F8000007F800001FFFFE00FFFFFE0000
F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000
F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000
F8000000F8018000F8018000F8018000F8018000F8018000F8018000F8018000F8018000
F801800078018000780300007C0300003C0200001E0600000F0C000003F00019357FB41E
>I123 D E end
%%EndProlog
%%BeginSetup
%%Feature: *Resolution 300dpi
TeXDict begin
%%PaperSize: a4

%%EndSetup
%%Page: 1 1
1 0 bop 315 305 a FC(A)-7 b(TENSOR)25 b({)i(REDUCE)e(program)j(for)f
(tensor)834 409 y(simpli\014cation)723 557 y FB(V.A.Ilyin)962
535 y FA(\003)980 557 y Fz(and)20 b FB(A.P)-5 b(.Kryuk)n(o)n(v)1403
535 y FA(y)371 631 y FB(Institute)17 b(of)j(Nuclear)e(Ph)n(ysics,)h
(Mosco)n(w)h(State)f(Univ)n(ersit)n(y)755 706 y(119899,)i(Mosco)n(w,)g
(Russia)882 823 y(April)c(10,)j(1996)118 1012 y Fy(PR)n(OGRAM)27
b(SUMMAR)-7 b(Y)118 1127 y Fz(Title)15 b(of)i(pr)n(o)n(gr)n(am:)j
Fx(A)l(TENSOR)118 1195 y Fz(Catalo)n(gue)c(numb)n(er:)118
1264 y(Pr)n(o)n(gr)n(am)28 b(available)f(fr)n(om:)46
b Fx(CPC)28 b(Program)d(Li-)118 1320 y(brary)l(,)12 b(Queen's)h(Univ)o
(ersit)o(y)e(of)h(Belfast,)f(N.)h(Ireland)118 1377 y(\(see)j
(application)f(form)g(in)h(this)f(issue\).)118 1445 y
Fz(Lic)n(ense)g(pr)n(ovisions:)20 b Fx(none)118 1513
y Fz(Computer:)f Fx(An)o(y)12 b(computers)f(where)h(REDUCE)g([7])118
1570 y(can)j(b)q(e)h(installed)118 1638 y Fz(Op)n(er)n(ation)g(system:)
k Fx(see)15 b(ab)q(o)o(v)o(e.)118 1706 y Fz(Pr)n(o)n(gr)n(amming)h
(language:)k Fx(REDUCE-3.4,)14 b(3.5)118 1774 y Fz(No.)21
b(of)16 b(bits)g(in)g(a)g(wor)n(d:)21 b Fx(32)118 1843
y Fz(No.)30 b(of)19 b(lines)f(in)h(distribute)n(d)g(pr)n(o)n(gr)n(am,)h
(including)118 1899 y(test)c(data,)h(etc.:)j Fx(1963)118
1967 y Fz(Keywor)n(ds:)f Fx(T)l(ensor,)13 b(symmetry)l(,)e(m)o
(ultiterm)e(linear)118 2024 y(iden)o(tities,)18 b(dumm)o(y)f(indices,)i
(simpli\014cation,)e(p)q(er-)118 2080 y(m)o(utation)c(group,)h(REDUCE,)
h(computer)f(algebra.)118 2149 y Fz(Natur)n(e)23 b(of)f(physic)n(al)f
(pr)n(oblem:)33 b Fx(Simpli\014cation)20 b(of)118 2205
y(tensor)27 b(expressions)h(with)e(taking)h(in)o(to)f(accoun)o(t)118
2261 y(m)o(ultiterm)10 b(linear)j(iden)o(tities,)f(symmetry)f
(relations)118 2318 y(and)21 b(renaming)e(dumm)o(y)g(indices.)37
b(This)20 b(problem)118 2374 y(is)14 b(imp)q(ortan)o(t)f(for)h(the)h
(calculations)f(in)g(the)h(gra)o(vit)o(y)118 2431 y(theory)l(,)d
(di\013eren)o(tial)f(geometry)l(,)g(other)g(\014elds)i(where)118
2487 y(indexed)j(ob)s(jects)f(arise.)p 118 2530 370 2
v 174 2561 a Fw(\003)193 2576 y Fv(E-mail:)j(ilyin@theory)m
(.npi.msu.su)176 2611 y Fw(y)193 2626 y Fv(E-mail:)g(kryuk)o(o)o
(v@theory)m(.npi.msu.su)1084 1012 y Fz(Metho)n(d)k(of)g(solution:)32
b Fx(The)21 b(group)g(algebra)g(tec)o(h-)1084 1068 y(nique)15
b(for)g(p)q(erm)o(utation)e(group)i(is)f(applied)h(to)g(con-)1084
1125 y(struct)21 b(a)g(canonical)g(subspace)h(and)g(the)g(e\013ectiv)o
(e)1084 1181 y(algorithm)12 b(for)j(the)g(corresp)q(onding)g(pro)s
(jection.)1084 1249 y Fz(R)n(estriction)20 b(on)h(the)h(c)n(omplexity)f
(of)h(the)f(pr)n(oblem:)1084 1306 y Fx(Computer)12 b(op)q(erativ)o(e)g
(memory)f(is)h(the)i(sev)o(erest)f(re-)1084 1362 y(striction.)1084
1430 y Fz(R)o(unning)h(time:)19 b Fx(It)14 b(dep)q(ends)h(on)f(the)f
(problem.)18 b(F)l(or)1084 1487 y(example)h(the)h(expression)g(con)o
(tained)f(con)o(traction)1084 1543 y(of)f(Riemann)h(tensor)g(with)f(an)
o(tisymmetr)o(ic)e(tensor)1084 1600 y(of)11 b(second)i(order)e
Fu(\017)1409 1607 y Ft(\026\027)1456 1600 y Fs(\003)s
Fu(R)1517 1607 y Ft(\026\027)r(\025\024)1604 1600 y Fs(\000)s
Fu(\017)1660 1607 y Ft(\013\014)1710 1600 y Fs(\003)s
Fu(R)1771 1607 y Ft(\025\024\014)r(\013)1870 1600 y Fx(require)1084
1656 y(ab)q(out)16 b(82s)f(CPU)h(time)e(on)i(HP9000/735)e(with)h(8M)
1084 1713 y(for)f(REDUCE.)1084 1781 y Fz(R)n(efer)n(enc)n(es:)1084
1837 y Fx([1])f(V.A.Ilyin)h(and)g(A.P)l(.Kryuk)o(o)o(v,)f(in)h(Pro)q
(c.)20 b(of)14 b(the)1084 1894 y(In)o(t.)25 b(Symp.)g(of)17
b(Sym)o(b)q(olic.)24 b(and)17 b(Algebraic)f(Com-)1084
1950 y(putation)h(\(ISSA)o(C'91\),)g(July)h(15-17,)f(1991,)g(Bonn,)1084
2007 y(Ed.)j(b)o(y)15 b(S.W)l(att,)f(A)o(CM)g(Press)h(\(1991\))e(224.)
1084 2067 y([2])h(V.A.Ilyin)h(and)h(A.P)l(.Kryuk)o(o)o(v,)e(in)h("New)g
(Com-)1084 2127 y(puting)31 b(tec)o(hniques)g(in)h(Ph)o(ysics)f
(Researc)o(h)g(I)q(I",)1084 2187 y(Pro)q(c.)22 b(of)15
b(AIHENP-92,)h(Ed.)22 b(b)o(y)16 b(D.P)o(erret-Gallix,)1084
2248 y(W)l(orld)e(Scien)o(ti\014c,)h(Singap)q(ore)g(\(1992\))e(639-348)
1051 2827 y Fr(1)p eop
%%Page: 2 2
2 1 bop 118 154 a Fy(LONG)28 b(WRITE-UP)118 353 y(1)81
b(In)n(tro)r(duction)118 463 y Fr(Ob)s(jects)12 b(with)h(indices)g(are)
f(often)h(used)f(in)h(math-)118 523 y(ematics)21 b(and)h(ph)o(ysics.)37
b(T)l(ensors)22 b(are)f(classical)118 583 y(examples)h(here)f([1,)g
(2].)37 b(Indexed)21 b(ob)s(jects)g(can)118 643 y(ha)o(v)o(e)16
b(v)o(ery)g(complicated)i(and)g(in)o(tricated)f(prop-)118
704 y(erties.)k(F)l(or)14 b(example)g(the)g(Riemann)g(tensor)h(has)118
764 y(symmetry)c(prop)q(erties)h(with)h(resp)q(ect)e(to)h(p)q(erm)o(u-)
118 824 y(tation)22 b(of)f(indices.)36 b(Moreo)o(v)o(er)19
b(it)i(satis\014es)h(the)118 884 y(cyclic)f(iden)o(tit)o(y)g([1].)35
b(There)21 b(are)g(a)h(n)o(um)o(b)q(er)e(of)118 944 y(linear)13
b(iden)o(tities)h(with)e(man)o(y)g(terms)g(in)g(the)g(case)118
1005 y(of)23 b(Riemann-Cartan)i(geometry)d(with)i(torsion)118
1065 y([2].)177 1125 y(So)29 b(there)e(is)i(a)f(problem)g(of)g
(reduction)h(of)118 1185 y(expressions)21 b(whic)o(h)f(con)o(tain)g
(indexed)g(ob)s(jects,)118 1245 y(called)d("tensor)g(expressions")h(b)q
(elo)o(w.)177 1305 y(Tw)o(o)f(reduction)g(strategies)g(can)f(b)q(e)h
(used.)177 1366 y(First,)k(the)f(corresp)q(onding)i(expressions)f(are)
118 1426 y(expanded)e(in)h(terms)e(of)i(basic)g(elemen)o(ts)e(to)h(re-)
118 1486 y(solv)o(e)k(symmetries)f(and)h(iden)o(tities)h(in)f(the)g
(ex-)118 1546 y(plicit)d(form.)29 b(Ho)o(w)o(ev)o(er,)17
b(this)j(w)o(a)o(y)f(requires)f(in-)118 1606 y(tro)q(ducing)h(a)e(lot)h
(of)g(ob)s(jects)f(of)g(di\013eren)o(t)h(t)o(yp)q(es)118
1667 y(and)c(rules)h(for)f(their)g(managemen)o(t.)20
b(In)13 b(the)h(Rie-)118 1727 y(mann)21 b(tensor)g(case,)g(these)g(are)
f(the)h(Christofel)118 1787 y(sym)o(b)q(ol,)15 b(the)g(metric)f
(tensor,)h(and)g(their)g(deriv)m(a-)118 1847 y(tiv)o(es.)38
b(As)21 b(a)h(rule,)h(this)g(leads)f(to)g(large)h(in)o(ter-)118
1907 y(mediate)18 b(expressions.)26 b(F)l(urthermore,)17
b(suc)o(h)h(an)118 1968 y(approac)o(h)k(fails,)i(for)d(instance,)i(in)f
(the)f(case)g(of)118 2028 y(geometry)16 b(with)h(torsion.)177
2088 y(Second)26 b(strategy)h(is)f(to)h(consider)f(indexed)118
2148 y(ob)s(jects)21 b(as)h(formal)g(ob)s(jects)f(with)h(some)f(prop-)
118 2208 y(erties.)57 b(Note)28 b(that)g(if)h(w)o(e)f(consider)h
(tensors)118 2269 y(whic)o(h)j(ha)o(v)o(e)e(only)i(symmetries)f
(corresp)q(ond-)118 2329 y(ing)d(to)f(p)q(erm)o(utation)g(indices)g
(and)g(renaming)118 2389 y(dumm)o(y)11 b(ones)h(then)f(the)h(problem)g
(can)g(b)q(e)g(solv)o(ed)118 2449 y(in)27 b(terms)e(of)i(double)g
(cosets)f(of)g(p)q(erm)o(utation)118 2509 y(group)18
b([3].)k(Ho)o(w)o(ev)o(er,)14 b(if)k(linear)g(iden)o(tities)f(with)118
2570 y(man)o(y)11 b(terms)g(\()p Fq(>)j Fr(2\))d(are)h(presen)o(t,)f
(this)h(approac)o(h)118 2630 y(fails)j(b)q(ecause)f(the)f(summation)h
(op)q(erator)h(lea)o(v)o(es)118 2690 y(the)h(group)h(framew)o(ork.)1143
154 y(Our)j(approac)o(h)g(to)h(the)e(problem)i(of)f(simpli-)1084
214 y(\014cation)27 b(of)f(tensor)g(expressions)h(is)g(based)f(on)1084
274 y(the)e(consideration)j(of)e(tensor)g(expressions)g(as)1084
334 y(v)o(ectors)19 b(in)h(some)g(linear)h(space.)33
b(The)20 b(prelimi-)1084 394 y(nary)12 b(v)o(ersion)h(of)g(this)g(idea)
g(w)o(as)g(prop)q(osed)h(in)f([4].)1084 455 y(The)k(adv)m(anced)h(v)o
(ersion)f(of)h(the)f(algorithm)i(w)o(as)1084 515 y(presen)o(ted)d(at)h
(ISSA)o(C'91)g([8])g(and)g(AIHENP-92)1084 575 y([9].)j(Here)14
b(w)o(e)h(presen)o(t)g(a)h(program)g(in)g(whic)o(h)f(w)o(e)1084
635 y(implemen)o(t)21 b(the)h(prop)q(osed)h(algorithm)h(in)f(RE-)1084
695 y(DUCE)12 b(and)h(giv)o(e)g(a)f(detailed)i(description)f(of)g(the)
1084 756 y(program.)32 b(W)l(e)20 b(generalized)g(the)g(algorithm)i(to)
1084 816 y(the)16 b(case)g(of)h(tensor)f(m)o(ultiplication.)1143
876 y(Complemen)o(tary)f(approac)o(h)g(w)o(as)h(dev)o(elop)q(ed)1084
936 y(in)h([11].)22 b(Here)16 b(Y)l(oung)h(diagram)h(tec)o(hnique)d(w)o
(as)1084 996 y(used)k(to)h(solv)o(e)f(the)g(simpli\014cation)k(problem)
c(in)1084 1056 y(some)i(sp)q(eci\014c)g(case.)36 b(Namely)l(,)21
b(when)g(dumm)o(y)1084 1117 y(indices)d(are)g(allo)o(w)o(ed)g(only)h(b)
q(et)o(w)o(een)d(basic)j(ten-)1084 1177 y(sors)24 b(for)g(whic)o(h)g
(generic)g(symmetry)e(relations)1084 1237 y(and)27 b(m)o(ultiterm)e
(linear)j(iden)o(tities)f(should)h(b)q(e)1084 1297 y(imp)q(osed.)21
b(Although)16 b(this)e(algorithm)j(is)d(a)h(p)q(o)o(w-)1084
1357 y(erful)i(to)q(ol)i(in)f(`indicial)i(tensor)d(calculations')j(of)
1084 1418 y(asymptotic)12 b(expansions)i(of)e(heat)g(k)o(ernels)f(of)h
(dif-)1084 1478 y(feren)o(tial)k(op)q(erators)i(it)f(fails)h(in)f
(general)g(case.)1143 1538 y(F)l(rom)h(the)h(user's)f(p)q(oin)o(t)i(of)
f(view,)h(there)e(are)1084 1598 y(three)d(groups)j(of)e(tensor)h(prop)q
(erties:)1084 1670 y Fp(S)f Fr(-)f(symmetry)g(with)h(resp)q(ect)f(to)h
(index)g(p)q(erm)o(u-)1084 1730 y(tations;)1084 1791
y Fp(I)g Fr(-)g(linear)i(iden)o(tities.)1084 1851 y Fp(D)d
Fr(-)g(in)o(v)m(ariance)h(with)g(resp)q(ect)f(to)g(renamings)i(of)1084
1911 y(dumm)o(y)e(indices;)1143 1983 y(As)j(an)h(illustration,)i(for)e
(the)f(Riemann)h(cur-)1084 2043 y(v)m(ature)d(tensor)h(these)f(prop)q
(erties)h(are:)1168 2108 y Fo(S:)60 b Fu(R)1307 2115
y Ft(abcd)1389 2108 y Fx(=)13 b Fu(R)1472 2115 y Ft(cdab)1540
2108 y Fu(;)99 b(R)1687 2115 y Ft(abcd)1768 2108 y Fx(=)13
b Fs(\000)p Fu(R)1886 2115 y Ft(bacd)1955 2108 y Fx(;)1168
2165 y Fo(I:)69 b Fu(R)1307 2172 y Ft(abcd)1386 2165
y Fx(+)11 b Fu(R)1467 2172 y Ft(acdb)1546 2165 y Fx(+)f
Fu(R)1626 2172 y Ft(adbc)1707 2165 y Fx(=)j(0;)1168 2221
y Fo(D:)49 b Fu(R)1307 2228 y Ft(abcd)1376 2221 y Fu(R)1411
2228 y Ft(ck)q(mn)1500 2221 y Fu(R)1535 2228 y Ft(dlps)1612
2221 y Fx(=)13 b Fu(R)1695 2228 y Ft(abdc)1764 2221 y
Fu(R)1799 2228 y Ft(dk)q(mn)1891 2221 y Fu(R)1926 2228
y Ft(clps)1987 2221 y Fu(:)1143 2314 y Fr(Note)h(that)h(m)o(ultiterm)f
(linear)i(iden)o(tities)f(will)1084 2374 y(pro)q(duce)30
b(man)o(y)f(rewriting)i(rules)g(whic)o(h)f(can)1084 2435
y(complicate)17 b(the)f(problem)g(essen)o(tially)l(.)1143
2495 y(The)i(problem)h(under)g(in)o(v)o(estigation)h(can)f(b)q(e)1084
2555 y(form)o(ulated)f(as)g(a)g(question:)24 b Fn(whether)19
b(two)g(ten-)1084 2615 y(sor)c(expr)n(essions)h(ar)n(e)f(e)n(qual)h(or)
f(not,)i(taking)f(into)1084 2675 y(ac)n(c)n(ount)22 b(S-I-D)h(pr)n(op)n
(erties?)35 b Fr(Then)21 b(the)g(prob-)1051 2827 y(2)p
eop
%%Page: 3 3
3 2 bop 118 154 a Fr(lem)12 b(of)g Fn(simplest)h(\(shortest\))g(c)n
(anonic)n(al)h(form)f(for)118 214 y(given)19 b(expr)n(ession)f(arises)f
(as)g(a)h(c)n(entr)n(al)f(one.)118 377 y Fy(2)81 b(Basic)33
b(tensors)g(and)f(ten-)239 468 y(sor)27 b(expressions)118
578 y Fr(Let)16 b(us)h(giv)o(e)f(some)h(de\014nitions.)177
638 y(Under)k Fn(b)n(asic)i(tensors)f Fr(w)o(e)g(will)i(understand)118
698 y(the)29 b(ob)s(ject)g(with)i(\014nite)f(n)o(um)o(b)q(er)f(of)g
(indices)118 758 y(whic)o(h)13 b(can)g(ha)o(v)o(e)e(suc)o(h)i(prop)q
(erties)g(as)g Fn(symmetry)118 819 y Fr(and)k Fn(multiterm)h(line)n(ar)
g(identities)770 801 y Fm(1)791 819 y Fr(.)177 879 y(Then,)12
b(under)f Fn(tensor)h(expr)n(ession)g Fr(w)o(e)e(will)j(un-)118
939 y(derstand)22 b(an)o(y)g(expression)h(whic)o(h)f(can)g(b)q(e)f(ob-)
118 999 y(tained)h(from)e(basic)i(tensors)g(with)f(the)g(help)g(of)118
1059 y(the)16 b(follo)o(wing)j(op)q(erations:)191 1143
y Fl(\017)24 b Fr(summation)17 b(with)g(in)o(teger)g(co)q(e\016cien)o
(ts;)191 1238 y Fl(\017)24 b Fr(m)o(ultiplication)19
b(\(comm)o(utativ)o(e\))14 b(of)i(basic)240 1298 y(tensors)389
1280 y Fm(2)409 1298 y Fr(.)177 1382 y(W)l(e)21 b(assume)g(that)g(all)h
(terms)f(in)g(the)g(tensor)118 1442 y(expression)14 b(ha)o(v)o(e)e(the)
h(same)f(n)o(um)o(b)q(er)h(of)g(indices.)118 1502 y(Some)19
b(pairs)h(of)g(them)e(are)h(mark)o(ed)g(as)g(dumm)o(y)118
1562 y(ones.)46 b(The)24 b(set)g(of)h(nondumm)o(y)f(names)g(ha)o(v)o(e)
118 1623 y(to)19 b(b)q(e)g(the)f(same)g(for)h(eac)o(h)f(term)g(in)h
(the)f(tensor)118 1683 y(expression.)29 b(The)19 b(names)g(of)g
(dummies)f(can)h(b)q(e)118 1743 y(arbitrary)l(.)118 1906
y Fy(3)81 b(Algebraic)28 b(approac)n(h)118 2016 y Fr(T)l(o)14
b(start)f(with,)h(let)g(us)f(consider)h(the)f(case)g(of)g(one)118
2076 y(basic)25 b(tensor)e(and)i(tensor)e(expressions)i(whic)o(h)118
2136 y(are)18 b(linear)g(com)o(binations)h(of)f(this)g(basic)h(tensor)
118 2196 y(with)c(in)o(teger)g(co)q(e\016cien)o(ts)f(\(i.e.)20
b(without)c(m)o(ulti-)118 2256 y(plication)j(of)d(tensors\).)177
2317 y(Let)27 b(a)h(tensor)f Fq(F)33 b Fr(has)28 b(indices)g
Fq(\026)847 2324 y Fm(1)867 2317 y Fq(;)8 b(:)g(:)g(:)f(;)h(\026)1005
2324 y Ft(n)1029 2317 y Fr(.)118 2377 y(There)16 b(are)g
Fq(n)p Fr(!)g(formally)i(di\013eren)o(t)e(ob)s(jects)118
2486 y Fq(F)150 2494 y Ft(\031)q Fm(\()p Ft(\026)206
2499 y Fk(1)223 2494 y Ft(;:::;\026)294 2498 y Fj(n)315
2494 y Fm(\))331 2486 y Fq(;)56 b(\031)16 b Fr(=)496
2426 y Fi(\032)569 2456 y Fr(1)83 b Fl(\001)8 b(\001)g(\001)83
b Fq(n)536 2517 y(\031)r Fr(\(1\))48 b Fl(\001)8 b(\001)g(\001)49
b Fq(\031)r Fr(\()p Fq(n)p Fr(\))888 2426 y Fi(\033)933
2486 y Fl(2)14 b Fq(S)1010 2493 y Ft(n)1034 2486 y Fq(;)p
118 2557 370 2 v 174 2588 a Fh(1)193 2603 y Fv(The)h(symmetry)f
(relations)i(are)f(partial)g(case)h(of)d(lin-)118 2652
y(ear)h(iden)o(tities)j(indeed)174 2687 y Fh(2)193 2702
y Fv(Including)e(con)o(traction)g(of)e(indices.)1084
154 y Fr(where)e Fq(S)1250 161 y Ft(n)1286 154 y Fr(is)h(the)g(group)h
(of)f(p)q(erm)o(utations)h(of)f(the)1084 214 y(set)k(\(1)p
Fq(;)8 b(:)g(:)g(:)g(;)g(n)p Fr(\))16 b(and)1181 376
y Fq(\031)r Fr(\()p Fq(\026)1259 383 y Fm(1)1279 376
y Fq(;)8 b(:)g(:)g(:)f(;)h(\026)1417 383 y Ft(n)1441
376 y Fr(\))14 b Fl(\021)f Fr(\()p Fq(\031)r Fr(\()p
Fq(\026)1623 383 y Fm(1)1643 376 y Fr(\))p Fq(;)8 b(:)g(:)g(:)f(;)h
(\031)r Fr(\()p Fq(\026)1849 383 y Ft(n)1872 376 y Fr(\)\))1084
478 y(.)1143 538 y(If)19 b Fq(F)26 b Fr(has)20 b(symmetries)f(with)i
(resp)q(ect)e(to)h(in-)1084 598 y(dex)g(p)q(erm)o(utations)i(it)g
(means)f(that)g(there)g(is)g(a)1084 658 y(subgroup)c
Fq(H)h Fl(2)d Fq(S)1431 665 y Ft(n)1470 658 y Fr(suc)o(h)h(that)1153
760 y Fq(F)1185 767 y Ft(h)p Fg(\016)p Ft(\031)1271 760
y Fl(\000)25 b Fq(d)p Fr(\()p Fq(h)p Fr(\))11 b Fl(\001)g
Fq(F)1494 767 y Ft(\031)1545 760 y Fr(=)28 b(0)p Fq(;)106
b Fl(8)p Fq(h)12 b Fl(2)i Fq(S)1901 767 y Ft(n)1925 760
y Fr(;)1084 862 y Fq(d)p Fr(\()p Fq(h)p Fr(\))g Fl(2)g
Fq(R)1273 841 y Fm(1)1293 862 y Fr(;)22 b Fq(h)p Fl(\016)p
Fq(\031)16 b Fl(\021)d Fr(\()p Fq(\031)r Fr(\()p Fq(h)p
Fr(\()p Fq(\026)1622 869 y Fm(1)1642 862 y Fr(\)\))p
Fq(;)8 b(:)g(:)g(:)f(;)h(\031)r Fr(\()p Fq(h)p Fr(\()p
Fq(\026)1914 869 y Ft(n)1937 862 y Fr(\)\)\))p Fq(:)1143
945 y Fr(Multiterm)j(linear)i(iden)o(tities)f(can)f(b)q(e)g(written)
1084 1006 y(in)17 b(the)f(follo)o(wing)j(form)1255 1066
y Fi(X)1241 1158 y Ft(\031)q Fg(2)p Ft(S)1307 1162 y
Fj(n)1354 1107 y Fq(\013)1385 1114 y Ft(\031)1419 1107
y Fl(\001)11 b Fq(F)1476 1114 y Ft(\031)1513 1107 y Fr(=)j(0)p
Fq(;)57 b(\013)1691 1114 y Ft(\031)1728 1107 y Fl(2)14
b Fp(R)1817 1087 y Fm(1)1837 1107 y Fq(:)1143 1246 y
Fr(If)35 b(some)h(pairs)h(of)f(dumm)o(y)f(indices)i(are)1084
1307 y(presen)o(t)24 b(without)i(an)o(y)f(loss)h(of)g(generalit)o(y)f
(w)o(e)1084 1367 y(ma)o(y)20 b(supp)q(ose)i(that)f(their)g(names)f(are)
h(already)1084 1427 y(normalized)29 b(in)g(some)f(w)o(a)o(y)l(,)i(i.e.)
56 b(they)28 b(ha)o(v)o(e)1084 1487 y(\014xed)c(names.)47
b(Therefore)24 b(one)h(can)g(only)g(ex-)1084 1547 y(c)o(hange)d(these)g
(names:)34 b(1\))22 b(c)o(hange)h(names)f(in-)1084 1607
y(side)d(eac)o(h)f(pair)h(and)g(2\))g(c)o(hange)f(pairs)i(of)e(these)
1084 1668 y(names.)i(With)12 b(this)h(restriction)g(the)f(exc)o
(hanging)1084 1728 y(of)23 b(dumm)o(y)f(indices)i(means)f(that)h(a)g
(subgroup)1084 1788 y Fq(M)19 b Fl(2)14 b Fq(S)1227 1795
y Ft(n)1267 1788 y Fr(exists)i(suc)o(h)g(that)1600 1770
y Fm(3)1132 1890 y Fq(F)1164 1898 y Ft(\031)q Fg(\016)p
Ft(m)p Fm(\()p Ft(\026)1269 1903 y Fk(1)1287 1898 y Ft(;)p
Fg(\001\001\001)o Ft(;\026)1357 1902 y Fj(n)1378 1898
y Fm(\))1408 1890 y Fr(=)d Fq(F)1491 1897 y Ft(\031)1515
1890 y Fq(;)56 b Fl(8)13 b Fq(m)g Fl(2)h Fq(M)r(;)8 b(\031)16
b Fl(2)e Fq(S)1922 1897 y Ft(n)1946 1890 y Fq(:)1143
1992 y Fr(Let)j(us)g(consider)h(no)o(w)g Fn(the)g(gr)n(oup)g(algebr)n
(a)g Fr(of)1084 2052 y Fq(S)1114 2059 y Ft(n)1156 2052
y Fr([5].)29 b(This)20 b(is)g(a)f(linear)h(space)f Fp(R)1773
2034 y Ft(n)p Fm(!)1825 2052 y Fr(in)h(whic)o(h)1084
2112 y(unit)d(v)o(ectors)e(corresp)q(ond)i(to)g(p)q(erm)o(utations:)
1337 2214 y Fp(R)1379 2193 y Ft(n)p Fm(!)1426 2214 y
Fl(3)d Fq(e)1496 2221 y Ft(\031)1533 2214 y Fl($)g Fq(\031)h
Fl(2)f Fq(S)1717 2221 y Ft(n)1741 2214 y Fq(:)1143 2316
y Fr(The)26 b(v)o(ectors)f Fq(e)1451 2323 y Ft(\031)1500
2316 y Fr(are)h(orthogonal)j(to)d(eac)o(h)1084 2376 y(other)16
b(in)h(the)f(Euclidean)i(metric.)p 1084 2407 V 1140 2438
a Fh(3)1158 2453 y Fv(The)i(di\013erence)i(in)d(actions)h(of)e
Ff(H)k Fv(and)d Ff(M)k Fv(on)c Ff(S)1985 2459 y Fe(n)1084
2503 y Fv(in)j(the)g(discussed)j(relations)e(\()p Ff(h)15
b FA(\016)f Ff(\031)23 b Fv(and)e Ff(\031)16 b FA(\016)e
Ff(m)22 b Fv(\))g(is)1084 2553 y(connected)17 b(with)f(the)f
(di\013eren)o(t)i(nature)f(of)f(these)h(trans-)1084 2603
y(formations:)28 b(the)20 b(symmetry)g(acts)g(up)q(on)f(place)i(of)d
(in-)1084 2652 y(dices)d(while)g(dumm)o(y)e(indices)j(renaming)d(acts)i
(up)q(on)e(the)1084 2702 y(names.)1051 2827 y Fr(3)p
eop
%%Page: 4 4
4 3 bop 177 154 a Fr(So)21 b(w)o(e)e(ha)o(v)o(e)g(an)h(explicit)h
(isomorphism)h(b)q(e-)118 214 y(t)o(w)o(een)15 b(tensor)h(expressions)h
(and)g(p)q(oin)o(ts)g(in)g Fp(R)996 196 y Ft(n)p Fm(!)1029
214 y Fr(:)325 279 y Fi(X)344 366 y Ft(\031)394 320 y
Fq(\013)425 327 y Ft(\031)459 320 y Fl(\001)11 b Fq(e)507
327 y Ft(\031)544 320 y Fl($)608 279 y Fi(X)627 366 y
Ft(\031)676 320 y Fq(\013)707 327 y Ft(\031)742 320 y
Fl(\001)f Fq(F)798 327 y Ft(\031)822 320 y Fq(;)118 485
y Fd(3.1)66 b(Subspace)23 b(K)118 577 y Fr(In)d(terms)f(of)i
Fp(R)424 559 y Ft(n)p Fm(!)457 577 y Fr(,)f(the)g(left)g(hand)h(sides)g
(of)f(the)118 638 y Fp(S-I-D)c Fr(relations)i(corresp)q(ond)f(to)g(the)
f(v)o(ectors)145 779 y Fq(e)168 786 y Ft(h)p Fg(\016)p
Ft(\031)240 779 y Fl(\000)11 b Fq(d)p Fr(\()p Fq(h)p
Fr(\))p Fq(e)404 786 y Ft(\031)427 779 y Fq(;)57 b(e)521
786 y Ft(\031)q Fg(\016)p Ft(m)604 779 y Fl(\000)11 b
Fq(e)677 786 y Ft(\031)700 779 y Fq(;)787 725 y Ft(n)p
Fm(!)773 738 y Fi(X)771 830 y Ft(k)q Fm(=1)843 779 y
Fq(\013)874 786 y Ft(k)896 779 y Fq(e)919 786 y Ft(k)940
779 y Fq(;)26 b Fr(\(1\))324 946 y Fq(h)14 b Fl(2)g Fq(H)q(;)22
b(m)14 b Fl(2)g Fq(M)r(;)22 b(\031)15 b Fl(2)f Fq(S)799
953 y Ft(n)823 946 y Fq(:)177 1032 y Fr(These)20 b(v)o(ectors)g(span)h
(some)g(subspace)f Fp(K)h Fl(2)118 1092 y Fp(R)160 1074
y Ft(n)p Fm(!)193 1092 y Fr(.)g(W)l(e)16 b(denote)h(its)g(dimension)g
(as)g Fq(K)t Fr(.)177 1152 y(No)o(w)12 b(w)o(e)g(can)g(split)i(group)f
(algebra)g(of)g Fq(S)924 1159 y Ft(n)960 1152 y Fr(in)o(to)118
1212 y(orthogonal)19 b(comp)q(onen)o(ts)f(in)f(terms)f(of)h(the)g(Eu-)
118 1273 y(clidean)g(metric)430 1379 y Fp(R)472 1359
y Ft(n)p Fm(!)519 1379 y Fr(=)c Fp(K)e Fl(\010)g Fp(Q)p
Fq(:)177 1486 y Fr(It)18 b(is)h(ob)o(vious)g(that)g(all)h(p)q(oin)o(ts)
f(of)g Fp(R)887 1468 y Ft(n)p Fm(!)938 1486 y Fr(lying)118
1546 y(in)13 b Fp(K)f Fr(corresp)q(ond)h(to)f(tensor)h(expressions)g
(whic)o(h)118 1606 y(are)18 b(equal)g(to)g(zero)f(due)h(to)g(the)f
Fp(S-I-D)g Fr(prop)q(er-)118 1666 y(ties.)j(Th)o(us,)13
b(an)o(y)e(t)o(w)o(o)h(p)q(oin)o(ts)h Fq(A)e Fr(and)i
Fq(A)852 1648 y Fg(0)875 1666 y Fr(lying)g(on)118 1727
y(the)j(plane)g(parallel)i(to)e Fp(K)g Fr(corresp)q(ond)h(to)f(equal)
118 1787 y(expressions:)252 1893 y(\()p Fq(A)11 b Fl(\000)f
Fq(A)405 1873 y Fg(0)417 1893 y Fr(\))j Fl($)527 1852
y Fi(X)513 1944 y Ft(\031)q Fg(2)p Ft(S)579 1948 y Fj(n)609
1893 y Fq(\013)640 1873 y Ft(S)r(I)s(D)640 1906 y(\031)725
1893 y Fl(\001)e Fq(F)782 1900 y Ft(\031)819 1893 y Fr(=)i(0)p
Fq(:)177 2040 y Fr(The)25 b(\()p Fq(n)p Fr(!)17 b Fl(\000)g
Fq(K)t Fr(\))25 b(dimensional)i(subspace)f Fp(Q)118 2100
y Fr(could)g(b)q(e)g(c)o(hosen)f(as)h(a)g(set)g(of)f(canonical)j(el-)
118 2160 y(emen)o(ts:)48 b(a)30 b(p)q(oin)o(t)h Fq(A)561
2167 y Ft(Q)621 2160 y Fr(can)f(b)q(e)g(determined)118
2221 y(as)21 b(a)g(canonical)h(represen)o(tativ)o(e)d(of)i(the)f
Fp(S-I-D)118 2281 y Fr(equiv)m(alence)g(class)g(of)g
Fq(A)p Fr(.)31 b(Then)19 b(one)h(can)g(con-)118 2341
y(clude)j(that)g(the)g(problem)g(of)g(comparing)h(ten-)118
2401 y(sor)e(expressions)h(ma)o(y)d(b)q(e)i(solv)o(ed)g(b)o(y)f
(compar-)118 2461 y(ing)27 b(their)g(canonical)h(represen)o(tativ)o
(es.)50 b(Suc)o(h)118 2522 y(an)30 b(approac)o(h)g(w)o(as)f(dev)o(elop)
q(ed)g(in)h([4])f(where)118 2582 y(the)15 b(Gramm-Sc)o(hmidt)f
(orthogonali)q(zatio)q(n)k(pro-)118 2642 y(cedure)10
b(w)o(as)i(used)f(as)g(a)h(main)f(tec)o(hnical)g(metho)q(d.)118
2702 y(Ho)o(w)o(ev)o(er,)17 b(this)i(pro)q(cedure)f(requires)g(to)q(o)h
(m)o(uc)o(h)1084 154 y(time)i(and)g(computer)g(memory)f(during)j
(execu-)1084 214 y(tions.)1143 274 y(In)e([8)o(])g(the)g(authors)h
(prop)q(osed)g(an)g(e\013ectiv)o(e)1084 334 y(pro)q(cedure)14
b(where)g(another)h(subspace,)g(denoted)1084 394 y(b)q(elo)o(w)i(as)f
Fp(L)p Fr(,)g(had)g(b)q(een)g(considered)h(as)f(a)h(set)f(of)1084
455 y(canonical)k(elemen)o(ts.)27 b(In)19 b(the)f(next)g(section)h(w)o
(e)1084 515 y(giv)o(e)13 b(a)g(concise)h(form)o(ulation)g(of)f(this)h
(pro)q(cedure.)1084 659 y Fd(3.2)66 b("T)-6 b(riangle")23
b(S-I-D)g(basis)1084 752 y Fr(Let's)16 b(designate)h(v)o(ectors)f
(\(1\))g(as)1227 899 y Fq(V)1266 879 y Fm(0)1255 911
y Ft(k)1300 899 y Fr(=)1367 845 y Ft(n)p Fm(!)1352 858
y Fi(X)1352 949 y Ft(j)r Fm(=1)1421 899 y Fq(\013)1452
879 y Fm(0)1452 911 y Ft(k)q(j)1490 899 y Fq(e)1513 906
y Ft(j)1531 899 y Fq(;)21 b(k)16 b Fr(=)e(\(1)p Fq(;)8
b(:::;)1800 887 y Fr(~)1788 899 y Fq(K)s Fr(\))p Fq(:)81
b Fr(\(2\))1143 1048 y(Then)15 b(w)o(e)g(construct)g(new)g(v)o(ectors)g
(b)o(y)f(recur-)1084 1108 y(ren)o(t)i(applying)k(\(with)e(steps)f
Fq(m)f Fr(=)g(1)p Fq(;)8 b(:)g(:)g(:)f(;)1900 1096 y
Fr(~)1887 1108 y Fq(K)t Fr(\))18 b(of)1084 1168 y(the)e(follo)o(wing)j
(transformation:)1143 1228 y(|)i Fn(if)i Fq(V)1305 1210
y Ft(m)p Fg(\000)p Fm(1)1294 1241 y Ft(m)1406 1228 y
Fl(6)p Fr(=)g(0)g Fn(then)g(de\014ne)h Fq(k)1799 1235
y Ft(m)1855 1228 y Fn(by)f(\014rst)1084 1289 y(nonzer)n(o)17
b(c)n(o)n(e\016cient)i(in)e Fq(V)1594 1271 y Ft(m)p Fg(\000)p
Fm(1)1582 1301 y Ft(m)1690 1289 y Fn(and)g(let)1209 1399
y Fq(V)1248 1378 y Ft(m)1237 1411 y(k)1295 1399 y Fl(\021)d
Fq(V)1387 1378 y Ft(m)p Fg(\000)p Fm(1)1376 1411 y Ft(k)1465
1399 y Fq(;)106 b(k)15 b Fr(=)f(1)p Fq(;)8 b(:)g(:)g(:)g(;)g(k)1836
1406 y Ft(m)1870 1399 y Fr(;)1109 1544 y Fq(V)1148 1524
y Ft(m)1137 1557 y(k)1195 1544 y Fl(\021)14 b Fq(V)1287
1524 y Ft(m)p Fg(\000)p Fm(1)1276 1557 y Ft(k)1371 1544
y Fl(\000)1429 1491 y Ft(m)1415 1503 y Fi(X)1417 1594
y Ft(i)p Fm(=1)1488 1507 y Fq(\013)1519 1487 y Ft(m)p
Fg(\000)p Fm(1)1519 1520 y Ft(k)q(j)1552 1525 y Fj(i)p
1488 1533 110 2 v 1488 1580 a Fq(\013)1519 1559 y Ft(m)p
Fg(\000)p Fm(1)1519 1592 y Ft(k)1537 1597 y Fj(i)1550
1592 y Ft(j)1564 1597 y Fj(i)1602 1544 y Fq(V)1642 1524
y Ft(m)p Fg(\000)p Fm(1)1630 1557 y Ft(k)1648 1562 y
Fj(i)1720 1544 y Fq(;)22 b(k)16 b(>)d(k)1873 1551 y Ft(m)1907
1544 y Fr(;)25 b(\(3\))1084 1672 y(|)16 b Fn(if)h Fq(V)1235
1654 y Ft(m)p Fg(\000)p Fm(1)1224 1684 y Ft(m)1328 1672
y Fr(=)c(0)18 b Fn(then)h Fq(V)1569 1654 y Ft(m)1558
1684 y(k)1616 1672 y Fl(\021)14 b Fq(V)1708 1651 y Ft(m)p
Fg(\000)p Fm(1)1697 1685 y Ft(k)1786 1672 y Fn(.)1143
1732 y Fr(As)g(a)g(result,)h(w)o(e)e(ha)o(v)o(e)h(a)g(set)g(of)g
(nonzero)h(v)o(ec-)1084 1792 y(tors)g Fq(V)1219 1767
y Fm(\()p Ft(K)r Fm(\))1208 1805 y Ft(k)1295 1792 y Fr(whic)o(h)f(span)
h(the)f(subspace)h Fp(K)p Fr(.)20 b(Note)1084 1859 y(that)13
b(all)h(nonzero)e(v)o(ectors)g Fq(V)1628 1834 y Fm(\()p
Ft(K)r Fm(\))1617 1872 y Ft(k)1702 1859 y Fr(are)h(linearly)h(in-)1084
1920 y(dep)q(enden)o(t.)30 b(Indeed,)19 b(let)g(us)h(reorder)f(the)g
(unit)1084 1980 y(v)o(ectors)1187 2090 y(\()p Fq(e)1229
2097 y Fm(1)1248 2090 y Fq(;)8 b(:)g(:)g(:)g(;)g(e)1381
2097 y Ft(n)p Fm(!)1413 2090 y Fr(\))14 b Fl(\000)-8
b(!)13 b Fr(\()p Fq(e)1582 2097 y Ft(j)1596 2102 y Fk(1)1616
2090 y Fq(;)8 b(:)g(:)g(:)f(;)h(e)1748 2097 y Ft(j)1762
2101 y Fj(m)1793 2090 y Fq(;)g(:)g(:)g(:)o Fr(\))p Fq(:)1084
2208 y Fr(Then)24 b(the)g(v)o(ectors)g Fq(V)1524 2183
y Fm(\()p Ft(K)r Fm(\))1513 2221 y Ft(k)1610 2208 y Fr(with)h
Fq(k)k Fl(\025)e Fq(k)1874 2215 y Ft(m)1932 2208 y Fr(will)1084
2268 y(ha)o(v)o(e)17 b(zero)h(pro)s(jections)h(on)o(to)g(the)f(unit)h
(v)o(ectors)1084 2328 y Fq(e)1107 2335 y Ft(j)1121 2340
y Fj(i)1148 2328 y Fr(\()p Fq(i)13 b(<)h(m)p Fr(\).)19
b(In)12 b(other)g(w)o(ords,)g(the)g(set)f Fq(V)1864 2303
y Fm(\()p Ft(K)r Fm(\))1852 2341 y Ft(k)1937 2328 y Fr(has)1084
2389 y(a)16 b("triangle")i(form)e(in)g(this)h(reordered)e(basis.)22
b(It)1084 2449 y(is)16 b(eviden)o(t)f(that)h(a)f(n)o(um)o(b)q(er)g(of)h
(nonzero)g(v)o(ectors)1084 2509 y Fq(V)1123 2484 y Fm(\()p
Ft(K)r Fm(\))1112 2522 y Ft(k)1205 2509 y Fr(is)21 b(equal)g(to)g
Fq(K)k Fr(-)20 b(the)h(dimension)g(of)g(the)1084 2569
y Fp(S-I-D)15 b Fr(subspace)i Fp(K)p Fr(.)1143 2629 y(W)l(e)g(ha)o(v)o
(e)g(made)g(some)g(optimization)j(in)e(ad-)1084 2690
y(dition)g(to)e(the)g(transformation)i(\(3\):)1051 2827
y(4)p eop
%%Page: 5 5
5 4 bop 177 154 a Fn(on)26 b(e)n(ach)g(step)h Fq(m)e
Fn(al)r(l)i(alr)n(e)n(ady)e(c)n(onstructe)n(d)118 214
y(nonzer)n(o)18 b(ve)n(ctors)g Fq(V)505 188 y Fm(\()p
Ft(K)r Fm(\))493 226 y Ft(k)511 231 y Fj(i)584 214 y
Fn(\()p Fq(i)d(<)f(m)p Fn(\))k(ar)n(e)f(impr)n(ove)n(d)118
274 y(by)h(the)g(fol)r(lowing)h(tr)n(ansformation)p Fr(:)196
452 y Fq(V)236 431 y Ft(m)224 464 y(k)242 469 y Fj(i)283
452 y Fl(!)14 b Fq(V)386 431 y Ft(m)375 464 y(k)393 469
y Fj(i)430 452 y Fl(\000)493 415 y Fq(\013)524 397 y
Ft(m)524 427 y(k)542 432 y Fj(i)556 427 y Ft(j)570 431
y Fj(m)p 485 440 125 2 v 485 486 a Fq(\013)516 469 y
Ft(m)516 499 y(k)534 503 y Fj(m)564 499 y Ft(j)578 503
y Fj(m)614 452 y Fq(V)654 431 y Ft(m)642 464 y(k)660
468 y Fj(m)692 452 y Fq(;)57 b(i)14 b(<)f(m:)78 b Fr(\(4\))177
588 y(Suc)o(h)16 b(optimization)j(do)q(esn't)e(sp)q(oil)i(the)d("tri-)
118 648 y(angle")23 b(structure)d(and)i(v)o(ectors)e
Fq(V)797 630 y Ft(k)786 661 y(i)840 648 y Fr(with)h Fq(k)j(<)118
709 y(k)143 716 y Ft(m)194 709 y Fr(will)c(ha)o(v)o(e)d(zero)g(pro)s
(jections)i(on)o(to)f(the)g(unit)118 769 y(v)o(ectors)i
Fq(e)311 776 y Ft(j)350 769 y Fr(with)i Fq(j)j Fr(=)d
Fq(j)591 776 y Fm(1)611 769 y Fq(;)8 b(:::;)g(j)717 776
y Ft(m)p Fg(\000)p Fm(1)794 769 y Fr(.)36 b(Th)o(us,)22
b(w)o(e)118 837 y(conclude)12 b(that)f(eac)o(h)g(v)o(ector)g
Fq(V)700 812 y Fm(\()p Ft(K)r Fm(\))689 850 y Ft(k)773
837 y Fr(has)h(not)g(more)118 898 y(then)k(\()p Fq(n)p
Fr(!)11 b Fl(\000)g Fq(K)t Fr(\))16 b(nonzero)h(comp)q(onen)o(ts.)118
1041 y Fd(3.3)66 b(Subspace)25 b(of)f(canonical)i(ele-)271
1116 y(men)n(ts)118 1208 y Fr(Let)21 b(us)g(consider)g(an)g(arbitrary)h
(v)o(ector,)e(desig-)118 1268 y(nated)d(b)q(elo)o(w)g(as)365
1398 y Fq(A)402 1377 y Fm(0)435 1398 y Fl(\021)d Fq(A)f
Fr(=)605 1344 y Ft(n)p Fm(!)591 1357 y Fi(X)590 1448
y Ft(j)r Fm(=1)660 1398 y Fq(a)686 1377 y Fm(0)686 1410
y Ft(i)716 1398 y Fl(\001)e Fq(e)764 1405 y Ft(j)782
1398 y Fq(;)118 1544 y Fr(and)22 b(recurren)o(tly)e(apply)i(\()p
Fq(m)g Fr(=)h(1)p Fq(;)8 b(:)g(:)g(:)f(;)h(K)t Fr(\))21
b(the)118 1604 y(follo)o(wing)e(transformation:)151 1794
y Fq(A)188 1774 y Ft(m)235 1794 y Fl(\021)13 b Fq(A)324
1774 y Ft(m)p Fg(\000)p Fm(1)413 1794 y Fl(\000)478 1758
y Fq(a)504 1737 y Ft(m)p Fg(\000)p Fm(1)504 1769 y Ft(j)518
1773 y Fj(m)p 468 1783 V 468 1830 a Fq(\013)499 1809
y Ft(m)p Fg(\000)p Fm(1)499 1842 y Ft(k)517 1846 y Fj(m)547
1842 y Ft(j)561 1846 y Fj(m)598 1794 y Fq(V)637 1769
y Fm(\()p Ft(K)r Fm(\))626 1807 y Ft(k)644 1811 y Fj(m)712
1794 y Fr(=)779 1740 y Ft(n)p Fm(!)765 1753 y Fi(X)764
1844 y Ft(j)r Fm(=1)834 1794 y Fq(a)860 1774 y Ft(m)860
1806 y(j)893 1794 y Fq(e)916 1801 y Ft(j)933 1794 y Fq(:)33
b Fr(\(5\))177 1937 y(It)16 b(is)h(easy)f(to)g(see)g(that)g(this)h
(linear)g(transfor-)118 1998 y(mation)g(has)g(the)f(follo)o(wing)j
(prop)q(erties:)191 2106 y({)25 b(it)19 b(shifts)g(the)f(v)o(ector)f
Fq(A)h Fr(along)i(the)d(plane)240 2166 y(parallel)h(to)e
Fp(K)p Fr(.)21 b(\()p Fn(So)c Fq(A)f Fn(and)h Fq(A)823
2148 y Ft(K)r Fm(+1)919 2166 y Fn(c)n(orr)n(e-)240 2226
y(sp)n(ond)g(to)h(e)n(qual)g(tensor)g(expr)n(essions)p
Fr(\);)191 2326 y({)25 b(v)o(ector)13 b Fq(A)421 2308
y Ft(K)r Fm(+1)514 2326 y Fr(has)i(zero)f(pro)s(jections)h(on)o(to)240
2386 y(unit)i(v)o(ectors)f Fq(e)532 2393 y Ft(j)566 2386
y Fr(with)h Fq(j)g Fr(=)c Fq(j)785 2393 y Fm(1)805 2386
y Fq(;)8 b(:)g(:)g(:)g(;)g(j)935 2393 y Ft(K)985 2386
y Fr(;)191 2486 y({)25 b Fq(A)277 2468 y Ft(K)r Fm(+1)370
2486 y Fr(=)13 b(0)66 b(i\013)g Fq(A)13 b Fl(2)h Fp(K)p
Fq(:)177 2594 y Fr(Th)o(us,)i(w)o(e)g(conclude)h(that)f
Fl(8)p Fq(A)c Fl(2)i Fp(R)859 2576 y Ft(n)p Fm(!)892
2594 y Fr(:)191 2702 y Fl(\017)24 b Fq(A)277 2684 y Ft(K)r
Fm(+1)370 2702 y Fr(=)13 b Fq(A)458 2684 y Fg(0)470 2679
y Ft(K)r Fm(+1)565 2702 y Fr(i\013)k(\()p Fq(A)11 b Fl(\000)g
Fq(A)777 2684 y Fg(0)788 2702 y Fr(\))j Fl(2)g Fp(K)p
Fr(;)1156 154 y Fl(\017)25 b Fr(transformation)13 b(\(5\))g(do)q(esn't)
f(shift)g Fq(A)1915 136 y Ft(K)r Fm(+1)1994 154 y Fr(;)1156
250 y Fl(\017)25 b Fr(image)32 b(of)g(the)g(transformation)i(\(5\))e
(is)1206 310 y(some)23 b(linear)h(subspace)f Fp(L)g Fr(with)h(dimen-)
1206 370 y(sion)17 b(\()p Fq(n)p Fr(!)11 b Fl(\000)g
Fq(K)t Fr(\))16 b(and)h Fp(L)11 b Fl(\\)g Fp(K)j Fr(=)f
Fl(f)p Fr(0)p Fl(g)1876 352 y Fm(4)1896 370 y Fr(;)1156
467 y Fl(\017)25 b Fr(ev)o(ery)18 b(v)o(ector)h(in)i
Fp(L)f Fr(has)h(not)g(more)e(than)1206 527 y(\()p Fq(n)p
Fr(!)10 b Fl(\000)h Fq(K)t Fr(\))16 b(nonzero)h(comp)q(onen)o(ts.)1143
620 y Fp(W)-5 b(e)24 b(de\014ne)f(the)h(subspace)g(L)g(as)g(a)g(set)
1084 680 y(of)32 b(canonical)h(representativ)n(es)e(for)h(S-I-)1084
740 y(D)20 b(equiv)m(alence)g(classes)h(under)f(consider-)1084
800 y(ation)p Fr(.)1084 964 y Fy(4)81 b(Multiplication)1084
1074 y Fr(If)25 b(a)i(tensor)f(expression)h(is)f(obtained)i(b)o(y)d
(the)1084 1134 y(m)o(ultiplication)e(of)f(basic)f(tensors)h(then)f(w)o
(e)f(di-)1084 1194 y(rectly)14 b(generate)g(the)g(set)g(of)h
Fp(S-I-D)e Fr(relations)j(as)1084 1254 y(a)g Fn(pr)n(o)n(duct)g
Fr(of)g(basic)h(ones.)1143 1314 y(Then)22 b(the)g(expression)h(is)g
(elab)q(orated,)i(tak-)1084 1375 y(ing)d(in)o(to)g(accoun)o(t)f
(additional)j(relations)f(origi-)1084 1435 y(nated)f(from)f(the)h(m)o
(ultiplication)i(rule)e(\(in)g(our)1084 1495 y(case)c(from)g(the)g
(comm)o(utativit)o(y\).)27 b(Let)19 b(us)f(con-)1084
1555 y(sider)g(a)g(tensor)g Fq(tt)f Fr(with)i(t)o(w)o(o)f(indices)g(as)
h(an)f(ex-)1084 1615 y(ample.)42 b(If)22 b(w)o(e)h(m)o(ultiply)h(it)f
(b)o(y)g(itself,)i(sa)o(y)e(as)1084 1676 y Fq(tt)p Fr(\()p
Fq(i;)8 b(j)s Fr(\))r Fl(\003)r Fq(tt)p Fr(\()p Fq(k)r(;)g(l)q
Fr(\),)h(the)j(additional)j(symmetry)10 b(ap-)1084 1736
y(p)q(ears:)1187 1827 y Fq(tt)p Fr(\()p Fq(i;)e(j)s Fr(\))i
Fl(\003)h Fq(tt)p Fr(\()p Fq(k)r(;)d(l)q Fr(\))k(=)i
Fq(tt)p Fr(\()p Fq(k)r(;)8 b(l)q Fr(\))i Fl(\003)h Fq(tt)p
Fr(\()p Fq(i;)d(j)s Fr(\))p Fq(:)1143 1919 y Fr(W)l(e)23
b(consider)h(all)h(suc)o(h)f(p)q(erm)o(utations)g(and)1084
1979 y(add)17 b(the)e(corresp)q(onding)k(elemen)o(ts)c(to)i(the)f
Fp(S-I-)1084 2039 y(D)21 b Fr(relations.)36 b(Then)21
b(w)o(e)g(p)q(erform)g(the)f("trian-)1084 2099 y(gle")c(pro)q(cedure)g
(\(3,4\))f(to)h(construct)f(the)h(full)g Fp(K)1084 2159
y Fr(subspace,)g(and)g(use)g(the)f(pro)q(cedure)h(\(5\))g(for)g(the)
1084 2220 y(canonical)i(represen)o(tativ)o(e)d(calculation)1839
2202 y Fm(5)1861 2220 y Fr(.)p 1084 2258 370 2 v 1140
2289 a Fh(4)1158 2304 y Fv(Here)g FA(f)p Fv(0)p FA(g)d
Fv(means)i(that)f(this)h(set)g(has)g(a)e(single)j(p)q(oin)o(t)1084
2354 y(-)e(zero)i(v)o(ector.)1140 2388 y Fh(5)1158 2403
y Fv(It)k(is)g(clear)h(ho)o(w)e(to)h(generalize)i(the)e(algorithm)g(to)
1084 2453 y(the)12 b(case)g(of)f(a)g(noncomm)o(utativ)o(e)g(\014nite)h
(algebra)g(of)f(basic)1084 2503 y(tensors.)25 b(In)16
b(suc)o(h)g(cases,)i(more)d(complicated)j(relations)1084
2553 y(will)c(app)q(ear)f(instead)h(of)e(the)h(simple)h(symmetry)f
(written)1084 2603 y(ab)q(o)o(v)o(e.)37 b(Ho)o(w)o(ev)o(er,)22
b(in)f(an)o(y)f(case)h(they)g(will)h(b)q(e)f(linear)1084
2652 y(iden)o(tities)c(whic)o(h)f(can)f(b)q(e)g(elab)q(orated)h
(naturally)f(in)g(the)1084 2702 y(framew)o(ork)e(of)g(our)h(approac)o
(h.)1051 2827 y Fr(5)p eop
%%Page: 6 6
6 5 bop 118 154 a Fy(5)81 b(Some)26 b(de\014nitions)118
263 y Fr(Let)14 b(us)g(giv)o(e)g(some)f(de\014nitions)j(whic)o(h)e(w)o
(e)f(use)h(in)118 323 y(the)i(follo)o(wing.)178 425 y(1.)24
b Fp(K)p Fr(-)p Fn(b)n(asis)19 b Fr(is)i(a)f(general)g(name)g(for)g
("trian-)240 485 y(gle")f(set)f(of)g(linear)i(indep)q(enden)o(t)e(v)o
(ectors)240 545 y Fq(V)279 520 y Fm(\()p Fc(K)p Fm(\))268
558 y Ft(k)357 545 y Fr(\()p Fq(k)e Fr(=)d Fq(k)493 552
y Fm(1)514 545 y Fq(;)8 b(:)g(:)g(:)f(;)h(k)648 552 y
Ft(K)682 545 y Fr(\).)178 647 y(2.)24 b Fp(K)284 654
y Fc(0)306 647 y Fr(-)p Fn(b)n(asis)12 b Fr(is)h(the)e
Fp(K)p Fr(-basis)j(for)e(a)g(basic)h(ten-)240 707 y(sor)h(considered)f
(as)h(a)g(separate)f(tensor)h(ex-)240 767 y(pression,)k(taking)f(in)o
(to)g(accoun)o(t)g(its)g(sym-)240 828 y(metries)f(and)h(linear)g(iden)o
(tities)h(only)l(.)178 929 y(3.)24 b Fp(K)284 936 y Fc(M)324
929 y Fr(-)p Fn(b)n(asis)14 b Fr(is)h(the)f Fp(K)p Fr(-)p
Fn(b)n(asis)g Fr(of)g(the)g(expres-)240 990 y(sion)20
b(under)e(consideration)i(whic)o(h)f(arises)240 1050
y(from)14 b Fp(K)397 1057 y Fc(0)419 1050 y Fr(-)p Fn(b)n(ases)g
Fr(of)h(basic)f(tensors)h(and)f(re-)240 1110 y(lations)21
b(generated)d(b)o(y)g(their)h(m)o(ultiplica-)240 1170
y(tion.)178 1272 y(4.)24 b Fp(K)284 1279 y Fc(D)317 1272
y Fr(-)p Fn(b)n(asis)11 b Fr(is)h(the)g(completion)g(of)f(the)h
Fp(K)986 1279 y Fc(M)1026 1272 y Fr(-)240 1332 y Fn(b)n(asis)28
b Fr(up)h(to)h(the)e(full)i Fp(K)p Fr(-)p Fn(b)n(asis)e
Fr(of)h(the)240 1392 y(expression)e(under)f(consideration,)k(tak-)240
1452 y(ing)19 b(in)o(to)f(accoun)o(t)f(relations)j(whic)o(h)d(arise)240
1513 y(from)32 b(renamings)i(of)f(dumm)o(y)e(indices.)240
1573 y(W)l(e)23 b(shall)i(also)g(call)g(this)f(basis)h(the)e
Fn(ful)r(l)240 1633 y Fp(K)p Fr(-)p Fn(b)n(asis)p Fr(.)178
1735 y(5.)h(T)l(o)12 b Fn(sieve)h Fr(some)f Fp(S)f Fl(\000)g
Fp(I)g Fl(\000)g Fp(D)g Fr(v)o(ector)g(means)240 1795
y(to)j(do)f(the)g(step)g Fq(m)g Fr(of)g(the)g("triangle")j(pro-)240
1855 y(cedure)g(\(3\).)178 1957 y(6.)24 b(T)l(o)g Fn(r)n(e)n(arr)n
(ange)f Fr(some)h Fp(S)11 b Fl(\000)g Fp(I)g Fl(\000)f
Fp(D)24 b Fr(v)o(ector)240 2017 y(means)16 b(to)g(do)g(the)g(step)g
Fq(m)f Fr(of)h(the)g("trian-)240 2077 y(gle")h(pro)q(cedure)g(\(4\).)
178 2179 y(7.)24 b(T)l(o)c Fn(sieve)h Fr(some)e(v)o(ector)g
Fq(A)g Fr(b)o(y)g(a)g Fp(K)p Fr(-)p Fn(b)n(asis)240 2239
y Fr(means)31 b(to)h(apply)f(the)g(transformation)240
2299 y(\(5\).)118 2466 y Fy(6)81 b(Algorithm)118 2575
y Fr(There)11 b(are)h(t)o(w)o(o)f(sets)h(of)g(op)q(erations.)21
b(One)12 b(is)g(p)q(er-)118 2635 y(formed)i(due)f(to)i(the)e(in)o(tro)q
(duction)j(of)e(new)g(basic)118 2696 y(tensors,)g(and)g(the)f(result)h
(of)f(these)g(op)q(erations)i(is)1084 154 y(the)i(construction)i(of)f
(the)f(new)h Fp(K)1738 161 y Fc(0)1760 154 y Fr(-bases.)27
b(An-)1084 214 y(other)12 b(set)g(of)h(op)q(erations)h(is)f(connected)f
(with)h(the)1084 274 y(simpli\014cation)19 b(of)d(tensor)h(expressions)
g(itself.)1143 334 y(The)g(starting)h(pro)q(cedure)f(for)g(the)g
(construc-)1084 394 y(tion)26 b(of)g Fp(K)1302 401 y
Fc(0)1325 394 y Fr(-bases)g(is)g Fq(T)7 b(S)s(Y)k(M)31
b Fr(\(section)26 b(8.4\),)1084 455 y(and)17 b(the)f(algorithm)i(is:)
1143 569 y(1.)25 b(Generate)e(full)h(list)h(of)e Fp(S-I)g
Fr(v)o(ectors)g(\(1\):)1206 629 y Fq(L)1239 636 y Fc(S)p
Fg(\000)p Fc(I)1320 629 y Fr(=)14 b Fl(f)p Fq(v)r Fl(g)p
Fr(.)1143 731 y(2.)25 b(Let)17 b Fp(K)d Fr(=)h Fp(K)1449
738 y Fc(0)1488 731 y Fr(where)i Fp(K)1674 738 y Fc(0)1713
731 y Fr(is)h(initial)h(basis)1206 791 y(\(ma)o(y)c(b)q(e)i(empt)o
(y\).)1143 892 y(3.)25 b(If)15 b(the)h(list)i Fq(L)1453
899 y Fc(S)p Fg(\000)p Fc(I)1537 892 y Fr(is)f(empt)o(y)e(then)h
(\014nish.)1143 994 y(4.)25 b(T)l(ak)o(e)30 b(the)h(next)f(v)o(ector)g
Fq(v)i Fr(from)e Fq(L)1940 1001 y Fc(S)p Fg(\000)p Fc(I)1206
1054 y Fr(and)21 b(delete)g(it)h(from)f(this)h(list:)32
b Fq(L)1868 1061 y Fc(S)p Fg(\000)p Fc(I)1958 1054 y
Fl(!)1206 1115 y Fq(L)1239 1122 y Fc(S)p Fg(\000)p Fc(I)1306
1115 y Fq(=)p Fl(f)p Fq(v)r Fl(g)p Fr(.)1143 1216 y(5.)25
b(Siev)o(e)j(the)h(v)o(ector)f Fq(v)j Fr(through)f(the)f
Fp(K)p Fr(-)1206 1276 y(basis)d(\(transformation)i(\(3\),)f(pro)q
(cedure)1206 1337 y Fq(siev)r(e)p 1321 1337 15 2 v 15
w(pv)r Fr(,)d(section)f(7.7\).)41 b(The)23 b(result)g(is)1206
1397 y(a)16 b(new)h(v)o(ector)e Fq(v)1519 1379 y Fg(0)1530
1397 y Fr(.)1143 1499 y(6.)25 b(If)16 b Fq(v)1281 1480
y Fg(0)1307 1499 y Fl(6)p Fr(=)e(0)k(then)e(insert)h
Fq(v)1674 1480 y Fg(0)1702 1499 y Fr(in)h(the)e Fp(K)p
Fr(-basis)1206 1559 y(and)21 b(rearrange)h(the)f(basis)i(\(transforma-)
1206 1619 y(tion)c(\(4\),)f(pro)q(cedure)g Fq(inser)q(t)p
1766 1619 V 17 w(pv)r Fr(,)f(section)1206 1679 y(7.7\).)1143
1781 y(7.)25 b(Rep)q(eat)16 b(from)g(step)g(3.)1143 1895
y(All)i Fp(K)1268 1902 y Fc(0)1290 1895 y Fr(-bases)g(are)f(stored.)25
b(There)17 b(is)h(a)g(p)q(os-)1084 1955 y(sibilit)o(y)j(to)e(delete)g
(an)o(y)g(basic)h(tensor)f(from)g(the)1084 2015 y(list)g(of)f(tensors)g
(and)g(so)h(to)f(delete)f(its)i Fp(K)1866 2022 y Fc(0)1888
2015 y Fr(-basis)1084 2076 y(\(section)e(8.3\).)1143
2136 y(The)f(algorithm)i(of)f(simpli\014cation)i(of)e(tensor)1084
2196 y(expressions)g(is:)1143 2298 y(1.)25 b(If)14 b(there)h(is)h(no)g
(m)o(ultiplication)i(of)d(tensors)1206 2358 y(or)i(there)g(are)h(no)f
(new)h Fp(S-I)f Fr(relations)i(due)1206 2418 y(to)c(their)g(m)o
(ultiplication)i(then)d(go)i(to)f(step)1206 2478 y(`)p
Fn(4)p Fr('.)1143 2580 y(2.)25 b(Expand)c(the)f Fp(K)1523
2587 y Fc(0)1546 2580 y Fr(-bases)h(in)o(v)o(olv)o(ed)g(up)g(to)1206
2640 y(the)13 b(necessary)h(rank)g(of)g(the)f(p)q(erm)o(utation)1051
2827 y(6)p eop
%%Page: 7 7
7 6 bop 240 154 a Fr(group)23 b(corresp)q(onding)i(to)d(the)g(m)o
(ultipli-)240 214 y(cation)f(of)f(basic)g(tensors)h(in)f(the)g(expres-)
240 274 y(sion)f(elab)q(orated)h(\(pro)q(cedure)d Fq(t)p
851 274 15 2 v 18 w(upr)q(ig)r(ht)p Fr(,)240 334 y(section)i(7.5\),)h
(and)f(collect)g(the)g(obtained)240 394 y(relations)i(as)e(the)g
(initial)j Fp(K)p Fr(-basis)e(of)f(the)240 455 y(considered)e
(expression.)178 556 y(3.)24 b(Complete)i(the)f Fp(K)p
Fr(-basis)i(b)o(y)e(additional)240 616 y(v)o(ectors)i(whic)o(h)g(arise)
h(from)f(the)h(m)o(ulti-)240 677 y(plication)23 b(\(see)d(section)i
(4\))f(b)o(y)f(the)g(algo-)240 737 y(rithm)14 b(of)g(the)f
Fp(K)p Fr(-basis)i(construction)g(\(see)240 797 y(ab)q(o)o(v)o(e\).)20
b(The)12 b(result)h(is)g(the)f Fp(K)812 804 y Fc(M)852
797 y Fr(-basis)i(for)240 857 y(the)i(expression)h(under)f
(simpli\014cation.)178 959 y(4.)24 b Fn(Dummies.)56 b
Fr(Complete)28 b(the)g Fp(K)882 966 y Fc(M)922 959 y
Fr(-basis)240 1019 y(b)o(y)19 b(v)o(ectors)g(corresp)q(onding)j(to)e
(the)f(rela-)240 1079 y(tions)26 b(whic)o(h)f(arise)g(from)f(renamings)
i(of)240 1139 y(dumm)o(y)20 b(indices)i(\(if)g(they)f(are)g(presen)o
(t\).)240 1200 y(The)g(result)h(is)g(the)f Fp(K)673 1207
y Fc(D)706 1200 y Fr(-basis)i(-)e(the)g(full)240 1260
y Fp(K)p Fr(-basis)d(for)f(the)f(expression)h(under)g(sim-)240
1320 y(pli\014cation.)178 1422 y(5.)24 b(Siev)o(e)j(the)g(tensor)g
(expression)h(through)240 1482 y(the)42 b Fp(K)394 1489
y Fc(D)427 1482 y Fr(-basis)i(\(transformation)g(\(5\),)240
1542 y(pro)q(cedure)22 b Fq(siev)r(e)p 587 1542 V 16
w(t)p Fr(,)h(section)g(7.7\).)39 b(The)240 1602 y(result)12
b(is)h(the)f(construction)h(of)f(the)f(canon-)240 1663
y(ical)17 b(represen)o(tativ)o(e)f(for)g(the)g(expression.)177
1764 y(An)o(y)23 b Fp(K)333 1771 y Fc(M)397 1764 y Fr(and)i
Fp(K)544 1771 y Fc(D)577 1764 y Fr(-bases)g(are)f(not)g(stored)118
1824 y(and)13 b(are)g(constructed)f(eac)o(h)g(time)h(an)g(expression)
118 1885 y(is)k(simpli\014ed.)118 2051 y Fy(7)81 b(Program)27
b(description)118 2161 y Fr(A)l(TENSOR)19 b(program)h(consists)g(of)f
(the)g(follo)o(w-)118 2221 y(ing)e(blo)q(c)o(ks:)191
2335 y Fl(\017)24 b Fr(in)o(terface)16 b(with)h(REDUCE)g(system;)191
2437 y Fl(\017)24 b Fr(generator)17 b(of)f(p)q(erm)o(utations;)191
2538 y Fl(\017)24 b Fr(p-v)o(ector)16 b(arithmetics;)191
2640 y Fl(\017)24 b Fr(tensor)17 b(arithmetics;)1156
154 y Fl(\017)25 b Fr(generator)j(of)f(the)g Fn(multiplic)n(ation)i
Fr(rela-)1206 214 y(tions;)1156 315 y Fl(\017)c Fr(generator)16
b(of)h(the)f Fn(dummy)g Fr(relations;)1156 417 y Fl(\017)25
b Fr(utilities)18 b(to)f(w)o(ork)f(with)h Fp(K)p Fr(-bases.)1084
562 y Fd(7.1)66 b(In)n(terface)22 b(with)h(REDUCE)1084
654 y Fr(In)o(terface)14 b(with)h(REDUCE)h(is)g(implemen)o(ted)e(b)o(y)
1084 714 y(de\014ning)21 b(of)g(a)g(domain)h([10)q(].)34
b(This)22 b(is)f(a)g(natu-)1084 774 y(ral)f(w)o(a)o(y)e(to)i(implemen)o
(t)e(a)i(new)e(ob)s(ject)h(in)h(RE-)1084 835 y(DUCE.)g(W)l(e)f(should)j
(de\014ne)d(the)h(follo)o(wing)j(set)1084 895 y(of)16
b(pro)q(cedures:)p 1084 969 906 2 v 1083 1026 2 57 v
1109 1009 a Fx(Op)q(eration)p 1334 1026 V 49 w(In)o(ternal)f(pro)q(c.)p
1655 1026 V 50 w(Commen)o(t)p 1988 1026 V 1084 1027 906
2 v 1083 1084 2 57 v 1109 1067 a(min)o(us)p 1334 1084
V 131 w(t)p 1380 1067 14 2 v 16 w(min)o(us)p 1655 1084
2 57 v 169 w(Unary)g(min)o(us)p 1988 1084 V 1083 1140
V 1109 1123 a(plus)p 1334 1140 V 169 w(t)p 1380 1123
14 2 v 16 w(plus)p 1655 1140 2 57 v 207 w(Summ)p 1988
1140 V 1083 1197 V 1109 1180 a(times)p 1334 1197 V 142
w(t)p 1380 1180 14 2 v 16 w(times)p 1655 1197 2 57 v
180 w(Pro)q(duct)p 1988 1197 V 1083 1253 V 1109 1236
a(di\013erence)p 1334 1253 V 62 w(t)p 1380 1236 14 2
v 16 w(di\013erence)p 1655 1253 2 57 v 100 w(Substruction)p
1988 1253 V 1083 1310 V 1109 1293 a(zerop)p 1334 1310
V 144 w(t)p 1380 1293 14 2 v 16 w(zerop)p 1655 1310 2
57 v 182 w(Do)q(es)g(tensor)p 1988 1310 V 1083 1366 V
1334 1366 V 1655 1366 V 1681 1349 a(equal)g(zero?)p 1988
1366 V 1084 1368 906 2 v 1083 1424 2 57 v 1109 1407 a(prepfn)p
1334 1424 V 123 w(t)p 1380 1407 14 2 v 16 w(prep)p 1655
1424 2 57 v 1988 1424 V 1083 1481 V 1109 1464 a(prifn)p
1334 1481 V 155 w(t)p 1380 1464 14 2 v 16 w(pri)p 1655
1481 2 57 v 232 w(Prin)o(t)f(function)p 1988 1481 V 1083
1537 V 1109 1520 a(in)o(tequiv)p 1334 1537 V 89 w(tin)o(tequiv)p
1655 1537 V 143 w(Is)h(tensor)g(equi-)p 1988 1537 V 1083
1594 V 1334 1594 V 1655 1594 V 1681 1577 a(v)m(alen)o(t)g(to)p
1988 1594 V 1083 1650 V 1334 1650 V 1655 1650 V 1681
1633 a(in)o(teger)p 1988 1650 V 1084 1652 906 2 v 1143
1750 a Fr(The)h(follo)o(wing)k(pro)q(cedures)c(m)o(ust)h(b)q(e)f
(de\014ne)1084 1810 y(for)e(completeness)h(but)f(can)h(not)g(b)q(e)g
(used)f(as)h(op-)1084 1870 y(erations)j(for)g(tensors.)25
b(These)17 b(pro)q(cedures)g(pro-)1084 1930 y(duce)f(an)g(error)h
(message)f(if)h(called.)1051 2827 y(7)p eop
%%Page: 8 8
8 7 bop 118 105 918 2 v 117 162 2 57 v 143 145 a Fx(Op)q(eration)p
368 162 V 50 w(In)o(ternal)15 b(pro)q(c.)p 690 162 V
49 w(Commen)o(t)p 1035 162 V 118 164 918 2 v 117 220
2 57 v 143 203 a(expt)p 368 220 V 164 w(t)p 415 203 14
2 v 16 w(expt)p 690 220 2 57 v 200 w(P)o(o)o(w)o(er)p
1035 220 V 117 276 V 143 260 a(quotien)o(t)p 368 276
V 86 w(t)p 415 260 14 2 v 16 w(quotien)o(t)p 690 276
2 57 v 1035 276 V 117 333 V 143 316 a(divide)p 368 333
V 131 w(t)p 415 316 14 2 v 16 w(divide)p 690 333 2 57
v 1035 333 V 117 389 V 143 372 a(gcd)p 368 389 V 183
w(t)p 415 372 14 2 v 16 w(gcd)p 690 389 2 57 v 219 w(Great)f(common)p
1035 389 V 117 446 V 368 446 V 690 446 V 715 429 a(divider)p
1035 446 V 117 502 V 143 485 a(min)o(usp)p 368 502 V
107 w(t)p 415 485 14 2 v 16 w(min)o(usp)p 690 502 2 57
v 143 w(Is)i(tensor)p 1035 502 V 117 559 V 368 559 V
690 559 V 715 542 a(negativ)o(e?)p 1035 559 V 117 615
V 143 598 a(onep)p 368 615 V 158 w(t)p 415 598 14 2 v
16 w(onep)p 690 615 2 57 v 194 w(Do)q(es)f(tensor)p 1035
615 V 117 672 V 368 672 V 690 672 V 715 655 a(equal)g(1?)p
1035 672 V 117 728 V 143 711 a(i2d)p 368 728 V 190 w(i2tensor)p
690 728 V 163 w(T)l(ransform)p 1035 728 V 117 785 V 368
785 V 690 785 V 715 768 a(in)o(teger)p 1035 785 V 117
841 V 368 841 V 690 841 V 715 824 a(to)g(tensor)p 1035
841 V 118 843 918 2 v 177 937 a(W)l(e)59 b(also)f(de\014ne)i(the)f
(domain)e(name)118 994 y(\()p Fu(T)6 b(E)s(N)f(S)s(O)q(R)p
Fx(\))12 b(and)k(the)f(tag)f(\(!)5 b(:)g Fu(T)h(E)s(N)f(S)s(O)q(R)p
Fx(\).)177 1050 y(T)l(o)21 b(complete)f(the)h(in)o(terface)g(with)g
(REDUCE,)118 1107 y(w)o(e)h(add)h(the)f(tag)g(of)g(the)g(tensor)g
(domain)f(to)h(the)118 1163 y(global)14 b(v)m(ariable)h
Fu(D)q(O)q(M)5 b(AI)t(N)g(LI)t(S)s(T)h Fx(!)-8 b Fs(\003)177
1220 y Fx(This)17 b(metho)q(d)g(supp)q(orts)h(the)g(input)g(pro)q(cess)
g(of)118 1276 y(tensor)11 b(expressions)h(and)g(pro)o(vides)f(calls)f
(of)i(the)f(cor-)118 1333 y(resp)q(onding)16 b(in)o(ternal)e(pro)q
(cedures)i(automatical)o(ly)l(.)118 1471 y Fd(7.2)66
b(P)n(erm)n(utations)118 1557 y Fx(This)15 b(blo)q(c)o(k)h(implemen)o
(ts)d(generation)i(of)g(p)q(erm)o(uta-)118 1613 y(tions)f(of)g
Fu(N)19 b Fx(order)14 b(and)g(includes)h(some)e(pro)q(cedures)118
1669 y(for)20 b(w)o(orking)g(with)g(them.)36 b(All)20
b(pro)q(cedures)i(w)o(ork)118 1726 y(with)15 b(the)g
Fz(p)n(acke)n(d)g Fx(and)h(the)f Fz(unp)n(acke)n(d)g
Fx(form)f(of)h(p)q(er-)118 1782 y(m)o(utations.)177 1839
y Fz(Unp)n(acke)n(d)i Fx(form)f(of)h(a)h(p)q(erm)o(utation)e(p)i(is)f
(a)g(list)118 1895 y(of)e(n)o(um)o(b)q(ers)339 1879 y
Fm(6)358 1895 y Fx(:)221 1996 y Fu(p)e Fx(=)g(\()p Fu(d)347
2003 y Fm(1)379 1996 y Fu(d)403 2003 y Fm(2)435 1996
y Fu(:::)e(d)509 2003 y Ft(k)530 1996 y Fx(\))p Fu(;)52
b Fx(1)13 b Fs(\024)g Fu(d)721 2003 y Ft(i)747 1996 y
Fs(\024)g Fu(k)h Fs(\024)f Fx(99)p Fu(:)177 2097 y Fz(Packe)n(d)i
Fx(form)e(is)i(the)g(corresp)q(onding)h(n)o(um)o(b)q(er:)447
2198 y Fu(p)d Fx(=)g Fu(d)555 2205 y Fm(1)574 2198 y
Fu(d)598 2205 y Fm(2)618 2198 y Fu(:::d)681 2205 y Ft(k)700
2198 y Fu(:)177 2299 y Fx(F)l(or)i(example,)206 2400
y Fu(p)e Fx(=)g(\(1)f(2)g(3)h(4)f(5\))90 b(and)h Fu(p)13
b Fx(=)g(12345)p Fu(:)177 2501 y Fx(The)20 b(transformati)o(on)c(of)j
(a)g(p)q(erm)o(utation)e(from)118 2558 y(one)26 b(form)e(to)h(another)h
(is)f(made)g(automaticall)o(y)l(.)118 2614 y(The)12 b(pac)o(k)o(ed)f
(form)e(is)i(more)f(economic)g(with)h(resp)q(ect)p 118
2657 370 2 v 174 2687 a Fh(6)193 2702 y Fv(see)k(section)h(9)d(for)h
(details.)1084 154 y Fx(to)c(computer)g(memory)l(,)f(but)h(requires)h
(more)e(time)g(to)1084 210 y(pro)q(ceed.)19 b(There)12
b(is)f(the)h(global)e(v)m(ariable)h(!)-5 b Fs(\003)g
Fu(ppack)q(ed)p Fx(.)1084 267 y(If)16 b(it)f(is)h Fu(T)22
b Fx(\(the)15 b(default)h(v)m(alue\))g(then)g(all)f(p)q(erm)o(uta-)1084
323 y(tions)h(are)h(pac)o(k)o(ed;)h(if)f Fu(N)5 b(I)t(L)16
b Fx(then)i(they)f(are)g(stored)1084 379 y(in)e(the)g(unpac)o(k)o(ed)h
(form.)1143 436 y(W)l(e)e(use)h(the)g(w)o(ell)f(kno)o(wn)g(algorithm)e
(for)i(gener-)1084 492 y(ation)h(of)h(p)q(erm)o(utations)e([12].)23
b(W)l(e)16 b(implemen)o(t)e(the)1084 549 y(follo)o(wing)f(pro)q
(cedures:)1159 642 y Fs(\017)24 b Fu(mk)q(unitp)p Fx(\()p
Fu(n)p Fx(\))12 b({)g(generates)g(the)h(unit)f(elemen)o(t)1206
699 y(of)i Fu(S)1285 706 y Ft(n)1309 699 y Fx(;)1159
789 y Fs(\017)24 b Fu(pf)5 b(ind)p Fx(\()p Fu(p)1364
796 y Fm(1)1383 789 y Fu(;)j(p)1427 796 y Fm(2)1445 789
y Fx(\))15 b({)h(returns)f Fu(x)g Fx(suc)o(h)h(that)f
Fu(p)1940 796 y Fm(2)1973 789 y Fx(=)1206 845 y Fu(x)10
b Fs(\016)g Fu(p)1298 852 y Fm(1)1317 845 y Fx(;)1159
935 y Fs(\017)24 b Fu(pr)q(ev)r Fx(\()p Fu(p)p Fx(\))15
b({)h(returns)g(rev)o(erse)g(p)q(erm)o(utation)f Fu(x)1206
992 y Fx(suc)o(h)g(that)g Fu(x)10 b Fs(\016)g Fu(p)i
Fx(=)h(1;)1159 1082 y Fs(\017)24 b Fu(psig)r(n)p Fx(\()p
Fu(p)p Fx(\))14 b({)g(returns)i(\()p Fs(\000)p Fx(1\))1679
1066 y Ft(k)1699 1082 y Fx(,)f(where)h Fu(k)g Fx(is)f(the)1206
1139 y(n)o(um)o(b)q(er)g(of)h(transp)q(ositions)f(whic)o(h)h(are)g
(nec-)1206 1195 y(essary)g(to)g(apply)h(to)f(the)h(p)q(erm)o(utation)d
(p)j(to)1206 1251 y(get)d(the)i(iden)o(tical)e(p)q(erm)o(utation.)1159
1342 y Fs(\017)24 b Fu(pmul)q(t)p Fx(\()p Fu(p)1367 1349
y Fm(1)1386 1342 y Fu(;)8 b(p)1430 1349 y Fm(2)1448 1342
y Fx(\))17 b({)g(returns)g(the)h(p)q(erm)o(utation)1206
1398 y Fu(x)12 b Fx(=)h Fu(p)1315 1405 y Fm(1)1345 1398
y Fs(\016)d Fu(p)1401 1405 y Fm(2)1420 1398 y Fx(;)1159
1488 y Fs(\017)24 b Fu(pappl)q Fx(\()p Fu(p;)8 b(l)q
Fx(\))13 b({)k(returns)g Fu(l)g Fx(with)f(the)h(elemen)o(ts)1206
1545 y(p)q(erm)o(uted)h(b)o(y)g Fu(p)p Fx(,)h(so)f(that)f
Fu(l)i Fx(is)f(replaced)h(b)o(y)1206 1601 y Fu(p)p Fx(\()p
Fu(l)q Fx(\).)1143 1695 y(There)g(are)h(some)e(utilities)f(to)i(w)o
(ork)f(with)h(p)q(er-)1084 1751 y(m)o(utations:)1159
1844 y({)24 b Fu(pupr)q(ig)r(ht)p Fx(\()p Fu(p;)8 b(d)p
Fx(\))g({)i(extends)i(the)f(p)q(erm)o(utation)1206 1901
y Fu(p)j Fs(2)g Fu(S)1315 1908 y Ft(n)1354 1901 y Fx(to)i(the)g(righ)o
(t)f(up)h(to)f(the)h(elemen)o(t)f(of)1206 1957 y Fu(S)1234
1964 y Ft(n)p Fm(+)p Ft(d)1323 1957 y Fx(with)21 b(the)g(iden)o(tical)e
(p)q(erm)o(utation)g(of)1206 2014 y(the)d(extra)h(indices)f(\(this)g
(utilit)o(y)f(is)h(used)h(for)1206 2070 y(the)c(elab)q(oration)f(of)h
(m)o(ultiplicatio)o(n)e(of)i(basic)1206 2127 y(tensors\);)1159
2217 y({)24 b Fu(pupl)q(ef)5 b(t)p Fx(\()p Fu(p;)j(d)p
Fx(\))15 b({)h(extends)i(the)f(p)q(erm)o(utation)1206
2273 y Fu(p)h Fs(2)h Fu(S)1324 2280 y Ft(n)1366 2273
y Fx(to)f(the)h(left)f(up)h(to)f(the)h(elemen)o(t)e(of)1206
2330 y Fu(S)1234 2337 y Ft(n)p Fm(+)p Ft(d)1323 2330
y Fx(with)k(the)g(iden)o(tical)e(p)q(erm)o(utation)g(of)1206
2386 y(the)d(extra)h(indices)f(\(this)g(utilit)o(y)f(is)h(used)h(for)
1206 2443 y(the)c(elab)q(oration)f(of)h(m)o(ultiplicatio)o(n)e(of)i
(basic)1206 2499 y(tensors\);)1159 2589 y({)24 b Fu(pappend)p
Fx(\()p Fu(p)1412 2596 y Fm(1)1431 2589 y Fu(;)8 b(p)1475
2596 y Fm(2)1493 2589 y Fx(\))22 b(-)f(concatenates)h(the)f(p)q(er-)
1206 2646 y(m)o(utation)12 b Fu(p)1424 2653 y Fm(1)1456
2646 y Fs(2)h Fu(S)1527 2653 y Ft(n)1548 2658 y Fk(1)1582
2646 y Fx(with)h(the)h(p)q(erm)o(utation)1206 2702 y
Fu(p)1229 2709 y Fm(2)1261 2702 y Fs(2)e Fu(S)1332 2709
y Ft(n)1353 2714 y Fk(2)1372 2702 y Fx(.)19 b(Returns)12
b(the)g(elemen)o(t)e(of)h Fu(S)1888 2709 y Ft(n)1909
2714 y Fk(1)1927 2709 y Fm(+)p Ft(n)1975 2714 y Fk(2)1995
2702 y Fx(;)1051 2827 y Fr(8)p eop
%%Page: 9 9
9 8 bop 193 154 a Fx({)24 b Fu(pk)q(p)p Fx(\()p Fu(p)p
Fx(\))14 b({)h(pac)o(ks)g(the)g(p)q(erm)o(utation)f Fu(p)p
Fx(;)193 247 y({)24 b Fu(unpk)q(p)p Fx(\()p Fu(p)p Fx(\))15
b({)f(unpac)o(ks)i(the)f(p)q(erm)o(utation)e Fu(p)p Fx(.)118
385 y Fd(7.3)66 b(P-v)n(ectors)118 470 y Fu(P)6 b Fx(-v)o(ectors)21
b(are)f(one)h(of)f(the)h(main)e(ob)s(jects)i(in)f(the)118
527 y(program.)34 b(They)20 b(represen)o(t)h(the)f(v)o(ector)g(in)g
Fo(R)980 510 y Fc(n)1020 527 y Fx({)118 583 y(the)d(group)g(algebra)f
(of)g Fu(S)571 590 y Ft(n)595 583 y Fx(.)25 b(In)17 b(the)g(program)e
(they)118 640 y(are)g(implemen)o(ted)e(as)i(a)g(REDUCE)g(domain)e([10)o
(].)177 696 y(In)o(ternal)i(structure)g(of)g Fu(p)p Fx(-v)o(ector)f
(is:)118 765 y Fu(p)s Fs(\000)s Fu(v)r(ector)h Fx(::=)g(\(!)5
b(:)g Fu(pv)13 b(:)f(p)s Fs(\000)s Fu(l)q(ist)p Fx(\))118
821 y Fu(p)s Fs(\000)s Fu(l)q(ist)i Fx(::=)h Fu(N)5 b(I)t(L)p
Fs(j)p Fx(\()p Fu(coef)g(f)16 b(:)c(per)q(m)p Fx(\))g
Fu(:)h(p)s Fs(\000)s Fu(l)q(ist)118 877 y(coef)5 b(f)20
b Fx(::=)15 b Fu(integ)r(er)177 946 y Fx(All)i(the)h(standard)f(op)q
(erations)g(are)g(de\014ned)i(for)118 1002 y Fu(p)p Fx(-v)o(ectors)c(b)
q(ecause)h(they)f(form)e(a)i(domain.)177 1059 y(The)d(follo)o(wing)e
(pro)q(cedures)i(are)g(used)g(for)g(tensor)118 1115 y
(simpli\014cation:)193 1219 y Fs(\017)24 b Fu(pv)p 289
1219 14 2 v 18 w(sor)q(t)p Fx(\()p Fu(pv)r Fx(\))17 b({)h(sorts)f(the)h
Fu(p)p Fx(-list)f(so)g(that)g(all)240 1275 y(p)q(erm)o(utation)h(will)h
(b)q(e)i(ordered,)g(e.g.)34 b Fu(p)972 1282 y Ft(i)1007
1275 y Fu(>)240 1332 y(p)263 1339 y Ft(j)294 1332 y Fs(8)13
b Fu(i)f(<)h(j)s Fx(;)193 1425 y Fs(\017)24 b Fu(pv)p
289 1425 V 18 w(compr)q(ess)p Fx(\()p Fu(pv)r Fx(\))31
b({)g(remo)o(v)o(es)f(all)h(terms)240 1481 y(with)15
b(zero)g(co)q(e\016cien)o(t;)193 1574 y Fs(\017)24 b
Fu(pv)p 289 1574 V 18 w(r)q(enor)q(m)p Fx(\()p Fu(pv)r
Fx(\))14 b({)g(reduces)i(the)f(\014rst)g(co)q(e\016-)240
1631 y(cien)o(t)g(\(in)g(in)o(teger)f(n)o(um)o(b)q(ers\),)g(i.e.)240
1687 y Fu(pv)29 b Fs(!)f Fu(pv)r(=GC)s(D)q Fx(\()p Fu(c)606
1694 y Fm(1)624 1687 y Fu(;)8 b(c)665 1694 y Fm(2)683
1687 y Fu(;)g(:::)p Fx(\))22 b(where)j Fu(c)944 1694
y Ft(i)982 1687 y Fx(are)240 1744 y(the)15 b(co)q(e\016cien)o(ts.)118
1848 y(Some)24 b(utilities)f(are)h(a)o(v)m(ailable)g(to)g(w)o(ork)g
(with)g Fu(p)p Fx(-)118 1904 y(v)o(ectors:)193 2008 y({)g
Fu(pappl)p 351 2008 V 17 w(pv)r Fx(\()p Fu(p;)8 b(pv)r
Fx(\))23 b({)i(applies)g(the)h(p)q(erm)o(uta-)240 2064
y(tion)14 b Fu(p)i Fx(to)e(the)h Fu(p)p Fx(-v)o(ector)g
Fu(pv)r Fx(.)240 2121 y(Returns)24 b Fu(p)444 2104 y
Fg(0)481 2121 y Fx(=)543 2089 y Fi(P)586 2132 y Ft(i)608
2121 y Fu(c)628 2128 y Ft(i)668 2121 y Fu(pmul)q(t)p
Fx(\()p Fu(p;)8 b(p)873 2128 y Ft(i)885 2121 y Fx(\))23
b(where)240 2177 y Fu(pv)14 b Fx(=)347 2145 y Fi(P)391
2189 y Ft(i)413 2177 y Fu(c)433 2184 y Ft(i)459 2177
y Fu(p)482 2184 y Ft(i)496 2177 y Fx(;)193 2270 y({)24
b Fu(pv)p 289 2270 V 18 w(appl)q(p)p Fx(\()p Fu(pv)r(;)8
b(v)r Fx(\))k({)k(applies)f(the)h Fu(p)p Fx(-v)o(ector)f
Fu(pv)240 2327 y Fx(to)g(the)g(p)q(erm)o(utation)e Fu(p)p
Fx(.)240 2383 y(Returns)24 b Fu(p)444 2367 y Fg(0)481
2383 y Fx(=)543 2351 y Fi(P)586 2395 y Ft(i)608 2383
y Fu(c)628 2390 y Ft(i)668 2383 y Fu(pmul)q(t)p Fx(\()p
Fu(p)829 2390 y Ft(i)842 2383 y Fu(;)8 b(p)p Fx(\))22
b(where)240 2440 y Fu(pv)14 b Fx(=)347 2408 y Fi(P)391
2451 y Ft(i)413 2440 y Fu(c)433 2447 y Ft(i)459 2440
y Fu(p)482 2447 y Ft(i)496 2440 y Fx(;)193 2533 y({)24
b Fu(pv)p 289 2533 V 18 w(upr)q(ig)r(ht)p Fx(\()p Fu(pv)r(;)8
b(d)p Fx(\))13 b(-)j(expands)g(the)g Fu(p)p Fx(-v)o(ector)240
2589 y Fu(pv)h Fx(to)d(the)i(righ)o(t.)240 2646 y(Returns)g
Fu(p)436 2629 y Fg(0)460 2646 y Fx(=)508 2614 y Fi(P)552
2657 y Ft(i)573 2646 y Fu(c)593 2653 y Ft(i)620 2646
y Fu(pupr)q(ig)r(ht)p Fx(\()p Fu(p)837 2653 y Ft(i)849
2646 y Fu(;)8 b(d)p Fx(\))14 b(where)240 2702 y Fu(pv)g
Fx(=)347 2670 y Fi(P)391 2714 y Ft(i)413 2702 y Fu(c)433
2709 y Ft(i)459 2702 y Fu(p)482 2709 y Ft(i)496 2702
y Fx(;)1159 154 y({)24 b Fu(pv)p 1255 154 V 18 w(upl)q(ef)5
b(t)p Fx(\()p Fu(pv)r(;)j(d)p Fx(\))g(-)i(extends)h(the)f
Fu(p)p Fx(-v)o(ector)f Fu(pv)1206 210 y Fx(to)14 b(the)i(left.)1206
267 y(Returns)j Fu(p)1405 250 y Fg(0)1435 267 y Fx(=)1488
234 y Fi(P)1532 278 y Ft(i)1554 267 y Fu(c)1574 274 y
Ft(i)1606 267 y Fu(pupl)q(ef)5 b(t)p Fx(\()p Fu(p)1798
274 y Ft(i)1811 267 y Fu(;)j(d)p Fx(\))18 b(where)1206
323 y Fu(pv)c Fx(=)1313 291 y Fi(P)1357 334 y Ft(i)1378
323 y Fu(c)1398 330 y Ft(i)1425 323 y Fu(p)1448 330 y
Ft(i)1462 323 y Fx(.)1084 460 y Fd(7.4)66 b(T)-6 b(ensors)1084
546 y Fx(T)l(ensors)18 b(are)g(the)h(main)e(ob)s(jects)h(in)h(the)f
(program.)1084 602 y(They)e(represen)o(t)f(tensor)g(expressions.)21
b(In)16 b(the)g(pro-)1084 658 y(gram)c(they)i(are)g(implemen)o(ted)d
(as)j(a)g(REDUCE)g(do-)1084 715 y(main)f([10)o(].)1143
771 y(The)i(in)o(ternal)f(structure)h(of)g(a)g(tensor)g(is:)1084
851 y Fu(tensor)i Fx(::=)e(\(!)5 b(:)g Fu(tensor)13 b(i)s
Fs(\000)s Fu(tensor)1685 858 y Fm(1)1717 851 y Fu(:::)25
b(i)s Fs(\000)s Fu(tensor)1966 858 y Ft(k)1987 851 y
Fx(\))1084 908 y Fu(i)s Fs(\000)s Fu(tensor)16 b Fx(::=)f(\()p
Fu(t)s Fs(\000)s Fu(header)25 b(t)s Fs(\000)s Fu(l)q(ist)p
Fx(\))1084 964 y Fu(t)s Fs(\000)s Fu(l)q(ist)15 b Fx(::=)f
Fu(N)5 b(I)t(L)12 b Fs(j)g Fu(p)s Fs(\000)s Fu(l)q(ist)g(:)g(t)s
Fs(\000)s Fu(l)q(ist)1084 1021 y(t)s Fs(\000)s Fu(header)k
Fx(::=)e(\()p Fu(t)s Fs(\000)s Fu(name)26 b(i)s Fs(\000)s
Fu(l)q(ist)p Fx(\))1084 1077 y Fu(t)s Fs(\000)s Fu(name)15
b Fx(::=)g(\()p Fu(t)1378 1084 y Fm(1)1423 1077 y Fu(t)1439
1084 y Fm(2)1484 1077 y Fu(:::)24 b(t)1563 1084 y Ft(k)1585
1077 y Fx(\))1084 1134 y Fu(i)s Fs(\000)s Fu(l)q(ist)14
b Fx(::=)h(\()p Fu(i)1333 1141 y Fm(1)1377 1134 y Fu(i)1393
1141 y Fm(2)1437 1134 y Fu(:::)25 b(i)1517 1141 y Ft(l)1529
1134 y Fx(\))1084 1202 y(where)19 b Fu(t)1235 1209 y
Fm(1)1255 1202 y Fu(;)8 b(t)1292 1209 y Fm(2)1311 1202
y Fu(;)g(:::;)g(t)1408 1209 y Ft(k)1446 1202 y Fx(are)19
b(basic)f(tensors)h(iden)o(ti\014ers,)1084 1258 y(and)c
Fu(i)1188 1265 y Fm(1)1208 1258 y Fu(;)8 b(i)1245 1265
y Fm(2)1263 1258 y Fu(;)g(:::;)g(i)1360 1265 y Ft(l)1385
1258 y Fx(are)15 b(indices)g(\(iden)o(ti\014ers\).)1143
1338 y(Let)20 b(us)g(consider)h(an)f(example)f(tensor)g(expres-)1084
1395 y(sion)e(and)h(its)f(represen)o(tation)g(in)h(the)g(in)o(ternal)f
(no-)1084 1451 y(tations.)1143 1508 y(Let)d Fu(tt)p Fx(\()p
Fu(i;)8 b(j)s Fx(\))13 b(b)q(e)i(a)f(tensor)g(of)f(second)i(order.)20
b(The)1084 1564 y(in)o(ternal)14 b(represen)o(tation)g(is)1238
1656 y(\(!)5 b(:)g Fu(tensor)13 b Fx(\(\(\()p Fu(tt)p
Fx(\))f(\()p Fu(i)25 b(j)s Fx(\)\))11 b(\(1)h Fu(:)h
Fx(12\)\)\))1084 1749 y(Th)o(us,)i(the)g(tensor)g(expression)1394
1841 y Fu(tt)p Fx(\()p Fu(i;)8 b(j)s Fx(\))g(+)j Fu(tt)p
Fx(\()p Fu(j;)d(i)p Fx(\))1084 1933 y(will)14 b(ha)o(v)o(e)g(the)i(in)o
(ternal)e(represen)o(tation)1161 2025 y(\(!)5 b(:)g Fu(tensor)13
b Fx(\(\(\()p Fu(tt)p Fx(\))f(\()p Fu(i)25 b(j)s Fx(\)\))11
b(\(1)h Fu(:)h Fx(21\))e(\(1)h Fu(:)h Fx(12\)\)\))1143
2117 y(The)22 b(most)f(imp)q(ortan)o(t)f(pro)q(cedures)j(from)d(this)
1084 2174 y(blo)q(c)o(k)15 b(are)g(describ)q(ed)h(b)q(ello)o(w)e(in)h
(section)g(8.)1143 2230 y(The)22 b(simpli\014cation)e(of)i(tensor)f
(expressions)h(is)1084 2287 y(p)q(erformed)16 b(b)o(y)i(the)f(function)
g Fu(t)p 1648 2287 V 17 w(simp)p Fx(.)26 b(The)17 b(result)1084
2343 y(of)h(this)g(pro)q(cedure)h(is)f(the)h(canonical)f(form)f(of)h
(the)1084 2400 y(tensor)c(expression,)h(i.e.)k(the)d(siev)o(ed)f(v)o
(ector)f Fu(t)1895 2383 y Fg(0)1920 2400 y Fs(2)f Fo(L)p
Fx(.)1084 2536 y Fd(7.5)66 b(T)-6 b(ensor)22 b(m)n(ultipli)q(cations)
1084 2646 y Fx(The)16 b(main)f(pro)q(cedures)j(of)e(the)g(tensor)g(m)o
(ultiplica-)1084 2702 y(tion)e(blo)q(c)o(k)h(are)g(the)g(follo)o(wing:)
1051 2827 y Fr(9)p eop
%%Page: 10 10
10 9 bop 193 154 a Fs(\017)24 b Fu(t)p 259 154 14 2 v
17 w(spl)q(it)p Fx(\()p Fu(tt)p Fx(\))e(-)g(splits)f(a)g(term)g(of)h
(the)g(tensor)240 210 y(expression)e(in)o(to)g(the)g(list)g(of)g(basic)
g(tensors)240 267 y(as)15 b(factors;)193 358 y Fs(\017)24
b Fu(t)p 259 358 V 17 w(f)5 b(use)p Fx(\()p Fu(tf)424
365 y Fm(1)445 358 y Fu(;)j(tf)504 365 y Fm(2)523 358
y Fx(\))13 b(-)f(com)o(bines)g(tensor)g(factors)240 414
y Fu(tf)278 421 y Fm(1)314 414 y Fx(and)j Fu(tf)440 421
y Fm(2)476 414 y Fx(in)o(to)f(the)i(pro)q(duct.)21 b(This)15
b(op)q(er-)240 470 y(ation)f(is)h(rev)o(erse)g(to)f(the)i(previous)f
(one;)193 562 y Fs(\017)24 b Fu(addmul)q(tsy)r(m)p Fx(\()p
Fu(t)528 569 y Fm(1)547 562 y Fu(;)8 b(t)584 569 y Fm(2)603
562 y Fx(\))j(-)g(adds)h(symmetry)c(and)240 618 y(m)o(ultiterm)18
b(linear)j(iden)o(tit)o(y)g(relations)f(gen-)240 674
y(erated)i(b)o(y)g(the)g(m)o(ultiplicat)o(ion)d(to)i(the)h
Fo(K)p Fx(-)240 731 y(basis.)118 827 y(Some)c(utilities)f(are)i(a)o(v)m
(ailable)f(to)g(w)o(ork)h(with)f(ten-)118 884 y(sors.)193
981 y Fs(\017)24 b Fu(t)p 259 981 V 17 w(upr)q(ig)r(ht)p
Fx(\()p Fu(tt;)8 b(th)p Fx(\))20 b(-)g(extends)h(the)g(tensor)f
Fu(tt)240 1037 y Fx(to)15 b(the)h(righ)o(t)e(with)h(resp)q(ect)h(to)f
(the)g Fu(t)p Fx(-header)240 1093 y Fu(th)p Fx(;)193
1184 y Fs(\017)24 b Fu(t)p 259 1184 V 17 w(upl)q(ef)5
b(t)p Fx(\()p Fu(tt;)j(th)p Fx(\))14 b(-)h(extends)g(the)f(tensor)h
Fu(tt)g Fx(to)240 1241 y(the)g(left)g(with)f(resp)q(ect)i(to)f(the)g
Fu(t)p Fx(-header)h Fu(th)p Fx(;)193 1332 y Fs(\017)24
b Fu(t)p 259 1332 V 17 w(pr)q(i)p Fx(\()p Fu(tt)p Fx(\))e(-)g(outputs)g
(the)g(tensor)g Fu(tt)h Fx(in)f(the)240 1388 y(natural)14
b(form.)118 1525 y Fd(7.6)66 b(Dumm)n(y)23 b(indices)118
1611 y Fx(Dumm)o(y)13 b(relations)i(are)g(created)h(in)g(the)g(pro)q
(cess)g(of)118 1668 y(ev)m(aluation)e(of)h(a)f(tensor)h(expressions.)k
(Their)c(n)o(um-)118 1724 y(b)q(er)f(ma)o(y)d(b)q(e)j(v)o(ery)e(large)h
(and)g(unpredictable)g(in)g(ad-)118 1781 y(v)m(ance.)20
b(Therefore)14 b(w)o(e)f(do)g(not)g(sa)o(v)o(e)g Fo(D)p
Fx(-relations)f(in)118 1837 y(con)o(trast)g(to)h Fo(S)g
Fx(and)h Fo(I)f Fx(ones.)20 b(This)13 b(leads)g(to)g(the)g(loss)118
1894 y(of)i(time)e(but)j(sa)o(v)o(es)e(the)h(memory)l(.)177
1950 y(During)20 b(simpli\014cation)e(of)h(tensor)h(expressions)118
2006 y(w)o(e)k(use)h(in)o(ternal)e(names)g(for)h(indices.)47
b(Original)118 2063 y(names)16 b(are)h(sa)o(v)o(ed)g(and)h(used)g(in)f
(the)g(I/O)h(pro)q(cess.)118 2119 y(Th)o(us,)12 b(if)f(w)o(e)g(ha)o(v)o
(e,)h(for)f(example,)g(a)g(dumm)o(y)f(index)i Fu(i)118
2176 y Fx(\(really)h(there)h(are)f(t)o(w)o(o)g(suc)o(h)h(names)f(in)h
(the)g(expres-)118 2232 y(sion)k(considered\))h(then)h(it)e(will)f(b)q
(e)j(replaced)f(with)118 2289 y(t)o(w)o(o)14 b(in)o(ternal)g(names:)p
366 2383 V 379 2383 a Fu(nn)92 b Fx(and)p 691 2383 V
107 w Fu(mm;)118 2476 y Fx(where)22 b Fu(mm)i Fx(=)g
Fu(nn)15 b Fx(+)g(1.)39 b(The)22 b(original)e(name)h(is)118
2533 y(stored)15 b(as)g(a)g(sp)q(ecial)g(prop)q(ert)o(y)f(of)h(the)g
(new)h(ones.)177 2589 y(The)21 b(dumm)o(y)e(blo)q(c)o(k)i(pro)q(duces)g
(relations)f(gen-)118 2646 y(erated)h(b)o(y)h(renamings)e(of)h
(dummies.)37 b(The)22 b(main)118 2702 y(pro)q(cedures)16
b(are)f(the)g(follo)o(wing:)1159 154 y Fs(\017)24 b Fu(adddummy)r
Fx(\()p Fu(tt)p Fx(\))17 b(-)i(adds)f(the)h(new)f(relations)1206
210 y(to)c(the)i Fo(K)p Fx(-basis;)1159 304 y Fs(\017)24
b Fu(dl)p 1248 304 V 16 w(g)r(et)p Fx(\()p Fu(il)q Fx(\))13
b(-)i(returns)f(the)h(list)e(of)h(dumm)o(y)f(in-)1206
360 y(dices)i(from)e(the)j(index)f(list)f Fu(il)q Fx(;)1159
454 y Fs(\017)24 b Fu(il)p 1240 454 V 16 w(simp)p Fx(\()p
Fu(il)q Fx(\))c(-)i(replaces)g(original)e(names)g(of)1206
511 y(the)k(dumm)o(y)e(indices)j(with)e(their)h(in)o(ternal)1206
567 y(names;)1159 661 y Fs(\017)g Fu(mk)p 1274 661 V
17 w(dsy)r(m)p Fx(\()p Fu(t)1430 668 y Fm(1)1450 661
y Fx(\))16 b(-)h(returns)g(the)g(list)f(of)g(tensor)1206
717 y(relations)11 b(with)h(c)o(hanged)h(dumm)o(y)d(indices)j(in)1206
774 y(eac)o(h)i(pair;)1159 868 y Fs(\017)24 b Fu(mk)p
1274 868 V 17 w(ddsy)r(m)p Fx(\()p Fu(t)1454 875 y Fm(1)1473
868 y Fx(\))13 b(-)g(returns)g(the)g(list)f(of)g(tensor)1206
924 y(relations)h(with)h(p)q(erm)o(uted)g(pairs)g(of)g(dumm)o(y)1206
980 y(indices.)1084 1119 y Fd(7.7)66 b(W)-6 b(orking)24
b(with)g(K-bases)1084 1205 y Fx(This)13 b(blo)q(c)o(k)g(con)o(tains)f
(the)h(pro)q(cedures)i(for)d(w)o(orking)1084 1261 y(with)i
Fo(K)p Fx(-bases.)1143 1318 y(All)21 b Fo(K)p Fx(-bases)g(for)g(v)m
(arious)g(tensor)g(expressions)1084 1374 y(are)15 b(stored)f(as)h
(lists)f(in)h(the)g(global)f(v)m(ariable)1196 1476 y(!)s
Fs(\003)s Fu(basis)c Fx(::=)j(\()p Fu(k)t Fs(\000)s Fu(basis)1610
1483 y Fm(1)1641 1476 y Fu(k)t Fs(\000)s Fu(basis)1809
1483 y Fm(2)1841 1476 y Fu(:::)p Fx(\))1084 1578 y(The)i(structure)g
(of)g(the)g(basis)g(is:)1223 1680 y Fu(k)t Fs(\000)s
Fu(basis)d Fx(::=)g(\()p Fu(t)s Fs(\000)s Fu(header)q
Fx(\))g Fu(:)g(t)s Fs(\000)s Fu(l)q(ist)1084 1782 y Fx(where)20
b(the)g(header)h Fu(t)f Fx(and)h(the)f(list)f Fu(t)i
Fx(are)e(de\014ned)1084 1839 y(ab)q(o)o(v)o(e.)1143 1895
y(The)c(main)f(pro)q(cedures)i(are)f(the)g(follo)o(wing:)1159
2002 y Fs(\017)24 b Fu(siev)r(e)p 1312 2002 V 16 w(pv)r
Fx(\()p Fu(pv)r(;)8 b(b)p Fx(\))19 b({)j(siev)o(es)g(the)h
Fu(p)p Fx(-v)o(ector)e Fu(pv)1206 2058 y Fx(using)27
b(the)g(basis)f Fu(b)p Fx(.)56 b(This)26 b(pro)q(cedure)i(is)1206
2115 y(used)17 b(for)f(the)g(construction)g(of)g(the)g
Fo(K)p Fx(-basis)1206 2171 y(\("triangle")11 b(transformatio)o(n)g
(\(3,4\)\))h(and)h(for)1206 2227 y(the)19 b(simpli\014cation)d(of)j
(tensors)f(expressions)1206 2284 y(\(pro)s(jection)9
b(to)h(the)i(canonical)e(elemen)o(t)f(\(5\)\).)1206 2340
y(This)25 b(is)g(the)g(main)f(step)h(of)g(the)h(function)1206
2397 y Fu(siev)r(e)p 1312 2397 V 16 w(t)p Fx(.;)1159
2491 y Fs(\017)e Fu(r)q(educe)p 1343 2491 V 15 w(pv)r
Fx(\()p Fu(pv)r(;)8 b(q)r(v)r Fx(\))16 b(-)j(reduces)g(the)g
Fu(p)p Fx(-v)o(ector)1206 2547 y Fu(pv)e Fx(with)e(resp)q(ect)i(to)e
(the)h Fu(p)p Fx(-v)o(ector)f Fu(q)r(v)r Fx(.)21 b(This)1206
2604 y(is)10 b(the)h(main)e(step)i(of)f(the)h(function)g
Fu(siev)r(e)p 1923 2604 V 16 w(pv)r Fx(.;)1039 2827 y
Fr(10)p eop
%%Page: 11 11
11 10 bop 193 154 a Fs(\017)24 b Fu(inser)q(t)p 366 154
14 2 v 17 w(pv)r Fx(\()p Fu(pv)r(;)8 b(b)p Fx(\))13 b(-)j(inserts)g
(the)g Fu(p)p Fx(-v)o(ector)g Fu(pv)240 210 y Fx(in)o(to)f(the)h(basis)
g Fu(b)p Fx(.)22 b(This)16 b(pro)q(cedure)h(also)e(re-)240
267 y(arranges)f Fu(b)h Fx(with)g(resp)q(ect)g(to)g Fu(pv)r
Fx(.)193 360 y Fs(\017)24 b Fu(siev)r(e)p 346 360 V 16
w(t)p Fx(\()p Fu(tt)p Fx(\))13 b(-)g(siev)o(es)f(the)h(tensor)f
Fu(tt)h Fx(using)f(the)240 417 y(corresp)q(onding)k Fo(K)p
Fx(-basis.)21 b(The)16 b(\014rst)g(step)g(of)240 473
y(this)h(pro)q(cedure)i(is)e(generation)g(of)h(relations)240
530 y(due)24 b(to)e(renamings)g(of)h(dummies)e(and)i(the)240
586 y(corresp)q(onding)d(completion)e(of)h Fo(K)871 593
y Fc(M)932 586 y Fx(up)h(to)240 643 y Fo(K)281 650 y
Fc(D)314 643 y Fx(-basis.)118 781 y Fd(7.8)66 b(Global)24
b(v)l(ariables)118 867 y Fx(In)g(this)e(section)h(w)o(e)g(describ)q(es)
h(the)f(main)f(global)118 923 y(v)m(ariables)k(whic)o(h)h(allo)o(w)e(a)
i(user)g(to)f(con)o(trol)g(the)118 980 y(w)o(ork.)19
b(W)l(e)c(sho)o(w)g(the)g(default)g(v)m(alues)g(in)g(brac)o(k)o(ets.)
193 1086 y Fs(\017)24 b Fx(!)t Fs(\003)t Fu(ppack)q(ed)p
Fx(\()p Fu(T)6 b Fx(\))16 b(-)i(are)f(p)q(erm)o(utations)f(stored)240
1142 y(in)f(pac)o(k)o(ed)g(form?)193 1236 y Fs(\017)24
b Fx(!)s Fs(\003)s Fu(debug)r Fx(\()p Fu(N)t(I)t(L)p
Fx(\))12 b(-)j(switc)o(hes)f(the)i(debug)f(out-)240 1293
y(put)g(on.)118 1452 y Fy(8)108 b(User's)27 b(in)n(terface)118
1554 y Fx(T)l(o)12 b(simplify)e(the)j(user)f(in)o(terface,)g(w)o(e)g
(restricted)g(the)118 1610 y(n)o(um)o(b)q(er)f(of)g(additional)f
(commands.)16 b(The)c(names)f(of)118 1667 y(these)19
b(commands)e(are)h(v)o(ery)h(similar)d(to)i(the)g(stan-)118
1723 y(dard)d(REDUCE)g(ones)h(used)f(in)g(similar)e(cases.)118
1862 y Fd(8.1)66 b Fb(K)t(B)s(AS)s(I)5 b(S)118 1947 y
Fx(The)17 b(command)e Fu(K)s(B)r(AS)s(I)t(S)k Fx(prin)o(ts)d(the)h
(tensor)f Fo(K)p Fx(-)118 2004 y(basis.)177 2060 y(The)g(n)o(um)o(b)q
(er)f(of)g(v)o(ectors)f(in)i(the)f(basis,)g(i.e.)20 b(the)118
2117 y(dimension)14 b(of)g(the)h(corresp)q(onding)g(subspace)g
Fo(K)p Fx(,)g(is)118 2173 y(t)o(yp)q(ed)h(in)f(the)g(last)f(line)h(of)g
(the)g(output.)20 b(F)l(ormat)13 b(of)118 2230 y(this)i(command)e(is:)
333 2332 y Fu(K)s(B)r(AS)s(I)t(S)27 b(tt)587 2339 y Fm(1)608
2332 y Fu(;)8 b(tt)661 2339 y Fm(2)680 2332 y Fu(;)g(:::;)g(tt)793
2339 y Ft(n)815 2332 y Fx(;)118 2434 y(Here)16 b Fu(tt)258
2441 y Fm(1)278 2434 y Fu(;)8 b(tt)331 2441 y Fm(2)351
2434 y Fu(;)g(:::;)g(tt)464 2441 y Ft(n)501 2434 y Fx(are)14
b(tensor)h(names.)177 2490 y(T)l(o)10 b(output)g(the)h
Fo(K)p Fx(-basis)f(in)g(the)g(case)g(of)g(the)h(m)o(ul-)118
2547 y(tiplication)16 b(of)i(t)o(w)o(o)e(or)h(more)g(tensors,)h(it)f
(is)g(neces-)118 2603 y(sary)k(to)f(use)i(the)f(follo)o(wing)e(format)g
(of)i(the)g(com-)118 2660 y(mand:)1276 210 y Fu(K)s(B)r(AS)s(I)t(S)28
b(t)1515 217 y Fm(1)1535 210 y Fx(\()p Fu(t)1569 217
y Fm(2)1588 210 y Fu(;)8 b(:::;)g(t)1685 217 y Ft(k)1704
210 y Fx(\))p Fu(;)g(:)g(:)g(:)d Fx(;)1084 290 y(Here)15
b Fu(t)1207 297 y Fm(1)1227 290 y Fu(;)8 b(t)1264 297
y Fm(2)1284 290 y Fu(;)g(:)g(:)g(:)k Fx(are)j(the)g(names)f(of)h
(tensor)g(factors.)1143 347 y(If)10 b(some)f(names)g(ha)o(v)o(e)h(not)g
(b)q(een)h(declared)g(as)f(ten-)1084 403 y(sors)k(the)i(message)d(is)i
(pro)q(duced)1171 483 y Fz(*****)j(b)n(asis1)d(***)i(Invalid)f(as)g
(tensor:)k(tt)1084 621 y Fd(8.2)66 b Fb(T)8 b(E)t(N)e(S)s(O)r(R)1084
706 y Fx(The)11 b(command)e Fu(T)d(E)s(N)f(S)s(O)q(R)k
Fx(declares)h(new)i(tensors.)1084 763 y(F)l(ormat)h(of)h(this)h
(command)e(is:)1316 858 y Fu(T)6 b(E)s(N)f(S)s(O)q(R)23
b(t)1569 865 y Fm(1)1589 858 y Fu(;)8 b(t)1626 865 y
Fm(2)1645 858 y Fu(;)g(:::;)g(t)1742 865 y Ft(n)1763
858 y Fx(;)1084 954 y(Here)14 b Fu(t)1206 961 y Fm(1)1226
954 y Fu(;)8 b(t)1263 961 y Fm(2)1282 954 y Fu(;)g(:::;)g(t)1379
961 y Ft(n)1414 954 y Fx(are)14 b(iden)o(ti\014ers.)19
b(The)14 b(n)o(um)o(b)q(er)f(of)1084 1010 y(indices)i(will)e(b)q(e)j
(\014xed)f(during)g(the)g(\014rst)g(ev)m(aluation)1084
1067 y(of)g(a)f(tensor)h(expressions.)1143 1123 y(If)d(some)f(names)h
(ha)o(v)o(e)f(b)q(een)j(declared)e(as)g(tensors)1084
1180 y(already)i(the)i(message)d(is)i(pro)q(duced:)1177
1260 y Fz(+++)h(tt)g(is)g(alr)n(e)n(ady)g(de)n(clar)n(e)n(d)f(as)h
(tensor.)1084 1397 y Fd(8.3)66 b Fb(T)8 b(C)t(LE)t(AR)1084
1483 y Fx(The)k(command)e Fu(T)c(C)s(LE)s(AR)k Fx(remo)o(v)o(es)g
(tensors)i(from)1084 1539 y(the)i(list)g(of)g(tensors.)19
b(F)l(ormat)12 b(of)i(this)g(command)f(is:)1319 1635
y Fu(T)6 b(C)s(LE)s(AR)24 b(t)1565 1642 y Fm(1)1585 1635
y Fu(;)8 b(t)1622 1642 y Fm(2)1642 1635 y Fu(;)g(:::;)g(t)1739
1642 y Ft(n)1760 1635 y Fx(;)1084 1731 y(Here)14 b Fu(t)1206
1738 y Fm(1)1226 1731 y Fu(;)8 b(t)1263 1738 y Fm(2)1283
1731 y Fu(;)g(:::;)g(t)1380 1738 y Ft(n)1415 1731 y Fx(are)14
b(the)g(names)f(of)h(tensor)g(\(iden-)1084 1787 y(ti\014ers\).)1143
1844 y(If)c(some)f(names)g(ha)o(v)o(e)h(not)g(b)q(een)h(declared)g(as)f
(ten-)1084 1900 y(sors)k(the)i(message)d(is)i(pro)q(duced)1293
1980 y Fz(+++)h(xxx)h(is)e(not)h(a)h(tensor.)1143 2060
y(Note:)37 b Fx(All)22 b Fo(K)p Fx(-bases)i(where)g(an)o(y)f(of)g
Fu(t)1863 2067 y Ft(i)1901 2060 y Fx(is)g(in-)1084 2117
y(cluded)16 b(as)e(a)h(factor)g(will)e(b)q(e)j(lost.)1084
2254 y Fd(8.4)66 b Fb(T)8 b(S)s(Y)14 b(M)1084 2340 y
Fx(The)j(command)e Fu(T)6 b(S)s(Y)k(M)22 b Fx(de\014nes)c(symmetry)c
(rela-)1084 2396 y(tions)d(of)h(basic)h(tensors.)18 b(F)l(ormat)10
b(of)i(this)g(command)1084 2453 y(is:)1316 2509 y Fu(T)6
b(S)s(Y)k(M)31 b(te)1528 2516 y Fm(1)1548 2509 y Fu(;)8
b(te)1606 2516 y Fm(2)1625 2509 y Fu(;)g(:::;)g(te)1743
2516 y Ft(k)1763 2509 y Fx(;)1084 2589 y(Here)18 b Fu(te)1231
2596 y Fm(1)1251 2589 y Fu(;)8 b(te)1309 2596 y Fm(2)1329
2589 y Fu(;)g(:::;)g(te)1447 2596 y Ft(k)1484 2589 y
Fx(are)18 b(linear)f(com)o(binations)e(of)1084 2646 y(basic)h(tensors)g
(with)g(in)o(teger)f(co)q(e\016cien)o(ts)h(not)h(con-)1084
2702 y(taining)d(without)g(dumm)o(y)f(indices.)1039 2827
y Fr(11)p eop
%%Page: 12 12
12 11 bop 177 154 a Fx(All)25 b(relations)f(corresp)q(ond)i(to)f(the)h
(left)f(hand)118 210 y(side)17 b(of)f(the)h(symmetry)d(equations.)24
b(F)l(or)16 b(example,)118 267 y(for)i(an)o(tisymm)o(etric)d(tensor)j
(w)o(e)g(ha)o(v)o(e)f(the)i(relation)118 323 y Fu(AA)p
Fx(\()p Fu(i;)8 b(j)s Fx(\))f(+)i Fu(AA)p Fx(\()p Fu(j;)f(i)p
Fx(\))j(=)h(0.)20 b(Th)o(us,)14 b(the)h(corresp)q(ond-)118
379 y(ing)g(input)g(format)e(is:)285 482 y Fu(T)6 b(S)s(Y)k(M)30
b(AA)p Fx(\()p Fu(I)t(;)8 b(J)t Fx(\))h(+)h Fu(AA)p Fx(\()p
Fu(J)o(;)e(I)t Fx(\);)118 620 y Fd(8.5)66 b(Algebraic)24
b(op)r(erations)118 706 y Fx(The)12 b(standard)e(algebraic)g(op)q
(erations)h(are)g(a)o(v)m(ailable)118 762 y(for)k(tensors:)202
806 y(+)74 b(sum)14 b(of)h(tensors;)202 862 y Fs(\000)74
b Fx(di\013erence)15 b(of)g(tensors)g(or)f(negation;)202
919 y Fs(\003)86 b Fx(m)o(ultiplicati)o(on)13 b(of)h(tensors.)177
971 y(W)l(e)20 b(assume)e(that)g(t)o(w)o(o)g(indices)i(with)e(iden)o
(tical)118 1028 y(names)d(means)g(the)i(summatio)o(n)d(o)o(v)o(er)h
(their)h(v)m(alues)118 1084 y(\(the)23 b(Einstein)g(con)o(v)o(en)o
(tion\))f(-)h(they)g(are)g(dumm)o(y)118 1141 y(ones.)31
b(Th)o(us,)19 b(the)g(m)o(ultiplication)d(of)i(t)o(w)o(o)g(tensors)118
1197 y(ma)o(y)d(b)q(e)j(either)f(a)g(direct)f(pro)q(duct,)i(or)e(it)h
(can)g(con-)118 1254 y(tain)e(con)o(tractions)e(of)i(dumm)o(y)e
(indices.)177 1310 y(Examples:)420 1367 y Fu(t)436 1374
y Fm(1)456 1367 y Fx(\()p Fu(i;)8 b(j)s Fx(\))g Fs(\003)i
Fu(t)608 1374 y Fm(2)628 1367 y Fx(\()p Fu(j;)e(k)q Fx(\);)386
1450 y Fu(t)402 1457 y Fm(1)422 1450 y Fx(\()p Fu(i;)g(j)s
Fx(\))g(+)i(2)g Fs(\003)g Fu(t)652 1457 y Fm(2)672 1450
y Fx(\()p Fu(j;)e(i)p Fx(\);)118 1588 y Fd(8.6)66 b(Switc)n(h)24
b Fb(D)r(U)6 b(M)g(M)g(Y)12 b(P)c(RI)118 1674 y Fx(This)17
b(switc)o(h)f(is)g(con)o(trolled)g(b)o(y)h(the)g(standard)g(RE-)118
1731 y(DUCE)i(commands)e Fu(O)q(N)5 b Fx(/)p Fu(O)q(F)h(F)g
Fx(.)32 b(It)19 b(con)o(trols)f(the)118 1787 y(output)d(pro)q(cess)h
(for)f(tensor)g(expressions.)20 b(The)c(de-)118 1843
y(fault)e(v)m(alue)i(is)f Fu(O)q(F)6 b(F)g Fx(.)177 1900
y Fu(D)q(U)f(M)g(M)g(Y)11 b(P)6 b(RI)22 b Fx(prin)o(ts)c(dumm)o(y)f
(indices)i(with)118 1956 y(in)o(ternal)i(names)f({)i(n)o(um)o(b)q(ers.)
38 b(The)22 b(general)f(rule)118 2013 y(is:the)10 b(index)g(\(2)p
Fu(k)r Fs(\000)p Fx(1\))f(is)g(con)o(tracted)h(with)g(the)g(index)118
2069 y(\(2)p Fu(k)q Fx(\).)177 2126 y(Examples)370 2109
y Fm(7)388 2126 y Fx(:)143 2190 y Fu(T)c(E)s(N)f(S)s(O)q(R)36
b(GG)p Fx(;)143 2247 y Fu(GG)p Fx(\()p Fu(M)r(;)8 b(M)d
Fx(\);)285 b Fs(\))13 b Fu(GG)p Fx(\()p Fu(M)r(;)8 b(M)d
Fx(\))143 2303 y Fu(O)q(N)42 b(D)q(U)5 b(M)g(M)g(Y)11
b(P)6 b(RI)t Fx(;)143 2359 y Fu(GG)p Fx(\()p Fu(M)r(;)i(M)d
Fx(\);)285 b Fs(\))13 b Fu(GG)p Fx(\()p Fu(M)857 2366
y Fm(41)894 2359 y Fu(;)8 b(M)959 2366 y Fm(42)996 2359
y Fx(\))p 118 2415 370 2 v 174 2445 a Fh(7)193 2460 y
Fv(Here)13 b(and)f(b)q(elo)o(w)h(REDUCE)g(output)f(is)h(giv)o(en)g
(after)118 2510 y(the)i(arro)o(w)e(")p FA(\))p Fv(".)1084
154 y Fd(8.7)66 b(Switc)n(h)23 b Fb(S)s(H)5 b(O)r(RT)j(E)t(S)s(T)1084
239 y Fx(This)16 b(switc)o(h)h(is)f(con)o(trolled)g(b)o(y)h(the)g
(standard)f(RE-)1084 296 y(DUCE)j(commands)e Fu(O)q(N)5
b Fx(/)p Fu(O)q(F)h(F)g Fx(.)32 b(It)19 b(con)o(trols)f(the)1084
352 y(output)d(pro)q(cess)h(for)e(tensor)h(expressions.)21
b(The)15 b(de-)1084 409 y(fault)f(v)m(alue)h(is)g Fu(O)q(F)6
b(F)g Fx(.)1143 465 y Fu(S)s(H)t(O)q(RT)g(E)s(S)s(T)31
b Fx(prin)o(ts)c(tensor)g(expression)h(in)1084 522 y(shortest)18
b(form)g(that)g(w)o(as)g(pro)q(duced)j(during)e(ev)m(al-)1084
578 y(uation.)24 b(Ho)q(ev)o(er,)17 b(the)g(sortest)f(form)g(ma)o(y)f
(b)q(e)i(non-)1084 635 y(canonical.)1084 703 y Fu(T)6
b(E)s(N)f(S)s(O)q(R)35 b(C)s Fx(;)1084 759 y Fu(T)6 b(S)s(Y)k(M)167
b(C)s Fx(\()p Fu(K)q(;)8 b(L;)g(M)d Fx(\))24 b(+)j Fu(C)s
Fx(\()p Fu(L;)8 b(M)r(;)g(K)s Fx(\))25 b(+)1084 816 y
Fu(C)s Fx(\()p Fu(M)r(;)8 b(K)q(;)g(L)p Fx(\);)1084 872
y Fu(C)s Fx(\()p Fu(K)q(;)g(L;)g(M)d Fx(\))i(+)j Fu(C)s
Fx(\()p Fu(M)r(;)e(L;)g(K)s Fx(\);)1261 929 y Fs(\))60
b Fx(\()p Fs(\000)p Fx(1\))28 b Fs(\003)g Fu(C)s Fx(\()p
Fu(L;)8 b(M)r(;)g(K)s Fx(\))27 b(+)i(\()p Fs(\000)p Fx(1\))f
Fs(\003)1084 985 y Fu(C)s Fx(\()p Fu(M)r(;)8 b(K)q(;)g(L)p
Fx(\))f(+)k Fu(C)s Fx(\()p Fu(M)r(;)d(L;)g(K)s Fx(\))1084
1042 y Fu(O)q(N)42 b(S)s(H)t(O)q(RT)6 b(E)s(S)s(T)g Fx(;)1084
1098 y Fu(C)s Fx(\()p Fu(K)q(;)i(L;)g(M)d Fx(\))i(+)j
Fu(C)s Fx(\()p Fu(M)r(;)e(L;)g(K)s Fx(\);)1214 1154 y
Fs(\))14 b Fu(C)s Fx(\()p Fu(K)q(;)8 b(L;)g(M)d Fx(\))h(+)11
b Fu(C)s Fx(\()p Fu(M)r(;)d(L;)g(K)s Fx(\))1084 1314
y Fy(9)81 b(Memory)25 b(usage)1084 1416 y Fx(Let)c(us)g(consider)g
(simpli\014cation)e(of)h(a)h(tensor)g(ex-)1084 1472 y(pressions)16
b(with)g Fu(n)h Fx(indices.)24 b(The)17 b(rank)f(of)g(the)h(cor-)1084
1529 y(resp)q(onding)26 b(p)q(erm)o(utation)e(group)h(is)h
Fu(n)g Fx(and)g(the)1084 1585 y(dimension)h(of)h(its)g(group)h(algebra)
e(is)h Fu(n)p Fx(!.)61 b(Let)1084 1642 y(us)22 b(consider)f(t)o(w)o(o)f
(cases:)33 b(when)22 b(there)g(are)f(man)o(y)1084 1698
y Fo(S)10 b Fs(\000)g Fo(I)g Fs(\000)h Fo(D)19 b Fx(relations)e(\(so)h
(that)h(the)g(dimension)e(of)1084 1755 y(the)11 b Fo(K)h
Fx(subspace)g(is)f(almost)e(equal)j(to)e Fu(n)p Fx(!\))i(and)f(when)
1084 1811 y(there)17 b(are)g(small)d(n)o(um)o(b)q(er)j(of)f
Fo(S)10 b Fs(\000)h Fo(I)f Fs(\000)g Fo(D)17 b Fx(relations)1084
1867 y(\(so)k(that)g(the)h(dimension)e(of)h(the)h Fo(K)g
Fx(subspace)g(is)1084 1924 y(small\).)1143 1980 y(In)f(the)g(\014rst)f
(case,)i(ab)q(out)e Fu(n)p Fx(!)14 b Fs(\001)f Fu(l)h
Fs(\001)g Fu(k)21 b Fx(Lisp)g(cells)1084 2037 y(are)16
b(necessary)g(to)g(store)g(the)g(full)g Fo(K)1734 2044
y Fc(D)1767 2037 y Fx(-basis.)24 b(Here)1084 2093 y Fu(l)14
b Fx(is)f(the)h(n)o(um)o(b)q(er)g(of)f(cells)g(needed)j(to)d(store)g(a)
h(single)1084 2150 y(term)c(of)i(a)g Fu(p)p Fx(-v)o(ector,)f(and)i
Fu(k)g Fx(is)e(the)i(a)o(v)o(erage)d(n)o(um)o(b)q(er)1084
2206 y(of)20 b(terms)e(in)i(v)o(ectors)g(from)e(this)i
Fo(K)1737 2213 y Fc(D)1770 2206 y Fx(-basis.)35 b(The)1084
2263 y(n)o(um)o(b)q(er)17 b(of)g(terms)f(in)i(these)g(v)o(ectors)f(\()p
Fu(k)q Fx(\))g(is)g(ab)q(out)1084 2319 y(2)s Fs(\000)s
Fx(3)12 b(in)f(practical)g(cases.)18 b(The)12 b(n)o(um)o(b)q(er)f(of)h
(terms)e(in)1084 2376 y(the)15 b(simpli\014ed)f(expression)i(is)f(\(in)
g(practical)f(cases\))1084 2432 y Fu(O)q Fx(\(1\),)g(and)h(can)g(b)q(e)
h(omitted)d(from)h(this)g(estimate.)1143 2488 y(In)h(the)f(case)g(of)f
(a)h(small)e(set)i(of)f(symmetries)f(and)1084 2545 y(linear)g(iden)o
(tities)h(of)g(basic)g(tensors,)g(the)g(n)o(um)o(b)q(er)g(of)1084
2601 y(v)o(ectors)20 b(in)g(the)h(full)f Fo(K)1512 2608
y Fc(D)1546 2601 y Fx(-basis)g(is)g(small)f(enough,)1084
2658 y(and)f(can)f(b)q(e)i(omitted)c(from)h(this)h(estimate.)25
b(Ho)o(w-)1039 2827 y Fr(12)p eop
%%Page: 13 13
13 12 bop 118 154 a Fx(ev)o(er,)19 b(the)f(n)o(um)o(b)q(er)f(of)h
(terms)f(in)h(a)f(canonical)h(rep-)118 210 y(resen)o(tativ)o(e)11
b(\(the)i(expression)f(after)g(simpli\014cation\))118
267 y(will)i(b)q(e)i(ab)q(out)f Fu(n)p Fx(!.)177 323
y(An)o(yw)o(a)o(y)l(,)26 b(w)o(e)f(ha)o(v)o(e)g(to)f(w)o(ork)g(with)g
(a)h(practi-)118 379 y(cally)19 b(full)h(set)g(of)f(p)q(erm)o
(utations,)g(whic)o(h)h(con)o(tains)118 436 y Fu(n)p
Fx(!)15 b(mem)o(b)q(ers.)177 492 y(Th)o(us,)f(the)h(minim)o(um)c
(computer)i(memory)f(nec-)118 549 y(essary)f(to)f(store)h(the)g(elab)q
(orated)f(expressions)h(is)g(not)118 605 y(less)16 b(then)h
Fu(n)p Fx(!)11 b Fs(\001)f Fu(l)i Fs(\001)e Fu(k)q Fx(.)24
b(The)17 b(t)o(ypical)e(n)o(um)o(b)q(er)h(of)g(Lisp)118
662 y(cells)c(necessary)g(to)g(store)f(a)h(single)f(term)g(of)h(a)g
(tensor)118 718 y(expressions)19 b(\(basic)f(tensor\))f(is)i(4.)29
b(The)19 b(length)g(of)118 775 y(eac)o(h)f(cell)f(is)h(8)f(Byte.)28
b(The)18 b(results)f(of)h(calculation)118 831 y(for)11
b(di\013eren)o(t)f(ranks)h(of)g(the)g(p)q(erm)o(utation)f(group)h(are)
118 888 y(collected)k(in)g(the)g(table.)p 177 917 859
2 v 176 1030 2 113 v 202 956 a(Rank)h(of)e Fu(S)402 963
y Ft(n)p 462 1030 V 488 956 a Fx(Num)o(b)q(er)39 b(of)488
1013 y(Mcells)p 748 1030 V 774 956 a(Memory)32 b(in)774
1013 y(Mb)o(yte)p 1034 1030 V 177 1032 859 2 v 176 1088
2 57 v 202 1071 a(9)p 462 1088 V 263 w(2.9)p 748 1088
V 227 w(22.6)p 1034 1088 V 176 1144 V 202 1127 a(10)p
462 1144 V 240 w(29.0)p 748 1144 V 204 w(226.8)p 1034
1144 V 176 1201 V 202 1184 a(11)p 462 1201 V 240 w(319.3)p
748 1201 V 181 w(2494.8)p 1034 1201 V 177 1203 859 2
v 177 1262 a(2{3)16 b(times)e(more)h(memory)f(is)i(necessary)g(in)g
(the)118 1318 y(in)o(termediate)26 b(steps)h(of)g(calculations.)56
b(Mo)q(dern)118 1375 y(computers)24 b(usually)h(equipp)q(ed)i(with)d
(up)i(to)f(512)118 1431 y(Mb)o(yte)f(memory)e(can)j(elab)q(orate)f
(tensor)g(expres-)118 1488 y(sions)19 b(with)g(not)g(more)f(then)i(10)f
(indices)g(with)g(the)118 1544 y(help)11 b(of)f(the)g(prop)q(osed)h
(algorithm.)k(Ho)o(w)o(ev)o(er,)10 b(hard-)118 1601 y(w)o(are)16
b(dev)o(elopmen)o(t)e(is)i(v)o(ery)g(fast)f(no)o(w,)h(and)g(it)g(will)
118 1657 y(b)q(e)k(p)q(ossible)g(to)f(solv)o(e)g(problems)f(with)h(11)g
(indices)118 1714 y(with)14 b(the)h(help)f(of)g(our)h(program.)i
(Finally)l(,)c(w)o(e)h(note)118 1770 y(that)e(it)f(p)q(ossible)h(to)g
(mo)q(dify)f(the)h(algorithm)d(so)j(that)118 1826 y(the)17
b(memory)c(limitatio)o(ns)h(w)o(ould)i(b)q(e)h(not)f(so)g(hard.)118
1883 y(Ho)o(w)o(ev)o(er,)i(this)g(adv)m(an)o(tage)h(is)f(comp)q
(ensated)g(b)o(y)h(a)118 1939 y(signi\014can)o(t)f(increase)h(of)f(the)
h(execution)g(time.)29 b(T)l(o)118 1996 y(summarize)17
b(this)i(section,)h(w)o(e)g(conclude)g(that)f(the)118
2052 y(absolute)f(limit)e(for)h(the)i(group)f(algebra)g(approac)o(h)118
2109 y(dev)o(elop)q(ed)e(in)f(this)g(w)o(ork)f(is)h(12)f(indices.)118
2269 y Fy(10)82 b(Examples)118 2388 y Fd(10.1)66 b(Symmetric)31
b(and)f(an)n(tisym-)305 2463 y(metric)23 b(tensors)118
2549 y Fx(A)o(t)18 b(the)h(b)q(eginning,)g(let)f(us)g(declare)h(the)f
(names)g(of)118 2605 y(basic)d(tensors:)118 2685 y Fu(tensor)27
b(s)p Fx(2)p Fu(;)8 b(a)p Fx(3)p Fu(;)g(v)r Fx(1)p Fu(;)g(v)r
Fx(2)p Fu(;)f(v)q Fx(3;)1143 154 y(By)j(using)h Fu(T)6
b(S)s(Y)j(M)16 b Fx(command)8 b(w)o(e)i(in)o(tro)q(duce)h(the)1084
210 y Fo(S-I)k Fx(relations)f(of)h(the)g(basic)g(tensors:)1109
277 y Fu(tsy)r(m)50 b(s)p Fx(2\()p Fu(i;)8 b(j)s Fx(\))g
Fs(\000)i Fu(s)p Fx(2\()p Fu(j;)e(i)p Fx(\))p Fu(;)141
b Fx(\045)15 b(Symmetric)1260 334 y Fu(a)p Fx(3\()p Fu(i;)8
b(j;)g(k)q Fx(\))f(+)k Fu(a)p Fx(3\()p Fu(j;)d(i;)g(k)q
Fx(\))p Fu(;)46 b Fx(\045)15 b(An)o(tisymm.)1260 390
y Fu(a)p Fx(3\()p Fu(i;)8 b(j;)g(k)q Fx(\))f Fs(\000)k
Fu(a)p Fx(3\()p Fu(j;)d(k)q(;)g(i)p Fx(\);)1143 491 y(Let)15
b(us)h(output)f(the)g Fo(K)1551 498 y Fc(0)1574 491 y
Fx(-bases)g(constructed)g(for)1084 548 y(the)g(tensors)g
Fu(a)1341 555 y Fm(2)1376 548 y Fx(and)g Fu(s)1485 555
y Fm(2)1084 628 y Fu(k)q(basis)25 b(s)p Fx(2)p Fu(;)8
b(a)p Fx(3;)1168 704 y Fs(\))50 b Fu(s)p Fx(2\()p Fu(j;)8
b(i)p Fx(\))g(+)j(\()p Fs(\000)p Fx(1\))e Fs(\003)h Fu(s)p
Fx(2\()p Fu(i;)e(j)s Fx(\))1168 761 y Fs(\))50 b Fx(1)1168
873 y Fs(\))g Fu(a)p Fx(3\()p Fu(k)q(;)8 b(i;)g(j)s Fx(\))f(+)j
Fu(a)p Fx(3\()p Fu(j;)e(i;)g(k)q Fx(\))1168 930 y Fs(\))50
b Fu(a)p Fx(3\()p Fu(k)q(;)8 b(j;)g(i)p Fx(\))f(+)k(\()p
Fs(\000)p Fx(1\))e Fs(\003)h Fu(a)p Fx(3\()p Fu(j;)e(i;)g(k)q
Fx(\))1168 986 y Fs(\))50 b Fu(a)p Fx(3\()p Fu(i;)8 b(k)q(;)g(j)s
Fx(\))f(+)j(\()p Fs(\000)p Fx(1\))g Fs(\003)f Fu(a)p
Fx(3\()p Fu(j;)f(i;)g(k)q Fx(\))1168 1043 y Fs(\))50
b Fu(a)p Fx(3\()p Fu(i;)8 b(j;)g(k)q Fx(\))f(+)k Fu(a)p
Fx(3\()p Fu(j;)d(i;)g(k)q Fx(\))1168 1099 y Fs(\))50
b Fu(a)p Fx(3\()p Fu(j;)8 b(k)q(;)g(i)p Fx(\))f(+)k Fu(a)p
Fx(3\()p Fu(j;)d(i;)g(k)q Fx(\))1168 1156 y Fs(\))50
b Fx(5)1143 1232 y(No)o(w)13 b(w)o(e)g(are)g(ready)h(to)f(simplify)e
(tensor)i(expres-)1084 1288 y(sions.)19 b(Some)14 b(examples)g(are:)
1109 1365 y Fu(s)p Fx(2\()p Fu(i;)8 b(j)s Fx(\))f(+)k
Fu(s)p Fx(2\()p Fu(j;)d(i)p Fx(\);)83 b Fs(\))13 b Fx(2)d
Fs(\003)f Fu(s)p Fx(2\()p Fu(i;)f(j)s Fx(\))1109 1421
y Fu(a)p Fx(3\()p Fu(i;)g(j;)g(k)q Fx(\))f Fs(\003)j
Fu(s)p Fx(2\()p Fu(i;)e(j)s Fx(\);)47 b Fs(\))13 b Fx(0)1109
1482 y Fu(a)p Fx(3\()p Fu(i;)8 b(j;)g(k)q Fx(\))f Fs(\003)j
Fu(v)r Fx(1\()p Fu(i)p Fx(\))e Fs(\003)i Fu(v)r Fx(2\()p
Fu(j)s Fx(\))e Fs(\003)i Fu(v)r Fx(1\()p Fu(k)q Fx(\);)48
b Fs(\))13 b Fx(0)1143 1562 y(Sometimes)19 b(one)j(can)f(get)h(a)f
('strange')f(output)1084 1618 y(if)e(one)g(will)f(not)h(b)q(e)h
(careful)g(with)e(the)i(input.)29 b(F)l(or)1084 1675
y(example,)1109 1751 y Fu(x)12 b Fx(:=)h Fu(s)p Fx(2\()p
Fu(i;)8 b(i)p Fx(\);)47 b Fs(\))13 b Fu(x)g Fx(:=)g Fu(s)p
Fx(2\()p Fu(i;)8 b(i)p Fx(\))1109 1807 y Fu(x)i Fs(\003)g
Fu(v)r Fx(1\()p Fu(i)p Fx(\);)111 b Fs(\))13 b Fu(s)p
Fx(2\()p Fu(i;)8 b(i)p Fx(\))g Fs(\003)i Fu(v)r Fx(1\()p
Fu(i)p Fx(\))1084 1884 y(F)l(rom)19 b(the)h(standard)g(p)q(oin)o(t)g
(of)h(view,)g(the)f(second)1084 1940 y(output)f(is)f(incorrect)h(due)g
(to)g(the)g(fact)f(that)h(three)1084 1996 y(indices)c(with)g(the)h
(same)e(name)g(are)i(presen)o(t.)k(Ho)o(w-)1084 2053
y(ev)o(er,)e(the)f(input)h(has)g(not)f(b)q(een)i(recognized)f(as)f(an)
1084 2109 y(error.)i(If)c(one)h(switc)o(hes)e(on)h(the)h(\015ag)1084
2189 y Fu(on)38 b(dummy)r(pr)q(i)p Fx(;)1084 2270 y(and)18
b(then)h(rep)q(eats)f(the)h(previous)f(input)g(then)h(one)1084
2326 y(gets)14 b(the)i(follo)o(wing)d(output:)1109 2406
y Fu(x)d Fs(\003)g Fu(v)r Fx(1\()p Fu(i)p Fx(\);)47 b
Fs(\))13 b Fu(s)p Fx(2\()p Fu(i)1473 2413 y Fm(23)1510
2406 y Fu(;)8 b(i)1547 2413 y Fm(24)1583 2406 y Fx(\))i
Fs(\003)g Fu(v)r Fx(1\()p Fu(i)p Fx(\))1084 2486 y(Hence,)21
b(the)f(\014rst)f(t)o(w)o(o)g Fu(i)p Fx('s)g(are)g(dummies)f(and)i(the)
1084 2543 y(last)14 b(one)h(is)g(a)g(free)g(index.)1143
2599 y(If)e(a)g(user)h(w)o(ould)e(lik)o(e)h(to)f(output)h(the)g
Fo(K)p Fx(-basis)g(of)1084 2655 y(the)18 b(pro)q(duct)h(of)g(the)f
(tensors)h Fu(s)1656 2662 y Fm(2)1694 2655 y Fx(and)g
Fu(a)1810 2662 y Fm(3)1830 2655 y Fx(,)g(the)f(fol-)1039
2827 y Fr(13)p eop
%%Page: 14 14
14 13 bop 118 154 a Fx(lo)o(wing)17 b(format)f(of)h(the)i(command)d
Fu(K)s(B)r(AS)s(I)t(S)k Fx(has)118 210 y(to)15 b(b)q(e)h(used:)118
290 y Fu(k)q(basis)25 b(s)p Fx(2\()p Fu(a)p Fx(3\);)168
369 y Fs(\))68 b Fu(a)p Fx(3\()p Fu(j;)8 b(i;)g(k)q Fx(\))f
Fs(\003)j Fu(s)p Fx(2\()p Fu(i;)e(j)s Fx(\))g(+)i Fu(a)p
Fx(3\()p Fu(k)q(;)e(i;)g(j)s Fx(\))f Fs(\003)i Fu(s)p
Fx(2\()p Fu(j;)f(i)p Fx(\))168 425 y Fs(\))68 b Fu(a)p
Fx(3\()p Fu(j;)8 b(i;)g(k)q Fx(\))f Fs(\003)j Fu(s)p
Fx(2\()p Fu(j;)e(i)p Fx(\))g(+)i Fu(a)p Fx(3\()p Fu(k)q(;)e(i;)g(j)s
Fx(\))f Fs(\003)j Fu(s)p Fx(2\()p Fu(j;)e(i)p Fx(\))168
482 y(.....)168 538 y Fs(\))68 b Fx(110)118 698 y Fd(10.2)e(Riemann)23
b(tensor)118 783 y Fx(Let)c(us)f(in)o(tro)q(duce)h(the)g(Riemann)e
(tensor)h(and)h(the)118 840 y(standard)c(set)g(of)g(its)f
Fo(S-I)h Fx(relations:)177 896 y Fu(tensor)27 b(r)q(i)p
Fx(;)118 953 y Fu(tsy)r(m)f(r)q(i)p Fx(\()p Fu(i;)8 b(j;)g(k)q(;)f(l)q
Fx(\))f(+)11 b Fu(r)q(i)p Fx(\()p Fu(j;)d(i;)g(k;)g(l)q
Fx(\))o(;)118 1009 y Fu(tsy)r(m)26 b(r)q(i)p Fx(\()p
Fu(i;)8 b(j;)g(k)q(;)f(l)q Fx(\))f(+)11 b Fu(r)q(i)p
Fx(\()p Fu(i;)d(j;)g(l;)f(k)q Fx(\);)118 1066 y Fu(tsy)r(m)26
b(r)q(i)p Fx(\()p Fu(i;)8 b(j;)g(k)q(;)f(l)q Fx(\))f(+)11
b Fu(r)q(i)p Fx(\()p Fu(i;)d(k)q(;)g(l)q(;)f(j)r Fx(\))g(+)j
Fu(r)q(i)p Fx(\()p Fu(i;)e(l)q(;)g(j;)f(k)q Fx(\);)177
1146 y(The)27 b Fo(K)323 1153 y Fc(0)346 1146 y Fx(-basis)g(consists)f
(of)g(22)h(v)o(ectors)f(\(see)118 1202 y(TEST)h(R)o(UN)g(OUTPUT\))g
(and)g(the)g(full)g(v)o(ector)118 1259 y(space)19 b(has)g(4!)f(=)h(24)f
(dimensions.)29 b(Th)o(us,)19 b(an)o(y)g(ex-)118 1315
y(pressions)13 b(whic)o(h)g(are)g(linear)g(com)o(binations)e(of)i(Rie-)
118 1372 y(mann)24 b(tensors)g(with)f(p)q(erm)o(uted)h(indices)h(can)g
(b)q(e)118 1428 y(simpli\014ed)c(to)h(expressions)g(con)o(taining)f
(only)h(t)o(w)o(o)118 1484 y(basic)15 b(tensors)372 1468
y Fm(8)391 1484 y Fx(.)177 1541 y(This)k(set)g(of)g(prop)q(erties)h
(leads)f(us)g(to)g(the)h(v)o(ery)118 1597 y(imp)q(ortan)o(t)11
b(symmetry)f(prop)q(ert)o(y)i(of)h(Riemann)f(ten-)118
1654 y(sor)i(with)g(resp)q(ect)h(to)f(the)h(exc)o(hange)g(of)f(pairs)g
(of)g(in-)118 1710 y(dices:)177 1767 y Fu(r)q(i)p Fx(\()p
Fu(i;)8 b(j;)g(k)q(;)f(l)q Fx(\))g Fs(\000)j Fu(r)q(i)p
Fx(\()p Fu(k)q(;)e(l)q(;)g(i;)f(j)r Fx(\);)95 b Fs(\))13
b Fx(0)177 1847 y(Let)j(us)f(consider)g(some)f(more)g(examples,)118
1927 y Fu(r)q(i)p Fx(\()p Fu(m;)8 b(n;)g(m;)g(n)p Fx(\))f
Fs(\000)j Fu(r)q(i)p Fx(\()p Fu(m;)e(n;)g(n;)g(m)p Fx(\))603
1983 y Fs(\))13 b Fx(2)d Fs(\003)g Fu(r)q(i)p Fx(\()p
Fu(m;)e(n;)g(m;)g(n)p Fx(\).)177 2063 y(An)o(y)16 b(tensors)g
(expressions)g(consists)f(of)h(Rieman)118 2120 y(tensors)i(ma)o(y)f(b)q
(e)j(expressed)f(through)g(summ)d(of)j(2)118 2176 y(ones:)118
2256 y Fu(r)q(i)p Fx(\()p Fu(i;)8 b(j;)g(k)q(;)f(l)q
Fx(\))35 b(+)k Fu(r)q(i)p Fx(\()p Fu(j;)8 b(k)q(;)g(l)q(;)f(i)p
Fx(\))35 b(+)k Fu(r)q(i)p Fx(\()p Fu(k)q(;)8 b(l)q(;)g(i;)f(j)s
Fx(\))35 b(+)118 2313 y Fu(r)q(i)p Fx(\()p Fu(l)q(;)8
b(i;)g(j)o(;)g(k)p Fx(\);)249 2369 y Fs(\))13 b Fx(\()p
Fs(\000)p Fx(2\))c Fs(\003)h Fu(r)q(i)p Fx(\()p Fu(l)q(;)e(j;)g(i;)f(k)
q Fx(\))g(+)j(4)g Fs(\003)g Fu(r)q(i)p Fx(\()p Fu(l)q(;)e(i;)g(j)o(;)g
(k)p Fx(\))177 2449 y(A)15 b(more)e(complicated)g(example)h(with)g(m)o
(ultipli-)118 2506 y(cation)f(of)g(the)h(Riemann)f(tensor)h(and)f(the)h
(an)o(tisym-)p 118 2549 370 2 v 174 2579 a Fh(8)193 2594
y Fv(This)g(simpli\014cation)i(has)e(no)g(relation)h(to)f(the)g(n)o
(um-)118 2644 y(b)q(er)d(of)f(indep)q(enden)o(t)i(comp)q(onen)o(ts)f
(of)f(the)g(Riemann)h(cur-)118 2694 y(v)n(ature)j(tensor)h(in)g
(space-time)g(of)e(v)n(arious)h(dimensions)1084 154 y
Fx(metric)f(tensor)i Fu(a)p Fx(2)g(is)g(giv)o(en)g(in)g(the)g(section)g
Fo(TEST)1084 210 y(R)o(UN)i(OUTPUT)p Fx(.)1084 370 y
Fy(Ac)n(kno)n(wledgemen)n(ts)1084 471 y Fx(The)c(authors)g(are)g
(grateful)f(to)g(A.Grozin)g(for)h(useful)1084 528 y(discussions.)1143
584 y(This)i(w)o(ork)f(w)o(as)h(supp)q(orted)h(b)o(y)f(Russian)h(F)l
(oun-)1084 641 y(dation)c(for)g(F)l(undamen)o(tal)f(Researc)o(h)i
(\(gran)o(t)f(93-02-)1084 697 y(14428\).)1084 857 y Fy(References)1084
958 y Fx([1])23 b(L.D.Landau)f(and)g(E.M.Lifshitz,)f
Fz(Field)h(The-)1133 1015 y(ory)p Fx(,)16 b(\(Mosco)o(w,)d(Nauk)m(a,)i
(1973,)f(in)h(Russian\);)1133 1071 y(J.A.Sc)o(houten,)h
Fz(T)m(ensor)g(analysis)f(for)j(physicist)p Fx(,)1133
1128 y(\(Oxford,)d(1951\).)1084 1222 y([2])23 b(A.T)l(rautman,)13
b Fz(Symp.)j(Math.)p Fx(,)f Fo(12)h Fx(\(1973\))d(139;)1133
1278 y(F.W.Hehl)g(et)g(al.,)f Fz(R)n(ev.)i(Mo)n(d.)h(Phys.)p
Fx(,)e Fo(48)h Fx(\(1976\))1133 1335 y(393;)1133 1391
y(Y)l(u.N.Obukho)o(v)e(and)g(P)l(.I.Pronin,)g Fz(A)n(cta)g(Physic)n(a)
1133 1447 y(Polonic)n(a)p Fx(,)i Fo(B19)i Fx(\(1988\))d(341.)1084
1541 y([3])23 b(A.Y)l(a.Ro)q(diono)o(v)14 b(and)h(A.Y)l(u.T)l(arano)o
(v,)e Fz(L)n(e)n(ctur)n(e)1133 1598 y(Notes)f(in)g(Comp.)g(Sci.)d
Fo(378)p Fx(,)j(\(Pro)q(ceedins)f(of)f(EU-)1133 1654
y(R)o(OCAL'87,)15 b(1989\))f(192)1084 1748 y([4])23 b(V.A.Ilyin)k(et)g
(al.,)i(in:)44 b Fz(Pr)n(o)n(c.)27 b(of)h(IV)e(Inter-)1133
1804 y(national)20 b(c)n(onfer)n(enc)n(e)e(on)i(c)n(omputer)h(algebr)n
(a)e(in)1133 1861 y(physic)n(al)g(r)n(ese)n(ar)n(ch)g(\(Dubna)g(1990,)i
(22-26)g(May,)1133 1917 y(USSR\))14 b Fx(190-194.)1084
2011 y([5])23 b(M.A.Naimark,)12 b Fz(The)n(ory)k(of)g(gr)n(oup)g(r)n
(epr)n(esenta-)1133 2068 y(tion)p Fx(,)f(\(Mosco)o(w,)e(Nauk)m(a,)i
(1976,)f(in)h(Russian\).)1084 2161 y([6])23 b(B.Buc)o(h)o(burger,)41
b(G.E.Collins)32 b(and)k(R.Lo)q(os,)1133 2218 y Fz(Computer)i(A)o
(lgebr)n(a)e(-)h(symb)n(olic)f(and)h(alge-)1133 2274
y(br)n(aic)12 b(c)n(omputation)p Fx(,)g(\(second)f(edition,)f
(Springer,)1133 2331 y(1983\).)1084 2425 y([7])23 b(A.C.Hearn,)15
b Fz(REDUCE)i(USER'S)f(MANUAL,)1133 2481 y(version)22
b(3.3)p Fx(,)i(\(The)e(Rand)h(publication)e(CP78,)1133
2538 y(Rev.)16 b(7.87,)d(1987\).)1084 2631 y([8])23 b(V.A.Ilyin)28
b(and)g(A.P)l(.Kryuk)o(o)o(v,)i(in)e(Pro)q(c.)g(of)1133
2688 y(the)21 b(In)o(t.)g(Symp.)e(of)i(Sym)o(b)q(olic.)e(and)i
(Algebraic)1039 2827 y Fr(14)p eop
%%Page: 15 15
15 14 bop 168 154 a Fx(Computation)14 b(\(ISSA)o(C'91\),)h(July)h
(15-17,)g(1991,)168 210 y(Bonn,)26 b(Ed.)e(b)o(y)g(S.W)l(att,)h(A)o(CM)
f(Press)g(\(1991\))168 267 y(224.)118 360 y([9])f(V.A.Ilyin)13
b(and)h(A.P)l(.Kryuk)o(o)o(v,)f(in)g("New)h(Com-)168
417 y(puting)21 b(tec)o(hniques)h(in)f(Ph)o(ysics)g(Researc)o(h)h(I)q
(I",)168 473 y(Pro)q(c.)34 b(of)f(AIHENP-92,)39 b(Ed.)34
b(b)o(y)g(D.P)o(erret-)168 530 y(Gallix,)22 b(W)l(orld)g(Scien)o
(ti\014c,)h(Singap)q(ore,)h(\(1992\))168 586 y(639-648.)118
680 y([10])f(R.J.)f(Bradford,)g(A.C.)f(Hearn,)i(J.A.)e(P)o(adget)168
736 y(and)g(E.)g(Sc)o(hr)q(\177)-24 b(ufer,)22 b(\\Enlarging)e(the)h
Fz(REDUCE)168 793 y Fx(Domain)h(of)j(Computation,")f(Pro)q(c.)g(of)g
(SYM-)168 849 y(SA)o(C)15 b('86,)f(A)o(CM,)g(New)h(Y)l(ork)g(\(1986\))e
(100.)118 943 y([11])23 b(S.A.F)l(ulling,)45 b(R.C.King,)h(B.G.Wyb)q
(ourne)168 1000 y(and)18 b(C.J.Cummi)o(ns)d(Class.)h(Quan)o(tum)h(Gra)o
(v.)f Fo(9)168 1056 y Fx(\(1992\))d(1151-1197.)118 1150
y([12])23 b(D.E.)35 b(Kn)o(uth,)41 b Fz(F)m(undamental)35
b(A)o(lgorithms,)168 1206 y(vol.)25 b(1)h(of)g(the)f("A)o(rt)h(of)g
(Computer)g(Pr)n(o)n(gr)n(am-)168 1263 y(ming")15 b Fx(\(Addison-W)l
(esley)l(,)g(1968\).)1039 2827 y Fr(15)p eop
%%Page: 16 16
16 15 bop 664 154 a Fy(TEST)26 b(R)n(UN)h(OUTPUT)118
264 y Fa(\045**************************)o(*******)o(********)o(*******)
o(*******)o(********)o(******)118 320 y(\045)620 b(ATENSOR)47
b(TEST)g(RUN.)118 377 y(\045)118 433 y(\045)549 b(V.A.Ilyin)22
b(&)i(A.P.Kryukov)118 490 y(\045)430 b(E-mail:)70 b
(ilyin@theory.npi.msu.su)118 546 y(\045)620 b
(kryukov@theory.npi.msu.su)118 603 y(\045)118 659 y(\045)382
b(Nucl.)23 b(Phys.)g(Inst.,)g(Moscow)g(State)g(Univ.)118
716 y(\045)573 b(119899)23 b(Moscow,)g(RUSSIA)118 772
y(\045**************************)o(*******)o(********)o(*******)o
(*******)o(********)o(******)118 885 y(\045)h(First)f(of)h(all)f(we)h
(have)f(to)h(load)f(the)g(ATENSOR)g(program)g(using)g(the)h(one)f(of)h
(the)118 941 y(\045)g(following)e(command:)118 998 y(\045)167
b(1\))24 b(in)f("atensor.red"$)213 b(\045)24 b(If)f(we)h(load)f(source)
g(code)118 1054 y(\045)167 b(2\))24 b(load)f(atensor$)309
b(\045)24 b(If)f(we)h(load)f(binary)g(\(compiled\))g(code.)118
1111 y(load)g(atensor;)118 1224 y(\(atensor\))118 1337
y(\045)h(To)f(control)g(of)h(total)f(execution)g(time)g(clear)g(timer:)
118 1393 y(showtime;)118 1506 y(Time:)g(0)h(ms)118 1619
y(\045)g(Switch)f(on)g(the)h(switch)f(TIME)g(to)h(control)f(of)g
(executing)g(time)118 1675 y(\045)h(for)f(each)h(statement.)118
1732 y(\045on)g(time$)118 1845 y(\045)g(Let)f(us)h(introduce)f(the)g
(antisymmetric)f(tensor)h(of)h(the)f(second)g(order.)118
1901 y(tensor)g(a2;)118 2014 y(\045)h(The)f(antisymmetric)f(property)h
(can)h(be)f(expressed)g(as:)118 2071 y(tsym)g(a2\(i,j\)+a2\(j,i\);)118
2183 y(\045)h(The)f(K-basis)g(that)h(span)f(K)h(subspace)e(is:)118
2240 y(kbasis)h(a2;)118 2353 y(a2\(i,j\))g(+)h(a2\(j,i\))118
2409 y(1)118 2522 y(\045)g(Let)f(us)h(input)f(very)g(simple)g(example:)
118 2579 y(a2\(k,k\);)118 2692 y(0)1039 2827 y Fr(16)p
eop
%%Page: 17 17
17 16 bop 118 210 a Fa(\045)24 b(By)f(the)h(way)f(the)h(next)f(two)h
(expressions)e(looks)h(like)g(different)g(ones:)118 267
y(a2\(i,j\);)118 379 y(a2\(i,j\))118 492 y(a2\(j,i\);)118
605 y(a2\(j,i\))118 718 y(\045)h(But)f(the)h(difference)e(of)i(them)f
(has)h(a)f(correct)g(value:)118 775 y(a2\(j,i\)-a2\(i,j\);)118
888 y(2*a2\(j,i\))118 1000 y(\045)h(Next)f(examples.)g(For)g(this)h
(purpose)e(we)i(introduce)f(3)g(abstract)118 1057 y(\045)h(vectors)f(-)
g(v1,v2,v3:)118 1113 y(tensor)g(v1,v2,v3;)118 1226 y(\045)h(The)f
(following)g(expression)f(equal)i(zero:)118 1283 y
(a2\(i,j\)*v1\(i\)*v1\(j\);)118 1396 y(0)118 1509 y(\045)g(It)f(is)h
(interest)f(that)g(the)h(result)f(is)g(consequence)g(of)g(the)h
(equivalence)118 1565 y(\045)g(of)f(the)h(name)f(of)h(tensors.)118
1678 y(\045)g(While)f(the)g(next)h(one)f(-)h(not:)118
1734 y(a2\(i,j\)*v1\(i\)*v2\(j\);)118 1847 y(a2\(i,j\)*v1\(i\)*v2\(j\))
118 1960 y(\045)g(Well.)f(Let)g(us)h(introduce)f(the)g(symmetric)g
(tensor)g(of)g(the)h(second)f(order.)118 2017 y(tensor)g(s2;)118
2130 y(tsym)g(s2\(i,j\)-s2\(j,i\);)118 2299 y(\045)h(Their)f(K-basis)g
(look)g(like)h(for)f(a2)h(excepted)e(sign:)118 2355 y(kbasis)h(s2;)118
2468 y(s2\(j,i\))g(+)h(\(-1\)*s2\(i,j\))118 2525 y(1)118
2638 y(\045)g(Of)f(course)g(the)h(contraction)e(symmetric)47
b(and)23 b(antisymmetric)f(tensors)118 2694 y(\045)i(equal)f(zero:)1039
2827 y Fr(17)p eop
%%Page: 18 18
18 17 bop 118 154 a Fa(a2\(i,j\)*s2\(i,j\);)118 267 y(0)118
379 y(\045)24 b(By)f(the)h(way,)f(the)h(next)f(example)g(not)g(so)h
(trivial)f(for)g(computer...)118 436 y(a2\(i,j\)*a2\(j,k\)*a2\(k,i\);)
118 549 y(0)118 662 y(\045)h(Much)f(more)g(interesting)g(examples)g(we)
g(can)h(demonstrate)e(with)h(the)118 718 y(\045)h(the)f(tensor)g
(higher)g(order.)g(For)h(example)f(full)g(antisymmetric)f(tensor)118
775 y(\045)i(of)f(the)h(third)f(order:)118 831 y(tensor)g(a3;)118
944 y(\045)h(The)f(antisymmetric)f(property)h(we)h(can)f(introduce)g
(through)g(the)118 1000 y(\045)h(permutation)e(of)i(the)f(two)h(first)f
(indices:)118 1057 y(tsym)g(a3\(i,j,k\)+a3\(j,i,k\);)118
1170 y(\045)h(And)f(the)h(cyclic)f(permutation)f(all)i(of)f(them:)118
1226 y(tsym)g(a3\(i,j,k\)-a3\(j,k,i\);)118 1339 y(\045)h(The)f(K)h
(basis)f(of)h(a3)f(consist)g(of)h(5)g(vectors:)118 1396
y(kbasis)f(a3;)118 1509 y(a3\(k,i,j\))g(+)g(a3\(j,i,k\))118
1565 y(a3\(k,j,i\))g(+)g(\(-1\)*a3\(j,i,k\))118 1621
y(a3\(i,k,j\))g(+)g(\(-1\)*a3\(j,i,k\))118 1678 y(a3\(i,j,k\))g(+)g
(a3\(j,i,k\))118 1734 y(a3\(j,k,i\))g(+)g(a3\(j,i,k\))118
1791 y(5)118 1904 y(\045)h(In)f(the)h(beginning)f(some)g(very)g(simple)
g(examples:)118 1960 y(a3\(i,k,i\);)118 2073 y(0)118
2186 y(a3\(i,j,k\)*s2\(i,j\);)118 2299 y(0)118 2412 y(\045)h(The)f
(full)h(symmetric)e(tensor)h(of)h(the)f(third)h(order)f(may)g(be)h
(introduce)118 2468 y(\045)g(by)f(the)h(similar)f(way:)118
2525 y(tensor)g(s3;)118 2638 y(tsym)g(s3\(i,j,k\)-s3\(j,i,k\);)1039
2827 y Fr(18)p eop
%%Page: 19 19
19 18 bop 118 154 a Fa(tsym)23 b(s3\(i,j,k\)-s3\(j,k,i\);)118
267 y(kbasis)g(s3;)118 379 y(s3\(k,j,i\))g(+)g(\(-1\)*s3\(i,j,k\))118
436 y(s3\(k,i,j\))g(+)g(\(-1\)*s3\(i,j,k\))118 492 y(s3\(j,k,i\))g(+)g
(\(-1\)*s3\(i,j,k\))118 549 y(s3\(j,i,k\))g(+)g(\(-1\)*s3\(i,j,k\))118
605 y(s3\(i,k,j\))g(+)g(\(-1\)*s3\(i,j,k\))118 662 y(5)118
775 y(\045)h(The)f(next)h(examples)e(demonstrate)h(some)g(calculation)f
(with)i(them:)118 831 y(s3\(i,j,k\)-s3\(i,k,j\);)118
944 y(0)118 1057 y(s3\(i,j,k\)*a2\(i,j\);)118 1170 y(0)118
1283 y(a3\(i,j,k\)*s2\(i,j\);)118 1396 y(0)118 1509 y
(s3\(i,j,k\)*a3\(i,j,k\);)118 1621 y(0)118 1734 y(\045)g(Now)f(we)h
(consider)f(very)g(important)g(physical)f(case)i(-)f(Rieman)g(tensor:)
118 1791 y(tensor)g(ri;)118 1904 y(\045)h(It)f(has)h(the)f
(antisymmetric)f(property)h(with)h(respect)e(to)i(the)f(permutation)118
1960 y(\045)h(of)f(the)h(first)f(two)h(indices:)118 2017
y(tsym)f(ri\(i,j,k,l\))g(+)h(ri\(j,i,k,l\);)118 2130
y(\045)g(It)f(has)h(the)f(antisymmetric)f(property)h(with)h(respect)e
(to)i(the)f(permutation)118 2186 y(\045)h(of)f(the)h(second)f(two)g
(indices:)118 2242 y(tsym)g(ri\(i,j,k,l\))g(+)h(ri\(i,j,l,k\);)118
2355 y(\045)g(And)f(the)h(triple)f(term)g(identity)g(with)g(cyclic)g
(permutation)g(the)118 2412 y(\045)h(third)f(of)h(them:)118
2468 y(tsym)f(ri\(i,j,k,l\))g(+)h(ri\(i,k,l,j\))e(+)i(ri\(i,l,j,k\);)
118 2581 y(\045)g(The)f(corresponding)f(K)i(basis)f(consist)g(of)h
(22\(!\))f(vectors:)118 2638 y(kbasis)g(ri;)1039 2827
y Fr(19)p eop
%%Page: 20 20
20 19 bop 118 154 a Fa(ri\(l,k,i,j\))22 b(+)i(\(-1\)*ri\(j,i,k,l\))118
210 y(ri\(l,k,j,i\))e(+)i(ri\(j,i,k,l\))118 267 y(ri\(l,i,k,j\))e(+)i
(\(-1\)*ri\(j,k,i,l\))118 323 y(ri\(l,i,j,k\))e(+)i(ri\(j,k,i,l\))118
379 y(ri\(l,j,k,i\))e(+)i(\(-1\)*ri\(j,k,i,l\))e(+)i(ri\(j,i,k,l\))118
436 y(ri\(l,j,i,k\))e(+)i(ri\(j,k,i,l\))f(+)g(\(-1\)*ri\(j,i,k,l\))118
492 y(ri\(k,l,i,j\))f(+)i(ri\(j,i,k,l\))118 549 y(ri\(k,l,j,i\))e(+)i
(\(-1\)*ri\(j,i,k,l\))118 605 y(ri\(k,i,l,j\))e(+)i
(\(-1\)*ri\(j,k,i,l\))e(+)i(ri\(j,i,k,l\))118 662 y(ri\(k,i,j,l\))e(+)i
(ri\(j,k,i,l\))f(+)g(\(-1\)*ri\(j,i,k,l\))118 718 y(ri\(k,j,l,i\))f(+)i
(\(-1\)*ri\(j,k,i,l\))118 775 y(ri\(k,j,i,l\))e(+)i(ri\(j,k,i,l\))118
831 y(ri\(i,l,k,j\))e(+)i(ri\(j,k,i,l\))118 888 y(ri\(i,l,j,k\))e(+)i
(\(-1\)*ri\(j,k,i,l\))118 944 y(ri\(i,k,l,j\))e(+)i(ri\(j,k,i,l\))f(+)g
(\(-1\)*ri\(j,i,k,l\))118 1000 y(ri\(i,k,j,l\))f(+)i
(\(-1\)*ri\(j,k,i,l\))e(+)i(ri\(j,i,k,l\))118 1057 y(ri\(i,j,l,k\))e(+)
i(\(-1\)*ri\(j,i,k,l\))118 1113 y(ri\(i,j,k,l\))e(+)i(ri\(j,i,k,l\))118
1170 y(ri\(j,l,k,i\))e(+)i(ri\(j,k,i,l\))f(+)g(\(-1\)*ri\(j,i,k,l\))118
1226 y(ri\(j,l,i,k\))f(+)i(\(-1\)*ri\(j,k,i,l\))e(+)i(ri\(j,i,k,l\))118
1283 y(ri\(j,k,l,i\))e(+)i(ri\(j,k,i,l\))118 1339 y(ri\(j,i,l,k\))e(+)i
(ri\(j,i,k,l\))118 1396 y(22)118 1509 y(\045)g(So)f(we)h(get)f(the)h
(answer)f(for)g(any)h(expressions)e(with)i(3)f(and)h(more)f(terms)g(of)
118 1565 y(\045)h(Rieman)f(tensors)g(with)g(not)h(more)f(then)g(2)h
(terms.)f(For)g(example:)118 1621 y(ri\(i,j,k,l\)+ri\(j,k,l,i\)+ri\()o
(k,l,i,j)o(\)+ri\(l,i)o(,j,k\);)118 1734 y(\(-2\)*ri\(l,j,i,k\))f(+)i
(4*ri\(l,i,j,k\))118 1847 y(\045)g(This)f(three)g(identities)g(leads)g
(us)h(to)f(very)h(important)e(symmetry)h(property)g(with)118
1904 y(\045)h(respect)f(to)g(exchange)g(of)h(pairs)f(indices:)118
1960 y(ri\(i,j,k,l\)-ri\(k,l,i,j\);)118 2073 y(0)118
2186 y(\045)h(Let)f(us)h(start)f(with)g(simple)g(example:)118
2242 y(ri\(m,n,m,n\)-ri\(m,n,n,m\);)118 2355 y(2*ri\(m,n,m,n\))118
2468 y(\045)h(Much)f(more)g(complicated)g(example)g(is:)118
2525 y(a2\(m,n\)*ri\(m,n,c,d\))e(+)j(a2\(k,l\)*ri\(c,d,l,k\);)118
2638 y(0)1039 2827 y Fr(20)p eop
%%Page: 21 21
21 20 bop 118 154 a Fa(\045)24 b(The)f(answer)g(is)h(trivial)f(but)g
(not)h(so)f(simple)g(to)h(obtain)f(one.)118 267 y(\045)h(The)f
(dimension)g(of)h(the)f(full)g(space)g(is)h(6!)g(=)f(720.)118
323 y(\045)h(The)f(K)h(basis)f(consists)g(of)h(690)f(vectors)g(\(to)g
(reduce)g(output)g(we)118 379 y(\045)h(commented)e(the)i(last)f
(statement\):)118 436 y(\045kbasis)g(ri\(a2\);)118 549
y(\045)h(One)f(else)h(nontrivial)e(examples)h(with)g(Riemann)g
(tensors:)118 605 y(\(ri\(i,j,k,l\)-ri\(i,k,j,l\)\)*a)o(2\(i,j\);)142
718 y(a2\(i,j\)*ri\(i,j,k,l\))118 775 y(---------------------)357
831 y(2)118 944 y(\045*****************)f(END)h(OF)h(TEST)f(RUN)g
(************************)118 1000 y(\045)h(The)f(total)g(execution)g
(time)g(is:)118 1057 y(showtime;)118 1170 y(Time:)g(196940)g(ms)48
b(plus)23 b(GC)h(time:)f(10670)g(ms)118 1283 y($)118
1396 y(END$)1039 2827 y Fr(21)p eop
%%Trailer
end
userdict /end-hook known{end-hook}if
%%EOF

mathpiper-0.81f+svn4469+dfsg3/src/packages/atensor/atensor.rlg0000644000175000017500000001272611527635055024364 0ustar  giovannigiovanniFri Feb 18 21:27:18 2011 run on win32
%*********************************************************************
%                          ATENSOR  TEST  RUN.
%
%                       V.A.Ilyin & A.P.Kryukov
%                  E-mail:   ilyin@theory.npi.msu.su
%                          kryukov@theory.npi.msu.su
%
%                Nucl. Phys. Inst., Moscow State Univ. 
%                        119899 Moscow, RUSSIA
%*********************************************************************

% First of all we have to load the ATENSOR program using the one of the
% following command:
%       1) in "atensor.red"$         % If we load source code
%       2) load atensor$             % If we load binary (compiled) code.
load atensor;



% To control of total execution time clear timer:
showtime;


Time: 0 ms


% Switch on the switch TIME to control of executing time 
% for each statement.
%on time$

% Let us introduce the antisymmetric tensor of the second order.
tensor a2;



% The antisymmetric property can be expressed as:
tsym a2(i,j)+a2(j,i);



% The K-basis that span K subspace is:
kbasis a2;

a2(i,j) + a2(j,i)
1


% Let us input very simple example:
a2(k,k);


0


% By the way the next two expressions looks like different ones:
a2(i,j);


a2(i,j)

a2(j,i);


a2(j,i)


% But the difference of them has a correct value:
a2(j,i)-a2(i,j);


2*a2(j,i)


% Next examples. For this purpose we introduce 3 abstract 
% vectors - v1,v2,v3:
tensor v1,v2,v3;



% The following expression equal zero:
a2(i,j)*v1(i)*v1(j);


0

% It is interest that the result is consequence of the equivalence 
% of the name of tensors.

% While the next one - not:
a2(i,j)*v1(i)*v2(j);


a2(i,j)*v1(i)*v2(j)


% Well. Let us introduce the symmetric tensor of the second order.
tensor s2;


tsym s2(i,j)-s2(j,i);



% Their K-basis look like for a2 excepted sign:
kbasis s2;

s2(j,i) + (-1)*s2(i,j)
1


% Of course the contraction symmetric  and antisymmetric tensors 
% equal zero:
a2(i,j)*s2(i,j);


0


% By the way, the next example not so trivial for computer...
a2(i,j)*a2(j,k)*a2(k,i);


0


% Much more interesting examples we can demonstrate with the
% the tensor higher order. For example full antisymmetric tensor
% of the third order:
tensor a3;



% The antisymmetric property we can introduce through the 
% permutation of the two first indices: 
tsym a3(i,j,k)+a3(j,i,k);



% And the cyclic permutation all of them:
tsym a3(i,j,k)-a3(j,k,i);



% The K basis of a3 consist of 5 vectors:
kbasis a3;

a3(k,i,j) + a3(j,i,k)
a3(k,j,i) + (-1)*a3(j,i,k)
a3(i,k,j) + (-1)*a3(j,i,k)
a3(i,j,k) + a3(j,i,k)
a3(j,k,i) + a3(j,i,k)
5


% In the beginning some very simple examples:
a3(i,k,i);


0

a3(i,j,k)*s2(i,j);


0


% The full symmetric tensor of the third order may be introduce
% by the similar way: 
tensor s3;


tsym s3(i,j,k)-s3(j,i,k);


tsym s3(i,j,k)-s3(j,k,i);


kbasis s3;

s3(k,j,i) + (-1)*s3(i,j,k)
s3(k,i,j) + (-1)*s3(i,j,k)
s3(j,k,i) + (-1)*s3(i,j,k)
s3(j,i,k) + (-1)*s3(i,j,k)
s3(i,k,j) + (-1)*s3(i,j,k)
5


% The next examples demonstrate some calculation with them:
s3(i,j,k)-s3(i,k,j);


0

s3(i,j,k)*a2(i,j);


0

a3(i,j,k)*s2(i,j);


0

s3(i,j,k)*a3(i,j,k);


0



% Now we consider very important physical case - Rieman tensor:
tensor ri;



% It has the antisymmetric property with respect to the permutation
% of the first two indices:
tsym ri(i,j,k,l) + ri(j,i,k,l);



% It has the antisymmetric property with respect to the permutation
% of the second two indices:
tsym ri(i,j,k,l) + ri(i,j,l,k);



% And the triple term identity with cyclic permutation the 
% third of them:
tsym ri(i,j,k,l) + ri(i,k,l,j) + ri(i,l,j,k);



% The corresponding K basis consist of 22(!) vectors:
kbasis ri;

ri(l,k,i,j) + (-1)*ri(j,i,k,l)
ri(l,k,j,i) + ri(j,i,k,l)
ri(l,i,k,j) + (-1)*ri(j,k,i,l)
ri(l,i,j,k) + ri(j,k,i,l)
ri(l,j,k,i) + (-1)*ri(j,k,i,l) + ri(j,i,k,l)
ri(l,j,i,k) + ri(j,k,i,l) + (-1)*ri(j,i,k,l)
ri(k,l,i,j) + ri(j,i,k,l)
ri(k,l,j,i) + (-1)*ri(j,i,k,l)
ri(k,i,l,j) + (-1)*ri(j,k,i,l) + ri(j,i,k,l)
ri(k,i,j,l) + ri(j,k,i,l) + (-1)*ri(j,i,k,l)
ri(k,j,l,i) + (-1)*ri(j,k,i,l)
ri(k,j,i,l) + ri(j,k,i,l)
ri(i,l,k,j) + ri(j,k,i,l)
ri(i,l,j,k) + (-1)*ri(j,k,i,l)
ri(i,k,l,j) + ri(j,k,i,l) + (-1)*ri(j,i,k,l)
ri(i,k,j,l) + (-1)*ri(j,k,i,l) + ri(j,i,k,l)
ri(i,j,l,k) + (-1)*ri(j,i,k,l)
ri(i,j,k,l) + ri(j,i,k,l)
ri(j,l,k,i) + ri(j,k,i,l) + (-1)*ri(j,i,k,l)
ri(j,l,i,k) + (-1)*ri(j,k,i,l) + ri(j,i,k,l)
ri(j,k,l,i) + ri(j,k,i,l)
ri(j,i,l,k) + ri(j,i,k,l)
22


% So we get the answer for any expressions with 3 and more terms of 
% Rieman tensors with not more then 2 terms. For example:
ri(i,j,k,l)+ri(j,k,l,i)+ri(k,l,i,j)+ri(l,i,j,k);


(-2)*ri(l,j,i,k) + 4*ri(l,i,j,k)
 

% This three identities leads us to very important symmetry property with
% respect to exchange of pairs indices:
ri(i,j,k,l)-ri(k,l,i,j);


0


% Let us start with simple example:
ri(m,n,m,n)-ri(m,n,n,m);


2*ri(m,n,m,n)


% Much more complicated example is:
a2(m,n)*ri(m,n,c,d) + a2(k,l)*ri(c,d,l,k);


0

% The answer is trivial but not so simple to obtain one.

% The dimension of the full space is 6! = 720.
% The K basis consists of 690 vectors (to reduce output we 
% commented the last statement):
%kbasis ri(a2);

% One else nontrivial examples with Riemann tensors:
(ri(i,j,k,l)-ri(i,k,j,l))*a2(i,j);


 a2(i,j)*ri(i,j,k,l)
---------------------
          2


%***************** END OF TEST RUN ************************
% The total execution time is:
showtime;


Time: 3994 ms  plus GC time: 48 ms


$

END$


Time for test: 3994 ms, plus GC time: 48 ms
@@@@@ Resources used: (4 18 3264 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/libreduce/0000755000175000017500000000000011722677365022465 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/libreduce/libreduce.red0000644000175000017500000001251611526203062025101 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: libreduce.red 477 2009-11-28 14:09:32Z arthurcnorman $
% ----------------------------------------------------------------------
% Copyright (c) 2008-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
% 
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
   
lisp <<
   fluid '(lr_rcsid!* lr_copyright!*);
   lr_rcsid!* := "$Id: libreduce.red 477 2009-11-28 14:09:32Z arthurcnorman $";
   lr_copyright!* := "(c) 2008 T. Sturm"
>>;

module coloutput;

fluid '(!*mode);

global '(statcounter);

copyd('lr_add2resultbuf,'add2resultbuf);

on comp;

procedure lr_sprint(u);
   prin2 u;

procedure lr_aprint(u);
   prin2 reval u;

procedure lr_result();
   <<
      prin2 int2id 3;
   >>;

procedure lr_statcounter();
   <<
      prin2 int2id 4
   >>;
   
procedure lr_mode();
   <<
      prin2 int2id 5
   >>;

procedure lr_posttext();
   <<
      prin2 int2id 6
   >>;

procedure lr_printer(u,mode);
   <<
      if mode eq 'symbolic then
	 (if u or !*mode eq 'symbolic then
	    lr_sprint u)
      else
	 lr_aprint u
   >>;

procedure add2resultbuf(u,mode);
   <<
      lr_result();
      if null(semic!* eq '!$) then lr_printer(u,mode);
      lr_statcounter();
      prin2 statcounter;
      lr_mode();
      prin2 if !*mode eq 'symbolic then 1 else 0;
      lr_posttext();
      terpri();
      lr_add2resultbuf(u,mode)
   >>;

off comp;

endmodule;  % coloutput;

module redfront;
% Prompt coloring for redfront.
% Written by Andreas Dolzmann and Thomas Sturm, 1998

fluid '(promptstring!* lr_switches!* lr_switches!-this!-sl!*
   lispsystem!*);

lr_switches!* := {!*msg,!*output};

off1 'msg;
off1 'output;

procedure lr_pslp();
   'psl memq lispsystem!*;

if lr_pslp() then <<
   lr_switches!-this!-sl!* := {!*usermode};
   off1 'usermode
>>;

procedure lr_color(c);
   if stringp c then
      compress('!" . int2id 1 .
      	 reversip('!" . int2id 2 . cdr reversip cdr explode c))
   else
      intern compress(int2id 1 . nconc(explode c,{int2id 2}));
      
procedure lr_uncolor(c);
   if stringp c then
      compress('!" . reversip('!" . cddr reversip cddr explode c))
   else
      intern compress('!! . reversip cdr reversip cdr explode c);

procedure lr_setpchar!-psl(c);
   begin scalar w;
      w := lr_setpchar!-orig c;
      promptstring!* := lr_color promptstring!*;
      return lr_uncolor w
   end;

procedure lr_setpchar!-csl(c);
   lr_uncolor lr_setpchar!-orig lr_color c;

copyd('lr_setpchar!-orig,'setpchar);

if lr_pslp() then
   copyd('setpchar,'lr_setpchar!-psl)
else
   copyd('setpchar,'lr_setpchar!-csl);

procedure lr_yesp!-psl(u);
   begin scalar ifl,ofl,x,y;
      if ifl!* then <<
	 ifl := ifl!* := {car ifl!*,cadr ifl!*,curline!*};
	 rds nil
      >>;
      if ofl!* then <<
	 ofl:= ofl!*;
 	 wrs nil
      >>;
      if null !*lessspace then
 	 terpri();
      if atom u then
 	 prin2 u
      else
 	 lpri u;
      if null !*lessspace then
 	 terpri();
      y := setpchar "?";
      x := yesp1();
      setpchar y;
      if ofl then wrs cdr ofl;
      if ifl then rds cadr ifl;
      cursym!* := '!*semicol!*;
      return x
   end;

if lr_pslp() then <<
   remflag('(yesp),'lose);
   copyd('lr_yesp!-orig,'yesp);
   copyd('yesp,'lr_yesp!-psl);
   flag('(yesp),'lose)
>>;

% Color PSL prompts, in case user falls through:

!#if (memq 'psl lispsystem!*)

procedure lr_compute!-prompt!-string(count,level);
   lr_color lr_compute!-prompt!-string!-orig(count,level);

if lr_pslp() then <<
   copyd('lr_compute!-prompt!-string!-orig,'compute!-prompt!-string);
   copyd('compute!-prompt!-string,'lr_compute!-prompt!-string)
>>;
   
procedure lr_break_prompt();
   <<
      prin2 "break["; prin2 breaklevel!*; prin2 "]";
      promptstring!* := lr_color promptstring!*
   >>;

!#endif

if lr_pslp() then <<
   copyd('break_prompt,'lr_break_prompt);
   flag('(break_prompt),'lose);
>>;

if lr_pslp() then
   onoff('usermode,car lr_switches!-this!-sl!*);

onoff('msg,car lr_switches!*);
onoff('output,cadr lr_switches!*);

crbuf!* := nil;
inputbuflis!* := nil;
lessspace!* := t;
statcounter := 0;

off1 'msg;
off1 'output;
on1 'time;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/package.map0000755000175000017500000002673711526203062022620 0ustar  giovannigiovanni

% For a build-system implemented mostly in Lisp it can be
% read directly. When the build system uses scripts in some
% other notation a simple Lisp program can read this and re-print
% it in whatever form that other system requires, be that shell
% scripts, fragments of a Makefile or whatever.

% Each REDUCE package lines in a sub-directory of the "packages"
% directory. In many cases the name of this sub-directory is the same
% as the name of the package, but sometimes it makes sense to organise
% several packages in one directory or to use a sub-directory structure.
% The list here lists every REDUCE package and explicitly gives the
% location where its source files live.

% When REDUCE is built the first step is to create a "core" system that
% contains all those things needed to build later packages. In an ideal
% this core would be as small as possible, but it is also the case that
% the "core" represents the parts of REDUCE that are pre-loaded at the
% start of any run - and so for historical reasons the set of packages
% included in it give a system rather similar to a very very old version
% of the whole system.
% In this list, packages that are part of the core are tagged as such,
% and they appear in the list on the order they should be built in.

% Packages that are not tagged as "core" ought ideally to be independently
% builable using just the core system. At present this is not the case and
% while building some packages load others. But the list here is ordered
% so that no package should try to load anything that has not appeared
% earlier in the list.

% Many packages have a test script alongside their source. For a package
% called xxx the test script should be "xxx.tst" and a file "xxx.rlg"
% should be reference output from running it.

% In principle there could be modules that were only to be built on the
% CSL or only on the PSL version, and so I tag each with something that
% indicates which they are relevant for. But if you find a module which
% is NOT for use with both at least beware!

(
 (support       "support"     core                               psl)
 (rlisp         "rlisp"       core                           csl psl)
 (alg           "alg"         core      test                 csl psl)
 (poly          "poly"        core      test                 csl psl)
 (polydiv       "poly"        core      test                 csl psl)
 (arith         "arith"       core      test                 csl psl)
 (mathpr        "mathpr"      core                           csl psl)
 (ezgcd         "factor"      core                           csl psl)
 (factor        "factor"      core      test                 csl psl)
 (hephys        "hephys"      core                           csl psl)
 (int           "int"         core      test                 csl psl)
 (matrix        "matrix"      core      test                 csl psl)
 (rlisp88       "rlisp88"     core                           csl psl)
 (rprint        "rprint"      core                           csl psl)
 (fmprint       "rprint"      core                           csl psl)
 (pretty        "rprint"      core                           csl psl)
 (solve         "solve"       core      test                 csl psl)
 (desir         "solve"       core      test                 csl psl)
 (ineq          "solve"       core      test                 csl psl)
 (modsr         "solve"       core      test                 csl psl)
 (rsolve        "solve"       core      test                 csl psl)
 (algint        "algint"      core      test                 csl psl)
 (arnum         "arnum"       core      test                 csl psl)
 (assist        "assist"      core      test                 csl psl)
 (dummy         "assist"      core      test                 csl psl)
 (cantens       "assist"      core      test                 csl psl)
 (atensor       "atensor"     core      test                 csl psl)
 (avector       "avector"     core      test                 csl psl)
 (invbase       "invbase"     core      test                 csl psl)
 (misc          "misc"        core                           csl psl)
 (boolean       "misc"        core      test                 csl psl)
 (cedit         "misc"        core                           csl psl)
 (rcref         "misc"        core                           csl psl)
%(ftr           "misc"        core                           csl psl)
 (reset         "misc"        core                           csl psl)
 (cali          "cali"        core      test                 csl psl)
 (camal         "camal"       core      test                 csl psl)
 (changevr      "misc"        core      test                 csl psl)
 (compact       "misc"        core      test                 csl psl)
 (dfpart        "misc"        core      test                 csl psl)
 (lie           "misc"        core      test                 csl psl)
 (assert        "assert"                test                 csl psl)
 (odesolve      "odesolve"    noncore   test                 csl psl)
 (pf            "misc"                  test                 csl psl)
 (cvit          "hephys"                test                 csl psl)
 (noncom2       "hephys"                                     csl psl)
 (physop        "hephys"                test                 csl psl)
 (crack         "crack"                 test                 csl psl)
 (liepde        "crack"                 test                 csl psl)
 (applysym      "crack"                 test                 csl psl)
 (conlaw        "crack"                 test                 csl psl)
 (excalc        "excalc"                test                 csl psl)
 (gentran       "gentran"               test                 csl psl)
 (fide1         "fide"                                       csl psl)
 (fide          "fide"                  test                 csl psl)
 (numeric       "numeric"               test                 csl psl)
 (randpoly      "misc"                  test                 csl psl)
 (reacteqn      "misc"                  test                 csl psl)
 (roots         "roots"                 test                 csl psl)
 (rlfi          "misc"                  test                 csl psl)
 (roots2        "roots"                                      csl psl)
 (sets          "misc"                  test                 csl psl)
 (xideal        "xideal"                test                 csl psl)
 (eds           "eds"                   test                 csl psl)
 (dipoly        "dipoly"                                     csl psl)
 (groebner      "groebner"              test                 csl psl)
 (groebnr2      "groebner"                                   csl psl)
 (ideals        "groebner"              test                 csl psl)
 (linalg        "linalg"                test                 csl psl)
 (ncpoly        "ncpoly"                test                 csl psl)
 (normform      "normform"              test                 csl psl)
 (orthovec      "orthovec"              test                 csl psl)
 (plot          "plot"                                       csl psl)
 (gnuplot       "plot"                                       csl psl)
 (laplace       "laplace"               test                 csl psl)
 (pm            "pm"                    test                 csl psl)
 (qsum          "qsum"                  test                 csl psl)
 (scope         "scope"                 test                 csl psl)
 (sparse        "sparse"                test                 csl psl)
 (spde          "spde"                  test                 csl psl)
 (specfn        "specfn"                test                 csl psl)
 (specfn2       "specfn"                                     csl psl)
 (specfaux      "specfn"                                     csl psl)
 (specbess      "specfn"                                     csl psl)
 (sfgamma       "specfn"                                     csl psl)
 (tps           "tps"                   test                 csl psl)
 (limits        "misc"                  test                 csl psl)
 (defint        "defint"                test                 csl psl)
 (fps           "specfn"                test                 csl psl)
 (trigint       "trigint"               test                 csl psl)
 (ratint        "ratint"                test                 csl psl)
 (mathml        "mathml"                test                 csl psl)
 (mathmlom      "mathml"                test                 csl psl)
 (rltools       "redlog/rltools"                             csl psl)
 (redlog        "redlog/rl"             test                 csl psl)
 (cgb           "cgb"                   test                 csl psl)
 (cl            "redlog/cl"                                  csl psl)
 (ofsf          "redlog/ofsf"           test                 csl psl)
 (dvfsf         "redlog/dvfsf"                               csl psl)
 (acfsf         "redlog/acfsf"                               csl psl)
 (dcfsf         "redlog/dcfsf"                               csl psl)
 (geometry      "geometry"                                   csl psl)
 (ibalp         "redlog/ibalp"          test                 csl psl)
 (pasf          "redlog/pasf"           test                 csl psl)
 (qqe           "redlog/qqe"                                 csl psl)
 (qqe_ofsf      "redlog/qqe_ofsf"       test                 csl psl)
 (mri           "redlog/mri"                                 csl psl)
 (mri_ofsf      "redlog/mri"                                 csl psl)
 (mri_pasf      "redlog/mri"                                 csl psl)
 (redfront      "redfront"                                   csl psl)
 (reduce4       "reduce4"                                    csl psl)
 (tables        "reduce4"                                    csl psl)
 (talp          "redlog/talp"                                csl psl)
 (v3tools       "crack"                                      csl psl)
 (sum           "sum"                   test                 csl psl)
 (zeilberg      "sum"                   test                 csl psl)
 (symaux        "symmetry"                                   csl psl)
 (symmetry      "symmetry"              test                 csl psl)
 (taylor        "taylor"                test                 csl psl)
 (mrvlimit      "mrvlimit"              test                 csl psl)
 (residue       "residue"               test                 csl psl)
 (susy2         "susy2"                 test                 csl psl)
 (tri           "tri"                   test                 csl psl)
 (trigsimp      "trigsimp"              test                 csl psl)
 (xcolor        "xcolor"                test                 csl psl)
 (wu            "wu"                    test                 csl psl)
 (ztrans        "ztrans"                test                 csl psl)
 (geoprover     "geometry"              test                 csl psl)
 (rataprx       "rataprx"               test                 csl psl)
 (rtrace        "rtrace"                                     csl psl)
 (tmprint       "tmprint"                                    csl psl)
 (libreduce     "libreduce"                                  csl psl)
 (qepcad        "redlog/qepcad"                              csl psl)
 (utf8          "utf8"                                       csl psl)
 (lpdo          "lpdo"                  test                 csl psl)
 (mma           "redlog/mma"                                 csl psl)
 (guardian      "guardian"              test                 csl psl)
 (cdiff         "cdiff"                 test                 csl psl)
)

% End of configuration data
mathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/0000755000175000017500000000000011722677364022027 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/convert.red0000644000175000017500000001644411526203062024172 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%ammend the output of ratint, converting complex logs to real arctans, and
%providing alternative forms for the answer

% want a procedure to convert the log sum notation to a sum involving
% radicals. We typically get something like
%
%  log(x+1)+log_sum(alpha,alpha^2+alpha+1,0,alpha*log(alpha*2+x*alpha),x)
%
% as our output from the ratint program,
% and we want to sub alpha into the log expression and sum.
% other possibilies include transforming the logarithmic expression (which
% often contains complex logarithms, to real arctangents.
% This could be important if definite integration is the goal
% Example
% in symbolic mode, we have
%
%  exp: (log_sum alpha (plus (expt alpha 2) alpha 1) 0
%         (times (log (plus (times alpha x) 1)) alpha) x)

% need a procedure to get rid of parts of the expression not involving
% log_sum

algebraic <<
logcomplex:=
  {
    log(~x+i) =>
      log(sqrt(x^2+1))+i*atan((1/sqrt(x^2+1))+i*(x/(sqrt(x^2+1)))), %when
               %repart(x)=x,
    log(~x- i) =>
       log(sqrt(x^2+1))-i*atan(1/sqrt(x^2+1)+i*(x/(sqrt(x^2+1)))),
                %when repart(x)=x,
    log(~x+i*~y) =>
    log(sqrt(x*x+y*y))+i*atan(y/sqrt(x*x+y*y)+i*x/(sqrt(x*x+y*y))),% when
     %repart(x)=x and repart(y)=y,
    log(~x-i*~y) =>
     log(sqrt(x*x+y*y))-i*atan(y/(sqrt(x*x+y*y))+i*(x/(sqrt(x*x+y*y)))), % when
         % repart(x)=x and repart(y)=y,
     log(~x/~y) => log(x)-log(y), %when repart(y)=y,
     log(sqrt ~x) => (log x)/2,
     log(-1) => i*pi,
     log(-i) => -i*pi/2,
     log(i) => i*pi/2,
     log(-~x) => i*pi+log(x), % when repart(x)=x and numberp x and x>0,
     log(-i*~x) => -i*pi/2+log(x),
       %when repart(x)=x and numberp x and x>0,
   log(i*~x) => i*pi/2 +log(x) %when repart(x)=x and numberp x and x>0
   }$
 >>;

%algebraic let logcomplex;

 %letrules logcomplex

symbolic procedure evalplus(a,b);
if numberp a and numberp b then a+b
  else prepsq simp!* aeval {'plus,a,b};

procedure my_plus(a,b); lisp evalplus(a,b);

symbolic procedure evalmax(a,b);
  if numberp a and numberp b then max(a,b)
   else if evalgreaterp(a,b) then a else b;

procedure my_max(a,b); lisp evalmax(a,b);


%remove(log_sum(alpha,alpha^2+alpha+1,0,alpha*log(alpha*2+x*alpha))+log(1+x));

symbolic procedure convert(exp);
begin scalar temp,solution, answer;
if(freeof(exp,'log_sum)) then return exp else
<<
   if(null exp) then return nil else
   <<
      if(car exp='log_sum) then
      <<
        temp:=caddr exp;
        if(not freeof(temp,'beta)) then
        <<
        temp:=subeval(list (list('equal,'beta,'alpha), temp));
        exp:=subeval(list (list('equal,'beta,'alpha),exp));
        >>;
        temp:=reval temp; exp:=reval exp;
        %temp:=sub(beta=alpha,temp) % so temp now depends on alpha
        if(deg(temp,'alpha))>2 then
        << %write "degree of", reval exp, " is >2";
           rederr "cannot convert to radicals, degree > 2";
        >>
        else
         <<
         % temp is of the form alpha^2+alpha+1 or something similar

         if(deg(temp,'alpha)=2) then % solve the quadratic eqn, obtain
                                    % radicals, and substitute
            << %temp:=reval temp
               solution:= algebraic solve(temp=0,alpha);
               write reval cadr solution;
               %now have a solution list, with two elements

    answer:=subeval(list (reval cadr solution, algebraic reval part(exp,4)));
    answer:=list('plus, answer,subeval(list (reval caddr solution,
                        algebraic reval part(exp,4))));
    %answer:=car answer;
    answer:=reval answer;
             >>
          >>
        >>
       else <<
       if null cdr exp then return convert(car exp) else
      return convert (cdr exp);
            >>
    >>
 >>;
return answer;
end;

procedure conv(exp); lisp convert(exp);
%conv(log(x+1)+log_sum(alpha,alpha^2+alpha-1,0,alpha*log(alpha*x^2+alpha*x-1),x%));

% procedure to separate real and imaginary parts in a log sum expression
symbolic procedure separate_real(exp);
begin scalar re, im, ans;
    re:=algebraic repart(exp);
    im:=algebraic impart(exp);
   ans:= 'list.list(re,im);
   ans:=reval ans;
   return ans;
end;

procedure sep(exp); lisp separate_real(exp);

% input an expression with complex logs, output real arctangents
symbolic procedure convert_log(exp,var);
begin scalar sepp,re,im, answer;

algebraic repart(var):=var; algebraic impart(var):=0;
   if(car exp='log) then <<
        sepp:=separate_real(exp); %now have a list of re and im parts
                                   % can pass these to logtoatan function now
   re:=car exp; im:=cadr exp;
   answer:=logtotan1(re,im,var);
   return answer;
   >> else nil;
end;

procedure convertlog(exp,var); lisp convert_log(exp,var);

% now need an assume real facility, so extract terms dependent on i only
%
% This algorithm transforms some complex logarithmic expressions to real
% arctangents.
%
% the algorithm apppears in Manuel Bronsteins book Symbolic Integration I :
%  Transendental Functions, published by Springer Verlag, 1997
%
% Given a field K of characteristic 0 such that sqrt(-1) is not in K and A,
% B are in K[x] with B neq 0, this returns a sum f of real arctangents of
% polynomials in K[x] such that
%
%      df   = d         (A+i*B)
%      --     -- i* log ------
%      dx     dx        (A-i*B)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

algebraic;
expr procedure logtoAtan(exp1,exp2,x);
begin scalar D,C,G, temp, rem;
rem:=pseudorem(exp1,exp2,x);
if(part(rem,1)=0) then return (2*atan(exp1/exp2))
%if(numberp(exp1/exp2)) then return (2*atan(exp1/exp2))
 else <<
      if(deg(exp1,x)>;
      >>;
 end;

%log_sum(alpha,alpha^2+alpha+1,0,alpha*log(alpha*2+x*alpha),x);
%trst convert;
%conv(ws);
%conv(log_sum(beta,beta^2+beta-4,0,beta*log(beta*x^2+beta^2+1),x));

%------------------------------------------------------------------------------
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/ratint.red0000644000175000017500000005137011526203062024010 0ustar  giovannigiovanni
% -------------------------------------------------------------------------
% Neil Langmead
% ZIB Berlin, December 1996 / January 1997
%
% Package to integrate rational functions. Uses the Hermite Horowitz Rothstein
% Trager algorithms to determine firstly, the reduction of the rational fn
% into its polynomial and logarithmic parts, then the integration  of these
% parts seperately.


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

create!-package('(ratint convert),nil);

global '(traceratint!*); % for the tracing facility

switch traceratint;

off traceratint; % set to off by default

algebraic;

% We first need a few utility functions, given below
%
% -------------------------------------------------------------------------
% routine to return the square free factorisation of a polynomial
% outputs factors in a list, coupled with their exponents.
% However, such a function is already defined in poly/facform.

% expr procedure square_free(poly,x);
% begin  scalar  !*EXP, !*FACTOR, !*DIV, !*RATARG, !*GCD, !*RATIONAL,
% l,k,c,w,z,y,output, answer, result;
% on exp; on div; on ratarg; off factor; on rational;
% k:=1; output:={}; answer:= df(poly,x);
% poly:=poly;
% c:=gcd(poly,answer);
% w:=poly/c;
% while (c neq 1) do
%        <<
%          y:=gcd(w,c);
%          z:=w/y;
%          if (z neq 1) then
%           output:=append({{z,k}},output);
%           k:=k+1;
%           w:=y; c:=c/y;
%         >>;
% output:=append({{w,k}},output);
% return output;
% end;

% expr procedure eval_square_free(list,var);
% begin scalar output;
% off exp;
% output:= for l:=1:arglength(list)
% product(part(part(list,l),1)^(part(part(list,l),2)));
% return output;
% end;

expr procedure make_mon(li,var);

begin scalar current, li2;
li2:={};
for k:=1:arglength(li) do
  <<
    current:=part(li,k);
    current:=monic(current,var);
    li2:=append(li2,{current});
   >>;
return(li2);
end;

expr procedure monic(exp,var);
begin scalar lecof, temp;
lecof:=lcof(exp,var);
exp:=exp/lecof;
return exp;
end;
%x^8-2*x^6+2*x^2-1;
%z:=square_free(x^8-2*x^6+2*x^2-1,x);
%res:= for l:=1:2 product(part(part(z,l),1)^(part(part(z,l),2)));

% -------------------------------------------------------------------------
% An implementation of the extended Eucledian algorithm. Given polynomials
% a and b in the variable x in a Euclidean domain D, this computes elements
% s and t in D such that g:=gcd(a,b)=sa+tb

%off factor;
% input is polynomials a and b, in variable var
on rational;
%expr procedure ratint_u(exp,var);
%lcof(exp,var);

expr procedure norm(exp,var);
exp/lcof(exp,var);

expr procedure gcd_ex(a,b,var);
begin scalar c, c1, c2,d,d1,d2,q,r,m,r1,r2,g,s,b;
on rational;
c:=norm(a,var); d:=norm(b,var);
c1:=1; d1:=0; c2:=0; d2:=1;

while(d neq 0) do
  <<
    on rational;
    m:=pseudorem(c,d,var);
    q:=part(pseudorem(c,d,var),3)/part(pseudorem(c,d,var),2);
    %q:=part(pf(c/d,var),1); q should be quo(c,d)
    %off rational;
    r:=c-q*d;
    %r:=part(m,1);
    r1:=c1-q*d1; r2:=c2-q*d2;
    c:=d; c1:=d1; c2:=d2;
    d:=r; d1:=r1; d2:=r2;
  >>;
s:=c1/(ratint_u(a,var)*ratint_u(c,var));
b:=c2/(ratint_u(b,var)*ratint_u(c,var));
return({s,b});
end;

expr procedure ratint_u(exp,var);
if(numberp(exp)) then exp else
lcof(exp,var);

%l:=3*x^3+x^2+x+5;% p:=5*x^2-3*x+1
%pseudorem(l,p,x);
%quote:=part(pseudorem(o,p,x),3)/part(pseudorem(o,p,x),2);
%gcd_ex(x^2-1,x+1,x);
%a:=x^2+(7/6)*x+(1/3); b:=2*x+(7/6);
%gcd_ex(a,b,x);
%f:=48*x^3-84*x^2+42*x-36; g:=-4*x^3-10*x^2+44*x-30;
%gcd_ex(f,g,x);

% -------------------------------------------------------------------------
% routine to remove elements from a list which are zero

expr procedure rem_zero(li);
begin scalar k,j,l,li1,li2;
for k:=1:arglength(li) do
   <<
     j:=part(li,k);
     if(j neq 0) then nil else
       <<
         li1:=for l:=1:k-1 collect part(li,l);
         li2:=for l:=k+1:arglength(li) collect part(li,l);
         li:=append(li1,li2);
       >>;
   >>;
return li;
end;

% --------------------------------------------------------------------------
% This routine takes as input a rational function p/q^(expt), returning p, q
% and expt seperately in a list

expr procedure hr_monic_den(li,x);
begin scalar !*EXP, !*FACTOR, q, lc;
on EXP;
li:= (for each r in li collect << lc:=lcof(den(r),x);
                                  {num(r)/lc, den(r)/lc} >> );
on FACTOR;
li:= (for each r in li collect
     <<  q:=part(r,2);
         if(arglength(q) > -1 and part(q,0)=expt) then
         {part(r,1),part(q,1),part(q,2)} else
         {part(r,1),part(q,1),1} >> ) ; return li;
end;

%q:={3/(x+3)^2,4/(x+1)^5};
%hr_monic_den(q,x);
%in "monic";

% -------------------------------------------------------------------------
% The implementation of the Rostein Trager algorithm
% Takes as input a/b in x, and returns a two element list, with the polynomial
% and logarithmic parts of the integral. For aesthetic reasons in REDUCE, the
% values aren't added. This should be done manually by the user, but is a
% trivial task.
% in "mkmonic.red";
operator c, rtof,v, alpha;
load_package arnum;

load_package assist;

expr procedure not_numberp(x);
if (not numberp(x)) then t else nil;

expr procedure rt(a,b,x);
begin scalar vv, j,k,i,current,sol,res,cc,b_prime,extra_term,
      current1,vvv,integral, eqn,d,v_list, sol1,sol2, temp, temp2;
b_prime:=df(b,x);
v_list:={};
on rational;
res:=resultant(a-z*b_prime,b,x);
on rational; on ifactor;
res:= old_factorize(res);
res:=extractlist(res, not_numberp);
res:=make_mon(res,z);
res:=mkset(res); % removes duplicates by turning list into a set
%write "res is ", res;

integral:=0;

for k:=1:arglength(res) do
<<
  current:=part(res,k);% write "current is ", current;
  d:=deg(current,z); %write "d is ", d;
  if(d=1) then
    <<
      sol:=solve(current=0,z);
      sol:=part(sol,1);
      cc:=part(sol,2);% write "cc is ", cc;
      vv:=gcd(a-cc*b_prime,b);% write "vv is " , vv;
      vv:=vv/(lcof(vv,x));
      extra_term:=append({cc},{log(vv)});% write extra_term;
      extra_term:=part(extra_term,1)*part(extra_term,2); %write extra_term;
      integral:=extra_term+integral; %write "integral is ", integral;
    >>
   else
    <<
      current:=sub(z=alpha,current);% write "current is ", current;
      current1:=sub(alpha=alp,current);% write "current1 is ", current1;
      defpoly(current);
      %write "alpha is ", alpha;
      a:=sub(x=z,a); b:=sub(x=z,b); b_prime:=sub(x=z,b_prime);
      vv:=gcd(a-alpha*b_prime,b);% write "vv is ", vv; % OK up to here

      off arnum;
      on fullroots;
      vv:=sub(a1=alpha*8,vv);
      vv:=sub(z=x,vv);
      vvv:=solve(vv=0,x);
      vvv:=sub(a1=1/alp,vvv);% write "vvv is ", vvv;
      eqn:=part(part(vvv,1),1)-part(part(vvv,1),2);
      %write "eqn is ", eqn;
      if(d=2) then
         <<
             sol:=solve(current1=0,alp);
             sol1:=part(sol,1); sol2:=part(sol,2);
             %write "sol1, 2 are ", sol1, sol2;
             c(1):=part(sol1,2); c(2):=part(sol2,2);
             %write "c(1), c(2) are ", c(1), c(2);
             for j:=1:2 do
             <<
               v(j):=sub(alp=c(j),eqn);
               integral:=integral+c(j)*log(v(j));
               %write "integral is ", integral;
             >>;
           >>
       else
        <<
           k:=1;
           %write "d is ", d;
           while (k<=d) do
           %for k:=1:3 do
           <<
              c(k):=rtof(current1);% write "c(k) is ", c(k);
              v(k):=sub({alp=c(k)},eqn);% write "v(k) is ", v(k);
              integral:=integral+c(k)*log(v(k));
              %write "integral is ", integral;
              k:=k+1;
           >>;
        >>;
    >>;
lisp null remprop ('alpha,'currep);
lisp null remprop ('alpha,'idvalfn);
>>;
return(integral);
end;

% -------------------------------------------------------------------------
% This piece of code was written by Matt Rebeck. Input are the functions
% p, q and variable x. It returns the pseudo remainder of p and q, and the
% quotient.

symbolic procedure prem(r,v,var);
  begin
    scalar d,dr,dv,l,n,tt,rule_list,m,q,input1,input2,rr,vv;
    on rational; off factor;
    rr := r;
    vv := v;
    dr := deg(r,var);
    dv := deg(v,var);
    if dv <= dr then
    <<
      l := reval coeffn(v,var,dv);
      v := reval{'plus,v,{'minus,{'times,l,{'expt,var,dv}}}};
    >>
    else l := 1;
    d := dr-dv+1;
    n := 0;
    while dv<=dr and r neq 0 do
    <<
      tt := reval{'times,{'expt,var,(dr-dv)},v,coeffn(r,var,dr)};
      if dr = 0 then r := 0
      else
      <<
        rule_list := {'expt,var,dr}=>0;
        let rule_list;
        r := reval r;
        clearrules rule_list;
      >>;
      r := reval{'plus,{'times,l,r},{'minus,tt}};
      dr := deg(r,var);
      n := n+1;
    >>;
    r := reval{'times,{'expt,l,(d-n)},r};
    m := reval{'expt,l,d};
    input1 := reval{'plus,{'times,{'expt,l,d},rr},{'minus,r}};
    input2 := vv;
    q := reval{'quotient,input1,input2};
    return {r,m,q};
  end;

procedure pseudorem(x,y,var); lisp ('list . prem(x,y,var));
%e.g.
 %pseudorem(3x^5+4,x^2+1,x);
%exp1:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;
%exp2:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;
%pseudorem(exp1,exp2,x);
%a:=x^8+x^6-3*x^4-3*x^3+8*x^2+2*x-5;
%b:=3*x^6+5*x^4-4*x^2-9*x+21;
%pseudorem(a,b,x);
%r:=-15*x^4+3*x^2-9;
%rr:=
%operator a,c, neil;
%in "rem";

% -------------------------------------------------------------------------
% this routine is the implementation of Horowitz' method of reducing the
% rational function into a polynomial and logarithmic part.

operator a,c, neil ;
expr procedure howy(p,q,x);

begin
scalar pseudo, quo,rem,pp, poly_part,d,mm,b,nn,j,k,aa,cc,
pseudo3,i,quo3,r,pseudo2,eqn,l,neil1,sol, var1, temp,var2,var3,p,test,output;
pseudo:=pseudorem(p,q,x);
quo:=part(pseudo,3)/part(pseudo,2);
rem:=part(pseudo,1)/part(pseudo,2);

poly_part:=quo;
pp:=rem;% write "pp is ", pp;
d:=gcd(q,df(q,x));
pseudo2:=pseudorem(q,d,x);
b:=part(pseudo2,3)/part(pseudo2,2);

mm:=deg(b,x);
nn:=deg(d,x);

aa:=for k:=0:(mm-1) sum (a(k))*(x^(k));
cc:=for j:=0:(nn-1) sum (c(j))*(x^(j));

var1:=for i:=0:(mm-1) collect a(i);
var2:=for k:=0:(nn-1) collect c(k);
var3:=append(var1,var2);
%write var3;
on rational;
pseudo3:=pseudorem(b*df(d,x),d,x);
quo3:=part(pseudo3,3)/part(pseudo3,2);

temp:=b*df(d,x)/d;

temp:=pseudorem(num(temp),den(temp),x);
temp:=part(temp,3)/part(temp,2);
%write "temp is ", temp;
r:=b*df(cc,x)-cc*temp+d*aa;% write "r is: ", r;

for k:=0:(mm+nn-1) do
     <<
       %on factor;
       neil(k):=coeffn(pp,x,k)-coeffn(r,x,k);
       %write "neil(k)= ", neil(k);
     >>;

neil1:=for k:=0:(mm+nn-1) collect neil(k)=0;
%write "neil1= ", neil1;

sol:=solve(neil1,var3);% write "sol= ", sol;
sol:=first(sol);% write "sol= ", sol;
aa:=sub(sol,aa);
%write "aa= ", aa;
%aa:=for k:=1:mm sum(part(sol,k));
cc:=sub(sol,cc);% write "cc is ", cc;
ans1:=cc/d;
ans2:=int(poly_part,x);
ans3:=(aa/b);
output:={ans1,ans2,ans3};
return output;
end;

% -------------------------------------------------------------------------
%in "eea"; in "rem"; in "phi";

expr procedure newton(a,p,u1,w1,B);
begin scalar alpha,gamma,eea_result,s,tt,u,w,ef,modulus,c,sigma,
sigma_tilde,tau, tau_tilde,re,r,quo;

alpha:=lcof(a,x);
a:=alpha*a;
gamma:=alpha;
%a:=gamma*a;

%u1:=n(u1,x);
u1:=ratint_phi(u1,x,p); write "u1 is ", u1;

off modular;
w1:=ratint_phi(alpha*w1,x,p); off modular;% write "w1 is ", w1;
%w1:=ratint_phi(alpha*w1,x,p); off modular;% write "w1 is ",w1;

eea_result:=gcd_ex(u1,w1,x);

on modular; setmod p;
s:=part(eea_result,1);   tt:=part(eea_result,2);


on modular; setmod p;
u:=replace_lc(u1,x,gamma);   w:=replace_lc(w1,x,alpha);

off modular;
ef:=a-u*w; off modular;  modulus:=p;
%write "ef is ", ef; write "u,w are  ", u,w;
% iterate until either the factorisation in Z[x] is obtained, or else
% the bound on modulus is reached

on modular; setmod p;
while(ef neq 0 and modulus<2*B*gamma) do
    <<

       c:=ef/modulus;% write "c is ", c; off modular;
      sigma_tilde:=ratint_phi(s*c,x,p); off modular;
      tau_tilde:=ratint_phi(tt*c,x,p); off modular;
      %
       re:=pseudorem(sigma_tilde,w1,x);

      r:=part(re,1)/part(re,2); quo:=part(re,3)/part(re,2);
     sigma:=re; tau:=ratint_phi(tau_tilde+quo*u1,x,p); off modular;
      % update the factors and compute the error
      u:=u+tau*modulus;  w:=w+sigma*modulus;
     % write "u is ",u; write "w is ",w; write "ef is ", ef;
      ef:=a-u*w; modulus:=modulus*p;
   >>;

% check termination status
        if(ef=0) then << u:=u; w:=w/gamma;   >>
                          else rederr "nsfe";
return {u,w};
end;

%trst newton;
 %newton(12*x^3+10*x^2-36*x+35,5,x,x^2+3,10000);
% in "phi.red";
% in "eea.red"; in "rem.red"; %in "replace_lc";
clear p;
%trst newton;trst newton;
%newton(12*x^3+10*x^2-36*x+35,5,2*x,x^2+2,10000)

% -------------------------------------------------------------------------
expr procedure replace_lc(exp,var,val);
begin scalar lead_term, new_lead_term,red;
lead_term:=lterm(exp,var);
red:=reduct(exp,var);
new_lead_term:=lead_term/lcof(exp,var);
new_lead_term:=new_lead_term*val;
new_exp:=new_lead_term+red;

return new_exp;
end;

% -------------------------------------------------------------------------
% in "rem"; in "eea";
% routine to solve the polynomial diophantine equation
% s(x)a(x)+t(x)b(x)=c(x) for the unknown polynomials s and t

expr procedure polydi(a,b,c,x);
begin scalar q,r, sigma,tau, s,tt,sol,sigma_tilde,tau_tilde,g;
on rational;
g:=gcd(a,b);

s:=part(gcd_ex(a,b,x),1);
tt:=part(gcd_ex(a,b,x),2);
sol:=(s*c/g)*a+(tt*c/g)*b;
% here, sol=c(x), our right hand side

sigma_tilde:=s*c/g;
tau_tilde:=tt*c/g;

result:=pseudorem(sigma_tilde,b/g,x);
q:=part(result,3)/part(result,2);
r:=part(result,1)/part(result,2);

sigma:=r;
tau:=tau_tilde+(q*(a/g));

return {sigma,tau};
end;
%in "rem"; in "eea";
%trst polydi;
%polydi(x+(7/3),1,294,x);
%polydi(x^2+(7/6)*x+(1/3),2*x+(7/6),-(4425/2)*x-(5525/4),x);

% -------------------------------------------------------------------------
expr procedure ratint_phi(exp,var,p);
 begin scalar prime;
 prime:=p;
 if(primep p) then << on modular;
                      setmod p;
                      exp:=exp mod p;% off modular;
                   >> else rederr "p should be prime";
 return exp;
 end;


expr procedure nn(exp,var,p);
 begin scalar lcoef;
 lcoef:=lcof(exp,var);
 if(primep p) then <<   on modular; setmod p;
                        exp:=exp/lcoef;

                  >> else rederr "p should be prime";

return exp;
 end;
off modular;
%in "ratint" %in "examples"
%in "make_monic"
%operator c, rtof,v, alpha;
load_package arnum;

%load_package assist

expr procedure not_numberp(x);
if (not numberp(x)) then t else nil;

operator log_sum;
expr procedure rt(a,b,x);
begin scalar vv, j,k,i,current,sol,res,cc,b_prime,extra_term,
      current1,vvv,integral, eqn,d,v_list, sol1,sol2, temp, temp2;
b_prime:=df(b,x);
v_list:={};
on rational;
res:=resultant(a-z*b_prime,b,x);
on rational; on ifactor;
res:= old_factorize(res);
res:=extractlist(res, not_numberp);
res:=make_mon(res,z);
res:=mkset(res); % removes duplicates by turning list into a set
%write "res is ", res;

integral:=0;

for k:=1:arglength(res) do
<<
  current:=part(res,k); %write "current is ", current;
  d:=deg(current,z); %write "d is ", d;
  if(d=1) then
    <<
      sol:=solve(current=0,z);
      sol:=part(sol,1);
      cc:=part(sol,2);% write "cc is ", cc;
      vv:=gcd(a-cc*b_prime,b);% write "vv is " , vv;
      vv:=vv/(lcof(vv,x));
      extra_term:=append({cc},{log(vv)});% write extra_term;
      extra_term:=part(extra_term,1)*part(extra_term,2);%write extra_term;
      integral:=extra_term+integral; %write "integral is ", integral
  if(lisp !*traceratint) then write "integral in Rothstein T is ", integral;
    >>
   else
    <<
      current:=sub(z=alpha,current);% write "current is ", current;
      current1:=sub(alpha=alp,current);% write "current1 is ", current1;
      off mcd; current:=current;
      defpoly(current);
      on mcd;
      %write "alpha is ", alpha; %write part(alpha,1);
      a:=sub(x=z,a); b:=sub(x=z,b); b_prime:=sub(x=z,b_prime);
      vv:=gcd(a-alpha*b_prime,b); % write "vv is ", vv; % OK up to here
      off arnum;
      on fullroots;
      %vv:=sub(a1=alpha*(1/part(alpha,1)),vv);
      vv:=sub(z=x,vv); % vv:=sub(a1=part(alpha,1)*alpha,vv);
      %write "vv is ", vv;
      %write "deg is ", deg(vv,x);
      on rational; on ratarg;
      % write "deg is ", deg(vv,x);
      if(deg(vv,x)>2) then
<<
% we want to give the answer not in terms of a complete pf decomposition,
% but without splitting the field

integral:=integral+log_sum(alpha_a,current1,0,alpha_a*log(vv),x);
integral:=sub(alpha_a=alpha,integral);
%integral:=sub(a1=part(alpha,1)*alpha,integral)
integral:=sub(alp=alpha,integral);
if(lisp !*traceratint) then write "integral in Rothstein T is ", integral;
>>
else % degree less than or eq to 2, so no problem solving vv=0
<<
      % write "current is ", current;
      current:=sub(alpha=beta,current);
      vv:=sub(alpha=beta,vv);
      integral:=integral+log_sum(beta,current,0,beta*log(vv));
      % vvv:=solve(vv=0,x);
      %vvv:=sub(a1=1/alp,vvv); write "vvv is ", vvv;
      %eqn:=part(part(vvv,1),1)-part(part(vvv,1),2);
      %write "eqn is ", eqn;
      if(d=2) then
         <<
             sol:=solve(current1=0,alp);
             sol1:=part(sol,1); sol2:=part(sol,2);
             %write "sol1, 2 are ", sol1, sol2;
             c(1):=part(sol1,2); c(2):=part(sol2,2);
             %write "c(1), c(2) are ", c(1), c(2)
             for j:=1:2 do
             <<
               v(j):=sub(alp=c(j),eqn);
               %integral:=integral+c(j)*log(v(j));
               % write "integral is ", integral;
             >>;
           >>
       else
        <<
           k:=1;
           %write "d is ", d;
           while (k<=d) do
           %for k:=1:3 do
           <<
              c(k):=rtof(current1); % write "c(k) is ", c(k);
              v(k):=sub({alp=c(k)},eqn); % write "v(k) is ", v(k);
              %integral:=integral+c(k)*log(v(k));
              %write "integral is ", integral;
              k:=k+1;
           >>;
        >>;
    >>;
>>;
lisp null remprop ('alpha,'currep);
lisp null remprop ('alpha,'idvalfn);
>>;
return(integral);
end;

expr procedure dependp(exp,x);

  if(freeof(exp,x) and not numberp(exp)) then nil else t ;
% -------------------------------------------------------------------------
% procedure to integrate any rational function, using the implementations of
% the above algorithms.

expr procedure ratint(p,q,x);
begin scalar s_list,first_term, second_term, r_part, answer;
% check input carefully

if(not dependp(p,x) and not dependp(q,x)) then
   return (p/q)*x
else <<
   if(not dependp(p,x) and dependp(q,x)) then return
      p*ratint(1,q,x)
 else <<
   if( dependp(p,x) and not dependp(q,x)) then return
       (1/q)*int(p,x);
      >>;
     >>;
if(numberp p and numberp q) then return (p/q)*x;
%if(not polynomp p or not polynomp q) then rederr "input must be polynomials"
if(lisp !*traceratint) then write "performing Howoritz reduction on ", p/q;
s_list:=howy(p,q,x);
if(lisp !*traceratint) then write "Howoritz gives: ", s_list;
first_term:=part(s_list,1);
second_term:=part(s_list,2);
r_part:=part(s_list,3);% write "r_part is ", r_part;
if(lisp !*traceratint) then write "computing Rothstein Trager on ", r_part;
r_part:=rt(num(r_part),den(r_part),x);
answer:={first_term+second_term,r_part};
return (answer);
end;

% examples

%exp1:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;

%exp2:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;

%k:=36*x^6+126*x^5+183*x^4+(13807/6)*x^3-407*x^2-(3242/5)*x+(3044/15);
%l:=(x^2+(7/6)*x+(1/3))^2*(x-(2/5))^3;

%ratint(k,l,x);

%aa:=7*x^13+10*x^8+4*x^7-7*x^6-4*x^3-4*x^2+3*x+3;
%bb:=x^14-2*x^8-2*x^7-2*x^4-4*x^3-x^2+2*x+1;
%trst ratint;
%ratint(aa,bb,x);
%-----------------------------------------------------------------------------

end;


















mathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/ratint.tst0000644000175000017500000000143411526203062024044 0ustar  giovannigiovanni
exp1:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;

exp2:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;

aa:=7*x^13+10*x^8+4*x^7-7*x^6-4*x^3-4*x^2+3*x+3;
bb:=x^14-2*x^8-2*x^7-2*x^4-4*x^3-x^2+2*x+1;

% example 2.14

a:=48*x^3-84*x^2+42*x-36;

b:=-4*x^3-10*x^2+44*x-30;


% square free ex

c:=x^8-2*x^6+2*x^2-1;

%square_free(a,x);

%eval_sq_free(ws,x);


% hr example

pu:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;

qu:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;

%makemon(p,q,x);

%pf(pu/qu,x);
%trst hr;


k:=36*x^6+126*x^5+183*x^4+(13807/6)*x^3-407*x^2-(3242/5)*x+(3044/15);
l:=(x^2+(7/6)*x+(1/3))^2*(x-(2/5))^3;
%trst hr;

ratint(k,l,x);

ratint(exp1,exp2,x);

ratint(1,x^2,x);

ratint(1,x^2+1,x);

ratint(1,x^3+x+1,x);

ratint(1,x^5+1,x);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/ratint.tex0000644000175000017500000004011511526203062024031 0ustar  giovannigiovanni
\documentstyle[11pt,reduce,fancyheadings]{article}
\title{
A Package to Integrate Rational Functions using the Minimal Algebraic
Extension to the Constant Field
}
\author{Neil Langmead \\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik (ZIB) \\ 
        Takustrasse 7  \\
        D- 14195 Berlin Dahlem \\
        Berlin
        Germany}
\date{January 1997}

\def\foottitle{Rational Integration in \small{REDUCE}}
\pagestyle{fancy}
\lhead[]{{\footnotesize\leftmark}{}}
\rhead[]{\thepage}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\addtolength{\oddsidemargin}{-20 mm}
\addtolength{\textwidth}{25 mm}
\pagestyle{fancy}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\setlength{\topmargin}{1 mm}
\setlength{\footskip}{10 mm}
\setlength{\textheight}{220 mm}
\cfoot{}
\rfoot{\small\foottitle}

\def\exprlist   {exp$_{1}$,exp$_{2}$, \ldots ,exp$_{{\tt n}}$}
\def\lineqlist  {lin\_eqn$_{1}$,lin\_eqn$_{2}$, \ldots ,lin\_eqn$_{n}$}
\pagestyle{fancy}
\begin{document}
\maketitle{
\begin{center} \Large Package to Integrate Rational Functions using the minimal algebraic extension to the constant field \end{center}}

\pagebreak
\tableofcontents
\pagebreak
\section{Rational Integration}
\normalsize
This package implements the Horowitz/ Rothstein/ Trager algorithms ~\cite{Ged92} for the integration of rational functions in \small{REDUCE}.\normalsize We work within a field $K$ of characteristic $0$ and functions $p,q \in K[x]$. $K$ is normally the field $Q$ of rational numbers, but not always. These procedures return $\int \frac{p}{q} dx.$
 The aim is to be able to integrate any function of the form $p/q$ in $x$, where $p$ and $q$ are polynomials in the field $Q$. The algorithms used avoid algebraic number extensions wherever possible, and in general, express the integral using the minimal algebraic extension field. \\

\subsection{Syntax of $ratint$}
This function has the following syntax:
\begin{center} \bf{ratint(p,q,var)} \end{center}
where $ p/q$ is a rational function in $var$. The output of $ratint$ is a list of two elements: the first is the polynomial part of the integral, the second is the logarithmic part. The integral is the sum of these parts.
\subsection{Examples}
consider the following examples in \small{REDUCE}:
\begin{verbatim}
ratint(1,x^2-2,x);

                sqrt(2)*x-2          sqrt(2)*x+2
           log(-------------) - log(-------------)
                  sqrt(2)              sqrt(2)
{ 0,        ---------------------------------------    }
                          2*sqrt(2)
   

p:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x
                                                       +24500;

q:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;

ratint(p,q,x);

   
    49   6  226  5   268  4   1332  3   2809  2   752     256
   ---*(x + ---*x  - ---*x  + ----*x  - ----*x  - ---*x + ---)
    2       147      49        49       147       21       9
 {-----------------------------------------------------------      , 0  }
              4    2   3      2          7
             x  - ---*x  - 4*x  + 6*x - ---
                   3                     3

    

k:=36*x^6+126*x^5+183*x^4+(13807/6)*x^3-407*x^2-(3242/5)*x+(3044/15);
l:=(x^2+(7/6)*x+(1/3))^2*(x-(2/5))^3;

ratint(k,l,x);


   5271    3    39547   2    31018       7142
  ------*(x  + -------*x  - -------*x + -------)
    5           52710        26355       26355
{------------------------------------------------,
       4    11   3    11   2    2        4
      x  + ----*x  - ----*x  - ----*x + ----
            30        25        25       75

  37451            2      91125           2      128000           1
 -------*(log(x - ---) + -------*log(x + ---) - --------*log(x + ---))}
   16              5      37451           3      37451            2



ratint(1,x^2+1,x);

                    2    1
{0,log_sum(beta,beta  + ---,0,log(2*beta*x - 1)*beta)}
                         4

\end{verbatim}

The meaning of the log\_sum function will be explained later.
\pagebreak
\section{The Algorithm}
The following main algorithm is used:

procedure $ratint(p,q,x);$

% p and q are polynomials in $x$, with coefficients in the %constant field Q

    solution\_list $\leftarrow HorowitzReduction(p,q,x)$ 
 \\
    $c/d \leftarrow$ part(solution\_list,1)\\  
    $poly\_part \leftarrow$ part(solution\_list,2)
  \\
    $rat\_part \leftarrow$ part(solution\_list,3)
\\
    $rat\_part \leftarrow LogarithmicPartIntegral(rat\_part,x) $
\\
 return($rat\_part+c/d +poly\_part$)
\\
end

The algorithm contains two subroutines, $HorowitzReduction$ and $rt$. $HorowitzReduction$ is an implementation of Horowitz' method to reduce a given rational function into a polynomial part and a logarithmic part. The integration of the polynomial part is a trivial task, and is done by the $int$ operator in \small{REDUCE}. The integration of the logarithmic part is done by the routine $rt$, which is an impementation of the Rothstein and Trager method. These two answers are outputed in a list, the complete answer being the sum of these two parts.
\\
These two algorithms are as follows:

procedure $how(p,q,x)$

for a given rational function $p/q$ in $x$, this algorithm calculates the
reduction of $ \int(p/q)$ into a polynomial part and logarithmic part. \\

$ poly\_part \leftarrow quo(p,q); \hspace{3 mm}  p \leftarrow rem(p,q)$;

$d \leftarrow GCD(q,q') $; \hspace{3 mm}    $b \leftarrow quo(q,d)$; \hspace{3 mm}
$m \leftarrow deg(b)$; \\  $n \leftarrow deg(d)$;

$a \leftarrow  \sum_{i=1}^{m-1} a_{i}x^{i}$; \hspace{3 mm}
   $ c \leftarrow \sum_{i=1}^{n-1} c_{i}x^{i}$; \\ 

$r \leftarrow b*c'-quo(b*d',d)+d*a; $\\
\begin{tabbing}
for $i$ from \= $0$ \=  to $m+n-1$ do \\
\> \{ \\
\> \>   $  eqns(i) \leftarrow coeff(p,i)=coeff(r,i)$; \\
\> \};
\end{tabbing}

$solve(eqns,\{a(0),....,a(m-1),c(0),....,c(n-1)\});$

return($c/d+\int poly\_part + \int a/b$);
\\
end;
\newpage
procedure RothsteinTrager($a,b,x$)

\% Given a rational function $a/b$ in $x$ with $deg(a) \{ \\
\> \> $ d  \leftarrow degree(r_{i}(z))$ \\
\> \> if $d=1$ then \= \\
\> \> \> \{ \\
\> \> \> c $\leftarrow solve(r_{i}(z)=0,z)$ \\
\> \> \> v $\leftarrow GCD(a-cb',b)$\\
\> \> \> v $\leftarrow v/lcoeff(v) $\\

\> \> \> $integral \leftarrow integral+c*log(v)$ \\
\> \> \> \}\\

\> \> else \= \{ \\
\> \> \> \%  we need to do a GCD over algebraic number field\\
\> \> \> v $\leftarrow GCD(a-\alpha*b',b)  $ \\
\> \> \> v $\leftarrow v/lcoff(v) $, \hspace{3 mm}
 where $\alpha=roof\_of(r_{i}(z)) $\\ 
\> \> if d=2 then \= \{ \\
\> \> \> \% give answer in terms of radicals  \\
\> \> \> c $\leftarrow solve(r_{i}(z)=0,z) $ \\
\> \> \> for j from 1 to 2 do \= \{ \\
\> \> \> $v[j] \leftarrow substitute(\alpha=c[j],v) $ \\
\> \> \> $integral \leftarrow integral+c[j]*log(v[j]) $ \\
% \> \> \> \> \> \} \\
\> \> \> \} \\
\> \> \> else \= \{ \\
\> \> \> \% Need answer in terms of root\_of notation \\
\> \> \> for j from 1 to d do \= \{ \\
\> \> \>  v[j] $\leftarrow substitute(\alpha=c[j],v) $ \\
\> \> \> integral $ \leftarrow integral+c[j]*log(v[j]) $ \\
\> \> \> \% where $c[j]=root\_of(r_{i}(z))$ \} \\
% \> \> \> \> \> \> \} \\
\> \> \> \} \\
\> \> \} \\
\> \} \\
return(integral) \\
end
\end{tabbing}
\pagebreak
\section{The log\_sum operator}
The algorithms above returns a sum of terms of the form
\[ \sum_{\alpha \mid R(\alpha)=0} \log(S(\alpha,x)), \]

where $R \in K[z]$ is square free, and $S \in K[z,x]$. In the cases where the degree of $R(\alpha)$ is less than two, this is merely a sum of logarithms. For cases where the degree is two or more, I have chosen to adopt this notation as the answer to the original problem of integrating the rational function. For example,
consider the integral
 \[ \int \frac{a}{b}=\int \frac{2x^5-19x^4+60x^3-159+x^2+50x+11}{x^6-13x^5+58x^4-85x^3-66x^2-17x+1}\, dx \]
Calculating the resultant $R(z)=res_x(a-zb',b)$ and factorising gives
  \[ R(z)=-190107645728000(z^3-z^2+z+1)^{2} \]
Making the result monic, we have
\[ R_2(z)=z^3-z^2+z+1 \]
which does not split over the constant field $Q$.
Continuting with the Rothstein Trager algorithm, we now calculate 
\[ gcd(a-\alpha\,b',b)=z^2+(2*\alpha-5)*z+\alpha^2, \] where $\alpha$ is a root of $R_2(z)$. \\
Thus we can write
\[ \int \frac{a}{b}= \sum_{\alpha \mid \alpha^3-\alpha^2+\alpha+1=0} \alpha*\log(x^2+2\alpha x-5x+\alpha^2), \]

and this is the answer now returned by \small{REDUCE}, via a function called $log\_sum$. This has the following syntax:
\begin{center}$ log\_sum(\alpha,eqn(\alpha),0,sum\_term,var)$ \end{center}
where $\alpha$ satisfies $eqn=0$, and $sum\_term$ is the term of the summation in the variable $var$. Thus in the above example, we have
\[ \int \frac{a}{b}\,dx= log\_sum(\alpha,\alpha^3-\alpha^2+\alpha+1,0,\alpha*\log(x^2+2\alpha x-5x+\alpha^2),x) \]

Many rational functions that could not be integrated by \small{REDUCE} previously can now be integrated with this package. The above is one example; some more are given on the next page.
\pagebreak
\subsection{More examples}
\begin{eqnarray*}
 \int \frac{1}{x^5+1} \, dx & = &\frac{1}{5}\log(x + 1) \\
 &  & \mbox{} + 5log\_sum(\beta,\beta^4+\frac{1}{5}\beta^3+\frac{1}{25}\beta^2+\frac{1}{125}\beta+\frac{1}{625},0,\log(5*\beta+x)*\beta) 
\end{eqnarray*}

which should be read as
\[
\int \frac{1}{x^5+1}\,dx = \frac{1}{5}\log(x+1)+\sum_{\beta \mid \beta^4+\frac{1}{5}\beta^3+\frac{1}{25}\beta^2+\frac{1}{125}\beta+\frac{1}{625}=0} \log(5*\beta+x)\beta \]
\vspace{5 mm}
\begin{eqnarray*}
\lefteqn{\int \frac{7x^{13}+10x^8+4x^7-7x^6-4x^3 -4x^2+3x+3}{x^{14}-2x^8-2x^7-2x^4-4x^3-x^2+2x+1} \, dx  =}  \\                                 
& &  log\_sum(\alpha,\alpha^2  -\alpha -\frac{1}{4},0,log( - 2\alpha x^2  - 2\alpha x + x^7  + x^2  - 1)*\alpha,x) ,
\end{eqnarray*}
\[ \int \frac{1}{x^3+x+1} \, dx = log\_sum(\beta,\beta^3-\frac{3}{31}\beta^2-\frac{1}{31},0,\beta \log(-\frac{62}{9}\beta^2+\frac{31}{9} \beta +x+\frac{4}{9})). \]

\section{Options}
There are several alternative forms that the answer to the integration problem can take. One output is the $log\_sum$ form shown in the examples above. There is an option with this package to convert this to a "normal" sum of logarithms in the case when the degree of $eqn$ in $\alpha$ is two, and $\alpha$ can be expressed in surds. To do this, use the function $convert$, which has the following syntax:
\begin{center}  convert(exp) \end{center}
If exp is free of $log\_sum$ terms, then $exp$ itself is returned. If $exp$ contains $log\_sum$ terms, then $\alpha$ is represented as surds, and substituted into the $log\_sum$ expression. For example, using the last example, we have in \small{REDUCE}:
\begin{verbatim}

2: ratint(a,b,x); 


  {0,

                    2            1
  log_sum(alpha,alpha  - alpha - ---,0,
                                 4

                         2                7    2
         log( - 2*alpha*x  - 2*alpha*x + x  + x  - 1)*alpha,x)} 



3: convert(ws);


 1                           2                7
---*(sqrt(2)*log( - sqrt(2)*x  - sqrt(2)*x + x  - x - 1)
 2

                             2                7
      - sqrt(2)*log(sqrt(2)*x  + sqrt(2)*x + x  - x - 1)

                        2                7
      + log( - sqrt(2)*x  - sqrt(2)*x + x  - x - 1)

                     2                7
      + log(sqrt(2)*x  + sqrt(2)*x + x  - x - 1))

\end{verbatim}
\subsection{LogtoAtan function}
The user could then combine these to form a more elegant answer, using the switch combinelogs if one so wished. Another option is to convert complex logarithms to real arctangents ~\cite{Bron97}, which is recommended if definite integration is the goal. This is implemented in \small{REDUCE} via a function $convert\_log$, which has the following syntax:
\begin{center} \bf{convert\_log(exp)}, \end{center}
where $exp$ is any log\_sum expression.\\


The procedure to convert complex logarithms to real arctangents is based on an algorithm by Rioboo. Here is what it does: \\

Given a field $K$ of characteristic 0 such that $\sqrt(-1) \not\in K$ and 
$A, B \in K[x]$ with $B \not = 0$, return a sum $f$ of arctangents of polynomials in $K[x]$ such that
\[  \frac{df}{dx}=\frac{d}{dx} i \log(\frac{A+ i B}{A- i B}) \]

Example:
\[ \int \frac{x^4-3*x^2+6}{x^6-5*x^4+5*x^2+4} \, dx = \sum_{ \alpha \mid 4\alpha+1=0} \alpha \log(x^3+2\alpha x^2-3 x-4 \alpha) \]

Substituting $\alpha=i/2$ and $\alpha=-i/2$ gives the result

\[ \frac{i}{2} \log(\frac{(x^3-3 x)+i (x^2-2)}{(x^3-3 x)-i (x^2-2)}) \]

Applying logtoAtan now with $A=x^3-3 x$, and $B=x^2-2$ we obtain

\[ \int \frac{x^4-3*x^2+6}{x^6-5*x^4+5*x^2+4} \, dx = \arctan(\frac{x^5-3 x^3+x}{2})+\arctan(x^3)+\arctan(x) , \]

and this is the formula which should be used for definite integration. \\

Another example in \small{REDUCE} is given below:
\begin{verbatim}

1: ratint(1,x^2+1,x);

*** Domain mode rational changed to arnum

                    2    1
{0,log_sum(beta,beta  + ---,0,log(2*beta*x - 1)*beta)}
                         4

13: part(ws,2);

                 2    1
log_sum(beta,beta  + ---,0,log(2*beta*x - 1)*beta)
                      4

14: on combinelogs;

15: convertlog(ws);

 1        - i*x + 1
---*log(------------)*i 
 2         i*x + 1


logtoAtan(-x,1,x);

2*atan(x) 

\end{verbatim}
\section{Hermite's method}
The package also implements Hermite's method to reduce the integral into its polynomial and logarithmic parts, but occasionally, \small{REDUCE} returns the incorrect answer when this algorithm is used. This is due to the REDUCE operator pf, which performs a complete partial fraction expansion when given a rational function as input. Work is presently being done to give the pf operator a facility which tells it that the input is already factored. This would then enable REDUCE to perform a partial fraction decomposition with respect to a square free denominator, which may not necessarily be fully factored over Q. 
\newline
For a complete explanation of this and the other algorithms used in this package, including the theoretical justification and proofs, please consult ~\cite{Ged92}.

\section{Tracing the $ratint$ program}
The package includes a facility to trace in some detail the inner workings of the $ratint$ program. Messages are given at the key stages of the algorithm, together with the results obtained. These messages are displayed when the switch $traceratint$ is on, which is done in \small{REDUCE} \normalsize with the command 
\begin{verbatim}
on traceratint;
\end{verbatim}
This switch is off by default. Here is an example of the output obtained with this switch on:

\begin{verbatim}
Loading image file: /silo/tony/red/lisp/psl/solaris/red/reduce.img
REDUCE Development Version, 21-May-97 ...

1: load_package ratint;

2: on traceratint;


3: ratint(1+x,x^2-2*x+1,x);

                                     x + 1
performing Howoritz reduction on --------------
                                   2
                                  x  - 2*x + 1

                   - 2        1
Howoritz gives: {-------,0,-------}
                  x - 1     x - 1

                                 1
computing Rothstein Trager on -------
                               x - 1

integral in Rothstein T is log(x - 1)

   - 2
{-------,log(x - 1)}
  x - 1

\end{verbatim}

\section{Bugs, suggestions and comments}
This package was written when the author was working as a placement student at ZIB Berlin. All comments should therefore be reported to Winfried Neun, ZIB, Takustrasse 7, D 14195 Berlin Dahlem, Germany \\ (email: neun@zib.de).

\pagebreak

\begin{thebibliography}{999999} 
\normalsize
\bibitem[Bron97]{Bron97} Bronstein, Manuel,
{\it Symbolic Integration I: Transendental Functions},
Springer-Verlag, Heidelberg, 1997.

\bibitem[Dav88]{Dav88} Davenport, James H. et al,
{\it Computer Algebra- Systems and Algorithms for Algebraic Computation},
Academic Press, 1988.

\bibitem[Ged92]{Ged92} Geddes, K.O. et al,
{\it Algorithms for Computer Algebra}, Klewer Academic \mbox{Publishers}, 1992.

\bibitem[Red36]{Red36} Hearn, Anthony C. and Fitch, John F.
{\it REDUCE User's Manual 3.6}, RAND Corporation, 1995
\end{thebibliography}

\end{document}




























































mathpiper-0.81f+svn4469+dfsg3/src/packages/ratint/ratint.rlg0000644000175000017500000001005311527635055024027 0ustar  giovannigiovanniFri Feb 18 21:28:09 2011 run on win32

*** c already defined as operator 

exp1:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;


exp1 := 

     7        6         5         4         3         2
441*x  + 780*x  - 2861*x  + 4085*x  + 7695*x  + 3713*x  - 43253*x + 24500


exp2:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;


           6      5       4       3        2
exp2 := 9*x  + 6*x  - 65*x  + 20*x  + 135*x  - 154*x + 49


aa:=7*x^13+10*x^8+4*x^7-7*x^6-4*x^3-4*x^2+3*x+3;


         13       8      7      6      3      2
aa := 7*x   + 10*x  + 4*x  - 7*x  - 4*x  - 4*x  + 3*x + 3

bb:=x^14-2*x^8-2*x^7-2*x^4-4*x^3-x^2+2*x+1;


       14      8      7      4      3    2
bb := x   - 2*x  - 2*x  - 2*x  - 4*x  - x  + 2*x + 1


% example 2.14

a:=48*x^3-84*x^2+42*x-36;


           3       2
a := 6*(8*x  - 14*x  + 7*x - 6)


b:=-4*x^3-10*x^2+44*x-30;


              3      2
b := 2*( - 2*x  - 5*x  + 22*x - 15)



% square free ex

c:=x^8-2*x^6+2*x^2-1;


      8      6      2
c := x  - 2*x  + 2*x  - 1


%square_free(a,x);

%eval_sq_free(ws,x);


% hr example

pu:=441*x^7+780*x^6-2861*x^5+4085*x^4+7695*x^3+3713*x^2-43253*x+24500;


           7        6         5         4         3         2
pu := 441*x  + 780*x  - 2861*x  + 4085*x  + 7695*x  + 3713*x  - 43253*x + 24500


qu:=9*x^6+6*x^5-65*x^4+20*x^3+135*x^2-154*x+49;


         6      5       4       3        2
qu := 9*x  + 6*x  - 65*x  + 20*x  + 135*x  - 154*x + 49


%makemon(p,q,x);

%pf(pu/qu,x);
%trst hr;


k:=36*x^6+126*x^5+183*x^4+(13807/6)*x^3-407*x^2-(3242/5)*x+(3044/15);


            6         5         4          3          2
      1080*x  + 3780*x  + 5490*x  + 69035*x  - 12210*x  - 19452*x + 6088
k := --------------------------------------------------------------------
                                      30

l:=(x^2+(7/6)*x+(1/3))^2*(x-(2/5))^3;


            7         6         5         4      3        2
      4500*x  + 5100*x  - 1315*x  - 2698*x  + 8*x  + 496*x  + 16*x - 32
l := -------------------------------------------------------------------
                                    4500

%trst hr;

ratint(k,l,x);


   5271    3    39547   2    31018       7142
  ------*(x  + -------*x  - -------*x + -------)
    5           52710        26355       26355
{------------------------------------------------,
       4    11   3    11   2    2        4
      x  + ----*x  - ----*x  - ----*x + ----
            30        25        25       75

  37451            2      91125           2      128000           1
 -------*(log(x - ---) + -------*log(x + ---) - --------*log(x + ---))}
   16              5      37451           3      37451            2


ratint(exp1,exp2,x);


   49    6    226   5    268   4    1608   3    6011   2    536       256
  ----*(x  + -----*x  - -----*x  - ------*x  + ------*x  + -----*x - -----)
   2          147        49          49         147         21         9
{---------------------------------------------------------------------------,
                        4    2   3      2          7
                       x  - ---*x  - 4*x  + 6*x - ---
                             3                     3

 0}


ratint(1,x^2,x);


   - 1
{------,0}
   x


ratint(1,x^2+1,x);


*** Domain mode rational changed to arnum 

                    2    1
{0,log_sum(beta,beta  + ---,0,log(2*beta*x - 1)*beta)}
                         4


ratint(1,x^3+x+1,x);


*** Domain mode rational changed to arnum 

{0,

                  3    3           1
 log_sum(beta,beta  - ----*beta - ----,0,
                       31          31

                 62      2    31              4
         log( - ----*beta  + ----*beta + x + ---)*beta)}
                 9            9               9


ratint(1,x^5+1,x);


*** Domain mode rational changed to arnum 

{0,

  1
 ---*(log(x + 1) + 5*log_sum(beta,
  5

             4    1      3    1       2     1            1
         beta  + ---*beta  + ----*beta  + -----*beta + -----,0,
                  5           25           125          625

         log(5*beta + x)*beta))}


end;


Time for test: 16 ms, plus GC time: 15 ms
@@@@@ Resources used: (0 0 8 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/0000755000175000017500000000000011722677364022032 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/glmat.red0000644000175000017500000003212211526203062023610 0ustar  giovannigiovannimodule glmat; % Routines for inverting matrices and finding eigen-values
              % and vectors. Methods are the same as in glsolve module.

% Author: Eberhard Schruefer.
% Modification: James Davenport and Fran Burstall.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*cramer !*factor !*gcd !*sqfree !*sub2 kord!*);

global '(!!arbint);

if null !!arbint then !!arbint := 0;

switch cramer;

put('cramer,'simpfg,
    '((t (put 'mat 'lnrsolvefn 'clnrsolve)
     (put 'mat 'inversefn 'matinv))
      (nil (put 'mat 'lnrsolvefn 'lnrsolve)
       (put 'mat 'inversefn 'matinverse))));

% algebraic operator arbcomplex;

% Done this way since it's also defined in the solve1 module.

deflist('((arbcomplex simpiden)),'simpfn);

symbolic procedure clnrsolve(u,v);
   % Interface to matrix package.
   multm(matinv u,v);

symbolic procedure minv u;
   matinv matsm u;

put('minv,'rtypefn,'quotematrix);

%put('mateigen,'rtypefn,'quotematrix);

remprop('mateigen,'rtypefn);

symbolic procedure matinv u;
   % U is a matrix form. Result is the inverse of matrix u.
   begin scalar sgn,x,y,z,!*exp;
     integer l,m,lm;
     !*exp := t;
     z := 1;
     lm := length car u;
     for each v in u do
       <>;
     z := c!:extmult(x,z)>>;
      if singularchk lpow z then rerror(matrix,13,"Singular matrix");
     sgn := evenp length lpow z;
      return for each k in lpow z collect
          <>
   end;

symbolic procedure singularchk u; pairp car lastpair u;

flag('(mateigen),'opfn);

flag('(mateigen),'noval);

symbolic procedure mateigen(u,eival);
   % U is a matrix form, eival an indeterminate naming the eigenvalues.
   % Result is a list of lists:
   %   {{eival-eq1,multiplicity1,eigenvector1},....},
   % where eival-eq is a polynomial and eigenvector is a matrix.
%    How much should we attempt to solve the eigenvalue eq.? sqfr?
%    Sqfr is necessary if we want to have the full eigenspace. If there
%    are multiple roots another pass through eigenvector calculation
%    is needed(done).
%    We should actually perform the calculations in the extension
%    field generated by the eigenvalue equation(done inside).
  begin scalar arbvars,exu,sgn,q,r,s,x,y,z,eivec,!*factor,!*sqfree,
               !*exp;
        integer l;
     !*exp := t;
     if not(getrtype u eq 'matrix) then typerr(u,"matrix");
     eival := !*a2k eival;
     kord!* := eival . kord!*;
     exu := mateigen1(matsm u,eival);
     q := car exu;
     y := cadr exu;
     z := caddr exu;
     exu := cdddr exu;
     !*sqfree := t;
     for each j in cdr fctrf numr subs2(lc z ./ 1)
          do if null domainp car j and mvar car j eq eival
                then s := (if null red car j
                              then !*k2f mvar car j . (ldeg car j*cdr j)
                            else j) . s;
     for each j in q
       do (if x then rplacd(x,cdr x + cdr j)
             else s := (y . cdr j) . s)
            where x := assoc(y,s) where y := absf reorder car j;
     l := length s;
     r := 'list .
       for each j in s collect
     <>;
       arbvars := nil;
       for each k in lpow z do
          if (y=1) or null(k member lpow y) then
         arbvars := (k . makearbcomplex()) . arbvars;
       sgn := (y=1) or evenp length lpow y;
       eivec := 'mat . for each k in lpow z collect list
                           if x := assoc(k,arbvars)
                              then mvar cdr x
                            else prepsq!* mkgleig(k,y,
                                    sgn := not sgn,arbvars);
       list('list,prepsq!*(car j ./ 1),cdr j,eivec)>>;
     kord!* := cdr kord!*;
     return r
   end;

symbolic procedure mateigen1(u,eival);
   begin scalar q,x,y,z; integer l,lm,m;
      lm := length car u;
      z := 1;
      u := for each v in u collect
          <>;
        y := z;
        z := c!:extmult(if null red x then <<
               q := (if p then (car p  . (cdr p + 1)) . delete(p,q)
                      else (lc x  . 1) . q) where p = assoc(lc x,q);
                        !*p2f lpow x>> else x,z);
        x>>;
      return q . y . z . u
   end;

symbolic procedure reduce!-mod!-eig(u,v);
   % Reduces exterior product v wrt eigenvalue equation u.
   begin scalar x,y;
     for each j on v do
       if numr(y := reduce!-mod!-eigf(u,lc j)) then
      x := lpow j .* y .+ x;
     y := 1;
     for each j on x do y := lcm(y,denr lc j);
     return for each j on reverse x collect
          lpow j .* multf(numr lc j,quotf(y,denr lc j))
   end;

symbolic procedure reduce!-mod!-eigf(u,v);
   (subs2 reduce!-eival!-powers(lpow u . negsq cancel(red u ./ lc u),v))
    where !*sub2 = !*sub2;

symbolic procedure reduce!-eival!-powers(v,u);
   if domainp u or null(mvar u eq caar v) then u ./ 1
    else reduce!-eival!-powers1(v,u ./ 1);

symbolic procedure reduce!-eival!-powers1(v,u);
   % Reduces powers with the help of the eigenvalue polynomial.
   if domainp numr u or (ldeg numr u>;
     z := c!:extmult(x,z)>>;
      return cancel(lc z ./ f)
   end;

% Not supported at algebraic user level since it is in general slower
% than other methods.

% put('detex,'simpfn,'detex);

symbolic procedure mkglimat(u,v,sgn,k);
   begin scalar s,x,y;
     x := nil ./ 1;
     y := lpow v;
     for each j on red v do
       if s := glmatterm(u,y,j,k)
      then x := addsq(cancel(s ./ lc v),x);
     return if sgn then negsq x else x
   end;

symbolic procedure glmatterm(u,v,w,k);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
       if pairp car y and (cdar y = k) then lc w else nil;
    if car x = u then return nil
         else if car x member v then <>
         else if y then return nil
               else <>;
        go to a
   end;

symbolic procedure mkgleig(u,v,sgn,arbvars);
   begin scalar s,x,y,!*gcd;
     x := nil ./ 1;
     y := lpow v;
     !*gcd := t;
     for each j on red v do
       if s := glsoleig(u,y,j,arbvars)
      then x := addsq(cancel(s ./ lc v),x);
     return if sgn then negsq x else x
   end;

symbolic procedure glsoleig(u,v,w,arbvars);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
           if null car y then lc w
        else multf(cdr assoc(car y,arbvars),
               if sgn then negf lc w else lc w);
        if car x = u then return nil
         else if car x member v then <>
         else if y then return nil
               else <>;
        go to a
   end;


%**** Support for exterior multiplication ****
% Data structure is lpow ::= list of col.-ind. in exterior product
%                            | nil . number of eq. for inhomog. terms.
%                   lc   ::= standard form


% Exterior multiplication and p-forms:
% Let V be a vector space of dimension n.
% We call the elements of V 1-forms and build new objects called
% p-forms as follows: define a multiplication on 1-forms ^ such that
%                v^w=-w^v
% then the linear span of such objects is the space of 2-forms and has
% dimension n(n-1)/2.  Indeed, if v_1,...,v_n is a basis of V then
% v_i^v_j for i>;
         go to a
   end;

symbolic procedure c!:ordxp(u,v);
   if pairp u then if pairp v then cdr u < cdr v
            else nil
    else if pairp v then t
    else u < v;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/bareiss.red0000644000175000017500000002547611526203062024152 0ustar  giovannigiovannimodule bareiss; % Inversion routines using the Bareiss 2-step method.

% Author: Anthony C. Hearn.
% Modifications by: David Hartley.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module is rife with essential references to RPLAC-based
% functions.

fluid '(!*exp asymplis!* subfg!* wtl!* !*trsparse powlis!* powlis1!*
        bareiss!-step!-size!*);   % !*solveinconsistent

global '(assumptions requirements);

bareiss!-step!-size!* := 2;     % Seems fastest on average.

symbolic procedure matinverse u;
   lnrsolve(u,generateident length u);

symbolic procedure lnrsolve(u,v);
   %U is a matrix standard form, V a compatible matrix form.
   %Value is U**(-1)*V.
   begin scalar temp,vlhs,vrhs,ok,
                !*exp,!*solvesingular;
   if !*ncmp then return clnrsolve(u,v);
   !*exp := t;
   if asymplis!* or wtl!* then
    <>;
   vlhs := for i:=1:length car u collect intern gensym();
   vrhs := for i:=1:length car v collect intern gensym();
   u := car normmat augment(u,v);
   v := append(vlhs,vrhs);
   ok := setkorder v;
   u := foreach r in u collect prsum(v,r);
   v := errorset!*({function solvebareiss, mkquote u,mkquote vlhs},t);
   if caar v memq {'singular,'inconsistent} then
      <>;
   v := pair(cadr s,car s) where s = cadar v;
   u := foreach j in vlhs collect
           coeffrow(negf numr q,vrhs,denr q) where q = cdr atsoc(j,v);
   setkorder ok;
   if temp then <>;
   return for each j in u collect
             for each k in j collect
                if temp then resimp k else cancel k;
   end;

symbolic procedure prsum(kl,cl);
   % kl: list of kernel, cl: list of sf -> prsum: sf
   % kl and cl assumed to have same length
   if null kl then nil
   else if null car cl then prsum(cdr kl,cdr cl)
   else car kl .** 1 .* car cl .+ prsum(cdr kl,cdr cl);

symbolic procedure solvebareiss(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvebareiss: tagged solution list
   % Solve linear system exlis for variables in varlis using multi-step
   % Bareiss elimination and fraction-free back-substitution.  The
   % equations in exlis are not converted to a matrix, but kept as
   % (sparse) standard forms.
   begin
   % if asymplis!* or wtl!* then
   %   <>;
   exlis := sparse_bareiss(exlis,varlis,bareiss!-step!-size!*);
   if car exlis = 'inconsistent then return 'inconsistent . nil;
   exlis := cdr exlis;
   if not !*solvesingular and length exlis < length varlis then
      return 'singular . nil;
   if !*trsparse then
      solvesparseprint("Reduced system",reverse exlis,varlis);
   exlis := sparse_backsub(exlis,varlis);
   varlis := foreach p in exlis collect car p;
   exlis := foreach p in exlis collect cdr p;
   % if temp then <>;
   exlis := for each ex in exlis collect resimp subs2!* ex;
   return t . {{exlis,varlis,1}};
   end;

symbolic procedure coeffrow(u,v,d);
   % u:sf, v:list of kernel, d:sf -> coeffrow: list of sq
   % u is linear homogeneous in the kernels in v
   if null v then nil
   else if null u or mvar u neq car v
    then (nil ./ 1) . coeffrow(u,cdr v,d)
   else (lc u ./ d) . coeffrow(red u,cdr v,d);


symbolic procedure augment(u,v);
   if null u then nil else append(car u,car v) . augment(cdr u,cdr v);

symbolic procedure generateident n;
  %returns matrix canonical form of identity matrix of order N.
   begin scalar u,v;
        for i := 1:n do
         <>;
        return v
   end;

symbolic procedure normmat u;
   %U is a matrix standard form.
   %Value is dotted pair of matrix polynomial form and factor.
   begin scalar x,y,z;
      x := 1;
      for each v in u do
         <>;
      return reverse z . x
   end;

symbolic procedure sparse_bareiss(u,v,k);
   % u: list of sf, v: list of kernel, k: posint
   % -> sparse_bareiss: (t|'inconsistent) . list of sf
   % Multi-step Bareiss elimination using exterior multiplication to
   % calculate and organise determinants efficiently. Individual blocks
   % are solved using Cramer's rule. Exterior forms are decomposed into
   % {constant,linear} parts in non-pivot variables (non-linear part is
   % not needed). The leading coefficient of the first expression
   % returned is the determinant of the system.
   begin scalar p,d,w,pivs,s,asymplis!*,powlis!*,powlis1!*,wtl!*;
   d := 1;
   u := foreach f in u join if f then {!*sf2ex(f,v)};
   while p := choose_pivot_rows(u,v,k,d) do
      begin
      u := car p; v := cadr p;  % throws out free vars as well
      p := cddr p;
      pivs := lpow car p;       % pivot variables
      u := foreach r in u join  % multi-step elim. on remaining rows
              begin
              r := splitup(r,v);
              r := extadd(extmult(cadr r,car p),extmult(car r,cadr p));
              if null (r := subs2chkex r) then return nil;
              r := innprodpex(pivs,quotexf!*(r,d));
              % since we did r := r^pivs and then r := pivs _| r,
              % sign has changed if degree(pivs) is odd
              if not evenp length pivs then r := negex r;
              return {r};
              end;
      d := lc car p;            % update divisor
      assumptions := 'list . mk!*sq !*f2q d .
                            (pairp assumptions and cdr assumptions);
      p := extadd(car p,cadr p);% recombine pivot rows
      s := evenp length pivs;
      foreach x in pivs do      % Cramer's rule on pivot rows
         w := if (s := not s) then innprodpex(delete(x,pivs),p) . w
              else negex innprodpex(delete(x,pivs),p) . w;
      end;
   foreach f in u do % inconsistent system
      requirements := 'list . mk!*sq !*f2q !*ex2sf f .
                          (pairp requirements and cdr requirements);
   return if u then 'inconsistent . nil
          else t . foreach f in w collect !*ex2sf f;
   end;

symbolic procedure choose_pivot_rows(u,v,k,d);
   % u: list of ex, v: list of kernel, k: posint, d: sf
   % -> choose_pivot_rows: nil or (list of ex).(list of kernel).ex
   % Choose pivots in the first k variables from v (or the first k-1
   % variables from the first pivot variable in v). If k pivots can't be
   % found, don't waste time looking in further columns (so number of
   % pivot rows is <= k).  If pivots found, return remaining rows,
   % remaining variables and decomposed exterior product of pivot rows.
   if null u or null v then nil else
   begin scalar w,s,ss,p,x,y,rows,pivots;
   w := u;
   for i:=1:k do if v then v := cdr v;
   while k neq 0 do
      if null u then % ran out of rows before finding k pivots
         if null v or null w or pivots then k := 0
         else % skip k more variables and reset everything
          << for i:=1:k do if v then v := cdr v; s := nil; u := w>>
      else if car(x := splitup(car u,v)) and
              (y := if null pivots then car x
                    else subs2chkex extmult(car x,car pivots)) then
         begin % found one
         rows := x . rows;
         pivots := (if null pivots then y else quotexf!*(y,d)) . pivots;
         % if # rows skipped is odd, then reverse sign
         if s then ss := not ss;
         w := delete(car u,w); u := cdr u; k := k - 1;
         end
      else <>; % skip row
   if null pivots then return; % couldn't find any pivots
   % next line adjusts sign to return row1^...^rowk
   % instead of rowk^...^row1
   if remainder(length lpow car pivots,4) member {2,3} then
      ss := not ss;
   rows := reverse rows;       % calculate dets along pivot rows
   pivots := reverse pivots;
   p := car rows;
   foreach r in cdr rows do
      p := {car(pivots := cdr pivots),
            quotexf!*(extadd(extmult(cadr r,car p),
                             extmult(car r,cadr p)),d)};
   return w . v . if ss then {negex car p,negex cadr p} else p;
   end;

symbolic procedure sparse_backsub(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> sparse_backsub: list of kernel.sq
   % Fraction-free back-substitution for exlis, where reverse exlis is
   % a list of rows of an upper-triangular matrix wrt varlis.  Since
   % exlis has been produced in a fraction-free way, the leading
   % coefficient of the first row is the determinant of the system.
   begin scalar d,z,c;
   if null exlis then return nil;       % trivial case
   d := lc car exlis;                  % determinant
   foreach x in exlis do % Almost redundant for first x.
      begin scalar s,p,v,r;
      p := lc x;   % pivot.
      v := mvar x;
      x := red x;
      while not domainp x and mvar x member varlis do
          <>;
      % Used to be quotf!*, but that could give a terminal error.
      s := negf quotff(addf(multf(addf(r,x),d),s),p);
      z := (v . s) . z;
      end;
   for each p in z do cdr p := cancel(cdr p ./ d);
   return z
   end;

symbolic procedure quotff(u,v);
   % We do the rationalizesq step to allow for surd divisors.
   if null u then nil
    else (if x then x
           else (if denr y = 1 then numr y
                  else rederr "Invalid division in backsub")
                 where y=rationalizesq(u ./ v))
          where x=quotf(u,v);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/resultnt.red0000644000175000017500000002353711526203062024376 0ustar  giovannigiovannimodule resultnt;

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn, Winfried Neun.

%**********************************************************************
%                                                                     *
% The resultant function defined here has the following properties:   *
%                                                                     *
%                           degr(p1,x)*degr(p2,x)                     *
%  resultant(p1,p2,x) = (-1)                     *resultant(p2,p1,x)  *
%                                                                     *
%                         degr(p2,x)                                  *
%  resultant(p1,p2,x) = p1             if p1 free of x                *
%                                                                     *
%  resultant(p1,p2,x) = 1  if p1 free of x and p2 free of x           *
%                                                                     *
%**********************************************************************

%exports resultant;

%imports reorder,setkorder,degr,addf,negf,multf,multpf;

load_package polydiv;

fluid '(!*bezout !*exp kord!*);

switch bezout;

put('resultant,'simpfn,'simpresultant);

symbolic procedure simpresultant u;
   if length u neq 3
     then rerror(matrix,19,
                   "Resultant called with wrong number of arguments")
    else resultantsq(simp!* car u,simp!* cadr u,!*a2k caddr u)
         where !*exp = t;

symbolic procedure resultant(u,v,var);
   % Kept for compatibility with old code.
   if domainp u and domainp v then 1
    else begin scalar x;
       kord!* := var . kord!*;  % updkorder can't be used here.
                                % See sum test.
       if null domainp u and null(mvar u eq var) then u := reorder u;
       if null domainp v and null(mvar v eq var) then v := reorder v;
       x := if !*bezout then bezout_resultant(u,v,var)
             else polyresultantf(u,v,var);
       setkorder cdr kord!*;
       return x
   end;

symbolic procedure resultantsq(u,v,var);
   % Uses resultant(a*P,b*Q,var) = a^ldeg Q*b^ldeg P*resultant(P,Q,var).
   if domainp numr u and domainp numr v and denr u = 1 and denr v = 1
     then 1 ./ 1
    else begin scalar x,y,z;
       kord!* := var . kord!*;  % updkorder can't be used here.
                                % See sum test.
       if null domainp numr u and null(mvar numr u eq var)
         then u := reordsq u;
       if null domainp numr v and null(mvar numr v eq var)
         then v := reordsq v;
       if (y := denr u) neq 1
          and smember(var,y) then typerr(prepf y,'polynomial)
        else if (z := denr v) neq 1
          and smember(var,z) then typerr(prepf z,'polynomial);
       u := numr u;
       v := numr v;
       if smember(var,coefflist(u,var)) then typerr(prepf u,'polynomial)
        else if smember(var,coefflist(v,var))
         then typerr(prepf v,'polynomial);
       x := if !*bezout then bezout_resultant(u,v,var)
             else polyresultantf(u,v,var);
       if y neq 1 then y := exptf(y,degr(v,var));
       if z neq 1 then y := multf(y,exptf(z,degr(u,var)));
       setkorder cdr kord!*;
       return x ./ y
   end;

symbolic procedure coefflist(u,var);
   % Returns list of pairs of degrees and coefficients of var in u.
   begin scalar z;
      while not domainp u and mvar u=var
         do <>;
      return if null u then z else (0 . u) . z
   end;

symbolic procedure polyresultantf(u,v,var);
   % Algorithm is from M. Bronstein, Symbolic Integration I -
   % Transcendental Functions Algorithms and Computation in Mathematics,
   % Vol. 1 Springer, Heidelberg, ISBN 3-540-60521-5.
   % Note var is assumed to be the leading term in kord!* and the main
   % variable in u and v.
   begin scalar beta,cd,cn,delta,gam,r,s,temp,x;
      cd := cn := r := s := 1;
      gam := -1;
      if domainp u or domainp v then return 1
       else if ldeg u>;
      while v do
       <>>>>>;
      return if not domainp u and mvar u eq var then nil
              else if ldeg temp neq 1
               then quotf(multf(s,multf(cn,exptf(u,ldeg temp))),cd)
              else u
   end;

symbolic procedure lcr(u,var);
   if domainp u or mvar u neq var then u else lc u;

symbolic procedure ldegr(u,var);
   if domainp u or mvar u neq var then 0 else ldeg u;

symbolic procedure pseudo_remf(u,v,var);
   !*q2f simp pseudo!-remainder {mk!*sq(u ./ 1),mk!*sq(v ./ 1),var};

symbolic procedure bezout_resultant(u,v,w);
   % U and v are standard forms. Result is resultant of u and v
   % w.r.t. kernel w. Method is Bezout's determinant using exterior
   % multiplication for its calculation.
   begin integer n,nm; scalar ap,ep,uh,ut,vh,vt;
     if domainp u or null(mvar u eq w)
        then return if not domainp v and mvar v eq w
                       then exptf(u,ldeg v)
                     else 1
      else if domainp v or null(mvar v eq w)
        then return if mvar u eq w then exptf(v,ldeg u) else 1;
     n := ldeg v - ldeg u;
     if n < 0 then return multd((-1)**(ldeg u*ldeg v),
                                bezout_resultant(v,u,w));
     ep := 1;
     nm := ldeg v;
     uh := lc u;
     vh := lc v;
     ut := if n neq 0 then multpf(w to n,red u) else red u;
     vt := red v;
     ap := addf(multf(uh,vt),negf multf(vh,ut));
     ep := b!:extmult(!*sf2exb(ap,w),ep);
     for j := (nm - 1) step -1 until (n + 1) do
        <>
           else uh := multf(!*k2f w,uh);
          if degr(vt,w) = j then
             <>
           else vh := multf(!*k2f w,vh);
          ep := b!:extmult(!*sf2exb(addf(multf(uh,vt),
                                    negf multf(vh,ut)),w),ep)>>;
      if n neq 0
         then <>;
      return if null ep then nil else lc ep
   end;

symbolic procedure !*sf2exb(u,v);
   %distributes s.f. u with respect to powers in v.
   if degr(u,v)=0 then if null u then nil
                        else list 0 .* u .+ nil
    else list ldeg u .* lc u .+ !*sf2exb(red u,v);

%**** Support for exterior multiplication ****
% Data structure is lpow ::= list of degrees in exterior product
%                   lc   ::= standard form

symbolic procedure b!:extmult(u,v);
   %Special exterior multiplication routine. Degree of form v is
   %arbitrary, u is a one-form.
   if null u or null v then  nil
    else if v = 1 then u
    else (if x then cdr x .* (if car x then negf multf(lc u,lc v)
                   else multf(lc u,lc v))
              .+ b!:extadd(b!:extmult(!*t2f lt u,red v),
                    b!:extmult(red u,v))
       else b!:extadd(b!:extmult(red u,v),
              b!:extmult(!*t2f lt u,red v)))
      where x = b!:ordexn(car lpow u,lpow v);

symbolic procedure b!:extadd(u,v);
   if null u then v
    else if null v then u
    else if lpow u = lpow v then
            (lambda x,y; if null x then y else lpow u .* x .+ y)
        (addf(lc u,lc v),b!:extadd(red u,red v))
    else if b!:ordexp(lpow u,lpow v) then lt u .+ b!:extadd(red u,v)
    else lt v .+ b!:extadd(u,red v);

symbolic procedure b!:ordexp(u,v);
   if null u then t
    else if car u > car v then t
    else if car u = car v then b!:ordexp(cdr u,cdr v)
    else nil;

symbolic procedure b!:ordexn(u,v);
   %u is a single integer, v a list. Returns nil if u is a member
   %of v or a dotted pair of a permutation indicator and the ordered
   %list of u merged into v.
   begin scalar s,x;
     a: if null v then return(s . reverse(u . x))
     else if u = car v then return nil
     else if u and u > car v then
                 return(s . append(reverse(u . x),v))
         else  <>;
         go to a
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/matrix.tst0000644000175000017500000002110511526203062024047 0ustar  giovannigiovanni% Miscellaneous matrix tests.

% Tests of eigenfunction/eigenvalue code.

v := mat((1,1,-1,1,0),(1,2,-1,0,1),(-1,2,3,-1,0),
        (1,-2,1,2,-1),(2,1,-1,3,0))$

mateigen(v,et);

eigv := third first ws$

% Now check if the equation for the eigenvectors is fulfilled.  Note
% that also the last component is zero due to the eigenvalue equation.
v*eigv-et*eigv;

% Example of degenerate eigenvalues.

u := mat((2,-1,1),(0,1,1),(-1,1,1))$

mateigen(u,eta);


% Example of a fourfold degenerate eigenvalue with two corresponding
% eigenvectors.

w := mat((1,-1,1,-1),(-3,3,-5,4),(8,-4,3,-4),
         (15,-10,11,-11))$

mateigen(w,al);

eigw := third first ws;

w*eigw - al*eigw;

% Calculate the eigenvectors and eigenvalue equation.

f := mat((0,ex,ey,ez),(-ex,0,bz,-by),(-ey,-bz,0,bx),
        (-ez,by,-bx,0))$

factor om;

mateigen(f,om);

% Specialize to perpendicular electric and magnetic field.

let ez=0,ex=0,by=0;

% Note that we find two eigenvectors to the double eigenvalue 0
% (as it must be).

mateigen(f,om);

% The following has 1 as a double eigenvalue. The corresponding
% eigenvector must involve two arbitrary constants.

j := mat((9/8,1/4,-sqrt(3)/8),
         (1/4,3/2,-sqrt(3)/4),
         (-sqrt(3)/8,-sqrt(3)/4,11/8));

mateigen(j,x);

% The following is a good consistency check.

sym := mat(
   (0,  1/2,  1/(2*sqrt(2)),  0,  0),
   (1/2,  0,  1/(2*sqrt(2)),  0,  0),
   (1/(2*sqrt(2)),  1/(2*sqrt(2)),  0,  1/2,  1/2),
   (0,  0,  1/2,  0,  0),
   (0,  0,  1/2,  0,  0))$

ans := mateigen(sym,eta);

% Check of correctness for this example.

for each j in ans do
  for each k in solve(first j,eta) do
      write sub(k,sym*third j - eta*third j);


% Tests of nullspace operator.

a1 := mat((1,2,3,4),(5,6,7,8));

nullspace a1;
 
b1 := {{1,2,3,4},{5,6,7,8}};

nullspace b1;

% Example taken from a bug report for another CA system.

c1 :=
{{(p1**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1**2*p2*(s + z))/(p1**2 + p3**2)), p1*(s + z),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)},
   {0, 0, 0, 0, 0, 0, 0, 0, 0},
  {(p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p3**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)), p3*(s + z),
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)},
  {-((p1**2*p2*(s + z))/(p1**2 + p3**2)), 0,
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1**2*p2**2*(s + 2*z))/((p1**2 + p3**2)*z)), (p1*p2*(s + 2*z))/z,
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)), 0, (p1**2*p2*z)/(p1**2 + p3**2)},
  {p1*(s + z), 0, p3*(s + z), (p1*p2*(s + 2*z))/z,
   -(((p1**2+p3**2)*(s+ 2*z))/z), (p2*p3*(s + 2*z))/z, p3*z,0, -(p1*z)},
  {-((p1*p2*p3*(s + z))/(p1**2 + p3**2)), 0,
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)), (p2*p3*(s + 2*z))/z,
   -((p2**2*p3**2*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p2*p3**2*z)/(p1**2 + p3**2)), 0, (p1*p2*p3*z)/(p1**2 + p3**2)},
  {-((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)),p3*z,-((p2*p3**2*z)/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))},
  {0, 0, 0, 0, 0, 0, 0, 0, 0}, 
  {(p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2),
   (p1**2*p2*z)/(p1**2 + p3**2), -(p1*z), (p1*p2*p3*z)/(p1**2 + p3**2),
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)), 0,
   -((p1**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)))}};

nullspace c1;
 
d1 := mat
(((p1**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1**2*p2*(s + z))/(p1**2 + p3**2)), p1*(s + z),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   (0, 0, 0, 0, 0, 0, 0, 0, 0),
  ((p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p3**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)), p3*(s + z),
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
  ( ((p1**2*p2*(s + z))/(p1**2 + p3**2)), 0,
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1**2*p2**2*(s + 2*z))/((p1**2 + p3**2)*z)), (p1*p2*(s + 2*z))/z,
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)), 0, (p1**2*p2*z)/(p1**2 + p3**2)),
  (p1*(s + z), 0, p3*(s + z), (p1*p2*(s + 2*z))/z,
   -(((p1**2 + p3**2)*(s + 2*z))/z),(p2*p3*(s + 2*z))/z,p3*z,0,-(p1*z)),
  (-((p1*p2*p3*(s + z))/(p1**2 + p3**2)), 0,
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)), (p2*p3*(s + 2*z))/z,
   -((p2**2*p3**2*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p2*p3**2*z)/(p1**2 + p3**2)), 0, (p1*p2*p3*z)/(p1**2 + p3**2)),
  (-((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)),p3*z,-((p2*p3**2*z)/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))),
  (0, 0, 0, 0, 0, 0, 0, 0, 0), 
   ((p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2),
   (p1**2*p2*z)/(p1**2 + p3**2), -(p1*z), (p1*p2*p3*z)/(p1**2 + p3**2),
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)), 0,
   -((p1**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)))));

nullspace d1;


% The following example, by Kenton Yee, was discussed extensively by
% the sci.math.symbolic newsgroup.

m := mat((e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), 0),
         (1, 1, 1, 1, 1, 1, 0, 1),(1, 1, 1, 1, 1, 0, 1, 1),
         (1, 1, 1, 1, 0, 1, 1, 1),(1, 1, 1, 0, 1, 1, 1, 1),
         (1, 1, 0, 1, 1, 1, 1, 1),(1, 0, 1, 1, 1, 1, 1, 1),
         (0, e, e, e, e, e, e, e));

eig := mateigen(m,x);

% Now check the eigenvectors and calculate the eigenvalues in the
% respective eigenspaces:

factor expt;

for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;

% For the special choice:

let e = -7 + sqrt 48;

% we get only 7 eigenvectors.

eig := mateigen(m,x);

for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;

% The same behaviour for this choice of e.

clear e; let e = -7 - sqrt 48;

% we get only 7 eigenvectors.

eig := mateigen(m,x);

for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;


% For this choice of values

clear e; let e = 1;

% the eigenvalue 1 becomes 4-fold degenerate. However, we get a complete
% span of 8 eigenvectors.

eig := mateigen(m,x);

for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;

ma := mat((1,a),(0,b));

% case 1:

let a = 0;

mateigen(ma,x);

% case 2:

clear a; let a = 0, b = 1;

mateigen(ma,x);

% case 3:

clear a,b; 

mateigen(ma,x);

% case 4:

let b = 1; 

mateigen(ma,x);

% Example from H.G. Graebe:

m1:=mat((-sqrt(3)+1,2         ,3         ),
	(2         ,-sqrt(3)+3,1         ),
	(3         ,1         ,-sqrt(3)+2));

nullspace m1;

for each n in ws collect m1*n;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/matrix.rlg0000644000175000017500000014045611527635055024050 0ustar  giovannigiovanniFri Feb 18 21:27:13 2011 run on win32
% Miscellaneous matrix tests.

% Tests of eigenfunction/eigenvalue code.

v := mat((1,1,-1,1,0),(1,2,-1,0,1),(-1,2,3,-1,0),
        (1,-2,1,2,-1),(2,1,-1,3,0))$



mateigen(v,et);


{{et - 2,

  1,


  [      0      ]
  [             ]
  [      0      ]
  [             ]
  [arbcomplex(1)]
  [             ]
  [arbcomplex(1)]
  [             ]
  [arbcomplex(1)]

  },

    4       3        2
 {et  - 6*et  + 13*et  + 5*et - 5,

  1,


  [       5*arbcomplex(2)*(et - 2)       ]
  [     ----------------------------     ]
  [          3        2                  ]
  [      2*et  - 10*et  + 23*et + 5      ]
  [                                      ]
  [                        2             ]
  [ arbcomplex(2)*et*( - et  + 6*et - 8) ]
  [--------------------------------------]
  [          3        2                  ]
  [      2*et  - 10*et  + 23*et + 5      ]
  [                                      ]
  [    arbcomplex(2)*et*( - 3*et + 7)    ]
  [   --------------------------------   ]
  [          3        2                  ]
  [      2*et  - 10*et  + 23*et + 5      ]
  [                                      ]
  [                    3       2         ]
  [   arbcomplex(2)*(et  - 4*et  + 10)   ]
  [  ----------------------------------  ]
  [          3        2                  ]
  [      2*et  - 10*et  + 23*et + 5      ]
  [                                      ]
  [            arbcomplex(2)             ]

  }}


eigv := third first ws$



% Now check if the equation for the eigenvectors is fulfilled.  Note
% that also the last component is zero due to the eigenvalue equation.
v*eigv-et*eigv;


[            0            ]
[                         ]
[            0            ]
[                         ]
[arbcomplex(1)*( - et + 2)]
[                         ]
[arbcomplex(1)*( - et + 2)]
[                         ]
[arbcomplex(1)*( - et + 2)]



% Example of degenerate eigenvalues.

u := mat((2,-1,1),(0,1,1),(-1,1,1))$



mateigen(u,eta);


{{eta - 1,2,

  [arbcomplex(3)]
  [             ]
  [arbcomplex(3)]
  [             ]
  [      0      ]

  },

 {eta - 2,1,

  [      0      ]
  [             ]
  [arbcomplex(4)]
  [             ]
  [arbcomplex(4)]

  }}



% Example of a fourfold degenerate eigenvalue with two corresponding
% eigenvectors.

w := mat((1,-1,1,-1),(-3,3,-5,4),(8,-4,3,-4),
         (15,-10,11,-11))$



mateigen(w,al);


{{al + 1,

  4,


  [            arbcomplex(5)             ]
  [           ---------------            ]
  [                  5                   ]
  [                                      ]
  [  - 5*arbcomplex(6) + 7*arbcomplex(5) ]
  [--------------------------------------]
  [                  5                   ]
  [                                      ]
  [            arbcomplex(5)             ]
  [                                      ]
  [            arbcomplex(6)             ]

  }}


eigw := third first ws;


        [            arbcomplex(5)             ]
        [           ---------------            ]
        [                  5                   ]
        [                                      ]
        [  - 5*arbcomplex(6) + 7*arbcomplex(5) ]
eigw := [--------------------------------------]
        [                  5                   ]
        [                                      ]
        [            arbcomplex(5)             ]
        [                                      ]
        [            arbcomplex(6)             ]



w*eigw - al*eigw;


[                           - arbcomplex(5)*(al + 1)                          ]
[                         ---------------------------                         ]
[                                      5                                      ]
[                                                                             ]
[ 5*arbcomplex(6)*al + 5*arbcomplex(6) - 7*arbcomplex(5)*al - 7*arbcomplex(5) ]
[-----------------------------------------------------------------------------]
[                                      5                                      ]
[                                                                             ]
[                           - arbcomplex(5)*(al + 1)                          ]
[                                                                             ]
[                           - arbcomplex(6)*(al + 1)                          ]



% Calculate the eigenvectors and eigenvalue equation.

f := mat((0,ex,ey,ez),(-ex,0,bz,-by),(-ey,-bz,0,bx),
        (-ez,by,-bx,0))$



factor om;



mateigen(f,om);


    4     2    2     2     2     2     2     2      2   2
{{om  + om *(bx  + by  + bz  + ex  + ey  + ez ) + bx *ex  + 2*bx*by*ex*ey

                       2   2                     2   2
   + 2*bx*bz*ex*ez + by *ey  + 2*by*bz*ey*ez + bz *ez ,

  1,


          2
  mat(((om *arbcomplex(7)*ez + om*arbcomplex(7)*(bx*ey - by*ex)

                                                        3         2     2     2
         + arbcomplex(7)*bz*(bx*ex + by*ey + bz*ez))/(om  + om*(bz  + ex  + ey )

          )),

             2
      (( - om *arbcomplex(7)*by + om*arbcomplex(7)*(bx*bz - ex*ez)

                                                        3         2     2     2
         - arbcomplex(7)*ey*(bx*ex + by*ey + bz*ez))/(om  + om*(bz  + ex  + ey )

          )),

          2
      ((om *arbcomplex(7)*bx + om*arbcomplex(7)*(by*bz - ey*ez)

                                                        3         2     2     2
         + arbcomplex(7)*ex*(bx*ex + by*ey + bz*ez))/(om  + om*(bz  + ex  + ey )

          )),

      (arbcomplex(7)))

}}


% Specialize to perpendicular electric and magnetic field.

let ez=0,ex=0,by=0;



% Note that we find two eigenvectors to the double eigenvalue 0
% (as it must be).

mateigen(f,om);


{{om,

  2,


  [ arbcomplex(9)*bx - arbcomplex(8)*bz ]
  [-------------------------------------]
  [                 ey                  ]
  [                                     ]
  [            arbcomplex(8)            ]
  [                                     ]
  [                  0                  ]
  [                                     ]
  [            arbcomplex(9)            ]

  },

    2     2     2     2
 {om  + bx  + bz  + ey ,

  1,


  [        - arbcomplex(10)*ey       ]
  [      ----------------------      ]
  [                bx                ]
  [                                  ]
  [        - arbcomplex(10)*bz       ]
  [      ----------------------      ]
  [                bx                ]
  [                                  ]
  [                   2     2     2  ]
  [ arbcomplex(10)*(bx  + bz  + ey ) ]
  [----------------------------------]
  [              om*bx               ]
  [                                  ]
  [          arbcomplex(10)          ]

  }}


% The following has 1 as a double eigenvalue. The corresponding
% eigenvector must involve two arbitrary constants.

j := mat((9/8,1/4,-sqrt(3)/8),
         (1/4,3/2,-sqrt(3)/4),
         (-sqrt(3)/8,-sqrt(3)/4,11/8));


     [     9             1          - sqrt(3) ]
     [    ---           ---       ------------]
     [     8             4             8      ]
     [                                        ]
     [     1             3          - sqrt(3) ]
j := [    ---           ---       ------------]
     [     4             2             4      ]
     [                                        ]
     [  - sqrt(3)     - sqrt(3)        11     ]
     [------------  ------------      ----    ]
     [     8             4             8      ]



mateigen(j,x);


{{x - 1,

  2,


  [sqrt(3)*arbcomplex(12) - 2*arbcomplex(11)]
  [                                         ]
  [             arbcomplex(11)              ]
  [                                         ]
  [             arbcomplex(12)              ]

  },

 {x - 2,

  1,


  [   - sqrt(3)*arbcomplex(13)  ]
  [ --------------------------- ]
  [              3              ]
  [                             ]
  [  - 2*sqrt(3)*arbcomplex(13) ]
  [-----------------------------]
  [              3              ]
  [                             ]
  [       arbcomplex(13)        ]

  }}


% The following is a good consistency check.

sym := mat(
   (0,  1/2,  1/(2*sqrt(2)),  0,  0),
   (1/2,  0,  1/(2*sqrt(2)),  0,  0),
   (1/(2*sqrt(2)),  1/(2*sqrt(2)),  0,  1/2,  1/2),
   (0,  0,  1/2,  0,  0),
   (0,  0,  1/2,  0,  0))$



ans := mateigen(sym,eta);


ans := {{eta,

         1,


         [        0        ]
         [                 ]
         [        0        ]
         [                 ]
         [        0        ]
         [                 ]
         [ - arbcomplex(14)]
         [                 ]
         [ arbcomplex(14)  ]

         },

        {eta - 1,

         1,


         [ 2*arbcomplex(15) ]
         [------------------]
         [     sqrt(2)      ]
         [                  ]
         [ 2*arbcomplex(15) ]
         [------------------]
         [     sqrt(2)      ]
         [                  ]
         [ 2*arbcomplex(15) ]
         [                  ]
         [  arbcomplex(15)  ]
         [                  ]
         [  arbcomplex(15)  ]

         },

        {2*eta + 1,

         1,


         [ - arbcomplex(16)]
         [                 ]
         [ arbcomplex(16)  ]
         [                 ]
         [        0        ]
         [                 ]
         [        0        ]
         [                 ]
         [        0        ]

         },

              2
        {4*eta  + 2*eta - 1,

         1,


         [        - arbcomplex(17)       ]
         [      -------------------      ]
         [         2*sqrt(2)*eta         ]
         [                               ]
         [        - arbcomplex(17)       ]
         [      -------------------      ]
         [         2*sqrt(2)*eta         ]
         [                               ]
         [ arbcomplex(17)*( - 2*eta + 1) ]
         [-------------------------------]
         [             2*eta             ]
         [                               ]
         [        arbcomplex(17)         ]
         [                               ]
         [        arbcomplex(17)         ]

         }}


% Check of correctness for this example.

for each j in ans do
  for each k in solve(first j,eta) do
      write sub(k,sym*third j - eta*third j);


[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]




% Tests of nullspace operator.

a1 := mat((1,2,3,4),(5,6,7,8));


      [1  2  3  4]
a1 := [          ]
      [5  6  7  8]



nullspace a1;


{

 [ 1  ]
 [    ]
 [ 0  ]
 [    ]
 [ - 3]
 [    ]
 [ 2  ]

 ,

 [ 0  ]
 [    ]
 [ 1  ]
 [    ]
 [ - 2]
 [    ]
 [ 1  ]

 }

 
b1 := {{1,2,3,4},{5,6,7,8}};


b1 := {{1,2,3,4},{5,6,7,8}}


nullspace b1;


{{1,0,-3,2},{0,1,-2,1}}


% Example taken from a bug report for another CA system.

c1 :=
{{(p1**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1**2*p2*(s + z))/(p1**2 + p3**2)), p1*(s + z),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)},
   {0, 0, 0, 0, 0, 0, 0, 0, 0},
  {(p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p3**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)), p3*(s + z),
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)},
  {-((p1**2*p2*(s + z))/(p1**2 + p3**2)), 0,
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1**2*p2**2*(s + 2*z))/((p1**2 + p3**2)*z)), (p1*p2*(s + 2*z))/z,
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)), 0, (p1**2*p2*z)/(p1**2 + p3**2)},
  {p1*(s + z), 0, p3*(s + z), (p1*p2*(s + 2*z))/z,
   -(((p1**2+p3**2)*(s+ 2*z))/z), (p2*p3*(s + 2*z))/z, p3*z,0, -(p1*z)},
  {-((p1*p2*p3*(s + z))/(p1**2 + p3**2)), 0,
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)), (p2*p3*(s + 2*z))/z,
   -((p2**2*p3**2*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p2*p3**2*z)/(p1**2 + p3**2)), 0, (p1*p2*p3*z)/(p1**2 + p3**2)},
  {-((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)),p3*z,-((p2*p3**2*z)/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))},
  {0, 0, 0, 0, 0, 0, 0, 0, 0}, 
  {(p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2),
   (p1**2*p2*z)/(p1**2 + p3**2), -(p1*z), (p1*p2*p3*z)/(p1**2 + p3**2),
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)), 0,
   -((p1**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)))}};


           2    2     2     2          2
         p1 *(p1  + p2  + p3  - s*z - z )
c1 := {{----------------------------------,
                      2     2
                    p1  + p3

        0,

                  2     2     2          2
         p1*p3*(p1  + p2  + p3  - s*z - z )
        ------------------------------------,
                       2     2
                     p1  + p3

              2
          - p1 *p2*(s + z)
        -------------------,
               2     2
             p1  + p3

        p1*(s + z),

          - p1*p2*p3*(s + z)
        ---------------------,
                2     2
              p1  + p3

                     2     2     2
          - p1*p3*(p1  + p2  + p3 )
        ----------------------------,
                   2     2
                 p1  + p3

        0,

           2    2     2     2
         p1 *(p1  + p2  + p3 )
        -----------------------},
                 2     2
               p1  + p3

       {0,0,0,0,0,0,0,0,0},

                  2     2     2          2
         p1*p3*(p1  + p2  + p3  - s*z - z )
       {------------------------------------,
                       2     2
                     p1  + p3

        0,

           2    2     2     2          2
         p3 *(p1  + p2  + p3  - s*z - z )
        ----------------------------------,
                      2     2
                    p1  + p3

          - p1*p2*p3*(s + z)
        ---------------------,
                2     2
              p1  + p3

        p3*(s + z),

                 2
          - p2*p3 *(s + z)
        -------------------,
               2     2
             p1  + p3

              2    2     2     2
          - p3 *(p1  + p2  + p3 )
        --------------------------,
                  2     2
                p1  + p3

        0,

                  2     2     2
         p1*p3*(p1  + p2  + p3 )
        -------------------------},
                  2     2
                p1  + p3

              2
          - p1 *p2*(s + z)
       {-------------------,
               2     2
             p1  + p3

        0,

          - p1*p2*p3*(s + z)
        ---------------------,
                2     2
              p1  + p3

           2   2
         p1 *p2 *( - s - 2*z)
        ----------------------,
                 2     2
            z*(p1  + p3 )

         p1*p2*(s + 2*z)
        -----------------,
                z

              2
         p1*p2 *p3*( - s - 2*z)
        ------------------------,
                  2     2
             z*(p1  + p3 )

          - p1*p2*p3*z
        ---------------,
             2     2
           p1  + p3

        0,

           2
         p1 *p2*z
        -----------},
           2     2
         p1  + p3

       {p1*(s + z),

        0,

        p3*(s + z),

         p1*p2*(s + 2*z)
        -----------------,
                z

              2         2       2         2
          - p1 *s - 2*p1 *z - p3 *s - 2*p3 *z
        --------------------------------------,
                          z

         p2*p3*(s + 2*z)
        -----------------,
                z

        p3*z,

        0,

         - p1*z},

          - p1*p2*p3*(s + z)
       {---------------------,
                2     2
              p1  + p3

        0,

                 2
          - p2*p3 *(s + z)
        -------------------,
               2     2
             p1  + p3

              2
         p1*p2 *p3*( - s - 2*z)
        ------------------------,
                  2     2
             z*(p1  + p3 )

         p2*p3*(s + 2*z)
        -----------------,
                z

           2   2
         p2 *p3 *( - s - 2*z)
        ----------------------,
                 2     2
            z*(p1  + p3 )

                 2
          - p2*p3 *z
        -------------,
            2     2
          p1  + p3

        0,

         p1*p2*p3*z
        ------------},
           2     2
         p1  + p3

                     2     2     2
          - p1*p3*(p1  + p2  + p3 )
       {----------------------------,
                   2     2
                 p1  + p3

        0,

              2    2     2     2
          - p3 *(p1  + p2  + p3 )
        --------------------------,
                  2     2
                p1  + p3

          - p1*p2*p3*z
        ---------------,
             2     2
           p1  + p3

        p3*z,

                 2
          - p2*p3 *z
        -------------,
            2     2
          p1  + p3

               2      2     2     2
           - p3 *z*(p1  + p2  + p3 )
        -------------------------------,
           2       2       2       2
         p1 *s + p1 *z + p3 *s + p3 *z

        0,

                      2     2     2
           p1*p3*z*(p1  + p2  + p3 )
        -------------------------------},
           2       2       2       2
         p1 *s + p1 *z + p3 *s + p3 *z

       {0,0,0,0,0,0,0,0,0},

           2    2     2     2
         p1 *(p1  + p2  + p3 )
       {-----------------------,
                 2     2
               p1  + p3

        0,

                  2     2     2
         p1*p3*(p1  + p2  + p3 )
        -------------------------,
                  2     2
                p1  + p3

           2
         p1 *p2*z
        -----------,
           2     2
         p1  + p3

         - p1*z,

         p1*p2*p3*z
        ------------,
           2     2
         p1  + p3

                      2     2     2
           p1*p3*z*(p1  + p2  + p3 )
        -------------------------------,
           2       2       2       2
         p1 *s + p1 *z + p3 *s + p3 *z

        0,

               2      2     2     2
           - p1 *z*(p1  + p2  + p3 )
        -------------------------------}}
           2       2       2       2
         p1 *s + p1 *z + p3 *s + p3 *z


nullspace c1;


{{p3,0, - p1,0,0,0,0,0,0},

 {0,1,0,0,0,0,0,0,0},

 {0,0,0,p3,0, - p1,0,0,0},

                  2     2
 {0,0,0,0,p2*p3,p1  + p3 ,0,0,0},

 {0,0,0,0,0,0,p1,0,p3},

 {0,0,0,0,0,0,0,1,0}}

 
d1 := mat
(((p1**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1**2*p2*(s + z))/(p1**2 + p3**2)), p1*(s + z),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   (0, 0, 0, 0, 0, 0, 0, 0, 0),
  ((p1*p3*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2), 0,
   (p3**2*(p1**2 + p2**2 + p3**2 - s*z - z**2))/(p1**2 + p3**2),
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)), p3*(s + z),
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
  ( ((p1**2*p2*(s + z))/(p1**2 + p3**2)), 0,
   -((p1*p2*p3*(s + z))/(p1**2 + p3**2)),
   -((p1**2*p2**2*(s + 2*z))/((p1**2 + p3**2)*z)), (p1*p2*(s + 2*z))/z,
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)), 0, (p1**2*p2*z)/(p1**2 + p3**2)),
  (p1*(s + z), 0, p3*(s + z), (p1*p2*(s + 2*z))/z,
   -(((p1**2 + p3**2)*(s + 2*z))/z),(p2*p3*(s + 2*z))/z,p3*z,0,-(p1*z)),
  (-((p1*p2*p3*(s + z))/(p1**2 + p3**2)), 0,
   -((p2*p3**2*(s + z))/(p1**2 + p3**2)),
   -((p1*p2**2*p3*(s + 2*z))/((p1**2 + p3**2)*z)), (p2*p3*(s + 2*z))/z,
   -((p2**2*p3**2*(s + 2*z))/((p1**2 + p3**2)*z)),
   -((p2*p3**2*z)/(p1**2 + p3**2)), 0, (p1*p2*p3*z)/(p1**2 + p3**2)),
  (-((p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)), 0,
   -((p3**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2)),
   -((p1*p2*p3*z)/(p1**2 + p3**2)),p3*z,-((p2*p3**2*z)/(p1**2 + p3**2)),
   -((p3**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z))),
  (0, 0, 0, 0, 0, 0, 0, 0, 0), 
   ((p1**2*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2), 0,
   (p1*p3*(p1**2 + p2**2 + p3**2))/(p1**2 + p3**2),
   (p1**2*p2*z)/(p1**2 + p3**2), -(p1*z), (p1*p2*p3*z)/(p1**2 + p3**2),
   (p1*p3*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)), 0,
   -((p1**2*(p1**2 + p2**2 + p3**2)*z)/((p1**2 + p3**2)*(s + z)))));


              2    2     2     2          2
            p1 *(p1  + p2  + p3  - s*z - z )
d1 := mat((----------------------------------,0,
                         2     2
                       p1  + p3

                     2     2     2          2         2
            p1*p3*(p1  + p2  + p3  - s*z - z )    - p1 *p2*(s + z)
           ------------------------------------,-------------------,p1*(s + z),
                          2     2                      2     2
                        p1  + p3                     p1  + p3

                                              2     2     2
             - p1*p2*p3*(s + z)    - p1*p3*(p1  + p2  + p3 )
           ---------------------,----------------------------,0,
                   2     2                  2     2
                 p1  + p3                 p1  + p3

              2    2     2     2
            p1 *(p1  + p2  + p3 )
           -----------------------),
                    2     2
                  p1  + p3

          (0,0,0,0,0,0,0,0,0),

                     2     2     2          2
            p1*p3*(p1  + p2  + p3  - s*z - z )
          (------------------------------------,0,
                          2     2
                        p1  + p3

              2    2     2     2          2
            p3 *(p1  + p2  + p3  - s*z - z )    - p1*p2*p3*(s + z)
           ----------------------------------,---------------------,p3*(s + z),
                         2     2                      2     2
                       p1  + p3                     p1  + p3

                    2                2    2     2     2
             - p2*p3 *(s + z)    - p3 *(p1  + p2  + p3 )
           -------------------,--------------------------,0,
                  2     2                2     2
                p1  + p3               p1  + p3

                     2     2     2
            p1*p3*(p1  + p2  + p3 )
           -------------------------),
                     2     2
                   p1  + p3

              2                                        2   2
            p1 *p2*(s + z)      - p1*p2*p3*(s + z)   p1 *p2 *( - s - 2*z)
          (----------------,0,---------------------,----------------------,
                2     2               2     2                2     2
              p1  + p3              p1  + p3            z*(p1  + p3 )

                                   2
            p1*p2*(s + 2*z)   p1*p2 *p3*( - s - 2*z)    - p1*p2*p3*z
           -----------------,------------------------,---------------,0,
                   z                   2     2             2     2
                                  z*(p1  + p3 )          p1  + p3

              2
            p1 *p2*z
           -----------),
              2     2
            p1  + p3

                                    p1*p2*(s + 2*z)
          (p1*(s + z),0,p3*(s + z),-----------------,
                                           z

                 2         2       2         2
             - p1 *s - 2*p1 *z - p3 *s - 2*p3 *z   p2*p3*(s + 2*z)
           --------------------------------------,-----------------,p3*z,0,
                             z                            z

            - p1*z),

                                            2                2
             - p1*p2*p3*(s + z)      - p2*p3 *(s + z)   p1*p2 *p3*( - s - 2*z)
          (---------------------,0,-------------------,------------------------,
                   2     2                2     2                2     2
                 p1  + p3               p1  + p3            z*(p1  + p3 )

                                2   2                        2
            p2*p3*(s + 2*z)   p2 *p3 *( - s - 2*z)    - p2*p3 *z     p1*p2*p3*z
           -----------------,----------------------,-------------,0,------------
                   z                  2     2           2     2        2     2
                                 z*(p1  + p3 )        p1  + p3       p1  + p3

           ),

                        2     2     2           2    2     2     2
             - p1*p3*(p1  + p2  + p3 )      - p3 *(p1  + p2  + p3 )
          (----------------------------,0,--------------------------,
                      2     2                       2     2
                    p1  + p3                      p1  + p3

                                         2           2      2     2     2
             - p1*p2*p3*z         - p2*p3 *z     - p3 *z*(p1  + p2  + p3 )
           ---------------,p3*z,-------------,-------------------------------,0,
                2     2             2     2      2       2       2       2
              p1  + p3            p1  + p3     p1 *s + p1 *z + p3 *s + p3 *z

                         2     2     2
              p1*p3*z*(p1  + p2  + p3 )
           -------------------------------),
              2       2       2       2
            p1 *s + p1 *z + p3 *s + p3 *z

          (0,0,0,0,0,0,0,0,0),

              2    2     2     2               2     2     2      2
            p1 *(p1  + p2  + p3 )     p1*p3*(p1  + p2  + p3 )   p1 *p2*z
          (-----------------------,0,-------------------------,-----------,
                    2     2                    2     2            2     2
                  p1  + p3                   p1  + p3           p1  + p3

                                              2     2     2
                    p1*p2*p3*z     p1*p3*z*(p1  + p2  + p3 )
            - p1*z,------------,-------------------------------,0,
                      2     2      2       2       2       2
                    p1  + p3     p1 *s + p1 *z + p3 *s + p3 *z

                  2      2     2     2
              - p1 *z*(p1  + p2  + p3 )
           -------------------------------))
              2       2       2       2
            p1 *s + p1 *z + p3 *s + p3 *z



nullspace d1;


{

 [0]
 [ ]
 [1]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]

 ,


 [  0  ]
 [     ]
 [  0  ]
 [     ]
 [  0  ]
 [     ]
 [ p3  ]
 [     ]
 [  0  ]
 [     ]
 [ - p1]
 [     ]
 [  0  ]
 [     ]
 [  0  ]
 [     ]
 [  0  ]

 ,


 [    0    ]
 [         ]
 [    0    ]
 [         ]
 [    0    ]
 [         ]
 [    0    ]
 [         ]
 [  p2*p3  ]
 [         ]
 [  2     2]
 [p1  + p3 ]
 [         ]
 [    0    ]
 [         ]
 [    0    ]
 [         ]
 [    0    ]

 ,


 [0 ]
 [  ]
 [0 ]
 [  ]
 [0 ]
 [  ]
 [0 ]
 [  ]
 [0 ]
 [  ]
 [0 ]
 [  ]
 [p1]
 [  ]
 [0 ]
 [  ]
 [p3]

 ,


 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [0]
 [ ]
 [1]
 [ ]
 [0]

 }



% The following example, by Kenton Yee, was discussed extensively by
% the sci.math.symbolic newsgroup.

m := mat((e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), e^(-1), 0),
         (1, 1, 1, 1, 1, 1, 0, 1),(1, 1, 1, 1, 1, 0, 1, 1),
         (1, 1, 1, 1, 0, 1, 1, 1),(1, 1, 1, 0, 1, 1, 1, 1),
         (1, 1, 0, 1, 1, 1, 1, 1),(1, 0, 1, 1, 1, 1, 1, 1),
         (0, e, e, e, e, e, e, e));


     [ 1    1    1    1    1    1    1    ]
     [---  ---  ---  ---  ---  ---  ---  0]
     [ e    e    e    e    e    e    e    ]
     [                                    ]
     [ 1    1    1    1    1    1    0   1]
     [                                    ]
     [ 1    1    1    1    1    0    1   1]
     [                                    ]
m := [ 1    1    1    1    0    1    1   1]
     [                                    ]
     [ 1    1    1    0    1    1    1   1]
     [                                    ]
     [ 1    1    0    1    1    1    1   1]
     [                                    ]
     [ 1    0    1    1    1    1    1   1]
     [                                    ]
     [ 0    e    e    e    e    e    e   e]



eig := mateigen(m,x);


eig := {{x - 1,

         3,


         [        0        ]
         [                 ]
         [ - arbcomplex(20)]
         [                 ]
         [ - arbcomplex(19)]
         [                 ]
         [ - arbcomplex(18)]
         [                 ]
         [ arbcomplex(18)  ]
         [                 ]
         [ arbcomplex(19)  ]
         [                 ]
         [ arbcomplex(20)  ]
         [                 ]
         [        0        ]

         },

        {x + 1,

         3,


               arbcomplex(23)
         mat((----------------),
                     e

             (arbcomplex(22)),

             (arbcomplex(21)),

             (( - arbcomplex(23)*e - arbcomplex(23) - 2*arbcomplex(22)*e

                - 2*arbcomplex(21)*e)/(2*e)),

             (( - arbcomplex(23)*e - arbcomplex(23) - 2*arbcomplex(22)*e

                - 2*arbcomplex(21)*e)/(2*e)),

             (arbcomplex(21)),

             (arbcomplex(22)),

             (arbcomplex(23)))

},

             2        2
        { - e *x + e*x  - 6*e*x + 7*e - x,

         1,


                                  8         7        7        6          6
         mat(((6*arbcomplex(24)*(e *x + 23*e *x - 7*e  + 179*e *x - 119*e

                          5          5        4          4        3          3
                   + 565*e *x - 581*e  + 768*e *x - 890*e  + 565*e *x - 581*e

                          2          2                        3   8         7
                   + 179*e *x - 119*e  + 23*e*x - 7*e + x))/(e *(e *x + 30*e *x

                          7        6          6         5           5
                     - 7*e  + 333*e *x - 168*e  + 1692*e *x - 1365*e

                             4           4         3           3         2
                     + 4023*e *x - 4368*e  + 4470*e *x - 5145*e  + 2663*e *x

                             2
                     - 2520*e  + 576*e*x - 251*e + 36*x))),

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

                                9         8        8        7          7
             ((arbcomplex(24)*(e *x + 29*e *x - 7*e  + 310*e *x - 161*e

                           6           6         5           5         4
                   + 1520*e *x - 1246*e  + 3577*e *x - 3836*e  + 4283*e *x

                           4         3           3        2          2
                   - 4795*e  + 2988*e *x - 3065*e  + 978*e *x - 672*e  + 132*e*x

                                    2   8         7        7        6          6
                   - 42*e + 6*x))/(e *(e *x + 30*e *x - 7*e  + 333*e *x - 168*e

                             5           5         4           4         3
                     + 1692*e *x - 1365*e  + 4023*e *x - 4368*e  + 4470*e *x

                             3         2           2
                     - 5145*e  + 2663*e *x - 2520*e  + 576*e*x - 251*e + 36*x)))

              ,

             (arbcomplex(24)))

}}


% Now check the eigenvectors and calculate the eigenvalues in the
% respective eigenspaces:

factor expt;



for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;


eigenvalue = 1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = -1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


                    4       3       2                2
              sqrt(e  + 12*e  + 10*e  + 12*e + 1) + e  + 6*e + 1
eigenvalue = ----------------------------------------------------
                                     2*e

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


                       4       3       2                2
               - sqrt(e  + 12*e  + 10*e  + 12*e + 1) + e  + 6*e + 1
eigenvalue = -------------------------------------------------------
                                       2*e

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]



% For the special choice:

let e = -7 + sqrt 48;



% we get only 7 eigenvectors.

eig := mateigen(m,x);


eig := {{x + 1,

         4,


               arbcomplex(27)
         mat((----------------),
               4*sqrt(3) - 7

             (arbcomplex(26)),

             (arbcomplex(25)),

             ((2*sqrt(3)

               *( - arbcomplex(27) - 2*arbcomplex(26) - 2*arbcomplex(25))

                + 3*arbcomplex(27) + 7*arbcomplex(26) + 7*arbcomplex(25))/(

                 4*sqrt(3) - 7)),

             ((2*sqrt(3)

               *( - arbcomplex(27) - 2*arbcomplex(26) - 2*arbcomplex(25))

                + 3*arbcomplex(27) + 7*arbcomplex(26) + 7*arbcomplex(25))/(

                 4*sqrt(3) - 7)),

             (arbcomplex(25)),

             (arbcomplex(26)),

             (arbcomplex(27)))

},

        {x - 1,

         3,


         [        0        ]
         [                 ]
         [ - arbcomplex(30)]
         [                 ]
         [ - arbcomplex(29)]
         [                 ]
         [ - arbcomplex(28)]
         [                 ]
         [ arbcomplex(28)  ]
         [                 ]
         [ arbcomplex(29)  ]
         [                 ]
         [ arbcomplex(30)  ]
         [                 ]
         [        0        ]

         },

        {x + 7,

         1,


         [                 arbcomplex(31)                   ]
         [                -----------------                 ]
         [                 56*sqrt(3) - 97                  ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(31) + 24*arbcomplex(31) ]
         [--------------------------------------------------]
         [                168*sqrt(3) - 291                 ]
         [                                                  ]
         [                  arbcomplex(31)                  ]

         }}


for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;


eigenvalue = -1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = 1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = -7

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]



% The same behaviour for this choice of e.

clear e;

 let e = -7 - sqrt 48;



% we get only 7 eigenvectors.

eig := mateigen(m,x);


eig := {{x + 1,

         4,


                - arbcomplex(34)
         mat((-------------------),
                 4*sqrt(3) + 7

             (arbcomplex(33)),

             (arbcomplex(32)),

             ((2*sqrt(3)

               *( - arbcomplex(34) - 2*arbcomplex(33) - 2*arbcomplex(32))

                - 3*arbcomplex(34) - 7*arbcomplex(33) - 7*arbcomplex(32))/(

                 4*sqrt(3) + 7)),

             ((2*sqrt(3)

               *( - arbcomplex(34) - 2*arbcomplex(33) - 2*arbcomplex(32))

                - 3*arbcomplex(34) - 7*arbcomplex(33) - 7*arbcomplex(32))/(

                 4*sqrt(3) + 7)),

             (arbcomplex(32)),

             (arbcomplex(33)),

             (arbcomplex(34)))

},

        {x - 1,

         3,


         [        0        ]
         [                 ]
         [ - arbcomplex(37)]
         [                 ]
         [ - arbcomplex(36)]
         [                 ]
         [ - arbcomplex(35)]
         [                 ]
         [ arbcomplex(35)  ]
         [                 ]
         [ arbcomplex(36)  ]
         [                 ]
         [ arbcomplex(37)  ]
         [                 ]
         [        0        ]

         },

        {x + 7,

         1,


         [                 - arbcomplex(38)                 ]
         [               -------------------                ]
         [                 56*sqrt(3) + 97                  ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [  - 14*sqrt(3)*arbcomplex(38) - 24*arbcomplex(38) ]
         [--------------------------------------------------]
         [                168*sqrt(3) + 291                 ]
         [                                                  ]
         [                  arbcomplex(38)                  ]

         }}


for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;


eigenvalue = -1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = 1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = -7

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]




% For this choice of values

clear e;

 let e = 1;



% the eigenvalue 1 becomes 4-fold degenerate. However, we get a complete
% span of 8 eigenvectors.

eig := mateigen(m,x);


eig := {{x - 1,

         4,


         [ - arbcomplex(42)]
         [                 ]
         [ - arbcomplex(41)]
         [                 ]
         [ - arbcomplex(40)]
         [                 ]
         [ - arbcomplex(39)]
         [                 ]
         [ arbcomplex(39)  ]
         [                 ]
         [ arbcomplex(40)  ]
         [                 ]
         [ arbcomplex(41)  ]
         [                 ]
         [ arbcomplex(42)  ]

         },

        {x + 1,

         3,


         [                   arbcomplex(45)                    ]
         [                                                     ]
         [                   arbcomplex(44)                    ]
         [                                                     ]
         [                   arbcomplex(43)                    ]
         [                                                     ]
         [ - (arbcomplex(45) + arbcomplex(44) + arbcomplex(43))]
         [                                                     ]
         [ - (arbcomplex(45) + arbcomplex(44) + arbcomplex(43))]
         [                                                     ]
         [                   arbcomplex(43)                    ]
         [                                                     ]
         [                   arbcomplex(44)                    ]
         [                                                     ]
         [                   arbcomplex(45)                    ]

         },

        {x - 7,

         1,


         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]
         [              ]
         [arbcomplex(46)]

         }}


for each eispace in eig do
  begin scalar eivaleq,eival,eivec;
    eival := solve(first eispace,x);
    for each soln in eival do
      <>
  end;


eigenvalue = 1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = -1

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]


eigenvalue = 7

check of eigen equation: 

[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]
[ ]
[0]



ma := mat((1,a),(0,b));


      [1  a]
ma := [    ]
      [0  b]



% case 1:

let a = 0;



mateigen(ma,x);


{{x - 1,1,

  [arbcomplex(47)]
  [              ]
  [      0       ]

  },

 { - b + x,1,

  [      0       ]
  [              ]
  [arbcomplex(48)]

  }}


% case 2:

clear a;

 let a = 0, b = 1;



mateigen(ma,x);


{{x - 1,2,

  [arbcomplex(49)]
  [              ]
  [arbcomplex(50)]

  }}


% case 3:

clear a,b;

 

mateigen(ma,x);


{{ - b + x,

  1,


  [ arbcomplex(51)*a ]
  [------------------]
  [      b - 1       ]
  [                  ]
  [  arbcomplex(51)  ]

  },

 {x - 1,1,

  [arbcomplex(52)]
  [              ]
  [      0       ]

  }}


% case 4:

let b = 1;

 

mateigen(ma,x);


{{x - 1,2,

  [arbcomplex(53)]
  [              ]
  [      0       ]

  }}


% Example from H.G. Graebe:

m1:=mat((-sqrt(3)+1,2         ,3         ),
	(2         ,-sqrt(3)+3,1         ),
	(3         ,1         ,-sqrt(3)+2));


      [ - sqrt(3) + 1        2               3       ]
      [                                              ]
m1 := [      2          - sqrt(3) + 3        1       ]
      [                                              ]
      [      3               1          - sqrt(3) + 2]



nullspace m1;


{

 [ 3*sqrt(3) - 7  ]
 [                ]
 [  sqrt(3) + 5   ]
 [                ]
 [ - 4*sqrt(3) + 2]

 }


for each n in ws collect m1*n;


{

 [0]
 [ ]
 [0]
 [ ]
 [0]

 }


end;


Time for test: 125 ms, plus GC time: 31 ms
@@@@@ Resources used: (0 1 60 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/nullsp.red0000644000175000017500000001207511526203062024026 0ustar  giovannigiovannimodule nullsp;  % Compute the nullspace (basis vectors) of a matrix.

% Author: Herbert Melenk .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Algorithm:  Rational Gaussian elimination with standard qutotients.

put('nullspace,'psopfn,'nullspace!-eval);

symbolic procedure nullspace!-eval u;
   % interface for the nullspace calculation.
   begin scalar v,n,matinput;
     v := reval car u;
     if eqcar(v,'MAT) then
        <>
     else if eqcar(v,'LIST) then
      v := for each row in cdr v collect
        if not eqcar(row,'LIST) then typerr ("matrix",u) else
        <> else rerror(matrix,16,"Not a matrix");
     v := nullspace!-alg v;
     return 'list . for each vect in v collect
         if matinput then 'MAT . for each x in vect collect list x
           else 'LIST . vect;
   end;

symbolic procedure nullspace!-alg(m);
   % "M" is a Matrix, encoded as list of lists(=rows) of algebraic
   % expressions.
   % Result is the basis of the kernel of M in the same encoding.
   begin scalar mp,vars,rvars,r,res,oldorder; integer n;
     n := length car m;
     vars := for i:=1:n collect gensym();
     rvars := reverse vars;
     oldorder := setkorder rvars;
     mp := for each row in m collect
     <>;
     res := nullspace!-elim(mp,rvars);
     setkorder oldorder;
     return reverse for each q in res collect
       for each x in vars collect
        cdr atsoc(x,q);
   end;

symbolic procedure nullspace!-elim(m,vars);
   % "M" is a matrix encoded as list of linear polnomials (sq's) in
   % the variables "vars". The current korder cooresponds to vars.
   % Result is a basis for the null space of the matrix, encoded
   % as list of vectors, where each vector is an alist over vars.
   % A rational Gaussian elimination is performed and unit vectors
   % are substituted for the remaining unrestricted variables.
  begin scalar c,s,x,w,arbvars,depvars,row,res,break;
     while vars and not break do
     <>;
            p>>;
        >>;
      >>;
    >>;
    if break then return nil;
         % Construct solutions by assigning unit vectors to the
         % free variables and perform backsubstitution.
    for each x in arbvars do
    << s := for each y in arbvars collect
          (y . if y=x then 1 else 0);
       c := 1;
       for each y in depvars do
       << s := (car y . prepsq (w:=subsq(cdr y,s))) . s;
          c := lcm!*(c,denr w)
       >>;
       if not(c=1) then <>;
       res := s . res;
    >>;
    return res;
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/matsm.red0000644000175000017500000001455311526203062023635 0ustar  giovannigiovannimodule matsm; % Simplification of matrices.

% Author: Anthony C. Hearn.

% Copyright (c) 1998 Anthony C. Hearn. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module is rife with essential references to RPLAC-based
% functions.

symbolic procedure matsm!*(u,v);
   % Matrix expression simplification function.
   matsm!*1 matsm u;

% symbolic procedure matsm!*1 u;
%    begin scalar sub2;
%       sub2 := !*sub2;  % Since we need value for each element.
%       u := 'mat . for each j in u collect
%                      for each k in j
%                         collect <>;
%       !*sub2 := nil;   % Since all substitutions done.
%       return u
%    end;

symbolic procedure matsm!*1 u;
   begin
      % We use subs2!* to make sure each element simplified fully.
      u := 'mat . for each j in u collect
                     for each k in j collect !*q2a subs2!* k;
      !*sub2 := nil;   % Since all substitutions done.
      return u
   end;

symbolic procedure matsm u;
   begin scalar x,y;
      for each j in nssimp(u,'matrix) do
         <>;
      return x
   end;

symbolic procedure matsm1 u;
   %returns matrix canonical form for matrix symbol product U;
   begin scalar x,y,z; integer n;
    a:  if null u then return z
         else if eqcar(car u,'!*div) then go to d
         else if atom car u then go to er
         else if caar u eq 'mat then go to c1
         else if flagp(caar u,'matmapfn) and cdar u
            and getrtype cadar u eq 'matrix
          then x := matsm matrixmap(car u,nil)
         else <>;
    b:  z := if null z then x
              else if null cdr z and null cdar z then multsm(caar z,x)
              else multm(x,z);
    c:  u := cdr u;
        go to a;
    c1: if not lchk cdar u then rerror(matrix,3,"Matrix mismatch");
        x := for each j in cdar u collect
                for each k in j collect xsimp k;
        go to b;
    d:  y := matsm cadar u;
        if (n := length car y) neq length y
          then rerror(matrix,4,"Non square matrix")
         else if (z and n neq length z)
          then rerror(matrix,5,"Matrix mismatch")
         else if cddar u then go to h
         else if null cdr y and null cdar y then go to e;
        x := subfg!*;
        subfg!* := nil;
        if null z then z := apply1(get('mat,'inversefn),y)
         else if null(x := get('mat,'lnrsolvefn))
          then z := multm(apply1(get('mat,'inversefn),y),z)
         else z := apply2(get('mat,'lnrsolvefn),y,z);
        subfg!* := x;
        % Make sure there are no power substitutions.
        z := for each j in z collect for each k in j collect
                 <>;
        go to c;
    e:  if null caaar y then rerror(matrix,6,"Zero divisor");
        y := revpr caar y;
        z := if null z then list list y else multsm(y,z);
        go to c;
     h: if null z then z := generateident n;
        go  to c;
    er: rerror(matrix,7,list("Matrix",car u,"not set"))
   end;

symbolic procedure lchk u;
   begin integer n;
        if null u or atom car u then return nil;
        n := length car u;
        repeat u := cdr u
           until null u or atom car u or length car u neq n;
        return null u
   end;

symbolic procedure addm(u,v);
   % Returns sum of two matrix canonical forms U and V.
   % Returns U + 0 as U. Patch by Francis Wright.
   if v = '(((nil . 1))) then u else       % FJW.
   for each j in addm1(u,v,function cons)
      collect addm1(car j,cdr j,function addsq);

symbolic procedure addm1(u,v,w);
   if null u and null v then nil
    else if null u or null v then rerror(matrix,8,"Matrix mismatch")
    else apply2(w,car u,car v) . addm1(cdr u,cdr v,w);

symbolic procedure tp u; tp1 matsm u;

put('tp,'rtypefn,'getrtypecar);

symbolic procedure tp1 u;
   %returns transpose of the matrix canonical form U;
   %U is destroyed in the process;
   begin scalar v,w,x,y,z;
        v := w := list nil;
        while car u do
         <>;
           w := cdr rplacd(w,list cdr y)>>;
        return cdr v
   end;

symbolic procedure scalprod(u,v);
   %returns scalar product of two lists (vectors) U and V;
   if null u and null v then nil ./ 1
    else if null u or null v then rerror(matrix,9,"Matrix mismatch")
    else addsq(multsq(car u,car v),scalprod(cdr u,cdr v));

symbolic procedure multm(u,v);
   %returns matrix product of two matrix canonical forms U and V;
   (for each y in u
      collect for each k in x collect subs2 scalprod(y,k))
     where x = tp1 v;

symbolic procedure multsm(u,v);
   %returns product of standard quotient U and matrix standard form V;
   if u = (1 ./ 1) then v
    else for each j in v collect for each k in j collect multsq(u,k);

% Explicit substitution code for matrices.

symbolic procedure matsub(u,v);
   'mat . for each x in cdr v collect
              for each y in x collect subeval1(u,y);

put('matrix,'subfn,'matsub);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/matpri.red0000644000175000017500000001437511526203062024012 0ustar  giovannigiovannimodule matpri;   % Matrix printing routines.

% Author: Anthony C. Hearn.
% Modified by Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*nat obrkp!* orig!* pline!* posn!* ycoord!* ymax!* ymin!*);

symbolic procedure setmatpri(u,v);
   matpri1(cdr v,u);

put('mat,'setprifn,'setmatpri);

symbolic procedure matpri u;
   matpri1(cdr u,nil);

symbolic procedure matpri1(u,x);
   % Prints a matrix canonical form U with name X.
   % Tries to do fancy display if nat flag is on.
   begin scalar m,n,r,l,w,e,ll,ok,name,nw,widths,firstflag,toprow,lbar,
                rbar,realorig;
      if !*fort
        then <>;
                    m := m+1>>;
               return nil>>;
      terpri!* t;
      if x and !*nat then <<
         name := layout!-formula(x, 0, nil);
         if name then <<
           nw := cdar name + 4;
           ok := !*nat >>>>
       else <>;
      ll := linelength nil - spare!* - orig!* - nw;
      m := length car u;
      widths := mkvect(1 + m);
      for i := 1:m do putv(widths, i, 1);
      % Collect sizes for all elements to see if it will fit in
      % displayed matrix form.
      % We need to compute things wrt a zero orig for the following
      % code to work properly.
      realorig := orig!*;
      orig!* := 0;
      if ok then for each y in u do
       < ll then ok := nil
                else <<
                  l := e . l;
                  putv(widths, n, col) >> end;
            n := n+1>>;
         r := (reverse l) . r >>;
         if ok then <<
         % Matrix will fit in displayed representation.
         % Compute format with respect to 0 posn.
         firstflag := toprow := t;
         r := for each py on reverse r collect begin
            scalar y, ymin, ymax, pos, pl, k, w;
            ymin := ymax := 0;
            pos := 1;    % Since "[" is of length 1.
            k := 1;
            pl := nil;
            y := car py;
            for each z in y do <<
               w := getv(widths, k);
               pl := append(update!-pline(pos+(w-cdar z)/2,0,caar z),
                            pl);      % Centre item in its field
               pos := pos + w + 2;    % 2 blanks between cols
               k := k + 1;
               ymin := min(ymin, cadr z);
               ymax := max(ymax, cddr z) >>;
            k := nil;
            if firstflag then firstflag := nil
             else ymax := ymax + 1;   % One blank line between rows
            for h := ymax step -1 until ymin do <<
               if toprow then <<
                  lbar := symbol 'mat!-top!-l;
                  rbar := symbol 'mat!-top!-r;
                  toprow := nil >>
                else if h = ymin and null cdr py then <<
                  lbar := symbol 'mat!-low!-l;
                  rbar := symbol 'mat!-low!-r >>
%               else lbar := rbar := symbol 'vbar;
                else <>;
               pl := ((((pos - 2) . (pos - 1)) . h) . rbar) . pl;
               k := (((0 . 1) . h) . lbar) . k >>;
            return (append(pl, k) . pos) . (ymin . ymax) end;
         orig!* := realorig;
         w := 0;
         for each y in r do w := w + (cddr y - cadr y + 1);
               % Total height.
         n := w/2;  % Height of mid-point.
         u := nil;
         for each y in r do <<
            u := append(update!-pline(0, n - cddr y, caar y), u);
            n := n - (cddr y - cadr y + 1) >>;
         if x then <>;
         pline!* := append(update!-pline(posn!*,ycoord!*,u),
                           pline!*);
         ymax!* := max(ycoord!* + w/2, ymax!*);
         ymin!* := min(ycoord!* + w/2 - w, ymin!*);
         terpri!*(not !*nat)>>
      else <>; matpri2 u>>
   end;

symbolic procedure matpri2 u;
   begin scalar y;
      prin2!* 'mat;
      prin2!* "(";
      obrkp!* := nil;
      y := orig!*;
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      while u do
         <>;
           u := cdr u>>;
      obrkp!* := t;
      orig!* := y;
      prin2!* ")";
      if null !*nat then prin2!* "$";
      terpri!* t
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/extops.red0000644000175000017500000001566511526203062024043 0ustar  giovannigiovannimodule extops;  % Support for exterior multiplication.

% Author: Eberhard Schrufer.
% Modifications by: David Hartley.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Data structure for simple exterior forms is

        ex ::= nil | lpow ex .* lc ex .+ ex
        lpow ex ::= list of kernel
        lc ex    ::= sf

All forms have degree > 0. lpow ex is a list of factors in a basis form;

symbolic procedure !*sf2ex(u,v);
   %Converts standardform u into a form distributed w.r.t. v
%*** Should we check here if lc is free of v?
   if null u then nil
    else if domainp u or null(mvar u memq v) then list nil .* u .+ nil
    else list mvar u .* lc u .+ !*sf2ex(red u,v);

symbolic procedure !*ex2sf u;
   % u: ex -> !*ex2sf: sf
   % reconverts 1-form u, but doesn't check ordering
   if null u then nil
   else if car lpow u = nil then subs2chk lc u
   else car lpow u .** 1 .* subs2chk lc u .+ !*ex2sf red u;

symbolic procedure extmult(u,v);
   % u,v: ex -> extmult: ex
   % Special exterior multiplication routine.  Degree of form v is
   % arbitrary, u is a one-form.
   if null u or null v then nil
    else (if x then cdr x .* (if car x then negf c!:subs2multf(lc u,lc v)
                               else c!:subs2multf(lc u,lc v))
                          .+ extadd(extmult(!*t2f lt u,red v),
                                    extmult(red u,v))
           else extadd(extmult(red u,v),extmult(!*t2f lt u,red v)))
          where x = ordexn(car lpow u,lpow v);

symbolic procedure extadd(u,v);
   % u,v: ex -> extadd: ex
   % a non-recursive exterior addition routine
   % u and v are of same degree
   % relies on setq functions for red
   if null u then v
   else if null v then u
   else
      begin scalar s,w,z;
      s := z := nil .+ nil;
      while u and v do
         if lpow v = lpow u then               % add coefficients
          <>;
            u := red u; v := red v>>
         else if ordexp(lpow v,lpow u) then   % swap v and u
          <>
         else
          <>;
      red z := if u then u else v;
      return red s;
      end;

symbolic procedure ordexp(u,v);
   if null u then t
    else if car u eq car v then ordexp(cdr u,cdr v)
    else if null car u then nil
    else if null car v then t
    else ordop(car u,car v);

symbolic procedure ordexn(u,v);
   %u is a single variable, v a list. Returns nil if u is a member
   %of v or a dotted pair of a permutation indicator and the ordered
   %list of u merged into v.
   begin scalar s,x;
     a: if null v then return(s . reverse(u . x))
         else if u eq car v then return nil
         else if u and ordop(u,car v) then
                 return(s . append(reverse(u . x),v))
         else  <>;
         go to a
   end;

symbolic procedure quotexf!*(u,v);
   % u: ex, v: sf -> quotexf!*: ex
   % catastrophe if division fails
   if null u then nil
   else lpow u .* quotfexf!*1(lc u,v) .+ quotexf!*(red u,v);

symbolic procedure quotfexf!*1(u,v);
   % We do the rationalizesq step to allow for surd divisors.
   if null u then nil
    else (if x then x
           else (if denr y = 1 then numr y
                 % Try once more.
                  else if denr (y := (rationalizesq y
                                         where !*rationalize = t))=1
                   then numr y
                  else rerror(matrix,11,
                              "Catastrophic division failure"))
                 where y=rationalizesq(u ./ v))
          where x=quotf(u,v);

symbolic procedure negex u;
   % u: ex -> negex: ex
   if null u then nil
   else lpow u .* negf lc u .+ negex red u;

symbolic procedure splitup(u,v);
   % u: ex, v: list of kernel -> splitup: {ex,ex}
   % split 1-form u into part free of v (not containing nil), and rest
   % assumes u ordered wrt v
   if null u then {nil,nil}
   else if null x or memq(x,v) where x = car lpow u then {nil,u}
   else {lt u .+ car x, cadr x} where x = splitup(red u,v);


symbolic procedure innprodpex(v,u);
   % v: lpow ex, u: ex -> innprodpex: ex
   % v _| u = v _| lt u .+ v _| red u (order is correct)
   if null u then nil else
   (if x then cdr x .* (if car x then negf lc u else lc u)
                    .+ innprodpex(v,red u)
    else innprodpex(v,red u))
    where x = innprodp2(v,lpow u);


symbolic procedure innprodp2(v,u);
   % u,v: lpow ex -> innprodp2: nil or bool . lpow ex
   % returns sign of permutation as well
   % (x^y) _| u =  y _| (x _| u)
   begin
   u := nil . u;
   while v and u do
    <>;
   return u;
   end;


symbolic procedure innprodkp(w,v,u,s);
   % w,u: lpow ex or nil, v: kernel, s: bool
   % -> innprodkp: nil or bool . lpow ex
   % w,u are exterior forms, v is vector in dual space
   % calulates w^(v _| u), assuming degree u > 1 and returns sign
   % permutation as well
   if null u then nil
   else if v = car u then s . nconc(reversip w,cdr u)
   else innprodkp(car u . w,v,cdr u,not s);


symbolic procedure subs2chkex u;
   % u:ex -> subs2chkex:ex
   % Leading coefficient of return value has been subs2chk'ed
   if null u then nil
   else (if x then lpow u .* x .+ red u else subs2chkex red u)
         where x = subs2chk lc u;


symbolic procedure subs2chk u;
   % This definition allows for a power substitution that can lead to
   % a denominator in subs2.  We omit the test for !*sub2 and powlis1!*
   % to make sure the check is made.  Maybe this can be optimized.
   begin scalar x;
      if subfg!* and denr(x := subs2f u)=1 then u := numr x;
      return u
     end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/cofactor.red0000644000175000017500000000445011526203062024307 0ustar  giovannigiovannimodule cofactor;   % Cofactor operator.

% Author: Alan Barnes .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


comment

Syntax:  COFACTOR(MATRIX:matrix,ROW:integer,COLUMN:integer):algebraic

The cofactor of the element in row ROW and column COLUMN of matrix
MATRIX is returned.  Errors occur if ROW or COLUMN do not simplify to
integer expressions or if MATRIX is not square;

symbolic procedure cofactorq (u,i,j);
   begin integer len;
      len:= length u;
      if not(i>0 and i0 and j>;
      IF !*FORT THEN RETURN FTERPRI U
       ELSE IF NOT PLINE!* OR NOT !*NAT THEN GO TO B;
      N := YMAX!*;
      PLINE!* := REVERSE PLINE!*;
    A:
      SCPRINT(PLINE!*,N);
      TERPRI();
      IF N=YMIN!* THEN GO TO B;
      N := N - 1;
      GO TO A;
    B:
      IF U THEN TERPRI();
    C:
      PLINE!* := NIL;
      POSN!* := ORIG!*;
      YCOORD!* := YMAX!* := YMIN!* := 0
   END;

SYMBOLIC PROCEDURE PLUS!-L U; PLUS!-L1(0,U);

SYMBOLIC PROCEDURE PLUS!-L1(N,U);
   IF NULL U THEN N ELSE <>;

SYMBOLIC PROCEDURE DELNTH(N,L);
   IF N=1 THEN CDR L ELSE CAR L . DELNTH(N - 1,CDR L);


% MATRIX Pretty printer.

SYMBOLIC PROCEDURE MAT!-P!-PRINT U;
   BEGIN INTEGER C!-LENG1,ICOLN,PP,ICOL,COLUMN!-LENG,M,N;
         SCALAR COLUMN!-S!-POINT,MAXLENG,ELEMENT!-LENG;
      U := CDR U;
      ICOLN := LENGTH CAR U;
      ICOL := LINELENGTH NIL - 8;
      !&M!-P!-FLAG!& := T;
      ELEMENT!-LENG := !&COUNT U;
      !&M!-P!-FLAG!& := NIL;
    A:
      MAXLENG := !&MAX!-ROW ELEMENT!-LENG;
      C!-LENG1 := PLUS!-L MAXLENG + 3*(ICOLN - 1);
      IF C!-LENG1=COLUMN!-LENG THEN GO TO DUMP;
      COLUMN!-LENG := C!-LENG1;
      IF COLUMN!-LENG>ICOL
        THEN <>;
      PRIN2!* !&NAME;
      PRIN2!* " := ";
      TERPRI!* NIL;
      N := 0;
      COLUMN!-S!-POINT :=
       FOR EACH Y IN MAXLENG COLLECT <>;
      COLUMN!-S!-POINT := APPEND(LIST 3,COLUMN!-S!-POINT);
      TERPRI();
      PRIN2 "|-";
      SPACES (COLUMN!-LENG + 4);
      PRIN2 "-|";
      TERPRI();
      M := 1;
      FOR EACH Y IN U DO
         <>
                 ELSE MAPRIN Z;
                N := N + 1>>;
           PP := COLUMN!-LENG + 7;
           FOR I := YMIN!*:YMAX!* DO
              <>;
           TERPRI!* NIL;
           M := M + 1;
           PRIN2 "| ";
           SPACES (COLUMN!-LENG + 4);
           PRIN2 " |";
           TERPRI()>>;
      PRIN2 "|-";
      SPACES (COLUMN!-LENG + 4);
      PRIN2 "-|";
      TERPRI();
      TERPRI();
      M := 1;
      FOR EACH Y IN U DO
         <>;
                N := N + 1>>;
           M := M + 1>>;
      RETURN NIL;
    DUMP:
      PRIN2T "Column length too long";
      MATPRI!*('MAT . U,LIST MKQUOTE !&NAME,'ONLY)
   END;

SYMBOLIC PROCEDURE !&COUNT U;
   BEGIN INTEGER N;
      RETURN FOREACH Y IN U COLLECT
                FOREACH Z IN Y COLLECT
                   <>;
   END;

GLOBAL '(!&MAX!-L);

SYMBOLIC PROCEDURE !&MAX!-ROW U;
   BEGIN SCALAR V;
    A:
      IF NULL CAR U THEN RETURN V;
      U := !&MAX!-ROW1 U;
      V := APPEND(V,LIST !&MAX!-L);
      GO TO A
   END;

SYMBOLIC PROCEDURE !&MAX!-ROW1 U;
   BEGIN
      !&MAX!-L := 1;
      RETURN FOR EACH Y IN U COLLECT
                <>
   END;

SYMBOLIC PROCEDURE MAXL U; MAXL1(CDR U,CAR U);

SYMBOLIC PROCEDURE MAXL1(U,V);
   IF NULL U THEN V
    ELSE IF CAR U>V THEN MAXL1(CDR U,CAR U)
    ELSE MAXL1(CDR U,V);

SYMBOLIC PROCEDURE MPRINT U;
   BEGIN SCALAR V;
    A:
      IF NULL U THEN RETURN NIL
       ELSE IF ATOM CAR U AND (V := GET(CAR U,'MATRIX))
        THEN <>
       ELSE IF STRINGP CAR U THEN VARPRI(CAR U,NIL,'ONLY)
       ELSE IF V := ARRAYP CAR U
        THEN <>
       ELSE <>;
    B:
      U := CDR U;
      GO TO A
   END;

RLISTAT '(MPRINT);

SYMBOLIC PROCEDURE PRINT!-ARRAY2(U,W);
   BEGIN INTEGER N; SCALAR V;
      V := CAR U;
      IF CAR V EQ '!&VECTOR
        THEN BEGIN
                N := CADR V;
                V := CDR V;
                IF W THEN W := CAR W;
                FOR I := 0:N DO
                   <>
             END
       ELSE IF V NEQ 0
        THEN <>
   END;


% Rational function Pretty printer.

SYMBOLIC PROCEDURE RAT!-P!-PRINT U;
   BEGIN INTEGER OS,LN,ORGNUM,ORGDEN,LL,LENNUM,LENDEN;
         SCALAR NAME,UDEN,UNUM;
      IF NULL U THEN RETURN NIL;
      IF NUMBERP U
        THEN <>;
      U := CADR U;
      !&M!-P!-FLAG!& := T;
      LENDEN := !&COUNT!-LENGTH (UDEN := CDR U./1);
      LENNUM := !&COUNT!-LENGTH (UNUM := CAR U./1);
      !&M!-P!-FLAG!& := NIL;
      LN := (LINELENGTH NIL - LENGTHC !&NAME) - 4;
      OS := ORIG!*;
      IF CDR U=1 OR LENDEN>LN OR LENNUM>LN THEN GO TO DUMP;
      IF !&NAME
        THEN <>;
      IF LENDEN>LENNUM
        THEN <>
       ELSE <>;
      POSN!* := ORGNUM + OS + 1;
      MAPRIN MK!*SQ UNUM;
      TERPRI!* NIL;
      IF NAME THEN PLINE!* := NAME ELSE PLINE!* := NIL;
      POSN!* := OS;
      FOR I := 1:LL + 2 DO PRIN2!* "-";
      TERPRI!* NIL;
      POSN!* := ORGDEN + OS + 1;
      MAPRIN MK!*SQ UDEN;
      TERPRI!* T;
      RETURN NIL;
    DUMP:
      VARPRI(MK!*SQ U,LIST MKQUOTE !&NAME,'ONLY);
      TERPRI();
      !&NAME := NIL
   END;

SYMBOLIC PROCEDURE !&COUNT!-LENGTH U;
   BEGIN INTEGER N;
      !&COUNT!& := NIL;
      MAPRIN MK!*SQ U;
      N := POSN!* - ORIG!*;
      IF !&COUNT!& THEN N := LINELENGTH NIL + 10;
      PLINE!* := NIL;
      POSN!* := ORIG!*;
      YCOORD!* := YMAX!* := YMIN!* := 0;
      RETURN N
   END;

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/nestdom.red0000644000175000017500000001441211526203062024157 0ustar  giovannigiovannimodule nestdom; % nested domain: domain elements are standard quotients
                % coefficients are taken from the integers or another
                % dnest.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Original version by Herbert Melenk, 1993(?)

% Improved version with Rainer mod.

% Changes to nestlevel, nestdmode and nestsq by Winfried Neun, 1998.


%%%%%%%%%
% Adaption to allow convertion between arnum and nested.
%%%%%%%%%
symbolic procedure ident(x);x;
put('!:ar!:,'!:nest!:,'ident);
%%%%%%%%%

% data structure:
%  a domain element is a list
%      ('!:nest!: level# dmode* . sq)

smacro procedure nestlevel u; if fixp u then 0 else cadr u;
smacro procedure nestdmode u; if fixp u then nil else caddr u;
smacro procedure nestsq u; if fixp u then simp u else cdddr u;

global '(domainlist!*);

fluid '(alglist!* nestlevel!*);
nestlevel!* := 0;

switch nested;

domainlist!* := union('(!:nest!:),domainlist!*);

put('nested,'tag,'!:nest!:);
put('!:nest!:,'dname,'nested);
flag('(!:nest!:),'field);
flag('(!:nest!:),'convert);
put('!:nest!:,'i2d,'!*i2nest);
%put('!:nest!:,'!:bf!:,'nestcnv);
%put('!:nest!:,'!:ft!:,'nestcnv);
%put('!:nest!:,'!:rn!:,'nestcnv);
put('!:nest!:,'!:bf!:,mkdmoderr('!:nest!:,'!:bf!:));
put('!:nest!:,'!:ft!:,mkdmoderr('!:nest!:,'!:ft!:));
put('!:nest!:,'!:rn!:,mkdmoderr('!:nest!:,'!:rn!:));
put('!:nest!:,'minusp,'nestminusp!:);
put('!:nest!:,'plus,'nestplus!:);
put('!:nest!:,'times,'nesttimes!:);
put('!:nest!:,'difference,'nestdifference!:);
put('!:nest!:,'quotient,'nestquotient!:);
put('!:nest!:,'divide,'nestdivide!:);
% put('!:nest!:,'gcd,'nestgcd!:);
put('!:nest!:,'zerop,'nestzerop!:);
put('!:nest!:,'onep,'nestonep!:);
% put('!:nest!:,'factorfn,'factornest!:);
put('!:nest!:,'prepfn,'nestprep!:);
put('!:nest!:,'prifn,'prin2);
put('!:rn!:,'!:nest!:,'rn2nest);

symbolic procedure !*i2nest u;
   %converts integer u to nested form;
   if domainp u then u else
   '!:nest!: . 0 . dmode!* . (u ./ 1);

symbolic procedure rn2nest u;
   %converts integer u to nested form;
   if domainp u then u else
   '!:nest!: . 0 . dmode!* . (cdr u);


symbolic procedure nestcnv u;
   rederr list("Conversion between `nested' and",
                get(car u,'dname),"not defined");

symbolic procedure nestminusp!: u;
         nestlevel u = 0 and minusf car nestsq u;

symbolic procedure sq2nestedf sq;
   '!:nest!: . nestlevel!* . dmode!* . sq;

symbolic procedure nest2op!:(u,v,op);
  (begin scalar r,nlu,nlv,nlr,dm,nestlevel!*;
     nlu := if not eqcar (u,'!:nest!:) then 0 else nestlevel u;
     nlv := if not eqcar (v,'!:nest!:) then 0 else nestlevel v;
     if nlu = nlv then goto case1
     else if nlu #> nlv then goto case2
     else goto case3;
   case1:    % same level for u and v
            dm := nestdmode u;
            if dm then setdmode(dm,t);
            nlr := nlu;
            nestlevel!* := nlu - 1;
            r := apply(op,list(nestsq u,nestsq v));
            goto ready;
   case2:    % v below u
            dm := nestdmode u;
            if dm then setdmode(dm,t);
            nlr := nlu;
            nestlevel!* := nlv;
            r := apply(op,list (nestsq u, v ./ 1));
            goto ready;
   case3:     % u below v
            dm := nestdmode v;
            if dm then setdmode(dm,t);
            nlr := nlv;
            nestlevel!* := nlu;
            r := apply(op,list (u ./ 1,nestsq v));
   ready:
            r := if null numr r then nil
            % The next line was commented out for a while, but is
            % needed for the normform tests.
                else if domainp numr r and denr r = 1 then numr r
                else '!:nest!: . nlr . dm . r;
            if dm then setdmode (dm,nil);
            return r;
   end )  where dmode!* = nil;

symbolic procedure nestplus!:(u,v); nest2op!:(u,v,'addsq);

symbolic procedure nesttimes!:(u,v); nest2op!:(u,v,'multsq);

symbolic procedure nestdifference!:(u,v);
    nest2op!:(u,v,function (lambda(x,y); addsq(x,negsq y)));

symbolic procedure nestdivide!:(u,v); nest2op!:(u,v,'quotsq) . 1;

% symbolic procedure nestgcd!:(u,v); !*i2nest 1;

symbolic procedure nestquotient!:(u,v); nest2op!:(u,v,'quotsq);

symbolic procedure nestzerop!: u; null numr nestsq u;

symbolic procedure nestonep!: u;
       (car v = 1 and cdr v = 1) where v = nestsq u;

initdmode 'nested;


% nested routines are defined in the gennest nestule with the exception
% of the following:

symbolic procedure setnest u;
   begin
      u := reval u;
      if not fixp u then typerr(u,"nestulus");
      nestlevel!* := u;
   end;

flag('(setnest),'opfn);   %to make it a symbolic operator;

flag('(setnest),'noval);

algebraic operator co;

symbolic procedure simpco u;
 % conmvert an expression to a nested coefficient
   begin scalar  sq,lev;
     if not (length u = 2 and fixp car u) then
             typerr(u,"nested coefficient");
     sq := simp cadr u;
     lev := car u;
     return (if null numr sq then nil else ('!:nest!: . lev . dmode!* .
                                                 sq)) ./ 1;
   end;

put('co,'simpfn,'simpco);

symbolic procedure nestprep!: u; list('co,nestlevel u,prepsq nestsq u);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/matrix.red0000644000175000017500000001426511526203062024020 0ustar  giovannigiovannimodule matrix;  % Header for matrix package.

% Author: Anthony C. Hearn.

% Copyright (c) 1998 Anthony C. Hearn. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This module has one reference to rplaca.

create!-package('(matrix matsm matpri extops bareiss det glmat nullsp
                  rank nestdom resultnt cofactor),nil);

fluid '(!*sub2 subfg!*);

global '(nxtsym!*);

symbolic procedure matrix u;
   % Declares list U as matrices.
   begin scalar w,x,y;
        for each j in u do
           if atom j then if null (x := gettype j)
                            then put(j,'rtype,'matrix)
                           else if x eq 'matrix
                            then <>
                           else typerr(list(x,j),"matrix")
            else if not idp car j then errpri2(j,'hold)
            else if not (x := gettype car j) or x eq 'matrix
             then <>
            else typerr(list(x,car j),"matrix")
   end;

rlistat '(matrix);

symbolic procedure nzero n;
   % Returns a list of N zeros.
   if n=0 then nil else 0 . nzero(n-1);

% Parsing interface.

symbolic procedure matstat;
   % Read a matrix.
   begin scalar x,y;
      if not (nxtsym!* eq '!() then symerr("Syntax error",nil);
   a: scan();
      if not (scan() eq '!*lpar!*) then symerr("Syntax error",nil);
      y := xread 'paren;
      if not eqcar(y,'!*comma!*) then y := list y else y := remcomma y;
      x := y . x;
      if nxtsym!* eq '!)
        then return <>
       else if not(nxtsym!* eq '!,) then symerr("Syntax error",nil);
      go to a
   end;

put('mat,'stat,'matstat);

symbolic procedure formmat(u,vars,mode);
   'list . mkquote car u
     . for each x in cdr u collect('list . formlis(x,vars,mode));

put('mat,'formfn,'formmat);

put('mat,'i2d,'mkscalmat);

put('mat,'inversefn,'matinverse);

put('mat,'lnrsolvefn,'lnrsolve);

put('mat,'rtypefn,'quotematrix);

symbolic procedure quotematrix u; 'matrix;

flag('(mat tp),'matflg);

flag('(mat),'noncommuting);

put('mat,'prifn,'matpri);

flag('(mat),'struct);      % for parsing

put('matrix,'fn,'matflg);

put('matrix,'evfn,'matsm!*);

flag('(matrix),'sprifn);

put('matrix,'tag,'mat);

put('matrix,'lengthfn,'matlength);

put('matrix,'getelemfn,'getmatelem);

put('matrix,'setelemfn,'setmatelem);

symbolic procedure mkscalmat u;
   % Converts id u to 1 by 1 matrix.
   list('mat,list u);

symbolic procedure getmatelem u;
   % This differs from setmatelem in that let x=y, where y is a
   % matrix, should work.
   begin scalar x,y;
      if length u neq 3 then typerr(u,"matrix element");
      x := get(car u,'avalue);
      if null x or not(car x eq 'matrix) then typerr(car u,"matrix")
       else if not eqcar(x := cadr x,'mat)
        then if idp x then return getmatelem (x . cdr u)
         else rerror(matrix,1,list("Matrix",car u,"not set"));
      y := reval_without_mod cadr u;
      if not fixp y or y<=0 then typerr(y,"positive integer");
      x := nth(cdr x,y);
      y := reval_without_mod caddr u;
      if not fixp y or y<=0 then typerr(y,"positive integer");
      return nth(x,y)
   end;

symbolic procedure setmatelem(u,v);
   begin scalar x,y;
      if length u neq 3 then typerr(u,"matrix element");
      x := get(car u,'avalue);
      if null x or not(car x eq 'matrix) then typerr(car u,"matrix")
       else if not eqcar(x := cadr x,'mat)
        then rerror(matrix,10,list("Matrix",car u,"not set"));
      y := reval_without_mod cadr u;
      if not fixp y or y<=0 then typerr(y,"positive integer");
      x := nth(cdr x,y);
      y := reval_without_mod caddr u;
      if not fixp y or y<=0 then typerr(y,"positive integer");
      return rplaca(pnth(x,y),v)
   end;

symbolic procedure matlength u;
   if not eqcar(u,'mat) then rerror(matrix,2,list("Matrix",u,"not set"))
    else list('list,length cdr u,length cadr u);

% Aggregate Property.  Commented out for now.

symbolic procedure matrixmap(u,v);
   if flagp(car u,'matmapfn)
    then matsm!*1 for each j in matsm cadr u collect
            for each k in j collect simp!*(car u . mk!*sq k . cddr u)
   else if flagp(car u,'matfn) then reval2(u,v)
    else typerr(car u,"matrix operator");

put('matrix,'aggregatefn,'matrixmap);

flag('(df int taylor),'matmapfn);

flag('(det trace),'matfn);

% symbolic procedure mk!*sq2 u;
%    begin scalar x;
%        x := !*sub2;   % Since we need value for each element.
%        u := subs2 u;
%        !*sub2 := x;
%        return mk!*sq u
%   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/det.red0000644000175000017500000001265111526203062023265 0ustar  giovannigiovannimodule det;   % Determinant and trace routines.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*cramer !*rounded asymplis!* bareiss!-step!-size!* kord!*
        powlis!* powlis1!* subfg!* wtl!*);

bareiss!-step!-size!* := 2;     % seems fastest on average.

symbolic procedure simpdet u;
   begin scalar x,!*protfg;
      !*protfg := t;
      return if !*cramer or !*rounded or
                errorp(x := errorset({'bareiss!-det,mkquote u},nil,nil))
               then detq matsm carx(u,'det)
              else car x
   end;

% The hashing and determinant routines below are due to M. L. Griss.

Comment Some general purpose hashing functions;

flag('(array),'eval);      % Declared again for bootstrapping purposes.

array !$hash 64;  % General array for hashing.

symbolic procedure gethash key;
   % Access previously saved element.
   assoc(key,!$hash(remainder(key,64)));

symbolic procedure puthash(key,valu);
   begin integer k; scalar buk;
      k := remainder(key,64);
      buk := (key . valu) . !$hash k;
      !$hash k := buk;
      return car buk
   end;

symbolic procedure clrhash;
   for i := 0:64 do !$hash i := nil;

Comment Determinant Routines;

symbolic procedure detq u;
   % Top level determinant function.
   begin integer len;
      len := length u;   % Number of rows.
      for each x in u do
        if length x neq len then rederr "Non square matrix";
      if len=1 then return caar u;
      clrhash();
      u := detq1(u,len,0);
      clrhash();
      return u
   end;

symbolic procedure detq1(u,len,ignnum);
   % U is a square matrix of order LEN. Value is the determinant of U.
   % Algorithm is expansion by minors of first row.
   % IGNNUM is packed set of column indices to avoid.
   begin integer n2; scalar row,sign,z;
      row := car u;   % Current row.
      n2 := 1;
      if len=1
        then return <>;
                      car row>>;   % Last row, single element.
      if z := gethash ignnum then return cdr z;
      len := len-1;
      u := cdr u;
      z := nil ./ 1;
      for each x in row do
        <>;
                   sign := not sign>>;
          n2 := 2*n2>>;
      puthash(ignnum,z);
      return z
   end;

symbolic procedure twomem(n1,n2);
   % For efficiency reasons, this procedure should be coded in assembly
   % language.
   not evenp(n2/n1);

put('det,'simpfn,'simpdet);

flag('(det),'immediate);

% A version of det using the Bareiss code.

symbolic procedure bareiss!-det u;
   % Compute a determinant using the Bareiss code.
   begin scalar nu,bu,n,ok,temp,v,!*exp;
   !*exp := t;
   nu := matsm car u;
   n := length nu;
   for each x in nu do
      if length x neq n then rederr "Non square matrix";
   if n=1 then return caar nu;
%  Note in an earlier version, these were commented out.
   if asymplis!* or wtl!* then
    <>;
   nu := normmat nu;
   v := for i:=1:n collect intern gensym();
   % Cannot rely on the ordering of the gensyms.
   ok := setkorder append(v,kord!*);
   car nu := foreach r in car nu collect prsum(v,r);
   bu := cdr sparse_bareiss(car nu,v,bareiss!-step!-size!*)
            where powlis!* = nil,powlis1!* = nil,subfg!* = nil;
      % It is probably sufficient to set subfg* to nil in previous line.
   bu := if length bu = n then (lc car bu ./ cdr nu) else (nil ./ 1);
   setkorder ok;
   if temp then <>;
   if getd 'remob then foreach vv in v do remob vv; %% WN
		%% PSL suffers from a potential lack of IDs after
                %% many det computations
   return resimp bu
   end;

symbolic procedure simptrace u;
   begin integer n; scalar z;
        u := matsm carx(u,'trace);
        if length u neq length car u then rederr "Non square matrix";
        n := 1;
        z := nil ./ 1;
        for each x in u do <>;
        return z
   end;

put('trace,'simpfn,'simptrace);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/matrix/rank.red0000644000175000017500000000525411526203062023445 0ustar  giovannigiovannimodule rank;

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Module for calculating the rank of a matrix or a system of linear
% equations.
% Format: rank  : rank .

symbolic procedure rank!-eval u;
   begin scalar n;
      if cdr u then rerror(matrix,17,"Wrong number of arguments")
       else if getrtype (u := car u) eq 'matrix
         then return rank!-matrix matsm u
       else if null eqcar(u := aeval u,'list) then typerr(u,"matrix")
       else return rank!-matrix
         for each row in cdr u collect
           if not eqcar(row,'list)
               then rerror(matrix,15,"list not in matrix shape")
            else <>
   end;


put('rank,'psopfn,'rank!-eval);

symbolic procedure rank!-matrix u;
   begin scalar x,y,z; integer m,n;
     z := 1;
     for each v in u do
          <>;
            if y := c!:extmult(x,z)
               then <>>>;
     return n
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/0000755000175000017500000000000011722677357022131 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/laplace.tex0000644000175000017500000000533511526203062024236 0ustar  giovannigiovanni\documentclass{article}

\usepackage[dvipdfm]{graphicx}
\usepackage[dvipdfm]{color}
\usepackage[dvipdfm]{hyperref}

\setlength{\parindent}{0cm}

\title{SOFIA LAPLACE AND INVERSE LAPLACE TRANSFORM PACKAGE}
\author{C. Kazasov\and M. Spiridonova \and V. Tomov}
\date{}


\begin{document}
\maketitle

\begin{center}
\begin{tabular}{lp{10cm}}
Reference: & {\bf Christomir Kazasov}, Laplace Transformations in REDUCE 3, Proc.
Eurocal '87, Lecture Notes in Comp. Sci., Springer-Verlag
(1987) 132-133.
\end{tabular} 
\end{center}
\ \\
\ \\
Some hints on how to use to use this package: \\
\ \\
Syntax: \\
\ \\
{\tt LAPLACE($,,$ }) \\
\ \\
{\tt INVLAP($,,$)} \\
\ \\
where $$ is the expression to be transformed, $$ is the source
variable (in most cases $$ depends explicitly of this variable) and
$$ is the target variable. If $$ is omitted, the package uses
an internal variable lp!\& or il!\&, respectively. \\
\ \\
The following switches can be used to control the transformations: \\
\begin{center}
\begin{tabular}{lp{10cm}}
{\tt lmon}: & If on, sin, cos, sinh and cosh are converted by {\tt LAPLACE} into
exponentials, \\
{\tt lhyp}: & If on, expressions $e^{\tilde{}x}$ are converted by {\tt INVLAP} into 
hyperbolic functions sinh and cosh, \\
{\tt ltrig}: & If on, expressions $e^{\tilde{}x}$ are converted by {\tt INVLAP} into
trigonometric functions sin and cos. \\
\end{tabular} 
\end{center}
\ \\
The system can be extended by adding Laplace transformation rules for
single functions by rules or rule sets.~ In such a rule the source
variable MUST be free, the target variable MUST be il!\& for {\tt LAPLACE} and
lp!\& for {\tt INVLAP} and the third parameter should be omitted.~ Also rules for
transforming derivatives are entered in such a form. \\

\pagebreak
{\bf Examples:}
\begin{verbatim}

    let {laplace(log(~x),x) => -log(gam * il!&)/il!&,

    invlap(log(gam * ~x)/x,x) => -log(lp!&)};


    operator f;

    let{

    laplace(df(f(~x),x),x) => il!&*laplace(f(x),x) - sub(x=0,f(x)),

    laplace(df(f(~x),x,~n),x) => il!&**n*laplace(f(x),x) -

    for i:=n-1 step -1 until 0 sum

    sub(x=0, df(f(x),x,n-1-i)) * il!&**i

    when fixp n,

    laplace(f(~x),x) = f(il!&)

    };

\end{verbatim}


Remarks about some functions: \\
\ \\
The DELTA and GAMMA functions are known. \\
ONE is the name of the unit step function. \\
INTL is a parametrized integral function 
\begin{center}
{\tt intl($,,0,$)}
\end{center}
which means \char`\"{}Integral of $$ wrt.~ $$ taken from 0 to $$\char`\"{},
e.g. {\tt intl($2{*}y^2,y,0,x$)} which is formally a function in $x$.
\ \\
\ \\
We recommend reading the file LAPLACE.TST for a further introduction.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/laplace.tst0000644000175000017500000002550511526203062024251 0ustar  giovannigiovanni% Title:  Examples of Laplace Transforms.

% Author: L. Kazasov.

% Date: 24 October 1988.

order p;

% Elementary functions with argument k*x, where x is object var.

laplace(1,x,p);
laplace(c,x,p);
laplace(sin(k*x),x,p); laplace(sin(x/a),x,p);
laplace(sin(17*x),x,p);
laplace(sinh x,x,p);
laplace(cosh(k*x),x,p);
laplace(x,x,p); laplace(x**3,x,p);
off mcd; laplace(e**(c*x) + a**x, x, s);
laplace(e**x - e**(a*x) + x**2, x, p);
laplace(one(k*t) + sin(a*t) - cos(b*t) - e**t, t, p);
laplace(sqrt(x),x,p); laplace(x**(1/2),x,p); on mcd;
laplace(x**(-1/2),x,p); laplace(x**(5/2),x,p);
laplace(-1/4*x**2*c*sqrt(x), x, p);

% Elementary functions with argument k*x - tau,
%   where k>0, tau>=0, x is object var.

laplace(cos(x-a),x,p);
laplace(one(k*x-tau),x,p);
laplace(sinh(k*x-tau),x,p); laplace(sinh(k*x),x,p);
laplace((a*x-b)**c,x,p);
% But ...
off mcd; laplace((a*x-b)**2,x,p); on mcd;
laplace(sin(2*x-3),x,p);
on lmon; laplace(sin(2*x-3),x,p); off lmon;
off mcd; laplace(cosh(t-a) - sin(3*t-5), t, p); on mcd;

% More complicated examples - multiplication of functions.
% We use here on lmon - a new switch that forces all
% trigonometrical functions which depend on object var
% to be represented as exponents.

laplace(x*e**(a*x)*cos(k*x), x, p);
laplace(x**(1/2)*e**(a*x), x, p);
laplace(-1/4*e**(a*x)*(x-k)**(-1/2), x, p);
laplace(x**(5/2)*e**(a*x), x, p);
laplace((a*x-b)**c*e**(k*x)*const/2, x, p);
off mcd; laplace(x*e**(a*x)*sin(7*x)/c*3, x, p); on mcd;
laplace(x*e**(a*x)*sin(k*x-tau), x, p);
% The next is unknown if lmon is off.
laplace(sin(k*x)*cosh(k*x), x, p);
laplace(x**(1/2)*sin(k*x), x, p);
on lmon;  % But now is OK.
laplace(x**(1/2)*sin(a*x)*cos(a*b), x, p);
laplace(sin(x)*cosh(x), x, p);
laplace(sin(k*x)*cosh(k*x), x, p);
% Off exp leads to very messy output in this case.
% off exp; laplace(sin(k*x-t)*cosh(k*x-t), x, p); on exp;
laplace(sin(k*x-t)*cosh(k*x-t), x, p);
laplace(cos(x)**2,x,p);laplace(c*cos(k*x)**2,x,p);
laplace(c*cos(2/3*x)**2, x, p);
laplace(5*sinh(x)*e**(a*x)*x**3, x, p);
off exp; laplace(sin(2*x-3)*cosh(7*x-5), x, p); on exp;
laplace(sin(a*x-b)*cosh(c*x-d), x, p);
% To solve this problem we must tell the program which one-function
% is rightmost shifted.  However, in REDUCE 3.4, this rule is still
% not sufficient.
for all x let one(x-b/a)*one(x-d/c) = one(x-b/a);
laplace(sin(a*x-b)*cosh(c*x-d), x, p);
for all x clear one(x-b/a)*one(x-d/c) ;
off lmon;

% Floating point arithmetic.
% laplace(3.5/c*sin(2.3*x-4.11)*e**(1.5*x), x, p);
on rounded;
laplace(3.5/c*sin(2.3*x-4.11)*e**(1.5*x), x, p);
laplace(x**2.156,x,p);
laplace(x**(-0.5),x,p);
off rounded; laplace(x**(-0.5),x,p); on rounded;
laplace(x*e**(2.35*x)*cos(7.42*x), x, p);
laplace(x*e**(2.35*x)*cos(7.42*x-74.2), x, p);
% Higher precision works, but uses more memory.
% precision 20; laplace(x**2.156,x,p);
% laplace(x*e**(2.35*x)*cos(7.42*x-74.2), x, p);
off rounded;

% Integral from 0 to x, where x is object var.
% Syntax is intl(,,0,).

laplace(c1/c2*intl(2*y**2,y,0,x), x,p);
off mcd; laplace(intl(e**(2*y)*y**2+sqrt(y),y,0,x),x,p); on mcd;
laplace(-2/3*intl(1/2*y*e**(a*y)*sin(k*y),y,0,x), x, p);

% Use of delta function and derivatives.

laplace(-1/2*delta(x), x, p); laplace(delta(x-tau), x, p);
laplace(c*cos(k*x)*delta(x),x,p);
laplace(e**(a*x)*delta(x), x, p);
laplace(c*x**2*delta(x), x, p);
laplace(-1/4*x**2*delta(x-pi), x, p);
laplace(cos(2*x-3)*delta(x-pi),x,p);
laplace(e**(-b*x)*delta(x-tau), x, p);
on lmon;
laplace(cos(2*x)*delta(x),x,p);
laplace(c*x**2*delta(x), x, p);
laplace(c*x**2*delta(x-pi), x, p);
laplace(cos(a*x-b)*delta(x-pi),x,p);
laplace(e**(-b*x)*delta(x-tau), x, p);
off lmon;

laplace(2/3*df(delta x,x),x,p);
off exp; laplace(e**(a*x)*df(delta x,x,5), x, p); on exp;
laplace(df(delta(x-a),x), x, p);
laplace(e**(k*x)*df(delta(x),x), x, p);
laplace(e**(k*x)*c*df(delta(x-tau),x,2), x, p);
on lmon;laplace(e**(k*x)*sin(a*x)*df(delta(x-t),x,2),x,p);off lmon;

% But if tau is positive, Laplace transform is not defined.

laplace(e**(a*x)*delta(x+tau), x, p);
laplace(2*c*df(delta(x+tau),x), x, p);
laplace(e**(k*x)*df(delta(x+tau),x,3), x, p);

% Adding new let rules for Laplace operator. Note the syntax.

for all x let laplace(log(x),x) = -log(gam*il!&)/il!&;
laplace(-log(x)*a/4, x, p); laplace(-log(x),x,p);
laplace(a*log(x)*e**(k*x), x, p);
for all x clear laplace(log(x),x);

operator f; for all x let
    laplace(df(f(x),x),x) = il!&*laplace(f(x),x) - sub(x=0,f(x));
for all x,n such that numberp n and fixp n let
    laplace(df(f(x),x,n),x) = il!&**n*laplace(f(x),x) -
      for i:=n-1 step -1 until 0 sum
        sub(x=0, df(f(x),x,n-1-i)) * il!&**i ;
for all x let laplace(f(x),x) = f(il!&);

laplace(1/2*a*df(-2/3*f(x)*c,x), x,p);
laplace(1/2*a*df(-2/3*f(x)*c,x,4), x,p);
laplace(1/2*a*e**(k*x)*df(-2/3*f(x)*c,x,2), x,p);
clear f;

% Or if the boundary conditions are known and assume that
% f(i,0)=sub(x=0,df(f(x),x,i)) the above may be overwritten as:
operator f; for all x let
    laplace(df(f(x),x),x) = il!&*laplace(f(x),x) - f(0,0);
for all x,n such that numberp n and fixp n let
    laplace(df(f(x),x,n),x) = il!&**n*laplace(f(x),x) -
      for i:=n-1 step -1 until 0 sum il!&**i * f(n-1-i,0);
for all x let laplace(f(x),x) = f(il!&);
let f(0,0)=0, f(1,0)=1, f(2,0)=2, f(3,0)=3;
laplace(1/2*a*df(-2/3*f(x)*c,x), x,p);
laplace(1/2*a*df(-2/3*f(x)*c,x,4), x,p);
clear f(0,0), f(1,0), f(2,0), f(3,0); clear f;

% Very complicated examples.

on lmon;
laplace(sin(a*x-b)**2, x, p);
off mcd; laplace(x**3*(sin x)**4*e**(5*k*x)*c/2, x,p);
a:=(sin x)**4*e**(5*k*x)*c/2; laplace(x**3*a,x,p); clear a; on mcd;
% And so on, but is very time consuming.
% laplace(e**(k*x)*x**2*sin(a*x-b)**2, x, p);
% for all x let one(a*x-b)*one(c*x-d) = one(c*x-d);
% laplace(x*e**(-2*x)*cos(a*x-b)*sinh(c*x-d), x, p);
% for all x clear one(a*x-b)*one(c*x-d) ;
% laplace(x*e**(c*x)*sin(k*x)**3*cosh(x)**2*cos(a*x), x, p);
off lmon;

% Error messages.

laplace(sin(-x),x,p);
on lmon; laplace(sin(-a*x), x, p); off lmon;
laplace(e**(k*x**2), x, p);
laplace(sin(-a*x+b)*cos(c*x+d), x, p);
laplace(x**(-5/2),x,p);
% With int arg, can't be shifted.
laplace(intl(y*e**(a*y)*sin(k*y-tau),y,0,x), x, p);
laplace(cosh(x**2), x, p);
laplace(3*x/(x**2-5*x+6),x,p);
laplace(1/sin(x),x,p);   % But ...
laplace(x/sin(-3*a**2),x,p);
% Severe errors.
% laplace(sin x,x,cos y);
% laplace(sin x,x,y+1);
% laplace(sin(x+1),x+1,p);


Comment  Examples of Inverse Laplace transformations;

symbolic(ordl!* := nil);   % To nullify previous order declarations.

order t;

% Elementary ratio of polynomials.

invlap(1/p, p, t);
invlap(1/p**3, p, t);
invlap(1/(p-a), p, t); invlap(1/(2*p-a),p,t); invlap(1/(p/2-a),p,t);
invlap(e**(-k*p)/(p-a), p, t); invlap(b**(-k*p)/(p-a), p, t);
invlap(1/(p-a)**3, p, t);
invlap(1/(c*p-a)**3, p, t); invlap(1/(p/c-a)**3, p, t);
invlap((c*p-a)**(-1)/(c*p-a)**2, p, t);
invlap(c/((p/c-a)**2*(p-a*c)), p, t);
invlap(1/(p*(p-a)), p, t);
invlap(c/((p-a)*(p-b)), p, t);
invlap(p/((p-a)*(p-b)), p, t);
off mcd; invlap((p+d)/(p*(p-a)), p, t);
invlap((p+d)/((p-a)*(p-b)), p, t);
invlap(1/(e**(k*p)*p*(p+1)), p, t); on mcd;
off exp; invlap(c/(p*(p+a)**2), p, t); on exp;
invlap(1, p, t); invlap(c1*p/c2, p, t);
invlap(p/(p-a), p, t); invlap(c*p**2, p, t);
invlap(p**2*e**(-a*p)*c, p, t);
off mcd;invlap(e**(-a*p)*(1/p**2-p/(p-1))+c/p, p, t);on mcd;
invlap(a*p**2-2*p+1, p, x);

% P to non-integer power in denominator - i.e. gamma-function case.

invlap(1/sqrt(p), p, t); invlap(1/sqrt(p-a), p, t);
invlap(c/(p*sqrt(p)), p, t); invlap(c*sqrt(p)/p**2, p, t);
invlap((p-a)**(-3/2), p, t);
invlap(sqrt(p-a)*c/(p-a)**2, p, t);
invlap(1/((p-a)*b*sqrt(p-a)), p, t);
invlap((p/(c1-3)-a)**(-3/2), p, t);
invlap(1/((p/(c1-3)-a)*b*sqrt(p/(c1-3)-a)), p, t);
invlap((p*2-a)**(-3/2), p, t);
invlap(sqrt(2*p-a)*c/(p*2-a)**2, p, t);
invlap(c/p**(7/2), p, t); invlap(p**(-7/3), p, t);
invlap(gamma(b)/p**b,p,t); invlap(c*gamma(b)*(p-a)**(-b),p,t);
invlap(e**(-k*p)/sqrt(p-a), p, t);

% Images that give elementary object functions.
% Use of new switches lmon, lhyp.

invlap(k/(p**2+k**2), p, t);
% This is made more readable by :
on ltrig; invlap(k/(p**2+k**2), p, t);
invlap(p/(p**2+1), p, t);
invlap((p**2-a**2)/(p**2+a**2)**2, p, t);
invlap(p/(p**2+a**2)**2, p, t);
invlap((p-a)/((p-a)**2+b**2), p, t); off ltrig;
on lhyp; invlap(s/(s**2-k**2), s, t);
invlap(e**(-tau/k*p)*p/(p**2-k**2), p, t); off lhyp;
% But it is not always possible to convert expt. functions, e.g.:
on lhyp; invlap(k/((p-a)**2-k**2), p, t); off lhyp;
on ltrig; invlap(e**(-tau/k*p)*k/(p**2+k**2), p, t); off ltrig;
% In such situations use the default switches:
invlap(k/((p-a)**2-k**2), p, t); % i.e. e**(a*t)*cosh(k*t).
invlap(e**(-tau/k*p)*k/(p**2+k**2), p, t); % i.e. sin(k*t-tau).

% More complicated examples.

off exp,mcd; invlap((p+d)/(p**2*(p-a)), p, t);
invlap(e**(-tau/k*p)*c/(p*(p-a)**2), p, t);
invlap(1/((p-a)*(p-b)*(p-c)), p, t);
invlap((p**2+g*p+d)/(p*(p-a)**2), p, t); on exp,mcd;
invlap(k*c**(-b*p)/((p-a)**2+k**2), p, t);
on ltrig; invlap(c/(p**2*(p**2+a**2)), p, t);
invlap(1/(p**2-p+1), p, t); invlap(1/(p**2-p+1)**2, p, t);
invlap(2*a**2/(p*(p**2+4*a**2)), p, t);
% This is (sin(a*t))**2 and you can get this by using the let rules :
for all x let sin(2*x)=2*sin x*cos x, cos(2*x)=(cos x)**2-(sin x)**2,
(cos x)**2 =1-(sin x)**2;
invlap(2*a**2/(p*(p**2+4*a**2)), p, t);
for all x clear sin(2*x),cos(2*x),cos(x)**2;  off ltrig;
on lhyp;invlap((p**2-2*a**2)/(p*(p**2-4*a**2)),p,t);
off lhyp; % Analogously, the above is (cosh(a*t))**2.

% Floating arithmetic.

invlap(2.55/((0.5*p-2.0)*(p-3.3333)), p, t);
on rounded;
invlap(2.55/((0.5*p-2.0)*(p-3.3333)), p, t);
invlap(1.5/sqrt(p-0.5), p, t);
invlap(2.75*p**2-0.5*p+e**(-0.9*p)/p, p, t);
invlap(1/(2.0*p-3.0)**3, p, t); invlap(1/(2.0*p-3.0)**(3/2), p, t);
invlap(1/(p**2-5.0*p+6), p, t);
off rounded;

% Adding new let rules for the invlap operator. note the syntax:

for all x let invlap(log(gam*x)/x,x) = -log(lp!&);
invlap(-1/2*log(gam*p)/p, p, t);
invlap(-e**(-a*p)*log(gam*p)/(c*p), p, t);
for all x clear invlap(1/x*log(gam*x),x);

% Very complicated examples and use of factorizer.

off exp,mcd; invlap(c**(-k*p)*(p**2+g*p+d)/(p**2*(p-a)**3), p, t);
on exp,mcd;
invlap(1/(2*p**3-5*p**2+4*p-1), p, t);
on ltrig,lhyp; invlap(1/(p**4-a**4), p, t);
invlap(1/((b-3)*p**4-a**4*(2+b-5)), p, t); off ltrig,lhyp;
% The next three examples are the same:
invlap(c/(p**3/8-9*p**2/4+27/2*p-27)**2,p,t);invlap(c/(p/2-3)**6,p,t);
off exp; a:=(p/2-3)**6; on exp; invlap(c/a, p, t); clear a;
% The following two examples are the same :
invlap(c/(p**4+2*p**2+1)**2, p, t); invlap(c/((p-i)**4*(p+i)**4),p,t);
% The following three examples are the same :
invlap(e**(-k*p)/(2*p-3)**6, p, t);
invlap(e**(-k*p)/(4*p**2-12*p+9)**3, p, t);
invlap(e**(-k*p)/(8*p**3-36*p**2+54*p-27)**2, p, t);

% Error messages.

invlap(e**(a*p)/p, p, t);
invlap(c*p*sqrt(p), p, t);
invlap(sin(p), p, t);
invlap(1/(a*p**3+b*p**2+c*p+d),p,t);
invlap(1/(p**2-p*sin(p)+a**2),p,t);
on rounded; invlap(1/(p**3-1), p, t); off rounded;
% Severe errors:
%invlap(1/(p**2+1), p+1, sin(t) );
%invlap(p/(p+1)**2, sin(p), t);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/laplace.red0000644000175000017500000012525611526203062024215 0ustar  giovannigiovannimodule laplace;  % Package for Laplace and inverse Laplace transforms.

% Authors:  C. Kazasov, M. Spiridonova, V. Tomov.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date:  24 October 1988.

% Revisions:
%     5 Nov 1993   H. Melenk: adapt code for REDUCE 3.5:
%                  - safe restoration of environment.
%                  - moved *mcd/*exp:=nil after initial
%                           simp/reval call for safer pattern
%                           match
%                  - enable invlap(1/x^n,x,t) (wrong termination
%                           condition)
%                  - repair fctrf call in invlap (incomplete input
%                           conversion and incomplete result test)
%                  - repair of pattern matching for rules
%                           with 2 argument laplace and invlap
%                           expressions as used in the xmpl file
%
%
%     2 Dec 1988.  Commented out rule for sqrt(-x), since it interferes
%                  with integrator.
%    20 Nov 1988.  Converted to lower case and tabs removed.
%
%*******************************************************************
%*                                                                 *
%*                 L A P L A C E   2.0                             *
%*                                                                 *
%*      AN EXPERIMENTAL PACKAGE FOR PERFORMING IN REDUCE 3         *
%*        DIRECT  AND  INVERSE  LAPLACE  TRANSFORMATIONS           *
%*                                                                 *
%*          SOFIA  UNIVERSITY - B U L G A R I A                    *
%*                                                                 *
%*******************************************************************

create!-package('(laplace),'(contrib misc));

fluid '(!*exp !*limitedfactors !*mcd !*precise !*rounded depl!* kord!*
        subfg!* transvar!* varstack!*);

global '(lpsm!* lpcm!* lpshm!* lpchm!* lpse!* lpce!* lpshe!* lpche!*
         lpexpt!* ile1!* ile2!* ile3!* ile4!* ile5!* lpvar!* ilvar!*
         lpshift!* !*lmsg !*lmon !*ltrig !*lhyp !*ldone !*lione );

switch lhyp,lmon,ltrig;

% Default value:

!*lmsg:= t;

% put('intl,'simpfn,'simpiden);
% put('one, 'simpfn,'simpiden);
% put('delta,'simpfn,'simpiden);
% put('gamma,'simpfn,'simpiden);

if not (gettype 'intl = 'operator) then algebraic operator intl;
if not (gettype 'one = 'operator) then algebraic operator one;
if not (gettype 'delta = 'operator) then algebraic operator delta;
if not (gettype 'gamma = 'operator) then algebraic operator gamma;

%*******************************************************************
%*                                                                 *
%*            Save and restore environment                         *
%*                                                                 *
%*******************************************************************

symbolic procedure lap!-save!-environment();
  begin scalar u;
   u:={ !*exp,!*mcd,kord!*,depl!*,
        get('expt,'opmtch),
        get('sin,'opmtch),
        get('cos,'opmtch),
        get('sinh,'opmtch),
        get('cosh,'opmtch),
        get('gamma,'simpfn),
        get('one,'simpfn),
        get('delta,'simpfn),
        get('intl,'simpfn),
        get('laplace,'simpfn),
        get('invlap,'simpfn)
   };
   % copy lists such that rplac* don't touch the environment
   kord!* := append(kord!*,nil);
   depl!*:=for each d in depl!* collect append(d,nil);
   return u;
  end;

symbolic procedure lap!-restore!-environment(u);
  begin
    !*exp := car u; u := cdr u;
    !*mcd := car u; u := cdr u;
    kord!*:= car u; u := cdr u;
    depl!*:= car u; u := cdr u;
    put('expt,'opmtch, car u); u:=cdr u;
    put('sin,'opmtch, car u); u:=cdr u;
    put('cos,'opmtch, car u); u:=cdr u;
    put('sinh,'opmtch, car u); u:=cdr u;
    put('cosh,'opmtch, car u); u:=cdr u;
    put('gamma,'simpfn, car u); u:=cdr u;
    put('one,'simpfn, car u); u:=cdr u;
    put('delta,'simpfn, car u); u:=cdr u;
    put('intl,'simpfn, car u); u:=cdr u;
    put('laplace,'simpfn, car u); u:=cdr u;
    put('invlap,'simpfn, car u); u:=cdr u;
  end;


%*******************************************************************
%*                                                                 *
%*            DIRECT  LAPLACE  TRANSFORMATION                      *
%*                                                                 *
%*******************************************************************


put('laplace, 'simpfn, 'simplaplace);


lpsm!*:='( ((minus !=x))
           (nil depends (reval (quote !=x)) lpvar!* )
           (minus (times (one (minus !=x)) (sin !=x)) ) nil );

lpcm!*:='( (( minus !=x ))
           (nil depends (reval (quote !=x)) lpvar!* )
           (times (one (minus !=x)) (cos !=x)) nil );

lpshm!*:='( ((minus !=x))
           (nil depends (reval (quote !=x)) lpvar!* )
           (minus (times (one (minus !=x)) (sinh !=x)) ) nil );

lpchm!*:='( (( minus !=x ))
           (nil depends (reval (quote !=x)) lpvar!* )
           (times (one (minus !=x)) (cosh !=x)) nil );


lpse!*:= '( (!=x) (nil depends (reval(quote !=x)) lpvar!* )
   (times (one !=x) (quotient (difference (expt e (times i !=x))
                                  (expt e (minus (times i !=x))) )
                              (times 2 i) ) ) nil ) ;

lpce!*:= '( (!=x) (nil depends (reval(quote !=x)) lpvar!* )
   (times (one !=x) (quotient (plus (expt e (times i !=x))
                                  (expt e (minus (times i !=x))) )
                              2 ) )  nil ) ;

lpshe!*:= '( (!=x) (nil depends (reval(quote !=x)) lpvar!* )
    (times (one !=x) (quotient (difference (expt e !=x)
                                   (expt e (minus !=x)) )
                              2 ) ) nil );

lpche!*:= '( (!=x) (nil depends (reval(quote !=x)) lpvar!* )
   (times (one !=x) (quotient (plus (expt e !=x)
                                    (expt e (minus !=x)) )
                              2 ) ) nil );

lpexpt!*:= '( (e (plus !=x !=y)) (nil . t)
   (times (expt e !=x) (expt e !=y) (one (plus !=x !=y)) ) nil );


symbolic procedure simplaplace u;
 begin scalar e,r;
    e:=lap!-save!-environment();
    r:=errorset({'simplaplace!*,mkquote u},nil,nil);
    lap!-restore!-environment(e);
    if errorp r then typerr('laplace.u,"Laplace form")
     else return laplace_fixup car r
   end;

symbolic procedure laplace_fixup u;
   % For some reason, results do not always come out in the most
   % natural form.  This is an attempt to fix this.
   <> where varstack!* = nil;

symbolic procedure simplaplace!*  u;
 % Main procedure for Laplace transformation.
 % U is in prefix form: (  ), where
 %    is the object function,
 %    is the var. of the object function (intern. lp!&),
 %    is the var. of the laplace transform(intern. il!&),
 %      and can be omitted - then il!& is assumed.
 % Returns a standard quotient of Laplace transform.
 begin scalar !*exp,!*mcd,v,w,transvar!*,!*precise;
   % We need to make this run with precise on.
   if null subfg!* then return mksq('laplace . u, 1);
   if cddr u and null idp(w:=caddr u) or null idp(v:=cadr u)
      then go to err;
   v:= caaaar simp v;
   transvar!* := w;     % Needed for returning a Laplace form.
   % Should the following be an error?
   if null transvar!* then transvar!* := 'il!&;
   if null idp v then go to err;
   u:= car u ;
 % Make environment for Laplace transform.
   !*mcd := !*exp := t;
   kord!*:= 'lp!& . 'il!& . kord!* ;
   put('one,'simpfn,'lpsimp1);
   put('gamma,'simpfn,'lpsimpg);
   if !*ldone then put('expt,'opmtch,lpexpt!*.get('expt,'opmtch));
   if !*lmon then
    << put('sin,'opmtch, lpse!* . get('sin,'opmtch));
       put('cos,'opmtch, lpce!* . get('cos,'opmtch));
       put('sinh,'opmtch, lpshe!* . get('sinh,'opmtch));
       put('cosh,'opmtch, lpche!* . get('cosh,'opmtch)) >>
             else
    << put('sin,'opmtch, lpsm!* . get('sin,'opmtch));
       put('cos,'opmtch, lpcm!* . get('cos,'opmtch));
       put('sinh,'opmtch, lpshm!* . get('sinh,'opmtch));
       put('cosh,'opmtch, lpchm!* . get('cosh,'opmtch)) >>;
   lpvar!*:= v; lpshift!*:=t;
   if v neq 'lp!& then kord!*:=v . kord!*;
   for each x in depl!* do if v memq cdr x then rplacd(x,'lp!& . cdr x);
   % HM: resimplify u for rules before mcd goes off.
   % ACH: However, it gives wrong results e.g. for laplace(sin(-x),x,p)
%  rmsubs(); u := reval u;
   off mcd;
   u:= laplace1 list(u,v);
   if w then u:=subf(numr u, list('il!& . w));
 % Restore old env.
   for each x in depl!* do
      if 'lp!& memq cdr x then rplacd(x,delete('lp!&,cdr x));
   put('one,'simpfn,'simpiden);
   put('gamma,'simpfn,'simpiden);
   kord!*:= cddr kord!*;
   put('sin,'opmtch, cdr get('sin,'opmtch) );
   put('cos,'opmtch, cdr get('cos,'opmtch) );
   put('sinh,'opmtch, cdr get('sinh,'opmtch) );
   put('cosh,'opmtch, cdr get('cosh,'opmtch) );
   if !*ldone then put('expt,'opmtch,cdr get('expt,'opmtch) );
   if erfg!* then erfg!*:=nil;
   return u;
 err: msgpri("Laplace operator incorrect",nil,nil,nil,t)
   end where !*exp = !*exp, !*mcd = !*mcd;

put('sin,'lpfn,'(quotient k (plus (expt il!& 2) (expt k 2) )) );
put('cos,'lpfn,'(quotient il!& (plus (expt il!& 2) (expt k 2) )) );
put('sinh,'lpfn,'(quotient k (plus (expt il!& 2)
                                   (minus (expt k 2)) )) );
put('cosh,'lpfn,'(quotient il!& (plus (expt il!& 2)
                                      (minus (expt k 2)) )) );
put('one,'lpfn,'(quotient 1 il!&) );
put('expt,'lpfn,'(quotient (times (expt k d) (gamma (plus d 1)) )
                           (expt il!& (plus d 1)) ) );
put('delta,'lpfn, 1 );


symbolic procedure laplace1 u;
 % Car u is in pref. form, cadr u is the var of the object function.
 % Returns standard quotient of Laplace transform.
 begin  scalar  v,w,z;
   v := cadr u;
   u := car u;
   z:= simp!* u;
   if denr z neq 1 then z := simp prepsq z;   % *SQ must have occurred.
   if denr z neq 1 then rederr list(u,"has non-trivial denominator");
   z := numr z;
   if v neq 'lp!& then << kord!*:=cdr kord!*;
                        z:=subla(list(v.'lp!&),z); z:=reorder z >>;
   if erfg!* then return !*kk2q list
       ('laplace, subla(list('lp!& . lpvar!*), u), lpvar!*,transvar!*);
   w:= nil ./ 1;  u:=z; !*exp:=nil;
   while u do
     if domainp u
        then << w:=addsq(w, lpdom u); u:=nil >>
        else << w:=addsq(w, if (z:=lptermx lt u) then z
                     else !*kk2q list('laplace, subla
          (list('lp!&.lpvar!*),prepsq !*t2q lt u),lpvar!*,transvar!*));
                u:= red u >>;
   return w;
 end;

symbolic procedure lptermx  u ;
 % U is standard term, which may contain integer power of lp!&.
 % Returns standard quot or nil, if Laplace transform is impossible.
 begin  scalar  w ; integer  n ;
   if tvar u neq 'lp!& then return lpterm u
    else if fixp cdar u
     then if (n:=cdar u)>0 then nil else return lpunknown u
    else return lpterm
       ( (list('expt,'lp!&,prepsq(cdar u ./ 1)) to 1) .* cdr u );
   if (w:=lpform cdr u) then nil else return nil ;
  a: % We use here the rule:
     %  laplace(x*fun(x),x)=-df(laplace(fun(x),x),il!&) ,or
     %  laplace(x**n*fun(x),x)=(-1)**n*df(laplace(fun(x),x),il!&,n);
   if n=0 then return w;
   w:=negsq diffsq(w,'il!&);
   n:=n-1; go to a;
 end;

symbolic procedure lpdom  u ;
 % We use here the rule: laplace(const,lp!&)=const/lp!&.
 % U is domain. Returns standard quotient.
   !*t2q (('il!& to -1) .* u) ;

symbolic procedure  lpform u ;
 % U is standard form, not containing integer powers of lp!&.
 % Returns standard quot or nil, if Laplace transform is impossible.
 begin  scalar  y,z ;
   if domainp u
      then return lpdom u
      else if red u
              then return
        ( if (y:=lpterm lt u) and (z:=lpform red u)
             then addsq(y,z) else nil )
              else return lpterm lt u ;
 end ;

symbolic procedure  lpterm  u ;
 % U is standard term, not containing integer powers of lp!&.
 % Returns standard quot or nil, if Laplace transform is impossible.
 begin  scalar  v,w,w1,y,z ;
   v:=car u; % l.pow. - the first factor.
   w:=cdr u; % l.coeff. - i.e. st.f.
   if atom (y:=car v) or atom car y % I.e. atom or Lisp func.
      then if not depends(y,'lp!&)
              then return if (z:=lpform w)
                             then multpq(v,z) else nil
              else if atom y then return lpunknown u
              else if car y = 'expt
                   then return lpexpt(v,nil,w) else nil % Go next.
      else return if not depends(prepsq(y./1),'lp!&)
                     then if (z:=lpform w)
                             then multpq(v,z) else nil
                     else lpunknown u;
 % We can't handle v now, because nothing is known for w for now.
   if domainp w then return lpfunc(v,w);
 % If we have sum, and off exp.
   if cdr w then return if (y:=lpterm list(v,car w)) and
       (z:=lpterm(v . cdr w))then addsq(y,z) else nil;
   w1:=cdar w; % l.coeff - i.e. st.f.
   w :=caar w; % l.pow. - the second factor.
  if not depends(if domainp(y:=car w) then y else prepsq(y./1),'lp!&)
      then return if (z:=lpterm(v.w1)) then multpq(w,z) else nil
      else if car y = 'expt then return lpexpt(w,v,w1);
 % Now we have multiply of two functions.
   if caar v = 'one and caar w = 'one
      then return lpmult1(v,w,w1)
      else return lpunknown u;
 end ;

symbolic procedure  lpunknown  u ;
 % Try to apply any previously given let rules for Laplace operator.
 % U is standard term.
 % Returns standard quotient or nil if matching not successful.
 begin  scalar  d,z,w;
   if domainp (d:=cdr u)  and  not !:onep d
      then (u:= !*p2q car u) else (u:= !*t2q u);
   u:= list('laplace, prepsq u, 'lp!&,transvar!*);
   w:= list('laplace, cadr u,'lp!&); % HM: short rule form
   if get('laplace,'opmtch) and
      ( (z:=opmtch u) or (z:=opmtch w))
      then << !*exp:=t;
              put('laplace,'simpfn,'laplace1);
              z:=simp z; !*exp:=nil;
              put('laplace,'simpfn,'simplaplace) >>;
   if null z then return if !*lmsg
      then msgpri("Laplace for", subla(list('lp!& . lpvar!*), cadr u),
                  if !*lmon or atom cadr u then "not known"
                  else "not known - try ON LMON",nil,nil)
      else nil;
   z:=subla(list('lp!&.lpvar!*), z);
   return if domainp d and not !:onep d then multsq(z,d./1) else z;
 end ;

symbolic procedure  lpsimp1  u ;
 % Simplify the one-function. % U is in prefix form.
 % Returns standard quotient or nil ./ 1 if an error occurs.
 begin  scalar  v,l,r ;
   v:=subla(list(lpvar!* . 'lp!&),u);
   if not depends(car v,'lp!&) then return 1 ./ 1;
   v:= car simpcar v; % Standard form.
   if mvar v neq 'lp!& then << !*mcd:=t; v:=subf(v,nil); !*mcd:=nil;
                               v:=multf(car v, recipf!* cdr v) >>;
   if not(mvar v eq 'lp!&  and  !:onep ldeg v)
      then go to err;
   l:=lc v; r:=red v;  % Standard form.
   if null r then if minusf l then go to err else return 1 ./ 1;
   v:=if minusf l then multsq(negf r ./ 1, 1 ./ negf l)
                  else multsq(r ./ 1, 1 ./ l);
   if not minusf numr v then return 1 ./ 1;
   if null lpshift!* then go to err
      else return mksq(list('one,prepsq addsq(!*k2q 'lp!&, v)), 1);
 err: if !*lmsg then msgpri("Laplace induces", 'one.u,
          " which is not allowed", nil, 'hold);
   return nil ./ 1;
 end ;

symbolic procedure  lpsimpg  u ;
 % Simplifies gamma(k), if k is rational and semiinteger.
 % U is in prefix form. Returns standard quotient.
 begin  scalar  n,v ;
   u:= simpcar cdr u;  % Gamma is now flagged "full".
   if denr u neq 1
     % Maybe we can do better than this.
     then return mksq(list('gamma,prepsq u),1);
   u := car u;
   if domainp u and eqcar(u,'!:rn!:) and (cddr u = 2) % Semiint.
      then return if (n:=cadr u) = 1
                     then mksq(list('sqrt,'pi),1)
                     else if n > 0 then
    << v:='!:rn!: . difference(n,2) . 2 ;
     resimp !*t2q ( (list('gamma,rnprep!: v) to 1) .* v ) >>
                                   else % N negative.
  resimp !*t2q ( (list('gamma,rnprep!:('!:rn!:.plus(n,2) . 2)) to 1)
                 .* ('!:rn!:.(-2).(-n)) )
      else return mksq(list('gamma,prepsq(u./1)),1);
 end ;

symbolic procedure  lpmult1 (u,v,w) ;
 % Perform: one(l1*lp!&-r1)*one(l2*lp!&-r2) = one(l*lp!&-r),
 %   where l,r are those for the rightmost shifted one-function.
 % U and v are standard powers for one-func., w is leading coeff.
 % Returns standard quotient if all coeff. are domains, otherwise nil.
 begin  scalar  u1,v1,l1,r1,l2,r2 ;
   u1:= car simp cadar u;
   v1:= car simp cadar v;
   l1:=lc u1; l2:=lc v1;
   r1:=red u1; r2:=red v1;
   if domainp l1 and domainp l2 and domainp r1 and domainp r2
      then if !:minusp adddm(multdm(r1,l2), !:minus multdm(r2,l1))
              then return lpterm(u . w)
              else return lpterm(v . w)
      else return lpunknown list(u, v.w);
 end ;

symbolic procedure  lpexpt (u,v,w) ;
 % Perform the rule: laplace(e**(l*lp!&)*fun(lp!&), lp!&) =
 %                   sub(il!&=il!&-l, laplace(fun(lp!&),lp!&)),
 %   or call lpfunc for gamma-function.
 % U is lpow for expt-func, v is other lpow or nil.  W is lcoeff.
 % Returns standard quotient or nil.
 begin  scalar  p,q,r,z,l,la ;
   r:=cdr u;  % Degree for expt-func.
   p:=cadar u;  % First arg for expt.
   q:=caddar u;  % Second arg for expt.
   if depends(p,'lp!&) then go to gamma;
   !*exp:=t; q:=car simp q;
   if mvar q neq 'lp!& then << !*mcd:=t; q:=subf(q,nil); !*mcd:=nil;
                               q:=multf(car q, recipf!* cdr q) >>;
   if not !:onep r then q:=multf(q,r); !*exp:=nil;
   if not(mvar q eq 'lp!& and !:onep ldeg q)
      then return if null v then lpunknown(u . w)
                            else lpunknown list(u, v . w);
   if (r:=red q) then
     << if !*ldone then << !*exp:=t;
          w:=multf(w, car lpsimp1 list prepsq(q./1)); !*exp:=nil >>;
        q:=list(lt q); r:=!*p2q(list('expt,p,prepsq(r./1)) to 1) >>;
   if p neq 'e then q:=multf(q, !*kk2f list('log,p) );
   z:= if null v then lpform w else lpterm(v.w);
   if null z then return nil;
   l:= prepsq !*f2q lc q;
   la:=list('il!& . list('difference,'il!&,l) );
   % Provide for those forms that contain the true transform variable.
   if not(transvar!* eq 'il!&)
     then z := subsq(z,list(transvar!* . 'il!&));
   z:=subf(numr z,la);
   return if r then multsq(r,z) else z;
 gamma: % Check and call lpfunc for gamma-func.
   return if null v
      then if domainp w
              then lpfunc(u,w)
              else % if off exp
 % if red w then if (z:=lpexpt(u,v,list(car w)) ) and
 %  (l:=lpexpt(u,v,cdr w)) then addsq(z,l) else nil else
                   if not depends((l:=mvar w),'lp!&)
                      then if (z:=lpexpt(u,nil,lc w))
                              then multpq(lpow w,z) else nil
                      else if not atom l and car l = 'expt
                              then lpexpt(lpow w,u,lc w)
                              else lpunknown(u . w)
      else lpunknown list(u, v . w);
 end ;

symbolic procedure  lpfunc (u,v) ;
 % Perform Laplace transform for intl-operator and simple functions:
 % expt(arg,const), sin,cos,sinh,cosh,one,
 % with args: k*lp!&-tau, where k>0, tau>=0 are const.
 % U is standard power, v a domain element.
 % Returns standard quotient or nil.
 begin  scalar  ld,fn,w,var,ex,k,tau,c ;
   ld:=cdr u;  % Degree of func.
   w:=car u;   % Func in prefix form.
   fn:=car w;  % Name of func.
 lintl: if fn neq 'intl then go to lexpt;
 % Perform Laplace(intl(,,0,lp!&), lp!&).
   if not ( !:onep ld  and  cadddr w =0  and
            car cddddr w = 'lp!&  and  idp(var:=caddr w) )
      then return if !*lmsg then msgpri("Laplace integral",
           subla(list('lp!& . lpvar!*), prepsq !*p2q u),
           "not allowed", nil, nil) else nil;
   ex:= subla(list(var . 'lp!&), cadr w);
   lpshift!*:=nil;  w:= laplace1 list(ex,'lp!&); lpshift!*:=t;
 return if w then multsq(multd(v,!*p2f('il!& to -1))./1, w) else nil;
 lexpt: if fn neq 'expt then go to lfunc;
 % Perform Laplace(expt,(k*lp!&-tau),d), for d - not int. const.
   ld:= multf(ld, car simp caddr w);
   if minusf(addd(1,ld))  or  depends(prepsq(ld./1), 'lp!&)
      then return lpunknown(u.v);
   ld:= prepsq !*f2q ld;
 lfunc: % Perform Laplace transform for simple and one-function.
   if fn = 'expt  or (fn = 'one) or  !:onep ld
      then nil else return lpunknown(u.v);
   !*exp:=t; ex:= car simp cadr w; !*exp:=nil;
   if not( mvar ex = 'lp!&  and  !:onep ldeg ex )
      then return lpunknown(u.v);
   k:=lc ex; tau:=red ex;
   if minusf k or (null lpshift!* and tau) then return
       if !*lmsg then msgpri("Laplace for",
    subla(list('lp!&.lpvar!*), w),"not allowed",nil,nil) else nil;
   if tau  and  not minusf tau  then return lpunknown(u.v);
   c:= prepsq !*f2q k;
 % Ind. lpfn gives Laplace transform for func(k*lp!&).
   if (w:= get(fn,'lpfn))
      then w:=car simp subla(list('k.c, 'd.ld), w);
   return if null w
             then lpunknown(u.v)
             else if null tau
                     then multd(v, w) ./ 1
                     else multd(v, multf( w,!*kk2f list
  ('expt,'e,prepsq multsq(!*k2q 'il!&, quotsq(tau./1, k./1)) )
                               ) ) ./ 1 ;
 end ;

% Tables for Explicit Transforms for Delta Function.  Note explicit
% construction for difference of arguments to reflect parser.

algebraic;

for all x,y,z let laplace(z*delta x,x,y) = sub(x=0,z);

for all k,x,y,z let laplace(z*delta(x+(-k)),x,y) = e**(y*-k)*sub(x=k,z);

for all x,y let laplace(df(delta x,x),x,y) = y;

for all n,x,y let laplace(df(delta x,x,n),x,y) = y**n;

for all k,x,y let laplace(df(delta(x+(-k)),x),x,y) = y*e**(-k*y);

for all k,n,x,y let laplace(df(delta(x+(-k)),x,n),x,y) = y**n*e**(-k*y);

symbolic;


%*******************************************************************
%*                                                                 *
%*              INVERSE  LAPLACE  TRANSFORMATION                   *
%*                                                                 *
%*******************************************************************


put('invlap, 'simpfn, 'simpinvlap);

ile1!*:='( (e (times i !=x))
           (nil depends(reval (quote !=x)) lpvar!*)
           (plus (cos !=x) (times i (sin !=x)))  nil );

ile2!*:='( (e (minus (times i !=x)))
           (nil depends(reval (quote !=x)) lpvar!*)
           (difference (cos !=x) (times i (sin !=x)))  nil );

ile3!*:='( (e !=x )
           (nil depends(reval (quote !=x)) lpvar!*)
           (plus (cosh !=x) (sinh !=x))  nil );

ile4!*:='( (e (minus !=x))
           (nil depends(reval (quote !=x)) lpvar!*)
           (difference (cosh !=x) (sinh !=x))  nil );

ile5!*:='( (e (plus !=x !=y))
           (nil and (not(depends(reval(quote !=x)) (quote i)))
                    (depends(reval(quote !=y)) (quote i)) )
           (times (expt e !=x) (expt e !=y)) nil );

symbolic procedure simpinvlap u;
  begin scalar r,e;
   e:=lap!-save!-environment();
   r:=errorset({'simpinvlap!*,mkquote u},nil,nil);
   lap!-restore!-environment e;
   if errorp r then typerr('invlap.u,"Laplace form")
    else return invlap_fixup car r
  end;

symbolic procedure invlap_fixup u;
   % For some reason, results do not always come out in the most
   % natural form.  This is an attempt to fix this.
   <> where varstack!* = nil;

symbolic procedure simpinvlap!*  u ;
 % Main procedure for inverse Laplace transformation.
 % U is in prefix form: (  ) ,where
 %    is the laplace transform,
 %    is the var. of the Laplace transform (intern. il!&),
 %    is the var. of the object function (intern. lp!&),
 %      and can be omitted - then lp!& is assumed.
 % Returns a standard quotient of inverse Laplace transform.
 begin scalar !*exp,!*mcd,v,w,!*precise;
   % We need to make this run with precise on.
   if null subfg!* then return mksq('invlap . u, 1);
   if cddr u and null idp(w:=caddr u) then go to err;
   v:= caaaar simp cadr u;
   transvar!* := w;
   if null idp v then go to err;
   u:= car u ;
 % Make environment for invlap transform.
   !*exp := !*mcd := nil;
   kord!*:= 'il!& . 'lp!& . kord!* ;
   put('gamma,'simpfn,'lpsimpg);
   put('one,'simpfn,'ilsimp1);
   ilvar!*:=v; if v neq 'il!& then kord!*:=v.kord!*;
   for each x in depl!* do if v memq cdr x then rplacd(x,'il!& . cdr x);
   u:= invlap1 list(u,v);
   put('invlap,'simpfn,'simpiden);
   if w then << lpvar!*:=w; u:=subla(list('lp!& . w), u) >>
        else lpvar!*:='lp!& ;
   if !*ltrig or !*lhyp then << !*exp:=t;
 if !*lhyp then put('expt,'opmtch,ile3!*.ile4!*.get('expt,'opmtch));
 if !*ltrig then put('expt,'opmtch,ile1!*.ile2!*.get('expt,'opmtch));
       put('expt,'opmtch, ile5!*.get('expt,'opmtch));
       u:= simp prepsq u;
       if !*ltrig and !*lhyp
          then put('expt,'opmtch, cdr cddddr get('expt,'opmtch))
          else put('expt,'opmtch, cdddr get('expt,'opmtch)) >>
                        else u:= resimp u;
 % Restore old env.
   for each x in depl!* do
      if 'il!& memq cdr x then rplacd(x,delete('il!&,cdr x));
   put('gamma,'simpfn,'simpiden);
   put('one,'simpfn,'simpiden);
   kord!*:= cddr kord!*;
   return u;
 err: msgpri("Invlap operator incorrect",nil,nil,nil,t);
 end where !*exp = !*exp, !*mcd = !*mcd;

symbolic procedure invlap1 u;
 % Car U is in prefix form, cadr u is the var of the Laplace transform.
 % Returns standard quotient of inverse Laplace transform.
 begin  scalar  v,w,z;
   v := cadr u;
   u := car u;
   z:= simp!* u;
   if denr z neq 1 then z := simp prepsq z;   % *SQ must have occurred.
   if denr z neq 1 then rederr list(u,"has non-trivial denominator");
   z := numr z;
   u := z;
   if v neq 'il!& then << kord!*:=cdr kord!*;
                     u:=subla(list(v.'il!&),u); u:=reorder u >>;
   w:= nil ./ 1;
   while u do
     if domainp u
       then << w:=addsq(w, !*t2q((list('delta,'lp!&) to 1) .* u) );
               u:= nil >>
       else << w:=addsq(w, if (z:=ilterm (lt u,1,1,nil)) then z
                     else !*kk2q list('invlap, subla
        (list('il!&.ilvar!*),prepsq !*t2q lt u), ilvar!*,transvar!*));
               u:= red u >>;
   return w;
 end;

symbolic procedure ilterm (u, numf, denf, rootl) ;
 % U is standard term, numf is standard form, with one term, and
 % contains only powers from numerator of expression, depends on il!&,
 % but not exponent.  Denf is standard form, with one term, and
 % contains only powers from denominator of expression, depends on il!&
 % but not exponent.  Rootl is assoc. list of: ( . ).
 % Returns standard quotient, or nil if inverse Laplace transform is
 % impossible.
 begin  scalar  v,v1,v2,w,y,z,p,p1 ;
   v:=car u; w:=cdr u; v1:=car v; v2:=cdr v;
   if not depends(if domainp v1 then v1 else prepsq(v1./1), 'il!&)
      then return if (z:=ilform(w,numf,denf,rootl))
                     then multpq (v,z) else nil;
   % V depends on il!&.
   if atom v1
         % the following clause "if n1 neq il& then" introduced by HM
       then (if not(v1 = 'il!&) then return ilunknown(u,numf,denf))
    else if atom car v1  % I.e. Lisp func.
     then return
           if car v1 = 'expt
            then ilexpt(v,nil,w,numf,denf,rootl)
           else if domainp w
            then ilexptfn(v,w,numf,denf)
           else if cdr w
            then if(y:=ilterm(list(v,lt w),numf,denf,rootl))
                       and (z:=ilterm(v.cdr w,numf,denf,rootl))
                  then addsq(y,z)
                 else nil
           else ilterm(list(lpow w,v.(lc w)),numf,denf,rootl);

   % May be infinite recursion above, if mult. of two unknown func.
   % Mvar is atom 'il!& or standard form, since exp off.
   if numberp v2 and fixp v2
    then
     if v2 > 0
      then
       if atom v1
        then return ilform(w, multf(!*p2f v,numf), denf, rootl)
        else nil
      else return ilroot(v, w, numf, denf, rootl)
    else return
          ilexpt(list('expt,
                      if domainp v1 then v1 else prepsq(v1./1),
                      prepsq(v2./1)) to 1, nil, w, numf,
                      denf, rootl);

   % Now v1 remains as a standard form and v2>0.
   v:= if !:onep v2 then v1 else !*p2f v;
   if red v1 then
      << !*exp:=t; y:=numr subf(v,nil); z:=y;
         while z do if domainp z then z:=nil
            else if ldeg z < 0 then if depends
          (if domainp(p1:=mvar z) then p1 else prepsq(p1 ./1), 'il!&)
                then << p:=t; z:=nil >> else z:=addf(lc z, red z)
              else z:=addf(lc z,red z);
         if p then w:=multf(y, w) else numf:=multf(v,numf);
         !*exp:=nil >>  else numf:=multf(v,numf);
   return ilform(w,numf,denf,rootl);
 end;

symbolic procedure  ilform (u, numf, denf, rootl) ;
 % U is a standard form.  Numf, denf, rootl are the same as in ILTERM.
 % Returns standard quotient or nil if invlap is impossible.
 begin  scalar  y,z ;
   return if domainp u
             then if (z:=ilresid(numf,denf,rootl))
                     then multsq(u ./ 1, z) else nil
             else if null red u
                     then ilterm(lt u,numf,denf,rootl)
                     else if (y:=ilterm(lt u,numf,denf,rootl)) and
                             (z:=ilform(red u,numf,denf,rootl))
                             then addsq(y,z) else nil;
 end ;

symbolic procedure  ilunknown (u, numf, denf) ;
 % We try here to apply any previously given let rules for Laplace
 % operator.  U is standard term, numf, denf are the same.
 % Returns standard quotient or nil if matching not successful.
 begin  scalar  d,z,w;
   if domainp (d:=cdr u) then if !:onep d
          then u:=!*t2q u else u:=!*p2q car u
      else u:=!*t2q u;
   if numf neq 1 then u:=multsq(u, numf./1);
   if denf neq 1 then u:=multsq(u,1 ./denf);
   u:= list('invlap, prepsq u,'il!&,transvar!*);
       % HM: alternative shorter form for rule match
   w:= list('invlap, cadr u, 'il!&);
   if get('invlap,'opmtch) and
        ((z:=opmtch u) or (z:=opmtch w))
      then << !*exp:=t;
              put('invlap,'simpfn,'invlap1);
              z:=simp z; !*exp:=nil;
              put('invlap,'simpfn,'simpinvlap) >>;
   if null z and !*lmsg then msgpri("Invlap for",
                     subla(list('il!& . ilvar!*), cadr u),
                     "not known", nil, nil);
   return if null z then nil
      else if domainp d and not !:onep d
              then multsq(z, d ./ 1) else z;
 end ;

symbolic procedure  ilsimp1  u ;
 % Simplify the one-function.  U is in prefix form.
 % Returns standard quotient.
 if atom car u then 1 ./ 1 else mksq('one . u, 1);

symbolic procedure  ilexpt (u, v, w, numf, denf, rootl) ;
 % Perform the rule: invlap(e**(-l*il!&)*fun(il!&), il!&) =
 %     sub(lp!&=lp!&-l, invlap(fun(il!&),il!&)), for l > 0,
 % or call ilfunc for gamma-function.
 % U is lpow for expt-function, v is other lpow or nil,
 % W is lcoeff (standard form), numf, denf, rootl are the same.
 % Returns standard quotient or nil.
 begin  scalar  p,q,r,z,l ;
   r:=cdr u;  % Degree for expt-func.
   p:=cadar u;  % First arg for expt.
   q:=caddar u;  % Second arg for expt.
   if depends(p,'il!&)then go to gamma;
   !*exp:=t; q:=car simp q;
   if mvar q neq 'il!& then << !*mcd:=t; q:=subf(q,nil); !*mcd:=nil;
                               q:=multf(car q, recipf!* cdr q) >>;
   if not !:onep r then q:=multf(q,r); !*exp:=nil;
   if not((mvar q = 'il!&) and !:onep ldeg q and minusf lc q)
      then return if null v then ilunknown(u.w,numf,denf)
                            else ilunknown(list(u,v.w),numf,denf);
   if (r:=red q) then<< q:=list(lt q);
                        r:=!*p2q(list('expt,p,prepsq(r./1)) to 1) >>;
   if p neq 'e then q:=multf(q, !*kk2f list('log,p) );
   z:= if null v then ilform(w,numf,denf,rootl)
                 else ilterm(v.w,numf,denf,rootl);
   if null z then return nil;
   l:= list('plus, 'lp!&, prepsq((lc q)./1));
   z:= subf(numr z, list('lp!& . l) ) ;  % Standard quotient.
 % If you want shifted one-func. to remain always in obj. func.
   if !*lione then z:=multsq(z, !*kk2q list('one,l) );
   return if r then multsq(r,z) else z ;
 gamma: % Check and call ilfunc if gamma-func. case.
   return if null v
     then if domainp w
       then ilexptfn(u,w,numf,denf)
       else if red w
         then if (z:=ilexpt(u,nil,list(car w),numf,denf,rootl)) and
                 (l:=ilexpt(u,nil,cdr w,numf,denf,rootl))
                 then addsq(z,l) else nil
         else if not depends(if domainp(l:=mvar w) then l
                                else prepsq(l./1), 'il!&)
           then if (z:=ilexpt(u,nil,lc w,numf,denf,rootl))
                   then multpq(lpow w,z) else nil
           else if not atom l and (car l = 'expt)
             then ilexpt(lpow w,u,lc w,numf,denf,rootl)
             else if atom l or not atom car l
               then ilterm(list(lpow w,u.(lc w)),numf,denf,rootl)
               else ilunknown(u.w,numf,denf)
     else ilunknown(list(u,v.w),numf,denf) ;
 end ;

symbolic procedure  ilexptfn (u, v, numf, denf) ;
 % Perform invlap for expt function - i.e., gamma-function case.
 % U is standard power for expt, v is domain, numf, denf the same.
 % Returns standard quotient or nil.
 begin  scalar  ex,dg,fn,k,a,b,y,d ;
   ex:=car u; dg:=cdr u; fn:=car ex;
   if fn neq 'expt then go to unk;
   d:=caddr ex; if atom(ex:=cadr ex) then k:=t;
   !*exp:=t; ex:=car simp ex;
   dg:=multd(dg,car simp d); a:=lc ex;
   if not(domainp a and !:onep a) then
     << ex:=multf(ex, recipf!* a);
        a:=!*kk2f list('expt,prepsq(a./1),prepsq(dg./1)) >>;
   b:=red ex; !*exp:=nil;
   if (mvar ex neq 'il!&) or (ldeg ex neq 1) or
      depends(prepsq(b./1),'il!&) then go to unk;
   if (numf=1) and (denf=1) then go to ret;
 % We must have identical monomials in numf, denf and in expt-func.
   y:= multf(multf(numf, !*kk2f list('expt,
       prepsq(ex./1),prepsq(dg./1)) ), recipf!* denf);
   if cdr y or (lc lc y neq 1) or (car mvar lc y neq 'expt)
      or (not k and (mvar y neq ex))
      or (k and (mvar y neq mvar ex)) then go to unk;
   dg:=addd(ldeg y,dg);
 ret: if minusf dg then d:=prepsq(negf dg ./ 1) else go to unk;
   if (y:=get(fn,'ilfn))
      then y:=car simp subla(list('d.d), y) else go to unk;
   if b then y:=multd(v, multf(y, !*kk2f list
          ('expt,'e,prepsq(multf(!*k2f 'lp!&,negf b) ./1)) ))
        else y:=multd(v, y);
   return if domainp a and !:onep a then y./1 else multf(a,y)./1;
 unk: return ilunknown(u.v, numf, denf);
   end   ;

put('expt,'ilfn,'(quotient (expt lp!& (plus d (minus 1))) (gamma d)));

symbolic procedure  addrootl (root,mltpl,rootl) ;
 % Add roots with multiplity at head of rootl - an assoc. list.
 begin  scalar  parr ;
   parr:=assoc(root,rootl);
   if parr then << mltpl:= mltpl + cdr parr;
                   rootl:= delete(parr,rootl) >>;
   return (root . mltpl) . rootl ;
 end     ;

symbolic procedure  recipf!*  u ;
 % U is standard form. Returns st.f. for u to (-1), by off mcd.
 begin scalar  d;
   if domainp u then if !:onep u then return 1
        else if !:onep negf u then return -1
          else if fieldp u then nil
            else if (d:=get(dmode!*,'i2d))
              then u:=apply1(d,u) else u:=mkratnum u
      else return if cdr u then !*p2f(u to (-1))
        else multf(!*p2f(mvar u to (-ldeg u)), recipf!* lc u);
   return dcombine(1,u,'quotient);
 end   ;

symbolic procedure ilroot (u,v,numf,denf,rootl);
 % Find the roots of polynomial of first and second degree.
 % U is standard power - the polynomial, v is the remaining st.f.
 % Numf, denf, rootl are the same. Returns standard quot or nil.
 begin  scalar  dg,ex,a,b,c,z,x1,x2 ;
   dg:=-cdr u; ex:=car u; % dg>0;
   if atom ex then return ilform(v,numf,
           multf(!*p2f('il!& to dg),denf), addrootl(nil,dg,rootl) );
   if atom car ex then return ilunknown(u.v,numf,denf);
   !*exp:=t; ex:=subf(ex,nil); !*exp:=nil;
   if not depends(prepsq ex, 'il!&) then return
      if (z:=ilform(v,numf,denf,rootl)) then multpq(u,z) else nil;
   ex:=car ex;
   if ldeg ex > 2 then return il3pol(u,v,numf,denf,rootl);
   a:=lc ex;
   if depends(prepsq(a./1),'il!&)
      then return ilunknown(u.v,numf,denf);
   if not(domainp a and !:onep a) then
      << !*exp:=t; a:=recipf!* a; ex:=multf(ex,a);
         if dg>1 then a:=exptf(a,dg); !*exp:=nil >>;
   if ldeg ex = 2 then go to lbin;
 lmon: if (b:=red ex)
          then << rootl:=addrootl(negf b, dg, rootl);
                  denf:= if !:onep dg then multf(ex, denf)
                            else multpf(ex to dg, denf) >>
          else << rootl:=addrootl(nil, dg, rootl);
                  denf:= multpf('il!& to dg, denf) >>;
   go to ret;
 lbin: if (b:=red ex)
          then if domainp b then << c:=b; b:=nil >>
             else if mvar b = 'il!& then << c:=red b; b:=lc b >>
                                    else << c:=b; b:=nil >>
          else c:=nil ;
   if depends(prepsq(b./1),'il!&) or depends(prepsq(c./1),'il!&)
      then return ilunknown(u.v,numf,denf);
   if null b and null c
     then << rootl:=addrootl(nil, 2*dg, rootl);
             denf:=multpf('il!& to (2*dg), denf) >>
     else << !*exp:=t; b:=multd('!:rn!: . ((-1) . 2), b);
       c := simp list('sqrt,prepsq(addf(multf(b,b),negf c)./1));
       if fixp denr c
         then c := multd(('!:rn!: . 1 . denr c),numr c)
        else rederr {"invalid laplace denominator",denr c};
             x1:=addf(b,c); x2:=addf(b,negf c); !*exp:=nil;
             if x1 = x2 then << rootl:=addrootl(x1,2*dg,rootl);
                                x1:=(('il!& to 1).*1) .+ negf x1;
                                denf:=multpf(x1 to (2*dg),denf) >>
                else << rootl:=addrootl(x2,dg,addrootl(x1,dg,rootl));
                        x1:=(('il!& to 1).*1) .+ negf x1;
                        x2:=(('il!& to 1).*1) .+ negf x2;
                        if not !:onep dg then
                     << x1:=!*p2f(x1 to dg); x2:=!*p2f(x2 to dg) >>;
                        denf:=multf(x2,multf(x1,denf)) >>  >>;
 ret: z:=ilform(v,numf,denf,rootl);
   return if (domainp a and !:onep a) then z
             else if null z then nil else multsq(a./1, z);
   end;

symbolic procedure  il3pol (u, v, numf, denf, rootl) ;
 % Find the roots of polynomial of third and higher degree.
 % U is standard power - the polynomial, v is the remaining st.f.
 % Numf, denf, rootl are the same. Returns standard quot or nil.
 (begin  scalar  a,d,p,y,z,w;
   if !*rounded then go to unk;
   d:=-cdr u; p:=car u;
   !*exp:=t; !*mcd:=t;
   % We must now convert rationals, if any, to standard quotients.
   % Since MCD was previously off, we must use limitedfactors here,
   % since the regular factorization turns EZGCD on.
   !*limitedfactors := t;
   y:=p; p:=nil./1;
   while y do if domainp y then << p:=addsq(p,!*d2q y); y:=nil >>
       else << a:=1; z:=list car y; % S.F. with 1 term only.
               while not domainp z do
                 << w:=lpow z;
                     % distinguish between mvar=kernel/form
                    w:=if kernlp car w then !*p2f w else
                          exptf(car w,cdr w);
                    a:=multf(a,w);
                    z:=lc z
                 >>;
               p:=addsq(p,multsq(a./1,!*d2q z)); y:=red y >>;
   if ((a:=cdr p) neq 1) and (d neq 1) then a:=exptf(a,d);
   z := fctrf car p;
   !*exp:=nil; !*mcd:=nil;
   % if length z = 2 then go to unk;   % No factors.
   % corrected (HM):
   if length z=2 and cdr cadr z=1 then go to unk;
   if car z neq 1 then errach list(car z,"found in IL3POL");
   z:=cdr z; y:=v;
   while z do << p:= caar z;
                 if cdar z neq 1 then p := exptf(p,cdar z);
                 if d neq 1 then p:=exptf(p,d);
                 y:=multf(y,recipf!* p); z:=cdr z >>;
   y:=ilform(y,numf,denf,rootl);
   if null y then go to unk
      else return if a = 1 then y else multsq(a./1, y);
 unk: return ilunknown(u.v,numf,denf);
 end) where !*limitedfactors := !*limitedfactors;

symbolic procedure  ilresid (numf, denf, rootl) ;
 % Apply the residue theorem at last.
 % Numf, denf, rootl are standard forms.  Returns standard quot or nil.
 begin scalar  n,d,ndeg,ddeg,m,x,y,z,w ;
   !*exp:=t; n:=numr subf(numf,nil); !*exp:=nil;
   z:=nil ./ 1; w:=nil ./ 1; x:=n; % Result accumulated in w.
   while x and not domainp x do
     << y:=car x; x:=cdr x;
        if depends(prepsq(cdr y./1),'il!&) or (caar y neq 'il!&
               and depends(caar y,'il!&) )
           then if (z:=ilterm(y,1,denf,rootl))
                   then << w:=addsq(w,z); n:=delete(y,n) >>
                   else x:=nil >> ;
   if null z then return ;
 % Now n is polynomial of il!& with constant coeff.
   ndeg:=if not domainp n and mvar n = 'il!& then ldeg n else 0;
   !*exp:=t; d:=numr subf(denf,nil); !*exp:=nil;
   ddeg:=if not domainp d and mvar d = 'il!& then ldeg d else 0;
   if ndeg < ddeg then go to resid;
   !*exp:=t; y:=qremf(n,d); !*exp:=nil;
   n:=cdr y; x:=car y; % N is remainder polynomial.
   while x do if domainp x
     then << w:=addsq(w, !*t2q(('(delta lp!&) to 1).* x)); x:=nil >>
     else if mvar x neq 'il!&
       then << w:=addsq(w, multsq(!*kk2q '(delta lp!&), !*t2q lt x) );
               x:=red x >>
       else << w:=addsq(w, multsq(!*kk2q list('df,list('delta,'lp!&),
                  'lp!&,ldeg x), lc x ./ 1) ); x:=red x >> ;
 resid: if null rootl then return w ;
   x:=caar rootl; m:=cdar rootl;
   if null x then y:=!*p2f('il!& to m)
      else << y:=(('il!& to 1) .* 1) .+ negf x;
              if m neq 1 then y:=!*p2f(y to m) >>;
   !*exp:=t; y:=numr subf(y,nil);
   y:=car qremf(d,y); !*exp:=nil; % D is quotient - remainder = 0.
   z:=multpf('(expt e (times il!& lp!&)) to 1, n); % Numerator.
   y:=recipf!* y;
   z:=multf(z,y) ./ 1;
   while (m:=m-1) > 0 do  z:=diffsq(z, 'il!&);
   x:= if null x then 0 else prepsq(x./1); % Root in prefix form.
   !*exp:=t; z:=subf(numr z, list('il!&.x)); % One residue as st.q.
   if not depends(prepsq z, 'lp!&)
      then z:=multsq(z, !*kk2q '(one lp!&));
   if (m:=cdar rootl) > 2 then while (m:=m-1) > 1 do
       z:=multf(car z,'!:rn!: . 1 . m)./1;
   w:=addsq(w,z); !*exp:=nil;
   rootl:=cdr rootl; go to resid;
 end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/laplace.rlg0000644000175000017500000007055111527635055024240 0ustar  giovannigiovanniFri Feb 18 21:27:58 2011 run on win32
% Title:  Examples of Laplace Transforms.

% Author: L. Kazasov.

% Date: 24 October 1988.

order p;



% Elementary functions with argument k*x, where x is object var.

laplace(1,x,p);


 1
---
 p

laplace(c,x,p);


 c
---
 p

laplace(sin(k*x),x,p);


    k
---------
  2    2
 p  + k
 laplace(sin(x/a),x,p);


     a
-----------
  2  2
 p *a  + 1

laplace(sin(17*x),x,p);


    17
----------
  2
 p  + 289

laplace(sinh x,x,p);


   1
--------
  2
 p  - 1

laplace(cosh(k*x),x,p);


     - p
------------
     2    2
  - p  + k

laplace(x,x,p);


 1
----
  2
 p
 laplace(x**3,x,p);


 6
----
  4
 p

off mcd;

 laplace(e**(c*x) + a**x, x, s);


                -1          -1
 - ((log(a) - s)   + (c - s)  )

laplace(e**x - e**(a*x) + x**2, x, p);


   -3             -1          -1
2*p   + ( - p + a)   + (p - 1)

laplace(one(k*t) + sin(a*t) - cos(b*t) - e**t, t, p);


       2    2 -1    -1     2    2 -1            -1
 - p*(p  + b )   + p   + (p  + a )  *a - (p - 1)

laplace(sqrt(x),x,p);


               - 3/2
1/2*sqrt(pi)*p
 laplace(x**(1/2),x,p);


               - 3/2
1/2*sqrt(pi)*p
 on mcd;


laplace(x**(-1/2),x,p);


 sqrt(pi)
----------
 sqrt(p)
 laplace(x**(5/2),x,p);


 15*sqrt(pi)
--------------
            3
 8*sqrt(p)*p

laplace(-1/4*x**2*c*sqrt(x), x, p);


  - 15*sqrt(pi)*c
------------------
              3
  32*sqrt(p)*p


% Elementary functions with argument k*x - tau,
%   where k>0, tau>=0, x is object var.

laplace(cos(x-a),x,p);


       p
---------------
  p*a   2
 e   *(p  + 1)

laplace(one(k*x-tau),x,p);


      1
--------------
  (p*tau)/k
 e         *p

laplace(sinh(k*x-tau),x,p);


           - k
-------------------------
  (p*tau)/k      2    2
 e         *( - p  + k )
 laplace(sinh(k*x),x,p);


     - k
------------
     2    2
  - p  + k

laplace((a*x-b)**c,x,p);


  c
 a *gamma(c + 1)
-----------------
   c  (p*b)/a
  p *e       *p

% But ...
off mcd;

 laplace((a*x-b)**2,x,p);


 -3   2  2                2
p  *(p *b  - 2*p*a*b + 2*a )
 on mcd;


laplace(sin(2*x-3),x,p);


         2
-------------------
  (3*p)/2   2
 e       *(p  + 4)

on lmon;

 laplace(sin(2*x-3),x,p);


         2
-------------------
  (3*p)/2   2
 e       *(p  + 4)
 off lmon;


off mcd;

 laplace(cosh(t-a) - sin(3*t-5), t, p);


  - p*a     2     -1       - 5/3*p   2     -1
e      *p*(p  - 1)   - 3*e        *(p  + 9)
 on mcd;



% More complicated examples - multiplication of functions.
% We use here on lmon - a new switch that forces all
% trigonometrical functions which depend on object var
% to be represented as exponents.

laplace(x*e**(a*x)*cos(k*x), x, p);


                           2            2    2
                          p  - 2*p*a + a  - k
-------------------------------------------------------------------------
  4      3        2  2      2  2        3          2    4      2  2    4
 p  - 4*p *a + 6*p *a  + 2*p *k  - 4*p*a  - 4*p*a*k  + a  + 2*a *k  + k

laplace(x**(1/2)*e**(a*x), x, p);


        - sqrt(pi)
--------------------------
 2*sqrt(p - a)*( - p + a)

laplace(-1/4*e**(a*x)*(x-k)**(-1/2), x, p);


               a*k
   - sqrt(pi)*e
--------------------
    p*k
 4*e   *sqrt(p - a)

laplace(x**(5/2)*e**(a*x), x, p);


                 - 15*sqrt(pi)
----------------------------------------------
                    3      2          2    3
 8*sqrt(p - a)*( - p  + 3*p *a - 3*p*a  + a )

laplace((a*x-b)**c*e**(k*x)*const/2, x, p);


     (b*k)/a  c
  - e       *a *gamma(c + 1)*const
-----------------------------------
     (p*b)/a        c
  2*e       *(p - k) *( - p + k)

off mcd;

 laplace(x*e**(a*x)*sin(7*x)/c*3, x, p);


     2            2      -2  -1
42*(p  - 2*p*a + a  + 49)  *c  *(p - a)
 on mcd;


laplace(x*e**(a*x)*sin(k*x-tau), x, p);


  (a*tau)/k   2                            2                2         (p*tau)/k
(e         *(p *tau - 2*p*a*tau + 2*p*k + a *tau - 2*a*k + k *tau))/(e

      4      3        2  2      2  2        3          2    4      2  2    4
   *(p  - 4*p *a + 6*p *a  + 2*p *k  - 4*p*a  - 4*p*a*k  + a  + 2*a *k  + k ))

% The next is unknown if lmon is off.
laplace(sin(k*x)*cosh(k*x), x, p);


*** Laplace for cosh(x*k)*sin(x*k) not known - try ON LMON 

laplace(cosh(k*x)*sin(k*x),x,p)

laplace(x**(1/2)*sin(k*x), x, p);


*** Laplace for sqrt(x)*sin(x*k) not known - try ON LMON 

laplace(sqrt(x)*sin(k*x),x,p)

on lmon;

  % But now is OK.
laplace(x**(1/2)*sin(a*x)*cos(a*b), x, p);


(sqrt(pi)*cos(a*b)

 *(sqrt(p - a*i)*p*i - sqrt(p + a*i)*p*i + sqrt(p - a*i)*a + sqrt(p + a*i)*a))/(

                                   2    2
   4*sqrt(p + a*i)*sqrt(p - a*i)*(p  + a ))

laplace(sin(x)*cosh(x), x, p);


  2
 p  + 2
--------
  4
 p  + 4

laplace(sin(k*x)*cosh(k*x), x, p);


     2      2
 k*(p  + 2*k )
---------------
    4      4
   p  + 4*k

% Off exp leads to very messy output in this case.
% off exp; laplace(sin(k*x-t)*cosh(k*x-t), x, p); on exp;
laplace(sin(k*x-t)*cosh(k*x-t), x, p);


        2      2
    k*(p  + 2*k )
----------------------
  (p*t)/k   4      4
 e       *(p  + 4*k )

laplace(cos(x)**2,x,p);


    2
   p  + 2
------------
     2
 p*(p  + 4)
laplace(c*cos(k*x)**2,x,p);


     2      2
 c*(p  + 2*k )
---------------
     2      2
 p*(p  + 4*k )

laplace(c*cos(2/3*x)**2, x, p);


       2
 c*(9*p  + 8)
---------------
       2
 p*(9*p  + 16)

laplace(5*sinh(x)*e**(a*x)*x**3, x, p);


       3      2          2        3         8      7         6  2      6
(120*(p  - 3*p *a + 3*p*a  + p - a  - a))/(p  - 8*p *a + 28*p *a  - 4*p

          5  3       5         4  4       4  2      4       3  5       3  3
    - 56*p *a  + 24*p *a + 70*p *a  - 60*p *a  + 6*p  - 56*p *a  + 80*p *a

          3         2  6       2  4       2  2      2        7         5
    - 24*p *a + 28*p *a  - 60*p *a  + 36*p *a  - 4*p  - 8*p*a  + 24*p*a

            3            8      6      4      2
    - 24*p*a  + 8*p*a + a  - 4*a  + 6*a  - 4*a  + 1)

off exp;

 laplace(sin(2*x-3)*cosh(7*x-5), x, p);


                2  11    2         11              11
               p *e   + p  + 14*p*e   - 14*p + 53*e   + 53
-------------------------------------------------------------------------
  (3*p + 1)/2                                                          5
 e           *(p + 7 + 2*i)*(p + 7 - 2*i)*(p - 7 + 2*i)*(p - 7 - 2*i)*e
 on exp;


laplace(sin(a*x-b)*cosh(c*x-d), x, p);


*** Laplace for  - 1/4*one((x*a - b)/a)*one((x*c - d)/c)*i**(-1) not known 

*** Laplace for 1/4*one((x*a - b)/a)*one((x*c - d)/c)*i**(-1) not known 

             a*i*x      a*x - b        c*x - d       2*c*x    2*d
          - e     *one(---------)*one(---------)*i*(e      + e   )
                           a              c
laplace(-----------------------------------------------------------,x,p)
                                b*i + c*x + d
                             4*e

             b*i      a*x - b        c*x - d       2*c*x    2*d
            e   *one(---------)*one(---------)*i*(e      + e   )
                         a              c
 + laplace(------------------------------------------------------,x,p)
                                a*i*x + c*x + d
                             4*e

% To solve this problem we must tell the program which one-function
% is rightmost shifted.  However, in REDUCE 3.4, this rule is still
% not sufficient.
for all x let one(x-b/a)*one(x-d/c) = one(x-b/a);


laplace(sin(a*x-b)*cosh(c*x-d), x, p);


     (2*b*c)/a  2    2*d  2      (2*b*c)/a          2*d        (2*b*c)/a  2
(a*(e         *p  + e   *p  + 2*e         *p*c - 2*e   *p*c + e         *a

        (2*b*c)/a  2    2*d  2    2*d  2       (p*b + a*d + b*c)/a
     + e         *c  + e   *a  + e   *c ))/(2*e

      4      2  2      2  2    4      2  2    4
   *(p  + 2*p *a  - 2*p *c  + a  + 2*a *c  + c ))

for all x clear one(x-b/a)*one(x-d/c) ;


off lmon;



% Floating point arithmetic.
% laplace(3.5/c*sin(2.3*x-4.11)*e**(1.5*x), x, p);
on rounded;


laplace(3.5/c*sin(2.3*x-4.11)*e**(1.5*x), x, p);


                   117.461059957
----------------------------------------------------
              1.78695652174*p     2
 2.71828182846               *c*(p  - 3.0*p + 7.54)

laplace(x**2.156,x,p);


 2.32056900246
---------------
     3.156
    p

laplace(x**(-0.5),x,p);


 1.77245385091
---------------
      0.5
     p

off rounded;

 laplace(x**(-0.5),x,p);


 sqrt(pi)
----------
 sqrt(p)
 on rounded;


laplace(x*e**(2.35*x)*cos(7.42*x), x, p);


                   2
                  p  - 4.7*p - 49.5339
---------------------------------------------------------
  4        3             2
 p  - 9.4*p  + 143.2478*p  - 569.44166*p + 3669.80312521

laplace(x*e**(2.35*x)*cos(7.42*x-74.2), x, p);


                 3                      2
(160664647206.0*p  - 1.11661929808e+12*p  + 1.14319162408e+13*p

                                     10.0*p
  - 2.36681205089e+13)/(2.71828182846

      4        3             2
   *(p  - 9.4*p  + 143.2478*p  - 569.44166*p + 3669.80312521))

% Higher precision works, but uses more memory.
% precision 20; laplace(x**2.156,x,p);
% laplace(x*e**(2.35*x)*cos(7.42*x-74.2), x, p);
off rounded;



% Integral from 0 to x, where x is object var.
% Syntax is intl(,,0,).

laplace(c1/c2*intl(2*y**2,y,0,x), x,p);


 4*c1
-------
  4
 p *c2

off mcd;

 laplace(intl(e**(2*y)*y**2+sqrt(y),y,0,x),x,p);


 -1           -3                  - 3/2
p  *(2*(p - 2)   + 1/2*sqrt(pi)*p      )
 on mcd;


laplace(-2/3*intl(1/2*y*e**(a*y)*sin(k*y),y,0,x), x, p);


                                2*k*( - p + a)
-------------------------------------------------------------------------------
       4      3        2  2      2  2        3          2    4      2  2    4
 3*p*(p  - 4*p *a + 6*p *a  + 2*p *k  - 4*p*a  - 4*p*a*k  + a  + 2*a *k  + k )


% Use of delta function and derivatives.

laplace(-1/2*delta(x), x, p);


  - 1
------
  2
 laplace(delta(x-tau), x, p);


   1
--------
  p*tau
 e

laplace(c*cos(k*x)*delta(x),x,p);


c

laplace(e**(a*x)*delta(x), x, p);


1

laplace(c*x**2*delta(x), x, p);


0

laplace(-1/4*x**2*delta(x-pi), x, p);


      2
  - pi
---------
    p*pi
 4*e

laplace(cos(2*x-3)*delta(x-pi),x,p);


 cos(3)
--------
  p*pi
 e

laplace(e**(-b*x)*delta(x-tau), x, p);


      1
--------------
  tau*(p + b)
 e

on lmon;


laplace(cos(2*x)*delta(x),x,p);


1

laplace(c*x**2*delta(x), x, p);


0

laplace(c*x**2*delta(x-pi), x, p);


     2
 c*pi
-------
  p*pi
 e

laplace(cos(a*x-b)*delta(x-pi),x,p);


 cos(a*pi - b)
---------------
      p*pi
     e

laplace(e**(-b*x)*delta(x-tau), x, p);


      1
--------------
  tau*(p + b)
 e

off lmon;



laplace(2/3*df(delta x,x),x,p);


 2*p
-----
  3

off exp;

 laplace(e**(a*x)*df(delta x,x,5), x, p);


             5
 - ( - p + a)
 on exp;


laplace(df(delta(x-a),x), x, p);


  p
------
  p*a
 e

laplace(e**(k*x)*df(delta(x),x), x, p);


p - k

laplace(e**(k*x)*c*df(delta(x-tau),x,2), x, p);


  k*tau     2            2
 e     *c*(p  - 2*p*k + k )
----------------------------
            p*tau
           e

on lmon;

laplace(e**(k*x)*sin(a*x)*df(delta(x-t),x,2),x,p);


  k*t      2*a*i*t  2      2        2*a*i*t          2*a*i*t
(e   *( - e       *p *i + p *i - 2*e       *p*a + 2*e       *p*i*k - 2*p*a

                     2*a*i*t  2        2*a*i*t        2*a*i*t    2    2
        - 2*p*i*k + e       *a *i + 2*e       *a*k - e       *i*k  - a *i

                     2       t*(p + a*i)
        + 2*a*k + i*k ))/(2*e           )
off lmon;



% But if tau is positive, Laplace transform is not defined.

laplace(e**(a*x)*delta(x+tau), x, p);


*** Laplace for delta(x + tau) not known - try ON LMON 

         a*x
laplace(e   *delta(tau + x),x,p)

laplace(2*c*df(delta(x+tau),x), x, p);


*** Laplace for df(delta(x + tau),x) not known - try ON LMON 

laplace(2*df(delta(tau + x),x)*c,x,p)

laplace(e**(k*x)*df(delta(x+tau),x,3), x, p);


*** Laplace for df(delta(x + tau),x,3) not known - try ON LMON 

         k*x
laplace(e   *df(delta(tau + x),x,3),x,p)


% Adding new let rules for Laplace operator. Note the syntax.

for all x let laplace(log(x),x) = -log(gam*il!&)/il!&;


laplace(-log(x)*a/4, x, p);


 log(p*gam)*a
--------------
     4*p
 laplace(-log(x),x,p);


 log(p*gam)
------------
     p

laplace(a*log(x)*e**(k*x), x, p);


 log(gam*(p - k))*a
--------------------
       - p + k

for all x clear laplace(log(x),x);



operator f;

 for all x let
    laplace(df(f(x),x),x) = il!&*laplace(f(x),x) - sub(x=0,f(x));


for all x,n such that numberp n and fixp n let
    laplace(df(f(x),x,n),x) = il!&**n*laplace(f(x),x) -
      for i:=n-1 step -1 until 0 sum
        sub(x=0, df(f(x),x,n-1-i)) * il!&**i ;


for all x let laplace(f(x),x) = f(il!&);



laplace(1/2*a*df(-2/3*f(x)*c,x), x,p);


 a*c*( - p*f(p) + f(0))
------------------------
           3

laplace(1/2*a*df(-2/3*f(x)*c,x,4), x,p);


          4         3         2
(a*c*( - p *f(p) + p *f(0) + p *sub(x=0,df(f(x),x)) + p*sub(x=0,df(f(x),x,2))

       + sub(x=0,df(f(x),x,3))))/3

laplace(1/2*a*e**(k*x)*df(-2/3*f(x)*c,x,2), x,p);


          2                                                2
(a*c*( - p *f(p - k) + 2*p*f(p - k)*k + p*f(0) - f(p - k)*k  - f(0)*k

       + sub(x=0,df(f(x),x))))/3

clear f;



% Or if the boundary conditions are known and assume that
% f(i,0)=sub(x=0,df(f(x),x,i)) the above may be overwritten as:
operator f;

 for all x let
    laplace(df(f(x),x),x) = il!&*laplace(f(x),x) - f(0,0);


for all x,n such that numberp n and fixp n let
    laplace(df(f(x),x,n),x) = il!&**n*laplace(f(x),x) -
      for i:=n-1 step -1 until 0 sum il!&**i * f(n-1-i,0);


for all x let laplace(f(x),x) = f(il!&);


let f(0,0)=0, f(1,0)=1, f(2,0)=2, f(3,0)=3;


laplace(1/2*a*df(-2/3*f(x)*c,x), x,p);


  - p*f(p)*a*c
---------------
       3

laplace(1/2*a*df(-2/3*f(x)*c,x,4), x,p);


          4         2
 a*c*( - p *f(p) + p  + 2*p + 3)
---------------------------------
                3

clear f(0,0), f(1,0), f(2,0), f(3,0);

 clear f;



% Very complicated examples.

on lmon;


laplace(sin(a*x-b)**2, x, p);


             2
          2*a
------------------------
  (p*b)/a     2      2
 e       *p*(p  + 4*a )

off mcd;

 laplace(x**3*(sin x)**4*e**(5*k*x)*c/2, x,p);


                          -4                       -4                         -4
c*(3/16*( - p + 4*i + 5*k)   + 3/16*(p + 4*i - 5*k)   - 3/4*( - p + 2*i + 5*k)

                         -4                   -4
    - 3/4*(p + 2*i - 5*k)   + 9/8*( - p + 5*k)  )

a:=(sin x)**4*e**(5*k*x)*c/2;


          5*k*x       4
a := 1/2*e     *sin(x) *c
 laplace(x**3*a,x,p);


                          -4                       -4                         -4
c*(3/16*( - p + 4*i + 5*k)   + 3/16*(p + 4*i - 5*k)   - 3/4*( - p + 2*i + 5*k)

                         -4                   -4
    - 3/4*(p + 2*i - 5*k)   + 9/8*( - p + 5*k)  )
 clear a;

 on mcd;


% And so on, but is very time consuming.
% laplace(e**(k*x)*x**2*sin(a*x-b)**2, x, p);
% for all x let one(a*x-b)*one(c*x-d) = one(c*x-d);
% laplace(x*e**(-2*x)*cos(a*x-b)*sinh(c*x-d), x, p);
% for all x clear one(a*x-b)*one(c*x-d) ;
% laplace(x*e**(c*x)*sin(k*x)**3*cosh(x)**2*cos(a*x), x, p);
off lmon;



% Error messages.

laplace(sin(-x),x,p);


***** Laplace induces one( - x)  which is not allowed 

laplace( - sin(x),x,p)

on lmon;

 laplace(sin(-a*x), x, p);


***** Laplace induces one( - x*a)  which is not allowed 

laplace( - sin(a*x),x,p)
 off lmon;


laplace(e**(k*x**2), x, p);


*** Laplace for e**(x**2*k) not known - try ON LMON 

            2
         k*x
laplace(e    ,x,p)

laplace(sin(-a*x+b)*cos(c*x+d), x, p);


*** Laplace for  - cos(x*c + d)*sin(x*a - b) not known - try ON LMON 

laplace( - cos(c*x + d)*sin(a*x - b),x,p)

laplace(x**(-5/2),x,p);


*** Laplace for x**( - 5/2) not known - try ON LMON 

             1
laplace(------------,x,p)
                  2
         sqrt(x)*x

% With int arg, can't be shifted.
laplace(intl(y*e**(a*y)*sin(k*y-tau),y,0,x), x, p);


*** Laplace for sin(x*k - tau) not allowed 

          a*x
 laplace(e   *sin(k*x - tau)*x,x,p)
------------------------------------
                 p

laplace(cosh(x**2), x, p);


*** Laplace for cosh(x**2) not known - try ON LMON 

              2
laplace(cosh(x ),x,p)

laplace(3*x/(x**2-5*x+6),x,p);


*** Laplace for (x**2 - 5*x + 6)**(-1) not known - try ON LMON 

             3*x
laplace(--------------,x,p)
          2
         x  - 5*x + 6

laplace(1/sin(x),x,p);


*** Laplace for sin(x)**(-1) not known - try ON LMON 

           1
laplace(--------,x,p)
         sin(x)
   % But ...
laplace(x/sin(-3*a**2),x,p);


      - 1
--------------
  2        2
 p *sin(3*a )

% Severe errors.
% laplace(sin x,x,cos y);
% laplace(sin x,x,y+1);
% laplace(sin(x+1),x+1,p);


Comment  Examples of Inverse Laplace transformations;


symbolic(ordl!* := nil);

   % To nullify previous order declarations.

order t;



% Elementary ratio of polynomials.

invlap(1/p, p, t);


1

invlap(1/p**3, p, t);


  2
 t
----
 2

invlap(1/(p-a), p, t);


 t*a
e
 invlap(1/(2*p-a),p,t);


  (t*a)/2
 e
----------
    2
 invlap(1/(p/2-a),p,t);


   2*t*a
2*e

invlap(e**(-k*p)/(p-a), p, t);


  t*a
 e
------
  a*k
 e
 invlap(b**(-k*p)/(p-a), p, t);


  t*a
 e
------
  a*k
 b

invlap(1/(p-a)**3, p, t);


  t*a  2
 e   *t
---------
    2

invlap(1/(c*p-a)**3, p, t);


  (t*a)/c  2
 e       *t
-------------
       3
    2*c
 invlap(1/(p/c-a)**3, p, t);


  t*a*c  2  3
 e     *t *c
--------------
      2

invlap((c*p-a)**(-1)/(c*p-a)**2, p, t);


  (t*a)/c  2
 e       *t
-------------
       3
    2*c

invlap(c/((p/c-a)**2*(p-a*c)), p, t);


  t*a*c  2  3
 e     *t *c
--------------
      2

invlap(1/(p*(p-a)), p, t);


  t*a
 e    - 1
----------
    a

invlap(c/((p-a)*(p-b)), p, t);


     t*a    t*b
 c*(e    - e   )
-----------------
      a - b

invlap(p/((p-a)*(p-b)), p, t);


  t*a      t*b
 e   *a - e   *b
-----------------
      a - b

off mcd;

 invlap((p+d)/(p*(p-a)), p, t);


 t*a  -1      t*a    -1
e   *a  *d + e    - a  *d

invlap((p+d)/((p-a)*(p-b)), p, t);


       -1   t*a      t*a      t*b      t*b
(a - b)  *(e   *a + e   *d - e   *b - e   *d)

invlap(1/(e**(k*p)*p*(p+1)), p, t);


     - t + k
 - e         + one(t - k)
 on mcd;


off exp;

 invlap(c/(p*(p+a)**2), p, t);


                t*a
  - (a*t + 1 - e   )*c
-----------------------
         t*a  2
        e   *a
 on exp;


invlap(1, p, t);


delta(t)
 invlap(c1*p/c2, p, t);


 df(delta(t),t)*c1
-------------------
        c2

invlap(p/(p-a), p, t);


            t*a
delta(t) + e   *a
 invlap(c*p**2, p, t);


df(delta(t),t,2)*c

invlap(p**2*e**(-a*p)*c, p, t);


sub(t=t - a,df(delta(t),t,2))*c

off mcd;

invlap(e**(-a*p)*(1/p**2-p/(p-1))+c/p, p, t);


                    t - a
t - delta(t - a) - e      - a + c
on mcd;


invlap(a*p**2-2*p+1, p, x);


delta(x) + df(delta(x),x,2)*a - 2*df(delta(x),x)


% P to non-integer power in denominator - i.e. gamma-function case.

invlap(1/sqrt(p), p, t);


        1
------------------
 sqrt(t)*sqrt(pi)
 invlap(1/sqrt(p-a), p, t);


        t*a
       e
------------------
 sqrt(t)*sqrt(pi)

invlap(c/(p*sqrt(p)), p, t);


 2*sqrt(t)*c
-------------
  sqrt(pi)
 invlap(c*sqrt(p)/p**2, p, t);


 2*sqrt(t)*c
-------------
  sqrt(pi)

invlap((p-a)**(-3/2), p, t);


            t*a
 2*sqrt(t)*e
----------------
    sqrt(pi)

invlap(sqrt(p-a)*c/(p-a)**2, p, t);


            t*a
 2*sqrt(t)*e   *c
------------------
     sqrt(pi)

invlap(1/((p-a)*b*sqrt(p-a)), p, t);


            t*a
 2*sqrt(t)*e
----------------
   sqrt(pi)*b

invlap((p/(c1-3)-a)**(-3/2), p, t);


            t*a*c1
 2*sqrt(t)*e      *sqrt(c1 - 3)*(c1 - 3)
-----------------------------------------
                       3*t*a
             sqrt(pi)*e

invlap(1/((p/(c1-3)-a)*b*sqrt(p/(c1-3)-a)), p, t);


            t*a*c1
 2*sqrt(t)*e      *sqrt(c1 - 3)*(c1 - 3)
-----------------------------------------
                      3*t*a
            sqrt(pi)*e     *b

invlap((p*2-a)**(-3/2), p, t);


          (t*a)/2
 sqrt(t)*e
------------------
 sqrt(pi)*sqrt(2)

invlap(sqrt(2*p-a)*c/(p*2-a)**2, p, t);


          (t*a)/2
 sqrt(t)*e       *sqrt(2)*c
----------------------------
         2*sqrt(pi)

invlap(c/p**(7/2), p, t);


            2
 8*sqrt(t)*t *c
----------------
  15*sqrt(pi)
 invlap(p**(-7/3), p, t);


    1/3
   t   *t
------------
        7
 gamma(---)
        3

invlap(gamma(b)/p**b,p,t);


  b
 t
----
 t
 invlap(c*gamma(b)*(p-a)**(-b),p,t);


  b  t*a
 t *e   *c
-----------
     t

invlap(e**(-k*p)/sqrt(p-a), p, t);


            t*a
           e
---------------------------
           a*k
 sqrt(pi)*e   *sqrt(t - k)


% Images that give elementary object functions.
% Use of new switches lmon, lhyp.

invlap(k/(p**2+k**2), p, t);


        2*t*i*k
 i*( - e        + 1)
---------------------
         t*i*k
      2*e

% This is made more readable by :
on ltrig;

 invlap(k/(p**2+k**2), p, t);


sin(t*k)

invlap(p/(p**2+1), p, t);


cos(t)

invlap((p**2-a**2)/(p**2+a**2)**2, p, t);


t*cos(t*a)

invlap(p/(p**2+a**2)**2, p, t);


 t*sin(t*a)
------------
    2*a

invlap((p-a)/((p-a)**2+b**2), p, t);


 t*a
e   *cos(t*b)
 off ltrig;


on lhyp;

 invlap(s/(s**2-k**2), s, t);


cosh(t*k)

invlap(e**(-tau/k*p)*p/(p**2-k**2), p, t);


cosh(t*k - tau)
 off lhyp;


% But it is not always possible to convert expt. functions, e.g.:
on lhyp;

 invlap(k/((p-a)**2-k**2), p, t);


sinh(t*k)*(cosh(t*a) + sinh(t*a))
 off lhyp;


on ltrig;

 invlap(e**(-tau/k*p)*k/(p**2+k**2), p, t);


        2*t*i*k    2*i*tau
 i*( - e        + e       )
----------------------------
         i*(t*k + tau)
      2*e
 off ltrig;


% In such situations use the default switches:
invlap(k/((p-a)**2-k**2), p, t);


  t*a   2*t*k
 e   *(e      - 1)
-------------------
         t*k
      2*e
 % i.e. e**(a*t)*cosh(k*t).
invlap(e**(-tau/k*p)*k/(p**2+k**2), p, t);


        2*t*i*k    2*i*tau
 i*( - e        + e       )
----------------------------
         i*(t*k + tau)
      2*e
 % i.e. sin(k*t-tau).

% More complicated examples.

off exp,mcd;

 invlap((p+d)/(p**2*(p-a)), p, t);


                       t*a           -2
 - ((d*t + 1)*a + d - e   *(a + d))*a

invlap(e**(-tau/k*p)*c/(p*(p-a)**2), p, t);


          -1
      - (k  *tau - t)*a    -1                            -1        -2
 - (e                  *((k  *tau - t)*a + 1) - one(t - k  *tau))*a  *c

invlap(1/((p-a)*(p-b)*(p-c)), p, t);


     t*b               2       -1    t*c                     2 -1
 - (e   *(a*b - a*c - b  + b*c)   - e   *(a*b - a*c - b*c + c )

        t*a   2                   -1
     - e   *(a  - a*b - a*c + b*c)  )

invlap((p**2+g*p+d)/(p*(p-a)**2), p, t);


     t*a   -2           -2      t*a       -1
 - (e   *(a  *d - 1) - a  *d - e   *(a + a  *d + g)*t)
 on exp,mcd;


invlap(k*c**(-b*p)/((p-a)**2+k**2), p, t);


  t*a     2*b*i*k    2*t*i*k
 e   *i*(c        - e       )
------------------------------
       t*i*k  a*b + b*i*k
    2*e     *c

on ltrig;

 invlap(c/(p**2*(p**2+a**2)), p, t);


 c*(t*a - sin(t*a))
--------------------
          3
         a

invlap(1/(p**2-p+1), p, t);


    t/2      sqrt(3)*t
 2*e   *sin(-----------)
                 2
-------------------------
         sqrt(3)
 invlap(1/(p**2-p+1)**2, p, t);


    t/2              sqrt(3)*t                    sqrt(3)*t
 2*e   *( - 3*t*cos(-----------) + 2*sqrt(3)*sin(-----------))
                         2                            2
---------------------------------------------------------------
                               9

invlap(2*a**2/(p*(p**2+4*a**2)), p, t);


  - cos(2*t*a) + 1
-------------------
         2

% This is (sin(a*t))**2 and you can get this by using the let rules :
for all x let sin(2*x)=2*sin x*cos x, cos(2*x)=(cos x)**2-(sin x)**2,
(cos x)**2 =1-(sin x)**2;


invlap(2*a**2/(p*(p**2+4*a**2)), p, t);


        2
sin(t*a)

for all x clear sin(2*x),cos(2*x),cos(x)**2;

  off ltrig;


on lhyp;

invlap((p**2-2*a**2)/(p*(p**2-4*a**2)),p,t);


 cosh(2*t*a) + 1
-----------------
        2

off lhyp;

 % Analogously, the above is (cosh(a*t))**2.

% Floating arithmetic.

invlap(2.55/((0.5*p-2.0)*(p-3.3333)), p, t);


            (33333*t)/10000    4*t
 51000*( - e                + e   )
------------------------------------
                6667

on rounded;


invlap(2.55/((0.5*p-2.0)*(p-3.3333)), p, t);


                           4.0*t                              3.3333*t
7.64961751912*2.71828182846      - 7.64961751912*2.71828182846

invlap(1.5/sqrt(p-0.5), p, t);


                             0.5*t
 0.846284375322*2.71828182846
-----------------------------------
                0.5
               t

invlap(2.75*p**2-0.5*p+e**(-0.9*p)/p, p, t);


2.75*df(delta(t),t,2) - 0.5*df(delta(t),t) + one(t - 0.9)

invlap(1/(2.0*p-3.0)**3, p, t);


                    1.5*t  2
0.0625*2.71828182846     *t
 invlap(1/(2.0*p-3.0)**(3/2), p, t);


                0.5              1.5*t
0.398942280401*t   *2.71828182846

invlap(1/(p**2-5.0*p+6), p, t);


             3.0*t                2.0*t
2.71828182846      - 2.71828182846

off rounded;



% Adding new let rules for the invlap operator. note the syntax:

for all x let invlap(log(gam*x)/x,x) = -log(lp!&);


invlap(-1/2*log(gam*p)/p, p, t);


 log(t)
--------
   2

invlap(-e**(-a*p)*log(gam*p)/(c*p), p, t);


 log(t - a)
------------
     c

for all x clear invlap(1/x*log(gam*x),x);



% Very complicated examples and use of factorizer.

off exp,mcd;

 invlap(c**(-k*p)*(p**2+g*p+d)/(p**2*(p-a)**3), p, t);


   - (log(c)*k - t)*a                   -4
(e                    - 1)*(a*g + 3*d)*a

         - (log(c)*k - t)*a                  2   -1      -2
 + 1/2*e                   *( - t + log(c)*k) *(a  *g + a  *d + 1)

      - (log(c)*k - t)*a                                  -3
 + (e                   *(a*g + 2*d) + d)*(log(c)*k - t)*a

on exp,mcd;


invlap(1/(2*p**3-5*p**2+4*p-1), p, t);


 t        t/2      t
e *t + 2*e    - 2*e

on ltrig,lhyp;

 invlap(1/(p**4-a**4), p, t);


  - sin(t*a) + sinh(t*a)
-------------------------
             3
          2*a

invlap(1/((b-3)*p**4-a**4*(2+b-5)), p, t);


  - sin(t*a) + sinh(t*a)
-------------------------
         3
      2*a *(b - 3)
 off ltrig,lhyp;


% The next three examples are the same:
invlap(c/(p**3/8-9*p**2/4+27/2*p-27)**2,p,t);


    6*t  5
 8*e   *t *c
-------------
     15
invlap(c/(p/2-3)**6,p,t);


    6*t  5
 8*e   *t *c
-------------
     15

off exp;

 a:=(p/2-3)**6;


             6
      (p - 6)
a := ----------
         64
 on exp;

 invlap(c/a, p, t);


    6*t  5
 8*e   *t *c
-------------
     15
 clear a;


% The following two examples are the same :
invlap(c/(p**4+2*p**2+1)**2, p, t);


     2*t*i  3    3      2*t*i  2        2         2*t*i                2*t*i
(c*(e     *t  + t  + 6*e     *t *i - 6*t *i - 15*e     *t - 15*t - 15*e     *i

                   t*i
     + 15*i))/(96*e   )
 invlap(c/((p-i)**4*(p+i)**4),p,t);


     2*t*i  3    3      2*t*i  2        2         2*t*i                2*t*i
(c*(e     *t  + t  + 6*e     *t *i - 6*t *i - 15*e     *t - 15*t - 15*e     *i

                   t*i
     + 15*i))/(96*e   )

% The following three examples are the same :
invlap(e**(-k*p)/(2*p-3)**6, p, t);


  (3*t)/2   5      4         3  2       2  3        4    5
 e       *(t  - 5*t *k + 10*t *k  - 10*t *k  + 5*t*k  - k )
------------------------------------------------------------
                             (3*k)/2
                       7680*e

invlap(e**(-k*p)/(4*p**2-12*p+9)**3, p, t);


  (3*t)/2   5      4         3  2       2  3        4    5
 e       *(t  - 5*t *k + 10*t *k  - 10*t *k  + 5*t*k  - k )
------------------------------------------------------------
                             (3*k)/2
                       7680*e

invlap(e**(-k*p)/(8*p**3-36*p**2+54*p-27)**2, p, t);


  (3*t)/2   5      4         3  2       2  3        4    5
 e       *(t  - 5*t *k + 10*t *k  - 10*t *k  + 5*t*k  - k )
------------------------------------------------------------
                             (3*k)/2
                       7680*e


% Error messages.

invlap(e**(a*p)/p, p, t);


*** Invlap for e**(p*a)/p not known 

         a*p
        e
invlap(------,p,t)
         p

invlap(c*p*sqrt(p), p, t);


*** Invlap for sqrt(p)*p not known 

invlap(sqrt(p)*c*p,p,t)

invlap(sin(p), p, t);


*** Invlap for sin(p) not known 

invlap(sin(p),p,t)

invlap(1/(a*p**3+b*p**2+c*p+d),p,t);


*** Invlap for (p**3*a + p**2*b + p*c + d)**(-1) not known 

                  1
invlap(-----------------------,p,t)
           3      2
        a*p  + b*p  + c*p + d

invlap(1/(p**2-p*sin(p)+a**2),p,t);


*** Invlap for (p**2 - p*sin(p) + a**2)**(-1) not known 

                - 1
invlap(--------------------,p,t)
                    2    2
        sin(p)*p - a  - p

on rounded;

 invlap(1/(p**3-1), p, t);


*** Invlap for (p**3 - 1)**(-1) not known 

          1
invlap(--------,p,t)
         3
        p  - 1
 off rounded;


% Severe errors:
%invlap(1/(p**2+1), p+1, sin(t) );
%invlap(p/(p+1)**2, sin(p), t);

end;


Time for test: 219 ms, plus GC time: 46 ms
@@@@@ Resources used: (1 3 49 8)
mathpiper-0.81f+svn4469+dfsg3/src/packages/laplace/laplace.txt0000644000175000017500000000424011526203062024247 0ustar  giovannigiovanni
           SOFIA LAPLACE AND INVERSE LAPLACE TRANSFORM PACKAGE

                   C. Kazasov, M. Spiridonova, V. Tomov


Reference:  Christomir Kazasov, Laplace Transformations in REDUCE 3, Proc.
            Eurocal '87, Lecture Notes in Comp. Sci., Springer-Verlag
            (1987) 132-133.

Some hints on how to use to use this package:

Syntax:

 LAPLACE(,,)

 INVLAP(,,)

where  is the expression to be transformed,  is the source
variable (in most cases  depends explicitly of this variable) and
 is the target variable. If  is omitted, the package uses
an internal variable lp!& or il!&, respectively.

The following switches can be used to control the transformations:

lmon:   If on, sin, cos, sinh and cosh are converted by LAPLACE into
        exponentials,

lhyp:   If on, expressions e**(~x) are converted by INVLAP into hyperbolic
        functions sinh and cosh,

ltrig:  If on, expressions e**(~x) are converted by INVLAP into
        trigonometric functions sin and cos.

The system can be extended by adding Laplace transformation rules for
single functions by rules or rule sets.  In such a rule the source
variable MUST be free, the target variable MUST be il!& for LAPLACE and
lp!& for INVLAP and the third parameter should be omitted.  Also rules for
transforming derivatives are entered in such a form.

Examples:

    let {laplace(log(~x),x) => -log(gam * il!&)/il!&,
         invlap(log(gam * ~x)/x,x) => -log(lp!&)};

  operator f;
  let{
    laplace(df(f(~x),x),x) => il!&*laplace(f(x),x) - sub(x=0,f(x)),

    laplace(df(f(~x),x,~n),x) => il!&**n*laplace(f(x),x) -
      for i:=n-1 step -1 until 0 sum
        sub(x=0, df(f(x),x,n-1-i)) * il!&**i
          when fixp n,

    laplace(f(~x),x) = f(il!&)
    };

Remarks about some functions:

The DELTA and GAMMA functions are known.

ONE is the name of the unit step function.

INTL is a parametrized integral function

    intl(,,0,)

   which means "Integral of  wrt  taken from 0 to ",
e.g. intl(2*y**2,y,0,x) which is formally a function in x.

We recommend reading the file LAPLACE.TST for a further introduction.
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/0000755000175000017500000000000011722677356022365 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/examples.tst0000644000175000017500000000323211526203062024714 0ustar  giovannigiovanni% examples for trigsimp.tex
linelength 60;

trigsimp(sin(x)^2+cos(x)^2);
trigsimp(sin(x)^2);
trigsimp(sin(x)^2, cos);
trigsimp(sin(2x+y));
trigsimp(sin(x)*cos(y), combine);
trigsimp((1-sin(x)^2)^20*(1-cos(x)^2)^20, compact);
trigsimp(sin(x), hyp);
trigsimp(sinh(x), expon);
trigsimp(e^x, trig);
trigsimp(tan(x+y), keepalltrig);
trigsimp(tan(x+y), tan);
trigsimp(csc x - cot x + csc y - cot y, x/2, y/2, tan);
trigsimp(sin(x)^4, cos, combine);
trigsimp((sinh(x)+cosh(x))^n+(cosh(x)-sinh(x))^n, expon);
trigsimp(ws, hyp);
trigsimp((cosh(a*n)*sinh(a)*sinh(p)+cosh(a)*sinh(a*n)*sinh(p)+
   sinh(a - p)*sinh(a*n))/sinh(a));
trigsimp(ws, combine);
trigsimp( { sin(2x) = cos(2x) } );

trigfactorize(sin(x), x/2);
trigfactorize(1+cos(x), x);
trigfactorize(1+cos(x), x/2);
trigfactorize(sin(2x)*sinh(2x), x);
on nopowers;
trigfactorize(1+cos(x), x/2);
off nopowers;

triggcd(sin(x), 1+cos(x), x/2);
triggcd(sin(x), 1+cos(x), x);
triggcd(sin(2x)*sinh(2x), (1-cos(2x))*(1+cosh(2x)), x);

trigsimp(tan(x)*tan(y));
trigsimp(ws, combine);
trigsimp((sin(x-a)+sin(x+a))/(cos(x-a)+cos(x+a)));
trigsimp(cosh(n*acosh(x))-cos(n*acos(x)), trig);
trigsimp(sec(a-b), keepalltrig);
trigsimp(tan(a+b), keepalltrig);
trigsimp(ws, keepalltrig, combine);
df(sqrt(1+cos(x)), x, 4);
on rationalize;
trigsimp(ws);
off rationalize;
load_package taylor;
taylor(sin(x+a)*cos(x+b), x, 0, 4);
trigsimp(ws, combine);
int(trigsimp(sin(x+y)*cos(x-y)*tan(x)), x);
int(trigsimp(sin(x+y)*cos(x-y)/tan(x)), x);
trigfactorize(sin(2x)*cos(y)^2, y/2);
trigfactorize(sin(y)^4-x^2, y);
trigfactorize(sin(x)*sinh(x), x/2);
triggcd(-5+cos(2x)-6sin(x), -7+cos(2x)-8sin(x), x/2);
triggcd(1-2cosh(x)+cosh(2x), 1+2cosh(x)+cosh(2x), x/2);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsimp.red0000644000175000017500000000640411526203062024700 0ustar  giovannigiovannimodule trigsimp;  % User controlled simplification
                  % of trigonometric expressions.

% Authors: Wolfram Koepf, Andreas Bernig, Herbert Melenk
% Version 1.0 April 1995
% Bugfix Dependent arguments 6.6.96 Harald Boeing

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Revised by Francis J. Wright 

% Version 2.0, 29 June 1998

% My primariy motivation was for use with the ODESolve package.  I
% have not made any changes to the main algorithms, but I have
% re-implemented the code making greater use of symbolic mode, and I
% have made changes to some of the sub-algorithms.  The revised
% version runs the test file (which I have not changed) almost 25%
% faster in my tests, for which I used the CSL development system
% (under Windows 95).  I have also fixed a few minor bugs (one of
% which was visible in the test file).  I hope that the result is a
% little more robust and will be easier to maintain.

% I have changed the definitions of a number of internal procedures,
% and removed others.  Fewer internal procedures now have
% algebraic-mode interfaces.  TrigSimp appears not to be used in any
% other package, but until I am sure that my revisions are correct and
% do not upset any other packages I am preserving the previous version
% in files whose names begin with `o' (for old).

% Version 2.1, 17 January 1999

% Tidied the TrigSimp code.  Fixed bug in handling of trig arguments.
% Added option to specify additional trig arguments, which are treated
% as if they appeared as arguments in the trig expression to be
% simplified.  Added options tan and tanh, to convert output to these
% forms as far as possible; the remaining trig functions will be as
% specified by the other optional arguments.

% Revised trigfactorize to support the new factorizer interface.  It
% now respects the switch nopowers, and uses the power form
% internally, which should be more efficient.


!#if (memq 'psl lispsystem!*)
  flag('(trigsmp1),'lap);
!#endif

create!-package('(trigsimp trigsmp1 trigsmp2), nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsmp1.red0000644000175000017500000002266711526203062024621 0ustar  giovannigiovannimodule trigsmp1$  % Collection of rule sets.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Revised by FJW, 22 June 1998

algebraic$

clearrules(trig_imag_rules)$            % FJW: pre-defined

%% trig_normalize!* :=
%% {
%%   cos(~a)^2  => 1 - sin(a)^2  when trig_preference=sin,
%%   sin(~a)^2  => 1 - cos(a)^2  when trig_preference=cos,
%%   cosh(~a)^2 => 1 + sinh(a)^2 when hyp_preference=sinh,
%%   sinh(~a)^2 => cosh(a)^2 - 1 when hyp_preference=cosh
%% }$

trig_normalize2sin!*  := {cos(~a)^2  => 1 - sin(a)^2}$ % FJW
trig_normalize2cos!*  := {sin(~a)^2  => 1 - cos(a)^2}$ % FJW
trig_normalize2sinh!* := {cosh(~a)^2 => 1 + sinh(a)^2}$ % FJW
trig_normalize2cosh!* := {sinh(~a)^2 => cosh(a)^2 - 1}$ % FJW


trig_expand_addition!* :=               % additions theorems
{
  sin((~a+~b)/~~m)
     => sin(a/m)*cos(b/m) + cos(a/m)*sin(b/m),

  cos((~a+~b)/~~m)
     => cos(a/m)*cos(b/m) - sin(a/m)*sin(b/m),

  tan((~a+~b)/~~m)
     => (tan(a/m)+tan(b/m))/(1-tan(a/m)*tan(b/m)),

  cot((~a+~b)/~~m)
     => (cot(a/m)*cot(b/m)-1)/(cot(a/m)+cot(b/m)),

  sec((~a+~b)/~~m)
     => 1/(1/(sec(a/m)*sec(b/m))-1/(csc(a/m)*csc(b/m))),

  csc((~a+~b)/~~m)
     => 1/(1/(sec(b/m)*csc(a/m))+1/(sec(a/m)*csc(b/m))),

  tanh((~a+~b)/~~m)
     => (tanh(a/m)+tanh(b/m))/(1+tanh(a/m)*tanh(b/m)),

  coth((~a+~b)/~~m)
     => (coth(a/m)*coth(b/m)+1)/(coth(a/m)+coth(b/m)),

  sinh((~a+~b)/~~m)
     => sinh(a/m)*cosh(b/m) + cosh(a/m)*sinh(b/m),

  cosh((~a+~b)/~~m)
     => cosh(a/m)*cosh(b/m) + sinh(a/m)*sinh(b/m),

  sech((~a+~b)/~~m)
     => 1/(1/(sech(a/m)*sech(b/m))+1/(csch(a/m)*csch(b/m))),

  csch((~a+~b)/~~m)
     => 1/(1/(sech(a/m)*csch(b/m))+1/(sech(b/m)*csch(a/m)))
}$


trig_expand_multiplication!* :=         % multiplication theorems
{
  sin(~n*~a/~~m)
     => sin(a/m)*cos((n-1)*a/m) + cos(a/m)*sin((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  sin(~n*~a/~~m)
     => 2*sin(n/2*a/m)*cos(n/2*a/m)
          when fixp n and mod(n,2)=0 and n>15,

  sin(~n*~a/~~m)
     => sin((n-1)/2*a/m)*cos((n+1)/2*a/m) +
        sin((n+1)/2*a/m)*cos((n-1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  cos(~n*~a/~~m)
     => cos(a/m)*cos((n-1)*a/m) - sin(a/m)*sin((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  cos(~n*~a/~~m)
      => 2*cos(n/2*a/m)**2-1
          when fixp n and mod(n,2)=0 and n>15,

  cos(~n*~a/~~m)
     => cos((n-1)/2*a/m)*cos((n+1)/2*a/m) -
        sin((n-1)/2*a/m)*sin((n+1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  sinh(~n*~a/~~m)
     => sinh(a/m)*cosh((n-1)*a/m)+cosh(a/m)*sinh((n-1)*a/m)
          when fixp n and n<=15 and n>1,

  sinh(~n*~a/~~m)
     => 2*sinh(n/2*a/m)*cosh(n/2*a/m)
          when fixp n and mod(n,2)=0 and n>15,

  sinh(~n*~a/~~m)
     => sinh((n-1)/2*a/m)*cosh((n+1)/2*a/m) +
        sinh((n+1)/2*a/m)*cosh((n-1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  cosh(~n*~a/~~m)
     => cosh(a/m)*cosh((n-1)*a/m) + sinh(a/m)*sinh((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  cosh(~n*~a/~~m)
      => 2*cosh(n/2*a/m)**2-1
          when fixp n and mod(n,2)=0 and n>15,

  cosh(~n*~a/~~m)
     => cosh((n-1)/2*a/m)*cosh((n+1)/2*a/m)+
        sinh((n-1)/2*a/m)*sinh((n+1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  tan(~n*~a/~~m)
     => (tan(a/m)+tan((n-1)*a/m))/(1-tan(a/m)*tan((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  tan(~n*~a/~~m)
      => 2*tan(n/2*a/m)/(1-tan(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  tan(~n*~a/~~m)
     => ( tan((n-1)/2*a/m)+tan((n+1)/2*a/m) ) /
        (1-tan((n-1)/2*a/m)*tan((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  tanh(~n*~a/~~m)
     => (tanh(a/m)+tanh((n-1)*a/m))/(1+tanh(a/m)*tanh((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  tanh(~n*~a/~~m)
      => 2*tanh(n/2*a/m)/(1+tanh(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  tanh(~n*~a/~~m)
     => ( tanh((n-1)/2*a/m)+tanh((n+1)/2*a/m) ) /
        (1+tanh((n-1)/2*a/m)*tanh((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  cot(~n*~a/~~m)
     => (cot(a/m)*cot((n-1)*a/m)-1)/(cot(a/m)+cot((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  cot(~n*~a/~~m)
      => (cot(n/2*a/m)**2-1)/(2cot(n/2*a/m))
          when fixp n and mod(n,2)=0 and n>15,

  cot(~n*~a/~~m)
     => ( cot((n-1)/2*a/m)*cot((n+1)/2*a/m)-1 ) /
        (cot((n-1)/2*a/m)+cot((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  coth(~n*~a/~~m)
     => (coth(a/m)*coth((n-1)*a/m)+1)/(coth(a/m)+coth((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  coth(~n*~a/~~m)
      => (coth(n/2*a/m)**2+1)/(2coth(n/2*a/m))
          when fixp n and mod(n,2)=0 and n>15,

  coth(~n*~a/~~m)
     => ( coth((n-1)/2*a/m)*coth((n+1)/2*a/m)+1 ) /
        (coth((n-1)/2*a/m)+coth((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  sec(~n*~a/~~m)
     => 1/(1/(sec(a/m)*sec((n-1)*a/m))-1/(csc(a/m)*csc((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  sec(~n*~a/~~m)
     =>1/(1/sec(n/2*a/m)**2-1/csc(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  sec(~n*~a/~~m)
     => 1/(1/(sec((n-1)/2*a/m)*sec((n+1)/2*a/m))-
        1/(csc((n-1)/2*a/m)*csc((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  csc(~n*~a/~~m)
     => 1/(1/(sec(a/m)*csc((n-1)*a/m))+1/(csc(a/m)*sec((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  csc(~n*~a/~~m)
     => sec(n/2*a/m)*csc(n/2*a/m)/2
          when fixp n and mod(n,2)=0,

  csc(~n*~a/~~m)
     => 1/(1/(sec((n-1)/2*a/m)*csc((n+1)/2*a/m))+
        1/(csc((n-1)/2*a/m)*sec((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  sech(~n*~a/~~m)
     => 1/(1/(sech(a/m)*sech((n-1)*a/m))+1/(csch(a/m)*csch((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  sech(~n*~a/~~m)
     => 1/(1/sech(n/2*a/m)**2+1/csch(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  sech(~n*~a/~~m)
     => 1/(1/(sech((n-1)/2*a/m)*sech((n+1)/2*a/m))+
        1/(csch((n-1)/2*a/m)*csch((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  csch(~n*~a/~~m)
     => 1/(1/(sech(a/m)*csch((n-1)*a/m))+1/(csch(a/m)*sech((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  csch(~n*~a/~~m)
     => sech(n/2*a/m)*csch(n/2*a/m)/2
          when fixp n and mod(n,2)=0 and n>15,

  csch(~n*~a/~~m)
     => 1/(1/(sech((n-1)/2*a/m)*csch((n+1)/2*a/m))+
        1/(csch((n-1)/2*a/m)*sech((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15
}$

trig_combine!* :=
{
  sin(~a)*sin(~b) => 1/2*(cos(a-b) - cos(a+b)),
  cos(~a)*cos(~b) => 1/2*(cos(a-b) + cos(a+b)),
  sin(~a)*cos(~b) => 1/2*(sin(a-b) + sin(a+b)),
  sin(~a)^2       => 1/2*(1-cos(2*a)),
  cos(~a)^2       => 1/2*(1+cos(2*a)),

  sinh(~a)*sinh(~b) => 1/2*(cosh(a+b) - cosh(a-b)),
  cosh(~a)*cosh(~b) => 1/2*(cosh(a-b) + cosh(a+b)),
  sinh(~a)*cosh(~b) => 1/2*(sinh(a-b) + sinh(a+b)),
  sinh(~a)^2        => 1/2*(cosh(2*a)-1),
  cosh(~a)^2        => 1/2*(1+cosh(2*a))
}$

trig_standardize!* :=
{
  tan(~a)  => sin(a)/cos(a),
  cot(~a)  => cos(a)/sin(a),
  tanh(~a) => sinh(a)/cosh(a),
  coth(~a) => cosh(a)/sinh(a),
  sec(~a)  => 1/cos(a),
  csc(~a)  => 1/sin(a),
  sech(~a) => 1/cosh(a),
  csch(~a) => 1/sinh(a)
}$

trig2exp!* :=
{
  cos(~a)  => (e^(i*a) + e^(-i*a))/2,
  sin(~a)  => -i*(e^(i*a) - e^(-i*a))/2,
  cosh(~a) => (e^(a) + e^(-a))/2,
  sinh(~a) => (e^(a) - e^(-a))/2
}$

pow2quot!* := { (~a/~b)^~c => (a^c)/(b^c) }$
exp2trig1!* := { e**(~x) => cos(x/i)+i*sin(x/i) }$
exp2trig2!* := { e**(~x) => 1/(cos(x/i)-i*sin(x/i)) }$

trig2hyp!* :=
{
  sin(~a)  => -i*sinh(i*a),
  cos(~a)  => cosh(i*a),
  tan(~a)  => -i*tanh(i*a),
  cot(~a)  => i*coth(i*a),
  sec(~a)  => sech(i*a),
  csc(~a)  => i*csch(i*a),
  asin(~a) => -i*asinh(i*a),
  acos(~a) => -i*acosh(a)
}$

hyp2trig!* :=
{
  sinh(~a)  => -i*sin(i*a),
  cosh(~a)  => cos(i*a),
  asinh(~a) => i*asin(-i*a),
  acosh(~a) => i*acos(a)
}$

subtan!* :=
{
  sin(~x)  => cos(x)*tan(x)   when trig_preference=cos,
  cos(~x)  => sin(x)/tan(x)   when trig_preference=sin,
  sinh(~x) => cosh(x)*tanh(x) when hyp_preference=cosh,
  cosh(~x) => sinh(x)/tanh(x) when hyp_preference=sinh
}$

endmodule$

end$

% FJW: For debugging using the rtrace package:

trrlid trig_normalize2sin!*, trig_normalize2cos!*,
   trig_normalize2sinh!*, trig_normalize2cosh!*,
   trig_expand_addition!*, trig_expand_multiplication!*,
   trig_combine!*, trig_standardize!*,
   trig2exp!*, exp2trig1!*, exp2trig2!*,
   trig2hyp!*, hyp2trig!*, subtan!*;
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsmp2.red0000644000175000017500000004505411526203062024615 0ustar  giovannigiovannimodule trigsmp2$  % TrigSimp executable code

% small revision by Winfried Neun 3. Nov. 2008
% need to take care of the dependencies (depl*) in case a df is in the form,
% e.g. trigsimp(cos((f1 - f2)/4)**4*df(f1,x,y),sin);

% Revised by Francis J. Wright 
% Revision Time-stamp: 

% (FJW) To do:
%   check with non-integer number domains

% These variables control rules in trigsmp1:
share hyp_preference, trig_preference$

fluid '(!*complex dmode!*)$


%%%%%%%%%%%%
% TrigSimp %
%%%%%%%%%%%%

fluid '(depl!*);

symbolic procedure trigsimp!*(u);
   (trigsimp(reval car u, revlis cdr u) where depl!* = depl!*);

put('trigsimp, 'psopfn, 'trigsimp!*)$

%% FJW: trigsimp is defined to autoload

symbolic procedure trigsimp(f, options);
   %% Map trigsimp1 over possible structures:
   if atom f then f                     % nothing to simplify!
   else if car f eq 'equal then         % equation
      'equal . for each ff in cdr f collect trigsimp(ff, options)
   else if car f eq 'list then          % list
      'list . for each ff in cdr f collect trigsimp(ff, options)
   else if car f eq 'mat then           % matrix
      'mat . for each ff in cdr f collect
         for each fff in ff collect trigsimp(fff, options)
   else trigsimp1(f, options);          % scalar


symbolic procedure trigsimp1(f, options);
   %% The main TrigSimp driver.
   begin scalar dname, trigpreference, hyppreference,
         tanpreference, tanhpreference,
         direction, mode, keepalltrig, onlytan, opt_args;

      onlytan := not or(smember('sin,f), smember('cos,f),
         smember('sinh,f), smember('cosh,f),
         smember('csc,f), smember('sec,f),
         smember('csch,f), smember('sech,f));

      %% Return quickly if simplification not appropriate:
      if onlytan and not or(smember('tan,f), smember('cot,f),
         smember('tanh,f), smember('coth,f),
         smember('exp,f), smember('e,f)) then
         return f;

      if (dname := get(dmode!*, 'dname)) then <<
         %% Force integer domain mode:
         off dname;
         f := prepsq simp!* f
      >>;

      %% Process optional arguments:
      for each u in options do
         if u memq '(sin cos) then
            if trigpreference then
               (u eq trigpreference) or
                  RedErr "Incompatible options: use either sin or cos."
            else trigpreference := u
         else if u memq '(sinh cosh) then
            if hyppreference then
               (u eq hyppreference) or
                  RedErr "Incompatible options: use either sinh or cosh."
            else hyppreference := u
         else if u eq 'tan then tanpreference := t
         else if u eq 'tanh then tanhpreference := t
         else if u memq '(expand combine compact) then
            if direction then
               (u eq direction) or
                  RedErr "Incompatible options: use either expand or combine or compact."
            else direction := u
         else if u memq '(hyp trig expon) then
            if mode then
               (u eq mode) or
                  RedErr "Incompatible options: use either hyp or trig or expon."
            else mode := u
         else if u eq 'keepalltrig then keepalltrig := t
         else if eqcar(u, 'quotient) and not(u member opt_args) then
            %% optional trig arg of the form `x/2'
            opt_args := u . opt_args
         else
            RedErr {"Option", u, "invalid.", " Allowed options are",
               "sin or cos, tan, cosh or sinh, tanh,",
               "expand or combine or compact,",
               "hyp or trig or expon, keepalltrig."};

      %% Set defaults and globals:
      if trigpreference then
         (if tanpreference then         % reverse trig preference
            trigpreference := if trigpreference eq 'sin then 'cos else 'sin)
      else
         trigpreference := 'sin;
      trig_preference := trigpreference;

      if hyppreference then
         (if tanhpreference then        % reverse hyp preference
            hyppreference := if hyppreference eq 'sinh then 'cosh else 'sinh)
      else
         hyppreference := 'sinh;
      hyp_preference := hyppreference;

      direction or (direction := 'expand);

      %% Application:
      %% algebraic let trig_normalize!*;
      if trigpreference eq 'sin
      then algebraic let trig_normalize2sin!*
      else algebraic let trig_normalize2cos!*;
      if hyppreference eq 'sinh
      then algebraic let trig_normalize2sinh!*
      else algebraic let trig_normalize2cosh!*;

      %% f := algebraic f;

      if not keepalltrig or direction memq '(combine compact)
      then f := algebraic(f where trig_standardize!*);

      if mode then f :=
         if mode eq 'trig then
            behandle algebraic(f where hyp2trig!*)
         else if mode eq 'hyp then
            << f := behandle(f);  algebraic(f where trig2hyp!*) >>
         else if mode eq 'expon then
            algebraic(f where trig2exp!*);

      if direction eq 'expand then
         algebraic(begin scalar u;
            %% Handling of dependent variables
            let trig_expand_addition!*;
            %% f := f;
            symbolic(u := subs_symbolic_multiples(reval f, opt_args));
            symbolic(f := car u);       % substituted term
            let trig_expand_multiplication!*;
            f := sub(symbolic cadr u, f); % unsubstitution equations
            clearrules trig_expand_addition!*,
               trig_expand_multiplication!*
         end)
      else if direction eq 'combine then <<
         f := algebraic(f where trig_combine!*);
         if onlytan and keepalltrig then
            f := algebraic(f where subtan!*)
      >>;
      %% algebraic clearrules(trig_normalize!*);
      algebraic clearrules trig_normalize2sin!*, trig_normalize2cos!*,
         trig_normalize2sinh!*, trig_normalize2cosh!*;

      if direction eq 'compact then algebraic <<
         load_package compact;
         %% f := f where trig_expand!*;
         f := (f where trig_expand_addition!*,
            trig_expand_multiplication!*);
         f := compact(f, {sin(x)**2+cos(x)**2=1})
      >>;

      if tanpreference then
         f := if trigpreference eq 'sin then
            algebraic(f where sin ~x => cos x * tan x)
         else
            algebraic(f where cos ~x => sin x / tan x);
      if tanhpreference then
         f := if hyppreference eq 'sinh then
            algebraic(f where sinh ~x => cosh x * tanh x)
         else
            algebraic(f where cosh ~x => sinh x / tanh x);

      if dname then <<
         %% Resimplify using global domain mode:
         on dname;
         f := prepsq simp!* f
      >>;

      return f
   end;


symbolic procedure more_variables(a, b);
   length find_indets(a, nil) > length find_indets(b, nil);

symbolic procedure find_indets(term, vars);
   % Watch out!!!  Expect to see the exponential function as "e" here
   if numberp term then vars            % FJW number (integer)
   else if atom term then               % FJW variable
      (if not memq(term, vars) then term . vars)
   else if cdr term then <<             % FJW examine function arguments only
      term := cdr term;
      vars := find_indets(car term, vars);
      if cdr term then find_indets(cdr term, vars) else vars
   >> else                              % FJW nullary function
      find_indets(car term, vars);


% auxiliary variables

algebraic operator auxiliary_symbolic_var!*$

symbolic procedure subs_symbolic_multiples(term, opt_args);
   %% This procedure replaces trig arguments in `term' that differ
   %% only by a (rational) numerical factor by their lowest common
   %% denominator, e.g. x/3 and x/4 would be replaced by x' = x/12, so
   %% that x/3 -> 4x' and x/4 -> 3x'.
   %% Assumes `term' is a prefix expression.
   %% `opt_args' is an initial list of user-specified trig arguments.
   %% Returns a Lisp list:
   %%   {substituted term, unsubstitution equation list}.
   if term = 0 then '(0 (list)) else
   begin scalar arg_list, unsubs, j;
      opt_args := union(opt_args, nil); % make into set
      arg_list := get_trig_arguments(term, opt_args);
      arg_list := for each arg in arg_list collect simp!* arg;
      j := 0;
      while arg_list do
      begin scalar x, x_nu, x_lcm;
         j := j + 1;
         x := car arg_list;
         x_lcm := denr(x_nu := numberget x); % integer

         %% Find args that differ only by a numerical factor, and find
         %% the lcm of their denominators.  Delete args that have been
         %% processed.
         begin scalar tail;  tail := arg_list;
            while cdr tail do
            begin scalar y, q, y_den;
               y := cadr tail;  q := quotsq(x, y);
               if atom numr q and atom denr q then <<
                  y_den := integer_content denr y;
                  %% Integer arithmetic, division guaranteed:
                  x_lcm := (x_lcm * y_den) / gcdn(x_lcm,y_den);
                  %% Delete the argument:
                  cdr tail :=  cddr tail
               >> else
                  tail := cdr tail
            end
         end;

         arg_list := cdr arg_list;

         if x_lcm neq 1 then <<
            x := !*q2a quotsq(x, x_nu); % primitive part
            depl!* := append(depl!*,
                sublis(list (reval x .
                        list('auxiliary_symbolic_var!*,j)),depl!*));
% in case of a df(x,...) in the term. This would be nullified. WN
            term := algebraic
               sub(x = auxiliary_symbolic_var!*(j)*x_lcm, term);
            unsubs := algebraic(auxiliary_symbolic_var!*(j) = x/x_lcm)
               . unsubs;
         >>
      end;
      return {term, 'list . unsubs}
   end;

symbolic procedure behandle ex;
   begin scalar n, d;
      %% FJW: Force (exp x)^n + (exp(-x))^n to simplify:
      ex := algebraic(ex where pow2quot!*);
      %% (Appears to have been unnecessary before REDUCE 3.7.)
      ex := simp!* ex;
      n := mk!*sq (numr ex ./ 1);
      d := mk!*sq (denr ex ./ 1);
      return algebraic((n where exp2trig1!*)/(d where exp2trig2!*))
   end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% General support routines %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure get_trig_arguments(term, args);
   %% Return a SET of all the arguments of the trig functions in the
   %% expression.  (Note that trig functions are unary!)  The
   %% arguments may themselves be general expressions -- they need not
   %% be kernels!
   if atom term then args else
   begin scalar f, r;
      f := car term;                    % function or operator
      % Winfried Neun, 1 May 2008: you might in very special cases
      % enter with equations which contain *SQs. These equations are
      % not perfectly reval'ed to prefix form. This is special for
      % equations and intentional, I think.  So...
      if (f = '!*sq) then << term := reval term; f := car term >>;
      r := cdr term;                    % arguments or operands
      if f memq '(sin cos sinh cosh) then return
         if not member(r := car r, args) then r . args else args;
      for each j in r do args := get_trig_arguments(j, args);
      return args
   end;

put('numberget, 'simpfn, 'numberget!-simpfn)$
symbolic procedure numberget!-simpfn p;
   %% Return the rational numeric content of a rational expression.
   %% Algebraic-mode interface.
   %% Cannot assume a numeric denominator!
   numberget simp!* car p;

symbolic procedure numberget p;
   %% Return the rational numeric content of a rational expression.
   %% Input and output in standard quotient form.
   %% Assume integer domain mode.
   %% Cannot assume a numeric denominator!
   begin scalar n, d, g;
      n := integer_content numr p;
      d := integer_content denr p;
      g := gcdn(n,d);
      return (n/g) ./ (d/g)
   end;

% FJW: The following numeric content code is modelled on that in
% poly/heugcd by James Davenport & Julian Padget.

symbolic procedure integer_content p;
   %% Extract INTEGER content of (multivariate) polynomial p in
   %% standard form, assuming default (integer) domain mode!
   if atom p then
      p or 0
   else if atom red p then
      if red p then gcdn(integer_content lc p, red p)
      else integer_content lc p
   else integer_content1(red red p,
      gcdn(integer_content lc p, integer_content lc red p));

symbolic procedure integer_content1(p,a);
   if a=1 then 1
   else if atom p then
      if p then gcdn(p,a) else a
   else integer_content1(red p,
      gcdn(remainder(integer_content lc p,a), a));


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% TrigGCD and TrigFactorize %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic operator degree$
symbolic procedure degree(p,x);
   %% cf. deg in poly/polyop
   if numr(p := simp!* p) then
      numrdeg(numr p, x) - numrdeg(denr p, x)
   else 'inf;

symbolic procedure balanced(p,x);
   %% cf. deg in poly/polyop
   <<
      p := simp!* p;
      numrdeg(numr p, x) = 2*numrdeg(denr p, x)
   >>;

symbolic procedure coordinated(p, x);
   %% FJW: Returns t if p contains only even or only odd degree terms
   %% wrt x; returns nil if p contains both even and odd degree terms.
   begin scalar kord!*, evendeg, coord;
      kord!* := {x := !*a2k x};
      p := reorder numr simp!* p;
      if domainp p or not(mvar p eq x) then return t; % degree = 0
      evendeg := remainder(ldeg p, 2) = 0; % leading degree is even
      p := red p;
      coord := t;
      while p and coord do
         if domainp p or not(mvar p eq x) then <<
            coord := evendeg eq t;         % degree = 0
            p := nil
         >> else <<
            coord := evendeg eq (remainder(ldeg p, 2) = 0);
            p := red p
         >>;
      return coord
   end;

flag ('(balanced coordinated), 'boolean)$

algebraic procedure trig2ord(p,x,y);
   if not balanced(p,x) or not balanced(p,y) then
      RedErr "trig2ord error: polynomial not balanced."
   else if not coordinated(p,x) or not coordinated(p,y) then
      RedErr "trig2ord error: polynomial not coordinated."
   else sub(x=sqrt(x), y=sqrt(y), x**degree(p,x)*y**degree(p,y)*p);

algebraic procedure ord2trig(p,x,y);
   x**(-degree(p,x))*y**(-degree(p,y))*sub(x=x**2, y=y**2, p);

algebraic procedure subpoly2trig(p,x);
   begin scalar r, d;
      d := degree(den(p),x);
      r := sub(x=cos(x)+i*sin(x), p*x**d);
      return r*(cos(x)-i*sin(x))**d
   end;

algebraic procedure subpoly2hyp(p,x);
   begin scalar r, d;
      d := degree(den(p),x);
      r := sub(x=cosh(x)+sinh(x), p*x**d);
      return r*(cosh(x)-sinh(x))**d
   end;

algebraic procedure varget(p);
   %% FJW: This procedure returns the variable `x' from an argument
   %% `p' of the form `n*x', where `n' must be numeric and `x' must be
   %% a kernel.
   begin scalar var;
      if not(var := mainvar num p) then RedErr
         "TrigGCD/Factorize error: no variable specified.";
      if not numberp(p/var) then RedErr
         "TrigGCD/Factorize error: last arg must be [number*]variable.";
      return var
   end;

symbolic procedure trigargcheck(p, var, nu);
   %% Check validity of trig arguments.  Note that nu may be rational!
   begin scalar df_arg_var;
      for each arg in get_trig_arguments(p, nil) do algebraic
         if (df_arg_var := df(arg,var)) and
            not fixp(df_arg_var/nu) then
            RedErr "TrigGCD/Factorize error: basis not possible."
   end;

symbolic operator sub2poly$
symbolic procedure sub2poly(p, var, nu, x, y);
   <<
      trigargcheck(p, var, nu);
      p := trigsimp1(p, nil);
      p := algebraic sub(
         sin var = sin(var/nu),
         cos var = cos(var/nu),
         sinh var = sinh(var/nu),
         cosh var = cosh(var/nu), p);
      p := trigsimp1(p, nil);
      algebraic sub(
         sin var = (x-1/x)/(2i),
         cos var = (x+1/x)/2,
         sinh var = (y-1/y)/2,
         cosh var = (y+1/y)/2, p)
   >>;

algebraic procedure triggcd(p, q, x);
   begin scalar not_complex, var, nu, f;
      symbolic if (not_complex := not !*complex) then on complex;
      var := varget x;  nu := numberget x;
      %% xx_x, yy_y should be gensyms?
      p := sub2poly(p, var, nu, xx_x, yy_y);
      q := sub2poly(q, var, nu, xx_x, yy_y);
      if not and(balanced(p,xx_x), balanced(q,xx_x),
         coordinated(p,xx_x), coordinated(q,xx_x),
         balanced(p,yy_y), balanced(q,yy_y),
         coordinated(p,yy_y), coordinated(q,yy_y))
      then f := 1
      else
      begin scalar h, !*nopowers, !*ifactor;
         symbolic(!*nopowers := t);
         p := trig2ord(p, xx_x, yy_y);
         q := trig2ord(q, xx_x, yy_y);
         h := gcd(num p, num q);
         h := ord2trig(h, xx_x, yy_y) / lcm(den p, den q);
         h := subpoly2trig(h, xx_x);
         h := subpoly2hyp(h, yy_y);
         h := sub(xx_x=var*nu, yy_y=var*nu, h);
         h := symbolic trigsimp1(h, nil);
         %% What follows is an expensive way to extract the primitive
         %% part!  Try using `integer_content' defined above or
         %% `comfac' in alg/gcd?
         h := factorize(num h);
         if numberp first h then h := rest h;
         f := for each r in h product r
      end;
      symbolic if not_complex then off complex;
      return f
   end;

algebraic procedure trigfactorize(p, x);
   begin scalar not_complex, var, nu, q, factors;
      symbolic if (not_complex := not !*complex) then on complex;
      var := varget x;  nu := numberget x;
      %% xx_x, yy_y should be gensyms?
      q := sub2poly(p, var, nu, xx_x, yy_y);
      if not(balanced(q,xx_x) and coordinated(q,xx_x) and
         balanced(q,yy_y) and coordinated(q,yy_y))
      then factors := if symbolic !*nopowers then {p} else {{p,1}}
      else
      begin scalar pow, content;
         %% Handle desired factorized form:
         if symbolic(not !*nopowers) then pow := 1;
         q := trig2ord(q, xx_x, yy_y);
         content := 1/den q;
         factors := {};
         for each fac in factorize num q do <<
            if pow then << pow := second fac;  fac := first fac >>;
            fac := ord2trig(fac, xx_x, yy_y);
            fac := subpoly2trig(fac, xx_x);
            fac := subpoly2hyp(fac, yy_y);
            fac := sub(xx_x=var*nu, yy_y=var*nu, fac);
            fac := symbolic trigsimp1(fac, nil);
            if fac freeof var then
               content := content*(if pow > 1 then fac^pow else fac)
            else
            begin scalar !*nopowers;
               for each u in factorize(fac) do
                  if u freeof var then <<
                     u := first u ^ second u;
                     content := content*(if pow > 1 then u^pow else u);
                     fac := fac/u
                  >>;
               factors := (if pow then {fac,pow} else fac) . factors
            end
         >>;
         if content neq 1 then
            factors := (if symbolic !*nopowers then content else {content,1})
               . factors
      end;
      symbolic if not_complex then off complex;
      return factors
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/otrgsimp.red0000644000175000017500000000325111526203062024703 0ustar  giovannigiovannimodule trigsimp; % User controlled simplification
                 % of trigonometric expressions.

% Authors: Wolfram Koepf, Andreas Bernig, Herbert Melenk
% Version 1.0 April 1995
% Bugfix Dependent arguments 6.6.96 Harald Boeing

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


!#if (memq 'psl lispsystem!*)
  flag('(trigsmp1),'lap);
!#endif

create!-package('(trigsimp trigsmp1 trigsmp2),'(contrib misc));

load_package compact;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsimp.tst0000644000175000017500000001073111526203062024736 0ustar  giovannigiovanni% Test file for TrigSimp package

%-------------------------TrigSimp--------------------------

trigsimp(tan(x+y), keepalltrig);
trigsimp(ws, keepalltrig, combine);
trigsimp(sin(5x-9y));
trigsimp(ws, combine);
trigsimp(cos(10x), cos);
trigsimp(cos(10x), sin);
trigsimp((sin(x-a)+sin(x+a))/(cos(x-a)+cos(x+a)));
trigsimp(cos(6x+4y), sin);
trigsimp(ws, expon);
trigsimp(ws, hyp);
trigsimp(ws, combine);
trigsimp(ws, trig, combine);
trigsimp(sqrt(1-cos(2x)));
trigsimp(sin(x)^20*cos(x)^20, sin);
trigsimp(sin(x)^20*cos(x)^20, cos);
trigsimp(sin(x)^20*cos(x)^20, compact);
trigsimp(sin(x)^10, combine);
trigsimp(ws, hyp);
trigsimp(ws, expon);
trigsimp(ws, trig);
int(sin(x+y)*cos(x-y)*tan(x), x);
int(trigsimp(sin(x+y)*cos(x-y)*tan(x)), x);
% int(sin(x+y)*cos(x-y)/tan(x), x) hangs
int(trigsimp(sin(x+y)*cos(x-y)/tan(x)), x);
trigsimp(2tan(x)*(sec(x)^2 - tan(x)^2 - 1));
on rationalize;
df(sqrt(1+cos(x)), x, 4);
off rationalize;
trigsimp(ws);
df(2cos((x+y)/2)*cos((x-y)/2), x);
trigsimp(ws, combine);
df(int(1/cos(x), x), x);
trigsimp(ws, combine);
trigsimp(cos(100x));
trigsimp(ws, combine);
trigsimp(sinh(3a+4b-5c)*cosh(3a-5b-6c));
trigsimp(ws, combine);
trigsimp(sec(20x-y), keepalltrig);
trigsimp(csc(10a-9b), keepalltrig);
trigsimp(ws, combine);
trigsimp(cosh(50*acosh(x))-cos(50*acos(x)));
trigsimp(cos(n*acos(x))-cosh(n*acosh(x)), trig);
trigsimp((2tan(log(x))*(sec(log(x))^2 - tan(log(x))^2 - 1))/x);
trigsimp(sech(10x), keepalltrig);
trigsimp(ws, combine);
trigsimp(csch(3x-5y), keepalltrig);
trigsimp(ws, combine);
off precise;
trigsimp((sinh(x)+cosh(x))^n+(cosh(x)-sinh(x))^n, expon);
on precise;
trigsimp(ws, hyp);
load_package taylor;
taylor(sin(x+a)*cos(x+b), x, 0, 4);
trigsimp(ws, combine);

%-----------------------TrigFactorize-----------------------

on nopowers;  % for comparison with version 2.0
trigfactorize(sin(x)**2, x);
trigfactorize(1+cos(x), x);
trigfactorize(1+cos(x), x/2);
trigfactorize(1+cos(x), x/6);
trigfactorize(sin(x)*(1-cos(x)), x);
trigfactorize(sin(x)*(1-cos(x)), x/2);
trigfactorize(tan(x), x);
trigfactorize(sin(x*3), x);
trigfactorize(sin(4x)-1, x);
trigfactorize(sin(x)**4-1, x);
trigfactorize(cos(x)**4-1, x);
trigfactorize(sin(x)**10-cos(x)**6, x);
trigfactorize(sin(x)*cos(y), x);
trigfactorize(sin(2x)*cos(y)**2, y/2);
trigfactorize(sin(y)**4-x**2, y);
trigfactorize(sin(x), x+1);
trigfactorize(sin(x), 2x);
trigfactorize(sin(x)*cosh(x), x/2);
trigfactorize(1+cos(2x)+2cos(x)*cosh(x), x/2);

%-------------------------TrigGCD---------------------------

triggcd(sin(x), cos(x), x);
triggcd(1-cos(x)^2, sin(x)^2, x);
triggcd(sin(x)^4-1, cos(x)^2, x);
triggcd(sin(5x+1), cos(x), x);
triggcd(1-cos(2x), sin(2x), x);
triggcd(-5+cos(2x)-6sin(x), -7+cos(2x)-8sin(x), x/2);
triggcd(1-2cosh(x)+cosh(2x), 1+2cosh(x)+cosh(2x), x/2);
triggcd(1+cos(2x)+2cos(x)*cosh(x), 1+2cos(x)*cosh(x)+cosh(2x), x/2);
triggcd(-1+2a*b+cos(2x)-2a*sin(x)+2b*sin(x),
   -1-2a*b+cos(2x)-2a*sin(x)-2b*sin(x), x/2);
triggcd(sin(x)^10-1, cos(x), x);
triggcd(sin(5x)+sin(3x), cos(x), x);
triggcd(sin(3x)+sin(5x), sin(5x)+sin(7x), x);

%-----------------------------------------------------------

% New facilities in version 2

%-----------------------------------------------------------

% TrigSimp applied to non-scalars data structures:
trigsimp( sin(2x) = cos(2x) );
trigsimp( { sin(2x), cos(2x) } );
trigsimp( { sin(2x) = cos(2x) } );
trigsimp( mat((sin(2x),cos(2x)),
              (csc(2x),sec(2x))) );

% An amusing identify:
trigsimp(csc x - cot x - tan(x/2));

% which could be DERIVED like this:
trigsimp(csc x - cot x, x/2, tan);

% A silly illustration of multiple additional trig arguments:
trigsimp(csc x - cot x, x/2, x/3);

% A more useful illustration of multiple additional trig arguments:
trigsimp(csc x - cot x + csc y - cot y, x/2, y/2, tan);

%-----------------------------------------------------------

% New TrigFactorize facility:
off nopowers;  % REDUCE 3.7 default, gives more compact output ...
trigfactorize(sin(x)^2, x);
trigfactorize(1+cos(x), x);
trigfactorize(1+cos(x), x/2);
trigfactorize(1+cos(x), x/6);
trigfactorize(sin(x)*(1-cos(x)), x);
trigfactorize(sin(x)*(1-cos(x)), x/2);
trigfactorize(tan(x), x);
trigfactorize(sin(3x), x);
trigfactorize(sin(4x) - 1, x);
trigfactorize(sin(x)^4 - 1, x);
trigfactorize(cos(x)^4 - 1, x);
trigfactorize(sin(x)^10 - cos(x)^6, x);
trigfactorize(sin(x)*cos(y), x);
trigfactorize(sin(2x)*cos(y)^2, y/2);
trigfactorize(sin(y)^4 - x^2, y);
trigfactorize(sin(x), x+1);
trigfactorize(sin(x), 2x);
trigfactorize(sin(x)*cosh(x), x/2);
trigfactorize(1 + cos(2x) + 2cos(x)*cosh(x), x/2);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/otrgsmp2.red0000644000175000017500000003433111526203062024617 0ustar  giovannigiovannimodule trigsmp2;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Executable code.

% remove_element by W. Neun, 06.06.1996
algebraic procedure remove_element(l, n);
        lisp ('list . remove1(cdr reval l, n));

symbolic procedure remove1(x, n);
        if (n = 1) then cdr x else (car x) . remove1(cdr x, n-1);

symbolic procedure indets(term);
% Watch out!!! Expect to see the exponential function as "e" here
begin
   scalar vars;
   vars:= {};
   vars:= find_indets(reval term, reval vars);
   return 'list . vars;
end$

symbolic operator indets$

symbolic procedure find_indets(term, vars);
begin
   if numberp(term) then return vars;
   if idp(term) then begin
      if (not memq(term,vars)) then
         vars:= term . vars;
      end
   else
      if null(cdr(term)) then
         vars:= find_indets(car(term), vars)
      else
         begin
            vars:= find_indets(cadr(term), vars);
            if not null(cddr(term)) then
               vars:= find_indets('list . cddr(term), vars);
         end;
   return vars;
end$

symbolic operator find_indets$


symbolic procedure trig_argumentlist(term);
begin
   scalar vars;
   vars:= {};
   vars:= get_trig_arguments(term, vars);
        return 'list .vars;
end$
symbolic operator trig_argumentlist;

symbolic procedure get_trig_arguments(term, vars);
begin
        scalar f, r;
   if (arglength(term)= -1) then return vars;
        f:= car(term);
        r:= cdr(term);
   if (f = 'sin) or (f = 'cos) or (f = 'sinh) or (f = 'cosh) then
      return << r:= car r;
                                         if not (r member vars) then
                vars:= r . vars; vars>>;
          f:= r;
   for each j in f do vars:= get_trig_arguments(j, vars);
   return vars;
end$
symbolic operator get_trig_arguments;


symbolic procedure more_variables(a, b);
   if (length(indets(a)) > length(indets(b))) then t else nil;
symbolic operator more_variables;

% auxiliary variables

algebraic;

operator auxiliary_symbolic_var!*;


procedure subs_symbolic_multiples(arg_term);
begin
   scalar term, var_list, tmp_list, j, x, y, x_nu, x_lcm, y_den, unsubs;
   term:= arg_term;
        if (term = 0) then return {0, {}};
        var_list:= trig_argumentlist(term);
   var_list:= sort(var_list, 'more_variables);
   unsubs:= {};
        j:= 0;
   while (var_list neq {}) do begin
                j:= j + 1;
      x:= first(var_list);
      var_list:= rest(var_list);
      x_nu:= numberget(x);
      x_lcm:= den(x_nu);
                tmp_list:= var_list;
      for k:=1:length(var_list) do begin
         y:= part(var_list, k);
         if numberp(x/y) then begin
            tmp_list:= remove_element(var_list, k);
            y_den:= den(numberget(y));
            x_lcm:= (x_lcm * y_den) / gcd(x_lcm,y_den);
         end; % of if
      end;
                var_list:= tmp_list;
                if (x_lcm neq 1) then begin
                        x:= x / x_nu;
                        unsubs:= append(unsubs,
                                 {auxiliary_symbolic_var!*(j)=x/x_lcm});
                        term:= (term where
                                (x=>auxiliary_symbolic_var!*(j)*x_lcm));
                end; % of if
   end;
   return({term, unsubs});
end;


procedure behandle(ex);
  begin scalar p,q,p2,q2;
    p := num ex;
    q := den ex;
    let exp2trig1!*;
    p2 := p;
    clearrules exp2trig1!*;
    let exp2trig2!*;
    q2 := q;
    clearrules exp2trig2!*;
    return p2/q2;
  end;

procedure trigsimp1(f,l);
  begin
    scalar u,p,trigpreferencelist,hyppreferencelist,
    directionlist,modelist,keepalltriglist,err,onlytan;

    err:=0;
    if freeof(f,sin) and freeof(f,cos) and freeof(f,cosh) and
    freeof(f,sinh) and freeof(f,csc) and
    freeof(f,sec) and freeof(f,csch) and freeof(f,sech) then
       onlytan:=1 else onlytan:=0;
    trigpreferencelist:={};
    hyppreferencelist:={};
    directionlist:={};
    modelist:={};
    keepalltriglist:={};
    while length(l) neq 0 do begin
      u:=first(l);
      l:=rest(l);
      if u=sin or u=cos then trigpreferencelist:=u.trigpreferencelist
      else if (u=sinh) or (u=cosh) then hyppreferencelist:=
         u.hyppreferencelist
      else if (u=expand) or (u=combine) or (u=compact) then
         directionlist:=u.directionlist
      else if u=hyp or u=trig or u=expon then modelist:=u.modelist
      else if (u=keepalltrig) then keepalltriglist:=u.keepalltriglist
      else <>;
    end;

%Defaults
    if trigpreferencelist={} then trigpreferencelist:={sin};
    if hyppreferencelist={} then hyppreferencelist:={sinh};
    if directionlist={} then directionlist:={expand};

%contradictions?
    if length(trigpreferencelist)>1 then <>;
    if length(hyppreferencelist)>1 then <>;
    if length(directionlist)>1 then <>;
    if length(modelist)>1 then <>;

    if err=0 then begin
%application

      if first(trigpreferencelist)=sin then trig_preference:=sin;
      if first(trigpreferencelist)=cos then trig_preference:=cos;
      if first(hyppreferencelist)=sinh then hyp_preference:=sinh;
      if first(hyppreferencelist)=cosh then hyp_preference:=cosh;

      let trig_normalize!*;
      p:=f;

      if keepalltriglist={} or directionlist={combine} or
         directionlist={compact}
      then <>;

      if modelist neq {} then begin
        if first(modelist)=trig then <>;
        if first(modelist)=hyp then
        <>;
        if first(modelist)=expon then
          <>;
      end;

      if first(directionlist)=expand then <<
                        % Handling of dependent variables
                        let trig_expand_addition!*;
                        p:= p;
                        u:= subs_symbolic_multiples(p);
                        let trig_expand_multiplication!*;
                        p:= part(u, 1);
                        p:= sub(part(u,2), p);
                        clearrules(trig_expand_addition!*);
                        clearrules(trig_expand_multiplication!*);
                >>;
      if first(directionlist)=combine then
      <>;>>;
      clearrules(trig_normalize!*);
      if first(directionlist)=compact then begin
      % load compact;  % Loaded at beginning.
        let trig_expand!*;p:=p+0;clearrules(trig_expand!*);
        p:=compact(f,{sin(x)**2+cos(x)**2=1});
      end;
    end;
    return p;
  end;

procedure degree(p,x);
  begin
  scalar h;
  if p=0 then h:=inf else h:=deg(num(p),x)-deg(den(p),x);
  return h;
  end;

procedure balanced(p,x);
  if deg(num(p),x)=2*deg(den(p),x) then 1 else 0;

procedure coordinated(p,x);
  begin
    scalar k,pneu,e,o,j;
    k:={};
    e:=0;
    o:=0;
    pneu:=num(p);
    for j:=0:deg(pneu,x) do
      <>;
    for j:=1:length(k) do
      <>;
     if o=e then return 0 else return 1;
  end;

procedure trig2ord(p,x,y);
  begin
    if balanced(p,x) neq 1 or balanced(p,y) neq 1 then write
    "error using trig2ord:
      polynomial not balanced.";
    if coordinated(p,x) neq 1 or coordinated(p,y) neq 1 then write
    "error using trig2ord:
      polynomial not coordinated";
    return sub(x=sqrt(x),y=sqrt(y),x**degree(p,x)*y**degree(p,y)*p);
  end;

procedure ord2trig(p,x,y);
  x**(-degree(p,x))*y**(-degree(p,y))*sub(x=x**2,y=y**2,p);

procedure factor_trig_poly(p,x,y);
  begin
    scalar j,p1,flist1,flist,d;
    p1:=trig2ord(p,x,y);
    d:=den(p1);
    flist1:= old_factorize(num(p1));
    flist:={};
    for j:=1:length(flist1) do
        flist:=ord2trig(part(flist1,j),x,y).flist;
    if d neq 1 then flist:=(1/d).flist;
    return flist;
  end;

procedure subpoly2trig(p,x);
  begin
    scalar r,d;
    d:=degree(den(p),x);
    r:=p*x**d;
    r:=sub(x=cos(x)+i*sin(x),r);
    r:=r*(cos(x)-i*sin(x))**d;
    return r;
  end;

procedure subpoly2hyp(p,x);
  begin
    scalar r,d;
    d:=degree(den(p),x);
    r:=p*x**d;
    r:=sub(x=cosh(x)+sinh(x),r);
    r:=r*(cosh(x)-sinh(x))**d;
    return r;
  end;

procedure varget(p);
  begin
    scalar q,l,h;
    q:= old_factorize(p);
    h:=0;
    for each l in q do
      <>;
    if h=0 then h:=1;
    return h;
  end;

procedure numberget(p);
  begin
    scalar q,d,l,h;
    q:= old_factorize(p);
    d:=1;
    h:=0;
    for each l in q do if numberp(l) then d:=d*l;
    return d;
  end;

procedure triggcd(p,q,x);
  begin
    scalar p1,q1,g1,g,u,d,nu,h,complex!*,err,l;
    on complex;
    nu:=numberget(x);
    err:=0;
    if varget(x)=1 then err:=1 else begin
      l:=trig_argumentlist(p);
      for d:=1:length(l) do if not(fixp(df(part(l,d),varget(x))/nu))
      and not(freeof(part(l,d),varget(x))) then err:=1;
      l:=trig_argumentlist(q);
      for d:=1:length(l) do if not(fixp(df(part(l,d),varget(x))/nu))
      and not(freeof(part(l,d),varget(x))) then err:=1;
    end;
    if err=0 then begin
      p1:=trigsimp1(p,{});
      p1:=sub(sin(varget(x))=sin(varget(x)/nu),
      cos(varget(x))=cos(varget(x)/nu),sinh(varget(x))
                    =sinh(varget(x)/nu),
      cosh(varget(x))=cosh(varget(x)/nu),p1);
      p1:=trigsimp1(p1,{});
      q1:=trigsimp1(q,{});
      q1:=sub(sin(varget(x))=sin(varget(x)/nu),
      cos(varget(x))=cos(varget(x)/nu),sinh(varget(x))
                    =sinh(varget(x)/nu),
      cosh(varget(x))=cosh(varget(x)/nu),q1);
      q1:=trigsimp1(q1,{});
      p1:=sub(sin(varget(x))=(xx_x-1/xx_x)/(2i),
      cos(varget(x)) =>xx_x/2+1/(2xx_x),
      sinh(varget(x))=(yy_y-1/yy_y)/2,
      cosh(varget(x))=yy_y/2+1/(2yy_y),p1);
      q1:=sub(sin(varget(x))=(xx_x-1/xx_x)/(2i),
      cos(varget(x)) =>xx_x/2+1/(2xx_x),
      sinh(varget(x))=(yy_y-1/yy_y)/2,
      cosh(varget(x))=yy_y/2+1/(2yy_y),q1);
      if balanced(p1,xx_x)+balanced(q1,xx_x)+coordinated(p1,xx_x)+
      coordinated(q2,xx_x)+balanced(p1,yy_y)+balanced(q1,yy_y)+
      coordinated(p1,yy_y)+coordinated(q2,yy_y) neq 8
      then d:=1
      else begin
        p1:=trig2ord(p1,xx_x,yy_y);
        q1:=trig2ord(q1,xx_x,yy_y);
        g1:=gcd(num(p1),num(q1));
        g:=ord2trig(g1,xx_x,yy_y)/lcm(den(p1),den(p2));
        h:=subpoly2trig(g,xx_x);
        h:=subpoly2hyp(h,yy_y);
        h:=sub(xx_x=varget(x)*nu,yy_y=varget(x)*nu,h);
        h:=trigsimp1(h,{});
        h:= old_factorize(num(h));
        d:=1;
        for each r in h do if not(numberp(r)) then d:=d*r;
      end;
    end else d:="error using triggcd, basis not possible.";
    return d;
  end;

procedure trigfactorize(p,x);
  begin
    scalar l,q,f,r,d,h,s,u,err,complex!*;
    on complex;
    nu:=numberget(x);
    err:=0;
    if varget(x)=1 then err:=1 else begin
      l:=trig_argumentlist(p);
      for d:=1:length(l) do if not(fixp(df(part(l,d),varget(x))/nu))
      and not(freeof(part(l,d),varget(x))) then err:=1;
    end;
    if err=1
      then rederr("error using trigfactorize, basis not possible")
    else begin
      q:=trigsimp1(p,{});
      q:=sub(sin(varget(x))=sin(varget(x)/nu),
      cos(varget(x))=cos(varget(x)/nu),sinh(varget(x))
                    =sinh(varget(x)/nu),
      cosh(varget(x))=cosh(varget(x)/nu),q);
      q:=trigsimp1(q,{});
      q:=sub(sin(varget(x))=(xx_x-1/xx_x)/(2i),
      cos(varget(x)) =xx_x/2+1/(2xx_x),
      sinh(varget(x))=(yy_y-1/yy_y)/2,cosh(varget(x))
                     =yy_y/2+1/(2yy_y),q);
      if balanced(q,xx_x)+coordinated(q,xx_x)+
      balanced(q,yy_y)+coordinated(q,yy_y)<4 then f:={p}
      else begin
        q:=factor_trig_poly(q,xx_x,yy_y);
        f:={};
        d:=1;
        for each r in q do
        <>;
          f:=reverse(h.reverse(f));
          end;
        >>;
        if d neq 1 then f:=d.f;
      end;
    end;
    return f;
  end;

symbolic procedure trigsimp!*(f);
begin scalar fff;
  fff :=  reval car f;
  return
  if eqcar (fff,'list) then
    'list . for each ff in cdr fff collect
       trigsimp1(ff,'list.for each w in cdr f collect reval w)
  else
  trigsimp1(reval car f,'list.for each w in cdr f collect reval w);
 end;

symbolic put('trigsimp,'psopfn, 'trigsimp!*);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/otrgsimp.tex0000644000175000017500000002366311526203062024742 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt TRIGSIMP}\\
A REDUCE Package for the Simplification and Factorization of Trigonometric
and Hyperbolic Functions}
\date{}
\author{Wolfram Koepf\\
        Andreas Bernig\\
        Herbert Melenk\\
        ZIB Berlin \\
        email: {\tt  Koepf@ZIB-Berlin.de}}
\begin{document}
\maketitle
\section{Introduction}

The REDUCE package TRIGSIMP is a useful tool for all kinds of trigonometric and
hyperbolic simplification and factorization. There are three
procedures included in TRIGSIMP: trigsimp, trigfactorize and triggcd. 
The first is for finding simplifications of trigonometric or 
hyperbolic expressions with many options, the second for factorizing 
them and the third 
for finding the greatest common divisor of two trigonometric or 
hyperbolic polynomials.

To start the package it must be loaded by:
{\small
\begin{verbatim}
1: load trigsimp;
\end{verbatim}
}\noindent

\section{\REDUCE{} operator {\tt trigsimp}}

As there is no normal form for trigonometric and hyperbolic functions, the same 
function can convert in many different directions, e.g. 
$\sin(2x) \leftrightarrow 2\sin(x)\cos(x)$. 
The user has the possibility to give several parameters to the 
procedure {\tt trigsimp} in order to influence the direction of transformations. 
The decision whether a rational expression in trigonometric 
and hyperbolic functions vanishes or not is possible.

To simplify a function {\tt f}, one uses {\tt trigsimp(f[,options])}. Example:
{\small
\begin{verbatim}
2: trigsimp(sin(x)^2+cos(x)^2);

1
\end{verbatim}
}\noindent

Possible options are (* denotes the default):
\begin{enumerate}
\item {\tt sin} (*) or {\tt cos}
\item {\tt sinh} (*) or {\tt cosh}
\item {\tt expand} (*) or {\tt combine} or {\tt compact}
\item {\tt hyp} or {\tt trig} or {\tt expon}
\item {\tt keepalltrig}
\end{enumerate}

From each group one can use at most one option, otherwise an error 
message will occur. The first group fixes the preference used while 
transforming a trigonometric expression:
{\small
\begin{verbatim}
3: trigsimp(sin(x)^2);

      2
sin(x)

4: trigsimp(sin(x)^2,cos);

         2
 - cos(x)  + 1
\end{verbatim}
}\noindent

The second group is the equivalent for the hyperbolic functions. 
The third group determines the type of transformations. With 
the default {\tt expand}, an expression is written in a form only using 
single arguments and no sums of arguments:
{\small
\begin{verbatim}
5: trigsimp(sin(2x+y));

                                 2
2*cos(x)*cos(y)*sin(x) - 2*sin(x) *sin(y) + sin(y)
\end{verbatim}
}\noindent

With {\tt combine}, products of trigonometric functions are transformed to 
trigonometric functions involving sums of arguments:
{\small
\begin{verbatim}
6: trigsimp(sin(x)*cos(y),combine);

        
 sin(x - y) + sin(x + y)
-------------------------
            2
\end{verbatim}
}\noindent

With {\tt compact}, the REDUCE operator {\tt compact} \cite{hearns}
is applied to {\tt f}. 
This leads often to a simple form, but in contrast to {\tt expand} one 
doesn't get a normal form. Example for {\tt compact}:
{\small
\begin{verbatim}
7: trigsimp((1-sin(x)**2)**20*(1-cos(x)**2)**20,compact);

      40       40
cos(x)  *sin(x)
\end{verbatim}
}\noindent

With the fourth group each expression is transformed to a
trigonometric, hyperbolic or exponential form:
{\small
\begin{verbatim}
8: trigsimp(sin(x),hyp);

 - sinh(i*x)*i

9: trigsimp(sinh(x),expon);
        
  2*x
 e    - 1
----------
      x
   2*e

10: trigsimp(e^x,trig);

     x          x
cos(---) + sin(---)*i
     i          i
\end{verbatim}
}\noindent 

Usually, {\tt tan}, {\tt cot}, {\tt sec}, {\tt csc} are expressed in terms of
{\tt sin} and {\tt cos}. It can 
be sometimes useful to avoid this, which is handled by the option 
{\tt keepalltrig}:
{\small
\begin{verbatim}
11: trigsimp(tan(x+y),keepalltrig);

  - (tan(x) + tan(y))
----------------------
  tan(x)*tan(y) - 1
\end{verbatim}
}\noindent

It is possible to use the options of different groups simultaneously:
{\small
\begin{verbatim}
12: trigsimp(sin(x)**4,cos,combine);

 cos(4*x) - 4*cos(2*x) + 3
---------------------------
             8
\end{verbatim}
}\noindent

Sometimes, it is necessary to handle an expression in different steps:
{\small
\begin{verbatim}
13: trigsimp((sinh(x)+cosh(x))**n+(cosh(x)-sinh(x))**n,expon);

  2*n*x
 e      + 1
------------
     n*x
    e 
 
14: trigsimp(ws,hyp);

2*cosh(n*x)

15: trigsimp((cosh(a*n)*sinh(a)*sinh(p)+cosh(a)*sinh(a*n)*sinh(p)+ 
    sinh(a - p)*sinh(a*n))/sinh(a));

cosh(a*n)*sinh(p) + cosh(p)*sinh(a*n)

16: trigsimp(ws,combine);

sinh(a*n + p)
\end{verbatim}
}\noindent

\section{\REDUCE{} operator {\tt trigfactorize}}

With {\tt trigfactorize(p,x)} one can factorize the trigonometric or 
hyperbolic polynomial {\tt p} with respect to the argument x. Example:
{\small
\begin{verbatim}
17: trigfactorize(sin(x),x/2); 

        x        x
{2,cos(---),sin(---)}
        2        2
\end{verbatim}
}\noindent

If the polynomial is not coordinated or balanced \cite{art}, 
the output will equal the input.
In this case, changing the value for x can help to find a factorization:
{\small
\begin{verbatim}
18: trigfactorize(1+cos(x),x);

{cos(x) + 1}

19: trigfactorize(1+cos(x),x/2); 

        x        x
{2,cos(---),cos(---)}
        2        2
\end{verbatim}
}\noindent

The polynomial can consist of both trigonometric and hyperbolic functions:
{\small
\begin{verbatim}
20: trigfactorize(sin(2x)*sinh(2x),x);

{4, cos(x), sin(x), cosh(x), sinh(x)}
\end{verbatim}
}\noindent

\section{\REDUCE{} operator {\tt triggcd}}

The operator {\tt triggcd} is an application of {\tt trigfactorize}. 
With its help the user can find the greatest common divisor of two 
trigonometric or hyperbolic polynomials. It uses the method described 
in \cite{art}. The syntax is: {\tt triggcd(p,q,x)}, where p and q 
are the polynomials and x is the smallest unit to use. Example:

{\small
\begin{verbatim}
21: triggcd(sin(x),1+cos(x),x/2);

     x
cos(---)
     2 

22: triggcd(sin(x),1+cos(x),x);

1
\end{verbatim}
}\noindent

The polynomials p and q can consist of both trigonometric and hyperbolic 
functions:
{\small
\begin{verbatim}
23: triggcd(sin(2x)*sinh(2x),(1-cos(2x))*(1+cosh(2x)),x);

cosh(x)*sin(x)
\end{verbatim}
}\noindent


\section{Further Examples}

With the help of the package the user can create identities:
{\small
\begin{verbatim}
24: trigsimp(tan(x)*tan(y));

 sin(x)*sin(y)
---------------
 cos(x)*cos(y)

25: trigsimp(ws,combine);

 cos(x - y) - cos(x + y)
-------------------------
 cos(x - y) + cos(x + y)

26: trigsimp((sin(x-a)+sin(x+a))/(cos(x-a)+cos(x+a)));

 sin(x)
--------
 cos(x)

27: trigsimp(cosh(n*acosh(x))-cos(n*acos(x)),trig);

0

28: trigsimp(sec(a-b),keepalltrig);

  csc(a)*csc(b)*sec(a)*sec(b)
-------------------------------
 csc(a)*csc(b) + sec(a)*sec(b)

29: trigsimp(tan(a+b),keepalltrig);

  - (tan(a) + tan(b))
----------------------
  tan(a)*tan(b) - 1

30: trigsimp(ws,keepalltrig,combine);

tan(a + b)
\end{verbatim}
}\noindent

Some difficult expressions can be simplified:
{\small
\begin{verbatim}

31: df(sqrt(1+cos(x)),x,4);

                              4            2       2            2
(sqrt(cos(x) + 1)*( - 4*cos(x)  - 20*cos(x) *sin(x)  + 12*cos(x)

                      2                       4            2
     - 4*cos(x)*sin(x)  + 8*cos(x) - 15*sin(x)  + 16*sin(x) ))/(16

           4           3           2
   *(cos(x)  + 4*cos(x)  + 6*cos(x)  + 4*cos(x) + 1))

32: trigsimp(ws);

 sqrt(cos(x) + 1)
------------------
        16

33: load taylor; 

34: taylor(sin(x+a)*cos(x+b),x,0,4);

cos(b)*sin(a) + (cos(a)*cos(b) - sin(a)*sin(b))*x

                                    2
 - (cos(a)*sin(b) + cos(b)*sin(a))*x

    2*( - cos(a)*cos(b) + sin(a)*sin(b))   3
 + --------------------------------------*x
                     3

    cos(a)*sin(b) + cos(b)*sin(a)   4      5
 + -------------------------------*x  + O(x )
                  3

35: trigsimp(ws,combine);

sin(a - b) + sin(a + b)                                2    2*cos(a + b)   3
------------------------- + cos(a + b)*x - sin(a + b)*x  - --------------*x
            2                                                    3

    sin(a + b)   4      5
 + ------------*x  + O(x )
        3
\end{verbatim}
}\noindent
Certain integrals whose calculation was not possible in REDUCE 
(without preprocessing), are now computable:
{\small
\begin{verbatim}
36: int(trigsimp(sin(x+y)*cos(x-y)*tan(x)),x);

       2                                                         2
 cos(x) *x - cos(x)*sin(x) - 2*cos(y)*log(cos(x))*sin(y) + sin(x) *x
---------------------------------------------------------------------
                                  2

37: int(trigsimp(sin(x+y)*cos(x-y)/tan(x)),x);

                                   x  2
(cos(x)*sin(x) - 2*cos(y)*log(tan(---)  + 1)*sin(y)
                                   2

                      x
  + 2*cos(y)*log(tan(---))*sin(y) + x)/2
                      2
\end{verbatim}
}\noindent

Without the package, the integration fails, in the second case one doesn't 
receive an answer for many hours.
{\small
\begin{verbatim}

38: trigfactorize(sin(2x)*cos(y)**2,y/2);

{2*cos(x)*sin(x),

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) - sin(---),
      2          2

      y          y
 cos(---) - sin(---)}
      2          2

39: trigfactorize(sin(y)**4-x**2,y);

          2               2
{ - sin(y)  + x, - (sin(y)  + x)}

40: trigfactorize(sin(x)*sinh(x),x/2);

        x        x         x         x
{4,cos(---),sin(---),cosh(---),sinh(---)}
        2        2         2         2

41: triggcd(-5+cos(2x)-6sin(x),-7+cos(2x)-8sin(x),x/2);

       x        x
2*cos(---)*sin(---) + 1
       2        2

42: triggcd(1-2cosh(x)+cosh(2x),1+2cosh(x)+cosh(2x),x/2);

        x  2
2*sinh(---)  + 1
        2
\end{verbatim}
}

\begin{thebibliography}{99}

\bibitem{art}
Roach, Kelly: Difficulties with Trigonometrics. Notes of a talk.

\bibitem{hearns}
Hearn, A.C.: COMPACT User Manual. 
\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsimp.tex0000644000175000017500000002727211526203062024734 0ustar  giovannigiovanni\documentclass[11pt]{article}

\usepackage{reduce}

\title{\texttt{TRIGSIMP} \\
A \REDUCE{} Package for the Simplification and Factorization of
Trigonometric and Hyperbolic Expressions}

\author{Wolfram Koepf \\
	Andreas Bernig \\
	Herbert Melenk \\
	ZIB Berlin \\
	~ \\
	Revised by Francis Wright \\
	QMW London \\
	E-mail: \texttt{F.J.Wright@Maths.QMW.ac.uk}}

\date{17 January 1999}

\begin{document}
\maketitle

\section{Introduction}

The \REDUCE{} package TRIGSIMP is a useful tool for all kinds of
problems related to trigonometric and hyperbolic simplification and
factorization.  There are three operators included in TRIGSIMP:
trigsimp, trigfactorize and triggcd.  The first is for simplifying
trigonometric or hyperbolic expressions and has many options, the
second is for factorizing them and the third is for finding the
greatest common divisor of two trigonometric or hyperbolic
polynomials.  This package is automatically loaded when one of these
operators is used.


\section{Simplifying trigonometric expressions}

As there is no normal form for trigonometric and hyperbolic
expressions, the same function can convert in many different
directions, e.g.\ $\sin(2x) \leftrightarrow 2\sin(x)\cos(x)$.  The
user has the possibility to give several parameters to the operator
\texttt{trigsimp} in order to influence the transformations.  It is
possible to decide whether or not a rational expression involving
trigonometric and hyperbolic functions vanishes.

To simplify an expression \texttt{f}, one uses
\texttt{trigsimp(f[,options])}.  For example:
\begin{verbatim}
trigsimp(sin(x)^2+cos(x)^2);

1
\end{verbatim}
The possible options (where $^*$ denotes the default) are:
\begin{enumerate}
\item \texttt{sin}$^*$ or \texttt{cos};
\item \texttt{sinh}$^*$ or \texttt{cosh};
\item \texttt{expand}$^*$, \texttt{combine} or \texttt{compact};
\item \texttt{hyp}, \texttt{trig} or \texttt{expon};
\item \texttt{keepalltrig};
\item \texttt{tan} and/or \texttt{tanh};
\item target arguments of the form \textit{variable} /
\textit{positive integer}.
\end{enumerate}
From each of the first four groups one can use at most one option,
otherwise an error message will occur.  Options can be given in any
order.

The first group fixes the preference used while transforming a
trigonometric expression:
\begin{verbatim}
trigsimp(sin(x)^2);

      2
sin(x)

trigsimp(sin(x)^2, cos);

         2
 - cos(x)  + 1
\end{verbatim}
The second group is the equivalent for the hyperbolic functions.

The third group determines the type of transformation.  With the
default, \texttt{expand}, an expression is transformed to use only
simple variables as arguments:
\begin{verbatim}
trigsimp(sin(2x+y));

                                 2
2*cos(x)*cos(y)*sin(x) - 2*sin(x) *sin(y) + sin(y)
\end{verbatim}
With \texttt{combine}, products of trigonometric functions are
transformed to trig\-onometric functions involving sums of variables:
\begin{verbatim}
trigsimp(sin(x)*cos(y), combine);

 sin(x - y) + sin(x + y)
-------------------------
            2
\end{verbatim}
With \texttt{compact}, the \REDUCE{} operator \texttt{compact}
\cite{hearns} is applied to \texttt{f}.  This often leads to a simple
form, but in contrast to \texttt{expand} one does not get a normal
form. For example:
\begin{verbatim}
trigsimp((1-sin(x)^2)^20*(1-cos(x)^2)^20, compact);

      40       40
cos(x)  *sin(x)
\end{verbatim}

With an option from the fourth group, the input expression is
transformed to trigonometric, hyperbolic or exponential form
respectively:
\begin{verbatim}
trigsimp(sin(x), hyp);

 - sinh(i*x)*i

trigsimp(sinh(x), expon);

  2*x
 e    - 1
----------
      x
   2*e

trigsimp(e^x, trig);

cos(i*x) - sin(i*x)*i
\end{verbatim}

Usually, \texttt{tan}, \texttt{cot}, \texttt{sec}, \texttt{csc} are
expressed in terms of \texttt{sin} and \texttt{cos}.  It can sometimes
be useful to avoid this, which is handled by the option
\texttt{keepalltrig}:
\begin{verbatim}
trigsimp(tan(x+y), keepalltrig);

  - (tan(x) + tan(y))
----------------------
  tan(x)*tan(y) - 1
\end{verbatim}
Alternatively, the options \texttt{tan} and/or \texttt{tanh} can be
given to convert the output to the specified form as far as possible:
\begin{verbatim}
trigsimp(tan(x+y), tan);

  - (tan(x) + tan(y))
----------------------
  tan(x)*tan(y) - 1
\end{verbatim}
By default, the other functions used will be \texttt{cos} and/or
\texttt{cosh}, unless the other desired functions are also specified
in which case this choice will be respected.

The final possibility is to specify additional target arguments for
the trigonometric or hyperbolic functions, each of which should have
the form of a variable divided by a positive integer.  These
additional arguments are treated as if they had occurred within the
expression to be simplified, and their denominators are used in
determining the overall denominator to use for each variable in the
simplified form:
\begin{verbatim}
trigsimp(csc x - cot x + csc y - cot y, x/2, y/2, tan);

     x          y
tan(---) + tan(---)
     2          2
\end{verbatim}

It is possible to use the options of different groups simultaneously:
\begin{verbatim}
trigsimp(sin(x)^4, cos, combine);

 cos(4*x) - 4*cos(2*x) + 3
---------------------------
             8
\end{verbatim}

Sometimes, it is necessary to handle an expression in separate steps:
\begin{verbatim}
trigsimp((sinh(x)+cosh(x))^n+(cosh(x)-sinh(x))^n, expon);

  1   n    n*x
(----)  + e
   x
  e

trigsimp(ws, hyp);

2*cosh(n*x)

trigsimp((cosh(a*n)*sinh(a)*sinh(p)+cosh(a)*sinh(a*n)*sinh(p)+
    sinh(a - p)*sinh(a*n))/sinh(a));

cosh(a*n)*sinh(p) + cosh(p)*sinh(a*n)

trigsimp(ws, combine);

sinh(a*n + p)
\end{verbatim}

The \texttt{trigsimp} operator can be applied to equations, lists and
matrices (and compositions thereof) as well as scalar expressions, and
automatically maps itself recursively over such non-scalar data
structures:
\begin{verbatim}
trigsimp( { sin(2x) = cos(2x) } );

                            2
{2*cos(x)*sin(x)= - 2*sin(x)  + 1}
\end{verbatim}


\section{Factorizing trigonometric expressions}

With \texttt{trigfactorize(p,x)} one can factorize the trigonometric
or hyperbolic polynomial \texttt{p} in terms of trigonometric
functions of the argument \texttt{x}.  The output has the same format
as that from the standard \REDUCE{} operator \texttt{factorize}.  For
example:
\begin{verbatim}
trigfactorize(sin(x), x/2);

             x            x
{{2,1},{sin(---),1},{cos(---),1}}
             2            2
\end{verbatim}
If the polynomial is not coordinated or balanced \cite{art}, the
output will equal the input.  In this case, changing the value for
\texttt{x} can help to find a factorization, e.g.
\begin{verbatim}
trigfactorize(1+cos(x), x);

{{cos(x) + 1,1}}

trigfactorize(1+cos(x), x/2);

             x
{{2,1},{cos(---),2}}
             2
\end{verbatim}
The polynomial can consist of both trigonometric and hyperbolic functions:
\begin{verbatim}
trigfactorize(sin(2x)*sinh(2x), x);

{{4,1}, {sinh(x),1}, {cosh(x),1}, {sin(x),1}, {cos(x),1}}
\end{verbatim}

The \texttt{trigfactorize} operator respects the standard \REDUCE{}
\texttt{factorize} switch \texttt{nopowers} -- see the \REDUCE{}
manual for details.  Turning it on gives the behaviour that was
standard before \REDUCE~3.7:
\begin{verbatim}
on nopowers;

trigfactorize(1+cos(x), x/2);

        x        x
{2,cos(---),cos(---)}
        2        2
\end{verbatim}


\section{GCDs of trigonometric expressions}

The operator \texttt{triggcd} is essentially an application of the
algorithm behind \texttt{trigfactorize}.  With its help the user can
find the greatest common divisor of two trigonometric or hyperbolic
polynomials.  It uses the method described in \cite{art}.  The syntax
is \texttt{triggcd(p,q,x)}, where \texttt{p} and \texttt{q} are the
trigonometric polynomials and \texttt{x} is the argument to use.  For
example:
\begin{verbatim}
triggcd(sin(x), 1+cos(x), x/2);

     x
cos(---)
     2

triggcd(sin(x), 1+cos(x), x);

1
\end{verbatim}
The polynomials $p$ and $q$ can consist of both trigonometric and
hyperbolic functions:
\begin{verbatim}
triggcd(sin(2x)*sinh(2x), (1-cos(2x))*(1+cosh(2x)), x);

cosh(x)*sin(x)
\end{verbatim}


\section{Further Examples}

With the help of this package the user can create identities:
\begin{verbatim}
trigsimp(tan(x)*tan(y));

 sin(x)*sin(y)
---------------
 cos(x)*cos(y)

trigsimp(ws, combine);
\end{verbatim}

{\samepage\begin{verbatim}
 cos(x - y) - cos(x + y)
-------------------------
 cos(x - y) + cos(x + y)
\end{verbatim}}

\begin{verbatim}
trigsimp((sin(x-a)+sin(x+a))/(cos(x-a)+cos(x+a)));

 sin(x)
--------
 cos(x)

trigsimp(cosh(n*acosh(x))-cos(n*acos(x)), trig);

0

trigsimp(sec(a-b), keepalltrig);

  csc(a)*csc(b)*sec(a)*sec(b)
-------------------------------
 csc(a)*csc(b) + sec(a)*sec(b)

trigsimp(tan(a+b), keepalltrig);

  - (tan(a) + tan(b))
----------------------
  tan(a)*tan(b) - 1

trigsimp(ws, keepalltrig, combine);

tan(a + b)
\end{verbatim}

Some difficult expressions can be simplified:
\begin{verbatim}
df(sqrt(1+cos(x)), x, 4);

            5           4            3       2            3
( - 4*cos(x)  - 4*cos(x)  - 20*cos(x) *sin(x)  + 12*cos(x)

             2       2            2                   4
  - 24*cos(x) *sin(x)  + 20*cos(x)  - 15*cos(x)*sin(x)

                    2                       4            2
  + 12*cos(x)*sin(x)  + 8*cos(x) - 15*sin(x)  + 16*sin(x) )/

(16*sqrt(cos(x) + 1)

         4           3           2
 *(cos(x)  + 4*cos(x)  + 6*cos(x)  + 4*cos(x) + 1))

on rationalize;
trigsimp(ws);

 sqrt(cos(x) + 1)
------------------
        16

off rationalize;
load_package taylor;

taylor(sin(x+a)*cos(x+b), x, 0, 4);

cos(b)*sin(a) + (cos(a)*cos(b) - sin(a)*sin(b))*x

                                    2
 - (cos(a)*sin(b) + cos(b)*sin(a))*x

    2*( - cos(a)*cos(b) + sin(a)*sin(b))   3
 + --------------------------------------*x
                     3

    cos(a)*sin(b) + cos(b)*sin(a)   4      5
 + -------------------------------*x  + O(x )
                  3

trigsimp(ws, combine);

 sin(a - b) + sin(a + b)                               2
------------------------- + cos(a + b)*x - sin(a + b)*x
            2

    2*cos(a + b)   3    sin(a + b)   4      5
 - --------------*x  + ------------*x  + O(x )
         3                  3
\end{verbatim}

Certain integrals whose evaluation was not possible in \REDUCE{}
(without preprocessing) are now computable:
\begin{verbatim}
int(trigsimp(sin(x+y)*cos(x-y)*tan(x)), x);

       2
(cos(x) *x - cos(x)*sin(x) - 2*cos(y)*log(cos(x))*sin(y)

          2
  + sin(x) *x)/2

int(trigsimp(sin(x+y)*cos(x-y)/tan(x)), x);

                                   x  2
(cos(x)*sin(x) - 2*cos(y)*log(tan(---)  + 1)*sin(y)
                                   2

                      x
  + 2*cos(y)*log(tan(---))*sin(y) + x)/2
                      2
\end{verbatim}
Without the package, the integration fails, and in the second case one
does not receive an answer for many hours.

\begin{verbatim}
trigfactorize(sin(2x)*cos(y)^2, y/2);

{{2*cos(x)*sin(x),1},

       y          y
 {cos(---) - sin(---),2},
       2          2

       y          y
 {cos(---) + sin(---),2}}
       2          2
\end{verbatim}
\begin{verbatim}
trigfactorize(sin(y)^4-x^2, y);

        2               2
{{sin(y)  + x,1},{sin(y)  - x,1}}

trigfactorize(sin(x)*sinh(x), x/2);

{{4,1},

        x
 {sinh(---),1},
        2

        x
 {cosh(---),1},
        2

       x
 {sin(---),1},
       2

       x
 {cos(---),1}}
       2

triggcd(-5+cos(2x)-6sin(x), -7+cos(2x)-8sin(x), x/2);

       x        x
2*cos(---)*sin(---) + 1
       2        2

triggcd(1-2cosh(x)+cosh(2x), 1+2cosh(x)+cosh(2x), x/2);

        x  2
2*sinh(---)  + 1
        2
\end{verbatim}

\begin{thebibliography}{99}

\bibitem{art}
Roach, Kelly: Difficulties with Trigonometrics. Notes of a talk.

\bibitem{hearns}
Hearn, A.C.: COMPACT User Manual.

\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/otrgsmp1.red0000644000175000017500000002141311526203062024613 0ustar  giovannigiovannimodule trigsmp1;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Collection of rule sets.

algebraic;

clearrules(trig_imag_rules);

trig_normalize!*:=
{

  cos(~a)^2 => 1 - sin(a)^2 when trig_preference=sin,
  sin(~a)^2 => 1 - cos(a)^2 when trig_preference=cos,
  cosh(~a)^2 => 1+sinh(a)^2 when hyp_preference=sinh,
  sinh(~a)^2 => cosh(a)^2-1 when hyp_preference=cosh
};


trig_expand_addition!*:=
{
% additions theorems

  sin((~a + ~b)/~~m)
     => sin(a/m)*cos(b/m) + cos(a/m)*sin(b/m),

  cos((~a + ~b)/~~m)
     => cos(a/m)*cos(b/m) - sin(a/m)*sin(b/m),

  tan((~a+~b)/~~m)
     => (tan(a/m)+tan(b/m))/(1-tan(a/m)*tan(b/m)),

  cot((~a+~b)/~~m)
     =>(cot(a/m)*cot(b/m)-1)/(cot(a/m)+cot(b/m)),

  sec((~a+~b)/~~m)
     =>1/(1/(sec(a/m)*sec(b/m))-1/(csc(a/m)*csc(b/m))),

  csc((~a+~b)/~~m)
     =>1/(1/(sec(b/m)*csc(a/m))+1/(sec(a/m)*csc(b/m))),

  tanh((~a+~b)/~~m)
     => (tanh(a/m)+tanh(b/m))/(1+tanh(a/m)*tanh(b/m)),

  coth((~a+~b)/~~m)
     =>(coth(a/m)*coth(b/m)+1)/(coth(a/m)+coth(b/m)),

  sinh((~a+~b)/~~m)
     => sinh(a/m)*cosh(b/m) + cosh(a/m)*sinh(b/m),

  cosh((~a+~b)/~~m)
     => cosh(a/m)*cosh(b/m) + sinh(a/m)*sinh(b/m),

  sech((~a+~b)/~~m)
     =>1/(1/(sech(a/m)*sech(b/m))+1/(csch(a/m)*csch(b/m))),

  csch((~a+~b)/~~m)
     =>1/(1/(sech(a/m)*csch(b/m))+1/(sech(b/m)*csch(a/m)))};


trig_expand_multiplication!*:= {

% multiplication theorems

  sin(~n*~a/~~m)
     => sin(a/m)*cos((n-1)*a/m) + cos(a/m)*sin((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  sin(~n*~a/~~m)
     =>2*sin(n/2*a/m)*cos(n/2*a/m)
         when fixp n and mod(n,2)=0 and n>15,

  sin(~n*~a/~~m)
     =>sin((n-1)/2*a/m)*cos((n+1)/2*a/m)+
       sin((n+1)/2*a/m)*cos((n-1)/2*a/m)
         when fixp n and mod(n,2)=1 and n>15,

  cos(~n*~a/~~m)
     => cos(a/m)*cos((n-1)*a/m) - sin(a/m)*sin((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  cos(~n*~a/~~m)
      => 2*cos(n/2*a/m)**2-1
          when fixp n and mod(n,2)=0 and n>15,

  cos(~n*~a/~~m)
     => cos((n-1)/2*a/m)*cos((n+1)/2*a/m)-
        sin((n-1)/2*a/m)*sin((n+1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  sinh(~n*~a/~~m)
     => sinh(a/m)*cosh((n-1)*a/m)+cosh(a/m)*sinh((n-1)*a/m)
         when fixp n and n<=15 and n>1,

  sinh(~n*~a/~~m)
     => 2*sinh(n/2*a/m)*cosh(n/2*a/m)
         when fixp n and mod(n,2)=0 and n>15,

  sinh(~n*~a/~~m)
     => sinh((n-1)/2*a/m)*cosh((n+1)/2*a/m)+
        sinh((n+1)/2*a/m)*cosh((n-1)/2*a/m)
         when fixp n and mod(n,2)=1 and n>15,

  cosh(~n*~a/~~m)
     => cosh(a/m)*cosh((n-1)*a/m) + sinh(a/m)*sinh((n-1)*a/m)
          when fixp n and n>1 and n<=15,

  cosh(~n*~a/~~m)
      => 2*cosh(n/2*a/m)**2-1
          when fixp n and mod(n,2)=0 and n>15,

  cosh(~n*~a/~~m)
     => cosh((n-1)/2*a/m)*cosh((n+1)/2*a/m)+
        sinh((n-1)/2*a/m)*sinh((n+1)/2*a/m)
          when fixp n and mod(n,2)=1 and n>15,

  tan(~n*~a/~~m)
     => (tan(a/m)+tan((n-1)*a/m))/(1-tan(a/m)*tan((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  tan(~n*~a/~~m)
      => 2*tan(n/2*a/m)/(1-tan(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  tan(~n*~a/~~m)
     => ( tan((n-1)/2*a/m)+tan((n+1)/2*a/m) )/
        (1-tan((n-1)/2*a/m)*tan((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  tanh(~n*~a/~~m)
     => (tanh(a/m)+tanh((n-1)*a/m))/(1+tanh(a/m)*tanh((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  tanh(~n*~a/~~m)
      => 2*tanh(n/2*a/m)/(1+tanh(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  tanh(~n*~a/~~m)
     => ( tanh((n-1)/2*a/m)+tanh((n+1)/2*a/m) )/
        (1+tanh((n-1)/2*a/m)*tanh((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  cot(~n*~a/~~m)
     => (cot(a/m)*cot((n-1)*a/m)-1)/(cot(a/m)+cot((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  cot(~n*~a/~~m)
      => (cot(n/2*a/m)**2-1)/(2cot(n/2*a/m))
          when fixp n and mod(n,2)=0 and n>15,

  cot(~n*~a/~~m)
     => ( cot((n-1)/2*a/m)*cot((n+1)/2*a/m)-1 ) /
        (cot((n-1)/2*a/m)+cot((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  coth(~n*~a/~~m)
     => (coth(a/m)*coth((n-1)*a/m)+1)/(coth(a/m)+coth((n-1)*a/m))
          when fixp n and n>1 and n<=15,

  coth(~n*~a/~~m)
      => (coth(n/2*a/m)**2+1)/(2coth(n/2*a/m))
          when fixp n and mod(n,2)=0 and n>15,

  coth(~n*~a/~~m)
     => ( coth((n-1)/2*a/m)*coth((n+1)/2*a/m)+1 ) /
        (coth((n-1)/2*a/m)+coth((n+1)/2*a/m))
          when fixp n and mod(n,2)=1 and n>15,

  sec(~n*~a/~~m)
     => 1/(1/(sec(a/m)*sec((n-1)*a/m))-1/(csc(a/m)*csc((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  sec(~n*~a/~~m)
     =>1/(1/sec(n/2*a/m)**2-1/csc(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  sec(~n*~a/~~m)
     =>1/(1/(sec((n-1)/2*a/m)*sec((n+1)/2*a/m))-
       1/(csc((n-1)/2*a/m)*csc((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  csc(~n*~a/~~m)
     => 1/(1/(sec(a/m)*csc((n-1)*a/m))+1/(csc(a/m)*sec((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  csc(~n*~a/~~m)
     =>sec(n/2*a/m)*csc(n/2*a/m)/2
          when fixp n and mod(n,2)=0,

  csc(~n*~a/~~m)
     =>1/(1/(sec((n-1)/2*a/m)*csc((n+1)/2*a/m))+
       1/(csc((n-1)/2*a/m)*sec((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  sech(~n*~a/~~m)
     => 1/(1/(sech(a/m)*sech((n-1)*a/m))+1/(csch(a/m)*csch((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  sech(~n*~a/~~m)
     =>1/(1/sech(n/2*a/m)**2+1/csch(n/2*a/m)**2)
          when fixp n and mod(n,2)=0 and n>15,

  sech(~n*~a/~~m)
     =>1/(1/(sech((n-1)/2*a/m)*sech((n+1)/2*a/m))+
       1/(csch((n-1)/2*a/m)*csch((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15,

  csch(~n*~a/~~m)
     => 1/(1/(sech(a/m)*csch((n-1)*a/m))+1/(csch(a/m)*sech((n-1)*a/m)))
          when fixp n and n>1 and n<=15,

  csch(~n*~a/~~m)
     =>sech(n/2*a/m)*csch(n/2*a/m)/2
          when fixp n and mod(n,2)=0 and n>15,

  csch(~n*~a/~~m)
     =>1/(1/(sech((n-1)/2*a/m)*csch((n+1)/2*a/m))+
       1/(csch((n-1)/2*a/m)*sech((n+1)/2*a/m)))
          when fixp n and mod(n,2)=1 and n>15

};

trig_expand!*:= append(trig_expand_addition!*,
                       trig_expand_multiplication!*);

trig_combine!*:=
{
  sin(~a)*sin(~b) => 1/2*(cos(a-b) - cos(a+b)),
  cos(~a)*cos(~b) => 1/2*(cos(a-b) + cos(a+b)),
  sin(~a)*cos(~b) => 1/2*(sin(a-b) + sin(a+b)),
  sin(~a)^2          => 1/2*(1-cos(2*a)),
  cos(~a)^2          => 1/2*(1+cos(2*a)),

  sinh(~a)*sinh(~b) => 1/2*(cosh(a+b) - cosh(a-b)),
  cosh(~a)*cosh(~b) => 1/2*(cosh(a-b) + cosh(a+b)),
  sinh(~a)*cosh(~b) => 1/2*(sinh(a-b) + sinh(a+b)),
  sinh(~a)^2          => 1/2*(cosh(2*a)-1),
  cosh(~a)^2          => 1/2*(1+cosh(2*a))
};

trig_standardize!*:=
{
  tan(~a) => sin(a)/cos(a),
  cot(~a) => cos(a)/sin(a),
  tanh(~a) => sinh(a)/cosh(a),
  coth(~a) => cosh(a)/sinh(a),
  sec(~a) => 1/cos(a),
  csc(~a) => 1/sin(a),
  sech(~a) => 1/cosh(a),
  csch(~a) => 1/sinh(a)
} ;

trig2exp!*:=
{
  cos(~a) => (e^(i*a) + e^(-i*a))/2,
  sin(~a) => -i*(e^(i*a) - e^(-i*a))/2,
  cosh(~a) => (e^(a) + e^(-a))/2,
  sinh(~a) => (e^(a) - e^(-a))/2
};

exp2trig1!*:=
{
  e**(~x)=>cos(x/i)+i*sin(x/i)
};

exp2trig2!*:=
{
  e**(~x)=>1/(cos(x/i)-i*sin(x/i))
};

trig2hyp!*:=
{
  sin(~a)=> -i * sinh(i*a),
  cos(~a)=> cosh(i*a),
  tan(~a)=> -i*tanh(i*a),
  cot(~a)=> i*coth(i*a),
  sec(~a)=> sech(i*a),
  csc(~a)=> i*csch(i*a),
  asin(~a)=> asinh(i*a)/i,
  acos(~a)=> acosh(a)/i
};

hyp2trig!*:=
{
  sinh(~a)=> -i*sin(i*~a),
  cosh(~a)=> cos(i*~a),
  acosh(~a)=> i*acos(a),
  asinh(~a)=> asin(-i*a)*i
};

subtan!*:=
{
  sin(~x)=>cos(x)*tan(x) when trig_preference=cos,
  cos(~x)=>sin(x)/tan(x) when trig_preference=sin,
  sinh(~x)=>cosh(x)*tanh(x) when hyp_preference=cosh,
  cosh(x)=>sinh(x)/tanh(x) when hyp_preference=sinh
};


endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/trigsimp.rlg0000644000175000017500000010432511527635055024727 0ustar  giovannigiovanniFri Feb 18 21:28:54 2011 run on win32
% Test file for TrigSimp package

%-------------------------TrigSimp--------------------------

trigsimp(tan(x+y), keepalltrig);


  - (tan(x) + tan(y))
----------------------
  tan(x)*tan(y) - 1

trigsimp(ws, keepalltrig, combine);


tan(x + y)

trigsimp(sin(5x-9y));


                     4       9                     4       7
 - 4096*cos(x)*sin(x) *sin(y)  + 9216*cos(x)*sin(x) *sin(y)

                     4       5                     4       3
 - 6912*cos(x)*sin(x) *sin(y)  + 1920*cos(x)*sin(x) *sin(y)

                    4                            2       9
 - 144*cos(x)*sin(x) *sin(y) + 3072*cos(x)*sin(x) *sin(y)

                     2       7                     2       5
 - 6912*cos(x)*sin(x) *sin(y)  + 5184*cos(x)*sin(x) *sin(y)

                     2       3                    2                           9
 - 1440*cos(x)*sin(x) *sin(y)  + 108*cos(x)*sin(x) *sin(y) - 256*cos(x)*sin(y)

                    7                    5                    3
 + 576*cos(x)*sin(y)  - 432*cos(x)*sin(y)  + 120*cos(x)*sin(y)

                                       5       8                     5       6
 - 9*cos(x)*sin(y) + 4096*cos(y)*sin(x) *sin(y)  - 7168*cos(y)*sin(x) *sin(y)

                     5       4                    5       2                   5
 + 3840*cos(y)*sin(x) *sin(y)  - 640*cos(y)*sin(x) *sin(y)  + 16*cos(y)*sin(x)

                     3       8                     3       6
 - 5120*cos(y)*sin(x) *sin(y)  + 8960*cos(y)*sin(x) *sin(y)

                     3       4                    3       2                   3
 - 4800*cos(y)*sin(x) *sin(y)  + 800*cos(y)*sin(x) *sin(y)  - 20*cos(y)*sin(x)

                            8                            6
 + 1280*cos(y)*sin(x)*sin(y)  - 2240*cos(y)*sin(x)*sin(y)

                            4                           2
 + 1200*cos(y)*sin(x)*sin(y)  - 200*cos(y)*sin(x)*sin(y)  + 5*cos(y)*sin(x)

trigsimp(ws, combine);


sin(5*x - 9*y)

trigsimp(cos(10x), cos);


          10              8              6             4            2
512*cos(x)   - 1280*cos(x)  + 1120*cos(x)  - 400*cos(x)  + 50*cos(x)  - 1

trigsimp(cos(10x), sin);


             10              8              6             4            2
 - 512*sin(x)   + 1280*sin(x)  - 1120*sin(x)  + 400*sin(x)  - 50*sin(x)  + 1

trigsimp((sin(x-a)+sin(x+a))/(cos(x-a)+cos(x+a)));


 sin(x)
--------
 cos(x)

trigsimp(cos(6x+4y), sin);


                        5       3                           5
256*cos(x)*cos(y)*sin(x) *sin(y)  - 128*cos(x)*cos(y)*sin(x) *sin(y)

                           3       3                           3
 - 256*cos(x)*cos(y)*sin(x) *sin(y)  + 128*cos(x)*cos(y)*sin(x) *sin(y)

                                 3
 + 48*cos(x)*cos(y)*sin(x)*sin(y)  - 24*cos(x)*cos(y)*sin(x)*sin(y)

             6       4             6       2            6             4       4
 - 256*sin(x) *sin(y)  + 256*sin(x) *sin(y)  - 32*sin(x)  + 384*sin(x) *sin(y)

             4       2            4             2       4             2       2
 - 384*sin(x) *sin(y)  + 48*sin(x)  - 144*sin(x) *sin(y)  + 144*sin(x) *sin(y)

            2           4           2
 - 18*sin(x)  + 8*sin(y)  - 8*sin(y)  + 1

trigsimp(ws, expon);


  12*i*x + 8*i*y
 e               + 1
---------------------
     6*i*x + 4*i*y
  2*e

trigsimp(ws, hyp);


                                 5          3
256*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    5
 + 128*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    3          3
 + 256*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    3
 + 128*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                             3
 + 48*cosh(i*x)*cosh(i*y)*sinh(i*x)*sinh(i*y)

                                                             6          4
 + 24*cosh(i*x)*cosh(i*y)*sinh(i*x)*sinh(i*y) + 256*sinh(i*x) *sinh(i*y)

                6          2               6                4          4
 + 256*sinh(i*x) *sinh(i*y)  + 32*sinh(i*x)  + 384*sinh(i*x) *sinh(i*y)

                4          2               4                2          4
 + 384*sinh(i*x) *sinh(i*y)  + 48*sinh(i*x)  + 144*sinh(i*x) *sinh(i*y)

                2          2               2              4              2
 + 144*sinh(i*x) *sinh(i*y)  + 18*sinh(i*x)  + 8*sinh(i*y)  + 8*sinh(i*y)  + 1

trigsimp(ws, combine);


cosh(6*i*x + 4*i*y)

trigsimp(ws, trig, combine);


cos(6*x + 4*y)

trigsimp(sqrt(1-cos(2x)));


sqrt(2)*abs(sin(x))

trigsimp(sin(x)^20*cos(x)^20, sin);


      20        20            18            16             14             12
sin(x)  *(sin(x)   - 10*sin(x)   + 45*sin(x)   - 120*sin(x)   + 210*sin(x)

                       10             8             6            4            2
           - 252*sin(x)   + 210*sin(x)  - 120*sin(x)  + 45*sin(x)  - 10*sin(x)

           + 1)

trigsimp(sin(x)^20*cos(x)^20, cos);


      20        20            18            16             14             12
cos(x)  *(cos(x)   - 10*cos(x)   + 45*cos(x)   - 120*cos(x)   + 210*cos(x)

                       10             8             6            4            2
           - 252*cos(x)   + 210*cos(x)  - 120*cos(x)  + 45*cos(x)  - 10*cos(x)

           + 1)

trigsimp(sin(x)^20*cos(x)^20, compact);


      20       20
cos(x)  *sin(x)

trigsimp(sin(x)^10, combine);


  - cos(10*x) + 10*cos(8*x) - 45*cos(6*x) + 120*cos(4*x) - 210*cos(2*x) + 126
------------------------------------------------------------------------------
                                     512

trigsimp(ws, hyp);


            10
 - sinh(i*x)

trigsimp(ws, expon);


     20*i*x       18*i*x       16*i*x        14*i*x        12*i*x        10*i*x
( - e       + 10*e       - 45*e       + 120*e       - 210*e       + 252*e

         8*i*x        6*i*x       4*i*x       2*i*x             10*i*x
  - 210*e      + 120*e      - 45*e      + 10*e      - 1)/(1024*e      )

trigsimp(ws, trig);


      10
sin(x)

int(sin(x+y)*cos(x-y)*tan(x), x);


int(cos(x - y)*sin(x + y)*tan(x),x)

int(trigsimp(sin(x+y)*cos(x-y)*tan(x)), x);


       2                                                         2
 cos(x) *x - cos(x)*sin(x) - 2*cos(y)*log(cos(x))*sin(y) + sin(x) *x
---------------------------------------------------------------------
                                  2

% int(sin(x+y)*cos(x-y)/tan(x), x) hangs
int(trigsimp(sin(x+y)*cos(x-y)/tan(x)), x);


                                   x  2
(cos(x)*sin(x) - 2*cos(y)*log(tan(---)  + 1)*sin(y)
                                   2

                      x
  + 2*cos(y)*log(tan(---))*sin(y) + x)/2
                      2

trigsimp(2tan(x)*(sec(x)^2 - tan(x)^2 - 1));


0

on rationalize;


df(sqrt(1+cos(x)), x, 4);


                              4            2       2            2
(sqrt(cos(x) + 1)*( - 4*cos(x)  - 20*cos(x) *sin(x)  + 12*cos(x)

                      2                       4            2
     - 4*cos(x)*sin(x)  + 8*cos(x) - 15*sin(x)  + 16*sin(x) ))/(16

           4           3           2
   *(cos(x)  + 4*cos(x)  + 6*cos(x)  + 4*cos(x) + 1))

off rationalize;


trigsimp(ws);


 sqrt(cos(x) + 1)
------------------
        16

df(2cos((x+y)/2)*cos((x-y)/2), x);


         x - y        x + y          x + y        x - y
 - (cos(-------)*sin(-------) + cos(-------)*sin(-------))
           2            2              2            2

trigsimp(ws, combine);


 - sin(x)

df(int(1/cos(x), x), x);


          x  2
  - (tan(---)  + 1)
          2
--------------------
        x  2
   tan(---)  - 1
        2

trigsimp(ws, combine);


   1
--------
 cos(x)

trigsimp(cos(100x));


                                     100
633825300114114700748351602688*sin(x)

                                          98
 - 15845632502852867518708790067200*sin(x)

                                           96
 + 192128294097091018664344079564800*sin(x)

                                            94
 - 1505335087771022414277335056384000*sin(x)

                                            92
 + 8567473526884295537508113973248000*sin(x)

                                             90
 - 37750993877408064336851542202122240*sin(x)

                                              88
 + 134036108580690866727917044786790400*sin(x)

                                              86
 - 394078512785625681900511864396185600*sin(x)

                                              84
 + 978503372439851812055958467641344000*sin(x)

                                               82
 - 2082455895192505138478065456775168000*sin(x)

                                               80
 + 3842131126630171980492030767750184960*sin(x)

                                               78
 - 6200783636440931286187342812099379200*sin(x)

                                               76
 + 8816739233064449172547628060953804800*sin(x)

                                                74
 - 11108623702136905456127648087408640000*sin(x)

                                                72
 + 12460295938318846194767764735918080000*sin(x)

                                                70
 - 12489614281703125832873100652943769600*sin(x)

                                                68
 + 11221137831217652115471926367879168000*sin(x)

                                               66
 - 9058026923994972189597820080095232000*sin(x)

                                               64
 + 6581798018959761296303294062264320000*sin(x)

                                               62
 - 4310885252184171141438414824407040000*sin(x)

                                               60
 + 2547463753712583633893763260298035200*sin(x)

                                               58
 - 1358954443662228159129584379363328000*sin(x)

                                              56
 + 654531379770880870350000868032512000*sin(x)

                                              54
 - 284578860769948204500000377405440000*sin(x)

                                              52
 + 111631674825053695350740279623680000*sin(x)

                                             50
 - 39472960218138986676021762874933248*sin(x)

                                             48
 + 12566106098549963273941439584665600*sin(x)

                                            46
 - 3595780740528756614156758967910400*sin(x)

                                           44
 + 923024074019658505866132324352000*sin(x)

                                           42
 - 212040013118649088525828358144000*sin(x)

                                          40
 + 43468202689323063147794813419520*sin(x)

                                         38
 - 7925478751208973645460484915200*sin(x)

                                         36
 + 1280241627320751027747867852800*sin(x)

                                        34
 - 182395347175955031090266112000*sin(x)

                                       32
 + 22799418396994378886283264000*sin(x)

                                      30                                     28
 - 2485387148331694929142087680*sin(x)   + 234623135747458180159897600*sin(x)

                                    26                                   24
 - 19023497493037149742694400*sin(x)   + 1312104559685287280640000*sin(x)

                                 22                                20
 - 76111992112891822080000*sin(x)   + 3662889620432918937600*sin(x)

                               18                             16
 - 143850563845029888000*sin(x)   + 4517474603507712000*sin(x)

                            14                          12
 - 110586893598720000*sin(x)   + 2042087523840000*sin(x)

                        10                      8                    6
 - 27227833651200*sin(x)   + 246628928000*sin(x)  - 1386112000*sin(x)

                 4              2
 + 4165000*sin(x)  - 5000*sin(x)  + 1

trigsimp(ws, combine);


cos(100*x)

trigsimp(sinh(3a+4b-5c)*cosh(3a-5b-6c));


                                     5        10
16384*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        5        8
 + 36864*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        5        6
 + 28672*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                       5        4
 + 8960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                      5        2
 + 960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                     5
 + 16*cosh(a)*cosh(b)*cosh(c)*sinh(a)

                                        3        10
 + 16384*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        3        8
 + 36864*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        3        6
 + 28672*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                       3        4
 + 8960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                      3        2
 + 960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                     3
 + 16*cosh(a)*cosh(b)*cosh(c)*sinh(a)

                                               10
 + 3072*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               8
 + 6912*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               6
 + 5376*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               4
 + 1680*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                              2
 + 180*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                                            5                11
 + 3*cosh(a)*cosh(b)*cosh(c)*sinh(a) + 16384*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                9
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                7
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                5
 + 19712*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                       5                3                      5
 + 3520*cosh(a)*sinh(a) *sinh(b)*sinh(c)  + 176*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                11
 + 16384*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                9
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                7
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                5
 + 19712*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                       3                3                      3
 + 3520*cosh(a)*sinh(a) *sinh(b)*sinh(c)  + 176*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                                       11
 + 3072*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                       9                                       7
 + 8448*cosh(a)*sinh(a)*sinh(b)*sinh(c)  + 8448*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                       5                                      3
 + 3696*cosh(a)*sinh(a)*sinh(b)*sinh(c)  + 660*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                                             6        11
 + 33*cosh(a)*sinh(a)*sinh(b)*sinh(c) - 16384*cosh(b)*sinh(a) *sinh(c)

                        6        9                        6        7
 - 45056*cosh(b)*sinh(a) *sinh(c)  - 45056*cosh(b)*sinh(a) *sinh(c)

                        6        5                       6        3
 - 19712*cosh(b)*sinh(a) *sinh(c)  - 3520*cosh(b)*sinh(a) *sinh(c)

                      6                                4        11
 - 176*cosh(b)*sinh(a) *sinh(c) - 24576*cosh(b)*sinh(a) *sinh(c)

                        4        9                        4        7
 - 67584*cosh(b)*sinh(a) *sinh(c)  - 67584*cosh(b)*sinh(a) *sinh(c)

                        4        5                       4        3
 - 29568*cosh(b)*sinh(a) *sinh(c)  - 5280*cosh(b)*sinh(a) *sinh(c)

                      4                               2        11
 - 264*cosh(b)*sinh(a) *sinh(c) - 9216*cosh(b)*sinh(a) *sinh(c)

                        2        9                        2        7
 - 25344*cosh(b)*sinh(a) *sinh(c)  - 25344*cosh(b)*sinh(a) *sinh(c)

                        2        5                       2        3
 - 11088*cosh(b)*sinh(a) *sinh(c)  - 1980*cosh(b)*sinh(a) *sinh(c)

                     2                              8
 - 99*cosh(b)*sinh(a) *sinh(c) + 128*cosh(b)*sinh(b) *sinh(c)

                      6                              4
 + 224*cosh(b)*sinh(b) *sinh(c) + 120*cosh(b)*sinh(b) *sinh(c)

                     2                              11                       9
 + 20*cosh(b)*sinh(b) *sinh(c) - 512*cosh(b)*sinh(c)   - 1408*cosh(b)*sinh(c)

                       7                      5                      3
 - 1408*cosh(b)*sinh(c)  - 616*cosh(b)*sinh(c)  - 110*cosh(b)*sinh(c)

                                            6                10
 - 5*cosh(b)*sinh(c) - 16384*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        6                8
 - 36864*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        6                6
 - 28672*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       6                4
 - 8960*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                      6                2                     6
 - 960*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 16*cosh(c)*sinh(a) *sinh(b)

                        4                10
 - 24576*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                8
 - 55296*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                6
 - 43008*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                4
 - 13440*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       4                2                     4
 - 1440*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 24*cosh(c)*sinh(a) *sinh(b)

                       2                10
 - 9216*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        2                8
 - 20736*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        2                6
 - 16128*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       2                4
 - 5040*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                      2                2                    2
 - 540*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 9*cosh(c)*sinh(a) *sinh(b)

                      9                      7                      5
 + 128*cosh(c)*sinh(b)  + 288*cosh(c)*sinh(b)  + 216*cosh(c)*sinh(b)

                     3                              10
 + 60*cosh(c)*sinh(b)  - 512*cosh(c)*sinh(b)*sinh(c)

                               8                              6
 - 1152*cosh(c)*sinh(b)*sinh(c)  - 896*cosh(c)*sinh(b)*sinh(c)

                              4                             2
 - 280*cosh(c)*sinh(b)*sinh(c)  - 30*cosh(c)*sinh(b)*sinh(c)

 + 4*cosh(c)*sinh(b)

trigsimp(ws, combine);


 sinh(9*b + c) + sinh(6*a - b - 11*c)
--------------------------------------
                  2

trigsimp(sec(20x-y), keepalltrig);


       20              20                20                   19
(csc(x)  *csc(y)*sec(x)  *sec(y))/(csc(x)  *csc(y) + 20*csc(x)  *sec(x)*sec(y)

                18              2              17       3
    - 190*csc(x)  *csc(y)*sec(x)  - 1140*csc(x)  *sec(x) *sec(y)

                 16              4               15       5
    + 4845*csc(x)  *csc(y)*sec(x)  + 15504*csc(x)  *sec(x) *sec(y)

                  14              6               13       7
    - 38760*csc(x)  *csc(y)*sec(x)  - 77520*csc(x)  *sec(x) *sec(y)

                   12              8                11       9
    + 125970*csc(x)  *csc(y)*sec(x)  + 167960*csc(x)  *sec(x) *sec(y)

                   10              10                9       11
    - 184756*csc(x)  *csc(y)*sec(x)   - 167960*csc(x) *sec(x)  *sec(y)

                   8              12               7       13
    + 125970*csc(x) *csc(y)*sec(x)   + 77520*csc(x) *sec(x)  *sec(y)

                  6              14               5       15
    - 38760*csc(x) *csc(y)*sec(x)   - 15504*csc(x) *sec(x)  *sec(y)

                 4              16              3       17
    + 4845*csc(x) *csc(y)*sec(x)   + 1140*csc(x) *sec(x)  *sec(y)

                2              18                   19                       20
    - 190*csc(x) *csc(y)*sec(x)   - 20*csc(x)*sec(x)  *sec(y) + csc(y)*sec(x)  )

trigsimp(csc(10a-9b), keepalltrig);


          10       9       10       9           10       8
( - csc(a)  *csc(b) *sec(a)  *sec(b) )/(9*csc(a)  *csc(b) *sec(b)

               10       6       3             10       4       5
    - 84*csc(a)  *csc(b) *sec(b)  + 126*csc(a)  *csc(b) *sec(b)

               10       2       7         10       9            9       9
    - 36*csc(a)  *csc(b) *sec(b)  + csc(a)  *sec(b)  - 10*csc(a) *csc(b) *sec(a)

                9       7              2              9       5              4
    + 360*csc(a) *csc(b) *sec(a)*sec(b)  - 1260*csc(a) *csc(b) *sec(a)*sec(b)

                9       3              6            9                     8
    + 840*csc(a) *csc(b) *sec(a)*sec(b)  - 90*csc(a) *csc(b)*sec(a)*sec(b)

                8       8       2                     8       6       2       3
    - 405*csc(a) *csc(b) *sec(a) *sec(b) + 3780*csc(a) *csc(b) *sec(a) *sec(b)

                 8       4       2       5
    - 5670*csc(a) *csc(b) *sec(a) *sec(b)

                 8       2       2       7            8       2       9
    + 1620*csc(a) *csc(b) *sec(a) *sec(b)  - 45*csc(a) *sec(a) *sec(b)

                7       9       3              7       7       3       2
    + 120*csc(a) *csc(b) *sec(a)  - 4320*csc(a) *csc(b) *sec(a) *sec(b)

                  7       5       3       4
    + 15120*csc(a) *csc(b) *sec(a) *sec(b)

                  7       3       3       6
    - 10080*csc(a) *csc(b) *sec(a) *sec(b)

                 7              3       8              6       8       4
    + 1080*csc(a) *csc(b)*sec(a) *sec(b)  + 1890*csc(a) *csc(b) *sec(a) *sec(b)

                  6       6       4       3
    - 17640*csc(a) *csc(b) *sec(a) *sec(b)

                  6       4       4       5
    + 26460*csc(a) *csc(b) *sec(a) *sec(b)

                 6       2       4       7             6       4       9
    - 7560*csc(a) *csc(b) *sec(a) *sec(b)  + 210*csc(a) *sec(a) *sec(b)

                5       9       5              5       7       5       2
    - 252*csc(a) *csc(b) *sec(a)  + 9072*csc(a) *csc(b) *sec(a) *sec(b)

                  5       5       5       4
    - 31752*csc(a) *csc(b) *sec(a) *sec(b)

                  5       3       5       6
    + 21168*csc(a) *csc(b) *sec(a) *sec(b)

                 5              5       8              4       8       6
    - 2268*csc(a) *csc(b)*sec(a) *sec(b)  - 1890*csc(a) *csc(b) *sec(a) *sec(b)

                  4       6       6       3
    + 17640*csc(a) *csc(b) *sec(a) *sec(b)

                  4       4       6       5
    - 26460*csc(a) *csc(b) *sec(a) *sec(b)

                 4       2       6       7             4       6       9
    + 7560*csc(a) *csc(b) *sec(a) *sec(b)  - 210*csc(a) *sec(a) *sec(b)

                3       9       7              3       7       7       2
    + 120*csc(a) *csc(b) *sec(a)  - 4320*csc(a) *csc(b) *sec(a) *sec(b)

                  3       5       7       4
    + 15120*csc(a) *csc(b) *sec(a) *sec(b)

                  3       3       7       6
    - 10080*csc(a) *csc(b) *sec(a) *sec(b)

                 3              7       8             2       8       8
    + 1080*csc(a) *csc(b)*sec(a) *sec(b)  + 405*csc(a) *csc(b) *sec(a) *sec(b)

                 2       6       8       3
    - 3780*csc(a) *csc(b) *sec(a) *sec(b)

                 2       4       8       5
    + 5670*csc(a) *csc(b) *sec(a) *sec(b)

                 2       2       8       7            2       8       9
    - 1620*csc(a) *csc(b) *sec(a) *sec(b)  + 45*csc(a) *sec(a) *sec(b)

                      9       9                    7       9       2
    - 10*csc(a)*csc(b) *sec(a)  + 360*csc(a)*csc(b) *sec(a) *sec(b)

                        5       9       4                    3       9       6
    - 1260*csc(a)*csc(b) *sec(a) *sec(b)  + 840*csc(a)*csc(b) *sec(a) *sec(b)

                             9       8           8       10
    - 90*csc(a)*csc(b)*sec(a) *sec(b)  - 9*csc(b) *sec(a)  *sec(b)

               6       10       3             4       10       5
    + 84*csc(b) *sec(a)  *sec(b)  - 126*csc(b) *sec(a)  *sec(b)

               2       10       7         10       9
    + 36*csc(b) *sec(a)  *sec(b)  - sec(a)  *sec(b) )

trigsimp(ws, combine);


        1
-----------------
 sin(10*a - 9*b)

trigsimp(cosh(50*acosh(x))-cos(50*acos(x)));


0

trigsimp(cos(n*acos(x))-cosh(n*acosh(x)), trig);


0

trigsimp((2tan(log(x))*(sec(log(x))^2 - tan(log(x))^2 - 1))/x);


0

trigsimp(sech(10x), keepalltrig);


        10        10          10             8        2              6        4
(csch(x)  *sech(x)  )/(csch(x)   + 45*csch(x) *sech(x)  + 210*csch(x) *sech(x)

                 4        6             2        8          10
    + 210*csch(x) *sech(x)  + 45*csch(x) *sech(x)  + sech(x)  )

trigsimp(ws, combine);


     1
------------
 cosh(10*x)

trigsimp(csch(3x-5y), keepalltrig);


           3        5        3        5            3        4
( - csch(x) *csch(y) *sech(x) *sech(y) )/(5*csch(x) *csch(y) *sech(y)

                3        2        3          3        5
    + 10*csch(x) *csch(y) *sech(y)  + csch(x) *sech(y)

               2        5                     2        3                2
    - 3*csch(x) *csch(y) *sech(x) - 30*csch(x) *csch(y) *sech(x)*sech(y)

                2                        4
    - 15*csch(x) *csch(y)*sech(x)*sech(y)

                        4        2
    + 15*csch(x)*csch(y) *sech(x) *sech(y)

                        2        2        3                    2        5
    + 30*csch(x)*csch(y) *sech(x) *sech(y)  + 3*csch(x)*sech(x) *sech(y)

             5        3             3        3        2
    - csch(y) *sech(x)  - 10*csch(y) *sech(x) *sech(y)

                       3        4
    - 5*csch(y)*sech(x) *sech(y) )

trigsimp(ws, combine);


        1
-----------------
 sinh(3*x - 5*y)

off precise;


trigsimp((sinh(x)+cosh(x))^n+(cosh(x)-sinh(x))^n, expon);


  2*n*x
 e      + 1
------------
     n*x
    e

on precise;


trigsimp(ws, hyp);


2*cosh(n*x)

load_package taylor;


taylor(sin(x+a)*cos(x+b), x, 0, 4);


cos(b)*sin(a) + (cos(a)*cos(b) - sin(a)*sin(b))*x

                                    2
 - (cos(a)*sin(b) + cos(b)*sin(a))*x

    2*( - cos(a)*cos(b) + sin(a)*sin(b))   3
 + --------------------------------------*x
                     3

    cos(a)*sin(b) + cos(b)*sin(a)   4      5
 + -------------------------------*x  + O(x )
                  3

trigsimp(ws, combine);


 sin(a - b) + sin(a + b)                               2    2*cos(a + b)   3
------------------------- + cos(a + b)*x - sin(a + b)*x  - --------------*x
            2                                                    3

    sin(a + b)   4      5
 + ------------*x  + O(x )
        3


%-----------------------TrigFactorize-----------------------

on nopowers;

  % for comparison with version 2.0
trigfactorize(sin(x)**2, x);


{sin(x),sin(x)}

trigfactorize(1+cos(x), x);


{cos(x) + 1}

trigfactorize(1+cos(x), x/2);


        x        x
{2,cos(---),cos(---)}
        2        2

trigfactorize(1+cos(x), x/6);


{2,

           x  2
  - 4*sin(---)  + 1,
           6

           x  2
  - 4*sin(---)  + 1,
           6

      x
 cos(---),
      6

      x
 cos(---)}
      6

trigfactorize(sin(x)*(1-cos(x)), x);


{sin(x)*( - cos(x) + 1)}

trigfactorize(sin(x)*(1-cos(x)), x/2);


{4,

      x
 cos(---),
      2

      x
 sin(---),
      2

      x
 sin(---),
      2

      x
 sin(---)}
      2

trigfactorize(tan(x), x);


{tan(x)}

trigfactorize(sin(x*3), x);


            2
{ - 4*sin(x)  + 3,sin(x)}

trigfactorize(sin(4x)-1, x);


{-1,

                           2
 2*cos(x)*sin(x) + 2*sin(x)  - 1,

                           2
 2*cos(x)*sin(x) + 2*sin(x)  - 1}

trigfactorize(sin(x)**4-1, x);


          2
{-1,sin(x)  + 1,cos(x),cos(x)}

trigfactorize(cos(x)**4-1, x);


       2
{sin(x)  - 2,sin(x),sin(x)}

trigfactorize(sin(x)**10-cos(x)**6, x);


{-1,

              2                  5
 cos(x)*sin(x)  - cos(x) - sin(x) ,

              2                  5
 cos(x)*sin(x)  - cos(x) + sin(x) }

trigfactorize(sin(x)*cos(y), x);


{cos(y),sin(x)}

trigfactorize(sin(2x)*cos(y)**2, y/2);


{2*cos(x)*sin(x),

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) - sin(---),
      2          2

      y          y
 cos(---) - sin(---)}
      2          2

trigfactorize(sin(y)**4-x**2, y);


       2           2
{sin(y)  - x,sin(y)  + x}

trigfactorize(sin(x), x+1);


***** TrigGCD/Factorize error: last arg must be [number*]variable. 

trigfactorize(sin(x), 2x);


***** TrigGCD/Factorize error: basis not possible. 

trigfactorize(sin(x)*cosh(x), x/2);


{2,

      x
 cos(---),
      2

      x
 sin(---),
      2

       x             x
 cosh(---) - i*sinh(---),
       2             2

       x             x
 cosh(---) + i*sinh(---)}
       2             2

trigfactorize(1+cos(2x)+2cos(x)*cosh(x), x/2);


{4,

      x         x            x         x
 cos(---)*cosh(---) + i*sin(---)*sinh(---),
      2         2            2         2

      x         x            x         x
 cos(---)*cosh(---) - i*sin(---)*sinh(---),
      2         2            2         2

      x          x
 cos(---) + sin(---),
      2          2

      x          x
 cos(---) - sin(---)}
      2          2


%-------------------------TrigGCD---------------------------

triggcd(sin(x), cos(x), x);


1

triggcd(1-cos(x)^2, sin(x)^2, x);


         2
 - sin(x)

triggcd(sin(x)^4-1, cos(x)^2, x);


         2
 - sin(x)  + 1

triggcd(sin(5x+1), cos(x), x);


1

triggcd(1-cos(2x), sin(2x), x);


sin(x)

triggcd(-5+cos(2x)-6sin(x), -7+cos(2x)-8sin(x), x/2);


       x        x
2*cos(---)*sin(---) + 1
       2        2

triggcd(1-2cosh(x)+cosh(2x), 1+2cosh(x)+cosh(2x), x/2);


        x  2
2*sinh(---)  + 1
        2

triggcd(1+cos(2x)+2cos(x)*cosh(x), 1+2cos(x)*cosh(x)+cosh(2x), x/2);


        x  2         x  2
 - sin(---)  + sinh(---)  + 1
        2            2

triggcd(-1+2a*b+cos(2x)-2a*sin(x)+2b*sin(x),
   -1-2a*b+cos(2x)-2a*sin(x)-2b*sin(x), x/2);


       x        x
2*cos(---)*sin(---) + a
       2        2

triggcd(sin(x)^10-1, cos(x), x);


cos(x)

triggcd(sin(5x)+sin(3x), cos(x), x);


cos(x)

triggcd(sin(3x)+sin(5x), sin(5x)+sin(7x), x);


              2
sin(x)*(sin(x)  - 1)


%-----------------------------------------------------------

% New facilities in version 2

%-----------------------------------------------------------

% TrigSimp applied to non-scalars data structures:
trigsimp( sin(2x) = cos(2x) );


                           2
2*cos(x)*sin(x)= - 2*sin(x)  + 1

trigsimp( { sin(2x), cos(2x) } );


                            2
{2*cos(x)*sin(x), - 2*sin(x)  + 1}

trigsimp( { sin(2x) = cos(2x) } );


                            2
{2*cos(x)*sin(x)= - 2*sin(x)  + 1}

trigsimp( mat((sin(2x),cos(2x)),
              (csc(2x),sec(2x))) );


[                              2    ]
[ 2*cos(x)*sin(x)    - 2*sin(x)  + 1]
[                                   ]
[        1                - 1       ]
[-----------------  --------------- ]
[ 2*cos(x)*sin(x)            2      ]
[                    2*sin(x)  - 1  ]



% An amusing identify:
trigsimp(csc x - cot x - tan(x/2));


0


% which could be DERIVED like this:
trigsimp(csc x - cot x, x/2, tan);


     x
tan(---)
     2


% A silly illustration of multiple additional trig arguments:
trigsimp(csc x - cot x, x/2, x/3);


                  x  5           x  3          x
          16*sin(---)  - 24*sin(---)  + 9*sin(---)
                  6              6             6
------------------------------------------------------------
         x        x  4           x        x  2          x
 16*cos(---)*sin(---)  - 16*cos(---)*sin(---)  + 3*cos(---)
         6        6              6        6             6


% A more useful illustration of multiple additional trig arguments:
trigsimp(csc x - cot x + csc y - cot y, x/2, y/2, tan);


     x          y
tan(---) + tan(---)
     2          2


%-----------------------------------------------------------

% New TrigFactorize facility:
off nopowers;

  % REDUCE 3.7 default, gives more compact output ...
trigfactorize(sin(x)^2, x);


{{sin(x),2}}

trigfactorize(1+cos(x), x);


{{cos(x) + 1,1}}

trigfactorize(1+cos(x), x/2);


             x
{{2,1},{cos(---),2}}
             2

trigfactorize(1+cos(x), x/6);


             x                 x  2
{{2,1},{cos(---),2},{ - 4*sin(---)  + 1,2}}
             6                 6

trigfactorize(sin(x)*(1-cos(x)), x);


{{sin(x)*( - cos(x) + 1),1}}

trigfactorize(sin(x)*(1-cos(x)), x/2);


             x            x
{{4,1},{sin(---),3},{cos(---),1}}
             2            2

trigfactorize(tan(x), x);


{{tan(x),1}}

trigfactorize(sin(3x), x);


                        2
{{sin(x),1},{ - 4*sin(x)  + 3,1}}

trigfactorize(sin(4x) - 1, x);


                                   2
{{-1,1},{2*cos(x)*sin(x) + 2*sin(x)  - 1,2}}

trigfactorize(sin(x)^4 - 1, x);


                          2
{{-1,1},{cos(x),2},{sin(x)  + 1,1}}

trigfactorize(cos(x)^4 - 1, x);


                   2
{{sin(x),2},{sin(x)  - 2,1}}

trigfactorize(sin(x)^10 - cos(x)^6, x);


{{-1,1},

               2                  5
 {cos(x)*sin(x)  - cos(x) + sin(x) ,1},

               2                  5
 {cos(x)*sin(x)  - cos(x) - sin(x) ,1}}

trigfactorize(sin(x)*cos(y), x);


{{cos(y),1},{sin(x),1}}

trigfactorize(sin(2x)*cos(y)^2, y/2);


{{2*cos(x)*sin(x),1},

       y          y
 {cos(---) - sin(---),2},
       2          2

       y          y
 {cos(---) + sin(---),2}}
       2          2

trigfactorize(sin(y)^4 - x^2, y);


        2               2
{{sin(y)  + x,1},{sin(y)  - x,1}}

trigfactorize(sin(x), x+1);


***** TrigGCD/Factorize error: last arg must be [number*]variable. 

trigfactorize(sin(x), 2x);


***** TrigGCD/Factorize error: basis not possible. 

trigfactorize(sin(x)*cosh(x), x/2);


{{2,1},

        x             x
 {cosh(---) + i*sinh(---),1},
        2             2

        x             x
 {cosh(---) - i*sinh(---),1},
        2             2

       x
 {sin(---),1},
       2

       x
 {cos(---),1}}
       2

trigfactorize(1 + cos(2x) + 2cos(x)*cosh(x), x/2);


{{4,1},

       x          x
 {cos(---) - sin(---),1},
       2          2

       x          x
 {cos(---) + sin(---),1},
       2          2

       x         x            x         x
 {cos(---)*cosh(---) - i*sin(---)*sinh(---),
       2         2            2         2

  1},

       x         x            x         x
 {cos(---)*cosh(---) + i*sin(---)*sinh(---),
       2         2            2         2

  1}}


end;


Time for test: 1061 ms, plus GC time: 63 ms
@@@@@ Resources used: (1 11 331 4)
mathpiper-0.81f+svn4469+dfsg3/src/packages/trigsimp/otrgsimp.rlg0000644000175000017500000007405211526203062024724 0ustar  giovannigiovanniFri Jul 21 09:24:26 PDT 1995
REDUCE Development Version, 19-Jul-95 ...

1: 1: 
2: 2: 2: 
(nil)

3: 3: 
4: 4: % test file for trigsimp package
%
%---------------------trigsimp---------------------------
trigsimp(tan(x+y),keepalltrig);


  - (tan(x) + tan(y))
----------------------
  tan(x)*tan(y) - 1

trigsimp(ws,keepalltrig,combine);


tan(x + y)

trigsimp(sin(5x-9y));


                     4       9                     4       7
 - 4096*cos(x)*sin(x) *sin(y)  + 9216*cos(x)*sin(x) *sin(y)

                     4       5                     4       3
 - 6912*cos(x)*sin(x) *sin(y)  + 1920*cos(x)*sin(x) *sin(y)

                    4                            2       9
 - 144*cos(x)*sin(x) *sin(y) + 3072*cos(x)*sin(x) *sin(y)

                     2       7                     2       5
 - 6912*cos(x)*sin(x) *sin(y)  + 5184*cos(x)*sin(x) *sin(y)

                     2       3                    2                           9
 - 1440*cos(x)*sin(x) *sin(y)  + 108*cos(x)*sin(x) *sin(y) - 256*cos(x)*sin(y)

                    7                    5                    3
 + 576*cos(x)*sin(y)  - 432*cos(x)*sin(y)  + 120*cos(x)*sin(y)

                                       5       8                     5       6
 - 9*cos(x)*sin(y) + 4096*cos(y)*sin(x) *sin(y)  - 7168*cos(y)*sin(x) *sin(y)

                     5       4                    5       2                   5
 + 3840*cos(y)*sin(x) *sin(y)  - 640*cos(y)*sin(x) *sin(y)  + 16*cos(y)*sin(x)

                     3       8                     3       6
 - 5120*cos(y)*sin(x) *sin(y)  + 8960*cos(y)*sin(x) *sin(y)

                     3       4                    3       2                   3
 - 4800*cos(y)*sin(x) *sin(y)  + 800*cos(y)*sin(x) *sin(y)  - 20*cos(y)*sin(x)

                            8                            6
 + 1280*cos(y)*sin(x)*sin(y)  - 2240*cos(y)*sin(x)*sin(y)

                            4                           2
 + 1200*cos(y)*sin(x)*sin(y)  - 200*cos(y)*sin(x)*sin(y)  + 5*cos(y)*sin(x)

trigsimp(ws,combine);


sin(5*x - 9*y)

trigsimp(cos(10x),cos);


          10              8              6             4            2
512*cos(x)   - 1280*cos(x)  + 1120*cos(x)  - 400*cos(x)  + 50*cos(x)  - 1

trigsimp(cos(10x),sin);


             10              8              6             4            2
 - 512*sin(x)   + 1280*sin(x)  - 1120*sin(x)  + 400*sin(x)  - 50*sin(x)  + 1

trigsimp((sin(x-a)+sin(x+a))/(cos(x-a) + cos(x+a)));


 sin(x)
--------
 cos(x)

trigsimp(cos(6x+4y),sin);


                        5       3                           5
256*cos(x)*cos(y)*sin(x) *sin(y)  - 128*cos(x)*cos(y)*sin(x) *sin(y)

                           3       3                           3
 - 256*cos(x)*cos(y)*sin(x) *sin(y)  + 128*cos(x)*cos(y)*sin(x) *sin(y)

                                 3
 + 48*cos(x)*cos(y)*sin(x)*sin(y)  - 24*cos(x)*cos(y)*sin(x)*sin(y)

             6       4             6       2            6             4       4
 - 256*sin(x) *sin(y)  + 256*sin(x) *sin(y)  - 32*sin(x)  + 384*sin(x) *sin(y)

             4       2            4             2       4             2       2
 - 384*sin(x) *sin(y)  + 48*sin(x)  - 144*sin(x) *sin(y)  + 144*sin(x) *sin(y)

            2           4           2
 - 18*sin(x)  + 8*sin(y)  - 8*sin(y)  + 1

trigsimp(ws,expon);


  12*i*x + 8*i*y
 e               + 1
---------------------
     6*i*x + 4*i*y
  2*e

trigsimp(ws,hyp);


                                 5          3
256*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    5
 + 128*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    3          3
 + 256*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                    3
 + 128*cosh(i*x)*cosh(i*y)*sinh(i*x) *sinh(i*y)

                                             3
 + 48*cosh(i*x)*cosh(i*y)*sinh(i*x)*sinh(i*y)

                                                             6          4
 + 24*cosh(i*x)*cosh(i*y)*sinh(i*x)*sinh(i*y) + 256*sinh(i*x) *sinh(i*y)

                6          2               6                4          4
 + 256*sinh(i*x) *sinh(i*y)  + 32*sinh(i*x)  + 384*sinh(i*x) *sinh(i*y)

                4          2               4                2          4
 + 384*sinh(i*x) *sinh(i*y)  + 48*sinh(i*x)  + 144*sinh(i*x) *sinh(i*y)

                2          2               2              4              2
 + 144*sinh(i*x) *sinh(i*y)  + 18*sinh(i*x)  + 8*sinh(i*y)  + 8*sinh(i*y)  + 1

trigsimp(ws,combine);


cosh(6*i*x + 4*i*y)

trigsimp(ws,trig,combine);


cos(6*x + 4*y)

trigsimp(sqrt(1-cos(2x)));


sqrt(2)*abs(sin(x))

trigsimp(sin(x)**20*cos(x)**20,sin);


      20        20            18            16             14             12
sin(x)  *(sin(x)   - 10*sin(x)   + 45*sin(x)   - 120*sin(x)   + 210*sin(x)

                       10             8             6            4            2
           - 252*sin(x)   + 210*sin(x)  - 120*sin(x)  + 45*sin(x)  - 10*sin(x)

           + 1)

trigsimp(sin(x)**20*cos(x)**20,cos);


      20        20            18            16             14             12
cos(x)  *(cos(x)   - 10*cos(x)   + 45*cos(x)   - 120*cos(x)   + 210*cos(x)

                       10             8             6            4            2
           - 252*cos(x)   + 210*cos(x)  - 120*cos(x)  + 45*cos(x)  - 10*cos(x)

           + 1)

trigsimp(sin(x)**20*cos(x)**20,compact);


      20       20
cos(x)  *sin(x)

trigsimp(sin(x)**10,combine);


  - cos(10*x) + 10*cos(8*x) - 45*cos(6*x) + 120*cos(4*x) - 210*cos(2*x) + 126
------------------------------------------------------------------------------
                                     512

trigsimp(ws,hyp);


            10
 - sinh(i*x)

trigsimp(ws,expon);


     20*i*x       18*i*x       16*i*x        14*i*x        12*i*x        10*i*x
( - e       + 10*e       - 45*e       + 120*e       - 210*e       + 252*e

         8*i*x        6*i*x       4*i*x       2*i*x             10*i*x
  - 210*e      + 120*e      - 45*e      + 10*e      - 1)/(1024*e      )

trigsimp(ws,trig);


      10
sin(x)

int(sin(x+y)*cos(x-y)*tan(x),x);


int(cos(x - y)*sin(x + y)*tan(x),x)

int(trigsimp(sin(x+y)*cos(x-y)*tan(x)),x);


       2                                                         2
 cos(x) *x - cos(x)*sin(x) - 2*cos(y)*log(cos(x))*sin(y) + sin(x) *x
---------------------------------------------------------------------
                                  2

% int(sin(x+y)*cos(x-y)/tan(x),x) hangs
int(trigsimp(sin(x+y)*cos(x-y)/tan(x)),x);


                                   x  2
(cos(x)*sin(x) - 2*cos(y)*log(tan(---)  + 1)*sin(y)
                                   2

                      x
  + 2*cos(y)*log(tan(---))*sin(y) + x)/2
                      2

trigsimp(2*tan(x)*(sec(x)**2 - tan(x)**2 - 1));


0

df(sqrt(1+cos(x)),x,4);


                              4            2       2            2
(sqrt(cos(x) + 1)*( - 4*cos(x)  - 20*cos(x) *sin(x)  + 12*cos(x)

                      2                       4            2
     - 4*cos(x)*sin(x)  + 8*cos(x) - 15*sin(x)  + 16*sin(x) ))/(16

           4           3           2
   *(cos(x)  + 4*cos(x)  + 6*cos(x)  + 4*cos(x) + 1))

trigsimp(ws);


 sqrt(cos(x) + 1)
------------------
        16

df(2cos((x+y)/2)*cos((x-y)/2),x);


         x - y        x + y          x + y        x - y
 - (cos(-------)*sin(-------) + cos(-------)*sin(-------))
           2            2              2            2

trigsimp(ws,combine);


 - sin(x)

df(int(1/cos(x),x),x);


          x  2
  - (tan(---)  + 1)
          2
--------------------
        x  2
   tan(---)  - 1
        2

trigsimp(ws,combine);


   1
--------
 cos(x)

trigsimp(cos(100x));


                                     100
633825300114114700748351602688*sin(x)

                                          98
 - 15845632502852867518708790067200*sin(x)

                                           96
 + 192128294097091018664344079564800*sin(x)

                                            94
 - 1505335087771022414277335056384000*sin(x)

                                            92
 + 8567473526884295537508113973248000*sin(x)

                                             90
 - 37750993877408064336851542202122240*sin(x)

                                              88
 + 134036108580690866727917044786790400*sin(x)

                                              86
 - 394078512785625681900511864396185600*sin(x)

                                              84
 + 978503372439851812055958467641344000*sin(x)

                                               82
 - 2082455895192505138478065456775168000*sin(x)

                                               80
 + 3842131126630171980492030767750184960*sin(x)

                                               78
 - 6200783636440931286187342812099379200*sin(x)

                                               76
 + 8816739233064449172547628060953804800*sin(x)

                                                74
 - 11108623702136905456127648087408640000*sin(x)

                                                72
 + 12460295938318846194767764735918080000*sin(x)

                                                70
 - 12489614281703125832873100652943769600*sin(x)

                                                68
 + 11221137831217652115471926367879168000*sin(x)

                                               66
 - 9058026923994972189597820080095232000*sin(x)

                                               64
 + 6581798018959761296303294062264320000*sin(x)

                                               62
 - 4310885252184171141438414824407040000*sin(x)

                                               60
 + 2547463753712583633893763260298035200*sin(x)

                                               58
 - 1358954443662228159129584379363328000*sin(x)

                                              56
 + 654531379770880870350000868032512000*sin(x)

                                              54
 - 284578860769948204500000377405440000*sin(x)

                                              52
 + 111631674825053695350740279623680000*sin(x)

                                             50
 - 39472960218138986676021762874933248*sin(x)

                                             48
 + 12566106098549963273941439584665600*sin(x)

                                            46
 - 3595780740528756614156758967910400*sin(x)

                                           44
 + 923024074019658505866132324352000*sin(x)

                                           42
 - 212040013118649088525828358144000*sin(x)

                                          40
 + 43468202689323063147794813419520*sin(x)

                                         38
 - 7925478751208973645460484915200*sin(x)

                                         36
 + 1280241627320751027747867852800*sin(x)

                                        34
 - 182395347175955031090266112000*sin(x)

                                       32
 + 22799418396994378886283264000*sin(x)

                                      30                                     28
 - 2485387148331694929142087680*sin(x)   + 234623135747458180159897600*sin(x)

                                    26                                   24
 - 19023497493037149742694400*sin(x)   + 1312104559685287280640000*sin(x)

                                 22                                20
 - 76111992112891822080000*sin(x)   + 3662889620432918937600*sin(x)

                               18                             16
 - 143850563845029888000*sin(x)   + 4517474603507712000*sin(x)

                            14                          12
 - 110586893598720000*sin(x)   + 2042087523840000*sin(x)

                        10                      8                    6
 - 27227833651200*sin(x)   + 246628928000*sin(x)  - 1386112000*sin(x)

                 4              2
 + 4165000*sin(x)  - 5000*sin(x)  + 1

trigsimp(ws,combine);


cos(100*x)

trigsimp(sinh(3a+4b-5c)*cosh(3a-5b-6c));


                                     5        10
16384*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        5        8
 + 36864*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        5        6
 + 28672*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                       5        4
 + 8960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                      5        2
 + 960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                     5
 + 16*cosh(a)*cosh(b)*cosh(c)*sinh(a)

                                        3        10
 + 16384*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        3        8
 + 36864*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                        3        6
 + 28672*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                       3        4
 + 8960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                      3        2
 + 960*cosh(a)*cosh(b)*cosh(c)*sinh(a) *sinh(c)

                                     3
 + 16*cosh(a)*cosh(b)*cosh(c)*sinh(a)

                                               10
 + 3072*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               8
 + 6912*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               6
 + 5376*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                               4
 + 1680*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                              2
 + 180*cosh(a)*cosh(b)*cosh(c)*sinh(a)*sinh(c)

                                                            5                11
 + 3*cosh(a)*cosh(b)*cosh(c)*sinh(a) + 16384*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                9
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                7
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        5                5
 + 19712*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                       5                3                      5
 + 3520*cosh(a)*sinh(a) *sinh(b)*sinh(c)  + 176*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                11
 + 16384*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                9
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                7
 + 45056*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                        3                5
 + 19712*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                       3                3                      3
 + 3520*cosh(a)*sinh(a) *sinh(b)*sinh(c)  + 176*cosh(a)*sinh(a) *sinh(b)*sinh(c)

                                       11
 + 3072*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                       9                                       7
 + 8448*cosh(a)*sinh(a)*sinh(b)*sinh(c)  + 8448*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                       5                                      3
 + 3696*cosh(a)*sinh(a)*sinh(b)*sinh(c)  + 660*cosh(a)*sinh(a)*sinh(b)*sinh(c)

                                                             6        11
 + 33*cosh(a)*sinh(a)*sinh(b)*sinh(c) - 16384*cosh(b)*sinh(a) *sinh(c)

                        6        9                        6        7
 - 45056*cosh(b)*sinh(a) *sinh(c)  - 45056*cosh(b)*sinh(a) *sinh(c)

                        6        5                       6        3
 - 19712*cosh(b)*sinh(a) *sinh(c)  - 3520*cosh(b)*sinh(a) *sinh(c)

                      6                                4        11
 - 176*cosh(b)*sinh(a) *sinh(c) - 24576*cosh(b)*sinh(a) *sinh(c)

                        4        9                        4        7
 - 67584*cosh(b)*sinh(a) *sinh(c)  - 67584*cosh(b)*sinh(a) *sinh(c)

                        4        5                       4        3
 - 29568*cosh(b)*sinh(a) *sinh(c)  - 5280*cosh(b)*sinh(a) *sinh(c)

                      4                               2        11
 - 264*cosh(b)*sinh(a) *sinh(c) - 9216*cosh(b)*sinh(a) *sinh(c)

                        2        9                        2        7
 - 25344*cosh(b)*sinh(a) *sinh(c)  - 25344*cosh(b)*sinh(a) *sinh(c)

                        2        5                       2        3
 - 11088*cosh(b)*sinh(a) *sinh(c)  - 1980*cosh(b)*sinh(a) *sinh(c)

                     2                              8
 - 99*cosh(b)*sinh(a) *sinh(c) + 128*cosh(b)*sinh(b) *sinh(c)

                      6                              4
 + 224*cosh(b)*sinh(b) *sinh(c) + 120*cosh(b)*sinh(b) *sinh(c)

                     2                              11                       9
 + 20*cosh(b)*sinh(b) *sinh(c) - 512*cosh(b)*sinh(c)   - 1408*cosh(b)*sinh(c)

                       7                      5                      3
 - 1408*cosh(b)*sinh(c)  - 616*cosh(b)*sinh(c)  - 110*cosh(b)*sinh(c)

                                            6                10
 - 5*cosh(b)*sinh(c) - 16384*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        6                8
 - 36864*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        6                6
 - 28672*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       6                4
 - 8960*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                      6                2                     6
 - 960*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 16*cosh(c)*sinh(a) *sinh(b)

                        4                10
 - 24576*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                8
 - 55296*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                6
 - 43008*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        4                4
 - 13440*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       4                2                     4
 - 1440*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 24*cosh(c)*sinh(a) *sinh(b)

                       2                10
 - 9216*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        2                8
 - 20736*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                        2                6
 - 16128*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                       2                4
 - 5040*cosh(c)*sinh(a) *sinh(b)*sinh(c)

                      2                2                    2
 - 540*cosh(c)*sinh(a) *sinh(b)*sinh(c)  - 9*cosh(c)*sinh(a) *sinh(b)

                      9                      7                      5
 + 128*cosh(c)*sinh(b)  + 288*cosh(c)*sinh(b)  + 216*cosh(c)*sinh(b)

                     3                              10
 + 60*cosh(c)*sinh(b)  - 512*cosh(c)*sinh(b)*sinh(c)

                               8                              6
 - 1152*cosh(c)*sinh(b)*sinh(c)  - 896*cosh(c)*sinh(b)*sinh(c)

                              4                             2
 - 280*cosh(c)*sinh(b)*sinh(c)  - 30*cosh(c)*sinh(b)*sinh(c)

 + 4*cosh(c)*sinh(b)

trigsimp(ws,combine);


 sinh(9*b + c) + sinh(6*a - b - 11*c)
--------------------------------------
                  2

trigsimp(sec(20x-y),keepalltrig);


       20              20                20                   19
(csc(x)  *csc(y)*sec(x)  *sec(y))/(csc(x)  *csc(y) + 20*csc(x)  *sec(x)*sec(y)

                18              2              17       3
    - 190*csc(x)  *csc(y)*sec(x)  - 1140*csc(x)  *sec(x) *sec(y)

                 16              4               15       5
    + 4845*csc(x)  *csc(y)*sec(x)  + 15504*csc(x)  *sec(x) *sec(y)

                  14              6               13       7
    - 38760*csc(x)  *csc(y)*sec(x)  - 77520*csc(x)  *sec(x) *sec(y)

                   12              8                11       9
    + 125970*csc(x)  *csc(y)*sec(x)  + 167960*csc(x)  *sec(x) *sec(y)

                   10              10                9       11
    - 184756*csc(x)  *csc(y)*sec(x)   - 167960*csc(x) *sec(x)  *sec(y)

                   8              12               7       13
    + 125970*csc(x) *csc(y)*sec(x)   + 77520*csc(x) *sec(x)  *sec(y)

                  6              14               5       15
    - 38760*csc(x) *csc(y)*sec(x)   - 15504*csc(x) *sec(x)  *sec(y)

                 4              16              3       17
    + 4845*csc(x) *csc(y)*sec(x)   + 1140*csc(x) *sec(x)  *sec(y)

                2              18                   19                       20
    - 190*csc(x) *csc(y)*sec(x)   - 20*csc(x)*sec(x)  *sec(y) + csc(y)*sec(x)  )

trigsimp(csc(10a-9b),keepalltrig);


          10       9       10       9           10       8
( - csc(a)  *csc(b) *sec(a)  *sec(b) )/(9*csc(a)  *csc(b) *sec(b)

               10       6       3             10       4       5
    - 84*csc(a)  *csc(b) *sec(b)  + 126*csc(a)  *csc(b) *sec(b)

               10       2       7         10       9            9       9
    - 36*csc(a)  *csc(b) *sec(b)  + csc(a)  *sec(b)  - 10*csc(a) *csc(b) *sec(a)

                9       7              2              9       5              4
    + 360*csc(a) *csc(b) *sec(a)*sec(b)  - 1260*csc(a) *csc(b) *sec(a)*sec(b)

                9       3              6            9                     8
    + 840*csc(a) *csc(b) *sec(a)*sec(b)  - 90*csc(a) *csc(b)*sec(a)*sec(b)

                8       8       2                     8       6       2       3
    - 405*csc(a) *csc(b) *sec(a) *sec(b) + 3780*csc(a) *csc(b) *sec(a) *sec(b)

                 8       4       2       5
    - 5670*csc(a) *csc(b) *sec(a) *sec(b)

                 8       2       2       7            8       2       9
    + 1620*csc(a) *csc(b) *sec(a) *sec(b)  - 45*csc(a) *sec(a) *sec(b)

                7       9       3              7       7       3       2
    + 120*csc(a) *csc(b) *sec(a)  - 4320*csc(a) *csc(b) *sec(a) *sec(b)

                  7       5       3       4
    + 15120*csc(a) *csc(b) *sec(a) *sec(b)

                  7       3       3       6
    - 10080*csc(a) *csc(b) *sec(a) *sec(b)

                 7              3       8              6       8       4
    + 1080*csc(a) *csc(b)*sec(a) *sec(b)  + 1890*csc(a) *csc(b) *sec(a) *sec(b)

                  6       6       4       3
    - 17640*csc(a) *csc(b) *sec(a) *sec(b)

                  6       4       4       5
    + 26460*csc(a) *csc(b) *sec(a) *sec(b)

                 6       2       4       7             6       4       9
    - 7560*csc(a) *csc(b) *sec(a) *sec(b)  + 210*csc(a) *sec(a) *sec(b)

                5       9       5              5       7       5       2
    - 252*csc(a) *csc(b) *sec(a)  + 9072*csc(a) *csc(b) *sec(a) *sec(b)

                  5       5       5       4
    - 31752*csc(a) *csc(b) *sec(a) *sec(b)

                  5       3       5       6
    + 21168*csc(a) *csc(b) *sec(a) *sec(b)

                 5              5       8              4       8       6
    - 2268*csc(a) *csc(b)*sec(a) *sec(b)  - 1890*csc(a) *csc(b) *sec(a) *sec(b)

                  4       6       6       3
    + 17640*csc(a) *csc(b) *sec(a) *sec(b)

                  4       4       6       5
    - 26460*csc(a) *csc(b) *sec(a) *sec(b)

                 4       2       6       7             4       6       9
    + 7560*csc(a) *csc(b) *sec(a) *sec(b)  - 210*csc(a) *sec(a) *sec(b)

                3       9       7              3       7       7       2
    + 120*csc(a) *csc(b) *sec(a)  - 4320*csc(a) *csc(b) *sec(a) *sec(b)

                  3       5       7       4
    + 15120*csc(a) *csc(b) *sec(a) *sec(b)

                  3       3       7       6
    - 10080*csc(a) *csc(b) *sec(a) *sec(b)

                 3              7       8             2       8       8
    + 1080*csc(a) *csc(b)*sec(a) *sec(b)  + 405*csc(a) *csc(b) *sec(a) *sec(b)

                 2       6       8       3
    - 3780*csc(a) *csc(b) *sec(a) *sec(b)

                 2       4       8       5
    + 5670*csc(a) *csc(b) *sec(a) *sec(b)

                 2       2       8       7            2       8       9
    - 1620*csc(a) *csc(b) *sec(a) *sec(b)  + 45*csc(a) *sec(a) *sec(b)

                      9       9                    7       9       2
    - 10*csc(a)*csc(b) *sec(a)  + 360*csc(a)*csc(b) *sec(a) *sec(b)

                        5       9       4                    3       9       6
    - 1260*csc(a)*csc(b) *sec(a) *sec(b)  + 840*csc(a)*csc(b) *sec(a) *sec(b)

                             9       8           8       10
    - 90*csc(a)*csc(b)*sec(a) *sec(b)  - 9*csc(b) *sec(a)  *sec(b)

               6       10       3             4       10       5
    + 84*csc(b) *sec(a)  *sec(b)  - 126*csc(b) *sec(a)  *sec(b)

               2       10       7         10       9
    + 36*csc(b) *sec(a)  *sec(b)  - sec(a)  *sec(b) )

trigsimp(ws,combine);


             2*cos(a)
----------------------------------
 sin(11*a - 9*b) + sin(9*a - 9*b)

trigsimp(cosh(50*acosh(x))-cos(50*acos(x)));


0

trigsimp(cos(n*acos(x))-cosh(n*acosh(x)),trig);


0

trigsimp((2*tan(log(x))*(sec(log(x))**2 - tan(log(x))**2 - 1))/x);


0

trigsimp(sech(10x),keepalltrig);


        10        10          10             8        2              6        4
(csch(x)  *sech(x)  )/(csch(x)   + 45*csch(x) *sech(x)  + 210*csch(x) *sech(x)

                 4        6             2        8          10
    + 210*csch(x) *sech(x)  + 45*csch(x) *sech(x)  + sech(x)  )

trigsimp(ws,combine);


     1
------------
 cosh(10*x)

trigsimp(csch(3x-5y),keepalltrig);


           3        5        3        5            3        4
( - csch(x) *csch(y) *sech(x) *sech(y) )/(5*csch(x) *csch(y) *sech(y)

                3        2        3          3        5
    + 10*csch(x) *csch(y) *sech(y)  + csch(x) *sech(y)

               2        5                     2        3                2
    - 3*csch(x) *csch(y) *sech(x) - 30*csch(x) *csch(y) *sech(x)*sech(y)

                2                        4
    - 15*csch(x) *csch(y)*sech(x)*sech(y)

                        4        2
    + 15*csch(x)*csch(y) *sech(x) *sech(y)

                        2        2        3                    2        5
    + 30*csch(x)*csch(y) *sech(x) *sech(y)  + 3*csch(x)*sech(x) *sech(y)

             5        3             3        3        2
    - csch(y) *sech(x)  - 10*csch(y) *sech(x) *sech(y)

                       3        4
    - 5*csch(y)*sech(x) *sech(y) )

trigsimp(ws,combine);


        1
-----------------
 sinh(3*x - 5*y)

off precise;


trigsimp((sinh(x)+cosh(x))**n+(cosh(x)-sinh(x))**n,expon);


  2*n*x
 e      + 1
------------
     n*x
    e

on precise;


trigsimp(ws,hyp);


2*cosh(n*x)

load taylor;


taylor(sin(x+a)*cos(x+b),x,0,4);


cos(b)*sin(a) + (cos(a)*cos(b) - sin(a)*sin(b))*x

                                    2
 - (cos(a)*sin(b) + cos(b)*sin(a))*x

    2*( - cos(a)*cos(b) + sin(a)*sin(b))   3
 + --------------------------------------*x
                     3

    cos(a)*sin(b) + cos(b)*sin(a)   4      5
 + -------------------------------*x  + O(x )
                  3

trigsimp(ws,combine);


 sin(a - b) + sin(a + b)                               2    2*cos(a + b)   3
------------------------- + cos(a + b)*x - sin(a + b)*x  - --------------*x
            2                                                    3

    sin(a + b)   4      5
 + ------------*x  + O(x )
        3

%----------------------trigfactorize------------------------
trigfactorize(sin(x)**2,x);


{sin(x),sin(x)}

trigfactorize(1+cos(x),x);


{cos(x) + 1}

trigfactorize(1+cos(x),x/2);


        x        x
{2,cos(---),cos(---)}
        2        2

trigfactorize(1+cos(x),x/6);


{2,

           x  2
  - 4*sin(---)  + 1,
           6

           x  2
  - 4*sin(---)  + 1,
           6

      x
 cos(---),
      6

      x
 cos(---)}
      6

trigfactorize(sin(x)*(1-cos(x)),x);


{sin(x)*( - cos(x) + 1)}

trigfactorize(sin(x)*(1-cos(x)),x/2);


{4,

      x
 cos(---),
      2

      x
 sin(---),
      2

      x
 sin(---),
      2

      x
 sin(---)}
      2

trigfactorize(tan(x),x);


{tan(x)}

trigfactorize(sin(x*3),x);


            2
{ - 4*sin(x)  + 3,sin(x)}

trigfactorize(sin(4x)-1,x);


{-1,

                           2
 2*cos(x)*sin(x) + 2*sin(x)  - 1,

                           2
 2*cos(x)*sin(x) + 2*sin(x)  - 1}

trigfactorize(sin(x)**4-1,x);


           2
{ - (sin(x)  + 1),cos(x),cos(x)}

trigfactorize(cos(x)**4-1,x);


             2
{-1, - sin(x)  + 2,sin(x),sin(x)}

trigfactorize(sin(x)**10-cos(x)**6,x);


{-1,

              2                  5
 cos(x)*sin(x)  - cos(x) - sin(x) ,

              2                  5
 cos(x)*sin(x)  - cos(x) + sin(x) }

trigfactorize(sin(x)*cos(y),x);


{cos(y),sin(x)}

trigfactorize(sin(2x)*cos(y)**2,y/2);


{2*cos(x)*sin(x),

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) + sin(---),
      2          2

      y          y
 cos(---) - sin(---),
      2          2

      y          y
 cos(---) - sin(---)}
      2          2

trigfactorize(sin(y)**4-x**2,y);


          2               2
{ - sin(y)  + x, - (sin(y)  + x)}

trigfactorize(sin(x),x+1);


***** error using trigfactorize, basis not possible 

trigfactorize(sin(x),2x);


***** error using trigfactorize, basis not possible 

trigfactorize(sin(x)*cosh(x),x/2);


{2,

      x
 cos(---),
      2

      x
 sin(---),
      2

       x             x
 cosh(---) - i*sinh(---),
       2             2

       x             x
 cosh(---) + i*sinh(---)}
       2             2

trigfactorize(1+cos(2x)+2cos(x)*cosh(x),x/2);


{4,

      x         x            x         x
 cos(---)*cosh(---) + i*sin(---)*sinh(---),
      2         2            2         2

      x         x            x         x
 cos(---)*cosh(---) - i*sin(---)*sinh(---),
      2         2            2         2

      x          x
 cos(---) + sin(---),
      2          2

      x          x
 cos(---) - sin(---)}
      2          2

%------------------------gcd---------------------------------
triggcd(sin(x),cos(x),x);


1

triggcd(1-cos(x)**2,sin(x)**2,x);


         2
 - sin(x)

triggcd(sin(x)**4-1,cos(x)**2,x);


         2
 - sin(x)  + 1

triggcd(sin(5x+1),cos(x),x);


1

triggcd(1-cos(2x),sin(2x),x);


sin(x)

triggcd(-5+cos(2x)-6sin(x),-7+cos(2x)-8sin(x),x/2);


       x        x
2*cos(---)*sin(---) + 1
       2        2

triggcd(1-2cosh(x)+cosh(2x),1+2cosh(x)+cosh(2x),x/2);


        x  2
2*sinh(---)  + 1
        2

triggcd(1+cos(2x)+2cos(x)*cosh(x),1+2cos(x)*cosh(x)+cosh(2x),x/2);


        x  2         x  2
 - sin(---)  + sinh(---)  + 1
        2            2

triggcd(-1+2*a*b+cos(2x)-2*a*sin(x)+2*b*sin(x),-1-2*a*b+cos(2x)-2*a*sin(x)
-2*b*sin(x),x/2);


       x        x
2*cos(---)*sin(---) + a
       2        2

triggcd(sin(x)**10-1,cos(x),x);


cos(x)

triggcd(sin(5*x) + sin(3*x),cos(x),x);


cos(x)

triggcd(sin(3x)+sin(5x),sin(5x)+sin(7x),x);


              2
sin(x)*(sin(x)  - 1)


end;

5: 5: 5: 5: 5: 5: 5: 5: 5: 

Time for test: 81520 ms, plus GC time: 5790 ms

6: 6: 
Quitting
Fri Jul 21 09:25:53 PDT 1995
mathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/0000755000175000017500000000000011722677364022371 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/mrvlimit.rlg0000644000175000017500000001315211527635055024736 0ustar  giovannigiovanniFri Feb 18 21:28:38 2011 run on win32
off exp;

 off mcd;


mrv_limit(e^x,x,infinity);


infinity


ex:=log(log(x)+log(log(x)))-log(log(x));


ex :=  - (log(log(x)) - log(log(log(x)) + log(x)))

ex:=ex/(log(log(x)+log(log(log(x)))));


ex := 

                                                                           -1
 - (log(log(x)) - log(log(log(x)) + log(x)))*log(log(log(log(x))) + log(x))

ex:=ex*log(x);


ex :=  - (log(log(x)) - log(log(log(x)) + log(x)))

                                     -1
      *log(log(log(log(x))) + log(x))  *log(x)


mrv_limit(e^-x,x,infinity);


0


mrv_limit(log(x),x,infinity);


infinity


mrv_limit(1/log(x),x,infinity);


0


a:=e^(1/x-e^-x)-e^(1/x);


       -1        - x
      x      - e
a := e   *(e         - 1)

a:=a/e^(-x);


           -1        - x
      x + x      - e
a := e       *(e         - 1)

 
mrv_limit(a,x,infinity) ;


-1
          % all of these are correct
mrv_limit(e^-x,x,infinity) ;


0

mrv_limit(log(x),x,infinity) ;


infinity

mrv_limit(1/log(x),x,infinity) ;


0


a:=e^(1/x-e^-x)-e^(1/x);


       -1        - x
      x      - e
a := e   *(e         - 1)

a:=a/e^(-x);


           -1        - x
      x + x      - e
a := e       *(e         - 1)

b:=e^x*(e^(1/x-e^-x)-e^(1/x));


           -1        - x
      x + x      - e
b := e       *(e         - 1)


%c:=e^x*(e^(1/x+e^(-x)+e^(-x^2))-e^(1/x-e^(-e^x)))
maxi1({e^(-x^2)},{e^x});


      2
   - x
{e     }


cc:= e^(log(log(x+e^(log(x)*log(log(x)))))/log(log(log(e^x+x+log(x)))));


                                 x   -1               log(x)
       log(log(log(log(x) + x + e )))  *log(log(log(x)       + x))
cc := e

 
b:=e^x*(e^(1/x-e^-x)-e^(1/x));


           -1        - x
      x + x      - e
b := e       *(e         - 1)


c:=e^x*(e^(1/x+e^(-x)+e^(-x^2))-e^(1/x-e^(-e^x)));


                           x         2
              -1        - e       - x      - x
         x + x      - e         e      + e
c :=  - e       *(e          - e              )


e^(log(log(x+e^(log(x)*log(log(x)))))/(log(log(log(e^x+x+log(x))))));


                           x   -1               log(x)
 log(log(log(log(x) + x + e )))  *log(log(log(x)       + x))
e


%% mrv_limit(ws,x,infinity);

aa:=e^(e^(e^x));


         x
        e
       e
aa := e

bb:=e^(e^(e^(x-e^(-e^x))));


                 x
              - e
          - e      + x
        e
       e
bb := e

ex1:=(e^x)*(e^((1/x)-e^(-x))-e^(1/x));


             -1        - x
        x + x      - e
ex1 := e       *(e         - 1)
  % returns -1 correct

ex2:=(e^x)*(e^((1/x)-e^(-x)-e^(-x^2))-e^((1/x)-e^(-e^x)));


                             x            2
                -1        - e          - x      - x
           x + x      - e          - e      - e
ex2 :=  - e       *(e          - e                 )
 % returns infinity

ex3:=e^(e^(x-e^-x)/(1-1/x))-e^(e^x);


                           - x
             x         - e     + x   -1     -1
            e      - e            *(x   - 1)
ex3 :=  - (e   - e                            )
 % returns - infinity

ex4:=e^(e^((e^x)/(1-1/x)))-e^(e^((e^x)/(1-1/x-(log(x))^(-log(x)))));


                 x         - log(x)    -1     -1         x   -1     -1
              - e *(log(x)          + x   - 1)        - e *(x   - 1)
            e                                       e
ex4 :=  - (e                                     - e                  )


ex5:=(e^(e^(e^(x+e^-x))))/(e^(e^(e^x)));


            - x
          e     + x     x
         e             e
        e           - e
ex5 := e


ex6:=(e^(e^(e^x)))/(e^(e^(e^(x-e^(-e^x)))));


                     x
                  - e
              - e      + x     x
            e                 e
         - e               + e
ex6 := e
   

ex7:=(e^(e^(e^x)))/(e^(e^(e^(x-e^(e^x)))));


                  x
                 e
              - e   + x     x
            e              e
         - e            + e
ex7 := e
       

ex8:=(e^(e^x))/(e^(e^(x-e^(-e^(e^x)))));


                     x
                    e
                 - e
             - e       + x    x
         - e               + e
ex8 := e


ex9:=((log(x)^2)*e^(sqrt(log(x))*((log(log(x)))^2)*e^((sqrt(log(log(x))))*(log(log(log(x)))^3))))/sqrt(x);


ex9 := 

                                            3
          sqrt(log(log(x)))*log(log(log(x)))                          2
  - 1/2  e                                   *sqrt(log(x))*log(log(x))        2
x      *e                                                              *log(x)


ex10:=((x*log(x))*(log(x*e^x-x^2))^2)/(log(log(x^2+2*e^(3*x^3*log(x)))));


                      3
                   3*x     2  -1       x        2
ex10 := log(log(2*x     + x ))  *log((e  - x)*x) *log(x)*x


misc1:=1/(e^(-x+e^-x))-e^x;


                   - x
          x    - e
misc1 := e *(e         - 1)
 % returns -1 correct

misc2:=(e^(1/x-e^-x)-e^(1/x))/(e^-x);


               -1        - x
          x + x      - e
misc2 := e       *(e         - 1)
 % returns -1 correct

misc3:=e^(-log(x+e^-x));


            - x     -1
misc3 := (e     + x)
 % returns 0 correct

misc4:=e^(x-e^x);


              x
           - e  + x
misc4 := e
 % returns 0 correct

% bb limit is infinity correct

mrv_limit(ex,x,infinity);


1
 %1

mrv_limit(ex1,x,infinity);


-1
 % -1

%% mrv_limit(ex2,x,infinity); % -1

%% mrv_limit(b,x,infinity); % -1

mrv_limit(a,x,infinity);


 - infinity
 

%% mrv_limit(ex3,x,infinity);

%% mrv_limit(ex4,x,infinity);

%% mrv_limit(ex5,x,infinity);  % 0

%% mrv_limit(ex6,x,infinity);

mrv_limit(misc1,x,infinity);


-1


mrv_limit(misc2,x,infinity);


 - infinity


mrv_limit(misc3,x,infinity);


0


mrv_limit(misc4,x,infinity);


0


end;


Time for test: 343 ms
@@@@@ Resources used: (0 6 60 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/mrvlimit.tst0000644000175000017500000000416211526203062024751 0ustar  giovannigiovannioff exp; off mcd;
mrv_limit(e^x,x,infinity);

ex:=log(log(x)+log(log(x)))-log(log(x));
ex:=ex/(log(log(x)+log(log(log(x)))));
ex:=ex*log(x);

mrv_limit(e^-x,x,infinity);

mrv_limit(log(x),x,infinity);

mrv_limit(1/log(x),x,infinity);

a:=e^(1/x-e^-x)-e^(1/x);
a:=a/e^(-x);
 
mrv_limit(a,x,infinity) ;          % all of these are correct
mrv_limit(e^-x,x,infinity) ;
mrv_limit(log(x),x,infinity) ;
mrv_limit(1/log(x),x,infinity) ;

a:=e^(1/x-e^-x)-e^(1/x);
a:=a/e^(-x);
b:=e^x*(e^(1/x-e^-x)-e^(1/x));

%c:=e^x*(e^(1/x+e^(-x)+e^(-x^2))-e^(1/x-e^(-e^x)))
maxi1({e^(-x^2)},{e^x});

cc:= e^(log(log(x+e^(log(x)*log(log(x)))))/log(log(log(e^x+x+log(x)))));
 
b:=e^x*(e^(1/x-e^-x)-e^(1/x));

c:=e^x*(e^(1/x+e^(-x)+e^(-x^2))-e^(1/x-e^(-e^x)));

e^(log(log(x+e^(log(x)*log(log(x)))))/(log(log(log(e^x+x+log(x))))));

%% mrv_limit(ws,x,infinity);

aa:=e^(e^(e^x));
bb:=e^(e^(e^(x-e^(-e^x))));
ex1:=(e^x)*(e^((1/x)-e^(-x))-e^(1/x));  % returns -1 correct

ex2:=(e^x)*(e^((1/x)-e^(-x)-e^(-x^2))-e^((1/x)-e^(-e^x))); % returns infinity

ex3:=e^(e^(x-e^-x)/(1-1/x))-e^(e^x); % returns - infinity

ex4:=e^(e^((e^x)/(1-1/x)))-e^(e^((e^x)/(1-1/x-(log(x))^(-log(x)))));

ex5:=(e^(e^(e^(x+e^-x))))/(e^(e^(e^x)));

ex6:=(e^(e^(e^x)))/(e^(e^(e^(x-e^(-e^x)))));   

ex7:=(e^(e^(e^x)))/(e^(e^(e^(x-e^(e^x)))));       

ex8:=(e^(e^x))/(e^(e^(x-e^(-e^(e^x)))));

ex9:=((log(x)^2)*e^(sqrt(log(x))*((log(log(x)))^2)*e^((sqrt(log(log(x))))*(log(log(log(x)))^3))))/sqrt(x);

ex10:=((x*log(x))*(log(x*e^x-x^2))^2)/(log(log(x^2+2*e^(3*x^3*log(x)))));

misc1:=1/(e^(-x+e^-x))-e^x; % returns -1 correct

misc2:=(e^(1/x-e^-x)-e^(1/x))/(e^-x); % returns -1 correct

misc3:=e^(-log(x+e^-x)); % returns 0 correct

misc4:=e^(x-e^x); % returns 0 correct

% bb limit is infinity correct

mrv_limit(ex,x,infinity); %1

mrv_limit(ex1,x,infinity); % -1

%% mrv_limit(ex2,x,infinity); % -1

%% mrv_limit(b,x,infinity); % -1

mrv_limit(a,x,infinity); 

%% mrv_limit(ex3,x,infinity);

%% mrv_limit(ex4,x,infinity);

%% mrv_limit(ex5,x,infinity);  % 0

%% mrv_limit(ex6,x,infinity);

mrv_limit(misc1,x,infinity);

mrv_limit(misc2,x,infinity);

mrv_limit(misc3,x,infinity);

mrv_limit(misc4,x,infinity);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/expon.red0000644000175000017500000003524611526203062024206 0ustar  giovannigiovanni %---------------------------------------------------------------------------
%
% these programs are written to sort the Taylor problem out; namely, the
% problem of extracting the leading exponent together with its sign from
% a taylor expression.
%
%----------------------------------------------------------------------------

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module expon;
load_package taylor;
algebraic;
expr procedure split(exp);
begin scalar temp,current,ans;
off mcd;
ans:={};
   if lisp(atom exp) then temp:={exp} else
   temp:=for k:=1:arglength(exp) collect part(exp,k); write "temp is ", temp;
   for k:=1:arglength(temp) do
   << current:=part(temp,k);
      if (lisp atom current) then
      << if(not freeof(current,ww)) then
               ans:=append(ans,{current}) else nil;
      >>
  else <<
    if(not freeof(current,expt)) then
          ans:=append(ans,{current}) else nil; >>;
   >>;

return ans;
end;


%load_package taylor;

expr procedure collect_power(li);
begin scalar ans;
on rational; on exp;
   ans:=for k:=1:length(li) collect lpower(part(li,k),ww);
return ans;
end;

%collect_power(split(1/2*(ww+x*ww^-1+2)));

expr procedure conv(li); % converts our list of powers to exponents
begin scalar ans,current;
ans:={};
  for k:=1:length(li) do
  <<
    current:=part(li,k); %write "current is ", current;
    if(lisp atom current) then << if(not freeof(current,ww))
             then ans:=append(ans,{1}) else nil; >>
    else <<
           if(part(current,0)=expt) then
           ans:=append(ans,{part(current,2)}) else nil;
          >>;
    >>;
return ans;
end;

%collect_power(split(1/2*(ww+x*ww^-1+2)));

%conv(ws);

%load_package assist;

expr procedure find_expt(exp);
begin scalar spli, coll, con, ans,ans2;
 %spli:=split(exp); %write "split is ", spli;
 coll:=collect_power(spli); write "collect is "; coll;
 con:=conv(coll); write "con is ", con;
 ans:=sortnumlist(con); write "ans is ", ans;
 ans2:=part(ans,1);
return ans2;
end;

% we get something like
% (expt(ww -1)
%--------------------------------------------------------------------------
symbolic procedure find(u);
begin
off mcd; off factor; off exp;
if(atom u) then
<<
 if(freeof(u,'ww)) then
        << if(numberp(u)) then return list('number,u) else
              <<
                if(u='e) then return list('number,'e) else return
                list('x_exp,u)
              >>;
         >>
 else return list('expt,'ww,1)
>>
else <<
if(car u='expt) then return list('expt, cadr u, caddr u)
else <<
           if(car u='plus) then
           <<
              if(atom cadr u and atom caddr u) then
              <<
                 if(length(cdr u)>2) then <<
                 if((cadr u='ww) and freeof(caddr u,'ww)) then
                 return
                 append({'expt,cadr u,1},find(append({'plus},cddr u))) else
                 return append(find(cadr u), append({'plus},cddr u))
                                           >>
                  else
                  <<   if(caddr u='ww) and freeof(cadr u,'ww) then
                             return list('x_exp,cadr u,'expt,'ww,1)
                       else <<
                        if(cadr u='ww and freeof(caddr u,'ww)) then
                return append({'expt,cadr u,1},find caddr u)
                      else return append(find(cadr u),find(caddr u))
                             >>
                   >>
                >>
            else <<
                if(atom cadr u and pairp caddr u) then
                   <<
                 if(length(cdr u)>2) then <<
                 if(cadr u='ww) then return
                   append({'expt,'ww,1},find(append({'plus},cddr u)))
                    else return
                append(find(cadr u),find(append({'plus},cddr u)))
                                          >>
                    else return append(find(cadr u),find(caddr u))
                     >>
                else <<
                 if(pairp cadr u and pairp caddr u) then
                 <<
                   if(length(cdr u)>2) then % plus has more than 2 args
                return append(find(cadr u),find(append({'plus},cddr u)))
                 else return
                  append(find(cadr u),find(caddr u))
                  >>
                       else <<
                  if(pairp cadr u and atom caddr u) then
                    <<
                     if(length(cdr u)>2) then %plus has more than two args
                      <<
                           if(caddr u='ww) then
                           <<
                             return find(cadr u).list('expt,'ww,1).
                             find(append({'plus},cddr u))
                            >>
                                 else <<
                                        if(numberp(caddr u)) then return
 find(cadr u).(list('number,caddr u).find(append({'plus},cdr u)))
      else nil
                                      >>

                         >>    else return
                               append(find(cadr u),find(caddr u))
                    >>
                    else return append(find(cadr u),{caddr u})
                                  >> % else nil % unneccesary ?
                               >>
                        >>
                    >>
          else <<
      if(car u='lminus) then
          <<
             if(numberp cadr u) then return list('number,u)
              else return find(cadr u)
           >>
      else <<
      if(car u='quotient) then <<
          if(numberp(cadr u) and numberp(caddr u)) then
                return list('number,cadr u, caddr u) else
                 return append(find(cadr u), find(caddr u))
                                >>
              else <<
                     if(car u='minus) then <<
                     if(atom cdr u) then return find(cadr u) else
                                     <<
                     if(cadr u='expt and caddr u='ww) then
        return append(append({'minus},find(cadr u)),find(caddr u))
          else return append({'minus},find(cadr u))
                                     >>
                                             >>

      else <<
      if(car u='times) then
              <<
                if(atom cadr u and atom caddr u) then
                 <<
                 if(not freeof(cadr u,'ww)) then return
                    list('expt,cadr u,1) else
                       << if(not freeof(caddr u,'ww)) then
                          return list(nil,caddr u) else nil
                        >>
                     >>
                  else <<
                          if(atom cadr u and pairp caddr u) then
                     <<
                        if(not freeof(cadr u,'ww)) then return
                        list('expt,cadr u,1) else return find(caddr u)
                             >>
                        else
                             << if(pairp cadr u and pairp caddr u) then
                                <<
                                if(length(cdr u))>2 then % times has +2 args
                                   return
                        append(find(cadr u),find(append({'times},cddr u)))
                        else return append(find(cadr u),find(caddr u))
                                 >>
                        else <<
                                if(pairp cadr u and atom caddr u) then
                                         <<
                               if(freeof(cadr u,'ww) and caddr u='ww) then
                                          return list('expt,'ww,1) else
                            return append(find(cadr u),find(caddr u))
                                          >> %else nil
                              >>

                              >>
                        >>
                 >>  %else return find(cdr u)
              >>
          >>
        >>
      >>
    >>
     >>% ;
end;

 algebraic;
algebraic procedure fin(u); lisp ('list.find(u));
%----------------------------------------------------------------------------
% input to this procedure is a list
% output is a list, containing all the exponents, marked expt, and any
% numbers, flagged number
% e.g.  ww^-1+ww^-2 +2
% apply fin yields  {expt,ww,-1,expt,ww,-2,number,2}
% now apply find_numbers to this gives
% {expt,-1,expt,-2,number,2}
% the presence of the number means that there is a power of ww^0 present,
% ie a constant term. If any of the expoents in the list are less than zero,
% then we require the lowest one; if they are all positive, then zero is the
% answer to be returned

expr procedure find_numbers(li);
begin scalar current,expt_list,ans,l,finished; % first, second, third;
off mcd; on rational; on exp;
li:=li;
expt_list:={}; ans:={};

   for k:=1:(length(li)-1) do <<
       current:=part(li,k);
       if(current=expt) then
        <<
       if(part(li,k+1)=ww) then
       expt_list:=append(expt_list,{expt,part(li,k+2)});
        >>
        else <<
        if(current=number) then
        expt_list:=append(expt_list,{number,part(li,k+1)}) else
                  <<
                if(current=x_expt) then
                expt_list:=append(expt_list,{x_part,part(li,k+1)})
                      else   <<
         if((current=lisp mk!*sq simp 'minus) and part(li,k+1)=expt) then
 expt_list:=append(expt_list,append({lisp reval 'minus},{expt,part(li,k+3)}));
              %else nil;
                         >>;
                    >>;
              >>;
                                >>;
 % there is no x terms or numbers in the series exp
return expt_list;
end;

%----------------------------------------------------------------------------
expr procedure find_least_expt(exp);
begin scalar ans,find, current,result,expt_list,expt_list2,num_list, x_list;
off mcd; % this causes a lot of problems when on, and some problems when off,
         % so I don't think I can win!!!

expt_list:={};
num_list:={};   % initialisations
x_list:={};

find:=fin(exp);
ans:=find_numbers(find);
if(lisp !*tracelimit) then write "exponent list is ", ans;
%ans:=delete_all(-x,ans);

if(freeof(ans,number)) then % there were no numbers in series exp, only
                            % exponents
<<
for k:=1:(arglength(ans)-1) do
   <<
      if(part(ans,k)=lisp mk!*sq simp 'minus) then
                <<
          if(numberp(part(ans,k+2)) and part(ans,k+2)<0) then
          expt_list:=append(expt_list,{lisp 'minus,part(ans,k+2)});
           %else     <<
           %      if(freeof(part(ans,k+2),x)) then
           %     expt_list:=append(expt_list,{minus,part(ans,k+2)});
           %          >>;
                 >>
          else <<
   if((part(ans,k)=expt) and part(ans,k-1) neq (lisp mk!*sq simp 'minus)) then
                  <<
                   if(numberp(part(ans,k+1))) then
                  expt_list:=append(expt_list,{part(ans,k+1)});
                   >>
                  else nil; >>;
    >>;
%ans:=sortnumlist(ans);
%result:=part(ans,1);
%write "got up to here OK";
>>
 else <<
     for k:=1:arglength(ans)-1 do
        <<
          current:=part(ans,k);
       if((current=expt)) then % and part(ans,k+1)=lisp mk!*sq simp 'ww) then
              <<
        if(freeof(part(ans,k+1),x)) then
        expt_list:=append(expt_list,{part(ans,k+1)});
              >>
          else
            <<
          if(current=number) then num_list:=append(num_list,{part(ans,k+1)})
         else   <>;
             >>;
        >>;
      >>;
if(expt_list={}) then % we have only a number to deal with; ie power of
                      % ww in series is 0
return append({number},num_list) else
<< if(num_list={}) then
   <<
      if(freeof(expt_list,(lisp mk!*sq simp 'minus))) then
      <<
      expt_list:=sortnumlist(expt_list);
      expt_list:={expt,part(expt_list,1)};
      return expt_list;
      >> %
      else <<  % our list contains a power with a minus sign
               % want to find the least exponent, and then see if it is tagged
               % with a minus sign
      expt_list2:=expt_list;
      expt_list2:=delete_all((lisp mk!*sq simp 'minus),expt_list2);
                    % list is now without minus
      expt_list2:=sortnumlist(expt_list2);
      expt_list2:=part(expt_list2,1); % smallest element, this is our expt
      % now want to check the sign of w with this exponent

      l:=0; finished:=0;
      while (l<=(arglength(expt_list)-1) and finished=0) do
                               <<
      if((part(expt_list,l)=(lisp mk!*sq simp 'minus))
                     and (part(expt_list,l+1)=expt_list2))
         then
         <<
            finished:=1;
            expt_list2:=append({lisp 'minus},{expt_list2});
         >> else l:=l+1;
                         >>;
            return expt_list2;

                >>;
   >>
   else <<
          if(freeof(expt_list,lisp mk!*sq simp 'minus)) then
          <<
          expt_list:=sortnumlist(expt_list);
          expt_list:={part(expt_list,1)}; % smallest element in the list
          if(part(expt_list,1)<0) then %%%%%% this is the value of e0 returned
          return append({expt},{part(expt_list,1)}) else
            return append({number},num_list);
           >>
           else << % doesn't matter what is in the number list, as minus is
                   % present, meaning there is a negative exponent here
           expt_list:=delete_all(lisp mk!*sq simp 'minus, expt_list);
           expt_list:=sortnumlist(expt_list);
           return {lisp 'minus,part(expt_list,1)}; >>;
         >>;


>>;
end;
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/mrvlimit.tex0000644000175000017500000002161311526203062024737 0ustar  giovannigiovanni\documentstyle[11pt,reduce,fancyheadings]{article}
\title{
A new exp-log limits package for \small{REDUCE}
}
\author{Neil Langmead \\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik (ZIB) \\ 
        Takustrasse 7  \\
        D- 14195 Berlin Dahlem \\
        Berlin
        Germany}
\date{January 1997}

\def\foottitle{Limits}
\pagestyle{fancy}
\lhead[]{{\footnotesize\leftmark}{}}
\rhead[]{\thepage}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\addtolength{\oddsidemargin}{-20 mm}
\addtolength{\textwidth}{25 mm}
\pagestyle{fancy}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\setlength{\topmargin}{1 mm}
\setlength{\footskip}{10 mm}
\setlength{\textheight}{220 mm}
\cfoot{}
\rfoot{\small\foottitle}

\def\exprlist   {exp$_{1}$,exp$_{2}$, \ldots ,exp$_{{\tt n}}$}
\def\lineqlist  {lin\_eqn$_{1}$,lin\_eqn$_{2}$, \ldots ,lin\_eqn$_{n}$}
\begin{document}
\maketitle{
\begin{center} \Large A new exp-log limits package for \small{REDUCE}
\end{center} }
\pagebreak
\tableofcontents
\pagebreak
\section{The Exp-Log Limits package}
This package  arises from the PhD thesis of Dominik Gruntz, of the ETH  Z\"{u}rich. He developed a new algorithm to compute limits of "exp-log" functions. Many of the examples he gave were unable to be computed by the present limits package in \small{REDUCE},\normalsize the simplest example being the following, whose limit is obviously $0$:
\begin{verbatim}
load limits;

limit(x^7/e^x,x,infinity);

        7
       x
limit(----,x,infinity)
        x
       e
\end{verbatim}

This particular problem arises, because L'Hopital's rule for the computation of indefinite forms (such as $0/0$, or $\frac{\infty}{\infty}$) can only be applied in a CAS a finite number of times, and in \small{REDUCE}~\cite{Red36}, \normalsize this number is 3. Applied 7 times to the above problem would have yielded the correct answer 0. 
The new algorithm solves this particular problem, and enables the computation of many more limit calculations in \small{REDUCE}. \normalsize We first define the domain in which we work, and then give a statement of the main algorithm that is used in this package. \\

Definition: \\
Let $\Re[x]$ be the ring of polynomials in $x$ with real coefficients, and let $f$ be an element in this ring. The field which is obtained from $\Re[x]$ by closing it under the operations $f$ $\rightarrow$ $exp(f)$ and $f$ $\rightarrow$ $\log |f|$ is called the $L$- field (or logarithmico-exponential field, or field of exp-log functions for short).
\newline 
\newline
Hardy proved that every $L$ function is ultimately continuous, of constant sign, monotonic, and tends to $\pm \infty$ or to a finite real constant as $x$ $\rightarrow +\infty.$ \\

Here are some examples of exp-log functions, which the package is able to deal with: \\

$ f(x)=e^{x}*\log(\log(x))$ \\

$ f(x)=\frac{\log(\log(x+e^{-x}))}{e^{x^{2}}+\log(\log(x))} $ \\

$ f(x)=\log(x)^{\log(x)} $ \\

$ f(x)=e^{x*\log(x)} $ \\

\pagebreak
\section{The Algorithm}
A complete statement of the algorithm now follows:
%\hspace{-1cm}\shadowbox{\parbox{9cm}{
Let $f$ be a log-exp function in $x$, whose limit we wish to compute as $x\rightarrow x_0.$ The main steps of the algorithm to do this are as follows: \\
\begin{itemize}
\item{Determine the set $\Omega$ of the most rapidly varying subexpressions of $f(x)$. Limits may have to be computed recursively at this stage.}
\item{Choose an expression $\omega$ such that $\omega>0$, $\lim_{x \rightarrow \infty} \omega=0 $ and $\omega$ is in the same comparability class as any element of $\Omega$. Rewrite the other expressions in $\Omega$ as $A(x)\omega^{c}$, where $A(x)$ only contains subexpressions in lower comparability classes than $\Omega$.}
\item{Let $f(\omega)$ be the function obtained from $f(x)$ by replacing all elements of $\Omega $ by their representation in terms of $\omega$. Consider all expressions independent of $\omega$ as constants and compute the leading term of the power series of f($\omega$) around $\omega=0^{+}$ }
\item{If the leading exponent $e_0>0$, then the limit is 0, and we stop. If the leading exponent $e_0<0$ then the limit is $\pm \infty$. The sign is defined by the sign of the leading coefficient $c_0$. If the leading exponent $e_0=0$ then the limit is the limit of the leading coeficient $c_0$. If $c_0$ $\not \in C$, where $C=Const(L)$, the set of exp-log constants, we apply the same algorithm recursively on $c_0$.} \\
\end{itemize}
%}}
The algorithm to compute the most rapidly varying subset (the mrv set) of a function f is given below:\\
\begin{tabbing}      
procedure mrv(f) \= \\ % f an exp log function in $x$ \\
  if (not (depend(f,$x$)))  $\rightarrow$ return (\{\}) \\
  \> else if $f=x \rightarrow$   return(\{$x$\}) \\
 \> else if $f=gh$  $\rightarrow$   return(max(mrv(g),mrv(h))) \\
  else if $f=g+h$ $\rightarrow$   return(max(mrv(g),mrv(h))) \\
  else if $f=g^{c}$ and c $\in C \rightarrow$   return(mrv(g)) \\
  else if $f=log(g)$ $\rightarrow$   return(mrv(g)) \\
  else if \= $f=e^{g}$ $\rightarrow$  \\
   \>   if $\lim_{x \rightarrow \infty} g=\pm\infty \rightarrow$ \\
   \>        return(max(\{$e^{g}$\}, mrv(g))) \\
    \>  else $\rightarrow $ return mrv(g) \\
\bf{end}
\end{tabbing}

\vspace{5 mm}
The function max() computes the maximum of the two sets of expressions. Max() compares two elements of its argument sets and returns the set which is in the higher comparability class or the union of both if they have the same order of variation. \\

For further details, proofs and explanations of the algorithm, please consult ~\cite{Grn96}.
\pagebreak

For example, we have \\

$mrv(e^{x})=\{e^x\}$ \\
$mrv(log(log(log(x+x^2+x^3))))=\{x\} $ \\
$mrv(x)=\{x\} $\\
$mrv(e^x+e^{-x}+x^2+x \log(x))= \{e^x,e^{-x} \}$ \\
$mrv(e^{e^{-x}})=\{e^{-x} \} $ \\

\subsection{Mrv\_limit Examples}
Consider the following in \small{REDUCE}:
\begin{verbatim}
mrv_limit(e^x,x,infinity);

infinity

mrv_limit(1/log(x),x,infinity);

0

b:=e^x*(e^(1/x-e^-x)-e^(1/x));


           -1        - x
      x + x      - e
b := e       *(e         - 1)


mrv_limit(b,x,infinity);


-1


                                       -1
  ex:=  - log(log(log(log(x))) + log(x))  *log(x)

                       *(log(log(x)) - log(log(log(x)) + log(x)));


            - log(x)*(log(log(x)) - log(log(log(x)) + log(x)))
ex:=     -----------------------------------------------------
                    log(log(log(log(x))) + log(x))

off mcd;

mrv_limit(ex,x,infinity);

1


(log(x+e^-x)+log(1/x))/(log(x)*e^x);

  - x       -1       -1          - x
e    *log(x)  *(log(x  ) + log(e     + x));

mrv_limit(ws,x,infinity);

0

mrv_limit((log(x)*e^-x)/e^(log(x)+e^(x^2)),x,infinity);

0

\end{verbatim}
\normalsize
\section{The tracing facility}
The package provides a means of tracing the $mrv\_limit$ function at its main steps, and is intended to help the user if he encounters problems. Messages are displayed informing the user which Taylor expansion is being computed, all recursive calls are listed, and the value returned by the $mrv$ function is given. This information is displayed when  a switch $tracelimit$ is on. This is off by default, but can be switched on with the command
\begin{verbatim}
on tracelimit;
\end{verbatim}
For a more complete examination of the workings of the algorithm, the user could also try the command
\begin{verbatim}
tr mrv_limit;
\end{verbatim}
This is not recommended, as the amount of information returned is often huge and difficult to wade through.
Here is a simple example in \small{REDUCE}:
\begin{verbatim}

Loading image file: /silo/cons/reduce35/Alpha/binary/redu37a.img
REDUCE Development Version,  4-Nov-96 ...

1: load mrvlimit;

2: on tracelimit;

3: mrv_limit(e^x,x,infinity);


                        -1
performing taylor on: ww

                      -1
series expansion is ww

            -1
series is ww

exponent list is {expt,-1}

leading exponent e0 is {expt,-1}

           x
mrv_f is {e }

mrv_f is {x}

                        -1
performing taylor on: ww

                      -1
series expansion is ww

            -1
series is ww

exponent list is {expt,-1}

leading exponent e0 is {expt,-1}

                        -1
performing taylor on: ww   

infinity
\end{verbatim}
\vspace{10 mm}
Note that, due to the recursiveness of the functions $mrv$ and $mrv\_limit$, many calls to each function are made, and information is given on all calls when the $ tracelimit$ switch is on.

\section{Comments, Bug reports and Suggestions}
Thsi package was written when the author was a placement student at ZIB Berlin. Please address all comments, bugs and suggestions to Winfried Neun, ZIB, Takustrasse 7, D-14195 Berlin Dahlem, Germany, or e/mail neun@zib.de. \\
\pagebreak
\begin{thebibliography}{99999}
\normalsize

\bibitem[Grn96]{Grn96} Gruntz, Dominik,
{\it On Computing Limits in a Symbolik Manipulation System}, \\
PhD Thesis, ETH Z\"urich

\bibitem[Red36]{Red36} Hearn, Anthony C. and Fitch, John F.
{\it REDUCE User's Manual 3.6}, \\ RAND Corporation, 1995

\end{thebibliography}
\end{document}



mathpiper-0.81f+svn4469+dfsg3/src/packages/mrvlimit/mrvlimit.red0000644000175000017500000004675111526203062024723 0ustar  giovannigiovanni%----------------------------------------------------------------------------
%                                                                           |
% A new Exp-Log limits package in REDUCE                                   |
%                                                                           |
% Author: Neil Langmead                                                        |
% Place:  ZIB, Berlin                                                           |
% Date:   April 1997                                                     |
% e/mail: langmead@zib.de                                             |
%                                                                           |
% some cleanup and a minor fix by WN 14 Dec 2005                            |
% all bugs and comments or suggestions please report to Winfried Neun,      |
% ZIB, Takustrasse 7, D-14195, Berlin Dahlem, Germany: e/mail neun@zib.de   |
%----------------------------------------------------------------------------

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module mrvlimit;
create!-package ('(mrvlimit expon),nil);

global '(tracelimit!*); % for the tracing facility)

switch tracelimit;

off tracelimit; % off by default

flag('(sqchk),'opfn);

%symbolic procedure max_power(f,x);
%  if domainp f then 0 else
%    if mvar f eq x then ldeg f else
%          max(max_power(lc f,x),max_power(red f,x))

%put('max2,'psopfn,'max_power)
load_package limits;
load_package sets;

algebraic;
off mcd;

symbolic procedure maxi(f,g);
begin scalar c;
if(freeof(f,'x)) then return g;
if(freeof(g,'x)) then return f;
if(f=g) then return  f else
<<
if(null f) then return  g else
<<
  if(null g) then return   f
  else <<
    if (intersection(f,g) neq '(list)) then return union(f,g)
      else <<
        if(evalb('x member f)='true) then return  g
         else <<
            if(evalb('x member g)='true) then return  f
             else  <<
              if(car f='list and cadr f='list) then % double list
                            << % only want caddr f to be given to compare
                                      c:=compare(caddr f,cadr g);
                                 %write "c is ", c; write length(c)
                                return c;
                            >>
                  else <<
                          if(car g='list and cadr g='list) then
                             <<
                             c:=compare(cadr f,caddr g);
                             %write "c is ", c;
                                 return c;
                          >>
                          else <<
                                 c:=compare(cadr f, cadr g);
                                  %write "c is ", c;
                                  return c;
                                 >>;
                        >>;

              %if(c=cadr f) then return cadr f else <<
              %         if(c=cadr g) then return (cadr g)
              % else return union(cdr f,cdr g);
                                           %   >>;
                    >>;
                >>;
            >>;
          >>;
 >>;
>>;
end; % of max

 %max
%-------------------------------------------------------------------------

algebraic;
procedure maxi1(f,g);  lisp cadr (lisp (list('list,maxi(f,g))));

algebraic;
expr procedure compare(f,g);
begin scalar logg, logf;
   logf:=log(f);
   logg:=log(g);

   if(mrv_limit(logf/logg,x,infinity)=0) then return {g} else <<
        if(mrv_limit(logg/logf,x,infinity)=0) then return {f} else
                return {f,g}; >>;
end;

procedure comp(f,g); lisp('list.compare(f,g));

%----------------------------------------------------------------------------
load_package assist;

symbolic procedure mrv(li);
begin
off mcd;  on factor;

% The next line doesn't do anything in symbolic mode. Presumably li
% should be simplified in some way.  However, li is not always an
% algebraic expression. Sometimes it is a list of one, or a list of a
% number.

li:=li;
if(numberp li) then return nil else <<
if(li='(list)) then return nil else <<
if(atom li) then return lisp ('list.{li}) else <<
  if(car li='times) then <<
               if(atom cadr li and atom caddr li) then
                     << if(length(cddr li)=1) then
                        return  lisp ('list.maxi1({cadr li}, {caddr li}))
                        else return maxi1({cadr li},mrv(cddr li))
                      >>
               else return  maxi1(mrv(cadr li), mrv(cddr li))
                           >>
    else <<
     if(car li='minus) then <<
          if(atom cadr li) then return 'list.{cadr li} else return
                mrv(cadr li)
                             >>
                            %return mrv(append({'plus},cdr li))
      else <<
     if(car li='plus) then <<
   %if(null caddr li) then return mrv(cadr li)
   if(length cdr li=1) then %only one argument to plus
      return mrv(cadr li) else <<
             if(atom cadr li and atom caddr li) then
               << if(length(cddr li)=1) then return
                       lisp ('list.maxi1({cadr li},{caddr li}))
                  else return
                  lisp ('list.maxi1({cadr li},mrv(append({'plus},cddr li))))
                >>
                else <<
                   if(atom cadr li and pairp caddr li) then
                  return
           maxi1('list.{cadr li}, mrv(cddr li)) % here as well
                else  <<
         if(pairp cadr li and null caddr li) then return mrv(cadr li) else
       <<
         if(pairp cadr li and atom caddr li) then
             <<
               if(length(cdr li)>2) then % we have plus with > two args
return lisp cdr ('list.maxi1(mrv(cadr li),mrv(append({'plus},cddr li)))) %her
 else
    return lisp cdr ('list.maxi1(mrv(cadr li), mrv(cddr li))) >>
    else
<< if(null caddr li) then return mrv(cadr li)
      else return maxi1(mrv(cadr li), mrv(append({'plus},cddr li))) >>
             >>
                      >>
                            >>
                                 >>
                                      >>
           else <<
           if(car li='expt) then <<
               if(cadr li neq 'e) then
               return  mrv(cadr li)
               else <<  %we have e to the power of something
                       if sqchk mrv_limit(caddr li,'x,'infinity)
                             eq 'infinity
                           then
                         return
                        maxi1('list.{li},mrv(caddr li)) else
                         <<
                           if sqchk mrv_limit(caddr li,'x,'infinity)
                              = '(minus infinity)
                               then
                     return  maxi1('list.{li},'list.mrv(cddr li)) else return
                            mrv(caddr li)
                          >>
                     >>
                                  >>
                else << if(car li='log) then
                        << if(atom cadr li) then return mrv(cadr li) else
                           return mrv(cdr li)
                         >> else <<
                       if(car li='sqrt) then return mrv(cdr li) else
                        return mrv(car li)
                                  >>
                      >>
                  >>
            >>
     >> % for minus
  >> %for null
 >> % for numberp
              >>;
off mcd;
end; % of mrv

algebraic;

procedure mrv1(li);  lisp (mrv(li));
%----------------------------------------------------------------------------
% procedure to return a list of subexpressions of exp
% this will then be used for the mrv function

symbolic procedure flatten(li);
  % This procedure turns a list with possibly nested sub_lists into a single
  % List with no nested sub-lists. Easier to search this list.
  makeflat(li,nil);

symbolic procedure makeflat(li,answer);
  if li=nil then nil
  else
    if atom li then li.answer
    else if (cdr li)=nil then makeflat(car li,answer)
       else append(makeflat(car li,answer),makeflat(cdr li,answer));

algebraic;
procedure flat(li); lisp(flatten li);
procedure mkflat(li); lisp(makeflat(li,nil));
%in "max";
%trst maxi;

symbolic procedure lim(exp,var,val);
begin scalar mrv_list, rule;
mrv_list:=mrv1(exp);
if(mrv_list='(list)) then rederr "unable to compute mrv set"
  else
    <<
       rule:=list(list ('replaceby, cdr mrv_list,'w));
       let rule;
    >>;

end;
% nedd to consider if x belongs to mrv(exp), then follow rest of alg.
algebraic;
expr procedure move_up(exp,x);
sub({log(x)=x,x=e^x},exp);

expr procedure move_down(exp,x);
sub({e^x=x,x=log(x)},exp);

%off mcd;
algebraic;
expr procedure rewrite(m);
begin scalar ans_list,summ,k,g,c,A;

ans_list:={};
g:=part(m,1); write length g;
for k:=1:arglength(m) do
<<
  summ:=length(den(part(m,k)))+length(num(part(m,k))); write summ;
  if(summ<(length(den(g))+length(num(g)))) then g:=part(m,k);
>>;
write "g is ", g;

for each f in m do
  <<
    c:=limit(log(f)/log(g),x,infinity);
    A:=e^(log(f)-c*log(g));
    f:=A*w^c;
    ans_list:=append({f}, ans_list);
  >>;
return ans_list;
end;

%expr procedure smallest(li);
%begin scalar current,k;
%current:=part(li,1);
%for k:=1:arglength(li) do <<
%             if(length(current)>length(part(li,k))) then
%             current:=part(li,k);
%                           >>;
%return current;
%end;

expr procedure smallest(li);
begin scalar l1,l2;
if(length li=1) then return part(li,1) else
            <<
l1:=lngth2(part(li,1));
l2:=lngth2(part(li,2));
if(l1>l2) then return part(li,2) else
 << if(l1>;
             >>;

end;

symbolic procedure lngth u;
 begin
     if(u='list) then return nil else
    <<
      if(atom u) then return 1 else
      <<
        if(atom car u) then return (1+lngth cdr u)
        else return lngth car u + lngth cdr u;
      >>;
    >>;
 end;

%put('lngth2,'psopfn,'lngth);
algebraic;
procedure lngth2 u; lisp lngth u;

%-------------------------------------------------------------------------

% main routine to compute limits of exp-log functions as the variable tends
% to infinity.

operator x;
operator series;
algebraic;

expr procedure mrv_limit(f,var,val);

begin scalar mrv_f,mrv1_f,w, mrv_f2,tt, lead_term, series_exp,f1, small, rule1,
const, e0,sig,rule2,k, nu,de,h,recurse;
off mcd; off factor; off rational; off exp; off precise;
%if(val neq infinity) then return sub(var=val,f);

% trigonometric expressions aren't dealt with by the algorithm

if(not(freeof(f,sin))) then rederr "input not an exp log function";
if(not(freeof(f,cos))) then rederr "input not an exp log function";
if(not(freeof(f,tan))) then rederr "input not an exp log function";
if(freeof(f,var)) then % possible cases: f can be a number, an expression
                       % independent of var, or possibly not an exp log
                       % function. In all cases, return f as the answer
return f;
if(val neq infinity) then return sub(var=val,f);

%on rational;
%on rounded;
%this checks for numbers. red doesn't recognise some objects as numbers unless
% the rounded switch is on

f1:=f; if(numberp(f1)) then return f; off rational;
off rounded;
if(var neq x) then f:=sub(var=x,f) else nil;
if(numberp(f)) then return f;
%%%% special case where f=e, or pi. Don't want to use the on rounded switch
%%%% in these cases
if(f=e) then return e;
if(f=pi) then return pi;
%if(f=x) then return plus_infinity;
on factor; off mcd; mrv_f:=mrv1(f);
%write "*********************************************************************";
if(lisp !*tracelimit) then
write "mrv_f is ", mrv_f;
lisp if null mrv_f then % emergency exit for now
         return ('limit . list(f,var,val));

%write "*********************************************************************";
off factor;
%on mcd;

if(member(x,mrv_f)) then
  <<
    off exp; off mcd;
    while(member(x,mrv_f)) do
      <<
        f:=move_up(f,x); %write "f is ", f;
        %mrv_f:=mrv1(f);
        mrv_f:=for k:=1:arglength(mrv_f) collect move_up(part(mrv_f,k),x);
        %write "mrv is ", mrv_f;
      >>;
    % we know that x was a member of mrv(f), so now, the mrv set will contain
    % e^x at least. Hence, write directly in terms of w=e^(-x)

    small:=e^(-x);
    % now have the smallest element, but don't know its limiting behaviour
    % if lim is infinity, need to set w to 1/small
    rule1:={small => ww };
    let rule1;
    f:=f;
    on mcd; nu:=num(f); de:=den(f); f:=nu/de; off mcd;
    f:=f; % write f;
    clearrules rule1;
       % f now rewritten
   >>
  else <<
         %mrv_f2:=rewrite(mrv_f); % write "f2 is ", mrv_f2;
                 % now need to rewrite f itself
        small:=smallest(mrv_f);
        h:=log(small); %write "h is ", h;
        if(mrv_limit(h,x,infinity)=infinity) then
         <<
            small:=small^-1;
            % write "small has been changed", small;
         >>;

          rule1:=
                { small => ww,
                  1/small => ww^-1 };
         let rule1; off mcd;

         f:=f;
         on mcd;
         off mcd; %f:=f;
         clearrules rule1;

         % now rewritten in terms of w, and mrv(f)=w hopefully
        >>;

% at this point, f has been rewritten. Now check lcof of series expansion


% lisp !*mcd:=nil; lisp !*factor:=nil; lisp !*exp:=t; lisp !*rational:=nil;

off mcd; on factor; off exp; off rational;
series_exp:=taylor(f,ww,0,1);
if(lisp !*tracelimit) then
   write "performing taylor on: ", f;

%off mcd; on exp; on factor; off rational;
if(not taylorseriesp series_exp and part(series_exp,0)=taylor)
  then rederr "could not compute the Taylor series expansion";

tt:=log(small);

series_exp:=sub(log(ww)=tt,series_exp); %off mcd; off factor; off exp;
series_exp:=taylortostandard series_exp;
if(lisp !*tracelimit) then write "series expansion is ", series_exp;
% should now have the lead term of the series expansion in terms of w
if(numberp(series_exp)) then return series_exp
else <<
       if(lisp !*tracelimit) then
       write "series is ", series_exp;
       off rational;  off mcd;  off exp; off factor;
       series_exp:=series_exp; off factor;
       const:=coeffn(series_exp,ww,0); %write "const is ", const;
       if(const neq 0) then
       <<
         if(numberp(const)) then return const else
         <<
             if(lisp !*tracelimit) then
             write "performing recursion on ", const;
             off mcd; on factor; off exp;  on rational; const:=const;
         return mrv_limit(const,x,infinity); >>;
       >>
       else
       <<
       % need to look at exponent of ww. If e0>0 then return 0, if
       % e0<0 return infinity, if e0=0 return mrv_limit(c)
       %write "series_exp is ", series_exp;
       series exp:=series_exp; off mcd; % try it here!
       %if(lisp !*tracelimit) then
       %write "series exp is  ", series_exp;
       %  series_exp:=lisp reval series_exp;
       %off mcd;
       e0:=find_least_expt(series_exp);
        if(lisp !*tracelimit) then write "leading exponent e0 is ", e0;
       off mcd; on factor; off exp; off rational;
       %if(part(e0,1)=expt) then
       %<< e0:=part(e0,2);
       %e0:=part(e0,1); if(e0=e) then return e;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% possible cases: e0:={expt_list,num_list,x_list}
% if both num_list and x_list are empty, then e0 takes the value of the
% smallest exponent in expt_list.
% if numbers in expt_list are all positive, then e0 is the value in either
% num_list, or expt_list: if num_list, then this number is returned, if
% expt_list, then we apply algorithm recusively to the value of x_exp
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       if(part(e0,1)=expt) then <<
                                               e0:=part(e0,2);
       %if(not numberp e0) then return part(e0,2);
       if(e0<0 and ((lisp car series_exp) neq minus))
        then return infinity else
                << %*sign(lcof(series_exp,ww))
                     if(e0<0) then return -infinity

                               else
                               <<
                               if(e0>0) then return 0 else <<
                          off mcd; off factor; off rational; on exp;
                           recurse:=lcof(series_exp,ww); return
                          mrv_limit(recurse,x,infinity); >>;
                               >>;
                 >>;
                                 >>
       else <<
       if(part(e0,1)=number) then return part(e0,2) else
        <" are used
      at the left and right edges to indicate out of bounds points.
      Without supplementary rules, many REDUCE implementations will be
      unable to numerically evaluate expressions involving operations
      other than +, -, *, /, and integer powers;

   SCALAR X, F, Y;  INTEGER COL, NCOLSMINUS1;
   NCOLSMINUS1 := NCOLS - 1;
   WRITE "Starting the plot of ",EX;
   X := LISTOFVARS EX;          % find indeterminates;
   IF LENGTH X > 1 THEN REDERR
     "ERROR: PLOT expression can have at most 1 indeterminate";
   IF NULL X THEN <<
      WRITE "ERROR: no indeterminates in ", EX;
      REDERR "" >>
   ELSE X := CAR X;
   WRITE " in variable ",x;terpri();
   COMMENT Convert args from algebraic to symbolic values;
   XINIT := REVALX XINIT;
   DX := REVALX DX;
   YINIT := REVALX YINIT;
   DY := REVALX DY;

   FOR J:= 0:NDX DO <<

      % generate expression with current value substituted for x
      F := SUBST(XINIT + J*DX, X, EX);
      Y := EVAL(F);                      % eval expression
      COL := RND((Y - YINIT)/DY);        % scale and round for cols

      IF COL<0 THEN WRITE "<"
      ELSE IF COL > NCOLSMINUS1 THEN << SPACES(NCOLSMINUS1);
         PRIN2 ">";
         TERPRI() >>
      ELSE << SPACES(COL);
         PRIN2 "*";
         TERPRI() >>
      >> ;
   IF NULL Y THEN REDERR
     "ERROR: UNABLE TO PERFORM FLOATING-POINT EVALUATION OF 1ST ARG"
   END;

PAUSE;

SYMBOLIC PROCEDURE LISTOFVARS CAMPRE;
   IF NULL CAMPRE OR NUMBERP CAMPRE THEN NIL
   ELSE IF ATOM CAMPRE THEN LIST CAMPRE
   ELSE VARSINARGS CDR CAMPRE;

SYMBOLIC PROCEDURE VARSINARGS LISTOFCAMPRE;
   BEGIN SCALAR X;
   RETURN IF NULL LISTOFCAMPRE THEN NIL
   ELSE UNION(LISTOFVARS CAR LISTOFCAMPRE, VARSINARGS CDR LISTOFCAMPRE);
   END;

SYMBOLIC PROCEDURE RND X;
   BEGIN SCALAR ANS;
   ANS := REVALX X;
   IF NOT NUMBERP X THEN REDDERR "RND GIVEN NON-NUMERIC ARGUMENT";
   IF ANS >=0 THEN ANS := FIX(ANS+00.5)
   ELSE ANS:= FIX(ANS-0.5);
   RETURN ANS
   END;

SYMBOLIC PROCEDURE REVALX U;
   % MAKE SURE WE GET TRUE FLOATS IN SYMBOLIC MODE.
   IF EQCAR(U,'!:RD!:) THEN RDPREPX U ELSE U;

SYMBOLIC PROCEDURE RDPREPX U;
   IF FLOATP CDR U THEN CDR U ELSE BF2FLR U;

PAUSE;

ON ROUNDED;

PLOT(Y**2,     0, 0.25, 10, 0, 0.25);
PAUSE;

PLOT((A+1)**2, 0, 0.25, 10, 0, 0.25);
PAUSE;

B := A*2;

PLOT(A*B,      0, 0.25, 10, 0, 0.25);
PAUSE;

COMMENT We leave it as an exercise to write a more elaborate plot
procedure which offers amenities such as automatic scaling, numbered
ordinates, etc.

Good luck with these exercises, with REDUCE, with computer algebra and
with all of your endeavors.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less5.red0000755000175000017500000004530611526203062023734 0ustar  giovannigiovanniCOMMENT

                  REDUCE INTERACTIVE LESSON NUMBER 5

                         David R. Stoutemyer
                        University of Hawaii


COMMENT  This is lesson 5 of 7 REDUCE lessons.

There are at least two good reasons for wanting to save REDUCE
expression assignments on secondary storage:
   1.  So that one can logout, then resume computation at a later
       time.
   2.  So that needed storage space can be cleared without
       irrecoverably losing the values of variables which are not
       needed in the next expression but will be needed later.

Using trivial small expressions, the following sequence illustrates
how this could be done:

   OFF NAT,
   OUT TEMP,
   F1 := (F + G)**2,
   G1 := G*F1,
   OUT T,
   CLEAR F1,
   H1 := H*G1,
   OUT TEMP,
   CLEAR G1,
   H2 := F*H1,
   CLEAR H1,
   SHUT TEMP,
   IN TEMP,
   F1,
   ON NAT,
   F1 .

ON NAT yields the natural output style with raised exponents, which
is unsuitable for subsequent input.

The OUT-statement causes subsequent output to be directed to the file
named in the statement, until overridden by a different OUT-statement
or until the file is closed by a SHUT-statement.  File T is the
terminal, and any other name designates a file on secondary storage.
Such names must comply with the local file-naming conventions as well
as with the REDUCE syntax.  If the output is not of lasting
importance, I find that including something like "TEMPORARY" or
"SCRATCH" in the name helps remind me to delete it later.

Successive OUT-statements to the same file will append rather than
overwrite output if and only if there is no intervening SHUT-
statement for that file.  The SHUT-statement also has the effect of
an implied OUT T.

Note:
   1.  The generated output is the simplified expression rather than
       the raw form entered at the terminal.
   2.  Each output assignment automatically has a dollar-sign
       appended so that it is legal input and so that (perhaps
       lengthy) output will not unavoidably be generated at the
       terminal when the file is read in later.
   3.  Output cannot be sent simultaneously to 2 or more files.
   4.  Statements entered at the terminal which do not generate
       output -- such as declarations, LET rules, and procedure
       definitions -- do not appear in the secondary storage file.
   5.  One could get declarations, procedure definitions, rules, etc.
       written on secondary storage from the terminal by typing
       statements such as

          WRITE "
          ALGEBRAIC PROCEDURE ...
             ... " .

       This could serve as a means of generating permanent copies
       of LET rules, procedures, etc., but it is quite awkward
       compared with the usual way, which is to generate a file
       containing the REDUCE program by using a text editor, then
       load the program by using the IN-statement.  If you have
       refrained from learning a local text editor and the operating-
       system file-management commands, hesitate no longer.  A half
       dozen of the most basic commands will enable you to produce
       (and modify!) programs more conveniently than any other method.
       To keep from confusing the editor from REDUCE, I suggest that
       your first text-editing exercise be to create an IN file for
       (re)defining the function FACTORIAL(n).

   5.  The reason I didn't actually execute the above sequence of
       statements is that when the input to REDUCE comes from a batch
       file, both the input and output are sent to the output file,
       (which is convenient for producing a file containing both the
       input and output of a demonstration.)  Consequently, you would
       have seen none of the statements between the "OUT TEMP" and
       "OUT T" as well as between the second "OUT TEMP" and the
       "SHUT TEMP", until the IN statement was executed.  The example
       is confusing enough without having things scrambled from the
       order you would type them. To clarify all of this, I encourage
       you to actually execute the above sequence, with an
       appropriately chosen file name and using semicolons rather
       than commas.  Afterwards, to return to the lesson, type CONT;

PAUSE;

COMMENT Suppose you and your colleagues developed or obtained a set
of REDUCE files containing supplementary packages such as trigono-
metric simplification, Laplace transforms, etc.  It would be a waste
of time (and perhaps paper) to have these files printed at the
terminal every time they were loaded, so this printing can be
suppressed by inserting the statement "OFF ECHO" at the beginning of
the file, together with the statement "ON ECHO" at the end of the
file.

The lessons have amply demonstrated the PAUSE-statement, which is
useful for insertion in batch files at the top-level or within
functions when input from the user is necessary or desired.

It often happens that after generating an expression, one decides
that it would be convenient to use it as the body of a function
definition, with one or more of the indeterminates therein as
parameters.  This can be done as follows (say yes to the define
operator prompt);

(1-(V/C)**2)**(1/2);
FOR ALL V SAVEAS F(V);
F(5);

COMMENT Here the indeterminate V became a parameter of F.
Alternatively, we can save the previous expression as an indeterminate;

SAVEAS FOF5;
FOF5;

COMMENT I find this technique more convenient than referring to the
special variable WS;

PAUSE;

COMMENT The FOR-loop provides a convenient way to form finite sums or
products with specific integer index limits.  However, this need is
so ubiquitous that REDUCE provides even more convenient syntax of
the forms

  FOR index := initial STEP increment UNTIL final SUM expression,

  FOR index := initial STEP increment UNTIL final PRODUCT expression.

As before, ":" is an acceptable abbreviation for "STEP 1 UNTIL".  As
an example of their use, here is a very concise definition of a
function which computes Taylor-series expansions of symbolic
expressions:;

ALGEBRAIC PROCEDURE TAYLOR(EX, X, PT, N);
   COMMENT This function returns the degree N Taylor-series
      expansion of expression EX with respect to indeterminate X,
      expanded about expression PT.  For a series-like appearance,
      display the answer under the influence of FACTOR X, ON RAT,
      and perhaps also ON DIV;
   SUB(X=PT, EX) + FOR K:=1:N SUM(SUB(X=PT, DF(EX,X,K))*(X-PT)**K
                 / FOR J:=1:K PRODUCT J);
CLEAR A, X;  FACTOR X;  ON RAT, DIV;
G1 := TAYLOR(E**X, X, 0, 4);
G2 := TAYLOR(E**COS(X)*COS(SIN(X)), X, 0, 3);
%This illustrates the Zero denominator limitation, continue anyway;
TAYLOR(LOG(X), X, 0, 4);

COMMENT  It would, of course, be more efficient to compute each
derivative and factorial from the preceding one.  (Similarly for
(X-PT)**K if and only if PT NEQ 0).

The Fourier series expansion of our example E**COS(X)*COS(SIN(X))
is  1 + cos(x) + cos(2*x)/2 + cos(3*x)/(3*2) + ... .
Use the above SUM and PRODUCT features to generate the partial sum of
this series through terms of order COS(6*X);

PAUSE;

COMMENT Closed-form solutions are often unobtainable for nontrivial
problems, even using computer algebra.  When this is the case,
truncated symbolic series solutions are often worth trying before
resorting to approximate numerical solutions.

When we combine truncated series it is pointless (and worse yet,
misleading) to retain terms of higher order than is justified by the
constituents.  For example, if we wish to multiply together the
truncated series G1 and G2 generated above, there is no point in
retaining terms higher than third degree in X.  We can avoid even
generating such terms as follows;

LET X**4 = 0;
G3 := G1*G2;

COMMENT Replacing X**4 with 0 has the effect of also replacing all
higher powers of X with 0.  We could, of course, use our TAYLOR
function to compute G3 directly, but differentiation is time
consuming compared to truncated polynomial algebra.  Moreover, our
TAYLOR function requires a closed-form expression to begin with,
whereas iterative techniques often permit us to construct symbolic
series solutions even when we have no such closed form.

Now consider the truncated series;

CLEAR Y;  FACTOR Y;
H1 := TAYLOR(COS Y, Y, 0, 6);

COMMENT Suppose we regard terms of order X**N in G1 as being
comparable to terms of order Y**(2*N) in H1, and we want to form
(G1*H1)**2.  This can be done as follows;

LET Y**7 = 0;
F1 := (G1*H1)**2;

COMMENT  Note however that any terms of the form C*X**M*Y**N with
2*M+N > 6 are inconsistent with the accuracy of the constituent
series, and we have generated several such misleading terms by
independently truncating powers of X and Y.  To avoid generating
such junk, we can specify that a term be replaced by 0 whenever a
weighted sum of exponents of specified indeterminates and functional
forms exceeds a specified weight level.  In our example this is done
as follows;

WEIGHT X=2, Y=1;
WTLEVEL 6;
F1 := F1;

COMMENT  variables not mentioned in a WEIGHT declaration have a
weight of 0, and the default weight-level is 2;

PAUSE;

COMMENT  In lesson 2 I promised to show you ways to overcome the lack
in most REDUCE implementations of automatic numerical techniques
for approximating fractional powers and transcendental functions of
numerical values.  One way is to provide a supplementary LET rule
for numerical arguments.  For example, since our TAYLOR function
would reveal that the Taylor series for cos x is
1 - x**2/2! + x**4/4! - ...;

FOR ALL X SUCH THAT NUMBERP X LET ABS(X)=X,ABS(-X)=X;
EPSRECIP := 1024 $
ON ROUNDED;
WHILE 1.0 + 1.0/EPSRECIP NEQ 1.0 DO
   EPSRECIP := EPSRECIP + EPSRECIP;
FOR ALL X SUCH THAT NUMBERP NUM X AND NUMBERP DEN X LET COS X =
   BEGIN COMMENT X is integer, real, or a rational number.  This rule
      returns the Taylor-series approximation to COS X, truncated when
      the last included term is less than (1/EPSRECIP) of the returned
      answer.  EPSRECIP is a global variable initialized to a value
      that is appropriate to the local floating-point precision.
      Arbitrarily larger values are justifiable when X is exact and
      ROUNDED is off.  No angle reduction is performed, so this
      function is not recommended for ABS(X) >= about PI/2;
   INTEGER K;  SCALAR MXSQ, TERM, ANS;
   K := 1;
   MXSQ := -X*X;
   TERM := MXSQ/2;
   ANS := TERM + 1;
   WHILE ABS(NUM TERM)*EPSRECIP*DEN(ANS)-ABS(NUM ANS)*DEN(TERM)>0 DO
      << TERM:= TERM*MXSQ/K/(K+1);
         ANS:= TERM + ANS;
         K := K+2 >>;
   RETURN ANS
   END;
COS(F) + COS(1/2);
OFF ROUNDED;
COS(1/2);

COMMENT  As an exercise, write a similar rule for the SIN or LOG, or
replace the COS rule with an improved one which uses angle reduction
so that angles outside a modest range are represented as equivalent
angles within the range, before computing the Taylor series;

PAUSE;

COMMENT  There is a REDUCE compiler, and you may wish to learn the
local incantations for using it.  However, even if rules such as
the above ones are compiled, they will be slow compared to the
implementation-dependent hand-coded ones used by most FORTRAN-like
systems, so REDUCE provides a way to generate FORTRAN programs which
can then be compiled and executed in a subsequent job step.  This is
useful when there is a lot of floating-point computation or when we
wish to exploit an existing FORTRAN program.  Suppose, for example,
that we wish to utilize an existing FORTRAN subroutine which uses the
Newton-Rapheson iteration

   Xnew := Xold - SUB(X=Xold, F(X)/DF(F(X),X))

to attempt an approximate solution to the equation F(X)=0.  Most such
subroutines require the user to provide a FORTRAN function or
subroutine which, given Xold, returns F(X)/DF(F(X),X) evaluated at
X=Xold.  If F(X) is complicated, manual symbolic derivation of
DF(F(X),X) is a tedious and error-prone process.  We can get
REDUCE to relieve us of this responsibility as is illustrated below
for the trivial example F(X) = X*E**X - 1:

   ON FORT, ROUNDED,
   OUT FONDFFILE,
   WRITE "      REAL FUNCTION FONDF(XOLD)",
   WRITE "      REAL XOLD, F",
                F := XOLD*E**XOLD - 1.0,
                FONDF := F/DF(F,XOLD),
   WRITE "      RETURN",
   WRITE "      END",
   SHUT FONDFFILE .

COMMENT  Under the influence of ON FORT, the output generated by
assignments is printed as valid FORTRAN assignment statements, using
as many continuation lines as necessary up to the amount specified
by the global variable !*CARDNO, which is initially set to 20.  The
output generated by an expression which is not an assignment is a
corresponding assignment to a variable named ANS.  In either case,
expressions which would otherwise exceed !*CARDNO continuation
lines are evaluated piecewise, using ANS as an intermediate variable.

Try executing the above sequence, using an appropriate filename and
using semicolons rather than commas at the end of the lines, then
print the file after the lesson to see how it worked;

PAUSE;
OFF FORT, ROUNDED;

COMMENT To make this technique usable by non-REDUCE programmers, we
could write a more general REDUCE program which given merely the
expression F by the user, outputs not only the function FONDF, but
also any necessary Job-control commands and an appropriate main
program for calling the Newton-Rapheson subroutine and printing the
results.

Sometimes it is desirable to modify or supplement the syntax
of REDUCE.  For example:
   1.  Electrical engineers may prefer to input J as the representation
       of (-1)**(1/2).
   2.  Many users may prefer to input LN to denote natural logarithms.
   3.  A user with previous exposure to the PL/I-FORMAC computer-
       algebra system might prefer to use DERIV instead of DF to
       request differentiation.

Such lexical macros can be established by the DEFINE declaration:;

CLEAR X,J;
DEFINE J=I, LN=LOG, DERIV=DF;

COMMENT  Now watch!;

N := 3;
G1 := SUB(X=LN(J**3*X), DERIV(X**2,X));

COMMENT Each "equation" in a DEFINE declaration must be of the form
"name = item", where each item is an expression, an operator, or a
REDUCE-reserved word such as "FOR".  Such replacements take place
during the lexical scanning, before any evaluation, LET rules, or
built-in simplification.  Think of a good application for this
facility, then try it;

PAUSE;

COMMENT  When REDUCE is being run in batch mode, it is preferable to
have REDUCE make reasonable decisions and proceed when it encounters
apparently undeclared operators, divisions by zero, etc.  In
interactive mode, it is preferable to pause and query the user.  ON
INT specifies the latter style, and OFF INT specifies the
former.  Under the influence of OFF INT, we can also have most
error messages suppressed by specifying OFF MSG.  This is sometimes
useful when we expect abnormal conditions and do not want our listing
marred by the associated messages.  INT is automatically turned off
during input from a batch file in response to an IN-command from a
terminal.

Some implementations permit the user to dynamically request more
storage by executing a command of the form

   CORE number,

where the number is an integer specifying the total desired core in
some units such as bytes, words, kilobytes, or kilowords;

PAUSE;

COMMENT  Some implementations have a trace command for debugging,
which employs the syntax

   TR functionname1, functionname2, ..., functionnameN .

An analogous command named UNTR removes function names from trace
status;

PAUSE;

COMMENT  Some implementations have an assignment-tracing command for
debugging, which employs the syntax

   TRST functionname1, functionname2, ..., functionnameN.

An analogous command named UNTRST removes functionnames from
this status.  All assignments in the designated functions are
reported, except for assignments to array elements.  Such functions
must be uncompiled and must have a top-level BEGIN-block. To apply
both TRST and TR to a function simultaneously, it is crucial to
request them in that order, and it is necessary to relinquish the two
kinds of tracing in the opposite order;

PAUSE;

COMMENT The REDUCE algebraic algorithms are written in a subset of
REDUCE called RLISP. In turn, the more sophisticated features of
RLISP are written in a small subset of RLISP which is written in a
subset of LISP that is relatively common to most LISP systems.

RLISP is ideal for implementing algebraic algorithms, but the RLISP
environment is not most suitable for the routine use of these
algorithms in the natural mathematical style of the preceding
lessons.  Accordingly, REDUCE jobs are initially in a mode called
ALGEBRAIC, which provides the user with the environment illustrated
in the preceding lessons, while insulating him from accidental
interaction with the numerous functions, global variables, etc.
necessary for implementing the built-in algebra.  In contrast, the
underlying RLISP system together with all of the algebraic
simplification algorithms written therein is called SYMBOLIC mode.

As we have seen, algebraic-mode rules and procedures can be used to
extend the built-in algebraic capabilities.  However, some extensions
can be accomplished most easily or efficiently by descending to
SYMBOLIC mode.

To make REDUCE operate in symbolic mode, we merely execute the top
level mode-declaration statement consisting of the word SYMBOLIC. We
can subsequently switch back by executing the statement consisting of
the word ALGEBRAIC.

RLISP has the semantics of LISP with the syntax of our by-now-familiar
algebraic-mode REDUCE, so RLISP provides a natural tool for many
applications besides computer algebra, such as games, theorem-proving,
natural-language translation, computer-aided instruction, and
artificial intelligence in general.  For this reason, it is possible
to run RLISP without any of the symbolic-mode algebraic algorithms
that are written in RLISP, and it is advisable to thus save space
when the application does not involve computer algebra.

We have now discussed virtually every feature that is available in
algebraic mode, so lesson 6 will deal solely with RLISP, and
lesson 7 will deal with communication between ALGEBRAIC and
SYMBOLIC mode for mathematical purposes.  However, I suggest that
you proceed to those lessons only if and when:
   1.  You have consolidated and fully absorbed the information in
       lessons 1 through 5 by considerable practice beyond the
       exercises therein.  (The exercises were intended to also
       suggest good related project ideas.)
   2.  You feel the need for a facility which you believe is impossible
       or quite awkward to implement solely in ALGEBRAIC mode.
   3.  You have read the pamphlet "Introduction to LISP", by D.  Lurie,
       or an equivalent.
   4.  You are familiar with definition of Standard LISP, as described
       in the "Standard LISP Report" which was published in the October
       1979 SIGPLAN Notices.

Remember, when you decide to take lesson 6, it is better to do so from
a RLISP job than from a REDUCE job.  Also, don't forget to print your
newly generated FORTRAN file and to delete any temporary files created
by this lesson.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less1.red0000755000175000017500000002613211526203062023724 0ustar  giovannigiovanniCOMMENT


                 REDUCE INTERACTIVE LESSON NUMBER 1

                         David R. Stoutemyer
                        University of Hawaii


COMMENT This is lesson 1 of 7 interactive lessons about the REDUCE
system for computer symbolic mathematics. These lessons presume an
acquaintance with elementary calculus, together with a previous
exposure to some computer programming language.

These lessons have been designed for use on a DEC system 10 or 20.
Apart from changes to the prompt and interrupt characters however
they should work just as well with any REDUCE implementation.

In REDUCE, any sequence of characters from the word "COMMENT" through
the next semicolon or dollar-sign statement separator is an
explanatory remark ignored by the system. In general, either
separator signals the end of a statement, with the dollar sign
suppressing any output that might otherwise automatically be produced
by the statement. The typing of a carriage return initiates the
immediate sequential execution of all statements which have been
terminated on that line. When REDUCE is ready for more input, it will
prompt you with an asterisk at the left margin.

To terminate the lesson and return to the operating system, type an
interrupt character (DEC: control-C ) at any time.

Expressions can be formed using "**", "*", "/", "+", and "-" to
indicate exponentiation, multiplication, division, addition, and
subtraction or negation respectively. Assignments to variables can
be done using the operator ":=". For example:;

R2D2 := (987654321/15)**3;

COMMENT The immediately preceding line, without a semicolon, is the
computed output generated by the line with a semicolon which precedes
it. Note that exact indefinite-precision rational arithmetic was
used, in contrast to the limited-precision arithmetic of traditional
programming languages.

We can use the name R2D2 to represent its value in subsequent
expressions such as;

R2D2 := -R2D2/25 + 3*(13-5);

COMMENT Now I will give you an opportunity to try some analogous
computations.  To do so, type the letter N followed by a carriage return
in response to our question "CONT?" (You could type Y if you wish to
relinquish this opportunity, but I strongly recommend reinforced
learning through active participation.) After trying an example or two,
type the command "CONT" terminated by a semicolon and carriage return
when you wish to proceed with the rest of the lesson.  To avoid
interference with our examples, please don't assign anything to any
variable names beginning with the letters E through I.  To avoid lengthy
delays, I recommend keeping all of your examples approximately as
trivial as ours, saving your more ambitious experiments until after the
lesson.  If you happen to initiate a calculation requiring an undue
amount of time to evaluate or to print, you can abort that computation
with an interrupt to get back to the operating system.  Restart REDUCE,
followed by the statement "IN LESS1", followed by a semicolon and
return, to restart the lesson at the beginning;

PAUSE;

COMMENT  Now watch this example illustrating some more dramatic
differences from traditional scientific programming systems:;

E1 := 2*G + 3*G + H**3/H;

COMMENT Note how we are allowed to use variables to which we have
assigned no values! Note too how similar terms and similar factors
are combined automatically. REDUCE also automatically expands
products and powers of sums, together with placing expressions over
common denominators, as illustrated by the examples:;

E2 := E1*(F+G);
E2 := E1**2;
E1+1/E1;

COMMENT Our last example also illustrates that there is no need to
assign an expression if we do not plan to use its value later. Try
some similar examples:;

PAUSE;

COMMENT It is not always desirable to expand expressions over a
common denominator, and we can use the OFF statement to turn off
either or both computational switches which control these
transformations. The switch named EXP controls EXPansion, and the
switch named MCD controls the Making of Common Denominators;

OFF EXP, MCD;
E2 := E1**2 $
E2 := E2*(F+G) + 1/E1;
COMMENT To turn these switches back on, we type:;

ON EXP, MCD;

COMMENT Try a few relevant examples with these switches turned off
individually and jointly;

PAUSE;

ON EXP;   % Just in case you turned it off.

COMMENT  Now consider the example:;

E2 := (2*(F*H)**2 - F**2*G*H - (F*G)**2 - F*H**3 + F*H*G**2 - H**4
       + G*H**3)/(F**2*H - F**2*G - F*H**2 + 2*F*G*H - F*G**2
       - G*H**2 + G**2*H);

COMMENT It is not obvious, but the numerator and denominator of this
expression share a nontrivial common divisor which can be canceled.
To make REDUCE automatically cancel greatest common divisors, we turn
on the computational switch named GCD:;

ON GCD;
E2;

COMMENT The switch is not on by default because

    1.  It can consume a lot of time.
    2.  Often we know in advance the few places where a nontrivial
        GCD can occur in our problem.
    3.  Even without GCD cancellation, expansion and common denomin-
        ators guarantee that any rational expression which is equiv-
        alent to zero simplifies to zero.
    4.  When the denominator is the greatest common divisor, such
        as for  (X**2 - 2*X + 1)/(X-1),  REDUCE cancels the
        greatest common divisor even when GCD is OFF.
    5.  GCD cancellation sometimes makes expressions more
        complicated, such as with  (F**10 - G**10)/(F**2 + F*G -2*G**2).

Try the examples mentioned in this comment, together with one
or two other relevant ones;

PAUSE;

COMMENT Exact rational arithmetic can consume an alarming amount of
computer time when the constituent integers have quite large
magnitudes, and the results become awkward to interpret
qualitatively. When this is the case and somewhat inexact numerical
coefficients are acceptable, we can have the arithmetic done floating
point by turning on the computational switch ROUNDED. With this switch
on, any non-integer rational numbers are approximated by floating-point
numbers, and the result of any arithmetic operation is floating-point
when any of its operands is floating point. For example:;

ON ROUNDED;
E1:= (12.3456789E3 *F + 3*G)**2 + 1/2;

COMMENT With ROUNDED off, any floating-point constants are
automatically approximated by rational numbers:;

OFF ROUNDED;
E1 := 12.35*G;
PAUSE;

COMMENT A number of elementary functions, such as SIN, COS and LOG,
are built into REDUCE. Moreover, the letter E represents the base of
the natural logarithms, so the exponentiation operator enables us to
represent the exponential function as well as fractional powers. For
example:;

E1:= SIN(-F*G) + LOG(E) + (3*G**2*COS(-1))**(1/2);

COMMENT What automatic simplifications can you identify in this
example?

Note that most REDUCE implementations do not approximate the values
of these functions for non-trivial numerical arguments, and exact
computations are generally impossible for such cases.

Experimentally determine some other built-in simplifications for
these functions;

PAUSE;

COMMENT Later you will learn how to introduce additional
simplifications and additional functions, including numerical
approximations for examples such as COS(1).

Differentiation is also built-into REDUCE. For example, to
differentiate E1 with respect to F;

E2 := DF(E1,F);

COMMENT To compute the second derivative of E2 with respect to G, we
can type either DF(E2,G,2) or DF(E1,F,1,G,2) or DF(E1,F,G,2) or
DF(E1,G,2,F,1) or;

DF(E1,G,2,F);

COMMENT Surely you can't resist trying a few derivatives of your
own! (Careful, High-order derivatives can be alarmingly complicated);

PAUSE;

COMMENT REDUCE uses the name I to represent (-1)**(1/2),
incorporating some simplification rules such as replacing I**2 by -1.
Here is an opportunity to experimentally determine other
simplifications such as for I**3, 1/I**23, and (I**2-1)/(I-1);

PAUSE;

COMMENT Clearly it is inadvisable to use E or I as a variable. T is
also inadvisable for reasons that will become clear later.

The value of a variable is said to be "bound" to the variable.  Any
variable to which we have assigned a value is called a bound variable,
and any variable to which we have not assigned a value is called an
indeterminate.  Occasionally it is desirable to make a bound variable
into an indeterminate, and this can be done using the CLEAR command.
For example:;

CLEAR R2D2, E1, E2;
E2;

COMMENT If you suspect that a degenerate assignment, such as E1:=E1,
would suffice to clear a bound variable, try it on one of your own
bound variables:;

PAUSE;

COMMENT REDUCE also supports matrix algebra, as illustrated by the
following sequence:;

MATRIX E1(4,1), F, H;

COMMENT This declaration establishes E1 as a matrix with 4 rows and 1
column, while establishing F and H as matrices of unspecified size.
To establish element values (and sizes if not already established in
the MATRIX declaration), we can use the MAT function, as illustrated
by the following example:;

H := MAT((LOG(G), G+3), (G, 5/7));

COMMENT Only after establishing the size and establishing the element
values of a declared matrix by executing a matrix assignment can we
refer to an individual element or to the matrix as a whole. For
example to increase the last element of H by 1 then form twice the
transpose of H, we can type;

H(2,2) := H(2,2) + 1;
2*TP(H);

COMMENT To compute the determinant of H:;

DET(H);

COMMENT  To compute the trace of H:;

TRACE(H);

COMMENT To compute the inverse of H, we can type H**(-1) or 1/H.  To
compute the solution to the equation H*F = MAT((G),(2)), we can
left-multiply the right-hand side by the inverse of H:;

F := 1/H*MAT((G),(2));

COMMENT Notes:
   1.  MAT((G),(2))/H would denote right-multiplication by the
       inverse, which is not what we want.
   2.  Solutions for a set of right-hand-side vectors are most
       efficiently computed simultaneously by collecting the right-
       hand sides together as the columns of a single multiple-column
       matrix.
   3.  Subexpressions of the form 1/H*... or H**(-1)*... are computed
       more efficiently than if the inverse is computed separately in
       a previous statement, so separate computation of the inverse
       is advisable only if several solutions are desired and if
       they cannot be computed simultaneously.
   4.  MAT must have parentheses around each row of elements even if
       there is only one row or only one element per row.
   5.  References to individual matrix elements must have exactly two
       subscripts, even if the matrix has only one row or one column.

Congratulations on completing lesson 1!  I urge you to try a sequence of
more ambitious examples for the various features that have been
introduced, in order to gain some familiarity with the relationship
between problem size and computing time for various operations. (In most
implementations, the command "ON TIME" causes computing time to be
printed.) I also urge you to bring to the next lesson appropriate
examples from textbooks, articles, or elsewhere, in order to experience
the decisive learning reinforcement afforded by meaningful personal
examples that are not arbitrarily contrived.

To avoid the possibility of interference from assignments and declar-
ations in lesson 1, it is wise to execute lesson 2 in a fresh REDUCE
job, when you are ready.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less2.red0000755000175000017500000002131511526203062023723 0ustar  giovannigiovanniCOMMENT

                 REDUCE INTERACTIVE LESSON NUMBER 2

                         David R. Stoutemyer
                        University of Hawaii


COMMENT This is lesson 2 of 7 REDUCE lessons.  Please refrain from
using variables beginning with the letters F through H during the
lesson.

By now you have probably had the experience of generating an
expression, and then having to repeat the calculation because you
forgot to assign it to a variable or because you did not expect to
want to use it later.  REDUCE maintains a history of all inputs and
computation during an interactive session. (Note, this is only for
interactive sessions.) To use an input expression in a new
computation, you can say

        INPUT(n)

where n is the appropriate command number.  The evaluated computations
can be accessed through

        WS(n)    or simply WS

if you wish to refer to the last computation.  WS stands for Work Space.
As with all REDUCE expressions, these can also be used to create new
expressions:

        (INPUT(n)/WS(n2))**2

Special characters can be used to make unique REDUCE variable names
that reduce the chance of accidental interference with any other
variables.  In general, whenever you want to include an otherwise
forbidden character such as * in a name, merely precede it by an
exclamation point, which is called the escape character.  However,
pick a character other than "*", which is used for many internal
REDUCE names.  Otherwise, if most of us use "*" the purpose will be
defeated;

G+!%H;
WS;
PAUSE;

COMMENT You can also name the expression in the workspace by using
the command SAVEAS, for example:;

SAVEAS GPLUSH;
GPLUSH;
PAUSE;

COMMENT You may have noticed that REDUCE imposes its own order on the
indeterminates and functional forms that appear in results, and that
this ordering can strongly affect the intelligibility of the results.
For example:;

G1:= 2*H*G + E + F1 + F + F**2 + F2 + 5 + LOG(F1) + SIN(F1);

COMMENT The ORDER declaration permits us to order indeterminates and
functional forms as we choose. For example, to order F2 before F1,
and to order F1 before all remaining variables:;

ORDER F2, F1;
G1;
PAUSE;

COMMENT Now suppose we partially change our mind and decide to
order LOG(F1) ahead of F1;

ORDER LOG(F1), F1;
G1;

COMMENT Note that any other indeterminates or functional forms under
the influence of a previous ORDER declaration, such as F2, rank
before those mentioned in the later declaration.  Try to determine
the default ordering algorithm used in your REDUCE implementation, and
try  to achieve some delicate  rearrangements using the ORDER
declaration.;

PAUSE;

COMMENT You may have also noticed that REDUCE factors out any
number, indeterminate, functional form, or the largest integer power
thereof which exactly divides every term of a result or every term of
a parenthesized subexpression of a result. For example:;

ON EXP, MCD;
G1:= F**2*(G**2 + 2*G) + F*(G**2+H)/(2*F1);

COMMENT This process usually leads to more compact expressions and
reveals important structural information. However, the process can
yield results which are difficult to interpret if the resulting
parentheses are nested more than about two levels, and it is often
desirable to see a fully expanded result to facilitate direct
comparison of all terms. To suppress this monomial factoring, we can
turn off an output control switch named ALLFAC;

OFF ALLFAC;
G1;
PAUSE;

COMMENT The ALLFAC monomial-factorization process is strongly
dependent upon the ordering.  We can achieve a more selective monomial
factorization by using the FACTOR declaration, which declares a
variable to have FACTOR status.  If any indeterminates or functional
forms occurring in an expression are in FACTOR status when the
expression is printed, terms having the same powers of the
indeterminates or functional forms are collected together, and the
power is factored out.  Terms containing two or more indeterminates or
functional forms under FACTOR status are not included in this monomial
factorization process.  For example:;

OFF ALLFAC; FACTOR F; G1;
FACTOR G; G1; PAUSE;

COMMENT We can use the REMFAC command to remove items from factor
status;

REMFAC F;
G1;

COMMENT ALLFAC can still have an effect on the coefficients of the
monomials that have been factored out under the influence of FACTOR:;

ON ALLFAC;
G1;
PAUSE;

COMMENT It is often desirable to distribute denominators over all
factored subexpressions generated under the influence of a FACTOR
declaration, such as when we wish to view a result as a polynomial or
as a power series in the factored indeterminates or functional forms,
with  coefficients which are rational  functions of any other
indeterminates or functional forms.  (A mnemonic aid is: think RAT
for RATional-function coefficients.) For example:;

ON RAT;
G1;
PAUSE;

COMMENT RAT has no effect on expressions which have no
indeterminates or functional forms under the influence of FACTOR.
The related but different DIV switch permits us to distribute numerical
and monomial factors of the denominator over every term of the
numerator, expressing these distributed portions as rational-number
coefficients and negative power factors respectively. (A mnemonic
aid: DIV DIVides by monomials.) The overall effect can also depend
strongly on whether the RAT switch is on or off.  Series and
polynomials are often most attractive with RAT and DIV both on;

ON DIV, RAT;
G1;
OFF RAT;
G1;
PAUSE;

REMFAC G;
G1;
PAUSE;

COMMENT With a very complicated result, detailed study of the result
is often facilitated by having each new term begin on a new line,
which can be accomplished using the LIST switch:;

ON LIST;
G1;
PAUSE;

COMMENT  In various combinations, ORDER, FACTOR, the computational
switches EXP, MCD, GCD, and ROUNDED, together with the output control
switches ALLFAC, RAT, DIV, and LIST provide a variety of output
alternatives. With experience, it is usually possible to use these
tools to produce a result in the desired form, or at least in a form
which is far more acceptable than the one produced by the default
settings.  I encourage you to experiment with various combinations
while this information is fresh in your mind;

PAUSE;
OFF LIST, RAT, DIV, GCD, ROUNDED;
ON ALLFAC, MCD, EXP;

COMMENT You may have wondered whether or not an assignment to a
variable, say F1, automatically updates the value of a bound
variable, say G1, which was previously assigned an expression
containing F1. The answer is:

   1.  If F1 was a bound variable in the expression when it was set
       to G1, then subsequent changes to the value of F1 have no
       effect on G1 because all traces of F1 in G1 disappeared after
       F1 contributed its value to the formation of G1.
   2.  If F1 was an indeterminate in an expression previously
       assigned to G1, then for each subsequent use of G1, F1
       contributes its current value at the time of that use.

These phenomena are illustrated by the following sequence:;

PAUSE;
F2 := F;
G1 := F1 + F2;
F2 := G;
G1;
F1 := G;
F1 := H;
G1;
F1 := G;
G1;

COMMENT  Experience indicates that it is well worth studying this
sequence and experimenting with others until these phenomena are
thoroughly understood. You might, for example, mimic the above
example, but with another level of evaluation included by inserting a
statement analogous to "Q9:=G1" after "F2:=G", and inserting an
expression analogous to "Q9" at the end, to compare with G1. ;

PAUSE;
COMMENT Note also, that if an indeterminate is used directly, or
indirectly through another expression, in evaluating itself, this will
lead to an infinite recursion.  For example, the following expression
results in infinite recursion at the first evaluation of H1.  On some
machines (Vax/Unix, IBM) this will cause REDUCE to terminate abnormally.

        H1 := H1 + 1

You may experiment with this problem, later at your own risk.

It is often desirable to make an assignment to an indeterminate in a
previously established expression have a permanent effect, as if the
assignment were done before forming the expression.  This can be done by
using the substitute function, SUB.

G1 := F1 + F2;

H1 := SUB(F1=H, G1);
F1 := G;
H1;

COMMENT Note the use of "=" rather than ":=" in SUB. This function
is also valuable for achieving the effect of a local assignment
within a subexpression, without binding the involved indeterminate or
functional form in the rest of the expression or wherever else it
occurs. More generally the SUB function can have any number of
equations of  the form  "indeterminate or  functional form  =
expression", separated by commas, before the expression which is its
last argument. Try devising a set of examples which reveals whether
such multiple substitutions are done left to right, right to left, in
parallel, or unpredictably.

This is the end of lesson 2. To execute lesson 3, start a fresh
REDUCE job.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less4.red0000755000175000017500000005264711526203062023741 0ustar  giovannigiovanniCOMMENT



                 REDUCE INTERACTIVE LESSON NUMBER 4

                         David R. Stoutemyer
                        University of Hawaii


COMMENT This is lesson 4 of 7 REDUCE lessons.  As before, please
refrain from using variables beginning with the letters F through H
during the lesson.

In  theory, assignments and LET  statements are sufficient to
accomplish anything that any other practical computing mechanism is
capable of doing. However, it is more convenient for some purposes
to use function procedures which can employ branched selection and
iteration as do most traditional programming languages. As a trivial
example, if we invariably wanted to replace cotangents with the
corresponding tangents, we could type;

ALGEBRAIC PROCEDURE COT(X); 1/TAN(X);

COMMENT As an example of the use of this function, we have;

COT(LOG(F));

PAUSE;
COMMENT Note:
   1.  The procedure definition automatically declares the procedure
       name as an operator.
   2.  A procedure can be executed any time after its definition,
       until it is cleared.
   3.  Any parameters are dummy variables that are distinct from
       any other variables with the same name outside the procedure
       definition, and the corresponding arguments can be
       arbitrary expressions.
   4.  The value returned by a procedure is the value of the
       expression following the procedure statement.

We can replace this definition with a different one;

ALGEBRAIC PROCEDURE COT(Y); COS(Y)/SIN(Y);

G1:= COT(LOG(F));

COMMENT In place of the word ALGEBRAIC, we can optionally use the
word INTEGER when a function always returns an integer value, or we
can optionally use the word REAL when a function always returns a
floating-point value.

Try writing a procedure definition for the sine in terms of the
cosine, then type G1;

PAUSE;

COMMENT Here is a more complicated function which introduces the
notion of a conditional expression;

ALGEBRAIC PROCEDURE SUMCHECK(AJ, J, M, N, S);
   COMMENT  J is an indeterminate and the other parameters are
      expressions.  This function returns the global variable named
      PROVED if the function can inductively verify that S equals the
      sum of AJ for J going from M through N, returning the global
      variable named UNPROVED otherwise.  For the best chance of
      proving a correct sum, the function should be executed under
      the influence of ON EXP, ON MCD, and any other user-supplied
      simplification rules relevant to the expression classes of AJ
      and S;
   IF SUB(J=M,AJ)-SUB(N=M,S) NEQ 0
       OR S+SUB(J=N+1,AJ)-SUB(N=N+1,S) NEQ 0 THEN UNPROVED
    ELSE PROVED;

ON EXP, MCD;

CLEAR X, J, N;

SUMCHECK(J, J, 1, N, N*(N+1)/2);

SUMCHECK(X**J, J, 0, N, (X**(N+1)-1)/(X-1));

COMMENT Within procedures of this sort a global variable is any
variable which is not one of the parameters, and a global variable
has the value, if any, which is current for that name at the point
from where the procedure is used.

;PAUSE; COMMENT
Conditional expressions have the form

   IF condition THEN expression1 ELSE expression2.

There are generally several equivalent ways of writing a conditional
expression. For example, the body of the above procedure could have
been written

   IF SUB(J=M,A)-SUB(N=M,S)=0 AND S+SUB(J=N+1,A)-SUB(N=N+1,S)=0
      THEN PROVED
    ELSE UNPROVED.

Note how we compare a difference with 0, rather than comparing
two nonzero expressions, for reasons explained in lesson 3.

As an exercise, write a procedure analogous to SUMCHECK for proving
closed-form product formulas, then test it on the valid formula that
COS(N*X) equals the product of COS(J*X)/COS(J*X-X) for J ranging from
1 through N.  You do not need to include prefatory comments
describing parameters and the returned value until you learn how to
use a text editor;

PAUSE;

COMMENT Most REDUCE statements are also expressions because they have
a value. The value is usually 0 if nothing else makes sense, but I
will mention the value only if it is useful.

The value of an assignment statement is the assigned value. Thus a
multiple assignment, performed right to left, can be achieved by a
sequence of the form

    "variable1 := variable2 := ... := variableN := expression",

moreover, assignments can be inserted within ordinary expressions
such as X*(Y:=5). Such assignments must usually be parenthesized
because of the low precedence of the assignment operator, and
excessive use of this construct tends to make programs confusing.

;PAUSE;COMMENT

REDUCE treats as a single expression any sequence of statements
preceded by the pair of adjacent characters << and followed by the
pair >>.  The value of such a group expression is the value of the
last statement in the group.

Group expressions facilitate the implementation of tasks that are
most easily stated as a sequence of operations.  However, such
sequences often  utilize temporary  variables to  count,  hold
intermediate results, etc., and it is hazardous to use global
variables for that purpose. If a top-level REDUCE statement or
another function directly or indirectly uses that variable name, then
its value or its virgin indeterminate status there might be damaged
by our use as a temporary variable. In large programs or programs
which rely on the  work of others, such interference has a
nonnegligible probability, even if all programmers agree to the
convention that all such temporary variables should begin with the
function name as a prefix and all programmers attempt to comply with
the convention. For this reason, REDUCE provides another
expression-valued sequence called a BEGIN-block, which permits the
declaration of local variables that are distinct from any other
variables outside the block having the same name. Another advantage
of using local variables for temporary variables is that the perhaps
large amount of storage occupied by their values can be reclaimed
after leaving their block.

;PAUSE;COMMENT
A BEGIN-block consists of the word BEGIN, followed by optional
declarations, followed by a sequence of statements, followed by the
word END.  Within BEGIN-blocks, it is often convenient to return
control and a value from someplace other than the end of the block.
Control and a value may be returned via a
RETURN-statement of the form

         RETURN expression
or
          RETURN,

0 being returned in the latter case.  A BEGIN-block does not return
the value of the last statement.  If a value is to be returned RETURN
must be used.  These features and others are illustrated by the
following function;

PAUSE;

ALGEBRAIC PROCEDURE LIMIT(EX, INDET, PNT);
   BEGIN COMMENT This function uses up through 4 iterations of
      L'Hospital's rule to attempt determination of the limit of
      expression EX as indeterminate INDET approaches expression
      PNT.  This function is intended for the case where
      SUB(INDET=PNT, EX) yields 0/0, provoking a zero-divide
      message.  This function returns the global variable named
      UNDEFINED when the limit is 0 dividing an expression which did
      not simplify to 0, and this function returns the global
      variable named UNKNOWN when it cannot determine the limit.
      Otherwise this function returns an expression which is the
      limit. For best results, this function should be executed
      under the influence of ON EXP, ON MCD, and any user-supplied
      simplification rules appropriate to the expression classes of
      EX and PNT;
   INTEGER ITERATION;
   SCALAR N, D, NLIM, DLIM;
   ITERATION := 0;
   N := NUM(EX);
   D := DEN(EX);
   NLIM := SUB(INDET=PNT, N);
   DLIM := SUB(INDET=PNT, D);
   WHILE NLIM=0 AND DLIM=0 AND ITERATION<5 DO <<
      N := DF(N, INDET);
      D := DF(D, INDET);
      NLIM := SUB(INDET=PNT, N);
      DLIM := SUB(INDET=PNT, D);
      ITERATION := ITERATION + 1 >>;
   RETURN (IF NLIM=0 THEN
              IF DLIM=0 THEN UNKNOWN
              ELSE 0
           ELSE IF DLIM=0 THEN UNDEFINED
           ELSE NLIM/DLIM)
   END;

% Examples follow..
PAUSE;

G1 := (E**X-1)/X;

% Evaluation at 1, causes Zero denominator error at top level, continue
% anyway.
SUB(X=0, G1);

LIMIT(G1, X, 0);

G1:= ((1-X)/LOG(X))**2;

% Evaluation at 1, causes Zero denominator error at top level, continue
% anyway.
SUB(X=1, G1);

LIMIT(G1, X, 1);

COMMENT  Note:
   1.  The idea behind L'Hospital's rule is that as long as the
       numerator and denominator are both zero at the limit point, we
       can replace them by their derivatives without altering the
       limit of the quotient.
   2.  Assignments within groups and BEGIN-blocks do not
       automatically cause output.
   3.  Local variables are declared INTEGER, REAL, or SCALAR, the
       latter corresponding to the same most general class denoted by
       ALGEBRAIC in a procedure statement.  All local variables are
       initialized to zero, so they cannot serve as indeterminates.
       Moreover, if we attempted to overcome this by clearing them,
       we would clear all variables with their names.
   4.  We do not declare the attributes of parameters.
   5.  The NUM and DEN functions respectively extract the numerator
       and denominator of their arguments.  (With OFF MCD, the
       denominator of  1+1/X would be 1.)
   6.  The WHILE-loop has the general form

          WHILE condition DO statement.

       REDUCE also has a "GO TO" statement, and using commas rather
       than semicolons to prevent termination of this comment, the
       above general form of a WHILE-loop is equivalent to

          BEGIN  GO TO TEST,
       LOOP: statement,
       TEST: IF condition THEN GO TO LOOP,
          RETURN 0
          END  .

       A GOTO statement is permitted only within a block, and the
       GOTO statement cannot refer to a label outside the same block
       or to a label inside a block that the GOTO statement is not
       also within.  Actually, 99.99% of REDUCE BEGIN-blocks are less
       confusing if written entirely without GOTOs, and I mention
       them primarily to explain WHILE-loops in terms of a more
       primitive notion.

;PAUSE;COMMENT
   7.  The LIMIT function provides a good illustration of nested
       conditional expressions.  Proceeding sequentially through such
       nests, each ELSE clause is matched with the nearest preceding
       unmatched THEN clause in the group or block.  In order to help
       reveal their structure, I have consistently indented nested
       conditional statements, continuations of multi-line statements
       and loop-bodies according to one of the many staunchly
       defended indentation styles. However, older versions of REDUCE
       may ruin my elegant style.  If you have such a version, I
       encourage you to indent nonetheless, in anticipation of a
       replacement for your obsolete version.  (If you have an
       instructor, I also urge you to humor him by adopting his style
       for the duration of the course.)
   8.  PL/I programmers take note:  "IF ... THEN ... ELSE ..." is
       regarded as one expression, and semicolons are used to
       separate rather than terminate statements.  Moreover, BEGIN
       and END are brackets rather than statements, so a semicolon is
       never needed immediately after BEGIN, and a semicolon is
       necessary immediately preceding END only if the END is
       intended as a labeled destination for a GOTO. Within
       conditional expressions, an inappropriate semicolon after an
       END, a >>, or an ELSE-clause is likely to be one of your most
       prevalent mistakes.;
PAUSE;

COMMENT The next exercise is based on the above LIMIT function:

For the sum of positive expressions AJ for J ranging from some finite
initial value to infinity, the infinite series converges if the limit
of the ratio SUB(J=J+1,AJ)/AJ is less than 1 as J approaches
infinity.  The series diverges if this limit exceeds 1, and the test
is inconclusive if the limit is 1.  To convert the problem to the
form required by the above LIMIT program, we can replace J by the
indeterminate 1/!*FOO in the ratio, then take the limit as !*FOO
approaches zero. (Since an indeterminate is necessary here, I picked
the weird name !*FOO to make the chance of conflict negligible)

After writing such a function to perform the ratio test, test it on
the examples AJ=J/2**J, AJ=1/J**2, AJ=2**J/J**10, and AJ=1/J.  (The
first two converge and the second two diverge);

PAUSE;

COMMENT  Groups or blocks can be used wherever any arbitrary
expression is allowed, including the right-hand side of a LET rule.

The need for loops with an integer index variable running from a
given initial value through a given final value by a given increment
is so prevalent that REDUCE offers a convenient special way of
accomplishing it via a FOR-loop, which has the general form

   FOR index := initial STEP increment UNTIL final DO statement .

Except for the use of commas as statement separators, this construct
is equivalent to

   BEGIN INTEGER index,
   index := initial,
   IF increment>0 THEN WHILE index <= final DO <<
      statement,
      index := index + increment >>
   ELSE WHILE index >= final DO <<
      statement,
      index := index + increment >>,
   RETURN 0
   END .

;PAUSE;COMMENT
Note:
   1.  The index variable is automatically declared local to the FOR-
       loop.
   2.  "initial", "increment", and "final" must have integer values.
   3.  FORTRAN programmers take note:  the body of the loop is not
       automatically executed at least once.
   4.  An acceptable abbreviation for "STEP 1 UNTIL" is ":".
   5.  Since the WHILE-loop and the FOR-loop have implied BEGIN-
       blocks, a RETURN statement within their bodies cannot transfer
       control further than the point following the loops.

Another frequent need is to produce output from within a group or
block, because such output is not automatically produced. This can
be done using the WRITE-statement, which has the form

WRITE expression1, expression2, ..., expressionN.

Beginning a new line with expression1, the expressions are printed
immediately adjacent to each other, split over line boundaries if
necessary. The value of the WRITE-statement is the value of its last
expression, and any of the expressions can be a character-string
of the form "character1 character2 ... characterM" .

Inserting the word "WRITE" on a separate line before an assignment
is convenient for debugging, because the word is then easily deleted
afterward. These features and others are illustrated by the following
equation solver;

PAUSE;
OPERATOR SOLVEFOR, SOLN;

FOR ALL X, LHS, RHS LET SOLVEFOR(X, LHS, RHS) = SOLVEFOR(X, LHS-RHS);

COMMENT LHS and RHS are expressions such that P=NUM(LHS-RHS) is a
polynomial of degree at most 2 in the indeterminate or functional
form X.  Otherwise an error message is printed.  As a convenience,
RHS can be omitted if it is 0.  If P is quadratic in X, the two
values of X which satisfy P=0 are stored as the values of the
functional forms SOLN(1) and SOLN(2).  If P is a first-degree
polynomial in X, SOLN(1) is set to the one solution.  If P simplifies
to 0, SOLN(1) is set to the identifier ARBITRARY.  If P is an
expression which does not simplify to zero but does not contain X,
SOLN(1) is set to the identifier NONE.  In all other cases, SOLN(1)
is set to the identifier UNKNOWN.  The function then returns the
number of SOLN forms which were set.  This function prints a well
deserved warning message if the denominator of LHS-RHS contains X. If
LHS-RHS is not polynomial in X, it is wise to execute this function
under the influence of ON GCD;

PAUSE;
FOR ALL X, LHSMRHS LET SOLVEFOR(X, LHSMRHS) =
   BEGIN INTEGER HIPOW;  SCALAR TEMP, CFLIST, CF0, CF1, CF2;
   IF LHSMRHS = 0 THEN <<
      SOLN(1) := ARBITRARY;
      RETURN 1 >>;
   CFLIST :=  COEFF(LHSMRHS, X);
   HIPOW := HIPOW!*;
   IF HIPOW = 0 THEN <<
      SOLN(1) := NONE;
      RETURN 1 >>;
   IF HIPOW > 2 THEN <<
      SOLN(1) := UNKNOWN;
      RETURN 1 >>;
   IF HIPOW = 1 THEN <<
      SOLN(1) := FIRST(CFLIST)/SECOND(CFLIST);
      IF DF(SUB(X=!*FOO, SOLN(1)), !*FOO) NEQ 0 THEN
         SOLN(1) := UNKNOWN;
      RETURN 1 >>;
   CF0 := FIRST(CFLIST)/THIRD(CFLIST);
   CF1 := -SECOND(CFLIST)/THIRD(CFLIST)/2;
   IF DF(SUB(X=!*FOO, CF0), !*FOO) NEQ 0
         OR DF(SUB(X=!*FOO, CF1), !*FOO) NEQ 0  THEN <<
      SOLN(1) := UNKNOWN;
      RETURN 1 >>;
   TEMP := (CF1**2 - CF0)**(1/2);
   SOLN(1) := CF1 + TEMP;
   SOLN(2) := CF1 - TEMP;
   RETURN 2
   END;

COMMENT And some examples;
PAUSE;

FOR K:=1:SOLVEFOR(X, A*X**2, -B*X-C) DO WRITE SOLN(K) := SOLN(K);

FOR K:=1:SOLVEFOR(LOG(X), 5*LOG(X)-7) DO WRITE SOLN(K) := SOLN(K);

FOR K:=1:SOLVEFOR(X, X, X) DO WRITE SOLN(K) := SOLN(K);

FOR K:= 1:SOLVEFOR(X, 5) DO WRITE SOLN(K) := SOLN(K);

FOR K:=1:SOLVEFOR(X, X**3+X+1) DO WRITE SOLN(K) := SOLN(K);

FOR K:=1:SOLVEFOR(X, X*E**X, 1) DO WRITE SOLN(K) := SOLN(K);

G1 := X/(E**X-1);

%Results in 'invalid as POLYNOMIAL' error, continue anyway;
FOR K:=1:SOLVEFOR(X, G1) DO WRITE SOLN(K) := SOLN(K);

SUB(X=SOLN(1), G1);

LIMIT(G1, X, SOLN(1));

PAUSE;

COMMENT Here we have used LET rules to permit the user the
convenience of omitting default arguments. (Function definitions have
to have a fixed number of parameters.)

Array elements are designated by the same syntax as matrix elements
and as functional forms having integer arguments. Here are some
desiderata that may help you decide which of these alternatives is
most appropriate for a particular application:
   1.  The lower bound of each array subscript is 0, vs. 1 for
       matrices vs unrestricted for functional forms.
   2.  The upper bound of each array subscript must have a specific
       integer value at the time the array is declared, as must the
       upper bounds of matrix subscripts when a matrix is first
       referred to, on the left side of a matrix assignment.  In
       contrast, functional forms never require a commitment to a
       specific upper bound.
   3.  An array can have any fixed number of subscripts, a matrix
       must have exactly 2, and a functional form can have a varying
       arbitrary number.
   4.  Matrix operations, such as transpose and inverse, are built-in
       only for matrices.
   5.  For most implementations, access to array elements requires
       time approximately proportional to the number of subscripts,
       whereas access to matrix elements takes time approximately
       proportional to the sum of the two subscript values, whereas
       access to functional forms takes average time approximately
       proportional to the number of bound functional forms having
       that name.
   6.  Only functional forms permit the effect of a subscripted
       indeterminate such as having an answer be "A(M,N) + B(3,4)".
   7.  Only functional forms can be used alone in the LHS of LET
       substitutions.
;PAUSE; COMMENT
   8.  All arrays, matrices, and operators are global regardless
       of where they are declared, so declaring them within a BEGIN
       block does not afford the protection and automatic storage
       recovery of local variables.  Moreover, clearing them within a
       BEGIN-block will clear them globally, and functions
       cannot return an array or a matrix value.  Furthermore, REDUCE
       parameters are referenced by value, which means that an
       assignment to a parameter has no effect on the corresponding
       argument.  Thus, matrix or array results cannot be transmitted
       back to an argument either.
   9.  It is often advantageous to use two or more of these
       alternatives to represent a set of quantities at different
       times in the same program. For example, to get the general
       form of the inverse of a 3-by-3 matrix, we could write

          MATRIX AA,
          OPERATOR A,
          AA := MAT((0,0,0),(0,0,0),(0,0,0)),
          FOR J:=1:3 DO
             FOR K:=1:3 DO AA(J,K) := A(J,K),
          AA**-1 .

       As another example, we might use an array to receive some
       polynomial coefficients, then transfer the values to a matrix
       for inversion.

;PAUSE;COMMENT
The COEFF function is the remaining new feature in our SOLVEFOR
example.  The first argument is a polynomial expression in the
indeterminate or functional form which is the second argument.  The
polynomial coefficients of the integer powers of the indeterminate are
returned as a LIST, with the independent coefficient first.  The
highest and lowest non-zero powers are placed in the variables HIPOW!*
and LOWPOW!* respectively.

A LIST is a kind of data structure, just as matrices and arrays are.
It is represented as comma separated list of elements enclosed in
braces.  The elements can be accessed with the functions FIRST,
SECOND, THIRD, PART(i) which returns the i-th element, and REST, which
returns a list of all but the first element.  For example;

CLEAR X;

COEFF(X**5+2, X);

LOWPOW!*;

HIPOW!*;

PAUSE;

COMMENT COEFF does not check to make sure that the coefficients do not
contain its second argument within a functional form, so that is the
reason we differentiated.  The reason we first substituted the
indeterminate !*FOO for the second argument is that differentiation
does not work with respect to a functional form.

The last exercise is to rewrite the last rule so that we can solve
equations which simplify to the form

   a*x**(m+2*l) + b*x**(m+l) + c*x**m = 0,   where m>=0 and l>=1.

The solutions are

   0,  with multiplicity m,
   x1*E**(2*j*I*pi/l),
   x2*E**(2*j*I*pi/l),   with j = 0, 1, ..., l-1,

where x1 and x2 are the solutions to the quadratic equation

   a*x**2 + b*x + c = 0 .

As a convenience to the user, you might also wish to have a global
switch named SOLVEPRINT, such that when it is nonzero, the solutions
are automatically printed.

This is the end of lesson 4. When you are ready to run lesson 5,
start a new REDUCE job.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/README.txt0000755000175000017500000000121611526203062023673 0ustar  giovannigiovanniThese interactive lessons are from David Stoutemyer and, as you will see from
the comments at the start of the firstm they date from when Reduce was run on
a DEC System 10 or System 20. That means that they are designed to be used
with versions of Reduce dating from the first half of the 1980s. They will
hence be out of date in various respects, and are NOT expected or guaranteed
even to work at all now. But perhaps somebody would like to review them,
check every step and all the results and parhaps extend the series with some
further lessons covering aspects of Reduce introduced over the last 20 years!

                Arthur Norman. March 2010
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less6.red0000755000175000017500000004024711526203062023734 0ustar  giovannigiovanniCOMMENT
 
                  REDUCE INTERACTIVE LESSON NUMBER 6
 
                         David R. Stoutemyer
                        University of Hawaii
 
 
COMMENT This is lesson 6 of 7 REDUCE lessons.  A prerequisite is to
read the pamphlet "An Introduction to LISP", by D. Lurie'.

To avoid confusion between RLISP and the SYMBOLIC-mode algebraic
algorithms, this lesson will treat only RLISP.  Lesson 7 deals with how
the REDUCE algebraic mode is implemented in RLISP and how the user can
interact directly with that implementation.  That is why I suggested
that you run this lesson in RLISP rather than full REDUCE.  If you
forgot or do not have a locally available separate RLISP, then please
switch now to symbolic mode by typing the statement SYMBOLIC;

SYMBOLIC;
PAUSE;

COMMENT Your most frequent mistakes are likely to be forgetting to quote
data examples, using commas as separators within lists, and not puttng
enough levels of parentheses in your data examples.

Now that you have learned from your reading about the built-in RLISP
functions CAR, CDR, CONS, ATOM, EQ, NULL, LIST, APPEND, REVERSE, DELETE,
MAPLIST, MAPCON, LAMBDA, FLAG, FLAGP, PUT, GET, DEFLIST, NUMBERP, ZEROP,
ONEP, AND, EVAL, PLUS, TIMES, CAAR, CADR, etc., here is an opportunity
to reinforce the learning by practice.:  Write expressions using CAR,
CDR, CDDR, etc., (which are defined only through 4 letters between C and
R), to individually extract each atom from F, where;

F := '((JOHN . DOE) (1147 HOTEL STREET) HONOLULU);
PAUSE;

COMMENT  My solutions are CAAR F, CDAR F, CAADR F, CADADR F,
CADDR CADR F, and CADDR F.

Although commonly the "." is only mentioned in conjunction with data, we
can also use it as an infix alias for CONS.  Do this to build from F and
from the data 'MISTER the s-expression consisting of F with MISTER
inserted before JOHN.DOE;

PAUSE;

COMMENT  My solution is ('MISTER . CAR F) . CDR F .

Enough of these inane exercises -- let's get on to something useful!
Let's develop a collection of functions for operating on finite sets.
We will let the elements be arbitrary s-expressions, and we will
represent a set as a list of its elements in arbitrary order, without
duplicates.

Here is a function which determines whether its first argument is a
member of the set which is its second element;

SYMBOLIC PROCEDURE MEMBERP(ELEM, SET1);
   COMMENT  Returns T if s-expression ELEM is a top-level element
      of list SET1, returning NIL otherwise;
   IF NULL SET1 THEN NIL
      ELSE IF ELEM = CAR SET1 THEN T
   ELSE MEMBERP(ELEM, CDR SET1);
MEMBERP('BLUE, '(RED BLUE GREEN));

COMMENT This function illustrates several convenient techniques for
writing functions which process lists:

   1.  To avoid the errors of taking the CAR or the CDR of an atom, and
   to build self confidence while it is not immediately apparent how to
   completely solve the problem, treat the trivial cases first.  For an
   s-expression or list argument, the most trivial cases are generally
   when one or more of the arguments are NIL, and a slightly less
   trivial case is when one or more is an atom. (Note that we will get
   an error message if we use MEMBERP with a second argument which is
   not a list.  We could check for this, but in the interest of brevity,
   I will not strive to make our set-package give set-oriented error
   messages.)

   2.  Use CAR to extract the first element and use CDR to refer to the
   remainder of the list.

   3.  Use recursion to treat more complicated cases by extracting the
   first element and using the same functions on smaller arguments.;

PAUSE;
COMMENT To make MEMBERP into an infix operator we make the declaration;

INFIX MEMBERP;
'(JOHN.DOE) MEMBERP '((FIG.NEWTON) FONZO (SANTA CLAUS));

COMMENT Infix operators associate left, meaning expressions of the form

   (operator1 operator operand2 operator ... operandN)

are interpreted as

   ((...(operand1 operator operand2) operator ... operandN).

Operators may also be flagged RIGHT  by

   FLAG ('(op1 op2 ...), 'RIGHT) .

to give the interpretation

   (operand1 operator (operand2 operator (... operandN))...).

Of the built-in operators, only ".", "*=", "+", and "*" associate right.

If we had made the infix declaration before the function definition, the
latter could have begun with the more natural statement

   SYMBOLIC PROCEDURE ELEM MEMBERP SET  .

Infix functions can also be referred to by functional notation if one
desires.  Actually, an analogous infix operator named MEMBER is already
built-into RLISP, so we will use MEMBER rather than MEMBERP from here
on;

MEMBER(1147, CADR F);

COMMENT Inspired by the simple yet elegant definition of MEMBERP, write
a function named SETP which uses MEMBER to check for a duplicate element
in its list argument, thus determining whether or not the argument of
SETP is a set;

PAUSE;

COMMENT  My solution is;

SYMBOLIC PROCEDURE SETP CANDIDATE;
   COMMENT Returns T if list CANDIDATE is a set, returning NIL
      otherwise;
   IF NULL CANDIDATE THEN T
   ELSE IF CAR CANDIDATE MEMBER CDR CANDIDATE THEN NIL
   ELSE SETP CDR CANDIDATE;
SETP '(KERMIT, (COOKIE MONSTER));
SETP '(DOG CAT DOG);

COMMENT If you used a BEGIN-block, local variables, loops, etc., then
your solution is surely more awkward than mine.  For the duration of the
lesson, try to do everything without groups, BEGIN-blocks, local
variables, assignments, and loops.  Everything can be done using
function composition, conditional expressions, and recursion.  It will
be a mind-expanding experience -- more so than transcendental
meditation, psilopsybin, and EST.  Afterward, you can revert to your old
ways if you disagree.

Thus endeth the sermon.

Incidentally, to make the above definition of SETP work for non-list
arguments all we have to do is insert "ELSE IF ATOM CANDIDATE THEN NIL"
below "IF NULL CANDIDATE THEN T".

Now try to write an infix procedure named SUBSETOF, such that SET1
SUBSETOF SET2 returns NIL if SET1 contains an element that SET2 does
not, returning T otherwise.  You are always encouraged, by the way, to
use any functions that are already builtin, or that we have previously
defined, or that you define later as auxiliary functions;

PAUSE;
COMMENT  My solution is;

INFIX SUBSETOF;
SYMBOLIC PROCEDURE SET1 SUBSETOF SET2;
   IF NULL SET1 THEN T
   ELSE IF CAR SET1 MEMBER SET2 THEN CDR SET1 SUBSETOF SET2
   ELSE NIL;
'(ROOF DOOR) SUBSETOF '(WINDOW DOOR FLOOR ROOF);
'(APPLE BANANA) SUBSETOF '((APPLE COBBLER) (BANANA CREME PIE));

COMMENT  Two sets are equal when they have identical elements, not
necessarily in the same order.  Write an infix procedure named
EQSETP which returns T if its two operands are equal sets, returning
NIL otherwise;

PAUSE;

COMMENT  The following solution introduces the PRECEDENCE declaration;

INFIX EQSETP;
PRECEDENCE EQSETP, =;
PRECEDENCE SUBSETOF, EQSETP;
SYMBOLIC PROCEDURE SET1 EQSETP SET2;
   SET1 SUBSETOF SET2  AND  SET2 SUBSETOF SET1;
'(BALLET TAP) EQSETP '(TAP BALLET);
'(PINE FIR ASPEN) EQSETP '(PINE FIR PALM);

COMMENT The precedence declarations make SUBSETOF have a higher
precedence than EQSETP and make the latter have higher precedence than
"=", which is higher than "AND",.  Consequently, these declarations
enabled me to omit parentheses around "SET1 SUBSUBSETOF SET2" and around
"SET2 SUBSETOF SET1".  All prefix operators are higher than any infix
operator, and to inspect the ordering among the latter, we merely
inspect the value of the global variable named;

PRECLIS!*;

COMMENT Now see if you can write a REDUCE infix function named
PROPERSUBSETOF, which determines if its left operand is a proper subset
of its right operand, meaning it is a subset which is not equal to the
right operand;

PAUSE;

COMMENT  All of the above exercises have been predicates.  In contrast,
the next exercise is to write a function called MAKESET, which returns
a list which is a copy of its argument, omitting duplicates;

PAUSE;

COMMENT  How about;

SYMBOLIC PROCEDURE MAKESET LIS;
   IF NULL LIS THEN NIL
   ELSE IF CAR LIS MEMBER CDR LIS THEN MAKESET CDR LIS
   ELSE CAR LIS . MAKESET CDR LIS;

COMMENT As you may have guessed, the next exercise is to implement an
operator named INTERSECT, which returns the intersection of its set
operands;

PAUSE;

COMMENT  Here is my solution;

INFIX INTERSECT;
PRECEDENCE INTERSECT, SUBSETOF;
SYMBOLIC PROCEDURE SET1 INTERSECT SET2;
   IF NULL SET1 THEN NIL
   ELSE IF CAR SET1 MEMBER SET2
      THEN CAR SET1 . CDR SET1 INTERSECT SET2
   ELSE CDR SET1 INTERSECT SET2;

COMMENT  Symbolic-mode REDUCE has a built-in function named SETDIFF,
which returns the set of elements which are in its first argument but
not the second.  See if you can write an infix definition of a similar
function named DIFFSET;

PAUSE;

COMMENT  Presenting --;

INFIX DIFFSET;
PRECEDENCE DIFFSET, INTERSECT;
SYMBOLIC PROCEDURE LEFT DIFFSET RIGHT;
   IF NULL LEFT THEN NIL
   ELSE IF CAR LEFT MEMBER RIGHT THEN CDR LEFT DIFFSET RIGHT
   ELSE CAR LEFT . (CDR LEFT DIFFSET RIGHT);
'(SEAGULL WREN CONDOR) DIFFSET '(WREN LARK);

COMMENT The symmetric difference of two sets is the set of all elements
which are in only one of the two sets.  Implement a corresponding infix
function named SYMDIFF.  Look for the easy way!  There is almost always
one for examinations and instructional exercises; PAUSE;

COMMENT  Presenting --;
INFIX SYMDIFF;
PRECEDENCE SYMDIFF, INTERSECT;
SYMBOLIC PROCEDURE SET1 SYMDIFF SET2;
   APPEND(SET1 DIFFSET SET2, SET2 DIFFSET SET1);
'(SEAGULL WREN CONDOR) SYMDIFF '(WREN LARK);

COMMENT We can use APPEND because the two set differences are disjoint.

The above set of exercises (exercises of set?) have all returned set
results.  The cardinality, size, or length of a set is the number of
elements in the set.  More generally, it is useful to have a function
which returns the length of its list argument, and such a function is
built-into RLISP.  See if you can write a similar function named SIZEE;

PAUSE;
COMMENT  Presenting --;
SYMBOLIC PROCEDURE SIZEE LIS;
   IF NULL LIS THEN 0
   ELSE 1 + SIZEE CDR LIS;
SIZEE '(HOW MARVELOUSLY CONCISE);
SIZEE '();

COMMENT Literal atoms, meaning atoms which are not numbers, are stored
uniquely in LISP and in RLISP, so comparison for equality of literal
atoms can be implemented by comparing their addresses, which is
significantly more efficient than a character-by-character comparison of
their names.  The comparison operator "EQ" compares addresses, so it is
the most efficient choice when comparing only literal atoms.  The
assignments

   N2 := N1 := 987654321,
   S2 := S1 := '(FROG (SALAMANDER.NEWT)),

make N2 have the same address as N1 and make S2 have the same address as
S1, but if N1 and N2 were constructed independently, they would not
generally have the same address, and similarly for S1 vs. S2.  The
comparison operator "=", which is an alias for "EQUAL", does a general
test for identical s-expressions, which need not be merely two pointers
to the same address.  Since "=" is built-in, compiled, and crucial, I
will define my own differently-named version denoted ".=" as follows:;

PAUSE;
NEWTOK '((!. !=) MYEQUAL);
INFIX EQATOM, MYEQUAL;
PRECEDENCE MYEQUAL, EQUAL;
PRECEDENCE EQATOM,EQ;
SYMBOLIC PROCEDURE S1 MYEQUAL S2;
   IF ATOM S1 THEN
      IF ATOM S2 THEN S1 EQATOM S2
      ELSE NIL
   ELSE IF ATOM S2 THEN NIL
   ELSE CAR S1 MYEQUAL CAR S2 AND CDR S1 MYEQUAL CDR S2;
SYMBOLIC PROCEDURE A1 EQATOM A2;
   IF NUMBERP A1 THEN
      IF NUMBERP A2 THEN ZEROP(A1-A2)
      ELSE NIL
   ELSE IF NUMBERP A2 THEN NIL
   ELSE A1 EQ A2;

COMMENT Here I introduced a help function named EQATOM, because I was
beginning to become confused by detail when I got to the line which uses
EQATOM.  Consequently, I procrastinated on attending to some fine detail
by relegating it to a help function which I was confident could be
successfully written later.  After completing MYEQUAL, I was confident
that it would work provided EQATOM worked, so I could then turn my
attention entirely to EQATOM, freed of further distraction by concern
about the more ambitious overall goal.  It turns out that EQATOM is a
rather handy utility function anyway, and practice helps develop good
judgement about where best to so subdivide tasks.  This psychological
divide-and-conquer programming technique is important in most other
programming languages too.

".=" is different from our previous examples in that ".=" recurses down
the CAR as well as down the CDR of an s-expression;

PAUSE;
COMMENT
If a list has n elements, our function named MEMBERP or the equivalent
built-in function named MEMBER requires on the order of n "=" tests.
Consequently, the above definitions of SETP and MAKESET, which require
on the order of n membership tests, will require on the order of n**2
"=" tests.  Similarly, if the two operands have m and n elements, the
above definitions of SUBSETOF, EQSETP, INTERSECT, DIFFSET, and
SYMDIFF require on the order of m*n "=" tests.  We could decrease the
growth rates to order of n and order of m+n respectively by sorting the
elements before giving lists to these functions.  The best algorithms
sort a list of n elements in the order of n*log(n) element comparisons,
and this need be done only once per input set.  To do so we need a
function which returns T if the first argument is "=" to the second
argument or should be placed to the left of the second argument.  Such a
function, named ORDP, is already built-into symbolic-mode REDUCE, based
on the following rules:

   1.  Any number orders left of NIL.
   2.  Larger numbers order left of smaller numbers.
   4.  Literal atoms order left of numbers.
   3.  Literal atoms order among themselves by address, as determined
       by the built-in RLISP function named ORDERP.
   5.  Non-atoms order left of atoms.
   6.  Non-atoms order among themselves according to ORDP of their
       CARs, with ties broken according to ORDP of their CDRs.

Try writing an analogous function named MYORD, and, if you are in
REDUCE rather than RLISP, test its behavior in comparison to ORDP;

PAUSE;

COMMENT  Whether or not we use sorted sets, we can reduce the
proportionality constant associated with the growth rate by replacing
"=" by "EQ" if the set elements are restricted to literal atoms.
However, with such elements we can use property-lists to achieve the
growth rates of the sorted algorithms without any need to sort the
sets.  On any LISP system that is efficient enough to support REDUCE
with acceptable performance, the time required to access a property of
an atom is modest and very insensitive to the number of distinct
atoms in the program and data.  Consequently, the basic technique
for any of our set operations is:
   1.  Scan the list argument or one of the two list arguments,
       flagging each element as "SEEN".
   2.  During the first scan, or during a second scan of the same
       list, or during a scan of the second list, check each element
       to see whether or not it has already been flagged, and act
       accordingly.
   3.  Make a final pass through all elements which were flagged to
       remove the flag "SEEN". (Otherwise, we may invalidate later set
       operations which utilize any of the same atoms.)

We could use indicators rather than flags, but the latter are slightly
more efficient when an indicator would have only one value (such as
having "SEEN" as the value of an indicator named "SEENORNOT").

As an example, here is INTERSECT defined using this technique;

SYMBOLIC PROCEDURE INTERSECT(S1, S2);
   BEGIN SCALAR ANS, SET2;
   FLAG(S1, 'SEEN);
   SET2 := S2;
   WHILE SET2 DO <<
      IF FLAGP(CAR SET2, 'SEEN) THEN ANS := CAR SET2 . ANS;
      SET2 := CDR SET2 >>;
   REMFLAG(S1, 'SEEN);
   RETURN ANS
   END;

COMMENT  Perhaps you noticed that, having used a BEGIN-block, group,
loop, and assignments, I have not practiced what I preached about
using only function composition, conditional expressions, and
recursion during this lesson.  Well, now that you have had some
exposure to both extremes, I think you should always fairly
consider both together with appropriate compromises, in each case
choosing whatever is most clear, concise, and natural.  For set
operations based on the property-list approach, I find the style
exemplified immediately above most natural.

As your last exercise for this lesson, develop a file containing a
package for set operations based upon either property-lists or sorting.

This is the end of lesson 6.  When you are ready to run the final lesson
7, load a fresh copy of REDUCE.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/lessons/less3.red0000755000175000017500000003303711526203062023730 0ustar  giovannigiovanniCOMMENT
                 REDUCE INTERACTIVE LESSON NUMBER 3

                         David R. Stoutemyer
                        University of Hawaii

                     Update for REDUCE 3.4 
                         Herbert Melenk
                      Konrad-Zuse-Zentrum Berlin

COMMENT This is lesson 3 of 7 REDUCE lessons.  Please refrain from
using variables beginning with the letters F through H during the
lesson.

Mathematics is replete with many named elementary and not-so-
elementary functions besides the set built into REDUCE such as SIN,
COS, and LOG, and it is often convenient to utilize expressions
containing a functional form such as f(x) to denote an unknown
function or a class of functions. Functions are called operators in
REDUCE, and by merely declaring their names as such, we are free to
use them for functional forms. For example;

OPERATOR F;
G1 := F(F(COT(F)), F());

COMMENT  Note that
   1.  We can use the same name for both a variable and an operator.
       (However, this practice often leads to confusion.)
   2.  We can use the same operator for any number of arguments --
       including zero arguments such as for F().
   3.  We can assign values to specific instances of functional
       forms;

PAUSE;
COMMENT COT is one of the functions already defined in REDUCE
together with a few of its properties. However, the user can augment
or even override these definitions depending on the needs of a given
problem. For example, if one wished to write COT(F) in terms of TAN,
one could say;

COT(F) := 1/TAN(F);
G1 := G1 + COT(H+1);

PAUSE;

COMMENT  Naturally, our assignment for COT(F) did not affect
COT(H+1) in our example above. However, we can use a LET rule to
make all cotangents automatically be replaced by the reciprocal of
the corresponding tangents:;

LET COT(~F) => 1/TAN(F);
G1;

COMMENT Any variable preceded by a tilde is a dummy variable which
is distinct from any other previously or subsequently introduced
indeterminate, variable, or dummy variable having the same name
outside the rule. The leftmost occurrence of a dummy variable in
a rule must be marked with a tilde. 

The arguments to LET are either single rules or lists (explicitly 
enlosed in {..} or as a variable with a list value). All elements 
of a list have to be rules (i.e., expressions written in terms of
the operator "=>") or names of other rule lists. So alternatively
we could have written the above command as
      LET COT(~F) => 1/TAN(F) 
   or as command sequence
      RS:={COT(~F) => 1/TAN(F)}
      LET RS

The CLEARRULES command allows to clear one or more rules. They
have to be entered here in the same form as for LET - otherwise
REDUCE is unable to identify them.

CLEARRULES COT(~F) => 1/TAN(F);
COT(G+5);
 
COMMENT alternative forms would have been
     CLEARRULES {COT(~F) => 1/TAN(F)}
   or with the above value of RS
     CLEARRULES RS
Note, that a call CLEAR RS would not remove the rule(s) from
the system - it only would remove the list value from the variable
RS;

PAUSE;

COMMENT The arguments of a functional form on the left-hand side of a
rule can be more complicated than mere indeterminates.  For example,
we may wish to inform REDUCE how to differentiate expressions involving
a symbolic function P, whose derivative is expressed in terms of
another function Q;

OPERATOR P,Q;
LET DF(P(~X),X) => Q(X)**2;

DF(3*P(F*G), G);

COMMENT Also, REDUCE obviously knows the chain rule;

PAUSE;

COMMENT As another example, suppose that we wish to employ the
angle-sum identities for SIN and COS;

LET{SIN(~X+~Y) => SIN(X)*COS(Y) + SIN(Y)*COS(X),
    COS(~X+~Y) => COS(X)*COS(Y) - SIN(X)*SIN(Y)};
COS(5+F-G);

COMMENT  Note that:
   1.  LET can have any number of replacement rules written
       as a list.
   2.  There was no need for rules with 3 or more addends, because
       the above rules were automatically employed recursively, with
       two of the three addends 5, F, and -G grouped together as one
     of the dummy variables the first time through.
   3.  Despite the subexpression F-G in our example, there was no
       need to make rules for the difference of two angles, because
       subexpressions of the form X-Y are treated as X+(-Y).
   4.  Built-in rules were employed to convert expressions of the
       form SIN(-X) or COS(-X) to -SIN(X) or COS(X) respectively.

As an exercise, try to implement rules which transform the logarithms
of products and quotients respectively to sums and differences of
logarithms, while converting the logarithm of a power of a quantity to
the power times the logarithm of the quantity; PAUSE;

COMMENT  Actually, the left-hand side of a rule also can be
somewhat more general than a functional form.  The left-hand side can
be a power of an indeterminate or of a functional form, or the left-
hand side can be a product of such powers and/or indeterminates or
functional forms.  For example, we can have the rule 
"SIN(~X)**2=>1-COS(~X)**2", or we can have the rule;

LET COS(~X)**2 => 1 - SIN(~X)**2;
G1 := COS(F)**3 + COS(G);
PAUSE;

COMMENT Note that a replacement takes place wherever a left-hand side of
a rule divides a term.  With a rule replacing SIN(X)**2 and a rule
replacing COS(X)**2 simultaneously in effect, an expression which uses
either one will lead to an infinite recursion that eventually exhausts
the available storage. (Try it if you wish -- after the lesson).  We are
also permitted to employ a more symmetric rule using a top level "+"
provided that no free variables appear in the rule.  However, a rule
such as "SIN(~X)**2+COS(X)**2=>1" is not permitted.  We can
get around the restriction against a top-level "+" on the left side
though, at the minor nuisance of having to employ an operator whenever
we want the rule applied to an expression:;

CLEARRULES COS(~X)**2 => 1 - SIN(~X)**2;
OPERATOR TRIGSIMP;
TRIGSIMP_RULES:=
  {TRIGSIMP(~A*SIN(~X)**2 + A*COS(X)**2 + ~C) => A + TRIGSIMP(C),
   TRIGSIMP(~A*SIN(~X)**2 + A*COS(X)**2) => A,
   TRIGSIMP(SIN(~X)**2 + COS(X)**2 + ~C) => 1 + TRIGSIMP(C),
   TRIGSIMP(SIN(~X)**2 + COS(X)**2) => 1,
   TRIGSIMP(~X) => X}$
G1 := F*COS(G)**2 + F*SIN(G)**2 + G*SIN(G)**2 + G*COS(G)**2 + 5;
G1 := TRIGSIMP(G1) WHERE TRIGSIMP_RULES;
PAUSE;


COMMENT Here we use another syntactical paradigm: the rule list
is assigned to a name (here TRIGSIMP_RULES) and it is activated
only locally for one evaluation, using the WHERE clause.

Why doesn't our rule TRIGSIMP(~X)=>X defeat the other more
specific ones?  The reason is that rules inside a list are applied in a
first-in-first-applied order, with the whole process immediately
restarted whenever any rule succeeds.  Thus the rule TRIGSIMP(X)=X,
intended to make the operator TRIGSIMP eventually evaporate, is tried
only after all of the genuine simplification rules have done all that
they can. For such reasons we usually write rules for an operator in
an order which proceeds from the most specific to the most general
cases.  Experimentation will reveal that TRIGSIMP will not simplify
higher  powers of  sine  and  cosine, such  as  COS(X)**4  +
2*COS(X)**2*SIN(X)**2 + SIN(X)**4,  and that TRIGSIMP will not
necessarily work when there are more than 6 terms. This latter
restriction is not fundamental but is a practical one imposed to keep
the combinatorial searching associated with the current algorithm
under reasonable control. As an exercise, see if you can generalize
the rules sufficiently so that 5*COS(H)**2+6*SIN(H)**2 simplifies to
5 + SIN(H)**2 or to 6-COS(H)**2;

PAUSE;

COMMENT  rules do not need to have free variables. For
example, we could introduce  the simplification rule to replace all
subsequent instances of M*C**2 by ENERGY;

CLEAR M,C,ENERGY;
G1 := (3*M**2*C**2 + M*C**3 + C**2 + M + M*C + M1*C1**2)
              WHERE M*C**2 => ENERGY;
PAUSE;

COMMENT Suppose that instead we wish to replace M by ENERGY/C**2:;

G1 WHERE M=>ENERGY/C**2;

COMMENT You may wonder how a rule of the trivial form 
"indeterminate => ..." differs from the corresponding assignment 
"indeterminate := ...". The difference is

   1.  The rule does not replace any contained bound variables
       with their values until the rule is actually used for a
       replacement.
   2.  The LET rule performs the evaluation of any contained bound
       variables every time the rule is used.

Thus, the rule "X => X + 1" would cause infinite recursion at the
first subsequent occurrence of X, as would the pair of rules 
"{X=>Y, Y=>X}". (Try it! -- after the lesson.) To illustrate point 1
above, compare the following sequence with the analogous earlier one in
lesson 2 using assignments throughout;

CLEAR E1, F;
E2:= F;
LET  F1 => E1 + E2;
F1;
E2 := G;
F1;
PAUSE;

COMMENT For a subsequent example, we need to replace E**(I*X) by
COS(X)**2 + I*SIN(X)**2 for all X. See if you can successfully
introduce this rule;

PAUSE;
E**I;

COMMENT REDUCE does not match I as an instance of the pattern I*X
with X=1, so if you neglected to include a rule for this degenerate
case, do so now;

PAUSE;
CLEAR X, N, NMINUS1;
ZERO := E**(N*I*X) - E**(NMINUS1*I*X)*E**(I*X);
REALZERO := SUB(I=0, ZERO);
IMAGZERO := SUB(I=0, -I*ZERO);

COMMENT Regarding the last two assignments as equations, we can solve
them to get recurrence relations defining SIN(N*X) and COS(N*X) in
terms of angles having lower multiplicity.

Can you figure out why I didn't use N-1 rather than NMINUS1 above?

Can you devise a similar technique to derive the angle-sum identities
that we previously implemented?;

PAUSE;

COMMENT To implement a set of trigonometric multiple-angle expansion
rules, we need to match the patterns SIN(N*X) and COS(N*X) only when N
is an integer exceeding 1.  We can implement one of the necessary rules
as follows;

   COS(~N*~X) => COS(X)*COS((N-1)*X) - SIN(X)*SIN((N-1)*X)
             WHEN FIXP N AND N>1

COMMENT Note:
   1.  In a conditional rule, any dummy variables should
       appear in the lhs of the replacement with a tilde.
   2.  FIXP, standing for fix Predicate, is a built-in function
       which yields true if and only if its argument is an integer.
       In lesson 6 we will learn how to write such a function 
       exclusively for integers. Other useful predicates 
       are NUMBERP (it is true if its argument represents a
       numeric value, that is an integer, a rational number
       or a rounded (floating point) number) and EVENP
       (which is true if the argument is an integer multiple
       of 2).
   3.  Arbitrarily-complicated true-false conditions can be composed
       using the relational operators =, NEQ, <, >, <=, >=, together
       with the logical operators "AND", "OR", "NOT".
   4.  Operators < , >, <=, and >= work only when both sides are 
       numbers. 
   5.  The relational operators have higher precedence than "NOT",
       which has higher precedence than "AND", which has higher
       precedence than "OR".
   6.  In a sequence of items joined by "AND" operators, testing is
       done left to right, and testing is discontinued after the
       first item which is false.
   7.  In a sequence of items joined by "OR" operators, testing is
       done left to right, and testing is discontinued after the
       first item which is true.
   8.  We didn't actually need the "AND N>1" part in the above rule
       Can you guess why?

Your mission is to complete the set of multiple-angle rules and to
test them on the example COS(4*X) + COS(X/3) + COS(F*X);

PAUSE;

COMMENT Now suppose that we wish to write a set of rules for doing
symbolic  integration,  such  that  expressions  of  the  form
INTEGRATE(X**P,X) are replaced by X**(P+1)/(P+1) for arbitrary X and
P, provided P is independent of X. This will of course be less
complete that the analytic integration package available with REDUCE,
but for specific classes of integrals it is often a reasonable way to
do such integration. Noting that DF(P,X) is 0 if P is independent of
X, we can accomplish this as follows;

OPERATOR INTEGRATE;
LET INTEGRATE(~X**~P,X) => X**(P+1)/(P+1) WHEN DF(P,X)=0;
INTEGRATE(F**5,F);
INTEGRATE(G**G, G);
INTEGRATE(F**G,F);

PAUSE;

G1 := INTEGRATE(G*F**5,F) + INTEGRATE(F**5+F**G,F);

COMMENT The last example indicates that we must incorporate rules
which distribute integrals over sums and extract factors which are
independent of the second argument of INTEGRATE. Can you think of
rules which accomplish this? It is a good exercise, but this
particular pair of properties of INTEGRATE is so prevalent in
mathematics that operators with these properties are called linear,
and a corresponding declaration is built into REDUCE;

LINEAR INTEGRATE;
G1;
G1:= INTEGRATE(F+1,F) + INTEGRATE(1/F**5,F);

PAUSE;

COMMENT We overcame one difficulty and uncovered 3 others. Clearly
REDUCE does not regard F to match the pattern F**P as F**1, or 1 to
match the pattern as F**0, or 1/F**5 to match the pattern as F**(-1),
so we can add additional rules for such cases;

LET {
   INTEGRATE(1/~X**~P,X) => X**(1-P)/(1-P) WHEN DF(P,X)=0,
   INTEGRATE(~X,X) => X**2/2,
   INTEGRATE(1,~X) => X}$
G1;

COMMENT A remaining problem is that INTEGRATE(X**-1,X) will lead to
X**0/(-1+1), which simplifies to 1/0, which will cause a zero-divide
error message. Consequently, we should also include the correct rule
for this special case;

LET INTEGRATE(~X**-1,X) => LOG(X);
INTEGRATE(1/X,X);

PAUSE;
 
COMMENT We now collect the integration rules so far to one list
according to the law that within a rule set a more specific rule 
should precede the more general one;
 
INTEGRATE_RULES :=
{ INTEGRATE(1,~X) => X,
  INTEGRATE(~X,X) => X**2/2,
  INTEGRATE(~X**-1,X) => LOG(X),
  INTEGRATE(1/~X**~P,X) => X**(1-P)/(1-P) WHEN DF(P,X)=0,
  INTEGRATE(~X**~P,X) => X**(P+1)/(P+1) WHEN DF(P,X)=0}$

COMMENT This is the end of lesson 3.  We leave it as an intriguing
exercise to extend this integrator.

;END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/0000755000175000017500000000000011722677362021775 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintk.red0000644000175000017500000005350411526203062024104 0ustar  giovannigiovannimodule defintk;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% A rule set to test for the validity of the thirty-five cases for
% the validity of the integration of a product of two Meijer
% G-functions.
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1 pages
%  346 & 347

algebraic<<

operator test_cases2,case1,case2,case3,case4,case5,case6,case7,case8,
         case9,case10,case11,case12,case13,case14,case15,case16,case17,
         case18,case19;

test_cases2_rules :=

{test_cases2(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,
        ~rho,~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

   when case1(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
        r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
        test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
        test_15) = 't

   or case2(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = 't

   or case3(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = 't

   or case4(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = 't

   or case5(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = 't

   or case6(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = t

   or case7(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = t

   or case8(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = t

   or case9(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,r2,
         phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15)
        = t

   or case10(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case11(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case12(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case13(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case14(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case15(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case16(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case17(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
          test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
          test_15) = t

   or case18(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case19(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case20(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
        r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
        test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
        test_15) = t

   or case21(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
          r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
          test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case22(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case23(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case24(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15)
        = 't

   or case25(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case26(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case27(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case28(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = 't

   or case29(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case30(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case31(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
          test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case32(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case33(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
          test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case34(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t

   or case35(m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,eta,mu,r1,
         r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
         test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
         test_15) = t
};

let test_cases2_rules;

case1_rules :=

{  case1(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m*n*k*l neq 0
              and delta > 0
              and epsilon > 0
              and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_10 = 't and test_12 = 't
        and transform_test('test_2,'test3,'test10,'test12,nil,nil,nil,
        nil) = 't

};

let case1_rules;

case2_rules :=

{  case2(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when u = v
              and delta = 0
        and epsilon > 0
        and sigma_tst(sigma) = 't
        and repart rho < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_12 = 't
        and transform_test('test2,'test3,'test12,'sigma_cond,nil,nil,
        nil,nil) = 't
};

let case2_rules;

case3_rules :=

{  case3(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q
        and epsilon = 0
        and delta >0
        and omega_tst(omega) = 't
        and repart eta < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_10 = 't
        and transform_test(test_2,'test3,'test10,'omega_cond,nil,nil,
        nil,nil) = 't
};

let case3_rules;

case4_rules :=

{  case4(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q
        and u = v
        and delta = 0
        and epsilon = 0
        and sigma_tst(sigma) = 't
        and omega_tst(omega) = 't
        and repart eta < 1
        and repart rho < 1
        and sigma^r1 neq omega^r2
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't
        and transform_test('test_2,'test3,'sigma_cond,'omega_cond,nil,
        nil,nil,nil) = 't
};

let case4_rules;


case5_rules :=

{  case5(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q
        and u = v
        and delta = 0
        and epsilon = 0
        and sigma_tst(sigma) = 't
        and omega_tst(omega) = 't
        and repart(eta + rho) < 1
        and sigma^r1 neq omega^r2
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't
        and transform_test('test2,'test3,'sigma_cond,'omega_cond,nil,
        nil,nil,nil) = 't
};

let case5_rules;

case6_rules :=

{  case6(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p > q
        and k > 0
        and delta > 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_5 = 't and test_10 = 't
        and test_13 = 't
        and transform_test('test3,'test5,'test10,'test13,nil,nil,nil,
        nil) = 't

};

let case6_rules;

case7_rules :=

{  case7(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p < q
        and l > 0
        and delta > 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_4 = 't and test_10 = 't
        and test_13 = 't
        and transform_test('test3,'test4,'test10,'test13,nil,nil,nil,
        nil) = 't

};

let case7_rules;


case8_rules :=

{  case8(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when u > v
        and m > 0
        and delta >= 0
        and epsilon > 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_7 = 't and test_11 = 't
        and test_12 = 't
        and transform_test('test3,'test7,'test11,'test12,nil,nil,nil,
        nil) = 't

};

let case8_rules;

case9_rules :=

{  case9(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when u < v
        and n > 0
        and delta >= 0
        and epsilon > 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_6 = 't and test_11 = 't
        and test_12 = 't
        and transform_test('test2,'test3,'test6,'test11,'test12,nil,
        nil,nil) = 't

};

let case9_rules;


case10_rules :=

{  case10(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p > q
        and u = v
        and delta = 0
        and epsilon >= 0
        and sigma_tst(sigma) = 't
        and repart rho < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_5 = 't and test_13 = 't
        and transform_test('test2,'test3,'test5,'test13,'sigma_cond,
        nil,nil,nil) = 't


};

let case10_rules;

case11_rules :=

{  case11(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p < q
        and u = v
        and delta = 0
        and epsilon >= 0
        and sigma_tst(sigma) = 't
        and repart rho < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_4 = 't and test_13 = 't
        and transform_test('test2,'test3,'test4,'test13,'sigma_cond,
        nil,nil,nil) = 't
};

let case11_rules;

case12_rules :=

{  case12(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q
        and u > v
        and delta >= 0
        and epsilon = 0
        and omega_tst(omega) = 't
        and repart eta < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_7 = 't and test_11 = 't
        and transform_test('test2,'test3,'test7,'test11,'omega_cond,
        nil,nil,nil) = 't
};

let case12_rules;

case13_rules :=

{  case13(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q
        and u < v
        and delta >= 0
        and epsilon = 0
        and omega_tst(omega) = 't
        and repart eta < 1
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_6 = 't and test_11 = 't
        and transform_test('test2,'test3,'test6,'test11,'omega_cond,
        nil,nil,nil) = 't
};

let case13_rules;

case14_rules :=

{  case14(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p < q
        and u > v
        and delta >= 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_4 = 't and test_7 = 't
        and test_11 = 't and test_13 = 't
        and transform_test('test2,'test3,'test4,'test7,'test11,'test13,
        nil,nil) = 't
};

let case14_rules;

case15_rules :=

{  case15(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p > q
        and u < v
        and delta >= 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_5 = 't and test_6 = 't
        and test_11 = 't and test_13 = 't
        and transform_test('test2,'test3,'test5,'test6,'test11,'test13,
        nil,nil) = 't
};

let case15_rules;

case16_rules :=

{  case16(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p > q
        and u > v
        and delta >= 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_5 = 't and test_7 = 't
        and test_8 = 't and test_11 = 't and test_13 = 't
        and test_14 = 't
        and transform_test('test2,'test3,'test5,'test7,'test8,'test11,
        'test13,'test14) = 't
};

let case16_rules;

case17_rules :=

{  case17(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p < q
        and u < v
        and delta >= 0
        and epsilon >= 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_4 = 't and test_6 = 't
        and test_9 = 't and test_11 = 't and test_13 = 't
        and test_14 = 't
        and transform_test('test2,'test3,'test4,'test6,'test9,'test11,
        'test13,'test14) = 't
};

let case17_rules;

case18_rules :=

{  case18(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when l = 0
        and k > 0
        and delta > 0
        and phi > 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_10 = 't
        and transform_test('test2,'test10,nil,nil,nil,nil,nil,nil) = 't
};

let case18_rules;

case19_rules :=

{  case19(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when k = 0
        and l > 0
        and delta > 0
        and phi < 0
        and test_1a = 't and test_1b = 't and test_3 = 't
              and test_10 = 't
        and transform_test('test10,nil,nil,nil,nil,nil,nil,nil) = 't
};

let case19_rules;
>>;

endmodule;
end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint.tst0000644000175000017500000001136711526203062023772 0ustar  giovannigiovanni% Test cases for definite integration.

int(x/(x+2),x,2,6);

int(sin x,x,0,pi/2);

int(log(x),x,1,5);

int((1+x**2/p**2)**(1/2),x,0,p);

int(x**9+y+y**x+x,x,0,2);


% Collected by Kerry Gaskell, ZIB, 1993/94.

int(x^2*log(1+x),x,0,infinity);

int(x*e^(-1/2x),x,0,infinity);

int(x/4*e^(-1/2x),x,0,infinity);

int(sqrt(2)*x^(1/2)*e^(-1/2x),x,0,infinity);

int(x^(3/2)*e^(-x),x,0,infinity);

int(sqrt(pi)*x^(3/2)*e^(-x),x,0,infinity);

int(x*log(1+1/x),x,0,infinity);

int(si(1/x),x,0,infinity);

int(cos(1/x),x,0,infinity);

int(sin(x^2),x,0,infinity);

int(sin(x^(3/2)),x,0,infinity);

int(besselj(2,x),x,0,infinity);

int(besselj(2,y^(5/4)),y,0,infinity);

int(x^(-1)*besselj(2,sqrt(x)),x,0,infinity);

int(bessely(2,x),x,0,infinity);

int(x*besseli(2,x),x,0,infinity);

int(besselk(0,x),x,0,infinity);

int(x^2*besselk(2,x),x,0,infinity);

int(sinh(x),x,0,infinity);

int(cosh(2*x),x,0,infinity);

int(-3*ei(-x),x,0,infinity);

int(x*shi(x),x,0,infinity);

int(x*fresnel_c(x),x,0,infinity);

int(x^3*e^(-2*x),x,0,infinity);

int(x^(-1)*sin(x/3),x,0,infinity);

int(x^(-1/2)*sin(x),x,0,infinity);

int(2*x^(-1/2)*cos(x),x,0,infinity);

int(sin x + cos x,x,0,infinity);

int(ei(-x) + sin(x^2),x,0,infinity);

int(x^(-1)*(sin (-2*x) + sin(x^2)),x,0,infinity);

int(x^(-1)*(cos(x/2) - cos(x/3)),x,0,infinity);

int(x^(-1)*(cos x - cos(2*x)),x,0,infinity);

int(x^(-1)*(cos(x) - cos(x)),x,0,infinity);

int(2,x,0,infinity);

int(cos(x)*si(x),x,0,infinity);

int(2*cos(x)*e^(-x),x,0,infinity);

int(x/2*cos(x)*e^(-x),x,0,infinity);

int(x^2/4*cos(x)*e^(-2*x),x,0,infinity);

int(1/(2*x)*sin(x)*e^(-3*x),x,0,infinity);

int(3/x^2*sin(x)*e^(-x),x,0,infinity);

int(cos(sqrt(x))*e^(-x),x,0,infinity);

int(e^(-x)*besselj(2,x),x,0,infinity);

int(cos(x^2)*e^(-x),x,0,infinity);

int(erf(x)*e^(-x),x,0,infinity);

int(besseli(2,x)*e^(-x),x,0,infinity);

int(e^(-x^2)*cos(x),x,0,infinity);

int(x^(-1)*sin(x)*cos(x),x,0,infinity);

int(x^(-1)*sin(x)*cos(2*x),x,0,infinity);

int(x^(-1)*sin(x)*cos(x/2),x,0,infinity);

int(e^x,x,0,infinity);

int(e^(-x^2 - x),x,0,infinity);

int(e^(-(x+x^2+1)),x,0,infinity);

int(e^(-(x+1/x)^2),x,0,infinity);

int(e^(-(x+2))*sin(x),x,0,infinity);

int(-3*x*e^(-1/2x),x,0,infinity);

int(x*e^(-1/2*x^2),x,0,infinity);

int(x^2*besselj(2,x),x,0,infinity);

int(x*besselk(1,x),x,0,infinity);

int(-3*ei(-x),x,0,infinity);

int(x^3*e^(-2*x^2),x,0,infinity);

int(sqrt(2)/2*x^(-3/2)*sin x,x,0,infinity);

int(x^(-1)*(sin(-2*x) + sin(x^2)),x,0,infinity);

int(x^(-1)*(cos(3*x) - cos(x/2)),x,0,infinity);

int(x^(-1)*(sin x - sin(2*x)),x,0,infinity);

int(1/x*sin(x)*e^(-3*x),x,0,infinity);

int(sin(x)*e^(-x),x,0,infinity);

int(x^(-1)*sin(x)*cos(x),x,0,infinity);

int(e^(1-x)*e^(2-x^2),x,0,infinity);

int(e^(-1/2x),x,0,y);

int(si(x),x,0,y);

int(besselj(2,x^(1/4)),x,0,y);

int(x*besseli(2,x),x,0,y);

int(x^(3/2)*e^(-x),x,0,y);

int(sinh(x),x,0,y);

int(cosh(2*x),x,0,y);

int(x*shi(x),x,0,y);

int(x^2*e^(-x^2),x,0,y);

int(x^(-1)/2*sin(x),x,0,y);

int(sin x + cos x,x,0,y);

int(sin x + sin(-2*x),x,0,y);

int(sin(n*x),x,0,y);

int(heaviside(x-1),x,0,y);


% Tests of transformations defined in defint package.

laplace_transform(1,x);

laplace_transform(x,x); 

laplace_transform(x^a/factorial(a),x);

laplace_transform(x,e^(-a*x),x);

laplace_transform(x^k,e^(-a*x),x);	

laplace_transform(cosh(a*x),x);	

laplace_transform(1/(2*a^3),sinh(a*x)-sin(a*x),x);

laplace_transform(1/(a^2),1-cos(a*x),x);	

laplace_transform(1/(b^2-a^2),cos(a*x)-cos(b*x),x);

laplace_transform(besselj(0,2*sqrt(k*x)),x);	

laplace_transform(Heaviside(x-1),x);

laplace_transform(1/x,sin(k*x),x);

laplace_transform(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);	

laplace_transform(1/k,e^(-k^2/(4*x)),x);

laplace_transform(2/(sqrt(pi*x)),besselk(0,2*sqrt(2*k*x)),x);	

hankel_transform(x,x);	

Y_transform(x,x);	

K_transform(x,x);	

struveh_transform(x,x);

fourier_sin(e^(-x),x);	

fourier_sin(sqrt(x),e^(-1/2*x),x);	

fourier_sin(1/x,e^(-a*x),x);	

fourier_sin(x^k,x);	

fourier_sin(1/(b-a),(e^(-a*x)-e^(-b*x)),x);

fourier_sin(besselj(0,a*x),x);

fourier_sin(1/sqrt(pi*x),cos(2*sqrt(k*x)),x);

fourier_sin(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);

fourier_cos(e^(-1/2x),x);	

fourier_cos(x,e^(-x),x);	

fourier_cos(x,e^(-1/2*x^2),x);	

fourier_cos(2*x^2,e^(-1/2x),x);	

fourier_cos(x,e^(-a*x),x);	

fourier_cos(x^n,e^(-a*x),x);	

fourier_cos(1/x,sin(k*x),x);

fourier_cos(1/sqrt(pi*x),cos(2*sqrt(k*x)),x);	

fourier_cos(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);

fourier_cos(1/(pi*x),sin(2*k*sqrt(x)),x);	

fourier_cos(1/(sqrt(pi*x)),e^(-2*k*sqrt(x)),x);

laplace_transform(x^n/factorial(n)*e^(-a*x),x);

laplace_transform(1/(2*a^2)*(cosh(a*x)-cos(a*x)),x);

laplace_transform(k*a^k/x*besselj(k,a*x),x);	

fourier_sin(1/x*e^(-3*x),x);	

fourier_sin(1/(pi*x)*sin(2*k*sqrt(x)),x);

fourier_cos(x^n*e^(-a*x),x);	

fourier_cos(1/(k*sqrt(pi))*e^(-x^2/(4*k^2)),x);

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/definte.red0000644000175000017500000002206011526203062024067 0ustar  giovannigiovannimodule definte;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic <<

laplace2_rules :=

{ laplace2(1/~x,~f1,~x) => int(1/x*f1*e^(-s*x),x,0,infinity),
  laplace2(1/~x^(~a),~f1,~x) => int(1/x^a*f1*e^(-s*x),x,0,infinity),
  laplace2(1/sqrt(~x),~f1,~x)=> int(1/sqrt(x)*f1*e^(-s*x),x,0,infinity),
  laplace2(1/(sqrt(~x)*~x),~f1,~x) =>
                 int(1/(sqrt(x)*x)*f1*e^(-s*x),x,0,infinity),
  laplace2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
                 int(1/(sqrt(x)*x^a)*f1*e^(-s*x),x,0,infinity),
  laplace2(~x^~a,~f1,~x) => int(x^a*f1*e^(-s*x),x,0,infinity),
  laplace2(~x,~f1,~x) => int(x*f1*e^(-s*x),x,0,infinity),
  laplace2(sqrt(~x),~f1,~x) => int(sqrt(x)*f1*e^(-s*x),x,0,infinity),
  laplace2(sqrt(~x)*~x,~f1,~x)=>int(sqrt(x)*x*f1*e^(-s*x),x,0,infinity),
  laplace2(sqrt(~x)*~x^~a,~f1,~x) =>
                    int(sqrt(x)*x^a*f1*e^(-s*x),x,0,infinity),
  laplace2(~b,~f1,~x) => int(b*f1*e^(-s*x),x,0,infinity),
  laplace2(~f1,~x) => int(f1*e^(-s*x),x,0,infinity)

};

let laplace2_rules;

hankel2_rules :=

{ hankel2(1/~x,~f1,~x) =>
                int(1/x*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(1/~x^(~a),~f1,~x) =>
                int(1/x^a*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(1/sqrt(~x),~f1,~x) =>
                int(1/sqrt(x)*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(1/(sqrt(~x)*~x),~f1,~x) =>
            int(1/(sqrt(x)*x)*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
          int(1/(sqrt(x)*x^a)*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(~x^~a,~f1,~x) =>
          int(x^a*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(~x,~f1,~x) => int(x*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(sqrt(~x),~f1,~x) =>
          int(sqrt(x)*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(sqrt(~x)*~x,~f1,~x) =>
          int(sqrt(x)*x,f1,besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(sqrt(~x)*~x^~a,~f1,~x) =>
          int(sqrt(x)*x^a*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(~b,~f1,~x) => int(b*f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity),
  hankel2(~f1,~x) => int(f1*besselj(n,2*(s*x)^(1/2)),x,0,infinity)
};

let hankel2_rules;

Y_transform2_rules :=

{ Y_transform2(1/~x,~f1,~x) =>
                      int(1/x*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(1/~x^(~a),~f1,~x) =>
                    int(1/x^a*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(1/sqrt(~x),~f1,~x) =>
                int(1/sqrt(x)*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(1/(sqrt(~x)*~x),~f1,~x) =>
            int(1/(sqrt(x)*x)*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
          int(1/(sqrt(x)*x^a)*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(~x^~a,~f1,~x) =>
                int(x^a*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(~x,~f1,~x) =>
                int(x*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(sqrt(~x),~f1,~x) =>
                int(sqrt(x)*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(sqrt(~x)*~x,~f1,~x) =>
                int(sqrt(x)*x*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(sqrt(~x)*~x^~a,~f1,~x) =>
              int(sqrt(x)*x^a*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(~b,~f1,~x) =>
              int(b*f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity),
  Y_transform2(~f1,~x) => int(f1*bessely(n,2*(s*x)^(1/2)),x,0,infinity)
};

let Y_transform2_rules;

K_transform2_rules :=

{ K_transform2(1/~x,~f1,~x) =>
                      int(1/x*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(1/~x^(~a),~f1,~x) =>
                    int(1/x^a*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(1/sqrt(~x),~f1,~x) =>
                int(1/sqrt(x)*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(1/(sqrt(~x)*~x),~f1,~x) =>
            int(1/(sqrt(x)*x)*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
          int(1/(sqrt(x)*x^a)*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(~x^~a,~f1,~x) =>
          int(x^a*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(~x,~f1,~x) =>
          int(x*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(sqrt(~x),~f1,~x) =>
          int(sqrt(x)*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(sqrt(~x)*~x,~f1,~x) =>
          int(sqrt(x)*x*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(sqrt(~x)*~x^~a,~f1,~x) =>
          int(sqrt(x)*x^a*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(~b,~f1,~x) =>
          int(b*f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity),
  K_transform2(~f1,~x) => int(f1*besselK(n,2*(s*x)^(1/2)),x,0,infinity)
};

let K_transform2_rules;

struveh2_rules :=

{ struveh2(1/~x,~f1,~x) =>
                 int(1/x*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(1/~x^(~a),~f1,~x) =>
                 int(1/x^a*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(1/sqrt(~x),~f1,~x) =>
                int(1/sqrt(x)*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(1/(sqrt(~x)*~x),~f1,~x) =>
            int(1/(sqrt(x)*x)*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
          int(1/(sqrt(x)*x^a)*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(~x^~a,~f1,~x) =>
          int(x^a*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(~x,~f1,~x) =>
          int(x*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(sqrt(~x),~f1,~x) =>
          int(sqrt(x)*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(sqrt(~x)*~x,~f1,~x) =>
          int(sqrt(x)*x*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(sqrt(~x)*~x^~a,~f1,~x) =>
          int(sqrt(x)*x^a*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(~b,~f1,~x) =>
          int(b*f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity),
  struveh2(~f1,~x) => int(f1*struveh(n,2*(s*x)^(1/2)),x,0,infinity)
};

let struveh2_rules;

fourier_sin2_rules :=

{ fourier_sin2(1/~x,~f1,~x) => int(1/x*f1*sin(s*x),x,0,infinity),
  fourier_sin2(1/~x^(~a),~f1,~x) => int(1/x^a*f1*sin(s*x),x,0,infinity),
  fourier_sin2(1/sqrt(~x),~f1,~x) =>
                                int(1/sqrt(x)*f1*sin(s*x),x,0,infinity),
  fourier_sin2(1/(sqrt(~x)*~x),~f1,~x) =>
                 int(1/(sqrt(x)*x)*f1*sin(s*x),x,0,infinity),
  fourier_sin2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
                 int(1/(sqrt(x)*x^a)*f1*sin(s*x),x,0,infinity),
  fourier_sin2(~x^~a,~f1,~x) => int(x^a*f1*sin(s*x),x,0,infinity),
  fourier_sin2(~x,~f1,~x) => int(x*f1*sin(s*x),x,0,infinity),
  fourier_sin2(sqrt(~x),~f1,~x)=> int(sqrt(x)*f1*sin(s*x),x,0,infinity),
  fourier_sin2(sqrt(~x)*~x,~f1,~x) =>
                 int(sqrt(x)*x*f1*sin(s*x),x,0,infinity),
  fourier_sin2(sqrt(~x)*~x^~a,~f1,~x) =>
                 int(sqrt(x)*x^a*f1*sin(s*x),x,0,infinity),
  fourier_sin2(~b,~f1,~x) => int(b*f1*sin(s*x),x,0,infinity),
  fourier_sin2(~f1,~x) => int(f1*sin(s*x),x,0,infinity)
};

let fourier_sin2_rules;

fourier_cos2_rules :=

{ fourier_cos2(1/~x,~f1,~x) => int(1/x*f1*cos(s*x),x,0,infinity),
  fourier_cos2(1/~x^(~a),~f1,~x) => int(1/x^a*f1*cos(s*x),x,0,infinity),
  fourier_cos2(1/sqrt(~x),~f1,~x) =>
                int(1/sqrt(x)*f1*cos(s*x),x,0,infinity),
  fourier_cos2(1/(sqrt(~x)*~x),~f1,~x) =>
                int(1/(sqrt(x)*x)*f1*cos(s*x),x,0,infinity),
  fourier_cos2(1/(sqrt(~x)*~x^~a),~f1,~x) =>
                int(1/(sqrt(x)*x^a)*f1*cos(s*x),x,0,infinity),
  fourier_cos2(~x^~a,~f1,~x) => int(x^a*f1*cos(s*x),x,0,infinity),
  fourier_cos2(~x,~f1,~x) => int(x*f1*cos(s*x),x,0,infinity),
  fourier_cos2(sqrt(~x),~f1,~x)=> int(sqrt(x)*f1*cos(s*x),x,0,infinity),
  fourier_cos2(sqrt(~x)*~x,~f1,~x) =>
                       int(sqrt(x)*x*f1*cos(s*x),x,0,infinity),
  fourier_cos2(sqrt(~x)*~x^~a,~f1,~x) =>
                       int(sqrt(x)*x^a*f1*cos(s*x),x,0,infinity),
  fourier_cos2(~b,~f1,~x) => int(b*f1*cos(s*x),x,0,infinity),
  fourier_cos2(~f1,~x) => int(f1*cos(s*x),x,0,infinity)
};

let fourier_cos2_rules;

>>;

endmodule;
end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint.rlg0000644000175000017500000003346611527635055023764 0ustar  giovannigiovanniFri Feb 18 21:28:02 2011 run on win32

*** ci already defined as operator 

*** si already defined as operator 
% Test cases for definite integration.

int(x/(x+2),x,2,6);


2*( - log(2) + 2)


int(sin x,x,0,pi/2);


1


int(log(x),x,1,5);


5*log(5) - 4


int((1+x**2/p**2)**(1/2),x,0,p);


 p*(sqrt(2) + log(sqrt(2) + 1))
--------------------------------
               2


int(x**9+y+y**x+x,x,0,2);


                               2
 10*log(y)*y + 522*log(y) + 5*y  - 5
-------------------------------------
              5*log(y)



% Collected by Kerry Gaskell, ZIB, 1993/94.

int(x^2*log(1+x),x,0,infinity);


     2
int(x *log(1 + x),x,0,infinity)


int(x*e^(-1/2x),x,0,infinity);


4


int(x/4*e^(-1/2x),x,0,infinity);


1


int(sqrt(2)*x^(1/2)*e^(-1/2x),x,0,infinity);


2*sqrt(pi)


int(x^(3/2)*e^(-x),x,0,infinity);


 3*sqrt(pi)
------------
     4


int(sqrt(pi)*x^(3/2)*e^(-x),x,0,infinity);


 3*pi
------
  4


int(x*log(1+1/x),x,0,infinity);


               1
int(x*log(1 + ---),x,0,infinity)
               x


int(si(1/x),x,0,infinity);


        1
int(si(---),x,0,infinity)
        x


int(cos(1/x),x,0,infinity);


         1
int(cos(---),x,0,infinity)
         x


int(sin(x^2),x,0,infinity);


 sqrt(pi)*sqrt(2)
------------------
        4


int(sin(x^(3/2)),x,0,infinity);


           2/3        5
 sqrt(pi)*2   *gamma(---)
                      6
--------------------------
                2
       3*gamma(---)
                3


int(besselj(2,x),x,0,infinity);


1


int(besselj(2,y^(5/4)),y,0,infinity);


    4/5        7
 2*2   *gamma(---)
               5
-------------------
            8
   5*gamma(---)
            5


int(x^(-1)*besselj(2,sqrt(x)),x,0,infinity);


1


int(bessely(2,x),x,0,infinity);


int(bessely(2,x),x,0,infinity)


int(x*besseli(2,x),x,0,infinity);


int(x*besseli(2,x),x,0,infinity)


int(besselk(0,x),x,0,infinity);


 pi
----
 2


int(x^2*besselk(2,x),x,0,infinity);


 3*pi
------
  2


int(sinh(x),x,0,infinity);


int(sinh(x),x,0,infinity)


int(cosh(2*x),x,0,infinity);


int(cosh(2*x),x,0,infinity)


int(-3*ei(-x),x,0,infinity);


3


int(x*shi(x),x,0,infinity);


int(x*shi(x),x,0,infinity)


int(x*fresnel_c(x),x,0,infinity);


int(x*fresnel_c(x),x,0,infinity)


int(x^3*e^(-2*x),x,0,infinity);


 3
---
 8


int(x^(-1)*sin(x/3),x,0,infinity);


 pi
----
 2


int(x^(-1/2)*sin(x),x,0,infinity);


 sqrt(pi)*sqrt(2)
------------------
        2


int(2*x^(-1/2)*cos(x),x,0,infinity);


sqrt(pi)*sqrt(2)


int(sin x + cos x,x,0,infinity);


int(sin(x) + cos(x),x,0,infinity)


int(ei(-x) + sin(x^2),x,0,infinity);


 sqrt(pi)*sqrt(2) - 4
----------------------
          4


int(x^(-1)*(sin (-2*x) + sin(x^2)),x,0,infinity);


  - pi
-------
   4


int(x^(-1)*(cos(x/2) - cos(x/3)),x,0,infinity);


        3
 - log(---)
        2


int(x^(-1)*(cos x - cos(2*x)),x,0,infinity);


log(2)


int(x^(-1)*(cos(x) - cos(x)),x,0,infinity);


0


int(2,x,0,infinity);


int(2,x,0,infinity)


int(cos(x)*si(x),x,0,infinity);


int(cos(x)*si(x),x,0,infinity)


int(2*cos(x)*e^(-x),x,0,infinity);


1


int(x/2*cos(x)*e^(-x),x,0,infinity);


0


int(x^2/4*cos(x)*e^(-2*x),x,0,infinity);


  1
-----
 125


int(1/(2*x)*sin(x)*e^(-3*x),x,0,infinity);


       1
 atan(---)
       3
-----------
     2


int(3/x^2*sin(x)*e^(-x),x,0,infinity);


     3            - x
int(----*sin(x)*e    ,x,0,infinity)
      2
     x


int(cos(sqrt(x))*e^(-x),x,0,infinity);


                  i        1/4
 sqrt( - pi)*erf(---) + 2*e
                  2
-------------------------------
               1/4
            2*e


int(e^(-x)*besselj(2,x),x,0,infinity);


  - 2*sqrt(2) + 3
------------------
     sqrt(2)


int(cos(x^2)*e^(-x),x,0,infinity);


               1              1          1                  1        1
(pi*( - 2*cos(---)*fresnel_s(---) + cos(---) + 2*fresnel_c(---)*sin(---)
               4              4          4                  4        4

             1
      - sin(---)))/(2*sqrt(pi)*sqrt(2))
             4


int(erf(x)*e^(-x),x,0,infinity);


 1/4          1
e   *( - erf(---) + 1)
              2


int(besseli(2,x)*e^(-x),x,0,infinity);


                    - 1                            1
2*hypergeometric({------},{},1) + hypergeometric({---},{},1) - 2
                    2                              2


int(e^(-x^2)*cos(x),x,0,infinity);


 sqrt(pi)
----------
     1/4
  2*e


int(x^(-1)*sin(x)*cos(x),x,0,infinity);


 pi
----
 4


int(x^(-1)*sin(x)*cos(2*x),x,0,infinity);


0


int(x^(-1)*sin(x)*cos(x/2),x,0,infinity);


 pi
----
 2


int(e^x,x,0,infinity);


     x
int(e ,x,0,infinity)


int(e^(-x^2 - x),x,0,infinity);


  1/4             1
 e   *pi*( - erf(---) + 1)
                  2
---------------------------
        2*sqrt(pi)


int(e^(-(x+x^2+1)),x,0,infinity);


  1/4             1
 e   *pi*( - erf(---) + 1)
                  2
---------------------------
       2*sqrt(pi)*e


int(e^(-(x+1/x)^2),x,0,infinity);


 sqrt(pi)
----------
      4
   2*e


int(e^(-(x+2))*sin(x),x,0,infinity);


  1
------
    2
 2*e


int(-3*x*e^(-1/2x),x,0,infinity);


-12


int(x*e^(-1/2*x^2),x,0,infinity);


1


int(x^2*besselj(2,x),x,0,infinity);


     2
int(x *besselj(2,x),x,0,infinity)


int(x*besselk(1,x),x,0,infinity);


 pi
----
 2


int(-3*ei(-x),x,0,infinity);


3


int(x^3*e^(-2*x^2),x,0,infinity);


 1
---
 8


int(sqrt(2)/2*x^(-3/2)*sin x,x,0,infinity);


sqrt(pi)


int(x^(-1)*(sin(-2*x) + sin(x^2)),x,0,infinity);


  - pi
-------
   4


int(x^(-1)*(cos(3*x) - cos(x/2)),x,0,infinity);


 - log(6)


int(x^(-1)*(sin x - sin(2*x)),x,0,infinity);


0


int(1/x*sin(x)*e^(-3*x),x,0,infinity);


      1
atan(---)
      3


int(sin(x)*e^(-x),x,0,infinity);


 1
---
 2


int(x^(-1)*sin(x)*cos(x),x,0,infinity);


 pi
----
 4


int(e^(1-x)*e^(2-x^2),x,0,infinity);


  1/4  3             1
 e   *e *pi*( - erf(---) + 1)
                     2
------------------------------
          2*sqrt(pi)


int(e^(-1/2x),x,0,y);


     y/2
 2*(e    - 1)
--------------
      y/2
     e


int(si(x),x,0,y);


si(y)*y - 1 + cos(y)


int(besselj(2,x^(1/4)),x,0,y);


                                 1/4               1/4
 - 2*((8*sqrt(y) - y)*besselj(0,y   ) - besselj(2,y   )*y

            1/4   1/4        1/4                 1/4
       + 4*y   *(y    + 2)*(y    - 2)*besselj(1,y   ))


int(x*besseli(2,x),x,0,y);


 - (2*(besseli(0,y) - 1) - besseli(1,y)*y)


int(x^(3/2)*e^(-x),x,0,y);


             y
 3*sqrt(pi)*e *erf(sqrt(y)) - 4*sqrt(y)*y - 6*sqrt(y)
------------------------------------------------------
                            y
                         4*e


int(sinh(x),x,0,y);


   y     2
 (e  - 1)
-----------
      y
   2*e


int(cosh(2*x),x,0,y);


   2*y        y        y
 (e    + 1)*(e  + 1)*(e  - 1)
------------------------------
               2*y
            4*e


int(x*shi(x),x,0,y);


      y   y                     2
  - (e *(e *(y - 1) - 2*shi(y)*y ) + y + 1)
--------------------------------------------
                       y
                    4*e


int(x^2*e^(-x^2),x,0,y);


            2
           y
 sqrt(pi)*e  *erf(y) - 2*y
---------------------------
               2
              y
           4*e


int(x^(-1)/2*sin(x),x,0,y);


 si(y)
-------
   2


int(sin x + cos x,x,0,y);


sin(y) + 1 - cos(y)


int(sin x + sin(-2*x),x,0,y);


  - (2*cos(y) - 1 - cos(2*y))
------------------------------
              2


int(sin(n*x),x,0,y);


  - (cos(n*y) - 1)
-------------------
         n


int(heaviside(x-1),x,0,y);


(y - 1)*heaviside(y - 1)



% Tests of transformations defined in defint package.

laplace_transform(1,x);


 1
---
 s


laplace_transform(x,x);


 1
----
  2
 s
 

laplace_transform(x^a/factorial(a),x);


  1
------
  a
 s *s


laplace_transform(x,e^(-a*x),x);


        1
-----------------
  2            2
 a  + 2*a*s + s


laplace_transform(x^k,e^(-a*x),x);


      gamma(k + 1)
-------------------------
        k            k
 (a + s) *a + (a + s) *s
	

laplace_transform(cosh(a*x),x);


   - s
---------
  2    2
 a  - s
	

laplace_transform(1/(2*a^3),sinh(a*x)-sin(a*x),x);


   - 1
---------
  4    4
 a  - s


laplace_transform(1/(a^2),1-cos(a*x),x);


     1
-----------
  2      3
 a *s + s
	

laplace_transform(1/(b^2-a^2),cos(a*x)-cos(b*x),x);


             s
----------------------------
  2  2    2  2    2  2    4
 a *b  + a *s  + b *s  + s


laplace_transform(besselj(0,2*sqrt(k*x)),x);


   1
--------
  k/s
 e   *s
	

laplace_transform(Heaviside(x-1),x);


  1
------
  s
 e *s


laplace_transform(1/x,sin(k*x),x);


      k
atan(---)
      s


laplace_transform(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);


     2  2              2  2
    k *s              k *s
 - e     *erf(k*s) + e
	

laplace_transform(1/k,e^(-k^2/(4*x)),x);


 besselk(1,sqrt(s)*k)
----------------------
       sqrt(s)


laplace_transform(2/(sqrt(pi*x)),besselk(0,2*sqrt(2*k*x)),x);


  k/s            k
 e   *besselk(0,---)
                 s
---------------------
       sqrt(s)
	

hankel_transform(x,x);


         n + 4
  gamma(-------)
           2
-------------------
        n - 2    2
 gamma(-------)*s
          2
	

Y_transform(x,x);


          - n + 4          n + 4
  gamma(----------)*gamma(-------)
            2                2
-------------------------------------
         - n + 3          n - 1    2
 gamma(----------)*gamma(-------)*s
           2                2
	

K_transform(x,x);


         - n + 4          n + 4
 gamma(----------)*gamma(-------)
           2                2
----------------------------------
                  2
               2*s
	

struveh_transform(x,x);


          - n - 3          n + 5
  gamma(----------)*gamma(-------)
            2                2
-------------------------------------
         - n - 2          n - 2    2
 gamma(----------)*gamma(-------)*s
           2                2


fourier_sin(e^(-x),x);


   s
--------
  2
 s  + 1
	

fourier_sin(sqrt(x),e^(-1/2*x),x);


           3*atan(2*s)
    2*sin(-------------)*pi
                2
--------------------------------
              2     3/4
 sqrt(pi)*(4*s  + 1)   *sqrt(2)
	

fourier_sin(1/x,e^(-a*x),x);


      s
atan(---)
      a
	

fourier_sin(x^k,x);


  k/2         - k          k
 4   *gamma(------)*gamma(---)*k
              2            2
---------------------------------
         k  k
      4*s *2 *gamma( - k)*s
	

fourier_sin(1/(b-a),(e^(-a*x)-e^(-b*x)),x);


         a*s + b*s
----------------------------
  2  2    2  2    2  2    4
 a *b  + a *s  + b *s  + s


fourier_sin(besselj(0,a*x),x);


                2    2
             - a  + s
 heaviside(------------)
                 2
                a
-------------------------
             2    2
    sqrt( - a  + s )


fourier_sin(1/sqrt(pi*x),cos(2*sqrt(k*x)),x);


                      k                          k
 sqrt(s)*sqrt(2)*cos(---) - sqrt(s)*sqrt(2)*sin(---)
                      s                          s
-----------------------------------------------------
                         2*s


fourier_sin(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);


 erf(i*k*s)*i
--------------
      2  2
     k *s
    e


fourier_cos(e^(-1/2x),x);


    2
----------
    2
 4*s  + 1
	

fourier_cos(x,e^(-x),x);


       2
    - s  + 1
---------------
  4      2
 s  + 2*s  + 1
	

fourier_cos(x,e^(-1/2*x^2),x);


                                 2
                 i*s            s /2
 sqrt(pi)*erf(---------)*i*s + e    *sqrt(2)
               sqrt(2)
---------------------------------------------
                  2
                 s /2
                e    *sqrt(2)
	

fourier_cos(2*x^2,e^(-1/2x),x);


              2
       - 384*s  + 32
---------------------------
     6       4       2
 64*s  + 48*s  + 12*s  + 1
	

fourier_cos(x,e^(-a*x),x);


       2    2
      a  - s
-------------------
  4      2  2    4
 a  + 2*a *s  + s
	

fourier_cos(x^n,e^(-a*x),x);


           s             s
 cos(atan(---)*n + atan(---))*gamma(n + 1)
           a             a
-------------------------------------------
              2    2 (n + 1)/2
            (a  + s )
	

fourier_cos(1/x,sin(k*x),x);


       2    2
 sign(k  - s )*pi + pi
-----------------------
           4


fourier_cos(1/sqrt(pi*x),cos(2*sqrt(k*x)),x);


                      k                          k
 sqrt(s)*sqrt(2)*cos(---) + sqrt(s)*sqrt(2)*sin(---)
                      s                          s
-----------------------------------------------------
                         2*s
	

fourier_cos(1/(k*sqrt(pi)),e^(-x^2/(4*k^2)),x);


   1
--------
   2  2
  k *s
 e


fourier_cos(1/(pi*x),sin(2*k*sqrt(x)),x);


        2             2
       k             k
intfc(----) + intfs(----)
       s             s
	

fourier_cos(1/(sqrt(pi*x)),e^(-2*k*sqrt(x)),x);


                    2               2                   2
                   k               k                   k
( - 2*sqrt(s)*cos(----)*fresnel_s(----) + sqrt(s)*cos(----)
                   s               s                   s

                          2         2                   2
                         k         k                   k
  + 2*sqrt(s)*fresnel_c(----)*sin(----) - sqrt(s)*sin(----))/(sqrt(2)*s)
                         s         s                   s


laplace_transform(x^n/factorial(n)*e^(-a*x),x);


            1
-------------------------
        n            n
 (a + s) *a + (a + s) *s


laplace_transform(1/(2*a^2)*(cosh(a*x)-cos(a*x)),x);


   - s
---------
  4    4
 a  - s


laplace_transform(k*a^k/x*besselj(k,a*x),x);


          2*k
         a
----------------------
        2    2      k
 (sqrt(a  + s ) + s)
	

fourier_sin(1/x*e^(-3*x),x);


      s
atan(---)
      3
	

fourier_sin(1/(pi*x)*sin(2*k*sqrt(x)),x);


        2             2
       k             k
intfc(----) - intfs(----)
       s             s


fourier_cos(x^n*e^(-a*x),x);


           s             s
 cos(atan(---)*n + atan(---))*gamma(n + 1)
           a             a
-------------------------------------------
              2    2 (n + 1)/2
            (a  + s )
	

fourier_cos(1/(k*sqrt(pi))*e^(-x^2/(4*k^2)),x);


   1
--------
   2  2
  k *s
 e


end;


Time for test: 3119 ms, plus GC time: 172 ms
@@@@@ Resources used: (4 33 41 841)
mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint.tex0000644000175000017500000003171611526203062023760 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\date{July 1994}
\title{A Definite Integration Interface for REDUCE}
\author{Kerry Gaskell \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin\\
Takustra\"se 7 \\
D--14195 Berlin -- Dahlem \\
Federal Republic of Germany \\[0.05in]
E--mail: neun@zib.de\footnotemark[1]}

\begin{document}
\maketitle
\footnotetext[1]{This definite integration interface was written
during my one year placement at ZIB. Any comments and/or
problems should therefore be directed to Winfried Neun at
neun@zib.de.}

\section{Introduction}
This documentation describes part of \REDUCE's definite
integration package that is able to calculate the definite integrals of
many functions, including several special functions.  There are other
parts of this package, such as Stan Kameny's code for contour integration,
that are not included here.  The integration process described here is not
the more normal approach of initially calculating the indefinite integral,
but is instead the rather unusual idea of representing each function as a
Meijer G-function (a formal definition of the Meijer G-function can be
found in \cite {Prudnikov}), and then calculating the integral by using
the following Meijer G integration formula.

\begin{displaymath}
\int_{0}^{\infty} x^{\alpha-1} G^{s t}_{u v} 
\left( \sigma x \  \Bigg\vert \  {( c_u) \atop (d_v)} \right) 
G^{m n}_{p q} \left( \omega x^{l/k} \  \Bigg\vert \ {(a_p) \atop (b_q)}
\right) dx = k G^{i j}_{k l} \left( \xi \ \Bigg\vert \ 
{(g_k) \atop (h_l)} \right)  \hspace{5mm} (1)
\end{displaymath}

The resulting Meijer G-function is then retransformed, either directly
or via a hypergeometric function simplification, to give
the answer. A more detailed account of this theory can be found in 
\cite {Adamchik:90}.

\section{Integration between zero and infinity}

As an example, if one wishes to calculate the following integral

\begin{displaymath}
\int_{0}^{\infty} x^{-1} e^{-x} sin(x) \, dx
\end{displaymath}

then initially the  correct Meijer G-functions are found, via a 
pattern matching 
process, and are substituted into (1) to give

\begin{displaymath}
\sqrt{\pi} \int_{0}^{\infty} x^{-1} G^{1 0}_{0 1} \left(x 
\ \Bigg\vert \ 
{. \atop 0}\right) G^{1 0}_{0 2}\left(\frac{x^{2}}{4} 
\ \Bigg\vert \ {. \; .  \atop \frac{1}{2} \; 0} \right) dx
\end{displaymath}

The cases for validity of the integral are then checked. If these 
are found to be satisfactory then the formula is calculated and we 
obtain the following Meijer G-function 

\begin{displaymath}  
G^{1 2}_{2 2} \left(1 \ \Bigg\vert \ {\frac{1}{2} \; 1 \atop 
\frac{1}{2} \; 0} \right)
\end{displaymath} 

This is reduced to the following hypergeometric function

\begin{math}
\hspace{50mm} _2F_1 (\frac{1}{2},1;\frac{3}{2};-1 )
\end{math}

which is then calculated to give the correct answer of 

\begin{displaymath}
\frac{\pi}{4}
\end{displaymath}

The above formula (1) is also true for the integration of a single
Meijer G-function by replacing the second Meijer G-function 
with a trivial Meijer G-function.

A list of numerous particular Meijer G-functions is available in 
\cite {Prudnikov}.

\section{Integration over other ranges}

Although the description so far has been limited to the computation of
definite integrals between 0 and infinity, it can also be extended to
calculate integrals between 0 and some specific upper bound, and
by further extension, integrals between any two bounds.  One approach is
to use the Heaviside function, i.e.

\begin{displaymath}
\int_{0}^{\infty} x^{2} e^{-x} H(1-x)\,dx = \int_{0}^{1} x^{2} e^{-x}dx
\end{displaymath} 

Another approach, again not involving the normal indefinite integration
process, again uses Meijer G-functions, this time by means of the
following formula

\begin{displaymath}
\int_{0}^{y} x^{\alpha-1} G^{m n}_{p q} 
\left( \sigma x \  \Bigg\vert \  {( a_u) \atop (b_v)} \right) dx=%
y^{\alpha}\,G^{m \; n+1}_{p+1 \; q+1} \left( \sigma y \  \Bigg\vert \
{( a_1..a_n,1-\alpha,a_{n+1}..a_p) 
\atop (b_1..b_m,-\alpha,b_{m+1}..b_q)} \right) (2) 
\end{displaymath}

For a more detailed look at the theory behind this see 
\cite{Adamchik:90}.

For example, if one wishes to calculate the following integral

\begin{displaymath}
\int_{0}^{y} sin(2 \sqrt{x}) \, dx 
\end{displaymath}

then initially the correct Meijer G-function is found, by a pattern 
matching process, and is substituted 
into (2) to give

\begin{displaymath}
\int_{0}^{y} G^{1 0}_{0 2}\left(x 
\ \Bigg\vert \ {. \; .  \atop \frac{1}{2} \; 0} \right) dx
\end{displaymath}

which then in turn gives

\begin{displaymath}
y \; G^{1 1}_{1 3}\left(y \ \Bigg\vert \ {0 \atop 
\frac{1}{2} -\!1 \; 0} \right) dx
\end{displaymath}

and returns the result

\begin{displaymath}
\frac{\sqrt{\pi} \, J_{3/2}(2 \, \sqrt{\,y}) \, y}{y^{1/4}}
\end{displaymath}

\section{Using the definite integration package}
To use this package, you must first load it by the command
\begin{verbatim}
load_package defint;
\end{verbatim}
Definite integration is then possible using the \verb+int+
command with the syntax:
\begin{verbatim}
   INT(EXPRN:algebraic,VAR:kernel,LOW:algebraic,UP:algebraic)
       :algebraic.
\end{verbatim}
where LOW and UP are the lower and upper bounds respectively for
the definite integration of EXPRN with respect to VAR.

\subsection{Examples}

\begin{displaymath}
\int_{0}^{\infty} e^{-x} dx 
\end{displaymath}


\begin{verbatim}
 int(e^(-x),x,0,infinity);

 1
\end{verbatim}

\begin{displaymath}
\int_{0}^{\infty} x sin(1/x) \, dx
\end{displaymath}

\begin{verbatim}
 int(x*sin(1/x),x,0,infinity);

           1
INT(X*SIN(---),X,0,INFINITY)
           X
\end{verbatim}

\begin{displaymath}
\int_{0}^{\infty} x^2 cos(x) \, e^{-2x} dx
\end{displaymath}

\begin{verbatim}
 int(x^2*cos(x)*e^(-2*x),x,0,infinity);

   4
 -----
  125
\end{verbatim}

\begin{displaymath}
\int_{0}^{\infty} x e^{-1/2x} H(1-x) \,dx = \int_{0}^{1} x e^{-1/2x} dx
\end{displaymath}

\begin{verbatim}
 int(x*e^(-1/2x)*Heaviside(1-x),x,0,infinity);

  2*(2*SQRT(E) - 3)
 -------------------
       SQRT(E)
\end{verbatim}

\begin{displaymath}
\int_{0}^{1} x \,log(1+x) \,dx
\end{displaymath}

\begin{verbatim}
 int(x*log(1+x),x,0,1);

  1
 ---
  4
\end{verbatim}

\begin{displaymath}
\int_{0}^{y} cos(2x) \,dx
\end{displaymath}

\begin{verbatim}
 int(cos(2x),x,y,2y);

 SIN(4*Y) - SIN(2*Y)
---------------------
          2
\end{verbatim}


\section{Integral Transforms}

A useful application of the definite integration package is in the 
calculation of various integral transforms. The transforms
available are as follows:

\begin{itemize}
\item Laplace transform 
\item Hankel transform 
\item Y-transform 
\item K-transform 
\item StruveH transform 
\item Fourier sine transform
\item Fourier cosine transform 
\end{itemize}

\subsection{Laplace transform}

The Laplace transform

$\hspace{20 mm} f(s) = \cal L$ \{F(t)\} =
$\int_{0}^{\infty} e^{-st}F(t)\,dt$

can be calculated by using the \verb+laplace_transform+ command.

This requires as parameters

\begin{itemize}
\item the function to be integrated
\item the integration variable.
\end{itemize}

For example

$\hspace{56 mm} \cal L$ $\{e^{-at}\} \\$
is entered as

\begin{verbatim}
        laplace_transform(e^(-a*x),x);
\end{verbatim}

and returns the result
 
\begin{displaymath}
\frac{1}{s+a}
\end{displaymath}

\subsection{Hankel transform}

The Hankel transform

\begin{displaymath}
f(\omega) = \int_{0}^{\infty} F(t) \,J_{\nu}(2\sqrt{\omega t}) \,dt 
\end{displaymath}

can be calculated by using the \verb+hankel_transform+ command e.g.

\begin{verbatim}
        hankel_transform(f(x),x);
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\subsection{Y-transform}

The Y-transform

\begin{displaymath}
f(\omega) = \int_{0}^{\infty} F(t) \,Y_{\nu}(2\sqrt{\omega t}) \,dt 
\end{displaymath}

can be calculated by using the \verb+Y_transform+ command e.g.

\begin{verbatim}
        Y_transform(f(x),x);    
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\subsection{K-transform}

The K-transform

\begin{displaymath}
f(\omega) = \int_{0}^{\infty} F(t) \,K_{\nu}(2\sqrt{\omega t}) \,dt
\end{displaymath}

can be calculated by using the \verb+K_transform+ command e.g.

\begin{verbatim}
        K_transform(f(x),x);    
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\subsection{StruveH transform}

The StruveH transform

\begin{displaymath}
f(\omega) = \int_{0}^{\infty} F(t) \,StruveH(\nu,2\sqrt{\omega t}) \,dt
\end{displaymath}

can be calculated by using the \verb+struveh_transform+ command e.g.

\begin{verbatim}
        struveh_transform(f(x),x);
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\subsection{Fourier sine transform}

The Fourier sine transform 

\begin{displaymath}
f(s) = \int_{0}^{\infty} F(t) \,sin (st) \,dt 
\end{displaymath}

can be calculated by using the \verb+fourier_sin+ command e.g.
\begin{verbatim}
        fourier_sin(f(x),x);    
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\subsection{Fourier cosine transform}

The Fourier cosine transform 

\begin{displaymath}
f(s) = \int_{0}^{\infty} F(t) \,cos (st) \,dt 
\end{displaymath}

can be calculated by using the \verb+fourier_cos+ command e.g.
\begin{verbatim}
        fourier_cos(f(x),x);
\end{verbatim}

This is used in the same way as the \verb+laplace_transform+ command.

\section{Additional Meijer G-function Definitions}

The relevant Meijer G representation for any function is found by a 
pattern-matching process which is carried out on a list of Meijer 
G-function definitions. This list, although extensive, can never hope 
to be complete and therefore the user may wish to add more definitions.
Definitions can be added by adding the following lines:

\begin{verbatim}
  defint_choose(f(~x),~var => f1(n,x);

  symbolic putv(mellin!-transforms!*,n,'
                (() (m n p q) (ai) (bj) (C) (var)));

\end{verbatim} 
     where f(x) is the new function, i = 1..p, j=1..q, C = a constant,
%where i = 1..p, j=1..q, C = a constant,  
     var = variable, n = an indexing number.

For example when considering $cos (x)$ we have

\it Meijer G representation  -  
\begin{displaymath}
\sqrt{\pi} \,G^{1 0}_{0 2}\left(\frac{x^{2}}{4} \ \Bigg\vert 
\ { . \; . \atop 0 \; \frac{1}{2}} \right) dx 
\end{displaymath}

\it Internal definite integration package representation  - 
\begin{verbatim}
  defint_choose(cos(~x),~var)   => f1(3,x);
\end{verbatim}

\rm where 3 is the indexing number corresponding to the 3
in the following formula

\begin{verbatim}
  symbolic putv(mellin!-transforms!*,3,'
                (() (1 0 0 2) () (nil (quotient 1 2))
                (sqrt pi) (quotient (expt x 2) 4)));
\end{verbatim} 

or the more interesting example of $J_{n}(x)$:

\it Meijer G representation  -  
\begin{displaymath}
G^{1 0}_{0 2} \left(\frac{x^{2}}{4} \ \Bigg\vert 
\ {. \; .  \atop \frac{n}{2} \; {\frac{-n}{2}}} \right) dx 
\end{displaymath}

\it Internal definite integration package representation  - 

\begin{verbatim}
  defint_choose(besselj(~n,~x),~var) => f1(50,x,n);

  symbolic putv(mellin!-transforms!*,50,'
                ((n) (1 0 0 2) () ((quotient n 2)
                                   (minus quotient n 2)) 1
                                   (quotient (expt x 2) 4)));
\end{verbatim} 

\section{The print\_conditions function}

\rm The required conditions for the validity of the transform integrals
can be viewed using the following command:

\begin{verbatim}
        print_conditions().
\end{verbatim}

For example after calculating the following laplace transform

\begin{verbatim}
        laplace_transform(x^k,x);
\end{verbatim}

using the \verb+print_conditions+ command would produce

\begin{verbatim}
                         
repart(sum(ai) - sum(bj)) + 1/2 (q + 1 - p)>(q - p) repart(s)
                         
 and ( - min(repart(bj))>
   else << off rounded; return nil>>;
>>
else << transform_mylessp(); return t>>;
end;


symbolic procedure transform_mylessp();

  begin scalar temp,cond_test;

  temp := lispeval '(list 'lessp (list 'mod (list 'arg 'eta))
                                (list 'times 'pi 'delta));
  if listp spec_cond then
        for each i in spec_cond do  if i = temp then cond_test := t;
  if cond_test neq t then spec_cond := temp . spec_cond;
end;


symbolic operator transform_mylessp;

flag('(arg_test),'boolean);

algebraic procedure arg_test(a,b);

%
% Test the validity of the following :-
%
%      a = (b + 2*k)*pi    k arbitrary integer
%

begin scalar temp;

if transform_tst neq t then
<< temp := (a - b*pi)/(2*pi); temp := symbolic (fixp temp);
   if temp = t  then return t else return nil>>
else << transform_arg_test(); return t>>;
end;

symbolic procedure transform_arg_test();

begin scalar temp,cond_test;

temp := lispeval '(list 'equal (list 'arg 'eta) (list 'times
                        (list 'plus 'delta (list 'times 2 'k)) 'pi));

if listp spec_cond then
 for each i in spec_cond do  if i = temp then cond_test := t;
if cond_test neq t then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test;

flag('(arg_test1),'boolean);

algebraic procedure arg_test1(a,b);

%
% Test the validity of the following :-
%
%      a = (b - 2*k)*pi    k = 0,1,....,[b/2]
%

begin scalar temp,int_test;

temp := (a - b*pi)/(-2*pi);
int_test := symbolic (fixp temp);

if int_test = t and  temp <= b/2 and temp >= 0 then return t
else return nil;
end;

flag('(arg_test2),'boolean);

algebraic procedure arg_test2(a,b);

% Test the validity of the following :-
%
%      a = b*pi     b > 0

if transform_tst neq t then
        if a/(b*pi) = 1 and b > 0 then t else nil
else
<< transform_arg_test2(); t>>;

symbolic procedure transform_arg_test2();

begin scalar temp,cond_test;

temp := lispeval '(list 'equal (list 'mod (list 'arg 'eta))
                                (list 'times 'pi 'delta));
if pairp spec_cond then

<< for each i in spec_cond do
   << if i = temp then cond_test := 't>>; >>;

if cond_test neq 't then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test2;

flag('(arg_test3),'boolean);

algebraic procedure arg_test3(a,b);

%
% Test the validity of the following :-
%
%      a = (b + 2*k)*pi     k >= 0 or k <= -(1 + b)  k an integer
%

begin scalar temp,int_test;
if transform_tst neq 't then

<< temp := (a - b*pi)/(2*pi);
   int_test := symbolic (fixp temp);

   if int_test = 't and (temp >= 0 or temp <= -(1+b)) then
       return 't else return nil>>
else << transform_arg_test3(); return 't>>;
end;

flag('(arg_test3a),'boolean);

algebraic procedure arg_test3a(a,b);

% Test the validity of the following :-
%
%      a = b*pi     b >= 0

if transform_tst neq t then

<< if a - b*pi = 0 then t else nil>>
else << transform_arg_test3(); t>>;

symbolic procedure transform_arg_test3();

begin scalar temp,cond_test;

temp := lispeval '(list 'equal (list 'arg 'eta) (list 'plus 'm
   (list 'difference 'n (list 'times (list 'quotient 1 2)
   (list 'plus 'p 'q) 'pi))));

if listp spec_cond then
 for each i in spec_cond do if i = temp then cond_test := t;
if cond_test neq t then spec_cond := temp . spec_cond;
end;

symbolic operator transform_arg_test3;

flag('(arg_test4),'boolean);

algebraic procedure arg_test4(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 1)*pi < a < (b + 2*k)*pi     k arbitrary integer

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);

if new_l1 = l1 then new_l1 := new_l1 + 1;

l2 := (a - b*pi + pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 then return 't else return nil;
end;

flag('(arg_test5),'boolean);

algebraic procedure arg_test5(a,b,xi);

% Test the validity of the following :-
%
%      (b + 2*k)*pi <= a < (b + 2*k + 1)*pi    -xi < k < 0 k an integer

begin scalar l1,l2,new_l2;

l1 := floor((a - b*pi)/(2*pi));
l2 := (a - b*pi - pi)/(2*pi);
new_l2 := ceiling(l2);
if l1 = new_l2 and l1 < 0 and -xi < l1 then return t else return nil;
end;

flag('(arg_test6),'boolean);

algebraic procedure arg_test6(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     1-xi < k < 1   k an integer

begin scalar l,int_test;

l := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp l);
if int_test = t and l < 1 and l > 1 - xi then return t else return nil;
end;

flag('(arg_test6a),'boolean);

algebraic procedure arg_test6a(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     1-xi <= k <= 0

begin scalar l,int_test;

l := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp l);
if l <= 0 and l >= 1 - xi then return t else return nil;
end;

flag('(arg_test7),'boolean);

algebraic procedure arg_test7(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k)*pi     k >= 0 or k <= -xi   k an integer

begin scalar temp,int_test;

temp := (a - b*pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test=t and (temp >= 0 or temp <= -xi) then return t
else return nil;
end;

flag('(arg_test8),'boolean);

algebraic procedure arg_test8(a,b);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     k arbitrary integer

begin scalar temp,int_test;

temp := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test = t then return t else return nil;
end;

flag('(arg_test8a),'boolean);

algebraic procedure arg_test8a(a,b,xi);

% Test the validity of the following :-
%
%      a = (b + 2*k - 1)*pi     k >= 1 k <= 1 - xi  k an integer

begin scalar temp,int_test;

temp := (a - b*pi + pi)/(2*pi);
int_test := symbolic (fixp temp);
if int_test = t and (temp >= 1 or temp <= 1 - xi) then return t
else return nil
end;

flag('(arg_test9),'boolean);

algebraic procedure arg_test9(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 2)*pi < a < (b + 2*k)*pi     k arbitrary

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);
if new_l1 = l1 then new_l1 := new_l1 + 1;
l2 := (a - b*pi + 2*pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 then return t else return nil;
end;

flag('(arg_test9a),'boolean);

algebraic procedure arg_test9a(a,b);

% Test the validity of the following :-
%
%      (b + 2*k - 2)*pi < a < (b + 2*k)*pi     1 - b <= k <= 0
%                                                       k arbitrary

begin scalar l1,l2,new_l1,new_l2;

l1 := (a - b*pi)/(2*pi);
new_l1 := ceiling(l1);
if new_l1 = l1 then new_l1 := new_l1 + 1;
l2 := (a - b*pi + 2*pi)/(2*pi);
new_l2 := floor(l2);
if new_l2 = l2 then new_l2 := new_l2 - 1;
if new_l1 = new_l2 and (1 - b <= new_l1 or new_l1 <= 0) then
    return t else return nil;
end;

symbolic procedure transform_test2(n1,n2);

begin scalar lst,temp,cond_test;

if transform_tst neq t then return t else
<< if n1 then temp := lispeval cdr assoc(n1,transform_lst) . temp;
   if n2 then temp := lispeval cdr assoc(n2,transform_lst) . temp;

   temp := 'and . temp;
   for each j in spec_cond do  if j = temp then cond_test := t;
   if cond_test neq t then spec_cond := temp . spec_cond;
   return nil;
>>;
end;

symbolic operator transform_test2;

endmodule;
end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint.red0000644000175000017500000000416211526203062023725 0ustar  giovannigiovannimodule defint;  % Special functions integrator package for REDUCE.

% Author:  Kerry Gaskell 1993/94.
%          Winfried Neun, Jan 1995 ...
%          contribution from Victor Adamchik (WRI)

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load_package limits,specfn2;

algebraic operator m_jacobip,m_gegenbauerp,m_laguerrep,m_hermitep,
                m_chebyshevu,m_chebyshevt,m_legendrep,
                struveh2,mycosh,mysinh;

global '(spec_cond unknown_tst product_tst transform_tst transform_lst);


create!-package ('(defint definta defintc defintf definti defint0
                defintd defintg defintj defintb definte
                definth defintk defintx),
%               definth defintk),
                 '(contrib defint));

!#if (memq 'psl lispsystem!*)
  flag('(definta defintb definte defintf definti defintk),'lap);
!#endif

fluid '(MELLINCOEF);
SHARE MELLINCOEF$

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintx.red0000644000175000017500000006276111526203062024126 0ustar  giovannigiovannimodule defintx;  % Code for definite integration using contour methods.

% Author: Stanley L. Kameny .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load_package solve,misc;

fluid '(!*allpoly rdon!* !*norationalgi); switch allpoly;

global '(domainlist!* poles!*);

algebraic <<
logcomplex :=
 {
  log(~x + i) =>
      log(sqrt(x*x+1))+i*atan2(1/sqrt(x*x+1),x/sqrt(x*x+1))
      when repart(x)=x,
  log(~x - i) =>
      log(sqrt(x*x+1))-i*atan2(1/sqrt(x*x+1),x/sqrt(x*x+1))
      when repart(x)=x,
  log(~x + i*~y) =>
      log(sqrt(x*x+y*y))+i*atan2(y/sqrt(x*x+y*y),x/sqrt(x*x+y*y))
      when repart(x)=x and repart(y)=y,
  log(~x - i*~y) =>
      log(sqrt(x*x+y*y))-i*atan2(y/sqrt(x*x+y*y),x/sqrt(x*x+y*y))
      when repart(x)=x and repart(y)=y,
  log(~x/~y) => log(x) - log(y) when repart(y)=y,
  log(sqrt ~x) => (log x)/2,
  log(-1) => i*pi,
  log (-i) => -i*pi/2,
  log i => i*pi/2,
  log(-~x) => i*pi+log x when repart(x)=x and numberp x and x>0,
  log(-i*~x) => -i*pi/2 + log x
       when repart(x)=x and numberp x and x>0,
  log(i*~x) => i*pi/2 + log x  when repart(x)=x and numberp x and x>0
}$

atan2eval :=
 {
  atan2(sqrt 3/2,1/2) => pi/3,
  atan2(-sqrt 3/2,1/2) => -pi/3,
  atan2(sqrt 3/2,-1/2) => 2*pi/3,
  atan2(-sqrt 3/2,-1/2) => -2*pi/3,
  atan2(3/(2*sqrt 3),1/2) => pi/3,      % these shouldn't be needed
  atan2(-3/(2*sqrt 3),1/2) => -pi/3,    % these shouldn't be needed
  atan2(3/(2*sqrt 3),-1/2) => 2*pi/3,   % these shouldn't be needed
  atan2(-3/(2*sqrt 3),-1/2) => -2*pi/3, % these shouldn't be needed
  atan2(1/2,sqrt 3/2) => pi/6,
  atan2(-1/2,sqrt 3/2) => -pi/6,
  atan2(1/2,-sqrt 3/2) => 5*pi/6,
  atan2(-1/2,-sqrt 3/2) => -5*pi/6,
  atan2(1/2,3/(2*sqrt 3)) => pi/6,      % these shouldn't be needed
  atan2(-1/2,3/(2*sqrt 3)) => -pi/6,    % these shouldn't be needed
  atan2(1/2,-3/(2*sqrt 3)) => 5*pi/6,   % these shouldn't be needed
  atan2(-1/2,-3*(2*sqrt 3)) => -5*pi/6, % these shouldn't be needed
  atan2(sqrt 2/2,sqrt 2/2) => pi/4,
  atan2(-sqrt 2/2,sqrt 2/2) => -pi/4,
  atan2(sqrt 2/2,-sqrt 2/2) => 3*pi/4,
  atan2(-sqrt 2/2,-sqrt 2/2) => -3*pi/4,
  atan2(0,-1) => pi,
  atan2(0,1) => 0,
  atan2(1,0) => pi/2,
  atan2(-1,0) => -pi/2
}$

ipower := {i^~n => cos(n*pi/2) + i*sin(n*pi/2),
    (-i)^~n => cos(n*pi/2) - i*sin(n*pi/2)}$

>> $

% We can't set atan2eval rules if rounded is on.

begin scalar oldmode;
      if !*rounded then oldmode := setdmode('rounded,nil);
      algebraic let ipower,atan2eval;
      if oldmode then setdmode('rounded,t)
   end;

%algebraic let logcomplex,atan2eval;

fluid '(!*diffsoln zplist!! poles!# !*msg !*rounded !*complex zlist);
switch diffsoln;

load_package int;

% put('defint,'psopfn,'defint0);

symbolic procedure defint0 u;
   begin
      scalar rdon!*,!*msg,c,!*noneglogs,fac,!*norationalgi,
         !*combinelogs,!*rationalize;
      if not getd 'solvesq then load_package solve;
      if length u neq 4 then rederr
        "defint called with wrong number of args";
      c := !*complex; off complex; % since complex on won't work here!
    %  on complex;  % this causes trouble here, so it was moved into
                    % defint11s after splitfactors has operated!
      !*noneglogs := t;
      algebraic (let logcomplex); %,atan2eval);
      fac := !*factor; on factor; !*norationalgi := t;
      u := errorset2 {'defint1,mkquote u};
      !*norationalgi := nil;
      if errorp u then <>
          where rl=repartsq u,im=impartsq u,eps=10.0^(2-precision 0));
      !*rationalize := t;
      u := aeval prepsq u;
      on complex;
      u := simp!* u;
   %   u := evalletsub2({'(logcomplexs),
   %      {'simp!*,{'prepsq,mkquote u}}},nil);
   %   if errorp u then error(99,list("error during log simp"))
   %      else u := car u;
 ret: if fac then on factor;
      algebraic (clearrules logcomplex); %,atan2eval);
      if u neq 'failed then u := prepsq u;
      off complex; on combinelogs;
      if u neq 'failed then u := aeval u;
ret2: if c then on complex;
      return u end;

symbolic procedure defint1 u; defint11s(car u,cadr u,caddr u,cadddr u);

symbolic procedure defint11s(exp,var,llim,ulim);
  % removes from integrand any factors independent of var, and passes
  % the dependent factors to defint11.  Based on FACTOR being on.
   <<% off complex; % not needed here since complex is off already.
     exp := splitfactors(simp!* aeval exp,var);
     on complex; % at this point it is safe to turn complex on.
     multsq(simp!* car exp,
        defint11(cadr exp,var,llim,ulim,t))>>;

symbolic procedure fxinfinity x;
  if x eq 'infinity then 'inf
   else if x = '(minus infinity) then 'minf else x;

symbolic procedure defint11(exp,var,llim,ulim,dtst);
  if evalequal(llim := fxinfinity llim, ulim := fxinfinity ulim)
    or evalequal(exp,0) then nil ./ 1 else
  begin scalar !*norationalgi,r,p,q,poles,rlrts,cmprts,q1;
     scalar m,n;
     if ulim = 'minf or llim = 'inf then
        return defint11({'minus,exp},var,ulim,llim,dtst);
     exp := simp!* exp;
    % Now the lower limit must be 'minf or a finite value,
    % and the upper limit must be 'inf or a finite value. There are
    % four cases:
    % Upper limit is 'inf.  Convert lower limit to zero if necessary,
    % and use methods for infinite integrals.
     if ulim = 'inf then
        <>;
          go to c0>>;
    % lower limit is 'minf.  Convert this case to upper limit 'inf.
     if llim = 'minf then
        <>;
    % Both limits are finite, so check for indef integral and
    % substitute values if it exists; else check for special forms with
    % finite limits, try substitutions, or abort.
     r := simpint {prepsq exp,var};
     if eqcar(prepsq r,'int) then go to c1;
     p := errorset2 list('subsq, mkquote r, mkquote {var . ulim});
     q := errorset2 list('subsq, mkquote r, mkquote {var . llim});
     if errorp(p) or errorp (q) then <<
        p:= simplimit list('limit!- ,mk!*sq(r),var,ulim);
        q:= simplimit list('limit!+ ,mk!*sq(r),var,llim); >>
     else <
    >;
     return q1 := addsq(p,negsq q);
 c1: rederr "special forms for finite limits not implemented";
 c0: r := exp; p := numr r; q := denr r;
  %   if not polynomp(q,var) then
   %     rederr "only polynomial denominator implemented";
     m := degreeof(p,var); n := degreeof(q,var);
     if smemql('(failed infinity),m) or smemql('(failed infinity),n)
       then return error(99, 'failed);
    % Note that degreeof may return a fraction or a general complex
    % quantity.
     if not evalgreaterp(prepsq addsq(repartsq n,negsq repartsq m),1)
        then go to div;
    % this is the point at which special cases can be tested.
     if (q1 := specformtestint(q,p,var,llim,ulim)) then return q1;
    % beyond here, only rational functions are handled.
     if not (m := sq2int m) or not (n := sq2int n) then
       <>;
     if n - m < 2 then go to div;
     if dtst and !*diffsoln then
        if (q1 := diffsol(q,p,m,n,var,llim,ulim)) then return q1;
     off factor; !*norationalgi := nil;
     poles := getpoles(q,var,llim);
     rlrts := append(car poles,cadr poles); cmprts := caddr poles;
     !*norationalgi := t;
     q1 := difff(q,var); q := q ./ 1;  p := p ./ 1;
     return if llim = 0 then defint2(p,q,q1,var,rlrts,cmprts)
        else defint3(p,q,q1,var,rlrts,cmprts);
div: % write "integral diverges"; terpri();
     error(99,'failed) end;

symbolic procedure zpsubsq x;
   subsq(x,for each v in zplist!! collect (v . 0));

symbolic procedure degreeof(p,var);
   % p is a standard form.
   % Note that limit returns "failed" as a structure, not an id.
   % Also, the limit code has problems with bessels at the present time.
  % if smemq('besseli,p) then !*k2q 'failed else
  if smemql ('(besselj besselk bessely besseli),p) then !*k2q 'failed else
  (if null car de then de else
    <>)
    where d=dmode!*,de=difff(p,var);

symbolic procedure genminusp x;
   if domainp x then !:minusp x else !:minusp topeval prepf x;

symbolic procedure sq2int x;
  (if null numr impartsq x and denr y=1
     then if null z then 0 else if numberp z then z else nil)
   where z=numr y where y=repartsq x;

symbolic procedure topeval u;
  <>
  where r=!*rounded,c=!*complex,!*msg=nil;

symbolic procedure firstatom x;
   if atom x then x else firstatom car x;

symbolic procedure valueof u;
   (if firstatom x neq 'root_of then x) where x=caar u;

symbolic procedure rdsolvesq u;
   solvesq(subf(numr simp!* cadr x,list((caddr x) . caadr u)),
        caadr u,caddr u)
   where x=caaaar caar u;

symbolic procedure defint2(p,q,q1,var,rlrts,cmprts);
  % Does the actual computation of integral with limits 0, inf.
  % Pertinent poles and their orders have been found previously.
     begin scalar int;
error(99,"THIS IS WRONG, Stanley!!");
        p := simp!* aeval{'times,{'log,{'minus,var}},prepsq p};
        int := nil ./ 1;
        for each r in append(rlrts,cmprts) do
           int := addsq(int,residuum(p,q,q1,var,prepsq car r,cdr r));
        return negsq int end;

symbolic procedure defint3(p,q,q1,var,rlrts,cmprts);
  % Does the actual computation of integral with limits minf, inf.
  % Pertinent poles and their orders have been found previously.
     begin scalar int,int2;
        int := int2 := nil ./ 1;
        for each r in cmprts do
           int := addsq(int,residuum(p,q,q1,var,prepsq car r,cdr r));
        int := addsq(int,int);
        for each r in rlrts do
           int2 := addsq(int2,residuum(p,q,q1,var,prepsq car r,cdr r));
        int := addsq(int,int2);
        return multsq(simp!* '(times pi i),int) end;

symbolic procedure diffsqn(sq,var,n);
   <0 then for j := 1:n do sq := diffsq(sq,var); sq>>;


symbolic procedure polypwrp(exp,var);
   begin scalar pol,fl; integer s,pwr;
     if eqcar(exp,'expt) then
       <>
     else if eqcar(exp,'times) then
       <>;
         if fl then return nil;
         s := (for each p in exp sum cadr p * caddr p)/pwr;
         pol := 'times .
           for each p in exp collect {'expt,car p,caddr p/pwr};
         return {pol,s,pwr}>> end;

symbolic procedure termvpwr(p,var);
   if freeof(p,var) then 0
   else if atom p then 1
   else if eqcar(p,'expt) and cadr p = var and
     numberp caddr p then caddr p
   else if eqcar(p,'times) then for each q in cdr p sum termvpwr(q,var)
   else 0;

symbolic procedure diffsol(q,p,mm,nn,var,llim,ulim);
  % p is numerator   q is denom    mm is deg p   nn is deg q
   (q := polypwrp(prepf q,var)) and
   begin scalar n,s,m,r,zplist!!;
     n := mm; s := cadr q; m := caddr q;
    % if s, the power of the base polynomial, > 4 then the base
    % polynomial won't be solved, and this approach won't work!
    % However, for s > 2, the approach is impractical, because the
    % roots of the zp!! polynomial are too complicated, so in the
    % following, s is tested s > 2.
     if s > 2 or m*s neq nn or nn - n <= 2 then return nil;
     r := (n+2)/s; if r*s < n+2 then r := r+1;
     if m = r then return nil;
     q := {'plus,car q,'zp!!}; zplist!! := '(zp!!);
     q := numr simp!*{'expt,q,r};
     nn :=(-1)^(m - r)*factorial(r - 1) ./ factorial(m - 1);
     p := defint11(prepsq(p ./ q),var,llim,ulim,nil);
     p := zpsubsq diffsqn(p,'zp!!,m - r);
     return multsq(nn,p) end;

symbolic procedure residuum(p,q,q1,var,pole,m);
   if m=1 then subsq(quotsq(p,q1),list(var . pole))
   else
   begin integer n;
     q1 := nil;
     for each r in poles!* do
       <>;
     n := ((lc numr simp!* prepsq q) where !*factor=nil);
     q1 := 'times . (n . q1);
     return if ((lt numr simp!* prepsq q =
       lt numr simp!*{'times,{'expt,{'difference,var,pole},m},q1})
          where !*factor=nil)
       then
           <>
         else q1 := simp!* (p := limit(
           prepsq
             quotsq(diffsqn(multsq(quotsq(p,q),
                 simp!* {'expt,{'difference,var,pole},m}),var,m - 1),
               factorial(m - 1) ./ 1),var,pole)) end;

symbolic procedure splitfactors(u,var);
  % returns a list of two factors:
  % independent of var and dependent on var.
   begin scalar n,d,ni,nd,di,dd,fli,fld;
     n := prepf numr u;
     if n=0 then return {0,0};
     d := prepf denr u;
     ni := nd := di := dd := 1;
     if simptermp n then
       <>;
     for each x in cdr n do
         if freeof(x,var) then ni := if ni = 1 then list x
              else <>
            else nd := if nd = 1 then list x else <>;
     ni := fleshoutt(ni,fli); nd := fleshoutt(nd,fld);
     fli := fld := nil;
  d: if simptermp d then
       <>;
     for each x in cdr d do
         if freeof(x,var) then di := if di = 1 then list x
              else <>
            else dd := if dd = 1 then list x else <>;
     di := fleshoutt(di,fli); dd := fleshoutt(dd,fld);
ret: return {fleshout(ni,di),fleshout(nd,dd)} end;

symbolic procedure simptermp x;
   atom x or ((y = 'minus and simptermp cadr x or y neq 'times)
     where y=car x);

symbolic procedure fleshout(n,d); if d = 1 then n else {'quotient,n,d};

symbolic procedure fleshoutt(n,d);
   if n = 1 then n else if d then 'times . n else car n;

symbolic procedure specformtestint(den,num,var,llim,ulim);
  % This tests for defint(x^(p-1)/(a*x^n+b)^m,x,0,inf) with
  % m,n,p positive integers, p/n not integer and m>(p/n) and either
  %    a*b>0   or   {a*b<0,m=1}.
  % Since splitfactors has removed all factors which do not depend upon
  % var, both num and den are either 1 or products of terms which
  % depend upon var.
   begin scalar a,b,d,m,n,p,q1,q,k,z,ff;
     den := prepf den; num := prepf num;
     if not(llim=0) and ulim='inf then go to t2;
    % This is the test for defint(y**(q-1)/(a*y**n +b)**m,y,0,inf);
    % which is converted to defint(x**(p-1)/(x+z)**m,x,0,inf);
    % the next test is assumed to be accessed at label t2.
     if num = 1 then q1 := 0
       else if (q1 := varpwrtst(num,var))=0 then go to t2;
     if atom den then go to t2
       else if not eqcar(den,'times) then
        %only (a*y**n+b)**m term in den.
         if (k := aynbmtst(den,var)) then go to sep4 else go to t2
       else if length den neq 3 then go to t2;
    % the denominator is the product of 2 terms, one of which must be
    % y**q and the other an aynbm form like the previous case.
     d := cdr den;
     if not((k := aynbmtst(cadr d,var))
            and eqcar(q := varpwrtst(car d,var),'quotient)
            or
            (k := aynbmtst(car d,var))
            and eqcar(q := varpwrtst(cadr d,var),'quotient))
              then go to t2;
sep4: n := caddr k; if not numberp n then go to t3;
     q := prepsq simp!* {'plus,1,q1,{'minus,q}};
     p := prepsq simp!* {'quotient,q,n};
     m := cadddr k; if not numberp m or m<1 then go to t3;
     a := car k;
     b := cadr k;
     z := prepsq simp!* {'quotient,b,a};
       if numr impartsq simp!* z then go to t2;
     ff := prepsq simp!* aeval {'quotient,1,{'times,n,{'expt,a,m}}};
    % there are two different cases:
    %  z > 0 and m >repart p >0  m >= 1
    %  z < 0 and m=1 (Cauchy principal value)
     if evalgreaterp(z,0) then if
       not (evalgreaterp((k := prepsq repartsq simp!* p),0) and
         evalgreaterp(m,k))
       then go to t3
     else
      <>;
    if m neq 1 then go to t3;
    write "Cauchy principal value"; terpri();
    k := prepsq simp!* aeval
      {'minus,{'expt,{'quotient,-1,z},{'difference,1,p}}};
    q := prepsq simp!* aeval
      {'times,ff,{'quotient,'pi,{'times,a,n}},{'cot,{'times,'pi,p}}};
    return simp!* aeval {'times,k,q};
t3: return nil; % most (if not all) of these are divergence cases.
t2: return specformtestint2(den,num,var,llim,ulim) end;

symbolic procedure aynbmtst(exp,var);
  % test for form (a*y**n+b)**m (or degenerate forms of this) and
  % extract parameters a,n,b,m.  b qnd m are required to be present.
  % car exp = 'expt or else m=1.
   begin scalar a,b,m,n;
      if not eqcar(exp,'expt) then <>;
      m := caddr exp;
      exp := cadr exp;
  a2: if not eqcar(exp,'plus) or length exp neq 3 then return nil;
      b := caddr exp;
      if eqcar(cadr exp,'times) then
         <>
        else
          <>;
      return {a,b,n,m} end;

fluid '(!*fullpoly); switch fullpoly;

symbolic procedure getpoles(q,var,llim);
   begin scalar poles,rt,m,rlrt,cmprt,rtv,rtvz,cpv,prlrts,nrlrts,rlrts,
       cmprts,!*multiplicities,!*fullroots,!*norationalgi;
     off factor; !*norationalgi := poles!* := nil;
     !*multiplicities := t;
    if !*fullpoly then !*fullroots := t;
    % if !*allpoly = 'all then
    %   <>;
     poles := solvesq(simp!* prepf q,var,1);
     !*norationalgi := t;
 lp: if null poles then go to int;
     rt := car poles; poles := cdr poles; m := caddr rt;
     rlrt := cmprt := nil;
     if (rtv := valueof rt) then
        < 1 then go to div else cpv := t;
                       prlrts := (rlrt . m) . prlrts>>
                     else nrlrts := (rlrt . m) . nrlrts>>
               else cmprts := (cmprt . m) . cmprts; go to lp>>
          else
             < 1 then go to div else cpv := t;
                    rlrts := (rlrt . m) . rlrts>>
               else if not genminusp car impartsq rtvz then
                  cmprts := (cmprt . m) . cmprts>>;
          go to lp>>;
una: if !*rounded then rederr "unable to find poles approximately";
     if not !*allpoly then < 4.  Approx integral requires ON ALLPOLY";
        terpri(); error(99,"failed")>>
        else <>;
     on rounded; rdon!* := t;
     if valueof car(rt := rdsolvesq rt) then
        <>;
     go to una;
div: % write "integral diverges"; terpri();
     error(99,'failed);
int: if cpv then <>;
     return if llim=0 then {prlrts,nrlrts,cmprts}
         else {rlrts,nil,cmprts} end;

symbolic procedure specformtestint2(den,num,var,llim,ulim);
  % This checks for defint(x^k*R(x),x,0 inf) where {k != 0,-11 on positive real axis.
   begin scalar d,k,k1,m,p,p1,q,q1,poles,prpoles,s1,s2;
     if not(llim=0) and ulim='inf then go to t2;
     p1 := polanalyz(num,var);
     k1 := polanalyz(den,var);
     if not (p1 or k1) then go to t2;
     k := prepsq simp!* aeval {'difference,p1,k1};
     if numberp k or not(evalgreaterp(k,-1) and evalgreaterp(1,k))
        then go to t2;%<==  this was t3 but caused problem!
     if (d := dmode!*) then onoff(d := get(d,'dname),nil);
     m := prepsq simp!* aeval {'quotient,{'times,var,num},den};
     if numr simp!* limit!+(m,var,0)
       or numr simp!* limit(m,var,'infinity) then go to t3;
     if d then onoff(d,t);
    % all tests met, except for finding poles of den.
    % move irrational factor to numerator, changing the sign of var.
     p := simp!* aeval {'times,num,
        {'expt,var,{'times,-1,p1}},{'expt,{'minus,var},k}};
    % note that p in general has a non-trivial denominator.
    % now remove irrational factor from denominator, leaving polynomial.
       q := simp!* aeval {'times,den,{'expt,var,{'times,-1,k1}}};
       q1 := diffsq(q,var);
     poles := getpoles(numr q,var,llim);
     prpoles := car poles; poles := append(cadr poles,caddr poles);
     s1 := s2 := nil ./ 1;
     k1 := {'times,'pi,{'plus,k,1}};
     if poles then
       <>
       else s1 := 0;
     if prpoles then
       <>
       else s2 := 0;
     return simp!* aeval {'difference,s1,s2};
 t2: return nil;  % replace by call to next test.
 t3: % write "integral diverges"; terpri();
     error(99,'failed)  end;

symbolic procedure polanalyz(exp,var);
  % test for fractional power of var in exp.
   if poltstp exp then
   ((if eqcar(
     exp := varpwrtst(if eqcar(ex2,'times) then cadr ex2 else ex2,var),
      'quotient) then exp else 0)
    where ex2=if eqcar(exp,'minus) then cadr exp else exp);

symbolic procedure poltstp exp;
   atom exp and exp or car exp member domainlist!* or
     car exp member '(plus times quotient minus expt sqrt) and
   begin scalar fg;
     for each c in cdr exp do if not poltstp c then fg := t;
     return null fg end;

symbolic procedure evalmax(a,b);
   if numberp a and numberp b then max(a,b)
     else if evalgreaterp(a,b) then a else b;

symbolic procedure evalplus(a,b);
   if numberp a and numberp b then a+b
   else prepsq simp!* aeval {'plus,a,b};

symbolic procedure varpwrtst(exp,var);
   if atom exp then if exp = var then 1 else 0
   else if car exp eq 'minus then varpwrtst(cadr exp,var)
   else if car exp member '(plus,difference) then
     (<>
      where q=0)
   else if eqcar(exp,'expt) then
     prepsq simp!* aeval{'times,varpwrtst(cadr exp,var),caddr exp}
   else if eqcar(exp,'sqrt) then
     prepsq simp!* aeval{'times,varpwrtst(cadr exp,var),{'quotient,1,2}}
   else if eqcar(exp,'times) then
     (<>
      where q=0)
   else 0;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintg.red0000644000175000017500000002550211526203062024075 0ustar  giovannigiovannimodule defintg;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*precise);

symbolic procedure print_conditions;

<< if spec_cond neq nil then mathprint ('or . spec_cond) else
            rederr "Conditions not valid";
        spec_cond := nil;
>>;

symbolic operator print_conditions;

symbolic procedure defint_reform(n);

% A function to rearrange the input to the integration process by
% expanding out multiple powers of the exponential function i.e.
%
%     2               2
%    x + x + 1       x     x
%   e            => e  * e  * e
%

begin scalar n,var,vble,const,result,reform_test,temp_result,
                reform_lst,lst,new_lst,res,coef,new_coef;

% test if integral needs to be reformed

on exp;
coef := 1;

var := caddar n;
const := caddr n;
vble := cadddr n;

% test to see if any part of the integral needs reforming

for each i in n do

<< if eqcar(i,'defint_choose) then

% test for integrals of a single function multiplied by a constant

   << if i neq '(defint_choose e x) and numberp cadr i
                and cadr i neq 0 then

      << new_coef := cadr i;
         coef := reval algebraic(coef*new_coef);
         n := const_case(n)>>

% special case for integration of 0

      else if i = '(defint_choose 0 x) then coef := 0

% test for special case of integral of e
      else if i = '(defint_choose e x) then
           coef := reval algebraic(e*coef)

      else if caadr i = 'expt then

      << reform_test := 't;
% Form a list of the functions which must be reformed
         reform_lst := append(reform_lst,{i})>>

      else if caadr i = 'quotient

% don't reform special compound functions which are represented as a
% single Meijer G-function

                and (listp cadadr i and car cadadr i neq 'm_chebyshevt
                        or not listp cadadr i) then

      << reform_test := 't;
% Form a list of the functions which must be reformed
         reform_lst := append(reform_lst,{i})>>

      else if caadr i = 'times then

      << if listp car cddadr i
                  and (caar cddadr i = 'm_chebyshevu
                  or caar cddadr i = 'm_jacobip

% do not reform functions containing the heaviside function

                  or car cadadr i = 'heaviside)
     then
          lst := append(lst,{i})  % A list of the functions which do
                                % not need reforming

         else if listp cdr cddadr i and cdr cddadr i neq 'nil
                        and listp cadr cddadr i
                           and caadr cddadr i = 'm_gegenbauerp
     then
          lst := append(lst,{i})  % A list of the functions which do
                                % not need reforming
         else << reform_test := 't;
% Form a list of the functions which must be reformed
            reform_lst := append(reform_lst,{i});>>
      >>
      else lst := append(lst,{i});  % A list of the functions which do
                                    % not need reforming
   >>;
>>;

if reform_test = nil then << n := coef . n; return n>>
else

<< for each i in reform_lst do

   << new_lst := cadr i;
      if car new_lst = 'expt and cadr new_lst = 'e then
          res := reform_expt(new_lst,var)
      else if car new_lst = 'times then
          res := reform_const(new_lst,var)
      else if car new_lst = 'quotient and cadr new_lst = 1 then
          res := reform_denom(new_lst,var)
      else if car new_lst = 'quotient then
          res := reform_quot(new_lst,var);
      new_coef := car res;
      coef := reval algebraic(coef*new_coef);
      res := cdr res;
      temp_result := append(temp_result,res);
   >>;

   temp_result := coef . temp_result;
   result := append(temp_result,lst);

if lst = nil and length result = 2 then result := append(result,{0});
   result := append(result,{const});
   result := append(result,{vble});
   return result;
>>;

end;


% A function to rearrange the integral if it contains exponentials of
% only positive numbers and there is no constant term

symbolic procedure reform_expt(n,var);

begin scalar temp,coef,lst;

% test for exponentials which do not need reforming i.e. e^x

if not listp n then
<< lst := {{'defint_choose,n,var}}; lst := 1 . lst>>

else if listp caddr n neq t then

<< if numberp caddr n then coef := n
         else lst := {{'defint_choose,n,var}}; >>

else if caaddr n = 'quotient then lst := {{'defint_choose,n,var}}

else
<<  temp := cdaddr n;
   for each i in temp do
   << lst := ({'defint_choose,{'expt,'e,car temp},var} . lst);
      temp := cdr temp>>;
>>;
if coef neq nil then lst := coef . lst else lst := 1 . lst;
return lst;
end;


% A function to rearrange the integral if the exponential is multiplied
% by a constant term

symbolic procedure reform_const(n,var);

begin scalar temp,coef,lst,temp1;

temp := n;

coef := caddr temp;
temp := cadr temp;

if temp neq nil and car temp = 'expt and (atom caddr temp or
                        caaddr temp neq 'plus) then
<< lst := {{'defint_choose,{'expt,'e,caddr temp},var}}>>
else
<< temp1 := cdaddr temp;
   for each i in temp1 do
   << lst := ({'defint_choose,{'expt,'e,car temp1},var} . lst);
      temp1 := cdr temp1>>;
>>;
if coef neq nil then lst := coef . lst else lst := 1 . lst;
return lst;
end;

% A function to rearrange the integral if all the exponential powers
% are negative powers

symbolic procedure reform_denom(n,var);
   begin scalar temp,coef,lst,temp1;
      temp := caddr n;
      % if the function contains e^n where n is a number than this can
      % be taken outside the integral as a constant.
      if not(eqcar(temp,'expt) or eqcar(temp,'times))
                        then return list(1,list('defint_choose,n,var));

      if temp = 'e or fixp caddr temp then <>
       else if car temp = 'times then
        <>
           else << coef := caddr temp; temp := cadr temp>>>>;
      % test for a single occurrence of e.
      if temp and eqcar(caddr temp ,'quotient)
              and listp car cdaddr temp and listp cadr cdaddr temp then
      << off mcd; temp:= {'expt,'e,quotient_case(reval temp)}; on mcd>>;
      if temp and car temp = 'expt and (atom caddr temp or
                              caaddr temp neq 'plus) then
      <>
      % else if there are multiple occurrences of e
      else if pairp caddr temp then
      << temp1 := cdaddr temp;
         for each i in temp1 do
         << lst:=({'defint_choose,
                       {'quotient,1,{'expt,'e,car temp1}},var}
                       . lst); temp1 := cdr temp1>>>>;
  a:  return if coef then lst := ({'quotient,1,coef} . lst)
              else lst := 1 . lst
   end;

% A function to rearrange the integral if the exponential consists of
% both positive and negative powers

symbolic procedure reform_quot(n,var);

begin scalar num,denom,num_coef,denom_coef,lst,num1,denom1;

num := cadr n;
denom := caddr n;

% Check for constants

if fixp num or atom num then << num_coef := num; num := nil>>

else if num = 'e or fixp caddr num then
        << num_coef := num; num := nil>>

else if car num  = 'times then
        << num_coef := caddr num; num  := cadr num>>;

if fixp denom or atom denom then
        << denom_coef := denom; denom := nil>>

else if denom = 'e or fixp caddr denom then
           << denom_coef := denom; denom := nil>>

else if car denom  = 'times then
        << denom_coef := caddr denom; denom  := cadr denom>>;

if denom and car denom = 'expt and (atom caddr denom or
                        caaddr denom neq 'plus) then
     lst := {{'defint_choose,{'quotient,1,
                {'expt,'e,caddr denom}},var}}

else if denom then

<< denom1 := cdaddr denom;
%  for each i in denom1 do
%  << lst := ({'defint_choose,{'quotient,1,
%               {'expt,'e,car denom1}},var} . lst);
%     denom1 := cdr denom1>>;
   for each i in denom1 do
     lst := ({'defint_choose,{'quotient,1,
                {'expt,'e,i}},var} . lst)>>;

if not atom num and car num = 'expt and (atom caddr num or
                        caaddr num neq 'plus) then

    lst := {'defint_choose,{'expt,'e,caddr num},var} . lst

else if not atom num then

<< num1 := cdaddr num;
   for each i in num1 do
   << lst := ({'defint_choose,{'expt,'e,car num1},var} . lst);
      num1 := cdr num1>>;
>>;

if num_coef then lst := (num_coef . lst)

else if denom_coef neq nil then
    lst := ({'quotient,1,denom_coef} . lst)

else lst := 1 . lst;
return lst;
end;

symbolic procedure const_case(n);

begin scalar n,new_n;
for i := 0 :length n do
<< if not listp car n or listp car n and not numberp cadar n then
       new_n := append(new_n,{car n}); n := cdr n>>;

new_n := append(new_n,{0});
new_n := append(new_n,n);
return new_n;
end;

symbolic procedure quotient_case(n);

begin scalar lst,new_lst;

lst := cdaddr n;
new_lst := {caaddr n};

for each i in lst do
<< if caddr i < 0 then
   << caddr i := minus caddr i;
      i := {car i,cadr i, {'minus,caddr i}}>>;
  new_lst := append(new_lst,{i});
>>;
return new_lst;
end;

put('transf,'simpfn,'simpinteg);
% put('indefint,'psopfn,'new_indefint);

symbolic procedure new_indefint(lst);
   begin scalar var,y,n1,n2,result,!*precise;
      if eqcar(car lst,'times)
        then return new_indefint append(cdar lst,cdr lst);
      result := 'unknown;  %%%%%% This line is new %%%%%%%
      var := nth(lst,length lst - 1);
      y := nth(lst,length lst);
      lst := hyperbolic_test(lst);
      if length lst = 4 then << n1 := car lst; n2 := cadr lst;
              result := reval algebraic indefint2(n1,n2,var,y)>>
      else if length lst = 3 then << n1 := car lst;
              result := reval algebraic indefint2(n1,var,y)>>;
      return result
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint.hlp0000644000175000017500000000660511526203062023742 0ustar  giovannigiovanni\chapter{DEFINT: Definite Integration for REDUCE}
\label{DEFINT}
\typeout{{DEFINT: Definite Integration for REDUCE}}

{\footnotesize
\begin{center}
Kerry Gaskell and Winfried Neun \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
e--mail: neun@sc.zib-berlin.de \\[0.10in]
Stanley L. Kameny \\
Los Angeles, U.S.A.
\end{center}
}

\ttindex{DEFINT}

\REDUCE{}'s definite integration package is able to calculate the
definite integrals of many functions, including several special
functions.  There are a number of parts of this package, including
contour integration.  The innovative integration process is to
represent each function as a Meijer G-function, and then calculating
the integral by using the following Meijer G integration formula.

\begin{displaymath}
\int_{0}^{\infty} x^{\alpha-1} G^{s t}_{u v}
\left( \sigma x \  \Bigg\vert \  {( c_u) \atop (d_v)} \right)
G^{m n}_{p q} \left( \omega x^{l/k} \  \Bigg\vert \ {(a_p) \atop (b_q)}
\right) dx = k G^{i j}_{k l} \left( \xi \ \Bigg\vert \
{(g_k) \atop (h_l)} \right)  \hspace{5mm} (1)
\end{displaymath}

The resulting Meijer G-function is then retransformed, either directly
or via a hypergeometric function simplification, to give
the answer.

The user interface is via a four argument version of the
\f{INT}\ttindex{INT} operator, with the lower and upper limits added.

\begin{verbatim}
load_package defint;

int(sin x,x,0,pi/2);

        1
\end{verbatim}
\newpage
\begin{verbatim}
int(log(x),x,1,5);

        5*log(5) - 4

int(x*e^(-1/2x),x,0,infinity);

        4

int(x^2*cos(x)*e^(-2*x),x,0,infinity);

          4
        -----
         125

int(x^(-1)*besselj(2,sqrt(x)),x,0,infinity);

        1

int(si(x),x,0,y);

        cos(y) + si(y)*y - 1

int(besselj(2,x^(1/4)),x,0,y);

                      1/4
         4*besselj(3,y   )*y
         ---------------------
                 1/4
                y
\end{verbatim}

The DEFINT package also defines a number of additional transforms,
such as the Laplace transform\index{Laplace transform}\footnote{See
Chapter~\ref{LAPLACE} for an alternative Laplace transform with
inverse Laplace transform}, the Hankel
transform\index{Hankel transform}, the Y-transform\index{Y-transform},
the K-transform\index{K-transform}, the StruveH
transform\index{StruveH transform}, the Fourier sine
transform\index{Fourier sine transform}, and the Fourier cosine
transform\index{Fourier cosine transform}.

\begin{verbatim}
laplace_transform(cosh(a*x),x);

   - s
---------
  2    2
 a  - s

laplace_transform(Heaviside(x-1),x);

  1
------
  s
 e *s

hankel_transform(x,x);

         n + 4
  gamma(-------)
           2
-------------------
        n - 2    2
 gamma(-------)*s
          2

fourier_sin(e^(-x),x);

   s
--------
  2
 s  + 1

fourier_cos(x,e^(-1/2*x^2),x);

                                  2
                    i*s          s /2
 sqrt( - pi)*erf(---------)*s + e    *sqrt(2)
                  sqrt(2)
----------------------------------------------
                  2
                 s /2
                e    *sqrt(2)

\end{verbatim}

It is possible to the user to extend the pattern-matching process by
which the relevant Meijer G representation for any function is found.
Details can be found in the complete documentation.

\noindent{\bf Acknowledgement:}
This package depends greatly on the pioneering work of Victor
Adamchik, to whom thanks are due.

mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/definti.red0000644000175000017500000001723111526203062024077 0ustar  giovannigiovannimodule definti;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% A rule set to test for the validity of the seven cases for the
% integration of a single Meijer G-function.
%
% 'The Special Functions and their Approximations', Volume 1,
%  Y.L.Luke. Chapter 5.6 pages 158 & 159

algebraic <<

operator test_cases,case_1,case_2,case_3,case_4,case_5,case_6,case_7;

test_cases_rules :=

{test_cases(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2) => 't

   when case_1(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_2(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_3(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_4(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_5(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_6(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
   or case_7(m,n,p,q,delta,xi,eta,test_1,test_1a,test_2) = 't
};

let test_cases_rules;

case_1_rules :=

{  case_1(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2) => 't
     when 1 <= n and n <= p and p < q
      and 1 <= m and m <= q
      and delta > 0 and eta neq 0
      and mylessp(abs(atan(impart eta/repart eta)),delta) = 't
      and test_1 = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1 and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and not (n = 0 and m = p + 1)
      and delta >0 and eta neq 0
      and mylessp(abs(atan(impart eta/repart eta)),delta) = 't
      and test_1 = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1 and 0 <= n and n <= p
      and 0 <= m and m <= q and q = p
      and delta > 0 and eta neq 0
      and mylessp(abs(atan(impart eta/repart eta)),delta) = 't
      and not (arg_test1(abs(atan(impart eta/repart eta)),delta) = 't)
      and test_1 = 't
      and transform_test2('tst1,nil) = 't

};

let case_1_rules;

case_2_rules :=

{  case_2(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2) => 't
     when n = 0 and 1 <= p + 1 and p + 1 <= m and m <= q
      and delta > 0
      and mylessp(abs(atan(impart eta/repart eta)),delta) = 't
      and test_1 = 't
      and transform_test2('tst1,nil) = 't
};

let case_2_rules;

case_3_rules :=

{  case_3(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2)  => 't
     when 0 <= n and n <= p and p < q
      and 1 <= m and m <= q
      and delta > 0
      and arg_test2(abs(atan(impart eta/repart eta)),delta) = 't
      and test_1 = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or 0 <= n and n <= p and p <= q - 2
      and delta = 0
      and arg_test3a(atan(impart eta/repart eta),0) = 't
      and test_1 = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't
};

let case_3_rules;

case_4_rules :=

{  case_4(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2)  => 't

     when 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 2
      and eta neq 0
      and delta <= 0
      and arg_test(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 2
      and eta neq 0
      and delta >= 1
      and arg_test3(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or test_1 = 't and test_2 = 't
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 2
      and eta neq 0
      and delta >= 0
      and arg_test3a(atan(impart eta/repart eta),delta) = 't
      and test_1 = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't
};

let case_4_rules;

case_5_rules :=

{  case_5(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2)  => 't
     when p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and arg_test4(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi >= 2
      and arg_test5(atan(impart eta/repart eta),delta,xi) = 't
      and test_1a = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi >= 2
      and arg_test6(atan(impart eta/repart eta),delta,xi) = 't
      and test_1a = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1
      and 1 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi >= 1
      and arg_test6a(atan(impart eta/repart eta),delta,xi) = 't
      and test_1 = 't
      and transform_test2('tst1,nil) = 't
};

let case_5_rules;

case_6_rules :=

{  case_6(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2)  => 't
     when p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi <= 1
      and arg_test(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi >= 2
      and arg_test7(atan(impart eta/repart eta),delta,xi) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi <= 1
      and arg_test8(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p + 1
      and eta neq 0
      and xi >= 2
      and arg_test8a(atan(impart eta/repart eta),delta,xi) = 't
      and test_1a = 't and test_2 = 't
      and transform_test2('tst1,'tst2) = 't
};

let case_6_rules;

case_7_rules :=

{  case_7(~m,~n,~p,~q,~delta,~xi,~eta,~test_1,~test_1a,~test_2)  => 't
     when p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p
      and eta neq 0
      and arg_test9(atan(impart eta/repart eta),delta) = 't
      and test_1a = 't
      and transform_test2('tst1,nil) = 't

     or p >= 1
      and 0 <= n and n <= p
      and 1 <= m and m <= q and q = p
      and eta neq 0
      and delta >= 1
      and arg_test9a(atan(impart eta/repart eta),delta) = 't
      and not (arg_test1(abs(atan(impart eta/repart eta)),delta) = 't)
      and test_1 = 't
      and transform_test2('tst1,nil) = 't
};

let case_7_rules;

>>;

endmodule;
end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintf.red0000644000175000017500000003334111526203062024074 0ustar  giovannigiovannimodule defintf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic <<

operator case20,case21,case22,case23,case24,case25,
         case26,case27,case28,case29,case30,case31,case32,case33,
         case34,case35;

case20_rules :=

{  case20(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when n = 0
        and m > 0
        and epsilon > 0
        and phi < 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_12 = 't
              and transform_test('test2,'test12,nil,nil,nil,nil,nil,nil) = 't
};

let case20_rules;

case21_rules :=

{  case21(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m = 0
        and n > 0
        and epsilon > 0
        and phi > 0
        and test_1a = 't and test_1b = 't and test_3 = 't
              and test_12 = 't
        and transform_test('test12,nil,nil,nil,nil,nil,nil,nil) = 't
};

let case21_rules;

case22_rules :=

{  case22(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when k*l = 0
        and delta > 0
        and epsilon > 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_10 = 't and test_12 = 't
        and transform_test('test2,'test3,'test10,'test12,nil,nil,nil,
        nil)= 't
};

let case22_rules;

case23_rules :=

{  case23(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m*n = 0
        and delta > 0
        and epsilon > 0
        and test_1a = 't and test_1b = 't and test_2 = 't
              and test_3 = 't and test_10 = 't and test_12 = 't
        and transform_test('test2,'test3,'test10,'test12,nil,nil,nil,
        nil) = 't
};

let case23_rules;

case24_rules :=

{  case24(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m + n > p
        and l = 0
        and phi = 0
        and k > 0
        and delta > 0
        and epsilon < 0
        and mylessp(abs(atan(impart omega/repart omega)),m + n - p + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_10 = 't and test_14 = 't and test_15 ='t
        and transform_test('test2,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case24_rules;

case25_rules :=

{  case25(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m + n > q
        and k = 0
        and phi = 0
        and l > 0
        and delta > 0
        and epsilon < 0
        and mylessp(abs(atan(impart omega/repart omega)),m + n - q + 1)
        and test_1a = 't and test_1b = 't and test_3 = 't
        and test_10 = 't and test_14 = 't and test_15 ='t
        and transform_test('test3,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case25_rules;

case26_rules :=

{  case26(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q - 1
        and l = 0
        and phi = 0
        and k > 0
        and delta > 0
        and epsilon >= 0
        and test_arg(abs(atan(impart omega/repart omega)),
                                                epsilon,epsilon + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_10 = 't and test_14 = 't and test_15 = 't
        and transform_test('test2,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case26_rules;

case27_rules :=

{  case27(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p = q + 1
        and k = 0
        and phi = 0
        and l > 0
        and delta > 0
        and epsilon >= 0
        and test_arg(abs(atan(impart omega/repart omega)),
                                                epsilon,epsilon + 1)
        and test_1a = 't and test_1b = 't and test_3 = 't
        and test_10 = 't and test_14 = 't and test_15 = 't
        and transform_test('test3,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case27_rules;

case28_rules :=

{  case28(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p < q - 1
        and l = 0
        and phi = 0
        and k > 0
        and delta > 0
        and epsilon >= 0
        and test_arg(abs(atan(impart omega/repart omega)),
                                                epsilon,m + n - p + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_10 = 't and test_14 = 't and test_15 = 't
        and transform_test('test2,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't

};

let case28_rules;

case29_rules :=

{  case29(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when p > q + 1
        and k = 0
        and phi = 0
        and l > 0
        and delta > 0
        and epsilon >= 0
        and test_arg(abs(atan(impart omega/repart omega)),
                                                epsilon,m + n - q + 1)
        and test_1a = 't and test_1b = 't and test_3 = 't
        and test_10 = 't and test_14 = 't and test_15 = 't
        and transform_test('test3,'test10,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case29_rules;

case30_rules :=

{  case30(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when n = 0
        and phi = 0
        and k + l > u
        and m > 0
        and epsilon > 0
        and delta < 0
        and mylessp(abs(atan(impart sigma/repart sigma)),k + l - u + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_12 = 't and test_14 = 't and test_15 = 't
        and transform_test('test2,'test12,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case30_rules;

case31_rules :=

{  case31(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m = 0
        and phi = 0
        and k + l > v
        and n > 0
        and epsilon > 0
        and delta < 0
        and mylessp(abs(atan(impart sigma/repart sigma)),k + l - v + 1)
        and test_1a = 't and test_1b = 't and test_3 = 't
        and test_12 = 't and test_14 = 't and test_15 = 't
        and transform_test('test3,'test12,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case31_rules;

case32_rules :=

{  case32(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when n = 0
        and phi = 0
        and u = v - 1
        and m > 0
        and epsilon > 0
        and delta >= 0
        and test_arg(abs(atan(impart sigma/repart sigma)),
                                                delta,delta + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_12 = 't and test_14 = 't and test_15 = 't
        and transform_test('test2,'test12,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case32_rules;

case33_rules :=

{  case33(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when m = 0
        and phi = 0
        and u = v + 1
        and n > 0
        and epsilon > 0
        and delta >= 0
        and test_arg(abs(atan(impart sigma/repart sigma)),
                                                delta,delta + 1)
        and test_1a = 't and test_1b = 't and test_3 = 't
        and test_12 = 't and test_14 = 't and test_15 = 't
        and transform_test('test3,'test12,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case33_rules;

case34_rules :=

{  case34(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => 't

     when n = 0
        and phi = 0
        and u < v - 1
        and m > 0
        and epsilon > 0
        and delta >= 0
        and test_arg(abs(atan(impart sigma/repart sigma)),
                                                delta,k + l - u + 1)
        and test_1a = 't and test_1b = 't and test_2 = 't
        and test_12 = 't and test_14 = 't and test_15 = 't
        and transform_test('test2,'test12,'test14,'test15,nil,nil,nil,
        nil) = 't
};

let case34_rules;

case35_rules :=

{  case35(~m,~n,~p,~q,~k,~l,~u,~v,~delta,~epsilon,~sigma,~omega,~rho,
        ~eta,~mu,~r1,~r2,~phi,~test_1a,~test_1b,~test_2,~test_3,
        ~test_4,~test_5,~test_6,~test_7,~test_8,~test_9,~test_10,
        ~test_11,~test_12,~test_13,~test_14,~test_15) => t

     when m = 0
        and phi = 0
        and u > v + 1
        and n > 0
        and epsilon > 0
        and delta >= 0
        and test_arg(abs(atan(impart sigma/repart sigma)),
                                                delta,k + l - v + 1)
        and test_1a = t and test_1b = t and test_3 = t
        and test_12 = t and test_14 = t and test_15 = t
        and transform_test('test3,'test12,'test14,'test15,nil,nil,nil,
        nil) = t
};

let case35_rules;


flag('(test_arg),'boolean);

algebraic procedure test_arg(a,b,c);

begin scalar !*rounded,dmode!*;
if transform_tst neq t then
<< on rounded;
   if b*pi < a and a < c*pi then << off rounded; return t>>
   else << off rounded; return nil>>;
>>
else return t;
end;

>>;

symbolic procedure transform_test(n1,n2,n3,n4,n5,n6,n7,n8);

begin scalar lst,temp,cond_test;

if transform_tst neq t then return t
else
<< lst := {n1,n2,n3,n4,n5,n6,n7,n8};
   for each i in lst do
    if i then  temp := lispeval cdr assoc(i,transform_lst) . temp; ;

   temp := 'and . temp;
   for each j in spec_cond do if j = temp then cond_test := t;
   if cond_test neq t then spec_cond := temp . spec_cond;
   return nil;
>>;
end;

symbolic operator transform_test;

flag('(sigma_tst),'boolean);

algebraic procedure sigma_tst(sigma);

begin scalar test;
if transform_tst neq t then
        << if sigma > 0 then return t else return nil>>
else
<< if test neq t then
   << symbolic(transform_lst := cons (('sigma_cond .'(list 'greaterp
                'sigma 0)),transform_lst));
      test := t>>;
   return reval t>>;
end;

flag('(omega_tst),'boolean);

symbolic procedure omega_tst(omega);

begin scalar test;

if transform_tst neq t then
<< if omega > 0 then return t else return nil>>
else
<< if test neq t then
   << symbolic(transform_lst := cons (('omega_cond .'(list 'greaterp
                'omega 0)),transform_lst));
      test := t>>;
   return reval t>>;
end;

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/definth.red0000644000175000017500000002031511526203062024073 0ustar  giovannigiovannimodule definth;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modification by WN after the call to GFMSQ, resubsitute.

fluid '(mellin!-transforms!* mellin!-coefficients!*);

symbolic smacro procedure listsq(u);
 % u - list of PF.
 % value is list of SQ.
 for each uu in u collect simp!* uu;

algebraic <<

operator indefint2;

indefint2_rules :=

{ indefint2((~f1+~~f2)/~~f3,~x,~y) =>
              indefint2(f1/f3,x,y)+indefint2(f2/f3,x,y) when not(f2=0),

  indefint2(~n,~f1-~f2,~x,~y) =>
                                   indefint2(n,f1,x,y)-indefint2(n,f2,x,y),
  indefint2(~n,~f1+~f2,~x,~y) =>
                                   indefint2(n,f1,x,y)+indefint2(n,f2,x,y),

  indefint2(1/~x^(~~a),~f,~x,~y) => transf(defint_choose(f,x),-a,y,x),
  indefint2(~x^(~~b)*sqrt(~x),~f,~x,~y) =>
                 transf(defint_choose(f,x),b+1/2,y,x),
  indefint2(sqrt(~x),~f,~x,~y) =>
                         transf(defint_choose(f,x),1/2,y,x),
  indefint2(~x^(~~a),~f,~x,~y) => transf(defint_choose(f,x),a,y,x),

  indefint2(~b*~ff,~f,~x,~y) => b*indefint2(ff,f,x,y) when freeof (b,x),
  indefint2(~b/(~~c*~ff),~f,~x,~y) => b/c*indefint2(1/ff,f,x,y)
                when freeof (b,x) and freeof (c,x) and not(b=1 and c=1),
  indefint2(~ff/~b,~f,~x,~y) =>
     1/b*indefint2(ff,f,x,y) when freeof (b,x),

  indefint2(~b*~ff,~f,~x,~y) => b*indefint2(ff,f,x,y) when freeof (b,x),
  indefint2(~ff/~b,~f,~x,~y) =>
     1/b*indefint2(ff,f,x,y) when freeof (b,x),

  indefint2(~~b,~f,~x,~y) => b*indefint2(f,x,y)
                         when freeof (b,x) and not(b=1),
  indefint2(~f,~x,~y) => transf(defint_choose(f,x),0,y,x)
};

let indefint2_rules;

symbolic procedure simpinteg(u);

begin scalar ff1,alpha,y,var,chosen_num,coef,!*uncached;

!*uncached := t;
ff1 := prepsq simp car u;

if ff1 = 'UNKNOWN then return simp 'UNKNOWN;
alpha := cadr u;
y := caddr u;

if smember('minus,y) then return simp 'UNKNOWN;
                       % until a fix is available
var := cadddr u;
chosen_num := cadr ff1;

if chosen_num = 0 then << coef := caddr ff1;
                          return simp reval
                                algebraic(coef*y**(alpha+1)/(alpha+1))>>
else
<< put('f1,'g,getv(mellin!-transforms!*,chosen_num));
   coef := getv(mellin!-coefficients!*,chosen_num);
   if coef then MELLINCOEF:= coef else MELLINCOEF :=1;

   return  simp list('new_mei,'f1 . cddr ff1,alpha,y,var)>>;
end$

put('new_mei,'simpfn,'new_meijer)$

symbolic procedure new_meijer(u);

begin scalar f,y,mellin,new_mellin,m,n,p,q,old_num,old_denom,temp,a1,
b1,a2,b2,alpha,num,denom,n1,temp1,temp2,coeff,v,var,new_var,new_y,
new_v,k;

f := prepsq simp car u;
y := caddr u;

mellin := bastab(car f,cddr f);

temp := car cddddr mellin;
var := cadr f;

if not idp VAR then RETURN error(99,'FAIL); % something is rotten, if not...
                                   % better give up

temp := reval algebraic(sub(x=var,temp));

mellin := {car mellin,cadr mellin,caddr mellin,cadddr mellin,temp};

temp := reduce_var(cadr u,mellin,var);

alpha := simp!* car temp;
new_mellin := cdr temp;

if car cddddr new_mellin neq car cddddr mellin then
        << k := car cddddr mellin;
           y := reval algebraic(sub(var=y,k));
           new_y := simp y>>
else
<< new_var := car cddddr new_mellin;
   new_y := simp reval algebraic(sub(x=y,new_var))>>;

n1 := addsq(alpha,'(1 . 1));

temp1 := {'expt,y,prepsq n1};
temp2  := cadddr new_mellin;

coeff := simp!* reval algebraic(temp1*temp2);

m := caar new_mellin;
n := cadar new_mellin;
p := caddar new_mellin;
q := car cdddar new_mellin;

old_num := cadr new_mellin;
old_denom := caddr new_mellin;


for i:=1 :n do
<< if old_num = nil then a1 := append(a1,{simp!* old_num })
   else <<  a1 := append(a1,{simp!* car old_num});
            old_num := cdr old_num>>;
>>;

for j:=1 :m do

<< if old_denom = nil then b1 := append(b1,{simp!*  old_denom })
   else <<  b1 := append(b1,{simp!* car old_denom});
            old_denom := cdr old_denom>>;
>>;

a2 := listsq old_num;
b2 := listsq old_denom;

if a1 = nil and a2 = nil then
    num := list({negsq alpha})
else if a2 = nil then num := list(append(a1,{negsq alpha}))
else
<< num := append(a1,{negsq alpha}); num := append({num},a2)>>;

if b1 = nil and b2 = nil then
    denom := list({subtrsq(negsq alpha,'(1 . 1))})
else if b2 = nil then
    denom := list(b1,subtrsq(negsq alpha,'(1 . 1)))
else
<< denom := list(b1,subtrsq(negsq alpha,'(1 . 1)));
   denom := append(denom,b2)>>;

v := gfmsq(num,denom,new_y);

if v = 'fail then return simp 'fail
else v := prepsq subsq(v,list(prepsq new_y . y));  % WN

if eqcar(v,'meijerg) then new_v := v else new_v := simp v;
return multsq(new_v,coeff);
end$


symbolic procedure reduce_var(u,v,var1);

% Reduce Meijer G functions of powers of x to x

begin scalar var,m,n,coef,alpha,beta,alpha1,alpha2,expt_flag,k,temp1,
            temp2,const,new_k;

var := car cddddr(v);
beta := 1;

% If the Meijer G-function is is a function of a variable which is not
% raised to a power then return initial function

if length var = 0 then return u . v
else
<< k := u; coef := cadddr v;
   for each i in var do
   << if listp i then
      << if car i = 'expt then
         << alpha := caddr i; expt_flag := 't>>

         else if car i = 'sqrt then
         << beta := 2; alpha := 1; expt_flag := 't>>

         else if car i = 'times then
         << temp1 := cadr i; temp2 := caddr i;

            if listp temp1 then
            << if  car temp1 = 'sqrt then
               << beta := 2; alpha1 := 1; expt_flag := 't>>

               else if car temp1 = 'expt and listp caddr temp1 then
                  << beta := cadr cdaddr temp1;
                     alpha1 := car cdaddr temp1;
                     expt_flag := 't>>;
            >>;

            if listp temp2 and car temp2 = 'expt then
            << alpha2 := caddr temp2; expt_flag := 't>>;

            if alpha1 neq 'nil then

     alpha := reval algebraic(alpha1 + beta*alpha2)
            else alpha := alpha2;
         >>;
      >>
      else
      << if i = 'expt then << alpha := caddr var; expt_flag := 't>>;
      >>;
   >>;

% If the Meijer G-function is is a function of a variable which is not
% raised to a power then return initial function

   if expt_flag = nil then return u . v

% Otherwise reduce the power by using the following formula :-
%
%   y                            (c*y)^(m/n)
%  /                                 /
%  |                           n     |
%  |t^k*F((c*t)^(m/n))dt = --------- |z^[((k + 1)*n - m)/m]*F(z)dz
%  |                       m*c^(k+1) |
%  /                                 /
% 0                                 0

   else

   << if listp alpha then << m := cadr alpha; n := caddr alpha;
                             n := reval algebraic(beta*n)>>

      else << m := alpha; n := beta>>;

      const := reval algebraic(sub(var1=1,var));
      const := reval algebraic(1/(const^(n/m)));

      new_k := reval algebraic(((k + 1)*n - m)/m);
      coef := reval algebraic((n/m)*coef*(const)^(k+1));

      var := reval algebraic(var^(n/m));
      return {new_k,car v,cadr v, caddr v,coef,var}>>;
>>;
end$

>>;

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintc.red0000644000175000017500000002005711526203062024071 0ustar  giovannigiovannimodule defintc;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(mellin!-transforms!* mellin!-coefficients!*);

symbolic (mellin!-transforms!* :=mkvect(200))$

symbolic putv(mellin!-transforms!*,0,'(1 . 1)); % undefined case
symbolic putv(mellin!-transforms!*,1,'(() (1 0 0 1) () (nil) 1 x));

     % trigonometric functions

symbolic putv(mellin!-transforms!*,2,'
    (() (1 0 0 2) () ((quotient 1 2) nil)
    (sqrt pi) (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,25,'
    (() (1 0 0 2) () ((quotient 1 2) nil)
    (minus (sqrt pi)) (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,3,'
    (() (1 0 0 2) () (nil (quotient 1 2))
   (sqrt pi) (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,7,'
    (() (2 0 2 2) (1 1) (nil (quotient 1 2))
    (quotient (sqrt pi) 2) (expt x 2)));

symbolic putv(mellin!-transforms!*,8,'
    (() (0 2 2 2) ((quotient 1 2) 1) (nil nil)
    (quotient (sqrt pi) 2) (expt x 2)));

symbolic putv(mellin!-transforms!*,9,'
    (() (1 2 2 2) ((quotient 1 2) 1) ((quotient 1 2) nil)
    (quotient 1 2) (expt x 2)));

     % hyperbolic functions

symbolic putv(mellin!-transforms!*,10,'
    (() (1 0 1 3) (1) ((quotient 1 2) 1 nil)
    (expt pi (quotient 3 2)) (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,11,'
    (() (1 0 1 3) ((quotient 1 2)) (nil (quotient 1 2) (quotient 1 2))
    (expt pi (quotient 3 2)) (quotient (expt x 2) 4)));


     % the Heavisides

symbolic putv(mellin!-transforms!*,30,'(() (1 0 1 1) (1) (nil) 1 x));

symbolic putv(mellin!-transforms!*,31,'(() (0 1 1 1) (1) (nil) 1 x));

symbolic putv(mellin!-transforms!*,32,'
    (() (2 0 2 2) (1 1) (nil nil) -1 x));

symbolic putv(mellin!-transforms!*,33,'
    (() (0 2 2 2) (1 1) (nil nil) 1 x));

symbolic putv(mellin!-transforms!*,34,'
    (() (1 2 2 2) (1 1) (1 nil) 1 x));

symbolic putv(mellin!-transforms!*,35,'
    (() (2 1 2 2) (nil 1) (nil nil) 1 x));


     % exponential integral

symbolic putv(mellin!-transforms!*,36,'
    (() (2 0 1 2) (1) (nil nil) -1 x));

     % sin integral

symbolic putv(mellin!-transforms!*,37,'
    (() (1 1 1 3) (1) ((quotient 1 2) nil nil)
    (quotient (sqrt pi) 2) (quotient (expt x 2) 4)));

     % cos integral

symbolic putv(mellin!-transforms!*,38,'
    (() (2 0 1 3) (1) (nil nil (quotient 1 2))
    (quotient (sqrt pi) -2) (quotient (expt x 2) 4)));

     % sinh integral

symbolic putv(mellin!-transforms!*,39,'
    (() (1 1 2 4) (1 nil) ((quotient 1 2) nil nil nil)
    (quotient (expt pi (quotient 3 2)) -2) (quotient (expt x 2) 4)));


     % error functions

symbolic putv(mellin!-transforms!*,41,'
    (() (1 1 1 2) (1) ((quotient 1 2) nil)
    (quotient 1 (sqrt pi)) (expt x 2)));

symbolic putv(mellin!-transforms!*,42,'
    (() (2 0 1 2) (1) (nil (quotient 1 2))
    (quotient 1 (sqrt pi)) (expt x 2)));

    % Fresnel integrals

symbolic putv(mellin!-transforms!*,43,'
    (() (1 1 1 3) (1) ((quotient 3 4) nil (quotient 1 4))
    (quotient 1 2) (quotient (expt x 2) 4)));


symbolic putv(mellin!-transforms!*,44,'
    (() (1 1 1 3) (1) ((quotient 1 4) nil (quotient 3 4))
    (quotient 1 2) (quotient (expt x 2) 4)));

    % gamma function

symbolic putv(mellin!-transforms!*,45,'
    ((n) (1 1 1 2) (1) (n nil) 1 x));

    % Bessel functions

symbolic putv(mellin!-transforms!*,50,'
    ((n) (1 0 0 2) () ((quotient n 2) (minus (quotient n 2)))
    1 (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,51,'
    ((n) (2 0 1 3) ((quotient (minus (plus n 1)) 2))
((quotient n 2) (minus (quotient n 2)) (quotient (minus (plus n 1)) 2))
    1 (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,52,'
    ((n) (1 0 1 3) ((plus (quotient 1 2) (quotient n 2)))
    ((quotient n 2) (minus (quotient n 2))
    (plus (quotient 1 2) (quotient n 2)))
    pi (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,53,'
    ((n) (2 0 0 2) () ((quotient n 2) (minus (quotient n 2)))
    (quotient 1 2) (quotient (expt x 2) 4)));

    % struve functions

symbolic putv(mellin!-transforms!*,54,'
    ((n) (1 1 1 3) ((quotient (plus n 1) 2))
    ((quotient (plus n 1) 2) (minus (quotient n 2)) (quotient n 2))
    1 (quotient (expt x 2) 4)));

symbolic putv(mellin!-transforms!*,55,'
    ((n) (1 1 2 4) ((quotient (plus n 1) 2) nil)
    ((quotient (plus n 1) 2) nil (quotient n 2) (minus (quotient n 2)))
    (times (minus pi) (sec (times (quotient (minus n) 2) pi)))
    (quotient (expt x 2) 4)));

    % legendre polynomials

symbolic putv(mellin!-transforms!*,56,'
    ((n) (2 0 2 2) ((minus n) (plus n 1)) (nil nil)
    1 (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,57,'
    ((n) (0 2 2 2) (1 1) ((minus n) (plus n 1))
    1 (quotient (plus x 1) 2)));

    % chebyshev polymomials

symbolic putv(mellin!-transforms!*,58,'
    ((n) (2 0 2 2)
    ((difference (quotient 1 2) n) (plus (quotient 1 2) n))
    (nil (quotient 1 2)) (sqrt pi) (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,59,'
    ((n) (0 2 2 2) (nil (quotient 1 2)) (n (minus n))
    (sqrt pi) (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,60,'
    ((n) (2 0 2 2)
    ((plus (quotient 3 2) n) (difference (minus (quotient 1 2)) n))
    (nil (quotient 1 2)) (quotient (plus n 1) (times 2 (sqrt pi)))
    (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,61,'
    ((n) (0 2 2 2) ((quotient 3 2) 2) ((minus n) (plus n 2))
    (quotient (plus n 1) (times 2 (sqrt pi)))
    (quotient (plus x 1) 2)));

    % hermite polynomials

symbolic putv(mellin!-transforms!*,62,'
    ((n) (1 0 1 2) (plus (quotient n 2) 1)
    ((difference (quotient n 2) (quotient n 2))
    (difference (quotient 1 2) (difference (quotient n 2)
    (quotient n 2))))
    (times (expt (minus 1) (quotient n 2)) (sqrt pi) (factorial n))
    (expt x 2)));

    % laguerre polynomials

symbolic putv(mellin!-transforms!*,63,'
    ((n l) (1 0 1 2) ((plus n 1)) (0 (minus l))
    (gamma (plus l n 1)) x));

    % gegenbauer polynomials

symbolic putv(mellin!-transforms!*,64,'
    ((n l) (2 0 2 2) ((plus l n (quotient 1 2))
    (difference (quotient 1 2) (quotient 1 n)))
    (0 (difference (quotient 1 2) l))
   (quotient (times 2 l (gamma (plus l (quotient 1 2)))) (factorial n))
    (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,65,'
    ((n l) (0 2 2 2) ((plus l (quotient 1 2)) (times 2 l))
    ((minus n) (plus (times 2 l) n))
   (quotient (times 2 l (gamma (plus l (quotient 1 2)))) (factorial n))
    (quotient (plus x 1) 2)));

    % jacobi polynomials

symbolic putv(mellin!-transforms!*,66,'
    ((n r s) (2 0 2 2) ((plus r n 1) (difference (minus s) n))
    (0 (minus s)) (quotient (gamma (plus r n 1)) (factorial n))
    (quotient (plus x 1) 2)));

symbolic putv(mellin!-transforms!*,67,'
    ((n r s) (0 2 2 2) ((plus r 1) (plus r s 1))
    ((minus n) (plus r s n 1))
    (quotient (gamma (plus r n 1)) (factorial n))
    (quotient (plus x 1) 2)));

symbolic (mellin!-coefficients!* :=mkvect(200))$

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/definta.red0000644000175000017500000012777511526203062024106 0ustar  giovannigiovanni%***********************************************************************
%*                             INTEGRATION                             *
%***********************************************************************

module definta$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


transform_lst := '();

algebraic operator f1$
algebraic operator f2$

fluid '(MELLINCOEF);

fluid '(plotsynerr!*);

%***********************************************************************
%*                          MAIN PROCEDURES                            *
%***********************************************************************

symbolic smacro procedure gw u;
  caar u$

symbolic smacro procedure gl u;
  caadar u$

symbolic smacro procedure gk u;
  cdadar u$

symbolic smacro procedure gr u;
  cadar u$

symbolic smacro procedure gm u;
  caadr u$

symbolic smacro procedure gn u;
  cadadr u$

symbolic smacro procedure gp u;
  caddr cadr u$

symbolic smacro procedure gq u;
  cadddr cadr u$

symbolic smacro procedure ga u;
  caddr u$

symbolic smacro procedure gb u;
  cadddr u$

symbolic procedure rdwrap f;
if numberp f then float f
  else if f='pi then 3.141592653589793238462643
  else if f='e then 2.7182818284590452353602987
  else if atom f then f
  else if eqcar(f, '!:RD!:) then
          if atom cdr f then cdr f else bf2flr f
  else if eqcar(f, '!:DN!:) then rdwrap2 cdr f
  else if eqcar(f, 'MINUS) then
    begin scalar x;
       x := rdwrap cadr f;
       return if numberp x then minus float x else {'MINUS, x}
    end
  else if get(car f, 'DNAME) then
    << plotsynerr!*:=t;
       rerror(PLOTPACKAGE, 32, {get(car f, 'DNAME),
                                "illegal domain for PLOT"})
    >>
  else if eqcar(f,'expt) then rdwrap!-expt f
  else rdwrap car f . rdwrap cdr f;

symbolic procedure rdwrap!-expt f;
% preserve integer second argument.
  if fixp caddr f then {'expt!-int,rdwrap cadr f,caddr f}
    else {'expt,rdwrap cadr f, rdwrap caddr f};

symbolic procedure rdwrap2 f;
% Convert from domain to LISP evaluable value.
  if atom f then f else float car f * 10^cdr f;

symbolic procedure rdwrap!* f;
% convert a domain element to float.
  if null f then 0.0 else rdwrap f;

symbolic procedure rdunwrap f;
  if f=0.0 then 0 else if f=1.0 then 1 else '!:rd!: . f;

symbolic procedure expt!-int(a,b); expt(a,fix b);

put('intgg,'simpfn,'simpintgg)$

symbolic procedure simpintgg(u);
<>;

symbolic procedure intggg(u1,u2,u3,u4);
begin scalar v,v1,v2,s1,s2,s3,coef,uu1,uu2,test_1,test_1a,test_2,m,n,p,
        q,delta,xi,eta,test,temp,temp1,temp2,var,var1,var2;


 off allfac;
 uu1:= cadr u1; uu1:= prepsq cadr(algebraic uu1);
 uu2:= cadr u2; uu2:= prepsq cadr(algebraic uu2);
 u1:=if null cddr u1 then list('f1, uu1) else 'f1 . uu1 . cddr u1;
 u2:=if null cddr u2 then list('f2, uu2) else 'f2 . uu2 . cddr u2;


% Cases for the integration of a single Meijer G-function
 if equal(get('F1,'G),'(1 . 1)) and
                 equal(get('F2,'G),'(1 . 1)) then

         return simp 'UNKNOWN

 else if equal(get('F1,'G),'(1 . 1)) then

% Obtain the appropriate Meijer G-function

    <>

 else if equal(get('F2,'G),'(1 . 1)) then

% Obtain the appropriate Meijer G-function

    <>;

% Case for the integration of a product of two Meijer G-functions

% Obtain the correct Meijer G-functions

  s1:=bastab(car u1,cddr u1);

  s2:=bastab(car u2,cddr u2);

  coef:=multsq(simp!* cadddr s1,simp!* cadddr s2);

  v1:= trpar(car cddddr s1, cadr u1, u4);
  if v1='FAIL then
  << on allfac;
     return simp 'FAIL >>;


  v2:= trpar(car cddddr s2, cadr u2, u4);
  if v2='FAIL then
  << on allfac;
     return simp 'FAIL >>;

  on allfac;

% Substitute in the correct variable value

  temp1 := car cddddr s1;
  var1 := cadr u1;
  temp1 := reval algebraic(sub(x=var1,temp1));

  s1 := {car s1,cadr s1,caddr s1,cadddr s1,temp1};

  temp2 := car cddddr s2;
  var2 := cadr u2;
  temp2 := reval algebraic(sub(x=var2,temp2));

  s2 := {car s2,cadr s2,caddr s2,cadddr s2,temp2};

  s1:=list(v1,car s1,listsq cadr s1,
         listsq caddr s1,simp!*(subpref(cadr u1,1,u4)));


  s2:=list(v2,car s2,listsq cadr s2,
         listsq caddr s2,simp!*(subpref(cadr u2,1,u4)));
  s3:=addsq(simp!* u3,'(1 . 1));

  if not numberp(gl s1) or not numberp(gl s2) then
        RETURN simp 'FAIL
  else
  if gl s1<0 then s1:=cong s1 else
  if gl s2<0 then s2:=cong s2 else


  if gl s1=gk s1 then GOTO A  else      % No reduction is necessary if
                                                                     % it is not a meijer G-function
                                                                     % of a power of x
  if gl s2=gk s2 then
                  <>;
                                                                 % No reduction necessary but
                                        % the Meijer G-functions must
                                        % be inverted
  coef:=multsq(coef,invsq gr s1);
                                                          %premultiply by inverse of power
  v:=modintgg(s3,s1,s2);
  s3:=car v;    s1:=cadr v;   s2:=caddr v;
  A:

% Test for validity of the integral


  test := validity_check(s1,s2,u3);

  if test neq 't then
      return simp 'UNKNOWN;

  coef := multsq(if numberp(mellincoef) then simp(mellincoef)
                                     else cadr mellincoef,
              multsq(coef,coefintg(s1,s2,s3)));

  v := deltagg(s1,s2,s3);
  v := redpargf(list(arggf(s1,s2),indgf(s1,s2),car v,cadr v));
  v := ('meijerg . mgretro (cadr v,caddr v,car v));
  v := aeval v;

  if eqcar(v,'!*sq) then
      v := cadr v
  else if fixp v then
      v := simp v;

  if v='FAIL then
      return simp 'FAIL
  else
      return multsq(coef,v);

end$



symbolic procedure mgretro (u,v,w);

  begin scalar caru,carv,cdru,cdrv;

  caru := car u; cdru := cdr u; carv := car v; cdrv := cdr v;

  return
  list('list . cons ('list . foreach aa in caru collect prepsq aa,
              foreach aa in cdru collect prepsq aa),
       'list . cons ('list . foreach aa in carv collect prepsq aa,
              foreach aa in cdrv collect prepsq aa),
       prepsq w);
end;

symbolic procedure intg(u1,u2,u3);
 begin scalar v;
   if numberp(gl(u1)) and gl(u1) < 0 then u1:=cong u1;
   v:=modintg(u2,u1);
   u1:=cadr v;
   v:=
     multlist(
       list(u3,
            expdeg(gw u1,negsq u2),
            quotsq(
               multgamma(
                 append(
                   listplus(car redpar1(gb u1,gm u1),u2),
                   listplus(
                     listmin(car redpar1(ga u1,gn u1)),
                     diff1sq('(1 . 1),u2)))),
               multgamma(
                 append(
                   listplus(cdr redpar1(ga u1,gn u1),u2),
                   listplus(
                     listmin(cdr redpar1(gb u1,gm u1)),
                     diff1sq('(1 . 1),u2)))))));
   return multsq(if numberp(mellincoef) then simp(mellincoef)
                                     else cadr mellincoef,
                 v);
end$

%***********************************************************************
%*              EVALUATION OF THE PARAMETERS FOR THE G-FUNCTION        *
%***********************************************************************

symbolic procedure simp_expt(u,v);

% Reduce Meijer G functions of powers of x to x

begin scalar var,m,n,coef,alpha,beta,alpha1,alpha2,expt_flag,k,temp1,
                  temp2;

var := car cddddr(v);

beta := 1;

% If the Meijer G-function is is a function of a variable which is not
% raised to a power then return initial function

if length var = 0 then
    return u . v

else

<< k := u;
   coef := cadddr v;

   for each i in var do

   << if listp i then
      << if car i = 'expt then
         << alpha := caddr i;
            expt_flag := 't>>

         else if car i = 'sqrt then
         << beta := 2;
            alpha := 1;
            expt_flag := 't>>

         else if car i = 'times then
         << temp1 := cadr i;
            temp2 := caddr i;

            if listp temp1 then
            << if  car temp1 = 'sqrt then
               << beta := 2;
                  alpha1 := 1;
                  expt_flag := 't>>

               else if car temp1 = 'expt and listp caddr temp1 then
                  << beta := cadr cdaddr temp1;
                     alpha1 := car cdaddr temp1;
                            expt_flag := 't>>;
            >>;

            if listp temp2 and car temp2 = 'expt then
            << alpha2 := caddr temp2;
               expt_flag := 't>>;

            if alpha1 neq 'nil then

     alpha := reval algebraic(alpha1 + beta*alpha2)
            else alpha := alpha2;
         >>;

      >>

      else
      << if i = 'expt then
         << alpha := caddr var;
            expt_flag := 't>>;
      >>;
   >>;

% If the Meijer G-function is is a function of a variable which is not
% raised to a power then return initial function

   if expt_flag = nil then
       return u . v

% Otherwise reduce the power by using the following formula :-
%
%   infinity                  infinity
%  /                         /
%  |                       n |
%  |t^alpha*F(t^(m/n))dt = - |z^[((alpha + 1)*n - m)/m]*F(z)dz
%  |                       m |
%  /                         /
% 0                         0

   else

   << if listp alpha then
      << m := cadr alpha;
         n := caddr alpha;
         n := reval algebraic(beta*n)>>

      else
      << m := alpha;
         n := beta>>;

      k := reval algebraic(((k + 1)*n - m)/m);
      coef := reval algebraic((n/m)*coef);
      var := reval algebraic(var^(n/m));

      return {k,car v,cadr v, caddr v,coef,var}>>;

>>;


end;

symbolic procedure test_1(aa,u,v);

% Check validity of the following formulae :=
%
% -min Re{bj} < Re{s} < 1 - max Re{ai}    i=1..n, j=1..m
% -min Re{bj} < Re{s} < 1 - max Re{ai}    i=1..n, j=1..p
%
% 'The Special Functions and their Approximations', Volume 1,
%  Y.L.Luke. Chapter 5.6 page 157 (3) & (3*)

begin scalar s,m,n,a,b,ai,bj,a_max,b_min,temp,temp1,
                !*rounded,dmode!*;

off rounded;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< s := algebraic(repart(1 + u));
   s := simp!* s;

   m := caar v;
   n := cadar v;

   a := cadr v;
   b := caddr v;

   if aa = nil then
   << for i := 1 :n do

      << if car a = 'nil then
              car a := 0;
          ai := append(ai,{car a});
         a := cdr a>>;


      if ai neq 'nil then
      << a_max := simpmax list('list . ai);
         a_max := simprepart list(list('!*sq,a_max,t))>>;

   >>

   else if aa = 'a then

   << if a neq 'nil then
      << a_max := simpmax list('list . a);
         a_max := simprepart list(list('!*sq,a_max,t))>>;
   >>;


   for j := 1 :m do

   << if car b = 'nil then
          car b := 0;
      bj := append(bj,{car b});
      b := cdr b>>;

   if bj neq 'nil then
   << b_min := simpmin list('list . bj);
      b_min := simprepart list(list('!*sq,negsq(b_min),t))>>;


   if a_max neq nil and b_min neq nil then

   << temp := subtrsq(s,diffsq(a_max,1));
      temp1 := subtrsq(b_min,s);

      if car temp = 'nil or car temp1 = 'nil
       or car temp > 0 or car temp1> 0 then
          return 'FAIL

      else
          return test2(s,cadr v,caddr v)>>

   else if a_max = nil then

   << temp := subtrsq(b_min,s);

      if car temp = 'nil or car temp > 0 then
          return 'FAIL

       else
          return 'T>>

   else if b_min = nil then

   << temp :=  subtrsq(s,diffsq(a_max,1));

      if car temp = 'nil or car temp > 0 then
          return 'FAIL

      else
          return 'T>>;

>>

else
<< transform_lst := cons (('tst1 . '(list 'lessp (list 'lessp
        (list 'minus
                (list 'min (list 'repart 'bj))) (list 'repart 's))
        (list 'difference 1
                (list 'max(list 'repart 'ai))))),transform_lst);

   return 't>>;

end;


symbolic procedure test2(s,a,b);

% Check validity of the following formula :=
%
% Re{Sum(ai) - Sum(bj)} + 1/2 * (q + 1 - p) > (q - p) * Re{s}
%                                                        i=1..p, j=1..q
% 'The Special Functions and their Approximations', Volume 1,
%  Y.L.Luke. Chapter 5.6 page 157 (4)

begin scalar s,p,q,sum_a,sum_b,diff_sum,temp1,temp2,temp,diff;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< s := algebraic(repart(1 + s));

   p := length a;
   q := length b;

   for each i in a do << sum_a := reval algebraic(sum_a + i)>>;

   for each j in b do << sum_b := reval algebraic(sum_b + j)>>;

   diff_sum := reval algebraic(repart(sum_a - sum_b));

   temp := reval algebraic(1/2*(q + 1 - p));
   temp1 := reval algebraic(diff_sum + temp);
   temp2 := reval algebraic((q-p)*s);
   diff := simp!* reval algebraic(temp1 - temp2);

   if car diff ='nil then return 'FAIL

   else if car diff < 0 then return 'FAIL else return T>>

else
<< transform_lst := cons (('tst2 . '(list 'greaterp (list 'plus
        (list 'repart (list 'difference (list 'sum 'ai)(list 'sum 'bj)))
        (list 'times (list 'quotient 1 2)
        (list 'plus 'q (list 'difference 1 'p)))) (list 'times
        (list 'difference 'q 'p) (list 'repart 's)))),
         transform_lst);

   return 't;

>>;

end;


symbolic procedure validity_check(s1,s2,u3);

% Check validity of the following formulae :=
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (1) - (15)


begin scalar alpha,m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,r,a,b,c,d,
               b_sum,a_sum,d_sum,c_sum,mu,rho,phi,eta,r1,r2,
         test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,test_7,
         test_8,test_9,test_10,test_11,test_12,test_13,test_14,test_15,
         test;

transform_lst := '();

alpha := reval algebraic(1 + u3);

m := caadr s1;
n := cadadr s1;
p := car cddadr s1;
q := cadr cddadr s1;

epsilon := reval algebraic(m + n - 1/2*(p + q));

k := caadr s2;
l := cadadr s2;
u := car cddadr s2;
v := cadr cddadr s2;

delta := reval algebraic(k + l -1/2*(u + v));

sigma := prepsq caar s1;
omega := prepsq caar s2;

r := prepsq cadar s2;

a := caddr s1;
b := cadddr s1;
c := caddr s2;
d := cadddr s2;

for each i in b do
        << i := prepsq i; b_sum := reval algebraic(b_sum + i)>>;

for each j in a do
        << j := prepsq j; a_sum := reval algebraic(a_sum + j)>>;

for each i in d do
        << i := prepsq i; d_sum := reval algebraic(d_sum + i)>>;

for each j in c do
        << j := prepsq j; c_sum := reval algebraic(c_sum + j)>>;

mu := reval algebraic(b_sum - a_sum + 1/2*(p - q) + 1);
rho := reval algebraic(d_sum - c_sum + 1/2(u - v) + 1);

phi := reval algebraic(q - p - r*(v - u));
eta := reval algebraic(1 - alpha*(v - u) - mu - rho);


if listp r then << r1 := symbolic(cadr r); r2 := symbolic(caddr r)>>
else            << r1 := r; r2 := 1>>;

test_1a := tst1a(m,n,a,b);
test_1b := tst1b(k,l,c,d);
test_2 := tst2(m,k,b,d,alpha,r);
test_3 := tst3(n,l,a,c,alpha,r);
test_4 := tst4(l,p,q,c,alpha,r,mu);
test_5 := tst5(k,p,q,d,alpha,r,mu);
test_6 := tst6(n,u,v,a,alpha,r,rho);
test_7 := tst7(m,u,v,b,alpha,r,rho);
test_8 := tst8(p,q,u,v,alpha,r,mu,rho,phi);
test_9 := tst9(p,q,u,v,alpha,r,mu,rho,phi);
test_10 := tst10(sigma,delta);
test_11 := tst11(sigma,delta);
test_12 := tst12(omega,epsilon);
test_13 := tst13(omega,epsilon);
test_14 := tst14(u,v,alpha,mu,rho,delta,epsilon,sigma,omega,r,phi,r1,
                               r2);
if p = q or u = v then test_15 := 'FAIL
        else test_15 := tst15(m,n,p,q,k,l,u,v,sigma,omega,eta);

test := {'test_cases2,m,n,p,q,k,l,u,v,delta,epsilon,sigma,omega,rho,
   eta,mu,r1,r2,phi,test_1a,test_1b,test_2,test_3,test_4,test_5,test_6,
   test_7,test_8,test_9,test_10,test_11,test_12,test_13,test_14,
   test_15};

test := reval test;

if transform_tst = t and spec_cond neq nil then test := t;
return test;
end;


symbolic procedure tst1a(m,n,a,b);

% Check validity of the following formula :=
%
%  ai - bj neq 1,2,3,....         i=1..n, j=1..m
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (1)

begin scalar a_new,b_new,temp,fail_test;

for i := 1 :n do << a_new := append(a_new,{car a}); a := cdr a>>;

for j := 1 :m do << b_new := append(b_new,{car b}); b := cdr b>>;

for each i in a_new do
<< for each j in b_new do
   << temp := subtrsq(i,j);
      if car temp neq 'nil and car temp > 0
          and cdr temp = 1 then
          fail_test := t>>;
>>;
if fail_test = t then return 'FAIL else return t;
end;

symbolic procedure tst1b(k,l,c,d);

% Check validity of the following formula :=
%
%  ci - dj neq 1,2,3,....         i=1..l, j=1..k
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (1)

begin scalar c_new,d_new,temp,fail_test;

for i := 1 :l do << c_new := append(c_new,{car c}); c := cdr c>>;

for j := 1 :k do << d_new := append(d_new,{car d}); d := cdr d>>;

for each i in c_new do
<< for each j in d_new do
   << temp := subtrsq(i,j);
      if car temp neq 'nil and car temp > 0
          and cdr temp = 1 then
          fail_test := t>>;
>>;
if fail_test = t then return 'FAIL else return t;
end;

symbolic procedure tst2(m,k,b,d,alpha,r);

% Check validity of the following formula :=
%
%  Re{alpha + r*bi + dj} > 0                 i=1..m, j=1..k
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (2)

begin scalar b_new,d_new,temp,temp1,temp2,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq t then

<< for i := 1 :m do
   << temp1 := prepsq car b;
      b_new := append(b_new,{temp1});
      b := cdr b>>;

   for j := 1 :k do
   << temp2  := prepsq car d;
      d_new := append(d_new,{temp2});
      d := cdr d>>;

   for each k in b_new do
   << for each h in d_new do
      << temp := simp!* reval algebraic(repart(alpha + r*k + h));
         if car temp = 'nil or car temp < 0 then
             fail_test := 't>>;
   >>;
   if fail_test = t then return 'FAIL else return t>>
else
<< transform_lst := cons (('test2 . '(list 'greaterp
  (list 'repart (list 'plus 'alpha (list 'times 'r 'bi) 'dj))
   0)),transform_lst);
   return t>>;
end;

symbolic procedure tst3(n,l,a,c,alpha,r);

% Check validity of the following formula :=
%
%  Re{alpha + r*ai + cj} < r + 1                  i=1..n, j=1..l
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (3)

begin scalar a_new,c_new,temp,temp1,temp2,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< for i := 1 :n do
   << temp1 := prepsq car a;
      a_new := append(a_new,{temp1});
      a := cdr a>>;

   for j := 1 :l do
   << temp2 := prepsq car c;
      c_new := append(c_new,{temp2});
      c := cdr c>>;

   for each k in a_new do
   << for each h in c_new do
      << temp := simp!* reval algebraic(repart(alpha + r*k + h)- r -1);
         if car temp = 'nil or car temp > 0 then
             fail_test := 't>>;
   >>;
   if fail_test = 't then return 'FAIL else return t>>
else

<< transform_lst := cons (('test3 . '(list 'lessp (list 'repart
  (list 'plus 'alpha (list 'times 'r 'ai) 'cj)) (list 'plus 'r 1))),
     transform_lst);
   return 't>>;
end;

symbolic procedure tst4(l,p,q,c,alpha,r,mu);

% Check validity of the following formula :=
%
%  (p - q)*Re{alpha + cj - 1} - r*Re{mu} > -3*r/2         j=1..l
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (4)

begin scalar c_new,temp1,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then
<< for j := 1 :l do
   << temp1 := prepsq car c;
      c_new := append(c_new,{temp1});
      c := cdr c>>;

   for each i in c_new do
   << temp := simp!* reval algebraic((p - q)*repart(alpha + i - 1)
                                                                - r*repart(mu) + 3/2*r);
      if car temp = 'nil or car temp < 0 then fail_test := t;
   >>;

   if fail_test = t then return 'FAIL else return t>>
else
<< transform_lst := cons (('test4 . '(list 'greaterp (list 'difference
 (list 'times (list 'difference 'p 'q) (list 'repart (list 'plus 'alpha
 (list 'difference 'cj 1)))) (list 'times 'r (list 'repart (list 'plus
 (list 'difference (list 'sum 'bj) (list 'sum 'ai))
 (list 'times (list 'quotient 1 2) (list 'difference 'p 'q)) 1))))
 (list 'minus (list 'times 3 (list 'quotient 'r 2))))),transform_lst);
   return 't>>;

end;

symbolic procedure tst5(k,p,q,d,alpha,r,mu);

% Check validity of the following formula :=
%
%  (p - q)*Re{alpha + dj} - r*Re{mu} > -3*r/2         j=1..k
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (5)

begin scalar d_new,temp1,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq t then

<< for j := 1 :k do
   << temp1 := prepsq car d;
      d_new := append(d_new,{temp1});
      d := cdr d>>;

   for each i in d_new do

   << temp := simp!* reval algebraic((p - q)*repart(alpha + i)
                                                                - r*repart(mu) + 3/2*r);
      if car temp = 'nil or car temp < 0 then fail_test := 't;
   >>;

   if fail_test = t then return 'FAIL else return t>>
else
<< transform_lst := cons (('test5 .'(list 'greaterp (list 'difference
   (list 'times(list 'difference 'p 'q)
   (list 'repart (list 'plus 'alpha 'dj)))
   (list 'times 'r (list 'repart (list 'plus (list 'difference
   (list 'sum 'bj) (list 'sum 'ai)) (list 'quotient
   (list 'difference 'p 'q) 2) 1))))
   (list 'minus (list 'times 3 (list 'quotient 'r 2)))) ),
   transform_lst);
   return t>>;
end;

symbolic procedure tst6(n,u,v,a,alpha,r,rho);

% Check validity of the following formula :=
%
%  (u - v)*Re{alpha + r*ai - r} - Re{rho} > -3/2         i=1..n
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (6)

begin scalar a_new,temp1,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then
<< for j := 1 :n do

   << temp1 := prepsq car a;
      a_new := append(a_new,{temp1});
      a := cdr a>>;

   for each i in a_new do

   << temp := simp!* reval algebraic((u - v)*repart(alpha + r*i - r)
                                                                              - repart(rho) + 3/2);
      if car temp = 'nil or car temp < 0 then fail_test := 't;
   >>;

  if fail_test = 't then return 'FAIL else return 't>>
else
<< transform_lst := cons (('test6 . '(list 'greaterp (list 'difference
  (list 'times (list 'difference 'u 'v) (list 'repart
  (list 'plus 'alpha (list 'difference (list 'times 'r 'ai) 'r))))
  (list 'repart (list 'plus (list 'difference (list 'sum 'dj)
  (list 'sum 'ci)) (list 'times (list 'quotient 1 2)
  (list 'difference 'u 'v)) 1))) (list 'minus (list 'quotient 3 2)))),
  transform_lst);
   return 't>>;
end;

symbolic procedure tst7(m,u,v,b,alpha,r,rho);

% Check validity of the following formula :=
%
%  (u - v)*Re{alpha + r*bi} - Re{rho} > -3/2         i=1..m
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (7)

begin scalar b_new,temp1,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< for j := 1 :m do
   << temp1 := prepsq car b;
      b_new := append(b_new,{temp1});
      b := cdr b>>;

   for each i in b_new do

   << temp := simp!* reval algebraic((u - v)*repart(alpha + r*i)
                                                                              - repart(rho) + 3/2);

      if car temp = 'nil or car temp < 0 then fail_test := 't;
   >>;

   if fail_test = t then return 'FAIL else return t>>
else

<< transform_lst := cons (('test7 . '(list 'greaterp (list 'difference
   (list 'times (list 'difference 'u 'v)
   (list 'repart (list 'plus 'alpha (list 'times 'r 'bi))) )
   (list 'repart (list 'plus (list 'difference (list 'sum 'dj)
   (list 'sum 'ci)) (list 'quotient (list 'difference 'u 'v) 2)1)))
   (list 'minus (list 'quotient 3 2)))),transform_lst);
   return 't>>;
end;

symbolic procedure tst8(p,q,u,v,alpha,r,mu,rho,phi);

% Check validity of the following formula :=
%
% abs(phi) + 2*Re{(q - p)*(v - u)*alpha +
%                     r*(v - u)*(mu - 1) + (q - p)*(rho - 1)} > 0
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (8)

begin scalar sum,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< sum := reval algebraic(2*repart((q - p)*(v - u)*alpha
                                  + r*(v - u)*(mu - 1) + (q - p)*(rho - 1)));

   temp := simp!* reval algebraic(abs phi + sum);
   if car temp = 'nil or car temp < 0 then fail_test := 't;
   if fail_test = t then return 'FAIL else return t>>

else

<< transform_lst := cons (('test8 . '(list 'greaterp (list 'plus
  (list 'abs (list 'difference (list 'difference 'q 'p)
  (list 'times 'r (list 'difference 'v 'u))))
  (list 'times 2 (list 'repart (list 'plus
  (list 'times (list 'difference 'q 'p) (list 'difference 'v 'u)
  'alpha) (list 'times 'r (list 'difference 'v 'u)
  (list 'plus (list 'difference (list 'sum 'bj) (list 'sum 'ai))
  (list 'quotient (list 'difference 'p 'q) 2)))
  (list 'times (list 'difference 'q 'p) (list 'plus
  (list 'difference (list 'sum 'dj) (list 'sum 'ci))
  (list 'quotient (list 'difference 'u 'v) 2)))) )))
  0)),transform_lst);
   return 't>>;

end;

symbolic procedure tst9(p,q,u,v,alpha,r,mu,rho,phi);

% Check validity of the following formula :=
%
% abs(phi) - 2*Re{(q - p)*(v - u)*alpha +
%                     r*(v - u)*(mu - 1) + (q - p)*(rho - 1)} > 0
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (9)

begin scalar sum,temp,fail_test;

transform_tst := reval algebraic(transform_tst);

if transform_tst neq 't then

<< sum := reval algebraic(2*repart((q - p)*(v - u)*alpha
                                  + r*(v - u)*(mu - 1) + (q - p)*(rho - 1)));

   temp := simp!* reval algebraic(abs phi - sum);

   if car temp = 'nil or car temp < 0 then fail_test := 't;

   if fail_test = t then return 'FAIL else return t>>
else

<< transform_lst := cons (('test9 . '(list 'greaterp (list 'difference
  (list 'abs (list 'difference (list 'difference 'q 'p)
  (list 'times 'r (list 'difference 'v 'u))))
  (list 'times 2 (list 'repart (list 'plus
  (list 'times (list 'difference 'q 'p) (list 'difference 'v 'u)
  'alpha) (list 'times 'r (list 'difference 'v 'u)
  (list 'plus (list 'difference (list 'sum 'bj) (list 'sum 'ai))
  (list 'quotient (list 'difference 'p 'q) 2)))
  (list 'times (list 'difference 'q 'p) (list 'plus
  (list 'difference (list 'sum 'dj) (list 'sum 'ci))
  (list 'quotient (list 'difference 'u 'v) 2)))) )))
  0)),transform_lst);
   return 't>>;

end;

algebraic procedure tst10(sigma,delta);

% Check validity of the following formula :=
%
% abs(arg sigma) < delta*pi
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (10)

begin scalar arg_sigma,pro,temp,fail_test,!*rounded,dmode!*;

if transform_tst neq 't then

<< on rounded;
   arg_sigma := abs(atan(impart sigma/repart sigma));
   pro :=  delta*pi;
   temp :=  pro - arg_sigma;
   if  numberp temp and temp <= 0 then fail_test := t;

   off rounded;

   if fail_test = t then return reval 'FAIL else return reval t>>

else

<>;

end;

algebraic procedure tst11(sigma,delta);

% Check validity of the following formula :=
%
% abs(arg sigma) = delta*pi
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (11)

begin scalar arg_sigma,pro,fail_test;

if transform_tst neq 't then

<< arg_sigma := abs(atan(impart sigma/repart sigma));
   pro := delta*pi;
   if arg_sigma neq pro then fail_test := 't;
   if fail_test = 't then return reval 'FAIL else return reval 't>>
else

<< symbolic(transform_lst := cons (('test11 .
'(list 'equal (list 'abs (list 'arg 'sigma))
 (list 'times (list 'plus 'k (list 'difference 'l (list 'quotient
(list 'plus 'u 'v) 2))) 'pi))),transform_lst));
   return reval 't>>;

end;

algebraic procedure tst12(omega,epsilon);

% Check validity of the following formula :=
%
% abs(arg omega) < epsilon*pi
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (12)

begin scalar arg_omega,pro,temp,fail_test,!*rounded,dmode!*;

if transform_tst neq 't then

<< on rounded;

   arg_omega := abs(atan(impart omega/repart omega));
   pro := epsilon*pi;
   temp := pro - arg_omega;
   if numberp temp and temp <= 0 then fail_test := 't;

   off rounded;

   if fail_test = 't then return reval 'FAIL else return reval 't>>

else

<< symbolic(transform_lst := cons (('test12 .
'(list 'lessp (list 'abs (list 'arg 'omega))
(list 'times (list 'plus 'm (list 'difference 'n
(list 'times (list 'quotient 1 2) (list 'plus 'p 'q))))
'pi))),transform_lst));
   return reval 't>>;

end;

algebraic procedure tst13(omega,epsilon);

% Check validity of the following formula :=
%
% abs(arg omega) = epsilon*pi
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (13)

begin scalar arg_omega,pro,fail_test;

if transform_tst neq 't then

<< arg_omega := abs(atan(impart omega/repart omega));
   pro := epsilon*pi;
   if arg_omega neq pro then fail_test := 't;
   if fail_test = t then return reval 'FAIL else return reval 't>>
else

<< symbolic(transform_lst := cons (('test13 .
'(list 'equal (list 'abs (list 'arg 'omega))
(list 'times (list 'plus 'm (list 'difference 'n
(list 'times (list 'quotient 1 2) (list 'plus 'p 'q))))
'pi))),transform_lst));
   return reval 't>>;
end;

algebraic procedure tst14(u,v,alpha,mu,rho,delta,epsilon,sigma,omega,
                                                                                                   r,phi,r1,r2);
% Check validity of the following formula :=
%
%  abs(arg(1 - z*sigma^(-r1)*omega^r2)) < pi
%
%     when phi = 0 and epsilon + r*(delta - 1) <= 0
%
%  where z = r^[r1*(v - u)]*exp[-(r1*delta + r2*epsilon)*pi*i]
%
%   or z = sigma^r1*omega^(-r2)
%     when Re{mu + rho + alpha*(v - u)}
%
% 'Integrals and Series, Volume 3, More Special Functions',
%  A.P.Prudnikov, Yu.A.Brychkov, O.I.Marichev. Chapter 2.24.1
%  page 345  (14)

begin scalar temp,z,arg,arg_test,!*rounded,dmode!*;

if transform_tst neq 't then

<< on rounded;

   temp := epsilon + r *(delta - 1);
   if phi = 0 and temp <= 0 then
       z := r^(r2*(v - u))*e^(-(r2*delta+r1*epsilon)*pi*i)

   else if numberp (mu + rho + alpha*(v - u)) and
                        repart(mu + rho + alpha*(v - u)) < 1 then
       z := sigma^r2*omega^(-r1)
   else return reval 'FAIL; % Wn
   arg := 1 - z*sigma^(-r2)*omega^r1;

   if arg = 0 then arg_test := 0
   else     arg_test := abs(atan(impart arg/repart arg));

   if numberp arg_test and arg_test < pi then
                << off rounded; return reval 't>>
   else     << off rounded; return reval 'FAIL>>;
>>

else
<< symbolic(transform_lst := cons (('test14 .'(list 'or (list 'and
  (list 'abs (list 'arg (list 'difference 1 (list 'times
  (list 'times (list 'expt 'r (list 'times 'r1
  (list 'difference 'v 'u))) (list 'exp (list 'minus
  (list 'times (list 'plus (list 'times 'r1 (list 'plus 'k
  (list 'difference 'l (list 'times (list 'quotient 1 2)
  (list 'plus 'u 'v)))) ) (list 'times 'r2 (list 'plus 'm
  (list 'difference 'n (list 'times (list 'quotient 1 2)
  (list 'difference 'p 'q)))) )) 'pi 'i))))
  (list 'expt 'sigma (list 'minus 'r1)) (list 'expt 'omega 'r2)))) )
  (list 'equal 'phi 0) (list 'leq (list 'plus 'k (list 'difference 'l
  (list 'times (list 'quotient 1 2) (list 'plus 'u 'v)))
  (list 'times 'r (list 'plus 'm (list 'difference (list 'difference 'n
  (list 'times (list 'quotient 1 2) (list 'plus 'p 'q))) 1)))) 0))
  (list 'and (list 'lessp (list 'repart (list 'plus
  (list 'difference (list 'sum 'bj) (list 'sum 'ai))
  (list 'times (list 'quotient 1 2) (list 'difference 'p 'q)) 1
  (list 'difference (list 'sum 'dj) (list 'sum 'ci))
  (list 'times (list 'quotient 1 2) (list 'difference 'u 'v)) 1
  (list 'times 'alpha (list 'difference 'v 'u)))) 0)
  (list 'equal 'phi 0) (list 'leq (list 'plus 'k (list 'difference 'l
  (list 'times (list 'quotient 1 2) (list 'plus 'u 'v)))
  (list 'times 'r (list 'plus 'm (list 'difference (list 'difference 'n
  (list 'times (list 'quotient 1 2) (list 'plus 'p 'q))) 1)))) 0)))),
                                        transform_lst));

   return reval 't>>;

end;

algebraic procedure tst15(m,n,p,q,k,l,u,v,sigma,omega,eta);

begin scalar lc,ls,temp_ls,psi,theta,arg_omega,arg_sigma,
        !*rounded,dmode!*;

if transform_tst neq 't then

<< arg_omega := atan(impart omega/repart omega);
   arg_sigma := atan(impart sigma/repart sigma);

   psi := (abs arg_omega + (q - m - n)*pi)/(q - p);
   theta := (abs arg_sigma + (v - k - l)*pi)/(v - u);


   lc := (q - p)*abs(omega)^(1/(q - p))*cos psi +
                             (v - u)*abs(sigma)^(1/(v - u))*cos theta;

   lc := lc;
   temp_ls := (q - p)*abs(omega)^(1/(q - p))*sign(arg_omega)*sin psi +
          (v - u)*abs(sigma)^(1/(v - u))*sign(arg_sigma)*sin theta;

   if arg_sigma*arg_omega neq 0 then ls := temp_ls
        else return reval 'fail;

   on rounded;
   if (numberp lc and lc > 0) or lc = 0 and ls = 0 and repart eta > -1
                  or lc = 0 and ls = 0 and repart eta > 0 then
   << off rounded; return reval 't>>

   else         << off rounded; return reval 'fail>>
>>

else
<< symbolic(transform_lst := cons (('test15 . '(list 'or
(list 'greaterp 'lambda_c 0) (list 'and (list 'equal 'lambda_c 0)
(list 'neq 'lambda_s 0) (list 'greaterp (list 'repart 'eta)
(list 'minus 1))) (list 'and (list 'equal 'lambda_c 0)
(list 'equal 'lambda_s 0) (list 'greaterp (list 'repart 'eta) 0)))),
                                        transform_lst));
return reval 't>>;

end;

symbolic procedure bastab(u,v);
 if u eq 'f1 then subpar(get('f1,'g),v) else
 if u eq 'f2 then subpar(get('f2,'g),v)$

symbolic procedure subpar(u,v);
if null v then list(cadr u,caddr u, cadddr u,car cddddr u,
                    cadr cddddr u)
  else list(cadr u,sublist1(caddr u,v,car u),
          sublist1(cadddr u,v,car u),
          subpref1(car cddddr u,v,car u),cadr cddddr u)$

symbolic procedure sublist1(u,v,z);
 % u,v,z - list PF.
 if null cdr v or null cdr z then sublist(u,car v,car z)
   else
    sublist1(
      sublist(u,car v,car z),
      cdr v,cdr z)$

symbolic procedure subpref1(u,v,z);
% u - pf
% v,z - list pf
 if null cdr v or null cdr z then subpref(u,car v,car z)
   else subpref(subpref1(u,cdr v,cdr z),car v,car z)$

symbolic procedure subpref(u,v,z);
% u,v,z - pf
 prepsq subsqnew(simp!* u,simp!* v,z)$

symbolic procedure sublist(u,v,z);
% u - list pf
% v,z - pf
if null u then nil else
     subpref(car u,v,z) . sublist(cdr u,v,z)$

symbolic procedure trpar(u1,u2,u3);
  if not numberp u2 and not atom u2 and car(u2)='plus then 'FAIL else
  begin scalar a!3,l!1,v1,v2,v3,v4;
   if (v1:=dubdeg(car simp u1,'x))='FAIL or
           (v2:=dubdeg(cdr simp u1,'x))='FAIL or
           (v3:=dubdeg(car simp u2,u3))='FAIL or
           (v4:=dubdeg(cdr simp u2,u3))='FAIL then return 'FAIL;
   a!3:=multsq(diff1sq(v1,v2), diff1sq(v3,v4));
   l!1:=subpref(u1,u2,'x);
   l!1:=subpref(l!1,1,u3);
   return list(simp!*(l!1),a!3);
  end$

symbolic procedure modintgg(u1,u2,u3);
 list(
    multsq(u1,invsq gr u2),
    change(u2,list(cons(gw u2,list '(1 . 1))),'(1)),
    change(u3,list(cons(gw u3,list(quotsq(gr u3,gr u2)))),'(1)))$

symbolic procedure change(u1,u2,u3);
 begin scalar v;integer k;
  while u1 do begin
   if u3 and car u3=(k:=k+1) then
            << v:=append(v,list car u2);
               if u2 then u2:=cdr u2;
               if u3 then u3:=cdr u3
            >>
     else
      v:=append(v,list car u1);
   u1:=cdr u1;
   if null u3 then << v:= append(v,u1); u1:= nil>>; %WN
  end;
  return v;
end$

symbolic procedure cong(u);
 list(
   list(invsq gw u,negsq gr u),
   list(gn u,gm u,gq u,gp u),
   difflist(listmin gb u,'(-1 . 1)),
   difflist(listmin ga u,'(-1 . 1)))$

symbolic procedure modintg(u1,u2);
 list(
  multsq(u1,invsq gr u2),
  change(u2,
    list(
      cons(gw u2,list '(1 . 1))),'(1)))$

symbolic procedure ccgf(u);
  quotsq(
     simp(2 * gm u + 2 * gn u - gp u - gq u),
     '(2 . 1))$

symbolic procedure vgg(u1,u2);
  diff1sq(
     simp(gq u2 - gp u2),
     multsq(gr u2,simp(gq u1 - gp u1)))$

symbolic procedure nugg(u1,u2,u3);
  diff1sq( diff1sq('(1 . 1), multsq(u3, simp(gq u1 - gp u1))),
           addsq(mugf u2,mugf u1))$

symbolic smacro procedure sumlistsq(u);
<< for each pp in u do <
    >; p>> where p = '(nil . 1);

symbolic procedure mugf(u);
  addsq(
     quotsq(simp(2 + gp u - gq u),'(2 . 1)),
     addsq(sumlistsq gb u,negsq sumlistsq ga u))$

symbolic procedure coefintg(u1,u2,u3);
  multlist(
   list(
     expdeg(gk u2 . 1,mugf u2),
     expdeg(gl u2 . 1,
       addsq(mugf u1,
         diff1sq(
            multsq(u3,(gq u1-gp u1) . 1),
            '(1 . 1)))),
     expdeg(gw u1,negsq u3),
     expdeg(simp '(times 2 pi),
       addsq(multsq(ccgf u1,(1-gl u2) . 1),
             multsq(ccgf u2,(1-gk u2) . 1)))))$

% The procedure name "delta" had been changed to "defint_delta" to avoid
% clashed with the cantens package.

symbolic procedure deltagg(u1,u2,u3);
  list(
     append( defint_delta(car redpar1(ga u2,gn u2), gk u2),
      append(
        defint_delta( difflist( listmin gb u1, addsq(u3,'(-1 . 1))), gl u2),
        defint_delta( cdr redpar1(ga u2,gn u2), gk u2))),
     append( defint_delta(car redpar1(gb u2,gm u2), gk u2),
      append(defint_delta( difflist(listmin ga u1,addsq(u3,'(-1 . 1))),gl u2),
        defint_delta( cdr redpar1(gb u2,gm u2), gk u2))))$

symbolic procedure redpargf(u);
 begin scalar v1,v2;
  v1:=redpar(car redpar1(gb u,gm u), cdr redpar1(ga u,gn u));
  v2:=redpar(cdr redpar1(gb u,gm u), car redpar1(ga u,gn u));

  return
    list(car u, (cadr v2 . cadr v1), (car v1 . car v2));

end$

symbolic procedure arggf(u1,u2);

% Calculate the coefficient of the variable in the combined meijerg
% function

 multlist(list(
     expdeg(gw u2, gk u2 . 1),
     expdeg(gk u2 . 1, (gk u2 * gp u2 - gk u2 * gq u2) . 1),
     invsq(expdeg(gw u1, gl u2 . 1)),
     expdeg(gl u2 . 1,(gl u2 * gq u1 - gl u2 * gp u1) . 1)))$

symbolic procedure indgf(u1,u2);

% Calculate the values of m,n,p,q of the combined meijerg function

 list(gk u2 * gm u2 + gl u2 * gn u1,
      gk u2 * gn u2 + gl u2 * gm u1,
      gk u2 * gp u2 + gl u2 * gq u1,
      gk u2 * gq u2 + gl u2 * gp u1)$

symbolic procedure dubdeg(x,y);
% x -- SF.
% y -- atom.
begin scalar c,b,a1,a3;
if numberp x or null x then return '(nil . 1);
if not null cdr(x) then return 'FAIL;
lb1: a1:=caar x;a3:=car a1;
  if atom a3 and a3=y then b:=cdr a1 . 1 ;
  if not atom a3 then
    if cadr a3=y then
     if null cddr(a3) then return 'FAIL else
       if not nump(simp caddr a3) then return simp(caddr a3)
                                else
          c:=times(cdr a1,cadr caddr a3).caddr caddr a3;
  if atom cdar x then
    if null b then
      if null c then return '(nil . 1)
      else return c
    else
    if null c then return b
    else return plus(times(car b,cdr c),car c).cdr c;
  x:=cdar x;go to lb1;
end$

symbolic procedure defint_delta(u,n);
  % u -- list of sq.
  % n -- number.
  if null u then nil else
    append(if n=1 then list car u else
             delta0(quotsq(car u,simp!* n),n,n)
          ,defint_delta(cdr u,n))$

symbolic procedure delta0(u,n,k);
  % u -- SQ.
  % n,k -- numbers.
   if k=0 then nil else
       u . delta0(addsq(u,invsq(simp!* n)),n,k-1)$

symbolic procedure nump(x);
 or(null car x,and(numberp car x,numberp cdr x))$


endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintd.red0000644000175000017500000002100611526203062024065 0ustar  giovannigiovannimodule defintd;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(mellincoef mellin!-coefficients!* mellin!-transforms!*);

% The following are needed by GAMMA.

load_package specfn,sfgamma;

symbolic procedure simpintgggg (u);

begin scalar ff1,ff2,alpha,var,chosen_num,coef,temp,const,result;

     u := defint_reform(u);
     const := car u;
     if const = 0 then result := nil . 1
     else
     << u := cdr u;
              if length u neq 4 then rederr  "Integration failed";
        if (car u) = 0 then ff1 := '(0 0 x)
        else ff1 := prepsq simp car u;
        if (cadr u) = 0 then ff2 := '(0 0 x)
        else  ff2 := prepsq simp cadr u;

        if (ff1 = 'UNKNOWN) then return simp 'unknown;
        if (ff2 = 'UNKNOWN) then return simp 'unknown;
        alpha := caddr u;
        var := cadddr u;

        if car ff1 = 'f31 or car ff1 = 'f32 then
                << put('f1,'g,spec_log(ff1)); MELLINCOEF :=1>>
        else
        << chosen_num := cadr ff1;
           put('f1,'g,getv(mellin!-transforms!*,chosen_num));
           coef := getv(mellin!-coefficients!*,chosen_num);
           if coef then MELLINCOEF:= coef else MELLINCOEF :=1>>;

        if car ff2 = 'f31 or car ff2 = 'f32 then
           put('f2,'g,spec_log(ff2))
        else
        << chosen_num := cadr ff2;
           put('f2,'g,getv(mellin!-transforms!*,chosen_num));
           coef := getv(mellin!-coefficients!*,chosen_num);
           if coef then MELLINCOEF:= coef * MELLINCOEF >>;

        temp :=  simp list('intgg,'f1 . cddr ff1,
                                                        'f2 . cddr ff2,alpha,var);

        temp := prepsq temp;

        if temp neq 'unknown then
            result := reval algebraic(const*temp)

        else result := temp;
         result := simp!* result; >>;
      return result;
end;

symbolic procedure spec_log(ls);

begin scalar n,num,denom,mellin;

  n := cadr ls;
  num := for i:= 0 :n collect 1;
  denom := for i:= 0 :n collect 0;

  if car ls = 'f31 then
    mellin := {{}, {n+1,0,n+1,n+1},num,denom, (-1)^n*factorial(n),'x}
   else mellin := {{}, {0,n+1,n+1,n+1},num,denom, factorial(n),'x};
return mellin;
end;

 % some rules which let the results look more convenient ...

algebraic <<

 for all z let sinh(z) = (exp (z) - exp(-z))/2;
 for all z let cosh(z) = (exp (z) + exp(-z))/2;

operator laplace2,Y_transform2,K_transform2,struveh_transform2,
               fourier_sin2,fourier_cos2;

gamma_rules :=

{ gamma(~n/2+1/2) => gamma(n)/(2^(n-1)*gamma(n/2))*gamma(1/2),
  gamma(~n/2+1) => n/2*gamma(1/2*n),
  gamma(3/4)*gamma(1/4) => pi*sqrt(2),
  gamma(~n)*~n/gamma(~n+1) => 1
};

let gamma_rules;

factorial_rules := {factorial(~a) => gamma(a+1) };
let factorial_rules;

>>;

% A function to calculate laplace transforms of given functions via
% integration of Meijer G-functions.

put('laplace_transform,'psopfn,'new_laplace);

symbolic procedure new_laplace(lst);

begin scalar new_lst;
lst := product_test(lst);
new_lst := {'laplace2,lst};
return defint_trans(new_lst);
end;

% A function to calculate hankel transforms of given functions via
% integration of Meijer G-functions.

put('hankel_transform,'psopfn,'new_hankel);

symbolic procedure new_hankel(lst);

begin scalar new_lst;
lst := product_test(lst);
new_lst := {'hankel2,lst};
return defint_trans(new_lst);
end;

% A function to calculate Y transforms of given functions via
% integration of Meijer G-functions.

put('Y_transform,'psopfn,'new_Y_transform);

symbolic procedure new_Y_transform(lst);

begin scalar new_lst;
lst := product_test(lst);
new_lst := {'Y_transform2,lst};
return defint_trans(new_lst);
end;

% A function to calculate K-transforms of given functions via
% integration of Meijer G-functions.

put('K_transform,'psopfn,'new_K_transform);

symbolic procedure new_K_transform(lst);

begin scalar new_lst;
lst := product_test(lst);
new_lst := {'K_transform2,lst};
return defint_trans(new_lst);
end;


% A function to calculate struveh transforms of given functions via
% integration of Meijer G-functions.

put('struveh_transform,'psopfn,'new_struveh);

symbolic procedure new_struveh(lst);

begin scalar new_lst,temp;
        lst := product_test(lst);
        new_lst := {'struveh2,lst};
        temp:=defint_trans(new_lst);
        return defint_trans(new_lst);
end;

% A function to calculate fourier sin transforms of given functions via
% integration of Meijer G-functions.

put('fourier_sin,'psopfn,'new_fourier_sin);

symbolic procedure new_fourier_sin(lst);

begin scalar new_lst;
lst := product_test(lst);
new_lst := {'fourier_sin2,lst};
return defint_trans(new_lst);
end;

% A function to calculate fourier cos transforms of given functions via
% integration of Meijer G-functions.

put('fourier_cos,'psopfn,'new_fourier_cos);

symbolic procedure new_fourier_cos(lst);

  begin scalar new_lst;
        lst := product_test(lst);
        new_lst := {'fourier_cos2,lst};
        return defint_trans(new_lst);
  end;

% A function to test whether the input is in a product form and if so
% to rearrange it into a list form.

% e.g. defint(x*cos(x)*sin(x),x) => defint(x,cos(x),sin(x),x);

symbolic procedure product_test(lst);

begin scalar temp;
product_tst := nil;
if listp car lst then
<< temp := caar lst;
   if temp = 'times and length cdar lst <= 3 then
   << lst := append(cdar lst,cdr lst); product_tst := t>>;
>>;
return lst;
end;

% A function to call the relevant transform's rule-set

symbolic procedure defint_trans(lst);

begin scalar type,temp_lst,new_lst,var,n1,n2,result;

% Set a test to indicate that the relevant conditions for validity
% should not be tested

        algebraic(transform_tst := t);

        spec_cond := '();
        type := car lst; % obtain the transform type
        temp_lst := cadr lst;
        var := nth(temp_lst,length temp_lst);
        new_lst := hyperbolic_test(temp_lst);

        if length temp_lst = 3 then
                << n1 := car new_lst;
                      n2 := cadr new_lst;
                      result := reval list(type,n1,n2,var)>>
         % Call the relevant rule-set

else if length temp_lst = 2 then
<< n1 := car new_lst;
   result := reval list(type,n1,var)>> % Call the relevant rule-set

        else if length temp_lst = 4 and product_tst = 't then
        << n1 := {'times,car new_lst,cadr new_lst};
           n2 := caddr new_lst;
           result := reval list(type,n1,n2,var)>>

        else << algebraic(transform_tst := nil);
                rederr "Wrong number of arguments">>;

return result;
end;

% A function to test for hyperbolic functions and rename them
% in order to avoid their transformation into combinations of
% the exponenetial function

%symbolic procedure hyperbolic_test(lst);
% begin scalar temp,new_lst,lth;
% lth := length lst;
% for i:=1 :lth do
% << temp := car lst;
%    if listp temp and (car temp = 'difference or car temp = 'plus) then
%        temp := hyperbolic_test(temp)
%    else if listp temp and car temp = 'sinh then car temp := 'mysinh
%    else if listp temp and car temp = 'cosh then car temp := 'mycosh;
%    new_lst := append(new_lst,{temp});
%   lst := cdr lst>>;
%return new_lst;
%end;

symbolic procedure hyperbolic_test lst;
   for each u in lst collect
      if atom u then u
       else if car u memq '(difference plus) then hyperbolic_test u
       else if car u eq 'sinh then 'mysinh . cdr u
       else if car u eq 'cosh then 'mycosh . cdr u
       else u;

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defintb.red0000644000175000017500000001321411526203062024065 0ustar  giovannigiovannimodule defintb;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic ;

 defint_choose_data :=

{ defint_choose(1/e**(~x),~var) => f1(1,x),
  defint_choose(sin(~x),~var)   => f1(2,x),
  defint_choose(-sin(~x),~var)   => f1(25,x),
  defint_choose(cos(~x),~var)   => f1(3,x),

  defint_choose(acos(~x)*Heaviside (1-(~x)),~var) => f1(7,x),
  defint_choose(acos(1/~x)*Heaviside ((~x)-1),~var) => f1(8,x),
  defint_choose(atan(~x),~var) => f1(9,x),
  defint_choose(mysinh(~x),~var) => f1(10,x),
  defint_choose((e^(2*~x)-1)/(2*e^~x),~var) => f1(10,x),   %sinh(x)
  defint_choose((e^(~y)-1)/(2*e^~x),~var) => f1(10,x)   %sinh(nx)
     when y = 2*x,
  defint_choose(mycosh(~x),~var)=> f1(11,x),

  defint_choose((e^(2*~x)+1)/(2*e^~x),~var) => f1(11,x),   %cosh(x)
  defint_choose((e^(~y)+1)/(2*e^~x),~var) => f1(11,x)   %cosh(nx)
     when y = 2*x,
  defint_choose(Heaviside (1-(~x)),~var) => f1(30,x),
  defint_choose(Heaviside ((~p-~x)/~p),~var) => f1(30,x/p),
  defint_choose(Heaviside ((~x)-1),~var) => f1(31,x),
  defint_choose(log(~x)*Heaviside (1-(~x)),~var) => f1(32,x),
  defint_choose(log(~x)*Heaviside ((~x)-1),~var) => f1(33,x),
  defint_choose((log(~x))^(~n)*Heaviside (1-(~x)),~var) => f31(n,x),
  defint_choose((log(~x))^(~n)*Heaviside ((~x)-1),~var) => f32(n,x),
  defint_choose(log(1+~x),~var) => f1(34,x),
  defint_choose(log((~x+1)/~x),~var) => f1(35,x),
  defint_choose(ei(-~x),~var) => f1(36,x),
  defint_choose(si(~x),~var) => f1(37,x),
  defint_choose(ci(~x),~var) => f1(38,x),
  defint_choose(shi(~x),~var) => f1(39,x),

  defint_choose(erf(~x),~var) => f1(41,x),
  defint_choose(-erf(~x)+1,~var) => f1(42,x),    %erfc(x)
  defint_choose(fresnel_s(~x),~var) => f1(43,x),
  defint_choose(fresnel_c(~x),~var) => f1(44,x),
  defint_choose(gamma(~n,~x),~var) => f1(45,x,n),

  defint_choose(besselj(~n,~x),~var) => f1(50,x,n),
  defint_choose(bessely(~n,~x),~var) => f1(51,x,n),
  defint_choose(besseli(~n,~x),~var) => f1(52,x,n),
  defint_choose(besselk(~n,~x),~var) => f1(53,x,n),
  defint_choose(struveh(~n,~x),~var) => f1(54,x,n),
  defint_choose(struvel(~n,~x),~var) => f1(55,x,n),
  defint_choose(m_legendrep(~n,~x)*Heaviside(1-(~x)),~var) =>
                                          f1(56,x,n),
  defint_choose(m_legendrep(~n,1/~x)*Heaviside((~x)-1),~var) =>
                                          f1(57,x,n),
  defint_choose((1-(~x))^(-1/2)*m_chebyshevt(~n,~x),~var) =>
                                          f1(58,x,n),
  defint_choose(((~x)-1)^(-1/2)*m_chebyshevt(~n,1/~x),~var) =>
                                          f1(59,x,n),
  defint_choose((1-(~x))^(1/2)*m_chebyshevu(~n,~x),~var) =>
                                          f1(60,x,n),
  defint_choose(((~x)-1)^(1/2)*m_chebyshevu(~n,1/~x),~var) =>
                                          f1(61,x,n),
  defint_choose(m_hermitep(~n,~x),~var) => f1(62,x,n),

  defint_choose(m_laguerrep(~n,~l,~x),~var) => f1(63,x,n,l),

  defint_choose(sqrt(1-~x)*m_gegenbauerp(~n,~l,~x),~var) =>
                                          f1(64,x,n,l),

  defint_choose(sqrt(1-~x)*(1-~x)*m_gegenbauerp(~n,~l,~x),~var) =>
                                          f1(64,x,n,l),

  defint_choose((~x-1)^~k*sqrt(~x-1)*m_gegenbauerp(~n,~l,~x),~var) =>
                                          f1(64,x,n,l),
  defint_choose((~x-1)^~k*sqrt(1-~x)*m_gegenbauerp(~n,~l,~x),~var) =>
                                          f1(64,x,n,l),

  defint_choose(-(~x-1)^~k*sqrt(1-~x)*m_gegenbauerp(~n,~l,~x),~var) =>
                                          f1(64,x,n,l),

  defint_choose(sqrt(~x-1)*m_gegenbauerp(~n,~l,1/~x),~var) =>
                                          f1(65,x,n,l),

  defint_choose(sqrt(~x-1)*(~x-1)*m_gegenbauerp(~n,~l,1/~x),~var) =>
                                          f1(65,x,n,l),

  defint_choose(sqrt(~x-1)*(~x-1)^(~k)*m_gegenbauerp(~n,~k,1/~x),~var)=>
                                          f1(65,x,n,l),

  defint_choose(-sqrt(~x-1)*(~x-1)^(~k)*m_gegenbauerp(~n,~k,1/~x),~var)
                                          => f1(65,x,n,l),

  defint_choose((1-~x)^~r*m_jacobip(~n,~r,~s,~x),~var) =>
                                                                       f1(66,x,n,r,s),
  defint_choose((~x-1)^~r*m_jacobip(~n,~r,~s,1/~x),~var) =>
                                          f1(67,x,n,r,s),
  defint_choose(0,~var) => f1(0,0),

  defint_choose(~n,~var) => f1(0,n)
     when numberp n,

  defint_choose(~f,~var)        => unknown };  % fallthrough case

let defint_choose_data;

endmodule;
end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/defint/defint0.red0000644000175000017500000002564111526203062024012 0ustar  giovannigiovannimodule defint0;  % Rules for definite integration.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(unknown_tst product_tst transform_tst transform_lst);

transform_lst := '();

fluid '(!*precise);

global '(spec_cond);

symbolic smacro procedure mynumberp(n);

begin; if numberp n then t

else if listp n and car n = 'quotient and (numberp cadr n or
mynumberp cadr n) and (numberp caddr n or mynumberp caddr n) then 't

else if listp n and car n = 'sqrt and (numberp cadr n or cadr n = 'pi)
         then t else nil;
end;

symbolic operator mynumberp;


put('intgggg,'simpfn,'simpintgggg);

% put('defint,'psopfn,'new_defint);

symbolic procedure new_defint(lst);
   begin scalar var,result,n1,n2,n3,n4,!*precise;
      if eqcar(car lst,'times)
        then return new_defint append(cdar lst,cdr lst);
      unknown_tst := nil;
      var := nth(lst,length lst);
      if length lst = 2 and listp car lst then
              lst := test_prod(lst,var);
      transform_tst := reval algebraic(transform_tst);
      if transform_tst neq t then lst := hyperbolic_test(lst);
      for each i in lst do specfn_test(i);
      if length lst = 5 then
         <>
      else if length lst = 4 then
         <>
      else if length lst = 3 then
         <>
      else if length lst = 2 then
         <>;
      algebraic(transform_tst := nil);
      if pairp result then <>
       else return result
   end;

symbolic procedure specfn_test(n);

begin;
if listp n and car n = 'times then
<< if listp caddr n and (car caddr n = 'm_gegenbauerp or
                                             car caddr n = 'm_jacobip)
    then off exp; >>;
end;

symbolic procedure test_prod(lst,var);

begin scalar temp,ls;

temp := caar lst;

if temp = 'times then
   << if listp caddar lst then

% test for special cases of Meijer G-functions of compoud functions

      << if car caddar lst neq 'm_chebyshevt and
                  car caddar lst neq 'm_chebyshevu and
            car caddar lst neq 'm_gegenbauerp and
            car caddar lst neq 'm_jacobip then
            ls := append(cdar lst,{var})

%else returned without change
         else ls := lst;>>
      else ls := append(cdar lst,{var});
   >>

else if temp = 'minus and caadar lst = 'times then
<< if length cadar lst = 3 then
      ls := {{'minus,car cdadar lst},cadr cdadar lst,var}
   else if length cadar lst = 4 then
      ls := {{'minus,car cdadar lst},cadr cdadar lst,
                                                                      caddr cdadar lst,var}>>
else ls := lst;
return ls;
end;

symbolic procedure test_unknown(n);

% A procedure to test for unknown as the result of the integration
% process

if pairp n then << for each i in n do test_unknown(i)>>
else if n = 'unknown then unknown_tst := 't;

algebraic<<
heaviside_rules :=

{ heaviside(~x) => 1 when numberp x and x >= 0,
  heaviside(~x) => 0 when numberp x and x < 0 };

let heaviside_rules;

operator defint2,defint_choose;

SHARE MELLINCOEF$

defint2_rules:=

{ defint2(~n,cos((~x*~~A)/~~C)-cos((~x*~~B)/~~D),~x) =>
                defint2(-2,n,sin((A/C+B/D)*x/2),sin((A/C-B/D)*x/2),x),
  defint2(cos((~x*~~A)/~~C)-cos((~x*~~B)/~~D),~x) =>
                defint2(-2,sin((A/C+B/D)*x/2),sin((A/C-B/D)*x/2),x),

  defint2(~b,~f1,~f2,~x) => b*defint2(f1,f2,x) when freeof (b,x),

  defint2(~~b*~f1,~~c*~f2,~x) => b*c*defint2(f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~c/~f2,~x) => c*b*defint2(1/f1,1/f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~~b*~f1,~c/~f2,~x) => c*b*defint2(f1,1/f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~~c*~f2,~x) => c*b*defint2(1/f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~f1/~~b,~~c*~f2,~x) => c/b*defint2(f1,f2,x)
         when freeof (b,x) and freeof (c,x) and not(b = 1 and c = 1),

  defint2(~b/~f1,~x) => b*defint2(1/f1,x)
        when freeof (b,x) and not(b = 1),

  defint2(~~b*~f1,~x) => b*defint2(f1,x)
        when freeof (b,x) and not(b = 1),

  defint2(~f1/~~b,~x) => 1/b*defint2(f1,x)
        when freeof (b,x) and not(b = 1),

  defint2((~f2+ ~~f1)/~~f3,~x) => defint2(f2/f3,x) + defint2(f1/f3,x)
                        when not(f1=0),
  defint2(-~f1,~x) =>  - defint2(f1,x),
  defint2((~f2+ ~~f1)/~~f3,~n,~x) =>
                 defint2(f2/f3,n,x) + defint2(f1/f3,n,x)
                when not(f1=0),
  defint2(-~f1,~n,~x) =>  - defint2(f1,n,x),
  defint2(~n,(~f2+ ~~f1)/~~f3,~x) =>
                 defint2(n,f2/f3,x) + defint2(n,f1/f3,x)
                when not(f1=0),
  defint2(~n,-~f1,~x) =>  - defint2(n,f1,x),
  defint2(~n,(~f2+ ~~f1)/~~f3,~nn,~x) =>
                 defint2(n,f2/f3,nn,x) + defint2(n,f1/f3,nn,x)
                when not(f1=0),
  defint2(~n,-~f1,~nn,~x) =>  - defint2(n,f1,nn,x),
  defint2(~n,~nn,(~f2+ ~~f1)/~~f3,~x) =>
                 defint2(n,nn,f2/f3,x) + defint2(n,nn,f1/f3,x)
                when not(f1=0),
  defint2(~n,~nn,-~f1,~x) =>  - defint2(n,nn,f1,x),

  defint2(~n,~x^~a,~f1,~f2,~x) =>
                            n*intgggg(defint_choose(f1,x),defint_choose(f2,x),a,x)
   when numberp n ,

  defint2(~n,~x,~f1,~f2,~x) =>
                 n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1,x)
   when numberp n ,
  defint2(~n,1/~x^~~a,~f1,~f2,~x) =>
                            n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-a,x)
   when numberp n ,
  defint2(~n,1/~x,~f1,~f2,~x) =>
                           n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1,x)
   when numberp n ,
  defint2(~n,sqrt(~x),~f1,~f2,~x) =>
                           n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x,~f1,~f2,~x) =>
                           n*intgggg(defint_choose(f1,x),defint_choose(f2,x),3/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x^~a,~f1,~f2,~x) =>
              n*intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2+a,x)
   when numberp n ,
  defint2(~n,1/sqrt(~x),~f1,~f2,~x) =>
               n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x),~f1,~f2,~x) =>
               n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-3/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x^~a),~f1,~f2,~x) =>
             n*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2-a,x)
   when numberp n ,

  defint2(~n,1/~x,~f1,~x) => n*intgggg(defint_choose(f1,x),0,-1,x)
   when numberp n ,
  defint2(~n,1/~x^(~a),~f1,~x) => n*intgggg(defint_choose(f1,x),0,-a,x)
   when numberp n ,
  defint2(~n,1/sqrt(~x),~f1,~x) =>
                 n*intgggg(defint_choose(f1,x),0,-1/2,x) when numberp n,
  defint2(~n,1/(sqrt(~x)*~x),~f1,~x) =>
                            n*intgggg(defint_choose(f1,x),0,-3/2,x)
   when numberp n ,
  defint2(~n,1/(sqrt(~x)*~x^~a),~f1,~x) =>
                            n*intgggg(defint_choose(f1,x),0,-1/2-a,x)
   when numberp n ,
  defint2(~n,~x**(~a),~f1,~x) => n*intgggg(defint_choose(f1,x),0,a,x)
   when numberp n ,
  defint2(~n,~x,~f1,~x) => n*intgggg(defint_choose(f1,x),0,1,x)
   when numberp n ,
  defint2(~n,sqrt(~x),~f1,~x) => n*intgggg(defint_choose(f1,x),0,1/2,x)
    when numberp n ,
 defint2(~n,sqrt(~x)*~x,~f1,~x) =>
    n*intgggg(defint_choose(f1,x),0,3/2,x)
   when numberp n ,
  defint2(~n,sqrt(~x)*~x^~a,~f1,~x) =>
                           n*intgggg(defint_choose(f1,x),0,1/2+a,x)
   when numberp n ,

  defint2(~~b*~x^~~a/~~c,~f1,~f2,~x) =>
        b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),a,x)
                        when freeof(b,x) and freeof (c,x),
  defint2(~b/(~~c*~x^~~a),~f1,~f2,~x) =>
        b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),-a,x)
                        when freeof(b,x) and freeof(c,x),
  defint2(sqrt(~x),~f1,~f2,~x) =>
                     intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2,x),
  defint2(sqrt(~x)*~x^~~a,~f1,~f2,~x) =>
               intgggg(defint_choose(f1,x),defint_choose(f2,x),1/2+a,x),
  defint2(~b/(~~c*sqrt(~x)),~f1,~f2,~x) =>
            b/c*intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2,x),
  defint2(1/(sqrt(~x)*~x^~~a),~f1,~f2,~x) =>
      intgggg(defint_choose(f1,x),defint_choose(f2,x),-1/2-a,x),

  defint2(1/~x^(~~a),~f1,~x) => intgggg(defint_choose(f1,x),0,-a,x),
  defint2(1/sqrt(~x),~f1,~x) => intgggg(defint_choose(f1,x),0,-1/2,x),
  defint2(1/(sqrt(~x)*~x^~~a),~f1,~x) =>
                             intgggg(defint_choose(f1,x),0,-1/2-a,x),
  defint2(~x**(~~a),~f1,~x) => intgggg(defint_choose(f1,x),0,a,x),
  defint2(sqrt(~x),~f1,~x) => intgggg(defint_choose(f1,x),0,1/2,x),
  defint2(sqrt(~x)*~x^~~a,~f1,~x) =>
                 intgggg(defint_choose(f1,x),0,1/2+a,x),

  defint2(~b,~f1,~x) => b*defint2(f1,x) when freeof(b,x),
  defint2(~f1,~f2,~x) =>
        intgggg(defint_choose(f1,x),defint_choose(f2,x),0,x),

  defint2(~n,~f1,~x) => n*intgggg(defint_choose(f1,x),0,0,x),

  defint2(~f1,~x) => intgggg(defint_choose(f1,x),0,0,x),

  defint2((~f1-~f2)/~f3,~f4,~x) =>
                                               defint2(f1/f3,f4,x) - defint2(f2/f3,f4,x),
  defint2(-~b,~f1,~f2,~x) => -b*defint2(f1,f2,x) when freeof(b,x)

};

let defint2_rules;
>>;
endmodule;
end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/0000755000175000017500000000000011722677364022040 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taydiff.red0000644000175000017500000001160411526203062024142 0ustar  giovannigiovannimodule TayDiff;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%        Differentiation of Taylor kernels
%
%*****************************************************************


exports difftaylorwrttayvar;

imports

% from the REDUCE kernel:
        !*k2q, !*n2f, depends, diffsq, lastpair, ldepends, multsq, negsq,
        nth, over,

% from the header module:
        !*tay2q, !*TayExp2q, make!-cst!-coefflis, make!-Taylor!*,
        TayCfPl, TayCfSq, TayCoeffList, TayFlags, Taylor!:,
        TayMakeCoeff, TayOrig, TayTemplate, TayTpElNext, TayTpElOrder,
        TayTpElPoint, TayTpElVars, TayVars,

% from module Tayintro:
        replace!-nth, replace!-nth!-nth, var!-is!-nth,

% from module Taybasic:
        addtaylor, multtaylor, multtaylorsq,

% from module Taysimp:
        expttayi;


fluid '(!*taylorkeeporiginal);

put ('taylor!*, 'dfform, 'taydiffp);

symbolic procedure taydiffp(u,v,n);
  %
  % differentiates u**n w.r.t. v, u is a Taylor kernel
  % value is a standard quotient
  %
  !*tay2q
    ((if n=1 then uv
       else multtaylor(multtaylorsq(expttayi(u,n - 1),!*n2f n ./ 1),uv))
      where uv := difftaylor(u,v));

symbolic procedure difftaylor (u,kernel);
  begin scalar d;
    d := if not ldepends(TayVars u,kernel)
           then make!-Taylor!*(
                  for each cc in TayCoeffList u collect
                    TayMakeCoeff(TayCfPl cc,
                                 diffsq(TayCfSq cc,kernel)),
                    TayTemplate u,
                    if !*taylorkeeporiginal and TayOrig u
                      then diffsq(TayOrig u,kernel)
                     else nil,
                    TayFlags u)
          else difftaylorwrttayvar(u,kernel);
    for each el in TayTemplate u do
      if depends(TayTpElPoint el,kernel)
        then begin scalar f;
               f := negsq diffsq(!*k2q TayTpElPoint el,kernel);
               for each var in TayTpElVars el do
                 d := addtaylor(d,
                        multtaylorsq(difftaylorwrttayvar(u,var),f));
             end;
    return d;
  end;

symbolic procedure difftaylorwrttayvar(u,kernel);
  %
  % kernel is one of the Taylor variables
  % differentiates Taylor kernel u wrt kernel
  %
  Taylor!:
  begin scalar v,w,w1; integer n,m;
    v := TayTemplate u;
    w := var!-is!-nth(v,kernel);
    n := car w;
    m := cdr w;
    w := for each x in TayCoeffList u join <<
           w := nth(TayCfPl x,n);
           w1 := nth(w,m);
           if w1 = 0 then nil
            else list
              if TayTpElPoint nth(v,n) eq 'infinity
                then TayMakeCoeff(
                        replace!-nth!-nth(TayCfPl x,n,m,w1 + 1),
                        multsq(TayCfSq x,!*TayExp2q (-w1)))
               else TayMakeCoeff(
                        replace!-nth!-nth(TayCfPl x,n,m,w1 - 1),
                        multsq (TayCfSq x,!*TayExp2q w1))>>;
    return
      make!-Taylor!*(
            if null w
              then make!-cst!-coefflis(nil ./ 1,v)
             else w,
            replace!-nth (v,n,
                          ({TayTpElVars w1,
                            TayTpElPoint w1,
                            if TayTpElPoint w1 eq 'infinity
                              then TayTpElOrder w1 + 1
                             else TayTpElOrder w1 - 1,
                            if TayTpElPoint w1 eq 'infinity
                              then TayTpElNext w1 + 1
                             else TayTpElNext w1 - 1}
                              where w1 := nth(v,n))),
            if !*taylorkeeporiginal and TayOrig u
              then diffsq(TayOrig u,kernel)
             else nil,
            TayFlags u)
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayexpnd.red0000644000175000017500000005726311526203062024363 0ustar  giovannigiovannimodule tayexpnd;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%          The Taylor expansion machinery
%
%*****************************************************************


exports taylorexpand;

imports

% from the REDUCE kernel:
        !*k2q, !*p2q, .*, .+, ./, aeval, addsq, apply1, denr,
        dependsl, dfn_prop, diffsq, domainp, eqcar, error1, errorp,
        errorset!*, exptsq, kernp, lastpair, lc, let, lpow, lprim,
        mk!*sq, mkquote, mksq, multsq, mvar, nconc!*, neq, nlist, nth,
        numr, operator, prepsq, quotsq, red, rederr, setcar, sfp,
        simp!*, subsq, subtrsq,

% from the header module:
        !*tay2q, cst!-Taylor!*, has!-Taylor!*, make!-cst!-coefficient,
        make!-Taylor!*, prune!-coefflist, set!-TayOrig, TayCfPl,
        TayCfSq, TayCoeffList, TayFlags, Taylor!*p,
        Taylor!-kernel!-sq!-p, Taylor!-trace, Taylor!-trace!-mprint,
        Taylor!:, TayMakeCoeff, TayOrig, TayTemplate, TayTpElNext,
        TayTpElOrder, TayTpElPoint, TayTpElVars, TayTpVars, TayVars,

% from module TayBasic:
        addtaylor!*, multtaylor, multtaylor!*, quottaylor!-as!-sq,

% from module TayConv:
        prepTaylor!*,

% from module TayFns:
        inttaylorwrttayvar, taycoefflist!-union,

% from module TayInterf:
        taylor1,

% from module TayIntro:
        nzerolist, replace!-nth, smemberlp, Taylor!-error,
        Taylor!-error!*, var!-is!-nth,

% from module TaySimp:
        expttayrat, taysimpsq, taysimpsq!*,

% from module TayUtils:
        add!.comp!.tp!., addto!-all!-taytpelorders, enter!-sorted,
        mult!.comp!.tp!., subtr!-tp!-order, tayminpowerlist,
        taytp!-min2, tp!-greaterp, truncate!-Taylor!*;


fluid '(!*backtrace
        !*taylor!-assoc!-list!*
        !*tayexpanding!*
        !*taylorkeeporiginal
        !*taylornocache
        !*tayrestart!*
        !*trtaylor);

global '(!*sqvar!* erfg!*);

symbolic smacro procedure !*tay2q!* u;
   ((u . 1) .* 1 .+ nil) ./ 1;


switch taylornocache;

symbolic procedure init!-taylor!-cache;
   !*taylor!-assoc!-list!* := nil . !*sqvar!*;

put('taylornocache,'simpfg,'((t (init!-taylor!-cache))));

symbolic init!-taylor!-cache();

symbolic procedure taylor!-add!-to!-cache(krnl,tp,result);
   if null !*taylornocache
     then car !*taylor!-assoc!-list!* :=
                        ({krnl,sublis({nil . nil},tp)} . result) .
                           car !*taylor!-assoc!-list!*;

fluid '(!*taylor!-max!-precision!-cycles!*);

symbolic(!*taylor!-max!-precision!-cycles!* := 5);

symbolic procedure taylorexpand(sq,tp);
   begin scalar result,oldklist,!*tayexpanding!*,!*tayrestart!*,ll;
         integer cycles;
      ll := tp;
      oldklist := get('taylor!*,'klist);
      !*tayexpanding!* := t;
    restart:
      !*tayrestart!* := nil;
      result := errorset!*({'taylorexpand1,mkquote sq,mkquote ll,'t},
                           !*trtaylor);
      put('taylor!*,'klist,oldklist);
      if null errorp result
        then <0 and Taylor!-kernel!-sq!-p result
                 then result := !*tay2q
                                  truncate!-Taylor!*(
                                   mvar numr result,tp);
               return result>>;
      if null !*tayrestart!* then error1();
      erfg!* := nil;
      Taylor!-trace {"Failed with template",ll};
      cycles := cycles + 1;
      if cycles > !*taylor!-max!-precision!-cycles!*
         then Taylor!-error('max_cycles,cycles - 1);
      ll := addto!-all!-TayTpElOrders(ll,nlist(2,length ll));
      Taylor!-trace {"Restarting with template",ll};
      goto restart
   end;


symbolic procedure taylorexpand1(sq,ll,flg);
   %
   % sq is a s.q. that is expanded according to the list ll
   %  which has the form
   %  ((var_1 var0_1 deg1) (var_2 var0_2 deg_2) ...)
   % flg if true indicates that the expansion order should be
   %  automatically increased if the result has insufficient order.
   %
   begin scalar oldresult,result,lll,lmin,dorestart,nl; integer count;
     lll := ll;
     if null cadr !*taylor!-assoc!-list!*
       then !*taylor!-assoc!-list!* := nil . !*sqvar!*;
    restart:
     count := count + 1;
     if count > !*taylor!-max!-precision!-cycles!*
        or oldresult and TayTemplate oldresult = TayTemplate result
       then Taylor!-error('max_cycles,count - 1);
     oldresult := result;
     if denr sq = 1
       then result := taysimpsq!* taylorexpand!-sf(numr sq,lll,t)
%      else if not dependsl(denr sq,TayTpVars lll) then begin scalar nn;
%         nn := taylorexpand!-sf(numr sq,lll,t);
%         if Taylor!-kernel!-sq!-p nn
%           then result := !*tay2q multtaylorsq(
%                             truncate!-Taylor!*(mvar numr nn,lll),
%                             1 ./ denr sq)
%          else result := taysimpsq!* quotsq(nn,1 ./ denr sq)
%        end
%      else if numr sq = 1 then begin scalar dd;
%         dd := taylorexpand!-sf(denr sq,lll,nil);
%         if null numr dd
%           then Taylor!-error!*('zero!-denom,'taylorexpand)
%          else if Taylor!-kernel!-sq!-p dd
%           then if Taylor!*!-zerop mvar numr dd
%                  then <>
%                 else result := !*tay2q invtaylor mvar numr dd
%          else result := taysimpsq!* invsq dd
%        end
%      else if not dependsl(numr sq,TayTpVars lll) then begin scalar dd;
%         dd := taylorexpand!-sf(denr sq,lll,nil);
%         if null numr dd
%           then Taylor!-error!*('zero!-denom,'taylorexpand)
%          else if Taylor!-kernel!-sq!-p dd
%           then if Taylor!*!-zerop mvar numr dd
%                  then <>
%          else result := !*tay2q multtaylorsq(
%                                     truncate!-Taylor!*(
%                                       invtaylor mvar numr dd,
%                                       lll),
%                                   numr sq ./ 1)
%          else result := taysimpsq!* quotsq(numr sq ./ 1,dd)
%        end
      else begin scalar nn,dd;
         dd := taylorexpand!-sf(denr sq,lll,nil);
         if null numr dd
           then Taylor!-error!*('zero!-denom,'taylorexpand)
          else if not Taylor!-kernel!-sq!-p dd
           then return
              result := taysimpsq!*
                          quotsq(taylorexpand!-sf(numr sq,lll,t),dd);
         lmin := prune!-coefflist TayCoeffList mvar numr dd;
         if null lmin then Taylor!-error!*('zero!-denom,'taylorexpand);
         lmin := tayminpowerlist lmin;
         nn := taylorexpand!-sf(
                 numr sq,
                 addto!-all!-TayTpElOrders(lll,lmin),t);
         if not (Taylor!-kernel!-sq!-p nn and Taylor!-kernel!-sq!-p dd)
           then result := taysimpsq!* quotsq(nn,dd)
          else result := quottaylor!-as!-sq(nn,dd);
       end;
     if not Taylor!-kernel!-sq!-p result
       then return if not smemberlp(TayTpVars ll,result)
                     then !*tay2q cst!-Taylor!*(result,ll)
                    else result;
     result := mvar numr result;
     dorestart := nil;
      Taylor!:
        begin scalar ll1;
          ll1 := TayTemplate result;
          for i := (length ll1 - length ll) step -1 until 1 do
            ll := nth(ll1,i) . ll;
          if flg then <0 then dorestart := t>>
         end;
     if dorestart
%     if tp!-greaterp(ll,TayTemplate result)
       then <>
        else Taylor!:
             <0
                         then <>
                        else 0;
               if dorestart
                 then <>
     else if sfp krnl then sk := taylorexpand!-sf(krnl,ll,flg)
     else if (sk := assoc({sp,ll},car !*taylor!-assoc!-list!*))
      then <>
     else if not(pow=1) and
             (sk := assoc({krnl . 1,ll},car !*taylor!-assoc!-list!*))
      then sk := cdr sk
     else <>;
                    if has!-Taylor!* args
                      then res := apply1(fn,car krnl . args)
                     else if null flg
                      then res :=
                             !*tay2q!* cst!-Taylor!*(mksq(krnl,1),ll)
                     else res := mksq(krnl,1);
                    return res
                  end;
            if Taylor!-kernel!-sq!-p sk
              then taylor!-add!-to!-cache(
                     krnl . 1,TayTemplate mvar numr sk,sk)>>;
    if not(pow = 1)
      then <>;
             if Taylor!-kernel!-sq!-p sk
               then taylor!-add!-to!-cache(
                      sp,TayTemplate mvar numr sk,sk)>>;
    Taylor!-trace "result of expanding s.p. is";
    Taylor!-trace!-mprint mk!*sq sk;
    return sk
  end;

symbolic procedure make!-pow!-Taylor!*(krnl,pow,ll);
  Taylor!:
   begin scalar pos,var0,nxt,ordr,x; integer pos1;
     pos := var!-is!-nth(ll,krnl);
     pos1 := cdr pos;
     pos := car pos;
     var0 := TayTpElPoint nth(ll,pos);
     ordr := TayTpElOrder nth(ll,pos);
     nxt := TayTpElNext nth(ll,pos);
%     if ordr < pow
%       then
             ll := replace!-nth(ll,pos,
                               ({TayTpElVars tpel,
                                 TayTpElPoint tpel,
                                 max2(pow,ordr),max2(pow,ordr)+nxt-ordr}
                                 where tpel := nth(ll,pos)));
%     if ordr < 1 then return
%        make!-Taylor!*(nil,replace!-nth(ll,pos,
%                                        ({TayTpElVars tpel,
%                                         TayTpElPoint tpel,
%                                         TayTpElOrder tpel,
%                                         1}
%                                         where tpel := nth(ll,pos))),
%                       nil,nil)
%     else
      if var0 = 0 or var0 eq 'infinity
        then return make!-Taylor!*(
               {make!-var!-coefflist(ll,pos,pos1,pow,
                                     var0 eq 'infinity)},
               ll,
               if !*taylorkeeporiginal then mksq(krnl,pow),
               nil);
      x := make!-Taylor!*(
               {make!-cst!-coefficient(simp!* var0,ll),
                make!-var!-coefflist(ll,pos,pos1,1,nil)},
               ll,
               nil,
               nil);
      if not (pow=1) then x := expttayrat(x,pow ./ 1);
      if !*taylorkeeporiginal then set!-TayOrig(x,mksq(krnl,pow));
      return x
   end;

symbolic procedure make!-var!-coefflist(tp,pos,pos1,pow,infflg);
   TayMakeCoeff(make!-var!-powerlist(tp,pos,pos1,pow,infflg),1 ./ 1);

symbolic procedure make!-var!-powerlist(tp,pos,pos1,pow,infflg);
   if null tp then nil
    else ((if pos=1
             then for j := 1:l collect
                    if j neq pos1 then 0
                     else if infflg then -pow
                     else pow
            else nzerolist l)
          where l := length TayTpElVars car tp)
          . make!-var!-powerlist(cdr tp,pos - 1,pos1,pow,infflg);


symbolic procedure taylorexpand!-taylor(tkrnl,ll,flg);
   begin scalar tay,notay,x;
     notay := nil ./ 1;
     for each cc in TayCoeffList tkrnl do <<
%       x := taylorexpand1(TayCfSq cc,ll,t);
       x := taylorexpand1(TayCfSq cc,ll,flg);
       if Taylor!-kernel!-sq!-p x
         then tay := nconc(tay,
                           for each cc2 in TayCoefflist mvar numr x
                             collect TayMakeCoeff(
                                       append(TayCfPl cc,TayCfPl cc2),
                                       TayCfSq cc2))
        else Taylor!-error('expansion,"(possbile singularity)")>>;
              %notay := aconc!*(notay,cc)>>;
     return
       if null tay then nil ./ 1
        else !*tay2q!* make!-Taylor!*(tay,
                                      append(TayTemplate tkrnl,ll),
                                      nil,nil);
  end;


comment The cache maintained in !*!*taylorexpand!-diff!-cache!*!* is
        the key to handle the case of a kernel whose derivative
        involves the kernel itself. It is guaranteed that in every
        recursive step the expansion order is smaller than in the
        previous one;

fluid '(!*!*taylorexpand!-diff!-cache!*!*);

symbolic procedure taylorexpand!-diff(krnl,ll,flg);
  begin scalar result;
    %
    % We use a very simple strategy: if we know a partial derivative
    %  of the kernel, we pass the problem to taylorexpand!-diff1 which
    %  will try to differentiate the kernel, expand the result and
    %  integrate again.
    %
    % NOTE: THE FOLLOWING test can be removed, but needs more checking
    %        removing it seems to slow down processing
    %
    if null atom krnl and get(car krnl,dfn_prop krnl)
      then
        (result := errorset!*({'taylorexpand!-diff1,
                                 mkquote krnl,mkquote ll,mkquote flg},
                                !*backtrace)
           where !*!*taylorexpand!-diff!-cache!*!* :=
                   !*!*taylorexpand!-diff!-cache!*!*);
    %
    % If this fails we fall back to simple differentiation and
    %  substitution at the expansion point.
    %
    if result and not errorp result
      then result := car result
     else if !*tayrestart!* then error1() % propagate
     else <>;
    if !*taylorkeeporiginal and Taylor!-kernel!-sq!-p result
      then set!-TayOrig(mvar numr result,!*k2q krnl);
    return result
  end;

symbolic procedure taylorexpand!-diff1(krnl,ll,flg);
   <>
       where result := !*k2q krnl,
             y := assoc(krnl,!*!*taylorexpand!-diff!-cache!*!*);

symbolic procedure taylorexpand!-diff2(sq,el,flg);
   begin scalar l,singlist,c0,tay,l0,tp,tcl,sterm;
     singlist := nil ./ 1;
     tp := {el};
     %
     % We check whether there is a rule for taylorsingularity.
     %
     sterm := simp!* {'taylorsingularity,mvar numr sq,
                      'list . TayTpElVars el,TayTpElPoint el};
     if kernp sterm and eqcar(mvar numr sterm,'taylorsingularity)
       then sterm := nil % failed
      else sq := subtrsq(sq,sterm);
     if TayTpElOrder el > 0 then <<
       l := for each var in TayTpElVars el collect begin scalar r;
            r := taylorexpand1(diffsq(sq,var),
                               {{TayTpElVars el,
                                 TayTpElPoint el,
                                 TayTpElOrder el - 1,
                                 TayTpElNext el - 1}},flg);
            if Taylor!-kernel!-sq!-p r
              then return inttaylorwrttayvar(mvar numr r,var)
             else Taylor!-error('expansion,"(possible singularity)");
          end;
       tcl := TayCoeffList!-union
                for each pp in l collect TayCoeffList cdr pp;
       for each pp in l do
         if car pp then singlist := addsq(singlist,car pp);
       if not null numr singlist
         then Taylor!-error('expansion,"(possible singularity)")>>;
     %
     % If we have a special singularity, then set c0 to zero.
     %
     if not null sterm then c0 := nil ./ 1
      else c0 := subsq(sq,for each var in TayTpElVars el collect
                            (var . TayTpElPoint el));
     l0 := {nzerolist length TayTpElVars el};

     if null numr c0 then nil
      else if not Taylor!-kernel!-sq!-p c0
       then tcl := TayMakeCoeff(l0,c0) . tcl
      else <>;

     if not null l
       then for each pp in l do
              tp := TayTp!-min2(tp,TayTemplate cdr pp);

     tay := !*tay2q!* make!-Taylor!*(tcl,tp,
                         if !*taylorkeeporiginal then sq else nil,nil);

     if not null numr singlist then tay := addsq(singlist,tay);

     if null sterm then return tay
      else return taysimpsq!* addsq(taylorexpand(sterm,tp),tay)
  end;

algebraic operator taylorsingularity;

if null get('psi,'simpfn) then algebraic operator psi;

algebraic let {
  taylorsingularity(dilog(~x),~y,~y0) => pi^2/6 - log(x)*log(1-x),
  taylorsingularity(ei(~x),~y,~y0) => log(x) - psi(1)
};

symbolic procedure taylorexpand!-samevar(u,ll,flg);
  Taylor!:
  begin scalar tpl;
    tpl := TayTemplate u;
    for each tpel in ll do begin scalar tp,varlis,mdeg,n; integer pos;
      varlis := TayTpElVars tpel;
      pos := car var!-is!-nth(tpl,car varlis);
      tp := nth(tpl,pos);
      if length varlis > 1 and not (varlis = TayTpElVars tp)
        then Taylor!-error('not!-implemented,
                            "(homogeneous expansion in TAYLORSAMEVAR)");
      n := TayTpElOrder tpel;
      if TayTpElPoint tp neq TayTpElPoint tpel
        then u := taylor1(if not null TayOrig u then TayOrig u
                           else simp!* prepTaylor!* u,
                          varlis,TayTpElPoint tpel,n);
      mdeg := TayTpElOrder tp;
      if n=mdeg then nil
       else if n > mdeg
        %
        % further expansion required
        %
        then if null flg then nil
              else Taylor!-error('expansion,
                                 "Cannot expand further... truncated.")
       else u := make!-Taylor!*(
          for each cc in TayCoeffList u join
            if nth(nth(TayCfPl cc,pos),1) > n
              then nil
             else list cc,
          replace!-nth(tpl,pos,{varlis,TayTpElPoint tpel,n,n+1}),
          TayOrig u,TayFlags u)
     end;
    return !*tay2q!* u
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayprint.red0000644000175000017500000001054711526203062024373 0ustar  giovannigiovannimodule TayPrint;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%     Functions for printing Taylor kernels
%
%*****************************************************************


exports Taylor!*print, Taylor!*print1;

imports

% from the REDUCE kernel:
        denr, eqcar, fmprint, kernp, lastpair, maprint, mvar, numr,
        prepsq, simp!*, smemq, typerr,

% from the header module:
        TayCfSq, TayCoeffList, TayOrig, TayTemplate, TayTpElOrder,
        TayTpElPoint, TayTpElVars,

% from module Tayconv:
        prepTaylor!*, prepTaylor!*1, Taylor!-gen!-big!-O;


fluid '(!*fort !*nat !*taylorprintorder Taylor!-truncation!-flag
        TaylorPrintTerms);

symbolic procedure check!-print!-terms u;
  begin scalar x;
    x := simp!* u;
    if kernp x and mvar numr x eq 'all then return nil
     else if denr x = 1 and fixp numr x then return numr x
     else typerr (x, "value of TaylorPrintTerms")
  end;


symbolic procedure Taylor!*print1 u;
  if smemq('!~,u) or atom TayCoeffList u and not null TayCoeffList u
    then 'Taylor . cdr u
   else begin scalar Taylor!-truncation!-flag, prepexpr, rest, nterms;
    nterms := if !*taylorprintorder
                then check!-print!-terms TaylorPrintTerms
               else nil;
    prepexpr := prepTaylor!*1 (
                  TayCoeffList u,
                  TayTemplate u,
                  nterms);
    if !*taylorprintorder then <<
      rest := {Taylor!-gen!-big!-O TayTemplate u};
      if Taylor!-truncation!-flag then begin integer notprinted;
           notprinted := -nterms;
           for each pp in TayCoeffList u do
             if not null numr TayCfSq pp then
               notprinted := notprinted + 1;
           if notprinted=1 then rest := "(1 term)" . rest
            else rest := compress append('(!" !(),
                           nconc(explode notprinted,
                                 '(!  !t !e !r !m !s !) !"))) . rest
        end
        %%%if prepexpr=0 and null cdr rest then return car rest
        >>
     else rest := {'!.!.!.};
    return if not eqcar (prepexpr, 'plus)
             then 'plus . (prepexpr or 0) . rest
            else nconc (prepexpr, rest)
  end;

comment The following statement is the interface for the XReduce
        fancy printer;

put('Taylor!*,'fancy!-reform,'Taylor!*print1);


symbolic procedure Taylor!*print(u,p);
  if !*fort then fmprint(prepTaylor!* u,0)
   else if null !*nat then maprint(
                     'taylor .
                        (if TayOrig u
                           then prepsq Tayorig u
                          else prepTaylor!* u) .
                        for each el in TayTemplate u join
                          {if null cdr TayTpElVars el
                             then car TayTpElVars el
                            else 'list . TayTpElVars el,
                           TayTpElPoint el,
                           TayTpElOrder el},
                     p)
   else maprint(Taylor!*print1 u,p);

put('Taylor!*,'pprifn,'Taylor!*print);


comment We need another printing function for use with the
        TeX-REDUCE interface; %not yet done;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taylor.tst0000644000175000017500000006160111526203062024070 0ustar  giovannigiovannicomment
        Test and demonstration file for the Taylor expansion package,
        by Rainer M. Schoepf.  Works with version 2.2a (01-Apr-2000);

%%% showtime;

on errcont; % disable interruption on errors

comment Simple Taylor expansion;

xx := taylor (e**x, x, 0, 4);
yy := taylor (e**y, y, 0, 4);

comment Basic operations, i.e. addition, subtraction, multiplication,
        and division are possible: this is not done automatically if
        the switch TAYLORAUTOCOMBINE is OFF.  In this case it is
        necessary to use taylorcombine;

taylorcombine (xx**2);
taylorcombine (ws - xx);
taylorcombine (xx**3);

comment The result is again a Taylor kernel;

if taylorseriesp ws then write "OK";

comment It is not possible to combine Taylor kernels that were
        expanded with respect to different variables;

taylorcombine (xx**yy);

comment But we can take the exponential or the logarithm
        of a Taylor kernel;

taylorcombine (e**xx);
taylorcombine log ws;

comment A more complicated example;

hugo := taylor(log(1/(1-x)),x,0,5);
taylorcombine(exp(hugo/(1+hugo)));

comment We may try to expand about another point;

taylor (xx, x, 1, 2);

comment Arc tangent is one of the functions this package knows of;

xxa := taylorcombine atan ws;

comment The trigonometric functions;

taylor (tan x / x, x, 0, 2);

taylorcombine sin ws;

taylor (cot x / x, x, 0, 4);

comment The poles of these functions are correctly handled;

taylor(tan x,x,pi/2,0);

taylor(tan x,x,pi/2,3);

comment Expansion with respect to more than one kernel is possible;

xy := taylor (e**(x+y), x, 0, 2, y, 0, 2);

taylorcombine (ws**2);

comment We take the inverse and convert back to REDUCE's standard
        representation;

taylorcombine (1/ws);
taylortostandard ws;

comment Some examples of Taylor kernel divsion;

xx1 := taylor (sin (x), x, 0, 4);
taylorcombine (xx/xx1);
taylorcombine (1/xx1);

tt1 := taylor (exp (x), x, 0, 3);
tt2 := taylor (sin (x), x, 0, 3);
tt3 := taylor (1 + tt2, x, 0, 3);
taylorcombine(tt1/tt2);
taylorcombine(tt1/tt3);
taylorcombine(tt2/tt1);
taylorcombine(tt3/tt1);


comment Here's what I call homogeneous expansion;

xx := taylor (e**(x*y), {x,y}, 0, 2);
xx1 := taylor (sin (x+y), {x,y}, 0, 2);
xx2 := taylor (cos (x+y), {x,y}, 0, 2);
temp := taylorcombine (xx/xx2);
taylorcombine (ws*xx2);

comment The following shows a principal difficulty:
        since xx1 is symmetric in x and y but has no constant term
        it is impossible to compute 1/xx1;

taylorcombine (1/xx1);

comment Substitution in Taylor expressions is possible;

sub (x=z, xy);

comment Expression dependency in substitution is detected;

sub (x=y, xy);

comment It is possible to replace a Taylor variable by a constant;

sub (x=4, xy);

sub (x=4, xx1);

sub (y=0, ws);

comment This package has three switches:
        TAYLORKEEPORIGINAL, TAYLORAUTOEXPAND, and TAYLORAUTOCOMBINE;

on taylorkeeporiginal;

temp := taylor (e**(x+y), x, 0, 5);

taylorcombine (log (temp));

taylororiginal ws;

taylorcombine (temp * e**x);

on taylorautoexpand;

taylorcombine ws;

taylororiginal ws;

taylorcombine (xx1 / x);

on taylorautocombine;

xx / xx2;

ws * xx2;

comment Another example that shows truncation if Taylor kernels
        of different expansion order are combined;

comment First we increase the number of terms to be printed;

taylorprintterms := all;

p := taylor (x**2 + 2, x, 0, 10);
p - x**2;
p - taylor (x**2, x, 0, 5);
taylor (p - x**2, x, 0, 6);
off taylorautocombine;
taylorcombine(p-x**2);
taylorcombine(p - taylor(x**2,x,0,5));

comment Switch back to finite number of terms;

taylorprintterms := 6;

comment Some more examples;

taylor(1/(1+y^4+x^2*y^2+x^4),{x,y},0,6);

taylor ((1 + x)**n, x, 0, 3);

taylor (e**(-a*t) * (1 + sin(t)), t, 0, 4);

operator f;

taylor (1 + f(t), t, 0, 3);

taylor(f(sqrt(x^2+y^2)),x,x0,4,y,y0,4);

clear f;

taylor (sqrt(1 + a*x + sin(x)), x, 0, 3);

taylorcombine (ws**2);

taylor (sqrt(1 + x), x, 0, 5);

taylor ((cos(x) - sec(x))^3, x, 0, 5);

taylor ((cos(x) - sec(x))^-3, x, 0, 5);

taylor (sqrt(1 - k^2*sin(x)^2), x, 0, 6);

taylor (sin(x + y), x, 0, 3, y, 0, 3);

taylor (e^x - 1 - x,x,0,6);

taylorcombine sqrt ws;

taylor(sin(x)/x,x,1,2);

taylor((sqrt(4+h)-2)/h,h,0,5);

taylor((sqrt(x)-2)/(4-x),x,4,2);

taylor((sqrt(y+4)-2)/(-y),y,0,2);

taylor(x*tanh(x)/(sqrt(1-x^2)-1),x,0,3);

taylor((e^(5*x)-2*x)^(1/x),x,0,2);

taylor(sin x/cos x,x,pi/2,3);

taylor(log x*sin(x^2)/(x*sinh x),x,0,2);

taylor(1/x-1/sin x,x,0,2);

taylor(tan x/log cos x,x,pi/2,2);

taylor(log(x^2/(x^2-a)),x,0,3);


comment Three more complicated examples contributed by Stan Kameny;

zz2 := (z*(z-2*pi*i)*(z-pi*i/2)^2)/(sinh z-i);
dz2 := df(zz2,z);
z0 := pi*i/2;
taylor(dz2,z,z0,6);

zz3:=(z*(z-2*pi)*(z-pi/2)^2)/(sin z-1);
dz3 := df(zz3,z);
z1 := pi/2;
taylor(dz3,z,z1,6);

taylor((sin tan x-tan sin x)/(asin atan x-atan asin x),x,0,6);


comment If the expansion point is not constant, it has to be taken
        care of in differentation, as the following examples show;

taylor(sin(x+a),x,a,8);
df(ws,a);
taylor(cos(x+a),x,a,7);


comment A problem are non-analytical terms: rational powers and
        logarithmic terms can be handled, but other types of essential
        singularities cannot;

taylor(sqrt(x),x,0,2);

taylor(asinh(1/x),x,0,5);

taylor(e**(1/x),x,0,2);

comment Another example for non-integer powers;

sub (y = sqrt (x), yy);

comment Expansion about infinity is possible in principle...;

taylor (e**(1/x), x, infinity, 5);
xi := taylor (sin (1/x), x, infinity, 5);

y1 := taylor(x/(x-1), x, infinity, 3);
z := df(y1, x);

comment ...but far from being perfect;

taylor (1 / sin (x), x, infinity, 5);

clear z;

comment You may access the expansion with the PART operator;

part(yy,0);
part(yy,1);
part(yy,4);
part(yy,6);


comment The template of a Taylor kernel can be extracted;

taylortemplate yy;

taylortemplate xxa;

taylortemplate xi;

taylortemplate xy;

taylortemplate xx1;

comment Here is a slightly less trivial example;

exp := (sin (x) * sin (y) / (x * y))**2;

taylor (exp, x, 0, 1, y, 0, 1);
taylor (exp, x, 0, 2, y, 0, 2);

tt := taylor (exp, {x,y}, 0, 2);

comment An example that uses factorization;

on factor;

ff := y**5 - 1;

zz := sub (y = taylor(e**x, x, 0, 3), ff);

on exp;

zz;

comment A simple example of Taylor kernel differentiation;

hugo := taylor(e^x,x,0,5);
df(hugo^2,x);

comment The following shows the (limited) capabilities to integrate
        Taylor kernels. Only simple cases are supported, otherwise
        a warning is printed and the Taylor kernels are converted to
        standard representation;

zz := taylor (sin x, x, 0, 5);
ww := taylor (cos y, y, 0, 5);

int (zz, x);
int (ww, x);
int (zz + ww, x);


comment And here we present Taylor series reversion.
        We start with the example given by Knuth for the algorithm;

taylor (t - t**2, t, 0, 5);

taylorrevert (ws, t, x);

tan!-series := taylor (tan x, x, 0, 5);
taylorrevert (tan!-series, x, y);
atan!-series:=taylor (atan y, y, 0, 5);

tmp := taylor (e**x, x, 0, 5);

taylorrevert (tmp, x, y);

taylor (log y, y, 1, 5);


comment The following example calculates the perturbation expansion
        of the root x = 20 of the following polynomial in terms of
        EPS, in ROUNDED mode;

poly := for r := 1 : 20 product (x - r);

on rounded;

tpoly := taylor (poly, x, 20, 4);

taylorrevert (tpoly, x, eps);

comment Some more examples using rounded mode;

taylor(sin x/x,x,0,4);

taylor(sin x,x,pi/2,4);

taylor(tan x,x,pi/2,4);

off rounded;


comment An example that involves computing limits of type 0/0 if
        expansion is done via differentiation;


taylor(sqrt((e^x - 1)/x),x,0,15);

comment An example that involves intermediate non-analytical terms
        which cancel entirely;

taylor(x^(5/2)/(log(x+1)*tan(x^(3/2))),x,0,5);

comment Other examples involving non-analytical terms;

taylor(log(e^x-1),x,0,5);

taylor(e^(1/x)*(e^x-1),x,0,5);

taylor(log(x)*x^10,x,0,5);

taylor(log(x)*x^10,x,0,11);

taylor(log(x-a)/((a-b)*(a-c)) + log(2(x-b))/((b-c)*(b-a))
     + log(x-c)/((c-a)*(c-b)),x,infinity,2);

ss := (sqrt(x^(2/5) +1) - x^(1/3)-1)/x^(1/3);
taylor(exp ss,x,0,2);

taylor(exp sub(x=x^15,ss),x,0,2);

taylor(dilog(x),x,0,4);

taylor(ei(x),x,0,4);

comment In the following we demonstrate the possibiblity to compute the
        expansion of a function which is given by a simple first order
        differential equation: the function myexp(x) is exp(-x^2);

operator myexp,myerf;
let {df(myexp(~x),~x) => -2*x*myexp(x), myexp(0) => 1,
     df(myerf(~x),~x) => 2/sqrt(pi)*myexp(x), myerf(0) => 0};
taylor(myexp(x),x,0,5);
taylor(myerf(x),x,0,5);
clear {df(myexp(~x),~x) => -2*x*myexp(x), myexp(0) => 1,
       df(myerf(~x),~x) => 2/sqrt(pi)*myexp(x), myerf(0) => 0};
clear myexp,erf;

%%% showtime;

comment There are two special operators, implicit_taylor and
        inverse_taylor, to compute the Taylor expansion of implicit
        or inverse functions;


implicit_taylor(x^2 + y^2 - 1,x,y,0,1,5);

implicit_taylor(x^2 + y^2 - 1,x,y,0,1,20);

implicit_taylor(x+y^3-y,x,y,0,0,8);

implicit_taylor(x+y^3-y,x,y,0,1,5);

implicit_taylor(x+y^3-y,x,y,0,-1,5);

implicit_taylor(y*e^y-x,x,y,0,0,5);

comment This is the function exp(-1/x^2), which has an essential
        singularity at the point 0;

implicit_taylor(x^2*log y+1,x,y,0,0,3);

inverse_taylor(exp(x)-1,x,y,0,8);

inverse_taylor(exp(x),x,y,0,5);

inverse_taylor(sqrt(x),x,y,0,5);

inverse_taylor(log(1+x),x,y,0,5);

inverse_taylor((e^x-e^(-x))/2,x,y,0,5);

comment In the next two cases the inverse functions have a branch
        point, therefore the computation fails;

inverse_taylor((e^x+e^(-x))/2,x,y,0,5);

inverse_taylor(exp(x^2-1),x,y,0,5);

inverse_taylor(exp(sqrt(x))-1,x,y,0,5);

inverse_taylor(x*exp(x),x,y,0,5);


%%% showtime;


comment An application is the problem posed by Prof. Stanley:
        we prove that the finite difference expression below
        corresponds to the given derivative expression;

operator diff,a,f,gg;  % We use gg to avoid conflict with high energy
                       % physics operator.

let diff(~f,~arg) => df(f,arg);

derivative_expression :=
diff(a(x,y)*diff(gg(x,y),x)*diff(gg(x,y),y)*diff(f(x,y),y),x) +
diff(a(x,y)*diff(gg(x,y),x)*diff(gg(x,y),y)*diff(f(x,y),x),y) ;

finite_difference_expression :=
+a(x+dx,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x+dx,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x+dx,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x+dx,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x+dx,y)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*gg(x+dx,y)*a(x+dx,y+dy)*f(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x+dx,y)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*a(x+dx,y)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y+dy)*gg(x,y+dy)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y+dy)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x+dx,y)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y)*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x,y+dy)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y+dy)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x+dx,y)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*gg(x+dx,y)*a(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
+a(x+dx,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x+dx,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x+dx,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x+dx,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x+dx,y)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*gg(x+dx,y)*a(x+dx,y-dy)*f(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x+dx,y)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*a(x+dx,y)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y-dy)*gg(x,y-dy)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y-dy)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x+dx,y)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y)*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x,y-dy)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y-dy)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x+dx,y)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*gg(x+dx,y)*a(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*a(x+dx,y)*gg(x+dx,y)^2/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x+dx,y)^2/(32*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x+dx,y)^2/(32*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x+dx,y)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*a(x+dx,y)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*a(x+dx,y)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x,y+dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y+dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x,y-dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y-dy)*gg(x+dx,y)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x+dx,y)/(32*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x+dx,y)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y)/(16*dx^2*dy^2)
+a(x-dx,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x-dx,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x-dx,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x-dx,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x-dx,y)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*gg(x-dx,y)*a(x-dx,y+dy)*f(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x-dx,y)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*a(x-dx,y)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y+dy)*gg(x,y+dy)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y+dy)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x-dx,y)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y)*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x,y+dy)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y+dy)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x-dx,y)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*gg(x-dx,y)*a(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
+a(x-dx,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x-dx,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x-dx,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x-dx,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x-dx,y)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*gg(x-dx,y)*a(x-dx,y-dy)*f(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x-dx,y)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*a(x-dx,y)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y-dy)*gg(x,y-dy)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y-dy)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x-dx,y)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y)*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x,y-dy)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y-dy)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x-dx,y)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*gg(x-dx,y)*a(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*a(x-dx,y)*gg(x-dx,y)^2/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x-dx,y)^2/(32*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x-dx,y)^2/(32*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x-dx,y)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*a(x-dx,y)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*a(x-dx,y)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x,y+dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y+dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x,y-dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y-dy)*gg(x-dx,y)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x-dx,y)/(32*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x-dx,y)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y)/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x,y+dy)^2/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y+dy)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x,y+dy)/(16*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x,y-dy)^2/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y-dy)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x,y-dy)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y)^2/(8*dx^2*dy^2)$

comment We define abbreviations for the partial derivatives;

operator ax,ay,fx,fy,gx,gy;
operator axx,axy,ayy,fxx,fxy,fyy,gxx,gxy,gyy;
operator axxx,axxy,axyy,ayyy,fxxx,fxxy,fxyy,fyyy,gxxx,gxxy,gxyy,gyyy;
operator axxxy,axxyy,axyyy,fxxxy,fxxyy,fxyyy,
         gxxxx,gxxxy,gxxyy,gxyyy,gyyyy;
operator axxxyy,axxyyy,fxxyyy,fxxxyy,gxxxxy,gxxxyy,gxxyyy,gxyyyy;
operator gxxxxyy,gxxxyyy,gxxyyyy;

operator_diff_rules := {
  df(a(~x,~y),~x) => ax(x,y),
  df(a(~x,~y),~y) => ay(x,y),
  df(f(~x,~y),~x) => fx(x,y),
  df(f(~x,~y),~y) => fy(x,y),
  df(gg(~x,~y),~x) => gx(x,y),
  df(gg(~x,~y),~y) => gy(x,y),

  df(ax(~x,~y),~x) => axx(x,y),
  df(ax(~x,~y),~y) => axy(x,y),
  df(ay(~x,~y),~x) => axy(x,y),
  df(ay(~x,~y),~y) => ayy(x,y),
  df(fx(~x,~y),~x) => fxx(x,y),
  df(fx(~x,~y),~y) => fxy(x,y),
  df(fy(~x,~y),~x) => fxy(x,y),
  df(fy(~x,~y),~y) => fyy(x,y),
  df(gx(~x,~y),~x) => gxx(x,y),
  df(gx(~x,~y),~y) => gxy(x,y),
  df(gy(~x,~y),~x) => gxy(x,y),
  df(gy(~x,~y),~y) => gyy(x,y),

  df(axx(~x,~y),~x) => axxx(x,y),
  df(axy(~x,~y),~x) => axxy(x,y),
  df(ayy(~x,~y),~x) => axyy(x,y),
  df(ayy(~x,~y),~y) => ayyy(x,y),
  df(fxx(~x,~y),~x) => fxxx(x,y),
  df(fxy(~x,~y),~x) => fxxy(x,y),
  df(fxy(~x,~y),~y) => fxyy(x,y),
  df(fyy(~x,~y),~x) => fxyy(x,y),
  df(fyy(~x,~y),~y) => fyyy(x,y),
  df(gxx(~x,~y),~x) => gxxx(x,y),
  df(gxx(~x,~y),~y) => gxxy(x,y),
  df(gxy(~x,~y),~x) => gxxy(x,y),
  df(gxy(~x,~y),~y) => gxyy(x,y),
  df(gyy(~x,~y),~x) => gxyy(x,y),
  df(gyy(~x,~y),~y) => gyyy(x,y),

  df(axyy(~x,~y),~x) => axxyy(x,y),
  df(axxy(~x,~y),~x) => axxxy(x,y),
  df(ayyy(~x,~y),~x) => axyyy(x,y),
  df(fxxy(~x,~y),~x) => fxxxy(x,y),
  df(fxyy(~x,~y),~x) => fxxyy(x,y),
  df(fyyy(~x,~y),~x) => fxyyy(x,y),
  df(gxxx(~x,~y),~x) => gxxxx(x,y),
  df(gxxy(~x,~y),~x) => gxxxy(x,y),
  df(gxyy(~x,~y),~x) => gxxyy(x,y),
  df(gyyy(~x,~y),~x) => gxyyy(x,y),
  df(gyyy(~x,~y),~y) => gyyyy(x,y),

  df(axxyy(~x,~y),~x) => axxxyy(x,y),
  df(axyyy(~x,~y),~x) => axxyyy(x,y),
  df(fxxyy(~x,~y),~x) => fxxxyy(x,y),
  df(fxyyy(~x,~y),~x) => fxxyyy(x,y),
  df(gxxxy(~x,~y),~x) => gxxxxy(x,y),
  df(gxxyy(~x,~y),~x) => gxxxyy(x,y),
  df(gxyyy(~x,~y),~x) => gxxyyy(x,y),
  df(gyyyy(~x,~y),~x) => gxyyyy(x,y),

  df(gxxxyy(~x,~y),~x) => gxxxxyy(x,y),
  df(gxxyyy(~x,~y),~x) => gxxxyyy(x,y),
  df(gxyyyy(~x,~y),~x) => gxxyyyy(x,y)
};

let operator_diff_rules;

texp := taylor (finite_difference_expression, dx, 0, 1, dy, 0, 1);

comment You may also try to expand further but this needs a lot
        of CPU time.  Therefore the following line is commented out;

%texp := taylor (finite_difference_expression, dx, 0, 2, dy, 0, 2);

factor dx,dy;

result := taylortostandard texp;

derivative_expression - result;


clear diff(~f,~arg);
clearrules operator_diff_rules;
clear diff,a,f,gg;
clear ax,ay,fx,fy,gx,gy;
clear axx,axy,ayy,fxx,fxy,fyy,gxx,gxy,gyy;
clear axxx,axxy,axyy,ayyy,fxxx,fxxy,fxyy,fyyy,gxxx,gxxy,gxyy,gyyy;
clear axxxy,axxyy,axyyy,fxxxy,fxxyy,fxyyy,gxxxx,gxxxy,gxxyy,gxyyy,gyyyy;
clear axxxyy,axxyyy,fxxyyy,fxxxyy,gxxxxy,gxxxyy,gxxyyy,gxyyyy;
clear gxxxxyy,gxxxyyy,gxxyyyy;

taylorprintterms := 5;

off taylorautoexpand,taylorkeeporiginal;

%%% showtime;

comment An example provided by Alan Barnes: elliptic functions;

% Jacobi's elliptic functions 
%       sn(x,k),  cn(x,k), dn(x,k).
% The modulus and complementary modulus are denoted by K and K!'
%      usually written mathematically as k and k' respectively
%
% epsilon(x,k) is the incomplete elliptic integral of the second kind
%      usually written mathematically as E(x,k)
%
% KK(k) is the complete elliptic integral of the first kind
%       usually written mathematically as K(k)
%       K(k) = arcsn(1,k)
% KK!'(k) is the complementary complete integral
%      usually written mathematically as K'(k)
%      NB.  K'(k) = K(k')
% EE(k) is the complete elliptic integral of the second kind
%      usually written mathematically as E(k)
% EE!'(k) is the complementary complete integral
%      usually written mathematically as E'(k)
%      NB.  E'(k) = E(k')

operator sn, cn, dn, epsilon;

elliptic_rules := {
% Differentiation rules for basic functions
   df(sn(~x,~k),~x)     => cn(x,k)*dn(x,k),
   df(cn(~x,~k),~x)     => -sn(x,k)*dn(x,k),
   df(dn(~x,~k),~x)     => -k^2*sn(x,k)*cn(x,k),
   df(epsilon(~x,~k),~x)=> dn(x,k)^2,

% k-derivatives
% DF Lawden     Elliptic Functions & Applications    Springer (1989)
   df(sn(~x,~k),~k)  => (k*sn(x,k)*cn(x,k)^2
                         -epsilon(x,k)*cn(x,k)*dn(x,k)/k)/(1-k^2)
                       + x*cn(x,k)*dn(x,k)/k,
   df(cn(~x,~k),~k)  => (-k*sn(x,k)^2*cn(x,k)
                         +epsilon(x,k)*sn(x,k)*dn(x,k)/k)/(1-k^2)
                        - x*sn(x,k)*dn(x,k)/k,
   df(dn(~x,~k),~k)  => k*(-sn(x,k)^2*dn(x,k)
                            +epsilon(x,k)*sn(x,k)*cn(x,k))/(1-k^2)
                          - k*x*sn(x,k)*cn(x,k),
   df(epsilon(~x,~k),~k) => k*(sn(x,k)*cn(x,k)*dn(x,k)
                                -epsilon(x,k)*cn(x,k)^2)/(1-k^2)
                             -k*x*sn(x,k)^2,

% parity properties
   sn(-~x,~k) => -sn(x,k),
   cn(-~x,~k) => cn(x,k),
   dn(-~x,~k) => dn(x,k),
   epsilon(-~x,~k) => -epsilon(x,k),
   sn(~x,-~k) => sn(x,k),
   cn(~x,-~k) => cn(x,k),
   dn(~x,-~k) => dn(x,k),
   epsilon(~x,-~k) => epsilon(x,k),


% behaviour at zero
   sn(0,~k) => 0,
   cn(0,~k) => 1,
   dn(0,~k) => 1,
   epsilon(0,~k) => 0,


% degenerate cases of modulus
   sn(~x,0) => sin(x),
   cn(~x,0) => cos(x),
   dn(~x,0) => 1,
   epsilon(~x,0) => x,

   sn(~x,1) => tanh(x),
   cn(~x,1) => 1/cosh(x),
   dn(~x,1) => 1/cosh(x),
   epsilon(~x,1) => tanh(x)
};

let elliptic_rules;

hugo := taylor(sn(x,k),k,0,6);
otto := taylor(cn(x,k),k,0,6);
taylorcombine(hugo^2 + otto^2);

clearrules elliptic_rules;

clear sn, cn, dn, epsilon;

%%% showtime;

comment That's all, folks;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taylor.rlg0000644000175000017500000016655311527635055024072 0ustar  giovannigiovanniFri Feb 18 21:28:37 2011 run on win32
comment
        Test and demonstration file for the Taylor expansion package,
        by Rainer M. Schoepf.  Works with version 2.2a (01-Apr-2000);


%%% showtime;

on errcont;

 % disable interruption on errors

comment Simple Taylor expansion;


xx := taylor (e**x, x, 0, 4);


               1   2    1   3    1    4      5
xx := 1 + x + ---*x  + ---*x  + ----*x  + O(x )
               2        6        24

yy := taylor (e**y, y, 0, 4);


               1   2    1   3    1    4      5
yy := 1 + y + ---*y  + ---*y  + ----*y  + O(y )
               2        6        24


comment Basic operations, i.e. addition, subtraction, multiplication,
        and division are possible: this is not done automatically if
        the switch TAYLORAUTOCOMBINE is OFF.  In this case it is
        necessary to use taylorcombine;


taylorcombine (xx**2);


             2    4   3    2   4      5
1 + 2*x + 2*x  + ---*x  + ---*x  + O(x )
                  3        3

taylorcombine (ws - xx);


     3   2    7   3    5   4      5
x + ---*x  + ---*x  + ---*x  + O(x )
     2        6        8

taylorcombine (xx**3);


           9   2    9   3    27   4      5
1 + 3*x + ---*x  + ---*x  + ----*x  + O(x )
           2        2        8


comment The result is again a Taylor kernel;


if taylorseriesp ws then write "OK";


OK


comment It is not possible to combine Taylor kernels that were
        expanded with respect to different variables;


taylorcombine (xx**yy);


          1   2    1   3    1    4      5
(1 + x + ---*x  + ---*x  + ----*x  + O(x ))
          2        6        24

            1   2    1   3    1    4      5
**(1 + y + ---*y  + ---*y  + ----*y  + O(y ))
            2        6        24


comment But we can take the exponential or the logarithm
        of a Taylor kernel;


taylorcombine (e**xx);


             2    5*e   3    5*e   4      5
e + e*x + e*x  + -----*x  + -----*x  + O(x )
                   6          8

taylorcombine log ws;


         1   2    1   3    1    4      5
1 + x + ---*x  + ---*x  + ----*x  + O(x )
         2        6        24


comment A more complicated example;


hugo := taylor(log(1/(1-x)),x,0,5);


             1   2    1   3    1   4    1   5      6
hugo := x + ---*x  + ---*x  + ---*x  + ---*x  + O(x )
             2        3        4        5

taylorcombine(exp(hugo/(1+hugo)));


         1    4      6
1 + x + ----*x  + O(x )
         12


comment We may try to expand about another point;


taylor (xx, x, 1, 2);


 65     8             5         2            3
---- + ---*(x - 1) + ---*(x - 1)  + O((x - 1) )
 24     3             4


comment Arc tangent is one of the functions this package knows of;


xxa := taylorcombine atan ws;


             65      1536             2933040          2            3
xxa := atan(----) + ------*(x - 1) - ----------*(x - 1)  + O((x - 1) )
             24      4801             23049601


comment The trigonometric functions;


taylor (tan x / x, x, 0, 2);


     1   2      3
1 + ---*x  + O(x )
     3


taylorcombine sin ws;


          cos(1)   2      3
sin(1) + --------*x  + O(x )
            3


taylor (cot x / x, x, 0, 4);


 -2    1     1    2     2    4      5
x   - --- - ----*x  - -----*x  + O(x )
       3     45        945


comment The poles of these functions are correctly handled;


taylor(tan x,x,pi/2,0);


         pi  -1          pi
 - (x - ----)   + O(x - ----)
         2               2


taylor(tan x,x,pi/2,3);


         pi  -1    1        pi      1         pi  3           pi  4
 - (x - ----)   + ---*(x - ----) + ----*(x - ----)  + O((x - ----) )
         2         3        2       45        2               2


comment Expansion with respect to more than one kernel is possible;


xy := taylor (e**(x+y), x, 0, 2, y, 0, 2);


               1   2                            3  3
xy := 1 + y + ---*y  + x + y*x + (4 terms) + O(x ,y )
               2


taylorcombine (ws**2);


             2                                3  3
1 + 2*y + 2*y  + 2*x + 4*y*x + (4 terms) + O(x ,y )


comment We take the inverse and convert back to REDUCE's standard
        representation;


taylorcombine (1/ws);


             2                                3  3
1 - 2*x + 2*x  - 2*y + 4*y*x + (4 terms) + O(x ,y )

taylortostandard ws;


   2  2      2        2        2                    2
4*x *y  - 4*x *y + 2*x  - 4*x*y  + 4*x*y - 2*x + 2*y  - 2*y + 1


comment Some examples of Taylor kernel divsion;


xx1 := taylor (sin (x), x, 0, 4);


            1   3      5
xx1 := x - ---*x  + O(x )
            6

taylorcombine (xx/xx1);


 -1        2       1   2      3
x   + 1 + ---*x + ---*x  + O(x )
           3       3

taylorcombine (1/xx1);


 -1    1         3
x   + ---*x + O(x )
       6


tt1 := taylor (exp (x), x, 0, 3);


                1   2    1   3      4
tt1 := 1 + x + ---*x  + ---*x  + O(x )
                2        6

tt2 := taylor (sin (x), x, 0, 3);


            1   3      4
tt2 := x - ---*x  + O(x )
            6

tt3 := taylor (1 + tt2, x, 0, 3);


                1   3      4
tt3 := 1 + x - ---*x  + O(x )
                6

taylorcombine(tt1/tt2);


 -1        2         2
x   + 1 + ---*x + O(x )
           3

taylorcombine(tt1/tt3);


     1   2    1   3      4
1 + ---*x  - ---*x  + O(x )
     2        6

taylorcombine(tt2/tt1);


     2    1   3      4
x - x  + ---*x  + O(x )
          3

taylorcombine(tt3/tt1);


     1   2    1   3      4
1 - ---*x  + ---*x  + O(x )
     2        6



comment Here's what I call homogeneous expansion;


xx := taylor (e**(x*y), {x,y}, 0, 2);


                       3
xx := 1 + y*x + O({x,y} )

xx1 := taylor (sin (x+y), {x,y}, 0, 2);


                      3
xx1 := y + x + O({x,y} )

xx2 := taylor (cos (x+y), {x,y}, 0, 2);


            1   2          1   2          3
xx2 := 1 - ---*y  - y*x - ---*x  + O({x,y} )
            2              2

temp := taylorcombine (xx/xx2);


             1   2            1   2          3
temp := 1 + ---*y  + 2*y*x + ---*x  + O({x,y} )
             2                2

taylorcombine (ws*xx2);


                 3
1 + y*x + O({x,y} )


comment The following shows a principal difficulty:
        since xx1 is symmetric in x and y but has no constant term
        it is impossible to compute 1/xx1;


taylorcombine (1/xx1);


***** Not a unit in argument to invtaylor 


comment Substitution in Taylor expressions is possible;


sub (x=z, xy);


         1   2                            3  3
1 + y + ---*y  + z + y*z + (4 terms) + O(z ,y )
         2


comment Expression dependency in substitution is detected;


sub (x=y, xy);


***** Invalid substitution in Taylor kernel: dependent variables y y 


comment It is possible to replace a Taylor variable by a constant;


sub (x=4, xy);


             13   2      3
13 + 13*y + ----*y  + O(y )
             2


sub (x=4, xx1);


           3
4 + y + O(y )


sub (y=0, ws);


4


comment This package has three switches:
        TAYLORKEEPORIGINAL, TAYLORAUTOEXPAND, and TAYLORAUTOCOMBINE;


on taylorkeeporiginal;



temp := taylor (e**(x+y), x, 0, 5);


                      y         y         y
         y    y      e    2    e    3    e    4                 6
temp := e  + e *x + ----*x  + ----*x  + ----*x  + (1 term) + O(x )
                     2         6         24


taylorcombine (log (temp));


           6
y + x + O(x )


taylororiginal ws;


x + y


taylorcombine (temp * e**x);


                  y         y         y
 x   y    y      e    2    e    3    e    4                 6
e *(e  + e *x + ----*x  + ----*x  + ----*x  + (1 term) + O(x ))
                 2         6         24


on taylorautoexpand;



taylorcombine ws;


                            y           y
 y      y        y  2    4*e    3    2*e    4                 6
e  + 2*e *x + 2*e *x  + ------*x  + ------*x  + (1 term) + O(x )
                          3           3


taylororiginal ws;


 2*x + y
e


taylorcombine (xx1 / x);


   -1              2
y*x   + 1 + O({x,y} )


on taylorautocombine;



xx / xx2;


     1   2            1   2          3
1 + ---*y  + 2*y*x + ---*x  + O({x,y} )
     2                2


ws * xx2;


                 3
1 + y*x + O({x,y} )


comment Another example that shows truncation if Taylor kernels
        of different expansion order are combined;


comment First we increase the number of terms to be printed;


taylorprintterms := all;


taylorprintterms := all


p := taylor (x**2 + 2, x, 0, 10);


          2      11
p := 2 + x  + O(x  )

p - x**2;


      2      11      2
(2 + x  + O(x  )) - x

p - taylor (x**2, x, 0, 5);


       6
2 + O(x )

taylor (p - x**2, x, 0, 6);


       7
2 + O(x )

off taylorautocombine;


taylorcombine(p-x**2);


       11
2 + O(x  )

taylorcombine(p - taylor(x**2,x,0,5));


       6
2 + O(x )


comment Switch back to finite number of terms;


taylorprintterms := 6;


taylorprintterms := 6


comment Some more examples;


taylor(1/(1+y^4+x^2*y^2+x^4),{x,y},0,6);


     4    2  2    4          7
1 - y  - y *x  - x  + O({x,y} )


taylor ((1 + x)**n, x, 0, 3);


                                2
           n*(n - 1)   2    n*(n  - 3*n + 2)   3      4
1 + n*x + -----------*x  + ------------------*x  + O(x )
               2                   6


taylor (e**(-a*t) * (1 + sin(t)), t, 0, 4);


                                         3      2
                    a*(a - 2)   2     - a  + 3*a  - 1   3
1 + ( - a + 1)*t + -----------*t  + ------------------*t
                        2                   6

        3      2
    a*(a  - 4*a  + 4)   4      5
 + -------------------*t  + O(t )
           24


operator f;



taylor (1 + f(t), t, 0, 3);


                                    sub(t=0,df(f(t),t,2))   2
f(0) + 1 + sub(t=0,df(f(t),t))*t + -----------------------*t
                                              2

    sub(t=0,df(f(t),t,3))   3      4
 + -----------------------*t  + O(t )
              6


taylor(f(sqrt(x^2+y^2)),x,x0,4,y,y0,4);


         2     2                          2    2
f(sqrt(x0  + y0 )) + sub(y=y0,df(f(sqrt(x0  + y )),y))*(y - y0)

                         2    2
    sub(y=y0,df(f(sqrt(x0  + y )),y,2))          2
 + -------------------------------------*(y - y0)
                     2

                         2    2
    sub(y=y0,df(f(sqrt(x0  + y )),y,3))          3
 + -------------------------------------*(y - y0)
                     6

                         2    2
    sub(y=y0,df(f(sqrt(x0  + y )),y,4))          4
 + -------------------------------------*(y - y0)
                    24

                       2     2
 + sub(x=x0,df(f(sqrt(x  + y0 )),x))*(x - x0) + (19 terms)

             5         5
 + O((x - x0) ,(y - y0) )


clear f;



taylor (sqrt(1 + a*x + sin(x)), x, 0, 3);


                     2                     3      2
     a + 1        - a  - 2*a - 1   2    3*a  + 9*a  + 9*a - 1   3      4
1 + -------*x + -----------------*x  + -----------------------*x  + O(x )
       2                8                        48


taylorcombine (ws**2);


                 1   3      4
1 + (a + 1)*x - ---*x  + O(x )
                 6


taylor (sqrt(1 + x), x, 0, 5);


     1       1   2    1    3     5    4     7    5      6
1 + ---*x - ---*x  + ----*x  - -----*x  + -----*x  + O(x )
     2       8        16        128        256


taylor ((cos(x) - sec(x))^3, x, 0, 5);


       6
0 + O(x )


taylor ((cos(x) - sec(x))^-3, x, 0, 5);


    -6    1   -4    11    -2     347       6767    2     15377    4      6
 - x   + ---*x   + -----*x   - ------- - --------*x  - ---------*x  + O(x )
          2         120         15120     604800        7983360


taylor (sqrt(1 - k^2*sin(x)^2), x, 0, 6);


      2         2        2              2         4       2
     k    2    k *( - 3*k  + 4)   4    k *( - 45*k  + 60*k  - 16)   6      7
1 - ----*x  + ------------------*x  + ----------------------------*x  + O(x )
     2                24                          720


taylor (sin(x + y), x, 0, 3, y, 0, 3);


     1   3        1     2    1   2      1    2  3                  4  4
x - ---*x  + y - ---*y*x  - ---*y *x + ----*y *x  + (2 terms) + O(x ,y )
     6            2          2          12


taylor (e^x - 1 - x,x,0,6);


 1   2    1   3    1    4     1    5     1    6      7
---*x  + ---*x  + ----*x  + -----*x  + -----*x  + O(x )
 2        6        24        120        720


taylorcombine sqrt ws;


    1              1       2        1        3         1        4
---------*x + -----------*x  + ------------*x  + -------------*x
 sqrt(2)       6*sqrt(2)        36*sqrt(2)        270*sqrt(2)

         1         5      6
 + --------------*x  + O(x )
    2592*sqrt(2)


taylor(sin(x)/x,x,1,2);


                                       - 2*cos(1) + sin(1)         2
sin(1) + (cos(1) - sin(1))*(x - 1) + ----------------------*(x - 1)
                                               2

            3
 + O((x - 1) )


taylor((sqrt(4+h)-2)/h,h,0,5);


 1     1         1    2      5     3      7      4      21      5      6
--- - ----*h + -----*h  - -------*h  + --------*h  - ---------*h  + O(h )
 4     64       512        16384        131072        2097152


taylor((sqrt(x)-2)/(4-x),x,4,2);


    1     1               1          2            3
 - --- + ----*(x - 4) - -----*(x - 4)  + O((x - 4) )
    4     64             512


taylor((sqrt(y+4)-2)/(-y),y,0,2);


    1     1         1    2      3
 - --- + ----*y - -----*y  + O(y )
    4     64       512


taylor(x*tanh(x)/(sqrt(1-x^2)-1),x,0,3);


        7   2      4
 - 2 + ---*x  + O(x )
        6


taylor((e^(5*x)-2*x)^(1/x),x,0,2);


                   3
 3      3      73*e    2      3
e  + 8*e *x + -------*x  + O(x )
                 3


taylor(sin x/cos x,x,pi/2,3);


         pi  -1    1        pi      1         pi  3           pi  4
 - (x - ----)   + ---*(x - ----) + ----*(x - ----)  + O((x - ----) )
         2         3        2       45        2               2


taylor(log x*sin(x^2)/(x*sinh x),x,0,2);


             1   2      3
log(x)*(1 - ---*x  + O(x ))
             6


taylor(1/x-1/sin x,x,0,2);


    1         3
 - ---*x + O(x )
    6


taylor(tan x/log cos x,x,pi/2,2);


          pi  -1          pi
  - (x - ----)   + O(x - ----)
          2               2
-------------------------------
    log(pi - 2*x) - log(2)


taylor(log(x^2/(x^2-a)),x,0,3);


                2
             - x
taylor(log(--------),x,0,3)
                 2
            a - x



comment Three more complicated examples contributed by Stan Kameny;


zz2 := (z*(z-2*pi*i)*(z-pi*i/2)^2)/(sinh z-i);


                 3            2       2        3
        z*(2*i*pi  - 12*i*pi*z  - 9*pi *z + 4*z )
zz2 := -------------------------------------------
                     4*(sinh(z) - i)

dz2 := df(zz2,z);


                         3                      3               2  2
dz2 := ( - 2*cosh(z)*i*pi *z + 12*cosh(z)*i*pi*z  + 9*cosh(z)*pi *z

                      4                 3                    2
         - 4*cosh(z)*z  + 2*sinh(z)*i*pi  - 36*sinh(z)*i*pi*z

                        2                 3          2           3       3
         - 18*sinh(z)*pi *z + 16*sinh(z)*z  + 18*i*pi *z - 16*i*z  + 2*pi

                  2             2
         - 36*pi*z )/(4*(sinh(z)  - 2*sinh(z)*i - 1))

z0 := pi*i/2;


       i*pi
z0 := ------
        2

taylor(dz2,z,z0,6);


                2
           i*(pi  - 16)        i*pi      pi        i*pi  2
 - 2*pi + --------------*(z - ------) + ----*(z - ------)
                4               2        2          2

              2
    i*( - 3*pi  + 80)        i*pi  3    pi        i*pi  4
 + -------------------*(z - ------)  - ----*(z - ------)
           120                2         24         2

           2
    i*(5*pi  - 168)        i*pi  5                      i*pi  7
 + -----------------*(z - ------)  + (1 term) + O((z - ------) )
         3360               2                            2


zz3:=(z*(z-2*pi)*(z-pi/2)^2)/(sin z-1);


                  3       2            2      3
        z*( - 2*pi  + 9*pi *z - 12*pi*z  + 4*z )
zz3 := ------------------------------------------
                     4*(sin(z) - 1)

dz3 := df(zz3,z);


                   3                2  2                 3             4
dz3 := (2*cos(z)*pi *z - 9*cos(z)*pi *z  + 12*cos(z)*pi*z  - 4*cos(z)*z

                      3               2                   2              3
         - 2*sin(z)*pi  + 18*sin(z)*pi *z - 36*sin(z)*pi*z  + 16*sin(z)*z

               3        2            2       3            2
         + 2*pi  - 18*pi *z + 36*pi*z  - 16*z )/(4*(sin(z)  - 2*sin(z) + 1))

z1 := pi/2;


       pi
z1 := ----
       2

taylor(dz3,z,z1,6);


          2                                            2
        pi  - 16        pi      pi        pi  2    3*pi  - 80        pi  3
2*pi + ----------*(z - ----) + ----*(z - ----)  + ------------*(z - ----)
           4            2       2         2           120            2

                           2
    pi        pi  4    5*pi  - 168        pi  5                      pi  7
 + ----*(z - ----)  + -------------*(z - ----)  + (1 term) + O((z - ----) )
    24        2           3360            2                          2


taylor((sin tan x-tan sin x)/(asin atan x-atan asin x),x,0,6);


     5   2    1313   4    2773    6      7
1 + ---*x  + ------*x  - -------*x  + O(x )
     3        1890        11907



comment If the expansion point is not constant, it has to be taken
        care of in differentation, as the following examples show;


taylor(sin(x+a),x,a,8);


                               sin(2*a)         2    cos(2*a)         3
sin(2*a) + cos(2*a)*(x - a) - ----------*(x - a)  - ----------*(x - a)
                                  2                     6

    sin(2*a)         4    cos(2*a)         5                        9
 + ----------*(x - a)  + ----------*(x - a)  + (3 terms) + O((x - a) )
       24                   120

df(ws,a);


                               cos(2*a)         2    sin(2*a)         3
cos(2*a) - sin(2*a)*(x - a) - ----------*(x - a)  + ----------*(x - a)
                                  2                     6

    cos(2*a)         4    sin(2*a)         5                        8
 + ----------*(x - a)  - ----------*(x - a)  + (2 terms) + O((x - a) )
       24                   120

taylor(cos(x+a),x,a,7);


                               cos(2*a)         2    sin(2*a)         3
cos(2*a) - sin(2*a)*(x - a) - ----------*(x - a)  + ----------*(x - a)
                                  2                     6

    cos(2*a)         4    sin(2*a)         5                        8
 + ----------*(x - a)  - ----------*(x - a)  + (2 terms) + O((x - a) )
       24                   120



comment A problem are non-analytical terms: rational powers and
        logarithmic terms can be handled, but other types of essential
        singularities cannot;


taylor(sqrt(x),x,0,2);


 1/2      3
x    + O(x )


taylor(asinh(1/x),x,0,5);


                       1   2    3    4    5    6      7
 - log(x) + (log(2) + ---*x  - ----*x  + ----*x  + O(x ))
                       4        32        96


taylor(e**(1/x),x,0,2);


        1/x
taylor(e   ,x,0,2)


comment Another example for non-integer powers;


sub (y = sqrt (x), yy);


     1/2    1       1   3/2    1    2      5/2
1 + x    + ---*x + ---*x    + ----*x  + O(x   )
            2       6          24


comment Expansion about infinity is possible in principle...;


taylor (e**(1/x), x, infinity, 5);


     1     1   1      1   1      1    1       1    1        1
1 + --- + ---*---- + ---*---- + ----*---- + -----*---- + O(----)
     x     2    2     6    3     24    4     120    5        6
               x          x           x            x        x

xi := taylor (sin (1/x), x, infinity, 5);


       1     1   1       1    1        1
xi := --- - ---*---- + -----*---- + O(----)
       x     6    3     120    5        6
                 x            x        x


y1 := taylor(x/(x-1), x, infinity, 3);


           1     1      1        1
y1 := 1 + --- + ---- + ---- + O(----)
           x      2      3        4
                 x      x        x

z := df(y1, x);


         1        1        1        1
z :=  - ---- - 2*---- - 3*---- + O(----)
          2        3        4        5
         x        x        x        x


comment ...but far from being perfect;


taylor (1 / sin (x), x, infinity, 5);


          1
taylor(--------,x,infinity,5)
        sin(x)


clear z;



comment You may access the expansion with the PART operator;


part(yy,0);


plus

part(yy,1);


1

part(yy,4);


  3
 y
----
 6

part(yy,6);


***** Expression taylor(1 + y + 1/2*y**2 + 1/6*y**3 + 1/24*y**4,y,0,4) 
does not have part 6



comment The template of a Taylor kernel can be extracted;


taylortemplate yy;


{{y,0,4}}


taylortemplate xxa;


{{x,1,2}}


taylortemplate xi;


{{x,infinity,5}}


taylortemplate xy;


{{x,0,2},{y,0,2}}


taylortemplate xx1;


{{{x,y},0,2}}


comment Here is a slightly less trivial example;


exp := (sin (x) * sin (y) / (x * y))**2;


              2       2
        sin(x) *sin(y)
exp := -----------------
              2  2
             x *y


taylor (exp, x, 0, 1, y, 0, 1);


       2  2
1 + O(x ,y )

taylor (exp, x, 0, 2, y, 0, 2);


     1   2    1   2    1   2  2      3  3
1 - ---*x  - ---*y  + ---*y *x  + O(x ,y )
     3        3        9


tt := taylor (exp, {x,y}, 0, 2);


           1   2    1   2          3
tt := 1 - ---*y  - ---*x  + O({x,y} )
           3        3


comment An example that uses factorization;


on factor;



ff := y**5 - 1;


        4    3    2
ff := (y  + y  + y  + y + 1)*(y - 1)


zz := sub (y = taylor(e**x, x, 0, 3), ff);


                 1   2    1   3      4  4             1   2    1   3      4  3
zz := ((1 + x + ---*x  + ---*x  + O(x ))  + (1 + x + ---*x  + ---*x  + O(x ))
                 2        6                           2        6

                    1   2    1   3      4  2             1   2    1   3      4
        + (1 + x + ---*x  + ---*x  + O(x ))  + (1 + x + ---*x  + ---*x  + O(x ))
                    2        6                           2        6

                        1   2    1   3      4
        + 1)*((1 + x + ---*x  + ---*x  + O(x )) - 1)
                        2        6


on exp;



zz;


          1   2    1   3      4  5
(1 + x + ---*x  + ---*x  + O(x ))  - 1
          2        6


comment A simple example of Taylor kernel differentiation;


hugo := taylor(e^x,x,0,5);


                 1   2    1   3    1    4     1    5      6
hugo := 1 + x + ---*x  + ---*x  + ----*x  + -----*x  + O(x )
                 2        6        24        120

df(hugo^2,x);


             2    8   3    4   4      5
2 + 4*x + 4*x  + ---*x  + ---*x  + O(x )
                  3        3


comment The following shows the (limited) capabilities to integrate
        Taylor kernels. Only simple cases are supported, otherwise
        a warning is printed and the Taylor kernels are converted to
        standard representation;


zz := taylor (sin x, x, 0, 5);


           1   3     1    5      6
zz := x - ---*x  + -----*x  + O(x )
           6        120

ww := taylor (cos y, y, 0, 5);


           1   2    1    4      6
ww := 1 - ---*y  + ----*y  + O(y )
           2        24


int (zz, x);


 1   2    1    4     1    6      7
---*x  - ----*x  + -----*x  + O(x )
 2        24        720

int (ww, x);


     x   2    x    4      6
x - ---*y  + ----*y  + O(y )
     2        24

int (zz + ww, x);


  1   2    1    4     1    6      7           x   2    x    4      6
(---*x  - ----*x  + -----*x  + O(x )) + (x - ---*y  + ----*y  + O(y ))
  2        24        720                      2        24



comment And here we present Taylor series reversion.
        We start with the example given by Knuth for the algorithm;


taylor (t - t**2, t, 0, 5);


     2      6
t - t  + O(t )


taylorrevert (ws, t, x);


     2      3      4       5      6
x + x  + 2*x  + 5*x  + 14*x  + O(x )


tan!-series := taylor (tan x, x, 0, 5);


                   1   3    2    5      6
tan-series := x + ---*x  + ----*x  + O(x )
                   3        15

taylorrevert (tan!-series, x, y);


     1   3    1   5      6
y - ---*y  + ---*y  + O(y )
     3        5

atan!-series:=taylor (atan y, y, 0, 5);


                    1   3    1   5      6
atan-series := y - ---*y  + ---*y  + O(y )
                    3        5


tmp := taylor (e**x, x, 0, 5);


                1   2    1   3    1    4     1    5      6
tmp := 1 + x + ---*x  + ---*x  + ----*x  + -----*x  + O(x )
                2        6        24        120


taylorrevert (tmp, x, y);


         1         2    1         3    1         4    1         5            6
y - 1 - ---*(y - 1)  + ---*(y - 1)  - ---*(y - 1)  + ---*(y - 1)  + O((y - 1) )
         2              3              4              5


taylor (log y, y, 1, 5);


         1         2    1         3    1         4    1         5            6
y - 1 - ---*(y - 1)  + ---*(y - 1)  - ---*(y - 1)  + ---*(y - 1)  + O((y - 1) )
         2              3              4              5



comment The following example calculates the perturbation expansion
        of the root x = 20 of the following polynomial in terms of
        EPS, in ROUNDED mode;


poly := for r := 1 : 20 product (x - r);


         20        19          18            17             16               15
poly := x   - 210*x   + 20615*x   - 1256850*x   + 53327946*x   - 1672280820*x

                        14                 13                   12
         + 40171771630*x   - 756111184500*x   + 11310276995381*x

                            11                     10                      9
         - 135585182899530*x   + 1307535010540395*x   - 10142299865511450*x

                              8                       7                        6
         + 63030812099294896*x  - 311333643161390640*x  + 1206647803780373360*x

                                5                        4
         - 3599979517947607200*x  + 8037811822645051776*x

                                 3                         2
         - 12870931245150988800*x  + 13803759753640704000*x

         - 8752948036761600000*x + 2432902008176640000


on rounded;



tpoly := taylor (poly, x, 20, 4);


                                                                2
tpoly := 1.21649393692e+17*(x - 20) + 4.31564847287e+17*(x - 20)

                                      3                             4
          + 6.68609351672e+17*(x - 20)  + 6.10115975015e+17*(x - 20)

                      5
          + O((x - 20) )


taylorrevert (tpoly, x, eps);


                                                  2                        3
20 + 8.22034512178e-18*eps - 2.39726594662e-34*eps  + 1.09290580232e-50*eps

                        4        5
 - 5.97114159465e-67*eps  + O(eps )


comment Some more examples using rounded mode;


taylor(sin x/x,x,0,4);


                    2                     4      5
1 - 0.166666666667*x  + 0.00833333333333*x  + O(x )


taylor(sin x,x,pi/2,4);


                                                                   2
1 + 6.12303176911e-17*(x - 1.57079632679) - 0.5*(x - 1.57079632679)

                                        3                                      4
 - 1.02050529485e-17*(x - 1.57079632679)  + 0.0416666666667*(x - 1.57079632679)

                        5
 + O((x - 1.57079632679) )


taylor(tan x,x,pi/2,4);


                      -1
 - (x - 1.57079632679)   + 0.333333333333*(x - 1.57079632679)

                                      3                        5
 + 0.0222222222222*(x - 1.57079632679)  + O((x - 1.57079632679) )


off rounded;




comment An example that involves computing limits of type 0/0 if
        expansion is done via differentiation;



taylor(sqrt((e^x - 1)/x),x,0,15);


     1       5    2     1    3     79     4      3     5                   16
1 + ---*x + ----*x  + -----*x  + -------*x  + -------*x  + (10 terms) + O(x  )
     4       96        128        92160        40960


comment An example that involves intermediate non-analytical terms
        which cancel entirely;


taylor(x^(5/2)/(log(x+1)*tan(x^(3/2))),x,0,5);


     1       1    2    7    3    139   4     67    5      6
1 + ---*x - ----*x  - ----*x  - -----*x  + ------*x  + O(x )
     2       12        24        720        1440


comment Other examples involving non-analytical terms;


taylor(log(e^x-1),x,0,5);


           1       1    2     1     4      5
log(x) + (---*x + ----*x  - ------*x  + O(x ))
           2       24        2880


taylor(e^(1/x)*(e^x-1),x,0,5);


 1/x       1   2    1   3    1    4     1    5      6
e   *(x + ---*x  + ---*x  + ----*x  + -----*x  + O(x ))
           2        6        24        120


taylor(log(x)*x^10,x,0,5);


         10      11
log(x)*(x   + O(x  ))


taylor(log(x)*x^10,x,0,11);


         10      12
log(x)*(x   + O(x  ))


taylor(log(x-a)/((a-b)*(a-c)) + log(2(x-b))/((b-c)*(b-a))
     + log(x-c)/((c-a)*(c-b)),x,infinity,2);


           log(2)            1   1        1
 - ---------------------- - ---*---- + O(----)
                 2           2    2        3
    a*b - a*c - b  + b*c         x        x


ss := (sqrt(x^(2/5) +1) - x^(1/3)-1)/x^(1/3);


             2/5         1/3
       sqrt(x    + 1) - x    - 1
ss := ---------------------------
                  1/3
                 x

taylor(exp ss,x,0,2);


 1      1    1/15     1    2/15     1     1/5      1     4/15      1      1/3
--- + -----*x     + -----*x     + ------*x    + -------*x     + --------*x
 e     2*e           8*e           48*e          384*e           3840*e

                   31/15
 + (25 terms) + O(x     )


taylor(exp sub(x=x^15,ss),x,0,2);


 1      1         1    2      3
--- + -----*x + -----*x  + O(x )
 e     2*e       8*e


taylor(dilog(x),x,0,4);


             1   2    1   3    1   4      5
log(x)*(x + ---*x  + ---*x  + ---*x  + O(x ))
             2        3        4

       2
     pi          1   2    1   3    1    4      5
 + (----- - x - ---*x  - ---*x  - ----*x  + O(x ))
      6          4        9        16


taylor(ei(x),x,0,4);


                        1   2    1    3    1    4      5
log(x) - psi(1) + (x + ---*x  + ----*x  + ----*x  + O(x ))
                        4        18        96


comment In the following we demonstrate the possibiblity to compute the
        expansion of a function which is given by a simple first order
        differential equation: the function myexp(x) is exp(-x^2);


operator myexp,myerf;


let {df(myexp(~x),~x) => -2*x*myexp(x), myexp(0) => 1,
     df(myerf(~x),~x) => 2/sqrt(pi)*myexp(x), myerf(0) => 0};


taylor(myexp(x),x,0,5);


     2    1   4      6
1 - x  + ---*x  + O(x )
          2

taylor(myerf(x),x,0,5);


    2               2        3        1        5      6
----------*x - ------------*x  + ------------*x  + O(x )
 sqrt(pi)       3*sqrt(pi)        5*sqrt(pi)

clear {df(myexp(~x),~x) => -2*x*myexp(x), myexp(0) => 1,
       df(myerf(~x),~x) => 2/sqrt(pi)*myexp(x), myerf(0) => 0};


clear myexp,erf;



%%% showtime;

comment There are two special operators, implicit_taylor and
        inverse_taylor, to compute the Taylor expansion of implicit
        or inverse functions;



implicit_taylor(x^2 + y^2 - 1,x,y,0,1,5);


     1   2    1   4      6
1 - ---*x  - ---*x  + O(x )
     2        8


implicit_taylor(x^2 + y^2 - 1,x,y,0,1,20);


     1   2    1   4    1    6     5    8     7    10                  21
1 - ---*x  - ---*x  - ----*x  - -----*x  - -----*x   + (5 terms) + O(x  )
     2        8        16        128        256


implicit_taylor(x+y^3-y,x,y,0,0,8);


     3      5       7      9
x + x  + 3*x  + 12*x  + O(x )


implicit_taylor(x+y^3-y,x,y,0,1,5);


     1       3   2    1   3    105   4    3   5      6
1 - ---*x - ---*x  - ---*x  - -----*x  - ---*x  + O(x )
     2       8        2        128        2


implicit_taylor(x+y^3-y,x,y,0,-1,5);


        1       3   2    1   3    105   4    3   5      6
 - 1 - ---*x + ---*x  - ---*x  + -----*x  - ---*x  + O(x )
        2       8        2        128        2


implicit_taylor(y*e^y-x,x,y,0,0,5);


     2    3   3    8   4    125   5      6
x - x  + ---*x  - ---*x  + -----*x  + O(x )
          2        3        24


comment This is the function exp(-1/x^2), which has an essential
        singularity at the point 0;


implicit_taylor(x^2*log y+1,x,y,0,0,3);


***** Computation of Taylor series of implicit function failed 
      Input expression non-zero at given point 


inverse_taylor(exp(x)-1,x,y,0,8);


     1   2    1   3    1   4    1   5    1   6                  9
y - ---*y  + ---*y  - ---*y  + ---*y  - ---*y  + (2 terms) + O(y )
     2        3        4        5        6


inverse_taylor(exp(x),x,y,0,5);


         1         2    1         3    1         4    1         5            6
y - 1 - ---*(y - 1)  + ---*(y - 1)  - ---*(y - 1)  + ---*(y - 1)  + O((y - 1) )
         2              3              4              5


inverse_taylor(sqrt(x),x,y,0,5);


 2      6
y  + O(y )


inverse_taylor(log(1+x),x,y,0,5);


     1   2    1   3    1    4     1    5      6
y + ---*y  + ---*y  + ----*y  + -----*y  + O(y )
     2        6        24        120


inverse_taylor((e^x-e^(-x))/2,x,y,0,5);


     1   3    3    5      6
y - ---*y  + ----*y  + O(y )
     6        40


comment In the next two cases the inverse functions have a branch
        point, therefore the computation fails;


inverse_taylor((e^x+e^(-x))/2,x,y,0,5);


***** Computation of Taylor series of inverse function failed 


inverse_taylor(exp(x^2-1),x,y,0,5);


***** Computation of Taylor series of inverse function failed 


inverse_taylor(exp(sqrt(x))-1,x,y,0,5);


 2    3    11   4    5   5      6
y  - y  + ----*y  - ---*y  + O(y )
           12        6


inverse_taylor(x*exp(x),x,y,0,5);


     2    3   3    8   4    125   5      6
y - y  + ---*y  - ---*y  + -----*y  + O(y )
          2        3        24



%%% showtime;


comment An application is the problem posed by Prof. Stanley:
        we prove that the finite difference expression below
        corresponds to the given derivative expression;


operator diff,a,f,gg;

  % We use gg to avoid conflict with high energy
                       % physics operator.

let diff(~f,~arg) => df(f,arg);



derivative_expression :=
diff(a(x,y)*diff(gg(x,y),x)*diff(gg(x,y),y)*diff(f(x,y),y),x) +
diff(a(x,y)*diff(gg(x,y),x)*diff(gg(x,y),y)*diff(f(x,y),x),y) ;


derivative_expression := 2*a(x,y)*df(f(x,y),x,y)*df(gg(x,y),x)*df(gg(x,y),y)

 + a(x,y)*df(f(x,y),x)*df(gg(x,y),x,y)*df(gg(x,y),y)

 + a(x,y)*df(f(x,y),x)*df(gg(x,y),x)*df(gg(x,y),y,2)

 + a(x,y)*df(f(x,y),y)*df(gg(x,y),x,y)*df(gg(x,y),x)

 + a(x,y)*df(f(x,y),y)*df(gg(x,y),x,2)*df(gg(x,y),y)

 + df(a(x,y),x)*df(f(x,y),y)*df(gg(x,y),x)*df(gg(x,y),y)

 + df(a(x,y),y)*df(f(x,y),x)*df(gg(x,y),x)*df(gg(x,y),y)


finite_difference_expression :=
+a(x+dx,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x+dx,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x+dx,y+dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x+dx,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x+dx,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y+dy)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y+dy)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x+dx,y)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*gg(x+dx,y)*a(x+dx,y+dy)*f(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x+dx,y)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x+dx,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*a(x+dx,y)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y+dy)*gg(x,y+dy)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y+dy)*gg(x+dx,y)*f(x+dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x+dx,y)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y)*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x,y+dy)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y+dy)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y+dy)*f(x+dx,y+dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x+dx,y+dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x+dx,y)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*gg(x+dx,y)*a(x+dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y+dy)/(32*dx^2*dy^2)
+a(x+dx,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x+dx,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x+dx,y)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x+dx,y-dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x+dx,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x+dx,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y-dy)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x+dx,y)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y-dy)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x+dx,y)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*gg(x+dx,y)*a(x+dx,y-dy)*f(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x+dx,y)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x+dx,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*a(x+dx,y)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y-dy)*gg(x,y-dy)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y-dy)*gg(x+dx,y)*f(x+dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x+dx,y)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x+dx,y)*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x,y-dy)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y-dy)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y-dy)*f(x+dx,y-dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x+dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x+dx,y)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*gg(x+dx,y)*a(x+dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*a(x+dx,y)*gg(x+dx,y)^2/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x+dx,y)^2/(32*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x+dx,y)^2/(32*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x+dx,y)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*a(x+dx,y)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*a(x+dx,y)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x,y+dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y+dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x,y-dy)*gg(x+dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y-dy)*gg(x+dx,y)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x+dx,y)/(32*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x+dx,y)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x+dx,y)/(16*dx^2*dy^2)
+a(x-dx,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x-dx,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x-dx,y+dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x-dx,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x-dx,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y+dy)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y+dy)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x-dx,y)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*gg(x-dx,y)*a(x-dx,y+dy)*f(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x-dx,y)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x-dx,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y+dy)*a(x-dx,y)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y+dy)*gg(x,y+dy)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y+dy)*gg(x-dx,y)*f(x-dx,y+dy)/(16*dx^2*dy^2)
-gg(x,y+dy)^2*a(x-dx,y)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y)*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y+dy)*gg(x,y+dy)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y+dy)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y+dy)*f(x-dx,y+dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x-dx,y+dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x-dx,y)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*gg(x-dx,y)*a(x-dx,y+dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y+dy)/(32*dx^2*dy^2)
+a(x-dx,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x-dx,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
+a(x,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x-dx,y)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x-dx,y-dy)^2/(32*dx^2*dy^2)
-gg(x,y)*a(x-dx,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x-dx,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y)*a(x,y-dy)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-a(x,y)*gg(x,y)*f(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x-dx,y)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y)*a(x,y-dy)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y)*gg(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x-dx,y)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*gg(x-dx,y)*a(x-dx,y-dy)*f(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x-dx,y)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x-dx,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y-dy)*a(x-dx,y)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y-dy)*gg(x,y-dy)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
+a(x,y)*gg(x,y-dy)*gg(x-dx,y)*f(x-dx,y-dy)/(16*dx^2*dy^2)
-gg(x,y-dy)^2*a(x-dx,y)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x-dx,y)*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y-dy)*gg(x,y-dy)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
-a(x,y)*gg(x,y-dy)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+gg(x,y)^2*a(x,y-dy)*f(x-dx,y-dy)/(32*dx^2*dy^2)
+a(x,y)*gg(x,y)^2*f(x-dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*gg(x-dx,y)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*gg(x-dx,y)*a(x-dx,y-dy)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y-dy)/(32*dx^2*dy^2)
+f(x,y)*a(x-dx,y)*gg(x-dx,y)^2/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x-dx,y)^2/(32*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x-dx,y)^2/(32*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x-dx,y)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y+dy)*a(x-dx,y)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*gg(x,y-dy)*a(x-dx,y)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y+dy)*gg(x,y+dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y+dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-f(x,y)*a(x,y-dy)*gg(x,y-dy)*gg(x-dx,y)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y-dy)*gg(x-dx,y)/(16*dx^2*dy^2)
+f(x,y)*gg(x,y+dy)^2*a(x-dx,y)/(32*dx^2*dy^2)
+f(x,y)*gg(x,y-dy)^2*a(x-dx,y)/(32*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x-dx,y)/(16*dx^2*dy^2)
+f(x,y)*a(x,y+dy)*gg(x,y+dy)^2/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y+dy)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x,y+dy)/(16*dx^2*dy^2)
+f(x,y)*a(x,y-dy)*gg(x,y-dy)^2/(16*dx^2*dy^2)
+a(x,y)*f(x,y)*gg(x,y-dy)^2/(16*dx^2*dy^2)
-f(x,y)*gg(x,y)^2*a(x,y-dy)/(16*dx^2*dy^2)
-a(x,y)*f(x,y)*gg(x,y)^2/(8*dx^2*dy^2)$



comment We define abbreviations for the partial derivatives;


operator ax,ay,fx,fy,gx,gy;


operator axx,axy,ayy,fxx,fxy,fyy,gxx,gxy,gyy;


operator axxx,axxy,axyy,ayyy,fxxx,fxxy,fxyy,fyyy,gxxx,gxxy,gxyy,gyyy;


operator axxxy,axxyy,axyyy,fxxxy,fxxyy,fxyyy,
         gxxxx,gxxxy,gxxyy,gxyyy,gyyyy;


operator axxxyy,axxyyy,fxxyyy,fxxxyy,gxxxxy,gxxxyy,gxxyyy,gxyyyy;


operator gxxxxyy,gxxxyyy,gxxyyyy;



operator_diff_rules := {
  df(a(~x,~y),~x) => ax(x,y),
  df(a(~x,~y),~y) => ay(x,y),
  df(f(~x,~y),~x) => fx(x,y),
  df(f(~x,~y),~y) => fy(x,y),
  df(gg(~x,~y),~x) => gx(x,y),
  df(gg(~x,~y),~y) => gy(x,y),

  df(ax(~x,~y),~x) => axx(x,y),
  df(ax(~x,~y),~y) => axy(x,y),
  df(ay(~x,~y),~x) => axy(x,y),
  df(ay(~x,~y),~y) => ayy(x,y),
  df(fx(~x,~y),~x) => fxx(x,y),
  df(fx(~x,~y),~y) => fxy(x,y),
  df(fy(~x,~y),~x) => fxy(x,y),
  df(fy(~x,~y),~y) => fyy(x,y),
  df(gx(~x,~y),~x) => gxx(x,y),
  df(gx(~x,~y),~y) => gxy(x,y),
  df(gy(~x,~y),~x) => gxy(x,y),
  df(gy(~x,~y),~y) => gyy(x,y),

  df(axx(~x,~y),~x) => axxx(x,y),
  df(axy(~x,~y),~x) => axxy(x,y),
  df(ayy(~x,~y),~x) => axyy(x,y),
  df(ayy(~x,~y),~y) => ayyy(x,y),
  df(fxx(~x,~y),~x) => fxxx(x,y),
  df(fxy(~x,~y),~x) => fxxy(x,y),
  df(fxy(~x,~y),~y) => fxyy(x,y),
  df(fyy(~x,~y),~x) => fxyy(x,y),
  df(fyy(~x,~y),~y) => fyyy(x,y),
  df(gxx(~x,~y),~x) => gxxx(x,y),
  df(gxx(~x,~y),~y) => gxxy(x,y),
  df(gxy(~x,~y),~x) => gxxy(x,y),
  df(gxy(~x,~y),~y) => gxyy(x,y),
  df(gyy(~x,~y),~x) => gxyy(x,y),
  df(gyy(~x,~y),~y) => gyyy(x,y),

  df(axyy(~x,~y),~x) => axxyy(x,y),
  df(axxy(~x,~y),~x) => axxxy(x,y),
  df(ayyy(~x,~y),~x) => axyyy(x,y),
  df(fxxy(~x,~y),~x) => fxxxy(x,y),
  df(fxyy(~x,~y),~x) => fxxyy(x,y),
  df(fyyy(~x,~y),~x) => fxyyy(x,y),
  df(gxxx(~x,~y),~x) => gxxxx(x,y),
  df(gxxy(~x,~y),~x) => gxxxy(x,y),
  df(gxyy(~x,~y),~x) => gxxyy(x,y),
  df(gyyy(~x,~y),~x) => gxyyy(x,y),
  df(gyyy(~x,~y),~y) => gyyyy(x,y),

  df(axxyy(~x,~y),~x) => axxxyy(x,y),
  df(axyyy(~x,~y),~x) => axxyyy(x,y),
  df(fxxyy(~x,~y),~x) => fxxxyy(x,y),
  df(fxyyy(~x,~y),~x) => fxxyyy(x,y),
  df(gxxxy(~x,~y),~x) => gxxxxy(x,y),
  df(gxxyy(~x,~y),~x) => gxxxyy(x,y),
  df(gxyyy(~x,~y),~x) => gxxyyy(x,y),
  df(gyyyy(~x,~y),~x) => gxyyyy(x,y),

  df(gxxxyy(~x,~y),~x) => gxxxxyy(x,y),
  df(gxxyyy(~x,~y),~x) => gxxxyyy(x,y),
  df(gxyyyy(~x,~y),~x) => gxxyyyy(x,y)
};


operator_diff_rules := {df(a(~x,~y),~x) => ax(x,y),

   df(a(~x,~y),~y) => ay(x,y),

   df(f(~x,~y),~x) => fx(x,y),

   df(f(~x,~y),~y) => fy(x,y),

   df(gg(~x,~y),~x) => gx(x,y),

   df(gg(~x,~y),~y) => gy(x,y),

   df(ax(~x,~y),~x) => axx(x,y),

   df(ax(~x,~y),~y) => axy(x,y),

   df(ay(~x,~y),~x) => axy(x,y),

   df(ay(~x,~y),~y) => ayy(x,y),

   df(fx(~x,~y),~x) => fxx(x,y),

   df(fx(~x,~y),~y) => fxy(x,y),

   df(fy(~x,~y),~x) => fxy(x,y),

   df(fy(~x,~y),~y) => fyy(x,y),

   df(gx(~x,~y),~x) => gxx(x,y),

   df(gx(~x,~y),~y) => gxy(x,y),

   df(gy(~x,~y),~x) => gxy(x,y),

   df(gy(~x,~y),~y) => gyy(x,y),

   df(axx(~x,~y),~x) => axxx(x,y),

   df(axy(~x,~y),~x) => axxy(x,y),

   df(ayy(~x,~y),~x) => axyy(x,y),

   df(ayy(~x,~y),~y) => ayyy(x,y),

   df(fxx(~x,~y),~x) => fxxx(x,y),

   df(fxy(~x,~y),~x) => fxxy(x,y),

   df(fxy(~x,~y),~y) => fxyy(x,y),

   df(fyy(~x,~y),~x) => fxyy(x,y),

   df(fyy(~x,~y),~y) => fyyy(x,y),

   df(gxx(~x,~y),~x) => gxxx(x,y),

   df(gxx(~x,~y),~y) => gxxy(x,y),

   df(gxy(~x,~y),~x) => gxxy(x,y),

   df(gxy(~x,~y),~y) => gxyy(x,y),

   df(gyy(~x,~y),~x) => gxyy(x,y),

   df(gyy(~x,~y),~y) => gyyy(x,y),

   df(axyy(~x,~y),~x) => axxyy(x,y),

   df(axxy(~x,~y),~x) => axxxy(x,y),

   df(ayyy(~x,~y),~x) => axyyy(x,y),

   df(fxxy(~x,~y),~x) => fxxxy(x,y),

   df(fxyy(~x,~y),~x) => fxxyy(x,y),

   df(fyyy(~x,~y),~x) => fxyyy(x,y),

   df(gxxx(~x,~y),~x) => gxxxx(x,y),

   df(gxxy(~x,~y),~x) => gxxxy(x,y),

   df(gxyy(~x,~y),~x) => gxxyy(x,y),

   df(gyyy(~x,~y),~x) => gxyyy(x,y),

   df(gyyy(~x,~y),~y) => gyyyy(x,y),

   df(axxyy(~x,~y),~x) => axxxyy(x,y),

   df(axyyy(~x,~y),~x) => axxyyy(x,y),

   df(fxxyy(~x,~y),~x) => fxxxyy(x,y),

   df(fxyyy(~x,~y),~x) => fxxyyy(x,y),

   df(gxxxy(~x,~y),~x) => gxxxxy(x,y),

   df(gxxyy(~x,~y),~x) => gxxxyy(x,y),

   df(gxyyy(~x,~y),~x) => gxxyyy(x,y),

   df(gyyyy(~x,~y),~x) => gxyyyy(x,y),

   df(gxxxyy(~x,~y),~x) => gxxxxyy(x,y),

   df(gxxyyy(~x,~y),~x) => gxxxyyy(x,y),

   df(gxyyyy(~x,~y),~x) => gxxyyyy(x,y)}


let operator_diff_rules;



texp := taylor (finite_difference_expression, dx, 0, 1, dy, 0, 1);


texp := a(x,y)*fx(x,y)*gx(x,y)*gyy(x,y) + a(x,y)*fx(x,y)*gxy(x,y)*gy(x,y)

         + 2*a(x,y)*fxy(x,y)*gx(x,y)*gy(x,y) + a(x,y)*fy(x,y)*gx(x,y)*gxy(x,y)

         + a(x,y)*fy(x,y)*gxx(x,y)*gy(x,y) + ax(x,y)*fy(x,y)*gx(x,y)*gy(x,y)

                                                 2   2
         + ay(x,y)*fx(x,y)*gx(x,y)*gy(x,y) + O(dx ,dy )


comment You may also try to expand further but this needs a lot
        of CPU time.  Therefore the following line is commented out;


%texp := taylor (finite_difference_expression, dx, 0, 2, dy, 0, 2);

factor dx,dy;



result := taylortostandard texp;


result := a(x,y)*fx(x,y)*gx(x,y)*gyy(x,y) + a(x,y)*fx(x,y)*gxy(x,y)*gy(x,y)

           + 2*a(x,y)*fxy(x,y)*gx(x,y)*gy(x,y) + a(x,y)*fy(x,y)*gx(x,y)*gxy(x,y)

           + a(x,y)*fy(x,y)*gxx(x,y)*gy(x,y) + ax(x,y)*fy(x,y)*gx(x,y)*gy(x,y)

           + ay(x,y)*fx(x,y)*gx(x,y)*gy(x,y)


derivative_expression - result;


0



clear diff(~f,~arg);


clearrules operator_diff_rules;


clear diff,a,f,gg;


clear ax,ay,fx,fy,gx,gy;


clear axx,axy,ayy,fxx,fxy,fyy,gxx,gxy,gyy;


clear axxx,axxy,axyy,ayyy,fxxx,fxxy,fxyy,fyyy,gxxx,gxxy,gxyy,gyyy;


clear axxxy,axxyy,axyyy,fxxxy,fxxyy,fxyyy,gxxxx,gxxxy,gxxyy,gxyyy,gyyyy;


clear axxxyy,axxyyy,fxxyyy,fxxxyy,gxxxxy,gxxxyy,gxxyyy,gxyyyy;


clear gxxxxyy,gxxxyyy,gxxyyyy;



taylorprintterms := 5;


taylorprintterms := 5


off taylorautoexpand,taylorkeeporiginal;



%%% showtime;

comment An example provided by Alan Barnes: elliptic functions;


% Jacobi's elliptic functions 
%       sn(x,k),  cn(x,k), dn(x,k).
% The modulus and complementary modulus are denoted by K and K!'
%      usually written mathematically as k and k' respectively
%
% epsilon(x,k) is the incomplete elliptic integral of the second kind
%      usually written mathematically as E(x,k)
%
% KK(k) is the complete elliptic integral of the first kind
%       usually written mathematically as K(k)
%       K(k) = arcsn(1,k)
% KK!'(k) is the complementary complete integral
%      usually written mathematically as K'(k)
%      NB.  K'(k) = K(k')
% EE(k) is the complete elliptic integral of the second kind
%      usually written mathematically as E(k)
% EE!'(k) is the complementary complete integral
%      usually written mathematically as E'(k)
%      NB.  E'(k) = E(k')

operator sn, cn, dn, epsilon;



elliptic_rules := {
% Differentiation rules for basic functions
   df(sn(~x,~k),~x)     => cn(x,k)*dn(x,k),
   df(cn(~x,~k),~x)     => -sn(x,k)*dn(x,k),
   df(dn(~x,~k),~x)     => -k^2*sn(x,k)*cn(x,k),
   df(epsilon(~x,~k),~x)=> dn(x,k)^2,

% k-derivatives
% DF Lawden     Elliptic Functions & Applications    Springer (1989)
   df(sn(~x,~k),~k)  => (k*sn(x,k)*cn(x,k)^2
                         -epsilon(x,k)*cn(x,k)*dn(x,k)/k)/(1-k^2)
                       + x*cn(x,k)*dn(x,k)/k,
   df(cn(~x,~k),~k)  => (-k*sn(x,k)^2*cn(x,k)
                         +epsilon(x,k)*sn(x,k)*dn(x,k)/k)/(1-k^2)
                        - x*sn(x,k)*dn(x,k)/k,
   df(dn(~x,~k),~k)  => k*(-sn(x,k)^2*dn(x,k)
                            +epsilon(x,k)*sn(x,k)*cn(x,k))/(1-k^2)
                          - k*x*sn(x,k)*cn(x,k),
   df(epsilon(~x,~k),~k) => k*(sn(x,k)*cn(x,k)*dn(x,k)
                                -epsilon(x,k)*cn(x,k)^2)/(1-k^2)
                             -k*x*sn(x,k)^2,

% parity properties
   sn(-~x,~k) => -sn(x,k),
   cn(-~x,~k) => cn(x,k),
   dn(-~x,~k) => dn(x,k),
   epsilon(-~x,~k) => -epsilon(x,k),
   sn(~x,-~k) => sn(x,k),
   cn(~x,-~k) => cn(x,k),
   dn(~x,-~k) => dn(x,k),
   epsilon(~x,-~k) => epsilon(x,k),


% behaviour at zero
   sn(0,~k) => 0,
   cn(0,~k) => 1,
   dn(0,~k) => 1,
   epsilon(0,~k) => 0,


% degenerate cases of modulus
   sn(~x,0) => sin(x),
   cn(~x,0) => cos(x),
   dn(~x,0) => 1,
   epsilon(~x,0) => x,

   sn(~x,1) => tanh(x),
   cn(~x,1) => 1/cosh(x),
   dn(~x,1) => 1/cosh(x),
   epsilon(~x,1) => tanh(x)
};


elliptic_rules := {df(sn(~x,~k),~x) => cn(x,k)*dn(x,k),

   df(cn(~x,~k),~x) =>  - sn(x,k)*dn(x,k),

                           2
   df(dn(~x,~k),~x) =>  - k *sn(x,k)*cn(x,k),

                                   2
   df(epsilon(~x,~k),~x) => dn(x,k) ,

                                         2                         dn(x,k)
                        k*sn(x,k)*cn(x,k)  - epsilon(x,k)*cn(x,k)*---------
                                                                      k
   df(sn(~x,~k),~k) => -----------------------------------------------------
                                                   2
                                              1 - k

                 dn(x,k)
    + x*cn(x,k)*---------,
                    k

                                    2                                 dn(x,k)
                         - k*sn(x,k) *cn(x,k) + epsilon(x,k)*sn(x,k)*---------
                                                                         k
   df(cn(~x,~k),~k) => --------------------------------------------------------
                                                     2
                                                1 - k

                 dn(x,k)
    - x*sn(x,k)*---------,
                    k

                                    2
                           - sn(x,k) *dn(x,k) + epsilon(x,k)*sn(x,k)*cn(x,k)
   df(dn(~x,~k),~k) => k*----------------------------------------------------
                                                     2
                                                1 - k

    - k*x*sn(x,k)*cn(x,k),

   df(epsilon(~x,~k),~k)

                                                        2
          sn(x,k)*cn(x,k)*dn(x,k) - epsilon(x,k)*cn(x,k)                2
    => k*------------------------------------------------- - k*x*sn(x,k) ,
                                   2
                              1 - k

   sn( - ~x,~k) =>  - sn(x,k),

   cn( - ~x,~k) => cn(x,k),

   dn( - ~x,~k) => dn(x,k),

   epsilon( - ~x,~k) =>  - epsilon(x,k),

   sn(~x, - ~k) => sn(x,k),

   cn(~x, - ~k) => cn(x,k),

   dn(~x, - ~k) => dn(x,k),

   epsilon(~x, - ~k) => epsilon(x,k),

   sn(0,~k) => 0,

   cn(0,~k) => 1,

   dn(0,~k) => 1,

   epsilon(0,~k) => 0,

   sn(~x,0) => sin(x),

   cn(~x,0) => cos(x),

   dn(~x,0) => 1,

   epsilon(~x,0) => x,

   sn(~x,1) => tanh(x),

                   1
   cn(~x,1) => ---------,
                cosh(x)

                   1
   dn(~x,1) => ---------,
                cosh(x)

   epsilon(~x,1) => tanh(x)}


let elliptic_rules;



hugo := taylor(sn(x,k),k,0,6);


                                2                           2
                  cos(x)*(cos(x) *x + cos(x)*sin(x) + sin(x) *x - 2*x)   2
hugo := sin(x) + ------------------------------------------------------*k  + (
                                           4

                 5             4         2           4
           cos(x) *x - 2*cos(x) *sin(x)*x  + 5*cos(x) *sin(x)

                       3       2             3             2       3  2
            - 10*cos(x) *sin(x) *x + 6*cos(x) *x - 4*cos(x) *sin(x) *x

                    2       3           2         2           2
            + cos(x) *sin(x)  + 8*cos(x) *sin(x)*x  + 4*cos(x) *sin(x)

                              4                     2
            - 11*cos(x)*sin(x) *x + 30*cos(x)*sin(x) *x - 16*cos(x)*x

                      5  2           3  2             2      4
            - 2*sin(x) *x  + 8*sin(x) *x  - 8*sin(x)*x )/64*k  + (

                      7  3            7              6         2
            - 6*cos(x) *x  + 17*cos(x) *x - 99*cos(x) *sin(x)*x

                       6                   5       2  3            5       2
            + 21*cos(x) *sin(x) - 18*cos(x) *sin(x) *x  - 71*cos(x) *sin(x) *x

                       5  3            5               4       3  2
            + 36*cos(x) *x  - 18*cos(x) *x - 135*cos(x) *sin(x) *x

                        4       3             4         2             4
            - 133*cos(x) *sin(x)  + 324*cos(x) *sin(x)*x  + 172*cos(x) *sin(x)

                       3       4  3            3       4
            - 18*cos(x) *sin(x) *x  - 13*cos(x) *sin(x) *x

                       3       2  3             3       2              3  3
            + 72*cos(x) *sin(x) *x  - 156*cos(x) *sin(x) *x - 72*cos(x) *x

                        3              2       5  2             2       5
            + 160*cos(x) *x + 27*cos(x) *sin(x) *x  - 118*cos(x) *sin(x)

                        2       3             2         2            2
            + 176*cos(x) *sin(x)  - 108*cos(x) *sin(x)*x  + 32*cos(x) *sin(x)

                             6  3                   6                     4  3
            - 6*cos(x)*sin(x) *x  + 75*cos(x)*sin(x) *x + 36*cos(x)*sin(x) *x

                               4                     2  3                    2
            - 498*cos(x)*sin(x) *x - 72*cos(x)*sin(x) *x  + 888*cos(x)*sin(x) *x

                         3                           7  2             5  2
            + 48*cos(x)*x  - 384*cos(x)*x + 63*sin(x) *x  - 324*sin(x) *x

                        3  2               2        6      7
            + 540*sin(x) *x  - 288*sin(x)*x )/2304*k  + O(k )

otto := taylor(cn(x,k),k,0,6);


                                   2                           2
                  sin(x)*( - cos(x) *x - cos(x)*sin(x) - sin(x) *x + 2*x)   2
otto := cos(x) + ---------------------------------------------------------*k  + 
                                             4

                    5  2           4                    3       2  2
        ( - 2*cos(x) *x  - 5*cos(x) *sin(x)*x - 4*cos(x) *sin(x) *x

                    3       2           3  2           2       3
          - 7*cos(x) *sin(x)  + 8*cos(x) *x  + 2*cos(x) *sin(x) *x

                    2                           4  2                  4
          + 2*cos(x) *sin(x)*x - 2*cos(x)*sin(x) *x  - 3*cos(x)*sin(x)

                           2  2                  2             2           5
          + 8*cos(x)*sin(x) *x  - 4*cos(x)*sin(x)  - 8*cos(x)*x  + 7*sin(x) *x

                     3                      4               7  2
          - 22*sin(x) *x + 16*sin(x)*x)/64*k  + ( - 9*cos(x) *x

                      6         3            6                      5       2  2
            + 6*cos(x) *sin(x)*x  - 71*cos(x) *sin(x)*x + 135*cos(x) *sin(x) *x

                       5       2            5  2            4       3  3
            - 66*cos(x) *sin(x)  - 36*cos(x) *x  + 18*cos(x) *sin(x) *x

                    4       3              4         3            4
            - cos(x) *sin(x) *x - 36*cos(x) *sin(x)*x  + 18*cos(x) *sin(x)*x

                        3       4  2            3       4
            + 297*cos(x) *sin(x) *x  + 61*cos(x) *sin(x)

                        3       2  2             3       2             3  2
            - 720*cos(x) *sin(x) *x  - 208*cos(x) *sin(x)  + 252*cos(x) *x

                       2       5  3            2       5
            + 18*cos(x) *sin(x) *x  + 31*cos(x) *sin(x) *x

                       2       3  3            2       3
            - 72*cos(x) *sin(x) *x  - 24*cos(x) *sin(x) *x

                       2         3            2                             6  2
            + 72*cos(x) *sin(x)*x  + 56*cos(x) *sin(x)*x + 153*cos(x)*sin(x) *x

                              6                    4  2                    4
            + 91*cos(x)*sin(x)  - 684*cos(x)*sin(x) *x  - 212*cos(x)*sin(x)

                               2  2                   2               2
            + 900*cos(x)*sin(x) *x  - 32*cos(x)*sin(x)  - 288*cos(x)*x

                      7  3            7              5  3             5
            + 6*sin(x) *x  - 39*sin(x) *x - 36*sin(x) *x  + 318*sin(x) *x

                       3  3             3                3
            + 72*sin(x) *x  - 672*sin(x) *x - 48*sin(x)*x  + 384*sin(x)*x)/2304

          6      7
        *k  + O(k )

taylorcombine(hugo^2 + otto^2);


      2         2      7
cos(x)  + sin(x)  + O(k )


clearrules elliptic_rules;



clear sn, cn, dn, epsilon;



%%% showtime;

comment That's all, folks;


end;


Time for test: 188 ms, plus GC time: 31 ms
@@@@@ Resources used: (1 2 97 10)
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taysimp.red0000644000175000017500000004251611526203062024210 0ustar  giovannigiovannimodule TaySimp;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%     The special Taylor simplification functions
%
%*****************************************************************


exports taysimpp, taysimpsq, taysimpsq!*, expttayrat, expttayrat1;

imports

% from the REDUCE kernel:
        !*f2q, !*k2q, !*p2f, !*p2q, !*t2q, addsq, apply1, denr,
        domainp, evenp, exptsq, invsq, kernp, mk!*sq, mkrn, multf,
        multpq, multsq, mvar, nth, numr, over, pdeg, prepsq, quotsq,
        reversip, sfp, simp, simp!*, tc, to, tpow,

% from the header module:
        !*q2TayExp, !*tay2f, !*tay2q, !*tayexp2q, comp!.tp!.!-p,
        cst!-taylor!*, has!-Taylor!*, find!-non!-zero,
        get!-degreelist, has!-TayVars, invert!-powerlist,
        make!-cst!-coefflis, make!-cst!-powerlist, make!-Taylor!*,
        prune!-coefflist, resimptaylor, TayCfPl, TayCfSq,
        TayCoeffList, TayFlags, TayGetCoeff, Taylor!-kernel!-sq!-p,
        Taylor!*p, Taylor!:, TayMakeCoeff, taymultcoeffs, TayOrig,
        TayTemplate, TayTpElNext, TayTpElPoint, TayTpElVars,
        TpNextList,

% from module Tayintro:
        confusion, Taylor!-error, Taylor!-error!*,

% from module Tayutils:
        addto!-all!-TayTpElOrders, get!-cst!-coeff, smallest!-increment,
        Taylor!*!-nzconstantp, Taylor!*!-zerop,

% from module Tayinterf:
        taylorexpand, taylorexpand!-sf,

% from module Taybasic:
        addtaylor, addtaylor!-as!-sq, invtaylor, makecoeffpairs,
        makecoeffs0, multtaylor, multtaylor!-as!-sq, multtaylorsq,
        quottaylor!-as!-sq;


fluid '(!*taylorautoexpand !*taylorkeeporiginal)$

comment The procedures in this module provide the higher taylor
        manipulation machinery.  Given any s.q. (s.f.,...) they
        return the equivalent Taylor kernel (disguised as a s.q.)
        if the argument contains a Taylor kernel and everything
        else may be Taylor expanded.
        Otherwise the Taylor kernels in the argument are only
        partially combined (but as far as possible);


symbolic procedure taysimpsq u;
  %
  % The argument u is any standard quotient.
  % numerator and denominator are first simplified independently,
  % then the quotient is built.
  % We have four possible cases here, as both expressions
  %  may or may not be Taylor kernels.
  %
  begin scalar nm,dd;
    dd := taysimpf denr u;
    if null numr dd then Taylor!-error('zero!-denom,'taysimpsq)
     else if Taylor!-kernel!-sq!-p dd
      then return taysimpf multf(numr u,!*tay2f invtaylor mvar numr dd);
    nm := taysimpf numr u;
    return
    if Taylor!-kernel!-sq!-p nm
      then if not has!-TayVars(mvar numr nm,dd)
             then !*tay2q resimptaylor
                            multtaylorsq(mvar numr nm,invsq dd)
            else if Taylor!*!-nzconstantp mvar numr nm
             then quotsq(get!-cst!-coeff mvar numr nm,dd)
            else if null !*taylorautoexpand or has!-Taylor!* dd
             then quotsq(nm,dd)
            else taysimpsq!*
                   quottaylor!-as!-sq(
                     nm,
                     taylorexpand(dd,TayTemplate mvar numr nm))
     else quotsq(nm,dd)
  end;

symbolic procedure taysimpsq!* u;
   %
   % Variant of taysimpsq that does not automatically expand
   %  non-Taylor expressions
   %
   taysimpsq u where !*taylorautoexpand := nil;


symbolic procedure taysimpf u;
  %
  % u is a standard form which may contain Taylor subexpressions;
  % value is a standard form
  %
  begin scalar tay,notay,x,flg;
    %
    % Remember the definition of a s.f.:
    %  it is either a domain element,
    %  or it's car is a standard term and it's cdr is a s.f.
    %
    notay := nil ./ 1;
    while u do
      %
      % Split the constituents of the s.f. into non-Taylor and
      %  Taylor parts.  Taylor s.t.'s are simplified accordingly.
      % A domain element can never be a Taylor kernel.
      %
      <>
                 else notay := addsq(notay,x)>>;
         u := if domainp u then nil else cdr u>>;
    %
    % tay is now a Taylor kernel or nil.
    %
    % We first make sure that it is not actually a constant.
    %
    if not null tay and not null TayOrig tay and null numr TayOrig tay
      then return notay
    %
    % If tay is nil, return the non-taylor parts.
    %
     else if null numr notay and not null tay then return !*tay2q tay
     else if null tay or Taylor!*!-zerop tay then return notay;
    %
    % Otherwise the non-taylor parts (if the are non-nil)
    % must be expanded if !*taylorautoexpand is non-nil.
    % The only exception are terms that do not contain
    % any of the Taylor variables: these are always expanded.
    %
    if Taylor!*!-nzconstantp tay and not has!-Taylor!* notay
      then return addsq(get!-cst!-coeff tay,notay)
     else if null !*taylorautoexpand and has!-TayVars(tay,notay)
      then return addsq(!*tay2q tay,notay);
    if flg then return addsq(!*tay2q tay,notay)
     else <<
       notay := taylorexpand(notay,TayTemplate tay);
       return taysimpsq!* addtaylor!-as!-sq(notay,!*tay2q tay)>>
  end;

symbolic procedure taysimpt u;
  %
  % u is a standard term containing one or more Taylor kernels,
  % value is the simplified Taylor expression (also as a s.f.).
  %
  begin scalar rest,pow;
    %
    % Since the coefficient of a term is a s.f.
    % we call taysimpf on it.
    %
    rest := taysimpf tc u;
    if null numr rest then return rest;
    pow := tpow u;
    %
    % Then we have to distinguish three cases:
    %   the case where no Taylor kernel appears was already caught
    %   by taysimpf before taysimpt was called.
    %
    % If combination of different Taylor kernels is impossible
    %   return them separately
    %
    % Remark: the call to SMEMQLP checks if rest contains one of
    %         the Taylor variables if it is not a Taylor kernel.
    %
    return if not has!-Taylor!* pow
      then if Taylor!-kernel!-sq!-p rest
             then multpowerintotaylor(pow,mvar numr rest)
            else multpq(pow,rest)
     else <>
  end;

symbolic procedure multpowerintotaylor (p, tk);
  %
  % p is a standard power, tk a Taylor kernel
  % value is p expanded to a Taylor kernel multiplied by tk
  % this requires Taylor expansion of p if it contains
  % at least one of the expansion variables
  %
  % Remark: the call to SMEMQLP checks if p contains one of
  %         the Taylor variables.
  %
  if not has!-TayVars(tk,p)
    then !*tay2q multtaylorsq(tk,!*p2q p)
   else if !*taylorautoexpand
%    then taysimpsq!*
%           multtaylor!-as!-sq(!*tay2q tk,
%                     taylorexpand(!*p2q p,TayTemplate tk))
%
% here the same comment as above applies
%
    then taysimpsq!*
           multtaylor!-as!-sq(!*tay2q tk,
                     taylorexpand!-sf(!*p2f p,TayTemplate tk,nil))
   else if Taylor!*!-nzconstantp tk
    then multpq(p,get!-cst!-coeff tk)
   else multpq(p,!*tay2q tk);


symbolic procedure taysimpp u;
  %
  % u is a standard power containing a Taylor expression,
  % value is the simplified Taylor expression, as a s.f.
  %
  % We begin by isolating base and exponent.
  % First we simplify them separately.
  % Remember that the exponent is always an integer,
  % base is a kernel.
  %
  % If the main variable of the power is a kernel made of one
  %  of the functions known to the Taylor simplifier, call
  %  the appropriate simplification function.
  %  (There is a user hook here!)
  %
  if null car u or null pdeg u then confusion 'taysimpp
   else if sfp car u then !*p2q u
%%%% taysimpsq exptsq(taysimpf car u,cdr u)
   else if not taylor!*p car u
    then ((if kernp x
             then if (x := mvar numr x) = car u then !*p2q u
                   else if cdr u=1 then !*k2q x
                   else taysimpp(x .** cdr u)
            else if cdr u=1 then x
            else taysimpsq exptsq(x,cdr u))
          where x := (taysimpmainvar car u))
   %
   % We know how to raise a Taylor series to a rational power:
   %  positive integer --> multiply
   %  negative integer --> multiply and invert
   % Zero exponent should not appear: should be already simplified
   %  to 1 by the standard simplifier
   %
   else if not fixp pdeg u or pdeg u = 0 then confusion 'taysimpp
   else if not null TayOrig car u and null numr TayOrig car u
    then (nil ./ 1)
   else !*tay2q
     if pdeg u = 1 then car u else expttayi(car u,cdr u)$


symbolic procedure taysimpmainvar u;
  if not sfp u then taysimpkernel u
   else !*f2q taysimpf u;


symbolic procedure taysimpkernel u;
  begin scalar fn, x;
    u := simp!* u;
    if not kernp u then return u
     else << x := mvar numr u;
             if atom x or Taylor!*p x then return u;
             fn := get (car x, 'taylorsimpfn);
             return if null fn then u
                     else apply1 (fn, x)>>
  end;


symbolic procedure expttayi(u,i);
  %
  % raise Taylor kernel u to integer power i
  % algorithm is a scheme that computes powers of two.
  %
  begin scalar v,flg;
    if i<0 then <>;
    v := if evenp i then cst!-Taylor!*(1 ./ 1,TayTemplate u)
          else <>;
    while (i:=i/2)>0 do <>;
    return if flg then invtaylor v else v
  end;


comment non-integer powers of Taylor kernels;


comment The implementation of expttayrat follows the algorithm
        quoted by Knuth in the second volume of `The Art of
        Computer Programming', extended to the case of series in
        more than one variable.

        Assume you want to compute the series W(x) where

            W(x) = V(x)**alpha

        Differentiation of this equation gives

            W'(x) = alpha * V(x)**alpha * V'(x) .

        You make now the ansatz

                    -----
                    \           n
            W(x) =   >      W  x  ,
                    /        n
                    -----

        substitute this into the above equation and compare
        powers of x.  This yields the recursion formula

                       n-1
                      -----
                  1   \                  m      m
           W  = -----  >    (alpha (1 - ---) - --- ) W  V     .
            n    V    /                  n      n     m  n-m
                  0   -----
                       m=0

        The first coefficient must be calculated directly, it is

           W   = V  ** alpha .
            0     0

        To use this for series in more than one variable you have to
        calculate all partial derivatives: n and m refer then to the
        corresponding component of the multi index.  Looking closely
        one finds that there is an ambiguity: the same coefficient
        can be calculated using any of the partial derivatives.  The
        only restriction is that the corresponding component of the
        multi index must not be zero, since we have to divide by it.

        We resolve this ambiguity by simply taking the first nonzero
        component.

        We use it here only for the case that alpha is a rational
        number;


symbolic procedure expttayrat(tay,rat);
  %
  % tay is a Taylor kernel, rat is a s.q. of two integers
  % value is tay ** rat
  % algorithm as quoted by Knuth
  %
  Taylor!:
  begin scalar clist,tc,tp;
    %
    % First of all we have to find out if we can raise the leading
    %  term to the power rat.
    % If so we calculate the reciprocal of this leading coefficient
    %  and multiply all other terms with it.
    % This guarantees that the resulting Taylor kernel starts with
    %  coefficient 1.
    %
    if not Taylor!*p tay then return simp!* {'expt,tay,mk!*sq rat};
    tc := prune!-coefflist TayCoeffList tay;
    tp := TayTemplate tay;
    %
    % Find first non-zero coefficient.
    %
    if null tc
      then if minusp numr rat
             then Taylor!-error!*('not!-a!-unit,'expttayrat)
            else <>
     else begin scalar c0,l,l1;
       c0 := car tc;
       l1 := for each ll in TayCfPl c0 collect
               for each p in ll collect (p * !*q2TayExp rat);
       l := invert!-powerlist TayCfPl c0;
       tp := addto!-all!-TayTpElOrders(tp,get!-degreelist l);
       l := TayMakeCoeff(l,invsq TayCfSq c0);
       %
       % We divide the rest of the kernel (without the leading term)
       %  by the leading term.
       %
       l := for each el in cdr tc collect taymultcoeffs(el,l);
       clist := expttayrat1(tp,l,rat);
       %
       % Next we multiply the resulting Taylor kernel by the leading
       %  coefficient raised to the power rat.
       %
       c0 := TayMakeCoeff(l1,simp!* {'expt,mk!*sq TayCfSq c0,
                                     {'quotient,numr rat,denr rat}});
       clist := for each el in clist collect taymultcoeffs(el,c0);
       tp := addto!-all!-TayTpElOrders(tp,get!-degreelist l1);
    end;
    %
    % Finally we fill in the original expression
    %
    return make!-Taylor!*(
             clist,
             tp,
             if !*taylorkeeporiginal and TayOrig tay
               then simp {'expt,prepsq TayOrig tay,
                          {'quotient,car rat,cdr rat}}
              else nil,
             TayFlags tay)
  end;

symbolic procedure expttayrat1(tp,tcl,rat);
  Taylor!:
   begin scalar clist,coefflis,il,l0,rat1;
     rat1 := addsq(rat,1 ./ 1);
     %
     % Now we compute the coefficients
     %
     l0 := make!-cst!-powerlist tp;
     clist := {TayMakeCoeff(l0,1 ./ 1)};
     tcl := TayMakeCoeff(l0,1 ./ 1) . tcl;
     il := smallest!-increment tcl;
     coefflis := makecoeffs0(tp,TpNextList tp,il);
     if null coefflis then return clist;
     for each cc in cdr coefflis do
       begin scalar s,pos,pp,q,n,n1;
         s := nil ./ 1;
         pos := find!-non!-zero cc;
         n := nth(nth(cc,car pos),cdr pos);
         pp := makecoeffpairs(l0,cc,l0,il);
         for each p in pp do begin scalar v,w;
           v := TayGetCoeff(cdr p,tcl);
           w := TayGetCoeff(car p,clist);
           %
           % The following line is a short cut for efficiency.
           %
           if null numr v or null numr w then return;
           w := multsq(w,v);
           n1 := nth(nth(car p,car pos),cdr pos);
           q := quotsq(!*TayExp2q(-n1),!*TayExp2q n);
           s := addsq(s,multsq(addsq(rat,multsq(q,rat1)),w))
          end;
         if not null numr s then clist := TayMakeCoeff(cc,s) . clist
       end;
     return reversip clist
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayfns.red0000644000175000017500000013454611526203062024033 0ustar  giovannigiovannimodule TayFns;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%       Simplification functions for special functions
%
%*****************************************************************


exports taysimpexpt, taysimpatan, taysimplog, taysimpexp,
        taysimptan, taysimpsin, taysimpsinh, taysimpasin;

imports

% from the REDUCE kernel:
        !*f2q, !:minusp, addsq, aeval, denr, domainp, eqcar, evenp,
        freeof, invsq, kernp, lastpair, let, lprim, lnc, mk!*sq, mksq,
        multsq, mvar, negsq, neq, nlist, nth, numr, over, prepd,
        prepsq, quotsq, retimes, reval, reversip, simp, simp!*,
        simplogi, simplogsq, subs2!*, subsq, subtrsq,

% from the header module:
        !*tay2q, !*TayExp2q, constant!-sq!-p, cst!-Taylor!*,
        find!-non!-zero, get!-degree, has!-TayVars,
        make!-cst!-powerlist, make!-Taylor!*, prune!-coefflist,
        set!-TayCoeffList, set!-TayFlags, set!-TayOrig, TayCfPl,
        TayCfSq, TayCoeffList, TayFlags, TayGetCoeff, Taylor!*p,
        Taylor!-kernel!-sq!-p, Taylor!:, TayMakeCoeff, TayOrig,
        TayTemplate, TayTpElNext, TayTpElOrder, TayTpElPoint,
        TayTpElVars, TayTpVars, TayVars, TpNextList,

% from the module Tayintro:
        confusion, delete!-nth, delete!-nth!-nth, replace!-nth,
        replace!-nth!-nth, Taylor!-error, Taylor!-error!*,
        var!-is!-nth,

% from the module Tayutils:
        addto!-all!-TayTpElORders, get!-cst!-coeff, is!-neg!-pl,
        smallest!-increment, subtr!-degrees, Taylor!*!-constantp,
        Taylor!*!-zerop,

% from the module Taybasic:
        addtaylor, addtaylor!-as!-sq, invtaylor, makecoeffs0,
        makecoeffpairs, makecoeffpairs1, multtaylor,
        multtaylor!-as!-sq, multtaylorsq, negtaylor, negtaylor1,
        quottaylor,

% from the module TayExpnd:
        taylorexpand,

% from the module Taysimp:
        expttayrat, taysimpsq, taysimpsq!*,

% from the module Taydiff:
        difftaylorwrttayvar,

% from the module TayConv:
        prepTayCoeff, prepTaylor!*,

% from the module Tayfrontend:
        taylorcombine, taylortostandard;


fluid '(!*taylorkeeporiginal !*!*taylor!-epsilon!*!* frlis!*);


symbolic procedure taysimpexpt u;
  %
  % Argument is of the form ('expt base exponent)
  % where both base and exponent (but a least one of them)
  % may contain Taylor kernels given as prefix forms.
  % Value is the equivalent Taylor kernel.
  %
  if not (car u eq 'expt) or cdddr u then confusion 'taysimpexpt
   else if cadr u eq 'e then taysimpexp {'exp, caddr u}
   else begin scalar bas, expn;
     bas := taysimpsq simp!* cadr u;
     expn := taysimpsq simp!* caddr u;
     if constant!-sq!-p bas then return taysimpexp
         {'exp,mk!*sq multsq(simp!*{'log,mk!*sq bas},expn)};
     if null kernp bas
       then if not(denr bas = 1)
              then return mksq({'expt,prepsq bas,prepsq expn},1)
             else if domainp numr bas
              then return taysimpexp {'exp,
                  prepsq multsq(simp!* {'log,prepd numr bas},expn)}
             else return mksq({'expt,prepsq bas,prepsq expn},1);
     if fixp numr expn and fixp denr expn
       then return !*tay2q expttayrat(mvar numr bas,expn);
     if denr expn = 1 and eqcar(numr expn,'!:rn!:)
       then return !*tay2q expttayrat(mvar numr bas,cdr numr expn);
     bas := mvar numr bas;
     return
       if Taylor!*p bas
         then if Taylor!-kernel!-sq!-p expn
                then if TayTemplate bas = TayTemplate mvar numr expn
                       then taysimpexp {'exp,
                                        mk!*sq taysimpsq
                                          multtaylor!-as!-sq(
                                              expn,
                                              taysimplog {'log,bas})}
                      else mksq({'expt,bas,mvar numr expn},1)
               else if not has!-TayVars(bas,expn)
                then begin scalar logterm;
                  logterm := taysimplog{'log,bas};
                  return
                    if Taylor!-kernel!-sq!-p logterm
                      then taysimpexp{'exp,
                                      multtaylorsq(mvar numr logterm,
                                                   expn)}
                     else taysimpsq
                            simp!* {'exp,mk!*sq multsq(logterm,expn)}
                 end
               else mksq({'expt,bas,mk!*sq expn},1)
        else if Taylor!-kernel!-sq!-p expn
               then if not has!-TayVars(mvar numr expn,bas)
                      then taysimpexp{'exp,
                                      multtaylorsq(mvar numr expn,
                                                   simp!*{'log,bas})}
                     else if Taylor!*!-constantp mvar numr expn
                      then taylorexpand(
                             simp!* {'expt,bas,
                                     prepTaylor!* mvar numr expn},
                             TayTemplate mvar numr expn)
                     else mksq({'expt,bas,mk!*sq expn},1)
        else mksq({'expt,bas,mk!*sq expn},1);
  end;

put('expt,'taylorsimpfn,'taysimpexpt);


symbolic procedure TayCoeffList!-union u;
  if null cdr u then car u
   else TayCoeffList!-union2 (car u, TayCoeffList!-union cdr u)$

symbolic procedure TayCoeffList!-union2 (x, y);
  %
  % returns union of TayCoeffLists x and y
  %
  << for each w in y do
       if null (assoc (car w, x)) then x := w . x;
     x >>$

symbolic procedure inttaylorwrttayvar(tay,var);
  %
  % integrates Taylor kernel tay wrt variable var
  %
  inttaylorwrttayvar1(TayCoeffList tay,TayTemplate tay,var)$

symbolic procedure inttaylorwrttayvar1(tcl,tp,var);
  %
  % integrates Taylor kernel with TayCoeffList tcl and template tp
  %  wrt variable var
  %
  Taylor!:
  begin scalar tt,u,w,singlist,csing; integer n,n1,m;
    u := var!-is!-nth(tp,var);
    n := car u;
    n1 := cdr u;
    tt := nth(tp,n);
    u := for each cc in tcl join <<
           m := nth(nth(TayCfPl cc,n),n1);
           if TayTpElPoint nth(tp,n) eq 'infinity
             then <<
               if m=1 then <>
                else {TayMakeCoeff(
                        replace!-nth!-nth(TayCfPl cc,n,n1,m-1),
                        multsq(TayCfSq cc,invsq !*TayExp2q(-m + 1)))}>>
            else <<
               if m=-1 then <>
               else {TayMakeCoeff(
                       replace!-nth!-nth(TayCfPl cc,n,n1,m+1),
                       multsq(TayCfSq cc,invsq !*TayExp2q(m + 1)))}>>>>;
    w := {TayTpElVars tt,TayTpElPoint tt,
          if var member TayTpElVars tt
            then if TayTpElPoint tt eq 'infinity
                   then TayTpElOrder tt - 1
                  else TayTpElOrder tt + 1
           else TayTpElOrder tt,
          if var member TayTpElVars tt
            then if TayTpElPoint tt eq 'infinity
                   then TayTpElNext tt - 1
                  else TayTpElNext tt + 1
           else TayTpElOrder tt};
    if singlist then begin scalar tpel;
        tpel := nth(tp,n);
        singlist := reversip singlist;
        if TayCfPl car singlist = '(nil) % no Taylor left
          then csing := TayCfSq car singlist
         else csing := !*tay2q
                         make!-Taylor!*(
                           singlist,
                           replace!-nth(
                             tp,n,
                             {delete!-nth(TayTpElVars tpel,n1),
                              TayTpElPoint tpel,
                              TayTpElOrder tpel,
                              TayTpElNext tpel}),
                           nil,nil);
        csing := multsq(csing,simp!* {'log,nth(TayTpElVars tpel,n1)})
       end;

    return (csing . make!-Taylor!*(u,replace!-nth(tp,n,w),nil,nil))
%
% The following is not needed yet
%
%     return make!-Taylor!*(
%              u,
%              replace!-nth(TayTemplate tay,n,w),
%              if !*taylorkeeporiginal and TayOrig tay
%                then simp {'int,mk!*sq TayOrig tay,var}
%               else nil,
%              TayFlags u)
  end;


comment The inverse trigonometric and inverse hyperbolic functions
        of a Taylor kernel are calculated by first computing the
        derivative(s) with respect to the Taylor variable(s) and
        integrating the result.  The derivatives can easily be
        calculated by the manipulation functions defined above.

        The method is best illustrated with an example.  Let T(x)
        be a Taylor kernel depending on one variable x.  To compute
        the inverse tangent T1(x) = atan(T(x)) we calculate the
        derivative

                                T'(x)
                    T1'(x) = ----------- .
                                      2
                              1 + T(x)

        (If T and T1 depend on more than one variable replace
        the derivatives by gradients.)
        This is integrated again with the integration constant
        T1(x0) = atan(T(x0)) yielding the desired result.
        If there is more than variable we have to find the
        potential function T1(x1,...,xn) corresponding to
        the vector grad T1(x1,...,xn) which is always possible
        by construction.

        The prescriptions for the eight functions asin, acos, asec,
        acsc, asinh, acosh, asech, and acsch can be put together
        in one procedure since the expressions for their derivatives
        differ only in certain signs.  The same remark applies to
        the four functions atan, acot, atanh, and acoth.

        These expressions are:

         d                 1
         -- asin x = ------------- ,
         dx           sqrt(1-x^2)

         d                -1
         -- acos x = ------------- ,
         dx           sqrt(1-x^2)

         d                 1
         -- asinh x = ------------- ,
         dx            sqrt(1+x^2)

         d                 1
         -- acosh x = ------------- ,
         dx            sqrt(x^2-1)

         d               1
         -- atan x = --------- ,
         dx           1 + x^2

         d               -1
         -- acot x = --------- ,
         dx           1 + x^2

         d                1
         -- atanh x = --------- ,
         dx            1 - x^2

         d                1
         -- acoth x = --------- ,
         dx            1 - x^2

        together with the relations

                       1
         asec x = acos - ,
                       x

                       1
         acsc x = asin - ,
                       x

                         1
         asech x = acosh - ,
                         x

                         1
         acsch x = asinh -
                         x .


        This method has one drawback: it is applicable only when T(x0)
        is a regular point of the function in question. E.g., if T(x0)
        = 0, then asech(T(x)) cannot be calculated by this method, as
        asech has a logarithmic singularity at 0. This means that the
        constant term of the series cannot be determined by computing
        asech(T(x0)).  In that case, we use the following relations
        instead:


         asin z = -i log(i z + sqrt(1 - z^2)),


         acos z = -i log(z + sqrt(z^2 - 1)),

                    1        1 + i z
         atan z = ----- log ---------,
                   2 i       1 - i z

                   -1        i z + 1
         acot z = ----- log ---------,
                   2 i       i z - 1


         asinh z = log(z + sqrt(1 + z^2)),


         acosh z = log(z + sqrt(z^2 - 1)),

                    1       1 + z
         atanh z = --- log -------,
                    2       1 - z

                    1       z + 1
         acoth z = --- log -------.
                    2       z - 1


         These formulas are applied at the following points:

           infinity for all functions,

           +i/-i for atan and acot,

           +1/-1 for atanh and acoth.


         There are still some branch points, where the calculation is
         not always possible:

           +1/-1 for asin and acos, and consequently for asec and acsc,

           +i/-i for asinh, acosh, asech and acsch.

         In these cases, the above formulas are applied as well, but
         simplification of the square roots and the logarithm may lead
         to a rather complicated result;



symbolic procedure taysimpasin u;
  if not (car u memq '(asin acos acsc asec asinh acosh acsch asech))
     or cddr u
    then confusion 'taysimpasin
   else Taylor!:
     begin scalar l,l0,c0,v,tay0,tay,tay2,tp,singlist;
     tay0 := taysimpsq simp!* cadr u;
     if not Taylor!-kernel!-sq!-p tay0
       then return mksq({car u,mk!*sq tay0},1);
     tay0 := mvar numr tay0; % asin's argument
     l0 := make!-cst!-powerlist TayTemplate tay0;
     c0 := TayGetCoeff(l0,TayCoeffList tay0);
     if car u memq '(asec acsc asech acsch)
       then if null numr c0 then return taysimpasec!*(car u,tay0)
             else tay := invtaylor tay0
      else tay := tay0;
     tp := TayTemplate tay;
     l := prune!-coefflist TayCoeffList tay;
     if null l then return !*tay2q cst!-Taylor!*(simp!* {car u,0},tp);
     if is!-neg!-pl TayCfPl car l then return taysimpasin!*(car u,tay);
     tay2 := multtaylor(tay,tay);
     if car u memq '(asin acos acsc asec)
       then tay2 := negtaylor tay2;
     tay2 := addtaylor(
               cst!-Taylor!*(
                 !*f2q(if car u memq '(acosh asech) then -1 else 1),
                 tp),
               tay2);
     if Taylor!*!-zerop tay2
       then Taylor!-error!*('branch!-point,car u)
      else if null numr TayGetCoeff(l0,TayCoeffList tay2)
       then return taysimpasin!*(car u,tay);

     tay2 := invtaylor expttayrat(tay2,1 ./ 2);
     if car u memq '(acos asec) then tay2 := negtaylor tay2;
     l := for each krnl in TayVars tay collect
            inttaylorwrttayvar(
              multtaylor(difftaylorwrttayvar(tay,krnl),tay2),
              krnl);
     v := TayCoeffList!-union
            for each pp in l collect TayCoeffList cdr pp;
     singlist := nil ./ 1;
     for each pp in l do
       if car pp then singlist := addsq(singlist,car pp);
     %
     % special treatment for zeroth coefficient
     %
     c0 := simp {car u,mk!*sq c0};
     v := TayMakeCoeff(l0,c0) . v;
     tay := make!-Taylor!*(
              v,
              tp,
              if !*taylorkeeporiginal and TayOrig tay
                then simp {car u,mk!*sq TayOrig tay}
               else nil,
              TayFlags tay);
     if null numr singlist then return !*tay2q tay;
     if !*taylorkeeporiginal and TayOrig tay
       then set!-TayOrig(tay,subtrsq(TayOrig tay,singlist));
     return addsq(singlist,!*tay2q tay)
  end;

symbolic procedure taysimpasec!*(fn,tay);
   begin scalar result,tay1,tay2,i1;
     i1 := simp 'i;
     if fn memq '(asin acsc) then tay := multtaylorsq(tay,i1);
     tay1 := cst!-Taylor!*(1 ./ 1,TayTemplate tay);
     tay2 := multtaylor(tay,tay);
     if fn memq '(asec asech) then tay2 := negtaylor tay2;
     result := taysimplog {'log,
                           addtaylor(
                             expttayrat(addtaylor(tay2,tay1),1 ./ 2),
                             tay1)};
     tay1 := taysimplog {'log,tay};
     if fn memq '(asin acos asec acsc)
       then <>
      else result := addtaylor!-as!-sq(result,
                                       negsq taysimplog {'log,tay});
     return taysimpsq!* result
   end;

symbolic procedure taysimpasin!*(fn,tay);
   begin scalar result,tay1;
     if fn memq '(asin acsc)
       then tay := multtaylorsq(tay,simp 'i);
     tay1 := cst!-Taylor!*(
               (if fn memq '(asin asinh acsc acsch)
                  then 1
                 else -1) ./ 1,
                TayTemplate tay);
     result := taysimplog {'log,
                           addtaylor(
                             expttayrat(addtaylor(multtaylor(tay,tay),
                                                  tay1),
                                        1 ./ 2),
                             tay)};
     if fn memq '(asin acos asec acsc)
       then result := quotsq(result,simp 'i);
     return taysimpsq!* result
   end;


put('asin,'taylorsimpfn,'taysimpasin);
put('acos,'taylorsimpfn,'taysimpasin);
put('asec,'taylorsimpfn,'taysimpasin);
put('acsc,'taylorsimpfn,'taysimpasin);
put('asinh,'taylorsimpfn,'taysimpasin);
put('acosh,'taylorsimpfn,'taysimpasin);
put('asech,'taylorsimpfn,'taysimpasin);
put('acsch,'taylorsimpfn,'taysimpasin);


symbolic procedure taysimpatan u;
  if not (car u memq '(atan acot atanh acoth)) or cddr u
    then confusion 'taysimpatan
   else begin scalar l,l0,c0,v,tay,tay2,tp,singlist;
     tay := taysimpsq simp!* cadr u;
     if not Taylor!-kernel!-sq!-p tay
       then return mksq({car u,mk!*sq tay},1);
     tay := mvar numr tay; % atan's argument
     tp := TayTemplate tay;
     l0 := make!-cst!-powerlist tp;
     l := prune!-coefflist TayCoeffList tay;
     if null l then return !*tay2q cst!-Taylor!*(simp!* {car u,0},tp);
     if is!-neg!-pl TayCfPl car l then return taysimpatan!*(car u,tay);
     c0 := get!-cst!-coeff tay;
     if car u memq '(atan acot)
       then c0 := subs2!* multsq(c0,simp 'i);
     if c0 = (1 ./ 1) or c0 = (-1 ./ 1)
       then return taysimpatan!*(car u,tay);
     tay2 := multtaylor(tay,tay);
     if car u memq '(atanh acoth) then tay2 := negtaylor tay2;
     tay2 := invtaylor addtaylor(cst!-Taylor!*(1 ./ 1,tp),tay2);
     if car u eq 'acot then tay2 := negtaylor tay2;
     l := for each krnl in TayVars tay collect
            inttaylorwrttayvar(
              multtaylor(difftaylorwrttayvar(tay,krnl),tay2),
              krnl);
     v := TayCoeffList!-union
            for each pp in l collect TayCoeffList cdr pp;
     singlist := nil ./ 1;
     for each pp in l do
       if car pp then singlist := addsq(singlist,car pp);
     %
     % special treatment for zeroth coefficient
     %
     c0 := simp {car u,
                 mk!*sq TayGetCoeff(l0,TayCoeffList tay)};
     v := TayMakeCoeff (l0,c0) . v;
     tay := make!-Taylor!*(
              v,
              tp,
              if !*taylorkeeporiginal and TayOrig tay
                then simp {car u,mk!*sq TayOrig tay}
               else nil,
              TayFlags tay);
     if null numr singlist then return !*tay2q tay;
     if !*taylorkeeporiginal and TayOrig tay
       then set!-TayOrig(tay,subtrsq(TayOrig tay,singlist));
     return addsq(singlist,!*tay2q tay)
  end;

symbolic procedure taysimpatan!*(fn,tay);
   begin scalar result,tay1;
     if fn memq '(atan acot)
       then tay := multtaylorsq(tay,simp 'i);
     tay1 := cst!-Taylor!*(1 ./ 1,TayTemplate tay);
     tay := quottaylor(addtaylor(tay1,tay),
                       addtaylor(tay1,negtaylor tay));
     result := multsq(taysimplog {'log,tay},1 ./ 2);
     if fn eq 'atan then result := quotsq(result,simp 'i)
      else if fn eq 'acot then result := multsq(result,simp 'i);
     return taysimpsq!* result
   end;



put('atan,'taylorsimpfn,'taysimpatan);
put('acot,'taylorsimpfn,'taysimpatan);
put('atanh,'taylorsimpfn,'taysimpatan);
put('acoth,'taylorsimpfn,'taysimpatan);


comment For the logarithm and exponential we use the extension of
        an algorithm quoted by Knuth who shows how to do this for
        series in one expansion variable.

        We extended this to the case of several variables which is
        straightforward except for one point, see below.
        Knuth's algorithm works as follows: Assume you want to compute
        the series W(x) where

            W(x) = log V(x)

        Differentiation of this equation gives

                    V'(x)
            W'(x) = ----- ,   or V'(x) = W'(x)V(x) .
                     V(x)

        You make now the ansatz

                    -----
                    \           n
            W(x) =   >      W  x  ,
                    /        n
                    -----

        substitute this into the above equation and compare
        powers of x.  This yields the recursion formula

                               n-1
                 V            -----
                  n       1   \
           W  = ---- - ------  >    m W  V     .
            n    V      n V   /        m  n-m
                  0        0  -----
                               m=0

        The first coefficient must be calculated directly, it is

           W   = log V  .
            0         0

        To use this for series in more than one variable you have to
        calculate all partial derivatives: n and m refer then to the
        corresponding component of the multi index.  Looking closely
        one finds that there is an ambiguity: the same coefficient
        can be calculated using any of the partial derivatives.  The
        only restriction is that the corresponding component of the
        multi index must not be zero, since we have to divide by it.

        We resolve this ambiguity by simply taking the first nonzero
        component.

        The case of the exponential is nearly the same: differentiation
        gives

            W'(x) = V'(x) W(x) ,

        from which we derive the recursion formula

                   n-1
                  -----
                  \     n-m
            W  =   >    --- W  V     , W  = exp V  .
             n    /      m   m  n-m     0        0
                  -----
                   m=0

        ;


symbolic procedure taysimplog u;
  %
  % Special Taylor expansion function for logarithms
  %
  if not (car u eq 'log) or cddr u then confusion 'taysimplog
   else Taylor!:
    begin scalar a0,clist,coefflis,il,l0,l,tay,tp,csing,singterm;
    u := simplogi cadr u;
    if not kernp u then return taysimpsq u;
    u := mvar numr u;
    if not (car u eq 'log) then confusion 'taysimplog;
    u := taysimpsq simp!* cadr u;
    if not Taylor!-kernel!-sq!-p u then return mksq({'log,mk!*sq u},1);
    tay := mvar numr u;
    tp := TayTemplate tay;
    l0 := make!-cst!-powerlist tp;
    %
    % The following relies on the standard ordering of the
    % TayCoeffList.
    %
    l := prune!-coefflist TayCoeffList tay;
    if null l then Taylor!-error!*('not!-a!-unit,'taysimplog);
    %
    % The assumption at this point is that the first term is the one
    % with lowest degree, i.e. dividing by this term yields a series
    % which starts with a constant term.
    %
    if TayCfPl car l neq l0 then
      <>>>;
    a0 := TayGetCoeff(l0,l);
    clist := {TayMakeCoeff(l0,simplogi mk!*sq a0)};
    il := if null l then nlist(1,length tp)
           else smallest!-increment l;
    coefflis := makecoeffs0(tp,TpNextList tp,il);
    if not null coefflis
      then for each cc in cdr coefflis do
             begin scalar s,pos,pp,n,n1;
               s := nil ./ 1;
               pos := find!-non!-zero cc;
               n := nth(nth(cc,car pos),cdr pos);
               pp := makecoeffpairs(l0,cc,TayCfPl car l,il);
               for each p in pp do <<
                 n1 := nth(nth(car p,car pos),cdr pos);
                 s := addsq(s,
                            multsq(!*TayExp2q n1,
                                   multsq(TayGetCoeff(car p,clist),
                                          TayGetCoeff(cdr p,l))))>>;
%               for each p in pp addsq
%                 multsq(!*TayExp2q nth(nth(car p,car pos),cdr pos),
%                        multsq(TayGetCoeff(car p,clist),
%                               TayGetCoeff(cdr p,l)));
               s := subtrsq(TayGetCoeff(cc,l),quotsq(s,!*TayExp2q n));
               if not null numr s
                 then clist := TayMakeCoeff(cc,quotsq(s,a0)) . clist;
             end;
    tay := make!-Taylor!*(
             reversip clist,
             tp,
             if !*taylorkeeporiginal and TayOrig tay
               then simplogi mk!*sq TayOrig tay
              else nil,
             TayFlags tay);
    if null csing then return !*tay2q tay;
    singterm := simplogsq singterm;
    if Taylor!*!-zerop tay then return singterm;
    if !*taylorkeeporiginal and TayOrig tay
      then set!-TayOrig(tay,subtrsq(TayOrig tay,singterm));
    return addsq(singterm,!*tay2q tay)
  end;

put('log,'taylorsimpfn,'taysimplog);


symbolic procedure taysimpexp u;
  %
  % Special Taylor expansion function for exponentials
  %
  if not (car u eq 'exp) or cddr u then confusion 'taysimpexp
   else Taylor!:
    begin scalar a0,clist,coefflis,il,l0,l,lm,lp,tay,tp;
    u := taysimpsq simp!* cadr u;
    if not Taylor!-kernel!-sq!-p u
      then return mksq ({'exp,mk!*sq u},1);
    tay := mvar numr u;
    tp := TayTemplate tay;
    l0 := make!-cst!-powerlist tp;
    %
    % The following relies on the standard ordering of the
    % TayCoeffList.
    %
    l := prune!-coefflist TayCoeffList tay;
    if null l then return !*tay2q cst!-Taylor!*(1 ./ 1,tp);
    for each pp in l do
      if is!-neg!-pl TayCfPl pp then lm := pp . lm
       else if not null numr TayCfSq pp then lp := pp . lp;
    lm := reversip lm;
    l := reversip lp;

    if lm
      then lm := simp!* {'exp,
                         preptaylor!* make!-Taylor!*(lm,tp,nil,nil)};

    if null l then return lm;

    a0 := TayGetCoeff(l0,l);
    clist := {TayMakeCoeff(l0,simp!* {'exp,mk!*sq a0})};
    il := smallest!-increment l;
    coefflis := makecoeffs0(tp,TpNextList tp,il);

    if not null coefflis
      then for each cc in cdr coefflis do
             begin scalar s,pos,pp,n,n1;
               s := nil ./ 1;
               pos := find!-non!-zero cc;
               n := nth(nth(cc,car pos),cdr pos);
               pp := makecoeffpairs(l0,cc,l0,il);
               for each p in pp do <<
                 n1 := nth(nth(car p,car pos),cdr pos);
                 s := addsq(s,
                            multsq(!*TayExp2q(n - n1),
                                   multsq(TayGetCoeff(car p,clist),
                                          TayGetCoeff(cdr p,l))))>>;
               s := subs2!* quotsq(s,!*TayExp2q n);
               if not null numr s
                 then clist := TayMakeCoeff(cc,s) . clist
             end;

    clist := reversip clist;

    u := !*tay2q
           make!-Taylor!*(
             clist,
             tp,
             if !*taylorkeeporiginal and TayOrig tay
               then simp {'exp,mk!*sq TayOrig tay}
              else nil,
             TayFlags tay);
    return if null lm then u else multsq(u,lm)
  end;

put('exp,'taylorsimpfn,'taysimpexp);


comment The algorithm for the trigonometric functions is also
        derived from their differential equation.
        The simplest case is that of tangent whose equation is

                            2
           tan'(x) = 1 + tan (x) .          (*)

        For the others we have

                               2
           cot'(x) = - (1 + cot (x)),

                              2
           tanh'(x) = 1 - tanh (x),

                              2
           coth'(x) = 1 - coth (x) .



        Let T(x) be a Taylor series,

                  -----
                  \         N
           T(x) =  >    a  x
                  /      N
                  -----
                   N=0

        Now, let

                              -----
                              \         N
           T1(x) = tan T(x) =  >    b  x
                              /      N
                              -----
                               N=0

        from which we immediately deduce that b  = tan a .
                                               0        0

        From (*) we get
                              2
           T1'(x) = (1 + T1(x) ) T'(x) ,

        or, written in terms of the series:

        Inserting this into (*) we get

          -----              /     /  -----       \ 2 \  -----
          \           N-1    |     |  \         N |   |  \           L
           >    N b  x    =  | 1 + |   >    b  x  |   |   >    L a  x
          /        N         |     |  /      N    |   |  /        L
          -----              \     \  -----       /   /  -----
           N=1                         N=0                L=1

        We perform the square on the r.h.s. using Cauchy's rule
        and obtain:


           -----
           \           N-1
            >    N b  x    =
           /        N
           -----
            N=1

                              N
               /     -----  -----            \  -----
               |     \      \              N |  \           L
               | 1 +  >      >    b    b  x  |   >    L a  x  .
               |     /      /      N-M  M    |  /        L
               \     -----  -----            /  -----
                      N=0    M=0                 L=1

        Expanding this once again with Cauchy's product rule we get

           -----
           \           N-1
            >    N b  x    =
           /        N
           -----
            N=1

                                L-1     N
           -----      /        -----  -----                    \
           \      L-1 |        \      \                        |
            >    x    | L a  +  >      >    b    b  (L-N) a    | .
           /          |    L   /      /      N-M  M        L-N |
           -----      \        -----  -----                    /
            L=1                 N=0    M=0

        From this we immediately deduce the recursion relation

                      L-1                 N
                     -----              -----
                     \       L-N        \
           b  = a  +  >     ----- a      >    b    b  .  (**)
            L    L   /        L    L-N  /      N-M  M
                     -----              -----
                      N=0                M=0

        This relation is easily generalized to the case of a
        series in more than one variable, where the same comments
        apply as in the case of log and exp above.

        For the hyperbolic tangent the relation is nearly the same.
        Since its differential equation has a `-' where that of
        tangent has a `+' we simply have to do the same substitution
        in the relation (**).  For the cotangent we get an additional
        overall minus sign.

        There is one additional problem to be handled: if the constant
        term of T(x), i.e. T(x0) is a pole of tangent. This can be
        solved quite easily: for a small quantity TAYEPS we calculate

             Te(x) = T(x) + TAYEPS .

        and perform the above calculation for Te(x). Then we recover
        the desired result via the relation

            tan T(x)  = tan (Te(x) - TAYEPS)

                           tan Te(x) - tan TAYEPS
                      = ---------------------------- .
                         1 + tan Te(x) * tan TAYEPS

        For the other functions we have similar relations:

            tanh T(x) = tanh (Te(x) - TAYEPS)

                           tanh Te(x) - tanh TAYEPS
                      = ------------------------------ ,
                         1 - tanh Te(x) * tanh TAYEPS

            cot T(x)  = cot (Te(x) - TAYEPS)

                         1 + cot Te(x) * cot TAYEPS
                      = ---------------------------- ,
                           cot TAYEPS - cot Te(x)

            coth T(x) = coth (Te(x) - TAYEPS)

                         1 - coth Te(x) * coth TAYEPS
                      = ------------------------------ .
                           coth Te(x) - coth TAYEPS

        We know that this result is independent of TAYEPS, and we can
        thus evaluate it for any value of TAYEPS.

        Since we further know that T(x0) is a pole of the function in
        question, we can express tan (T(x0) + TAYEPS) as

                                1
                        - ------------ ,
                           tan TAYEPS

        and similarly all the other possible expressions involving
        TAYEPS can be written in terms of tan TAYEPS and tanh TAYEPS,
        respectively. This makes it possible to just substitute any
        occurrence of tan TAYEPS or tanh TAYEPS by zero, which greatly
        simplifies the final calculation

        ;


!*!*taylor!-epsilon!*!* := compress '(t a y e p s);

symbolic procedure taysimptan u;
  %
  % Special Taylor expansion function for circular and hyperbolic
  %  tangent and cotangent
  %
  if not (car u memq '(tan cot tanh coth)) or cddr u
    then confusion 'taysimptan
   else Taylor!:
    begin scalar a,a0,clist,coefflis,il,l0,l,poleflag,tay,tp;
    tay := taysimpsq simp!* cadr u;
    if not Taylor!-kernel!-sq!-p tay
      then return mksq({car u,mk!*sq tay},1);
    tay := mvar numr tay;
    tp := TayTemplate tay;
    l0 := make!-cst!-powerlist tp;
    %
    % First we get rid of possible zero coefficients.
    %
    l := prune!-coefflist TayCoeffList tay;
%    if null l then return !*tay2q cst!-Taylor!*(simp!* {car u,0},tp);
    %
    % The following relies on the standard ordering of the
    % TayCoeffList.
    %
    if not null l and is!-neg!-pl TayCfPl car l
      then Taylor!-error('essential!-singularity,car u);
    a0 := TayGetCoeff(l0,l);
    il := if null l then nlist(1,length tp)
           else smallest!-increment l;
    %
    %%% handle poles of function
    %
    a := quotsq(a0,simp 'pi);
    if car u memq '(tanh coth) then a := subs2!* multsq(a,simp 'i);
    if car u memq '(tan tanh) and
       denr(a := multsq(a,simp '2)) = 1 and
       fixp (a := numr a) and not evenp a
       or car u memq '(cot coth) and denr a = 1 and
          (null (a := numr a) or fixp a)
      then <<
        %
        % OK, now we are at a pole, so we add a small quantity, compute
        %  the series and use the addition formulas to get the real
        %  result.
        %
        poleflag := t;
        a0 := if car u eq 'tan
                then negsq invsq simp!* {'tan,!*!*taylor!-epsilon!*!*}
               else if car u eq 'tanh
                then invsq simp!* {'tanh,!*!*taylor!-epsilon!*!*}
               else if car u eq 'cot
                then invsq simp!* {'tan,!*!*taylor!-epsilon!*!*}
               else invsq simp!* {'tanh,!*!*taylor!-epsilon!*!*};
        clist := {TayMakeCoeff(l0,a0)};
        >>
     else clist := {TayMakeCoeff(l0,simp!* {car u,mk!*sq a0})};
    %
    coefflis := makecoeffs0(tp,TpNextList tp,il);

    if not null coefflis
      then for each cc in cdr coefflis do
             begin scalar cf,s,pos,x,y,n,n1;
               s := nil ./ 1;
               pos := find!-non!-zero cc;
               n := nth(nth(cc,car pos),cdr pos);
               for each p in makecoeffpairs(l0,cc,l0,il) do <<
                 x := reversip makecoeffpairs1(l0,car p,l0,il);
                 y := nil ./ 1;
                 for each z in x do
                   y := addsq(y,multsq(TayGetCoeff(car z,clist),
                                       TayGetCoeff(cdr z,clist)));
                 n1 := nth(nth(car p,car pos),cdr pos);
                 s := addsq(s,
                            multsq(!*TayExp2q(n - n1),
                                   multsq(y,TayGetCoeff(cdr p,l))))>>;
               cf := quotsq(s,!*TayExp2q n);
               if car u memq '(tanh coth) then cf := negsq cf;
               cf := addsq(TayGetCoeff(cc,l),cf);
               if null numr cf then return;  % short cut for efficiency
               if car u eq 'cot then cf := negsq cf;
               clist := TayMakeCoeff(cc,cf) . clist
             end;
    a := make!-Taylor!*(reversip clist,tp,nil,nil);
    %
    % Construct ``real'' series in case of pole
    %
    if poleflag then begin scalar x;
       x := if car u eq 'cot
              then cst!-Taylor!*(
                     invsq simp {'tan,!*!*taylor!-epsilon!*!*},tp)
             else if car u eq 'coth
              then cst!-Taylor!*(
                     invsq simp {'tanh,!*!*taylor!-epsilon!*!*},tp)
             else cst!-Taylor!*(
                     simp {car u,!*!*taylor!-epsilon!*!*},tp);

       if car u eq 'tan then
         a := quottaylor(addtaylor(a,negtaylor x),
                         addtaylor(cst!-taylor!*(1 ./ 1,tp),
                                   multtaylor(a,x)))
        else if car u eq 'cot then
         a := quottaylor(addtaylor(multtaylor(a,x),
                                   cst!-taylor!*(1 ./ 1,tp)),
                         addtaylor(x,negtaylor a))
        else if car u eq 'tanh then
         a := quottaylor(addtaylor(a,negtaylor x),
                         addtaylor(cst!-taylor!*(1 ./ 1,tp),
                                   negtaylor multtaylor(a,x)))
        else if car u eq 'coth then
         a := quottaylor(addtaylor(multtaylor(a,x),
                                   cst!-taylor!*(-1 ./ 1,tp)),
                         addtaylor(x,negtaylor a));

        if not (a freeof !*!*taylor!-epsilon!*!*)
          then set!-TayCoeffList(a,
                  for each pp in TayCoeffList a collect
                    TayMakeCoeff(TayCfPl pp,
                                 subsq(TayCfSq pp,
                                       {!*!*taylor!-epsilon!*!* . 0})));
      end;
    %
    if !*taylorkeeporiginal and TayOrig tay
      then set!-TayOrig(a,simp {car u,mk!*sq TayOrig tay});
    set!-Tayflags(a,TayFlags tay);
    return !*tay2q a
  end;

put('tan,'taylorsimpfn,'taysimptan);
put('cot,'taylorsimpfn,'taysimptan);
put('tanh,'taylorsimpfn,'taysimptan);
put('coth,'taylorsimpfn,'taysimptan);



comment For the circular sine and cosine and their reciprocals
        we calculate the exponential and use it via the formulas


                     exp(+I*x) - exp(-I*x)
            sin x = ----------------------- ,
                               2

                     exp(+I*x) + exp(-I*x)
            cos x = ----------------------- ,
                               2

        etc. To avoid clumsy expressions we separate the constant term
        of the argument,

               T(x) = a0 + T1(x),

        and use the addition theorems which give

                       1
            sin T(x) = - exp(+I*T1(x)) * (sin a0 - I*cos a0) +
                       2

                       1
                       - exp(-I*T1(x)) * (sin a0 + I*cos a0) ,
                       2

                       1
            cos T(x) = - exp(+I*T1(x)) * (cos a0 + I*sin a0) +
                       2

                       1
                       - exp(-I*T1(x)) * (cos a0 - I*sin a0) .
                       2

        ;


symbolic procedure taysimpsin u;
  %
  % Special Taylor expansion function for circular sine, cosine,
  %  and their reciprocals
  %
  if not (car u memq '(sin cos sec csc)) or cddr u
    then confusion 'taysimpsin
   else Taylor!:
    begin scalar l,tay,result,tp,i1,l0,a0,a1,a2;
    tay := taysimpsq simp!* cadr u;
    if not Taylor!-kernel!-sq!-p tay
      then return mksq({car u,mk!*sq tay},1);
    tay := mvar numr tay;
    tp := TayTemplate tay;
    l0 := make!-cst!-powerlist tp;
    l := prune!-coefflist TayCoeffList tay;
%    if null l then return !*tay2q cst!-Taylor!*(simp!* {car u,0},tp);
%    if is!-neg!-pl TayCfPl car l
%      then Taylor!-error('essential!-singularity,car u);
    a0 := TayGetCoeff(l0,l);
    %
    % make constant term to 0
    %
    i1 := simp 'i;
    if not null numr a0
      then tay := addtaylor(tay,cst!-Taylor!*(negsq a0,tp));
    result := taysimpexp{'exp,multtaylor(tay,cst!-Taylor!*(i1,tp))};
    a1 := simp!* {'sin,mk!*sq a0} . simp!* {'cos,mk!*sq a0};
    if car u memq '(sin csc) then <<
      a2 := addsq(car a1,multsq(i1,cdr a1));
      a1 := addsq(car a1,negsq multsq(i1,cdr a1));
      >>
     else <<
      a2 := addsq(cdr a1,negsq multsq(i1,car a1));
      a1 := addsq(cdr a1,multsq(i1,car a1));
     >>;
    result := multsq(addsq(multsq(result,a1),
                           multsq(taysimpsq!* invsq result,a2)),
                     1 ./ 2);
    if car u memq '(sec csc) then result := invsq result;
    return taysimpsq!* result
  end;


put('sin,'taylorsimpfn,'taysimpsin);
put('cos,'taylorsimpfn,'taysimpsin);
put('sec,'taylorsimpfn,'taysimpsin);
put('csc,'taylorsimpfn,'taysimpsin);



comment For the hyperbolic sine and cosine and their reciprocals
        we calculate the exponential and use it via the formulas


                     exp(+x) - exp(-x)
           sinh x = ------------------- ,
                             2

                     exp(+x) + exp(-x)
           cosh x = ------------------- ,
                             2

        etc. To avoid clumsy expressions we separate the constant term
        of the argument,

               T(x) = a0 + T1(x),

        and use the addition theorems which give

                        1
            sinh T(x) = - exp(+T1(x)) * (sinh a0 + cosh a0) +
                        2

                        1
                        - exp(-T1(x)) * (sinh a0 - cosh a0) ,
                        2

                        1
            cosh T(x) = - exp(+T1(x)) * (cosh a0 + sinh a0) +
                        2

                        1
                        - exp(-T1(x)) * (cosh a0 - sinh a0) .
                        2
        ;


symbolic procedure taysimpsinh u;
  %
  % Special Taylor expansion function for circular sine, cosine,
  %  and their reciprocals
  %
  if not (car u memq '(sinh cosh sech csch)) or cddr u
    then confusion 'taysimpsin
   else Taylor!:
    begin scalar l,tay,result,tp,l0,a0,a1,a2;
    tay := taysimpsq simp!* cadr u;
    if not Taylor!-kernel!-sq!-p tay
      then return mksq({car u,mk!*sq tay},1);
    tay := mvar numr tay;
    tp := TayTemplate tay;
    l0 := make!-cst!-powerlist tp;
    l := prune!-coefflist TayCoeffList tay;
%    if null l then return !*tay2q cst!-Taylor!*(simp!* {car u,0},tp);
%    if is!-neg!-pl TayCfPl car l
%      then Taylor!-error('essential!-singularity,car u);
    a0 := TayGetCoeff(l0,l);
    %
    % make constant term to 0
    %
    if not null numr a0
      then tay := addtaylor(tay,cst!-Taylor!*(negsq a0,tp));
    result := taysimpexp{'exp,tay};
    a1 := simp!* {'sinh,mk!*sq a0} . simp!* {'cosh,mk!*sq a0};
    if car u memq '(sinh csch) then <<
      a2 := addsq(car a1,cdr a1);
      a1 := subtrsq(car a1,cdr a1);
      >>
     else <<
      a2 := addsq(cdr a1,car a1);
      a1 := subtrsq(cdr a1,car a1);
     >>;
    result := multsq(addsq(multsq(result,a2),
                           multsq(taysimpsq!* invsq result,a1)),
                     1 ./ 2);
    if car u memq '(sech csch) then result := invsq result;
    return taysimpsq!* result
  end;


put('sinh, 'taylorsimpfn, 'taysimpsinh);
put('cosh, 'taylorsimpfn, 'taysimpsinh);
put('sech, 'taylorsimpfn, 'taysimpsinh);
put('csch, 'taylorsimpfn, 'taysimpsinh);


comment Support for the integration of Taylor kernels.
        Unfortunately, with the current interface, only Taylor kernels
        on toplevel can be treated successfully.

        The way it is down means stretching certain interfaces beyond
        what they were designed for...but it works!

        First we add a rule that replaces a call to INT with a Taylor
        kernel as argument by a call to TAYLORINT, then we define
        REVALTAYLORINT as simplification function for that;


algebraic let {

  int(symbolic algebraic(taylor!*(~x,~y,~z,~w)),~u)
      => taylorint(~x,~y,~z,~w,~u),

  int(log(~u)^~~n * symbolic algebraic(taylor!*(~x,~y,~z,~w)),~u)
      => log(u)^n * int(symbolic('(taylor!* x y z w)),u)
          - int(log(u)^(n-1)
             * taylorcombine(int(symbolic('(taylor!* x y z w)),u)/u),u),

  int(~x,~y) => taylorint1(~x,~y)
                  when not symbolic algebraic(~x freeof 'Taylor!*)
};


put('taylorint1, 'psopfn, 'revaltaylorint1);

symbolic procedure revaltaylorint1 x;
  begin scalar u,v;
    u := car x;
    v := cadr x;
    if Taylor!*p u then return revaltaylorint append(cdr u,{v});
    u := reval taylorcombine u;
    if Taylor!*p u then return revaltaylorint append(cdr u,{v});
    if not atom u
      then if car u memq '(plus minus difference)
             then return
                    reval (car u . for each term in cdr u collect
                                     {'int,term,v});
    lprim "Converting Taylor kernels to standard representation";
    return aeval {'int,taylortostandard car x,v}
  end;

put('taylorint, 'psopfn, 'revaltaylorint);

symbolic procedure revaltaylorint u;
  begin scalar taycfl, taytp, tayorg, tayflgs, var;
    taycfl := car u;
    taytp := cadr u;
    tayorg := caddr u;
    tayflgs := cadddr u;
    var := car cddddr u;
    if null (var member TayTpVars taytp)
      then return mk!*sq !*tay2q
            make!-Taylor!*(
              for each pp in taycfl collect
                TayCfPl pp . simp!* {'int,mk!*sq TayCfSq pp,var},
              taytp,
              if not null tayorg
                then simp!* {'int,mk!*sq tayorg,var}
               else nil,
            nil)
     else return mk!*sq
            ((if null car result then !*tay2q cdr result
               else addsq(car result,!*tay2q cdr result))
             where result := inttaylorwrttayvar1(taycfl,taytp,var))
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayconv.red0000644000175000017500000001072311526203062024200 0ustar  giovannigiovannimodule TayConv;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%     Functions converting Taylor kernels to prefix forms
%
%*****************************************************************


exports prepTaylor!*!*, prepTaylor!*, prepTaylor!*1,
        Taylor!-gen!-big!-O;

imports

% from the REDUCE kernel:
        eqcar, lastpair, prepsq!*, replus, retimes, reval,

% from the header module:
        prepTayExp, TayCfPl, TayCfSq, TayCoeffList, TayTemplate,
        TayTpElNext, TayTpElPoint, TayTpElVars;


fluid '(convert!-Taylor!*
        TaylorPrintTerms
        Taylor!-truncation!-flag);


symbolic procedure prepTaylor!*1 (coefflist, template, no!-of!-terms);
  replus for each cc in coefflist join
    begin scalar x; integer count;
      if Taylor!-truncation!-flag then return nil;
      x := prepTaylor!*2 (cc, template);
      if null x or null no!-of!-terms then return x;
      no!-of!-terms := no!-of!-terms - 1;
      if no!-of!-terms < 0
        then << Taylor!-truncation!-flag := t;
                return nil >>;
      return x
    end;

symbolic procedure prepTaylor!*2 (coeff, template);
  (lambda (pc);
    if pc = 0 then nil
     else {retimes (
            (if eqcar (pc, 'quotient) and eqcar (cadr pc, 'minus)
               then {'minus, {'quotient, cadr cadr pc, caddr pc}}
              else pc) . preptaycoeff (TayCfPl coeff, template))})
    (prepsq!* TayCfSq coeff);


symbolic procedure checkdifference (var, var0);
  if var0 = 0 then var else {'difference, var, var0};

symbolic procedure checkexp(bas,exp);
  if exp = 0 then 1
   else if exp = 1 then bas
   else {'expt,bas,prepTayExp exp};

symbolic smacro procedure checkpower (var, var0, n);
  if var0 eq 'infinity
    then if n = 0 then 1
          else {'quotient, 1, checkexp (var, n)}
   else checkexp (checkdifference (var, reval var0), n);

symbolic procedure preptaycoeff (cc, template);
  begin scalar result;
    while not null template do begin scalar ccl;
      ccl := car cc;
      for each var in TayTpElVars car template do <<
        result := checkpower (var, TayTpElPoint car template, car ccl)
                    . result;
        ccl := cdr ccl >>;
      cc := cdr cc;
      template := cdr template
    end;
    return result
  end;

put ('taylor!*, 'prepfn2, 'preptaylor!*!*);

symbolic procedure prepTaylor!*!* u;
   if null convert!-taylor!* then u else preptaylor!* u;

symbolic procedure prepTaylor!* u;
   prepTaylor!*1 (TayCoeffList u, TayTemplate u, nil);

symbolic procedure Taylor!-gen!-big!-O tp;
  %
  % Generates a big-O notation for the Taylor template tp
  %
  "O" . for each el in tp collect
          if null cdr TayTpElVars el
            then checkpower(car TayTpElVars el,TayTpElPoint el,
                            TayTpElNext el)
           else begin scalar var0;
             var0 := reval TayTpElPoint el;
             return
               if var0 eq 'infinity
                 then {'quotient,1,
                       checkexp('list . TayTpElVars el,TayTpElNext el)}
                else checkexp(
                 'list .
                   for each krnl in TayTpElVars el collect
                     checkdifference(krnl,var0),
                 TayTpElNext el)
           end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayrevrt.red0000644000175000017500000002317411526203062024401 0ustar  giovannigiovannimodule TayRevrt;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%       Functions for reversion of Taylor kernels
%
%*****************************************************************


exports taylorrevert;

imports

% from the REDUCE kernel:
        !*a2k, !*q2a, invsq, lastpair, mvar, neq, nth, numr, over,
        reval, simp!*, typerr,

% from the header module:
        !*TayExp2q, cst!-Taylor!*, make!-cst!-coefficient,
        make!-taylor!*, multtaylorsq, prepTayExp, prune!-coefflist,
        set!-TayTemplate, TayCfPl, TayCfSq, TayCoeffList,
        TayExp!-Quotient, Taylor!:, TayMakeCoeff,
        Taylor!-kernel!-sq!-p, TayTemplate, TayTpElNext, TayTpElOrder,
        TayTpElPoint, TayTpElVars,

% from module Tayintro:
        delete!-nth, Taylor!-error,

% from module Taybasic:
        addtaylor, invtaylor, multtaylor, negtaylor,

% from module TaySimp:
        expttayrat,

% from module Tayutils:
        enter!-sorted, smallest!-increment;


symbolic procedure tayrevert (tay, okrnl, krnl);
  %
  % Reverts Taylor kernel tay that has okrnl as variable
  %  into a Taylor kernel that has krnl as variable.
  %
  % This is the driver procedure; it check whether okrnl
  %  is valid for this operation and calls tayrevert1 to do the work.
  %
  begin scalar tp, cfl, x; integer i;
    cfl := TayCoeffList tay;
    tp := TayTemplate tay;
    x := tp;
    i := 1;
    %
    % Loop through the template and make sure that the kernel
    %  okrnl is present and not part of a homogeneous template.
    %
   loop:
    if okrnl member TayTpElVars car x then <<
      if not null cdr TayTpElVars car x then <<
        Taylor!-error ('tayrevert,
                       {"Kernel", okrnl,
                        "appears in homogenous template", car x});
        return
        >>
       else goto found;
      >>
     else <<
       x := cdr x;
       i := i + 1;
       if not null x then goto loop
       >>;
    Taylor!-error
      ('tayrevert, {"Kernel", okrnl, "not found in template"});
    return;
   found:
    return tayrevert1 (tp, cfl, car x, i, okrnl, krnl)
  end;


symbolic procedure tayrevertreorder (cf, i);
  %
  % reorders coefflist cf so that
  %  a) part i of template is put first
  %  b) the resulting coefflist is again ordered properly
  %
  begin scalar cf1, pl, sq;
    for each pp in cf do <<
      pl := TayCfPl pp;
      sq := TayCfSq pp;
      pl := nth (pl, i) . delete!-nth (pl, i);
      cf1 := enter!-sorted (TayMakeCoeff (pl, sq), cf1)
      >>;
    return cf1
  end;

symbolic procedure tayrevertfirstdegreecoeffs (cf, n);
  %
  % Returns a coefflist that corresponds to the coefficient
  %  of (the first kernel in the template) ** n.
  %
  for each el in cf join
    if car car TayCfPl el = n and not null numr TayCfSq el
     then {TayMakeCoeff (cdr TayCfPl el, TayCfSq el)} else nil;

symbolic procedure tayrevert1(tp,cf,el,i,okrnl,krnl);
  %
  % This is the procedure that does the real work.
  %  tp is the old template,
  %  cf the old coefflist,
  %  el the element of the template that contains the "old" kernel,
  %  i its position in the template,
  %  okrnl the old kernel,
  %  krnl the new kernel.
  %
  Taylor!:
  begin scalar first,incr,newtp,newcf,newpoint,newel,u,u!-k,v,w,x,x1,n,
               expo,upper;
    %
    % First step: reorder the coefflist as if the okrnl appears
    %              at the beginning of the template and construct a
    %              new template by first deleting this element from it.
    %
    newcf := prune!-coefflist tayrevertreorder (cf, i);
    newtp := delete!-nth (tp, i);
    %
    % Check that the lowest degree of okrnl is -1, 0, or +1.
    %  For -1, we have a first order pole.
    %  For 0, reversion is possible only if the coefficient
    %   of okrnl is a constant w.r.t. the other Taylor variables.
    %  For +1, we use the algorithm quoted by Knuth,
    %   in: The Art of Computer Programming, vol2. p. 508.
    %
    n := car car TayCfPl car newcf;
    if n < 0
      then tayrevert1pole(tp,cf,el,i,okrnl,krnl,newcf,newtp);
    if n = 0
      then if not null newtp
             then begin scalar xx;
               xx := tayrevertfirstdegreecoeffs(newcf,0);
               if length xx > 1
                 then Taylor!-error
                       ('tayrevert,
                        "Term with power 0 is a Taylor series");
               xx := car xx;
               for each el in TayCfPl xx do
                 for each el2 in el do
                   if el2 neq 0
                     then Taylor!-error
                           ('tayrevert,
                            "Term with power 0 is a Taylor series");
               newpoint := !*q2a TayCfSq xx;
              end
            else <>
     else newpoint := 0;
    tp := {{krnl},newpoint,TayTpElOrder el,TayTpElNext el} . newtp;
    first := TayExp!-quotient(1,n);
    incr := car smallest!-increment newcf;
    expo := first * incr;
    if not(expo=1)
      then (<>
            where newtay := expttayrat(Make!-Taylor!*(newcf,tp,nil,nil),
                                       !*TayExp2q expo));
    upper := TayExp!-quotient(TayTpElNext car tp,incr) - 1;
    x := tayrevertfirstdegreecoeffs(newcf,incr);
    x1 := x := invtaylor make!-Taylor!*(x,newtp,nil,nil);
    w := for each pp in TayCoeffList x1 collect
           TayMakeCoeff({expo} . TayCfPl pp,TayCfSq pp);

    v := mkvect upper;

    for j := 2 : upper do
      putv(v,j,
           multtaylor(
               x,
               make!-Taylor!*(tayrevertfirstdegreecoeffs(newcf,j*incr),
                              newtp,nil,nil)));

    u := mkvect upper;

    putv(u,0,cst!-Taylor!*(1 ./ 1,newtp));
    for j := 2 : upper do <<
      for k := 1 : j - 2 do begin
        u!-k := getv(u,k);
        for l := k - 1 step -1 until 0 do
          u!-k := addtaylor
                   (u!-k,
                    negtaylor
                      multtaylor(getv(u,l),
                                 getv(v,k - l + 1)));
        putv(u,k,u!-k);
        end;
      u!-k := multtaylorsq(getv(v,j),!*TayExp2q j);

      for k := 1 : j - 2 do
        u!-k := addtaylor
                 (multtaylorsq(multtaylor(getv(u,k),
                                          getv(v,j - k)),
                               !*TayExp2q (j - k)),
                  u!-k);

      u!-k := negtaylor u!-k;
      putv(u,j - 1,u!-k);
%
      x1 := multtaylor(x1,x);            % x1 is now x ** j
      for each pp in TayCoeffList
             multtaylor(multtaylorsq
                           (getv(u,j - 1),
                            invsq !*TayExp2q j),x1) do
        w := enter!-sorted (TayMakeCoeff({j * expo}
                         . TayCfPl pp,TayCfSq pp),
                            w);
      >>;
%
      newtp := (car tp) . newtp;
      w := enter!-sorted(
             make!-cst!-coefficient(simp!* TayTpElPoint el,newtp),
             w);

    w := Make!-taylor!*(w,newtp,nil,nil);
    return if incr = 1 then w
            else expttayrat(w,invsq !*TayExp2q incr)
  end;

comment The mechanism for a first order pole is very simple:
        This corresponds to a first order zero at infinity,
        so we invert the original kernel and revert the result;

symbolic procedure tayrevert1pole (tp, cf, el, i, okrnl, krnl,
                                   newcf, newtp);
  begin scalar x, y, z;
    cf := TayCoeffList invtaylor make!-Taylor!*(cf,tp,nil,nil);
    x := tayrevert1 (tp, cf, el, i, okrnl, krnl);
    y := TayTemplate x;
    if TayTpElPoint car y neq 0
      then Taylor!-error ('not!-implemented,
                          "(Taylor series reversion)")
     else <<
       set!-TayTemplate (x, {{krnl}, 'infinity, TayTpElOrder car y}
                              . cdr y);
       return x >>
  end;

comment The driver routine;

symbolic procedure TaylorRevert (u, okrnl, nkrnl);
  (if not Taylor!-kernel!-sq!-p sq
     then typerr (u, "Taylor kernel")
    else tayrevert (mvar numr sq, !*a2k okrnl, !*a2k nkrnl))
     where sq := simp!* u$

flag ('(TaylorRevert), 'opfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taysubst.red0000644000175000017500000002164211526203062024375 0ustar  giovannigiovannimodule TaySubst;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%      Interface to the substitution functions
%
%*****************************************************************


exports subsubtaylor$

imports

% from the REDUCE kernel:
        addsq, denr, depends, domainp, eqcar, exptsq, invsq, lc, ldeg,
        mkrn, multsq, mvar, nlist, nth, numr, prepsq, red,
        replace!-nth!-nth, reval, reversip, simp!*, simprn, sort,
        subeval1, subs2!*, subsq, subtrsq, typerr,

% from the header module:
        make!-Taylor!*, set!-TayCfSq, TayCfPl, TayCfSq, TayCoeffList,
        TayFlags, Taylor!:, Taylor!-error, TayVars, TayMakeCoeff,
        TayOrig, TayTemplate, TayTpElNext, TayTpElOrder, TayTpElPoint,
        TayTpElVars,

% from module Tayintro:
        constant!-sq!-p, delete!-nth, delete!-nth!-nth, replace!-nth,
        Taylor!-error, Taylor!-error!*, var!-is!-nth,

% from module Tayutils:
       enter!-sorted, rat!-kern!-pow;


fluid '(!*taylorkeeporiginal);

put ('taylor!*, 'subfunc, 'subsubtaylor);

symbolic procedure subsubtaylor(l,v);
  begin scalar x,clist,delete_list,tp,pl;
    clist := for each u in TayCoeffList v collect
               TayMakeCoeff(TayCfPl u,subsq(TayCfSq u,l));
    tp := TayTemplate v;
    %
    % Substitute in expansion point
    %
    tp := for each quartet in tp collect
            {TayTpElVars quartet,
             reval subeval1(l,TayTpElPoint quartet),
             TayTpElOrder quartet,
             TayTpElNext quartet};
    pl := for each quartet in tp collect
            nlist(nil,length TayTpElVars quartet);
    %
    % Make x the list of substitutions of Taylor variables.
    %
    for each p in l do
      if car p member TayVars v
        %
        % The replacement of a Taylor variable must again be
        % a kernel.  If it is a constant, we have to delete it
        % from the list of Taylor variables.  Actually the main
        % problem is to distinguish kernels that are constant
        % expressions (e.g. sin (acos (4))) from others.
        %
        then begin scalar temp;
         temp := simp!* cdr p;
         if constant!-sq!-p temp
          then begin scalar about,ll,w,y,z; integer pos,pos1;
            %
            % Determine the position of the variable
            %
            w := var!-is!-nth(tp,car p);
            pos := car w;
            pos1 := cdr w;
            if not null nth(nth(pl,pos),pos1)
              then Taylor!-error('invalid!-subst,
                            "multiple substitution for same variable");
            pl := replace!-nth!-nth(pl,pos,pos1,0);
            %
            % Calculate the difference (new_variable - expansion_point)
            %
            about := TayTpElPoint nth(tp,pos);
            if about eq 'infinity
              then if null numr temp
                then Taylor!-error!*('zero!-denom,"Taylor Substitution")
               else temp := invsq temp
             else temp := subtrsq(temp,simp!* about);
            %
            % Adjust for already deleted
            %
            foreach pp in delete_list do
              if car pp < pos then pos := pos - 1;
            delete_list := (pos . pos1) . delete_list;
            %
            % Substitute in every coefficient
            %
            Taylor!:
            for each cc in clist do begin scalar exponent;
              w := nth(TayCfPl cc,pos);
              w := if null cdr w then delete!-nth(TayCfPl cc,pos)
                    else delete!-nth!-nth(TayCfPl cc,pos,pos1);
              exponent := nth(nth(TayCfPl cc,pos),pos1);
              z := if exponent = 0 then TayCfSq cc
                     else if exponent < 0 and null numr temp
                      then Taylor!-error!*('zero!-denom,
                                         "Taylor Substitution")
                     else multsq(TayCfSq cc,exptsq(temp,exponent));
              y := assoc(w,ll);
              if y then set!-TayCfSq(y,subs2!* addsq(TayCfSq y,z))
               else if not null numr (z := subs2!* z)
                then ll := TayMakeCoeff(w,z) . ll
             end;
            %
            % Delete zero coefficients
            %
            clist := nil;
            while ll do <<
              if not null numr TayCfSq car ll
                then clist := enter!-sorted(car ll,clist);
              ll := cdr ll>>;
          end
         else if not (denr temp = 1 and
                      (temp := rat!-kern!-pow(numr temp,t)))
          then typerr({'replaceby,car p,cdr p},
                      "Taylor substitution")
         else begin scalar w,expo; integer pos,pos1;
           expo := cdr temp;
           temp := car temp;
           for each el in delete(car p,TayVars v) do
             if depends(temp,el)
               then Taylor!-error('invalid!-subst,
                                  {"dependent variables",cdr p,el});
           if not (expo = 1) then <<
             w := var!-is!-nth(tp,car p);
             pos := car w;
             pos1 := cdr w;
             if not null nth(nth(pl,pos),pos1)
               then Taylor!-error('invalid!-subst,
                            "different powers in homogeneous template");
             pl := replace!-nth!-nth(pl,pos,pos1,expo)>>;
           x := (car p . temp) . x
         end
        end;
   for each pp in sort(delete_list,function sortpred) do
      <>
         else <>>>
          where u := nth(tp,car pp);
    if null tp
      then return if null clist then 0 else prepsq TayCfSq car clist;
    x := reversip x;
    pl := check!-pl pl;
    if null pl then Taylor!-error('invalid!-subst,
                            "different powers in homogeneous template");
    return if pl = nlist(1,length tp)
             then make!-Taylor!*(clist,sublis(x,tp),
                        if !*taylorkeeporiginal and TayOrig v
                          then subsq(TayOrig v,l)
                         else nil,
                        TayFlags v)
            else make!-Taylor!*(change!-coefflist(clist,pl),
                        change!-tp(sublis(x,tp),pl),
                        if !*taylorkeeporiginal and TayOrig v
                          then subsq(TayOrig v,l)
                         else nil,
                        TayFlags v)
  end;

symbolic procedure sortpred(u,v);
   car u > car v or car u = car v and cdr u > cdr v;

symbolic procedure check!-pl pl;
  Taylor!:
   if null pl then nil
    else ((if n=0 then check!-pl cdr pl
            else if n and n<0 then nil
            else n . check!-pl cdr pl)
           where n := check!-pl0(car car pl,cdr car pl));

symbolic procedure check!-pl0(n,nl);
   if null nl then n else n=car nl and check!-pl0(n,cdr nl);

symbolic procedure change!-coefflist(cflist,pl);
   for each cf in cflist collect
     TayMakeCoeff(change!-pl(TayCfPl cf,pl),TayCfSq cf);

symbolic procedure change!-tp(tp,pl);
   if null tp then nil
    else (if null car pl then car tp
           else Taylor!:{TayTpElVars car tp,
                         TayTpElPoint car tp,
                         TayTpElOrder car tp * car pl,
                         TayTpElNext car tp * car pl})
        . cdr tp;

symbolic procedure change!-pl(pl,pl0);
  if null pl then nil
   else (if null car pl0 then car pl
          else for each n in car pl collect Taylor!:(car pl0 * n))
        . change!-pl(cdr pl,cdr pl0);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taypart.red0000644000175000017500000000711511526203062024202 0ustar  giovannigiovannimodule TayPart;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%      The interface to the PART operator
%
%*****************************************************************

%exports Taylor!*part,Taylor!*setpart;
exports Taylor!*part;

imports

% from the REDUCE kernel:
        !*a2k, aeval, eqcar, parterr, rederr, revalsetp1, simp!*,
        typerr,

% from the header module:
        make!-Taylor!*, TayCoefflist, TayFlags, TaylorTemplate,
        TayOrig,

% from module TayConv:
        prepTaylor!*;


%fluid '(!*taylorprintorder TaylorPrintTerms);


symbolic procedure Taylor!*part(tay,n);
   begin scalar prep;
%     prep := (Taylor!*print1 tay) where !*taylorprintorder='t,
%                                        TaylorPrintTerms='all;
     prep := prepTaylor!* tay;
     if atom prep then parterr(prep,n);
     if n=0 then return car prep;
     prep := cdr prep;
     if n<0 then <>;
     if length prep < n then parterr(tay,n);
     return nth(prep,n)
   end;

put('Taylor!*,'partop,'Taylor!*part);


%symbolic procedure Taylor!*setpart(tay,nl,repl);
%   if car nl=2
%     then make!-Taylor!*(
%            TayCoefflist tay,
%            list!-to!-template(
%              revalsetp1(TaylorTemplate tay,cdr nl,repl),
%              length TayTemplate tay),
%            TayOrig tay,
%            TayFlags tay)
%    else if car nl=3 and TayOrig tay
%     then make!-Taylor!*(
%            TayCoefflist tay,
%            TayTemplate tay,
%            simp!* revalsetp1(reval!* mk!*sq TayOrig tay,cdr nl,repl),
%            TayFlags tay)
%    else rederr {"Cannot replace part",car nl,"in Taylor kernel"};
%
%
%put('Taylor!*,'setpartop,'Taylor!*setpart);
%
%
%symbolic procedure list!-to!-template (ttp,l);
%   if not eqcar(ttp,'list) or length cdr ttp neq l
%     then typerr(ttp,"Taylor template")
%    else for each ttpel in cdr ttp collect list!-to!-tpel ttpel;
%
%symbolic procedure list!-to!-tpel ttpel;
%   if not eqcar(ttpel,'list) or length ttpel<4
%     then typerr(ttpel,"Taylor Template element")
%    else {if eqcar(cadr ttpel,'list)
%            then for each var in cdr cadr ttpel collect !*a2k var
%           else {!*a2k cadr ttpel},
%          caddr ttpel,
%          ((if fixp x then x else typerr(x,"number"))
%            where x := aeval cadddr ttpel)};

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taylor.hlp0000644000175000017500000004264211526203062024045 0ustar  giovannigiovanni\section{Taylor series}

\begin{Introduction}{TAYLOR}
This short note describes a package of REDUCE procedures that allow
Taylor expansion in one or more variables and efficient manipulation
of the resulting Taylor series. Capabilities include basic operations
(addition, subtraction, multiplication and division) and also
application of certain algebraic and transcendental functions. To a
certain extent, Laurent expansion can be performed as well.
\end{Introduction}

\begin{Operator}{taylor}
  The \name{taylor} operator is used for expanding an expression into a
  Taylor series.

  \begin{Syntax}
    \name{taylor}\(\meta{expression}
                   \name{,}\meta{var}\name{,}
                   \meta{expression}\name{,}\meta{number}\\
                   \{\name{,}\meta{var}\name{,}
                   \meta{expression}\name{,}\meta{number}\}\optional\)
  \end{Syntax}
  \meta{expression} can be any valid REDUCE algebraic expression.
  \meta{var} must be a \nameref{kernel}, and is the expansion
  variable.  The \meta{expression} following it denotes the point
  about which the expansion is to take place. \meta{number} must be a
  non-negative integer and denotes the maximum expansion order.  If
  more than one triple is specified \name{taylor} will expand its
  first argument independently with respect to all the variables.
  Note that once the expansion has been done it is not possible to
  calculate higher orders.

  Instead of a \nameref{kernel}, \meta{var} may also be a list of
  kernels.  In this case expansion will take place in a way so that
  the {\em sum\/} of the degrees of the kernels does not exceed the
  maximum expansion order.  If the expansion point evaluates to the
  special identifier \name{infinity}, \name{taylor} tries to expand in
  a series in 1/\meta{var}.

  The expansion is performed variable per variable, i.e.\ in the
  example above by first expanding 
  \IFTEX{$\exp(x^{2}+y^{2})$}{exp(x^2+y^2)}
  with respect to
  \name{x} and then expanding every coefficient with respect to \name{y}.

  \begin{Examples}
    taylor(e^(x^2+y^2),x,0,2,y,0,2);     &
                1 + Y^{2} + X^{2} + Y^{2}*X^{2} + O(X^{2},Y^{2})   \\
    taylor(e^(x^2+y^2),{x,y},0,2); & 1 + Y^{2} + X^{2} + O(\{X^{2},Y^{2}\})\\
    \explanation{The following example shows the case of a non-analytical function.}\\
    taylor(x*y/(x+y),x,0,2,y,0,2); & ***** Not a unit in argument to QUOTTAYLOR \\
  \end{Examples}

  \begin{Comments}
    Note that it is not generally possible to apply the standard
    reduce operators to a Taylor kernel. For example, \nameref{part},
    \nameref{coeff}, or \nameref{coeffn} cannot be used. Instead, the
    expression at hand has to be converted to standard form first
    using the \nameref{taylortostandard} operator.

    Differentiation of a Taylor expression is possible.  If you
    differentiate with respect to one of the Taylor variables the
    order will decrease by one.

    Substitution is a bit restricted: Taylor variables can only be
    replaced by other kernels.  There is one exception to this rule:
    you can always substitute a Taylor variable by an expression that
    evaluates to a constant.  Note that REDUCE will not always be able
    to determine that an expression is constant: an example is
    sin(acos(4)).

    Only simple taylor kernels can be integrated. More complicated
    expressions that contain Taylor kernels as parts of themselves are
    automatically converted into a standard representation by means of
    the \nameref{taylortostandard} operator. In this case a suitable
    warning is printed.

  \end{Comments}

\end{Operator}


\begin{Switch}{taylorautocombine}
  If you set \name{taylorautocombine} to \name{on}, REDUCE
  automatically combines Taylor expressions during the simplification
  process.  This is equivalent to applying \nameref{taylorcombine} to
  every expression that contains Taylor kernels.  Default is
  \name{on}.
\end{Switch}

\begin{Switch}{taylorautoexpand}
  \name{taylorautoexpand} makes Taylor expressions ``contagious'' in
  the sense that \nameref{taylorcombine} tries to Taylor expand all
  non-Taylor subexpressions and to combine the result with the rest.
  Default is \name{off}.
\end{Switch}

\begin{Operator}{taylorcombine}
  This operator tries to combine all Taylor kernels found in its
  argument into one.  Operations currently possible are:
  \begin{itemize}
    \item Addition, subtraction, multiplication, and division.
    \item Roots, exponentials, and logarithms.
    \item Trigonometric and hyperbolic functions and their inverses.
  \end{itemize}

  \begin{Examples}
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    taylorcombine log hugo; & X + O(X^{3})\\
    taylorcombine(hugo + x); & (1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})) + X\\
    on taylorautoexpand; \\
    taylorcombine(hugo + x); & 1 + 2*X + \rfrac{1}{2}*X^{2} + O(X^{3})
  \end{Examples}

  \begin{Comments}
    Application of unary operators like \name{log} and \name{atan}
    will nearly always succeed. For binary operations their arguments
    have to be Taylor kernels with the same template. This means that
    the expansion variable and the expansion point must match.
    Expansion order is not so important, different order usually means
    that one of them is truncated before doing the operation.

    If \nameref{taylorkeeporiginal} is set to \name{on} and if all
    Taylor kernels in its argument have their original expressions
    kept \name{taylorcombine} will also combine these and store the
    result as the original expression of the resulting Taylor kernel.
    There is also the switch \nameref{taylorautoexpand}.

    There are a few restrictions to avoid mathematically undefined
    expressions: it is not possible to take the logarithm of a Taylor
    kernel which has no terms (i.e. is zero), or to divide by such a
    beast.  There are some provisions made to detect singularities
    during expansion: poles that arise because the denominator has
    zeros at the expansion point are detected and properly treated,
    i.e.\ the Taylor kernel will start with a negative power.  (This
    is accomplished by expanding numerator and denominator separately
    and combining the results.)  Essential singularities of the known
    functions (see above) are handled correctly.
  \end{Comments}
\end{Operator}

\begin{Switch}{taylorkeeporiginal}
  \name{taylorkeeporiginal}, if set to \name{on}, forces the
  \nameref{taylor} and all Taylor kernel manipulation operators to
  keep the original expression, i.e.\ the expression that was Taylor
  expanded.  All operations performed on the Taylor kernels are also
  applied to this expression which can be recovered using the operator
  \nameref{taylororiginal}.  Default is \name{off}.
\end{Switch}

\begin{Operator}{taylororiginal}
  Recovers the original expression (the one that was expanded) from
  the Taylor kernel that is given as its argument.

  \begin{Syntax}
    \name{taylororiginal}\(\meta{expression}\) or
    \name{taylororiginal} \meta{simple_expression}
  \end{Syntax}

  \begin{Examples}
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    taylororiginal hugo; &
       ***** Taylor kernel doesn't have an original part in TAYLORORIGINAL\\
    on taylorkeeporiginal; \\
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    taylororiginal hugo; & E^{X}
  \end{Examples}

  \begin{Comments}
    An error is signalled if the argument is not a Taylor kernel or if
    the original expression was not kept, i.e.\ if
    \nameref{taylorkeeporiginal} was set \name{off} during expansion.
  \end{Comments}

\end{Operator}

\begin{Switch}{taylorprintorder}
  \name{taylorprintorder}, if set to \name{on}, causes the remainder
  to be printed in big-O notation.  Otherwise, three dots are printed.
  Default is \name{on}.
\end{Switch}

\begin{Variable}{taylorprintterms}
  Only a certain number of (non-zero) coefficients are printed. If
  there are more, an expression of the form \name{n terms} is printed
  to indicate how many non-zero terms have been suppressed.  The
  number of terms printed is given by the value of the shared
  algebraic variable \name{taylorprintterms}.  Allowed values are
  integers and the special identifier \name{all}. The latter setting
  specifies that all terms are to be printed. The default setting is
  5.

  \begin{Examples}
    taylor(e^(x^2+y^2),x,0,4,y,0,4); &
           1 + Y^{2} + \rfrac{1}{2}*Y^{4} + X^{2} + Y^{2}*X^{2} +
             (4 terms) + O(X^{5},Y^{5})\\
    taylorprintterms := all; & TAYLORPRINTTERMS := ALL \\
    taylor(e^(x^2+y^2),x,0,4,y,0,4); &
    \begin{multilineoutput}{}
1 + Y^{2} + \rfrac{1}{2}*Y^{4} + X^{2} + Y^{2}*X^{2} +%
 \rfrac{1}{2}*Y^{4}*X^{2} + \rfrac{1}{2}*X^{4} +%
 \rfrac{1}{2}*Y^{2}*X^{4}\\
 + \rfrac{1}{4}*Y^{4}*X^{4} + O(X^{5},Y^{5})
    \end{multilineoutput}
  \end{Examples}

\end{Variable}


\begin{Operator}{taylorrevert}
  \name{taylorrevert} allows reversion of a Taylor series of a
  function f, i.e., to compute the first terms of the expansion of the
  inverse of $f$ from the expansion of $f$.

  \begin{Syntax}
    \name{taylorrevert}\(\meta{expression}\name{,}
                         \meta{var}\name{,}\meta{var}\)
  \end{Syntax}

  The first argument must evaluate to a Taylor kernel with the second
  argument being one of its expansion variables. 

  \begin{Examples}
    taylor(u - u**2,u,0,5); &    U - U^{2} + O(U^{6}) \\
    taylorrevert (ws,u,x);  &    X + X^{2} + 2*X^{3} + 5*X^{4} + 14*X^{5} + O(X^{6})
  \end{Examples}

\end{Operator}

\begin{Operator}{taylorseriesp}
  This operator may be used to determine if its argument is a Taylor
  kernel.

  \begin{Syntax}
    \name{taylorseriesp}\(\meta{expression}\) or \name{taylorseriesp}
    \meta{simple_expression}
  \end{Syntax}

  \begin{Examples}
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    if taylorseriesp hugo then OK;& OK \\
    if taylorseriesp(hugo + y) then OK else NO; & NO
  \end{Examples}

  \begin{Comments}
    Note that this operator is subject to the same restrictions as,
    e.g., \name{ordp} or \name{numberp}, i.e.\ it may only be used in
    boolean expressions in \name{if} or \name{let} statements.
  \end{Comments}

\end{Operator}


\begin{Operator}{taylortemplate}
  The template of a Taylor kernel, i.e.\ the list of all variables
  with respect to which expansion took place together with expansion
  point and order can be extracted using

  \begin{Syntax}
    \name{taylortemplate}\(\meta{expression}\) or
    \name{taylortemplate} \meta{simple_expression}
  \end{Syntax}

  This returns a list of lists with the three elements
  (VAR,VAR0,ORDER).  An error is signalled if the argument is not a
  Taylor kernel.

  \begin{Examples}
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    taylortemplate hugo; & \{\{X,0,2\}\}
  \end{Examples}

\end{Operator}

\begin{Operator}{taylortostandard}
  This operator converts all Taylor kernels in its argument into
  standard form and resimplifies the result.

\begin{Syntax}
  \name{taylortostandard}\(\meta{expression}\) or
  \name{taylortostandard} \meta{simple_expression}
\end{Syntax}

  \begin{Examples}
    hugo := taylor(exp(x),x,0,2); & HUGO := 1 + X + \rfrac{1}{2}*X^{2} + O(X^{3})\\
    taylortostandard hugo; & \rfrac{X^{2} + 2*X + 2}{2}
  \end{Examples}

\end{Operator}

\endinput

\section{Warnings and error messages}
\index{errors ! TAYLOR package}
\begin{itemize}

\item \name{Branch point detected in ...}\\
    This occurs if you take a rational power of a Taylor kernel
    and raising the lowest order term of the kernel to this
    power yields a non analytical term (i.e.\ a fractional power).

\item \name{Cannot expand further... truncation done}\\
    You will get this warning if you try to expand a Taylor kernel to
    a higher order.

\item \name{Converting Taylor kernels to standard representation}\\
    This warning appears if you try to integrate an expression that
    contains Taylor kernels.

\item \name{Error during expansion (possible singularity)}\\
    The expression you are trying to expand caused an error.
    As far as I know this can only happen if it contains a function
    with a pole or an essential singularity at the expansion point.
    (But one can never be sure.)

\item \name{Essential singularity in ...}\\
    An essential singularity was detected while applying a
    special function to a Taylor kernel.
    This error occurs, for example, if you try to take
    the logarithm of a Taylor kernel that starts with a negative
    power in one of its variables, i.e.\ that has a pole
    at the expansion point.

\item \name{Expansion point lies on branch cut in ...}\\
    The only functions with branch cuts this package knows of are
    (natural) logarithm, inverse circular and hyperbolic tangent and
    cotangent.  The branch cut of the logarithm is assumed to lie on
    the negative real axis.  Those of the arc tangent and arc
    cotangent functions are chosen to be compatible with this: both
    have essential singularities at the points $\pm i$.  The branch
    cut of arc tangent is the straight line along the imaginary axis
    connecting $+1$ to $-1$ going through $\infty$ whereas that of arc
    cotangent goes through the origin.  Consequently, the branch cut
    of the inverse hyperbolic tangent resp.\ cotangent lies on the
    real axis and goes from $-1$ to $+1$, that of the latter across
    $0$, the other across $\infty$.
    
    The error message can currently only appear when you try to
    calculate the inverse tangent or cotangent of a Taylor
    kernel that starts with a negative degree.
    The case of a logarithm of a Taylor kernel whose constant term
    is a negative real number is not caught since it is
    difficult to detect this in general.

\item \name{Not a unity in ...}\\
    This will happen if you try to divide by or take the logarithm of 
    a Taylor series whose constant term vanishes.

\item \name{Not implemented yet (...)}\\
    Sorry, but I haven't had the time to implement this feature.
    Tell me if you really need it, maybe I have already an improved
    version of the package.

\item \name{Reversion of Taylor series not possible: ...}\\
\ttindex{TAYLORREVERT}
    You tried to call the \name{TAYLORREVERT} operator with
    inappropriate arguments. The second half of this error message
    tells you why this operation is not possible.

\item \name{Substitution of dependent variables ...}\\
    You tried to substitute a variable that is already present in the
    Taylor kernel or on which one of the Taylor variables depend.

\item \name{Taylor kernel doesn't have an original part}\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORKEEPORIGINAL}
    The Taylor kernel upon which you try to use \name{TAYLORORIGINAL}
    was created with the switch \name{TAYLORKEEPORIGINAL}
    set to \name{OFF}
    and does therefore not keep the original expression.

\item \name{Wrong number of arguments to TAYLOR}\\
    You try to use the operator \name{TAYLOR} with a wrong number of
    arguments.

\item \name{Zero divisor in TAYLOREXPAND}\\
    A zero divisor was found while an expression was being expanded.
    This should not normally occur.

\item \name{Zero divisor in Taylor substitution}\\
    That's exactly what the message says.  As an example consider the
    case of a Taylor kernel containing the term \name{1/x} and you try
    to substitute \name{x| by \verb|0}.

\item \name{... invalid as kernel}\\
    You tried to expand with respect to an expression that is not a
    kernel.

\item \name{... invalid as order of Taylor expansion}\\
    The order parameter you gave to \name{TAYLOR} is not an integer.

\item \name{... invalid as Taylor kernel}\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORTEMPLATE}
    You tried to apply \name{TAYLORORIGINAL| or \verb|TAYLORTEMPLATE}
    to an expression that is not a Taylor kernel.

\item \name{... invalid as Taylor variable}\\
    You tried to substitute a Taylor variable by an expression that is
    not a kernel.

\item \name{... invalid as value of TaylorPrintTerms}\\
\ttindex{TAYLORPRINTTERMS} 
    You have assigned an invalid value to \name{TAYLORPRINTTERMS}.
    Allowed values are: an integer or the special identifier
    \name{ALL}.

\item \name{TAYLOR PACKAGE (...): this can't happen ...}\\
    This message shows that an internal inconsistency was detected.
    This is not your fault, at least as long as you did not try to
    work with the internal data structures of \REDUCE. Send input
    and output to me, together with the version information that is
    printed out.

\end{itemize}

\section{Comparison to other packages}

At the moment there is only one \REDUCE{} package that I know of:
the truncated power series package by Alan Barnes and Julian Padget.
In my opinion there are two major differences:
\begin{itemize}
  \item The interface. They use the domain mechanism for their power
        series, I decided to invent a special kind of kernel. Both
        approaches have advantages and disadvantages: with domain
        modes, it is easier
        to do certain things automatically, e.g., conversions.
  \item The concept of a truncated series. Their idea is to remember
        the original expression and to compute more coefficients when
        more of them are needed. My approach is to truncate at a
        certain order and forget how the unexpanded expression
        looked like.  I think that their method is more widely
        usable, whereas mine is more efficient when you know in
        advance exactly how many terms you need.
\end{itemize}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayintrf.red0000644000175000017500000003703311526203062024360 0ustar  giovannigiovannimodule TayIntrf;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%      The interface to the REDUCE simplificator
%
%*****************************************************************


exports simptaylor, simpTaylor!*, taylorexpand$

imports

% from the REDUCE kernel:
        !*f2q, aconc!*, denr, depends, diffsq, eqcar, kernp, lastpair,
        leq, lprim, mkquote, mksq, multsq, mvar, neq, nth, numr, over,
        prepsq, revlis, reversip, simp, simp!*, subs2, subsq, typerr,

% from the header module:
        !*tay2q, get!-degree, has!-Taylor!*, has!-TayVars,
        make!-Taylor!*, multintocoefflist, resimptaylor, TayCfPl,
        TayCfSq, TayCoeffList, TayFlags, TayMakeCoeff, TayOrig,
        TayTemplate, TayTpElOrder, TayTpElPoint,
        Taylor!-kernel!-sq!-p, taymincoeff,

% from module Tayintro:
        replace!-nth, Taylor!-error, var!-is!-nth,

% from module TayExpnd:
        taylorexpand,

% from module Tayutils:
        delete!-superfluous!-coeffs,

% from module taybasic:
        invtaylor1, quottaylor1,

% from module Tayconv:
        prepTaylor!*;


fluid '(!*backtrace !*precise !*tayinternal!* !*taylorkeeporiginal !*taylorautocombine
        frlis!* subfg!*);

global '(mul!*);

comment The following statement forces all expressions to be
        re-simplified if the switch `taylorautocombine' is set to on,
        unfortunately, this is not always sufficient;

put ('taylorautocombine, 'simpfg, '((t (rmsubs))));


comment Interface to the fkern mechanism that makes kernels unique and 
        stores them in the klist property;

symbolic procedure tayfkern u;
  begin scalar x,y;
    if !*tayinternal!* then return u;
    % rest of code borrowed from fkern
    y := get('taylor!*,'klist);
    x := assoc(u,y);
    if null x
      then <>;
    return x
  end;

put('taylor!*, 'fkernfn, 'tayfkern);


symbolic procedure simptaylor u;
  %
  % (PrefixForm) -> s.q.
  %
  % This procedure is called directly by the simplifier.
  % Its argument list must be of the form
  %     (exp, [var, var0, deg, ...]),
  % where [...] indicate one or more occurences.
  % This means that exp is to be expanded w.r.t var about var0
  % up to degree deg.
  % var may also be a list of variables, which means that the
  % the expansion takes place in a homogeneous way.
  % If var0 is the special atom infinity var is replaced by 1/var
  % and the result expanded about 0.
  %
  % This procedure returns the input if it cannot expand the expression.
  %
  if remainder(length u,3) neq 1
    then Taylor!-error('wrong!-no!-args,'taylor)
   else if null subfg!* then mksq('taylor . u,1)
   else begin scalar !*precise,arglist,degree,f,ll,result,var,var0;
     %
     % Allow automatic combination of Taylor kernels.
     %
     if !*taylorautocombine and not ('taysimpsq memq mul!*)
       then mul!* := aconc!*(mul!*,'taysimpsq);
     %
     % First of all, call the simplifier on exp (i.e. car u),
     %
     f := simp!* car u;
     u := revlis cdr u; % reval instead of simp!* to handle lists
     arglist := u;
     %
     % then scan the rest of the argument list.
     %
     while not null arglist do
       << var := car arglist;
          var := if eqcar(var,'list) then cdr var else {var};
          % In principle one should use !*a2k
          % but typerr (maprin) does not correctly print the atom nil
          for each el in var collect begin
            el := simp!* el;
            if kernp el then return mvar numr el
             else typerr(prepsq el,'kernel)
            end;
          var0 := cadr arglist;
          degree := caddr arglist;
          if not fixp degree
            then typerr(degree,"order of Taylor expansion");
          arglist := cdddr arglist;
          ll := {var,var0,degree,degree + 1} . ll>>;
     %
     % Now ll is a Taylor template, i.e. of the form
     %  ((var_1 var0_1 deg1 next_1) (var_2 var0_2 deg_2 next_2) ...)
     %
     result := taylorexpand(f,reversip ll);
     %
     % If the result does not contain a Taylor kernel, return the input.
     %
     return if has!-Taylor!* result then result
             else mksq('taylor . prepsq f . u,1)
   end;

put('taylor,'simpfn,'simptaylor)$


%symbolic procedure taylorexpand (f, ll);
%  %
%  % f is a s.q. that is expanded according to the list ll
%  %  which has the form
%  %  ((var_1 var0_1 deg1) (var_2 var0_2 deg_2) ...)
%  %
%  begin scalar result;
%    result := f;
%    for each el in ll do
%      %
%      % taylor1 is the function that does the real work
%      %
%      result := !*tay2q taylor1 (result, car el, cadr el, caddr el);
%      if !*taylorkeeporiginal then set!-TayOrig (mvar numr result, f);
%      return result
%  end$


symbolic procedure taylor1 (f, varlis, var0, n);
  %
  % Taylor expands s.q. f w.r.t. varlis about var0 up to degree n.
  % var is a list of kernels, which means that the expansion
  % takes place in a homogeneous way if there is more than one
  % kernel.
  % If var0 is the special atom infinity all kernels in varlis are
  % replaced by 1/kernel.  The result is then expanded about 0.
  %
  taylor1sq (if var0 eq 'infinity
               then subsq (f,
                           for each krnl in varlis collect
                             (krnl . list ('quotient, 1, krnl)))
              else f,
             varlis, var0, n)$

symbolic procedure taylor1sq (f, varlis, var0, n);
  %
  % f is a standard quotient, value is a Taylor kernel.
  %
  % First check if it is a Taylor kernel
  %
  if Taylor!-kernel!-sq!-p f
    then if has!-TayVars(mvar numr f,varlis)
           %
           % special case: f has already been expanded w.r.t. var.
           %
           then taylorsamevar (mvar numr f, varlis, var0, n)
          else begin scalar y, z;
            f := mvar numr f;
            %
            % taylor2 returns a list of the form
            %  ((deg1 . coeff1) (deg2 . coeff2) ... )
            % apply this to every coefficient in f.
            % car cc is the degree list of this coefficient,
            % cdr cc the coefficient itself.
            % Finally collect the new pairs
            %  (degreelist . coefficient)
            %
            z :=
              for each cc in TayCoeffList f join
                for each cc2 in taylor2 (TayCfSq cc, varlis, var0, n)
                  collect
                    TayMakeCoeff (append (TayCfPl cc, TayCfPl cc2),
                                  TayCfSq cc2);
            %
            % Append the new list to the Taylor template and return.
            %
            y := append(TayTemplate f,list {varlis,var0,n,n+1});
            return make!-Taylor!* (z, y, TayOrig f, TayFlags f)
            end
   %
   % Last possible case: f is not a Taylor expression.
   % Expand it.
   %
   else make!-Taylor!* (
                 taylor2 (f, varlis, var0, n),
                 list {varlis,var0,n,n+1},
                 if !*taylorkeeporiginal then f else nil,
                 nil)$

symbolic procedure taylor2 (f, varlis, var0, n);
  begin scalar result,oldklist;
    oldklist := get('Taylor!*,'klist);
    result := errorset (list ('taylor2e,
                               mkquote f,
                               mkquote varlis,
                               mkquote var0,
                               mkquote n),
                        nil, !*backtrace);
    put('Taylor!*,'klist,oldklist);
    if atom result
      then Taylor!-error ('expansion, "(possible singularity!)")
     else return car result
  end$

symbolic procedure taylor2e (f, varlis, var0, n);
  %
  % taylor2e expands s.q. f w.r.t. varlis about var0 up to degree n.
  % var is a list of kernels, which means that the expansion takes
  % place in a homogeneous way if there is more than one kernel.
  % The case that var0 is the special atom infinity has to be taken
  % care of by the calling function(s).
  % Expansion is carried out separately for numerator and
  % denominator.  This approach has the advantage of not producing
  % complicated s.q.'s which usually appear if an s.q. is
  % differentiated.  The procedure is (roughly) as follows:
  %  if the denominator of f is free of var
  %   then expand the numerator and divide,
  %  else if the numerator is free of var expand the denominator,
  %   take the reciprocal of the Taylor series and multiply,
  %  else expand both and divide the two series.
  % This fails if there are nontrivial dependencies, e.g.,
  %  if a variable is declared to depend on a kernel in varlis.
  % It is of course necessary that the denominator yields a unit
  %  in the ring of Taylor series. If not, an error will be
  %  signalled by invtaylor or quottaylor, resp.
  %
  if cdr varlis then taylor2hom (f, varlis, var0, n)
   else if denr f = 1 then taylor2f (numr f, car varlis, var0, n, t)
   else if not depends (denr f, car varlis)
    then multintocoefflist (taylor2f (numr f, car varlis, var0, n, t),
                            1 ./ denr f)
   else if numr f = 1
    then delete!-superfluous!-coeffs
           (invtaylor1 ({varlis,var0,n,n+1},
                        taylor2f (denr f, car varlis, var0, n, nil)),
            1, n)
   else if not depends (numr f, car varlis)
    then multintocoefflist
           (invtaylor1 ({varlis,var0,n,n+1},
                        taylor2f (denr f, car varlis, var0, n, nil)),
            !*f2q numr f)
   else begin scalar denom; integer n1;
     denom := taylor2f (denr f, car varlis, var0, n, nil);
     n1 := n + taymincoeff denom;
     return
       delete!-superfluous!-coeffs
         (quottaylor1 ({varlis,var0,n1,n1+1},
                       taylor2f (numr f, car varlis, var0, n1, t),
                       denom),
          1, n)
  end$

symbolic procedure taylor2f (f, var, var0, n, flg);
  %
  % taylor2f is the procedure that does the actual expansion
  % of the s.f. f.
  % It returns a list of the form
  %  ((deglis1 . coeff1) (deglis2 . coeff2) ... )
  % For the use of the parameter `flg' see below.
  %
  begin scalar x, y, z; integer k;
    %
    % Calculate once what is needed several times.
    % var0 eq 'infinity is a special case that has already been taken
    % care of by the calling functions by replacing var by 1/var.
    %
    if var0 eq 'infinity then var0 := 0;
    x := list (var . var0);
    y := simp list ('difference, var, var0);
    %
    % The following is a first attempt to treat expressions
    % that have poles at the expansion point.
    % Currently nothing more than factorizable poles, i.e.
    % factors in the denominator are handled.
    % We use the following trick to calculate enough terms: If the
    % first l coefficients of the Taylor series are zero we replace n
    % by n + 2l.  This is necessary since we separately expand
    % numerator and denominator of an expression.  If the expansion of
    % both parts starts with, say, the quadratic term we have to
    % expand them up to order (n+2) to get the correct result up to
    % order n. However, if the numerator starts with a constant term
    % instead, we have to expand up to order (n+4).  It is important,
    % however, to drop the additional coefficients as soon as they are
    % no longer needed.  The parameter `flg' is used here to control
    % this behaviour.  The calling function must pass the value `t' if
    % it wants to inhibit the calculation of additional coefficients.
    % This is currently the case if the s.q. f has a denominator that
    % may contain the expansion variable.  Otherwise `flg' is used to
    % remember if we already encountered a non-zero coefficient.
    %
    f := !*f2q f;
    z := subs2 subsq (f, x);
    if null numr z and not flg then n := n + 1 else flg := t;
    y := list TayMakeCoeff ((list list 0), z);
    k := 1;
    while k <= n and not null numr f do
      << f := multsq (diffsq (f, var), 1 ./ k);
                                             % k is always > 0!
         % subs2 added to simplify expressions involving roots
         z := subs2 subsq (f, x);
         if null numr z and not flg then n := n + 2 else flg := t;
         if not null numr z then y := TayMakeCoeff(list list k, z) . y;
         k := k + 1 >>;
    return reversip y
  end;

symbolic procedure taylor2hom (f, varlis, var0, n);
  %
  % Homogeneous expansion of s.q. f wrt the variables in varlis,
  % i.e. the sum of the degrees of the kernels is varlis is <= n
  %
  if null cdr varlis then taylor2e (f, list car varlis, var0, n)
   else for each u in taylor2e (f, list car varlis, var0, n) join
     for each v in taylor2hom (cdr u,
                               cdr varlis,
                               var0,
                               n - get!-degree TayCfPl car u)
           collect list (car TayCfPl car u . TayCfPl car v) . cdr v$

symbolic procedure taylorsamevar (u, varlis, var0, n);
  begin scalar tp; integer mdeg, pos;
    if cdr varlis
      then Taylor!-error ('not!-implemented,
                          "(homogeneous expansion in TAYLORSAMEVAR)");
    tp := TayTemplate u;
    pos := car var!-is!-nth (tp, car varlis);
    tp := nth (tp, pos);
    if TayTpElPoint tp neq var0
      then return taylor1 (if not null TayOrig u then TayOrig u
                            else simp!* prepTaylor!* u,
                           varlis, var0, n);
    mdeg := TayTpElOrder tp;
    if n=mdeg then return u
     else if n > mdeg
      %
      % further expansion required
      %
      then << lprim "Cannot expand further... truncated.";
              return u >> ;
    return make!-Taylor!* (
        for each cc in TayCoeffList u join
          if nth (nth (TayCfPl cc, pos), 1) > n
            then nil
           else list cc,
        replace!-nth(TayTemplate u,pos,
                      {varlis,TayTpElPoint tp,n,n+1}),
        TayOrig u, TayFlags u)
  end$


comment The `FULL' flag causes the whole term (including the
        Taylor!* symbol) to be passed to SIMPTAYLOR!* ;

symbolic procedure simpTaylor!* u;
  if TayCoefflist u memq frlis!* or eqcar(TayCoefflist u,'!~)
    then !*tay2q u
   else <<
     %
     % Allow automatic combination of Taylor kernels.
     %
     if !*taylorautocombine and not ('taysimpsq memq mul!*)
       then mul!* := aconc!* (mul!*, 'taysimpsq);
     !*tay2q resimptaylor u >>$

flag ('(Taylor!*), 'full)$

put ('Taylor!*, 'simpfn, 'simpTaylor!*)$

comment The following is necessary to properly process Taylor kernels
        in substitutions;

flag ('(Taylor!*), 'simp0fn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taylor.red0000644000175000017500000014312011526203062024025 0ustar  giovannigiovannimodule Taylor;

%****************************************************************
%
%                      THE TAYLOR PACKAGE
%                      ==================
%
%****************************************************************
%
%  Copyright (C) 1989--2010 by Rainer M. Schoepf, all rights reserved.
%
%
%  Error reports please to: 
%
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%
%
%
%  This package implements a new data structure:
%
%            >>> the TAYLOR KERNEL <<<
%
%  and the functions necessary to operate on it.
%
%  A TAYLOR KERNEL is a kernel of the following form:
%
%   (Taylor!* TayCoeffList TayTemplate TayOrig TayFlags)
%
%   where:
%    Taylor!*        is a symbol identifying the kernel.
%    TayCoeffList    is a list of TayCoeff's.
%                    A TayCoeff is a pair
%                     (TayPowerList . StandardQuotient).
%                    A TayPowerList is a list of TayDegreeList's,
%                    each of which is a list of integers that
%                    denote the exponents of the Taylor variables.
%    TayTemplate     is a list of lists, each containing the three
%                    elements  TayVars, TayPoint, TayOrder,
%                    TayNextOrder, (being the list of variables, the
%                    expansion point the power of the variable in the
%                    last coefficient computed, and the power of the
%                    next coefficient, respectively)
%                    It is used as a template for the car of the
%                    pairs in a TayCoeffList.
%    TayOrig         is the original expression to be Taylor expanded,
%                    as a standard quotient. It is held mainly for
%                    the use by possible future extensions.
%                    This part is nil if the switch taylorkeeporiginal
%                    was off during expansion.
%    TayFlags        is currently unused and reserved for future
%                    extensions.
%
%
%
%*****************************************************************
%
%       Revision history
%
%*****************************************************************
%
% 21-Aug-2010    2.2c
%   Create taylor's own fkern function, instead of manipulating
%   the klist!* directly
%
% 08-Jun-2001    2.2b
%   Bind !*precise to nil in simptaylor, to avoid problems with SQRT
%    and ABS.
%
% 01-Apr-2000    2.2a
%   Corrected problem in taysimpasin, discovered by John Fitch.
%
% 18-Jun-1997    2.2
%   Added module TayPart, an interface to the PART operator.
%
%   Minor improvement in procedure taylorexpand!-samevar: do not signal
%    an error if we are content with the terms we got (i.e. third
%    argument flg is nil.
%
% 16-Apr-1997    2.1f
%   Slight improvement in tracing output (smacro Taylor!-trace).
%   Avoid infinite recursion when mcd is off (pointed out by
%    Wolfram Koepf).
%
% 03-May-1995    2.1e
%   Corrected differentation of Taylor kernels if expansion point
%    depends on variable. (Integration still gives wrong result.)
%   Printing procedures did not always work for right hand side of
%    rules.
%
% 03-Apr-1995    2.1d
%   Removed special handling for constant Taylor series in taysimptan,
%    taysimpsin and taysimpsinh, as it didn't work when the function in
%    question has a pole and the expansion point.
%
% 09-Jan-1995    2.1c
%   Changed rules in tayfns.red to new ~~ format.
%
% 22-Jul-1994    2.1b
%   Corrected glitch in function common!-increment.
%
% 10-Jun-1994    2.1a
%   Corrected expansion of tan at pole up to order 0: make quottaylor
%    and invtaylor signal restartable error, have taylorexpand truncate
%    its result.
%   Operator expint is now called ei.
%   Changed error message in taysimpasin to signal a branch point, not
%    an essential singularity.
%
% 08-May-1994    2.1
%   Added implicit_taylor and inverse_taylor.
%
%
% 02-May-1994    2.0c
%   Corrected missing Next field in function taylor2e.
%
% 14-Apr-1994    2.0b
%   Corrected function expttayi.
%   Renamed pos!-rat!-kern!-pow to rat!-kern!-pow and changed calling
%    convention, moved to tayutils module.
%   subfg!* changed from global to fluid.
%   Removed a few unused local variables.
%   Added TayExp!-max2.
%   Rewrote expansion code for monomials to produce higher order terms.
%
% 14-Mar-1994    2.0a
%   Corrected generation of simple Taylor kernels when switch mcd is
%    off.
%   Added code to catch looping with increased order, introduced a
%    better error message.
%   Added a few missing parentheses in functions taysimpexpt and
%    tayrevert1.
%
% 03-Mar-1994    2.0
%   Introduced rational exponents for Puiseux series. This required
%    changes to various functions:
%      Taylor exponent manipulation functions
%      expttayrat
%      expttayrat!* (removed)
%      pos!-rat!-kern!-pow
%      smallest!-increment and common!-increment
%      truncate!-Taylor!*
%      tayrevert1
%   Added exceeds!-order!-variant that uses strict greaterp, rather
%    than geq as exceeds!-order does.
%   Added lcmn to compute the least common multiple of two integers.
%   Replaced call to subs2 with binding of !*sub2 by subs2!* in
%    functions below.
%   Removed error type inttaylorwrttayvar, no longer generated.
%   
%
%
% 15-Feb-1994    1.9c
%   Improved taysimpsinh to generate hyperbolic functions in the
%    the coefficients of the result rather than exponentials.
%   Improved handling of zero Taylor kernels if TayOrig is present.
%   Improved taylorexpand!-samevar to handle expansions in more
%    than one variable.
%   Corrected Taylor substitution to handle parallel substitution
%    of several Taylor variables.
%   Updated check for differentiation rules of kernels.
%   Added new error types for Taylor expansion of implicit and
%    inverse functions.
%   Made division by zero in taysubst recoverable error during
%    expansion.
%   Corrected term ordering in Taylorexpand!-diff2.
%   Corrected addition and multiplication of Taylor kernels in
%    taylorexpand!-sf.
%   Added taysimpasec!* to handle singular arguments of asec and
%    friends.
%
% 02-Dec-1993    1.9b
%   Added missing setting of TayOrig part in make!-var!-Taylor!*.
%   Corrected handling of substitution of all Taylor variables in
%    taysubst.
%   Ensure that psi is declared algebraic operator.
%   Corrected substitution of Taylor variable by a power of itself.
%
% 30-Nov-1993    1.9a
%   Corrected cdr of nil in several places, caused by makecoeffs
%    returning an empty list.
%   Improved handling of zero Taylor kernels if TayOrig is present.
%   Added missing setting of TayOrig part in taylorexpand!-diff2.
%
% 29-Nov-1993    1.9
%   Added min2!-order and replace!-next.
%   Improved basic Taylor manipulation functions addtaylor, multtaylor,
%    quottaylor.
%   Added taylorsingularity feature to expansion code.
%
%
% 24-Nov-1993    1.8h
%   Changed calling convention for addtaylor1 to include the template.
%
% 15-Nov-1993    1.8g
%   Rewritten parts of subsubtaylor to better recognize invalid
%    substitutions.
%
% 09-Nov-1993    1.8f
%   Added TayExp!-geq and TayExp!-leq.
%   Changed protocol of truncate!-coefflist and exceeds!-order to use
%    the next part rather than the order part of a template.
%   Cleaned up inv!.tp!..
%
% 08-Nov-1993    1.8e
%   Improved handling of negative first coefficient in taysimplog.
%   Removed binding of !*taylorautocombine in taysimpsq!*.
%
% 03-Nov-1993    1.8d
%   Improved taysimpsq and taysimpf to avoid returning a constant Taylor
%    series as part of an expression.
%   Fixed bug in error handling of expansion code that would produce
%    "This can't happen" error message.
%   Improved error detection for (unknown) operators with logarithmic
%    singularity in derivative.
%   Removed tayinpoly/tayinpoly1 (no longer used).
%   Replaced !*f2q by !*TayExp2q in difftaylorwrttayvar.
%   Changed evaluation and printing procedures so that they can be used
%    in rule patterns.
%   Corrected bug in Taylor kernel integration if the switch
%    taylorkeeporiginal was on.
%   Improved integration of Taylor kernels in combination with
%    logarithmic terms.
%   Rewrote rules integration rules in algebraic form.
%   Added TpNextList smacro.
%   Changed mult!.comp!.tp!. in preparation for non-integer exponents,
%    to handle next parts.
%   Added invert!-powerlist smacro and used in invtaylor1.
%   Renamed taydegree!-lessp to taydegree!< and
%    taydegree!-strict!-less!-or!-equal!-p to taydegree!-strict!. The macro Taylor!: is used to replace normal
%    operations by these.
%    Changed makecoeffpairs and addcoeffs to avoid consing pairs and
%     taking them apart again.
%    Changed makecoeffpairshom to allow steps different from 1.
%
%
% 07-Jun-1993    1.4l
%   Introduced TayNextOrder and made corresponding changes to the
%    sources.
%   Added addto!-all!-TayTpElOrders function.
%   Corrected problem in expttayrat that would result in extra (wrong)
%    terms if there was no constant term in the Taylor series to be
%    raised to a power.
%   Removed some calls to !*n2f.
%   Replaced call to subs2 by subs2!* in taysimptan.
%   Corrected generation of new template in inttaylorwrttayvar
%
% 03-Jun-1993    1.4k
%   Changed expttayi to handle negative integer powers as well,
%    changed taysimpp correspondingly.
%
% 27-May-1993    1.4j
%   Corrected some oversights in taysimpexpt.
%   Added smacro TayTpVars.
%   Added code to taysimpp to handle s.f. as main variable.
%   Added function subtr!-degrees to tayutils.red.
%   Corrected error in var!-is!-nth in tayintro.red.
%   Corrected error in taydegree!-lessp in tayutils.red that caused
%    incorrect ordering of coefficients.
%   Corrected error in quottaylor1.
%
% 06-May-1993    1.4i
%   Changed printing routines for better interface to fancy printing.
%
% 21-Apr-1993    1.4h
%   Corrected cosec --> csc, cosech --> csch in tayfns.red.
%   Corrected taysimpsin to calculate coth with correct overall sign.
%   Improved handling of poles in taysimptan.
%   Rewritten taysimpsin to use exponential rather than tangent.
%   Added slight optimization in taylorsamevar if desired matches
%    actual expansion order.
%
% 01-Apr-1993    1.4g
%   Changed multtaylor1 so that in multiplication of Taylor kernels
%    products would be simplified as well.
%   Changed taysimptan to allow expansion point to be a pole of tan,
%    cot, tanh, or coth.
%   Changed constant!-sq!-p and taysimpexpt to recognize constant
%    expression in first argument to expt.
%   Changed printing so that only non-vanishing terms are counted.
%   Introduced taysimpsinh for simplifcation of expressions involving
%   sinh, coth, sech, csch.
%   Added subs2coefflist and resimpcoefflist smacros.
%   Modified addtaylor1, multtaylor1, quottaylor1 and invtaylor1 to call
%    subs2coefflist.
%   Protected klist property of atom Taylor!* against being filled
%    unnecessarily with intermediate results.
%   Changed expttayrat to print a more meaningful error message when it
%    detects a branch point.
%   Improved taysimpexpt to handle more cases.
%
% 08-Mar-1993    1.4f
%   Changed printing of Taylor kernels to include `(nn terms)' instead
%    of `...'.
%
% 25-Feb-1993    1.4e
%   Made expttayi more efficient by replacing straightforward 
%    multiplication by a scheme that computes powers of 2.
%   Corrected error in taysimpexp.
%
% 24-Feb-1993    1.4d
%   Corrected error in taydiffp.
%   Made especially multtaylor1, but also addtaylor1 and expttayrat
%    more efficient.
%
% 01-Feb-1993    1.4c
%   Corrected error in tayrevert1: constant term was missing.
%   Changed frlis!* from global to fluid.
%   Corrected error in taylor2f that caused certain expressions, like
%    i^2, not to be simplified correctly (discovered by Stan Kameny).
%
% 16-Apr-1992    1.4b
%   Corrected errors in taysimpexpt, mult!.comp!.tp!., and expttayrat.
%   The error corrected in version 1.4a was also present in invtaylor.
%   Corrected error in taylor2e/taylor2f.
%   Improved printing of negative coefficients.
%   Corrected error in subsubtaylor.
%   Corrected error in taysimpexp.
%   Added simp0fn property to Taylor!* for proper handling of
%    substitutions.
%   Added make!-cst!-coefficient smacro.
%   Added partial suppression of printing of coefficients and
%    TAYLORPRINTTERMS variable.
%
% 11-Feb-1992    1.4a
%   Corrected error in quottaylor1: If numerator or denominator had
%    a zero constant term, the result had the wrong number of terms.
%
% 09-Jan-1992    1.4
%   Implemented Taylor reversion.
%
%
% 07-Jan-1992    1.3e
%   Corrected bug in taysimpsin: wrong type of return value.
%
% 27-Nov-1991    1.3d
%   Corrected glitch in quottaylor1: Taylor kernel representing 0
%    as numerator gave an error.
%
% 06-Nov-1991    1.3c
%   Improved support for integration of expressions involving Taylor
%    kernels.
%
% 31-Oct-1991    1.3b
%   Added (limited) support for the integration of Taylor kernels.
%
% 19-Jul-1991    1.3a
%   Introduced taysimpmainvar for main variables that are standard
%    forms, as in factored expressions. Changed taysimpp accordingsly.
%   Introduced new smacros !*tay2f and !*tay2q that make Taylor kernels
%    unique.
%
% 03-Jun-1991    1.3
%   Started version for REDUCE 3.4.
%   Updated diffp according to changes for REDUCE 3.4.
%   Replaced freeof by has!-Taylor!* in taysimpf and taysimpt, and by
%    depends in difftaylor and taylor2e.
%   Changed module names to conform to file names.
%   Moved (nearly) all smacros into header (taylor) module,
%    made cst!-Taylor!* an smacro, moved remaining functions from
%    taymacros into tayutils, deleted taymacros module.
%   Made makecoeffpairs (in module taybasic) from smacro to expr.
%   Changed taylorsamevar to use TayOrig part of Taylor kernel if
%    present.
%   Changed Taylor printing functions since it is now possible to
%    pass information of operator precedence (via pprifn property).
%   Fixed bug in subsubtaylor (found by H. Melenk): did not substitute
%    in expansion point.
%   Changed error handling to call new function rerror instead of
%    rederr.
%   Changed for use of new hooks prepfn2, subfunc, and dfform
%    instead of redefining sqchk, subsublis, and diffp.
%
% 20-Oct-1990    1.2j
%   Added check in subsubtaylor for variable dependency.
%   Fixed stupid bug in taylorsamevar.
%   Corrected taysimpexpt to handle rational exponents with ON RATIONAL.
%   Corrected expttayrat: looks now at first NON-ZERO coefficient to
%    determine whether root can safely be computed.
%   Fixed bug in mult!.comp!.tp..
%   Added error check in invtaylor1 and quottaylor1.
%   Fixed bug in quottaylor1 that produced wrong results for
%    multidimensional Taylor series, introduced taydegree!-min2 and
%    taydegree!-strict!-less!-or!-equal!-p.
%
% 05-Oct-1990    1.2i
%   Replaced variable name nn by nm in taysimpsq to avoid name conflicts
%    with the SPDE package by Fritz Schwartz.
%   Replaced call to apply by apply1 in taysimpkernel.
%   Minor changes in expttayrat, taysimplog, taysimpexp, and taysimptan:
%    inserted explicit calls to invsq to allow negative numbers in
%    denominator.
%   Fixed bugs in difftaylorwrttayvar, inttaylorwrttayvar and
%    subsubtaylor: treatment of a Taylor kernel expanded about infinity
%    would give a wrong result.  Found by John Stewart.
%
% 11-Aug-1990    1.2h
%   Replaced call to get!* by get in diffp since get!* will no longer
%    be available in REDUCE 3.4.
%   Fixed bug in multintocoefflist that was introduced by replacing
%    car by TayCfPl.
%   Moved setting of TayOrig part from taylor1 to taylorexpand.  This
%    avoids Taylor kernels in the TayOrig part of multidimensional
%    Taylor expansions.  It does not fully solve the problem since
%    they can still be generated by applying the Taylor operator to
%    expressions that do not contain fully Taylor-combined Taylor
%    kernels.
%   Reversed list of expansions in call to taylorexpand in simptaylor.
%    Modified taylor1 accordingly.  Previously this could trigger a
%    `This can't happen' error message (due to incorrect ordering of
%    the Taylor variables).
%   Removed procedures delete!-coeff and replace!-coeff since they are
%    no longer used.
%   Moved call to subs2 out of differentiation loop in taylor2f,
%    improves timing significantly; deleted superfluous declared
%    integer variable.
%   Fixed bug in taylorsamevar.
%   Added extra checks and double evaluation of lists in simptaylor.
%   Replaced a number of ./ by !*f2q, introduced some !*n2f conversion
%    functions.
%   Development frozen, version shipped out.
%
% 06-May-1990    1.2g
%   Fixed bug in taylor2e that caused order of kernels in homogenous
%    expansions to be reverted.  Discovered by Karin Gatermann.
%   Removed binomial!-coeff since no longer needed (in expttayrat).
%   Replaced some forgotten car/cdr by TayCfPl/TayCfSq.
%   Reordered import declarations.
%   Replaced many semicolons by dollar signs.  Decreases amount of
%    printing during input of this file.
%   Minor bug fix in taysimpsin.
%   Minor change in taysimpasin and taysimpatan.
%   Split inttaylorwrttayvar into two procedures, added check for
%    logarithmic term in integration procedure inttaylorwrttayvar1.
%   Replaced combination of addsq and negsq by subtrsq in quottaylor1,
%    subsubtaylor and taysimplog.
%   Renamed taygetcoeff to TayGetCoeff (doesn't make any difference
%    on case-insensitive systems).
%   Minor changes in taymultcoeffs, multintocoefflist, resimptaylor,
%    taylor1sq, taylor2f, negtaylor1, quottaylor1, invtaylor1,
%    expttayrat, subsubtaylor, difftaylor, taysimpasin, taysimpatan,
%    taysimplog, taysimpexp, taysimptan, difftaylorwrttayvar,
%    inttaylorwrttayvar1, addtaylor1 (cons -> TayMakeCoeff).
%   Similar change in taysimpp (cons -> .**, i.e. to).
%
% 29-Mar-1990    1.2f
%   Fixed bug in taysimpf (addition of Taylor kernels) that could cause
%    "This can't happen" message.
%   Fixed bug in difftaylorwrttayvar: arguments to make!-cst!-coefflis
%    were interchanged.
%   Fixed similar bug in expttayrat (this procedure was never used!)
%   Added forgotten call to list in taylor2f.
%   Changed representation of big-O notation: print O(x^3,y^3) instead
%    of O(x^3*y^3) if expansion was done up to x^2*y^2.
%   Introduced new version of expttayrat (algorithm as quoted by Knuth)
%    which is faster by about a factor of two.
%   Fixed Taylor!-gen!-big!-O so that expansion point at infinity
%    is treated correctly for homogeneously expanded series.
%
% 27-Feb-1990    1.2e
%   Removed procedures addlogcoeffs, addexpcoeffs and addtancoeffs,
%    inserted code directly into taysimplog, taysimpexp, and
%    taysimptan.
%   taylorvars renamed to TayVars.
%   find!-non!-zero moved into Taylor!:macros module.
%
% 26-Feb-1990    1.2d
%   Added following selector, constructor, and modification smacros:
%    TayCfPl, TayCfSq, TayMakeCoeff, set!-TayCfPl, set!-TayCfSq,
%    TayTpElVars, TayTpElPoint, TayTpElOrder.
%   Some minor changes in several procedures to improve readability.
%
% 19-Jan-1990    1.2c
%   Removed first argument of addtaylor since never used.
%
% 14-Nov-1989    1.2b
%   Added taysimpsin.
%   Split tayinpoly1 off from tayinpoly, modified expttayrat
%    accordingly.
%   Changed global declarations to fluid.  No reason to prevent
%    binding.
%
% 11-Nov-1989    1.2a
%   Minor changes in the procedures changed yesterday (cleanup).
%   Added procedure taysimptan.
%   Replaced taylor1sq by taylorexpand in taysimpf1.
%   taysimpsq partly rewritten (will these bugs never die out?)
%   taysimpf1 renamed to taysimpf, taylor!*!-sf!-p to
%    Taylor!-kernel!-sf!-p.
%   Replaced a few of these by Taylor!-kernel!-sq!-p.
%
% 10-Nov-1989    1.2
%   Introduced taylorexpand to be the heart of simptaylor and to
%    replace simptaylor in taysimpt and multpowerintotaylor.
%   Added new versions of procedures taysimplog and taysimpexp
%    (Knuth's algorithm).
%   Taylor!:basic module moved up (so that some smacros are
%    defined earlier).
%
%
% 09-Nov-1989    1.1b
%   Fixed bug in taylor2e: quottaylor1 got the wrong template so
%    that it would truncate the resulting coeff list.
%   Added call to subs2 after call to diffsq in taylor2f so that
%    expressions containing radicals are simplified already at
%    this point.
%
% 21-Aug-1989    1.1a
%   Fixed bug in taysimpp: it could return a s.q. instead of a s.f.
%   Added a few forgotten import declarations.
%
% 31-Jul-1989    1.1
%   Slight changes in calls to confusion, minor change in taysimpp.
%   Introduced big-O notation, added taylorprintorder switch.
%   taysimpasin and taysimpatan now also calculate the inverse
%    hyperbolic functions.
%   New smacro Taylor!-kernel!-sq!-p replaces combinations of
%    kernp and Taylor!*p.
%
%
% 24-Jul-1989    1.0a
%   Bug fix in constant!-sq!-p: mvar applied to s.q., not s.f.
%   Added safety check in taysimpt.
%
% 27-May-1989    1.0
%   Decided to call this version 1.0, it seems to be sufficiently (?)
%    bug free to do so.
%   Minor bug fix in expttayrat (forgotten variable declaration).
%
%
% 25-May-1989    0.9l
%   Bug fixed in taylor2e
%    (thanx to Rich Winkel from UMC for pointing out this one).
%   Cleaned up the code for truncating when combining Taylor kernels
%    of different order.
%   Introduced taysimpasin for computing the asin, acos, etc.
%    of a Taylor kernel.
%   Changed some internal procedures to call addtaylor1, etc.
%    instead of addtaylor, etc. if both arguments have the same
%    template.
%   Changed representation of the coefflist: expansion with respect
%    to one variable is a special case of homogeneous expansion.
%    This is now reflected in the internal representation.  These
%    changes make the code shorter since all expansions are
%    done the same way (fewer checks necessary).
%
% 23-Mar-1989    0.9k
%   Numerous bug fixes.
%   Changed subsubtaylor to allow error checking in var!-is!-nth.
%   Rewrote taydegree!-lessp to iterate over its arguments rather
%    than call itself recursively.
%   Introduced exceeds!-order instead of taydegree!-lessp
%    (in truncate!-coefflist and multtaylor1).
%   Minor changes in Taylor!*!-sf!-p, taysimpexp, var!-is!-nth,
%    taysimpexpt, and inttaylorwrttayvar.
%   Changed simptaylor!* to apply resimp to all coefficients and
%    to the tayorig part.
%   Changed subsubtaylor to allow substitution of a kernel into a
%    homogeneously expanded expression.
%   Changed difftaylorwrttayvar to allow differentiation of
%    homogeneously expanded expressions.
%   Changed subsubtaylor so that substitution of a kernel is possible
%    (not only a variable).
%   New constructor smacros make!-Taylor!* and TayFlagsCombine replace
%    explicit list building.
%   New procedures: get!-degree and truncate!-coefflist induced
%    changes in addtaylor/multtaylor/quottaylor/invtaylor.
%    This fixes the other problem pointed out by H. Melenk.
%   Split addtaylor/multtaylor the same way as quottaylor/invtaylor.
%   Introduced taylorautocombine switch and interface to simp!*
%    (via mul!* list).
%   Added symbolic; statement in taylor!-intro module; necessary
%    until module/endmodule are fixed to work together with faslout.
%   Changed subsubtaylor to return a conventional prefix form
%    if all Taylor variables are substituted by constants.
%   Changed difftaylorwrttayvar to ensure that the coefflist of
%    the Taylor kernel it returns is not empty.
%   Changed subsubtaylor to avoid 0**n for n<=0 when substituting
%    a Taylor variable (to signal an error instead);  changed
%    taylor!-error accordingly.
%   Added taylortemplate operator, removed smacro
%    taylor!-map!-over!-coefficients.
%   Added code for expansion about infinity.
%   Split quottaylor into two parts: the driver (quottaylor) and
%    the routine doing the work (quottaylor1).  Same for invtaylor.
%   Rewrote the expansion procedures taylor1, taylor2,...
%   Change in taylor2e: added flg parameter, introduced
%    delete!-superfluous!-coeffs.
%   Added set!-tayorig and multintocoefflist.
%   Replaced simp by simp!* for simplication of tayorig part in
%    taysimplog and taysimpexpt.
%   Removed taysimpsq in taylorseriesp: it now returns t iff its
%    argument is a Taylor kernel disguised as a standard quotient.
%   Added taylororiginal operator.
%   Added a number of tests if tayorig of a Taylor kernel is non-nil
%    if !*taylorkeeporiginal is set.
%   Replaced calls to simpdiff in taylor2e and simpexpt by a call
%    to simp.
%   Minor change in taylor!*print!*1.
%   H. Melenk discovered that the code did not behave as documented:
%    addition of Taylor kernels differing only in their order did not
%    work, and Taylor expansion of a Taylor kernel w.r.t. one of its
%    variables would fail.
%    Corrected the latter problem by changing the substitution code
%    to allow a Taylor variable to be replaced by a constant.
%   taylorseriesp is now a boolean operator and therefore only
%    usable in if statements.
%   Replaced calls to subsq1/subf1 by subsq/subf,
%    definitions of subsq1 and taymaxdegree deleted.
%   Minor changes in taylor2hom and taylor2e.
%
% 28-Nov-1988    0.9j
%   Changed printing of `. . . ' to `...'.
%   Changed simptrig to simp in taysimpatan.
%   Changed simptaylor to simplify all its arguments, not only
%    the first one.
%   Added !*verboseload switch to conditionalize printing of
%    loading info.
%   Changed taylor2 to call taylor!-error instead of rederr.
%    Modified taylor!-error accordingly.
%
% 16-Nov-1988    0.9i
%   Fixed a Typo in quottaylor.
%   Inserted module/endmodule declarations.
%   Added errorset in taylor2 to catch zero denominators, etc.,
%    caused by expansion about essential singularities.
%
% 10-Nov-1988    0.9h
%   Fixed bugs that caused taking car of an atom (found by A.C.Hearn).
%    taysimpt used multf instead of multpf.
%    I also discovered a car/cdr of nil in
%    makecoeffpairs1/makecoeffpairshom1.
%    Reason: (nil . nil) == (nil), but what I want is
%    ((nil . nil)) == ((nil)).  Stupid, eh?
%
% 23-Jul-1988    0.9g
%   Added dmode!* to list of fluid variables,
%    removed taylor!-map!-over!-coefficients!-and!-orig.
%
% 26-May-1988    0.9f
%   Minor bug fix in taydegree!-lessp.
%
% 25-May-1988    0.9e
%   Fixed a number of smaller bugs.
%   Finally implemented multiplication and division for
%    homogeneously expanded Taylor series.
%   Today I realized that the procedure diffp in ALG2 had
%    been changed for REDUCE 3.3.
%
% 21-May-1988    0.9d
%   Fixed bug in invtaylor.
%   Rewrote quottaylor to do direct division rather use invtaylor.
%
% 14-May-1988    0.9c
%   Fixed substitution for expansion variable.
%
% 11-May-1988    0.9b
%   Fixed user interface functions taylorseriesp and taylortostandard.
%
% 10-May-1988    0.9a
%   Small changes in subsubtaylor and difftaylor to make the code
%    compilable, plus minor bug fixes.
%
% 08-May-1988    0.9
%    invtaylor changed to allow inversion of multidimensional
%     Taylor kernels (but still not for homogeneous expansion).
%
%
% 06-May-1988    0.8i
%   `conc' changed to `join' (for mnemonic purposes).
%
% 29-Apr-1988    0.8h
%   Minor bug fix in invtaylor (missing quote).
%
% 21-Mar-1988    0.8g
%   Minor change in TayDegreeSum.
%
% 17-Jan-1988    0.8f
%   Started implementation of homogeneous expansion
%    (required change in conversion to prefix form).
%
% 16-Jan-1988    0.8e
%   Minor change in the definition of confusion.
%
% 15-Jan-1988    0.8d
%   Changed to conform to REDUCE 3.3
%    (SWITCH statement, minor changes in parsing).
%
% 03-Jan-1988    0.8c
%   First version that is supposed to return always a correct result
%    (but not all possible cases are handled).
%
%
%*****************************************************************
%
%       Things to do:
%
%*****************************************************************
%
%     a) Finish implementation of homogeneous expansion (hard).
%     b) Find a method to handle singularities (very hard).
%     c) Perhaps I should change the definition of ORDP to order
%         Taylor kernels in some special way?
%     d) A better interface for the PART operator is desirable, e.g.
%         where the whole argument list to PART is passed to some
%         function.
%        It is not possible to interface to COEFF and COEFFN with
%         redefining the functions in the REDUCE kernel.
%     e) Rewrite the expansion code to recursively descend a standard
%         form.  This allows recognition of certain special functions,
%         e.g., roots and logarithms.  (Much work, requires rewriting
%         of a large part of the code.)
%     f) With e) it is easy to implement a DEFTAYLOR operator so that
%         the user may define the Taylor expansion of an unknown
%         function.
%     g) This would also allow the use of Taylor for power series
%         solutions of ODEs.
%     h) Implement a sort of lazy evaluation scheme, similar to the
%         one used in the TPS package written by Alan Barnes and
%         Julian Padget.  This would allow the calculation of more
%         terms of a series when they are needed.
%     i) Replace all non-id kernels that are independent of the Taylor
%         variables by gensyms.  This would reduce the size of the
%         expressions.
%
%

create!-package('(Taylor TayIntro TayUtils TayIntrf TayExpnd TayBasic
                  TaySimp      TaySubst  TayDiff  TayConv     TayPrint
                  TayFront TayFns TayRevrt TayImpl TayPart),
                '(contrib taylor));


%*****************************************************************
%
%       Non-local variables used in this package
%
%*****************************************************************

fluid  '(Taylor!:version        % version number
         Taylor!:date!*         % release date
         TaylorPrintTerms       % Number of terms to be printed
         !*tayexpanding!*
         !*tayinternal!*
         !*tayrestart!*
         !*taylorkeeporiginal   % \
         !*taylorautoexpand     %  \
         !*taylorautocombine    %   >  see below
         !*taylorprintorder     %  /
         !*trtaylor             % /
         convert!-Taylor!*
         !*sub2
         !*verboseload);

share TaylorPrintTerms;

comment This package has six switches:
        `TAYLORKEEPORIGINAL' causes the expression for which the
        expansion is performed to be kept.
        `TAYLORAUTOEXPAND' makes Taylor expressions ``contagious''
        in the sense that all other terms are automatically
        Taylor expanded and combined.
        `TAYLORAUTOCOMBINE' causes taysimpsq to be applied to all
        expressions containing Taylor kernels.  This is equivalent
        to applying `TAYLORCOMBINE' to all those expressions.
        If `TAYLORPRINTORDER' is set to ON Taylor kernels are
        printed in big-O notation instead of just printing three dots.
        `TRTAYLOR', if on, prints some information about the expansion
        process.
        `VERBOSELOAD' is a variable used by Portable Standard Lisp
        and causes a loading info to be printed;

switch taylorautocombine,
       taylorautoexpand,
       taylorkeeporiginal,
       taylorprintorder,
       trtaylor,
       verboseload;

convert!-Taylor!* := nil;      % flag indicating that Taylor kernels
                               % should be converted to prefix forms
TaylorPrintTerms := 5;         % Only this nubmer of non-zero terms 
                               % will normally be printed.
!*taylorkeeporiginal := nil;   % used to indicate if the original
                               % expressions (before the expansion)
                               % are to be kept.
!*taylorautoexpand := nil;     % set if non-taylor expressions are to
                               % be expanded automatically on
                               % combination.
!*taylorautocombine := t;      % set if taysimpsq should be added to
                               % the MUL!* list.
!*taylorprintorder := t;       % set if Taylor kernels should be printed
                               % with big-O notation, now on by default.
%!*verboseload := nil;         % set if loading info should be printed
!*tayexpanding!* := nil;       % set by taylorexpand to indicate that
                               % expansion is in progress.
!*tayinternal!* := nil;        % set while doing internal computations,
                               % to indicate that some normal REDUCE 
                               % operations should not be done (like
                               % making kernels unique and storing them.
!*tayrestart!* := nil;         % set by Taylor!-error!* if expansion is
                               % in progress to indicate that the error
                               % might disappear if the order is
                               % increased.
Taylor!:version := "2.2b";      % version number of the package
Taylor!:date!* := "08-Jun-2001"; % release date

if !*verboseload then
  << terpri ();
     prin2 "TAYLOR PACKAGE, version ";
     prin2 Taylor!:version;
     prin2 ", as of ";
     prin2 Taylor!:date!*;
     prin2t " for REDUCE 3.7 being loaded...";
     terpri () >> ;



exports !*tay2f, !*tay2q, !*TayExp2q, copy!-list, cst!-Taylor!*,
        get!-degree, get!-degreelist, has!-Taylor!*, has!-TayVars,
        make!-cst!-coefficient, make!-cst!-coefflis,
        make!-cst!-powerlist, make!-Taylor!*, multintocoefflist,
        nzerolist, prepTayExp, resimpcoefflist, resimptaylor,
        set!-TayCfPl, set!-TayCfSq, set!-TayCoeffList, set!-TayFlags,
        set!-TayOrig, set!-TayTemplate, subs2coefflist, TayCfPl,
        TayCfSq, TayCoeffList, TayDegreeSum, TayExp!-difference,
        TayExp!-greaterp, TayExp!-lessp, TayExp!-max2, TayExp!-min2,
        TayExp!-minus, TayExp!-minusp, TayExp!-plus, TayExp!-plus2,
        TayExp!-times, TayExp!-times2, TayFlags, TayFlagsCombine,
        TayGetCoeff, Taylor!*p, Taylor!-kernel!-sf!-p,
        Taylor!-kernel!-sq!-p, Taylor!:, TayMakeCoeff, taymincoeff,
        taymultcoeffs, TayOrig, TayTemplate, TayTpElNext,
        TayTpElOrder, TayTpElPoint, TayTpElVars, TayVars,
        TpDegreeList;

imports

% from REDUCE kernel: 
        !*f2q, !*i2rn, !*p2f, !*p2q, !:minusp, confusion, domainp,
        eqcar, kernp, lastpair, lc, ldeg, lpriw, mathprint, mk!*sq,
        mksp, multsq, mvar, nlist, numr, over, prin2t, red, resimp,
        rndifference!:, rnminus!:, rnminusp!:, rnplus!:, rnprep!:,
        rnquotient!:, rntimes!:, simprn, smember, subs2, subs2!*,

% from module Tayintro:
        smemberlp,

% from module Tayutils:
        add!-degrees;

%*****************************************************************
%
%      General utility smacros
%
%*****************************************************************


symbolic smacro procedure nzerolist n;
  %
  % generates a list of n zeros
  %
  nlist (0, n);

symbolic smacro procedure copy!-list l;
  %
  % produces a copy of list l.
  %
  append (l, nil);



%*****************************************************************
%
%      Selector and constructor smacros for Taylor kernels
%
%*****************************************************************


symbolic smacro procedure make!-Taylor!* (cflis, tp, orig, flgs);
  %
  % Builds a new Taylor kernel structure out of its parts.
  %
  {'Taylor!*, cflis, tp, orig, flgs};

symbolic smacro procedure TayMakeCoeff (u, v);
  %
  % Builds a coefficient from degreelist and s.q.
  %
  u . v;


comment Selector smacros for the parts of a Taylor kernel;

symbolic smacro procedure TayCoeffList u; cadr u;

symbolic smacro procedure TayTemplate u; caddr u;

symbolic smacro procedure TayOrig u; cadddr u;

symbolic smacro procedure TayFlags u; car cddddr u;

symbolic smacro procedure TayCfPl u; car u;

symbolic smacro procedure TayCfSq u; cdr u;

symbolic smacro procedure TayTpVars tp;
  for each x in tp join copy!-list car x;

symbolic smacro procedure TayVars u;
  TayTpVars TayTemplate u;

symbolic smacro procedure TayGetCoeff (degrlis, coefflis);
  (if null cc then nil ./ 1 else TayCfSq cc)
    where cc := assoc (degrlis, coefflis);

symbolic smacro procedure TayTpElVars u; car u;

symbolic smacro procedure TayTpElPoint u; cadr u;

symbolic smacro procedure TayTpElOrder u; caddr u;

symbolic smacro procedure TayTpElNext u; cadddr u;

symbolic smacro procedure TpDegreeList tp;
  for each x in tp collect TayTpElOrder x;

symbolic smacro procedure TpNextList tp;
  for each x in tp collect TayTpElNext x;

%symbolic smacro procedure TayDegreeList u;
%  TpDegreeList TayTemplate u;

symbolic smacro procedure TayDegreeSum u;
  for each x in TayTemplate u sum TayTpElOrder x;


comment Modification smacros;

symbolic smacro procedure set!-TayCoeffList (u, v);
  %
  % Sets TayCoeffList part of Taylor kernel u to v
  %
  rplaca (cdr u, v);

symbolic smacro procedure set!-TayTemplate (u, v);
  %
  % Sets TayTemplate part of Taylor kernel u to v
  %
  rplaca (cddr u, v);

symbolic smacro procedure set!-TayOrig (u, v);
  %
  % Sets TayOrig part of Taylor kernel u to v
  %
  rplaca (cdddr u, v);

symbolic smacro procedure set!-TayFlags (u, v);
  %
  % Sets TayFlags part of Taylor kernel u to v
  %
  rplaca (cddddr u, v);

symbolic smacro procedure set!-TayCfPl (u, v);
  rplaca (u, v);

symbolic smacro procedure set!-TayCfSq (u, v);
  rplacd (u, v);


comment Smacro that implement arithmetic operations on
        exponents in powerlist;

symbolic smacro procedure exponent!-check!-int rn;
   if cddr rn=1 then cadr rn else rn;

symbolic procedure !*TayExp2q u;
   if atom u then !*f2q (if zerop u then nil else u)
    else cdr u;

symbolic procedure !*q2TayExp u;
   (if null x then confusion '!*q2TayExp
     else exponent!-check!-int car x)
      where x := simprn {mk!*sq u};

symbolic procedure prepTayExp u;
   if atom u then u else rnprep!: u;

symbolic macro procedure TayExp!-plus x;
   if null cdr x then 0
    else if null cddr x then cadr x
    else expand(cdr x,'TayExp!-plus2);   

symbolic procedure TayExp!-plus2(e1,e2);
   if atom e1 and atom e2 then e1+e2
    else exponent!-check!-int(
           if atom e1 then rnplus!:(!*i2rn e1,e2)
            else if atom e2 then rnplus!:(e1,!*i2rn e2)
            else rnplus!:(e1,e2));

symbolic procedure TayExp!-difference(e1,e2);
   if atom e1 and atom e2 then e1-e2
    else exponent!-check!-int(
           if atom e1 then rndifference!:(!*i2rn e1,e2)
            else if atom e2 then rndifference!:(e1,!*i2rn e2)
            else rndifference!:(e1,e2));

symbolic procedure TayExp!-minus e;
   if atom e then -e else rnminus!: e;

symbolic macro procedure TayExp!-times x;
   if null cdr x then 1
    else if null cddr x then cadr x
    else expand(cdr x,'TayExp!-times2);   

symbolic procedure TayExp!-times2(e1,e2);
   if atom e1 and atom e2 then e1*e2
    else exponent!-check!-int(
           if atom e1 then rntimes!:(!*i2rn e1,e2)
            else if atom e2 then rntimes!:(e1,!*i2rn e2)
            else rntimes!:(e1,e2));

symbolic procedure TayExp!-quotient(u,v);
   exponent!-check!-int
     rnquotient!:(if atom u then !*i2rn u else u,
                  if atom v then !*i2rn v else v);

symbolic procedure TayExp!-minusp e;
   if atom e then minusp e
    else rnminusp!: e;

symbolic procedure TayExp!-greaterp(a,b);
   TayExp!-lessp(b,a);

symbolic macro procedure TayExp!-geq x;
   {'not,'TayExp!-lessp . cdr x};

symbolic procedure TayExp!-lessp(e1,e2);
   if atom e1 and atom e2 then e1 TayCoeff
  %
  % multiplies the two coefficients c1,c2.
  % both are of the form (TayPowerList . s.q.)
  % so generate an appropriate degreelist by adding the degrees.
  %
  TayMakeCoeff (add!-degrees (TayCfPl c1, TayCfPl c2),
                multsq (TayCfSq c1, TayCfSq c2));

symbolic smacro procedure prune!-coefflist(cflist);
   <> where cflis := cflist;

symbolic smacro procedure multintocoefflist(coefflis,sq);
  %
  % (TayCoeffList, s.q.) -> TayCoeffList
  %
  % Multiplies each coefficient in coefflis by the s.q. sq.
  %
  for each p in coefflis collect
    TayMakeCoeff(TayCfPl p,resimp subs2!* multsq(TayCfSq p,sq));

symbolic smacro procedure subs2coefflist clist;
  for each pp in clist join
    ((if not null numr sq then {TayMakeCoeff(TayCfPl pp,sq)})
     where sq := subs2!* TayCfSq pp);

symbolic smacro procedure resimpcoefflist clist;
  for each cc in clist collect
    TayMakeCoeff(TayCfPl cc,subs2 resimp TayCfSq cc);

symbolic smacro procedure resimptaylor u;
  %
  % (TaylorKernel) -> TaylorKernel
  %
  % u is a Taylor kernel, value is the Taylor kernel
  % with coefficients and TayOrig part resimplified
  %
  make!-Taylor!* (
         resimpcoefflist TayCoeffList u,
         TayTemplate u,
         if !*taylorkeeporiginal and TayOrig u
           then resimp TayOrig u else nil,
         TayFlags u);

symbolic smacro procedure make!-cst!-powerlist tp;
  %
  % (TayTemplate) -> TayPowerList
  %
  % Generates a powerlist for the constant coefficient
  % according to template tp
  %
  for each el in tp collect nzerolist length TayTpElVars el;

symbolic smacro procedure make!-cst!-coefficient (cst, tp);
  %
  % (s.q., TayTemplate) -> TayCoefficient
  %
  % Generates the constant coefficient cst
  % according to Taylor template tp
  %
  TayMakeCoeff (make!-cst!-powerlist tp, cst);

symbolic smacro procedure make!-cst!-coefflis (cst, tp);
  %
  % (s.q., TayTemplate) -> TayCoeffList
  %
  % Generates a TayCoeffList with only the constant coefficient cst
  % according to Taylor template tp
  %
  {make!-cst!-coefficient (cst, tp)};

symbolic smacro procedure cst!-Taylor!* (cst, tp);
  %
  % (s.q., TayTemplate) -> TaylorKernel
  %
  % generates a Taylor kernel with template tp for the constant cst.
  %
  make!-Taylor!* (
     make!-cst!-coefflis (cst, tp), tp, cst, nil);


comment Predicates;

symbolic smacro procedure has!-Taylor!* u;
  %
  % (Any) -> Boolean
  %
  % checks if an expression u contains a Taylor kernel
  %
  smember ('Taylor!*, u);

symbolic smacro procedure Taylor!*p u;
  %
  % (Kernel) -> Boolean
  %
  % checks if kernel u is a Taylor kernel
  %
  eqcar (u, 'Taylor!*);

symbolic smacro procedure Taylor!-kernel!-sf!-p u;
  %
  % (s.f.) -> Boolean
  %
  % checks if s.f. u is a Taylor kernel
  %
  not domainp u and null red u and lc u = 1
     and ldeg u = 1 and Taylor!*p mvar u;

symbolic smacro procedure Taylor!-kernel!-sq!-p u;
  %
  % u is a standard quotient,
  % returns t if it is simply a Taylor kernel
  %
  kernp u and Taylor!*p mvar numr u;

symbolic smacro procedure has!-TayVars(tay,ex);
   %
   % Checks whether ex contains any of the Taylor variables
   %  of Taylor kernel tay.
   %
   smemberlp(TayVars tay,ex);

symbolic procedure Taylor!*!-zerop tay;
   TayCoeffList!-zerop TayCoefflist tay;

symbolic procedure TayCoeffList!-zerop tcl;
   null tcl
     or null numr TayCfSq car tcl and TayCoeffList!-zerop cdr tcl;


comment smacros for the generation of unique Taylor kernels;

symbolic smacro procedure !*tay2f u;
  !*p2f mksp (u, 1);

symbolic smacro procedure !*tay2q u;
  !*p2q mksp (u, 1);


comment some procedures for tracing;

symbolic smacro procedure Taylor!-trace u;
   if !*trtaylor then lpri("Taylor: " . if u and atom u then list u else u);

symbolic smacro procedure Taylor!-trace!-mprint u;
   if !*trtaylor then mathprint u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taybasic.red0000644000175000017500000004160711526203062024321 0ustar  giovannigiovannimodule TayBasic;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%      Functions that implement the basic operations
%       on Taylor kernels
%
%*****************************************************************


exports addtaylor, addtaylor1, invtaylor, invtaylor1, makecoeffpairs,
        makecoeffs, makecoeffs0, multtaylor, multtaylor1,
        multtaylorsq, negtaylor, negtaylor1, quottaylor, quottaylor1$

imports

% from the REDUCE kernel:
        addsq, invsq, lastpair, mvar, multsq, negsq, neq, nth, numr,
        over, quotsq, reversip, subtrsq, union,

% from the header module:
        !*tay2q, common!-increment, get!-degree, invert!-powerlist,
        make!-Taylor!*, multintocoefflist, prune!-coefflist,
        smallest!-increment, subtr!-degrees, subs2coefflist, TayCfPl,
        TayCfSq, TayCoeffList, TayFlags, TayFlagsCombine, TayGetCoeff,
        Taylor!-kernel!-sq!-p, Taylor!:, TayMakeCoeff, TayOrig,
        TayTemplate, TayTpElVars, TpDegreeList, TpNextList,

% from module Tayintro:
        confusion, Taylor!-error, Taylor!-error!*,

% from module Tayutils:
        add!.comp!.tp!., add!-degrees, enter!-sorted, exceeds!-order,
        inv!.tp!., min2!-order, mult!.comp!.tp!., replace!-next,
        taydegree!-strict!>;
    for each cc in l2 do
      if not null numr TayCfSq cc
        then if not exceeds!-order(tn,TayCfPl cc)
               then <>
              else tn := min2!-order(tn,tp,TayCfPl cc);
    return tn . subs2coefflist clist
  end;


symbolic procedure negtaylor u;
  make!-Taylor!* (
         negtaylor1 TayCoeffList u,
         TayTemplate u,
         if !*taylorkeeporiginal and TayOrig u
           then negsq TayOrig u else nil,
         TayFlags u)$

symbolic procedure negtaylor1 tcl;
  for each cc in tcl collect
    TayMakeCoeff (TayCfPl cc, negsq TayCfSq cc)$

symbolic procedure multtaylor(u,v);
  %
  % u and v are two Taylor kernels,
  % result is their product, as a Taylor kernel.
  %
  (if null tps then confusion 'multtaylor
    else multtaylor!*(u,v,tps))
   where tps := mult!.comp!.tp!.(u,v,nil);

symbolic procedure multtaylor!-as!-sq(u,v);
   begin scalar tps;
     return
       if Taylor!-kernel!-sq!-p u and Taylor!-kernel!-sq!-p v and
          (tps := mult!.comp!.tp!.(mvar numr u,mvar numr v,nil))
         then !*tay2q multtaylor!*(mvar numr u,mvar numr v,tps)
        else multsq(u,v)
   end;

symbolic procedure multtaylor!*(u,v,tps);
   make!-Taylor!*
        (cdr z,replace!-next(car tps,car z),
         if !*taylorkeeporiginal and TayOrig u and TayOrig v
           then multsq (TayOrig u, TayOrig v)
          else nil,
         TayFlagsCombine(u,v))
     where z := multtaylor1(car tps,TayCoeffList u,TayCoeffList v);

symbolic procedure multtaylor1(tmpl,l1,l2);
  %
  % Returns the coefflist that is the product of coefflists l1, l2,
  %  with respect to Taylor template tp.
  %
  begin scalar cff,pl,rlist,sq,tn,tp;
    tp := TpDegreeList tmpl;
    tn := TpNextList tmpl;
    for each cf1 in l1 do
      for each cf2 in l2 do <<
        pl := add!-degrees(TayCfPl cf1,TayCfPl cf2);
        if not exceeds!-order(tn,pl) then <<
          sq := multsq(TayCfSq cf1,TayCfSq cf2);
          if not null numr sq then <<
            cff := assoc(pl,rlist);
            if null cff
              then rlist := enter!-sorted(TayMakeCoeff(pl,sq),rlist)
             else rplacd(cff,addsq(TayCfSq cff,sq))>>>>
         else tn := min2!-order(tn,tp,pl)>>;
    return tn . subs2coefflist rlist
  end;

comment Implementation of Taylor division.
        We use the following algorithm:
        Suppose the numerator and denominator are of the form

                -----                    -----
                \          k             \          l
        f(x) =   >     a  x   ,  g(x) =   >     b  x   ,
                /       k                /       l
                -----                    -----
                k>=k0                    l>=l0

        respectively.  The quotient is supposed to be

                -----
                \          m
        h(x) =   >     c  x   .
                /       m
                -----
                m>=m0

        Clearly: m0 = k0 - l0.  This follows immediately from
        f(x) = g(x) * h(x) by comparing lowest order terms.
        This equation can now be written:

         -----            -----                 -----
         \          k     \             l+m     \              n
          >     a  x   =   >     b  c  x     =   >    b    c  x  .
         /       k        /       l  m          /      n-m  m
         -----            -----                 -----
         k>=k0            l>=l0              m0<=m<=n-l0
                          m>=m0                n>=l0+m0

        Comparison of orders leads immediately to

                  -----
                  \
          a    =   >    b    c   ,  n>=l0+m0 .
           n      /      n-m  m
                  -----
               m0<=m<=n-l0

        We write the last term of the series separately:

                  -----
                  \
          a    =   >    b    c   + b   c     ,  n>=l0+m0 ,
           n      /      n-m  m     l0  n-l0
                  -----
               m0<=m     b    c   | .
          n-l0    b    |  n    /       n-m  m  |
                   l0  \       -----           /
                            m0<=m     b       c   | .  (*)
          n       b    |  n+l0    /       n-m+l0  m  |
                   l0  \          -----              /
                                 m0<=m TayPowerList
  %
  % returns minimum of both powerlists
  %
  for i := 1 : length u collect begin scalar l1,l2;
    l1 := nth(u,i);
    l2 := nth(v,i);
    return
      for j := 1 : length l1 collect
        Taylor!: min2(nth(l1,j),nth(l2,j))
  end;

symbolic procedure makecoeffshom(cmin,lastterm,incr);
  if null cmin then '(nil)
   else Taylor!:
     for i := 0 step incr until lastterm join
       for each l in makecoeffshom(cdr cmin,lastterm - i,incr) collect
              (car cmin + i) . l;

symbolic procedure makecoeffshom0(nvars,lastterm,incr);
  if nvars=0 then '(nil)
   else Taylor!:
     for i := 0 step incr until lastterm join
       for each l in makecoeffshom0(nvars - 1,lastterm - i,incr) collect
             i . l;

symbolic procedure makecoeffs(plmin,dgl,il);
  %
  % plmin the list of the smallest terms, dgl the degreelist
  % of the largest term, il the list of increments.
  % It returns an ordered list of all index lists matching this
  % requirement.
  %
  Taylor!:
  if null plmin then '(nil)
   else for each l1 in makecoeffs(cdr plmin,cdr dgl,cdr il) join
        for each l2 in makecoeffshom(
                         car plmin,
                         car dgl - get!-degree car plmin - car il,
                         car il)
                 collect (l2 . l1);

symbolic procedure makecoeffs0(tp,dgl,il);
  %
  % tp is a Taylor template,
  % dgl a next list (m1 ... ),
  % il the list of increments (i1 ... ).
  % It returns an ordered list of all index lists matching the
  % requirement that for every element ni: 0 <= ni < mi and ni is
  % a multiple of i1
  %
  Taylor!:
  if null tp then '(nil)
   else for each l1 in makecoeffs0(cdr tp,cdr dgl,cdr il) join
        for each l2 in makecoeffshom0(length TayTpElVars car tp,
                                      car dgl - car il,
                                      car il)
                 collect (l2 . l1);

symbolic procedure makecoeffpairs1(plmin,pl,lmin,il);
  Taylor!:
  if null pl then '((nil))
   else for each l1 in makecoeffpairs1(
                         cdr plmin,
                         cdr pl,cdr lmin,cdr il) join
     for each l2 in makecoeffpairshom(car plmin,
                                      car pl,car lmin,- car il)
           collect (car l2 . car l1) . (cdr l2 . cdr l1)$

symbolic procedure makecoeffpairs(plmin,pl,lmin,il);
  reversip cdr makecoeffpairs1(plmin,pl,lmin,il);

symbolic procedure makecoeffpairshom(clow,chigh,clmin,inc);
  if null clmin then '((nil))
   else Taylor!:
    for i := car chigh step inc until car clow join
      for each l in makecoeffpairshom(cdr clow,cdr chigh,cdr clmin,inc)
          collect (i . car l) . ((car chigh + car clmin - i) . cdr l);

symbolic procedure addcoeffs(cl1,cl2,pllow,plhigh);
  begin scalar s,il;
    s := nil ./ 1;
    il := common!-increment(smallest!-increment cl1,
                            smallest!-increment cl2);
    for each p in makecoeffpairs(pllow,plhigh,caar cl2,il) do
        s := addsq(s,multsq(TayGetCoeff(car p,cl1),
                            TayGetCoeff(cdr p,cl2)));
    return s
%    return for each p in makecoeffpairs(ccmin,cc,caar cl2,dl) addsq
%             multsq(TayGetCoeff(car p,cl1),TayGetCoeff(cdr p,cl2));
  end;

symbolic procedure invtaylor u;
  %
  % Inverts a Taylor series expansion,
  % depends on ordering of the coefficients according to the
  %  degree of the expansion variables (lowest first)
  %
  if null u then confusion 'invtaylor
   else begin scalar tps;
     tps := inv!.tp!. u;
     return make!-Taylor!*(
               invtaylor1(car tps,TayCoeffList u),
               car tps,
               if !*taylorkeeporiginal and TayOrig u
                then invsq TayOrig u
                 else nil,
               TayFlags u);
   end;

symbolic procedure invtaylor1(tay,l);
  %
  % Does the real work, called also by the expansion procedures.
  % Returns the coefflist.
  %
  Taylor!:
  begin scalar clist,amin,ccmin,coefflis,il;
    l := prune!-coefflist l;
    if null l then Taylor!-error!*('not!-a!-unit,'invtaylor);
    amin := TayCfSq car l;  % first element must have lowest degree
    ccmin := TayCfPl car l;
    for each cf in cdr l do
      if not taydegree!-strict!>
         else <>>>;
      tp := cdr tp>>
    until null tp or found;
    if not found then confusion 'var!-is!-nth
     else return (n . m)
  end;

symbolic procedure delete!-nth (l, n);
  %
  % builds a new list with nth element of list l removed
  %
  if n = 1 then cdr l else car l . delete!-nth (cdr l, n - 1);

symbolic procedure delete!-nth!-nth (l, n, m);
  %
  % builds a new list with mth element of nth sublist of list l
  % removed
  %
  if n = 1 then delete!-nth (car l, m) . cdr l
   else car l . delete!-nth!-nth (cdr l, n - 1, m);

symbolic procedure replace!-nth (l, n, v);
  %
  % builds a new list with the nth element of list l replaced by v
  %
  if n = 1 then v . cdr l else car l . replace!-nth (cdr l, n - 1, v);

symbolic procedure replace!-nth!-nth (l, n, m, v);
  %
  % builds a new list with the mth element of nth sublist of list l
  % replaced by v
  %
  if n = 1 then replace!-nth (car l, m, v) . cdr l
   else car l . replace!-nth!-nth (cdr l, n - 1, m, v);

symbolic procedure constant!-sq!-p u;
  %
  % returns t if s.q. u represents a constant
  %
  numberp denr u and domainp numr u
      or kernp u and atom mvar u and flagp (mvar u, 'constant)
      or constant_exprp prepsq u;

symbolic procedure smemberlp (u, v);
  %
  % true if any member of list u is contained at any level in v
  %
  if null v then nil
   else if atom v then v member u
   else smemberlp (u, car v) or smemberlp (u, cdr v);

symbolic procedure confusion msg;
  %
  % called if an internal error occurs.
  % (I borrowed the name from Prof. Donald E. Knuth's TeX program)
  %
  << terpri ();
     prin2 "TAYLOR PACKAGE (version ";
     prin2 Taylor!:version;
     prin2 ", as of ";
     prin2 Taylor!:date!*;
     prin2t "):";
     prin2 "This can't happen (";
     prin2 msg;
     prin2t ") !";
     rerror (taylor, 1,
             "Please send input and output to Rainer M. Schoepf!") >>;

symbolic procedure Taylor!-error (type, info);
  %
  % called if a normal error occurs.
  % type is the type of error, info the error info.
  %
  begin scalar msg; integer errno;
    msg := if type eq 'not!-a!-unit then "Not a unit in argument to"
            else if type eq 'wrong!-no!-args
             then "Wrong number of arguments to"
            else if type eq 'expansion
             then "Error during expansion"
            else if type eq 'wrong!-type!-arg
             then "Wrong argument type"
            else if type eq 'no!-original
             then "Taylor kernel doesn't have an original part in"
            else if type eq 'zero!-denom
             then "Zero divisor in"
            else if type eq 'essential!-singularity
             then "Essential singularity in"
            else if type eq 'branch!-point
             then "Branch point detected in"
            else if type eq 'branch!-cut
             then "Expansion point lies on branch cut in"
%            else if type eq 'inttaylorwrttayvar
%             then
%              "Integration of Taylor kernel yields non-analytical term"
            else if type eq 'invalid!-subst
             then "Invalid substitution in Taylor kernel:"
            else if type eq 'tayrevert
             then "Reversion of Taylor series not possible:"
            else if type eq 'implicit_taylor
             then
              "Computation of Taylor series of implicit function failed"
            else if type eq 'inverse_taylor
             then
              "Computation of Taylor series of inverse function failed"
            else if type eq 'max_cycles
             then "Computation loops (recursive definition?):"
            else if type eq 'not!-implemented
             then "Not implemented yet"
            else confusion 'Taylor!-ERROR;
%    rerror (taylor, errno,
    rerror (taylor, 2,
            if null info then msg
             else if atom info then {msg, info}
             else msg . info);
  end;

symbolic procedure Taylor!-error!*(type,info);
   %
   % Like Taylor!-error, but calls sets !*tayrestart!* and calls
   %  error1 if !*tayexpanding!* indicates that expansion is going
   %  on and more terms might be necessary.
   %
   if !*tayexpanding!* then <>
    else Taylor!-error(type,info);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/taylor.tex0000644000175000017500000004434011526203062024057 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\newcommand{\MACSYMA}{{\sf MACSYMA}}
\newcommand{\MAPLE}{{\sf MAPLE}}
\newcommand{\Mathematica}{{\sf Mathematica}}
\newcommand{\PSL}{{\sf PSL}}
\title{A \REDUCE{} package for manipulation of Taylor series}
\date{}
\author{Rainer Sch\"opf\\
Zentrum f\"ur Datenverarbeitung der Universit\"at Mainz\\
Anselm-Franz-von-Bentzel-Weg~12\\
D-55099 Mainz\\
Germany\\
E--mail: {\tt Schoepf@Uni-Mainz.DE}}
\begin{document}
\maketitle
\index{Taylor Series} \index{TAYLOR package}
\index{Laurent series}

This short note describes a package of \REDUCE{} procedures that allow
Taylor expansion in one or several variables, and efficient
manipulation of the resulting Taylor series. Capabilities include
basic operations (addition, subtraction, multiplication and division),
and also application of certain algebraic and transcendental
functions. To a certain extent, Laurent and Puiseux expansions can be
performed as well. In many cases, separable singularities are detected
and factored out.

\section{Introduction}

The Taylor package was written to provide \REDUCE{} with some of
the facilities
that \MACSYMA's \verb+TAYLOR+ function offers,
but most of all I needed it to be faster and
more space-efficient.
Especially I wanted procedures that would return the logarithm or
arc tangent of a Taylor series, again as a Taylor series.
This turned out be more work than expected. The features absolutely
required were (as usual) those that were hardest to implement,
e.g., arc tangent applied to a Taylor expansion in more than
one variable.

This package is still undergoing development.
I'll be happy if it is of any use for you.
Tell me if you think that there is something missing.
I invite everybody to criticize and comment and will eagerly try to
correct any errors found.

\section{How to use it}

The most important operator is `\verb+TAYLOR+'. \index{TAYLOR operator}
It is used as follows:

\noindent {\tt TAYLOR}(EXP:{\em exprn}[,VAR:{\em kernel},
            VAR$_0$:{\em exprn},ORDER:{\em integer}]\ldots):{\em exprn}

where EXP is the expression to be expanded. It can be any \REDUCE{}
object, even an expression containing other Taylor kernels.  VAR is
the kernel with respect to which EXP is to be expanded. VAR$_0$
denotes the point about which and ORDER the order up to which
expansion is to take place. If more than one (VAR, VAR0, ORDER) triple
is specified {\tt TAYLOR} will expand its first argument independently
with respect to each variable in turn. For example,

\begin{verbatim}
  taylor(e^(x^2+y^2),x,0,2,y,0,2);
\end{verbatim}

will calculate the Taylor expansion up to order $X^{2}*Y^{2}$.
Note that once the expansion has been done it is not possible to
calculate higher orders.
Instead of a kernel, VAR may also
be a list of kernels. In this case expansion will take place in a way
so that the {\em sum\/} of the degrees of the kernels does not exceed
ORDER.
If VAR$_0$ evaluates to the special identifier \verb|INFINITY|
{\tt TAYLOR} tries to expand EXP in a series in 1/VAR.

The expansion is performed variable per variable, i.e.\ in the example
above by first expanding $\exp(x^{2}+y^{2})$ with respect to $x$ and
then expanding every coefficient with respect to $y$.

\index{IMPLICIT\_TAYLOR operator}\index{INVERSE\_TAYLOR} There are two
extra operators to compute the Taylor expansions of implicit and
inverse functions:

\noindent {\tt IMPLICIT\_TAYLOR}(F:{\em exprn},VAR1,VAR2:{\em kernel},\\
\hphantom{{\tt IMPLICIT\_TAYLOR}(}VAR1$_0$,VAR2$_0$:{\em exprn},
                                 ORDER:{\em integer}):{\em exprn}

takes a function F depending on two variables VAR1 and VAR2 and
computes the Taylor series of the implicit function VAR2(VAR1)
given by the equation F(VAR1,VAR2) = 0. For example,

\begin{verbatim}
  implicit_taylor(x^2 + y^2 - 1,x,y,0,1,5);
\end{verbatim}

\noindent {\tt INVERSE\_TAYLOR}(F:{\em exprn},VAR1,VAR2:{\em kernel},\\
\hphantom{{\tt INVERSE\_TAYLOR}(}VAR1$_0$:{\em exprn},
                                 ORDER:{\em integer}):{\em exprn}

takes a function F depending on VAR1 and computes the Taylor series of
the inverse of F with respect to VAR2. For example,

\begin{verbatim}
  inverse_taylor(exp(x)-1,x,y,0,8);
\end{verbatim}


\index{TAYLORPRINTTERMS variable}
When a Taylor kernel is printed, only a certain number of (non-zero)
coefficients are shown. If there are more, an expression of the form
\verb|(|$n$\verb| terms)| is printed to indicate how many non-zero
terms have been suppressed. The number of terms printed is given by
the value of the shared algebraic variable \verb|TAYLORPRINTTERMS|.
Allowed values are integers and the special identifier \verb|ALL|. The
latter setting specifies that all terms are to be printed. The default
setting is $5$.

\index{PART operator}\index{PART}
The \verb|PART| operator can be used to extract subexpressions of a
Taylor expansion in the usual way. All terms can be accessed,
irregardless of the value of the variable \verb|TAYLORPRINTTERMS|.


\index{TAYLORKEEPORIGINAL switch}
If the switch \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| the
original expression EXP is kept for later reference.
It can be recovered by means of the operator

\hspace*{2em} {\tt TAYLORORIGINAL}(EXP:{\em exprn}):{\em exprn}

An error is signalled if EXP is not a Taylor kernel or if the original
expression was not kept, i.e.\ if \verb|TAYLORKEEPORIGINAL| was
\verb|OFF| during expansion.  The template of a Taylor kernel, i.e.\
the list of all variables with respect to which expansion took place
together with expansion point and order can be extracted using
\ttindex{TAYLORTEMPLATE}.

\hspace*{2em} {\tt TAYLORTEMPLATE}(EXP:{\em exprn}):{\em list}

This returns a list of lists with the three elements (VAR,VAR0,ORDER).
As with \verb|TAYLORORIGINAL|,
an error is signalled if EXP is not a Taylor kernel.

\hspace*{2em} {\tt TAYLORTOSTANDARD}(EXP:{\em exprn}):{\em exprn}

converts all Taylor kernels in EXP into standard form and
\ttindex{TAYLORTOSTANDARD} resimplifies the result.

\hspace*{2em} {\tt TAYLORSERIESP}(EXP:{\em exprn}):{\em boolean}

may be used to determine if EXP is a Taylor kernel.
\ttindex{TAYLORSERIESP} Note that this operator is subject to the same
restrictions as, e.g., ORDP or NUMBERP, i.e.\ it may only be used in
boolean expressions in \verb|IF| or \verb|LET| statements.  Finally
there is

\hspace*{2em} {\tt TAYLORCOMBINE}(EXP:{\em exprn}):{\em exprn}

which tries to combine all Taylor kernels found in EXP into one.
\ttindex{TAYLORCOMBINE}
Operations currently possible are:
\index{Taylor series ! arithmetic}
\begin{itemize}
  \item Addition, subtraction, multiplication, and division.
  \item Roots, exponentials, and logarithms.
  \item Trigonometric and hyperbolic functions and their inverses.
\end{itemize}
Application of unary operators like \verb|LOG| and \verb|ATAN| will
nearly always succeed. For binary operations their arguments have to be
Taylor kernels with the same template. This means that the expansion
variable and the expansion point must match. Expansion order is not so
important, different order usually means that one of them is truncated
before doing the operation.

\ttindex{TAYLORKEEPORIGINAL} \ttindex{TAYLORCOMBINE}
If \verb|TAYLORKEEPORIGINAL| is set to \verb|ON| and if all Taylor
kernels in \verb|exp| have their original expressions kept
\verb|TAYLORCOMBINE| will also combine these and store the result
as the original expression of the resulting Taylor kernel.
\index{TAYLORAUTOEXPAND switch}
There is also the switch \verb|TAYLORAUTOEXPAND| (see below).

There are a few restrictions to avoid mathematically undefined
expressions: it is not possible to take the logarithm of a Taylor
kernel which has no terms (i.e. is zero), or to divide by such a
beast.  There are some provisions made to detect singularities during
expansion: poles that arise because the denominator has zeros at the
expansion point are detected and properly treated, i.e.\ the Taylor
kernel will start with a negative power.  (This is accomplished by
expanding numerator and denominator separately and combining the
results.)  Essential singularities of the known functions (see above)
are handled correctly.

\index{Taylor series ! differentiation}
Differentiation of a Taylor expression is possible.  If you
differentiate with respect to one of the Taylor variables the order
will decrease by one.

\index{Taylor series ! substitution}
Substitution is a bit restricted: Taylor variables can only be replaced
by other kernels.  There is one exception to this rule: you can always
substitute a Taylor variable by an expression that evaluates to a
constant.  Note that \REDUCE{} will not always be able to determine
that an expression is constant.

\index{Taylor series ! integration}
Only simple taylor kernels can be integrated. More complicated
expressions that contain Taylor kernels as parts of themselves are
automatically converted into a standard representation by means of the
TAYLORTOSTANDARD operator. In this case a suitable warning is printed.

\index{Taylor series ! reversion} It is possible to revert a Taylor
series of a function $f$, i.e., to compute the first terms of the
expansion of the inverse of $f$ from the expansion of $f$. This is
done by the operator

\hspace*{2em} {\tt TAYLORREVERT}(EXP:{\em exprn},OLDVAR:{\em kernel},
                                 NEWVAR:{\em kernel}):{\em exprn}

EXP must evaluate to a Taylor kernel with OLDVAR being one of its
expansion variables. Example:

\begin{verbatim}
  taylor (u - u**2, u, 0, 5);
  taylorrevert (ws, u, x);
\end{verbatim}

This package introduces a number of new switches:
\begin{itemize}

\index{TAYLORAUTOCOMBINE switch}
\item If you set \verb|TAYLORAUTOCOMBINE| to \verb|ON| \REDUCE{}
    automatically combines Taylor expressions during the simplification
    process.  This is equivalent to applying \verb|TAYLORCOMBINE| to
    every expression that contains Taylor kernels.
    Default is \verb|ON|.

\index{TAYLORAUTOEXPAND switch}
\item \verb|TAYLORAUTOEXPAND| makes Taylor expressions ``contagious''
    in the sense that \verb|TAYLORCOMBINE| tries to Taylor expand
    all non-Taylor subexpressions and to combine the result with the
    rest. Default is \verb|OFF|.

\index{TAYLORKEEPORIGINAL switch}
\item \verb|TAYLORKEEPORIGINAL|, if set to \verb|ON|, forces the
    package to keep the original expression, i.e.\ the expression
    that was Taylor expanded.  All operations performed on the
    Taylor kernels are also applied to this expression  which can
    be recovered using the operator \verb|TAYLORORIGINAL|.
    Default is \verb|OFF|.

\index{TAYLORPRINTORDER switch}
\item \verb|TAYLORPRINTORDER|, if set to \verb|ON|, causes the
    remainder to be printed in big-$O$ notation.  Otherwise, three
    dots are printed. Default is \verb|ON|.

\index{VERBOSELOAD switch}
\item There is also the switch \verb|VERBOSELOAD|.  If it is set to
    \verb|ON|
    \REDUCE{} will print some information when the Taylor package is
    loaded.  This switch is already present in \PSL{} systems.
    Default is \verb|OFF|.

\end{itemize}
\index{defaults ! TAYLOR package}

\section{Caveats}
\index{caveats ! TAYLOR package}

\verb|TAYLOR| should now always detect non-analytical expressions in
its first argument. As an example, consider the function $xy/(x+y)$
that is not analytical in the neighborhood of $(x,y) = (0,0)$: Trying
to calculate
\begin{verbatim}
  taylor(x*y/(x+y),x,0,2,y,0,2);
\end{verbatim}
causes an error
\begin{verbatim}
***** Not a unit in argument to QUOTTAYLOR
\end{verbatim}
Note that it is not generally possible to apply the standard \REDUCE{}
operators to a Taylor kernel. For example, \verb|PART|, \verb|COEFF|,
or \verb|COEFFN| cannot be used. Instead, the expression at hand has
to be converted to standard form first using the \verb|TAYLORTOSTANDARD|
operator.

\section{Warnings and error messages}
\index{errors ! TAYLOR package}
\begin{itemize}

\item \verb|Branch point detected in ...|\\
    This occurs if you take a rational power of a Taylor kernel
    and raising the lowest order term of the kernel to this
    power yields a non analytical term (i.e.\ a fractional power).

\item \verb|Cannot expand further... truncation done|\\
    You will get this warning if you try to expand a Taylor kernel to
    a higher order.

\item \verb|Cannot replace part ... in Taylor kernel|\\
\index{PART Operator}
    The \verb|PART| operator can only be used to either replace the
    template of a Taylor kernel (part 2) or the original expression
    that is kept for reference (part 3).    

\item \verb|Computation loops (recursive definition?): ...|\\
    Most probably the expression to be expanded contains an operator
    whose derivative involves the operator itself.

\item \verb|Converting Taylor kernels to standard representation|\\
    This warning appears if you try to integrate an expression that
    contains Taylor kernels.

\item \verb|Error during expansion (possible singularity)|\\
    The expression you are trying to expand caused an error.
    As far as I know this can only happen if it contains a function
    with a pole or an essential singularity at the expansion point.
    (But one can never be sure.)

\item \verb|Essential singularity in ...|\\
    An essential singularity was detected while applying a
    special function to a Taylor kernel.

\item \verb|Expansion point lies on branch cut in ...|\\
    The only functions with branch cuts this package knows of are
    (natural) logarithm, inverse circular and hyperbolic tangent and
    cotangent.  The branch cut of the logarithm is assumed to lie on
    the negative real axis.  Those of the arc tangent and arc
    cotangent functions are chosen to be compatible with this: both
    have essential singularities at the points $\pm i$.  The branch
    cut of arc tangent is the straight line along the imaginary axis
    connecting $+1$ to $-1$ going through $\infty$ whereas that of arc
    cotangent goes through the origin.  Consequently, the branch cut
    of the inverse hyperbolic tangent resp.\ cotangent lies on the
    real axis and goes from $-1$ to $+1$, that of the latter across
    $0$, the other across $\infty$.

    The error message can currently only appear when you try to
    calculate the inverse tangent or cotangent of a Taylor
    kernel that starts with a negative degree.
    The case of a logarithm of a Taylor kernel whose constant term
    is a negative real number is not caught since it is
    difficult to detect this in general.

\item \verb|Invalid substitution in Taylor kernel: ...|\\
    You tried to substitute a variable that is already present in the
    Taylor kernel or on which one of the Taylor variables depend.

\item \verb|Not a unity in ...|\\
    This will happen if you try to divide by or take the logarithm of
    a Taylor series whose constant term vanishes.

\item \verb|Not implemented yet (...)|\\
    Sorry, but I haven't had the time to implement this feature.
    Tell me if you really need it, maybe I have already an improved
    version of the package.

\item \verb|Reversion of Taylor series not possible: ...|\\
\ttindex{TAYLORREVERT}
    You tried to call the \verb|TAYLORREVERT| operator with
    inappropriate arguments. The second half of this error message
    tells you why this operation is not possible.

\item \verb|Taylor kernel doesn't have an original part|\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORKEEPORIGINAL}
    The Taylor kernel upon which you try to use \verb|TAYLORORIGINAL|
    was created with the switch \verb|TAYLORKEEPORIGINAL|
    set to \verb|OFF|
    and does therefore not keep the original expression.

\item \verb|Wrong number of arguments to TAYLOR|\\
    You try to use the operator \verb|TAYLOR| with a wrong number of
    arguments.

\item \verb|Zero divisor in TAYLOREXPAND|\\
    A zero divisor was found while an expression was being expanded.
    This should not normally occur.

\item \verb|Zero divisor in Taylor substitution|\\
    That's exactly what the message says.  As an example consider the
    case of a Taylor kernel containing the term \verb|1/x| and you try
    to substitute \verb|x| by \verb|0|.

\item \verb|... invalid as kernel|\\
    You tried to expand with respect to an expression that is not a
    kernel.

\item \verb|... invalid as order of Taylor expansion|\\
    The order parameter you gave to \verb|TAYLOR| is not an integer.

\item \verb|... invalid as Taylor kernel|\\
\ttindex{TAYLORORIGINAL} \ttindex{TAYLORTEMPLATE}
    You tried to apply \verb|TAYLORORIGINAL| or \verb|TAYLORTEMPLATE|
    to an expression that is not a Taylor kernel.

\item \verb|... invalid as Taylor Template element|\\
    You tried to substitute the \verb|TAYLORTEMPLATE| part of a Taylor
    kernel with a list a incorrect form. For the correct form see the
    description of the \verb|TAYLORTEMPLATE| operator.

\item \verb|... invalid as Taylor variable|\\
    You tried to substitute a Taylor variable by an expression that is
    not a kernel.

\item \verb|... invalid as value of TaylorPrintTerms|\\
\ttindex{TAYLORPRINTTERMS}
    You have assigned an invalid value to \verb|TAYLORPRINTTERMS|.
    Allowed values are: an integer or the special identifier
    \verb|ALL|.

\item \verb|TAYLOR PACKAGE (...): this can't happen ...|\\
    This message shows that an internal inconsistency was detected.
    This is not your fault, at least as long as you did not try to
    work with the internal data structures of \REDUCE. Send input
    and output to me, together with the version information that is
    printed out.

\end{itemize}

\section{Comparison to other packages}

At the moment there is only one \REDUCE{} package that I know of:
the truncated power series package by Alan Barnes and Julian Padget.
In my opinion there are two major differences:
\begin{itemize}
  \item The interface. They use the domain mechanism for their power
        series, I decided to invent a special kind of kernel. Both
        approaches have advantages and disadvantages: with domain
        modes, it is easier
        to do certain things automatically, e.g., conversions.
  \item The concept of a truncated series. Their idea is to remember
        the original expression and to compute more coefficients when
        more of them are needed. My approach is to truncate at a
        certain order and forget how the unexpanded expression
        looked like.  I think that their method is more widely
        usable, whereas mine is more efficient when you know in
        advance exactly how many terms you need.
\end{itemize}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayfront.red0000644000175000017500000000605011526203062024361 0ustar  giovannigiovannimodule TayFront;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%          User interface
%
%*****************************************************************


exports taylorcombine, taylororiginal, taylorprintorder,
        taylorseriesp, taylortemplate, taylortostandard;

imports

% from the REDUCE kernel:
        eqcar, mk!*sq, mvar, numr, prepsq, simp!*, typerr,

% from the header module:
        Taylor!-kernel!-sq!-p, TayOrig, TayTemplate, TayTpElOrder,
        TayTpElPoint, TayTpElVars,

% from module Tayintro:
        Taylor!-error,

% from module Taysimp:
        taysimpsq;


symbolic procedure taylorseriesp u;
  (Taylor!-kernel!-sq!-p sq)
      where sq := simp!* u;

symbolic procedure taylorcombine u;
  mk!*sq taysimpsq simp!* u;

symbolic procedure taylortostandard u;
  (prepsq if not eqcar (u, '!*sq) then simp!* u else cadr u)
          where convert!-Taylor!* := t;

symbolic procedure taylororiginal u;
  (if not Taylor!-kernel!-sq!-p sq
     then typerr (u, "Taylor kernel")
    else (if TayOrig tay then mk!*sq TayOrig tay
        else Taylor!-error ('no!-original, 'taylororiginal))
           where tay := mvar numr sq)
     where sq := simp!* u;

symbolic procedure taylortemplate u;
  (if not Taylor!-kernel!-sq!-p sq
     then typerr (u, "Taylor kernel")
    else 'list . for each quartet in TayTemplate mvar numr sq collect
              {'list,
               if null cdr TayTpElVars quartet
                 then car TayTpElVars quartet
                else 'list . TayTpElVars quartet,
               TayTpElPoint quartet,
               TayTpElOrder quartet})
     where sq := simp!* u;

flag ('(taylorseriesp taylorcombine taylortostandard taylororiginal
        taylortemplate),
      'opfn);

flag ('(taylorseriesp), 'boolean);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayimpl.red0000644000175000017500000001175311526203062024200 0ustar  giovannigiovannimodule tayimpl;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%      Functions for computing Taylor expansions of implicit
%       or inverse functions
%
%*****************************************************************


exports implicit_taylor, inverse_taylor;

imports

% from the REDUCE kernel:
        !*f2q, !*n2f, diffsq, errorp, errorset!*, invsq, mkquote,
        mk!*sq, mvar, negsq, numr, quotsq, typerr, simp!*,

% from the header module:
        has!-taylor!*, make!-Taylor!*, Taylor!-kernel!-sq!-p,
        TayMakeCoeff,

% from module taybasic:
        addtaylor, multtaylor, multtaylorsq,

% from module taydiff:
        difftaylor,

% from module tayexpnd:
        taylorexpand,

% from module taysubst:
        subsubtaylor;


symbolic procedure implicit_taylor(f,x,y,x0,y0,n);
%   if not fixp n or n < 0 then typerr(n,"expansion order") else
   begin scalar x,l,!*tayexpanding!*;
     f := simp!* f;
     if not null numr subsq(f,{x . x0,y . y0})
       then Taylor!-error('implicit_taylor,
              "      Input expression non-zero at given point");
     !*tayexpanding!* := t;
     l := {'implicit_taylor1,
            mkquote f,
            mkquote x,
            mkquote y,
            mkquote x0,
            mkquote y0,
            mkquote n};
     x := errorset!*(l,!*trtaylor);
     if not errorp x then return car x
      else Taylor!-error('implicit_taylor,nil)
   end;

symbolic procedure implicit_taylor1(f,x,y,x0,y0,n);
   begin scalar ft,fn,f1,g;
    if n <= 0
      then return make!-Taylor!*({TayMakeCoeff({{0}},simp!* y0)},
                                 {{{x},x0,n,n+1}},nil,nil);
    ft := quotsq(negsq diffsq(f,x),diffsq(f,y));
    f1 := taylorexpand(ft,{{{x},x0,n,n+1}});
    if not Taylor!-kernel!-sq!-p f1 then typerr(f,"implicit function");
    fn := f1 := mvar numr f1;
    g := {TayMakeCoeff({{1}},simp!* subsubtaylor({x . x0,y . y0},f1)),
          TayMakeCoeff({{0}},simp!* y0)};
    for i := 2 : n do
      <>;
    return construct!-Taylor!*(reversip g,x,x0,n)
  end;

symbolic operator implicit_taylor;

symbolic procedure construct!-Taylor!*(cfl,x,x0,n);
   if not has!-Taylor!* cfl
     then make!-Taylor!*(cfl,{{{x},x0,n,n+1}},nil,nil)
    else mk!*sq
           taylorexpand(simp!* prepTaylor!*1(cfl,{{{x},x0,n,n+1}},nil),
                        {{{x},x0,n,n+1}});

symbolic operator implicit_taylor;

symbolic procedure inverse_taylor(f,y,x,y0,n);
   begin scalar x,l,!*tayexpanding!*;
     !*tayexpanding!* := t;
     l := {'inverse_taylor1,
            mkquote simp!* f,
            mkquote x,
            mkquote y,
            mkquote subeval {{'replaceby,y,y0},f},
            mkquote y0,
            mkquote n};
     x := errorset!*(l,!*trtaylor);
     if not errorp x then return car x
      else Taylor!-error('inverse_taylor,nil)
   end;

symbolic procedure inverse_taylor1(f,x,y,x0,y0,n);
   begin scalar fn,f1,g;
    if n < 0 then n := 0;
    f1 := taylorexpand(invsq diffsq(f,y),{{{y},y0,n,n+1}});
    if not Taylor!-kernel!-sq!-p f1 then typerr(f,"implicit function");
    fn := f1 := mvar numr f1;
    g := {TayMakeCoeff({{1}},simp!* subsubtaylor({y . y0},f1)),
          TayMakeCoeff({{0}},simp!* y0)};
    for i := 2 : n do
      <>;
    return construct!-Taylor!*(reversip g,x,x0,n)
  end;

symbolic operator inverse_taylor;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/taylor/tayutils.red0000644000175000017500000004664611526203062024410 0ustar  giovannigiovannimodule TayUtils;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%       Utility functions that operate on Taylor kernels
%
%*****************************************************************


exports add!-degrees, add!.comp!.tp!., check!-for!-cst!-Taylor,
        comp!.tp!.!-p, delete!-superfluous!-coeffs, enter!-sorted,
        exceeds!-order, exceeds!-order!-variant, find!-non!-zero,
        get!-cst!-coeff, inv!.tp!., is!-neg!-pl, min2!-order,
        mult!.comp!.tp!., rat!-kern!-pow, replace!-next,
        subtr!-degrees, subtr!-tp!-order, taydegree!<,
        taydegree!-strict!>;
        dl := reversip w . dl;
        dl1 := cdr dl1;
        dl2 := cdr dl2>>;
      return reversip dl
    end;

symbolic procedure subtr!-degrees(dl1,dl2);
  %
  % calculates the element-wise difference of two degree lists dl1, dl2.
  %
  Taylor!:
    begin scalar dl,u,v,w;
      while dl1 do <<
        u := car dl1;
        v := car dl2;
        w := nil;
        while u do <<
          w := (car u - car v) . w;
          u := cdr u;
          v := cdr v>>;
      dl := reversip w . dl;
      dl1 := cdr dl1;
      dl2 := cdr dl2>>;
    return reversip dl
  end;

symbolic procedure find!-non!-zero pl;
  %
  % pl is a power list.  Returns pair (n . m) of position of first
  % non zero degree.
  %
  begin scalar u; integer n, m;
    n := 1;
   loop:
    m := 1;
    u := car pl;
   loop2:
    if not (car u = 0) then return (n . m);
    u := cdr u;
    m := m + 1;
    if not null u then goto loop2;
    pl := cdr pl;
    n := n + 1;
    if null pl then confusion 'find!-non!-zero;
    goto loop
  end$


symbolic procedure lcmn(n,m);
   %
   % returns the least common multiple of two integers m,n.
   %
   n*(m/gcdn(n,m));

symbolic smacro procedure get!-denom expo;
   if atom expo then 1 else cddr expo;

symbolic procedure get!-denom!-l expol;
   <>
      where result := get!-denom car expol;

symbolic procedure get!-denom!-ll(dl,pl);
   if null dl then nil
    else lcmn(car dl,get!-denom!-l car pl)
           . get!-denom!-ll(cdr dl, cdr pl);

symbolic procedure smallest!-increment cfl;
   if null cfl then confusion 'smallest!-increment
    else begin scalar result;
     result := for each l in TayCfPl car cfl collect get!-denom!-l l;
     for each el in cdr cfl do
       result := get!-denom!-ll(result,TayCfPl el);
     return for each n in result collect if n=1 then n else mkrn(1,n);
   end;


symbolic procedure common!-increment(dl1,dl2);
   begin scalar result,l;
     loop:
       l := lcmn(get!-denom car dl1,get!-denom car dl2);
       result := (if l=1 then l else mkrn(1,l)) . result;
       dl1 := cdr dl1;
       dl2 := cdr dl2;
       if not null dl1 then goto loop
        else if not null dl2 then confusion 'common!-increment
        else return reversip result
   end;

symbolic procedure min2!-order(nextlis,ordlis,dl);
  %
  % (List of Integers, List of Integers, TayPowerList) -> Boolean
  %
  % nextlis is the list of TayTpElNext numbers,
  % ordlis the list if TayTpElOrder numbers,
  % dl the degreelist of a coefficient.
  % Dcecrease the TayTpElNext number if the degree is greater than
  % the order, but smaller than the next.
  % Returns the corrected nextlis.
  %
  if null nextlis then nil
   else (Taylor!: (if dg > car ordlis then min2(dg,car nextlis)
                   else car nextlis) where dg := get!-degree car dl)
          . min2!-order(cdr nextlis,cdr ordlis,cdr dl);

symbolic procedure replace!-next(tp,nl);
   %
   % Given a template and a list of exponents, returns a template
   %  with the next part replaced.
   %
   if null tp then nil
    else {TayTpElVars car tp,
          TayTpElPoint car tp,
          TayTpElOrder car tp,
          car nl}
           . replace!-next(cdr tp,cdr nl);

symbolic procedure comp!.tp!.!-p (u, v);
  %
  % Checks templates of Taylor kernels u and v for compatibility,
  % i.e. whether variables and expansion points match.
  % Returns t if possible.
  %
  begin;
    u := TayTemplate u; v := TayTemplate v;
    if length u neq length v then return nil;
   loop:
    if not (TayTpElVars car u = TayTpElVars car v
            and TayTpElPoint car u = TayTpElPoint car v)
      then return nil;
    u := cdr u; v := cdr v;
    if null u then return t;
    goto loop
  end$

symbolic procedure add!.comp!.tp!.(u,v);
  %
  % Checks templates of Taylor kernels u and v for compatibility
  % when adding them, i.e. whether variables and expansion points
  % match.
  % Returns either a list containing a new Taylor template whose
  % degrees are the minimum of the corresponding degrees of u and v,
  % or nil if variables or expansion point(s) do not match.
  %
  Taylor!:
  begin scalar w;
    u := TayTemplate u; v := TayTemplate v;
    if length u neq length v then return nil;
    if null u then return {nil};
   loop:
    if not (TayTpElVars car u = TayTpElVars car v
            and TayTpElPoint car u = TayTpElPoint car v)
      then return nil
     else w := {TayTpElVars car u,
                TayTpElPoint car u,
                min2(TayTpElOrder car u,TayTpElOrder car v),
                min2(TayTpElNext car u,TayTpElNext car v)}
                . w;
    u := cdr u; v := cdr v;
    if null u then return {reversip w};
    goto loop
  end;

symbolic procedure taymindegreel(pl,dl);
   Taylor!:
     if null pl then nil
      else min2(get!-degree car pl,car dl)
             . taymindegreel(cdr pl,cdr dl);

symbolic procedure get!-min!-degreelist cfl;
  Taylor!:
    if null cfl then confusion 'get!-min!-degreelist
     else if null cdr cfl then get!-degreelist TayCfPl car cfl
     else taymindegreel(TayCfPl car cfl,
                        get!-min!-degreelist cdr cfl);

symbolic procedure mult!.comp!.tp!.(u,v,div!?);
  %
  % Checks templates of Taylor kernels u and v for compatibility
  % when multiplying or dividing them, i.e., whether variables and
  % expansion points match.  The difference to addition is that
  % in addition to the new template it returns two degreelists
  % and two nextlists to be used by truncate!-coefflist which
  % are made up so that the kernels have the same number of terms.
  %
  Taylor!:
  begin scalar cf1,cf2,next1,next2,ord1,ord2,w,
        !#terms!-1,!#terms!-next,dl1,dl2,mindg;
    cf1 := prune!-coefflist TayCoeffList u;
    if null cf1 then dl1 := nzerolist length TayTemplate u
     else dl1 := get!-min!-degreelist cf1;
    cf2 := prune!-coefflist TayCoeffList v;
    if null cf2 then dl2 := nzerolist length TayTemplate v
     else dl2 := get!-min!-degreelist cf2;
    u := TayTemplate u; v := TayTemplate v;
    if length u neq length v then return nil;
    if null u then return {nil,nil,nil,nil,nil};
   loop:
    if not (TayTpElVars car u = TayTpElVars car v
            and TayTpElPoint car u = TayTpElPoint car v)
      then return nil;
    mindg := if div!? then car dl1 - car dl2 else car dl1 + car dl2;
    !#terms!-1 := min2(TayTpElOrder car u - car dl1,
                       TayTpElOrder car v - car dl2);
    !#terms!-next := min2(TayTpElNext car u - car dl1,
                          TayTpElNext car v - car dl2);
    ord1 := (!#terms!-1 + car dl1) . ord1;
    ord2 := (!#terms!-1 + car dl2) . ord2;
    next1 := (!#terms!-next + car dl1) . next1;
    next2 := (!#terms!-next + car dl2) . next2;
    w := {TayTpElVars car u,TayTpElPoint car u,
          mindg + !#terms!-1,mindg + !#terms!-next}
          . w;
    u := cdr u; v := cdr v; dl1 := cdr dl1; dl2 := cdr dl2;
    if null u then return {reversip w,
                           reversip ord1,
                           reversip ord2,
                           reversip next1,
                           reversip next2};
    goto loop
  end;

symbolic procedure inv!.tp!. u;
  %
  % Checks template of Taylor kernel u for inversion. It returns a
  % template (to be used by truncate!-coefflist)
  % which is made up so that the resulting kernel has the correct
  % number of terms.
  %
  Taylor!:
  begin scalar w,cf,!#terms!-1,!#terms!-next,dl,mindg;
    cf := prune!-coefflist TayCoeffList u;
    if null cf then dl := nzerolist length TayTemplate u
     else dl := get!-degreelist TayCfPl car cf;
    u := TayTemplate u;
    if null u then return {nil,nil};
   loop:
    mindg := - car dl;
    !#terms!-1 := TayTpElOrder car u - car dl;
    !#terms!-next := TayTpElNext car u - car dl;
    w := {TayTpElVars car u,TayTpElPoint car u,mindg + !#terms!-1,
          mindg + !#terms!-next}
          . w;
    u := cdr u; dl := cdr dl;
    if null u then return {reversip w};
    goto loop
  end;

symbolic smacro procedure taycoeff!-before(cc1,cc2);
  %
  % (TayCoeff, TayCoeff) -> Boolean
  %
  % returns t if coeff cc1 is ordered before cc2
  % both are of the form (degreelist . sq)
  %
  taydegree!<(TayCfPl cc1,TayCfPl cc2);

symbolic procedure taydegree!<(u,v);
  %
  % (TayPowerList, TayPowerList) -> Boolean
  %
  % returns t if coefflist u is ordered before v
  %
  Taylor!:
  begin scalar u1,v1;
   loop:
    u1 := car u;
    v1 := car v;
   loop2:
     if car u1 > car v1 then return nil
      else if car u1 < car v1 then return t;
     u1 := cdr u1;
     v1 := cdr v1;
     if not null u1 then go to loop2;
    u := cdr u;
    v := cdr v;
    if not null u then go to loop
  end;

symbolic procedure taydegree!-strict! Boolean
  %
  % returns t if every component coefflist u is less or equal than
  %  respective component of v
  %
  Taylor!:
  begin scalar u1,v1;
   loop:
    u1 := car u;
    v1 := car v;
   loop2:
     if car u1 > car v1 then return nil;
     u1 := cdr u1;
     v1 := cdr v1;
     if not null u1 then go to loop2;
    u := cdr u;
    v := cdr v;
    if not null u then go to loop;
    return t
  end;

symbolic procedure exceeds!-order(ordlis,cf);
  %
  % (List of Integers, TayPowerlist) -> Boolean
  %
  % Returns t if the degrees in coefficient cf are greater or
  % equal than those in the degreelist ordlis
  %
  if null ordlis then nil
   else Taylor!:(get!-degree car cf >= car ordlis)
          or exceeds!-order(cdr ordlis,cdr cf);

symbolic procedure exceeds!-order!-variant(ordlis,cf);
  %
  % (List of Integers, TayPowerlist) -> Boolean
  %
  % Returns t if the degrees in coefficient cf are greater or
  % equal than those in the degreelist ordlis
  %
  if null ordlis then nil
   else Taylor!:(get!-degree car cf > car ordlis)
          or exceeds!-order!-variant(cdr ordlis,cdr cf);

symbolic procedure enter!-sorted (u, alist);
  %
  % (TayCoeff, TayCoeffList) -> TayCoeffList
  %
  % enters u into the alist alist according to the standard
  % ordering for the car part
  %
  if null alist then {u}
   else if taycoeff!-before (u, car alist) then u . alist
   else car alist . enter!-sorted (u, cdr alist)$

symbolic procedure delete!-superfluous!-coeffs(cflis,pos,n);
  %
  % (TayCoeffList, Integer, Integer) -> TayCoeffList
  %
  % This procedure deletes all coefficients of a TayCoeffList cflis
  % whose degree in position pos exceeds n.
  %
  Taylor!:
  for each cc in cflis join
     (if get!-degree nth(TayCfPl cc,pos) > n then nil else {cc});

symbolic procedure truncate!-coefflist (cflis, dl);
  %
  % (TayCoeffList, List of Integers) -> TayCoeffList
  %
  % Deletes all coeffs from coefflist cflis that are equal or greater
  %  in degree than the corresponding degree in the degreelist dl.
  %
  begin scalar l;
    for each cf in cflis do
      if not exceeds!-order (dl, TayCfPl cf) then l := cf . l;
    return reversip l
  end;

symbolic procedure TayTp!-min2(tp1,tp2);
  %
  % finds minimum (w.r.t. Order and Next parts) of compatible
  %  templates tp1 and tp2
  %
  Taylor!:
    if null tp1 then nil
     else if not (TayTpElVars car tp1 = TayTpElVars car tp2 and
                  TayTpElPoint car tp1 = TayTpElPoint car tp2)
      then confusion 'TayTpmin2
     else {TayTpElVars car tp1,TayTpElPoint car tp2,
           min2(TayTpElOrder car tp1,TayTpElOrder car tp2),
           min2(TayTpElNext car tp1,TayTpElNext car tp2)}
          . TayTp!-min2(cdr tp1,cdr tp2);


symbolic procedure truncate!-Taylor!*(tay,ntp);
  %
  % tcl is a coefflist for template otp
  % truncate it to coefflist for template ntp
  %
  Taylor!:
   begin scalar nl,ol,l,tp,tcl,otp;
     tcl := TayCoeffList tay;
     otp := TayTemplate tay;
     tp := for each pp in pair(ntp,otp) collect
           {TayTpElVars car pp,
            TayTpElPoint car pp,
            min2(TayTpElOrder car pp,TayTpElOrder cdr pp),
            min2(TayTpElNext car pp,TayTpElNext cdr pp)};
     nl := TpNextList tp;
     ol := TpDegreeList tp;
     for each cf in tcl do
       if not null numr TayCfSq cf
%         then ((if not exceeds!-order(nl,pl) then l := cf . l
%                 else nl := min2!-order(nl,ol,pl))
         then ((if not exceeds!-order!-variant(ol,pl) then l := cf . l
                 else nl := min2!-order(nl,ol,pl))
                where pl := TayCfPl cf);
     return make!-Taylor!*(reversip l,replace!-next(tp,nl),
                           TayOrig tay,TayFlags tay)
   end;

symbolic procedure tp!-greaterp(tp1,tp2);
   %
   % Given two templates tp1 and tp2 with matching variables and
   %  expansion points this function returns t if the expansion
   %  order wrt at least one variable is greater in tp1 than in tp2.
   %
   if null tp1 then nil
    else Taylor!: (TayTpElOrder car tp1 > TayTpElOrder car tp2)
           or tp!-greaterp(cdr tp1,cdr tp2);

symbolic procedure subtr!-tp!-order(tp1,tp2);
   %
   % Given two templates tp1 and tp2 with matching variables and
   %  expansion points this function returns the difference in their
   %  orders.
   %
   Taylor!:
    if null tp1 then nil
     else (TayTpElOrder car tp1 - TayTpElOrder car tp2)
            . subtr!-tp!-order(cdr tp1,cdr tp2);


comment Procedures to non-destructively modify Taylor templates;

symbolic procedure addto!-all!-TayTpElOrders(tp,nl);
  Taylor!:
   if null tp then nil
    else {TayTpElVars car tp,
          TayTpElPoint car tp,
          TayTpElOrder car tp + car nl,
          TayTpElNext car tp + car nl} .
         addto!-all!-TayTpElOrders(cdr tp,cdr nl);

symbolic procedure taymincoeff cflis;
  %
  % Returns degree of first non-zero coefficient
  % or 0 if there isn't any.
  %
  if null cflis then 0
   else if not null numr TayCfSq car cflis
    then get!-degree car TayCfPl car cflis
   else taymincoeff cdr cflis;

symbolic procedure tayminpowerlist cflis;
  %
  % Returns degreelist of first non-zero coefficient of TayCoeffList
  % cflis or a list of zeroes if there isn't any.
  %
  if null cflis then confusion 'tayminpowerlist
   else tayminpowerlist1(cflis,length TayCfPl car cflis);

symbolic procedure tayminpowerlist1(cflis,l);
   if null cflis then nzerolist l
    else if null numr TayCfSq car cflis
     then tayminpowerlist1(cdr cflis,l)
    else get!-degreelist TayCfPl car cflis;

symbolic procedure get!-cst!-coeff tay;
   TayGetCoeff(make!-cst!-powerlist TayTemplate tay,TayCoeffList tay);

symbolic procedure Taylor!*!-constantp tay;
   Taylor!*!-constantp1(make!-cst!-powerlist TayTemplate tay,
                        TayCoeffList tay);

symbolic procedure Taylor!*!-constantp1(pl,tcf);
   if null tcf then t
    else if TayCfPl car tcf = pl
     then TayCoeffList!-zerop cdr tcf
    else if not null numr TayCfSq car tcf then nil
    else Taylor!*!-constantp1(pl,cdr tcf);

symbolic procedure check!-for!-cst!-Taylor tay;
   begin scalar pl,tc;
      pl := make!-cst!-powerlist TayTemplate tay;
      tc := TayCoeffList tay;
      return if Taylor!*!-constantp1(pl,tc) then TayGetCoeff(pl,tc)
              else !*tay2q tay
   end;

symbolic procedure Taylor!*!-nzconstantp tay;
   Taylor!*!-nzconstantp1(make!-cst!-powerlist TayTemplate tay,
                          TayCoeffList tay);

symbolic procedure Taylor!*!-nzconstantp1(pl,tcf);
   if null tcf then nil
    else if TayCfPl car tcf = pl
     then if null numr TayCfSq car tcf then nil
           else TayCoeffList!-zerop cdr tcf
    else if TayCfPl car tcf neq pl and
            not null numr TayCfSq car tcf
     then nil
    else Taylor!*!-nzconstantp1(pl,cdr tcf);

symbolic procedure Taylor!*!-onep tay;
   Taylor!-onep1(make!-cst!-powerlist TayTemplate tay,TayCoeffList tay);

symbolic procedure Taylor!-onep1(pl,tcf);
   if null tcf then nil
    else if TayCfPl car tcf = pl
     then if TayCfSq car tcf = (1 ./ 1)
            then TayCoeffList!-zerop cdr tcf
           else nil
    else if null numr TayCfSq car tcf
     then Taylor!*!-nzconstantp1(pl,cdr tcf)
    else nil;

symbolic procedure is!-neg!-pl pl;
  %
  % Returns t if any of the exponents in pl is negative.
  %
  Taylor!:
    if null pl then nil
     else if get!-degree car pl < 0 then t
     else is!-neg!-pl cdr pl;

symbolic procedure rat!-kern!-pow(x,pos);
   %
   % check that s.f. x is a kernel to a rational power.
   %  if pos is t allow only positive exponents.
   %  returns pair (kernel . power)
   %
   begin scalar y; integer n;
     if domainp x or not null red x or not (lc x=1) then return nil;
     n := ldeg x;
     x := mvar x;
     Taylor!:
       if eqcar(x,'sqrt) then return (cadr x . mkrn(1,2)*n)
        else if eqcar(x,'expt) and (y := simprn{caddr x})
               then if null pos or (y := car y)>0
                      then return (cadr x . (y*n))
                     else return nil
        else return (x . n)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/0000755000175000017500000000000011722677365021272 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/alg/maxmin.red0000644000175000017500000001006411526203062023235 0ustar  giovannigiovannimodule maxmin;  % Support for generalized MAX and MIN.

% Author: F.J. Wright, QMW, London (fjw@maths.qmw.ac.uk) 7/7/90.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Provide support for the MAX and MIN functions to allow:-
%     any number domain;
%     any symbolic arguments remain so;
%     nested algebraic-level lists of arguments;
% and to discard redundant nested max and min.
% The Lisp functions max and min are not affected.

% Revision : W. Neun, ZIB Berlin, 25/6/94
%  added handling of  max(n,n+1,n-1) => n+1

put('max, 'simpfn, 'simpmax);

symbolic procedure simpmax u;
   S_simpmaxmin('max, function evalgreaterp, u, nil);

put('min, 'simpfn, 'simpmin);

symbolic procedure simpmin u;
   S_simpmaxmin('min, function evallessp, u, nil);

flag('(max min),'listargp);

symbolic smacro procedure maxmin_difflist(u,v);
 for each uu in u collect reval list('difference,uu ,v);


symbolic procedure S_simpmaxmin(maxmin, relation, u,rec);
   begin scalar arglist, arglistp, mval, x;
      if null u then return nil ./ 1;   % 0 returned for empty args.
      arglistp := arglist := list nil;  % Dummy car with cdr to rplacd.
      for each val in flattenmaxmin(maxmin, revlis u) do
         if atom denr(x := simp!* val)
            and (atom numr x or car numr x memq '(!:rd!: !:rn!:))
         % extremize numerical args:
           then (if null mval or apply2(relation,val, mval)
                   then mval := val)
         else
         % successively append symbolic args efficiently:
            << rplacd(arglistp, list val); arglistp := cdr arglistp >>;
      arglist := cdr arglist;  % Discard dummy car
      % Put any numerical extreme value at head of arg list:
      if mval then arglist := mval . arglist;
      % If more than one arg then keep as a max or min:
      if cdr arglist and rec then
                return !*kk2f(maxmin . !*trim arglist) ./ 1;
      if cdr arglist then
        if length cdr arglist >= 1 and
           not eqcar(prepsq(mval :=S_simpmaxmin(maxmin,relation,
                        maxmin_difflist(arglist,car arglist),T)),maxmin)
           then return addsq(mval,simp!* car arglist)
           else return !*kk2f(maxmin . !*trim arglist) ./ 1;
      % Otherwise just return the single (extreme) value:
      return simp car arglist
   end;  % simpmaxmin

symbolic procedure !*trim u;
   % Trim repeated elements from u.
   if null u then nil
    else if car u member cdr u then !*trim cdr u
    else car u . !*trim cdr u;

symbolic procedure flattenmaxmin(maxmin, u);
   % Flatten algebraic-mode lists and already recursively simplified
   % calls of max/min as appropriate.
   for each el in u join
      if atom el then list el
      else if car el eq 'list then flattenmaxmin(maxmin, cdr el)
      else if car el eq maxmin then cdr el
      else if car el='MAT then for each r in cdr el join r
      else list el;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/elem.red0000644000175000017500000005232711526203062022676 0ustar  giovannigiovannimodule elem; % Simplification rules for elementary functions.

% Author: Anthony C. Hearn.
% Modifications by:  Herbert Melenk, Rainer Schoepf.

% Copyright (c) 1993 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*!*sqrt !*complex !*keepsqrts !*precise !*precise_complex
        !*rounded dmode!* !*elem!-inherit);

% No references to RPLAC-based functions in this module.

% For a proper bootstrapping the following order of operator
% declarations is essential:

%    sqrt
%    sign with reference to sqrt
%    trigonometrical functions using abs which uses sign

algebraic;

% Square roots.

deflist('((sqrt simpsqrt)),'simpfn);

% for all x let sqrt x**2=x;

% !*!*sqrt:  used to indicate that SQRTs have been used.

% !*keepsqrts:  causes SQRT rather than EXPT to be used.

symbolic procedure mksqrt u;
   if not !*keepsqrts then list('expt,u,list('quotient,1,2))
    else <>;
      list('sqrt,u)>>;

for all x let df(sqrt x,x)=sqrt x/(2*x);


% SIGN operator.

symbolic procedure sign!-of u;
  % Returns -1,0 or 1 if the sign of u is known. Otherwise nil.
   (numberp s and s) where s = numr simp!-sign{u};

symbolic procedure simp!-sign u;
 begin scalar s,n;
   u:=reval car u;
   s:=if eqcar(u,'abs) then '(1 . 1)
      else if eqcar(u,'times) then simp!-sign!-times u
      else if eqcar(u,'plus) then simp!-sign!-plus u
      else simpiden{'sign,u};
   if not numberp(n:=numr s) or n=1 or n=-1 then return s;
   typerr(n,"sign value");
 end;

symbolic procedure simp!-sign!-times w;
 % Factor all known signs out of the product.
  begin scalar n,s,x;
   n:=1;
   for each f in cdr w do
   <>;
   n:=(n/abs n) ./ 1;
   s:=if null s then '(1 . 1) else
     simpiden {'sign, if cdr s then 'times.reversip s else car s};
   return multsq (n,s)
  end;

symbolic procedure simp!-sign!-plus w;
 % Stop sign evaluation as soon as two different signs
 % or one unknown sign were found.
  begin scalar n,m,x,q;
   for each f in cdr w do if null q then
   <>;
   return if null q then n ./ 1 else
       simpiden {'sign,w};
  end;

fluid '(rd!-sign!*);

symbolic procedure rd!-sign u;
  % if U is constant evaluable return sign of u.
  % the value is set aside.
  if pairp rd!-sign!* and u=car rd!-sign!* then cdr rd!-sign!*
    else
  if !*complex or !*rounded or not constant_exprp u then nil
    else
  (begin scalar x,y,dmode!*;
    setdmode('rounded,t);
    x := aeval u;
    if evalnumberp x and 0=reval {'impart,x}
    then y := if evalgreaterp(x,0) then 1 else
         if evalequal(x,0) then 0 else -1;
    setdmode('rounded,nil);
    rd!-sign!*:=(u.y);
    return y
  end) where alglist!*=alglist!*;

symbolic operator rd!-sign;

operator sign;

put('sign,'simpfn,'simp!-sign);

% The rules for products and sums are covered by the routines
% below in order to avoid a combinatoric explosion. Abs (sign ~x)
% cannot be defined by a rule because the evaluation of abs needs
% sign.

sign_rules :=
   { sign ~x => (if x>0 then 1 else if x<0 then -1 else 0)
        when numberp x and impart x=0,
     sign(-~x) => -sign(x),
%%   sign( ~x * ~y) =>  sign x * sign y
%%         when numberp sign x or numberp sign y,
     sign( ~x / ~y) =>  sign x * sign y
           when y neq 1 and (numberp sign x or numberp sign y),
%%   sign( ~x + ~y) =>  sign x when sign x = sign y,
     sign( ~x ^ ~n) => 1 when fixp (n/2) and 
                              lisp(not (!*complex or !*precise_complex)),
     sign( ~x ^ ~n) => sign x^n when fixp n and numberp sign x,
     sign( ~x ^ ~n) => sign x when fixp n and 
                                   lisp(not (!*complex or !*precise_complex)),
     sign(sqrt ~a)  => 1 when sign a=1,
     sign( ~a ^ ~x) => 1 when sign a=1 and impart x=0,
%%   sign(abs ~a)   => 1,
     sign ~a => rd!-sign a when rd!-sign a,
     % Next rule here for convenience.
     abs(~x)^2 => x^2 when symbolic not !*precise}$
     % $ above needed for bootstrap.

let sign_rules;

% Rule for I**2.

remflag('(i),'reserved);

let i**2= -1;

flag('(e i nil pi),'reserved);   % Leave out T for now.

% Logarithms.

let log(e)= 1,
    log(1)= 0;

for all x let log(e**x)=x; % e**log x=x now done by simpexpt.

% The next rule is implemented via combine/expand logs.

% for all x,y let log(x*y) = log x + log y, log(x/y) = log x - log y;

let df(log(~x),~x) => 1/x;

let df(log(~x/~y),~z) => df(log x,z) - df(log y,z);

% Trigonometrical functions.

deflist('((acos simpiden) (asin simpiden) (atan simpiden)
          (acosh simpiden) (asinh simpiden) (atanh simpiden)
          (acot simpiden) (cos simpiden) (sin simpiden) (tan simpiden)
          (sec simpiden) (sech simpiden) (csc simpiden) (csch simpiden)
          (cot simpiden)(acot simpiden)(coth simpiden)(acoth simpiden)
          (cosh simpiden) (sinh simpiden) (tanh simpiden)
          (asec simpiden) (acsc simpiden)
          (asech simpiden) (acsch simpiden)
   ),'simpfn);

% The following declaration causes the simplifier to pass the full
% expression (including the function) to simpiden.

flag ('(acos asin atan acosh acot asinh atanh cos sin tan cosh sinh tanh
        csc csch sec sech cot acot coth acoth asec acsc asech acsch),
      'full);

% flag ('(atan),'oddreal);

flag('(acoth acsc acsch asin asinh atan atanh sin tan csc csch sinh
       tanh cot coth),
     'odd);

flag('(cos sec sech cosh),'even);

flag('(cot coth csc csch),'nonzero);

% In the following rules, it is not necessary to let f(0)=0, when f
% is odd, since simpiden already does this.

% Some value have been commented out since these can be computed from
% other functions.

let cos(0)= 1,
  % sec(0)= 1,
  % cos(pi/12)=sqrt(2)/4*(sqrt 3+1),
    sin(pi/12)=sqrt(2)/4*(sqrt 3-1),
    sin(5pi/12)=sqrt(2)/4*(sqrt 3+1),
  % cos(pi/6)=sqrt 3/2,
    sin(pi/6)= 1/2,
  % cos(pi/4)=sqrt 2/2,
    sin(pi/4)=sqrt 2/2,
  % cos(pi/3) = 1/2,
    sin(pi/3) = sqrt(3)/2,
    cos(pi/2)= 0,
    sin(pi/2)= 1,
    sin(pi)= 0,
    cos(pi)=-1,
    cosh 0=1,
    sech(0) =1,
    sinh(i) => i*sin(1),
    cosh(i) => cos(1),
    acosh(1) => 0,
    acosh(-1) => i*pi
  % acos(0)= pi/2,
  % acos(1)=0,
  % acos(1/2)=pi/3,
  % acos(sqrt 3/2) = pi/6,
  % acos(sqrt 2/2) = pi/4,
  % acos(1/sqrt 2) = pi/4
  % asin(1/2)=pi/6,
  % asin(-1/2)=-pi/6,
  % asin(1)=pi/2,
  % asin(-1)=-pi/2
  ;

for all x let cos acos x=x, sin asin x=x, tan atan x=x,
           cosh acosh x=x, sinh asinh x=x, tanh atanh x=x,
           cot acot x=x, coth acoth x=x, sec asec x=x,
           csc acsc x=x, sech asech x=x, csch acsch x=x;

for all x let acos(-x)=pi-acos(x),
              acot(-x)=pi-acot(x);

% Fold the elementary trigonometric functions down to the origin.

let

 sin( (~~w + ~~k*pi)/~~d)
     => (if evenp fix(k/d) then 1 else -1)
          * sin((w + remainder(k,d)*pi)/d)
      when w freeof pi and ratnump(k/d) and fixp k and abs(k/d) >= 1,

 sin( ~~k*pi/~~d) => sin((1-k/d)*pi)
      when ratnump(k/d) and k/d > 1/2,

 cos( (~~w + ~~k*pi)/~~d)
     => (if evenp fix(k/d) then 1 else -1)
          * cos((w + remainder(k,d)*pi)/d)
      when w freeof pi and ratnump(k/d) and fixp k and abs(k/d) >= 1,

 cos( ~~k*pi/~~d) => -cos((1-k/d)*pi)
      when ratnump(k/d) and k/d > 1/2,

 tan( (~~w + ~~k*pi)/~~d)
     => tan((w + remainder(k,d)*pi)/d)
      when w freeof pi and ratnump(k/d) and fixp k and abs(k/d) >= 1,

 cot( (~~w + ~~k*pi)/~~d)
     => cot((w + remainder(k,d)*pi)/d)
      when w freeof pi and ratnump(k/d) and fixp k and abs(k/d) >= 1;

% The following rules follow the pattern
%   sin(~x + pi/2)=> cos(x) when x freeof pi
% however allowing x to be a quotient and a negative pi/2 shift.
% We need to handleonly pi/2 shifts here because
% the bigger shifts are already covered by the rules above.

let sin((~x + ~~k*pi)/~d) => sign(k/d)*cos(x/d)
         when x freeof pi and abs(k/d) = 1/2,

    cos((~x + ~~k*pi)/~d) => -sign(k/d)*sin(x/d)
         when x freeof pi and abs(k/d) = 1/2,

    tan((~x + ~~k*pi)/~d) => -cot(x/d)
         when x freeof pi and abs(k/d) = 1/2,

    cot((~x + ~~k*pi)/~d) => -tan(x/d)
         when x freeof pi and abs(k/d) = 1/2;

% Inherit function values.

symbolic (!*elem!-inherit := t);

symbolic procedure knowledge_about(op,arg,top);
  % True if the form '(op arg) can be formally simplified.
  % Avoiding recursion from rules for the target operator top by
  % a local remove of the property opmtch.
  % The internal switch !*elem!-inherit!* allows us to turn the
  % inheritage temporarily off.
    if dmode!* eq '!:rd!: or dmode!* eq '!:cr!:
     or null !*elem!-inherit then nil else
    (begin scalar r,old;
       old:=get(top,'opmtch); put(top,'opmtch,nil);
       r:= errorset!*({'aeval,mkquote{op,arg}},nil);
       put(top,'opmtch,old);
       return not errorp r and not smemq(op,car r)
             and not smemq(top,car r);
    end) where varstack!*=nil;

symbolic operator knowledge_about;

symbolic procedure trigquot(n,d);
  % Form a quotient n/d, replacing sin and cos by tan/cot
  % whenver possible.
  begin scalar m,u,w;
    u:=if eqcar(n,'minus) then <> else n;
    if pairp u and pairp d then
      if car u eq 'sin and car d eq 'cos and cadr u=cadr d
            then w:='tan else
      if car u eq 'cos and car d eq 'sin and cadr u=cadr d
            then w:='cot;
    if null w then return{'quotient,n,d};
    w:={w,cadr u};
    return if m then {'minus,w} else w;
  end;

symbolic operator trigquot;

% cos, tan, cot, sec, csc inherit from sin.


let cos(~x)=>sin(x+pi/2)
        when (x+pi/2)/pi freeof pi and knowledge_about(sin,x+pi/2,cos),
    cos(~x)=>-sin(x-pi/2)
        when (x-pi/2)/pi freeof pi and knowledge_about(sin,x-pi/2,cos),
    tan(~x)=>trigquot(sin(x),cos(x)) when knowledge_about(sin,x,tan),
    cot(~x)=>trigquot(cos(x),sin(x)) when knowledge_about(sin,x,cot),
    sec(~x)=>1/cos(x) when knowledge_about(cos,x,sec),
    csc(~x)=>1/sin(x) when knowledge_about(sin,x,csc);

% area functions

let asin(~x)=>pi/2 - acos(x) when knowledge_about(acos,x,asin),
    acot(~x)=>pi/2 - atan(x) when knowledge_about(atan,x,acot),
    acsc(~x) => asin(1/x) when knowledge_about(asin,1/x,acsc),
    asec(~x) => acos(1/x) when knowledge_about(acos,1/x,asec),
    acsch(~x) => acsc(-i*x)/i when knowledge_about(acsc,-i*x,acsch),
    asech(~x) => asec(x)/i when knowledge_about(asec,x,asech);

% hyperbolic functions

let sinh(i*~x)=>i*sin(x) when knowledge_about(sin,x,sinh),
    sinh(i*~x/~n)=>i*sin(x/n) when knowledge_about(sin,x/n,sinh),
    cosh(i*~x)=>cos(x) when knowledge_about(cos,x,cosh),
    cosh(i*~x/~n)=>cos(x/n) when knowledge_about(cos,x/n,cosh),
    cosh(~x)=>-i*sinh(x+i*pi/2)
       when (x+i*pi/2)/pi freeof pi
          and knowledge_about(sinh,x+i*pi/2,cosh),
    cosh(~x)=>i*sinh(x-i*pi/2)
       when (x-i*pi/2)/pi freeof pi
          and knowledge_about(sinh,x-i*pi/2,cosh),
    tanh(~x)=>sinh(x)/cosh(x) when knowledge_about(sinh,x,tanh),
    coth(~x)=>cosh(x)/sinh(x) when knowledge_about(sinh,x,coth),
    sech(~x)=>1/cosh(x) when knowledge_about(cosh,x,sech),
    csch(~x)=>1/sinh(x) when knowledge_about(sinh,x,csch);

let acsch(~x) => asinh(1/x) when knowledge_about(asinh,1/x,acsch),
    asech(~x) => acosh(1/x) when knowledge_about(acosh,1/x,asech),
    asinh(~x) => -i*asin(i*x) when i*x freeof i
                   and knowledge_about(asin,i*x,asinh);


% hyperbolic functions

let

 sinh( (~~w + ~~k*pi)/~~d)
      => (if evenp fix(i*k/d) then 1 else -1)
           * sinh((w + remainder(i*k,d)*pi/i)/d)
       when w freeof pi and ratnump(i*k/d) and fixp k and abs(i*k/d)>=1,

 sinh( ~~k*pi/~~d) => sinh((i-k/d)*pi)
       when ratnump(i*k/d) and abs(i*k/d) > 1/2,

 cosh( (~~w + ~~k*pi)/~~d)
      => (if evenp fix(i*k/d) then 1 else -1)
           * cosh((w + remainder(i*k,d)*pi/i)/d)
       when w freeof pi and ratnump(i*k/d) and fixp k and abs(i*k/d)>=1,

 cosh( ~~k*pi/~~d) => -cosh((i-k/d)*pi)
       when ratnump(i*k/d) and abs(i*k/d) > 1/2,

 tanh( (~~w + ~~k*pi)/~~d)
      => tanh((w + remainder(i*k,d)*pi/i)/d)
       when w freeof pi and ratnump(i*k/d) and fixp k and abs(i*k/d)>=1,

 coth( (~~w + ~~k*pi)/~~d)
      => coth((w + remainder(i*k,d)*pi/i)/d)
       when w freeof pi and ratnump(i*k/d) and fixp k and abs(i*k/d)>=1;

% The following rules follow the pattern
%   sinh(~x + i*pi/2)=> cosh(x) when x freeof pi
% however allowing x to be a quotient and a negative i*pi/2 shift.
% We need to handle only pi/2 shifts here because
% the bigger shifts are already covered by the rules above.

let sinh((~x + ~~k*pi)/~d) => i*sign(-i*k/d)*cosh(x/d)
          when x freeof pi and abs(i*k/d) = 1/2,

    cosh((~x + ~~k*pi)/~d) => i*sign(-i*k/d)*sinh(x/d)
          when x freeof pi and abs(i*k/d) = 1/2,

    tanh((~x + ~~k*pi)/~d) => coth(x/d)
          when x freeof pi and abs(i*k/d) = 1/2,

    coth((~x + ~~k*pi)/~d) => tanh(x/d)
          when x freeof pi and abs(i*k/d) = 1/2;


% Transfer inverse function values from cos to acos and tan to atan.
% Negative values not needed.

%symbolic procedure simpabs u;
%   if null u or cdr u then mksq('abs . revlis u, 1)  % error?.
%    else begin scalar x;
%      u := car u;
%      if eqcar(u,'quotient) and fixp cadr u and fixp caddr u
%         and cadr u>0 and caddr u>0 then return simp u;
%      if x := rd!-abs u then return x;
%      u := simp!* u;
%      return if null numr u then nil ./ 1
%             else quotsq(mkabsf1 absf numr u,mkabsf1 denr u)
%  end;

acos_rules :=
  symbolic(
  'list . for j:=0:12 join
    (if eqcar(q,'acos) and cadr q=w then {{'replaceby,q,u}})
     where q=reval{'acos,w}
      where w=reval{'cos,u}
       where u=reval{'quotient,{'times,'pi,j},12})$

let acos_rules;

clear acos_rules;

atan_rules :=
  symbolic(
  'list . for j:=0:5 join
    (if eqcar(q,'atan) and cadr q=w then {{'replaceby,q,u}})
     where q= reval{'atan,w}
      where w= reval{'tan,u}
       where u= reval{'quotient,{'times,'pi,j},12})$

let atan_rules;

clear atan_rules;


repart(pi) := pi$       % $ used for bootstrapping purposes.
impart(pi) := 0$

% ***** Differentiation rules *****.

for all x let df(acos(x),x)= -sqrt(1-x**2)/(1-x**2),
              df(asin(x),x)= sqrt(1-x**2)/(1-x**2),
              df(atan(x),x)= 1/(1+x**2),
              df(acosh(x),x)= sqrt(x**2-1)/(x**2-1),
              df(acot(x),x)= -1/(1+x**2),
              df(acoth(x),x)= -1/(1-x**2),
              df(asinh(x),x)= sqrt(x**2+1)/(x**2+1),
              df(atanh(x),x)= 1/(1-x**2),
              df(acoth(x),x)= 1/(1-x**2),
              df(cos x,x)= -sin(x),
              df(sin x,x)= cos(x),
              df(sec x,x) = sec(x)*tan(x),
              df(csc x,x) = -csc(x)*cot(x),
              df(tan x,x)=1 + tan x**2,
              df(sinh x,x)=cosh x,
              df(cosh x,x)=sinh x,
              df(sech x,x) = -sech(x)*tanh(x),
%              df(tanh x,x)=sech x**2,
              % J.P. Fitch prefers this one for integration purposes
              df(tanh x,x)=1-tanh(x)**2,
              df(csch x,x)= -csch x*coth x,
              df(cot x,x)=-1-cot x**2,
              df(coth x,x)=1-coth x**2;

let df(acsc(~x),x) =>  -1/(x*sqrt(x**2 - 1)),
%   df(asec(~x),x) => 1/(x*sqrt(x**2 - 1)),  % Only true for abs x>1.
    df(asec(~x),x) => 1/(x^2*sqrt(1-1/x^2)),
    df(acsch(~x),x)=> -1/(x*sqrt(1+ x**2)),
    df(asech(~x),x)=> -1/(x*sqrt(1- x**2));

%for all x let e**log x=x;   % Requires every power to be checked.

for all x,y let df(x**y,x)= y*x**(y-1),
                df(x**y,y)= log x*x**y;

% Ei, erf, exp and dilog.

operator dilog,ei,erf,exp;

let dilog(0)=pi**2/6;

for all x let df(dilog x,x)=-log x/(x-1);

for all x let df(ei(x),x)=e**x/x;

let erf 0=0;

for all x let erf(-x)=-erf x;

for all x let df(erf x,x)=2*sqrt(pi)*e**(-x**2)/pi;

for all x let exp(x)=e**x;

% Supply missing argument and simplify 1/4 roots of unity.

let   e**(i*pi/2) = i,
      e**(i*pi) = -1;
%     e**(3*i*pi/2)=-i;

% Rule for derivative of absolute value.

for all x let df(abs x,x)=abs x/x;

% More trigonometrical rules.

invtrigrules := {
  sin(atan ~u)   => u/sqrt(1+u^2),
  cos(atan ~u)   => 1/sqrt(1+u^2),
  sin(2*atan ~u) => 2*u/(1+u^2),
  cos(2*atan ~u) => (1-u^2)/(1+u^2),
  sin(~n*atan ~u) => sin((n-2)*atan u) * (1-u^2)/(1+u^2) +
                     cos((n-2)*atan u) * 2*u/(1+u^2)
                     when fixp n and n>2,
  cos(~n*atan ~u) => cos((n-2)*atan u) * (1-u^2)/(1+u^2) -
                     sin((n-2)*atan u) * 2*u/(1+u^2)
                     when fixp n and n>2,
  sin(acos ~u) => sqrt(1-u^2),
  cos(asin ~u) => sqrt(1-u^2),
  sin(2*acos ~u) => 2 * u * sqrt(1-u^2),
  cos(2*acos ~u) => 2*u^2 - 1,
  sin(2*asin ~u) => 2 * u * sqrt(1-u^2),
  cos(2*asin ~u) => 1 - 2*u^2,
  sin(~n*acos ~u) => sin((n-2)*acos u) * (2*u^2 - 1) +
                     cos((n-2)*acos u) * 2 * u * sqrt(1-u^2)
                     when fixp n and n>2,
  cos(~n*acos ~u) => cos((n-2)*acos u) * (2*u^2 - 1) -
                     sin((n-2)*acos u) * 2 * u * sqrt(1-u^2)
                     when fixp n and n>2,
  sin(~n*asin ~u) => sin((n-2)*asin u) * (1 - 2*u^2) +
                     cos((n-2)*asin u) * 2 * u * sqrt(1-u^2)
                     when fixp n and n>2,
  cos(~n*asin ~u) => cos((n-2)*asin u) * (1 - 2*u^2) -
                     sin((n-2)*asin u) * 2 * u * sqrt(1-u^2)
                     when fixp n and n>2
%  Next rule causes a simplification loop in solve(atan y=y).
% atan(~x) => acos((1-x^2)/(1+x^2)) * sign (x) / 2
%             when symbolic(not !*complex) and x^2 neq -1
%                   and acos((1-x^2)/(1+x^2)) freeof acos
}$

invhyprules := {
  sinh(atanh ~u)   => u/sqrt(1-u^2),
  cosh(atanh ~u)   => 1/sqrt(1-u^2),
  sinh(2*atanh ~u) => 2*u/(1-u^2),
  cosh(2*atanh ~u) => (1+u^2)/(1-u^2),
  sinh(~n*atanh ~u) => sinh((n-2)*atanh u) * (1+u^2)/(1-u^2) +
                       cosh((n-2)*atanh u) * 2*u/(1-u^2)
                       when fixp n and n>2,
  cosh(~n*atanh ~u) => cosh((n-2)*atanh u) * (1+u^2)/(1-u^2) +
                       sinh((n-2)*atanh u) * 2*u/(1-u^2)
                       when fixp n and n>2,
  sinh(acosh ~u) => sqrt(u^2-1),
  cosh(asinh ~u) => sqrt(1+u^2),
  sinh(2*acosh ~u) => 2 * u * sqrt(u^2-1),
  cosh(2*acosh ~u) => 2*u^2 - 1,
  sinh(2*asinh ~u) => 2 * u * sqrt(1+u^2),
  cosh(2*asinh ~u) => 1 + 2*u^2,
  sinh(~n*acosh ~u) => sinh((n-2)*acosh u) * (2*u^2 - 1) +
                       cosh((n-2)*acosh u) * 2 * u * sqrt(u^2-1)
                       when fixp n and n>2,
  cosh(~n*acosh ~u) => cosh((n-2)*acosh u) * (2*u^2 - 1) +
                       sinh((n-2)*acosh u) * 2 * u * sqrt(u^2-1)
                       when fixp n and n>2,
  sinh(~n*asinh ~u) => sinh((n-2)*asinh u) * (1 + 2*u^2) +
                       cosh((n-2)*asinh u) * 2 * u * sqrt(1+u^2)
                       when fixp n and n>2,
  cosh(~n*asinh ~u) => cosh((n-2)*asinh u) * (1 + 2*u^2) +
                       sinh((n-2)*asinh u) * 2 * u * sqrt(1+u^2)
                       when fixp n and n>2,
  atanh(~x) => acosh((1+x^2)/(1-x^2)) * sign (x) / 2
               when symbolic(not !*complex)
                     and acosh((1+x^2)/(1-x^2)) freeof acosh
}$

let invtrigrules,invhyprules;

trig_imag_rules := {
    sin(i * ~~x / ~~y)   => i * sinh(x/y) when impart(y)=0,
    cos(i * ~~x / ~~y)   => cosh(x/y) when impart(y)=0,
    sinh(i * ~~x / ~~y)  => i * sin(x/y) when impart(y)=0,
    cosh(i * ~~x / ~~y)  => cos(x/y) when impart(y)=0,
    asin(i * ~~x / ~~y)  => i * asinh(x/y) when impart(y)=0,
    atan(i * ~~x / ~~y)  => i * atanh(x/y) when impart(y)=0
                                and not(x=1 and y=1),
    asinh(i * ~~x / ~~y) => i * asin(x/y) when impart(y)=0,
    atanh(i * ~~x / ~~y) => i * atan(x/y) when impart(y)=0
}$

let trig_imag_rules;

% Generalized periodicity rules for trigonometric functions.
% FJW, 16 October 1996.

let {
 cos(~n*pi*arbint(~i) + ~~x) => cos(remainder(n,2)*pi*arbint(i) + x)
  when fixp n,
 sin(~n*pi*arbint(~i) + ~~x) => sin(remainder(n,2)*pi*arbint(i) + x)
  when fixp n,
 tan(~n*pi*arbint(~i) + ~~x) => tan(x) when fixp n,
 sec(~n*pi*arbint(~i) + ~~x) => sec(remainder(n,2)*pi*arbint(i) + x)
  when fixp n,
 csc(~n*pi*arbint(~i) + ~~x) => csc(remainder(n,2)*pi*arbint(i) + x)
  when fixp n,
 cot(~n*pi*arbint(~i) + ~~x) => cot(x) when fixp n
};

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/forall.red0000644000175000017500000010557011526203062023232 0ustar  giovannigiovannimodule forall; % FOR ALL and LET-related commands.

% Author: Anthony C. Hearn.
% Modifications by:  Herbert Melenk.

% Copyright (c) 1993 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*resimp !*sub2 alglist!* arbl!* asymplis!* frasc!* wtl!*);

fluid '(!*!*noremove!*!* frlis!* newrule!* oldrules!* props!* subfg!*);

fluid '(!*reduce4 !*sqrtrulep powlis!* powlis1!*);

global '(!*match cursym!* erfg!* letl!* mcond!*);

letl!* := '(let match clear saveas such);   % Special delimiters.

% Contains two RPLAC references commented out.

remprop('forall,'stat);

remprop('forall,'formfn);

symbolic procedure forallstat;
   begin scalar arbl,conds;
        if cursym!* memq letl!* then symerr('forall,t);
        flag(letl!*,'delim);
        arbl := remcomma xread nil;
        if cursym!* eq 'such then
          <>;
        remflag(letl!*,'delim);
        if not(cursym!* memq letl!*) then symerr('let,t)
         else return list('forall,arbl,conds,xread1 t)
   end;

symbolic procedure forall u;
   begin scalar x,y;
      x := for each j in car u collect newvar j;
      y := pair(car u,x);
      mcond!* := subla(y,cadr u);
%     mcond!* := formbool(subla(y,eval cadr u),nil,'algebraic);
      frasc!* := y;
      frlis!* := union(x,frlis!*);
      return lispeval caddr u
   end;

symbolic procedure arbstat;
   <>;

put('arb,'stat,'arbstat);

symbolic procedure newvar u;
   if not idp u then typerr(u,"free variable")
%   else if flagp(u,'reserved)
%    then typerr(list("Reserved variable",u),"free variable")
    else intern compress append(explode '!=,explode u);

symbolic procedure formforall(u,vars,mode);
   begin scalar arbl!*,x,y;
      u := cdr u;
%     vars := append(car u,vars);   % Semantics are different.
      if null cadr u then x := t else x := formbool(cadr u,vars,mode);
%     if null cadr u then x := t else x := form1(cadr u,vars,mode);
      y := form1(caddr u,vars,mode);
      % Allow for a LET or MATCH call during a similar evaluation.
      % This might occur in autoloading.
      if eqcar(y,'let) then y := 'let00 . cdr y
       else if eqcar(y,'match) then y := 'match00 . cdr y;
      return list('forall,list('list,mkquote union(arbl!*,car u),
                  mkquote x,mkquote y))
   end;

symbolic procedure def u;
   % Defines a list of operators.
   <>>>;

put('def,'stat,'rlis);

deflist('((forall formforall)),'formfn);

deflist('((forall forallstat)),'stat);

flag ('(clear let match),'quote);

symbolic procedure formlet1(u,vars,mode);
   requote ('list . for each x in u collect
      if eqexpr x
        then list('list,mkquote car x,form1(cadr x,vars,mode),
                                !*s2arg(form1(caddr x,vars,mode),vars))
       else form1(x,vars,mode));

symbolic procedure requote u;
   if atom u or not(car u eq 'list) then u
    else (if x then mkquote x else u) where x=requote1 cdr u;

symbolic procedure requote1 u;
   begin scalar x,y;
   a: if null u then return reversip x
       else if numberp car u or car u memq '(nil t)
        then x := car u . x
       else if atom car u then return nil
       else if caar u eq 'quote then x := cadar u . x
       else if caar u eq 'list and (y := requote1 cdar u)
        then x := y . x
       else return nil;
      u := cdr u;
      go to a
   end;

symbolic procedure !*s2arg(u,vars);
   %makes all NOCHANGE operators into their listed form;
   if atom u or eq(car u,'quote) then u
    else if not idp car u or not flagp(car u,'nochange)
     then for each j in u collect !*s2arg(j,vars)
    else mkarg(u,vars);

put('let,'formfn,'formlet);

put('clear,'formfn,'formclear);

put('match,'formfn,'formmatch);

symbolic procedure formclear(u,vars,mode);
   list('clear,formclear1(cdr u,vars,mode));

symbolic procedure formclear1(u,vars,mode);
   'list . for each x in u collect
      if flagp(x,'share) then mkquote x else form1(x,vars,mode);

symbolic procedure formlet(u,vars,mode);
   list('let,formlet1(cdr u,vars,mode));

symbolic procedure formmatch(u,vars,mode);
   list('match,formlet1(cdr u,vars,mode));

symbolic procedure let u; let0 u;    % to distinguish between operator
                                     % and function.

symbolic procedure let0 u;
   let00 u where frasc!* = nil;

symbolic procedure let00 u;
   begin
      u := errorset!*(list('let1,mkquote u),t);
      frasc!* := mcond!* := nil;
      if errorp u then error1() else return car u
   end;

symbolic procedure let1 u;
   begin scalar x,y;
      u := reverse u;  % So that rules are added in order given.
      while u do
         < invalid in FOR ALL statement")
                   else rule!-list(list x,t)
            else if car x eq 'equal
                    then if smemq('!~,x)
                           then if frasc!* then typerr(x,"rule")
                                 else rule!-list(list x,t)
                          else let2(cadr x,caddr x,nil,t)
            else revalruletst x;
           u := cdr u>>
   end;

symbolic procedure revalruletst u;
   (if u neq v then let1 list v else typerr(u,"rule list"))
   where v = reval u;

symbolic procedure let2(u,v,w,b);
   begin scalar flgg,x,y,z;
        % FLGG is set true if free variables are found.
        if (y := getrtype u) and (z := get(y,'typeletfn))
           and flagp(z,'direct)
          then return lispapply(z,list(u,v,y,b,getrtype v))
         else if (y := getrtype v) and (z := get(y,'typeletfn))
                 and flagp(z,'direct)
          then return lispapply(z,list(u,v,nil,b,y));
        x := subla(frasc!*,u);
        if x neq u
          then if atom x then return errpri1 u
                 else <>;
        x := subla(frasc!*,v);
        if x neq v
          then <>;
                 % to ensure no kernels are replaced by uneq copies
                 % during pattern matching process.
        % Check for unmatched free variables.
        x := smemql(frlis!*,mcond!*);
        y := smemql(frlis!*,u);
        if (z := setdiff(x,y))
           or (z := setdiff(setdiff(smemql(frlis!*,v),x),
                    setdiff(y,x)))
          then <>
         else if numberp x then return errpri1 u;
        % Allow redefinition of id's, regardless of type.
       % The next line allows type of LHS to be redefined.
       y2 := getrtype v;
       if b and idp x then <>;
%        else if idp x and flagp(x,'reserved)
%         then rederr list(x,"is a reserved identifier");
        if (y1 := getrtype x)
          then return if z := get(y1,'typeletfn)
                        then lispapply(z,list(x,v,y1,b,getrtype v))
                       else typelet(x,v,y1,b,getrtype v)
         else if y2 and not(y2 eq 'yetunknowntype)
          then return if z := get(y2,'typeletfn)
                        then lispapply(z,list(x,v,nil,b,y2))
                       else typelet(x,v,nil,b,y2)
         else letscalar(u,v,w,x,b,flgg)
   end;

symbolic procedure letscalar(u,v,w,x,b,flgg);
   begin
      if not atom x
               then if not idp car x then return errpri2(u,'hold)
                     else if car x eq 'df
                      then if null letdf(u,v,w,x,b) then nil
                            else return nil
                     else if getrtype car x
                      then return let2(reval x,v,w,b)
                     else if not get(car x,'simpfn)
                      then <>
                     else nil
         else if null b and null w
          then <>;
                 rmsubs(); % since all kernel lists are gone.
                 return nil>>;
        if eqcar(x,'expt) and caddr x memq frlis!*
          then letexprn(u,v,w,!*k2q x,b,flgg)
           % Special case of a non-integer exponent match.
         else if eqcar(x,'sqrt)
          then <>;
           % Since SQRTs can be converted into EXPTs.
        x := simp0 x where !*precise = t;  % We don't want to break
                                           % up exponents.
        return if not domainp numr x then letexprn(u,v,w,x,b,flgg)
                else errpri1 u
   end;

symbolic procedure letexprn(u,v,w,x,b,flgg);
   % Replacement of scalar expressions.
   begin scalar y,z;
        if denr x neq 1
          then return let2(let!-prepf numr x,
                           list('times,let!-prepf denr x,v),w,b)
         else if red(x := numr x)
          then return let2(let!-prepf !*t2f lt x,
                           list('difference,v,let!-prepf red x),w,b)
         else if null (y := kernlp x)
          then <>
         else if y neq 1
          then return let2(let!-prepf quotf!*(x,y),
                           list('quotient,v,let!-prepf y),w,b);
        x := klistt x;
        y := list(w . (if mcond!* then mcond!* else t),v,nil);
        if cdr x
          then return <>
         else if null w and cdar x=1    % ONEP
          then <>
                  else if atom x then return errpri1 u
                  else <>>>
         else <>
                 else if w or not(cdar y eq t) or frasc!*
                  then powlis1!* := xadd(car x . y,powlis1!*,b)
                 else if null b and (z := assoc(caar x,asymplis!*))
                    and z=car x
                  then asymplis!* := delasc(caar x,asymplis!*)
              else <>>>
   end;

rlistat '(clear let match);


% Further support for rule lists and local rule applications.

symbolic procedure clearrules u;
   rule!-list(u,nil) where !*sqrtrulep=nil;

% symbolic procedure letrules u; rule!-list(u,t);

rlistat '(clearrules);   % letrules.

symbolic procedure rule!-list(u,type);
   % Type is true if the rule is being added, NIL if being removed.
   begin scalar v,x,y,z;
   a: frasc!* := nil;   % Since free variables must be declared in each
                        % rule.
      if null u or u = {{}} then return (mcond!* := nil);
      mcond!* := t;
      v := car u;
      if idp v
        then if (x := get(v,'avalue)) and car x eq 'list
               then <>
              else typerr(v,"rule list")
       else if car v eq 'list
          then <>
       else if car v eq 'equal
        then lprim "Please use => instead of = in rules"
       else if not(car v eq 'replaceby) then typerr(v,"rule");
      y := remove!-free!-vars cadr v;
      if eqcar(caddr v,'when)
        then <>
       else z := remove!-free!-vars!* caddr v;
      rule!*(y,z,frasc!*,mcond!*,type);
      u := cdr u;
      go to a
   end;

symbolic procedure rule!*(u,v,frasc,mcond,type);
   % Type is T if a rule is being added, OLD if an old rule is being
   % reinstalled, or NIL if a rule is being removed.
   begin scalar x;
      frasc!* := frasc;
      mcond!* := mcond eq t or subla(frasc,mcond);
      if type and type neq 'old
        then <>;
                        if x := get(u,'avalue)
                          then <>>>;
               % Asymptotic case.
               if v=0 and eqcar(u,'expt) and idp cadr u
                  and numberp caddr u
                  and (x := assoc(cadr u,asymplis!*))
                then updoldrules(x,nil)>>;
      return rule(u,v,frasc,if type eq 'old then t else type)
   end;

symbolic procedure rule(u,v,frasc,type);
   begin scalar flg,frlis,x,y,z;
        % FLGG is set true if free variables are found.
        %
        x := subla(frasc,u);
        if x neq u
          then if atom x then return errpri1 u
                 else <>;
        x := subla(frasc,v);
        if x neq v
          then <>;
                 % to ensure no kernels are replaced by uneq copies
                 % during pattern matching process.
        % Check for unmatched free variables.
        frlis := for each j in frasc collect cdr j;
        x := smemql(frlis,mcond!*);
        y := smemql(frlis,u);
        if (z := setdiff(x,y))
           or (z := setdiff(setdiff(smemql(frlis,v),x),
                    setdiff(y,x)))
          then <>;

newtok '((!= !>) replaceby);

infix =>;

precedence =>,to;

symbolic procedure equalreplaceby u;
   'replaceby . u;

put('replaceby,'psopfn,'equalreplaceby);

flag('(replaceby),'equalopr);           % Make LHS, RHS etc work.

flag('(replaceby),'spaced);             % Make it print with spaces.

symbolic procedure formreplaceby(u,vars,mode);
   list('list,mkquote car u,form1(cadr u,vars,mode),
                                !*s2arg(form1(caddr u,vars,mode),vars));

put('replaceby,'formfn,'formreplaceby);

infix when;

precedence when,=>;

symbolic procedure formwhen(u,vars,mode);
   list('list,algid('when,vars),form1(cadr u,vars,mode),
%  We exclude formbool in following so that rules print prettily.
%                   mkarg(formbool(caddr u,vars,mode),vars));
                    mkarg(caddr u,vars));

put('when,'formfn,'formwhen);

flag('(whereexp),'listargp);   % letsub.

% put('letsub,'simpfn,'simpletsub);

put('whereexp,'psopfn,'evalwhereexp);

% symbolic procedure simpletsub u; simp evalletsub1(u,t);

symbolic procedure evalwhereexp u;
   % We assume that the arguments of this function are well-formed, as
   % they would be if produced from a "where" parse.
   % It looks like there is a spurious simplification, but it's needed
   % in x:= (e^(12i*pi/5) - e^(8i*pi/5) + 4e^(6i*pi/5) - e^(4i*pi/5)
   %     - 2e^(2i*pi/5) - 1)/(16e^(6i*pi/5)); y:= {e^(~a*i*pi/~(~ b))
   %     => e^((a - b)/b*i*pi) when numberp a and numberp b and a>b};
   %     x where y;
   evalletsub({cdar u,{'aeval,mkquote{'aeval,carx(cdr u,'where)}}},nil);

flag('(aeval),'opfn);   % To make the previous procedure work.

% symbolic procedure evalletsub1(u,v);
%  begin scalar x;
%     x := car u;
%     u := carx(cdr u,'simpletsub);
%     if eqcar(x,'list) then x := cdr x else errach 'simpletsub;
%     return evalletsub2({x,{'aeval,mkquote u}},v)
%  end;

symbolic procedure evalletsub(u,v);
   if errorp(u := evalletsub2(u,v))
     then rerror(alg,24,"Invalid simplification")
    else car u;

symbolic procedure evalletsub2(u,v);
  % car u   is an untagged list of rules or ruleset names,
  % cadr u  is an expression to be evaluated by errorset* with the
  %          rules activated locally,
  % v should be nil unless the rules contain equations.
  % Returns the expression value corresponding to the
  % errorset protocol.
   begin scalar newrule!*,oldrules!*,props!*,w;
      w := set_rules(car u,v);
      % We need resimp on since u may contain (*SQ ... T).
      u := errorset!*(cadr u,nil); % where !*resimp = t;
      % Restore previous environment, if changed.
      restore_rules w;
      return u
   end;

symbolic procedure set_rules(u,v);
   begin scalar !*resimp,x,y,z;
      for each j in u do
      % The "v" check in next line causes "a where a=>4" to fail.
         if eqcar(j,'replaceby) then y := j . y
          else if null v and eqcar(j,'equal)
           then < instead of = in rules";
                  y := ('replaceby . cdr j) . y>>
          else if (x := validrule j)
             or idp j and (x := validrule reval j)
           then (x := reverse car x) and <>
          else typerr(j,"rule list");
      rule!-list(y,t);
      return y . z
   end;

symbolic procedure restore_rules u;
   <>
   where !*resimp := nil;

symbolic procedure restore_props;
   % At present, the only thing props!* can contain is an RTYPE
   % property.  However, it is in this form to handle any other cases
   % that arise.
   for each j in props!* do
      if pairp cdr j then put(car j,cadr j,cddr j)
       else flag({car j},cdr j);

symbolic procedure resimpcar u; resimp car u;

symbolic procedure validrule u;
   (if null x then nil else list x) where x=validrule1 u;

symbolic procedure validrule1 u;
   if atom u then nil
    else if car u eq 'list
     then if null cdr u then {{}}
           else for each j in cdr u collect validrule1 j
    else if car u eq 'replaceby then u
    else if car u eq 'equal then 'replaceby . cdr u
    else nil;

symbolic procedure remove!-free!-vars!* u;
   remove!-free!-vars u where !*!*noremove!*!* := t;

symbolic procedure remove!-free!-vars u;
   begin scalar x,w;
      return if atom u then u
          else if car u eq '!~
           then if !*!*noremove!*!*
                  then if (x := atsoc(cadr u,frasc!*))
                         or eqcar(cadr u,'!~)
                            and (x := atsoc(cadadr u,frasc!*))
                        then cdr x else u
                 else if atom cdr u then typerr(u,"free variable")
                 % Allow for the substitution of a free variable.
                 else if numberp(w := cadr u) then u
                 else if idp w or eqcar(w,'!~) and (w:=cadr w)
                  then <>
                 else if idp caadr u   % Free operator.
                  then <>
                 else typerr(u,"free variable")
          else remove!-free!-vars!-l u
   end;

symbolic procedure remove!-free!-vars!-l u;
   if atom u then u
    else if car u eq '!*sq then remove!-free!-vars!-l prepsq!* cadr u
    else (if x=u then u else x)
         where x=remove!-free!-vars car u . remove!-free!-vars!-l cdr u;

symbolic procedure get!-free!-form u;
   begin scalar x,opt;
      if x := atsoc(u,frasc!*) then return cdr x;
      if eqcar(u,'!~) then <>;
      return tpowadd(x,!*t2f lt u) . tpowadd(x,red u)
   end;

symbolic procedure tpowadd(u,v);
   <>;

symbolic procedure frvarsof(u,l);
  % Extract the free variables in u in their left-to-right order.
   if memq(u,frlis!*) then if memq(u,l) then l else append(l,{u})
    else if atom u then l
    else frvarsof(cdr u,frvarsof(car u,l));

symbolic procedure simp0 u;
   begin scalar !*factor,x,y,z;
        if eqcar(u,'!*sq) then return simp0 prepsq!* cadr u;
        y := setkorder frvarsof(u,nil);
        x := subfg!* . !*sub2;
        alglist!* := nil . nil;   % Since assignments will change.
        subfg!* := nil;
        if atom u
           or idp car u
              and (flagp(car u,'simp0fn) or get(car u,'rtype))
          then z := simp u
         else z := simpiden u;
        rplaca(alglist!*,delasc(u,car alglist!*));
        % Since we don't want to keep this value.
        subfg!* := car x;
        !*sub2 := cdr x;
        setkorder y;
        return z
   end;

flag('(cons difference eps expt minus plus quotient times),'simp0fn);

symbolic procedure let!-prepf u;
   subla(for each x in frasc!* collect (cdr x . car x),prepf u);

symbolic procedure match u;
   match00 u where frasc!* = nil;

symbolic procedure match00 u;
   <>;

symbolic procedure clear u;
   begin
      rmsubs();
      u := errorset!*(list('clear1,mkquote u),t);
      mcond!* := frasc!* := nil;
      if errorp u then error1() else return car u
   end;

symbolic procedure clear1 u;
   begin scalar x,y;
      while u do
         <>;
           u := cdr u>>
   end;

symbolic procedure typelet(u,v,ltype,b,rtype);
   % General function for setting up rules for typed expressions.
   % LTYPE is the type of the left hand side U, RTYPE, that of RHS V.
   % B is a flag that is true if this is an update, nil for a removal.
   begin scalar ls;
        if null rtype then rtype := 'scalar;
        if ltype eq rtype then go to a
         else if null b then go to c
         else if ltype
          then if ltype eq 'list and rtype eq 'scalar
                 then <>
                else typerr(list(ltype,u),rtype)
         else if not atom u
          then if arrayp car u then go to a else typerr(u,rtype);
        redmsg(u,rtype);
    l:  put(u,'rtype,rtype);
        ltype := rtype;
    a:  if b and (not atom u or flagp(u,'used!*)) then rmsubs();
    c:  if not atom u
          then if arrayp car u
                 then setelv(u,if b then v else nil)
                else put(car u,'opmtch,xadd!*(cdr u .
                    list(nil . (if mcond!* then mcond!* else t),v,nil),
                        get(car u,'opmtch),b))
         else if null b
          then <>
         else if ls
          then <>
         else <>
       else if not atom u
         and idp car u
      % Excalc currently needs getrtype to check for free indices.
      % Getrtype *must* be called as first argument in OR below.
         and ((x := getrtype u or get(car u,'rtype))
                and (x := get(x,'setelemfn))
               or (x := get(car u,'setkfn)))
        % We must update alglist!* when an element is defined.
        then <>
        % alglist!* is updated here in simp0.
       else let2(u,v,nil,t);
      return v
   end;

symbolic procedure setk1(u,v,b);
   begin scalar x,y,z,!*uncached;
      !*uncached := t;
      if atom u
        then <>
                else if (x:= get(u,'avalue)) then put!-avalue(u,car x,v)
                else put!-avalue(u,'scalar,v);
               return v>>
       else if not atom car u
        then rerror(alg,25,"Invalid syntax: improper assignment");
      u := car u . revlis cdr u;
      if null b
        then <>
                else put(car u,'kvalue,delete(x,y));
                if z then wtl!*:=delasc(u,wtl!*);
               return nil>>
       else if not (y := get(car u,'kvalue))
        then put!-kvalue(car u,nil,u,v)
       else <>;
              put!-kvalue(car u,y,u,v)>>;
      return v
     end;

% symbolic procedure put!-avalue(u,v,w);
%    if smember(u,w) then recursiveerror u
%    else put(u,'avalue,{v,w});

symbolic procedure put!-avalue(u,v,w);
   % This definition allows for an assignment such as a := a 4.
   if v eq 'scalar
     then if eqcar(w,'!*sq) and sq_member(u,cadr w)
            then recursiveerror u
           else if !*reduce4 then putobject(u,w,'generic)
           else put(u,'avalue,{v,w})
    else if smember(u,w) then recursiveerror u
    else put(u,'avalue,{v,w});

symbolic procedure sq_member(u,v);
   sf_member(u,numr v) or sf_member(u,denr v);

symbolic procedure sf_member(u,v);
   null domainp v and
     (mvar_member(u,mvar v) or sf_member(u,lc v) or sf_member(u,red v));

symbolic procedure mvar_member(u,v);
   % This and arglist member have to cater for the funny forms we
   % find in packages like TAYLOR.
   u = v or (null atom v and arglist_member(u,cdr v));

symbolic procedure arglist_member(u,v);
   null atom v and (mvar_member(u,car v) or arglist_member(u,cdr v));

% symbolic procedure put!-kvalue(u,v,w,x);
%    if smember(w,x) then recursiveerror w
%     else put(u,'kvalue,aconc(v,{w,x}));

symbolic procedure put!-kvalue(u,v,w,x);
   % This definition is needed to allow p(2) := sqrt(1-p^2).
   if (if eqcar(x,'!*sq) then sq_member(w,cadr x) else smember(w,x))
     then recursiveerror w
    else put(u,'kvalue,aconc(v,{w,x}));

symbolic procedure klistt u;
   if atom u then nil else caar u . klistt cdr carx(u,'list);

symbolic procedure kernlp u;
   % Returns leading domain coefficient if U is a monomial product
   % of kernels, NIL otherwise.
   if domainp u then u else if null red u then kernlp lc u else nil;

symbolic procedure xadd(u,v,b);
   % Adds replacement U to table V, with new rule at head.
   % Note that format of u and v depends on whether a free variable
   % occurs in the expression or asymplis* is being updated!!.
   begin scalar x;
        x := assoc(car u,v);
        if null x
          then if b and not(b eq 'replace) then v := u . v else nil
         else if b
          then <>
%        else if cadr x=cadr u then v := delete(x,v);
         else if atom cdr x and cdr x=cdr u
              or not atom cdr x and cadr x=cadr u
          then v := delete(x,v);
        return v
   end;

symbolic procedure updoldrules(v,w);
   (if null u then nil
     else oldrules!* := append(
                 (if not atom v and numberp cdr v   % asymptotic case.
                    then list list(list('expt,car v,cdr v),0,nil,t)
                   else if atom car u
                    then list list(car u . car v,cadr v,nil,t)
                   else (if car u neq y
                           then list list(car u,y,x,rsubla(x,w))
                          else nil) where y=rsubla(x,v)),
                 oldrules!*)
           where x=caddr u)
    where u=newrule!*;

symbolic procedure xadd!*(u,v,b);
   % Adds replacement U to table V, with new rule at head.
   % Also checks boolean part for equality.
   % Note, in an earlier version, we removed all rules in the CLEAR mode
   % regardless of whether they came from a LET or a MATCH, or had
   % boolean constraints.  However, this made the fps tests not work.
   begin scalar x,y;
      x := v;
%     while x and not(car u=caar x and (cadr u=cadar x or null b))
      while x and not(car u=caar x and cadr u=cadar x)
         do x := cdr x;
      if x then < c might have occurred, in which case we
                  % need to adjust the form of the replaced value.
                 if b and newrule!*
                   then if car x neq (y := car newrule!*)
                           and powlisp car x
                      then updoldrules(prepsq simp {'plus,y,
                              {'difference,caddr x,'times .
                       for each j in car x collect {'expt,car j,cdr j}}},
                                       cdadr x)
                  else updoldrules(caddr x,cdadr x)>>;
      if b then v := u . v;
      return v
   end;

symbolic procedure powlisp u;
   null u or not atom car u and numberp cdar u and powlisp cdr u;

symbolic procedure rsubla(u,v);
   begin scalar x;
        if null u or null v then return v
         else if atom v
                 then return if x:= rassoc(v,u) then car x else v
         else return(rsubla(u,car v) . rsubla(u,cdr v))
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/rmsubs.red0000644000175000017500000000375511526203062023270 0ustar  giovannigiovannimodule rmsubs;   % Remove system wide standard quotient substitutions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(alglist!*);

global '(!*sqvar!*);

% Contains RPLACA update of *SQVAR*.

!*sqvar!*:= list 't;    %variable used by *SQ expressions to control
                        %resimplification;

symbolic procedure rmsubs;
   begin
        rplaca(!*sqvar!*,nil); !*sqvar!* := list t;
%       while kprops!* do
%          <>;
%       exlist!* := list '(!*);
        %This is too dangerous: someone else may have constructed a
        %standard form;
        alglist!* := nil . nil
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/linop.red0000644000175000017500000001661611526203062023076 0ustar  giovannigiovannimodule linop; % Linear operator package.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*intstr);

symbolic procedure linear u;
   for each x in u do
    if not idp x then typerr(x,'operator) else flag(list x,'linear);

rlistat '(linear);

symbolic procedure formlnr u;
   begin scalar x,y,z;
      x := car u;
      if null cdr u or null cddr u
        then rerror(alg,29,list("Linear operator",
                                x,"called with too few arguments"));
      y := cadr u;
      z := !*a2k caddr u . cdddr u;
      return if y = 1 then u
       else if not depends(y,car z)
        then list('times,y,x . 1 . z)
       else if atom y then u
       else if car y eq 'plus
        then 'plus . for each j in cdr y collect formlnr(x . j. z)
       else if car y eq 'minus
        then list('minus,formlnr(x . cadr y . z))
       else if car y eq 'difference
        then list('difference,formlnr(x . cadr y . z),
                              formlnr(x . caddr y . z))
       else if car y eq 'times then formlntms(x,cdr y,z,u)
       else if car y eq 'quotient then formlnquot(x,cdr y,z,u)
       else if car y eq 'recip
        then formlnrecip(x,carx(cdr y,'recip),z,u)
       else if y := expt!-separate(y,car z)
        then list('times,car y,x . cdr y . z)
       else u
   end;

symbolic procedure formseparate(u,v);
   %separates U into two parts, and returns a dotted pair of them: those
   %which are not commutative and do not depend on V, and the remainder;
   begin scalar w,x,y;
      for each z in u do
        if not noncomp z and not depends(z,v) then x := z . x
         else if (w := expt!-separate(z,v))
        then <>
         else y := z . y;
      return reversip!* x . reversip!* y
   end;

symbolic procedure expt!-separate(u,v);
   %determines if U is an expression in EXPT that can be separated into
   %two parts, one that does not depend on V and one that does,
   %except if there is no non-dependent part, NIL is returned;
   if not eqcar(u,'expt) or depends(cadr u,v)
           or not eqcar(caddr u,'plus)
     then nil
    else expt!-separate1(cdaddr u,cadr u,v);

symbolic procedure expt!-separate1(u,v,w);
   begin scalar x;
      x := formseparate(u,w);
      return if null car x then nil
              else list('expt,v,replus car x) .
                   if null cdr x then 1 else list('expt,v,replus cdr x)
   end;

symbolic procedure formlntms(u,v,w,x);
   %U is a linear operator, V its first argument with TIMES removed,
   %W the rest of the arguments and X the whole expression.
   %Value is the transformed expression;
   begin scalar y;
      y := formseparate(v,car w);
      return if null car y then x
              else 'times . aconc!*(car y,
                if null cddr y then formlnr(u . cadr y . w)
                      else u . ('times . cdr y) . w)
   end;

symbolic procedure formlnquot(fn,quotargs,rest,whole);
   %FN is a linear operator, QUOTARGS its first argument with QUOTIENT
   %removed, REST the remaining arguments, WHOLE the whole expression.
   %Value is the transformed expression;
   begin scalar x;
      return if not depends(cadr quotargs,car rest)
         then list('quotient,formlnr(fn . car quotargs . rest),
                   cadr quotargs)
        else if not depends(car quotargs,car rest)
               and car quotargs neq 1
         then list('times,car quotargs,
                   formlnr(fn . list('recip,cadr quotargs) . rest))
        else if eqcar(car quotargs,'plus)
         then 'plus . for each j in cdar quotargs
                collect formlnr(fn . ('quotient . j . cdr quotargs)
                                 . rest)
        else if eqcar(car quotargs,'minus)
         then list('minus,formlnr(fn .
                        ('quotient . cadar quotargs . cdr quotargs)
                            . rest))
        else if eqcar(car quotargs,'times)
                and car(x := formseparate(cdar quotargs,car rest))
         then 'times . aconc!*(car x,
                formlnr(fn . list('quotient,mktimes cdr x,
                             cadr quotargs) . rest))
        else if eqcar(cadr quotargs,'times)
                and car(x := formseparate(cdadr quotargs,car rest))
         then list('times,list('recip,mktimes car x),
                formlnr(fn . list('quotient,car quotargs,mktimes cdr x)
                         . rest))
        else if x := expt!-separate(car quotargs,car rest)
         then list('times,car x,formlnr(fn . list('quotient,cdr x,cadr
                                                     quotargs) . rest))
        else if x := expt!-separate(cadr quotargs,car rest)
         then list('times,list('recip,car x),
                   formlnr(fn . list('quotient,car quotargs,cdr x)
                              . rest))
        else if (x := reval!* cadr quotargs) neq cadr quotargs
         then formlnquot(fn,list(car quotargs,x),rest,whole)
        else whole
   end;

symbolic procedure formlnrecip(fn,reciparg,rest,whole);
   % FN is a linear operator, RECIPARG the RECIP argument, REST the
   % remaining arguments, WHOLE the whole expression.  Value is the
   % transformed expression.
   begin scalar x;
      return if not depends(reciparg,car rest)
         then list('quotient,fn . 1 . rest,reciparg)
        else if eqcar(reciparg,'minus)
         then list('minus,formlnr(fn . ('recip . cdr reciparg) . rest))
        else if eqcar(reciparg,'times)
                and car(x := formseparate(cdr reciparg,car rest))
         then list('times,list('recip,mktimes car x),
                formlnr(fn . list('recip,mktimes cdr x)
                         . rest))
        else if x := expt!-separate(reciparg,car rest)
         then list('times,list('recip,car x),
                   formlnr(fn . list('recip,cdr x)
                              . rest))
        else if (x := reval!* reciparg) neq reciparg
         then formlnrecip(fn,x,rest,whole)
        else whole
   end;

symbolic procedure mktimes u;
   if null cdr u then car u else 'times . u;

symbolic procedure reval!* u;
   %like REVAL, except INTSTR is always ON;
   begin scalar !*intstr;
      !*intstr := t;
      return reval u
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/part.red0000644000175000017500000001273011526203062022714 0ustar  giovannigiovannimodule part;  % Access and updates parts of an algebraic expression.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*intstr);

symbolic procedure revalpart u;
   begin scalar !*intstr,bool,expn,v,z;
      !*intstr := t;   % To make following result in output form.
      expn := if (z := getrtype car u) eq 'list then listeval0 car u
               else reval car u;
      !*intstr := nil;
      v := cdr u;
      while v do
         begin scalar x,y;
           if atom expn then <>
            else if not numberp(x := reval car v)
             then msgpri("Invalid argument",car v,"to part",nil,t)
            else if (y := get(car expn,'partop))
             then return <>
            else if x=0
              then return <>
                                else w) where w = car expn;
                           v := nil>>
            else if x<0 then <>
            else y := cdr expn;
           if bool then nil
            else if length y>
            else expn := (if (getrtype w eq 'list) and (z := 'list)
                            then listeval0 w
                           else if z eq 'list
                            then <>
                           else w) where w = nth(y,x);
           v := if bool then nil else cdr v
        end;
      return if bool then 0 else reval expn
   end;

symbolic procedure parterr2(u,v);
   <>;

put('part,'psopfn,'revalpart);

flag('(part),'immediate);

symbolic procedure revalsetpart u;
   % Simplifies a SETPART expression.
   begin scalar !*intstr,x,y;
      x := reverse cdr u;
      !*intstr := t;
      y := reval car u;
      !*intstr := nil;
      return  revalsetp1(y,reverse cdr x,reval car x)
   end;

symbolic procedure revalsetp1(expn,ptlist,rep);
   if null ptlist then rep
    else if atom expn then parterr(expn,car ptlist)
    else begin scalar x,y;
      if not numberp(x := reval car ptlist)
             then msgpri("Invalid argument",car ptlist,"to part",nil,t)
       else return
        if y := get(car expn,'setpartop) then apply3(y,expn,ptlist,rep)
         else if x=0 then rep . cdr expn
         else if x<0
          then car expn .
                reverse ssl(reverse cdr expn,
                            -x,cdr ptlist,rep,expn . car ptlist)
         else car expn . ssl(cdr expn,x,cdr ptlist,
                             rep,expn . car ptlist)
   end;

symbolic procedure ssl(expn,indx,ptlist,rep,rest);
   if null expn then parterr(car rest,cdr rest)
    else if indx=1 then revalsetp1(car expn,ptlist,rep) . cdr expn
    else car expn . ssl(cdr expn,indx-1,ptlist,rep,rest);

put('part,'rtypefn,'rtypepart);

symbolic procedure rtypepart u;
   if getrtypecar u then 'yetunknowntype else nil;

% symbolic procedure rtypepart(u);
%   if null cdr u then getrtypecar u
%    else begin scalar x,n;
%       x := car u;
%       if idp x then <>;
%       if eqcar(x,'list) and numberp (n := aeval cadr u)
%         then return rtypepart(nth(cdr x,n) . cddr u)
%    end;

% put('part,'setqfn,'(lambda (u v w) (setpart!* u v w)));

put('setpart!*,'psopfn,'revalsetpart);

symbolic procedure arglength u;
   begin scalar !*intstr,x;
      if null u then return 0;
      !*intstr := t;
      x := reval u;
      return if atom x then -1 else length cdr x
   end;

flag('(arglength),'opfn);

flag('(arglength),'noval);

put('partlength,'psopfn,'partlengthreval);

symbolic procedure partlengthreval u;
   (if atom expn then 0 else length cdr expn)
      where expn = (if getrtype car u eq 'list then listeval0 car u
                     else reval car u) where !*intstr = t;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/alg.rlg0000644000175000017500000003533611527635055022546 0ustar  giovannigiovanniFri Feb 18 21:27:12 2011 run on win32
Comment This is a standard test file for REDUCE that has been used for
many years.  It only tests a limited number of facilities in the
current system.  In particular, it does not test floating point
arithmetic, or any of the more advanced packages that have been made
available since REDUCE 3.0 was released.  It does however test more
than just the alg package in which it is now stored.  It has been used
for a long time to benchmark the performance of REDUCE.  A description
of this benchmarking with statistics for REDUCE 3.2 was reported in Jed
B. Marti and Anthony C. Hearn, "REDUCE as a Lisp Benchmark", SIGSAM
Bull. 19 (1985) 8-16.  That paper also gives information on the the
parts of the system exercised by the test file.  Updated statistics may
be found in the "timings" file in the REDUCE Network Library;


showtime;


Time: 0 ms


comment some examples of the FOR statement;


comment summing the squares of the even positive integers
        through 50;


for i:=2 step 2 until 50 sum i**2;


22100


comment to set  w  to the factorial of 10;


w := for i:=1:10 product i;


w := 3628800


comment alternatively, we could set the elements a(i) of the
        array  a  to the factorial of i by the statements;


array a(10);



a(0):=1$



for i:=1:10 do a(i):=i*a(i-1);



comment the above version of the FOR statement does not return
        an algebraic value, but we can now use these array
        elements as factorials in expressions, e. g.;


1+a(5);


121


comment we could have printed the values of each a(i)
        as they were computed by writing the FOR statement as;


for i:=1:10 do write a(i):= i*a(i-1);


a(1) := 1

a(2) := 2

a(3) := 6

a(4) := 24

a(5) := 120

a(6) := 720

a(7) := 5040

a(8) := 40320

a(9) := 362880

a(10) := 3628800


comment another way to use factorials would be to introduce an
operator FAC by an integer procedure as follows;


integer procedure fac (n);
   begin integer m;
        m:=1;
    l1: if n=0 then return m;
        m:=m*n;
        n:=n-1;
        go to l1
   end;


fac


comment we can now use  fac  as an operator in expressions, e. g.;


z**2+fac(4)-2*fac 2*y;


          2
 - 4*y + z  + 24


comment note in the above example that the parentheses around
the arguments of FAC may be omitted since it is a unary operator;


comment the following examples illustrate the solution of some
        complete problems;


comment the f and g series (ref  Sconzo, P., Leschack, A. R. and
         Tobey, R. G., Astronomical Journal, Vol 70 (May 1965);


deps:= -sigma*(mu+2*epsilon)$


dmu:= -3*mu*sigma$


dsig:= epsilon-2*sigma**2$


f1:= 1$


g1:= 0$


 
for i:= 1:8 do 
 <b;

symbolic procedure ilessp(a,b); a) igreaterp);
newtok '((!# !<) ilessp);
newtok '((!# !=) iequal);

infix #+,#-,#*,#/,#>,#<,#=;

precedence #+,+;
precedence #-,-;
precedence #*,*;
precedence #/,/;
precedence #>,>;
precedence #<,<;
precedence #=,=;

deflist('((idifference iminus)),'unary);

deflist('((iminus iminus)),'unary);

deflist('((iminus iplus2)), 'alt);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/sub.red0000644000175000017500000003114011526203062022533 0ustar  giovannigiovannimodule sub; % Functions for substituting in standard forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*nosqrts asymplis!* dmode!* errmsg!* ncmp!* sublist!* wtl!*);

% Evaluation interface.

symbolic procedure subeval u;
   % This baroque definition is needed to handle an infinite loop in
   % expressions like
   % sub(x = root_of(2log(sqrt(y^2 + 1) + 1) + 2log(sqrt(y^2 + 1) - 1)
   %                - 2log(sqrt(y^2 + 1) + 1)*a - a^2 + 4y^2 + 4,y,tag),
   %     2sqrt(x^2 + 1));
   % arising from the rule for root_of in solve/solve1.red.
   begin scalar sublist!*,x;
      put('sub,'psopfn,'subeval0);
      x := errorset2{'subeval0,mkquote u};
      put('sub,'psopfn,'subeval);
      if errorp x
        then if errmsg!* then rederr errmsg!* else rederr 'sub;
      return car x
   end;

symbolic procedure subeval0 u;
   % This is the general evaluator for SUB forms.  All but the last
   % argument are assumed to be substitutions.  These can either be
   % an explicit rule with a lhs and rhs separated by an equal sign,
   % a list of such rules, or something that evaluates to this.
   begin scalar x,y,z,ns;
   % Check for spurious substitutions.
   while cdr u do <>;
   if null x then return car u else u := nconc(reversip x,u);
   % Separate assignments from expression.
      if u member sublist!* then return mk!*sq !*p2q mksp('sub . u,1)
       else sublist!* := u . sublist!*;
      if null(u and cdr u)
       then rederr "SUB requires at least 2 arguments"; % F.J. Wright.
      (while cdr u do
          <>>>) where !*evallhseqp=nil;
      x := aeval car u;
%     Next line only makes sense if an nssubfn existed (which it
%     currently doesn't.  However, subeval2 suffers from the problem
%     that its evaluation is sequential.
%     if ns then x := subeval2(ns,x);
      return subeval1(append(ns,z),x)
   end;

symbolic procedure subeval1(u,v);
   begin scalar y,z;
      while u and caar u = cdar u do u := cdr u;
      if null u then return v
       else if y := getrtype v
        then if z := get(y,'subfn) then return apply2(z,u,v)
              else rerror(alg,23,
                            list("No substitution defined for type",y));
        u := subsq(simp v,u);
        u := subs2 u where !*sub2 = t;   % Make sure powers are reduced.
        return mk!*sq u
   end;

% symbolic procedure subeval2(u,v);
   % This function handles sub rules that have a non *sq rhs.
   % The corresponding substitution functions are keyed by the
   % rtype in an alist stored as a property nssubfn on the rtype
   % of the expression in which the substitutions are to be carried out.
   % Substitutions are made sequentially.
%   begin scalar x,y,z;
%     for each s in u do
%       <>;
%%         else rerror(alg,23,
%%            {"No substitution defined for type",y," into type ",x})>>;
%     return v
%   end;

put('sub,'psopfn,'subeval);


% Explicit substitution code for scalar expressions.

symbolic procedure subsq(u,v);
   % We need to use subs2!* to avoid say (I^4-2I^2-1)/(I^2-1) => I^2-1
   % instead of a 0/0 error.
      begin scalar x;
      x := subf(numr u,v);
      u := subf(denr u,v);
      if null numr subs2!* u
       then if null numr subs2!* x then rederr "0/0 formed"
             else rederr "Zero divisor";
      return quotsq(x,u)
   end;

symbolic procedure subs2!* u;
   (subs2 u) where !*sub2=!*sub2;

symbolic procedure subf(u,l);
   % In REDUCE 3.4, this procedure used to rebind *nosqrts to T.
   % However, this can introduce two representations of a sqrt in the
   % same calculation.  For now then, this rebinding is removed.
   begin scalar alglist!*,x,y,z;
   % Domain may have changed, so next line uses simpatom.
      if domainp u then return !*d2q u
       else if ncmp!* and noncomexpf u then return subf1(u,l);
      x := reverse intersection(for each y in l collect car y,
                                kernord(u,nil));
      x := setkorder x;
      u := subf1(reorder u,l);
%     if powlis1!* then u := subs2q u;
      % The subf code does not combine expts completely, e.g.,
      % sub(ll=2l,df(1/(1+exp(-z/(2l))),z) - df(1/(1+exp(-z/(ll))),z));
      while not(u member z)
        and (atsoc('expt,kernels numr u) or atsoc('expt,kernels denr u))
        and not((y := prepsq u) member varstack!*)
         do <>;
      setkorder x;
      return reorder numr u ./ reorder denr u
   end;

symbolic procedure noncomexpf u;
   not domainp u
      and (noncomp mvar u or noncomexpf lc u or noncomexpf red u);

%%% SUBF1 changed so that domain elements are resimplified during a call
%%%       to RESIMP even if their tags are the same as dmode*.
%%%       This happens only if the domain is flagged

symbolic procedure subf1(u,l);
   % U is a standard form,
   % L an association list of substitutions of the form
   % ( . ).
   % Value is the standard quotient for substituted expression.
   % Algorithm used is essentially the straight method.
   % Procedure depends on explicit data structure for standard form.
   if null u then nil ./ 1
    else if domainp u
     then if atom u then if null dmode!* then u ./ 1 else simpatom u
%          else if dmode!* eq car u then !*d2q u
          else if dmode!* eq car u and
                  not flagp(dmode!*, 'resimplify) then !*d2q u
          else simp prepf u
    else begin integer n; scalar kern,l1,m,varstack!*,v,w,x,xexp,y,y1,z;
        % Leaving varstack!* unchanged can make the simplifier think
        % there is a loop.
        z := nil ./ 1;
    a0: kern := mvar u;
        v := nil;
        if assoc(kern,l) and (v := assoc(kern,wtl!*)) then v := cdr v;
        if m := assoc(kern,asymplis!*) then m := cdr m;
    a:  if null u or (n := degr(u,kern))=0 then go to b
         else if null m or n>;
        l := reversip l1;
        if not atom kern and not atom car kern then kern := prepf kern;
        if null l then xexp := if kern eq 'k!* then 1 else kern
         else if (xexp := subsublis(l,kern)) = kern
                   and not assoc(kern,asymplis!*)
          then go to f;
    c:  w := 1 ./ 1;
        n := 0;
        % Make sure exponent is not a variable at this point.
        if y and minusp cdaar y then go to h;
        if (x := getrtype xexp) eq 'yetunknowntype
          then x:= getrtype(xexp:= eval!-yetunknowntypeexpr(xexp,nil));
        if x and not(x eq 'list)
         then typerr(list(x,xexp),"substituted expression");
        % At this point we are simplifying the expression that is
        % substituted.  Ideally, this should be done in the order
        % environment that existed when entering SUB.  However, to avoid
        % the many code changes that would imply, we make sure
        % substituted expression is evaluated in a standard order.
        % Note also that SIMP!* here causes problem with HE package --
        % We also can't use powlis1!* here, since then match x=0,x^2=1;
        % will match all powers of x to zero!
        v := setkorder nil;
        x := simp xexp;
        setkorder v;
        x := reordsq x;
        % Needed in case substitution variable is in XEXP.
        if null l and kernp x and mvar numr x eq kern then go to f
         else if null numr x then go to e;   %Substitution of 0;
        for each j in y do
         <>;
    e:  y := nil;
        if null u then return z
         else if domainp u then return addsq(subf1(u,l),z);
        go to a0;
    f:  sub2chk kern;
        for each j in y do z := addsq(multpq(car j,subf1(cdr j,l)),z);
        go to e;
    h:  % Substitution for negative powers.
        x := simprecip list xexp;
    j:  y1 := car y . y1;
        y := cdr y;
        if y and cdaar y<0 then go to j;
    k:  m := -cdaar y1;
        w := multsq(subs2 exptsq(x,m-n),w);
        n := m;
        z := addsq(multsq(w,subf1(cdar y1,l)),z);
        y1 := cdr y1;
        if y1 then go to k else if y then go to c else go to e
     end;

symbolic procedure wtchk(u,wt);
   % If a weighted variable is substituted for, we need to remove the
   % weight of that variable in an expression.
   if null wt then u
    else (if null x then errach list("weight confusion",u,wt)
           else lt x)
         where x=quotf(u .+ nil ,!*p2f('k!* .**(wt*tdeg u)));

symbolic procedure subsublis(u,v);
   % NOTE: This definition assumes that with the exception of *SQ and
   % domain elements, expressions do not contain dotted pairs.
   begin scalar x;
      x := if x := assoc(v,u) then cdr x
              % allow for case of sub(sqrt 2=s2,atan sqrt 2).
              else if eqcar(v,'sqrt)
                 and (x := assoc(list('expt,cadr v,'(quotient 1 2)),u))
               then cdr x
              else if atom v then v
              else if not idp car v
               then for each j in v collect subsublis(u,j)
              else if x := get(car v,'subfunc) then apply2(x,u,v)
              else if get(car v,'dname) then v
              else if car v eq '!*sq then subsublis(u,prepsq cadr v)
              else for each j in v collect subsublis(u,j);
      % Could there be other cases here apart from equal?
      % This code does not seem to be necessary with current
      % subeval0 checks.
%     return if eqcar(x,'equal) then x else prepsq!* simp x
      return x
   end;

symbolic procedure subsubf(l,expn);
   % Sets up a formal SUB expression when necessary.
   begin scalar x,y;
      % This code does not seem to be necessary with current
      % subeval0 checks.
%     for each j in l do if car j neq (y := prepsq!* simp!* cdr j)
%                          then x := (car j . y) . x;
%     l := reversip x;
%     if null l then return expn;
%     y := nil;
      for each j in cddr expn do
         if (x := assoc(j,l)) then <>;
      expn := sublis(l,car expn)
                 . for each j in cdr expn collect subsublis(l,j);
        %to ensure only opr and individual args are transformed;
      if null y then return expn;
      expn := aconc!*(for each j in reversip!* y
                     collect list('equal,car j,aeval cdr j),expn);
      return if l then subeval expn
              else mk!*sq !*p2q mksp('sub . expn,1)
   end;


% Explicit substitution code for lists.

symbolic procedure listsub(u,v);
   makelist for each x in cdr v collect subeval1(u,x);

put('list,'subfn,'listsub);

put('int,'subfunc,'subsubf);

put('df,'subfunc,'subsubf);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/algbool.red0000644000175000017500000000605611526203062023371 0ustar  giovannigiovannimodule algbool; % Evaluation functions for algebraic boolean operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure evalequal(u,v);
   begin scalar x;
      return if (x := getrtype u) neq getrtype v then nil
              else if null x
               then numberp(x := reval list('difference,u,v))
                       and zerop x
              else u=v
   end;

put('equal,'boolfn,'evalequal);

% symbolic procedure equalreval u; 'equal . revlis u;  % defined in eqn.

% put('equal,'psopfn,'equalreval);

put('equal,'rtypefn,'quoteequation);

symbolic procedure quoteequation u; 'equation;

symbolic procedure evalgreaterp(u,v);
   (lambda x;
    if not atom denr x or not domainp numr x
      then typerr(mk!*sq if minusf numr x then negsq x else x,"number")
     else numr x and !:minusp numr x)
        simp!* list('difference,v,u);

put('greaterp,'boolfn,'evalgreaterp);

symbolic procedure evalgeq(u,v); not evallessp(u,v);

put('geq,'boolfn,'evalgeq);

symbolic procedure evallessp(u,v); evalgreaterp(v,u);

put('lessp,'boolfn,'evallessp);

symbolic procedure evalleq(u,v); not evalgreaterp(u,v);

put('leq,'boolfn,'evalleq);

symbolic procedure evalneq(u,v); not evalequal(u,v);

put('neq,'boolfn,'evalneq);

symbolic procedure evalnumberp u;
   (if atom x then numberp x
     else if not(car x eq '!*sq) or not atom denr cadr x then nil
     else (atom y or flagp(car y,'numbertag)) where y=numr cadr x)
    where x=aeval u;

put('numberp,'boolfn,'evalnumberp);

% Number tags.

flag('(!:rd!: !:cr!: !:rn!: !:crn!: !:mod!: !:gi!:),'numbertag);

symbolic procedure ratnump x;
   % Returns T iff any prefix expression x is a rational number.
   atom numr(x := simp!* x) and atom denr x;

flag ('(ratnump), 'boolean);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/genmod.red0000644000175000017500000001620711526203062023222 0ustar  giovannigiovannimodule genmod; % Modular arithmetic where the modulus may be any size.

% Authors: A. C. Norman and P. M. A. Moore, 1981.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: John Abbott.

% Note: when balanced_mod is on, the results here are not always in
% range. *modular2f is used to correct this. However, these routines
% should be updated to give balanced results.

fluid '(!*balanced_mod current!-modulus modulus!/2);

global '(largest!-small!-modulus);

symbolic procedure set!-general!-modulus p;
  if not numberp p or p=0 then current!-modulus
   else begin
     scalar previous!-modulus;
     previous!-modulus:=current!-modulus;
     current!-modulus:=p;
     modulus!/2 := p/2;
     % Allow for use of small moduli where appropriate.
     if p <= largest!-small!-modulus then set!-small!-modulus p;
     return previous!-modulus
  end;

symbolic procedure general!-modular!-plus(a,b);
  begin scalar result;
     result:=a+b;
     if result >= current!-modulus then result:=result-current!-modulus;
     return result
  end;

symbolic procedure general!-modular!-difference(a,b);
  begin scalar result;
     result := a - b;
     if result < 0 then result:=result+current!-modulus;
     return result
  end;

symbolic procedure general!-modular!-number a;
  begin
     a:=remainder(a,current!-modulus);
     if a < 0 then a:=a+current!-modulus;
     return a
  end;

symbolic procedure general!-modular!-times(a,b);
  begin scalar result;
     result:=remainder(a*b,current!-modulus);
     if result<0
       then result := result+current!-modulus;  %can this happen?
     return result
  end;

symbolic procedure general!-modular!-reciprocal a;
   % Note this returns a positive result.
   if !*balanced_mod and a<0
     then general!-reciprocal!-by!-gcd(current!-modulus,
                                       a + current!-modulus,0,1)
    else general!-reciprocal!-by!-gcd(current!-modulus,a,0,1);

symbolic procedure general!-modular!-quotient(a,b);
    general!-modular!-times(a,general!-modular!-reciprocal b);

symbolic procedure general!-modular!-minus a;
    if a=0 then a else current!-modulus - a;

symbolic procedure general!-reciprocal!-by!-gcd(a,b,x,y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B;
   if b=0 then rerror(alg,8,"Invalid modular division")
   else if b=1 then if y < 0 then y+current!-modulus else y
   else begin scalar w;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     w:=quotient(a,b); %Truncated integer division;
     return general!-reciprocal!-by!-gcd(b,a-b*w,y,x-y*w)
   end;

% The next two functions compute the "reverse" of a binary number.
% This is the number obtained when writing down the binary expansion
% in reverse order.  If 2^r divides n (but 2^(r+1) does not) then
% reverse-num(reverse-num(n)) = abs(n)/2^r. r can be computed using
% height2.

symbolic procedure reverse!-num(n);
   if n = 0 then n
    else if n<0 then -reverse!-num1(-n,ilog2(-n)+1)
    else reverse!-num1(n,ilog2(n)+1);

global '(reverse!-num!-table!*);

reverse!-num!-table!* := mkvect 16;
putv(reverse!-num!-table!*,1,8);
putv(reverse!-num!-table!*,2,4);
putv(reverse!-num!-table!*,3,12);
putv(reverse!-num!-table!*,4,2);
putv(reverse!-num!-table!*,5,10);
putv(reverse!-num!-table!*,6,6);
putv(reverse!-num!-table!*,7,14);
putv(reverse!-num!-table!*,8,1);
putv(reverse!-num!-table!*,9,9);
putv(reverse!-num!-table!*,10,5);
putv(reverse!-num!-table!*,11,13);
putv(reverse!-num!-table!*,12,3);
putv(reverse!-num!-table!*,13,11);
putv(reverse!-num!-table!*,14,7);
putv(reverse!-num!-table!*,15,15);

symbolic procedure reverse!-num1(n,bits);
   if n = 0 then 0
    else if bits = 1 then n
    else if bits = 2 then getv(reverse!-num!-table!*,4*n)
    else if bits = 3 then getv(reverse!-num!-table!*,2*n)
    else if bits = 4 then getv(reverse!-num!-table!*,n)
    else begin scalar shift,qr;
       shift := 2**(bits/2);
       qr := divide(n,shift);
       if not evenp bits then shift := shift*2;
       return reverse!-num1(cdr qr,bits/2)*shift +
           reverse!-num1(car qr,(bits+1)/2)
   end;

% Interface to algebraic mode.

flag('(reverse!-num),'integer);

deflist('((reverse!-num rnreverse!-num!*)),'!:rn!:);

%put('fibonacci,'!:rn!:,'rnfibonacci!*);

put('reverse!-num,'number!-of!-args,1);

put('reverse!-num,'simpfn,'simpiden);

symbolic procedure rnreverse!-num!*(x);
   (if fixp y then reverse!-num(y)
    else !*p2f mksp(list('reverse!-num,y),1))
    where y=rnfixchk x;

% Interface to algebraic mode.

put('reverse!-num, 'simpfn, 'simpreverse!-num);

symbolic procedure simpreverse!-num(u);
   begin scalar arg;
      if length(u) neq 1 then typerr(u,"integer");
      arg := simpcar u;
      if denr(arg) neq 1 or not fixp(numr(arg))
        then rederr("reverse!-num: argument should be an integer");
      return reverse!-num(numr(arg)) ./ 1
   end;

% This is an iterative version of general!-modular!-expt.
% Its principal advantage over the (simpler) recursive implementation
% is that it avoids excessive memory consumption when both n and the
% modulus are quite large -- try primep(2^10007-1) if you don't believe
% it!

symbolic procedure general!-modular!-expt(a,n);
   % Computes a**n modulo current-modulus.  Uses Fermat's Little
   % Theorem where appropriate for a prime modulus.
    if a=0 then if n=0 then rerror(alg,101,"0^0 formed") else 0
    else if n=0 then 1
    else if n=1 then a
    else if n>=current!-modulus-1 and primep current!-modulus
     then general!-modular!-expt(a,remainder(n,current!-modulus-1))
    else begin scalar x, revn;
      while evenp n do <>;
      revn := reverse!-num n;
      x := 1;
      while revn>0 do
      <>;
      return x
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/numsup.red0000644000175000017500000000360011526203062023271 0ustar  giovannigiovannimodule numsup;   % Numerical support for basic algebra package.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%  Numerical greatest common divisor.

symbolic procedure gcdn(u,v);
%  U and v are integers. Value is absolute value of gcd of u and v.
   if v = 0 then abs u else gcdn(v,remainder(u,v));


% Interface to rounded code.

% Only needed if package ARITH is autoloaded.

% switch rounded;

% put('rounded,'package!-name,'arith);

% put('rounded,'simpfg,
%             '((t (load!-package 'arith) (setdmode 'rounded t))));
    % Enough for now.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/alg.red0000644000175000017500000000413311526203062022507 0ustar  giovannigiovannimodule alg;  % Header module for alg package.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(alg alg!-form intro general farith numsup genmod
                  random smallmod zfactor sort reval algbool simp
                  exptchk simplog logsort sub order forall eqn rmsubs
                  algdcl opmtch prep extout depend str coeff weight
                  linop elem showrule nestrad maxmin nssimp part map),
                nil);

flag('(alg),'core_package);

put('alglist!*,'initvalue!*,'(cons nil nil));

% Some renamings so that no user operations in algebraic mode need an
% asterisk.

deflist('((eval_mode !*mode)
          (cardno!* card_no)
          (fortwidth!* fort_width)
          (high_pow hipow!*)
          (low_pow lowpow!*)
          (root_multiplicities multiplicities!*)),
        'newnam);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/nestrad.red0000644000175000017500000000620511526203062023406 0ustar  giovannigiovannimodule nestrad; % Simplify nested square roots.

% Author: H. Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: A. C. Hearn:

% The case sqrt(x+8-6*sqrt(x-1)) gave the wrong sign for say x=5.
% However, adding an abs call messed up int(1/(x**4+4*x**2+1),x).
% So for the time being, we only use this code when the argument can
% be shown to be a non-negative number.

fluid '(!*intflag!*);

symbolic procedure unnest!-sqrt!-sqrt!*(a0,b0,r0);
  % look for a simplified equivalent to sqrt(a + b*sqrt(c));
  % See: Borodin et al, JSC (1985) 1,p 169ff.
  begin scalar d,a,b,r,s,w;
   if numberp r and r<0 then return nil;
   a:=simp a0; b:=simp b0; r:=simp r0;
     % discriminant: d:=sqrt(a^2-b^2*r).
   d:=subtrsq(multsq(a,a),multsq(multsq(b,b),r));
   if denr d neq 1 or (not domainp(d:=numr d) and not evenp ldeg d)
      or cdr(d:=radf(d,2)) then return nil;
   d := car d ./ 1;
    % s := 2(a+d).
   s:=addsq(a,d); s:=addsq(s,s); s:=prepsq s;
    % w:=(s+2 b sqrt r)/2 sqrt s.
   w:={'quotient,{'times,{'sqrt,s},{'plus,s,{'times,2,b0,{'sqrt,r0}}}},
                 {'times,2,s}};
   return w;
 end;

symbolic procedure unnest!-sqrt!-sqrt(a,b,r);
  begin scalar w;
     return if (w:=unnest!-sqrt!-sqrt!*(a,b,r)) then chkabs w
             else if (w:=unnest!-sqrt!-sqrt!*({'times,b,r},a,r))
              then chkabs {'quotient,w,{'expt,r,{'quotient,1,4}}}
             else nil
  end;

symbolic procedure chkabs u;
   if !*intflag!* then u      % The integrator doesn't care about sign.
%   else (if null x then {'abs,u}
    else (if null x then u
           else if not minusp!: x then u
           else {'minus,u})
         where x = not_imag_num u;

symbolic operator unnest!-sqrt!-sqrt;

algebraic;

sqrtsqrt_rules := {
(~a + ~b * ~c^(1/2)) ^(1/2) => !*!*w
   when (!*!*w:=unnest!-sqrt!-sqrt(a,b,c)),
(~a + ~c^(1/2)) ^(1/2) => !*!*w
   when (!*!*w:=unnest!-sqrt!-sqrt(a,1,c))}$

let sqrtsqrt_rules;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/gcdchk.red0000644000175000017500000001673311526203062023200 0ustar  giovannigiovanniMODULE GCDCHK;   % Check for a unit gcd using modular arithmetic.

% Author: Arthur C. Norman and Mary Ann Moore.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn.

FLUID '(!*BACKTRACE LIST!-OF!-LARGE!-PRIMES MODULAR!-VALUES);

% LIST!-OF!-LARGE!-PRIMES is a list of the largest pair of adjacent
% primes that can fit in the inum range of the implementation.
% This should be set here in an implementation dependent manner.
% For the time begin, a maximum inum value of 2^23 is assumed.

LIST!-OF!-LARGE!-PRIMES := '(8388449 8388451);

SYMBOLIC PROCEDURE MONIC!-MOD!-P A;
   IF NULL A THEN NIL
    ELSE IF DOMAINP A THEN 1
    ELSE IF LC A = 1 THEN A
    ELSE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,MODULAR!-RECIPROCAL LC A);

SMACRO PROCEDURE BEFORE!-IN!-ORDER(A,B);
%Predicate taking the value true if the polynomial
%a has a leading term which comes strictly before that
%of b in canonical order;
   NULL DOMAINP A AND (DOMAINP B OR LDEG A>LDEG B);

SYMBOLIC PROCEDURE UNI!-PLUS!-MOD!-P(A,B);
% Form the sum of the two univariate polynomials a and b
% working over the ground domain defined by the routines
% modular!-plus, modular!-times etc. The inputs to this
% routine are assumed to have coefficients already
% in the required domain;
  IF NULL A THEN B
   ELSE IF NULL B THEN A
   ELSE IF BEFORE!-IN!-ORDER(A,B)
    THEN (LT A) .+ UNI!-PLUS!-MOD!-P(RED A,B)
   ELSE IF BEFORE!-IN!-ORDER(B,A)
    THEN (LT B) .+ UNI!-PLUS!-MOD!-P(A,RED B)
   ELSE IF DOMAINP A
    THEN <>
   ELSE BEGIN SCALAR W;
      W:=UNI!-PLUS!-MOD!-P(RED A,RED B);
      B:=MODULAR!-PLUS(LC A,LC B);
      IF B=0 THEN RETURN W;
      RETURN (LPOW A .* B) .+ W
   END;

%symbolic procedure uni!-times!-mod!-p(a,b);
%   if (null a) or (null b) then nil
%   else if domainp a then multiply!-by!-constant!-mod!-p(b,a)
%   else if domainp b then multiply!-by!-constant!-mod!-p(a,b)
%   else uni!-plus!-mod!-p(
%         uni!-plus!-mod!-p(uni!-times!-mod!-p(red a,red b),
%                                 uni!-times!-term!-mod!-p(lt a,b)),
%                    uni!-times!-term!-mod!-p(lt b,red a));

SYMBOLIC PROCEDURE UNI!-TIMES!-TERM!-MOD!-P(TERM,B);
%Multiply the given polynomial by the given term;
    IF NULL B THEN NIL
    ELSE IF DOMAINP B THEN <<
       B:=MODULAR!-TIMES(TC TERM,B);
       IF B=0 THEN NIL
       ELSE (TPOW TERM .* B) .+ NIL >>
    ELSE BEGIN SCALAR W;
        W:=MODULAR!-TIMES(TC TERM,LC B);
        IF W=0 THEN RETURN UNI!-TIMES!-TERM!-MOD!-P(TERM,RED B);
        W:= (TVAR TERM TO (TDEG TERM+LDEG B)) .* W;
        RETURN W .+ UNI!-TIMES!-TERM!-MOD!-P(TERM,RED B)
    END;

SYMBOLIC PROCEDURE UNI!-REMAINDER!-MOD!-P(A,B);
% Remainder when a is divided by b;
    IF NULL B THEN REDERR "B=0 IN REMAINDER-MOD-P"
    ELSE IF DOMAINP B THEN NIL
    ELSE XUNI!-REMAINDER!-MOD!-P(A,B);

SYMBOLIC PROCEDURE XUNI!-REMAINDER!-MOD!-P(A,B);
% Remainder when the univariate modular polynomial a is
% divided by b, given that b is non degenerate;
   IF DOMAINP A OR LDEG A < LDEG B THEN A
   ELSE BEGIN
    SCALAR Q,W;
    Q:=MODULAR!-QUOTIENT(MODULAR!-MINUS LC A,LC B);
% compute -lc of quotient;
    W:= LDEG A - LDEG B; %ldeg of quotient;
    IF W=0 THEN A:=UNI!-PLUS!-MOD!-P(RED A,
      MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED B,Q))
    ELSE
      A:=UNI!-PLUS!-MOD!-P(RED A,UNI!-TIMES!-TERM!-MOD!-P(
            (MVAR B TO W) .* Q,RED B));
% the above lines of code use red a and red b because
% by construction the leading terms of the required
% answers will cancel out;
     RETURN XUNI!-REMAINDER!-MOD!-P(A,B)
   END;

SYMBOLIC PROCEDURE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,N);
% Multiply the polynomial a by the constant n
% assumes that a is univariate, and that n is coprime with
% the current modulus so that modular!-times(xxx,n) neq 0
% for all xxx;
   IF NULL A THEN NIL
   ELSE IF N=1 THEN A
   ELSE IF DOMAINP A THEN MODULAR!-TIMES(A,N)
   ELSE (LPOW A .* MODULAR!-TIMES(LC A,N)) .+
     MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED A,N);

SYMBOLIC PROCEDURE UNI!-GCD!-MOD!-P(A,B);
%Return the monic gcd of the two modular univariate
%polynomials a and b;
    IF NULL A THEN MONIC!-MOD!-P B
    ELSE IF NULL B THEN MONIC!-MOD!-P A
    ELSE IF DOMAINP A THEN 1
    ELSE IF DOMAINP B THEN 1
    ELSE IF LDEG A > LDEG B THEN
      ORDERED!-UNI!-GCD!-MOD!-P(A,B)
    ELSE ORDERED!-UNI!-GCD!-MOD!-P(B,A);

SYMBOLIC PROCEDURE ORDERED!-UNI!-GCD!-MOD!-P(A,B);
% As above, but degr a > degr b;
   IF NULL B THEN MONIC!-MOD!-P A
   ELSE ORDERED!-UNI!-GCD!-MOD!-P(B,UNI!-REMAINDER!-MOD!-P(A,B));

SYMBOLIC MACRO PROCEDURE MYERR U;
   LIST('ERRORSET,
        'LIST .
           MKQUOTE CAADR U .
              FOR EACH J IN CDADR U COLLECT LIST('MKQUOTE,J),
        T,'!*BACKTRACE);

SYMBOLIC PROCEDURE MODULAR!-MULTICHECK(U,V,VAR);
   IF ERRORP (U := MYERR MODULAR!-MULTICHECK1(U,V,VAR)) THEN NIL
    ELSE CAR U;

SYMBOLIC PROCEDURE MODULAR!-MULTICHECK1(U,V,VAR);
% TRUE if a modular check tells me that U and V are coprime;
  BEGIN
    SCALAR OLDP,P,MODULAR!-VALUES,UMODP,VMODP;
    P:=LIST!-OF!-LARGE!-PRIMES;
    OLDP:=SETMOD NIL;
TRY!-NEXT!-PRIME:
    MODULAR!-VALUES:=NIL;
    IF NULL P THEN GOTO UNCERTAIN;
    SETMOD CAR P;
    P:=CDR P;
    IF NULL MODULAR!-IMAGE(LC U,VAR) OR NULL MODULAR!-IMAGE(LC V,VAR)
      THEN GO TO TRY!-NEXT!-PRIME;
    UMODP:=MODULAR!-IMAGE(U,VAR);
    VMODP:=MODULAR!-IMAGE(V,VAR);
    P := DOMAINP UNI!-GCD!-MOD!-P(UMODP,VMODP);
UNCERTAIN:
    SETMOD OLDP;
    RETURN P
  END;

SYMBOLIC PROCEDURE MODULAR!-IMAGE(P,VAR);
    IF DOMAINP P
      THEN IF NULL P THEN NIL
            ELSE IF NOT ATOM P THEN ERROR1()
            ELSE <
    >
    ELSE BEGIN
      SCALAR V,X,W;
      V:=MVAR P;
      IF V=VAR THEN <<
          X:=MODULAR!-IMAGE(LC P,VAR);
          IF NULL X THEN RETURN MODULAR!-IMAGE(RED P,VAR)
          ELSE RETURN (LPOW P .* X) .+ MODULAR!-IMAGE(RED P,VAR) >>;
      X:=ATSOC(V,MODULAR!-VALUES);
      IF NULL X THEN <<
          X:=MODULAR!-NUMBER RANDOM CAR LIST!-OF!-LARGE!-PRIMES;
          MODULAR!-VALUES:=(V . X) . MODULAR!-VALUES >>
      ELSE X:=CDR X;
      X:=MODULAR!-EXPT(X,LDEG P);
      W:=MODULAR!-IMAGE(RED P,VAR);
      V:=MODULAR!-IMAGE(LC P,VAR);
      IF NULL V THEN X:=NIL
      ELSE X:=MODULAR!-TIMES(V,X);
      IF W THEN X:=MODULAR!-PLUS(X,W);
      RETURN IF X=0 THEN NIL ELSE X
    END;

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/eqn.red0000644000175000017500000001206511526203062022532 0ustar  giovannigiovannimodule eqn;   % Support for equations as top level structures.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% At the moment "EQUAL" is the tag for such structures.

% Evalequal is defined in alg/algbool.

fluid '(!*evallhseqp);

switch evallhseqp;

!*evallhseqp := t;   % Default is currently on.

symbolic procedure equalreval u;
   % This definition really needs to know whether we are trying
   % to produce a tagged standard quotient or a prefix form.
   % It would also be more efficient to leave a *SQ form unchanged
   % on the right hand side as shown.  However, it messes up printing.
  (if !*evallhseqp or not atom car u and flagp(caar u,'immediate)
     then list('equal,reval car u,x)
    else list('equal,car u,x))
   where x= reval y % (if eqcar(y,'!*sq) then aeval y else reval y)
             where y=cadr u;

put('equal,'psopfn,'equalreval);

put('equal,'rtypefn,'quoteequation);

put('equal,'i2d,'eqnerr);

symbolic procedure eqnerr u; typerr(u,"equation");

put('equation,'evfn,'evaleqn);

% symbolic procedure evaleqn(u,v);
%    begin scalar op,x;
%       if null cdr u or not eqcar(cadr u,'equal)
%         then rerror(alg,26,"Invalid equation structure");
%      op := car u;
%       if null cddr u
%         then return 'equal . for each j in cdadr u
%          collect if op eq 'eqneval then reval1(j,v) else list(op,j)
%        else if eqcar(caddr u,'equal) or cdddr u
%         then rerror(alg,27,"Invalid equation structure");
%       x := caddr u;
%       return 'equal . for each j in cdadr u collect list(op,j,x)
%   end;

% put('eqneval,'rtypefn,'getrtypecar);

symbolic procedure evaleqn(u,v);
 % This function allows us to perform elementary equation arithmetic
 % combining one equation and scalars by  + - * / ^, and to compute
 % sums and differences of equations. Restriction: the equation must
 % be the leftmost term in the arithmetic expression.
  begin scalar e,l,r,w,op,x,found;
   if (x:=get(u,'avalue)) then u:=cadr x;
   if not !*evallhseqp then
   <>;
   op:=car u; w:=cdr u;
   if op='plus or op='difference or op='minus then
   <>
          else   <>;
     >>;
     r:=op.reverse r; l:=op.reverse l;
   >>
   else
   << u:=op . for each q in w collect reval q;
      e:=evaleqn1(u,u,nil);
      if e then
      <>;
   >>;
   if not found then rederr
      "failed to locate equal sign in equation processing";
   return {'equal, reval1(l,v), reval1(r,v)}
  end;

symbolic procedure evaleqn1(u,u0,e);
   if atom u then e
    else
   if car u='equal then
     (if e then typerr(u0,"equation expression") else u)
   else evaleqn1(cdr u,u0,evaleqn1(car u,u0,e));

% put(equal,'prifn,'equalpri);

% put('equal,'lengthfn,'eqnlength);

symbolic procedure lhs u;
   % Returns the left-hand-side of an equation.
   lhs!-rhs(u,'cadr);

symbolic procedure rhs u;
   % Returns the right-hand-side of an equation.
   lhs!-rhs(u,'caddr);

symbolic procedure lhs!-rhs(u,op);
 <>;

flag('(lhs rhs),'opfn);  % Make symbolic operators.


% Explicit substitution code for equations.

symbolic procedure eqnsub(u,v);
   if !*evallhseqp or not atom car u and flagp(caar u,'immediate)
     then 'equal . for each x in cdr v collect subeval1(u,x)
    else list('equal,cadr v,subeval1(u,caddr v));

put('equation,'subfn,'eqnsub);

put('equation,'lengthfn,'eqnlength);

symbolic procedure eqnlength u; length cdr u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/alg.tst0000644000175000017500000001502211526203062022546 0ustar  giovannigiovanniComment This is a standard test file for REDUCE that has been used for
many years.  It only tests a limited number of facilities in the
current system.  In particular, it does not test floating point
arithmetic, or any of the more advanced packages that have been made
available since REDUCE 3.0 was released.  It does however test more
than just the alg package in which it is now stored.  It has been used
for a long time to benchmark the performance of REDUCE.  A description
of this benchmarking with statistics for REDUCE 3.2 was reported in Jed
B. Marti and Anthony C. Hearn, "REDUCE as a Lisp Benchmark", SIGSAM
Bull. 19 (1985) 8-16.  That paper also gives information on the the
parts of the system exercised by the test file.  Updated statistics may
be found in the "timings" file in the REDUCE Network Library;

showtime;

comment some examples of the FOR statement;

comment summing the squares of the even positive integers
        through 50;

for i:=2 step 2 until 50 sum i**2;

comment to set  w  to the factorial of 10;

w := for i:=1:10 product i;

comment alternatively, we could set the elements a(i) of the
        array  a  to the factorial of i by the statements;

array a(10);

a(0):=1$

for i:=1:10 do a(i):=i*a(i-1);

comment the above version of the FOR statement does not return
        an algebraic value, but we can now use these array
        elements as factorials in expressions, e. g.;

1+a(5);

comment we could have printed the values of each a(i)
        as they were computed by writing the FOR statement as;

for i:=1:10 do write a(i):= i*a(i-1);

comment another way to use factorials would be to introduce an
operator FAC by an integer procedure as follows;

integer procedure fac (n);
   begin integer m;
        m:=1;
    l1: if n=0 then return m;
        m:=m*n;
        n:=n-1;
        go to l1
   end;

comment we can now use  fac  as an operator in expressions, e. g.;

z**2+fac(4)-2*fac 2*y;

comment note in the above example that the parentheses around
the arguments of FAC may be omitted since it is a unary operator;

comment the following examples illustrate the solution of some
        complete problems;

comment the f and g series (ref  Sconzo, P., Leschack, A. R. and
         Tobey, R. G., Astronomical Journal, Vol 70 (May 1965);

deps:= -sigma*(mu+2*epsilon)$
dmu:= -3*mu*sigma$
dsig:= epsilon-2*sigma**2$
f1:= 1$
g1:= 0$
 
for i:= 1:8 do 
 <>;
       if n neq 1 and p*p>n
         then <>>>;
       return if n=1 then factor!-list
               else if null bool then (n . 1) . factor!-list
               else mcfactor!*(n,factor!-list)
     end;

symbolic procedure mcfactor!*(n,factors!-so!-far);
   if internal!-primep n then add!-factor(n,factors!-so!-far)
    else <>;
         if tries>!*maxtrys!* then <<
            prin2 "ZFACTOR(mcfactor!*): Assuming ";
            prin2 n; prin2t " is prime";
            p:=list n>>
         else p>>)
          (mcfactor(n,1),1);
   if atom n then add!-factor(n,factors!-so!-far)
   else if car n < cdr n then
      mcfactor!*(cdr n,mcfactor!*(car n,factors!-so!-far))
   else mcfactor!*(car n,mcfactor!*(cdr n,factors!-so!-far))>>;

symbolic procedure mcfactor(n,p);
% Based on "An Improved Monte-Carlo Factorisation Algorithm" by
% R.P.Brent in BIT 20 (1980) pp 176-184.  Argument n is the number to
% factor, p specifies the constant term of the polynomial.  There are
% supposed to be optimal p's for each n, but in general p=1 works well.
begin scalar gg,k,m,q,r,x,y,ys;
   m := 20;
   y:=0; r:=q:=1;
outer:
   x:=y;
   for i:=1:r do y:=remainder(y*y+p,n);
   k:=0;
inner:
   ys:=y;
   for i:=1:(if m<(r-k) then m else r-k) do <<
      y:=remainder(y*y+p,n);
      q:=remainder(q*abs(x-y),n)
   >>;
   gg:=gcdn(q,n);
   k:=k+m;
   if (k>
    else if n<0 then primep(-n)
    else if n=1 then nil
    else if n<=!*last!-prime!-in!-list!* then n member !*primelist!*
    else if n<=!*last!-prime!-squared!*
     then begin scalar p;
             p := !*primelist!*;
             while p and remainder(n,car p) neq 0 do p := cdr p;
             return null p
          end
    else if n>largest!-small!-modulus then general!-primep n
    else small!-primep n;

flag('(primep),'boolean);

symbolic procedure internal!-primep n;
   if n>largest!-small!-modulus then general!-primep n
    else small!-primep n;

% This is a version of primep written by FEB for inclusion in zfactor.
% It provides small-primep and general-primep with the following
% corrections of the distribution versions:
% (1) random number zero excluded as a potential witness
% (2) correct range of powers of seed provided
% (3) inspection for -1 replacing gcd's.


symbolic procedure small!-primep n;
% Based on an algorithm of M.Rabin published in the Journal of Number
% Theory Vol 12, pp 128-138 (1980).
  begin integer i,l,m,x,y,w,save; scalar result;
% Filter out some easy cases first
    if evenp n or remainder(n,3) = 0 then return nil;
    m := n-1;
    save := set!-small!-modulus n;
% Express n-1 = (2^l)*m
    l:=0;
    while evenp m do <>;
    i:=1;
    result:=t;
    while result and i<=!*confidence!* do <<
% Select a potential witness, noting 0, 1 and -1 are not liable to help.
       w := 1 + random(n-2);
% Raise to the odd power.
       x := modular!-expt(w, m);
% From here I can complete the calculation of w^(n-1) by doing a
% sequence of squaring operations.  While I do that I check to see if I
% come across a non-trivial square root of 1, and if I do then I know n
% could not have been prime.  In fact in that case I could exhibit a
% factor, but that does not concern me here.
       if x neq 1 then <<
         for k:=1:l do <<
           y := modular!-times(x,x);
% It is tolerable to continue round the loop after setting result=nil
% because I will then be repeating a squaring of 1, which is cheap.
           if y=1 and x neq (n-1) and x neq 1 then result := nil
           else x := y >>;
% Also if I do not get to 1 at the end then the number is composite, but
% I have no clue as to any factor.
         if x neq 1 then result := nil >>;
       i:=i+1 >>;
    set!-small!-modulus save;
    return result
  end;

symbolic procedure general!-primep n;
% Based on an algorithm of M.Rabin published in the Journal of Number
% Theory Vol 12, pp 128-138 (1980).
  begin integer i,l,m,x,y,w,save; scalar result;
% Filter out some easy cases first
    if evenp n or remainder(n,3) = 0 then return nil;
    m := n-1;
    save := set!-general!-modulus n;
% Express n-1 = (2^l)*m
    l:=0;
    while evenp m do <>;
    i:=1;
    result:=t;
    while result and i<=!*confidence!* do <<
% Select a potential witness, noting 0, 1 and -1 are not liable to help.
       w := 1 + random(n-2);
% Raise to the odd power.
       x:=general!-modular!-expt(w, m);
% From here I can complete the calculation of w^(n-1) by doing a
% sequence of squaring operations.  While I do that I check to see if I
% come across a non-trivial square root of 1, and if I do then I know n
% could not have been prime.  In fact in that case I could exhibit a
% factor, but that does not concern me here.
       if x neq 1 then <<
         for k:=1:l do <<
           y:=general!-modular!-times(x,x);
% It is tolerable to continue round the loop after setting result=nil
% because I will then be repeating a squaring of 1, which is cheap.
           if y=1 and x neq (n-1) and x neq 1 then result := nil
           else x := y >>;
% Also if I do not get to 1 at the end then the number is composite, but
% I have no clue as to any factor.
         if x neq 1 then result := nil >>;
       i:=i+1 >>;
    set!-general!-modulus save;
    return result
  end;

% The next function comes from J.H. Davenport.

symbolic procedure nextprime p;
   % Returns the next prime number bigger than p.
   if null p or p=0 or p=1 or p=-1 or p=-2 then 2
    else if p=-3 then -2
    else if not fixp p then typerr(!*f2a p,"integer")
    else begin
       if evenp p then p:=p+1 else p:=p+2;
       while not primep p do p:=p+2;
       return p
   end;

put('nextprime,'polyfn,'nextprime);

% The following definition has been added by Herbert Melenk.

symbolic procedure nrootnn(n,x);
   % N is an integer, x a positive integer. Value is a pair
   % of integers r,s such that r*s**(1/x)=n**(1/x). The decomposition
   % may be incomplete if the number is too big. The extraction of
   % the members of primelist* is complete.
   begin scalar pl,signn,qr,w; integer r,s,p,q;
     r := 1; s := 1;
     if n<0 then <>;
     pl:= !*primelist!*;
loop:
     p:=car pl; pl:=cdr pl; q:=0;
     while cdr (qr:=divide(n,p))=0 do <>;
     if not (q #< x) then
         <>;
     while q #> 0 do <>;
     if car qr < p then << s:=n*s; goto done>>;
     if pl then goto loop;
       % heuristic bound for complete factorization.
     if 10^20 > n then
     <>;
     >>
      else if (q:=iroot(n,x)) then r:=r*q
      else s:=n*s;
done:
     if signn then s := -s;
     return r . s
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/prep.red0000644000175000017500000001557211526203062022723 0ustar  giovannigiovannimodule prep; % Functions for converting canon. forms into prefix forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*bool !*intstr);

symbolic procedure prepsqxx u;
   % This is a top level conversion function.  It is not clear if we
   % need prepsqxx, prepsqx, prepsq!* and prepsq, but we keep them all
   % for the time being.
   negnumberchk prepsqx u;

symbolic procedure negnumberchk u;
   if eqcar(u,'minus) and numberp cadr u then - cadr u else u;

symbolic procedure prepsqx u;
   if !*intstr then prepsq!* u else prepsq u;

symbolic procedure prepsq u;
   if null numr u then 0 else sqform(u,function prepf);

symbolic procedure sqform(u,v);
   (lambda (x,y); if y=1 then x else list('quotient,x,y))
      (apply1(v,numr u),apply1(v,denr u));

symbolic procedure prepf u;
   (if null x then 0 else replus x) where x=prepf1(u,nil);

symbolic procedure prepf1(u,v);
   if null u then nil
    else if domainp u then list retimes(prepd u . exchk v)
    else nconc!*(prepf1(lc u,if mvar u eq 'k!* then v else lpow u . v),
                 prepf1(red u,v));

symbolic procedure prepd u;
   if atom u then if u<0 then list('minus,-u) else u
    else if apply1(get(car u,'minusp),u)
%    then list('minus,prepd1 !:minus u)
     then (if null x then 0 else list('minus,x))
          where x=prepd1 !:minus u
%   else if !:onep u then 1
    else apply1(get(car u,'prepfn),u);

symbolic procedure prepd1 u;
   if atom u then u else apply1(get(car u,'prepfn),u);

% symbolic procedure exchk u;
%    begin scalar z;
%       for each j in u do
%          if cdr j=1
%            then if eqcar(car j,'expt) and caddar j = '(quotient 1 2)
%                    then z := list('sqrt,cadar j) .z
%                   else z := sqchk car j . z
%            else z := list('expt,sqchk car j,cdr j) . z;
%       return z
%   end;

symbolic procedure exchk u; exchk1(u,nil,nil,nil);

symbolic procedure exchk1(u,v,w,x);
   % checks forms for kernels in EXPT. U is list of powers.  V is used
   % to build up the final answer. W is an association list of
   % previous non-constant (non foldable) EXPT's, X is an association
   % list of constant (foldable) EXPT arguments.
   if null u then exchk2(append(x,w),v)
    else if eqcar(caar u,'expt)
     then begin scalar y,z;
            y := simpexpon list('times,cdar u,caddar car u);
            if numberp cadaar u   % constant argument
              then <>
             else <>;
            return exchk1(cdr u,v,w,x)
        end
    else if cdar u=1 then exchk1(cdr u,sqchk caar u . v,w,x)
    else exchk1(cdr u,list('expt,sqchk caar u,cdar u) . v,w,x);

symbolic procedure exchk2(u,v);
   if null u then v
    else exchk2(cdr u,
%               ((if eqcar(x,'quotient) and caddr x = 2
%                  then if cadr x = 1 then list('sqrt,caar u)
%                        else list('expt,list('sqrt,caar u),cadr x)
                ((if x=1 then caar u
                   else if !*nosqrts then list('expt,caar u,x)
                   else if x = '(quotient 1 2) then list('sqrt,caar u)
                   else if x=0.5 then list('sqrt,caar u)
                   else list('expt,caar u,x)) where x = prepsqx cdar u)
                . v);

symbolic procedure assoc2(u,v);
   % Finds key U in second position of terms of V, or returns NIL.
   if null v then nil
    else if u = cdar v then car v
    else assoc2(u,cdr v);

symbolic procedure replus u;
   if null u then 0
    else if atom u then u
    else if null cdr u then car u
    else 'plus . unplus u;

symbolic procedure unplus u;
   if atom u then u
   else if car u = 'plus then unplus cdr u
   else if atom car u or not eqcar(car u,'plus)
      then (car u) . unplus cdr u
   else append(cdar u,unplus cdr u);

% symbolic procedure retimes u;
%    % U is a list of prefix expressions. Value is prefix form for the
%    % product of these;
%    begin scalar bool,x;
%       for each j in u do
%         <>     % ONEP
%             else if numberp j and minusp j
%              then <>
%             else x := j . x>>;
%        x := if null x then 1
%                else if cdr x then 'times . reverse x else car x;
%        return if bool then list('minus,x) else x
%   end;

symbolic procedure retimes u;
   begin scalar !*bool;
      u := retimes1 u;
      u := if null u then 1
            else if cdr u then 'times . u
            else car u;
      return if !*bool then list('minus,u) else u
   end;

symbolic procedure retimes1 u;
   if null u then nil
    else if car u = 1 then retimes1 cdr u
    else if minusp car u
     then <>
    else if atom car u then car u . retimes1 cdr u
    else if caar u eq 'minus
     then <>
    else if caar u eq 'times then retimes1 append(cdar u,cdr u)
    else car u . retimes1 cdr u;

symbolic procedure sqchk u;
   if atom u then u
    else (if x then apply1(x,u) else if atom car u then u else prepf u)
          where x=get(car u,'prepfn2);

put('!*sq,'prepfn2,'prepcadr);

put('expt,'prepfn2,'prepexpt);

symbolic procedure prepcadr u; prepsq cadr u;

symbolic procedure prepexpt u; if caddr u=1 then cadr u else u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/opmtch.red0000644000175000017500000002765211526203062023251 0ustar  giovannigiovannimodule opmtch; % Functions that apply basic pattern matching rules.

% Author: Anthony C. Hearn.
% Modifications by: Winfried Neun.

% Copyright (c) 2000 Anthony C. Hearn. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*uncached frlis!* matchlength!* subfg!*);

matchlength!* := 5; % Maximum number of arguments checked in matching.

share matchlength!*;

% Operator // for extended quotient match to be used only in the
% lhs of a rule.

newtok '((!/ !/) slash);

mkop 'slash;

infix slash;

precedence slash, quotient;

% put('slash,'simpfn, function(lambda(u); typerr("//",'operator)));

symbolic procedure emtch u;
   if atom u then u else (lambda x; if x then x else u) opmtch u;

symbolic procedure opmtch u;
   begin scalar q,x,y,z;
        if null(x := get(car u,'opmtch)) then return nil
         else if null subfg!* then return nil  % null(!*sub2 := t).
         else if (null !*uncached) and (q := assoc(u,cdr alglist!*))
                 then return cdr q;
%WN%     else if q := assoc(u,cdr alglist!*) then return cdr q;
        z := for each j in cdr u collect emtch j;
    a:  if null x then go to c;
        y := mcharg(z,caar x,car u);
    b:  if null y then <>
         else if lispeval subla(car y,cdadar x)
          then <>;
        y := cdr y;
        go to b;
    c:  if not !*uncached then rplacd(alglist!*,(u . q) . cdr alglist!*);
%WN% c:  rplacd(alglist!*,(u . q) . cdr alglist!*);
        return q
   end;

symbolic procedure mcharg(u,v,w);
  <>;

symbolic procedure mcharg1(u,v,w);
   % Procedure to determine if an argument list matches given template.
   % U is argument list of operator W, V is argument list template being
   % matched against.  If there is no match, value is NIL,
   % otherwise a list of lists of free variable pairings.
   if null u and null v then list nil
    else begin integer m,n;
        m := length u;
        n := length v;
        if flagp(w,'nary) and m>2
          then if m<=matchlength!* and flagp(w,'symmetric)
                             then return mchcomb(u,v,w)
                else if n=2 then <>
                else return nil;   % We cannot handle this case.
        return if m neq n then nil
                else if flagp(w,'symmetric) then mchsarg(u,v,w)
                else if mtp v then list pair(v,u)
                else mcharg2(u,v,list nil,w)
   end;

symbolic procedure reform!-minus(u,v);
  % Convert forms (quotient (minus a) b) to (minus (quotient a b))
  % if the corresponding pattern in v has a top level minus.
    if null v or null u then u else
      ((if eqcar(car v,'minus) and eqcar(c,'quotient)
           and eqcar(cadr c,'minus)
          then {'minus,{'quotient,cadr cadr c,caddr c}} else c)
                      . reform!-minus(cdr u,cdr v))
                               where c=car u;

symbolic procedure reform!-minus2(u,v);
 % Prepare an extended quotient match; v is a pattern with leading "//".
 % Create for a form (quotient a b) a second form
 %  (quotient (minus a) (minus b)) if b contains a minus sign.
   if null u or not eqcar(car u,'quotient) then nil else
  <>;

symbolic procedure mchcomb(u,v,op);
   begin integer n;
      n := length u - length v +1;
      if n<1 then return nil
       else if n=1 then return mchsarg(u,v,op)
       else if not smemqlp(frlis!*,v) then return nil;
      return for each x in comb(u,n) join
           if null ncmp!* then mchsarg((op . x) . setdiff(u,x),v,op)
%  (reversip!* (for each j in permutations v collect pair(j,w))
%               where w=(op . x) . setdiff(u,x))
%          else if length v>2
%           then rederr "noncom with 3 free args not implemented"
            else (if null y then nil
%            else if cdr y then mchsarg(aconc(car y,op . x),v,op)
%             else mchsarg((op . x) . car y,v,op))
                   else mchsarg((op . x) . car y,
                                if cdr y then reverse v else v,op))
            where y = mchcomb2(x,u,nil,nil,nil)
   end;

symbolic procedure mchcomb2(u,v,w,bool1,bool2);
   % Determines if v can be removed from u according to noncom rules,
   % and whether remaining terms must be on the left (t) or right (nil).
   if null u
     then nconc(reversip w,v) . bool2
   % (bool2 or null noncomlistp v and noncomlistp w and 'ok)
    else if car u = car v
           then if noncomp car u then mchcomb2(cdr u,cdr v,w,t,bool2)
                 else mchcomb2(cdr u,cdr v,w,bool1,bool2)
    else if noncomp car u
     then if bool1 then nil
           else mchcomb2(u,cdr v,car v . w,t,if bool2 then bool2 else t)
    else mchcomb2(u,cdr v,car v . w,bool1,bool2);

symbolic procedure comb(u,n);
   % Value is list of all combinations of N elements from the list U.
   begin scalar v; integer m;
        if n=0 then return list nil
         else if (m:=length u-n)<0 then return nil
         else for i := 1:m do
          <>;
        return u . v
   end;

symbolic procedure mcharg2(u,v,w,x);
   % Matches compatible list U of operator X against template V.
   begin scalar y;
        if null u then return w;
        y := mchk(car u,car v);
        u := cdr u;
        v := cdr v;
        return for each j in y
           join mcharg2(u,updtemplate(j,v,x),msappend(w,j),x)
   end;

symbolic procedure msappend(u,v);
   % Mappend u and v with substitution.
   for each j in u collect append(v,sublis(v,j));

symbolic procedure updtemplate(u,v,w);
   begin scalar x,y;
      return for each j in v collect
        if (x := subla(u,j)) = j then j
         else if (y := reval!-without(x,w)) neq x then y
         else x
   end;

symbolic procedure reval!-without(u,v);
   % Evaluate U without rules for operator V.  This avoids infinite
   % recursion with statements like
   % for all a,b let kp(dx a,kp(dx a,dx b)) = 0; kp(dx 1,dx 2).
   begin scalar x;
      x := get(v,'opmtch);
      remprop(v,'opmtch);
      u := errorset!*(list('reval,mkquote u),t);
      put(v,'opmtch,x);
      if errorp u then error1() else return car u
   end;

symbolic procedure mchk(u,v);
  % Extension to optional arguments for binary forms suggested by
  % Herbert Melenk.
   if u=v then list nil
    else if eqcar(u,'!*sq) then mchk(prepsqxx cadr u,v)
    else if eqcar(v,'!*sq) then mchk(u,prepsqxx cadr v)
    else if atom v
           then if v memq frlis!* then list list (v . u) else nil
    else if atom u      % Special check for negative number match.
     then if numberp u and u<0 and eqcar(v,'minus)
          then mchk(list('minus,-u),v) else mchkopt(u,v)
       % "difference" may occur in a pattern like (a - b)^~n.
    else if car v = 'difference then
       mchk(u,{'plus,cadr v,{'minus,caddr v}})
    else if get(car u,'dname) or get(car v,'dname) then nil
    else if car u eq car v then mcharg(cdr u,cdr v,car u)
    else if car v memq frlis!*    % Free operator.
      then for each j in mcharg(subst(car u,car v,cdr u),
                                subst(car u,car v,cdr v),
                                car u)
               collect (car v . car u) . j
    else if car u eq 'minus then mchkminus(cadr u,v)
    else mchkopt(u,v);

symbolic procedure mchkopt(u,v);
 % Check whether the pattern v is a binary form with an optional
 % argument.
   (if o then mchkopt1(u,v,o)) where o=get(car v,'optional);

symbolic procedure mchkopt1(u,v,o);
  begin scalar v1,v2,w;
    if null (w:=cdr v) then return nil; v1:=car w;
    if null (w:=cdr w) then return nil; v2:=car w;
    if cdr w then return nil;
    return
     if flagp(v1,'optional) then
      for each r in mchk(u,v2) collect (v1.car o) . r
     else if flagp(v2,'optional) then
      for each r in mchk(u,v1) collect (v2.cadr o) . r
     else nil;
   end;

put('plus,'optional,'(0 0));
put('times,'optional,'(1 1));
put('quotient,'optional,
     '((rule_error "fraction with optional numerator") 1));
put('expt,'optional,
     '((rule_error "exponential with optional base")  1));

symbolic procedure rule_error u;
  rederr{"error in rule:",u,"illegal"};

symbolic operator rule_error;

% The following function pushes a minus sign into a term.
% E.g. a + ~~y*~z matches
%                         y   z
%     (a + b)             1   b
%     (a - b)            -1   b
%     (a -3b)            -3   b
%                         b  -3
%     (a - b*c)          -b   c
%                         c  -b
%
% For products, the minus is assigned to a numeric coefficient or
% an artificial factor (-1) is created. For quotients the minus is
% always put in the numerator.

symbolic procedure mchkminus(u,v);
  if not(car v memq '(times quotient)) then nil else
  if atom u or not(car u eq car v) then
    if car v eq 'times then mchkopt1(u,v,'((minus 1)(minus 1)))
        else mchkopt({'minus,u},v)
  else if numberp cadr u or pairp cadr u and get(caadr u,'dname)
        or car v eq 'quotient
     then mcharg({'minus,cadr u}.cddr u,cdr v,car v)
  else mcharg('(minus 1).cdr u,cdr v,'times);

symbolic procedure mkbin(u,v);
   if null cddr v then u . v else list(u,car v,mkbin(u,cdr v));

symbolic procedure mtp v;
   null v or (car v memq frlis!* and not(car v member cdr v)
       and mtp cdr v);

symbolic procedure mchsarg(u,v,w);
   %  From ACH: I don't understand why I put in the following reversip,
   %  since it causes the least direct match to come back first.
   reversip!* if mtp v and (W NEQ 'TIMES OR noncomfree u)
     then for each j in noncomperm v collect pair(j,u)
    else for each j in noncomperm u join mcharg2(j,v,list nil,w);

symbolic procedure noncomfree u;
   if idp u then not flagp(u,'noncom)
    else atom u or noncomfree car u and noncomfree cdr u;

symbolic procedure noncomperm u;
   % Find possible permutations when non-commutativity is taken into
   % account.
   if null u then list u
    else for each j in u join
       (if x eq 'failed then nil else mapcons(noncomperm x,j))
        where x=noncomdel(j,u);

symbolic procedure noncomdel(u,v);
   if null NONCOMP!* u then delete(u,v) else noncomdel1(u,v);

symbolic procedure noncomdel1(u,v);
   begin scalar z;
   a: if null v then return reversip!* z
       else if u eq car v then return nconc(reversip!* z,cdr v)
       else if NONCOMP!* car v then return 'failed;
      z := car v . z;
      v := cdr v;
      go to a
   end;

symbolic procedure NONCOMP!* u;
   noncomp u or eqcar(u,'expt) and noncomp cadr u;

flagop antisymmetric,symmetric;

flag ('(plus times),'symmetric);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/algdcl.red0000644000175000017500000000555511526203062023203 0ustar  giovannigiovannimodule algdcl;  % Various declarations.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(preclis!* ws);

symbolic procedure formopr(u,vars,mode);
   if mode eq 'symbolic
     then list('flag,mkquote cdr u,mkquote 'opfn)
    else list('operator,mkarg(cdr u,vars));

put('operator,'formfn,'formopr);

symbolic procedure operator u; for each j in u do mkop j;

rlistat '(operator);

symbolic procedure remopr u;
   % Remove all operator related properties from id u.
   begin
      remprop(u,'alt);
      remprop(u,'infix);
      remprop(u,'op);
      remprop(u,'prtch);
      remprop(u,'simpfn);
      remprop(u,'unary);
      remflag(list u,'linear);
      remflag(list u,'nary);
      remflag(list u,'opfn);
      remflag(list u,'antisymmetric);
      remflag(list u,'symmetric);
      remflag(list u,'right);
      preclis!* := delete(u,preclis!*)
   end;

flag('(remopr),'eval);

symbolic procedure den u;
   mk!*sq (denr simp!* u ./ 1);

symbolic procedure num u;
   mk!*sq (numr simp!* u ./ 1);

flag('(den num),'opfn);

flag('(den num),'noval);

put('saveas,'formfn,'formsaveas);

symbolic procedure formsaveas(u,vars,mode);
   list('saveas,formclear1(cdr u,vars,mode));

symbolic procedure saveas u;
   let00 list list(if smemq('!~,car u) then 'replaceby else 'equal,
                   car u,
                   if eqcar(ws,'!*sq)
                      and smemql(for each x in frasc!* collect car x,
                                 cadr ws)
                     then list('!*sq,cadr ws,nil)
                    else ws);

rlistat '(saveas);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/general.red0000644000175000017500000001327411526203062023367 0ustar  giovannigiovannimodule general;   % General functions for the support of REDUCE.

% Author: Anthony C. Hearn.

% Copyright (c) 1999 Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!!arbint);

!!arbint := 0; % Index for arbitrary constants.

symbolic procedure atomlis u;
   null u or (atom car u and atomlis cdr u);

symbolic procedure carx(u,v);
   if null cdr u then car u
    else rerror(alg,5,list("Wrong number of arguments to",v));

% We assume concat2 is defined in the underlying Lisp system.

% symbolic macro procedure concat u;
%    if null u then nil else expand(cdr u,'concat2);

% symbolic procedure delasc(u,v);
%    if null v then nil
%    else if atom car v or u neq caar v then car v . delasc(u,cdr v)
%    else cdr v;

% This definition, due to A.C. Norman, avoids recursion.

symbolic procedure delasc(u,v);
  begin scalar w;
     while v do
      <>;
     return reversip w
  end;

symbolic procedure eqexpr u;
   % Returns true if U is an equation or similar structure
   % (e.g., a rule).
   not atom u
      and flagp(car u,'equalopr) and cddr u and null cdddr u;

flag('(eq equal),'equalopr);

symbolic procedure evenp x; remainder(x,2)=0;

flag('(evenp),'opfn);  % Make a symbolic operator.

symbolic procedure lengthc u;
   %gives character length of U excluding string and escape chars;
   begin integer n; scalar x;
      n := 0;
      x := explode u;
      if car x eq '!" then return length x-2;
      while x do
        <>;
      return n
   end;

symbolic procedure makearbcomplex;
   begin scalar ans;
      !!arbint := !!arbint+1;
      ans := car(simp!*(list('arbcomplex, !!arbint)));
      % This CAR is NUMR, which is not yet defined.
      return ans
   end;

symbolic procedure mapcons(u,v);
   for each j in u collect v . j;

symbolic procedure mappend(u,v);
   for each j in u collect append(v,j);

symbolic procedure nlist(u,n);
   if n=0 then nil else u . nlist(u,n-1);

symbolic procedure nth(u,n);
   car pnth(u,n);

symbolic procedure pnth(u,n);
   if null u then rerror(alg,6,"Index out of range")
    else if n=1 then u
    else pnth(cdr u,n-1);

symbolic procedure permp(u,v);
   % This used to use EQ.  However, SUBST use requires =.
   if null u then t
    else if car u=car v then permp(cdr u,cdr v)
    else not permp(cdr u,subst(car v,car u,cdr v));

symbolic procedure permutations u;
   %  Returns list of all permutations of the list u.
   if null u then list u
    else for each j in u join mapcons(permutations delete(j,u),j);

symbolic procedure posintegerp u;
   % True if U is a positive (non-zero) integer.
   fixp u and u>0;

symbolic procedure remove(x,n);
   % Returns X with Nth element removed;
   if null x then nil
    else if n=1 then cdr x
    else car x . remove(cdr x,n-1);

symbolic procedure repasc(u,v,w);
   % Replaces value of key U by V in association list W.
   if null w then rerror(alg,7,list("key",u,"not found"))
    else if u = caar w then (u . v) . cdr w
    else car w . repasc(u,v,cdr w);

symbolic procedure repeats x;
   if null x then nil
    else if car x member cdr x then car x . repeats cdr x
    else repeats cdr x;

symbolic procedure revpr u;
   cdr u . car u;

symbolic procedure smember(u,v);
   %determines if S-expression U is a member of V at any level;
   if u=v then t
    else if atom v then nil
    else smember(u,car v) or smember(u,cdr v);

symbolic procedure smemql(u,v);
   %Returns those members of id list U contained in V at any
   %level (excluding quoted expressions);
   if null u then nil
    else if smemq(car u,v) then car u . smemql(cdr u,v)
    else smemql(cdr u,v);

symbolic procedure smemqlp(u,v);
   %True if any member of id list U is contained at any level
   %in V (exclusive of quoted expressions);
   if null v or numberp v then nil
    else if atom v then v memq u
    else if car v eq 'quote then nil
    else smemqlp(u,car v) or smemqlp(u,cdr v);

symbolic procedure spaces n; for i := 1:n do prin2 " ";

symbolic procedure subla(u,v);
   % Substitutes the atom u in v. Retains previous structure where
   % possible.
   if null u or null v then v
    else if atom v then (if x then cdr x else v) where x=atsoc(v,u)
    else (if y=v then v else y) where y=subla(u,car v) . subla(u,cdr v);

symbolic procedure xnp(u,v);
   %returns true if the atom lists U and V have at least one common
   %element;
   u and (car u memq v or xnp(cdr u,v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/map.red0000644000175000017500000001127111526203062022522 0ustar  giovannigiovannimodule map;  % Mapping univariate functions to composite objects.

% Author: Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Syntax: map(unary-function,linear-structure-or-matrix)
%
%           map(sqrt ,{1,2,3,4});
%           map(df(~u,x),mat((x^2,sin x)));
%
%         select(unary-predicate,linear-structure)
%
%           select(evenp,{1,2,3,4,5,6,7});
%           select(evenp deg(~u,x),(x+y)^5);
%
%  The function/predicate may contain one free variable.

put('!~map,'oldnam,'map);

put('map,'newnam,'!~map);

put('!~map,'psopfn,'map!-eval);

put('!~map,'rtypefn,'getrtypecadr);

symbolic procedure getrtypecadr u; getrtype cadr u;

symbolic procedure map!-eval u;
  <>;

symbolic procedure !~map(b,a);
 % Called only inside matrix expressions.
   cdr map!-eval1('mat . matsm a,b,
     function (lambda w; list('!*sq,w,t)),'simp);

symbolic procedure map!-eval1(o,q,fcn1,fcn2);
 % o       structure to be mapped.
 % q       map expression (univariate function).
 % fcn1    function for evaluating members of o.
 % fcn2    function computing results (e.g. aeval).
  begin scalar v,w;
    v := '!&!&x;
    if idp q
      and (get(q,'simpfn) or get(q,'number!-of!-args)=1)
    then <>
    else if eqcar(q,'replaceby) then
      <>
    else
      <>;
    if eqcar(w,'!~) then w:=cadr w;
    q := sublis({w.v,{'!~,w}.v},q);
    if atom o then rederr "cannot map for atom";
    return if car o ='mat then
     'mat . for each row in cdr o collect
             for each w in row collect
              map!-eval2(w,v,q,fcn1,fcn2)
     else car o . for each w in cdr o collect
       map!-eval2(w,v,q,fcn1,fcn2);
  end;

symbolic procedure map!-eval2(w,v,q,fcn1,fcn2);
  begin scalar r;
   r :=evalletsub2({{{'replaceby ,v,apply1(fcn1,w)}},
        {fcn2,mkquote q}},nil);
   if errorp r then rederr "error during map";
   return car r;
  end;

symbolic procedure map!-frvarsof(q,l);
  if atom q then l
  else if car q eq '!~ then
     if q member l then l else q.l
  else map!-frvarsof(cdr q,map!-frvarsof(car q,l));

symbolic procedure select!-eval u;
 % select from a list l members according to a boolean test.
 begin scalar l,w,v,r;
  l := reval cadr u; w := car u;
  if atom l or (car l neq'list and not flagp(car l,'nary)) then
           typerr(l,"select operand");
  if idp w and get(w,'number!-of!-args)=1 then w:={w,{'~,'!&!&}};
  if eqcar(w,'replaceby) then <>;
  w:=freequote formbool(w,nil,'algebraic);
  if v then w:={'replaceby,v,w};
  r:=for each q in
        pair(cdr map!-eval1(l,w,function(lambda y;y),'lispeval),cdr l)
      join if car q and car q neq 0 then {cdr q};
  if r then return car l . r;
  if (r:=atsoc(car l,'((plus . 0)(times . 1)(and . 1)(or . 0))))
    then return cdr r
   else rederr {"empty selection for operator ",car l}
 end;

symbolic procedure freequote u;
  % Preserve structure where possible.
  if atom u then u
  else if car u eq 'list and cdr u and cadr u = '(quote !~)
   then mkquote{'!~,cadr caddr u}
  else (if v=u then u else v)
        where v = freequote car u . freequote cdr u;

put('select,'psopfn,'select!-eval);

put('select,'number!-of!-args,2);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/weight.red0000644000175000017500000000642311526203062023237 0ustar  giovannigiovannimodule weight; % Asymptotic command package.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modified by F.J. Wright@Maths.QMW.ac.uk, 18 May 1994,
% mainly to return the previous settings rather than nothing.

fluid '(asymplis!* wtl!*);

flag('(k!*),'reserved);

% Asymptotic list and weighted variable association lists.

symbolic procedure weight u;
   % Returns previous weight list for the argument variables, omitting
   % any unweighted variables.  Returns the current weight without
   % resetting it for any argument that is a variable rather than a
   % weight equation, and with no arguments returns all current
   % variable weights.
   makelist if null car u then
      for each x in wtl!* collect {'equal, car x, cdr x}
   else <<
      % Make sure asymplis!* is initialized.
      if null atsoc('k!*,asymplis!*)
         then asymplis!* := '(k!* . 2) . asymplis!*;
      rmsubs();
      % Build the output list while processing the input:
      for each x in u join
      begin scalar y,z;
         if eqexpr x then <<
            z := reval caddr x;
            if not fixp z or z<=0 then typerr(z,"weight");
            x := cadr x >>;
         y := !*a2kwoweight x;
         x := if (x := atsoc(y,wtl!*)) then {{'equal, car x, cdr x}};
         if z then wtl!* :=  (y . z) . delasc(y,wtl!*);
         return x
      end
   >>;


symbolic procedure wtlevel n;
   begin scalar oldn;
      % Returns previous wtlevel; with no arg returns current wtlevel
      % without resetting it.
      oldn := (if x then cdr x - 1 else 1)
              where x = atsoc('k!*,asymplis!*);
      if car n then <<
         n := reval car n;
         if not fixp n or n<0 then typerr(n,"weight level");
         if n>;
      return oldn
   end;

rlistat '(weight wtlevel);
% but preserve current mode as mode of result:
flag('(weight wtlevel), 'nochange);

% algebraic let k!***2=0;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/simp.red0000644000175000017500000015114111526203062022716 0ustar  giovannigiovannimodule simp; % Functions to convert prefix forms into canonical forms.

% Author: Anthony C. Hearn.

% Modifications by: J.H. Davenport, F. Kako, S. Kameny, E. Schruefer and
%                   Francis J. Wright.

% Copyright (c) 1998, Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*allfac !*div);

fluid '(!*asymp!* !*complex !*exp !*gcd !*ifactor !*keepsqrts !*mcd
        !*mode !*modular !*notseparate !*numval !*precise !*precise_complex
        !*rationalize !*reduced !*resimp !*sub2 !*uncached alglist!* dmd!*
        dmode!* varstack!* !*combinelogs !*expandexpt !*msg frlis!* subfg!*
        !*norationalgi factorbound!* ncmp!* powlis1!* !*nospurp
        !*ncmp);

global '(!*match
         den!*
%        exptl!*   No-one else refers to this variable - just slows us
         initl!*
         mul!*
         simpcount!*
         simplimit!*
         tstack!*
         ws);

switch expandexpt; % notseparate;

!*expandexpt := t;

% The NOTSEPARATE switch inhibits an expression such as x^(4/3) to
% become x*x^(1/3).  At the present time, no one is using this.

factorbound!* := 10000;   % Limit for factoring with IFACTOR off.

% !*KEEPSQRTS uses SQRT rather than EXPT for square roots.
% Normally set TRUE in the integrator, false elsewhere.

put('ifactor,'simpfg,'((t (rmsubs))));

put('alglist!*,'initl,'(cons nil nil));

put('simpcount!*,'initl,0);

initl!* := union('(alglist!* simpcount!*),initl!*);

simplimit!* := 1000;

symbolic procedure noncom u;
   % Declare vars u to be noncom.
   <>;

symbolic procedure noncom1 u;
   <>;

put('noncom,'stat,'rlis);

symbolic procedure simp!* u;
   begin scalar !*asymp!*,x;
        if eqcar(u,'!*sq) and caddr u and null !*resimp
          then return cadr u;
        x := mul!* . !*sub2;    % Save current environment.
        mul!* := nil;
        u:= simp u;
        if !*nospurp then mul!* := union(mul!*,'(isimpq));
        for each j in mul!* do u:= apply1(j,u);
        mul!* := car x;
        u := subs2 u;
        if !*combinelogs then u := clogsq!* u;
        % Must be here, since clogsq!* can upset girationalizesq!:.
        % For defint, it is necessary to turn off girationalizesq - SLK.
        if dmode!* eq '!:gi!: and not !*norationalgi
          then u := girationalize!: u
          else if !*rationalize then u := rationalizesq u
         else u := rationalizei u;
        !*sub2 := cdr x;
        % If any leading terms have cancelled, a gcd check is required.
        if !*asymp!* and !*rationalize then u := gcdchk u;
        return u
   end;

symbolic procedure rationalizei u;
   % Remove overall factor of i in denominator.
   begin scalar v,w;
      if domainp (v := denr u) or not smemq('i,v) then return u;
      v := reordsq u where kord!* = 'i . kord!*;
      return if lpow (w := denr v) = '(i . 1) and null red w
               then negf multf(!*k2f 'i,reorder numr v) ./ reorder lc w
              else u
   end;

symbolic procedure subs2 u;
   begin scalar xexp,v,w,x;
    if null subfg!* then return u
     else if !*sub2 or powlis1!* then u := subs2q u;
    u := exptchksq u;
    x := get('slash,'opmtch);
    if null (!*match or x) or null numr u then return u
     else if null !*exp
      then <>;
    u := subs3q u;
    if xexp then <>;
    if x then u := subs4q u;
    return u
   end;

symbolic procedure simp u;
   (begin scalar x,y;
    % This case is sufficiently common it is done first.
    if fixp u
      then if u=0 then return nil ./ 1
            else if not dmode!* then return u ./ 1
            else nil
     else if u member varstack!* then recursiveerror u;
    varstack!* := u . varstack!*;
    if simpcount!*>simplimit!*
      then <>
     else if eqcar(u,'!*sq) and caddr u and null !*resimp
      then return cadr u
     else if null !*uncached and (x := assoc(u,car alglist!*))
      then return <>;
    simpcount!* := simpcount!*+1; % undone by returning through !*SSAVE.
    if atom u then return !*ssave(simpatom u,u)
     else if not idp car u or null car u
      then if atom car u then typerr(car u,"operator")
            else if idp caar u and (x := get(caar u,'name))
             then return !*ssave(u,u)     %%% not yet correct
            else if eqcar(car u,'mat)
                and numlis(x := revlis cdr u) and length x=2
             then return !*ssave(simp nth(nth(cdar u,car x),cadr x),u)
            else errpri2(u,t)
     else if flagp(car u,'opfn)
      then if null(y := getrtype(x := opfneval u))
             then return !*ssave(simp_without_resimp x,u)
            else if y eq 'yetunknowntype and null getrtype(x := reval x)
             then return simp x
            else typerr(u,"scalar")
     else if x := get(car u,'psopfn)
      then if getrtype(x := apply1(x,cdr argnochk u))
             then typerr(u,"scalar")
        else if x=u then return !*ssave(!*k2q x,u)
        else return !*ssave(simp_without_resimp x,u)
     % Note in above that the psopfn MUST return a *sq form,
     % otherwise an infinite recursion occurs.
     else if x := get(car u,'polyfn)
      then return
        <>
     else if get(car u,'opmtch)
        and not(get(car u,'simpfn) eq 'simpiden)
        and (x := opmtchrevop u)
      then return !*ssave(simp x,u)
     else if x := get(car u,'simpfn)
      then return !*ssave(apply1(x,
                                 if x eq 'simpiden or flagp(car u,'full)
                                   then argnochk u
                                 else cdr argnochk u),
                          u)
     else if (x := get(car u,'rtype)) and (x := get(x,'getelemfn))
      then return !*ssave(simp apply1(x,u),u)
     else if flagp(car u,'boolean) or get(car u,'infix)
      then typerr(if x := get(car u,'prtch) then x else car u,
              "algebraic operator")
     else if flagp(car u,'nochange)
      then return !*ssave(simp lispeval u,u)
     else if get(car u,'psopfn) or get(car u,'rtypefn)
      then typerr(u,"scalar")
     else <>;
   end) where varstack!* = varstack!*;

symbolic procedure opmtchrevop u;
   % The following structure is designed to make index mu; p1.mu^2;
   % work.  It also introduces a redundant revlis in most cases.
   if null !*val or smemq('cons,u) then opmtch u
    else opmtch(car u . revlis cdr u);

symbolic procedure simp_without_resimp u;
   simp u where !*resimp := nil;

put('array,'getelemfn,'getelv);

put('array,'setelemfn,'setelv);

symbolic procedure getinfix u;
   %finds infix symbol for U if it exists;
   begin scalar x; return if x := get(u,'prtch) then x else u end;

symbolic procedure !*ssave(u,v);
   % We keep !*sub2 as well, since there may be an unsubstituted
   % power in U.
   begin
      if not !*uncached
    then rplaca(alglist!*,(v . (!*sub2 . u)) . car alglist!*);
      simpcount!* := simpcount!*-1;
      return u
   end;

symbolic procedure numlis u;
   null u or (numberp car u and numlis cdr u);

symbolic procedure simpatom u;
%  if null u then typerr("NIL","algebraic identifier")
   if null u then nil ./ 1   % Allow NIL as default 0.
    else if numberp u
     then if u=0 then nil ./ 1
           else if not fixp u then ('!:rd!: . cdr fl2bf u) ./ 1
             % we assume that a non-fixp number is a float.
           else if dmode!* eq '!:mod!: and current!-modulus = 1
            then nil ./ 1
           else if flagp(dmode!*,'convert) and u neq 1 % Don't convert 1
            then !*d2q apply1(get(dmode!*,'i2d),u)
           else u ./ 1
    else if stringp u then typerr(list("String",u),"identifier")
    else if flagp(u,'share) then
      <<(if x eq u then mksq(u,1) else simp x) where x=lispeval u>>
    else begin scalar z;
      if z := get(u,'idvalfn) then return apply1(z,u)
       else if !*numval and dmode!* and flagp(u,'constant)
          and (z := get(u,dmode!*))
          and not errorp(z := errorset!*(list('lispapply,mkquote z,nil),
                         nil))
        then return !*d2q car z
       else if getrtype u then typerr(u,'scalar)
       else return mksq(u,1) end;

flag('(e pi),'constant);

symbolic procedure mkop u;
   begin scalar x;
    if null u then typerr("Local variable","operator")
     else if (x := gettype u) eq 'operator
      then lprim list(u,"already defined as operator")
    % Allow a scalar to also be an operator.
     else if x and not(x memq '(fluid global procedure scalar))
      then typerr(u,'operator)
%    else if u memq frlis!* then typerr(u,"free variable")
     else put(u,'simpfn,'simpiden)
   end;

symbolic procedure operatorp u;
    gettype u eq 'operator;

symbolic procedure simpcar u;
   simp car u;

put('quote,'simpfn,'simpcar);

symbolic procedure share u;
   begin scalar y;
      for each v in u do
         if not idp v then typerr(v,"id")
         else if flagp(v,'share) then nil
         else if flagp(v,'reserved) then rsverr v
         else if (y := getrtype v) and y neq 'list
            then rerror(alg,13,list(y,v,"cannot be shared"))
         else
          % if algebraic value exists, transfer to symbolic.
         <>
          % if no algebraic value but symbolic value, leave unchanged.
            else if not boundp v then setifngfl(v,v);
          % if previously unset, set symbolic self pointer.
           flag(list v,'share)>>
   end;

symbolic procedure boundp u;
   % Determines if the id u has a value.
   % NB:  this function must be redefined in many systems (e.g., CL).
   null errorp errorset!*(u,nil);

symbolic procedure setifngfl(v,y);
   <>;

rlistat '(share);

flag('(ws !*mode),'share);

flag('(share),'eval);


% ***** SIMPLIFICATION FUNCTIONS FOR EXPLICIT OPERATORS - EXP *****

symbolic procedure simpexpon u;
   % Exponents must not use non-integer arithmetic unless NUMVAL is on,
   % in which case DOMAINVALCHK must know the mode.
   simpexpon1(u,'simp!*);

symbolic procedure simpexpon1(u,v);
   if !*numval and (dmode!* eq '!:rd!: or dmode!* eq '!:cr!:)
     then apply1(v,u)
    else begin scalar dmode!*,alglist!*; return apply1(v,u) end;

symbolic procedure simpexpt u;
   % We suppress reordering during exponent evaluation, otherwise
   % internal parts (as in e^(a*b)) can have wrong order.
   begin scalar expon;
      expon := simpexpon carx(cdr u,'expt) where kord!*=nil;
      % We still need the right order, else
      % explog := {sqrt(e)**(~x*log(~y)/~z) => y**(x/z/2)};
      % on ezgcd,gcd; let explog; fails.
      expon := simpexpon1(expon,'resimp);
      return simpexpt1(car u,expon,nil)
   end;

symbolic procedure simpexpt1(u,n,flg);
   % FLG indicates whether we have done a PREPSQ SIMP!* U or not: we
   % don't want to do it more than once.
   begin scalar !*allfac,!*div,m,x,y;
      if onep u then return 1 ./ 1;
      !*allfac := t;
      m := numr n;
      if m=1 and denr n=1 then return simp u;
     % this simplifies e^(n log x) -> x^n  for all n,x.
      if u eq 'e and domainp denr n and not domainp m and ldeg m=1
         and null red m and eqcar(mvar m,'log) then return
            simpexpt1(prepsq!* simp!* cadr mvar m,lc m ./ denr n,nil);
      if not domainp m or not domainp denr n
        then return simpexpt11(u,n,flg);
      x := simp u;
      if null m
        then return if null numr x then rerror(alg,14,"0**0 formed")
                     else 1 ./ 1;
      % We could use simp!* here, except it messes up the handling of
      % gamma matrix expressions.
%     if denr x=1 and not domainp numr x and not(denr n=1)
%       then <1 then return simpexptfctr(y,n)>>;
      return if null numr x
               then if domainp m and minusf m
                      then rerror(alg,15,"Zero divisor")
                     else nil ./ 1
              else if atom m and denr n=1 and domainp numr x
                 and denr x=1
               then if atom numr x and m>0 then !*d2q(numr x**m)
                     else <>
              else if y := domainvalchk('expt,list(x,n)) then y
              else if atom m and denr n=1
               then <>     % This uses OFF EXP option.
                      % There may be a pattern matching problem though.
     % We need the subs2 in the next line to take care of power and
     % product simplification left over from the call of simp on u.
              else simpexpt11(if flg then u else prepsq!* subs2!* x,n,t)
   end;

symbolic procedure simpexptfctr(u,n);
   begin scalar x;
     x := 1 ./ 1;
     for each j in u do
         x:= multsq(simpexpt1(prepf car j,multsq(cdr j ./ 1,n),nil),x);
     return x
   end;

symbolic procedure simpexpt11(u,n,flg);
   % Expand exponent to put expression in canonical form.
   begin scalar x;
      return if !*precise_complex then simpexpt2(u,n,flg)
              else if domainp denr n
                 or not(car(x := qremf(numr n,denr n)) and cdr x)
               then simpexpt2(u,n,flg)
              else multsq(simpexpt1(u,car x ./ 1,flg),
                          simpexpt1(u,cdr x ./ denr n,flg))
   end;

symbolic procedure simpexpt2(u,n,flg);
   % The "non-numeric exponent" case.  FLG indicates whether we have
   % done a PREPSQ SIMP!* U or not: we don't want to do it more than
   % once.
   begin scalar m,n,x,y;
    if u=1 then return 1 ./ 1;
%  The following is now handled in mkrootsq.
%    else if fixp u and u>0 and (u1 or cdar x>1)
%     then <>;
    m:=numr n;
    if pairp u then <<
     if car u eq 'expt and null !*precise_complex
      then <>
     else if car u eq 'sqrt and not !*keepsqrts
      then return simpexpt2(cadr u, multsq(1 ./ 2,n),flg)
     % We need the !*precise check for, say, sqrt((1+a)^2*y*z).
     else if car u eq 'times and not !*precise
      then <>
        % For a product under *precise we isolate positive factors.
     else if car u eq 'times and (y:=split!-sign cdr u) and car y
%             and null !*precise_complex
      then <>
     else if car u eq 'quotient
%    The next lines did not allow, e.g., sqrt(a/b) => sqrt(a)/sqrt(b).
%    when precise is on and there is a risk of
%    E.g., sqrt(a/b) neq sqrt(a)/sqrt(b) when a=1, b=-1.
%    We allow however the denominator to be a positive number.
        and (not !*precise
%               or alg_constant_exptp(cadr u,n)
%               or alg_constant_exptp(caddr u,n)
                or posnump caddr u and posnump prepsq n
            )
      then <>
     % Special case of (-expression)^(1/2).
%    else if car u eq 'minus
%            and (n = '(1 . 2) or n = '((!:rd!: . 0.5) . 1)
%                 or n = '((!:rd!: 5 . -1) . 1)
%                 or n = '((!:rn!: 1 . 2) . 1))
%     then return simptimes list('i,list('expt,cadr u,prepsq n))>>;
%    else if car u eq 'minus and numberp m and denr n=1
%     then return multsq(simpexpt list(-1,m),
%                simpexpt list(cadr u,m))>>;
     else if car u eq 'minus and not !*precise and not(cadr u = 1)
      then return (multsq(simpexpt list(-1,expon),
                 simpexpt list(cadr u,expon))) where expon=prepsq n>>;
    if null flg
      then <<% Don't expand say e and pi, since whole expression is not
             % numerical.
            if null(dmode!* and idp u and get(u,dmode!*))
               then u := prepsq simp!* u;
             return simpexpt1(u,n,t)>>
     else if numberp u and zerop u then return nil ./ 1
     else if not numberp m then m := prepf m;
    n := prepf denr n;
    if m memq frlis!* and n=1 then return list ((u . m) . 1) . 1;
       % "power" is not unique here.
    if !*mcd or not numberp m or n neq 1
      or atom u or denr simp!* u neq 1 then return simpx1(u,m,n)
      else return mksq(u,m)  % To make pattern matching work.
   end;

symbolic procedure posnump u;
   % True if u is a positive number. Test is naive but correct.
   if atom u then (numberp u and u>0) or u memq '(e pi)
    else if car u memq '(expt plus quotient sqrt times)
     then posnumlistp cdr u
    else nil;

symbolic procedure posnumlistp u;
   null u or posnump car u and posnumlistp cdr u;

% symbolic procedure alg_constant_exptp(u,v);
%    % U an expression, v a standard quotient.
%    alg_constantp u and alg_constantp car v and alg_constantp cdr v;

% symbolic procedure alg_constantp u;
%    % True if u is an algebraic constant whose surd is unique.
%    if atom u then numberp u
%    else if car u memq
%        '(difference expt plus minus quotient sqrt times)
%      then alg_constant_listp cdr u
%     else nil;

% symbolic procedure alg_constant_listp u;
%    null u or alg_constantp car u and alg_constant_listp cdr u;

put('expt,'simpfn,'simpexpt);

symbolic procedure split!-sign u;
  % U is a list of factors. Split into positive, negative
  % and unknown sign part. Nil if no sign is known.
  begin scalar p,n,w,s;
    for each f in u do
      if 1=(s:=sign!-of f) then p:=f.p else if -1=s then n:=f.n
          else w:=f.w;
    if null p and null n then return nil;
    return p.n.w;
  end;

symbolic procedure conv2gid(u,d);
   if null u or numberp u or eqcar(u,'!:gi!:) then d
    else if domainp u
     then if eqcar(u,'!:crn!:) then lcm(d,lcm(cdadr u,cdddr u))
           else if eqcar(u,'!:rn!:) then lcm(d,cddr u) else d
    else conv2gid(lc u,conv2gid(red u,d));

symbolic procedure conv2gi2 u;
   if null u then u
   else if numberp u then u * den!*
   else if eqcar(u,'!:gi!:) then '!:gi!:.((den!**cadr u).(den!**cddr u))
   else if eqcar(u,'!:crn!:)
    then <>
           else if fixp m then
                   if fixp n then <<
                      if flg then m := -m;
                      z := m;
                      if !*mcd and (fixp u or null !*notseparate)
                        then <>>>
                       else m := 0;
                      x := simpexpt list(u,m);
                      if z=0 then return x
                      else if n=2 and !*keepsqrts
                       then <>;
                              return exptsq(x,z)>>
      % Note the indirect call: the integrator rebinds this property.
      % JHD understands this interaction - don't change without
      % consulting him.  Note that, since KEEPSQRTS is true, SIMPSQRT
      % won't recurse on SIMPEXPT1.
                      else return
                              multsq(x,exptsq(simprad(simp!* u,n),z))>>
                   else <>
                else z:=1
     else if atom m then z:=1
     else if car m eq 'minus then <>
     else if car m eq 'plus and !*expandexpt then <<
         z := 1 ./ 1;
         for each x in cdr m do
             z := multsq(simpexpt list(u,
                         list('quotient,if flg then list('minus,x)
                                               else x,n)),
                           z);
         return z >>
%%   else if car m eq 'times and fixp cadr m and numberp n
%%    then <<
%%      z := gcdn(n,cadr m);
%%      n := n/z;
%%      z := cadr m/z;
%%      m := retimes cddr m >>
%% BEGIN modification by Francis J. Wright:
     else if car m eq 'times and fixp cadr m
      then <<
        if numberp n
          then <>
         else z := cadr m;
        % retimes seems to me to be overkill here, so try just ...
        m := if cdddr m then 'times . cddr m else caddr m>>
%% END   modification by FJW.
     else if car m eq 'quotient and n=1 and !*expandexpt
      then <>
     else z := 1;
     if idp u and not flagp(u,'used!*) then flag(list u,'used!*);
        if u = '(minus 1)
               and n=1
               and null numr simp list('difference,m,'(quotient 1 2))
         then <>;
    u := list('expt,u,if n=1 then m else list('quotient,m,n));
    return mksq(u,if flg then -z else z); %U is already in lowest terms;
    mns: %if numberp m and numberp n and !*rationalizeflag
     %  then return multsq(simpx1(u,n-m,n),invsq simp u) else
    % return invsq simpx1(u,m,n)
    if !*mcd then return invsq simpx1(u,m,n);
    flg := not flg;
    go to a;
   end;

symbolic procedure expf(u,n);
   %U is a standard form. Value is standard form of U raised to
   %negative integer power N. MCD is assumed off;
   %what if U is invertable?;
   if null u then nil
    else if u=1 then u
    else if atom u then mkrn(1,u**(-n))
    else if domainp u then !:expt(u,n)
    else if red u then mksp!*(u,n)
    else (lambda x; if x>0 and sfp mvar u
             then multf(exptf(mvar u,x),expf(lc u,n))
            else mvar u .** x .* expf(lc u,n) .+ nil)
     (ldeg u*n);

% ******* The "radical simplifier" section ******

symbolic procedure simprad(u,n);
   % Simplifies radical expressions.
   if !*reduced then multsq(radfa(numr u,n),invsq radfa(denr u,n))
     else begin scalar iflag,x,y,z;
       if !*rationalize then << % Move all radicands into numerator.
          y:=list(denr u,1); % A partitioned expression.
          u:=multf(numr u, exptf(denr u,n-1)) ./ 1 >>
         else y := radf(denr u,n);
       if n=2 and minusf numr u % Should this be 'evenp n'?
         then <>
        else x := radf(numr u,n);
       z := simp list('quotient,retimes cdr x, retimes cdr y);
       if domainp numr z and domainp denr z
      % This test allows transformations like sqrt(2/3)=>sqrt(2)/sqrt(3)
      % whereas we really don't want to do this for symbolic elements
      % since we can introduce paradoxes that way.
         then z := multsq(mkrootsq(prepf numr z,n),
                          invsq mkrootsq(prepf denr z,n))
        else <>;
               z := mkrootsq(prepsq z,n)>>;
       z := multsq(multsq(if !*precise and evenp n
                            then car x ./ 1   % mkabsf0 car x
                           else car x ./ 1, 1 ./ car y), z);
       if iflag then z := multsq(z,mkrootsq(-1,2));
       return z
   end;

symbolic procedure radfa(u,n);
   begin scalar x,y;
      x := fctrf u;
      if numberp car x then x := append(zfactor car x,cdr x)
       else x := (car x ./ 1) . cdr x;
      y := 1 ./ 1;
      for each j in x do y := multsq(y,radfb(car j,cdr j,n));
      return y
   end;

symbolic procedure radfb(u,m,n);
   begin scalar x,y;
      x := radf(u,n);
    % if !*precise and evenp n then y := mkabsf0 car x ./ 1 else
      y := exptf(car x,m) ./ 1;
      return multsq(exptsq(mkrootlsq(cdr x,n),m),y)
   end;

symbolic procedure mkrootlsq(u,n);
   % U is a list of prefix expressions, N an integer.
   % Value is standard quotient for U**(1/N);
   % NOTE we need the REVAL call so that PREPSQXX is properly called on
   % the argument for consistency with the pattern matcher.  Otherwise
   % for all x,y let sqrt(x)*sqrt(y)=sqrt(x*y); sqrt(30*(l+1))*sqrt 5;
   % goes into an infinite loop.
   if null u then !*d2q 1
    else if null !*reduced then mkrootsq(reval retimes u,n)
    else mkrootlsq1(u,n);

symbolic procedure mkrootlsq1(u,n);
   if null u then !*d2q 1
    else multsq(mkrootsq(car u,n),mkrootlsq1(cdr u,n));

symbolic procedure mkrootsq(u,n);
   % U is a prefix expression, N an integer.
   % Value is a standard quotient for U**(1/N).
   if u=1 then !*d2q 1
    else if n=2 and (u= -1 or u= '(minus 1)) then simp 'i
    else if eqcar(u,'expt) and fixp caddr u and null !*precise_complex
     then exptsq(mkrootsq(cadr u,n),caddr u)
    else begin scalar x,y;
            if fixp u and not minusp u
                      and (length(x :=
                            zfactor1(u,u1
                           or cdar x>1)
              then return mkrootsql(x,n);
            x := if n=2 then mksqrt u
                  else list('expt,u,list('quotient,1,n));
            if y := opmtch x then return simp y
             else return mksq(x,1)
         end;

symbolic procedure mkrootsql(u,n);
   if null u then !*d2q 1
    else if cdar u>1
     then multsq(exptsq(mkrootsq(caar u,n),cdar u),mkrootsql(cdr u,n))
    else multsq(mkrootsq(caar u,n),mkrootsql(cdr u,n));


comment The following four procedures return a partitioned root
    expression, which is a dotted pair of integral part (a standard
    form) and radical part (a list of prefix expressions). The whole
    structure represents U**(1/N);

symbolic procedure check!-radf!-sign(rad,result,n);
   % Changes the sign of result if result**n = -rad. rad and result are
   % s.f.'s, n is an integer.
   (if evenp n and s = -1 or
       not evenp n and numberp s and
        ((numberp s1 and s neq s1)
           where s1 = reval {'sign,mk!*sq !*f2q rad})
      then negf result
     else result)
    where s = reval{'sign,mk!*sq !*f2q result};

symbolic procedure radf(u,n);
   % U is a standard form, N a positive integer. Value is a partitioned
   % root expression for U**(1/N).
   begin scalar ipart,rpart,x,y,z,!*gcd,!*mcd;
      if null u then return list u;
      !*gcd := !*mcd := t;  % mcd cannot be off in this code.
      ipart := 1;
      z := 1;
      while not domainp u do
     <>;
       x := quotf(u,comfac!-to!-poly y);   % We need *exp on here.
       u := cdr y;
       if !*reduced and minusf x
         then <>;
       if flagp(dmode!*,'field) then
          <>>>;
       if x neq 1
         then <>;
                rpart := append(rpart,cdr x)>>>>;
      if u neq 1
    then <>;
      if z neq 1
    then if !*numval
        and (y := domainvalchk('expt,
                       list(!*f2q z,!*f2q !:recip n)))
           then ipart := multd(!*q2f y,ipart)
          else rpart := prepf z . rpart;  % was aconc(rpart,z).
      return ipart . rpart
   end;

symbolic procedure radf1(u,n);
   %U is a form_power list, N a positive integer. Value is a
   %partitioned root expression for U**(1/N);
   begin scalar ipart,rpart,x;
      ipart := 1;
      for each z in u do
     <>;
      return ipart . rpart
   end;

symbolic procedure radd(u,n);
   %U is a domain element, N an integer.
   %Value is a partitioned root expression for U**(1/N);
   begin scalar bool,ipart,x;
      if not atom u then return list(1,prepf u);
%      then if x := integer!-equiv u then u := x
%            else return list(1,prepf u);
      if u<0 and evenp n then <>;
      x := nrootnn(u,n);
      if bool then if !*reduced and n=2
             then <>
            else <>
       else <>;
      return if x=1 then list ipart else list(ipart,x)
   end;

% symbolic procedure iroot(m,n);
%    %M and N are positive integers.
%   %If M**(1/N) is an integer, this value is returned, otherwise NIL;
%   begin scalar x,x1,bk;
%      if m=0 then return m;
%      x := 10**iroot!-ceiling(lengthc m,n);   %first guess;
%   a: x1 := x**(n-1);
%      bk := x-m/x1;
%      if bk<0 then return nil
%       else if bk=0 then return if x1*x=m then x else nil;
%      x := x - iroot!-ceiling(bk,n);
%      go to a
%   end;

 symbolic procedure iroot(n,r);
    % N, r are integers; r >= 1.  If n is an exact rth power then its
    % rth root is returned, otherwise NIL.
    begin scalar tmp;
       tmp := irootn(n,r);
       return if tmp**r = n then tmp else nil
  end;

symbolic procedure iroot!-ceiling(m,n);
   %M and N are positive integers. Value is ceiling of (M/N) (i.e.,
   %least integer greater or equal to M/N);
   (lambda x; if cdr x=0 then car x else car x+1) divide(m,n);

symbolic procedure mkexpt(u,n);
   if n=1 then u else list('expt,u,n);

% The following definition is due to Eberhard Schruefer.

symbolic procedure nrootn(n,x);
   % N is an integer, x a positive integer. Value is a pair
   % of integers r,s such that r*s**(1/x)=n**(1/x).
   begin scalar fl,r,s,m,signn;
     r := 1;
     s := 1;
     if n<0 then <>;
     fl := zfactor n;
     for each j in fl do
         <>;
     if signn then s := -s;
     return r . s
   end;

% symbolic procedure nrootn(n,x);
%   % N is an integer, X a positive integer. Value is a pair
%   % of integers I,J such that I*J**(1/X)=N**(1/X).
%   begin scalar i,j,r,signn;
%      r := 1;
%      if n<0 then <>;
%      j := 2**x;
%      while remainder(n,j)=0 do <>;
%      i := 3;
%      j := 3**x;
%      while j<=n do
%         <>;
%           if remainder(i,3)=1 then i := i+4 else i := i+2;
%           j := i**x>>;
%      if signn then n := -n;
%      return r . n
%   end;

switch precise_complex;

put('precise_complex,'simpfg,'((t nil) (nil (rmsubs))));

% ***** simplification functions for other explicit operators *****

symbolic procedure simpiden u;
   % Convert the operator expression U to a standard quotient.
   % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1
   % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a
   % loop in the pattern matcher.
   begin scalar bool,fn,x,y,z;
    fn := car u; u := cdr u;
    % Allow prefix ops with names of symbolic functions.
    if (get(fn,'!:rn!:) or get(fn,'!:rd!:)) and (x := valuechk(fn,u))
      then return x;
    % Keep list arguments in *SQ form.
    if u and eqcar(car u,'list) and null cdr u
      then return mksq(list(fn,aeval car u),1);
    x := for each j in u collect aeval j;
    u := for each j in x collect
              if eqcar(j,'!*sq) then prepsqxx cadr j
               else if numberp j then j
               else <>;
%   if u and car u=0 and (flagp(fn,'odd) or flagp(fn,'oddreal))
    if u and car u=0 and flagp(fn,'odd)
         and not flagp(fn,'nonzero)
      then return nil ./ 1;
    u := fn . u;
    if flagp(fn,'noncom) then ncmp!* := t;
    if null subfg!* then go to c
     else if flagp(fn,'linear) and (z := formlnr u) neq u
      then return simp z
     else if z := opmtch u then return simp z;
 %   else if z := get(car u,'opvalfn) then return apply1(z,u);
 %    else if null bool and (z := domainvalchk(fn,
 %                for each j in x collect simp j))
 %     then return z;
    c:  if flagp(fn,'symmetric) then u := fn . ordn cdr u
     else if flagp(fn,'antisymmetric)
      then <>;
%    if (flagp(fn,'even) or flagp(fn,'odd))
%       and x and minusf numr(x := simp car x)
%     then <>;
    u := mksq(u,1);
    return if y then negsq u else u
   end;

switch rounded;

symbolic procedure not_imag_num a;
 % Tests true if a is a number that is not a pure imaginary number.
 % Rebinds sqrtfn and *keepsqrts to make integrator happy.
   begin scalar !*keepsqrts,!*msg,!*numval,dmode,sqrtfn;
      dmode := dmode!*;
      !*numval := t;
      sqrtfn := get('sqrt,'simpfn);
      put('sqrt,'simpfn,'simpsqrt);
      on rounded,complex;
      a := resimp simp a;
      a := numberp denr a and domainp numr a and numr repartsq a;
      off rounded,complex;
      if dmode then onoff(get(dmode,'dname),t);
      put('sqrt,'simpfn,sqrtfn);
      return a
   end;

flagop even,odd,nonzero;

symbolic procedure domainvalchk(fn,u);
   begin scalar x;
      if (x := get(dmode!*,'domainvalchk)) then return apply2(x,fn,u);
      % The later arguments tend to be smaller ...
      u := reverse u;
  a:  if null u then return valuechk(fn,x)
       else if denr car u neq 1 then return nil;
      x := mk!*sq car u . x;
      u := cdr u;
      go to a
   end;

symbolic procedure valuechk(fn,u);
   begin scalar n;
      if (n := get(fn,'number!-of!-args)) and length u neq n
         or not n
            and u and cdr u and (get(fn,'!:rd!:) or get(fn,'!:rn!:))
       then rerror(alg,17,list("Wrong number of arguments to",fn));
      u := opfchk!!(fn . u);
      if u then return znumrnil
          ((if eqcar(u,'list) then list((u . 1) . 1) else u) ./ 1)
   end;

symbolic procedure znumrnil u; if znumr u then nil ./ 1 else u;

symbolic procedure znumr u;
   null (u := numr u) or numberp u and zerop u
   or not atom u and domainp u and
     (y and apply1(y,u) where y=get(car u,'zerop));

symbolic procedure opfchk!! u;
   begin scalar fn,fn1,sf,sc,int,ce; fn1 := fn := car u; u := cdr u;
     % first save fn and check to see whether fn is defined.
     % Integer functions are defined in !:rn!:,
     % real functions in !:rd!:, and complex functions in !:cr!:.
      fn := if flagp(fn,'integer) then <>
         else if !*numval and dmode!* memq '(!:rd!: !:cr!:)
            then get(fn,'!:rd!:);
      if not fn then return nil;
      sf := if int then 'simprn
         else if (sf := get(fn,'simparg)) then sf else 'simprd;
     % real function fn is defined.  now check for complex argument.
      if int or not !*complex then go to s; % the simple case.
     % mode is complex, so check for complex argument.
     % list argument causes a slight complication.
      if eqcar(car u,'list)
         then if (sc := simpcr revlis cdar u) and eqcar(sc,nil)
            then go to err else go to s;
      if not (u := simpcr revlis u) then return nil
     % if fn1 = 'expt, then evaluate complex function only; else
     % if argument is real, evaluate real function, but if error
     % occurs, then evaluate complex function.
      else if eqcar(u,nil) or
          fn1 eq 'expt and rd!:minusp caar u then u := cdr u
         else <>;
     % argument is complex or real function failed.
     % now check whether complex fn is defined.
 evc: if fn := get(fn1,'!:cr!:) then go to a;
 err: rerror(alg,18,list(fn1,"is not defined as complex function"));
   s: if not (u := apply1(sf, revlis u)) then return nil;
   a: u := errorset!*(list('apply,mkquote fn,mkquote u),nil);
      if errorp u then
         if ce then <> else return nil
       else return if int then intconv car u else car u
   end;

symbolic procedure intconv x;
   if null dmode!* or dmode!* memq '(!:rd!: !:cr!:) then x
   else apply1(get(dmode!*,'i2d),x);

symbolic procedure simpcr x;
 % Returns simprd x if all args are real, else nil . "simpcr" x.
  if atom x then nil else
   <<(<>;

symbolic procedure simprd x;
   % Converts any argument list that can be converted to list of rd's.
   if atom x then nil else <>
        where b=simp!* a);
    if not fl then return x
   end;

symbolic procedure mconv v; <>;

symbolic procedure dmconv0 dmd;
   dmd!* := if null dmd then '!:rn!:
        else if dmd eq '!:gi!: then '!:crn!: else dmd;

symbolic procedure dmconv1 v;
   if null v or eqcar(v,dmd!*) then v
   else if atom v then if flagp(dmd!*,'convert)
      then apply1(get(dmd!*,'i2d),v) else v
   else if domainp v then apply1(get(car v,dmd!*),v)
   else lpow v .* dmconv1(lc v) .+ dmconv1(red v);

symbolic procedure mconv1 v;
   if domainp v then drnconv v
   else lpow v .* mconv1(lc v) .+ mconv1(red v);

symbolic procedure drnconv v;
   if null v or numberp v or eqcar(v,dmd!*) then v else
   <<(if y and atom y then apply1(y,v) else v)
   where y=get(car v,dmd!*)>>;

% Absolute Value Function.

symbolic procedure simpabs u;
   if null u or cdr u then mksq('abs . revlis u, 1)  % error?.
    else begin scalar x;
      u := car u;
      if numberp u then return abs u ./ 1
       else if x := sign!-abs u then return x;
      u := simp!* u;
      return if null numr u then nil ./ 1
        else quotsq(simpabs1 numr u, simpabs1 denr u);
    end;

symbolic procedure simpabs1 u;
   % Currently abs(sqrt(2)) does not simplify, whereas it clearly
   % should simplify to just sqrt(2).  The facts that abs(i) -> 1 and
   % abs(sqrt(-2)) -> abs(sqrt(2)) imply that REDUCE regards abs as
   % the complex modulus function, in which case I think it is always
   % correct to commute abs and sqrt.  However, I will do this only if
   % the result is a simplification.  FJW, 18 July 1998
   begin scalar x,y,w;
      x:=prepf u; u := u ./ 1;
      if eqcar(x,'minus) then x:=cadr x;
      % FJW: abs sqrt y -> sqrt abs y if abs y simplifies.
      if eqcar(x,'sqrt) then
         return !*kk2q if eqcar(y:=reval('abs.cdr x), 'abs)
         then {'abs, x} else {'sqrt, y};
%%    if eqcar(x,'times) and (y:=split!-sign cdr x) then
%%    <>
%%    >>;
      if eqcar(x,'times) then
      begin scalar abslist, noabs;
         for each fac in cdr x do
            % FJW: abs sqrt y -> sqrt abs y if abs y simplifies.
            if eqcar(fac,'sqrt)
               and not eqcar(y:=reval('abs.cdr fac), 'abs)
            then noabs := {'sqrt, y} . noabs
            else abslist := fac . abslist;
         abslist := reversip abslist;
         if noabs then
            u := quotsq(u, noabs := simp!*('times . reversip noabs));
         if (y:=split!-sign abslist) then
         <>;
            if noabs then w := multsq(noabs, w)
         >>
         else w := noabs
      end;
      if numr u neq 1 or denr u neq 1 then
         u:=quotsq(mkabsf1 absf numr u,mkabsf1 denr u);
      if w then u:=multsq(w,u);
      return u
   end;

%symbolic procedure rd!-abs u;
%   % U is a prefix expression.  If it represents a constant, return the
%   % abs of u.
%   (if !*rounded or not constant_exprp u then nil
%    else begin scalar x,y,dmode!*;
%           setdmode('rounded,t) where !*msg := nil;
%           x := aeval u;
%           if evalnumberp x
%             then if null !*complex or 0=reval {'impart,x}
%                    then y := if evalgreaterp(x,0) then u
%                               else if evalequal(x,0) then 0
%                               else {'minus,u};
%           setdmode('rounded,nil) where !*msg := nil;
%           return if y then simp y else nil
%       end) where alglist!*=alglist!*;

symbolic procedure sign!-abs u;
   % Sign based evaluation of abs - includes the above rd!-abs
   % method as sub-branch.
    <> where n=sign!-of u;

symbolic procedure constant_exprp u;
   % True if u evaluates to a constant (i.e., number).
   if atom u
     then numberp u or flagp(u,'constant) or u eq 'i and idomainp()
    else (flagp(car u,'realvalued)
             or flagp(car u,'alwaysrealvalued)
             or car u memq '(plus minus difference times quotient)
             or get(car u,'!:rd!:)
             or !*complex and get(car u,'!:cr!:))
          and not atom cdr u
          and constant_expr_listp cdr u;

symbolic procedure constant_expr_listp u;
   % True if all members of u are constant_exprp.
   % U can be a dotted pair as well as a list.
   if atom u
     then null u or numberp u or flagp(u,'constant)
        or u eq 'i and idomainp()
    else constant_exprp car u and constant_expr_listp cdr u;

symbolic procedure mkabsf0 u; simp{'abs,mk!*sq !*f2q u};

symbolic procedure mkabsf1 u;
   if domainp u then mkabsfd u
    else begin scalar x,y,v;
           x := comfac!-to!-poly comfac u;
           u := quotf1(u,x);
           y := split!-comfac!-part x;
           x := cdr y;
           y := car y;
           if positive!-sfp u then <>;
           u := multf(u,x);
           v := lnc y;
           y := quotf1(y,v);
           v := multsq(mkabsfd v,y ./ 1);
           return if u = 1 then v
                   else multsq(v,simpiden list('abs,prepf absf u))
        end;

symbolic procedure mkabsfd u;
   if null get('i,'idvalfn) then absf u ./ 1
    else (simpexpt list(prepsq nrm,'(quotient 1 2))
          where nrm = addsq(multsq(car us,car us),
                             multsq(cdr us,cdr us))
          where us = splitcomplex u);

symbolic procedure positive!-sfp u;
   if domainp u
      then if get('i,'idvalfn)
              then !:zerop impartf u and null !:minusp repartf u
            else null !:minusp u
    else positive!-powp lpow u and positive!-sfp lc u
         and positive!-sfp red u;

symbolic procedure positive!-powp u;
   not atom car u and caar u memq '(abs norm);

% symbolic procedure positive!-powp u;
%    % This definition allows for the testing of positive valued vars.
%    if atom car u then flagp(car u, 'positive)
%     else ((if x then apply2(x,car u,cdr u) else nil)
%           where x = get(caar u,'positivepfn));

symbolic procedure split!-comfac!-part u;
   split!-comfac(u,1,1);

symbolic procedure split!-comfac(u,v,w);
   if domainp u then multd(u,v) . w
    else if red u then
       if positive!-sfp u then multf(u,v) . w
        else v . multf(u,w)
    else if mvar u eq 'i then split!-comfac(lc u,v,w)
    else if positive!-powp lpow u
      then split!-comfac(lc u,multpf(lpow u,v),w)
    else split!-comfac(lc u,v,multpf(lpow u,w));

put('abs,'simpfn,'simpabs);

symbolic procedure simpdiff u;
   <>;

put('difference,'simpfn,'simpdiff);

symbolic procedure simpminus u;
   negsq simp carx(u,'minus);

put('minus,'simpfn,'simpminus);

symbolic procedure simpplus u;
   begin scalar z;
     if length u=2 then ckpreci!# u;
     z := nil ./ 1;
  a: if null u then return z;
     z := addsq(simpcar u,z);
     u := cdr u;
     go to a
   end;

put('plus,'simpfn,'simpplus);

symbolic procedure ckpreci!# u;
   % Screen for complex number input.
   !*complex
      and (if a and not b then ckprec2!#(cdar u,cadr u)
            else if b and not a then ckprec2!#(cdadr u,car u))
            where a=timesip car u,b=timesip cadr u;

symbolic procedure timesip x; eqcar(x,'times) and 'i memq cdr x;

symbolic procedure ckprec2!#(im,rl);
   % Strip im and rl to domains.
   <>;

remflag('(!?a2bf),'lose);   % Until things stabilize.

symbolic smacro procedure make!:ibf (mt, ep);
   '!:rd!: . (mt . ep);

symbolic smacro procedure i2bf!: u; make!:ibf (u, 0);

symbolic procedure !?a2bf a;
   % Convert decimal or integer to bfloat.
   if atom a then if numberp a then i2bf!: a else nil
    else if eqcar(a,'!:dn!:) then a;

symbolic procedure ckprec3!#(x,y);
  % if inputs are valid, check for precision increase.
   if x and y then
   precmsg max(length explode abs cadr x+cddr x,
               length explode abs cadr y+cddr y);

symbolic procedure simpquot q;
   (if null numr u
      then if null numr v then rerror(alg,19,"0/0 formed")
            else rerror(alg,20,"Zero divisor")
     else if dmode!* memq '(!:rd!: !:cr!:) and domainp numr u
        and domainp denr u and domainp denr v
            and !:onep denr u and !:onep denr v
      then (if null numr v then nil else divd(numr v,numr u)) ./ 1
     else <>)
   where v=simpcar q,u=simp cadr q;

put('quotient,'simpfn,'simpquot);

symbolic procedure simprecip u;
   if null !*mcd then simpexpt list(carx(u,'recip),-1)
    else invsq simp carx(u,'recip);

put('recip,'simpfn,'simprecip);

symbolic procedure simpset u;
  begin scalar x;
     x := prepsq simp!* car u;
     if null x % or not idp x
       then typerr(x,"set variable");
     let0 list(list('equal,x,mk!*sq(u := simp!* cadr u)));
     return u
  end;

put ('set, 'simpfn, 'simpset);

symbolic procedure simpsqrt u;
   if u=0 then nil ./ 1 else
   if null !*keepsqrts
     then simpexpt1(car u, simpexpon '(quotient 1 2), nil)
    else begin scalar x,y;
       x := xsimp car u;
       return if null numr x then nil ./ 1
               else if denr x=1 and domainp numr x and !:minusp numr x
                then if numr x=-1 then simp 'i
                      else multsq(simp 'i,
                                  simpsqrt list prepd !:minus numr x)
               else if y := domainvalchk('sqrt,list x) then y
               else simprad(x,2)
     end;

symbolic procedure xsimp u; expchk simp!* u;

symbolic procedure simptimes u;
   begin scalar x,y;
    if null u then return 1 ./ 1;
    if tstack!* neq 0 or null mul!* then go to a0;
    y := mul!*;
    mul!* := nil;
    a0: tstack!* := tstack!*+1;
    x := simpcar u;
    a:    u := cdr u;
    if null numr x then go to c
     else if null u then go to b;
    x := multsq(x,simpcar u);
    go to a;
    b:    if null mul!* or tstack!*>1 then go to c;
    x:= apply1(car mul!*,x);
    alglist!* := nil . nil;   % since we may need MUL!* set again.
    mul!*:= cdr mul!*;
    go to b;
    c:    tstack!* := tstack!*-1;
    if tstack!* = 0 then mul!* := y;
    return x;
   end;

put('times,'simpfn,'simptimes);

symbolic procedure resimp u;
   % U is a standard quotient.
   % Value is the resimplified standard quotient.
   resimp1 u where varstack!*=nil;

symbolic procedure resimp1 u;
   begin
      u := quotsq(subf1(numr u,nil),subf1(denr u,nil));
      !*sub2 := t;
      return u
   end;

symbolic procedure simp!*sq u;
   if cadr u and null !*resimp then car u else resimp1 car u;

put('!*sq,'simpfn,'simp!*sq);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/intro.red0000644000175000017500000003034311526203062023101 0ustar  giovannigiovannimodule intro;  % Introductory material for algebraic mode.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*cref !*exp !*factor !*fort !*ifactor !*intstr !*lcm !*mcd
        !*msg !*mode !*nat !*nero !*period !*precise !*pri !*protfg
        !*rationalize !*reduced !*sub2 !*varopt !*wsm posn!* subfg!*);

global '(!*resubs
         !*val
         erfg!*
         exlist!*
         initl!*
         nat!*!*
         ofl!*
         simpcount!*
         simplimit!*
         tstack!*);

% Non-local variables needing top level initialization.

!*exp := t;             % expansion control flag;
!*lcm := t;             % least common multiple computation flag;
!*mcd := t;             % common denominator control flag;
!*mode := 'symbolic;    % current evaluation mode;
!*msg := t;             % flag controlling message printing;
!*nat := t;             % specifies natural printing mode;
!*period := t;          % prints a period after a fixed coefficient
                        % when FORT is on;
!*precise := t;         %  Specifies more precise handling of surds.
!*resubs := t;          % external flag controlling resubstitution;
!*val := t;             % controls operator argument evaluation;
!*varopt := t;          % Used by SOLVE, etc.
exlist!* := '((!*));    % property list for standard forms used as
                        %  kernels;
initl!* := append('(subfg!* !*sub2 tstack!*),initl!*);
simpcount!* := 0;       % depth of recursion within simplifier;
simplimit!* := 2000;    % allowed recursion limit within simplifier;
subfg!* := t;           % flag to indicate whether substitution
                        % is required during evaluation;
tstack!* := 0;          % stack counter in SIMPTIMES;

% Initial values of some global variables in BEGIN1 loops.

put('subfg!*,'initl,t);

put('tstack!*,'initl,0);


% Description of some non-local variables used in algebraic mode.

% alglist!* := nil . nil; %association list for previously simplified
                        %expressions;
% asymplis!* := nil;    %association list of asymptotic replacements;
% cursym!*              current symbol (i. e. identifier, parenthesis,
%                       delimiter, e.t.c,) in input line;
% dmode!* := nil;       %name of current polynomial domain mode if not
                        %integer;
% domainlist!* := nil;  %list of currently supported poly domain modes;
% dsubl!* := nil;       %list of previously calculated derivatives of
                        % expressions;
% exptl!* := nil;       %list of exprs with non-integer exponents;
% frlis!* := nil;       %list of renamed free variables to be found in
                        %substitutions;
% kord!* := nil;        %kernel order in standard forms;
% kprops!* := nil;      %list of active non-atomic kernel plists;
% mchfg!* := nil;       %indicates that a pattern match occurred during
                        %a cycle of the matching routines;
% mul!* := nil;         %list of additional evaluations needed in a
                        %given multiplication;
% nat!*!* := nil;       %temporary variable used in algebraic mode;
% ncmp!* := nil;        %flag indicating non-commutative multiplication
                        %mode;
% ofl!* := nil;         %current output file name;
% posn!* := nil;        %used to store output character position in
                        %printing functions;
% powlis!* := nil;      %association list of replacements for powers;
% powlis1!* := nil;     %association list of conditional replacements
                        %for powers;
% subl!* := nil;        %list of previously evaluated expressions;
% wtl!* := nil;         %tells that a WEIGHT assignment has been made;
% !*ezgcd := nil;       %ezgcd calculation flag;
% !*float := nil;       %floating arithmetic mode flag;
% !*fort := nil;        %specifies FORTRAN output;
% !*gcd := nil;         %greatest common divisor mode flag;
% !*group := nil;       %causes expressions to be grouped when EXP off;
% !*intstr := nil;      %makes expression arguments structured;
% !*int                 indicates interactive system use;
% !*match := nil;       %list of pattern matching rules;
% !*nero := nil;        %flag to suppress printing of zeros;
% !*nosubs := nil;      %internal flag controlling substitution;
% !*numval := nil;      %used to indicate that numerical expressions
                        %should be converted to a real value;
% !*outp := nil;        %holds prefix output form for extended output
                        %package;
% !*pri := nil;         %indicates that fancy output is required;
% !*reduced := nil;     %causes arguments of radicals to be factored.
                        %E.g., sqrt(-x) --> i*sqrt(x);
% !*sub2 := nil;        %indicates need for call of RESIMP;


% ***** UTILITY FUNCTIONS *****.

symbolic procedure mkid(x,y);
  % creates the ID XY from identifier X and (evaluated) object Y.
  if not idp x then typerr(x,"MKID root")
   else if atom y and (idp y or fixp y and not minusp y)
    then intern compress nconc(explode x,explode y)
   else typerr(y,"MKID index");

flag('(mkid),'opfn);

symbolic procedure multiple!-result(z,w);
   % Z is a list of items (n . prefix-form), in ordering in descending
   % order wrt n, which must be non-negative.  W is either an array
   % name, another id, a template for a multi-dimensional array or NIL.
   % Elements of Z are accordingly stored in W if it is non-NIL, or
   % returned as a list otherwise.
   begin scalar x,y;
        if null w then return 'list . reversip!* fillin z;
        x := getrtype w;
        if x and not(x eq 'array) then typerr(w,"array or id");
        lpriw("*****",
              list(if x eq 'array then "ARRAY" else "ID",
                   "fill no longer supported --- use lists instead"));
        if atom w then (if not arrayp w
           then (if numberp(w := reval w) then typerr(w,'id)))
         else if not arrayp car w then typerr(car w,'array)
         else w := car w . for each x in cdr w
                            collect if x eq 'times then x else reval x;
        x := length z-1;  % don't count zeroth element;
        if not((not atom w and atom car w
                         and (y := dimension car w))
             or ((y := dimension w) and null cdr y))
         then <>;
                lprim if length w=1 then list(car w,"is non zero")
                       else aconc!*(reversip!* w,"are non zero");
                return x>>
         else if atom w
          then <>;
                 w := list(w,'times)>>;
        y := pair(cdr w,y);
        while y and not smemq('times,caar y) do y := cdr y;
        if null y then errach "MULTIPLE-RESULT";
        y := cdar y-reval subst(0,'times,caar y)-1;
           %-1 needed since DIMENSION gives length, not highest index;
        if caar z>y
          then rerror(alg,3,list("Index",caar z,"out of range"));
        repeat
           if null z or y neq caar z
             then setelv(subst(y,'times,w),0)
            else <>
          until (y := y-1) < 0;
        return x
   end;

symbolic procedure fillin u;
   % fills in missing terms in multiple result argument list u
   % and returns list of coefficients.
   if null u then nil else fillin1(u,caar u);

symbolic procedure fillin1(u,n);
   if n<0 then nil
    else if u and caar u=n then cdar u . fillin1(cdr u,n-1)
    else 0 . fillin1(u,n-1);


% ***** FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES *****

symbolic procedure msgpri(u,v,w,x,y);
   begin integer posn!*; scalar nat1,z,pline!*;
        if null y and null !*msg then return;
        nat1 := !*nat;
        !*nat := nil;
        if ofl!* and (!*fort or not nat1) then go to c;
    a:  terpri();
        lpri ((if null y then "***" else "*****")
                 . if u and atom u then list u else u);
        posn!* := posn();
        maprin v;
        prin2 " ";
        lpri if w and atom w then list w else w;
        posn!* := posn();
        maprin x;
        terpri!*(t); % if not y or y eq 'hold then terpri();
        if null z then go to b;
        wrs cdr z;
        go to d;
    b:  if null ofl!* then go to d;
    c:  z := ofl!*;
        wrs nil;
        go to a;
    d:  !*nat := nat1;
        if y then if y eq 'hold then erfg!* := y else error1()
   end;

symbolic procedure errach u;
   begin
        terpri!* t;
        lprie "CATASTROPHIC ERROR *****";
        printty u;
        lpriw(" ",nil);
        rerror(alg,4,
   "Please report output and input listing on the sourceforge bug tracker")
   end;

symbolic procedure errpri1 u;
   msgpri("Substitution for",u,"not allowed",nil,t);  % was 'HOLD

symbolic procedure errpri2(u,v);
   msgpri("Syntax error:",u,"invalid",nil,v);

symbolic procedure redmsg(u,v);
    if !*wsm or null !*msg or v neq "operator" then nil
     else if terminalp() then yesp list("Declare",u,v,"?") or error1()
     else lprim list(u,"declared",v);

symbolic procedure typerr(u,v);
   % Note this replaces definition in rlisp/lpri. If outputhandler!* is
   % non-nil I go back to the simple ould version, which may be less
   % pretty but that does not end up with messages getting lost so often!
   if outputhandler!* then rerror('rlisp,6, list(u,"invalid as",v))
   else
   <>
               else if null u then prin2!* u
               else maprin u;
              prin2!* " invalid as "; prin2!* v;
              terpri!* nil>>;
     erfg!* := t; error1()>>;


%                 ***** ALGEBRAIC MODE DECLARATIONS *****

flag ('(aeval cond getel go prog progn prog2 return
        reval setq setk setel assgnpri !*s2i),'nochange);

flag ('(or and not member memq equal neq eq geq greaterp leq
        fixp lessp numberp ordp freeof),'boolean);

flag ('(or and not),'boolargs);

deflist ('((exp ((nil (rmsubs)) (t (rmsubs))))
        (factor ((nil (setq !*exp t) (rmsubs))
                 (t (setq !*exp nil) (rmsubs))))
        (fort ((nil (setq !*nat nat!*!*)) (t (setq !*nat nil))))
        (gcd ((t (rmsubs))))
        (intstr ((nil (rmsubs)) (t (rmsubs))))
        (mcd ((nil (rmsubs)) (t (rmsubs))))
        (nat ((nil (setq nat!*!* nil)) (t (setq nat!*!* t))))
        (numval ((t (rmsubs))))
        (rationalize ((t (rmsubs))))
        (reduced ((t (rmsubs))))
        (val ((t (rmsubs))))),'simpfg);

switch exp,cref,factor,fort,gcd,ifactor,intstr,lcm,mcd,nat,nero,numval,
       period,precise,pri,rationalize,reduced,varopt;   % resubs, val.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/simplog.red0000644000175000017500000001405611526203062023423 0ustar  giovannigiovannixmodule simplog;  % Simplify logarithms.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*intflag!* !*noneglogs !*expandlogs);

global '(domainlist!*);

exports simplog,simplogi,simplogsq;

imports addf,addsq,comfac,quotf,prepf,mksp,simp!*,!*multsq,simptimes,
        minusf,negf,negsq,mk!*sq,carx,multsq,resimp,simpiden,simpplus,
        prepd,mksq,rerror,zfactor,sfchk;

symbolic procedure simplog u;
   (if !*expandlogs then
     (resimp simplogi x where !*expandlogs=nil)
    else if eqcar(x,'quotient) and cadr x=1
      and (null !*precise or realvaluedp caddr x)
     then negsq simpiden('log . cddr x)
    else simpiden u)
    where x=carx(cdr u,'simplog);

put('log,'simpfn,'simplog);

flag('(log),'full);

put('expandlogs,'simpfg,'((nil (rmsubs)) (t (rmsubs))));

put('combinelogs,'simpfg,'((nil (rmsubs)) (t (rmsubs))));

symbolic procedure simplogi(sq);
   % This version will only expand a log if at most one of the
   % arguments is complex.  Otherwise you can finish up on the wrong
   % sheet.
   if atom sq then simplogsq simp!* sq
    else if car sq memq domainlist!* then simpiden list('log,sq)
    else if car sq eq 'times
          then if null !*precise or one_complexlist cdr sq
           then simpplus(for each u in cdr sq collect mk!*sq simplogi u)
          else !*kk2q {'log,sq}
    else if car sq eq 'quotient
       and (null !*precise or one_complexlist cdr sq)
     then addsq(simplogi cadr sq,negsq simplogi caddr sq)
    else if car sq eq 'expt
     then simptimes list(caddr sq,mk!*sq simplogi cadr sq)
    else if car sq eq 'nthroot
     then multsq!*(1 ./ caddr sq,simplogi cadr sq)
    % we had (nthroot of n).
    else if car sq eq 'sqrt then multsq!*(1 ./ 2,simplogi cadr sq)
    else if car sq = '!*sq then simplogsq cadr sq
    else simplogsq simp!* sq;

symbolic procedure one_complexlist u;
   % True if at most one member of list u is complex.
   if null u then t
    else if realvaluedp car u then one_complexlist cdr u
    else null cdr u or realvaluedlist cdr u;

symbolic procedure multsq!*(u,v);
   if !*intflag!* then !*multsq(u,v) else multsq(u,v);

symbolic procedure simplogsq sq;
   % This procedure needs to be reworked to provide for proper sheet
   % handling.
   if null numr sq then rerror(alg,210,"Log 0 formed")
    else if denr sq=1 and domainp numr sq and !:onep numr sq
     then nil ./ 1
    else if !*precise then !*kk2q {'log,prepsq sq}
    else addsq(simplog2 numr sq,negsq simplog2 denr sq);

symbolic procedure simplog2(sf);
 if atom sf
   then if null sf then rerror(alg,21,"Log 0 formed")
      else if numberp sf
       then if sf iequal 1 then nil ./ 1
             else if sf iequal 0 then rerror(alg,22,"Log 0 formed")
             else simplogn sf
      else formlog(sf)
   else if domainp sf then mksq({'log,prepd sf},1)
     else begin scalar form;
        form := comfac sf;
        if not null car form
          then return addsq(formlog(form .+ nil),
                            simplog2 quotf(sf,form .+ nil));
        % We have killed common powers.
        form := cdr form;
        if form neq 1
          then return addsq(simplog2 form,simplog2 quotf(sf,form));
        % Remove a common factor from the sf.
        return formlog sf
     end;

symbolic procedure simplogn u;
   % See comments in formlog for an explanation of the code.
   begin scalar y,z;
      y := zfactor u;
      if car y= '(-1 . 1) and null(y := mergeminus cdr y)
       then return !*kk2q {'log,u};
      for each x in y do
          z := addf(((mksp({'log,car x},1) .* cdr x) .+ nil),z);
      return z ./ 1
   end;

symbolic procedure mergeminus u;
   begin scalar x;
   a: if null u then return nil
       else if remainder(cdar u,2)=1
        then return nconc(reversip x,((-caar u) . cdar u) . cdr u)
       else <>
   end;

symbolic procedure formlog sf;
   % Minus test commented out. Otherwise, we can get:
   % log(a) + log(-1) => log(a*(-1)) => log(-a).
   % log(a) - log(-1) => log(a/(-1)) => log(-a).
   % I.e., log(-a) can be log(a) + log(-1) or log(a) - log(-1).
   if null red sf then formlogterm sf
%   else if minusf sf and null !*noneglogs
%    then addf((mksp(list('log,-1),1) .* 1) .+ nil,
%              formlog2 negf sf) ./ 1
    else (formlog2 sf) ./ 1;

symbolic procedure formlogterm(sf);
   begin scalar u;
      u := mvar sf;
      if not atom u and (car u member '(times sqrt expt nthroot))
         then u := addsq(simplog2 lc sf,
                         multsq!*(simplogi u,simp!* ldeg sf))
        else if (lc sf iequal 1) and (ldeg sf iequal 1)
         then u := ((mksp(list('log,sfchk u),1) .* 1) .+ nil) ./ 1
        else u := addsq(simptimes list(list('log,sfchk u),ldeg sf),
                        simplog2 lc sf);
      return u
   end;

symbolic procedure formlog2 sf;
   ((mksp(list('log,prepf sf),1) .* 1) .+ nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/order.red0000644000175000017500000001302611526203062023060 0ustar  giovannigiovannimodule order; % Functions for internal ordering of expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1999 Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(kord!*);

% symbolic procedure ordad(a,u);
%   if null u then list a
%    else if ordp(a,car u) then a . u
%    else car u . ordad(a,cdr u);

% This definition, due to A.C. Norman, avoids recursion.

symbolic procedure ordad(a,u);
   begin scalar r;
      while u and not ordp(a,car u) do <>;
      u := a . u;
      while r do <>;
      return u
   end;

symbolic procedure ordn u;
   if null u then nil
    else if null cdr u then u
    else if null cddr u then ord2(car u,cadr u)
    else ordad(car u,ordn cdr u);

symbolic procedure ord2(u,v);
   if ordp(u,v) then list(u,v) else list(v,u);



!#if (not (memq 'csl lispsystem!*))

% A version of ordp is provided built-in to CSL and the version there
% is intended to behave just the way that this does. Now until recently I
% had used a LOSE flag to make that the version that got used. However both
% helphy/noncom2 and spde/spde redefine ordp - and if I use a LOSE flag
% then their redefinitions get discarded as well as this one. Hence I am
% moving to the ugly and somwhat unsatisfactory use of !#if. A better
% resolution will be to arrange that neither hephys nor spde redefine
% this function!

symbolic procedure ordp(u,v);
   % Returns TRUE if U ordered ahead or equal to V, NIL otherwise.
   % An expression with more structure at a given level is ordered
   % ahead of one with less.
   if null u then null v
    else if null v then t
    else if vectorp u then if vectorp v then ordpv(u,v) else atom v
    else if atom u
       then if atom v
                then if numberp u then numberp v and not(ulu then i>lv
    else (if x=y then ordpv1(u,v,i,lu,lv) else ordp(x,y))
          where x=getv(u,i),y=getv(v,i);

symbolic procedure ordop(u,v);
   begin scalar x;
        x := kord!*;
    a:  if null x then return ordp(u,v)
         else if u eq car x then return t
         else if v eq car x then return;
        x := cdr x;
        go to a
   end;

symbolic procedure ordpp(u,v);
   % This version is used for addition, where NONCOM properties aren't
   % relevant.
   begin scalar x;
        if car u eq car v then return cdr u>cdr v;
        x := kord!*;
        u := car u;
        v := car v;
    a:  if null x then return ordpa(u,v)
         else if u eq car x then return t
         else if v eq car x then return nil;
        x := cdr x;
        go to a
   end;

symbolic procedure ordpa(u,v);
   % Returns TRUE if U ordered ahead or equal to V, NIL otherwise.
   % An expression with more structure at a given level is ordered
   % ahead of one with less.
   if null u then null v
    else if null v then t
    else if vectorp u then if vectorp v then ordpv(u,v) else atom v
    else if atom u
       then if atom v
                then if numberp u then numberp v and not(u3
        then rerror(alg,28,
                    "COEFF called with wrong number of arguments")
       else return coeff1(car u,cadr u,
                         if null cddr u then nil else caddr u)
      end;

put('coeff,'psopfn,'coeffeval);

symbolic procedure coeff1(u,v,w);
   % Finds the coefficients of V in U and returns results in W.
   % We turn EXP on and FACTOR off to make sure powers of V separate.
   (begin scalar !*factor,bool,x,y,z;
        if eqcar(u,'!*sq) and null !*exp
          then <>
         else <>;
        v := !*a2kwoweight v;
        bool := !*ratarg or freeof(prepf denr u,v);
        if null bool then u := !*q2f u;
        x := updkorder v;
        if null bool then <>
         else <>;
        setkorder x;
        if null y then go to a;
        while not domainp y and mvar y=v
           do <>;
        if null y then go to b;
    a:  z := (0 . !*ff2a(y,u)) . z;
    b:  lowpow!* := caar z;
        z := reverse z;
        hipow!* := caar z;
        z := multiple!-result(z,w);
        return if null w then z else hipow!*
   end) where !*exp = !*exp;

symbolic procedure coeffn(u,v,n);
   % Returns n-th coefficient of U.
   % We turn EXP on and FACTOR off to make sure powers of V separate.
   begin scalar !*exp,!*factor,bool,x,y;
      !*exp := t;
      n := reval n;
      if not fixp n or minusp n then typerr(n,"COEFFN index");
      v := !*a2kwoweight v;
      u := simp!* u;
      bool := !*ratarg or freeof(prepf denr u,v);
      if null bool then u := !*q2f u;
      x := updkorder v;
      if null bool then <>
       else <>;
      setkorder x;
      if null y then return 0; % changed by JHD for consistency
   b: if domainp y or mvar y neq v
        then return if n=0 then !*ff2a(y,u) else 0
       else if n=ldeg y then return !*ff2a(lc y,u)
       else if n>ldeg y then return 0
       else <>
   end;

flag('(coeffn),'opfn);

flag('(coeffn),'noval);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/str.red0000644000175000017500000001246711526203062022565 0ustar  giovannigiovannimodule str;  % Routines for structuring expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*fort !*nat !*savestructr scountr svar svarlis);

global '(varnam!*);

varnam!* := 'ans;

switch savestructr;

flag('(structr),'intfn);        % To fool the supervisor into printing
                                % results of STRUCTR.

% ***** two essential uses of RPLACD occur in this module.

symbolic procedure structr u;
   begin scalar scountr,fvar,svar,svarlis;
      % SVARLIS is a list of elements of form:
      % ( .  . );
      scountr :=0;
      fvar := svar := varnam!*;
      if cdr u
        then <>;
      u := structr1 aeval car u;
      if !*fort then svarlis := reversip!* svarlis
       else if not !*savestructr
        then <>>>;
      if !*fort or not !*savestructr
        then for each x in svarlis do
             <>;
      if !*fort then assgnpri(u,list fvar,t)
       else if !*savestructr
        then return 'list . u .
                        foreach x in svarlis
                           collect list('equal,cadr x,
                                               mkquote cddr x)
   end;

rlistat '(structr);

symbolic procedure structr1 u;
   % This routine considers special case STRUCTR arguments. It could be
   % easily generalized.
   if atom u then u
    else if car u eq 'mat
     then car u .
        (for each j in cdr u collect for each k in j collect structr1 k)
    else if car u eq 'list
     then 'list . for each j in cdr u collect structr1 j
    else if car u eq 'equal then list('equal,cadr u,structr1 caddr u)
    else if car u eq '!*sq
     then mk!*sq(structf numr cadr u ./ structf denr cadr u)
    else if getrtype u then typerr(u,"STRUCTR argument")
    else u;

symbolic procedure structf u;
   if null u then nil
    else if domainp u then u
    else begin scalar x,y;
        x := mvar u;
        if sfp x then if y := assoc(x,svarlis) then x := cadr y
                else x := structk(prepsq!*(structf x ./ 1),
                                  structvar(),x)
%        else if not atom x and not atomlis cdr x
          else if not atom x
             and not(atom car x and flagp(car x,'noreplace))
          then if y := assoc(x,svarlis) then x := cadr y
                else x := structk(x,structvar(),x);
% Suggested patch by Rainer Schoepf to cache powers.
%       if ldeg u = 1
%         then return x .** ldeg u .* structf lc u .+ structf red u;
%       z := retimes exchk list (x .** ldeg u);
%       if y := assoc(z,svarlis) then x := cadr y
%        else x := structk(z, structvar(), z);
%       return x .** 1 .* mystructf lc u .+ mystructf red u
        return x .** ldeg u .* structf lc u .+ structf red u
     end;

symbolic procedure structk(u,id,v);
   begin scalar x;
      if x := subchk1(u,svarlis,id)
        then rplacd(x,(v . id . u) . cdr x)
       else if x := subchk2(u,svarlis)
        then svarlis := (v . id . x) . svarlis
       else svarlis := (v . id . u) . svarlis;
      return id
   end;

symbolic procedure subchk1(u,v,id);
   begin scalar w;
      while v do
       <>;
         v := cdr v>>;
      return w
   end;

symbolic procedure subchk2(u,v);
   begin scalar bool;
      for each x in v do
       smember(cddr x,u)
          and <>;
      if bool then return u else return nil
   end;

symbolic procedure structvar;
   begin
      scountr := scountr + 1;
      return if arrayp svar then list(svar,scountr)
       else intern compress append(explode svar,explode scountr)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/fac.red0000644000175000017500000000455311526203062022503 0ustar  giovannigiovannimodule fac;  % Support "factor" as an operator.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*micro!-version);

symbolic procedure factor u;
   if !*micro!-version then factor0 u else factor1(u,t,'factors!*);

symbolic procedure factor0 u;
   begin scalar oldexp,v,w;
      if cdr u or kernp (v := simp!* car u)
        then <>;
      oldexp := !*exp;
      !*exp := t;
      if null oldexp then v := resimp v;
      w := !*fcfm2f fctrf numr v ./ !*fcfm2f fctrf denr v;
      if null oldexp then !*exp := oldexp;
%      if w = u or w = v then return u
%       else if null oldexp then return mk!*sq w
%       else return list('!*sq,w,nil)
      return mk!*sq w
    end;

flag('(factor),'intfn);

symbolic procedure !*fcfm2f u;
   % converts factored form u to standard form.
   multf(car u,!*fcfm2f1 cdr u);

symbolic procedure !*fcfm2f1 u;
   if null u then 1 else multpf(mksp(caar u,cdar u),!*fcfm2f1 cdr u);

symbolic procedure expandd u; reval u where !*exp = t;

flag('(expandd),'opfn);

flag('(expandd),'noval);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/nssimp.red0000644000175000017500000001235511526203062023262 0ustar  giovannigiovannimodule nssimp;  % Simplification functions for non-scalar quantities.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*div frlis!* subfg!*);

% Several inessential uses of ACONC, NCONC, and MAPping "JOIN". Latter
% not yet changed.

symbolic procedure nssimp(u,v);
   %U is a prefix expression involving non-commuting quantities.
   %V is the type of U.  Result is an expression of the form
   % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard
   %quotients and the M(I,J) non-commuting expressions;
   %N. B: the products in M(I,J) are returned in reverse order
   %(to facilitate, e.g., matrix augmentation);
   begin scalar r,s,w,x,y,z;
        u := dsimp(u,v);
    a:  if null u then return z;
        w := car u;
    c:  if null w then go to d
         else if numberp(r := car w)
                or not(eqcar(r,'!*div) or
                       (if (s := getrtype r) eq 'yetunknowntype
                          then getrtype(r :=
                                        eval!-yetunknowntypeexpr(r,nil))
                         else s) eq v)
          then x := aconc!*(x,r)
         else y := aconc!*(y,r);
        w := cdr w;
        go to c;
    d:  if null y then go to er;
    e:  z := addns(((if null x then 1 ./ 1 else simptimes x) . y),z);
        u := cdr u;
        x := y:= nil;
        go to a;
    er: y := v;
        if idp car x
          then if not flagp(car x,get(y,'fn)) then redmsg(car x,y)
            else rerror(alg,30,list(y,x,"not set"))
         else if w := get(get(y,'tag),'i2d)
          then <>
         %to allow a scalar to be a 1 by 1 matrix;
         else msgpri(list("Missing",y,"in"),car x,nil,nil,t);
        put(car x,'rtype,y);
        y := list car x;
        x := cdr x;
        go to e
   end;

symbolic procedure dsimp(u,v);
   %result is a list of lists representing a sum of products;
   %N. B: symbols are in reverse order in product list;
   if numberp u then list list u
    else if atom u
     then (if x and subfg!* then dsimp(cadr x,v)
            else if flagp(u,'share) then dsimp(lispeval u,v)
            else <>)
      where x= get(u,'avalue)
    else if car u eq 'plus
     then for each j in cdr u join dsimp(j,v)
    else if car u eq 'difference
     then nconc!*(dsimp(cadr u,v),
                dsimp('minus . cddr u,v))
    else if car u eq 'minus
     then dsimptimes(list(-1,carx(cdr u,'dsimp)),v)
    else if car u eq 'times then dsimptimes(cdr u,v)
    else if car u eq 'quotient
     then dsimptimes(list(cadr u,list('recip,carx(cddr u,'dsimp))),v)
    else if not(getrtype u eq v) then list list u
    else if car u eq 'recip
     then list list list('!*div,carx(cdr u,'dsimp))
    else if car u eq 'expt then (lambda z;
       if not numberp z then errpri2(u,t)
        else if z<0
         then list list list('!*div,'times . nlist(cadr u,-z))
         else if z=0 then list list list('!*div,cadr u,1)
        else dsimptimes(nlist(cadr u,z),v))
      reval_without_mod caddr u
    else if flagp(car u,'noncommuting) then list list u
    else if arrayp car u
       then dsimp(getelv u,v)
    else (if x then dsimp(x,v)
           else ((if z then dsimp(z,v) else {{y}})
                  where z=opmtch y) where y=revop1 u)
          where x=opmtch u;

symbolic procedure dsimptimes(u,v);
   if null u then errach 'dsimptimes
    else if null cdr u then dsimp(car u,v)
    else (lambda j; for each k in dsimptimes(cdr u,v) join mappend(j,k))
          dsimp(car u,v);

symbolic procedure addns(u,v);
   if null v then list u
    else if cdr u=cdar v
       then (lambda x; % if null car x then cdr v else;
                         (x . cdr u) . cdr v)
       addsq(car u,caar v)
    else if ordp(cdr u,cdar v) then u . v
    else car v . addns(u,cdr v);

symbolic procedure getelx u;
   %to take care of free variables in LET statements;
   if smemqlp(frlis!*,cdr u) then nil
    else if null(u := getelv u) then 0
    else reval u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/mkgroup.red0000644000175000017500000000727211526203062023437 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

SYMBOLIC PROCEDURE MKGROUP;
   %Expects a list of statements terminated by a >>;
   BEGIN SCALAR LST,DELIM;
    A:      LST := ACONC(LST,XREAD 'GROUP);
        IF CURSYM!* EQ '!*RSQB!* THEN GO TO B
         ELSE IF NULL DELIM THEN DELIM := CURSYM!*
         ELSE IF NOT(DELIM EQ CURSYM!*)
          THEN SYMERR("Syntax error: mixed , and ; in group",NIL);
        GO TO A;
    B:  SCAN();
        RETURN IF DELIM EQ '!*SEMICOL!* THEN 'PROGN . LST
                ELSE 'VECT . LST
   END;

PUT('!*LSQB!*,'STAT,'MKGROUP);

NEWTOK '((![) !*LSQB!*);

NEWTOK '((!]) !*RSQB!*);

SYMBOLIC PROCEDURE FORMVECT(U,VARS,MODE);
   BEGIN INTEGER N; SCALAR V;
      U := FOR EACH X IN U COLLECT FORM1(X,VARS,MODE); % was FORMC
      V := MKVECT(LENGTH U-1);
      N := 0;
      FOR EACH X IN U DO <>;
      RETURN V
   END;

PUT('VECT,'FORMFN,'FORMVECT);

PUT('VECEXPRP,'EVFN,'EVVECTOR);

SYMBOLIC PROCEDURE !*!*A2S(U,VARS);
   IF U = '(QUOTE NIL) THEN NIL
%   else if eqcar(u,'for) and not(cadddr u eq 'do)
%    then list('foraeval,u)
    ELSE IF VECTORP U THEN LIST(!*!*A2SFN,U)
    ELSE IF NULL U OR CONSTANTP U AND NULL FIXP U
      OR INTEXPRNP(U,VARS) AND NULL !*COMPOSITES
      OR NOT ATOM U AND IDP CAR U
         AND FLAGP(CAR U,'NOCHANGE) AND NOT(CAR U EQ 'GETEL)
     THEN U
    ELSE LIST(!*!*A2SFN,U);

SYMBOLIC PROCEDURE VECEXPRP U;
   % Determines if U is a valid vector expression.
   IF VECTORP U THEN T
    ELSE IF ATOM U THEN NIL
    ELSE IF CAR U EQ 'PLUS THEN VECEXPRLISP CDR U
    ELSE IF CAR U EQ 'TIMES THEN ONEVECEXPRLISP CDR U
    ELSE IF CAR U EQ 'MINUS THEN VECEXPRP CADR U
    ELSE IF CAR U EQ 'QUOTIENT
     THEN VECEXPRP CADR U AND NOT VECEXPRP CADDR U
    ELSE NIL;

SYMBOLIC PROCEDURE VECEXPRLISP U;
   NULL U OR VECEXPRP CAR U AND VECEXPRLISP CDR U;

SYMBOLIC PROCEDURE ONEVECEXPRLISP U;
   IF NULL U THEN NIL
    ELSE IF VECEXPRP CAR U THEN NOTVECEXPRLISP CDR U
    ELSE ONEVECEXPRLISP CDR U;

SYMBOLIC PROCEDURE NOTVECEXPRLISP U;
   NULL U OR NOT VECEXPRP CAR U AND NOTVECEXPRLISP CDR U;

SYMBOLIC PROCEDURE EVVECTOR(u,v);
   % Simplification function for a vector expression.
   IF VECTORP U THEN EVVECT(U,NIL,NIL)
    ELSE NIL;

SYMBOLIC PROCEDURE EVVECT(U,OPR,ARG);
   BEGIN INTEGER N; SCALAR V;
      N := UPBV U;
      V := MKVECT N;
      FOR I := 0:N DO PUTV(V,I,
                           REVAL IF NULL OPR THEN GETV(U,I)
                                  ELSE LIST(OPR,GETV(U,I),ARG));
      RETURN V
   END;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/smallmod.red0000644000175000017500000001205311526203062023554 0ustar  giovannigiovannimodule smallmod; % Small integer modular arithmetic used in factorizer.

% Author: Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Note: when balanced_mod is on, the results here are not always in
% range. *modular2f is used to correct this.

fluid '(!*balanced_mod current!-modulus modulus!/2);

global '(largest!-small!-modulus);

symbolic procedure set!-modulus p; set!-general!-modulus p;

symbolic procedure set!-small!-modulus p;
  begin
    scalar previous!-modulus;
    if p>largest!-small!-modulus
      then rerror(alg,9,list("Overlarge modulus",p,"being used"));
    previous!-modulus:=current!-modulus;
    current!-modulus:=p;
    modulus!/2 := p/2;
    return previous!-modulus
  end;


smacro procedure modular!-plus(a,b);
  begin scalar result;
     result:=a #+ b;
     if not(result #< current!-modulus) then
            result:=result #- current!-modulus;
     return result
  end;

smacro procedure modular!-difference(a,b);
  begin scalar result;
     result:=a #- b;
     if iminusp result then result:=result #+ current!-modulus;
     return result
  end;

symbolic procedure modular!-number a;
  begin
     if not atom a then typerr(a,"integer in modular-number");
     a:=remainder(a,current!-modulus);
     if iminusp a then a:=a #+ current!-modulus;
     return a
  end;

smacro procedure modular!-times(a,b);
    remainder(a*b,current!-modulus);

symbolic procedure modular!-reciprocal a;
   if !*balanced_mod and a<0
     then reciprocal!-by!-gcd(current!-modulus,
                              a #+ current!-modulus,0,1)
    else reciprocal!-by!-gcd(current!-modulus,a,0,1);

symbolic procedure reciprocal!-by!-gcd(a,b,x,y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B;
   if b=0 then rerror(alg,10,"Invalid modular division")
   else if b=1 then if iminusp y then y #+ current!-modulus else y
   else begin scalar w;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     w:= a #/ b; %Truncated integer division;
     return reciprocal!-by!-gcd(b,a #- b #* w,
                                y,x #- y #* w)
   end;

symbolic procedure safe!-modular!-reciprocal a;
   if !*balanced_mod and a<0
     then safe!-reciprocal!-by!-gcd(current!-modulus,
                              a #+ current!-modulus,0,1)
    else safe!-reciprocal!-by!-gcd(current!-modulus,a,0,1);

symbolic procedure safe!-reciprocal!-by!-gcd(a,b,x,y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B. If a and b are not coprime return NIL not an error; 
   if b=0 then nil
   else if b=1 then if iminusp y then y #+ current!-modulus else y
   else begin scalar w;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     w:= a #/ b; %Truncated integer division;
     return safe!-reciprocal!-by!-gcd(b,a #- b #* w,
                                      y,x #- y #* w)
   end;

smacro procedure modular!-quotient(a,b);
    modular!-times(a,modular!-reciprocal b);


smacro procedure modular!-minus a;
    if a=0 then a else current!-modulus #- a;

symbolic procedure modular!-expt(a,n);
   % Computes a**n modulo current-modulus.  Uses Fermat's Little
   % Theorem where appropriate for a prime modulus.
    if n=0 then 1
    else if n=1 then a
    else if n>=current!-modulus-1 and primep current!-modulus
     then modular!-expt(a,remainder(n,current!-modulus-1))
    else begin scalar x;
     x:=modular!-expt(a,n/2);
     x:=modular!-times(x,x);
     if not(remainder(n,2)=0) then x:=modular!-times(x,a);
     return x
    end;

symbolic set!-modulus(1) ; % forces everything into a standard state.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/random.red0000644000175000017500000001315711526203062023232 0ustar  giovannigiovannimodule random;  % Random Number Generator.

% Author: C.J. Neerdaels, with adjustments by A.C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Entrypoints:
%     random_new_seed n Re-seed the random number generator
%     random n          return next value (range 0 <= r < n)
%     next!-random!-number()
%                       return next value in range 0<=r>;
    for k:=1:4 do <<      % Cycle generator a few times to pre-scramble.
      for i:=0:54 do <<
        ml := getv(unidev_vec!*, i) #-
              getv(unidev_vec!*, remainder(i #+ 31,55));
        if iminusp ml then ml := ml #+ randommodulus!*;
        putv(unidev_vec!*, i, ml) >> >>;
    unidev_next!* := 0;
    unidev_nextp!* := 31;
    return nil
  end;

%*************************UNIDEV****************************************

symbolic procedure next!-random!-number;
% Returns a uniform random deviate between 0 and randommodulus!*-1.
  begin scalar mj;
    if unidev_next!* = 54 then unidev!_next!* := 0
     else unidev!_next!* := unidev!_next!* #+ 1;
    if unidev!_nextp!* = 54 then unidev!_nextp!* := 0
     else unidev!_nextp!* := unidev!_nextp!* #+ 1;
    mj := getv(unidev_vec!*, unidev_next!*) #-
          getv(unidev_vec!*, unidev_nextp!*);
    if iminusp mj then mj := mj #+ randommodulus!*;
    putv(unidev_vec!*, unidev_next!*, mj);
    return mj
  end;

symbolic procedure random size;
% Returns a random value in the range 0 <= r < size.
  begin scalar m, r;
    if not numberp size or size <= 0
      then typerr(size,"positive number");
    if floatp size then <<
% next!-random!-number() returns just under 27 bits of randomness, and
% for a properly random double precision (IEEE) value I need 52 or 53
% bits.  So I just call next!-random!-number() twice and glue the bits
% together.
      r := float next!-random!-number() * unidev_fac!*;
      return (float next!-random!-number() + r) * unidev_fac!* * size >>
    else <<
% I first generate a random variate over a range that is some power of
% randommodulus!*.  Then I select from this to restrict my range to be
% an exact multiple of size.  The worst case for this selection is when
% the power of randommodulus!* is just less than twice size, in which
% case on average two trials are needed.  In the vast majority of cases
% the cost of making the selection will be much less.  With a value
% uniform over some multiple of my range I can use simple remaindering
% to get the result.
      repeat <<
        r := next!-random!-number();
        m := randommodulus!*;
        while m < size do <<
          m := m * randommodulus!*;
          r := randommodulus!* * r + next!-random!-number() >>;
        >> until r < m - remainder(m, size);
      return remainder(r, size) >>
  end;

random_new_seed 1;    % Ensure that code is set up ready for use.

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/showrule.red0000644000175000017500000002100711526203062023613 0ustar  giovannigiovannimodule showrule; % Display rules for an operator.

% Author: Herbert Melenk, ZIB, Berlin. E-mail: melenk@zib.de.
% Copyright (c) 1992 ZIB Berlin. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modified by: Francis J. Wright 
% Time-stamp: <10 November 1998>

% $Id: showrule.red 1.2 1998-11-10 08:33:09+00 fjw Exp $

global '(!*match);

fluid '(asymplis!* powlis!*);

% All let-rules for an operator are collected as rule set.

% Usage in algebraic mode:
%  e.g. SHOWRULES SIN;
% The rules for exponentiation can be listed by
%       SHOWRULES EXPT;

symbolic procedure showrules opr;
   begin scalar r;
     r := showruleskvalue opr;
     r:=append(r,showrulesopmtch opr);
     r:=append(r,showrules!*match opr);
     r:=append(r,showrulesdfn opr);
     if opr eq 'expt then
        <>
     else
        %% FJW: Show rules for powers of opr:
        <>;
       return 'list.r;
   end;

symbolic procedure showruleskvalue opr;
  for each rule in get(opr,'kvalue) collect
   begin scalar pattern, vars, target;
      pattern := car rule;
      vars := selectletvars pattern;
      vars := arbvars vars;
      pattern := subla(vars,pattern);
      target := cadr rule;
      target := subla(vars,target);
      return mkrule(nil,pattern,target)
   end;

symbolic procedure showonerule(test,pattern,target);
   % central routine produces one rule.
   begin scalar vars;
      vars := selectletvars pattern;
      vars := arbvars vars;
      pattern := subla(vars,pattern);
      test := subla(vars,test);
      target := subla(vars,target);
      test := simpletsymbolic test;
      if test=t then test:=nil;
      %% target := simpletsymbolic target;
      %% FJW: mangles lists in target, e.g. for hypergeometric, but
      %% not applying simpletsymbolic might not be the right fix!
      return mkrule(test,pattern,target)
   end;

symbolic procedure showrulesopmtch opr;
   for each rule in get(opr,'opmtch) collect
      showonerule(cdadr rule,opr . car rule,caddr rule);

symbolic procedure showrulesdfn opr;
   append(showrulesdfn1 opr, showrulesdfn2 opr);

symbolic procedure showrulesdfn1 opr;
   for i:=1:5 join showrulesdfn1!*(opr,i);

symbolic procedure showrulesdfn1!*(opr,n);
   % simple derivatives
   begin scalar dfn,pl,rule,pattern,target;
    dfn:=dfn_prop(for j:=0:n collect j);
    if(pl:=get(opr,dfn)) then return
     for j:=1:n join
      if (rule:=nth(pl,j)) then
      <<  pattern := car rule;
          pattern := {'df,opr . pattern,nth(pattern,j)};
          target := cdr rule;
          {showonerule(nil,pattern,target)}
      >>;
   end;

symbolic procedure mkrule(c,a,b);
  <>;

symbolic procedure strip!~ u;
   if null u then u else
   if idp u then
     (if eqcar(w,'!~) then intern compress cdr w else u)
         where w=explode2 u
   else if atom u then u
   else if car u = '!~ then strip!~ cadr u
   else strip!~ car u . strip!~ cdr u;

symbolic procedure separate!~ u;
   if null u or u='!~ then u else
   if idp u then
     (if eqcar(w,'!~) then {'!~,intern compress cdr w} else u)
         where w=explode2 u
   else if atom u then u
   else separate!~ car u . separate!~ cdr u;


symbolic procedure showrulesdfn2 opr;
   % collect possible rules from df
   for each rule in get('df,'opmtch) join
      if eqcar(caar rule,opr) then
    {showonerule(cdadr rule,'df . car rule,caddr rule)};

symbolic procedure showrules!*match opr;
  for each rule in !*match join if smember(opr,rule) then
   begin scalar pattern,target,test,p1,p2;
       pattern := car rule;
       p1 := car pattern;
       p2 := cadr pattern;
       pattern := list('times,prepsq !*p2q p1,
                                prepsq !*p2q p2);
       test := cdadr rule;
       target := caddr rule;
       return {showonerule(test,pattern,target)}
     end;

symbolic procedure showrulespowlis!*();
 for each rule in powlis!* collect
   begin scalar pattern,target;
      pattern := list ('expt,car rule,cadr rule);
      target := cadddr rule;
      return mkrule(nil,pattern,target);
   end;

symbolic procedure showrulespowlis1!*();
 for each rule in powlis1!* collect
   begin scalar pattern,target,test,p1,p2;
      pattern := car rule;
      p1 := car pattern;
      p2 := cdr pattern;
      pattern := list ('expt, p1, p2);
      test := cdadr rule;
      target := caddr rule;
      return showonerule(test,pattern,target);
    end;

symbolic procedure showrulesasymplis!*();
   for each rule in asymplis!* collect
      mkrule(nil,{'expt,car rule,cdr rule},0);

symbolic procedure showrulespowlis!*opr opr;
   %% FJW: Pick rules in powlis!* for operator opr:
   for each rule in powlis!* join
      if eqcar(car rule, opr) then
      begin scalar pattern,target;
         pattern := list ('expt,car rule,cadr rule);
         target := cadddr rule;
         return mkrule(nil,pattern,target) . nil
      end;

symbolic procedure showrulespowlis1!*opr opr;
   %% FJW: Pick rules in powlis1!* for operator opr:
   for each rule in powlis1!* join
      if eqcar(caar rule, opr) then
      begin scalar pattern,target,test,p1,p2;
         pattern := car rule;
         p1 := car pattern;
         p2 := cdr pattern;
         pattern := list ('expt, p1, p2);
         test := cdadr rule;
         target := caddr rule;
         return showonerule(test,pattern,target) . nil
       end;

symbolic procedure showrulesasymplis!*opr opr;
   %% FJW: Pick rules in asymplis!* for operator opr:
   for each rule in asymplis!* join
      if eqcar(car rule, opr) then
         mkrule(nil,{'expt,car rule,cdr rule},0) . nil;

symbolic procedure selectletvars u;
     if null u then nil else
     if memq(u,frlis!*) then {u} else
     if atom u then nil else
     union (selectletvars car u, selectletvars cdr u);

symbolic procedure simpletsymbolic u;
    if atom u then u else
    if car u eq 'quote then simpletsymbolic cadr u else
    if car u memq '(aeval reval revalx boolvalue!*) then
       if needs!-lisp!-tag cadr u
         then {'symbolic,simpletsymbolic cadr u}
        else simpletsymbolic cadr u
     else
    if car u eq 'list then simpletsymbolic cdr u else
    if isboolfn car u then simpletsymbolic (isboolfn car u . cdr u)
       else simpletsymbolic car u . simpletsymbolic cdr u;

symbolic procedure needs!-lisp!-tag u;
   if numberp u then nil else
   if atom u then t else
   if car u memq '(aeval reval revalx boolvalue!* quote) then nil else
   if car u eq 'list then needs!-lisp!-tag1 cdr u
   else if car u eq 'cons then
        needs!-lisp!-tag cadr u or needs!-lisp!-tag caddr u
   else t;

symbolic procedure needs!-lisp!-tag1 u;
  if null u then nil else
    needs!-lisp!-tag car u or needs!-lisp!-tag1 cdr u;

fluid '(bool!-functions!*);

bool!-functions!* :=
  for each x in {'equal,'greaterp,'lessp,'geq,'leq,'neq,'numberp}
      collect get(x,'boolfn).x;

symbolic procedure isboolfn u;
    if idp u and (u:=assoc(u,bool!-functions!*)) then cdr u;

symbolic procedure arbvars vars;
  for each var in vars collect
         var . {'!~, intern compress cddr explode var};

symbolic operator showrules;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/extout.red0000644000175000017500000003124211526203062023275 0ustar  giovannigiovannimodule extout; % Extended output package for expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*allfac !*div !*mcd !*noequiv !*pri !*rat factors!* kord!*
  !*combinelogs wtl!*);

global '(dnl!* ordl!* upl!*);

switch allfac,div,pri,rat;

!*allfac := t;          % factoring option for this package
!*pri := t;             % to activate this package

% dnl!* := nil;         % output control flag: puts powers in denom
% factors!* := nil;     % list of output factors
% ordl!* := nil;        % list of kernels introduced by ORDER statement
% upl!* := nil;         % output control flag: puts denom powers in
                        % numerator
% !*div := nil;         % division option in this package
% !*rat := nil;         % flag indicating rational mode for output.

symbolic procedure factor u;
   factor1(u,t,'factors!*);

symbolic procedure factor1(u,v,w);
   begin scalar x,y,z,r;
        y := lispeval w;
        for each j in u do
          if (x := getrtype j) and (z := get(x,'factor1fn))
              then apply2(z,u,v)
            else <>;
                   x := !*a2kwoweight j;
                   if v then y := aconc!*(delete(x,y),x)
                    else if not(x member y)
                     then msgpri(nil,j,"not found",nil,nil)
                    else y := delete(x,y)>>;
        set(w,y);
        if r then return factor1(r,v,w)
   end;

symbolic procedure remfac u;
   factor1(u,nil,'factors!*);

rlistat '(factor remfac);

symbolic procedure order u;
   <>>>;

rlistat '(order);

symbolic procedure up u;
   factor1(u,t,'upl!*);

symbolic procedure down u;
   factor1(u,t,'dnl!*);

% rlistat '(up down);  % Omitted since not documented.

symbolic procedure formop u;
   if domainp u then u
    else raddf(multop(lpow u,formop lc u),formop red u);

symbolic procedure multop(u,v);
   if null kord!* then multpf(u,v)
    else if car u eq 'k!* then v
    else rmultpf(u,v);

symbolic smacro procedure lcx u;
   % Returns leading coefficient of a form with zero reductum, or an
   % error otherwise.
   cdr carx(u,'lcx);

symbolic procedure quotof(p,q);
   % P is a standard form, Q a standard form which is either a domain
   % element or has zero reductum.
   % Returns the quotient of P and Q for output purposes.
   if null p then nil
    else if p=q then 1
    else if q=1 then p
    else if domainp q then quotofd(p,q)
    else if domainp p
      % Make sure free variable degrees are accommodated.
     then (mksp(mvar q,
                if numberp x then -x else {'minus,x})
                    .* quotof(p,lcx q) .+ nil) where x = ldeg q
    else (lambda (x,y);
          if car x eq car y
              then (lambda (n,w,z);
                 if n=0 then raddf(w,z)
                  else ((car y .** n) .* w) .+ z)
              (cdr x-cdr y,quotof(lc p,lcx q),quotof(red p,q))
           else if ordop(car x,car y)
              then (x .* quotof(lc p,q)) .+ quotof(red p,q)
           else mksp(car y,- cdr y) .* quotof(p,lcx q) .+ nil)
       (lpow p,lpow q);

symbolic procedure quotofd(p,q);
   % P is a form, Q a domain element. Value is quotient of P and Q
   % for output purposes.
   if null p then nil
    else if domainp p then quotodd(p,q)
    else (lpow p .* quotofd(lc p,q)) .+ quotofd(red p,q);

symbolic procedure quotodd(p,q);
   % P and Q are domain elements. Value is domain element for P/Q.
   if atom p and atom q then int!-equiv!-chk mkrn(p,q)
    else lowest!-terms(p,q);

symbolic procedure lowest!-terms(u,v);
   % Reduces compatible domain elements U and V to a ratio in lowest
   % terms.  Value as a rational may contain domain arguments rather
   % just integers.  Modified to use dcombine for field division.
   if u=v then 1
    else if flagp(dmode!*,'field) or not atom u and flagp(car u,'field)
       or not atom v and flagp(car v,'field)
%    then multdm(u,!:recip v)
     then dcombine!*(u,v,'quotient)
     else begin scalar x;
      if atom(x := dcombine!*(u,v,'gcd)) and x neq 1 then
         <>;
      return if v=1 then u else '!:rn!: . (u . v)
   end;

symbolic procedure dcombine!*(u,v,w);
   if atom u and atom v then apply2(w,u,v) else dcombine(u,v,w);

symbolic procedure ckrn u;
   % Factors out the leading numerical coefficient from field domains.
   if flagp(dmode!*,'field) and not(dmode!* memq '(!:rd!: !:cr!:))
     then begin scalar x;
       x := lnc u;
       x := multf(x,ckrn1 quotfd(u,x));
       if null x then x := 1;
          % NULL could be caused by floating point underflow.
       return x
      end
     else ckrn1 u;

symbolic procedure ckrn1 u;
   begin scalar x;
        if domainp u then return u;
    a:  x := gck2(ckrn1 cdar u,x);
        if null cdr u
          then return if noncomp mvar u then x else list(caar u . x)
         else if domainp cdr u or not(caaar u eq caaadr u)
          then return gck2(ckrn1 cdr u,x);
        u := cdr u;
        go to a
   end;

symbolic procedure gck2(u,v);
   % U and V are domain elements or forms with a zero reductum.
   % Value is the gcd of U and V.
   if null v then u
    else if u=v then u
    else if domainp u
     then if domainp v then
        if flagp(dmode!*,'field)
          or pairp u and flagp(car u,'field)
          or pairp v and flagp(car v,'field) then 1
           else if dmode!* eq '!:gi!: then intgcdd(u,v) else gcddd(u,v)
        else gck2(u,cdarx v)
    else if domainp v then gck2(cdarx u,v)
    else (lambda (x,y);
        if car x eq car y
          then list((if cdr x>cdr y then y else x) .
                    gck2(cdarx u,cdarx v))
         else if ordop(car x,car y) then gck2(cdarx u,v)
         else gck2(u,cdarx v))
    (caar u,caar v);

symbolic procedure cdarx u;
   cdr carx(u,'cdar);

symbolic procedure negf!* u; negf u where !*noequiv = t;

symbolic procedure prepsq!* u;
   begin scalar x,y,!*combinelogs;
        if null numr u then return 0;
        % The following leads to some ugly output.
%        else if minusf numr u
%         then return list('minus,prepsq!*(negf!* numr u ./ denr u));
        x := setkorder ordl!*;
        setkorder
                  append(sort(for each j in factors!*
                     join if not idp j then nil
                           else if y := get(j,'prepsq!*fn)
                            then apply2(y,u,j)
                           else for each k in get(j,'klist)
                                     collect car k,'ordop),
                   append(sort(factors!*,'ordop),ordl!*));
        if kord!* neq x or wtl!*
          then u := formop numr u . formop denr u;
%       u := if !*rat or (not flagp(dmode!*,'field) and !*div)
        u := if !*rat or !*div
                      or upl!* or dnl!*
               then replus prepsq!*1(numr u,denr u,nil)
              else sqform(u,function prepsq!*2);
        setkorder x;
        return u
end;

symbolic procedure prepsq!*0(u,v);
   % U is a standard quotient, but not necessarily in lowest terms.
   % V a list of factored powers.
   % Value is equivalent list of prefix expressions (an implicit sum).
   begin scalar x;
      return if null numr u then nil
              else if (x := gcdf(numr u,denr u)) neq 1
        then prepsq!*1(quotf(numr u,x),quotf(denr u,x),v)
       else prepsq!*1(numr u,denr u,v)
   end;

symbolic procedure prepsq!*1(u,v,w);
   % U and V are the numerator and denominator expression resp,
   % in lowest terms.
   % W is a list of powers to be factored from U.
   begin scalar x,y,z;
        % Look for "factors" in the numerator.
        if not domainp u and (mvar u member factors!* or (not
                atom mvar u and car mvar u member factors!*))
          then return nconc!*(
               if v=1 then prepsq!*0(lc u ./ v,lpow u . w)
                else (begin scalar n,v1,z1;
                % See if the same "factor" appears in denominator.
                n := ldeg u;
                v1 := v;
                z1 := !*k2f mvar u;
                while (z := quotfm(v1,z1)) do <>;
                return
                  prepsq!*0(lc u ./ v1,
                            if n>0 then (mvar u .** n) . w
                             else if n<0
                              then mksp(list('expt,mvar u,n),1) . w
                             else w)
                   end),
                        prepsq!*0(red u ./ v,w));
        % Now see if there are any remaining "factors" in denominator.
        % (KORD!* contains all potential kernel factors.)
        if not domainp v
         then for each j in kord!* do
           begin integer n; scalar z1;
                n := 0;
                z1 := !*k2f j;
                while z := quotfm(v,z1) do <>;
                if n<0 then w := mksp(list('expt,j,n),1) . w
           end;
        % Now all "factors" have been removed.
        if kernlp u then <>;
        if dnl!*
          then <>;
        if upl!*
          then <>
         else if !*div then y := ckrn v
         else y := 1;
        u := canonsq (u . quotof(v,y));
%       if !*gcd then u := cancel u;
        u := quotof(numr u,y) ./ denr u;
        if !*allfac
          then <>>>;
        return if w then list retimes aconc!*(exchk w,prepsq u)
         else rmplus prepsq u
   end;

symbolic procedure addfactors(u,v);
   % U is a (possible) product of factors, v a standard form.
   % Result is a folded prefix expression.
   if u = 1 then prepf v
    else if v = 1 then u
    else if eqcar(u,'times) then 'times . aconc!*(cdr u,prepf v)
    else retimes list(u,prepf v);

symbolic procedure rmplus u; if eqcar(u,'plus) then cdr u else list u;

symbolic procedure prepsq!*2 u; replus prepsq!*1(u,1,nil);

symbolic procedure ckrn!*(u,v);
   if null u then errach 'ckrn!*
    else if domainp u then 1
    else if caaar u member v
       then list (caar u . ckrn!*(cdr carx(u,'ckrn),v))
    else ckrn!*(cdr carx(u,'ckrn),v);

symbolic procedure mkkl(u,v);
   if null u then v else mkkl(cdr u,list (car u . v));

symbolic procedure quotfm(u,v);
   begin scalar !*mcd; !*mcd := t; return quotf(u,v) end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/heugcd.red0000644000175000017500000003722311526203062023211 0ustar  giovannigiovannimodule heugcd;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%Authors: James Davenport & Julian Padget

% For full details of the algorithms see first Char et al. from the
% Proceedings of EUROSAM 84 (Springer LNCS #174), then Davenport and
% Padget in the Proceedings of EUROCAL 85 (Springer LNCS #204) and
% Davenport and Padget in the proceedings of Calcul Formel (Homage a
% Noel Gastinel) published by Masson-Wiley (France).

%exports heu!-gcd, heu!-gcd!-list;

%imports to be determined

%internal-functions
%       univariatep, univariatep1, htc, kontent, kontent1,
%       horner!-eval!-rat, horner!-eval!-rat!-and!-gcdl,
%       horner!-eval!-rat!-and!-gcdl1, heu!-quotfl, heu!-quotfl1,
%       heu!-quotf, xceiling, next!-even!-value, next!-odd!-value,
%       heu!-gcdl, analyse!-polynomials, negshiftz, gen!-poly,
%       gen!-poly!-forward, gen!-poly!-backward, gcdlist2, gcdf2

fluid '(!*heugcd reduction!-count);

global '(ee);


% ****************** Various polynomial utilities **********************

symbolic smacro procedure univariatep p; univariatep1(p,mvar p);

symbolic procedure univariatep1(p,v);
% checks that p is univariate in v;
   if atom p then t
   else if mvar p neq v then nil
   else if atom lc p then univariatep1(red p,v)
   else nil;

symbolic procedure htc p;
   if atom p then p
   else if null red p then lc p
   else htc red p;

symbolic procedure kontent p;
% extract integer content of polynomial p
   if domainp p then
           if numberp p then p
      else if null p then 1
      else rederr "HEUGCD(kontent): unsupported domain element"
   else if domainp red p then
           if numberp red p then gcdn(lc p,red p)
      else if null red p then lc p
      else rederr "HEUGCD(kontent): unsupported domain element"
  else kontent1(red red p,gcdn(lc p,lc red p));

symbolic procedure kontent1(p,a);
   if a=1 then 1
   else if domainp p then
      if numberp p then gcdn(p,a)
      else if null p then a
      else rederr "HEUGCD(kontent1): unsupported domain element"
   else kontent1(red p,gcdn(remainder(lc p,a),a));

symbolic procedure horner!-eval!-rat(p,v);
% evaluate the (sparse univariate) polynomial p at a rational v using
% Horner's scheme.  Denominators are cleared by in fact calculating the
% following:
%
%    for i:=min:max sum (a[i] * n**(i-min) * d**(max-min-i))
%
% note that if the polynomial does not end in a non-zero constant
% the routine it return the evaluation of p/(trailing exponent)
%        s accumulates d**(max-min-i)
%        ans accumulates the sum
%        m is degree difference between current and previous term
% See specific routines below for further detail
   if (numr v)=1 then horner!-eval!-integer(p,denr v,1,0)
   else if (denr v)=1 then horner!-eval!-reciprocal(p,numr v,0,0)
   else horner!-eval!-rational(p,numr v,denr v,0,1,0);

symbolic procedure horner!-eval!-rational(p,n,d,m,s,ans);
% general case of an arbitrary rational
   if domainp p then
      if p then ans*n**m+s*p else ans
   else (lambda mp;
           horner!-eval!-rational(red p,n,d,mp,s*d**mp,ans*n**m+s*lc p))
         (ldeg p)-(if domainp red p then 0 else ldeg red p);

symbolic procedure horner!-eval!-integer(p,d,s,ans);
% simple sub case of an integer (n/1)
   if domainp p then
      if p then ans+s*p else ans
   else horner!-eval!-integer(red p,d,
           s*d**((ldeg p)-(if domainp red p then 0 else ldeg red p)),
           ans+s*lc p);

symbolic procedure horner!-eval!-reciprocal(p,n,m,ans);
% simpler sub case of a straight reciprocal of an integer (1/n)
   if domainp p then
      if p then ans*n**m+p else ans
   else horner!-eval!-reciprocal(red p,n,
           (ldeg p)-(if domainp red p then 0 else ldeg red p),
           ans*n**m+lc p);

symbolic procedure horner!-eval!-rat!-and!-gcdl(l,v);
% l is a list of polynomials to be evaluated at the point v
% and then take the GCD of these evaluations.  We use an auxiliary
% routine with an accumulator variable to make the computation
% tail-recursive
   if null cdr l then horner!-eval!-rat(car l,v)
   else if null cddr l then
      gcdn(horner!-eval!-rat(car l,v),horner!-eval!-rat(cadr l,v))
   else horner!-eval!-rat!-and!-gcdl1(cddr l,v,
          gcdn(horner!-eval!-rat(car l,v),horner!-eval!-rat(cadr l,v)));

symbolic procedure horner!-eval!-rat!-and!-gcdl1(l,v,a);
   if a=1 then 1
   else if null l then a
   else horner!-eval!-rat!-and!-gcdl1(cdr l,v,
           gcdn(horner!-eval!-rat(car l,v),a));

%*********** Polynomial division utilities and extensions *************

symbolic procedure heu!-quotfl(l,d);
% test division of each of a list of SF's (l) by the SF d
   if null cdr l then heu!-quotf(car l,d)
   else heu!-quotfl1(cdr l,d,heu!-quotf(car l,d));

symbolic procedure heu!-quotfl1(l,d,flag);
   if null flag then nil
   else if null cdr l then heu!-quotf(car l,d)
   else heu!-quotfl1(cdr l,d,heu!-quotf(car l,d));

symbolic procedure heu!-quotf(p,q);
   if domainp q then
      if domainp p then
         if null p then nil
         else if null q then
            rederr "HEUGCD(heu-quotf): division by zero"
         else (lambda temp; if cdr temp=0 then car temp else nil)
               divide(p,q)
      else quotf(p,q)
   else if domainp p then nil
   else if ldeg p>
      else return nil>>
   else return nil;
   value:=first!-value(inp,inq,lcp,lcq,tcp,tcq);
      % first check for trivial GCD
   d:=gen!-poly(horner!-eval!-rat!-and!-gcdl(l,value),
                value,mvar car l,xsx);
   if heu!-quotfl(l,d) then return d;
      % since that failed we pick a much higher evaluation point
      % courtesy of a modified Mignotte inequality and just work on the
      % first two
   lgcd:=gcdn(lcp,lcq);
   for each x in cddr l do lgcd:=gcdn(lc x,lgcd);
   tgcd:=gcdn(tcp,tcq);
   for each x in cddr l do tgcd:=gcdn(htc x,tgcd);
   value:=second!-value(inp,inq,lcp,lcq,lgcd,tcp,tcq,tgcd);
loop:
   d:=gen!-poly(horner!-eval!-rat!-and!-gcdl(l,value),
                value,mvar car l,xsx);
   if heu!-quotfl(l,d) then return d;
   value:=next!-odd!-value value;
   k:=k+1;
   d:=gen!-poly(horner!-eval!-rat!-and!-gcdl(l,value),
                value,mvar car l,xsx);
   if heu!-quotfl(l,d) then return d;
   value:=next!-even!-value value;
   k:=k+1;
   if k < 10 then goto loop;
   print "(HEUGCD):heu-gcd-list fails";
   return nil
end;

symbolic procedure heu!-gcd(p,q);
% Heuristic univariate polynomial GCD after Davenport & Padgets'
% extensions of Geddes' algorithm (EUROSAM 84)
% the method of choosing the evaluation point is quite complex (but not
% as general as it ought to be).  It is
%
%    min(infinity!-norm p/lc p, infinity!-norm p/htc p,
%        infinity!-norm q/lc q, infinity!-norm q/htc q)
%
begin scalar k,value,d,dval,xsx,inp,inq,lcp,lcq,lgcd,tcp,tcq,tgcd,tmp;
      % check if one of p and q is linear
   if (ldeg q=1) or (ldeg p=1) then return
      if univariatep p and univariatep q then
         (lambda (pp,pq);
           if (ldeg pq)=1 then
              (lambda h; if null h then 1 else pq) heu!-quotf(pp,pq)
           else
              (lambda h; if null h then 1 else pp) heu!-quotf(pq,pp))
          (quotf(p, kontent p), quotf(q, kontent q))
      else nil;
      % general case
   if (ldeg p)>(ldeg q) then return heu!-gcd(q,p);
   tmp:=analyse!-polynomial p;
   if tmp then <<
      inp:=car tmp; lcp:=lc p; xsx:=cadr tmp; tcp:=caddr tmp;
      tmp:=analyse!-polynomial q;
      if tmp then <<
         inq:=car tmp; lcq:=lc q; xsx:=min(xsx,cadr tmp); tcq:=caddr tmp>>
      else return nil>>
   else return nil;
   value:=first!-value(inp,inq,lcp,lcq,tcp,tcq);
      % first check for trivial GCD
   dval:=gcdn(horner!-eval!-rat(p,value),horner!-eval!-rat(q,value));
   d:=gen!-poly(dval,value,mvar p,xsx);
   if heu!-quotf(p,d) and heu!-quotf(q,d) then return d;
      % if that failed we pick a much higher evaluation point
   lgcd:=gcdn(lcp,lcq);
   tgcd:=gcdn(lcp,lcq);
   value:=second!-value(inp,inq,lcp,lcq,lgcd,tcp,tcq,tgcd);
   k:=0;
loop:
   dval:=gcdn(horner!-eval!-rat(p,value),horner!-eval!-rat(q,value));
   d:=gen!-poly(dval,value,mvar p,xsx);
   if heu!-quotf(p,d) and heu!-quotf(q,d) then return d;
   value:=next!-odd!-value value;
   k:=k+1;
   dval:=gcdn(horner!-eval!-rat(p,value),horner!-eval!-rat(q,value));
   d:=gen!-poly(dval,value,mvar p,xsx);
   if heu!-quotf(p,d) and heu!-quotf(q,d) then return d;
   value:=next!-even!-value value;
   k:=k+1;
   if k < 10 then goto loop;
   print "(HEUGCD):heu-gcd fails";
   return nil
end;

symbolic procedure analyse!-polynomial p;
% Determine the infinity norm of p and take note of the trailing
% coefficient, simultaneously check that p is univariate and take note
% of any trailing powers of the main variable. The result is a triple
% of (infinity-norm,excess powers,trailing coefficient)
   analyse!-polynomial1(p,1,lc p,0,mvar p);

symbolic procedure analyse!-polynomial1 (p,inp,tcp,xsxp,mvarp);
   if domainp p then
      if p then list(max(inp,abs p),0,abs p)
      else list(inp,xsxp,abs tcp)
   else if ((mvar p) neq mvarp) then nil
   else if domainp lc p then
      analyse!-polynomial1(red p,max(inp,abs lc p),lc p,ldeg p,mvarp)
   else nil;

%********** Reconstruction from the Z-adic representation *************

% given a number in [0,modulus), return the equivalent
% member of [-modulus/2,modulus/2)
% LAMBDA to ensure only one evaluation of arguments;
symbolic smacro procedure negshiftz(n,modulus);
   (lambda (nn,mmodulus);
      if nn>quotient(mmodulus,2) then nn-mmodulus else nn)
    (n,modulus);

symbolic procedure gen!-poly(dval,value,var,xsx);
   if (numr value)=1 then gen!-poly!-backward(dval,denr value,var,xsx)
   else if (denr value)=1 then gen!-poly!-forward(dval,numr value,var,xsx)
   else rederr "HEUGCD(gen-poly):point must be integral or reciprocal";

symbolic procedure gen!-poly!-forward(dval,value,var,xsx);
% generate a new polynomial in var from the value-adic representation
% provided by dval
begin scalar i,d,val,val1,kont;
   kont:=0;
   val:=dval;
   i:=xsx;
   if zerop i then <<
      % an x**0 term is represented specially;
      val1:=negshiftz(remainder(val,value),value);
      if not zerop val1 then kont:=d:=val1;
      val:=quotient(val-val1,value);
      i:=1
   >>;
   while not zerop val do <<
      val1:=negshiftz(remainder(val,value),value);
      if not zerop val1 then <<
         kont:=gcdn(val1,kont);
         d:=var .** i .* val1 .+ d
      >>;
      val:=quotient(val-val1,value);
      i:=1+i
   >>;
   return quotf(d,kont)
end;

symbolic procedure gen!-poly!-backward(dval,value,var,xsx);
% generate a new polynomial in var from the 1/value-adic representation
% provided by dval
begin scalar i,d,ans,val,val1,kont;
   kont:=0;
   val:=dval;
   % because we are at the 1/value representation
   % we need the implicit REVERSE that the two-loop strategy here
   % provides;
   while not zerop val do <<
      val1:=negshiftz(remainder(val,value),value);
      d:=val1 . d;
      val:=quotient(val-val1,value)
   >>;
   i:=xsx;
   if (zerop i and not zerop car d) then <<
      % Handle x**0 term specially;
      kont:=ans:=car d;
      d:=cdr d;
      i:=1
   >>;
   while d do <<
      if not zerop car d then <<
         kont:=gcdn(car d,kont);
         ans:= var .** i .* car d .+ ans
      >>;
      d:=cdr d;
      i:=i+1
   >>;
   return quotf(ans,kont)
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/alg-form.red0000644000175000017500000000402411526203062023447 0ustar  giovannigiovannimodule alg!-form;   % Some particular algebraic mode analysis functions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(inputbuflis!* resultbuflis!* ws);

symbolic procedure forminput(u,vars,mode);
   begin scalar x;
      u := cadr u; if eqcar(u,'!:int!:) then u := cadr u;
      if null(x := assoc(u,inputbuflis!*))
        then rerror(alg,1,list("Entry",u,"not found"));
      return caddr x
   end;

put('input,'formfn,'forminput);

symbolic procedure formws(u,vars,mode);
   begin scalar x;
      u := cadr u; if eqcar(u,'!:int!:) then u := cadr u;
      if x := assoc(u,resultbuflis!*) then return mkquote cdr x
       else rerror(alg,2,list("Entry",u,"not found"))
   end;

put('ws,'formfn,'formws);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/sort.red0000644000175000017500000001513011526203062022732 0ustar  giovannigiovannimodule sort;  % A simple sorting routine.

% Author: Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure sort(l,pred);
   % Sort the list l according to the given predicate.  If l is a list
   % of numbers then the predicate "lessp" will sort the list into
   % ascending order.  The predicate should be a strict inequality,
   % i.e. it should return NIL if the two items compared are equal.  As
   % implemented here SORT just calls STABLE-SORT, but as a matter of
   % style any use where the ordering of incomparable items in the
   % output matters ought to use STABLE!-SORT directly, thereby
   % allowing the replacement of this code with a faster non-stable
   % method. (Note: the previous REDUCE sort function also happened to
   % be stable, so this code should give exactly the same results for
   % all calls where the predicate is self-consistent and never has
   % both pred(a,b) and pred(b,a) true).
   stable!-sortip(append(l, nil), pred);

symbolic procedure stable!-sort(l,pred);
   % Sorts a list, as SORT, but if two items x and y in the input list
   % satisfy neither pred(x,y) nor pred(y,x) [i.e. they are equal so far
   % as the given ordering predicate is concerned] this function
   % guarantees that they will appear in the output list in the same
   % order that they were in the input.
   stable!-sortip(append(l, nil), pred);

symbolic procedure stable!-sortip(l, pred);
   % As stable!-sort, but over-writes the input list to make the output.
   % It is not intended that people should call this function directly:
   % it is present just as the implementation of the main sort
   % procedures defined above.
   begin scalar l1,l2,w;
      if null l then return l;    % Input list of length 0
      l1 := l;
      l2 := cdr l;
      if null l2 then return l;   % Input list of length 1
      % Now I have dealt with the essential special cases of lists of
      % length 0 and 1 (which do not need sorting at all).  Since it
      % possibly speeds things up just a little I will now have some
      % fairly ugly code that makes special cases of lists of length 2.
      % I could easily have special code for length 3 lists here (and
      % include it, but commented out), but at present my measurements
      % suggest that the speed improvement that it gives is minimal and
      % the increase in code bulk is large enough to give some pain.
      l := cdr l2;
      if null l then <<           % Input list of length 2
         if apply2(pred, car l2, car l1) then <<
            l := car l1;
            rplaca(l1, car l2);
            rplaca(l2, l) >>;
       return l1 >>;
      % Now I will check to see if the list is in fact in order already
      % Doing so will have a cost - but sometimes that cost will be
      % repaid when I am able to exit especially early.  The result of
      % all this is that I will have a best case behaviour with linear
      % cost growth for inputs that are initially in the correct order,
      % while my average and worst-case costs will increase by a
      % constant factor.
      l := l1;
      % In the input list is NOT already in order then I expect that
      % this loop will exit fairly early, and so will not contribute
      % much to the total cost.  If it exits very late then probably in
      % the next recursion down the first half of the list will be
      % found to be already sorted, and again I have a chance to win.
      while l2 and not apply2(pred, car l2, car l) do
         <>;
      if null l2 then return l1;
      l2 := l1;
      l := cddr l2;
      while l and cdr l do << l2 := cdr l2; l := cddr l >>;
      l := l2;
      l2 := cdr l2;
      rplacd(l, nil);
      % The two sub-lists are then sorted.
      l1 := stable!-sortip(l1, pred);
      l2 := stable!-sortip(l2, pred);
      % Now I merge the sorted fragments, giving priority to item from
      % the earlier part of the original list.
      l := w := list nil;
      while l1 and l2 do <<
         if apply2(pred, car l2, car l1) then <<
            rplacd(w, l2); w := l2; l2 := cdr l2 >>
         else <>>>;
      if l1 then l2 := l1;
      rplacd(w,l2);
      return cdr l
  end;

symbolic procedure idsort u;
   % lexicographically sort list of ids.
   sort(u,function idcompare);

symbolic procedure idcompare(u,v);
   % compare lexicographical ordering of two ids.
   idcomp1(explode2 u,explode2 v);

symbolic procedure idcomp1(u,v);
   if null u then t
    else if null v then nil
    else if car u eq car v then idcomp1(cdr u,cdr v)
    else orderp(car u,car v);

% Comparison functions and special cases for sorting.

symbolic procedure lesspcar(a,b); car a < car b;

symbolic procedure lesspcdr(a,b); cdr a < cdr b;

symbolic procedure lessppair(a,b);
    if car a = car b then cdr a cdr b;

symbolic procedure lesspcdadr(a,b); cdadr a < cdadr b;

symbolic procedure lesspdeg(a,b);
   if domainp b then nil else if domainp a then t else ldeg a.

% Copyright (c) 1996 The RAND Corporation. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(alglist!* depl!* frlis!*);

% DEPL* is a list of dependencies among kernels.

symbolic procedure depend u;
   depend0(u,t);

symbolic procedure nodepend u;
   <>;

rlistat '(depend nodepend);

%symbolic procedure depend0(u,bool);
%   % We need to include both  and _ in the list to provide for
%   % ROOT_OF expressions.
%   <>;

symbolic procedure depend1(u,v,bool);
   begin scalar y,z;
      u := !*a2k u;
      v := !*a2k v;
      if u eq v then return nil;
      y := assoc(u,depl!*);
%     if y then if bool then rplacd(y,union(list v,cdr y))
%                else if (z := delete(v,cdr y)) then rplacd(y,z)
      if y then if bool
                 then depl!*:= repasc(car y,union(list v,cdr y),depl!*)
                 else if (z := delete(v,cdr y))
                  then depl!* := repasc(car y,z,depl!*)
                 else depl!* := delete(y,depl!*)
       else if null bool
         then lprim list(u,"has no prior dependence on",v)
       else depl!* := list(u,v) . depl!*
   end;

symbolic procedure depends(u,v);
   if null u or numberp u or numberp v then nil
    else if u=v then u
    else if atom u and u memq frlis!* then t
      %to allow the most general pattern matching to occur;
    else if (lambda x; x and ldepends(cdr x,v)) assoc(u,depl!*)
     then t
    else if not atom u and idp car u and get(car u,'dname) then
        (if depends!-fn then apply2(depends!-fn,u,v) else nil)
           where (depends!-fn = get(car u,'domain!-depends!-fn))
    else if not atom u
      and (ldepends(cdr u,v) or depends(car u,v)) then t
    else if atom v or idp car v and get(car v,'dname) then nil
    % else dependsl(u,cdr v);
    else nil;

symbolic procedure ldepends(u,v);
   % Allow for the possibility that U is an atom.
   if null u then nil
    else if atom u then depends(u,v)
    else depends(car u,v) or ldepends(cdr u,v);

symbolic procedure dependsl(u,v);
   v and (depends(u,car v) or dependsl(u,cdr v));

symbolic procedure freeof(u,v);
   not(smember(v,u) or v member assoc(u,depl!*));

symbolic operator freeof;

flag('(freeof),'boolean);

% infix freeof;

% precedence freeof,lessp;   %put it above all boolean operators;

% This following code, by Francis J. Wright, enhances the depend and
% nodepend commands.  If the first argument is an (algebraic) LIST
% then change the dependency for each element of it, i.e.

%   (no)depend {y1, y2, ...}, x1, x2, ...  maps to
%   (no)depend y1, x1, x2, ...;  (no)depend y2, x1, x2, ...; ...

% Also allow a sequence of such dependence sequences, where the
% beginning of each new sequence is indicated by a LIST of one or more
% dependent variables.

symbolic procedure depend0(u, bool);
   % u = y,x1,x2,..., {yy1,yy2,...},xx1,xx2,...,  OR
   % u = {y1,y2,...},x1,x2,..., {yy1,yy2,...},xx1,xx2,...,
 <>
            end;
         u := v
      end>>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/exptchk.red0000644000175000017500000001303111526203062023407 0ustar  giovannigiovannimodule exptchk;   % Check expt products for further simplification.

% Author: Anthony C. Hearn.

% Copyright (c) 2005, Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*combineexpt);

switch combineexpt;

put('combineexpt,'simpfg,'((t (rmsubs)) (nil (rmsubs))));

symbolic procedure exptchksq u;
   % U is a standard quotient. Result is u with possible expt
   % simplifications.
   if null !*combineexpt then u
    else multsq(exptchk numr u,invsq exptchk denr u);

symbolic procedure exptchk u;
   if domainp u then u ./ 1
    else (if length v<2 then u ./ 1 else exptchk0(u,nil,v)) where v=comm_kernels u;

symbolic procedure exptchk0(u,v,w);
   if null u then nil ./ 1
    else if domainp u then exptunwind(u,v)
    else if expttermp(mvar u,w)
     then addsq(exptchk0(lc u,lpow u . v,w),exptchk0(red u,v,w))
    else addsq(multsq(!*p2f lpow u ./ 1,exptchk0(lc u,v,w)),exptchk0(red u,v,w));

symbolic procedure expttermp(u,v);
   if eqcar(u,'expt) then expttermp1(cadr u,v) else expttermp1(u,v);

symbolic procedure expttermp1(u,v);
   v and (u=car v or (eqcar(car v,'expt) and u=cadar v)
             or expttermp1(u,cdr v));

symbolic procedure exptunwind(u,v);
   begin integer n; scalar w,x;
   % U is a standard form, v a list of powers.
   % Result is a standard form of product(v) * u.
   % This function is the key to a better treatment of surds.
      n := 1;
      while v do
   %%%   <>
                     else v := x . delete(w,cdr v)>>
            else <>>>; 
      u := rm_neg_pow u;
      return multsq(n ./ 1,u)
   end;

symbolic procedure rm_neg_pow u;
   if domainp u then u ./ 1
    else if minusp ldeg u 
            then addsq(multsq(1 ./ (mvar u .^ (-ldeg u) .* 1 .+ nil),rm_neg_pow lc u),
                       rm_neg_pow red u)
          else addsq(multsq(!*p2f lpow u ./ 1,rm_neg_pow lc u),rm_neg_pow red u);

symbolic procedure mergex(u,v);
   if eqcar(car u,'expt)
     then if eqcar(car v,'expt)
              then if cadar u=cadar v
                     then mergey(cadar u,caddar u,caddar v,cdr u,cdr v)
                    else if caddar u=caddar v and cdr u=cdr v
               then mksp({'expt,{'times,cadar u,cadar v},caddar u},cdr u)
                    else rederr 'foo
%           else mergey(cadar u,caddar u,car v,cdr u,cdr v)
           else mergey(cadar u,caddar u,1,cdr u,cdr v)
    else if eqcar(car v,'expt) then mergey(car u,1,caddar v,cdr u,cdr v)
    else rederr {'mergex,u,v};

symbolic procedure mergey(u,v,w,x,y);
   begin
      x := simp!*{'plus,{'times,v,x},{'times,w,y}};
      if (y:= intcoeff numr x) neq 1 then x := quotf(numr x,y) ./ denr x;
      x := prepsq!* x;
      return if fixp u and fixp x then (u^x)^y else mksp({'expt,u,x},y)
   end;

symbolic procedure intcoeff u;
   % Returns an integer multiplier of standard form u.
   if domainp u then if fixp u then u else 1
    else (if null red u then n else gcdn(n,intcoeff red u))
             where n = intcoeff lc u;

symbolic procedure meldx(u,v);
   if eqcar(car u,'expt)
     then (if w then w
            else if eqcar(caar v,'expt) then meldx1(u,delete(u,v))
            else nil) where w=meldx0(cadar u,delete(u,v))
    else meldx0(car u,delete(u,v));

symbolic procedure meldx0(u,v);
   if null v then nil
    else if (eqcar(caar v,'expt) and u=cadaar v) or u=caar v then car v
    else meldx0(u,cdr v);

symbolic procedure meldx1(u,v);
   % Look for equal exponents.
   if null v then nil
    else if eqcar(car v,'expt) and caddar u=caddar car v and cdr u=cdar v
     then car v
    else meldx1(u,cdr v);

symbolic procedure comm_kernels u;
   % Returns list of commutative kernels in standard form u.
   comm_kernels1(u,nil);

symbolic procedure comm_kernels1(u,v);
   % We append to end of list to put kernels in the right order, even
   % though a cons on the front of the list would be faster.
   if domainp u then v
    else comm_kernels1(lc u,
                       comm_kernels1(red u,
                                     if x memq v or noncomp x
                                        then v else append(v,list x)))
         where x=mvar u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/reval.red0000644000175000017500000002753011526203062023063 0ustar  giovannigiovannimodule reval; % Functions for algebraic evaluation of prefix forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*combineexpt !*exp !*intstr !*listargs !*mcd !*resimp alglist!*
        dmode!* subfg!* varstack!*);

switch listargs;

global '(!*resubs !*sqvar!* !*val);

symbolic procedure reval u;
   reval1(u,t);

symbolic procedure aeval u;
   reval1(u,nil);

symbolic procedure aeval!* u;
   % This version rebinds alglist!* to avoid invalid computation in
   % loops.
   begin scalar alglist!*;
      return reval1(u,nil)
   end;

symbolic procedure reval1(u,v);
   (begin scalar x,y;
      if null u then return nil   % This may give trouble.
       else if stringp u then return u
       else if fixp u
        then return if flagp(dmode!*,'convert) then reval2(u,v) else u
       else if atom u
        then if null subfg!* then return u
              else if idp u and (x := get(u,'avalue))
               then if u memq varstack!* then recursiveerror u
                     else <>
              else nil
       else if not idp car u % or car u eq '!*comma!*
        then errpri2(u,t)
       else if car u eq '!*sq
        then return if caddr u and null !*resimp
                      then if null v then u else prepsqxx cadr u
                     else reval2(u,v)
       else if flagp(car u,'remember) then return rmmbreval(u,v)
       else if flagp(car u,'opfn) then return reval1(opfneval u,v)
       else if x := get(car u,'psopfn)
         then <>
          % Note that we assume that the results of such functions are
          % always returned in evaluated form.
       else if arrayp car u then return reval1(getelv u,v);
       return if x := getrtype u then
                  if y := get(x,'evfn) then apply2(y,u,v)
                    else rerror(alg,101,
                                list("Missing evaluation for type",x))
               else if not atom u
                     and not atom cdr u
                     and (y := getrtype cadr u)
                     and null(y eq 'list and cddr u) % Don't pass opr to
                                   % list if there is more than one arg.
                     and (x := get(y,'aggregatefn))
                     and (not(x eq 'matrixmap) or flagp(car u,'matmapfn))
                     and not flagp(car u,'boolean)
                     and not !*listargs and not flagp(car u,'listargp)
                then apply2(x,u,v)
               else reval2(u,v)
   end) where varstack!* := varstack!*;

flagop listargp;

symbolic procedure rmmbreval(u,v);
 % The leading operator of u is flagged 'remember.
  begin scalar fn,x,w,u1,u2;
   fn := car u;
   u1:={fn}; u2:={fn};
   for each y in cdr u do
   <>;
   if (x:=assoc(u1,w:=get(fn,'kvalue))) then<>;
     % Evaluate "algebraic procedure" and "algebraic operator" directly.
   if flagp(fn,'opfn) then x:= reval1(opfneval u2,v)
   else if get(fn,'simpfn) then x:=!*q2a1(simp!* u2,v)
   else % All others are passed to reval.
   << remflag({fn},'remember);
      x:=reval1(u2,v);
      flag({fn},'remember);
   >>;
   if not smember(u1,x) and not smember(u2,x)
        then put!-kvalue(fn,get(fn,'kvalue),(car u)
                . foreach uuu in cdr u collect reval uuu,x);
 a: return x;
  end;

symbolic procedure remember u;
  % Remember declaration for operator and procedure names.
 for each fn in u do
  <>;
    if flagp(fn,'noval) or flagp(fn,'listargp)
        then typerr(fn,"remember operator");
    flag({fn},'remember);
  >>;

put('remember,'stat,'rlis);

symbolic procedure recursiveerror u;
   msgpri(nil,u,"improperly defined in terms of itself",nil,t);

put('quote,'psopfn,'car);    % Since we don't want this evaluated.

symbolic procedure opfneval u;
   if flagp(car u ,'remember) then
    begin scalar interm,resul,x;
             interm := for each j in
                  (if flagp(car u,'noval) then cdr u else revlis cdr u)
                  collect if fixp j then j else mkquote j;
              if (x:=assoc(car u . interm ,get(car u,'kvalue)))
                         then return cadr x;
              resul := lispeval(car u . interm);
              put!-kvalue(car u,get(car u,'kvalue), car u . interm, resul);
              return resul;
     end
       else
   lispeval(car u . for each j in
                  (if flagp(car u,'noval) then cdr u else revlis cdr u)
                  collect mkquote j);

flag('(reval),'opfn);   % to make it a symbolic operator.

symbolic procedure reval2(u,v);
   % This test is designed to simplify expressions such as e*e^(2/(2-x))
   % and e^(x+3)*e^(3/(4-3*x))/e^(5*x-3). However, the normform test
   % shows it doesn't work well with non-integer domains.
   if v or null !*combineexpt or dmode!* then !*q2a1(simp!* u,v)
    else !*q2a1((simp!* u where !*mcd = nil),v);

symbolic procedure getrtype u;
   % Returns overall algebraic type of u (or NIL is expression is a
   % scalar). Analysis is incomplete for efficiency reasons.
   % Type conflicts will later be resolved when expression is evaluated.
   begin scalar x,y;
    return
    if null u then nil   % Suggested by P.K.H. Gragert to avoid the
                         % loop caused if NIL has a share flag.
     else if atom u
      then if not idp u then not numberp u and getrtype1 u
            else if flagp(u,'share) % then getrtype lispeval u
             then if (x := eval u) eq u then nil else getrtype x
            else if (x := get(u,'avalue)) and
                       not(car x memq '(scalar generic))
                    or (x := get(u,'rtype)) and (x := list x)
                    then if y := get(car x,'rtypefn) then apply1(y,nil)
                          else car x
                  else nil
     else if not idp car u then nil
     else if (x := get(car u,'avalue)) and (x := get(car x,'rtypefn))
      then apply1(x,cdr u)
     % Special case handling for the SUB operator.
     else if car u eq 'sub then 'yetunknowntype
     else getrtype2 u
   end;

symbolic procedure getrtype1 u;
   % Placeholder for packages that use vectors.
   nil;

symbolic procedure getrtype2 u;
   % Placeholder for packages that key expression type to the operator.
   begin scalar x;
     % Next line is maybe only needed by EXCALC.
      return if (x := get(car u,'rtype)) and (x := get(x,'rtypefn))
               then apply1(x,cdr u)
              else if x := get(car u,'rtypefn) then apply1(x,cdr u)
              else if flagp(car u,'matmapfn) and cdr u
                 and getrtype cadr u eq 'matrix
               then 'matrix
              else nil
   end;

remprop('rtypecar,'stat);

symbolic procedure rtypecar u;
   for each j in u do put(j,'rtypefn,'getrtypecar);

deflist('((rtypecar rlis)),'stat);

rtypecar difference,expt,minus,plus,recip;

deflist('
  ((quotient getrtypeor)
   (times getrtypeor)
   (!*sq (lambda (x) nil))
 ),'rtypefn);

symbolic procedure getrtypecar u; getrtype car u;

symbolic procedure getrtypeor u;
   u and (getrtype car u or getrtypeor cdr u);

symbolic procedure !*eqn2a u;
   % If u is an equation a=b, it is converted to an equivalent equation
   % a-b=0, or if a=0, b=0.  Otherwise u is returned converted to true
   % prefix form.
   if not eqexpr u then prepsqyy u
    else if null cdr u or null cddr u or cdddr u
     then typerr(u,"equation")
    else (if rh=0 then lh else if lh=0 then rh else{'difference,lh,rh})
          where lh=prepsqyy cadr u,rh=prepsqyy caddr u;

symbolic procedure prepsqyy u;
   if eqcar(u,'!*sq) then prepsqxx cadr u else u;

symbolic procedure getelv u;
   % Returns the value of the array element U.
%  getel(car u . for each x in cdr u collect ieval x);
   getel(car u . for each x in cdr u collect reval_without_mod x);

symbolic procedure setelv(u,v);
%  setel(car u . for each x in cdr u collect ieval x,v);
   setel(car u . for each x in cdr u collect reval_without_mod x,v);

symbolic procedure reval_without_mod u;
   % Evaluate u without a modulus.
   if dmode!* eq '!:mod!: then (reval u where dmode!* = nil)
    else reval u;

symbolic procedure revlis u; for each j in u collect reval j;

symbolic procedure revop1 u;
   if !*val then car u . revlis cdr u else u;

symbolic procedure mk!*sq u;
   % Modified by Francis J. Wright to return a list correctly.
%  if null numr u then 0
%   else if atom numr u and denr u=1 then numr u
%   else '!*sq . expchk u . if !*resubs then !*sqvar!* else list nil;
  (if null numr u then 0
    else if atom numr u and denr u=1 then numr u
    else if kernp u and eqcar(mvar numr u,'list) then mvar numr u
    else '!*sq . u . if !*resubs then !*sqvar!* else list nil)
   where u=expchk u;

symbolic macro procedure !*sq u;
   % Provide an interface to symbolic mode.
   prepsq cadr u;

symbolic procedure expchk u; if !*exp then u else offexpchk u;

symbolic procedure lengthreval u;
   begin scalar v,w,x;
      if length u neq 1
        then rerror(alg,11,
                    "LENGTH called with wrong number of arguments");
      u := car u;
      if idp u and arrayp u then return 'list . get(u,'dimension);
      v := aeval u;
      if (w := getrtype v) and (x := get(w,'lengthfn))
        then return apply1(x,v)
       else if atom v then return 1
       else if not idp car v or not(x := get(car v,'lengthfn))
        then if w
          then lprie list("LENGTH not defined for argument of type",w)
         else typerr(u,"LENGTH argument")
       else return apply1(x,cdr v)
   end;

put('length,'psopfn,'lengthreval);


% Code for evaluation of expressions whose type can only be
% infered after partial evaluation.

symbolic procedure yetunknowntypeeval(u,v);
   % Assumes that only psopfn's can produce yet unknown types.
   reval1(eval!-yetunknowntypeexpr(u,v),v);

symbolic procedure eval!-yetunknowntypeexpr(u,v);
   if atom u
      then ((if w then eval!-yetunknowntypeexpr(cadr w,v)
              else u)
            where w = get(u,'avalue))
    else if car u eq '!*sq or get(car u,'dname) or car u eq '!:dn!:
     then u
    else ((if x and (getrtype u eq 'yetunknowntype)
              then apply1(x,cdr u)
            else car u . for each j in cdr u collect
                             eval!-yetunknowntypeexpr(j,v))
          where x = get(car u,'psopfn));

put('yetunknowntype,'evfn,'yetunknowntypeeval);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/alg/logsort.red0000644000175000017500000001223411526203062023436 0ustar  giovannigiovannimodule logsort;  % Combine sums of logs.

% Author:  Stanley L. Kameny.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(domainlist!*);

fluid '(!*div factors!* !*combinelogs !*noneglogs !*expandlogs
        !*uncached);

switch combinelogs,expandlogs;

% !*combinelogs := t;   % Default value is ON.

symbolic procedure clogsq!* x;
   begin scalar !*div,!*combinelogs,!*expandlogs;
      !*div := !*expandlogs := t;
      x:= simp prepsq x where !*uncached=t; !*expandlogs := nil;
      return simp!* comblog prepsq!* x end;

symbolic procedure logsort x; % combines log sums at all levels.
   begin scalar !*div,!*combinelogs,!*expandlogs,!*noneglogs;
      !*div := !*expandlogs := !*noneglogs := t;
      x:= simp x where !*uncached=t; !*expandlogs := nil;
      return comblog prepsq!* x end;

% symbolic procedure logsorta a; aeval logsort a;

% symbolic operator logsorta;

symbolic procedure comblog x;
   if atom x or car x memq domainlist!* then x
   else if car x eq 'plus
     or car x eq 'times and
         ((not domainp y and eqcar(mvar y,'log))
           where y=numr simp!* x)
       then prepsq!* clogsq simp!* x
   else (comblog car x) . comblog cdr x;

symbolic procedure clogsq x; clogf numr x ./ clogf denr x;

symbolic procedure clogf u;
   begin scalar x,y;
      x := kernels u;
      for each j in x do if eqcar(j,'log) then y := j . y;
      if null y then return u;
      x := setdiff(x,y);
      x := setkorder nconc(x,y);
      u := clogf1 reorder u;
      setkorder x;
      return reorder u
   end;

symbolic procedure clogf1 x;
   if domainp x then x
    else if eqcar(mvar x,'log) then clogf2 x
    else addf(multpf(lpow x,clogf1 lc x),clogf1 red x);
%   else ((if null z then x else
%          addf(if atom y then list lt x else numr simp!* comblog y,z))
%      where y=prepsq!*(list lt x ./ 1),z=clogf1 red x);

symbolic procedure clogf2 x; % does actual log combining.
   begin scalar y,z,r,s,g,a,b,c,d,w,xx; integer k;
      xx := x;
  st: if domainp x then <>
       else if not eqcar(mvar x,'log) or ldeg x neq 1
        then <>;
      y := list lt x;
      if not domainp(z := red x) then go to lp;
     % g := coefgcd(c := lc y,0); a := quotf(c,g);
     % y := multf(a,numr simp!* list('log,logarg(cadr mvar y,g)));
      go to ret;
     % in this loop, y is a log term, r is a term, and z the reductum.
  lp: if domainp z then go to ret;
      r := list lt z; z := red z;
      if eqcar(mvar r,'log) and ldeg r=1 then go to a2;
  a1: s := addf(r,s); go to lp;
  a2: b := coefgcd(a := lc r,0); a := quotf(a,b);
      d := coefgcd(c := lc y,0); c := quotf(c,d);
      g := gcdf(a,c); a := quotf(a,g); c := quotf(c,g);
      if not domainp a or not domainp c then go to a1
       else if numberp a and numberp c then go to a3
       else if quotf(a,c)=-1 then
         <>
       else go to a1;
  a3: % a := list('times,logarg(cadr mvar r,multf(a,b)),
      %    logarg(cadr mvar y,multf(c,d))); g := g ./ 1;
      b := multf(a,b); d := multf(c,d);
      k := gcdf(k,gcdf(b,d)); b := quotf(b,k); d := quotf(d,k);
      % Only combine a log if at most one of the arguments is complex.
      % Otherwise you can finish up on the wrong sheet.
      if !*precise and not one_complexlist {cadr mvar r,cadr mvar y}
        then return xx;
      a := list('times,logarg(cadr mvar r,b),
         logarg(cadr mvar y,d)); g := g ./ 1;
  a4: a := prepsq simp!* a;
      y := numr simp!* list('times,k,
         if eqcar(a,'quotient) and cadr a=1
            then list('minus,list('log,caddr a)) else list('log,a),
         prepsq g);
      go to lp;
 ret: return addf(w,addf(y,addf(z,clogf1 s))) end;

symbolic procedure logarg(a,c);
   if c=1 then a else list('expt,a,c);

symbolic procedure coefgcd(u,g);
   if domainp u then gcdf(u,g) else coefgcd(lc u,coefgcd(red u,g));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/0000755000175000017500000000000011722677366021641 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codopt.red0000644000175000017500000021064311526203062023607 0ustar  giovannigiovannimodule codopt;   % Generalization of Breuer's Growth Factor Algorithm.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, W.N. Borst.            ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

%-------------------------------------------------------------------- ;
% The module CODOPT contains:                                         ;
%                                                                     ;
% THE GENERALIZED VERSION OF BREUER'S GROWTH FACTOR ALGORITHM         ;
%                                                                     ;
% A description can be found in :                                     ;
% M.A. Breuer : "Generation of Optimal Code for Expressions via       ;
%      Factorization", Comm.ACM 12, 333-340 (1969).                   ;
% J.A. van Hulzen : "Breuer's Grow Factor Algorithm in Computer       ;
%      Algebra",Proceedings SYMSAC '81 (P.S. Wang, ed.), 100-104, New ;
%      York: ACM(1981).                                               ;
% J.A. van Hulzen : "Code Optimization of Multivariate Polynomial     ;
%      Schemes : A Pragmatic Approach", Proceedings EUROCAL '83 (J.A. ;
%      van Hulzen, ed.),Springer LNCS-series nr 162, 286-300 (1983).  ;
% ------------------------------------------------------------------- ;
%                                                                     ;
% ------ DATA STRUCTURES AND WEIGHTS ------                           ;
% Via FFVAR!! and in combination with SSETVARS(also the CODMAT module);
% a set of input-expressions is decomposed and stored in the "matrix" ;
% CODMAT.                                                             ;
% The Breuer-like searches, for finding common subexpressions (cse's  ;
% for short), concentrate on Zstrt's, defining the primitive parts    ;
% (pp's for short) of input-expressions. These pp's are either linear ;
% expressions (Opval='PLUS) or monomials (Opval='TIMES). The pp's be- ;
% long to larger expressions if CHROW is not NIL at the same level or ;
% if the FarVar-field of the row contains a rowindex (of a father ex- ;
% pression).                                                          ;
% The Zstrt is a list of pairs Z.Such a Z consists of a (column)index,;
% denoted by XIND(Z) or YIND(Z) and an integer value IVAL(Z), being   ;
% the exponent (or coefficient) of the variable corresponding with the;
% column-index, occurring in this pair. In a similar way columns are  ;
% used to define the occurrences of variables in the description of   ;
% the input-expressions( see the CODMAT module).                      ;
% Each row or column has a weight WGHT=((AWght.MWght).HWght), where   ;
% HWght=AWght + 3*MWght. The A(dditive)W(ei)ght is the length of the  ;
% Zstrt. The M(ultiplicative)W(ei)ght is its number of (|IVAL|>1)-ele-;
% ments. The factor 3 reflects the assumption that multiplication is 3;
% times as expensive as addition. The HWghts play an essential role in;
% the heuristics (on which the Breuer searches are based) and are com-;
% puted and stored via application of the procedure INITWGHT (see the ;
% CODMAT module).                                                     ;
% NOTE : It is of course possible to make the factor 3 a parameter.   ;
% This requires some resettings in the weight-routines (see the module;
% CODMAT).                                                            ;
% HWghts can be associated with both rows and columns.                ;
% This allows to produce weightfactors (see the references),  to be   ;
% associated with rows (or columns) to refine heuristic decisions, if ;
% required. The weightfactor of a row(column) is the sum of the HWghts;
% of those columns(rows) which share a non-zero entry with it.Although;
% the use  of weightfactors might improve decision making, its over-  ;
% head in computational cost can be considerable, certainly when the  ;
% CODMAT-matrix is large. The visual intuitive selection-mechanisms   ;
% for cse-building (extend a set of column-indices against the price  ;
% of reducing the number of parents (rows)) can be impractical, becau-;
% se - certainly initially - the number of variables is a fraction of ;
% the number of rows, corresponding with (sub)pp's.                   ;
% So we drop the weightfactors and we select rows instead of columns. ;
% To speed up the row-selection all rows with an equal HWght are col- ;
% lected in a double linked list, using the HiR-fields. These sets are;
% accessible via the elements of the CODHISTO-vector (details are gi- ;
% ven in the CODMAT module, procedure INSHISTO). We recall only that  ;
% CODHISTO(i) = k means that HWght(k) = i and that HiR(k) allows to   ;
% access the FILO-list of rows j with HWght(j) = i.                   ;
% NOTE : These FILO-lists, a kind of buckets, can contain both PLUS-  ;
% and TIMES-rows if both are SETFREE (see the COSYMP module and again ;
% INSHISTO). The operator-type is irrelevant during the Breuer-search.;
% In fact, it is only explicitly required in the procedure ADDCSE.    ;
%                                                                     ;
% ------ THE SEARCHES : THE ESSENTIALS ------                         ;
% Initially the cse's are either linear expressions or monomials. To  ;
% discover them the integer-matrices (CODMAT-parts with PLUS and TIMES;
% Opval-fields,respectively), are heuristically searched for submatri-;
% ces of rank 1 of maximal size. The size is determined, using a      ;
% profit-criterium. A basic scan is used, which can be qualified as   ;
% "test whether the determinant of a (2,2)-matrix of non-zero entries ;
% is zero". Its use is based on information about the row-weights,    ;
% which allow to locate completely dense submatrices. The row-weight  ;
% is a reflection of the arithmetic complexity of the pp,corresponding;
% with the row. Since we want to reduce the arithmetic complecity AC =;
% (n+,n*) of the set of input-expressions, a cse-selection ought to   ;
% contribute to a reduction of the number of additions (n+) and/or the;
% number of multiplications (n*). This is only possible if the cse oc-;
% curs at least twice and if the additive weight AWght is at least 2. ;
% The profit-criterium WSI is based on this assumption. Its actual va-;
% lue is (|Psi|-1) * (|Jsi|-1). Here Psi is the set of Parent- row in-;
% dices and Jsi is the set of indices of columns, which are associated;
% with variables occurring in the cse under construction.             ;
% Once a cse is found its description is removed from the rows,defined;
% by Psi, and from the columns, with indices in Jsi. The cse itself is;
% added to CODMAT as a new row. It has a system-selected name (given  ;
% in the FarVar-field and produced with FNEWSYM (see CODCTL module)), ;
% which is also used as recognizer of the new column added to CODMAT, ;
% to define the occurrences of the new cse (via the Psi-set). In addi-;
% tion the HWghts of the Psi rows, used in the previous resettings are;
% recomputed and reinserted via CODHISTO and the cse-row is entered in;
% CODHISTO, to allow it to play its own role in the optimization. We  ;
% also insert the new cse in the output hierarchy via the ORDR-field  ;
% of the Psi-parents, associated with the cse. We finally remark that ;
% it also might be possible that the cse is identical to one or more  ;
% of its parent-pp's. In this case it might be necessary to migrate   ;
% information from the PLUS(TIMES)-matrix to the TIMES(PLUS)-matrix.  ;
% Further details are given in the source, contained in this module.  ;
%                                                                     ;
% Essentially all searches are done in Zstrt's. A Zstrt is a list of  ;
% pairs (index . value). The ordering in the Zstrt is based on the    ;
% indices. A column-Zstrt contains (positive) row-indices, given in   ;
% descending order. A row-Zstrt contains (negative) column-indices,   ;
% given in ascending order. The indices define relative positions. In ;
% all operations on CODMAT information-pieces (except for MKZEL-calls);
% these relative positions, produced via Rowmax and Rowmin value chan-;
% ges, are needed for information retrieval and information storage.  ;
% These relative CODMAT-positions are used during the searches, i.e.  ;
% the sets (lists) Psi and Jsi are built with them.During the searches;
% ordering is only relevant if the procedure PnthXZZ is used. The ap- ;
% plication PnthXZZ(A,B) delivers the Zstrt B, but after removal of   ;
% the elements preceding the Z-element with the A-index. This Z-elem. ;
% can thus be obtained as CAR(PnthXZZ(A,B)). Since the searches are   ;
% based on row-selection followed by Jsi-resettings, only ordering in ;
% Jsi is relevant. When a cse is found, Psi is ordered, before making ;
% and adding to CODMAT the corresponding Zstrt.                       ;
%                                                                     ;
% ------ DOMAIN CONSIDERATIONS ------                                 ;
% As stipulated above operator considerations are hardly relevant du- ;
% ring cse-searches. Identical tests can be applied for cse's occur-  ;
% ring in linear expressions as well as in monomials, albeit that via ;
% the Expand- and ShrinkProd mechanism additional searches are perfor-;
% med for monomial-cse's, simply because the mathematical context is  ;
% somewhat richer. When allowing various coefficient domains, a dis-  ;
% tinction between coefficient- and exponent searches is needed :     ;
% Assuming MkZel, SetIVal and IVal become generic functions, the fol- ;
% lowing changes in CODOPT are required :                             ;
% - ExtBrsea - A double CODHISTO-mechanism ( to allow to analyse PLUS ;
%              and TIMES rows separately) is required and doubles in  ;
%              fact initialization, as well as appl. of ExtBrsea1.    ;
% - TestPr   - The zero-minor test has to be made generic.            ;
% - RZstrtCse- The GC-computations uses ABS-value computations, which ;
%               ought to be generic, as well as the gcd comp.'s with  ;
% - Gcd2     - This routine must be generic.                          ;
% - CZstrtCse- The ZZcse-construction requires multiplication factor  ;
%              computations, i.e. divisions of domain-elements, which ;
%              ought to be generic.                                   ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% The global identifiers needed in this module are :                  ;
% ------------------------------------------------------------------- ;

global '(psi jsi npsi njsi wsi rcoccup roccup1 roccup2 newjsi newnjsi
         codhisto headhisto rowmin rowmax )$

% ------------------------------------------------------------------- ;
% Description of the global variables used in this module (see also   ;
% the CODMAT module):                                                 ;
% ------------------------------------------------------------------- ;
%   Roccup1 : Indices of rows, which become (temporarily) irrelevant  ;
%             during a cse search (see procedure FindOptRow).         ;
%   Roccup2 : Indices of rows, which were (temporarily) selected as   ;
%             candidate-parent row (see procedure FindOptRow).        ;
%   RCoccup : Indices of rows and columns, either used for building   ;
%             the cse or leading to a failure, i.e. to Wsi=0.         ;
%       Psi : Indices of the parents of the cse.                      ;
%      NPsi : Number of elments in Psi.                               ;
%       Jsi : A list of column indices representing the current cse.  ;
%      NJsi : Number of elements in Jsi.                              ;
%    NewJsi : Contains the new Jsi if a certain rowindex is added to  ;
%             Psi (see FINDOPTROW).                                   ;
%   NewNJsi : Number of elements in NewJsi.                           ;
%       Wsi : Profitfunction = (|Psi|-1)*(|Jsi|-1). See proc. TestRed.;
%  CodHisto : Vector representing the Histogram.                      ;
% Headhisto : CodHisto(i) = 0 if i > Headhisto, i.e. the list of rows ;
%             with HWght = HeadHisto is accessible via CodHisto(Head- ;
%             Histo).                                                 ;
%-------------------------------------------------------------------- ;


rcoccup:=roccup1:=roccup2:=nil;


symbolic procedure extbrsea;
% ------------------------------------------------------------------- ;
% The main procedure governing the Breuer-searches. Both,monomials and;
% linear expressions, can be found as cse.                            ;
% ------------------------------------------------------------------- ;
begin scalar further;
   % ---------------------------------------------------------------- ;
   % We start excluding those rows and columns, which are irrelevant  ;
   % for our searches : Either the FarVar-field = -1 (This setting is ;
   % performed by application of the procedure ClearRow, defined in   ;
   % the module CODMAT, and expresses that a row or column is not in  ;
   % use anymore) or = -2 (Columns reservedto store temporarily mono- ;
   % mial information created in ExpandProd and removed in ShrinkProd);
   % ---------------------------------------------------------------- ;
   for x:=rowmin:rowmax do
    if farvar(x)=-1 or farvar(x)=-2
    then setoccup(x)
    else setfree(x);
   % ---------------------------------------------------------------- ;
   % After initialization the searches are performed.                 ;
   % ---------------------------------------------------------------- ;
   initbrsea();
   extbrsea1();
   % ---------------------------------------------------------------- ;
   % The remaining monomials can further be analysed for cse-occurren-;
   % ces when they are temporarily expanded, using a specific addition;
   % chain mechanism (see procedure EXPANDPROD).                      ;
   % ---------------------------------------------------------------- ;
   repeat
    <>
   until not(further);
   % ---------------------------------------------------------------- ;
   % Once the Breuer-searches are completed control is passed over to ;
   % IMPROVELAYOUT, before TCHScheme and finally CODFAC are used.     ;
   % TCHScheme allows information migration and CODFAC application of ;
   % the distributive law. Application of IMPROVELAYOUT might lead to ;
   % the conclusion that the Expand-Shrink activities resulted in re- ;
   % dundant cse-names, such as a double name for x^2 or the like.    ;
   % Details are given in OPTIMIZELOOP (see the module CODCTL).       ;
   % ---------------------------------------------------------------- ;
end;

symbolic procedure initbrsea;
% ------------------------------------------------------------------- ;
% The CODMAT-submatrices are prepared for the Breuer-searches.        ;
% The weights are set, the vector CODHISTO gets its initial values    ;
% and redundant information is temporarily removed. It is of course   ;
% needed again for output and eventually during later stages of the   ;
% optimization process, due to information migration. Information is  ;
% redundant when a row or column, i.e a Zstrt, only contains one Z-   ;
% element. This demands for a recursive search through CODMAT, since  ;
% a redundant row can lead to a redundant column if the element they  ;
% share ought to be disregarded.                                      ;
% ------------------------------------------------------------------- ;
begin scalar hlen;
  hlen:=histolen;
  for x:=rowmin:rowmax do
  if free(x) then initwght(x);
  % ----------------------------------------------------------------- ;
  % Only the weights for relevant rows and columns are computed. Once ;
  % the weights are known, the redundancy can be removed using :      ;
  % ----------------------------------------------------------------- ;
  redcodmat();
  % ----------------------------------------------------------------- ;
  % If the vector CODHISTO is already known, it might have been crea- ;
  % ted during a previous use of the Optimizer. In this case its en-  ;
  % tries are set to NIL. Otherwise it is created, before the HWght-  ;
  % information is stored in the HiR-fields and in CODHISTO.          ;
  % ----------------------------------------------------------------- ;
  if codhisto
   then for x:=0:histolen do sethisto(x,nil)
   else codhisto:=mkvect(hlen);
  headhisto:=0;
  for x:=0:rowmax do
   inshisto(x);
end;

symbolic procedure redcodmat;
% ------------------------------------------------------------------- ;
% Recursive removal of redundant information using the procedure      ;
% TestRed.                                                            ;
% ------------------------------------------------------------------- ;
for x:=rowmin:rowmax do testred(x);

symbolic procedure testred(x);
% ------------------------------------------------------------------- ;
% If the row or column X is still relevant but has an additive weight ;
% of 1 or 0 its information is irrelevant for the searches.           ;
% Remark : It is possible to consider the LOWER BOUND of 2 as a PARA- ;
% METER. If we are only interested in cse's of a LENGTH of AT LEAST M ;
% we have to replace the 2 by M and to MAKE this M GLOBAL. It demands ;
% a revision of the procedure DOWNWGHT1 and similar routines, given in;
% the CODMAT module, and a modification of the profit criterium WSI   ;
% (see the procedure EXTBRSEA1).                                      ;
% So when a row is redundant we declare it to be occupied and reduce  ;
% the weights of the column its shares its element with, before we    ;
% test if this column is now redundant as well. The role of rows and  ;
% columns are thus interchangeable.                                   ;
% ------------------------------------------------------------------- ;
if free(x) and awght(x)<2
then
 <>
 >>;

symbolic procedure extbrsea1;
% ------------------------------------------------------------------- ;
% This procedure defines the kernel of the generalized Breuer-search. ;
% It is based on the basic scan for zero-determinants. An explanation ;
% is given, using a (6,4)-matrix B of integers, which can also be     ;
% found in Van Hulzen '83, p.295 :                                    ;
%                                                                     ;
% column -4 -3 -2 -1                                                  ;
%                                                                     ;
% row 6 | 0  0  1  1 | AWght = 2 MWght = 0 HWght = 2 CodHisto( 2) = 6 ;
%     5 | 0  1  2  2 |         3         2         9         ( 9)   5 ;
%     4 | 0  2  2  3 |         3         3        12         (12)   4 ;
%     3 | 2  3  4  5 |         4         4        16         (16)   3 ;
%     2 | 4  6  0  0 |         2         2         8         ( 8)   2 ;
%     1 | 1  6  8 10 |         4         3        13         (13)   1 ;
%                                                                     ;
% AWght = 3  5  5  5                                                  ;
%                                                                     ;
% Hence Zstrt(-4) = ((3.2) (2.4) (1.1))                               ;
%   and Zstrt( 6) = ((-2.1)(-1.1)).                                   ;
% ------------------------------------------------------------------- ;
begin scalar hr,hc,x;
  while hr:=findhr() do
  % ----------------------------------------------------------------- ;
  % ExtBrsea1 consists of a WHILE-loop,which is executed as long as   ;
  % a first parent-row can be found using CODHISTO, via FindHR. So    ;
  % initially Psi = (HR).                                             ;
  % ----------------------------------------------------------------- ;
   if hc:=findhc(hr)
   % ---------------------------------------------------------------- ;
   % As long as a row HC can be found, which can be used in combinati-;
   % on with HR, the cse-search continues. Since redundancy is removed;
   % the AWght of HC is at least 2. Via FINDHC the column with maximal;
   % AWght, which shares a non-zero element with Row(HR) is selected. ;
   % ---------------------------------------------------------------- ;
    then
     < Ws(i) or NPsi * (NJs(i+1) - 1) > Ws(i), the  ;
       % number of columns, which are required for a further cse-exten;
       % sion is at least NJs(i+1),i.e. is larger than Floor(Wsi/NPsi);
       % + 1.                                                         ;
       % ------------------------------------------------------------ ;
       foreach x in roccup1 do
        setfree(x);
       % ------------------------------------------------------------ ;
       % Not usable during construction of the present cse. Given free;
       % again for a next attempt, with of course another HR.         ;
       % ------------------------------------------------------------ ;
       foreach x in roccup2 do
        setfree(x);
       % ------------------------------------------------------------ ;
       % Used for cse-construction, but now possibly reusable.        ;
       % ------------------------------------------------------------ ;
       roccup1:=roccup2:=nil;
       if wsi>0
        then
         <>
         else
          if npsi=1
           then
            << % ---------------------------------------------------- ;
               % If Wsi = 0 and NPsi = 1 the (HR,HC)-selection was un-;
               % lucky.No cse is found, i.e. HC has to be disregarded.;
               % ---------------------------------------------------- ;
               setoccup(hc);
               rcoccup:=hc.rcoccup
            >>
      >>
     else
      << % ---------------------------------------------------------- ;
         % No columns available for cse-construction using the row HR.;
         % Hence HR is an unlucky choise. The elements of RCoccup are ;
         % freed to be reused. HR is disregarded via RowDel(HR), with ;
         % as a consequence a possible, intermediate introduction of  ;
         % redundancy, which can be removed by applying TestredZZ.    ;
         % ---------------------------------------------------------- ;
         foreach x in rcoccup do
          setfree(x);
         rcoccup:=nil;
         rowdel(hr);
         testredzz(hr)
      >>
end;
symbolic procedure findhr;
% ------------------------------------------------------------------- ;
% CODHISTO is subjected to a top-down search to find the non-zero en- ;
% try with maximal index, i.e. to find the index of the most interes- ;
% ting row. This is row 3 in the example in the comment in ExtBrsea1. ;
% This value is returned. In addition Psi, NPsi and RCoccur are initia;
% lized (Psi = (3), NPsi = 1 and RCoccur = (3),for example). Finally  ;
% row X (= 3), selected as most attractive row, is removed from the   ;
% candidate rows, by assigning NIL to the FREE-field.                 ;
% Note that X = Nil is possible, implying that the search, defined in ;
% ExtBrsea1,is finished during this stage of the optimization process.;
% ------------------------------------------------------------------- ;
begin scalar x;
  while headhisto>0 and null(x:=histo headhisto) do
  headhisto:=headhisto-1;
  if x
  then
  <>;
  return x
end;

symbolic procedure findhc(hr);
% ------------------------------------------------------------------- ;
% HR is the index of a row, for instance selected with FindHR.        ;
% The Zstrt of HR is used to select the column, which can best be used;
% in combination with the row HR to start constructing a cse, i.e. the;
% "leftmost" column with locally maximal AWght. When looking at the   ;
% example in ExtBrsea1 this will be column -3.                        ;
% In addition Jsi and NJsi are initialized. Only the columns, which   ;
% are FREE are used( Jsi = (-1 -2 -3 -4), NJsi = 4).The return value  ;
% is Y = -3.                                                          ;
% NOTE :ExtBrsea1 is applied as long as it is possible.This might lead;
% to the need of disregarding columns during some stage in the itera- ;
% tive process. Therefore the test FREE(Y1:=Yind Z) is required.      ;
% ------------------------------------------------------------------- ;
begin scalar y,y1,aw,awmax;
  awmax:=njsi:=0;
  jsi:=nil;
  foreach z in zstrt(hr) do
  if free(y1:=yind z)
  then
  <awmax
    then
    <>
  >>;
  jsi:=reverse(jsi);
  return y
end;

symbolic procedure findoptrow(hr,hc,lmax);
% ------------------------------------------------------------------- ;
% The row-index HR and the column-index HC are used to  find a Row(X),;
% applying the test defined in the procedure TestPr, such that Row(HR);
% and Row(X) have a cse of at least a length Lmax + 1.                ;
% If HR =3 and HC = -3  FindOptRow will produce X = 1.                ;
% In TestPr a zero-minor-test is performed, always using B(HR,HC), and;
% here for shortness called Bil. Bil is used in all the TestPr-tests. ;
% These tests are done for all rows, which share a non-zero element   ;
% with the column HC, and which are not yet disregarded for further   ;
% searches.The new version of Jsi is assigned to the local variable S,;
% i.e. the return-value of TestPr. If S is a list of one element, HC, ;
% its Cdr is Nil, i.e Row(X1) does not contribute to a possible cse,  ;
% contained in a pp, defined by Row(HR). Then X1 is added to the list ;
% Roccup1. If the profit is satisfactory, i.e. if the list S is longer;
% than Lmax a new set of column-indices, called NewJsi, is created and;
% the index X1 is also renamed and returned. Hence when no X1 is found;
% X is not initialized, implying that Nil is returned.                ;
% Regardless of X1's role, it is added to the list Roccup2 if S con-  ;
% tains at least 2 elements. Before returning to the calling procedure;
% ExtBrsea1, the FREE-field of Row(X1) is set to Nil, implying that it;
% is disregarded until further notice.                                ;
% TestPr produces S = (-1 -2 -3).                                     ;
% ------------------------------------------------------------------- ;
begin scalar l,s,x,x1,bil;
  bil:=ival(car pnthxzz(hc,zstrt hr));
  foreach z in zstrt(hc) do
   if free(x1:=xind z)
    then
     <lmax
            then
             <>;
           roccup2:=x1.roccup2
         >>;
        setoccup(x1)
     >>;
  return x
end;

symbolic procedure testpr(x,hr,bkl,bil);
% ------------------------------------------------------------------- ;
% TestPr is a procedure to perform zero-minor tests.                  ;
% X and HR are row-indices. Bkl = B(X,HC) and Bil = B(HR,HC).         ;
% The test is : Is Bil*Bkj - Bij*Bkl = 0?                             ;
% Assumptions : Bkj = B(X,j) and Bij = B(HR,j), where j is running    ;
% through Jsi, the set of indices of columns, which share a non-zero  ;
% element with Row(HR).HC is an element of Jsi.                       ;
% The new JSI-set is returned. It contains at least HC.               ;
% ------------------------------------------------------------------- ;
begin scalar zz,zzhr,x1,y,p,ljsi,cljsi;
  ljsi:=jsi;
  zz:=zstrt(x);
  zzhr:=zstrt(hr);
  while ljsi and zz do
  if (cljsi:=car ljsi)=(x1:=xind car zz)
  then
  << % -------------------------------------------------------------- ;
     % The list LJsi is initially equal to the already existing Jsi,a ;
     % list consisting of column-indices. The lists ZZ and ZZHR are,  ;
     % initially the Zstrt's of Row(X) and Row(HR), respectively. The ;
     % Zstrt's consist of pairs (column-index . coefficient/exponent).;
     % The WHILE-loop is performed as long as the lists LJsi and ZZ   ;
     % are not yet empty. The test defining alternative actions is ba-;
     % sed on a comparison of the car-elements of the remaining parts ;
     % of these lists, which are given in ascending index-order.      ;
     % -------------------------------------------------------------- ;
     zzhr:=pnthxzz(cljsi,zzhr);
     % -------------------------------------------------------------- ;
     % The Zstrt ZZHR is also in ascending order. If the Car of LJsi, ;
     % CLJsi, is equal to X1, the column-index of the Car of Zstrt(X),;
     % the elements of Zstrt(HR), preceding the element, containing   ;
     % CLJSI as column-index,are removed from ZZHR.                   ;
     % This can imply that ZZHR =(),i.e. that Car(ZZHR) = Nil and that;
     % IVal(Car(ZZHR)) = 0.                                           ;
     % -------------------------------------------------------------- ;
    if zeropp(dm!-difference(dm!-times(ival(car zz),bil),
                              dm!-times(ival(car zzhr),bkl)))
     then p:=cljsi.p;
comment
  if zeropp(dm!-difference(dm!-quotient(bil,bkl),
                            dm!-quotient(ival(car zzhr),ival(car zz))))
      then p:=cljsi.p;
     % -------------------------------------------------------------- ;
     % CLJsi can be added to the new Jsi-list, which is under construc;
     % tion, using P, if the test succeeds.Here Ival(Car ZZ) = Bkj and;
     % IVal(Car ZZHR) = Bij.                                          ;
     % -------------------------------------------------------------- ;
     ljsi:=cdr(ljsi);
     zz:=cdr(zz)
  >>
  else
    if cljsi>x1
    % --------------------------------------------------------------- ;
    % The lists are in ascending order. Hence if the Car's do not     ;
    % match one of the two has to be skipped.                         ;
    % --------------------------------------------------------------- ;
     then zz:=cdr(zz)
     else ljsi:=cdr(ljsi);
  return p
end;

symbolic procedure brupdate(x);
% ------------------------------------------------------------------- ;
% Assume Row(X) was found with procedure FindOptRow. It is the most   ;
% recently found cse-parent. Therefore the administration needs some  ;
% updating : The set Psi of parents must be extended with X, the set  ;
% Jsi of column-indices ought to be replaced by NewJsi and (de)activa-;
% tion of relevant rows(columns) ought to take place.                 ;
% ------------------------------------------------------------------- ;
<>;

symbolic procedure addcse;
% ------------------------------------------------------------------- ;
% The cse defined by the index-sets Psi and Jsi is added to CODMAT.   ;
% So its occurrences in the rows,which have an index in Psi, are remo-;
% ved, the description of the cse is added as a new row to CODMAT and ;
% the system-selected cse-name is used to head a new column,defining  ;
% occurrences in the parent-rows. In combination with these measures  ;
% some weights have to be reset and thus also some information in     ;
% CODHISTO. The cse-ordering has - finally - to be taken care of via  ;
% the procedure SETPREV (see the CODMAT module for comment).          ;
% ------------------------------------------------------------------- ;
begin scalar zz,zzr,zzc,lzzr,lzzc,opv,var,gc,flt,min;
  zzr:=lzzr:=rzstrtcse() ;
  lzzc:=czstrtcse(ival car zzr);
  gc:=dm!-abs(ival car lzzc);
  min:=gc;
  flt:=floatprop(gc);
  foreach zz in lzzc do    % We have to test all the zz elements
  <<                       % because one could be a float
     flt:=flt or floatprop(ival zz);
     min:=dm!-min(min,dm!-abs(ival zz));
     if not(flt) then gc:=gcd2(gc,abs(ival zz))
  >>;
  if flt then gc:=min;     % When a float was encountered we take the
                           % smallest IVal, otherwise the gcd.
  if not(!:onep gc) then   % Correct when flt.
           << zz:=nil;     % When not(flt) gc<1 is not possible
              foreach z in zzr do
                 zz:=mkzel(xind z,dm!-times(ival(z),gc)).zz;
              zzr:=lzzr:=reverse zz;
              zz:=nil;
              foreach z in lzzc do
                 zz:=mkzel(xind z,dm!-quotient(ival(z),gc)).zz;
              lzzc:=reverse zz
            >>;
   zz:=nil;

  % ----------------------------------------------------------------- ;
  % ZZr and LZZr are assigned a row-Zstrt, in ascending order, defi-  ;
  % ning the cse, which must be added to CODMAT, in row Rowmax.       ;
  % LZZc is the column-Zstrt of the cse in ascending, thus "wrong" or-;
  % der. But LZZc is reversed, when updating the parent-rows in the   ;
  % Psi-loop. Similarly LZZr is used in the Jsi-loop for updating co- ;
  % lumns.                                                            ;
  % ----------------------------------------------------------------- ;
  var:=fnewsym();
  rowmax:=rowmax+1;
  setrow(rowmax,opv:=opval car jsi,var,list nil,zzr);
  % ----------------------------------------------------------------- ;
  % List Nil, parameter 4, defines the empty list of children and ex- ;
  % presses that also the EXPCOF-field of row(Rowmax) remains unused. ;
  % ----------------------------------------------------------------- ;
  rowmin:=rowmin-1;
  setrow(rowmin,opv,var,nil,nil);
  % ----------------------------------------------------------------- ;
  % The column(Rowmin) is reserved for the cse-description reverse(   ;
  % LZZc). Only the name Var is stored in the FarVar-field, like the  ;
  % operator-value in the OPVAL-field.                                ;
  % ----------------------------------------------------------------- ;
  if opv eq 'plus
   then put(var,'varlst!+,rowmin)
   else put(var,'varlst!*,rowmin);
  put(var,'rowindex,rowmax);
  % ----------------------------------------------------------------- ;
  % The new cse-name is stored either in the list of add.variables or ;
  % in the list of multiplicative variables. Its row-index is stored  ;
  % to allow retrieval of relevant information later on.              ;
  % ----------------------------------------------------------------- ;
  foreach x in psi do
  <>;
  foreach y in jsi do
  <>;
  setzstrt(rowmin,zzc);
  % ----------------------------------------------------------------- ;
  % The column-Zstrt ZZc is removed from all the Jsi columns it is oc-;
  % curring in and ZZc itself is stored in column(Rowmin), already re-;
  % served for this purpose. All relevant column-HWghts are recomputed;
  % like done for row(Rowmax) :                                       ;
  % ----------------------------------------------------------------- ;
  initwght(rowmax);
  inshisto(rowmax);
  initwght(rowmin);
  % ----------------------------------------------------------------- ;
  % Finally we test the modified columns and rows for redundancy.     ;
  % ----------------------------------------------------------------- ;
  foreach x in jsi do
   testredh(x);
  foreach x in psi do
   testredh(x)
end;

symbolic procedure rzstrtcse;
% ------------------------------------------------------------------- ;
% The Zstrt defining the cse,associated with Psi and Jsi, is made.    ;
% Psi is a list of row-indices, defining the parents.                 ;
% Jsi is a list of column -indices, defining the variables, occurring ;
% in the cse.                                                         ;
% Jsi is in ascending order. Psi is - in fact - not ordered.          ;
% This is due to the construction process.                            ;
% The cse-Zstrt is made out of the Zstrt of Row(Car Psi). The IVal's  ;
% in this Zstrt (coefficients or exponents) can be either integers or ;
% floats. When all of these IVals are integer (e.g. when dealing with ;
% exponents) the parents contain an integer-multiple (or integral     ;
% power) of the cse. In this case, when constructing the cse-Zstrt    ;
% such that the IVal's are relative prime all further required        ;
% resettings lead to integer IVal's in CODMAT.                        ;
% When one of the IVal's is a float, the smalest one is divided out.  ;
% Generally, this leads to float IVal's in CODMAT.                    ;
% ------------------------------------------------------------------- ;
begin scalar ljsi,zz,zzcse,gc,flt,min;
  zz:=pnthxzz(car jsi,zstrt car psi);
  zzcse:=list(car zz);
  gc:=dm!-abs(ival(car zz));
  min:=gc;
  flt:=floatprop(gc);
  % ----------------------------------------------------------------- ;
  % All initializations for the WHILE-loop are made :                 ;
  % ZZ is that part of the Zstrt(Car Psi) that starts with the element;
  % containing the leftmost element of Jsi in its index-field.        ;
  % So its first element is also the first element of the cse-Zstrt.  ;
  % The IVal-value of this head-element is assumed to contain the gcd ;
  % of all the IVal's of the cse. During the WHILE-loop other elements;
  % of Jsi,collected in LJsi are consumed,thus producing the cse-Zstrt;
  % ----------------------------------------------------------------- ;
  foreach ljsi in cdr(jsi) do
  <>;
  if flt then gc:=min; % When a float has been encountered, the ;
  return               % minimum of the ival's is divided out   ;
    if !:onep(gc) or expshrtest()
     then reverse(zzcse)
     % -------------------------------------------------------------- ;
     % If GC = 1 the IVal's are relative prime or/so there is no need ;
     % to divide out an IVal. The ZZcse ought to be                   ;
     % reversed, because the cons-construction reverses the original  ;
     % information.                                                   ;
     % The alternative expresses that the GC(d) of the exponents, de- ;
     % fining a monomial-cse, obtained after temporarily expanding the;
     % TIMES-columns, has not to be divided out, since it is in con-  ;
     % flict with the information storage and retrieval of the tempo- ;
     % rarily used TIMES-columns, as realized by using the NPCD- and  ;
     % PCDvar indicators in ExpandProd and ShrinkProd.                ;
     % -------------------------------------------------------------- ;
     else
     <>
end;

symbolic procedure gcd2(a1,a2);
% ------------------------------------------------------------------- ;
% The Gcd of A1 and A2 is computed. The value returned is positive, if;
% A1 and A2 are positive.                                             ;
% ------------------------------------------------------------------- ;
begin scalar a3;
  a3:=remainder(a1,a2);
  return
    if a3=0
      then a2
      else gcd2(a2,a3)
end;

symbolic procedure expshrtest;
% ------------------------------------------------------------------- ;
% ExpShrTest returns T is Jsi contains atleast one index of a column, ;
% which is temporarily used to store (part of) the expanded represen- ;
% tation of a column, defining a TIMES-variable. Such a column has a  ;
% -2 Farvar-value. Details : Expandprod and ShrinkProd.               ;
% ------------------------------------------------------------------- ;
begin scalar ljsi,further;
 if not (opval(car jsi) eq 'plus)
  then << ljsi:=jsi;
          while (ljsi and not further) do
           << further:=(farvar(car ljsi)=-2);
              ljsi:=cdr ljsi>>
       >>;
 return(further)
end;

symbolic procedure czstrtcse(iv);
% ------------------------------------------------------------------- ;
% The row-Zstrt of the actual cse is made by applying RZstrtCse. The  ;
% parameter IV is the IVal of the head-element of this Zstrt. It will ;
% be used to compute the multiplicity of the cse in the different pa- ;
% rents. These multiplicities are stored as IVal's in the column-Zstrt;
% associated with the new life of the cse as new variable.            ;
% ------------------------------------------------------------------- ;
begin scalar lpsi,zz,zzcse;
  zz:=zstrt(car jsi);
  lpsi:=ordn(psi); % Standard Reduce function ;
  psi:=nil;
  % ----------------------------------------------------------------- ;
  % The set LPsi defines Psi in descending order, i.e. the ordering   ;
  % needed for the construction of the column-Zstrt. ZZ is the Zstrt  ;
  % of the column,which contains the parameter IV as one of its IVal's;
  % ZZ is used to produce the Psi elements, which form the cse-Zstrt, ;
  % called ZZcse.ZZ is in descending order. During the WHILE-loop exe-;
  % cution Psi is reconstructed in ascending order.                   ;
  % ----------------------------------------------------------------- ;
  while lpsi do
   <>;
  return zzcse
end;

symbolic procedure testredzz(x);
% ------------------------------------------------------------------- ;
% TestredZZ is mutually recursive with TestredH and use in combination;
% with this routine to remove redundancy from CODMAT. Always of course;
% on a temporary basis.                                               ;
% ------------------------------------------------------------------- ;
foreach z in zstrt(x) do testredh(yind z);

symbolic procedure testredh(x);
% ------------------------------------------------------------------- ;
% Row (column) X is disregarded during further searches and its infor-;
% mation is deleted from CODHISTO, if the length of Zstrt(X) is redu- ;
% ced to 1. This redundancy test has to be done recursively.          ;
% ------------------------------------------------------------------- ;
if free(x) and awght(x)<2
 then
  <>;

symbolic procedure expandprod;
% ------------------------------------------------------------------- ;
% Only linear-expression like monomial cse's are found when applying  ;
% ExtBrsea1. The zero-minor condition is too strong. Monomial cse be- ;
% haviour is additive. Therefore addition chain mechanisms are employ-;
% ed to extend the relevant TIMES-columns in a number of temporarily  ;
% used columns, of which all the non-zero elements have the same expo-;
% nent value. Then ExtBrsea1 can be applied again, after relevant re- ;
% settings in CODHISTO. Procedure Shrinkprod is applied to undo this  ;
% expansion after the additional searches.                            ;
% Expandprod's functioning is illustrated by an example :             ;
% Assume : Y = -15, Var (= FarVar Y) = X and                          ;
%          Zstrt(Y) = ((6.1)(5.5)(4.5)(3.3)(2.5)(1.2)).               ;
% Zstrt(Y) is transformed into a matrix, using algorithm 2.1, given in;
% van Hulzen '83, page 296-297. The overall functioning can be vizua- ;
% lized in the following way :                                        ;
%                                                                     ;
%     Before      Expandprod Application         After                ;
%                                                                     ;
%  column|-15|                       column|-15 -23 -24 -40 |         ;
%        +---+                             +----------------+         ;
%  row 1 | 2 |                       row 1 | 1   1          |         ;
%      2 | 5 |                           2 | 1   1   1   2  |         ;
%      3 | 3 |                           3 | 1   1   1      |         ;
%      4 | 5 |                           4 | 1   1   1   2  |         ;
%      5 | 5 |                           5 | 1   1   1   2  |         ;
%      6 | 1 |                           6 | 1              |         ;
%        -----                             ------------------         ;
%                                                                     ;
% ------------------------------------------------------------------- ;
begin scalar var,pcvary,pcdvar,zzr,ivalz,n,m,npcdvar,npcdv,col!*,
                                                               relcols;
  for y:=rowmin:(-1) do
   if opval(y) eq 'times and not numberp(farvar y) and testrel(y)
    then relcols:=y . relcols;
  foreach y in relcols do
  << var := farvar y;
     % -------------------------------------------------------------- ;
     % TIMES-columns are only elaborated, when their Farvar-field is  ;
     % not a number, i.e. is the name of a variable or a cse, and if  ;
     % their Zstrt consists of at least 2 elements, which are not all ;
     % equal 1.                                                       ;
     % The Zstrt of such a column contains IVal's being powers of Var,;
     % the name associated with the column.                           ;
     % -------------------------------------------------------------- ;
     pcvary:=pcdvar:=zzr:=nil;
     foreach zel in zstrt(y) do
      if not((ivalz:=ival zel)=1)
       then
        <>;
     pcdvar:=inspcvv(y,1,pcdvar);
     % -------------------------------------------------------------- ;
     % PCDvar is a list of pairs consisting of an exponent EXPO and a ;
     % list of indices of columns, which were (temporarily) used to   ;
     % store occurrences of Var^EXPO. Initially holds :               ;
     % PCDvar := ((1.(-15))).                                         ;
     % -------------------------------------------------------------- ;
     n:=0;
     npcdv:=npcdvar:=get(var,'npcdvar);
     % -------------------------------------------------------------- ;
     % NPCDvar is a list of column-indices, which were used during a  ;
     % previous ExpandProd activity, to store temporarily the additio-;
     % nal columns, to be produced with PCvarY. NPCDvar was stored on ;
     % the property-list of Var, during a previous application of     ;
     % Expandprod, and using the actual value of NPCDv. Assume now,   ;
     % for the example, that NPCDvar = (-23 -24).                     ;
     % NPCDv is initially the previous version of NPCDvar, but eventu-;
     % ally extended, during an ExpandProd-application. This new value;
     % is stored on the property-list of Var before leaving ExpandProd;
     % Hence the columns, associated with NPCDvar are reused when ever;
     % necessary. Their Farvar-fields will always contain the value -2;
     % to avoid a wrong use.                                          ;
     % -------------------------------------------------------------- ;
     foreach pc in pcvary do
     % -------------------------------------------------------------- ;
     % Each item of the PCvarY list is now used to make a new column, ;
     % starting with the smallest exponent value.                     ;
     % -------------------------------------------------------------- ;
      <>
         else
          <>;
        %------------------------------------------------------------ ;
        % Hence, whenever necessary a new column-index is made and ad-;
        % ded to the set (list) NPCDv.                                ;
        % ----------------------------------------------------------- ;
        zzr:=mkzel(col!*,car(pc)-n).zzr;
        % ----------------------------------------------------------- ;
        % ZZr is a Zstrt, used to produce relevant additional row in- ;
        % formation, needed on a temporary basis, when expanding mono-;
        % mial row descriptions. ZZr is growing during the execution  ;
        % of the current ForEach-loop in the following way :          ;
        % ZZr := ((-23 . 1)),                                         ;
        % ZZr := ((-24 . 1) (-23 . 1)),                               ;
        % ZZr := ((-40 . 2) (-24 . 1) (-23 . 1)).                     ;
        % ----------------------------------------------------------- ;
        setrow(col!*,'times,-2,nil,nil);
        % ----------------------------------------------------------- ;
        % FarVar := -2 setting of column COL!*.                       ;
        % ----------------------------------------------------------- ;
        foreach x in cdr(pc) do
         % ---------------------------------------------------------- ;
         % PC is a pair (reduced exponent . list of indices of rows,of;
         % which the Zstrt ought to be temporarily modified).         ;
         % ---------------------------------------------------------- ;
         foreach z in zzr do
          <>;
        % ----------------------------------------------------------- ;
        % This double FOREACH-loop is executed inside the PC-FOREACH- ;
        % loop. For the example holds :                               ;
        % PC=(1.(1)) & ZZr=((-23 . 1)) gives insertion of (-23 . 1) in;
        % Zstrt(row(1)) and of (1 . 1) in Zstrt(col(-23)).            ;
        % PC=(2.(3)) & ZZr=((-24 .1 )(-23 . 1)) gives insertion of    ;
        % (-24 . 1) and (-23 . 1) in Zstrt(row(3)) and of (3 . 1) in  ;
        % Zstrt(col(-23)) and Zstrt(col(-24)).                        ;
        % Finally PC=(4.(2 4 5)) & ZZr=((-40 . 2)(-24 . 1)(-23 . 1))  ;
        % gives insertion of (-40 . 2),(-24 . 1) and (-23 . 1) in     ;
        % in Zstrt(row(2)), Zstrt(row(4)) and Zstrt(row(5)),of (2 . 2);
        % (4 . 2) and (5 . 2) in Zstrt(col(-40)), and of (2 . 1),(4 . ;
        % 1) and (5 . 1), finally, in both Zstrt(col(-23)) and Zstrt( ;
        % col(-24)).                                                  ;
        % See also the matrix shown above.                            ;
        % ----------------------------------------------------------- ;
        pcdvar:=inspcvv(col!*,car(pc)-n,pcdvar);
        % ----------------------------------------------------------- ;
        % The PCDvar-list is also iteratively built up. This list is  ;
        % needed in Shrinkprod. Its final form for the example is :   ;
        % ((1.(-15 -23 -24)) (2.(-40)))                               ;
        % ----------------------------------------------------------- ;
        n:=car(pc);
        % ----------------------------------------------------------- ;
        % N is used to compute the reduced exponents iteratively.     ;
        % ----------------------------------------------------------- ;
      >>;
     put(var,'pcdvar,pcdvar);
     put(var,'npcdvar,npcdv);
   >>
end;

symbolic procedure testrel colindex;
% ------------------------------------------------------------------- ;
% TestRel(evance) is used to determine if the TIMES-column with index ;
% Y possesses a Zstrt n which at least 2 elements obey the condition  ;
% that their IVal-value is at least 2. This test is either performed  ;
% in EXPANDPROD or in SHRINKPROD. In the latter case the test is need-;
% ed to be able to decide if a next application of EXPANDPROD is re-  ;
% quired. If so this is indicated by setting the flag EXPSHR. Hence   ;
% its existence is tested in the former case. When the flag proves to ;
% have been set it is removed to allow a possible next test. If it was;
% not yet set the TIMES-column with the index Y has not been used be- ;
% fore in an application of EXPANDPROD.                               ;
% ------------------------------------------------------------------- ;
begin scalar btst,mn,rcol,relcols,relrow,onerows,orows;
  if(btst:=flagp(list(farvar(colindex)),'expshr))
    then remflag(list(farvar(colindex)),'expshr)
    else
      << mn:=0;
         foreach z in zstrt(colindex) do
          if ival(z)>1 then << mn:=mn+1;
                               if mn=1 then relrow:=xind z
                            >>
                       else onerows:=xind(z).onerows;
         if not (btst:=(mn>1)) and mn=1 and
            onerows and length(zstrt(relrow))>1
            then
             << mn:=0;
                foreach z in zstrt(relrow) do
                 if (yind(z) neq colindex)
                  then << mn:=mn+1; relcols:=yind(z).relcols >>;
                if mn>0
                 then
                  while relcols and not(btst) do
                   << rcol:=car relcols; relcols:=cdr relcols;
                      orows:=onerows;
                      while orows and not(btst) do
                       << btst:=pnthxzz(car orows,zstrt rcol);
                          orows:=cdr orows
                       >>
                   >>
             >>
      >>;
  return(btst)
end;

symbolic procedure inspcvv(x,iv,s);
% ------------------------------------------------------------------- ;
% S is a list of pairs, given in ascending Car-ordering. The Cars are ;
% integers IV and the Cdrs are lists of objects X. Application of     ;
% InsPCvv leads to inclusion of the object X in the list associated   ;
% with IV. This Integer Value might be an exponent and the objects can;
% be row-indices, for instance.                                       ;
% ------------------------------------------------------------------- ;
if null(s)
 then list(iv.list(x))
 else
  if dm!-eq(iv,caar(s))
   then (iv.(x.cdar(s))).cdr(s)
   else
    if dm!-lt(iv,caar(s))
     then (iv.list(x)).s
     else car(s).inspcvv(x,iv,cdr s);


symbolic procedure shrinkprod;
% ------------------------------------------------------------------- ;
% After expansion of certain Times-columns additional Breuer-searches ;
% are performed. Shrinkprod is used to restore the remaining informa- ;
% tion in the standard form. So the distributed exponent portions are ;
% added together and stored in the original column. For the example,  ;
% introduced in Expandprod all remaining information is to be collect-;
% ed in column -15.                                                   ;
% Assume the Breuer-searches to have produced the following result :  ;
%                                                                     ;
% column|-15 -23 -24 -40|-60 -61 -62|     Row(7) and column(-60)      ;
%       +---------------+-----------+     define cse X5=X^2*X3.       ;
% row 1 |               |         1 |                                 ;
%     2 |               | 1         |     Row(8) and column(-61)      ;
%     3 |               |     1     |     define cse X3=X*X2.         ;
%     4 |               | 1         |                                 ;
%     5 |               | 1         |     Row(9) and column(-62)      ;
%     6 | 1             |           |     define cse X2=X*X.          ;
%       +---------------+-----------+                                 ;
%     7 |             2 |     1     |     The columns -15,-23 and -24 ;
%     8 |         1     |         1 |     define X-occurrences and    ;
%     9 | 1   1         |           |     the column -40 defines an   ;
%       -----------------------------     X^2-occurrence.             ;
%                                                                     ;
% ShrinkProd is used to recombine the information of column -15 and   ;
% those given in the PCDvar-list. The result is :                     ;
%                                                                     ;
% column|-15 -23 -24 -40|-60 -61 -62|                                 ;
%       +---------------+-----------+                                 ;
% row 1 |               |         1 |    The columns -23, -24 and -40 ;
%     2 |               | 1         |    remain unused until the next ;
%     3 |               |     1     |    application of ExpandProd.   ;
%     4 |               | 1         |    The indices remain stored in ;
%     5 |               | 1         |    the list NPCDvar (see the    ;
%     6 | 1             |           |    procedure ExpandProd).       ;
%       +---------------+-----------+    X^2 can again be found as a  ;
%     7 | 2             |     1     |    cse (see column -15). Hence  ;
%     8 | 1             |         1 |    ImproveLayout(see the module ;
%     9 | 2             |           |    CODAD1) is needed.           ;
%       -----------------------------                                 ;
%                                                                     ;
% ------------------------------------------------------------------- ;
begin scalar var,pcdvar,zz,zstreet,el,exp,collst,indx,further;
  for y:=rowmin:(-1) do
  if not numberp(var:=farvar y) and (pcdvar:=get(var,'pcdvar))
                                and opval(y) eq 'times
  then
  << % -------------------------------------------------------------- ;
     % Only Times-columns are elaborated, which are associated with   ;
     % those Var's of which the PCDvar-indicator has a nonNil value.  ;
     % The Opval test is needed because Var's are in general associa- ;
     % ted with both PLUS and TIMES-columns.                          ;
     % For the example holds : Var = X and PCDvar = ((1.(-15 -23 -24) ;
     % (2.(-40))).                                                    ;
     % -------------------------------------------------------------- ;
     zstreet:=zstrt(y);
     % -------------------------------------------------------------- ;
     % Initially holds : Zstrt(Y) = Zstreet = ((9.1)(6.1)).           ;
     % Application of ShrinkProd leads to : Zstreet = ((9.2)(8.1)(7.2);
     % (6.1)). This also affects the Zstrt's of the rows 7,8 and 9 and;
     % of the columns -23,-24 and -40.                                ;
     % -------------------------------------------------------------- ;
     foreach pcd in pcdvar do
      <<% ----------------------------------------------------------- ;
        % Pcd gets 2 different values for the example :               ;
        % (1.(-15=Y -23 -24)) and (2.(-40)).                          ;
        % ----------------------------------------------------------- ;
        exp:=car(pcd);
        collst:=delete(y,cdr pcd);
        % ----------------------------------------------------------- ;
        % The original Var!* column is left out during the now follow-;
        % ing reconstruction process, because it is Zstreet = Zstrt(Y);
        % which is restored.                                          ;
        % ----------------------------------------------------------- ;
        foreach col in collst do
        % ----------------------------------------------------------- ;
        % These Col's are all FarVar = -2 columns.                    ;
        % ----------------------------------------------------------- ;
         <>;
              setzstrt(indx,delyzz(col,zstrt indx))
              % ----------------------------------------------------- ;
              % Now the element Z is removed from the Zstrt of row    ;
              % Indx. The complete column Col is emptied and can thus ;
              % freely be reused during a next application of Expandp.;
              % To avoid any confusion ClearRow is used, implying that;
              % the FarVar-field of the column Col gets the value -1. ;
              % ----------------------------------------------------- ;
            >>;
           clearrow(col)
         >>
       >>;
      setzstrt(y,zstreet);
      remprop(var,'pcdvar);
      % ------------------------------------------------------------- ;
      % The final Zstreet-value is stored in column Y ( in the example;
      % column -15) and the PCDvar information is removed from the    ;
      % property list of Var.                                         ;
      % ------------------------------------------------------------- ;
      if testrel(y) then <>
      % ------------------------------------------------------------- ;
      % After regrouping TIMES-column information it is tested if a   ;
      % next application of EXPANDPROD is needed. If so T is returned.;
      % This value is used in EXTBRSEA to decide if the EXPAND-SHRINK ;
      % repeat-loop has to be continued or not.                       ;
      % ------------------------------------------------------------- ;
    >>;
    return(further)
 end;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codad2.red0000644000175000017500000016610211526203062023453 0ustar  giovannigiovannimodule codad2;   % Facilities applied after optimization.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors : J.A. van Hulzen, B.J.A. Hulshof, W.N. Borst.              ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

% ------------------------------------------------------------------- ;
% The module CODAD2 contains a number of facilities, to be applied    ;
% when the optimization process itself is finished and before  produ- ;
% cing output. This finishing touch, obtained by applying the function;
% PrepFinalplst (see the module CODCTL), covers the following one-row ;
% and/or one-column operations:                                       ;
%                                                                     ;
% PART 1 : Sum restructuring : s = (t1 + ... + tn) ^ exponent is re-  ;
%          placed by name := t1 + ... + tn; s:= name ^ exponent.      ;
%          Remark : This form allows application of an addition chain ;
%          algorithm on the exponent, as part of the print process,   ;
%          and as defined in the module CODPRI.                       ;
%                                                                     ;
% PART 2 : REMoval of REPeatedly occurring MULTiples of VARiables in  ;
%          linear (sub)expressions, which could not be replaced by a  ;
%          Breuer-search, since it requires one-column operations in  ;
%          the PLUS-part of CodMat. If such a multiple occurs atleast ;
%          twice, it is replaced by a new name. The TIMES-part of     ;
%          CodMat is consulted  if such a multiple is found to allow  ;
%          the replacement of such multiples in monomials as well. So ;
%          x = 3.a + b, y = 3.a + c, z = 3.a.b + c                    ;
%          is replaced by                                             ;
%          s = 3.a                                                    ;
%          x = s + b, y = s + c, z = s.b + c.                         ;
%                                                                     ;
% PART 3 : An UPDATE of MONOMIALS is performed. Constant multilpes of ;
%          identifiers are selected using the TIMES-part of CodMat.   ;
%          Since the PLUS-part is already checked with REMREPMULTVARS ;
%          the search is limited to the TIMES-part. Replacement by a  ;
%          new name is only effectuated if such a multiple literally  ;
%          occurs twice. So                                           ;
%          x = 3.a.b + 6.b.c, y = 3.a.c + 6.a.b                       ;
%          is replaced by                                             ;
%          s1 = 3.a, s2 = 6.b                                         ;
%          x = s1.b + s2.c, y = s1.c + s2.a.                          ;
%                                                                     ;
% PART 4 : An all level factoring out of gcd's of constant coeff.'s in;
%          (composite) sums, using the function CODGCD. For example   ;
%           sum = 9.a - 18.b + 6.sin(x) + 5.c -5.d                    ;
%          can be rewritten into                                      ;
%           sum = 3.(3.a - 6.b + 2.sin(x)) + 5.(c - d).               ;
%          But the arithmetic complexity of both representations of   ;
%          sum is equal. We therefore produce                         ;
%           sum = 9.a - 18.b + 6.sin(x) + 5.(c - d).                  ;
%          Regrouping of (composite) products demands for an identical;
%          algorithm. For instance                                    ;
%                   9 18   6                                          ;
%           prod = a b  sin (x)                                       ;
%          can be rewritten into                                      ;
%                               3                                     ;
%                    3 6   2                                          ;
%           prod = {a b sin (x)}                                      ;
%          thus reducing the required number of multiplications.      ;
%                                                                     ;
% PART 5 : A quotient-cse search. For example                         ;
%          kvarlst = ( (g1 quotient g2 g3)                            ;
%                      (g4 quotient g5 dm) )                          ;
%          matrix :  g2 = nr * a                                      ;
%                    g3 = dm * b                                      ;
%                    g5 = nr * c                                      ;
%          will be rewritten as                                       ;
%          kvarlst = ( (g7 quotient nr dm)                            ;
%                      (g1 quotient g2 b)                             ;
%                      (g4 g5) )                                      ;
%          matrix :  g2 = g7 * a                                      ;
%                    g5 = g7 * c                                      ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% Global identifiers needed in this module are :                      ;
% ------------------------------------------------------------------- ;

global '(rowmin rowmax);

% ------------------------------------------------------------------- ;
% The meaning of these globals is given in the module CODMAT.         ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure find!+var(var,fa,iv);
getcind(var,'varlst!+,'plus,fa,iv);

symbolic smacro procedure find!*var(var,fa,iv);
getcind(var,'varlst!*,'times,fa,iv);

symbolic procedure getcind(var,varlst,op,fa,iv);
% ------------------------------------------------------------------- ;
% REMARK : GETCIND is also defined in the module CODAD1. This copy    ;
%          allows seperate compilation.                               ;
% ------------------------------------------------------------------- ;
% The purpose of the procedure GetCind is to create a column in CODMAT;
% which will be associated with the variable Var if this variable does;
% not yet belong to the set Varlst,i.e.does not yet play a role in the;
% corresponding PLUS- or TIMES setting (known by the value of Op).Once;
% the column exists (either created or already available), its Zstrt  ;
% is modified by inserting the Z-element (Fa,IV) in it. Finally the   ;
% corresponding Z-element for the father-row, i.e. (Y,IV) is returned.;
% ------------------------------------------------------------------- ;
begin scalar y,z;
  if null(y:=get(var,varlst))
  then
  <>;
  setzstrt(y,inszzzn(z:=mkzel(fa,iv),zstrt y));
  return mkzel(y,val z)
end;


% ------------------------------------------------------------------- ;
% PART 1 : SUM RESTRUCTURING                                          ;
% ------------------------------------------------------------------- ;

symbolic procedure powerofsums;
% ------------------------------------------------------------------- ;
% The CODMAT PLUS-rows are investigated, who have an ExpCof-value > 1.;
% Such rows define a sum raised to the exponent ExpCof(rowindex).     ;
% ------------------------------------------------------------------- ;
begin scalar var,z,rmax;
  rmax:=rowmax;
  for x:=0:rmax do
  if opval(x) eq 'plus and expcof(x)>1 and not(farvar(x)=-1)
  then
   <>;
end;


% ------------------------------------------------------------------- ;
% PART 2 : REMoval of REPeatedly Occurring Constant MULTiples of PLUS ;
%          VARiableS.                                                 ;
% ------------------------------------------------------------------- ;

symbolic procedure remrepmultvars;
% ------------------------------------------------------------------- ;
% All PLUS-columns of CODMAT are investigated. Let Var be the variable;
% associated with thw column Y. A list P(lus)col(umn)inf(ormation) is ;
% made out of the Zstreet of column Y. Pcolinf consists of pairs of   ;
% the form  constant(k). list of pairs (rowindex.sign(constant(k))),  ;
% such that 0>;
      % ------------------------------------------------------------- ;
      % The list Tcolinf is now ready.If the number of elem.s of Srows;
      % and Tcolinf together is atleast 2 the multiplicative complexi-;
      % ty is not increasing if say 3*A is replaced by cse-name.      ;
      % ------------------------------------------------------------- ;
      if length(srows)+length(tcolinf)>1
      then
       << % --------------------------------------------------------- ;
          % A new expression is made and all required bookkeeping ac- ;
          % tions are performed. So all occurrences of say 3*A are re-;
          % moved from the Zstreet of the corresponding PLUS-column, a;
          % new column to store the placeholder for this 3*A is crea- ;
          % ted and all required modifications in the affected Zstrts ;
          % are carries out.                                          ;
          % --------------------------------------------------------- ;
          z:=mkzel(y,mmult);
          nvar:=fnewsym();
          rowmax:=rowmax+1;
          setrow(rowmax,'plus,nvar,list nil,list z);
          put(nvar,'rowindex,rowmax);
          rowmin:=rowmin-1;
          zz:=nil;
          foreach rowinf in srows do
            <>;
          setzstrt(y,mkzel(rowmax,val z).remzzzz(zz,zstrt y));
          setrow(rowmin,'plus,nvar,nil,zz);
          put(nvar,'varlst!+,rowmin);
          if tcolinf
           then
            << % --------------------------------------------------- ;
               % Since Tcolinf is not empty some monomials have to be;
               % modified as well.                                   ;
               % --------------------------------------------------- ;
               rowmin:=rowmin-1;
               zz1:=zz:=nil;
               foreach rowinf in tcolinf do
                 <1
                    then setival(z,ival(z)-1)
                    else
                     <>;
                   setzstrt(rindx,mkzel(rowmin,val car zz).
                                                       zstrt(rindx));
                   setprev(rindx,rowmax);
                   setexpcof(rindx,dm!-quotient(expcof(rindx),mmult))
                 >>;
               setzstrt(prodcoli,remzzzz(zz1,zstrt prodcoli));
               setrow(rowmin,'times,nvar,nil,zz);
               put(nvar,'varlst!*,rowmin)
            >>
         >>
      >>
  >>
end;


% ------------------------------------------------------------------- ;
% PART 3 : An UPDATE of MONOMIALS via a TIMES-columns search.         ;
% ------------------------------------------------------------------- ;

symbolic procedure updatemonomials;
% ------------------------------------------------------------------- ;
% For each column, which is associated with an identifier, a Gclst is ;
% produced. The syntax of such a list is given in PART 4. Each element;
% of such a list, is itself a list, consisting of a constant and      ;
% structural information about the occurrences of this constant. These;
% sublists are used to deside if constant multiples can be replaced by;
% new names. The decision are made by applying the function REMGCMON. ;
% ------------------------------------------------------------------- ;
for y:=rowmin:(-1) do
if not numberp(farvar y) and opval(y) eq 'times
 then foreach gcel in mkgclstmon(y) do remgcmon(gcel,y);

symbolic procedure mkgclstmon(y);
% ------------------------------------------------------------------- ;
% All monomial coefficients of the TIMES-rows sharing an element with ;
% the current TIMES-column are grouped in a Gclst if their absolute   ;
% value is atleast 2.                                                 ;
% ------------------------------------------------------------------- ;
begin scalar gclst,cof,indxsgn;
  foreach z in zstrt(y) do
   if not !:onep dm!-abs(cof:=expcof xind z)
    then
     << indxsgn:=cons(xind(z), if !:minusp cof then -1 else 1);
        gclst:=insgclst(cof,indxsgn,gclst,1)
     >>;
  return gclst
end;

symbolic procedure remgcmon(gcel,y);
% ------------------------------------------------------------------- ;
% RemGcMon is recursively applied on Gcel. Its purpose is finding re- ;
% peatedly occurring multiples of idntifiers in monomials. However 6.a;
% is not considered when 3.a proves to be a cse, simply because it    ;
% does not reduce the multiplicative complexity of the set of expres- ;
% sions being optimized.                                              ;
% The srategy employed is very similar to the techniques used in PART ;
% 4.                                                                  ;
% ------------------------------------------------------------------- ;
begin scalar x,nvar,gc,zel,zzy,zzgc,ivalz;
 if length(cadr gcel)>1
  then
   << gc:=car gcel;
      rowmin:=rowmin-1; rowmax:=rowmax+1;
      nvar:=fnewsym();
      zel:=mkzel(y,1);
      setrow(rowmax,'times,nvar,list(nil,gc),list(zel));
      put(nvar,'rowindex,rowmax);
      zzy:=mkzel(rowmax,val(zel)).zstrt(y);
      zzgc:=nil;
      foreach z in cadr(gcel) do
       << x:=car(z);
          setexpcof(x,1);
          setprev(x,rowmax);
          zel:=car(pnthxzz(x,zzy));
          if ival(zel)>1
           then
            << zzy:=inszzz(mkzel(x,ivalz:=dm!-difference(ival(zel),1)),
                                                         delyzz(x,zzy));
               setzstrt(x,inszzzr(mkzel(y,ivalz),delyzz(y,zstrt x)))
            >>
           else
            << zzy:=delyzz(x,zzy);
               setzstrt(x,delyzz(y,zstrt x))
            >>;
          zzgc:=inszzz(zel:=mkzel(x,1),zzgc);
          setzstrt(x,mkzel(rowmin,val zel).zstrt(x))
       >>;
     setzstrt(y,zzy);
     setrow(rowmin,'times,nvar,nil,zzgc);
     put(nvar,'varlst!*,rowmin)
   >>;
  if cddr(gcel) then foreach item in cddr(gcel) do remgcmon(item,y)
end;

% ------------------------------------------------------------------- ;
% PART 4 : Gcd-based expression rewriting                             ;
% ------------------------------------------------------------------- ;
% We employ a two stage strategy. We start producing a Gclst, consis- ;
% ting of row-information. If relevant, Gclst is used to rewrite the  ;
% expression (part), defined by the current row of CodMat. The Gclst- ;
% syntax is :                                                         ;
%                                                                     ;
% Gclst ::= (Gcdlst  Gcdlst  ... Gcdlst ) , n >= 1 .                  ;
%                  1       2           n                              ;
% Gcdlst ::= (G Glocations glst  ... glst ) , m >= 0 .                ;
%                              1         m                            ;
% G ::= positive integer                                              ;
% Glocations ::= (location  ... location ) , k >= 0 .                 ;
%                         1             k                             ;
% location ::= (index . coeffsign)                                    ;
% coeffsign ::= +1 | -1                                               ;
% index ::= columnindex | rowindex                                    ;
% columnindex ::= negative integer (relative value, see CodMat def.)  ;
% rowindex ::= non-negative integer (relative value, see Codmat def.) ;
% glst ::= (g Glocations)                                             ;
% g ::= positive integer                                              ;
%                                                                     ;
% Semantics : We assume G = gcd(g1,...,gm) > 1. When other domains are;
% introduced, the presumed domain is not longer Z, implying that Gcd2,;
% * and / have to be made generic, when producing Gclst and rewriting ;
% the expression using the function RemGc.                            ;
% When m = 0, i.e. no glst's occur, the absolute value of all coeffi- ;
% cients is equal to G.                                               ;
% Glocations can be an empty list,as shown in the following example : ;
%                                                                     ;
% ((3 NIL (9 ((a.1))) (18 ((b.-1))) (6 ((sin(x).1))))                 ;
%  (5 ((c.1) (d.-1))))                                                ;
%                                                                     ;
% is the Gclst, associated with                                       ;
% sum = 9.a - 18.b + 6.sin(x) + 5.c - 5.d,                            ;
% when replacing the negative, relative column-indices by a,b,c and d,;
% and the positive relative child row-index by sin(x).                ;
% This list is used for the remodelling. The Glocations list is NIL,  ;
% because sum has no coefficients equal to either 3 or -3.            ;
% ------------------------------------------------------------------- ;

symbolic procedure codgcd();
begin scalar presentrowmax;
% ------------------------------------------------------------------- ;
% For all relevant rows of CodMat we compute the Gclst, by applying   ;
% the function MkGclst. Then each item in this list, a Gcdlst, is used;
% for a reconstruction of the expression( part) defined by row X.     ;
% ------------------------------------------------------------------- ;
presentrowmax:=rowmax;
for x:=0:presentrowmax do
  if not(farvar(x)=-1)then foreach gcel in mkgclst(x) do remgc(gcel,x)
end;

symbolic procedure mkgclst(x);
% ------------------------------------------------------------------- ;
% The Gclst of row X is produced and returned.                        ;
% ------------------------------------------------------------------- ;
begin scalar gclst,iv,opv;
  foreach z in zstrt(x) do
   if not !:onep(dm!-abs(iv:=ival z))
    then
     % -------------------------------------------------------------- ;
     % The location (Yind(Z).coeffsign) is added to the glst with g = ;
     % abs(IV).                                                       ;
     % -------------------------------------------------------------- ;
     if !:minusp(iv)
      then gclst:=insgclst(dm!-minus(iv),yind(z).(-1),gclst,1)
      else gclst:=insgclst(iv,yind(z) . 1,gclst,1);
  opv:=opval(x);
  foreach ch in chrow(x) do
   if not(opval(ch)=opv) and not(!:onep dm!-abs(iv:=expcof ch))
    % --------------------------------------------------------------- ;
    % Only non *(+)-children of *(+)-parents are considered.          ;
    % --------------------------------------------------------------- ;
    then
      % ------------------------------------------------------------- ;
      % The location (CH(=rowindex of child).coeffsign) is added to   ;
      % the glst with g = abs(IV).                                    ;
      % ------------------------------------------------------------- ;
      if !:minusp(iv)
       then gclst:=insgclst(dm!-minus iv,ch.(-1),gclst,1)
       else gclst:=insgclst(iv,ch . 1,gclst,1);
  return gclst;
end;

symbolic procedure insgclst(iv,y,gclst,gc0);
% ------------------------------------------------------------------- ;
% The most recent version of Gclst is returned after being updated by ;
% adding the location Y to the glst with g = abs(IV) in Gclst, assu-  ;
% ming that G = Gc0.                                                  ;
% ------------------------------------------------------------------- ;
begin scalar gc,cgcl;
  return
    if null(gclst)
     then
      % ------------------------------------------------------------- ;
      % Start making such a list : If Y = (-1 . 1) and IV = 4 then we ;
      % get ((4 ((-1 . 1)))).                                         ;
      % ------------------------------------------------------------- ;
      list(iv.(list(y).nil))
     else
      % ------------------------------------------------------------- ;
      % Extend the Gclst.                                             ;
      % ------------------------------------------------------------- ;
      if dm!-eq(caar(gclst),iv)
       % ------------------------------------------------------------ ;
       % Add floats only to Gcdlst's of type (G Glocations).          ;
       % Then IV = G (of Gcdlst ) and Y is added to Glocations  as new;
       %                       1                              1       ;
       % location (since Cadar(Gclst) = Glocations of Gcdlst , Cddar  ;
       %                                                    1         ;
       % (Gclst) = (glst  ... glst ) and Cdr(Gclst) = (Gcdlst  ...    ;
       %                1         m                           2       ;
       % Gcdlst )).                                                   ;
       %       n                                                      ;
       % If now IV = 4 and Y =(-2 . 1) then Gclst = ((4 ((-1 . 1))))  ;
       % is extended to ((4 ((-2 . 1) (-1 . 1)))).                    ;
       % ------------------------------------------------------------ ;
       then (iv.((y.cadar(gclst)).cddar(gclst))).(cdr gclst)
       else
        if floatprop(iv) or floatprop(caar gclst) or
             (gc:=gcd2(iv,caar gclst)) <= gc0
         then
         % ---------------------------------------------------------- ;
         % IV and G  are relative prime. The elements Gcdlst , i > 1, ;
         %                                                  i         ;
         % are further investigated, if existing.                     ;
         % So if IV = 5 and Y = (-2 . 1) then Gclst = ((4 (-1 . 1)))) ;
         % is extended to ((4 ((-1 . 1))) (5 ((-2 . 1))))).           ;
         % ---------------------------------------------------------- ;
          car(gclst).insgclst(iv,y,cdr gclst,gc0)
         else
        % ----------------------------------------------------------- ;
        % Gc = gcd(IV,G ) > Gc0 (=1, initially).                      ;
        %              1                                              ;
        % ----------------------------------------------------------- ;
          if gc=caar(gclst)
           % -------------------------------------------------------- ;
           % IV > Gc = G , implying that the (IV,Y)-info has to be    ;
           %            1                                             ;
           % stored in one of the Gcdlst  lists, i > 1.               ;
           %                            i                             ;
           % So if IV=8 and Y=(-2 . 1) then Gclst = ((4 ((-1 . 1))))  ;
           % is extended to ((4 ((-1 . 1)) (8 ((-2 . 1)))).           ;
           % -------------------------------------------------------- ;
           then (append
                  (list(gc,cadar gclst),insdiff(iv,y,cddar gclst))).
                                                            (cdr gclst)
           else
            if gc=iv
            % ------------------------------------------------------- ;
            % Gc = IV < G  demands for remodelling of Gcdlst , such   ;
            %            1                                  1         ;
            % that now Gcdlst  = (Gc Etc).So if IV = 2 and Y =(-2 . 1);
            %                1                                        ;
            % then Gclst = ((4 ((-1 . 1)))) is extended to the list   ;
            % ((2 ((-2 . 1)) (4 ((-1 . 1))))).                        ;
            % ------------------------------------------------------- ;
             then << if null(cadar gclst)
                      then list(append(list(gc,list(y)),cddar gclst))
                      else if cddar(gclst) and caddar(gclst)
            % ------------------------------------------------------- ;
            %                  ^ Neccesary test for R35.              ;
            % Can't take car of cddar if cddar is NIL (a.o.t. R34)    ;
            %----------------------------------------------JB 1994----;
                        then (append(list(gc,list(y),list(caar gclst,
                                cadar gclst)),cddar gclst)).(cdr gclst)
                        else (gc.(list(y).list(car gclst))).(cdr gclst)
                  >>
             else
             % ------------------------------------------------------ ;
             % Gc < IV and Gc < G , i.e. Glocations := NIL. So if IV =;
             %                   1                 1                  ;
             % 6 and Y = (-2 . 1) then Gclst = ((4 (-1 . 1)))0 is ex- ;
             % tended to ((2 NIL (6 ((-2 . 1))) (4 ((-1 . 1))))).     ;
             % ------------------------------------------------------ ;
               (gc.(nil.append(list(iv.(list(y).nil)),
                    if cddar gclst
                     then append(list(list(caar gclst,cadar gclst)),
                                                           cddar gclst)
                     else list(list(caar gclst,cadar gclst)))))
                     .(cdr gclst)
end;

symbolic procedure insdiff(iv,y,glsts);
% ------------------------------------------------------------------- ;
% glstst is a list of glst 's, i >= 0. If IV = g , k<= i, then Y is   ;
%                         i                     k                     ;
% inserted in glocations  and else list(IV.(list(Y).NIL)) is added to ;
%                       k                                             ;
% glsts.                                                              ;
% ------------------------------------------------------------------- ;
begin scalar b,rlst;
 while glsts and (not b) do
  << if caar(glsts)=iv
      then <>
      else rlst:=car(glsts).rlst;
     glsts:=cdr(glsts)
  >>;
 return if b
         then append(reverse(rlst),glsts)
         else append(list(iv.(list(y).nil)),reverse(rlst))
end;


symbolic procedure remgc(gcel,x);
% ------------------------------------------------------------------- ;
% RemGc allows a recursive investigation of Gcel, a Gcdlst being an   ;
% element of the Gclst of row X. Therefore it returns a list of loca- ;
% tions, which can be empty as well. These locations are remodelled   ;
% into Zstrt-elements, subject to some profitability criteria, which  ;
% will be explained in the body of this function.                     ;
% Once the list of remodelled locations is ready, it is used to re-   ;
% arrange the corresponding CodMat-elements into the desired form.    ;
% ------------------------------------------------------------------- ;
begin scalar zzch,zzchl,zzr,chr,zz,ch,nsum,nprod,ns,np,opv,gc,cof,
                                                   cofloc,iv,var1,var2;
  % ----------------------------------------------------------------- ;
  % Gcel is a Gcdlst, i.e. it has the structure (G Glocations glst's).;
  % So Cddr(Gcel) = (glsts's) =(glst  ... glst ), m>= 0. A glst itself;
  %                                 1         m                       ;
  % has the structure (g Glocations), i.e. Cddr(glst) = NIL.          ;
  % Hence Gcel is either a Gcdlst or a glst. For both alternatives    ;
  % holds : Car(Gcel) = a positive integer (G or g) and Cadr(Gcel) =  ;
  % a Glocations-list, i.e. each element of Cadr(Gcel) ia a pair      ;
  % (index.coeffsign), where Car(Gcel) is the absolute value of the   ;
  % coefficient (exponent) to be associated with row X and a column-  ;
  % index or the row-index of a child, respectively.                  ;
  % If Gcel defines the structure of a monomial the description is im-;
  % proved if atleast 2 exponents are G or if the exponents have a gcd;
  %               6 6      6 9                         2 3 3          ;
  % > 1. So both a b  and a b  are restructured into (a b )  and      ;
  %     6                                                             ;
  % (ab) , respectively.                                              ;
  % If Gcel defines the structure of a sum coefficients are factored  ;
  % out (recursively), i.e. 6.a + 9.b remains unchanged and 6.a + 6.b ;
  % is restructured into 6.(a + b). The Gcel is (3 NIL (6 ((a.1)))    ;
  % (9 ((b.1)))) and (6 ((a.1) (b.1))), respectively.                 ;
  % Restructuring requires a new TIMES(PLUS)-row to store the EXPCOF  ;
  % value GC (6) and a new PLUS(TIMES)-row to store its base ab or    ;
  % factor a + b, respectively.                                       ;
  % ----------------------------------------------------------------- ;
  if ((opv:=opval(x)) eq 'times and
     (length(cadr gcel)>1 or cddr(gcel))) or
     ((opv eq 'plus) and (length(cadr gcel)>1))
  then
   <>
     else
       << nprod:=rowmax+1; nsum:=rowmax:=rowmax+2;
          setchrow(x,nprod.chrow(x));
          setrow(nprod,if opv eq 'plus then 'times else 'plus,x,
                                    list(list(nsum),gc:=car gcel),nil);
          setrow(nsum,opv,nprod,list nil,nil)
       >>;
     zzch:=updaterowinf(x,nsum,1,cadr gcel,zzr,chr);
     foreach y in cddr gcel do
      <>
              else
               << ns:=rowmax:=rowmax+1;
                  var2:=fnewsym();
                  put(var2,'rowindex,ns);
                  setprev(get(var1,'rowindex),ns);
                  setrow(rowmin:=rowmin-1,'times,var2,nil,
                                             list(iv:=mkzel(nsum,cof)));
                  setzstrt(nsum,inszzzr(mkzel(rowmin,val iv),
                           zstrt nsum));
                  put(var2,'varlst!*,rowmin);
                  setrow(ns,'times,var2,list nil,nil)
               >>;
            zz:=ch:=nil;
            zzchl:=updaterowinf(x,ns,1,cofloc,zz,ch);
            setzstrt(ns,car zzchl);
            setchrow(ns,cdr zzchl)
          >>
         else
          zzch:=updaterowinf(x,nsum,cof,cofloc,car zzch,cdr zzch)
      >>;
     foreach zel in car(zzch) do setzstrt(nsum,inszzzr(zel,zstrt nsum));
     setchrow(nsum,if chrow(nsum) then append(chrow(nsum),cdr zzch)
                                  else cdr zzch)
  >>
else
 foreach item in cddr gcel do remgc(item,x)
end;


symbolic procedure updaterowinf(x,nrow,cof,infolst,zz,ch);
% ------------------------------------------------------------------- ;
% UpdateRowInf is used in the function RemGc to construct the Zstrt   ;
% ZZ and the list of children CH of row Nrow and using the Infol(i)st.;
% Infolst is a glst.                                                  ;
% ------------------------------------------------------------------- ;
begin scalar indx,iv,mz,dyz;
 foreach item in infolst do
  << indx:=car(item);
     if indx < 0
      then
       << zz:=inszzzr(iv:=mkzel(indx,dm!-times(cof,cdr(item))),zz);
          setzstrt(indx,inszzz(mkzel(nrow,val(iv)),
                                               delyzz(x,zstrt indx)));
          setzstrt(x,delyzz(indx,zstrt x))
       >>
      else
       << ch:=indx.ch;
          chdel(x,indx);
          setfarvar(indx,nrow);
          setexpcof(indx,dm!-times(cof,cdr(item)))
       >>
  >>;
 return zz.ch
 end;

% ------------------------------------------------------------------- ;
% PART 5 : QUOTIENT-CSE SEARCH                                        ;
% ------------------------------------------------------------------- ;

global '(kvarlst qlhs qrhs qlkvl);

symbolic procedure tchscheme2;
% ---
% Moves every plus-row having just one z-element to the times-scheme.
% Also copies every single child(i.e. it's the only child of its father)
% of a plus-row to its father-row.
% ---
begin
   for x:=0:rowmax do
   << removechild x;
      to!*scheme x
   >>;
end;

symbolic procedure to!*scheme x;
% ---
% Moves plus-row x, which has just one z-element, to the times-scheme.
% ---
begin scalar z,yi,exp;
   if not(numberp farvar(x)) and opval(x) eq 'plus and
         length(zstrt x)=1 and null(chrow x) then
   << z:=car zstrt(x);
      yi:=yind z;
      exp:=expcof x;
      setexpcof(x,dm!-expt(ival z,exp));
      z:=find!*var(farvar yi,x,exp.bval(z));
      setzstrt(yi,delyzz(x,zstrt yi));
      setzstrt(x,list z);
      setopval(x,'times);
   >>
end;

symbolic procedure removechild x;
% ---
% Copies the only child of plus-row x to row x.
% ---
begin scalar ch,exp,iv;
   if not(numberp farvar(x)) and opval(x) eq 'plus and
         null(zstrt x) and length(chrow x)=1 then
   << ch:=car chrow x;
      exp:=expcof x;
      foreach z in zstrt ch do
      << setzstrt(yind z,delyzz(ch,zstrt yind z));
         iv:=dm!-times(ival(z),exp);
         setzstrt(yind z,inszzz(mkzel(x,iv),zstrt yind z));
         setzstrt(x,inszzzr(mkzel(yind z,iv),zstrt x))
      >>;
      foreach chld in chrow(ch) do setfarvar(chld,x);
      setopval(x,'times);
      setexpcof(x,dm!-times(expcof ch,exp));
      setchrow(x,chrow ch);
      clearrow ch;
   >>
end;

symbolic procedure searchcsequotients;
begin
  scalar res,continuesearch;
  tchscheme2();
  res := continuesearch := searchcsequotients2();
  while continuesearch do
        continuesearch := searchcsequotients2();
  return res;
  end;

symbolic procedure searchcsequotients2;
% -------------------------------------------------------------------- ;
% Quotient-structured cse's can exist in the prefixlist, defining the
% result of an extended Breuer-search, since this search is performed
% on a set of polynomial-like (sub)-expressions, which may contain
% numerators and denominators as seperate expressions.
% So we know after optimization that neither the subset of numerators
% nor the subset of denominators have a cse in common.
% This implies that possibly occurring cse's always have the form
% (quotient numer denom), where both numer and denom are either numbers
% or identifiers.
% An example:
% The set {x:=(ab)/(cd),y:=(ae)/(cf),z:=(bg)/(dh)} contains the cse's
% s1:=a/c and s2:=b/d,
% which can lead to the new set
%  {s1:=a/c,s2:=b/d, x:=s1.s2, y:=(s1.e)/f,z:=(s2.g)/h},
% thus saving 3 *'s but adding 1 /.
% This function serves to produce such revisions when ever possible,
% and assuming that one / is equivalent to at most two *'s.
% -------------------------------------------------------------------- ;
begin
  scalar j,quotients,dmlst,dm,numerinfol,nrlst,selecteddms,
         selectednrs,quotlst,b,quots,profit,qcse,cselst,var,s;
  qlkvl:=length(kvarlst);
  qlhs:=mkvect(qlkvl); qrhs:=mkvect(qlkvl);
  j:=0;
  quotients:=nil;
  foreach item in kvarlst do
     << putv(qlhs,j:=j+1,car item);
        putv(qrhs,j,cdr item);
        if relquottest(getv(qrhs,j))
           then quotients:=cons(j,quotients);
     >>;
% ---
% quotients contains indices of relevant quotients in lhs-rhs (kvarlst)
% ---
   if quotients then
   <<
      foreach indx in quotients do
         dmlst:=insertin(dmlst,caddr getv(qrhs,indx),indx);
      dmlst:=addmatnords(dmlst);
% ---
% dmlst = ( (item.(indices to quotients containing item in denominator))
%           ... )
% ---
      selecteddms:=selectmostfreqnord(dmlst);
         if selecteddms and length(cdr selecteddms)>1
            then % at least 2 ../dm's.
              << % selecteddms = item which appears the most in
                 % denominators.
                 dm:=car selecteddms; numerinfol:=cdr selecteddms;
                 nrlst:=nil;
                 foreach indx in numerinfol do
                    nrlst:=insertin(nrlst,cadr getv(qrhs,indx),indx);
                 nrlst:=addmatnords(nrlst);
                 % ---
                 % nrlst = ((item.(indices of quotients containing item
                 %             in numerator and the selected denominator
                 %             in the denominator) ... )
                 % ---
                 if (selectednrs:=selectmostfreqnord(nrlst))
                    then if length(cdr selectednrs)>1
                            then % cse is car(selectednrs)/dm.
                       quotlst:=((car(selectednrs).dm).cdr(selectednrs))
                                           . quotlst
              >>;

      %  dmlst:=delete(selecteddms,dmlst);
      % ---
      % quotlst = (((numerator . denominator) .
      %            st of indices to quotients containing quotient)) ...)
      % i.e. list of quotients containing the cse-quotient
      % ---

      if quotlst then
      << quots:=mkvect(qlkvl);
         foreach item in quotlst do
         << profit:=qprofit(item);
         % ----------------------------------------------------------- ;
         % qprofit delivers the pair *-savings./-savings. The assoc.   ;
         % quotient, defined as pair numerator.denominator and stored  ;
         % as car of the item, will be considered as cse if profit=t.  ;
         % ----------------------------------------------------------- ;
          if ((cdr profit) geq 0) or ((car(profit)+2*cdr(profit)) geq 0)
            then   % cse-quotient is profitable
            << b:=t;
               qcse:=list('quotient,caar item,cdar item);
               if (var:=assoc(qcse,s:=get(car qcse,'kvarlst))) then
                  qcse:=cdr(var).qcse
               else
               << var:=fnewsym();
                  put(car qcse,'kvarlst,(qcse.var).s);
                  qcse:=var.qcse;
                  cselst:=qcse.cselst
               >>;
               foreach indx in cdr(item) do
                  if car(qcse) neq getv(qlhs,indx)
                     then substqcse(qcse,indx)
            >>
         >>;
         kvarlst:=nil;
         for j:=1:qlkvl do
            if getv(qlhs,j)
               then % remove cleared quotients
               kvarlst:=append(kvarlst,list(getv(qlhs,j).getv(qrhs,j)));
         % add new quotients
         kvarlst:=append(kvarlst,cselst);
      >>
   >>;
   qlkvl:=qlhs:=qrhs:=nil;
   return(b)
end$


symbolic procedure relquottest(item);
% -------------------------------------------------------------------- ;
% returns t if item is a quotient with a numerator (cadr item) and a
% denominator (caddr item), which are a product, a constant or an .    ;
% identifier i.e. , which have a relv(evant) str(ucture).              ;
% -------------------------------------------------------------------- ;
   eqcar(item,'quotient) and relvstr(cadr item) and relvstr(caddr item);

symbolic procedure relvstr(item);
% -------------------------------------------------------------------- ;
% Only those numerators or denominators are relevant which can possibly;
% contribute to cse-quotients, i.e. constants, identifiers or products ;
% -------------------------------------------------------------------- ;
begin scalar rowindx;
   return
      constp(item) or idp(item) %or
%         ((rowindx:=get(item,'rowindex)) and opval(rowindx) eq 'times)
end;

symbolic procedure addmatnords(nordlst);
% ---
% The numerators and denominators are concidered at two levels:
% 1) nords in the kvarlst and
% 2) nords in rows which are used in the kvarlst. Nordlst contains
% relevant nords from level 1.
% A row from level 1 is opened, i.e. replaced by relevant nords from
% level 2 (its z-elements) when:
%     o The row occurs only once in the union of both levels.
%     o The row is only used for this nord and is used nowhere else in
%       codmat or kvarlst.
% Otherwise the nord is unchanged.
% ---
begin scalar matnords,templst,rowindx;
   % First: find all the nords at level 2 (matnords)
   foreach nord in nordlst do
      foreach indx in cdr nord do
         if (rowindx:=get(car nord,'rowindex)) and
            opval(rowindx) eq 'times then
         << foreach z in zstrt rowindx do
               matnords:=insertin(matnords,farvar yind z,indx);
            if abs(expcof rowindx) neq 1 then
               matnords:=insertin(matnords,expcof rowindx,indx)
         >>;
   % Second: open the appropriate 1st level rows
   foreach nord in nordlst do
   << if length(cdr nord)>1 then
         foreach indx in cdr nord do
            templst:=insertin(templst,car nord,indx)
      else
         if assoc(car nord,matnords) then
            templst:=insertin(templst,car nord,cadr nord)
         else
            if (rowindx:=get(car nord,'rowindex)) and
               opval(rowindx) eq 'times and nofnordocc(car nord)=1 then
            << foreach z in zstrt rowindx do
                  templst:=insertin(templst,farvar yind z,cadr nord);
               templst:=insertin(templst,expcof rowindx,cadr nord)
            >>
   >>;
   return templst
end;

symbolic procedure nofnordocc(nord);
% ---
% Finds out howmany times nord occurs in the kvarlst and the schemes.
% ---
begin scalar nofocc;
   nofocc:=nofmatnords nord;
   for i:=1:qlkvl do
      nofocc:=nofocc+numberofocc(nord,getv(qrhs,i));
   return nofocc
end;

symbolic procedure numberofocc(var,expression);
% -------------------------------------------------------------------- ;
% The number of occurrences of Var in Expression is computed and       ;
% returned.                                                            ;
% -------------------------------------------------------------------- ;
if constp(expression) or idp(expression)
 then
  if var=expression then 1 else 0
 else
 (if cdr expression
   then numberofocc(var,cdr expression)
   else 0)
 +
 (if var=car expression
   then 1
   else
    if not atom car expression
     then numberofocc(var,car expression)
     else 0);

symbolic procedure nofmatnords nord;
begin scalar nofocc,colindx;
   nofocc:=0;
   if (colindx:=get(nord,'varlst!*)) then
      nofocc:=length zstrt colindx;
   if (colindx:=get(nord,'varlst!+)) then
      nofocc:=nofocc+length zstrt colindx;
   return nofocc
end;

symbolic procedure insertin(nordlst,item,indx);
% -------------------------------------------------------------------- ;
% Once it is known that item is a constant or an identifier it can be  ;
% stored in the nordlst list.If item is a negative number the -indx is ;
% attached to the cdr of nordlst and -item is used as recognizer.      ;
% -------------------------------------------------------------------- ;
begin scalar pr;
 return(if !:onep(dm!-abs item) then nordlst
        else
           if (pr:=assoc(item,nordlst))
           then foreach el in nordlst collect
            if car(el)=item then item.append(cdr pr,list(indx)) else el
           else append(list(item.list(indx)),nordlst))
end;

symbolic procedure selectmostfreqnord(nordlst);
% -------------------------------------------------------------------- ;
% The nordlst consists of pairs, formed by a constant or identifier as ;
% car and a list of indices of rhs's, denoting the quotients containing;
% this car.                                                            ;
% The pair with the longest indxlst is selected and returned.          ;
% -------------------------------------------------------------------- ;
begin scalar templst,temp,selectedpr,lmax;
 if nordlst
  then
   << selectedpr:=car nordlst;
      lmax:=length(cdr selectedpr);
      templst:=cdr nordlst;
      foreach pr in templst do
       << if lmax < (temp:=length(cdar templst))
           then << lmax:=temp; selectedpr:=car templst >>;
          templst:=cdr templst
       >>
   >>;
 return(selectedpr)
end;

symbolic procedure qprofit(item);
% -------------------------------------------------------------------- ;
% indxlist consists of signed indices of the vectors lhs and rhs. The  ;
% structure of the rhs's, being quotients is used to determine the     ;
% number of multiplications and divisions saved by considering the     ;
% corresponding quotient as a cse.                                     ;
% The rules we apply are straightforward. Assume the cse-candidate     ;
% is defined by s:=nr/dm. Then we can distinguish between the 4 fol-   ;
% lowing situations:                                                   ;
% -1- quotient=s,       i.e. 1 /-operation can be saved.               ;
% -2- quotient=s/a,     i.e. 1 *-operation can be saved.               ;
% -3- quotient=s*a,     i.e. 1 /-operation can be saved.               ;
% -4- quotient=(s*a)/b, i.e. 1 *-operation can de saved, but no        ;
%                              /-operation is saved.                   ;
% We simply test if dm is a constant or an identifier (1 /-saving) or a;
% product (1 *-saving).                                                ;
% But if nr is a product we still need the /-operation                 ;
% s will function as cse if nbof!/>=0 or when nbof!*+2*nbof!/>=0,      ;
% assuming that a division is atmost as costly as 2 multiplications.   ;
% We neglect for the moment the extra assignments, i.e. stores.        ;
% -------------------------------------------------------------------- ;
begin scalar nbof!*,nbof!/,tempquot,h,f,tf,il;
   il:=cdr(item);
   while il do
   << h:= car(il); il:=cdr(il); f:=h.f;
      foreach indx in il do << if indx neq h then tf:=indx.tf >>;
      if not null(tf)
       then << il:=reverse tf, tf:=nil >>
       else il:=nil
    >>;
   if length(il:=reverse f)=1
    then
     << nbof!*:=0; nbof!/:=-1 >>
    else
     << nbof!*:=0; nbof!/:=-1;
                   % nbof!* is atmost 0. nbof!/ may be negative.
        foreach sgnindx in il do
         << tempquot:=getv(qrhs,sgnindx);
                                 % The rhs-struct. is '(quotient nr dm).
            if cdar(item)=caddr(tempquot) then nbof!/:=1+nbof!/
                                          else nbof!*:=1+nbof!*;
         >>
      >>;
   return(cons(nbof!*,nbof!/))
end;

symbolic procedure substqcse(csepair,indx);
% -------------------------------------------------------------------- ;
% csepair is a pair consisting of a system generated cse name and the  ;
% struct. of a quotient-cse. If sgnindx<0 the cse parent has a minus as;
% leading operator. If minsgn the cse has also a minus as leading ope- ;
% rator. Based on this information the rhs(abs(sgnindx)) is rewritten, ;
% i.e. the cse-value is removed and replaced by the cse-name.          ;
% -------------------------------------------------------------------- ;
begin scalar var,val,dm,nr,pnr,pdm,ninrow,dinrow,expo;
   var:=car(csepair);
   val:=cdr(csepair);
   nr:=cadr val;
   dm:=caddr val;
   pnr:=cadr(getv(qrhs,indx));
   pdm:=caddr(getv(qrhs,indx));
   ninrow:=if (nr neq pnr) then get(pnr,'rowindex) else nil;
   dinrow:=if (dm neq pdm) then get(pdm,'rowindex) else nil;
   expo:=min(nordexpo(nr,pnr),nordexpo(dm,pdm));
   pnr:=remnord(nr,expo,pnr,indx);
   pnr:=insnord(var,expo,pnr,indx);
   pdm:=remnord(dm,expo,pdm,indx);
   pnr:=checknord(pnr,ninrow,indx);
   pdm:=checknord(pdm,dinrow,indx);
   % If we want to remove qlhs[indx] this should not be a protected
   % variable of some sort...
   if !:onep(pdm) and unprotected(getv(qlhs,indx))
    then << remquotient(pnr,indx); putv(qlhs,indx,nil) >>
    else putv(qrhs,indx,if !:onep(pdm)
                          then pnr else list('quotient,pnr,pdm))
end;

symbolic procedure unprotected var;
% States wether var is free to be removed or not.
flagp(var,'newsym) and not get(var,'alias);

symbolic procedure nordexpo(x,y);
% ---
% Calculates the power of x in product y.
% Assumption : y contains x.
% ---
   if constp x then
      1
   else if idp x then
      if x=y then
         1
      else
         begin scalar res;
           if (res:=assoc(get(x,'varlst!*),zstrt get(y,'rowindex)))
              then res := ival res
              else res := 0;
           return res
           end;

symbolic procedure remnord(item,expo,dest,indx);
% ---
% Divides item^expo out of dest. Dest is a constant, a variable or a
% variable determining a row in CODMAT.
% Item is a constant or a variable.
% Assumption : dest contains item^n, n >= expo.
% ---
begin scalar rowindx,colindx,z;
   return
      if constp dest then
         dm!-quotient(dest,dm!-expt(item,expo))
      else
         if item=dest then
         << remquotordr(indx,item);
            if (rowindx:=get(item,'rowindex)) then
               remquotordr(indx,rowindx);
            1
         >>
         else
         << rowindx:=get(dest,'rowindex);
            if constp(item) then
            << if opval(rowindx)='times then
                setexpcof(rowindx,dm!-quotient(expcof rowindx,
                                              dm!-expt(item,expo)))
               else <>;
               dest
            >>
            else
            << colindx:=get(item,'varlst!*);
               z:=assoc(colindx,zstrt rowindx);
               setzstrt(colindx,delyzz(rowindx,zstrt colindx));
               setzstrt(rowindx,delete(z,zstrt rowindx));
               if ival(z)=expo then
               << remprev(rowindx,item);
                  if get(item,'rowindex) then
                     remprev(rowindx,get(item,'rowindex))
               >>
               else
               << setzstrt(colindx,
                           inszzz(mkzel(rowindx,(ival(z)-expo).bval(z)),
                                          zstrt colindx));
                  setzstrt(rowindx,
                          inszzzr(mkzel(colindx,(ival(z)-expo).bval(z)),
                                           zstrt rowindx))
               >>;
               dest
            >>
         >>
end;

symbolic procedure insnord(item,expo,dest,indx);
% ---
% Multiplies item^expo into dest. Dest is a constant, a variable or a
% variable determining a row in CODMAT.
% Item is a constant or a variable.
% ---
begin scalar rowindx;
   return
      if constp dest then
         if constp item then
            dm!-times(dest,dm!-expt(item,expo))
         else
         << %if (rowindx:=get(item,'rowindex)) then
            %   insquotordr(indx,rowindx)
            %else
            %   insquotordr(indx,item);
            item  % dest = 1
         >>
      else
      << rowindx:=get(dest,'rowindex);
         if constp item then
         <>
         else
         << setzstrt(rowindx,inszzzr(mkzel(car find!*var(item,
                                                         rowindx,expo),
                                           expo),zstrt rowindx));
            if get(item,'rowindex) then
               setprev(rowindx,get(item,'rowindex))
            else
               setprev(rowindx,item);
            dest
         >>
      >>
end;

symbolic procedure insquotordr(indx,ord);
% ---
% This procedure inserts ord in all order-lists of rows containing the
% quotient indiced by indx.
% ---
begin scalar col;
   if (col:=get(getv(qlhs,indx),'varlst!+)) then
      foreach z in zstrt(col) do
         setprev(xind z,ord);
   if (col:=get(getv(qlhs,indx),'varlst!*)) then
      foreach z in zstrt(col) do
         setprev(xind z,ord)
end;

symbolic procedure remquotordr(indx,ord);
% ---
% This procedure removes ord from all order-lists of rows containing
% the quotient indiced by indx.
% ---
begin scalar col;
   if (col:=get(getv(qlhs,indx),'varlst!+)) then
      foreach z in zstrt(col) do
         remprev(xind z,ord);
   if (col:=get(getv(qlhs,indx),'varlst!*)) then
      foreach z in zstrt(col) do
         remprev(xind z,ord)
end;

symbolic procedure remprev(x,y);
% ---
% See setprev.
% ---
   if numberp(farvar x) then
      remprev(farvar x,y)
   else
      setordr(x,remordr(y,ordr x));

symbolic procedure checknord(nord,inrow,indx);
begin
   if inrow then
   << if null(zstrt inrow) and null(chrow inrow) then
      << nord:=expcof inrow;
         remquotordr(indx,inrow);
         remquotordr(indx,farvar inrow);
         clearrow(inrow)
      >>
      else insquotordr(indx,get(nord,'rowindex))
      % In inrow obviously something usefull is defined, so
      % this cse should be defined for its use.
      % This means update ordr-fields.  JB. 7-5-93.

      %else
      % if (zz:=zstrt(inrow)) and null(cdr zz) and
      %    null(chrow inrow) and
      %    !:onep(expcof inrow) and !:onep(ival car zz) then ...
      %  handled by IMPROVELAYOUT
   >>;
   return nord
end;

symbolic procedure remquotient(pnr,indx);
% pnr is a variable (row)
begin scalar var,col,rowindx;
   var:=getv(qlhs,indx);
   if (col:=get(var,'varlst!+)) then
      foreach z in zstrt col do
         remprev(xind z,var);
   if (col:=get(var,'varlst!*)) then
      foreach z in zstrt col do
         remprev(xind z,var);
   tshrinkcol(getv(qlhs,indx),pnr,'varlst!+);
   tshrinkcol(getv(qlhs,indx),pnr,'varlst!*);
   for i:=1:(qlkvl) do
      putv(qrhs,i,subst(pnr,getv(qlhs,indx),getv(qrhs,i)));
   if (rowindx:=get(pnr,'rowindex)) then
      pnr:=rowindx;
   if (col:=get(pnr,'varlst!+)) then
      foreach z in zstrt col do
         setprev(xind z,pnr);
   if (col:=get(pnr,'varlst!*)) then
      foreach z in zstrt col do
         setprev(xind z,pnr)
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.tst0000644000175000017500000001407211526203062023466 0ustar  giovannigiovanni% Test SCOPE Package.
% ==================
% NOTE:  The SCOPE, GHORNER, GSTRUCTR and GENTRAN packages must be loaded
% to run these tests.

% Further reading: SCOPE 1.5 manual Section 3, example 1;

scope_switches$

% Further reading: SCOPE 1.5 manual Section 3.1, examples 2,3,4 and 5.

on priall$
optimize z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+2*b^2*m^6+b^2*m^2
	   iname s;
off priall$
on primat,acinfo$
optimize
     ghorner <>
     vorder m
     iname s;
off exp,primat,acinfo$ 
q:=a+b$
r:=q+a+b$
optimize x:=a+b,q:=:q^2,p(q)::=:r iname s;
on exp$
clear q,r$

% A similar example follows.
% operator a$% Not necessary. Some differences between REDUCE 3.5 and REDUCE 3.6
% when dealing with indices.

on inputc$
k:=j:=1$
u:=c*x+d$
v:=sin(u)$
optimize {a(k,j):=v*(v^2*cos(u)^2+u),
          a(k,j)::=:v*(v^2*cos(u)^2+u)} iname s;
off exp$
optimize {a(k,j):=v*(v^2*cos(u)^2+u),
          a(k,j)::=:v*(v^2*cos(u)^2+u)} iname s;
off inputc,period$
optlang fortran$
optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;
off ftch$
optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;
optlang c$
optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;

% Note: C code never contains exponentiations.

on ftch$
optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;
off ftch$
optlang fortran$
optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;
on ftch$
setlength 2$
optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;
resetlength$
optlang nil$

% Further reading: SCOPE 1.5 manual section 3.1, example 9 and section 3.2.

u:=a*x+2*b$
v:=sin(u)$
w:=cos(u)$
f:=v^2*w;
off exp$
optimize f:=:f,g:=:f^2+f iname s$
alst:=aresults;
restorables;
f;
arestore f;
f;
alst;
optimize f:=:f,g:=:f^2+f iname s$
alst:=aresults$
optimize f:=:f,g:=:f^2+f iname s$
restoreall$
f;

% Further reading: SCOPE 1.5 manual section 3.1, example 8. 
%                  See also section 5.
%                  Also recommended: section 9.

clear a$
matrix a(2,2)$
a(1,1):=x+y+z$
a(1,2):=x*y$
a(2,1):=(x+y)*x*y$
a(2,2):=(x+2*y+3)^3-x$
on exp$
off fort,nat$
optimize detexp:=:det(a) out "expfile" iname s$
off exp$
optimize detnexp:=:det(a) out "nexpfile" iname t$
in expfile$
in nexpfile$
on nat$
detexp-detnexp;
system "rm expfile nexpfile"$

% Further reading: SCOPE 1.5 manual section 4.2, example 15.
% Although the output is similar, it is in general equivalent and
% not identical when using REDUCE 3.6 in stead of REDUCE 3.5. This
% is due to improvements in the simplification strategy.

on acinfo$
optimize 
   gstructr<>
name v iname s;
alst:=
  algopt(algstructr({a,b=(x+y)^2,c=(x+y)*(y+z),d=(x+2*y)*(y+z)*(z+x)^2},v),s);
off acinfo$

% Further reading: SCOPE 1.5 manual section 4.3, example 16.

clear a$
procedure taylor(fx,x,x0,n);
 sub(x=x0,fx)+(for k:=1:n sum(sub(x=x0,df(fx,x,k))*(x-x0)^k/factorial(k)))$
hlst:={f1=taylor(e^x,x,0,4),f2=taylor(cos x,x,0,6)}$
on rounded$
hlst:=hlst;
optimize alghorner(hlst,{x}) iname g$
off rounded$

% Further reading: SCOPE 1.5 manual section 3.1, examples 6 and 7.

optimize z:=:for j:=2:6 sum a^(1/j) iname s$
optimize z1:=a+sqrt(sin(a^2+b^2)), z2:=b+sqrt(sin(a^2+b^2)), 
         z3:=a+b+(a^2+b^2)^(1/2),  z4:=sqroot(a^2+b^2)+(a^2+b^2)^3, 
         z5:=a^2+b^2+cos(a^2+b^2), z6:=(a^2+b^2)^(1/3)+(a^2+b^2)^(1/6)  
iname s;

% Further reading: SCOPE 1.5 manual section 6, examples 18 and 19.

optlang fortran$
optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;
optlang c$
optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;
optlang  pascal$
optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;
optlang ratfor$
optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;
precision 7$
on rounded, double$
optlang fortran$
optimize x1:=2         *a + 10        *b,
         x2:=2.00001   *a + 10        *b,
         x3:=2         *a + 10.00001  *b,
         x4:=6         *a + 10        *b,
         x5:=2.0000001 *a + 10.000001 *b
iname s
declare << x1,x2,x3,x4,x5,a,b:real>>$

% Further reading: SCOPE 1.5 manual section 7, example 20.
% Notice the double role of e: In the lhs as identifier. In the rhs as
% exponential function.
% Further notice that a is expected to be declared operator. This is
% due to lower level scope activities.

optimize a(1,x+1)  := g + h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c + h/(g + sin(d)),
         d         := k*e + d*(a(1,1+x) + 3),
         e         := d*(a(1,1+x) + 3) + sin(d),
         f         := d*(3 + a(1,1+x)) + sin(d),
         g         := d*(3 + a(1,1+x)) + f
iname s
declare << a(5,5),b(7),c,c1,d,e,f,g,h,r:real*8; x,y:integer>>$

% Further reading: SCOPE 1.5 manual section 8, examples 21 and 22.
%                  Also recommended: section 9.

optlang nil$
delaydecs$
 gentran declare <>$
 gentran a:=b+c$
 gentran d:=b+c$
 gentran <>$
makedecs$
on gentranopt$
delaydecs$
 gentran declare <>$
 gentran a:=b+c$
 gentran d:=b+c$
 gentran <>$
makedecs$
off gentranopt$
delayopts$
 gentran declare <>$
 gentran a:=b+c$
 gentran d:=b+c$
 gentran <>$
makeopts$
delaydecs$
 gentran declare <>$
 delayopts$
  gentran a:=b+c$
  gentran d:=b+c$
  gentran <>$
 makeopts$
makedecs$
clear a,b,c,d,q,w$
matrix a(2,2)$
a:=mat(((b+c)*(c+d),(b+c+2)*(c+d-3)),((c+b-3)*(d+b),(c+b)*(d+b+4)));
gentranlang!*:='c$
delayopts$
 gentran aa:=:a$
makeopts$
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codgen.red0000644000175000017500000002423611526203062023557 0ustar  giovannigiovannimodule codgen;

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, The Netherlands.;
% Author:     J.A. van Hulzen.                                        ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


lisp$
global '(!*for!* !*do!*)$ % Gentran-globals used in makedecs.
global '(!*currout!*)$ % Gentran global used in redefinition
                       % of symbolic procedure gentran.
fluid '(!*gentranseg)$ % Gentran fluid introduced.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Patch 8 november 94 HvH.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

put('c,'preproc,'preproc)$
put('ratfor,'preproc,'preproc)$
put('fortran,'preproc,'preproc)$
put('pascal,'preproc,'preproc)$
put('c,'parser,'gentranparse)$
put('ratfor,'parser,'gentranparse)$
put('fortran,'parser,'gentranparse)$
put('pascal,'parser,'gentranparse)$
put('c,'lispcode,'lispcode)$
put('ratfor,'lispcode,'lispcode)$
put('fortran,'lispcode,'lispcode)$
put('pascal,'lispcode,'lispcode)$

global '(!*wrappers!*)$
!*wrappers!*:='(optimization segmentation)$

symbolic procedure optimization forms;
 if !*gentranopt then opt forms else forms$

symbolic procedure segmentation forms;
 if !*gentranseg then seg forms else forms$

symbolic procedure gentran!-wrappers!* forms;
begin
  if !*wrappers!* then
   foreach proc_name in !*wrappers!* do
              forms:=apply1(proc_name,forms);
  return forms
end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%
%%%% Herbert's facility can now be added:
%%%%
%%%% !*wrappers!*:=append(list('differentiate),!*wrappers!*)$
%%%% symbolic procedure differentiate forms;
%%%%  << load!-package adiff; adiff!-eval forms>>$
%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure gentran(forms, flist);
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%      Redefinition of the main gentran procedure          %%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
begin scalar !:print!-prec!: ; % Gentran ignores print_precision
if flist then
    lispeval list('gentranoutpush, list('quote, flist));
forms:=
 apply1(get(gentranlang!*,'preproc) or get('fortran,'preproc),
       list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
forms:=
 apply1(get(gentranlang!*,'lispcode) or get('fortran,'lispcode),forms);
forms:=gentran!-wrappers!* forms;
apply1(get(gentranlang!*,'formatter) or get('fortran,'formatter),
       apply1(get(gentranlang!*,'codegen) or get('fortran,'codegen),
              forms));
if flist then
<<
    flist := car !*currout!* or ('list . cdr !*currout!*);
    lispeval '(gentranpop '(nil));
    return flist
>>
else
    return car !*currout!* or ('list . cdr !*currout!*)
end$

%=================================================================
%=== The codgen.red module itself!!!
%=================================================================

symbolic procedure interchange_defs(def1,def2);
begin scalar temp1,temp2;
temp1:=getd def1; remd def1;
temp2:=getd def2; remd def2;
putd(def1,car temp2,cdr temp2);
putd(def2,car temp1,cdr temp1);
end$

symbolic procedure strip_progn(lst);
if pairp lst
   then if pairp(car lst) and caar(lst)='progn
           then cdar(lst)
           else if pairp(car lst) and
                   caar(lst)='prog and
                   cadar(lst)='nil
                   then cddar(lst)
                   else lst;

symbolic procedure add_progn(lst);
if pairp lst then append(list('progn),lst) else lst;

switch gentranopt$
!*gentranopt:=nil$
fluid '(delaylist!* delayoptlist!* delaydecs!* !*gendecs !*period!*)$

symbolic procedure delaydecs;
% ------------------------------------------------------------------- ;
% Effect: Redefinition of codegeneration functions.                   ;
% ------------------------------------------------------------------- ;
begin
 !*period!*:=!*period; !*period:=nil;
 delaydecs!*:=t; delaylist!*:=nil;
 symtabrem('!*main!*,'!*decs!*);
 symtabrem('!*main!*,'!*params!*);
 symtabrem('!*main!*,'!*type!*);
 !*wrappers!*:=
              delete('optimization,delete('segmentation,!*wrappers!*));
 interchange_defs('gentran,'gentran_delaydecs);
end;

put('delaydecs,'stat,'endstat)$

symbolic procedure gentran_delaydecs(forms,flist);
% ------------------------------------------------------------------- ;
% This procedure replaces the gentran-evaluator when production of    ;
% delcarations has to be delayed. The results of all gentran eval.s   ;
% are collected in the list delaylist!* and processed together  by    ;
% activating thre function make decs.                                 ;
% ------------------------------------------------------------------- ;
begin
forms:= apply1(get(gentranlang!*,'preproc) or
                 get('fortran,'preproc),
               list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
forms:= apply1(get(gentranlang!*,'lispcode) or
                 get('fortran,'lispcode),
               forms);
forms:=gentran!-wrappers!* forms;
 if !*gentranopt then forms:=opt strip_progn forms;
 if !*gentranseg then forms:=seg forms;
 forms:=strip_progn forms;
 if delaylist!*
  then delaylist!*:=append(delaylist!*,forms)
  else delaylist!*:=forms
end;

symbolic procedure makedecs;
% ------------------------------------------------------------------- ;
% Effect: Original situation restored. Template processing performed. ;
% Symboltable cleaned up.                                             ;
% ------------------------------------------------------------------- ;
begin scalar gentranopt,gentranseg;
 if delayoptlist!*
  then gentranerr(nil,nil,"DELAYOPT ACTIVE",nil)
  else
   << !*period:=!*period!*;
      !*gendecs:=t; delaydecs!*:=nil;
      gentranopt:=!*gentranopt;!*gentranopt:=nil;
      gentranseg:=!*gentranseg;!*gentranseg:=nil;
      interchange_defs('gentran,'gentran_delaydecs);
        delaylist!* := subst('for,!*for!*, delaylist!*);  % JB 9/3/94
        delaylist!* := subst('do, !*do!*,  delaylist!*);  % JB 9/3/94
      apply('gentran,list(add_progn delaylist!*,nil));
      delaylist!*:=nil;
      !*wrappers!*:=
              append(!*wrappers!*,list('optimization,'segmentation));
      !*gentranopt:=gentranopt;!*gentranseg:=gentranseg;
   >>
end;

put('makedecs,'stat,'endstat)$

symbolic procedure delayopts;
% ------------------------------------------------------------------- ;
% This procedure allows to avoid optimization until further notice,   ;
% i.e. until the command makeopts is executed.                        ;
% All gentran evaluations are collected in the list delayoptlist!*.   ;
% Through makeopts this colection is processed in one run.            ;
% ------------------------------------------------------------------- ;
begin
 if not delaydecs!*
  then !*wrappers!*:=
              delete('optimization,delete('segmentation,!*wrappers!*));
 interchange_defs('gentran,'gentran_delayopt);
 delayoptlist!*:=nil
end;

put('delayopts,'stat,'endstat)$

symbolic procedure gentran_delayopt(forms,flist);
% ------------------------------------------------------------------- ;
% This procedure replaces the current gentran evaluator when produc-  ;
% tion of optimizwd code has to be delayed. We informally introduce a ;
% two-pass evaluation mechanism by doing so: one for gentran treatable;
% prefix statements and a second for optimization of this set of sta- ;
% tements.                                                            ;
% ------------------------------------------------------------------- ;
begin
forms:= apply1(get(gentranlang!*,'preproc) or
               get('fortran,'preproc),
               list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
 if delayoptlist!*
  then delayoptlist!*:=
       append(delayoptlist!*,
              strip_progn(gentran!-wrappers!* lispcode forms))
  else delayoptlist!*:=strip_progn(gentran!-wrappers!* lispcode forms);
end;

symbolic procedure makeopts;
% ------------------------------------------------------------------- ;
% The previous gentran environment is restored and the list of state- ;
% ments delayoptlist!* is treated in this environment.                ;
% ------------------------------------------------------------------- ;
begin scalar gendecs,gentranopt;
 interchange_defs('gentran,'gentran_delayopt);
 gentranopt:=!*gentranopt;!*gentranopt:=t;
 gendecs:=!*gendecs; !*gendecs:=nil;
 if delaydecs!*
  then
   if delaylist!*
    then delaylist!*:=
          append(delaylist!*,strip_progn opt delayoptlist!*)
    else delaylist!*:=strip_progn opt delayoptlist!*
  else << !*wrappers!*:=
               append(!*wrappers!*,list('optimization,'segmentation));
          apply('gentran,list(add_progn delayoptlist!*,nil))
       >>;
 delayoptlist!*:=nil; !*gentranopt:=gentranopt ; !*gendecs:=gendecs;
end;

put('makeopts,'stat,'endstat)$

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.tex0000644000175000017500000055623311526203062023466 0ustar  giovannigiovanni\documentstyle[11pt,reduce,makeidx]{article}
\pagestyle{empty}
\makeindex
\title{{\bf SCOPE 1.5\\ A Source-Code Optimization PackagE\\ for\\ REDUCE 3.6\\
\vspace{0.5cm}
=====\\
\vspace{0.5cm} User's Manual}}
\date{}
\author {\large
 \vspace{1cm} \\
J.A. van Hulzen \\ University of Twente, Department of Computer Science\\
P.O. Box 217, 7500 AE Enschede, The Netherlands \\
Email: infhvh@cs.utwente.nl}
\newcommand{\ad}{\mbox{$\rightarrow$}\hspace{-.30cm}{$/$}\hspace{.30cm}}

\begin{document}

\maketitle
\vspace{3cm}
\begin{center}
{\bf Abstract}\\
\end{center}

The facilities, offered by SCOPE 1.5, a Source-Code Optimization PackagE 
for {\REDUCE} 3.6, are presented. We discuss the user aspects of the package.
The algorithmic backgrounds are shortly summarized.
Examples of straightforward and more advanced usage are shown,  
both in algebraic and symbolic mode.
Possibilities for a combined use of GENTRAN and SCOPE are presented as well.

\vspace{1.5cm}
\copyright {\em \ \ } J.A. van Hulzen, University of Twente. All rights reserved.

\newpage
\tableofcontents
\newpage
\pagestyle{headings}
\section{Introduction}\label{SCOPE:intro}
\pagenumbering{arabic}

An important application of computer algebra systems is the generation
of code for numerical purposes via automatic or semi-automatic program
generation or synthesis. 
GENTRAN~\cite{Gates:84,Gates:85,Gates:86,Gates:91}, a flexible general-purpose
package, was especially developed to assist in such a task, when using
MACSYMA or {\REDUCE}.
\index{optimization}
Attendant to {\bf automatic program generation} is the problem 
of {\bf automatic source-code optimization}. 
This is a crucial aspect because code
generated from symbolic computations often tends to be made up of
lengthy arithmetic expressions. 
Such lengthy codes are grouped together in
blocks of straight-line code in a program for numerical purposes. The
main objective of SCOPE, our source-code optimization package, has been
minimization of the number of (elementary) arithmetic operations in such 
blocks. This can be accomplished by replacing repeatedly occuring
subexpressions, called common subexpressions or cse's for short,
\index{cse (common subexpression)}
by placeholders. We further assume that new statements of the form
"placeholder := cse" are inserted correctly in the code. This 
form of optimization is often helpful in reducing redundancy in (sets of) 
expressions. A recent application, code generation for an 
incompressible Navier-Stokes problem~\cite{Goldman:95}, showed reduction 
from 45.000 lines of FORTRAN code to 13.000 lines.

\index{optimizing compilers}
Optimizing compilers ought to deal effectively and efficiently with
the average, hand coded program. The enormous, arithmetic intensive
expressions, easily producable by a computer algebra system, fall
outside the range of the FORTRAN programs, once analyzed and discussed
by Knuth~\cite{Knuth:71}. He suggested that optimization of the arithmetic in
such a program is slightly overdone. The usual compiler optimization strategy
is based on easy detection of redundancy, without assuming the validity of
(some) algebric laws (see for instance ~\cite{Gonzales}) 
Our optimization strategy however, requires the validity of
some elementary algebraic laws. We employ heuristic techniques to
reduce the arithmetic complexity of the given representation of a set
${\rm E}_{in}$ of input statements, thus producing a set 
${\rm E}_{out}$ of output assignment statements.
${\rm E}_{in}$ and ${\rm E}_{out}$ define blocks of
code, which would compute the same exact values for the same exact
inputs, thus implicitly proving the correctness of the underlying
software.  Obviously the use of ${\rm E}_{out}$ ought to save a considerable
amount of execution time in comparison with the application of ${\rm
E}_{in}$.  Johnson et al~\cite{Johnson:79} suggest that such
transformations do not destabilize the computations.  However this is only
apparent after a careful error analysis of both ${\rm E}_{in}$ and ${\rm
E}_{out}$.  In view of the size of both ${\rm E}_{in}$ and ${\rm E}_{out}$
such an analysis has to be automatized as well.  Work in this direction is
in progress ~\cite{Hulshof,Molenkamp:91,Molenkamp:94}.
\index{error analysis}
\index{arithmetic complexity}

Although the use of SCOPE can considaribly reduce the arithmetic complexity
of a given piece of code,
we have to be aware of possible numerical side effects. In addition we have
to realize that a mapping is performed from one source language to another 
source language, seemingly without taking into account the platform the resulting 
numerical code has to be executed on. Seemingly, because we implemented some
facilities for regulating minimal expression length  and for producing
vector code.
\index{vector code}

This manual is organized as follows. We begin with some preliminary remarks
in section~\ref{SCOPE:prel}. The history and the present status, 
the optimization
strategy and the interplay between GENTRAN and SCOPE are shortly summarized.
The basic algebraic mode facilities are presented in
section~\ref{SCOPE:basic}. Special SCOPE features are discussed in 
section~\ref{SCOPE:soph}. Besides facilities for Horner-rules and an extended
version of the REDUCE function {\tt structr}, we introduce some tools for
extending  SCOPE with user defined specialties. File management follows in
section~\ref{SCOPE:files}. In section~\ref{SCOPE:decl} declaration handling
and related issues are discussed, before illustrating our strategy concerning
data dependencies and generation of vector code in section~\ref{SCOPE:dda}. 
In section~\ref{SCOPE:gopt} is shown how a combined used of GENTRAN and SCOPE 
can be profitable for pro\-gram-ge\-ne\-ra\-ti\-on. The use of SCOPE in 
symbolic mode is presented in section~\ref{SCOPE:symb}. A SCOPE syntax
summary is given in section~\ref{SCOPE:syntax}.
For completeness we present guidelines for installing the 
package in the last section.\\

{\bf Requests}
\begin{itemize}
\item Comment and complaints about possible bugs can be send to the author 
using the e-mail address infhvh@cs.utwente.nl. A compact piece with 
REDUCE code, illustrating the bug, is prefered. 
\item When SCOPE 1.5 is used in prepairing results, presented in some 
publication, reference to its use is highly appreciated. A copy of the 
published document as well.
\end{itemize}
\newpage

\section{Preliminaries}\label{SCOPE:prel}

For completeness we present a historical survey, a birds-eye view of the
overall optimization strategy and the interplay between GENTRAN and SCOPE.

\subsection{History and Present Status}\label{SCOPE:hito}

The first version of the package was designed to optimize the
description of {\REDUCE}-statements, generated by
NETFORM~\cite{Smit:81,Smit:82}. This
version was tailored to a restrictive class of problems, mainly occurring
in electrical network theory, thus implying that the right-hand
sides (rhs's) in the input were limited to elements of ${\rm {\bf Z_2}}$[V],
where V is a set of identifiers.  The second version~\cite{vanHulzen:83}
allowed rhs's from {\bf Z}[V]. For both versions the validity of the
commutative and the associative law was assumed.  A third version
evolved from the latter package by allowing to apply the distributive
law, i.e. by replacing (sub)expressions like $a.b  +  a.c$ by $a.(b 
+  c)$ whenever possible.  But the range of possible applications of
this version was really enlarged by redefining V as a set of kernels,
implying that almost any proper {\REDUCE}
expression could function as a rhs.  The mathematical capabilities of
this version are shortly summarized in~\cite{Wang:84}, in the context of code
generation and optimization for finite-element analysis. This version
was further extended~\cite{vanHulzen:89} with a declaration-module, 
in accordance with the strategy outlined in~\cite{Aho:86}, chapter 6. 
It is used \index{GENTRAN} 
in combination with GENTRAN, for 
the construction of Jacobians and Hessians~\cite{Heuvel:89,Berger:92} and 
also in experiments with strategies for code vectorization~\cite{Goldman:89}. 
In the meantime the Jacobian-Hessian production package, at present 
called GENJAC, is further extended with possibilities for global optimization
and with some form of loop-differentiation. So in stead of optimizing 
separate blocks of arithmetic we are now able to optimize complete programs,
albeit of a rather specific syntactical structure~\cite{Berger:92}.
The present 1.5 version of SCOPE, is an intermediate between the distributed first
version and the future, second version.  Version 2 is currently in 
development and will contain, besides the already existing common sub 
expression (cse) searches, facilities for structure and pattern recognition.
The 1.5 version permits -using the present REDUCE terminology- rounded
coefficients, based on the domain features, described in~\cite{Bradford:86},
discovery and adequate treatement of a variety of data dependencies, and
quotient-optimization, besides a collection of other improvements and 
refinements for using the facilities in the algebraic mode. 
Furthermore, an increased flexibility in the interplay between 
GENTRAN and SCOPE is accomplished.  It is used for experiments concerning 
automatic differentiation ~\cite{Goldman:91}, symbolic-numeric approaches to
stability analysis ~\cite{Ganzha:92,Ganzha:94} and for code generation for
numerically solving the Navier-Stokes equations for incompressible 
flows ~\cite{Goldman:95}. An interesting example of its use elsewhere can be found
in ~\cite{Dyer:94}.

\subsection{Acknowledgements}\label{SCOPE:ackn}

Many discussions with Victor V. Goldman, Jaap Smit and Paul S. Wang
have contributed to the present status of SCOPE. I express my
gratitude to the many students, who have also 
contributed to SCOPE, either by assisting in designing and implementing new 
facilities, or by applying the package in automated program generation projects
in and outside university, thus showing shortcomings and suggesting 
improvements and extensions.  I mention explicitly
Frits Berger, Johan de Boer, John Boers, Pim Borst, Barbara Gates, 
Marcel van Heerwaarden, Pim van den Heuvel, Ben Hulshof, Emiel Jongerius, 
Steffen Posthuma, Anco Smit, Bernard van Veelen and Jan Verheul.

\subsection{The Optimization Strategy in a Birds-eye View}\label{SCOPE:bird}

In~\cite{vanHulzen:81,vanHulzen:83} we described the overall
optimization strategy used for
\index{optimization strategy}
SCOPE as a composite function ${{\rm R}^{-1}} \circ {{\rm T}} 
\circ {{\rm R}}$.  The function R defines how to store the input
${{\rm E}}_{0}$ in an expression database ${{\rm D}}_{0}$.
The inverse function ${{\rm R}}^{{-1}}$ defines the output production.  
The function T defines the
optimization process itself. It essentially consists of a heuristic
remodeling of the (extendable and modifiable) expression database  
in combination with storing information required for a fast 
retrieval and correct insertion of the detected cse's in the output.  
This is accomplished by an iteratively
applied search, resulting in a stepwise reduction of the arithmetic
complexity of the input set, using an extended version of Breuer's
\index{Breuer's Algorithm}
grow factor algorithm~\cite{Breuer:69,vanHulzen:81,vanHulzen:83}.
It is applied until no further profit
is gained, i.e. until the reduction in arithmetic complexity stops.
Before producing output, a finishing touch can be performed to further
\index{finishing touch}
reduce the arithmetic complexity with some locally applied techniques.
Hence T is also a composite function.
The overall process can be summarized as follows: 
%\begin{eqnarray*}
\[ \begin{array}{rcrcl}
{\rm R} & : & {\rm E_{in}}~=~{\rm E_0} & \rightarrow & ({\rm D_0},{\rm profit_0}) \\
{\rm T_{\beta}} & : & ({\rm D_i},{\rm profit_i}) & \rightarrow & ({\rm D_{i+1}},
{\rm profit_{i+1}})~,~{\rm i}~=~0,...,~\lambda - 1.  \\
{\rm F} & : & ({\rm D_{\lambda}},{\rm profit_{\lambda}}) & \rightarrow & {D_{\lambda}}\\
{\rm R^{-1}} & : & {D_{\lambda}} & \rightarrow & {\rm E_{\lambda}}~=~{\rm E_{out}}
%\end{eqnarray*}
\end{array} \]
 ${\rm D_0}$ is created as a result of an R-application performed on 
input ${\rm E_0}$. The termination condition depends on some profit criterion
related to the arithmetic complexity of the latest version of the
input, ${{{\rm D}}_i}$. Hence we assume ${{{\rm profit}}_i} = true$
for $i =0,~\cdots , \lambda -1$ and ${{{\rm profit}}_\lambda} =
false$.  The function T is defined 
by ${\rm T} = {\rm F} \circ {\rm T_{\beta}^{\lambda}}$, where 
${{\rm T}}_{\beta}$ defines one iteration step, i.e. one application of the
extended version of Breuer's algorithm, and where F defines a
\index{extended Breuer algorithm}
finishing touch, resulting in the final version $D_{\lambda}$ of
${{\rm D}}_{0}$, used to produce the output ${{\rm E}}_{\lambda}$. 
It is stated in ~\cite{vanHulzen:83} that the computing time for
${\rm T_{\beta}^{\lambda}}$ is ${\rm O(n.m)}$, where n is the size 
of ${\rm E_{in}}$ and m the number of cse's found during this process.
Practical experience showed that the finishing touch can take about 
10 \% of the actual cpu-time and that its real profit is limited. 
Therefore its use is made optional. 

The wish to optimize source code, defining arithmetic, usually leads an attempt
to minimize the arithmetic complexity. This can be accomplished by replacing 
cse's by placeholders, assuming a new assignment 
statement "placeholder $:=$ cse" is correctly inserted in the code. 
So most of the cse-searches are done in right hand sides of 
arithmetic assignment statements.

The search strategy depends on the permissible structure of the arithmetic
expressions. We assume these expressions to be multivariate polynomials
or rational functions in a finite set of kernels, and  presented in some 
normal form. Let us further assume that scalar placeholders are substituted
for the non-scalar kernels, such that back-substitution remains possible,
using an adequate information storage mechanism. Then we are left with 
the interesting question how to define a minimal set of constituents of
multivariate polynomials in some normal form norm.  Let us take as an 
example of such a polynomial or rational function $p = 3a + 2b +  3 {b^2} c 
(3a + 2b){(c + d)^2}$.  We easily recognize linear forms, i.e. $3a + 2b$
(twice) and  $c + d$, possibly raised to some power (${(c + d)}^2$), power
products, such as ${b^2} c$, or monomial parts of products, i.e. $3 {b^2} c$.
Hence with some imagination, one realizes that every polynomial can be
decomposed in a set of linear forms and a set of power products. When 
assuming the validity of the commutative and the associative law, one can also
realize that we can associate a coefficient matrix with the linear forms and 
an exponent matrix with the power products. The rows can correspondent
with (sub)\-ex\-pressions and the columns with scalar identifiers.
The entries are either coefficients or exponents.
It is therefore conceivable to make a parser, mapping a set of REDUCE 
expressions in a database, consisting of two 
incidence matrices and a function table, such that the original expressions 
can be retrieved. Taking a group of assignmemnt statements or a list of 
equations, where in both cases the lhs's function as right hand side 
recognizers, does not confuse this idea. This rather informal indication
merely serves as a suggestion how ${\rm R}$ and its inverse operation are
designed.

So we suggest that we can consider any set of rhs's as being built with 
linear forms and power products only.  An additional remark is worth being 
made: Non-scalar kernels will in general have non-commutable arguments. 
These arguments  can in turn be arbitrary {\REDUCE}-expressions, which 
also have to be incorporated in the database.  Hence the function table 
is created recursively.

\index{cse (common subexpression)}
What is a cse and how do we locate its occurrences?  A (sub)expression
is common when it occurs repeatedly in the input. The occurrences are,
as part of the input, distributed over the matrices, and shown as
equivalent (sub)patterns.  In fact, we repeatedly search for
completely dense (sub)matrices of rank 1.  The expression $2a + 3c$
is a cse of ${e_1}  = 2a + 4b + 3c$ and ${e_2} = 4a + 6c + 5d$, 
representable by (2,4,3,0) and (4,0,6,5), respectively.  We
indeed have to assume commutativity, so as to be able to produce new
patterns (2,0,3,0,0), (0,4,0,0,1) and (0,0,0,5,2), representing $s = 2a + 3c$,
 ${e_1} = 4b + s$ and ${e_2} = 5d + 2s$,
respectivily, and thus saving one addition and one multiplication.
Such an additive cse can be a factor in a (sub)product,
which in turn can extend its monomial part, when replacing the cse 
by a new symbol. Therefore an essential part of an
optimization step is regrouping of information. This migration of
information between the matrices is performed if the Breuer-searches
are temporarily completed.  After this regrouping the distributive law
is applied, possibly also leading to a further regrouping. If at
least one of these actions leads to a rearrangement of information the
function ${\rm T} _{\beta}$ is again applied.  In view of the
iterative character of the optimization process we always accept
minimal profits.

A similar search is performed to detect multiplicative cse's, for
instance occuring in ${e_1} = {a^2} {b^4} {c^3}$ and ${e_2} =
{a^4} {c^6} {d^5}$.  However, given a power product $\prod_{i=1}^m
{x_i}^{{a}_i}$, any product $\prod_{i=1}^m {x_i}^{{b}_i}$, such that
some ${b_i} \leq  {a_i}$, for i = 1(1)m, can function as a cse.  We
therefore extend the search for multiplicative cse's by employing this
property, and as indicated in~\cite{vanHulzen:83}.

The finishing touch F is made to perform one-row and/or
one-column searches. Once the extended Breuer-searches do not lead to
further reduction in the arithmetic complexity we try -applying it- to
improve what is left.  The coefficients in (sub)sums can have,
possibly locally, a gcd, which can be factored out.  One-column
operations serve to discover and to replace properly constant multiples of
identifiers.  As part of the output-process we subject all
exponentiations left - at most one for each identifier - to an
addition chain algorithm.  

\subsection{The Interplay between GENTRAN and SCOPE 1.5}\label{SCOPE:inter}

The current version of SCOPE is written in RLISP. 
Like GENTRAN, it can be used as an extension of {\REDUCE}.
When SCOPE is loaded GENTRAN is also activated.

If we start a REDUCE session, we create an initial algebraic mode 
programming environment. All switches get their initial value, such as 
{\tt ON EXP,PERIOD} and {\tt OFF FORT}. 
Certain REDUCE commands serve to modify or to enrich the current environment.
Others are used to perform calculations, producing formulae. Such a
calculation follows a standard pattern, although parts of this repertoire 
can be influenced by the user, for instance by changing the value of 
certain switches. Usually execution is a three-step process.
First the infix text is parsed into a prefix form.  Then the internal algebra 
is applied on this form, leading to a so-called standard quotient.
This quotient is stored on the property list of the identifier 
functioning as assigned variable for this value. The last step
defines the inverse route from internal existence to external presentation 
in infix form. Occurrences of identifiers are recursively
replaced by their standard quotient representation when the internal algebra
is applied. Hence the REDUCE simplification strategy follows the imperative
programming paradigm.

When loading SCOPE, and thus GENTRAN, the environment is enriched with 
features for program generation and program optimization. 
Evaluation of GENTRAN and SCOPE commands differs from the standard REDUCE
approach to evaluation. Both packages employ their own storage mechanism.
The output is normally produced as a side-effect of the command evaluation.
The output is directed to some medium, a file or a screen. Command evaluation 
is similar in GENTRAN and in SCOPE.

The code generation process of GENTRAN can be viewed as the application
\index{GENTRAN ! code generation process}
of a composite function to an argument, which is almost equivalent with a 
piece of REDUCE code. Almost, because some GENTRAN specific facilities 
can be used. We can distinguish between the preprocessing phase, 
the translation phase and the postprocessing phase.
During preprocessing relevant parts of the input are evaluated prior to 
translation into prefix form. Such a locally performed evaluation can be 
accomplished through recognition of certain "evaluation markers", i.e. 
modifications of the traditional assignment symbol {\tt :=}, 
such as {\tt ::=}, {\tt :=:} and {\tt ::=:}. The {\tt :=} operator
"orders" GENTRAN to translate the statement literally. Addition of an extra 
colon to the left hand side orders subscript expression evaluation before
translation. An extra colon to the right hand side leads to right hand side 
evaluation, but without application of the storage mechanism of REDUCE. 
Hence evaluations
remain anonymous and are only incorporated in the translatable "text".
Another aspect of preprocessing is initialization of the symbol table, 
using information provided by a {\tt DECLARE} statement.
\index{GENTRAN ! {\tt DECLARE} statement}
GENTRAN also allows to further rewrite (sets of) arithmetic assignment
statements, using the switches {\tt GENTRANOPT} and {\tt GENTRANSEG}, 
\index{{\tt GENTRANOPT} switch}
\index{{\tt GENTRANSEG} switch} 
introduced for code optimization (using SCOPE) and segmentation, respectively. 
\index{GENTRAN ! code segmentation}
It possibly leads to storage of additional information in the symbol table.
During the translation phase the final internal form
of the code is produced, in combination with formatting specifications and
instructions to produce declarations.
Postprocessing finally does produce formatted code strings. So essentially,
each GENTRAN command has its own seperate translation process, implying that
the symbol table, required for the production of declarations, is fresh
at the beginning of a GENTRAN command evaluation.

As stated before, a SCOPE command evaluation is also a composite operation. 
The role of the assignment operators in both GENTRAN and SCOPE is similar.
In SCOPE, the locally performed evaluation provides
information to be entered in the database ${\rm D_0}$.
If the declaration feature is activated, the symbol table generation and 
maintenance mechanism is borrowed from GENTRAN. 
For output production, we can make a choice from 
GENTRAN's target language repertoire. When declarations are required, we simply 
obey the GENTRAN regime as well. ${D_{\lambda}}$ is used to update the symbol 
table. All cse-names, generated during the optimization process, are typed in 
accordance with the strategy for dynamic typing, which is discussed 
in~\cite{Aho:86}, chapter 6. We assume all relevant identifiers 
of ${\rm E_{in}}$ to be adequately typed, using SCOPE's {\tt DECLARE} facility,
an equivalent of GENTRAN's {\tt DECLARE} statement. The
\index{SCOPE ! {\tt DECLARE} facility}
\index{GENTRAN ! {\tt DECLARE} statement}
production of ${D_{\lambda}}$ is completely decoupled from the normal
REDUCE simplification strategy, because we employ our own expression database.

In principle, the status of REDUCE before and after a GENTRAN or SCOPE
command execution is unaltered. In principle, because some minor modifications,
although user controlable, may be necessary. The special assignment symbols 
 -also usable in SCOPE- were only introduced as a syntactical instrument to 
allow internal algebraic actions, decoupled from the standard REDUCE 
expression processing.

This short excursion into the different evaluation strategies is added to
assist in understanding the functioning of the different SCOPE commands and 
facilities, to be introduced in the next sections.
\newpage

\section{The Basic SCOPE 1.5 Facilities in the Algebraic Mode}\label{SCOPE:basic}

{\REDUCE} allows, roughly speaking, two modes of operation in algebraic
mode: {\tt ON EXP} or {\tt OFF EXP}.  
The first is the default setting, leading to
expanded forms.  The latter gives unexpanded forms, as discussed by Hearn
in some detail~\cite{Hearn:85,Hearn:86}.  It is obvious that the {\tt OFF
EXP} setting is in general preferable over the {\tt ON
EXP} setting when attempting to optimize the description of a set of
assignment statements.

\index{{\tt ACINFO} switch} 
\index{{\tt ROUNDED} switch}
\index{{\tt DOUBLE} switch}
\index{{\tt INPUTC} switch}
\index{{\tt PRIMAT} switch}
\index{{\tt PRIALL} switch}
\index{{\tt EXP} switch} 
\index{{\tt FORT} switch}
\index{{\tt FTCH} switch}
\index{{\tt AGAIN} switch}
\index{{\tt SIDREL} switch}
\index{{\tt VECTORC} switch}
\index{{\tt NAT} switch}
\index{{\tt PERIOD} switch} 
\index{{\tt GENTRANOPT} switch}
\index{{\tt PREFIX} switch}
\index{{\tt INTERN} switch}
\index{{\tt EVALLHSEQP} switch}
\index{{\tt ROUNDBF} switch} 

The result of an application of SCOPE can be influenced by the use of
certain {\REDUCE}- or SCOPE-switches. The influence of {\tt EXP} is obvious:
unexpanded input is more compact than expanded.
{\tt ON ACINFO} serves to produce tables with the numbers of arithmetic 
operations, oc\-cu\-ring in ${{{\rm E}}_0}$ and ${{\rm E}}_{\lambda}$, 
respectively.
{\tt ON INPUTC} serves to echo the input, processed by SCOPE. The actual
form of the input can be the consequence of locally performed evaluations, 
before the actual parsing into the database takes place.
{\tt ON  PRIMAT} can be used to visualize 
both ${{\rm D}}_{0}$ and $D_{\lambda}$.  
{\tt ON  PRIALL} finally, can be used instead of
{\tt ON ACINFO,INPUTC,PRIMAT}. These SCOPE-switches are initially all turned
{\tt OFF}. SCOPE has a facility to visualize the status of all
SCOPE-switches and some relevant {\REDUCE}-switches. The current status
of all relevant switches can be presented with the command

\hspace*{1cm} {\tt SCOPE\_SWITCHES}\verb+$+
\index{SCOPE function ! {\tt SCOPE\_SWITCHES}}


\example\label{ex:3.1.1}
\index{SCOPE ! example}

The start of a {\REDUCE} session shows the initial state
of {\REDUCE}, directly after loading the SCOPE package. 
The set of relevant switches is made visible. 
Besides the {\REDUCE} switches {\tt EVALLHSEQP}, {\tt EXP}, {\tt FORT}, 
{\tt NAT}, {\tt PERIOD}, {\t ROUNDBF}
and {\tt ROUNDED} six additional SCOPE switches, i.e. {\tt AGAIN}, {\tt FTCH}, 
{\tt INTERN}, {\tt PREFIX}, {\tt SIDREL} and {\tt VECTORC}, and the GENTRAN
switches {\tt DOUBLE} and {\tt GENTRANOPT} are thus presented. 
They all wil be discussed in more 
detail below.

{\small
\begin{verbatim}
REDUCE 3.6, 15-Jul-95 ...

1: load_package nscope$

2: SCOPE_SWITCHES$

 ON  :  exp  ftch  nat  period  
 OFF :  acinfo  again  double  evallhseqp  fort  gentranopt  inputc  
        intern  prefix  priall  primat  roundbf  rounded  sidrel  
        vectorc  

3: % etc. ...
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

Output is by default given in {\REDUCE} syntax, but FORTRAN syntax is
possible in the usual way, e.g. {\tt ON FORT} and {\tt OFF PERIOD}, for 
instance.  The use of other target languages
from the GENTRAN repertoire is discussed in section~\ref{SCOPE:decl}.

\subsection{The {\tt OPTIMIZE} command: Straightforward use}\label{SCOPE:optim}

\index{{\tt OPTIMIZE} command}
\index{{\tt INAME} option}
\index{REDUCE function ! {\tt gensym}}
\index{SCOPE function ! {\tt SETLENGTH}}
A SCOPE application is easily performed and based on the use of 
the following syntax:

\begin{center}
\begin{tabular}{lcl}
 $<$SCOPE\_application$>$ & $::=$ & {\tt OPTIMIZE} $<$object\_seq$>$
 [{\tt INAME} $<$cse\_prefix$>$]\\
 $<$object\_seq$>$ & $::=$ & $<$object$>$[,$<$object\_seq$>$]\\
 $<$object$>$ & $::=$ & $<$stat$>~\mid~<$alglist$>~\mid~<$alglist\_production$>$ \\
 $<$stat$>$ & $::=$ & $<$name$>~<$assignment operator$>~<$expression$>$\\
 $<$assignment operator$>$ & $::=$ & $:=~\mid~::=~\mid~::=:~\mid~:=:$\\
 $<$alglist$>$ & $::=$ & \{$<$eq\_seq$>$\}\\
 $<$eq\_seq$>$ & $::=$ & $<$name$>~=~<$expression$>$[,$<$eq\_seq$>$]\\
 $<$alglist\_production$>$ & $::=$ & $<$name$>~\mid~<$function\_application$>$\\
 $<$name$>$ & $::=$ & $<$id$>~\mid~<$id$>(<$a\_subscript\_seq$>)$\\
 $<$a\_subscript\_seq$>$ & $::=$ & $<$a\_subscript$>$[,$<$a\_subscript\_seq$>$]\\
 $<$a\_subscript$>$ & $::=$ & $<$integer$>~\mid~<$integer infix\_expression$>$\\
 $<$cse\_prefix$>$ & $::=$ & $<$id$>$
\end{tabular}
\end{center}

A SCOPE action can be applied on one assignment statement. 
The assigned variable
is either a scalar identifier, like {\tt z} in example~\ref{ex:3.1.2}, or a 
name with subscripts, such as {\tt a(1,1)} in example~\ref{ex:3.1.3}. 
In stead of one
statement a sequence of such statements, separated by comma's, is possible.
An alternative is provided by the use of an algebraic mode list, consisting
of {\REDUCE} equations. An assigned variable, identifying such a list, is 
allowed as well. Examples are presented in section~\ref{SCOPE:algo}.
The function\_application is introduced in section~\ref{SCOPE:soph}. Such an 
application ought to produce an alglist.

The expressions, i.e. rhs's in assignments or equations are legal {\REDUCE}
expressions or ought to evaluate to such expressions. Statements inside 
expressions are allowed, but only useful if these expressions are evaluated,
before being optimized. Only integer or rounded coefficients are supported
by SCOPE. So we either suppose the default integer setting or allow the switch
{\tt ROUNDED} to be turned {\tt ON}.

The optional use of the {\tt INAME} extension in an {\tt OPTIMIZE} command
is introduced to allow the user to influence the generation of cse-names.
The cse\_prefix is an identifier, used to generate cse-names, by
extending it with an integer part. If the cse\_prefix consists of letters
only, the initially selected integer part is 0. All following integer parts are
obtained by incrementing the previous integer part by 1. If the user-supplied
cse\_prefix ends with an integer its value functions as initial integer part.
The {\tt gensym}-function is applied when the {\tt INAME}-extension is omitted.
The three alternatives are illustrated in example~\ref{ex:3.1.2}.

As stated before minimal profits are accepted during all stages of the
optimization process: many small steps may lead to impressive final results.
But it can also lead to unwanted details. Therefore, it can be desirable
to rerun an optimization request with a restriction on the minimal size of 
the rhs's. The command 

\hspace*{1cm} {\tt SETLENGTH} $<$integer$>$\$  

can be used to produce rhs's with a minimal arithmetic complexity, 
dictated by the value of 
its integer argument. Statements, used to rename function applications, are 
not affected by the {\tt SETLENGTH} command. The default setting is restored 
with the command 

\hspace*{1cm} {\tt RESETLENGTH}\$
\index{SCOPE function ! {\tt RESETLENGTH}}

We now illustrate the use of the {\tt OPTIMIZE} command through a number of
small examples, being parts of {\REDUCE} sessions. We show in
example~\ref{ex:3.1.2} the effect of the different visualization switches,
the use of {\tt SETLENGTH} and {\tt RESETLENGTH} and of the three {\tt INAME}
alternatives. In example~\ref{ex:3.1.3} the effect of some of the GENTRAN and 
SCOPE input processing features is presented. Some finishing touch activities 
are illustrated in the examples  ~\ref{ex:3.1.4} and ~\ref{ex:3.1.5}. 
The approach towards rational exponents is presented in 
example~\ref{ex:3.1.6}, while some form of quotient optimization is 
illustrated in example~\ref{ex:3.1.7}. Finally, we present the differences 
in {\tt ON/OFF EXP} processing in example~\ref{ex:3.1.8}.

\example\label{ex:3.1.2}
\index{SCOPE ! example}

The multivariate polynomial {\tt z} is a sum of 6 terms. These
terms, monomials, are constant multiples of power products.  A
picture of ${{\rm D}}_{0}$ is shown after the input echo. The
sums-matrix consists of only one row, identifiable by its Fa(the)r {\tt z},
the lhs. Its exponent is given in the EC (Exponent or Coefficient)
field. The 6 monomials are stored in the products-matrix. The
coefficients are stored in the EC-fields and the predecessor row
index, 0, is given in the Far-field. Before the $D_{\lambda}$ picture
is given the effect of the optimization process, the output and the
operator counts are shown. The optimized form of {\tt z} is obtained by
applying the distributive law. The output also shows applications of
an addition chain algorithm (\cite{Knuth:80} 441-466) as part of ${{\rm
R}}^{{-1}}$, although its use in example~\ref{ex:3.1.4} is more apparent.
\index{addition chain algorithm}

Observe that the output illustrates the heuristic character of the
optimization process: In this particular case the rhs can be written
as a polynomial in {\tt g4}, thus saving one extra multiplication.

The {\tt SETLENGTH} command is illustrated too. See also example~\ref{ex:3.2.6}.
Application of a Horner-rule may be profitable as well. See, for instance
example~\ref{ex:4.1.3}.
\index{{\tt PRIALL} switch}
{\small
\begin{verbatim}
ON PRIALL$

z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+2*b^2*m^6+b^2*m^2;

      2  2       2  6    2  2          4      2  6    2  2
z := a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m

OPTIMIZE z:=:z$

      2  2       2  6    2  2          4      2  6    2  2
z := a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m

Sumscheme :

   || EC|Far
------------
  0||  1| z
------------
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
Productscheme :

   |  0  1  2| EC|Far
---------------------
  1|     2  2|  1| 0
  2|  6     2| 10| 0
  3|  2     2|  1| 0
  4|  4  1  1|  2| 0
  5|  6  2   |  2| 0
  6|  2  2   |  1| 0
---------------------
0  : m
1  : b
2  : a

Number of operations in the input is: 

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 10
Number of integer ^ operations  : 11
Number of / operations          : 0
Number of function applications : 0

g1 := b*a
g5 := m*m
g2 := g5*b*b
g3 := g5*a*a
g4 := g5*g5
z := g2 + g3 + g1*(2*g4 + g1) + g4*(2*g2 + 10*g3)

Number of operations after optimization is:

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 12
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 0

Sumscheme :

   |  0  3  4  5| EC|Far
------------------------
  0|        1  1|  1| z
 15|        2 10|  1| 14
 17|  2  1      |  1| 16
------------------------
0  : g4
3  : g1
4  : g2
5  : g3
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
Productscheme :

   |  8  9 10 11 17 18 19 20| EC|Far
------------------------------------
  7|                    1  1|  1| g1
  8|  1                 2   |  1| g2
  9|  1                    2|  1| g3
 10|  2                     |  1| g4
 11|                 2      |  1| g5
 14|     1                  |  1| 0
 16|              1         |  1| 0
------------------------------------
8  : g5
9  : g4
10 : g3
11 : g2
17 : g1
18 : m
19 : b
20 : a

OFF PRIALL$
SETLENGTH 2$

OPTIMIZE z:=:z INAME s$

       2  2
s1 := b *m
       2  2
s2 := a *m
               4                       4
z := (a*b + 2*m )*a*b + 2*(s1 + 5*s2)*m  + s1 + s2

RESETLENGTH$

OPTIMIZE z:=:z INAME s1$

s1 := b*a
s5 := m*m
s2 := s5*b*b
s3 := s5*a*a
s4 := s5*s5
z := s2 + s3 + s1*(2*s4 + s1) + s4*(2*s2 + 10*s3)
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\index{SCOPE function ! {\tt SETLENGTH}}
\index{SCOPE function ! {\tt RESETLENGTH}}
\example\label{ex:3.1.3} 
\index{SCOPE ! example}

The input echo below shows the literal copy of the first assignment.
This is in accordance with role the GENTRAN assignment operator {\tt :=}
ought to play.  The second assignment, this time using the operator {\tt ::=:},
leads to rhs evaluation (expansion) and lhs subscript-value substitution.
Application of the distributive law is refected by the rhs of {\tt a(1,1)} 
in the presented result.
\index{{\tt INPUTC} switch}
{\small
\begin{verbatim}
OPERATOR a$ k:=j:=1$ u:=c*x+d$ v:=sin(u)$
ON INPUTC$

OPTIMIZE a(k,j):=v*(v^2*cos(u)^2+u), a(k,j)::=:v*(v^2*cos(u)^2+u) INAME s;

              2       2
a(k,j) := v*(v *cos(u)  + u)

                      2             3
a(1,1) := cos(c*x + d) *sin(c*x + d)  + sin(c*x + d)*c*x + sin(c*x + d)*d

s9 := cos(u)*v
a(k,j) := v*(u + s9*s9)
s6 := x*c + d
s5 := sin(s6)
s10 := s5*cos(s6)
a(1,1) := s5*(s6 + s10*s10)
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\example\label{ex:3.1.4}
\index{SCOPE ! example}

The effect is shown of a finishing touch application, in combination
with FORTRAN output. The value of {\tt S0} is rewritten during output 
preparation, and the earlier mentioned addition chain algorithm is applied.
When turning {\tt OFF} the switch {\tt FTCH} the latter activity is skipped.
\index{{\tt FTCH} switch}
\index{{\tt FORT} switch}
\index{{\tt PERIOD} switch}
{\small
\begin{verbatim}
ON FORT$ OFF PERIOD$

OPTIMIZE z:=(6*a+18*b+9*c+3*d+6*f+18*g+6*h+5*j+5*k+3)^13 INAME s;

      S0=5*(J+K)+3*(3*C+D+1+6*(B+G)+2*(A+F+H))
      S3=S0*S0*S0
      S2=S3*S3
      Z=S0*S2*S2

OFF FTCH$

OPTIMIZE z:=(6*a+18*b+9*c+3*d+6*f+18*g+6*h+5*j+5*k+3)^13 INAME s;

      Z=(5*(J+K)+3*(3*C+D+1+6*(B+G)+2*(A+F+H)))**13
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\example\label{ex:3.1.5}
\index{SCOPE ! example}

Recovery of repeatedly occurring integer multiples of identifiers,
as part of the finishing touch, is illustrated. This facility is
part of the finishing touch and will seemingly be neglected when
using {\tt SETLENGTH} 2\verb+$+ instruction in stead of {\tt OFF FTCH}.
\index{{\tt FTCH} switch}
{\small
\begin{verbatim}
OPTIMIZE x:=3*a*p, y:=3*a*q, z:=6*a*r+2*b*p,
         u:=6*a*d+2*b*q, v:=9*a*c+4*b*d, w:=4*b INAME s;

s2 := 3*a
x := s2*p
y := s2*q
s0 := 2*b
s3 := 6*a
z := s0*p + s3*r
u := s0*q + s3*d
w := 4*b
v := w*d + 9*c*a

OFF FTCH$

OPTIMIZE x:=3*a*p, y:=3*a*q, z:=6*a*r+2*b*p,
         u:=6*a*d+2*b*q, v:=9*a*c+4*b*d, w:=4*b INAME t;

x := 3*p*a
y := 3*q*a
z := 2*b*p + 6*r*a
u := 2*b*q + 6*d*a
v := 4*d*b + 9*c*a
w := 4*b

ON FTCH$
SETLENGTH 2$

OPTIMIZE x:=3*a*p, y:=3*a*q, z:=6*a*r+2*b*p,
         u:=6*a*d+2*b*q, v:=9*a*c+4*b*d, w:=4*b INAME t;

x := 3*p*a
y := 3*q*a
z := 2*b*p + 6*r*a
u := 2*b*q + 6*d*a
v := 4*d*b + 9*c*a
w := 4*b
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\index{{\tt FTCH} switch}
\index{SCOPE function ! {\tt SETLENGTH}}
\example\label{ex:3.1.6}
\index{SCOPE ! example}

This example serves to show how SCOPE deals with rational 
exponents.  All rational exponents of an identifier are collected. 
\index{rational exponents}
The least common
multiple lcm of the denominators of these rationals is
computed and the variable is replaced by a possibly newly selected
variable name, denoting the variable raised to the power 1/lcm. This
facility is only efficient for what we believe to be problems
occurring in computational practice. That is easily verified by
extending the sum we are elaborating here with some extra terms.
\newpage
{\small
\begin{verbatim}
ON INPUTC,FORT$

OPTIMIZE z:=:FOR j:=2:6 SUM q^(1/j) INAME s;

      1/6    1/5    1/4    1/3
z := q    + q    + q    + q    + sqrt(q)

      S0=Q**(1.0/60.0)
      S8=S0*S0
      S7=S8*S0
      S5=S8*S7
      S3=S5*S5
      S2=S8*S3
      S1=S7*S2
      S4=S5*s1
      Z=S4+S1+S2+S3+S4*S3
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\example\label{ex:3.1.7}
\index{SCOPE ! example}

\index{{\tt INPUTC} switch}
\index{{\tt ROUNDED} switch}
\index{{\tt FORT} switch}
The special attention, given to rational exponents, is not extended to 
rational coefficients. The script in this example shows four different 
approaches for dealing with such coefficients using the expressions assigned to
{\tt f} and {\tt g}. We start with a literal parsing of the two assignments,
leading to a form of ${\rm D}_0$, which is  based on the present REDUCE 
strategy for dealing with fixed float numbers in the default integer 
coefficient domain setting.
The four rational numbers $\frac{31}{5} ,~ \frac{31}{10} ,~\frac{93}{5}~
{\rm and}~\frac{93}{10}$ are just like ${\rm b}^{\frac{1}{5}}$, $\sqrt {\rm 
sin(\cdots)}$ and ${\rm sin(\cdots)}^{\frac{5}{3}}$ considered as kernels.

The second approach illustrates the effect of simplification in 
an {\tt OFF ROUNDED} mode prior to parsing. The input expressions are 
remodeled into rational expressions, the usual internal standard quotient form.

After turning {\tt ON} the switch  {\tt ROUNDED}  we repeat the previous 
commands. Again some differences in evaluation can be observed. Literally
taken input, the third approach,  shows rational exponent optimizations
prior to the production of rounded exponents in the output.
The last approach, simplification before parsing, leads to a float 
representation for the rational exponents. SCOPE's exponent optimization
features are designed for integer and rational exponents only. Floating
point exponentiation is therefore assumed to be a function application.

Further illustrations of operations on quotients are shown in
example~\ref{ex:8.2}.
{\small
\begin{verbatim}
ON INPUTC$

OPTIMIZE
f:= cos(6.2*a+18.6*(b)^(1/5))/sqrt(sin(3.1*a+9.3*(b)^(1/5))),
g:= sin(6.2*a+18.6*(b)^(1/5))/sin(3.1*a+9.3*(b)^(1/5))^(5/3)
INAME s$

\end{verbatim}}
\newpage
{\small
\begin{verbatim}
              31       93   1/5
         cos(----*a + ----*b   )
              5        5
f := -------------------------------
                31       93   1/5
      sqrt(sin(----*a + ----*b   ))
                10       10

            31       93   1/5
       sin(----*a + ----*b   )
            5        5
g := ----------------------------
           31       93   1/5 5/3
      sin(----*a + ----*b   )
           10       10


        1/5
s15 := b
            93       31
s12 := s15*---- + a*----
            5        5
           93         31
s6 := sin(----*s15 + ----*a)
           10         10
         1/6
s14 := s6
s5 := s14*s14*s14
      cos(s12)
f := ----------
         s5
      sin(s12)
g := -----------
      s5*s14*s6


OPTIMIZE
f:=: cos(6.2*a+18.6*(b)^(1/5))/sqrt(sin(3.1*a+9.3*(b)^(1/5))),
g:=: sin(6.2*a+18.6*(b)^(1/5))/sin(3.1*a+9.3*(b)^(1/5))^(5/3)
INAME t$


                  1/5
              93*b    + 31*a
         cos(----------------)
                    5
f := -----------------------------
                    1/5
                93*b    + 31*a
      sqrt(sin(----------------))
                      10
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
                           1/5
                       93*b    + 31*a
                  sin(----------------)
                             5
g := ------------------------------------------------
               1/5                      1/5
           93*b    + 31*a  2/3      93*b    + 31*a
      sin(----------------)   *sin(----------------)
                 10                       10


          1/5
t7 := 93*b    + 31*a
       t7
t2 := ----
       5
           t7
t5 := sin(----)
           10
         1/6
t11 := t5
t4 := t11*t11*t11
      cos(t2)
f := ---------
        t4
       sin(t2)
g := -----------
      t4*t11*t5


ON ROUNDED$

OPTIMIZE
f:= cos(6.2*a+18.6*(b)^(1/5))/sqrt(sin(3.1*a+9.3*(b)^(1/5))),
g:= sin(6.2*a+18.6*(b)^(1/5))/sin(3.1*a+9.3*(b)^(1/5))^(5/3)
INAME s$


                          1/5
        cos(6.2*a + 18.6*b   )
f := -----------------------------
                            1/5
      sqrt(sin(3.1*a + 9.3*b   ))

                         1/5
       sin(6.2*a + 18.6*b   )
g := --------------------------
                       1/5 5/3
      sin(3.1*a + 9.3*b   )
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
           0.2
s5 := 9.3*b    + 3.1*a
s8 := 2*s5
s4 := sin(s5)
         0.166666666667
s10 := s4
s3 := s10*s10*s10
      cos(s8)
f := ---------
        s3
       sin(s8)
g := -----------
      s3*s10*s4


OPTIMIZE
f:=: cos(6.2*a+18.6*(b)^(1/5))/sqrt(sin(3.1*a+9.3*(b)^(1/5))),
g:=: sin(6.2*a+18.6*(b)^(1/5))/sin(3.1*a+9.3*(b)^(1/5))^(5/3)
INAME t$


                 0.2
       cos(18.6*b    + 6.2*a)
f := --------------------------
               0.2         0.5
      sin(9.3*b    + 3.1*a)

                      0.2
            sin(18.6*b    + 6.2*a)
g := ------------------------------------
               0.2         1.66666666667
      sin(9.3*b    + 3.1*a)


           0.2
t6 := 9.3*b    + 3.1*a
t9 := 2*t6
t5 := sin(t6)
      cos(t9)
f := ---------
         0.5
       t5
          sin(t9)
g := -----------------
        1.66666666667
      t5
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\newpage
\example\label{ex:3.1.8}
\index{SCOPE ! example}
\index{{\tt ACINFO} switch}
\index{{\tt FORT} switch}
\index{{\tt PERIOD} switch}
\index{{\tt EXP} switch}

The effect of {\tt ON EXP} or {\tt OFF EXP} on the result of a
SCOPE-application is illustrated by optimi\-zing the representation of the
determinant of a symmetric (3,3) matrix {\tt m}.  Besides differences in
computing time we also observe that the arithmetic complexity of the
optimized version of the expanded representation of the determinant is
about the same as the not optimized form of the unexpanded representation.

{\small
\begin{verbatim}
MATRIX m(3,3)$

m(1,1):=18*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z-
        9*sin(q3)^2*m30*p^2+j1oy+j30y+m10*p^2+18*m30*p^2$

m(2,1):=
m(1,2):=9*cos(q3)*cos(q2)*m30*p^2-sin(q3)^2*j30y+sin(q3)^2*j30z-
        9*sin(q3)^2*m30*p^2+j30y+9*m30*p^2$

m(3,1):=
m(1,3):=-9*sin(q3)*sin(q2)*m30*p^2$

m(2,2):=-sin(q3)^2*j30y+sin(q3)^2*j30z-9*sin(q3)^2*m30*p^2+j30y+
        9*m30*p^2$

m(3,2):=
m(2,3):=0$

m(3,3):=9*m30*p^2+j30x$

ON ACINFO,FORT$ OFF PERIOD$

OPTIMIZE detm:=:det(m) INAME s;

Number of operations in the input is: 

Number of (+/-) operations      : 36
Number of unary - operations    : 0
Number of * operations          : 148
Number of integer ^ operations  : 84
Number of / operations          : 0
Number of function applications : 32

      S2=SIN(REAL(Q2))
      S30=S2*S2
      S3=SIN(REAL(Q3))
      S29=S3*S3
      S31=P*P
      S8=S31*M30
      S32=S8*S8
      S4=S32*J30Y
      S28=S32*S8
      S9=S29*M10
      S10=S30*S29*S29
      S44=COS(REAL(Q3))*COS(REAL(Q2))
      S11=S44*S44
      S20=S31*S8
      S23=S31*J30X
      S22=S29*J30X
      S24=S8*J1OY
      S19=M10*J30Y
      S43=81*S32*J30X
      S35=-S43-(81*S32*J1OY)
      S36=-(729*S29*S28)-(81*S29*S4)
      S37=J30Z-J30Y
      S39=9*S37
      S40=9*J30X
      S41=81*S32*J30Z
      S42=81*S4
      DETM=S42+S36-S35+729*S28+S37*(S22*J1OY+9*S29*S24+S23*S9)+S10*(S42-
     . S41)+S20*S8*81*(M10-S9)+S20*S9*(S39-S40)+S22*S8*(S39-(9*J1OY))+
     . S20*(9*S19+S40*M10)+S24*(S40+9*J30Y)+J30Y*J30X*(J1OY+9*S8)+S28*
     . 729*(S10-S11)+S29*(S41+S35)+S36*S30+S23*S19-(S43*S11)

Number of operations after optimization is:

Number of (+/-) operations      : 30
Number of unary - operations    : 0
Number of * operations          : 59
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 4

OFF EXP$

OPTIMIZE detm:=:det(m) INAME t;

Number of operations in the input is: 

Number of (+/-) operations      : 23
Number of unary - operations    : 1
Number of * operations          : 38
Number of integer ^ operations  : 21
Number of / operations          : 0
Number of function applications : 10

      T1=SIN(REAL(Q3))
      T9=T1*T1
      T8=P*P
      T5=T8*M30
      T16=9*T5
      T10=-T16-(9*T5*COS(REAL(Q3))*COS(REAL(Q2)))
      T13=(T16+J30Y-J30Z)*T9
      T15=T13-J30Y
      T0=T15+T10
      T14=T13-T16-J30Y
      T17=T5*SIN(REAL(Q2))
      DETM=81*T17*T17*T14*T9-((T16+J30X)*(T0*T0-(T14*(T15+2*T10-J1OY-(T8
     . *M10)))))

Number of operations after optimization is:

Number of (+/-) operations      : 13
Number of unary - operations    : 0
Number of * operations          : 18
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 4
\end{verbatim}}

We can also use this example to show that correctness of results is
easily verified. When storing
the result of a SCOPE application in a file, it is of course possible
to read the result in again. Then we apply a normal {\REDUCE} evaluation
strategy. This implies that all references to cse-names are automatically
replaced by their values.  We show the ``correctness'' of SCOPE by
storing the optimized version of the expanded form of the determinant
of {\tt M}, called {\tt detm1} in file {\tt out.1} and the result of a 
SCOPE-application on the unexpanded form, {\tt detm2}, in file {\tt out.2}, 
followed by reading in both files and by subtracting {\tt detm2} 
from {\tt detm1}, resulting in the value 0.
This is of course an ad hoc correctness-proof for one specific
example. It is in fact another way of testing the code of the package.
We show it as a direct continuation of the previous determinant calculations.

\index{{\tt NAT} switch}
This example also serves to show that the {\tt OPTIMIZE} command can be 
extended with the {\tt OUT} option. The keyword {\tt OUT} has to be followed
\index{{\tt OUT} option}
by a file-name. This file is properly closed and left in a readable form,
assuming printing is produced in a {\tt OFF NAT} fashion.
SCOPE's file management features are discussed in more detail in 
section~\ref{SCOPE:files}.
{\small
\begin{verbatim}
OFF ACINFO,FORT,NAT$ ON EXP$

OPTIMIZE detm1:=:det(M) OUT "out.1" INAME s;

OFF EXP$

OPTIMIZE detm2:=:det(M) OUT "out.2" INAME t;

ON NAT$
IN "out.1","out.2"$

detm1-detm2;

0
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

So far we presented via some examples straightforward
algebraic mode use. The output is produced as a side-effect. However,
optimization results can easily be made operational in algebraic mode.
The parameterless function 

\hspace*{1cm} {\tt ARESULTS} 
\index{SCOPE function ! {\tt ARESULTS}}

delivers the result of the directly
preceding {\tt OPTIMIZE} command in the form of a list of equations,
corresponding with the sequence of assignment statements, shown either in
{\REDUCE} syntax or in the syntax of one of GENTRAN's target languages.
But, we need to operate carefully. Application of a variety of assignment 
operators can easily bring in identifiers, representing earlier produced
algebraic values. They will be substituted automatically, when referenced in 
rhs's in the list, produced with an {\tt ARESULTS} application. 
Therefore, we implemented a
protection mechanism. Before delivering output produced by {\tt ARESULTS},
we make the system temporarily deaf for such references. The
possibly game-spoiling algebraic values are stored at a seemingly 
anonymous place. All
identifiers, subjected to this special treatement, can be made visible with
the command 

\hspace*{1cm} {\tt RESTORABLES};
\index{SCOPE function ! {\tt RESTORABLES}}

Their original status can be restored, either globally with the command 

\hspace*{1cm} {\tt RESTOREALL}\verb+$+ 
\index{SCOPE function ! {\tt RESTOREALL}}

or selectively with the instruction 

\hspace*{1cm} {\tt ARESTORE} $<$subsequence$>$\verb+$+ 
\index{SCOPE function ! {\tt ARESTORE}}

This subsequence is built with names, selected  from the list 
of {\tt RESTORABLES}, and separated by comma's. Information restoration 
is only possible before the next {\tt OPTIMIZE} command.

\example\label{ex:3.1.9}
\index{SCOPE ! example}

The use of these commands is now illustrated.
A further explanation is given in the form of comment in the script. 

{\small
\begin{verbatim}
u:=a*x+2*b$ v:=sin(u)$ w:=cos(u)$ f:=v^2*w;

                                  2
f := cos(a*x + 2*b)*sin(a*x + 2*b)

OFF EXP$

OPTIMIZE f:=:f,g:=:f^2+f INAME s;

s3 := x*a + 2*b
s2 := sin(s3)
f := s2*s2*cos(s3)
g := f*(f + 1)

alst:=ARESULTS;

alst := {s3=a*x + 2*b,

         s2=sin(s3),

                     2
         f=cos(s3)*s2 ,

         g=(f + 1)*f}

% ---
% SCOPE is made deaf for the standard reference mechanism for algebraic 
% variables. However the rhs's in the list alst are simplified before 
% being shown. It explains the differences between the layout in the 
% alst items and the results, presented by the OPTIMIZE-command itself.
% ---

RESTORABLES;

{f}

f;

f

ARESTORE f$

f;
                             2
cos(a*x + 2*b)*sin(a*x + 2*b)

% ---
% f is re-associated with its original value. This can lead to a modified 
% presentation of some of the rhs's of alst.
% ---

alst;

{s3=a*x + 2*b,

 s2=sin(s3),

             2
 f=cos(s3)*s2 ,

                                2                                   2
 g=(cos(a*x + 2*b)*sin(a*x + 2*b)  + 1)*cos(a*x + 2*b)*sin(a*x + 2*b) }

OPTIMIZE f:=:f,g:=:f^2+f INAME s;

s3 := x*a + 2*b
s2 := sin(s3)
f := s2*s2*cos(s3)
g := f*(f + 1)

alst2:=ARESULTS$

OPTIMIZE f:=:f,g:=:f^2+f INAME s;

g := f*(f + 1)

% ---
% The algebraic value, which was associated with f, is permanently
% lost. It ought to be restored before a new OPTIMIZE command is given. 
% Therefore f:=:f produced an identity, which is redundant in terms of 
% code production. More details about removal of redundant code are
% given in section 7, when discussing data dependencies and related topics.
% ---

RESTOREALL$

f;

f
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

\subsection{The function {\tt ALGOPT}: Straightforward use}\label{SCOPE:algo}

\index{SCOPE function ! {\tt ALGOPT}}
\index{SCOPE function ! {\tt RESTOREALL}}
\index{SCOPE function ! {\tt RESTORABLES}}
\index{SCOPE function ! {\tt ARESULTS}}
\index{SCOPE function ! {\tt ARESTORE}}
The function {\tt ALGOPT} accepts up to three arguments. It can be used in 
stead of the {\tt OPTIMIZE} command. It returns the optimization result,
like {\tt ARESULTS}, in the form of a list of equations. 
Since the {\tt ARESULTS} mechanism
is applied as well, the pre-{\tt ALGOPT}-application situation can be restored
with {\tt RESTOREALL} or partly and selective with {\tt ARESTORE}, using
information, providable by an application of the function {\tt RESTORABLES}.

The first argument of {\tt ALGOPT}, like the other two optional, is the 
equivalent of the alglist or alglist\_production in the earlier introduced
syntax of a SCOPE\_application.
The second argument can be used to inform SCOPE
that input from file(s) have to be processed. We survey SCOPE's file 
management features in section~\ref{SCOPE:files}. So we omit a further 
discussion now. The last argument correspondents with the cse\_prefix 
of the {\tt INAME } option of the {\tt OPTIMIZE} command. The extension
of the SCOPE\_application syntax, needed to include possible {\tt ALGOPT} 
activities, is:

\begin{tabular}{lcl}
$<$SCOPE\_application$>$ & $::=$ & $\cdots~\mid~$\\
 & & {\tt ALGOPT}($<$a\_object\_list$>$[,$<$string\_id\_list$>$][,$<$cse\_prefix$>$]) $\mid$\\
 & & {\tt ALGOPT}([$<$a\_object\_list$>$,]$<$string\_id\_list$>$[,$<$cse\_prefix$>$])\\
\end{tabular}
\begin{tabular}{lcl}
$<$a\_object\_list$>$ & $::=$ & $<$a\_object$>~\mid$ \{$<$a\_object$>$[,$<$a\_object\_seq$>$]\}\\
$<$a\_object\_seq$>$ & $::=$ & $<$a\_object$>$[,$<$a\_object\_seq$>$]\\
$<$a\_object$>$ & $::=$ & $<$id$>~\mid~<$alglist$>~\mid~<$alglist\_production$>~\mid$
 \{$<$a\_object$>$\}
\end{tabular}

We require at least one actual parameter, here the a\_object\_list. Its
syntactical structure allows to apply a GENTRAN-like repertoire in an 
algebraic mode setting. The a\_object's can
either be an alglist identifier, an alglist producing function application, 
or an alglist itself. An alglist identifier can be
either a scalar or a matrix or array entry. The alglist producing
functions will be discussed in section~\ref{SCOPE:soph}. An alglist has the
structure of an algebraic mode list; its elements are either a\_object's
or equations of the form lhs = rhs. Such equations correspondent
with the "take literal" GENTRAN operator {\tt :=} facility in the setting
of an {\tt OPTIMIZE} command (see also section~\ref{SCOPE:soph} for a further
discussion). The alternatives, i.e. uses of {\tt ::=}, {\tt :=:} or {\tt ::=:},
are also covered by the a\_object syntax.
The examples, given in this subsection, show that simplification of an algebraic
list of equations leads to right hand side simplification, corresponding with
the effect of the colon-added-to-the-right-extension of the assignment operator.
However, as illustrated by example~\ref{ex:3.2.7}, some care has to be taken
when operating in {\tt OFF EXP} mode.
Turning {\tt ON} the switch {\tt EVALLHSEXP}, can lead to lhs evaluations,
corresponding with the extra-colon-to-the-left strategy. But we have to
be aware of the instanteneous evaluation mechanism for matrix and 
array entries, when referenced. 

We present some examples of possible use of the {\tt ALGOPT} function.
In example~\ref{ex:3.2.4} a straightforward application is given.
In example~\ref{ex:3.2.5} follows an ilustration of a possible strategy 
concerning optimizing sets of array- and/or matrix-entries. Then, 
in example~\ref{ex:3.2.6}, possible SCOPE assistance in problem analysis is 
shown. Finally in example~\ref{ex:3.2.7}
some differences in simplification and their influence on optimization are
discussed. We also introduce and explain the role of the SCOPE 
switch {\tt SIDREL}.
\index{{\tt SIDREL} switch}
\index{{\tt EVALLHSEQP} switch}

\example\label{ex:3.2.4}
\index{SCOPE ! example}

A number of possible alglist elements is presented in the script.
The first three elements of the actual parameter define values, obtained
via the usual algebraic mode list evaluation mechanism. The last two will be
processed literally. So, the actual parameter for {\tt ALGOPT} is composed 
of the scalar {\tt alist}, a list consisting of the matrix element {\tt m(1,1)},
the array element {\tt ar(2,2)}, nested even deeper, and two equations. Before 
an {\tt ALGOPT} argument is optimized it is flattened by the SCOPE parser 
into a list of equations, the algebraic mode equivalent of the sequence of
assignments in the {\tt OPTIMIZE} context. Evaluation of an {\tt ALGOPT}
application leads to an algebraic mode list of equations, with optimized rhs's.
The cse\_prefix was seemingly superfluous, because all its references
disappeared by back-substitution before output-processing started. See also
example~\ref{ex:3.2.7}.

\index{{\tt ALGOPT} application}
Since an {\tt ALGOPT} application always results in an algebraic mode list,
one can not use this feature for production of code in one of GENTRAN's target
languages. To facilitate the translation of the result of an {\tt ALGOPT}
application, we extended the syntax of the {\tt OPTIMIZE} input repertoire, 
such that alglst\_production's are processable by {\tt OPTIMIZE} 
as well, as illustrated in the script of this example and 
in example~\ref{ex:3.2.7}
{\small
\begin{verbatim}
OFF EXP$
ARRAY ar(2,2)$ MATRIX m(2,2)$

alst:={p1=a+b,p2=(a+b)^2}$

m(1,1):={q1=c+d,q2=(c+d)^2}$

ar(2,2):={r1=(a+b)*(c+d),r2=(a+b)^2*(c+d)^2}$

optlst:=ALGOPT({alst,{m(1,1)},{{ar(2,2)}},
                t1=(a+b)*(c+d)^2,t2=(c+d)*(a+b)^2},s);

optlst := {p1=a + b,
                2
           p2=p1 ,
           q1=c + d,
                2
           q2=q1 ,
           r1=p1*q1,
                2
           r2=r1 ,
           t1=q1*r1,
           t2=p1*r1}

OPTIMIZE optlst$

p1 := a + b
p2 := p1*p1
q1 := c + d
q2 := q1*q1
r1 := q1*p1
r2 := r1*r1
t1 := r1*q1
t2 := r1*p1
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\example\label{ex:3.2.5}
\index{SCOPE ! example}

In example~\ref{ex:3.1.8} we introduced a symmetric (3,3)-matrix {\tt m}. We
present an alternative computation of its determinant. We start with building 
a list of equations, with rhs's, being the non-zero entries of {\tt m}, 
relevant for the computation. The lhs's are produced with 
the {\tt mkid} function. These
newly generated names are assigned to the matrix-entries as well. Finally
we add the definition of the computation of the determinant of {\tt m}, 
in terms of the redefined entries, to this list. 
For the construction of the value of {\tt mlst} we applied both the lhs and
rhs evaluation mechanism. Observe also that, due to the redefinition process,
the original values of the entries of the matrix {\tt m} are lost.
We can optimize {\tt mlst}, using
either an {\tt OPTIMIZE} command or an {\tt ALGOPT} application. The reduction
in arithmetic is not yet impressive here, certainly comparing it with the 
non-expanded, optimized form in the earlier example~\ref{ex:3.1.8}. 
(See also example~\ref{ex:3.2.7} for additional comment).
However, working with larger and non-symmetric matrices will certainly 
improve results, when applying a comparable strategy. 

Observe that the syntax of permissible {\tt ALGOPT} a\_object's does not 
allow to use matrix or array names  to compactly identify the complete set
of their entries. The script in this example shows that such a facility is
easily made. This possibility exists already for matrices in a GENTRAN 
setting (see also example~\ref{ex:8.2} in section~\ref{SCOPE:gopt}).
\index{{\tt EVALLHSEQP} switch}
{\small
\begin{verbatim}
% ---
% We assume the matrix m to be known already.
% ---

mlst:={}$ l:=-1$

OFF EXP$ ON EVALLHSEQP$

FOR j:=1:3 DO FOR k:=j:3 DO
 IF m(j,k) neq 0 THEN
  << s:=mkid(t,l:=l+1);
     mlst:=append(mlst,{s=m(j,k)});
     m(j,k):=m(k,j):=s
  >>$

OFF EVALLHSEQP$

m;

[t0  t1  t2]
[          ]
[t1  t3  0 ]
[          ]
[t2  0   t4]


mlst:=append(mlst,{detm=det(m)});

                                     2         2
mlst := {t0= - (j30y - j30z + 9*m30*p )*sin(q3)

                                    2                      2
          + 18*cos(q2)*cos(q3)*m30*p  + j10y + j30y + m10*p

                    2
          + 18*m30*p ,

                                     2         2
         t1= - (j30y - j30z + 9*m30*p )*sin(q3)

                                   2                 2
          + 9*cos(q2)*cos(q3)*m30*p  + j30y + 9*m30*p ,

                                      2
         t2= - 9*sin(q2)*sin(q3)*m30*p ,

                                     2         2                 2
         t3= - (j30y - j30z + 9*m30*p )*sin(q3)  + j30y + 9*m30*p ,

                          2
         t4=j30x + 9*m30*p ,

                         2         2
         detm=(t0*t3 - t1 )*t4 - t2 *t3}

ON ACINFO,FORT$ OFF PERIOD$
\end{verbatim}}
\index{{\tt ACINFO} switch}
\index{{\tt FORT} switch}
\index{{\tt PERIOD} switch}
{\small
\begin{verbatim}
OPTIMIZE mlst INAME s;

Number of operations in the input is: 

Number of (+/-) operations      : 19
Number of unary - operations    : 1
Number of * operations          : 33
Number of integer ^ operations  : 16
Number of / operations          : 0
Number of function applications : 9

      S0=SIN(REAL(Q3))
      S7=P*P
      S5=S7*M30
      S4=S5*COS(REAL(Q3))*COS(REAL(Q2))
      S13=9*S5
      S11=(S13+J30Y-J30Z)*S0*S0
      T0=J30Y+J10Y+18*(S4+S5)+S7*M10-S11
      T3=S13+J30Y-S11
      T1=T3+9*S4
      T2=-(S13*SIN(REAL(Q2))*S0)
      T4=S13+J30X
      DETM=T4*(T3*T0-(T1*T1))-(T2*T2*T3)

Number of operations after optimization is:

Number of (+/-) operations      : 13
Number of unary - operations    : 1
Number of * operations          : 17
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 4
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\example\label{ex:3.2.6}
\index{SCOPE ! example}

We now illustrate that information, produced by SCOPE, can possibly also play 
a role in computations in algebraic mode.  Let ${\rm A.\vec{x}~=~\vec{b}}$ 
be given by

 \[ \left[ \begin{array}{rrrrrr}
                             -1 & 2  & -2 & 1 & 3 & 2 \\
                             -2 & 4  & -4 & 2 & -2 & 3 \\
                              1 & 1  &  1 & 1 & 2 & 4 \\
                              2 & -2 & -1 & 1 & -1 & -2 \\
                              3 & 1  & -4 & 1 & 1 & 2 \\
                             -1 & -5 &  1 & 1 & 3 & 6
      \end{array}\right]~\cdot~\left[ \begin{array}{c}
                                 x1 \\ x2 \\ x3 \\ x4 \\ x5 \\ x6
                               \end{array} \right]~=~
                               \left[ \begin{array}{r}
                                 5 \\ 1 \\ 10 \\ -3 \\ 4 \\ 5
                               \end{array} \right] \cdot \]

This artificial system is constructed for illustrative purposes. 
Its solution is simply ${\rm x_i~=~1}$, ${\rm i~=~1,..,6}$. 
But straightforward inspection shows that

 \[ {\rm A}~=~\left[ \begin{array}{cc}
                          {\rm A}_1 & {\rm A}_2 \\
                          {\rm A}_3 & {\rm A}_4 \end{array}\right]~
            {\rm where}~{\rm A}_1~=~\left[ \begin{array}{cccc}
                                  -1 & 2 & -2 & 1\\ 
                                  -2 & 4 & -4 & 2  \end{array}\right]~
            {\rm and}~ {\rm A}_4~=~\left[ \begin{array}{rr}
                          2 & 4 \\
                         -1 & -2 \\
                          1 & 2 \\
                          3 & 6 \end{array} \right] \cdot \]

We can use {\tt ALGOPT} to "discover" and thus to employ this information.
The system is introduced in the form of assignment statements
  $e_i~=~(\sum_{j=1}^{6}~a_{ij}~\cdot~x_{j})~-~b_{i},~i~=~1, \cdots ,6$.
We use {\tt alst}, identifying the set of equations (see command 9), 
as actual parameter for {\tt ALGOPT}, leading to an algebraic list, 
identified by {\tt reslst} (see command 10). We recognize {\tt g2 = g6 + x5} 
{\tt (= x5 + 2x6)} and {\tt g1 = g3 + g5 + -2x3} {\tt (= -x1 + 2x2 - 2x3 + x4)}. 
Through command 12 we require
cse's to have an arithmetic complexity of a least 4. We then find {\tt g1}
directly, now called {\tt g8}, because we continue applying the
function {\tt gensym}; the cse\_prefix was left out as actual parameter. 
The {\tt solve} function is applied (command 14) to obtain {\tt rootset1}, a list
of values for {\tt x5} and {\tt x6}, expressed in the parameter {\tt g8}.
After assigning {\tt g8} its value in algebraic mode and 
resetting the algebraic values of {\tt ei}, $i~=~ 1, \cdots ,6$ 
with {\tt RESTOREALL} instructions (the commands 11 and 16), 
we can obtain the solution 
of the subsets, denoted by {\tt rootset1} and {\tt rootset2}.
\index{SCOPE function ! {\tt RESTOREALL}}
{\small
\begin{verbatim}
1: LOAD_PACKAGE nscope$

2: e1:=2*x6+3*x5+x4-2*x3+2*x2-x1-5$

3: e2:=3*x6-2*x5+2*x4-4*x3+4*x2-2*x1-1$

4: e3:=2*x5+4*x6+x1+x2+x3+x4-10$

5: e4:=-x5-2*x6+2*x1-2*x2-x3+x4+3$

6: e5:=x5+2*x6+3*x1+x2-4*x3+x4-4$

7: e6:=3*x5+6*x6-x1-5*x2+x3+x4-5$

8: solve({e1,e2,e3,e4,e5,e6},{x1,x2,x3,x4,x5,x6});

{{x1=1,x2=1,x3=1,x4=1,x5=1,x6=1}}

9: alst:={e1=e1,e2=e2,e3=e3,e4=e4,e5=e5,e6=e6}$

10: reslst:=ALGOPT alst;

reslst := {g3= - x1 + x4,

           g5=2*x2,

           g1=g3 + g5 - 2*x3,

           g6=2*x6,

           e1=g1 + g6 + 3*x5 - 5,

           e2=2*g1 - 2*x5 + 3*x6 - 1,

           g2=g6 + x5,

           g4=x2 + x4,

           e3=2*g2 + g4 + x1 + x3 - 10,

           e4= - g2 - g5 + 2*x1 - x3 + x4 + 3,

           e5=g2 + g4 + 3*x1 - 4*x3 - 4,

           e6=3*g2 + g3 - 5*x2 + x3 - 5}

11: RESTOREALL$

12: SETLENGTH 4$

13: reslst:=ALGOPT alst;

reslst := {g8= - x1 + 2*x2 - 2*x3 + x4,

           e1=g8 + 3*x5 + 2*x6 - 5,

           e2=2*g8 - 2*x5 + 3*x6 - 1,

           e3=x1 + x2 + x3 + x4 + 2*x5 + 4*x6 - 10,

           e4=2*x1 - 2*x2 - x3 + x4 - x5 - 2*x6 + 3,

           e5=3*x1 + x2 - 4*x3 + x4 + x5 + 2*x6 - 4,

           e6= - x1 - 5*x2 + x3 + x4 + 3*x5 + 6*x6 - 5}

14: rootset1:=solve({part(reslst,2,2),part(reslst,3,2)},{x5,x6});

                  g8 + 13       - 8*g8 + 13
rootset1 := {{x5=---------,x6=--------------}}
                    13              13
15: g8:=part(reslst,1,2);

g8 :=  - x1 + 2*x2 - 2*x3 + x4

16: RESTOREALL$

17: rootset2:=solve(sub(rootset1,{e3,e4,e5,e6}),{x1,x2,x3,x4});

rootset2 := {{x1=1,x2=1,x3=1,x4=1}}

18: rootset1:=sub(rootset2,rootset1);

rootset1 := {{x5=1,x6=1}}
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\index{SCOPE function ! {\tt SETLENGTH}}
\index{{\tt EXP} switch}
\example\label{ex:3.2.7}
\index{SCOPE ! example}

The script in example~\ref{ex:3.2.5} suggests that we can easily copy GENTRAN's
assignment features by some listprocessing in algebraic mode. However, we 
have to operate carefully. In the script of the present example we introduce an
expression denoted by {\tt f}. Production of a number of its partial (higher)
derivatives is a straightforward mechanism to assist in constructing a set
of assignment statements, containing lots of cse's. Inspection of the values,
in {\tt OFF EXP} mode assigned to {\tt faa}, {\tt tst1} and {\tt tst2}, 
respectively, learns that the value of {\tt mlst} in example~\ref{ex:3.2.5}
may be improvable.
{\small
\begin{verbatim}
u:=a*x+2*b$ v:=sin(u)$ w:=cos(u)$ f:=v^2*w$

OFF EXP$

faa:=df(f,a,2);

                        2                   2                  2
faa := (2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)*x

tst1:={faa=df(f,a,2)};

                             3  2                                  2  2
tst1 := {faa=2*cos(a*x + 2*b) *x  - 7*cos(a*x + 2*b)*sin(a*x + 2*b) *x }

tst2:={faa=(faa:=df(f,a,2))};

                              2                   2                  2
tst2 := {faa=(2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)*x }
\end{verbatim}}
We produce an optimized version of the value of {\tt tlst}, using {\tt ALGOPT}.
Switching {\tt ON INPUTC} and {\tt PRIMAT} results in an input echo, indeed
showing expanded rhs's and a vizualized picture of the \verb+Sumscheme+ of
$D_{\lambda}$. We skipped the ${\rm D_0}$-picture and the rest of the 
$D_{\lambda}$-picture from the script. The value of {\tt reslst} shows the
patterns {\tt s14 = -7.f.x + 2.s9.x} and {\tt fbb = -28.f + 8.s9}. 
The presented \verb+Sumscheme+ of $D_{\lambda}$ suggests that {\tt fbb} and 
{\tt s13} (see the Fa(the)r entries) seemingly have
nothing in common. But {\tt s14} stands for {\tt 2.s6 - 7.s7}, because,
column 8 has to be identified with {\tt s7}, etc. Since both {\tt S6} and
{\tt S7} occur only once in $D_{\lambda}$, their value replaces them in the 
output.
It is an illustration of the heuristic character of the optimization process.
Optimization of the value of {\tt reslst} shows that the repeated pattern 
is now recognized.
\index{{\tt INPUT} switch}
\index{{\tt PRIMAT} switch}
{\small
\begin{verbatim}
tlst:={f=f,fa=df(f,a),fb=df(f,b),faa=df(f,a,2),
       fab=df(f,a,b),fba=df(f,b,a),fbb=df(f,b,2)}$

ON INPUTC,PRIMAT$

reslst:=ALGOPT(tlst,s);

                                  2
f := cos(a*x + 2*b)*sin(a*x + 2*b)

                      2                                  3
fa := 2*cos(a*x + 2*b) *sin(a*x + 2*b)*x - sin(a*x + 2*b) *x

                      2                                  3
fb := 4*cos(a*x + 2*b) *sin(a*x + 2*b) - 2*sin(a*x + 2*b)

                       3  2                                  2  2
faa := 2*cos(a*x + 2*b) *x  - 7*cos(a*x + 2*b)*sin(a*x + 2*b) *x

                       3                                     2
fab := 4*cos(a*x + 2*b) *x - 14*cos(a*x + 2*b)*sin(a*x + 2*b) *x

                       3                                     2
fba := 4*cos(a*x + 2*b) *x - 14*cos(a*x + 2*b)*sin(a*x + 2*b) *x

                       3                                   2
fbb := 8*cos(a*x + 2*b)  - 28*cos(a*x + 2*b)*sin(a*x + 2*b)

Sumscheme :

   |  3  4  5  6  7  8  9 10 11 12 32| EC|Far
---------------------------------------------
  3|                             1  2|  1| s3
 20|         -28  8                  |  1| fbb
 37|                -7  2            |  1| s14
 38|                      -1  2      |  1| s15
---------------------------------------------
3  : s3
4  : s15
5  : s14
6  : s4
7  : s9
8  : s7
9  : s6
10 : s10
11 : s5
12 : s8
32 : b

reslst := {s3=a*x + 2*b,

           s0=cos(s3),

                3
           s9=s0 ,

           s2=sin(s3),

           s12=s0*s2,

           f=s12*s2,

                            3
           s15=2*s0*s12 - s2 ,

           fa=s15*x,

           fb=2*s15,

           s14= - 7*f*x + 2*s9*x,

           faa=s14*x,

           fab=2*s14,

           fba=fab,

           fbb= - 28*f + 8*s9}

OFF INPUTC,PRIMAT$

OPTIMIZE reslst$

s3 := 2*b + x*a
s0 := cos(s3)
s9 := s0*s0*s0
s2 := sin(s3)
s12 := s2*s0
f := s12*s2
s15 := 2*s12*s0 - s2*s2*s2
fa := s15*x
fb := 2*s15
g3 := 2*s9 - 7*f
s14 := g3*x
faa := s14*x
fab := 2*s14
fba := fab
fbb := 4*g3
\end{verbatim}}
Repeating this process, this time with an {\tt OPTIMIZE} command to begin with,
learns that the {\tt OFF EXP} mode is now effective. But this time, and for 
similar
reasons, the assignments {\tt fbb = 4.s9.s0} and {\tt s12 = s9.s0.x} still
have a subexpression in common. Now the \verb+Productscheme+ of $D_{\lambda}$ 
helps understanding the phenomenon; again we skipped for shortness the rest of
the information, provided by the {\tt ON PRIMAT} status of SCOPE.
Internally {\tt s12} denotes the product {\tt s4.s9},
where {\tt s4 = x.s0}. The cse {\tt s4} disappeared from the output. 
An {\tt ALGOPT} application leads to the "discovery" of the 
cse {\tt g10 = s0.s9}.
{\small
\begin{verbatim}
f:=v^2*w;
                                  2
f := cos(a*x + 2*b)*sin(a*x + 2*b)

ON INPUTC,PRIMAT$

OPTIMIZE f:=:f,fa:=:df(f,a),fb:=:df(f,b),faa:=:df(f,a,2),
         fab:=:df(f,a,b),fba:=:df(f,b,a),fbb:=:df(f,b,2) INAME s$

                                  2
f := cos(a*x + 2*b)*sin(a*x + 2*b)

                       2                 2
fa := (2*cos(a*x + 2*b)  - sin(a*x + 2*b) )*sin(a*x + 2*b)*x

                         2                 2
fb := 2*(2*cos(a*x + 2*b)  - sin(a*x + 2*b) )*sin(a*x + 2*b)

                        2                   2                  2
faa := (2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)*x

                          2                   2
fab := 2*(2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)*x

                          2                   2
fba := 2*(2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)*x

                          2                   2
fbb := 4*(2*cos(a*x + 2*b)  - 7*sin(a*x + 2*b) )*cos(a*x + 2*b)

s3 := x*a + 2*b
s0 := cos(s3)
s2 := sin(s3)
s6 := s2*s2
f := s6*s0
s14 := 2*s0*s0
s13 := (s14 - s6)*s2
fa := s13*x
fb := 2*s13
s9 := s14 - 7*s6
s12 := s9*s0*x
faa := s12*x
fab := 2*s12
fba := fab
fbb := 4*s9*s0

Productscheme :

   |  0  2  3  4  5 12 14 18 19 20 21 22 23| EC|Far
---------------------------------------------------
  0|                    1           1      |  1| f
  5|     1                             1   |  1| fa
  9|     1                                 |  2| fb
 13|        1                          1   |  1| faa
 17|  1                                    |  1| fab
 21|  1                                    |  1| fba
 25|           1                    1      |  4| fbb
 29|                                1  1   |  1| s4
 30|                                   1  1|  1| s5
 31|                             2         |  1| s6
 33|                                2      |  1| s8
 37|           1              1            |  1| s12
 38|              1              1         |  1| s13
 39|                 1                     |  2| s14
 40|        1                              |  2| s15
---------------------------------------------------
0  : s15
2  : s13
3  : s12
4  : s9
5  : s10
12 : s8
14 : s6
18 : s5
19 : s4
20 : s2=sin(s3)
21 : s0=cos(s3)
22 : x
23 : a

ALGOPT ARESULTS;

{s3=a*x + 2*b,

 s0=cos(s3),

 s2=sin(s3),

      2
 s6=s2 ,

 f=s0*s6,

         2
 s14=2*s0 ,

 s13=(s14 - s6)*s2,

 fa=s13*x,

 fb=2*s13,

 s9=s14 - 7*s6,

 g10=s0*s9,

 s12=g10*x,

 faa=s12*x,

 fab=2*s12,

 fba=fab,

 fbb=4*g10}     
\end{verbatim}}
This script is shown for different reasons. It illustrates the heuristic 
character of the optimization process. We optimize, but do not guarantee 
the optimal solution. It also shows how easily repeated SCOPE applications
can be accomplished. Hence commands like "{\tt ALGOPT} {\tt ARESULTS};", 
"{\tt ALGOPT} {\tt ALGOPT} $\cdots$ ;" 
or "{\tt OPTIMIZE} {\tt ALGOPT} $\cdots$ ;" are all possible.
However, it is sometimes better to avoid such a combination when a 
{\tt RESTOREALL} instruction has to follow the first application.
A more detailed discussion about these possibilities is given in 
section~\ref{SCOPE:soph}, and especially in section~\ref{SSF:Sl}.
An additional reason was, to stipulate that SCOPE's actual parameters
have to be built carefully.
\index{{\tt SIDREL} switch}
\index{SCOPE function ! {\tt SETLENGTH}}

This example is also used to illustrate the role, which the switch {\tt SIDREL}
can possibly play. When turned it {\tt ON} the finishing touch F (see 
subsection~\ref{SCOPE:bird}) is omitted and all non-additive cse's
are substituted back, thus producing a possibly still rewritten input set,
which consists of toplevel input and additive cse's only. A simple
straightforward backsubstitution mechanism is applied on the optimization
result before it is presented to the user. Seemingly, it can lead to surprises
as shown below by the differences between the presentations of {\tt s15}, 
{\tt s14} and {\tt fbb} when again optimizing the contents of {\tt tlst}.
This effect disappeares when using {\tt SETLENGTH}.

The switch {\tt SIDREL} was introduced in SCOPE quite long ago. By that
time Hearn was wondering ~\cite{Hearn:85,Hearn:86} if (parts of) SCOPE output, 
presented in algebraic mode, can be used as input for a Gr\"{o}bner-base
algorithm application, thus attempting to assist in expression restructuring 
leading to improved expression representations. 
{\small
\begin{verbatim}
ON SIDREL$

ALGOPT(tlst,s);

{s3=a*x + 2*b,

                  2
 f=cos(s3)*sin(s3) ,

              2                  3
 s15=2*cos(s3) *sin(s3) - sin(s3) ,

 fa=s15*x,

 fb=2*s15,

                                       2              3
 s14= - 7*cos(a*x + 2*b)*sin(a*x + 2*b) *x + 2*cos(s3) *x,

 faa=s14*x,

 fab=2*s14,

 fba=2*s14,

                                        2            3
 fbb= - 28*cos(a*x + 2*b)*sin(a*x + 2*b)  + 8*cos(s3) }

SETLENGTH 4$

ALGOPT(tlst,s);

                                2
{f=cos(a*x + 2*b)*sin(a*x + 2*b) ,

                     2                                3
 s15=2*cos(a*x + 2*b) *sin(a*x + 2*b) - sin(a*x + 2*b) ,

 fa=s15*x,

 fb=2*s15,

                     3                                    2
 s14=2*cos(a*x + 2*b) *x - 7*cos(a*x + 2*b)*sin(a*x + 2*b) *x,

 faa=s14*x,

 fab=2*s14,

 fba=2*s14,

                     3                                   2
 fbb=8*cos(a*x + 2*b)  - 28*cos(a*x + 2*b)*sin(a*x + 2*b) }
\end{verbatim}}
{\small
\begin{flushright}
$\Box$
\end{flushright}}
\newpage
\section{Special SCOPE 1.5 Features}\label{SCOPE:soph}

Part of the input syntax for the function {\tt ALGOPT} was left undiscussed
in section~\ref{SCOPE:algo}. It was the permissable form for (parts of) 
the actual parameter, defining function applications, producing 
an alglist. The alglist is an algebraic mode list, consisting 
either of equations of the form lhs = rhs or of constructs 
evaluating into an alglist or referencing an alglist.
In section~\ref{SSF:Sl} is explained which type of user defined
functions lead to permissable function applications as (part of an) actual 
parameter for an {\tt OPTIMIZE} command or an {\tt ALGOPT} application.
Tools are provided for building a SCOPE library.
Already available facilities, designed along these lines, cover
{\bf structure recognition}, presented in section~\ref{SSF:sr} and
{\bf Horner-rule} based expression rewriting, surveyed in section~\ref{SSF:Hr}.

\subsection{Towards a SCOPE 1.5 Library}\label{SSF:Sl}

\index{REDUCE function ! {\tt ENDSTAT}-type}
\index{REDUCE function ! {\tt NORMAL}-type}
\index{REDUCE function ! {\tt PSOPFN}-type}
Design and implementation of an algebraic or symbolic procedure, returning
a list of equations in algebraic mode, is straightforward as long as the 
number of formal parameters is exactly known. Let us call such procedures
functions of {\tt NORMAL}-type. When formal parameters are not required, 
the so-called {\tt ENDSTAT}-variant can be used.
One simply associates an indicator {\tt stat}, with
value {\tt endstat}, with the function name {\tt f-name},
using \verb+lisp(put('f-name,'stat,'endstat))$+ as instruction. 
Such a function will be said to be of {\tt ENDSTAT}-type.

The so-called {\tt PSOPFN}-type function is similar to the {\tt FEXPR}-type 
function in symbolic mode. It may have an arbitrary number of unevaluated
parameters.
Special attention is made possible by modifying the function {\tt reval1}, used
in both {\tt reval} and {\tt aeval}. The relevant section of the evaluator is:
{\small
\begin{verbatim}
symbolic procedure aeval u; reval1(u,nil);
symbolic procedure reval u; reval1(u,t);

symbolic procedure reval1(u,v);
.......................
else if x:=get(car u,'psopfn)
 then << u:=apply(x,list cdr u);
         if x:=get(x,'cleanupfn) then u:=apply(x,list(u,v));
         return u
      >>
.......................
\end{verbatim}}
The actual parameter {\tt u} of {\tt reval1} is a function application in
prefixform: ({\tt function-name} {\tt arg1} ... {\tt argn}). 
The {\tt function-name} is replaced by the value of the indicator {\tt psopfn}.
The thus modified S-expression is evaluated. This mechanism leaves control
over evaluation of (part of) the arguments, collected in {\tt cdr u}, to the
designer of the function hidden behind the {\tt psopfn} value. We employed
this simple mechanism to implement {\tt ALGOPT} and some of the features,
to be discussed in section~\ref{SSF:sr} and section~\ref{SSF:Hr}.
A possible re-evaluation step, based on the use of the
value of the indicator {\tt cleanupfn} was not necessary; it is not yet 
allowed in the SCOPE context.

The different combinations, suggested in example~\ref{ex:3.2.7}, such as
{\tt ALGOPT} {\tt ALGOPT} or {\tt ALGOPT} {\tt ARESULTS}, are merely examples 
of a general rule:

{\em {\tt ENDSTAT}-, {\tt NORMAL}- and {\tt PSOPFN}-type functions, delivering
an alglist when applied, are all applicable as actual parameter or
as element of an alglist, functioning as actual parameter in an
{\tt OPTIMIZE} command or an {\tt ALGOPT} application. }

\index{REDUCE function ! {\tt ENDSTAT}-type}
\index{REDUCE function ! {\tt NORMAL}-type}
\index{REDUCE function ! {\tt PSOPFN}-type}
So, in principle, special features, providing a form of preprocessing, can be
designed and implemented as extension of the default optimization repertoire.
Of course additional function types are conceivable.
We illustrate the potential of this facility with a simple example. 
Further examples follow
in section~\ref{SSF:sr} and section~\ref{SSF:Hr}. 

\example\label{ex:4.1.1}
\index{SCOPE ! example}

The procedures {\tt asquares} and {\tt repeated\_squaring}  
define the production of
lists of equations. The lhs's function as name and the rhs's as
the computational rules.
Application of these functions shows how easy a user can provide new features,
usable in a SCOPE context.
The procedures {\tt asquares} and {\tt repeated\_squaring} are essentially 
different The first has one parameter, a list of equations, while the latter
accepts an arbitrary number of such lists as actual parameters. 
The {\tt psopfn} indicator value is
{\tt repeated\_squaringeval}, the name of the function, which is actually
introduced. {\tt asquares} is of {\tt NORMAL}-type and applicable in both 
algebraic and symbolic mode.
{\small
\begin{verbatim}
OPERATOR square$

sq_rule:={square(~u) => u^2}$

ALGEBRAIC PROCEDURE asquare u;
 square(u) WHERE sq_rule$

SYMBOLIC PROCEDURE rsquare u; 
 reval asquare aeval u$

SYMBOLIC PROCEDURE asquares u;
 append(list('list),
        FOREACH el IN cdr u COLLECT list('equal,cadr el,rsquare caddr el))$

SYMBOLIC OPERATOR asquares$

SYMBOLIC PROCEDURE repeated_squaringeval u;
BEGIN SCALAR res; INTEGER j;
 j=0;
 FOREACH el IN u DO
  << j:=j+1; el:=asquares el;
     FOR k:=2:j DO el:=asquares el;
     res:= IF j=1 THEN el ELSE append(res,cdr el)
  >>;
 RETURN res
END$

LISP( put('repeated_squaring,'psopfn,'repeated_squaringeval))$

% ---
% Examples of the use of asquares and repeated_squaring.
% Although the psopfn-mechanism can be easily avoided, 
% it is used for illustrative purposes here.
% ---

OFF EXP$

asquare sin(x);

      2
sin(x)

LISP(rsquare('(sin x)));

(expt (sin x) 2)

asq:=asquares {s1=a+b,s2=(a+b)^2,s3=(a+b)^3};

                  2           4           6
asq := {s1=(a + b) ,s2=(a + b) ,s3=(a + b) }

repeated_squaring({s1=a+b,s2=(a+b)^2},{s3=(a+b)^3,s4=(a+b)^4},
                           {s5=(a+b)^5,s6=(a+b)^6});

           2
{s1=(a + b) ,

           4
 s2=(a + b) ,

           12
 s3=(a + b)  ,

           16
 s4=(a + b)  ,

           40
 s5=(a + b)  ,

           48
 s6=(a + b)  }

% ---
% The "ALGOPT asquares ...;" application is similar to the "ALGOPT asq;"
% instruction.
% ---

ALGOPT(asquares {s1=a+b,s2=(a+b)^2,s3=(a+b)^3},t);

               2      2
{t2=a + b,s1=t2 ,s2=s1 ,s3=s1*s2}

ALGOPT asq;
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
               2      2
{g6=a + b,s1=g6 ,s2=s1 ,s3=s1*s2}

% ---
% The OPTIMIZE variant is now applied on a repeated_squaring application.
% ---

OPTIMIZE repeated_squaring({s1=a+b,s2=(a+b)^2},{s3=(a+b)^3,s4=(a+b)^4},
                           {s5=(a+b)^5,s6=(a+b)^6}) INAME t;
t5 := a + b
s1 := t5*t5
s2 := s1*s1
t12 := s2*s2
s3 := s2*t12
s4 := s2*s3
s5 := t12*t12*t12*s4
s6 := t12*s5
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

\subsection{Structure Recognition: 
{\tt GSTRUCTR} and {\tt ALGSTRUCTR}} \label{SSF:sr}

\index{REDUCE function ! {\tt GSTRUCTR}}
\index{REDUCE function ! {\tt structr}}
\index{SCOPE function ! {\tt ALGSTRUCTR}}
The {\tt structr} command in REDUCE 3.6 (see the manual, section 8.3.8)
can be used
to display the skeletal structure of its evaluated argument, a single 
expression. After setting {\tt ON SAVESTRUCTR} a {\tt structr} command 
will return a list, whose first element is a presentation for the expression 
and subsequent elements are the subexpression relations.\\
A special SCOPE feature provides an extended display facility, called
{\tt GSTRUCTR}. The syntax of this generalized command is:

\begin{center}
\begin{tabular}{lcl}
$<${\tt REDUCE}\_command$>$ & $::=$ & $\cdots~\mid$\\
& & {\tt GSTRUCTR} $<$stat\_group$>$ [{\tt NAME} $<$cse\_prefix$>$]\\ 
$<$stat\_group$>$ & $::=$ & $\ll~<$stat\_list$>~\gg$\\
$<$stat\_list$>$ & $::=$ & $<$gstat$>$ [; $<$stat\_list$>$]\\
$<$gstat$>$ & $::=$ & $<$name$>~:=~<$ expression$>~\mid~<$matrix\_id$>$
\end{tabular}
\end{center}

The stat\_group consists
of one assignment statement or a group of such statements. Application of 
a {\tt GSTRUCTR} command provides a display of the structure of the whole 
set of assignments. Such an assignment can be replaced by a matrix reference.  
That leads to the display of all the non-zero entries of the referenced
matrix as well. The {\tt NAME} part is optional. The cse-name mechanism 
is applied in the usual way.

The equivalent of a possible {\tt ON SAVESTRUCTR} setting is provided in the
form of a {\tt PSOPFN}-type function, called {\tt ALGSTRUCTR}. 
Its syntax is:

\begin{center}
\begin{tabular}{lcl}
$<$function\_application$>$ & $::=$ & 
{\tt ALGSTRUCTR} ($<$arg\_list$>$ [, $<$cse\_prefix$>$ ]) \\
$<$arg\_list$>$ & $::=$ & $<$arg\_list\_name$>~\mid~$\{$<$arg\_seq$>$\}\\
$<$arg\_seq$>$ & $::=$ & $<$arg$>$[,$<$arg\_seq$>$]\\
$<$arg$>$ & $::=$ & $<$matrix\_id$>~\mid~<$name$>$=$<$expression$>$\\
$<$arg\_list\_name$>$ & $::=$ & $<$id$>$
\end{tabular}
\end{center}

The result is presented in the form of an algebraic mode list.

Earlier SCOPE-versions allowed to use a {\tt GSTRUCTR} command as (part of an)
actual parameter for an {\tt OPTIMIZE} command. This facility is not longer
supported. In stead, an {\tt ALGSTRUCTR} application can now be used as (part
of an) actual parameter in both an {\tt OPTIMIZE} command or an {\tt ALGOPT} 
application. We now illustrate these features in:
\index{REDUCE function ! {\tt GSTRUCTR}}
\index{SCOPE function ! {\tt ALGSTRUCTR}}

\example\label{ex:4.1.2}
\index{SCOPE ! example}

The script hardly requires explanation. However, observe 
that {\tt v1}, {\tt v3}, {\tt v4}, {\tt v6} and {\tt v7} occur only once 
in the result of the {\tt GSTRUCTR} application. When this application
is used as actual parameter for an {\tt OPTIMIZE} command
these redundancies are removed before the actual optimization process starts.
Likewise,
an {\tt ALGSTRUCTR} application only leads to identification of repeatedly
occuring sub-structures in its input. 
{\tt ALGSTRUCTR}, {\tt ALGHORNER}, see the next subsection, and {\tt ALGOPT}
all apply the same output production strategy, i.e. it might be necessary to
restore the previous algebraic mode status by applying the 
function {\tt RESTOREALL}.
{\small
\begin{verbatim}
OFF EXP,PERIOD$

MATRIX a(2,2);

a:=mat((x+y+z,x*y),((x+y)*x*y,(x+2*y+3)^3-x));

     [ x + y + z          x*y        ]
     [                               ]
a := [                          3    ]
     [(x + y)*x*y  (x + 2*y + 3)  - x]

GSTRUCTR <> NAME v$

a(1,1) := v1
a(1,2) := x*y
a(2,1) := v2*x*y
a(2,2) := v4
       2
b := v2
c := v2*v5
          2
d := v6*v7 *v5

   where

      v7 := x + z
      v6 := x + 2*y
      v5 := y + z
              3
      v4 := v3  - x
      v3 := x + 2*y + 3
      v2 := x + y
      v1 := x + y + z

ALGSTRUCTR({a,b=(x+y)^2,c=(x+y)*(y+z),d=(x+2*y)*(y+z)*(z+x)^2},v);

{a(1,1)=x + y + z,

 a(1,2)=x*y,

 v2=x + y,

 a(2,1)=v2*x*y,

                     3
 a(2,2)=(x + 2*y + 3)  - x,

     2
 b=v2 ,

 v5=y + z,

 c=v2*v5,

                    2
 d=(x + 2*y)*(x + z) *v5}
\end{verbatim}}
\index{SCOPE function ! {\tt RESTORABLES}}
\index{SCOPE function ! {\tt ARESTORE}}
{\small
\begin{verbatim}
RESTORABLES;

{a}

ARESTORE a$

alst:=
 ALGOPT(ALGSTRUCTR({a,b=(x+y)^2,c=(x+y)*(y+z),d=(x+2*y)*(y+z)*(z+x)^2},v),s);

*** a declared operator 

alst := {s5=x + z,

         a(1,1)=s5 + y,

         a(1,2)=x*y,

         v2=x + y,

         a(2,1)=a(1,2)*v2,

         s6=x + 2*y,

         s4=s6 + 3,

                  3
         a(2,2)=s4  - x,

             2
         b=v2 ,

         v5=y + z,

         c=v2*v5,

             2
         d=s5 *s6*v5}

% ---
% The above delivered warning is caused by the decloupling of a and its
% status as matrix. Therefore a(1,2) can function in the rhs of a(2,1).
% After an ARESTORE instruction a can restart its life as matrix_id.
% ---

a;

a

ARESTORE a$

a;

[ x + y + z          x*y        ]
[                               ]
[                          3    ]
[(x + y)*x*y  (x + 2*y + 3)  - x]
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

\subsection{Horner-rules: {\tt GHORNER} and {\tt ALGHORNER}} \label{SSF:Hr}

\index{Horner-rules} 
\index{REDUCE function ! {\tt GHORNER}} 
\index{SCOPE function ! {\tt ALGHORNER}}
Horner-rule based expression modification is a SCOPE facility, 
called {\tt GHORNER}. The syntax of the command is similar to the
{\tt GSTRUCTR} syntax: 

\begin{center}
\begin{tabular}{lcl}
$<${\tt REDUCE}\_command$>$ & $::=$ & $\cdots~\mid$\\
& & {\tt GHORNER} $<$stat\_group$>$ [{\tt VORDER} $<$id\_seq$>$];
\end{tabular}
\end{center}

The {\tt VORDER} part is optional. Application of 
a (generalized) Horner-rule assumes an identifier ordering. The syntax
of the identifier sequence is: 

\hspace{1cm} $<$id\_seq$>~::=~<$id$>$[,$<$id\_seq$>$].

We assume the rhs's in the stat\_group to be polynomials in
the identifiers, partly or completely given in the id\_seq. The 
left-to-right ordering of this sequence replaces the existing system 
identifier ordering. Identifiers, omitted from the {\tt vorder} sequence
have a lower preference and follow the existing system ordering. The
rewritten rhs's are presented as a side-effect. FORTRAN notation is of
course permitted. It is simply an extended print facility.

The {\tt PSOPFN}-type variant of the {\tt GHORNER} command is 
called {\tt ALGHORNER}. Its syntax is:

\begin{center}
\begin{tabular}{lcl}
$<$function\_application$>$ & $::=$ & $\cdots~\mid$\\
 & & {\tt ALGHORNER} ($<$arg\_list$>$ [,\{$<$id\_seq$>$\}]) \\
\end{tabular}
\end{center}

The syntax for the arg\_list can be found in subsection~\ref{SSF:sr}.
The result is presented in the form of an algebraic mode list.
An {\tt ALGHORNER} application can be used as (part of an) actual parameter 
of either an {\tt OPTIMIZE} command or an {\tt ALGOPT} application.

\example\label{ex:4.1.3}
\index{SCOPE ! example}

We illustrate the Horner-facilities by rewriting the expression of 
example~\ref{ex:3.1.2}, before optimizing it. Observe that 
application of {\tt ALGHORNER} in the default algebraic mode setting 
is useless. Due to  the algebraic mode regime the rewritten expression 
is expanded again. We also show some Taylor-series remodelling.
{\small
\begin{verbatim}
ON EXP$

z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+2*b^2*m^6+b^2*m^2;

      2  2       2  6    2  2          4      2  6    2  2
z := a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m

GHORNER z:=z VORDER a;

         2  6    2  2            4       2       6    2
z := (2*b *m  + b *m ) + a*(2*b*m  + a*(b  + 10*m  + m ))

GHORNER z:=z VORDER b;

          2  6    2  2            4       2      6    2
z := (10*a *m  + a *m ) + b*(2*a*m  + b*(a  + 2*m  + m ))

hlst:={z=z}$

ALGHORNER(hlst,{a,b,m});

    2  2       2  6    2  2          4      2  6    2  2
{z=a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m }

OPTIMIZE ALGHORNER(hlst,{a,b,m}) INAME s;

s1 := m*m
s0 := s1*s1
s2 := b*b
s4 := 2*s0
z := a*(a*(s2 + s1*(10*s0 + 1)) + s4*b) + s2*s1*(s4 + 1)

OPTIMIZE ALGHORNER(hlst,{b,m}) INAME s;

s2 := m*m
s0 := s2*s2
s1 := a*a
s4 := 2*s0
z := b*(b*(s1 + s2*(s4 + 1)) + s4*a) + s2*(s1 + 10*s1*s0)
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
% Hornering Taylor-series:

PROCEDURE taylor(fx,x,x0,n);
sub(x=x0,fx)+(FOR k:=1:n SUM(sub(x=x0,df(fx,x,k))*(x-x0)^k/factorial(k)))$

hlst2:={f1=taylor(e^x,x,0,4),f2=taylor(cos x,x,0,6)};

               4      3       2
              x  + 4*x  + 12*x  + 24*x + 24
hlst2 := {f1=-------------------------------,
                           24

                  6       4        2
               - x  + 30*x  - 360*x  + 720
          f2=------------------------------}
                          720

OPTIMIZE ALGHORNER(hlst2,{x});


       24 + x*(24 + x*(12 + x*(4 + x)))
f1 := ----------------------------------
                      24
g7 := x*x
       720 + g7*(g7*(30 - g7) - 360)
f2 := -------------------------------
                    720

ON ROUNDED$


hlst2:=hlst2;

                              4                   3        2
hlst2 := {f1=0.0416666666667*x  + 0.166666666667*x  + 0.5*x  + x + 1,

                                  6                    4        2
          f2= - 0.00138888888889*x  + 0.0416666666667*x  - 0.5*x  + 1

          }

OPTIMIZE ALGHORNER(hlst2,{x});


f1 := 1 + x*(1 + x*(0.5 + x*(0.0416666666667*x + 0.166666666667)))
g9 := x*x
f2 := 1 + g9*(g9*(0.0416666666667 - 0.00138888888889*g9) - 0.5)
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\index{{\tt ROUNDED} switch}

\newpage
\section{File Management and Optimization Strategies}\label{SCOPE:files}

Both the {\tt OPTIMIZE} command and the {\tt ALGOPT} function accept
input from file(s). Obviously, this input ought to obey the
usual syntactical rules, as introduced in the previous (sub)sections.

The {\tt OPTIMIZE} command is designed as a syntactical extension of {\REDUCE}
itself, i.e. the meaning of its actual parameters is understood from the
token-context in the command. However, an {\tt ALGOPT}
application requires one, two or three actual parameters without additional
provisions or conditions.
The {\tt ALGOPT} facility is added to provide a simple, user friendly, 
algebraic mode tool. Therefore -in contrast with the {\tt OPTIMIZE} command- 
it does not allow to direct output to a file; the default {\REDUCE} features
for dealing with output files can be applied.
\index{file management}
\index{{\tt IN} option}
\index{{\tt OUT} option}
\index{{\tt INAME} option}
\index{{\tt AGAIN} switch}
The previously given syntax requires some extensions:

$<$SCOPE\_application$>~::=$ $<${\tt OPTIMIZE} command$>~\mid~<${\tt ALGOPT} application$>$\\
$<${\tt OPTIMIZE} command$>~::=$\\
\hspace*{1cm}  {\tt OPTIMIZE} $<$object\_seq$>$ [{\tt IN} $<$file\_id\_seq$>$] [{\tt OUT} $<$file\_id$>$] [{\tt INAME} $<$cse\_prefix$>$] $\mid$\\
\hspace*{1cm}  {\tt OPTIMIZE} [$<$object\_seq$>$] {\tt IN} $<$file\_id\_seq$>$ [{\tt OUT} $<$file\_id$>$] [{\tt INAME} $<$cse\_prefix$>$]\\
$<${\tt ALGOPT} application$>~::=$\\
\hspace*{1cm}  {\tt ALGOPT}($<$a\_object\_list$>$[,$<$string\_id\_list$>$][,$<$cse\_prefix$>$]) $\mid$\\
\hspace*{1cm}  {\tt ALGOPT}([$<$a\_object\_list$>$,]$<$string\_id\_list$>$[,$<$cse\_prefix$>$])

The different variations for the object\_seq and
the a\_object\_list and the meaning of cse\_prefix are introduced
in the subsections ~\ref{SCOPE:optim} and ~\ref{SCOPE:algo}. 
The syntax of the file handling features is: 
\begin{center}
\begin{tabular}{lcl}
$<$file\_id\_seq$>$ & $::=$ & $<$file\_id$>$ [,$<$file\_id\_seq$>$]\\
$<$file\_id$>$ & $::=$ & $<$id$>$ $\mid$ $<$string\_id$>$\\
$<$string\_id\_list$>$ & $::=$ & $<$string\_id$>$ $\mid$ 
 \{$<$string\_id\_seq$>$\}\\
$<$string\_id\_seq$>$ & $::=$ & $<$string\_id$>$ [,$<$string\_id\_seq$>$]\\
$<$string\_id$>$ & $::=$ & {\tt "}$<$id$>${\tt "} $\mid$ 
{\tt "}$<$id$>.<$f\_extension$>${\tt "}
\end{tabular}
\end{center}

The differences in input-file management are introduced for practical reasons.
As stated above, the {\tt ALGOPT} function can have up to three arguments.
To be able to distinguish the optional second argument from the first and the
last requires file-names to be  given in the form of strings. The
{\tt OPTIMIZE} command follows the ordinary {\REDUCE} rules for file names.

File management can be used as a tool for input partioning.  If $m>1$ then
$N^m>\sum_{i=1}^k {n^k}_i$ for positive integers $N$ and $n_i$ , such that
$N=\sum_{i=1}^k n_i$. In view of the time-complexity of the
optimization algorithm, it may be worth the effort to partition
SCOPE input of size $N$ in $k$ partitions, of sizes $n_i,~i=1,...,k$. We can
start optimizing the contents of file fi.1, containing the initial $n_1$-sized
piece of code, and store the result of this operation in file fo.1. 
Consecutive steps provide an optimization of the combined contents of the 
files fo.i and fi.(i+1), i=1,..., k-1. 
During this iterative process, or during variations 
of this strategy, it is better not to perform a finishing touch. The switch
{\tt AGAIN}, which is normally {\tt OFF}, can be used, when set {\tt ON}, to 
avoid this. The switch serves an additional purpose. When switched {\tt ON} 
storage of partly optimized code in a file will include all relevant 
information, needed to restore the required status of system generated 
sub-expression names.

We illustrate SCOPE's file management facilities with example.

\example\label{ex:5.1}
\index{SCOPE ! example}

We assume to have three files, called f1, f2 and f3. Each file contains only
one assignment. We simply show different variations of the use of these files.
\index{{\tt INPUTC} switch}
\index{{\tt IN} option}
With {\tt ON INPUTC} the contents of the files is made visible.
{\small
\begin{verbatim}
ON INPUTC$

OPTIMIZE IN f1,f2,f3 INAME s;
 

                                 2
                 2        (x + y)              8        2      2
        2*(sin(x)  - cos(e        ) + 3*cos(x)) *(x + y)  + 4*y  + 4*y
e1 := ----------------------------------------------------------------
                                  3*x + 2*y

                                2
                2        (x + y)              2        3
e2 := (4*(sin(x)  - cos(e        ) + 2*cos(x)) *(x + y)

              2                   2
        + (4*x  - 4*y) - 6*x)/(8*x  + 3*y - 2*x)

                         2
                  (x + y)                       2           2
       4*sin(cos(e        )) + sin(x + y) + (4*x  - x + 2*y)
e3 := --------------------------------------------------------
                      3*y + f(x,g( - cos(x)))

s3 := sin(x)
s20 := x + y
s6 := s20*s20
           s6
s4 := cos(e  )
s8 := cos(x)
s31 := s3*s3 - s4
s2 := s31 + 3*s8
s44 := s2*s2
s43 := s44*s44
s36 := 4*y
s34 := 2*y
s10 := s34 + 3*x
       s36 + s36*y + 2*s6*s43*s43
e1 := ----------------------------
                  s10
s13 := s31 + 2*s8
s33 := 4*x*x
s30 := s33 - x
s35 := 3*y
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
       s33 - 2*s10 + 4*s6*s20*s13*s13
e2 := --------------------------------
                s35 + 2*s30
s21 := s34 + s30
       4*sin(s4) + sin(s20) + s21*s21
e3 := --------------------------------
            s35 + f(x,g( - s8))

\end{verbatim}}

We repeat the same process. However, this time we apply input partitioning.
The switch {\tt AGAIN} is turned {\tt ON}. Output is redirected to the
output file {\tt fo.1} in an {\tt OFF NAT} fashion and ended with the required
{\tt ;end;} closure, thus made ready for re-use during a next step. 
The default mode of operation is {\tt OFF AGAIN} and {\tt ON NAT}. If the
switch {\tt NAT} is turned {\tt OFF} file output is automatically ended
by {\tt ;end;}.
\index{{\tt AGAIN} switch}
\index{{\tt NAT} switch}

Due to the {\tt ON INPUTC} effect we can also observe that the identifiers
{\tt gsym} and {\tt cses} are apparently used to store relevant information
about cse names.

{\small
\begin{verbatim}
ON AGAIN,INPUTC$

OPTIMIZE IN f1 OUT "fo.1" INAME s$


                                2
                2        (x + y)              8        2      2
       2*(sin(x)  - cos(e        ) + 3*cos(x)) *(x + y)  + 4*y  + 4*y
e1 := ----------------------------------------------------------------
                                 3*x + 2*y


OPTIMIZE IN "fo.1",f2 OUT "fo.2" INAME t$

gsym := g0001
cses := s6
             2
s6 := (x + y)
                2                          2        s6  8
       4*y + 4*y  + 2*s6*(3*cos(x) + sin(x)  - cos(e  ))
e1 := ----------------------------------------------------
                           3*x + 2*y
                                2
                2        (x + y)              2        3
e2 := (4*(sin(x)  - cos(e        ) + 2*cos(x)) *(x + y)

              2                   2
        + (4*x  - 4*y) - 6*x)/(8*x  + 3*y - 2*x)

OFF AGAIN$

ALGOPT({"fo.2","f3"},u);

gsym := g0002

cses := t23 + t11 + t26 + t7 + t17 + t19

t19 := x + y

          2
t17 := t19

t7 := cos(x)

             2        t17
t26 := sin(x)  - cos(e   )

t11 := 3*x + 2*y

                2                 8
       4*y + 4*y  + 2*(t26 + 3*t7) *t17
e1 := ----------------------------------
                     t11

        2
t23 := x

                                         2
       4*t23 - 2*t11 + 4*t19*(t26 + 2*t7) *t17
e2 := -----------------------------------------
                  8*t23 - 2*x + 3*y

                         2
                  (x + y)                       2           2
       4*sin(cos(e        )) + sin(x + y) + (4*x  - x + 2*y)
e3 := --------------------------------------------------------
                      3*y + f(x,g( - cos(x)))


*** f declared operator 

*** g declared operator 

{u23=x + y,

        2
 u20=u23 ,

 t7=cos(x),

 u5=sin(x),

         u20
 u6=cos(e   ),

\end{verbatim}}
\newpage
{\small
\begin{verbatim}
       2
 t26=u5  - u6,

 u33=2*y,

 t11=u33 + 3*x,

 u10=t26 + 3*t7,

        2
 u46=u10 ,

        2
 u45=u46 ,

 u35=4*y,

              2
     2*u20*u45  + u35*y + u35
 e1=--------------------------,
               t11

      2
 t23=x ,

 u13=t26 + 2*t7,

 u36=4*t23,

 u31=u36 - x,

 u34=3*y,

                     2
      - 2*t11 + 4*u13 *u20*u23 + u36
 e2=---------------------------------,
               2*u31 + u34

 u24=u31 + u33,

                               2
     sin(u23) + 4*sin(u6) + u24
 e3=-----------------------------}
         f(x,g( - t7)) + u34
\end{verbatim}}
\noindent
Observe that the initial characters of the sub-expression names indicate
their moment of generation. We used {\tt f} and {\tt g} as operators. 
Therefore, a warning was produced ahead of the {\tt ALGOPT} output.
Since an {\tt OPTIMIZE} command produces output as a side-effect these warnings
were not given earlier.
{\small
\begin{flushright}
$\Box$
\end{flushright}}
\newpage
\section{Generation of Declarations}\label{SCOPE:decl}

GENTRAN's {\tt DECLARE} statement can be used as an optional extension of the
{\tt OPTIMIZE} command, and as ilustrated in example~\ref{ex:6.1}. The syntax 
of such an extension is in accordance with the GENTRAN rules:
\index{GENTRAN ! {\tt DECLARE} statement}
\index{SCOPE ! {\tt DECLARE} facility}
\index{{\tt DECLARE} option}
\index{{\tt IN} option}
\index{{\tt OUT} option}
\index{{\tt INAME} option}
\index{{\tt IMPLICIT} type}
\index{{\tt integer} type}
\index{{\tt real} type}
\index{{\tt real*8} type}
\index{{\tt complex} type}
\index{{\tt complex*16} type}
\index{SCOPE function ! {\tt OPTLANG}}
\index{SCOPE target language ! {\tt fortran77}}
\index{SCOPE target language ! {\tt fortran90}}
\index{SCOPE target language ! {\tt f90}}
\index{SCOPE target language ! {\tt c}}
\index{SCOPE target language ! {\tt pascal}}
\index{SCOPE target language ! {\tt ratfor}}
\index{SCOPE target language ! {\tt nil}}

$<${\tt OPTIMIZE} command$>~::=$\\
 \hspace*{1cm} {\tt OPTIMIZE} $<$object\_seq$>$ [{\tt IN} $<$file\_id\_seq$>$] 
 [{\tt OUT} $<$file\_id$>$]\\ 
 \hspace*{3cm} [{\tt INAME} $<$cse\_prefix$>$] 
  [{\tt DECLARE} $<$declaration\_group$>$] $\mid$\\
 \hspace*{1cm} {\tt OPTIMIZE} [$<$object\_seq$>$] {\tt IN} $<$file\_id\_seq$>$ 
 [{\tt OUT} $<$file\_id$>$]\\
 \hspace*{3cm} [{\tt INAME} $<$cse\_prefix$>$] 
 [{\tt DECLARE} $<$declaration\_group$>$]\\

The syntax of the declaration\_group is:
\begin{center}
\begin{tabular}{lcl}
$<$declaration\_group$>$ & $::=$ & $<$declaration$>~\mid~\ll~<$declaration\_list$>~\gg$\\
$<$declaration\_list$>$ & $::=$ & $<$declaration$>$[$;<$declaration\_list$>$]\\
$<$declaration$>$ & $::=$ & $<$range\_list$>:$ {\tt IMPLICIT} $<$type$>~\mid$
 $<$id\_list$>:<$type$>$\\
$<$range\_list$>$& $::=$ & $<$range$>$[,$<$range\_list$>$]\\
$<$range$>$ & $::=$ & $<$id$>~\mid~<$id$>-<$id$>$\\
$<$id\_list$>$ & $::=$ & $<$id$>$[,$<$id\_list$>$]\\
$<$type$>$ & $::=$ & {\tt integer} $\mid$ {\tt real} $\mid$ {\tt complex} $\mid$ {\tt real*8} $\mid$ {\tt complex*16}
\end{tabular}
\end{center}

The symbol table features of GENTRAN are used. During the subtask
R (see subsection ~\ref{SCOPE:bird}) of an {\tt OPTIMIZE} command evaluation, 
all typing information is installed in the symbol table. Once optimization
is ready all relevant information for completing the declarations ought to
be known, i.e. the contents of the symbol table and the result of the
optimization operations, collected in prefix form in a list, 
called {\tt prefixlist}. This {\tt prefixlist} is employed do decide which not yet typed identifiers and system selected cse names have to be entered in the
symbol table. We make use of earlier provided information, delivered via the
{\tt DECLARE} option, (sub)expression structure and the normal hierarchy in data
types. The strategy to achieve this form of dynamic typing is based on 
chapter 6 of ~\cite{Aho:86}.
Once the table is completed a list of declarations is produced and precedes the
other SCOPE output. SCOPE output is by default given in {\REDUCE} notation.
Therefore such lists of declarations are also given in {\REDUCE} text.
Incomplete initial typing information can lead to overtyping after 
optimization, such as {\tt complex} in stead of {\tt real}, for instance. 
It can therefore lead to erroneous results and even to an error message. 
A safe procedure is to
use the {\tt DECLARE} option of the {\tt OPTIMIZE} command for typing
all identifiers, occuring in the input set ${\rm E}_0$
\index{dynamic typing}

Alternative output can be obtained via an application of the function 
{\tt OPTLANG}. This function accepts one argument from the set \{{\tt fortran},
{\tt c}, {\tt ratfor}, {\tt pascal}\footnote{The {\tt pascal} module of
GENTRAN is not error free. Especially the template file features do not
function correctly.}, {\tt f90}, {\tt nil}\}.
The {\tt fortran}(77) choice can also be made by turning {\tt ON} the 
switch {\tt FORT}. The {\tt nil} option is necessary if one wants to
switch back to the usual {\REDUCE} output. 
not yet generally available. The output modules of GENTRAN are used for 
producing formatted code in the user selected target language. The
{\tt f90} option, for the production of {\tt fortran90} code, 
is not yet provided by the standard GENTRAN version ~\cite{Borst:94}.

Especially the above given syntax rules for typing require some additional 
explanation:
\begin{itemize}
\item The corresponding types in Fortran are {\tt integer}, {\tt real},
{\tt complex}, {\tt double precision} and {\tt complex*16}.
\item The GENTRAN switch {\tt DOUBLE} is automatically turned {\tt ON},
when a type {\tt real*8} or  type {\tt complex*16}  is introduced in
a {\tt DECLARE} option. The same mode of operation is introduced when 
floating point numbers appear in SCOPE input. Fixed floats do not produce 
this side effect.
\item When generating {\tt fortran} code we have to be aware of a possibly 
existing statement length limitation. If one is afraid that a declaration statement 
will become 
too long, for instance due to a huge number, dynamically added cse-names, 
it may be better to use {\tt IMPLICIT} typing.
\item C neither supports {\tt IMPLICIT} types nor has the 
types {\tt complex} and {\tt complex*16}. The remaining types are denoted
by {\tt int}, {\tt float} and {\tt double}, respectively.
\item Array and/or matrix definitions are also considered to be id's in
 id\_list's in declarations. 
However, we have to be aware of the instantaneous replacement of array-
and/or matrix entries, when  expressions are simplified. Therefore, we have to
use operators, functioning as array and/or matrix names in code we want to
optimize. We return to this question in the sections ~\ref{SCOPE:dda} and
 ~\ref{SCOPE:gopt}.
\end{itemize}
\index{{\tt ROUNDED} switch}
\index{{\tt DOUBLE} switch} 
When the {\tt ON/OFF AGAIN} strategy is applied we have to be aware of the
above outlined declaration strategy. The last {\tt OPTIMIZE} command,
executed directly after choosing {\tt OFF AGAIN}, has to be extended 
with the {\tt DECLARE} option. 

Array and/or matrix names only occur in literally parsed information. In all
other situations we have to make use of {\REDUCE} {\tt operators}. Normally,
function applications inside SCOPE input are instantaneously replaced by
newly selected cse names after putting them in the function table.
Usually array and/or matrix entries are considered to be function applications.
However, when due to a {\tt DECLARE} option array and/or matrix names
are known via the contents of the symbol table, such entries are 
substituted back before SCOPE produces output.

\index{{\tt IMPLICIT} type}
\index{{\tt integer} type}
\index{{\tt real} type}
\index{{\tt real*8} type}
\index{{\tt complex} type}
\index{{\tt double precision} type}
\index{{\tt int} type}
\index{{\tt float} type}
\index{{\tt double} type}
\index{{\tt DOUBLE} switch}
\index{{\tt AGAIN} switch}
\index{SCOPE function ! {\tt OPTLANG}}
\example\label{ex:6.1}
\index{SCOPE ! example}

A simple {\tt OPTIMIZE} command, extended with a {\tt DECLARE} option, is
executed for the various output options of GENTRAN, including the {\tt f90}
alternative.
{\small
\begin{verbatim}
OPTLANG fortran$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

      INTEGER B(5),I,S10,S9
      REAL A(4,4),X(4),Y(5)
      S10=I+1
      S9=I-1
      X(S10)=A(S10,S9)+B(I)
      Y(S9)=A(S9,S10)-B(i)

OPTLANG ratfor$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

integer b(5),i,s10,s9
real a(4,4),x(4),y(5)
{
    s10=i+1
    s9=i-1
    x(s10)=a(s10,s9)+b(i)
    y(s9)=a(s9,s10)-b(i)
}

OPTLANG c$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

int b[6],i,s10,s9;
float a[5][5],x[5],y[6];
{
    s10=i+1;
    s9=i-1;
    x[s10]=a[s10][s9]+b[i];
    y[s9]=a[s9][s10]-b[i];
}

OPTLANG pascal$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

var
    s9,s10,i: integer;
    b: array[0..5] of integer;
    y: array[0..5] of real;
    x: array[0..4] of real;
    a: array[0..4,0..4] of real;
begin
    s10:=i+1;
    s9:=i-1;
    x[s10]:=a[s10,s9]+b[i];
    y[s9]:=a[s9,s10]-b[i]
end;

OPTLANG nil$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

integer b(5),i,s10,s9
real a(4,4),x(4),y(5)

s10 := i + 1
s9 := i - 1
x(s10) := a(s10,s9) + b(i)
y(s9) := a(s9,s10) - b(i)

OPTLANG fortran$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real*8; b(5):integer>>$

      INTEGER B(5),I,S10,S9
      DOUBLE PRECISION A(4,4),X(4),Y(5)
      S10=I+1
      S9=I-1
      X(S10)=A(S10,S9)+B(I)
      Y(S9)=A(S9,S10)-B(I)

OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << x(4),y(5):real; b(5):complex>>$

***** Type error:
real x(4),y(5)
complex b(5)
(integer all) s9
integer s5,i
real := complex(all)
***** Wrong typing 
Cont? (Y or N)
\end{verbatim}}

We can restart \REDUCE and rerun the example with
the {\tt Fortran90} version of SCOPE. It results in:
\index{{\tt scope90}}
{\small
\begin{verbatim}
LOAD_PACKAGE scope90$
OPTLANG f90$
OPTIMIZE x(i+1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)
INAME s
DECLARE << a(4,4),x(4),y(5):real; b(5):integer>>$

      REAL,DIMENSION(4,4)::A
      INTEGER,DIMENSION(5)::B
      INTEGER::I,S10,S9
      REAL,DIMENSION(4)::x
      REAL,DIMENSION(5)::y
      S10=I+1
      S9=I-1
      X(S10)=A(S10,S9)+B(I)
      Y(S9)=A(S9,S10)-B(I)
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

\subsection{Coefficient Arithmetic and Precision Handling}\label{SCOPE:caph}

{\REDUCE} knows a variety of coefficient domains, as presented in 
subsection 9.11 of the {REDUCE} 3.6 manual ~\cite{Hearn:95}, entitled
 {\em Polynomial Coefficient Arithmetic}. As stated in subsection~\ref{SCOPE:optim} 
SCOPE supports integer and real coefficients.  By turning {\tt ON} the switch 
 {\tt ROUNDED} we introduce float arithmetic for coefficients.
The operator {\tt PRECISION} can be applied to change the default,
machine dependent {\em precision}. Internally, {\REDUCE} uses floating point 
numbers up to the precison supported by the underlying machine hardware, and
so-called {\em bigfloats} for higher precision. The internal precision is two decimals 
greater than the exernal precision to guard against roundoff inaccuracies.
Rounded numbers are normally printed to the specified precision. If the user
wishes to print such numbers with less precision, the printing
precision can be set by the command {\tt PRINT\_PRECISION}. If a case
arises where use of the machine arithmetic leads to problems, a user can force
{\REDUCE} to use the bigfloat representation by turning {\tt ON} the switch
{\tt ROUNDBF}, which is normally {\tt OFF}. GENTRAN, and thus SCOPE as well,
support bigfloat notation. However the precision is a responsibility
of the user. A possibility is to use the {\tt PRINT\_PRECISION} command, both
for algebraic mode output and for output in a selected target language, 
like {\tt fortran77}. SCOPE uses the given precision for selecting cse's. 
Although complex arithmetic is not supported in SCOPE, a simple alternative
is provided. When using float arithmetic in {\REDUCE} the protected name
{\tt I} can be used to denote $\sqrt -1$. If the {\tt I} is included in a
declaration list as an identifier of type {\tt complex}({\tt !*}), its assumed value is 
automatically put ahead of the resulting optimized code.
We illustrate the different possibilities in example ~\ref{ex:6.2}. Comment
is  included.
\index{{\tt ROUNDBF} switch}
\index{REDUCE function ! {\tt PRECISION}}
\index{REDUCE function ! {\tt PRINT\_PRECISION}}
\index{bigfloats}
\index{coefficient arithmetic}
\index{machine precision}

\example\label{ex:6.2}
\index{SCOPE ! example}
{\small
\begin{verbatim}
OPTLANG fortran$
ON ROUNDED, DOUBLE$

% ---
% We start with precision 6. The returned value is the internal
% precision supported by the underlying machine hardware.
% ---

PRECISION 6;

12

OPTIMIZE x1:= 2        *a + 10         * b,
         x2:= 2.00001  *a + 10         * b,
         x3:= 2        *a + 10.00001   * b,
         x4:= 6        *a + 30         * b,
         x5:= 2.0000001*a + 10.000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,X1,X2,X3,X4,X5
      S1=10*B
      X1=S1+2*A
      X2=S1+2.00001D0*A
      X3=X1
      X4=3*X1
      X5=X1

% ---
% Explanation: X1 is a cse of X3, X4 and X5, but not of X2, because
% the coefficient 2.00001 is given in 6 decimal digits. 
% Increase in precision will show this.
% ---

PRECISION 7$

OPTIMIZE x1:= 2        *a + 10         * b,
         x2:= 2.00001  *a + 10         * b,
         x3:= 2        *a + 10.00001   * b,
         x4:= 6        *a + 30         * b,
         x5:= 2.0000001*a + 10.000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.00001D0*A
      X3=S1+1.000001D1*B
      X4=3*X1
      X5=X1

PRECISION 8$

OPTIMIZE x1:= 2        *a + 10         * b,
         x2:= 2.00001  *a + 10         * b,
         x3:= 2        *a + 10.00001   * b,
         x4:= 6        *a + 30         * b,
         x5:= 2.0000001*a + 10.000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.00001D0*A
      X3=S1+1.000001D1*B
      X4=3*X1
      X5=2.0000001D0*A+1.0000001D1*B

% ---
% All rhs's were taken literally. Let us now increase precision and
% simplify the rhs's before optimization. It is in fact a repetition
% of the examples above, this time with a larger precision.
% ---

PRECISION 20$

OPTIMIZE x1:=:2                      *a + 10                       * b,
         x2:=:2.0000000000000000001  *a + 10                       * b,
         x3:=:2                      *a + 10.0000000000000000001   * b,
         x4:=:6                      *a + 30                       * b,
         x5:=:2.000000000000000000001*a + 10.000000000000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.0000000000000000001D0*A
      X3=S1+1.0D1*B
      X4=3*X1
      X5=1.0D0*X1

PRECISION 21$

OPTIMIZE x1:=:2                      *a + 10                       * b,
         x2:=:2.0000000000000000001  *a + 10                       * b,
         x3:=:2                      *a + 10.0000000000000000001   * b,
         x4:=:6                      *a + 30                       * b,
         x5:=:2.000000000000000000001*a + 10.000000000000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.0000000000000000001D0*A
      X3=S1+1.00000000000000000001D1*B
      X4=3*X1
      X5=2.0D0*A+1.0D1*B

PRECISION 22$

OPTIMIZE x1:=:2                      *a + 10                       * b,
         x2:=:2.0000000000000000001  *a + 10                       * b,
         x3:=:2                      *a + 10.0000000000000000001   * b,
         x4:=:6                      *a + 30                       * b,
         x5:=:2.000000000000000000001*a + 10.000000000000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.0000000000000000001D0*A
      X3=S1+1.00000000000000000001D1*B
      X4=3*X1
      X5=2.000000000000000000001D0*A+1.0D1*B

% ---
% However, we can observe some differences in both modes of operation, when
% selecting a precision around the precision supported by the undelying
% machine hardware. Then the switch ROUNDBF can better be turned ON.
% ---
\end{verbatim}}
\index{{\tt ROUNDBF} switch}
\index{{\tt complex} type}
{\small
\begin{verbatim}
OFF ROUNDBF$
PRECISION 12$

OPTIMIZE x1:= 2.00         *a + 10.00       * b,
         x2:= 2.00000000001*a + 10         * b,
         x3:= 2           *a + 10.000000001* b,
         x4:= 6           *a + 30         * b,
         x5:= 2.0000000000001*a + 10.0000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.00000000001D0*A
      X3=S1+1.0000000001D1*B
      X4=3*X1
      X5=X1


OPTIMIZE x1:=:2.00         *a + 10.00       * b,
         x2:=:2.00000000001*a + 10         * b,
         x3:=:2           *a + 10.000000001* b,
         x4:=:6           *a + 30         * b,
         x5:=:2.0000000000001*a + 10.0000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.0D0*A
      X3=S1+10.0D0*B
      X4=3*X1
      X5=X1

% ---
% Observe that simplification prior to optimization leads to internal
% roundings, which differ from the rounding used for literally taken
% coefficients. This difference disappeares with ON ROUNDBF.
% ---

ON ROUNDBF$

OPTIMIZE x1:= 2.00         *a + 10.00       * b,
         x2:= 2.00000000001*a + 10         * b,
         x3:= 2           *a + 10.000000001* b,
         x4:= 6           *a + 30         * b,
         x5:= 2.0000000000001*a + 10.0000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.00000000001D0*A
      X3=S1+1.0000000001D1*B
      X4=3*X1
      X5=X1

OPTIMIZE x1:=:2.00         *a + 10.00       * b,
         x2:=:2.00000000001*a + 10         * b,
         x3:=:2           *a + 10.000000001* b,
         x4:=:6           *a + 30         * b,
         x5:=:2.0000000000001*a + 10.0000000000001 * b
INAME s
DECLARE <>$

      DOUBLE PRECISION A,B,S1,S2,X1,X2,X3,X4,X5
      S1=2*A
      S2=10*B
      X1=S2+S1
      X2=S2+2.00000000001D0*A
      X3=S1+1.0000000001D1*B
      X4=3*X1
      X5=X1

% ---
% Complex arithmetic is not supported in SCOPE. However the Fortan equivalent
% of I, a protected name in REDUCE, is automatically created, ahead of the 
% optimized code, whenever I is included in the declaration as a type complex 
% or a type complex*16 identifier.
% ---

OPTIMIZE a:=b+c 
INAME s
DECLARE <>;

      COMPLEX*16 B,I,C,A
      I=(0.0D0, 1.0D0)
      A=B+C

OFF DOUBLE$

OPTIMIZE a:=b+c 
INAME s
DECLARE <>;

      COMPLEX B,I,C,A
      I=(0.0, 1.0)
      A=B+C
\end{verbatim}}
\begin{flushright}
$\Box$
\end{flushright}
\newpage
\section{Dealing with Data Dependencies}\label{SCOPE:dda}
\index{flow dependency}
\index{anti dependency}
\index{used identifiers}
\index{defined identifiers}
\index{dead code}
\index{data dependency analysis}

SCOPE is designed to optimize blocks $B$ of straight line code, i.e.
sequences of $n$ assignment statements $S_i$ of the 
form ${\lambda}_i := {\rho}_i$, where $i = 1, \cdots , n$. If an identifier 
occurs in ${\lambda}_i$, it is said to be {\em defined} in $S_i$. All 
identifiers occuring in ${\rho}_i$ are said to be {\em used} in $S_i$. 
The set DEF($S_i$)
is formed by the identifiers defining $S_i$, usually only one.
The set USE($S_i$) is formed by the identifiers, which are used in $S_i$.
The relation DEF($S_i$) $\in$ USE($S_j$), for $1 \leq i < j \leq n$, is 
called  a {\em flow dependency} and denoted by $S_i \rightarrow S_j$. The
relation DEF($S_i$) $\in$ USE($S_j$), for $1 \leq j \leq i \leq n$ is called
an {\em anti dependency} and denoted by $S_i$ \ad $S_j$. The {\em set of inputs}
of $B$, denoted by $I(B)$, consists of identifiers, which are used
in $B$, before being defined, if defined at all. The {\em set of outputs} of
$B$, denoted by $O(B)$, consists of the set of all last definitions of
identifiers, occuring in $B$. So a block of straight line code can be 
introduced as a triple $B = \{ S, I, O \}$, where $S$ stands for the sequence
$S_1 ; S_2 ; \cdots ; S_{n-1} ; S_n$, and where $I$ and $O$ define the
inputs and outputs, respectively. When optimizing source code defined by $B$,
i.e. the sequence $S$, the intention is to mechanically produce an equivalent,
but computationally less complex sequence, preserving the relation between
inputs and outputs. Due to anti dependencies, i.e. redefinitions of the rules
for computing identifier values or stepwise computing such values, 
 $\mid O(B) \mid < n$ is possible.  But that in turn implies that some of the
used identifiers, although being literally identical, represent different
values. Therefore, a mechanical search for cse's can only be maintained if 
these critical identifiers are adequately renamed internally before the 
optimization process itself is started. As long as the relation between
$I(B)$ and $O(B)$ is preserved it is even allowed to partly maintain these
additional names, when presenting the results of an optimization operation.
Furthermore it is worth noting that {\em dead code} can be left out, when
ever occuring. Such code can be introduced through redundant assignments.
The SCOPE features for dealing with data dependencies are illustrated, using 
the following artificial piece of code:
\begin{center}
\[ \begin{array}{lclcl}
 S_1 & : & a_{1,x+1} & := & g + h . r^f \\
 S_2 & : & b_{y+1} & := & a_{1, 2.x+1} .(g + h . r^f) \\
 S_3 & : & c1 & := &  h.r. a_{2,1+x}/g \\
 S_4 & : & c2 & := & c1 . a_{1,x+1} + sin(d) \\
 S_5 & : & a_{1,x+1} & := & c1 + 2 \\
 S_6 & : & d & := & b_{y+1} . a_{1,x+1} \\
 S_7 & : & a_{1,1+2.x} & := & a_{1,x+1} . b_{y+1} . c/(d . g^2)  \\
 S_8 & : & b_{y+1} & := & a_{1.x+1} + b_{y+1} + sin(d) \\
 S_9 & : & a_{1,x+1} & := & b_{y+1} . c + h/(g  + sin(d))\\
 S_{10} & : & d & := & k . e + d . (a_{1,1+x} + 3) \\
 S_{11} & : & e & := &  d . (a_{1,1+x} + 3) + sin(d) \\
 S_{12} & : & f & := &  d . (a_{1,1+x} + 3) + sin(d) \\
 S_{13} & : & g & := &  d . (3 + a_{1,1+x}) + f \\
\end{array}\]
\end{center}

The different flow and anti dependencies can be vizualized in the following way:
\begin{center}
\begin{tabular}{lcl}
 $x$ & : & $\{ {\lambda}_1 , {\rho}_2 , {\rho}_3 , {\rho}_4 , {\lambda}_5 ,
 {\rho}_6 , {\lambda}_7 , {\rho}_7 , {\rho}_8 ,{\lambda}_9 , {\rho}_{10} ,
 {\rho}_{11} , {\rho}_{12} , {\rho}_{13} \}$ \\
 $y$ & : & $\{ {\lambda}_2 , {\rho}_6 , {\rho}_7 , {\lambda}_8 , {\rho}_8 ,
 {\rho}_9 \}$ 
\end{tabular}
\end{center}

The identifiers, occuring in the piece of code given above, can be defined,
can be used or can play both roles. Identifiers, used in one or more of the
$\lambda_i , i = 1 \cdots n$ figure in subscript expressions. The set 
notation \{ $\cdots$ \} is used to explicitly describe USE sets. Since
all DEF sets consist of one element only, we omitted the set notation for the
DEF sets. This provides a simple tool to distinguish flow and anti dependencies:

\begin{center}
\begin{tabular}{lcl}
 $a_{1,x+1}$ & : & ${\lambda}_1 \rightarrow \{ {\rho}_3 , {\rho}_4 \}$ \ad 
 ${\lambda}_5 \rightarrow \{ {\rho}_6 , {\rho}_7 , {\rho}_8 \}$ \ad 
 ${\lambda}_9 \rightarrow \{ {\rho}_{10} , {\rho}_{11} , {\rho}_{12} , 
 {\rho}_{13} \}$ \\
 $g$ & : & $\{ {\rho}_1 , {\rho}_2 , {\rho}_3 , {\rho}_7 , {\rho}_9 \}$ \ad
 ${\lambda}_{13}$ \\
 $h$ & : & $\{ {\rho}_1 , {\rho}_2 , {\rho}_3 , {\rho}_9 \}$ \\
 $r$ & : & $\{ {\rho}_1 , {\rho}_2 , {\rho}_3 \}$ \\
 $f$ & : & $\{ {\rho}_1 , {\rho}_2 \}$ \ad 
 ${\lambda}_{12} \rightarrow {\rho}_{13}$ \\
 $b_{y+1}$ & : & ${\lambda}_2 \rightarrow \{ {\rho}_6 , {\rho}_7 , {\rho}_8 \}$  \ad ${\lambda}_8 \rightarrow \{ {\rho}_9 \}$ \\
 $a_{1,2.x+1}$ & : & $\{ {\rho}_2 \}$ \ad ${\lambda}_7$ \\
 $c1$ & : & ${\lambda}_3 \rightarrow \{ {\rho}_4 , {\rho}_5 \}$ \\
 $a_{2,1+x}$ & : & $\{ {\rho}_3 \}$ \\
 $c2$ & : & ${\lambda}_4$ \\
 $d$ & : & $\{ {\rho}_4 \}$ \ad ${\lambda}_6 \rightarrow \{ {\rho}_7 , 
 {\rho}_8 , {\rho}_9 , {\rho}_{10} \}$ \ad ${\lambda}_{10} \rightarrow 
  \{ {\rho}_{11} , {\rho}_{12} , {\rho}_{13} \}$ \\
 $c$ & : & $\{ {\rho}_7 , {\rho}_9 \}$ \\
 $k$ & : & $\{ {\rho}_{10} \}$ \\
 $e$ & : & $\{ {\rho}_{10} \}$ \ad ${\lambda}_{12}$ 
\end{tabular}
\end{center}

We observe that
\[ I(B) = \{ x, y, g, h, r, f, a_{1,2.x+1} , a_{2,1+x} , d, c, k, e \} ,\]
\[ O(B) = \{ a_{1,x+1} , g, f, b_{y+1} , a_{1,2.x+1} , c1 , c2 , d, e\}\]
and thus, that
\[ I(B) \cap O(B) \neq \emptyset .\]
The identifiers $a_{1,1+x}$ and $d$ are redefined twice and the identifier 
$b_{y+1}$ once. Only the input occurrences and the last
output definitions need to be preserved.
\index{output definition preservation}
\index{{\tt VECTORC} switch}
\index{SCOPE function ! {\tt VECTORCODE}}

We also observe that some of the identifiers are subscripted. In our example
the subscript expressions are constructed with input identifiers only. More
general situations are conceivable. The set of subscript expressions contains 
cse's. Since our optimization strategy is based on an all level approach 
expressions, like $1+x$ and $y+1$ are certainly discovered as cse's.

An {\tt OPTIMIZE} command can be extended with a {\tt DECLARE} option, 
indicating that both $a$ and $b$ are array names. Their subscript expressions
are optimized. In addition, the $a$ and $b$ entries are considered to be
array entries, and not as function applications. The latter will happen when
the {\tt DECLARE} option is omitted. Vector architectures make often use of
machine specific optimizing compilers. Therefore it may be better not to 
optimize the subset of subscript expressions. We implemented some facilities 
to take such machine specific limitations into account.  When turning {\tt ON}
the switch {\tt VECTORC} the finishing touch is omitted and subscript 
expressions are not optimized. The function
\index{{\tt VECTORC} switch}

\hspace*{1cm} {\tt VECTORCODE} $<$a\_or\_m\_id\_seq$>$

can be used to operate more selectively. The a\_or\_m\_id\_seq consists of
one or more array and/or matrix names, separated by comma's. Only the
actual parameters of {\tt VECTORCODE} are assumed to be  names of arrays. So
only their subscript expressions are disregarded during an optimization
process. We can undo the effect of the {\tt VECTORCODE} setting with a
command of the form:

\hspace*{1cm} {\tt VCLEAR} $<$a\_or\_m\_id\_(sub)seq$>$
\index{SCOPE function ! {\tt VCLEAR}}

The actual parameters are supposed to be taken from the sequence of actual
parameters of its counterpart, the function {\tt VECTORCODE}.

The different settings are now illustrated in:

\example\label{ex:7.1}
\index{SCOPE ! example}

The above given block of code $B = \{ S, I, O \}$ is optimized in five
different situations. To start with we hand it over to SCOPE, using an
{\tt OPTIMIZE} command, without using the {\tt DECLARE} option.
We observe, looking at the results, that some renaming of non significant 
identifier
definitions have been performed. The first occurrence of $a_{1,1+x}$ is replaced
by {\tt s34}, the second by  {\tt s4}. The first occurrence of $b_{y+1}$ is
replaced by {\tt s3}, but the occurrences of $d$, a scalar identifier,
are maintained.  

Especially the role of the scalar $d$ is quite interesting. The first definition
of $d$ is given in $S_6$ In $S_7$ $d$ is used twice: explicitly in the 
denominator and in a hidden way in the numerator as well. The optimized 
version of $S_7$ shows a factor $d/d$. The reason is that $d$ locally replaces
an internally created cse name, substituted for ${\rho}_6$ and for part of the 
numerator of ${\rho}_7$. Like illustrated in example~\ref{ex:3.2.7} a second
SCOPE application can further simplify ${\rho}_7$. The scalar $d$ is also used
as argument of the $sin$-function in $S_4 , S_8 , S_9 , S_{11}$ and $S_{12}$. 
The $d$-values in $S_4$, in $\{ S_8 , S_9 \}$ and in $\{ S_{11} , S_{12} \}$ 
are all different, due to the redefinitions in $S_6$ and in $S_{10}$. Therefore 
we recognize two different cse's, containing $sin(d)$: {\tt s24} and {\tt e}.
The role of $a_{1,x+1}$ is of course very similar, albeit less transparant,
due to the renamings.

The second run showes that adding a {\tt DECLARE}
option does not influence the form of the output in this particular case. 
Besides the production of declarations, the result of both runs is identical.
All relevant input and output names are preserved in both runs.
{\small
\begin{verbatim}
OPTIMIZE a(1,x+1)  := g+h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c+h/(g + sin(d)),
         d         := k*e+d*(a(1,1+x)+3),
         e         := d*(a(1,1+x)+3) + sin(d),
         f         := d*(3+a(1,x+1)) + sin(d),
         g         := d*(3+a(1,x+1))+f
INAME s$


s0 := x + 1
        f
s34 := r *h + g
s2 := 1 + y
s6 := 2*x + 1
s3 := s34*a(1,s6)
               r*h
c1 := a(2,s0)*-----
                g
c2 := sin(d) + s34*c1
s4 := sqrt(c1)*c1*c1
d := s4*s3
             d*c
a(1,s6) := -------
            g*g*d
s24 := sin(d)
b(s2) := s4 + s3 + s24
               h
a(1,s0) := --------- + b(s2)*c
            g + s24
s29 := 3 + a(1,s0)
d := s29*d + e*k
s33 := s29*d
e := s33 + sin(d)
f := e
g := s33 + f

ON FORT$

OPTIMIZE a(1,x+1)  := g+h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c+h/(g + sin(d)),
         d         := k*e+d*(a(1,1+x)+3),
         e         := d*(a(1,1+x)+3) + sin(d),
         f         := d*(3+a(1,x+1)) + sin(d),
         g         := d*(3+a(1,x+1))+f
INAME s
DECLARE <>$

      INTEGER X,Y,S0,S2,S6
      DOUBLE PRECISION C,H,R,S34,S3,C1,C2,S4,S24,B(7),A(5,5),S29,K,D,S33
     . ,E,F,g
      S0=X+1
      S34=R**F*H+G
      S2=1+Y
      S6=2*X+1
      S3=S34*A(1,S6)
      C1=A(2,S0)*((R*H)/G)
      C2=DSIN(D)+S34*C1
      S4=DSQRT(C1)*C1*C1
      D=S4*S3
      A(1,S6)=(D*C)/(G*G*D)
      S24=DSIN(D)
      B(S2)=S4+S3+S24
      A(1,S0)=H/(G+S24)+B(S2)*C
      S29=3+A(1,S0)
      D=S29*D+DEXP(1.0D0)*K
      S33=S29*D
      E=S33+DSIN(D)
      F=DEXP(1.0D0)
      G=S33+F

OFF FORT$
\end{verbatim}}

Observe the differences in the {\tt f} and {\tt F} assignments. When generating
{\tt fortran77} code all right hand side occurrences of {\tt e} are 
automatically considered as appearances of the base of the natural logarithm
and are translated accordingly.

\index{{\tt VECTORC} switch}
\index{SCOPE function ! {\tt VECTORCODE}}
\index{SCOPE function ! {\tt VCLEAR}}
The third run is influenced by turning {\tt ON} the switch {\tt VECTORC}.
We observe that all array references are substituted back, without having
replaced repeatedly occuring identical subscript expressions by internally 
selected cse names.

The fourth and the last run are governed by the functions {\tt VECTORCODE} and 
{\tt VCLEAR}, after having turned {\tt OFF} the switch {\tt VECTORC}.
{\small
\begin{verbatim}
ON VECTORC$

OPTIMIZE a(1,x+1)  := g+h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c+h/(g + sin(d)),
         d         := k*e+d*(a(1,1+x)+3),
         e         := d*(a(1,1+x)+3) + sin(d),
         f         := d*(3+a(1,x+1)) + sin(d),
         g         := d*(3+a(1,x+1))+f
INAME s$

               f
a(1,x + 1) := r *h + g
b(y + 1) := a(1,x + 1)*a(1,2*x + 1)
                  r*h
c1 := a(2,x + 1)*-----
                   g
c2 := sin(d) + a(1,x + 1)*c1
                         2
a(1,x + 1) := sqrt(c1)*c1
d := a(1,x + 1)*b(y + 1)
\end{verbatim}}
\newpage
{\small
\begin{verbatim}
                 d*c
a(1,1 + 2*x) := ------
                  2
                 g *d
s20 := sin(d)
b(y + 1) := a(1,x + 1) + b(y + 1) + s20
                  h
a(1,x + 1) := --------- + b(y + 1)*c
               g + s20
s25 := a(1,x + 1) + 3
d := s25*d + e*k
s28 := s25*d
e := s28 + sin(d)
f := e
g := s28 + f

OFF VECTORC$
VECTORCODE a,b$

OPTIMIZE a(1,x+1)  := g+h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c+h/(g + sin(d)),
         d         := k*e+d*(a(1,1+x)+3),
         e         := d*(a(1,1+x)+3) + sin(d),
         f         := d*(3+a(1,x+1)) + sin(d),
         g         := d*(3+a(1,x+1))+f
INAME s$

               f
a(1,x + 1) := r *h + g
b(y + 1) := a(1,x + 1)*a(1,2*x + 1)
                  r*h
c1 := a(2,x + 1)*-----
                   g
c2 := sin(d) + a(1,x + 1)*c1
a(1,x + 1) := sqrt(c1)*c1*c1
d := a(1,x + 1)*b(y + 1)
                  d*c
a(1,1 + 2*x) := -------
                 g*g*d
s22 := sin(d)
b(y + 1) := a(1,x + 1) + b(y + 1) + s22
                  h
a(1,x + 1) := --------- + b(y + 1)*c
               g + s22
s27 := 3 + a(1,x + 1)
d := s27*d + e*k
s30 := s27*d
e := s30 + sin(d)
f := e
g := s30 + f


VCLEAR b$

OPTIMIZE a(1,x+1)  := g+h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c+h/(g + sin(d)),
         d         := k*e+d*(a(1,1+x)+3),
         e         := d*(a(1,1+x)+3) + sin(d),
         f         := d*(3+a(1,x+1)) + sin(d),
         g         := d*(3+a(1,x+1))+f
INAME s$

               f
a(1,x + 1) := r *h + g
s1 := y + 1
s2 := a(1,x + 1)*a(1,1 + 2*x)
                  r*h
c1 := a(2,1 + x)*-----
                   g
c2 := sin(d) + a(1,x + 1)*c1
a(1,x + 1) := sqrt(c1)*c1*c1
d := a(1,x + 1)*s2
                  d*c
a(1,1 + 2*x) := -------
                 g*g*d
s23 := sin(d)
b(s1) := a(1,x + 1) + s2 + s23
                  h
a(1,x + 1) := --------- + b(s1)*c
               g + s23
s28 := 3 + a(1,x + 1)
d := s28*d + e*k
s31 := s28*d
e := s31 + sin(d)
f := e
g := s31 + f
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\newpage
\section{A Combined Use of GENTRAN and SCOPE 1.5}\label{SCOPE:gopt}
\index{{\tt GENTRANOPT} switch}

As already stated in subsection~\ref{SCOPE:inter} each GENTRAN command is 
evaluated separately, implying that the symbol table, required 
for the production of declarations, is fresh at the beginning of a GENTRAN 
command evaluation. Turning {\tt ON} the switch {\tt GENTRANOPT} leads to
the optimization of the arithmetic code, defined in  the GENTRAN command,
obeying the new {\tt GENTRANOPT} regime. In addition, we can observe that 
each separate GENTRAN command can produce its own declarations.
\index{{\tt GENTRANOPT} switch}

To increase flexibility we introduced facilities for making declarations,
associated with a group of GENTRAN commands and for the optimization of
the arithmetic in such a group as well.
We implemented two function pairs of parameter-less functions:

\hspace{1cm} ({\tt DELAYDECS}, {\tt MAKEDECS})
\index{SCOPE function ! {\tt DELAYDECS}}
\index{SCOPE function ! {\tt MAKEDECS}}

and 

\hspace{1cm} ({\tt DELAYOPTS}, {\tt MAKEOPTS}).
\index{SCOPE function ! {\tt DELAYOPTS}}
\index{SCOPE function ! {\tt MAKEOPTS}}

Both pairs function as "brackets" around groups of statements. The {\tt OPTS}
pair can be used (repeatedly) inside a {\tt DECS} pair. Both pairs achieve
an alterned GENTRAN mode of operation. All GENTRAN productions between such
a pair are collected in an internal format, say {\tt if\_list}. 
The {\tt DELAY...} functions initialize the modified mode of operation. 
The {\tt MAKE...} functions restore the previous mode of operation in 
combination with the production either of declarations, associated with the
contents of {\tt if\_list}, or of an optimized representation  of the
contents of {\tt if\_list}.

Example~\ref{ex:8.1} serves to introduce a variety of approaches to code 
generation, based on the use of these pairs of brackets and of the 
switch {\tt GENTRANOPT}. We illustrate a more realistic use in 
example~\ref{ex:8.2}: generation of optimized fortran77 code for the 
computation of the entries of the inverse of a symmetric (3,3) matrix. 
It is a continuation of example~\ref{ex:3.1.8} in 
subsection~\ref{SCOPE:optim} and example~\ref{ex:3.2.5} in 
subsection ~\ref{SCOPE:algo}. It was also presented 
in ~\cite{Gates:85}, albeit in a slightly different form.

\example\label{ex:8.1}
\index{SCOPE ! example}

The output of combined GENTRAN and SCOPE operations is by default given 
in fortran77 notation. We illustrate the different possibilities in the
form of small pieces of code.
\begin{itemize}
\item The pair ({\tt DELAYDECS}, {\tt MAKEDECS}) encloses four GENTRAN commands.
The first is needed to initialize the symbol table. The literal translation in
internal format of the last three commands is stored in the {\tt if\_list}.
The application of {\tt MAKEDECS} leads to the restoration of the default
GENTRAN regime, applied to the {\tt if\_list} and leading to the result,
presented in the form of fortran77 code.
{\small
\begin{verbatim}
DELAYDECS$

  GENTRAN DECLARE <>$
  GENTRAN a:=b+c$
  GENTRAN d:=b+c$
  GENTRAN <>$

MAKEDECS$

      REAL A,B,C,D,Q,W
      A=B+C
      D=B+C
      Q=B+C
      W=B+C
\end{verbatim}}
\item We repeat the previous commands, but execute them in a slightly different
setting by turning {\tt ON} the switch {\tt GENTRANOPT}. This time the
arithmetical rules in each of the three last GENTRAN commands are optimized 
separately.  This is illustrated by the form of the output. The last piece of 
code contains the cse {\tt B+C}, which is presented under the name {\tt Q} 
in the fortran77 output.
\index{{\tt GENTRANOPT} switch}
\index{SCOPE function ! {\tt DELAYDECS}}
\index{SCOPE function ! {\tt MAKEDECS}}
\index{SCOPE function ! {\tt DELAYOPTS}}
\index{SCOPE function ! {\tt MAKEOPTS}}
{\small
\begin{verbatim}
ON GENTRANOPT$

DELAYDECS$

  GENTRAN DECLARE <>$
  GENTRAN a:=b+c$
  GENTRAN d:=b+c$
  GENTRAN <>$

MAKEDECS$

      REAL B,C,A,D,Q,W
      A=B+C
      D=B+C
      Q=B+C
      W=Q

OFF GENTRANOPT$
\end{verbatim}}
\item We can improve the optimization strategy by using the function pair
({\tt DELAYOPTS}, {\tt MAKEOPTS}) in stead of the
pair ({\tt DELAYDECS}, {\tt MAKEDECS}). All blockwise combinable arithmetic
is collected. These blocks of straight line code are optimized as separate
input sets ${\rm E_{in}}$, when activating {\tt MAKEOPTS}.
{\small
\begin{verbatim}
DELAYOPTS$

  GENTRAN a:=b+c$
  GENTRAN d:=b+c$
  GENTRAN <>$

MAKEOPTS$

      A=B+C
      D=A
      Q=A
      W=A
\end{verbatim}}
\item We can furhter improve the optimization strategy by using the 
function pair ({\tt DELAYOPTS}, {\tt MAKEOPTS}) inside the 
pair ({\tt DELAYDECS}, {\tt MAKEDECS}). All blockwise combinable arithmetic
is collected. These blocks of straight line code are optimized as separate
input sets ${\rm E_{in}}$, when activating {\tt MAKEOPTS}. But this time the
results are added in internal format to the {\tt if\_list} version, 
being maintained, as to obey the {\tt DELAYDECS} regime.
{\small
\begin{verbatim}
DELAYDECS$

  GENTRAN DECLARE <>$

  DELAYOPTS$

    GENTRAN a:=b+c$
    GENTRAN d:=b+c$
    GENTRAN <>$

  MAKEOPTS$

MAKEDECS$

      REAL B,C,A,D,Q,W
      A=B+C
      D=A
      Q=A
      W=A
\end{verbatim}}
\item A slightly more realistic example suggests how easily optimized code
for sets of matrix entries can be obtained. We use two identical matrices
{\tt a} and {\tt d}. The latter is not introduced at the {\REDUCE} level,
but simply used inside a GENTRAN command. The entries of {\tt a} are
initialized inside a double for-loop. After each initialization a GENTRAN
command is applied, using the special assignment operator {\tt ::=:} for
correctly combining entry names and entry values. The REDUCE algebraic mode 
assignments are again used, when identifying the matrix {\tt d} with the 
matrix {\tt a}, applying the special assignment operator {\tt :=:} in a 
separate GENTRAN command. The latter command is internally expanded into
separate GENTRAN commands for each entry assignment. By using the pair
({\tt DELAYOPTS}, {\tt MAKEOPTS}) one block of straigt line code is
constructed and optimized. It consists of two sets of assignments, one 
for the entries of the matrix {\tt a} and another for the entries of the 
matrix {\tt d}. The presented output shows that both matrices are indeed 
identical.
{\small
\begin{verbatim}
MATRIX a(4,4);

DELAYDECS$

  GENTRAN DECLARE <>$

  DELAYOPTS$

    FOR i:=1:4 DO FOR j:=1:4 DO << a(i,j):=(i+j)*(b+c)+i*b+j*c;
                                   GENTRAN a(i,j)::=:a(i,j)>>$
    GENTRAN d:=:a$

  MAKEOPTS$

MAKEDECS$

      REAL B,C,G56,G54,G57,G55,A(4,4),D(4,4)
      A(1,1)=3.0*(B+C)
      G56=5.0*C
      A(1,2)=G56+4.0*B
      G54=5.0*B
      G57=7.0*C
      A(1,3)=G57+G54
      A(1,4)=6.0*B+9.0*C
      A(2,1)=G54+4.0*c
      A(2,2)=2.0*A(1,1)
      G55=7.0*B
      A(2,3)=G55+8.0*C
      A(2,4)=2.0*A(1,2)
      A(3,1)=G56+G55
      A(3,2)=G57+8.0*B
      A(3,3)=3.0*A(1,1)
      A(3,4)=10.0*B+11.0*C
      A(4,1)=9.0*B+6.0*C
      A(4,2)=2.0*A(2,1)
      A(4,3)=11.0*B+10.0*C
      A(4,4)=4.0*A(1,1)
      D(1,1)=A(1,1)
      D(1,2)=A(1,2)
      D(1,3)=A(1,3)
      D(1,4)=A(1,4)
      D(2,1)=A(2,1)
      D(2,2)=A(2,2)
      D(2,3)=A(2,3)
      D(2,4)=A(2,4)
      D(3,1)=A(3,1)
      D(3,2)=A(3,2)
      D(3,3)=A(3,3)
      D(3,4)=A(3,4)
      D(4,1)=A(4,1)
      D(4,2)=A(4,2)
      D(4,3)=A(4,3)
      D(4,4)=A(4,4)
\end{verbatim}}
\item Finally, and again only for illustrative purposes the fifth piece of
code is again executed in an almost identical manner. We omit the declarations
and replace the instruction {\tt GENTRAN d:=:a}\verb+$+ by the command
{\tt GENTRAN a:=:a}\verb+$+. Hence the matrix a is simply redefined. As
stated in section~\ref{SCOPE:dda} redundant assignments --- producing dead
code, for instance by copying previous assignments --- are automatically 
removed. as part of the optimization process. Therefore the optimized
entry values of the matrix {\tt a} are presented only once.
{\small
\begin{verbatim}
DELAYOPTS$

  FOR i:=1:4 DO FOR j:=1:4 DO << a(i,j):=(i+j)*(b+c)+i*b+j*c;
                                 GENTRAN a(i,j)::=:a(i,j)>>$
  GENTRAN a:=:a$

MAKEOPTS$

      A(1,1)=3.0*(B+C)
      G111=5.0*C
      A(1,2)=G111+4.0*B
      G109=5.0*B
      G112=7.0*C
      A(1,3)=G112+G109
      A(1,4)=6.0*B+9.0*C
      A(2,1)=G109+4.0*C
      A(2,2)=2.0*A(1,1)
      G110=7.0*B
      A(2,3)=G110+8.0*C
      A(2,4)=2.0*A(1,2)
      A(3,1)=G111+G110
      A(3,2)=G112+8.0*B
      A(3,3)=3.0*A(1,1)
      A(3,4)=10.0*B+11.0*C
      A(4,1)=9.0*B+6.0*C
      A(4,2)=2.0*A(2,1)
      A(4,3)=11.0*B+10.0*C
      A(4,4)=4.0*A(1,1)
\end{verbatim}}
\end{itemize}
{\small
\begin{flushright}
$\Box$
\end{flushright}}

\example\label{ex:8.2}
\index{SCOPE ! example}

Let us now again look at the symmetric (3,3) matrix {\tt m}, already used in
the examples ~\ref{ex:3.1.8} and ~\ref{ex:3.2.5}. For completeness we begin
by showing the entry values. We generate optimized fortran77 code
for the inverse {\tt mnv} of {\tt m} and store it in a file, 
named {\tt inverse.code}, using the function pair ({\tt GENTRANOUT}, 
{\tt GENTRANSHUT}). Inside this pair we apply the pair ({\tt DELAYDECS},
{\tt MAKEDECS}). The latter pair encloses in turn the pair ({\tt DELAYOPTS},
{\tt MAKEOPTS}). Inside these innermost brackets four different sections of 
code can be distinguished. The first section consists of three {\tt LITERAL} 
commands, for inserting comment in the target code. The second is formed by
a double for-loop.  Essential are the applications of the GENTRAN functions
{\tt tempvar} and {\tt markvar} for assigning internal names to matrix entry
values. These applications are very similar to the approach, chosen in
example~\ref{ex:3.2.5}. The third section is again formed by {\tt LITERAL}
commands and the last orders the creation of the entries of the inverse
matrix {\tt mnv}. Before introducing the file {\tt inverse.code} we selected
{\tt S0} as initial cse name, using the function {\tt INAME}, and 
turned {\tt ON} the switches {\tt ACINFO} and {\tt DOUBLE}.
\index{GENTRAN function ! {\tt GENTRANOUT}}
\index{GENTRAN function ! {\tt GENTRANSHUT}}
\index{{\tt ACINFO} switch}
\index{{\tt DOUBLE} switch}
\index{SCOPE function ! {\tt INAME}}
\index{GENTRAN's {\tt DECLARE} statement}
\index{GENTRAN's {\tt LITERAL} statement}
\index{REDUCE function ! {\tt gensym}}

Observe that directly after the {\tt MAKEOPTS} instruction two sets of tables
are printed with information about the arithmetic complexity of the two blocks 
of code, which are generated in the second and the last section.  We 
activated {\tt ACINFO} to show this effect.  The tables are printed as 
a side effect. The output itself is directed to the file {\tt inverse.code}.
Looking at the contents of this file, given below, shows three different 
kinds of internally generated names. A number of {\tt S}-names is created 
during the optimization of the first block of straight line code, created with
the second section. In this piece of code we also notice {\tt T}-names,
generated by {\tt tempvar} applications. The intial {\tt T} character is the
default internal GENTRAN selection for {(temporarily needed) names.
And finally {\tt G}-names, introduced by
applications of {\tt gensym}, during the second optimization operation for
reducing the arithmetic complexity of the entries of {\tt mnv}. Because the
code splitting is internally performed, the second SCOPE application 
is missing its {\tt INAME} initialisation, thus leading to the application of
{\tt gensym}. Observe as well that {\tt INAME} can be used as a separate 
facility as well.  
{\small
\begin{verbatim}
OFF EXP$

MATRIX m(3,3),mnv(3,3)$
IN "matrix.M"$

m(1,1) :=  - ((j30y - j30z + 9*m30*p )*sin(q3)

                                         2                      2
               - 18*cos(q2)*cos(q3)*m30*p  - j10y - j30y - m10*p

                         2
               - 18*m30*p )

                                              2         2
m(2,1) := m(1,2) :=  - ((j30y - j30z + 9*m30*p )*sin(q3)

                             2                 2
    - 9*cos(q2)*cos(q3)*m30*p  - j30y - 9*m30*p )

                                              2
m(3,1) := m(1,3) :=  - 9*sin(q2)*sin(q3)*m30*p

                                    2         2                 2
m(2,2) :=  - ((j30y - j30z + 9*m30*p )*sin(q3)  - j30y - 9*m30*p )

m(3,2) := m(2,3) := 0

                        2
m(3,3) := j30x + 9*m30*p

INAME s0$
ON ACINFO,DOUBLE$

GENTRANOUT "inverse.code"$

DELAYDECS$

  GENTRAN DECLARE <>$
  DELAYOPTS$

    GENTRAN LITERAL "C",tab!*,"  ",cr!*$
    GENTRAN LITERAL "C",tab!*," -- Computation of relevant M-entries --",cr!*$
    GENTRAN LITERAL "C",tab!*,"  ",cr!*$

    FOR j:=1:3 DO FOR k:=j:3 DO
     IF m(j,k) NEQ 0 THEN
      << s:=tempvar('real); markvar s;
         GENTRAN eval(s):=:m(j,k);
         m(j,k):=m(k,j):=s
      >>$
\end{verbatim}}
\index{GENTRAN function ! {\tt markvar}}
\index{GENTRAN function ! {\tt tempvar}}
{\small
\begin{verbatim}
    GENTRAN LITERAL "C",tab!*,"  ",cr!*$
    GENTRAN LITERAL "C",tab!*," -- Computation of the inverse of M --",cr!*$
    GENTRAN LITERAL "C",tab!*,"  ",cr!*$

    GENTRAN mnv:=:m^(-1)$

  MAKEOPTS$

Number of operations in the input is: 

Number of (+/-) operations      : 17
Number of unary - operations    : 4
Number of * operations          : 30
Number of integer ^ operations  : 14
Number of / operations          : 0
Number of function applications : 9


Number of operations after optimization is:

Number of (+/-) operations      : 11
Number of unary - operations    : 1
Number of * operations          : 12
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 4


Number of operations in the input is: 

Number of (+/-) operations      : 20
Number of unary - operations    : 4
Number of * operations          : 45
Number of integer ^ operations  : 20
Number of / operations          : 9
Number of function applications : 0


Number of operations after optimization is:

Number of (+/-) operations      : 4
Number of unary - operations    : 2
Number of * operations          : 11
Number of integer ^ operations  : 0
Number of / operations          : 4
Number of function applications : 0

MAKEDECS$

GENTRANSHUT "inverse.code"$
\end{verbatim}}

The contents of the file {\tt inverse.code} is:
{\small
\begin{verbatim}
      DOUBLE PRECISION P,M30,J30Y,J30Z,Q3,M10,Q2,J10Y,J30X,S0,S7,S5,S4,
     . S13,S11,T0,T3,T1,T2,T4,G153,G152,G151,G147,G155,G156,MNV(3,3)
C       
C      -- Computation of relevant M-entries --
C       
      S0=DSIN(Q3)
      S7=P*P
      S5=S7*M30
      S4=S5*DCOS(Q3)*DCOS(Q2)
      S13=9.0D0*S5
      S11=(S13+J30Y-J30Z)*S0*S0
      T0=J30Y+J10Y+18.0D0*(S4+S5)+S7*M10-S11
      T3=S13+J30Y-S11
      T1=T3+9.0D0*S4
      T2=-(S13*DSIN(Q2)*S0)
      T4=S13+J30X
C       
C      -- Computation of the inverse of M --
C       
      G153=T2*T2
      G152=T1*T1
      G151=T0*T4
      G147=G151*T3-(G153*T3)-(G152*T4)
      G155=T4/G147
      MNV(1,1)=G155*T3
      MNV(1,2)=-(G155*T1)
      G156=T2/G147
      MNV(1,3)=-(G156*T3)
      MNV(2,1)=MNV(1,2)
      MNV(2,2)=(G151-G153)/G147
      MNV(2,3)=G156*T1
      MNV(3,1)=MNV(1,3)
      MNV(3,2)=MNV(2,3)
      MNV(3,3)=(T0*T3-G152)/G147
\end{verbatim}}

Let us now repeat the generation process in a slightly different setting.
We leave out the comment generating instructions, thus creating only one
block of straight line code to be optimized. We choose for an {\tt S}-name
selection based on {\tt tempvar} applications and for {\tt T}-names for cse's.
This time the default use of {\tt gensym} is not necessary.

The contents' of both output files illustrate quotient optimization.
All denominators, being the determinant of the matrix {\tt m}, are identical.
The set of rational entries of {\tt MNV} contains the cse's {\tt G155 (T45)}
and {\tt G156 (T46)}.
\index{GENTRAN identifier !{\tt TEMPVARNAME*}}
\index{GENTRAN identifier !{\tt TEMPVARNUM*}}
\index{GENTRAN function ! {\tt GENTRANOUT}}
\index{SCOPE function ! {\tt INAME}}
{\small
\begin{verbatim}
TEMPVARNAME!*:='s$
TEMPVARNUM!*:=0$
INAME t0$

GENTRANOUT "inverse.code2"$

DELAYDECS$

  GENTRAN DECLARE <>$
  DELAYOPTS$

    FOR j:=1:3 DO FOR k:=j:3 DO
     IF m(j,k) NEQ 0 THEN
      << s:=tempvar('real); markvar(s);
         GENTRAN eval(s):=:m(j,k);
         m(j,k):=m(k,j):=s
      >>$

    GENTRAN mnv:=:m^(-1)$

  MAKEOPTS$

Number of operations in the input is: 

Number of (+/-) operations      : 37
Number of unary - operations    : 8
Number of * operations          : 75
Number of integer ^ operations  : 34
Number of / operations          : 9
Number of function applications : 9


Number of operations after optimization is:

Number of (+/-) operations      : 15
Number of unary - operations    : 3
Number of * operations          : 23
Number of integer ^ operations  : 0
Number of / operations          : 4
Number of function applications : 4

MAKEDECS$

GENTRANSHUT "inverse.code2"$
\end{verbatim}}

The contents of the file {\tt inverse.code2} is:
{\small
\begin{verbatim}
      DOUBLE PRECISION P,M30,J30Y,J30Z,Q3,M10,Q2,J10Y,J30X,T9,T40,T32,
     . T31,T49,T47,S0,S3,S1,S2,S4,T39,T38,T36,T30,T45,T46,MNV(3,3)
      T9=DSIN(Q3)
      T40=P*P
      T32=T40*M30
      T31=T32*DCOS(Q3)*DCOS(Q2)
      T49=9.0D0*T32
      T47=(T49+J30Y-J30Z)*T9*T9
      S0=J30Y+J10Y+18.0D0*(T31+T32)+T40*M10-T47
      S3=T49+J30Y-T47
      S1=S3+9.0D0*T31
      S2=-(T49*DSIN(Q2)*T9)
      S4=T49+J30X
      T39=S2*S2
      T38=S1*S1
      T36=S0*S4
      T30=T36*S3-(T39*S3)-(T38*S4)
      T45=S4/T30
      MNV(1,1)=T45*S3
      MNV(1,2)=-(T45*S1)
      T46=S2/T30
      MNV(1,3)=-(T46*S3)
      MNV(2,1)=MNV(1,2)
      MNV(2,2)=(T36-T39)/T30
      MNV(2,3)=T46*S1
      MNV(3,1)=MNV(1,3)
      MNV(3,2)=MNV(2,3)
      MNV(3,3)=(S0*S3-T38)/T30
\end{verbatim}}

A comparison between the arithmetic complexities given here and in example
~\ref{ex:3.2.5} shows that computing the entries of {\tt MNV}(=${\tt M}^{-1}$) 
instead of the value of the determinant of {\tt M}, only requires 2 
extra additions, 1 extra negation, 6 extra multilications and 4 extra 
divisions. 
{\small
\begin{flushright}
$\Box$
\end{flushright}}

Other examples of this combined use of GENTRAN and SCOPE can be found 
in ~\cite{vanHulzen:95,Ganzha:94}. The symbolic-numeric strategy discussed in
~\cite{Ganzha:94} also relies on the {\tt ALGOPT} facilities, which were 
introduced earlier. 
\newpage
\section{Symbolic Mode Use of SCOPE 1.5}~\label{SCOPE:symb}

Both the {\tt OPTIMIZE} command and the {\tt ALGOPT} function are transformed
into the same symbolic mode function, called {\tt SYMOPTIMIZE}. It is this
function, which governs the optimization process as a whole, delivering
the results of an optimization run as a side effect, for instance by making
it visible on a screen or by storing it in a file. Using {\tt SYMOPTIMIZE}
is straighforward, once the syntax for its five actual parameters is known.
If we set {\tt ON INTERN} a {\tt SYMOPTIMIZE} application will deliver a
list, containing the correctly ordered results of an optimization operation 
in the form of assignment statements in prefix form in Lisp notation. The thus
provided results can function as one of the five actual parameters for
{\tt SYMOPTIMIZE} as well. This simple feature helps avoiding file traffic
when stepwise optimizing code and as illustrated earlier in example~\ref{ex:5.1}
in section ~\ref{SCOPE:files}. Before illustrating that in example~\ref{ex:9.1}
we present the syntax of the actual parameters for {\tt SYMOPTIMIZE}:
\index{{\tt INTERN} switch}
\index{SCOPE function ! {\tt SYMOPTIMIZE}}

$<$SCOPE\_application$>~::=~\cdots~\mid$\\
\hspace*{1cm} {\tt SYMOPTIMIZE}($<$ssetq\_list$>,<$infile\_list$>,<$outfile\_name$>,<$cse\_prefix$>,\\
\hspace*{6cm} <$declaration\_list$>$)

\begin{center}
\begin{tabular}{lcl}
$<$ssetq\_list$>$ & $::=$ & ($<$ssetq\_seq$>$)\\
$<$ssetq\_seq$>$ & $::=$ & $<$ssetq\_stat$>~[<$ssetq\_seq$>]$\\
$<$ssetq\_stat$>$ & $::=$ & ({\tt setq} $<$lhs\_id$>~<$rhs$>)~\mid$
({\tt rsetq} $<$lhs\_id$>~<$rhs$>)~\mid$\\
 & & ({\tt lsetq} $<$lhs\_id$>~<$rhs$>)~\mid$
({\tt lrsetq} $<$lhs\_id$>~<$rhs$>)$\\
$<$lhs\_id$>$ & $::=$ & $<$id$>~\mid~<$subscripted\_id$>$\\
$<$subscripted\_id$>$ & $::=$ & $(<$id$>~<$s\_subscript\_seq$>)$\\
$<$s\_subscript\_seq$>$ & $::=$ & $<$s\_subscript$>[~<$s\_subscript\_seq$>$]\\
$<$s\_subscript$>$ & $::=$ & $<$integer$>~\mid~<$integer prefix\_expression$>$\\
$<$rhs$>$ & $::=$ & $<$prefix\_expression$>$\\
$<$infile\_list$>$ & $::=$ & $(<$infile\_seq$>)$\\
$<$infile\_seq$>$ & $::=$ & $<$infile\_name$>[~<$infile\_seq$>]$\\
$<$infile\_name$>$ & $::=$ & $<$string\_id$>$\\
$<$outfile\_name$>$ & $::=$ & $<$string\_id$>$\\
$<$declaration\_list$>$ & $::=$ & $(<$declaration\_seq$>)$\\
$<$declaration\_seq$>$ & $::=$ & $<$declaration$>~<$declaration\_seq$>$\\
$<$declaration$>$ & $::=$ & $(<$type$>~<$lhs\_id\_seq$>)$\\
$<$lhs\_id\_seq$>$ & $::=$ & $<$lhs\_id$>~<$lhs\_id\_seq$>$
\end{tabular}
\end{center}

The above given syntax requires some explanation:
\begin{itemize}
\item The presented ssetq syntax is incomplete. The prefix equivalent of 
any object, introduced in subsection~\ref{SCOPE:optim} and of any a\_object,
defined in subsection~\ref{SCOPE:algo}, is accepted as ssetq item. Such prefix
equivalents can be obtained quite easily by using the function {\tt show}:

\hspace*{1cm} {\tt SYMBOLIC PROCEDURE show u; prettyprint u}\verb+$+ \\
\hspace*{1cm} {\tt SYMBOLIC OPERATOR show}\verb+$+

The explicit presentation of a subset of the syntax rules for ssetq
is given to suggest that local simplification in symbolic mode can be brought 
in easily by using the assignment operators {\tt lsetq}, {\tt lrsetq} 
and {\tt rsetq}. The algebraic mode equivalent of these operators is
{\tt ::=}, {\tt ::=:} and {\tt :=:}, respectively. Their effect on
simplification is discussed in subsection~\ref{SCOPE:inter} and already 
shown in a number of examples. In addition it is worth noting that 
any (sub)expression
in a lhs\_id or a rhs may contain any number of calls to {\tt eval}. 
These calls lead to simplification of their arguments, prior to optimization.
Details about the use of {\tt eval} are presented in the 
GENTRAN manual~\cite{Gates:91}.
\item Since we operate in symbolic mode the last four formal parameters
have possibly to be replaced by quoted actual parameters. This is illustrated 
in example ~\ref{ex:9.1}.
\item  The infile\_seq consists of  file names in string notation. The contents'
of such input files may contain any form of infix input, obeying the syntax
rules for objects and/or a\_objects, as introduced in the subsections
 ~\ref{SCOPE:optim} and ~\ref{SCOPE:algo}, respectively.
\item The single output file name  outfile\_name ought to be given in string
notation as well. The outfile\_name  is properly closed. The default output
is REDUCE infix in an {\tt ON NAT} fashion. Alternatives are discussed above:
{\tt ON AGAIN} or {\tt OFF NAT}, both leading to re-readable output, or an 
application of {\tt OPTLANG} for a non {\tt nil} argument.
\item The declaration list presents declarations in prefix notation. The list
is used to initialize the symbol table prior to optimization. This 
information is used for dynamically typing  the result of an optimization
process. In addition it is used to determine wether subscripted names denote
array elements or a function call. The latter is replaced by a cse name in the
presented output, whereas the former is not.
\item  The five parameters of {\tt SYMOPTIMIZE} correspondent with optional
extensions of the {\tt OPTIMIZE} command. When part of these options remains
unused, {\tt nil} has to taken as value for the corresponding actual parameters.
\end{itemize}
\index{{\tt AGAIN} switch}
\index{{\tt INPUTC} switch}
\index{{\tt INTERN} switch}
\index{{\tt NAT} switch}
\index{SCOPE function ! {\tt OPTLANG}}
\index{GENTRAN function ! {\tt lsetq}}
\index{GENTRAN function ! {\tt lrsetq}}
\index{GENTRAN function ! {\tt rsetq}}

We illustrate the symbolic mode variant of the {\tt OPTIMIZE} command by
repeating example~\ref{ex:5.1} from section~\ref{SCOPE:files}, albeit in
a modified setting.

\example\label{ex:9.1}
\index{SCOPE ! example}

The script explains itself. 
{\small
\begin{verbatim}
LISP$
ON ACINFO,INPUTC,INTERN,AGAIN$

prettyprint(prefixlist:=SYMOPTIMIZE(nil,'("f1" "f2"),nil,'c,nil))$

                                2
                2        (x + y)              8        2      2
       2*(sin(x)  - cos(e        ) + 3*cos(x)) *(x + y)  + 4*y  + 4*y
e1 := ----------------------------------------------------------------
                                 3*x + 2*y

                                2
                2        (x + y)              2        3
e2 := (4*(sin(x)  - cos(e        ) + 2*cos(x)) *(x + y)

              2                   2
        + (4*x  - 4*y) - 6*x)/(8*x  + 3*y - 2*x)

Number of operations in the input is: 

Number of (+/-) operations      : 16
Number of unary - operations    : 0
Number of * operations          : 16
Number of integer ^ operations  : 11
Number of / operations          : 2
Number of function applications : 8


Number of operations after optimization is:

Number of (+/-) operations      : 16
Number of unary - operations    : 0
Number of * operations          : 16
Number of integer ^ operations  : 6
Number of / operations          : 2
Number of function applications : 4

((setq gsym c23)
   (setq cses (plus c18 c10 c20 c8 c6 c14))
   (setq c14 (plus x y))
   (setq c6 (expt c14 2))
   (setq c8 (cos x))
   (setq c20 (plus (expt (sin x) 2) (minus (cos (expt e c6)))) )
   (setq c10 (plus (times 3 x) (times 2 y)))
   (setq e1
      (quotient
         (plus
            (times 4 y)
            (times 4 (expt y 2))
            (times 2 c6 (expt (plus c20 (times 3 c8)) 8)))
         c10))
   (setq c18 (expt x 2))
   (setq e2
      (quotient
         (plus
            (times 4 c18)
            (minus (times 2 c10))
            (times 4 c6 c14 (expt (plus c20 (times 2 c8)) 2)))
         (plus (times 8 c18) (minus (times 2 x)) (times 3 y)))) )
\end{verbatim}}
\index{{\tt DOUBLE} switch}
\index{{\tt FORT} switch}
{\small
\begin{verbatim}
OFF INTERN,AGAIN,PERIOD$
ON DOUBLE,FORT$

SYMOPTIMIZE(prefixlist,'("f3"), '"f7",'d,'((real e1 e2 e3 x y)))$

gsym := c23

cses := c18 + c10 + c20 + c8 + c6 + c14

c14 := x + y

         2
c6 := c14

c8 := cos(x)

             2        c6
c20 := sin(x)  - cos(e  )

c10 := 3*x + 2*y

                2                    8
       4*y + 4*y  + 2*c6*(c20 + 3*c8)
e1 := ---------------------------------
                     c10

        2
c18 := x

                                            2
       4*c18 - 2*c10 + 4*c6*c14*(c20 + 2*c8)
e2 := ----------------------------------------
                 8*c18 - 2*x + 3*y

                         2
                  (x + y)                       2           2
       4*sin(cos(e        )) + sin(x + y) + (4*x  - x + 2*y)
e3 := --------------------------------------------------------
                      3*y + f(x,g( - cos(x)))

Number of operations in the input is: 

Number of (+/-) operations      : 23
Number of unary - operations    : 1
Number of * operations          : 20
Number of integer ^ operations  : 9
Number of / operations          : 3
Number of function applications : 11


Number of operations after optimization is:

Number of (+/-) operations      : 15
Number of unary - operations    : 1
Number of * operations          : 24
Number of integer ^ operations  : 0
Number of / operations          : 3
Number of function applications : 8
\end{verbatim}}

The contents of the output file {\tt f7} is:
{\small
\begin{verbatim}
      DOUBLE PRECISION X,Y,D19,D16,C8,D1,D2,C20,D29,C10,D6,D38,D37,D31,
     . E1,C18,D9,D32,D27,D30,E2,D20,E3
      D19=X+Y
      D16=D19*D19
      C8=DCOS(X)
      D1=DSIN(X)
      D2=DCOS(DEXP(D16))
      C20=D1*D1-D2
      D29=2*Y
      C10=D29+3*X
      D6=C20+3*C8
      D38=D6*D6
      D37=D38*D38
      D31=4*Y
      E1=(D31+D31*Y+2.0D0*D16*D37*D37)/C10
      C18=X*X
      D9=C20+2*C8
      D32=4*C18
      D27=D32-X
      D30=3*Y
      E2=(D32-(2.0D0*C10)+4.0D0*D9*D9*D19*D16)/(D30+2.0D0*D27)
      D20=D29+D27
      E3=(4.0D0*DSIN(D2)+DSIN(D19)+D20*D20)/(D30+F(X,G(-C8)))
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}

We especially designed these symbolic mode facilities for our joint 
research with Delft Hy\-draulics concerning code generation for an 
incompressible Navier-Stokes problem ~\cite{Goldman:95}.

\index{{\tt PREFIX} switch}
\index{{\tt INTERN} switch}
A final remark: The {\tt ON PREFIX} mode of operation, in both 
algebraic and symbolic mode causes the results of a SCOPE 
application to be presented in the form of an association  list,  
called {\tt Prefixlist}.  The pairs are formed by lhs\_id's and 
rhs values in prefixform. This lisp S-expression can be used to 
create an alternative version of the optimization results, 
in whatever target language the user prefers to choose. 

\example\label{ex:9.2}
\index{SCOPE ! example}

We show the {\tt ON PREFIX} effect. When switching to symbolic mode
(command 5) we can again obtain the output, assigned as value to the global
identifer {\tt prefixlist}. The {\tt ON PREFIX} facility allows storage
in a file for later use. When working in symbolic mode it is of course
possible to apply {\tt ON INTERN} in stead and to remove the {\tt setq} 
extensions from the provided output value, if desired.
{\small
\begin{verbatim}
REDUCE 3.6, 15-Jul-95 ...

1: LOAD_PACKAGE nscope$

2: OPTIMIZE a:=b+c*sin(x), d:=c*sin(x)*cos(y);

g7 := sin(x)*c
a := g7 + b
d := g7*cos(y)

3: ON PREFIX$

4: input 2;

Prefixlist:=
((g3 times (sin x) c) (a plus g3 b) (d times g3 (cos y)))

5: LISP$

6: prettyprint prefixlist$
((g3 times (sin x) c) (a plus g3 b) (d times g3 (cos y)))

7: caar prefixlist;

g3

7: cdar prefixlist;

(times (sin x) c)

9: BYE;
\end{verbatim}
\begin{flushright}
$\Box$
\end{flushright}}
\newpage
\section{ A Syntax Summary of SCOPE 1.5}~\label{SCOPE:syntax}

{\REDUCE} is extended with some commands, designed to apply the facilities
offered by SCOPE in a flexible way. The syntactical rules, defining how to
activate SCOPE in both algebraic and symbolic mode, are given in subsection
~\ref{SCOPE:srules}. A short overview of the set of additional functions is   
given in subsection~\ref{SCOPE:arules} and the relevant switches are again
presented in subsection~\ref{SCOPE:switches}.

\subsection{SCOPE's Toplevel Commands}~\label{SCOPE:srules}

We assume the syntax of {\tt id}'s, {\tt integer}'s and the like to be already 
known. Hence we do not present an exhaustive description of the rules.\\
\index{SCOPE function ! {\tt OPTIMIZE}}
\index{SCOPE function ! {\tt ALGOPT}}
\index{SCOPE function ! {\tt SYMOPTIMIZE}}
\index{REDUCE function ! {\tt GSTRUCTR}}
\index{REDUCE function ! {\tt GHORNER}}

$<${\tt REDUCE}\_command$>~::=~ \cdots ~ \mid~<${\tt SCOPE}\_application$>$\\
\hspace*{1cm} $<${\tt GSTRUCTR}\_application$>~\mid$
$<${\tt GHORNER}\_application$>~\mid$\\
$<${\tt SCOPE}\_application$>~::=~<${\tt OPTIMIZE} command$>~\mid$\\
\hspace*{1cm} 
$<${\tt ALGOPT} application$>~\mid$
$<${\tt SYMOPTIMIZE} application$>$\\

$<${\tt OPTIMIZE} command$>~::=$\\
\hspace*{1cm}{\tt OPTIMIZE} $<$object\_seq$>$ [{\tt IN} $<$file\_id\_seq$>$]
 [{\tt OUT} $<$file\_id$>$]\\
\hspace*{3cm}[{\tt INAME} $<$cse\_prefix$>$]
[{\tt DECLARE} $<$declaration\_group$>$] $\mid$\\
\hspace*{1cm}{\tt OPTIMIZE} [$<$object\_seq$>$] {\tt IN} $<$file\_id\_seq$>$
 [{\tt OUT} $<$file\_id$>$]\\ 
\hspace*{3cm}[{\tt INAME} $<$cse\_prefix$>$]
[{\tt DECLARE} $<$declaration\_group$>$]\\

$<${\tt ALGOPT} application$>~::=$\\
\hspace*{1cm}{\tt ALGOPT}($<$a\_object\_list$>$[,$<$string\_id\_list$>$][,$<$cse\_prefix$>$]) $\mid$\\
\hspace*{1cm}{\tt ALGOPT}([$<$a\_object\_list$>$,]$<$string\_id\_list$>$[,$<$cse\_prefix$>$])\\

$<${\tt SYMOPTIMIZE} application$>~::=$\\
\hspace*{0.3cm} {\tt SYMOPTIMIZE}($<$ssetq\_list$>,<$infile\_list$>,<$outfile\_name$>,<$cse\_prefix$>$,\\
\hspace*{2.3cm} $<$declaration\_list$>$)\\

\begin{tabular}{lcl}
$<${\tt GSTRUCTR}\_application$>$ & $::=$ & 
 {\tt GSTRUCTR} $<$stat\_group$>$ [{\tt NAME} $<$cse\_prefix$>$]\\ 
$<$stat\_group$>$ & $::=$ & $\ll~<$stat\_list$>~\gg$\\
$<$stat\_list$>$ & $::=$ & $<$gstat$>$ [; $<$stat\_list$>$]\\
$<$gstat$>$ & $::=$ & $<$name$>~:=~<$ expression$>~\mid~<$matrix\_id$>$\\
$<${\tt GHORHER}\_application$>$ & $::=$ &
 {\tt GHORNER} $<$stat\_group$>$ [{\tt VORDER} $<$id\_seq$>$]\\
$<$id\_seq$>$ & $::=$ & $<$id$>$[,$<$id\_seq$>$]\\
\end{tabular}
\index{SCOPE ! {\tt DECLARE} facility}
\index{{\tt DECLARE} option}
\index{{\tt IN} option}
\index{{\tt OUT} option}
\index{{\tt INAME} option}

\newpage
\index{GENTRAN function ! {\tt lsetq}}
\index{GENTRAN function ! {\tt lrsetq}}
\index{GENTRAN function ! {\tt rsetq}}
\index{SCOPE function ! {\tt ALGSTRUCTR}}
\index{SCOPE function ! {\tt ALGHORNER}}
\index{{\tt IMPLICIT} type}
\index{{\tt integer} type}
\index{{\tt real} type}
\index{{\tt real*8} type}
\index{{\tt complex} type}
\index{{\tt complex*16} type}
\begin{center}
\begin{tabular}{lcl}
 $<$object\_seq$>$ & $::=$ & $<$object$>$[,$<$object\_seq$>$]\\
 $<$object$>$ & $::=$ & $<$stat$>~\mid~<$alglist$>~\mid~<$alglist\_production$>$ \\
 $<$stat$>$ & $::=$ & $<$name$>~<$assignment operator$>~<$expression$>$\\
 $<$assignment operator$>$ & $::=$ & $:=~\mid~::=~\mid~::=:~\mid~:=:$\\
 $<$alglist$>$ & $::=$ & \{$<$eq\_seq$>$\}\\
 $<$eq\_seq$>$ & $::=$ & $<$name$>~=~<$expression$>$[,$<$eq\_seq$>$]\\
 $<$alglist\_production$>$ & $::=$ & $<$name$>~\mid~<$function\_application$>$\\
 $<$name$>$ & $::=$ & $<$id$>~\mid~<$id$>(<$a\_subscript\_seq$>)$\\
 $<$a\_subscript\_seq$>$ & $::=$ & $<$a\_subscript$>$[,$<$a\_subscript\_seq$>$]\\
 $<$a\_subscript$>$ & $::=$ & $<$integer$>~\mid~<$integer infix\_expression$>$\\
 $<$cse\_prefix$>$ & $::=$ & $<$id$>$\\
 & & $\ \ $\\
$<$a\_object\_list$>$ & $::=$ & $<$a\_object$>~\mid$ \{$<$a\_object$>$[,$<$a\_object\_seq$>$]\}\\
$<$a\_object\_seq$>$ & $::=$ & $<$a\_object$>$[,$<$a\_object\_seq$>$]\\
$<$a\_object$>$ & $::=$ & $<$id$>~\mid~<$alglist$>~\mid~<$alglist\_production$>~\mid$\\
& & \{$<$a\_object$>$\}\\
 & & $\ \ $\\
$<$function\_application$>$ & $::=$ & 
{\tt ALGSTRUCTR} ($<$arg\_list$>$ [, $<$cse\_prefix$>$ ]) $\mid$\\
 & & {\tt ALGHORNER} ($<$arg\_list$>$ [,\{$<$id\_seq$>$\}]) $\mid$ \\
 & & $\cdots$\\
$<$arg\_list$>$ & $::=$ & $<$arg\_list\_name$>~\mid~$\{$<$arg\_seq$>$\}\\
$<$arg\_seq$>$ & $::=$ & $<$arg$>$[,$<$arg\_seq$>$]\\
$<$arg$>$ & $::=$ & $<$matrix\_id$>~\mid~<$name$>$=$<$expression$>$\\
$<$arg\_list\_name$>$ & $::=$ & $<$id$>$\\
 & & $\ \ $\\
$<$file\_id\_seq$>$ & $::=$ & $<$file\_id$>$ [,$<$file\_id\_seq$>$]\\
$<$file\_id$>$ & $::=$ & $<$id$>$ $\mid$ $<$string\_id$>$\\
$<$string\_id\_list$>$ & $::=$ & $<$string\_id$>$ $\mid$ 
 \{$<$string\_id\_seq$>$\}\\
$<$string\_id\_seq$>$ & $::=$ & $<$string\_id$>$ [,$<$string\_id\_seq$>$]\\
$<$string\_id$>$ & $::=$ & {\tt "}$<$id$>${\tt "} $\mid$ 
{\tt "}$<$id$>.<$f\_extension$>${\tt "}\\
 & & $\ \ $\\
$<$declaration\_group$>$ & $::=$ & $<$declaration$>~\mid~\ll~<$declaration\_list$>~\gg$\\
$<$declaration\_list$>$ & $::=$ & $<$declaration$>$[$;<$declaration\_list$>$]\\
$<$declaration$>$ & $::=$ & $<$range\_list$>:$ {\tt IMPLICIT} $<$type$>~\mid$
 $<$id\_list$>:<$type$>$\\
$<$range\_list$>$& $::=$ & $<$range$>$[,$<$range\_list$>$]\\
$<$range$>$ & $::=$ & $<$id$>~\mid~<$id$>-<$id$>$\\
$<$id\_list$>$ & $::=$ & $<$id$>$[,$<$id\_list$>$]\\
$<$type$>$ & $::=$ & {\tt integer} $\mid$ {\tt real} $\mid$ {\tt complex} $\mid$ 
 {\tt real*8} $\mid$ {\tt complex*16}\\
 & & $\ \ $\\
$<$ssetq\_list$>$ & $::=$ & ($<$ssetq\_seq$>$)\\
$<$ssetq\_seq$>$ & $::=$ & $<$ssetq\_stat$>~[<$ssetq\_seq$>]$\\
$<$ssetq\_stat$>$ & $::=$ & ({\tt setq} $<$lhs\_id$>~<$rhs$>)~\mid$
({\tt rsetq} $<$lhs\_id$>~<$rhs$>)~\mid$\\
 & & ({\tt lsetq} $<$lhs\_id$>~<$rhs$>)~\mid$
({\tt lrsetq} $<$lhs\_id$>~<$rhs$>)$\\
\end{tabular}
\end{center}

\begin{center}
\begin{tabular}{lcl}
$<$lhs\_id$>$ & $::=$ & $<$id$>~\mid~<$subscripted\_id$>$\\
$<$subscripted\_id$>$ & $::=$ & $(<$id$>~<$s\_subscript\_seq$>)$\\
$<$s\_subscript\_seq$>$ & $::=$ & $<$s\_subscript$>[~<$s\_subscript\_seq$>$]\\
$<$s\_subscript$>$ & $::=$ & $<$integer$>~\mid~<$integer prefix\_expression$>$\\
$<$rhs$>$ & $::=$ & $<$prefix\_expression$>$\\
$<$infile\_list$>$ & $::=$ & $(<$infile\_seq$>)$\\
$<$infile\_seq$>$ & $::=$ & $<$infile\_name$>[~<$infile\_seq$>]$\\
$<$infile\_name$>$ & $::=$ & $<$string\_id$>$\\
$<$outfile\_name$>$ & $::=$ & $<$string\_id$>$\\
$<$declaration\_list$>$ & $::=$ & $(<$declaration\_seq$>)$\\
$<$declaration\_seq$>$ & $::=$ & $<$declaration$>~<$declaration\_seq$>$\\
$<$declaration$>$ & $::=$ & $(<$type$>~<$lhs\_id\_seq$>)$\\
$<$lhs\_id\_seq$>$ & $::=$ & $<$lhs\_id$>~<$lhs\_id\_seq$>$
\end{tabular}
\end{center}

\subsection{Additional SCOPE-functions}~\label{SCOPE:arules}

Fifteen additional functions can be used. We shortly summarize their name and use: 

\begin{center}
\begin{tabular}{| l | l | l |} \hline 
Name(s) & Introduced in & See the examples:\\ \hline \hline
{\tt SCOPE\_SWITCHES} & ~\ref{SCOPE:basic} & ~\ref{ex:3.1.1}\\
{\tt SETLENGTH, RESETLENGTH} & ~\ref{SCOPE:optim} & ~\ref{ex:3.1.2}, 
 ~\ref{ex:3.1.5}, ~\ref{ex:3.2.6} and ~\ref{ex:3.2.7}\\
{\tt ARESULTS, RESTORABLES, ARESTORE, RESTOREALL} & ~\ref{SCOPE:optim} & 
 ~\ref{ex:3.1.9}, ~\ref{ex:3.2.6} and ~\ref{ex:4.1.2}\\
{\tt OPTLANG} & ~\ref{SCOPE:decl} & ~\ref{ex:6.1}\\
{\tt VECTORCODE, VCLEAR} & ~\ref{SCOPE:dda} & ~\ref{ex:7.1}\\
{\tt DELAYDECS, MAKEDECS, DELAYOPTS, MAKEOPTS} & ~\ref{SCOPE:gopt} &
 ~\ref{ex:8.1} and ~\ref{ex:8.2}\\
{\tt INAME} & ~\ref{SCOPE:gopt} & ~\ref{ex:8.2}\\ \hline
\end{tabular}
\end{center}
\index{SCOPE function ! {\tt SCOPE\_SWITCHES}}
\index{SCOPE function ! {\tt SETLENGTH}}
\index{SCOPE function ! {\tt RESETLENGTH}}
\index{SCOPE function ! {\tt ARESULTS}}
\index{SCOPE function ! {\tt RESTORABLES}}
\index{SCOPE function ! {\tt ARESTORE}}
\index{SCOPE function ! {\tt RESTOREALL}}
\index{SCOPE function ! {\tt OPTLANG}}
\index{SCOPE function ! {\tt VECTORCODE}}
\index{SCOPE function ! {\tt VCLEAR}}
\index{SCOPE function ! {\tt DELAYDECS}}
\index{SCOPE function ! {\tt MAKEDECS}}
\index{SCOPE function ! {\tt DELAYOPTS}}
\index{SCOPE function ! {\tt MAKEOPTS}}
\index{SCOPE function ! {\tt INAME}}

\subsection{The relevant REDUCE, GENTRAN and SCOPE switches}~\label{SCOPE:switches}

We also shortly summarize the use of the switches, which were introduced 
in section ~\ref{SCOPE:basic} in example~\ref{ex:3.1.1}:

\begin{center}
\begin{tabular}{| l | l | l |}\hline 
Name & Origin & Illustrated in the examples:\\ \hline \hline
{\tt ACINFO} & SCOPE & ~\ref{ex:3.1.8}, ~\ref{ex:3.2.5}, ~\ref{ex:8.2}
 and ~\ref{ex:9.1}\\
{\tt AGAIN} & SCOPE & ~\ref{ex:5.1} and ~\ref{ex:9.1}\\
{\tt DOUBLE} & GENTRAN & ~\ref{ex:9.1}\\
{\tt EVALLHSEQP} & REDUCE & ~\ref{ex:3.2.5}\\
{\tt EXP} & REDUCE & ~\ref{ex:3.1.8}, ~\ref{ex:3.2.7}, ~\ref{ex:4.1.3} and 
 ~\ref{ex:8.2}\\
{\tt FORT} & REDUCE & ~\ref{ex:3.1.4}, ~\ref{ex:3.1.6}, ~\ref{ex:3.1.8},
 ~\ref{ex:3.2.5}, ~\ref{ex:7.1} and ~\ref{ex:9.1}\\
{\tt FTCH} & SCOPE & ~\ref{ex:3.1.4} and ~\ref{ex:3.1.5}\\ \hline
\end{tabular}
\end{center}
\index{{\tt ACINFO} switch}
\index{{\tt AGAIN} switch}
\index{{\tt DOUBLE} switch}
\index{{\tt EVALLHSEQP} switch}
\index{{\tt EXP} switch}
\index{{\tt FORT} switch}
\index{{\tt FTCH} switch}
\newpage
\index{{\tt GENTRANOPT} switch}
\index{{\tt INPUTC} switch}
\index{{\tt INTERN} switch}
\index{{\tt NAT} switch}
\index{{\tt PERIOD} switch}
\index{{\tt PREFIX} switch}
\index{{\tt PRIALL} switch}
\index{{\tt PRIMAT} switch}
\index{{\tt ROUNDBF} switch}
\index{{\tt ROUNDED} switch}
\index{{\tt SIDREL} switch}
\index{{\tt VECTORC} switch}
\begin{center}
\begin{tabular}{| l | l | l |}\hline 
Name & Origin & Illustrated in the examples:\\ \hline \hline
{\tt GENTRANOPT} & GENTRAN & ~\ref{ex:8.1}\\
{\tt INPUTC} & SCOPE & ~\ref{ex:3.1.3}, ~\ref{ex:3.1.6}, ~\ref{ex:3.1.7},
 ~\ref{ex:3.2.7}, ~\ref{ex:5.1} and ~\ref{ex:9.1}\\
{\tt INTERN} & SCOPE & ~\ref{ex:9.1}\\
{\tt NAT} & REDUCE & ~\ref{ex:3.1.8} and ~\ref{ex:5.1}\\
{\tt PERIOD} & REDUCE & ~\ref{ex:3.1.4}\\
{\tt PREFIX} & SCOPE & ~\ref{ex:9.2}\\
{\tt PRIALL} & SCOPE & ~\ref{ex:3.1.2}\\
{\tt PRIMAT} & SCOPE & ~\ref{ex:3.2.7}\\
{\tt POUNDBF} & REDUCE & ~\ref{ex:6.2}\\
{\tt ROUNDED} & REDUCE & ~\ref{ex:3.1.7} and ~\ref{ex:8.2}\\
{\tt SIDREL} & SCOPE & ~\ref{ex:3.2.7}\\
{\tt VECTORC} & SCOPE & ~\ref{ex:7.1}\\ \hline
\end{tabular}
\end{center}
\newpage
\section{SCOPE 1.5 Installation Guide}~\label{SCOPE:inst}

SCOPE 1.5 is easily installed. The usual code compilation facilities of {\REDUCE}
can be applied. In view of the frequent interaction between SCOPE and GENTRAN
a compiled version of GENTRAN is required during the creation of the load module
for SCOPE 1.5.  The compilation process itself is vizualized below.

{\small
\begin{verbatim}
faslout "~infhvh/mkscope/scope_15";

lisp in "~infhvh/mkscope/cosmac.red"$
lisp in "~infhvh/mkscope/codctl.red"$
lisp in "~infhvh/mkscope/codmat.red"$
lisp in "~infhvh/mkscope/codopt.red"$
lisp in "~infhvh/mkscope/codad1.red"$
lisp in "~infhvh/mkscope/codad2.red"$
lisp in "~infhvh/mkscope/coddec.red"$
lisp in "~infhvh/mkscope/codpri.red"$
lisp in "~infhvh/mkscope/codgen.red"$
lisp in "~infhvh/mkscope/codhrn.red"$
lisp in "~infhvh/mkscope/codstr.red"$
lisp in "~infhvh/mkscope/coddom.red"$
%lisp in "~infhvh/mkscope/apatch.red"$
algebraic;

faslend ;
end;
\end{verbatim}}

The subdirectory {\tt mkscope} in the author's directory system 
contains the files with the source code of SCOPE 1.5. 
The order in which the files are read in is irrelevant except
the first and the last. The file {\tt cosmac.red} contains
one module, named {\tt cosmac}, which consists of a set of
smacro procedures, designed to simplify access to the lower
levels of the expression data base, employed during optimization.
These smacro's are used in all other code sections.
The last file in optional and usually executed to include new
patches into a recompilable version of the package.
Once it is stored in the {\tt fasl} directory of the local
REDUCE system it is available as a {\tt load\_package}.

In short, the files contain the following code sections: 

\begin{itemize}
\item {\tt cosmac.red} contains the module {\tt cosmac}, consisting of
smacro procedures, allowing access to the expression data base.
\item {\tt codctl.red} consists of the three modules {\tt codctl},
{\tt restore} and {\tt minlenght}. The first is a large module,
containing the optimization process managing facilities. The second
module is added to regulate the interplay with the REDUCE simplifier,
when entering optimizer output in algebraic mode using functions like
{\tt ARESULTS}. The last module serves to vary the minimal length of
cse's using {\tt SETLENGTH} and {\tt RESETLENGTH}.
\item {\tt codmat.red} contains the module {\tt codmat}, definig the
parsing process and the expression data base setup and access facilities.
\item {\tt codopt.red}'s content is formed by the module {\tt codopt}.
It is the kernel of the optimization process, the implementation of the
extended Breuer algorithm.
\item {\tt codad1.red} contains the module {\tt codad1}, formed by additional
facilities for improving the lay-out of the overall result, for information
migration between different sections of the expression data base  and for the
application of the distributive law to remodel and compactify (sub)expression 
structure  at any level.
\item {\tt codad2.red} contains the module {\tt codad2}. This module defines
five different possible activities during the optimization process. The first
four regulate the so called {\em finishing touch}. The last one is a new
section, defining how to optimize {\em rational forms} as part of the overall
optimization process.
\item {\tt coddec.red} covers the declaration facilities, presented in 
section ~\ref{SCOPE:decl}, collected in the module {\tt coddec} and 
based on chapter 6 of ~\cite{Aho:86}. The symbol table setup of GENTRAN is used.
\item {\tt codpri.red} is also formed by one module, called {\tt codpri}.
It covers all printing facilities. The first section is applied when the
switch {\tt PRIMAT} is turned {\tt ON}. The latter is used to produce
an internal list of pairs, consisting of the left hand side and the right 
hand side of assignment statements in prefix notation, and  defining the 
output of the optimization process in sequential order. This prefix list is 
delivered to GENTRAN or REDUCE to make the results visible in the user 
prefered form. The intial version of this list, created directly 
after the optimization process, is improved using a collection of functions, 
also grouped together in the module {\tt codpri}. These improvements may 
for instance be necessary to remove temporarily introduced names, internally 
employed as a result of a data dependency analysis.
\item {\tt codgen.red} consists of the module {\tt codgen}. The interface
between GENTRAN and SCOPE 1.5, introduced in section ~\ref{SCOPE:gopt} of 
this manual is defined in this module.
\item {\tt codhrn.red} is formed by the module {\tt ghorner}. It defines the
facilities, presented in section ~\ref{SSF:Hr} of this manual.
\item {\tt codstr.red} contains the module {\tt gstructr}. This module defines
the possibilities for expression structure recognition, as presented in section
~\ref{SSF:sr} of this manual.
\item {\tt coddom.red} finally, consists of one module, called {\tt coddom}.
It covers additional coefficient domain functions, needed to make the
extended Breuere algorithm and the additional functions, collected in the
modules {\tt codad1} and {\tt codad2} for instance, applicable for 
(multiple presicion) floating point coefficients.
\end{itemize}


A few additional remarks:

\begin{itemize}
\item GENTRAN plays an important role when creating declarations and output.
The package is automatically loaded when executing one of the first 
instructions in the module {\tt codctl}. Hence it may be necessary to 
look critically to the load instruction in {\tt codctl} before installing 
SCOPE 1.5. By changing this load instruction we easily created a {\tt fortran90} 
compatable SCOPE version ~\cite{Borst:94}. At present it is only available for our own 
internal and experimental use.  
\item We believe the code to be almost version independent. Over the past 
years all uses of {\tt nil} have been critically reviewed. However 
the {\tt coddom} module may require version based maintenance when 
installing SCOPE 1.5.
\item The present size of the source code is given in the table below.
Comment is included in these figures
\begin{center}
\begin{tabular}{| c | r | r |} \hline
File naam & number of lines & number of characters \\ \hline \hline
{\tt cosmac.red} & 172 & 4761 \\
{\tt codctl.red} & 1439 & 61466 \\
{\tt codmat.red} & 1488 & 72733 \\
{\tt codopt.red} & 1243 & 68809\\
{\tt codad1.red} & 801 & 39175 \\
{\tt codad2.red} & 1314 & 59217 \\
{\tt coddec.red} & 928 & 41069\\
{\tt codpri.red} & 1371 & 62600\\
{\tt codgen.red} & 214 & 9120\\
{\tt codhrn.red} & 752 & 30549\\
{\tt codstr.red} & 308 & 11199\\
{\tt coddom.red} & 204 & 6638\\ \hline
\end{tabular}
\end{center}
\item The modules {\tt ghorner} and {\tt gstructr} can be left out without
harming the other facilities, presented in this manual.
\end{itemize}
\newpage
\addcontentsline{toc}{section}{References}
\bibliography{scope}
\bibliographystyle{plain}
\newpage
\addcontentsline{toc}{section}{Index}
\printindex
\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codctl.red0000644000175000017500000014216511526203062023572 0ustar  giovannigiovannimodule codctl;  % Facilities for controlling the overall optimization.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden,  ;
%             J.B. van Veelen, B.L. Gates.                            ;
% ------------------------------------------------------------------- ;
% The file CODCTL.RED contains the functions defining the interface   ;
% between SCOPE and REDUCE.                                           ;
% Besides, CODCTL consists of facilities for controlling the          ;
% overall optimization process( making use of a number of global      ;
% variables and switches) and for the creation of an initial operating;
% environment for the optimization process.                           ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% ------------------------------------------------------------------- ;
% The optimization process is initialized by applying the function    ;
% INIT, designed to create the initial state of the data structures,  ;
% used to store the input, which will be subjected to a heuristic     ;
% search for common sub-expressions (cse's). INIT serves also to      ;
% restore initial settings when an unexpected termination occurs.     ;
% ARESULTS can be used to obtain the output in an algebraic list, once;
% the optimization itself is finished and only when relevant, i.e. if ;
% !*SIDREL=T, !*AGAIN or Optlang!* is NIL.                            ;
% During input translation the incidence matrix(CODMAT) is partly     ;
% made, by creating its row structure via FFVAR!!, given in the module;
% CODMAT.  Once input is processed the optimization activities are    ;
% activated by applying the function CALC.The kernel of the body of   ;
% this function is the procedure OPTIMIZELOOP. However, first the     ;
% function SSETVSARS (see CODMAT module) is applied to complete the   ;
% matrix CODMAT (column creation). The optimize-loop is a repeated    ;
% search for cse's, using facilities, defined in the modules CODOPT   ;
% and CODAD1.  During these searches different cse-names for identical;
% cse's might be created,for instance due to EXPAND- and SHRINK-      ;
% activities (see CODOPT), an inefficiency repaired via IMPROVELAYOUT ;
% (see the module CODAD1). When !*AGAIN is T  output is created       ;
% without performing the finishing touch (see CODAD2). Output is      ;
% created through the functions MAKEPREFIXL and PRIRESULT. Finally the;
% REDUCE environment, which existed before the optimization activities;
% is restored as last activity of CALC.                               ;
% ------------------------------------------------------------------- ;

symbolic$

global '(codmat endmat !*acinfo prevlst !*sidrel maxvar malst
        rowmax rowmin !*priall !*primat codbexl!* !*prefix !*again
        ops kvarlst cname!* cindex!* optlang!* gentranlang!*
        varlst!* varlst!+ !*outstk!* !*optdecs !*inputc !*vectorc
        !*intern min!-expr!-length!*)$

fluid '(!*gentranopt !*double !*period !*noequiv );

switch acinfo,sidrel,priall,primat,prefix,optdecs,again,inputc,vectorc,
       intern$

% ------------------------------------------------------------------- ;
% Initial settings for the globals.                                   ;
% ------------------------------------------------------------------- ;
codmat:=!*priall:=!*primat:=!*sidrel:=!*optdecs:=optlang!*:=nil;
!*again:=!*prefix:=!*acinfo:=!*inputc:=!*intern:=!*vectorc:=nil;
min!-expr!-length!*:=nil;
rowmin:=0; rowmax:=-1;

% ------------------------------------------------------------------- ;
% Description of global variables and switches.                       ;
% ------------------------------------------------------------------- ;
% MATRIX ACCESS:                                                      ;
%                                                                     ;
% CODMAT : is a vector used to store the +,* matrices,merged in CODMAT;
% MAXVAR : The size of this merged matrix is 2*MAXVAR.                ;
% ROWMAX : Largest actual row index.                                  ;
% ROWMIN : Smallest actual column index.                              ;
% ENDMAT : Value of MAXVAR when cse-search starts.                    ;
%                                                                     ;
% Remark - The storage strategy can be vizualized as follows:         ;
%                                                                     ;
%  MAXVAR + MAXVAR                                                    ;
%  -------|------------------------------------------------|          ;
%         | Storage left for cse's                         |          ;
%  -------|------------------------------------------------|          ;
%  MAXVAR + ROWMAX (ENDMAT when input processing completed)|          ;
%  -------|------------------------------------------------|          ;
%         | Matrix Rows:Input decomposition                |          ;
%  -------|------------------------------------------------|          ;
%  MAXVAR + 0                                              |          ;
%  -------|------------------------------------------------|          ;
%         | Matrix columns:Variable occurrence information |          ;
%  -------|------------------------------------------------|          ;
%  MAXVAR - ROWMIN                                         |          ;
%  -------|------------------------------------------------|          ;
%         | Storage left for cse-occurrence information    |          ;
%  -------|------------------------------------------------|          ;
%  MAXVAR - MAXVAR                                         |          ;
%                                                                     ;
%                                                                     ;
%  CSE-NAME SELECTION                                                 ;
%                                                                     ;
%  Cname!* : Created in INAME and exploded representation of letter-  ;
%            part of current cse-name.                                ;
%  Cindex!*: Current cse-number. If cindex!*:=Nil then GENSYM() is use;
%  Bnlst   : List of initial cse-names. When !*AGAIN=T used to save   ;
%            these names via CSES:=('PLUS.Bnlst).If necessary extended;
%            with last GENSYM-generation(see MAKEPREFIXLIST). This    ;
%            assignment statement preceeds other output and is used in;
%            FFVAR!! (see module CODMAT) to flag all old cse-names    ;
%            with NEWSYM when continuing with next set of input files.;
%                                                                     ;
%  The cse-name generation process is organized by the procedures     ;
%  INAME,NEWSYM1 and FNEWSYM. The procedure DIGITPART is needed in    ;
%  FFVAR!! (via RestoreCseInfo)  to restore the cse-name flags NEWSYM.;
%  This information is saved by SaveCseInfo (see MAKEPREFIXLST).      ;
%                                                                     ;
%  SWITCHES : THE ON-EFFECT IS DESCRIBED                              ;
%                                                                     ;
%    ACinfo   : (Evaluated) input and Operation counts displayed with-;
%               out disturbing Outfile declarations.                  ;
%    Primat   : Initial and final state of matrix CODMAT is printed.  ;
%    Priall   : Turns !*ACinfo,!*Primat on.                           ;
%    Prefix   : Output in pretty printed prefixform.                  ;
%    Again    : Optimization of partioned input will be continued a   ;
%               next time. Cse's added to prefixlist and finishing    ;
%               touch delayed.                                        ;
%    SidRel   : The Optimizer output, collected in Prefixlist, is re- ;
%               written, using the procedure EvalPart, defined in this;
%               module, resulting in a list of (common sub)expressions;
%               with PLUS or DIFFERENCE as their leading operator,    ;
%               when ever possible.                                   ;
%    Optdecs :  The output is preceded by a list of declarations.     ;
%                                                                     ;
%  REMAINING GLOBALS                                                  ;
%                                                                     ;
%  Prefixlist : Association list defining output. Built in CODPRI-part;
%               2 and used either via ASSGNPRI (ON FORT or ON/OFF NAT);
%               or via PRETTYPRINT (ON PREFIX).                       ;
% Pre-                                                                ;
% Prefixlist :  Rational exponentiations require special provisions   ;
%               during parsing, such as the production of this list of;
%               special assignments, made as side-effect of the appli-;
%               cation of the function PrepMultMat in SSetVars (see   ;
%               the module CODMAT). This list is put in front of the  ;
%               list Prefixlist.                                      ;
%  Prevlst    : Used in FFVAR!! to store information about expression ;
%               hierarchy when translating input.                     ;
%               Later used (initialized in SSETVARS) to obtain correct;
%               (sub)expression ordering.                             ;
%  Kvarlst    : Used for storing information about kernels.           ;
%  Optlang!*  : Its value ('FORTRAN, 'C, for instance) denotes the    ;
%               target language selection for the output production.  ;
%  CodBexl!*  : List consisting of expression recognizers. It guaran- ;
%               tees a correct output sequence. Its initial structure ;
%               is built in FFVAR!! and modified in IMPROVELAYOUT,for ;
%               instance, when superfluous intermediate cse-names are ;
%               removed.                                              ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% Some GENTRAN modules  are required to obtain a correct interface.   ;
% The file names are installation dependent.                          ;
% ------------------------------------------------------------------- ;

%IN "$gentranutil/sun-gentran-load"$
 load!-package 'gentran$  % Moet worden gentran90 !!

% Load and initialize rounded-package
if not !*rounded then << on 'rounded; off 'rounded >>;


% ------------------------------------------------------------------- ;
% PART 1 : Interface between Scope and Reduce.                        ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
%   ALGEBRAIC MODE COMMAND PARSER                                     ;
% ------------------------------------------------------------------- ;

put('optimize, 'stat, 'optimizestat);


global '(optlang!* avarlst known rhsaliases);
fluid '(!*fort preprefixlist prefixlist);

symbolic expr procedure optimizestat;
    % --------------------------------------------------------------- ;
    %  OPTIMIZE command parser.                                       ;
    % --------------------------------------------------------------- ;
    begin scalar forms, vname, infiles, outfile, x, decs, kwds, delims;
    symtabrem('!*main!*,'!*decs!*);
    kwds := '(iname in out declare);
    delims := append(kwds, '(!*semicol!* !*rsqb!* end));
    flag(kwds, 'delim);
    while not memq(cursym!*, delims) do
        if (x := xreadforms()) then
            forms := append(forms, x);
    while memq(cursym!*, kwds) do
        if eq(cursym!*, 'iname) then
            vname := xread t
        else if eq(cursym!*, 'in) then
            if atom (x := xread nil) then
                infiles := list x
            else if eqcar(x, '!*comma!*) then
                infiles := cdr x
            else
                infiles := x
        else if eq(cursym!*, 'out) then
            outfile:=xread t
        else if eq(cursym!*, 'declare) then
            decs := append(decs, cdr declarestat());
    remflag(kwds, 'delim);
    return list('symoptimize, mkquote forms,
                              mkquote infiles,
                              mkquote outfile,
                              mkquote vname,
                              mkquote decs)
    end;

% ------------------------------------------------------------------- ;
%   ALGEBRAIC MODE OPERATOR ALGOPT                                    ;
% ------------------------------------------------------------------- ;

symbolic procedure algopteval u;
% ------------------------------------------------------------------- ;
% Algebraic mode interface in the form of a function-application. The ;
% procedure algresults1 is used for result production.                ;
% u = list of the form : (forms, filesnames, csename). The arguments  ;
% are optional.                                                       ;
% forms is a list of eq's, defining pairs (lhs-name,rhs-value),       ;
% filenames is a list of filenames, containing symtactically correct  ;
% input and the csename, optional too, is the initial cse-name part,  ;
% a scalar.                                                           ;
% --------------------------------------------------------------------;
begin
  scalar su,res,intern!*; integer nargs;
  intern!*:=!*intern; !*intern:='t;
  nargs := length u;
  u:=foreach el in u collect
   if listp(el) and eqcar(el,'list) and allstring(cadr el)
    then cdr(el) else el;
  if listp(car u) and not(allstring car u) and not(eqcar(car u,'list))
   then u:=list('list,car u).cdr u;
  res :=
   if nargs = 1
    then if su:=allstring(car u)
          then symoptimize(nil,su,nil,nil,nil)
          else symoptimize(car u,nil,nil,nil,nil)
    else if nargs = 2
     then if su:=allstring(cadr u)
           then symoptimize(car u,su,nil,nil,nil)
           else if (su:=allstring(car u)) and atom cadr u
            then symoptimize(nil,su,nil,cadr u,nil)
            else if atom cadr u
             then symoptimize(car u,nil,nil,cadr u,nil)
             else '!*!*error!*!*
    else if nargs = 3 and (su:=allstring cadr u)
     then symoptimize(car u,su, nil, caddr u,nil)
     else '!*!*error!*!*;
   !*intern:=intern!*;
   if eq(res,'!*!*error!*!*)
    then rederr("SYNTAX ERROR IN ARGUMENTS ALGOPT")
    else return algresults1(foreach el in res
                                   collect cons(cadr el,caddr el))
   end;

put ('algopt,'psopfn,'algopteval);

symbolic procedure allstring s;
% ------------------------------------------------------------------- ;
% Consists s of one are more filenames?                               ;
% ------------------------------------------------------------------- ;
if atom s
 then if stringp s then list(s)
                   else nil
else if not(nil member foreach el in s collect stringp el) then s
                                                           else nil;


% ------------------------------------------------------------------- ;
%   SYMBOLIC MODE PROCEDURE                                           ;
% ------------------------------------------------------------------- ;

global '(!*algpri !*optdecs)$
switch algpri,optdecs$
!*optdecs:=nil$

symbolic expr procedure symoptimize(forms,infiles,outfile,vname,decs);
    % --------------------------------------------------------------- ;
    %  Symbolic mode function.                                        ;
    % --------------------------------------------------------------- ;
    begin scalar algpri,echo,fn,forms1,optdecs, comdecs;
    echo:=!*echo;
    eval list('off, mkquote list 'echo);
    if infiles then
        forms := append(forms, files2forms infiles);
    algpri := !*algpri;
    !*echo:=echo;
    if decs
       then << optdecs:=!*optdecs; !*optdecs:=t;
               % JB 31/3/94 Fixed to deal with complex input:
              if (comdecs:=assoc('complex, decs)) or
                 (comdecs:=assoc('complex!*16, decs))
                 then <>;
    eval list('off, mkquote list 'algpri);
    if vname then iname vname;
    forms := analyse_forms(forms);
    !*algpri := algpri;
    preproc1 ('declare . decs);
    prefixlist:=
           eval formoptimize(list('optimizeforms,forms,outfile,vname),
                             !*vars!*,
                             !*mode);
    if decs then !*optdecs:=optdecs;
            %else !*gendecs:=optdecs;

    if !*intern
     then return (foreach el in prefixlist
                   collect list('setq,car el,cdr el))
  end$


symbolic procedure analyse_forms(forms);
% --------------------------------------------------------------------;
% forms is recursively analysed and replaced by a flattened list of   ;
% items, which are either of the form ('setq lhs rhs) or have the     ;
% structure ('equal lhs rhs).
% Here lhs can be a scalar, a matrix or an array identifier.          ;
% The rhs is a REDUCE expression in prefix form. During the analysis  ;
% scalar, matrix or array identifier elements of the list forms are   ;
% replaced by the prefix equivalent of their algebraic value, which is;
% assumed to be a list of equations of the form                       ;
%  {lhs1=rhs1,...,lhsn=rhsn}.                                         ;
% Similarly elements of forms, being function-applications (either    ;
% symbolic operators or psopfn facilities), evaluable to lists of the ;
% above mentioned structure, are replaced by their evaluations.       ;
% ------------------------------------------------------------------- ;
begin scalar fn,res,forms1;
if atom(forms) then forms:=list(forms)
else if (listp(forms) and get(car forms,'avalue)
        and car(get(car forms,'avalue)) member '(array matrix))
 then forms:=list(forms)
else if listp forms and eqcar(forms,'list) then forms:=cdr forms;
res:=
 foreach f in forms conc
  if atom(f) and car(get(f,'avalue))='list then cdr reval f
  else if listp(f) and get(car f,'avalue) and
          car(get(car f,'avalue)) member '(array matrix)
   then cdr reval f
  else if listp(f) and eqcar(f,'list) then list f
  else if listp(f) and eqcar(f,'equal) and eqcar(caddr f,'!*sq)
      then list list('equal,cadr f,sq2pre caddr f)
  else if listp(f) and
          not member(car f,'(equal lsetq lrsetq rsetq setq))
   then <>
  else list f;
return foreach f in res conc
 if listp(f) and eqcar(f,'list) then analyse_forms(cdr f) else list f
end;

symbolic expr procedure xreadforms;
    begin scalar x;
    x := xread t;
    if listp x and eqcar(x, 'list) then
        return flattenlist x
    else if x then
        return list x
    else
        return x
    end;

symbolic expr procedure flattenlist x;
    if atom(x) or constp(x) then
      x
    else
    << if eqcar(x, 'list) then
         foreach y in cdr x collect flattenlist y
       else
         x
    >>;

symbolic expr procedure files2forms flist;
    begin scalar ch, holdch, x, forms;
    holdch := rds nil;
    forms := nil;
    foreach f in flist do
    <<
        ch := open(mkfil f, 'input);
        rds ch;
        while (x := xreadforms()) do
            forms := append(forms, x);
        rds holdch;
        close ch
    >>;
    return forms
    end;


symbolic expr procedure formoptimize(u, vars, mode);
    car u . foreach arg in cdr u
                collect formoptimize1(arg, vars, mode);

symbolic procedure chopchop rep;
% rep : m . e;
% no trailing zeros in m; e < 0.
% rep is the cdr-part of a (!:rd!: !:cr!: !:crn!: !:dn!:)-notation.
if length(explode abs car rep)> !!rdprec
   then begin
          scalar sgn,restlist,lastchop,exppart;
          restlist:=reverse explode abs(car rep);
          sgn:=(car rep < 0);
          exppart:= cdr rep;
          while length(restlist) > !!rdprec
                do << lastchop:=car restlist;
                      restlist:=cdr restlist;
                      exppart:=exppart+1 >>;
          restlist:= compress reverse restlist;
          if compress list lastchop >= 5
             then restlist:=restlist + 1;
          return (if sgn then -1*restlist else restlist) . exppart;
          end
   else rep;

symbolic expr procedure formoptimize1(u, vars, mode);
 if constp u
    then mkquote u % JB 30/3/94.
                   % Constants are not neccesarily atoms.
    else
 if atom u
    then mkquote u
    else if member(car u,'(!:rd!: !:cr!: !:crn!: !:dn!:))
            then % JB 31/3/94 This seems to work. Honestly
                 % stolen from formgentran.
                 mkquote <<%precmsg length explode abs car(u := cdr u);
                           u:=chopchop cdr u;
                           decimal2internal(car u,cdr u)>>
    else if eq(car u,'!:int!:)
            then mkquote cadr u
    else if eqcar(u, 'eval) then
            list('sq2pre, list('aeval, form1(cadr u, vars, mode)))
    else if car u memq '(lsetq rsetq lrsetq) then
        begin scalar op, lhs, rhs;
        op := car u;
        lhs := cadr u;
        rhs := caddr u;
        if op memq '(lsetq lrsetq) and listp lhs then
            lhs := car lhs . foreach s in cdr lhs
                                collect list('eval, s);
        if op memq '(rsetq lrsetq) then
            rhs := list('eval, rhs);
        return formoptimize1(list('setq, lhs, rhs), vars, mode)
        end
    else
        ('list . foreach elt in u
                        collect formoptimize1(elt, vars, mode));

symbolic expr procedure sq2pre f;
    if atom f then
        f
    else if listp f and eqcar(f, '!*sq) then
        prepsq cadr f
    else
        prepsq f;

% ------------------------------------------------------------------- ;
%   CALL CODE OPTIMIZER                                               ;
% ------------------------------------------------------------------- ;

symbolic procedure optimizeforms(forms,outfile,vname);
begin
  scalar noequiv,double,period,ch,fort,holdch,optlang,primat,
         acinfo,inputc;
  period:=!*period; !*period:=nil;   % No periods in subscripts please.
  noequiv:=!*noequiv; !*noequiv:=t;  % No equivalence check, see coddom
  double:=!*double;
  put('!:rd!:,'zerop,'rd!:zerop!:);  % New zerop which respects
                                     % precision-setting, onep is o.k.
  if vname and not(getd('newsym)) then iname vname;
  if !*fort then << fort:=t;!*fort:=nil;
                    optlang:=optlang!*; optlang!*:='fortran>>;
  if outfile then
  << if not(optlang!*)
      then << holdch:=wrs nil;               % get old output channel
              if ch:=assoc(intern outfile,!*outstk!*)
               then ch:=cdr ch
               else ch:=open(mkfil outfile,'output);
              wrs ch                         % set output channel to ch
           >>
      else eval list('gentranoutpush,list('quote,list(outfile)))
  >>;
  if !*priall     % Save previous flag configuration.
   then << primat:=!*primat; acinfo:=!*acinfo; inputc:=!*inputc;
           !*primat:=!*acinfo:=!*inputc:=t >>;

  prefixlist:=calc forms;

  if !*priall then               % Restore original flag configuration.
  << !*primat:=primat; !*acinfo:=acinfo; !*inputc:=inputc >>;
  if outfile then
  << if not(optlang!*)
      then
       << if (not(!*nat) or !*again) then write ";end;";
          % Restore output channel
          if assoc(intern outfile,!*outstk!*)
            then <> else <>
       >>
      else eval '(gentranpop '(nil))
  >>;
  if fort then << !*fort:=t; optlang!*:=optlang>>;
  put('!:rd!:,'zerop,'rd!:zerop);
  !*double:=double; !*noequiv:=noequiv; !*period := period;
  return prefixlist;
end;

symbolic procedure opt forms;
    % --------------------------------------------------------------- ;
    %  Replace each sequence of one or more assignment(s) by its      ;
    %  optimized equivalent sequence.                                 ;
    % --------------------------------------------------------------- ;
    begin scalar seq, res, fort, optlang;
        fort:=!*fort;
        !*fort:=nil;
        optlang:=optlang!*;
        optlang!*:=gentranlang!*;
        if atom forms then
            res := forms
        else if eqcar(forms, 'setq) then
        <<
            res := foreach pr in optimizeforms(list forms, nil, nil)
                      collect list('setq, car pr, cdr pr);
            if onep length res
                then res := car res
                else res := mkstmtgp(0, res)
         >>
        else if atom car forms then
            res := (car forms . opt cdr forms)
        else
        <<
            seq := nil;
            while forms and listp car forms and eqcar(car forms, 'setq)
               do <>;
            if seq then
            < 1 then
                  seq := list mkstmtgp(0, seq);
              res := append(seq, opt forms)
            >>
            else
                res := (opt car forms . opt cdr forms);
        >>;
        optlang!*:=optlang;
        !*fort:=fort;
        return res;
    end;


% ------------------------------------------------------------------- ;
% PART 2 : Control of overall optimization process.                   ;
% ------------------------------------------------------------------- ;

symbolic procedure init n;
% ------------------------------------------------------------------- ;
% arg: Size of the matrix N.                                          ;
% eff: Initial state (re)created by (re)initializing the matrix CODMAT;
%      and some related identifiers.                                  ;
% ------------------------------------------------------------------- ;
begin scalar var;
  for y:=rowmin:rowmax do
  if row(y) and not numberp(var:=farvar y)
  then
  <>;
  if maxvar=n
    then for x:=0:2*n do putv(codmat,x,nil)
    else codmat:=mkvect(2*n);
  if kvarlst then foreach item in kvarlst do
  << remprop(cadr item,'kvarlst);
     remprop(cadr item,'nex)
  >>;
  foreach item in '(plus minus difference times expt sqrt) do
                                               remprop(item,'kvarlst);
  %-------------------------------------------------------------------
  % If not all algresults were reversed by the user, by means of
  % `restorall', or `arestore', they become irreversible commited
  % after the following resetting of `avarlst'.
  %-------------------------------------------------------------------
  %bnlst:=
   varlst!*:=varlst!+:=prevlst:=kvarlst:=codbexl!*:=avarlst:=nil;
  malst:=preprefixlist:=nil; prefixlist:=nil;
  rowmax:=-1; maxvar:=n;
  rowmin:=0;
  ops:=list(0,0,0,0)
end;


symbolic procedure calc forms;
% ------------------------------------------------------------------- ;
% CALC produces,via OPTIMIZELOOP, the association list PREFIXLIST.    ;
% This list is used for output production by apllying PRIRESULT.      ;
% ------------------------------------------------------------------- ;
begin scalar fil;
  init 200;
  prefixlist:=rhsaliases:=nil;
  forms := preremdep forms;
  foreach item in forms do
          prefixlist:=ffvar!!(cadr item, caddr item, prefixlist);
  preprefixlist:=ssetvars(preprefixlist); % Complete parsing.
  fil:=wrs(nil);              % Save name output file,which has to be ;
                              % used for storing the final results    ;
  if !*primat then primat();
  if !*acinfo then countnop(reverse prefixlist,'input);
  optimizeloop();
  terpri();
  wrs(fil);
  prefixlist:=makeprefixl(preprefixlist,nil);
  if !*gentranopt
     then typeall(prefixlist)
     else if not !*intern
             then priresult(prefixlist);
  fil:=wrs(nil);
  if getd('newsym) then remd('newsym); %bnlst:=nil;
  if !*acinfo then << countnop(reverse prefixlist,'output); terpri()>>;
  if !*primat
  then << for x:=rowmin:rowmax do if farvar(x)=-1 or farvar(x)=-2
                                   then setoccup(x) else setfree(x);
           primat();
       >>;
  wrs(fil);
  return prefixlist
end$


% ------------------------------------------------------------------- ;
% Reduce interface for CALC, allowing the command CALC instead of     ;
% CALC().                                                             ;
% ------------------------------------------------------------------- ;

% put('calc,'stat,'endstat);


symbolic procedure pprintf(ex,nex);
% --------------------------------------------------------------------;
% arg : The name Nex of an expression Ex.                             ;
% eff : Nex:=Ex is printed using assgnpri on the output medium without;
%       disturbing the current file management and output flagsettings;
% --------------------------------------------------------------------;
begin scalar s,fil,nat;
  terpri();
  fil:=wrs(nil);
  if not(!*nat) then << nat:=!*nat; s:=!*nat:=t>>;
  assgnpri(ex,list nex,'last);
  wrs(fil);
  if s then !*nat:=nat
end;

symbolic procedure optimizeloop;
% ------------------------------------------------------------------- ;
% Iterative cse-search.                                               ;
% ------------------------------------------------------------------- ;
begin scalar b1,b2,b3,b4;
  repeat
  << extbrsea();
    % --------------------------------------------------------------- ;
    % Extended Breuer search (see module CODOPT):                     ;
    % Common linear expressions or power products are heuristically   ;
    % searched for using methods which are partly based on Breuer's   ;
    % grow factor algorithm.                                          ;
    % --------------------------------------------------------------- ;
    b1:=improvelayout();
    % --------------------------------------------------------------- ;
    % Due to search strategy, employed in EXTBRSEA, identical cse's   ;
    % can have different names. IMPROVELAYOUT (see module CODAD1 is   ;
    % used to detect such situations and to remove double names.      ;
    % --------------------------------------------------------------- ;
    b2:=tchscheme();
    % --------------------------------------------------------------- ;
    % Migration of information, i.e. the newly generated cse-names for;
    % linear expressions occuring as factor in a product are transfer-;
    % red from the + to the * scheme. Similar operations are performed;
    % for power products acting as terms. File CODAD1.RED contains    ;
    % TCHSCHEME.                                                      ;
    % --------------------------------------------------------------- ;
    b3:=codfac();
    % --------------------------------------------------------------- ;
    % Application of the distributive law,i.e. a*b + a*c is changed in;
    % a*(b + c) and expression storage in CODMAT is modified according;
    % ly. File CODAD1.RED contains CODFAC.                            ;
    % --------------------------------------------------------------- ;
    b4:=searchcsequotients();
  >>
  until not(b1 or b2 or b3 or b4);
end;

symbolic procedure countnop(prefixlst,io);
% ------------------------------------------------------------------- ;
% The number of +/-, unary -, *, integer ^, / and function applica-   ;
% tions is counted in prefixlist, consisting of pairs (lhs.rhs). Array;
% references are seen as function applications if the array name is   ;
% not contained in the symbol table. The content of the symbol table  ;
% is prescribed through the declare-option of the optimize-command,   ;
% i.e. when io='input, and posibly modified after optimization, i.e.  ;
% when io='output.                                                    ;
% ------------------------------------------------------------------- ;
begin scalar totcts;
 totcts:='(0 0 0 0 0 0);
 foreach item in prefixlst do
 << if pairp(car item) then totcts:=counts(car item,totcts,nil);
    totcts:=counts(cdr item,totcts,nil)
 >>;
 terpri();
 if io eq 'input
  then write "Number of operations in the input is: "
  else write "Number of operations after optimization is:";
 terpri(); terpri();
 write "Number of (+/-) operations      : ",car totcts; terpri();
 write "Number of unary - operations    : ",cadr totcts; terpri();
 write "Number of * operations          : ",caddr totcts; terpri();
 write "Number of integer ^ operations  : ",cadddr totcts; terpri();
 write "Number of / operations          : ",car cddddr totcts;terpri();
 write "Number of function applications : ",car reverse totcts;terpri()
end;

symbolic procedure counts(expression,locs,root);
% ------------------------------------------------------------------- ;
% The actual counts are recursively done with the function counts by  ;
% modifying the value of the 6 elements of locs.  The elements of locs;
% define the present number of the 6 possible categories of operators,;
% which we distinguish.                                               ;
% ------------------------------------------------------------------- ;
begin scalar n!+,n!-,n!*,n!^,n!/,n!f,tlocs,loper,operands;
 if idp(expression) or constp(expression)
  then tlocs:=locs
  else
   << n!+:=car locs; n!-:=cadr locs; n!*:=caddr locs; n!^:=cadddr locs;
      n!/:=car cddddr locs; n!f:= car reverse locs;
      loper:=car expression; operands:=cdr expression;
      if loper memq '(plus difference)
       then n!+:=(length(operands)-1)+n!+
       else
        if loper eq 'minus
         then (if root neq 'plus then n!-:=1+n!-)
         else
          if loper eq 'times
           then n!*:=(length(operands)-1)+n!*
           else
            if loper eq 'expt
             then (if integerp(cadr operands)
                   then n!^:=1+n!^ else n!f:=1+n!f)
             else
              if loper eq 'quotient
               then n!/:=1+n!/
               else
                if not(subscriptedvarp(loper))
                 then n!f:=1+n!f;
      tlocs:=list(n!+,n!-,n!*,n!^,n!/,n!f);
      foreach op in operands do tlocs:=counts(op,tlocs,loper)
   >>;
 return(tlocs)
end;

symbolic procedure complex!-i!-init!-statement st;
%
% See if we need to initialize i.
%
begin scalar tl, res;
  tl:=formtypelists symtabget('!*main!*,'!*decs!*);
  foreach el in tl do
       <>;
   return res;
   end;

symbolic procedure priresult(prefixlist);
% ------------------------------------------------------------------- ;
% Besides flag settings and the like the essential action is printing.;
% ------------------------------------------------------------------- ;
begin scalar pfl,nat,istat;
  if !*optdecs then typeall prefixlist;

  if optlang!*
  then << if null(assoc('e,prefixlist)) then symtabrem(nil,'e);
          pfl := foreach pr in prefixlist collect
                    list('setq, car pr,lispcodeexp(cdr pr,!*period));
          if (istat:=complex!-i!-init!-statement(nil))
             then pfl := append(istat, pfl);
          pfl := list mkstmtgp(0, pfl);
          apply1(get(optlang!*, 'formatter),
                 apply1(get(optlang!*, 'codegen), pfl));
       >>
  else if !*prefix
       then << write "Prefixlist:=";
               terpri();
               prettyprint(prefixlist)
            >>
       else << if !*optdecs then printdecs();
               if (istat:=complex!-i!-init!-statement('t))
                  then <>;
               if not !*again
               then
                  foreach item in prefixlist do
                     assgnpri(cdr item,list car item,'last)
               else
               << nat:=!*nat; !*nat:=nil;
                  assgnpri(append(list('list),
                           for each item in prefixlist
                            collect list('setq,car item,cdr item)),
                         nil,'last);
                  !*nat:=nat;
                  terpri();%write ";end;";  % done by nat being off.
                                            % JB 15/3/94
               >>
            >>
end;

symbolic procedure printdecs;
% ------------------------------------------------------------------- ;
% A list of declarations is printed.                                  ;
% ------------------------------------------------------------------- ;
begin
   scalar typ;
   terpri!* t;
   for each typelist in formtypelists symtabget('!*main!*, '!*decs!*)
   do << if !*double then
         << typ:=assoc(car typelist,
                   '((real . double! precision) (complex . complex!*16)
                    (implicit! real . implicit! double! precision)
                    (implicit! complex . implicit! complex!*16)));
            typ:=if null typ then car typelist else cdr typ
         >>
         else
            typ:=car typelist;
         prin2!* typ;
         prin2!* " ";
         inprint('!*comma!*, 0, cdr typelist);
         terpri!* t
      >>
end;

global '(!*ftch);
switch ftch;
!*ftch:='t;

symbolic procedure makeprefixl(pp,prefixlist);
% ------------------------------------------------------------------- ;
% If the finishing touch is appropriate, i.e. if OFF AGAIN holds      ;
% PREPFINALPLST is called before producing PREFIXLIST using a FOREACH ;
% statement. If the optimization attempts have to be continued during ;
% another session(i.e. ON AGAIN) SAVECSEINFO is called to guarantee   ;
% all relevant cse-information to be saved.                           ;
% ------------------------------------------------------------------- ;
begin scalar b,kvl,nex,xx;
  if not(!*again)
     then prepfinalplst();
  for x:=0:rowmax do setfree(x);

  kvl:=kvarlst;

  foreach bex in reverse(codbexl!*) do
  <>;                                         % --------------------- ;
  % ----------------------------------------------------------------- ;
  % Possibly, information about primitive factors of the form         ;
  % ('EXPT  ) as given in the list     ;
  % PrePrefixlist is put in front of Prefixlist.                      ;
  % ----------------------------------------------------------------- ;
  kvarlst:=kvl;
  prefixlist:=reverse prefixlist;
  if !*optdecs or !*gentranopt then
     prefixlist:=removearraysubstitutes(prefixlist);
  prefixlist:=cleanupprefixlist(prefixlist);
  if !*sidrel then prefixlist:=evalpartprefixlist(prefixlist);
  if !*again then prefixlist:=savecseinfo(prefixlist);
  return prefixlist
end$

global '(!*min!-expr!-length!*)$
!*min!-expr!-length!*:=nil$

symbolic procedure prepfinalplst;
% ------------------------------------------------------------------- ;
% The refinements defined by this procedure - the socalled finishing  ;
% touch - are only applied directly before producing the final version;
% of the output, i.e. the optimized version of the input.             ;
% These refinements are:                                              ;
% - POWEROFSUMS (see module CODAD2): Replace (a+b+...)^intpower by    ;
%                                   cse1=(a+b+...),cse1^intpower.     ;
% - CODGCD     (see module CODAD2): Replace 4.a+2.b+2.c+4.d by        ;
%                                   2.(2.(a+d)+b+c),where a,b,c,d can ;
%                                   be composite as well.             ;
% - REMREPMULTVARS (see   CODAD2) : Replace 3.a+b,3.a+c by            ;
%                                   cse3=3.a,cse3+b,cse3+c.           ;
% - UPDATEMONOMIALS (see  CODAD2) : Replace 3.a.b, 3.a.c., 6.a.d,     ;
%                                   6.a.f by                          ;
%                                   cse4=3.a, cse4.b, cse4.c, cse5=6.a;
%                                   cse5.d, cse5.f.                   ;
% ------------------------------------------------------------------- ;
begin scalar n;
  if (!*vectorc or !*sidrel or not !*ftch
               or not null(min!-expr!-length!*)) % HvH 8/11/94
     then  codgcd()
     else << repeat
             << n:=rowmax;
                powerofsums();
                remrepmultvars();
                updatemonomials();
                codgcd();
                if not(n=rowmax) then optimizeloop()
             >> until n=rowmax;
             preppowls()
          >>;
  if not !*ftch and optlang!*='c then preppowls()
  % ----------------------------------------------------------------- ;
  % PREPPOWLS (see module CODPRI, part 2) serves to create addition   ;
  % chains for integer powers, such as cse1^intpower (due to          ;
  % POWEROFSUMS) and cse4=a^3 (produced by UPDATEMONOMIALS).          ;
  % ----------------------------------------------------------------- ;
end;

symbolic procedure savecseinfo(prefixlist);
% ------------------------------------------------------------------- ;
% If ON AGAIN then cse-information have to be saved. This is done by  ;
% extending PREFIXLIST resulting in:                                  ;
% ((CSES.cses) (GSYM.gsym) PREFIXLIST) or                             ;
% ((CSES.cses) (BINF.binf) PREFIXLIST).                               ;
% Here                                                                ;
% CSES=first cse nsme[+...+ last cse name],                           ;
% GSYM=GENSYM(), if GENSYM has been used for cse-name generation,     ;
%      because we do not want to generate identical cse-names during a;
%      next run when using GENSYM.                                    ;
%      If GENSYM is not used then we create                           ;
% BINF=first initial cse-name[+...+ last initial cse-name],thus saving;
%      the Bnlst.                                                     ;
% ------------------------------------------------------------------- ;
begin scalar cses,gsym,binf;
 foreach item in prefixlist do
  if pairp(item) and flagp( car(item),'newsym)
    then cses:=car(item).cses;
  if pairp(cses) then if cdr(cses) then cses:='plus.cses
                                   else cses:=car cses;
  prefixlist:=('cses.cses).prefixlist;
  return if cses
            then ('gsym . fnewsym()) . prefixlist
            else ('gsym . gensym()) . prefixlist
end;

symbolic operator iname;

symbolic procedure iname(nm);
% ------------------------------------------------------------------- ;
% Construction of initial cse-name, extension of Bnlst and creation of;
% NEWSYM procedure via MOVD and using NEWSYM1.                        ;
% If, for instance, the initial name is aa55 then NEWSYM1 generates   ;
% aa55, aa56 , aa57, etc.                                             ;
% ------------------------------------------------------------------- ;
  begin scalar digitl,dlst,nb,dg,initname;
      digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
                (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
      cname!*:=nil;
      dlst:=reverse explode nm;
      repeat
      <>
         else << cname!*:=reverse dlst;
                 cindex!*:=0;
                 dg:=length(nb);
                 for i:=1:dg do
                  <> >>
      >>
      until cname!* or null(dlst);
      if not getd('newsym) then movd('newsym,'newsym1);
      % ------------------------------------------------------------- ;
      % Bnlst is empty if INAME is used for the first time, i.e. if   ;
      % NEWSYM has to be identified with NEWSYM1.                     ;
      % ------------------------------------------------------------- ;
      initname:=newsym();
      cindex!*:=cindex!*-1;
%      bnlst:=initname.bnlst
end;

symbolic procedure movd(tod,fromd);
% ------------------------------------------------------------------- ;
% Transfer of a procedure description from Fromd to Tod.              ;
% ------------------------------------------------------------------- ;
begin scalar s;
  s:=getd(fromd);
  putd(tod,car s,cdr s);
end;

symbolic procedure newsym1();
% ------------------------------------------------------------------- ;
% Global variables:                                                   ;
% cname!* is exploded letterpart of current cse-name.                 ;
% cindex!* is current cse-index.                                      ;
% ------------------------------------------------------------------- ;
  begin scalar x;
        x:=explode cindex!*;
        cindex!*:=cindex!*+1;
        return compress append(cname!*,x)
  end;

symbolic procedure fnewsym;
begin scalar x;
  if getd('newsym)
   then x:=newsym()
   else << x:=gensym();
           x:=compress(append(explode(letterpart(x)),
                              explode(digitpart(x))))
        >>;
   x:=intern(x); % May be necessary for some REDUCE systems;
  flag(list x,'newsym);
  return x;
end;

symbolic procedure letterpart(name);
% ------------------------------------------------------------------- ;
% Eff: Letterpart of Name returned,i.e. aa of aa55.                   ;
% ------------------------------------------------------------------- ;
begin scalar digitl,letters,el;
    digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
                (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
    letters:=reverse explode name;
    while (el := assoc(car letters,digitl)) and numberp cdr el do
      << letters:=cdr letters >>;
    return intern compress reverse letters;
end;

symbolic procedure digitpart(name);
% ------------------------------------------------------------------- ;
% Eff: Digitpart of Name returned,i.e. 55 of aa55.                    ;
% ------------------------------------------------------------------- ;
begin scalar digitl,nb,dg,dlst;
   digitl:='((!1 . 1) (!2 . 2) (!3 . 3) (!4 . 4) (!5 . 5)
                (!6 . 6) (!7 . 7) (!8 . 8) (!9 . 9) (!0 . 0));
   dlst:= reverse explode name;
   nb:=nil;
   while (dg:=assoc(car dlst,digitl)) and numberp(dg := cdr dg) do
     << dlst:=cdr dlst; nb:=dg.nb >>;
   dg:=0;
   foreach digit in nb do dg:=10*dg+digit;
   return dg;
 end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codmat.red0000644000175000017500000022123711526203062023567 0ustar  giovannigiovannimodule codmat;  %  Support for matrix optimization.

% -------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer    ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands. ;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden,   ;
%             J.C.A. Smit, W.N. Borst.                                 ;
% -------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% -------------------------------------------------------------------- ;
% The module CODMAT consists of two parts:                             ;
%  1 - A collection of Extended Access Functions to the CODMAT-matrix  ;
%      and the associated hashvector CODHISTO.                         ;
%  2 - Routines for constructing the incidence matrix CODMAT via par-  ;
%      sing and storage of a set of input expressions.                 ;
%  3 - Routines for removing gcd's from quotients.                     ;
% -------------------------------------------------------------------- ;
%                                                                      ;
% -------------------------------------------------------------------- ;
% PART 1 : EXTENDED ACCESS FUNCTIONS                                   ;
% -------------------------------------------------------------------- ;
%                                                                      ;
% These functions allow to STORE,RETRIEVE or MODIFY information stored ;
% in CODMAT and CODHISTO, used for hashing.                            ;
% Remark:A detailed description of the vectors CODMAT and CODHISTO and ;
% their DIRECT ACCESS FUNCTIONS, heavily used here, is given in the    ;
% module COSYMP.                                                       ;
%                                                                      ;
% ------ A CLASSIFICATION OF THE EXTENDED ACCESS FUNCTIONS ------      ;
%                                                                      ;
% - STORAGE : SetRow,InsZZZ,InsZZZn,InsZZZr,PnthXZZ.                   ;
% - HISTOGRAM OPERATIONS : InsHisto,DelHisto,Downwght,Downwght1,Upwght,;
%   Upwght1,Initwght.                                                  ;
% - MODIFICATION : Rowdel,Rowins,RemZZZZ,Chdel,DelYZZ,Clearrow.        ;
% - PRINTING TESTRUNS : ChkCodMat.                                     ;
%                                                                      ;
% ------ TERMINOLOGY USED ------                                       ;
% ZZ stands for a Zstrt and Z for a single item in ZZ.  A Zstrt is a   ;
% list of pairs (row(column)index . coeff(exponent)information).Hence a;
% double linked list representation is used. Both X and Y denote indi- ;
% ces.The Cdr-part of a Z-element is in fact again a dotted pair (IVal.;
% BVal). The BValue however is only used in CODPRI.RED for printing    ;
% purposes,related to the finishing touch. Therefore we only take IVal ;
% as Cdr-part in the                                                   ;
% Example :                               +| a b c d                   ;
%  Let                                    -+---------                  ;
%  f =  a + 2*b + 3*c                     f| 1 2 3                     ;
%  g =2*a + 4*b + 5*d                     g| 2 4   5                   ;
%                                                                      ;
% Taking MaxVar=4 results in :                                         ;
%                                                                      ;
% CODMAT index=|I| |Zstrt ZZ            |                              ;
% -------------+-+-+--------------------+----------------------------- ;
% .......      | | |                    |Rows: Structure created by    ;
% .......      | | |                    |Fvar or FFvar using I=MaxVar+ ;
% .......      | | |                    |RowMax (See Row and FillRow,  ;
% Rowmax= 1    |5|g|((-4.5)(-2.4)(-1.2))|defined in module COSYMP      ;
% Rowmax= 0    |4|f|((-3.3)(-2.2)(-1.1))|and used in SETROW).          ;
% -------------+-+-+--------------------+----------------------------- ;
% Rowmin=-1    |3|a|((1.2)(0.1))        |Columns:Created by SSetVars(  ;
% Rowmin=-2    |2|b|((1.4)(0.2))        |part 2 of this module) : I=   ;
% Rowmin=-3    |1|c|((0.3))             |Maxvar+Rowmin. The Zstrts of  ;
% Rowmin=-4    |0|d|((1.5))             | the rows are also completed  ;
% .......      | | |                    | by SSetvars.                 ;
% -------------------------------------------------------------------- ;
%                                                                      ;
% Remarks :                                                            ;
% -1- The CODMAT index I used in the above example is thus the physical;
%     value of the subscript. This in contrast to the indices used when;
%     calling routines like SETROW, which operate on Rowmax or Rowmin  ;
%     values (details are given in CODCTL.RED and in the routine ROW in;
%     COSYMP.RED).                                                     ;
% -2- A similar picture is produced for f=a*b^2*c^3 and g=a^2*b^4*d^5. ;
%     When introducing monomials as terms or sum as factors also the   ;
%     Child-facilities have to be used like done for operators other   ;
%     than + or *.                                                     ;
% -------------------------------------------------------------------- ;

symbolic$

global '(codmat maxvar rowmin rowmax endmat codhisto headhisto
         !*vectorc !*inputc known rhsaliases);

fluid '(preprefixlist prefixlist);

switch vectorc$

!*vectorc := nil$

% ____________________________________________________________________ ;
% A description of these globals is given in the module CODCTL         ;
% -------------------------------------------------------------------- ;

symbolic procedure setrow(n,op,fa,s,zz);
% -------------------------------------------------------------------- ;
% arg : N : Row(column)index of the row(column) of which the value has ;
%           to be (re)set. Physically we need MaxVar + N(see ROW in    ;
%           COSYMP.RED).                                               ;
%       Op: Operator value to be stored in Opval,i.e. 'PLUS,'TIMES or  ;
%           some other operator.                                       ;
%       Fa: For a row the name (toplevel) or index (subexpression) of  ;
%           the father.For a column the template of the column variable;
%       S : Compiled code demands atmost 5 parameters,atleast for some ;
%           REDUCE implementations. Therefore S stands for a list of   ;
%           Chrow information,if necessary extended with the monomial  ;
%           coefficient(Opval='TIMES) or the exponent of a linear ex-  ;
%           pression(Opval='PLUS),to be stored in the CofExp-field.    ;
%       ZZ: The Z-street.                                              ;
% eff : Row(column) N is created and set. If necessary,i.e. if N>MaxVar;
%       then CODMAT is doubled in size.                                ;
% -------------------------------------------------------------------- ;
begin scalar codmat1;
  if abs(n)>maxvar
  then % Double the size of CODMAT.
    <>;
 % --------------------------------------------------------------------;
 % Now the values are set,using LenCol=4 and LenRow=8,i.e. the fields  ;
 % Chrow,CofExp,HiR and Ordr are not in use for columns because:       ;
 % - Chrow and CofExp are irrelevant for storing information about     ;
 %   variable occurrences.                                             ;
 % - Hashing(HiR) and CSE-insertion(Ordr) are based on row-information ;
 %   only.                                                             ;
 % --------------------------------------------------------------------;
  if n<0
  then fillrow(n,mkvect lencol)
  else
  <>;
  setfree(n);
  setopval(n,op);
  setfarvar(n,fa);
  setzstrt(n,zz)
end;

symbolic procedure inszzz(z,zz);
% -------------------------------------------------------------------- ;
% arg : Z : A matrix element.                                          ;
%       ZZ: A set of matrix elements with indices in descending order. ;
% eff : A set of matrix elements including Z and ZZ,again in ascending ;
%       order,such that in case Z's index already exists the Ival-     ;
%       parts of both elements are added together.                     ;
% -------------------------------------------------------------------- ;
if null zz or xind(car zz)>
  else car(zz).inszzz(z,cdr zz);

symbolic procedure inszzzn(z,zz);
% -------------------------------------------------------------------- ;
% eff : Similar to InsZZZ.However,Z is only inserted if its index is   ;
%       not occuring as car-part of one of the elements of ZZ.         ;
% -------------------------------------------------------------------- ;
if null(zz) or xind(car zz)xind(z)
then z.zz
else
  if xind(car zz)=xind(z)
  then <>
  else car(zz).inszzzr(z,cdr zz);

symbolic procedure pnthxzz(x,zz);
% -------------------------------------------------------------------- ;
% arg : X is a row(column)index and ZZ a Z-street.                     ;
% res : A sublist of ZZ such that Caar ZZ = X.                         ;
% -------------------------------------------------------------------- ;
if null(zz) or xind(car zz)=x
then zz
else pnthxzz(x,cdr zz);

symbolic procedure inshisto(x);
% -------------------------------------------------------------------- ;
% arg : Rowindex X.                                                    ;
% eff : X is inserted in the Histogram-hierarchy.                      ;
%                                                                      ;
% The insertion can be vizualized in the following way :               ;
%                                                                      ;
%    CODHISTO                 CODMAT                                   ;
%                                                                      ;
% index  value      Row Hwght      HiR                                 ;
%  200   +---+      index     (PHiR . NHiR)                            ;
%        |   |      .   .   .                                          ;
%        :   :      :   :   :                                          ;
%        |   |      :   :   :                                          ;
%        +---+      |   |   |                                          ;
%   i    | k | <--> +---+---+---------------+                          ;
%        +---+      | k | i |   Nil .  m    |                          ;
%        |   |      +---+---+---------------+                          ;
%        :   :      |   |   |               |                          ;
%        |   |      :   :   :               :                          ;
%        +---+      |   |   |               |                          ;
%   0    |   |      +---+---+---------------+                          ;
%        +---+      | m | i |     k .  p    |                          ;
%                   +---+---+---------------+                          ;
%                   |   |   |               |                          ;
%                   :   :   :               :                          ;
%                   |   |   |               |                          ;
%                   +---+---+---------------+                          ;
%                   | p | i |     m . Nil   |                          ;
%                   +---+---+---------------+                          ;
%                   :   :   :               :                          ;
%                                                                      ;
% -------------------------------------------------------------------- ;
if free(x) and x>=0
then
begin scalar y,hv;
  if y:=histo(hv:=min(hwght x,histolen))
  then setphir(y,x)
  else
    if hv>headhisto
    then headhisto:=hv;
  sethir(x,nil.y);
  sethisto(hv,x)
end;

symbolic procedure delhisto(x);
% -------------------------------------------------------------------- ;
% arg : Rowindex X.                                                    ;
% eff : Removes X from the histogram-hierarchy.                        ;
% -------------------------------------------------------------------- ;
if free(x) and x>=0
then
begin scalar y,z,hv;
  y:=phir x;
  z:=nhir x;
  hv:=min(hwght(x),histolen);
  if y then setnhir(y,z) else sethisto(hv,z);
  if z then setphir(z,y);
end;

symbolic procedure rowdel x;
% -------------------------------------------------------------------- ;
% arg : Row(column)index X.                                            ;
% eff : Row X is deleted from CODMAT. SetOccup ensures that row X is   ;
%       disregarded until further notice. Although the Zstrt remains,  ;
%       the weights of the corresponding columns are reset like the    ;
%       Histogram info.                                                ;
% -------------------------------------------------------------------- ;
<>;

symbolic procedure rowins x;
% -------------------------------------------------------------------- ;
% arg : Row(column)index X.                                            ;
% eff : Reverse of the Rowdel operations.                              ;
% -------------------------------------------------------------------- ;
<>;

symbolic procedure downwght(x,iv);
% -------------------------------------------------------------------- ;
% arg : Row(column)index X. Value IV.                                  ;
% eff : The weight of row X is adapted because an element with value IV;
%       has been deleted.                                              ;
% -------------------------------------------------------------------- ;
<>;

symbolic procedure downwght1(x,iv);
% -------------------------------------------------------------------- ;
%  eff : Weight values reset in accordance with defining rules given in;
%        COSYMP.RED and further argumented in CODOPT.RED.              ;
% -------------------------------------------------------------------- ;
if not(!:onep dm!-abs(iv))
then setwght(x,((awght(x)-1).(mwght(x)-1)).(hwght(x)-4))
else setwght(x,((awght(x)-1).mwght(x)).(hwght(x)-1));

symbolic procedure upwght(x,iv);
% -------------------------------------------------------------------- ;
% arg : Row(column)index X. value IV.                                  ;
% eff : The weight of row X is adapted because an element with value IV;
%       is brought into the matrix.                                    ;
% -------------------------------------------------------------------- ;
<>;

symbolic procedure upwght1(x,iv);
% -------------------------------------------------------------------- ;
%  eff : Functioning similar to Downwght1.                             ;
% -------------------------------------------------------------------- ;
if not(!:onep dm!-abs(iv))
then setwght(x,((awght(x)+1).(mwght(x)+1)).min(hwght(x)+4,histolen))
else setwght(x,((awght(x)+1).mwght(x)).min(hwght(x)+1,histolen));

symbolic procedure initwght(x);
% -------------------------------------------------------------------- ;
% arg : Row(column)index X.                                            ;
% eff : The weight of row(column) X is initialized.                    ;
% -------------------------------------------------------------------- ;
begin scalar an,mn;
  an:=mn:=0;
  foreach z in zstrt(x) do
  if free(xind z)
  then
  << if not(!:onep dm!-abs(ival z)) then mn:=mn+1;
     an:=an+1>>;
  setwght(x,(an.mn).(an+3*mn));
end;

symbolic procedure remzzzz(zz1,zz2);
% -------------------------------------------------------------------- ;
% arg : Zstrt ZZ1 and ZZ2, where ZZ1 is a part of ZZ2.                 ;
% res : All elements of ZZ2, without the elements of ZZ2.              ;
% -------------------------------------------------------------------- ;
if null(zz1)
then zz2
else
  if yind(car zz1)=yind(car zz2)
  then remzzzz(cdr zz1,cdr zz2)
  else car(zz2).remzzzz(zz1,cdr zz2);

symbolic procedure chdel(fa,x);
% -------------------------------------------------------------------- ;
% arg : Father Fa of child X.                                          ;
% eff : Child X is removed from the Chrow of Fa.                       ;
% -------------------------------------------------------------------- ;
setchrow(fa,delete(x,chrow fa));

symbolic procedure delyzz(y,zz);
% -------------------------------------------------------------------- ;
% arg : Column(row)index Y. Zstrt ZZ.                                  ;
% res : Zstrt without the element corresponding with Y.                ;
% -------------------------------------------------------------------- ;
if y=yind(car zz)
then cdr(zz)
else car(zz).delyzz(y,cdr zz);

symbolic procedure clearrow(x);
% -------------------------------------------------------------------- ;
% arg : Rowindex X.                                                    ;
% eff : Row X is cleared. This can be recognized since the father is   ;
%       set to -1.                                                     ;
% -------------------------------------------------------------------- ;
<=0
  then
  <>;
  setwght(x,nil);
  setfarvar(x,-1)
>>;

% -------------------------------------------------------------------- ;
% PART 2 : PROCEDURES FOR THE CONSTRUCTION OF THE MATRIX CODMAT,i.e.   ;
%          FOR INPUT PARSING                                           ;
% -------------------------------------------------------------------- ;
%                                                                      ;
% ------ GENERAL STRATEGY ------                                       ;
% REDUCE assignment statements of the form "Nex:=Expression" are trans-;
% formed into pairs (Nex,Ex(= prefixform of the Expression)), using    ;
% GENTRAN-facilities.The assignment operator := defines a literal trans;
% lation of  both Nex and Ex. Replacing this operator by :=: results in;
% translation of the simplified form of Ex. When taking ::=: or ::= the;
% Nex is evaluated before translation, i.e. the subscripts occurring in;
% Nex are evaluated before the translation is performed.               ;
% Once input reading is completed(i.e. when calling CALC) the data-    ;
% structures can and have to be completed (column info and the like)   ;
% using SSETVARS (called in OPTIMIZE (see CODCTL.RED)) before the CSE- ;
% search actually starts.                                              ;
%                                                                      ;
% ------ PRESUMED EXPRESSION STRUCTURE ------                          ;
% Each expression is considered to be an (exponentiated) sum,a product ;
% or something else and to consist of an (eventually empty) primitive  ;
% part and an (also eventually empty) composite part. The primitive    ;
% part of a sum is a linear combination of atoms(variables) and its    ;
% composite part consists of terms which are products or functions. The;
% primitive part of a product is a monomial in atoms and its composite ;
% part is formed by factors which are again expressions(Think of OFF   ;
% EXP).Primitive parts are stored in Zstrts as lists of pairs (RCindex.;
% COFEXP). Composite parts are stored in and via Chrows.               ;
% The RCindex denotes a Row(Column)index in CODMAT if the Zstrt defines;
% a column(row). Rows describe primitive parts. Due to the assumption  ;
% that the commutative law holds column information is not completely  ;
% available as long as input processing is not finished.               ;
% Conclusion : Zstrts cannot be completed (by SSETVARS in CALC or in   ;
% HUGE (see CODCTL.RED)) before input processing is completed,i.e.tools;
% to temporarily store Zstrt info are required. They consist of certain;
% lists,which are built up during parsing, being :                     ;
% The identifiers Varlst!+, Varlst!*  and Kvarlst play a double role.  ;
% They are used as indicators in certain propertylists and also as glo-;
% bal variables carrying information during parsing and optimization.  ;
% To distinguish between these two roles we quote the indicator name   ;
% in the comment given below.                                          ;
% -- Varlst!+  : A list of atoms occuring in primitive sum parts of the;
%                input expressions,i.e. variables used to construct the;
%                sum part of CODMAT.                                   ;
% -- 'Varlst!+ : The value of this indicator,associated with each atom ;
%                of Varlst!+, is a list of dotted pairs (X,IV),where X ;
%                is a rowindex and IV a coefficient,i.e.IV*atom occurs ;
%                as term of a primitive part of some input expression  ;
%                defined by row X.                                     ;
% -- Varlst!*  : Similar to Varlst!+ when replacing the word sum by mo-;
%                nomial and the word coefficient by exponent.          ;
% -- 'Varlst!* : The value of this indicator,occuring on the property  ;
%                list of each element of Varlst!*, is  a list of dotted;
%                pairs of the form (X.IV),where X is a rowindex and IV ;
%                an exponent,i.e. atom^IV occurs as factor in a mono-  ;
%                mial,being a primitive (sub)product,defined through   ;
%                row X.                                                ;
% Remark : Observe that it is possible that an atom possesses both     ;
% 'Varlst!+ and 'Varlst!*,i.e. plays a role in the + - and in the * -  ;
% part of CODMAT.                                                      ;
% -- Kvarlst   : A list of dotted pairs (var.F),where var is an identi-;
%                fier (system selected via FNEWSYM,if necessary) and   ;
%                where F is a list of the form (Functionname . (First  ;
%                argument ... Last argument)). The arguments are either;
%                atoms or composite,and in the latter case replaced by ;
%                a system selected identifier. This identifier is asso-;
%                ciated with the CODMAT-row which is used to define the;
%                composite argument.                                   ;
%                Remark : Kvarlst is also used in CODPRI.RED to guaran-;
%                tee the F's to be printed in due time,i.e.directly    ;
%                after all its composite arguments.                    ;
% -- 'Kvarlst  : This indicator is associated with each operator name  ;
%                during input processing. Its value consists of a list ;
%                of pairs os the form (F.var). To avoid needless name- ;
%                selections this list if values is consulted whenever  ;
%                necessary to see of an expression of the form F is    ;
%                already associated with a system selected identifier. ;
%                As soon as input processing is completed the 'Kvarlst ;
%                values are removed.                                   ;
% -- Prevlst   : This list is also constructed during input processing.;
%                It is a list of dotted pairs (Father.Child),where     ;
%                Child is like Father a rowindex or a system selected  ;
%                identifier name. Prevlst is employed,using SETPREV,to ;
%                store in the ORDR-field of CODMAT-rows relevant info  ;
%                about the structure of the input expressions. During  ;
%                the iterative CSE-search the ORDR-info is updated when;
%                ever necessary.                                       ;
% -- CodBexpl!*: A list consisting of CODMAT-row indices associated    ;
%                with input expression toplevel(i.e. the FarVar-field  ;
%                contains the expression name).                        ;
%                This list is used on output to obtain a correct input ;
%                reflection (see procedures MAKEPREFIXL and PRIRESULT  ;
%                in CODCTL.RED).                                       ;
%                                                                      ;
% ------ PARSING PATHS and PROCEDURE CLASSIFICATION ------             ;
% A prefix-form parsing is performed via FFVAR!!,FFVAR!* and FFVAR!+.  ;
% During parsing,entered via FFVAR!!, the procedure FVAROP is used to  ;
% analyse and transform functions( Operators in the REDUCE terminology);
% and thus also to construct Kvarlst and Prevlst. FVAROP is indirectly ;
% activated through the routines PVARLST!* and PVARLST!+, which assist ;
% in preparing (')Varlst!* and (')Varlst!+,respectively.               ;
% FCOFTRM ,assisting in detecting prim.parts, is used in FFVAR!!2.     ;
% PPRINTF is used (in FFVAR!!) to obtain an input echo on the terminal ;
% (when ON ACINFO, the default setting, holds).                        ;
% RESTORECSEINFO serves to restore the CSE-info when combining the re- ;
% sult of a previous session with the present one( see also CODCTL.RED);
% SSETVARS,and thus SSETVARS1, serves to complete CODMAT once input    ;
% processing is finished. PREPMULTMAT is used to preprocess *-columns  ;
% if one of the exponents, occuring in it, is rational, i.e. when the  ;
% with this column corresponding indentifier has the flag Ratexp.      ;
% SETPREV is used for maintaining consistency in input expression orde-;
% ring and thus for consequent information retrieval at a later stage, ;
% such as during printing.                                             ;
% -------------------------------------------------------------------- ;
global '(varlst!+ varlst!* kvarlst prevlst codbexl!* )$
fluid '(preprefixlist prefixlist);

varlst!+:=varlst!*:=kvarlst:=nil;

% -------------------------------------------------------------------- ;
% ------ THE PREFIX FORM PARSING  ------                               ;
% FFvar!! is the main procedure activating parsing. Besides some house-;
% keeping,information is send to either FFvar!* (either a product (but ;
% not a prim. term) or a 'EXPT-application) or FFvar!+(a  sum or a     ;
% function application).                                               ;
% The parsing is based on the following Prefix-Form syntax:            ;
% -------------------------------------------------------------------- ;
% This syntax needs some revision!!!                                   ;
% -------------------------------------------------------------------- ;
%            ::= |                   ;
%               ::= |('EXPT  )            ;
%           ::= |                                ;
%                            ('TIMES  )|             ;
%                            ('TIMES  )|    ;
%                            ('MINUS )                    ;
%                   ::= |('PLUS.)            ;
%         ::= ( )|( )  ;
%                  ::= ||  ;
%        ::= ||                    ;
%                            ('TIMES  )|           ;
%                                                ;
%               ::= |('TIMES.)       ;
%       ::= ( )|( );
%                ::= ||;
%      ::= |('EXPT  )| ;
%                                                ;
%  ::= .   ;
%       ::= identifier, where identifier is not       ;
%                            in {'PLUS,'TIMES,'EXPT,'MINUS,'DIFFERENCE,;
%                                'SQRT,dmode!*}.                       ;
%                            Obvious elements are sin,cos,tan,etc.     ;
%                            The function applications are further     ;
%                            analyzed in FvarOp.                       ;
%   ::= ()|.;
%              ::= element of the set of variable names,     ;
%                            either delivered as input or produced by  ;
%                            the Optimizer when the need to introduce  :
%                            cse-names exists. This is done with the   ;
%                            procedure FNewSym(see CODCTL.RED) which is;
%                            initiated either using the result of the  ;
%                            procedure INAME(see CODCTL.RED) or simply ;
%                            by using GENSYM().                        ;
%              ::= element of the set of integers            ;
%                            representable by REDUCE | domain element  ;
%              ::= element of the set of integer an rational ;
%                            numbers representable by REDUCE.          ;
% -------------------------------------------------------------------- ;

symbolic procedure ffvar!!(nex,ex,prefixlist);
% -------------------------------------------------------------------- ;
% arg : An expression Ex in Prefix-Form, and its associated name NEx.  ;
% eff : The expression Ex is added to the incidence matrix CODMAT.     ;
%       Parsing is based on the above given syntax.                    ;
% -------------------------------------------------------------------- ;
begin scalar n, nnex, argtype, var, s;
 prefixlist:=cons(nex,ex).prefixlist;
% if nex memq '(cses gsym)     % deleted : binf no more used. JB 13/4/94
% then restorecseinfo(nex,ex)
 n:=rowmax:=rowmax+1;
 codbexl!*:=n.codbexl!*;
 if flagp(nex,'newsym)
    then put(nex,'rowindex,n);
 put(nex,'rowocc, list n);
 ffvar!!2(n,nex,remdiff ex);
 return prefixlist
end;


symbolic procedure restorecseinfo(nex,ex);
% -------------------------------------------------------------------- ;
% arg : Nex is an element of the set {CSES,GSYM,BINF} and Ex a corres- ;
%       pondig information carrier.                                    ;
% eff : RestoreCseInfo is called in FFvar!! when during input parsing  ;
%       name Nex belongs to the above given set. In this case the input;
%       is coming from a file which is prepared during a previous run. ;
%       It contains all output from this previous run, preceded by     ;
%       system prepared cse-info stored as value of the 4 system       ;
%       variables CSES,GSYM and BINF (see the function SaveCseInfo  in ;
%       CODCTL.RED for further information).                           ;
% -------------------------------------------------------------------- ;
begin scalar inb,nb,s;
if nex eq 'cses
 then (if atom(ex) then flag(list ex,'newsym)
                   else foreach el in cdr(ex) do flag(list el,'newsym))
 % Ammendments to increase robustness:
 % More strict control over what cse-name is going to be used,
 % starting from which index.
 % This prevents scope from generating a cse twice, thus overwriting
 % earlier occurrences and introducing strange erronous output.
 %                                                           JB 13/4/94
 else if eq(letterpart(ex),'g)
         then if eq((s:=letterpart fnewsym()),'g)
                 then iname s
                 else<< nb:=digitpart(ex);
                       inb:=digitpart(fnewsym());
                       for j:=inb:nb do gensym() >>
         else if eq(letterpart(ex), letterpart(s:= fnewsym())) and
                 digitpart(ex) > digitpart(s)
                 then iname ex
                 else iname s
end;

symbolic procedure remdiff f;
% -------------------------------------------------------------------- ;
% Replace all occurrences of (DIFFERENCE A B) in F for arbitrary A and ;
% B by (PLUS A (MINUS B)).                                             ;
% -------------------------------------------------------------------- ;
if idp(f) or constp(f) then f
 else
 << if car(f) eq 'difference
   then f:=list('plus,remdiff cadr f,list('minus,remdiff caddr f))
   else car(f) . (foreach op in cdr(f) collect remdiff(op))
 >>;

symbolic procedure ffvar!!2(n, nex, ex);
% -------------------------------------------------------------------- ;
% Serviceroutine used in FFvar!!.                                      ;
% -------------------------------------------------------------------- ;
  if eqcar(ex, 'times) and not fcoftrm ex
   then setrow(n, 'times, nex, ffvar!*(cdr ex, n), nil)
   else
    if eqcar(ex, 'expt) and (integerp(caddr ex) or rationalexponent(ex))
     then setrow(n, 'times, nex, ffvar!*(list ex, n), nil)
     else setrow(n, 'plus, nex, ffvar!+(list ex, n), nil);

symbolic procedure fcoftrm f;
% -------------------------------------------------------------------- ;
% arg : A prefix form F.                                               ;
% res : T if F is a (simple) term with an integer coefficient, NIL     ;
%       otherwise.                                                     ;
% -------------------------------------------------------------------- ;
(null(cdddr f) and cddr f) and
(constp(cadr f) and not (pairp(caddr f) and
      caaddr(f) memq '(expt times plus difference minus)));

symbolic procedure rationalexponent(f);
% -------------------------------------------------------------------- ;
% arg : F is an atom or a  prefixform.                                 ;
% res : T if F is an 'EXPT with a rational exponent.                   ;
% -------------------------------------------------------------------- ;
   rationalp caddr f;
%(pairp caddr f) and (caaddr f eq 'quotient) and (integerp(cadr caddr f)
%                                          and integerp(caddr caddr f));

symbolic procedure rationalp f;
   eqcar(f,'quotient) and integerp(cadr f) and integerp(caddr f);

symbolic procedure ffvar!+(f,ri);
% -------------------------------------------------------------------- ;
% arg : F is a list of terms,i.e. th sum SF='PLUS.F is parsed. Info    ;
%       storage starts in row RI resulting in                          ;
% res : a list (CH) formed by all the indices of rows where the descrip;
%       tion of children(composite terms) starts. As a by product(via  ;
% eff : PVARLST!+) the required Zstrt info is made.                    ;
% N.B.: Possible forms for the terms of SF( the elements of F) are:    ;
%       -a sum     - which is recursively managed after minus-symbol   ;
%                    distribution.                                     ;
%       -a product - of the form constant*atom : which is as term of a ;
%                    prim. sum treated by PVARLST!+.                   ;
%                    of another form : which is managed via FFVAR!*.   ;
%       -a constant                                                    ;
%            power - of a product of atoms : is transformed into a prim;
%                    product and then treated as such.                 ;
%                    of something else : is always parsed via FFVAR!*. ;
%       -a function- application is managed via PVARLST!+,i.e. via     ;
%                    FVAROP with additional Varlst!+ storage of system ;
%                    selected subexpression names.                     ;
% -------------------------------------------------------------------- ;
begin scalar ch,n,s,b,s1,nn;
  foreach trm in f do
  <>;
    if s eq 'difference
     then
     <>
     else
      if s eq 'times
     then
      <<% ------------------------------------------------------------ ;
        % Trm is a , which might have the form            ;
        % ('TIMES  ). Here the         ;
        %  can be ('SQRT ) , i.e. has;
        %  to be changed into :                                        ;
        % ('TIMES  ('EXPT  ('QUOTIENT 1 2)))     ;
        % ------------------------------------------------------------ ;
        if pairp caddr trm and caaddr trm eq 'sqrt and null cdddr trm
        then
          trm := list('times,cadr trm,list('expt,cadr caddr trm,
                                                  list('quotient,1,2)));
        if fcoftrm trm
          % ---------------------------------------------------------- ;
          % Trm is ('TIMES  )                      ;
          % ---------------------------------------------------------- ;
         then pvarlst!+(caddr trm,ri,if b then dm!-minus(cadr trm)
                                          else cadr trm)
         else
          % ---------------------------------------------------------- ;
          % Trm is a                                      ;
          % ---------------------------------------------------------- ;
         <>
        >>
        else
        < which is a ;
          % which is ('SQRT ) which is of course           ;
          % ('EXPT  )                            ;
          % ---------------------------------------------------------- ;
          <>
          else pvarlst!+(trm,ri,if b then -1 else 1)
        >>;
  >>;
  return list(ch)
end;

symbolic procedure pvarlst!+(var,x,iv);
% -------------------------------------------------------------------- ;
% arg : Var is one of the first 2 alternatives for a kernel,i.e. a vari;
%       able or an operator with a simplified list of arguments (like  ;
%       sin(x)) with a coefficient IV,belonging to a Zstrt which will  ;
%       be stored in row X.                                            ;
% eff : If the variable happens to be a constant a special internal var;
%       !+ONE is introduced to assist in defining the constant contribu;
%       tions to primitive sumparts in accordance with the chosen data-;
%       structures.                                                    ;
%       When Var is an operator(etc.) Fvarop is used for a further ana-;
%       lysis and a system selected name for var is returned. Then this;
%       name,!+ONE or the variable name Var are used to eventually     ;
%       extend Varlst!+ with a new name.The pair (rowindex.coeff.value);
%       is stored on the property list of this var as pair of the list ;
%       'Varlst!+,which is used in SSETVARS1 to built the Zstrts associ;
%       ated with this variable.                                       ;
% -------------------------------------------------------------------- ;
begin scalar l,s,nvar;
  if constp var then <>
        else
         if s memq '(plus difference minus)
          then
           << if s eq 'minus and constp(cadr fac) and null cddr fac
               then cof:=dm!-minus dm!-times(cof,cadr(fac))
               else <>;
                      setrow(n,'plus,ri,ffvar!+(list fac,n),nil);
                      ch:=n.ch
                    >>
           >>
          else
          <. In this;
            % case a ('SQRT ) which is of course           ;
            % ('EXPT  ('QUOTIENT 1 2)).                    ;
            % -------------------------------------------------------- ;
            <                ;
                 %                       ) ;
                 % --------------------------------------------------- ;
             (if pairp(cadr fac) and caadr(fac) eq 'sqrt
               then
                << if nr then <>
                         else <>;
                   pvarlst!*(cadr cadr fac,ri,cons(nr,dm))
                >>
               else
                 pvarlst!*(cadr fac,ri,
                           if integerp(caddr fac)
                            then caddr fac
                            else (cadr caddr fac . caddr caddr fac)))
            else pvarlst!*(fac,ri,1)
          >>;
  if b and not(!:onep dm!-abs(cof))
   then
    % ---------------------------------------------------------------- ;
    % The product Cof*....*(c1*a+....+cn*z) is replaced by             ;
    % the product ....*({Cof*c1}*a+...+{Cof*cn}*z), assuming Cof, c1,..;
    % ..,cn are numerical constants.                                   ;
    % ---------------------------------------------------------------- ;
    << foreach el in chrow(rownr) do
           setexpcof(el,dm!-times(cof,expcof(el)));
       foreach var in varlst!+ do
                         if (pr:=assoc(rownr,get(var,'varlst!+)))
                          then rplacd(pr,dm!-times(cdr(pr),cof));
       cof:=1;
    >>;
  return list(ch,cof)
end;

symbolic procedure pvarlst!*(var,x,iv);
% -------------------------------------------------------------------- ;
%  eff : Similar to Pvarlst!+.                                         ;
%      : The flag Ratexp is associated with Var if one of its exponents;
%        is rational. This flag is used in the function PrepMultMat.   ;
% -------------------------------------------------------------------- ;
begin scalar l,s,bvar,bval;
 if constp(var)
  then
   << var:=fvarop(if iv='(1 . 2)
                   then list('sqrt,var)
                   else list('expt,var,
                              if pairp iv
                               then list('quotient,car iv,cdr iv)
                               else iv),x);
      iv:=1
   >>;
  if not(atom(var) or constp(var))
   then << s:=get('!*bases!*,'kvarlst);
           if s then bvar:=assoc(bval:=reval var,s);
           if bvar then var:=cdr bvar
                   else <<  var:=fvarop(var,x);
                            put('!*bases!*,'kvarlst,(bval.var).s)
                        >>
        >>;
 if null(s:=get(var,'varlst!*)) then varlst!*:=var.varlst!*;
 if pairp(iv) and not(constp iv) then flag(list(var),'ratexp);
 put(var,'varlst!*,(x.iv).s)
end;

symbolic procedure fvarop(f,x);
% ------------------------------------------------------------------- ;
% arg : F is a prefixform, being .. X is ;
%       the index of the CODMAT row where the description of F has to ;
%       start.                                                        ;
% ------------------------------------------------------------------- ;
begin scalar svp,varf,valf,n,fargl,s,b;
 if eqcar(f,'sqrt) and not(constp(cadr f))
  then f:=list('expt,cadr f,list('quotient,1,2));
 b:=(not (car f memq '(plus minus times expt)))
      or
    (car(f) eq 'expt
       and
    (not (numberp(caddr f) or rationalexponent(f))
       or
    ((cadr(f) eq 'e) or constp(cadr(f)))));
 svp:=subscriptedvarp car f;
 s:=get(car f, 'kvarlst);
 %------------------------------------------------------------
 % b tells us whether f is a regular function (NIL) or
 % not (T). So b=T for everything but ye ordinary expressions.
 % We've got to check whether we deal with an array variable
 % and if so, whether there is a valid cse-name for this
 % variable.
 % We also want to recognize a valid index-expression, for
 % wich `not b' holds.
 %------------------------------------------------------------
 varf := if svp then assoc(ireval(f),s)
                else assoc(f,s);
 if (varf and svp) or
    (b and varf and allconst(cdr f, cdr varf))
    %---------------------------------------------------------
    % This condition states that in order to allow the current
    % and a previous expression to be regarded as equal, the
    % expression should denote a subscripted variable, or a
    % use of an function with constant parameters, i.e.
    % numerical parameters.
    %---------------------------------------------------------
  then varf:=cdr varf
  else
  << varf:=fnewsym();
     put(car f,'kvarlst,((if svp then ireval f else f).varf).s);
     if not b
      then
       << put(varf,'rowindex,n:=rowmax:=rowmax+1);
          if not(eqcar(f,'expt) and
                 rationalexponent(f) or flagp(cadr f,'ratexp))
           then prevlst:=(x.n).prevlst;
          ffvar!!2(n,varf,f)
       >>
      else
        << if not (!*vectorc and svp)
            then << foreach arg in cdr(f) do
                    if not(constp(arg) or atom(arg))
                       then fargl:=fvarop(if svp then reval arg
                                                 else arg,x).fargl
                       else fargl:=arg.fargl;
                    f:=car(f).reverse(fargl);
                 >>;
           kvarlst:=(varf.f).kvarlst
        >>
  >>;
 prevlst:=(x.varf).prevlst;
 return varf
end;

symbolic procedure allconst (l,f);
not (nil member foreach el in l collect jbconstp (el,f));

symbolic procedure jbconstp (item,ref);
if constp item
   then % some numerical value
        T
   else if atom item
           then % some id
                if get(item,'rowocc)
                   then % item parsed as lefthandside.
                        if (car(get(item,'rowocc))< findvardef(ref))
                            then % This use and the previous are in the
                                 % scope of one definition of item.
                                 T
                            else % This use and the previous are in
                                 % scopes of diferent definitions of
                                 % item.
                                 NIL

                   else % some input id used twice ore more on rhs.
                        T
           else not(NIL member foreach el in cdr item
                                  collect jbconstp(el,ref));

symbolic procedure findvardef v;
begin
  scalar r,vp,vt;
  r:=get(v,'rowocc);
  vt:=get(v,'varlst!*);
  vp:=get(v,'varlst!+);
  if r
    then r:= car r
    else if vt
           then if vp
                  then
                  if ((vt := caar reverse vt) > (vp := caar reverse vp))
                         then r:= vt
                         else r:= vp
                  else r:= caar reverse vt
           else r:= caar reverse vp;
   return r;
   end;


symbolic procedure ssetvars(preprefixlist);
% -------------------------------------------------------------------- ;
% eff : The information stored on the property lists of the elements of;
%       the lists Varlst!+ and Varlst!* is stored in the matrix CODMAT,;
%       i.e.the Z-streets are produced via the SSetvars1 calls.        ;
%       Before doing so PrepMultMat is used to modify, if necessary,the;
%       Varlst!* information by incorporating information about ratio- ;
%       nal exponents.                                                 ;
%       Furthermore the elements of Prevlst are used to store the hier-;
%       archy information in the ORDR-fields in the matrix CODMAT. In  ;
%       addition some bookkeeping activities are performed: Needless   ;
%       information is removed from property lists and not longer need-;
%       ed lists are cleared. EndMat is also initialized.              ;
% -------------------------------------------------------------------- ;
<<
  preprefixlist:=prepmultmat(preprefixlist);
  %--------------------------------------------------------------------
  % From now on preprefixlist has the following structure :
  %
  %  ((var1 aliases )(var2 aliases )...)
  %
  %--------------------------------------------------------------------
  ssetvars1('varlst!+,'plus);
  ssetvars1('varlst!*,'times);
  varlst!+:=varlst!*:=nil;
  foreach el in reverse(prevlst) do setprev(car el,cdr el);
  foreach el in kvarlst do remprop(cadr el,'kvarlst);
  foreach el in '(plus minus difference times sqrt expt) do
                                                   remprop(el,'kvarlst);
  remprop('!*bases!*,'kvarlst);
  endmat:=rowmax;
  preprefixlist
>>;

symbolic procedure revise2 (f,d);
begin
  scalar res;
  if atom f
    then if constp f
          then return f
          else if get(f,'aliaslist)
                then return get(f,'finalalias)
                else << if not(member(f,known))
                         then known:=f . known;
                        return f;
                     >>
    else if not constp f
          then % car f is operator or indexed var
               if subscriptedvarp car f
                then % We have to search d to rewrite f.
                     % Then we check `known' for an alias.
                     if get(car f,'aliaslist)
                      then <>
                                    else return f >>
                       else if !*vectorc
                             then % rhs-alias introduction.
                             <>
                             else return f
                else if res:=assoc(f,d)
                      then return cadr res
                      else return car f . foreach el in cdr f
                                             collect revise2 (el,d)
          else return f;
end;

symbolic procedure revise (f,d);
car f . (cadr f . foreach l in cddr f collect revise2 (l,d));

symbolic procedure preremdep forms;
%----------------------------------------------------------------------
% We remove dependencies and indexed variables in forms by introducing
% aliases.
%                      ABOUT ALIASES.
%
% In search for common subexpressions, scope does not, ironically,
% bother for rules of scope. This means that :
%
% a:=x+y
% ..
% a:=cos(x)
% z:=x+y
%
% is going to be optimized into:
%
% a:=x+y,
% ..
% a:=cos(x),
% z:=a.
%
% We solve this anomaly by replacing every occurrence of `a', starting
% from the second definition, by a generated name; so
%
% a := ...
%   := ... a ...
% a := ... a ...
% a := ...
%   := ... a ...
%
% becomes :
%
% a := ...
%   := ... a ...
% a1:= ... a ...
% a2:= ...
%   := ... a2 ...
%
% This prevents scope from finding c.s.e.'s where there aren't any. At
% the end of the optimization process, these aliases are backsubstitu-
% ted, with their original values, (provided these are atomic!)
% Secondly the aliasmechanism is usefull in the storage process:
% When dealing with nonatomic, i.e. subscripted variables, problems
% arise in storing these variables in codmat, and putting all kind of
% info as properties on them.  A variable is subscripted when declared
% as such by the option `declare' or `vectorcode', or when encountered
% as lhs of an assignment.
% We alias subscripted variables by an atomic, generated variable:
%
% a(i) := ...
% ...  := ... a(i) ...
%
% becomes:
%
% g1   := ...
% ...  := ... g1 ...
%
% When the indexexpressions are not atomic, i.e. they could be or con-
% tain c.s.e.'s, we put an assignment right in front of their first
% use (when the switch VECTORC is off!!!):
%
% a(x+y):= ...
% ...   := ... a(x+y) ...
%
% becomes:
%
% g0    := x+y
% g1    := ...
% ...   := ... g1 ...
%
% We only backsubstitute the output-definition of a sub'ted variable,
% i.e. the last definition, thus saving some memorymanagementoverhead.
% Atomic originals are all backsubstituted, for economy in allocation
% of variables.
%
%                 TECHNICAL DETAILS ALIASMECHANISM
%
% Aliasing is performed by a double linking mechanism:
% The original has properties `aliaslist'(a list of all aliases for
% this variable) and `finalalias' (the alias to be used in the current
% or final scope).
%
%    Original ------[finalalias]--------> Aliasxx
%       |     <-----[alias     ]---------/   ^
%       |                                    |
%    [aliaslist]                             |
%       |                                    |
%       *------------------------------------/
%       |
%       *-------------------------------> Aliasyy
%       |                                    .
%       .                                    .
%       |                                    .
%       *-------------------------------> Aliaszz
%
% All aliases of the original are linked to the original by their
% property `alias' with value Original. (This is left out of above pic.
% for Aliasyy .. Aliaszz.)
% Finally, all generated assignments, stemming from indexexpressions,
% have the property `inalias', which links them to the variable they
% arose from. This property can be updated during optimization, or even
% be copied onto other variables, due to finding of c.s.e.'s.
%
%    Generated Assignment:
%            Aliasxx := indexexpression.
%                  |
%                  [  inalias ]
%                             |
%                             V
%    Original: <----[alias]---Aliasyy
%    A(.., Aliasxx, ..)
%
% All variables generated in the aliasing process obtain a flag
% `aliasnewsym'.
% All aliasinfo is removed after the optimization process.
%----------------------------------------------------------------------
begin
  scalar defs,var,alias,res,currall;
  known:=nil;
  foreach f in forms do
    <>
                           else  known:= var . known;
                           res:=f . res;
                         >>
                   else if !*vectorc or flagp(car var, 'vectorvar)
                         then % Switch vectorc is set,or this is just
                              % `vectorcode-marked' variable.
                              % No further analization of var needed.
                              % For output purposes we apply remdiff to
                              % the subscripts.
                              % Then just introduce aliases.
                           <>
                         else % Introduce cse's for the non-atomic
                              % index-expressions,
                              % prepend this to current assignment and
                              % introduce its alias.
                           <>;
                                     alias
                                   >>
                               else ie;
                              alias:=introduce!-alias ireval var;
                              foreach a in currall
                                 do put(a,'inalias,
                                        alias . get(a,'inalias));
                              rplaca(cdr f,alias);
                              res:= f . res;
                           >>
               >>
          else res:= f . res
       else restorecseinfo(cadr forms, caddr forms)
     >>;
  restoreall;
  return reverse res;
  end;

symbolic procedure introduce!-alias var;
% Introduce an alias for var;
begin
  scalar alias,v2;
  alias:=fnewsym();
  remflag(list alias,'newsym);
  flag(list alias, 'aliasnewsym);
  v2:= if atom var then var else car var;
  put(v2,'aliaslist,
      alias . get(v2,'aliaslist));
  if atom var
     then put(var,'finalalias,alias)
     else %-----------------------------------------------------------
          % An subscripted var can have a finalalias for several
          % entries.
          %-----------------------------------------------------------
         put(v2,'finalalias,
                 list(var,alias)
                 . delete(assoc(var, get(v2,'finalalias)),
                                     get(v2,'finalalias)));
  put(alias,'alias,var);
  known:=alias . known;
  return alias;
  end;

symbolic procedure ssetvars1(varlst,opv);
% -------------------------------------------------------------------- ;
% eff : Zstrt's are completed via a double loop and association of     ;
%       column indices(if necessary for both the + and  the * part of  ;
%       CODMAT) with the var's via storage on the var property lists.  ;
% -------------------------------------------------------------------- ;
begin scalar z,zz,zzel;
  %foreach var in lispeval(varlst) do
  foreach var in eval(varlst) do
  <>;
    put(var,varlst,rowmin); % Save column index for later use;
    setrow(rowmin,opv,var,nil,zz)
  >>;
end;

symbolic procedure prepmultmat(preprefixlist);
% -------------------------------------------------------------------- ;
% eff : The information concerning rational exponents and stored in the;
%       Varlst!* lists is used to produce exact integer exponents,to be;
%       stored in the Z-streets of the matrix Codmat:                  ;
%       For all elements in Varlst!* the Least Common Multiplier (LCM) ;
%       of their exponent-denominators is computed.                    ;
%       If LCM > 1 the element has a rational exponent. The exponent of;
%       each element is re-calculated  to obtain LCM * the orig. exp.  ;
%       Modulo LCM arithmetic is used to spread information over 2     ;
%       varlst!*'s, one for the original var(iable) and another for the;
%       fraction-part left.                                            ;
%       Renaming is adequately introduced when necessary.              ;
% -------------------------------------------------------------------- ;
begin scalar tlcm,var,varexp,kvl,kfound,pvl,pfound,tel,ratval,ratlst,
                                                      newvarlst,hvarlst;
 hvarlst:= nil;
 while not null (varlst!*) do
 <>
                   else << pvl:=car(prevlst).pvl;
                           prevlst:=cdr(prevlst)
                        >>;
                 if pvl then
                  if prevlst then prevlst:=append(reverse prevlst,pvl)
                             else prevlst:=pvl
              >>
             else
              << kvl:=car(kvarlst).kvl; kvarlst:=cdr kvarlst>>;
           if kvl then
             if kvarlst then kvarlst:=append(reverse kvl,kvarlst)
                      else kvarlst:=reverse kvl
         >>
        else preprefixlist:=tel.preprefixlist;
       ratlst:=newvarlst:=nil;
       foreach elem in get(var,'varlst!*) do
        if pairp cdr elem
         then
          << ratval:=divide((tlcm * cadr elem)/(cddr elem),tlcm);
             ratlst:=cons(car elem,cdr ratval).ratlst;
             if car(ratval)>0
              then newvarlst:=cons(car elem,car ratval).newvarlst
          >>
         else newvarlst:=elem.newvarlst;
       if ratlst
        then << put(varexp,'varlst!*,reverse ratlst);
                hvarlst:=varexp.hvarlst
             >>;
       if newvarlst
        then << put(var,'varlst!*,reverse newvarlst);
                hvarlst:=var.hvarlst
             >>
        else remprop(var,'varlst!*)
     >>
    else hvarlst:=var.hvarlst
 >>;
 varlst!* := hvarlst;
 return preprefixlist
end;

symbolic procedure lcm2(a,b);
% ---
% Switch rounded off before calling lcm.
% lcm doesn't seem to work in rounded mode
% for lcm
% ---
begin scalar g, res;
  g := gcd2(a,b);
  res := a*b;
  return res/g;
  end;

% -------------------------------------------------------------------- ;
% ORDERING OF (SUB)EXPRESSIONS :                                       ;
% -------------------------------------------------------------------- ;
% It is based op the presumption that the ordering of the input expres-;
% sions has to remain unchanged when attempting to optimize their des- ;
% cription. This ordering is stored in the list CodBexl!* via FFVAR    ;
% and used in the procedure MAKEPREFIXL( via PRIRESULT and also given  ;
% in CODCTL.RED) for managing output. Hence any subexpression found by ;
% whatever means has to be inserted in the latest version of the       ;
% description of the set ahead of the first expression in which it     ;
% occurs and assuming its occurences are replaced by a system selected ;
% name which is also used as subexpression recognizer(i.e., as assigned;
% var). We distinguish between different types of subexpressions:      ;
% Some are directly recognizable : sin(x),a(1,1) and the like. Others  ;
% need optimizer searches to be found: sin(a+2*b),f(a,c,d+g(a)),etc.   ;
% Via FVAROP an expression like sin(x) is replaced by a system selected;
% name(g001,for instance),the pair (g001.sin(x)) is added to the       ;
% Kvarlst, the pair (sin(x).g001) is added to the 'Kvarlst of sin,thus ;
% allowing a test to be able to uniquely use the name g001 for sin(x). ;
% Finally the pair (rowindex of father of this occurence of sin(x) .   ;
% g001) is added to Prevlst. However if the argument of a sin applica- ;
% tion is not directly recognizable(a*b+a*c or a*(b+c),etc) the argu-  ;
% ment is replaced by a system selected name(g002,for instance),which  ;
% then needs incorporation in the administration. This is also done in ;
% FVAROP: The index of the CODMAT-row used to start the description of ;
% this argument is stored on the property list of g002 as value of the ;
% indicator Rowindex and the Prevlist is now extended with the pair    ;
% (father indx. g002 indx).When storing nested expressions in CODMAT   ;
% the father-child relations based on interchanges of + and * symbols  ;
% are treated in a similar way.So the Prevlst consists of two types of ;
% pairs: (row number.row number) and (row number.subexpression name).  ;
% The CODMAT-row, where the description of this subexpression starts   ;
% can be found on the property list of the subexpression name as value ;
% of the indicator Rowindex. All function applications are stored uni- ;
% quely in Kvarlst. This list is consulted in CODPRI.RED when construc-;
% ting PREFIXLIST,which represents the result as a list of dotted pairs;
% of the form ((sub)expr.name . (sub)expr.value) as to guarantee a cor-;
% rect insertion of the function appl.,i.e. directly ahead of the first;
% (sub)expr. it is part of.After inserting the pair (subexpression name;
% . function application) the corresponding description is removed from;
% the Kvarlst,thus avoiding a multiple insertion. This demands for a   ;
% tool to know when to consult the Kvarlst.This is provided by the ORDR;
% field of the CODMAT-rows.It contains a list of row indices and func- ;
% tion application recognizers, which is recursively built up when     ;
% searching for subexpressions,after its initialization in SSETVARS,   ;
% using the subexpression recognizers introduced during parsing.       ;
% -------------------------------------------------------------------- ;

symbolic procedure setprev(x,y);
% -------------------------------------------------------------------- ;
% arg : Both X and Y are rowindices.                                   ;
% eff : Y is the index of a row where the description of a subexpr.    ;
%       starts. If X is the index of the row where the description of a;
%       toplevel expression starts( an input expression recognizable by;
%       the father-field Farvar) Y is put on top of the list of indices;
%       of subexpressions which have to be printed ahead of this top-  ;
%       level expression.Otherwise we continue searching for this top- ;
%       level father via a recursive call of SetPrev.                  ;
% -------------------------------------------------------------------- ;
if numberp(farvar x)
then setprev(farvar x,y)
else setordr(x,y.ordr(x));

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/coddec.red0000644000175000017500000012255511526203062023544 0ustar  giovannigiovannimodule coddec;  % Functions for generating declarations.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author  :   M.C. van Heerwaarden, W.N. Borst.                       ;
% ------------------------------------------------------------------- ;
%                                                                     ;
% ------------------------------------------------------------------- ;
% The module CODDEC contains the functions, which have to be used to  ;
% generate declarations, associated with the optimized version of a   ;
% set of input expressions when the switch Optdecs is turned on.      ;
% It can also be used via GENTRAN, when the SCOPE-GENTRAN interface is;
% modified, by adding the command TYPEALL Prefixlist;                 ;
% GLOBALS   : -                                                       ;
% INDICATORS: CHKTYPE, ARGTYPE                                        ;
% ENTRIES   : dettype, typecheck, argnrcheck                          ;
% IMPORTED  : Subscriptedvarp, symtabput, sybtabget, symtabrem        ;
%             FROM $gentransrc/util.red                               ;
% CONVERSION: Conversion imposes a partial ordering on types. With    ;
%             respect to this ordering, we can speak of types being   ;
%             greater or less than others. Uncertainty in the type of ;
%             a certain variable or function is expressed by typing   ;
%             the variable in combination with type-bounds, i.e. a    ;
%             variable for which nothing is certain is typed as       ;
%             '(UNKNOWN ALL).                                         ;
% REMARK    : Double precision declarations are dealt with in the     ;
%             following way: any kind of a double precision           ;
%             declaration causes the gentran switch DOUBLE to be      ;
%             switched on. As a result, ALL declarations in the       ;
%             output will be of double precision.                     ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

global '(fortconv!* optlang!*)$
fluid '(!*double)$
switch double;

symbolic procedure typeall forms;
   begin
      scalar b, declst,nforms;
      on!-double(forms);
      declst := symtabget(nil, '!*decs!*);
      if optlang!* = 'fortran2
      then <>;
             if b
             then fortconv!* := '(unknown
                                    (integer real complex all)
                                    (bool all)
                                    (char string all)
                                  )
             else fortconv!* := '(unknown
                                    (integer real all)
                                    (bool all)
                                    (char string all)
                                 )
           >>;
      foreach ass in forms do
          <>;
      apply1('arestore,avarlst);   % For bootstrapping.
      nforms := reverse nforms;
      finish!-typing nforms;
      fix!-implicit();
      return nforms;
   end;


symbolic procedure on!-double(forms);
% ------------------------------------------------------------------- ;
% eff : Changes the Gentran symbol table and the DOUBLE switch to     ;
%       use the Gentran double precision facility.                    ;
%       Any double precision declaration in the symbol table causes   ;
%       the DOUBLE switch to be switched on. Then, these double       ;
%       precision declarations are replaced by their single precision ;
%       types. Walks also through the FORMS-list an switches DOUBLE   ;
%       switch on when FORMS contains a bigfloat or gaussian bigfloat ;
%       number.                                                       ;
% ------------------------------------------------------------------- ;
begin
  scalar newtype;
  foreach dec in symtabget(nil, '!*Decs!*) do
    if newtype := assoc(cadr(dec),
                         '((real!*8 . real)
                           (complex!*16 . complex)
                           (implicit! real!*8 . implicit! real)
                           (implicit! complex!*16 . implicit! complex))
                       ) then
    << symtabput(nil, car(dec), list(cdr newtype));
       !*double := t
    >>;
  on!-double1(forms)
end;

symbolic procedure on!-double1(forms);
if pairp(forms)
then if doublep(car forms)
     then !*double := 't
     else << on!-double1(car forms);
             on!-double1(cdr forms)
          >>;

symbolic procedure fix!-implicit;
% ------------------------------------------------------------------- ;
% eff : Checks every declaration in the symbol table if that          ;
%       declaration matches an implicit declaration in the table.     ;
%       If so, the types are checked and the explicit declaration is  ;
%       removed out of the table                                      ;
% ------------------------------------------------------------------- ;
begin
  scalar decl, type;
  foreach decl in symtabget(nil, '!*decs!*)
  do if (not isimplicit(cadr decl)) and (type := implicitdec(car decl))
     then << if greatertype(type, cdr(decl))
             then typerror(8, cdr(decl) . type);
             symtabrem(nil, car(decl))
          >>
end;



% ------------------------------------------------------------------- ;
% MODULE       Operations on the Symbol table                         ;
% OPERATIONS : getdec, implicitdec, isimplicit, implicittype          ;
% ------------------------------------------------------------------- ;

symbolic procedure getdec(vname);
% ------------------------------------------------------------------- ;
% args: vname = name of the variable which declaration is requested   ;
% ret : the type of the variable as it is explicitly or implicitly    ;
%       stored in the symbol table                                    ;
% ------------------------------------------------------------------- ;
begin
  scalar decl;
  decl := symtabget(nil, vname);
  if not decl
  then decl := implicitdec(vname);
  return decl
end;

symbolic procedure implicitdec(vname);
% ------------------------------------------------------------------- ;
% args: vname = name of the implicit declared variable which          ;
%       declaration is requested                                      ;
% ret : the type of the variable as it is stored in the symbol table  ;
% ------------------------------------------------------------------- ;
begin
  scalar decl, decs;
  decl := nil;
  decs := symtabget(nil, '!*decs!*);
  while not decl and decs do
  << if isimplicit(cadar(decs)) and firstmatch(vname,caar(decs))
     then decl := list(vname, implicittype(cadar(decs)));
     decs := cdr(decs)
  >>;
  return decl
end;

symbolic procedure firstmatch(vname, implicit);
% -------------------------------------------------------------------- ;
% args: vname = variable name                                          ;
%       implicit = range of an implicit declaration (for instance x!-z);
% ret : 'T iff the variable name matches the range, nil otherwise      ;
% -------------------------------------------------------------------- ;
begin
  scalar first;
  first := id2int(car(explode(vname)));
  return first >= id2int(car(explode(implicit))) and
         first <= id2int(cadddr(explode(implicit)))
end;

symbolic procedure isimplicit(type);
% ------------------------------------------------------------------- ;
% args: type = type of a variable                                     ;
% ret : 'T iff the type is an implicit type, nil otherwise            ;
% ------------------------------------------------------------------- ;
begin
  scalar implicit, result, etype;
  implicit := explode('IMPLICIT! );
  etype := explode(type);
  result := 't;
  while result and implicit do
  <<  result := car(etype) = car(implicit);
      implicit := cdr(implicit);
      etype := cdr(etype)
  >>;
  return result
end;

symbolic procedure implicittype(implicit);
% ------------------------------------------------------------------- ;
% args: implicit = an implicit type                                   ;
% ret : the type of the implicit type                                 ;
% ------------------------------------------------------------------- ;
  intern compress pnth(explode implicit,11);


symbolic procedure asstype(lhs, rhs);
% ------------------------------------------------------------------- ;
% Performs typechecking on the assignment statement lhs-rhs, leading  ;
% to a lhs-type, which fits in the ordering imposed by the rhs.       ;
% ------------------------------------------------------------------- ;
begin
   scalar lhstype;
   lhstype :=
        typecheck(dettype(lhs, 'unknown), dettype(rhs, 'unknown), rhs);
   if atom lhs
   then symtabput(nil, lhs, list lhstype)
   else if subscriptedvarp car lhs
   then symtabput(nil, car lhs, list lhstype)
   else symtabput(nil, car lhs, append(list if atom lhstype
                                            then list lhstype
                                            else lhstype,
                                       for each ndx in cdr lhs
                                       collect 'n
              )               )
end;


symbolic procedure dettype(xpr, minimumtype);
% ------------------------------------------------------------------- ;
% args: xpr = some expression                                         ;
%       minimumtype = minimum type xpr should have. This is set when  ;
%                     operators are encountered.                      ;
% eff : Determine type of xpr and typecheck arguments of operators in ;
%       xpr.                                                          ;
% ret : Type of xpr. If no type is known, '(UNKNOWN ALL) is returned. ;
% ------------------------------------------------------------------- ;
%
% Fixed to handle a NIL returned from OPCHECK mcd 22/7/89
%
begin
   scalar type, dtype, optype, mtype, mntype, mxtype;
   return
          if atom(xpr)
          then if numberp xpr
               then if floatp(xpr)
                    then 'real
                    else 'integer
               else if (type := getdec(xpr))
                   and (type := cadr type)
               then if greatertype(minimumtype, mintype type)
                    then if greatertype(minimumtype, maxtype type)
                         then typerror(1, xpr)
                         else
                          << symtabput(nil, xpr, list(type:=returntype
                                       list(minimumtype,maxtype type)));
                             type
                          >>
                    else type
               else << symtabput(nil, xpr, list list(minimumtype,'all));
                       list(minimumtype, 'all)
                    >>
          else if memq(car xpr, domainlist!*)
          then if memq(car xpr, '(!:rd!: !:rn!:))
               then 'real
               else if memq(car xpr, '(!:gi!: !:cr!: !:crn!:))
                    then 'complex
                    else typerror(5, car xpr)
          else if subscriptedvarp2 car xpr
          then << for each ndx in cdr xpr
                  do typecheck('integer, dettype(ndx, 'integer), ndx);
                     % argument minimumtype independent of parameter
                     % minimumtype
                  cadr getdec(car xpr)
               >>
          else if smember('argtype,
                          car( (optype := opcheck xpr) or '(nil)))
          then << mtype:=mntype:=mxtype:=
                                        car eval get(car xpr,'argtype);
                  % mxtype now contains the first type of the class in
                  % which the arguments must be
                  for each arg in cdr xpr
                  do << dtype := dettype(arg, mtype);
                        if greatertype(type := maxtype dtype, mxtype)
                        then mxtype := type;
                        if greatertype(type := mintype dtype, mntype)
                        then mntype := type
                     >>;
                  if atom cdr optype
                  then << if cdr optype = 'argtype
                          then returntype list(mntype, mxtype)
                          else cdr optype
                       >>
                  else if greatertype(mxtype, cadr optype)
                       then <<  if greatertype(mntype, cadr optype)
                                then list(mntype, mxtype)
                                else list(cadr optype, mxtype)
                            >>
                       else cadr optype
               >>
          else if optype
          then << type := car optype;
                  if atom type then type := list type;
                  foreach arg in cdr xpr
                                       % Number of args already checked
                  do << mtype := firstinclass car type;
                        typecheck(car type, dettype(arg, mtype), arg);
                        type := cdr type
                     >>;
                  cdr optype
               >>
          else << for each arg in cdr xpr
                  do dettype(arg, 'unknown);
                  list(minimumtype, 'all)
               >>
end;


symbolic procedure typecheck(lhstype, rhstype, rhs);
% ------------------------------------------------------------------- ;
% args: lhstype = type as known so far for lhs of ass. stat.          ;
%       rhstype = type as known so far for rhs of ass. stat.          ;
%       rhs     = rhs of ass. stat                                    ;
% eff : The rules used for typechecking are :                         ;
%                                                                     ;
%                    Condition:        Check:            Result:      ;
%                                                                     ;
% lhs        |---|   mintype(lhs) >    OK                mintype(lhs) ;
% rhs  |---|         maxtype(rhs)                                     ;
%                                                                     ;
% lhs  |---|         maxtype(lhs) <    ERROR                          ;
% rhs        |---|   mintype(rhs)                                     ;
%                                                                     ;
% lhs      ...-|     maxtype(lhs) <    OK when adjust-   intersection ;
% rhs      ...---|   maxtype(rhs)      ments possible    of lhs & rhs ;
%                                                                     ;
%                    all other cases   OK                intersection ;
%                                                        of lhs & rhs ;
%                                                                     ;
% ret: The - possibly adjusted type of lhs.                           ;
% ------------------------------------------------------------------- ;
begin
  scalar type;
  if greatertype(mintype lhstype, maxtype rhstype)
  then mintype lhstype
  else << type := typeintersec(lhstype, rhstype);
          if greatertype(maxtype rhstype, maxtype type)
          then if not(putmaxtype(rhs, maxtype type))
               then typerror(2, lhstype . rhstype)
       >>;
  return type
end;

symbolic procedure typeintersec(type1, type2);
% ------------------------------------------------------------------- ;
% ret : the intersection of the two types.                            ;
%       generates an error when the intersection is empty or when the ;
%       types are in different typeclasses.                           ;
% ------------------------------------------------------------------- ;
begin
  scalar mint, maxt;
  mint := if greatertype(mintype type1, mintype type2)
          then mintype type1
          else mintype type2;
  maxt := if greatertype(maxtype type1, maxtype type2)
          then maxtype type2
          else maxtype type1;
  if greatertype(mint, maxt)
  then typerror(2, type1 . type2);
  return returntype list(mint, maxt)
end;


symbolic procedure mintype type;
% ------------------------------------------------------------------- ;
% A type may be a pair (l u) wher l is the minimum type for a variable;
% and u is the maximum type. This procedure returns the minimum type. ;
% ------------------------------------------------------------------- ;
   if atom type
   then type
   else car type;

symbolic procedure maxtype type;
% ------------------------------------------------------------------- ;
% A type may be a pair (l u) wher l is the minimum type for a variable;
% and  u is the maximum type. This procedure returns the maximum type.;
% ------------------------------------------------------------------- ;
   if atom type then type
    else if pairp cdr type then cadr type else car type;

symbolic procedure returntype type;
% ------------------------------------------------------------------- ;
% ret: returns mintype if mintype and maxtype are equal and type      ;
% otherwise.                                                          ;
% ------------------------------------------------------------------- ;
   if mintype type = maxtype type
   then mintype type
   else if greatertype(mintype type, maxtype type)
        then typerror(7, nil)
        else type;


symbolic procedure putmaxtype(xpr, type);
% ------------------------------------------------------------------- ;
% args: xpr = some expression                                         ;
%       type = maximum type for variables and for the result type of  ;
%              operators.                                             ;
% eff : To generate a correctly typed program,the maximum type for xpr;
%       should be Type. If the result type of the main operator of Xpr;
%       is not dependent of its arguments, it is sufficient to check  ;
%       this result type. Otherwise, putmaxtype must be applied to all;
%       arguments.                                                    ;
%       When xpr is a variable and its maximum type is greater than   ;
%       Type the maximum type is tried to be smallened to Type.If this;
%       is not possible, an error occurs.                             ;
% ret:  T if xpr is of correct type, i.e. smaller than Type           ;
%       NIL if it is not possible to smallen the type of xpr when     ;
%       necessary.                                                    ;
% note: Perhaps this procedure does not choose consequently between   ;
%       returning an error and returning NIL.                         ;
% ------------------------------------------------------------------- ;
%
% Fixed to handle a NIL returned from OPCHECK mcd 22/7/89
%
begin
   scalar restype, b;
   return if null xpr
          then t
          else if atom xpr
          then if numberp xpr
               then geqtype(type, dettype(xpr, 'integer))
               else if restype := cadr getdec(xpr)
               then if atom restype
                    then geqtype(type, restype)
                    else if geqtype(type, mintype restype)
                    then << if type = mintype restype
                            then symtabput(nil, xpr, list type)
                            else symtabput(nil, xpr,
                                    list list(mintype restype, type));
                            t
                         >>
                    else nil
               else typerror(3, xpr)
          else if subscriptedvarp car xpr
          then geqtype(type, cadr getdec(car xpr))
               % No uncertainty allowed in type of matrix
          else if (restype := cdr (opcheck(xpr) or '(nil))) = 'argtype
                  or listp(restype)
          then << b := t;
                  for each arg in cdr xpr
                  do b := b and putmaxtype(arg, type);
                  b
               >>
          else if restype
          then geqtype(type, restype)
          else geqtype(type, 'unknown)
end;


% ------------------------------------------------------------------- ;
% MODULE    : CONVERSION fortconv!*, cconv!*, ratconv!*, pasconv!*,   ;
%                        f90conv!*                                    ;
% STRUCTURE : conv!* ::= (UNKNOWN (class-list)-list)                  ;
%             class-list ::= ordered list of types: a type can be     ;
%             converted to the types which occur in the rest of the   ;
%             list.                                                   ;
% OPERATIONS: greatertype, geqtype, lesstype, getnum                  ;
% GLOBALS   : fortconv!*, cconv!*, ratconv!*, pasconv!*,f90conv!*     ;
% INDICATORS: conversion                                              ;
% ------------------------------------------------------------------- ;

global '(fortconv!* cconv!* ratconv!* pasconv!* f90conv!* optlang!*);

put('fortran, 'conversion, 'fortconv!*);
put('f90, 'conversion, 'f90conv!*);
put('c, 'conversion, 'cconv!*);
put('ratfor, 'conversion, 'ratconv!*);
put('pascal, 'conversion, 'pasconv!*);

fortconv!* := '(unknown
                   (integer real complex all)
                   (bool all)
                   (char string all)
               );

f90conv!* := '(unknown
                   (integer real complex all)
                   (bool all)
                   (char string all)
               );

cconv!* := ratconv!* := pasconv!* :=
              '(unknown
                   (integer real all)
                   (bool all)
                   (char string all)
               );

symbolic procedure getnum;
% ------------------------------------------------------------------- ;
% Returns class of numeric types.                                     ;
% ------------------------------------------------------------------- ;
begin
  scalar conv, found;
  conv := eval get(if optlang!* then optlang!* else 'fortran,
                   'conversion);
  while not found and (conv := cdr conv)
  do if caar conv = 'integer
     then found := t;
  return car conv
end;

symbolic procedure greatertype(t1, t2);
% ------------------------------------------------------------------- ;
% args: t1 = t2 = type                                                ;
% ret : T       if t1 >  t2                                           ;
%                      t                                              ;
%                                                                     ;
%       NIL     if t1 <=  t2                                          ;
%                       t                                             ;
% note: >  means greater in the sense of the ordering which is        ;
%        t                                                            ;
%       described above for various languages.                        ;
% ------------------------------------------------------------------- ;
begin
  scalar conv, class, found, found1, found2, f;
  conv := eval get(if optlang!* then optlang!*
                                else 'fortran, 'conversion);
  if car conv = t2
  then f := t
  else if car conv = t1
  then f := nil
  else << while (conv := cdr conv) and not found
          do << class := car conv;
                while class and not found2
                do << if car class = t1
                      then found1 := t;
                      if car class = t2
                      then found2 := t
                      else class := cdr class
                   >>;
                if found2
                then << class := cdr class;
                        while class and not f
                        do if car class = t1
                           then found1 := f := t
                           else class := cdr class;
                     >>;
                if (found1 and not found2) or (not found1 and found2)
                then typerror(4, t1 . t2)
                else if found1 and found2 then found := t
       >>    >>;
  return f
end;

symbolic procedure geqtype(t1, t2);
% ------------------------------------------------------------------- ;
% args: t1 = t2 = type                                                ;
% ret : T       if t1 >=  t2                                          ;
%                       t                                             ;
%                                                                     ;
%       NIL     if t1 <  t2                                           ;
%                      t                                              ;
% Note: See greatertype.                                              ;
% ------------------------------------------------------------------- ;
begin
  scalar conv, class, found, found1, found2, f;
  conv := eval get(if optlang!* then optlang!*
                                else 'fortran, 'conversion);
  if car conv = t2
  then f := t
  else if car conv = t1
  then nil
  else << while (conv := cdr conv) and not found
          do << class := car conv;
                while class and not found2
                do << if car class = t1
                      then found1 := t;
                      if car class = t2
                      then found2 := t
                      else class := cdr class
                   >>;
                if found2
                then while class and not f
                     do if car class = t1
                        then found1 := f := t
                        else class := cdr class;
                if (found1 and not found2) or (not found1 and found2)
                then typerror(4, t1 . t2)
                else if found1 and found2 then found := t
       >>    >>;
  return f
end;

symbolic procedure lesstype(t1, t2);
   greatertype(t2, t1);

symbolic procedure firstinclass type;
% ------------------------------------------------------------------- ;
% Return : First (smallest) type of the class of types in which Type  ;
% belongs.                                                            ;
% ------------------------------------------------------------------- ;
begin
   scalar conv, found, class, mclass;
   conv := eval get(if optlang!* then optlang!*
                                 else 'fortran, 'conversion);
   return if (type = 'all) or (type = 'unknown)
          then 'unknown
          else << while (conv := cdr conv) and not found
                  do << mclass := car(class := car conv);
                        while class and not found
                        do << if car class = type
                              then found := t;
                              class := cdr class
                     >>    >>;
                  if found
                  then mclass
                  else typerror(5, type)
               >>
end;

symbolic procedure lastinclass type;
% ------------------------------------------------------------------- ;
% Returns : Last (greatest) type of the class of types in which Type  ;
% belongs.                                                            ;
% ------------------------------------------------------------------- ;
begin
   scalar conv, found, class;
   conv := eval get(if optlang!* then optlang!*
                                 else 'fortran, 'conversion);
   if type neq 'all
   then while (conv := cdr conv) and not found
        do << class := car conv;
              while class and not found
              do if car class = type
                 then << found := t;
                         repeat type := car class
                         until (class := cdr class) = '(all)
                      >>
                 else class := cdr class
           >>;
   return type
end;

% ------------------------------------------------------------------- ;
% MODULE    : FUNCTION TYPING                                         ;
% STRUCTURE :                                                         ;
% OPERATIONS: resulttype                                              ;
% GLOBALS   :                                                         ;
% INDICATORS: type: (argumenttype . resulttype)                       ;
%             argumenttype:                                           ;
%              Atom ==> 1 argument                                    ;
%              List with 1 type ==> number of arguments must be >= 2  ;
%              List with > 1 type ==> number of types = number        ;
%                                                         of arguments;
%             resulttype has the following meaning                    ;
%                                                                     ;
%   resulttype     meaning                                            ;
%                                                                     ;
%    'argtype   the type of the result is determined by the arguments ;
%    'type      the type of the result is always the given type       ;
%    '(type)    the type of the result is determined in the following ;
%               way:                                                  ;
%                                                                     ;
%             maximium of the    minimum of the                       ;
%             mintypes of the    maxtypes of the                      ;
%             arguments          arguments                            ;
%                                                                     ;
%       type       |------------------|                               ;
%                  |------------------|         = type of the result  ;
%                                                                     ;
%                  |-----type---------|                               ;
%                        type---------|         = type of the result  ;
%                                                                     ;
%                  |------------------|    type                       ;
%                                          type = type of the result  ;
%                                                                     ;
%             argtype:                                                ;
%              The type of a function or argument can be one of a     ;
%              class of types. Evaluation of the value of this        ;
%              indicator returns the whole class.                     ;
%                                                                     ;
% ------------------------------------------------------------------- ;



for each op in '(times plus difference)
do << put(op, 'chktype, '((argtype) . argtype));
      put(op, 'argtype, '(getnum))
   >>;
put('quotient, 'chktype, '((argtype argtype) . (real)));
put('quotient, 'argtype, '(getnum));
put('expt, 'chktype, '((argtype argtype) . argtype));
put('expt, 'argtype, '(getnum));
put('minus, 'chktype, '(argtype . argtype));
put('minus, 'argtype, '(getnum));
for each op in '(or and)
do put(op, 'chktype, '((bool) . bool));
put('not, 'chktype, '(bool . bool));
for each op in '(eq leq geq greaterp lessp neq)
do << put(op, 'chktype, '((argtype argtype) . bool));
      put(op, 'argtype, '(getnum))
   >>;
for each op in '(sin cos tan asin acos atan sinh cosh tanh asinh
                                            acosh atanh cot log sqrt)
do put(op, 'chktype, '(real . real));

symbolic procedure opcheck op;
% ------------------------------------------------------------------- ;
% args: op = operator                                                 ;
% eff : performs a check on the number of arguments                   ;
% ret : Complete type of operator, i.e.                               ;
%       (type-of-arguments-list .  resulttype)                        ;
% note: Decisions about what to do when Op's type is ARGTYPE are left ;
%       to the calling procedures.                                    ;
% ------------------------------------------------------------------- ;
begin
   scalar optype;
   return if not(optype := get(car op, 'chktype))
          then 'nil
          else if atom car optype
          then if length cdr op = 1
               then optype
               else typerror(6, car op)
          else if cdar optype
          then if length cdr op = length car optype
               then optype
               else typerror(6, car op)
          else if length cdr op >= 2
               then optype
               else typerror(6, car op)
end;

% ------------------------------------------------------------------- ;
% MODULE finish type analysis & checking.                             ;
%        Each variable will be bound to a single type.                ;
% ------------------------------------------------------------------- ;

symbolic procedure finish!-typing prflst;
% ------------------------------------------------------------------- ;
% args: prflst = the prefixlist from the optimizer.                   ;
% eff : After some simple checks, each variable in the assignment has ;
%       a definite type. This type can be found in the symbol table.  ;
% ret : -                                                             ;
% ------------------------------------------------------------------- ;
begin
   scalar ltype, rtype;
   for each item in prflst
   do if (ltype := det!&bind(car item, 'all))
      then << if ltype = 'all
              then if (rtype := det!&bind(cdr item, ltype)) = 'all
                   then
                     write list("Unknown type for operator", cdr item)
                   else ltype := lastinclass rtype
              else rtype := det!&bind(cdr item, ltype);
              if greatertype(rtype, ltype)
              then typerror(2, item)
              else if atom car item
              then symtabput(nil, car item, list ltype)
              else symtabput(nil, caar item, list ltype)
           >>
      else % When a lhs variable is not declared, it is a variable
           % generated by the optimizer which still needs typing.
           symtabput(nil, car item, list det!&bind(cdr item, 'all))
end;


symbolic procedure det!&bind(xpr, maximumtype);
% ------------------------------------------------------------------- ;
% args: xpr = expression for which a definite type must be determined ;
%       maximumtype = the maximum type which Xpr may obtain; only used;
%                     in cases where the variable's type is           ;
%                     (UNKNOWN ALL).                                  ;
%                     Typechecking is done in finish!-typing.         ;
% eff : if xpr is a variable,its definite type is stored on the symbol;
%       table.                                                        ;
% ret : the type of Xpr after binding all variables to a certain type.;
% ------------------------------------------------------------------- ;
%
% Fixed to handle a NIL returned from OPCHECK mcd 22/7/89
%
begin
   scalar type, mtype, optype;
   return if idp(xpr) or constp(xpr)
          then if constp(xpr)
               then dettype(xpr, 'integer)
               else det!&bindmax(xpr, maximumtype)
          else if subscriptedvarp car xpr
          then << for each ndx in cdr xpr
                  do det!&bind(ndx, 'integer);
                  det!&bindmax(car xpr, maximumtype)
               >>
          else if smember('argtype,
                          car((optype := opcheck xpr) or '(nil)))
          then << mtype := 'unknown;
                  for each arg in cdr xpr do
                  if greatertype(type:=
                                      det!&bind(arg,maximumtype),mtype)
                     then mtype := type;
                  % Fixed to handle complex division. ;
                  if atom cdr optype
                  then << if cdr optype = 'argtype
                          then mtype
                          else cdr optype
                       >>
                  else if greatertype(mtype, cadr optype)
                       then mtype
                       else cadr optype
               >>
          else if optype
          then << type := car optype;
                  if atom type then type := list type;
                  for each arg in cdr xpr
                  do << det!&bind(arg, car type);
                        type := cdr type
                     >>;
                  cdr optype
               >>
          else << for each arg in cdr xpr
                  do det!&bind(arg, 'all);
                  maximumtype
               >>
end;


symbolic procedure det!&bindmax(xpr, maximumtype);
begin
   scalar type;
   if pairp(type := cadr getdec(xpr))
   then if maxtype type = 'all
        then if mintype type = 'unknown
             then << type := maximumtype;
                     symtabput(nil, xpr, list maximumtype)
                  >>
             else << type := lastinclass mintype type;
                     if greatertype(type, maximumtype)
                        then type:=maximumtype;
                     symtabput(nil, xpr, list type)
                  >>
        else symtabput(nil, xpr, list(type := maxtype type));
    return type
end;


symbolic procedure typerror(errornr, xpr);
% ------------------------------------------------------------------- ;
% eff : Besides the error message, the declarations known so far are  ;
%       printed.                                                      ;
% ------------------------------------------------------------------- ;
   if errornr = 6
   then rederr list("Wrong number of arguments for", xpr)
   else << terpri!* t;
           write("***** Type error:");
           terpri!* t;
           printdecs();
           if errornr = 1
           then rederr list("Wrong type for variable", xpr)
           else if errornr = 2
           then <>
           else if errornr = 3
           then rederr list(xpr, "not checked on type")
           else if errornr = 4
           then rederr
             list(car xpr, "and", cdr xpr, "in different type classes")
           else if errornr = 5
           then rederr list(xpr, "is an unknown type")
           else if errornr = 7
           then rederr list("Wrong reasoning")
           else if errornr = 8
           then rederr list(car xpr, "cannot be redeclared to",cdr xpr)
           else rederr list("Unknown type error")
        >>;

symbolic expr procedure subscriptedvarp v;
    % --------------------------------------------------------------- ;
    %  Returns t if and only if v has been declared to be a           ;
    %  subscripted variable name, or assumed to be so by the parser.  ;
    % --------------------------------------------------------------- ;
    length symtabget(nil, v) > 2
    or flagp(v,'subscripted);

symbolic expr procedure subscriptedvarp2 v;
    % --------------------------------------------------------------- ;
    %  Returns t if and only if v has been declared to be a           ;
    %  subscripted variable name.                                     ;
    % --------------------------------------------------------------- ;
    length symtabget(nil, v) > 2;

global '(!*symboltable!*);

symbolic expr procedure dumpsymtab;
    begin scalar res;
    res :=
        foreach pn in !*symboltable!* conc
                list(
                     list('symtabput,mkquote pn, mkquote '!*type!*,
                                     mkquote symtabget(pn, '!*type!*)),
                     list('symtabput,mkquote pn, mkquote '!*params!*,
                                     mkquote symtabget(pn,'!*params!*)),
                     list('symtabput,mkquote pn, mkquote '!*decs!*,
                                     mkquote symtabget(pn, '!*decs!*))
                     );
    res := 'progn . list('setq,'!*symboltable!*,mkquote !*symboltable!*)
                   . res;
    return res
    end;

%--- Coddec patch. John Boers wil i.p.v. ranges ook atomen impliciet
%---               declareren. dus: s,t i.p.v. s-t.

symbolic procedure firstmatch(vname, implicit);
% -------------------------------------------------------------------- ;
% args: vname = variable name                                          ;
%       implicit = range of an implicit declaration (for instance x!-z);
% ret : 'T iff the variable name matches the range, nil otherwise      ;
% -------------------------------------------------------------------- ;
begin
  scalar first;
  first := id2int(car(explode(vname)));
  if freeof(explode implicit,'!-)
     then return first=id2int(car(explode(implicit)))
     else
  return first >= id2int(car(explode(implicit))) and
         first <= id2int(cadddr(explode(implicit)))
end;
endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.red0000644000175000017500000001366511526203062023435 0ustar  giovannigiovannimodule scope;  % Header module for SCOPE package.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, W.N. Borst, M.C.       ;
%             van Heerwaarden, J.B. van Veelen.                       ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(scope codctl restore minlngth codmat codopt codad1
                  codad2 coddec codpri codgen codhrn codstr coddom),
                % ghorner
                '(contrib scope));

% Smacro definitions for access functions.

% ------------------------------------------------------------------- ;
% Access functions for the incidence matrix                           ;
% ------------------------------------------------------------------- ;

global '(codmat maxvar)$

define lenrow=8,lencol=4;
% ------------------------------------------------------------------- ;
% Length of the rows and the columns                                  ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure row x$
   getv(codmat,maxvar+x)$

symbolic smacro procedure free x$
   getv(row x,0)$

symbolic smacro procedure wght x$
   getv(row x,1)$

symbolic smacro procedure awght x$
   caar(wght x)$

symbolic smacro procedure mwght x$
   cdar(wght x)$

symbolic smacro procedure hwght x$
   cdr(wght x)$

symbolic smacro procedure opval x$
   getv(row x,2)$

symbolic smacro procedure farvar x$
   getv(row x,3)$

symbolic smacro procedure zstrt x$
   getv(row x,4)$

symbolic smacro procedure chrow x$
   getv(row x,5)$

symbolic smacro procedure expcof x$
   getv(row x,6)$

symbolic smacro procedure hir x$
   getv(row x,7)$

symbolic smacro procedure phir x$
   car(hir x)$

symbolic smacro procedure nhir x$
   cdr(hir x)$

% ------------------------------------------------------------------- ;
% Assignments in the incidence matrix                                 ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure fillrow(x,v)$
   putv(codmat,maxvar+x,v)$

symbolic smacro procedure setoccup x$
   putv(row x,0,nil)$

symbolic smacro procedure setfree x$
   putv(row x,0,t)$

symbolic smacro procedure setwght(x,v)$
   putv(row x,1,v)$


symbolic smacro procedure setopval(x,v)$
   putv(row x,2,v)$

symbolic smacro procedure setfarvar(x,v)$
   putv(row x,3,v)$

symbolic smacro procedure setzstrt(x,v)$
   putv(row x,4,v)$

symbolic smacro procedure setchrow(x,v)$
   putv(row x,5,v)$

symbolic smacro procedure setexpcof(x,v)$
   putv(row x,6,v)$

symbolic smacro procedure sethir(x,v)$
   putv(row x,7,v)$

symbolic smacro procedure setphir(x,v)$
   rplaca(hir x,v)$

symbolic smacro procedure setnhir(x,v)$
   rplacd(hir x,v)$

% ------------------------------------------------------------------- ;
% Access functions for Z elements                                     ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure xind z$
   car z$

symbolic smacro procedure yind z$
   car z$

symbolic smacro procedure val z$
   cdr z$

symbolic smacro procedure ival z$
   car val z$

symbolic smacro procedure bval z$
   cdr val z$

% ------------------------------------------------------------------- ;
% Assignment functions for Z elements                                 ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure setival(z,v)$
   rplaca(val z,v)$

symbolic smacro procedure setbval(z,v)$
   rplacd(val z,v)$

symbolic smacro procedure mkzel(n,iv);
   if idp(iv) or constp(iv) then n.(iv.nil) else n.iv$
    % --------------------------------------------------------------- ;
    % Distinguish between atom and non atom for IVAL and BVAL.        ;
    % --------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% Access functions for ordening subexpressions                        ;
% ------------------------------------------------------------------- ;

symbolic smacro procedure ordr x$
   getv(row x,8)$

symbolic smacro procedure setordr(x,l)$
   putv(row x,8,l)$

% ------------------------------------------------------------------- ;
% Access functions for Histogram                                      ;
% ------------------------------------------------------------------- ;

global '(codhisto)$

codhisto:=nil;

define histolen=200$

symbolic smacro procedure histo x$
   getv(codhisto,x)$

symbolic smacro procedure sethisto(x,v)$
   putv(codhisto,x,v)$

endmodule;

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.hlp0000644000175000017500000000736511526203062023446 0ustar  giovannigiovanni\chapter[SCOPE: source code optimisation package]{SCOPE: REDUCE source code optimisation package}
\label{SCOPE}
\typeout{{SCOPE: REDUCE source code optimisation package}}

{\footnotesize
\begin{center}
J.A. van Hulzen \\
University of Twente, Department of Computer Science \\
P.O. Box 217, 7500 AE Enschede \\
The Netherlands \\[0.05in]
e--mail: infhvh@cs.utwente.nl
\end{center}
}

SCOPE is a package to produce optimised versions of algebraic
expressions.  It can be used in two distinct fashions, as an adjunct
to numerical code generation (using GENTRAN, described in
chapter~\ref{GENTRAN}) or as a stand alone way of investigating
structure in an expression.

When used with GENTRAN\ttindex{GENTRAN} it is sufficient to set the
switch {\tt GENTRANOPT}\ttindex{GENTRANOPT} on, and GENTRAN will then
use SCOPE internally.  This is described in its internal detail in the
GENTRAN manual and the SCOPE documentation.

As a stand-alone package SCOPE provides the operator {\tt OPTIMIZE}.

\ttindex{OPTIMIZE}
A SCOPE application is easily performed and based on the use of
the following syntax:

\begin{center}
\begin{tabular}{lcl}
 $<$SCOPE\_application$>$ & $::=$ & {\tt OPTIMIZE} $<$object\_seq$>$
 [{\tt INAME} $<$cse\_prefix$>$]\\
 $<$object\_seq$>$ & $::=$ & $<$object$>$[,$<$object\_seq$>$]\\
 $<$object$>$ & $::=$ & $<$stat$>~\mid~<$alglist$>~\mid~<$alglist\_production$>$ \\
 $<$stat$>$ & $::=$ & $<$name$>~<$assignment operator$>~<$expression$>$\\
 $<$assignment operator$>$ & $::=$ & $:=~\mid~::=~\mid~::=:~\mid~:=:$\\
 $<$alglist$>$ & $::=$ & \{$<$eq\_seq$>$\}\\
 $<$eq\_seq$>$ & $::=$ & $<$name$>~=~<$expression$>$[,$<$eq\_seq$>$]\\
 $<$alglist\_production$>$ & $::=$ & $<$name$>~\mid~<$function\_application$>$\\
 $<$name$>$ & $::=$ & $<$id$>~\mid~<$id$>(<$a\_subscript\_seq$>)$\\
 $<$a\_subscript\_seq$>$ & $::=$ & $<$a\_subscript$>$[,$<$a\_subscript\_seq$>$]\\
 $<$a\_subscript$>$ & $::=$ & $<$integer$>~\mid~<$integer infix\_expression$>$\\
 $<$cse\_prefix$>$ & $::=$ & $<$id$>$
\end{tabular}
\end{center}

A SCOPE action can be applied on one assignment statement, or to a
sequence of such statements, separated by commas, or a list of expressions.

\index{SCOPE option ! {\tt INAME}}
The optional use of the {\tt INAME} extension in an {\tt OPTIMIZE}
command is introduced to allow the user to influence the generation of
cse-names.  The cse\_prefix is an identifier, used to generate
cse-names, by extending it with an integer part. If the cse\_prefix
consists of letters only, the initially selected integer part is 0.
If the user-supplied cse\_prefix ends with an integer its value
functions as initial integer part.

\begin{verbatim}
z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+2*b^2*m^6+b^2*m^2;

      2  2       2  6    2  2          4      2  6    2  2
z := a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m

OPTIMIZE z:=:z ;


G0 := b*a
G4 := m*m
G1 := G4*b*b
G2 := G4*a*a
G3 := G4*G4
z := G1 + G2 + G0*(2*G3 + G0) + G3*(2*G1 + 10*G2)

\end{verbatim}
it can be desirable
to rerun an optimisation request with a restriction on the minimal size of
the righthandsides. The command

\index{SCOPE function ! {\tt SETLENGTH}}
\hspace*{1cm} {\tt SETLENGTH} $<$integer$>$\$

can be used to produce rhs's with a minimal arithmetic complexity,
dictated by the value of
its integer argument. Statements, used to rename function applications, are
not affected by the {\tt SETLENGTH} command. The default setting is restored
with the command

\hspace*{1cm} {\tt RESETLENGTH}\$
\index{SCOPE function ! {\tt RESETLENGTH}}

{\em Example:}
\begin{verbatim}
SETLENGTH 2$

OPTIMIZE z:=:z INAME s$

       2  2
s1 := b *m
       2  2
s2 := a *m
               4                       4
z := (a*b + 2*m )*a*b + 2*(s1 + 5*s2)*m  + s1 + s2

\end{verbatim}

Details of the algorithm used is given in the Scope User's Manual.

mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/restore.red0000644000175000017500000001553011526203062024000 0ustar  giovannigiovannimodule restore;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(prefixlist);

global '(!*vectorc malst optlang!*);

symbolic procedure vectorcode list_of_names;
% ------------------------------------------------------------------- ;
% All names are assigned the flag subscripted
% ------------------------------------------------------------------- ;
<< %!*vectorc:='t;                   % should NOT be set. JB 15/3/94
   flag(list_of_names,'subscripted);
   flag(list_of_names,'vectorvar); >>$

put('vectorcode,'stat,'rlis)$
symbolic operator vectorcode$

symbolic procedure vclear list_of_names;
% ------------------------------------------------------------------- ;
% All names are assigned the flag subscripted.
% ------------------------------------------------------------------- ;
<< remflag(list_of_names,'subscripted);
   remflag(list_of_names,'vectorvar); >>$

put('vclear,'stat,'rlis)$
symbolic operator vclear$

symbolic procedure vectorvarp u;
(!*vectorc and subscriptedvarp(u))
or
flagp(u, 'vectorvar);

%global '(!*vectorc)$ switch vectorc$ !*vectorc:='nil$

symbolic procedure optlang u;
if not member(car u, '(nil c fortran f90 pascal ratfor))
   then if eq(car(u), 'fortran90)
           then optlang!* := 'f90
           else rederr("No such targetlanguage available !!!")
   else optlang!* := car u$

put('optlang,'stat,'rlis);

global '(avarlst)$ malst:=avarlst:='nil$

symbolic procedure algresults;
algresults1 prefixlist;

symbolic procedure algresults1 prefixlist;
%-------------------------------------------------------------------- ;
% The algebraic mode facility aresults is used to produce an alg. mode;
% list, presenting the result of a previous optimize-run. All possibly;
% existing algebraic values, of both lhs and rhs variables in the     ;
% listed eq's are stored with the indicator-name a2value,             ;
% simply to avoid untimely backsubstitutions.                         ;
% The algebraic variables, having an avalue are collectedin the list  ;
% avarlst. This list is mainly produced with the procedure check_info.;
% ------------------------------------------------------------------- ;
begin
  scalar results;
  foreach item in prefixlist do
   << check_info car item;
      check_info cdr item;
      results:=list('equal,car item, reval cdr item).results;
   >>;
 if malst then foreach el in malst do put(car el,'simpfn,'simpiden);
 return append(list('list),reverse results)
end;

symbolic operator algresults$
algebraic operator aresults;
algebraic(let aresults=algresults());

symbolic procedure check_info info;
% ------------------------------------------------------------------- ;
% The list info is searched for algebraic variables having an avalue. ;
% This value is saved as value of the indicator a2value, before the   ;
% avalue itself is removed. The variable name is stored in the list   ;
% avarlst.                                                            ;
% ------------------------------------------------------------------- ;
begin scalar aval;
 if pairp(info)
  then
   if constp(info) % Could be some float...
     then info
     else foreach item in info do check_info item
  else
   if idp(info) and not(memq(info,avarlst)) and
      (aval:=get(info,'avalue))
    then << put(info,'a2value,aval);
            remprop(info,'avalue);
            avarlst:=info.avarlst;
            if member(get(info,'rtype),'(array matrix))
               then <>
         >>;
end;
symbolic expr procedure arestore(list_of_names);
% ------------------------------------------------------------------- ;
% All names in the list_of_names get their avalue back.
% Their names are removed from the avarlst.
% ------------------------------------------------------------------- ;
 foreach name in list_of_names do
        << put(name,'avalue,get(name,'a2value));
           remprop(name,'a2value);
           avarlst:=delete(name,avarlst);
           if assoc(name,malst)
              then <>
        >>;
put('arestore,'stat,'rlis)$
symbolic operator arestore$

symbolic procedure restoreall;
% ------------------------------------------------------------------- ;
% All names in the list avarlst get their avalue back.
% Then avarlst is set to nil again.
% ------------------------------------------------------------------- ;
arestore avarlst;


remprop('restoreall,'stat)$   % So next line parses properly.
symbolic operator restoreall$
put('restoreall,'stat,'endstat)$

symbolic expr procedure ireval ex;
%----------------------------------------------------------------------
% `Symbolic-reval'; all variables known to the system by their avalue,
% are hidden by check_info.
% This prevents expressions like x + 1  and 2x + 1  to evaluate to 1
% when x has the avalue 0.
% After this `reval' is applied to obtain a canonical representation of
% ex.
%----------------------------------------------------------------------
begin
  check_info ex;
  if atom ex
     then return ex
     else return (car ex . foreach el in cdr ex collect reval el);
  end;


symbolic procedure ids_to_restore;
% ---------------------------------------------------------------------
% The present value of the fluid variable avarlst is printed.
% ---------------------------------------------------------------------
append(list('list),avarlst)$

symbolic operator ids_to_restore$
algebraic operator restorables$
algebraic(let restorables=ids_to_restore())$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.rlg0000644000175000017500000003745111527635055023462 0ustar  giovannigiovanniFri Feb 18 21:27:59 2011 run on win32
% Test SCOPE Package.
% ==================
% NOTE:  The SCOPE, GHORNER, GSTRUCTR and GENTRAN packages must be loaded
% to run these tests.

% Further reading: SCOPE 1.5 manual Section 3, example 1;

scope_switches$


 ON  :  evallhseqp  exp  ftch  nat  period  
 OFF :  acinfo  again  double  fort  gentranopt  inputc  intern  prefix
        priall  primat  roundbf  rounded  sidrel  vectorc  


% Further reading: SCOPE 1.5 manual Section 3.1, examples 2,3,4 and 5.

on priall$


optimize z:=a^2*b^2+10*a^2*m^6+a^2*m^2+2*a*b*m^4+2*b^2*m^6+b^2*m^2
	   iname s;


      2  2       2  6    2  2          4      2  6    2  2
z := a *b  + 10*a *m  + a *m  + 2*a*b*m  + 2*b *m  + b *m

Sumscheme :

   || EC|Far
------------
  0||  1| z
------------



Productscheme :

   |  0  1  2| EC|Far
---------------------
  1|     2  2|  1| 0
  2|  6     2| 10| 0
  3|  2     2|  1| 0
  4|  4  1  1|  2| 0
  5|  6  2   |  2| 0
  6|  2  2   |  1| 0
---------------------
0  : m
1  : b
2  : a

Number of operations in the input is: 

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 10
Number of integer ^ operations  : 11
Number of / operations          : 0
Number of function applications : 0


s0 := b*a
s4 := m*m
s1 := s4*b*b
s2 := s4*a*a
s3 := s4*s4
z := s1 + s2 + s0*(2*s3 + s0) + s3*(2*s1 + 10*s2)

Number of operations after optimization is:

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 12
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 0


Sumscheme :

   |  0  3  4  5| EC|Far
------------------------
  0|        1  1|  1| z
 15|        2 10|  1| 14
 17|  2  1      |  1| 16
------------------------
0  : s3
3  : s0
4  : s1
5  : s2



Productscheme :

   |  8  9 10 11 17 18 19 20| EC|Far
------------------------------------
  7|                    1  1|  1| s0
  8|  1                 2   |  1| s1
  9|  1                    2|  1| s2
 10|  2                     |  1| s3
 11|                 2      |  1| s4
 14|     1                  |  1| 0
 16|              1         |  1| 0
------------------------------------
8  : s4
9  : s3
10 : s2
11 : s1
17 : s0
18 : m
19 : b
20 : a

off priall$


on primat,acinfo$


optimize
     ghorner <>
     vorder m
     iname s;


Sumscheme :

   || EC|Far
------------
  0||  1| z
  3||  1| 2
  7||  1| 6
 10||  1| 9
------------



Productscheme :

   |  0  1  2| EC|Far
---------------------
  1|     2  2|  1| 0
  2|  2      |  1| 0
  4|        2|  1| 3
  5|     2   |  1| 3
  6|  2      |  1| 3
  8|     1  1|  2| 7
  9|  2      |  1| 7
 11|        2| 10| 10
 12|     2   |  2| 10
---------------------
0  : m
1  : b
2  : a

Number of operations in the input is: 

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 8
Number of integer ^ operations  : 9
Number of / operations          : 0
Number of function applications : 0


s0 := b*a
s1 := b*b
s2 := a*a
s3 := m*m
z := s0*s0 + s3*(s1 + s2 + s3*(2*s0 + s3*(2*s1 + 10*s2)))

Number of operations after optimization is:

Number of (+/-) operations      : 5
Number of unary - operations    : 0
Number of * operations          : 11
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 0


Sumscheme :

   |  0  1  2| EC|Far
---------------------
  0|         |  1| z
  3|     1  1|  1| 2
  7|  2      |  1| 6
 10|     2 10|  1| 9
---------------------
0  : s0
1  : s1
2  : s2



Productscheme :

   |  3  4  5  9 10 11 12| EC|Far
---------------------------------
  1|           2         |  1| 0
  2|  1                  |  1| 0
  6|  1                  |  1| 3
  9|  1                  |  1| 7
 13|                 1  1|  1| s0
 14|                 2   |  1| s1
 15|                    2|  1| s2
 16|              2      |  1| s3
---------------------------------
3  : s3
4  : s2
5  : s1
9  : s0
10 : m
11 : b
12 : a

off exp,primat,acinfo$

 
q:=a+b$


r:=q+a+b$


optimize x:=a+b,q:=:q^2,p(q)::=:r iname s;



x := a + b
q := x*x
p(x) := 2*x

on exp$


clear q,r$



% A similar example follows.
% operator a$% Not necessary. Some differences between REDUCE 3.5 and REDUCE 3.6
% when dealing with indices.

on inputc$


k:=j:=1$


u:=c*x+d$


v:=sin(u)$


optimize {a(k,j):=v*(v^2*cos(u)^2+u),
          a(k,j)::=:v*(v^2*cos(u)^2+u)} iname s;


              2       2
a(1,1) := v*(v *cos(u)  + u)

                      2             3
a(1,1) := cos(c*x + d) *sin(c*x + d)  + sin(c*x + d)*c*x + sin(c*x + d)*d


s9 := cos(u)*v
a(1,1) := v*(u + s9*s9)
s6 := x*c + d
s5 := sin(s6)
s10 := s5*cos(s6)
a(1,1) := s5*(s6 + s10*s10)

off exp$


optimize {a(k,j):=v*(v^2*cos(u)^2+u),
          a(k,j)::=:v*(v^2*cos(u)^2+u)} iname s;


              2       2
a(1,1) := v*(v *cos(u)  + u)

                                 2             2
a(1,1) := (c*x + d + cos(c*x + d) *sin(c*x + d) )*sin(c*x + d)


s9 := cos(u)*v
a(1,1) := v*(u + s9*s9)
s6 := x*c + d
s5 := sin(s6)
s10 := s5*cos(s6)
a(1,1) := s5*(s6 + s10*s10)

off inputc,period$


optlang fortran$


optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;



      s0=5*(h+k)+3*(3*c+d+1+6*(b+f)+2*(a+j+g))
      s3=s0*s0*s0
      s2=s3*s3
      z=s0*s2*s2

off ftch$


optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;


      z=(5*(h+k)+3*(3*c+d+1+6*(b+f)+2*(a+j+g)))**13

optlang c$


optimize z:=(6*a+18*b+9*c+3*d+6*j+18*f+6*g+5*h+5*k+3)^13 iname s;



{
    s0=5*(h+k)+3*(3*c+d+1+6*(b+f)+2*(a+j+g));
    s3=s0*s0*s0;
    s2=s3*s3;
    z=s0*s2*s2;
}


% Note: C code never contains exponentiations.

on ftch$


optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;



{
    s2=3*a;
    x=s2*p;
    y=s2*q;
    s0=2*b;
    s3=6*a;
    z=s0*p+s3*r;
    u=s0*q+s3*d;
    w=4*b;
    v=w*d+9*c*a;
}

off ftch$


optlang fortran$


optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;


      x=3*p*a
      y=3*q*a
      z=2*b*p+6*r*a
      u=2*b*q+6*d*a
      v=4*d*b+9*c*a
      w=4*b

on ftch$


setlength 2$


optimize {x:=3*a*p,y:=3*a*q,z:=6*a*r+2*b*p,u:=6*a*d+2*b*q,
v:=9*a*c+4*b*d,w:=4*b} iname s;


      x=3*p*a
      y=3*q*a
      z=2*b*p+6*r*a
      u=2*b*q+6*d*a
      v=4*d*b+9*c*a
      w=4*b

resetlength$


optlang nil$



% Further reading: SCOPE 1.5 manual section 3.1, example 9 and section 3.2.

u:=a*x+2*b$


v:=sin(u)$


w:=cos(u)$


f:=v^2*w;


                                  2
f := cos(a*x + 2*b)*sin(a*x + 2*b)

off exp$


optimize f:=:f,g:=:f^2+f iname s$



s3 := x*a + 2*b
s2 := sin(s3)
f := s2*s2*cos(s3)
g := f*(f + 1)

alst:=aresults;


alst := {s3=a*x + 2*b,

         s2=sin(s3),

                     2
         f=cos(s3)*s2 ,

         g=(f + 1)*f}

restorables;


{f}

f;


f

arestore f;


f;


                             2
cos(a*x + 2*b)*sin(a*x + 2*b)

alst;


{s3=a*x + 2*b,

 s2=sin(s3),

                              2           2
 cos(a*x + 2*b)*sin(a*x + 2*b) =cos(s3)*s2 ,

                                 2                                   2
 g=(cos(a*x + 2*b)*sin(a*x + 2*b)  + 1)*cos(a*x + 2*b)*sin(a*x + 2*b) }

optimize f:=:f,g:=:f^2+f iname s$



s3 := x*a + 2*b
s2 := sin(s3)
f := s2*s2*cos(s3)
g := f*(f + 1)

alst:=aresults$


optimize f:=:f,g:=:f^2+f iname s$



g := f*(f + 1)

restoreall$


f;


f


% Further reading: SCOPE 1.5 manual section 3.1, example 8. 
%                  See also section 5.
%                  Also recommended: section 9.

clear a$


matrix a(2,2)$


a(1,1):=x+y+z$


a(1,2):=x*y$


a(2,1):=(x+y)*x*y$


a(2,2):=(x+2*y+3)^3-x$


on exp$


off fort,nat$


optimize detexp:=:det(a) out "expfile" iname s$



off exp$


optimize detnexp:=:det(a) out "nexpfile" iname t$



in expfile$


in nexpfile$


on nat$


detexp-detnexp;


0

system "rm expfile nexpfile"$



% Further reading: SCOPE 1.5 manual section 4.2, example 15.
% Although the output is similar, it is in general equivalent and
% not identical when using REDUCE 3.6 in stead of REDUCE 3.5. This
% is due to improvements in the simplification strategy.

on acinfo$


optimize 
   gstructr<>
name v iname s;


Number of operations in the input is: 

Number of (+/-) operations      : 8
Number of unary - operations    : 0
Number of * operations          : 8
Number of integer ^ operations  : 3
Number of / operations          : 0
Number of function applications : 0


v1 := y + z
a(1,1) := v1 + x
a(1,2) := y*x
v3 := y + x
a(2,1) := a(1,2)*v3
s6 := 2*y + x
s4 := s6 + 3
a(2,2) := s4*s4*s4 - x
aa := v3*v3
b := v1*v3
s5 := z + x
c := s6*s5*s5*v1

Number of operations after optimization is:

Number of (+/-) operations      : 7
Number of unary - operations    : 0
Number of * operations          : 10
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 5


alst:=
  algopt(algstructr({a,b=(x+y)^2,c=(x+y)*(y+z),d=(x+2*y)*(y+z)*(z+x)^2},v),s);


Number of operations in the input is: 

Number of (+/-) operations      : 8
Number of unary - operations    : 0
Number of * operations          : 8
Number of integer ^ operations  : 3
Number of / operations          : 0
Number of function applications : 0



Number of operations after optimization is:

Number of (+/-) operations      : 7
Number of unary - operations    : 0
Number of * operations          : 10
Number of integer ^ operations  : 0
Number of / operations          : 0
Number of function applications : 5


*** a declared operator 

alst := {v1=y + z,

         a(1,1)=v1 + x,

         a(1,2)=x*y,

         v3=x + y,

         a(2,1)=a(1,2)*v3,

         s6=x + 2*y,

         s4=s6 + 3,

                  3
         a(2,2)=s4  - x,

             2
         b=v3 ,

         c=v1*v3,

         s5=x + z,

             2
         d=s5 *s6*v1}

off acinfo$



% Further reading: SCOPE 1.5 manual section 4.3, example 16.

clear a$


procedure taylor(fx,x,x0,n);
 sub(x=x0,fx)+(for k:=1:n sum(sub(x=x0,df(fx,x,k))*(x-x0)^k/factorial(k)))$


hlst:={f1=taylor(e^x,x,0,4),f2=taylor(cos x,x,0,6)}$


on rounded$


hlst:=hlst;


                              3      2
hlst := {f1=0.0416666666667*(x  + 4*x  + 12*x + 24)*x + 1,

                                  4       2         2
         f2= - 0.00138888888889*(x  - 30*x  + 360)*x  + 1}

optimize alghorner(hlst,{x}) iname g$



g1 := x*x
g0 := g1*x
f1 := 1 + x*(0.166666666667*g1 + 0.0416666666667*g0 + 1 + 0.5*x)
f2 := 1 + g1*(0.0416666666667*g1 - 0.5 - 0.00138888888889*g0*x)

off rounded$



% Further reading: SCOPE 1.5 manual section 3.1, examples 6 and 7.

optimize z:=:for j:=2:6 sum a^(1/j) iname s$



       1/60
s0 := a
s8 := s0*s0
s7 := s8*s0
s5 := s8*s7
s3 := s5*s5
s2 := s8*s3
s1 := s7*s2
s4 := s5*s1
z := s3 + s2 + s1 + s4 + s4*s3

optimize z1:=a+sqrt(sin(a^2+b^2)), z2:=b+sqrt(sin(a^2+b^2)), 
         z3:=a+b+(a^2+b^2)^(1/2),  z4:=sqroot(a^2+b^2)+(a^2+b^2)^3, 
         z5:=a^2+b^2+cos(a^2+b^2), z6:=(a^2+b^2)^(1/3)+(a^2+b^2)^(1/6)  
iname s;



s6 := b*b + a*a
s8 := sqrt(sin(s6))
z1 := s8 + a
z2 := s8 + b
        1/6
s7 := s6
s9 := s7*s7
z3 := a + b + s9*s7
z4 := sqroot(s6) + s6*s6*s6
z5 := s6 + cos(s6)
z6 := s7 + s9


% Further reading: SCOPE 1.5 manual section 6, examples 18 and 19.

optlang fortran$


optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;



      integer b(5),i,s10,s9
      real a(4,4),x(4),y(5)
      s10=i+1
      s9=i-1
      x(s10,s9)=a(s10,s9)+b(i)
      y(s9)=a(s9,s10)-b(i)

optlang c$


optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;



int b[6],i,s10,s9;
float a[5][5],x[5],y[6];
{
    s10=i+1;
    s9=i-1;
    x[s10][s9]=a[s10][s9]+b[i];
    y[s9]=a[s9][s10]-b[i];
}

optlang  pascal$


optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;



var
    s9,s10,i: integer;
    b: array[0..5] of integer;
    y: array[0..5] of real;
    x: array[0..4] of real;
    a: array[0..4,0..4] of real;
begin
    s10:=i+1;
    s9:=i-1;
    x[s10,s9]:=a[s10,s9]+b[i];
    y[s9]:=a[s9,s10]-b[i]
end;

optlang ratfor$


optimize {x(i+1,i-1):=a(i+1,i-1)+b(i),y(i-1):=a(i-1,i+1)-b(i)} iname s
         declare <>;



integer b(5),i,s10,s9
real a(4,4),x(4),y(5)
{
    s10=i+1
    s9=i-1
    x(s10,s9)=a(s10,s9)+b(i)
    y(s9)=a(s9,s10)-b(i)
}

precision 7$


on rounded, double$


optlang fortran$


optimize x1:=2         *a + 10        *b,
         x2:=2.00001   *a + 10        *b,
         x3:=2         *a + 10.00001  *b,
         x4:=6         *a + 10        *b,
         x5:=2.0000001 *a + 10.000001 *b
iname s
declare << x1,x2,x3,x4,x5,a,b:real>>$



      double precision a,b,s1,s2,x1,x2,x3,x4,x5
      s1=2*a
      s2=10*b
      x1=s2+s1
      x2=s2+2.00001d0*a
      x3=s1+1.000001d1*b
      x4=s2+6*a
      x5=x1


% Further reading: SCOPE 1.5 manual section 7, example 20.
% Notice the double role of e: In the lhs as identifier. In the rhs as
% exponential function.
% Further notice that a is expected to be declared operator. This is
% due to lower level scope activities.

optimize a(1,x+1)  := g + h*r^f,
         b(y+1)    := a(1,2*x+1)*(g+h*r^f),
         c1        := (h*r)/g*a(2,1+x),
         c2        := c1*a(1,x+1) + sin(d),
         a(1,x+1)  := c1^(5/2),
         d         := b(y+1)*a(1,x+1),
         a(1,1+2*x):= (a(1,x+1)*b(y+1)*c)/(d*g^2),
         b(y+1)    := a(1,1+x)+b(y+1) + sin(d),
         a(1,x+1)  := b(y+1)*c + h/(g + sin(d)),
         d         := k*e + d*(a(1,1+x) + 3),
         e         := d*(a(1,1+x) + 3) + sin(d),
         f         := d*(3 + a(1,1+x)) + sin(d),
         g         := d*(3 + a(1,1+x)) + f
iname s
declare << a(5,5),b(7),c,c1,d,e,f,g,h,r:real*8; x,y:integer>>$


*** a declared operator 


      integer x,y,s0,s2,s6
      double precision c,h,r,s34,s3,c1,c2,s4,s24,b(7),a(5,5),s29,k,d,s33
     . ,e,f,g
      s0=x+1
      s34=r**f*h+g
      s2=1+y
      s6=2*x+1
      s3=s34*a(1,s6)
      c1=a(2,s0)*((r*h)/g)
      c2=dsin(d)+s34*c1
      s4=dsqrt(c1)*c1*c1
      d=s4*s3
      a(1,s6)=(d*c)/(g*g*d)
      s24=dsin(d)
      b(s2)=s4+s3+s24
      a(1,s0)=h/(g+s24)+b(s2)*c
      s29=3+a(1,s0)
      d=s29*d+dexp(1.0d0)*k
      s33=s29*d
      e=s33+dsin(d)
      f=dexp(1.0d0)
      g=s33+f


% Further reading: SCOPE 1.5 manual section 8, examples 21 and 22.
%                  Also recommended: section 9.

optlang nil$


delaydecs$


 gentran declare <>$


 gentran a:=b+c$


 gentran d:=b+c$


 gentran <>$


makedecs$

      double precision a,b,c,d,q,w
      a=b+c
      d=b+c
      q=b+c
      w=b+c

on gentranopt$


delaydecs$


 gentran declare <>$


 gentran a:=b+c$




 gentran d:=b+c$




 gentran <>$




makedecs$

      double precision b,c,a,d,q,w
      a=b+c
      d=b+c
      q=b+c
      w=q

off gentranopt$


delayopts$


 gentran declare <>$


 gentran a:=b+c$


 gentran d:=b+c$


 gentran <>$


makeopts$



      a=b+c
      d=a
      q=a
      w=a

delaydecs$


 gentran declare <>$


 delayopts$


  gentran a:=b+c$


  gentran d:=b+c$


  gentran <>$


 makeopts$




makedecs$

      double precision b,c,a,d,q,w
      a=b+c
      d=a
      q=a
      w=a

clear a,b,c,d,q,w$


matrix a(2,2)$


a:=mat(((b+c)*(c+d),(b+c+2)*(c+d-3)),((c+b-3)*(d+b),(c+b)*(d+b+4)));


     [  (b + c)*(c + d)    (c + 2 + b)*(d - 3 + c)]
a := [                                            ]
     [(c - 3 + b)*(b + d)    (d + 4 + b)*(b + c)  ]


gentranlang!*:='c$


delayopts$


 gentran aa:=:a$


makeopts$



{
    {
        g17=b+c;
        g18=c+d;
        aa[1][1]=g18*g17;
        aa[1][2]=(g18-3)*(g17+2);
        g16=b+d;
        aa[2][1]=g16*(g17-3);
        aa[2][2]=g17*(g16+4);
    }
}

end;


Time for test: 93 ms
@@@@@ Resources used: (0 0 30 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/minlngth.red0000644000175000017500000001773511526203062024146 0ustar  giovannigiovannimodule minlngth;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%----------------------------------------------------------------------
%  Minimum length provisions.
%  Date   : Feb. 1992
%  Provides user with operator setlength to indicate minimal length of
%  requested c.s.e.'s.
%----------------------------------------------------------------------

symbolic operator setlength,resetlength;
put('resetlength,'stat,'endstat)$

symbolic procedure setlength l;
%---------------------------------------------------------------
% l : integer evaluable expression.
% min!-expr!-length!* is set accordingly.
%---------------------------------------------------------------
if not fixp reval l
   then
    rederr("Please use integer values for minimum length setting!!")
   else min!-expr!-length!* := reval l;

symbolic procedure resetlength;
%---------------------------------------------------------------
% Resets min!-expr!-length!* to nil.
%---------------------------------------------------------------
if min!-expr!-length!*
   then << % write "Old value : ",min!-expr!-length!*;terpri();
           min!-expr!-length!* := nil;
        >> ;

symbolic procedure countsilent prf;
% -------------------------------------------------------------------
% Altered version of `countnop'.
% The number of +/-, unary -, *, integer ^, / and function applica-
% tions is counted in prf, consisting of a pair (lhs.rhs). Array
% references are seen as function applications if the array name is
% not contained in the symbol table.
% The result of the counts operation is the list totcts of the form :
%  ( #(+/-) #(-) #(*) #(^) #(/) #(other) )
%                                                 (# = number of.)
% -------------------------------------------------------------------
begin scalar totcts,res;
 totcts:='(0 0 0 0 0 0);
 totcts:=counts2(cdr prf,totcts,nil);
 res:=0;
 foreach el in totcts do res:=res + el;
 return res
end;

symbolic procedure counts2(expression,locs,root);
% -------------------------------------------------------------------
% Altered version of `counts'.
% The actual counts are recursively done with the function counts by
% modifying the value of the 6 elements of locs.  The elements of locs
% define the present number of the 6 possible categories of operators,
% which we distinguish.
% -------------------------------------------------------------------
begin scalar n!+,n!-,n!*,n!^,n!/,n!f,tlocs,loper,operands;
 if idp(expression) or constp(expression)
  then tlocs:=locs
  else
   << n!+:=car locs; n!-:=cadr locs; n!*:=caddr locs; n!^:=cadddr locs;
      n!/:=car cddddr locs; n!f:= car reverse locs;
      loper:=car expression; operands:=cdr expression;
      if loper memq '(plus difference)
       then n!+:=(length(operands)-1)+n!+
       else
        if loper eq 'minus
         then (if root neq 'plus then n!-:=1+n!-)
         else
          if loper eq 'times
           then n!*:=(length(operands)-1)+n!*
           else
            if loper eq 'expt
             then (if integerp(cadr operands)
                   then n!^:=1+n!^ else n!f:=min!-expr!-length!*)
             else
              if loper eq 'quotient
               then n!/:=1+n!/
               else
                if not(subscriptedvarp(loper))
                 then n!f:=min!-expr!-length!*;
      tlocs:=list(n!+,n!-,n!*,n!^,n!/,n!f);
      if not subscriptedvarp(loper)
         then foreach op in operands do tlocs:=counts2(op,tlocs,loper);
   >>;
 return(tlocs)
end;

symbolic smacro procedure protected(a,pn);
member((if atom a then a else car a), pn);

symbolic procedure make_min_length(prefixlist, protectednames);
% ---------------------------------------------------------------------
% This procedure modifies the prefixlist in a sense that either :
%    - righthandsides contain at least min!-expr!-length!* operations
%      at the first level.
%    - righthandsides define an output variable
%      (lhside member protectednames)
% ---------------------------------------------------------------------
begin
  scalar exp,lhs,rhs,npfl,dellst,ass;
  exp:=!*exp; !*exp:=nil;
  while prefixlist do
        <>;
          if not protected(car ass, protectednames)
             and (countsilent(ass) < min!-expr!-length!*)
             then dellst := ass . dellst
             else npfl := ass . npfl;
         >>;
  !*exp:=exp;
  return reverse npfl;
  end;

symbolic procedure scope_switches2(choice);
% ------------------------------------------------------------------- ;
% If choice = t a list of all switches, given in the list switches,   ;
% which are on, is produced.                                          ;
% If choice = nil a complementary action is performed.                ;
% Hence both possible calls produce the union of all switches relevant;
% in the scope context.                                               ;
% ------------------------------------------------------------------- ;
begin scalar switches, twoblanks, eightblanks, prtlist, len, firstpart;
 switches:='(!*acinfo !*again !*double !*evallhseqp !*exp !*fort !*ftch
             !*gentranopt !*inputc !*intern !*nat !*period !*prefix
             !*priall !*primat !*roundbf !*rounded !*sidrel !*vectorc);
 twoblanks:='(!! !  !! !  );
 eightblanks:=append(
               append(
                append(twoblanks,twoblanks),
                twoblanks),
               twoblanks);
 foreach swtch in reverse(switches) do
  if choice=eval(swtch)
   then prtlist:=append(append(cddr explode swtch,twoblanks),prtlist);
 while (len:=length prtlist)>72 do
  << firstpart:=pnth(reverse prtlist, len-71);
     prtlist:=pnth(prtlist,73);
     while car(firstpart) neq car '(!!) do
      << firstpart:=car(prtlist).firstpart;
         prtlist:=cdr prtlist ;
      >>;
     prtlist:=car(firstpart).prtlist;        %
     firstpart:=reverse cdr firstpart;       % remove '!!
     while car(firstpart) member '(!! ! ) do firstpart:=cdr firstpart;
     write compress firstpart; terpri();
     write compress eightblanks;              % correct indentation
  >>;
 if prtlist then
 while car(prtlist) eq car '(!!) or
       car(prtlist) eq car '(! ) do prtlist:=cdr prtlist;
 if prtlist then write compress prtlist; terpri()
end;

symbolic procedure scope_ons;
<< write" ON  :  ";
   scope_switches2 't
>>;


symbolic procedure scope_offs;
<>;

symbolic procedure scope_switches;
begin
  terpri();
  scope_ons();
  scope_offs();
end;

symbolic operator scope_switches$
put('scope_switches,'stat,'endstat)$
symbolic operator scope_ons$
put('scope_ons,'stat,'endstat)$
symbolic operator scope_offs$
put('scope_offs,'stat,'endstat)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codhrn.red0000644000175000017500000007622711526203062023604 0ustar  giovannigiovannimodule ghorner;   % Generalized Horner support.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author  :   M.C. van Heerwaarden.                                   ;
% ------------------------------------------------------------------- ;
% ------------------------------------------------------------------- ;
% This module contains procedures which implement a generalized Horner;
% scheme. There are two generalizations:                              ;
% 1. It is possible to offer a set of assignment statements. Each RHS ;
%    will be transformed into a Horner scheme.;                       ;
% 2. A list of identifiers is accepted as input.The polynomial will be;
%    hornered w.r.t. the first identifier in the list, then the       ;
%    coefficients are hornered w.r.t. the second identifier, etc.     ;
%                                                                     ;
% The following steps are taken to achieve this result.               ;
%                                                                     ;
% The polynomial P is expanded by turning on the switch EXP and by    ;
% applying Aeval on P. Each term of the expanded polynomial is brought;
% in a normal form. The terms are sorted using a binary tree represen-;
% tation. From this tree a list of terms is extracted with the powers ;
% in descending order.This list is rewritten into a Horner scheme.    ;
%                                                                     ;
% The 'normal form' of a term is:                                     ;
%      (TIMES COEF (EXPT X N))                                        ;
% It may be degenerated to:                                           ;
%      (EXPT X N)                for COEF = 1                         ;
%      (TIMES COEF X)            for N = 1                            ;
%      (COEF)                    for N = 0                            ;
% When a term is a minus term, the minus is handled as a part of the  ;
% coefficient.                                                        ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*algpri autohorn);

switch algpri;

!*algpri := t;

% ------------------------------------------------------------------- ;
% ALGEBRAIC MODE COMMAND PARSER                                       ;
% ------------------------------------------------------------------- ;
% The -STAT and FORM- procedures provide an interface with the        ;
% algebraic mode. To horner a set of expressions, one can use the     ;
% HORNER command, which has the following syntax:                     ;
%    ::= GHORNER  [VORDER ]       ;
%         ::=  |                     ;
%                        <<                     ;
%                                        {; } >>;
%           ::=  |  {, }                         ;
% When the switch ALGPRI is ON, results are printed using Assgnpri,   ;
% When used inside a SCOPE-command the switch ALGPRI is turned OFF    ;
% automatically. However the current ALGPRI-setting is automatically  ;
% restored by SCOPE.                                                  ;
% ------------------------------------------------------------------- ;

put('ghorner, 'stat, 'ghornerstat);

symbolic procedure ghornerstat;
begin
    scalar x,y;
    % --------------------------------------------------------------- ;
    % GHORNER has already been read.                                  ;
    % --------------------------------------------------------------- ;
    flag('(vorder), 'delim);
    flag('(!*rsqb), 'delim);
    if car(x := xread t) = 'progn   % Read expressions;
    then x := cdr x                 % Remove keyword PROGN;
    else x := list x;               % An assignment is also an asslist;
    if not(cursym!* eq 'vorder)
    then if cursym!* eq '!*semicol!*
         then autohorn := t
         else symerr('ghorner, t)
    else << autohorn := nil;
            y := remcomma xread nil   % Read variable ordering list;
         >>;
    remflag('(vorder), 'delim);
    remflag('(!*rsqb), 'delim);
    return list('ghorner, x, y)
end;

put('ghorner, 'formfn, 'formghorner);

symbolic procedure formghorner(u, vars, mode);
    list('ghorner, mkquote cadr u, mkquote caddr u);

symbolic procedure ghorner(assset, varlist);
% ------------------------------------------------------------------- ;
% arg: assset = set of assignment statements                          ;
%      varlist = a list of variables                                  ;
% eff: For each assignment statement in assset, the RHS is turned into;
%      a Horner scheme. When varlist is not empty, the first variable ;
%      from varlist is used to form the scheme. The cdr of varlist is ;
%      used to transform the coefficients into a Horner scheme.       ;
%      Implicitly, the assignment is executed by putting the SQ-form  ;
%      of the Horner scheme on the property-list of the LHS-variable. ;
%      This means that the Horner scheme is available in the algebraic;
%      mode. When the switch ALGPRI is ON, the list of assignment     ;
%      statements is printed.                                         ;
% res: If ALGPRI is OFF the list with hornered assignment statements  ;
%      is returned. Nothing is returned when ALGPRI is ON.            ;
% ------------------------------------------------------------------- ;

begin
    scalar h, hexp, res;
    hexp := !*exp;
    !*exp := nil;
    res := for each ass in assset collect
               if not eqcar(ass, 'setq)
               then
                rederr("Assignment statement expected")
               else
                << h:=inithorner(caddr ass, varlist);
                   if !*algpri
                    then << if eqcar(h, 'quotient)
                             then
                              put(cadr ass,'avalue,
                               list('scalar,
                                     mk!*sq(numr !*f2q !*a2f cadr h ./
                                            numr !*f2q !*a2f caddr h)))
                              else
                               put(cadr ass,'avalue,
                                list('scalar, mk!*sq !*f2q !*a2f h));
                             assgnpri(h, list cadr ass, t);
                             terpri()
                          >>
                     else list(car ass,cadr ass,h)
                 >>;
    autohorn := nil;
    !*exp := hexp;
    if not !*algpri
    then return res
end;

symbolic procedure inithorner(p, varlist);
% ------------------------------------------------------------------- ;
% arg: p = polynomial                                                 ;
%      varlist = list of variables                                    ;
% eff: p is expanded and hornered to the various variables            ;
% res: the hornered version of p                                      ;
% ------------------------------------------------------------------- ;
begin scalar n, d, hmcd, res;
    hmcd := !*mcd;
    !*mcd := t;
    p := reval p;
    res := hornersums(p, varlist);
    !*mcd := hmcd;
    return res
end;

symbolic procedure hornersums(p, varlist);
    if (atom(p) or domprop(p))      % JB 9/3/94
    then p
    else if eqcar(p, 'plus)
         then horner(p, varlist)
         else append(list car p,
                     for each elt in cdr p
                     collect hornersums(elt, varlist));

symbolic procedure horner(p, varlist);
% ------------------------------------------------------------------- ;
% arg: p = polynomial                                                 ;
%      varlist = a list of variables for which the scheme must be made;
% res: A Horner scheme of p with respect to first variable in varlist ;
% ------------------------------------------------------------------- ;
begin
    scalar hexp, tree, var;
    hexp := !*exp;
    !*exp := t;
    p := reval p;
    tree := '(nil nil nil);
    var := if varlist
           then car varlist
           else if autohorn
                then mainvar2 p
                else nil;
    if var
    then << for each kterm in cdr p
            do tree := puttree(tree,
                               orderterm(kterm, var),
                               var);
            p := gathertree(tree, var . cdr varlist);
            p := schema(p, var, kpow(car p, var))
          >>;
    !*exp := hexp;
    return p
end;


symbolic procedure hornercoef(term, varlist);
% ------------------------------------------------------------------- ;
% arg: term = term of a polynomial in 'normal form'                   ;
%      varlist = the list of variables, including the one which just  ;
%                has been used to create the scheme.                  ;
% res: The same term is returned, but the coefficient has been turned ;
%      into a Horner scheme, using the second variable of varlist as  ;
%      main variable.                                                 ;
% ------------------------------------------------------------------- ;
begin
    scalar n, cof;
    return if null(cof := kcof(term, (n := kpow(term, car varlist))))
           then nil
           else if atom cof
                then term
                else if n = 0
                     then hornersums(cof, cdr varlist)
                     else list(car term,
                               hornersums(cof, cdr varlist),
                               caddr term)
end;

symbolic procedure puttree(tree, term, var);
% ------------------------------------------------------------------- ;
% arg: tree = tree structure ( node, left edge, right edge), in which ;
%             the ordered terms are present.                          ;
%      term = the term which has to be put in                         ;
%      var = the variable for which the Horner scheme must be made    ;
% res: When the power of term is higher than the power of the node of ;
%      the root, puttree is called to place term in the right subtree ;
%      If the power is lower, term is placed in the left subtree. If  ;
%      the powers are equal the coefficients are added.               ;
% ------------------------------------------------------------------- ;
begin
    scalar c, n, m;
    return if null tree or null car tree
           then list (term, nil, nil)
           else if (n := kpow(term, var)) < (m := kpow(car tree, var))
                then list(car tree,
                          puttree(cadr tree, term, var),
                          caddr tree)
                else if n > m
                     then list(car tree,
                               cadr tree,
                               puttree(caddr tree, term, var))
                     else << % n = m so at least one term has been    ;
                             % inserted. Terms are added using only   ;
                             % one plus.                              ;
                             c := kcof(car tree, n);
                             if pairp c and car c = 'plus
                             then c := cdr c
                             else c := list c;
                             if n = 0
                             then
                              list(append('(plus),
                                         append(list(kcof(term,n)),c)),
                                   cadr tree,
                                   caddr tree)
                             else
                              list(list('times,
                                         append('(plus),
                                         append(list(kcof(term,n)),c)),
                                         if car c = 1
                                          then car tree
                                          else caddar tree
                                        ),
                                   cadr tree,
                                   caddr tree)>>
end;


symbolic procedure gathertree(tree, varlist);
% ------------------------------------------------------------------- ;
% arg: tree = a tree as made by puttree                               ;
%      varlist = list of variables                                    ;
% res: a list of the terms which are stored in the tree. The term with;
%      the highest power is first in the list. For every term found, a;
%      Horner-scheme is made for the coefficients of this term.At this;
%      point the current variable remains on varlist.                 ;
% ------------------------------------------------------------------- ;
begin
    % This is a reversed depth-first search;
    return if null tree
           then nil
           else append(gathertree(caddr tree, varlist),
                       append(list hornercoef(car tree, varlist),
                              gathertree(cadr tree, varlist)))
end;


symbolic procedure orderterm(tt, var);
% ------------------------------------------------------------------- ;
% arg: tt = one term from the expanded polynomial                     ;
%      var = the variable for which the Horner scheme must be made    ;
% res: the term tt is returned in the 'normal form' which is described;
%      in the opening section.                                        ;
% ------------------------------------------------------------------- ;
begin
    scalar h, res, factr, min;
    min := nil;
    if tt = var
    then res := tt
    else << if eqcar(tt, 'minus)
            then << min := t;
                    tt := cadr tt
                 >>;
            if not eqcar(tt,'times)
            then if min
                 then if tt=var or (eqcar(tt,'expt) and cadr tt=var)
                      then res := list('times, '(minus 1), tt)
                      else res := list('minus, tt)
                 else res := tt
            else << while not null (tt := cdr tt)
                    do << if pairp(h := car tt) and eqcar(h, 'minus)
                          then << min := not min;
                                  h := cadr h
                               >>;
                          if h = var
                          then factr := h
                          else << if eqcar(h, 'expt) and cadr h = var
                                  then factr := h
                                  else res := append(res, list h)
                               >>
                       >>;
                    if min
                    then << h := list('minus, car res);
                            if null cdr res
                            then res := list h
                            else res := append(list h, cdr res)
                         >>;
                    res := if null factr
                           then cons('times, res)
                           else if null cdr res
                                then list('times, car res, factr)
                                else list('times,
                                          append('(times), res),
                                          factr)
                 >>
         >>;
    return res
end;

symbolic procedure schema(pn, var, n);
% ------------------------------------------------------------------- ;
% arg: pn  = the polynomial pn given as a list of terms in 'normal    ;
%            form' in decsending order w.r.t. the powers of these     ;
%            terms.                                                   ;
%      var = the Horner-scheme variable.                              ;
%      n   = degree of the polynomial.                                ;
% eff: Some effort is made to change "(TIMES var 1)" to "var" and to  ;
%      turn "...(TIMES var (TIMES var..." into                        ;
%           "...(TIMES (EXPT var n) ..."                              ;
% res: Horner scheme for the polynomial pn.                           ;
% ------------------------------------------------------------------- ;
begin
    scalar hn, k, k!+1mis;
    hn := kcof(car pn, n); % The n-th term always exists;
    if null (pn := cdr pn) then pn:=list(nil);
       % Else car(NIL) could be evaluated.
    for k := (n - 1) step -1 until 0
    do << % --------------------------------------------------------- ;
          % hn contains the coefficients for the terms var^n upto     ;
          % var^(k+1). The var for term var^(k+1) is still missing.   ;
          % This is correct when for k=0 the last var will be added.  ;
          % --------------------------------------------------------- ;
          if kpow(car pn, var) = k
          then << % k-th term exists;
                  hn := list('plus, kcof(car pn, k),
                             if hn = 1
                             then var
                             else if not (k = n-1) and k!+1mis
                                  then
                                   if pairp hn and car hn = 'times
                                    then list('times,list('expt,var,
                                              kpow(cadr hn, var) + 1),
                                                 caddr hn)
                                    else list('expt,var,
                                                 kpow(hn, var) + 1)
                                  else list('times, var, hn)
                            );
                  k!+1mis := nil;
                  if null (pn := cdr pn) then pn:=list(nil)
               >>
          else << % k-th term misses;
                  hn := if hn = 1
                        then var
                        else if not (k = n-1) and k!+1mis
                             then
                              if pairp hn and car hn = 'times
                               then list('times,list('expt,var,
                                               kpow(cadr hn, var) + 1),
                                          caddr hn)
                               else list('expt, var, kpow(hn, var) + 1)
                             else list('times, var, hn);
                  k!+1mis := t
               >>
       >>;
    return hn
end;


symbolic procedure kpow(term, var);
% ------------------------------------------------------------------- ;
% arg: term = term of a polynomial in 'normal form'                   ;
%      var  = the variable for which the Horner scheme must be made   ;
% res: the power of var in term                                       ;
% ------------------------------------------------------------------- ;
begin
    scalar h;
    return if null term
           then nil
           else if (h := term) = var
                then 1
                else if eqcar(h, 'expt) and eqcar(cdr h, var)
                     then caddr h
                     else if eqcar(h, 'times)
                          then if (h := caddr h) = var
                               then 1
                               else if not atom h and eqcar(cdr h, var)
                                    then caddr h
                                    else 0
                          else 0
end;


symbolic procedure kcof(term, n);
% ------------------------------------------------------------------- ;
% arg: term = term of a polynomial in 'normal form'                   ;
%      n    = the power of term                                       ;
% res: the coefficient of var in term                                 ;
% ------------------------------------------------------------------- ;
    if null n
    then nil
    else if n = 0
         then term
         else if n = 1
              then if not eqcar(term, 'times)
                   then 1
                   else cadr term
              else if eqcar(term, 'expt)
                   then 1
                   else cadr term;

symbolic procedure mainvar2 u;
% ------------------------------------------------------------------- ;
% Same procedure as mainvar from ALG2.RED, but returns NIL instead of ;
% 0 and does not allow a mainvar of the form (EXPT E X) to be returned;
% ------------------------------------------------------------------- ;
begin
   scalar res;
   res := if domainp(u := numr simp!* u)
          then nil
          else if sfp(u := mvar u)
               then prepf u
               else u;
   if eqcar(res, 'expt)
   then res := nil;
   return res
 end;


%-----------------------------------------------------------------------
% Algebraic mode psop function definition.
%-----------------------------------------------------------------------

symbolic procedure alghornereval u;
% -------------------------------------------------------------------- ;
% Variant of ghorner-command.  Accepts 1 or 2 arguments.  The first has
% to be a list of equations.  Their rhs's have to be hornered.  The
% second argument is optional.  It defines the list of identifiers to
% be used for the ordering.

% -------------------------------------------------------------------- ;
begin scalar algpri,assset,res,varlist; integer nargs;
 nargs:=length u;
 if nargs<3
  then << assset:=foreach el in (if atom car u
                                    then cdr reval car u
                                    else cdar u )collect
                  list('setq,cadr el,caddr el);
          if nargs=2 then varlist:=cdadr u
       >>
  else assset:='!*!*error!*!*;
 if eq(assset,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS ALGHORNER")
  else << algpri:=!*algpri; !*algpri:=nil;
          res:=apply('ghorner,list(assset,varlist));
          if (!*algpri:=algpri)
           then
           return algresults1(foreach el in res
                                 collect cons(cadr el,caddr el))
           else return res
       >>
end;

put('alghorner,'psopfn,'alghornereval)$


%------------------------------------------------------------------
%       Construction of Krukyov Horner's form of polynomial  % JB 9/3/94
%------------------------------------------------------------------

algebraic procedure horner0(p,x)$
  %----------------------------------------------------------
  %       p is a polynomial,
  %       x is a Horner's variable$
  %       return p transformed to Horner's form
  %----------------------------------------------------------
  begin scalar c,h$
    on exp$
    p:=p$
    c:=reverse coeff(p,x)$
    off exp$
    h:=0$
    while c neq {} do <<
      h:=h*x+first c$
      c:=rest c$
    >>$
    return h$
end$

algebraic procedure horner1(p)$
  %----------------------------------------------------------
  %       p is a polynomial,
  %       return p transformed to Horner's form
  %       the MAINVAR of p use as a Horner's variable
  %----------------------------------------------------------
 if numberp p then p else
  begin scalar c,h,x$
    on exp$
    p:=p$
    x:=mainvar p$
    c:=reverse coeff(p,x)$
    off exp$
    h:=0$
    while c neq {} do <<
      h:=h*x+horner1 first c$
      c:=rest c$
    >>$
    return h$
end$

lisp global '(hvlst)$     % use for debug purposes.

algebraic procedure horner2(p)$
  %----------------------------------------------------------
  %       p is a polynomial,
  %       return p transformed to Horner's form
  %       Horner's variable is defined by HVAR1 procedure.
  %       Outside effect: clear HVLST variable.
  %       HVLST variable content the result of work of HVAR1
  %          (use for debug purposes).
  %----------------------------------------------------------
  << clhvlist()$ horner20 p >>$

algebraic procedure horner20(p)$
  %----------------------------------------------------------
  %       p is a polynomial,
  %       return p transformed to Horner's form
  %       Horner's variable is defined by HVAR1 procedure.
  %----------------------------------------------------------
 if numberp p then p
  else begin scalar q,x,c$
         on exp$
           q:=p$
           x:=hvar1 q$
           c:=sub(x=0,q)$
           q:=(q-c)/x$
         off exp$
         q:=horner20(q)*x+horner20(c)$
         return q$
       end$

symbolic procedure hvar1 q$
  %----------------------------------------------------------
  %       q is a polynomial,
  %       return Horner's variable.
  %       Outside effect: set HVLST variable (use for debug only).
  %         HVLST::=((expr . alst)...)
  %         expr::=polynomial
  %         alst::=((var.number)...)
  %       Here the Horner's variable define as a variable
  %       that entry to q in more tems then others.
  %       For example: X+X**2+Y+1. The Horner's variable is X.
  %----------------------------------------------------------
 if numberp q then rederr "HVAR1: impossible!" else
  begin scalar x,y,v$
    q:=reval q$              % usually it is not needed.
    if null atom q and car q eq 'plus then q:=cdr q
      else q:=list q$
    for each z in q do <<
         if null atom z and car z eq 'minus then z:=cadr z$
         if null atom z and car z eq 'times then z:=cdr z
           else z:=list z$
         for each w in z do <<
             if null atom w and car w eq 'expt then w:=cadr w
              else if numberp w then w:=nil$
             if w and (y:=assoc(w,v)) then rplacD(y,cdr y + 1)
              else if w then v:=(w . 1).v$
         >>$
    >>$
    x:=car v$
    for each z in cdr v do if cdr z > cdr x then x:=z$
    hvlst:=(q.v).hvlst$
    return car x$
end$

algebraic procedure khorner20(p,vlst)$
  %----------------------------------------------------------
  %       p is a polynomial, vlst is a list of horner-variables.
  %       return p transformed to Horner's form
  %       Horner's variable is defined by the khvar1-procedure.
  %----------------------------------------------------------
if numberp p then p
else
 begin scalar q,x,c;
  on exp;
  q:=p;
  if (x:=khvar1(q,vlst))
   then
    << c:=sub(x=0,q);
       q:=(q-c)/x;
       off exp;
       return(khorner20(q,vlst)*x+khorner20(c,vlst))
    >>
   else
    << off exp;
       return(nestedfac q)
    >>
 end$

symbolic procedure khvar1(q,vlst);
  %----------------------------------------------------------
  %       q is a polynomial, vlst is a list of horner-variables.
  %       return Horner's variable.
  %       Here the Horner's variable is defined as a variable
  %       that occurs in more q-terms than the others.
  %       For example: X  in q = X+X**2+Y+1.
  %----------------------------------------------------------
if numberp q then rederr "HVAR1: impossible!"
 else
  begin scalar x,y,v;
   vlst:=cdr vlst; q:=reval q;% redefinition q usually not needed.
   if null atom q and car q eq 'plus
    then q:=cdr q else q:=list q;
   foreach z in q
    do << if null atom z and car z eq 'minus
           then z:=cadr z;
          if null atom z and car z eq 'times
           then z:=cdr z else z:=list z;
          for each w in z
           do << if null atom w and car w eq 'expt
                  then w:=cadr w else if numberp w then w:=nil;
                 if w and memq(w,vlst)
                  then if (y:=assoc(w,v))
                        then rplacd(y,cdr y + 1)
                        else v:=(w . 1).v
              >>
       >>;
   if v
    then << x:=car v;
            foreach z in cdr v do if cdr z > cdr x then x:=z$
            return car x
         >>
    else return nil
  end$

symbolic procedure hvlist()$
  %----------------------------------------------------------
  %       Procedure for printing HVLST variable.
  %       Debug utility.
  %----------------------------------------------------------
  for each x in hvlst do print x$

symbolic procedure clhvlist()$
  %----------------------------------------------------------
  %       Procedure for clearing HVLST variable.
  %       Debug utility.
  %----------------------------------------------------------
  hvlst:=nil$

symbolic operator khvar1,hvar1,hvlist,clhvlist$ % Interface with REDUCE

% -------------------------------------------------------------------
% Interface for generalised facilities, based on the use of the
% procedure gkhorner. This procedure can be used with one argument
% only, being a list of equations of the form lhsi=rhsi, where the
% i-th lhs is a name and the i-th rhs a (multivariate) polynomial,
% to be hornered either exhaustively using horner20(rhsi) or restric-
% tively using the second argument vlst, being a list of horner-
% variables, and procedure khorner20. When further vlst variables are
% absent the remaining parts of q are further polished using nestedfac.
% -------------------------------------------------------------------

symbolic procedure khornereval u;
begin scalar poly,varlst; integer nargs;
 nargs:=length u;
 if nargs<3
  then << poly:=aeval car u;
          if nargs=2 then varlst:=aeval cadr u>>
  else poly:='!*!*error!*!*;
 if eq(poly,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS KHORNER")
  else return if nargs=1
               then reval horner2 poly
               else reval khorner20(poly,varlst)
end;

put('khorner,'psopfn,'khornereval)$

symbolic procedure gkhornereval u;
begin scalar poly_s,varlst; integer nargs;
 nargs:=length u;
 if nargs<3
  then << poly_s:=cdar u;
          if nargs=2 then varlst:=cadr u>>
  else poly_s:='!*!*error!*!*;
 if eq(poly_s,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS GKHORNER")
  else
  return if pairp(car poly_s) and eq(caar poly_s,'equal)
   then append(list('list),
                    foreach poly in poly_s collect
                     list('equal,
                           cadr poly,
                           khornereval if nargs=1 then cddr poly
                                       else list(caddr poly,varlst)))
   else append(list('list),
                    foreach poly in poly_s collect
                     khornereval if nargs=1 then list(poly)
                                       else list(poly,varlst))
end$

put('gkhorner,'psopfn,'gkhornereval)$

symbolic procedure alggkhornereval u;
begin scalar poly_s,varlst; integer nargs;
 nargs:=length u;
 if nargs<3
  then << poly_s:=cdar u;
          if nargs=2 then varlst:=cadr u
       >>
  else poly_s:='!*!*error!*!*;
 if eq(poly_s,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS GKHORNER")
  else
   return
     algresults1(foreach poly in poly_s
                  collect cons(cadr poly,
                               khornereval if nargs=1 then cddr poly
                                          else list(caddr poly,varlst)))
end;

put('alggkhorner,'psopfn,'alggkhornereval)$

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codad1.red0000644000175000017500000011725511526203062023457 0ustar  giovannigiovannimodule codad1;  % Description of some procedures.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, W.N. Borst.            ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

% ------------------------------------------------------------------- ;
% The module CODAD1 contains the description of the procedures        ;
% IMPROVELAYOUT (part 1), TCHSCHEME (part 2) and CODFAC (part 3),     ;
% which are used in the procedure OPTIMIZELOOP (see the module CODCTL);
% to complete the effect of an application of EXTBRSEA (see the module;
% CODOPT). Application of each of these routines is completed by re-  ;
% turning a Boolean value, which is used to decide if further optimi- ;
% zation is still profitable.                                         ;
% The Smacro's Find!+Var and Find!*Var form service facilities, needed;
% at different places in this module. These Smacro's define an applic-;
% ation of the procedure GetCind.                                     ;
% ------------------------------------------------------------------- ;

% ------------------------------------------------------------------- ;
% Global identifiers needed in this module are:                       ;
% ------------------------------------------------------------------- ;

global '(rowmin rowmax kvarlst codbexl!*);

% ------------------------------------------------------------------- ;
% The meaning of these globals is given in the module CODMAT.         ;
% ------------------------------------------------------------------- ;

symbolic procedure getcind(var,varlst,op,fa,iv);
% ------------------------------------------------------------------- ;
% The purpose of the procedure GetCind is to create a column in CODMAT;
% which will be associated with the variable Var if this variable does;
% not yet belong to the set Varlst,i.e.does not yet play a role in the;
% corresponding PLUS- or TIMES setting (known by the value of Op).Once;
% the column exists (either created or already available), its Zstrt  ;
% is modified by inserting the Z-element (Fa,IV) in it. Finally the   ;
% corresponding Z-element for the father-row, i.e. (Y,IV) is returned.;
% ------------------------------------------------------------------- ;
begin scalar y,z;
  if null(y:=get(var,varlst))
  then
  <>;
  setzstrt(y,inszzzn(z:=mkzel(fa,iv),zstrt y));
  return mkzel(y,val z)
end;

symbolic smacro procedure find!+var(var,fa,iv);
getcind(var,'varlst!+,'plus,fa,iv);

symbolic smacro procedure find!*var(var,fa,iv);
getcind(var,'varlst!*,'times,fa,iv);

% ------------------------------------------------------------------- ;
% PART 1 : LAYOUT IMPROVEMENT                                         ;
% ------------------------------------------------------------------- ;

symbolic procedure improvelayout;
% ------------------------------------------------------------------- ;
% During optimization, and thus during common subexpression generation;
% it might happen that a (sub)expression is reduced to a single varia-;
% ble, leading to output containing the assignment statements :       ;
%  b:=b-thing;                                                        ;
%  ......                                                             ;
%  a:=b;                                                              ;
% This redundancy can be removed by replacing all occurrences of b by ;
% a, by replacing b:=b-thing by a:=b=thing and by removing a:=b. Here ;
% we assume a,b to be only cse-names.                                 ;
% ------------------------------------------------------------------- ;
begin scalar var,b;
  for x:=0:rowmax do
  if not (numberp(var:=farvar x)
          or
          pairp(var)
          or
          (member(x,codbexl!*)
           and
           (get(var,'nex) or
            not(flagp(var, 'newsym)) or
            get(var,'alias)
            % or not(get(var,'alias)) % JB 10/3/94
            % finds no cse in p.e. cos(e^s6),sin(e^s6)
           )))
     and testononeel(var,x) then b:=t;
  % ----------------------------------------------------------------- ;
  % If B=T redundancy was removed from CODMAT, but not necessarily    ;
  % from Kvarlst, the list of pairs of kernels and names associated   ;
  % with them. ImproveKvarlst is applied to achieve this.             ;
  % ----------------------------------------------------------------- ;
  if b then improvekvarlst();
  return b
end;

symbolic procedure testononeel(var,x);
% ------------------------------------------------------------------- ;
% Row X,having Var as its assigned variable, and defining some expres-;
% sion, through its Zstrt, Chrow and ExpCof, is analysed.             ;
% If this row defines a redundant assignment statement the above indi-;
% cated actions are performed.                                        ;
% ------------------------------------------------------------------- ;
begin
  scalar scol,srow,el,signiv,signec,zz,ordrx,negcof,trow,
                                           oldvar,b,el1,scof,bop!+,lhs;
  if (zz:=zstrt x) and null(cdr zz) and null(chrow x) and
      !:onep(dm!-abs(signiv:=ival(el:=car zz))) and
      !:onep(signec:=expcof(x))
  %   !:onep(dm!-abs(signec:=expcof(x)))
  %   This could mean a:=b^(-1), which is rather tricky to update
  %   when b is used in other plusrows.  JB. 7-5-93.
  then
   << % ------------------------------------------------------------- ;
      % Row(X) defines a Zstreet, consisting of one Z-element. The    ;
      % variable-name, associated with this element is stored in the  ;
      % FarVar-field of the column, whose index is in the Yind-part of;
      % this Z-element,i.e. Oldvar:=FarVar(SCol),the b mentioned above;
      % The IVal-value of this element, an exponent or a coefficient, ;
      % is 1 or -1 and the ExpCof-value, a coefficient or an exponent,;
      % is also 1 or -1. Realistic possibilities are of course only   ;
      % 1*Oldvar^1 or -1*Oldvar^1 (i.e. 1*b^1 or -1*b^1).             ;
      % ------------------------------------------------------------- ;
      scol:=yind el;
      oldvar:=farvar(scol);
      if srow:=get(oldvar,'rowindex)
       then b:=t
       else
        if assoc(oldvar,kvarlst) and
           !:onep(signiv) and !:onep(signec) and
           not member(oldvar,codbexl!*)
         then b:=t;
      % ------------------------------------------------------------- ;
      % So B=T if either Oldvar has its own defining row, whose index ;
      % is stored as value of the indicator Rowindex, i.e. if Oldvar  ;
      % defines a cse, or if Oldvar is the name of a kernel, stored in;
      % Kvarlst, as cdr-part of the pair having Oldvar as its car-part;
      % ------------------------------------------------------------- ;
       if b
        then
         << % ------------------------------------------------------- ;
            % We start replacing all occurrences of Oldvar by Var, in ;
            % both the PLUS- and the TIMES-part of CODMAT, by applying;
            % the function TShrinkCol. In addition all eventually exis;
            % ting occurences of Oldvar in Kvarlst have to replaced as;
            % well by Var(,the a mentioned above).                    ;
            % ------------------------------------------------------- ;
            setzstrt(scol,delyzz(x,zstrt scol));
            tshrinkcol(oldvar,var,'varlst!+);
            tshrinkcol(oldvar,var,'varlst!*);
            if ((opval(x) eq 'plus) and !:onep(dm!-minus signiv))
                or
               ((opval(x) eq 'times) and !:onep(dm!-minus signec))
             then << var:=list('minus,var);
                     kvarlst:=subst(var,oldvar,kvarlst);
                     preprefixlist:=subst(var,oldvar,preprefixlist);
                     var:=cadr var;
                     negcof:=-1
                  >>
             else << kvarlst:=subst(var,oldvar,kvarlst);
                     preprefixlist:=subst(var,oldvar,preprefixlist);
                     negcof:=1
                  >>;
            if (lhs:=get(oldvar,'inlhs))
               then
               << put(lhs,'nex,subst(var,oldvar,get(lhs,'nex)));
                  remprop(oldvar,'inlhs)>>;
            if (lhs:=get(oldvar,'inalias))
               then
               << updatealiases(oldvar,var);
                  %put(lhs,'alias,subst(var,oldvar,get(lhs,'alias)));
                  remprop(oldvar,'inalias)>>;
            if srow
            then
             << % --------------------------------------------------- ;
                % Oldvar is the name of a cse, defined through the row;
                % index Srow. So this cse-definition has to be assign-;
                % ed to Var as new value and the Srow itself has to be;
                % made redundant. The Ordr-field of Var has to be chan;
                % ged to be able to remain guaranteeing a correct out-;
                % put sequence.                                       ;
                % --------------------------------------------------- ;
                ordrx:=ordr(x);
                bop!+:=opval(srow) eq 'plus;
                if bop!+ then scof:=expcof srow
                         else scof:=dm!-times(negcof,expcof(srow));
                setrow(x,opval srow,var,list(chrow srow,scof),
                                                           zstrt srow);
                setordr(x,append(ordr srow,remordr(srow,ordrx)));
                if !:onep(dm!-minus signiv)
                 then
                  <>;
                foreach ch in chrow(srow) do setfarvar(ch,x);
                clearrow(srow);
                setordr(srow,nil);
                codbexl!*:=subst(x,srow,codbexl!*);
                foreach z in zstrt(x) do
                 <>;
                for sindex:=0:rowmax
                 do setordr(sindex,subst(x,srow,ordr sindex));
                testononeel(var,x)
             >>
            else
             << % --------------------------------------------------- ;
                % Oldvar is the system-generated name of a kernel.    ;
                % The internal administration is modified, as to pro- ;
                % vide Var with its new role.                         ;
                % As a side-effect the index X of the kernel defining ;
                % row is replaced in CodBexl!* by the name Var, if oc-;
                % curring of course, i.e. if this function definition ;
                % was given at toplevel on input.                     ;
                % This information is used in ImproveKvarlst.         ;
                % --------------------------------------------------- ;
                codbexl!*:=subst(var,x,codbexl!*);
                ordrx:=remordr(oldvar,ordr x);
                clearrow(x);
                setordr(x,nil);
                for sindex:=0:rowmax do
                 setordr(sindex,
                              updordr(ordr sindex,var,oldvar,ordrx,x));
                improvekvarlst()
             >>;
         >>
   >>;
  return b;
end$

symbolic procedure remordr(x,olst);
% ------------------------------------------------------------------- ;
% Olst is the value of the Ordr-field of a row of CODMAT. Olst defines;
% in which order the cse's, occurring in the (sub)expression, whose   ;
% description starts in this row, have to be printed ahead of this    ;
% (sub)expression. It is a list of kernelnames and/or indices of rows ;
% where cse-descriptions start.                                       ;
% RemOrdr returns Olst after removal of X, if occcurring.             ;
% ------------------------------------------------------------------- ;
if null(olst)
then olst
else
  if car(olst)=x
  then remordr(x,cdr olst)
  else car(olst).remordr(x,cdr olst);

symbolic procedure updordr(olst,var,oldvar,ordrx,x);
% ------------------------------------------------------------------- ;
% Olst is described in RemOrdr. OrdrX is the Olst of row X after remo-;
% val Oldvar from it. Row X defines Var:=Oldvar. Oldvar, a kernelname,;
% is replaced by Var in Olst. If X is occurring in Olst OrdrX have to ;
% be inserted in Olst. The thus modified version of Olst is returned. ;
% ------------------------------------------------------------------- ;
if null(olst)
then olst
else
  if car(olst) eq oldvar
  then var.updordr(cdr olst,var,oldvar,ordrx,x)
  else
    if car(olst)=x
    then append(var.ordrx,updordr(cdr olst,var,oldvar,ordrx,x))
    else car(olst).updordr(cdr olst,var,oldvar,ordrx,x);

symbolic procedure improvekvarlst;
% ------------------------------------------------------------------- ;
% Kvarlst, a list of pairs (name . function definition) is improved,if;
% necessary. This is only required if in the list CodBexl!* occuring  ;
% names are not yet used in Kvarlst. Hence adequate rewriting of      ;
% b:=sin(x)                                                           ;
% ........                                                            ;
% a:=b                                                                ;
% into                                                                ;
% a:=sin(x) is needed,i.e. replacement of (b . sin(x)) by (a . sin(x));
% in Kvarlst.                                                         ;
% ------------------------------------------------------------------- ;
begin scalar invkvl,newkvl,x,y,kv,lkvl,cd,cd1;
  newkvl:=kvarlst;
  repeat
  <>;
        tshrinkcol(kv,x,'varlst!+);
        tshrinkcol(kv,x,'varlst!*);
        for rindx:=0:rowmax do
        setordr(rindx,subst(x,kv,ordr rindx));
        newkvl:=subst(x,kv,newkvl);
        invkvl:=subst(x,kv,invkvl);
        lkvl:=subst(x,kv,lkvl)
      >>
      else
      <>
    >>
  >>
  until length(kvarlst)=length(newkvl);
end;

symbolic procedure tshrinkcol(oldvar,var,varlst);
% ------------------------------------------------------------------- ;
% All occurrences of Oldvar have to be replaced by Var. This is done  ;
% by replacing the PLUS and TIMES column-indices of Oldvar by the cor-;
% responding indices of Var. Y1 and Y2 get the value of the Oldvar-   ;
% index and the Var-index, respectively. As a side-effect, all additi-;
% onal information, stored in the property-list of Oldvar is removed. ;
% ------------------------------------------------------------------- ;
begin scalar y1,y2;
  if get(oldvar,'inalias)
     then updatealiases(oldvar, var);
  if y1:=get(oldvar,varlst)
  then
  <>;
      clearrow(y1)
    >>
    else
    <>;
    remprop(oldvar,varlst)
  >>;
  remprop(oldvar,'npcdvar);
  remprop(oldvar,'nvarlst);
end;

symbolic procedure updatealiases(old, new);
% ----------------------------------------------------------------- ;
% Variable old is going to be replaced  by new.
% We hav eto ensure that the alias-linking remains
% consistent. This means that the following has to
% be updated:
% Occurrence-info of index-alias:
%           new.inalias <- old.inalias
% The aliased vars have to be informed that the alias
% is performed by a new variable:
%           alias <- new|old
%           original.finalalias <- new|old
%     where A|B means : replace B by A.
% ----------------------------------------------------------------- ;
begin scalar original;
  put(new,'inalias,get(old,'inalias));
  flag(list new,'aliasnewsym);
  foreach el in get(old,'inalias) do
     <>;
end$

% ------------------------------------------------------------------- ;
% PART 2 : INFORMATION MIGRATION                                      ;
% ------------------------------------------------------------------- ;
symbolic procedure tchscheme;
% ------------------------------------------------------------------- ;
% A product(sum) -reduced to a single element- can eventually be remo-;
% ved from the TIMES(PLUS)-part of CODMAT. If certain conditions are  ;
% fulfilled (defined by the function TransferRow) it is transferred to;
% the Zstreet of its father PLUS(TIMES)-row and its index is removed  ;
% from the ChRow of its father.                                       ;
% T is returned if atleast one such a migration event takes place.    ;
% NIL is returned otherwise.                                          ;
% ------------------------------------------------------------------- ;
begin scalar zz,b;
  for x:=0:rowmax do
  if not(farvar(x)=-1)
     and (zz:=zstrt x) and null(cdr zz) and transferrow(x,ival car zz)
   then <>;
  return b;
end;

symbolic procedure chscheme(x,z);
% ------------------------------------------------------------------- ;
% The Z-element Z, the only element the Zstreet of row(X) has, has to ;
% be transferred from the PLUS(TIMES)-part to the TIMES(PLUS)-part of ;
% CODMAT.                                                             ;
% ------------------------------------------------------------------- ;
begin scalar fa,opv,cof,exp;
    setzstrt(yind z,delyzz(x,zstrt yind z));
    setzstrt(x,nil);
    if opval(x) eq 'plus
    then <>
    else <>;
 l1: fa:=farvar(x);
     opv:=opval(x);
     if opv eq 'plus
     then
     <>
     >>
     else
     << if opv eq 'times
        then
        <>
        >>
     >>;
     updfa(fa,exp,cof,z)
end;

symbolic procedure updfa(fa,exp,cof,z);
% ------------------------------------------------------------------- ;
%  FA is the index of the father-row of the Z-element Z,which has to  ;
% be incorporated in the Zstreet of this row. Its exponent is Exp and ;
% its coefficient is Cof, both computed in its calling function       ;
% ChScheme.                                                           ;
% ------------------------------------------------------------------- ;
if opval(fa) eq 'plus
then setzstrt(fa,inszzzr(find!+var(farvar yind z,fa,cof),zstrt fa))
else
<>;

symbolic procedure transferrow(x,iv);
% ------------------------------------------------------------------- ;
% IV is the Ivalue of the Z-element, oreming the Zstreet of row X.    ;
% This element can possibly be transferred.                           ;
% T is returned if this element can be transferred. NIL is returned   ;
% otherwise.                                                          ;
% ------------------------------------------------------------------- ;
if opval(x) eq 'plus
 then transferrow1(x) and opval(farvar x) eq 'times
 else transferrow1(x) and transferrow2(x,iv);

symbolic procedure transferrow1(x);
% ------------------------------------------------------------------- ;
% T is returned if row(X) defines a primitive expression (no children);
% which is part of a larger expression, i.e. row(X) defines a child-  ;
% expression.                                                         ;
% ------------------------------------------------------------------- ;
null(chrow x) and numberp(farvar x);

symbolic procedure transferrow2(x,iv);
% ------------------------------------------------------------------- ;
% Row(X) defines a product of the form ExpCof(X)*(a variable) ^ IV,   ;
% which is part of a sum.                                             ;
% X is temporarily removed from the list of its fathers children when ;
% computing B, the return-value.                                      ;
% B=T if the father-row defines a sum and if either the exponent IV=1 ;
% or if the father-Zstreet is empty (no primitive terms) and the fa-  ;
% ther itself can be transferred, i.e. if ExpCof(X)*(a variable) ^ (IV;
% *ExpCof(Fa)) can be incorporated in the Zstreet of the grandfather- ;
% row (,which again defines a product).                               ;
% ------------------------------------------------------------------- ;
begin scalar fa,b;
  fa:=farvar(x);
  chdel(fa,x);
  b:=opval(fa) eq 'plus and (iv=1 or (null(zstrt fa) and
                            transferrow(fa,iv*expcof(fa))));
  setchrow(fa,x.chrow(fa));
  return b;
end;

% ------------------------------------------------------------------- ;
% PART 3 : APPLICATION OF THE DISTRIBUTIVE LAW.                       ;
% ------------------------------------------------------------------- ;
% An expression of the form a*b + a*c + d is distributed over 3 rows  ;
% of CODMAT : One to store the sum structure, i.e. to store the pp of ;
% the sum, being d, in a Zstrt and 2 others to store the composite    ;
% terms a*b and a*c as monomials. The indices of the latter rows are  ;
% also stored in the list Chrow, associated with the sum-row.         ;
% In addition 4 columns are introduced. One to store the 2 occurrences;
% of a and 3 others to store the information about b,c and d. The a,b ;
% and c column belong to the set of TIMES-columns, i.e. a,b and c are ;
% elements of the list Varlst!* (see the module CODMAT). Similarly the;
% d belongs to Varlst!+. If this sum is remodelled to obtain a*(b + c);
% + d changes have to be made in the CODMAT-structure:                ;
% Now 2 sum-rows are needed and only 1 product-row. Hence the Chrow-  ;
% information of the original sum-row has to be changed and the 2 pro-;
% duct-rows have to be removed and replaced by one new row, defining  ;
% the Zstrt for a and the Chrow to find the description of b + c back.;
% In addition the column-information for all 4 columns has to be reset;
% This is a simple example. In general more complicated situations can;
% be expected. An expression like a*b + a*sin(c) + d requires 4 rows, ;
% for instance . A CODFAC-application always follows a ExtBrsea-execu-;
% tion. This implies that potential common factors, defined through *-;
% col's always have an exponent-value = 1. A common factor like a^3 is;
% always replaced by a cse (via an appl. of Expand- and Shrinkprod),  ;
% before the procedure CODFAC is applied. Hence atmost 1 exponent in a;
% column is not equal 1.                                              ;
% ------------------------------------------------------------------- ;

symbolic procedure codfac;
% ------------------------------------------------------------------- ;
% An application of the procedure CodFac results in an exhaustive all-;
% level application of the distributive law on the present structure  ;
% of the set of input-expressions, as reflected by the present version;
% of CODMAT.                                                          ;
% If any application of the distributive law proves to be possible the;
% value T is returned.This is an indication for the calling routine   ;
% OptimizeLoop that an additional application of ExtBrsea might be    ;
% profitable.                                                         ;
% If such an application is not possible the value Nil is returned.   ;
% ------------------------------------------------------------------- ;
begin scalar b,lxx;
  for y:=rowmin:(-1) do
   % ---------------------------------------------------------------- ;
   % The Zstrts of all *-columns, which are usable (because their Far-;
   % Var-field contains a Var-name), are examined by applying the pro-;
   % cedure SameFar. If this application leads to a non empty list LXX;
   % with information, needed to be able to apply the distributive law;
   % the local variable B is set T, possibly the value to be returned.;
   % B gets the initial value Nil, by declaration.                    ;
   % ---------------------------------------------------------------- ;
   if not (farvar(y)=-1 or farvar(y)=-2) and
                                opval(y) eq 'times and (lxx:=samefar y)
    then
     <>;
  return b
end;

symbolic procedure samefar(y);
% ------------------------------------------------------------------- ;
% Y is the index of a TIMES-column. The procedure SameFar is designed ;
% to allow to find and return a list Flst consisting of pairs, formed ;
% by a father-index and a sub-Zstrt of the Zstrt(Y), consisting of Z's;
% such that Farvar(Xind Z) = Car Flst, i.e. the Xind(Z)-rows define   ;
% (composite) productterms of the same sum, which contain the variable;
% corresponding with column Y as factor in their primitive part.      ;
% ------------------------------------------------------------------- ;
begin scalar flst,s,far;
  foreach z in zstrt(y) do
   if numberp(far:=farvar xind z) and opval(far) eq 'plus
    then
     if s:=assoc(far,flst)
      then rplacd(s,inszzz(z,cdr(s)))
      else flst:=(far.inszzz(z,s)).flst;
  return
    foreach el in flst conc
    if cddr(el)
    then list(el)
    else nil
end;

symbolic procedure commonfac(y,xx);
% ------------------------------------------------------------------- ;
% Y is the index of a TIMES-column and XX an element of LXX, made with;
% SameFar(Y), i.e. a pair consisting of the index Far of a father-sum ;
% row and a sub-Zstrt,consisting of Z-elements, defining factors in   ;
% productterms of this father-sum.                                    ;
% These factors are defined by Z-elements (Y.exponent). Atmost one of ;
% these exponents is greater than 1.                                  ;
% The purpose of CommonFac is to factor out this element,i.e. to remo-;
% ve a Z-element (Y.1) from the Zstrts of the children and also its   ;
% corresponding occurrences from ZZ3 = Zstrt(Y), to combine the remai-;
% ning sum-information in a new PLUS-row, with index Nsum, and to cre-;
% ate a TIMES-row, with index Nprod, defining the product of the sum, ;
% given by the row Nsum, and the variable corresponding with column Y.;
% ZZ2 and CH2 are used to (re)structure information, by allowing to   ;
% combine the remaining portions of the child-rows.The father (with   ;
% index Far) is defined by a Zstrt (its primitive part) and by CH1 =  ;
% Chrow (its composite part). ZZ4 and CH4 are used to identify the    ;
% Zstrts of the children after removal of a (Y.1)-element and the     ;
% Chrow's,respectively.If exponent>1 in (Y.exponent) the Zstrt has to ;
% be modified to obtain ZZ4, instead of a simple removal of (Y.1) from;
% from Zstrt X.                                                       ;
% Alternatives for the structure of the such a child-row are :        ;
% -1- A combination of a non-empty Zstrt and a non-empty list Chrow   ;
%     of children.                                                    ;
% -2- An empty Zstrt, but a non-empty Chrow.                          ;
% -3- A non-empty Zstrt, but an empty Chrow.                          ;
% Special attention is required when in case -3- the Zstrt consists of;
% only 1 Z-element besides the element shared with column Y.          ;
% In case -2- similar care have to be taken when Chrow consists of 1  ;
% row index only.                                                     ;
% Remark : Since the overall intention is optimization, i.e. reduction;
% of the arithmetic complexity of a set of expressions, viewed as ru- ;
% les to perform arithmetic operations, expression parts like a*b + a ;
% are not changed into a*(b + 1). Hence a forth alternative, being an ;
% empty Zstrt and an empty Chrow is irrelevant.                       ;
% ------------------------------------------------------------------- ;
begin scalar far,ch1,ch2,ch4,chindex,zel,zeli,zz2,zz3,zz4,
                                         nsum,nprod,opv,y1,cof,x,ivalx;
  far:=car(xx);
  ch1:=chrow(far);
  zz3:=zstrt(y);
  nprod:=rowmax+1;
  nsum:=rowmax:=rowmax+2;
  % ----------------------------------------------------------------- ;
  % After some initial settings all children,accessible via the Z-el.s;
  % collected in Cdr(XX) are examined using a FOREACH_loop.           ;
  % ----------------------------------------------------------------- ;
  foreach item in cdr(xx) do
  <>;
        foreach ch in chrow(ch4) do
        <<% --------------------------------------------------------- ;
          % The row CH defines a child directly if Cof = 1. In all    ;
          % other cases a multiplication with Cof has to be performed.;
          % Either by changing the ExpCof field if the child is a pro-;
          % duct or by introducing a new TIMES-row.                   ;
          % --------------------------------------------------------- ;
          chindex:=ch;
          if not(!:onep cof)
           then
            if opval(ch) eq 'times
             then
              << setexpcof(ch,dm!-times(cof,expcof(ch)));
                 setfarvar(ch,nsum)
              >>
             else
              << chindex:=rowmax:=rowmax+1;
                 setrow(chindex,'times,nsum,(ch).cof,nil)
              >>
           else  setfarvar(ch,nsum);
          ch2:=chindex.ch2
        >>;
        % ----------------------------------------------------------- ;
        % The row CH4 is not longer needed in CODMAT, because its     ;
        % content is distributed over other rows.                     ;
        % ----------------------------------------------------------- ;
        clearrow(ch4);
      >>
      else
      <<% ----------------------------------------------------------- ;
        % This is still the special case -2-. (CH4) contains 1 child  ;
        % index. The leading operator of this child is not PLUS. So   ;
        % CH4 is simply added to the list of children indices CH2 and ;
        % the father index of row CH4 is changed into Nsum.           ;
        % ----------------------------------------------------------- ;
        setfarvar(ch4,nsum);
        ch2:=ch4.ch2
      >>;
      % ------------------------------------------------------------- ;
      % The row X is not longer needed in CODMAT, because its content ;
      % is distributed over other rows.                               ;
      % ------------------------------------------------------------- ;
      clearrow(x)
    >>
    else
     if null(ch4) and (null(cdr zz4) and car(zz4))
      then
      <<% ----------------------------------------------------------- ;
        % This is the special case of possibility -3-: A Zstrt ZZ4    ;
        % consisting of only one Z-element.                           ;
        % This Z-element defines just a variable if IVal(Car ZZ4) =1. ;
        % It is a power of a variable in case IVal-value > 1 holds.   ;
        % In the latter situation Nsum ought to become the new father ;
        % index of the row with index Xind Car ZZ4.In the former case ;
        % the single variable is added to the Zstrt ZZ2, before row X ;
        % can be cleared.                                             ;
        % ----------------------------------------------------------- ;
        if not(!:onep ival(car(zz4)))
         then
          << setfarvar(x,nsum);
             setzstrt(x,zz4);
             ch2:=x.ch2
          >>
         else
          << zz2:=inszzzr(find!+var(farvar(y1:=yind car zz4),nsum,
                                                            cof),zz2);
             setzstrt(y1,delyzz(x,zstrt y1));
             clearrow(x)
          >>
      >>
      else
      <<% ----------------------------------------------------------- ;
        % Now the general form of one of the 3 alternatives holds.    ;
        % Row index X is added to the list of children indices CH2    ;
        % and the new father index for row X becomes Nsum. The Zstrt  ;
        % of X is also reset. It becomes ZZ4, i.e. the previous Zstrt ;
        % after removal of (Y.1).                                     ;
        % ----------------------------------------------------------- ;
        ch2:=x.ch2;
        setfarvar(x,nsum);
        setzstrt(x,zz4)
      >>;
    % --------------------------------------------------------------- ;
    % The previous "life" of X is skipped by removing its impact from ;
    % the "history book" CODMAT.                                      ;
    % --------------------------------------------------------------- ;
    ch1:=delete(x,ch1);
    zz3:=delyzz(x,zz3);
    if ivalx>2 then zz3:=inszzz(mkzel(x,val(zeli)),zz3)
  >>;
  % ----------------------------------------------------------------- ;
  % Some final bookkeeping is needed :                                ;
  % -1- (Y.1) was deleted from the ZZ4's. Its new role, factor in the ;
  %     product,defined via the row Nprod, has still to be establish- ;
  %     ed by inserting this information in Y's Zstrt.                ;
  % ----------------------------------------------------------------- ;
   setzstrt(y,(zel:=mkzel(nprod,1)).zz3);
  % ----------------------------------------------------------------- ;
  % -2- The list of indices of children of the row with index Far     ;
  %     ought to be extended with Nprod.                              ;
  % ----------------------------------------------------------------- ;
  setchrow(far,nprod.ch1);
  % ----------------------------------------------------------------- ;
  % -3- Finally the new rows Nprod and Nsum have to be filled. How-   ;
  %     ever the :=: assignment-option might cause - otherwise non-   ;
  %     existing - problems, because simplification is skipped before ;
  %     parsing input and storing the relevant information in CODMAT. ;
  % An input expression of the form x*(a + t) + x*(a - t) can thus be ;
  % transformed - by an application of CODFAC - into the form         ;
  % x*(2*a + 0). Its Zstrt can contain an element (index  . 0), like  ;
  % the Zstrt associated with t. The latter is due to the coefficient ;
  % addition, implied by insert-operations, like InsZZZ or InsZZZr.   ;
  % Hence a test is made to discover if a Z-element Zel exists, such  ;
  % that IVal(Zel)=0. If so, its occurrence is removed from both ZZ2  ;
  % and the Zstrt of the t-column.                                    ;
  % If now Null(CH2) and Null(Cdr ZZ2) holds the PLUS-row Nsum is     ;
  % superfluous. Only 2*a*x has to be stored in Nprod. The row Nsum   ;
  % is removed when it is easily detectable, because this index is    ;
  % not used anymore and anywhere, when the above limitations are     ;
  % valid.                                                            ;
  % ----------------------------------------------------------------- ;
  foreach z in zz2 do if zeropp(ival(z))
     then << zz2:=delyzz(y1:=xind z,zz2);
             setzstrt(y1,delyzz(nsum,zstrt y1))
          >>;
  % ----------------------------------------------------------------- ;
  % Expressions like x(a-w)+x(a+w) lead to printable, but not yet to  ;
  % completely satisfactory prefixlist-representations. This problem  ;
  % is solved in the module CODPRI in the function  ConstrExp.        ;
  % ----------------------------------------------------------------- ;
  setrow(nprod,'times,far,list list nsum,list mkzel(y,val zel));
  setrow(nsum,'plus,nprod,list ch2,zz2)
 end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/scope.bib0000644000175000017500000002502111526203062023404 0ustar  giovannigiovanni
@BOOK{Gates:91,
  AUTHOR = "B.L. Gates",
  TITLE = "{GENTRAN} User's Manual, {REDUCE} Version",
  ADDRESS = "{Santa Monica, Cal.}",
  PUBLISHER = "Rand Corporation",
  YEAR = 1991}

@BOOK{Hearn:95,
  AUTHOR = "A.C. Hearn",
  TITLE = "{REDUCE} User's Manual, Version 3.6",
  ADDRESS = "{Santa Monica, Cal.}",
  PUBLISHER = "{Rand Corporation, Publication CP78(Rev. 7/95)}",
  YEAR = 1995}

@BOOK{Molenkamp:94,
  AUTHOR = "J.H.J. Molenkamp and J.A. van Hulzen and V.V. Goldman",
  TITLE = "An arbitrary precision real interval arithmetic package in {REDUCE},
              {Memorandum INF-94-14}",
  ADDRESS = "{Enschede, The Netherlands}",
  PUBLISHER = "{University of Twente}",
  YEAR = 1994}

@ARTICLE{Gates:85,
  AUTHOR = "B. L. Gates",
  TITLE =  "{GENTRAN}: An automatic code generation facility for {REDUCE}",
  JOURNAL = "{ACM SIGSAM} Bulletin",
  VOLUME = 19, NUMBER = 3, PAGES = "24-42",
  YEAR = 1985}

@INPROCEEDINGS{Gates:84,
  AUTHOR = "B. L. Gates and P. S. Wang",
  TITLE = "{LISP}-based {RATFOR} code generator",
  EDITOR = "V. E. Golden",
  PAGES = "319-329",
  BOOKTITLE = "1984 MACSYMA User's Conference",
  ADDRESS = "Schenectady, N.Y.",
  ORGANIZATION = "Gen. El.",
  YEAR = 1984}

@INPROCEEDINGS{Gates:86,
  AUTHOR = "B. L. Gates",
  TITLE = "A Numerical Code Generation Facility for {REDUCE}",
  EDITOR = "B.W. Char",
  PAGES = "94-99",
  BOOKTITLE = "Proceedings {SYMSAC} '86",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1986}

@INPROCEEDINGS{Bradford:86,
  AUTHOR = "R.J. Bradford and A.C. Hearn and J.A. Padget and E. Schr{\"{u}}fer",
  TITLE = "Enlarging the {REDUCE} Domain of Computation",
  EDITOR = "B.W. Char",
  PAGES = "100-106",
  BOOKTITLE = "Proceedings {SYMSAC} '86",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1986}

@INPROCEEDINGS{vanHulzen:89,
  AUTHOR = "J.A. van Hulzen and B.J.A. Hulshof and B. L. Gates and 
           M.C. van Heerwaarden",
  TITLE = "A Code Optimization package for {REDUCE}",
  EDITOR = "G.H. Gonnet",
  PAGES = "163-170",
  BOOKTITLE = "Proceedings {ISSAC} '89",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1989}

@INPROCEEDINGS{Borst:94,
  AUTHOR = "W.N. Borst and V.V. Goldman and J.A. van Hulzen",
  TITLE = "{GENTRAN90}: A {REDUCE} package for the  generation of {FORTRAN} 90 
           code",
  EDITOR = "J. von zur Gathen and M. Giesbrecht",
  PAGES ="45-51",
  BOOKTITLE = "Proceedings  {ISSAC} '94",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1994}

@INPROCEEDINGS{Dyer:94,
  AUTHOR = "Ch. C. Dyer",
  TITLE = "An application of symbolic computation in the physical sciences",
  EDITOR = "J. von zur Gathen and M. Giesbrecht",
  PAGES ="181-186",
  BOOKTITLE = "Proceedings  {ISSAC} '94",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1994}

@INPROCEEDINGS{Ganzha:94,
  AUTHOR = "V.G. Ganzha and E.V. Vorozhtsov and J. Boers and J.A. van Hulzen",
  TITLE = "Symbolic-Numeric Stability Investigations of {Jameson}'s Schemes for
           Thin-layer {Navier-Stokes} Equations",
  EDITOR = "J. von zur Gathen and M. Giesbrecht",
  PAGES = "242-249",
  BOOKTITLE = "Proceedings {ISSAC} '94",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1994}

@INPROCEEDINGS{Ganzha:92,
  AUTHOR = "V.G. Ganzha and E.V. Vorozhtsov and J.A. van Hulzen",
  TITLE = "A New Symbolic-Numeric Approach to Stability Analysis of Difference 
           Schemes",
  EDITOR = "P.S. Wang",
  PAGES = "9-15",
  BOOKTITLE = "Proceedings {ISSAC} '92",
  ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1992}

@INPROCEEDINGS{Goldman:95,
  AUTHOR = "V.V. Goldman and J.A. van Hulzen and  A.E. Mynett and  
            A.S. Posthuma and H.J. van Zuylen",
  TITLE = "The application of computer algebra for the discretization and coding
           of the {Navier-Stokes} equations",
  EDITOR = "A.M. Cohen and S.M. Verduyn Lunel",
  BOOKTITLE = "{Computer Algebra in Industry, Problem Solving in Practice,
               Proceedings of the 1992 SCAFI Seminar}",
  ADDRESS = "Chichester", PUBLISHER = "John Wiley \& Sons",
  YEAR = "1995 (to appear)"}

@INPROCEEDINGS{vanHulzen:95,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Towards Automated Program Generation in Computer Algebra 
           Environments",
  EDITOR = "A.M. Cohen and S.M. Verduyn Lunel",
  BOOKTITLE = "{Computer Algebra in Industry, Problem Solving in Practice,
               Proceedings of the 1992 SCAFI Seminar}",
  ADDRESS = "Chichester", PUBLISHER = "John Wiley \& Sons",
  YEAR = "1995 (to appear)"}

@INPROCEEDINGS{Berger:92,
  AUTHOR = "F.C. Berger and V.V. Goldman and M.C. van Heerwaarden 
            and J.A. van Hulzen",
  TITLE = "Automatic generation of numerical code for {Jacobians and Hessians}",
  EDITOR = "P.W. Gaffney and E.N. Houstis",
  PAGES = "309-320",
  BOOKTITLE = "Programming Environments for High-Level Scientific 
               Problem Solving",
  ADDRESS = "Amsterdam", PUBLISHER = "North-Holland",
  YEAR = 1992}

@INPROCEEDINGS{Goldman:91,
  AUTHOR = "V.V. Goldman and J.H.J. Molenkamp and J.A. van Hulzen",
  TITLE = "Efficient Numerical Program Generation and Computer Algebra 
           Environments",
  EDITOR = "A. Griewank and G.E. Corliss",
  PAGES = "74-84",
  BOOKTITLE = "{Automatic Differentiation of Algorithms: Theory, Implementation,
               and Application}",
  ADDRESS = "Philadelphia", PUBLISHER = "{SIAM}",
  YEAR = 1991}

@INPROCEEDINGS{Hearn:85,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Structure:  The Key to Improved Algebraic Computation",
 EDITOR = "N. Inada and T. Soma",
 YEAR = 1985,
 BOOKTITLE = "Proc. of the Second {RIKEN} International
 Symposium on Symbolic and Algebraic Computation by Computers",
 PUBLISHER = "World Scientific", ADDRESS = "Singapore", PAGES = "215-230"}

@INPROCEEDINGS{Hearn:86,
 AUTHOR = "Anthony C. Hearn",
 TITLE = "Optimal Evaluation of Algebraic Expressions",
 EDITOR = "J. Calmet",
 BOOKTITLE = "Proc. of {AAECC}-3, LNCS",
  PUBLISHER = "Springer Verlag",
  SERIES = "Springer {LNCS}",
  ADDRESS = "Heidelberg",
 YEAR = 1986, VOLUME = 229, PAGES = "392-403"}

@ARTICLE{Knuth:71,
  AUTHOR = "D. E. Knuth",
  TITLE = "An empirical study of Fortran programs",
  JOURNAL = "Software Practice and Experience",
  VOLUME = 1, PAGES = "105-133", YEAR = 1971}

@BOOK{Aho:86,
  AUTHOR = "A. V. Aho and R. Sethi and J. D. Ullman",
  TITLE = "Compiler Principles, Techniques and Tools",
  ADDRESS = "Reading, Mass",
  PUBLISHER = "Addison-Wesley",
  YEAR = 1986}

@ARTICLE{Gonzales,
  AUTHOR = "T. Gonzales and J. Ja' Ja'",
  TITLE = "Evaluation of arithmetic expressions with algebraic identities",
  JOURNAL = "{SIAM} J. Comp", YEAR = 1982,
  VOLUME = 11, NUMBER = 4, PAGES = "633-662"}

@ARTICLE{Johnson:79,
  AUTHOR = "B. B. Johnson and W. Miller and B. Minnihan and C. Wrathall",
  TITLE = "Reducibility among floating-point graphs",
  JOURNAL = "Journal of the {ACM}", VOLUME = 26, NUMBER = 4,
  PAGES = "739-760", YEAR = 1979}

@ARTICLE{Smit:81,
  AUTHOR = "J. Smit and J.A. van Hulzen and B.J.A. Hulshof",
  TITLE = "{NETFORM} and code optimizer manual",
  JOURNAL = "{ACM SIGSAM} Bulletin",
  VOLUME =15, NUMBER = 4, PAGES = "23-32",
  YEAR = 1981}

@INPROCEEDINGS{Smit:82,
  AUTHOR = "J. Smit and J.A. van Hulzen",
  TITLE = "Symbolic-numeric methods in microwave technology",
  BOOKTITLE = "Proceedings {EUROCAM} '82",
  EDITOR = "J. Calmet",
  PUBLISHER = "Springer Verlag",
  SERIES = "Springer {LNCS}",
  VOLUME = 144, PAGES = "281-288",
  ADDRESS = "Heidelberg",
  YEAR = 1982}

@INPROCEEDINGS{vanHulzen:83,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Code optimization of multivariate polynomial schemes: A pragmatic
approach",
  BOOKTITLE = "Proceedings {EUROCAL} '83",
  EDITOR = "J.A. van Hulzen",
  SERIES = "Springer {LNCS}",
  VOLUME = 162, PAGES = "286-300",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1983}

@INPROCEEDINGS{Wang:84,
  AUTHOR = "P.S. Wang and T.Y.P. Chang and J.A. van Hulzen",
  TITLE = "Code generation and optimization for finite element analysis",
  BOOKTITLE = "Proceedings {EUROSAM} '84",
  EDITOR = "J.P. Fitch",
  SERIES = "Springer {LNCS}",
  VOLUME = 174, PAGES = "237-247",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1984}

@INPROCEEDINGS{Hulshof,
  AUTHOR = "B.J.A. Hulshof and J.A. van Hulzen",
  TITLE = "Automatic error cumulation control",
  BOOKTITLE = "Proceedings {EUROSAM} '84",
  EDITOR = "J.P. Fitch",
  SERIES = "Springer {LNCS}",
  VOLUME = 174, PAGES = "260-271",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1984}

@INPROCEEDINGS{Heuvel:89,
  AUTHOR = "P. van den Heuvel and J.A. van Hulzen and V.V. Goldman",
  TITLE = "Automatic generation of {FORTRAN}-coded {Jacobians and Hessians}",
  BOOKTITLE = "Proceedings {EUROCAL} '87",
  EDITOR = "J.H. Davenport",
  SERIES = "Springer {LNCS}",
  VOLUME = 378, PAGES = "120-131",
  ADDRESS = "Heidelberg", PUBLISHER = "Springer Verlag", YEAR = 1989}

@INPROCEEDINGS{Goldman:89,
  AUTHOR = "V.V. Goldman and J.A. van Hulzen",
  TITLE = "Automatic code vectorization of arithmetic expressions by
           bottom-up structure recognition",
  BOOKTITLE = "Computer Algebra and Parallelism",
  EDITOR = "J. Della Dora and J.P. Fitch",
  PAGES = "119-132",
  ADDRESS = "London",
  PUBLISHER = "Academic Press", YEAR = 1989}

@INPROCEEDINGS{vanHulzen:81,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Breuer's grow factor algorithm in computer algebra",
  BOOKTITLE = "Proceedings {SYMSAC} '81",
  EDITOR = "P.S. Wang",
  PAGES = "100-104", ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1981}

@INPROCEEDINGS{Molenkamp:91,
  AUTHOR = "J.H.J. Molenkamp and V.V. Goldman and J.A. van Hulzen",
  TITLE = "An improved approach to automatic error cumulation control",
  BOOKTITLE = "Proceedings {ISSAC} '91",
  EDITOR = "S.M. Watt",
  PAGES = "414-418", ADDRESS = "New York", PUBLISHER = "{ACM} Press",
  YEAR = 1991}

@ARTICLE{Breuer:69,
  AUTHOR = "M.A. Breuer",
  TITLE = "Generation of optimal code for expressions via factorization",
  JOURNAL = "Communications of the {ACM}",
  VOLUME = 12, NUMBER = 6, PAGES = "330-340", YEAR = 1969}

@BOOK{Knuth:80,
  AUTHOR = "D.E. Knuth",
  TITLE = "The art of computer programming",
  VOLUME = 2, EDITION = "Second", ADDRESS = "Reading, Mass",
  PUBLISHER = "Addison-Wesley",
  YEAR = 1980}

@INPROCEEDINGS{vanHulzen:90,
  AUTHOR = "J.A. van Hulzen",
  TITLE = "Current trends in source-code optimization",
  EDITOR = "D.V. Shirkov and V.A. Rostovtsev and V.P. Gerdt",
  BOOKTITLE = "Proceedings {JINR IV} Conference on Computer Algebra and its
                Applications in Theoretical Physics",
  ADDRESS = "Dubna", MONTH = "May", YEAR = 1990,
  NOTE = "Also available as Memorandum {\bf INF-90-41}, Department of
Computer Science, University Twente"}

mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codpri.red0000644000175000017500000017507311526203062023606 0ustar  giovannigiovannimodule  codpri;  % Support for visualizing output.

% -------------------------------------------------------------------- ;
% Copyright : J.A. Van Hulzen, Twente University, Dept. of Computer    ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands. ;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden,   ;
%             J.B. van Veelen                                          ;
% -------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

% -------------------------------------------------------------------- ;
% The module CODPRI consists of three parts:                           ;
%  1 - Facilities to vizualize the data structures on user request,i.e.;
%      when ON PRIMAT or ON PRIALL is set(see CODCTL.RED).             ;
%  2 - Routines for constructing PREFIXLIST. The value of this variable;
%      is an association list,consisting of pairs (name.value),where   ;
%      name is the (sub)expression name and where value stands for the ;
%      prefixform of the corresponding (sub)expression. Its construc-  ;
%      tion is activated via the procedure MAKEPREFIXL used in CALC    ;
%      (see the module CODCTL).                                        ;
%  3 - Functions for improving the final layout of the output. These   ;
%      functions are applied on the final form of Codmat before the    ;
%      preparations for the printing process start.Calling the function;
%      ImproveFinalLayout suffices.                                    ;
% -------------------------------------------------------------------- ;

% -------------------------------------------------------------------- ;
% Global identifiers needed in this module are :                       ;
% -------------------------------------------------------------------- ;

fluid '(preprefixlist);

global '(codbexl!* rowmax rowmin lintlst kvarlst endmat rhsaliases
         avarlst min!-expr!-length!* !*vectorc)$

global '(codmat maxvar)$

% -------------------------------------------------------------------- ;
% LINTLST is a list of integers which are too long to be included in   ;
% the schemes directly.LINTLST is built up in the procedure PRINUMB and;
% used in the procedure PRISCHEME via the procedure PRILINT.           ;
% The globals ROWMAX,ROWMIN and ENDMAT are defined in CODCTL.RED. The  ;
% global KVARLST is introduced in CODMAT.RED.                          ;
% -------------------------------------------------------------------- ;

% -------------------------------------------------------------------- ;
% PART 1 : PROCEDURES FOR VIZUALIZING THE DATA STRUCTURES              ;
% -------------------------------------------------------------------- ;
% These print facilities are mainly designed as debugging tool.They are;
% usable via an ON PRIMAT or an ON PRIALL setting.The governing routine;
% is PRIMAT,called in the procedure CALC to vizualize the result of    ;
% parsing a set of input expressions and to show the results of optimi-;
% zing this set.                                                       ;
% In PRIMAT the linelength is temporarily reset to 120,thus limiting   ;
% the size of the matrix schemes produced by PRISCHEME('PLUS) and      ;
% PRISCHEME('TIMES) in PRIMAT.                                         ;
% In PRISCHEME(Operator) a message is generated when the linelength is ;
% not sufficient telling that printing is impossible.In all other cases;
% the procedure PRISCHEME produces a compact version of reality.It uses;
% the routines PRI(nt)NUMB(er),PRI(nt)ROW,PRI(nt)VAR(iable) and PRI(nt);
% L(ong)INT(eger). The procedures TESTPROW and MEMPQ are used for test-;
% ing details in PRISCHEME and PRIROW,resp. To simplify explaining the ;
% code we give a simple example :                                      ;
%                                                                      ;
% Assume we have :                                                     ;
%                                       8  2                   8       ;
% U := ((A + 2*B)*SIN(A + 2*B)*A*B + 2*A *B  + 2*A + 4*B - 677)  + 1234;
%                                                                      ;
% Then PRIMAT produces via PRISCHEME :                                 ;
%                                                                      ;
% Sumscheme :                                                          ;
%                                                                      ;
%    |  3  4  5| EC|Far                                                ;
% ---------------------                                                ;
%   0|        X|  1| U                                                 ;
%   2|  2  4  X|  8| 1                                                 ;
%   4|  1  2   |  1! 3                                                 ;
%   5|  1  2   |  1| S0                                                ;
% ---------------------                                                ;
% The following integers ought to replace the X-entries of the matrix  ;
% in a left-to-right-and-top-down order : 1234  -677                   ;
% 3 : A                                                                ;
% 4 : B                                                                ;
% 5 : +ONE                                                             ;
%                                                                      ;
% Productscheme :                                                      ;
%                                                                      ;
%    |  0  1  2| EC|Far                                                ;
% ---------------------                                                ;
%   1|         |  1| 0                                                 ;
%   3|  1  1  1|  1| 2                                                 ;
%   6|     8  2|  2| 2                                                 ;
% ---------------------                                                ;
% 0 : S1=SIN(S0)                                                       ;
% 1 : A                                                                ;
% 2 : B                                                                ;
%                                                                      ;
% If Far has a name (U,S0) as value its row defines the prim.part of   ;
% the expression assigned to this name.Its composite parts can be found;
% in those rows of the other scheme,which have the index of the present;
% row in their Far-field( i.e. their father). The EC-field shows the   ;
% E(xponent of a sum) or the C(oefficient of a product).               ;
% The column numbers in the schemes correspondent with the CODMAT co-  ;
% lumn indices. These numbers are used to give a (vertical) list of    ;
% pairs (number : varname),where varname is either a variable name,the ;
% special symbol !+ONE( for the constants in a sum) or an assignment   ;
% like S1=SIN(S0),indicating that function applications are replaced by;
% system selected names.                                               ;
% When exponents or coefficients are too long to be printed,i.e. when  ;
% entry>999 or when entry<-99 an X is printed instead. A sequence of   ;
% integers corresponding with these X's in the scheme is given directly;
% below it in a left-to-right-and-top-down order. Hence :              ;
%                                                                      ;
% U     := 1234 + prod1(= product defined in row 1)                    ;
% prod1 := 1 * sum2(= sum defined in row 2)                            ;
% sum2  := (2*A + 4*B -677 + prod3 + prod6)^8                          ;
% prod3 := S1 * A * B * sum4                                           ;
% sum4  := A + 2*B                                                     ;
% S1    := SIN(S0)                                                     ;
% S0    := A + 2*B                                                     ;
% prod6 := 2 * A^8 * B^2                                               ;
% -------------------------------------------------------------------- ;

symbolic smacro procedure testprow(y,opv);
% -------------------------------------------------------------------- ;
% arg : Column index Y. Operator value Opv.                            ;
% res : T if the column Y is part of the Opv-scheme,NIL otherwise.     ;
% -------------------------------------------------------------------- ;
free(y) and opval(y) eq opv;


symbolic procedure primat;
% -------------------------------------------------------------------- ;
% res : A reflection is produced of the state of the matrix CODMAT     ;
% -------------------------------------------------------------------- ;
   begin scalar l;
     l:=linelength 120;
     terpri();
     prin2 "Sumscheme :";
     prischeme('plus);
     terpri();
     terpri();
     terpri();
     prin2 "Productscheme :";
     prischeme('times);
     linelength(l);
   end;

% -------------------------------------------------------------------- ;
% The procedure Primat1 can be used for testing new features.          ;
% -------------------------------------------------------------------- ;
global '(freevec freetest)$
freetest:=nil;

symbolic procedure primat1;
begin scalar freevec1,rmin,rmax;
 rmin:=rowmin; rmax:=rowmax;
 if null freetest or freetest>;
 for j:=rmin:rmax do <>;
 primat();
 for j:=rmin:rmax do
  << if not getv(freevec,j+maxvar) then setoccup(j);
     terpri();
     if j<0 then write "col(",j,")=",getv(codmat,maxvar+j)
     else write "row(",j,")=",getv(codmat,maxvar+j)
  >>;
 terpri()
end;

symbolic procedure prischeme(opv);
% -------------------------------------------------------------------- ;
% arg : The value of Opv is either 'TIMES or 'PLUS.                    ;
% eff : The Opv-scheme is printed                                      ;
% -------------------------------------------------------------------- ;
begin scalar n,yl;
  n:=0;
  lintlst:=nil;
  terpri();
  terpri();
  prin2 "   |";
  for y:=rowmin:(-1) do
  if testprow(y,opv)
  then <>;
  prin2 "| EC|Far";
  terpri();
  n:=3*n+12;
  if n>120 then <>;
  for j:=1:n do prin2 "-";
  yl:=reverse(yl);
  for x:=0:rowmax do
  if testprow(x,opv)
  then prirow(x,opv,yl);
  terpri();
  for j:=1:n do prin2 "-";
  prilint();
  terpri();
  for y:=rowmin:(-1) do
  if testprow(y,opv)
  then
  <>;
     for j:=1:length(yl) do prin2 "   ";
     prin2 "|";
     prinumb(expcof x);
     prin2 "| ";
     privar(farvar x);
   end;

symbolic procedure memqp(y,yl);
% -------------------------------------------------------------------- ;
% arg : Y is the index of the column of which the exponent/coefficient ;
%       of the corresponding variable has to be printed. Y1 is the list;
%       of indices of columns which can also contribute to the row     ;
%       which is now in the process of being printed.                  ;
% eff : If Y=Car(Y1) the calling routine,PRIROW,can continue its prin- ;
%       ting activities directly with the exp./coeff. in question. If  ;
%       not we have to print blanks to indicate that the column and row;
%       have nothing in common. We continue with the Cdr of the list Y1;
% -------------------------------------------------------------------- ;
if y=car(yl)
then cdr(yl)
else
<>;

symbolic procedure prinumb(n);
% -------------------------------------------------------------------- ;
% arg : A number N.                                                    ;
% eff : N is printed using atmost three positions if possible.In case  ;
%       the size of the number is to large or the number is a float,   ;
%       we print "  X" and add N to then list LINTLST of long numbers, ;
%       which are printed once the scheme is completed.                ;
% -------------------------------------------------------------------- ;
<>
  else
  if minusp(n)
  then
    (if n>-10
     then prin2 " "
     else
      if n<=-100
      then <>)
  else
   (if n<10
    then prin2 "  "
    else
      if n<100
      then prin2 " "
      else
        if n>=1000
        then <>);
  prin2 n;
>>;

symbolic procedure prilint;
% -------------------------------------------------------------------- ;
% eff : The list of "long" numbers LINTLST,produced in the procedure   ;
%       PRINUMB,is printed.                                            ;
% -------------------------------------------------------------------- ;
if lintlst
then
<>;
>>;

symbolic procedure privar(var);
% -------------------------------------------------------------------- ;
% arg : The template VAR  for a variable,a list defining a kernel in   ;
%       prefix notation,i.e.(a b c) in stead of a(b,c) or a constant.  ;
% eff : VAR is printed.                                                ;
% -------------------------------------------------------------------- ;
if atom(var)
then prin2 var
else
<>;
  prin2 ")";
>>;


% -------------------------------------------------------------------- ;
% PART 2 : PRODUCTION OF PREFIXLIST - THE FINAL RESULT                 ;
% -------------------------------------------------------------------- ;
% Given :                                                              ;
%                                       8  2                   8       ;
% U := ((A + 2*B)*SIN(A + 2*B)*A*B + 2*A *B  + 2*A + 4*B - 677)  + 1234;
%                                                                      ;
% The optimizer produces the sequence of assignment statements :       ;
%                                                                      ;
%    S0 := A + 2*B                                                     ;
%    S1 := SIN(S0)                                                     ;
%    S3 := A*B                                                         ;
%    S9 := A*A                                                         ;
%    S8 := A*S9                                                        ;
%    S7 := S8*S8                                                       ;
%    S5 := 2*S0 - 677 + S3*(S0*S1 + 2*S3*S7)                           ;
%    S9 := S5*S5                                                       ;
%    S8 := S9*S9                                                       ;
%    S6 := S8*S8                                                       ;
%    U := 1234 + S6                                                    ;
%                                                                      ;
% The above given REDUCE infix notation can be replaced by FORTRAN or a;
% prefix form. This depends on the current flag settings. But for prin-;
% ting we always use the value of PREFIXLIST,which is in this particu- ;
% lar case :                                                           ;
%                                                                      ;
%   ((S0 PLUS A (TIMES 2 B))                                           ;
%    (S1 SIN S0)                                                       ;
%    (S3 TIMES A B)                                                    ;
%    (S9 TIMES A A)                                                    ;
%    (S8 TIMES A S9)                                                   ;
%    (S7 TIMES S8 S8)                                                  ;
%    (S5                                                               ;
%       PLUS                                                           ;
%       (TIMES 2 S0)                                                   ;
%       (MINUS 677)                                                    ;
%       (TIMES S3 (PLUS (TIMES S0 S1) (TIMES 2 S3 S7))))               ;
%    (S9 TIMES S5 S5)                                                  ;
%    (S8 TIMES S9 S9)                                                  ;
%    (S6 TIMES S8 S8)                                                  ;
%    (U PLUS 1234 (TIMES S6)))                                         ;
%                                                                      ;
% PREFIXLIST is iteratively constructed by the procedure MAKEPREFIXL   ;
% (see CODCTL.RED),by successively using the items of the (global) list;
% CodBexl!* via a ForEach-statement. Such an item is either an index of;
% a row,where the description of the corresponding assignment statement;
% starts(in the above example U) or of a system generated cse-name.    ;
% These alternatives demand for either a call of PRFEXP(rowindex) or of;
% PRFKVAR(cse-name).The routines PR(epare pre)F(ix form of an )EXP(res-;
% sion) and PR(epare pre)F(ix form of an element of)KVAR(lst) call each;
% other and the procedures CONSTR(uct an)EXP(ression),PR(epare the list;
% of operands in pre)F(ix form of the pri)M(.part of an)EX(pression),  ;
% (prepare the list of operands in prefix form of the)COMP(osite part  ;
% of an)EX(pression) and PR(epare in pre)F(ix form a redefinition of a);
% POW(er into a)L(ist of multiplications(i.d. an addition chain mecha- ;
% nism)). The last routine uses the additional procedures PREPPOWLS    ;
% and INSEXPLST. For further comment : see below.                      ;
% -------------------------------------------------------------------- ;

global '(!*prefix !*again)$
fluid '(prefixlist);
prefixlist:=nil;

% -------------------------------------------------------------------- ;
% These globals are already introduced in CODCTL.RED.                  ;
% -------------------------------------------------------------------- ;

symbolic procedure prfexp(x,prefixlist);
% -------------------------------------------------------------------- ;
% arg : X is the CODMAT-index of the row where the description of a top;
%       level sum or product starts.                                   ;
% eff : The prefix definition of this expression ,a dotted pair (name. ;
%       value) is added to PREFIXLIST,in combination with all its cse's;
%       which have to precede the expression when printing the result. ;
%       Since "consing" is used for the construction of PREFIXLIST it  ;
%       ought to be reversed before it can be used for the actual prin-;
%       ting.The cse-ordering is defined by the value of the ORDR-field;
%       of row X of CODMAT,a list built up during input parsing (see   ;
%       CODMAT.RED) and optimization(see CODOPT.RED) using the procedu-;
%       re SETPREV(see CODMAT.RED,part 2).                             ;
% -------------------------------------------------------------------- ;
begin scalar xx,nex;
 if free(x)
 then % Start with cse's.;
 <>
   >>;
    % ---------------------------------------------------------------- ;
    % Continue with expression itself if it has not yet been printed as;
    % part of an addition chain ('Bexl:=T,see PREPPOWLS).              ;
    % ---------------------------------------------------------------- ;
   if not( get(farvar x,'bexl) = x)
    then if nex:=get(farvar x,'nex)
          then << foreach arg in cdr nex do
                   if xx := get(arg, 'rowindex)
                     then prefixlist:=prfexp(xx,prefixlist)
                     else prefixlist:=prfkvar(arg,prefixlist);
                  remprop(car nex, 'kvarlst);
                  % remprop(farvar x,'nex); Needed in cleanupprefixl to
                  %                         handle arrays
                  prefixlist:=(nex.constrexp(x)).prefixlist;
                  symtabrem(nil, farvar x)
               >>
          else prefixlist:=(farvar(x).constrexp(x)).prefixlist
     else remprop(farvar x,'bexl);
   setoccup(x)
 >>;
 return prefixlist
end;


symbolic procedure constrexp(x);
% -------------------------------------------------------------------- ;
% arg : X is the CODMAT-index of the row where the description starts  ;
%       of the expression to be added to PREFIXLIST.                   ;
% res : Construction of the expression in prefix form. The result is   ;
%       used in PRFEXP.                                                ;
% -------------------------------------------------------------------- ;
begin scalar s,ec,opv,ch,ls;
  if (opv:=opval x) eq 'times
  then
  <1 then s:='times.s else s:=car(s)
     else
       if !:onep(dm!-minus ec)
        then s:=(if ls>1 then list('minus,'times.s)
                                              else list('minus,car s))
        else
         if !:minusp(ec)
          then s:=list('minus,'times.((dm!-minus ec).s))
          else s:='times.(ec.s)
  >>
  else
    if opv eq 'plus
    then
    <1 then s:='plus.shiftminus(s) else s:=car(s);
      if (ec:=expcof(x))>1 then s:=list('expt,s,ec)
    >>
    else
    <>
      else s:=z.s;
      s:=car(opv).reverse(s);
      foreach op in cdr(opv) do
      s:=list(op,s);
      if (ec:=expcof x)>1
      then s:=list('expt,s,ec)
    >>;
  return s
end;

symbolic procedure shiftminus(s);
begin scalar ts,head;
 ts:=s; head:=nil;
 while ts and (pairp(car ts) and caar(ts) eq 'minus) do
  << head:=car(ts).head; ts:=cdr ts>>;
 return if ts then append(ts,reverse head) else s
end;

symbolic procedure prfmex(zz,op);
% -------------------------------------------------------------------- ;
% arg : ZZ is a Zstrt and Op an element of {'PLUS,'TIMES}.             ;
% res : List of operands in prefix form,i.e. a list of multiples or a  ;
%       list of powers of variables.                                   ;
% -------------------------------------------------------------------- ;
foreach z in zz collect
begin scalar var,nex;
  var:=farvar(yind z);
  if nex:=get(var,'nex) then << var:=nex; symtabrem(nil,var)>>;
  if var eq '!+one
  then % A constant.;
    if !:minusp(ival(z))
    then return list('minus,dm!-minus(ival(z)))
    else return ival(z);
  if not(!:onep dm!-abs(ival z))
  then
    if op eq 'plus
    then var:=list('times,dm!-abs ival z,var)
    else
      if bval(z)
      then var:=bval(z)
      else var:=list('expt,var,ival z);
  if !:minusp(ival z)
  then var:=list('minus,var);
  return var;
end;

symbolic procedure compex(chr);
% -------------------------------------------------------------------- ;
% arg : Chr is a list of indices of rows where the description starts  ;
%       of (sub)expressions,being composite terms or factors.          ;
% res : A list of these (sub)expressions in prefix form.               ;
% -------------------------------------------------------------------- ;
foreach ch in chr collect
constrexp(ch);

symbolic procedure prfkvar(kv,prefixlist);
% -------------------------------------------------------------------- ;
% arg : Kv is the Car-part of an element (Var.F) of the Kvarlst,where F;
%       is a list of the form (function-name (list of arguments)),if   ;
%       not already added to PREFIXLIST                                ;
% eff : The occurence of Kv in Kvarlst is tested. If Kv is still there ;
%       the corresponding dotted pair is used for extending PREFIXLIST ;
%       before it is removed from Kvarlst.                             ;
% -------------------------------------------------------------------- ;
begin scalar kvl,x,kvl1,nex;
  while kvarlst and not (kv=caar(kvarlst)) do
  <>;
  if null(kvarlst)
  then
  <<% KVar already printed or redefined as a lhs.;
    kvarlst:=kvl;
    if nex:=get(kv,'nex)
     then prefixlist:=(kv.nex).nexcheck(kv,nex,prefixlist)
  >>
  else
  <>;
    prefixlist:=(kv.cdr(kvl1)).prefixlist;
    flag (list (kv),'done)
  >>;
  return prefixlist
end;

symbolic procedure nexcheck(kv,nex,prefixlist);
begin scalar x;
if not (flagp (kv, 'done) or (!*vectorc and subscriptedvarp (car nex)))
  then for each arg in cdr nex do
          if x:=get(arg,'rowindex)
             then prefixlist:=prfexp(x,prefixlist)
             else prefixlist:=prfkvar(arg,prefixlist);
  symtabrem(nil,kv);
  %--------------------------------------------------------------------;
  % Otherwise, this further non-used temporary variable will also be   ;
  % declared.                                                          ;
  %--------------------------------------------------------------------;
  remprop(kv,'nex);
  return prefixlist
end;

symbolic procedure evalpartprefixlist(prefixlist);
% ------------------------------------------------------------------- ;
% Evaluate partially the elements of Prefixlist leading to a list of  ;
% (sub)expressions, which have either PLUS or MINUS as their leading  ;
% operator.                                                           ;
% ------------------------------------------------------------------- ;
begin scalar newprefixlist,pair,temp;
 while not null prefixlist do
  <>;
 foreach item in get('evalpart1,'setklist) do
  << remprop(item,'avalue);
     if (temp:=get(item,'taval))
      then <>
  >>;
 remprop('evalpart1,'setklist);
 return reverse(newprefixlist)
end;

symbolic procedure evalpart1 pair;
begin scalar carpair,exp,res,x;
 exp:=!*exp; !*exp:=t;
 carpair:= car pair;
 x:=reval cdr pair;
 if not (atom(x) or (car x memq '(plus difference))) and
    flagp(carpair,'newsym)
  then << if (get(carpair,'avalue)) and not(get(carpair,'taval))
           then  put(carpair,'taval,prepsq cadadr get(carpair,'avalue));
          setk(carpair,aeval(x))
       >>
  else res:=(carpair).x;
 if null res
  then put('evalpart1,'setklist,(carpair).get('evalpart1,'setklist));
 !*exp:=exp;
 return res
end;

symbolic procedure removearraysubstitutes(prefixlist);
% ------------------------------------------------------------------- ;
% When arrayelements form rhs's in pairs of prefixlist, used to       ;
% produce output, the cse-names, used to denote them in the rest of   ;
% prefixlist, are replaced by these arrayelements if the arrayname    ;
% occurs in the GENTRAN symboltable, used for making declarations.    ;
% ------------------------------------------------------------------- ;
begin scalar newprefixlist,pair;
 while not null prefixlist do
  << pair:= car prefixlist; prefixlist:=cdr prefixlist;
     if flagp(car pair,'newsym)
         and
        (pairp(cdr pair) and subscriptedvarp(cadr pair))
      then
       prefixlist:=(foreach item in prefixlist collect
                                     subst(cdr pair,car pair,item))
    %subst(cdr pair,car pair,car item).subst(cdr pair,car pair,cdr item)
      else
       newprefixlist:=pair.newprefixlist;
  >>;
 return reverse newprefixlist
end;


% -------------------------------------------------------------------- ;
% COMPUTATION RULES FOR POWERS : AN ADDITION CHAIN MECHANISM           ;
%                                                                      ;
% The above given Optimizer output contains the following subsequences ;
%  ................                                                    ;
%  S9 := A * A          A ^ 2   ( 2 = 1 + 1 )                          ;
%  S8 := A * S9         A ^ 3   ( 3 = 2 + 1 )                          ;
%  S7 := S8 * S8        A ^ 6   ( 6 = 3 + 3 )                          ;
%  ................                                                    ;
%  S9 := S5 * S5       S5 ^ 2   ( 2 = 1 + 1 )                          ;
%  S8 := S9 * S9       S5 ^ 4   ( 4 = 2 + 2 )    S9 is re used         ;
%  S6 := S8 * S8       S5 ^ 8   ( 8 = 4 + 4 )    S8 is re used         ;
%                                                                      ;
% Printing a view on CODMAT (after the above given output is produced) ;
% using the procedure PRIMAT (see part 1 of this module) shows:        ;
%                                                                      ;
%  Sumscheme :                                                         ;
%                                                                      ;
%     |  7 11 12 13| EC|Far                                            ;
%  ------------------------                                            ;
%    0|          X |  1| U                                             ;
%    5|     1  2   |  1| S0                                            ;
%   10|            |  1| 9                                             ;
%   12|  2       X |  1| S5                                            ;
%  ------------------------                                            ;
%  The following integers ought tp replace the X-entries of the matrix ;
%  in a left-to-right-and-top-down order : 1234  -677                  ;
%  7  : S0                                                             ;
%  11 : A                                                              ;
%  12 : B                                                              ;
%  13 : +ONE                                                           ;
%                                                                      ;
%  Productscheme :                                                     ;
%                                                                      ;
%     |  1  3  4  8  9 10| EC|Far                                      ;
%  ------------------------------                                      ;
%    1|  8               |  1| 0                                       ;
%    3|     1     1      |  1| 10                                      ;
%    6|        1     6   |  2| 10                                      ;
%    8|              1  1|  1| S3                                      ;
%    9|        1         |  1| 12                                      ;
%  ------------------------------                                      ;
%  1  : S5                                                             ;
%  3  : S0                                                             ;
%  4  : S3                                                             ;
%  8  : S1=SIN(S0)                                                     ;
%  9  : A                                                              ;
%  10 : B                                                              ;
%                                                                      ;
% S5 ^ 8 and A ^ 6 are still there,in contrast to S6,S7,S8 and S9, be- ;
% cause the latter group is produced in a different way. S6 and S7 are ;
% generated via PREPPOWLS,called in PREPFINALPLST(see CODCTL.RED),acti-;
% vated in MAKEPREFIXL, assuming OFF AGAIN holds.                      ;
% In PREPPOWLS the Nvarlst's ((8.S6)(1.S5)) and ((6.S7)(1.A)) are made ;
% and via their property lists associated with S5 and A,respectively.  ;
% These lists are used in PRFPOWL to produce the above given chains.   ;
% The addition chain-like algorithm used is reflected by the structure ;
% of PRFPOWL : Given a list of at least two exponents(integers),being  ;
% the Car's of the elements of Nvarlst,produce an intuitively minimal  ;
% number of additions by halving even numbers and by making odd numbers;
% even by substracting 1. Hence (63 1) leads to :                      ;
% 63=62+1,62=31+31,31=30+1,30=15+15,15=14+1,14=7+7,7=6+1,6=3+3,3=2+1,  ;
% 2=1+1. Since the Nvarlst might be longer,for instance (63 28 15 1),  ;
% PRFPOWL allows a more general approach,which for example leads to :  ;
% 63=62+1,62=31+31,31=28+3,28=15+13,15=13+2,13=12+1,12=6+6,6=3+3,3=2+1,;
% 2=1+1.                                                               ;
% -------------------------------------------------------------------- ;

symbolic procedure preppowls;
% -------------------------------------------------------------------- ;
% eff : This procedure is called before the actual printing starts,i.e.;
%       before PREFIXLIST is made. This allows to refer to results     ;
%       produced by this routine in PRFEXP at two different places. The;
%       value of the indicators 'Nvarlst(i.e. exists such a list?) and ;
%       'Bexl(=T if the corresponding (sub)expression name is part of a;
%       chain) are used in PRFEXP.                                     ;
%       The Zstrt's of all relevant 'TIMES-columns are analysed. If non;
%       one elements occur they are stored in a so called Nvarlst,asso-;
%       ciated with these relevant columns as value of the indicator   ;
%       'Nvarlst,which is put on the property list of the variable gi- ;
%       ving the column its identity via its FarVar-value. Nvarlst is a;
%       list of pairs (exponent=IVal(Zstrt-element) . associated name).;
%       This name can be newly generated(such as S6 and S7 in the above;
%       example) or already exist if,for instance, FarVar^exponent is  ;
%       itself an expression.This is marked with the indicator 'Bexl=T.;
%       The incorporation of this expression in PREFIXLIST is now done ;
%       via the production of the addition chain,implying that it is no;
%       longer necessary to treat it seperately.                       ;
% -------------------------------------------------------------------- ;
begin scalar var,nvar,nvarlst,rindx;
  for y:=rowmin:(-1) do
  if not numberp(var:=farvar y) and opval(y) eq 'times
  then
  <>;
    if nvarlst then <>
  >>;
terpri()
end$

symbolic procedure prfpowl(y,prefixlist);
% -------------------------------------------------------------------- ;
% arg : Y is a variable with an NVarlst in its property list.          ;
% res : The NVarlst is used to produce an addition chain in the above  ;
%       suggested way.Its is produced in the form of a list Powlst of  ;
%       dotted pairs which can be included in PREFIXLIST directly. So  ;
%       the pairs have a name as Car-part and a product of 2 variables ;
%       as Cdr-part.                                                   ;
% -------------------------------------------------------------------- ;
begin scalar nvarlst,explst,first,cfirst,csecond,diff,var,
             powlst,var1,var2;
  nvarlst:=explst:=get(y,'nvarlst);
  repeat
  <csecond
    then
    <>;
      diff:=csecond:=cfirst/2;
    >>;
    if null(assoc(diff,nvarlst))
    then
    <>;
    var1:=cdr(assoc(diff,nvarlst));
    var2:=cdr(assoc(csecond,nvarlst));
    powlst:=(cdr(first).list('times,var1,var2)).powlst;
    explst:=insexplst((diff.var1),explst);
  >>
  until diff=csecond and csecond=1;
  prefixlist:=append(reverse(powlst),prefixlist);
  return prefixlist
end;

symbolic procedure insexplst(el,explst);
% -------------------------------------------------------------------- ;
% arg : EL is a dotted pair (integer . name). Explst is a list of such ;
%       dotted pairs . The car-parts of the list elements define a de- ;
%       cending order for the elements of Explst.                      ;
% res : EL is inserted in Explst,but only if the Car-part was not yet  ;
%       available.                                                     ;
% -------------------------------------------------------------------- ;
if null(explst) or car(el)>caar(explst)
then el.explst
else
  if car(el)=caar(explst)
  then explst
  else car(explst).insexplst(el,cdr explst);


% -------------------------------------------------------------------- ;
% PART 3 : IMPROVEMENT OF THE FINAL FORM OF PREFIXLIST                 ;
% -------------------------------------------------------------------- ;
% The function CleanupPrefixlist is used in MakePrefixlist, defined in ;
% CODCTL.RED, for back substitution of identifiers, which occur only   ;
% once in  the set of right hand sides, defining the optimized version ;
% of the input.                                                        ;
% -------------------------------------------------------------------- ;

global '(codbexl!*);

symbolic procedure aliasbacksubst(pfl);
%--------------------------------------------------------------------
% pfl : list of (lhsides . rhsides) in reverse order.
% ret : new pfl with no more superfluous aliases in correct order.
%--------------------------------------------------------------------
begin
  scalar backsubstlist,original,lhs,npfl;
  backsubstlist := rhsaliases;
  foreach stat in reverse pfl do
  <>;
   return reverse npfl;
   end;

symbolic procedure recaliasbacksubst(ex, al);
%---------------------------------------------------------------
% Commit the actual backsubstitution.
%---------------------------------------------------------------
if atom ex or constp(ex)
   then if assoc(ex,al)
           then cdr assoc(ex,al)
           else ex
   else foreach el in ex collect recaliasbacksubst(el,al);

symbolic procedure reinsertratexps (ppl,pfl);
% ----------------------------------------------------------------
% All rational exponents, collected in the preprefixlist, are
% reinserted in the prefixlist, in a position defining them just
% before their use.
% ----------------------------------------------------------------
begin
  scalar keys,npfl;
  keys:= foreach re in ppl collect car re;
  for each stat in pfl do
           << foreach k in keys do
                      if not freeof(cdr stat, k)
                         then << npfl:=assoc(k,ppl) . npfl;
                                 keys:=delete(k,keys)
                              >>;
              npfl:=stat . npfl
            >>;
  return reverse npfl
  end;

symbolic procedure cleanupvars (p,pfl);
% ----------------------------------------------------------------
% Remove all generated flags and properties w.r.t. aliases.
% ----------------------------------------------------------------
begin scalar csenow,lp,dp,pn,sv;
  csenow:=fnewsym();
  lp:=letterpart csenow;
  dp:=digitpart csenow;
  pn:=for idx:=0:dp collect mkid(lp,idx);
  if !*again and not !*vectorc
     then <>
          >>
     else if not !*again
             then <>;
                                 remprop(sv,'aliaslist);
                                >>;
                     % remove all garbage from variables.
                     pn := append(pn,p);
%                           foreach el in p collect
%                              if atom el then el else car el);
                     remflag(pn,'subscripted);
                   % remflag(pn,'vectorvar); % This is user-controlled
                                             % JB 16/3/94
                     remflag(pn,'inalias);
                     remflag(pn,'aliasnewsym);
                  >>;
  end;

symbolic procedure listeq(a,b);
if atom a
   then eq(a,b)
   else if atom b
           then nil
           else listeq(car a, car b)
                and listeq(cdr a, cdr b);

symbolic smacro procedure protected(a,pn);
member((if atom a then a else car a), pn);

symbolic smacro procedure protect(n,pn);
if member((if atom n then n else car n),pn)
   then pn
   else (if atom n then n else car n). pn;

symbolic procedure cleanupprefixlist(prefixlist);
% -------------------------------------------------------------------- ;
% This procedure is used for making the final version of the prefix-   ;
% list. The prefixlist is made shorter by substituting some assign-    ;
% ments occuring in the prefixlist in expressions in the other assign- ;
% ments in the list.                                                   ;
% The following cases are considered:                                  ;
%                                                                      ;
% 1)    :                                                              ;
%    a := (-)constant     a is not protected i.e. not an output var.   ;
%    . := ...a...      T  a -> (-)constant (old -> new) is substituted ;
%       :              v                in this part of the prefixlist ;
%                                                                      ;
% 2)    :                                                              ;
%    a := expression      a not protected, this assignment is removed  ;
%    . := ...a...      T  this is the only place where a is used       ;
%       :              v  a -> expression substituted in this part     ;
%                                                                      ;
% 3)    :                                                              ;
%    b := ...                                                          ;
%    . := ...b...                                                      ;
%    a := (-)b            a not protected, this assignment is removed  ;
%    . := ...b...      T  a -> (-)b substituted in this part of the    ;
%    . := ...a...      |            prefixlist                         ;
%       :              v                                               ;
%                                                                      ;
% 4)    :                                                              ;
%    b := ...          T  b not protected, changed to a := ...         ;
%    . := ...b...      |                                               ;
%    a := b            |  a protected, this assignment is removed      ;
%    . := ...b...      |  b -> a substituted in this part of the       ;
%    . := ...a...      |         prefixlist                            ;
%       :              v                                               ;
%                                                                      ;
% 5)    :                                                              ;
%    b := ...          T  b not protected, changed to a:= ...          ;
%    . := ...b...      |                                               ;
%    a := -b           |  a protected, this assignment is removed      ;
%    . := ...b...      |  b -> a and a -> -a substituted in this part  ;
%    . := ...a...      |                     of the prefixlist         ;
%       :              v                                               ;
%                                                                      ;
% Substitution-rules are collected in a list called SUBSTLST.          ;
% All assignments in the prefixlist are treated one by one.            ;
% First, all substitutions are made in the assignment. Second, the     ;
% resulting assignment is checked if it leads to a new substitution as ;
% described in 1) - 3). If so, the new substitution is added to the    ;
% substitutionlist.                                                    ;
% Note that substitutions of kind 4) and 5) require substitutions in   ;
% assignments prior to the one that is treated (a := (-)b). Therefore  ;
% these substitutions are collected before the actual cleaning-up.     ;
% These backward-substitutions may not contain subscripted variables.  ;
% This constraint is made because of the following reasons:            ;
%  - Substitution of b -> a[i] can introduce an assignment at a point  ;
%    where i is not yet calculated.                                    ;
%  - As substitutions are not applied to the substitutes, b -> a[expr] ;
%    can become invalid by a substitution of/in expr.                  ;
%  - The second reason also applies to b[i] -> a.                      ;
%  - b -> a[i] introduces more accesses of a[i] which are slower than  ;
%    accesses of b.                                                    ;
%  - b[i] -> a cannot occur because subscripted variables are output-  ;
%    variables and therefore protected.                                ;
% When, during the cleanup, a substitution is formed concerning a      ;
% variable already involved in a backward-substitution this backward-  ;
% substitution is overrided (i.e. removed) and the new substitution is ;
% added to the substitutionlist.                                       ;
% Variables:                                                           ;
%    protectednames  : output variables                                ;
%    defvarlst       : list of variables defined in the prefixlist     ;
%    rhsocc          : ((var . #) ...) where # = number of times that  ;
%                      var occurs in the rhs or in a subscript of a    ;
%                      lhs in an assignment in the prefixlist          ;
%    substlst        : ((old . new) ...), substitutionlist             ;
%    dellst          : list of indices of assignments in the prefixlist;
%                      which must be removed because of a backward-    ;
%                      substitution                                    ;
% -------------------------------------------------------------------- ;
begin scalar lpl,protectednames,j,item,substlst,dellst,se,ose,
             r,defvarlst,rhsocc,occ,var,sgn,lhs,rhs;
  % -------------------------------------------------------------------
  %  Add rational exponentexpressions to prefixlist.
  % -------------------------------------------------------------------
  if preprefixlist
     then prefixlist:=reinsertratexps(preprefixlist, prefixlist);
  % -------------------------------------------------------------------
  %  Ensure backsubstitution of `aliased' output-variables.
  % -------------------------------------------------------------------
  prefixlist := aliasbacksubst(reverse prefixlist);
  lpl:=length(prefixlist);
  lhs:=mkvect(lpl); rhs:=mkvect(lpl);
  % -------------------------------------------------------------------
  %  Determine protected names.
  % -------------------------------------------------------------------
  foreach indx in codbexl!* do
    if numberp(indx) then
       <>
       else if idp(indx) then
               if not flagp(indx,'aliasnewsym)
                  then protectednames:=protect(indx, protectednames)
                  else if (var:=get(indx,'alias))
                          then protectednames
                                  := protect(var, protectednames);
  % -------------------------------------------------------------------
  % Preliminaries.
  % -------------------------------------------------------------------
  j:=0;
  foreach item in prefixlist do
     <<  % Build lhs and rhs vectors
       putv(lhs,j:=j+1,car item);
       putv(rhs,j,cdr item);
         % Remove now redundant information.
       se := nil;
       if pairp(cdr item) and get (se := cadr item, 'kvarlst)
          then remprop (se ,'kvarlst);
       if flagp (se,'done)
          then remflag (list(se),'done);
         % Build defvarlst
       defvarlst:=(car(item) . j) . defvarlst;
         % Build variable occurences lists
       if pairp car(item)
          then rhsocc:=insoccs(car(item),rhsocc);
       rhsocc:=insoccs(cdr(item),rhsocc);
         % Determine backward substitutions
       sgn:=nil;
       if eqcar(cdr item,'minus) then
       << sgn:=t;
          item:=car(item).caddr(item)>>;
       if idp(cdr item) and
          (protected(car item, protectednames) and
              not protected(cdr item,protectednames)) and
          not(get(car item,'finalalias) and pairp(car item)) and
          (r:= assoc(cdr item, defvarlst)) and
          not(assoc(cdr item,substlst)) and
          movable(item,defvarlst)
          then << dellst:=car(item).dellst;
                  substlst:=substel(cdr(item).car(item),sgn).substlst;
                  if sgn and r then
                     <<% We 've found : S0 := blah
                       %                A  := - S0
                       % This becomes : A  := - blah,
                       % and further occurences of S0 will be replaced
                       % by: - A
                       % The actual substitution takes now place.
                       % We also create a nonsense-statement at here,
                       % to be deleted later on.
                       putv(rhs,cdr r,('minus . list getv(rhs,cdr r)));
                       putv(lhs,cdr r,getv(lhs,j));
                       putv(rhs,j,(getv(lhs,j)))>>
               >>;
     >>;
  % -------------------------------------------------------------------
  % Do the cleaning up!
  % -------------------------------------------------------------------
  for j:=1:lpl do
     <>
          else % Do the substitutions
               <>;
                 se:=nil;
                 if listeq(car item,cdr item)
                    then % We created nonsense like ( a . a )
                         <>
                    else
                    <>;
                 % Add the substitution
                 if se
                 then <>;
                        substlst:=se.substlst;
                        putv(lhs,j,nil); % delete current assignment
                        putv(rhs,j,nil)
                      >>
                 else if (se:=assoc(car item,substlst)) and
                         not(protected(car item, protectednames) and
                             eq(j,cdr assoc(car item,defvarlst)))
                         then % backward-substitution of lhs
                              putv(lhs,j,cdr se)
                         else if se
                                 then % This is an output occurrence
                                      substlst:=delete(se,substlst);
               >>
     >>;
  % -------------------------------------------------------------------
  % Determine new prefixlist
  % -------------------------------------------------------------------
  prefixlist:=nil;
  for j:=1:lpl do
     if getv(lhs,j)
        then prefixlist:=(getv(lhs,j).getv(rhs,j)).prefixlist;
  % -------------------------------------------------------------------
  % Check on minimumlength requirements.
  % -------------------------------------------------------------------
  if min!-expr!-length!*
     then prefixlist:=
                     make_min_length(reverse prefixlist,protectednames)
     else prefixlist:=reverse prefixlist;
  % -------------------------------------------------------------------
  % Undo temporary value-backup and remove rubbish.
  % -------------------------------------------------------------------
  apply1('arestore,avarlst);   % For bootstrapping.
  cleanupvars(protectednames,prefixlist);
  % -------------------------------------------------------------------
  % Finish.
  % -------------------------------------------------------------------
  return prefixlist
  end$

symbolic procedure movable(v,defl);
%---------------------------------------------------------------------;
% We have to avoid that a subscripted variable is moved outside the
% scope of a cse-definition it depends upon. We can check this by
% comparing the new position and the position of the cse in the defl.
% ------------------------------------------------------------------- ;
  if pairp car(v)
     then
       not(nil member foreach idx in cdar v collect
                (numberp(idx) or
                if assoc(idx, defl)
                   then (cdr assoc(idx,defl) < cdr assoc(cdr v,defl))
                   else t))
     else t$

symbolic procedure insoccs(x,occlst);
begin
   if idp(x) or subscriptedvarp(x) or
      ((pairp x) and (subscriptedvarp car x))
      then occlst:=insertocc(occlst,x);
   if not(idp x) and not(constp x) then
      foreach arg in cdr x do
         occlst:=insoccs(arg,occlst);
   return occlst
end;


symbolic procedure insertocc(occlst,var);
begin scalar oldel;
   if oldel:=assoc(var,occlst) then
      occlst:=subst((var.(cdr(oldel)+1)),oldel,occlst)
   else
      occlst:=(var.1).occlst;
   return occlst
end;

symbolic procedure substel(oldnew,sign);
   car(oldnew).(if sign then list('minus,cdr oldnew) else cdr oldnew);

symbolic procedure replacein(expr1,sl);
% -------------------------------------------------------------------- ;
% All substitutions in sl are applied to expr1.                        ;
% In the resulting expression,                                         ;
%    (times 1 rest)        is replaced by (times rest)                 ;
%    (plus 0 rest)                     by (plus rest)                  ;
%    (minus (minus expr))              by expr                         ;
%    (minus 0)                         by 0                            ;
%    (times 1)                         by 1                            ;
%    (plus 0)                          by 0                            ;
%    (expt expr 0)                     by 1                            ;
%    (expt expr 1)                     by expr                         ;
%    (quotient expr 1)                 by expr                         ;
% -------------------------------------------------------------------- ;
begin scalar nexpr,iszero;
   return
      if idp(expr1) or subscriptedvarp(expr1) then
         if (nexpr:=assoc(expr1,sl)) then cdr(nexpr) else expr1
      else if constp expr1 then
         expr1
      else
      << nexpr:=foreach el in cdr(expr1) collect replacein(el,sl);
         expr1:=append(list(car expr1),nexpr);
         if eqcar(expr1,'minus) and eqcar(cadr expr1,'minus) then
            expr1:=cadadr expr1;
         if eqcar(expr1,'plus) then
         << nexpr:='(plus);
            foreach el in cdr(expr1) do
               if not(constp(el) and !:zerop(el)) then
                  nexpr:=append(nexpr,
                       (if eqcar(el,'plus) then cdr(el) else list(el)));
            expr1:=nexpr
         >>
         else if eqcar(expr1,'times) then
         << iszero:=nil;
            nexpr:='(times);
            foreach el in cdr(expr1) do
            << if not(constp(el) and !:onep(el)) then
                  nexpr:=append(nexpr,
                      (if eqcar(el,'times) then cdr(el) else list(el)));
               if constp(el) and !:zerop(el) then iszero:=t
            >>;
            expr1:=if iszero then 0 else nexpr
         >>
         else if eqcar(expr1,'quotient) and constp(caddr expr1) and
                    !:onep(caddr expr1) then
            expr1:=cadr(expr1)
         else if eqcar(expr1,'quotient) then
            expr1:=qqstr!?(expr1)
         else if eqcar(expr1,'minus) and constp(cadr expr1) and
                    !:zerop(cadr expr1) then
            expr1:=0
         else if eqcar(expr1,'expt) and constp(caddr expr1) then
            if !:zerop(caddr expr1) then
               expr1:=1
            else if !:onep(caddr expr1) then
               expr1:=cadr expr1;
         if pairp(expr1) and memq(car expr1,'(times plus)) then
            if length(expr1)=2 then
               expr1:=cadr expr1
            else
               if length(expr1)=1 then
                  expr1:=if expr1='plus then 0 else 1;
         expr1
      >>
end$

symbolic procedure qqstr!?(expr1);
 begin scalar nr,dm,nr2,dm2;
  nr:=cadr expr1; dm:=caddr expr1;
  if eqcar(nr,'quotient)
   then << dm2:=caddr nr; nr:=cadr nr>>
  else if eqcar(nr,'times)
   then nr:=foreach fct in nr collect
             if eqcar(fct,'quotient)
              then << dm2:=caddr fct; cadr fct>>
              else fct;
  if eqcar(dm,'quotient)
   then <>
  else if eqcar(dm,'times)
   then dm:=foreach fct in dm collect
             if eqcar(fct,'quotient)
              then << nr2:=caddr fct; cadr fct>>
              else fct;
  if dm2 then dm:=append(list('times,dm2),
                         if eqcar(dm,'times) then cdr dm else list dm);
  if nr2 then nr:=append(list('times,nr2),
                         if eqcar(nr,'times) then cdr nr else list nr);
  return(list('quotient,nr,dm))
end;

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/coddom.red0000644000175000017500000001727711526203062023574 0ustar  giovannigiovannimodule coddom;

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author    : W.N. Borst.                                             ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic$

fluid '(!:prec!:);
fluid '(pline!* posn!* orig!* ycoord!* ymax!* ymin!*);

symbolic procedure zeropp u;
% Returns T if u equals 0, regardless of u being
% an integer or an floating-point number.
   if atom u then zerop u
    else if car u eq '!:rd!: then rd!:zerop u
    else nil$

symbolic procedure constp c;
% Returns T iff c is a number, NIL otherwise
   numberp(c) or (pairp(c) and memq(car c, domainlist!*))$

symbolic procedure integerp i;
% Returns T iff i is an integer, NIL otherwise
   numberp(i) and not floatp(i)$

symbolic procedure floatprop f;
% Returns T iff f is a (domain mode) float, NIL otherwise
   floatp(f) or eqcar(f,'!:rd!:)$

symbolic procedure domprop d;
% Returns T iff d is a domain element, NIL otherwise
   pairp(d) and memq(car d, domainlist!*);

symbolic procedure doublep d;
% Returns T iff d is an arbitrary precision rounded number, else NIL
   eqcar(d,'!:rd!:) and pairp(cdr d);

symbolic procedure nil2zero u;
% Conversion NIL -> 0 needed for domain mode operations
   if null(u) then 0 else u;

symbolic procedure zero2nil u;
% Conversion 0 -> NIL needed for domain mode operations
   if !:zerop(u) then nil else u;

symbolic procedure dm!-plus(u,v);
   nil2zero(!:plus(zero2nil u, zero2nil v));

symbolic procedure dm!-difference(u,v);
   nil2zero(!:difference(zero2nil u, v));

symbolic procedure dm!-minus(u);
   nil2zero(!:minus(u));

symbolic procedure dm!-abs(u);
   if !:minusp(u) then dm!-minus(u) else u;

symbolic procedure dm!-min(u,v);
% Domain mode minimum
   if dm!-gt(u,v) then v else u;

symbolic procedure dm!-max(u,v);
% Domain mode maximum
   if dm!-gt(u,v) then u else v;

symbolic procedure dm!-times(u,v);
   nil2zero(!:times(zero2nil u,zero2nil v));

symbolic procedure dm!-mkfloat(u);
% Use consistent and version independent trafo:
   if integerp u then
      %'!:rd!: . (u + 0.0)
      %i2rd!* u
      apply1(get('!:rd!:,'i2d),u)
   else u;

symbolic procedure dm!-quotient(u,v);
% ---
% Domain mode quotient
% Always performs a floating point division and returns integers
% when possible
% ---
begin scalar noequiv;
   noequiv:=!*noequiv;
   !*noequiv:=nil;            % for integer results in productscheme
   return nil2zero(!:quotient(dm!-mkfloat u,dm!-mkfloat v));
   !*noequiv:=noequiv;
end;

symbolic procedure dm!-expt(u,n);
   nil2zero(!:expt(zero2nil u,n));

symbolic procedure dm!-gt(u,v);
% Domain mode greater than
   !:minusp(dm!-difference(v,u));

symbolic procedure dm!-eq(u,v);
% Domain mode equal to
   !:zerop(dm!-difference(u,v));

symbolic procedure dm!-lt(u,v);
% Domain mode less than
   !:minusp dm!-difference(u,v);

symbolic procedure dm!-print(p);
% ---
% Domain mode PRIN2. This is an adapted version of mathprint.
% It is used for printing floats in the data structures
% (part 1 of CODPRI)
% ---
begin
   terpri!* nil;
   maprint(p,0);
   pline!* := reverse pline!*;
   scprint(pline!*, ymax!*);
   pline!* := nil;
   posn!* := orig!*;
   ycoord!* := ymax!* := ymin!* := 0;
end;

symbolic procedure rd!:zerop!: u;
   if atom cdr u then
      ft!:zerop cdr u
   else
      bfzerop!: round!* u;

%-----------------------------------
% R3.5 seems to have machine-dependent precision algorithms.
% So we comment this out :
%
%symbolic procedure bfzerop!: u;
%% A new bigfloat zerop test which respects the precision setting
%begin scalar x;
%   return
%      << x:=cadr(u) * 10^(cddr(u) + !:prec!:);
%         ((x>-50) and (x<50))
%      >>
%end;

symbolic procedure ft!:zerop u;
begin scalar x;
   return
      << x:=u * 10^!:prec!:;
         (x>-50 and x<50)
      >>
end;

symbolic procedure ftintequiv u;
begin scalar x;
   return
      if ft!:zerop(u-(x := fix u)) then x else nil
end;

symbolic procedure dm!-fixp u;
% u = (m . e), meaning m*10^e.
% Returned : fix(u) if u is interpretable as an integer,
% nil otherwise.
%                                                  JB 14/4/94
begin scalar r,fp;
   r:=reverse explode car u;
   fp:='t;
   if (cdr u) >= 0
      then for i:=1:(cdr u) do r:='!0 . r
      else if (fp:=(length(r) > -(cdr u)))
              then for i:=1:-cdr(u) do <>
              else r:= list '!0;
    return if fp then compress reverse r
                 else nil;
   end;

symbolic procedure bfintequiv u;
% We need to be sure we work with radix 10.
% This is guaranteed by `internal2decimal'.
% We need `dm!-fixp' to avoid entering an endless loop.
%                                                  JB 14/4/94
begin scalar i;
   i:=dm!-fixp internal2decimal(u,!:prec!:);
   return
      if i then i else u
end;

symbolic procedure rdintequiv u;
   if atom cdr u then
      ftintequiv cdr u
   else
      bfintequiv u;

put('!:rd!:,'intequivfn,'rdintequiv);

% complex mode . Is momentarliy superfluous ??
symbolic expr procedure complexp v;
('complex member getdec(car v))
 or
(!*complex and not(freeof(cdr v,'i)));

symbolic procedure myprepsq u;
   if null numr u then 0 else sqform(u,function myprepf);

symbolic procedure myprepf u;
   (if null x then 0 else replus x) where x=myprepf1(u,nil);

symbolic procedure myprepf1(u,v);
   if null u then nil
    else if domainp u then list retimes(u . exchk v)
    else nconc!*(myprepf1(lc u,if mvar u eq 'k!* then v
                                else lpow u . v),
                 myprepf1(red u,v));

symbolic procedure cireval u;
% (plus a (times b i)) -> (!:cr!: !:crn!: !:gi!:)
begin
  scalar ocmplx, res;
  ocmplx:=!*complex;!*complex:='t;
  res :=if freeof(u,'i)
           then u
           else myprepsq cadr aeval ireval u;
  !*complex:=ocmplx;
  return res;
  end$

symbolic procedure remcomplex u;
% (!:cr!: !:crn!: !:gi!:) -> (plus a (times b i))
if atom u
   then u
   else if member(car u,'(!:cr!: !:crn!: !:gi!:))
           then if eqcar(u,'!:gi!:)
                   then list('plus,cadr u,list('times,cddr u,'i))
                   else prepsq cr!:simp u
           else if not(constp u) % Could be other domain-notation.
                                 % JB 18/3/94.
                   then (car u)
                      . foreach el in cdr u collect remcomplex el
                   else u;
endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/scope/codstr.red0000644000175000017500000003021511526203062023610 0ustar  giovannigiovannimodule gstructr;  % Generalized structure routines.

% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer   ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author  :   M.C. van Heerwaarden, J.A. van Hulzen                   ;
% ------------------------------------------------------------------- ;

symbolic$

% ------------------------------------------------------------------- ;
% This module contains an extended version of the structr facility of ;
% REDUCE.                                                             ;
%                                                                     ;
% Author of structr-routines: Anthony C. Hearn.                       ;
%                                                                     ;
% Copyright (c) 1987 The RAND Corporation. All rights reserved.       ;
%                                                                     ;
% ------------------------------------------------------------------- ;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% ------------------------------------------------------------------- ;
% This is a generalization of the STRUCTR-command. Instead of one     ;
% expression, GSTRUCTR takes as input a list of assignment statements.;
% SYNTAX:                                                             ;
%         ::= GSTRUCTR  NAME          ;
%                 ::= { | }            ;
%                       ::=                         ;
% As a result, all assignments are printed with substitutions for the ;
% CSE's. Then WHERE is printed, followed by the list of CSE's. These  ;
% CSE's are printed in reversed order. Matrices are treated as if     ;
% assignments were made for all matrix elements.                      ;
% When the switch FORT is ON, the statements will be in  FORTRAN execu;
% table order. Be sure PERIOD is OFF when using a matrix,since FORTRAN;
% expects integer subscripts, and REDUCE generates a floating point   ;
% representation for these subscripts when PERIOD is ON.              ;
% The switch ALGPRI can be turned OFF when the list of assignments is ;
% needed in prefix-form.                                              ;
% ------------------------------------------------------------------- ;

fluid '(countr svar !*varlis);

global '(!*algpri );
%global '(!*fort );
%global '(!*nat );
%global '(!*savestructr);

global'(varnam!*);

switch savestructr, algpri;

% loadtime(on algpri);

% ***** two essential uses of RPLACD occur in this module.

put('gstructr, 'stat, 'gstructrstat);

symbolic procedure gstructrstat;
begin
    scalar x,y;
    flag('(name), 'delim);
    if eqcar(x := xread t, 'progn)
    then x := cdr x
    else x := list x;
    if cursym!* = 'name
    then y := xread t;
    remflag('(name), 'delim);
    return list('gstructr, x, y)
end;

put('gstructr, 'formfn, 'formgstructr);

symbolic procedure formgstructr(u, vars, mode);
list('gstructr, mkquote cadr u, mkquote caddr u);

symbolic procedure gstructr(assset, name);
begin
  !*varlis := nil;
  countr := 0;
  for each ass in assset
  do if not pairp ass
     then if get(ass, 'rtype) = 'matrix
            then prepstructr(cadr get(ass,'avalue),name,ass)
           else rederr {ass, "is not a matrix"}
     else prepstructr(caddr ass, name, cadr ass);
  if !*algpri
  then print!*varlis()
  else return remredundancy(for each x in reversip!* !*varlis
              collect list('setq, cadr x, cddr x))
end;

symbolic procedure prepstructr(u, name, fvar);
   begin scalar i, j;
      %!*VARLIS is a list of elements of form:
      %( .  . );
      if name
      then svar := name
      else svar := varnam!*;
      u := aeval u;
      if flagpcar(u, 'struct)
      then << i := 0;
              u:= car u .
                   (for each row in cdr u collect
                    << i := i + 1;
                       j := 0;
                       for each column in row collect
                       << j := j + 1;
                          !*varlis := (nil .
                                       list(fvar,i,j) .
                                       prepsq prepstruct!*sq column) .
                                       !*varlis
                    >> >>
                   )
           >>
      else if getrtype u
           then typerr(u,"STRUCTR argument")
           else !*varlis:=(nil.fvar.prepsq prepstruct!*sq u).!*varlis
   end;

symbolic procedure print!*varlis;
begin
  if !*fort
  then !*varlis := reversip!* !*varlis;
  if not !*fort
  then << for each x in reverse !*varlis
          do if null car x
             then << assgnpri(cddr x,list cadr x,t);
                     if not flagpcar(cddr x,'struct) then terpri();
                     if null !*nat then terpri()
                  >>;
          if countr=0 then return nil;
          prin2t "   where"
       >>;
  for each x in !*varlis
  do if !*fort or car x
     then <>;
  if !*savestructr
    then <>;
           for each x in !*varlis do
              if car x then setk2(cadr x,mk!*sq !*k2q car x)>>
end;

symbolic procedure prepstruct!*sq u;
if eqcar(u,'!*sq)
   then prepstructf numr cadr u ./ prepstructf denr cadr u
   else u;

symbolic procedure prepstructf u;
if null u
then nil
else if domainp u
     then u
     else begin
            scalar x,y;
            x := mvar u;
            if sfp x
            then if y := assoc(x,!*varlis)
                 then x:=cadr y
                 else x:=prepstructk(prepsq!*(prepstructf x ./ 1),
                                     prepstructvar(),x)
            else if not atom x and not atomlis cdr x
                 then if y := assoc(x,!*varlis)
                      then x := cadr y
                      else x := prepstructk(x,prepstructvar(),x);
            return x .** ldeg u .* prepstructf lc u .+ prepstructf red u
          end;

symbolic procedure prepstructk(u,id,v);
begin
  scalar x;
  if x := prepsubchk1(u,!*varlis,id)
     then rplacd(x,(v . id . u) . cdr x)
     else if x := prepsubchk2(u,!*varlis)
             then !*varlis := (v . id . x) . !*varlis
             else !*varlis := (v . id . u) . !*varlis;
  return id
end;

symbolic procedure prepsubchk1(u,v,id);
   begin scalar w;
      while v do
       <>;
         v := cdr v>>;
      return w
   end;

symbolic procedure prepsubchk2(u,v);
   begin scalar bool;
      for each x in v do
       smember(cddr x,u)
          and <>;
      if bool then return u else return nil
   end;

symbolic procedure prepstructvar;
   begin
      countr := countr + 1;
      return if arrayp svar then list(svar,countr)
       else compress append(explode svar,explode countr)
   end;

symbolic procedure remredundancy setqlist;
% -------------------------------------------------------------------- ;
% This function is used for backsubstitution of values of identifiers  ;
% in rhs's if the corresponding identifier occurs only once in the set ;
% of rhs's. SetqList is thus made shorter if possible.                 ;
% An element of Setqlist has the form (SETQ assname value), where      ;
% assname can be redundant if                                          ;
% Atom(assname) and Letterpart(assname) = svar                         ;
% -------------------------------------------------------------------- ;
begin scalar lsl,lhs,rhs,relevant,j,var,freq,k,firstocc,templist;
 lsl:=length(setqlist);
 lhs:=mkvect(lsl); rhs:=mkvect(lsl); relevant:=mkvect(lsl);
 j:=0; var:=explode(svar);
 foreach item in setqlist do
  <>;
 for j:=1:lsl do
  if getv(relevant,j)
   then
    << var:=getv(lhs,j); freq:=0; k:=j; firstocc:=0;
       while freq=0 and k>;
          if firstocc>0 and freq>0 then firstocc:=0
       >>;
       if firstocc=0
        then templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist
        else  putv(rhs,firstocc,
                            subst(getv(rhs,j),var,getv(rhs,firstocc)))
    >>
    else templist:=list('setq,getv(lhs,j),getv(rhs,j)) . templist;
 return reverse(templist);
end;

symbolic procedure letterparts(name);
   % ----------------------------------------------------------------- ;
   % Eff: The exploded form of the Letterpart of Name returned, i.e.   ;
   % (!a !a) if Name=aa55.                                             ;
   % ----------------------------------------------------------------- ;
   begin scalar letters;
       letters:=reversip explode name;
       while digit car letters do letters:=cdr letters;
       return reversip letters
   end;

symbolic procedure numberofoccs(var,expression);
% -------------------------------------------------------------------- ;
% The number of occurrences of Var in Expression is computed and       ;
% returned.                                                            ;
% -------------------------------------------------------------------- ;
if atom(expression)
 then
  if var=expression then 1 else 0
 else
 (if cdr expression
   then numberofoccs(var,cdr expression)
   else 0)
 +
 (if var=car expression
   then 1
   else
    if not atom car expression
     then numberofoccs(var,car expression)
     else 0);



%-----------------------------------------------------------------------
% Algebraic mode psop-function definition.
%-----------------------------------------------------------------------

symbolic procedure algstructreval u;
% -------------------------------------------------------------------- ;
% Variant of gstructr-command. Accepts list of equations and optionally
% an initial part of a subpart recognizer name.
% -------------------------------------------------------------------- ;
begin scalar algpri,name,period,res; integer nargs;
 nargs:=length u;
 name:= (if nargs=1 and getd('newsym) then fnewsym()
         else if nargs=2 then cadr u
         else '!*!*error!*!*);
 if eq(name,'!*!*error!*!*)
  then rederr("WRONG NUMBER OF ARGUMENTS ALGSTRUCTR")
  else << algpri:=!*algpri; period:=!*period; !*algpri:=!*period:=nil;
          res:=apply('gstructr,list(cdar u,name));
          !*period:=period;
          if (!*algpri:=algpri)
           then return
             algresults1(foreach el in res
                            collect cons(cadr el,caddr el))
           else return res
       >>
end;

put('algstructr,'psopfn,'algstructreval)$

endmodule;
end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/0000755000175000017500000000000011722677366021303 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/eds/prolong.red0000644000175000017500000002150011526203062023431 0ustar  giovannigiovannimodule prolong;

% Prolonged systems, tableaux

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
        !*solveinconsistent depl!* !*edssloppy pullback_maps);


% Grassmann bundle variety


put('grassmann_variety,'rtypefn,'getrtypecar);
put('grassmann_variety,'edsfn,'grassmannvariety);
flag('(grassmannvariety grassmannvarietysolution
       grassmannvarietytorsion),'hidden);

symbolic procedure grassmannvariety s;
   % s:eds -> grassmannvariety:eds
   % Reduced Grassmann contact system together with Grassmann variety
   % conditions as one system with 0-forms
   begin scalar p,g,s0,v;
   if g := geteds(s,'grassmannvariety) then return g;
   s0 := closure s;
   g := gbsys s0;
   p := solvedpart pfaffpart eds_sys s0;
   % reduction in next lines ok since lpows g = prlkrns s0
   foreach f in setdiff(eds_sys s0,p) do
      v := union(foreach q in xcoeffs xreduce(f,eds_sys g) collect
                    1 .* q .+ nil,v);
   g := augmentsys(g,append(v,p));
   puteds(s,'grassmannvariety,g);
   return g;
   end;


% Prolongation


put('prolong,'rtypefn,'quoteeds);
put('prolong,'edsfn,'prolongeds);


symbolic procedure prolongeds s;
   % s:eds -> prolongeds:xeds
   begin
   pullback_maps := makelist {};
   return
      if not edsp s  then typerr(s,'eds)
      else mkxeds makelist
               foreach x in prolong s join
            if cdr x then {cdr x};
   end;


symbolic procedure prolong s;
   % s:eds -> prolong:list of tag.eds
   % where tag is one of
   %       prolonged       s was prolonged
   %       reduced         s was reduced
   %    failed          couldn't solve Grassmann variety conditions (eds
   %                    is {Grassmann system with variety conditions})
   %    inconsistent    prolongation is inconsistent
   % eds_ind s is preserved by prolong. Note the
   % heuristic to eliminate independent variables is incomplete.
   begin scalar g,v,s1;
   g := copyeds grassmannvariety s;
   updkordl edscob g;
   eds_sys g := setdiff(eds_sys g,scalarpart eds_sys g);
   v := decomposegrassmannvariety s;
   return if null v then
   << edsverbose("Prolongation inconsistent",nil,nil);
      eds_sys g := {!*k2pf 1};
      {'inconsistent . g} >>
   else foreach strata in v join
      if car strata = 'failed then
      << edsverbose("Prolongation failed - solution variety:",
                    cdr strata,'sq);
         {'failed .
            augmentsys(g,foreach q in cdr strata collect 1 .* q .+ nil)}
       >>
      else if car strata = 'base then
      << edsverbose("Reduction using new equations:",cdr strata,'rmap);
         pullback_maps := append(pullback_maps,{!*rmap2a cdr strata});
         s1 := edscall pullback0(s,cdr strata);
          if scalarpart eds_sys s1 then
            s1 := edscall positiveeds s1;
         if emptyedsp s1 then {'inconsistent . s1}
         else if edsp s1 then {'reduced . s1}
         else foreach s2 in getrlist s1 collect 'reduced . s2 >>
      else if car strata = 'fibre then
      << if cadr strata then
            edsverbose("Prolongation using new equations:",
                       cdr strata,'rmap)
         else
            edsverbose("Prolongation (no new equations)",nil,nil);
         pullback_maps := append(pullback_maps,{!*rmap2a cdr strata});
               s1 := edscall pullback0(g,cdr strata);
         {'prolonged . s1} >>;
   end;


symbolic procedure decomposegrassmannvariety s;
   % s:eds -> decomposegrassmannvariety:list of tag.value
   % where tag.value is one of
   %       'fibre.rmap             s can be prolonged
   %       'base.rmap              s must be reduced
   %    'failed . list of sq    couldn't solve Grassmann variety
   %                            conditions
   %    'inconsistent.nil      Grassmann variety empty
   begin scalar g,v,c,b;
   g := grassmannvariety s;
   c := reverse setdiff(edscrd g,edsindcrd g);
   c := edsgradecoords(c,geteds(g,'jet0));
   % Allow for case where g has no fibre coordinates (s has finite type)
   if null setdiff(edscrd g,edscrd s) then c := {} . c;
   if semilinearp s then
      if v := grassmannvarietytorsion s then
         if null(v := edssolvegraded(v,cdr c,cfrm_rsx eds_cfrm s))
         then return {'inconsistent . nil}
         else return foreach m in v collect
            if car m then 'base . cdr m
            else 'failed . cdr m
      else if v := partsolvegrassmannvariety s then return
               {'fibre . !*map2rmap
            foreach x in car v join if not(car x memq cadr v) then
               {car x . mk!*sq subsq(simp!* cdr x,caddr v)}}
      else errdhh "Bad solution to semilinear system"
   else % not semilinearp s
   << v := foreach f in scalarpart eds_sys g collect lc f;
      if null(v := edssolvegraded(v,c,cfrm_rsx eds_cfrm s))
      then return {'inconsistent . nil}
      else return foreach m in v collect
         if null car m then 'failed . cdr m
         else if (b := foreach s in cadr m join
                                       if not memq(car s,car c) then {s}) then
            'base . {b,for each p in caddr m
                          join if freeofl(p,car c) then {p}}
         else 'fibre . cdr m; >>;
   end;


% Special routines for semilinear systems


symbolic procedure partsolvegrassmannvariety s;
   % s:eds -> partsolvegrassmannvariety:{map,list of kernel,map}
   % Partly solves the variety equations for a linear system s.
   % The "solution" is returned as from edspartsolve.
   begin scalar v,c;
   if v := geteds(s,'grassmannvarietysolution) then return v;
   v := grassmannvariety s;
   c := reverse setdiff(edscrd v,edscrd s);
   v := foreach f in scalarpart eds_sys v collect lc f;
   v := edspartsolve(v,c);
   puteds(s,'grassmannvarietysolution,v);
   return v;
   end;


put('dim_grassmann_variety,'simpfn,'dimgrassmannvarietyeval);

symbolic procedure dimgrassmannvarietyeval u;
   % u:{eds}|{eds,sys} -> dimgrassmannvarietyeval:sq
   if length u < 1 or length u > 2 then
      rerror(eds,000,
             "Wrong number of arguments to dim_grassmann_variety")
   else if edsp car(u := revlis u) then
      edscall dimgrassmannvariety(car u,if cdr u then !*a2sys cadr u)
         ./ 1
   else typerr(car u,"EDS");


symbolic procedure dimgrassmannvariety(s,x);
   % s:eds, x:sys -> dimgrassmannvariety:int
   begin scalar v,c;
   if not quasilinearp s then
      if null x then
               rerror(eds,000,"Integral element required for nonlinear EDS")
      else
               s := linearise(s,x);
   v := grassmannvariety s;
   c := length setdiff(edscrd v,edscrd s);
   % Treat quasilinear and semilinear systems the same
   % Will storing the solution etc cause trouble for q-l. s?
   v := partsolvegrassmannvariety s;
   c := c - foreach x in car v sum
                     if car x memq cadr v then 0 else 1;
   return c;
   end;


put('torsion,'rtypefn,'quotelist);
put('torsion,'listfn,'torsioneval);

symbolic procedure torsioneval(u,v);
   % u:{eds}, v:bool -> torsioneval:rlist
   if not edscall semilinearp(u := reval car u) then
      rerror(eds,000,"TORSION available for semi-linear systems only")
   else
      makelist for each q in edscall grassmannvarietytorsion u
                  collect !*q2a1(q,v);


symbolic procedure grassmannvarietytorsion s;
   % s:eds -> grassmannvarietytorsion:list of sf
   begin scalar v;
   if v := geteds(s,'grassmannvarietytorsion) then return v;
   v := partsolvegrassmannvariety s;
   v := foreach x in car v join
                 if car x memq cadr v and numr
                 << x := addsq(negsq !*k2q car x,simp!* cdr x);
              x := subsq(x,caddr v) >>
                 then {x};
   puteds(s,'grassmannvarietytorsion,v);
   return v;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/systems.red0000644000175000017500000004063511526203062023472 0ustar  giovannigiovannimodule systems;

% Operations on exterior differential systems

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(kord!* xtruncate!* !*arbvars !*edssloppy cfrmcob!*);
global '(indxl!*);


symbolic procedure copyeds s;
   % s:eds -> copyeds:eds
   % Copy s to allow destructive operations using selectors
   append(s,{});



put('augment,'rtypefn,'getrtypecar);
put('augment,'edsfn,'augmenteds);

symbolic procedure augmenteds(s,u);
   % s:eds, u:prefix sys -> augmenteds:eds
   begin
   u := makelist getrlist u;
   u := !*a2sys u;
   s := augmentsys(s,u);
   foreach f in {'pfaffian,'closed,'quasilinear,'involutive} do
      rempropeds(s,f);
   return checkeds s; % removes all hidden flags, adds new rsx
   end;


symbolic procedure augmentsys(s,u);
   % s:eds, u:sys -> augmentsys:eds
   % Augment system by adding new forms, using ordering of s on input in
   % final sort. Doesn't change flags or check integrity.
   begin scalar c;
   s := copyeds s;
   eds_sys s := sortsys(union(u,eds_sys s),edscob s);
   return s;
   end;


put('quasilinear,'psopfn,'quasilineareval);

symbolic procedure quasilineareval s;
   % s:{eds} -> quasilineareval:0 or 1
   if edsp(s := reval car s) then
      if knowntrueeds(s,'quasilinear) or
               not knownfalseeds(s,'quasilinear) and
               edscall quasilinearp s then 1 else 0
   else typerr(s,'eds);


symbolic procedure quasilinearp s;
   % s:eds -> quasilinearp:bool
   % Test whether (closure of) system is quasilinear
   knowntrueeds(s,'quasilinear) or
      not knownfalseeds(s,'quasilinear) and
      if not normaledsp s then
               rerror(eds,000,{"System not in normal form in quasilinearp"})
      else if null scalarpart eds_sys s and
              quasilinearsys(nonpfaffpart eds_sys closure s,prlkrns s)
       then << flagtrueeds(s,'quasilinear); t >>
      else
            << flagfalseeds(s,'quasilinear); nil >>;


symbolic procedure quasilinearsys(s,prl);
   % s:sys, prl:list of 1-form kernel -> quasilinearsys:bool
   % Systems with 0-forms are non-linear by definition here.
   null cadr lineargens(s,{},prl);


symbolic procedure lineargenerators s;
   % s:eds -> lineargenerators:eds
   % Makes linearly generated part of s explicitly linear.
   begin scalar p;
   p := pfaffpart eds_sys s;
   p := append(p,append(car q,cadr q))
                 where q = lineargens(setdiff(eds_sys s,p),{},prlkrns s);
   if p = eds_sys s then return s;
   s := copyeds s;
   eds_sys s := p;
   return sorteds s;
   end;


symbolic procedure lineargens(s,g,prl);
   % s,g:sys, prl:list of 1-form kernel -> lineargens:{sys,sys}
   % g is a GB for a linear system, s is fully reduced wrt g. Returns as
   % linear a set of generators as possible.  For a linear system,
   % returns a linear set of generators.  Recursively checks if
   % non-linear part of s can be reduced mod linear part + g to give a
   % linear system.  Systems with 0-forms are non-linear by definition
   % here.
   begin scalar w,xtruncate!*; integer d;
   foreach f in s do
   << d := max(d,degreepf f);
      if degreepf f neq 0 and quasilinearpf(f,prl) then
          w := f . w >>;
   w := reversip w;
   s := setdiff(s,w);
   if null s then return {w,{}};
   if null w then return {{},s};
   xtruncate!* := d;
   g := xidealpf append(g,w);
   s := foreach f in s join
           if f := xreduce(f,g) then {f};
   return {append(w,car p),cadr p} where p = lineargens(s,g,prl);
   end;


symbolic procedure quasilinearpf(f,p);
   % f:pf, p:list of 1-form kernel -> quasilinearpf:bool
   % result is t if f is at most linear in p
   if null f then t
   else length intersection(wedgefax lpow f,p) <= 1
        and quasilinearpf(red f,p);


put('semilinear,'psopfn,'semilineareval);

symbolic procedure semilineareval s;
   % s:{eds} -> semilineareval:0 or 1
   if edsp(s := reval car s) then
      if edscall semilinearp s then 1 else 0
   else typerr(s,'eds);


symbolic procedure semilinearp s;
   % s:eds -> semilinearp:bool
   % Test whether (closure of) system is semilinear
   if not normaledsp s then nil
   else if !*edssloppy then edscall quasilinearp s
   else semilinearsys(nonpfaffpart eds_sys edscall closure s,prlkrns s);


symbolic procedure semilinearsys(s,prl);
   % s:sys, prl:list of 1-form kernel -> semilinearsys:bool
   % 0-forms are non-linear by definition here.
   null s or
      degreepf car s neq 0 and
      semilinearpf(car s,prl) and
      semilinearsys(cdr s,prl);


symbolic procedure semilinearpf(f,p);
   % f:pf, p:list of 1-form kernel -> semilinearpf:bool
   % Works when xvars!* allows 0-forms as well - used in solvegraded.
   % result is t if f is at most linear in p with constant coefficient
   null f or
      (l = 0 or
                l = 1 and
          cfrmconstant numr lc f and
          cfrmconstant denr lc f
            where l = length foreach k in wedgefax lpow f join
                                                   if k memq p then {k}) and
      semilinearpf(red f,p);


put('pfaffian,'psopfn,'pfaffianeval);

symbolic procedure pfaffianeval s;
   % s:{eds} -> pfaffianeval:0 or 1
   if edsp(s := reval car s) then
      if knowntrueeds(s,'pfaffian) or
               not knownfalseeds(s,'pfaffian) and
               edscall pfaffian s then 1 else 0
   else typerr(s,'eds);


symbolic procedure pfaffian s;
   % s:eds -> pfaffian:bool
   knowntrueeds(s,'pfaffian) or
      not knownfalseeds(s,'pfaffian) and
      if not normaledsp s then
               rerror(eds,000,{"System not in normal form in pfaffian"})
      else if pfaffsys eds_sys s then
      << flagtrueeds(s,'pfaffian); t>>
      else
      << flagfalseeds(s,'pfaffian); nil>>;


symbolic procedure pfaffsys s;
   % s:sys -> pfaffsys:bool
   % Systems with 0-forms are non-Pfaffian by definition here.
   begin scalar p,xtruncate!*; integer d;
   if scalarpart s then return nil;
   foreach f in s do
   << d := max(d,degreepf f);
      if degreepf f = 1 then p := f . p >>;
   s := setdiff(s,p);
   if null s then return t;
   if null p then return nil;
   xtruncate!* := d;
   p := xidealpf foreach f in p collect xreduce(exdfpf f,p);
   while s and null xreduce(car s,p) do s := cdr s;
   return null s;
   end;


put('closure,'edsfn,'closure);
put('closure,'rtypefn,'getrtypecar);

symbolic procedure closure s;
   % s:eds -> closure:eds
   begin scalar p,sys,s0; integer d;
   if knowntrueeds(s,'closed) then return s;
   if s0 := geteds(s,'closure) then return s0;
%%%   if not normaledsp s then
%%%      rerror(eds,000,{"System not in normal form in closure"});
%%%   if scalarpart eds_sys s then
%%%      rerror(eds,000,{"Closure with 0-forms not yet implemented"});
   if scalarpart eds_sys s then
      lprim {"0-forms in closure: result may not be closed"};
   d := length eds_ind s;
   p := solvedpart eds_sys s;
   sys := foreach f in eds_sys s join
             if degreepf f < d and
                (f := xreduce(xreorder exdfpf f,p)) then {f};
   if null sys then return <>;
   s0 := augmentsys(s,sys);
   if pfaffpart sys then rempropeds(s0,'solved);
   flagtrueeds(s0,'closed);
   s0 := normaleds s0;        % might add 0-forms or become inconsistent
   return if emptyedsp s0 then s0
      else if scalarpart eds_sys s0 then s0
      else <>;
   end;

flag('(closure),'hidden);


% symbolic operator closed;
% symbolic procedure closed u;
%    % u:eds|rlist of prefix|prefix -> closed:bool
%    % True if u is a closed eds, a closed system of forms or a closed
%    % form
%    if edsp u then
%       knowntrueeds(u,'closed) or edscall closededs u
%    else if rlistp u then
%       closedsys foreach f in getrlist u collect xpartitop f
%    else null exdfpf xpartitop u;

% flag('(closed),'boolean);

% symbolic procedure closededs s;
%    % s:eds -> closededs:bool
%    knowntrueeds(s,'closed) or
%    if closedsys eds_sys s then
%    << flagtrueeds(s,'closed); t>>;



put('closed,'psopfn,'closedeval);

symbolic procedure closedeval s;
   % s:{eds} -> closedeval:0 or 1
   if edsp(s := reval car s) then
      if knowntrueeds(s,'closed) or
               not knownfalseeds(s,'closed) and
         edscall closed s then 1 else 0
   else if rlistp s then
      if closedsys foreach f in getrlist s collect xpartitop f then 1
      else 0
   else if null exdfpf xpartitop s then 1 else 0;


symbolic procedure closed s;
   % s:eds -> closed:bool
   knowntrueeds(s,'closed) or
      not knownfalseeds(s,'closed) and
      if closedsys eds_sys s then
      << flagtrueeds(s,'closed); t>>
      else
      << flagfalseeds(s,'closed); nil>>;


symbolic procedure closedsys s;
   % s:sys -> closedsys:bool
   begin scalar p,xtruncate!*; integer d;
   foreach f in s do
   << d := max(d,1 + degreepf f);
      f := xreduce(exdfpf f,s);
      if f then p := f . p >>;
   if null p then return t;
   xtruncate!* := d;
   s := xidealpf s;
   while p and null xreduce(car p,s) do p := cdr p;
   return null p;
   end;


symbolic operator frobenius;
symbolic procedure frobenius u;
   % u:eds|rlist of prefix|prefix -> frobenius:bool
   % True if u is an eds or list of forms generated by 1-forms
   % satisfying the Frobenius test
   if edsp u then
      null nonpfaffpart eds_sys u and
      null nonpfaffpart eds_sys edscall closure u
   else if rlistp u then
      frobeniussys foreach f in getrlist u collect xpartitop f
   else rerror(eds,000,"Invalid argument to frobenius");

flag('(frobenius),'boolean);


symbolic procedure frobeniussys s;
   % s:sys -> frobeniussys:bool
   begin scalar p;
   p := pfaffpart s;
   s := union(foreach f in p collect exdfpf f,setdiff(s,p));
   p := xautoreduce p;
   while s and null xreduce(car s,p) do s := cdr s;
   return null s;
   end;


put('cauchy_system,'rtypefn,'quotelist);
put('cauchy_system,'listfn,'evalcauchysys);

symbolic procedure evalcauchysys(u,v);
   % u:{prefix}, v:bool -> evalcauchysys:rlist
   if xedsp(u := reval car u) then
      evalcartansys({edscall closure u},v)
   else if rlistp u then
      evalcartansys({append(u,foreach f in cdr u collect aeval{'d,f})},v)
   else
      evalcartansys({makelist {u,aeval{'d,u}}},v);


put('cartan_system,'rtypefn,'quotelist);
put('cartan_system,'listfn,'evalcartansys);

symbolic procedure evalcartansys(u,v);
   % u:{prefix}, v:bool -> evalcartansys:rlist
   if xedsp(u := reval car u) then
      if edsp u then !*sys2a1(edscall cartansyseds u,v)
      else makelist for each s in cdr u
                       collect !*sys2a1(edscall cartansyseds u,v)
   else if rlistp u then
      !*sys2a1(cartansys !*a2sys u,v)
   else
      !*sys2a1(cartansyspf xpartitop u,v);


symbolic procedure cartansys u;
   % u:list of pf -> cartansys:list of pf
   begin scalar xtruncate!*;
   xtruncate!* := eval('max.foreach f in u collect degreepf f);
   xtruncate!* := xtruncate!* - 1;
   u := xidealpf u;
   return reversip xautoreduce purge foreach f in u join cartansyspf f;
   end;


symbolic procedure cartansyspf f;
   % f:pf -> cartansyspf:list of pf
   begin scalar x,p,q,z;
   if degreepf f = 1 then return {f};
   while f do
      begin
      p := wedgefax lpow f;
      foreach k in p do
         if not((q := delete(k,p)) member z) then
         << z := q . z;
            x := xcoeff(f,q) . x >>;
      f := red f;
      end;
   return reverse xautoreduce purge x;
   end;


symbolic procedure cartansyseds s;
   % s:eds -> cartansyseds:sys
   cartansys eds_sys s;


put('linearise,'edsfn,'lineariseeds);
put('linearise,'rtypefn,'quoteeds);
put('linearize,'edsfn,'lineariseeds);
put('linearize,'rtypefn,'quoteeds);
flag('(linearise linearize),'nospread);

symbolic procedure lineariseeds u;
   % u:{eds[,rlist]} -> lineariseeds:eds
   begin scalar x;
   if null u or length u > 2 then
      rerror(eds,000,{"Wrong number of arguments to linearise"});
   if cdr u then x := !*a2sys cadr u;
   if nonpfaffpart x then typerr(cadr u,"integral element");
   return edscall linearise(car u,x);
   end;


symbolic procedure linearise(s,x);
   % s:eds, x:sys -> linearise:eds
   % x is an integral element of s, result is linearisation of s at x
   % in original cobasis.
   if quasilinearp s then lineargenerators s else
   begin scalar xx,q,prl;
   s := copyeds closure s;
   x := xreordersys x;
   q := nonpfaffpart eds_sys s;
   prl := prlkrns s;
   % pick out those products which occur
   xx := purge foreach f in q join
                  foreach k in xpows f join
               nonlinfax intersection(wedgefax k,prl);
   % form the relevant poducts from x
   x := pair(lpows x,x);
   xx := foreach pr in xx collect
                  wedgepf(cdr atsoc(car pr,x),cdr atsoc(cadr pr,x));
   % reduce the system mod x^x
   eds_sys s := append(setdiff(eds_sys s,q),
                      foreach f in q join if f := xreduce(f,xx) then {f});
   flagtrueeds(s,'quasilinear);
   return s;
   end;


symbolic procedure nonlinfax l;
   % l:list of kernel -> nonlinfax:list of list of 2 kernel
   % Collect elements of l pairwise, discarding any odd element.
   if length l > 1 then {car l,cadr l} . nonlinfax cddr l;

%% symbolic procedure linearise(s,x);
%%    % s:eds, x:sys -> linearise:eds
%%    % x is an integral element of s, result is linearisation of s at x
%%    % in original cobasis.
%%    % NB Changes background coframing.
%%    if quasilinearp s then lineargenerators s else
%%    begin scalar s1;
%%    s1 := linearise0(s,x);
%%    x := cadr s1;
%%    s1 := car s1;
%%    return xformeds0(s1,x,setdiff(edscob s,edscob s1));
%%    end;
%%
%%
%% symbolic procedure linearise0(s,x);
%%    % s:eds, x:sys -> linearise0:{eds,xform}
%%    % x is an integral element of s, result is linearisation of s at x
%%    % in a cobasis based on x, together with transform required for
%%    % original cobasis. The structure equations are NOT updated.
%%    % NB Changes background coframing.
%%    begin scalar c,y,prl;
%%    c := foreach f in x collect mkform!*(intern gensym(),1);
%%    x := pair(c,x);
%%    y := invxform x;
%%    s := copyeds closure s;
%%    s := tmpind xformeds0(s,y,c);
%%    x := append(x,cadr s);
%%    s := car s;
%%    prl := prlkrns s;
%%    eds_sys s := foreach f in eds_sys s join
%%                               if degreepf f < 2 then {f}
%%                  else if inhomogeneouspart(f,prl) then
%%                     typerr(!*sys2a foreach p in x collect cdr p,
%%                            "integral element")
%%                  else if f := linearpart(f,prl) then {f};
%%    flagtrueeds(s,'quasilinear);
%%    return {s,x};
%%    end;


put('one_forms,'rtypefn,'quotelist);
put('one_forms,'listfn,'oneformseval);

symbolic procedure oneformseval(u,v);
   % u:{xeds|rlist}, v:bool -> oneformseds:rlist
   if edsp(u := reval car u) then
      !*sys2a1(pfaffpart eds_sys u,v)
   else if xedsp u then
      makelist foreach s in getrlist u collect
         !*sys2a1(pfaffpart eds_sys s,v)
   else
      makelist foreach f in getrlist u join
         if reval{'exdegree,f}=1 then {f};


put('zero_forms,'rtypefn,'quotelist);
put('zero_forms,'listfn,'zeroformseval);
put('nought_forms,'rtypefn,'quotelist);
put('nought_forms,'listfn,'zeroformseval);

symbolic procedure zeroformseval(u,v);
   % u:{xeds|rlist}, v:bool -> zeroformseval:rlist
   if edsp(u := reval car u) then
      !*sys2a1(scalarpart eds_sys u,v)
   else if xedsp u then
      makelist foreach s in getrlist u collect
         !*sys2a1(scalarpart eds_sys s,v)
   else
      makelist foreach f in getrlist u join
         if reval{'exdegree,f}=0 then {f};

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/element.red0000644000175000017500000000724711526203062023416 0ustar  giovannigiovannimodule element;

% Generate a random integral element

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. At present, the Cartan-Kaehler construction is used, as by
Wahlquist, to reduce the problem to linear algebra. This fails for
non-involutive systems.

endcomment;


put('integral_element,'rtypefn,'quotelist);
put('integral_element,'listfn,'intelteval);

symbolic procedure intelteval(u,v);
   % u:{eds}, v:bool -> intelteval:list of prefix
   if length u neq 1 then
      rerror(eds,000,"Wrong number of arguments to integral_element")
   else if not edsp(u := reval car u) then typerr(u,"EDS")
   else !*sys2a1(edscall intelt u,v);


symbolic procedure intelt s;
   % s:eds -> intelt:sys
   % Produce an arbitrary integral element of s using the Cartan-Kaehler
   % construction.
   begin scalar g,v,a,h,z;
   s := closure s;
   g := gbsys s;
   % reduction in next lines ok since lpows g = prlkrns s
   v := foreach f in nonpfaffpart eds_sys s join
                 if f := xreduce(f,eds_sys g) then {f};
   % get polar systems
   h := reversip foreach w on reverse indkrns s collect
           foreach f in v join
              foreach c in ordcomb(cdr w,degreepf f - 1) join
                 if c := xcoeff(f,car w . c) then {lc c};
   % get graded variable list
   a := v := {};
   foreach w in indkrns s do
   << v := setdiff(foreach f in eds_sys g collect
                    mvar numr lc xcoeff(f,{w}),a) . v;
      a := append(car v,a) >>;
   v := reverse v;
   % solve polar systems
   foreach x in pair(h,v) do
   << v := cdr x;
      x := foreach f in car x join if numr(f := subsq(f,z)) then {f};
      edsdebug("Polar system",x,'sq);
      z := append(edsransolve(x,v),z) >>;
   return foreach f in eds_sys g collect pullbackpf(f,z);
   end;


symbolic procedure edsransolve(x,v);
   % x:list of sq, v:list of kernel -> edsransolve:map
   begin
   x := edssolve(x,v);
   if null x then
      rerror(eds,000,"Singular system in integral_element");
   if length x > 1 or null caar x then
      rerror(eds,000,"Bad system in integral_element");
   x := car cdr car x; % get the map part of first solution
   v := setdiff(v,foreach m in x collect car m);
   edsverbose({length v,"free variables"},nil,nil);
   v := foreach c in v collect c . sparserandom 5;
   x := nconc(pullbackmap(x,v),v);
   edsdebug("Solution",x,'map);
   return x;
   end;


symbolic procedure sparserandom n;
   if random 100 < 0 then 0 else random(2*n+1)-n;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edssolve.red0000644000175000017500000003573211526203062023611 0ustar  giovannigiovannimodule edssolve;

% Specialised solvers for EDS

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. The EDS solve routines are interfaces to the general REDUCE
solver, presenting the results in a form more useful in EDS. The most
primitive is edssolve, which basically just turns off arbvars and
reorganises the answer, and the most sophisticated is edssolvegraded,
which tries to solve the principal part first if the equations are
semilinear. This is useful since the principal part is often less
complex than the rest. Solutions are returned as rmaps, giving
information about both the solution and its applicability.

endcomment;


fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
        !*solveinconsistent depl!* cfrmcrd!* cfrmrsx!* xvars!*
        !*edssloppy !*edsdisjoint);


symbolic procedure edssolvegraded(xl,vl,rsx);
   % xl:list of sq, vl:list of list of kernel, rsx:rsx
   % -> edssolvegraded:list of (t.rmap)|(nil.list of sq)
   (begin scalar fl,z;
   z := foreach l in vl join append(l,{});
   if vl and semilinearsql(xl,car vl,if !*edssloppy then car vl else z)
     then return edssolvesemi(xl,vl,rsx);
   foreach l on vl do
      foreach y in car l do foreach ll in cdr l do
          foreach x in ll do depend1(y,x,t);
   xl := edssolve(xl,z);
   fl := {};
   xl := foreach s in xl join
      if null car s  then <>
      else if not member(0,z := pullbackrsx(rsx,cadr s)) then
          {{cadr s,purgersx append(z,caddr s)}};
   return append(reverse fl,foreach s in edsdisjoin xl collect t . s);
   end) where depl!* = depl!* ;


symbolic procedure semilinearsql(xl,vl,kl);
   % xl:list of sq, vl,kl:list of kernel -> semilinearsql:bool
   null xl
      or semilinearsq(car xl,vl,kl) and semilinearsql(cdr xl,vl,kl);


symbolic procedure semilinearsq(x,vl,kl);
   % x:sq, vl,kl:list of kernel -> semilinearsq:bool
   % True if x is linear in vl with coefficients independent of kl.
   % Assumes that kl includes vl.
   semilinearpf0(xpartitsq x,vl,kl) where xvars!* = vl;


symbolic procedure semilinearpf0(f,vl,kl);
   % f:pf, vl,kl:list of kernel  -> semilinearpf0:bool
   % Works when xvars!* allows 0-forms as well - used in solvegraded.
   % True if x is linear in vl with coefficients independent of kl.
   % Assumes that kl includes vl.
   null f or
      (lpow f = 1 and
       freeoffl(denr lc f,vl) and   % because vl might occur inside
                                    % operators
       freeoffl(numr lc f,vl)
                 or
       length wedgefax lpow f = 1 and
       freeoffl(denr lc f,kl) and   % because vl might occur inside
                                    % operators
       freeoffl(numr lc f,kl)) and
      semilinearpf0(red f,vl,kl);


symbolic procedure edssolvesemi(xl,vl,rsx);
   % xl:list of sq, vl:list of list of kernel, rsx:rsx
   % -> edssolvesemi:list of (t.rmap)|(nil.list of sq)
   % xl is known to be semilinear
   begin scalar sl,nl;
   xl := edspartsolve(xl,car vl);
   foreach x in car xl do
      if not(car x memq cadr xl) then
         sl := (car x . mk!*sq subs2 subsq(simp!* cdr x,caddr xl)) . sl
      else if numr
      << x := addsq(negsq !*k2q car x,simp!* cdr x);
         x := subs2 subsq(x,caddr xl) >>
      then nl := x . nl;
   sl := !*map2rmap reversip sl;
   if 0 member (rsx := pullbackrsx(rsx,car sl)) then return nil;
   rsx := purgersx append(rsx,cadr sl); sl := car sl;
   if null nl then return {t . {sl,rsx}};
   xl := edssolvegraded(nl,cdr vl,rsx);
   return foreach s in xl collect
      if null car s then
         nil . append(cdr s,foreach x in sl collect
                                             addsq(negsq !*k2q car x,simp!* cdr x))
      else
         t . {append(pullbackmap(sl,cadr s),cadr s),caddr s};
   end;


symbolic procedure edssolve(xl,vl);
   % xl:list of sq, vl:list of kernel -> edssolve: list of tag.value
   % where tag.value is one of
   %        t.rmap          an explicit solution
   %        nil.list of sq    a (partial) system which couldn't be solved
   % This is an interface to the REDUCE solve routines, for use by other
   % eds routines. It switches off arbvars and returns the result in a
   % form more easily used in eds. If the system is inconsistent, an
   % empty list {} is returned.
   begin scalar kl,sl,msg;
         scalar !*arbvars;  % stop arbcomplex's being generated
   msg := {"Solving",length xl,"equations in",length vl,"variables"};
   foreach q in xl do kl := union(kernels numr q,kl);
   kl := expanddependence kl;
   vl := intersection(vl,kl);        % must preserve order of vl
   msg := append(msg,{{length vl,"present"}}); % {a,b} prints as (a b)
   edsdebug(msg,nil,nil);
   sl := edssolvesys(foreach q in xl collect numr q,vl);
   if eqcar(sl,'inconsistent) then
      sl := {}
   else if eqcar(sl,'failed) or eqcar(sl,nil) then
      sl := {nil . xl}
   else if eqcar(sl,t) then
      sl := foreach s in cdr sl join
               if not explicitsolutionp s then
            {nil . foreach pr in pair(cadr s,car s) collect
               addsq(negsq !*k2q car pr,cdr pr)}
               else % need to reorder return value from edssolvesys!
            {t . !*map2rmap pair(cadr s,for each q in car s
                                           collect mk!*sq reordsq q)}
   else errdhh{"Unexpected result from solvesys:",sl};
   return sl;
   end;


symbolic procedure expanddependence kl;
   % kl: list of kernel -> expanddependence:list of kernel
   % expand kl recursively to include all kernels explicitly appearing
   % as operator arguments. Should we check implicit dependence also?
   if null kl then nil
   else if atomf car kl then
      car kl . expanddependence cdr kl
   else % must be operator, so add all arguments to list
      car kl . expanddependence append(cdar kl,cdr kl);


symbolic procedure edssolvesys(xl,vl);
   % xl:list of sf, vl:list of kernel -> edssolvesys: list of tag.value
   % where tag.value is given in solve.red. This just calls solvesys.
   solvesys(xl,vl);


symbolic procedure explicitsolutionp s;
   % s:solve solution -> explicitsolutionp:bool
   not smember('root_of,s) and not smember('one_of,s);


symbolic procedure edspartsolve(xl,vl);
   % x:list of sq,
   % vl:list of kernel -> edspartsolve:{map,list of kernel,map}
   % Solves the equations xl for the variables vl by splitting into
   % homogeneous and inhomogeneous parts.  The results are only
   % guaranteed for linear equations whose coefficient are independent
   % of the inhomogeneous parts.  The solution is returned in terms of
   % some temporary variables representing the inhomogeneous parts.
   % The temporary variables are given in the original variables by the
   % third return value.
   (begin scalar al,il,l;
%        scalar depl!*;       % preserve dependencies
   xl := splitlinearequations(xl,vl);
   xl := foreach p in xl collect
                  if null numr cdr p then
               car p
            else if (l := mk!*sq cdr p member il) then
               addsq(car p,!*k2q nth(al,1 + length il - length l))
            else
            << al := intern gensym() . al;
               il := mk!*sq cdr p . il;
               addsq(car p,!*k2q car al) >>;
   al := reversip al; il := reversip il;
   foreach y in vl do
      foreach z in al do depend1(y,z,t);
   xl := edssolve(xl,append(vl,al));
   if length xl neq 1 or null car(xl := car xl) then
      errdhh{"Bad solution in edspartsolve",xl};
   return {cadr xl,al,pair(al,il)};
   end) where depl!* = depl!*;     % preserve dependencies


symbolic procedure splitlinearequations(v,c);
   % v:list of sq, c:list of kernel
   % -> splitlinearequations:{list of sq.sq}
   % Splits rational expressions in v into homogeneous and
   % inhomogeneous parts wrt variables in c.
   begin scalar ok,g,h;
         scalar !*exp;
   !*exp := t;
   ok := setkorder c;
   v := foreach q in v collect
        << g := h := nil;
                 while not domainp f and mvar f memq c do
                    << g := lt f . g; f := red f >>;
           foreach u in g do h := u .+ h;
                 cancel(h ./ d) . cancel(f ./ d) >>
         where f = reorder numr q,
               d = reorder denr q;
   setkorder ok;
   return foreach p in v collect reordsq car p . reordsq cdr p;
   end;


symbolic procedure edsgradecoords(crd,jet0);
   % crd,jet0:list of kernel -> edsgradecoords:list of list of kernel
   % grade coordinates according to jet order, highest jet first
   if null jet0 then {crd}
   else
      begin scalar u;
      foreach c in crd do
         begin scalar j0,c0;
         j0 := jet0;
         while j0 and null(c0 := splitoffindices(car j0,c)) do
            j0 := cdr j0;
         if j0 := assoc(length c0,u) then nconc(j0,{c})
         else u := (length c0 . {c}) . u;
         end;
      u := sort(u,function(lambda x,y; car x > car y));
      return foreach v in u collect cdr v;
      end;



Comment. The routine solvepfsys tries to bring a system into solved form
in the current environment specified by cfrmcrd!* and cfrmrsx!*.

endcomment;

symbolic procedure solvepfsys sys;
   % sys:sys -> solvepfsys:{sys,sys}
   % Bring sys into solved form as far as possible.
   solvepfsys1(sys,{});

symbolic procedure solvepfsys1(sys,vars);
   % sys:sys, vars:list of lpow pf -> solvepfsys1:{sys,sys}
   % Solve sys for vars. If vars is {} then solve for anything. Kernel
   % ordering changed so that solved set comes ahead of rest. Ordering
   % within solved set and others is unchanged. The solved part is
   % returned sorted in decreasing order of lpow.  NBB. Kernel ordering
   % changed!!
   begin scalar ok,sl,nl;
   % save old kernel ordering
   ok := updkordl nil;
   nl := foreach f in sys collect subs2pf!* f;
   % First try for constant coefficients
   if nl then
      begin
%      nl := solvepfsyseasy(nl,vars,'domainp);
      nl := solvepfsyseasy(nl,vars,'cfrmconstant);
      if car nl then
          edsdebug("Solved with constant coefficients:",car nl,'sys);
      if cadr nl then
          edsdebug("Unsolved with constant coefficients:",cadr nl,'sys);
      sl := append(sl,car nl);
      nl := cadr nl;
      end;
   % If that's not enough, try for nowhere-zero coefficients
   if nl then
      begin
      nl := solvepfsyseasy(nl,vars,'cfrmnowherezero);
      if car nl then
          edsdebug("Solved with nonzero coefficients:",car nl,'sys);
      if cadr nl then
          edsdebug("Unsolved with nonzero coefficients:",cadr nl,'sys);
      sl := append(sl,car nl);
      nl := cadr nl;
      end;
   % If that's not enough, try Cramer's rule.
   if nl then
      begin
      nl := solvepfsyshard(nl,vars);
      if car nl then
          edsdebug("Solved with Cramer's rule:",car nl,'sys);
      if cadr nl then
          edsdebug("Unsolved with Cramer's rule:",cadr nl,'sys);
      sl := append(sl,car nl);
      nl := cadr nl;
      end;
   % Fix up kernel ordering and back-substitute solved forms
   setkorder ok;
   updkordl lpows sl;
   sl := xautoreduce1 xreordersys sl;
   nl := xreordersys nl;
   % Block structure may have messed up order of solved kernels
   sl := sortsys(sl,ok);
   updkordl lpows sl;
   return {sl,nl};
   end;


symbolic procedure solvepfsyseasy(sys,vars,test);
   % sys:sys, vars:list of lpow pf,
   % test:function -> solvepfsyseasy:{sys,sys}
   % Recursively bring sys into weakly solved form as far as possible
   % just by changing kernel ordering and normalising.  The solved part
   % is in normalised upper triangular form, and korder is completely
   % messed up - results must be reordered under lpows solved part.
   begin scalar sl,nl,kl;
   kl := purge foreach f in sys join xsolveables(f,test);
   kl := sort(if vars then intersection(kl,vars) else kl,'termordp);
   if null kl then return {{},sys};
   updkordl kl;
   foreach f in sys do
      if (f := xreduce(xreorder f,sl)) and apply1(test,numr lc f) then
         sl := xnormalise f . sl
      else if f then
         nl := f . nl;
   sl := reversip sl; % sl in upper triangular form
   nl := reversip foreach f in nl join
      if f := subs2pf!* xreduce(f,sl) then {f};
   if null sl or null nl then return {sl,nl};
   nl := solvepfsyseasy(nl,vars,test);
   return {append(sl,car nl),cadr nl};
   end;


symbolic procedure xsolveables(f,test);
   % f:pf, test:function -> xsolveables:list of lpow pf
   % All powers in f whose coefficient numerators satisfy test
   if null f then nil
   else if apply1(test,numr lc f) then lpow f . xsolveables(red f,test)
   else xsolveables(red f,test);


symbolic procedure solvepfsyshard(sys,vars);
   % sys:sys, vars:list of lpow pf -> solvepfsyshard:{sys,sys}
   % Bring sys into weakly solved form by Cramer's rule.  The solved
   % part is in normalised upper triangular form, and korder is
   % completely messed up - results must be reordered under lpows
   % solved part.  Allowing !*edssloppy to work here for the first time
   % minimises the number of restrictions added.
   begin scalar sl,nl,kl,w;
   if null sys then return {{},{}};
   if vars then updkordl vars;
   w := !*k2pf 1;
   foreach f in sys do
      if f := subs2pf wedgepf(if vars then xreorder f else f,w) then
         if null vars or subsetp(wedgefax lpow f,vars) then
            w := f
         else
         << if degreepf f neq 1 then
               f := xcoeff(f,intersection(wedgefax lpow f,vars));
            nl := multpfsq(f,invsq lc w) . nl >>; % exact divisions
   kl := xsolveables(w,'cfrmnowherezero);
   if null kl and !*edssloppy then kl := xpows w;
   if vars then while kl and not subsetp(wedgefax car kl,vars) do
         kl := cdr kl;
   if null kl or (car kl = 1) then return {{},sys};
   kl := wedgefax car kl;
   if !*edssloppy then
      cfrmrsx!* := xpartitsq(numr lc xcoeff(w,kl) ./ 1) . cfrmrsx!*
                                     where xvars!* = cfrmcrd!*;
   sl := foreach k in kl collect xcoeff(w,delete(k,kl));
   updkordl kl;
   return {foreach f in sl collect xnormalise xreorder f,
                 foreach f in nl collect xrepartit!* f};
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edspde.red0000644000175000017500000002337111526203062023225 0ustar  giovannigiovannimodule edspde;

% PDE interface to EDS

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(xvars!* kord!* depl!* dependencies);
global '(indxl!*);


put('pde2eds,'rtypefn,'quoteeds);
put('pde2eds,'edsfn,'pde2eds);
flag('(pde2eds),'nospread);

symbolic procedure pde2eds u;
   % u:{pde:list of equations|expressions, [dep,ind:list of variables]}
   % -> pde2eds:eds
   % Assumes all non-kernel variables are indexed 0-forms.
   begin scalar pde,dep,ind,vars,fns,s,map;
   % Analyse PDE and convert to jet notation
   pde := pde2jet u; dep := cadr pde; ind := caddr pde;
   fns := cadddr pde; pde := getrlist car pde;
   vars := append(ind,foreach p in dep collect car p);
   % Save dependencies in shared variable "dependencies"
   dependencies := makelist purge
      foreach k in append(fns,vars) join
          if k := atsoc(lid k,depl!*) then {makelist k};
   % All variables must be dependency-free, and all functions have
   % fdomains.  Functions without dependencies must depend on all
   % independent variables.
   foreach k in vars do
   << k := lid k; % get leading id
      foreach x in atsoc(k,depl!*) do depend1(k,x,nil);
      remflag({k},'impfun); >>;
   foreach k in fns do
   << k := lid k; % get leading id
      foreach x in setdiff(atsoc(k,depl!*),ind) do depend1(k,x,nil);
      if null atsoc(k,depl!*) then foreach x in ind do depend1(k,x,t);
      flag({k},'impfun); >>;
   % Construct contact system
   vars := {};
   foreach p in dep do
      if s := assoc(cdr p,vars) then cdr s := car p . cdr s
      else vars := (cdr p . {car p}) . vars;
   s := partialcontact(makelist foreach l in vars collect
                 makelist l,makelist ind);
   % Decide what to pullback or augment
   map := makelist foreach x in pde join
                   if eqexpr x and kernp simp!* cadr x then {x};
   pde := makelist foreach x in setdiff(pde,map) collect !*eqn2a x;
   % Finished
   if pde then s := edscall augmenteds(s,pde);
   if map then s := edscall pullbackeds(s,map);
   return s;
   end;


put('partial_contact,'rtypefn,'quoteeds);
put('partial_contact,'edsfn,'partialcontact);

symbolic procedure partialcontact(vars,ind);
   % vars:rlist of (degree . rlist of kernel), ind:rlist of kernel
   % -> partialcontact:eds
   begin scalar s,jet,ord,sys;
   vars := foreach l in getrlist vars collect getrlist l;
   vars := sort(vars,function(lambda(x,y); car x > car y));
   ind := !*a2cfrm{makelist getrlist ind};
   s := mkeds{{},foreach f in cfrm_cob ind collect !*k2pf f,ind,nil};
   puteds(s,'sqvar,!*sqvar!*);
   foreach f in {'solved,'reduced,'quasilinear,'pfaffian,'involutive} do
      flagtrueeds(s,f);
   while vars do
   << jet := !*a2cfrm{makelist cdar vars};
      eds_cfrm s := cfrmprod2(eds_cfrm s,jet);
      puteds(s,'jet0,append(geteds(s,'jet0),cdar vars));
      ord := if cdr vars then caar vars - caadr vars else caar vars;
      for i:=1:ord do   % gbsys doesn't produce redundant mixed partials
      << sys := eds_sys s;
         s := edscall gbsys s;
               eds_sys s := append(sys,eds_sys s) >>;
      vars := cdr vars >>;
   return s;
   end;


put('pde2jet,'rtypefn,'quotelist);
put('pde2jet,'listfn,'pde2jeteval);

symbolic procedure pde2jeteval(u,v);
   reval1(car pde2jet revlis u,v);


symbolic procedure pde2jet u;
   % u:{pde:list of equations|expressions, [dep,ind:list of variables]}
   % -> pde2jet:{pde:rlist of prefix, dep:list of kernel . int,
   %             ind:list of kernel, fns:list of kernel}
   begin scalar dep1,ind1,drv,ind,dep,fns,idxs,rlb,!*evallhseqp;
   if length u neq 1 and length u neq 3 then
      rerror(eds,000,"Wrong number of arguments to pde2jet");
   if length u > 1 then
   << dep1 := foreach v in getrlist cadr u collect !*a2k v;
         ind1 := foreach v in getrlist caddr u collect !*a2k v >>;
   on evallhseqp;
   % Collect all derivatives and possible dependent variables
   foreach x in getrlist car u do drv := union(edsdfkernels x,drv);
   edsdebug("Derivatives and functions found",drv,'cob);
   % Scan to distinguish dependent and independent variables and get
   % orders
   ind := edspdescan drv; dep := car ind; ind := cadr ind;
   % If there are explicit variable lists given, pick out functions not
   % in dependent variables, add any dependent variable which did not
   % occur, and likewise for independent variables
   if length u > 1 then
   << if not subsetp(ind,ind1) then
         rerror(eds,000,
                "Less independent variables given than occur in PDE");
      ind := ind1;
      foreach k in ind do dep := delasc(k,dep);
      fns := setdiff(foreach p in dep collect car p,dep1);
      foreach k in fns do dep := delasc(k,dep);
      foreach k in dep1 do if not atsoc(k,dep) then
         dep := (k . 0) . dep; >>;
   % Sort variables
   dep := sort(dep,function ordopcar);
   ind := sort(ind,function ordop);
   fns := sort(fns,function ordop);
   edsdebug("Dependent variables and orders",
            makelist foreach p in dep
               collect {'equal,car p,cdr p},'prefix);
   edsdebug("Independent variables",ind,'cob);
   edsdebug("Other functions",fns,'cob);
   % All variables and functions must be 0-forms.
   foreach k in append(fns,ind) do if not exformp k then mkform!*(k,0);
   foreach k in dep do if not exformp car k then mkform!*(car k,0);
   % All dependent variables and functions with dependencies must be
   % impfuns
   %% flag(foreach k in fns join if atsoc(k,depl!*) then {k},'impfun);
   %% flag(foreach p in dep join if atsoc(car p,depl!*) then
   %%    {car p},'impfun);
   % Get indices and fix index names (cf. gbsys)
   idxs := uniqids ind;
   if not subsetp(idxs,indxl!*) then % indexrange is an rlist
      apply1('indexrange,{{'equal,gensym(),makelist idxs}});
   idxs := pair(ind,idxs);
   % Construct relabelling list
   foreach k in drv do
      if eqcar(k,'df) or eqcar(k,'partdf) then
         if cadr k memq fns then
            rlb := {'equal,k,!*df2partdf k} . rlb
         else
            rlb := {'equal,k,!*df2jet(k,idxs)} . rlb;
   edsdebug("Relabelling list",makelist rlb,'prefix);
   return {subeval{makelist rlb,car u},dep,ind,fns};
   end;


symbolic procedure edspdescan u;
   % u:list of kernel-> edspdescan:{list of kernel . int,list of kernel}
   % Look for dependent and independent variables and order of
   % differentials in u. All variables which are not differentiated wrt
   % are considered dependent. All non-indexed variables are broken up
   % and the arguments are scanned instead.
   begin scalar dep,ind,k,p;
   while u do
   << k := car u; u := cdr u;
      if eqcar(k,'partdf) or eqcar(k,'df) then
      << k := cadr k . edsdfexpand cddr k;
         ind := union(cdr k,ind);
         if (p := atsoc(car k,dep)) then
            cdr p := max(cdr p,length cdr k)
         else
            dep := (car k . length cdr k) . dep >>
      else if not atsoc(k,dep) then
         if atom k or (xvarp k where xvars!* = t) then
            dep := (k . 0) . dep
               else
            foreach v in cdr k do u := union(edsdfkernels v,u) >>;
   foreach k in ind do dep := delasc(k,dep);
   return {dep,ind};
   end;


symbolic procedure edsdfkernels x;
   % x:prefix -> edsdfkernels:list of kernel
   % Returns all kernels in x which could be differentiable
   if eqexpr x then
      union(edsdfkernels cadr x,edsdfkernels caddr x)
   else
   << x := simp!* x;
      foreach k in union(kernels numr x,kernels denr x) join
         if eqcar(k,'df) or eqcar(k,'partdf) or
            assoc(k,depl!*) or exformp k then {k} >>;


symbolic procedure !*df2jet(u,idxs);
   % u:df or partdf kernel, idxs:alist of kernel . id -> !*df2jet:kernel
   begin scalar v,ixl;
   u := cdr u;
   if atom(v := car u) then v := {v};
   ixl := sublis(idxs,edsdfexpand cdr u);
   ixl := foreach j in sort(ixl,'indtordp) collect lowerind j;
   u := car fkern append(v,ixl);
   return mkform!*(u,0);
   end;


symbolic procedure !*df2partdf u;
   % u:df kernel -> !*df2partdf:kernel
   car fkern('partdf . cadr u . edsdfexpand cddr u);


symbolic procedure edsdfexpand u;
   % u:list of (id|posint) -> edsdfexpand:list of id
   % take list of derivatives used by df and partdf operators and
   % expand any repeat counts to explicitly repeat derivatives
   if null u then nil
   else if cdr u and fixp cadr u then
      nconc(nlist(car u,cadr u),edsdfexpand cddr u)
   else
      car u . edsdfexpand cdr u;


symbolic operator mkdepend;
symbolic procedure mkdepend u;
   % u:rlist of rlists -> nil
   foreach v in getrlist u do
      if v := getrlist v then
      << depl!* := v . delasc(car v,depl!*);
         if exformp car v or flagp(car v,'indexvar) then
             flag({car v},'impfun) >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/eds.rlg0000644000175000017500000021635111527635055022564 0ustar  giovannigiovanniFri Feb 18 21:27:53 2011 run on win32

*** ^ redefined 

+++ depends redefined


		  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
		  %   Twisting type N solutions of GR   %
		  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The problem is to analyse an ansatz for a particular type of vacuum
% solution to Einstein's equations for general relativity. The analysis was
% described by Finley and Price (Proc Aspects of GR and Math Phys
% (Plebanski Festschrift), Mexico City June 1993). The equations resulting
% from the ansatz are:

% F    - F*gamma = 0
%  3 3
%
% F   *x  + 2*F *x    + x     *F - x *Delta*F = 0
%  2 2  1      2  1 2    1 2 2      1
%
% 2*F   *x    + 2*F *x      + 2*F   *x    + 2*F *x      + x       *F = 0
%    2 3  2 3      2  2 3 3      3 2  2 3      3  2 2 3    2 2 3 3
%
% Delta =0       Delta  neq 0
%      3	           1      
%
% gamma =0       gamma  neq 0
%      2	           1      

% where the unknowns are {F,x,gamma,Delta} and the indices refer to
% derivatives with respect to an anholonomic basis. The highest order is 4,
% but the 4th order jet bundle is too large for practical computation, so
% it is necessary to construct partial prolongations. There is a single
% known solution, due to Hauser, which is verified at the end.

on evallhseqp,edssloppy,edsverbose;


off arbvars,edsdebug;



pform {F,x,Delta,gamma,v,y,u}=0;


pform v(i)=0,omega(i)=1;


indexrange {i,j,k,l}={1,2,3};



% Construct J1({v,y,u},{x}) and transform coordinates. Use ordering
% statement to get v eliminated in favour of x where possible.
% NB Coordinate change cc1 is invertible only when x(-1) neq 0.

J1 := contact(1,{v,y,u},{x});


j1 := EDS({d x - x *d u - x *d v - x *d y},d u^d v^d y)
                  u        v        y

korder x(-1),x(-2),v(-3);


cc1 :=	{x(-v) = x(-1),
	 x(-y) = x(-2),
	 x(-u) = -x(-1)*v(-3)};


cc1 := {x =x ,
         v  1

        x =x ,
         y  2

        x = - x *v }
         u     1  3

J1 := restrict(pullback(J1,cc1),{x(-1) neq 0});


j1 := EDS({d x + v *x *d u - x *d v - x *d y},d u^d v^d y)
                  3  1        1        2


% Set up anholonomic cobasis

bc1 :=	{omega(1) = d v - v(-3)*d u,
	 omega(2) = d y,
	 omega(3) = d u};


             1                      2          3
bc1 := {omega = - v *d u + d v,omega =d y,omega =d u}
                   3

J1 := transform(J1,bc1);


                         1           2       1      2      3
j1 := EDS({d x - x *omega  - x *omega },omega ^omega ^omega )
                  1           2


% Prolong to J421: 4th order in x, 2nd in F and 1st in rest

J2 := prolong J1$

Prolongation using new equations: 

       - x
          2 3
v   =---------
 3 2    x
         1


       - x
          1 3
v   =---------
 3 1    x
         1


x   =x
 2 1  1 2


x  neq 0
 1


J20 := J2 cross {F}$


J31 := prolong J20$

Prolongation using new equations: 

        2*x   *x    - x *x
           1 3  2 3    1  2 3 3
v     =-------------------------
 3 3 2               2
                 (x )
                   1


                               2
         - x     *x  + 2*(x   )
            1 3 3  1       1 3
v     =--------------------------
 3 3 1               2
                 (x )
                   1


         - x   *x    + x *x
            1 2  2 3    1  2 2 3
x     =--------------------------
 2 3 2             x
                    1


        x     *x  - x   *x
         1 2 3  1    1 2  1 3
x     =-----------------------
 2 3 1           x
                  1


x     =x
 2 2 1  1 2 2


         - x   *x    + x     *x
            1 1  2 3    1 2 3  1
x     =--------------------------
 1 3 2             x
                    1


        x     *x  - x   *x
         1 1 3  1    1 1  1 3
x     =-----------------------
 1 3 1           x
                  1


x     =x
 1 2 1  1 1 2


x  neq 0
 1


J310 := J31 cross {Delta,gamma}$


J421 := prolong J310$

Prolongation using new equations: 

       - f *x    + f   *x
          1  2 3    2 3  1
f   =----------------------
 3 2           x
                1


      f   *x  - f *x
       1 3  1    1  1 3
f   =-------------------
 3 1         x
              1


f   =f
 2 1  1 2


                                     2                               2
          3*x     *x *x    - 6*(x   ) *x    + 3*x   *x *x      - (x ) *x
             1 3 3  1  2 3       1 3    2 3      1 3  1  2 3 3     1    2 3 3 3
v       =-----------------------------------------------------------------------
 3 3 3 2                                      3
                                          (x )
                                            1


                          2                              3
           - x       *(x )  + 6*x     *x   *x  - 6*(x   )
              1 3 3 3   1        1 3 3  1 3  1       1 3
v       =--------------------------------------------------
 3 3 3 1                           3
                               (x )
                                 1


x
 2 3 3 2

                                                                2
   - 2*x     *x *x    + 2*x   *x   *x    - x   *x *x      + (x ) *x
        1 2 3  1  2 3      1 2  1 3  2 3    1 2  1  2 3 3     1    2 2 3 3
=--------------------------------------------------------------------------
                                       2
                                   (x )
                                     1


                       2                                                    2
          x       *(x )  - 2*x     *x   *x  - x   *x     *x  + 2*x   *(x   )
           1 2 3 3   1        1 2 3  1 3  1    1 2  1 3 3  1      1 2   1 3
x       =---------------------------------------------------------------------
 2 3 3 1                                     2
                                         (x )
                                           1


           - x     *x    + x *x
              1 2 2  2 3    1  2 2 2 3
x       =------------------------------
 2 2 3 2               x
                        1


          x       *x  - x     *x
           1 2 2 3  1    1 2 2  1 3
x       =---------------------------
 2 2 3 1             x
                      1


x       =x
 2 2 2 1  1 2 2 2


x
 1 3 3 2

                                                                         2
   - 2*x     *x *x    + 2*x   *x   *x    - x   *x *x      + x       *(x )
        1 1 3  1  2 3      1 1  1 3  2 3    1 1  1  2 3 3    1 2 3 3   1
=--------------------------------------------------------------------------
                                       2
                                   (x )
                                     1


                       2                                                    2
          x       *(x )  - 2*x     *x   *x  - x   *x     *x  + 2*x   *(x   )
           1 1 3 3   1        1 1 3  1 3  1    1 1  1 3 3  1      1 1   1 3
x       =---------------------------------------------------------------------
 1 3 3 1                                     2
                                         (x )
                                           1


           - x     *x    + x       *x
              1 1 2  2 3    1 2 2 3  1
x       =------------------------------
 1 2 3 2               x
                        1


          x       *x  - x     *x
           1 1 2 3  1    1 1 2  1 3
x       =---------------------------
 1 2 3 1             x
                      1


x       =x
 1 2 2 1  1 1 2 2


           - x     *x    + x       *x
              1 1 1  2 3    1 1 2 3  1
x       =------------------------------
 1 1 3 2               x
                        1


          x       *x  - x     *x
           1 1 1 3  1    1 1 1  1 3
x       =---------------------------
 1 1 3 1             x
                      1


x       =x
 1 1 2 1  1 1 1 2


x  neq 0
 1


cc4 := first pullback_maps;


              x *f    - f *x
               1  2 3    1  2 3
cc4 := {f   =-------------------,
         3 2         x
                      1

              x *f    - f *x
               1  1 3    1  1 3
        f   =-------------------,
         3 1         x
                      1

        f   =f   ,
         2 1  1 2

                         2
        v       =( - (x ) *x        + 3*x *x     *x    + 3*x *x   *x
         3 3 3 2       1    2 3 3 3      1  1 3 3  2 3      1  1 3  2 3 3

                      2           3
            - 6*(x   ) *x   )/(x ) ,
                  1 3    2 3    1

                         2                                       3
                   - (x ) *x        + 6*x *x     *x    - 6*(x   )
                       1    1 3 3 3      1  1 3 3  1 3       1 3
        v       =--------------------------------------------------,
         3 3 3 1                           3
                                       (x )
                                         1

                      2
        x       =((x ) *x        - 2*x *x     *x    - x *x   *x
         2 3 3 2    1    2 2 3 3      1  1 2 3  2 3    1  1 2  2 3 3

                                    2
            + 2*x   *x   *x   )/(x ) ,
                 1 2  1 3  2 3    1

        x
         2 3 3 1

              2                                                             2
          (x ) *x        - 2*x *x     *x    - x *x   *x      + 2*x   *(x   )
            1    1 2 3 3      1  1 2 3  1 3    1  1 2  1 3 3      1 2   1 3
        =---------------------------------------------------------------------,
                                             2
                                         (x )
                                           1

                  x *x        - x     *x
                   1  2 2 2 3    1 2 2  2 3
        x       =---------------------------,
         2 2 3 2             x
                              1

                  x *x        - x     *x
                   1  1 2 2 3    1 2 2  1 3
        x       =---------------------------,
         2 2 3 1             x
                              1

        x       =x       ,
         2 2 2 1  1 2 2 2

                      2
        x       =((x ) *x        - 2*x *x     *x    - x *x   *x
         1 3 3 2    1    1 2 3 3      1  1 1 3  2 3    1  1 1  2 3 3

                                    2
            + 2*x   *x   *x   )/(x ) ,
                 1 1  1 3  2 3    1

        x
         1 3 3 1

              2                                                             2
          (x ) *x        - 2*x *x     *x    - x *x   *x      + 2*x   *(x   )
            1    1 1 3 3      1  1 1 3  1 3    1  1 1  1 3 3      1 1   1 3
        =---------------------------------------------------------------------,
                                             2
                                         (x )
                                           1

                  x *x        - x     *x
                   1  1 2 2 3    1 1 2  2 3
        x       =---------------------------,
         1 2 3 2             x
                              1

                  x *x        - x     *x
                   1  1 1 2 3    1 1 2  1 3
        x       =---------------------------,
         1 2 3 1             x
                              1

        x       =x       ,
         1 2 2 1  1 1 2 2

                  x *x        - x     *x
                   1  1 1 2 3    1 1 1  2 3
        x       =---------------------------,
         1 1 3 2             x
                              1

                  x *x        - x     *x
                   1  1 1 1 3    1 1 1  1 3
        x       =---------------------------,
         1 1 3 1             x
                              1

        x       =x       ,
         1 1 2 1  1 1 1 2

        x  neq 0}
         1


% Apply first order de and restrictions

de1 :=	{Delta(-3) = 0,
	 gamma(-2) = 0,
	 Delta(-1) neq 0,
	 gamma(-1) neq 0};


de1 := {delta =0,
             3

        gamma =0,
             2

        delta  neq 0,
             1

        gamma  neq 0}
             1


J421 := pullback(J421,de1)$



% Main de in original coordinates 

de2 :=	{F(-3,-3) - gamma*F,
	 x(-1)*F(-2,-2) + 2*x(-1,-2)*F(-2)
		 + (x(-1,-2,-2) - x(-1)*Delta)*F,
	 x(-2,-3)*(F(-2,-3)+F(-3,-2)) + x(-2,-2,-3)*F(-3)
		 + x(-2,-3,-3)*F(-2) + (1/2)*x(-2,-2,-3,-3)*F};


de2 := {f    - f*gamma,
         3 3

        f   *x  + 2*f *x    + x     *f - x *delta*f,
         2 2  1      2  1 2    1 2 2      1

         2*f   *x    + 2*f *x      + 2*f   *x    + 2*f *x      + x       *f
            2 3  2 3      2  2 3 3      3 2  2 3      3  2 2 3    2 2 3 3
        --------------------------------------------------------------------}
                                         2


% This is not expressed in terms of current coordinates.
% Missing coordinates are seen from 1-form variables in following

d de2 xmod cobasis J421;


{d f   *x   }
    3 2  2 3


% The necessary equation is contained in the last prolongation

pullback(d de2,cc4) xmod cobasis J421;


{}


% Apply main de

pb1 := first solve(pullback(de2,cc4),{F(-3,-3),F(-2,-2),F(-2,-3)});


pb1 := {f   =f*gamma,
         3 3

               - 2*f *x    - x     *f + x *delta*f
                    2  1 2    1 2 2      1
        f   =--------------------------------------,
         2 2                   x
                                1

                         2
              2*f *(x   )  - 2*f *x *x      - 2*f *x *x      - x *x       *f
                 1   2 3        2  1  2 3 3      3  1  2 2 3    1  2 2 3 3
        f   =----------------------------------------------------------------}
         2 3                            4*x *x
                                           1  2 3

Y421 := pullback(J421,pb1)$



% Check involution

on ranpos;


characters Y421;


{15,7,0}

dim_grassmann_variety Y421;


28


% 15+2*7 = 29 > 28: Y421 not involutive, so prolong

Y532 := prolong Y421$

Prolongation using new equations: 

           - gamma *x
                  1  2 3
gamma   =----------------
     3 2        x
                 1


          gamma   *x  - gamma *x
               1 3  1        1  1 3
gamma   =---------------------------
     3 1             x
                      1


gamma   =0
     1 2


          delta *x
               1  2 3
delta   =-------------
     2 3      x
               1


delta   =delta
     2 1      1 2


          delta *x
               1  1 3
delta   =-------------
     1 3      x
               1


                                                   2          2
f     =(2*f   *x   *x  + f *x     *x  - 2*f *(x   )  + f *(x ) *gamma
 1 3 3     1 3  1 3  1    1  1 3 3  1      1   1 3      1   1

                      2        2
         + gamma *(x ) *f)/(x )
                1   1        1


                           3                        2              2
f     =( - 2*f   *x *(x   )  + 4*f   *x   *x *(x   )  - 2*f   *(x ) *x     *x
 1 3 2        1 1  1   2 3        1 2  1 3  1   2 3        1 2   1    2 3 3  2 3

                      2                               3                        2
         - 2*f   *(x ) *x     *x    - 2*f *x   *(x   )  + 2*f *x     *x *(x   )
              1 3   1    2 2 3  2 3      1  1 1   2 3        1  1 2 3  1   2 3

                                2
         - 2*f *x   *x   *(x   )  + 2*f *x   *x *x     *x
              1  1 2  1 3   2 3        1  1 3  1  2 2 3  2 3

                  2                                   2
         - f *(x ) *x       *x    - 2*f *x       *(x ) *x
            1   1    2 2 3 3  2 3      2  1 2 3 3   1    2 3

                                                      2
         + 4*f *x     *x   *x *x    + 2*f *x     *(x ) *x
              2  1 2 3  1 3  1  2 3      2  1 2 3   1    2 3 3

                                                      2
         + 2*f *x   *x     *x *x    - 4*f *x   *(x   ) *x
              2  1 2  1 3 3  1  2 3      2  1 2   1 3    2 3

                                                        2
         - 2*f *x   *x   *x *x      - 2*f *x       *(x ) *x
              2  1 2  1 3  1  2 3 3      3  1 2 2 3   1    2 3

                                                      2
         + 2*f *x     *x   *x *x    + 2*f *x     *(x ) *x
              3  1 2 2  1 3  1  2 3      3  1 2 3   1    2 2 3

                                                 2
         - 2*f *x   *x   *x *x      + x     *(x ) *x       *f
              3  1 2  1 3  1  2 2 3    1 2 3   1    2 2 3 3

                                         2                           2       2
         - x   *x   *x *x       *f - (x ) *x         *x   *f)/(4*(x ) *(x   ) )
            1 2  1 3  1  2 2 3 3       1    2 2 3 3 1  2 3         1     2 3


        f     *x  - f   *x
         1 1 3  1    1 1  1 3
f     =-----------------------
 1 3 1           x
                  1


                        3                        2              2
f     =(2*f   *x *(x   )  + 4*f   *x   *x *(x   )  - 2*f   *(x ) *x     *x
 1 2 3     1 1  1   2 3        1 2  1 3  1   2 3        1 2   1    2 3 3  2 3

                      2                               3                        2
         - 2*f   *(x ) *x     *x    - 2*f *x   *(x   )  + 2*f *x     *x *(x   )
              1 3   1    2 2 3  2 3      1  1 1   2 3        1  1 2 3  1   2 3

                                2
         - 2*f *x   *x   *(x   )  + 2*f *x   *x *x     *x
              1  1 2  1 3   2 3        1  1 3  1  2 2 3  2 3

                  2                                   2
         - f *(x ) *x       *x    - 2*f *x       *(x ) *x
            1   1    2 2 3 3  2 3      2  1 2 3 3   1    2 3

                                                      2
         + 4*f *x     *x   *x *x    + 2*f *x     *(x ) *x
              2  1 2 3  1 3  1  2 3      2  1 2 3   1    2 3 3

                                                      2
         + 2*f *x   *x     *x *x    - 4*f *x   *(x   ) *x
              2  1 2  1 3 3  1  2 3      2  1 2   1 3    2 3

                                                        2
         - 2*f *x   *x   *x *x      - 2*f *x       *(x ) *x
              2  1 2  1 3  1  2 3 3      3  1 2 2 3   1    2 3

                                                      2
         + 2*f *x     *x   *x *x    + 2*f *x     *(x ) *x
              3  1 2 2  1 3  1  2 3      3  1 2 3   1    2 2 3

                                                 2
         - 2*f *x   *x   *x *x      + x     *(x ) *x       *f
              3  1 2  1 3  1  2 2 3    1 2 3   1    2 2 3 3

                                         2                           2       2
         - x   *x   *x *x       *f - (x ) *x         *x   *f)/(4*(x ) *(x   ) )
            1 2  1 3  1  2 2 3 3       1    2 2 3 3 1  2 3         1     2 3


                   2                                            2
f     =(delta *(x ) *f - 2*f   *x   *x  - f *x     *x  + f *(x ) *delta
 1 2 2       1   1          1 2  1 2  1    1  1 2 2  1    1   1

         - 2*f *x     *x  + 2*f *x   *x    - x       *x *f + x   *x     *f)/
              2  1 1 2  1      2  1 1  1 2    1 1 2 2  1      1 1  1 2 2

           2
       (x )
         1


f     =f
 1 2 1  1 1 2


                           2
v         =(4*x       *(x ) *x    - 24*x     *x   *x *x
 3 3 3 3 2     1 3 3 3   1    2 3       1 3 3  1 3  1  2 3

                            2                   3                 2
             + 6*x     *(x ) *x      + 24*(x   ) *x    - 12*(x   ) *x *x
                  1 3 3   1    2 3 3        1 3    2 3        1 3    1  2 3 3

                          2                3                 4
             + 4*x   *(x ) *x        - (x ) *x         )/(x )
                  1 3   1    2 3 3 3     1    2 3 3 3 3    1


                              3                       2             2     2
v         =( - x         *(x )  + 8*x       *x   *(x )  + 6*(x     ) *(x )
 3 3 3 3 1      1 3 3 3 3   1        1 3 3 3  1 3   1         1 3 3     1

                               2               4      4
             - 36*x     *(x   ) *x  + 24*(x   ) )/(x )
                   1 3 3   1 3    1        1 3      1


                           2       3                       3
x         =( - 12*f   *(x ) *(x   )  + 12*f *x   *x *(x   )
 2 3 3 3 2         1 3   1     2 3         1  1 3  1   2 3

                        2              2            3
             - 6*f *(x ) *x     *(x   )  - 4*f *(x ) *x       *x
                  1   1    2 3 3   2 3        2   1    2 3 3 3  2 3

                        3         2            3       2
             + 6*f *(x ) *(x     )  - 8*f *(x ) *(x   ) *gamma
                  2   1     2 3 3        2   1     2 3

                        3                          3
             - 6*f *(x ) *x       *x    + 6*f *(x ) *x     *x
                  3   1    2 2 3 3  2 3      3   1    2 2 3  2 3 3

                              2       2                             2
             - 6*x       *(x ) *(x   ) *f + 12*x     *x   *x *(x   ) *f
                  1 2 3 3   1     2 3           1 2 3  1 3  1   2 3

                            2                                        2
             - 6*x     *(x ) *x     *x   *f + 6*x   *x     *x *(x   ) *f
                  1 2 3   1    2 3 3  2 3        1 2  1 3 3  1   2 3

                             2       2
             - 12*x   *(x   ) *(x   ) *f + 6*x   *x   *x *x     *x   *f
                   1 2   1 3     2 3          1 2  1 3  1  2 3 3  2 3

                          2                         3
             - 2*x   *(x ) *x       *x   *f + 3*(x ) *x       *x     *f
                  1 2   1    2 3 3 3  2 3         1    2 2 3 3  2 3 3

                     3                             3
             - 4*(x ) *x     *x   *f*gamma)/(2*(x ) *x   *f)
                   1    2 2 3  2 3               1    2 3


                           3                       2                       2
x         =(x         *(x )  - 3*x       *x   *(x )  - 3*x     *x     *(x )
 2 3 3 3 1   1 2 3 3 3   1        1 2 3 3  1 3   1        1 2 3  1 3 3   1

                              2                        2
             + 6*x     *(x   ) *x  - x   *x       *(x )  + 6*x   *x     *x   *x
                  1 2 3   1 3    1    1 2  1 3 3 3   1        1 2  1 3 3  1 3  1

                            3      3
             - 6*x   *(x   ) )/(x )
                  1 2   1 3      1


                                3                    3                        2
x         =( - 12*f   *x *(x   )  + 12*f *x   *(x   )  - 6*f *x *x     *(x   )
 2 2 3 3 3         1 3  1   2 3         1  1 3   2 3        1  1  2 3 3   2 3

                        2                          2         2
             - 4*f *(x ) *x       *x    + 6*f *(x ) *(x     )
                  2   1    2 3 3 3  2 3      2   1     2 3 3

                        2       2                  2
             - 8*f *(x ) *(x   ) *gamma - 6*f *(x ) *x       *x
                  2   1     2 3              3   1    2 2 3 3  2 3

                        2                       2
             + 6*f *(x ) *x     *x      + 3*(x ) *x       *x     *f
                  3   1    2 2 3  2 3 3       1    2 2 3 3  2 3 3

                     2                             2
             - 4*(x ) *x     *x   *f*gamma)/(2*(x ) *x   *f)
                   1    2 2 3  2 3               1    2 3


                             3                        2
x         =(12*f   *x *(x   )  + 6*f *x *x     *(x   )
 2 2 3 3 2      1 2  1   2 3        1  1  2 2 3   2 3

                                     2                         2
             + 24*f *x     *x *(x   )  - 24*f *x   *x   *(x   )
                   2  1 2 3  1   2 3         2  1 2  1 3   2 3

                        2                          2
             - 6*f *(x ) *x       *x    + 6*f *(x ) *x     *x
                  2   1    2 2 3 3  2 3      2   1    2 2 3  2 3 3

                                     2
             + 12*f *x     *x *(x   )  - 12*f *x   *x *x     *x
                   3  1 2 2  1   2 3         3  1 2  1  2 2 3  2 3

                        2                          2         2
             - 4*f *(x ) *x       *x    + 6*f *(x ) *(x     )
                  3   1    2 2 2 3  2 3      3   1     2 2 3

                        2       2                             2
             - 8*f *(x ) *(x   ) *delta + 8*x       *x *(x   ) *f
                  3   1     2 3              1 2 2 3  1   2 3

                                   2
             - 8*x     *x   *(x   ) *f + 4*x     *x *x     *x   *f
                  1 2 2  1 3   2 3          1 2 2  1  2 3 3  2 3

                                                 2
             - 6*x   *x *x       *x   *f + 3*(x ) *x       *x     *f
                  1 2  1  2 2 3 3  2 3         1    2 2 3 3  2 2 3

                     2                             2
             - 4*(x ) *x     *x   *delta*f)/(2*(x ) *x   *f)
                   1    2 3 3  2 3               1    2 3


                             3                        2
x         =(12*f   *x *(x   )  + 6*f *x *x     *(x   )
 2 2 2 3 3      1 2  1   2 3        1  1  2 2 3   2 3

                                     2                         2
             + 24*f *x     *x *(x   )  - 24*f *x   *x   *(x   )
                   2  1 2 3  1   2 3         2  1 2  1 3   2 3

                        2                          2
             - 6*f *(x ) *x       *x    + 6*f *(x ) *x     *x
                  2   1    2 2 3 3  2 3      2   1    2 2 3  2 3 3

                                     2
             + 12*f *x     *x *(x   )  - 12*f *x   *x *x     *x
                   3  1 2 2  1   2 3         3  1 2  1  2 2 3  2 3

                        2                          2         2
             - 4*f *(x ) *x       *x    + 6*f *(x ) *(x     )
                  3   1    2 2 2 3  2 3      3   1     2 2 3

                        2       2                              2
             - 8*f *(x ) *(x   ) *delta + 12*x       *x *(x   ) *f
                  3   1     2 3               1 2 2 3  1   2 3

                                    2
             - 12*x     *x   *(x   ) *f + 6*x     *x *x     *x   *f
                   1 2 2  1 3   2 3          1 2 2  1  2 3 3  2 3

                                                 2
             - 6*x   *x *x       *x   *f + 3*(x ) *x       *x     *f
                  1 2  1  2 2 3 3  2 3         1    2 2 3 3  2 2 3

                     2                             2
             - 4*(x ) *x     *x   *delta*f)/(2*(x ) *x   *f)
                   1    2 3 3  2 3               1    2 3


             - x       *x    + x *x
                1 2 2 2  2 3    1  2 2 2 2 3
x         =----------------------------------
 2 2 2 3 2                 x
                            1


            x         *x  - x       *x
             1 2 2 2 3  1    1 2 2 2  1 3
x         =-------------------------------
 2 2 2 3 1               x
                          1


x         =x
 2 2 2 2 1  1 2 2 2 2


                              2
x         =( - 3*x       *(x ) *x    + 6*x     *x   *x *x
 1 3 3 3 2        1 1 3 3   1    2 3      1 1 3  1 3  1  2 3

                            2
             - 3*x     *(x ) *x      + 3*x   *x     *x *x
                  1 1 3   1    2 3 3      1 1  1 3 3  1  2 3

                            2                                         2
             - 6*x   *(x   ) *x    + 3*x   *x   *x *x      - x   *(x ) *x
                  1 1   1 3    2 3      1 1  1 3  1  2 3 3    1 1   1    2 3 3 3

                              3      3
             + x         *(x ) )/(x )
                1 2 3 3 3   1      1


                           3                       2                       2
x         =(x         *(x )  - 3*x       *x   *(x )  - 3*x     *x     *(x )
 1 3 3 3 1   1 1 3 3 3   1        1 1 3 3  1 3   1        1 1 3  1 3 3   1

                              2                        2
             + 6*x     *(x   ) *x  - x   *x       *(x )  + 6*x   *x     *x   *x
                  1 1 3   1 3    1    1 1  1 3 3 3   1        1 1  1 3 3  1 3  1

                            3      3
             - 6*x   *(x   ) )/(x )
                  1 1   1 3      1


x         =( - 2*x       *x *x    + 2*x     *x   *x    - x     *x *x
 1 2 3 3 2        1 1 2 3  1  2 3      1 1 2  1 3  2 3    1 1 2  1  2 3 3

                                                                      2
             + 2*x       *x   *x  + x     *x     *x  - 2*x     *(x   )
                  1 2 2 3  1 3  1    1 2 2  1 3 3  1      1 2 2   1 3

                   2                 2
             + (x ) *x         )/(x )
                 1    2 2 3 3 1    1


x
 1 2 3 3 1

                 2                                                          2
  x         *(x )  - 2*x       *x   *x  - x     *x     *x  + 2*x     *(x   )
   1 1 2 3 3   1        1 1 2 3  1 3  1    1 1 2  1 3 3  1      1 1 2   1 3
=-----------------------------------------------------------------------------
                                         2
                                     (x )
                                       1


                                                                   2
x         =(2*x       *x   *x  + x     *x     *x  - 2*x     *(x   )
 1 2 2 3 3     1 2 2 3  1 3  1    1 2 2  1 3 3  1      1 2 2   1 3

                   2                 2
             + (x ) *x         )/(x )
                 1    2 2 3 3 1    1


             - x       *x    + x         *x
                1 1 2 2  2 3    1 2 2 2 3  1
x         =----------------------------------
 1 2 2 3 2                 x
                            1


            x         *x  - x       *x
             1 1 2 2 3  1    1 1 2 2  1 3
x         =-------------------------------
 1 2 2 3 1               x
                          1


x         =x
 1 2 2 2 1  1 1 2 2 2


x         =( - 2*x       *x *x    + 2*x     *x   *x    - x     *x *x
 1 1 3 3 2        1 1 1 3  1  2 3      1 1 1  1 3  2 3    1 1 1  1  2 3 3

                              2      2
             + x         *(x ) )/(x )
                1 1 2 3 3   1      1


x
 1 1 3 3 1

                 2                                                          2
  x         *(x )  - 2*x       *x   *x  - x     *x     *x  + 2*x     *(x   )
   1 1 1 3 3   1        1 1 1 3  1 3  1    1 1 1  1 3 3  1      1 1 1   1 3
=-----------------------------------------------------------------------------
                                         2
                                     (x )
                                       1


             - x       *x    + x         *x
                1 1 1 2  2 3    1 1 2 2 3  1
x         =----------------------------------
 1 1 2 3 2                 x
                            1


            x         *x  - x       *x
             1 1 1 2 3  1    1 1 1 2  1 3
x         =-------------------------------
 1 1 2 3 1               x
                          1


x         =x
 1 1 2 2 1  1 1 1 2 2


             - x       *x    + x         *x
                1 1 1 1  2 3    1 1 1 2 3  1
x         =----------------------------------
 1 1 1 3 2                 x
                            1


            x         *x  - x       *x
             1 1 1 1 3  1    1 1 1 1  1 3
x         =-------------------------------
 1 1 1 3 1               x
                          1


x         =x
 1 1 1 2 1  1 1 1 1 2


x  neq 0
 1


x    neq 0
 2 3


f neq 0



characters Y532;


{22,6,0}

dim_grassmann_variety Y532;


34


% 22+2*6 = 34: just need to check for integrability conditions

torsion Y532;


{}


% Y532 involutive. Dimensions?

dim Y532;


79

length one_forms Y532;


48


% The following puts in part of Hauser's solution and ends up with an ODE
% system (all characters 0), so no more solutions, as described by Finley
% at MG6.

hauser := {x=-v+(1/2)*(y+u)**2,delta=3/(8x),gamma=3/(8v)};


               2                  2
              u  + 2*u*y - 2*v + y
hauser := {x=-----------------------,
                        2

                   3
           delta=-----,
                  8*x

                   3
           gamma=-----}
                  8*v

H532 := pullback(Y532,hauser)$

New 0-form conditions detected 

              2
  - 8*gamma *v  - 3*v
           3         3
-----------------------
            2
         8*v


              2
  - 8*gamma *v  - 3
           1
--------------------
           2
        8*v


                               3*(v  - u - y)
                                   3
----------------------------------------------------------------------------
     4      3        2        2  2                  3      2        2    4
 2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


              4             3               2                2  2
( - 2*delta *u  - 8*delta *u *y + 8*delta *u *v - 12*delta *u *y
           2             2               2                2

                                  3             2               2             4
  + 16*delta *u*v*y - 8*delta *u*y  - 8*delta *v  + 8*delta *v*y  - 2*delta *y
            2                2               2             2               2

                    4      3        2        2  2                  3      2
  - 3*u - 3*y)/(2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v

                           2    4
                    - 4*v*y  + y ))


              4             3               2                2  2
( - 2*delta *u  - 8*delta *u *y + 8*delta *u *v - 12*delta *u *y
           1             1               1                1

                                  3             2               2             4
  + 16*delta *u*v*y - 8*delta *u*y  - 8*delta *v  + 8*delta *v*y  - 2*delta *y
            1                1               1             1               1

            4      3        2        2  2                  3      2        2
  + 3)/(2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y

               4
            + y ))


 - v  + u + y
    3


 - x  + u + y
    2


 - (x  + 1)
     1


lift ws;

Solving 0-forms 
New equations: 

         - 3*(u + y)
gamma =--------------
     3         2
            8*v


         - 3
gamma =------
     1     2
        8*v


delta
     2

                                  - 3*(u + y)
=----------------------------------------------------------------------------
      4      3        2        2  2                  3      2        2    4
  2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


delta
     1

                                      3
=----------------------------------------------------------------------------
      4      3        2        2  2                  3      2        2    4
  2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


v =u + y
 3


x =u + y
 2


x =-1
 1

New 0-form conditions detected 

                3      2                     2
  - 8*gamma   *v  + 6*u  + 12*u*y - 3*v + 6*y
           3 3
-----------------------------------------------
                        3
                     8*v


 3*(x    - 1)
     2 3
--------------
        2
     8*v


                3
  - 8*gamma   *v  + 3*x   *v + 6*u + 6*y
           1 3         1 3
-----------------------------------------
                     3
                  8*v


                3
  - 4*gamma   *v  + 3*u + 3*y
           1 3
------------------------------
                3
             4*v


                3
  - 4*gamma   *v  + 3
           1 1
----------------------
            3
         4*v


                                3*(x    - 1)
                                    2 3
----------------------------------------------------------------------------
     4      3        2        2  2                  3      2        2    4
 2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


                8                7                  6                  6  2
( - 2*delta   *u  - 16*delta   *u *y + 16*delta   *u *v - 56*delta   *u *y
           2 2              2 2                2 2                2 2

                 5                     5  3                4  2
  + 96*delta   *u *v*y - 112*delta   *u *y  - 48*delta   *u *v
            2 2                   2 2                 2 2

                  4    2                 4  4                 3  2
  + 240*delta   *u *v*y  - 140*delta   *u *y  - 192*delta   *u *v *y
             2 2                    2 2                  2 2

                  3    3                 3  5                2  3
  + 320*delta   *u *v*y  - 112*delta   *u *y  + 64*delta   *u *v
             2 2                    2 2                 2 2

                  2  2  2                 2    4                2  6
  - 288*delta   *u *v *y  + 240*delta   *u *v*y  - 56*delta   *u *y
             2 2                     2 2                   2 2

                    3                     2  3                    5
  + 128*delta   *u*v *y - 192*delta   *u*v *y  + 96*delta   *u*v*y
             2 2                   2 2                   2 2

                   7                4                3  2                2  4
  - 16*delta   *u*y  - 32*delta   *v  + 64*delta   *v *y  - 48*delta   *v *y
            2 2                2 2              2 2                 2 2

                   6               8      4       3         2         2  2
  + 16*delta   *v*y  - 2*delta   *y  + 9*u  + 36*u *y - 12*u *v + 54*u *y
            2 2               2 2

                     3       2         2      4       8      7        6
  - 24*u*v*y + 36*u*y  - 12*v  - 12*v*y  + 9*y )/(2*(u  + 8*u *y - 8*u *v

             6  2       5           5  3       4  2        4    2       4  4
       + 28*u *y  - 48*u *v*y + 56*u *y  + 24*u *v  - 120*u *v*y  + 70*u *y

             3  2          3    3       3  5       2  3        2  2  2
       + 96*u *v *y - 160*u *v*y  + 56*u *y  - 32*u *v  + 144*u *v *y

              2    4       2  6         3           2  3           5        7
       - 120*u *v*y  + 28*u *y  - 64*u*v *y + 96*u*v *y  - 48*u*v*y  + 8*u*y

             4       3  2       2  4        6    8
       + 16*v  - 32*v *y  + 24*v *y  - 8*v*y  + y ))


              8               7                 6                  6  2
( - delta   *u  - 8*delta   *u *y + 8*delta   *u *v - 28*delta   *u *y
         1 2             1 2               1 2                1 2

                 5                    5  3                4  2
  + 48*delta   *u *v*y - 56*delta   *u *y  - 24*delta   *u *v
            1 2                  1 2                 1 2

                  4    2                4  4                3  2
  + 120*delta   *u *v*y  - 70*delta   *u *y  - 96*delta   *u *v *y
             1 2                   1 2                 1 2

                  3    3                3  5                2  3
  + 160*delta   *u *v*y  - 56*delta   *u *y  + 32*delta   *u *v
             1 2                   1 2                 1 2

                  2  2  2                 2    4                2  6
  - 144*delta   *u *v *y  + 120*delta   *u *v*y  - 28*delta   *u *y
             1 2                     1 2                   1 2

                   3                    2  3                    5
  + 64*delta   *u*v *y - 96*delta   *u*v *y  + 48*delta   *u*v*y
            1 2                  1 2                   1 2

                  7                4                3  2                2  4
  - 8*delta   *u*y  - 16*delta   *v  + 32*delta   *v *y  - 24*delta   *v *y
           1 2                1 2              1 2                 1 2

                  6             8      3       2                    2
  + 8*delta   *v*y  - delta   *y  - 6*u  - 18*u *y + 12*u*v - 18*u*y  + 12*v*y
           1 2             1 2

       3    8      7        6         6  2       5           5  3       4  2
  - 6*y )/(u  + 8*u *y - 8*u *v + 28*u *y  - 48*u *v*y + 56*u *y  + 24*u *v

                   4    2       4  4       3  2          3    3       3  5
            - 120*u *v*y  + 70*u *y  + 96*u *v *y - 160*u *v*y  + 56*u *y

                  2  3        2  2  2        2    4       2  6         3
            - 32*u *v  + 144*u *v *y  - 120*u *v*y  + 28*u *y  - 64*u*v *y

                    2  3           5        7       4       3  2       2  4
            + 96*u*v *y  - 48*u*v*y  + 8*u*y  + 16*v  - 32*v *y  + 24*v *y

                   6    8
            - 8*v*y  + y )


                                   3*x
                                      1 3
----------------------------------------------------------------------------
     4      3        2        2  2                  3      2        2    4
 2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


              6               5                 4                  4  2
( - delta   *u  - 6*delta   *u *y + 6*delta   *u *v - 15*delta   *u *y
         1 2             1 2               1 2                1 2

                 3                    3  3                2  2
  + 24*delta   *u *v*y - 20*delta   *u *y  - 12*delta   *u *v
            1 2                  1 2                 1 2

                 2    2                2  4                  2
  + 36*delta   *u *v*y  - 15*delta   *u *y  - 24*delta   *u*v *y
            1 2                   1 2                 1 2

                     3                 5               3                2  2
  + 24*delta   *u*v*y  - 6*delta   *u*y  + 8*delta   *v  - 12*delta   *v *y
            1 2                 1 2               1 2              1 2

                  4             6                6      5        4         4  2
  + 6*delta   *v*y  - delta   *y  - 6*u - 6*y)/(u  + 6*u *y - 6*u *v + 15*u *y
           1 2             1 2

          3           3  3       2  2       2    2       2  4         2
    - 24*u *v*y + 20*u *y  + 12*u *v  - 36*u *v*y  + 15*u *y  + 24*u*v *y

              3        5      3       2  2        4    6
    - 24*u*v*y  + 6*u*y  - 8*v  + 12*v *y  - 6*v*y  + y )


              6               5                 4                  4  2
( - delta   *u  - 6*delta   *u *y + 6*delta   *u *v - 15*delta   *u *y
         1 1             1 1               1 1                1 1

                 3                    3  3                2  2
  + 24*delta   *u *v*y - 20*delta   *u *y  - 12*delta   *u *v
            1 1                  1 1                 1 1

                 2    2                2  4                  2
  + 36*delta   *u *v*y  - 15*delta   *u *y  - 24*delta   *u*v *y
            1 1                   1 1                 1 1

                     3                 5               3                2  2
  + 24*delta   *u*v*y  - 6*delta   *u*y  + 8*delta   *v  - 12*delta   *v *y
            1 1                 1 1               1 1              1 1

                  4             6        6      5        4         4  2
  + 6*delta   *v*y  - delta   *y  + 6)/(u  + 6*u *y - 6*u *v + 15*u *y
           1 1             1 1

          3           3  3       2  2       2    2       2  4         2
    - 24*u *v*y + 20*u *y  + 12*u *v  - 36*u *v*y  + 15*u *y  + 24*u*v *y

              3        5      3       2  2        4    6
    - 24*u*v*y  + 6*u*y  - 8*v  + 12*v *y  - 6*v*y  + y )


 - v    + 1
    3 3


 - x    + 1
    2 3


 - x    + 1
    2 2


 - x
    1 3


 - x
    1 2


 - x
    1 1

Solving 0-forms 
New equations: 

                2                  2
          3*(2*u  + 4*u*y - v + 2*y )
gamma   =-----------------------------
     3 3                3
                     8*v


          3*(u + y)
gamma   =-----------
     1 3       3
            4*v


           3
gamma   =------
     1 1     3
          4*v


                4       3        2         2  2                   3      2
delta   =(3*(3*u  + 12*u *y - 4*u *v + 18*u *y  - 8*u*v*y + 12*u*y  - 4*v
     2 2

                     2      4        8      7        6         6  2       5
              - 4*v*y  + 3*y ))/(2*(u  + 8*u *y - 8*u *v + 28*u *y  - 48*u *v*y

                      5  3       4  2        4    2       4  4       3  2
                + 56*u *y  + 24*u *v  - 120*u *v*y  + 70*u *y  + 96*u *v *y

                       3    3       3  5       2  3        2  2  2        2    4
                - 160*u *v*y  + 56*u *y  - 32*u *v  + 144*u *v *y  - 120*u *v*y

                      2  6         3           2  3           5        7       4
                + 28*u *y  - 64*u*v *y + 96*u*v *y  - 48*u*v*y  + 8*u*y  + 16*v

                      3  2       2  4        6    8
                - 32*v *y  + 24*v *y  - 8*v*y  + y ))


                 3      2                  2            3     8      7
delta   =(6*( - u  - 3*u *y + 2*u*v - 3*u*y  + 2*v*y - y ))/(u  + 8*u *y
     1 2

                  6         6  2       5           5  3       4  2        4    2
             - 8*u *v + 28*u *y  - 48*u *v*y + 56*u *y  + 24*u *v  - 120*u *v*y

                   4  4       3  2          3    3       3  5       2  3
             + 70*u *y  + 96*u *v *y - 160*u *v*y  + 56*u *y  - 32*u *v

                    2  2  2        2    4       2  6         3           2  3
             + 144*u *v *y  - 120*u *v*y  + 28*u *y  - 64*u*v *y + 96*u*v *y

                       5        7       4       3  2       2  4        6    8
             - 48*u*v*y  + 8*u*y  + 16*v  - 32*v *y  + 24*v *y  - 8*v*y  + y )


             6      5        4         4  2       3           3  3       2  2
delta   =6/(u  + 6*u *y - 6*u *v + 15*u *y  - 24*u *v*y + 20*u *y  + 12*u *v
     1 1

                   2    2       2  4         2             3        5      3
             - 36*u *v*y  + 15*u *y  + 24*u*v *y - 24*u*v*y  + 6*u*y  - 8*v

                   2  2        4    6
             + 12*v *y  - 6*v*y  + y )


v   =1
 3 3


x   =1
 2 3


x   =1
 2 2


x   =0
 1 3


x   =0
 1 2


x   =0
 1 1

New 0-form conditions detected 

 - v
    3 3 3


 - x
    2 3 3


 - x
    2 2 3


 - x
    2 2 2


 - x
    1 3 3


 - x
    1 2 3


 - x
    1 2 2


 - x
    1 1 3


 - x
    1 1 2


 - x
    1 1 1

Solving 0-forms 
New equations: 

v     =0
 3 3 3


x     =0
 2 3 3


x     =0
 2 2 3


x     =0
 2 2 2


x     =0
 1 3 3


x     =0
 1 2 3


x     =0
 1 2 2


x     =0
 1 1 3


x     =0
 1 1 2


x     =0
 1 1 1

New 0-form conditions detected 

 - v
    3 3 3 3


 - x
    2 3 3 3


 - x
    2 2 3 3


 - x
    2 2 2 3


 - x
    2 2 2 2


 - x
    1 3 3 3


 - x
    1 2 3 3


 - x
    1 2 2 3


 - x
    1 2 2 2


 - x
    1 1 3 3


 - x
    1 1 2 3


 - x
    1 1 2 2


 - x
    1 1 1 3


 - x
    1 1 1 2


 - x
    1 1 1 1

Solving 0-forms 
New equations: 

v       =0
 3 3 3 3


x       =0
 2 3 3 3


x       =0
 2 2 3 3


x       =0
 2 2 2 3


x       =0
 2 2 2 2


x       =0
 1 3 3 3


x       =0
 1 2 3 3


x       =0
 1 2 2 3


x       =0
 1 2 2 2


x       =0
 1 1 3 3


x       =0
 1 1 2 3


x       =0
 1 1 2 2


x       =0
 1 1 1 3


x       =0
 1 1 1 2


x       =0
 1 1 1 1

New 0-form conditions detected 

 - v
    3 3 3 3 3


 - x
    2 3 3 3 3


 3*( - 4*f   *v + f )
          1 3      2
----------------------
        2*f*v


            2                                   2
 3*(2*f   *u  + 4*f   *u*y - 4*f   *v + 2*f   *y  + f )
       1 2         1 2          1 2        1 2       3
--------------------------------------------------------
                   2                  2
               f*(u  + 2*u*y - 2*v + y )


 - x
    2 2 2 2 3


 - x
    2 2 2 2 2


 - x
    1 3 3 3 3


 - x
    1 2 3 3 3


 - x
    2 2 3 3 1


 - x
    1 2 2 2 3


 - x
    1 2 2 2 2


 - x
    1 1 3 3 3


 - x
    1 1 2 3 3


 - x
    1 1 2 2 3


 - x
    1 1 2 2 2


 - x
    1 1 1 3 3


 - x
    1 1 1 2 3


 - x
    1 1 1 2 2


 - x
    1 1 1 1 3


 - x
    1 1 1 1 2


 - x
    1 1 1 1 1

Solving 0-forms 
New equations: 

v         =0
 3 3 3 3 3


x         =0
 2 3 3 3 3


x         =0
 2 2 3 3 1


x         =0
 2 2 2 2 3


x         =0
 2 2 2 2 2


x         =0
 1 3 3 3 3


x         =0
 1 2 3 3 3


x         =0
 1 2 2 2 3


x         =0
 1 2 2 2 2


x         =0
 1 1 3 3 3


x         =0
 1 1 2 3 3


x         =0
 1 1 2 2 3


x         =0
 1 1 2 2 2


x         =0
 1 1 1 3 3


x         =0
 1 1 1 2 3


x         =0
 1 1 1 2 2


x         =0
 1 1 1 1 3


x         =0
 1 1 1 1 2


x         =0
 1 1 1 1 1


      f
       2
f   =-----
 1 3  4*v


                 - f
                    3
f   =---------------------------
 1 2      2                  2
      2*(u  + 2*u*y - 2*v + y )

New 0-form conditions detected 

  - 4*f *v - 2*f *u - 2*f *y + 3*f
       1        2        2
-----------------------------------
                  2
               8*v


            2                              2             2
  - 8*f   *u *v - 16*f   *u*v*y + 16*f   *v  - 8*f   *v*y  + 3*f
       1 1            1 1             1 1         1 1
-----------------------------------------------------------------
                         2                  2
                  16*v*(u  + 2*u*y - 2*v + y )


              2  2                2                3             2  2         2
( - 8*f     *u *v  - 16*f     *u*v *y + 16*f     *v  - 8*f     *v *y  - 2*f *u
       1 1 3             1 1 3              1 1 3         1 1 3            2

                              2             2   2                  2
  - 4*f *u*y + 4*f *v - 2*f *y  - f *v)/(8*v *(u  + 2*u*y - 2*v + y ))
       2          2        2       3


         2                              2             2
 8*f   *u *v + 16*f   *u*v*y - 16*f   *v  + 8*f   *v*y  - 3*f
    1 1            1 1             1 1         1 1
--------------------------------------------------------------
                        2                  2
                 16*v*(u  + 2*u*y - 2*v + y )


               2                             2
       - 2*f *u  - 4*f *u*y + 4*f *v - 2*f *y  + 2*f *u + 2*f *y - 3*f
            1         1          1        1         3        3
----------------------------------------------------------------------------
     4      3        2        2  2                  3      2        2    4
 2*(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


              4                3                  2  2              2    2
( - 8*f     *u *v - 32*f     *u *v*y + 32*f     *u *v  - 48*f     *u *v*y
       1 1 2            1 1 2              1 1 2             1 1 2

                 2                    3              3              2  2
  + 64*f     *u*v *y - 32*f     *u*v*y  - 32*f     *v  + 32*f     *v *y
        1 1 2              1 1 2              1 1 2          1 1 2

                4       2                           2
  - 8*f     *v*y  - f *u  - 2*f *u*y + 2*f *v - f *y  - 8*f *v)/(8*v
       1 1 2         2         2          2      2         3

      4      3        2        2  2                  3      2        2    4
   *(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y ))

Solving 0-forms 
New equations: 

                 2                        2           2        2
f     =(3*(2*f *u *v + 4*f *u*v*y - 4*f *v  + 2*f *v*y  - 2*f*u  - 4*f*u*y
 1 1 3        1           1            1         1

                           2        2
            + 3*f*v - 2*f*y ))/(16*v

             3      2                  2            3
          *(u  + 3*u *y - 2*u*v + 3*u*y  - 2*v*y + y ))


                    2                        2           2      2
f     =(3*( - 4*f *u *v - 8*f *u*v*y + 8*f *v  - 4*f *v*y  - f*u  - 2*f*u*y
 1 1 2           1           1            1         1

                         2           5      4        3         3  2       2
            - 6*f*v - f*y ))/(16*v*(u  + 5*u *y - 4*u *v + 10*u *y  - 12*u *v*y

                    2  3        2           2        4      2          3    5
              + 10*u *y  + 4*u*v  - 12*u*v*y  + 5*u*y  + 4*v *y - 4*v*y  + y ))


                  3*f
f   =-----------------------------
 1 1        2                  2
      8*v*(u  + 2*u*y - 2*v + y )


          2                             2
    2*f *u  + 4*f *u*y - 4*f *v + 2*f *y  + 3*f
       1         1          1        1
f =---------------------------------------------
 3                   2*(u + y)


     - 4*f *v + 3*f
          1
f =-----------------
 2     2*(u + y)

New 0-form conditions detected 

              4  2              3  2                2  3              2  2  2
( - 8*f     *u *v  - 32*f     *u *v *y + 32*f     *u *v  - 48*f     *u *v *y
       1 1 1             1 1 1               1 1 1             1 1 1

                 3                  2  3              4              3  2
  + 64*f     *u*v *y - 32*f     *u*v *y  - 32*f     *v  + 32*f     *v *y
        1 1 1              1 1 1               1 1 1          1 1 1

              2  4         2                        2           2        2
  - 8*f     *v *y  + 3*f *u *v + 6*f *u*v*y - 6*f *v  + 3*f *v*y  - 3*f*u
       1 1 1            1           1            1         1

                            2      2
  - 6*f*u*y + 12*f*v - 3*f*y )/(8*v

      4      3        2        2  2                  3      2        2    4
   *(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y ))

Solving 0-forms 
New equations: 

f
 1 1 1

         2                        2         2      2                        2
  3*(f *u *v + 2*f *u*v*y - 2*f *v  + f *v*y  - f*u  - 2*f*u*y + 4*f*v - f*y )
      1           1            1       1
=-------------------------------------------------------------------------------
     2   4      3        2        2  2                  3      2        2    4
  8*v *(u  + 4*u *y - 4*u *v + 6*u *y  - 8*u*v*y + 4*u*y  + 4*v  - 4*v*y  + y )


                        4*f *v - 3*f
                   1       1               2
EDS({d f - f *omega  + --------------*omega
            1            2*(u + y)

                  2                             2
          - 2*f *u  - 4*f *u*y + 4*f *v - 2*f *y  - 3*f
               1         1          1        1                3
      + ------------------------------------------------*omega ,
                           2*(u + y)

                         3*f                   1
     d f  - -----------------------------*omega
        1          2                  2
             8*v*(u  + 2*u*y - 2*v + y )

                2                             2
          2*f *u  + 4*f *u*y - 4*f *v + 2*f *y  + 3*f
             1         1          1        1                 2
      + -----------------------------------------------*omega
             3      2                  2            3
         4*(u  + 3*u *y - 2*u*v + 3*u*y  - 2*v*y + y )

         4*f *v - 3*f
            1               3       1      2      3
      + --------------*omega },omega ^omega ^omega )
         8*v*(u + y)

characters ws;


{0,0,0}


clear v(i),omega(i);


clear F,x,Delta,gamma,v,y,u,omega;


off ranpos;





	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	%   Isometric embeddings of Ricci-flat R(4) in ISO(10)   %
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Determine the Cartan characters of a Ricci-flat embedding of R(4) into
% the orthonormal frame bundle ISO(10) over flat R(6).  Reference:
% Estabrook & Wahlquist, Class Quant Grav 10(1993)1851

% Indices

indexrange {p,q,r,s}={1,2,3,4,5,6,7,8,9,10},
      	   {i,j,k,l}={1,2,3,4},{a,b,c,d}={5,6,7,8,9,10};



% Metric for R10

pform g(p,q)=0;


g(p,q) := 0$

 g(-p,-q) := 0$

 g(-p,-p) := g(p,p) := 1$



% Hodge map for R4

pform epsilon(i,j,k,l)=0;


index_symmetries epsilon(i,j,k,l):antisymmetric;


epsilon(1,2,3,4) := 1;


       1 2 3 4
epsilon        := 1


% Coframe for ISO(10)
% NB index_symmetries must come after o(p,-q) := ... (EXCALC bug)

pform e(r)=1,o(r,s)=1;


korder index_expand {e(r)};


e(-p) := g(-p,-q)*e(q)$


o(p,-q) := o(p,r)*g(-r,-q)$


index_symmetries o(p,q):antisymmetric;



% Structure equations

flat_no_torsion := {d e(p) => -o(p,-q)^e(q),
      	       	    d o(p,q) => -o(p,-r)^o(r,q)};


                       p        p    q
flat_no_torsion := {d e  =>  - o   ^e ,
                                  q

      p q        p    r q
   d o    =>  - o   ^o   }
                   r


% Coframing structure

ISO := coframing({e(p),o(p,q)},flat_no_torsion)$


dim ISO;


55


% 4d curvature 2-forms

pform F(i,j)=2;


index_symmetries F(i,j):antisymmetric;


F(-i,-j) := -g(-i,-k)*o(k,-a)^o(a,-j);

         1 10  2 10    1 5  2 5    1 6  2 6    1 7  2 7    1 8  2 8    1 9  2 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 1 2

         1 10  3 10    1 5  3 5    1 6  3 6    1 7  3 7    1 8  3 8    1 9  3 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 1 3

         2 10  3 10    2 5  3 5    2 6  3 6    2 7  3 7    2 8  3 8    2 9  3 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 2 3

         1 10  4 10    1 5  4 5    1 6  4 6    1 7  4 7    1 8  4 8    1 9  4 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 1 4

         2 10  4 10    2 5  4 5    2 6  4 6    2 7  4 7    2 8  4 8    2 9  4 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 2 4

         3 10  4 10    3 5  4 5    3 6  4 6    3 7  4 7    3 8  4 8    3 9  4 9
f    := o    ^o     + o   ^o    + o   ^o    + o   ^o    + o   ^o    + o   ^o
 3 4



% EDS for vacuum GR (Ricci-flat) in 4d

GR0 := eds({e(a),epsilon(i,j,k,l)*F(-j,-k)^e(-l)},
	   {e(i)},
      	   ISO)$



% Find an integral element, and linearise

Z := integral_element GR0$

45 free variables 
39 free variables 
29 free variables 
21 free variables 

GRZ := linearise(GR0,Z)$



% This actually tells us the characters already:
%  {45-39,39-29,29-21,21} = {6,10,8,21}

% Get the characters and dimension at Z

characters GRZ;

Cauchy characteristics detected from characters 

{6,10,8,21}

dim_grassmann_variety GRZ;


134


% 6+2*10+3*8+4*21 = 134, so involutive

clear e(r),o(r,s),g(p,q),epsilon(i,j,k,l),F(i,j);


clear e,o,g,epsilon,F,Z;


indexrange 0;



			%%%%%%%%%%%%%%%%%%%%%%%%%%
			%   Janet's PDE system   %
			%%%%%%%%%%%%%%%%%%%%%%%%%%

% This is something of a standard test problem in analysing integrability
% conditions. Although it looks very innocent, it must be prolonged five
% times from the second jet bundle before reaching involution. The initial 
% equations are just
%
%     u   =w,    u   =u   *y + v
%      y y        z z  x x 

load sets;


off varopt;


pform {x,y,z,u,v,w}=0$



janet := contact(2,{x,y,z},{u,v,w})$


janet := pullback(janet,{u(-y,-y)=w,u(-z,-z)=y*u(-x,-x)+v})$



% Prolong to involution

involutive janet;


0

involution janet;

Prolongation using new equations: 

u     =u     *y + u    + v
 y z z  x x y      x x    y


u     =w
 y y z  z


u     =u     *y + v
 x z z  x x x      x


u     =w
 x y y  x

Reduction using new equations: 

         - v    - w   *y + w
            y y    x x      z z
u     =-------------------------
 x x y             2

Reduction using new equations: 

w     =v      + w     *y + 3*w
 y z z  y y y    x x y        x x

Prolongation using new equations: 

w       =v        + w       *y + 3*w
 y z z z  y y y z    x x y z        x x z


w       =v        + w       *y + 4*w
 y y z z  y y y y    x x y y        x x y


w       =v        + w       *y + 3*w
 x y z z  x y y y    x x x y        x x x


                                                 2
          2*u      - v     *y + 2*v    - w     *y  + w     *y
             x x x    x y y        x y    x x x       x z z
u       =-----------------------------------------------------
 x y z z                           2


u       =w
 x y y z  x z


u       =u       *y + v
 x x z z  x x x x      x x


           - v      - w     *y + w
              y y z    x x z      z z z
u       =-------------------------------
 x x y z                2


           - v      - w     *y + w
              x y y    x x x      x z z
u       =-------------------------------
 x x x y                2

Reduction using new equations: 

w
 z z z z

                                                           2
=2*u        - v       *y + 2*v      + v        - w       *y  + 2*w       *y
    x x x x    x x y y        x x y    y y z z    x x x x         x x z z


EDS({d u - u *d x - u *d y - u *d z,
            x        y        z

     d v - v *d x - v *d y - v *d z,
            x        y        z

     d w - w *d x - w *d y - w *d z,
            x        y        z

     d u  - u   *d x - u   *d y - u   *d z,
        x    x x        x y        x z

     d u  - u   *d x - w*d y - u   *d z,
        y    x y                y z

     d u  - u   *d x - u   *d y - (u   *y + v)*d z,
        z    x z        y z         x x

     d v  - v   *d x - v   *d y - v   *d z,
        x    x x        x y        x z

     d v  - v   *d x - v   *d y - v   *d z,
        y    x y        y y        y z

     d v  - v   *d x - v   *d y - v   *d z,
        z    x z        y z        z z

     d w  - w   *d x - w   *d y - w   *d z,
        x    x x        x y        x z

     d w  - w   *d x - w   *d y - w   *d z,
        y    x y        y y        y z

     d w  - w   *d x - w   *d y - w   *d z,
        z    x z        y z        z z

                            v    + w   *y - w
                             y y    x x      z z
     d u    - u     *d x + ----------------------*d y - u     *d z,
        x x    x x x                 2                   x x z

               v    + w   *y - w
                y y    x x      z z
     d u    + ----------------------*d x - w *d y - u     *d z,
        x y             2                   x        x y z

     d u    - u     *d x - u     *d y - (u     *y + v )*d z,
        x z    x x z        x y z         x x x      x

     d u    - u     *d x - w *d y
        y z    x y z        z

                                           2
          - 2*u    + v   *y - 2*v  + w   *y  - w   *y
               x x    y y        y    x x       z z
      + ----------------------------------------------*d z,
                              2

     d v    - v     *d x - v     *d y - v     *d z,
        x x    x x x        x x y        x x z

     d v    - v     *d x - v     *d y - v     *d z,
        x y    x x y        x y y        x y z

     d v    - v     *d x - v     *d y - v     *d z,
        x z    x x z        x y z        x z z

     d v    - v     *d x - v     *d y - v     *d z,
        y y    x y y        y y y        y y z

     d v    - v     *d x - v     *d y - v     *d z,
        y z    x y z        y y z        y z z

     d v    - v     *d x - v     *d y - v     *d z,
        z z    x z z        y z z        z z z

     d w    - w     *d x - w     *d y - w     *d z,
        x x    x x x        x x y        x x z

     d w    - w     *d x - w     *d y - w     *d z,
        x y    x x y        x y y        x y z

     d w    - w     *d x - w     *d y - w     *d z,
        x z    x x z        x y z        x z z

     d w    - w     *d x - w     *d y - w     *d z,
        y y    x y y        y y y        y y z

     d w    - w     *d x - w     *d y + ( - v      - w     *y - 3*w   )*d z,
        y z    x y z        y y z            y y y    x x y        x x

     d w    - w     *d x + ( - v      - w     *y - 3*w   )*d y - w     *d z,
        z z    x z z            y y y    x x y        x x         z z z

                                v      + w     *y - w
                                 x y y    x x x      x z z
     d u      - u       *d x + ----------------------------*d y - u       *d z,
        x x x    x x x x                    2                      x x x z

                                v      + w     *y - w
                                 y y z    x x z      z z z
     d u      - u       *d x + ----------------------------*d y
        x x z    x x x z                    2

      - (u       *y + v   )*d z,
          x x x x      x x

                 v      + w     *y - w
                  y y z    x x z      z z z
     d u      + ----------------------------*d x - w   *d y
        x y z                2                      x z

                                                   2
          - 2*u      + v     *y - 2*v    + w     *y  - w     *y
               x x x    x y y        x y    x x x       x z z
      + --------------------------------------------------------*d z,
                                   2

     d v      - v       *d x - v       *d y - v       *d z,
        x x x    x x x x        x x x y        x x x z

     d v      - v       *d x - v       *d y - v       *d z,
        x x y    x x x y        x x y y        x x y z

     d v      - v       *d x - v       *d y - v       *d z,
        x x z    x x x z        x x y z        x x z z

     d v      - v       *d x - v       *d y - v       *d z,
        x y y    x x y y        x y y y        x y y z

     d v      - v       *d x - v       *d y - v       *d z,
        x y z    x x y z        x y y z        x y z z

     d v      - v       *d x - v       *d y - v       *d z,
        x z z    x x z z        x y z z        x z z z

     d v      - v       *d x - v       *d y - v       *d z,
        y y y    x y y y        y y y y        y y y z

     d v      - v       *d x - v       *d y - v       *d z,
        y y z    x y y z        y y y z        y y z z

     d v      - v       *d x - v       *d y - v       *d z,
        y z z    x y z z        y y z z        y z z z

     d v      - v       *d x - v       *d y - v       *d z,
        z z z    x z z z        y z z z        z z z z

     d w      - w       *d x - w       *d y - w       *d z,
        x x x    x x x x        x x x y        x x x z

     d w      - w       *d x - w       *d y - w       *d z,
        x x y    x x x y        x x y y        x x y z

     d w      - w       *d x - w       *d y - w       *d z,
        x x z    x x x z        x x y z        x x z z

     d w      - w       *d x - w       *d y - w       *d z,
        x y y    x x y y        x y y y        x y y z

     d w      - w       *d x - w       *d y
        x y z    x x y z        x y y z

      + ( - v        - w       *y - 3*w     )*d z,
             x y y y    x x x y        x x x

     d w      - w       *d x + ( - v        - w       *y - 3*w     )*d y
        x z z    x x z z            x y y y    x x x y        x x x

      - w       *d z,
         x z z z

     d w      - w       *d x - w       *d y - w       *d z,
        y y y    x y y y        y y y y        y y y z

     d w      - w       *d x - w       *d y
        y y z    x y y z        y y y z

      + ( - v        - w       *y - 4*w     )*d z,
             y y y y    x x y y        x x y

     d w      - w       *d x + ( - v        - w       *y - 3*w     )*d y + (
        z z z    x z z z            y y y z    x x y z        x x z

                                                                     2
         - 2*u        + v       *y - 2*v      - v        + w       *y
              x x x x    x x y y        x x y    y y z z    x x x x

         - 2*w       *y)*d z,
              x x z z

     d u       ^d x + d u       ^d z
        x x x x          x x x z

          - v        - w       *y + w
             x x y y    x x x x      x x z z
      + -------------------------------------*d x^d y
                          2

         v        + w       *y - w
          x y y z    x x x z      x z z z
      + ----------------------------------*d y^d z,
                        2

                       1
     d u       ^d z + ---*d u       ^d x
        x x x x        y     x x x z

          - v        - w       *y + w                    v
             x y y z    x x x z      x z z z              x x x
      + -------------------------------------*d x^d y + --------*d x^d z
                         2*y                               y

         v        + w       *y - w
          x x y y    x x x x      x x z z
      + ----------------------------------*d y^d z,
                        2

                       y                    1
     d u       ^d z - ---*d v       ^d z + ---*d v       ^d y
        x x x x        2     x x y y        2     y y y z

                               2
         1                    y                     y
      + ---*d v       ^d z - ----*d w       ^d z + ---*d w       ^d y
         2     y y z z        2      x x x x        2     x x y z

                                                 3*w
                            1                       x x x z
      + y*d w       ^d z + ---*d w       ^d x + ------------*d x^d y
             x x z z        2     x z z z            2

                            v        - 2*w       *y - w
                             x x y y      x x x x      x x z z
      + v       *d x^d z + ------------------------------------*d y^d z,
         x x x y                            2

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x x x          x x x y          x x x z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x x y          x x y y          x x y z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x x z          x x y z          x x z z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x y y          x y y y          x y y z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x y z          x y y z          x y z z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x x z z          x y z z          x z z z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x y y y          y y y y          y y y z

     d v       ^d y + y*d w       ^d y + d w       ^d x + d w       ^d z
        x y y y            x x x y          x x z z          x z z z

      + 3*w       *d x^d y - 3*w       *d y^d z,
           x x x x              x x x z

     d v       ^d z + y*d w       ^d z + d w       ^d x + d w       ^d y
        x y y y            x x x y          x x y z          x y y z

      + 3*w       *d x^d z + 4*w       *d y^d z,
           x x x x              x x x y

     d v       ^d x + d v       ^d y + d v       ^d z,
        x y y z          y y y z          y y z z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x y z z          y y z z          y z z z

     d v       ^d x + d v       ^d y + d v       ^d z,
        x z z z          y z z z          z z z z

     d v       ^d z + y*d w       ^d z + d w       ^d x + d w       ^d y
        y y y y            x x y y          x y y z          y y y z

      + 4*w       *d x^d z + 5*w       *d y^d z,
           x x x y              x x y y

     d w       ^d x + d w       ^d y + d w       ^d z,
        x x x x          x x x y          x x x z

     d w       ^d x + d w       ^d y + d w       ^d z,
        x x x y          x x y y          x x y z

     d w       ^d x + d w       ^d y + d w       ^d z,
        x x x z          x x y z          x x z z

     d w       ^d x + d w       ^d y + d w       ^d z,
        x x y y          x y y y          x y y z

     d w       ^d x + d w       ^d y + d w       ^d z},d x^d y^d z)
        x y y y          y y y y          y y y z

involutive ws;


1


% Solve the homogeneous system, for which the
% involutive prolongation is completely integrable

fdomain u=u(x,y,z),v=v(x,y,z),w=w(x,y,z);



janet := {@(u,y,y)=0,@(u,z,z)=y*@(u,x,x)};


janet := {@   u=0,@   u=@   u*y}
           y y     z z   x x

janet := involution pde2eds janet$

Prolongation using new equations: 

u     =u     *y + u
 y z z  x x y      x x


u     =0
 y y z


u     =u     *y
 x z z  x x x


u     =0
 x y y

Reduction using new equations: 

u     =0
 x x y

Prolongation using new equations: 

u       =u
 x y z z  x x x


u       =0
 x y y z


u       =u       *y
 x x z z  x x x x


u       =0
 x x y z


u       =0
 x x x y

Reduction using new equations: 

u       =0
 x x x x

Prolongation using new equations: 

u         =0
 x x x z z


u         =0
 x x x y z


u         =0
 x x x x z



% Check if completely integrable
if frobenius janet then write "yes" else write "no";


yes

length one_forms janet;


12


% So there are 12 constants in the solution: there should be 12 invariants

length(C := invariants janet);


12

solve(for i:=1:length C collect
         part(C,i) = mkid(k,i),coordinates janet \ {x,y,z})$


S := select(lhs ~q = u,first ws);


             3             2                                     3             3
s := {u=(k1*x  + 3*k1*x*y*z  - 6*k10*y*z - 6*k11 - 6*k12*z - k2*x *z - k2*x*y*z

                                          2           3                    2
          - 6*k3*x*y*z - 6*k4*x*y - 3*k5*x *z - k5*y*z  - 6*k6*x*z - 3*k7*x

                    2
          - 3*k7*y*z  - 6*k8*x - 6*k9*y)/6}


% Check solution
mkdepend dependencies;


sub(S,{@(u,y,y),@(u,z,z)-y*@(u,x,x)});


{0,0}


clear u(i,j),v(i,j),w(i,j),u(i),v(i),w(i);


clear x,y,z,u,v,w,C,S;



end;


Time for test: 1839 ms, plus GC time: 141 ms
@@@@@ Resources used: (1 21 149 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edsexptl.red0000644000175000017500000002115211526203062023604 0ustar  giovannigiovannimodule edsexptl;

% Experimental (algebraic mode) operators

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These procedures need the other packages loaded during compilation

load_package 'xideal;

%%%% Characteristic variety, symbol relations and symbol matrix

Comment. At present, algebraic routines.

endcomment;

fluid '(!*varopt !*arbvars xvars!* !*allbranch);


symbolic operator indexnames;
symbolic procedure indexnames u;
   begin
   u := makelist uniqids foreach k in getrlist u collect !*a2k k;
   apply1('indexrange,{{'equal,gensym(),u}});
   return u;
   end;


algebraic procedure symbol_relations(S,name);
   % S:eds, name:id -> symbol_relations:list of 1-form
   begin scalar tbl,ix,sys,pis,!*varopt,!*arbvars;
   pform name(i,j) = 1;
   tbl := tableau S;
   ix := indexnames independence S;
   for i:=1:first length tbl do
      indexrange !!symbol!!index=i;
   pis := for i:=1:first length tbl collect
      foreach j in ix collect name(i,-j);
   sys := for i:=1:first length tbl join
      for j:=1:length ix collect (tbl(i,j) - part(pis,i,j));
   pis := foreach l in pis join l;
   sys := first solve(sys,append(cobasis s,pis));
   sys := foreach x in sys join
      if lhs x member pis then {lhs x - rhs x} else {};
   return sys;
   end;


algebraic procedure symbol_matrix(S,name);
   % S:eds, name:id -> symbol_matrix:matrix of 0-form
   begin scalar sys,wlist,n;
   pform name(i) = 0,{!!symbol!!pi(i,j),!!symbol!!w(i)}=1;
   n := first length tableau S;
   wlist := for i:=1:n collect !!symbol!!w(i);
   sys := symbol_relations(S,!!symbol!!pi);
   rl := for i:=1:n join
      foreach j in indexnames independence S collect
          make_rule(!!symbol!!pi(i,-j),!!symbol!!w(i)*name(-j));
   let rl;
%   sys := (sys where rl);
   sys := sys;
%   write showrules !!symbol!!pi;
   clearrules rl;
   matrix !!symbol!!mat(length sys,length wlist);
   for i:=1:length sys do
      for j:=1:length wlist do
         !!symbol!!mat(i,j) := coeffn(part(sys,i),part(wlist,j),1);
   return !!symbol!!mat;
   end;


algebraic procedure characteristic_variety(S,name);
   % S:eds, name:id -> characteristic_variety:{list of 0-form,list of
   % variable}
   begin scalar ix,m,sys;
         scalar xvars!*;  % make all 0-forms coefficients
   ix := indexnames independence S;
   m := symbol_matrix(S,name);
   if first length m > second length m then m := tp m;
   for i:=1:second length m do
      indexrange symbol!!index!!=i;
   wlist := for i:=1:second length m collect !!symbol!!w(i);
   www := 1;
   for i:=1:first length m do
      www := (for j:=1:length wlist sum m(i,j)*!!symbol!!w(j))^www;
   return {excoeffs www,foreach i in ix collect name(-i)};
   end;


algebraic procedure make_rule(lh,rh);
   lh => rh;


%%% Invariants, or first integrals.

fluid '(!*edsdebug print_ fname_ time_ xvars!* !*allbranch !*arbvars);


mkform!*('eds!:t,0);

algebraic procedure edsorderp(x,y);
   % Just a hook for sort
   if ordp(x,y) then 1 else 0;

put('invariants,'psopfn,'invariants);

symbolic procedure invariants u;
   if length u = 2 then
      (algebraic invariants0(x,y)) where x=car u, y=cadr u
   else if length u = 1 then
      (algebraic invariants0(x,y)) where x=car u, y=makelist nil
   else
      rederr "Wrong number of arguments to invariants";


algebraic procedure invariants0(S,C);
   begin scalar ans,inv,cfrm,Z,xvars!*;
   load_package odesolve,crack;
   % Update for CRACK version 1-Dec-2002
   setcrackflags();
   cfrm := coframing();
   if part(S,0) = eds then
   << set_coframing S;
      if C = {} then C := coordinates S;
      S := systemeds S >> % Use systemeds rather than system for
                          % compiler.
   else
      S := xauto S;
   if C = {} then C := reverse sort(coordinates S,edsorderp);
   Z := for a:=1:length S collect lisp mkform!*(mkid('eds!:u,a),0);
   ans := foliation(S,C,Z);
   inv := solve(ans,Z);
   if length Z = 1 then
      inv := foreach x in inv collect {x};
   if lisp !*edsdebug then write "Constants";
   if lisp !*edsdebug then write inv;

   if length inv neq 1 then
      rederr "Not a unique solution";

   set_coframing cfrm;
   return foreach x in first inv collect rhs x;
   end;


algebraic procedure foliation(S,C,Z);
   begin scalar r,n,x,S0,Z0,g,Q,f,f0;
               scalar print_,fname_,time_,!*allbranch,!*arbvars,xvars!*;
   % Constants
   r := length S;
   n := length C;
   fname_ := 'eds!:c;
   % Deal with errors and end case
   if r > n then
      rerror(eds,000,"Not enough coordinates in foliation");
   if r neq length Z then
      rerror(eds,000,"Wrong number of invariant labels in foliation");
   if r = n then
   << g := for a:=1:r collect part(C,a) = part(Z,a);
      lisp edsdebug("Intermediate result",g,'prefix);
      return g >>;
   % Choose truncation
   S0 := {}; Z0 := {};
   while length S0 < r do
   << x := first C;
      C := rest C;
      Z0 := x . Z0;
      S0 := xauto(S xmod {d x}) >>;
   C := append(C,rest Z0);
   lisp edsdebug("Truncating coordinate : ",x,'prefix);
   % Compute foliation for truncation
   g := foliation(S0,C,Z);
   % Calculate ODE
   foreach y in Z do
   << lisp(y := !*a2k y); fdomain y=y(eds!:t) >>;
   S := pullback(S,g);
   S := pullback(S,{x = eds!:t});
   Q := foreach f in S collect @eds!:t _| f;
   Q := solve(Q,foreach y in Z collect @(y,eds!:t));
   if r neq 1 then Q :=  first Q;
   Q := foreach f in Q collect (lhs f - rhs f);
   Q := sub(partdf=df,Q);
   lisp edsdebug("CRACK ODE",Q,'prefix);
   % Solve ODE
   Q := crack(Q,{},Z,{});
   % Restore 0-form properties of Z (cleared by CRACK)
   foreach y in Z do
      << lisp(y := !*a2k y); lisp mkform!*(y, 0) >>;
   lisp edsdebug("CRACK solution",Q,'prefix);
   % Analyse result for the general solution
   f := {};
   while Q neq {} do
   << f := first Q; Q := rest Q;
      Z0 := third f;
      if first f = {} and length Z0 = r then Q := {}
      else if length Z0 > r then
               if length(f0 := solve(first f,Z)) = 0 then f := {}
               else
               << if r = 1 then f0 := {{first f0}};
            Z0 := foreach v in Z0 join
               if v member Z then {} else {v};
            f := {{},append(second f,first f0),Z0};
             Q := {} >>
      else f := {} >>;
   foreach y in Z do
      << lisp(y := !*a2k y); remfdomain y >>;
   if f = {} then
      rerror(eds,000,"Intermediate ODE general solution not found");
   % Compose general solution with truncated foliation
   g := sub(second f,g);
   f := (eds!:t = x) . for a := 1:r collect part(Z0,a) = part(Z,a);
   g := sub(f,g);
   lisp edsdebug("Intermediate result",g,'prefix);
   return g;
   end;


%%% Homotopy operator

algebraic procedure poincare df;
   % with df a closed p-form POINCARE returns a (p-1)-form f
   % satisfying df=d f.
   begin scalar f;
   pform !!lambda!! = 0;
   f := sub(for each c in coordinates df collect c = c * !!lambda!!,df);
%   f := sub(for each c in allcoords df collect c = c * !!lambda!!,df);
   f := @(!!lambda!!) _| f;
   f := int(f,!!lambda!!);
   f := sub(!!lambda!! = 1,f) - sub(!!lambda!! = 0,f);
%   if d f - df neq 0 then write "error in POINCARE";
   return reval f;
   end;


%%% Integrability conditions

put('integrability,'rtypefn,'quotelist);
put('integrability,'listfn,'evalintegrability);

symbolic procedure evalintegrability(s,v);
   % s:eds|rlist, v:bool -> evalintegrability:rlist
   if edsp(s := reval car s) then
      !*sys2a1(nonpfaffpart eds_sys edscall closure s,v)
   else
      algebraic append(s xmod one_forms s,d s xmod one_forms s);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edsnorml.red0000644000175000017500000002003711526203062023600 0ustar  giovannigiovannimodule edsnormal;

% Converting exterior systems to internal form

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. The next section contains routines for putting an EDS into
"normal" form. An EDS S is in "normal" form if

***   1) S contains no 0-forms,                *** removed 27/4/95
   2) the 1-forms {theta(a)} in S satisfy
               lc theta(a) = 1
         lpow theta(a) in xpows theta(b) iff a = b.
   3) the 1-forms {omega(i)} in eds_ind S are reduced mod {theta(a)}
      and satisfy
               trc omega(i) = 1
         trpow omega(i) in xpows omega(j) iff i = j
      where trc/trpow mean trailing coefficient/power.
   4) S\{theta(a)} is in normal form mod {theta(a)}.

If S satisfies 1, it is "generated in positive degree". If S satisfies
2, and 3, it is in "solved" form. If S satisfies 4, it is "reduced".

endcomment;

fluid '(cfrmrsx!* !*edssloppy pullback_maps xvars!* kord!*);


symbolic procedure normaleds s;
   % s:eds -> normaleds:eds
   % Bring s into normal form as far as possible.
   if normaledsp s then s
%   else if emptyedsp(s := solvededs s) then s
%   else positiveeds sorteds reducededs s;
   else sorteds reducededs solvededs s;


symbolic procedure normaledsp s;
   % s:eds -> normaledsp:bool
   solvededsp s and
   reducededsp s;
%   null scalarpart eds_sys s;


put('lift,'edsfn,'positiveeds);
put('lift,'rtypefn,'getrtypecar);

symbolic procedure positiveeds s;
   % s:eds -> positiveeds:xeds
   % Bring s into positive form as far as possible.
   begin scalar v,c,s1;
   v := foreach f in scalarpart eds_sys s collect lc f;
   if null v then return s;
   edsverbose("Solving 0-forms",nil,nil);
   eds_sys s := setdiff(eds_sys s,v);
   c := reverse setdiff(edscrd s,edsindcrd s);
   c := edsgradecoords(c,geteds(s,'jet0));
   v := edssolvegraded(v,c,cfrm_rsx eds_cfrm s);
   s := purgexeds makelist
      if null v then
               << edsverbose("System inconsistent",nil,nil); {}>>
      else foreach strata in v collect
          if null car strata then
               << edsverbose("Couldn't solve 0-forms",cdr strata,'sq);
            strata := foreach q in cdr strata collect 1 .* q .+ nil;
            augmentsys(s,strata) >>
         else
         << edsverbose("New equations:",cadr strata,'map);
%%%         pullback_maps:= append(pullback_maps,{!*rmap2a cdr strata});
            s1 := pullback0(s,cdr strata);           % might add 0-forms
            if null scalarpart eds_sys s1 then s1
            else edscall positiveeds s1 >>;          % so go round again
   return s;
   end;


flag('(reduced solved),'hidden); % non-printing and purgeable


symbolic procedure reducededs s;
   % s:eds -> reducededs:eds
   % Bring s into reduced form as far as possible.
   % Changes background coframing.
   if knowntrueeds(s,'reduced) then s else
   begin scalar m,p,q;
   m := setcfrm eds_cfrm!* s;
   p := solvedpart pfaffpart eds_sys s;
   q := foreach f in setdiff(eds_sys s,p) join
                 if f := xreduce(f,p) then
               {if cfrmnowherezero numr lc f then xnormalise f else f};
   eds_sys s := append(p,q);
   flagtrueeds(s,'reduced);
   return s;
   end;


symbolic procedure reducededsp s;
   % s:eds -> reducededsp:bool
   knowntrueeds(s,'reduced);


symbolic procedure solvededs s;
   % s:eds -> solvededs:eds
   % Bring s into solved form as far as possible.
   % Local variables:
   %    m  - coframing for s
   %    n  - external background coframing
   %    p  - solved part of 1-forms in s
   %    q  - unsolved part of 1-forms in s
   %    z  - 0-forms picked up from 1-forms in s
   %    i  - independence 1-forms
   %    ik - independent kernels (cf indkrns)
   %    dk - dependent kernels (cf depkrns)
   %    pk - principal kernels (cf prlkrns)
   %    kl - cobasis (cf edscob)
   if knowneds(s,'solved) then s else
   begin scalar m,n,p,q,z,i,ik,dk,pk,kl;
   m := copycfrm eds_cfrm!* s;
   % Set up coframing and initial ordering
   i := xautoreduce eds_ind s;   % check if indkrns are obvious
   i := if !*edssloppy or singleterms i then reverse lpows i else {};
   kl := append(setdiff(cfrm_cob m,i),i);
   cfrm_cob m := kl;
   n := setcfrm m;
   % Put 1-forms into solved form as far as possible
   edsdebug("Solving Pfaffian subsystem",nil,nil);
   q := solvepfsys1(pfaffpart eds_sys s,
                                 if !*edssloppy then setdiff(cfrm_cob m,i));
   p := car q;
   dk := lpows p;
   % Put independence 1-forms into solved form mod p
   edsdebug("Solving independence forms",nil,nil);
   i := solvepfsys1(foreach f in eds_ind s join
                                           if f := xreduce(xreorder f,p) then {f},
                      if !*edssloppy then i);
   if length eds_ind s > length car i + length cadr i then
      return <>;
   ik := lpows car i;
   % Check for f(i)*omega(i) 1-forms from q
   q := foreach f in cadr q join
                 if xreduce(f := xreorder f,car i) then {f}
           else
            <>;
   if z then edsverbose("New 0-form conditions detected",z,'sys);
   % Set final ordering
   pk := setdiff(kl,append(dk,ik));
   kl := append(dk,append(pk,ik)); % dep > prl > ind
   updkordl kl;
   % Construct final eds
   m := copycfrm eds_cfrm s;
   s := copyeds s;
   eds_sys s :=
      xreordersys append(z,append(p,append(q,nonpfaffpart eds_sys s)));
   eds_ind s := xreordersys append(car i,cadr i);
   cfrm_cob m := kl;
   eds_cfrm s := m;
   if !*edssloppy then eds_cfrm s := updatersx eds_cfrm s;
   % Fix flags
   if q or cadr i then flagfalseeds(s,'solved)
   else flagtrueeds(s,'solved);
   rempropeds(s,'reduced);
   if z then remtrueeds(s,'closed);
   remkrns s;
   setcfrm n;
   return s;
   end;


symbolic procedure xreordersys p;
   % p:sys -> xreordersys:sys
   foreach f in p collect xreorder f;


symbolic procedure solvededsp s;
   % s:eds -> solvededsp:bool
   knowntrueeds(s,'solved);


symbolic procedure reordereds s;
   % s:eds -> reordereds:eds
   % Reorder s according to current kernel order as far as possible.
   begin scalar r,k;
   r := copyeds s;
   k := rightunion(kord!*,edscob r);
   eds_sys r := sortsys(xreordersys eds_sys r,k);
   eds_ind r := sortsys(xreordersys eds_ind r,k);
   eds_cfrm r := reordercfrm eds_cfrm r;
   return if r = s then s else normaleds r;
   end;


symbolic procedure sorteds s;
   % s:eds -> sorteds:eds
   begin scalar k;
   s := copyeds s;
   k := edscob s;
   eds_sys s := sortsys(eds_sys s,k);
   eds_ind s := sortsys(eds_ind s,k);
   return s;
   end;


symbolic procedure sortsys(s,c);
   % s:sys, c:cob -> sortsys:sys
   % sort forms by degree, should add some more stuff.
   reversip sort(s,function pfordp)
      where kord!* = reverse c;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edsequiv.red0000644000175000017500000000711511526203062023604 0ustar  giovannigiovannimodule edsequiv;

% Check if EDS structures are equivalent

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(xtruncate!*);


infix equiv;
precedence equiv,equal;

symbolic operator equiv;
symbolic procedure equiv(u,v);
   if cfrmp u then cfrmp v and equalcfrm(u,v)
   else if edsp u then edsp v and edscall equaleds(u,v)
   else rerror(eds,000,"Don't know how to test equivalence");


symbolic procedure equalcfrm(m,n);
   % m,n:cfrm -> equalcfrm:bool
   equall(cfrm_cob m,cfrm_cob n) and
   equall(cfrm_crd m,cfrm_crd n) and
   equaldrv(cfrm_drv m,cfrm_drv n) and
   equalrsx(cfrm_rsx m,cfrm_rsx n);


symbolic procedure equall(u,v);
   % u,v:list -> equall:bool
   (length u = length v) and subsetp(u,v);


symbolic procedure equaldrv(d1,d2);
   % d1,d2:drv -> equaldrv:bool
   equall(d1,d2) or
   equall(foreach r in d1 collect cadr r,
                foreach r in d2 collect cadr r) and
   equall(foreach r in d1 collect resimp simp!* caddr r,
                foreach r in d2 collect resimp simp!* caddr r);


symbolic procedure equalrsx(r1,r2);
   % r1,r2:rsx -> equalrsx:bool
   equall(r1,r2) or
   equall(foreach r in r1 collect absf numr simp!* r,
                foreach r in r2 collect absf numr simp!* r);


symbolic procedure equaleds(s1,s2);
   % s1,s2:eds -> equaleds:bool
   equalcfrm(eds_cfrm s1,eds_cfrm s2) and
   equivsys(eds_sys s1,eds_sys s2) and
   equivsys(eds_ind s1,eds_ind s2);


symbolic procedure equivsys(p,q);
   % p,q:sys -> equivsys:bool
   % Assumes background coframing set up correctly.
   equall(p := xreordersys p,q := xreordersys q) or
   begin scalar p1,q1,g,xtruncate!*; integer d;
   p1 := foreach f in setdiff(p,q) join
      if f := xreduce(f,q) then {f};
   q1 := foreach f in setdiff(q,p) join
      if f := xreduce(f,p) then {f};
   if null p1 and null q1 then return t;
   if scalarpart p1 or scalarpart q1 then
      rerror(eds,000,"Can't compare systems with 0-forms");
   if p1 then
   << d := 0; foreach f in p1 do d := max(d,degreepf f);
      xtruncate!* := d; g := xidealpf q;
      p1 := foreach f in p1 join
               if f := xreduce(f,g) then {f}>>;
   if p1 then return nil;
   if q1 then
   << d := 0; foreach f in q1 do d := max(d,degreepf f);
      xtruncate!* := d; g := xidealpf p;
      q1 := foreach f in q1 join
               if f := xreduce(f,g) then {f}>>;
   return null q1;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edscfrm.red0000644000175000017500000005742411526203062023412 0ustar  giovannigiovannimodule edscfrm;

% Coframing structure for EDS

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. An EDS coframing is stored in a list:

        cfrm    ::= {'!!cfrm!!,cob,crd,drv,rsx}
        cob     ::= list of kernel
        crd     ::= list of kernel
        drv     ::= list of rule
        rsx         ::= list of prefix (mostly !*sq)

The procedure !*a2cfrm allows a number of algebraic quantities to be
turned into coframings. These quantities will be collectively termed
cfrmdef's.

        cfrmdef ::=  cfrm|eds|rlist of pform

endcomment;


fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!* xvars!* kord!*);
global '(!*sqvar!*);


% Type definition


put('cfrm,'tag,'!!cfrm!!);
put('!!cfrm!!,'rtypefn,'quotecfrm);

symbolic procedure quotecfrm u; 'cfrm;


% Evaluation interface


put('cfrm,'evfn,'cfrmeval);

symbolic procedure cfrmeval(u,v);
   % u:prefix, v:bool -> cfrmeval:prefix
   % v is t for reval, nil for aeval. Here it is ignored (and abused as
   % a local variable!).  u is either an id with an avalue whose car has
   % rtype cfrm or a list with rtype cfrm. This routine differs from
   % most evfn's in that the argument list is evaluated prior to calling
   % a cfrmfn.
   if atom u then
      cfrmeval(if flagp(u,'share) then eval u
              else cadr get(u,'avalue),v)
   else if cfrmp u then u
   else if v := get(car u,'cfrmfn) then
      if flagp(car u,'nospread) then cfrmprotect{v,revlis cdr u}
      else cfrmprotect(v . revlis cdr u)
   else rerror(eds,000,{"Illegal operation on coframings"});


symbolic procedure cfrmprotect u;
   % u:prefix -> cfrmprotect:prefix
   % Protected evaluation environment for
   % operations on coframings.
   begin scalar m,ok,od;
         scalar xvars!*;
   % If one of the arguments is cfrm, take the last one
   foreach v in cdr u do if cfrmp v then m := v;
   % Save environment and adjust for cfrm calculation.
   ok := kord!*; od := append(get('d,'kvalue),nil); % copy pairs
   if m then m := setcfrm m;
   u := errorset!*(car u . foreach j in cdr u collect mkquote j,t);
   % Restore environment
   if m then setcfrm m;
   setkorder ok; if od then put('d,'kvalue,od) else remprop('d,'kvalue);
   if errorp u then error1()
   else return car u;
   end;


% Constructors and tests


symbolic procedure mkcfrm u;
   % tag u as cfrm
   '!!cfrm!! . u;


symbolic procedure copycfrm u;
   % copy pairs in u to allow destructive operations
   foreach p in u collect p;


symbolic procedure cfrmp u;
   % u:any -> cfrmp:bool
   eqcar(u,'!!cfrm!!);


symbolic procedure emptycfrm;
   % -> emptycfrm:cfrm
   mkcfrm{{},{},{},{}};


% Global background coframing


put('set_coframing,'psopfn,'setcfrmeval);

symbolic procedure setcfrmeval u;
   % u:{cfrm|nil} -> setcfrmeval:cfrm
   begin scalar m;
   u :=
      if null u or (u = {nil}) then setcfrm emptycfrm()
      else if cfrmp(m := reval car u) then setcfrm m
      else if edsp m then setcfrm eds_cfrm m
      else typerr(u,'cfrm);
   rmsubs();
   return u;
   end;


symbolic procedure setcfrm m;
   % m:cfrm -> setcfrm:cfrm
   % Set up m as background coframing, returning old one.
   % NB. Changes kernel order and let rules.
   begin scalar n;
   n := getcfrm();
   if m = n then return n;
   cfrmswapkord(cfrm_cob m,cfrm_cob n);
   cfrmswaprules(cfrm_drv m,cfrm_drv n);
   cfrmcob!* := cfrm_cob m;
   cfrmcrd!* := cfrm_crd m;
   cfrmdrv!* := cfrm_drv m;
   cfrmrsx!* := (foreach p in cfrm_rsx m collect
                               xpartitop p) where xvars!* = cfrm_crd m;
   return n;
   end;


symbolic procedure cfrmswapkord(new,old);
   % new,old:list of kernel -> cfrmswapkord:list of kernel
   % Swap old for new in kernel ordering.  New kernels come first.
   % Return old kernel ordering.
   setkorder append(new,setdiff(kord!*,append(new,old)));


symbolic procedure cfrmswaprules(new,old);
   % new,old:list of rules -> cfrmswaprules:nil
   % Swap the current rules given by old for those contained in
   % new. Since these rules will be removed before returning to the
   % outside, try to preserve !*sqvar!*. This may cause trouble.
   begin scalar sq;
   if new = old then return;
   sq := !*sqvar!*;
   if old then rule!-list(old,nil);
   if new then rule!-list(new,t);
   !*sqvar!* := sq;
   car !*sqvar!* := t;
   end;


symbolic procedure getcfrm();
   % -> getcfrm:cfrm
   % Get background coframing.
   mkcfrm{cfrmcob!*,cfrmcrd!*,cfrmdrv!*,
                    foreach f in cfrmrsx!* collect !*pf2a f};



% Input interface


put('coframing,'rtypefn,'quotecfrm);
put('coframing,'cfrmfn,'!*a2cfrm);
flag('(coframing),'nospread);

symbolic procedure !*a2cfrm u;
   % u:nil|{cfrmdef}|{xeds}|list of cpt(see below) -> !*a2cfrm:cfrm
   % With no arguments, return the background coframing.  For a cfrm,
   % just return it (this redundancy allows !*a2cfrm to be called from
   % contact etc).  For an eds or xeds, just return the associated
   % coframing(s).  For a list of pforms, deduce the coframing
   % structure required to sustain them.  Otherwise, the coframing is
   % specified by a list of its components.
   if null u then getcfrm()
   else if length u = 1 then
      if cfrmp car u then
         car u
      else if edsp car u then
          eds_cfrm car u
      else if xedsp car u then
          makelist foreach s in getrlist car u collect eds_cfrm s
      else
          !*sys2cfrm !*a2sys car u
   else  !*a2cfrm1 u;


symbolic procedure !*a2cfrm1 u;
   % u:list of cpt -> !*a2cfrm1:cfrm
   %       where cpt is one of
   %       cob - list of 1-form kernel
   %       crd - list of 0-form kernel
   %       rsx - list of prefix inequality
   %       drv - list of rule
   begin scalar cob,crd,drv,rsx;
   % Read through arguments
   foreach l in u do
      if null(l := getrlist indexexpandeval {l}) then nil
      else if eqexpr car l then drv := l
      else if eqcar(car l,'neq) then rsx := l
      else if xdegree car l = 1 then cob := l
      else if xdegree car l = 0 then crd := l
      else rerror(eds,000,"Badly formed coframing");
   % Check correctness of each item and convert to desired type
   cob := foreach k in cob collect
      if xdegree(k := !*a2k k) = 1 then k
      else typerr(k,"cobasis element");
   crd := foreach k in crd collect
      if xdegree(k := !*a2k k) = 0 and
         xvarp k where xvars!* = t then k
      else typerr(k,"coordinate");
   drv := foreach r in drv collect
      if eqexpr r then r
      else typerr(r,"structure equation");
   rsx := foreach f in rsx collect
      if eqcar(f,'neq) then aeval {'difference,cadr f,caddr f}
      else typerr(f,"restriction (only neq allowed)");
   return checkcfrm mkcfrm{cob,crd,drv,rsx};
   end;


symbolic procedure !*sys2cfrm s;
   % s:sys -> !*sys2cfrm:cfrm
   % Return coframing suitable for set of pforms s.  Error if variables
   % of other degrees found explicitly in s. All structure equations are
   % checked for new forms and restrictions.
   begin scalar crd,cob,drv,rsx;
   while s do
      begin scalar new;
      foreach k in kernelspf car s do
         if not(k memq crd or k memq cob) and exformp k then
                  if xdegree k = 0 then
               if assoc(k,depl!*) or eqcar(k,'partdf) or
                  not(xvarp k where xvars!* = t) then % function
                         foreach p in xpows exdfk k do new := !*k2pf p . new
               else
               << crd := k . crd;
                          new := exdfk k . new;
                          if car new neq !*k2pf {'d,k} then
                            drv := {'replaceby,{'d,k},!*pf2a car new} . drv >>
                  else if xdegree k = 1 then
            << cob := k . cob;
               if not exact k then
               << new := exdfk k . new;
                          if car new neq !*k2pf {'d,k} then
                            drv := {'replaceby,{'d,k},!*pf2a car new} . drv
                          else
                            new := cdr new >>
               else if not(cadr k memq crd) then
                  crd := cadr k . crd >>
                  else typerr(k,"0-form or 1-form");
      foreach q in xcoeffs car s do
         if not freeoffl(denr q,crd) then
            rsx := mk!*sq !*f2q denr q . rsx;
      s := append(cdr s,new);
      end;
   return purgecfrm mkcfrm{sort(cob,'termordp),sort(crd,'termordp),drv,
                           rsx}
   end;


% Output interface


put('!!cfrm!!,'prifn,'cfrmprint);
put('!!cfrm!!,'fancy!-reform,'!*cfrm2a);
put('cfrm,'texprifn,'texpricfrm);
%put('cfrm,'prepfn,'!*cfrm2a);


symbolic procedure cfrmprint m;
   % m:cfrm -> cfrmprint:bool
   % if already in external format, use inprint
   maprin !*cfrm2a m;


symbolic procedure !*cfrm2a m;
   % m:cfrm -> !*cfrm2a:prefix
      "coframing" .
         {makelist cfrm_cob m,
          makelist cfrm_crd m,
          makelist foreach r in cfrm_drv m collect !*rule2prefix r,
          makelist foreach f in cfrm_rsx m collect {'neq,reval f,0}};


symbolic procedure !*rule2prefix r;
   car r . foreach a in cdr r collect
      if eqcar(a,'!*sq) then prepsq!* cadr a else a;


symbolic procedure texpricfrm(u,v,w);
   % Have to hide coframing from TRI's makeprefix
   texvarpri('texpriedsop . !*cfrm2a u,v,w);


symbolic procedure texpricfrm(u,v,w);
   % Have to hide the coframing from TRI's makeprefix
   % but not from TRIX's makeprefix.
   texvarpri(
      if get('hodge,'texname) then !*cfrm2a u
      else 'texpriedsop . !*cfrm2a u,v,w);


% Algebraic access to coframing parts


put('cobasis,'rtypefn,'quotelist);
put('cobasis,'listfn,'cobeval);

symbolic procedure cobeval(s,v);
   % s:{any}, v:bool -> cobeval:prefix cob
   % cobeval1 returns true prefix always
   if null v then aeval cobeval1 s else cobeval1 s;


symbolic procedure cobeval1 s;
   % s:{any} -> cobeval1:prefix cob
   % For an eds, returns the cobasis in the ordering used internally.
   if cfrmp(s := reval car s) then
      makelist cfrm_cob s
   else if edsp s then
      makelist edscob s
   else if xedsp s then
      makelist foreach x in cdr s collect makelist edscob x
   else edsparterr(s,"cobasis");


put('coordinates,'rtypefn,'quotelist);
put('coordinates,'listfn,'crdeval);

symbolic procedure crdeval(s,v);
   % s:{any}, v:bool -> crdeval:prefix cob
   % crdeval1 returns true prefix always
   if null v then aeval crdeval1 s else crdeval1 s;


symbolic procedure crdeval1 s;
   % s:{any} -> crdeval1:prefix cob
   if cfrmp(s := reval car s) then
      makelist cfrm_crd s
   else if edsp s then
      makelist cfrm_crd eds_cfrm s
   else if xedsp s then
      makelist foreach x in cdr s collect makelist cfrm_crd eds_cfrm x
   else if rlistp s then
      makelist purge foreach x in getrlist s join
         getrlist allcoords x
   else if null getrtype s then
      allcoords s
   else edsparterr(s,"coordinates");


put('structure_equations,'rtypefn,'quotelist);
put('structure_equations,'listfn,'drveval);

symbolic procedure drveval(s,v);
   % s:{cfrm}|{eds}|{xeds}|{rlist}|{rlist,rlist}, v:bool
   % -> drveval:prefix cob
   reval1(drveval1 s,v);


symbolic procedure drveval1 s;
   % s:{cfrm}|{eds}|{xeds}|{rlist}|{rlist,rlist} -> drveval1:prefix cob
   % Input can be cfrm, eds, xeds, xform or xform + inverse
   if cfrmp car(s := revlis s) then
      makelist cfrm_drv car s
   else if edsp car s then
      makelist cfrm_drv eds_cfrm car s
   else if xedsp car s then
      makelist foreach x in getrlist car s collect
          makelist cfrm_drv eds_cfrm x
   else if rlistp car s and cdr car s and eqexpr cadr car s then
      xformdrveval s
   else edsparterr(s,"structure equations");


put('restrictions,'rtypefn,'quotelist);
put('restrictions,'listfn,'rsxeval);

symbolic procedure rsxeval(s,v);
   % s:{any}, v:bool -> rsxeval:prefix cob
   if cfrmp(s := reval car s) then
      makelist foreach r in cfrm_rsx s collect
          {'neq,reval1(r,v),0}
   else if edsp s then
      makelist foreach r in cfrm_rsx eds_cfrm s collect
          {'neq,reval1(r,v),0}
   else if xedsp s then
      makelist foreach x in cdr s collect
          makelist foreach r in cfrm_rsx eds_cfrm x collect
             {'neq,reval1(r,v),0}
   else edsparterr(s,"restrictions");


symbolic procedure edsparterr(u,v);
   % u:prefix, v:any -> edsparterr:error
   % u is math-printed (with nat off), v is line-printed
   msgpri(nil,u,{"has no",v},nil,t);


symbolic procedure cfrmpart(m,n);
   % m:cfrm, n:int -> cfrmpart:prefix
   if n = 0 then 'coframing
   else if n = 1 then makelist cfrm_cob m
   else if n = 2 then makelist cfrm_crd m
   else if n = 3 then makelist cfrm_drv m
   else if n = 4 then
      makelist foreach r in cfrm_rsx m collect {'neq,r,0}
   else parterr(m,n);

put('!!cfrm!!,'partop,'cfrmpart);


symbolic procedure cfrmsetpart(m,l,r);
   % m:cfrm, l:list of int, r:prefix -> cfrmsetpart:error
   rerror(eds,000,"Part setting disabled on coframing operator");

put('!!cfrm!!,'setpartop,'cfrmsetpart);


% Consistency check, resimplification and cleanup


symbolic procedure checkcfrm m;
   % m:cfrm -> checkcfrm:cfrm
   % Check integrity and completeness of m. Cobasis must be correctly
   % specified, other details (eg missing coordinates, restrictions) can
   % be deduced via !*sys2cfrm. Call via cfrmprotect to install correct
   % structure equations and korder.
   cfrmprotect {'checkcfrm1,m};


symbolic procedure checkcfrm1 m;
   % m:cfrm -> checkcfrm1:cfrm
   % As checkcfrm, but assumes m is background coframing.
   begin scalar n,u,drv;
   m := copycfrm m;
   % Pick up coframing implied by cob/crd
   n := !*sys2cfrm !*a2sys makelist append(cfrm_cob m,cfrm_crd m);
   % Error if cobasis different
   if cfrm_cob n neq cfrm_cob m then
      rerror(eds,000,"Missing cobasis elements");
   % Coordinates and structure equations of n must include those of m,
   % but some restrictions may not be noticed.
   cfrm_rsx n := union(cfrm_rsx m,cfrm_rsx n);
   % Check whether all structure equations are known.
   % Missing coordinate differentials show up as missing cobasis
   % elements.
   drv := foreach d in cfrm_drv n collect cadr d;
   foreach k in cfrm_cob n do
      if not exact k and not member({'d,k},drv) then u := k . u;
   if u then edsverbose("Missing structure equations",reverse u,'cob);
   return purgecfrm n;
   end;


symbolic procedure resimpcfrm s;
   % s:cfrm -> resimpcfrm:cfrm
   begin scalar r;
   r := copycfrm s;
   cfrm_cob r := foreach f in cfrm_cob s collect reval f;
   cfrm_crd r := foreach f in cfrm_crd s collect reval f;
   cfrm_drv r := foreach f in cfrm_drv s collect reval f;
   cfrm_rsx r := foreach f in cfrm_rsx s collect aeval f;
   return if r = s then s else checkcfrm r;
   end;


put('reorder,'psopfn,'reordereval);
   % Can't have an cfrmfn here because we want the external kernel order

symbolic procedure reordereval s;
   % s:{any} -> reordereval:prefix cob
   if cfrmp(s := reval car s) then
      reordercfrm s
   else if edsp s then
      reordereds s
   else if xedsp s then
      makelist foreach x in cdr s collect reordereds x
   else msgpri(nil,nil,"Don't know how to reorder",s,t);


symbolic procedure reordercfrm s;
   % s:cfrm -> reordercfrm:cfrm
   begin scalar r;
   r := copycfrm s;
   cfrm_cob r := sort(cfrm_cob s,'termordp);
   cfrm_crd r := sort(cfrm_crd s,'termordp);
   cfrm_drv r :=
      sort(cfrm_drv s,'(lambda (x y) (termordp (cadr x) (cadr y))));
   cfrm_rsx r := sort(cfrm_rsx s,'ordop);
   return if r = s then s else r;
   end;


put('cleanup,'rtypefn,'getrtypecar);
put('cleanup,'cfrmfn,'cleancfrm);

symbolic procedure cleancfrm m;
   % m:cfrm -> cleancfrm:cfrm
   % Clean up, resimplify and check m.
   begin scalar n;
   n := resimpcfrm m;
   return % eq test here essential!
      if n eq m then checkcfrm m
      else n;
   end;


symbolic procedure purgecfrm m;
   % m:cfrm -> purgecfrm:cfrm
   % Clean up drv and rsx parts of m.
   % Background coframing need not be m.
   begin scalar cfrmcrd!*,cfrmcob!*;
   m := copycfrm m;
   cfrmcob!* := cfrm_cob m;
   cfrmcrd!* := cfrm_crd m;
   cfrm_drv m := purgedrv cfrm_drv m;
   cfrm_rsx m := purgersx cfrm_rsx m;
   return m;
   end;


symbolic procedure purgedrv x;
   % x:drv -> purgedrv:drv
   % Sift through structure equations, checking they are all current.
   % Can't use memq here because lhs's are not evaluated, so kernels may
   % not be unique. Take out d x => d x as well. Should we catch d(0)?
   begin scalar drv,dl,dr,r2;
   foreach r in x do
      if exact(dl := cadr r) and
         (cadr dl member cfrmcob!* or cadr dl member cfrmcrd!*) and
               not(kernp(dr := simp!* caddr r) and dl = mvar numr dr) then
                  if null (r2 := assoc(dl,drv)) then
               drv := (dl . dr) . drv
            else if cdr r2 neq dr and
               resimp cdr r2 neq resimp dr then
               << edsdebug("Inconsistent structure equations",
                     makelist{{'replaceby,dl,mk!*sq dr},
                              {'replaceby,car r2,mk!*sq cdr r2}},
                           'prefix);
                         rerror(eds,000,"Inconsistent structure equations") >>;
   drv := foreach p in reversip drv collect
                   {'replaceby,car p,mk!*sq cdr p};
   return sort(drv,'(lambda (x y) (termordp (cadr x) (cadr y))));
   end;


symbolic procedure purgersx x;
   % x:rsx -> purgersx:rsx
   begin scalar rsx;
   foreach f in reverse purge x do
      rsx := addrsx(numr simp!* f,rsx);
   return rsx;
   end;


symbolic procedure addrsx(x,rsx);
   % x:sf, rsx:rsx -> addrsx:rsx
   % Must reorder before fctrf in case we are handling expressions from
   % another coframing.
   begin
   if not cfrmconstant x and
      not member(mk!*sq !*f2q x,rsx)
   then foreach f in cdr fctrf reorder x do
      if not cfrmconstant car f and
         not member(f := mk!*sq !*f2q car f,rsx)
      then rsx := f . rsx;
   return rsx;
   end;


% Algebraic operations


infix cross;
precedence cross,times;
put('cross,'rtypefn,'getrtypecar);
put('cross,'edsfn,'extendeds);
put('cross,'cfrmfn,'cfrmprod);
flag('(cross),'nospread);
flag('(cross),'nary);


symbolic procedure extendeds u;
   % u:eds.list of cfrmdef -> extendeds:eds
   begin scalar s,jet0;
   % trivial case first
   if null cdr u then return car u;
   s := copyeds car u;
   u := cfrmprod cdr u;
   if jet0 := geteds(s,'jet0) then
      puteds(s,'jet0,
         purgejet0(append(jet0,setdiff(cfrm_crd u,edscrd s)),
                          uniqids indkrns s));
   eds_cfrm s := cfrmprod2(eds_cfrm s,u);
   remkrns s;
   return normaleds purgeeds!* s;
   end$

symbolic procedure purgejet0(crd,idxl);
   begin scalar j,j0;
   idxl := foreach i in flatindxl idxl collect lowerind i;
   foreach c in crd do
   << j := j0;
      while j and not jetprl(c,car j,idxl) do j := cdr j;
      if null j then
         j0 := c . foreach c0 in j0 join
            if not jetprl(c0,c,idxl) then {c0} >>;
   return j0;
   end$

symbolic procedure jetprl(c,c0,idxl);
   if c := splitoffindices(c0,c) then subsetp(cdr c,idxl)$


symbolic procedure cfrmprod u;
   % u:list of cfrmdef -> cfrmprod:cfrm
   % u is non-empty, first line excludes m:xeds
   (if not cfrmp m then typerr(car u,"coframing")
   else if length u = 1 then m
   else cfrmprotect {'cfrmprod2,m,cfrmprod cdr u})
      where m = !*a2cfrm{car u};


symbolic procedure cfrmprod2(m,n);
   % m,n:cfrm -> cfrmprod2:cfrm
   if xnp(cfrm_cob m,cfrm_cob n) or
      xnp(cfrm_crd m,cfrm_crd n)
   then cfrmbprod(m,n)
   else mkcfrm{append(cfrm_cob m,cfrm_cob n),
                    append(cfrm_crd m,cfrm_crd n),
                    append(cfrm_drv m,cfrm_drv n),
                    append(cfrm_rsx m,cfrm_rsx n)}$


symbolic procedure cfrmbprod(m,n);
   % m,n:cfrm -> cfrmbprod:cfrm
   % m and n are cfrm with common elements,
   % result is bundle product.
   begin scalar z,u,v;
   % get common elements
   z := !*a2sys makelist append(
               intersection(cfrm_cob m,cfrm_cob n),
         intersection(cfrm_crd m,cfrm_crd n));
   % generate coframing from each
   setcfrm m; u := !*sys2cfrm z;
   setcfrm n; v := !*sys2cfrm z;
   % check equivalence
   if not equalcfrm(u,v) then
      rerror(eds,000,
         "Cannot form coframing product: overlap cannot be factored");
   % compose as (m/u).n
   return resimpcfrm mkcfrm{
      append(setdiff(cfrm_cob m,cfrm_cob u),cfrm_cob n),
      append(setdiff(cfrm_crd m,cfrm_crd u),cfrm_crd n),
      append(setdiff(cfrm_drv m,cfrm_drv u),cfrm_drv n),
      append(setdiff(cfrm_rsx m,cfrm_rsx u),cfrm_rsx n)};
   end$


put('dim,'simpfn,'simpdim);

symbolic procedure simpdim u;
   % u:{any} -> simpdim:sq
   if cfrmp(u := reval car u) then
      length cfrm_cob u ./ 1
   else if edsp u then
      length edscob u ./ 1
   else edsparterr(u,"dimension");



% Auxiliary routines


Comment.  The following routines are for testing whether an expression
is nowhere zero on a restricted coframing specified by some coordinates
and some expressions assumed not to vanish.  Expressions with unknown
(explicit or implicit) dependence on the coordinates are not nowhere
zero.
endcomment;

symbolic procedure cfrmnowherezero x;
   % x:sf -> cfrmnowherezero:bool
   % Heuristic to test if x is nowhere zero on the coframing described
   % by cfrmcrd!* restricted away from the zeros of the expressions in
   % cfrmrsx!*. This version checks first directly, and then tests (if
   % x can be factorised) whether all the factors are nowhere zero.
   (domainp x or                     % quick exit for constants
   cfrmnowherezero1 xpartitsq(x ./ 1) or       % check x as a whole
   if (x := cdr fctrf x) and (length x > 1 or cdar x > 1) then
   << while x and cfrmnowherezero1 xpartitsq(caar x ./ 1) do
               x := cdr x;
      null x >>)
   where xvars!* = cfrmcrd!*;


symbolic procedure cfrmnowherezero1 x;
   % x:pf -> cfrmnowherezero1:bool
   % Result is t if x is constant or doesn't vanish on restricted space,
   % as tested by substituting x=0 into the expressions in cfrmrsx!* and
   % seeing if one vanishes. If lc x contains an (explicit or implicit)
   % unknown dependence on cfrmcrd!*, result is nil.
   if lpow x = 1 then cfrmconstant numr lc x
   else cfrmviolatesrsx x;


symbolic procedure cfrmconstant x;
   % x:sf -> cfrmconstant:bool
   freeoffl(x,cfrmcrd!*);


symbolic procedure freeoffl(x,v);
   % x:sf, v:list of kernel -> freeoffl:bool
   % freeofl for sf's
   null v or freeoff(x,car v) and freeoffl(x,cdr v);


symbolic procedure freeoff(x,v);
   % x:sf, v:kernel -> freeoff:bool
   % freeof for sf's, using ndepends from EXCALC to handle indexed
   % forms properly
   if domainp x then t
   else if sfp mvar x then
      freeoff(mvar x,v) and freeoff(lc x,v) and freeoff(red x,v)
   else
      not ndepends(mvar x,v) and freeoff(lc x,v) and freeoff(red x,v);


symbolic procedure cfrmviolatesrsx x;
   % x:pf -> cfrmviolatesrsx:bool
   % result is t if x = 0 annihilates at least one of cfrmrsx!*
   begin scalar rsx;
   rsx := cfrmrsx!*; x := {x};
   while rsx and xreduce(car rsx,x) do rsx := cdr rsx;
   return not null rsx; % to give true bool and make trace nicer
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/eds.tex0000644000175000017500000026314211526203062022564 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}

\title{\bf EDS\\
A package for exterior differential systems}

\author{
David Hartley						\\
\it Physics and Mathematical Physics			\\
University of Adelaide	\quad SA 5005			\\
Australia						\\[1mm]
{\tt DHartley{\rm @}physics.adelaide.edu.au}
}

\date{
{\bf Version 2.2}\\
\strut\\
7 July 2003}

% Extra macros

\def\d{{\rm d}}
\def\union{\cup}
\def\R{\hbox{\bf R}}
\def\del{\partial}
\def\implies{\Rightarrow}
\def\optional#1{$\,[$#1$]\,$}
\newenvironment{syntax}
   {\begin{list}{}{\tt}\item[]}
   {\end{list}}


\begin{document}
\maketitle

\begin{abstract}
EDS is a REDUCE package for symbolic analysis of partial differential
equations using the geometrical approach of exterior differential
systems. The package implements much of exterior differential systems
theory, including prolongation and involution analysis, and has been
optimised for large, non-linear problems. 
\end{abstract}

\newpage
\tableofcontents

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%\newpage
\section{Introduction}

Exterior differential systems give a geometrical framework for partial
differential equations and more general differential geometric problems.
The geometrical formulation has several advantages stemming from its
coordinate-independence, including superior treatment of nonlinear and
global problems. There is not sufficient space in this manual for an
introduction to exterior differential systems beyond the scant details
given in section \ref{EDS data structures and concepts}, but there are a
number of up-to-date texts on the subject (eg \cite{BCGGG,Spivak}). 

EDS provides a number of tools for setting up and manipulating exterior
differential systems and implements many features of the theory. Its main
strengths are the ability to use anholonomic or moving frames and the care
taken with nonlinear problems.

There has long been interest in implementing the theory of exterior
differential systems in a computer algebra system (eg
\cite{Shapeev,Ganzha,HartleyTucker}). The EDS package owes much to these
earlier efforts, and also to related packages for PDE analysis (eg
\cite{MansfieldFackerell,Reid,Seiler}), as well as to earlier versions of
EDS produced at Lancaster university with R~W~Tucker and
P~A~Tuckey. Finally, EDS uses the exterior calculus package EXCALC of
E~Schr{\"u}fer \cite{EXCALC} and the exterior ideals package XIDEAL
\cite{XIDEAL}. XIDEAL and EXCALC are loaded automatically with EDS.

This work has been supported by the Graduate College on Scientific
Computing, University of Cologne and GMD St Augustin, funded by the DFG (Deutsche
Forschungsgemeinschaft). I would like to express my thanks to R~W~Tucker,
E~Schr{\"u}fer, P~A~Tuckey, F~W~Hehl and R~B~Gardner for helpful and
encouraging discussions.



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{EDS data structures and concepts}
\label{EDS data structures and concepts}

This section presents the various structures used for expressing exterior
systems quantities in EDS. In addition, some the concepts used in EDS to
aid computation are described.

\subsection{Coframings}
\label{Coframings}

Within the context of EDS, a {\it coframing} means a real
finite-dimensional differentiable manifold with a given global cobasis.
The information about a coframing required by EDS is kept in a
\meta{coframing} object. The cobasis is the identifying element of an
EDS \meta{coframing}: distinct cobases for the same differentiable
manifold are treated as distinct \meta{coframing} objects in EDS. The
cobasis may be either holonomic or anholonomic, allowing some manifolds
with non-trivial topology (eg.  group manifolds) to be treated. 

In addition to the cobasis, an EDS \meta{coframing} can be given {\it
coordinates}, {\it structure equations} and {\it restrictions}. The
coordinates may be an incomplete or overcomplete set. The structure
equations express the exterior derivative of the coordinates and cobasis
elements as needed.  All coordinate differentials must be expressed in
terms of the given cobasis, but not all cobasis differentials need be
known. The restrictions are a set of inequalities (at present using just
$\neq$) describing point sets not in the manifold. 

The \meta{coframing} object is, of course, by no means a full
description of a differentiable manifold. For example, there is no
topology and there are no charts. However, the \meta{coframing} object
carries sufficient information about the underlying manifold to allow a
range of exterior systems calculations to be carried out. As such, it is
convenient to accept an abuse of language and think of the
\meta{coframing} object as a manifold. 

A \meta{coframing} is constructed or selected using the \f{coframing}
operator. 

\paragraph{\it Examples:}
\begin{itemize}
\item $\R^3$ with cobasis $\{\d x,\d y,\d z\}$ and coordinates $\{x,y,z\}$.
\item $\R^2\backslash\{0\}$ with cobasis $\{e^1,e^2\}$, a single
	coordinate $\{r\}$, ``structure equations'' $\{\d r = e^1$,
	$\d e^1=0$,$\d e^2=e^1\wedge e^2/r\}$ and restrictions $\{r\neq0\}$.
\item $\R^2\backslash\{0\}$ with cobasis $\{\d x,\d y\}$,
	coordinates $\{x,y\}$ and restrictions $\{x^2+y^2\neq0\}$.
\item $S^1$ with cobasis $\{\omega\}$ and structure equations 
	$\{\d\omega = 0\}$.
\item $S^2$ cannot be encapsulated by an EDS \meta{coframing} since there
        is no global cobasis.
\end{itemize}

\subsection{Exterior differential systems}
\label{Exterior differential systems}

A simple \meta{EDS}, or exterior differential system, is a triple
$(S,\Omega,M)$, where $M$ is a \meta{coframing} (section
\ref{Coframings}), $S$ is a \meta{system} (section \ref{Systems}) on
$M$, and $\Omega$ is an independence condition: either a decomposable
\meta{p-form} or a \meta{system} of 1-forms on $M$ (exterior
differential systems without independence condition are not treated by
EDS). 

More generally, an \meta{EDS} is a list of simple \meta{EDS} objects
where the various coframings are all disjoint. This last requirement in
not enforced within EDS unless the \f{edsdisjoint} switch is \f{on}
(section \ref{edsdisjoint}). These more general \meta{EDS} objects are
represented as a list of simple \meta{EDS} objects. All operators which
take an \meta{EDS} argument accept both simple and compound types. 

The trivial \meta{EDS}, describing an inconsistent problem with no
solutions, is defined to be (\{1\},\{\},\{\}). 

An \meta{EDS} is represented by the \f{eds} operator (section \ref{eds}),
and can additionally be generated using the \f{contact} and \f{pde2eds}
operators (sections \ref{contact}, \ref{pde2eds}).

The solutions of $(S,\Omega,M)$ are integral manifolds, or immersions (cf
section \ref{Maps}) on which $S$ vanishes and the rank of $\Omega$ is
preserved. Solutions at a single point are described by integral elements
(section \ref{Integral elements}).

\subsection{Systems}
\label{Systems}

In EDS, the label \meta{system} refers to a list
\begin{syntax}
	\{\meta{p-form expr},$\cdots$\}
\end{syntax}
of differential forms. This is distinct from an \meta{EDS} (section
\ref{Exterior differential systems}), which has additional structure.
However, many EDS operators will accept either an \meta{EDS} or a
\meta{system} as arguments. In the latter case, any extra information
which is required is taken from the background coframing (section
\ref{Background coframing}). 

The \meta{system} of an \meta{EDS} can be obtained with the \f{system}
operator (section \ref{system}).

\subsection{Background coframing}
\label{Background coframing}

The information encapsulated in a \f{coframing} operator is usually
inactive. However, when operations are performed on a \meta{coframing} or an
\meta{EDS} object (sections \ref{Coframings}, \ref{Exterior differential
systems}), this information is activated for the duration of those
operations. It is possible to activate the rules and orderings of a
\f{coframing} operator globally, by making it the {\em background
coframing}. All subsequent EXCALC operations will be governed by those
rules. Operations on \meta{EDS} objects are unaffected, since their
coframings are still activated locally. The background coframing can be set
and changed with the \f{set\_coframing} command, and inspected using
\f{coframing}.

\subsection{Integral elements}
\label{Integral elements}

An {\it integral element} of an exterior system $(S,\Omega,M)$ is a
subspace $P\subset T_pM$ of the tangent space at some point $p\in M$
such that all forms in $S$ vanish when evaluated on vectors from $P$. In
addition, no non-zero vector in $P$ may annul every form in $\Omega$. 

Alternatively, an integral element $P\subset T_pM$ can be represented
by its annihilator $P^\perp\subset T^*_pM$, comprising those 1-forms
at $p$ which annul every vector in $P$. This can also be understood as a
maximal set of 1-forms at $p$ such that $S \simeq 0 \pmod{P^\perp}$ and
the rank of $\Omega$ is preserved modulo $P^\perp$.  This is the
representation used by EDS. Further, the reference to the point $p$ is
omitted, so an \meta{integral element} in EDS is a distribution of
1-forms on $M$, specified as a \meta{system} of 1-forms. 

In specifying an integral element for a particular \meta{EDS}, it is
possible to omit the Pfaffian component of the \meta{EDS}, since these
1-forms must be part of any integral element.

\paragraph{\it Examples:}
\begin{itemize}
\item With $M = \R^3 = \{(x,y,z)\}$, $S = \{\d x\wedge \d z\}$ and
      $\Omega = \{\d x,\d y\}$, the integral element $P = \{\partial\sb
      x + \partial_z,\partial_y\}$ is equally determined by its
      annihilator $P^\perp = \{\d z - \d x\}$. 
\item For $S = \{\d z - y\d x\}$ and $\Omega = \{\d x\}$, the integral
      element $P = \{\partial_x + y\partial_z\}$ can be specified
      simply as $\{\d y\}$.
\end{itemize}

\subsection{Properties}
\label{Properties}

For large problems, it can require a great deal of computation to establish
whether, for example, a system is closed or not. In order to save
recomputing such properties, an \meta{EDS} object carries a list of
\meta{properties} of the form
\begin{syntax}
	\{\meta{keyword} = \meta{value},$\cdots$\}
\end{syntax}
where \meta{keyword} is one of \f{closed}, \f{quasilinear}, \f{pfaffian} or
\f{involutive}, and \meta{value} is either \f{0} (false) or \f{1}
(true). These properties are suppressed when an \meta{EDS} is printed,
unless the \f{nat} switch is \f{off}. They can be examined using the
\f{properties} operator (section \ref{properties}).

Properties are usually generated automatically by EDS as required, but may
be explicitly checked using the operators in section \ref{Testing exterior
systems}. If a property is not yet present on the list, it is not yet
known, and must be checked explicitly if required.

In addition to the properties just described, an \meta{EDS} object carries
a number of hidden properties which record the results of previous
calculations, such as the closure or information about the prolongation of
the system. These hidden properties speed up many operations which
contain common sub-calculations. The hidden properties are stored using
internal LISP data structures and so are not available for inspection.

Properties can be asserted when an \meta{EDS} is constructed with the
\f{eds} operator (section \ref{eds}). Care is needed since such assertions
are never checked. Properties can be erased using the \f{cleanup} operator
(section \ref{cleanup}).

\subsection{Maps}
\label{Maps}

Within EDS, a map $f:M\to N$ is given as a \meta{map} object, a list 
\begin{syntax}
\{\meta{coordinate} = \meta{expr},$\cdots$,\meta{expr} neq \meta{expr},$\cdots$\}
\end{syntax}
of substitutions and restrictions. The substitutions express coordinates on
the target manifold $N$ in terms of those on the source manifold $M$. The
restrictions describe point sets not contained in the source manifold
$M$. The ordering of substitutions and restrictions in the list is
unimportant. It is not necessary that the restrictions and right-hand sides
of the substitutions be written entirely in $M$ coordinates, but it must be
possible by repeated substitution to produce expressions on $M$ (see the
examples below). Any denominators in the substitutions are automatically
added to the list of restrictions. It is not necessary to include trivial
equations for coordinates which are present on both $M$ and $N$. Note that
projections cannot be represented in this fashion (but see the \f{cross}
operator, section \ref{cross}).

Maps are applied using the \f{pullback} and \f{restrict} operators
(sections \ref{pullback}, \ref{restrict}).

\paragraph{\it Examples:}
\begin{itemize}
\item The map $\R^2\backslash\{0\}\to\R^3$, $(x,y)\mapsto (x,y,z=x^2+y^2)$
      is represented $\{z = x^2+y^2,z\neq 0\}$.
\item $\{x=u+v,y=u-v\}$ might represent the coordinate change
      $\R^3\to\R^3$, $(u,v,z)\mapsto(x=u+v,y=u-v,z)$.
\item $\{x=u+v,y=2u-x\}$ is the same map again.
\item $\{x=2v+y,y=2u-x\}$ is unacceptable since $x$ and $y$ cannot be
      eliminated from the right-hand sides by repeated substitution.
\end{itemize}

\subsection{Cobasis transformations}
\label{Cobasis transformations}

A cobasis transformation is given in EDS by a \meta{transform}, a list
\begin{syntax}
	\{\meta{cobasis element} = \meta{1-form expr},$\cdots$\}
\end{syntax}
of substitutions. When applying a transformation to a \meta{p-form} or
\meta{system}, it is necessary to specify the {\it forward}
transformation just as for a \f{sub} substitution. For \meta{EDS} and
\meta{coframing} objects, it is also possible to specify the inverse of
the desired substition: EDS will automatically invert the transformation
as required. For a partial change of cobasis, it is not necessary to
include trivial equalities. Cobasis transformations are applied by the
\f{transform} operator (section \ref{transform}). 

\paragraph{\it Examples:}
\begin{itemize}
\item $\{\omega^1 = x\d y - y\d x, \omega^2 = x\d x + y\d y\}$ gives a
transformation between Cartesian and polar cobases on
$\R^2\backslash\{0\}$.
\item On $J^1(\R^2,\R)$ with cobasis $\{\d u,\d p,\d q,\d r,\d s,\d t,\d
x,\d y\}$, the list $\{\theta^1=\d u - p\d x - q\d y, \theta^2=\d p -
r\d x - s\d y, \theta^3=\d q - s\d x - t\d y\}$ specifies a new cobasis in
which the contact system is simply $\{\theta^1,\theta^2,\theta^3\}$.
\end{itemize}

\subsection{Tableaux}
\label{Tableaux}

For a quasilinear Pfaffian exterior differential system
$(\{\theta^a\},\{\omega^i\},M)$, the tableau $A=[\pi^a_i]$
is a matrix of 1-forms such that
$$	\d \theta^a + \pi^a_i\wedge\omega^i \simeq 0 
		\pmod{\{\theta^a,\omega^i\wedge\omega^j\}}
$$
The $\pi^a_i$ are not unique: if $\{\theta^a,\pi^\rho,\omega^i\}$ is a
standard cobasis for the system (section \ref{Standard cobasis}), the EDS
\meta{tableau} is a matrix containing linear combinations of the $\pi^\rho$
only. Zero rows are omitted.

The tableau of an \meta{EDS} is generated by the \f{tableau} operator
(section \ref{tableau}), or can be entered using the \f{mat} operator. The
Cartan characters of a tableau are found using \f{characters} (section
\ref{characters}).

\subsection{Normal form}
\label{Normal form}

Parts of the theory of exterior differential systems apply only at points
on the underlying manifold where the system is in some sense
non-singular. To ensure the theory applies, EDS automatically works all
exterior systems $(S,\Omega,M)$ into a {\em normal form} in which

\begin{enumerate}
\item The Pfaffian (degree 1) component of $S$ is in {\em solved} form,
      where each expression has a distinguished term with coefficient 1,
      unique to that expression.
\item The independence condition $\Omega$ is also in solved form.
\item The distinguished terms from the 1-forms in $S$ have been eliminated
      from the rest of $S$ and from $\Omega$.
\item Any 1-forms in $S$ which vanish modulo the independence condition are
      removed from the system and their coefficients are appended as
      0-forms.
\end{enumerate}

Conditions 1 and 2 ensure the 1-forms have constant rank, while 3 is
convenient for many tests and calculations. In bringing the system into
solved form, divisions will be made only by coefficients which are
constants, parameters or functions which are nowhere zero on the
manifold. The test for nowhere-zero functions uses the restrictions
component of the \meta{coframing} structure (cf section \ref{Coframings}) and
is still primitive: facts such as $x^2+1\neq0$ on a real manifold are
overlooked. See also the switch \f{edssloppy} (section \ref{edssloppy}).

This ``normal form'' has, of course, nothing to do with the various normal 
forms (eg Goursat) into which some exterior systems may be brought by
cobasis transformations and choices of generators.

\paragraph{\it Examples:}
\begin{itemize}
\item On $M=\{(u,v,w)\in\R^3\mid u\neq v\}$, the Pfaffian system
      $$\{u\d u + v\d v + \d w,\>(u^2 + u - v^2)\d u + u\d v + \d w\}$$ has
      the solved form
      $$\{\d v + (u + v)\d u,\>\d w + ( - uv + u - v )\d u\}.$$
\item Since the independence condition is defined only modulo the system,
      the system
      $$S=\{\d u - \d x - u_y\d y\},\quad \Omega=\d x\wedge\d y$$ has an
      equivalent normal form
      $$S=\{\d x - \d u + u_y\d y\},\quad \Omega=\d u\wedge\d y.$$
\end{itemize}

\subsection{Standard cobasis}
\label{Standard cobasis}

Given an \meta{EDS} $(S,\Omega,M)$ in normal form (section \ref{Normal
form}), the cobasis of the \meta{coframing} $M$ can be decomposed into three
sets: $\{\theta^a\}$, the distinguished terms from the 1-forms in $S$,
$\{\omega^i\}$, the distinguished terms from the 1-forms in $\Omega$, and
the remainder $\{\pi^\rho\}$. Within EDS, $\{\theta^a,\pi^\rho,\omega^i\}$
is called the {\em standard cobasis}, and all expressions are ordered so
that $\theta^a > \pi^\rho > \omega^i$. The ordering within the three sets
is determined by the REDUCE \meta{kernel} ordering.

\paragraph{\it Examples:}
\begin{itemize}
\item For the system $S=\{\d u - \d x - u_y\d y\}$, $\Omega=\d x\wedge\d y$,
      the decomposed standard cobasis is $\{\d u\}\cup\{\d u_y\}\cup\{\d
      x,\d y\}$.
\item For the contact system 
	$$S=\cases{\d u - u_x\d x - u_y\d y\cr
		   \d u_x - u_{xx}\d x - u_{xy}\d y\cr
		   \d u_y - u_{xy}\d x - u_{yy}\d y,\cr}$$
      the standard cobasis is $\{\d u,\d u_x,\d u_y\}\cup\{\d
      u_{xx},\d u_{xy},\d u_{yy}\}\cup\{\d x,\d y\}$.

\end{itemize}


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Constructing EDS objects}
\label{Constructing EDS objects}

Before analysing an exterior system, it is necessary to enter it into EDS
somehow. Several means are provided for this purpose, and are described in
this section.

\subsection{\tt coframing}
\label{coframing}

An EDS \meta{coframing} is constructed using the \f{coframing}
operator. There are several ways in which it can be used. 

The simplest syntax
\begin{syntax}
	coframing(\{\meta{expr},$\cdots$\})
\end{syntax}
examines the argument for 0-form and 1-form variables and deduces a full
\meta{coframing} object capable of supporting the given expressions. This
includes recursively examining the exterior derivatives of the variables
appearing explicitly in the argument, taking into account prevailing
\f{let} rules. In this form, the ordering of the final cobasis elements
follows the prevailing REDUCE ordering. Free indices in indexed expressions
are expanded to a list of explicit indices using \f{index\_expand} (section
\ref{index_expand}).

A more basic syntax is
\begin{syntax}
	coframing(\meta{cobasis}\optional{,\meta{coordinates}}
	\optional{,\meta{restrictions}}
	\\\phantom \qquad\qquad\quad
	\optional{,\meta{structure equations}})
\end{syntax}
where \meta{cobasis} is a list of \meta{kernel} 1-forms,
\meta{coordinates} is a list of \meta{kernel} 0-forms,
\meta{restrictions} is a list of inequalities (using only $\neq$ at
present), and \meta{structure equations} is a list of rules giving the
exterior derivatives of the coordinates and cobasis elements. All
arguments except the cobasis are optional, and the order of arguments is
unimportant. As in the first syntax, missing parts are deduced. The
ordering of the final cobasis elements follows the ordering specified,
rather than the prevailing REDUCE ordering. 

Finally,
\begin{syntax}
	coframing(\meta{EDS})
\end{syntax}
returns the coframing argument of an \meta{EDS}, and
\begin{syntax}
	coframing()
\end{syntax}
returns the current background coframing (section \ref{Background
coframing}).

\paragraph{\it Examples:}
\begin{verbatim}
coframing {x,y,z};

   coframing({d x,d y,d z},{x,y,z},{},{})

coframing({e 1,e 2},{r},{r neq 0},
          {d r=>e 1,d e 1=>0,d e 2=>e 1^e 2/r});

                                            1  2
               1  2          1        2    e ^e           1
   coframing({e ,e },{r},{d e => 0,d e => -------,d r => e },
                                             r 
             {r neq 0})

coframing({e 2}) where {d r=e 1,d e 1=0,d e 2=e 1^e 2/r};

                                            1  2
               1  2          1        2    e ^e           1
   coframing({e ,e },{r},{d e => 0,d e => -------,d r => e },
                                             r 
             {r neq 0})
\end{verbatim}

\subsection{\tt eds}
\label{eds}

A simple \meta{EDS} is constructed using the \f{eds} operator.
\begin{syntax}
	eds(\meta{system},\meta{indep. condition}\ignorespaces
	\optional{,\meta{coframing}}\optional{,\meta{properties}})
\end{syntax}
(cf sections \ref{Systems}, \ref{Coframings}, \ref{Properties}). The
\meta{indep. condition} can be either a decomposable \meta{p-form} or a
\meta{system} of 1-forms. Free indices in indexed expressions are expanded
to a list of explicit indices using \f{index\_expand} (section
\ref{index_expand}).

The \meta{coframing} argument can be omitted, in which case the expressions
from the \meta{system} and \meta{indep. condition} are fed to the
\f{coframing} operator (section \ref{coframing}) to construct a suitable
working space.

The \meta{properties} argument is optional, allowing the given properties
to be asserted. This can save considerable time for large systems, but care
is needed since the assertions are never checked.

The \meta{EDS} is put into normal form (section \ref{Normal form}) before
being returned.

On output, only the \meta{system} and \meta{indep. condition} are
displayed, unless the \f{nat} switch is off, in which case the
\meta{coframing} and \meta{properties} are shown too. This is so that an
\meta{EDS} can be written out to a file and read back in. 

The parts of an \meta{EDS} are obtained with the operators \f{system},
\f{cobasis}, \f{independence} and \f{properties} (sections \ref{system},
\ref{cobasis}, \ref{independence} and \ref{properties}).

\paragraph{\it Examples:}
\begin{verbatim}
pform {x,y,z,p,q}=0,{e(i),w(i,j)}=1;

indexrange {i,j,k}={1,2},{a,b,c}={3};

eds({d z - p*d x - q*d y, d p^d q},{d x,d y});

   EDS({d z - p*d x - q*d y,d p^d q},{d x,d y}) 

OMrules := 
   index_expand {d e(i)=>-w(i,-j)^e(j),w(i,-j)+w(j,-i)=>0}$

eds({e(a)},{e(i)}) where OMrules;

         3    1  2
   EDS({e },{e ,e })

coframing ws;
               3  2    1  2         1        2  2 
   coframing({e ,w   ,e ,e },{},{d e  =>  - e ^w   ,
                    1                             1 
                  2     1  2 
               d e  => e ^w   },{})
                             1 
\end{verbatim}

\subsection{\tt contact}
\label{contact}

Many PDE problems are formulated as exterior systems using a jet bundle
contact system. To facilitate construction of these systems, the
\f{contact} operator is provided. The syntax is
\begin{syntax}
	contact(\meta{order},\meta{source manifold},\meta{target manifold})
\end{syntax}
where \meta{order} is a non-negative integer, and the two remaining
arguments are either \meta{coframing} objects or lists of \meta{p-form}
expressions. In the latter case, the expressions are fed to the
\f{coframing} operator (section \ref{coframing}). The contact system for the
bundle $J^r(M,N)$ of $r$-jets of maps $M\to N$ is thus returned by
\f{contact(r,M,N)}. Source and target spaces may have anholonomic
cobases. Indexed names for the jet bundle fibre coordinates are constructed
using the identifiers in the source and target cobases.

\paragraph{\it Examples:}
\begin{verbatim}
pform {x,y,z,u,v}=0,{e i,w a}=1;
indexrange {i}={1,2},{a}=1;
contact(1,{x,y,z},{u,v});

   EDS({d u - u *d x - u *d y - u *d z,
               x        y        z 
        d v - v *d x - v *d y - v *d z},{d x,d y,d z})
               x        y        z 

contact(2,{e(i)},{w(a)}) 
   where index_expand{d e(1)=>e(1)^e(2),d e(2)=>0,d w(a)=>0};

         1    1    1    1    2
   EDS({w  - w   *e  - w   *e ,
                1         2 
           1      1      1    1      2
        d w    - w     *e  - w     *e ,
             1      1 1         1 2 
           1          1        1     1    1      2    1  2
        d w    + ( - w      + w   )*e  - w     *e },{e ,e })
             2          1 2      1          2 2 
\end{verbatim}

\subsection{\tt pde2eds}
\label{pde2eds}

A PDE system can be encoded into an \meta{EDS} using \f{pde2eds}. The
syntax is
\begin{syntax}
	pde2eds(\meta{pde}\optional{,\meta{dependent},\meta{independent}})
\end{syntax}
where \meta{pde} is a list of equations or expressions (implicitly assumed
to vanish) specifying the PDE system using either
the standard REDUCE \f{df} operator, or the EXCALC \f{@} operator. If the
optional variable lists \meta{dependent} and \meta{independent} are not
given, \f{pde2eds} infers them from the expressions in \meta{pde}. The
order of each dependent variable is determined automatically.

The result returned by \f{pde2eds} is an \meta{EDS} based on the contact
system of the relevant mixed-order jet bundle. Any of the \meta{pde}
members which is in solved form is used to pull back this contact
system. Any remaining expressions or unresolved equations are simply
appended as 0-forms: before many of the analysis tools (section
\ref{Analysing exterior systems}) can be applied, it is necessary to
convert this to a system generated in positive degree using the \f{lift}
operator (section \ref{lift}).

The automatic inference of dependent and independent variables is governed
by the following rules. The independent variables are all those with
respect to which derivatives appear. The dependent variables are those
for which explicit derivatives appear, as well as any which have
dependencies (as declared by \f{depend} or \f{fdomain}) or which are 0-forms.
To exclude a variable from the dependent variable list (for example,
because it is regarded as given) or to include extra independent variables,
use the optional arguments to \f{pde2eds}.

One of the awkward points about \f{pde2eds} is that implicit dependence
is changed globally. In order for the \f{df} and \f{@} operators to be used
to express the PDE, the \meta{dependent} variables must depend (via
\f{depend} or \f{fdomain}) on the \meta{independent} variables. On the
other hand, in the \meta{EDS}, these variables are all completely
independent coordinates. The \f{pde2eds} operator thus removes the implicit
dependence so that the \meta{EDS} is correct upon return. This means that
the \meta{pde} will no longer evaluate properly until such time as the
dependence is manually restored, whereupon the \meta{EDS} will no longer be
correct, and so on.

To assist with this difficulty, \f{pde2eds} saves a record of the
dependencies it has removed in the shared variable \f{dependencies}. The
operator \f{mkdepend} can be used to restore the initial state.

See also the operators \f{pde2jet} (section \ref{pde2jet}) and \f{mkdepend}
(section \ref{mkdepend}).

\paragraph{\it Example:}
\begin{verbatim}
depend u,x,y; depend v,x,y;
pde2eds({df(u,y,y)=df(v,x),df(v,y)=y*df(v,x)});

   EDS({d u - u *d x - u *d y,
               x        y

        d u  - u   *d x - u   *d y,
           x    x x        y x

        d u  - u   *d x - v *d y,
           y    y x        x

        d v - v *d x - v *y*d y},d x^d y)
               x        x

dependencies;

   {{u,y,x},{v,y,x}}
\end{verbatim}

\subsection{\tt set\_coframing}
\label{set_coframing}

The background coframing (section \ref{Background coframing}) is set with
\f{set\_coframing}. The syntax is
\begin{syntax}
   set\_coframing \meta{arg}
\end{syntax}
where \meta{arg} is a \meta{coframing} or an \meta{EDS} and the previous
background coframing is returned. All rules, orderings etc pertaining to the
previous background coframing are removed and replaced by those for the new
\meta{coframing}. The special form
\begin{syntax}
   set\_coframing()
\end{syntax}
clears the background coframing entirely and returns the previous one.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Inspecting EDS objects}
\label{Inspecting EDS objects}

Given an \meta{EDS} or some other EDS structure, it is often desirable to
inspect or extract some part of it. The operators described in this section
do just that. Many of them accept various types of arguments and return the
relevant information in each case.

\subsection{\tt cobasis}
\label{cobasis}

\begin{syntax}
	cobasis \meta{arg}
\end{syntax}
returns the cobasis for \meta{arg}, which may be either a \meta{coframing}
or an \meta{EDS} (sections \ref{Coframings}, \ref{Exterior differential
systems}). The order of the items in the list gives the \meta{kernel}
ordering which applies when the \meta{coframing} in \meta{arg} is active.

\subsection{\tt coordinates}
\label{coordinates}

\begin{syntax}
	coordinates \meta{arg}
\end{syntax}
returns the coordinates for \meta{arg}, which may be either a
\meta{coframing}, an \meta{EDS}, or a list of \meta{expr} (sections
\ref{Coframings}, \ref{Exterior differential systems}). The coordinates in a
list of \meta{expr} are defined to be those 0-form \meta{kernels} with no
implicit dependencies.

\paragraph{\it Examples:}
\begin{verbatim}
coordinates contact(3,{x},{u});

   {x,u,u ,u   ,u     }
         x  x x  x x x 

fdomain u=u(x);
coordinates {d u+d y};

   {x,y} 
\end{verbatim}

\subsection{\tt structure\_equations}
\label{structure_equations}

\begin{syntax}
	structure\_equations \meta{arg}
\end{syntax}
returns the structure equations (cf section \ref{Coframings}) for
\meta{arg}, which may be either a \meta{coframing}, an \meta{EDS}, or a
\meta{transform} (sections \ref{Coframings}, \ref{Exterior differential
systems}, \ref{Cobasis transformations}). In the case of a
\meta{transform}, it is assumed the exterior derivatives of the right-hand
sides are known, and a list giving the exterior derivatives of the
left-hand sides is returned. This requires inverting the transformation. In
case this has already been done, and was time consuming, an alternative
syntax
\begin{syntax}
	structure\_equations(\meta{transform},\meta{inverse transform})
\end{syntax}
avoids recomputing the inverse.

\paragraph{\it Example:}
\begin{verbatim}
structure_equations{e 1=d x/x,e 2=x*d y};

       1         2     1  2
   {d e  => 0,d e  => e ^e } 
\end{verbatim}

\subsection{\tt restrictions}
\label{restrictions}

\begin{syntax}
	restrictions \meta{arg}
\end{syntax}
returns the restrictions for \meta{arg}, which may be either a
\meta{coframing} or an \meta{EDS} (sections \ref{Coframings}, \ref{Exterior
differential systems}). The result is a list of inequalities.

\subsection{\tt system}
\label{system}

\begin{syntax}
	system \meta{EDS}
\end{syntax}
returns the system component of an \meta{EDS} (sections \ref{Exterior
differential systems}, \ref{Systems}) as a list of \meta{p-form}
expressions. (The PSL-based REDUCE command \f{system} operates as before:
the syntax
\begin{syntax}
	system "\meta{command}"
\end{syntax}
executes an operating system (eg UNIX) command.)

\subsection{\tt independence}
\label{independence}

\begin{syntax}
	independence \meta{EDS}
\end{syntax}
returns the independence condition of an \meta{EDS} (section \ref{Exterior
differential systems}) as a list of \meta{1-form} expressions.


\subsection{\tt properties}
\label{properties}

\begin{syntax}
	properties \meta{EDS}
\end{syntax}
returns the currently known properties of an \meta{EDS} (sections
\ref{Exterior differential systems}, \ref{Properties}) as a list of
equations of the form {\tt\meta{keyword} = \meta{value}}.

\paragraph{\it Example:}
\begin{verbatim}
properties closure contact(1,{x},{u});

   {closed=1,pfaffian=1,quasilinear=1}
\end{verbatim}


\subsection{\tt one\_forms}
\label{one_forms}

\begin{syntax}
	one\_forms \meta{arg}
\end{syntax}
returns the 1-forms in \meta{arg}, which may be either an \meta{EDS} or a
list of \meta{expr} (sections \ref{Exterior differential systems},
\ref{Systems}).

\paragraph{\it Example:}
\begin{verbatim}
one_forms {5,x*y - u,d u - x*d y,d u^d x- x*d y^d x};

   {d u - d y*x} 
\end{verbatim}

\subsection{\tt zero\_forms, nought\_forms}
\label{zero_forms}

\begin{syntax}
	zero\_forms \meta{arg}
\end{syntax}
returns the 0-forms in \meta{arg}, which may be either an \meta{EDS} or a
list of \meta{expr} (sections \ref{Exterior differential systems},
\ref{Systems}). The alternative syntax \f{nought\_forms} does the same thing.

\paragraph{\it Example:}
\begin{verbatim}
zero_forms {5,x*y - u,d u - x*d y,d u^d x- x*d y^d x};

   {5, - u + x*y} 
\end{verbatim}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Manipulating EDS objects}
\label{Manipulating EDS objects}

The abililty to change coordinates or cobasis, or to modify the system or
coframing can make the difference between an intractible problem and a
solvable one. The facilities described in this section form the low-level
core of EDS functions.

Most of the operators in this section can be applied to both \meta{EDS} and
\meta{coframing} objects. Where it makes sense (eg \f{pullback},
\f{restrict} and \f{transform}), they can be applied to a \meta{system}, or
list of differential forms as well.

\subsection{\tt augment}
\label{augment}

\begin{syntax}
	augment(\meta{EDS},\meta{system})
\end{syntax}
appends the extra forms in the second argument to the system part of the
first. If the forms in the \meta{system} do not live on the coframing of the
\meta{EDS}, an error results. The original \meta{EDS} is unchanged.

\paragraph{\it Example:}
\begin{verbatim}
% Non-Pfaffian system for a Monge-Ampere equation
S := contact(1,{x,y},{z})$
S := augment(S,{d z(-x)^d z(-y)});

   s := EDS({d z - z *d x - z *d y,
                    x        y 

             d z ^d z },{d x,d y})
                x    y 
\end{verbatim}

\subsection{\tt cross}
\label{cross}

The infix operator \f{cross} gives the direct product of
\meta{coframing} objects. The syntax is
\begin{syntax}
	\meta{arg1} cross \meta{arg2} \optional{cross $\cdots$}
\end{syntax}
The first argument may be either a \meta{coframing} (section
\ref{Coframings}) or an \meta{EDS} (section \ref{Exterior differential
systems}). The remaining arguments may be either \meta{coframing}
objects or any valid argument to the \f{coframing} operator (section
\ref{coframing}), in which case the corresponding \meta{coframing} is
automatically inferred. The arguments may not contain any common
coordinates or cobasis elements.

If the first argument is an \meta{EDS}, the result is the \meta{EDS}
lifted to the direct product space. In this way, it is possible to
execute a pullback under a projection. 

\paragraph{\it Example:}
\begin{verbatim}
coordinates(contact(1,{x,y},{u}) cross {v});

   {x,y,u,u ,u ,v}
           x  y 
\end{verbatim}

\subsection{\tt pullback}
\label{pullback}

Pullbacks with respect to an EDS \meta{map} (section \ref{Maps}) have the
syntax
\begin{syntax}
	pullback(\meta{arg},\meta{map})
\end{syntax}
where \meta{arg} can be any one of \meta{EDS}, \meta{coframing},
\meta{system} or \meta{p-form} expression (sections \ref{Exterior
differential systems}, \ref{Coframings}, \ref{Systems}). The result is of
the same type as \meta{arg}.

For an \meta{EDS} or \meta{coframing} with anholonomic cobasis, \f{pullback}
calculates the pullbacks of the cobasis elements and chooses a cobasis for
the source coframing itself. For a \meta{system}, any zeroes in the result
are dropped from the list.

\paragraph{\it Examples:}
\begin{verbatim}
pullback(contact(1,{x,y},{u}),{u(-y) = u*u(-x)});

   EDS({d u - u *d x - u *u*d y},{d x,d y})
               x        x 

M := coframing({e 1,e 2},{r},{r neq 0},
               {d r=>e 1,d e 1=>0,d e 2=>e 1^e 2/r})$

pullback(M,{r=1/x});
                                     2
               2              2     e ^d x
   coframing({e ,d x},{x},{d e  => --------},{x neq 0})
                                      x 

pullback(ws,{x=0});

   ***** Map image not within target coframing in pullback  

pullback({y*d y,d y - d x},{y=x});

   {d x*x}
\end{verbatim}

\subsection{\tt restrict}
\label{restrict}

Restrictions with respect to an EDS \meta{map} (section \ref{Maps}) have the
syntax
\begin{syntax}
	restrict(\meta{arg},\meta{map})
\end{syntax}
where \meta{arg} can be any one of \meta{EDS}, \meta{coframing},
\meta{system} or \meta{p-form} expression (sections \ref{Exterior
differential systems}, \ref{Coframings}, \ref{Systems}). The result is of
the same type as \meta{arg}. The action of \f{restrict} is similar to that
of \f{pullback}, except that only scalar coefficients are affected: 1-form
variables are unchanged.

\paragraph{\it Examples:}
\begin{verbatim}
% Bring a system into normal form by restricting the coframing

S := eds({u*d v - v*d u},{d x});

   s := EDS({v*d u - u*d v},{d x}) 

restrict(S,{u neq 0});

               v
   EDS({d v - ---*d u},{d x})
               u 

% Difference between restrict and pullback

pullback({x*d x - y*d y},{x=y,y=1});

   {}

restrict({x*d x - y*d y},{x=y,y=1});

   {d x - d y}
\end{verbatim}

\subsection{\tt transform}
\label{transform}

A change of cobasis is made using the \f{transform} operator
\begin{syntax}
	transform(\meta{arg},\meta{transform})
\end{syntax}
where \meta{arg} can be any one of \meta{EDS}, \meta{coframing},
\meta{system} or \meta{p-form} expression (sections \ref{Exterior
differential systems}, \ref{Coframings}, \ref{Systems}) and \meta{transform}
is a list of substitutions (cf section \ref{Cobasis transformations}). The
result is of the same type as \meta{arg}.

For an \meta{EDS} or \meta{coframing}, \f{transform} can detect whether the
tranformation is given in the forward or reverse direction and invert
accordingly. Structure equations are updated correctly. If an exact cobasis
element is eliminated, its expression in terms of the new cobasis is added
to the list of structure equations, since the corresponding coordinate may
still be present elsewhere in the structure.

\paragraph{\it Example:}
\begin{verbatim}
S := contact(1,{x},{u});

   s := EDS({d u - u *d x},{d x})
                    x

new := {e(1) = first system S,w(1) = d x};

            1               1
   new := {e =d u - d x*u ,w =d x}
                         x 

S := transform(S,new);

              1    1
   s := EDS({e },{w }) 

structure_equations s;

       1             1
   {d e  =>  - d u ^w ,
                  x 
       1
    d w  => 0, 

            1       1
    d u => e  + u *w ,
                 x 
            1
    d x => w }
\end{verbatim}

\subsection{\tt lift}
\label{lift}

Many of the analysis tools (section \ref{Analysing exterior systems})
cannot treat systems containing 0-forms. The \f{lift} operator
\begin{syntax}
	lift \meta{EDS}
\end{syntax}
solves the 0-forms in the system and uses the solution to pull back to a
smaller manifold. This may generate new 0-form conditions (in the course of
bringing the pulled-back system into normal form), in which case the
process is repeated until the system is generated in positive degree. In
non-linear problems, the solution space of the 0-forms may be a variety, in
which case a compound \meta{EDS} (section \ref{Exterior differential
systems}) will result. If \f{edsverbose} is on (section \ref{edsverbose}),
the solutions are displayed as they are generated.

\paragraph{\it Example:}
\begin{verbatim}
S := augment(contact(2,{x,y},{u}),{u(-y,-y)-u(-x,-x)})$
on edsverbose;
lift S;
   Solving 0-forms 
   New equations:  
   u   =u
    y y  x x  

   EDS({d u - u *d x - u *d y,
               x        y 

        d u  - u   *d x - u   *d y,
           x    x x        x y 

        d u  - u   *d x - u   *d y},{d x,d y})
           y    x y        x x 
\end{verbatim}


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Analysing exterior systems}
\label{Analysing exterior systems}

This section describes higher level operators for extracting information
about exterior systems. Many of them require a \meta{EDS} in normal form
(section \ref{Normal form}) generated in positive degree as input, but some
can also analyse a \meta{system} (section \ref{Systems}) or a single
\meta{p-form}. Only trivial examples are provided in this section, but many
of these operators are used in the longer examples in the test file which
accompanies this package.


\subsection{\tt cartan\_system}
\label{cartan_system}

The {\em Cartan system} of a form or system $S$ is the smallest Pfaffian
system $C$ such that $\Lambda(C)$ contains a set $I$ of forms algebraically
equivalent to $S$. The Cartan system is also known as the {\em associated
Pfaff system} or {\em retracting space}. An alternative characterisation is
to note that the annihilator $C^\perp$ comprises all vectors $V$ satisfying
$i_V S \simeq 0 \pmod{S}$.  Note this is a purely algebraic concept: $S$
need not be closed under differentiation. See also \f{cauchy\_system}
(section \ref{cauchy_system}).

The operator
\begin{syntax}
	cartan\_system \meta{arg}
\end{syntax}
returns the Cartan system of \meta{arg}, which may be an \meta{EDS}, a
\meta{system} or a single \meta{p-form} expression (sections \ref{Exterior
differential systems}, \ref{Systems}). For an \meta{EDS}, the result is a
Pfaffian \meta{EDS} on the same manifold, otherwise it is a
\meta{system}. The argument must be generated in positive degree.

\paragraph{\it Example:}
\begin{verbatim}
cartan_system{d u^d v + d v^d w + d x^d y};

   {d u - d w,d v,d x,d y}
\end{verbatim}

\subsection{\tt cauchy\_system}
\label{cauchy_system}

The {\em Cauchy system} $C$ of a form or system $S$ is the Cartan system or
retracting space of its closure under exterior differentiation (section
\ref{cartan_system}). The annihilator $C^\perp$ consists of the Cauchy
vectors for the $S$.

The operator
\begin{syntax}
	cauchy\_system \meta{arg}
\end{syntax}
returns the Cauchy system of \meta{arg}, which may be an \meta{EDS}, a
\meta{system} or a single \meta{p-form} expression (sections \ref{Exterior
differential systems}, \ref{Systems}). For an \meta{EDS}, the result is a
Pfaffian \meta{EDS} on the same manifold, otherwise it is a
\meta{system}. The argument must be generated in positive degree.

\paragraph{\it Example:}
\begin{verbatim}
cauchy_system{u*d v + v*d w + x*d y};

   {d u,d v,d w,d x,d y}
\end{verbatim}

\subsection{\tt characters}
\label{characters}

The Cartan characters $\{s_1,...,s_n\}$ of an \meta{EDS} or \meta{tableau}
(sections \ref{Exterior differential systems}, \ref{Tableaux}) are obtained
with
\begin{syntax}
	characters \meta{EDS} \qquad{\em or}\qquad characters \meta{tableau}
\end{syntax}
The zeroth character $s_0$ is not returned, it is simply the number of
1-forms in the \meta{EDS} (cf \f{one\_forms}, section \ref{one_forms}). The
definition used for the last character: $s_n = (d - n) - (s_0 + s_1 + ... +
s_{n-1})$, where $d$ is the manifold dimension, allows Cartan's test to be
used even when Cauchy characteristics are present.

For a nonlinear \meta{EDS}, the Cartan characters can vary from stratum to
stratum of the Grassmann bundle variety of ordinary integral elements (cf
\f{grassmann\_variety} in section \ref{grassmann_variety}). Nonetheless,
they are constant on each stratum, so it suffices to calculate them at one
point (ie at one integral element). This is done using the syntax
\begin{syntax}
	characters(\meta{EDS},\meta{integral element})
\end{syntax}
where \meta{integral element} is a list of 1-forms (cf section
\ref{Integral elements}).

The Cartan characters are calculated from the reduced characters for a
fixed flag of integral elements based on the 1-forms in the independence
condition of an \meta{EDS}. This can lead to incorrect results if the flag
is somehow singular, so two switches are provided to overcome this (section
\ref{ranpos}). First, \f{genpos} looks at a generic flag by using a general
linear transformation to put the system in {\em general position}. This
guarantees correct results, but can be too slow for practical
purposes. Secondly, \f{ranpos} performs a linear transformation using a
sparse matrix of random integers. In most cases, this is much faster than
using general position, and a few repetitions give some confidence in the
results.

\paragraph{\it Example:}
\begin{verbatim}
S := pullback(contact(2,{x,y},{u}),{u(-x,-y)=0});

   s := EDS({d u - u *d x - u *d y,
                    x        y 

             d u  - u   *d x,
                x    x x 

             d u  - u   *d y},{d x,d y})
                y    y y

characters S;

   {1,1} 

on ranpos; characters S;

   {2,0}
\end{verbatim}

\subsection{\tt closure}
\label{closure}

\begin{syntax}
	closure \meta{EDS}
\end{syntax}
returns the closure of the \meta{EDS} under exterior differentiation. 

Owing to conflicts with the requirements of a normal form (section
\ref{Normal form}), \f{closure} cannot guarantee that the resulting system
is closed if the \meta{EDS} contains 0-forms.

\subsection{\tt derived\_system}
\label{derived_system}

\begin{syntax}
	derived\_system \meta{arg}
\end{syntax}
returns the first derived system of \meta{arg}, which must be a Pfaffian
\meta{EDS} or \meta{system}. Repeated use gives the derived flag leading to
the maximal integrable subsystem.

\paragraph{\it Example:}
\begin{verbatim}
pform {p,r,x,y,z}=0; korder z;
derived_system eds({d z - q*d y,d p - e**z*d y,
                    d r - e**z*p*d y,d x},{d y});

               z            z
   EDS({d p - e *d y,d r - e *p*d y,d x},{d y}) 

derived_system ws;

               1
   EDS({d p - ---*d r,d x},{d y})
               p 

derived_system ws;

               1
   EDS({d p - ---*d r,d x},{d y})
               p 
\end{verbatim}

\subsection{\tt dim\_grassmann\_variety}
\label{dim_grassmann_variety}

\begin{syntax}
	dim\_grassmann\_variety \meta{EDS}
\end{syntax}
returns the dimension of the Grassmann bundle variety of ordinary integral
elements for an \meta{EDS} (cf \f{grassmann\_variety}, section
\ref{grassmann_variety}). This number is useful, for example, in Cartan's
test. For a nonlinear \meta{EDS}, this can vary from stratum to stratum of
the variety, so
\begin{syntax}
	dim\_grassmann\_variety(\meta{EDS},\meta{integral element})
\end{syntax}
returns the dimension of the stratum containing the \meta{integral element}
(cf section \ref{Integral elements}).

\subsection{\tt dim}
\label{dim}

\begin{syntax}
	dim \meta{arg}
\end{syntax}
returns the dimension of the manifold underlying \meta{arg},
which can be either an \meta{EDS} or a \meta{coframing} (sections \ref{Exterior
differential systems}, \ref{Coframings}).

\subsection{\tt involution}
\label{involution}

\begin{syntax}
	involution \meta{EDS}
\end{syntax}
repeatedly prolongs an \meta{EDS} until it reaches involution or
inconsistency (cf \f{prolong}, section \ref{prolong}). The system must be
in normal form (section \ref{Normal form}) and generated in positive
degree. For nonlinear problems, all branches of the prolongation tree are
followed. The result is an \meta{EDS} (usually a compound one for
nonlinear problems, see section \ref{Exterior differential systems})
giving the involutive prolongation. In case some variety couldn't be
resolved during the process, the relevant branch is truncated at that point
and represented by a system with 0-forms, as with \f{grassmann\_variety}
(section \ref{grassmann_variety}). The result of \f{involution} might then
{\em not} be in involution.

If the \f{edsverbose} switch is on (section \ref{edsverbose}), a trace of
the prolongations is produced. See the Janet problem in the test file for
an example.

\subsection{\tt linearise, linearize}
\label{linearise}

A nonlinear exterior system can be linearised at some point on the
manifold with respect to any integral element, yielding a constant
coefficient exterior system with the same Cartan characters. In EDS,
reference to the point is omitted, so the result is an exterior system
linearised with respect to a distribution of integral elements. The syntax
is
\begin{syntax}
	linearise(\meta{EDS},\meta{integral element})
\end{syntax}
but \f{linearize} will work just as well. See the isometric embeddings
example in the test file.

For a quasilinear \meta{EDS} (cf section \ref{quasilinear}),
\begin{syntax}
	linearise \meta{EDS}
\end{syntax}
returns an equivalent exterior system containing only linear generators.

\paragraph{\it Example:}
\begin{verbatim}
f := d u^d x + d v^d y$
S := eds({f,d v^f},{d x,d y});

   s := EDS({d u^d x + d v^d y,d u^d v^d x},{d x,d y}) 

linearise S;

   EDS({d u^d x + d v^d y},{d x,d y}) 
\end{verbatim}

\subsection{\tt integral\_element}
\label{integral_element}

\begin{syntax}
	integral\_element \meta{EDS}
\end{syntax}
returns a random \meta{integral element} of the \meta{EDS} (section
\ref{Integral elements}). The system must be in normal form (section
\ref{Normal form}) and generated in positive degree. This integral element
is found using the method described by Wahlquist \cite{Wahlquist}
(essentially the Cartan-K{\"a}hler construction filling in the free variables
from each polar system with random integer values). This method can fail on
non-involutive systems, or \meta{EDS} objects whose independence conditions
indicate a singular flag of integral elements (cf the discussion about
Cartan characters, section \ref{characters}).

See the isometric embedding problem in the test file for an example.

\subsection{\tt prolong}
\label{prolong}

\begin{syntax}
	prolong \meta{EDS}
\end{syntax}
calculates the prolongation of the \meta{EDS} to the Grassmann bundle
variety of integral elements. The system must be in normal form (section
\ref{Normal form}) and generated in positive degree. The variety is
decomposed using essentially the REDUCE \f{solve} operator. If no solutions
can be found, the variety is empty, and the prolongation is the
inconsistent \meta{EDS} (section \ref{Exterior differential
systems}). Otherwise, the result is a list of variety components, which
fall into three classes:
\begin{enumerate}
\item a submanifold of the Grassmann bundle which surjects onto the base
      manifold. The result in this case is the pullback of the Grassmann
      bundle contact \meta{EDS} to this submanifold.
\item a submanifold of the Grassmann bundle which does not surject onto the
      base manifold (ie cannot be presented by solving for Grassmann
      bundle fibre coordinates). The result in this case is the pullback of
      the original \meta{EDS} to the projection onto the base manifold. If
      0-forms arise in bringing the pullback to normal form, these are
      solved recursively and the system pulled back again until the result
      is generated in positive degree (cf \f{lift}, section \ref{lift}).
\item a component of the variety which \f{solve} was not able to resolve
      explicitly. The result in this case is the Grassmann bundle contact
      \meta{EDS} augmented with the 0-forms which \f{solve} couldn't
      treat. This can be extracted from the result of \f{prolong} and
      manipulated further ``by hand'',
\end{enumerate}
The result returned by \f{prolong} will, in general, be a compound
\meta{EDS} (section \ref{Exterior differential systems}). If the switch
\f{edsverbose} (section \ref{edsverbose}) is on, a trace of the
prolongation is printed.

The \meta{map}s which are generated in a \f{prolong} call are available
subsequently in the global variable \f{pullback\_maps}. This facility is
still very primitive and unstructured. It should be extended to the
\f{involution} operator as well...

\paragraph{\it Example:}
\begin{verbatim}
pde := {u(-y,-y)=u(-x,-x)**2/2,u(-x,-y)=u(-x,-x)};

                       2
                 (u   )
                   x x
   pde := {u   =---------,u   =u   }
            y y     2      x y  x x 

S := pullback(contact(2,{x,y},{u}),pde)$
on edsverbose;
prolong S;
   Reduction using new equations:  
   u   =1
    x x 
   Prolongation using new equations:  
   u     =0
    x x x  
   u     =0
    x x y 
   
   {EDS({d u - u *d x - u *d y,
                x        y 
   
         d u  - d x - d y,
            x 
                       1
         d u  - d x - ---*d y},{d x,d y}),
            y          2 
   
    EDS({d u - u *d x - u *d y,
                x        y 
   
         d u  - u   *d x - u   *d y,
            x    x x        x x 
                                  2
                            (u   )
                              x x
         d u  - u   *d x - ---------*d y,
            y    x x           2 
   
         d u   },{d x,d y})}
            x x 
\end{verbatim}

\subsection{\tt tableau}
\label{tableau}

\begin{syntax}
	tableau \meta{EDS}
\end{syntax}
returns the \meta{tableau} (section \ref{Tableaux}) of a quasilinear
Pfaffian \meta{EDS}, which must be in normal form and generated in positive
degree.

\paragraph{\it Example:}
\begin{verbatim}
tableau contact(2,{x,y},{u});

   [d u     d u   ]
   [   x x     x y]
   [              ]
   [d u     d u   ]
   [   x y     y y] 
\end{verbatim}

\subsection{\tt torsion}
\label{torsion}

For a semilinear Pfaffian exterior differential system, the torsion
corresponds to first-order integrability conditions for the
system. Specifically,
\begin{syntax}
	torsion \meta{EDS}
\end{syntax}
returns a list of 0-forms describing the projection of the Grassmann bundle
variety of integral elements onto the base manifold. If the switch
\f{edssloppy} (section \ref{edssloppy}) is on, quasilinear systems are
treated as semilinear. A semilinear system is involutive if both the
torsion is empty, and Cartan's test for the reduced characters is
satisfied.

\paragraph{\it Example:}
\begin{verbatim}
S := pullback(contact(2,{x,y},{u}),
              {u(-y,-y)=u(-x),u(-x,-y)=u});

   s := EDS({d u - u *d x - u *d y,
                    x        y 
   
             d u  - u   *d x - u*d y,
                x    x x 
   
             d u  - u*d x - u *d y},{d x,d y})
                y            x 
torsion s;

   {u    - u }
     x x    y 
\end{verbatim}

\subsection{\tt grassmann\_variety}
\label{grassmann_variety}

Given an exterior system $(S,\Omega,M)$ with independence condition of
rank $n$, the Grassmann bundle of $n$-planes over $M$ contains a
submanifold characterised by those $n$-planes compatible with the
independence condition. All integral elements must lie in this
submanifold. The operator
\begin{syntax}
	grassmann\_variety \meta{EDS}
\end{syntax}
returns the contact system for this part of the Grassmann bundle augmented
by the 0-forms specifying the variety of integral elements of $S$. In cases
where \f{prolong} (section \ref{prolong}) is unable to decompose the
variety automatically, \f{grassmann\_variety} can be used in combination
with \f{zero\_forms} (section \ref{zero_forms}) to calculate the variety
conditions. Any solutions found ``by hand'' can be incorporated using
\f{pullback} (section \ref{pullback}).

\paragraph{\it Example:}
Using the system from the example in section \ref{prolong}:
\begin{verbatim}
zero_forms grassmann_variety S;

   { - u     *u    + u     ,
        x x x  x x    x x y 
   
     - u      + u     }
        x x x    x x y 

solve ws;

   Unknowns: {u     ,u     ,u   }
               x x x  x x y  x x
   
   {{u     =0,u     =0},
      x x y    x x x 
   
    {u   =1,u     =u     }}
      x x    x x x  x x y 
\end{verbatim}
The second solution contains an integrability condition.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Testing exterior systems}
\label{Testing exterior systems}

The operators in this section allow various properties of an \meta{EDS} to
be checked. These checks are done automatically when required on entry to
the routines in sections \ref{Manipulating EDS objects} and \ref{Analysing
exterior systems}, but sometimes it is useful to know explicitly. The
result is either a \f{1} (true) or a \f{0} (false), so the operators can be
used in boolean expressions within \f{if} statements etc.  Since checking
these properties can be very time-consuming, the result of the first test
is stored on the \meta{properties} record of an \meta{EDS} to avoid
re-checking. This memory can be cleared using the \f{cleanup} operator.

\subsection{\tt closed}
\label{closed}

\begin{syntax}
	closed \meta{arg}
\end{syntax}
checks whether \meta{arg}, which may be an \meta{EDS}, a \meta{system} or a
single \meta{p-form} is closed under exterior differentiation.

\paragraph{\it Examples:}
\begin{verbatim}
closed(x*d x);

   1

closed {d u - p*d x,d p - p/y*d x};

   0
\end{verbatim}

\subsection{\tt involutive}
\label{involutive}

\begin{syntax}
	involutive \meta{EDS}
\end{syntax}
checks whether \meta{EDS} is involutive, using Cartan's test. See the test
file for examples.

\subsection{\tt pfaffian}
\label{pfaffian}

\begin{syntax}
	pfaffian \meta{EDS}
\end{syntax}
checks whether \meta{EDS} is a Pfaffian system: generated by a set of
1-forms and their exterior derivatives. The \meta{EDS} must be in normal
form (section \ref{Normal form}) for this to succeed. Systems with 0-forms
are non-Pfaffian by definition in EDS.

\paragraph{\it Examples:}
\begin{verbatim}
pfaffian eds({d u - p*d x - q*d y,d p^d x+d q^d y},{d x,d y});

   1

pfaffian eds({d u - p*d x - q*d y,d p^d q},{d x,d y});

   0
\end{verbatim}

\subsection{\tt quasilinear}
\label{quasilinear}

An exterior system $(S,\Omega,M)$ is said to be {\em quasilinear} if, when
written in the standard cobasis $\{\theta^a,\pi^\rho,\omega^i\}$ (section
\ref{Standard cobasis}), its {\em closure} can be generated by a set of
forms which are of combined total degree 1 in $\{\theta^a,\pi^\rho\}$. The
operation
\begin{syntax}
	quasilinear \meta{EDS}
\end{syntax}
checks whether the {\em closure} of \meta{EDS} is a quasilinear system. The
\meta{EDS} must be in normal form (section \ref{Normal form}) for this to
succeed. Systems with 0-forms are not quasilinear by definition in EDS.

\paragraph{\it Examples:}
\begin{verbatim}
% A system where pi(rho)={d p,d q}, and which looks non-linear

S := eds({d u - p*d x - q*d y,d p^d q^d y},{d x,d y})$

quasilinear S;

   1

linearise closure S;

   EDS({d u - p*d x - q*d y, 
         - d p^d x - d q^d y},{d x,d y})

% One which is really non-linear

quasilinear eds({d u - p*d x - q*d y,d p^d q},{d x,d y});

   0
\end{verbatim}

\subsection{\tt semilinear}
\label{semilinear}

Let $(S,\Omega,M)$ be such that, written in the standard cobasis
$\{\theta^a,\pi^\rho,\omega^i\}$ (section \ref{Standard cobasis}), its
closure is explicitly quasilinear. If the coefficients of $\{\pi^\rho\}$
depend only on the independent variables, then the system is said to be
{\em semilinear}.  The operation
\begin{syntax}
	semilinear \meta{EDS}
\end{syntax}
checks whether {\em closure} of \meta{EDS} is a semilinear system. The
\meta{EDS} must be in normal form (section \ref{Normal form}) for this to
succeed. Systems with 0-forms are not semilinear by definition in EDS.

For semilinear systems, the expressions determining the Grassmann bundle
variety of integral elements will be linear in the Grassmann bundle fibre
coordinates, with coefficients which depend only upon the independent
variables. This allows alternative, faster algorithms to be used in
analysis.

If the switch \f{edssloppy} is on (section \ref{edssloppy}), all
quasilinear systems are treated as if they are semilinear.

\paragraph{\it Examples:}
\begin{verbatim}
% A semilinear system: @(u,y) = y*@(u,x)
S := eds({d u - p*d x - p*y*d y},{d x,d y})$
semilinear S;

   1
% A quasilinear system: @(u,y) = u*@(u,x)
S := eds({d u - p*d x - p*u*d y},{d x,d y})$
quasilinear S;

   1
semilinear S;

   0
on edssloppy;
semilinear S;

   1
\end{verbatim}

\subsection{\tt frobenius}
\label{frobenius}

\begin{syntax}
	frobenius \meta{arg}
\end{syntax}
checks whether \meta{arg}, which may be an \meta{EDS} or a \meta{system},
is a completely integrable Pfaffian system.

\paragraph{\it Examples:}
\begin{verbatim}
if frobenius eds({d u -p*(d x+d y)},d x^d y) then yes else no;

   no

if frobenius eds({d u -u*(d x+d y)},d x^d y) then yes else no;

   yes
\end{verbatim}

\subsection{\tt equiv}
\label{equiv}

\begin{syntax}
	\meta{EDS1} equiv \meta{EDS2}
\end{syntax}
checks whether \meta{EDS1} and \meta{EDS2} are algebraically equivalent as
exterior systems (ie generate the same algebraic ideal).

\paragraph{\it Examples:}
\begin{verbatim}
S1 := contact(2,{x,y},{u})$
S2 := augment(S1,foreach f in system S1 join {d f,d x^d f})$
if S1 equiv S2 then yes else no;

   no 

if closure S1 equiv S2 then yes else no;

   yes 
\end{verbatim}



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Switches}
\label{Switches}

EDS provides several switches to govern the display of information and 
speed or reliability of the results.

\subsection{\tt edsverbose}
\label{edsverbose}

If \f{edsverbose} is \f{on}, a number of operators (eg \f{prolong},
\f{involution}) will display additional information as the calculation
progresses. For large problems, this can produce too much output to be
useful, so \f{edsverbose} is \f{off} by default. This allows only warning
(\f{***}) and error (\f{*****}) messages to be printed.

\subsection{\tt edsdebug}
\label{edsdebug}

If \f{edsdebug} is \f{on}, EDS produces copious quantities of information,
in addition to that produced with \f{edsverbose} on. This information is
for debugging purposes, and may not make much sense without knowledge of
the inner workings of EDS. \f{edsdebug} is \f{off} by default.

\subsection{\tt edssloppy}
\label{edssloppy}

Normally, EDS will not divide by any expressions it does not know to be
nowhere zero. If an \meta{EDS} can be brought into normal form only by
restricting away from the zeroes of some coefficients, then these
restrictions should be made using the \f{restrict} operator (section
\ref{restrict}). However, if \f{edssloppy} is \f{on}, then EDS will, as a
last resort, divide by whatever is necessary to bring an \meta{EDS} into
normal form, invert a transformation, and so on. The relevant restrictions
will be made automatically, so no inconsistency should arise. In addition,
with \f{edssloppy} \f{on}, all quasilinear systems are treated as if they
were semilinear (cf section \ref{semilinear}). \f{edssloppy} is \f{off} by
default.


\subsection{\tt edsdisjoint}
\label{edsdisjoint}

When decomposing a variety into (something like) smooth components, EDS
normally pays no attention to whether the components are disjoint. Turning
\f{on} the switch \f{edsdisjoint} forces EDS to ensure the decomposition is
a disjoint union (cf \f{disjoin}, section \ref{disjoin}). For large
problems this can lead to a proliferation of singular pieces. If some of
these turn out to be uninteresting, EDS cannot re-join the remaining pieces
into a smaller decomposition. \f{edsdisjoint} is \f{off} by default.

\subsection{\tt ranpos, genpos}
\label{ranpos}

When calculating Cartan characters (eg to check involution), EDS uses the
independence condition of an \meta{EDS} {\em as presented} to define a flag
of integral elements. Depending on the cobasis and ordering, this flag may
be singular, leading to incorrect Cartan characters. To overcome this
problem, the switches \f{ranpos} and \f{genpos} provide a means to select
other flags. With \f{ranpos} \f{on}, a flag defined by taking a random
linear transformation of the 1-forms in the independence condition will be
used. The results may still be incorrect, but the likelihood is much lower.
With \f{genpos} on, a generic (upper triangular) transformation is
used. this guarantees the correct Cartan characters, but reduces
performance too much to be useful for large problems. Both switches are
\f{off} by default, and switching one \f{on} automatically switches the other
\f{off}. See section \ref{characters} for an example.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Auxiliary functions}
\label{Auxiliary functions}

This section describes various operators designed to ease working with
exterior forms and exterior systems in REDUCE.

\subsection{\tt invert}
\label{invert}

\begin{syntax}
	invert \meta{transform}
\end{syntax}
returns a \meta{transform} which is inverse to the given one (section
\ref{transform}). If the \meta{transform} given is only partial, the
1-form \meta{kernel}s to eliminate are chosen based on the prevailing
kernel ordering. If a background coframing (section \ref{Background
coframing}) is active, and \f{edssloppy} (section \ref{edssloppy}) is
\f{off}, \f{invert} will divide by nowhere-zero expressions only.

\paragraph{\it Examples:}
\begin{verbatim}
set_coframing coframing{u,v,w,x,y,z}$
invert {d u = 3*d x - d y + 5*d z, d v = d x + 2*d z};

   {d x=d v - 2*d z,d y= - d u + 3*d v - d z}

% A y coefficient forces a different choice of inverse

invert {d u = 3*d x - y*d y + 5*d z, d v = d x + 2*d z};

   {d x=2*d u - 5*d v + 2*d y*y,d z= - d u + 3*d v - d y*y} 
\end{verbatim}


% \subsection{\tt exact}
% \label{exact}

% \begin{syntax}
% 	exact \meta{expr}
% \end{syntax}
% is a boolean operator which tests if the given expression is an exact
% \meta{kernel} (ie $\d x$ for some variable $x$). More general exact
% expressions are not recognised

% \paragraph{\it Examples:}
% \begin{verbatim}
% if exact d x then yes;

%    yes

% if exact d(x+y) then yes else no;

%    no
% \end{verbatim}

\subsection{\tt linear\_divisors}
\label{linear_divisors}

\begin{syntax}
	linear\_divisors \meta{pform}
\end{syntax}
returns a basis for the space of linear divisors (1-form factors) of a
\meta{p-form}.

\paragraph{\it Example:}
\begin{verbatim}
f := d p^d q^d u - d p^d q^d x*x + d p^d q^d z*y
     - d u^d v^d x*x + d u^d v^d z*y + d u^d x^d y
     + d x^d y^d z*y$
linear_divisors f;

   {d u - d x*x + d z*y}
\end{verbatim}

\subsection{\tt exfactors}
\label{exfactors}
\begin{syntax}
	exfactors \meta{pform}
\end{syntax}
returns a list of factors for a \meta{p-form}, consisting of the linear
divisors plus one more factor. The list is ordered such that the original
expression is a product of the factors in this order.

\paragraph{\it Example:}
\begin{verbatim}
f := d p^d q^d u - d p^d q^d x*x + d p^d q^d z*y
     - d u^d v^d x*x + d u^d v^d z*y + d u^d x^d y
     + d x^d y^d z*y$
exfactors f;

   {d p^d q - d v^d x*x + d v^d z*y + d x^d y, 
    d u - d x*x + d z*y} 

f - (part(ws,0) := ^);

   0
\end{verbatim}

\subsection{\tt index\_expand}
\label{index_expand}

EXCALC caters for indexed variables in which various index names have been
assigned a specific set of values. Any expression with {\em paired} indices
is expanded automatically to an explicit sum over the index set (provided
the EXCALC command \f{nosum} has not been applied). The EDS operator
\f{index\_expand} is designed to expand an expression with {\em free}
indices to an explicit list over the index set, taking some limited account
of the possible index symmetries.

The syntax is
\begin{syntax}
	index\_expand \meta{arg}
\end{syntax}
where \meta{arg} can be an expression, a rule or equation or a boolean
expression, or an arbitrarily nested list of these items. The result is a
flattened list.

\paragraph{\it Examples:}
\begin{verbatim}
indexrange {i,j,k}={1,2,3},{a,b}={x,y};
pform {e(i),o(a,b)}=1;
index_expand(e(i)^e(j));

     1  2  1  3  2  3
   {e ^e ,e ^e ,e ^e }

index_expand{o(-a,-b)+o(-b,-a) => 0};

   {2*o    => 0,o    + o    => 0, 2*o    => 0}
       x x       x y    y x          y y 
\end{verbatim}


\subsection{\tt pde2jet}
\label{pde2jet}

A PDE system can be encoded into EDS jet variable notation using
\f{pde2jet}. The syntax is as for \f{pde2eds}:
\begin{syntax}
	pde2jet(\meta{pde}\optional{,\meta{dependent},\meta{independent}})
\end{syntax}
where \meta{pde} is a list of equations or expressions (implicitly assumed
to vanish) specifying the PDE system using either the standard REDUCE
\f{df} operator, or the EXCALC \f{@} operator. If the optional variable
lists \meta{dependent} and \meta{independent} are not given, \f{pde2jet}
infers them from the expressions in \meta{pde}, using the same rules as
\f{pde2eds} (section \ref{pde2eds}).

The result of \f{pde2jet} is the input \meta{pde}, with all derivatives
of dependent variables replaced by indexed 0-form variables from the
appropriate jet bundle. Unlike \f{pde2eds}, \f{pde2jet} does not disturb
the variable dependencies.

\paragraph{\it Example:}
\begin{verbatim}
depend u,x,y; depend v,x,y;
pde2jet({df(u,y,y)=df(v,x),df(v,y)=y*df(v,x)});

   {u   =v ,
     y y  x

    v =v *y}
     y  x
\end{verbatim}


\subsection{\tt mkdepend}
\label{mkdepend}

The \f{mkdepend} operator is intended for restoring the dependencies
destroyed by a call to \f{pde2eds} (section \ref{pde2eds}). The syntax is
\begin{syntax}
	mkdepend \{\meta{list of variables},$\cdots$\}
\end{syntax}
where the first variable in each list is declared to depend on the
remaining ones.


\subsection{\tt disjoin}
\label{disjoin}

The \f{disjoin} operator takes a list of \meta{maps} (section \ref{Maps})
describing a decomposition of a variety, and returns an equivalent list of
\meta{maps} such that the components are all disjoint. The background
coframing (section \ref{Background coframing}) should be set appropriately
before calling \f{disjoin}. The syntax is
\begin{syntax}
	disjoin \{\meta{map},$\cdots$\}
\end{syntax}

\paragraph{\it Example:}
\begin{verbatim}
set_coframing coframing {x,y};
disjoin {{x=0},{y=0}};

   {{y=0,x neq 0},{x=0,y neq 0},{y=0,x=0}}
\end{verbatim}

\subsection{\tt cleanup}
\label{cleanup}

To avoid lengthy recomputations, EDS stores various properties (section
\ref{Properties}) and also many intermediate results in a hidden list
attached to each \meta{EDS}. When EDS detects a change in circumstances
which could make the information innacurate, it is discarded and
recomputed. Unfortunately, this mechanism is not perfect, and occasionally
misses something which renders the results incorrect. In such a case, it is
possible to discard all the properties and hidden information using the
\f{cleanup} operator. The call
\begin{syntax}
	cleanup \meta{arg}
\end{syntax}
returns a copy of \meta{arg}, which may be a \meta{coframing} or an
\meta{EDS} which has been stripped of this auxilliary information. Note
that the original input (with possible innacuracies) is left undisturbed by
this operation: the result of \f{cleanup} must be used.

\paragraph{\it Example:}
\begin{verbatim}
% An erroneous property assertion
S := eds({d u - p*d x},{d x,d y},{closed = 1})$
closure S;

   EDS({d u - p*d x},{d x,d y});

S := cleanup S$
properties S;

   {}

closure S;

   EDS({d u - p*d x, - d p^d x},{d x,d y});
\end{verbatim}

\subsection{\tt reorder}
\label{reorder}

All operations with a \meta{coframing} or \meta{EDS} temporarily override
the prevailing kernel order with their own. Thus the ordering of the
cobasis elements in a \meta{coframing} operator remains fixed, even when a
REDUCE \f{korder} statement is issued. To enforce conformity to the
prevailing kernel order, the \f{reorder} operator is available. The call
\begin{syntax}
	reorder \meta{arg}
\end{syntax}
returns a copy of \meta{arg}, which may be a \meta{coframing} or an
\meta{EDS} which has been reordered. Note that the original input is left
undisturbed by this operation: the result of \f{reorder} must be used.

\paragraph{\it Example:}
\begin{verbatim}
M := coframing {x,y,z};

   m := coframing({d x,d y,d z},{x,y,z},{},{}) 

korder z,y,x;
reorder m;

   coframing({d z,d y,d x},{z,y,x},{},{}) 
\end{verbatim}



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Experimental facilities}
\label{Experimental facilities}

This section describes various operators in EDS which either not
algorithmically well-founded, or whose implementation is very unstable, or
which have known bugs.


\subsection{\tt poincare}
\label{poincare}

The \f{poincare} operator implements the homotopy integral found in the
proof of Poincar{\'e}'s lemma. The expansion point is the origin of the
coordinates found in the input. The syntax is
\begin{syntax}
	poincare \meta{p-form}
\end{syntax}
If \f{f} is a $p$-form, then \f{poincare f} is a $(p-1)$-form, and
\f{f - poincare d f} is an exact $p$-form.

\paragraph{\it Examples:}
\begin{verbatim}
poincare(3*d x^d y^d z);

   d x^d y*z - d x^d z*y + d y^d z*x 

d ws;

   3*d x^d y^d z

2*x*d y - poincare d(2*x*d y);

   d x*y + d y*x
\end{verbatim}


\subsection{\tt invariants}
\label{invariants}

The \f{invariants} operator implements the algorithm implicit in the
inductive proof of the Frobenius theorem. The syntax is
\begin{syntax}
	invariants(\meta{system}\optional{,\meta{list of coordinate}})
\end{syntax}
where \meta{system} is a set of 1-forms satisfying the Frobenius condition.
The optional second argument specifies the order in which the coordinates
are projected away to get a trivially integrable system.  The CRACK and
ODESOLVE packages are used to solve the ODE systems which arise, so the
limitations of these packages constrain the scope of this operator as well.

\paragraph{\it Examples:}
\begin{verbatim}
invariants {d x*y + d y*x*z + d z*log(y)*x*y};

        z
   { - y *x}

invariants {d y*z**2 - d y*z + d z*y,d x*(1 - z) + d z*x};

       x     y*(z - 1)
   {-------,-----------}
     z - 1       z
\end{verbatim}


\subsection{\tt symbol\_relations}
\label{symbol_relations}

The \f{symbol\_relations} operator finds the linear relations between the
entries of the tableau matrix for a quasilinear system. The syntax is
\begin{syntax}
	symbol\_relations(\meta{EDS},\meta{identifier})
\end{syntax}
where \meta{EDS} is a quasilinear Pfaffian system and \meta{identifier} is
used to create a 2-indexed 1-form which will label the tableau entries.

\paragraph{\it Example:}
\begin{verbatim}
S := pde2eds {df(u,y,y) = df(u,x,x)};

   s := EDS({d u - u *d x - u *d y,
                    x        y
   
             d u  - u   *d x - u   *d y,
                x    x x        x y

             d u  - u   *d x - u   *d y},d x^d y)
                y    x y        x x

symbol_relations(S,pi);

      1       2 
   {pi    - pi   ,
        x       y 
      1       2 
    pi    - pi   }
        y       x 
\end{verbatim}

\subsection{\tt symbol\_matrix}
\label{symbol_matrix}

The \f{symbol\_matrix} operator returns the symbol matrix for a quasilinear
system in terms of a given variable. The syntax is
\begin{syntax}
	symbol\_matrix(\meta{EDS},\meta{identifier})
\end{syntax}
where \meta{EDS} is a quasilinear Pfaffian system and \meta{identifier} is
used to create an indexed 0-form which will parameterise the matrix.

\paragraph{\it Example:}
\begin{verbatim}
% With the same system as for symbol_relations:

symbol_matrix(S,xi);

   [xi    - xi ]
   [  x       y]
   [           ]
   [xi    - xi ]
   [  y       x]
\end{verbatim}

\subsection{\tt characteristic\_variety}
\label{characteristic_variety}

The \f{characteristic\_variety} operator returns the equations specifying
the characteristic variety for a quasilinear
system in terms of a given variable. The syntax is
\begin{syntax}
	characteristic\_variety(\meta{EDS},\meta{identifier})
\end{syntax}
where \meta{EDS} is a quasilinear Pfaffian system and \meta{identifier} is
used to create an indexed 0-form variable. The result is a list of two
lists: the first being the variety equations and the second the variables
involved.

\paragraph{\it Example:}
\begin{verbatim}
% With the same system as for symbol_relations:

characteristic_variety(S,xi);

          2        2
   {{(xi )  - (xi ) },
        x        y 
    {xi ,xi }}
       x   y
\end{verbatim}


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% \section{Examples}
% \label{Examples}

% This section contains some longer examples showing complete calculations
% using the facilities of EDS.

% \subsection{Twisting type-N solutions to Einstein's equations}
% \label{Twisting type-N solutions to Einstein's equations}

% \subsection{Isometric immersions}
% \label{Isometric immersions}

% \subsection{Riemannian submersions}
% \label{Riemannian submersions}

% \subsection{The ``Janet'' problem}
% \label{The ``Janet'' problem}\label{janet}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%\newpage
\appendix
\section{Command tables}\label{tables}

            %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            %           NOTE FOR HTML CONVERTERS             %
            %                                                %
            % The tables in this appendix use special        %
            % macros for fonts which will probably confuse   %
            % an automatic converter.  The best idea would   %
            % be to drop the appendix from the HTML version. %
            %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Syntax elements:
% "..." for literal, <...> for type

\catcode`\"=\active \def"{\bgroup\catcode`\_=\active\literal}
\def\literal#1"{\mbox{\tt#1}\egroup}
\catcode`\<=\active \def<#1>{\mbox{$\langle$\it#1\/$\rangle$}}

% Command Table environment

\newsavebox{\commandtablecaption}
\newenvironment{commandtable}[2]
   {%\savebox\commandtablecaption{#1} % save caption for the end
    \def\mkcaption{\caption{#1}\label{#2}}
    \def\header##1{$\vcenter to 2\baselineskip{\vfill\bf##1\vfill}$}
    \table[htbp]\small\tabular{|p{.4\hsize}|p{.5\hsize}|}\hline}
   {\endtabular%\caption{\usebox\commandtablecaption}
    \mkcaption\endtable}
\def\nl{\par}             % for use within columns

% Text

The tables in this appendix summarise the commands available in EDS.
More detailed descriptions of the syntax and function of each command
are to be found in the earlier sections. In each case, examples of
the command are given, whereby the argument variables have the following
types (see section \ref{EDS data structures and concepts}):

\bigskip
\begin{tabular}{ll}
$E$, $E'$   &\\
$S$         &\\
$M$, $N$    &, or a  specifying a \\
$r$         &\\
$\Omega$    &\\
$f$         &\\
$rsx$       &\\
$cob$       &\\
$crd$, $dep$, $ind$     
            &\\
$drv$       &\\
$pde$       &\\
$X$         &\\
$T$         &\\
$P$         &\\
\end{tabular}


\begin{commandtable}{Commands for constructing EDS objects}{constructors}
\header{Command}
    &\header{Function}\\\hline
"coframing($cob$,$crd$,$rsx$,$drv$)"
    &constructs a  with the given cobasis $cob$, coordinates $crd$,
     restrictions $rsx$ and structure equations $drv$: $crd$, $rsx$ and $drv$
     are optional\\\hline 
"coframing($S$)"
    &constructs a  capable of supporting the given
     \\\hline
"eds($S$,$\Omega$,$M$)"
    &constructs a simple  object with given system and independence
     condition: if $M$ is not supplied, it is deduced from the rest\\\hline
"contact($r$,$M$,$N$)"
    &constructs the  for the contact system of the jet bundle
     $J^r(M,N)$\\\hline
"pde2eds($pde$,$dep$,$ind$)"
    &converts a PDE system to an EDS: dependent and independent
    variables are deduced if they are not specified (variable dependencies
    are removed)\\\hline
"set_coframing($M$)"\nl
"set_coframing($E$)"
    &sets background coframing and returns previous one\\\hline
"set_coframing()"
    &clears background coframing and returns previous one\\\hline
\end{commandtable}


\begin{commandtable}{Commands for inspecting EDS objects}{selectors}
\header{Command}
    &\header{Function}\\\hline
"coframing($E$)"
    &extracts the underlying \\\hline
"coframing()"
    &returns the current background coframing\\\hline
"cobasis($M$)"\nl "cobasis($E$)"
    &extracts the underlying cobasis\\\hline
"coordinates($M$)"\nl "coordinates($E$)"
    &extracts the coordinates\\\hline
"structure_equations($M$)"\nl "structure_equations($E$)"
    &extracts the rules for exterior derivatives for cobasis and 
     coordinates\\\hline
"restrictions($M$)"\nl "restrictions($E$)"
    &extracts the inequalities describing the restrictions 
     in the \\\hline
"system($E$)"
    &extracts the  part of $E$\\\hline
"independence($E$)"
    &extracts the independence condition from $E$ as a Pfaffian
     \\\hline
"properties($E$)"
    &returns the currently known properties of the  $E$ as a list of
     equations $ = $\\\hline
"one_forms($E$)"\nl "one_forms($S$)"
    &selects the 1-forms from a system\\\hline
"zero_forms($E$)"\nl "zero_forms($S$)"
    &selects the 0-forms from a system\\\hline
\end{commandtable}


\begin{commandtable}{Commands for manipulating EDS objects}{manipulators}
\header{Command}
    &\header{Function}\\\hline
"augment($E$,$S$)"
    &appends the extra forms in $S$ to the system in $E$\\\hline
"$M$ cross $N$"\nl "$E$ cross $N$"
    &forms the direct product of two coframings: an  $E$ is lifted
     to the extended space\\\hline
"pullback($E$,$f$)"\nl "pullback($S$,$f$)"\nl "pullback($\Omega$,$f$)"
    &pulls back the first argument using the  $f$\\\hline
"pullback($M$,$f$)"
    &returns a  $N$ suitable as the source for $f:N\to M$\\\hline
"restrict($E$,$f$)"\nl "restrict($S$,$f$)"\nl "restrict($\Omega$,$f$)"
    &restricts the first argument to the points specified by the 
      $f$\\\hline
"restrict($M$,$f$)"
    &adds the restrictions in $f$ to $M$\\\hline
"transform($M$,$X$)"\nl "transform($E$,$X$)"\nl
"transform($S$,$X$)"\nl "transform($\Omega$,$X$)"
    &applies the change of cobasis $X$ to the first argument: for a 
     $M$ or an  $E$, $X$ may be specified in either the forward or
     reverse direction\\\hline
"lift($E$)"
    &eliminates any 0-forms in $E$ by solving and pulling back\\\hline
\end{commandtable}


\begin{commandtable}{Commands for analysing exterior systems}{analysers}
\header{Command}
    &\header{Function}\\\hline
"cartan_system($E$)"\nl "cartan_system($S$)"\nl "cartan_system($\Omega$)"
    &calculates the Cartan system (associated Pfaff system, retracting
     space): no differentiations are performed\\\hline
"cauchy_system($E$)"\nl "cauchy_system($S$)"\nl "cauchy_system($\Omega$)"
    &calculates the Cauchy system: the Cartan system of the closure under
     exterior differentiation\\\hline
"characters($E$)" \nl "characters($T$)"
    &calculates the (reduced) Cartan characters $\{s_1,...,s_n\}$ 
     ($E$ quasilinear)\\\hline
"characters($E$,$P$)"
    &Cartan characters for a non-linear $E$ at integral element $P$\\\hline
"closure($E$)"
    &calculates the closure of $E$ under exterior
    differentiation\\\hline
"derived_system($E$)"\nl "derived_system($S$)"
    &calculates the first derived system of the Pfaffian system $E$ or
    $S$\\\hline
"dim_grassmann_variety($E$)"\nl "dim_grassmann_variety($E$,$P$)"
    &dimension of the Grassman bundle variety of integral elements: for
    non-linear $E$, the base element $P$ must be given\\\hline
"dim($M$)"\nl "dim($E$)"
    &returns the manifold dimension\\\hline
"involution($E$)"
    &repeatedly prolongs $E$ to involution (or inconsistency)\\\hline
"linearise($E$,$P$)"
    &linearise the (non-linear) EDS $E$ with respect to the integral element
     $P$\\\hline
"integral_element($E$)"
    &find a random  of $E$\\\hline
"prolong($E$)"
    &prolongs $E$, and projects back down to a subvariety of the
     original manifold if integrability conditions arise\\\hline
"tableau($E$)"
    &calculates the  of the quasilinear Pfaffian 
     $E$\\\hline
"torsion($E$)"
    &returns a  of 0-forms specifying the integrability
     conditions for the semilinear or quasilinear Pfaffian 
     $E$\\\hline
"grassmann_variety($E$)"
    &returns the contact  for the Grassmann bundle of $n$-planes
     over the manifold of $E$, augmented by the 0-forms specifying the
     variety of integral elements of $E$\\\hline
\end{commandtable}


\begin{commandtable}{Commands for testing exterior systems}{testers}
\header{Command}
    &\header{Function}\\\hline
"closed($E$)"\nl "closed($S$)"\nl "closed($\Omega$)"
    &checks for closure under exterior differ\-entiation\\\hline
"involutive($E$)"
    &applies Cartan's test for involution\\\hline
"pfaffian($E$)"
    &checks if $E$ is generated by 1-forms and their exterior
     derivatives\\\hline
"quasilinear($E$)"
    &tests if the {\it closure} of $E$ can be generated by forms at
     most linear in the complement of the independence condition\\\hline
"semilinear($E$)"
    &tests if the {\it closure} of $E$ is quasilinear and, in addition, the
    coefficients of the linear terms contain only independent variables or
    constants\\\hline
"$E$ equiv $E'$"
    &checks whether $E$ and $E'$ are algebraically equivalent\\\hline
\end{commandtable}


\begin{commandtable}{Switches (all "off" by default)}{switches}
\header{Switch}
    &\header{Function}\\\hline
"edsverbose"
    &if "on", displays additional information as calculations
    progress\\\hline
"edsdebug"
    &if "on", produces copious quantities of internal information,
    in addition to that produced by "edsverbose"\\\hline
"edssloppy"
    &if "on", allows EDS to divide by expressions not known to be non-zero
    and treats quasilinear systems as semilinear\\\hline
"edsdisjoint"
    &if "on", forces varieties to be decomposed into disjoint
    components\\\hline
"ranpos"\nl "genpos"
    &if "on", uses a random or generic flag of integral elements when
    calculating Cartan characters: otherwise the independence condition as
    presented guides the choice of flag\\\hline 
\end{commandtable}


\begin{commandtable}{Auxilliary functions}{auxilliaries}
\header{Command}
    &\header{Function}\\\hline
\nl "coordinates($S$)"
    &scans the expressions in $S$ for coordinates\\\hline
"invert($X$)"
    &returns the inverse  $X^{-1}$\\\hline
"structure_equations($X$)" \nl
"structure_equations($X$,$X^{-1}$)"
    &returns exterior derivatives of $\mathop{\hbox{lhs}}(X)$\\\hline
"linear_divisors($\Omega$)"
    &calculates a basis for the space of 1-form factors of
     $\Omega$\\\hline
"exfactors($\Omega$)"
    &as for "linear_divisors", but with the additional (non-linear) factor\\\hline
"index_expand($any$)"
    &returns a list of copies of its argument, with free EXCALC indices
     replaced by successive values from the relevant index range\\\hline
"pde2jet($pde$,$dep$,$ind$)"
    &converts a PDE system into jet bundle notation, replacing derivatives by
     jet bundle coordinates (variable dependencies are not affected)\\\hline
"mkdepend($list$)"
    &restores variable dependencies destroyed by "pde2eds"\\\hline
"disjoin($\{f,g,...\}$)"
    &decomposes the variety specified by the given  variables into
     a disjoint union\\\hline
"cleanup($E$)"\nl "cleanup($M$)"
    &returns a fresh copy of $E$ or $M$ with all properties and stored
     results removed\\\hline
"reorder($E$)"\nl "reorder($M$)"
    &returns a fresh copy of $E$ or $M$, conforming to the prevailing
    REDUCE kernel order\\\hline
\end{commandtable}


\begin{commandtable}{Experimental functions (unstable)}{experiments}
\header{Command}
    &\header{Function}\\\hline
"poincare($\Omega$)"
    &calculates the homotopy integral from the proof of Poincar{\'e}'s lemma:
    if $\Omega$ is exact, then the result is a form whose exterior derivative
    gives back $\Omega$\\\hline
"invariants($E$,$crd$)"\nl "invariants($S$,$crd$)"
    &calculates the invariants (first integrals) of a completely
    integrable Pfaffian system using the inductive proof of the Frobenius
    theorem: the optional second argument specifies the
    order in which the coordinates are to be projected away\\\hline
"symbol_relations($E$,$\pi$)"
    &returns relations between the entries of the tableau
    matrix, represented by 2-indexed <1-form> variables $\pi^a{}_i$\\\hline
"symbol_matrix($E$,$\xi$)"
    &returns the symbol matrix for a quasilinear  $E$ as a function
    of <0-form> variables $\xi_i$\\\hline
"characteristic_variety($E$,$\xi$)"
    &returns equations describing the characteristic variety of
    $E$ in terms of <0-form> variables $\xi_i$\\\hline 
\end{commandtable}


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\newpage
\begin{thebibliography}{00}

\bibitem{Shapeev}
	E A Arais, V P Shapeev and N N Yanenko,
	Computer realization of Cartan's exterior calculus, 
	{\em Soviet Math Dokl} {\bf 15} (1974) 203--205
\bibitem{BCGGG}
	R L Byrant, S S Chern, R B Gardner, H L Goldschmidt and
	P A Griffiths, {\em
	Exterior Differential Systems}
	(Springer Verlag, New York, 1991)
\bibitem{Ganzha}
	V G Ganzha, S V Meleshko, F A Murzin, V P Shapeev and
	N N Yanenko,
	Computer realization of an algorithm for investigating the
	compatibility of systems of partial differential equations,
	{\em Soviet Math Dokl} {\bf 24} (1981) 638--640
\bibitem{HartleyTucker} 
	D H Hartley and R W Tucker,
	A constructive implementation of the Cartan-K{\"a}hler theory of
	exterior differential systems,
	{\em J Symb Comp} {\bf12} (1991) 655
\bibitem{XIDEAL}
	D Hartley and P A Tuckey, {\em
	XIDEAL, Gr{\"o}bner Bases for Exterior Algebra}
	(REDUCE library package)
\bibitem{MansfieldFackerell}
	E Mansfield and E D Fackerell,
	Differential Gr{\"o}bner bases and involutivity of systems of
	non-linear partial differential equations,
	{\em submitted to Eur J Appl Math} 1993
\bibitem{Reid}
	G J Reid,
	Algorithms for reducing a system of partial differential equations
	to standard form, determining the dimension of its solutions space
	and calculating its Taylor series solution,
	{\em Eur J Appl Math} {\bf 2} (1991) 293--318
\bibitem{EXCALC}
	E Schr{\"u}fer, {\em
	EXCALC, a system for doing calculations in the calculus of modern
	differential geometry, User's manual}
	(Rand Corporation, Santa Monica, 1986)
\bibitem{Seiler}
	W M Seiler, {\em
	Applying AXIOM to partial differential equations}
	(Internal Report 95-17, Universit{\"a}t Karlsruhe, Fakult{\"a}t f{\"u}r
	Informatik, 1995)
\bibitem{Spivak}
	M Spivak, {\em
	A comprehensive introduction to differential geometry}
	(Publish or Perish, Berkeley, 1979)
\bibitem{Wahlquist}
	HD Wahlquist,
	Monte Carlo calculation of Cartan characters: using the
	maximal-slicing, Ricci-flat ideal as an example,
	{\em Proc Aspects of General Relativity and Mathematical Physics,
	eds N Bret{\'o}n, R Capovilla and
	T Matos}, (1993) 168--174
\end{thebibliography}

\end{document}

Local Variables:
outline-regexp: "\\\\\\(sub\\)*sec"
End:
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/invol.red0000644000175000017500000002100611526203062023101 0ustar  giovannigiovannimodule invol;

% Cartan characters, reduced characters, involution test

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*edsverbose !*edsdebug !*edssloppy !*genpos !*ranpos);


put('characters,'psopfn,'chareval);

symbolic procedure chareval u;
   if length u < 1 or length u > 2 then
      rerror(eds,000,"Wrong number of arguments to characters")
   else if edsp car(u := revlis u) then
      makelist characters(car u,if cdr u then !*a2sys cadr u)
   else
      makelist characterstab !*a2tab u;


symbolic procedure characterstab u;
   % u:tab -> characterstab:list of int
   countchars tp1 foreach r in cdr u collect
      foreach c in r collect c; % copy u because tp1 destroys it


symbolic procedure characters(s,x);
   % s:eds, x:sys -> characters:list of int
   % Have to protect call since kernel ordering changes
   edscall characters1(s,x);


symbolic procedure characters1(s,x);
   % s:eds, x:sys -> characters1:list of int
   begin scalar prl,x,ind,q,sp;
   if not normaledsp s then
      rerror(eds,000,"System not in normal form");
   if scalarpart eds_sys s then
      rerror(eds,000,"Characters with 0-forms not yet implemented");
   s := closure s;
   if quasilinearp s then
      s := car tmpind changeposition lineargenerators s
   else if null x then
      rerror(eds,000,
             "Integral element required for nonlinear EDS characters")
   else
      s := car tmpind changeposition linearise(s,x);
   if not normaledsp s or scalarpart eds_sys s then
      errdhh "Result from tmpind has 0-forms or is not in normal form";
   prl := prlkrns s; ind := indkrns s;
   q := foreach f in nonpfaffpart eds_sys s join
           if f := linearpart(f,prl) then {f};
   x := reversip foreach w on reverse ind collect
           foreach f in q join
              foreach c in ordcomb(cdr w,degreepf f - 2) join
                 if c := xcoeff(f,car w . c) then {c};
   % Get characters from tableau
   x := reverse countchars x;
   % Get last character from s(p) = n - (p + s(0) + s(1) + ... + s(n-1))
   sp := length edscob s - (length ind + length pfaffpart eds_sys s +
                  foreach si in cdr x sum si);
   % Compare the two, since we have them
   if sp neq car x then
      edsverbose("Cauchy characteristics detected from characters",
                 nil,nil);
   return reverse(sp . cdr x);
   end;


symbolic procedure changeposition s;
   % s:eds -> changeposition:eds
   % Transform system to general or random position, depending on
   % switches. Ordering of lists is arranged so that transforms are
   % lower triangular, since this should suffice.  Derivatives are not
   % updated, so s should be closed first if necessary.
   % NB Kernel order changed.
   if !*genpos then
      begin scalar x,new;
      new := for i:=1:length eds_ind s collect
                mkform!*(intern gensym(),1);
      x := reversip foreach k in new collect !*k2pf k;
      x := foreach l on x collect
              zippf(l,(1 ./ 1) . for i:=2:length l collect
                                                !*k2q intern gensym());
      x := pair(indkrns s,reverse x);
      edsdebug("Transformation to general position",x,'xform);
      return xformeds0(s,x,new);
      end
   else if !*ranpos then
      begin scalar x,y,k,new;
      new := for i:=1:length eds_ind s collect
                mkform!*(intern gensym(),1);
      x := reversip foreach k in new collect !*k2pf k;
      k := updkordl lpows x;
      for i:=1:length eds_ind s do
         begin scalar f;
                   while null(f := xreduce(f,y)) do
               f := zippf(x,ranlistsq(length eds_ind s,10,5));
            y := f . y;
         end;
      setkorder k;
      x := pair(indkrns s,foreach f in y collect xreorder f);
      edsdebug("Transformation to random position",x,'xform);
      return xformeds0(s,x,new);
      end
   else s;


symbolic procedure ranlistsq(n,p,m);
   % n,p,m:int -> ranlist:list of sq
   % Produces a list of n random numbers between -m and m, with
   % at most p non-zero elements.
   begin scalar u,v;
   p := min2(n,p);
   u := for i:=1:p collect simpatom(random(2*m+1) - m);
   while length v < p do
      (if not(x memq v) then v := x . v) where x = 1 + random n;
   u := pair(v,u);
   return for i:=1:n collect
                 if v := atsoc(i,u) then cdr v else nil ./ 1;
   end;


symbolic procedure countchars x;
   % x:list of list of pf -> list of int
   % all pf are 1-forms
   begin scalar p,ri,si;
   foreach r in x do
      begin
      p := weak_xautoreduce append(r,p);
      ri := length p . ri;
      end;
   while cdr ri do
      <>;
   return car ri . si;
   end;


symbolic procedure involutionchk(s0,s1);
   % s0,s1:eds -> involutionchk:bool
   % s1 is prolongation of s0
   cartantest(characters(s0,eds_sys s1),
                     length edscob s1 - length edscob s0);


symbolic procedure cartantest(c,d);
   % c:list of int, d:int
   % c is list of characters, d is dimension of solution variety
   begin integer m;
   c := reverse c;
   foreach k on c do
      m := length k*car k + m;
   if d > m then errdhh {"Inconsistency in Cartan's test:",reverse c,d}
   else return d = m;
   end;


put('involutive,'psopfn,'involutiveeval);

symbolic procedure involutiveeval s;
   % s:{eds} -> involutiveeval:0 or 1
   if edsp(s := reval car s) then
      if knowntrueeds(s,'involutive) or
               not knownfalseeds(s,'involutive) and
               edscall involutive s then 1 else 0
   else typerr(s,'eds);


symbolic procedure involutive s;
   % s:eds -> involutive:bool
   knowntrueeds(s,'involutive) or
      not knownfalseeds(s,'involutive) and
      begin scalar s0,s1,flg;
      s0 := closure s;
      if semilinearp s0 then
         flg := cartantest(characters(s0,nil),
                           dimgrassmannvariety(s0,nil))
                 and null grassmannvarietytorsion s0
      else
      << s1 := prolong s0;
         while s1 and (caar s1='prolonged) and involutionchk(s0,cdar s1)
            do s1 := cdr s1;
               flg := null s1 >>;
      if flg
      then <>;
      %%% We mustn't flag involutive FALSE since it might be an accident
      %%% of the integral flag and not a property of the system we want
      %%% to immortalise.
      % else <>;
   end;


put('involution,'rtypefn,'quoteeds);
put('involution,'edsfn,'involutioneds);

symbolic procedure involutioneds s;
   % s:eds -> involutioneds:xeds
   if not edsp s then typerr(s,'eds)
   else mkxeds makelist
      foreach x in edscall involution s collect
          if null car x then {'involution,cdr x}
          else cdr x;


symbolic procedure involution s;
   % s:eds -> involution:list of tag.eds
   % where tag = t if eds is involutive
   %             nil if prolongation failed
   % NEEDS WORK!!!
   begin scalar r,s0;
   s0 := closure s;
   if semilinearp s0 and
      cartantest(characters(s0,nil),dimgrassmannvariety(s0,nil)) and
      null grassmannvarietytorsion s0
   then return {t.s};
   foreach s1 in edscall prolong s0 do
      if car s1 = 'inconsistent then nil
      else if car s1 = 'failed then r := union({nil . cdr s1},r)
      else if car s1 = 'prolonged and involutionchk(s0,cdr s1) then
              r := union({t.s},r)
      else r := union(edscall involution cdr s1,r);
   return r;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/disjoin.red0000644000175000017500000001052211526203062023412 0ustar  giovannigiovannimodule disjoin;

% Convert a variety to a disjoint union of sub-coframings

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
        !*solveinconsistent depl!* cfrmcrd!* cfrmrsx!* xvars!*
        !*edssloppy !*edsdisjoint);


Comment.  The edsdisjoin routines decompose a solution returned by
eds*solve into a disjoint union of solutions (rmaps).  The operations
intersection and difference are somewhat slow, so the whole process is
only performed automatically if the switch edsdisjoint is on.

endcomment;


symbolic operator disjoin;
symbolic procedure disjoin u;
   (makelist foreach rm in
      edsdisjoin(foreach s in getrlist u collect !*a2rmap s) collect
         !*rmap2a rm) where !*edsdisjoint = t;


symbolic procedure edsdisjoin u;
   % u:list of rmap -> edsdisjoin:list of rmap
   if !*edsdisjoint then reverse edsdisjoin1(u,{}) else u;


symbolic procedure edsdisjoin1(u,v);
   % u,v:list of rmap -> edsdisjoin1:list of rmap
   % rmaps in v are disjoint already.
   if null u then v
   else edsdisjoin1(cdr u,edsdisjoin2(car u,v));


symbolic procedure edsdisjoin2(x,v);
   % x:rmap, v:list of rmap -> edsdisjoin2:list of rmap
   % rmaps in v are disjoint already.
   if null v then {x}
   else
      begin scalar y,z;
      y := car v;
      return
         if z := rmapintersection(x,y) then
            append(rmapdifference(y,x),
            append(z,edsdisjoin1(rmapdifference(x,y),cdr v)))
         else
            y . edsdisjoin2(x,cdr v);
   end;


symbolic procedure rmapintersection(x,y);
   % x,y:rmap -> rmapintersection:list of rmap
   begin scalar lhx,xl,z,rsx,rsy,mx,my;
   % First a simple check which may save us going into solve
   rsy := pullbackrsx(cadr y,car x);
   if 0 member rsy then return nil;
   rsx := pullbackrsx(cadr x,car y);
   if 0 member rsx then return nil;
   % Now just pile everything together and resolve
   return rmapeval {append(car x,car y),append(rsx,rsy)};
   end;


symbolic procedure rmapdifference(x,z);
   % x,z:rmap -> rmapdifference:list of rmap
   % NO LONGER assumes z is a sub-coframing of x
   begin scalar m;
   m := foreach s in car z join
           if s := numr subsq(subtrsq(simp!* car s,simp!* cdr s),car x)
             then rmapeval {car x,addrsx(s,cadr x)};
   m := append(m,
        foreach s in cadr z join
           rmapeval {(0 . s) . car x,cadr x});
   return edsdisjoin purge m;
   end;


symbolic procedure rmapeval x;
   % x:rmap -> rmapeval:list of rmap
   % Resolve a badly formed rmap into a disjoint list of rmaps.
   % The map part of x may include equations expr=expr.
   begin scalar xl,vl;
   % First resolve map part, solving for lhs variables where possible
   vl := purge foreach s in car x collect car s;
   vl := {intersection(cfrmcrd!*,vl),setdiff(cfrmcrd!*,vl)};
   xl := foreach s in car x collect
           subtrsq(simp!* car s,simp!* cdr s);
   return foreach s in edssolvegraded(xl,vl,cadr x) collect
      if car s then cdr s
      else
      << lprim "Could not resolve decomposition entirely";
         {foreach q in cdr s collect 0 . mk!*sq q,cadr x} >>;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/pullback.red0000644000175000017500000002430011526203062023547 0ustar  giovannigiovannimodule pullback;

% Pullback transformations

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Data structure:

        map     ::= list of kernel . prefix

endcomment;

fluid '(xvars!* kord!* subfg!*);
global '(!*sqvar!*);

fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!*);


% Type coersions


symbolic procedure !*a2map u;
   % u:list of equation -> !*a2map:map
   % should remove x=x entries
   unrollmap for each j in getrlist u collect
      if eqexpr j then !*a2k lhs j . rhs j
      else rerror(eds,000,"Incorrectly formed pullback map");


symbolic procedure !*map2a u;
   % u:map -> !*map2a:prefix
   makelist foreach p in u collect {'equal,car p,cdr p};


% Pullback


put('pullback,'rtypefn,'getrtypecar);
put('pullback,'cfrmfn,'pullbackcfrm);
put('pullback,'edsfn,'pullbackeds);
put('pullback,'listfn,'pullbacklist);
put('pullback,'simpfn,'simppullback);


symbolic procedure pullbackcfrm(m,x);
   % m:cfrm, x:list of equation|inequality -> pullbackcfrm:cfrm
   % pullback m using map x
   begin
   x := !*a2rmap x;
   m := car pullbackcfrm1(m,car x);
   return if cadr x then cfrmprotect{'restrictcfrm1,m,{{},cadr x}}
           else m
   end;


symbolic procedure pullbackeds(s,x);
   % s:eds, x:list of equation|inequality -> pullback:eds
   % pulls back s using rmap x
   pullback0(s,!*a2rmap x);


symbolic procedure pullbacklist(u,v);
   % u:{prefix list of prefix ,prefix list of equation|inequality}, v:bool
   % -> pullbacklist:prefix list of prefix
   begin scalar x;
   x := car !*a2rmap reval cadr u; % throw away rsx
   u := reval car u;
   return
      makelist foreach f in cdr u join
               if (f := !*pf2a1(pullbackpf(xpartitop f,x),v)) neq 0 then {f};
   end;


symbolic procedure simppullback u;
   % u:{prefix,prefix list of equation} -> simppullback:sq
   (if degreepf f < 0 then rerror(eds,000,"Cannot pull back vectors")
   else !*pf2sq repartit pullbackpf(f,x))
      where f = xpartitop car u,
            x = car !*a2rmap reval cadr u;


symbolic procedure pullbackcfrm1(m,x);
   % m:cfrm, x:map -> pullbackcfrm1:{cfrm,{cob,map}}
   % Pull back coframing m. Also returns extended map showing which
   % cobasis elements have been eliminated in case of ambiguity (e.g.
   % anholonomic cobases).
   begin scalar n,cfrmcrd!*,cfrmrsx!*;
   if null x then return m;
   m := copycfrm m;
   x := unrollmap x;
   % Get source coframing (or subcoframing thereof)
   n := !*map2srccfrm x;
   %%if xnp(foreach p in x collect car p,cfrm_crd n) then
   %%   rerror(eds,000,"Recursive map in pullback");
   % New coordinates (ordering here critical)
   cfrm_crd m := rightunion(cfrm_crd m,cfrm_crd n);
   cfrm_crd m := setdiff(cfrm_crd m,foreach p in x collect car p);
   % Pull back rsx and check (ordering here critical)
   cfrm_rsx m := rightunion(cfrm_rsx m,cfrm_rsx n);
   cfrm_rsx m := pullbackrsx(cfrm_rsx m,x);
   if 0 member cfrm_rsx m then
      rerror(eds,000,
             "Map image not within target coframing in pullback");
   % Get target cobasis, and differentiate appropriate part of map
   % Need to use new coframing's coordinates
   cfrmcrd!* := cfrm_crd m;
   cfrmrsx!* := (foreach p in cfrm_rsx m collect
                               xpartitop p) where xvars!* = cfrmcrd!*;
   x := !*map2cotangent x;
   if not subsetp(car x,cfrm_cob m) then
      rerror(eds,000,
             "Map image not within target coframing in pullback");
   % New cobasis (ordering here critical)
   cfrm_cob m := rightunion(cfrm_cob m,cfrm_cob n);
   cfrm_cob m := setdiff(cfrm_cob m,car x);
   % Pullback derivatives (ordering here critical)
   cfrm_drv m := rightunion(cfrm_drv m,cfrm_drv n);
   cfrm_drv m := pullbackdrv(cfrm_drv m,cadr x);
   return {purgecfrm m,x};
   end;


symbolic procedure unrollmap x;
   % x:map -> unrollmap:map
   % Straighten out recursive maps. Designed to work only for weakly
   % reduced maps (ie row-echelon form).
   begin scalar r,z,cfrmcrd!*; integer c;
   cfrmcrd!* := foreach p in x collect car p;
   %%%edsdebug("Unroll input",x,'map);
   while x and (c := c+1) < 20 do
      begin
      foreach p in x do
      << r := simp!* cdr p;
               if cfrmconstant numr r and cfrmconstant denr r then
            z := p . z >>;
      x := pullbackmap(setdiff(x,z),append(x,z));
      %%%edsdebug("Recursive part",x,'map);
      end;
   if x then rerror(eds,000,"Recursive map");
   return z;
   end;


symbolic procedure !*map2srccfrm x;
   % x:map -> !*map2srccfrm:cfrm
   % Determine a possible source coframing for map x by
   % inspecting the rhs of each rule.
   !*sys2cfrm foreach p in x collect
          (1 .* simp!* cdr p .+ nil);


symbolic procedure !*map2cotangent x;
   % x:map -> !*map2cotangent:{cob,map}
   % Differentiate map x and determine which cobasis elements are
   % eliminated (ambiguous for anholonomic frames). Also returns
   % differentiated map.
   begin scalar f,old,xl;
   foreach p in x do
   << f := xpows exdfk car p;
      if length f > 1 or car f neq {'d,car p} then xl := p . xl
      else old := car f . old >>;
   if xl then x := exdfmap(xl,x);
   old := append(old,for each p in x
                        join if xdegree car p = 1 then {car p});
   edsdebug("Cobasis elements eliminated",old,'cob);
   return {old,x};
   end;


symbolic procedure exdfmap(xl,x);
   % xl,x:map -> exdfmap:map
   % produce substitution for differentials in xl from those for scalars
   % x is the whole map, xl is usually only a subset
   begin scalar f,old,y,ok;
   ok := updkordl {};
   foreach p in xl do
   << f := exdfk car p;
      old := union(xpows f,old);
      if red f or lpow f neq {'d,car p} then
         f := pullbackpf(f,x);
      y := addpf(f,negpf pullbackpf(xpartitop{'d,cdr p},x)) . y >>;
   edsdebug("Possibilities for elimination",old,'cob);
   y := solvepfsys1(y,old);
   if cadr y then
      rerror(eds,000,"Cannot determine suitable coframe for pullback");
   setkorder ok;
   return
      append(x,
                   foreach f in car y collect
                 lpow f . mk!*sq !*pf2sq negpf xreorder!* red f);
   end;


symbolic procedure pullbackdrv(d,x);
   % d:drv, x:map -> pullbackdrv:drv
   (foreach r in d collect
      {car r,cadr r,mk!*sq subsq(simp!* caddr r,x)})
          ; %%% where subfg!*=nil; %%% Why?


symbolic procedure pullbackmap(p,x);
   % p:map, x:map -> pullbackmap:map
   % substitute map x into map p
   foreach s in p collect car s . mk!*sq subsq(simp!* cdr s,x);


symbolic procedure pullback0(s,x);
   % s:eds, x:rmap -> pullback0:eds
   % restricts and pulls back s using rmap x
   if emptyedsp(s := pullback(s,car x)) then s
   else if cadr x then edscall restrict(s,{{},cadr x})
   else s;


symbolic procedure pullback(s,x);
   % s:eds, x:map -> pullback:eds
   % Pulls back s using map x.
   begin scalar prl,cob,m;
   if null x then return s;
   % Get some information about s
   prl := prlkrns s; cob := edscob s;
   % Pullback coframing, and get cotangent space info
   m := pullbackcfrm1(eds_cfrm s,x);
   x := cadr m; m:= car m;
   % Setting coframe here reduces need to reorder later. If some
   % cobasis elements are eliminated, the forms in sys and ind may be
   % out of order, but this doesn't seem to matter since these will be
   % replaced anyway.
   setcfrm m;
   % Fix flags first (need to test using old sys/ind)
   s := purgeeds!* s; % copies s
   if not subsetp(cfrm_cob m,cob) then
      rempropeds(s,'jet0);
   if subsetp(car x,prl) and % try to avoid re-solving
      null xnp(prl,foreach f in pfaffpart eds_sys s join xpows f) and
      null xnp(prl,foreach f in eds_ind s join xpows f) then
      remtrueeds(s,'reduced)
   else
      remtrueeds(s,'solved);
   foreach f in {'solved,'pfaffian,'quasilinear,'closed} do
      remfalseeds(s,f);
   rempropeds(s,'involutive);
   % Form new eds
   eds_sys s := foreach f in eds_sys s join
      if f := pullbackpf(f,cadr x) then {f};
   eds_ind s := foreach f in eds_ind s join
      if f := pullbackpf(f,cadr x) then {f}
      else <>;
   cfrm_cob m := append(setdiff(cfrm_cob m,i),i) where i=indkrns s;
   eds_cfrm s := m;
   if not subsetp(cfrm_cob m,cob) then % probably need to reorder
   << setcfrm m;
      eds_sys s := xreordersys eds_sys s;
      eds_ind s := xreordersys eds_ind s; >>;
   remkrns s;
   return normaleds s;
   end;


symbolic procedure pullbackpf(f,x);
   % f:pf, x:map -> pullbackpf:pf
   % pulls back f using map x
   % should watch out for partdf's
   % This version assumes x introduces no new xvars in coefficients.
   % Done using two routines to reduce subs2 checking.
   subs2pf pullbackpf1(f,x);


symbolic procedure pullbackpf1(f,x);
   % f:pf, x:map -> pullbackpf1:pf
   if f then
      addpf(multpfsq(pullbackk(lpow f,x),subsq(lc f,x)),
            pullbackpf1(red f,x));


symbolic procedure pullbackk(k,x);
   % k:lpow pf, x:map -> pullbackk:pf
   % need xreorder here because subf returns unordered wedge kernels
   xreorder xpartitsq subf(!*k2f k,x);


symbolic procedure pullbacksq(q,x);
   % q:sq, x:map -> pullbacksq:pf
   xpartitsq subsq(q,x);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/transfrm.red0000644000175000017500000002777311526203062023627 0ustar  giovannigiovannimodule transfrm;

% Cobasis transformations

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Data structure:

        xform   ::= list of 1-form kernel . 1-form pf

endcomment;


fluid '(xvars!* kord!* subfg!*);
global '(!*sqvar!*);

fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!* !*edssloppy);


% Type coersions


symbolic procedure !*a2xform u;
   % u:list of equation -> !*a2xform:xform
   % Turn off subfg!* to stop let rules being applied.
   % should remove x=x entries
   for each j in getrlist u collect
      if eqexpr j then !*a2k lhs j . xpartitop rhs j where subfg!* = nil
      else rerror(eds,000,"Incorrectly formed transform");


symbolic procedure !*xform2map x;
   % x:xform -> !*xform2map:map
   foreach p in x collect
      car p . mk!*sq !*pf2sq cdr p;


symbolic procedure !*map2xform u;
   % u:map -> !*map2xform:xform
   % Turn off subfg!* to stop let rules being applied.
   (for each x in u collect
      car u . xpartitop cadr u) where subfg!* = nil;


symbolic procedure !*xform2drv x;
   % x:xform -> !*xform2drv:drv
   % Turn off subfg!* to stop let rules being applied.
   (foreach p in x collect
      {'replaceby,car p,!*pf2a cdr p}) where subfg!* = nil;


symbolic procedure !*xform2sys x;
   % x:xform -> !*xform2sys:sys
   foreach p in x collect addpf(!*k2pf car p,negpf cdr p);


% Transform


put('transform,'rtypefn,'getrtypecar);
put('transform,'cfrmfn,'transformcfrm);
put('transform,'edsfn,'transformeds);


symbolic procedure transformcfrm(m,x);
   % m:cfrm, x:list of equation -> transformcfrm:cfrm
   % Transform m using map x.
   checkcfrm xformcfrm(m,!*a2xform x);


symbolic procedure transformeds(s,x);
   % s:eds, x:list of equation -> transform:eds
   % pulls back s using map x
   xformeds(s,!*a2xform x);


symbolic procedure xformcfrm(m,x);
   % m:cfrm, x:xform -> xformcfrm:cfrm
   % Apply transform x to m, where x may be either old=f(new,old) or
   % new=f(old).
   xformcfrm1(m,car u,cadr u,caddr u)
      where u = getxform(x,cfrm_cob m);


symbolic procedure xformcfrm1(m,x,y,new);
   % m:cfrm, x,y:xform, new:cob -> xformcfrm1:cfrm
   % Apply transform x to m, where x is old=f(new,old), y is x inverse,
   % and new gives the new cobasis elements.
   begin scalar p,z;
   m := copycfrm m;
   z := pair(foreach p in x collect car p,new);
   cfrm_cob m :=            % replace old by new in-place
      foreach k in cfrm_cob m collect % sublis here destroys kernels
                                if p := atsoc(k,z) then cdr p else k;
   cfrm_crd m :=        % retain all old coordinates (may appear in eds)
       reverse union(foreach k in new join if exact k then {cadr k},
                          reverse cfrm_crd m);
   cfrm_drv m :=      % add new differentials and structure equations
      append(xformdrv(cfrm_drv m,x),
      append(!*xform2drv foreach p in x join if exact car p then {p},
             structeqns(y,x)));
   if !*edssloppy then m := updatersx m; % invxform may have added new
                                         % rsx
   m := purgecfrm m;
   return m;
   end;


symbolic procedure xformcfrm0(m,x,new);
   % m:cfrm, x:xform, new:cob -> xformcfrm0:cfrm
   % Cut down version of xformcfrm1 which doesn't update structure
   % equations. Useful when following operations are purely algebraic.
   begin scalar p,z;
   m := copycfrm m;
   z := pair(foreach p in x collect car p,new);
   cfrm_cob m :=            % replace old by new in-place
      foreach k in cfrm_cob m collect % sublis here destroys kernels
                                if p := atsoc(k,z) then cdr p else k;
   cfrm_crd m :=        % retain all old coordinates (may appear in eds)
       reverse union(foreach k in new join if exact k then {cadr k},
                          reverse cfrm_crd m);
   if !*edssloppy then m := updatersx m; % invxform may have added new
                                         % rsx
   m := purgecfrm m;
   return m;
   end;


symbolic procedure xformdrv(d,x);
   % d:drv, x:xform -> xformdrv:drv
   % Apply xform to drv. Must suppress active rules, for example if d a
   % => d b is active and x = {d b => d a}, then after applying x, it
   % will be undone immediately.
   pullbackdrv(d,!*xform2map x) where subfg!* = nil;


symbolic procedure updatersx m;
   % m:cfrm -> updatersx:cfrm
   % Reinstall restrictions in s from global variable, typically
   % after solvepfsys when !*edssloppy is t.
   begin
   m := copycfrm m;
   cfrm_rsx m := foreach f in purge cfrmrsx!* collect !*pf2a f;
   return m;
   end;


symbolic procedure xformeds(s,x);
   % s:eds, x:xform -> xformeds:eds
   % Apply transform x to m, where x may be either old=f(new,old) or
   % new=f(old).
   % possibly changes kernel order
   xformeds1(s,car u,cadr u,caddr u)
      where u = getxform(x,edscob s);



symbolic procedure xformeds1(s,x,y,new);
   % s:eds, x,y:xform, new:cob -> xformeds1:eds
   % Apply transform x to m, where x is old=f(new,old), y is x inverse,
   % and new gives the new cobasis elements.  Changes background
   % coframing.
   begin scalar k;
   s := copyeds s;
   % Transform coframing
   eds_cfrm s := xformcfrm1(eds_cfrm s,x,y,new);
   % Make sure old get eliminated (and add new to kord!* for safety)
   k := updkordl append(foreach p in x collect car p,new);
   x := !*xform2sys x;
   % Transform rest of eds
   eds_sys s := foreach f in eds_sys s collect xreduce(xreorder f,x);
   eds_ind s := foreach f in eds_ind s collect xreduce(xreorder f,x);
   remkrns s;
   s := purgeeds!* s;
   rempropeds(s,'jet0);
   foreach f in {'solved,'reduced} do rempropeds(s,f);
   setkorder k;
   s := normaleds s; % Refine this a bit?
   setcfrm eds_cfrm!* s;
   return s;
   end;


symbolic procedure xformeds0(s,x,new);
   % s:eds, x:xform, new:cob -> xformeds0:eds
   % Cut down version of xformeds1 which doesn't care about structure
   % equations (some are lost). Useful when following operations are
   % purely algebraic. Changes background coframing.
   begin scalar k;
   s := copyeds s;
   % Transform coframing (ignore structure equations)
   eds_cfrm s := xformcfrm0(eds_cfrm s,x,new);
   % Make sure old get eliminated (and add new to kord!* for safety)
   k := updkordl append(foreach p in x collect car p,new);
   x := !*xform2sys x;
   % Transform rest of eds
   eds_sys s := foreach f in eds_sys s collect xreduce(xreorder f,x);
   eds_ind s := foreach f in eds_ind s collect xreduce(xreorder f,x);
   remkrns s;
   s := purgeeds!* s;
   rempropeds(s,'jet0);
   foreach f in {'solved,'reduced} do rempropeds(s,f);
   setkorder k;
   s := normaleds s; % Refine this a bit?
   setcfrm eds_cfrm!* s;
   return s;
   end;


symbolic procedure getxform(x,cob);
   % x:xform, cob:cob -> getxform:{xform,xform,cob}
   % Analyse transform x, which may be either old=f(new,old) or
   % new=f(old). The sense is established by cob, which contains the old
   % cobasis. Return value is {x,y,new} where x is in the sense old =
   % f(new,old), and y is the inverse of x (ie new = f(old)).  The
   % inverse y is calculated only if x is old = f(new,old) and there
   % are anholonomic forms in new.
   begin scalar old,new,y;
   foreach p in x do
   << new := union(xpows cdr p,new);
      old := car p . old >>;
   if not xnp(old,cob) then  % x is new=f(old), must invert
   << y := x; x := invxform x;
      new := old; old := foreach p in x collect car p >>;
   new := sort(setdiff(new,cob),'termordp);
   edsdebug("New cobasis elements...",new,'cob);
   edsdebug("... replacing old cobasis elements",old,'cob);
   if length new neq length old or not subsetp(old,cob) then
      rerror(eds,000,"Bad cobasis transformation");
   if not allexact new and null y then
      y := invxform x; % for structure equations
   return {x,y,new};
   end;


% Structure equations


symbolic procedure xformdrveval u;
   % u:{rlist,rlist} or {rlist} -> xformdrveval:rlist
   begin scalar x,y,k;
   y := !*a2xform car u;
   x := if cdr u then !*a2xform cadr u else invxform y;
   k := updkordl foreach p in x collect car p;
   y := structeqns(y,x);
   setkorder k;
   return makelist y;
   end;

symbolic procedure xformdrveval u;
   % u:{rlist,rlist} or {rlist} -> xformdrveval:rlist
   begin scalar x,y,xvars!*;
   y := !*a2xform car u;
   x := if cdr u then !*a2xform cadr u else invxform y;
   y := structeqns(y,x);
   return makelist y;
   end;


symbolic procedure structeqns(y,x);
   % y,x:xform -> structeqns:list of rule
   % y is the inverse of x, and d lhs x are known.
   % Returns rules for d lhs y.
   begin scalar ok;
   ok := updkordl foreach p in x collect car p;
   x := !*xform2sys x;
   y := foreach p in y join
                 if not exact car p then
              {{'replaceby,
                {'d,car p},
                    !*pf2a xreduce(exdfpf cdr p,x)}};
   setkorder ok;
   return y;
   end;

symbolic procedure structeqns(y,x);
   % y,x:xform -> structeqns:list of rule
   % y is the inverse of x, and d lhs x are known.
   % Returns rules for d lhs y.
   begin scalar ok;
   ok := updkordl sort(foreach p in x collect car p,function ordop);
   x := !*xform2sys x;
   y := foreach p in y join
                 if not exact car p then
              {{'replaceby,
                {'d,car p},
                    !*pf2a xreduce(exdfpf cdr p,x)}};
   setkorder ok;
   return y;
   end;

% Inverting tranformations


put('invert,'rtypefn,'quotelist);
put('invert,'listfn,'inverteval);

symbolic procedure inverteval(u,v);
   % u:{prefix list of eqn} -> inverteval:{prefix list of eqn}
   % u is unevaluated.
   makelist foreach p in invxform !*a2xform(u := reval car u) collect
      {'equal,car p,!*pf2a1(cdr p,v)};


symbolic procedure invxform x;
   % x:xform -> invxform:xform
   % Returns inverse transformation. Selects kernels to eliminate based
   % on prevailing order
   begin scalar old,y,k, subfg!*;
   subfg!* := nil;
   foreach p in x do old := union(xpows cdr p,old);
   old := sort(old,'termordp);
   % ensure old eliminated, and add new to kord!* for safety
   k := updkordl append(old,foreach p in x collect car p);
   edsdebug("Inverting transform",nil,nil);
   y := solvepfsys1(!*xform2sys x,old);       % invert transformation
   if cadr y then
      rerror(eds,000,"Cobasis transform could not be inverted");
   setkorder k;
   return foreach f in car y collect
      lpow f . negpf xreorder red f;
   end;


symbolic procedure tmpind s;
   % s:eds -> tmpind:{eds,xform}
   % Returns s with eds_ind s all kernels, transforming to a new
   % cobasis if necessary.  Second return value is nil if no change
   % made, or the list of transformation relations.  Structure
   % equations are not transformed, so s should be closed first if
   % necessary.  NB.  Background coframing changed.
   begin scalar new,x;
   if singleterms eds_ind s then return {s,nil};
   new := foreach f in eds_ind s collect mkform!*(intern gensym(),1);
   x := invxform pair(new,eds_ind s);
   updkordl foreach p in x collect car p;
   return {xformeds0(s,x,new),x};
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edseval.red0000644000175000017500000004376111526203062023411 0ustar  giovannigiovannimodule edseval;

% Definition and manipulation of eds structure for exterior systems

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. A simple exterior differential system is stored in a list:

        eds     ::= {'!!eds!!,sys,ind,cfrm,props}
        sys     ::= list of pf
        ind     ::= list of pf
        cfrm    ::= cfrm
        props   ::= alist of id.atom|id.list of prefix

More generally, exterior differential systems are stored as algebraic
lists, with a single-element list represented by a simple eds.

              xeds   ::= eds | 'list . list of xeds

endcomment;


fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!* xvars!* kord!*);
global '(!*sqvar!*);


% Type definition


put('eds,'tag,'!!eds!!);
put('!!eds!!,'rtypefn,'quoteeds);

symbolic procedure quoteeds u; 'eds;


if not(get('list,'rtypefn) memq {'quotelist,'edsorlist}) then
   lprim {"Changing list rtypefn from",get('list,'rtypefn)};

put('list,'rtypefn,'edsorlist);

symbolic procedure edsorlist u;
   % u:list of prefix -> edsorlist:'eds|'list
   % Gives rtype eds to an rlist of eds.
   if u and getrtype car u = 'eds then 'eds
   else 'list;


% Evaluation interface


put('eds,'evfn,'edseval);

symbolic procedure edseval(u,v);
   % u:prefix, v:bool -> edseval:prefix
   % v is t for reval, nil for aeval. Here it is ignored (and abused as
   % a local variable!).  u is either an id with an avalue whose car has
   % rtype eds or a list with rtype eds. This routine differs from most
   % evfn's in that the argument list is evaluated prior to calling an
   % edsfn. This is because the predicted result type of eds might be
   % wrong (it might give an xeds). If this happens, reval is called
   % again.
   if atom u then
      edseval(if flagp(u,'share) then eval u
              else cadr get(u,'avalue),v)
   else if edsp u then resimpeds!* u
   else if xedsp u then
      mkxeds makelist foreach s in mkxeds0 u collect resimpeds!* s
   else if v := get(car u,'edsfn) then
      mkxeds makelist foreach f in edsexpand revlis cdr u collect
         if flagp(car u,'nospread) then edsprotect{v,f}
               else edsprotect(v . f)
   else rerror(eds,000,{"Illegal operation on EDS"});


symbolic procedure resimpeds!* s;
   % s:eds -> resimpeds!*:eds
   % Resimplify s iff sqvar is nil
   if v and car v where v = geteds(s,'sqvar) then s
   else resimpeds s;


symbolic procedure edsexpand u;
   % u:list of prefix -> edsexpand:list of list of prefix
   % Input is an argument list, result is a list of argument lists.
   % All xeds in the argument list are distributed in the result,
   % which contains only simple eds.
   if null u then {u}
   else if not xedsp car u then
      foreach w in edsexpand cdr u collect car u . w
   else foreach s in mkxeds0 car u join
      foreach w in edsexpand cdr u collect s . w;


symbolic procedure edsexpand u;
   % u:list of prefix -> edsexpand:list of list of prefix
   % Input is an argument list, result is a list of argument lists.
   % The first xeds in the argument list is distributed in the result,
   % which contains only simple eds.
   if null u or not xedsp car u then {u}
   else foreach s in mkxeds0 car u collect s . cdr u;


symbolic procedure edsprotect u;
   % u:prefix -> edsprotect:prefix
   % Protected evaluation environment for operations on exterior
   % systems. Like cfrmprotect, but removes base coordinates and order
   % cobasis.
   begin scalar m,ok,od;
         scalar xvars!*;
   % If one of the arguments is eds, take the first one
   foreach v in cdr u do if null m and edsp v then m := v;
   % Save environment and adjust for eds calculation.
   ok := kord!*; od := append(get('d,'kvalue),nil); % copy pairs
   if m then m := setcfrm eds_cfrm!* m;
   u := errorset!*(car u . foreach j in cdr u collect mkquote j,t);
   % Restore environment
   if m then setcfrm m;
   setkorder ok; if od then put('d,'kvalue,od) else remprop('d,'kvalue);
   if errorp u then error1()
   else return car u;
   end;


symbolic procedure eds_cfrm!* s;
   % s:eds -> eds_cfrm!*:cfrm
   % Coframing for s but with base coordinates removed from list.
   begin scalar m;
   m := copycfrm eds_cfrm s;
   cfrm_crd m := setdiff(cfrm_crd m,edsindcrd s);
   return m;
   end;


symbolic procedure edscob s;
   % s:eds -> edscob:cob
   % Cobasis ordering for s: dep > prl > ind.
   cfrm_cob eds_cfrm s;


symbolic procedure edscrd s;
   % s:eds -> edscrd:list of kernel
   cfrm_crd eds_cfrm s;


symbolic procedure edsindcrd s;
   % s:eds -> edsindcrd:list of kernel
   % Tries to determine independent coordinates in s. Can go wrong with
   % anholonomic systems.
   begin scalar i,j;
   i := indkrns s;
   j := foreach k in i join
                 if exact k then {cadr k};
   if length j = length i then return j;
   j := append(j,foreach c in setdiff(edscrd s,j) join
                              if lpow exdfk c memq i then {c});
   if length j = length i then return j;
   %edsdebug("Can't determine independent coordinates - guessing",nil,
   %         nil);
   return
      if length j > length i then
               reverse pnth(reverse j,1 + length j - length i)
      else j;
   end;


put('list,'edsfn,'listeds);
flag('(list),'nospread);

symbolic procedure listeds u;
   % u:list of eds -> listeds:rlist of eds
   makelist u;


% Constructors and tests


symbolic procedure mkeds u;
   % tag u as eds
   '!!eds!! . u;


symbolic procedure mkxeds u;
   % u:xeds -> mkxeds:xeds
   % take possibly nested xeds's and produce a flat list, or an eds
   if length(u := mkxeds0 u) = 1 then car u
   else makelist u;


symbolic procedure mkxeds0 u;
   % u:xeds|eds -> mkxeds0:list of eds
   % take possibly nested xeds's and produce a flat list
   if edsp u then {u}
   else if rlistp u then
      foreach v in cdr u join mkxeds0 v
   else typerr(u,'eds);


symbolic procedure emptyeds;
   % -> emptyeds:eds
   mkeds{{!*k2pf 1},{},emptycfrm(),{}};


symbolic procedure emptyedsp s;
   % s:eds -> emptyedsp:bool
   !*k2pf 1 member eds_sys s;


symbolic procedure edsp u;
   % u:any -> edsp:bool
   eqcar(u,'!!eds!!);


symbolic procedure xedsp u;
   % u:any -> xedsp:bool
   edsp u or
   rlistp u and cdr u and xedsp cadr u;


symbolic procedure purgexeds s;
   % s:xeds -> purgexeds:xeds
   % Remove all empty eds's from s (except perhaps one)
   begin
   s := foreach s0 in mkxeds0 s join
                if not emptyedsp s0 then {s0};
   return
      if null s then emptyeds()
      else if length s = 1 then car s
      else makelist s;
   end;


% Input interface


put('eds,'rtypefn,'quoteeds);
put('eds,'edsfn,'!*a2eds);
flag('(eds),'nospread);

symbolic procedure !*a2eds s;
   % s:eds -> !*a2eds:xeds
   % Argument syntax:
   %    eds(sys,ind[,cfrm][,props])
   begin scalar sys,ind,cfrm,props;
   if length s < 2 or length s > 4 then
      rerror(eds,000,{"Wrong number of arguments to EDS"});
   sys := !*a2sys car s;
   if rlistp cadr s then ind := !*a2sys cadr s
   else if getrtype cadr s then typerr(cadr s,"independence form")
   else if null(ind := xdecomposepf xpartitop cadr s) then
       typerr(cadr s,"independence form (not decomposable)");
   foreach l in cddr s do
      if cfrmp l then cfrm := l
      else if rlistp l and edspropsp cdr l then props := cdr l
      else rerror(eds,000,"Badly formed EDS");
   ind := foreach f in ind collect
      if degreepf f = 1 then f
      else typerr(f,"independence 1-form");
   if null cfrm then cfrm := !*sys2cfrm append(sys,ind);
   props := foreach x in props collect
                     if not idp cadr x then
                  rerror(eds,000,"Badly formed properties in EDS")
               else cadr x .
                   if rlistp caddr x then
                     revlis cdr indexexpandeval{caddr x}
                  else caddr x;
   s := mkeds{sys,ind,cfrm,props};
   return edscall checkeds s;
   end;


symbolic procedure edspropsp u;
   % u:any -> edspropsp:bool
   % Tests if u is candidate for property list (ie a list of eqn)
   null u or eqexpr car u and edspropsp cdr u;


% Output interface


put('!!eds!!,'prifn,'edsprint);
put('!!eds!!,'fancy!-reform,'!*eds2a);
put('eds,'texprifn,'texprieds);
%put('eds,'prepfn,'!*eds2a);


symbolic procedure edsprint s;
   % s:eds -> edsprint:bool
   % if already in external format, use inprint
   maprin !*eds2a s;


symbolic procedure !*eds2a s;
   % s:eds -> !*eds2a:prefix
   edscall !*eds2a1 s;


symbolic procedure !*eds2a1 s;
   % s:eds -> !*eds2a1:prefix
   if !*nat then
      "EDS" . {makelist for each f in eds_sys s
                           collect preppf repartit f,
               if eds_ind s then
                  mknwedge foreach f in eds_ind s
                              collect preppf repartit f
               else makelist nil}
   else
      "eds" . {makelist for each f in eds_sys s
                           collect preppf repartit f,
               if eds_ind s then
                  mknwedge foreach f in eds_ind s
                              collect preppf repartit f
               else makelist nil,
               !*cfrm2a eds_cfrm s,
               edsproperties s};


% The next bit is just temporary till TRI is fixed

%% symbolic procedure texprieds(u,v,w);
%%    % Have to hide the EDS from TRI's makeprefix
%%    if edsp u then
%%       texvarpri('texpriedsop . !*eds2a u,v,w)
%%    else
%%       texvarpri(makelist foreach s in cdr u collect
%%        'texpriedsop . !*eds2a s,v,w);


symbolic procedure texprieds(u,v,w);
   % Have to hide the EDS from TRI's makeprefix
   % but not from TRIX's makeprefix.
   if edsp u then
      texvarpri(
         if get('hodge,'texname) then !*eds2a u
         else 'texpriedsop . !*eds2a u,v,w)
   else
      texvarpri(makelist foreach s in getrlist u collect
         if get('hodge,'texname) then !*eds2a s
         else 'texpriedsop . !*eds2a s,v,w);



put('texpriedsop,'simpfn,'simptexpriedsop);

symbolic procedure simptexpriedsop u;
   % don't do anything to u, treat it as a kernel
   % this is all to get around makeprefix in TRI
   !*k2q u;


% Algebraic access to eds parts


put('system,'formfn,'formsystem);

symbolic procedure formsystem(u,v,mode);
   % distinguish between system(string) and system(eds).
   begin scalar x;
   x := formlis(cdr u,v,mode);
   return if mode = 'symbolic then
      'system . x
   else if x and stringp car x then
      'list . mkquote 'system . x
   else %if x and eqcar(car x,'quote) and getrtype eval car x = 'eds
        % then
    'list . mkquote 'systemeds . x;
   end;

put('systemeds,'rtypefn,'quotelist);
put('systemeds,'listfn,'syseval);

symbolic procedure syseval(s,v);
   % s:{xeds}, v:bool -> syseval:prefix sys
   if not xedsp(s := reval car s) then typerr(s,'eds)
   else if edsp s then
      !*sys2a1(eds_sys s,v)
   else makelist foreach x in cdr s collect
      !*sys2a1(eds_sys x,v);


put('independence,'rtypefn,'quotelist);
put('independence,'listfn,'indeval);

symbolic procedure indeval(s,v);
   % s:{xeds}, v:bool -> indeval:prefix ind
   if not xedsp(s := reval car s) then typerr(s,'eds)
   else if edsp s then
      makelist foreach f in eds_ind s collect !*pf2a1(f,v)
   else makelist foreach x in cdr s collect
      makelist foreach f in eds_ind x collect !*pf2a1(f,v);


put('properties,'rtypefn,'quotelist);
put('properties,'listfn,'propertieseval);

symbolic procedure propertieseval(s,v);
   % s:{xeds}, v:bool -> propertieseval:prefix list of list
   % ignore v argument
   if not xedsp(s := reval car s) then typerr(s,'eds)
   else if edsp s then edsproperties s
   else makelist foreach x in cdr s collect edsproperties x;


symbolic procedure edsproperties s;
   % s:eds -> edsproperties:prefix list of list
   makelist foreach p in eds_props s join
      if not flagp(car p,'hidden) then
         {{'equal,car p,if pairp cdr p then makelist cdr p else cdr p}};


put('eds,'lengthfn,'edslength);

symbolic procedure edslength s;
   % s:eds -> edslength:int
   if edsp s then 1
   else length cdr s;


symbolic procedure edspart(s,n);
   % s:eds, n:int -> edspart:prefix
   if n = 0 then 'eds
   else if n = 1 then !*sys2a eds_sys s
   else if n = 2 then !*sys2a eds_ind s
   else if n = 3 then eds_cfrm s
   else if n = 4 then edsproperties s
   else parterr(s,n);

put('!!eds!!,'partop,'edspart);


symbolic procedure edssetpart(s,l,r);
   % s:eds, l:list of int, r:prefix -> edssetpart:error
   rerror(eds,000,"Part setting disabled on EDS operator");

put('!!eds!!,'setpartop,'edssetpart);


symbolic procedure mapeds(fn,s);
   % Map function for eds
   begin
   s := copyeds s;
   eds_sys s := foreach f in eds_sys s collect
                                xpartitop apply1(fn,!*pf2a f);
   eds_ind s := foreach f in eds_ind s collect
                                xpartitop apply1(fn,!*pf2a f);
   return edscall checkeds s;
   end;

put('!!eds!!,'mapfn,'mapeds);


% Consistency check, resimplification and cleanup


symbolic procedure checkeds s;
   % s:eds -> checkeds:eds
   % Check EDS actually resides on coframing, and bring to normal form.
   begin scalar m,n;
   s := purgeeds s; % remove all hidden properties
   % Pick up coframing for sys/ind
   n := !*sys2cfrm append(eds_ind s,eds_sys s);
   % Check this against given coframing, if any.
   m := copycfrm eds_cfrm s;
   if not subsetp(cfrm_crd n,cfrm_crd m) then
      rerror(eds,000,
             "EDS not expressed in terms of coframing coordinates");
   if not subsetp(cfrm_cob n,cfrm_cob m) then
      rerror(eds,000,"EDS not expressed in terms of coframing cobasis");
   % Add any restrictions or structure equations picked up
   cfrm_rsx m := union(cfrm_rsx n,cfrm_rsx m);
   cfrm_drv m := union(cfrm_drv n,cfrm_drv m);
   eds_cfrm s := purgecfrm m;
   puteds(s,'sqvar,!*sqvar!*);
   return normaleds s;
   end;


symbolic procedure resimpeds s;
   % s:eds -> resimpeds:eds
   begin scalar r,ok;
   r := copyeds s;
   ok := cfrmswapkord(edscob r,{});
   eds_sys r := foreach f in eds_sys r collect xrepartit!* f;
   eds_ind r := foreach f in eds_ind r collect xrepartit!* f;
   eds_cfrm r := resimpcfrm eds_cfrm r;
   % next line no good, because sqvar is changed in closure etc
   %eds_props r := foreach p in eds_props r collect
   %                              car p . reval cdr p;
   if revlis geteds(r,'jet0) neq geteds(s,'jet0) then
      rempropeds(r,'jet0);
   setkorder ok;
   if r = s then
   << puteds(s,'sqvar,!*sqvar!*);
      return s >>;
   return edscall checkeds r;
   end;

flag('(sqvar),'hidden); % so it doesn't ever get printed


put('cleanup,'rtypefn,'getrtypecar);
put('cleanup,'edsfn,'cleaneds);

symbolic procedure cleaneds s;
   % s:eds -> cleaneds:eds
   begin scalar r,j;
   s := copyeds s;
   j := geteds(s,'jet0);
   eds_props s := {}; % remove ALL properties except jet0
   if j then puteds(s,'jet0,j);
   r := resimpeds s;
   return  % eq test here essential!
      if r eq s then edscall checkeds s
      else r;
   end;


symbolic procedure purgeeds s;
   % s:eds -> purgeeds:eds
   % Remove all hidden flags and properties
   begin
   s := copyeds s;
   eds_props s := foreach p in eds_props s join
      if not flagp(car p,'hidden) then {p};
   return s;
   end;


symbolic procedure purgeeds!* s;
   % s:eds -> purgeeds!*:eds
   % Remove most hidden flags and properties.
   begin
   s := copyeds s;
   eds_props s := foreach p in eds_props s join
      if car p memq {'solved,'reduced,'sqvar} or
         not flagp(car p,'hidden)
      then {p};
   return s;
   end;


% Operations on eds property list


symbolic procedure puteds(s,k,v);
   % s:eds, k:id, v:any -> puteds:any
   if not edsp s then
      errdhh {"Attempt to do puteds on",s,"which is not an EDS"}
   else if not idp k then
      errdhh {"Attempt to do puteds with",k,"which is not an id"}
   else
      begin scalar p;
      if p := assoc(k,eds_props s) then
         eds_props s := (k.v) . delete(p,eds_props s)
      else
         eds_props s := (k.v) . eds_props s;
      return v;
      end;


symbolic procedure rempropeds(s,k);
   % s:eds, k:id -> rempropeds:any
   if not edsp s or not idp k then nil
   else
      begin scalar p;
      if p := assoc(k,eds_props s) then
         eds_props s := delete(p,eds_props s);
      return if p then cdr p;
      end;


symbolic procedure geteds(s,k);
   % s:any, k:id -> geteds:any
   if not edsp s or not idp k then nil
   else (if p then cdr p) where p = assoc(k,eds_props s);


% Ternary logic flags


symbolic procedure flagtrueeds(s,k);
   % s:eds, k:id -> flagtrueeds:nil
   <>;


symbolic procedure knowntrueeds(s,k);
   % s:eds, k:id -> knowntrueeds:bool
   geteds(s,k) = 1;


symbolic procedure remtrueeds(s,k);
   % s:eds, k:id -> remtrueeds:nil
   <>;


symbolic procedure flagfalseeds(s,k);
   % s:eds, k:id -> flagfalseeds:nil
   <>;


symbolic procedure knownfalseeds(s,k);
   % s:eds, k:id -> knownfalseeds:bool
   geteds(s,k) = 0;


symbolic procedure remfalseeds(s,k);
   % s:eds, k:id -> remfalseeds:nil
   <>;


symbolic procedure knowneds(s,k);
   % s:eds, k:id -> knowneds:bool
   geteds(s,k);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/eds.tst0000644000175000017500000001466611526203062022603 0ustar  giovannigiovanni

		  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
		  %   Twisting type N solutions of GR   %
		  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The problem is to analyse an ansatz for a particular type of vacuum
% solution to Einstein's equations for general relativity. The analysis was
% described by Finley and Price (Proc Aspects of GR and Math Phys
% (Plebanski Festschrift), Mexico City June 1993). The equations resulting
% from the ansatz are:

% F    - F*gamma = 0
%  3 3
%
% F   *x  + 2*F *x    + x     *F - x *Delta*F = 0
%  2 2  1      2  1 2    1 2 2      1
%
% 2*F   *x    + 2*F *x      + 2*F   *x    + 2*F *x      + x       *F = 0
%    2 3  2 3      2  2 3 3      3 2  2 3      3  2 2 3    2 2 3 3
%
% Delta =0       Delta  neq 0
%      3	           1      
%
% gamma =0       gamma  neq 0
%      2	           1      

% where the unknowns are {F,x,gamma,Delta} and the indices refer to
% derivatives with respect to an anholonomic basis. The highest order is 4,
% but the 4th order jet bundle is too large for practical computation, so
% it is necessary to construct partial prolongations. There is a single
% known solution, due to Hauser, which is verified at the end.

on evallhseqp,edssloppy,edsverbose;
off arbvars,edsdebug;

pform {F,x,Delta,gamma,v,y,u}=0;
pform v(i)=0,omega(i)=1;
indexrange {i,j,k,l}={1,2,3};

% Construct J1({v,y,u},{x}) and transform coordinates. Use ordering
% statement to get v eliminated in favour of x where possible.
% NB Coordinate change cc1 is invertible only when x(-1) neq 0.

J1 := contact(1,{v,y,u},{x});
korder x(-1),x(-2),v(-3);
cc1 :=	{x(-v) = x(-1),
	 x(-y) = x(-2),
	 x(-u) = -x(-1)*v(-3)};
J1 := restrict(pullback(J1,cc1),{x(-1) neq 0});

% Set up anholonomic cobasis

bc1 :=	{omega(1) = d v - v(-3)*d u,
	 omega(2) = d y,
	 omega(3) = d u};
J1 := transform(J1,bc1);

% Prolong to J421: 4th order in x, 2nd in F and 1st in rest

J2 := prolong J1$
J20 := J2 cross {F}$
J31 := prolong J20$
J310 := J31 cross {Delta,gamma}$
J421 := prolong J310$
cc4 := first pullback_maps;

% Apply first order de and restrictions

de1 :=	{Delta(-3) = 0,
	 gamma(-2) = 0,
	 Delta(-1) neq 0,
	 gamma(-1) neq 0};

J421 := pullback(J421,de1)$

% Main de in original coordinates 

de2 :=	{F(-3,-3) - gamma*F,
	 x(-1)*F(-2,-2) + 2*x(-1,-2)*F(-2)
		 + (x(-1,-2,-2) - x(-1)*Delta)*F,
	 x(-2,-3)*(F(-2,-3)+F(-3,-2)) + x(-2,-2,-3)*F(-3)
		 + x(-2,-3,-3)*F(-2) + (1/2)*x(-2,-2,-3,-3)*F};

% This is not expressed in terms of current coordinates.
% Missing coordinates are seen from 1-form variables in following

d de2 xmod cobasis J421;

% The necessary equation is contained in the last prolongation

pullback(d de2,cc4) xmod cobasis J421;

% Apply main de

pb1 := first solve(pullback(de2,cc4),{F(-3,-3),F(-2,-2),F(-2,-3)});
Y421 := pullback(J421,pb1)$

% Check involution

on ranpos;
characters Y421;
dim_grassmann_variety Y421;

% 15+2*7 = 29 > 28: Y421 not involutive, so prolong

Y532 := prolong Y421$

characters Y532;
dim_grassmann_variety Y532;

% 22+2*6 = 34: just need to check for integrability conditions

torsion Y532;

% Y532 involutive. Dimensions?

dim Y532;
length one_forms Y532;

% The following puts in part of Hauser's solution and ends up with an ODE
% system (all characters 0), so no more solutions, as described by Finley
% at MG6.

hauser := {x=-v+(1/2)*(y+u)**2,delta=3/(8x),gamma=3/(8v)};
H532 := pullback(Y532,hauser)$
lift ws;
characters ws;

clear v(i),omega(i);
clear F,x,Delta,gamma,v,y,u,omega;
off ranpos;



	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	%   Isometric embeddings of Ricci-flat R(4) in ISO(10)   %
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Determine the Cartan characters of a Ricci-flat embedding of R(4) into
% the orthonormal frame bundle ISO(10) over flat R(6).  Reference:
% Estabrook & Wahlquist, Class Quant Grav 10(1993)1851

% Indices

indexrange {p,q,r,s}={1,2,3,4,5,6,7,8,9,10},
      	   {i,j,k,l}={1,2,3,4},{a,b,c,d}={5,6,7,8,9,10};

% Metric for R10

pform g(p,q)=0;
g(p,q) := 0$ g(-p,-q) := 0$ g(-p,-p) := g(p,p) := 1$

% Hodge map for R4

pform epsilon(i,j,k,l)=0;
index_symmetries epsilon(i,j,k,l):antisymmetric;
epsilon(1,2,3,4) := 1;

% Coframe for ISO(10)
% NB index_symmetries must come after o(p,-q) := ... (EXCALC bug)

pform e(r)=1,o(r,s)=1;
korder index_expand {e(r)};
e(-p) := g(-p,-q)*e(q)$
o(p,-q) := o(p,r)*g(-r,-q)$
index_symmetries o(p,q):antisymmetric;

% Structure equations

flat_no_torsion := {d e(p) => -o(p,-q)^e(q),
      	       	    d o(p,q) => -o(p,-r)^o(r,q)};

% Coframing structure

ISO := coframing({e(p),o(p,q)},flat_no_torsion)$
dim ISO;

% 4d curvature 2-forms

pform F(i,j)=2;
index_symmetries F(i,j):antisymmetric;
F(-i,-j) := -g(-i,-k)*o(k,-a)^o(a,-j);

% EDS for vacuum GR (Ricci-flat) in 4d

GR0 := eds({e(a),epsilon(i,j,k,l)*F(-j,-k)^e(-l)},
	   {e(i)},
      	   ISO)$

% Find an integral element, and linearise

Z := integral_element GR0$
GRZ := linearise(GR0,Z)$

% This actually tells us the characters already:
%  {45-39,39-29,29-21,21} = {6,10,8,21}

% Get the characters and dimension at Z

characters GRZ;
dim_grassmann_variety GRZ;

% 6+2*10+3*8+4*21 = 134, so involutive

clear e(r),o(r,s),g(p,q),epsilon(i,j,k,l),F(i,j);
clear e,o,g,epsilon,F,Z;
indexrange 0;

			%%%%%%%%%%%%%%%%%%%%%%%%%%
			%   Janet's PDE system   %
			%%%%%%%%%%%%%%%%%%%%%%%%%%

% This is something of a standard test problem in analysing integrability
% conditions. Although it looks very innocent, it must be prolonged five
% times from the second jet bundle before reaching involution. The initial 
% equations are just
%
%     u   =w,    u   =u   *y + v
%      y y        z z  x x 

load sets;
off varopt;
pform {x,y,z,u,v,w}=0$

janet := contact(2,{x,y,z},{u,v,w})$
janet := pullback(janet,{u(-y,-y)=w,u(-z,-z)=y*u(-x,-x)+v})$

% Prolong to involution

involutive janet;
involution janet;
involutive ws;

% Solve the homogeneous system, for which the
% involutive prolongation is completely integrable

fdomain u=u(x,y,z),v=v(x,y,z),w=w(x,y,z);

janet := {@(u,y,y)=0,@(u,z,z)=y*@(u,x,x)};
janet := involution pde2eds janet$

% Check if completely integrable
if frobenius janet then write "yes" else write "no";
length one_forms janet;

% So there are 12 constants in the solution: there should be 12 invariants

length(C := invariants janet);
solve(for i:=1:length C collect
         part(C,i) = mkid(k,i),coordinates janet \ {x,y,z})$
S := select(lhs ~q = u,first ws);

% Check solution
mkdepend dependencies;
sub(S,{@(u,y,y),@(u,z,z)-y*@(u,x,x)});

clear u(i,j),v(i,j),w(i,j),u(i),v(i),w(i);
clear x,y,z,u,v,w,C,S;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/restrict.red0000644000175000017500000001561211526203062023617 0ustar  giovannigiovannimodule restrict;

% Restrict to a subset of a coframing

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Data structures:

        rsx     ::= list of prefix (usually !*sq)
        rmap    ::= {map,rsx}

Restrictions are store in rmap's, where the second part gives the
restrictions to the coframing.

endcomment;

fluid '(xvars!* kord!* subfg!*);
global '(!*sqvar!*);

fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!*);


% Type coersions


symbolic procedure !*a2rmap u;
   % u:list of equation/inequality -> !*a2rmap:rmap
   % should remove x=x entries
   begin scalar map,rsx;
   for each j in getrlist u do
      if eqexpr j then
      << map := (!*a2k lhs j . rhs j) . map;
         rsx := addrsx(denr simp!* cdar map,rsx) >>
      else if eqcar(j := reval j,'neq) then
         rsx := addrsx(numr subtrsq(simp!* cadr j,simp!* caddr j),rsx)
      else typerr(j,"either equality or inequality");
   map := unrollmap map;
   rsx := pullbackrsx(rsx,map);
   return {map,rsx};
   end;


symbolic procedure !*rmap2a u;
   % u:rmap -> !*rmap2a:prefix
   makelist append(foreach p in car u collect {'equal,car p,cdr p},
                                foreach p in cadr u collect {'neq,p,0});


symbolic procedure !*map2rmap x;
   % x:map -> !*map2rmap:rmap
   % Pick up denominators in x
   begin scalar rsx;
   for each s in x do
      rsx := addrsx(reorder denr simp!* cdr s,rsx);
   return {x,reversip rsx};
   end;


% Restrict


if not operatorp 'neq then
   mkop 'neq; % make it an algebraic operator so it can be reval'd


put('restrict,'rtypefn,'getrtypecar);
put('restrict,'cfrmfn,'restrictcfrm);
put('restrict,'edsfn,'restricteds);
put('restrict,'listfn,'restrictlist);
put('restrict,'simpfn,'simprestrict);


symbolic procedure restrictcfrm(m,x);
   % m:cfrm, x:list of equation/inequality -> restrictcfrm:cfrm
   % restricts m using rmap x
   restrictcfrm1(m,!*a2rmap x);


symbolic procedure restricteds(s,x);
   % s:eds, x:list of equation/inequality -> restrict:eds
   % restricts s using rmap x
   restrict(s,!*a2rmap x);


symbolic procedure restrictlist(u,v);
   % u:{prefix list of prefix,prefix list of equation/inequality}, v:bool
   % -> restrictlist:prefix list of prefix
   begin scalar x;
   x := car !*a2rmap reval cadr u;
   u := reval car u;
   return
      makelist foreach f in cdr u join
               if (f := !*pf2a1(restrictpf(xpartitop f,x),v)) neq 0 then {f};
   end;


symbolic procedure simprestrict u;
   % u:{prefix,prefix list of equation/inequality} -> simprestrict:sq
   % just ignores inequalities
   !*pf2sq repartit restrictpf(f,x)
      where f = xpartitop car u,
            x = car !*a2rmap reval cadr u;


symbolic procedure restrictcfrm1(m,x);
   % m:cfrm, x:rmap -> restrictcfrm:cfrm
   begin scalar kl,rl;
   if null car x and null cadr x then return m;
   m := copycfrm m;
   kl := union(!*map2cob car x,!*rsx2cob cadr x);
   % Get rsx restrictions from denominators of map part
   rl := purge foreach p in car x join
                  if not cfrmconstant(p := denr simp!* cdr p) then
                {mk!*sq !*f2q p};
   % Put all rsx together and restrict
   rl := append(cfrm_rsx m,append(cadr x,rl));
   cfrm_rsx m := pullbackrsx(rl,car x);
   if not subsetp(kl,cfrm_cob m) or 0 member cfrm_rsx m then
      rerror(eds,000,
             "Map image not within target coframing in restrict");
   % Restrict derivatives
   cfrm_drv m := restrictdrv(cfrm_drv m,car x);
   return purgecfrm m;
   end;


symbolic procedure !*map2cob x;
   % x:map -> !*map2cob:cob
   % Collect all 1-form variables in map x.
   begin scalar f,kl;
   foreach p in x do
   << f := simp!* cdr p;
      f := foreach k in union(kernels denr f,kernels numr f) join
              if exformp k then xpows exdfk k;
      f := append(xpows exdfk car p,f);
      kl := union(f,kl) >>;
   return kl;
   end;


symbolic procedure !*rsx2cob x;
   % x:rsx -> !*rsx2cob:cob
   % Collect all 1-form variables in restrictions x.
   begin scalar f,kl;
   foreach p in x do
   << f := simp!* p;
      f := foreach k in union(kernels denr f,kernels numr f) join
              if exformp k then xpows exdfk k;
      kl := union(f,kl) >>;
   return kl;
   end;


symbolic procedure restrictdrv(d,x);
   % d:drv, x:map -> restrictdrv:drv
   (foreach r in d collect
      {car r,cadr r,mk!*sq restrictsq(simp!* caddr r,x)})
          ; %%% where subfg!*=nil; %%% Why?


symbolic procedure restrictsq(q,x);
   % q:sq, x:map -> restrictsq:sq
    !*pf2sq restrictpf(xpartitsq q,x);


symbolic procedure restrict(s,x);
   % s:eds, x:rmap -> restrict:eds
   % restricts s using rmap x
   begin
   if null car x and null cadr x then return s;
   % Do coframing first (spot errors faster)
   s := copyeds s;
   eds_cfrm s := restrictcfrm1(eds_cfrm s,x);
   % Fix flags
   s := purgeeds!* s;
   foreach f in {'solved,'pfaffian,'quasilinear,'closed} do
      remfalseeds(s,f);
   rempropeds(s,'involutive);
   remkrns s;
   % Form new eds
   eds_sys s := foreach f in eds_sys s join
      if f := restrictpf(f,car x) then {f};
   eds_ind s := foreach f in eds_ind s join
      if f := restrictpf(f,car x) then {f}
      else <>;
   return normaleds s;
   end;


symbolic procedure restrictpf(f,x);
   % f:pf, x:map -> restrictpf:pf
   % restricts f using map x
   % should watch out for partdf's
   if null f then nil
   else if null x then f        % doesn't check let rules
   else (if numr c then lpow f .* c .+ restrictpf(red f,x)
         else restrictpf(red f,x)) where c = subsq(lc f,x);


symbolic procedure pullbackrsx(rsx,x);
   % rsx:rsx, x:map -> pullbackrsx:rsx
   foreach p in rsx collect mk!*sq subf(numr simp!* p,x);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edsaux.red0000644000175000017500000002667711526203062023266 0ustar  giovannigiovannimodule edsaux;

% Miscellaneous support functions

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*edsverbose !*edsdebug);


% Operations on eds

% Storing these kernel lists seems to have <1% effect on speed.

symbolic procedure indkrns s;
   % s:eds -> indkrns:list of lpow pf
   % independent kernels - leading basis forms in eds_ind s
%   geteds(s,'indkrns) or
%   puteds(s,'indkrns,
      foreach f in eds_ind s join
            if tc(f := trterm f) = (1 ./ 1) then {tpow f}; %);


symbolic procedure depkrns s;
   % s:eds -> depkrns:list of lpow pf
   % dependent kernels - a basis for edscob s/eds_ind s
   % OK?
%   geteds(s,'depkrns) or
%   puteds(s,'depkrns,
      foreach f in  eds_sys s join
            if lc f = (1 ./ 1) and degreepf f = 1 then {lpow f}; %);


symbolic procedure prlkrns s;
   % s:eds -> prlkrns:list of lpow pf
   % principal kernels - a basis for the non-linear part of s
%   geteds(s,'prlkrns) or
%   puteds(s,'prlkrns,
      setdiff(edscob s,append(indkrns s,depkrns s)); %);


symbolic procedure remkrns s;
   % s:eds -> remkrns:nil
   foreach p in {'indkrns,'depkrns,'prlkrns} do rempropeds(s,p);


% Operations on sys


symbolic procedure degreepart(s,d);
   % s:sys, d:int -> degreepart:sys
   foreach f in s join if degreepf f = d then {f};


symbolic procedure scalarpart s;
   % s:sys -> scalarpart:sys
   degreepart(s,0);


symbolic procedure pfaffpart s;
   % s:sys -> pfaffpart:sys
   degreepart(s,1);


symbolic procedure nonpfaffpart s;
   % s:sys -> nonpfaffpart:sys
   foreach f in s join if degreepf f neq 1 then {f};


symbolic procedure solvedpart s;
   % s:sys -> solvedpart:sys
   foreach f in s join if f and lc f = (1 ./ 1) then {f};


symbolic procedure lpows s;
   % s:list of pf -> lpows:list of lpow pf
   % returns the leading kernels in s
   foreach f in s collect lpow f;


symbolic procedure singleterms s;
   % s:list of pf -> singleterms:bool
   % true if each form in s is a single term
   null s or null red car s and singleterms cdr s;


symbolic procedure !*a2sys u;
   % u:prefix list -> !*a2sys:list of pf
   if rlistp u then
      foreach f in cdr indexexpandeval{u} collect xpartitop f
   else typerr(u,'list);


symbolic procedure !*sys2a u;
   % u:list of pf -> !*sys2a:prefix list
   makelist foreach f in u collect !*pf2a f;


symbolic procedure !*sys2a1(u,v);
   % u:list of pf -> !*sys2a:prefix list
   % !*sys2a with choice of !*sq or true prefix
   makelist foreach f in u collect !*pf2a1(f,v);


% Operations on pf


symbolic procedure xpows f;
   % f:pf -> xpows:list of lpow pf
   if f then lpow f . xpows red f;


symbolic procedure xcoeffs f;
   % f:pf -> xcoeffs:list of sq
   if f then lc f . xcoeffs red f;


symbolic procedure degreepf f;
   % f:pf -> degreepf:int
   % assumes f homogeneous
   % could replace with xdegree from XIDEAL2
   if null f then 0
   else (if null x then 0
   else if fixp x then x
   else rerror('eds,130,"Non-integral degree not allowed in EDS"))
   where x = deg!*form lpow f;


symbolic procedure xreorder f;
   % f:pf -> xreorder:pf
   if f then
      addpf(multpfsq(xpartitop lpow f,reordsq lc f),
            xreorder red f);


symbolic procedure xreorder!* f;
   % f:pf -> xreorder!*:pf
   % Like xreorder when it is known that only the order between terms
   % has changed (and not within terms).
   if f and red f then
      addpf(lt f .+ nil,xreorder!* red f)
   else f;


symbolic procedure xrepartit f;
   % f:pf -> xrepartit:pf
   if f then
      addpf(wedgepf(xpartitsq subs2 resimp lc f,xpartitop lpow f),
            xrepartit red f);


symbolic procedure xrepartit!* f;
   % f:pf -> xrepartit!*:pf
   % Like xrepartit when xvars!* hasn't changed.
   if f then
      addpf(multpfsq(xpartitop lpow f,subs2 resimp lc f),
            xrepartit!* red f);


symbolic procedure trterm f;
   % f:pf -> trterm:lt pf
   % the trailing term in f
   if null red f then lt f else trterm red f;


symbolic procedure linearpart(f,p);
   % f:pf, p:list of 1-form kernel -> linearpart:pf
   % result is the part of f of degree 1 in p
   if null f then nil
   else if length intersection(wedgefax lpow f,p) = 1 then
      lt f .+ linearpart(red f,p)
   else linearpart(red f,p);


symbolic procedure inhomogeneouspart(f,p);
   % f:pf, p:list of 1-form kernel -> inhomogeneouspart:pf
   % result is the part of f of degree 0 in p
   if null f then nil
   else if length intersection(wedgefax lpow f,p) = 0 then
      lt f .+ inhomogeneouspart(red f,p)
   else inhomogeneouspart(red f,p);


symbolic procedure xcoeff(f,c);
   % f:pf, c:pffax -> xcoeff:pf
   if null f then nil
   else
      begin scalar q,s;
      q := xdiv(c,wedgefax lpow f);
      if null q then return xcoeff(red f,c);
      q := mknwedge q;
      if append(q,c) = lpow f then s := 1 % an easy case
      else s := numr lc wedgepf(!*k2pf q,!*k2pf mknwedge c);
      return q .* (if s = 1 then lc f else negsq lc f)
               .+ xcoeff(red f,c);
      end;


symbolic procedure xvarspf f;
   % f:pf -> xvarspf:list of kernel
   if null f then nil
   else
      union(foreach k in
               append(wedgefax lpow f,
               append(kernels numr lc f,
                      kernels denr lc f)) join if xvarp k then {k},
            xvarspf red f);


symbolic procedure kernelspf f;
   % f:pf -> kernelspf:list of kernel
   % breaks up wedge products
   if null f then nil
   else
      union(append(wedgefax lpow f,
            append(kernels numr lc f,
                          kernels denr lc f)),
            kernelspf red f);


symbolic procedure mkform!*(u,p);
   % u:prefix, p:prefix (usually int) -> mkform!*:prefix
   % putform with u returned, and covariant flag removed
   begin
   putform(u,p);
   return u;
   end;


% Operations on lists


symbolic procedure purge u;
   % u:list -> purge:list
   % remove repeated elements from u, leaving last occurence only
   if null u then nil
   else if car u member cdr u then purge cdr u
   else car u . purge cdr u;


symbolic procedure rightunion(u,v);
   % u,v:list -> rightunion:list
   % Like union, but appends v to right. Ordering of u and v preserved
   % (last occurence of each element in v used).
   append(u,foreach x on v join
      if not(car x member u) and not(car x member cdr x) then {car x});


symbolic procedure sublisq(u,v);
   % u:a-list, v:any -> sublisq:any
   % like sublis, but leaves structure untouched where possible
   if null u or null v then v
   else
      begin scalar x,y;
      if (x := atsoc(v,u)) then return cdr x;
      if atom v then return v;
      y := sublisq(u,car v) . sublisq(u,cdr v);
      return if y = v then v else y;
      end;


symbolic procedure ordcomb(u,n);
   % u:list, n:int -> ordcomb:list of list
   % List of all combinations of n distinct elements from u.
   % Order of u is preserved: ordcomb(u,1) = mapcar(u,'list)
   % which is not true for comb, from which this is copied.
   begin scalar v; integer m;
   if n=0 then return {{}}
   else if (m:=length u-n)<0 then return {}
   else for i := 1:m do
    <>;
   return nconc!*(v,{u})
   end;


symbolic procedure updkordl u;
   % u:list of kernel -> updkordl:list of kernel
   % list version of updkorder
   % kernels in u will have highest precedence, order of
   % other kernels unchanged
   begin scalar v,w;
   v := kord!*;
   w := append(u,setdiff(v,u));
   if v=w then return v;
   kord!* := w;
   alglist!* := nil . nil;        % Since kernel order has changed.
   return v
   end;


symbolic procedure allequal u;
   % u:list of any -> allequal:bool
   % t if all elements of u are equal
   if length u < 2 then t
   else car u = cadr u and allequal cdr u;


symbolic procedure allexact u;
   % u:list of kernel -> allexact:bool
   % t if all elements of u are exact pforms
   if null u then t
   else exact car u and allexact cdr u;


symbolic procedure coords u;
   % u:list of kernel -> coords:list of kernel
   % kernels in u are 1-forms, returns coordinates involved
   % THIS SHOULD GO
   foreach k in u join if exact k then {cadr k};


symbolic procedure zippf(pfl,sql);
   % pfl:list of pf, sql:list of sq
   % -> zippf:pf
   % Multiply elements of pfl by corresponding elements of sql, and add
   % results together. If trailing nulls on pfl or sql can be omitted.
   if null pfl or null sql then nil
   else if numr car sql and car pfl then
      addpf(multpfsq(car pfl,car sql),zippf(cdr pfl,cdr sql))
   else
      zippf(cdr pfl,cdr sql);


% EDS tracing and debugging


symbolic procedure errdhh u;
% Special error call for errors that shouldn't happen
rerror(eds,999,"Internal EDS error -- please contact David Hartley
*****" . if atom u then {u} else u);


symbolic procedure edsverbose(msg,v,type);
   % msg:atom or list, v:various, type:id|nil
   % -> edsverbose:nil
   % type gives the type of v, one of
   %    nil  - v is empty
   %    'sf  - v is a list of sf
   %    'sq  - v is a list of sq
   %    'sys - v is a list of pf
   %    'cob - v is a list of kernel
   %    'map - v is a map (list of kernel.prefix)
   %    'xform - v is an xform (list of kernel.pf)
   %    'prefix- v is prefix
   if !*edsverbose or !*edsdebug then
   begin
   if atom msg then msg := {msg};
   lpri msg; terpri();
   if null type then nil
   else if type = 'sf then
      foreach f in v do edsmathprint prepf f
   else if type = 'sq then
      foreach f in v do edsmathprint prepsq f
   else if type = 'sys then
      foreach f in v do edsmathprint preppf f
   else if type = 'cob then
      edsmathprint makelist v
   else if type = 'map then
      foreach p in v do edsmathprint {'equal,car p,cdr p}
   else if type = 'rmap then
   << foreach p in car v do edsmathprint {'equal,car p,cdr p};
      foreach p in cadr v do edsmathprint {'neq,p,0} >>
   else if type = 'xform then
      foreach p in v do edsmathprint {'equal,car p,preppf cdr p}
   else if type = 'prefix then
      edsmathprint v
   else errdhh{"Unrecognised type",type,"in  edsverbose"};
   end;


symbolic procedure edsdebug(msg,v,type);
   % msg:string, v:various, type:id|nil
   % -> edsdebug:nil
   % Like edsverbose, just for debugging.
   if !*edsdebug then edsverbose(msg,v,type);


symbolic procedure edsmathprint f;
   % f:prefix -> nil
   % Similar to mathprint, except going in at writepri,
   % so TRI package picks it up too.
   <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edsuser.red0000644000175000017500000002141611526203062023431 0ustar  giovannigiovannimodule edsuser;

% Miscellaneous user functions

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



fluid '(alglist!* subfg!* !*arbvars xvars!*);

global '(indxl!*);


put('index_expand,'rtypefn,'quotelist);
put('index_expand,'listfn,'indexexpandeval0);

symbolic procedure indexexpandeval0(u,v);
   % u:list of prefix, v:bool -> indexexpandeval0:prefix list
   % kludge to add v argument to index_expand listfn
   makelist foreach p in getrlist indexexpandeval u collect reval1(p,v);


symbolic procedure indexexpandeval u;
   % u:list of prefix -> indexexpandeval:prefix list
   if length u neq 1 then
      rerror(eds,000,"Wrong number of arguments to index_expand")
   else if rlistp(u := reval car u) then
      makelist purge foreach x in cdr u join cdr indexexpandeval {x}
   else makelist indexexpand u;


symbolic procedure indexexpand u;
   % u:prefix -> indexexpand:list of prefix
   % u has always been reval'd, so there is no need to expand
   % summations.
   if eqexpr u then indexexpandeqn u else
   if boolexpr u then indexexpandbool u else
   begin scalar i,v,alglist!*;
   u := simp!* u;
   % Expand free indices (put them into some order for safety)
   i := idsort purge if numr u and not domainp numr u then
                              flatindxl allind !*t2f lt numr u;
   v := foreach j in mkaindxc(i,nil) join
                 if numr(j := subfreeindices(numr u,pair(i,j))) then
              {absf numr j ./ denr j};  % nprimitive too?
   return for each q in purge v collect mk!*sq multsq(q,1 ./ denr u);
   end;


symbolic procedure indexexpandeqn u;
   % u:rule|equation -> indexexpandeqn:list of rule|equation
   begin scalar i,v,lh,rh;
               scalar alglist!*;
   % Expand free indices on lhs (put them into some order for safety)
   lh := reval cadr u where subfg!* = nil; % avoid let rules
   i := idsort purge flatindxl allindk lh;
   rh := aeval caddr u;
   v := foreach j in mkaindxc(i,nil) join
      if j := subfreeindeqn({car u,lh,rh},pair(i,j)) then {j};
   % Remove duplicates
   i := {};
   v := foreach r in v join
      if not(cadr r member i) then
               << i := cadr r . i; {r} >>;
   return v;
   end;


symbolic procedure subfreeindeqn(u,l);
   % u:rule|equation, l:alist -> subfreeindeqn:rule|equation|nil
   % Make index substitution l in u. Only index symmetry simplifications
   % are allowed, so the lhs can either vanish (nil returned) or acquire
   % an overall sign (sign transferred to rhs).
   begin scalar lh,rh;
   lh := subfreeindk(cadr u,l);
   if null atomf lh then lh := revop1 lh; % gets done in rule!-list
                                          % anyway
   lh := reval lh where subfg!* = nil; % avoid let rules;
   if lh = 0 then return nil;
   rh := simp!* caddr u;
   rh := quotsq(subfreeindices(numr rh,l),subfreeindices(denr rh,l));
   if eqcar(lh,'minus) then
   << lh := cadr lh;
      rh := negsq rh >>;
   return {car u,lh,mk!*sq rh};
   end;


symbolic procedure boolexpr u;
   % u:any -> boolexpr:bool
   not atom u and flagp(car u,'boolean);


symbolic procedure indexexpandbool u;
   % u:prefix -> indexexpandbool:list of prefix
   begin scalar i,v,alglist!*;
   % Expand free indices on lhs (put them into some order for safety)
   i := idsort purge flatindxl allindk u;
   v := foreach j in mkaindxc(i,nil) collect
           car u .
              foreach a in cdr u collect reval subfreeindk(a,pair(i,j));
   return purge v;
   end;


symbolic procedure subfreeindices(u,l);
   % u:sf, l:a-list -> subfreeindices:sq
   % Discriminates indices from variables, modified from EXCALC's
   % subfindices to go inside operators other than EXCALC's.
   begin scalar alglist!*;
   return
      if domainp u then u ./ 1
      else
         addsq(
            multsq(if atom mvar u then
                             !*p2q lpow u
                          else if sfp mvar u then
                      exptsq(subfreeindices(mvar u,l),ldeg u)
                   else
                      exptsq(simp subfreeindk(mvar u,l),ldeg u),
                   subfreeindices(lc u,l)),
            subfreeindices(red u,l))
   end;


symbolic procedure subfreeindk(u,l);
   % u:kernel, l:a-list -> subfreeindk:kernel
   % Extends subindk to indexed variables
   if atom u then u
   else if flagp(car u,'indexvar) then
      car u . subla(l,cdr u)
   else subindk(l,u);


put('linear_divisors,'rtypefn,'quotelist);
put('linear_divisors,'listfn,'lineardivisors);

symbolic procedure lineardivisors(u,v);
   % u:{prefix}, v:bool -> lineardivisors:prefix list
   makelist foreach f in lineardivisorspf xpartitop reval car u collect
      !*pf2a1(f,v);


symbolic procedure lineardivisorspf f;
   % f:pf -> lineardivisorspf:list of pf
   begin scalar x,g,v;
   foreach p in xpows f do x := union(wedgefax p,x);
   foreach k in x do
   << v := intern gensym() . v;
      g := addpf(k .* !*k2q car v .+ nil,g)>>;
   x := edssolve(xcoeffs wedgepf(g,f),v);
   if length x neq 1 or caar x neq t then
      errdhh "Bad solve result in lineardivisorspf";
   x := cadar x;
   v := updkordl v;
   g := numr subf(numr !*pf2sq g,x);
   x := {};
   while g do
   << x := xpartitsq(lc g ./ 1) . x;
      g := red g >>;
   setkorder v;
   return reverse xautoreduce x;
   end;


symbolic procedure xdecomposepf f;
   % f:pf -> xdecomposepf:list of pf
   begin scalar x;
   x := lineardivisorspf f;
   if length x = degreepf f then return reverse x;
   end;


put('exfactors,'rtypefn,'quotelist);
put('exfactors,'listfn,'exfactors);

symbolic procedure exfactors(u,v);
   % u:{prefix}, v:bool -> exfactors:prefix list
   makelist foreach f in xfactorspf xpartitop reval car u collect
      !*pf2a1(f,v);


symbolic procedure xfactorspf f;
   % f:pf -> xfactorspf:list of pf
   begin scalar x;
   x := lineardivisorspf f;
   f := xreduce(f,foreach g in x collect
                                  addpf(1 .* (-1 ./ 1) .+ nil,g));
   return
      if f = !*k2pf 1 then reverse x
      else f . reverse x;
   end;


symbolic operator exact;
symbolic procedure exact u;
   % u:prefix -> exact:bool
   % True if u is an exact pform kernel
   eqcar(u,'d);

flag('(exact),'boolean);


put('derived_system,'rtypefn,'getrtypecar);
put('derived_system,'edsfn,'deriveeds);
put('derived_system,'listfn,'derivelist);

symbolic procedure derivelist(u,v);
   % u:{xeds|rlist}, v:bool -> derivelist:rlist
   !*sys2a1(derive !*a2sys reval car u,v) where xvars!* = nil;


symbolic procedure deriveeds s;
   % s:eds -> deriveeds:eds
   begin
   s := copyeds s;
   if pfaffian s then
      eds_sys s := derive pfaffpart eds_sys s
   else rerror(eds,000,"non-Pfaffian system in derived_system");
   return s;
   end;


symbolic procedure derive s;
   % s:sys -> derive:sys
   begin scalar c,f;
   if null s then s;
   s := xautoreduce s;
   c := for each f in s collect
               if degreepf f = 1 then intern gensym()
         else rerror(eds,000,"non-Pfaffian system in derived_system");
   f := zippf(s,foreach k in c collect !*k2q k);
   s := edssolve(xcoeffs xreduce(exdfpf f,s),c);
   if length s neq 1 or null caar s then
      errdhh{"Bad solve result in derive:",s};
   s := cadr car s;
   f := pullbackpf(f,s);
   c := setdiff(c,foreach m in s collect car m);
   f := xrepartit f where xvars!* = c;
   return for each x in reverse c collect xcoeff(f,{x});
   end;


symbolic procedure allcoords f;
   % f:prefix -> allcoords:list of kernel
   % Pick up 0-form kernels in f
   makelist purge
      foreach k in (xvarspf xpartitop f where xvars!* = t) join
               if xdegree k = 0 and
            not assoc(k,depl!*) and
             not eqcar(k,'partdf) then {k}
         else if (xdegree k = 1) and exact k then {cadr k};

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/tableaux.red0000644000175000017500000000576111526203062023571 0ustar  giovannigiovannimodule tableaux;

% Definition and manipulation of tableaux using tab structure

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment. Tableaux are stored internally in a tagged matrix of 1-forms:

         tab     ::= 'tab . matrix of pf

The external format is a matrix:

         prefix tab       ::= prefix matrix of prefix


endcomment;


symbolic procedure !*a2tab u;
   % u:prefix tab -> tab
   % primitive - not much checking
   if not eqcar(u,'mat) then typerr(u,'matrix)
   else mktab foreach r in cdr u collect
           foreach f in r collect xpartitop f;


symbolic procedure !*tab2a u;
   % u:tab -> prefix tab
   'mat . foreach r in cdr u collect
         foreach f in r collect !*pf2a f;


symbolic procedure mktab u;
   % u:matrix of pf -> mktab:tab
   'tab . u;


symbolic procedure tableaup u;
   % u:any -> tableaup:bool
   eqcar(u,'tab);


put('tableau,'psopfn,'tableaueval);

symbolic procedure tableaueval s;
   % s:{eds} -> prefix tab
   if not edsp(s := reval car s) then typerr(s,'eds)
   else !*tab2a edscall tableau s;


symbolic procedure tableau s;
   % s:eds -> tab
   % very much like characterseds
   % Only non-empty rows are returned, unless whole thing is empty,
   % in which case a 1xN matrix of zeros is returned.
   begin scalar prl,ind;
   if not pfaffian s or not quasilinearp s then
      rerror(eds,000,
             "Tableau only works for quasilinear Pfaffian systems");
   s := car tmpind closure s;
   prl := prlkrns s; ind := indkrns s;
   s := foreach f in nonpfaffpart eds_sys s join
           if f := linearpart(f,prl) then {f};
   if null s then return mktab {nlist(nil,length ind)};
   return mktab foreach f in s collect
                   foreach i in ind collect negpf xcoeff(f,wedgefax i);
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/contact.red0000644000175000017500000002225611526203062023415 0ustar  giovannigiovannimodule contact;

% Contact systems on jet bundles and Grassmann bundles

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



global '(indxl!* !*sqvar!*);

put('contact,'rtypefn,'quoteeds);
put('contact,'edsfn,'contact);
flag('(contact),'nospread);


symbolic procedure contact u;
   % u:{int,cfrm|rlist of prefix,cfrm|rlist of prefix[,props]}
   % -> contact:eds
   % Contact system for jet bundle of order ord
   % over bundle with base coframing bas and fibre coframing jet
   begin scalar ord,bas,jet,props,s,m,sys;
   if length u < 3 or length u > 4 then
      rerror(eds,000,"Wrong number of arguments to contact");
   ord := car u;
   if not fixp ord or ord < 0 then
      typerr(ord,"non-negative integer");
   bas := !*a2cfrm{car(u := cdr u)};
   jet := !*a2cfrm{car(u := cdr u)};
   props := if cdr u then foreach x in getrlist cadr u collect
                     if not idp cadr x then
                  rerror(eds,000,"Badly formed properties in EDS")
               else cadr x .
                   if rlistp caddr x then cdr indexexpandeval{caddr x}
                  else caddr x;
   m := cfrmprod2(bas,jet);
   s := mkeds{{},
              foreach f in cfrm_cob bas collect !*k2pf f,
              m,
              props};
   puteds(s,'jet0,uniqvars cfrm_cob jet);
   puteds(s,'sqvar,!*sqvar!*);
   foreach f in {'solved,'reduced,'quasilinear,'pfaffian,'involutive} do
      flagtrueeds(s,f);
   if allexact cfrm_cob m then
      for i:=1:ord do   % gbsys doesn't produce redundant mixed partials
      << sys := eds_sys s;
         s := edscall gbsys s;
               eds_sys s := append(sys,eds_sys s) >>
   else
      for i:=1:ord do   % have to allow for structure constants
         s := edscall prolongeds s;
   return s;
   end;


symbolic procedure gbsys s;
   % s:eds -> gbsys:eds
   % Refine test for flg argument to gbcoords
   begin scalar prl,dep,ind,jet,jet0,sys,cob,idxs,x,crd,m;
   if not normaledsp s then
      rerror(eds,000,{"System not in normal form"});
   % Get information about s
   ind := indkrns s; idxs := uniqids ind;
   prl := prlkrns s; jet := uniqvars prl;
   cob := edscob s;
   jet0 := geteds(s,'jet0) or jet;
   % Generate new index names if necessary
   if not subsetp(idxs,indxl!*) then % indexrange is an rlistat
      apply1('indexrange,{{'equal,gensym(),makelist idxs}});
   % Generate new coordinates
   jet := gbcoords(jet,idxs,jet0,allexact cob);
   % New contact forms
   sys := foreach pr in pair(prl,jet) collect
             car pr .* (1 ./ 1) .+
                negpf zippf(eds_ind s,
                            for each c in cdr pr collect !*k2q c);
   % Compile coordinate and cobasis lists in correct order
   foreach j in jet do crd := union(j,crd);
   prl := foreach c in crd collect
             if (x := lpow exdfk c) =  {'d,c} then x
             else errdhh{"Bad differential",x,"from",{'d,c},"in gbsys"};
   prl := reversip setdiff(prl,cob);
   dep := setdiff(cob,ind);
   cob := append(dep,append(prl,ind));
   crd := reversip setdiff(crd,edscrd s);
   crd := append(edscrd s,crd);
   % Update coframing
   m := copycfrm eds_cfrm s;
   cfrm_cob m := cob;
   cfrm_crd m := crd;
   % Update eds
   s := copyeds s;
   eds_sys s := sys;
   eds_cfrm s := m;
   puteds(s,'jet0,jet0);
   foreach f in {'solved,'reduced,'quasilinear,'pfaffian} do
      flagtrueeds(s,f);
   flagfalseeds(s,'closed);
   rempropeds(s,'involutive);
   s := purgeeds!* s;
   remkrns s;
   return s;
   end;


symbolic procedure gbcoords(prlvars,indids,jet0,flg);
   % prlvars:list of kernel, indids:list of id, jet0:list of kernel,
   % flg:bool
   % -> gbcoords:matrix of kernel
   % constructs coordinates for fibre of Grassmann bundle
   % index symmetries???
   foreach c in prlvars collect
      begin scalar x; integer n;
      % split c into {base,indices} using jet0
      if jet0 eq prlvars then
         c := {splitoffindices(c,c)}
      else
         c := foreach c0 in jet0 join
                 if c0 := splitoffindices(c0,c) then {c0};
      if length c neq 1 then
         errdhh {"Name conflict in gbcoords:",length c,"matches"}
      else c := car c;
      n := length car c + length cdr c; % actually, cdar c + cdr c + 1
      if (x := get(caar c,'ifdegree)) and (x := assoc(n,x)) and cdr x
         then errdhh {"Degree conflict in gbcoords:",
                      append(car c,nil.cdr c)}
         else mkform!*(append(car c,nil.cdr c),0);
      return foreach i in indids collect
         begin scalar x;
         x := if (jet0 neq prlvars) and flg then foreach j in
                 sort(i . flatindxl cdr c,'indtordp)
                 collect lowerind j
              else append(cdr c,{lowerind i});
         x := car fkern append(car c,x);
         if reval x neq x then typerr(x,"free coordinate");
         return x;
         end;
      end;


symbolic procedure splitoffindices(u,v);
   % u,v:kernel -> splitoffindices:nil or kernel.list of id
   % v is an indexed variable, u is a variable
   % if v is obtained from u by adding indices,
   % return base.indices otherwise nil
   % Rules:             a,a     -> {a}.{}
   %                     a,{a,i..}       -> {a}.{i..}
   %               {a,i..},{a,i..} -> {a,i..}.{}
   %           {a,i..},{a,i..,j..}     -> {a,i..}.{j..}
   %                     otherwise       -> nil
   if atom u then
      if u = v then {u}.{}
      else if pairp v and car v = u then {u}.cdr v
      else nil
   else if pairp v and car v = car u then
      if null cdr u then u.cdr v
      else (if x then u.cdr x)
            where x = splitoffindices(cdr u,cdr v);


symbolic procedure indtordp(u,v);
   % a total ordering for indices
   begin scalar x;
        x := indxl!*;
    a:  if null x then return orderp(u,v)
         else if u eq car x then return t
         else if v eq car x then return;
        x := cdr x;
        go to a
   end;


symbolic procedure uniqids u;
   % u:list of kernel -> uniqids:list of id
   % returns id's suitable for use as indices
   % if elements of u are indexed pforms with the same base,
   % we can use the indices, otherwise artificial names are
   % constructed (if excalc allowed non-atomic index names, we
   % wouldn't need to contrive id's).
   begin scalar x;
   x := foreach i in u collect indexid i;
   if memq(nil,x)
      or not allequal sublis(pair(x,nlist(nil,length x)),u)
      then x := foreach i in u collect pformid i;
   if repeats x then errdhh "Name conflict in uniqids";
   return x;
   end;


symbolic procedure indexid u;
   % u:kernel -> indexid:id or nil
   % returns the index on a single-index kernel, else nil
   (if x and length x = 1 then car x)
    where x = flatindxl indexlist u;


symbolic procedure indexlist u;
   % u:kernel -> indexlist:list of kernel
   % returns list of ALL indices in u, free or not
   % based on allindk
   if atom u then nil
   else if get(car u,'rtype) = 'indexed!-form then
      for each j in cdr u collect revalind j
   else if get(car u,'indexfun) then
      indexlist apply1(get(car u,'indexfun),cdr u)
   else if car u eq 'partdf then
      if null cddr u then
         for each j in indexlist cdr u collect revalind lowerind j
      else append(indexlist cadr u,
                  for each j in indexlist cddr u
                    collect revalind lowerind j)
   else append(indexlist car u,indexlist cdr u);


symbolic procedure pformid u;
   % u:kernel -> pformid:id
   % constructs an id for the pform variable in u
   (if atom x then x
    else intern compress foreach a in flatindxl x join explode a)
    where x = pformvar u;


symbolic procedure uniqvars u;
   % u:list of kernel -> uniqvars:list of kernel
   % extracts pform variables from u, checking for repeats
   if repeats(u := foreach k in u collect pformvar k)
      then errdhh "Name conflict in uniqvars"
      else u;


symbolic procedure pformvar u;
   % u:kernel -> pformvar:kernel
   % extracts pform variable from u
   if atom u or get(car u,'rtype) = 'indexed!-form then u
   else if car u memq '(d hodge partdf)
           and null cddr u then pformvar cadr u
   else errdhh {"No unique variable in ",u};

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/eds.red0000644000175000017500000001747411526203062022543 0ustar  giovannigiovannimodule eds;
%
%                               EDS V2.2
%
%
% Author:         David Hartley
%                Physics and Mathematical Physics
%               University of Adelaide   SA 5005
%               Australia
%
%                email:   DHartley@physics.adelaide.edu.au
%
%
% Description:    EDS is a REDUCE package for symbolic analysis of partial
%                differential equations using the geometrical approach of
%                exterior differential systems. The package implements
%                much of exterior differential systems theory, including
%                prolongation and involution analysis, and has been
%                optimised for large, non-linear problems.
%
%
% Requires:      REDUCE 3.8
%
% Created:       23/6/90  V0       as es.red (with Robin W Tucker)
%
% Modified:     8/8/90   V0.1   Added quasi-linear solving and consist-
%                               ency conditions for simultaneous eqns
%               11/9/90  V0.2    Added resimp in front of all subf, subsq
%                               etc as temporary fix for subf bug.
%               14/5/91  V0.3   Switched off factor (and on exp) in
%                               various routines to make simplifications
%                               work.
%               22/5/91  V0.4    Added subs2 in front of all resimp as
%                               temporary fix for unseen power LET rule
%                               bug.
%               26/11/91 V0.5   Altered algorithm in regchn so that
%                               alpha coefficients are not chosen until
%                               entire chain has been constructed.
%               30/6/92  V1       Renamed exsys.red.
%                               Radically altered exsolve to use modulo
%                               rather than contraction. Eliminated need
%                               for frame vectors. Added extra switches
%                               to allow given, random or (as before)
%                               generic combinations of the independence
%                               1-forms to be used to construct a
%                               regular chain.
%                               Removed many utilities to tools.red.
%               23/7/92  V1.1    Added module `complete'
%               14/3/94  V1.2     Renamed eds.red.
%                               Modified for independent compilation,
%                               and for compatibility with new xideal.
%               25/4/96  V2.0   Total rewrite using parts of earlier
%                               versions.
%                               Added types for EDS and coframing.
%               26/11/96 V2.1    Made cross a bundle product when arguments
%                               share submanifold
%               08/07/03 V2.2    Various bug fixes and updates for REDUCE 3.8
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% Other packages which must be loaded at run-time.

load_package solve,excalc,xideal;

create!-package('(

     eds     % Header module
     edseval % Definition and manipulation of eds structure for exterior systems
     edscfrm % Coframing structure for EDS
     systems % Operations on exterior differential systems
     tableaux        % Definition and manipulation of tableaux using tab structure
     contact % Contact systems on jet bundles and Grassmann bundles
     invol   % Cartan characters, reduced characters, involution test
     prolong % Prolonged systems, tableaux
     pullback        % Pullback transformations
     restrict        % Restrict to a subset of a coframing
     transfrm        % Cobasis transformations
     edspde  % PDE interface to EDS
     edsequiv        % Check if EDS structures are equivalent
     edsuser % Miscellaneous user functions
     edsnorml        % Converting exterior systems to internal form
     edssolve        % Specialised solvers for EDS
     disjoin % Convert a variety to a disjoint union of sub-coframings
     element % Generate a random integral element
     edsaux  % Miscellaneous support functions
     edsexptl        % Experimental (algebraic mode) operators
     edspatch        % Various patches for other parts of Reduce.

                ),'(contrib eds));

% Switches

fluid '(!*edsverbose !*edsdebug !*edssloppy !*edsdisjoint !*genpos
        !*ranpos);

switch edsverbose;       % prints calculation traces when on
switch edsdebug; % prints debugging information when on
switch edsdisjoint;      % allows automatic variety decomposition when on
switch edssloppy;        % treat quasilinear systems as semilinear
switch genpos;          % Calculate characters with system in general
                        % position
switch ranpos;          % Calculate characters with system in random
                        % position

put('genpos,'simpfg,'((t (setq !*ranpos nil))));
put('ranpos,'simpfg,'((t (setq !*genpos nil))));


% Global variables

fluid '(cfrmcob!* cfrmcrd!* cfrmdrv!* cfrmrsx!* pullback_maps
        dependencies);

cfrmcob!* := nil;     % cobasis for background coframing
cfrmcrd!* := nil;     % coordinates for background coframing
cfrmdrv!* := nil;     % structure equations for background coframing
cfrmrsx!* := nil;     % restrictions for background coframing as pf
pullback_maps:= makelist {}; % list of maps used by last call to prolong
dependencies := makelist {}; % dependencies removed by pde2eds

flag('(pullback_maps dependencies),'share);

remprop('indexlist,'vartype);   % WN indexlist may not be fluid
				% it is a function in contact.red
% Macros used throughout


symbolic smacro procedure eds_sys s;
   cadr s;

symbolic smacro procedure eds_ind s;
   caddr s;

symbolic smacro procedure eds_cfrm s;
   cadddr s;

symbolic smacro procedure eds_props s;
   car cddddr s;

symbolic smacro procedure cfrm_cob m;
   cadr m;

symbolic smacro procedure cfrm_crd m;
   caddr m;

symbolic smacro procedure cfrm_drv m;
   cadddr m;

symbolic smacro procedure cfrm_rsx m;
   nth(m,5);


% Macro for edscall


symbolic macro procedure edscall u;
   % evaluate form cadr u within edsprotect
   function edsprotect .
      foreach x in cdr u collect
         function list . mkquote car x . cdr x;


%%%% Form function for edscall
%%%
%%%
%%%put('edscall,'formfn,'formedscall);
%%%
%%%symbolic procedure formedscall(u,v,mode);
%%%   % evaluate form cadr u within edsprotect
%%%   function edsprotect .
%%%      foreach x in formlis(cdr u,v,mode) collect
%%%         function list . mkquote car x . cdr x;


% Macros from excalc for compilation


smacro procedure !*k2pf u;
   u .* (1 ./ 1) .+ nil;

smacro procedure negpf u;
   multpfsq(u,(-1) ./ 1);

smacro procedure lowerind u;
   list('minus,u);

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/eds/edspatch.red0000644000175000017500000002750711526203062023561 0ustar  giovannigiovannimodule edspatch;

% Various patches for other parts of Reduce.

% Author: David Hartley

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
        !*solveinconsistent depl!*);

%%% General changes

% Extend MAP/SELECT to other structures than list/matrix

symbolic procedure map!-eval1(o,q,fcn1,fcn2);
 % o       structure to be mapped.
 % q       map expression (univariate function).
 % fcn1    function for evaluating members of o.
 % fcn2    function computing results (e.g. aeval).
 map!-apply(map!-function(q,fcn1,fcn2),o);

symbolic procedure map!-function(q,fcn1,fcn2);
   begin scalar v,w;
   v := '!&!&x;
   if idp q
      and (get(q,'simpfn) or get(q,'number!-of!-args)=1)
   then <>
   else if eqcar(q,'replaceby) then
      <>
   else
   <>;
   if eqcar(w,'!~) then w:=cadr w;
   q := sublis({w.v,{'!~,w}.v},q);
   return {'lambda,{'w},
      {'map!-eval2,'w,mkquote v,mkquote q,mkquote fcn1,mkquote fcn2}};
   end;

symbolic procedure map!-apply(f,o);
   if atom o then apply1(f,o)
   else (if m then apply2(m,f,o)
               else car o . for each w in cdr o collect apply1(f,w))
                   where m = get(car o,'mapfn);

symbolic procedure mapmat(f,o);
   'mat . for each row in cdr o collect
      for each w in row collect
         apply1(f,w);

put('mat,'mapfn,'mapmat);


%%% EXCALC modifications

global '(indxl!*);
fluid '(kord!*);

% Remove covariant flag from indexed 0-forms.
% Add a subfunc to indexed forms.

if not getd 'excalcputform then copyd('excalcputform,'putform);

symbolic procedure putform(u,v);
   begin
   excalcputform(u,v);
   if not atom u then
   << put(car u,'subfunc,'(lambda (a b) b));
      remflag({car u},'covariant) >>;
   end;


% Have to update ndepends to REDUCE3.6 depends.

symbolic procedure ndepends(u,v);
   if null u or numberp u or numberp v then nil
    else if u=v then u
    else if atom u and u memq frlis!* then t
      %to allow the most general pattern matching to occur;
    else if (lambda x; x and lndepends(cdr x,v)) assoc(u,depl!*)
     then t
    else if not atom u and idp car u and get(car u,'dname) then
        (if depends!-fn then apply2(depends!-fn,u,v) else nil)
           where (depends!-fn = get(car u,'domain!-depends!-fn))
    else if not atomf u
      and (lndepends(cdr u,v) or ndepends(car u,v)) then t
    else if atomf v or idp car v and get(car v,'dname) then nil
    % else ndependsl(u,cdr v);
    else nil;

%%% Make depends from ALG into ndepends from EXCALC (identical except
%%% for atomf test which treats indexed variables as atoms).

copyd('depends,'ndepends);

symbolic procedure lndepends(u,v);
   % Need to allow the possibility that U is an atom because the int
   % package calls depends with sq instead of prefix.
   if null u then nil
    else if atom u then ndepends(u,v)
    else ndepends(car u,v) or lndepends(cdr u,v);

% changed first u -> v (error otherwise)

symbolic procedure ndependsl(u,v);
   v and (ndepends(u,car v) or ndependsl(u,cdr v));


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%        OLD PATCHES: REMOVE ONCE IN PATCHES.RED!!!             %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


fluid '(!*edsverbose !*edsdebug !*arbvars !*varopt !*groebopt
        !*solveinconsistent depl!*);


%%% SOLVE changes

% Changed depl!* line to work for non-atom kernels as well.

fluid '(!*expandexpt);   % from simp.red

fluid '( system!*        % system to be solved
         osystem!*       % original system on input
         uv!*            % user supplied variables
         iv!*            % internal variables
         fv!*            % restricted variables
         kl!*            % kernels to be investigated
         sub!*           % global substitutions
         inv!*           % global inverse substitutions
         depl!*          % REDUCE dependency list
         !*solvealgp     % true if using this module
         solvealgdb!*    % collecting some data
         last!-vars!*    % collection of innermost aux variables
         const!-vars!*   % variables representing constants
         root!-vars!*    % variables representing root expressions
         !*expli         % local switch: explicit solution
         groebroots!*    % predefined roots from input surds
         !*test_solvealg % debugging support
         !*arbvars
       );

fluid '(!*trnonlnr);
  % If set on, the modified system and the Groebner result
  % or the reason for the failure are printed.

global '(loaded!-packages!* !!arbint);

symbolic procedure solvenonlnrsys2();
  % Main driver. We need non-local exits here
  % because of possibly hidden non algebraic variable
  % dependencies.
  if null !*solvealgp then system!*:='(FAILED) else % against recursion.
  (begin scalar iv!*,kl!*,inv!*,fv!*,r,w,!*solvealgp,solvealgdb!*,sub!*;
         scalar last!-vars!*,groebroots!*,const!-vars!*,root!-vars!*;
         % preserving the variable sequence if *varopt is off
%      if not !*varopt then depl!* :=
%        append(pair(uv!*,append(cdr uv!*,{gensym()})),depl!*);
      if not !*varopt then depl!* :=
        append(foreach l on uv!* collect l,depl!*);
         % hiding dmode because exponentials need integers.
      for each f in system!* do solvealgk0
         (if dmode!* then numr subf(f,nil) where dmode!*=nil else f);
      if !*trnonlnr then print list("original system:",system!*);
      if !*trnonlnr then print list("original kernels:",kl!*);
      if null cdr system!* then
          if (smemq('sin,system!*)or smemq('cos,system!*)) and
             (r:=solvenonlnrtansub(prepf(w:=car system!*),car uv!*))
             and car r
            then return solvenonlnrtansolve(r,car uv!*,w)
           else if (smemq('sinh,system!*)or smemq('cosh,system!*)) and
             (r:=solvenonlnrtanhsub(prepf(w:=car system!*),car uv!*))
             and car r
            then return solvenonlnrtanhsolve(r,car uv!*,w);
      if atom (errorset('(solvealgk1),!*trnonlnr,nil))
               where dmode!*=nil
         then return (system!*:='(FAILED));
      system!*:='LIST.for each p in system!* collect prepf p;
      if not('groebner memq loaded!-packages!*)
        then load!-package 'groebner;
      for each x in iv!* do if not member(x,last!-vars!*) then
        for each y in last!-vars!* do depend1(x,y,t);
      iv!* := sort(iv!*,function (lambda(a,b);depends(a,b)));
      if !*trnonlnr then
      <<  prin2t "Entering Groebner for system";
          writepri(mkquote system!*,'only);
          writepri(mkquote('LIST.iv!*), 'only);
      >>;
      r := list(system!*,'LIST.iv!*);
      r := groesolveeval r;
      if !*trnonlnr then
      <<  prin2t "leaving Groebner with intermediate result";
          writepri(mkquote r,'only);
          terpri(); terpri();
      >>;
      if 'sin memq solvealgdb!* then r:=solvealgtrig2 r;
      if 'sinh memq solvealgdb!* then r:=solvealghyp2 r;
      r:= if r='(LIST) then '(INCONSISTENT) else solvealginv r;
      system!* := r;  % set value aside
      return r;
  end) where depl!*=depl!* ;


% Make variable dependency override reordering.


fluid '(!*trsparse);

symbolic procedure solvesparsecheck(sys,vl);
   % sys: list of sf, vl: list of kernel
   % -> solvesparsecheck: nil or {list of sf,list of kernel}
   % This program checks for a sparse linear system. If the
   % system is sparse enough, it returns (exlis.varlis) reordered
   % such that a maximum triangular upper diagonal form is
   % established. Otherwise the result is NIL.
   begin scalar vl1,xl,sys1,q,x,y;
         integer sp;

   % First collect a list vl1 where each variable is followed
   % by the number of equations where it occurs, and then
   % by the number of other variables which occur in these
   % equations (connectivity). At the same time, collect a measure
   % of the sparsity.
   sp:=0;
   vl1:= for each x in vl collect x . 0 . nil;
   foreach q in sys do
      foreach x in (xl := intersection(topkerns q,vl)) do
       <>;
   foreach p in vl1 do
      cddr p := length cddr p - 1; % could drop the -1

   % Drop out if density > 80%
   if sp > length sys * length vl * 0.8 then
    <>;

   % If varopt is on, sort variables first by least occurrences and then
   % least connectivity, but allow dependency to override.
   % Reset kernel order and reorder equations.
   if !*trsparse then
     solvesparseprint("Original sparse system",sys,vl);

   if !*varopt then
   << vl1 := sort(vl1,function solvevarordp);
      vl1 := foreach x in vl1 collect car x;
%      if !*trsparse then lpriw("Optimal variable order:",vl1);
%      foreach k in reverse vl1 do updkorder k;
%      vl1 := sort(vl1,function solvevarordp1);
      vl1 := solvevaradjust vl1;
%      if !*trsparse then lpriw("Adjusted variable order:",vl1);
      foreach k in reverse vl1 do updkorder k;
      sys := for each q in sys collect reorder q >>
   else vl1 := foreach x in vl1 collect car x;

   % Next sort equations in ascending order of their first variable
   % and then descending order of the next variable.
   sys1:= (nil . nil) . foreach x in vl1 collect x . nil;
   foreach q in sys do
      <>;
   foreach p in cdr sys1 do
      if cdr p then cdr p := sort(cdr p, function solvesparsesort);

   % Finally split off a leading diagonal system and push the remaining
   % equations down.
   sys := nconc(foreach p in sys1 join if cdr p then {cadr p},
                reversip foreach p in sys1 join if cdr p then cddr p);
   if !*trsparse then
      solvesparseprint("Variables and/or equations rearranged",sys,vl1);
   return sys.vl1;
   end;


symbolic procedure solvevarordp(x,y);
   cadr x < cadr y or
   cadr x = cadr y and cddr x < cddr y;

symbolic procedure solvevarordp1(x,y);
   % This is incomplete, since it is not transitive
   depends(x,y) or
   not depends(y,x) and ordop(x,y);


symbolic procedure solvevaradjust u;
   begin scalar v,y;
   if null u then return nil;
   v := foreach x in u join
              << y := assoc(x,depl!*);
            if null y or null xnp(cdr y,u) then {x} >>;
   return nconc(solvevaradjust setdiff(u,v),v);
   end;

% Usually solve goes to the Cramer method since the expressions
% contain exponentials. The Bareiss code should work, so disable this.

symbolic procedure exptexpflistp u;
   nil;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/0000755000175000017500000000000011722677363022154 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbint.red0000644000175000017500000000774711526203062024317 0ustar  giovannigiovannimodule invbint; % Algebraic mode interface to invbase.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure invtorder u;
  begin scalar w,o;
    w := reval car u;
    o := assoc(w,'((gradlex . glex) (revgradlex .grev) (lex . lex)));
    if null o then typerr(w,"involutive term ordering");
    ordering := cdr o;
    invsysvars!* :=
     if cdr u then
      for each y in cdr listeval (cadr u,nil) collect reval y
       else nil;
  end;

put('invtorder,'stat,'rlis);

symbolic procedure invbase u;
  begin scalar sys,vars,r;
    u := reval car u;
    if not eqcar(u,'list) then rederr "Argument to invbase not a list";
    sys := for each p in cdr u collect
     <
    >;
   % find the variables.
   vars := invsysvars!* or gvarlis sys;
   readsys('list.sys,'list.vars);
   invbase!*();
   r:= for each p in gg collect
     'plus . for each m in getv(gv,car p) collect
        prepsq !*di2q(list m,vars);
  return 'list . r;
 end;

put('invbase,'psopfn,'invbase);

symbolic procedure invlex u;
  begin scalar sys,vars,r;
    u := reval car u;
    if not eqcar(u,'list) then rederr "Argument to invlex not a list";
    sys := for each p in cdr u collect
     <
    >;
   % find the variables.
   vars := invsysvars!* or gvarlis sys;
   readsys('list.sys,'list.vars);
   invlex!*();
   (r:= for each p in gg collect
     'plus . for each m in getv(gv,car p) collect
        prepsq !*di2q(list m,vars)) where ordering='lex;
  return 'list . r;
 end;

put('invlex,'psopfn,'invlex);

symbolic procedure invtest u;
  begin scalar sys,vars,r;
    u := reval car u;
    if not eqcar(u, 'list) then rederr "Argument to invtest not a list";
    sys := for each p in cdr u collect
     <
    >;
   % find the variables.
   vars := invsysvars!* or gvarlis sys;
   readsys('list.sys,'list.vars);
   return invtest!*();
 end;

put('invtest,'psopfn,'invtest);

% the following procedure are borrowed from the groebner package:

symbolic procedure gvarlis u;
   % Finds variables (kernels) in the list of expressions u.
   sort(gvarlis1(u,nil),function ordop);

symbolic procedure gvarlis1(u,v);
   if null u then v
    else union(gvar1(car u,v),gvarlis1(cdr u,v));

symbolic procedure gvar1(u,v);
   if null u or numberp u or (u eq 'i and !*complex) then v
    else if atom u then if u member v then v else u . v
    else if get(car u,'dname) then v
    else if car u memq '(plus times expt difference minus)
     then gvarlis1(cdr u,v)
    else if car u eq 'quotient then gvar1(cadr u,v)
    else if u member v then v
    else u . v;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbase.red0000644000175000017500000000433311526203062024261 0ustar  giovannigiovannimodule invbase; % Computing involutive basis of polynomial system.

% Authors:  Alexey Yu. Zharkov, Yuri A. Blinkov
%           Saratov University, Astrakhanskaya 83,
%           Saratov 410071, Russia
%           e-mail: postmaster@scnit.saratov.su

% Copyright A. Zharkov, Y. Blinkov;
%           all rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Minor fixes by John Fitch.

create!-package('(invbase invbint invbcomp),'(contrib invbase));

fluid '(CONDS GV HV BV NG GG VARLIST VJETS NC);            % globals
fluid '(ORDERING REDTAILS);                                % modes
fluid '(PATH TRED STARS);                                  % tracing
fluid '(REDUCTIONS NFORMS ZEROS MAXORD TITLE);             % statistics
fluid '(invsysvars!* !*trinvbase alfa beta shortway thirdway
         invtempbasis);

share invtempbasis;

ordering := 'grev;

switch trinvbase;

gv:=mkvect(1000)$  % p o l y n o m i a l s
bv:=mkvect(1000)$  % f l a g  (n e w  p r o l o n g a t i o n s)

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbase.tex0000644000175000017500000001653011526203062024311 0ustar  giovannigiovanni\documentstyle[12pt]{article}
\textwidth 155mm
\textheight 225mm
\topmargin -10mm
\oddsidemargin 7mm
\evensidemargin 7mm
\pagestyle{empty}
\begin{document}
\def \bg #1 {\begin{tabular}{{#1}}}
\def \nd {\end{tabular}}
\begin{center}
{\large \bf INVBASE: A Package for Computing Involutive Bases}
\vskip 0.7cm
\noindent
A.Yu.Zharkov, Yu.A.Blinkov\\
Saratov University\\
Astrakhanskaya 83\\
410071 Saratov\\
Russia\\
Email: postmaster@scnit.saratov.su\\
\end{center}
\vspace{0.3cm}
\vskip 0.5cm
\section{Introduction}
Involutive bases are a new tool for solving problems in connection with
multivariate polynomials, such as solving systems of polynomial equations
and analyzing polynomial ideals, see \cite{Lille}. An involutive basis of
polynomial ideal is nothing but a special form of a redundant Gr\"obner
basis. The construction of involutive bases reduces the problem of solving
polynomial systems to simple linear algebra.\\
The INVBASE package
\footnote{The REDUCE implementation has been supported by
the Konrad-Zuse-Zentrum Berlin}
calculates involutive bases of polynomial ideals
using an algorithm described in \cite{Lille}
which may be considered as an alternative to
the well-known Buchberger algorithm \cite{Buch}.
The package can be used over
a variety of different coefficient domains, and for different variable
and term orderings.\\
The algorithm implemented in the INVBASE package is proved
to be valid for any zero-dimensional ideal (finite number of solutions)
as well as for positive-dimensional ideals in generic form. However,
the algorithm does not terminate for ``sparse'' positive-dimensional systems.
In order to stop the process we use the maximum degree
bound for the Gr\"obner bases of generic ideals in the total-degree
term ordering established in \cite{Laz}.
In this case, it is reasonable
to call the GROEBNER package with the answer of INVBASE as input
information in order to compute the reduced Gr\"obner basis under the
same variable and term ordering.\\
Though the INVBASE package supports computing involutive bases in any
admissible term ordering,
it is reasonable to compute them only for the total-degree term
orderings. The package includes a special algorithm for conversion
of total-degree involutive bases into the triangular bases
in the lexicographical term ordering that is desirable for
finding solutions. Normally the sum of timings for these two
computations is much less than the timing for direct computation
of the lexicographical involutive bases. As a rule, the result
of the conversion algorithm is a reduced Gr\"obner basis in the
lexicographical term ordering. However, because of some gaps in
the current version of the algorithm,
there may be rare situations when the resulting triangular set
does not possess the formal property of Gr\"obner bases.
Anyway, we recommend using the GROEBNER package with the result
of the conversion algorithm as input in order either to check
the Gr\"obner bases property or to transform the result into a
lexicographical Gr\"obner basis.
\section{The Basic Operators}
\subsection{Term Ordering}
The following term order modes are available:
$$ REVGRADLEX,\; GRADLEX,\; LEX $$
These modes have the same meaning as for the GROEBNER package.\\
All orderings are based on an ordering among the variables.
For each pair of variables an order relation $>$ must be defined,
e.g. $x>y$. The term ordering mode as well as the order of variables
are set by the operator
$$ INVTORDER\,,\{x_1,...,x_n\} $$
where $$ is one of the term order modes listed above.
The notion of $\{x_1,...,x_n\}$ as a list of variables
at the same time means $x_1>...>x_n$.
\vskip 0.1cm
\noindent
{\bf Example 1.}
$$ INVTORDER\>\,REVGRADLEX,\{x,y,z\} $$
sets the reverse graduated term ordering based on the variable
order $x>y>z$.\\
The operator $INVTORDER$ may be omitted. The default term order mode
is $REV\-GRADLEX$ and the default decreasing variable order is
alphabetical (or, more generally, the default REDUCE kernel order).
Furthermore, the list of variables in the $INVTORDER$ may be omitted.
In this case the default variable order is used.
\subsection{Computing Involutive Bases}
To compute the involutive basis of ideal generated by the set of
polynomials $\{p_1,...,p_m\}$ one should type the command
$$ INVBASE \> \{p_1,...,p_m\} $$
where $p_i$ are polynomials in variables listed in the
$INVTORDER$ operator. If some kernels in $p_i$ were not listed
previously in the $INVTORDER$ operator they are considered as
parameters, i.e. they are considered part of the coefficients of
polynomials. If $INVTORDER$ was omitted, all the kernels
in $p_i$ are considered as variables with the default REDUCE
kernel order.\\
The coefficients of polynomials $p_i$ may be integers as well as
rational numbers (or, accordingly, polynomials and rational functions
in the parametric case). The computations modulo prime numbers are
also available. For this purpose one should type the REDUCE commands
$$ ON \> MODULAR;\> SETMOD \> p; $$
where $p$ is a prime number.\\
The value of the $INVBASE$ function is a list of integer polynomials
$\{g_1,...,g_n\}$ representing an involutive basis of a given ideal.\\
\newpage
\noindent
{\bf Example 2.}
\begin{eqnarray*}
& & INVTORDER \> REVGRADLEX,\{x,y,z\}; \\
& & g:= INVBASE \> \{4*x**2 + x*y**2 - z + 1/4,\>
                     2*x + y**2*z + 1/2,\> \\
& &    x**2*z - 1/2*x - y**2 \};
\end{eqnarray*}
The resulting involutive basis in the reverse graduate ordering is
\begin{eqnarray*}
g := \{& & 8*x*y*z^3  - 2*x*y*z^2  + 4*y^3  - \\
& &  4*y*z^2 + 16*x*y + 17*y*z - 4*y,\\
& &  8*y^4  - 8*x*z^2  - 256*y^2  + 2*x*z + 64*z^2  - 96*x + 20*z - 9,\\
& &  2*y^3*z + 4*x*y + y,\\
& &  8*x*z^3  - 2*x*z^2  + 4*y^2  - 4*z^2 + 16*x + 17*z - 4,\\
& & - 4*y*z^3  - 8*y^3  + 6*x*y*z + y*z^2  - 36*x*y - 8*y,\\
& &  4*x*y^2  + 32*y^2  - 8*z^2  + 12*x - 2*z + 1,\\
& &  2*y^2*z + 4*x + 1,\\
& & - 4*z^3  - 8*y^2  + 6*x*z + z^2  - 36*x - 8,\\
& &  8*x^2  - 16*y^2  + 4*z^2  - 6*x - z \quad \}
\end{eqnarray*}
To convert it into a lexicographical Gr\"obner basis one should type
$$ h:=INVLEX\>g; $$
The result is
\begin{eqnarray*}
h :=\{& &3976*x + 37104*z^6 - 600*z^5 + 2111*z^4 +  \\
& &  122062*z^3 + 232833*z^2 - 680336*z + 288814,\\
& &  1988*y^2 - 76752*z^6 + 1272*z^5 - 4197*z^4 - \\
& &  251555*z^3 - 481837*z^2 + 1407741*z - 595666,\\
& &  16*z^7 - 8*z^6 + z^5 + 52*z^4 +
     75*z^3 - 342*z^2 + 266*z - 60 \quad \}
\end{eqnarray*}
In the case of ``sparse'' positive-dimensioned system
when the involutive basis in the sense of \cite{Lille} does not exist,
you get the error message $$ *****\> MAXIMUM \> DEGREE \> BOUND \>
EXCEEDED $$ The resulting list of polynomials which is not an involutive
basis is stored in the share variable INVTEMPBASIS. In this case
it is reasonable to call the GROEBNER package with the value of
INVTEMPBASIS as input under the same variable and term ordering.

\begin{thebibliography}{99}

\bibitem{Lille}
Zharkov A.Yu., Blinkov Yu.A. Involution Approach to Solving Systems
of Algebraic Equations. Proceedings of the IMACS '93, 1993, 11-16.

\bibitem{Buch}
Buchberger B. Gr\"obner bases: an Algorithmic Method in Polynomial
Ideal Theory. In: (Bose N.K., ed.) Recent Trends in Multidimensional
System Theory, Reidel, 1985.

\bibitem{Laz}
Lazard D. Gr\"obner Bases, Gaussian Elimination and Resolution of
Systems of Algebraic Equations. Proceedings of EUROCAL '83.
Lecture Notes in Computer Science 162, Springer 1983, 146-157.

\end{thebibliography}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbase.rlg0000644000175000017500000002235211527635055024310 0ustar  giovannigiovanniFri Feb 18 21:27:23 2011 run on win32

% *****  Example 1  *****

g:=invbase{4*x^2 + x*y^2 - z +1/4,
           2*x + y^2*z + 1/2,
           x^2*z - 1/2*x - y^2};


             3          2      3        2
g := {8*x*y*z  - 2*x*y*z  + 4*y  - 4*y*z  + 16*x*y + 17*y*z - 4*y,

         4        2        2               2
      8*y  - 8*x*z  - 256*y  + 2*x*z + 64*z  - 96*x + 20*z - 9,

         3
      2*y *z + 4*x*y + y,

           3        2      2      2
      8*x*z  - 2*x*z  + 4*y  - 4*z  + 16*x + 17*z - 4,

              3      3                2
       - 4*y*z  - 8*y  + 6*x*y*z + y*z  - 36*x*y - 8*y,

           2       2      2
      4*x*y  + 32*y  - 8*z  + 12*x - 2*z + 1,

         2
      2*y *z + 4*x + 1,

            3      2            2
       - 4*z  - 8*y  + 6*x*z + z  - 36*x - 8,

         2       2      2
      8*x  - 16*y  + 4*z  - 6*x - z}


h:=invlex g;


                      6        5         4           3           2
h := {3976*x + 37104*z  - 600*z  + 2111*z  + 122062*z  + 232833*z  - 680336*z

       + 288814,

            2          6         5         4           3           2
      1988*y  - 76752*z  + 1272*z  - 4197*z  - 251555*z  - 481837*z  + 1407741*z

       - 595666,

          7      6    5       4       3        2
      16*z  - 8*z  + z  + 52*z  + 75*z  - 342*z  + 266*z - 60}



% *****  Example 2  *****

on trinvbase$


invtorder revgradlex,{x,y,z}$



g:=invbase{x^3 + y^2 + z - 3,
           y^3 + z^2 + x - 3,
           z^3 + x^2 + y - 3};



---------- ORDER = 3 ----------


---------- ORDER = 4 ----------


---------- ORDER = 5 ----------


---------- ORDER = 6 ----------


---------- ORDER = 7 ----------


reductions = 77  zeros = 11  maxord = 7  order = 7  length = 13


D i m e n s i o n  =  0

N u m b e r  o f  s o l u t i o n s  =  27

       2  2  3      2  2      2      2  2        2    2          2      2
g := {x *y *z  - 3*x *y  - x*y *z - x *z  + x*y*z  + x *y + 3*x*y  + 3*x

                  2
       - 3*x*y + y  + z - 3,

       2    3    2  2      2                2    2
      x *y*z  + x *y  - 3*x *y - x*y*z + x*z  + x  + 3*x*y - 3*x,

         2  3        2    2        2      2    2            2
      x*y *z  - 3*x*y  - y *z - x*z  + y*z  - x  + x*y + 3*y  + 3*x - 3*y,

       2  3    2  2      2    2
      x *y  + x *z  - 3*x  - y  - z + 3,

       2  3    2        2      2
      x *z  + x *y - x*y  - 3*x  - x*z + 3*x,

           3      2                  2
      x*y*z  + x*y  - 3*x*y - y*z + z  + x + 3*y - 3,

       2  3    2  2      2    2
      y *z  + x *y  - 3*y  - z  - x + 3,

         3      2    2
      x*y  + x*z  + x  - 3*x,

         3          2
      x*z  + x*y - y  - 3*x - z + 3,

         3    2      2
      y*z  + x *y + y  - 3*y,

       3    2
      x  + y  + z - 3,

       3    2
      y  + z  + x - 3,

       3    2
      z  + x  + y - 3}


h:=invlex g;


h := { - 412373224241856640945111992285148*x

                                          26
       - 1449641911307232269543863070491*z

                                          25
       - 2168612583844782211565651535007*z

                                          24
       - 2847785553349083352614138977565*z

                                           23
       + 35576725674692081471990149502410*z

                                           22
       + 54428253744724168431241789131696*z

                                           21
       + 72399213723404842594731673129040*z

                                            20
       - 367271934803243933721304377312611*z

                                            19
       - 577412401939211224792461395441215*z

                                            18
       - 752437808233499373488146484648759*z

                                             17
       + 2023265153056028087298524971059780*z

                                             16
       + 3362763223678472034221124579531852*z

                                             15
       + 4206754352383617663824252489277347*z

                                             14
       - 6294684651757967009725536832231313*z

                                              13
       - 11645937803380007452970955449190202*z

                                              12
       - 13912359441969785881761771576274650*z

                                              11
       + 10813944944367254864931915957111635*z

                                              10
       + 24146769890624467199683669920316403*z

                                              9
       + 28253894162862384778437975597863994*z

                                             8
       - 9413195341759783675090699662838024*z

                                              7
       - 28732526014615244592092156992897700*z

                                              6
       - 34274801170918929476253738727746640*z

                                             5
       + 3129736563440111416048255862484824*z

                                              4
       + 17956474721641990844572020234799903*z

                                              3
       + 21526113174342847360723274047268152*z

                                            2
       + 795762450545743140366490379212137*z

       - 6078501600786528783018721470971548*z

       - 3909915395631179340911139035268300,

       - 412373224241856640945111992285148*y

                                          26
       + 3680069960199680647552580014011*z

                                          25
       + 4946533576928304373640222248439*z

                                          24
       + 6522058320833813074018729716109*z

                                           23
       - 91123955793021263648983859056246*z

                                            22
       - 122860148727246593163920662895892*z

                                            21
       - 161652285275223157884596590612424*z

                                            20
       + 962753147411097965886678769071203*z

                                             19
       + 1303906344577106971108666976068347*z

                                             18
       + 1646174502798616879170351863301227*z

                                             17
       - 5539016636709239326199213127901604*z

                                             16
       - 7732787650045519336370661934943044*z

                                             15
       - 9110016144563661988538140239320223*z

                                              14
       + 18612337918090152097453612706753413*z

                                              13
       + 27965492180063505085033283788513066*z

                                              12
       + 30440317356106139389125602029763822*z

                                              11
       - 36863224004805998790098755360970471*z

                                              10
       - 62542906673581589636380853858043447*z

                                              9
       - 64689461678563738668073440578715518*z

                                              8
       + 42623160090556250860454187465583768*z

                                              7
       + 83548043234053149543179359124170180*z

                                              6
       + 85865493477306743665317502795142584*z

                                              5
       - 27434780477528021937653276615015928*z

                                              4
       - 61602505785524913541319871156904287*z

                                              3
       - 62515628463318116801915981996829328*z

                                             2
       + 5925778048881538700551831705942583*z

       + 24088990130824351149845277501309728*z

       + 15820742036151533576971241715895080,

          27       24        21       19         18       17        16
       - z   + 27*z   - 317*z   + 18*z   + 2067*z   + 50*z   - 279*z

               15        14         13          12         11         10
       - 8156*z   - 645*z   + 1674*z   + 20359*z   + 3044*z   - 4645*z

                9         8         7          6         5         4          3
       - 33644*z  - 6288*z  + 6388*z  + 36936*z  + 5925*z  - 4957*z  - 23187*z

               2
       - 4063*z  + 4342*z + 5352}


 
% *****  Example 3 (limited by the degree bound)  *****

invtorder revgradlex,{x,z,y,t}$



k:=5$



on errcont$



invbase{x^(k+1)-y^(k-1)*z*t, 
         x*z^(k-1)-y**k, 
         x^k*y-z^k*t};



---------- ORDER = 6 ----------


---------- ORDER = 7 ----------


---------- ORDER = 8 ----------


---------- ORDER = 9 ----------


---------- ORDER = 10 ----------


---------- ORDER = 11 ----------


---------- ORDER = 12 ----------


---------- ORDER = 13 ----------


---------- ORDER = 14 ----------


---------- ORDER = 15 ----------


---------- ORDER = 16 ----------


---------- ORDER = 17 ----------


---------- ORDER = 18 ----------


---------- ORDER = 19 ----------


---------- ORDER = 20 ----------


---------- ORDER = 21 ----------


***** Maximum degree bound exceeded. 


invtempbasis;


       17    2  16
{ - t*z   + x *y  ,

       13    3  11
  - t*z   + x *y  ,

       9    4  6
  - t*z  + x *y ,

       4      6
  - t*y *z + x ,

       5    5
  - t*z  + x *y,

    4    5
 x*z  - y }


end$


Time for test: 16 ms
@@@@@ Resources used: (0 0 9 1)
mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbase.tst0000644000175000017500000000102511526203062024314 0ustar  giovannigiovanni
% *****  Example 1  *****

g:=invbase{4*x^2 + x*y^2 - z +1/4,
           2*x + y^2*z + 1/2,
           x^2*z - 1/2*x - y^2};

h:=invlex g;


% *****  Example 2  *****

on trinvbase$
invtorder revgradlex,{x,y,z}$

g:=invbase{x^3 + y^2 + z - 3,
           y^3 + z^2 + x - 3,
           z^3 + x^2 + y - 3};

h:=invlex g;

 
% *****  Example 3 (limited by the degree bound)  *****

invtorder revgradlex,{x,z,y,t}$

k:=5$

on errcont$

invbase{x^(k+1)-y^(k-1)*z*t, 
         x*z^(k-1)-y**k, 
         x^k*y-z^k*t};

invtempbasis;

end$

mathpiper-0.81f+svn4469+dfsg3/src/packages/invbase/invbcomp.red0000644000175000017500000005041211526203062024446 0ustar  giovannigiovannimodule invbcomp;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%----------------------------------------------------------------------
symbolic proceDURE C_ZERO();  nil$           %  REPRESENTATION OF ZERO
%----------------------------------------------------------------------
symbolic procedure CNEG(C);                  %  - C
negf c$
%----------------------------------------------------------------------
symbolic procedure CSUM(C1,C2);              %   C1 + C2
addf(c1,c2);
%----------------------------------------------------------------------
symbolic procedure CPROD(C1,C2);             %   C1 * C2
multf(c1,c2);
%----------------------------------------------------------------------
symbolic procedure CDIV(C1,C2);               %   C1/C2
numr resimp(c1 . c2);
%----------------------------------------------------------------------
symbolic procedure trass(id,value);  % tracing of assignments
<< terpri(); write id; write " = "; write value; terpri(); >>$
%----------------------------------------------------------------------
symbolic procedure leftzeros(u);  % u : list
if null u or car u neq 0 then 0 else 1 #+ leftzeros cdr u$
%----------------------------------------------------------------------
procedure class(jet);
if ord jet = 0 then 0 else 1
#+ leftzeros reverse (if ordering = 'lex then jet else cdr jet);
%----------------------------------------------------------------------
symbolic procedure ord(jet);
if ordering = 'lex then eval('plus . jet) else car jet$
%----------------------------------------------------------------------
symbolic procedure ljet(p); caar p$
%----------------------------------------------------------------------
symbolic procedure sub01(v,u);
%%% replace each x in u by < if x=v then 1 else 0 >
if u then (if (car u = v) then 1 else 0) . sub01(v,cdr u);
%----------------------------------------------------------------------
symbolic procedure !*v2j(v);
if ordering = 'lex then sub01(v,varlist) else (1 . sub01(v,varlist) );
%----------------------------------------------------------------------
symbolic procedure nonmult(cl);  % --> list of vjets
reverse cdr member(nth(reverse vjets,cl),reverse vjets);
%----------------------------------------------------------------------
symbolic procedure insert(x,gg);
begin scalar gg1;
   while gg and dless(cdr x,cdar gg) do
   << gg1 := car gg . gg1; gg := cdr gg >>;
   return append(reversip gg1, x . gg);
end;
%----------------------------------------------------------------------
symbolic procedure addnew(f,ind,ff);
%%% adds element f to set (with index ind), returns modified ff
<< putv(gv,ind,f); putv(bv,ind,t);
   if null f then ff
   else ff := insert(ind . ljet f, ff)
>>$
%----------------------------------------------------------------------
symbolic procedure dlesslex(D1,D2);
%%%%  RETURNS T IF D1 < D2 (lex), NIL OTHERWISE
IF NULL D1 THEN NIL ELSE
IF CAR D1 #> CAR D2 THEN NIL ELSE
IF CAR D1 #< CAR D2 THEN T ELSE dlesslex(CDR D1,CDR D2);
%----------------------------------------------------------------------
symbolic procedure dless(d1,d2);   % --> T if d1 < d2 , NIL otherwise
if ordering = 'lex then dlesslex(d1,d2) else
if car d1 #< car d2 then t else if car d1 #> car d2 then nil
else if ordering = 'glex then dlesslex(cdr d1,cdr d2)
else if ordering = 'grev then dlesslex(reverse cdr d2, reverse cdr d1);
%-----------------------------------------------------------------------
symbolic procedure DDMULT(D1,D2);
IF NULL D1 THEN NIL ELSE (CAR D1 #+ CAR D2) . DDMULT(CDR D1,CDR D2);
%-----------------------------------------------------------------------
symbolic procedure DQUOT(D2,D1);
%%%%  RETURNS D2-D1 IF D1 DIVIDES D2, NIL OTHERWISE
BEGIN SCALAR D3; INTEGER N;
L1:N:=CAR(D2)-CAR(D1);
   IF N #< 0 THEN RETURN NIL;
   D3:=N . D3;
   D1:=CDR D1; D2:=CDR D2;
   IF D1 THEN GOTO L1;
   RETURN REVERSIP D3;
end;
%-----------------------------------------------------------------------
symbolic procedure PCMULT(P,C);              %  P*C  (C IS NOT ZERO)
FOR EACH X IN P COLLECT CAR X.CPROD(C,CDR X);
%-----------------------------------------------------------------------
symbolic procedure pcdiv(p,c);               %  P/C  (division in ring)
for each x in p collect car x . cdiv(cdr x,c);
%-----------------------------------------------------------------------
symbolic procedure PDMULT(P,D);              %  P*< D >
FOR EACH X IN P COLLECT
 (FOR EACH Y IN PAIR(CAR X,D) COLLECT CAR(Y)#+CDR(Y)).CDR X$
%-----------------------------------------------------------------------
symbolic procedure PSUM(P1,P2);              %  P1 + P2
BEGIN SCALAR T1,T2,D2,C3,P3,SUM,RET;
   IF NULL P1 THEN SUM:=P2 ELSE
   IF NULL P2 THEN SUM:=P1 ELSE
   WHILE P2 AND NOT RET DO
   << T2:=CAR P2; D2:=CAR T2;
      WHILE P1 AND DLESS(D2,CAAR P1) DO
      << P3:=CAR(P1).P3; P1:=CDR P1 >>;
      IF NULL P1 THEN
      << SUM:=APPEND(REVERSE P3,P2); RET:=T >> ELSE
      << T1:=CAR P1;
         IF D2=CAR T1 THEN                     %%%%  NOW T1<=T2
         << C3:=CSUM(CDR T1,CDR T2);           %%%%  LIKE TERM
            IF C3 neq C_ZERO() THEN P3:=(D2.C3).P3;
            P1:=CDR P1;
            T1:=IF P1 THEN CAR P1;              %%%%  NEW T1
         >>
         ELSE P3:=T2.P3;                        %%%%  OLD T1
         P2:=CDR P2;                            %%%%  NEW T2
         IF NULL P2 THEN SUM:= APPEND(REVERSE P3,P1)
   >> >>;
   RETURN SUM
end;
%-----------------------------------------------------------------------
symbolic procedure PNEG(P);                  %  - P
FOR EACH X IN P COLLECT CAR(X).CNEG(CDR(X));
%-----------------------------------------------------------------------
symbolic procedure PDIF(P1,P2);              %  P1 - P2
PSUM(P1,PNEG P2);
%-----------------------------------------------------------------------
symbolic procedure DD(D1,D2);   %  uses fluid VJETS
begin scalar dq,lz;
   dq:=dquot(d2,d1);
   if not dq then return if dless(d1,d2) then 1  % D1 < D2
                                         else 0; % D1 > D2
   if ordering neq 'lex then dq:=cdr dq;
   lz := leftzeros dq;
   return
   if not nc and not(lz #< length varlist #- class d1)
      then 3   % D1 divides D2 (mult.)
   else if nc and not(lz #< length varlist #- nc)
      then 4   % D1 divides D2 in 1:nc classes and coincides in others
      else 2;  % D1 divides D2 (usual)
end;
%-----------------------------------------------------------------------
symbolic procedure dlcm(d1,d2);
if ordering='lex then for each x in pair(d1,d2) collect max(car x,cdr x)
else addgt( for each x in pair(cdr d1,cdr d2) collect max(car x,cdr x));
%-----------------------------------------------------------------------
symbolic procedure NF(H,GG,sw);
%%%%  H = NORMALIZED POLYNOMIAL
%%%%  GG = LIST OF KEYED LPP'S OF GG-SET
%%%%  RETURNS NORMAL FORM OF H WITH RESPECT TO GG-SET
%%%%  ===============================================
IF NULL GG THEN H ELSE
BEGIN SCALAR F,LPF,g,c,cf,cg,NF,G1,G2,U,nr; nr:=0;
   F:=H; G1:=GG;
NEXTLPF: IF NULL F THEN goto EXIT;
   LPF:=caar F;

%  diminish G1 so that LPF >= G1 (and might be reduced !)
%  ------------------------------------------------------
   WHILE NOT NULL G1 AND DLESS(LPF,CDAR G1) DO G1:=CDR G1;
   IF NULL G1 THEN goto EXIT;
   G2:=G1;                                     % NOW LPF >= G2

%  reduction of LPF
%  ----------------
   WHILE G2 AND DD(CDAR G2,LPF) #< sw + 2 DO G2:=CDR G2;

   IF NULL G2 THEN                             % LPF NOT REDUCED
   ( if redtails then << NF:=(LPF.CDAR F).NF; F:=CDR F >>
     else goto EXIT )
   ELSE                                        % REDUCTION OF LPF
   << G:=getv(gv,caar g2);
      C:=gcdf!*(cdar F, cdar G);
      cf:=cdiv(cdar f,c); cg:=cdiv(cdar g,c);
      f:=pcmult(f,cg); nf:=pcmult(nf,cg); g:=pcmult(g,cf);
      U:=PDMULT(CDR G, DQUOT(LPF,CDAR G2));
      if tred then
      << terpri();
         write "r e d u c t i o n :  ",lpf,"/",cdar g2;
         terpri();
      >>;
      if stars then write "*";
      nr := nr #+ 1;
      F:=PDIF(CDR F,U);
   >>;
   GOTO NEXTLPF;
EXIT:
   reductions := reductions #+ nr;
   nforms := nforms #+ 1;
   u:= gcdout append(reversip nf,f);
   if null u then zeros := zeros #+ 1;
   return u;
end;
%-----------------------------------------------------------------------
symbolic procedure gcdout(p);
   % cancel coeffs of P by their common factor.
if !*modular then p else
if null p then nil else if ord ljet p = 0 then p else
begin scalar c,p1;
   p1:=p; c:=cdar p1;
   while p1 and c neq 1 do << c:=gcdf!*(c,cdar p1); p1:=cdr p1 >>;
   return if c = 1 then p else pcdiv(p,c);
end;
%-----------------------------------------------------------------------
expr PROCEDURE NEWBASIS(gg,sw)$
%%%% SIDE EFFECT:   CHANGES CDR'S OF GV(K);
BEGIN SCALAR G1,G2;
   G1:=reverse GG;
   WHILE G1 DO
   << PUTV(GV,caar g1,NF(GETV(GV,caar g1),G2,sw));
      g2:=(car g1).g2; g1:=cdr g1;
   >>;
END$
%-----------------------------------------------------------------------
symbolic procedure !*f2di(f,varlist);
%%% f: st.f., varlist: kernel list --> f in distributive form
if null f then nil else
if domainp f then
((addgt for each v in varlist collect 0).(f)).nil else
psum(if member(mvar f,varlist) then
     pdmult(!*f2di(lc f,varlist),
            addgt for each v in varlist collect
            if v = mvar f then ldeg f else 0
           )
     else  pcmult(!*f2di(lc f,varlist),((lpow f.1).nil)),
     !*f2di(red f,varlist)  );
%-----------------------------------------------------------------------
symbolic procedure !*di2q0(p,varlist);
if null p then nil . 1 else
addsq( (lambda s,u;
        << for each x in u do
          if cdr x neq 0 then s:=multsq(s,((x.1).nil).1);
          s  >>
       ) (cdar p, pair(varlist,
                       if ordering='lex then ljet p else cdr ljet p)),
       !*di2q0(cdr p,varlist) );
%----------------------------------------------------------------------
symbolic procedure !*di2q(p,varlist);
!*di2q0(for each x in p collect car x . (cdr x . 1), varlist);
%----------------------------------------------------------------------
symbolic procedure show(str,p);  % p = poly in a special (dist.) form
if null p then (algebraic write str," := 0")
else algebraic write str," := ",
lisp prepsq !*di2q(list car p, varlist)," + ",
lisp prepsq !*di2q(cdr p, varlist);
%----------------------------------------------------------------------
LISP procedure ADDGT(U);
if ordering = 'lex then u else eval('plus.u) . u$
%-----------------------------------------------------------------------
symbolic procedure printsys(str,gg);
begin scalar i; i:=0;
   for each x in gg do
   << i:=i+1;
      algebraic write str,"(",lisp i,") := ",
      lisp prepsq !*di2q(list car getv(gv,car x), varlist)," + ",
      lisp prepsq !*di2q(cdr getv(gv,car x), varlist);
   >>;
end;
%-----------------------------------------------------------------------
symbolic procedure answer(gg);
<< if title then algebraic write "% ",lisp title;
   trass("% ORDERING",varlist); printsys("G",reverse gg);
>>$
%-----------------------------------------------------------------------
symbolic procedure wr(file,gg);
<< off nat,time; out file;
   write "algebraic$"; write "operator g$";
   answer(gg);
   write "end;"; shut file; on nat,time >>$
%-----------------------------------------------------------------------
symbolic procedure invtest!*();
begin scalar g,c; c:=t;
   if !*trinvbase then terpri();
   for each x in gg do
   if c then
   << g:=getv(gv, car x);
      for each vj in nonmult(class ljet g) do
      if c and nf(pdmult(g,vj),gg,1) then
      << c:=nil;
         if !*trinvbase then prin2t "INV - t e s t  f a i l e d"; >>;
   >>;
   if c and !*trinvbase then prin2t "I n v o l u t i v e  b a s i s";
   return c;
end;
%-----------------------------------------------------------------------
symbolic procedure redall(gg,ff,sw);
   % side effect : changes flag thirdway.
begin scalar rr,f,f1,lj,k,new;
   rr := ff; thirdway:=shortway:=nil; new:=t;
   while rr do
   << f:=car reverse rr; rr:=delete(f,rr);
      k:=car f; f1:=getv(gv,k);
      if path then
      << % write k,": ";
         if new then write ljet f1," ==> "
         else write ljet f1," --> ";
      >>;
      f:=putv(gv,k,nf(f1,gg,sw));
      lj:=if f then ljet f else 0;
      if path then
      << write lj; terpri() >>;
      if null f then  nil else
      if ord lj = 0 then conds := f . conds  else
      << if ljet f neq ljet f1 then shortway:=t;
         if not new and f neq f1 then thirdway:=t;
         for each x in gg do if dd(lj,cdr x) >= sw + 2  then
         << gg:=delete(x,gg); rr:=insert(x,rr);
            putv(bv,car x,t); %
         >>;
         gg:=insert(k.lj,gg); new:=nil;
   >> >>;
   return gg;
end;
%-----------------------------------------------------------------------
symbolic procedure remred(ff,sw);  % removes redundant elements
begin scalar gg,gg1,f,g,p;
   ff:=reverse ff;
   while ff do
   << f:=car ff; ff:=cdr ff;
      p:=t; gg1:=gg;
      while p and gg1 do
      << g:=car gg1; gg1:=cdr gg1;
         if dd(cdr g,cdr f) >= sw + 2  then p:=nil;
      >>;
      if p then gg := f . gg;
   >>;
   return gg;
end;
%-----------------------------------------------------------------------
symbolic procedure invbase!*();
begin scalar gg1,g,k,nm,f,thirdway,shortway,fin,p,p0,lb,r;
   if !*trinvbase then terpri();
   p:=maxord:=-1;
   if path then terpri();
   gg:=redall(nil,gg,1);
   newbasis(gg,1);
   lb:=0;
   for each x in gg do lb:=lb + ord cdr x;
   lb:=lb + length varlist - 1;
l: gg1 := reverse gg;
   while gg1 and null getv(bv,caar gg1) do gg1 := cdr gg1;
   if gg1 then
   << if cadar gg1 = cadar gg then
      << p0:=p;
         p:=cadar gg1;
         if !*trinvbase and p > p0 then
         << terpri();
            write "---------- ORDER = ",cadar gg," ----------";
            terpri(); terpri();
         >>;
         if p > lb then
         << gg:=redall(nil,gg,0);
            newbasis(gg,0);
            invtempbasis := 'list .
                for each x in gg
                   collect 'plus . for each m in getv(gv,car x)
                      collect prepsq !*di2q(list m,varlist);
            rederr "Maximum degree bound exceeded.";
         >>;
         maxord:=max(maxord,cadar gg);
         if cadar gg < maxord then fin:=t;
      >>;
      if fin then goto m;
      k := caar gg1;
      g := getv(gv,k); putv(bv,k,nil);
      nm := nonmult(class ljet g);
      for each vj in nm do
      << ng := ng + 1;
         f := pdmult(g,vj); putv(gv,ng,f); putv(bv,ng,t);
         gg := redall(gg,list(ng.ljet f),1);
         if thirdway then newbasis(gg,1) else
         if shortway then for each y in gg do if car y neq ng then
         putv(gv,car y,nf(getv(gv,car y),list(ng.ljet getv(gv,ng)),1));
      >>;
      go to l;
   >>;
   m: stat(); if p <= lb then dim gg;
end;
%-----------------------------------------------------------------------
symbolic procedure njets(n,q);   % number of jets of n vars and order q
combin(q,q+n-1);
%----------------------------------------------------------------------
symbolic procedure combin(m,n);    % number of combinations of m from n
if m>n then 0 else
begin integer i1,i2; i1:=i2:=1;
   for i:=n-m+1:n do i1:=i1*i; for i:=1:m do i2:=i2*i;
   return i1/i2;
end;
%----------------------------------------------------------------------
symbolic procedure dim(gg);
if !*trinvbase then
begin integer q,n,cl,s,y,dim,dp,mon;
   q:=cadar gg; n:=length varlist; dim:=0;
   for i:=1:n do putv(beta,i,0);
   for each x in gg do
   << cl:=class cdr x;
      for i:=cl step -1 until 1 do
      << y:=njets(cl-i+1,q-ord cdr x);
         putv(beta,i,getv(beta,i)+y);
   >> >>;
   terpri();
   for i:=1:n do
   << putv(alfa,i,combin(n-i,q+n-i)-getv(beta,i));
      if getv(alfa,i) neq 0 then dim := dim + 1;
      % write "a[",i,",",q,"]=",getv(alfa,i)," ";
   >>;
   terpri();
   terpri(); write "D i m e n s i o n  =  ",dim; terpri();
   if dim = 0 then nroots gg;
end;
%----------------------------------------------------------------------
symbolic procedure nroots(gg);
   % number of roots of zero-dimensional Ideal.
if gg then begin integer d;
   for each x in gg do d := d + car reverse x;
   terpri(); write "N u m b e r  o f  s o l u t i o n s  =  ",d;
   terpri();
end;
%----------------------------------------------------------------------
symbolic procedure stat();
if !*trinvbase then
<< terpri();
   write "reductions = ",reductions;
   write "  zeros = ",zeros;     write "  maxord = ",maxord;
   write "  order = ",cadar gg;  write "  length = ",length gg;
>>$
%----------------------------------------------------------------------
symbolic procedure !*g2lex(p);
   % works correctly only when ORDERING= lex.
   %%% p: poly in graduate form ---> lexicographic form
begin scalar p1;
   for each x in p do p1:=psum(p1,list(cdar x . cdr x));
   return p1;
end;
%----------------------------------------------------------------------
symbolic procedure lexorder(lst);
   % works correctly only when ORDERING = lex.
begin scalar lst1,lj;
   for each x in lst do
   << lj:=ljet putv(gv, car x, gcdout !*g2lex getv(gv,car x));
      lst1 := insert((car x).lj, lst1);
   >>;
   return lst1;
end;
%----------------------------------------------------------------------
symbolic procedure gi(gg,i);  % subsystem of GG of class = i
begin scalar ff;
   for each x in gg do if class cdr x = i then ff := x . ff;
   return ff;
end;
%----------------------------------------------------------------------
symbolic procedure monic(jet,cl);  % for lexicoraphy only
begin scalar u,n;
   jet:=reverse jet;
   n:=length varlist;
   for i:=1:n do if i neq cl then u:=nth(jet,i).u;
   return u = for each v in cdr varlist collect 0$
end;
%----------------------------------------------------------------------
symbolic procedure monicmember(gg,cl);
begin scalar p;
l: if null gg then return nil;
   if monic(cdar gg,cl) then return t;
   gg:=cdr gg;
   go to l;
end;
%----------------------------------------------------------------------
symbolic procedure montest(gg);
begin scalar p,n;
   p:=t;
   n:=length varlist;
   for i:=1:n do if not monicmember(gg,i) then << p:=nil; i:=n+1 >>;
   return p;
end;
%----------------------------------------------------------------------
symbolic procedure invlex!*();  % side effect: changes GG
begin scalar gi,n,gginv,ordering;
   n:=length varlist; gginv:=mkvect n;
   ordering:='lex;
   for i:=1:n do putv(gginv,i,lexorder gi(gg,i));
   gg:=nil;
   for i:=1:n do
   << nc:=i;
      if path then << trass("i",i); terpri() >>;
      gg:=redall(gg,getv(gginv,i),2);
      if montest gg then i:=n+1;
   >>;
   nc:=nil;
   gg:=remred(gg,0);
   newbasis(gg,0);
end;
%----------------------------------------------------------------------
symbolic procedure readsys(elist,vlist);
begin;
   varlist:=cdr vlist;
   ng:=reductions:=nforms:=zeros:=0;
   alfa:=mkvect length varlist;
   beta:=mkvect length varlist;
   gg:=nil;
   for each x in cdr elist do
   gg:=addnew(gcdout !*f2di(numr simp x, varlist), ng:=ng+1, gg);
   vjets:=for each v in varlist collect !*v2j(v);
end;
%-----------------------------------------------------------------------
lisp operator readsys$
%-----------------------------------------------------------------------

%        D E F A U L T  V A L U E S
% ======================================================================
  ordering:='grev$ redtails:=t$
  tred := path := stars := nil$
% ======================================================================

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/0000755000175000017500000000000011722677355021650 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arnum.rlg0000644000175000017500000001517611527635055023504 0ustar  giovannigiovanniFri Feb 18 21:27:18 2011 run on win32
% Test of algebraic number package.

defpoly sqrt2**2-2;



1/(sqrt2+1);


sqrt2 - 1


(x**2+2*sqrt2*x+2)/(x+sqrt2);


x + sqrt2


on gcd;



(x**3+(sqrt2-2)*x**2-(2*sqrt2+3)*x-3*sqrt2)/(x**2-2);


  2
 x  - 2*x - 3
--------------
  x - sqrt2


off gcd;



sqrt(x**2-2*sqrt2*x*y+2*y**2);


abs(x - sqrt2*y)


off arnum;

  %to start a new algebraic extension.


defpoly cbrt5**3-5;



on rationalize;



1/(x-cbrt5);


  2                  2
 x  + cbrt5*x + cbrt5
-----------------------
         3
        x  - 5


off rationalize;



off arnum;

  %to start a new algebraic extension.


%The following examples are taken from P.S. Wang Math. Comp. 30,
%    134,(1976),p.324.

on factor;



defpoly i**2+1=0;



w0 := x**2+1;


w0 := (x + i)*(x - i)


w1 := x**4-1;


w1 := (x + i)*(x - i)*(x + 1)*(x - 1)


w2 := x**4+(i+2)*x**3+(2*i+5)*x**2+(2*i+6)*x+6;


        2
w2 := (x  + i*x + 3)*(x + i + 1)*(x - (i - 1))


w3 := (2*i+3)*x**4+(3*i-2)*x**3-2*(i+1)*x**2+i*x-1;


                  2              2     2        3
w3 := (2*i + 3)*(x  + i*x - 1)*(x  - (----*i - ----))
                                       13       13


off arnum;




defpoly a**2-5;



w4 := x**2+x-1;


            1       1          1       1
w4 := (x + ---*a + ---)*(x - (---*a - ---))
            2       2          2       2


off arnum;




defpoly a**2+a+2;



w5 := x**4+3*x**2+4;


w5 := (x + a + 1)*(x + a)*(x - (a + 1))*(x - a)


off arnum;




defpoly a**3+2=0;



w6:=64*x**6-4;


           2    1         1   2    2    1         1   2        1           1
w6 := 64*(x  + ---*a*x + ---*a )*(x  - ---*a*x + ---*a )*(x + ---*a)*(x - ---*a)
                2         4             2         4            2           2


off arnum;




defpoly a**4+a**3+a**2+a+1=0;



w7:=16*x**4+8*x**3+4*x**2+2*x+1;


w7 := 

         1   3    1   2    1       1         1   3        1   2        1
16*(x + ---*a  + ---*a  + ---*a + ---)*(x - ---*a )*(x - ---*a )*(x - ---*a)
         2        2        2       2         2            2            2


off arnum, factor;




defpoly sqrt5**2-5,cbrt3**3-3;


*** Defining polynomial for primitive element:

  6        4       3        2
a1  - 15*a1  - 6*a1  + 75*a1  - 90*a1 - 116



cbrt3**3;


3


sqrt5**2;


5


cbrt3;


     120     5     27     4    2000    3    1170    2    6676        6825
 - (------*a1  + ------*a1  - ------*a1  - ------*a1  + ------*a1 - ------)
     8243         8243         8243         8243         8243        8243


sqrt5;


 120     5     27     4    2000    3    1170    2    14919        6825
------*a1  + ------*a1  - ------*a1  - ------*a1  + -------*a1 - ------
 8243         8243         8243         8243         8243         8243


sqrt(x**2+2*(sqrt5-cbrt3)*x+5-2*sqrt5*cbrt3+cbrt3**2);


         240     5     54     4    4000    3    2340    2    21595        13650
abs(x + ------*a1  + ------*a1  - ------*a1  - ------*a1  + -------*a1 - -------
         8243         8243         8243         8243         8243         8243

)


on rationalize;



1/(x+sqrt5-cbrt3);


  5     240     5     54     4    4000    3    2340    2    21595        13650
(x  - (------*a1  + ------*a1  - ------*a1  - ------*a1  + -------*a1 - -------)
        8243         8243         8243         8243         8243         8243

   4
 *x  - 

   108     5    800     4    1800    3    15433    2    15900        14465    3
 (------*a1  - ------*a1  - ------*a1  + -------*a1  + -------*a1 + -------)*x
   8243         8243         8243         8243          8243         8243

       3           2
  - (a1  - 15*a1)*x  - 

   900     5    3919    4    15000    3    8775    2    148986        154225
 (------*a1  - ------*a1  - -------*a1  - ------*a1  + --------*a1 - --------)*x
   8243         8243         8243          8243          8243          8243

      1919    5    1050    4    18245    3    12528    2    236725        73080
  - (------*a1  + ------*a1  - -------*a1  - -------*a1  + --------*a1 - -------
      8243         8243         8243          8243           8243         8243

          6       4      3       2
     ))/(x  - 15*x  - 6*x  + 75*x  - 90*x - 116)


off arnum, rationalize;




split_field(x**3+2);


*** Splitting field is generated by:

  6
a3  + 108


  1     4    1
{----*a3  + ---*a3,
  36         2

     1     4
  - ----*a3 ,
     18

  1     4    1
 ----*a3  - ---*a3}
  36         2


for each j in ws product (x-j);


 3
x  + 2


split_field(x**3+4*x**2+x-1);


*** Splitting field is generated by:

  3       2
a4  + 4*a4  + a4 - 1


      2                  2
{a4,a4  + 3*a4 - 2, - (a4  + 4*a4 + 2)}


for each j in ws product (x-j);


 3      2
x  + 4*x  + x - 1


split_field(x**3-3*x+7);


*** Splitting field is generated by:

  6        4        2
a6  - 18*a6  + 81*a6  + 1215


   1     4    5     2    1        2
{-----*a6  - ----*a6  + ---*a6 + ---,
  126         42         2        7

      1     4    5     2    4
  - (----*a6  - ----*a6  + ---),
      63         21         7

   1     4    5     2    1        2
 -----*a6  - ----*a6  - ---*a6 + ---}
  126         42         2        7


for each j in ws product (x-j);


 3
x  - 3*x + 7


split_field(x**3+4*x**2+x-1);


*** Splitting field is generated by:

  3       2
a7  + 4*a7  + a7 - 1


      2                  2
{a7,a7  + 3*a7 - 2, - (a7  + 4*a7 + 2)}


for each j in ws product (x-j);


 3      2
x  + 4*x  + x - 1


split_field(x**3-x**2-x-1);


*** Splitting field is generated by:

  6       5       4        3        2
a9  - 6*a9  + 7*a9  + 12*a9  - 17*a9  - 6*a9 + 53


      3     4    3     3    1     2    5         17
{ - (----*a9  - ----*a9  - ----*a9  - ----*a9 + ----),
      76         19         38         38        76

  3     4    6     3    1     2    14        17
 ----*a9  - ----*a9  - ----*a9  + ----*a9 + ----,
  38         19         19         19        38

      3     4    3     3    1     2    33        59
  - (----*a9  - ----*a9  - ----*a9  + ----*a9 - ----)}
      76         19         38         38        76


for each j in ws product (x-j);


 3    2
x  - x  - x - 1


% A longer example.

off arnum;



defpoly a**6+3*a**5+6*a**4+a**3-3*a**2+12*a+16;



factorize(x**3-3);


       1   5    1   4    2   3    1   2    2       7
{{x + ---*a  + ---*a  + ---*a  - ---*a  + ---*a + ---,1},
       6        3        3        6        3       3

        1    5    1    4    1   3    7    2    11       4
 {x - (----*a  + ----*a  + ---*a  - ----*a  + ----*a + ---),1},
        12        12        6        12        12       3

        1    5    1   4    1   3    5    2    1
 {x - (----*a  + ---*a  + ---*a  + ----*a  - ---*a + 1),1}}
        12        4        2        12        4


end;


Time for test: 31 ms
@@@@@ Resources used: (0 0 9 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arinv.red0000644000175000017500000001470311526203062023446 0ustar  giovannigiovannimodule arinv;   % Routines for inversion of algebraic numbers.

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(dmode!*);

global '(arbase!* curdefpol!*);

symbolic procedure arquot(u,v);
   % U is an ar domain element, result is a matrix form which
   % needs to be inverted for calculating the inverse of ar.
   begin scalar mv,r,sgn,x,y,z,w,dmode!*;
         integer n;
     mv := mvar curdefpol!*;
     x := u;
     w := for each k in cdr arbase!* collect
             (x := reducepowers multf(!*k2f mv,x));
     x := nil;
     w := negf v . (u . w);
     for j := (ldeg curdefpol!* - 1) step -1 until 0 do
       <>
                 else <>;
         if z neq 1 then
            y := for each j on y collect
                     lpow j .* if eqcar(lc j,'!:rn!:) then
                                  cadr lc j*z/cddr lc j
                                else lc j*z;
         if null x then x := y
          else x := b!:extmult(y,x)>>;
     sgn := evenp length lpow x;
     z := nil;
     for each j in lpow x do
         z := addf(if j = 0 then arnum!-mkglsol(0,x,sgn := not sgn,-1)
                    else multpf(mv to j,
                                arnum!-mkglsol(j,x,sgn:=not sgn,-1)),z);
     return z
   end;

symbolic procedure arquot1 u;
   % U is an ar domain element, result is a matrix form which
   % needs to be inverted for calculating the inverse of ar.
   begin scalar mv,r,sgn,x,y,z,w,dmode!*;
         integer n;
     mv := mvar curdefpol!*;
     x := u;
     w := for each k in cdr arbase!* collect
             (x := reducepowers multf(!*k2f mv,x));
     x := nil;
     w := -1 . (u . w);
     for j := (ldeg curdefpol!* - 1) step -1 until 0 do
       <>
                 else <>;
         if z neq 1 then
            y := for each j on y collect
                     lpow j .* if eqcar(lc j,'!:rn!:) then
                                  cadr lc j*z/cddr lc j
                                else lc j*z;
         if null x then x := y
          else x := b!:extmult(y,x)>>;
     sgn := evenp length lpow x;
     z := nil;
     for each j in lpow x do
         z := addf(if j = 0 then arnum!-mkglsol(0,x,sgn := not sgn,-1)
                    else multpf(mv to j,
                             arnum!-mkglsol(j,x,sgn := not sgn,-1)),z);
     return z
   end;

symbolic procedure arinv u;
   % Sort of half-extended gcd. No B-technique applied yet.
   % Performance is pretty bad.
   begin scalar mv,sgn,x,z,v,dmode!*;
         integer k,m,n;
     m := ldeg curdefpol!*;
     n := ldeg u;
     v := curdefpol!*;
     mv := mvar curdefpol!*;
     x := list(m-1) .* lc u .+ (list(-1) .* lc v .+ nil);
     for j := 2:(n+m) do
       begin scalar y;
         if j=(n+m) then y := list(-n-1) .* -1 .+ nil
          else nil;
         if (n + m - j - degr(v,mv) + 1) = 0 then v := red v;
         if (n + m - j - degr(u,mv) + 1) = 0 then u := red u;
             z := u;
         a:  if z and ((k := m - j + n - degr(z,mv)) -1 then
         z := addf(if j = 0 then arnum!-mkglsol(0,x,sgn := not sgn,-n-1)
                    else multpf(mv to j,
                             arnum!-mkglsol(j,x,sgn:=not sgn,-n-1)),z);
     return z
   end;

symbolic procedure arnum!-mkglsol(u,v,sgn,n);
   begin scalar s,x,y,dmode!*;
     dmode!* := '!:rn!:;
     y := lpow v;
     for each j on red v do
       if s := arnum!-glsolterm(u,y,j,n)
          then x := s;
     return int!-equiv!-chk mkrn(if sgn then -x else x,lc v)
   end;

symbolic procedure arnum!-glsolterm(u,v,w,n);
   begin scalar x,y,sgn;
     x := lpow w;
     a: if null x then return
           if car y = n then lc w;
        if car x = u then return nil
         else if car x member v then <>
         else if y then return nil
               else <>;
        go to a
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/bath.red0000644000175000017500000014565111526203062023254 0ustar  giovannigiovanni%%%%%%%%%%%%%%%%%%%%%%%%%

% module README

 An Algebraic Number and Factorizer Package for REDUCE 3.2

      This code is copyright the authors and
        the University of Bath 1985


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

This is a short guide to the installation and use of the algebraic number
package.  Some familiarity with terms from Galois theory is assumed as is
familiarity with REDUCE. The routines were developed under REDUCE 3.1 and
3.2, and rely on various built-in functions. Occasionally a bug in one of
these functions may cause a confusing error message to  be  produced;  we
include a few fixes to some of these functions.

To  load  all the algebraic number code enter REDUCE and type
           in algin$
This will load and compile (when the compiler is  on)  all  the  relevant
pieces  of  the  package.   The  code  can  of  course  be  included as a
collection of modules in the usual way.  If the factoriser is not  needed
then the arithmetic functions alone may be loaded by typing
         in arithin$

To start using algebraic numbers, type
        on algebraics;
and this indicates that the algebraic domain is to be used. The call
      alpha := algof(f);
will set alpha to a representative of a root of f where f is a univariate
(irreducible)  polynomial with integral or algebraic coefficients.  Alpha
can then be used in calculations much as one might expect.  Alpha  is  in
general  a  polynomial  in algebraic kernels, particularly in the case of
quadratic roots. Higher degree numbers may be shifted or scaled if it  is
thought the result has a 'simpler' minimal polynomial than the given one.
The polynomial f is NOT checked for irreducibility (this would  take  too
long),  it  is  left  to the user to do this.  In particular, it is quite
possible to create dependent algebraics i.e.  one minimal  polynomial  is
reducible  over  an  extension  of  Q  by  some  of the other algebraics.
Provided dependent algebraics are  kept  separate  no  problems  will  be
encountered,  but care should be taken not to mix dependent algebraics in
an expression  as  non-trivial  representations  of  0  may  occur;  also
division  may  fail  if  such  expressions  are  used  (this produces the
message: "Unexpected factor of a minimal polynomial").

Once all the code has been loaded, a short test is available: use
          in algtest$
If all is well, this should respond with a few timings for the tests.  If
not,  some  sort  of  error  message  should be produced. This might help
pinpoint the area in need of attention. Of course, an error-free  run  of
the test does not imply error-free code...





Below is a summary of the functions supplied in this package:

alpha := algof(f);    this assigns to alpha an algebraic which is a
                      root of the univariate polynomial f.

showalgs();       print the minimal polynomials of the currently created
                      algebraics.

polyof(alpha, x);     result is the minimal polynomial of alpha over Z as a
                      univariate polynomial in the kernel x.

algfactor(f,a,b,..);  factorize the polynomial f over Q(a,b,..).
                      Any algebraic occurring in a coefficient of f must be
                      included in the list a, b, ...
                      If a, b, ... are omitted then factorization is over Z.

norm(f,a,b,..);       find the norm of f over Q(a,b,..).
                      If a, b, ... are omitted then the result is just f.

on tralg;             switches on tracing of the factorizer,
off tralg;            switches off ...

Interface to algebraic factorizer in symbolic mode:

The  top-level  function  is  algfactorf(f,l)  (in  algfac)  where f is a
standard form, and l is a list of algebraic kernels of the  type  (alg  .
algn),  in  the  order  "most  recently  created first" (this ordering is
crucial to correct operation). This returns (c . flist), where c  is  the
numeric content, and flist is a list of pairs (factor . multiplicity).

The funtion normf(f,alg) (in algnorm) produces the the standard form that
is the norm of the standard form f over the extension  by  the  algebraic
kernel  alpha.  The function normf1(f,alglist) returns the norm of f over
the extension by the list of kernels alglist.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGTEST

% some tests of the algebraic number and factorizer package

on algebraics$

% arithmetic;
a := algof(x*x-2)$
b := algof(x*x-3)$
c := algof(x*x-5)$

d := 1/(a+b+c)$
if d*(a+b+c) neq 1 then write "****arithmetic error****"$

% creation;
aa := algof(x*x-a)$
bb := algof(2*x*x-1)$
cc := algof(a*x*x-1)$
dd := algof(x**3+x*x+1)$

% factorizer;
a := algof(x*x+1)$
% b := algof(x*x-3)$
c := algof(x*x+5)$

on time$
<< write "factorizer problem 1:"; algfactor(x*x+x+1,a,b,c) >>$
if factor1*factor2 neq x*x+x+1 then
  write "****factorizer error (1st problem)****"$

% a := algof(x*x+1)$
b := algof(x*x-a)$       % NB sqrt a MUST be created AFTER a

<< write "factorizer problem 2:"; algfactor(x*x-a,a,b) >>$
if factor1*factor2 neq x*x-a then
  write "****factorizer error (2nd problem)****"$

off time$

end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% module ARITHIN

% File to read in algebraic arithmetic.

% the next two should be fluid - not globals!
unglobal '(dmode!* kord!*);
fluid '(dmode!* kord!*);

% alg-kord* is used to record the order of creation of algebraics -
% this is essential to correct manipulation of polynomials in
% algebraics.
lisp global '(alg!-kord!*);

in algmacros$  % macro definitions
in algsupport$  % miscellaneous functions
in algdom$  % domain definitions
in algarith$  % main arithmetic
in algrecip$  % calculation of reciprocals
in algcreate$  % creation of algebraics
in algnorm$  % calculation of norms
in fixes$  % fixes to cope with domains

end;


%%%%%%%%%%%%%%%%%%%%

% module trailc

% these are the patches for trailing coefficient and other tests in
% the factorize algorithm;

SYMBOLIC PROCEDURE FACTOR!-TRIALDIV(POLY,FLIST,M,LLIST);
% Combines the factors in FLIST mod M and test divides the result
% into POLY (over integers) to see if it goes. If it doesn't
% then DIDNTGO is returned, else the pair (D . Q) is
% returned where Q is the quotient obtained and D is the product
% of the factors mod M;
  IF POLYZEROP POLY THEN ERRORF "Test dividing into zero?"
  ELSE BEGIN SCALAR D,Q,tcpoly,tcoeff,x,oldmod,w,poly1,try1;
    factor!-trace <<
      prin2!* "We combine factors ";
      for each ff in flist do <<
        w:=assoc(ff,llist);
        prin2!* "f(";
        prin2!* cdr w;
        prin2!* "), " >> ;
      prin2!* "and try dividing : " >>;
    x := mvar poly;
    tcpoly :=trailing!.coefft(poly,x);
    tcoeff := 1;
    oldmod := set!-general!-modulus m;
    for each fac in flist do
      tcoeff := general!-modular!-times(tcoeff,trailing!.coefft(fac,x));
    if not zerop remainder(tcpoly,tcoeff) then <<
      factor!-trace printstr " it didn't go (tc test)";
      set!-modulus oldmod;
      return 'DIDNTGO >>;
  % it has passed the tc test - now try evaluating at 1;
    poly1 := eval!-at!-1 poly;
    try1 := 1;
    for each fac in flist do
      try1 := general!-modular!-times(try1,eval!-at!-1 fac);
    set!-modulus oldmod;
    if (zerop try1 and not zerop poly1) or
       not zerop remainder(poly1,try1) then <<
      factor!-trace printstr " it didn't go (test at 1)";
      return 'DIDNTGO >>;
  % it has passed both tests - work out longhand;
    D:=COMBINE(FLIST,M,LLIST);
    IF DIDNTGO(Q:=QUOTF(POLY,CAR D)) THEN <<
      FACTOR!-TRACE PRINTSTR " it didn't go (division fail)";
      RETURN 'DIDNTGO >>
    ELSE <<
      FACTOR!-TRACE PRINTSTR " it worked !";
      RETURN (CAR D . QUOTF(Q,CDR D)) >>
  END;



SYMBOLIC PROCEDURE COMBINE(FLIST,M,L);
% multiply factors in flist mod m;
% L is a list of the factors for use in FACTOR!-TRACE;
  BEGIN SCALAR OM,RES,W,LCF,LCFINV,LCFPROD;
%    FACTOR!-TRACE <<                         )
%      PRIN2!* "We combine factors ";         )  RJB:
%      FOR EACH FF IN FLIST DO <<             )  Moved to factor-trialdiv;
%        W:=ASSOC(FF,L);                      )  This is the only change to
%        PRIN2!* "f(";                        )  this routine.
%        PRIN2!* cdr w;                       )
%        PRIN2!* "), " >> ;                   )
%      PRIN2!* "and try dividing : " >>;      )
    LCF := LC CAR FLIST; % ALL LEADING COEFFTS SHOULD BE THE SAME;
    LCFPROD := 1;
% This is one of only two places in the entire factorizer where
% it is ever necessary to use a modulus larger than word-size;
    IF M>LARGEST!-SMALL!-MODULUS THEN <<
      OM:=SET!-GENERAL!-MODULUS M;
      LCFINV := GENERAL!-MODULAR!-RECIPROCAL LCF;
      RES:=GENERAL!-REDUCE!-MOD!-P CAR FLIST;
      FOR EACH FF IN CDR FLIST DO <<
        IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST";
        RES:=GENERAL!-TIMES!-MOD!-P(
            GENERAL!-TIMES!-MOD!-P(LCFINV,
                GENERAL!-REDUCE!-MOD!-P FF),RES);
        LCFPROD := LCFPROD*LCF >>;
      RES:=GENERAL!-MAKE!-MODULAR!-SYMMETRIC RES;
      SET!-MODULUS OM;
      RETURN (RES . LCFPROD) >>
    ELSE <<
      OM:=SET!-MODULUS M;
      LCFINV := MODULAR!-RECIPROCAL LCF;
      RES:=REDUCE!-MOD!-P CAR FLIST;
      FOR EACH FF IN CDR FLIST DO <<
        IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST";
        RES:=TIMES!-MOD!-P(TIMES!-MOD!-P(LCFINV,REDUCE!-MOD!-P FF),RES);
        LCFPROD := LCFPROD*LCF >>;
      RES:=MAKE!-MODULAR!-SYMMETRIC RES;
      SET!-MODULUS OM;
      RETURN (RES . LCFPROD) >>
  END;

symbolic procedure eval!-at!-1 f;
  % f a univariate standard form over Z;
  % return f(1);
  % NB: this is only called when f(1) neq 0, ie no nil to worry about.
  if atom f then f else (lc f) + eval!-at!-1(red f);

symbolic procedure try!.combining(l,poly,m,sofar);
  try!.combining1(l,poly,m,sofar,2);

SYMBOLIC PROCEDURE TRY!.COMBINING1(L,POLY,M,SOFAR,k);
% l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly
% but no f(i) divides poly over the integers. we find the combinations
% of the f(i) that yield the true factors of poly over the integers.
% sofar is a list of these factors found so far.
% start combining K at a time.
  IF POLY=1 THEN
    IF NULL L THEN SOFAR
    ELSE ERRORF(LIST("TOO MANY BAD FACTORS:",L))
  ELSE BEGIN SCALAR N,RES,FF,V,W,W1,COMBINED!.FACTORS,LL; % K removed here;
    N:=LENGTH L;
    IF N=1 THEN
      IF LDEG CAR L > (LDEG POLY)/2 THEN
        RETURN ('ONE! BAD! FACTOR . SOFAR)
      ELSE ERRORF(LIST("ONE BAD FACTOR DOES NOT FIT:",L));
    IF N=2 OR N=3 THEN <<
      W:=LC CDAR L; % The LC of all the factors is the same;
      WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors;
      IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
        PRINTSTR "We combine:";
         FOR EACH LF IN L DO FAC!-PRINTSF CDR LF;
         PRIN2!* " mod "; PRIN2!* M;
         PRINTSTR " to give correct factor:";
         FAC!-PRINTSF POLY >>;
       COMBINE!.ALPHAS(L,T);
       RETURN (POLY . SOFAR) >>;
    LL:=FOR EACH FF IN L COLLECT (CDR FF . CAR FF);
%    K := 2;  K is now an argument to try.combining1;
  LOOP1:
      IF K > N/2 THEN GO TO EXIT;
      W:=KOUTOF(K,IF 2*K=N THEN CDR L ELSE L,NIL);
      WHILE W AND (V:=FACTOR!-TRIALDIV(POLY,CAR W,M,LL))='DIDNTGO DO
      << W:=CDR W;
        WHILE W AND
            ((CAR W = '!*LAZYADJOIN) OR (CAR W = '!*LAZYKOUTOF)) DO
          IF CAR W= '!*LAZYADJOIN THEN
            W:=LAZY!-ADJOIN(CADR W,CADDR W,CADR CDDR W)
          ELSE W:=KOUTOF(CADR W,CADDR W,CADR CDDR W)
        >>;
      IF NOT(V='DIDNTGO) THEN <<
        FF:=CAR V; V:=CDR V;
        IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
          PRINTSTR "We combine:";
           FOR EACH A IN CAR W DO FAC!-PRINTSF A;
         PRIN2!* " mod "; PRIN2!* M;
         PRINTSTR " to give correct factor:";
         FAC!-PRINTSF FF >>;
       FOR EACH A IN CAR W DO <<
         W1:=L;
         WHILE NOT (A = CDAR W1) DO W1:=CDR W1;
         COMBINED!.FACTORS:=CAR W1 . COMBINED!.FACTORS;
         L:=DELETE(CAR W1,L) >>;
       COMBINE!.ALPHAS(COMBINED!.FACTORS,T);
%%% Now try combining the remaining factors, starting with k-tuples.
       RES:=try!.combining1(l,v,m,ff . sofar,k);
       GO TO EXIT>>;
    K := K + 1;
    GO TO LOOP1;
  EXIT:
    IF RES THEN RETURN RES
    ELSE <<
      W:=LC CDAR L; % The LC of all the factors is the same;
      WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W);
            % poly's LC may be a higher power of w than we want
            % and we must return a result with the same
            % LC as each of the combined factors;
      IF NOT !*OVERVIEW THEN FACTOR!-TRACE <<
        PRINTSTR "We combine:";
          FOR EACH FF IN L DO FAC!-PRINTSF CDR FF;
          PRIN2!* " mod "; PRIN2!* M;
          PRINTSTR " to give correct factor:";
          FAC!-PRINTSF POLY >>;
      COMBINE!.ALPHAS(L,T);
      RETURN (POLY . SOFAR) >>
  END;

end;


%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGIN
%
% File to read in algebraic arithmetic and algebraic factorizer.
% the next two should be fluid - not globals!
unglobal '(dmode!* kord!*);
fluid '(dmode!* kord!*);
% alg-kord* is used to record the order of creation of algebraics -
% this is essential to correct manipulation of polynomials in
% algebraics.
lisp global '(alg!-kord!*);
in algmacros$  % macro definitions
in algsupport$  % miscellaneous functions
in algdom$  % domain definitions
in algarith$  % main arithmetic
in algrecip$  % calculation of reciprocals
in algcreate$  % creation of algebraics
in algnorm$  % calculation of norms
in algfac$  % Trager factorizer
in trailc$  % update to integer factorizer
in fixes$  % fixes to cope with domains
end;

%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGSUPPORT
%
% Miscellaneous support functions for algebraics;

symbolic procedure degree!-in!-term(f,v);
  % f a standard form, v a kernel;
  % returns degree of f in v;
  if tvar f = v then tdeg f
  else degree!-in!-form(tc f,v);

symbolic procedure substitute(f,v);
  % f a univariate standard form, v an algebraic kernel;
  % substitutes v for mvar f in f;
  % returns a sf;
  if numberp f then f
  else if domainp f then numr cdr f
  else
    v .** ldeg f .* substitute(lc f,v) .+  substitute(red f,v);

symbolic procedure newsubf(f,g);
  % f a univariate sf, g an sq;
  % return the sq resulting from substituting g into f;
  if domainp f then !*f2q f
  else
    addsq(newsubf(red f,g),multsq(!*f2q lc f,exptsq(g,ldeg f)));

symbolic procedure cons!-count f;
  % a measure of the complexity of f;
  if atom f or algebraicp f then 0
  else cons!-count(car f) + cons!-count(cdr f) + 1;

symbolic procedure extract(f,v,n);
  % f a standard form, v a kernel;
  % returns coefficient of v**n in f;
  if domainp f then
    if n=0 then f else nil
  else if mvar f = v then <<
    while not domainp f and degree!-in!-form(f,v) > n do
      f := red f;
    if null f or degree!-in!-form(f,v) neq n then nil
    else if n=0 then f else lc f
  >>
  else if ordop(v,mvar f) then
    if n=0 then f else nil
  else addf( multf( !*p2f lpow f, extract(lc f,v,n) ),
             extract(red f,v,n) );

symbolic procedure degree!-in!-form(f,v);
  % f a standard form, v a kernel;
  % returns degree of f in v;
  if domainp f then 0
  else if mvar f = v then ldeg f
  else if ordop(v,mvar f) then 0
  else max( degree!-in!-form(lc f,v),
            degree!-in!-form(red f,v) );

symbolic procedure collect!-kernels f;
  % f standard form. Returns list of non-algebraic kernels
  % in f, or nil if none;
  if domainp f then nil
  else if algebraicp mvar f then
    union(collect!-kernels lc f,collect!-kernels red f)
  else
    union(list mvar f,
          union(collect!-kernels lc f,collect!-kernels red f));

symbolic procedure get!-mvar f;
  % f an sf with algebraics and kernels;
  % return most main non-algebraic kernel, or nil if none present;
  (lambda kerlist;
    if null kerlist then nil
    else car kerlist
  ) sort(collect!-kernels f,'ordp);

symbolic procedure adjust!-algebraics f;
  % f an sf, returns an sf
  % reorder f so that algebraic kernels are last;
  if domainp f then f
  else begin scalar ker,form;
    ker := get!-mvar f;
    if null ker then return f;
    (lambda coeff;
      if not null coeff then <<
        form := adjust!-algebraics coeff;
        f := addf(f,negf(coeff))
      >>
      else form := nil
    ) extract(f,ker,0);
    for i := 1:degree!-in!-form(f,ker) do
      (lambda coeff;
        if not null coeff then <<
          form := ((ker .** i) .* adjust!-algebraics coeff) . form;
          f := addf(f,negf( (ker .** i) .* coeff .+ nil ))
        >>
      ) extract(f,ker,i);
    return form
  end;

symbolic procedure num!-content f;
% find numeric content of non-zero polynomial;
  if domainp f then absf f
  else if null red f then num!-content lc f
  else begin scalar g1;
    g1 := num!-content lc f;
    if not (g1=1) then g1 := gcddd(g1,num!-content red f);
    return g1
  end;

end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% module FIXES

% Fixes for REDUCE 3.2 to cope properly with domains;
%
% The problem occurs when two domain elements are multiplied together
% to produce an integer, eg i*i -> -1, as the tagged domain type
% (:alg: ....) becomes an untagged integer. This results in (usually)
% an illegal car or cdr access to the integer that was believed to be
% tagged.

symbolic procedure multdm(u,v);
  % not all results are strictly domain elements...
  if atom u and atom v then times2(u,v)
  else int!-equiv!-chk dcombine(u,v,'times);

symbolic procedure !:expt(u,n);
   % raises domain element u to power n.  value is a domain element;
   if null u then if n=0 then rederr "0/0 formed" else nil
    else if n=0 then 1
    else if n<0
     then !:recip !:expt(if not fieldp u then mkratnum u else u,-n)
    else if atom u then u**n
    else begin scalar v,w,x;
%      v := apply1(get(car u,'i2d),1);   %unit element;
%      x := get(car u,'times);
      v := 1;
   a: w := divide(n,2);
      if cdr w=1 then v := multf(u,v);  % was "apply(x,list(u,v))";
      if car w=0 then return v;
      u := multf(u,u);    % was "apply(x,list(u,u))";
      n := car w;
      go to a
   end;

SYMBOLIC PROCEDURE MULTD(U,V);
   %U is a domain element, V a standard form.
   %Value is standard form for U*V;
   IF NULL V THEN NIL
    ELSE IF DOMAINP V THEN MULTDM(U,V)
    ELSE adjoin!-term(LPOW V, MULTD(U,LC V), MULTD(U,RED V));

%
% Not sure why we fix this one;
%
SYMBOLIC PROCEDURE RECIPROCAL!-BY!-GCD(A,B,X,Y);
%On input A and B should be coprime. This routine then
%finds X and Y such that A*X+B*Y=1, and returns the value Y
%on input A > B;
   IF B=0 THEN ERRORF "INVALID MODULAR DIVISION"
   ELSE IF B=1 THEN IF Y < 0 THEN Y+CURRENT!-MODULUS ELSE Y
   ELSE BEGIN SCALAR W;
%N.B. Invalid modular division is either:
% a)  attempt to divide by zero directly
% b)  modulus is not prime, and input is not
%     coprime with it;
     W:=divide(A,B); % quotient . remainder;
     RETURN RECIPROCAL!-BY!-GCD(B,cdr w,Y,X-Y*car W)
   END;

end;


%%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGARITH

% General arithmetic routines for algebraics;

symbolic procedure algmultsq(u,v);
  % u,v are both sqs with groundp denrs;
  % returns an sq;
  begin scalar numer,dener,hcf;
    numer := algmultf(numr u,numr v);
    dener := denr u * denr v;      % denr's don't contain algebraics;
    hcf := gcdf!*(numer,dener);    % can't be an algebraic hcf;
    numer := quotf(numer,hcf);
    dener := quotf(dener,hcf);
    return
      if minusp dener then
        negatef numer ./ -dener
      else
        numer ./ dener
  end;

symbolic procedure algmultf(u,v);
  % u,v both sf's, containing only algebraics and groundp's;
  % value is standard form for u*v;
  if null u or null v then nil
  else if onep u then v
  else if onep v then u
  else if numberp u then multn(u, v)
  else if numberp v then multn(v, u)
  else if mvar u = mvar v then algmultcancel(u, v)
  else if ordop(mvar u, mvar v)
         then lpow u .* algmultf(lc u, v) .+ algmultf(red u, v)
         else lpow v .* algmultf(lc v, u) .+ algmultf(red v, u);

symbolic procedure multn(n, f);
  % n is an integer, f is a SF over Z : result is SF for n*f.
  if null f then nil
  else if onep n then f
  else if numberp f then times2(n, f)
  else lpow f .* multn(n, lc f) .+ multn(n, red f);

symbolic procedure algmultcancel(u, v);
  % u, v are SFs over Z in only alg kernels with the same mvar.
  % Result is SF for u*v reduced mod the minpoly.
  begin scalar ans;
    ans := algmult(u, v);
    return
      if ldeg ans < degree!-of!-algebraic mvar ans then ans
      else algmodf(ans, min!-poly!-of mvar ans)
  end;

symbolic procedure algmult(u, v);
  % u, v are SFs over Z in only alg kernels with mvar u <= mvar v.
  % Result is SF for u*v with terms in the mvar not reduced mod the minpoly.
  if null u then nil
  else if numberp u then multn(u, v)
  else if mvar u neq mvar v then algmultf(u, v)
  else addf(algmult(red u, v), algmultt(lt u, v));

symbolic procedure algmultt(term, poly);
  % term is a term, poly is a SF over Z : result is SF for term*poly.
  if null poly then nil
  else if numberp poly then tpow term .* multn(poly, tc term) .+ nil
  else if tvar term neq mvar poly then
    tpow term .* algmultf(tc term, poly) .+ nil
  else
    mvar poly .** (tdeg term + ldeg poly) .* algmultf(lc poly, tc term)
                                          .+ algmultt(term, red poly);

symbolic procedure algmodf(f, g);
  % f, g are SFs over Z in only alg kernels : result is f mod g.
  if null f or numberp f or mvar f neq mvar g or ldeg f < ldeg g then f
  else if ldeg f = ldeg g then
    addf(f, algmultf(negf lc f, g))
  else
    algmodf(addf(f, algmultt(mvar f .** (ldeg f - ldeg g)
                                    .* negf lc f, g)),
            g);

symbolic procedure algquotientsq(u,v);
  % u,v both sq's, return an sq;
  if not algebraic!-mvarp numr v then
    if minusp numr v then
      algmultsq(u, -denr v ./  -numr v)
    else
      algmultsq(u,denr v ./ numr v)
  else
    algmultsq(u, algmultsq((denr v ./ 1),algrecip numr v));

symbolic procedure negatesq u;
  % u an sq, return -u;
  if null car u then u
  else (negatef car u) ./ cdr u;

symbolic procedure differencesq(u,v);
  % u,v sq's, return u - v;
  addsq(u,negatesq v);

symbolic procedure negatef u;
  % u a sf, return -u;
  if null u then nil
  else if domainp u then multdm(-1,u)
  else lpow u .* negatef(lc u) .+ negatef(red u);

symbolic procedure differencef(u,v);
  % u,v sfs, return u - v;
  addf(u,negatef v);

end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGDOM

% algebraics using domains 23/4/85;

symbolic;

fluid '(!*algebraics);      % 'on algebraics;' switches on algebraics;

global '(domainlist!*);
domainlist!* := union( '(!:alg!:), domainlist!*);

% an ":alg:" is (:alg: . sq), where the sq contains algebraics of the
% form (alg . algn) in the numerator, and only groundp's in the
% denominator;

put('algebraics,'tag,'!:alg!:);
put('!:alg!:,'dname,'algebraics);
flag( '(!:alg!:), 'field);
put('!:alg!:,'i2d,'!*i2alg);
put('!:alg!:,'minusp,'algminusp!:);
put('!:alg!:,'plus,'algplus!:);
put('!:alg!:,'times,'algtimes!:);
put('!:alg!:,'difference,'algdifference!:);
put('!:alg!:,'quotient,'algquotient!:);
put('!:alg!:,'zerop,'algzerop!:);
put('!:alg!:,'prepfn,'algprep!:);
put('!:alg!:,'specprn,'!:alg!:prin);
put('alg,'specprn,'algprin);

% conversion functions;

put('!:alg!:,'!:rn!:,'algcnv);
put('!:alg!:,'!:ft!:,'algcnv);
put('!:alg!:,'!:mod!:,'algcnv);

algebraic;

symbolic procedure !*i2alg u;
  % integer -> algebraic;
  '!:alg!: . ((if u = 0 then nil else u) ./ 1);

symbolic procedure mkalg u;
  % u an sq with groundp denominator, possibly containing kernels other
  % than algebraics in the numerator. Convert this to the standard tagged
  % form;
  (lambda (numer,dener);
    if null numer then nil
    else if has!-algebraic numer then
      (lambda kers;
        if null kers then mkalg1 u
        else mkalg2(adjust!-algebraics numer,dener)
      ) collect!-kernels numer
    else if onep dener then numer
    else mkalg1 u
  ) (numr u,denr u);

symbolic procedure has!-algebraic f;
  % untagged sf f: are there any (alg . algn)?
  if null f or numberp f then nil
  else
    (domainp f and eqcar(f,'alg)) or
    eqcar(mvar f,'alg) or
    has!-algebraic red f or
    has!-algebraic lc f;

symbolic procedure mkalg1 u;
  % u an sq;
  '!:alg!: . u;

symbolic procedure mkalg2(f,n);
  % f an sf containing untagged algebraics - tag them using n as
  % a denominator;
  if groundp f or domainp f then f
  else if algebraic!-mvarp f then mkalg1(f ./ n)
  else begin scalar newlc,newred;
    newlc := mkalg2(lc f,n);
    newred := mkalg2(red f,n);
    return
      if newlc eq lc f then
        if newred eq red f then f
        else lt f .+ newred
      else (lpow f) .* newlc .+ newred
  end;

symbolic procedure algcnv u;
  rederr list("Conversion between algebraics and",
               get(car u,'dname),"not defined");

symbolic procedure algminusp!: u;
  % not sure on this one;
  minusf cadr u;

symbolic procedure algplus!:(u,v);
  % nothing nasty happens here if we turn off dmode*.
  % We rebind kord* to the algebraic ordering;
  begin scalar dmode!*,kord!*;
    kord!* := alg!-kord!*;
    return mkalg addsq(cdr u,cdr v)
  end;

symbolic procedure algtimes!:(u,v);
  % but here we must use the new multiplier;
  % there is a fudge for :expt, which doesn't expect powers of domain
  % elements to be non-domain elements;
  begin scalar dmode!*,kord!*;
    kord!* := alg!-kord!*;
    if atom u or car u neq '!:alg!: then u := mkalg1(u ./ 1);
    if atom v or car v neq '!:alg!: then v := mkalg1(v ./ 1);
    return mkalg algmultsq(cdr u,cdr v)
  end;

symbolic procedure algdifference!:(u,v);
  begin scalar dmode!*,kord!*;
    kord!* := alg!-kord!*;
    return mkalg differencesq(cdr u,cdr v)
  end;

symbolic procedure algquotient!:(u,v);
  % and here the new quotient;
  begin scalar dmode!*,kord!*;
    kord!* := alg!-kord!*;
    return mkalg algquotientsq(cdr u,cdr v)
  end;

symbolic procedure algzerop!: u;
  null cadr u;

symbolic procedure algprep!: u;
  prepsq cdr u;

symbolic procedure !:alg!:prin u;
  % u a sq with algebraics perhaps;
  if cdr u = 1 then maprin prepsq!* u
  else <<
    prin2!* "(";
    maprin prepsq!* u;
    prin2!* ")"
  >>;

symbolic procedure algprin u;
  % u is a gensym;
  if ldeg gts u = 2 then <<
    prin2!* "Sqrt(";
    xprinf(negatef red gts u,nil,nil);
    prin2!* ")"
  >>
  else prin2!* u;

symbolic initdmode 'algebraics;

end;

%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGFAC

% Trager algorithm for factorization over algebraic number fields;

lisp fluid '(!*tralg algfac!-level recursedp trivial!-factors);

symbolic procedure my!-subf(f,x,c);
  % substitutes x + c for the kernel x in the standard form f,
  % c a domain element;
  % returns a standard form;
  if domainp f or (mvar f neq x and ordop(x,mvar f)) then f
  else begin scalar newred,newlc;
    newred := my!-subf(red f,x,c);
    newlc  := my!-subf(lc f,x,c);
    return
      if mvar f neq x then
        if newred eq red f and newlc eq lc f then f
        else addf(multf(newlc,!*p2f lpow f),newred)
      else addf(multf(newlc,exptf(x .** 1 .* 1 .+ c,ldeg f)),newred)
    end;

symbolic procedure my!-quotf(u,v);
  % u and v standard forms, probably with algebraics, v dividing u up to a
  % numeric factor. Returns u/v ignoring this factor;
  numr quotsq(!*f2q u,!*f2q v);

symbolic procedure variatep f;
  % does f contain a non-algebraic kernel?
  not null pick!-a!-kernel f;

symbolic procedure pick!-a!-kernel f;
  % f a standard form;
  % returns a non-algebraic kernel in f, or nil if none;
  if groundp f then nil
  else if not algebraicp mvar f then mvar f
  else
    (lambda (ker);
       if ker then ker else pick!-a!-kernel(red f) )
    (pick!-a!-kernel(lc f));

symbolic procedure sqfr!-norm(f,x,alg!-tower);
  % f a standard form over k(alpha),
  % where alpha = car alg!-tower, k = Q(cdr alg-tower);
  % value (s,g,R) where s is a non-negative integer,
  % g(x,alpha) = f(x-s*alpha,alpha), R(x) = Norm(g(x,alpha)),
  % and R is square-free, g and R are standard forms;
  % thus we map Norm:k(alpha) -> k;
  % Barry Trager's version of van der Waerden's algorithm;
  begin scalar alpha,s,g,R,minus!-alpha,!*ezgcd;
    alpha := car alg!-tower;
    minus!-alpha := multdm(mkalg1 !*k2q alpha,-1);
    s := 0;
    g := f;
    if not contains!-alpha(f,alpha) then << % we may increase s immediately;
      s := s+1;
      g := my!-subf(g,x,minus!-alpha)
    >>;
    R := normf(g,alpha);
    while degree!-in!-form( gcdf!*( R,diff(R,x) ),x ) neq 0 do <<
      repeat <<
        s := s+1;
        g := my!-subf(g,x,minus!-alpha)
      >> until contains!-alpha(g,alpha);
      R := normf(g,alpha)
    >>;
    if !*tralg then <<
      if s > 0 then <<
        prin2!* "we make a linear substitution ";
        prin2!* x; prin2!* " -> "; prin2!* x ;prin2!* " - ";
        if s > 1 then << prin2!* s; prin2!* "*" >>;
        algprin(cdr alpha);
        prin2!* " so that ";
      >>;
      printstr "the norm ";
      fac!-printsf R;
      printstr "is square-free, and we try to factorise this"
    >>;
    return list(s,g,R)
  end;

symbolic procedure pick!-minimal!-kernel f;
  % f a standard form. Picks non-algebraic kernel
  % of least degree, or errors if none;
  minimal!-ker( f,(lambda l;if null l then rederr "no kernel present"
                            else l)(collect!-kernels f) );

symbolic procedure minimal!-ker(f,l);
  % picks kernel of least degree in the standard form f
  % from the list of kernels l;
  if onep length l then car l
  else
    (lambda mink;
       if degree!-in!-form(f,car l) < degree!-in!-form(f,mink) then
         car l else mink)(minimal!-ker(f,cdr l));

symbolic procedure my!-factorf f;
  % f a standard form, square-free;
  % returns ( sf sf ... ), a list of the factors of f;
  begin scalar fac!-list;
    fac!-list :=                                        % remove content and
      for each fac in cdr factorf(f) collect car fac;   % multiplicities;
    if !*tralg then
      if length fac!-list = 1 then
        printstr "the norm is irreducible"
      else <<
        printstr "the norm factorises into";
        for each fac in fac!-list do
          fac!-printsf fac
      >>;
    return fac!-list
  end;

symbolic procedure normalise(u,x);
  % u a standard form, returns a standard form;
  if null u then nil
  else if groundp u then 1
  else my!-quotf(u,extract(u,x,degree!-in!-form(u,x)));

symbolic procedure alg!-factor(f,x,alg!-tower);
  % f a standard form over k(alpha), where car alg!-tower = alpha;
  % f is square-free;
  % returns a list of the factors of f over k(alpha),
  % as standard forms;
  % Barry Trager's version of van der Waerden's algorithm;
  begin scalar s,g,R,norm!-list,l,h,alpha,!*ezgcd;
    if degree!-in!-form(f,x) = 1 then <<
      if !*tralg then printstr "it is linear";
      return list f
    >>;
    if null alg!-tower and contains!-algebraic f then <<
      terpri!* t;prin2!* "***** ";algprin(cdr mvar f);terpri!*();
      rederr "unexpectedly found in factorisation"
    >>;
    if null alg!-tower then
      return my!-factorf(f);
    alpha := car alg!-tower;
    norm!-list := sqfr!-norm(f,x,alg!-tower);
    s := car norm!-list;
    g := cadr norm!-list;
    R := caddr norm!-list;
    l := alg!-factor(R,x,cdr alg!-tower);
         % we recurse down the tower;
    if length l = 1 then return list f;     % f irreducible;
    return
      for each h in l collect  <<
        h := gcdf!*(h,g);
        if s = 0 then normalise(h,x)
        else normalise(my!-subf(h,x,multdm(mkalg1 !*k2q alpha,s)),x)
      >>
  end;

symbolic procedure sqfr!-decompose(f,x);
  % f a standard form in x;
  % returns ( (sf . n) (sf . n) ... ), of the square-free parts
  % of f together with their multiplicities;
  sqfr!-decompose1(f,x,1);

symbolic procedure sqfr!-decompose1(f,x,n);
  % n a count of multiplicity so far;
  begin scalar q,r,s,!*ezgcd;
    r := gcdf!*( f,normalise(diff(f,x),x) );
    if degree!-in!-form(r,x) = 0 then return list( f . n );
    s := my!-quotf(f,r);
    q := my!-quotf(s,gcdf!*(r,s));
    return
      if q=1 then
        sqfr!-decompose1(r,x,n+1)
      else
        ( q . n ) . sqfr!-decompose1(r,x,n+1)
  end;

symbolic procedure simpfactorise u;
  % u is (sf . l), l a list of algebraics;
  if atom u then rederr "factorise needs arguments"
  else if null cdr u or null alg!-kord!* then
    simpfactorize u       % fall through to integer factorizer;
  else begin scalar f,l,algs,alg!-order;
    % get algebraics, and reorder correctly;
    alg!-order := alg!-kord!*;
    algs :=
      for each alg in cdr u collect
        (lambda a;
          if car a neq '!:alg!: then typerr(alg,'algebraic)
          else mvar cadr a) (!*a2f alg);
    while not null alg!-order do <<
      if member(car alg!-order,algs) then
        l := append(l,list(car alg!-order));
      alg!-order := cdr alg!-order
    >>;
    f := !*a2f car u;
    return algfactorf(f,l)
  end;

put('algfactor,'simpfn,'simpfactorise);

symbolic procedure algfactorf(f,algs);
  % f a standard form, algs a list of algebraic kernels;
  begin scalar algfac!-level,recursedp,factor!-list,z,factor!-count;
    algfac!-level := 0;                 % depth of recursion
    recursedp := nil;                   % flags for tralg;
    factor!-list := factorise1(f,algs);
    z := list( 0 . mk!*sq car(factor!-list) );
    factor!-count := 0;
    for each fff in cdr factor!-list do
      for i := 1:cdr fff do
        z := ((factor!-count := factor!-count + 1) .
               mk!*sq !*f2q(car fff)) . z;
    return multiple!-result(z,'factor)
  end;

symbolic procedure factorise1(f,alg!-tower);
  % f a standard form;
  % factorises f over Q(alg-tower);
  % returns (n . l): n numeric (non-variate) content as a standard quotient,
  % l a list of factors (standard forms) paired with their multiplicities;
  begin scalar x,fac!-list,con,n!-content;
    algfac!-level := algfac!-level + 1;
    x := pick!-minimal!-kernel f;
    if algfac!-level > 1 then
      recursedp := t;
    if !*tralg then <<
      if recursedp then prin2!* "now ";
      prin2!* "to factorise ";
      fac!-printsf f;
      prin2!* "we pick the kernel ";
      printvar x;
    >>;
    fac!-list := factorise2(f,alg!-tower,x);
    n!-content := 1;
    if algfac!-level = 1 then <<     % only bother with content at the end;
      con := 1;
      for each fac in fac!-list do
        for i:= 1:cdr fac do con := multf(con,lnc car fac);
      n!-content := quotsq(!*f2q lnc f,!*f2q con);
      if !*tralg then <<
        printstr "final result:";
        if n!-content neq (1 . 1) then <<
          prin2!* "the numeric content is ";
          printsq n!-content
        >>;
      printstr "the factors are";
      for each fac in fac!-list do
        fac!-printsf !*p2f mksp(prepf car fac,cdr fac)
      >>
    >>;
    algfac!-level := algfac!-level - 1;
    return n!-content . fac!-list
  end;

symbolic procedure factorise2(f,alg!-tower,x);
  % this is an entry for when x is already given;
  % we hand the polynomial to the routines that actually do the work
  % after a little tidying up;
  % returns ( (sf . n) (sf . n) ... );
  begin scalar fac!-list,unfac!-list,sqfr!-list,n!-content,p!-content,
               facl,trivial!-factors;
    if null extract(f,x,0) then   % we can divide out some x's;
      return factor!-by!-xes(f,x,alg!-tower);
    n!-content := num!-content f;
    f := quotfd(f,n!-content);
    p!-content := polynomial!-content(f,x);
    f := my!-quotf(f,p!-content);
    if variatep p!-content then <<
      if !*tralg then <<
        prin2!* "then extract a content of ";
        fac!-printsf p!-content
      >>;
      fac!-list := cdr factorise1(p!-content,alg!-tower);
        % fac-list is a list of the factored parts of f (with multiplicities);
    >>;
    if !*tralg and recursedp and algfac!-level = 1 then <<
      prin2!* "we now return to the polynomial ";
      fac!-printsf f
    >>;
    sqfr!-list := sqfr!-decompose(f,x);
    if length sqfr!-list > 1 or cdar sqfr!-list > 1 then <<
      trivial!-factors := t;
      if !*tralg then
        printstr "the polynomial decomposes into the square-free parts:";
        for each part in sqfr!-list do
          fac!-printsf !*p2f mksp(prepf car part,cdr part)
      >>
    else if !*tralg then printstr "the polynomial is square-free";
    for each part in sqfr!-list do <<
      facl := trivial!-factor(car part);
      if length facl > 1 then <<
        trivial!-factors := t;
        if !*tralg then <<
          prin2!* "we find ";
          fac!-printsf car part;
          printstr "factorises trivially as:";
          for each fac in facl do
            fac!-printsf fac
        >>
      >>;
      for each fac in facl do
        unfac!-list := (fac . cdr part) . unfac!-list
          % unfac-list is a list of the unfactored parts of f
          % (with multiplicities);
    >>;
    for each part in unfac!-list do <<
      if !*tralg and trivial!-factors then <<
        prin2!* "We consider the factor ";
        fac!-printsf car part
      >>;
      for each fac in alg!-factor(car part,x,alg!-tower) do
        fac!-list := (fac . cdr part) . fac!-list
    >>;
    return fac!-list
  end;

symbolic procedure polynomial!-content(f,x);
  % returns the polynomial content of f wrt x;
  begin scalar p!-content,!*ezgcd;
    for i:=0:degree!-in!-form(f,x) do
      p!-content := gcdf!*(p!-content,extract(f,x,i));
    return p!-content
  end;

symbolic procedure factor!-by!-xes(f,x,alg!-tower);
  % x = 0 is a n-fold root of f;
  % remove x**n and factor the remaining part;
  % returns ( (sf . n) (sf . n) ... )
  begin scalar xes;
    xes := 0;
    repeat
      xes := xes + 1
    until not null extract(f,x,xes);
    f := quotf(f,!*p2f(x .** xes));
    if !*tralg then <<
      prin2!* "divide out by ";
      prin2!* x;
      if xes > 1 then << prin2!* "**";prin2!* xes >>;
      terpri!* t       >>;
    return
      if variatep f then <<
        (!*k2f x . xes) . cdr factorise1(f,alg!-tower)
      >>
      else list(!*k2f x . xes)
  end;

symbolic smacro procedure cyclotomicp f;
  % f a standard form;
  testx!*!*n!+1 f or testx!*!*n!-1 f;

symbolic procedure trivial!-factor(f);
  % f a (square-free) standard form. We see if f factorises trivially
  % over the integers in some special cases;
  if not contains!-algebraic f or cyclotomicp f then
    for each fac!.n in cdr factorf(f) collect
      car fac!.n
  else list f;

symbolic procedure contains!-algebraic f;
  % does the sf f contain any algebraics?
  if groundp f then nil
  else if domainp f then
    car mvar numr cdr f = 'alg
  else contains!-algebraic(lc f) or contains!-algebraic(red f);

lisp unfluid '(algfac!-level recursedp trivial!-factors);

end;

%%%%%%%%%%%%%%%%%%

% module ALGCREATE

% Routines to create algebraics, and to show them;
%
% An algebraic kernel has the form alpha = (alg . algn) where algn is a
% gensym pointing to the minimal polynomial of alpha.
%

symbolic procedure make!-algebraic!-form(f,x);
  % f standard form in x, degree in x >= 2;
  % returns algebraic form of x, a standard quotient;
  begin scalar canf,alg!-name,alg!-form,degf,lcf,shift,scale;
    degf := degree!-in!-form(f,x);
    alg!-name := gensym1 'alg;          % viz algn;
    alg!-form := 'alg . alg!-name;      % algebraic kernel;
    canf := canon(f,x);
    if degf = 2 or cons!-count car canf < cons!-count f then <<
      shift := cadr canf;    % the shifted and scaled version of f is
      scale := cddr canf;    % better then the original;
      f := car canf
    >>
    else <<
      shift := nil;
      scale := 1;
      lcf := extract(f,x,degf);
      if lcf neq 1 then <<
        f := multf(f,exptf(lcf,degf-1));
        f := numr newsubf(f,quotsq(!*k2q x,!*f2q lcf));
        scale := lcf;
               % x := x/lcf to make f monic;
      >>
    >>;
% at this point f is monic and shifted when this is advantageous; shift
% and scale are set appropriately;
    set(alg!-name,substitute(f,alg!-form));
                          % replace x's by algs, and strip :alg:'s;
    alg!-kord!* := alg!-form . alg!-kord!*;
                          % record for ordering purposes;
    return quotsq(!*f2q differencef(mkalg1 !*k2q alg!-form,shift),
                  !*f2q scale);
  end;

symbolic procedure canon(f,x);
  % canonicise f wrt x, ie shift to remove x**(n-1) term, then monicise.
  % return the new f dotted on to a pair (shift . scale factor),
  % then oldx = (newx - shift)/scale;
  begin scalar degf,lcf,shift,scale;
    degf := ldeg f;               % may be a polynomial in algebraics;
    shift := extract(f,x,degf-1); % ditto
    lcf := lc f;
    if lcf = 1 and null shift then return f . (nil . 1);
    if not null shift then <<
      scale := multf(lcf,degf);
      f := numr newsubf(f,differencesq(!*k2q x,
                                       quotsq(!*f2q shift,
                                              !*f2q scale)));
           % x := x - a[n-1]/(lcf*degf);
      f := multf(f,multf(exptf(lcf,degf-1),degf**degf));  % clear denominator;
      f := numr newsubf(f,quotsq(!*k2q x,!*f2q scale));
         % x := x/(lcf*degf);
    >>
    else <<
      scale := lcf;
      if scale neq 1 then <<
        f := multf(f,exptf(lcf,degf-1));
        f := numr newsubf(f,quotsq(!*k2q x,!*f2q scale));
             % x := x/lcf;
      >>
    >>;
    return f . (shift . scale)
  end;

symbolic procedure simpalgof u;
  begin scalar f,x;
    f:= !*a2f car u;
    x:= mvar f;
    if multivariatep(f,x) then rederr "not univariate";
    if not !*algebraics then rederr "algebraics not selected";
    if degree!-in!-form(f,x) < 2 then
      rederr " degree is < 2"
    else return make!-algebraic!-form(f,x)
  end;

lisp put ('algof,'simpfn,'simpalgof);

symbolic procedure simppolyof u;
  % u is (alg . kernel).
  % return the minimal polynomial of alg using the kernel as
  % the variable (or x if absent);
  begin scalar alg,x,minpoly;
    alg := !*a2f car u;
    x := if null cdr u then 'x else cadr u;
    if not domainp alg or car alg neq '!:alg!: then
      typerr(alg,'algebraic);
    minpoly :=  min!-poly!-of mvar cadr alg;
    return mkalg(subst(x,mvar minpoly,minpoly) ./ 1) ./ 1
  end;

lisp put('polyof,'simpfn,'simppolyof);

symbolic procedure simpshow();
  % lists the current algebraics;
  if null alg!-kord!* then
    printstr "no algebraics created"
  else <<
    for each alg in alg!-kord!* do
      fac!-printsf min!-poly!-of alg;
    length alg!-kord!* ./ 1
  >>;

lisp put('showalgs,'simpfn,'simpshow);

lisp put('alg,'simpfn,'simpalg);

lisp flag('(alg),'full);
            % to get the entire kernel with alg passed to simpalg;

symbolic procedure simpalg(u);
  u .** 1 .* 1 .+ nil ./ 1;

end;

%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGMACROS

% Definition of macros used in algebraic number code;

symbolic smacro procedure groundp u;
  atom u;

symbolic smacro procedure algebraicp u;
  % u a kernel;
  domainp u and eqcar(u,'alg);

symbolic smacro procedure min!-poly!-of u;
  % u a kernel;
  gts cdr u;

symbolic smacro procedure degree!-of!-algebraic u;
  % u a kernel;
  ldeg min!-poly!-of u;

symbolic smacro procedure algebraic!-mvarp u;
  % u a sf;
  not groundp u and algebraicp mvar u;

end;

%%%%%%%%%%%%%%%%%%%%%%%

% module ALGNORM

symbolic procedure contains!-alpha(f,a);
  % does the sf f contain the algebraic a ?
  if groundp f then nil
  else if domainp f then
    (mvar numr cdr f = a) or contains!-alpha(numr cdr f,a)
  else contains!-alpha(lc f,a) or contains!-alpha(red f,a);

symbolic procedure normf(f,alpha);
  % find norm of f over alpha;
  my!-resultantf(min!-poly!-of alpha,f,alpha);

symbolic procedure normf1(f,alg!-tower);
  % produces the norm of the standard form f over
  % Q(alg!-tower);
  if null alg!-tower then f
  else
    (lambda alg;
      if contains!-alpha(f,alg) then
        normf1( my!-resultantf(min!-poly!-of alg,f,alg),cdr alg!-tower )
      else
        normf1( exptf(f,degree!-of!-algebraic alg),cdr alg!-tower )
    )(car alg!-tower);

symbolic procedure simpnorm u;
  % u is (f . list of algebraics).
  % Return the norm of f over the algebraics;
  if null u then nil ./ 1
  else if null cdr u then !*a2f car u ./ 1       % Norm over Z;
  else begin scalar f,algs;
    f := !*a2f car u;                            % collect algebraics;
    algs :=
      for each alg in cdr u collect
        (lambda a;
           if car a neq '!:alg!: then typerr(alg,'algebraic)
           else mvar cadr a)
        (!*a2f alg);
    return(normf1(f,algs) ./ 1)
  end;

put('norm,'simpfn,'simpnorm);

symbolic procedure my!-resultantf(f,g,alpha);
  % f is an untagged algebraic mimimum polynomial,
  % g some polynomial, alpha the algebraic to be 'normed' over;
  % resultant where we substitute ':x: for alpha in f and g;
  % we do this do overcome the problems of algebraics being hidden
  % behind :alg:'s.
  subresultant(resubstf('!:x!:, alpha, f),
               resimpf subst('!:x!:, alpha, g), '!:x!:);

symbolic procedure resubstf(x,alpha,f);
  % substitute x for alpha in the untagged mimimum polynomial f;
  if domainp f or mvar f neq alpha then
    mkalg !*f2q f
  else x .** ldeg f.* mkalg !*f2q lc f .+ resubstf(x,alpha,red f);

symbolic procedure resimpf f;
  % resimps the standard form f into a standard form;
  if domainp f then
    if eqcar(f,'!:alg!:) then mkalg cdr f
    else f
  else addf(resimpf red f,multf(resimpf lc f,!*p2f lpow f));

symbolic procedure resprem(f, g);
  % f, g are SFs.
  % Result is prem(f, g).
  if (domainp f) or (mvar f neq mvar g) or (ldeg f < ldeg g) then f
  else if ldeg f = ldeg g then
    addf(multf(lc g, red f), multf(negf lc f, red g))
  else begin scalar term, tmp, degtmp;
    term := mvar f .** (ldeg f - ldeg g) .* negf  lc f .+ nil;
    tmp := addf(multf(lc g, red f), multf(term, red g));
    degtmp := if domainp tmp or mvar tmp neq mvar f then 0 else ldeg tmp;
    if ldeg f neq 1 + degtmp then
      tmp := multf(exptf(lc g, ldeg f - degtmp - 1), tmp);
    return resprem(tmp, g)
  end;

symbolic procedure subresultant(u, v, x);
  % u, v are SFs : result is resultant of f and g with respect to x.
  % Method used is subresultant PRS.
  begin scalar g, h, d, r, oldkord;
    if mvar u neq x or mvar v neq x then <<
       oldkord := list setkorder list x;
       u := reorder u;
       v := reorder v;
       if mvar u neq x or mvar v neq x then
         REDERR "Subresultant: args must involve eliminating variable"
    >>;
    if ldeg u < ldeg v then <<
      g := u;
      u := v;
      v := g
    >>;
    g := h := 1;
    repeat <<
      d := ldeg u - ldeg v;
      r := resprem(u, v);
      u := v;
      v := quotfail(r, multf(g, exptf(h, d)));
      g := lc u;
      if onep d then h := g
      else if d neq 0 then
        h := quotfail(exptf(g, d),exptf(h, d-1));
    >> until domainp v or mvar u neq mvar v;
    if not null oldkord and not null car oldkord then <<
      setkorder car oldkord;
      v := reorder v
    >>;
    return v
  end;

end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% module ALGRECIP
%
% Calculation of the reciprocals of algebraics;

symbolic procedure algprem(f, g, cf, cg);
  % f, g, numr cf, numr cg are SFs over Z in only algebraic kernels,
  % denr cf & denr cg are positive integers.
  % Result is prem(f, g) . h where h=same lin comb of cf &
  % cg as prem is of f & g.
  if (domainp f) or (mvar f neq mvar g) or (ldeg f < ldeg g) then
    f . cf
  else if ldeg f = ldeg g then
    addf(algmultf(lc g, red f), algmultf(negf lc f, red g)) .
    addsq(quotsq(algmultf(lc g, numr cf) ./ 1, denr cf ./ 1),
          quotsq(algmultf(negf lc f, numr cg) ./ 1, denr cg ./ 1))
  else begin scalar term, tmp, newcofac, extra!-factor, degtmp;
    term := mvar f .** (ldeg f - ldeg g) .* negf  lc f .+ nil;
    tmp := addf(algmultf(lc g, red f), algmultf(term, red g));
    degtmp := if numberp tmp or mvar tmp neq mvar f then 0 else ldeg tmp;
    newcofac := addsq(quotsq(algmultf(lc g, numr cf) ./ 1, denr cf ./ 1),
                      quotsq(algmultf(term, numr cg) ./ 1, denr cg ./ 1));
    if ldeg f neq 1 + degtmp then <<
      extra!-factor := algexptf(lc g, ldeg f - degtmp - 1);
      tmp := algmultf(extra!-factor, tmp);
      newcofac := quotsq(algmultf(extra!-factor, numr newcofac) ./ 1,
                         denr newcofac ./ 1)
    >>;
    return algprem(tmp, g, newcofac, cg)
  end;

symbolic procedure algexptf(f, n);
  % f is a SF over Z in only alg kernels, n is a non-negative integer.
  % Result is SF over Z in only alg kernels for f**n.
  if zerop n then 1
  else if onep n then f
  else if evenp n then algexptf(algmultf(f, f), n/2)
  else algmultf(f, algexptf(algmultf(f, f), n/2));

symbolic procedure algrecip(f);
  % f is a SF involving an algebraic [unchecked, and ASSUMEd to be the mvar]
  % result is SQ for 1/f with all algebraics in the numerator.
  % Method used is subresultant PRS for finding gcd and the cofactor[=answer]
  if null f then
    rederr "attempt to take reciprocal of 0"
  else if numberp f then
    if minusp f then (-1) ./ (-f) else 1 ./ f
  else begin scalar dmode!*, cu, cv, u, v, g, h, d, tmp, invg, invh,
                    invg!*h!*!*d, r, oldh;
    dmode!* := nil; % change domain to integers - restored on exit
    g := h := 1;
    invg := invh := 1 ./ 1;
    u := min!-poly!-of mvar f;
    cu := nil ./ 1;
    v := f;
    cv := 1 ./ 1;
    repeat <<
      d := ldeg u - ldeg v;
      tmp := algprem(u, v, cu, cv);
      r := car tmp;
      if null r then
        rederr "unexpected factor of a minimal polynomial";
      if not(numberp r or mvar r neq mvar v) then <<
        u := v;
        cu := cv;
        invg!*h!*!*d := quotsq(algmultf(numr invg,
                                        algexptf(numr invh, d)) ./ 1,
                               (denr invg * denr(invh) ** d) ./ 1);
        v := quotfail(algmultf(r, numr invg!*h!*!*d), denr invg!*h!*!*d);
        cv := quotsq(algmultf(numr cdr tmp, numr invg!*h!*!*d) ./ 1,
                     denr cdr tmp * denr invg!*h!*!*d ./ 1);
        g := lc u;
        invg := algrecip g;
        if onep d then <<
          h := g;
          invh := invg
        >>
        else <<
          oldh := h;
          h := quotfail(algmultf(algexptf(g, d),
                                 algexptf(numr invh, d-1)),
                        denr(invh) ** (d-1));
          invh := quotsq(algmultf(algexptf(oldh, d-1),
                                  algexptf(numr invg, d)) ./ 1,
                         denr(invg) ** d ./ 1)
        >>
      >>
    >> until numberp r or mvar r neq mvar v;
    r := algrecip r;
    return quotsq(algmultf(numr cdr tmp, numr r) ./ 1,
                  (denr r * denr cdr tmp) ./ 1)
  end;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arnum.red0000644000175000017500000006044611526203062023456 0ustar  giovannigiovannimodule arnum;  % Support for algebraic rationals.

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(arnum arinv),'(contrib arnum));

fluid '(!*bezout);

global '(domainlist!* arbase!* arvars!* repowl!* curdefpol!*
     !*acounter!* !*extvar!* reexpressl!*);

!*acounter!* := 0;    %counter for number of extensions;

!*bezout := t;

!*extvar!* := 'a;     %default print character for primitive element;

fluid '(!*arnum dmode!* !*exp !*chk!-reducibility !*reexpress
        !*arinv !*arquot !*arq alglist!*);

global '(timer timef);

switch arnum; % chk!-reducibility;

timer:=timef:=0;

domainlist!*:=union('(!:ar!:),domainlist!*);

% Definition of DEFPOLY changed by F. Kako.

symbolic procedure defpoly u;
   begin
     if null(dmode!* eq '!:ar!:) then on 'arnum;
     for each j in u do
         (if eqexpr j then
          if cadr j=0 then defpoly1 caddr j
           else if caddr j=0 then defpoly1 cadr j
           else rerror(arnum,1,list(cadr j,"=",caddr j,
              "  is not a proper defining polynomial"))
          else defpoly1 j)
   end;

symbolic procedure defpoly1 u;
   begin scalar x,alglist!*;
      x := aeval u;
      if x = 0 then mkextension u else mkextension x
   end;

rlistat '(defpoly);

symbolic procedure mkextension u;
   if null curdefpol!* then initalgnum u
    else begin scalar !*exp;
        !*exp := t;
        primitive!_elem !*a2f u
     end;

symbolic procedure initalgnum u;
   begin scalar dmode!*,alglist!*,!*exp,x;
     !*exp := t;
     arbase!* := nil;
     u := numr simp0 u;
     if x := not!_in!_extension u then u := x
      else return;
     if lc u neq 1 then u := monicize u;
     % rederr("defining polynomial must be monic");
     curdefpol!* := u;
     for j:=0:(ldeg u-1) do
         arbase!* := (if j=0 then 1
                       else mksp(mvar u,j)) . arbase!*;
     arvars!* := mvar u . arvars!*;
     mk!-algebraic!-number!-vars list mvar u;
     repowl!* := lpow u . negf red u
   end;

symbolic procedure put!-current!-representation(u,v);
   put(u,'currep,v);

symbolic procedure get!-current!-representation u;
   get(u,'currep);

symbolic procedure mkdar u;
   %puts any algebraic number domain element into its tagged form.
   %updated representations (through field extension) are accessed here;
   ((if x then x else '!:ar!: . !*k2f u) ./ 1)
    where x = get!-current!-representation u;

symbolic procedure release u;
   %Undeclares elements of list u to be algebraic numbers;
   for each j in u do
     if atom j then remprop(j,'idvalfn)
      else clear1 {!*a2k j};

symbolic procedure mk!-algebraic!-number!-vars u;
   %Declares elements of list u to be algebraic numbers;
   for each j in u do
     if atom j then put(j,'idvalfn,'mkdar)
      else setk(!*a2k j,mk!*sq mkdar j);

symbolic procedure uncurrep u;
   for each j in u do remprop(j,'currep);

symbolic procedure update!-extension u;
   %Updates representation of elements in list u;
    for each j in u do
       ((x and put(j,'currep,numr simp prepf cdr x))
      where x = get(j,'currep));

symbolic procedure express!-in!-arvars u;
   %u is an untagged rational number. Result is equivalent algebraic
   %number expressed in input variables.
   rerror(arnum,2,"Switch reexpress not yet implemented");
%  begin scalar x;
%    for each j in reexpressl!* do
%        x := extmult(extadd(...,j),x);
%    return solve!-for!-arvars x
%  end;

symbolic procedure mkreexpressl;
   %Sets up the homogenous part of the system to be solved for
   %expressing a primitive element expression in terms of the
   %input variables.
   reexpressl!* := nil;
%  begin scalar x;
%


put('reexpress,'simpfg,'((t (mkreexpressl))
             (nil (setq reexpressl!* nil))));

%*** tables for algebraic rationals ***;

flag('(!:ar!:),'field);
put('arnum,'tag,'!:ar!:);
put('!:ar!:,'dname,'arnum);
put('!:ar!:,'i2d,'!*i2ar);
%put('!:ar!:,'!:rn!:,'ar2rn);
put('!:ar!:,'!:rd!:,'arconv);
put('!:ar!;,'!:cr!:,'arconv);
put('!:ar!:,'!:mod!:,'arconv);
put('!:ar!:,'minusp,'arminusp!:);
put('!:ar!:,'zerop,'arzerop!:);
put('!:ar!:,'onep,'aronep!:);
put('!:ar!:,'plus,'arplus!:);
put('!:ar!:,'difference,'ardifference!:);
put('!:ar!:,'times,'artimes!:);
put('!:ar!:,'quotient,'arquotient!:);
put('!:ar!:,'factorfn,'arfactor!:);
put('!:ar!:,'rationalizefn,'arrationalize!:);
put('!:ar!:,'prepfn,'arprep!:);
put('!:ar!:,'intequivfn,'arintequiv!:);
put('!:ar!:,'prifn,'arprn!:);
put('!:rn!:,'!:ar!:,'rn2ar);
flag('(!:ar!:),'ratmode);

symbolic procedure rn2ar u;
   '!:ar!: . if cddr u=1 then cadr u else u;

symbolic procedure ar2rn u;
   if cadr u eq '!:rn!: then cdr u
    else if numberp cdr u then '!:rn!: . (cdr u . 1)
    else rerror(arnum,3,list "Conversion to rational not possible");

symbolic procedure !*i2ar u;
   '!:ar!: . u;

symbolic procedure arconv u;
   rerror(arnum,4,list("Conversion between current extension and",
               get(car u,'dname),"not possible"));


symbolic procedure arminusp!: u;
   minusf cdr u;

symbolic procedure arzerop!: u;
   null cdr u;

symbolic procedure aronep!: u;
   cdr u=1;

symbolic procedure arintequiv!: u;
   if numberp cdr u then cdr u
    else if (cadr u eq '!:rn!:) and (cdddr u=1) then caddr u
    else nil;

smacro procedure mkar u;
 '!:ar!: . u;

symbolic procedure arplus!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar addf(cdr u,cdr v)
   end;

symbolic procedure ardifference!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar addf(cdr u,negf cdr v)
   end;

symbolic procedure artimes!:(u,v);
   begin scalar dmode!*,!*exp;
     !*exp := t;
     return mkar reducepowers multf(cdr u,cdr v)
   end;

symbolic procedure arquotient!:(u,v);
   begin scalar r,s,y,z,dmode!*,!*exp;
     !*exp := t;
     if domainp cdr v then
          return mkar multd(<>),s);
     return mkar s
    end;

symbolic procedure arfactor!: v;
   if domainp v then list v
    else if null curdefpol!* then factorf v
    else
   begin scalar w,x,y,z,aftrs,ifctr,ftrs,mva,mvu,
         dmode!*,!*exp;
     timer:=timef:=0;
     !*exp := t;
     mva := mvar curdefpol!*;
     mvu := mvar v;
     ifctr := factorft numr(v := fd2q v);
     dmode!* := '!:ar!:;
     w := if denr v neq 1 then mkrn(car ifctr,denr v)
           else car ifctr;
     for each f in cdr ifctr do
         begin scalar l;
           y := numr subf1(car f,nil);
           if domainp y then <>;
           y := sqfrnorm y;
           dmode!* := nil;
           ftrs := factorft car y;
           dmode!* := '!:ar!:;
           if cadr y neq 0 then
              l := list(mvu . prepf addf(!*k2f mvu,
                                      negf multd(cadr y,!*k2f mva)));
           y := cddr y;
           for each j in cdr ftrs do
              <>
         end;
      %print timer; print timef;
      return w . sort!-factors aftrs
    end;

symbolic procedure afactorize u;
   begin scalar ftrs,x,!*exp; integer n;
     !*exp := t;
     if cdr u then <>;
     x := arfactor!: !*a2f car u;
     ftrs := (0 . mk!*sq(car x ./ 1)) . nil;
     for each j in cdr x do
       for k := 1:cdr j do
           ftrs := ((n := n+1) . mk!*sq(car j ./ 1)) . ftrs;
     return multiple!-result(ftrs,nil)
   end;


put('algeb!_factorize,'psopfn,'afactorize);

symbolic procedure arprep!: u;                         %u;
   prepf if !*reexpress then express!-in!-arvars cdr u
      else cdr u;

%symbolic procedure simpar u;
%('!:ar!: . !*a2f car u) ./ 1;

%put('!:ar!:,'simpfn,'simpar);


symbolic procedure arprn!: v;
   ( if atom u or (car u memq '(times expt)) then maprin u
     else <>) where u = prepsq!*(cdr v ./ 1);


%*** utility functions ***;

symbolic procedure monicize u;
   %makes standard form u monic by the appropriate variable subst.;
   begin scalar a,mvu,x;
         integer n;
     x := lc u;
     mvu := mvar u;
     n := ldeg u;
     !*acounter!* := !*acounter!* + 1;
     a := intern compress append(explode !*extvar!*,
                 explode !*acounter!*);
     u := multsq(subf(u,list(mvu . list('quotient,a,x))),
                 x**(n-1) ./ 1);
     mk!-algebraic!-number!-vars list mvu;
     put!-current!-representation(mvu,
                  mkar(a to 1 .* ('!:rn!: . 1 . x)
                       .+ nil));
     terpri();
     prin2 "defining polynomial has been monicized";
     terpri();
     maprin prepsq u;
     terpri!* t;
     return !*q2f u
   end;


symbolic procedure polynorm u;
   begin scalar dmode!*,x,y;
         integer n;
     n := ldeg curdefpol!*;
     x := fd2q u;
     y := resultantft(curdefpol!*,numr x,mvar curdefpol!*);
     dmode!* := '!:ar!:;
     return if denr x = 1 then y
         else !*q2f multsq(y ./ 1,1 ./ (denr x)**n)
   end;

symbolic procedure resultantft(u,v,w);
   resultant(u,v,w);

symbolic procedure factorft u;
   begin scalar dmode!*; return fctrf u end;

symbolic procedure fd2q u;
   %converts a s.f. over ar to a s.q. over the integers;
   if atom u then u ./ 1
    else if car u eq '!:ar!: then fd2q cdr u
    else if car u eq '!:rn!: then cdr u
    else addsq(multsq(!*p2q lpow u,fd2q lc u),fd2q red u);

symbolic procedure sqfrnorm u;
   begin scalar l,norm,y; integer s;
     y := u;
     if algebnp u then go to b;
     a: s := s-1;
        l := list(mvar u . prepf
          addf(!*k2f mvar u,multd(s,!*k2f mvar curdefpol!*)));
        y := numr subf1(u,l);
        if null algebnp y then go to a;
     b: norm := polynorm y;
        if not ar!-sqfrp norm then go to a;
     return norm . (s . y)
   end;

symbolic procedure algebnp u;
   if atom u then nil
    else if car u eq '!:ar!: then t
    else if domainp u then nil
    else algebnp lc u or algebnp red u;

symbolic procedure ar!-sqfrp u;
   % This is same as sqfrp in gint module.
   domainp gcdf!*(u,diff(u,mvar u));

symbolic procedure primitive!_elem u;
   begin scalar a,x,y,z,newu,newdefpoly,olddefpoly;
     if x := not!_in!_extension u then u := x
      else return;
     !*acounter!* := !*acounter!* + 1;
     a := intern compress append(explode !*extvar!*,
                 explode !*acounter!*);
     x := sqfrnorm u;
     newdefpoly := !*q2f subf(car x,list(mvar car x . a));
     olddefpoly := curdefpol!*;
     newu := !*q2f subf(cddr x,list(mvar car x . a));
     rmsubs();
     release arvars!*;
     begin scalar !*chk!-reducibility;
       initalgnum prepf newdefpoly end;
     y := gcdf!*(numr simp prepf newu,olddefpoly);
     arvars!* := mvar car x . arvars!*;
     mk!-algebraic!-number!-vars arvars!*;
     put!-current!-representation(mvar olddefpoly,
                  z := quotf!*(negf red y,lc y));
     put!-current!-representation(mvar car x,
                  addf(mkar !*k2f a,
                       multf(!*n2f cadr x,z)));
     rmsubs();
     update!-extension arvars!*;
     terpri!* t;
     prin2!* "*** Defining polynomial for primitive element:";
     terpri!* t;
     maprin prepf curdefpol!*;
     terpri!* t
   end;

symbolic procedure not!_in!_extension u;
   %We still need a criterion which branch to choose;
   %Isolating intervals would do;
   begin scalar ndp,x; integer cld;
     if null !*chk!-reducibility then return u;
     cld := ldeg u;
     ndp := u;
     x := if curdefpol!* then arfactor!: u
           else factorf u;
     for each j in cdr x do
         if ldeg car j < cld then
            <>;
     if cld=1 then <>
      else return ndp
   end;

symbolic procedure split!_field1(u,v);
   % Determines the minimal splitting field for u.
   begin scalar a,ftrs,mvu,q,x,y,z,roots,bpoly,minpoly,newminpoly,
                polys,newfactors,dmode!*,!*exp,!*chk!-reducibility;
         integer indx,lcu,k,n,new!_s;
    off 'arnum;  %crude way to clear previous extensions;
    !*exp := t;
    u := !*q2f simp!* u;
    mvu := mvar u;
    lcu := lc u;
    if lcu neq 1
       then u := !*q2f multsq(subf(u,list(mvu .
                                          list('quotient,mvu,lcu))),
                              lcu**(ldeg u - 1) ./ 1);
    indx := 1;
    polys := (1 . u) . polys;
    !*acounter!* := !*acounter!* + 1;
    a := intern compress append(explode !*extvar!*,
            explode !*acounter!*);
    minpoly := newminpoly := numr subf(u,list(mvu . a));
    dmode!* := '!:ar!:;
    mkextension prepf minpoly;
    roots := mkar !*k2f  a . roots;
     b: polys := for each j in polys collect
            if indx=car j then
               car j . quotf!*(cdr j,
                    addf(!*k2f mvu,negf car roots))
             else j;
        k := 1;
        indx := 0;
        for each j in polys do
            begin scalar l;
              x := sqfrnorm cdr j;
              if cadr x neq 0 then
                 l := list(mvu . prepf addf(!*k2f mvu,
                                         negf multd(cadr x,!*k2f a)));
              z := cddr x;
              dmode!* := nil;
              ftrs := cdr factorf car x;
              dmode!* := '!:ar!:;
              for each qq in ftrs do
                < ldeg newminpoly then
                     <>;
                  z := quotf!*(z,y);
                  if l then y := numr subf(y,l);
                  if ldeg y=1 then
                     roots := quotf(negf red y,lc y) . roots
                   else <>>>
            end;
        if null newfactors then
       <>;
    !*acounter!* := !*acounter!* + 1;
    a := intern compress append(explode !*extvar!*,
                    explode !*acounter!*);
        newminpoly := numr subf(newminpoly,list(mvu . a));
        bpoly := numr subf(bpoly,list(mvu . a));
        rmsubs();
        release arvars!*;
        initalgnum prepf newminpoly;
        x := gcdf!*(minpoly,numr simp prepf bpoly);
    mk!-algebraic!-number!-vars arvars!*;
    put!-current!-representation(mvar minpoly,
                     z := quotf!*(negf red x,lc x));
        rmsubs();
        roots := addf(mkar !*k2f a,multf(!*n2f new!_s,z)) .
                      for each j in roots collect numr subf(cdr j,nil);
        polys := for each j in newfactors collect
                     car j . numr simp prepf cdr j;
        newfactors := nil;
        minpoly := newminpoly;
        go to b
  end;

symbolic procedure split!-field!-eval u;
   begin scalar x;
     if length u > 2
       then rerror(arnum,5,
                  "Split!_field called with wrong number of arguments");
     x := split!_field1(car u,if cdr u then cadr u else nil);
     dmode!* := '!:ar!:;
     %The above is necessary for working with the results.
     return x
  end;

put('split!_field,'psopfn,'split!-field!-eval);

symbolic procedure arrationalize!: u;
   %We should actually factorize the denominator first to
   %make sure that the result is in lowest terms. ????
   begin scalar x,y,z,dmode!*;
     if domainp denr u then return quotf(numr u,denr u) ./ 1;
     if null algebnp denr u then return u;
     x := polynorm numr fd2q denr u;
     y := multsq(fd2q multf(numr u,quotf!*(x,denr u)),1 ./ x);
     dmode!* := '!:ar!:;
     x := numr subf(denr y,nil);
     y := numr subf(numr y,nil);
     z := lnc x;
     return quotf(y,z) ./ quotf(x,z)
   end;

%put('rationalize,'simpfn,'rationalize); its now activated by a switch.
put('polynorm,'polyfn,'polynorm);

%*** support functions ***;

comment the function ilnrsolve and others are identical to the
    %ones in matr except they work only on integers here;
        %there should be better algorithms;


symbolic procedure reducepowers u;
   %reduces powers with the help of the defining polynomial;
   if domainp u or (ldeg u>
                          else 0 . 1) . car v);
                  v := cdr v;
                  r>>>>;
     return v
   end;

symbolic procedure mkqcol u;
   %u is an ar domainelement result is a matrix form
   %representing u as a coefficient matrix of the ar base;
   begin scalar x,v;
     v := for each j in arbase!* collect
             if atom j then list ratn u
              else if domainp u then list(0 . 1)
              else if j=lpow u then <>
               else list(0 . 1);
     return v
   end;

symbolic procedure ratn u;
   if null u then 0 . 1
    else if atom u then u . 1
    else if car u eq '!:rn!: then cdr u
    else rerror(arnum,6,"Illegal domain in :ar:");

symbolic procedure inormmat u;
   begin integer y; scalar z;
%    x := 1;
     for each v in u do
       <>;
     return reverse z
   end;

symbolic procedure ilcm(u,v);
   if u=0 or v=0 then 0
    else if u=1 then v
    else if v=1 then u
    else u*v/gcdn(u,v);

symbolic procedure ilnrsolve(u,v);
   %u is a matrix standard form, v a compatible matrix form;
   %value is u**(-1)*v;
   begin integer n;
     n := length u;
     v := ibacksub(ibareiss inormmat ar!-augment(u,v),n);
     u := ar!-rhside(car v,n);
     v := cdr v;
    return for each j in u collect
              for each k in j collect mkrn(k,v)
    end;

symbolic procedure ar!-augment(u,v);
   % Same as augment in bareiss module.
   if null u then nil
    else append(car u,car v) . ar!-augment(cdr u,cdr v);


symbolic procedure ar!-rhside(u,m);
   % Same as rhside in bareiss module.
   if null u then nil else pnth(car u,m+1) . ar!-rhside(cdr u,m);

 symbolic procedure ibareiss u;
   %as in matr but only for integers;
   begin scalar ik1,ij,kk1,kj,k1j,k1k1,ui,u1,x;
    integer k,k1,aa,c0,ci1,ci2;
    aa:= 1;
    k:= 2;
    k1:=1;
    u1:=u;
    go to pivot;
    agn: u1 := cdr u1;
    if null cdr u1 or null cddr u1 then return u;
    aa:=nth(car u1,k);              %aa := u(k,k);
    k:=k+2;
    k1:=k-1;
    u1:=cdr u1;
    pivot:  %pivot algorithm;
    k1j:= k1k1 := pnth(car u1,k1);
    if car k1k1 neq 0 then go to l2;
    ui:= cdr u1;                    %i := k;
    l:   if null ui then return nil
     else if car(ij := pnth(car ui,k1))=0
      then go to l1;
    l0:  if null ij then go to l2;
    x:= car ij;
    rplaca(ij,-car k1j);
    rplaca(k1j,x);
    ij:= cdr ij;
    k1j:= cdr k1j;
    go to l0;
    l1:  ui:= cdr ui;
    go to l;
    l2:  ui:= cdr u1;                    %i:= k;
    l21: if null ui then return; %if i>m then return;
    ij:= pnth(car ui,k1);
    c0:= car k1k1*cadr ij-cadr k1k1*car ij;
    if c0 neq 0 then go to l3;
    ui:= cdr ui;                    %i:= i+1;
    go to l21;
    l3:  c0:= c0/aa;
    kk1 := kj := pnth(cadr u1,k1);  %kk1 := u(k,k-1);
    if cdr u1 and null cddr u1 then go to ev0
     else if ui eq cdr u1 then go to comp;
    l31: if null ij then go to comp;     %if i>n then go to comp;
    x:= car ij;
    rplaca(ij,-car kj);
    rplaca(kj,x);
    ij:= cdr ij;
    kj:= cdr kj;
    go to l31;
    %pivoting complete;
     comp:
    if null cdr u1 then go to ev;
    ui:= cddr u1;                   %i:= k+1;
     comp1:
    if null ui then go to ev;       %if i>m then go to ev;
    ik1:= pnth(car ui,k1);
    ci1:= (cadr k1k1*car ik1-car k1k1*cadr ik1)/aa;
    ci2:= (car kk1*cadr ik1-cadr kk1*car ik1)/aa;
    if null cddr k1k1 then go to comp3;%if j>n then go to comp3;
    ij:= cddr ik1;                  %j:= k+1;
    kj:= cddr kk1;
    k1j:= cddr k1k1;
     comp2:
    if null ij then go to comp3;
    rplaca(ij,(car ij*c0+car kj*ci1+car k1j*ci2)/aa);
    ij:= cdr ij;
    kj:= cdr kj;
    k1j:= cdr k1j;
    go to comp2;
     comp3:
    ui:= cdr ui;
    go to comp1;
     ev0:if c0=0 then return;
     ev: kj := cdr kk1;
    x := cddr k1k1;                 %x := u(k-1,k+1);
    rplaca(kj,c0);
     ev1:kj:= cdr kj;
    if null kj then go to agn;
    rplaca(kj,(car k1k1*car kj-car kk1*car x)/aa);
    x := cdr x;
    go to ev1
    end;

 symbolic procedure ibacksub(u,m);
    begin scalar ij,ijj,ri,uj,ur; integer i,jj,summ,detm,det1;
    %n in comments is number of columns in u;
    if null u then rerror(arnum,7,"Singular matrix");
    ur := reverse u;
    detm := car pnth(car ur,m);             %detm := u(i,j);
    if detm=0 then rerror(arnum,8,"Singular matrix");
    i := m;
     rows:
    i := i-1;
    ur := cdr ur;
    if null ur then return u . detm;
         %if i=0 then return u . detm;
    ri := car ur;
    jj := m+1;
    ijj:=pnth(ri,jj);
     r2: if null ijj then go to rows;    %if jj>n then go to rows;
    ij := pnth(ri,i);               %j := i;
    det1 := car ij;                 %det1 := u(i,i);
    uj := pnth(u,i);
    summ := 0;                      %summ := 0;
     r3: uj := cdr uj;                   %j := j+1;
    if null uj then go to r4;       %if j>m then go to r4;
    ij := cdr ij;
    summ := summ+car ij*nth(car uj,jj);
         %summ:=summ+u(i,j)*u(j,jj);
    go to r3;
     r4: rplaca(ijj,(detm*car ijj-summ)/det1);
         %u(i,j):=(detm*u(i,j)-summ)/det1;
    jj := jj+1;
    ijj := cdr ijj;
    go to r2
    end;

initdmode 'arnum;

put('arnum,'simpfg,
      '((t (setdmode (quote arnum) t))
    (nil (setdmode (quote arnum) nil) (release arvars!*)
         (uncurrep arvars!*) (setq curdefpol!* nil)
         (setq arvars!* nil))));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arnum.bib0000644000175000017500000000133211526203062023425 0ustar  giovannigiovanni% Bibliography entry for arnum.tex.

@INPROCEEDINGS{Bradford:86,
  AUTHOR = "R. J. Bradford and A. C. Hearn and J. A. Padget and E.
            Schr{\"u}fer",
  TITLE = "Enlarging the {REDUCE} Domain of Computation",
  BOOKTITLE = "Proceedings of {SYMSAC} '86", YEAR = 1986,
  PAGES = "100-106"}

@INPROCEEDINGS{Trager:76,
  AUTHOR = "B. M. Trager",
  TITLE = "Algebraic Factoring and Rational Function Integration",
  BOOKTITLE = "Proceedings of {SYMSAC} '76",
  YEAR = 1976, PAGES = "196-208"}

@INCOLLECTION{Davenport:81,
  AUTHOR = "James Harold Davenport",
  TITLE = "On the Integration of Algebraic Functions",
  BOOKTITLE = "Lecture Notes in Computer Science",
  PUBLISHER = "Springer Verlag",
  VOLUME = 102, YEAR = 1981}
mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arnum.tex0000644000175000017500000001751011526203062023476 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{Algebraic Number Fields}
\date{}
\author{Eberhard Schr\"{u}fer \\
Institute SCAI.Alg   \\
German National Research Center for Information Technology (GMD) \\
Schloss Birlinghoven \\
D-53754 Sankt Augustin \\
Germany       \\[0.05in]
Email: schruefer@gmd.de}
\begin{document}
\maketitle

\index{algebraic number fields}
\index{algebraic numbers}
\index{ARNUM package}
Algebraic numbers are the solutions of an irreducible polynomial over
some ground domain.  \index{i} The algebraic number $i$ (imaginary
unit), \index{imaginary unit} for example, would be defined by the
polynomial $i^2 + 1$.  The arithmetic of algebraic number $s$ can be
viewed as a polynomial arithmetic modulo the defining polynomial.

Given a defining polynomial for an algebraic number $a$
\begin{eqnarray*}
a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0}
\end{eqnarray*}

All algebraic numbers which can be built up from $a$ are then of the form:
\begin{eqnarray*}
{r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ... ~+~ {r_0}
\end{eqnarray*}
where the $r_j$'s are rational numbers.

\index{+ ! algebraic numbers}
The operation of addition is defined by
\begin{eqnarray*}
({r_{n-1}} {a ^{n-1}} ~+~ {r_{n-2}} {a ^{n-2}} ~+~ ...) ~ + ~
({s_{n-1}} {a ^{n-1}} ~+~ {s_{n-2}} {a ^{n-2}} ~+~ ...) ~ =  \\
({r_{n-1}+s_{n-1}}) {a ^{n-1}} ~+~ ({r_{n-2}+s_{n-2}}) {a ^{n-2}} ~+~ ...
\end{eqnarray*}

\index{* ! algebraic numbers}
Multiplication of two algebraic numbers can be performed by normal
polynomial multiplication followed by a reduction of the result with the
help of the defining polynomial.

\begin{eqnarray*}
({r_{n-1}} {a ^{n-1}} + {r_{n-2}} {a ^{n-2}} + ...) ~ \times ~
({s_{n-1}} {a ^{n-1}} + {s_{n-2}} {a ^{n-2}} + ...) = \\
 {r_{n-1}} {s ^{n-1}}{a^{2n-2}} +  ... ~ {\bf modulo} ~
a^n ~ + ~ {p _{n-1}} {a ^ {n -1}} ~ + ~ ... ~ + ~ {p_0} \\
= ~~~{q_{n-1}} a^{n-1} ~ + ~ {q _{n-2}} {a ^ {n -2}} ~ + ~ ...
\end{eqnarray*}

\index{/ ! algebraic numbers}
Division of two algebraic numbers r and s yields another algebraic number q.

$ \frac{r}{s} = q$ or $ r = q s $.

The last equation written out explicitly reads

\begin{eqnarray*}
\lefteqn{({r_{n-1}} {a^{n-1}} + {r_{n-2}} {a^{n-2}} + \ldots)} \\
& = & ({q_{n-1}} {a^{n-1}} + {q_{n-2}} {a^{n-2}} + \ldots) \times
({s_{n-1}} {a^{n-1}} + {s_{n-2}} {a^{n-2}} + \ldots) \\
& & {\bf modulo} (a^n + {p _{n-1}} {a^{n -1}} + \ldots) \\
& = & ({t_{n-1}} {a^{n-1}} + {t_{n-2}} {a^{n-2}} + \ldots)
\end{eqnarray*}

The $t_i$ are linear in the $q_j$.  Equating equal powers of $a$ yields a
linear system for the quotient coefficients $q_j$.

With this, all field operations for the algebraic numbers are available.  The
translation into algorithms is straightforward.  For an implementation we
have to decide on a data structure for an algebraic number.  We have chosen
the representation REDUCE normally uses for polynomials, the so-called
standard form.  Since our polynomials have in general rational coefficients,
we must allow for a rational number domain inside the algebraic number.

\begin{tabbing}
\s{algebraic number} ::= \\
\hspace{.25in} \= {\tt :ar:} . \s{univariate polynomial over the rationals}
\\[0.05in]

\s{univariate polynomial over the rationals} ::= \\
\> \s{variable} .** \s{ldeg} .* \s{rational} .+ \s{reductum} \\[0.05in]

\s{ldeg} ::= integer \\[0.3in]

\s{rational} ::= \\
\> {\tt :rn:} . \s{integer numerator} . \s{integer denominator} :
integer \\[0.05in]

\s{reductum} ::= \s{univariate polynomial} : \s{rational} : nil
\end{tabbing}

This representation allows us to use the REDUCE functions for adding and
multiplying polynomials on the tail of the tagged algebraic number.  Also,
the routines for solving linear equations can easily be used for the
calculation of quotients.  We are still left with the problem of
introducing a particular algebraic number.  In the current version this is
done by giving the defining polynomial to the statement {\bf defpoly}.  The
\index{DEFPOLY statement}
algebraic number sqrt(2), for example, can be introduced by
\begin{verbatim}
   defpoly sqrt2**2 - 2;
\end{verbatim}

This statement associates a simplification function for the
translation of the variable in the defining polynomial into its tagged
internal form and also generates a power reduction rule used by the
operations {\bf times} and {\bf quotient} for the reduction of their
result modulo the defining polynomial.  A basis for the representation
of an algebraic number is also set up by the statement.  In the
working version, the basis is a list of powers of the indeterminate of
the defining polynomial up to one less then its degree.  Experiments
with integral bases, however, have been very encouraging, and these
bases might be available in a later version.  If the defining
polynomial is not monic, it will be made so by an appropriate
substitution.

\example \index{ARNUM package ! example}

\begin{verbatim}
     defpoly sqrt2**2-2;

     1/(sqrt2+1);

     sqrt2 - 1

     (x**2+2*sqrt2*x+2)/(x+sqrt2);

     x + sqrt2

     on gcd;

     (x**3+(sqrt2-2)*x**2-(2*sqrt2+3)*x-3*sqrt2)/(x**2-2);

       2
     (x  - 2*x - 3)/(x - sqrt2)

     off gcd;

     sqrt(x**2-2*sqrt2*x*y+2*y**2);

     abs(x - sqrt2*y)
\end{verbatim}

Until now we have dealt with only a single algebraic number.  In practice
this is not sufficient as very often several algebraic numbers appear in an
expression.  There are two possibilities for handling this: one can use
multivariate extensions \cite{Davenport:81} or one can construct a defining
polynomial that contains all specified extensions.  This package implements
the latter case (the so called primitive representation).  The algorithm we
use for the construction of the primitive element is the same as given by
Trager \cite{Trager:76}.  In the implementation, multiple extensions can be
given as a list of equations to the statement {\bf defpoly}, which, among other
things, adds the new extension to the previously defined one.  All
algebraic numbers are then expressed in terms of the primitive element.


\example\index{ARNUM package ! example}

\begin{verbatim}
   defpoly sqrt2**2-2,cbrt5**3-5;

   *** defining polynomial for primitive element:

     6       4        3        2
   a1  - 6*a1  - 10*a1  + 12*a1  - 60*a1 + 17

   sqrt2;

             5             4              3              2
   48/1187*a1  + 45/1187*a1  - 320/1187*a1  - 780/1187*a1  +


   735/1187*a1 - 1820/1187

   sqrt2**2;

   2
\end{verbatim}
\newpage
We can provide factorization of polynomials over the algebraic number
domain by using Trager's algorithm.  The polynomial to be factored is first
mapped to a polynomial over the integers by computing the norm of the
polynomial, which is the resultant with respect to the primitive element of
the polynomial and the defining polynomial.  After factoring over the
integers, the factors over the algebraic number field are recovered by GCD
calculations.

\example\index{ARNUM package ! example}

\begin{verbatim}
   defpoly a**2-5;

   on factor;

   x**2 + x - 1;

   (x + (1/2*a + 1/2))*(x - (1/2*a - 1/2))
\end{verbatim}
\index{SPLIT\_FIELD function}
We have also incorporated a function {\bf split\_field} for the calculation
of a primitive element of minimal degree for which a given polynomial splits
into linear factors.  The algorithm as described in Trager's article is
essentially a repeated primitive element calculation.

\example\index{ARNUM package ! example}

\begin{verbatim}
   split_field(x**3-3*x+7);

   *** Splitting field is generated by:

     6        4        2
   a2  - 18*a2  + 81*a2  + 1215



            4          2
   {1/126*a2  - 5/42*a2  - 1/2*a2 + 2/7,


              4          2
    - (1/63*a2  - 5/21*a2  + 4/7),


           4          2
   1/126*a2  - 5/42*a2  + 1/2*a2 + 2/7}


   for each j in ws product (x-j);

    3
   x  - 3*x + 7
\end{verbatim}

A more complete description can be found in \cite{Bradford:86}.
\bibliography{arnum}
\bibliographystyle{plain}
\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/arnum/arnum.tst0000644000175000017500000000271111526203062023505 0ustar  giovannigiovanni% Test of algebraic number package.

defpoly sqrt2**2-2;

1/(sqrt2+1);

(x**2+2*sqrt2*x+2)/(x+sqrt2);

on gcd;

(x**3+(sqrt2-2)*x**2-(2*sqrt2+3)*x-3*sqrt2)/(x**2-2);

off gcd;

sqrt(x**2-2*sqrt2*x*y+2*y**2);

off arnum;  %to start a new algebraic extension.


defpoly cbrt5**3-5;

on rationalize;

1/(x-cbrt5);

off rationalize;

off arnum;  %to start a new algebraic extension.


%The following examples are taken from P.S. Wang Math. Comp. 30,
%    134,(1976),p.324.

on factor;

defpoly i**2+1=0;

w0 := x**2+1;

w1 := x**4-1;

w2 := x**4+(i+2)*x**3+(2*i+5)*x**2+(2*i+6)*x+6;

w3 := (2*i+3)*x**4+(3*i-2)*x**3-2*(i+1)*x**2+i*x-1;

off arnum;


defpoly a**2-5;

w4 := x**2+x-1;

off arnum;


defpoly a**2+a+2;

w5 := x**4+3*x**2+4;

off arnum;


defpoly a**3+2=0;

w6:=64*x**6-4;

off arnum;


defpoly a**4+a**3+a**2+a+1=0;

w7:=16*x**4+8*x**3+4*x**2+2*x+1;

off arnum, factor;


defpoly sqrt5**2-5,cbrt3**3-3;

cbrt3**3;

sqrt5**2;

cbrt3;

sqrt5;

sqrt(x**2+2*(sqrt5-cbrt3)*x+5-2*sqrt5*cbrt3+cbrt3**2);

on rationalize;

1/(x+sqrt5-cbrt3);

off arnum, rationalize;


split_field(x**3+2);

for each j in ws product (x-j);

split_field(x**3+4*x**2+x-1);

for each j in ws product (x-j);

split_field(x**3-3*x+7);

for each j in ws product (x-j);

split_field(x**3+4*x**2+x-1);

for each j in ws product (x-j);

split_field(x**3-x**2-x-1);

for each j in ws product (x-j);

% A longer example.

off arnum;

defpoly a**6+3*a**5+6*a**4+a**3-3*a**2+12*a+16;

factorize(x**3-3);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/utf8/0000755000175000017500000000000011722677360021410 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/utf8/utf8.red0000644000175000017500000003065511526203062022765 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: utf8.red 729 2010-08-26 15:13:09Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(utf8_rcsid!* utf8_copyright!*);
   utf8_rcsid!* := "$Id: utf8.red 729 2010-08-26 15:13:09Z thomas-sturm $";
   utf8_copyright!* := "(c) 2009 T. Sturm"
>>;


module utf8;

create!-package('(utf8),nil);

fluid '(lispsystem!* overflowed!* posn!* testing!-width!* !*nat);

!#if (memq 'psl lispsystem!*)
   fluid '(maxchannels writefunction out!*);
!#endif

switch utf8;
switch utf82d;
switch utf82dround;
switch utf8exp;
switch utf8expall;
switch utf8diffquot;
switch utf8pad;

put('utf82dround,'simpfg,'((t (utf82droundon)) (nil (utf82droundoff))));

procedure utf82droundon();
   <<
      put('utf8_mat!-top!-l,'utf8,'(1 226 142 155));
      put('utf8_mat!-mid!-l,'utf8,'(1 226 142 156));
      put('utf8_mat!-low!-l,'utf8,'(1 226 142 157));
      put('utf8_mat!-top!-r,'utf8,'(1 226 142 158));
      put('utf8_mat!-mid!-r,'utf8,'(1 226 142 159));
      put('utf8_mat!-low!-r,'utf8,'(1 226 142 160))
   >>;

procedure utf82droundoff();
   <<
      put('utf8_mat!-top!-l,'utf8,'(1 226 142 161));
      put('utf8_mat!-mid!-l,'utf8,'(1 226 142 162));
      put('utf8_mat!-low!-l,'utf8,'(1 226 142 163));
      put('utf8_mat!-top!-r,'utf8,'(1 226 142 164));
      put('utf8_mat!-mid!-r,'utf8,'(1 226 142 165));
      put('utf8_mat!-low!-r,'utf8,'(1 226 142 166))
   >>;

on1 'utf8;
on1 'utf82d;
on1 'utf82dround;
off1 'utf8exp;
on1 'utf8expall;
on1 'utf8diffquot;
on1 'utf8pad;

copyd('prin2!*_orig,'prin2!*);
copyd('scprint_orig,'scprint);
copyd('exptpri_orig,'exptpri);

procedure prin2!*(u);
   if not !*utf8 then
      prin2!*_orig u
   else
      utf8_prin2!* u;

procedure utf8_prin2!*(u);
   if outputhandler!* then apply2(outputhandler!*,'prin2!*,u)
   else begin integer m,n,p; scalar x,y;
      if x := get(u,'oldnam) then u := x;
      if overflowed!* then return 'overflowed
      else if !*fort then return fprin2!* u
      else if !*nat then <<
	 if u = 'pi then u := symbol '!.pi
	 else if u = 'infinity then u := symbol 'infinity>>;
      % Suggested by Wolfram Koepf:
      if fixp u and n>50 and !*rounded then return rd!:prin i2rd!* u;
      n := if x := get(u,'utf8) then
 	 car x
      else if (x := utf8_indexsplit u) and (y := get(car x,'utf8)) then
	 car y + cadr x
      else
 	 lengthc u;
      m := posn!* #+ n;
      p := linelength nil - spare!*;
      return if m<=p
	 or (not testing!-width!*
	    % The next line controls whether to add a newline before a long id.
	    % At present it causes one in front of a number too.
	    and <>)
      then add_prin_char(u,m)
	 % Identifier longer than one line.
      else if testing!-width!*
      then <>
      else prin2lint(u,posn!* #+ 1,p #- 1)
   end;

procedure scprint(u,n);
   <<
      if not !*utf8 then
      	 scprint_orig(u,n)
      else
      	 utf8_scprint(u,n);
      if !*utf8pad then
      	 utf8_dots(cdaar lastcar u - posn!*)
   >>;

procedure utf8_scprint(u,n);
   begin scalar m,w,x,padded;
      posn!* := 0;
      for each v in u do <<
	 if cdar v=n then <<
	    if not((m:= caaar v-posn!*)<0) then
	       if !*utf8pad and not padded then <<
		  utf8_dots m;
		  padded := t
	       >> else
	    	  spaces m;
	    if w := get(cdr v,'utf8) then
	       utf8_tyo w
	    else if w := utf8_indexsplit cdr v then <<
	       if x := get(car w,'utf8) then
		  utf8_tyo x
	       else
	       	  utf8_prin2 car w;
	       utf8_tyo cdr w
	    >> else
	       utf8_prin2 cdr v;
	    posn!* := cdaar v
 	 >>
      >>
   end;

procedure utf8_dots(n);
   for i := 1:n do prin2 " ";

!#if (memq 'psl lispsystem!*)
   procedure utf8_tyo(itml);
      <<
	 setf(wgetv(lineposition,out!*),wgetv(lineposition,out!*)+car itml);
      	 for each itm in cdr itml do
      	    utf8_channelwritechar(out!*,lisp2char itm)
      >>;

   procedure utf8_channelwritechar(channel,char);
      <<
      	 if not wleq(0,channel) and wleq(channel,maxchannels) then
      	    noniochannelerror(channel,"ChannelWriteChar");
      	 idapply(wgetv(writefunction,channel),{channel,char})
      >>;
!#else
   procedure utf8_tyo(itml);
      for each itm in cdr itml do
      	 tyo itm;
!#endif

procedure utf8_prin2(itm);
   prin2 itm;

procedure utf8_indexsplit(u);
   begin integer idxlen; scalar l,d;
      if numberp u or digit u then
	 return nil;
      l := reversip explode u;
      while digit car l do <<
	 idxlen := idxlen + 1;
	 d := append(utf8_subscript car l,d);
      	 l := cdr l
      >>;
      return intern compress reversip l . (idxlen . d)
   end;

procedure utf8_subscript(d);
   cdr atsoc(d,'((!1 . (226 130 129)) (!2 . (226 130 130)) (!3 . (226 130 131))
      (!4 . (226 130 132)) (!5 . (226 130 133)) (!6 . (226 130 134))
      (!7 . (226 130 135)) (!8 . (226 130 136)) (!9 . (226 130 137))
      (!0 . (226 130 128))));

procedure exptpri(x,y);
   if not !*utf8 then
      exptpri_orig(x,y)
   else
      utf8_exptpri(x,y);

procedure utf8_exptpri(x,p);
   begin scalar q,expo,w;
      if not !*nat then
      	 return 'failed;
      if null !*utf8exp or not numberp caddr x then
      	 return exptpri_orig(x,p);
      expo := explode caddr x;
      if null !*utf8expall and utf8_supmixp expo then
	 return exptpri_orig(x,p);
      q := pairp cadr x and (w := get(caadr x,'infix)) and
 	 w <= get('expt,'infix);
      if q then prin2!* "(";
      maprin cadr x;
      if q then prin2!* ")";
      x := compress append('(u t f 8 !_ e x p),expo);
      put(x,'utf8,length expo . for each d in expo join copy utf8_supscript d);
      utf8_prin2!* x
   end;

procedure utf8_supmixp(exp);
   intersection(exp,'(!1 !2 !3)) and intersection(exp,'(!4 !5 !6 !7 !8 !9 !0));

procedure utf8_supscript(d);
   cdr atsoc(d,'((!1 . (194 185)) (!2 . (194 178)) (!3 . (194 179))
      (!4 . (226 129 180)) (!5 . (226 129 181)) (!6 . (226 129 182))
      (!7 . (226 129 183)) (!8 . (226 129 184)) (!9 . (226 129 185))
      (!0 . (226 129 176))));

procedure utf8_priabs(u);
   if not !*utf8 then
      'failed
   else <<
      prin2!* "|";
      maprin cadr u;
      prin2!* "|"
   >>;

procedure utf8_pripartial(u);
   if not !*utf8 then
      'failed
   else <<
      utf8_prin2!* car u;
      maprin cadr u
   >>;

procedure utf8_pridiff(u);
   if not !*utf8 then
      'failed
   else if !*utf8diffquot then <<
      maprin {'quotient,
	 if eqn(cadddr u,1) then
 	    {'partial,cadr u}
 	 else
 	    {'powpartial,cadr u,cadddr u},
	 if eqn(cadddr u,1) then
 	    {'partial,caddr u}
 	 else
 	    {'expt,{'partial,caddr u},cadddr u}}
   >> else <<
      if eqn(cadddr u,1) then
	 utf8_prin2!* 'partial
      else
      	 maprin {'expt,'partial,cadddr u};
      utf8_prin2!* caddr u;
      utf8_prin2!* "(";
      maprin cadr u;
      utf8_prin2!* ")";
   >>;

procedure utf8_pripowpartial(u);
   <<
      maprin {'expt,'partial,caddr u};
      maprin cadr u
   >>;

procedure utf8_priint(u);
   if not !*utf8 then
      'failed
   else if !*utf82d then
      intprint u
   else <<
      utf8_prin2!* car u;
      if cdddr u then <<
	 utf8_prin2!* "[";
	 maprin cadddr u;
	 utf8_prin2!* ",";
	 maprin car cddddr u;
	 utf8_prin2!* "]"
      >>;
      utf8_prin2!* " ";
      maprin cadr u;
      utf8_prin2!* " d";
      utf8_prin2!* caddr u
   >>;

procedure intprint u;
   % Hijacked from mathpr/xprint.red.
   if not !*nat or !*fort then 'failed
   else begin
      scalar m;
      prin2!* symbol 'int!-mid;
      m := posn!* - 1;
      pline!* := (((m . posn!*) . (ycoord!* + 1)) .
                      symbol 'int!-top) . pline!*;
      pline!* := (((m . posn!*) . (ycoord!* - 1)) .
                      symbol 'int!-low) . pline!*;
      if ycoord!*+1>ymax!* then ymax!* := ycoord!*+1;
      if ymin!*>ycoord!*-1 then ymin!* := ycoord!*-1;
      prin2!* " ";
      maprin cadr u;
      prin2!* " ";
      prin2!* symbol 'd;
      maprin caddr u
   end;

procedure symbol(s);
   if !*utf8 and !*utf82d then
      get(s,'utf8_2d!-symbol!-character) or
      get(s,'utf8_symbol!-character) or get(s,'symbol!-character)
   else if !*utf8 then
      get(s,'utf8_symbol!-character) or get(s,'symbol!-character)
   else
      get(s,'symbol!-character);

put('ex,'utf8,'(1 226 136 131));
put('all,'utf8,'(1 226 136 128));
put('not,'utf8,'(2 194 172 32));
put('and,'utf8,'(1 226 136 167));
put('or,'utf8,'(1 226 136 168));
put('repl,'utf8,'(1 226 134 144));
put('impl,'utf8,'(1 226 134 146));
put('equiv,'utf8,'(1 226 134 148));
%put('repl,'utf8,'(2 226 159 181 32));
%put('impl,'utf8,'(2 226 159 182 32));
%put('equiv,'utf8,'(2 226 159 183 32));
put('bex,'utf8,'(1 226 168 134));
put('ball,'utf8,'(1 226 168 133));

put('reals,'utf8,'(1 226 132 157));
put('ofsf,'utf8,'(1 226 132 157));
put('integers,'utf8,'(1 226 132 164));
put('pasf,'utf8,'(1 226 132 164));
put('boolean,'utf8,'(1 240 157 148 185));
put('ibalp,'utf8,'(1 240 157 148 185));

put('!>!=,'utf8,'(1 226 137 165));
put('!,'utf8,'(1 226 137 160));

put('cong,'utf8,'(1 226 137 161));
put('ncong,'utf8,'(1 226 137 161 226 128 139 204 184));
%put('ncong,'utf8,'(1 226 137 162);
%put('ncong,'utf8,'(1 226 137 161 226 131 146));

put('infinity,'utf8,'(1 226 136 158));
put('infty,'utf8,'(1 226 136 158));

put('!*,'utf8,'(1 226 139 133));

put('bar,'utf8_symbol!-character,'utf8_bar);
put('utf8_bar,'utf8,'(1 226 128 149));

put('alpha,'utf8,'(1 206 177));
put('beta,'utf8,'(1 206 178));
put('gamma,'utf8,'(1 206 179));
put('delta,'utf8,'(1 206 180));
put('epsilon,'utf8,'(1 206 181));
put('zeta,'utf8,'(1 206 182));
put('eta,'utf8,'(1 206 183));
put('theta,'utf8,'(1 206 184));
put('iota,'utf8,'(1 206 185));
put('kappa,'utf8,'(1 206 186));
put('lambda,'utf8,'(1 206 187));
put('mu,'utf8,'(1 206 188));
put('nu,'utf8,'(1 206 189));
put('xi,'utf8,'(1 206 190));
put('omikron,'utf8,'(1 206 191));
put('pi,'utf8,'(1 207 128));
put('rho,'utf8,'(1 207 129));
put('sigma,'utf8,'(1 207 131));
put('tau,'utf8,'(1 207 132));
put('ypsilon,'utf8,'(1 207 133));
put('phi,'utf8,'(1 207 134));
put('chi,'utf8,'(1 207 135));
put('psi,'utf8,'(1 207 136));
put('omega,'utf8,'(1 207 137));

put('int,'utf8,'(1 226 136 171));
put('int!-top,'utf8_2d!-symbol!-character,'utf8_int!-top);
put('utf8_int!-top,'utf8,'(1 226 140 160));
put('int!-mid,'utf8_2d!-symbol!-character,'utf8_int!-mid);
put('utf8_int!-mid,'utf8,'(1 226 142 174));
put('int!-low,'utf8_2d!-symbol!-character,'utf8_int!-low);
put('utf8_int!-low,'utf8,'(1 226 140 161));
put('int,'prifn,'utf8_priint);
put('abs,'prifn,'utf8_priabs);

put('partial,'utf8,'(1 226 136 130));
put('partial,'prifn,'utf8_pripartial);
put('powpartial,'prifn,'utf8_pripowpartial);  % Hack but how else ...?

put('diff,'prifn,'utf8_pridiff);

put('!*!*!*,'utf8,'(1 226 136 153));

put('mat!-top!-l,'utf8_2d!-symbol!-character,'utf8_mat!-top!-l);
put('mat!-mid!-l,'utf8_2d!-symbol!-character,'utf8_mat!-mid!-l);
put('mat!-low!-l,'utf8_2d!-symbol!-character,'utf8_mat!-low!-l);
put('mat!-top!-r,'utf8_2d!-symbol!-character,'utf8_mat!-top!-r);
put('mat!-mid!-r,'utf8_2d!-symbol!-character,'utf8_mat!-mid!-r);
put('mat!-low!-r,'utf8_2d!-symbol!-character,'utf8_mat!-low!-r);

endmodule;  % utf8

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/0000755000175000017500000000000011722677365022366 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/normform/smithex1.red0000644000175000017500000002527111526203062024610 0ustar  giovannigiovannimodule smithex1;
%                                                                      %
%**********************************************************************%

% The function smithex_int computes the Smith normal form S of an n by
% m rectangular matrix of integers.
%
% Specifically:
%
% - smithex_int(A) will return {S,P,Pinv} where S, P, and Pinv
%   are such that inverse(P)*A*P = S.


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




symbolic procedure smithex_int(B);
  begin
    scalar Left,Right,isclear,A;
    integer n,m,i,j,k,l,tmp,g,ll,rr,int1,int2,quo1,quo2,r,sgn,rrquo,
            q,input_mode;

    matrix_input_test(B);

    input_mode := get(dmode!*,'dname);
    if input_mode = 'modular
     then rederr "ERROR: smithex_int does not work with modular on.";

    integer_entries_test(B);

    A := copy_mat(B);

    n := car size_of_matrix(A); %  No. of rows.
    m := cadr size_of_matrix(A); %  No. of columns.

    Left := make_identity(n,n) ;
    Right := make_identity(m,m);

    for k:=1:min(n,m) do
    <<
      %
      %  Pivot selection from row k to column k.
      %
      i := k; while i<= n and getmat(A,i,k) = 0 do i:=i+1;
      j := k; while j<= m and getmat(A,k,j) = 0 do j:=j+1;

      if i>n and j>m then <<>>
      else
      <<
        %
        %  Select smallest non-zero entry as pivot.
        %
        for l:=i+1:n do
        <<
          if getmat(A,l,k) = 0 then l := l+1
          else if abs(getmat(A,l,k)) < abs(getmat(A,i,k)) then i := l;
        >>;

        for l:=j+1:m do
        <<
          if getmat(A,k,l) = 0 then l := l+1
          else if abs(getmat(A,k,l)) < abs(getmat(A,k,j)) then j := l;
        >>;

        if i<=n and (j>m or abs(getmat(A,i,k))>;

            for l:=1:n do
            <<
              tmp:= getmat(Left,l,i);
              setmat(Left,l,i,getmat(Left,l,k));
              setmat(Left,l,k,tmp);
            >>;

          >>
        >>
        else
        %
        %  Pivot is A(k,j), interchange column k,j if necessary.
        %
        <<
          if j neq k then
          <<

            for l:=k:n do
            <<
              tmp:= getmat(A,l,j);
              setmat(A,l,j,getmat(A,l,k));
              setmat(A,l,k,tmp);
            >>;

            for l:=1:m do
            <<
              tmp:= getmat(Right,j,l);
              setmat(Right,j,l,getmat(Right,k,l));
              setmat(Right,k,l,tmp);
            >>;

          >>;
        >>;

        isclear := nil;

        while not isclear do
        %
        %  0 out column k from k+1 to n.
        %
        <<
          for i:=k+1:n do
          <<
            if getmat(A,i,k) = 0 then <<>>
            else
            <<
              int1 := getmat(A,k,k);
              int2 := getmat(A,i,k);
              tmp := (calc_exgcd_int(int1,int2));
              g := car tmp;
              ll := cadr tmp;
              rr := caddr tmp;
              quo1 := get_quo_int(getmat(A,k,k),g);
              quo2 := get_quo_int(getmat(A,i,k),g);

              %
              %  We have  ll A(k,k)/g + rr A(i,k)/g = 1
              %
              %       [  ll     rr   ]  [ A[k,k]  A[k,j] ]   [ g  ... ]
              %       [              ]  [                ] = [        ]
              %       [ -quo2  quo1  ]  [ A[i,k]  A[i,j] ]   [ 0  ... ]
              %
              %       for j = k+1..m  where note  ll quo1 + rr quo2 = 1
              %

              for j:=k+1:m do
              <<
                tmp := ll*getmat(A,k,j)+rr*getmat(A,i,j);
                setmat(A,i,j,quo1*getmat(A,i,j)-quo2*getmat(A,k,j));
                setmat(A,k,j,tmp);
              >>;

              for j:=1:n do
              <<
                tmp := quo1*getmat(Left,j,k)+quo2*getmat(Left,j,i);
                setmat(Left,j,i,-rr*getmat(Left,j,k)+ll*
                       getmat(Left,j,i));
                setmat(Left,j,k,tmp);
              >>;

              setmat(A,k,k,g);
              setmat(A,i,k,0);
            >>;
          >>;

          isclear := t;
          %
          %  0 out row k from k+1 to m.
          %
          for i:=k+1:m do
          <<
            q := get_quo_int(getmat(A,k,i),getmat(A,k,k));
            setmat(A,k,i,get_rem_int(getmat(A,k,i),getmat(A,k,k)));

            for j:=1:m do
            <<
              setmat(Right,k,j,getmat(Right,k,j)+q*getmat(Right,i,j));
            >>;

          >>;

          for i:=k+1:m do
          <<
            if getmat(A,k,i) = 0 then <<>>
            else
            <<
              tmp := calc_exgcd_int( getmat(A,k,k),getmat(A,k,i));
              g := car tmp;
              ll := cadr tmp;
              rr := caddr tmp;
              quo1 := get_quo_int(getmat(A,k,k),g);
              quo2 := get_quo_int(getmat(A,k,i),g);

              for j:=k+1:n do
              <<
                tmp := ll*getmat(A,j,k) + rr*getmat(A,j,i);
                setmat(A,j,i,quo1*getmat(A,j,i)-quo2*getmat(A,j,k));
                setmat(A,j,k,tmp);
              >>;

              for j:=1:m do
              <<
                tmp := quo1*getmat(Right,k,j)+quo2*getmat(Right,i,j);
                setmat(Right,i,j,-rr*getmat(Right,k,j)+ll*
                       getmat(Right,i,j));
                setmat(Right,k,j,tmp);
              >>;

              setmat(A,k,k,g);
              setmat(A,k,i,0);

              isclear := nil;
            >>;
          >>;

        >>;
      >>;
    >>;

    r := 0;
    %
    %  At this point, A is diagonal: some A(i,i) may be zero.
    %  Move non-zero's up also making all entries unit normal.
    %
    for i:=1:min(n,m) do
    <<
      if getmat(A,i,i) neq 0 then
      <<
        r := r+1;
        sgn := algebraic (sign(getmat(A,i,i)));
        setmat(A,r,r,sgn*getmat(A,i,i));
        if i = r then
        <<

          for j:=1:m do
          <<
            setmat(Right,i,j,getmat(Right,i,j)*sgn);
          >>;

        >>
        else
        <<
          setmat(A,i,i,0);

          for j:=1:n do
          <<
            tmp := getmat(Left,j,r);
            setmat(Left,j,r,getmat(Left,j,i));
            setmat(Left,j,i,tmp);
          >>;

          for j:=1:m do
          <<
            tmp := getmat(Right,i,j)*sgn;
            setmat(Right,i,j,getmat(Right,r,j)*sgn);
            setmat(Right,r,j,tmp);
          >>;

        >>;
      >>;
    >>;
    %
    %  Now make A(i,i) | A(i+1,i+1) for 1 <= i < r.
    %
    for i:=1:r-1 do
    <<
      j:=i+1;
      <<
        while getmat(A,i,i) neq 1 and j <= r do
        <<
          int1 := getmat(A,i,i);
          int2 := getmat(A,j,j);
          g := car (calc_exgcd_int(int1,int2));
          ll := cadr (calc_exgcd_int(int1,int2));
          rr := caddr (calc_exgcd_int(int1,int2));
          quo1 := get_quo_int(getmat(A,i,i),g);
          quo2 := get_quo_int(getmat(A,j,j),g);

          setmat(A,i,i,g);
          setmat(A,j,j,quo1*getmat(A,j,j));

          for k:=1:n do
          <<
            tmp := quo1*getmat(Left,k,i)+quo2*getmat(Left,k,j);
            setmat(Left,k,j,-rr*getmat(Left,k,i)+ll*
                   getmat(Left,k,j));
            setmat(Left,k,i,tmp);
          >>;

          for k:=1:m do
          <<
            rrquo := rr*quo2;
            tmp := (1-rrquo)*getmat(Right,i,k)+rrquo*
                   getmat(Right,j,k);
            setmat(Right,j,k,-getmat(Right,i,k)+getmat(Right,j,k));
            setmat(Right,i,k,tmp);
          >>;

          j := j+1;
        >>;
      >>;
    >>;

    return {'list,A,Left,Right};
  end;

flag ('(smithex_int),'opfn);  %  So it can be used from algebraic mode.



symbolic procedure calc_exgcd_int(int1,int2);
  begin
    integer gcd,c,c1,c2,d,d1,d2,q,r,r1,r2,s1,t1;

    if int1 = 0 and int2 = 0  then return {0,0,0}
    else
    <<

      c := reval int1;
      d := reval int2;

      c1 := 1;
      d1 := 0;
      c2 := 0;
      d2 := 1;

      while d neq 0 do
      <<
        q  := get_quo_int(c,d);
        r  := c - q*d;
        r1 := c1 - q*d1;
        r2 := c2 - q*d2;
        c  := d;
        c1 := d1;
        c2 := d2;
        d  := r;
        d1 := r1;
        d2 := r2;
      >>;

      gcd := abs(c);
      s1  := c1;
      t1  := c2;

      if c < 0 then
      <<
        s1 := -s1;
        t1 := -t1;
      >>;

      return {gcd,s1,t1};
    >>;
  end;


symbolic procedure get_quo_int(int1,int2);
  begin
    integer quo1,input1,input2;

    input1 := reval int1;
    input2 := reval int2;

    if input1 = 0 and input2 = 0 then return 0
    else
    <<
      if input1 < 0 and input2 < 0 then
      <<
        (input1 := abs(input1));
        (input2 := abs(input2));
      >>;

      if (input1/input2) < 0 then
      <<
        quo1 :=ceiling(input1/input2);
      >>
      else
      <<
        quo1 :=floor(input1/input2);
      >>;

      return quo1;
    >>;
  end;


symbolic procedure get_rem_int(int1,int2);
  begin
    integer rem1,input1,input2;
    input1 := reval int1;
    input2 := reval int2;
    rem1 := input1 - get_quo_int(input1,input2)*input2;
    return rem1;
  end;


symbolic procedure integer_entries_test(B);
  begin
    for i:=1:car size_of_matrix(B) do
    <<
      for j:=1:cadr size_of_matrix(B) do
      <<
        if not numberp getmat(B,i,j) then rederr
         "ERROR: matrix contains non_integer entries. Try smithex. "
      >>;
    >>;
  end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/jordsymb.red0000644000175000017500000004364111526203062024700 0ustar  giovannigiovannimodule jordsymb; % Computation of the Jordan normal form of a matrix.                                                              %

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The function jordansymbolic computes the Jordan normal form J of a
% matrix A, the transformation matrix P and its inverse P^(-1).
% Here symbolic names are used for the zeroes of the characteristic
% polynomial p not in K. Also a list of irreducible factors of p is
% returned.
%
% Specifically:
%
% - jordansymbolic(A) will return {J,l,P,Pinv} where J, P, and
%   Pinv are such that P*J*Pinv = A. J is calculated with symbolic
%   names if necessary. l is {ll,x} where x is a name and ll
%   is a list of irreducible factors of p(x). If symbolic names are
%   used then xij is a zero of ll(i).

% Global description of the algorithm:
%
% For a given n by n matrix A over a field K, we car compute the
% rational Jordan normal form R of A. Then we compute the Jordan normal
% form of R, which is also the Jordan normal form of A.
% car consider the case where R=C(p), the companion matrix of the
% monic, irreducible polynomial p=x^n+p(n-1)*x^(n-1)+..+p1*x+p0.
% If y is a zero of p then
% (y^(n-1)+p(n-1)*y^(n-2)+..+p2*y+p1,y^(n-2)+p(n-1)*y^(n-3)+..+p3*y+p2,
% ....,y^2+p(n-1)*y+p(n-2),y+p(n-1),1)
% is an eigenvector of R with eigenvalue y.
%
% Let v1     = x^(n-1)+p(n-1)*x^(n-2)+..+p2*x+p1,
%     v2     = x^(n-2)+p(n-1)*x^(n-3)+..+p3*x+p2,
%     ...
%     v(n-2) = x^2+P(n-1)*x+p(n-2),
%     v(n-1) = x+p(n-1),
%     vn     = 1.
%
% If y1,..,yn are the different zeroes of p in a splitting field of p
% over K (we asssume that p is separable, this is always true if K is a
% perfect field) we get:
%
%       inverse(V)*R*V=diag(y1,..,yn),
%
% where
%
%          [ v1(y1) v1(y2) ... v1(yn) ]
%          [ v2(y1) v2(y2) ... v2(yn) ]
%      V = [  ...    ...   ...  ...   ]
%          [  ...    ...   ...  ...   ]
%          [ vn(y1) vn(y2) ... vn(yn) ]
%
%
% One can prove that
%
%      [1 y1 ... y1^(n-1)] [v1(y1) v1(y2) ... v1(yn)]
%      [1 y2 ... y2^(n-1)] [v2(y1) v2(y2) ... v2(yn)]
%      [.................] [........................] =
%      [.................] [........................]
%      [1 yn ... yn^(n-1)] [vn(y1) vn(y2) ... vn(yn)]
%
%    = diag(diff(p,x)(y1),diff(p,x)(y2),...,diff(p,x)(yn)).
%
% If s and t are such that s*p+t*diff(p,x)=1 then we get
%
%                                           [1 y1 ... y1^(n-1) ]
%                                           [1 y2 ... y2^(n-1) ]
%    inverse(V)=diag(t(y1),t(y2),...,t(yn))*[................. ]
%                                           [................. ]
%                                           [1 yn ... yn^(n-1) ]
%
% Let Y=diag(y1,..,yn). From V^(-1)*R*V=Y it follows that
%
%                          [C(p)  I             ]
%                          [    C(p)  I         ]
%   diag(V^(-1),..,V^(-1))*[          .   .     ]*diag(V,..,V)=
%                          [            C(p)  I ]
%                          [                C(p)]
%
%          [ Y I       ]
%          [   Y I     ]
%        = [     . .   ]
%          [       Y I ]
%          [         Y ]
%
% It is now easy to see that to get our general result, we only have to
% permute diag(V,..,V) and diag(V^(-1),..,V^(-1)).

% looking_good controls formating output to print the greek character
% xi instead of lambda. At present xr does not support indexing of
% lambda but it does for all other greek letters, which is the reason
% for this switch.
%
% Only  helpful when using xr.

switch looking_good;


switch balanced_was_on;
symbolic procedure jordansymbolic(A);
  begin
    scalar AA,P,Pinv,tmp,ans_mat,ans_list,full_coeff_list,rule_list,
           output,input_mode;

    matrix_input_test(A);
    if (car size_of_matrix(A)) neq (cadr size_of_matrix(A))
     then rederr "ERROR: expecting a square matrix. ";

    if !*balanced_mod then
    <<
      off balanced_mod;
      on balanced_was_on;
    >>;

    input_mode := get(dmode!*,'dname);
    %
    % If modular or arnum are on then we keep them on else we want
    % rational on.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then on rational;
    on combineexpt;

    tmp := nest_input(A);
    AA := car tmp;
    full_coeff_list := cadr tmp;

    tmp := jordansymbolicform(AA,full_coeff_list);
    ans_mat := car tmp;
    ans_list := cadr tmp;
    P := caddr tmp;
    Pinv := caddr rest tmp;
    %
    %  Set up rule list for removing nests.
    %
    rule_list := {'co,2,{'~,'int}}=>'int when numberp(int);
    for each elt in full_coeff_list do
    <<
      tmp := {'co,2,{'~,elt}}=>elt;
      rule_list := append (tmp,rule_list);
    >>;
    %
    % Remove nests.
    %
    let rule_list;
    ans_mat := de_nest_mat(ans_mat);
    car ans_list := append({'list},car ans_list);
    ans_list := append({'list},ans_list);
    cadr ans_list := for each elt in cadr ans_list collect reval elt;
    P := de_nest_mat(P);
    Pinv := de_nest_mat(Pinv);
    clearrules rule_list;
    %
    % Return to original mode.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then
       <<
         % onoff('nil,t) doesn't work so ...
         if input_mode = 'nil then off rational
         else onoff(input_mode,t);
       >>;
    if !*balanced_was_on then on balanced_mod;
    off combineexpt;

    output := {'list,ans_mat,ans_list,P,Pinv};
    if !*looking_good then output := looking_good(output);
    return output;
  end;

flag ('(jordansymbolic),'opfn);  %  So it can be used from
                                 %  algebraic mode.



symbolic procedure jordansymbolicform(A,full_coeff_list);
  begin
    scalar l,R,TT,Tinv,S,Sinv,tmp,P,Pinv,invariant;

    tmp := ratjordanform(A,full_coeff_list);
    R := car tmp;
    TT := cadr tmp;
    Tinv := caddr tmp;

    tmp := ratjordan_to_jordan(R);
    l := car tmp;
    S := cadr tmp;
    Sinv := caddr tmp;

    P := off_mod_reval {'times,TT,S};
    Pinv := off_mod_reval {'times,Sinv,Tinv};

    invariant := invariant_to_jordan(nth(l,1));

    return {invariant,nth(l,2),P,Pinv};
  end;




symbolic procedure find_companion(R,rr,x);
  begin
    scalar  p;
    integer row_dim,k;

    row_dim := car size_of_matrix(R);
    k := rr+1;

    while k<=row_dim and getmat(R,k,k-1)=1 do k:=k+1;

    p := 0;
    for j:=rr:k-1 do
    <<
      p:={'plus,p,{'times,{'minus,getmat(R,j,k-1)},{'expt,x,j-rr}}};
    >>;
    p := {'plus,p,{'expt,x,k-rr}};

    return p;
  end;




symbolic procedure find_ratjblock(R,rr,x);
  begin
    scalar p,continue;
    integer k,e,row_dim;

    row_dim := car size_of_matrix(R);
    p := reval find_companion(R,rr,x);
    e := 1;
    k:= off_mod_reval({'plus,rr,deg(p,x)});

    continue := t;
    while continue do
    <<
      if k>row_dim then continue := nil;
      if identitymatrix(R,k-deg(p,x),k,deg(p,x)) then
      <<
        e:=e+1;
        k:=k+deg(p,x);
      >>
      else
      <<
        continue := nil;
      >>;
    >>;

    return({p,e});
  end;




symbolic procedure identitymatrix(A,i,j,m);
  %
  % Tests if the submatrix of A, starting at position (i,j) and of
  % square size m, is an identity matrix.
  %
  begin
    integer row_dim;

    row_dim := car size_of_matrix(A);
    if i+m-1>row_dim or j+m-1>row_dim then return nil
    else
    <<
      if submatrix(A,{i,i+m-1},{j,j+m-1}) = make_identity(m,m) then
         return t
      else return nil;
    >>;
  end;

flag ('(identitymatrix),'boolean);



symbolic procedure invariant_to_jordan(invariant);
  begin
    scalar block_list;
    integer n,m;

    n := length invariant;
    block_list := {};

    for i:=1:n do
    <<
      m := length nth(nth(invariant,i),2);
      for j:=1:m do
      <<
        block_list := append(block_list,
                      {jordanblock(nth(nth(invariant,i),1),
                      nth(nth(nth(invariant,i),2),j))});
      >>;
    >>;
    return (reval {'diagi,block_list});
  end;




symbolic procedure jordanblock(const,mat_dim);
  %
  % Takes a constant (const) and an integer (mat_dim) and creates
  % a jordan block of dimension mat_dim x mat_dim.
  %
  % Can be used independently from algebraic mode.
  %
  begin
    scalar JB;

    JB := mkmatrix(mat_dim,mat_dim);
    for i:=1:mat_dim do
    <<
      for j:=1:mat_dim do
      <<
        if i=j then
        <<
          setmat(JB,i,j,const);
          if i>;
      >>;
    >>;

    return JB;
  end;

flag ('(jordanblock),'opfn); %  So it can be used independently
                             %  from algebraic mode.



switch mod_was_on;
symbolic procedure ratjordan_to_jordan(R);
  begin
    scalar prim_inv,TT,Tinv,Tinvlist,Tlist,exp_list,invariant,p,partT,
           partTinv,s1,t1,v,w,sum1,tmp,S,Sinv,x;
    integer nn,n,d;
    %
    % lambda would be better but as yet reduce can't output lambda with
    % indices (under discussion), so we use xi. If it is decided that
    % lambda can be used with indices then change xi to lambda both
    % here and in the functions looking_good and make_rule.
    %
    if !*looking_good then x := 'xi
    else x := 'lambda;

    prim_inv := ratjordan_to_priminv(R,x);

    invariant := {};
    Tlist := {};
    Tinvlist := {};

    nn := length prim_inv;
    for i:=1:nn do
    <<
      p := nth(nth(prim_inv,i),1);
      exp_list := nth(nth(prim_inv,i),2);
      d := off_mod_reval(deg(p,x));
      if d=1 then
      <<
        invariant := append(invariant,{{reval {'minus,coeffn(p,x,0)},
                            exp_list}});
      >>
      else
      <<
        for j:=1:d do
        <<
          invariant := append(invariant,{{mkid(x,off_mod_reval{'plus,
                              {'times,10,i},j}),exp_list}});
        >>;
      >>;
      %
      % Compute eigenvector of C(p) with eigenvalue x.
      %
      v := mkvect(d);
      putv(v,d,1);
      for j:=d-1 step -1 until 1 do
      <<
        tmp := 0;
        sum1 := 0;
        for k:=j:d-1 do
        <<
          tmp := reval{'times,coeffn(p,x,k),{'expt,x,k-j}};
          sum1 := reval{'plus,sum1,tmp};
        >>;
        putv(v,j,reval {'plus,sum1,{'expt,x,d-j}});
      >>;

      sum1 := 0;
      for j:=1:length exp_list do
      <<
        tmp := reval nth(exp_list,j);
        sum1 := reval {'plus,sum1,tmp};
      >>;
      n := sum1;

      partT := mkmatrix(n*d,n);
      for j:=1:n do
      <<
        for k:=1:d do
        <<
          setmat(partT,(j-1)*d+k,j,getv(v,k));
        >>;
      >>;

      TT := mkmatrix(n*d,n*d);
      if d=1 then
      <<
        %
        % off modular else the mkid number part will be calculated
        % in modular mode.
        %
        if !*modular then << off modular; on mod_was_on; >>;
        TT := copyinto(algebraic (sub({x=-coeffn(p,x,0)},partT)),
                       TT,1,1);
        if !*mod_was_on then << on modular; off mod_was_on; >>;
      >>
      else for j:=1:d do
      <<
        %
        % off modular else the mkid number part will be calculated
        % in modular mode.
        %
        if !*modular then << off modular; on mod_was_on; >>;
        TT := copyinto(algebraic sub(x=mkid(x,off_mod_reval{'plus,
                       {'times,10,i},j}),partT),TT,1,(j-1)*n+1);
        if !*mod_was_on then << on modular; off mod_was_on; >>;
      >>;
      Tlist := append(Tlist,{TT});

      tmp := algebraic df(p,x);
      tmp := calc_exgcd(p,tmp,x);
      s1 := cadr tmp;
      t1 := caddr tmp;
      w := mkvect(d);
      putv(w,1,t1);

      for j:=2:d do
      <<
        putv(w,j,get_rem(reval{'times,x,getv(w,j-1)},p));
      >>;

      partTinv := mkmatrix(n,n*d);
      for j:=1:n do
      <<
        for k:=1:d do
        <<
          setmat(partTinv,j,(j-1)*d+k,getv(w,k));
        >>;
      >>;

      Tinv := mkmatrix(n*d,n*d);
      if d=1 then
      <<
        %
        % off modular else the mkid number part will be calculated
        % in modular mode.
        %
        if !*modular then << off modular; on mod_was_on; >>;
        Tinv := reval copyinto(algebraic sub(x=-coeffn(p,x,0),partTinv)
                               ,Tinv,1,1);
        if !*mod_was_on then << on modular; off mod_was_on; >>;
      >>
      else for j:=1:d do
      <<
        %
        % off modular else the mkid number part will be calculated
        % in modular mode.
        %
        if !*modular then << off modular;  on mod_was_on; >>;
        Tinv := reval copyinto(algebraic sub(x=mkid(x,off_mod_reval
                {'plus,{'times,10,i},j}),partTinv),Tinv,(j-1)*n+1,1);
        if !*mod_was_on then << on modular; off mod_was_on; >>;
      >>;
      Tinvlist := append(Tinvlist,{Tinv});

    >>;

    S := reval{'diagi,Tlist};
    Sinv := reval{'diagi,Tinvlist};
    tmp := {for i:=1:nn collect nth(nth(prim_inv ,i),1)};
    tmp := append(tmp,{x});
    tmp := append({invariant},{tmp});

    return {tmp,S,Sinv};
  end;




symbolic procedure ratjordan_to_priminv(R,x);
  %
  % ratjordan_to_priminv(R,x) computes the primary invariant of a matrix
  % R which is in rational Jordan normal form.
  %
  begin
    scalar p,plist,exp_list,l,prim_inv;
    integer n,rr,ii,nn;

    n := car size_of_matrix(R);
    rr := 1;

    plist := {};
    while rr<=n do
    <<
      l := find_ratjblock(R,rr,x);
      plist := append(plist,{l});
      rr := off_mod_reval({'plus,rr,{'times,nth(l,2),deg(nth(l,1),x)}});
    >>;

    p := reval nth(nth(plist,1),1);
    exp_list := {nth(nth(plist,1),2)};
    prim_inv := {};
    nn := length plist;
    ii := 2;
    while ii<=nn do
    <<
      if reval nth(nth(plist,ii),1) = p then
      <<
        exp_list := append(exp_list,{nth(nth(plist,ii),2)})
      >>
      else
      <<
        prim_inv := append(prim_inv,{{p,exp_list}});
        p := reval nth(nth(plist,ii),1);
        exp_list := {nth(nth(plist,ii),2)};
      >>;
      ii := ii+1;
    >>;
    prim_inv := append(prim_inv,{{p,exp_list}});

    return prim_inv;
  end;




symbolic procedure submatrix(A,row_list,col_list);
  %
  % Creates the submatrix of A from rows  p to q (row_list = {p,q})
  % and columns r to s (col_list = {r,s}).
  %
  % Can be used independently from algebraic mode.
  %
  begin
    scalar AA;
    integer row_dim,col_dim,car_row,last_row,car_col,last_col,
            A_row_dim,A_col_dim;

    matrix_input_test(A);

    %  If algebraic input remove 'list.
    if car row_list = 'list then row_list := cdr row_list;
    if car col_list = 'list then col_list := cdr col_list;

    car_row := car row_list;
    last_row := cadr row_list;
    row_dim := last_row - car_row + 1;
    car_col := car col_list;
    last_col := cadr col_list;
    col_dim := last_col - car_col + 1;

    A_row_dim := car size_of_matrix(A);
    A_col_dim := cadr size_of_matrix(A);
    if car_row = 0 or last_row = 0 then rederr
     {"0 is out of range for ",A,". The car row is labelled 1."};
    if car_col = 0 or last_col = 0 then rederr
     {"0 is out of range for",A,". The car column is labelled 1."};
    if car_row > A_row_dim then rederr
     {A,"doesn't have",car_row,"rows."};
    if last_row > A_row_dim then rederr
     {A,"doesn't have",last_row,"rows."};
    if car_col > A_col_dim then rederr
     {A,"doesn't have",car_col,"columns."};
    if last_col > A_col_dim then rederr
     {A,"doesn't have",last_col,"columns."};

    AA := mkmatrix(row_dim,col_dim);
    for i:=1:row_dim do
    <<
      for j:=1:col_dim do
      <<
        setmat(AA,i,j,getmat(A,i+car_row-1,j+car_col-1));
      >>;
    >>;

    return AA;
  end;

flag ('(submatrix),'opfn);  %  So it can be used independently
                            %  from algebraic mode.



symbolic procedure looking_good(output);
  %
  % Converts output for correct display of indices with greek
  % font. Only used when switch looking_good is on, which is only on
  % when using xr.
  %
  % xiab => xi(a,b) is used instead of xiab => xi(ab) to reduce problems
  % when using modular arithmetic. In mod 17 (for example) xi(21) will
  % get converted to xi(2,1) but the alternative would give xi(4) -
  % wrong! Unfortunately the alternative probably looks a bit nicer but
  % there you go. If the modulus is <= 7 then this may give problems,
  % eg: xi55 in mod 5 will give xi(0,0). These cases will be very rare
  % but if they occur turn OFF looking_good.
  %
  begin
    scalar rule_list;

    algebraic operator xi;
    algebraic print_indexed(xi);
    %
    % Create rule list to convert xiab => xi(a,b) for a,b:=1:9.
    %
    rule_list := make_rule();

    let rule_list;
    output := reval output;
    clearrules rule_list;

    return output;
  end;




symbolic procedure make_rule();
  begin
    scalar rule_list,tmp,tmp1;

    rule_list := {};
    for i:=1:9 do
      <<
        for j:=1:9 do
        <<
          tmp1 := reval mkid('xi,i);
          tmp1 := reval mkid(tmp1,j);
          tmp := {'replaceby,tmp1,{'xi,i,j}};
          rule_list := append(rule_list,{tmp});
        >>;
      >>;
      rule_list := append({'list},rule_list);
      return rule_list;
  end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/ratjord.red0000644000175000017500000006725311526203062024521 0ustar  giovannigiovannimodule ratjord; %Computation of rational Jordan normal form of a matrix.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The function ratjordan computes the rational Jordan normal form R of
% a matrix A, the transformation matrix P and its inverse P^(-1).
%
% Specifically:
%
% - ratjordan(A) will return {R,P,Pinv} where R, P, and Pinv
%   are such that P*R*Pinv = A.

% Global description of the algorithm:
%
% For a given n by n matrix A over a field K, we first compute the
% Frobenius normal form F of A. Then we compute the rational Jordan
% normal form of F, which is also the rational Jordan normal form of A.
% If F=diag(C1,..,Cr), where Ci is the companion matrix associated with
% a polynomial pi in K[x], we first compute the rational Jordan normal
% form of C1 to Cr. From these we then extract the rational Jordan
% normal form of F.

null(load!-package 'specfn);  % To use binomial, but not load during
                              % compilation.

symbolic procedure ratjordan(A);
  begin
    scalar AA,tmp,ans,P,Pinv,full_coeff_list,rule_list,input_mode;

    matrix_input_test(A);
    if (car size_of_matrix(A)) neq (cadr size_of_matrix(A))
     then rederr "ERROR: expecting a square matrix. ";

    input_mode := get(dmode!*,'dname);
    %
    % If modular or arnum are on then we keep them on else we want
    % rational on.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then on rational;
    on combineexpt;

    tmp := nest_input(A);
    AA := car tmp;
    full_coeff_list := cadr tmp;

    tmp := ratjordanform(AA,full_coeff_list);
    ans := car tmp;
    P := cadr tmp;
    Pinv := caddr tmp;
    %
    %  Set up rule list for removing nests.
    %
    rule_list := {'co,2,{'~,'int}}=>'int when numberp(int);
    for each elt in full_coeff_list do
    <<
      tmp := {'co,2,{'~,elt}}=>elt;
      rule_list := append (tmp,rule_list);
    >>;
    %
    %  Remove nests.
    %
    let rule_list;
    ans := de_nest_mat(ans);
    P := de_nest_mat(P);
    Pinv := de_nest_mat(Pinv);
    clearrules rule_list;
    %
    % Return to original mode.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then
       <<
         % onoff('nil,t) doesn't work so ...
         if input_mode = 'nil then off rational
         else onoff(input_mode,t);
       >>;
    off combineexpt;

    return {'list,ans,P,Pinv};
  end;

flag ('(ratjordan),'opfn);  %  So it can be used from
                            %  algebraic mode.



symbolic procedure ratjordanform(A,full_coeff_list);
  begin
    scalar tmp,F,TT,Tinv,prim_inv,S,Sinv,P,Pinv,x;

    x := mkid('x,0);

    tmp := frobeniusform(A);
    F := car tmp;
    TT := cadr tmp;
    Tinv := caddr tmp;

    tmp := frobenius_to_ratjordan(F,full_coeff_list,x);
    prim_inv := car tmp;
    S := cadr tmp;
    Sinv := caddr tmp;

    P := reval {'times,TT,S};
    Pinv := reval {'times,Sinv,Tinv};

    prim_inv := priminv_to_ratjordan(prim_inv,x);

    return {prim_inv,P,Pinv};
  end;




% companion_to_ratjordan computes the rational Jordan normal form of a
% matrix C which is the companion matrix of a polynomial p. Since the
% factors of p are known, the rational Jordan normal form of C is also
% known, so in fact we only have to compute the transition matrix.

% Global description of the algorithm:
%
% car consider the case where p=q^e, q irreducible. Let n=degree(p).
% Then we have the following diagram:
%
%                           ~
%                   K^n <------- K[x]/q^e
%
%                    |               |
%                    |               |
%                    |C              |x
%                    |               |
%                    |               |
%                   \ /             \ /
%                           ~
%                   K^n <------- K[x]/q^e
%
% We look for a K-basis (b1,..,bn) of K[x]/q^e such that we get the
% following diagram:
%
%                       ~                ~
%               K^n <------- K[x]/q^e -------> K^n
%
%                |               |              |
%                |               |              |
%                |C              |x             |ratj(q,e)
%                |               |              |
%                |               |              |
%               \ /             \ /            \ /
%                       ~                ~
%               K^n <------- K[x]/q^e -------> K^n
%
% Let q=x^d+q(d-1)*x^(d-1)+..+q1*x+q0. It follows that b1,..,bn must
% satisfy the following relations:
%
% x*b1      = b2
% x*b2      = b3
% ...
% x*bd      = -q0*b1-q1*b2-..-q(d-1)*bd
% x*b(d+1)  = b(d+2)+b1
% x*b(d+2)  = b(d+3)+b2
% ...
% x*b(2d)   = -q0*b(d+1)-q1*b(d+2)-..-q(d-1)*b(2d)+bd
% x*b(2d+1) = b(2d+2)+b(d+1)
% ...
% x*bn      = -q0*b(n-d+1)-q1*b(n-d+2)-..-q(d-1)*bn+b(n-d)
%
% From this we deduce that b1,b(d+1),b(2d+1),... must satisfy the
% following relations:
%
% q*b1      = 0
% q*b(d+1)  = q'*b1
% q*b(2d+1) = q'*b(d+1)-1/2*q''*b1
% q*b(3d+1) = q'*b(2d+1)-1/2*q''*b(d+1)+1/6*q'''*b1
% q*b(4d+1) = q'*b(3d+1)-1/2*q''*b(2d+1)+1/6*q'''*b(d+1)-1/24*q''''*b1
% ...
%
% where ' stands for taking the derivative with respect to x.
% If we choose b1=q^(e-1) we can compute b2,..,bn from the relations
% above. We assume that K is a perfect field, so q' is not zero. From
% this we see that q^(e-i-1) divides b(id+1) while q^(e-i) does not
% divide b(di+1). In particular we have gcd(b((e-1)i+1),q)=1.
% Notice also the following relations which can be easily proved:
%
% x^i*b1      = b(i+1)
% x^i*b(d+1)  = b(d+i+1)+binomial(i,1)*bi
% x^i*b(2d+1) = b(2d+i+1)+binomial(i,1)*b(d+i)+binomial(i,2)*b(i-1)
% ...
%
% Now the general case where p=q1^e1*q2^e2*..*qr^er. To compose the
% partial results we use the following diagram:
%
%      ~       ~                            ~
% K^n<--K[x]/p-->K[x]/q1^e1 X..X K[x]/qr^er-->K^n1 X......X K^nr
%
%  |       |         |               |          |             |
%  |       |         |               |          |             |
%  |C      |x        |x              |x         |  ratj       | ratj
%  |       |         |               |          |( q1,e1)     |(qr,er)
%  |       |         |               |          |             |
% \ /     \ /       \ /             \ /        \ /           \ /
%
%      ~       ~                            ~
% K^n<--K[x]/p-->K[x]/q1^e1 X..X K[x]/qr^er-->K^n1 X......X K^nr
%
% In order to compose the K_bases of K[x]/q1^e1 through K[x]/qr^er to
% a K-basis of K[x]/p we compute polynomials u1,..,ur such that
% (ui mod qi^ei)=1 and (ui mod qj^ej)=0.


symbolic procedure companion_to_ratjordan(fact_list,f,x);
  begin
    scalar g_list,u_list,bbasis,q1,e,qpower,diffq,part_basis,
           ratj_basis,s,tt,g,rowQinv,pol_lincomb,qq,rr,lincomb,index1,v,
           u,a,tmp,Qinv,Q,sum1;
    integer r,n,d;

    r := length fact_list;
    n := deg(f,x);

    g_list := for i:=1:r collect reval{'expt,nth(nth(fact_list,i),1),
                                       nth(nth(fact_list,i),2)};

    %%%%%%%%%%%%%%%%%%%
    % Compute u1,..,ur.
    %%%%%%%%%%%%%%%%%%%
    u_list := mkvect(r);
    if r=1 then putv(u_list,1,1)
    else
    <<
      tmp := calc_exgcd(nth(g_list,1),nth(g_list,2),x);
      s := cadr tmp;
      tt := caddr tmp;
      putv(u_list,1,{'times,tt,nth(g_list,2)});
      putv(u_list,2,{'times,s,nth(g_list,1)});
      g := {'times,nth(g_list,1),nth(g_list,2)};
      for i:=3:r do
      <<
        tmp := calc_exgcd(g,nth(g_list,i),x);
        s := cadr tmp;
        tt := caddr tmp;
        for j:=1:i-1 do
        <<
          putv(u_list,j,get_rem({'times,getv(u_list,j),tt,nth(g_list,i)}
               ,f));
        >>;
        putv(u_list,i,{'times,s,g});
        g := {'times,g,nth(g_list,i)};
      >>;
    >>;
    %%%%%%%%%%%%%%%%%%%

    bbasis := {};    %  Basis will contain a K-basis of K[x]/f.
    rowQinv := 0;

    Q := mkmatrix(n,n);
    Qinv := mkmatrix(n,n);

    for i:=1:r do
    <<
      q1 := nth(nth(fact_list,i),1);
      e := reval nth(nth(fact_list,i),2);
      d := deg(q1,x);

      qpower := mkvect(e+1);
      putv(qpower,1,1);
      for j:=2:e+1 do
      <<
        putv(qpower,j,{'times,q1,getv(qpower,j-1)});
      >>;

      if e>1 then
      <<
        diffq := mkvect(e-1);
        putv(diffq,1,reval algebraic df(q1,x));
        for j:=2:e-1 do
        <<
          tmp := reval getv(diffq,j-1);
          putv(diffq,j,reval algebraic df(tmp,x));
        >>;
      >>;

      %%%%%%%%%%%%%%%%%%%
      % Compute b1,b(d+1),b(2d+1),...
      %%%%%%%%%%%%%%%%%%%
      part_basis := mkvect(e);
      putv(part_basis,1,reval {'expt,q1,e-1});

      for j:=2:e do
      <<
        sum1 := 0;
        for k:=1:j-1 do
        <<
          tmp := reval{'times, reval {'quotient,reval {'expt,-1,k-1},
                       reval{'factorial,k}},reval getv(diffq,k),
                       reval getv(part_basis,j-k)};
          sum1 := reval{'plus,sum1,tmp};
        >>;
        putv(part_basis,j,reval{'quotient,sum1,q1});
      >>;
      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
      % Compute b1,..,bni.
      %%%%%%%%%%%%%%%%%%%
      ratj_basis := mkvect(e*d);
      putv(ratj_basis,1,getv(part_basis,1));

      for k:=2:d do
      <<
        putv(ratj_basis,k,{'times,x,getv(ratj_basis,k-1)});
      >>;

      for j:=2:e do
      <<
        putv(ratj_basis,(j-1)*d+1,getv(part_basis,j));
        for k:=2:d do
        <<
          putv(ratj_basis,(j-1)*d+k,{'plus,{'times,x,getv(ratj_basis,
               (j-1)*d+k-1)},{'minus,getv(ratj_basis,(j-2)*d+k-1)}});
        >>;
      >>;

      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
      % Complete basis.
      %%%%%%%%%%%%%%%%%%%
      for k:=1:e*d do
      <<
        tt := get_rem({'times,getv(u_list,i),getv(ratj_basis,k)},f);
        bbasis := append(bbasis,{tt});
      >>;
      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
      % Compute next e*d rows of Qinv (see diagram above).
      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
      % Compute coordinates of 1 with respect to basis (b1,..,bn).
      % Use fact that q1^(e-i-1) divides b(id+1) and gcd(b((e-1)d+1),q1)
      %  = 1
      %%%%%%%%%%%%%%%%%%%
      pol_lincomb := mkvect(e);
      for j:=1:e do putv(pol_lincomb,j,0);
      tmp := calc_exgcd(getv(part_basis,e),getv(qpower,e+1),x); % =1
      s := cadr tmp;
      tt := caddr tmp;
      putv(pol_lincomb,e,s);

      for j:=e step -1 until 1 do
      <<
        qq := get_quo(getv(pol_lincomb,j),q1);
        rr := get_rem(getv(pol_lincomb,j),q1);
        putv(pol_lincomb,j,rr);

        for k:=1:j-1 do
        <<
          putv(pol_lincomb,j-k,get_rem({'plus,getv(pol_lincomb,j-k),
               {'times,qq,getv(diffq,k),{'expt,-1,{'quotient,k,
               {'factorial,k}}}}},getv(qpower,j+1)));
        >>;

      >>;

      lincomb := mkvect(e*d);
      for j:=1:e do
      <<
        for k:=1:d do
        <<
          index1 := (j-1)*d+k;
          putv(lincomb,index1,coeffn(getv(pol_lincomb,j),x,k-1));

          for v:=1:min(j-1,k-1) do
          <<
            putv(lincomb,index1-v*d-v,reval{'plus,getv(lincomb,
                 index1-v*d-v),{'times,coeffn(getv(pol_lincomb,j),x,k-1)
                 ,binomial(k-1,v)}});
          >>;

        >>;
      >>;

      for u:=1:e*d do
      <<
        rowQinv:=rowQinv+1;
        setmat(Qinv,rowQinv,1,getv(lincomb,u));
      >>;
      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
      % Compute coordinates of x^v with respect to basis (b1,..,bn).
      %%%%%%%%%%%%%%%%%%%
      for v:=2:n do
      <<
        %
        % a := copy(lincomb).
        %
        a := mkvect(upbv lincomb);
        for i:=1:upbv lincomb do
        <<
          putv(a,i,getv(lincomb,i));
        >>;

        index1 := 0;
        for j:=1:e-1 do
        <<
          index1 := index1 + 1;
          putv(lincomb,index1,reval{'plus,{'times,
               {'minus,coeffn(q1,x,0)},getv(a,j*d)},getv(a,j*d+1)});

          for k:=2:d do
          <<
            index1 := index1+1;
            putv(lincomb,index1,reval{'plus,{'plus,getv(a,(j-1)*d+k-1),
                 {'times,{'minus,coeffn(q1,x,k-1)},getv(a,j*d)},
                 getv(a,j*d+k)}});
          >>;

        >>;

        index1 := index1 + 1;
        putv(lincomb,index1,reval{'times,{'minus,coeffn(q1,x,0)},
             reval getv(a,e*d)});

        for k:=2:d do
        <<
          index1 := index1 + 1;
          putv(lincomb,index1,reval{'plus,getv(a,(e-1)*d+k-1),{'times,
               {'minus,coeffn(q1,x,k-1)},getv(a,e*d)}});
        >>;

        rowQinv := rowQinv-e*d;
        for u:=1:e*d do
        <<
          rowQinv := rowQinv +1;
          setmat(Qinv,rowQinv,v,getv(lincomb,u));
        >>;

      >>;
      %%%%%%%%%%%%%%%%%%%

      %%%%%%%%%%%%%%%%%%%
    >>;

    %%%%%%%%%%%%%%%%%%%
    % Compute Q (see diagram above).
    %%%%%%%%%%%%%%%%%%%
    for j:=1:n do
    <<
      for k:=1:n do
      <<
        setmat(Q,k,j,coeffn(nth(bbasis,j),x,k-1));
      >>;
    >>;
    %%%%%%%%%%%%%%%%%%%

    return {Q,Qinv};
  end;




symbolic procedure convert_to_mult(faclist,x);
  %
  % This function takes as input a list of factors from factorize
  % and converts it to a list as follows: {{fac,mult},{fac,mult}...},
  % where mult is the multiplicity of that factorial.
  %
  % No need to deal with cases such as {x,x,x,x+1,x+1,x,x,x,x+1}
  % (for example) as factorize groups factorials together.
  %
  % Note that {x,-x} will give {{x,2}}.
  %
  % The factorials are normalised w.r.t. x. ie: 5*x^2 -> x^2.
  % NB: This does not normalise multivariate polynomials as completely
  %     as the maple "factors" does. This may cause a bug in the matrix
  %     normforms but all cases tried so far seem to work.
  %
  begin
    scalar multlist,z;
    integer mult1;

    faclist := cdr faclist; % Remove 'list that is added by factorize.

    %  Remove non polynomial (integer) factor if it's there.
    if numberp car faclist then faclist := cdr faclist;

    multlist := {};

    for i:=2:length faclist+1 do
    <<
      mult1 := 1;

      % While we're in faclist and abs value of adjacent elt's is equal.
      while i<= length faclist and numberp(z := reval {'quotient,
            nth(faclist,i-1),nth(faclist,i)}) and abs z = 1 do
      <<
        mult1 := mult1+1;
        i := i+1;
      >>;
      %
      %  Normalise list so that lcof of each elt wrt x is +1.
      %  NB: no need to consider case where lcof(int,x) gives 0 as
      %  faclist will never contain integers.
      %
      if numberp off_mod_lcof(nth(faclist,i-1),x) and
         off_mod_lcof(nth(faclist,i-1),x) neq 0 then
      <<
          multlist := append(multlist,{{reval {'quotient,
                             nth(faclist,i-1),off_mod_lcof
                             (nth(faclist,i-1),x)},mult1}});
      >>
      % Make -elt -> elt.
      else if car nth(faclist,i-1) = 'minus then
      <<
        multlist := append(multlist,{{cadr nth(faclist,i-1),mult1}});
      >>
      else multlist := append(multlist,{{nth(faclist,i-1),mult1}});

    >>;

    return multlist;
  end;




symbolic procedure copyinto(BB,AA,p,q);
  %
  % Copies matrix BB into AA with BB(1,1) at AA(p,q).
  % Returns newly formed matrix A.
  %
  % Can be used independently from algebraic mode.
  %
  begin
    scalar A,B;
    integer m,n,r,c;

    matrix_input_test(AA);
    matrix_input_test(BB);

    if p = 0 or q = 0 then
     rederr "     0 is out of bounds for matrices.
     The top left element is labelled (1,1) and not (0,0).";

    m := car size_of_matrix(AA);
    n := cadr size_of_matrix(AA);
    r := car size_of_matrix(BB);
    c := cadr size_of_matrix(BB);

    if r+p-1>m or c+q-1>n then rederr
     {"The matrix",BB,"does not fit into",AA,"at position",p,q,"."};

    A := mkmatrix(m,n);
    B := mkmatrix(r,c);

    for i:=1:m do
    <<
      for j:=1:n do
      <<
        setmat(A,i,j,getmat(AA,i,j));
      >>;
    >>;

    for i:=1:r do
    <<
      for j:=1:c do
      <<
        setmat(B,i,j,getmat(BB,i,j));
      >>;
    >>;

    for i:=1:r do
    <<
      for j:=1:c do
      <<
        setmat(A,p+i-1,q+j-1,getmat(B,i,j));
      >>;
    >>;

    return A;
  end;

flag ('(copyinto),'opfn);  %  So it can be used independently
                           %  from algebraic mode.



symbolic procedure de_nest_list(input,full_coeff_list);
  %
  % Takes as input a list of nested polys and de-nests them all.
  %
  begin
    scalar tmp,copy,rule_list;

    if full_coeff_list = nil then copy := input
    else
    <<
      copy := input;
      %
      %  Set up rule list for removing nests.
      %
      rule_list := {'co,2,{'~,'int}}=>'int when numberp(int);
      for each elt in full_coeff_list do
      <<
        tmp := {'co,2,{'~,elt}}=>elt;
        rule_list := append (tmp,rule_list);
      >>;
      %
      %  Remove nests.
      %
      let rule_list;
      if atom copy then copy := reval copy
      else copy := for each elt in copy collect reval elt;
      clearrules rule_list;
    >>;

    return copy;
  end;




symbolic procedure deg_sort(l,x);
  %
  % Takes a list of polys and sorts them into increasing order.
  %
  % Has been written so that it can also be run independently
  % from algebraic mode.
  %
  begin
    scalar ll,alg;
    integer n;
    %
    %  If input from algebraic mode then car is 'list. In the normal
    %  forms, l in entered without the 'list.
    %
    if car l = 'list then
    <<
      ll := cdr l;
      alg := t;
    >>
    else ll := l;

    %  Get no of elts.
    n := length ll;

    for i:=1:n-1 do
    <<
      for j:=i+1:n do
      <<
        if deg(nth(ll,j),x) < deg(nth(ll,i),x) then
        <<
          ll := append(append(append(for k:=1:i-1 collect nth(ll,k),
                       {nth(ll,j)}),for k:=i:j-1 collect nth(ll,k)),
                       for k:=j+1:n collect nth(ll,k));
        >>;
      >>;
    >>;

    %  If input from algebraic mode then make output algebraic
    %  compatible.
    if alg then ll := append({'list},ll);

    return ll;
  end;

flag ('(deg_sort),'opfn);  %  So it can be used independently from
                           %  algebraic mode.



symbolic procedure frobenius_to_invfact(F,x);
  %
  % For a matrix F in Frobenius normal form, frobenius_to_invfact(F,x)
  % computes inv_fact := {p1,..,pr} such that
  % F=invfact_to_frobenius(plist,x).
  %
  begin
    scalar p,inv_fact;
    integer row_dim,m,k;

    row_dim := car size_of_matrix(F);
    inv_fact := {};
    k := 1;

    while k<=row_dim do
    <<
      p := 0;
      m := k+1;
      while m<=row_dim and getmat(F,m,m-1)=1 do m:=m+1;
      for j:=k:m-1 do
      <<
        p := reval{'plus,p,{'times,{'minus,getmat(F,j,m-1)},
                   {'expt,x,j-k}}};
      >>;
      p := reval{'plus,p,{'expt,x,m-k}};
      inv_fact := append(inv_fact,{p});
      k := m;
    >>;

    return inv_fact;
  end;




symbolic procedure frobenius_to_ratjordan(F,full_coeff_list,x);
  %
  % frobenius_to_ratjordan computes the rational Jordan form R of a
  % matrix F which is in Frobenius normal form. Say F=diag(C1,..,Cr),
  % where Ci is the companion matrix associated with the polynomial pi.
  % first we determine the irreducible factors p1,..,pN which appear
  % in p1 through pr and build a matrix fact_mat such that pi=
  % product(Pj^fact_mat(i,j),j=1..N). This matrix is used a several
  % places in the algorithm.
  % In fact we can immediately extract from fact_mat the rational
  % Jordan normal of F. We compute the transformation matrix by
  % rearranging the former results.
  % If R is the matrix in rational Jordan normalform corresponding to
  % prim_inv:=[[q1,[e11,e12,...]],[q2,[e21,e22,...]],....], then
  % prim_inv is returned by frobenius_to_ratjordan.
  %
  begin
    scalar inv_fact,gg,l,m,h,p,Fact_mat,G,ii,pp,ff,j,t_list,tinv_list,
           facts,tmp,q,qinv,degp,D,TT,S,cols,count,Tinv,Sinv,exp_list,
           prim_inv,nn,prod;
    integer r,n;

    %  Compute p1,..,pr.
    inv_fact := frobenius_to_invfact(F,x);
    r := length inv_fact;

    %%%%%%%%%%%%%%%%%%%
    % Compute fact_mat
    %%%%%%%%%%%%%%%%%%%
    gg := append({nth(inv_fact,1)},for i:=2:r collect
    get_quo(nth(inv_fact,i),nth(inv_fact,i-1)));

    l := {};
    for i:=1:r do
    <<

      % the problem is that den co(2,?) gives 1 and not ? so we
      % have to de_nest it first (then use co(2,m) later).
      prod := 1;
      for j:=0:deg(nth(gg,i),x) do
      <<
        %
        %  In the following code we take the denominator of a
        %  polynomial.
        %  There are two problems:
        %  1) den co(2,?) gives 1 and not ?.
        %  2) with rational on den(1/3) = 1 (we require 3).
        %  To solve problem 1 we de_nest the polynomial.
        %  To solve problem 2 the easy solution would be to turn
        %  rational off. Unfortunately arnum may be on so we can't do
        %  this. Thus we test to see if poly is a number and then a
        %  quotient. If it is we take the den using get_den. If poly is
        %  not a  number then problem 2 does not apply.
        %
        tmp := de_nest(reval coeffn(nth(gg,i),x,j));
        if evalnumberp tmp then
        <<
          if quo_test(tmp) then tmp := get_den(tmp)
          else tmp := 1;
        >>
        %  else coeffn is a poly in which case den will work.
        else
        <<
          tmp := den(tmp);
        >>;
        prod := reval {'times,tmp,prod};
      >>;
      m := prod;

      %  Next lines not necessary but quicker.
      if m = 1 and nth(gg,i) = 1 then h := {}
      else if m = 1 then
      <<
        tmp := de_nest_list(nth(gg,i),full_coeff_list);
        tmp := old_factorize(tmp);
        tmp := re_nest_list(tmp,full_coeff_list);
        h := (convert_to_mult(tmp,x));
      >>
      else
      <<
        tmp := reval{'times,{'co,2,m},nth(gg,i)};
        tmp := de_nest_list(tmp,full_coeff_list);
        tmp := old_factorize(tmp);
        tmp := re_nest_list(tmp,full_coeff_list);
        h := (convert_to_mult(tmp,x));
      >>;
      l := append(l,(for j:=1:length h collect {i,{'quotient,
                  nth(nth(h,j),1),off_mod_lcof(nth(nth(h,j),1),x)},
                  nth(nth(h,j),2)}));
    >>;

    p := deg_sort(for i:=1:length l collect nth(nth(l,i),2),x);
    n := length p;
    G := mkmatrix(r,n);
    Fact_mat := mkmatrix(r,n);

    for k:=1:length l do
    <<
      ii := nth(nth(l,k),1);
      pp := nth(nth(l,k),2);
      ff := nth(nth(l,k),3);
      j := 1;
      while pp neq nth(p,j) and j<=n do j:=j+1;
      setmat(G,ii,j,ff);
    >>;

    for j:=1:n do setmat(Fact_mat,1,j,getmat(G,1,j));
    for i:=2:r do
    <<
      for j:=1:n do
      <<
        setmat(Fact_mat,i,j,{'plus,getmat(Fact_mat,i-1,j),
               getmat(G,i,j)});
      >>;
    >>;
    %%%%%%%%%%%%%%%%%%%

    %%%%%%%%%%%%%%%%%%%
    % Compute transition matrix for C1 through Cr.
    %%%%%%%%%%%%%%%%%%%
    t_list := {};
    tinv_list := {};
    for i:=1:r do
    <<
      facts := {};

      for j:=1:n do
      <<
        if getmat(Fact_mat,i,j) neq 0 then
        <<
          facts := append(for each elt in facts collect elt,
                          {{nth(p,j),getmat(Fact_mat,i,j)}});
        >>;
      >>;

      tmp := companion_to_ratjordan(facts,nth(inv_fact,i),x);
      Q := car tmp;
      Qinv := cadr tmp;
      tinv_list := append(tinv_list,{Qinv});
      t_list := append(t_list,{Q});
    >>;
    %%%%%%%%%%%%%%%%%%%

    %%%%%%%%%%%%%%%%%%%
    % Compute transition matrix by permuting diag(t_list(1),..,
    % t_list(r)).
    %%%%%%%%%%%%%%%%%%%
    D := mkmatrix(r,n);
    degp := mkvect(r);
    for i:=1:r do
    <<
      for j:=1:n do
      <<
        setmat(d,i,j,{'times,deg(nth(p,j),x),getmat(fact_mat,i,j)});
      >>;
      putv(degp,i,for j:=1:n sum off_mod_reval(getmat(d,i,j)));
    >>;

    cols := {};
    for j:=1:n do
    <<
      for i:=1:r do
      <<
        count := reval{'plus,for k:=1:i-1 sum off_mod_reval
                       (getv(degp,k)),for k:=1:j-1 sum reval
                       getmat(d,i,k)};
        for h:=1:off_mod_reval(getmat(d,i,j)) do
        <<
          cols := append(cols,{reval{'plus,count,h}});
        >>;
      >>;
    >>;

    TT := reval{'diagi,t_list};
    nn := car size_of_matrix(TT);
    S := mkmatrix(nn,nn);
    for i:=1:nn do
    <<
      for j:=1:nn do
      <<
        setmat(S,i,j,getmat(TT,i,nth(cols,j)));
      >>;
    >>;

    Tinv := reval{'diagi,tinv_list};
    Sinv := mkmatrix(nn,nn);
    for i:=1:nn do
    <<
      for j:=1:nn do
      <<
        setmat(Sinv,i,j,getmat(Tinv,nth(cols,i),j));
      >>;
    >>;
    %%%%%%%%%%%%%%%%%%%

    %%%%%%%%%%%%%%%%%%%
    % Compute prim_inv.
    %%%%%%%%%%%%%%%%%%%
    prim_inv := {};
    for j:=1:n do
    <<
      exp_list:={};
      for i:=1:r do
      <<
        if getmat(fact_mat,i,j) neq 0
         then exp_list := append(exp_list,{getmat(fact_mat,i,j)});
      >>;
      prim_inv := append(prim_inv,{{nth(p,j),exp_list}});
    >>;
    %%%%%%%%%%%%%%%%%%%

    return {prim_inv,S,Sinv};
  end;

symbolic procedure get_den(input);
  %
  % Gets denominator, ignoring sign.
  %
  begin
    scalar denom,copy;
    copy := input;
    if car copy = 'minus then copy := cadr copy;
    denom := caddr copy;
    return denom;
  end;

symbolic procedure make_ratj_block(p,e,x);
  %
  % For a monic polynomial p in x and a positive integer e,
  % make_ratj_block(p,e,x) returns the matrix ratj(p,e).
  %
  begin
    scalar C,J_block;
    integer d,n;

    C := companion(p,x);

    d := deg(p,x);
    e := off_mod_reval(e);
    n := d*e;
    J_block  := mkmatrix(n,n);

    for i:=1:e do
    <<
      J_block := copyinto(C,J_block,(i-1)*d+1,(i-1)*d+1);
    >>;

    for i:=1:n-d do
    <<
      setmat(J_block,i,i+d,1);
    >>;

    return J_block;
  end;




symbolic procedure priminv_to_ratjordan(prim_inv,x);
  %
  % For a primary invariant prim_inv, priminv_to_ratjordan(prim_inv,x)
  % returns the matrix R in rational Jordan normal form corresponding to
  % prim_inv.
  %
  begin
    scalar p,exp_list,block_list;
    integer r;

    r := length prim_inv;
    block_list := {};

    for i:=1:r do
    <<
      p := nth(nth(prim_inv,i),1);
      exp_list := nth(nth(prim_inv,i),2);
      for j:=1:length exp_list do
      <<
        block_list := append(block_list,{make_ratj_block(p,
    nth(exp_list,j),x)});
      >>;
    >>;

    return reval{'diagi,block_list};
  end;




symbolic procedure quo_test(input);
  %
  % Tests for quotient returning t or nil;
  %
  begin
    scalar boolean,copy;
    copy := input;
    if atom copy then <<>> else
    <<
      if car copy = 'minus then copy := cadr copy;
      if car copy := 'quotient then boolean := t else boolean := nil;
    >>;
    return boolean;
  end;




symbolic procedure re_nest_list(input,full_coeff_list);
  %
  % Re_nests the list that has been de_nested.
  %
  begin
    scalar tmp,copy;

    copy := input;

    for each elt in full_coeff_list do
    <<
      tmp := {'co,2,elt};
      copy := algebraic (sub(elt=tmp,copy));
    >>;

    return copy;
  end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/normform.tst0000644000175000017500000001507511526203062024746 0ustar  giovannigiovanni%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
% Examples of calculations of matrix normal forms using the REDUCE     %
% NORMFORM package.                                                    %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% load_package normform;

on errcont; % So that computation continues after an error.

%
% If using xr, the X interface for REDUCE, then turn on looking_good to 
% improve the appearance of the output.
%
fluid '(options!*);

lisp if memq('fmprint ,options!*) then on looking_good;

procedure test(tmp,A);
  % 
  % Checks that P * N * P^-1 = A where tmp is the output {P,N,P^-1} 
  % of the Normal form calculation on A.
  %
  begin
    if second tmp * first tmp * third tmp = A then
    write "Seems O.K." else rederr "something isn't working.";
  end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%% Smithex %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((3*x,x^2+x),(0,x^2));
  answer := smithex(A,x);
  test(answer,A);

  %
  % Extend algebraic field to include sqrt2.
  %
  load_package arnum;
  defpoly sqrt2**2-2;
  A := mat((sqrt2*y^2,y+1),(3*sqrt2,y^3+y*sqrt2));
  answer := smithex(A,y);
  test(answer,A);
  off arnum;

  %
  % smithex will compute the Smith normal form of matrices containing 
  % only integer entries but the integers are regarded as univariate 
  % polynomials in x over a field F (the rationals unless the field has 
  % been extended). For calculations over the integers use smithex_int.
  %
  A := mat((9,-36,30),(-36,192,-180),(30,-180,180));
  answer := smithex(A,x);
  test(answer,A);

%%%%%%%%%%%%%%%%%%%%%%%%%%%% Smithex_int %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((1,2,3),(4,5,6),(7,8,x));
  answer := smithex_int(A);

  A := mat((9,-36,30),(-36,192,-180),(30,-180,180));
  answer := smithex_int(A);
  test(answer,A);


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Frobenius %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));
  answer := frobenius(A);
  test(answer,A);

  %
  % Extend algebraic field to include i.
  %
%   load_package arnum;
    defpoly i^2+1;
    A := mat((-3-i,1,2+i,7-9*i),(-2,1,1,5-i),(-2-2*i,1,2+2*i,4-2*i),
             (2,0,-1,-2+8*i));
    answer := frobenius(A);
    off arnum;

  A := mat((10,-5,-5,8,3,0),(-4,2,-10,-7,-5,-5),(-8,2,7,3,7,5),
           (-6,-7,-7,-7,10,7),(-4,-3,-3,-6,8,-9),(-2,5,-5,9,7,-4));
  F := first frobenius(A);

  %
  % Calculate in Z\23Z...
  %
    on modular;
    setmod 23;
    F_mod := first frobenius(A);
 
  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;
    F_bal_mod := first frobenius(A);
    off balanced_mod;
    off modular;


%%%%%%%%%%%%%%%%%%%%%%%%%%% Ratjordan %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));
  answer := ratjordan(A);
  test(answer,A);

  %
  % Extend algebraic field to include sqrt(2).
  %
  %  load_package arnum;
    defpoly sqrt2**2-2;
    A:= mat((4*sqrt2-6,-4*sqrt2+7,-3*sqrt2+6),(3*sqrt2-6,-3*sqrt2+7,
            -3*sqrt2+6),(3*sqrt2,1-3sqrt2,-2*sqrt2));
    answer := ratjordan(A);
    test(answer,A);
    off arnum;

  A := mat((-12752,-6285,-9457,-7065,-4939,-5865,-3769),(13028,6430,
           9656, 7213,5041,5984,3841),(16425,8080,12192,9108,6370,7569,
           4871), (-6065,-2979,-4508,-3364,-2354,-2801,-1803),(2968,
           1424,2231, 1664,1171,1404,919),(-22762,-11189,-16902,-12627,
           -8833, -10498,-6760),(23112,11400,17135,12799,8946,10622,
           6821));
  R := first ratjordan(A);

  %
  % Calculate in Z/23Z...
  %
    on modular;
    setmod 23;
    R_mod := first ratjordan(A);

  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;
    R_bal_mod := first ratjordan(A);
    off balanced_mod;
    off modular;


%%%%%%%%%%%%%%%%%%%%%%%%%%% jordansymbolic %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));
  answer := jordansymbolic(A);


  %
  % Extend algebraic field.
  %
  % load_package arnum;
    defpoly b^3-2*b+b-5;
    A := mat((1-b,2+b^2),(3+b-2*b^2,3));
    answer := jordansymbolic(A);
    off arnum;

  A := mat((-9,21,-15,4,2,0),(-10,21,-14,4,2,0),(-8,16,-11,4,2,0),
           (-6,12,-9,3,3,0),(-4,8,-6,0,5,0),(-2,4,-3,0,1,3));
  answer := jordansymbolic(A);
  
  % Check to see if looking_good (*) is on as the choice of using 
  % either lambda or xi is dependent upon this.
  % (* -> the use of looking_good is described in the manual.).
  if not lisp !*looking_good then
  <<
    %
    % NB: we use lambda_ in solve (instead of lambda) as lambda is used
    % for other purposes in REDUCE which mean it cannot be used with
    % solve.
    %
    solve(lambda_^2-4*lambda_+5,lambda_);
    J := sub({lambda31=i + 2,lambda32= - i + 2},first answer);
    P := sub({lambda31=i + 2,lambda32= - i + 2},third answer);
    Pinv :=sub({lambda31=i + 2,lambda32= - i + 2},third rest answer);
  >>
  else 
  <<
    solve(xi^2-4*xi+5,xi);
    J := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},first answer);
    P := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},third answer);
    Pinv := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},third rest answer);
  >>;
  test({J,P,Pinv},A);

  %
  % Calculate in Z/23Z...
  %
    on modular;
    setmod 23;
    answer := jordansymbolic(A)$
    J_mod := {first answer, second answer};

  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;
    answer := jordansymbolic(A)$
    J_bal_mod := {first answer, second answer};
    off balanced_mod;
    off modular;
 

%%%%%%%%%%%%%%%%%%%%%%%%%%%% jordan %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((1,y),(y^2,3));
  answer := jordan(A);
  test(answer,A);

  A := mat((-12752,-6285,-9457,-7065,-4939,-5865,-3769),(13028,6430,
          9656, 7213,5041,5984,3841),(16425,8080,12192,9108,6370,7569,
          4871), (-6065,-2979,-4508,-3364,-2354,-2801,-1803),(2968,
          1424,2231, 1664,1171,1404,919),(-22762,-11189,-16902,-12627,
          -8833, -10498,-6760),(23112,11400,17135,12799,8946,10622,
          6821));
  on rounded;
  J := first jordan(A);
  off rounded;

  %
  % Extend algebraic field.
  %
  % load_package arnum;
    defpoly b^3-2*b+b-5;
    A := mat((1-b,2+b^2),(3+b-2*b^2,3));
    J := first jordan(A);
    off arnum;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/normform.red0000644000175000017500000000722511526203062024704 0ustar  giovannigiovannimodule normform; % Package for the computation of several normal forms.
%                                                                      %
% This file contains routines for computation of the following         %
% normal forms of matrices:                                            %
%                                                                      %
%  - smithex_int                                                       %
%  - smithex                                                           %
%  - frobenius                                                         %
%  - ratjordan                                                         %
%  - jordansymbolic                                                    %
%  - jordan                                                            %
%                                                                      %
% The manual for this package is found in the normform.tex file.       %
% It includes descriptions of the various normal forms.                %
%                                                                      %
% Further examples are found in the normform.log file.                 %
%                                                                      %
% For a description of the algorithms see the comments.                %
%                                                                      %
%                                                                      %
% Author: Matt Rebbeck   Nov '93 - Feb '94                             %
%                                                                      %
% This code has been converted from the normform and Normform packages %
% written by T.M.L. Mulders and A.H.M. Levelt for Maple.               %
%                                                                      %
% normform contains one switch: looking_good. If using xr, the X       %
% interface for REDUCE, switching this on will improve the appearance  %
% of the output. The switch serves no (useful) purpose in standard     %
% REDUCE (ie: not using xr).                                           %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(normform jordan jordsymb ratjord froben matarg
                  nestdom smithex smithex1),'(contrib normform));

endmodule;

end;




















mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/smithex.red0000644000175000017500000003134011526203062024521 0ustar  giovannigiovannimodule smithex; % Computation of the Smithex normal form of a matrix.                                                              %


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% The function smithex computes the Smith normal form S of an n by m
% rectangular matrix of univariate polynomials in x.
%
% Specifically:
%
% - smithex(A,x) will return {S,P,Pinv} where S, P, and Pinv
%   are such that P*S*Pinv = A.

symbolic procedure smithex(mat1,x);
  begin
    scalar A,Left,Right,tmp,isclear,g,L,R1,poly1,poly2,quo1,quo2,r,
           lc,tquo,q,full_coeff_list,rule_list,input_mode;
    integer i,j,n,m;

    matrix_input_test(mat1);

    input_mode := get(dmode!*,'dname);
    if input_mode = 'modular
     then rederr "ERROR: smithex does not work with modular on.";
    all_integer_entries_test(mat1);
    if input_mode neq 'arnum and input_mode neq 'rational
     then on rational;
    on combineexpt;

    tmp := nest_input_smith(mat1,x);
    A := car tmp;
    full_coeff_list := cadr tmp;

    n := car size_of_matrix(A); %  No. of rows.
    m := cadr size_of_matrix(A); %  No. of columns.

    Left := make_identity(n,n) ;
    Right := make_identity(m,m);

    for k:=1:min(n,m) do
    <<
      %
      %  Pivot selection from row k to column k.
      %
      i := k; while i <= n and getmat(A,i,k) = 0 do i := i+1;
      j := k; while j <= m and getmat(A,k,j) = 0 do j := j+1;

      if i > n and j > m then <<>>
      else
      <<
        %
        %  Select smallest non-zero entry as pivot.
        %
        for l:=i+1:n do
        <<
          if getmat(A,l,k) = 0 then l := l+1
          else if deg(getmat(A,l,k),x) < deg(getmat(A,i,k),x) then
          i := l;
        >>;

        for l:=j+1:m do
        <<
          if getmat(A,k,l) = 0 then l := l+1
          else if deg(getmat(A,k,l),x) < deg(getmat(A,k,j),x) then
          j := l;
        >>;

        if i <= n and (j > m or deg(getmat(A,i,k),x) <
                                 deg(getmat(A,k,j),x))
    then
        %
        %  Pivot is A(i,k), interchange row k,i if necessary.
        %
        <<
          if i neq k then
          <<

            for l:=k:m do
            <<
              tmp := getmat(A,i,l);
              setmat(A,i,l,getmat(A,k,l));
              setmat(A,k,l,tmp);
            >>;

            for l:=1:n do
            <<
              tmp := getmat(Left,l,i);
              setmat(Left,l,i,getmat(Left,l,k));
              setmat(Left,l,k,tmp);
            >>;

          >>
        >>
        else
        %
        %  Pivot is A(k,j), interchange column k,j if necessary.
        %
        <<
          if j neq k then
          <<

            for l:=k:n do
            <<
              tmp := getmat(A,l,j);
              setmat(A,l,j,getmat(A,l,k));
              setmat(A,l,k,tmp);
            >>;

            for l:=1:m do
            <<
              tmp := getmat(Right,j,l);
              setmat(Right,j,l,getmat(Right,k,l));
              setmat(Right,k,l,tmp);
            >>;

          >>;
        >>;

        isclear := nil;

        while not isclear do
        %
        %  0 out column k from k+1 to n.
        %
        <<
          for i:=k+1:n do
          <<
            if getmat(A,i,k) = 0 then <<>>
            else
            <<
              poly1 := getmat(A,k,k);
              poly2 := getmat(A,i,k);
              tmp := calc_exgcd(poly1,poly2,x);
              g := car tmp;
              L := cadr tmp;
              R1 := caddr tmp;
              quo1 := get_quo(poly1,g);
              quo2 := get_quo(poly2,g);

              for j:=k+1:m do
              <<
                tmp := {'plus,{'times,L,getmat(A,k,j)},{'times,R1,
                        getmat(A,i,j)}};
                setmat(A,i,j,{'plus,{'times,quo1,getmat(A,i,j)},{'times,
                       {'minus,quo2},getmat(A,k,j)}});
                setmat(A,k,j,tmp);
              >>;

              for j:=1:n do
              <<
                tmp := {'plus,{'times,quo1,getmat(Left,j,k)},
                        {'times,quo2,getmat(Left,j,i)}};
                setmat(Left,j,i,{'plus,{'times,{'minus,R1},
                       getmat(Left,j,k)},{'times,L,getmat(Left,j,i)}});
                setmat(Left,j,k,tmp);
              >>;

              setmat(A,k,k,g);
              setmat(A,i,k,0);
            >>;
          >>;

          isclear := t;
          %
          % 0 out row k from k+1 to m.
          %
          for i:=k+1:m do
          <<
            q := get_quo(getmat(A,k,i),getmat(A,k,k));
            setmat(A,k,i,get_rem(getmat(A,k,i),getmat(A,k,k)));

            for j:=1:m do
            <<
              setmat(Right,k,j,{'plus,getmat(Right,k,j),{'times,q,
                     getmat(Right,i,j)}});
            >>;

          >>;

          for i:=k+1:m do
          <<
            if getmat(A,k,i) = 0 then <<>>
            else
            <<
              poly1 := getmat(A,k,k);
              poly2 := getmat(A,k,i);
              tmp := calc_exgcd(poly1,poly2,x);
              g := car tmp;
              L := cadr tmp;
              R1 := caddr tmp;
              quo1 := get_quo(poly1,g);
              quo2 := get_quo(poly2,g);

              for j:=k+1:n do
              <<
                tmp := {'plus,{'times,L,getmat(A,j,k)},{'times,R1,
                        getmat(A,j,i)}};
                setmat(A,j,i,{'plus,{'times,quo1,getmat(A,j,i)},{'times,
                       {'minus,quo2},getmat(A,j,k)}});
                setmat(A,j,k,tmp);
              >>;

              for j:=1:m do
              <<
                tmp := {'plus,{'times,quo1,getmat(Right,k,j)},
                        {'times,quo2,getmat(Right,i,j)}};
                setmat(Right,i,j,{'plus,{'times,{'minus,R1},
                       getmat(Right,k,j)},
                       {'times,L,getmat(Right,i,j)}});
                setmat(Right,k,j,tmp);
              >>;

              setmat(A,k,k,g);
              setmat(A,k,i,0);
              isclear := nil;
            >>;
          >>;

        >>;
      >>;
    >>;

    r := 0;
    %
    %  At this point, A is diagonal: some A(i,i) may be zero.
    %  Move non-zero's up also making all entries unit normal.
    %
    for i:=1:min(n,m) do
    <<
      if getmat(A,i,i) neq 0 then
      <<
        r := r+1;
        % Watch out for integers giving lc = 0.
        if lcof(getmat(A,i,i),x) = 0  then lc := getmat(A,i,i)
        else lc := lcof(getmat(A,i,i),x);
        setmat(A,r,r,{'quotient,getmat(A,i,i),lc});

        if i = r then
        <<
          for j:=1:m do
          <<
            setmat(Right,i,j,{'times,getmat(Right,i,j),lc});
          >>;
        >>
        else
        <<
          setmat(A,i,i,0);
          for j:=1:n do
          <<
            tmp := getmat(Left,j,r);
            setmat(Left,j,r,getmat(Left,j,i));
            setmat(Left,j,i,tmp);
          >>;
          for j:=1:m do
          <<
            tmp := {'times,getmat(Right,i,j),lc};
            setmat(Right,i,j,{'quotient,getmat(Right,r,j),lc});
            setmat(Right,r,j,tmp);
          >>;
        >>;

      >>;
    >>;
    %
    %  Now make A(i,i) | A(i+1,i+1) for 1 <= i < r.
    %
    for i:=1:r-1 do
    <<
      j:=i+1;
      <<
        while getmat(A,i,i) neq 1 and j <= r do
        <<
          poly1 := getmat(A,i,i);
          poly2 := getmat(A,j,j);
          tmp := calc_exgcd(poly1,poly2,x);
          g := car tmp;
          L := cadr tmp;
          R1 := caddr tmp;
          quo1 := get_quo(poly1,g);
          quo2 := get_quo(poly2,g);

          setmat(A,i,i,g);
          setmat(A,j,j,{'times,quo1,getmat(A,j,j)});

          for k:=1:n do
          <<
            tmp := {'plus,{'times,quo1,getmat(Left,k,i)},{'times,quo2,
                    getmat(Left,k,j)}};
            setmat(Left,k,j,{'plus,{'times,{'minus,R1},
                   getmat(Left,k,i)},{'times,L,getmat(Left,k,j)}});
            setmat(Left,k,i,tmp);
          >>;

          for k:=1:m do
          <<
            tquo := {'times,R1,quo2};
            tmp := {'plus,{'times,{'plus,1,{'minus,tquo}},
                    getmat(Right,i,k)},{'times,tquo,getmat(Right,j,k)}};
            setmat(Right,j,k,{'plus,{'minus,getmat(Right,i,k)},
                   getmat(Right,j,k)});
            setmat(Right,i,k,tmp);
          >>;

          j := j+1;
        >>;
      >>;
    >>;
    %
    %  Set up rule list for removing nests.
    %
    rule_list := {'co,2,{'~,'int}}=>'int when numberp(int);
    for each elt in full_coeff_list do
    <<
      tmp := {'co,2,{'~,elt}}=>elt;
      rule_list := append (tmp,rule_list);
    >>;
    %
    %  Remove nests.
    %
    let rule_list;
    A := de_nest_mat(A);
    Left := de_nest_mat(Left);
    Right := de_nest_mat(Right);
    clearrules rule_list;
    %
    % Return to original mode.
    %
    if input_mode neq 'rational and input_mode neq 'arnum then
    <<
      % onoff('nil,t) doesn't work so...
      if input_mode = 'nil then off rational
      else onoff(input_mode,t);
    >>;
    off combineexpt;

    return {'list,A,Left,Right};
  end;

flag ('(smithex),'opfn);  %  So it can be used from algebraic mode.



symbolic procedure get_coeffs_smith(poly,x);
  %
  % Gets all kernels in a poly.
  %
  % This is the version form smithex. The polynomials are
  % known to be in x (smithex(matrix,x)) so this is removed
  % from the output so as to not be nested in
  % nest_input_smith.
  %
  begin
    scalar ker_list_num,ker_list_den,new_list;

    ker_list_num := kernels !*q2f simp reval num poly;
    ker_list_den := kernels !*q2f simp reval den poly;

    ker_list_num := union(ker_list_num,ker_list_den);

    if ker_list_num = nil then new_list := nil
    else
    <<
      %  Remove x.
      for i:=1:length ker_list_num do
      <<
        if car ker_list_num = x then new_list := new_list
        else new_list := car ker_list_num.new_list;
        ker_list_num := cdr ker_list_num;
      >>;
    >>;

    return new_list;
  end;




symbolic procedure nest_input_smith(A,x);
  %
  % Takes a matrix and converts all elements into nested form.
  % Also finds all coefficients and returns them in a list.
  %
  % With Smithex all polynomials are in x (input by user) so
  % this is removed from the full_coeff_list (see get_coeffs),
  % and is thus not nested.
  %
  begin
    scalar tmp,coeff_list,full_coeff_list,AA;

    integer row_dim,col_dim;

    full_coeff_list := nil;
    coeff_list := nil;

    AA := copy_mat(A);

    row_dim := car size_of_matrix(AA);
    col_dim := cadr  size_of_matrix(AA);

    for i := 1:row_dim do
    <<
      for j := 1:col_dim do
      <<
        coeff_list := get_coeffs_smith(getmat(AA,i,j),x);
        if coeff_list = nil then <<>>
        else full_coeff_list := union(coeff_list,full_coeff_list);
        for each elt in coeff_list do
        <<
          tmp := {'co,2,elt};
          setmat(AA,i,j,algebraic (sub(elt=tmp,getmat(AA,i,j))));
        >>;
      >>;
    >>;


    return {AA,full_coeff_list};
  end;




switch int_test;
symbolic procedure all_integer_entries_test(mat1);
  begin
    on int_test;
    for i:=1:car size_of_matrix(mat1) do
    <<
      for j:=1:cadr size_of_matrix(mat1) do
      <<
        if not numberp getmat(mat1,i,j) and !*int_test
         then off int_test;
      >>;
    >>;
% Note that this is one of the very very few places in Reduce where
% a string with an embedded newline is used. I will leave it in so that
% it continues to test behaviour in that situation. But elsewhere people
% will have used two calls to prin2t rather than one!
    if !*int_test then prin2t
    "*** WARNING: all matrix entries are integers.
    If calculations in Z(the integers) are required, use smithex_int.";
    % system "sleep 3";
  end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/normform.rlg0000644000175000017500000010603411527635055024730 0ustar  giovannigiovanniFri Feb 18 21:27:57 2011 run on win32

*** co already defined as operator 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
% Examples of calculations of matrix normal forms using the REDUCE     %
% NORMFORM package.                                                    %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% load_package normform;

on errcont;

 % So that computation continues after an error.

%
% If using xr, the X interface for REDUCE, then turn on looking_good to 
% improve the appearance of the output.
%
fluid '(options!*);



lisp if memq('fmprint ,options!*) then on looking_good;



procedure test(tmp,A);
  % 
  % Checks that P * N * P^-1 = A where tmp is the output {P,N,P^-1} 
  % of the Normal form calculation on A.
  %
  begin
    if second tmp * first tmp * third tmp = A then
    write "Seems O.K." else rederr "something isn't working.";
  end;


test



%%%%%%%%%%%%%%%%%%%%%%%%%%%% Smithex %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((3*x,x^2+x),(0,x^2));


     [3*x  x*(x + 1)]
     [              ]
a := [         2    ]
     [ 0      x     ]


  answer := smithex(A,x);


answer := {

           [x  0 ]
           [     ]
           [    2]
           [0  x ]

           ,


           [1  0]
           [    ]
           [x  1]

           ,


           [3   x + 1]
           [         ]
           [-3   - x ]

           }

  test(answer,A);


Seems O.K.


  %
  % Extend algebraic field to include sqrt2.
  %
  load_package arnum;


  defpoly sqrt2**2-2;


  A := mat((sqrt2*y^2,y+1),(3*sqrt2,y^3+y*sqrt2));


     [       2                ]
     [sqrt2*y       y + 1     ]
a := [                        ]
     [              2         ]
     [3*sqrt2   y*(y  + sqrt2)]


  answer := smithex(A,y);


answer := {

           [1             0           ]
           [                          ]
           [    5          3          ]
           [0  y  + sqrt2*y  - 3*y - 3]

           ,


           [       2   1       ]
           [sqrt2*y   ---*sqrt2]
           [           6       ]
           [                   ]
           [3*sqrt2       0    ]

           ,


           [    1            2         ]
           [1  ---*sqrt2*y*(y  + sqrt2)]
           [    6                      ]
           [                           ]
           [0           - sqrt2        ]

           }

  test(answer,A);


Seems O.K.

  off arnum;



  %
  % smithex will compute the Smith normal form of matrices containing 
  % only integer entries but the integers are regarded as univariate 
  % polynomials in x over a field F (the rationals unless the field has 
  % been extended). For calculations over the integers use smithex_int.
  %
  A := mat((9,-36,30),(-36,192,-180),(30,-180,180));


     [ 9   -36    30 ]
     [               ]
a := [-36  192   -180]
     [               ]
     [30   -180  180 ]


  answer := smithex(A,x);


*** WARNING: all matrix entries are integers.
    If calculations in Z(the integers) are required, use smithex_int.

answer := {

           [1  0  0]
           [       ]
           [0  1  0]
           [       ]
           [0  0  1]

           ,


           [            1  ]
           [ 9   18   -----]
           [           720 ]
           [               ]
           [-36  -24    0  ]
           [               ]
           [30    0     0  ]

           ,


           [1  -6    6   ]
           [             ]
           [         - 3 ]
           [0  1   ------]
           [         2   ]
           [             ]
           [0  0    2160 ]

           }

  test(answer,A);


Seems O.K.


%%%%%%%%%%%%%%%%%%%%%%%%%%%% Smithex_int %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((1,2,3),(4,5,6),(7,8,x));


     [1  2  3]
     [       ]
a := [4  5  6]
     [       ]
     [7  8  x]


  answer := smithex_int(A);


***** ERROR: matrix contains non_integer entries. Try smithex.  


  A := mat((9,-36,30),(-36,192,-180),(30,-180,180));


     [ 9   -36    30 ]
     [               ]
a := [-36  192   -180]
     [               ]
     [30   -180  180 ]


  answer := smithex_int(A);


answer := {

           [3  0   0 ]
           [         ]
           [0  12  0 ]
           [         ]
           [0  0   60]

           ,


           [-17  -5   -4 ]
           [             ]
           [64   19   15 ]
           [             ]
           [-50  -15  -12]

           ,


           [1   -24  30 ]
           [            ]
           [-1  25   -30]
           [            ]
           [0   -1    1 ]

           }

  test(answer,A);


Seems O.K.



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Frobenius %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));


     [       2    2              2        2           2    2   ]
     [    - x  + y  + y       - x  + x + y  - y      x  - y    ]
     [  ----------------    --------------------    ---------  ]
     [         y                     y                  y      ]
     [                                                         ]
     [                                   2                     ]
     [                        x*y + x + y  - y                 ]
a := [     x + y + 1         ------------------     - (x + y)  ]
     [                               y                         ]
     [                                                         ]
     [     2        2            2        2         2        2 ]
     [  - x  - x + y  + y     - x  + x + y  - y    x  + x - y  ]
     [--------------------  --------------------  -------------]
     [         y                     y                  y      ]


  answer := frobenius(A);


answer := {

           [ x                    ]
           [---  0        0       ]
           [ y                    ]
           [                      ]
           [          - x*(x + y) ]
           [ 0   0  --------------]
           [              y       ]
           [                      ]
           [                    2 ]
           [         x*y + x + y  ]
           [ 0   1  --------------]
           [              y       ]

           ,


                     3      2      2      2            2           2    2
                  - x  - 2*x *y - x  - x*y  + x*y + 2*y  + y      x  - y  - y
           mat((---------------------------------------------,-1,-------------),
                                y*(x + y + 1)                          y

               (x + y + 1,0, - (x + y + 1)),

                     2        2            2        2
                  - x  - x + y  + 2*y     x  + x - y  - y
               (----------------------,0,-----------------))
                          y                      y

,


[                     x - y                                        ]
[0                   -------                            1          ]
[                       y                                          ]
[                                                                  ]
[         3    2      2      2    3    2            2            2 ]
[      - x  - x *y - x  + x*y  + y  + y  + y     - x  - 2*x*y - y  ]
[-1  ----------------------------------------  --------------------]
[                 y*(x + y + 1)                     x + y + 1      ]
[                                                                  ]
[                2        2                                        ]
[               x  + x - y  - 2*y                                  ]
[0             -------------------                      1          ]
[                 y*(x + y + 1)                                    ]

}

  test(answer,A);


Seems O.K.


  %
  % Extend algebraic field to include i.
  %
%   load_package arnum;
    defpoly i^2+1;


    A := mat((-3-i,1,2+i,7-9*i),(-2,1,1,5-i),(-2-2*i,1,2+2*i,4-2*i),
             (2,0,-1,-2+8*i));


     [  - (i + 3)   1   i + 2    - (9*i - 7)]
     [                                      ]
     [     -2       1     1       - (i - 5) ]
a := [                                      ]
     [ - (2*i + 2)  1  2*i + 2   - (2*i - 4)]
     [                                      ]
     [     2        0    -1       8*i - 2   ]


    answer := frobenius(A);


answer := {

           [i + 1  0  0       0      ]
           [                         ]
           [  0    0  0    7*i - 3   ]
           [                         ]
           [  0    1  0   - (8*i - 9)]
           [                         ]
           [  0    0  1    8*i - 3   ]

           ,


           [ 425       189                             ]
           [-----*i + -----  -1   i + 3     18*i - 18  ]
           [ 106       106                             ]
           [                                           ]
           [ 634       258                             ]
           [-----*i + -----  0      2       2*i - 12   ]
           [ 53        53                              ]
           [                                           ]
           [ 150       588                             ]
           [-----*i - -----  0   2*i + 2    4*i - 10   ]
           [ 53        53                              ]
           [                                           ]
           [ 108       7                               ]
           [-----*i + ----   0     -2      - (16*i - 8)]
           [ 53        53                              ]

           ,


           mat((0, - i,1,1),

                        143       268    263       152   491       155
               (-1, - (-----*i - -----),-----*i + -----,-----*i + -----),
                        53        53     53        53    106       106

                       339       368        392       383        370       189
               (0, - (-----*i + -----), - (-----*i - -----), - (-----*i - -----)
                       106       53         53        106        53        53

                ),

                       101        9          7        54
               (0, - (-----*i + -----), - (-----*i - ----),1))
                       106       106        106       53

}

    off arnum;



  A := mat((10,-5,-5,8,3,0),(-4,2,-10,-7,-5,-5),(-8,2,7,3,7,5),
           (-6,-7,-7,-7,10,7),(-4,-3,-3,-6,8,-9),(-2,5,-5,9,7,-4));


     [10  -5  -5   8   3   0 ]
     [                       ]
     [-4  2   -10  -7  -5  -5]
     [                       ]
     [-8  2    7   3   7   5 ]
a := [                       ]
     [-6  -7  -7   -7  10  7 ]
     [                       ]
     [-4  -3  -3   -6  8   -9]
     [                       ]
     [-2  5   -5   9   7   -4]


  F := first frobenius(A);


     [0  0  0  0  0  -867960]
     [                      ]
     [1  0  0  0  0  -466370]
     [                      ]
     [0  1  0  0  0   47845 ]
f := [                      ]
     [0  0  1  0  0   -712  ]
     [                      ]
     [0  0  0  1  0    -95  ]
     [                      ]
     [0  0  0  0  1    16   ]



  %
  % Calculate in Z\23Z...
  %
    on modular;


    setmod 23;


1

    F_mod := first frobenius(A);


         [0  17  0  0  0  0 ]
         [                  ]
         [1  19  0  0  0  0 ]
         [                  ]
         [0  0   0  0  0  10]
f_mod := [                  ]
         [0  0   1  0  0  5 ]
         [                  ]
         [0  0   0  1  0  15]
         [                  ]
         [0  0   0  0  1  20]


 
  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;


    F_bal_mod := first frobenius(A);


             [0   - 6  0  0  0   0  ]
             [                      ]
             [1   - 4  0  0  0   0  ]
             [                      ]
             [0   0    0  0  0   10 ]
f_bal_mod := [                      ]
             [0   0    1  0  0   5  ]
             [                      ]
             [0   0    0  1  0   - 8]
             [                      ]
             [0   0    0  0  1   - 3]


    off balanced_mod;


    off modular;




%%%%%%%%%%%%%%%%%%%%%%%%%%% Ratjordan %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));


     [       2    2              2        2           2    2   ]
     [    - x  + y  + y       - x  + x + y  - y      x  - y    ]
     [  ----------------    --------------------    ---------  ]
     [         y                     y                  y      ]
     [                                                         ]
     [                                   2                     ]
     [                        x*y + x + y  - y                 ]
a := [     x + y + 1         ------------------     - (x + y)  ]
     [                               y                         ]
     [                                                         ]
     [     2        2            2        2         2        2 ]
     [  - x  - x + y  + y     - x  + x + y  - y    x  + x - y  ]
     [--------------------  --------------------  -------------]
     [         y                     y                  y      ]


  answer := ratjordan(A);


answer := {

           [ x             ]
           [---   0     0  ]
           [ y             ]
           [               ]
           [      x        ]
           [ 0   ---    0  ]
           [      y        ]
           [               ]
           [ 0    0   x + y]

           ,


                     3      2      2      2            2           2
                  - x  - 2*x *y - x  - x*y  + x*y + 2*y  + y    - x  - x*y + y
           mat((---------------------------------------------,-----------------,
                                y*(x + y + 1)                              2
                                                                x*y - x + y

                  2        2
                 x  + x - y  - y
                -----------------),
                             2
                  x*y - x + y

                           y*(x + y + 1)    - y*(x + y + 1)
               (x + y + 1,---------------,------------------),
                                      2                 2
                           x*y - x + y       x*y - x + y

                     2        2             2        2        2        2
                  - x  - x + y  + 2*y    - x  - x + y  + y   x  + x - y  - y
               (----------------------,--------------------,-----------------))
                          y                           2                  2
                                           x*y - x + y        x*y - x + y

,


        x - y
mat((0,-------,1),
          y

             3      3    2  2    2      2      3      2            4    3    2
          - x *y + x  - x *y  - x *y + x  + x*y  - x*y  - 2*x*y + y  + y  + y
    (-1,-----------------------------------------------------------------------,
                                     2
                                    y *(x + y + 1)

          2      2        2              3
       - x *y + x  - 2*x*y  + x*y + x - y
     --------------------------------------),
                 y*(x + y + 1)

          - x - y + 1     x + y
    (-1,--------------,-----------))
          x + y + 1     x + y + 1

}

  test(answer,A);


Seems O.K.


  %
  % Extend algebraic field to include sqrt(2).
  %
  %  load_package arnum;
    defpoly sqrt2**2-2;


    A:= mat((4*sqrt2-6,-4*sqrt2+7,-3*sqrt2+6),(3*sqrt2-6,-3*sqrt2+7,
            -3*sqrt2+6),(3*sqrt2,1-3sqrt2,-2*sqrt2));


     [4*sqrt2 - 6   - (4*sqrt2 - 7)   - (3*sqrt2 - 6)]
     [                                               ]
a := [3*sqrt2 - 6   - (3*sqrt2 - 7)   - (3*sqrt2 - 6)]
     [                                               ]
     [  3*sqrt2     - (3*sqrt2 - 1)      - 2*sqrt2   ]


    answer := ratjordan(A);


answer := {

           [sqrt2    0           0        ]
           [                              ]
           [  0    sqrt2         0        ]
           [                              ]
           [  0      0     - (3*sqrt2 - 1)]

           ,


           [                21           49           21           18  ]
           [7*sqrt2 - 6    ----*sqrt2 - ----      - (----*sqrt2 - ----)]
           [                31           31           31           31  ]
           [                                                           ]
           [                21           18           21           18  ]
           [3*sqrt2 - 6    ----*sqrt2 - ----      - (----*sqrt2 - ----)]
           [                31           31           31           31  ]
           [                                                           ]
           [                  3            24       3            24    ]
           [3*sqrt2 + 1   - (----*sqrt2 + ----)    ----*sqrt2 + ----   ]
           [                  31           31       31           31    ]

           ,


           [0       sqrt2 + 1          1   ]
           [                               ]
           [-1     4*sqrt2 + 9      4*sqrt2]
           [                               ]
           [         1                     ]
           [-1   - (---*sqrt2 - 1)     1   ]
           [         6                     ]

           }

    test(answer,A);


Seems O.K.

    off arnum;



  A := mat((-12752,-6285,-9457,-7065,-4939,-5865,-3769),(13028,6430,
           9656, 7213,5041,5984,3841),(16425,8080,12192,9108,6370,7569,
           4871), (-6065,-2979,-4508,-3364,-2354,-2801,-1803),(2968,
           1424,2231, 1664,1171,1404,919),(-22762,-11189,-16902,-12627,
           -8833, -10498,-6760),(23112,11400,17135,12799,8946,10622,
           6821));


     [-12752  -6285   -9457   -7065   -4939  -5865   -3769]
     [                                                    ]
     [13028    6430    9656    7213   5041    5984   3841 ]
     [                                                    ]
     [16425    8080   12192    9108   6370    7569   4871 ]
     [                                                    ]
a := [-6065   -2979   -4508   -3364   -2354  -2801   -1803]
     [                                                    ]
     [ 2968    1424    2231    1664   1171    1404    919 ]
     [                                                    ]
     [-22762  -11189  -16902  -12627  -8833  -10498  -6760]
     [                                                    ]
     [23112   11400   17135   12799   8946   10622   6821 ]


  R := first ratjordan(A);


     [0  2  0  0  0  0  0 ]
     [                    ]
     [1  0  0  0  0  0  0 ]
     [                    ]
     [0  0  0  0  0  0  5 ]
     [                    ]
r := [0  0  1  0  0  0  0 ]
     [                    ]
     [0  0  0  1  0  0  -2]
     [                    ]
     [0  0  0  0  1  0  3 ]
     [                    ]
     [0  0  0  0  0  1  0 ]



  %
  % Calculate in Z/23Z...
  %
    on modular;


    setmod 23;


23

    R_mod := first ratjordan(A);


         [19  0   0   0  0  0  0 ]
         [                       ]
         [0   18  0   0  0  0  0 ]
         [                       ]
         [0   0   17  0  0  0  0 ]
         [                       ]
r_mod := [0   0   0   5  0  0  0 ]
         [                       ]
         [0   0   0   0  0  0  5 ]
         [                       ]
         [0   0   0   0  1  0  19]
         [                       ]
         [0   0   0   0  0  1  10]



  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;


    R_bal_mod := first ratjordan(A);


             [5   0     0     0    0  0   0  ]
             [                               ]
             [0   - 4   0     0    0  0   0  ]
             [                               ]
             [0   0     - 5   0    0  0   0  ]
             [                               ]
r_bal_mod := [0   0     0     - 6  0  0   0  ]
             [                               ]
             [0   0     0     0    0  0   5  ]
             [                               ]
             [0   0     0     0    1  0   - 4]
             [                               ]
             [0   0     0     0    0  1   10 ]


    off balanced_mod;


    off modular;




%%%%%%%%%%%%%%%%%%%%%%%%%%% jordansymbolic %%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat(((y+y^2-x^2)/y,(x-x^2-y+y^2)/y,(x^2-y^2)/y),(1+x+y,
            (x-y+y^2+x*y)/y,-x-y),((y-x+y^2-x^2)/y,(x-y+y^2-x^2)/y,
            (x+x^2-y^2)/y));


     [       2    2              2        2           2    2   ]
     [    - x  + y  + y       - x  + x + y  - y      x  - y    ]
     [  ----------------    --------------------    ---------  ]
     [         y                     y                  y      ]
     [                                                         ]
     [                                   2                     ]
     [                        x*y + x + y  - y                 ]
a := [     x + y + 1         ------------------     - (x + y)  ]
     [                               y                         ]
     [                                                         ]
     [     2        2            2        2         2        2 ]
     [  - x  - x + y  + y     - x  + x + y  - y    x  + x - y  ]
     [--------------------  --------------------  -------------]
     [         y                     y                  y      ]


  answer := jordansymbolic(A);


answer := {

           [ x             ]
           [---   0     0  ]
           [ y             ]
           [               ]
           [      x        ]
           [ 0   ---    0  ]
           [      y        ]
           [               ]
           [ 0    0   x + y]

           ,

              lambda*y - x
           {{--------------,lambda - x - y},
                   y

            lambda},


                     3      2      2      2            2           2
                  - x  - 2*x *y - x  - x*y  + x*y + 2*y  + y    - x  - x*y + y
           mat((---------------------------------------------,-----------------,
                                y*(x + y + 1)                              2
                                                                x*y - x + y

                  2        2
                 x  + x - y  - y
                -----------------),
                             2
                  x*y - x + y

                           y*(x + y + 1)    - y*(x + y + 1)
               (x + y + 1,---------------,------------------),
                                      2                 2
                           x*y - x + y       x*y - x + y

                     2        2             2        2        2        2
                  - x  - x + y  + 2*y    - x  - x + y  + y   x  + x - y  - y
               (----------------------,--------------------,-----------------))
                          y                           2                  2
                                           x*y - x + y        x*y - x + y

,


        x - y
mat((0,-------,1),
          y

             3      3    2  2    2      2      3      2            4    3    2
          - x *y + x  - x *y  - x *y + x  + x*y  - x*y  - 2*x*y + y  + y  + y
    (-1,-----------------------------------------------------------------------,
                                     2
                                    y *(x + y + 1)

          2      2        2              3
       - x *y + x  - 2*x*y  + x*y + x - y
     --------------------------------------),
                 y*(x + y + 1)

          - x - y + 1     x + y
    (-1,--------------,-----------))
          x + y + 1     x + y + 1

}



  %
  % Extend algebraic field.
  %
  % load_package arnum;
    defpoly b^3-2*b+b-5;


    A := mat((1-b,2+b^2),(3+b-2*b^2,3));


     [                    2    ]
     [    - (b - 1)      b  + 2]
a := [                         ]
     [       2                 ]
     [ - (2*b  - b - 3)    3   ]


    answer := jordansymbolic(A);


answer := {

           [lambda11     0    ]
           [                  ]
           [   0      lambda12]

           ,

                   2                       2
           {{lambda  + (b - 4)*lambda + 3*b  + 4*b - 8},lambda},


           [  lambda11 - 3       lambda12 - 3   ]
           [                                    ]
           [       2                  2         ]
           [ - (2*b  - b - 3)   - (2*b  - b - 3)]

           ,


                      1966    2     3514         1054                 1
           mat(( - (--------*b  + --------*b - --------)*(lambda11 + ---*b - 2),
                     239891        239891       239891                2

                   127472    2     236383         82923
                (----------*b  + ----------*b + ---------)
                  29986375        29986375       5997275

                              26   2    107       45
                *(lambda11 + ----*b  - -----*b + ----)),
                              11        11        11

                      1966    2     3514         1054                 1
               ( - (--------*b  + --------*b - --------)*(lambda12 + ---*b - 2),
                     239891        239891       239891                2

                   127472    2     236383         82923
                (----------*b  + ----------*b + ---------)
                  29986375        29986375       5997275

                              26   2    107       45
                *(lambda12 + ----*b  - -----*b + ----)))
                              11        11        11

}

    off arnum;



  A := mat((-9,21,-15,4,2,0),(-10,21,-14,4,2,0),(-8,16,-11,4,2,0),
           (-6,12,-9,3,3,0),(-4,8,-6,0,5,0),(-2,4,-3,0,1,3));


     [-9   21  -15  4  2  0]
     [                     ]
     [-10  21  -14  4  2  0]
     [                     ]
     [-8   16  -11  4  2  0]
a := [                     ]
     [-6   12  -9   3  3  0]
     [                     ]
     [-4   8   -6   0  5  0]
     [                     ]
     [-2   4   -3   0  1  3]


  answer := jordansymbolic(A);


answer := {

           [3  0  0  0     0         0    ]
           [                              ]
           [0  3  0  0     0         0    ]
           [                              ]
           [0  0  1  1     0         0    ]
           [                              ]
           [0  0  0  1     0         0    ]
           [                              ]
           [0  0  0  0  lambda31     0    ]
           [                              ]
           [0  0  0  0     0      lambda32]

           ,

                                         2
           {{lambda - 3,lambda - 1,lambda  - 4*lambda + 5},lambda},


           [     - 3         1    6*lambda31 - 17     6*lambda32 - 17  ]
           [3  ------   1   ---  -----------------   ----------------- ]
           [     8           4           2                   2         ]
           [                                                           ]
           [     - 3         1    5*(lambda31 - 3)    5*(lambda32 - 3) ]
           [3  ------   1   ---  ------------------  ------------------]
           [     8           4           2                   2         ]
           [                                                           ]
           [     - 3         1                                         ]
           [3  ------   1   ---   2*(lambda31 - 3)    2*(lambda32 - 3) ]
           [     8           4                                         ]
           [                                                           ]
           [     - 3    3    3    3*(lambda31 - 3)    3*(lambda32 - 3) ]
           [3  ------  ---  ---  ------------------  ------------------]
           [     8      4    8           2                   2         ]
           [                                                           ]
           [     - 3    1    1                                         ]
           [3  ------  ---  ---     lambda31 - 3        lambda32 - 3   ]
           [     8      2    4                                         ]
           [                                                           ]
           [     - 1    1    1      lambda31 - 3        lambda32 - 3   ]
           [2  ------  ---  ---    --------------      --------------  ]
           [     8      4    8           2                   2         ]

           ,


           [                                     - 1        ]
           [       0              0        0   ------  0   1]
           [                                     3          ]
           [                                                ]
           [                                     8          ]
           [       0              0        0    ---    -8  8]
           [                                     3          ]
           [                                                ]
           [       0              -4       6     0     -2  0]
           [                                                ]
           [       0              0        -4    8     -4  0]
           [                                                ]
           [ - lambda31 + 3  lambda31 - 4  1     0     0   0]
           [                                                ]
           [ - lambda32 + 3  lambda32 - 4  1     0     0   0]

           }

  
  % Check to see if looking_good (*) is on as the choice of using 
  % either lambda or xi is dependent upon this.
  % (* -> the use of looking_good is described in the manual.).
  if not lisp !*looking_good then
  <<
    %
    % NB: we use lambda_ in solve (instead of lambda) as lambda is used
    % for other purposes in REDUCE which mean it cannot be used with
    % solve.
    %
    solve(lambda_^2-4*lambda_+5,lambda_);
    J := sub({lambda31=i + 2,lambda32= - i + 2},first answer);
    P := sub({lambda31=i + 2,lambda32= - i + 2},third answer);
    Pinv :=sub({lambda31=i + 2,lambda32= - i + 2},third rest answer);
  >>
  else 
  <<
    solve(xi^2-4*xi+5,xi);
    J := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},first answer);
    P := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},third answer);
    Pinv := sub({xi(3,1)=i + 2,xi(3,2)= - i + 2},third rest answer);
  >>;


  test({J,P,Pinv},A);


Seems O.K.


  %
  % Calculate in Z/23Z...
  %
    on modular;


    setmod 23;


23

    answer := jordansymbolic(A)$


    J_mod := {first answer, second answer};


j_mod := {

          [3  0  0  0     0         0    ]
          [                              ]
          [0  3  0  0     0         0    ]
          [                              ]
          [0  0  1  1     0         0    ]
          [                              ]
          [0  0  0  1     0         0    ]
          [                              ]
          [0  0  0  0  lambda31     0    ]
          [                              ]
          [0  0  0  0     0      lambda32]

          ,

                                          2
          {{lambda + 20,lambda + 22,lambda  + 19*lambda + 5},lambda}}


  %
  % ...and with a balanced modular representation.
  %
    on balanced_mod;


    answer := jordansymbolic(A)$


    J_bal_mod := {first answer, second answer};


j_bal_mod := {

              [3  0  0  0     0         0    ]
              [                              ]
              [0  3  0  0     0         0    ]
              [                              ]
              [0  0  1  1     0         0    ]
              [                              ]
              [0  0  0  1     0         0    ]
              [                              ]
              [0  0  0  0  lambda31     0    ]
              [                              ]
              [0  0  0  0     0      lambda32]

              ,

                                            2
              {{lambda - 3,lambda - 1,lambda  - 4*lambda + 5},lambda}}

    off balanced_mod;


    off modular;


 

%%%%%%%%%%%%%%%%%%%%%%%%%%%% jordan %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  A := mat((1,y),(y^2,3));


     [1   y]
     [     ]
a := [ 2   ]
     [y   3]


  answer := jordan(A);


answer := {

           [      3                              ]
           [sqrt(y  + 1) + 2           0         ]
           [                                     ]
           [                           3         ]
           [       0           - sqrt(y  + 1) + 2]

           ,


           [      3                     3          ]
           [sqrt(y  + 1) - 1   - (sqrt(y  + 1) + 1)]
           [                                       ]
           [        2                   2          ]
           [       y                   y           ]

           ,


           [        3                  3         3       ]
           [  sqrt(y  + 1)       sqrt(y  + 1) + y  + 1   ]
           [ --------------     -----------------------  ]
           [       3                    2   3            ]
           [   2*(y  + 1)            2*y *(y  + 1)       ]
           [                                             ]
           [          3                  3         3     ]
           [  - sqrt(y  + 1)     - sqrt(y  + 1) + y  + 1 ]
           [-----------------  --------------------------]
           [       3                    2   3            ]
           [   2*(y  + 1)            2*y *(y  + 1)       ]

           }

  test(answer,A);


Seems O.K.


  A := mat((-12752,-6285,-9457,-7065,-4939,-5865,-3769),(13028,6430,
          9656, 7213,5041,5984,3841),(16425,8080,12192,9108,6370,7569,
          4871), (-6065,-2979,-4508,-3364,-2354,-2801,-1803),(2968,
          1424,2231, 1664,1171,1404,919),(-22762,-11189,-16902,-12627,
          -8833, -10498,-6760),(23112,11400,17135,12799,8946,10622,
          6821));


     [-12752  -6285   -9457   -7065   -4939  -5865   -3769]
     [                                                    ]
     [13028    6430    9656    7213   5041    5984   3841 ]
     [                                                    ]
     [16425    8080   12192    9108   6370    7569   4871 ]
     [                                                    ]
a := [-6065   -2979   -4508   -3364   -2354  -2801   -1803]
     [                                                    ]
     [ 2968    1424    2231    1664   1171    1404    919 ]
     [                                                    ]
     [-22762  -11189  -16902  -12627  -8833  -10498  -6760]
     [                                                    ]
     [23112   11400   17135   12799   8946   10622   6821 ]


  on rounded;


  J := first jordan(A);


*** Domain mode rounded changed to rational 

*** Domain mode rational changed to complex-rational 

*** Domain mode complex-rational changed to rational 

*** Domain mode rational changed to rounded 

j := mat((1.41421356237,0,0,0,0,0,0),

         (0, - 1.41421356237,0,0,0,0,0),

         (0,0, - 1.80492,0,0,0,0),

         (0,0,0, - 1.12491,0,0,0),

         (0,0,0,0,1.03589*i + 0.620319,0,0),

         (0,0,0,0,0, - 1.03589*i + 0.620319,0),

         (0,0,0,0,0,0,1.68919))


  off rounded;



  %
  % Extend algebraic field.
  %
  % load_package arnum;
    defpoly b^3-2*b+b-5;


    A := mat((1-b,2+b^2),(3+b-2*b^2,3));


     [                    2    ]
     [    - (b - 1)      b  + 2]
a := [                         ]
     [       2                 ]
     [ - (2*b  - b - 3)    3   ]


    J := first jordan(A);


                11   2                   1
j := mat((sqrt(----*b  + 6*b - 12)*i - (---*b - 2),0),
                4                        2

                      11   2                  1
         (0, - (sqrt(----*b  + 6*b - 12)*i + ---*b - 2)))
                      4                       2


    off arnum;



end;


Time for test: 624 ms
@@@@@ Resources used: (1 7 3290 1)
mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/nestdom.red0000644000175000017500000001373311526203062024517 0ustar  giovannigiovannimodule nestdom; %
                % nested domain: domain elements are standard quotients.
                % Coefficients are taken from the integers or another
                % dnest.
                %
                % This module was written by H. Melenk.
                %

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%
% Adaption to allow convertion between arnum and nested.
%%%%%%%%%
symbolic procedure ident(x);x;
PUT('!:ar!:,'!:nest!:,'ident);
%%%%%%%%%


% data structure:
%  a domain element is a list
%      ('!:nest!: level# dmode* . sq)

smacro procedure nestlevel u; cadr u;
smacro procedure nestdmode u; caddr u;
smacro procedure nestsq u; cdddr u;

GLOBAL '(DOMAINLIST!*);

FLUID '(alglist!* nestlevel!*);
nestlevel!* := 0;

switch nested;

DOMAINLIST!* := UNION('(!:nest!:),DOMAINLIST!*);

PUT('NESTED,'TAG,'!:nest!:);
PUT('!:nest!:,'DNAME,'NESTED);
FLAG('(!:nest!:),'FIELD);
FLAG('(!:nest!:),'CONVERT);
PUT('!:nest!:,'I2D,'!*I2nest);
% PUT('!:nest!:,'!:BF!:,'nestCNV);
% PUT('!:nest!:,'!:FT!:,'nestCNV);
% PUT('!:nest!:,'!:RN!:,'nestCNV);
PUT('!:nest!:,'!:BF!:,mkdmoderr('!:nest!:,'!:BF!:));
PUT('!:nest!:,'!:FT!:,mkdmoderr('!:nest!:,'!:ft!:));
PUT('!:nest!:,'!:RN!:,mkdmoderr('!:nest!:,'!:RN!:));
PUT('!:nest!:,'MINUSP,'nestMINUSP!:);
PUT('!:nest!:,'PLUS,'nestPLUS!:);
PUT('!:nest!:,'TIMES,'nestTIMES!:);
PUT('!:nest!:,'DIFFERENCE,'nestDIFFERENCE!:);
PUT('!:nest!:,'QUOTIENT,'nestQUOTIENT!:);
PUT('!:nest!:,'divide,'nestdivide!:);
% PUT('!:nest!:,'gcd,'nestgcd!:);
PUT('!:nest!:,'ZEROP,'nestZEROP!:);
PUT('!:nest!:,'ONEP,'nestONEP!:);
% PUT('!:nest!:,'factorfn,'factornest!:);
PUT('!:nest!:,'PREPFN,'nestPREP!:);
PUT('!:nest!:,'PRIFN,'PRIN2);
PUT('!:RN!:,'!:nest!:,'RN2nest);

SYMBOLIC PROCEDURE !*I2nest U;
   %converts integer U to nested form;
   if domainp u then u else
   '!:nest!: . 0 . dmode!* . (u ./ 1);

SYMBOLIC PROCEDURE RN2nest U;
   %converts integer U to nested form;
   if domainp u then u else
   '!:nest!: . 0 . dmode!* . (cdr u);

SYMBOLIC PROCEDURE nestCNV U;
   REDERR LIST("Conversion between `nested' and",
                GET(CAR U,'DNAME),"not defined");

SYMBOLIC PROCEDURE nestMINUSP!: U;
   nestlevel u = 0 and minusf car nestsq u;

SYMBOLIC PROCEDURE sq2nestedf sq;
  '!:nest!: . nestlevel!* . dmode!* . sq;

SYMBOLIC PROCEDURE nest2op!:(U,V,op);
  (begin scalar r,nlu,nlv,nlr,dm,nestlevel!*;
     nlu := if not eqcar (u,'!:nest!:) then 0 else nestlevel u;
     nlv := if not eqcar (v,'!:nest!:) then 0 else nestlevel v;
     if nlu = nlv then goto case1
     else if nlu #> nlv then goto case2
     else goto case3;
   case1:    % same level for u and v
            dm := nestdmode u;
            if dm then setdmode(dm,t);
            nlr := nlu;
            nestlevel!* := nlu - 1;
            r := apply(op,list(nestsq u,nestsq v));
            goto ready;
   case2:    % v below u
            dm := nestdmode u;
            if dm then setdmode(dm,t);
            nlr := nlu;
            nestlevel!* := nlv;
            r := apply(op,list (nestsq u, v ./ 1));
            goto ready;
   case3:     % u below v
            dm := nestdmode v;
            if dm then setdmode(dm,t);
            nlr := nlv;
            nestlevel!* := nlu;
            r := apply(op,list (u ./ 1,nestsq v));
   ready:
            r := if null numr r then nil
            else if domainp numr r and denr r = 1 then numr r
            else '!:nest!: . nlr . dm . r;
     if dm then setdmode (dm,nil);
     return r;
    end )  where dmode!* = nil;

SYMBOLIC PROCEDURE nestPLUS!:(u,v); nest2op!:(u,v,'addsq);

SYMBOLIC PROCEDURE nestTIMES!:(U,V); nest2op!:(u,v,'multsq);

SYMBOLIC PROCEDURE nestDIFFERENCE!:(U,V);
    nest2op!:(u,v,function (lambda(x,y); addsq(x,negsq y)));

symbolic procedure nestdivide!:(u,v); nest2op!:(u,v,'quotsq) . 1;

%symbolic procedure nestgcd!:(u,v); !*i2nest 1;

SYMBOLIC PROCEDURE nestQUOTIENT!:(U,V); nest2op!:(u,v,'quotsq);

SYMBOLIC PROCEDURE nestZEROP!: U; null numr nestsq u;

SYMBOLIC PROCEDURE nestONEP!: U;
       (car v = 1 and cdr v = 1) where v = nestsq u;

INITDMODE 'nested;


% nested routines are defined in the GENnest nestule with the exception
% of the following:

SYMBOLIC PROCEDURE SETnest U;
   begin
      u := reval u;
      if not fixp u then typerr(u,"nestulus");
      nestlevel!* := u;
   end;

FLAG('(SETnest),'OPFN);   %to make it a symbolic operator;

flag('(setnest),'noval);

algebraic operator co;

symbolic procedure simpco u;
 % conmvert an expression to a nested coefficient
   begin scalar  sq,lev;
     if not (length u = 2 and fixp car u) then
             typerr(u,"nested coefficient");
     sq := simp cadr u;
     lev := car u;
     return (if null numr sq then nil else ('!:nest!: . lev . dmode!* .
sq)) ./ 1;
   end;

put('co,'simpfn,'simpco);

symbolic procedure nestPREP!: u; list('co,nestlevel u,prepsq nestsq u);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/normform.tex0000644000175000017500000005366211526203062024740 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{A \REDUCE{} package for the computation of several matrix 
normal forms}
\author{Matt Rebbeck \\ 
Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin \\
Takustra\"se 7  \\
D--14195 Berlin -- Dahlem \\
Federal Republic of Germany \\[0.05in]
E--mail: neun@zib.de \\[0.05in]
}
\date{February 1994}
\begin{document}
\maketitle
\index{NORMFORM package}


\section{Introduction}
When are two given matrices similar? Similar matrices have the same
trace, determinant, \hspace{0in} characteristic polynomial, 
\hspace{0in} and eigenvalues, \hspace{0in} but the matrices 
\begin{displaymath}
\begin{array}{ccc} {\cal U} = \left( \begin{array}{cc} 0 & 1 \\ 0 & 
0 \end{array} \right) & $and$ & {\cal V} = \left( \begin{array}{cc} 
0 & 0 \\ 0 & 0 \end{array} \right) \end{array} 
\end{displaymath}
are the same in all four of the above but are not similar. Otherwise 
there could exist a nonsingular ${\cal N} {\in} M_{2}$ (the set of 
all $2 \times 2$ matrices) such that ${\cal U} = {\cal N} \, {\cal V}
\, {\cal N}^{-1} = {\cal N} \, {\it 0} \, {\cal N}^{-1} = {\it 0}$, 
which is a contradiction since ${\cal U} \neq {\it 0}$.

Two matrices can look very different but still be similar. One 
approach to determining whether two given matrices are similar is to 
compute the normal form of them. If both matrices reduce to the same 
normal form they must be similar.

{\small NORMFORM} is a package for computing the following normal 
forms of matrices:

\begin{verbatim}
 - smithex
 - smithex_int
 - frobenius
 - ratjordan
 - jordansymbolic
 - jordan
\end{verbatim}
 
The package is loaded by {\tt load\_package normform;}

By default all calculations are carried out in {\cal Q} (the rational 
numbers). For {\tt smithex}, {\tt frobenius}, {\tt ratjordan}, 
{\tt jordansymbolic}, and {\tt jordan}, this field can be extended. 
Details are given in the respective sections.

The {\tt frobenius}, {\tt ratjordan}, and {\tt jordansymbolic} normal 
forms can also be computed in a modular base. Again, details are given 
in the respective sections.

The algorithms for each routine are contained in the source code.

{\small NORMFORM} has been converted from the normform and Normform 
packages written by T.M.L. Mulders and A.H.M. Levelt. These have been 
implemented in Maple [4].


\section{smithex}

\subsection{function}

{\tt smithex}(${\cal A},\, x$) computes the Smith normal form ${\cal S}$
of the matrix ${\cal A}$.

It returns \{${\cal S}, {\cal P}, {\cal P}^{-1}$\} where ${\cal S}, 
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P S P}^{-1} = 
{\cal A}$.

${\cal A}$ is a rectangular matrix of univariate polynomials in $x$.

$x$ is the variable name.

\subsection{field extensions}

Calculations are performed in ${\cal Q}$. To extend this field the 
{\small ARNUM} package can be used. For details see {\it section} 8.

\subsection{synopsis}

\begin{itemize}
\item The Smith normal form ${\cal S}$ of an n by m matrix ${\cal A}$ 
with univariate polynomial entries in $x$ over a field {\it F} is 
computed. That is, the polynomials are then regarded as elements of the
{\it E}uclidean domain {\it F}($x$).

\item The Smith normal form is a diagonal matrix ${\cal S}$ where:

  \begin{itemize}
  \item rank(${\cal A}$) = number of nonzero rows (columns) of 
        ${\cal S}$.
  \item ${\cal S}(i,\, i)$ is a monic polynomial for 0 $< i \leq $
        rank(${\cal A}$).
  \item ${\cal S}(i,\, i)$ divides ${\cal S}(i+1,\, i+1)$ for 0 $< i
        <$ rank(${\cal A}$).
  \item ${\cal S}(i,\,i)$ is the greatest common divisor of all $i$ by 
        $i$ minors of ${\cal A}$.
  \end{itemize}

      Hence, if we have the case that $n = m$, as well as 
      rank(${\cal A}$) $= n$, then product (${\cal S}(i,\,i), 
      i=1\ldots n$) = det(${\cal A}$) / lcoeff(det$({\cal A}), \, x$).

\item The Smith normal form is obtained by doing elementary row and 
      column operations. This includes interchanging rows (columns),
      multiplying through a row (column) by $-1$, and adding integral 
      multiples of one row (column) to another.

\item Although the rank and determinant can be easily obtained from 
      ${\cal S}$, this is not an efficient method for computing these 
      quantities except that this may yield a partial factorization of 
      det(${\cal A}$) without doing any explicit factorizations.

\end{itemize}

\subsection{example}

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} x & x+1 \\ 0 & 3*x^2 \end{array} 
\right)
\end{displaymath}

\begin{displaymath}
\hspace{-0.5in}
\begin{array}{ccc}
{\tt smithex}({\cal A},\, x) & = & 
\left\{ \left( \begin{array}{cc} 1 & 0 \\ 
0 & x^3 \end{array} \right), \left( \begin{array}{cc} 1 & 0 \\ 3*x^2 
& 1 \end{array} \right), \left( \begin{array}{cc} x & x+1 \\ -3 & -3 
\end{array} \right) \right\} \end{array}
\end{displaymath}


\section{smithex\_int}

\subsection{function}

Given an $n$ by $m$ rectangular matrix ${\cal A}$ that contains 
{\it only} integer entries, {\tt smithex\_int}(${\cal A}$) computes the
Smith normal form ${\cal S}$ of ${\cal A}$.

It returns \{${\cal S}, {\cal P}, {\cal P}^{-1}$\} where ${\cal S}, 
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P S P}^{-1} = 
{\cal A}$.


\subsection{synopsis}

\begin{itemize}
\item The Smith normal form ${\cal S}$ of an $n$ by $m$ matrix 
${\cal A}$ with integer entries is computed.

\item The Smith normal form is a diagonal matrix ${\cal S}$ where:

  \begin{itemize}
  \item rank(${\cal A}$) = number of nonzero rows (columns) of 
        ${\cal S}$.
  \item sign(${\cal S}(i,\, i)$) = 1 for 0 $< i \leq $ rank(${\cal A}$).
  \item ${\cal S}(i,\, i)$ divides ${\cal S}(i+1,\, i+1)$ for 0 $< i
        <$ rank(${\cal A}$).
  \item ${\cal S}(i,\,i)$ is the greatest common divisor of all $i$ by 
        $i$ minors of ${\cal A}$.
  \end{itemize}

      Hence, if we have the case that $n = m$, as well as 
      rank(${\cal A}$) $= n$, then abs(det(${\cal A}$)) = 
      product(${\cal S}(i,\,i),i=1\ldots n$).
      
\item The Smith normal form is obtained by doing elementary row and 
      column operations. This includes interchanging rows (columns),
      multiplying through a row (column) by $-1$, and adding integral 
      multiples of one row (column) to another. 
\end{itemize}

\subsection{example}

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{ccc} 9 & -36 & 30 \\ -36 & 192 & -180 \\
30 & -180 & 180  \end{array} 
\right)
\end{displaymath}

{\tt smithex\_int}(${\cal A}$) = 
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{ccc} 3 & 0 & 0 \\ 0 & 12 & 0 \\ 0 & 0 & 60 
\end{array} \right), \left( \begin{array}{ccc} -17 & -5 & -4 \\ 64 & 19 
& 15 \\ -50 & -15 & -12 \end{array} \right), \left( \begin{array}{ccc} 
1 & -24 & 30 \\ -1 & 25 & -30 \\ 0 & -1 & 1 \end{array} \right) \right\}
\end{displaymath}
\end{center}


\section{frobenius}

\subsection{function}

{\tt frobenius}(${\cal A}$) computes the Frobenius normal form 
${\cal F}$ of the matrix ${\cal A}$.

It returns \{${\cal F}, {\cal P}, {\cal P}^{-1}$\} where ${\cal F}, 
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P F P}^{-1} = 
{\cal A}$.

${\cal A}$ is a square matrix.

\subsection{field extensions}

Calculations are performed in ${\cal Q}$. To extend this field the 
{\small ARNUM} package can be used. For details see {\it section} 8.

\subsection{modular arithmetic}

{\tt frobenius} can be calculated in a modular base. For details see 
{\it section} 9.

\subsection{synopsis}

\begin{itemize}
\item ${\cal F}$ has the following structure:
      \begin{displaymath}
      {\cal F} = \left( \begin{array}{cccc} {\cal C}{\it p_{1}} &  &  & 
      \\  & {\cal C}{\it p_{2}} &  &  \\  &  & \ddots &  \\  &  &  & 
      {\cal C}{\it p_{k}} \end{array} \right) 
      \end{displaymath}
      where the ${\cal C}({\it p_{i}})$'s are companion matrices 
      associated with polynomials ${\it p_{1}, p_{2}},\ldots, 
      {\it p_{k}}$, with the property that ${\it p_{i}}$ divides 
      ${\it p_{i+1}}$ for $i =1\ldots k-1$. All unmarked entries are 
      zero.

\item The Frobenius normal form defined in this way is unique (ie: if 
      we require that ${\it p_{i}}$ divides ${\it p_{i+1}}$ as above).
\end{itemize}
 
\subsection{example}

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} \frac{-x^2+y^2+y}{y} & 
\frac{-x^2+x+y^2-y}{y} \\ \frac{-x^2-x+y^2+y}{y} & \frac{-x^2+x+y^2-y}
{y} \end{array} \right)
\end{displaymath}

{\tt frobenius}(${\cal A}$) = 
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} 0 & \frac{x*(x^2-x-y^2+y)}{y} \\ 1 & 
\frac{-2*x^2+x+2*y^2}{y} \end{array} \right), \left( \begin{array}{cc}
1 & \frac{-x^2+y^2+y}{y} \\ 0 & \frac{-x^2-x+y^2+y}{y} \end{array} 
\right), \left( \begin{array}{cc} 1 & \frac{-x^2+y^2+y}{x^2+x-y^2-y} \\
0 & \frac{-y}{x^2+x-y^2-y} \end{array} \right) \right\}
\end{displaymath}
\end{center}


\section{ratjordan}

\subsection{function}

{\tt ratjordan}(${\cal A}$) computes the rational Jordan normal form 
${\cal R}$ of the matrix ${\cal A}$.

It returns \{${\cal R}, {\cal P}, {\cal P}^{-1}$\} where ${\cal R}, 
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P R P}^{-1} = 
{\cal A}$.

${\cal A}$ is a square matrix.

\subsection{field extensions}

Calculations are performed in ${\cal Q}$. To extend this field the 
{\small ARNUM} package can be used. For details see {\it section} 8.

\subsection{modular arithmetic}

{\tt ratjordan} can be calculated in a modular base. For details see 
{\it section} 9.

\subsection{synopsis}

\begin{itemize}
\item ${\cal R}$ has the following structure:
      \begin{displaymath}
      {\cal R} = \left( \begin{array}{cccccc} {\it r_{11}} \\  & 
      {\it r_{12}} \\  &  & \ddots \\  &  &  & {\it r_{21}}  \\ &  &  
      &  & {\it r_{22}} \\ &  &  &  &  & \ddots \end{array} \right) 
      \end{displaymath}

      The ${\it r_{ij}}$'s have the following shape:  
      \begin{displaymath}
      {\it r_{ij}} = \left( \begin{array}{ccccc} {\cal C}({\it p}) & 
      {\cal I}  &  &  & \\  &  {\cal C}({\it p}) & {\cal I}  & & \\ & 
      & \ddots & \ddots & \\ &  &  &  {\cal C}({\it p}) & {\cal I} \\ &
      &  &  & {\cal C}({\it p}) \end{array} \right) 
      \end{displaymath}

      where there are e${\it ij}$ times ${\cal C}({\it p})$ blocks 
      along the diagonal and ${\cal C}({\it p})$ is the companion 
      matrix  associated with the irreducible polynomial ${\it p}$. All 
      unmarked entries are zero.
\end{itemize}

\subsection{example}

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} x+y & 5 \\ y & x^2  \end{array} 
\right)
\end{displaymath}

{\tt ratjordan}(${\cal A}$) = 
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} 0 & -x^3-x^2*y+5*y \\ 1 & 
x^2+x+y \end{array} \right), \left( \begin{array}{cc}
1 & x+y \\ 0 & y \end{array} \right), \left( \begin{array}{cc} 1 & 
\frac{-(x+y)}{y} \\ 0 & \hspace{0.2in} \frac{1}{y} \end{array} \right) 
\right\}
\end{displaymath}
\end{center}


\section{jordansymbolic}

\subsection{function}

{\tt jordansymbolic}(${\cal A}$) \hspace{0in} computes the Jordan 
normal form ${\cal J}$of the matrix ${\cal A}$.

It returns \{${\cal J}, {\cal L}, {\cal P}, {\cal P}^{-1}$\}, where 
${\cal J}, {\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P J P}^
{-1} = {\cal A}$. ${\cal L}$ = \{ {\it ll} , $\xi$ \}, where $\xi$ is 
a name and {\it ll} is a list of irreducible factors of ${\it p}(\xi)$.

${\cal A}$ is a square matrix.

\subsection{field extensions}

Calculations are performed in ${\cal Q}$. To extend this field the 
{\small ARNUM} package can be used. For details see {\it section} 8.

\subsection{modular arithmetic}

{\tt jordansymbolic} can be calculated in a modular base. For details 
see {\it section} 9.

\subsection{extras}

If using {\tt xr}, the X interface for \REDUCE, the appearance of the 
output can be improved by switching {\tt on looking\_good;}. This 
converts all lambda to $\xi$ and improves the indexing, eg: lambda12 
$\Rightarrow \xi_{12}$. The example ({\it section} 6.6) shows the 
output when this switch is on.

\subsection{synopsis}

\begin{itemize}
\item A {\it Jordan block} ${\jmath}_{k}(\lambda)$ is a $k$ by $k$ 
      upper triangular matrix of the form:

      \begin{displaymath}
      {\jmath}_{k}(\lambda) = \left( \begin{array}{ccccc} \lambda & 1 
      &  &  & \\  &  \lambda & 1  & & \\ & 
      & \ddots & \ddots & \\ &  &  &  \lambda & 1 \\ &
      &  &  & \lambda \end{array} \right) 
      \end{displaymath}
      
      There are $k-1$ terms ``$+1$'' in the superdiagonal; the scalar 
      $\lambda$ appears $k$ times on the main diagonal. All other 
      matrix entries are zero, and ${\jmath}_{1}(\lambda) = (\lambda)$.

\item A Jordan matrix ${\cal J} \in M_{n}$ (the set of all $n$ by $n$ 
      matrices) is a direct sum of {\it jordan blocks}.

      \begin{displaymath}
      {\cal J} = \left( \begin{array}{cccc} \jmath_{n_1}(\lambda_{1}) 
      \\  & \jmath_{n_2}(\lambda_{2}) \\ & & \ddots \\ & & & 
      \jmath_{n_k}(\lambda_{k}) \end{array} \right),
      {\it n}_{1}+{\it n}_{2}+\cdots +{\it n}_{k} = n
      \end{displaymath}

      in which the orders ${\it n}_{i}$ may not be distinct and the 
      values ${\lambda_{i}}$ need not be distinct.

\item Here ${\lambda}$ is a zero of the characteristic polynomial 
      ${\it p}$ of ${\cal A}$. If ${\it p}$ does not split completely, 
      symbolic names are chosen for the missing zeroes of ${\it p}$.
      If, by some means, one knows such missing zeroes, they can be 
      substituted for the symbolic names. For this, 
      {\tt jordansymbolic} actually returns $\{ {\cal J,L,P,P}^{-1} \}$.
      ${\cal J}$ is the Jordan normal form of ${\cal A}$ (using 
      symbolic names if necessary). ${\cal L} = \{ {\it ll}, \xi \}$, 
      where $\xi$ is a name and ${\it ll}$ is a list of irreducible 
      factors of ${\it p}(\xi)$. If symbolic names are used then 
      ${\xi}_{ij}$ is a zero of ${\it ll}_{i}$. ${\cal P}$ and 
      ${\cal P}^{-1}$ are as above.
\end{itemize}      

\subsection{example}

{\tt load\_package normform;}\\
{\tt on looking\_good;} 

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} 1 & y \\ y^2 & 3  \end{array} 
\right)
\end{displaymath}

{\tt jordansymbolic}(${\cal A}$) = 
\begin{eqnarray}
 & & \left\{ \left( \begin{array}{cc} \xi_{11} & 0 \\ 0 & \xi_{12}
\end{array} \right) ,
\left\{ \left\{ -y^3+\xi^2-4*\xi+3 \right\}, \xi \right\}, \right. 
\nonumber \\ & & \hspace{0.1in} \left. \left( \begin{array}{cc} 
\xi_{11} -3 & \xi_{12} -3 \\ y^2 & y^2 
\end{array} \right), \left( \begin{array}{cc} \frac{\xi_{11} -2}
{2*(y^3-1)} & \frac{\xi_{11} + y^3 -1}{2*y^2*(y^3+1)} \\ 
\frac{\xi_{12} -2}{2*(y^3-1)} & \frac{\xi_{12}+y^3-1}{2*y^2*(y^3+1)}
\end{array} \right) \right\} \nonumber
\end{eqnarray}

\vspace{0.2in}
\begin{flushleft}
\begin{math}
{\tt solve(-y^3+xi^2-4*xi+3,xi)}${\tt ;}$
\end{math}
\end{flushleft}

\vspace{0.1in}
\begin{center}
\begin{math}
\{ \xi = \sqrt{y^3+1} + 2,\, \xi = -\sqrt{y^3+1}+2 \}
\end{math}
\end{center}

\vspace{0.1in}
\begin{math}
{\tt {\cal J}  = sub}{\tt (}{\tt \{ xi(1,1)=sqrt(y^3+1)+2,\, xi(1,2) = 
-sqrt(y^3+1)+2\},} 
\end{math}
\\ \hspace*{0.29in} {\tt first  jordansymbolic (${\cal A}$));} 
 
\vspace{0.2in}
\begin{displaymath}
{\cal J} = \left( \begin{array}{cc} \sqrt{y^3+1} + 2 & 0 \\ 0 & 
-\sqrt{y^3+1} + 2 \end{array} \right)
\end{displaymath}

\vspace{0.2in}
For a similar example ot this in standard {\REDUCE} (ie: not using 
{\tt xr}), see the {\it normform.log} file.

\vspace{0.5in}

\section{jordan}

\subsection{function}

{\tt jordan}(${\cal A}$) computes the Jordan normal form 
${\cal J}$ of the matrix ${\cal A}$.

It returns \{${\cal J}, {\cal P}, {\cal P}^{-1}$\}, where 
${\cal J}, {\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P J P}^
{-1} = {\cal A}$. 

${\cal A}$ is a square matrix.

\subsection{field extensions}

Calculations are performed in ${\cal Q}$. To extend this field the 
{\small ARNUM} package can be used. For details see {\it section} 8.

\subsection{note}
In certain polynomial cases {\tt fullroots} is turned on to compute the 
zeroes. This can lead to the calculation taking a long time, as well as 
the output being very large. In this case a message {\tt ***** WARNING: 
fullroots turned on. May take a while.} will be printed. It may be 
better to kill the calculation and compute {\tt jordansymbolic} instead.

\subsection{synopsis}

\begin{itemize}
\item The Jordan normal form ${\cal J}$ with entries in an algebraic 
      extension of ${\cal Q}$ is computed.

\item A {\it Jordan block} ${\jmath}_{k}(\lambda)$ is a $k$ by $k$ 
      upper triangular matrix of the form:

      \begin{displaymath}
      {\jmath}_{k}(\lambda) = \left( \begin{array}{ccccc} \lambda & 1 
      &  &  & \\  &  \lambda & 1  & & \\ & 
      & \ddots & \ddots & \\ &  &  &  \lambda & 1 \\ &
      &  &  & \lambda \end{array} \right) 
      \end{displaymath}
      
      There are $k-1$ terms ``$+1$'' in the superdiagonal; the scalar 
      $\lambda$ appears $k$ times on the main diagonal. All other 
      matrix entries are zero, and ${\jmath}_{1}(\lambda) = (\lambda)$.

\item A Jordan matrix ${\cal J} \in M_{n}$ (the set of all $n$ by $n$ 
      matrices) is a direct sum of {\it jordan blocks}.

      \begin{displaymath}
      {\cal J} = \left( \begin{array}{cccc} \jmath_{n_1}(\lambda_{1}) 
      \\  & \jmath_{n_2}(\lambda_{2}) \\ & & \ddots \\ & & & 
      \jmath_{n_k}(\lambda_{k}) \end{array} \right),
      {\it n}_{1}+{\it n}_{2}+\cdots +{\it n}_{k} = n
      \end{displaymath}

      in which the orders ${\it n}_{i}$ may not be distinct and the 
      values ${\lambda_{i}}$ need not be distinct.

\item Here ${\lambda}$ is a zero of the characteristic polynomial 
      ${\it p}$ of ${\cal A}$. The zeroes of the characteristic 
      polynomial are computed exactly, if possible. Otherwise they are 
      approximated by floating point numbers.
\end{itemize}      

\subsection{example}

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cccccc} -9 & -21 & -15 & 4 & 2 & 0 \\
-10 & 21 & -14 & 4 & 2 & 0 \\ -8 & 16 & -11 & 4 & 2 & 0 \\ -6 & 12 & -9 
& 3 & 3 & 0 \\ -4 & 8 & -6 & 0 & 5 & 0 \\ -2 & 4 & -3 & 0 & 1 & 3 
\end{array} \right)
\end{displaymath}

\begin{flushleft}
{\tt ${\cal J}$ = first jordan$({\cal A})$;}
\end{flushleft}
  
\begin{displaymath}
{\cal J} = \left( \begin{array}{cccccc} 3 & 0 & 0 & 0 & 0 & 0 \\ 0 & 3 
& 0 & 0 & 0 & 0 \\ 0 & 0 & 1 & 1 & 0 & 0 \\ 0 & 0 & 0 & 1 & 0 & 0 \\
 0 & 0 & 0 & 0 & i+2 & 0 \\ 0 & 0 & 0 & 0 & 0 & -i+2 
\end{array} \right)
\end{displaymath}

\newpage


\section{arnum}

The package is loaded by {\tt load\_package arnum;}. The algebraic 
field ${\cal Q}$ can now be extended. For example, {\tt defpoly 
sqrt2**2-2;} will extend it to include ${\sqrt{2}}$ (defined here by 
{\tt sqrt2}). The {\small ARNUM} package was written by Eberhard 
Schr\"ufer and is described in the {\it arnum.tex} file.

\subsection{example}

{\tt load\_package normform;} \\
{\tt load\_package arnum;} \\
{\tt defpoly sqrt2**2-2;} \\
(sqrt2 now changed to ${\sqrt{2}}$ for looks!) 
\vspace{0.2in}

\begin{displaymath}
{\cal A} = \left( \begin{array}{ccc} 4*{\sqrt{2}}-6 & -4*{\sqrt{2}}+7 &
-3*{\sqrt{2}}+6 \\ 3*{\sqrt{2}}-6 & -3*{\sqrt{2}}+7 & -3*{\sqrt{2}}+6 
\\ 3*{\sqrt{2}} & 1-3*{\sqrt{2}} & -2*{\sqrt{2}}   \end{array} \right)
\end{displaymath} 
\vspace{0.2in}

\begin{eqnarray}
{\tt ratjordan}({\cal A}) & = & 
\left\{ \left( \begin{array}{ccc} {\sqrt{2}} & 0 & 0 \\ 0 & {\sqrt{2}} 
& 0 \\ 0 & 0 & -3*{\sqrt{2}}+1 \end{array} \right), \right. \nonumber 
\\ & & \hspace{0.1in} \left. \left( \begin{array}{ccc} 7*{\sqrt{2}}-6 
& \frac{2*{\sqrt{2}}-49}{31} & \frac{-21*{\sqrt{2}}+18}{31} \\ 
3*{\sqrt{2}}-6 & \frac{21*{\sqrt{2}}-18}{31} & \frac{-21*{\sqrt{2}}+18}
{31} \\ 3*{\sqrt{2}}+1 & \frac{-3*{\sqrt{2}}+24}{31} & 
\frac{3*{\sqrt{2}}-24}{31} \end{array} \right), \right. \nonumber \\ & 
& \hspace{0.1in} \left. \left( \begin{array}{ccc} 0 & {\sqrt{2}}+1 & 
1 \\ -1 & 4*{\sqrt{2}}+9 & 4*{\sqrt{2}} \\ -1 & -\frac{1}{6}*{\sqrt{2}}
+1 & 1 \end{array} \right) \right\} \nonumber 
\end{eqnarray}

\newpage


\section{modular}

Calculations can be performed in a modular base by switching {\tt on 
modular;}. The base can then be set by {\tt setmod p;} (p a prime). The 
normal form will then have entries in ${\cal Z}/$p${\cal Z}$. 

By also switching {\tt on balanced\_mod;} the output will be shown using
a symmetric modular representation. 

Information on this modular manipulation can be found in {\it chapter} 
9 (Polynomials and Rationals) of the {\REDUCE}  User's Manual [5].

\subsection{example}

{\tt load\_package normform;} \\
{\tt on modular;} \\
{\tt setmod 23;} 
\vspace{0.1in}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} 10 & 18 \\ 17 & 20 \end{array} 
\right)
\end{displaymath}

{\tt jordansymbolic}(${\cal A}$) = 
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} 18 & 0 \\ 0 & 12 \end{array} \right),
\left\{ \left\{ \lambda + 5, \lambda + 11  \right\}, \lambda \right\}, 
\left( \begin{array}{cc} 15 & 9 \\ 22 & 1 \end{array} \right), \left( 
\begin{array}{cc} 1 & 14 \\ 1 & 15 \end{array} \right) \right\}
\end{displaymath}
\end{center}
\vspace{0.2in}

{\tt on balanced\_mod;}
\vspace{0.2in}

{\tt jordansymbolic}(${\cal A}$) = 
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} -5 & 0 \\ 0 & -11 \end{array} \right),
\left\{ \left\{ \lambda + 5, \lambda + 11  \right\}, \lambda \right\}, 
\left( \begin{array}{cc} -8 & 9 \\ -1 & 1 \end{array} \right), \left( 
\begin{array}{cc} 1 & -9 \\ 1 & -8 \end{array} \right) \right\}
\end{displaymath}
\end{center}

\newpage
\begin{thebibliography}{6}
\bibitem{MulLev} T.M.L.Mulders and A.H.M. Levelt: {\it The Maple 
        normform and Normform packages.} (1993)
\bibitem{Mulders} T.M.L.Mulders: {\it Algoritmen in De Algebra, A 
        Seminar on Algebraic Algorithms, Nigmegen.} (1993)
\bibitem{HoJo} Roger A. Horn and Charles A. Johnson: {\it Matrix 
        Analysis.} Cambridge University Press (1990)
\bibitem{Maple} Bruce W. Chat\ldots [et al.]: {\it Maple (Computer 
        Program)}. Springer-Verlag (1991)
\bibitem{Reduce} Anthony C. Hearn: {\REDUCE} {\it User's Manual 3.6.}
	RAND (1995)
\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/froben.red0000644000175000017500000007714511526203062024330 0ustar  giovannigiovannimodule froben; % Computation of the frobenius normal form of a matrix.                                                              %

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The function frobenius computes the Frobenius normal form F of a
% matrix A, the transformation matrix P and its inverse P^(-1).
%
% Specifically:
%
% - frobenius(A) will return {F,P,Pinv} where F, P, and Pinv
%   are such that P*F*Pinv=A.

% Global description of the algorithm:
%
% For a given n by n matrix A over a field K, let L be the linear
% transformation of K^n induced by A. A polycyclic basis of K^n with
% respect to L is a basis of the following form:
% v1,L*v1,.,L^(d1-1)*v1,v2,L*v2,.,L^(d2-1)*v2,.,vr,L*vr,., L^(dr-1)*vr
% such that v1,L*v1,..,L^(d1-1)*v1,..,vi,L*vi,..,L^(di-1)*vi,L^di*vi
% are linearly dependent for i=1..r.
% It is easy to see that the matrix B of L with respect to a polycyclic
% basis is of the form plist_to_polycompanion(plist,x), where plist is
% a list of monic elements of K[x] of strictly increasing degree (for
% a description of plist_to_polycompanion see below).
% The computation of a polycyclic basis of K^n and the transformation
% matrix from A to B is performed in the function cyclic_vectors.
% Next we view K^n as a K[x]-module via x*v=B*v. Suppose that
% B=plist_to_polycompanion(plist,x), where plist=[p1,..,pr] and
% degree(pi)=di. Let G be the r by r upper triangular matrix such that
% G(i,j) satisfies:
%  pj=G(1,j)+G(2,j)*x^d1+G(3,j)*x^d2+..+G(j,j)*x^d(j-1),
% where degree(G(j,j))=dj-d(j-1) and degree(G(i,j)) K[x]^r/R -------> K^n
%                              L
%     |               |                  |              |
%     |               |                  |              |
%     |F              |x                 |x             |B
%     |               |                  |              |
%     |               |                  |              |
%    \ /             \ /                \ /            \ /
%            ~                 ~                 ~
%    K^n <------- K[x]^r/R' -------> K[x]^r/R -------> K^n
%                              L
%
% Here F is in Frobenius normal form and thus it is the Frobenius
% normal form of B (and thus of A). The computation of the Smith
% normal form of G is performed in the function cyclic_to_frobenius.


symbolic procedure frobenius(A);
  begin
    scalar AA,P,Pinv,ans,tmp,full_coeff_list,rule_list,input_mode;

    matrix_input_test(A);
    if (car size_of_matrix(A)) neq (cadr size_of_matrix(A))
     then rederr "ERROR: expecting a square matrix. ";

    input_mode := get(dmode!*,'dname);
    %
    % If modular or arnum are on then we keep them on else we want
    % rational on.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then on rational;
    on combineexpt;

    tmp := nest_input(A);
    AA := car tmp;
    full_coeff_list := cadr tmp;

    tmp := frobeniusform(AA);
    ans := car tmp;
    P := cadr tmp;
    Pinv := caddr tmp;
    %
    %  Set up rule list for removing nests.
    %
    rule_list := {'co,2,{'~,'int}}=>'int when numberp(int);
    for each elt in full_coeff_list do
    <<
      tmp := {'co,2,{'~,elt}}=>elt;
      rule_list := append (tmp,rule_list);
    >>;
    %
    %  Remove nests.
    %
    let rule_list;
    ans := de_nest_mat(ans);
    P := de_nest_mat(P);
    Pinv := de_nest_mat(Pinv);
    clearrules rule_list;
    %
    % Return to original mode.
    %
    if input_mode neq 'modular and input_mode neq 'arnum and
     input_mode neq 'rational then
       <<
         % onoff('nil,t) doesn't work so ...
         if input_mode = 'nil then off rational
         else onoff(input_mode,t);
       >>;
    off combineexpt;

    return {'list,ans,P,Pinv};
  end;

flag ('(frobenius),'opfn);  %  So it can be used from algebraic mode.



symbolic procedure frobeniusform(A);
  begin
    scalar ans,plist,tmp,P,Pinv,inv_fact,T1,Tinv,V,Vinv,x;

    x := mkid('x,0);

    tmp := cyclic_vectors(A,x);
    plist := car tmp;
    V := cadr tmp;
    Vinv := caddr tmp;

    tmp := cyclic_to_frobenius(plist,x);
    inv_fact := car tmp;
    T1 := cadr tmp;
    Tinv := caddr tmp;

    P:= reval {'times,V,T1};
    Pinv:= reval {'times,Tinv,Vinv};

    ans := invfact_to_frobenius(inv_fact,x);

    return {ans,P,Pinv};
  end;




symbolic procedure basis(n,i);
  %
  % Basis creates an element of the natural basis of a vector space.
  %
  begin
    scalar VV;
    VV := mkmatrix(1,n);
    setmat(VV,1,i,1);
    return VV;
  end;




symbolic procedure calc_exgcd(poly1,poly2,x);
  %
  % Extended Euclidean algorithm for polynomials.
  % poly1, and poly2 are polynomials in x.
  % Returns gcd, s1, and t1 such that s1 * poly1 + t1 * poly2 = gcd,
  % with degree(s1,x)>;

      gcd := reval norm(c,x);
      s1  := reval{'quotient,c1,{'times,normform_unit(poly1,x),normform_unit(c,x)}};
      t1  := reval{'quotient,c2,{'times,normform_unit(poly2,x),normform_unit(c,x)}};

    return {gcd,s1,t1};
    >>;
  end;



symbolic procedure norm(poly,x);
  begin
    scalar normal;
    if poly = 0 then normal := 0
    else if lcof(poly,x) = 0 then normal := 1
    else normal := reval{'quotient,poly,lcof(poly,x)};
    return normal;
  end;



symbolic procedure normform_unit(poly,x);
  begin
    scalar unit1;
    if poly = 0 then unit1 := 1
    else if lcof(poly,x) = 0 then unit1 := poly
    else unit1 := reval lcof(poly,x);
    return unit1;
  end;




symbolic procedure companion(poly,x);
  %
  % Takes as input a monic univariate polynomial in a variable x.
  % Returns a companion matrix associated with the polynomial poly(x).
  % If C := companion(p,x) and p is a0+a1*x+...+x^n (a univariate monic
  % polynomial), them C(i,n) = -coeff(p,x,i-1), C(i,i-1) = 1 (i=2..n)
  % and C(i,j) = 0 for all other i and j.
  %
  % Can be used independently from algebraic mode.
  %
   begin
    scalar mat1;
    integer n;

    n := deg(poly,x);

    if de_nest(reval coeffn(poly,x,n)) neq 1
     then rederr {"ERROR: polynomial",poly," is not monic."};

    mat1 := mkmatrix(n,n);
    setmat(mat1,1,n,{'minus,coeffn(poly,x,0)});

    for i:=2:n do
    <<
      setmat(mat1,i,i-1,1);
    >>;

    for j:=2:n do
    <<
      setmat(mat1,j,n,{'minus,coeffn(poly,x,j-1)});
    >>;

    return mat1;
  end;

flag('(companion),'opfn);  %  So it can be used independently from
                           %  algebraic mode.



symbolic procedure compute_g(r,dd,plist,x);
  begin
    scalar G,tmp,new_elt;

    G := mkmatrix(r,r);

    for j:=1:r do
    <<
      for i:=1:j-1 do
      <<
        new_elt := 0;
        for k:=getmat(dd,1,i):getmat(dd,1,i+1)-1 do
        <<
          tmp := {'times,coeffn(nth(plist,j),x,k),{'expt,x,{'plus,k,
                  {'minus,getmat(dd,1,i)}}}};
          new_elt := {'plus,new_elt,tmp};
        >>;
        setmat(G,i,j,new_elt);
      >>;

      new_elt := 0;
      for k:=getmat(dd,1,j):getmat(dd,1,j+1) do
      <<
        tmp := {'times,coeffn(nth(plist,j),x,k),{'expt,x,{'plus,k,
                {'minus,getmat(dd,1,j)}}}};
        new_elt := {'plus,new_elt,tmp};
      >>;

      setmat(G,j,j,new_elt);

    >>;

    return G;
  end;




symbolic procedure copy_mat(A);
  %
  % Creates a copy of the input and returns it;
  %
  begin
    scalar C;
    integer row_dim,col_dim;

    matrix_input_test(A);

    row_dim := car size_of_matrix(A);
    col_dim := cadr size_of_matrix(A);

    C := mkmatrix(row_dim,col_dim);

    for i:=1:row_dim do
    <<
      for j:=1:col_dim do
      <<
        setmat(C,i,j,getmat(A,i,j));
      >>;
    >>;

    return C;
  end;




symbolic procedure cyclic_to_frobenius(plist,x);
  %
  % A matrix B=plist_to_polycompanion(plist,x) is transformed to its
  % Frobenius normal form F.
  % If F=diag(C1,..,Cr) where Ci is the companion matrix associated with
  % pi, then cyclic_to_frobenius will return {p1,..,pr}.
  % Let G be the matrix as described before. We compute the Smith normal
  % form S of G. Then S=diag(p1,..,pr), where pi in K[x] such that pi
  % pi divides p(i+1) for i=1..(r-1), and
  % F=invfact_to_frobenius({p1,..,pr},x) is the frobenius normal form of
  % B (for description of invfact_to_frobenius see invfact_to_frobenius)
  % .
  % Remark: to compute the smith normal form of G we car simplify G
  % using the fact that G is upper triangular. Then we use a modified
  % version of smithex.
  begin
    scalar dd,D,US,S,G,C,T1,Tinv,inv_fact,L,Linv,columnT,rowT,rr,q,
           columnTinv,rowTinv,tmp,tmp1;
    integer r,n;

    r := length plist;

    dd := mkmatrix(1,r+1);
    for j:=1:r do
    <<
      setmat(dd,1,j+1,deg(nth(plist,j),x));
    >>;

    n:= getmat(dd,1,r+1);

    %%%%%%%%%%%%%%%%%%%
    % Compute matrix G.
    %%%%%%%%%%%%%%%%%%%
    G:=compute_g(r,dd,plist,x);
    %%%%%%%%%%%%%%%%%%%

    %%%%%%%%%%%%%%%%%%%
    % Compute smith normal form of G.
    %%%%%%%%%%%%%%%%%%%
    tmp := uppersmith(G,x);
    US:=car tmp;
    L := cadr tmp;
    Linv := caddr tmp;

    tmp:=mysmith(US,L,Linv,x);
    S:=car tmp;
    L := cadr tmp;
    Linv := caddr tmp;
    %%%%%%%%%%%%%%%%%%%

    D := mkmatrix(1,r);
    for i:=1:r do
    <<
      setmat(D,1,i,deg(getmat(S,i,i),x));
    >>;

    %%%%%%%%%%%%%%%%%%%
    % Compute transformation matrix.
    %%%%%%%%%%%%%%%%%%%
    C := mkmatrix(1,r);
    T1 := mkmatrix(n,n);
    columnT:=0;

    for i:=1:r do
    <<
      for k:=1:r do
      <<
        setmat(C,1,k,getmat(L,k,i));
      >>;
      for j:=1:getmat(D,1,i) do
      <<
        columnT:=columnT+1;
        for ii:=r step -1 until 1 do
        <<
          q:=get_quo(getmat(C,1,ii),getmat(G,ii,ii));
          rr:=get_rem(getmat(C,1,ii),getmat(G,ii,ii));
          setmat(C,1,ii,rr);
          for jj:=1:(ii-1) do
          <<
            setmat(C,1,jj,reval {'plus,reval getmat(C,1,jj),{'times,
                   {'minus,q},reval getmat(G,jj,ii)}});
          >>;
        >>;
        rowT:=0;
        for ii:=1:r do
        <<
          tmp := reval{'plus,getmat(dd,1,ii+1),{'minus,
                       getmat(dd,1,ii)}};
          for jj:=1:tmp do
          <<
            rowT:=rowT+1;
            tmp1 := coeffn(getmat(C,1,ii),x,jj-1);
            setmat(T1,rowT,columnT,tmp1);
          >>;
        >>;
        for ii:=1:r do setmat(C,1,ii,{'times,getmat(C,1,ii),x});
      >>;
    >>;
    %%%%%%%%%%%%%%%%%%%

    %%%%%%%%%%%%%%%%%%%
    % Compute inverse transformation matrix
    %%%%%%%%%%%%%%%%%%%
    <<
      Tinv := mkmatrix(n,n);
      columnTinv:=0;

      for i:=1:r do
      <<
        for k:=1:r do setmat(C,1,k,getmat(Linv,k,i));
        for j:=1:reval {'plus,getmat(dd,1,i+1),{'minus,
                        getmat(dd,1,i)}} do
        <<
          columnTinv:=columnTinv+1;
          rowTinv:=0;
          for ii:=1:r do
          <<
            setmat(C,1,ii,get_rem(getmat(C,1,ii),getmat(S,ii,ii)));
            for jj:=1:reval getmat(D,1,ii) do
            <<
              rowTinv:=rowTinv+1;
              setmat(Tinv,rowTinv,columnTinv,reval
                     coeffn(getmat(C,1,ii),x,jj-1));
            >>;
          >>;
          for ii:=1:r do setmat(C,1,ii,{'times,getmat(C,1,ii),x});
        >>;
      >>;

    >>;
    %%%%%%%%%%%%%%%%%%%

    inv_fact := {};

    for i:=1:r do
    <<
      if getmat(D,1,i)>0 then
      <<
        inv_fact := append(inv_fact,{getmat(S,i,i)});
      >>;
    >>;

    return {inv_fact,T1,Tinv};
  end;




symbolic procedure cyclic_vectors(A,x);
  %
  % cyclic_vectors computes a polycyclic basis of K^n with respect to A.
  % If this basis is (b1,..,bn)=
  % (v1,A*v1,..,A^(d1-1)*v1,v2,A*v2,.,A*(d2-1)*v2,..,vr,A*vr,..,A^(dr-1)
  % *vr)  and a1*b1+..+a(d1+..+di)*b(d1+..+di)+A^di*vi=0 we set
  % pi=a1+a2*x+..+a(d1+..+di)*x^(d1+..+di-1)+x^(d1+..di).
  % cyclic_vectors returns {p1,..,pr}.
  % The matrix of A on this basis (b1,..,bn) is
  % plist_to_polycompanion([p1,..,pr],x).
  %
  begin
    scalar V,Vinv,plist,U,Uinv,S,carrier,lincomb,VV,UU,SS,l,car,c,
           tmp,ans,q,break;
    integer n,r;

    n := car size_of_matrix(A);

    U := mkmatrix(n,n);
    S := mkmatrix(n,n);
    plist := {};
    V := mkmatrix(n,n);
    Vinv := mkmatrix(n,n);
    carrier := mkvect(n);
    lincomb := mkvect(n);

    r := 0;  %  No. of elements already computed.

    while r>;

            putv(lincomb,car,c);
          >>;

        >>;

        q := 1;
        while q<=n and reval getmat(UU,1,q)=0 do
        <<
          q:=q+1;
        >>;

        if q<=n then
        <<

          %  New element of basis.
          r:=r+1;
          putv(carrier,q,r); % This basis-element carries coordinates q.

          %  Always U=V*S.
          for j:=q:n do setmat(U,j,r,getmat(UU,1,j));
          for j:=1:n do setmat(V,j,r,getmat(VV,1,j));

          for j:=1:r-1 do
          <<
            tmp:=getv(lincomb,j);
            for l:=j+1:r-1 do tmp:={'plus,tmp,{'times,getmat(S,j,l),
                                    getv(lincomb,l)}};
            setmat(S,j,r,{'minus,tmp});
          >>;
          setmat(S,r,r,1);

          %  Compute A*VV.
          for i:=1:n do
          <<
            tmp:=0;
            for j:=1:n do
            <<
             tmp:=reval{'plus,tmp,reval{'times,reval getmat(A,i,j),
                        reval getmat(VV,1,j)}};
            >>;
            setmat(UU,1,i,tmp);
          >>;

          for i:=1: cadr size_of_matrix(UU) do
          <<
            setmat(VV,1,i,getmat(UU,1,i));
          >>;

        >>
        else
        <<
          break := t;
        >>;

      >>;

      %%%%%%%%%%%%%%%%%%%
      % New cycle found
      %%%%%%%%%%%%%%%%%%%
      SS := mkmatrix(1,r);

      for j:=1:r do
      <<
        tmp:=reval getv(lincomb,j);

        for l:=j+1:r do
        <<
          tmp:=reval{'plus,tmp,{'times,reval getmat(S,j,l),
                     reval getv(lincomb,l)}};
        >>;

        setmat(SS,1,j,tmp);
      >>;

      ans := nil;
      for j:=1:r do
      <<
        tmp := {'times,getmat(SS,1,r+1-j),{'expt,x,r-j}};
        ans := reval{'plus,ans,tmp};
      >>;

      tmp := reval{'plus,{'expt,x,r},{'minus,ans}};
      plist := append(plist,{tmp});
      %%%%%%%%%%%%%%%%%%%

    >>; %  End while r>;
        setmat(Vinv,i,j,tmp);
      >>;
    >>;

    return {plist,V,Vinv};
  end;




symbolic procedure de_nest(input);
  %
  % Takes simple nested input and de-nests it.
  %
  begin
    scalar output;
    if atom input then output := input
    else if car input neq 'co then output := input
    else output := caddr input;
    return output;
  end;




symbolic procedure de_nest_mat(mat1);
  %
  % Removes nests from each elt of input matrix.
  % Rules being applied from outside.
  %
  begin
    integer row_dim,col_dim;

    row_dim := car size_of_matrix(mat1);
    col_dim := cadr size_of_matrix(mat1);

    for i:=1:row_dim do
    <<
      for j:=1:col_dim do
      <<
        setmat(mat1,i,j,getmat(mat1,i,j));
      >>;
    >>;

    return mat1;
  end;




%  Allow variable input.
put('diagi,'psopfn,'diag);
symbolic procedure diag(uu);
  %
  % Takes square or scalar matrix entries and creates a matrix with
  % these matrices on the diagonal.
  %
  begin
    scalar bigA,arg,input,u;
    integer nargs,n,Aidx,stp,bigsize,smallsize;

    u := car uu;
    input := u;
    bigsize:=0;

    nargs:=length input;
    for i:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 then bigsize:=bigsize+1
      else
      <<
        bigsize:=bigsize+car size_of_matrix(arg);
      >>;
      input := cdr input;
    >>;

    bigA := mkmatrix(bigsize,bigsize);
    Aidx:=1;
    input := u;
    for k:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 then
      <<
        setmat(bigA,Aidx,Aidx,arg);
        Aidx:=Aidx+1;
        input := cdr input;
      >>
      else
      <<
        smallsize:= car size_of_matrix(arg);
        stp:=smallsize+Aidx-1;
        for i:=Aidx:stp do
        <<
          for j:=Aidx:stp do
          <<
            arg:=car input;
            % Find (i-Aidx+1)'th row.
            arg := cdr arg;
            <<
              n:=1;
              while n < (i-Aidx+1) do
              <<
                arg := cdr arg;
                n:=n+1;
              >>;
            >>;
            arg := car arg;
            %
            %  Find (j-Aidx+1)'th column elt of i'th row.
            %
            <<
              n:=1;
              while n < (j-Aidx+1) do
              <<
                arg := cdr arg;
                n:=n+1;
              >>;
            >>;
            arg := car arg;

            setmat(bigA,i,j,arg);
          >>;
        >>;
        Aidx := Aidx+smallsize;
        input := cdr input;
      >>;
    >>;

    return biga;
  end;





symbolic procedure get_coeffs(poly);
  %
  % Gets all kernels in a poly.
  %
  begin
    scalar ker_list_num,ker_list_den;

    ker_list_num := kernels !*q2f simp reval num poly;
    ker_list_den := kernels !*q2f simp reval den poly;

    ker_list_num := union(ker_list_num,ker_list_den);

    return ker_list_num;
  end;




symbolic procedure get_quo(poly1,poly2);
  %
  % Gets quotient of two polys.
  %
  begin
    scalar quo1,input1,input2;

    if input1 = 0 and input2 = 0 then return 0
    else
    <<
      input1 := reval poly1;
      input2 := reval poly2;
      algebraic (quo1 := (input1-remainder(input1,input2))/input2);
      quo1 := reval quo1;
      return quo1;
    >>;
  end;




symbolic procedure get_rem(poly1,poly2);
  %
  % Gets remainder of two polys.
  %
  begin
    scalar rem1,input1,input2;

    input1 := reval poly1;
    input2 := reval poly2;

    algebraic (rem1 := remainder(input1,input2));
    rem1 := reval rem1;

    return rem1;
  end;




symbolic procedure inv(U,carrier);
  %
  % inv computes the inverse of a permuted upper triangular matrix. The
  % permutation is given by carrier.
  %
  begin
    scalar Uinv,tmp;
    integer n;

    n:= car size_of_matrix(U);
    Uinv := mkmatrix(n,n);

    for i:=1:n do
    <<

      for j:=1:i-1 do
      <<
        tmp:=0;

        for k:=j:i-1 do
        <<
          tmp := {'plus,tmp,{'times,getmat(U,i,getv(carrier,k)),
                  getmat(Uinv,getv(carrier,k),j)}};
        >>;

        setmat(Uinv,getv(carrier,i),j,{'quotient,{'minus,tmp},
               getmat(U,i,getv(carrier,i))});
      >>;

      setmat(Uinv,getv(carrier,i),i,{'quotient,1,getmat(U,i,
             getV(carrier,i))});
      for j:=i+1:n do setmat(Uinv,getv(carrier,i),j,0);
    >>;

    return Uinv;
  end;




symbolic procedure invfact_to_frobenius(inv_fact,x);
  %
  % For plist={p1,..,pr] where pi is a monic polynomial in x,
  % invfact_to_frobenius(plist,x) makes a square matrix with diagonal
  % blocks C1,..,Cr where Ci is the companion matrix to pi.
  %
  begin
    scalar diag_mat,tmp;
    integer num;
    num := length inv_fact;
    tmp:=for i:=1:num collect companion(nth(inv_fact,i),x);
    diag_mat := reval{'diagi, tmp};
    return diag_mat;
  end;




symbolic procedure make_identity(row_dim,col_dim);
  %
  % Creates identity matrix.
  %
  begin
    scalar A;
    A := mkmatrix(row_dim,col_dim);
    for i:=1:row_dim do
    <<
      for j:=1:col_dim do
      <<
        if i=j then setmat(A,i,i,1);
      >>
    >>;
    return A;
  end;





symbolic procedure matrix_input_test(A);
  begin
    if not eqcar(A,'mat) then rederr
     {"ERROR: `",A,"' is non matrix input."}
    else return A;
  end;




symbolic procedure mysmith(US,L,Linv,x);
  %
  % The Smith normal form S of a matrix US is computed. L and Linv are
  % also computed where L*S*R=US.
  % For description of mysmith see smithex.
  %
  begin
    scalar S,a,b,g,jj,s1,t1,tmp,isclear,q,lc,poly1,poly2,input1,input2;
    integer n,r;

    n:= car size_of_matrix(US);

    S := copy_mat(US);

    for k:=1:n do
    <<

      isclear := nil;
      while not isclear do
      <<
        for i:= k+1:n do
        <<

          if getmat(S,i,k) = 0 then <<>>
          else
          <<

            poly1 := getmat(S,k,k);
            poly2 := getmat(S,i,k);
            tmp := calc_exgcd(poly1,poly2,x);
            g := car tmp;
            s1 := cadr tmp ;
            t1 := caddr tmp ;
            a := get_quo(poly1,g);
            b := get_quo(poly2,g);
            for j:=k+1:n do
            <<
              input1 := getmat(S,k,j);
              input2 := getmat(S,i,j);
              tmp := {'plus,{'times,s1,input1},{'times,t1,input2}};
              setmat(S,i,j,{'plus,{'times,a,input2},{'minus,{'times,b,
                     input1}}});
              setmat(S,k,j,tmp);
            >>;

            for j:=1:n do
            <<
              tmp := reval{'plus,{'times,a,getmat(L,j,k)},{'times,b,
                           getmat(L,j,i)}};
              setmat (L,j,i,reval{'plus,{'times,{'minus,t1},
                      getmat(L,j,k)},{'times,s1,getmat(L,j,i)}});
              setmat (L,j,k,tmp);
            >>;

            for j:=1:n do
            <<
              tmp := reval{'plus,{'times,s1,getmat(Linv,k,j)},
                           {'times,t1,getmat(Linv,i,j)}};
              setmat (Linv,i,j,reval{'plus,{'times,a,getmat(Linv,i,j)},
                      {'times,{'minus,b},getmat(Linv,k,j)}});
              setmat (Linv,k,j,tmp);
            >>;

            setmat(S,k,k,g);
            setmat(S,i,k,0);

          >>;

        >>;
        isclear := t;

        for i:=k+1:n do
        <<
          poly1:=getmat(S,k,i);
          poly2:=getmat(S,k,k);
          setmat(S,k,i,get_rem(poly1,poly2));
          q := get_quo(poly1,poly2);
        >>;

        for i:=k+1:n do
        <<
          if getmat(S,k,i) = 0 then <<>>
          else
          <<
            poly1:=getmat(S,k,k);
            poly2:=getmat(S,k,i);
            tmp := calc_exgcd(poly1,poly2,x);
            g:= car tmp;
            s1 := cadr tmp;
            t1 := caddr tmp;
            a:=get_quo(poly1,g);
            b:=get_quo(poly2,g);

            for j:=k+1:n do
            <<
              input1 := getmat(S,j,k);
              input2 := getmat(S,j,i);
              tmp := {'plus,{'times,s1,input1},{'times,t1,input2}};
              setmat(S,j,i,{'plus,{'times,a,input2},{'minus,{'times,b,
                     input1}}});
              setmat(S,j,k,tmp);
            >>;

            setmat(S,k,k,g);
            setmat(S,k,i,0);
            isclear := nil;
          >>;
        >>;

      >>;
    >>;

    r:=0;
    for i:=1:n do
    <<

      if getmat(S,i,i) neq 0 then
      <<
        r:=r+1;
        %  Watch out for integers giving lc = 0.
        if off_mod_lcof(getmat(S,i,i),x) = 0 then lc := getmat(S,i,i)
        else lc := off_mod_lcof(getmat(S,i,i),x);
        setmat(S,r,r,{'quotient,getmat(S,i,i),lc});
        if i neq r then
        <<
          setmat(S,i,i,0);

          for j:=1:n do
          <<
            tmp := reval getmat(L,j,r);
            setmat(L,j,r,reval getmat(L,i,j));

            setmat(L,j,i,tmp);
          >>;

          for j:=1:n do
          <<
            tmp := reval getmat(Linv,r,j);
            setmat(Linv,r,j,reval getmat(Linv,i,j));
            setmat(Linv,i,j,tmp);
          >>;

        >>;
      >>;

    >>;



    for i:=1:r-1 do
    <<
      jj:=i+1;
      <<
        while reval getmat(S,i,i) neq 1 and jj <= r do
        <<
          poly1:=reval getmat(S,i,i);
          poly2:=reval getmat(S,jj,jj);
          tmp := calc_exgcd(poly1,poly2,x);
          g:= car tmp;
          s1 := cadr tmp;
          t1 := caddr tmp;
          a:=get_quo(poly1,g);
          b:=get_quo(poly2,g);
          setmat(S,i,i,g);
          setmat(S,jj,jj,{'times,a,poly2});

          for k:=1:n do
          <<
            tmp := reval {'plus,{'times,a,getmat(L,k,i)},{'times,b,
                          getmat(L,k,jj)}};
            setmat (L,k,jj,reval {'plus,{'times,{'minus,t1},
                    getmat(L,k,i)},{'times,s1,getmat(L,k,jj)}});
            setmat (L,k,i,tmp);
          >>;

          for k:=1:n do
          <<
            tmp := reval {'plus,{'times,s1,getmat(Linv,i,k)},{'times,t1,
                          getmat(Linv,jj,k)}};
            setmat(Linv,jj,k,reval {'plus,{'times,a,getmat(Linv,jj,k)},
                   {'times,{'minus,b},getmat(Linv,i,k)}});
            setmat(Linv,i,k,tmp);
          >>;

          jj:=jj+1;
        >>;
      >>;
    >>;

    return {S,L,Linv};
  end;




symbolic procedure nest_input(A);
  %
  % Takes a matrix and converts all elements into nested form.
  % Also finds union of all coefficients in all elements and
  % returns them in a list, along with the new matrix.
  %
  begin
    scalar tmp,coeff_list,full_coeff_list,AA;
    integer row_dim,col_dim;

    full_coeff_list := nil;
    coeff_list := nil;

    AA := copy_mat(A);

    row_dim := car size_of_matrix(AA);
    col_dim := cadr size_of_matrix(AA);

    for i := 1:row_dim do
    <<
      for j := 1:col_dim do
      <<
        coeff_list := get_coeffs(getmat(AA,i,j));
        if coeff_list = nil then <<>>
        else full_coeff_list := union(coeff_list,full_coeff_list);
        for each elt in coeff_list do
        <<
          tmp := {'co,2,elt};
          setmat(AA,i,j,algebraic (sub(elt=tmp,getmat(AA,i,j))));
        >>;
      >>;
    >>;


    return {AA,full_coeff_list};
  end;




symbolic procedure off_mod_lcof(input,x);
  begin
    if !*modular then
    <<
      off modular;
      input := lcof (input,x);
      on modular;
    >>
    else input := lcof (input,x);
    return input;
  end;




symbolic procedure off_mod_reval(input);
  %
  %  In certain cases it is required to reval with modular off,
  %  eg: when calculating degrees of polys.
  %
  begin
    if !*modular then
    <<
      off modular;
      input := reval input;
      on modular;
    >>
    else input := reval input;
    return input;
  end;

flag('(off_mod_reval),'opfn);  %  So it can be used from
                               %  algebraic mode.



symbolic procedure plist_to_polycompanion(plist,x);
  %
  % This is not used.
  % It is here to help explain what's going on.
  %
  % If a=a0+a1*x+x^2, b=b0+b1*x+b2*x^2+x^3 and
  % c=c0+c1*x+c2*x^2+c3*x^3+c4*x^4+x^5, then
  % plist_to_polycompanion({a,b,c},x) yields
  %
  %      [ 0  -a0  -b0   0   -c0 ]
  %      [                       ]
  %      [ 1  -a1  -b1   0   -c1 ]
  %      [                       ]
  %      [ 0   0   -b2   0   -c2 ]
  %      [                       ]
  %      [ 0   0    0    0   -c3 ]
  %      [                       ]
  %      [ 0   0    0    1   -c4 ]
  %
  begin
    scalar d,A;
    integer r,n;

    r := length plist;
    d := mkvect(r);
    putv(d,0,0);

    for i:=1:r do putv(d,i,deg(nth(plist,i),x));

    n := getv(d,r);
    A := mkmatrix(n,n);

    for i:=1:r do
    <<
      for j:=getv(d,i-1)+2:getv(d,i) do setmat(A,j,j-1,1);
      for j:=i:r do
      <<
        for k:=getv(d,i-1)+1:getv(d,i) do
        <<
          setmat(A,k,getv(d,j),{'minus,coeffn(nth(plist,j),x,k-1)});
        >>;
      >>;
    >>;

    return A;
  end;




symbolic procedure size_of_matrix(A);
  %
  % Takes matrix and returns list {no. of rows, no. of columns).
  %
  begin
    integer row_dim,col_dim;
    matrix_input_test(A);
    row_dim := -1 + length A;
    col_dim := length cadr A;
    return {row_dim,col_dim};
  end;




symbolic procedure uppersmith(G,x);
  %
  % An upper triangular matrix G is simplified. Entry G(i,j) is reduced
  % modulo gcd(G(i,i),G(j,j)). L and L^(-1) are also comnputed where
  % L*G'*R=G, where G' is the reduced matrix.
  %
  begin

    scalar US,L,Linv,g,s1,t1,q,r,tmp;
    integer n;

    n:= car size_of_matrix(G);

    US:=copy_mat(G);

    L := make_identity(n,n);
    Linv := make_identity(n,n);

    for j:=2:n do
    <<
      for i:=1:j-1 do
      <<
        tmp:=calc_exgcd(getmat(US,i,i),getmat(US,j,j),x);
        g:= car tmp;
        s1:= cadr tmp;
        t1 := caddr tmp;
        q := get_quo(getmat(US,i,j),g);
        r := get_rem(getmat(US,i,j),g);

        setmat(US,i,j,r);

        for k:=1:i-1 do
        <<
          tmp := getmat(US,k,i);
          setmat(US,k,j,{'plus,getmat(US,k,j),{'times,{'minus,q},s1,
                 getmat(US,k,i)}});
        >>;

        for k:=j+1:n do
        <<
          setmat(US,i,k,{'plus,getmat(US,i,k),{'times,{'minus,q},t1,
                 getmat(US,j,k)}});
        >>;

        for k:=1:i do
        <<
          setmat(L,k,j,{'plus,getmat(L,k,j),{'times,q,t1,
                 getmat(L,k,i)}});
        >>;

        setmat(Linv,i,j,{'times,{'minus,q},t1});
      >>;
    >>;

    return {US,L,Linv};
  end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/jordan.red0000644000175000017500000001664111526203062024324 0ustar  giovannigiovannimodule jordan; % Computation of the Jordan normal form of a matrix.                                                              %

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load!-package 'matrix;  %  Otherwise setmat can fail (letmtr undefined).

load!-package 'arnum; % So we can test whether it's in use or not.

% The following functions may be useful by themselves. They can be     %
% called from algebraic mode: companion, copyinto, deg_sort,           %
% jordanblock, submatrix.                                              %
%                                                                      %

%**********************************************************************%

% jordan(A) computes the Jordan normal form of a square matrix A.
% First jordansymbolic is applied to A, then the symbolic zeroes of the
% characteristic polynomial are replaced by the actual zeroes. The
% zeroes of the characteristic polynomial of A are computed exactly if
% possible. The zeroes which cannot be computed exactly are
% approximated by floating point numbers.

% Specifically:
%
% - jordan(A) will return {J,P,Pinv} where J, P, and Pinv
%   are such that P*J*Pinv = A.
%

% For more details of the algorithm and general workings of jordan
% see jordansymbolic.


symbolic procedure jordan(A);
  begin
    scalar AA,l,tmp,P,Pinv,ans,ans_mat,full_coeff_list,rule_list,
           input_mode;

    matrix_input_test(A);
    if (car size_of_matrix(A)) neq (cadr size_of_matrix(A))
     then rederr "ERROR: expecting a square matrix. ";

    input_mode := get(dmode!*,'dname);
    if input_mode = 'modular then rederr
    "ERROR: jordan does not work with modular on. Try jordansymbolic. ";
    %
    % If arnum is on then we keep it on else we want
    % rational on.
    %
    if input_mode neq 'arnum and input_mode neq 'rational
     then on rational;
    on combineexpt;

    tmp := nest_input(A);
    AA := car tmp;
    full_coeff_list := cadr tmp;

    l := jordansymbolicform(AA, full_coeff_list);

    tmp := jordanform(l, full_coeff_list);
    ans := car tmp;
    P := cadr tmp;
    Pinv := caddr tmp;
    %
    %  Set up rule list for removing nests.
    %
    rule_list := {'co, 2,{'~, 'int}}=>'int when numberp(int);
    for each elt in full_coeff_list do
    <<
      tmp := {'co, 2, {'~, elt}}=>elt;
      rule_list := append (tmp, rule_list);
    >>;
    %
    %  Remove nests.
    %
    let rule_list;
    ans_mat := de_nest_mat(ans);
    P := de_nest_mat(P);
    Pinv := de_nest_mat(Pinv);
    clearrules rule_list;
    %
    % Return to original mode.
    %
    if input_mode neq 'arnum and input_mode neq 'rational then
    <<
      % onoff('nil,t) doesn't work so...
      if input_mode = 'nil then off rational
      else onoff(input_mode,t);
    >>;
    off combineexpt;

    return {'list, ans_mat, P, Pinv};
  end;

flag ('(jordan),'opfn);  %  So it can be used from algebraic mode.



symbolic procedure jordanform(l, full_coeff_list);
  begin
    scalar jj,z,zeroes,P,Pinv,x,tmp,tmp1,de_nest;
    integer n,d;

    P := nth(l,3);
    Pinv := nth(l,4);

    n := length nth(nth(l,2),1);
    x := nth (nth(l,2),2);
    jj := nth(l,1);

    for i:=1:n do
    <<
      d := deg(nth(nth(nth(l,2),1),i),x);
      if d>1 then
      <<
        %
        %  Determine zeroes.
        %
        z := nth(nth(nth(l,2),1),i);
        zeroes := {};
        %  de-nest as solve sometimes fails with nests.
        de_nest := de_nest_list(z,full_coeff_list);
        tmp := algebraic solve(de_nest,x);
        tmp := cdr tmp;  %  Remove algebraic 'list.
        for j:=1:length tmp do
        <<
          if test_for_root_of(nth(tmp,j)) then
          <<
            %  If poly is univariate then can solve using roots.
            if length get_coeffs(de_nest) = 1 then
            <<
              on complex;
              tmp1 := algebraic roots(z);
              off complex;
            >>
            else
            <<
              on fullroots;
              prin2t "***** WARNING: fullroots turned on.";
              prin2t "               May take a while.";
              % system "sleep 3";
              tmp1 := algebraic solve(de_nest,x);
              off fullroots;
              tmp1 := re_nest_list(tmp1,full_coeff_list);
            >>;
            zeroes := append(zeroes,tmp1);
            zeroes := cdr zeroes;
          >>
         else
          <<
            tmp1 := algebraic solve(z,x);
            tmp1 := cdr tmp1;
            zeroes := append(zeroes,{nth(tmp1,j)});
          >>;
        >>;
        %
        %  Substitute zeroes for symbolic names.
        %
        for j:=1:length zeroes do
        <<
          tmp := nth(zeroes,j);
          tmp := caddr tmp;
          jj := algebraic sub(mkid(x,off_mod_reval{'plus,
                              {'times,10,i},j})=tmp, jj);
        >>;

        for j:=1:length zeroes do
        <<
          tmp := nth(zeroes,j);
          tmp := caddr tmp;
          P := algebraic sub(mkid(x,off_mod_reval{'plus,
                             {'times,10,i},j})=tmp,P);
        >>;

        for j:=1:length zeroes do
        <<
          tmp := nth(zeroes,j);
          tmp := caddr tmp;
          Pinv := algebraic sub(mkid(x,off_mod_reval{'plus,
                                {'times,10,i},j})= tmp, Pinv);
        >>;
      >>;
    >>;

    return {jj,P,Pinv};
  end;




symbolic procedure test_for_root_of(input);
  %
  % Goes through a list testing to see if there is a 'root-of
  % contained within it.
  %
  begin
    scalar tmp,copy_input,boolean,tmp1;

    boolean := nil;
    copy_input := input;

    if atom copy_input then <<>>
    else if car copy_input = 'root_of
     then boolean := t
    else while copy_input and boolean = nil do
    <<
      tmp := copy_input;
      tmp :=  car copy_input;
      if tmp = 'root_of then boolean := t
      else while pairp tmp and boolean = nil do
      <<
        tmp1 := tmp;
        if car tmp1 = 'root_of then boolean := t
        else if atom tmp1 then <<>>
        else while pairp tmp1 and boolean = nil do
        <<
          if car tmp1 = 'root_of then boolean := t
          else tmp1 := car tmp1;
        >>;
        tmp := cdr tmp;
      >>;
      copy_input := cdr copy_input;
    >>;

    return boolean;
  end;

flag ('(test_for_root_of),'boolean);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/normform.hlp0000644000175000017500000001621511526203062024714 0ustar  giovannigiovanni\chapter[NORMFORM: matrix normal forms]%
        {NORMFORM: Computation of matrix normal forms}
\label{NORMFORM}
\typeout{{NORMFORM: Computation of matrix normal forms}}

{\footnotesize
\begin{center}
Matt Rebbeck \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
\end{center}
}
\ttindex{NORMFORM}

This package contains routines for computing the following
normal forms of matrices:
\begin{itemize}
\item smithex\_int
\item smithex
\item frobenius
\item ratjordan
\item jordansymbolic
\item jordan.
\end{itemize}

By default all calculations are carried out in {\cal Q} (the rational
numbers). For {\tt smithex}, {\tt frobenius}, {\tt ratjordan},
{\tt jordansymbolic}, and {\tt jordan}, this field can be extended to
an algebraic number field using ARNUM (chapter~\ref{ARNUM}).
The {\tt frobenius}, {\tt ratjordan}, and {\tt jordansymbolic} normal
forms can also be computed in a modular base.

\section{Smithex}

\ttindex{smithex}
{\tt Smithex}(${\cal A},\, x$) computes the Smith normal form ${\cal S}$
of the matrix ${\cal A}$.

It returns \{${\cal S}, {\cal P}, {\cal P}^{-1}$\} where ${\cal S},
{\cal P}$, and ${\cal P}^{-1}$ are such that
 ${\cal P S P}^{-1} = {\cal A}$.

 ${\cal A}$ is a rectangular matrix of univariate polynomials in $x$
where $x$ is the variable name.

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} x & x+1 \\ 0 & 3*x^2 \end{array}
\right)
\end{displaymath}

\begin{displaymath}
\hspace{-0.5in}
\begin{array}{ccc}
{\tt smithex}({\cal A},\, x) & = &
\left\{ \left( \begin{array}{cc} 1 & 0 \\
0 & x^3 \end{array} \right), \left( \begin{array}{cc} 1 & 0 \\ 3*x^2
& 1 \end{array} \right), \left( \begin{array}{cc} x & x+1 \\ -3 & -3
\end{array} \right) \right\} \end{array}
\end{displaymath}


\section{Smithex\_int}

\ttindex{smithex\_int}
Given an $n$ by $m$ rectangular matrix ${\cal A}$ that contains
{\it only} integer entries, {\tt smithex\_int}(${\cal A}$) computes the
Smith normal form ${\cal S}$ of ${\cal A}$.

It returns \{${\cal S}, {\cal P}, {\cal P}^{-1}$\} where ${\cal S},
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P S P}^{-1} =
{\cal A}$.

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{ccc} 9 & -36 & 30 \\ -36 & 192 & -180 \\
30 & -180 & 180  \end{array}
\right)
\end{displaymath}

{\tt smithex\_int}(${\cal A}$) =
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{ccc} 3 & 0 & 0 \\ 0 & 12 & 0 \\ 0 & 0 & 60
\end{array} \right), \left( \begin{array}{ccc} -17 & -5 & -4 \\ 64 & 19
& 15 \\ -50 & -15 & -12 \end{array} \right), \left( \begin{array}{ccc}
1 & -24 & 30 \\ -1 & 25 & -30 \\ 0 & -1 & 1 \end{array} \right) \right\}
\end{displaymath}
\end{center}


\section{Frobenius}

\ttindex{frobenius}
{\tt Frobenius}(${\cal A}$) computes the Frobenius normal form
${\cal F}$ of the matrix ${\cal A}$.

It returns \{${\cal F}, {\cal P}, {\cal P}^{-1}$\} where ${\cal F},
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P F P}^{-1} =
{\cal A}$.

${\cal A}$ is a square matrix.

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} \frac{-x^2+y^2+y}{y} &
\frac{-x^2+x+y^2-y}{y} \\ \frac{-x^2-x+y^2+y}{y} & \frac{-x^2+x+y^2-y}
{y} \end{array} \right)
\end{displaymath}

{\tt frobenius}(${\cal A}$) =
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} 0 & \frac{x*(x^2-x-y^2+y)}{y} \\ 1 &
\frac{-2*x^2+x+2*y^2}{y} \end{array} \right), \left( \begin{array}{cc}
1 & \frac{-x^2+y^2+y}{y} \\ 0 & \frac{-x^2-x+y^2+y}{y} \end{array}
\right), \left( \begin{array}{cc} 1 & \frac{-x^2+y^2+y}{x^2+x-y^2-y} \\
0 & \frac{-y}{x^2+x-y^2-y} \end{array} \right) \right\}
\end{displaymath}
\end{center}


\section{Ratjordan}

\ttindex{ratjordan}
{\tt Ratjordan}(${\cal A}$) computes the rational Jordan normal form
${\cal R}$ of the matrix ${\cal A}$.

It returns \{${\cal R}, {\cal P}, {\cal P}^{-1}$\} where ${\cal R},
{\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P R P}^{-1} =
{\cal A}$.

${\cal A}$ is a square matrix.

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} x+y & 5 \\ y & x^2  \end{array}
\right)
\end{displaymath}

{\tt ratjordan}(${\cal A}$) =
\begin{center}
\begin{displaymath}
\left\{ \left( \begin{array}{cc} 0 & -x^3-x^2*y+5*y \\ 1 &
x^2+x+y \end{array} \right), \left( \begin{array}{cc}
1 & x+y \\ 0 & y \end{array} \right), \left( \begin{array}{cc} 1 &
\frac{-(x+y)}{y} \\ 0 & \hspace{0.2in} \frac{1}{y} \end{array} \right)
\right\}
\end{displaymath}

\end{center}


\section{Jordansymbolic}

\ttindex{jordansymbolic}
{\tt Jordansymbolic}(${\cal A}$) \hspace{0in} computes the Jordan
normal form ${\cal J}$of the matrix ${\cal A}$.

It returns \{${\cal J}, {\cal L}, {\cal P}, {\cal P}^{-1}$\}, where
${\cal J}, {\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P J P}^
{-1} = {\cal A}$. ${\cal L}$ = \{~{\it ll},~$\xi$~\}, where $\xi$ is
a name and {\it ll} is a list of irreducible factors of ${\it p}(\xi)$.

${\cal A}$ is a square matrix.

{\tt load\_package normform;}\\

\begin{displaymath}
{\cal A} = \left( \begin{array}{cc} 1 & y \\ y^2 & 3  \end{array}
\right)
\end{displaymath}

{\tt jordansymbolic}(${\cal A}$) =
\begin{eqnarray}
 & & \left\{ \left( \begin{array}{cc} \xi_{11} & 0 \\ 0 & \xi_{12}
\end{array} \right) ,
\left\{ \left\{ -y^3+\xi^2-4*\xi+3 \right\}, \xi \right\}, \right.
\nonumber \\ & & \hspace{0.1in} \left. \left( \begin{array}{cc}
\xi_{11} -3 & \xi_{12} -3 \\ y^2 & y^2
\end{array} \right), \left( \begin{array}{cc} \frac{\xi_{11} -2}
{2*(y^3-1)} & \frac{\xi_{11} + y^3 -1}{2*y^2*(y^3+1)} \\
\frac{\xi_{12} -2}{2*(y^3-1)} & \frac{\xi_{12}+y^3-1}{2*y^2*(y^3+1)}
\end{array} \right) \right\} \nonumber
\end{eqnarray}

\vspace{0.2in}
\begin{flushleft}
\begin{math}
{\tt solve(-y^3+xi^2-4*xi+3,xi)}${\tt ;}$
\end{math}
\end{flushleft}

\vspace{0.1in}
\begin{center}
\begin{math}
\{ \xi = \sqrt{y^3+1} + 2,\, \xi = -\sqrt{y^3+1}+2 \}
\end{math}
\end{center}

\vspace{0.1in}
\begin{math}
{\tt {\cal J}  = sub}{\tt (}{\tt \{ xi(1,1)=sqrt(y^3+1)+2,\, xi(1,2) =
-sqrt(y^3+1)+2\},}
\end{math}
\\ \hspace*{0.29in} {\tt first  jordansymbolic (${\cal A}$));}

\vspace{0.2in}
\begin{displaymath}
{\cal J} = \left( \begin{array}{cc} \sqrt{y^3+1} + 2 & 0 \\ 0 &
-\sqrt{y^3+1} + 2 \end{array} \right)
\end{displaymath}



\section{Jordan}

\ttindex{jordan}
{\tt Jordan}(${\cal A}$) computes the Jordan normal form
${\cal J}$ of the matrix ${\cal A}$.

It returns \{${\cal J}, {\cal P}, {\cal P}^{-1}$\}, where
${\cal J}, {\cal P}$, and ${\cal P}^{-1}$ are such that ${\cal P J P}^
{-1} = {\cal A}$.

${\cal A}$ is a square matrix.

{\tt load\_package normform;}

\begin{displaymath}
{\cal A} = \left( \begin{array}{cccccc} -9 & -21 & -15 & 4 & 2 & 0 \\
-10 & 21 & -14 & 4 & 2 & 0 \\ -8 & 16 & -11 & 4 & 2 & 0 \\ -6 & 12 & -9
& 3 & 3 & 0 \\ -4 & 8 & -6 & 0 & 5 & 0 \\ -2 & 4 & -3 & 0 & 1 & 3
\end{array} \right)
\end{displaymath}

\begin{flushleft}
{\tt ${\cal J}$ = first jordan$({\cal A})$;}
\end{flushleft}

\begin{displaymath}
{\cal J} = \left( \begin{array}{cccccc} 3 & 0 & 0 & 0 & 0 & 0 \\ 0 & 3
& 0 & 0 & 0 & 0 \\ 0 & 0 & 1 & 1 & 0 & 0 \\ 0 & 0 & 0 & 1 & 0 & 0 \\
 0 & 0 & 0 & 0 & i+2 & 0 \\ 0 & 0 & 0 & 0 & 0 & -i+2
\end{array} \right)
\end{displaymath}

mathpiper-0.81f+svn4469+dfsg3/src/packages/normform/matarg.red0000644000175000017500000000564311526203062024322 0ustar  giovannigiovannimodule matarg;
               % This module forms the ability for matrices to be passed
               % between functions.
               %
               % This module can be used independently from algebraic
               % mode.
               %
               % It was written by W. Neun.
               %

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure mkmatrix(n,m);
   'mat . (for i:=1:n collect
           for j:=1:m collect 0);

symbolic procedure setmat(matri,i,j,val);
    <<   if !*modular then << off modular; on mod_was_on; >>;
         i := reval i;
         j := reval j;
         val := mk!*sq simp reval val;
         letmtr(list(matri,i,j),val,matri);
         if !*mod_was_on then << on modular; off mod_was_on; >>;
         matri>>;

symbolic procedure letmtr(u,v,y);
   %substitution for matrix elements;
   begin scalar z;
        if not eqcar(y,'mat)
          then rerror(matrix,10,list("Matrix",car u,"not set"))
         else if not numlis (z := revlis cdr u) or length z neq 2
          then return errpri2(u,'hold);
        rplaca(pnth(nth(cdr y,car z),cadr z),v);
   end;

symbolic procedure getmat(matri,i,j);
    <<   i := off_mod_reval i;
         j := off_mod_reval j;
         unchecked_getmatelem list(matri,i,j)>>;

symbolic procedure unchecked_getmatelem u;
  begin scalar x;
         if not eqcar(x :=  car u,'mat)
          then  rerror(matrix,1,list("Matrix",car u,"not set"))
         else return nth(nth(cdr x,cadr u),caddr u);
   end;

flag('(setmat,getmat,mkmatrix,letmtr),'opfn);  %  So they can be used
                                               %  independently from
                                               %  algebraic mode.

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/susy2/0000755000175000017500000000000011722677363021612 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/susy2/susy2.tst0000644000175000017500000002551711526203062023424 0ustar  giovannigiovannion list;
on errcont;

% 1.) Example of ordering of objects such as fer,bos,axp;
axp(bos(f,0,0))*bos(g,3,1)*fer(k,1,0);
%fer(k,1,0)*bos(g,3,1)*axp(bos(f,0,0));

% 2.) Example of ordering of fer and fer objects
fer(f,1,2)*fer(f,1,2);
% 0
fer(f,1,2)*fer(g,2,3);
% -fer(g,2,3)*fer(f,1,2);
fer(f,1,2)*fer(f,1,3);
% - fer(f,1,3)*fer(f,1,2);
fer(f,1,2)*fer(f,2,2);
% - fer(f,2,2)*fer(f,1,2);

% 3.) Example of ordering of bos and bos objects;
bos(f,3,0)*bos(g,0,4);
%bos(g,0,4)*bos(f,3,0);
bos(f,3,0)*bos(f,0,0);
%bos(f,3,0)*bos(f,0,0);
bos(f,3,2)*bos(f,3,5);
%bos(f,3,5)*bos(f,3,2);

% 4.) ordering of inverse superfunctions;
% last index in bos objects denotes powers;
bos(f,0,3)*bos(k,0,2)*bos(zz,0,3,-1)*bos(k,0,2,-1);
%bos(zz,0,3,-1)*bos(f,0,3);
bos(c,0,3)*bos(b,0,2)*bos(a,0,3,-1)*bos(b,0,2,-1);
%bos(c,0,3)*bos(a,0,3,-1);

% 5.) Demostration of inverse rule;
let inverse;
bos(f,0,3)**3*bos(k,3,1)**40*bos(f,0,3,-2);
%bos(k,3,1,40)*bos(f,0,3,1);
clearrules inverse;


% 6.) Demonstration of (susy) derivative operators;
% Up to now we did not decided on the chirality assumption
% so let us check first the tradicional algebra os susy derivative;
let trad;

%first susy derivative
der(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));

fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*del(1);
sub(del=der,ws);

%second susy derivative
der(2)*fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0));

fer(r,2,1)*bos(kk,3,4,-4)*axp(fer(f,1,2)*fer(g,2,1))*del(2);
sub(del=der,ws);

%usual derivative;
d(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));
fer(g,2,1)*bos(f,0,2,-2)*axp(fer(h,1,2)*fer(k,2,1))*d(2);
sub(d(2)=d(1),ws);

% 7.) the value of action of (susy) derivative;

xxx:=fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3));
yyy:=fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3));

%first susy derivative

pr(1,xxx);
pr(1,yyy);

%second susy2 derivative;
pr(2,xxx);
pr(2,yyy);

% third susy2 derivative;

pr(3,xxx);
pr(3,yyy);

clearrules trad;
let chiral;
pr(3,xxx);
clearrules chiral;
let chiral1;
pr(3,xxx);

clearrules chiral1;
let trad;
% usual derivative
pg(1,xxx);
pg(3,yyy);

clear xxx,yyy;

% 8.)
% And now let us change traditional algebra on the chiral algebra;
clearrules trad;
let chiral;
% And now we compute the same derivative but in the chiral
% representation;

%first susy derivative
der(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));

fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*del(1);
sub(del=der,ws);

%second susy derivative
der(2)*fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0));

fer(r,2,1)*bos(kk,3,4,-4)*axp(fer(f,1,2)*fer(g,2,1))*del(2);
sub(del=der,ws);
;

% 9.) the value of action of (susy) derivative;

xxx:=fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3));
yyy:=fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3));

%first susy derivative

pr(1,xxx);
pr(1,yyy);

%second susy2 derivative;
pr(2,xxx);
pr(2,yyy);

clear xxx,yyy;
% We return back to the traditional algebra;

clearrules chiral;
let trad;

% 10.) The components of super-objects;

xxx:=fer(f,2,3)*bos(g,3,2,2);

% all components;
fpart(xxx);

%bosonic sector;
bpart(xxx);

%the given component
bf_part(xxx,0);

%the given component in the bosonic sector;

b_part(xxx,0);
b_part(xxx,1);



clear zzz;
clearrules trad;
let chiral;
zzz:=bos(f,3,1,-1)*bos(g,0,1,2);
b_part(zzz,0);
b_part(zzz,3);
clearrules chiral;
let chiral1;
b_part(zzz,0);
b_part(zzz,3);
clearrules chiral1;
let trad;

%11 matrix represenattion of operators;
lax:=der(1)*der(2)+bos(u,0,0);

macierz(lax,b,b);
macierz(lax,f,b);
macierz(lax,b,f);
macierz(lax,f,f);

% 12.) Demonstration of chirality properties;
clearrules trad;
let chiral;
b_chiral:={f0};
b_antychiral:={f1};
f_chiral:={f2};
f_antychiral:={f3};
for k:=0:3 do  write fer(f0,k,0);
for k:=0:3 do  write fer(f1,k,0);
for k:=0:3 do  write fer(f2,k,0);
for k:=0:3 do  write fer(f3,k,0);
for k:=0:3 do  write bos(f1,k,0);
for k:=0:3 do  write bos(f2,k,0);
for k:=0:3 do  write bos(f2,k,0);
for k:=0:3 do  write bos(f3,k,0);

% 13.) Integrations;

d(-1)*xxx;

%we have to declare ww;
ww:=2;

d(-1)*xxx;
xxx*d(-2);
d(-3)*xxx;

ww:=4;
d(-1)**5:=0;d(-2)**5:=0;

d(-1)*yyy;
yyy*d(-2);

clear d(-1)**5,d(-2)**5;


on list;

% 14.) The accelerations of integrations;

clear ww;
ww:=3;
let drr;
let cutoff;
cut:=4;
d(-1)*xxx;
d(-1)**2*yyy;
clear ww,cut;
ww:=4;
cut:=5;
d(-1)**3*yyy;
d(-1)*xxx;

clearrules cutoff;clearrules drr;
clear cut,ww;

% it is possible to use directly accelerated integrations oprators dr;
ww:=4;
dr(-2)*fer(f,1,2)*bos(kk,0,2);

on time;
showtime;

dr(-3)*bos(g,3,1)*bos(ff,3,2);

showtime;
%if you try usual integration

d(-1)**3*bos(g,3,1)*bos(ff,3,2);

showtime;

% then the time - diffrences is evident. In this example d(-1)
% integration is 10 times slower then  dr integrations.

off time;

let cutoff;
cut:=5;
dr(-2)*fer(f,1,2)*bos(aa,0,1);
dr(-3)*bos(g,3,1)*bos(bb,0,3);
clear ww,cut;
ww:=6;
cut:=7;
dr(-3)*fer(k,2,3)*bos(h,0,2);
dr(-4)*bos(h,0,3)*bos(k,0,2);

clear ww,cut;
clearrules cutoff;

% 15.) The combinations

%the combinations of dim 7 constructed from fields of
% the 2 ,3 dimensions, free  parameters are numerated by "a";

w_comb({{f,2,b},{g,3,b}},7,a,b);
w_comb({{f,2,f},{g,3,f}},4,s,f);

% and now compute the last example but withouth the (susy)divergence
%terms;

fcomb({{f,2,b},{g,3,b}},5,c,b);
fcomb({{f,1,f}},4,r,f);


% 16.) The element of pseudo - susy -differential algebra;

pse_ele(2,{{f,2,b}},c);
pse_ele(3,{{f,2,b}},c);
pse_ele(4,{{f,2,b}},c);
pse_ele(3,{{f,1,b},{g,2,b}},r);

% The components of the elements of pseudo - susy - differential algebra;

xxx:=pse_ele(2,{{f,1,b},{g,2,b}},r);

for k:=0:3 do write s_part(xxx,k);

for k:=0:2 do write d_part(xxx,k);

for k:=0:2 do for l:=0:3 do write sd_part(xxx,l,k);

clear xxx;

% 17.) Projection onto invariant subspace;

xxx:=
w_comb({{f,1,b}},2,a,b)*d(1)+
w_comb({{f,1,b}},3,b,b)*der(1)*der(2)+
w_comb({{f,1,b}},5/2,c,b)*der(1)+
w_comb({{f,1,b}},3,ee,b)*d(1)^2+
w_comb({{f,1,b}},7/2,fe,b)*d(1)*der(2)+
w_comb({{f,1,b}},3,g,b)*der(1)*der(2)*d(1);

for k:=0:2 do write rzut(xxx,k);

clear xxx;

% 18.) Test for the adjoint operators;

cp(der(1));
cp(der(1)*der(2));
clearrules trad;
let chiral1;
cp(der(3));
cp(der(1)*d(1));
clearrules chiral1;
let trad;
cp(d(1));
cp(d(2));
as:=fer(f,1,0)*d(-3)*fer(g,2,0)+fer(h,1,2)*d(-3)*fer(kk,2,1);
cp(as);
cp(as*as);

as:=fer(f,1,0);
cp(as);
cp(ws);

clear as;

as:=bos(f,0,0);
as1:=as*der(1);
cp(as1);
cp(ws);
cp(as1)+der(1)*as;

as2:=as*der(1)*der(2);
cp(as2);
cp(ws);
cp(as2) - der(1)*der(2)*as;


clear as;
as:=mat((fer(f,1,0)*der(1),bos(g,0,0)*d(-3)*bos(h,0,0)),
(fer(h,2,1),fer(h,1,2)*d(-3)*fer(k,2,3)));
cp(as);
clear as;


% 19.) Analog of coeff

xxx:=pse_ele(2,{{f,1,b}},a);
yyy:=lyst(xxx);
zzz:=lyst1(xxx);
yyy:=lyst2(xxx);
clear xxx,yyy,zzz;

% 20.) Simplifications;

% we would like to compute third generalizations of the SUSY KdV
% equation
% example from Z.Popowicz Phys.Lett.A.174 (1993) p.87

lax:=d(1)+d(-3)*der(1)*der(2)*bos(u,0,0);
lb2:=lax^2;
la2:=chan(lb2);
lb3:=lax*la2;
la3:=chan(lb3);
lax3:=rzut(la3,1);
comm:=lax*lax3 - lax3*lax;
com:=chan(comm);
result:=sub(der=del,com);
%the equation is
equ:=sub(del(1)=1,del(2)=1,d(-3)=1,result);

clear lax,lb2,la2,lb3,la3,lax3,comm,com,result;

% we now compute the same but starting from
% different realizations of susy algebra
%
clearrules trad;
let chiral1;
lax:=d(1)+d(-3)*del(3)*bos(u,0,0);
la2:=chan(lax^2);
la3:=rzut(chan(lax*la2),0);
com:=chan(lax*la3-la3*lax);
equ_chiral1:=sub(d(-3)=1,del(3)=1,com);
clear lax,lb2,la2,lb3,la3,lax3,lax,comm,com,result;
clearrules chiral1;
let trad;

% 21.) Conservation laws;
% we would like to check the conservations laws for our third
%generalization of susy kdv equation;
%

ham:=fcomb({{u,1,b}},3,a,b);

conserv:=dot_ham({{u,equ}},ham);
% we check now on susy-divergence behaviour;
%
az:=war(conserv,u);
solve(az);
clear equ,ha,conserv,az;

% 22.) The residue of Lax operator
% we would like to find conservation laws for Lax susy KdV
% equation considered in the previous example
%
lax:=d(1)-d(-3)*del(1)*der(2)*bos(u,0,0);
lb2:=lax^2;
la2:=chan(lb2);
lb4:=la2^2;
kxk^3:=0;
la4:=chan(lb4);
lc4:=sub(kxk=1,qq=-3,sub(d(-3)=kxk*d(qq),la4));
lb5:=lax*lc4;
lc5:=s_part(lb5,3);
la5:=lc5-sub(d(-3)=0,lc5);
ld5:=chan(la5);
konserv:=sub(d(-3)=1,d_part(ld5,-1));
clear lax,lb2,la2,lb4,kxk,la4,lc4,lb5,lc5,la5,konserv;

%22.) The N=2 SuSy Boussinesq equation
% example from Z.Popowicz Phys.LettB.319 (1993) 478-484

clearrules trad;
let chiral;

lax:=del(1)*(d(1)^2+bos(j,0,0)*d(1)+bos(tt,0,0))*der(2);
la2:=del(1)*(d(1)+2*bos(j,0,0)/3)*der(2);
com:=sub(del(1)=1,der(2)=1,lax*la2-la2*lax);
operator boss;
boss(j,t):=d_part(com,1);
boss(tt,t):=d_part(com,0);

% let us shift bos(tt,0,0) to

bos(tt,0,0):=bos(tx,0,0)/2+bos(j,0,0)**2/6 + bos(j,0,1)/2;
bos(tt,0,1):=pg(1,bos(tt,0,0));
bos(tt,0,2):=pg(1,bos(tt,0,1));
fer(tt,1,0):=pr(1,bos(tt,0,0));
fer(tt,2,0):=pr(2,bos(tt,0,0));

% then the equations of motion are;

bos(j,t):=boss(j,t);
bos(tx,t):=2*(boss(tt,t) - boss(j,t)*bos(j,0,0)/3-
            pg(1,boss(j,t))/2);

clear lax,la2;
clearrules chiral;
let trad;

%23.) the Jacobi identity;
% we will find the N=2 susy extension of the Virasoro algebra.
% First we found the most general form of the susy-pseudo-differential
% element of the dimension two.

vira:=pse_ele(2,{{f,1,b}},a);

% This vira should be antisymmetrical so we found

ewa:=vira+cp(vira);

%we first solve ewa in order to found free coefficients;

load_package groebner;
adam:=groesolve(sub(der(1)=1,der(2)=1,d(1)=1,lyst1(ewa)));

% we define now the most general antisymmetrical susy-pseudo-symmetrical
% element of conformal dimension two.

vira:=sub(adam,vira);

% we make additional assumption that our Poisson tensor vira should be O(2)
% invariant under the change of susy derivatives;

dad:=odwa(vira)-vira;
factor der;
wyr1:=sub(der(1)=1,der(2)=1,lyst1(dad));
remfac der;
dad:=groesolve(wyr1);
vira:=sub(dad,vira);
% we check wheather it is really O(2) invariant;
vira-odwa(vira);
% O.K
%so
%now we check the Jacobi identity

jjacob:=fjacob(vira,f);

% we now check jjacob on the susy-divergence behaviour w.r. to the test
% superfunction !#a;

az:=war(jjacob,!#a);
as:=groesolve(az);
array ew(3);

for k:=1:2 do ew(k):=part(as,k);

% as we see we have two different solutions
% first give us classical realizations of the Virasoro algebra
% (without the center term)  which is

sub(ew(1),vira);


% the second solution give us desired susy generalizations of
% Virasoro algebra

sub(ew(2),vira);

% the coefficient "a" could be absorbed by redefinations of
% bos(f,0,0)
% we check that previous result satisfies the antisymmetric requirements

ws + cp(ws);

clearrules trad;
let chiral1 ;

% We check that for chiral1 realization the following operator
vira:=der(3)*d(1)+bos(j,0,1)+bos(j,0,0)*d(1)+
        fer(j,1,0)*der(2)+fer(j,2,0)*der(1);
% satisfy the Jacobi identity;
jjacob:=fjacob(vira,j);

az:=war(jjacob,!#a);

%24 superintegration
clearrules chiral1;
let trad;


as:=s_int(0,bos(f,3,0)^2-bos(f,0,1)^2,{f});
as1:=sub(d(-3)=0,ws);
as2:=sub(d(-3)=1,as-as1);
as3:=s_int(1,as2,{f});
as4:=sub(del(-1)=0,ws);
as4:=sub(del(-1)=1,as3-as4);
as5:=s_int(2,as4,{f});

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/susy2/susy2.tex0000644000175000017500000013474511526203062023416 0ustar  giovannigiovanni\documentstyle[12pt]{article}
\def\be{\begin{equation}}
\def\ee{\end{equation}}
\def\pe{\begin{eqnarray}}
\def\ke{\end{eqnarray}}
\topmargin=-2cm\textheight=23.5cm\textwidth=16cm
\oddsidemargin=0.25cm
\evensidemargin=0.25cm

\begin{document}

                \title{S U S Y 2}

                \author{by \\
        Ziemowit Popowicz by \\ \\
        Institute of Theoretical Physics, University of Wroc{\l}aw,\\
        pl.M.Borna 9 50-205 Wroc{\l}aw, Poland \\
		e-mail ziemek@ift.uni.wroc.pl \\
                version 1.2}

\maketitle
\begin{abstract}
This package deal, with supersymmetric functions and with algebra
of supersymmetric operators in the extended N=2 as well as in the
nonextended N=1 supersymmery. It allows us
to make  realization of SuSy algebra of differential operators,
compute the gradients of given SuSy Hamiltonians and to obtain
SuSy version of soliton equations using SuSy Lax approach. There
are also many additional procedures also encountered in SuSy soliton
approach, as for example: conjugation of a given SuSy operator, computation
of general form of SuSy Hamiltonians (up to SuSy-divergence equivalence),
checking of the validity of the Jacobi identity for some SuSy
Hamiltonian operators.
\end{abstract}
\section{Introduction}

  The main idea of the supersymmetry (SuSy) is to treat boson and fermion
operators equally [1,2]. This has been realised by introducing the so called
supermultiplets constructed from the boson and fermion operators and
additionally from the Mayorana spinors. Such supermultiplets posses  the
proper transfomations property under the transformation of the Lorentz group.
At the moment we have no experimental confirmations that the supersymmetry
appeare in the nature.

        The idea of using supersymmetry (SuSy) for the
generalization of the soliton equations [3-7] appeared almost in parallel
to the usage of SuSy in the quantum field theory. The first results,
concerning the construction of classical field theories  with fermionic
and bosonic fields
depending on time and one space variable, can be found in [8-12].
In many cases, the  addition of fermions fields does not guarantee that the
final theory becomes SuSy invariant and therefore this method was named as
the fermionic extension in order to distinguish it from the fully SuSy method.

        In order to get a SuSy theory  we have to add to a system of k bosonic
equations kN fermion and k(N-1) boson fields (k=1,2,... N=1,2,..) in such a way
that the final theory becomes SuSy invariant.  From the soliton point of view
we can distinguish two important classes of the supersymmetric equations:
the non-extended $(N = 1)$ and extended $( N > 1 )$ cases. Consideration of the
extended case may imply new bosonic equations whose properties need further
investigation. This may be viewed as a bonus, but this extended case is no
more fundamental than the non-extended one. The problem of the
supersymmetrization of the nonlinear partial differential equations has its
own history, and at the moment we have no unique solution [13-40].
We can distinguish three different methods of
supersymmetrization, as for example the algebraic, geometric and direct method.

        In the first two cases we are looking for the symmetry group of the
given equation and then we replace this group by the corresponding
SuSy group. As a final product we are able to obtain
SuSy generalization
of the given equation. The classification into  the algebraical or
geometrical approach is connected with the kind of symmetry which appears
in the classical case. For example, if our classical equation could be
described  in terms of the geometrical object then the simple exchange
of the classical symmetry group of this object with its SuSy partner
justifies the name geometric. In the case of algebraic we are looking for the
symmetry group of the equation without any reference to its
geometrical origin. This strategy could be applied to the so called
hidden symmetry as for example in the case of the Toda lattice .
These methods each have advantages and disadvantages. For example,
sometimes we obtain the fermionic extensions. In the case of the
extended supersymmetric Korteweg-de-Vries equation  we have three different
fully SuSy extensions; however only one of them fits to these two
classifications.

In the direct approach we simply replace all
objects which are appear in the evolution equation  by all possible
combinations of the supermultiplets and its superderivative in such a way
that to conserve the conformal dimensions. This is non unique
and we yields many different possibilities. However the
arbitrariness is reduced if we additionally investigate
super-bi-hamiltonian structure or try to find its supersymmetric Lax pair.
In many cases this approach is successful.


The utilization  of the above methods can be helped by
symbolic computer algebraic and for this reason
we prapared the package SuSy2 in the symbolic language
REDUCE [41].

       We have implemented and ordered the superfunctions in our program,
extensively using the concept of `` noncom operator '' in order to implement
the supersymmetric integro - differential operators. The program is meant
to perform the symbolic calculations using either fully supersymmetric
supermultiplets or the components version of our supersymmetry.
We have constructed 25 different commands to allow us to compute
almost all objects encountered in the supersymmetrization procedure
of the soliton equation.

\section{Supersymmetry}

        The basic object in the supersymmetric analysis is the superfield
and the supersymmetric derivative. The superfields are the superfermions or
the superbosons [1]. These fields, in the case of extended N=2 sypersymmetry,
depends, in addition to $ x $  and  $ t $, upon two
anticommuting variables, $\theta_{1}$ and $\theta_{2}$ {~}{~}
($\theta_{2}\theta_{1} = - \theta_{1}\theta_{2} , \theta_{1}^{2}=
\theta_{2}^{2}=0 $ ).
Their Taylor expansion with respect to the $ \theta^{'}s $ is
\be
       b(x,t,\theta_{1},\theta_{2}):=w+\theta_{1}\zeta_{1}+
        \theta_{2}\zeta_{2}+\theta_{2}\theta_{1}u\\,
\ee
in the case of superbosons, while for the superfermions reads
\be
        f(x,t,\theta_{1},\theta_{2}):=\zeta_{1}+\theta_{1}w+
        \theta_{2}u+\theta_{2}\theta_{1}\zeta_{2},
\ee
where $w$ and $u$ are classical (commuting) functions depending  on $ x $ and $ t $ ,
$ \zeta_{1} $ and $ \zeta_{2} $ are odd Grassmann valued functions  depending
on $ x $ and $ t $.

        In the set of these superfunctions we can defined the usual derivative
and the superderivative. Usually, we encounter two different realizations
of the superderivative : the first we call  `` traditional '' and the second
`` chiral ''.

The traditional realization can be defined by introducing
two superderivatives $ D_{1} $ and $ D_{2} $
\pe
        D_{1} &=& \partial_{\theta_{1}}+\theta_{1}\partial,\\
        D_{2} &=& \partial_{\theta_{2}}+\theta_{2}\partial,
\ke
with the properties:
\pe
        D_{1}*D_{1}=D_{2}*D_{2} = \partial ,  \\
        D_{1}*D_{2} + D_{2}*D_{1} = 0 .
\ke
        The chiral denoted is by
\pe
        D_{1} &=& \partial_{\theta_{1}} - \frac{1}{2}\theta_{2}\partial,\\
        D_{2} &=& \partial_{\theta_{2}} - \frac{1}{2}\theta_{1}\partial,
\ke
with the properties:
\pe
        D_{1}*D_{1}=D_{2}*D_{2} = 0 ,  \\
        D_{1}*D_{2} + D_{2}*D_{1} = -\partial .
\ke

Below we shall use the name `` traditional'' or `` chiral '' or
`` chiral1 ''algebras to denote  kind of the commutation realations on the
superderivativeis assumed.  The `` chiral1 '' algebras case possess,
additioanly to the ``chiral '' algebra, the commutator of $D_{1}$ and
$D_{2}$ denoted  as
\pe
        D_{3} = D_{1}*D_{2} -D_{2}*D_{1}.
\ke

In SuSy2 package we have will implemented the superfunctions and the
algebra of superderivatives. Moreover, we have defined many additional
procedures  which are useful in the supersymetrizations of the classical
nonlinear system of partial differential equation. Different applications
of this package to the  physical problems could be found in the
papers [34-38].


\section{Superfunctions}

The superfunctions are represented in this package by:
\be
        {\bf bos}(f,0,0),
\ee
for superbosons, while by
\be
        {\bf fer}(g,0,0),
\ee
for superfermions.

The first index denotes the name of the given superobject,  the second
denotes the value of SuSy derivatives,  and the last give the value
of usual derivative. The $bos$ and $fer$ objects are declared as the
operators and as noncom object in the Reduce language. The first index
can take an arbitrary name but with the following restriction:

\be
        {\bf bos}(0,n,m)=0,
\ee
\be
        {\bf fer}(0,n,m)=0.
\ee
for any values of n,m.

        The program has the capability to compute the coordinates of
the arbitrary SuSy expression, using the expansions in the powers of $\theta$.
We have here four commands:
\vspace{0.5cm}

A) In order to have the given expression in the components use
\be
        {\bf fpart}(expression).
\ee
The output is in the form of the list, in which first element is the zero
order term in $\theta$, second is the first order term in $\theta_{1}$,
third is the first order term in $\theta_{2}$ and the fourth is in
$\theta_{2}*\theta_{1}$. For example, the superfunction (11) has the
representation
\pe
  {\bf fpart(bos}(f,0,0)) & => & \{ {\bf fun}(f_{0},0),{\bf gras}(ff_{1},0), \cr
     &&   {\bf gras}(ff_{2},0),{\bf fun}(f_{1},0) \},
\ke
where $fun$ denotes the classical function while the $gras$ the Grassmann
function. First index in the $fun$ or in $gras$ denotes the name of the given
object, while the second denotes the usual derivative.
\vspace{0.2cm}

B) In order to have the bosonic sector only, in which all odd Grassmann
functions disappear,  use
\be
      {\bf bpart}(expression).
\ee

Example:
\be
      bpart(fer(g,0,0)) => \{0, fun(g_{0},0), fun(g_{1},0),0 \}.
\ee

C) In order to have the given coordinates, use
\be
        {\bf bf\underline{~}part}(expression,n),
\ee
where n=0,1,2,3.

Example:
\be
        bf\underline{~}part(bos(f,0,0),3) => fun(f_{1},0).
\ee

D) In order to have the given coordinates in the bosonic sector, use
\be
        {\bf b\underline{~}part}(expression,n),
\ee
where n=0,1,2,3.

Example
\be
        b\underline{~}part(fer(g,0,0),1) => fun(g_{0},0)
\ee


Notice that in the program,  from the default we switch to on the
factor $ fer,bos,gras,fun $. If you remove this factor, then many commands
give you wrong result (for example the command lyst, lyst1 and lyst2).

\section{The inverse and exponentials of superfunctions.}

        In addition to our definitions of the superfunctions we can also
define the inverse and the exponential of superboson.

The inverse of the given bos function (not to be confused with the
`` inverse function '' encountered in the usual analysis) is defined as
\be
        {\bf bos}(f,n,m,-1),
\ee
for an arbitrary $ f,n,m $ with the property $bos(f,n,m,-1)*bos(f,n,m,1)=1$.
The object  $ bos(f,n,m,k) $, in general denotes the k-th power of the
$ bos(f,n,m) $ superfunction.
If we  use the command $``{\bf{let{~}inverse}}''$ then three indices
$ bos $ objects
are transformed onto four indices objects.

The exponential of the superboson function is
\be
        {\bf axp}(bos(f,0,0)).
\ee
It is also possible to use $ axp(f) $, but then we should specify what is f.

We have the following representation in the components for the inverse and
$ axp $ superfunctions
\pe
         fpart(bos(f,0,0,-1)) & = & \{fun(f_{0},0,-1),
       -fun(f_{0},0,-1)*gras(ff_{1},0), \cr
      && -fun(f_{0},0,-1)*gras(ff_{2},0),
      - fun(f_{0},0,-2)*fun(f_{1},0,1)  \cr
      && + 2*fun(f_{0},0,-3)*gras(ff_{1},0)*
       gras(ff_{2},0)\}  \\
      fpart(axp(f)) & = & \{{\bf axx}( bf\underline{~}part(f,0) ),
      axx(bf\underline{~}part(f,0))*bf\underline{~}part(f,1),    \cr
        && axx(bf\underline{~}part(f,0))*bf\underline{~}part(f,2),
        axx(bf\underline{~}part(f,0))  \cr
        && *(bf\underline{~}part(f,3)
        +2bf\underline{~}part(f,1)*bf\underline{~}part(f,2)) \}
\ke

where $ axx(f) $ denotes teh exponentiation of the given classical
function while $ fun(f,m,n) $ the $ n $ th power of the function $ fun(f,m)$.


\section{Ordering.}

Three different superfunctions $ fer,bos,axp $ are ordered among themselves as
\pe
        fer(f,n,m)*bos(h,j,k)*axp(g) , \\
       fer(f,n,m)*bos(h,j,k,l)*axp(g),
\ke

indenpendently of the indices. Superfunctions $ bos $  and $ axp $ are
commuting among themselves, while the superfunctions $fer$ anticommutes
among themselves. For these superfunctions we introduce the following
ordering:.

A) The $ bos $  objects with three and four indices  are  ordered as:
the first index  antilexicographically, the second and the third index as
decreasing order of natural numbers. The last, fourth index is not
ordered because:
\pe
        bos(f,n,m,k)*bos(f,n,m,l) => bos(f,n,m,k+l)
\ke

B) The anticommuting $ fer $ objects we ordered as follows: the first index
antilexicographically, second and third index as decreasing order of natural
numbers.

Example:
\be
fer(f,n,m)*fer(g,k,l)  =>  - fer(g,k,l)*fer(f,n,m)
\ee
for an arbitrary n,m,k,l

\be
fer(f,n,m)*fer(f,n,m) =>     0
\ee
for an arbitrary f,n,m.
\pe
bos(f,2,3,7)*bos(aa,0,3)*bos(f,2,3,-7)   => bos(aa,0,3) , \\
bos(f,2,3,2)*bos(zz,0,3,2)*bos(f,2,3,-2) => bos(zz,0,3,2).
\ke


C) For all exponential functions we have
\be
        axp(f)*axp(g) => axp(f+g).
\ee

\section{(Super)Differential operators.}

        We have implemented three different realizations of the
supersymmetric derivatives. In order to select traditional realization
declare $ {\bf{let {~} trad}} $ . In order to
select chiral or chiral1 algebra declare
$ {\bf{let {~} chiral}} $ or $ {\bf{let {~} chiral1}}$.
By default we have  traditional algebra.

        We have introduced three different types of SuSy
operators which act on the superfunctions
and are considered as operators and as noncomuting objects in
the Reduce language.

For the usual differentiation we introduced two types of operators:

(i) rigth differentations,
\be
{\bf d(1)}*bos(f,0,0) =>  bos(f,0,1)+bos(f,0,0)*d(1);
\ee

(ii) left differentations,
\be
fer(f,0,0)*{\bf d(2)} => -fer(f,0,1)+d(2)*fer(f,0,0).
\ee

From this example follows that the third index in the $bos,fer$ object can
take an arbitrary integer value.

Susy derivatives we denote as $der$ and $del$. $Der$ and $del$ represent
the right and left operatopns, respectively, and are one component argument
operations. The action of these objects on the superfunctions depends on
the choice of the supersymmetric algebra.

Explicitely we have for the traditional algebra:

a) Right SuSy derivative

\pe
        {\bf der(1)}*bos(f,0,0) & =>&  fer(f,1,0)+bos(f,0,0)*der(1), \\
        {\bf der(2)}*fer(g,0,0) & =>&  bos(g,2,0)-fer(g,0,0)*der(2), \\
        der(1)*fer(f,2,0) & =>&  bos(f,3,0)-fer(f,2,0)*der(1), \\
        der(2)*bos(f,3,0) & =>& -fer(f,1,1)+bos(f,3,0)*der(2), \\
        der(1)*bos(f,0,0,-1) & =>& -fer(f,1,0)*bos(f,0,0,-2) + \cr
              && bos(f,0,0,-1)*der(1),  \\
   der(2)*axp(bos(f,0,0)) &=>&  fer(f,2,0)*axp(bos(f,0,0))+ \cr
       && axp(bos(f,0,0))*der(2).
\ke

b) Left SuSy derivative
\pe
        bos(f,0,0)*{\bf del(1)} &=>& -fer(f,1,0)+del(1)*bos(f,0,0), \\
        fer(g,0,0)*{\bf del(2)} &=>&  bos(g,2,0)-del(2)*fer(g,0,0), \\
        fer(f,2,0)*del(2) &=>&  bos(f,3,0)-del(1)*fer(f,2,0), \\
        bos(f,3,0)*del(2) &=>&  fer(f,1,1)+del(2)*bos(f,3,0), \\
        bos(f,0,0,-1)*del(1) &=>&  fer(f,1,0)*bos(f,0,0,-2)+\cr
                && del(1)*bos(f,0,0,-1),\\
   axp(bos(f,0,0))*del(2)& =>& -fer(f,2,0)*axp(bos(f,0,0))+\cr
       && del(2)*axp(bos(f,0,0)).
\ke
From these examples follows that the second index in the fer, bos objects
can take  0, 1, 2, 3 values only with the following meaning: 0 - no SuSy
derivatives, 1 - first SuSy derivative, 2 - second SuSy derivative, 3 - first
and second SuSy derivative.

Using the notations we obtain
\pe
der(1)*der(2)*bos(f,0,0) & => & bos(f,3,0)+ \cr
            && bos(f,0,0)*der(1)*der(2)+ \cr
            &&  fer(f,1,0)*der(2) \cr
            && - fer(f,2,0)*der(1).
\ke

For the ``chiral '' representation, the meaning of the second argument in
the  $bos$ or $fer$ object is  same as in the ``traditional ''
case while the actions of susy operators on the superfunctions are
different. For example we have
\pe
        der(1)*fer(f,1,0) => -fer(f,1,0)*der(1), \\
        der(1)*fer(f,2,0) => bos(g,3,0) - fer(f,2,0)*der(1), \\
        der(2)*bos(g,3,0) => -fer(g,2,1) + bos(g,3,0)*der(2) \\
        bos(g,2,0)*del(2) => del(2)*bos(g,2,)).
\ke
For the ``chiral1'' representation we have different meanig of the second
argument in the $bos$ and $fer$ object. Explicitely  the values 0,1,2 in
this second arguments denotes the values of the susy derivatives while 3
denotes the value of the commutator. Explicitey we have
\pe
der(3)*bos(f,0,0) & => & bos(f,3,0) + 2*fer(f,1,0,0)*der(2) \cr
&& -2*fer(f,2,0)*der(1) + bos(f,0,0)*der(3) \\
        der(1)*fer(f,2,0) &=>& (bos(f,3,0)-bos(f,0,1))/2 - fer(f,2,0)*der(1).
\ke

The supersymmetric operators are always ordered in the case of ``traditional''
algebra as
\pe
        der(2)*der(1) &=>& -der(1)*der(2),\\
        del(2)*del(1) &=>& -del(1)*del(2), \\
        der(1)*del(1) &=>& d(1), \\
        der(1)*del(2) &=>& -del(2)*der(1),
\ke
and similarly for others.

For the ``chiral'' algebra we postulate
\pe
        der(2)*der(1) &=>& -d(1) - der(1)*der(2),\\
        del(2)*del(1) &=>& -d(1) - del(1)*del(2), \\
        der(1)*del(1) &=>& 0, \\
        der(1)*del(2) &=>& -d(1) - del(2)*der(1),
\ke
while for ``chiral1'' additionaly we have
\pe
        der(3)*der(1) => -der(1)*d(1) \\
        der(1)*der(3) => der(1)*d(1) \\
        der(3)*der(2) => der(2)*d(1) \\
        der(2)*der(3) => -der(2)*d(1).
\ke

Please notice that if we would like to have the commponents of some
$bos(f,3,0,-1)$ superfunction in the ``chiral'' representation then new
object appear. Indeed,
\pe
 b\underline{~}part(bos(f,3,0,-1) ,1)  => {\bf fun(f1,0,f0,1,-1)},
\ke
We should consider this five indices object $fun$  as
\pe
fun(f,n,g,m,-k) => (fun(f,n)-fun(g,m)/2)^{-k}.
\ke
Similar interpretation is valid for other commands containing
objects like $bos(f,3,n,-k)$

\section{Action of the operators.}

In order to have the value of the action of the given operator
on some  superfunction we introduce two operations pr and pg.

A)
\be
        pr(n,expression)
\ee
where n:=0,1,2,3.
This command denotes the value itself of action of the SuSy derivatives
on the given expression.For n=0 there is no SuSy derivative, n=1 corresponds
to $der(1)$, n=2 to $der(2)$, while n=3 to $der(1)*der(2)$.

Example:
\be
        pr(1,bos(f,0,0)) => fer(f,1,0),
\ee
\be
        pr(3,fer(g,0,0)) => fer(f,3,0).
\ee


B) For the usual derivative we reserve command
\be
        pg(n,expression)
\ee

where n=0,1,2,...., denotes the value of the usual derivative on the
expression

Example
\be
        pg(2,bos(f,0,0)) => bos(f,0,2)
\ee
\section{Supersymmetric integration}

There is one command ${\bf s\underline {~} int}(number,expression,list)$ 
only. This allows us to compute the value  of supersymmetric integration of 
arbitrary polynomial expression constructed from $fer$ and $bos$ objects. It 
is valid in the traditional representation of the supersymmetry. The 
$numbers$ takes the following values: $ 0 \rightarrow $ corresponds for 
usual $"x"$ integration, $ 1 $ or $ 2 $ for the first or second 
supersymmetric index while $ 3 $ to the integration both over first and 
second indexes. The $list$  is the list of the names of the superfunctions 
over which we would like to integrate. The output of this command is in the 
form of the integrated part and non-integrated part. The non-integrated part 
is denoted by $del(-number)$ if $number = 1,2,3$ and by $d(-3)$ for 0. 

Example 

\be 
{\bf {s\underline {~} int}}(0, 2bos(f,0,1)*bos(f,0,1),\{f\}) = 
bos(f,0,0)^{2},
\ee
\be
s\underline {~} int(1,2*fer(f,1,0)*bos(f,0,0),\{f\}) = bos(f,0,0)^{2},
\ee
\pe
&& s\underline {~} int(3, 
bos(f,3,0)*bos(g,0,0)+bos(f,0,0)*bos(g,3,0),\{f,g\}) =\ \\
&& {~~}{~~}{~~~~}{~~~}{~~}bos(f,0,0)*bos(g,0,0)-\ \\ 
&& del(-3)\Big ( fer(f,1,0)*fer(g,2,0)-fer(f,2,0)*bos(g,1,0) \Big ).
\ke

\section{Integration operators.}

We introduced four different types of integration operators:
right and left denoted as $ d(-1) $ and $ d(-2) $ respectively and moreover
two different types of neutral integration operators $ d(-3) $ and $ d(-4) $.
In first two cases they act acorrding to the formula
\be
        {\bf d(-1)}*bos(f,0,0) = \sum_{i=1}^{\infty} (-1)^{i}*bos(f,0,i-1)*d(-1)^{i},
\ee   \label{calka}

for the right integration, while
\be
        bos(f,0,0)*{\bf d(-2)}= \sum_{i=1}^{\infty} d(-2)^{i}*bos(f,0,i-1),
\ee
for the left integration.


Before using these operators the precision of the integration must be
specified by the declaration
${\bf{ww:=number}}$.
If required this precision can be changed
by clearing the old value of $ww$ and introducing the new one.
Both operators are defined by their action and by the properties
\pe
       d(1)*d(-1) &=& d(-1)*d(1)=d(2)*d(-1)=d(2)*d(-1)=1 ,  \\
             &&   der(1)*d(-1)=d(-1)*der(1),  \\
             &&   d(-1)*del(1)=del(1)*d(-1) ,
\ke
and analogously for $ d(-2) $ and $ der(2), del(2) $.

The neutral operator does not show up any action on some expression but
has several properties. More precisly
\pe
        d(1)*{\bf d(-3)} &=& d(-3)*d(1)=d(2)*d(-3)=d(-3)*d(2)=1,  \\
            &&    der(k)*d(-3)=d(-3)*der(k),  \\
            &&    d(-3)*del(k)=del(k)*d(-3),
\ke
while for $ d(-4) $
\pe
        d(1)*{\bf d(-4)} &=& d(-4)*d(1)=d(2)*d(-4)=d(-4)*d(2)=1 , \\
             &&   der(k)*d(-4)=d(-4)*der(k),
\ke
where k=1, 2.

From the last two formulas we see that $ d(-3) $ operator is transparent under
$ del $  operators while $ d(-4) $ operators stops $ del $  action.

Similarly to  $ d(-3) $ or $ d(-4) $ it is also possible to use the neutral
differentation operator denote ${\bf d(3)}$. It has the properties

\pe
        d(3)*d(-4) &=& d(-4)*d(3)=d(3)*d(-3)=d(-3)*d(3)=1, \\
      &&  der(k)*d(3)=d(3)*der(k), \\
      &&  d(3)*del(k)=del(k)*d(3),
\ke
where k=1, 2.

        We can have also `` accelerated '' integration operators denoted by
$ dr(-n) $ where n is a natural number. The action of these operators
is exactly the same as $ d(-1)**n $ but instead of using n - times the
integration formulas  in the case $ d(-1)**n $, $ dr(-n) $  uses
only once the following formula
\be
{\bf dr(-n)}*bos(f,0,0) = \sum\limits^{ww}_{s=0}(-1)^{s}\pmatrix{ n+s-1 \cr n-1 }
                bos(f,0,s)dr(-n-s).
\ee
We have to, similarly to the $ d(-1) $ case,
declare also the "precision" of integration if we would like to use the
"accelerated" integration operators.
The switch  $ {\bf{let {~} cutoff}} $ and command $ {\bf{cut:= number}} $
allows us to annihilate the higher order terms in the $ dr $ integrations
procedure. Moreover, the switch $ {\bf{let {~} drr}} $
automatically changes usual integrations $ d(-1) $ into
"accelerated" integrations $ dr $. The switch $ {\bf{let {~} nodrr}} $
changes $ dr $ integrations onto $ d(-1) $.


\section{Useful Commands.}

A) Combinations.

We encounter, in many practical applications, problem of construction
of different possible combinations of superfunction and
super-pseudo-differential elements with the given conformal dimensions.
We declare three different procedures in order to realize this requirement:
\pe
     {\bf w\underline{~}comb}(list,n,m,x), \\
     {\bf fcomb}(list,n,m,x), \\
     {\bf pse\underline{~}ele}(n,list,m).
\ke
All these
commands are based on the gradations trick (to associate with
superfuction and superderivative the scaling parametr -
conformal dimension).
We consider here k/2 and k (k natural number and $ k > 0 $ )
gradation only.

        Command $w\underline{~}comb$ gives the most general form of
superfunctions combinations of given gradation. It is four argument
procedure in which:

(i) first argument is a list in which each element is
three elements list in which:  first element is the name of the
superfuction from which we would like to construct our combinations,
second denotes its gradation while the last can take two values
f - in the case where superfunction is superfermionic or b -
for superbosonic.

(ii) second argument is a number - the desired gradation.

(iii) third argument  is an arbitrary not numerical value which enumerates
the free parameters in our combinations.

(iv) fourth argument takes two values

f - in the case when whole combinations should be fermionic  or

b -  for the bosonic nature of combination.
\vspace{0.5cm}

Examples:
\pe
        w\underline{~}comb(\{ \{ f,1,b \},\{g,1,b \} \},2,z,b) & =>&
z1*bos(f,3,0)+
       z2*bos(f,0,1)+\cr
       &&z3*bos(f,0,0)^2; \\
 w\underline{~}comb( \{ \{ f,1,b \} \},3/2,g,f)     &=>&
g1*fer(f,1,0)+ g2*fer(f,2,0);
\ke

        Command $fcomb$, simillarly to  $w\underline{~}comb$, gives us
general form of an arbitrary combination of superfunctions modulo
divergence terms.
It is four argument command with the same meaning of
arguments as in  $w\underline{~}comb$ case. This command first calls
$w\underline{~}comb$, then eliminates in the canonical way
SuSy - derivatives, by integrations by parts of $w\underline{~}comb$.
By canonical we understand that (SuSy) derivatives are removed first
from the superfunction which is first in the list of superfuctions
in fcomb command,  next from  second etc.

In order to illustrate cannonical manner of elimination
of (SuSy) derivatives let us consider some expression which is
constructed from  f, g and h superfunctions and their (SuSy) derivatives.
This expression is first splited onto three subexpression called
$f-expression, g-expression $ and $h-expression$.
$F-expression$ contains  only  combinations of f with
f or g or (and) h, while $g-expression$  contains only  combinations
of g with g or h and last $h-expresion$ contains  only  combinations of
h with h. Command $fcomb$ removes first (SuSy) derivatives from f in f-exprssion,
next from g in g-expression, and finally from h in h-expression.
Let us present such situation on the following example
\be
                fer(f,1,0)*fer(g,2,0) +bos(g,0,0)*bos(g,3,0).
\ee
Let us now assume that we have $ f,g $ order then $ f-expression $ is
$ fer(f,1,0)*fer(g,2,0) $, while $g-expression$ is $ bos(g,0,1)*bos(g,3,0) $.
Now canonical elimination gives us
\be
       - bos(f,0,0)*bos(g,3,0) + 2*bos(g,0,0)*bos(g,3,1),
\ee
while assuming $ g,f $ order we obtain
\be
       - bos(f,3,0)*bos(g,0,0) +2*bos(g,0,0)*bos(g,3,1)
\ee
Example
\pe
 fcomb( \{\{u,1\}\},4,h) &=>& h(1)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0) +\cr
           && h(2)*bos(u,3,0)*bos(u,0,0)^2 + \cr
            && h(3)*bos(u,0,2)*bos(u,0,0)  +\cr
                         &&   h(4)*bos(u,0,0)^4;
\ke

Finally, comand $pse\underline{~}ele$ gives us the general form of
element which belongs to algebra of pseudo-SuSy derivative
algebra [3].
Such element can be symbolically written down as
\be
         ( bos + fer*der(1)+fer*der(2)+bos*der(1)*der(2))*d(1)^n,
\ee
for the traditional and ``chiral'' representation while for ``chiral1''
as
\be
        ( bos + fer*der(1)+fer*der(2)+bos*der(3))*d(1)^n,
\ee
where at the moment, $ bos $ and $ fer $ denotes some  an arbitrary
superfunctions.
The mentioned command  allows us to obtain such element
of the given gradation
which is constructed from some set of superfunctions of given
gradation.  This command is three arguments.
\be
        {\bf pse\underline{~}ele}(wx,wy,wz),
\ee
First index denotes the gradation of SuSy-pseudo-element.
Second the names and gradations of the superfunctions from which we would
like to construct  our element. This second index $ wy $ is in the form of list
exactly the same as in the $ w\underline{~}comb $ command.
Last index denotes
the names which enumerates the free parameters in our combination.
\vspace{0.9cm}

B) Parts of the pseudo-SuSy-differential elements.

In order to obtain the components of the (pseudo)-SuSy element we have
three different commands:
\pe
       {\bf s\underline{~}part}(expression,n),  \\
       {\bf d\underline{~}part}(expression,m),  \\
       {\bf sd\underline{~}part}(expression,n,m),
\ke
where  n,m=0,1,2,3,....

The $s\underline{~}part$ gives us  coefficient standing in n-th SuSy
derivative. However notice, that for n=3 we should consider the coefficients
standing in the $der(1)*der(2) $ operator for the traditional or chiral
representations while for the chiral1 representation the terms standing in
the $der(3)$ operator. The
$d\underline{~}part$ command give us the coefficients
standing in  same power of d(1), while $sd\underline{~}part$ the term
standing in  n-th SuSy derivative and m-th power of usual derivative.

Example:
\pe
ala: &=& bos(g,0,0)+fer(f,3,0)*der(1)+ (fer(h,2,0)*der(2)+\cr
&& bos(r,0,0)*der(1)*der(2))*d(1);\\
s\underline{~}part(ala,3) & => & fer(f,3,0);\\
        d\underline{~}part(ala,1) &=>& fer(h,2,0)*der(2)+\cr
                && bos(r,0,0)*der(1)*der(2);\\
        sd\underline{~}part(ala,0,0) &=>& bos(g,0,0);
\ke
\vspace{0.9cm}

C) Adjoint.

        The adjoint of some SuSy operator is defined in standard form as
\be
        << \alpha,PP*\beta >> = << \beta,PP^*\alpha >>
\ee
where $\alpha$ and $\beta$ are the test superboson functions, PP is the opertor
under consideration and $<< \alpha,\beta >>$ is a scalar product defined as
\be
        << \alpha, \beta >>= \int \alpha*\beta*d\theta_{1}*d\theta_{2}
\ee

where we use the Berezin integral definition [1]
\pe
        \int \theta_{i}*d\theta_{j} = \delta_{i,j}, \\
        \int d\theta_{i} =0.
\ke
For this operation we have  command
\be
        {\bf cp}(expression);
\ee
Examples:
\pe
        cp(der(1))  &=>& -der(1),\\
        cp(del(1)*fer(r,1,0)*der(1))   & =>& fer(r,1,1)+fer(r,1,0)*d(1) -\cr
                                             &&  del(1)*bos(r,0,1),
\ke

From the last example there  follows that it is possible to
define $ cp(del(1)*fer(r,1,0)*der(1))$ in the different but equivalent
manner
namely as $fer(r,1,0)*d(1) - bos(r,0,1)*der(1)$.

From the practical point of view,  we do not define the conjugation for
the $d(-1)$ and $d(-2)$ operators, because then
we should define the precision of the action of the operators $d(-1)$ or
$d(-2)$ and even then, we would obtain very complicated formulas. However,
if somebody decides to use this conjugation to the $d(-1)$ or to the $d(-2)$,
it is recommended, first to change by hand, these operators on $d(-3)$, next
to compute $cp$ and change once more $d(-3)$ into $d(-1)$ or $d(-2)$ together
with the declaration of the precision.
\vspace{0.9cm}

D) Projection.

        In many cases, especially in SuSy approach to soliton theory
we have to obtain projection onto the invariant subspace (with respect
to commutator) of algebra of  pseu\-do-Su\-Sy-di\-ffe\-rential algebra.
There are three different subspaces [4] and hence we have two argument
command
\be
        {\bf rzut}(expression,n)
\ee
in which n=0, 1, 2.

Example
\pe
ewa: &=& (bos(f,0,0)+fer(f1,1,0)*der(1)+fer(f2,2,0)*der(2)+\cr
             &&  bos(f3,0,0)*der(1)*der(2))+ (bos(g,0,0)+ \cr
             && fer(g1,1,0)*der(1)+fer(g2,2,0)*der(2)+ \cr
               && bos(g3,0,0)*der(1)*der(2))*d(1),\\
        rzut(ewa,0) & =>& ewa,\\
        rzut(ewa,1) & =>& ewa-bos(f,0,0);\\
        rzut(ewa,2) & =>& bos(f3,0,0)*der(1)*der(2)+
                        (fer(g1,1,0)*der(1) \cr
           && +fer(g2,2,0)*der(2)+ \cr
           &&  bos(g3,0,0)*der(1)*der(2))*d(1),
\ke
\vspace{0.9cm}

E) Analogon of coeff.

Motivated by practical applications, we constructed for our supersymmetric
functions three commands, which allow us to obtain the list of the same
combinations of some superfunctions and (SuSy) derivatives from  some
given operator-valued expression.

    The first command is one argument
\be
        {\bf lyst}(expression)
\ee
with the output in the form of list.

Example
\pe
        magda:=fer(f,1,0)*fer(f,2,0)*a1 + der(1),\\
        lyst(magda) => \{fer(f,1,0)*fer(f,2,0)*a1, der(1) \},
\ke

    The second command is also one argument
\be
        {\bf lyst1}(expression)
\ee
with the output in the form of list in which each element is constructed
from  coefficients and (SuSy) operators of corresponding element in
$lyst$ list. For example
\be
        lyst1(magda) => \{ a1,der(1) \},
\ee

        The third command is also one argument
\be
        {\bf lyst2}(expression)
\ee
with the output in the form of list in which each element is constructed
from coefficients standing in the given expression. For exampla
\be
        lyst2(magda) => \{a1,1\}
\ee
\vspace{0.9cm}

F) Simplifications.

        If we encounter during the process of computations such
expression
\be
        fer(f,1,0)*d(-3)*fer(f,2,0)*d(1)
\ee
it is not reduced further. On the other side we can replace $d(1)$ onto
$d(2)$ and back $d(2)$ onto $d(1)$. In order to do such replacement we
have the command
\be
        {\bf chan}(expression)
\ee
Example
\pe
        && chan(fer(f,1,0)*d(-3)*fer(f,2,0)*d(1)) => \cr
        && -fer(f,2,0)*fer(f,1,0) - fer(f,1,0)*d(-3)*fer(f,2,1).
\ke
Notice that as the result we kill the d(1) operation.
\vspace{0.9cm}

G) O(2) invariance.

In many cases in the supersymmetric theories we deal with the O(2)
invariance of SuSy indices. This invariance follows from the physical
assumption on the nonprivileging the "fermionic" coordinates in the
superspace. In order to check whether our formula posseses such
invariance we can use
\be
        {\bf odwa}(expression)
\ee
This procedure replaces in the given expresion $der(1)$ onto $-der(2)$ and
$der(2)$ onto $der(1)$. Next, it changes, in the same manner, the values
of the action of these operators on the superfunctions.
\vspace{0.9cm}

F) Macierz

Similarly to the representation of the superfunctions in the components
We can define the supercomponent form for the $pse\underline{~}ele$ objects
similarly to the representation of the supersfunctions. Usually we can
consider such object as the matrix which acts on the components of the
superfunctions.It is realized in our program using the command :
\be
        {\bf macierz}(expression,x,y),
\ee
where expression is the formula under consideration while x can take
two values f or b depending wheather we would like to conside bosonic
(b) part or fermionic (f) part of the expression. Last index in this
command denotes the option in which we acts on the bosonic or fermionic
superfunction. It takes two values f- for fermionic test superfunction
or b - for bosonic case. More explicitely we obtain
\pe
macierz(der(1)*der(2),b,f) =\pmatrix{0 & 0 & 0 & 0 \cr
                0 & 0 & d(1) & 0 \cr
                0 & -d(1) & 0 & 0 \cr
                -d(1)**2 & 0 & 0 & 0 } \\
macierz(der(1)*der(2),f,b)= \pmatrix {
                0 & 0 & 0 & 0 \cr
                0 & 0 & 0 & d(1) \cr
                -d(1) & 0 & 0 & 0 \cr
                0 & 0 & 0 & 0 } .
\ke
\section{Functional gradients.}

        In  SuSy soliton approach we very frequently encounter
problem of computing the gradient of the given functional.
The usual definition of the gradient [2] is adopted, in the supersymmetry
also.
\pe
        H^{'}[v] = < grad H ,v > , \\
        H^{'}[v] = \frac{\partial}{\partial \epsilon} H(u+\epsilon v)
        \mid_{\epsilon=0},
\ke
where $ H $ denotes some functional which depends on u. v denotes
vector under which we compute the gradient and $ <,> $ the relevant
scalar product.

We implemented all that in our package for the ``tradicional '' algebra
only. In order to compute the gradient with respect to some superfuction
use
\be
        {\bf gra}(expression,f),
\ee
where "expression" is the given density of the functional, while f denotes
the first index in the superfunction ( name of the superfunction).

Example
\be
        gra(bos(f,3,0)*fer(f,1,0),f) => -2*fer(f,2,1)
\ee
For practical use we perform two additional commands:
\pe
        {\bf dyw}(expression,f) \\
        {\bf war}(expression,f).
\ke
The first computes the variation of expression with respect to
superfunction f, next  removes (via integrations by parts) SuSy-
derivatives from  varied functions and finally produces  list
of factorized $fer$ and $bos$ superfunctions. When the given expression
is full (SuSy)-derivative,  the result of the dyw command is 0 and hence
this command is very usefull in verifications of (SuSy)-divergences of
expressions.

When result of applications of dyw command is not zero
then we would like to have the system of equations on the coefficients
standing in the same factorized $fer$ and $bos$ superfunction. We can quickly
obtain such list using command $war(expression,f)$ with the same
meaning of arguments as in the $dyw$ command.

Examples
\be
        xxx:=fer(f,1,0)*fer(f,2,0)+x*bos(f,3,0)^2;
\ee
\pe
        dyw(xxx,f) &=>& \{ -2*bos(f,3,0)*bos(f,0,0),\cr
        && -2*x*bos(f,0,2)*bos(f,0,0) \}
\ke
\be
        war(xxx,f) => \{-2,-2*x \}.
\ee

\section{Conservation Laws.}
        In many cases we would like to know whether the given expression is
a conservation law for some Hamiltonian equation. We can quikly check it
using
\be
        {\bf dot\underline{~}ham}( {equation},expression)
\ee
where "equation"  is a set of two elements list in which
first element denotes the function while the second its flow.
The second argument should be understand as the density of some
conserved current. For example, for SuSy version of the Nonlinear
Schrodinger Equation  [7] we obtain
\pe
        ew: &=& \{ \{q,-bos(q,0,2)+bos(q,0,0)^3*bos(r,0,0)^2 -\cr
              &&  2*bos(q,0,0)*pr(3,bos(q,0,0)*bos(r,0,0)) \},\cr
              &&\{ r,bos(r,0,2)-bos(q,0,0)^2*bos(r,0,0)^3+\cr
               && 2*bos(r,0,0)*pr(3,bos(q,0,0)*bos(r,0,0)) \} \},\\
        ham: &=& bos(q,0,1)*bos(r,0,0)+x*bos(q,0,0)^2*bos(r,0,0)^2,\\
        yyy: &=& dot\underline{~}ham(ew,ham).
\ke

As the result of previous computations we have a complicated expression
which is not zero. We woulld like to interpreted it as a
full (SuSy)-divergence  and we can quickly verify it, if we use command
$war$. We can solve, obtained list of equations, using known techniques.
For example, in our previous case we obtain
\be
        war(yyy,q) => \{ -4*x,-8*x,-4*x \};
\ee
\be
        war(yyy,r) => \{ 4*x,8*x,4*x \};
\ee
and we conclude that our ham is a constant of motion if x=0.


        It is also possible to use command $dot\underline{~}ham$ to
the pseudo-SuSy-differential element what is very useful in SuSy
approach to Lax operator in which we would like to check
validity of the formula

\be
        \partial_{t}*L:=[ L,A ].
\ee
where $ A $ is a some (SuSy) operator.



\section{Jacobi Identity.}
        The Jacobi identity for some SuSy - hamiltonian operators is verified
using the relation
\be
        << \alpha , P^{`}_{(P\beta)}*\gamma >> + cyclic{~}permutation(
        \alpha,\beta,\gamma),
\ee
where $P^{`}$ denotes the directional derivative along the $P(\beta)$ vector
and $<< , >>$  scalar product. Directional derivative is defined
in the standard manner as [44]
\be
        F^{'}(u)[v] = \frac{\partial}{\partial \epsilon}
        F(u+\epsilon v)\mid_{\epsilon =0},
\ee
where $ F $ is some functional depending on u. V is a directional vector.

In this package we have several commands which allow us to
verify the Jacobi identity.
We have the possibility to compute, indenpendently  of veryfing Jacobi
identity, directional derivative for the given Hamiltonian operator along
the given vector using
\be
                {\bf n\underline{~}gat}( pp, wim )
\ee
where pp is scalar or matrix Hamiltonian operator. $ Wim $  denotes
components of a vector along which we compute derivative and has the
form of list in which each element has following representation
\be
        bos(f) => .
\ee
The $ bos(f) $, in the last formula, denotes the shift of  $ bos(f,0,0) $
superfunction according to definition of directional derivative.

In order to compute Jacobi identity use command
\be
        {\bf fjacob}( pp, wim),
\ee
with the same meaning of $pp$ and $wim$ as in $n\underline{~}gat$ command.

Notice that ordering of components in  $wim$ list is important and
is connected with interpretation of components of Hamiltonian operator
$pp$ as a set of Poisson brackets constructed just from elements of $ wim $
list.
For example, in our scheme, first component of wim is always connected
with element, from which we create  Poisson bracket and  which
corresponds to first element on the diagonal of pp, second element of
$ wim $ with second element on diagonal of $pp$ and etc.

As the result of applications of $ fjacob $ command to some Hamiltonian
operator we obtain a complicated formula, not necesarily equal to zero but
which would be expressed as (SuSy) divergence. However, we can quickly
verify it using the same method as in $ dot\underline{~}ham $ command
which has been described in previous section.

Usually, after the application of the $ fjacob $  command to some matrix
Hamiltonian operator we obtain the hudge expression which is too complicated
to analyze even when we would like to check its (SuSy)divergence. In this case
we could extract from $fjacob$ expression terms containing given
components of vector test functions fixed by us. We can use in this
order command
\be
                {\bf jacob}(pp,wim,mm)
\ee
where $ pp $ and $ wim $ has the same meaning as in $ fjacob $ case while
$ mm $ is a three elements list denoting the components of
${\alpha,\beta,\gamma}$.

This command is not prepered to compute in full the Jacobi identity,
which contains the integrations operators. We do not implement here the
symbolic integrations of superfunctions in order to simplify the final results.
\newpage

\section{The list of Objects, Commands and Switches}

Objects:
\vspace{0.6cm}

\begin{tabular}{ c  c  c  c  c  c }
& {\bf bos}(f,n,m) & {\bf bos}(f,n,m,k) & {\bf fer}(f,n,m) & {\bf axp}(f)
& {\bf fun}(f,n)  \cr
& {\bf fun}(f,n,m)   & {\bf gras}(f,n)  & {\bf axx}(f)  & {\bf d}(1)
& {\bf d}(2)  \cr
& {\bf d}(3)         & {\bf d}(-1)      & {\bf d}(-2)   & {\bf d}(-3)
& {\bf d}(-4) \cr
& {\bf dr}(-n) & {\bf der}(1)  & {\bf der}(2) & {\bf del}(1) & {\bf del}(2)
\end{tabular}
\vspace{0.3cm}


\noindent Commands
\vspace{0.5cm}

\flushleft
{\footnotesize
\begin{tabular}{ l l l l }
 {\bf fpart}(expression) & {\bf bpart}(expression) &
 {\bf bf\underline{~}part}(expression,n) \cr
 {\bf b\underline{~}part}(expression,n) & {\bf pr}(n,expression) &
 {\bf pg}(n,expression) \cr
 {\bf w\underline{~}comb}
(\{ \{ f,n,x
\},...\} ,m,z,y) &
{\bf fcomb}
(\{ \{ f,n,x
\},...\},m,z,y) &
{\bf pse\underline{~}ele}
(n,\{ \{ f,n \},... \},z) \cr
 {\bf s\underline{~}part}(expression,n) &
{\bf d\underline{~}part}(expression,n) & {\bf sd\underline{~}}(expression,n,m) \cr
 {\bf cp}(expression) & {\bf rzut}(expression,n) & {\bf lyst}(expression) \cr
 {\bf lyst1}(expression) & {\bf lyst2}(expression) & {\bf
chan}(expression) \cr
 {\bf odwa}(expression) & {\bf gra}(expression,f) & {\bf
dyw}(expression,f) \cr
 {\bf war}(expression,f) & {\bf dot\underline{~}ham}(equations,expression)&
{\bf n\underline{~}gat}(operator,list) \cr
{\bf fjacob}(operator,list) & {\bf jacob}(operator,list,\{
$\alpha,\beta,\gamma$ \})& {\bf macierz}(expression,x,y) \cr  
{\bf s\underline {~} int}( numbers, expession,list) & &
\end{tabular}
}
\vspace{0.3cm}


\noindent Switches
\vspace{0.3cm}

\begin{tabular}{ c c c c c c c}
& \bf trad & \bf chiral & \bf chiral1   {~}\bf inverse & \bf drr & \bf nodrr
\end{tabular}

\section{Acknowledgement}
        The author would like to thank to dr. W.Neun for valuable remarks.


\begin{thebibliography}{99}

\item{} J.Wess and J.Bagger, ``Supersymmetry and Supergravity''
        (Princeton, NJ 1982 );

\item{} S.Ferrara and J.G.Taylor ``Introduction to Supergravity''
        ( Moscow 1985 ).

\item{}  L.Faddeev and L.Takhtajan ``Hamiltonian Methods in the Theory of
        Solitons '' (Springer-VerlaG 1987); A.Das ``Integrable Models'' (World
        Sci.1989); M.Ablowitz and H.Segur ``Solitons and the Inverse
        Scattering Transform'' (SIAM Philadelphia 1981).

\item{}  A.Polyakov in ``Fields, Strings and critical Phenomena'' ed.E.Brezin and
        J.Zinn-Justin, (North Holland 1989).


\item{}   S.Manakov, S.Novikov, L.Pitaevski and V.Zakharov ``Soliton Theory: The
        Inverse Problem'' (Nauka, Moscow (1980).

\item{}  L.A.Dickey ``Soliton Equations and Hamiltonian Systems'', (World
        Scientific, Singapore 1991).

\item{}  E.Date, M.Jimbo, M.Kashiwara and T.Miwa, in ``Nonlinear Integrable
        Systems - Classical and Quantum Theory'', ed. by M.Jimbo and
        T.Miwa , (World Scientific, Singapore 1983) p. 39.


\item{} B.Kupershmidt, ``Elements of Superintegrable Systems''(Kluwer 1987).

\item{} M.Chaichian, P.Kulish Phys.Lett.18B (1978) 413.

\item{} R.D'Auria and S.Sciuto, Nucl. Phys. B.171 (1980) 189.

\item{} M.Gurses and O.Oguz, Phys.Lett.108A (1985) 437.

\item{} Y.Manin and R.Radul, Commun.Math.Phys. 98 (1985) 65 .


\item{} C.Morosi and L.Pizzochero, Commun.Math.Phys. 158 (1993) 267 .

\item{} C.Morosi and L.Pizzochero, J.Math.Phys.35 (1994) 2397.

\item{} C.Morosi and L.Pizzochero  ''A Fully Supersymmetric AKNS Theory ''
        preprint of Dipartimento di Matematica,Politecnico di Milano.
        April 1994, to appeare in Commun.math.Phys.(1995).

\item{} P.Mathieu, J.Math.Phys.29 (1988) 2499.

\item{} C.A.Laberge and P.Mathieu, Phys.Lett.215B (1988) 718 .

\item{} P.Labelle and P.Mathieu, J.Math.Phys.32 (1991) 923 .

\item{} M.Chaichian and J.Lukierski, Phys.Lett. 183B (1987) 169 .

\item{} T.Inami and H.Kanno, Commun.Math.Phys. 136 (1991) 519 .

\item{} S.K.Nam, Intern.J.Mod.Phs.4 (1989) 4083.

\item{} K.Hiutu and D.Nemeschansky, Mod.Phys.Lett.A. 6 (1991) 3179.

\item{} C.M.Yung, Phys.Lett. 309B (1993) 75.

\item{} E.Ivanov and S.Krivons, Phys.Lett.291B (1992) 63.

\item{} P.Kulish Lett.Math.Phys.10 (1985) 87.

\item{} G.H.M.Roelofs and P.H.M. Kersten Journ. Math.Phys.33 (1992) 2185 .

\item{} J.C.Brunelli and A.Das, Journ.Math.Phys.36 (1995) 268.

\item{} F.Toppan, Int.Journ.Mod.Phys.A10 (1995) 895.

\item{} S.Krivonos and A.Sorin ``The minimal N=2 superextension of the NLS
        equation'' hep-th/9504084 to appeare in Phys.lett.B.

\item{} S.Krivonos, A.Sorin and F.Toppan `` On the Super-NLS Equation and its
        Relation with N=2 Super-KdV within Coset Approach'' hep-th/9504138.

\item{} W.Oevel and Z.Popowicz, Commun.Math.Phys. 139 (1991) 441.

\item{} Z.Popowicz J.Phys.A:Math.Gen. 19 (1986) 1495.

\item{} Z.Popowicz J.Phys.A:Math.Gen. 23 (1990) 1127.

\item{} Z.Popowicz Phys.Lett.319B (1993) 478.

\item{} Z.Popowicz Phys.Lett. 174A (1993) 411.

\item{} Z.Popowicz Int.Jour.Mod.Phys. 9 (1994) 2001.

\item{} Z.Popowicz Phys.Lett. 194A (1994) 375.

\item{} Z.Popowicz J.Phys.A.Math.Gen. 29 (1996) 1281.

\item{} M.Olshanetsky, Comm.Math.Phys. 88 (1983) 63.

\item{} J.Evans and T.Hollowood, Nucl.Phys. B352 (1991) 723.

\item{} A.C.Hearn ``R E D U C E user's manual 3.6'' (Rand.Publ.1995).

\item{} P.K.H.Gragert and P.H.M.Kersten  ``Liesuper''  ftp.math.utwente.nl/pub/rweb /appl/lisuper.web

\item{} S.Krivonos and K.Thielmans ``A Mathematica Package for Computing N=2
    Superfield Opeerator Product Expansion'', Preprint Imperial College
    London TP  95-96/13 or hep-th/9512029.

\item{} B.Fuchssteiner and A.S.Fokas, Physica 4D (1981) 718.

\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/susy2/susy2.red0000644000175000017500000021367311526203062023366 0ustar  giovannigiovannimodule susy2;
%version 1.2
%changes and bugs compare to version 1.0
%8.12.1996
%vericication of cp,axp;
%12.05.1997
%lyst in order to consider  n(0)*d(1)^3+m(0)*d(1)^3;
%10.09.1997
%verification of jacob(wx,wx1,wx2) i fjacob
%1.10.1997
%introduction  chiral1 and
%b_chiral,f_chiral,b_antychiral,f_antychiral
%introduction  lyst2
%introduction of matrix(expression,boson or fermion, full or boson sector)
%3.10.1997
%verification of coordinates
%6.10.1997
%verification of wcomb,fcomb;
%19.04.1999
%changes and bugs compare to version 1.1
%new command s_int

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;
operator !@f_f,!@g_g,newton,delta,b_part,bf_part,pg,chan,s_part,prykr,prykl;
operator bos,fer,der,del,d,axp,axx,zan,zen,fun,tet,gras,ber,fir,berz,firr,dr,
stp,byk,r_r,!&a,p_p,s_s,waga;
noncom   bos,fer,der,del,d,axp,axx,zan,zen,fun,tet,gras,ber,fir,berz,firr,dr,
stp,byk,r_r;
factor !&a,byk;
factor fer,bos,fun,gras;
%fer,bos,axp superfunctions
%der,del,d,dr operations
%zan,zen needs to divergency
%fun,tet,gras,axx classical part
%stp to adjoint
%ber,fir,berz,firr corresponds to Gato
%byk,r_r,!&a,p_p,s_s,waga for super integration
%*******************************************%
%*** declaration of chirality and **********%
%*** cutoff and drr ************************%
%*******************************************%
chiral:={ abra_kadabra => 1 ,
der(~n)**2 => 0, del(~n)**2 => 0,del(2)*del(1) => - d(1) - del(1)*del(2),
der(2)*der(1) => -d(1) - der(1)*der(2),der(~n)*del(~n) => 0,
del(~n)*der(~n) => 0,der(1)*del(2)=> -d(1) - del(2)*der(1),
der(2)*del(1)=> -d(1) - del(1)*der(2),
%b_chiral,f_chiral,b_antychiral,f_antychiral as lists
b_chiral => {}, f_chiral => {}, b_antychiral => {}, f_antychiral => {},
fer(~f,1,~m) => 0 when not freeof(b_chiral,f),
bos(~f,3,~m) => -bos(f,0,m+1) when not freeof(b_chiral,f),
bos(~f,3,~m,~k) => (-1)**k*bos(f,0,m+1,k) when not freeof(b_chiral,f),

bos(~f,1,~m) => 0 when not freeof(f_chiral,f),
bos(~f,1,~m,~k) => 0 when not freeof(f_chiral,f),
fer(~f,3,~m) => -fer(f,0,m+1) when not freeof(f_chiral,f),

fer(~f,2,~m) => 0 when not freeof(b_antychiral,f),
bos(~f,3,~m) => 0 when not freeof(b_antychiral,f),
bos(~f,3,~m,~k) => 0 when not freeof(b_antychiral,f),

bos(~f,2,~m) => 0 when not freeof(f_antychiral,f),
bos(~f,2,~m,~k) => 0 when not freeof(f_antychiral,f),
fer(~f,3,~m) => 0 when not freeof(f_antychiral,f),

der(1)*fer(~f,1,~m) =>  - fer(f,1,m)*der(1),
der(1)*fer(~f,2,~m) => bos(f,3,m) -  fer(f,2,m)*der(1),
der(1)*fer(~f,3,~m) => - fer(f,3,m)*der(1),
fer(~f,1,~m)*del(1) =>  - del(1)*fer(f,1,m),
fer(~f,2,~m)*del(1) => bos(f,3,m) -  del(1)*fer(f,2,m),
fer(~f,3,~m)*del(1) =>  - del(1)*fer(f,3,m),
der(2)*fer(~f,1,~m) => -bos(f,0,m+1) - bos(f,3,m) - fer(f,1,m)*der(2),
der(2)*fer(~f,2,~m) =>  - fer(f,2,m)*der(2),
der(2)*fer(~f,3,~m) => -bos(f,2,m+1)-fer(f,3,m)*der(2),
fer(~f,1,~m)*del(2) => -bos(f,0,m+1) - bos(f,3,m) - del(2)*fer(f,1,m),
fer(~f,2,~m)*del(2) =>   - del(2)*fer(f,2,m),
fer(~f,3,~m)*del(2) => -bos(f,2,m+1)-del(2)*fer(f,3,m),
der(1)*bos(~f,1,~m) =>  bos(f,1,m)*der(1),
der(1)*bos(~f,2,~m) => fer(f,3,m) + bos(f,2,m)*der(1),
der(1)*bos(~f,3,~m) =>  bos(f,3,m)*der(1),
bos(~f,1,~m)*del(1) =>  del(1)*bos(f,1,m),
bos(~f,2,~m)*del(1) => -fer(f,3,m)+del(1)*bos(f,2,m),
bos(~f,3,~m)*del(1) =>  del(1)*bos(f,3,m),
der(2)*bos(~f,1,~m) => -fer(f,0,m+1) - fer(f,3,m) + bos(f,1,m)*der(2),
der(2)*bos(~f,2,~m) =>  bos(f,2,m)*der(2),
der(2)*bos(~f,3,~m) => -fer(f,2,m+1) + bos(f,3,m)*der(2),
bos(~f,1,~m)*del(2) => fer(f,0,m+1) + fer(f,3,m) + del(2)*bos(f,1,m),
bos(~f,2,~m)*del(2) =>  del(2)*bos(f,2,m),
bos(~f,3,~m)*del(2) => fer(f,2,m+1) + del(2)*bos(f,3,m),
der(1)*bos(~f,1,~m,~l) =>  bos(f,1,m,l)*der(1),
der(1)*bos(~f,2,~m,~l) => l*fer(f,3,m)*bos(f,2,m,l-1)+bos(f,2,m,l)*der(1),
der(1)*bos(~f,3,~m,~l) =>  bos(f,3,m,l)*der(1),
bos(~f,1,~m,~l)*del(1) =>  del(1)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(1) => -l*fer(f,3,m)*bos(f,2,m,l-1)+del(1)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(1) =>  del(1)*bos(f,3,m,l),
der(2)*bos(~f,1,~m,~l) => -l*(fer(f,0,m+1)+fer(f,3,m))*bos(f,1,m,l-1) +
                       bos(f,1,m,l)*der(2),
der(2)*bos(~f,2,~m,~l) =>  bos(f,2,m,l)*der(2),
der(2)*bos(~f,3,~m,~l) => -l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       bos(f,3,m,l)*der(2),
bos(~f,1,~m,~l)*del(2) => l*(fer(f,0,m+1)+fer(f,3,m))*bos(f,1,m,l-1) +
                       del(2)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(2) => del(2)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(2) => l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       del(2)*bos(f,3,m,l)}$

chiral1:={abra_kadabra => 3 ,
%der(3) as commutator,bos(f,3,n) or fer(f,3,4) as commutator
der(~n)**2 => 0 when n neq 3, del(~n)**2 => 0 when n neq 3,
der(3)^2 => d(1)^2,   del(3)^2 => d(1)^2,

der(2)*der(1) => -(d(1)+der(3))/2,der(1)*der(2) => (-d(1)+der(3))/2,
del(2)*del(1) => -(d(1)+del(3))/2,del(1)*del(2) => (-d(1)+del(3))/2,
der(1)*der(3) => d(1)*der(1),  der(2)*der(3) => -d(1)*der(2),
der(3)*der(1) => -d(1)*der(1), der(3)*der(2) =>  d(1)*der(2),
del(1)*del(3) => d(1)*del(1),  del(2)*del(3) => -d(1)*del(2),
del(3)*del(1) => -d(1)*del(1), del(3)*del(2) =>  d(1)*del(2),
der(~n)*del(~n) => if n neq 3 then 0 else if n = 3 then d(1)^2,
del(~n)*der(~n) => if n neq 3 then 0 else if n = 3 then d(1)^2,
der(1)*del(2) => -d(1) -del(2)*der(1),der(2)*del(1) => -d(1) -del(1)*der(2),
der(1)*del(3) => d(1)*del(1), der(2)*del(3) => -d(1)*del(2),
b_chiral => {}, f_chiral => {}, b_antychiral => {}, f_antychiral => {},
fer(~f,1,~m) => 0 when not freeof(b_chiral,f),
bos(~f,3,~m) => -bos(f,0,m+1) when not freeof(b_chiral,f),
bos(~f,3,~m,~k) => (-1)**k*bos(f,0,m+1,k) when not freeof(b_chiral,f),

bos(~f,1,~m) => 0 when not freeof(f_chiral,f),
bos(~f,1,~m,~k) => 0 when not freeof(f_chiral,f),
fer(~f,3,~m) => -fer(f,0,m+1) when not freeof(f_chiral,f),

fer(~f,2,~m) => 0 when not freeof(b_antychiral,f),
bos(~f,3,~m) => bos(f,0,m+1) when not freeof(b_antychiral,f),
bos(~f,3,~m,~k) => bos(f,0,m+1,k) when not freeof(b_antychiral,f),

bos(~f,2,~m) => 0 when not freeof(f_antychiral,f),
bos(~f,2,~m,~k) => 0 when not freeof(f_antychiral,f),
fer(~f,3,~m) => fer(f,0,m+1) when not freeof(f_antychiral,f),

der(1)*fer(~f,1,~m) =>  - fer(f,1,m)*der(1),
der(1)*fer(~f,2,~m) => -bos(f,0,m+1)/2+bos(f,3,m)/2 -  fer(f,2,m)*der(1),
der(1)*fer(~f,3,~m) =>  bos(f,1,m+1)-fer(f,3,m)*der(1),

fer(~f,1,~m)*del(1) =>  - del(1)*fer(f,1,m),
fer(~f,2,~m)*del(1) => -bos(f,0,m+1)/2 + bos(f,3,m)/2 -  del(1)*fer(f,2,m),
fer(~f,3,~m)*del(1) =>  bos(f,1,m+1) - del(1)*fer(f,3,m),

der(2)*fer(~f,1,~m) => -bos(f,0,m+1)/2 - bos(f,3,m)/2 - fer(f,1,m)*der(2),
der(2)*fer(~f,2,~m) =>  - fer(f,2,m)*der(2),
der(2)*fer(~f,3,~m) => -bos(f,2,m+1)-fer(f,3,m)*der(2),

fer(~f,1,~m)*del(2) => -bos(f,0,m+1)/2 - bos(f,3,m)/2 - del(2)*fer(f,1,m),
fer(~f,2,~m)*del(2) =>   - del(2)*fer(f,2,m),
fer(~f,3,~m)*del(2) => -bos(f,2,m+1)-del(2)*fer(f,3,m),

der(3)*fer(~f,0,~m) => fer(f,3,m) + fer(f,0,m)*der(3) - 2*bos(f,1,m)*der(2)
                        + 2*bos(f,2,m)*der(1),
der(3)*fer(~f,1,~m) => -fer(f,1,m+1) - bos(f,0,m+1)*der(1) -bos(f,3,m)*der(1)
                        +fer(f,1,m)*der(3),
der(3)*fer(~f,2,~m) =>  bos(f,0,m+1)*der(2) - bos(f,3,m)*der(2) + fer(f,2,m+1)
                        +fer(f,2,m)*der(3),
der(3)*fer(~f,3,~m) => fer(f,0,m+2) + fer(f,3,m)*der(3)
                        -2*bos(f,1,m+1)*der(2)-2*bos(f,2,m+1)*der(1),

fer(~f,0,~m)*del(3) =>  fer(f,3,m)+ del(3)*fer(f,0,m) + 2*del(2)*bos(f,1,m)
                        - 2*del(1)*bos(f,2,m),
fer(~f,1,~m)*del(3) => -fer(f,1,m+1)+ del(1)*bos(f,0,m+1) +
                del(1)*bos(f,3,m) + del(3)*fer(f,1,m),
fer(~f,2,~m)*del(3) => - del(2)*bos(f,0,m+1) +del(2)*bos(f,3,m) +fer(f,2,m+1)
                        +del(3)*fer(f,2,m),
fer(~f,3,~m)*del(3) => fer(f,0,m+2) + del(3)*fer(f,3,m)
                        + 2*del(2)*bos(f,1,m+1) + 2*del(1)*bos(f,2,m+1),

der(1)*bos(~f,1,~m) =>  bos(f,1,m)*der(1),
der(1)*bos(~f,2,~m) => -fer(f,0,m+1)/2 + fer(f,3,m)/2 + bos(f,2,m)*der(1),
der(1)*bos(~f,3,~m) =>  fer(f,1,m+1) + bos(f,3,m)*der(1),

bos(~f,1,~m)*del(1) =>  del(1)*bos(f,1,m),
bos(~f,2,~m)*del(1) => fer(f,0,m+1)/2 - fer(f,3,m)/2 +del(1)*bos(f,2,m),
bos(~f,3,~m)*del(1) =>  - fer(f,1,m+1) + del(1)*bos(f,3,m),

der(2)*bos(~f,1,~m) => -fer(f,0,m+1)/2 - fer(f,3,m)/2 + bos(f,1,m)*der(2),
der(2)*bos(~f,2,~m) =>  bos(f,2,m)*der(2),
der(2)*bos(~f,3,~m) => -fer(f,2,m+1) + bos(f,3,m)*der(2),

bos(~f,1,~m)*del(2) => fer(f,0,m+1)/2 + fer(f,3,m)/2 + del(2)*bos(f,1,m),
bos(~f,2,~m)*del(2) =>  del(2)*bos(f,2,m),
bos(~f,3,~m)*del(2) => fer(f,2,m+1) + del(2)*bos(f,3,m),

der(3)*bos(~f,0,~m) => bos(f,3,m) + bos(f,0,m)*der(3) + 2*fer(f,1,m)*der(2)
                        -2*fer(f,2,m)*der(1),
der(3)*bos(~f,1,~m) => -bos(f,1,m+1) + fer(f,0,m+1)*der(1) + fer(f,3,m)*der(1)
                        + bos(f,1,m)*der(3),
der(3)*bos(~f,2,~m) =>  - fer(f,0,m+1)*der(2) + fer(f,3,m)*der(2)
                        + bos(f,2,m)*der(3) +bos(f,2,m+1),
der(3)*bos(~f,3,~m) => bos(f,0,m+2) + 2*fer(f,2,m+1)*der(1) +
                2*fer(f,1,m+1)*der(2) + bos(f,3,m)*der(3),

bos(~f,0,~m)*del(3) =>  bos(f,3,m) + del(3)*bos(f,0,m) + 2*del(2)*fer(f,1,m)
                        -  2*del(1)*fer(f,2,m),
bos(~f,1,~m)*del(3) => del(1)*fer(f,0,m+1) + del(1)*fer(f,3,m) -bos(f,1,m+1)
                        + del(3)*bos(f,1,m),
bos(~f,2,~m)*del(3) =>  -del(2)*fer(f,0,m+1) + del(2)*fer(f,3,m)
                        + del(3)*bos(f,2,m) +bos(f,2,m+1) ,
bos(~f,3,~m)*del(3) =>  bos(f,0,m+2) + 2*del(1)*fer(f,2,m+1) +
                2*del(2)*fer(f,1,m+1) + del(3)*bos(f,3,m),

der(1)*bos(~f,1,~m,~l) =>  bos(f,1,m,l)*der(1),
der(1)*bos(~f,2,~m,~l) => l*bos(f,2,m,l-1)*(-fer(f,0,m+1)/2 + fer(f,3,m)/2)
                + bos(f,2,m,l)*der(1),
der(1)*bos(~f,3,~m,~l) => l*bos(f,3,m,l-1)*fer(f,1,m+1) +
                         bos(f,3,m,l)*der(1),

bos(~f,1,~m,~l)*del(1) =>  del(1)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(1) => - l*bos(f,2,m,l-1)*(-fer(f,0,m+1)/2 + fer(f,3,m)/2)
                        +del(1)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(1) => - l*bos(f,3,m,l-1)*fer(f,1,m+1) +
                         del(1)*bos(f,3,m,l),

der(2)*bos(~f,1,~m,~l) => - l*bos(f,1,m,l-1)*(fer(f,0,m+1)/2+ fer(f,3,m)/2)
                      + bos(f,1,m,l)*der(2),
der(2)*bos(~f,2,~m,~l) =>  bos(f,2,m,l)*der(2),
der(2)*bos(~f,3,~m,~l) => -l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       bos(f,3,m,l)*der(2),

bos(~f,1,~m,~l)*del(2) => l*(fer(f,0,m+1)/2+fer(f,3,m)/2)*bos(f,1,m,l-1) +
                       del(2)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(2) => del(2)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(2) => l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       del(2)*bos(f,3,m,l),

der(3)*bos(~f,~k,~m,~l) =>
        der(1)*prykr(bos(f,k,m,l),2)-der(2)*prykr(bos(f,k,m,l),1),
bos(~f,~k,~m,~l)*del(3) =>
        -prykl(bos(f,k,m,l),2)*del(1)+prykl(bos(f,k,m,l),1)*del(2) }$

trad:={abra_kadabra => 2 ,
der(~n)**2 => d(1),del(~n)**2 => d(1),del(2)*del(1) => -del(1)*del(2),
der(2)*der(1) => -der(1)*der(2), der(~n)*del(~n) => d(1),
del(~n)*der(~n) => d(1), der(1)*del(2) => -del(2)*der(1),
der(2)*del(1) => -del(1)*der(2),
der(1)*fer(~f,1,~m) => bos(f,0,m+1) - fer(f,1,m)*der(1),
der(1)*fer(~f,2,~m) => bos(f,3,m) -  fer(f,2,m)*der(1),
der(1)*fer(~f,3,~m) => bos(f,2,m+1) - fer(f,3,m)*der(1),
fer(~f,1,~m)*del(1) => bos(f,0,m+1) - del(1)*fer(f,1,m),
fer(~f,2,~m)*del(1) => bos(f,3,m) -  del(1)*fer(f,2,m),
fer(~f,3,~m)*del(1) => bos(f,2,m+1) - del(1)*fer(f,3,m),
der(2)*fer(~f,1,~m) => -bos(f,3,m) - fer(f,1,m)*der(2),
der(2)*fer(~f,2,~m) => bos(f,0,m+1) - fer(f,2,m)*der(2),
der(2)*fer(~f,3,~m) => -bos(f,1,m+1)-fer(f,3,m)*der(2),
fer(~f,1,~m)*del(2) => -bos(f,3,m) - del(2)*fer(f,1,m),
fer(~f,2,~m)*del(2) =>  bos(f,0,m+1) - del(2)*fer(f,2,m),
fer(~f,3,~m)*del(2) => -bos(f,1,m+1)-del(2)*fer(f,3,m),
der(1)*bos(~f,1,~m) => fer(f,0,m+1) + bos(f,1,m)*der(1),
der(1)*bos(~f,2,~m) => fer(f,3,m)+bos(f,2,m)*der(1),
der(1)*bos(~f,3,~m) => fer(f,2,m+1) + bos(f,3,m)*der(1),
bos(~f,1,~m)*del(1) => -fer(f,0,m+1) + del(1)*bos(f,1,m),
bos(~f,2,~m)*del(1) => -fer(f,3,m)+del(1)*bos(f,2,m),
bos(~f,3,~m)*del(1) => -fer(f,2,m+1) + del(1)*bos(f,3,m),
der(2)*bos(~f,1,~m) => -fer(f,3,m) + bos(f,1,m)*der(2),
der(2)*bos(~f,2,~m) => fer(f,0,m+1) + bos(f,2,m)*der(2),
der(2)*bos(~f,3,~m) => -fer(f,1,m+1) + bos(f,3,m)*der(2),
bos(~f,1,~m)*del(2) => fer(f,3,m) + del(2)*bos(f,1,m),
bos(~f,2,~m)*del(2) => -fer(f,0,m+1) + del(2)*bos(f,2,m),
bos(~f,3,~m)*del(2) => fer(f,1,m+1) + del(2)*bos(f,3,m),
der(1)*bos(~f,1,~m,~l) => l*fer(f,0,m+1)*bos(f,1,m,l-1) +
                       bos(f,1,m,l)*der(1),
der(1)*bos(~f,2,~m,~l) => l*fer(f,3,m)*bos(f,2,m,l-1)+
                       bos(f,2,m,l)*der(1),
der(1)*bos(~f,3,~m,~l) => l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       bos(f,3,m,l)*der(1),
bos(~f,1,~m,~l)*del(1) => -l*fer(f,0,m+1)*bos(f,1,m,l-1) +
                       del(1)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(1) => -l*fer(f,3,m)*bos(f,2,m,l-1)+
                       del(1)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(1) => -l*fer(f,2,m+1)*bos(f,3,m,l-1) +
                       del(1)*bos(f,3,m,l),
der(2)*bos(~f,1,~m,~l) => -l*fer(f,3,m)*bos(f,1,m,l-1) +
                       bos(f,1,m,l)*der(2),
der(2)*bos(~f,2,~m,~l) => l*fer(f,0,m+1)*bos(f,2,m,l-1) +
                       bos(f,2,m,l)*der(2),
der(2)*bos(~f,3,~m,~l) => -l*fer(f,1,m+1)*bos(f,3,m,l-1) +
                       bos(f,3,m,l)*der(2),
bos(~f,1,~m,~l)*del(2) => l*fer(f,3,m)*bos(f,1,m,l-1) +
                       del(2)*bos(f,1,m,l),
bos(~f,2,~m,~l)*del(2) => -l*fer(f,0,m+1)*bos(f,2,m,l-1) +
                       del(2)*bos(f,2,m,l),
bos(~f,3,~m,~l)*del(2) => l*fer(f,1,m+1)*bos(f,3,m,l-1) +
                       del(2)*bos(f,3,m,l)}$

drr:= { d(-1)**(~n) => dr(-n) when n neq 1,d(-1) => dr(-1) }$
nodrr:={ dr(-~n) => d(-1)**n when n neq 1, dr(-1) => d(-1) }$
cutoff:= { dr(~n) => 0 when  n < - cut }$
inverse:={bos(~f,~n,~m) => bos(f,n,m,1) ,
          fun(~f,~n)    => fun(f,n,1)   }$
%*******************************************%
%*** module  ordering **********************%
%*******************************************%
%ordering of bos with 4 and 3 indices and (fer,axp,ber,fir,zen,zan)
let {
bos(~f,~n,~m,~k)*bos(~g,~x,~z,~v) => bos(g,x,z,v)*bos(f,n,m,k) when
       ordp(f,g) and f neq g or f equal g and n bos(g,x,z)*bos(f,n,m) when
       ordp(f,g) and f neq g or f equal g and n bos(g,x,z)*bos(f,n,m,k) when
       ordp(f,g) and f neq g or f equal g and nbos(f,n,m,k)*bos(g,x,z) when
       ordp(g,f) and f neq g or f equal g and n>x or
       f equal g and n equal x and m>z,
bos(~f,~n,~m,~k)*bos(~f,~n,~m,~l) => bos(f,n,m,k+l),
bos(~f,~n,~m,~k)**2 => bos(f,n,m,2k),
bos(~f,~n,~m,0) => 1, bos(0,~f,~n,~m) => 0, bos(0,~f,~n) => 0,
bos(~f,~n,~m,~k)*bos(~f,~n,~m) => bos(f,n,m,k+1),
bos(~f,~n,~m)*bos(~f,~n,~m,~k) => bos(f,n,m,k+1),

ber(~f,~n,~m)*bos(~g,~k,~x,~l) => bos(g,k,x,l)*ber(f,n,m),
fir(~f,~n,~m)*bos(~g,~k,~x,~l) => bos(g,k,x,l)*fir(f,n,m),
ber(~f,~n,~m)*bos(~g,~k,~l) => bos(g,k,l)*ber(f,n,m),
ber(~f,~n,~m)*fer(~g,~k,~l) => fer(g,k,l)*ber(f,n,m),
fir(~f,~n,~m)*bos(~g,~k,~l) => bos(g,k,l)*fir(f,n,m),
fir(~f,~n,~m)*fer(~g,~k,~l) => -fer(g,k,l)*fir(f,n,m),
%ordering of fer,
fer(0,~n,~m) => 0,
bos(~f,~n,~m,~y)*fer(~g,~x,~h) => fer(g,x,h)*bos(f,n,m,y),
bos(~f,~n,~m)*fer(~g,~x,~h)    => fer(g,x,h)*bos(f,n,m),
fer(~f,~n,~m)**2 => 0,
fer(~f,~n,~m)*fer(~g,~k,~l) => - fer(g,k,l)*fer(f,n,m) when
        ordp(f,g) and f neq g or f equal g and n fun(g,k,l)*fun(f,n,m) when
        ordp(f,g) and f neq g or f equal g and n fun(g,x)*fun(f,n,m) when
        ordp(f,g) and f neq g or f equal g and n fun(f,n,m)*fun(g,x) when
       ordp(g,f) and f neq g or f equal g and n>x,
fun(~f,~n)*fun(~g,~m) => fun(g,m)*fun(f,n) when
        ordp(f,g) and f neq g or f equal g and n fun(s,x)*fun(f,n,m,k,l),
fun(~f,~n,~m,~k,~l)*fun(~s,~x,~z) => fun(s,x,z)*fun(f,n,m,k,l),
fun(~f,~n,~m,~k,~l)*gras(~s,~x) => gras(s,x)*fun(f,n,m,k,l),
fun(~f,~n,~m,~k,~l)*tet(~s) => tet(s)*fun(f,n,m,k,l),
fun(~f,~n,~m,~k,~l)*fun(~s,~x,~z) => fun(s,x,z)*fun(f,n,m,k,l),
fun(~f,~n,~m)*gras(~g,~x) => gras(g,x)*fun(f,n,m),
fun(~f,~n)*gras(~g,~x) => gras(g,x)*fun(f,n),
gras(~f,~n)*gras(~g,~m) =>-gras(g,m)*gras(f,n) when
        ordp(f,g) and f neq g or f equal g and n fun(g,m)*fun(f,n),
ber(~f,~n)*gras(~g,~m) => gras(g,m)*fun(f,n),
fir(~f,~n)*fun(~g,~m) => fun(g,m)*fir(f,n),
fir(~f,~n)*gras(~g,~m) => - fir(g,m)*gras(f,n),
gras(~f,~n)^2 => 0,
fun(~f,~n,0) => 1,fun(0,~n,~m) => 0, fun(0,~n) => 0, gras(0,~n) => 0,
fun(~f,~n,~m)*fun(~f,~n,~k) => fun(f,n,m+k),
fun(~f,~n,~m)**2 => fun(f,n,2m),
fun(~f,~n,~m)*tet(~k) => tet(k)*fun(f,n,m),
fun(~f,~n)*tet(~k) => tet(k)*fun(f,n),
gras(~f,~n)*tet(~k) => - tet(k)*gras(f,n),
axx(~f)*fun(~g,~n) => fun(g,n)*axx(f),
axx(~f)*gras(~g,~n) => gras(g,n)*axx(f),
axx(~f)*fun(~g,~n,~m) => fun(g,n,m)*axx(f),
axx(~f)*fun(~g,~n,~m,~k,~l) => fun(g,n,m,~k,~l)*axx(f),
fun(~f,~n,~g,~m,~k) => (for s:=0:k sum
(-1)**s*newton(k,s)*fun(f,n,k-s)*fun(g,m,s)/(2**s))
when numberp(k) and k >=0,
%ordering other,
bos(~g,~x,~h)*zan(~f,~n,~m)    => zan(f,n,m)*bos(g,x,h),
bos(~g,~x,~h,~l)*zan(~f,~n,~m) => zan(f,n,m)*bos(g,x,h,l),
fer(~g,~x,~h)*zan(~f,~n,~m)    => zan(f,n,m)*fer(g,x,h),
bos(~g,~x,~h)*zen(~f,~n,~m)    => zen(f,n,m)*bos(g,x,h),
bos(~g,~x,~h,~l)*zen(~f,~n,~m) => zen(f,n,m)*bos(g,x,h,l),
fer(~g,~x,~h)*zen(~f,~n,~m)    => - zen(f,n,m)*fer(g,x,h),
axp(~g)*zan(~f,~n,~m)          => zan(f,n,m)*axp(g),
axp(~g)*zen(~f,~n,~m)          => zen(f,n,m)*axp(g),
axp(~g)*bos(~f,~n,~m) => bos(f,n,m)*axp(g),
axp(~g)*bos(~f,~n,~m,~l) => bos(f,n,m,l)*axp(g),
axp(~g)*fer(~f,~n,~m) => fer(f,n,m)*axp(g),
axp(~f)*axp(~g) => axp(f+g), axp(~f)**(~n) => axp(n*f)}$
%other;
let {          dr(~n)*dr(~m) => dr(n+m),tet(~n)^2 => 0,
tet(~n)*tet(~m) => -tet(m)*tet(n) when n 0 when m=0 or m=3,
dr(~n)*d(1) => dr(n+1),   d(1)*dr(~n) => dr(n+1),dr(~n)*d(2) => dr(n+1),
d(2)*dr(~n) => dr(n+1),der(~m)*dr(~n) => dr(n)*der(m),
dr(~n)*del(~m) => del(m)*dr(n), dr(~n)**2 => dr(2n),axp(0)=> 1,
axx(0)=> 1,dr(0)=> 1, der(0) => 1,
der(~n)*d(~m) => d(m)*der(n) when m neq t,
d(1)*del(~n) => del(n)*d(1),del(~n)*d(2) => d(2)*del(n),
d(-1)*del(~n) => del(n)*d(-1),del(~n)*d(-2) => d(-2)*del(n),
d(-3)*del(~n) => del(n)*d(-3),del(~n)*d(-4) => d(-4)*del(n),

d(1)*d(-1)=> 1,d(-1)*d(1)=>1,d(1)*d(-2)=> 1,d(-2)*d(1)=> 1,
d(1)*d(-3)=> 1,d(-3)*d(1)=>1,d(1)*d(-4)=> 1,d(-4)*d(1)=> 1,
d(3)*d(-1)=> 1,d(-1)*d(3)=>1,d(3)*d(-2)=> 1,d(-2)*d(3)=> 1,
d(3)*d(-4)=> 1,d(-4)*d(3)=>1,d(2)*d(-1)=> 1,d(-1)*d(2)=> 1,
d(2)*d(-2)=> 1,d(-2)*d(2)=>1,d(2)*d(-3)=> 1,d(-3)*d(2)=> 1,
d(2)*d(-4)=> 1,d(-4)*d(2)=>1,d(3)*d(-3)=>1,
d(1)*d(3)=> d(3)*d(1), d(-3)*d(3)=>1,
d(t)*d(1)=> d(1)*d(t),d(t)*d(2)=>d(2)*d(t),
d(t)*der(~n)=>der(n)*d(t),d(t)*del(~n)=>del(n)*d(t),
d(t)*d(-1)=>d(-1)*d(t),d(t)*d(-2)=> d(-2)*d(t),!@x_y^2 =>1,
d(t)*d(-3)=>d(-3)*d(t),d(t)*d(-4)=> d(-4)*d(t),abs(!#ll) =>1,
delta(~f,~g)    => if f equal g then 1 else 0,
bf_part(~wx,~n) => part(fpart(wx),n+1),
b_part(~wx,~n)  => part(bpart(wx),n+1),
pg(~n,~x)       => sub(d(1)=0,d(1)**n*x),
chan(~x)        => sub(d(2)=d(1),sub(d(1)=d(2),x)),
s_part(~x,~n)   => coeffn(sub(der(1)=!@k,der(2)=(!@k)^2,der(3)=(!@k)^3,
                    del(1)=!@k,del(2)=(!@k)^2,der(3)=(!@k)^3,x),!@k,n),
newton(~n,~m)   => factorial(n)/(factorial(m)*factorial(n-m)),
prykr(~f,~g)    => if g = 1 then der(1)*f else if g = 2 then der(2)*f,
prykl(~f,~g)    => if g = 1 then f*del(1) else if g = 2 then f*del(2)}$
%adjoint
let {   bos(~f,~n,~m)*stp(~x)     => stp(x)*bos(f,n,m),
   bos(~f,~n,~m,~l)*stp(~x)       => stp(x)*bos(f,n,m,l),
   axp(~f)*stp(~x)                => stp(x)*axp(f),
d(~n)*stp(~x)  => -stp(x)*d(n) ,
der(~k)*stp(1) => stp(2)*der(k) when k neq 3,
der(~k)*stp(2)  => - stp(1)*der(k) when k neq 3,
del(~k)*stp(1) => - del(k) when k neq 3,
del(~k)*stp(2)  => - stp(1)*del(k) when k neq 3,
der(3)*stp(~x) => stp(x)*der(3),del(3)*stp(~x) => stp(x)*der(3),
del(~x)*stp(10)           => stp(20)*del(x) when x neq 3,
del(~x)*stp(20)           => -stp(10)*del(x) when x neq 3,
fer(~f,~n,~m)*stp(1)      => stp(10)*fer(f,n,m),
fer(~f,~n,~m)*stp(10)     => -stp(20)*fer(f,n,m),
fer(~f,~n,~m)*stp(20)     => stp(10)*fer(f,n,m),
fer(~f,~n,~m)*stp(2)      => stp(10)*fer(f,n,m)}$
%***********************************%
%*** Local action ******************%
%***********************************%
tryk:={ d(~f)*fer(~g,~n,~m)    => delta(f,g)*zen(g,n,m) + fer(g,n,m)*d(f),
        d(~f)*bos(~g,~n,~m)    => delta(f,g)*zan(g,n,m) + bos(g,n,m)*d(f),
        d(~f)*bos(~g,~n,~m,~l) => l*delta(f,g)*zan(g,n,m)*bos(g,n,m,l-1)+
                                  bos(g,n,m,l)*d(f),
        d(~f)*axp(~g)         => axp(g)*(d(f)*g-g*d(f))+axp(g)*d(f) }$
tryk1:={zan(~f,0,~m) => (-1)**m*d(1)**m,
       zan(~f,3,~m) =>
               if abra_kadabra = 2 then (-1)**m*der(1)*der(2)*d(1)**m
         else  if abra_kadabra = 1 then (-1)**(m+1)*der(2)*der(1)*d(1)**m
         else  if abra_kadabra = 3 then (-1)**m*der(3)*d(1)**m,
       zan(~f,1,~m) => (-1)**m*der(1)*d(1)**m,
       zan(~f,2,~m) => (-1)**m*der(2)*d(1)**m,
       zen(~f,1,~m) => (-1)**(m+1)*der(1)*d(1)**m,
       zen(~f,2,~m) => (-1)**(m+1)*der(2)*d(1)**m,
       zen(~f,0,~m) => (-1)**m*d(1)**m,
       zen(~f,3,~m) =>
               if abra_kadabra = 2 then (-1)**m*der(1)*der(2)*d(1)**m
         else  if abra_kadabra = 1 then (-1)**(m+1)*der(2)*der(1)*d(1)**m
         else  if abra_kadabra = 3 then (-1)**m*der(3)*d(1)**m}$
tryk2:={zan(~f,0,~m) => bos(f,0,0)*(-1)**m*d(1)**m,
        zan(~f,3,~m) => bos(f,0,0)*(
               if abra_kadabra = 2 then (-1)**m*der(1)*der(2)*d(1)**m
         else  if abra_kadabra = 1 then (-1)**(m+1)*der(2)*der(1)*d(1)**m
         else  if abra_kadabra = 3 then (-1)**m*der(3)*d(1)**m),
        zan(~f,1,~m) => fer(f,0,0)*(-1)**m*der(1)*d(1)**m,
        zan(~f,2,~m) => fer(f,0,0)*(-1)**m*der(2)*d(1)**m,
        zen(~f,1,~m) => bos(f,0,0)*(-1)**(m+1)*der(1)*d(1)**m,
        zen(~f,2,~m) => bos(f,0,0)*(-1)**(m+1)*der(2)*d(1)**m,
        zen(~f,0,~m) => fer(f,0,0)*(-1)**m*d(1)**m,
        zen(~f,3,~m) => fer(f,0,0)*(
               if abra_kadabra = 2 then (-1)**m*der(1)*der(2)*d(1)**m
         else  if abra_kadabra = 1 then (-1)**(m+1)*der(2)*der(1)*d(1)**m
         else  if abra_kadabra = 3 then (-1)**m*der(3)*d(1)**m)}$
tryk3:={fer(~f,~n,~m)    =>1,        bos(~f,~n,~m)    =>1,
        bos(~f,~n,~m,~l) =>1,        axp(~f)          => 1 }$
tryk4:={fer(~f,~n,~m)    => 1,        bos(~f,~n,~m)    => 1,
        axp(~f)          => 1,        bos(~f,~n,~m,~l) => 1,
        der(~n)  => 1, d(~n)  => 1,  del(~n)  => 1}$
%only for  trad
tryk5:={bos(~f,~m,~n) => if m=0 then
       fun(mkid(f,0),n)+tet(1)*gras(mkid(f,mkid(f,1)),n)+
       tet(2)*gras(mkid(f,mkid(f,2)),n)+tet(2)*tet(1)*fun(mkid(f,1),n)
       else if m=1  then
       fun(mkid(f,0),n) - tet(2)*gras(mkid(f,mkid(f,2)),n) +
       tet(1)*gras(mkid(f,mkid(f,1)),n+1) - tet(2)*tet(1)*fun(mkid(f,1),n+1)
       else if m=2 then
       fun(mkid(f,1),n) + tet(1)*gras(mkid(f,mkid(f,2)),n) +
       tet(2)*gras(mkid(f,mkid(f,1)),n+1) + tet(2)*tet(1)*fun(mkid(f,0),n+1)
       else if m=3 then
       tet(1)*gras(mkid(f,mkid(f,2)),n+1) + fun(mkid(f,1),n) -
       tet(2)*tet(1)*fun(mkid(f,0),n+2) - tet(2)*gras(mkid(f,mkid(f,1)),n+1)
       else rederr " wrong values of arguments",
fer(~f,~m,~n) => if m=0 then
       gras(mkid(f,mkid(f,1)),n)+tet(1)*fun(mkid(f,0),n)+
        tet(2)*fun(mkid(f,1),n)+tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n)
       else if m=1 then
        gras(mkid(f,mkid(f,1)),n)-tet(2)*fun(mkid(f,1),n)+
        tet(1)*fun(mkid(f,0),n+1)-tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n+1)
       else if m=2 then
        gras(mkid(f,mkid(f,2)),n)+tet(1)*fun(mkid(f,1),n)+
        tet(2)*fun(mkid(f,0),n+1)+tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+1)
       else if m=3  then
       tet(1)*fun(mkid(f,1),n+1) + gras(mkid(f,mkid(f,2)),n) -
       tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+2) - tet(2)*fun(mkid(f,0),n+1)
        else rederr "wrong values of arguments" ,
bos(~f,~m,~n,~l) => if m equal 0 then
       fun(mkid(f,0),n,l) + l*fun(mkid(f,0),n,l-1)*(tet(1)*gras(mkid(f,1),n)+
       tet(2)*gras(mkid(g,2),n) +tet(2)*tet(1)*(fun(mkid(f,1),n,1)+
       (l-1)*fun(mkid(f,0),n,-1)*gras(mkid(g,1),n)*gras(mkid(g,2),n)))
       else if m=1 then
       fun(mkid(f,0),n,l)+l*fun(mkid(f,0),n,l-1)*(tet(1)*gras(mkid(g,1),n+1)-
       tet(2)*gras(mkid(g,2),n)+tet(2)*tet(1)*(fun(mkid(f,1),n+1,1)-
       (l-1)*fun(mkid(f,0),n,-1)*gras(mkid(g,1),n+1)*gras(mkid(g,2),n)))
       else if m=2 then
       fun(mkid(f,1),n,l)+l*fun(mkid(f,1),n,l-1)*(tet(1)*gras(mkid(g,2),n)+
       tet(2)*gras(mkid(g,1),n+1)+tet(2)*tet(1)*(fun(mkid(f,0),n+1,1) -
       (l-1)*fun(mkid(f,1),n,-1)*gras(mkid(g,1),n+1)*gras(mkid(g,2),n)))
       else if m=3 then
       fun(mkid(f,1),n,l)+l*fun(mkid(f,1),n,l-1)*(tet(1)*gras(mkid(g,2),n+1)-
       tet(2)*gras(mkid(g,1),n+1) + tet(2)*tet(1)*(-fun(mkid(f,0),n+1,1)+
       (l-1)*fun(mkid(f,1),n,-1)*gras(mkid(g,1),n+1)*gras(mkid(g,2),n+1) ) )
       else rederr "wrong values of arguments" ,
axp(~f) => axx(bf_part(f,0))*(1+ tet(1)*bf_part(f,1)+
      tet(2)*bf_part(f,2) + tet(2)*tet(1)*(bf_part(f,3)+
        2*bf_part(f,1)*bf_part(f,2))) }$
tryk6:={ gras(~f,~n) =>0 }$
tryk7:={  !@f_f(~f,0,~n)    => bos(f,0,n),
!@f_f(~f,1,~n)    =>    if abra_kadabra = 2 then bos(f,1,n) else
                        if not freeof(f_chiral,f) then 0 else bos(f,1,n),
!@f_f(~f,2,~n)    =>    if abra_kadabra = 2 then bos(f,2,n) else
                        if not freeof(f_antychiral,f) then 0 else  bos(f,2,n),
!@f_f(~f,3,~n)    =>    if abra_kadabra = 2 then bos(f,3,n) else
if not freeof(b_chiral,f) then - bos(f,0,n+1) else
if abra_kadabra = 1 and not freeof(b_antychiral,f) then 0 else
if abra_kadabra = 3 and not freeof(b_antychiral,f) then bos(f,0,n+1) else
bos(f,3,n),
!@g_g(~f,0,~n)    => fer(f,0,n),
!@g_g(~f,1,~n)    =>    if abra_kadabra = 2 then fer(f,1,n) else
                        if not freeof(b_chiral,f) then 0 else fer(f,1,n),
!@g_g(~f,2,~n)    =>    if abra_kadabra = 2 then fer(f,2,n) else
                        if not freeof(b_antychiral,f) then 0 else fer(f,2,n),
!@g_g(~f,3,~n)    =>    if abra_kadabra = 2 then fer(f,3,n) else
if not freeof(f_chiral,f) then -fer(f,0,n+1) else
if abra_kadabra = 1 and not freeof(f_antychiral,f) then 0 else
if abra_kadabra = 3 and not freeof(f_antychiral,f) then fer(f,0,n+1) else
fer(f,3,n)}$
tryk8:={ bos(~f,~n,~m)     => berz(f,n,m)+eps*ber(f,n,m),
         fer(~f,~n,~m)     => firr(f,n,m)+eps*fir(f,n,m),
         bos(~f,~n,~m,~l)  => berz(f,n,m,l)+l*eps*berz(f,n,m,l-1)*ber(f,n,m)}$
tryk9:={ berz(~f,~n,~m)    => bos(f,n,m), firr(~f,~n,~m)    => fer(f,n,m),
         berz(~f,~n,~m,~l) => bos(f,n,m,l)}$
tryk10:= { fir(~f,~n,~m)    => pg(m,pr(n,bos(f))),
          ber(~f,~n,~m)    => pg(m,pr(n,bos(f)))}$
tryk11:= {  !#a(~n) => !#aa(n),  !#b(~n) => !#bb(n),  !#c(~n) => !#cc(n) }$
tryk12:= { !#aa(~n) =>  !#b(n), !#bb(~n) =>  !#c(n), !#cc(~n) =>  !#a(n) }$
tryk13:= { !#aa(~n) =>  !#c(n), !#bb(~n) =>  !#a(n), !#cc(~n) =>  !#b(n) }$
tryk14:={ bos(~f,~n,~m,t,t) => pg(m,pr(n,bos(f,t))),
        fer(~f,~n,~m,t) => pg(m,pr(n,bos(f,t))) }$
tryk15:={ bos(~f,~n,~m,~l) => if n equal 0 or n equal 3 then berz(f,n,m,l)
               else if n equal 1 then (-1)**l*berz(f,2,m,l)
               else if n equal 2 then  berz(f,1,m,l),
       bos(~f,~n,~m)  => if n equal 0 or n equal 3 then berz(f,n,m)
               else if n equal 1 then -berz(f,2,m)
               else if n equal 2 then   berz(f,1,m),
       fer(~f,~n,~m)  => if n equal 0 or n equal 3 then firr(f,n,m)
               else if n equal 1 then -firr(f,2,m)
                else if n equal 2 then  firr(f,1,m) }$
%only for chiral
tryk16:={
bos(~f,0,~n) => if not freeof(b_chiral,f)  then
                fun(mkid(f,0),n)+tet(2)*gras(mkid(f,mkid(f,2)),n)-
                tet(2)*tet(1)*fun(mkid(f,0),n+1)/2
        else    if not freeof(b_antychiral,f) then
                fun(mkid(f,0),n)+tet(1)*gras(mkid(f,mkid(f,1)),n) +
                tet(2)*tet(1)*fun(mkid(f,0),n+1)/2
        else    fun(mkid(f,0),n)+tet(1)*gras(mkid(f,mkid(f,1)),n)+
       tet(2)*gras(mkid(f,mkid(f,2)),n)+tet(2)*tet(1)*fun(mkid(f,1),n),
bos(~f,1,~n)   =>  if not freeof(f_chiral,f) then 0 else
                   if not freeof(f_antychiral,f) then
       fun(mkid(f,0),n) - tet(2)*gras(mkid(f,mkid(f,1)),n+1) -
       tet(2)*tet(1)*fun(mkid(f,0),n+1)/2
else  fun(mkid(f,0),n) - tet(2)*gras(mkid(f,mkid(f,2)),n) -
       tet(2)*gras(mkid(f,mkid(f,1)),n+1)/2 -
       tet(2)*tet(1)*fun(mkid(f,0),n+1)/2,

bos(~f,2,~n) => if not freeof(f_chiral,f) then
                fun(mkid(f,0),n) - tet(2)*gras(mkid(f,mkid(f,1)),n+1) -
                tet(2)*tet(1)*fun(mkid(f,0),n+1)/2
        else if not freeof(f_antychiral,f) then 0
        else     fun(mkid(f,1),n) + tet(1)*gras(mkid(f,mkid(f,2)),n) -
       tet(1)*gras(mkid(f,mkid(f,1)),n+1) + tet(2)*tet(1)*fun(mkid(f,1),n+1)/2,

bos(~f,3,~n) => if abra_kadabra = 1 then
   if not freeof(b_chiral,f) then - bos(f,0,n+1) else
   if not freeof(b_antychiral,f) then 0  else
        fun(mkid(f,1),n) - fun(mkid(f,0),n+1)/2 -
        tet(2)*gras(mkid(f,mkid(f,2)),n+1) -
        tet(2)*tet(1)*fun(mkid(f,1),n+1)/2 +
        tet(2)*tet(1)*fun(mkid(f,0),n+2)/4
else if abra_kadabra = 3 then
   if not freeof(b_chiral,f) then - bos(f,0,n+1) else
   if not freeof(b_antychiral,f) then bos(f,0,n+1) else
   2*fun(mkid(f,1),n) - tet(2)*gras(mkid(f,mkid(f,2)),n+1) +
   tet(1)*gras(mkid(f,mkid(f,1)),n+1)+tet(2)*tet(1)*fun(mkid(f,0),n+2)/2,

bos(~f,0,~n,~k) =>
if not freeof(b_chiral,f)  then
   fun(mkid(f,0),n,k)+k*tet(2)*fun(mkid(f,0),n,k-1)*
   (gras(mkid(f,mkid(f,2)),n) -tet(1)*fun(mkid(f,0),n+1,1)/2)
else    if not freeof(b_antychiral,f) then
   fun(mkid(f,0),n,k)+k*tet(1)*fun(mkid(f,0),n,k-1)*
   (gras(mkid(f,mkid(f,1)),n) - tet(2)*fun(mkid(f,0),n+1,1)/2)
else  fun(mkid(f,0),n,k)+
   k*tet(1)*gras(mkid(f,mkid(f,1)),n)*fun(mkid(f,0),n,k-1)+
   k*tet(2)*gras(mkid(f,mkid(f,2)),n)*fun(mkid(f,0),n,k-1)+
+tet(2)*tet(1)*(k*fun(mkid(f,1),n,1)*fun(mkid(f,0),n,k-1)+
k*(k-1)*gras(mkid(f,mkid(f,1)),n)*gras(mkid(f,mkid(f,2)),n)*
fun(mkid(f,0),n,k-2)),

bos(~f,1,~n,~k)   =>
 if not freeof(f_chiral,f) then 0 else
 if not freeof(f_antychiral,f) then
fun(mkid(f,0),n,k) - k*fun(mkid(f,0),n,k-1)*tet(2)*(
gras(mkid(f,mkid(f,1)),n+1) + tet(1)*fun(mkid(f,0),n+1,1)/2)
 else  fun(mkid(f,0),n,k) -k*fun(mkid(f,0),n,k-1)*tet(2)*
    (gras(mkid(f,mkid(f,2)),n) + gras(mkid(f,mkid(f,1)),n+1)/2 +
       tet(1)*fun(mkid(f,0),n+1,1)/2),

bos(~f,2,~n,~k) => if not freeof(f_chiral,f) then
    fun(mkid(f,0),n,k) - k*tet(2)*fun(mkid(f,0),n,k-1)*
     (gras(mkid(f,mkid(f,1)),n+1) + tet(1)*fun(mkid(f,0),n+1)/2)
else if not freeof(f_antychiral,f) then 0
else   fun(mkid(f,1),n,k) + k*tet(1)*fun(mkid(f,1),n,k-1)*
    (gras(mkid(f,mkid(f,2)),n) - gras(mkid(f,mkid(f,1)),n+1) -
    tet(2)*fun(mkid(f,1),n+1,1)/2),

bos(~f,3,~n,~k) => if abra_kadabra = 1 then
     if not freeof(b_chiral,f) then (-1)**k*bos(f,0,n+1,k)
else if not freeof(b_antychiral,f) then 0
else  fun(mkid(f,1),n,mkid(f,0),n+1,k) - k*fun(mkid(f,1),n,mkid(f,0),n+1,k-1)*
        (tet(2)*gras(mkid(f,mkid(f,2)),n+1) +
        tet(2)*tet(1)*fun(mkid(f,1),n+1,1)/2 -
        tet(2)*tet(1)*fun(mkid(f,0),n+2,1)/4)
else if abra_kadabra = 3 then
     if not freeof(b_chiral,f) then (-1)**k*bos(f,0,n+1,k)
else if not freeof(b_antychiral,f) then bos(f,0,n+1,k)
else   2**k*fun(mkid(f,1),n,k) + k*2**(k-1)*fun(mkid(f,1),n,k-1)*
  (- tet(2)*gras(mkid(f,mkid(f,2)),n+1) +
   tet(1)*gras(mkid(f,mkid(f,1)),n+1)+tet(2)*tet(1)*fun(mkid(f,0),n+2,1)/2)
 -k*(k-1)*2**(k-2)*tet(2)*tet(1)*fun(mkid(f,1),n,k-2)*
        gras(mkid(f,mkid(f,1)),n+1)*gras(mkid(f,mkid(f,2)),n+1),

fer(~f,0,~n) => if not freeof(f_chiral,f) then
                gras(mkid(f,mkid(f,1)),n)+tet(2)*fun(mkid(f,1),n) -
                tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+1)/2
        else if not freeof(f_antychiral,f) then
                gras(mkid(f,mkid(f,1)),n)+tet(1)*fun(mkid(f,0),n)+
                tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+1)/2
        else    gras(mkid(f,mkid(f,1)),n)+tet(1)*fun(mkid(f,0),n)+
        tet(2)*fun(mkid(f,1),n)+tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n),

fer(~f,1,~n) => if not freeof(b_chiral,f) then 0
          else  if not freeof(b_antychiral,f) then
                gras(mkid(f,mkid(f,1)),n) -
                tet(2)*fun(mkid(f,0),n+1) -
                tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+1)/2
          else  gras(mkid(f,mkid(f,1)),n) - tet(2)*fun(mkid(f,1),n)-
                tet(2)*fun(mkid(f,0),n+1)/2 -
                tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+1)/2,

fer(~f,2,~n) => if not freeof(b_chiral,f) then
                gras(mkid(f,mkid(f,2)),n) -tet(1)*fun(mkid(f,0),n+1)+
                tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n+1)/2
        else    if not freeof(b_antychiral,f) then 0
        else    gras(mkid(f,mkid(f,2)),n)+tet(1)*fun(mkid(f,1),n) -
                tet(1)*fun(mkid(f,0),n+1)/2 +
                tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n+1)/2,

fer(~f,3,~n) => if abra_kadabra = 1 then
        if not freeof(f_chiral,f) then  - fer(f,0,n+1)
        else    if not freeof(f_antychiral,f) then 0
        else   gras(mkid(f,mkid(f,2)),n) - gras(mkid(f,mkid(f,1)),n+1)/2 -
               tet(2)*fun(mkid(f,1),n+1) -
        tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+2)/4 -
        tet(2)*tet(1)*gras(mkid(f,mkid(f,2)),n+1)/2
else if abra_kadabar = 3 then
        if not freeof(f_chiral,f) then - fer(f,0,n+1)
  else  if not freeof(f_antychiral,f) then fer(f,0,n+1)
else    2*gras(mkif(f,mkid(f,2)),n) - tet(2)*fun(mkid(f,1),n+1) +
 tet(1)*fun(mkid(f,0),n+1) +tet(2)*tet(1)*gras(mkid(f,mkid(f,1)),n+2)/2,

axp(~f) => axx(bf_part(f,0))*(1+ tet(1)*bf_part(f,1)+
      tet(2)*bf_part(f,2) + tet(2)*tet(1)*(bf_part(f,3)+
        2*bf_part(f,1)*bf_part(f,2))) }$
%***********************************%
%*** module - operators  ***********%
%***********************************%
%differentations
let {   d(1)*fer(~f,~n,~m) => fer(f,n,m+1)+fer(f,n,m)*d(1),
d(1)*bos(~f,~n,~m)         => bos(f,n,m+1)+bos(f,n,m)*d(1),
fer(~f,~n,~m)*d(2)         => -fer(f,n,m+1)+d(2)*fer(f,n,m),
bos(~f,~n,~m)*d(2)         => -bos(f,n,m+1)+d(2)*bos(f,n,m),
d(1)*bos(~f,~n,~m,~l)      => l*bos(f,n,m+1,1)*bos(f,n,m,l-1)+bos(f,n,m,l)*d(1),
bos(~f,~n,~m,~l)*d(2)      => -l*bos(f,n,m+1,1)*bos(f,n,m,l-1)+d(2)*bos(f,n,m,l),

der(~k)*fer(~f,0,~m) => bos(f,k,m)-fer(f,0,m)*der(k) when numberp k and k < 3,
der(~k)*bos(~f,0,~m) => fer(f,k,m)+bos(f,0,m)*der(k) when numberp k and k < 3,
fer(~f,0,~m)*del(~k) => bos(f,k,m)-del(k)*fer(f,0,m) when numberp k and k < 3,
bos(~f,0,~m)*del(~k) => -fer(f,k,m)+del(k)*bos(f,0,m) when numberp k and k < 3,
der(~k)*bos(~f,0,~m,~l) => l*fer(f,k,m)*bos(f,0,m,l-1)+bos(f,0,m,l)*der(k)
                when numberp k and k < 3,
bos(~f,0,~m,~l)*del(~k) => -l*fer(f,k,m)*bos(f,0,m,l-1)+del(k)*bos(f,0,m,l)
                when numberp k and k < 3,
d(1)*axp(~g) => pg(1,g)*axp(g)+axp(g)*d(1),
der(1)*axp(~g) => pr(1,g)*axp(g)+axp(g)*der(1),
der(2)*axp(~g) => pr(2,g)*axp(g)+axp(g)*der(2),
axp(~g)*d(2) => -pg(1,g)*axp(g)+d(2)*axp(g),
axp(~g)*del(1) => -pr(1,g)*axp(g)+del(1)*axp(g),
axp(~g)*del(2) => -pr(2,g)*axp(g)+del(2)*axp(g),
d(1)*fun(~f,~m) => fun(f,m+1)+fun(f,m)*d(1),
fun(~f,~m)*d(2) => -fun(f,m+1)+d(2)*fun(f,m),
d(1)*fun(~f,~n,~m) => m*fun(f,n+1,1)*fun(f,n,m-1)+fun(f,n,m)*d(1),
fun(~f,~n,~m)*d(2) => -m*fun(f,n+1,1)*fun(f,n,m-1)+d(2)*fun(f,n,m),
gras(~f,~m)*d(2) => -gras(f,m+1)+d(2)*gras(f,m),
d(1)*gras(~f,~m) => gras(f,m+1)+gras(f,m)*d(1),
d(1)*axx(~f) => pg(1,f)*axx(f)+axx(f)*d(1),
axx(~f)*d(2) => -pg(1,f)*axx(f)+d(2)*axx(f)}$
%integrations;
let { d(-1)*fer(~f,~n,~m) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*fer(f,n,m+k)*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
fer(~f,~n,~m)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*fer(f,n,m+k) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*bos(~f,~n,~m) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*bos(f,n,m+k)*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
bos(~f,~n,~m)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*bos(f,n,m+k) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*bos(~f,~n,~m,~l) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*pg(k,bos(f,n,m,l))*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
bos(~f,~n,~m,~l)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*pg(k,bos(f,n,m,l)) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*axp(~f) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*pg(k,axp(f))*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
axp(~f)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*pg(k,axp(f)) else
rederr "introduce the precision e.g. give the value of ww > 0",
%acceleration;
dr(~x)*bos(~f,~n,~m) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*bos(f,n,m+s)*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
dr(~x)*fer(~f,~n,~m) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*fer(f,n,m+s)*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
dr(~x)*bos(~f,~n,~m,~l) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*pg(s,bos(f,n,m,l))*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
dr(~x)*fun(~f,~n) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*fun(f,n+s)*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
dr(~x)*gras(~f,~n) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*gras(f,n+s)*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
dr(~x)*fun(~f,~n,~l) => if numberp(ww) then
for s:=0:ww sum (-1)**s*newton(-x+s-1,-x-1)*pg(s,fun(f,n,l))*dr(x-s)
else rederr "introduce the precision e.g. give the value of ww > 0",
%classical
d(-1)*fun(~f,~n,~m) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*pg(k,fun(f,n,m))*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
fun(~f,~n,~m)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*pg(k,fun(f,n,m)) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*fun(~f,~n) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*fun(f,n+k)*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
fun(~f,~n)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*fun(f,n+k) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*gras(~f,~n) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*gras(f,n+k)*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
gras(~f,~n)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*gras(f,n+k) else
rederr "introduce the precision e.g. give the value of ww > 0",
d(-1)*axx(~f) => if numberp(ww) then
for k:=0:ww-1 sum (-1)**k*pg(k,axx(f))*d(-1)**(k+1) else
rederr "introduce the precision e.g. give the value of ww > 0",
axx(~f)*d(-2) => if numberp(ww) then
for k:=0:ww-1 sum d(-2)**(k+1)*pg(k,axx(f)) else
rederr "introduce the precision e.g. give the value of ww > 0" }$
%other time
let
{ d(t)*axp(~f) => axp(f)*d(t)*f,
d(t)*bos(~f,~n,~m) => bos(f,n,m,t,t) + bos(f,n,m)*d(t),
d(t)*fer(~f,~n,~m) => fer(f,n,m,t) +fer(f,n,m)*d(t),
d(t)*bos(~f,~n,~m,~l) => l*bos(f,n,m,l-1)*bos(f,n,m,t,t)+bos(f,n,m,l)*d(t) }$
%******************************************%
%*** module - actions  ********************%
%******************************************%
procedure rzut(rr,n);
       begin scalar ola,ewa;
       ola:=chan(rr);  ewa:=sub(d(-1)=0,d(-2)=0,d(-3)=0,d(-4)=0,ola);
       if n = 0 then return ewa;
       if n = 1 then  ewa:=ewa-sub(der(1)=0,der(2)=0,der(3)=0,d(1)=0,ewa);
       if n = 2 then  ewa:=ewa-sd_part(ewa,0,0)-sd_part(ewa,1,0)*der(1)-
       sd_part(ewa,2,0)*der(2)-sd_part(ewa,0,1)*d(1);
return ewa    end$
procedure sd_part(wr,n,m);
       begin scalar ewa,ola;
       ewa:=sub(d(1)=!@kk,d(2)=!@kk,d(-2)=!@ss,d(-1)=!@ss,
                 d(-3)=!@ss*d(-33),d(-4)=!@ss*d(-44),wr);
       ola:=if m greaterp 0 then coeffn(ewa,!@kk,m) else if m equal 0 then
       sub(!@ss=0,!@kk=0,ewa) else coeffn(ewa,!@ss,-m);
return s_part(sub(!@ss=1,!@kk=1,d(-33)=d(-3),d(-44)=d(-4),ola),n)  end$
procedure d_part(ww,n);
       begin scalar ewa,ola;
       ewa:=sub(d(1)=!@kk,d(2)=!@kk,d(-1)=!@ss,d(-2)=!@ss,
               d(-3)=!@ss*d(-33),d(-4)=d(-44)*!@ss,ww);
       ola:=if n greaterp 0 then coeffn(ewa,!@kk,n) else if n=0 then
       sub(!@kk=0,!@ss=0,ewa) else coeffn(ewa,!@ss,-n);
return sub(d(-33)=d(-3),d(-44)=d(-4),ola)   end$
procedure pr(n,ww);
       begin scalar ewa;
       if n=0 then ewa:=ww;            if n=1 then ewa:=der(1)*ww;
       if n=2 then ewa:=der(2)*ww;
       if n=3 then if abra_kadabra = 3 then ewa:=der(3)*ww else
        ewa:=der(1)*pr(2,ww);
return sub(der(1)=0,der(2)=0,der(3)=0,ewa)   end$
%*********************************%
%*** module adjoint     **********%
%*********************************%
% stp(1),stp(10),stp(20) if does not appeare der or apeapare der(1)*der(2);
% stp(2) if appeare der;
!@rak:={ stp(1)=1, stp(10)=1, stp(20)=1, stp(2)= - 1 }$
procedure cp(xwx);
       begin scalar kap,kap1,ess,k,l;
        if xwx equal 0 then return 0;kap:=length(xwx);
        if numberp(kap) then return cp1(xwx);
        kap1:=first kap;
        matrix !@z_z(kap1,kap1);matrix !@s_s(kap1,kap1);
        for k:=1:kap1 do for l:=1:kap1 do <<
        ess:=sub(!@krr=1,!@krr*xwx(k,l));!@z_z(k,l):=cp1(ess);  clear ess; >>;
        clear !@krr;!@s_s:=tp(!@z_z);clear !@z_z;  return !@s_s  end$
procedure cp1(yyz);
       begin scalar ewa,ola,xx,yyy;
if yyz equal 0 then return 0;  yyy:=if length(yyz) equal 1 and arglength(yyz)
equal -1 then !@*yyz else yyz; factor d,der,del;       ewa:=lyst(yyy);
ola:=for each xx in ewa collect
    begin scalar mew,wem,em1,em2,em,em3,licz,mian;
licz:=num(xx);mian:=den(xx); if numberp(licz) then return xx;
mew:=licz*stp(1);wem:=sub(!@rak,mew);em:=if part(wem,0) equal minus
then -1 else 1;
em1:= cp2(em*wem);
em2:=part(reverse(em1),0):=*;
        return em2*em/mian  end;   remfac d,der,del;
return sub(!@=1,part(ola,0):=+)  end$
procedure cp2(zz);
        begin scalar ewa,ola,ela,el1;
        if arglength(@*zz) equal 2 then return {zz};
        ewa:=(zz where tryk4);
        ola:=zz/ewa;
        ela:=if arglength(!@*ola) equal 2 then {ola} else part(ola,0):=list;
        el1:=append({ewa},ela);
        return el1  end$
%************************************%
%***  module O(2) invariance ********%
%************************************%
procedure odwa(wx);
       begin scalar ewa,ola;
       let tryk15; ewa:=sub(der(1)=-der(20),der(2)=der(10),
            del(1)=-del(20),del(2)=del(10),wx); clearrules tryk15;
       let tryk9;  ola:=ewa; clearrules tryk9;
return sub(der(10)=der(1),der(20)=der(2),del(10)=del(1),del(20)=del(2),ola) end$
%************************************%
%*** module - coefficients **********%
%************************************%
procedure lyst(wx);
       begin scalar ewa,ola,kap,kap1,adam;
       if wx=0 then return {0};
        factor d,der,del;kap:=length(wx);kap1:=arglength(wx);
       if kap equal 1 and kap1 equal -1 then return {wx};
        if kap1>kap then return {wx};  on div; ewa:=wx;
        if part(ewa,0) = plus then adam:=part(ewa,0):=list else
        adam:={ewa};off div; remfac d,der,del;return adam;   end$
procedure lyst1(wy);
       begin scalar ewa,ola;   ewa:=lyst(wy);
       ola:=(ewa where tryk3);return ola  end$
procedure lyst2(wy);
       begin scalar ewa,ola;   ewa:=lyst(wy);
       ola:=(ewa where tryk4);return ola  end$
%************************************%
%*** module - gradients *************%
%************************************%
procedure war(wa,f);
       begin scalar ewa,ola,adam,mew;
       let tryk;       ewa:=d(f)*wa-wa*d(f);   clearrules tryk;
       ola:=(ewa where tryk1);
       ewa:=sub(d(1)=0,der(1)=0,der(2)=0,der(3)=0,ola);
       if ewa=0 then return 0; adam:=lyst(ewa); mew:=(adam where tryk3);
        return if mew equal 0 then {} else mew  end$
procedure dyw(wa,f);
       begin scalar ewa,ola;
         ewa:=(d(f)*wa-wa*d(f) where tryk);
        ola:=(ewa where tryk2);
       ewa:=sub(d(1)=0,der(1)=0,der(2)=0,der(3)=0,ola);
       if ewa=0 then return 0;
return lyst(ewa) end$

procedure gra(wa,f);
        begin scalar ewa,ola;
        ewa:=(d(f)*wa-wa*d(f) where tryk); ola:=(ewa where tryk1);
       return sub(d(1)=0,der(1)=0,der(2)=0,der(3)=0,ola) end$
%***************************************%
%*** module - coordinates **************%
%***************************************%
procedure fpart(wx);
       begin scalar ewa,ola,adam;
       ewa:=if abra_kadabra = 2 then (wx where tryk5) else (wx where tryk16);
       ola:=sub(tet(1)=!#qw,tet(2)=!#qq,ewa);
       adam:= {coeffn(coeffn(ola,!#qw,0),!#qq,0),
               coeffn(coeffn(ola,!#qw,1),!#qq,0),
               coeffn(coeffn(ola,!#qw,0),!#qq,1),
               coeffn(coeffn(ola,!#qw,1),!#qq,1)};   return adam end$
procedure bpart(wx);
        begin scalar ewa,ola,adam;
        ewa:=if abra_kadabra = 2 then (wx where  tryk5) else (wx where tryk16);
        let tryk6; ola:=sub(tet(1)=!#qw,tet(2)=!#qq,ewa);clearrules tryk6;
       adam:= {coeffn(coeffn(ola,!#qw,0),!#qq,0),
               coeffn(coeffn(ola,!#qw,1),!#qq,0),
               coeffn(coeffn(ola,!#qw,0),!#qq,1),
               coeffn(coeffn(ola,!#qw,1),!#qq,1)};      return adam end$
%******************************************%
%*** module combinations ******************%
%******************************************%
procedure koza(wx,wi,wn);
        begin scalar ew1,ew2,am;
        ew3:=part(wx,3);ew1:=part(wx,1);
        am:=
if ew3 eq f and wi = 0 or ew3 eq f and wi = 3 then
                !@x_y*!@g_g(ew1,wi,wn) else
if ew3 eq f and wi = 1 or ew3 eq f and wi = 2 then
                !@x_y**2*!@f_f(ew1,wi,wn) else
if ew3 eq b and wi = 0 or ew3 eq b and wi = 3 then
                !@x_y**2*!@f_f(ew1,wi,wn) else
if ew3 eq b and wi = 1 or ew3 eq b and wi = 2 then
                !@x_y*!@g_g(ew1,wi,wn);  return am end$
procedure w_comb(as,m,a,bb);
       begin scalar kap,ewa,ola,wic,wid,wod,wod1,wx,k,s,!*precise;
        kap:=length(as);

       if m = 0 then return 0;if m = 0.5 then return w_comb1(as,a,bb);
       (!#l)^(m+1):=0;(!#l)^(m+1/2):=0;
       ewa:=for s:=0:floor(m) sum  for k:=1:kap sum
               (!#l)^(part(as,k,2)+s)*(koza(part(as,k),0,s)*2+
               (!#l)*koza(part(as,k),3,s)+
               (!#l)^(1/2)*koza(part(as,k),1,s)+
               (!#l)^(1/2)*koza(part(as,k),2,s));
       ola:=ewa;wic:=ewa;
       for k:=0:floor(m) do << ola:=ewa*ola;
       ewa:=for s:=0:m-k+1 sum  for r:=1:kap sum
                         (!#l)^(part(as,r,2)+s)*(koza(part(as,r),0,s)*2+
                         (!#l)*koza(part(as,r),3,s)+
                         (!#l)^(1/2)*koza(part(as,r),1,s)+
                         (!#l)^(1/2)*koza(part(as,r),2,s)); wic:=wic+ola;>>;
       wid:=sub((!#l)=(!#ll)^2,wic); wod:=coeffn(wid,(!#ll),2m);
       wod:=if bb eq b then  sub(!@x_y=0,wod) else
            if bb eq f then  coeffn(wod,!@x_y,1);
        wod1:=lyst((wod where tryk7));  clear (!#l)^(m+1),(!#l)^(m+1/2);
       kap:=length(wod1);ewa:=0; for k:=1:kap do <>;
return ewa end$

procedure w_comb1(as,a,bb);
begin scalar ew,kap1,ew1,kap;
kap:=length(as);
ew:=for n:=1:kap join
if part(as,n,2) neq  1/2 then  {} else
if part(as,n,3) eq f and bb eq f then {fer(part(as,n,1),0,0)} else
if part(as,n,3) eq f and bb eq b then {} else
if part(as,n,3) eq b and bb eq f then {} else
if part(as,n,3) eq b and bb eq b then {bos(part(as,n,1),0,0)};
kap1:=length(ew);
ew1:=if kap1 = 0 then 0 else
for n:=1:kap1 sum mkid(a,n)*part(ew,n);
return ew1 end$

procedure fcomb(as,n,b,bb);
       begin scalar ewa,ola,ala,k,kap,wx,wy,kap1,wod,wod1,ema,wz,wz1;
       operator b;ewa:=w_comb(as,n,a,bb);kap:=length(as);ala:={};
       wz:=ewa;wz1:=ewa;ema:={};
       for k:=1:kap do << wz:=sub(part(as,k,1)=0,wz);
       wx:=wz1-wz; wz1:=wz;ema:=append(ema,{{wx}});>>;
       for k:=1:kap do << wx:=dyw(part(ema,k,1),part(as,k,1));
       wy:=if wx=0 then {} else wx;
       ala:=append(ala,wy);>>; kap1:=length(ala); ewa:=0;
       for k:=1:kap1 do << wod:=part(ala,k);
       wod1:=(wod where tryk3);ewa:=ewa+b(k)*wod/wod1;>>; return ewa end$

procedure pse_ele(n,ww,ss);
       begin scalar ewa,ola,kap,k,maj,maj1,ela;
       ewa:=0;
        operator ss;
        for k:=1:n do << ewa:=ewa+
(w_comb(ww,k,mkid(mkid(a,k),a),b)+
 w_comb(ww,k-1/2,mkid(mkid(a,k),b),f)*der(1) +
 w_comb(ww,k-1/2,mkid(mkid(a,k),c),f)*der(2)+
 w_comb(ww,k-1,mkid(mkid(a,k),d),b)*(if abra_kadabra = 3 then
der(3) else  der(1)*der(2)))*d(1)**(n-k);>>;
        remfac fer,bos; kap:=length(ewa); ola:=0;
        for k:=1:kap do << maj:=if ewa = 0 then 0 else
        if kap equal 1 then ewa else part(ewa,k);
        maj1:=if maj = 0 then 1 else (maj where tryk4);
        ola:=ola+ss(k+1)*maj/maj1;>>;
        ela:=ss(0)*d(1)**n+ss(1)*(if abra_kadabra = 3 then der(3) else
        der(1)*der(2))*d(1)**(n-1)+ola;factor fer,bos;
        if abra_kadabra = 3 then ela:=(ela where {der(1)*der(2) => der(3)});
       return ela end$
%********************************************%
%*** module jacobi  *************************%
%********************************************%
%wim as {bos(f)=>expression};
procedure n_gat(pp,wim);
        begin scalar kap,niech,zyje;
       kap:=length(wim);
       niech:=gato(pp); let wim;zyje:=(niech where tryk10);
        clearrules wim;
       return zyje end$
procedure gato(p);
       begin scalar as,ess,mess;
       if numberp(length(p)) then return gat1(p);
       as:=first length(p);       matrix !#zz(as,as);
       for k:=1:as do   for l:=1:as do
        << ess:=(!#zab*p(k,l) where tryk8);
   mess:=(ess/!#zab where tryk9);!#zz(k,l):=sub(eps=0,df(mess,eps));>>;
       return !#zz   end$
procedure gat1(p);
       begin scalar ess,zz,mess;
        ess:=(p  where tryk8);  mess:=(ess where tryk9);
       zz:=sub(eps=0,df(mess,eps)); return zz end$
% p is a hamiltonian operator in d,der;
% w is a list of functions with the ordering such way that
%first corresponds to the (1,1) element of p corresponds to {f,f};
% m is a list of components of the test vecor functions;
procedure fjacob(p,w);
        begin scalar as,as1,es1,wod0,wod1,wod2,wod3,wodx;
       if numberp(length(p)) then return jacob1(p,w);
       as:=first length(p); matrix !#ala(as,as),!#ela(as,as);
       !#ala:=gato(p);   operator !#a,!#b,!#c;
       as1:=for k:=1:as collect for l:=1:as sum
               sub(d(1)=0,der(1)=0,der(2)=0,p(k,l)*bos(!#b(l),0,0));
       for k:=1:as do << bos(part(w,k)):=part(as1,k);>>;
       !#ela:=(!#ala where tryk10);
       wod:=for k:=1:as sum for l:=1:as sum
                bos(!#c(k),0,0)*!#ela(k,l)*bos(!#a(l),0,0);
       wod1:=sub(d(1)=0,der(1)=0,der(2)=0,wod);
%permutation;
wodx:=(wod1 where tryk11); wod2:=(wodx where tryk12);
wod3:=(wodx where tryk13); return wod1+wod2+wod3 end$
procedure jacob(p,w,m);
        begin scalar woda;
        woda:=for wx:=1:3 sum
        begin scalar trys,as1,as,wod;
      operator !#a,!#b,!#c,!@a,!@b,!@c;
        as:=first length(p);
       trys:=for k:=1:as join {
       !@a(k)=if k equal first(m) then !#a(k) else 0,
       !@b(k)=if k equal second(m) then !#b(k) else 0,
       !@c(k)=if k equal third(m) then !#c(k) else 0};
       let trys; matrix !@ala(as,as),!@ela(as,as);
        !@ala:=gato(p);
       as1:=for k:=1:as collect for l:=1:as sum
               sub(d(1)=0,der(1)=0,der(2)=0,p(k,l)*bos(
        if wx = 1 then !@b(l) else
        if wx = 2 then !@c(l) else
        if wx = 3 then !@a(l),0,0));
       for k:=1:as do <<  bos(part(w,k)):=part(as1,k);>>;
       !@ela:=(!@ala where tryk10);
       wod:=for k:=1:as sum for l:=1:as sum
bos(if wx = 1 then !@c(k) else
    if wx = 2 then !@a(k) else
    if wx = 3 then !@b(k),0,0)*!@ela(k,l)*
bos(if wx = 1 then !@a(l) else
    if wx = 2 then !@b(l) else
    if wx = 3 then !@c(l),0,0);
        for k:=1:as do clear  !@a(k),!@b(k),!@c(k),bos(part(w,k));
        return sub(d(1)=0,der(1)=0,der(2)=0,wod)  end;  return woda end$
procedure jacob1(p,w);
        begin scalar ala,ela,wod,wod1,wod2,wodx,ewa;
        ala:=gat1(p);bos(w):=sub(d(1)=0,der(1)=0,der(2)=0,p*bos(!#b,0,0));
let tryk10;ela:=ala;clearrules tryk10;wod:=bos(!#c,0,0)*ela*bos(!#a,0,0);
       wod1:=sub(d(1)=0,der(1)=0,der(2)=0,wod);
%permutation;
        wodx:=sub(!#a=!#aa,!#b=!#bb,!#c=!#cc,wod1);
        wod2:=sub(!#aa=!#b,!#bb=!#c,!#cc=!#a,wodx);
        wod3:=sub(!#aa=!#c,!#bb=!#a,!#cc=!#b,wodx);
        clear bos(w);
        return wod1+wod2+wod3 end$
%************************************************
%********* module macierz ***********************
%************************************************
%wx pse_ele
%xx f (fermion)  or b (boson)
%yy bosonic part or fermionic part
procedure macierz(wx,xx,yy);
        begin scalar ewa,ola,ew1,ew2;
        matrix !@z_z_x(4,4);   ewa:=if xx eq f then
 sub(der(1)=0,der(2)=0,der(3)=0,d(1)=0,wx*fer(!#z_z,0,0)) else
 if xx eq b then sub(der(1)=0,der(2)=0,der(3)=0,d(1)=0,wx*bos(!#z_z,0,0)) else
        rederr "wrong value of second  argument which should be b or f";
 ola:=if yy eq b then bpart(ewa) else if yy eq f then fpart(ewa) else
        rederr "wrong value of third  argument which should be b or f";
        ew1:=(ola where
        {fun(!#z_z0,~n) => ber(1,n),fun(!#z_z1,~n) => ber(2,n),
gras(!#z_z!#z_z1,~n) => fir(1,n),gras(!#z_z!#z_z2,~n) => fir(2,n)});
        ew2:=(ew1 where {
        ber(1,~n) => !#s_s*d(1)^n, ber(2,~n) => !#s_s^4*d(1)^n,
        fir(1,~n) => !#s_s^2*d(1)^n,fir(2,~n) => !#s_s^3*d(1)^n});
for k:=1:4 do for l:=1:4 do !@z_z_x(k,l):=chan(coeffn(part(ew2,k),!#s_s,l));
        return !@z_z_x end$

%********************************************%
%*** module dot_ham *************************%
%********************************************%
procedure dot_ham(ww,mm);
       begin scalar ewa,ola,ala,as;
       as:=length(ww); ewa:=d(t)*mm-mm*d(t);
        for k:=1:as do bos(part(part(ww,k),1),t):=part(part(ww,k),2);
       ola:=(ewa where tryk14);
       for k:=1:as do clear bos(part(part(ww,k),1),t);
return ola end$
%module supersymmetric integration

%############################################################################
%#########    F U N C T I O N A L    S U S Y   I N T E G R A T I O N   ######
%#########           O N L Y    F O R   T R A D                        ######
%############################################################################
%  s_int(number,expression,variable)
%  numbers corespond to integration over: 0 => d(1),
%  1=> der(1), 2=> der(2), 3 => der(1)*der(2)
%  variable {f,g,...} the names of the superfunctions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% G L O B A L   A C T I O N %%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
let {
waga(~k,~s,~m) =>
2*m+delta(k,s)+2*delta(3,s)+delta(3-k,s)*(if m>0 then 1 else 0),
        s_s(~f,~n) =>1, s_s(1,~f,~n)   => 1,
der(1)*del(-1)=>1,      der(2)*del(-2) => 1,       der(3)*del(-3) =>1,
del(0)=>d(-3),          der(1)*del(-3) => 1,       der(2)*del(-3) =>del(-3),
der(1)*der(2)*del(-3)=>1
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%&&&&&&&&&&&&&&&&&
%%%% L O C A L    A C T I O N %%%%%%%%%%%%%%%%&&&&&&&&&&&&&&&&&
%##############################################################
%%%%%%%%%%%%%%%%%%%%%%%         n_dyw    %%%%%%%%%%%%%%%%%%%%%%
%##############################################################
%scaling
dryk:=  {d(~f,~n)*fer(~g,~k,~m) => fer(g,k,m)*d(f,n+delta(f,g)),
         d(~f,~n)*bos(~g,~k,~m) => bos(g,k,m)*d(f,n+delta(f,g)),
         d(~f,~n)*zan(~g,~k,~m) => zan(g,k,m)*d(f,n+1),
         d(~f,~n)*zen(~g,~k,~m) => zen(g,k,m)*d(f,n+1)
}$
%wariation
wariat_0:={
        zen(~f,~k,~n) => (-1)^n*fer(f,k,0)*d(1)^n,
        zan(~f,~k,~n) => (-1)^n*bos(f,k,0)*d(1)^n
}$
wariat_1:={
        zen(~f,~k,~n) => if k = 3 or k = 1 then
(-1)^(n+1)*bos(f,k-1,0)*der(1)*d(1)^n else (-1)^n*fer(f,k,0)*d(1)^n ,

        zan(~f,~k,~n) => if k = 3 or k = 1 then
(-1)^n*fer(f,k-1,0)*der(1)*d(1)^n else (-1)^n*bos(f,k,0)*d(1)^n
}$
wariat_2:={
        zen(~f,~k,~n) => if k = 3 or k = 2 then
(-1)^(k-1+n)*bos(f,k-2,0)*der(2)*d(1)^n else (-1)^n*fer(f,k,0)*d(1)^n ,

        zan(~f,~k,~n) => if k = 3 or k = 2 then
(-1)^(k+n)*fer(f,k-2,0)*der(2)*d(1)^n else (-1)^n*bos(f,k,0)*d(1)^n
}$
wariat_3:={
zen(~f,0,~n) =>  if n > 1 then  (-1)^(n-1)*(-fer(f,0,0)*d(1)^n
                + n*d(1)*fer(f,0,0)*d(1)^(n-1)) else fer(f,0,n) ,
zen(~f,1,~n) =>
        (-1)^n*(fer(f,1,0)*d(1)^n + n*d(1)*bos(f,0,0)*der(1)*d(1)^(n-1)),
zen(~f,2,~n) =>
        (-1)^n*(fer(f,2,0)*d(1)^n + n*d(1)*bos(f,0,0)*der(2)*d(1)^(n-1)),
zen(~f,3,~n)  =>
        -zen(f,0,n)*der(1)*der(2) + zan(f,1,n)*der(2) - zan(f,2,n)*der(1),

zan(~f,0,~n) =>  if n>1 then (-1)^(n-1)*(-bos(f,0,0)*d(1)^n
                + n*d(1)*bos(f,0,0)*d(1)^(n-1)) else bos(f,0,n),
zan(~f,1,~n) =>
        (-1)^n*(bos(f,1,0)*d(1)^n - n*d(1)*fer(f,0,0)*der(1)*d(1)^(n-1)),
zan(~f,2,~n) =>
        (-1)^n*(bos(f,2,0)*d(1)^n - n*d(1)*fer(f,0,0)*der(2)*d(1)^(n-1)),
zan(~f,3,~n)  =>
        -zan(f,0,n)*der(1)*der(2) - zen(f,1,n)*der(2)+zen(f,2,n)*der(1)
}$
%###########################################################
%%%%%%%%%%%%%%%%%%%%%%          maxi     %%%%%%%%%%%%%%%%%%%
%###########################################################
szukaj0:={
byk(~n,~g)*fer(~f,~k,~m) => if n<=2*m then fer(f,k,m)*byk(2*m,f)
                                        else fer(f,k,m)*byk(n,g),
byk(~n,~g)*bos(~f,~k,~m) => if n<=2*m then bos(f,k,m)*byk(2*m,f)
                                        else bos(f,k,m)*byk(n,g)
}$
szukaj1:={
byk(~k,~g)*fer(~f,~n,~m) => if k <= waga(1,n,m) then
        fer(f,n,m)*byk(waga(1,n,m),f) else fer(f,n,m)*byk(k,g),

byk(~k,~g)*bos(~f,~n,~m) =>if k <= waga(1,n,m) then
        bos(f,n,m)*byk(waga(1,n,m),f) else bos(f,n,m)*byk(k,g)
}$
szukaj2:={
byk(~k,~g)*fer(~f,~n,~m) => if k <= waga(2,n,m) then
        fer(f,n,m)*byk(waga(2,n,m),f) else fer(f,n,m)*byk(k,g),

byk(~k,~g)*bos(~f,~n,~m) => if k<= waga(2,n,m) then
        bos(f,n,m)*byk(waga(2,n,m),f) else bos(f,n,m)*byk(k,g)
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
szukaj3:={
byk(~k,~g)*fer(~f,0,~m) => if m < 2 then fer(f,0,m)*byk(k,g) else
<< if k <= 2*m then fer(f,0,m)*byk(2*m,f) else  fer(f,0,m)*byk(k,g) >>,

byk(~k,~g)*fer(~f,1,~m) => if m < 1 then fer(f,1,m)*byk(k,g) else
<< if k <= 2*m+1 then fer(f,1,m)*byk(2*m+1,f) else fer(f,1,m)*byk(k,g) >>,

byk(~k,~g)*fer(~f,2,~m) => if m < 1 then fer(f,2,m)*byk(k,g) else
<< if k <= 2*m+1 then fer(f,2,m)*byk(2*m+1,f) else fer(f,2,m)*byk(k,g) >> ,

byk(~k,~g)*fer(~f,3,~m) => if k <= 2*m+2 then fer(f,3,m)*byk(2*m+2,f)
                else fer(f,3,m)*byk(k,g),

byk(~k,~g)*bos(~f,0,~m) => if m < 2 then bos(f,0,m)*byk(k,g) else
<< if k <= 2*m then bos(f,0,m)*byk(2*m,f) else   bos(f,0,m)*byk(k,g) >> ,

byk(~k,~g)*bos(~f,1,~m) => if m < 1 then bos(f,1,m)*byk(k,g) else
<< if k <= 2*m+1 then bos(f,1,m)*byk(2*m+1,f) else bos(f,1,m)*byk(k,g) >>,

byk(~k,~g)*bos(~f,2,~m) => if m < 1 then bos(f,2,m)*byk(k,g) else
<< if k <= 2*m+1 then bos(f,2,m)*byk(2*m+1,f) else bos(f,2,m)*byk(k,g) >>,

byk(~k,~g)*bos(~f,3,~m) => if k<=2*m+2 then bos(f,3,m)*byk(2*m+2,f)
                else bos(f,3,m)*byk(k,g)
}$
%###########################################################################
poszukaj0:={
fer(~f,~s,~m)*r_r(~k,~g) => if k = 2*m and g equal f then
                        r_r(2*m,f)*zen(f,s,m) else r_r(k,g)*fer(f,s,m),
bos(~f,~s,~m)*r_r(~k,~g) => if k = 2*m and g equal f then
                        r_r(2*m,f)*zan(f,s,m) else r_r(k,g)*bos(f,s,m)
}$
poszukaj1:={
fer(~f,~s,~m)*r_r(~k,~g) => if k = waga(1,s,m) and g equal f
        then r_r(k,f)*zen(f,s,m) else r_r(k,g)*fer(f,s,m) ,

bos(~f,~s,~m)*r_r(~k,~g) => if k = waga(1,s,m) and g equal f
        then r_r(k,f)*zan(f,s,m) else r_r(k,g)*bos(f,s,m)
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
poszukaj2:={
fer(~f,~s,~m)*r_r(~k,~g) => if k = waga(2,s,m) and g equal f
        then r_r(k,f)*zen(f,s,m) else r_r(k,g)*fer(f,s,m),

bos(~f,~s,~m)*r_r(~k,~g) => if k = waga(2,s,m) and g equal f
        then r_r(k,f)*zan(f,s,m) else r_r(k,g)*bos(f,s,m)
}$
poszukaj3:={
fer(~f,0,~m)*r_r(~k,~g) => if m < 2 then  r_r(k,g)*fer(f,0,m) else
        << if k = 2*m and f equal g then r_r(1,2*m,f)*zen(f,0,m)
                else r_r(k,g)*fer(f,0,m) >>,
fer(~f,1,~m)*r_r(~k,~g) => if m < 1 then r_r(k,g)*fer(f,1,m) else
        <>,
fer(~f,2,~m)*r_r(~k,~g) => if m < 1 then r_r(k,g)*fer(f,2,m) else
        << if k = 2*m+1 and f e        qual g then r_r(1,2*m+1,f)*zen(f,2,m) else
        r_r(k,g)*fer(f,2,m) >> ,
fer(~f,3,~m)*r_r(~k,~g) => if k = 2*m+2 and f equal g then
        r_r(1,2*m+2,f)*zen(f,3,m) else r_r(k,g)*fer(f,3,m),


bos(~f,0,~m)*r_r(~k,~g) => if m < 2 then  r_r(k,g)*bos(f,0,m) else
        << if k = 2*m and f equal g then r_r(1,2*m,f)*zan(f,0,m)
                else r_r(k,g)*bos(f,0,m) >>,
bos(~f,1,~m)*r_r(~k,~g) => if m < 1 then r_r(k,g)*bos(f,1,m) else
        << if k = 2*m+1 and f equal g then r_r(1,2*m+1,f)*zan(f,1,m)
                else r_r(k,g)*bos(f,1,m) >>,
bos(~f,2,~m)*r_r(~k,~g) => if m < 1 then r_r(k,g)*bos(f,2,m) else
        << if k = 2*m+1 and f e        qual g then r_r(1,2*m+1,f)*zan(f,2,m)
                else r_r(k,g)*bos(f,2,m) >> ,
bos(~f,3,~m)*r_r(~k,~g) => if k = 2*m+2 and f equal g then
        r_r(1,2*m+2,f)*zan(f,3,m) else r_r(k,g)*bos(f,3,m)

}$
%#######################################################################
%%%%%%%%%%%%%%%%%%%%% I N T E G R A T I O N  %%%%%%%%%%%%%%%%%%%%%%%%%%%
%#######################################################################
calkuj0:={
zen(~f,~n,~m) => fer(f,n,m-1),zan(~f,~n,~m) => bos(f,n,m-1)
}$
pocalkuj0:={
zen(~f,~n,~m) => -fer(f,n,m-1)*d(1),
zan(~f,~n,~m) => -bos(f,n,m-1)*d(1)
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
calkuj1:={
zen(~f,~k,~n) => if k = 3 or k = 1 then bos(f,k-1,n) else
        if k = 0 and n > 0 or k = 2 and n > 0 then bos(f,k+1,n-1),
zan(~f,~k,~n) => if k = 3 or k = 1 then fer(f,k-1,n) else
        if k = 0 and n > 0 or k = 2 and n > 0 then fer(f,k+1,n-1)
}$
pocalkuj1:={
zen(~f,~k,~n) =>  if k = 3 or k = 1 then -bos(f,k-1,n)*der(1) else
    if k = 0 and n > 0 or k = 2 and n > 0 then -bos(f,k+1,n-1)*der(1),
zan(~f,~k,~n) =>  if k = 3 or k = 1 then fer(f,k-1,n)*der(1) else
    if k = 0 and n > 0 or k = 2 and n > 0 then fer(f,k+1,n-1)*der(1)
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
calkuj2:={
zen(~f,~k,~n) =>   if k = 3 or k = 2 then (-1)^k*bos(f,k-2,n) else
    if k = 0 and n > 0 or k = 1 and n > 0 then  (-1)^k*bos(f,k+2,n-1) ,
zan(~f,~k,~n) =>   if k = 3 or k = 2 then (-1)^k*fer(f,k-2,n) else
    if k = 0 and n > 0 or k = 1 then (-1)^k*fer(f,k+2,n-1)
}$
pocalkuj2:={
zen(~f,~k,~n) => if k = 3 or k = 2 then    -(-1)^k*bos(f,k-2,n)*der(2) else
if k = 0 and n > 0 or k = 1 and n > 0 then -(-1)^k*bos(f,k+2,n-1)*der(2) ,
zan(~f,~k,~n) =>   if k = 3 or k = 2 then  (-1)^k*fer(f,k-2,n)*der(2) else
if k = 0 and n > 0 or k = 1 and n > 0 then (-1)^k*fer(f,k+2,n-1)*der(2)
}$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
calkuj3:={
zen(~f,0,~n) => if n < 2 then fer(f,0,n) else -fer(f,3,n-2),
zen(~f,1,~n) => if n < 1 then fer(f,1,0) else  fer(f,2,n-1),
zen(~f,2,~n) => if n < 1 then fer(f,2,0) else -fer(f,1,n-1),
zen(~f,3,~n) => fer(f,0,n),

zan(~f,0,~n) => if n < 2 then fer(f,0,n) else -bos(f,3,n-2),
zan(~f,1,~n) => if n < 1 then fer(f,1,0) else  bos(f,2,n-1),
zan(~f,2,~n) => if n < 1 then fer(f,2,0) else -bos(f,1,n-1),
zan(~f,3,~n) => bos(f,0,n)
}$
pocalkuj3:={
zen(~f,0,~n) => -bos(f,2,n-1)*der(2)-bos(f,1,n-1)*der(1)+
                        fer(f,3,n-2)*der(1)*der(2) ,
zen(~f,1,~n) =>  bos(f,3,n-1)*der(2)-bos(f,0,n)*der(1)-
                        fer(f,2,n-1)*der(1)*der(2) ,
zen(~f,2,~n) => -bos(f,0,n)*der(2)-bos(f,3,n-1)*der(1)+
                        fer(f,1,n-1)*der(1)*der(2),
zen(~f,3,~n) =>   -fer(f,0,n)*der(1)*der(2)+bos(f,1,n)*der(2)-bos(f,2,n)*der(1),

zan(~f,0,~n) => bos(f,3,n-2)*der(1)*der(2)+fer(f,2,n-1)*der(2)+
                        fer(f,1,n-1)*der(1),
zan(~f,1,~n) => -fer(f,3,n-1)*der(2)+fer(f,0,n)*der(1)-
                        bos(f,2,n-1)*der(1)*der(2) ,
zan(~f,2,~n) => fer(f,3,n-1)*der(1)+fer(f,0,n)*der(2)+
                        bos(f,1,n-1)*der(1)*der(2) ,
zan(~f,3,~n) => -bos(f,0,n)*der(1)*der(2)-fer(f,1,n)*der(2)+fer(f,2,n)*der(1)
}$
%$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
%$$$$$                                          $$$$$$
%$$$$$           P R O C E D U R E S               $$$$$$
%$$$$$                                          $$$$$$
%$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
%%%%%%%%%%%%%%%%%           one maximum   %%%%%%%%%%%%%%%%%%%%%
procedure maxi(wrt,wx);
        begin scalar kr,kr1,ew1,ew2,ew3,ew4,ew5;
if wx equal 0 then return {0,0};
                kr:=num wx;                kr1:=den wx;
ew1:=(byk(0,0)*kr where (help!* := mkid(szukaj,wrt)));
        ew2:=(ew1 where {byk(~n,~f) => (!l_a_!@m)^n*p_p(n,f)});
                ew2:=sub(p_p=r_r,lcof(ew2,!l_a_!@m));
                        ew2:=(ew2 where (help!* := mkid(poszukaj,wrt)));
                                ew3:=sub(r_r=s_s,ew2);
ew1:=if part(ew3,0) equal minus then -1 else 1;
        ew4:=sub(x_x=0,if length(ew1*ew3) < arglength(ew1*ew3)
        then ew1*ew3 else part(ew1*ew3+x_x,1));
                  ew5:=kr-sub(zen=fer,zan=bos,ew1*ew4);
                        return {ew1*ew4/kr1,ew5/kr1} end$
%#################################################################
%%%%%%%%%%%%%%%%%     dywergent terms  %%%%%%%%%%%%%%%%%%%%%%%%%%%
%#################################################################
procedure n_dyw(wrt,wx,wz);
        begin scalar eks0,eks,eks1,eks2,osa1,osa2,osa3,osa4;
kap:=length wz;
        eks:=num wx;             eks0:=den wx;
                eks1:=if part(eks,0) equal minus then -1 else 1;
                        eks2:=eks1*eks;osa4:=0;
for k:=1:kap do <<
osa1:=eks2-sub(part(wz,k)=0,eks2);
        eks2:=eks2-osa1;
                osa2:=sub(d(part(wz,k))=0,(d(part(wz,k))*osa1 where tryk));
%scaling
osa3:=(d(part(wz,k),0)*osa2 where dryk);
        osa3:=(osa3 where {d(~f,~n) => 1/n when n>0});
%end scaling
osa3:=sub(der(1)=0,d(1)=0,der(3)=0,der(2)=0,
                           (osa3 where (help!* := mkid(wariat_,wrt))));
                        osa4:=osa4+osa3;
>>;
        return {wx-eks1*osa4/eks0,eks1*osa4/eks0} end$
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
%***************                        *******************************
%***************      MAIN PROCEDURE    *******************************
%***************                        *******************************
%&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
procedure s_int(wrt,wx,wz);
        begin scalar kak,kak1,kak2,pak,pak1,pak2,kap,pak3,pak4;
if wx equal 0 then return 0;
if abra_kadabra equal 1 and wrt > 0 or abra_kadabra equal 3
and wrt > 0 then
rederr " **** I T is Impossible to define in a proper
manner this integral => use trad representation for computation only";
        kak:=n_dyw(wrt,wx,wz);
                                kak1:=first kak;
                                        kak2:=second kak;
%if kak2 neq 0 then return del(-wrt)*wx;
pak:=hom(kak1);
        pak1:=first first pak;            pak2:=second pak;
                kap:=length pak2;
pak3:=if pak2 equal 0 then 0 else for k:=1:kap sum cal(wrt,part(pak2,k));
        pak4:= pak1*pak3+del(-wrt)*kak2 ;
                        return pak4   end$
procedure cal(wrt,wx);
        begin scalar wem,wem1,wem2,wem3,wem4,wem5,wem6,z_z_z;
if wx equal 0 then return 0;
        wem:=maxi(wrt,wx);      wem1:=first(wem);        wem2:=second(wem);
                                z_z_z:=0;
while wem1 neq 0 do <<
wem3:=sub(zen=fer,zan=bos,wem1);
    wem4:=(wem1 where (help!* := mkid(calkuj,wrt)));
           wem5:=sub(der(3)=0,der(1)=0,d(1)=0,der(2)=0,(-wem1 where
                (help!* := mkid(pocalkuj,wrt))));
if wem4 = 0 then
z_z_z:=z_z_z+del(-wrt)*wem3 else   <<
        xxx:=(-!l_a_!@m*wem4+wem3+wem5 where {wem3=>koz});
                wem6:=(rhs first solve(xxx,koz));clear xxx;
                        z_z_z:=z_z_z+coeffn(wem6,!l_a_!@m,1);
wem6:=sub(!l_a_!@m=0,wem6);            wem2:=wem2+wem6  >>;
wem6:=maxi(wrt,wem2);
        wem1:=first wem6;         wem2:=second wem6;
>>;
        return z_z_z                    end$

procedure hom(wx);
        begin scalar zet1,zet2,iks,iks1,iks2;
if wx equal 0 then return {{0},0};
        iks:=num wx;iks2:=den wx;
                iks1:=if part(iks,0) equal minus then -1 else 1;
                        iks:=iks1*iks;
zet1:=(iks where {
fer(~f,~k,~n) => !&a(f)*!&a(!@)^(2n+(if k = 1 or k = 2 then 1 else
                                if k = 3 then 2 else 0))*zen(f,k,n),
bos(~f,~k,~n) => !&a(f)*!&a(!@)^(2n+(if k = 1 or k = 2 then 1 else
                                if k = 3 then 2 else 0))*zan(f,k,n)});
        zet2:=part(zet1+x_x,0):=list;
                 zet1:=reverse rest reverse zet2;
return {{iks1/iks2},sub(zen=fer,zan=bos,(zet1 where
                                {!&a(~f) =>1,!&a(!@) => 1}))}
end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% D E C L A R A T I O N %%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
let trad;


endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/susy2/susy2.rlg0000644000175000017500000063746711527635055023427 0ustar  giovannigiovanniFri Feb 18 21:28:38 2011 run on win32
on list;


on errcont;



% 1.) Example of ordering of objects such as fer,bos,axp;
axp(bos(f,0,0))*bos(g,3,1)*fer(k,1,0);


fer(k,1,0)*bos(g,3,1)*axp(bos(f,0,0))

%fer(k,1,0)*bos(g,3,1)*axp(bos(f,0,0));

% 2.) Example of ordering of fer and fer objects
fer(f,1,2)*fer(f,1,2);


0

% 0
fer(f,1,2)*fer(g,2,3);



-fer(g,2,3)*fer(f,1,2)

% -fer(g,2,3)*fer(f,1,2);
fer(f,1,2)*fer(f,1,3);



-fer(f,1,3)*fer(f,1,2)

% - fer(f,1,3)*fer(f,1,2);
fer(f,1,2)*fer(f,2,2);



-fer(f,2,2)*fer(f,1,2)

% - fer(f,2,2)*fer(f,1,2);

% 3.) Example of ordering of bos and bos objects;
bos(f,3,0)*bos(g,0,4);


bos(g,0,4)*bos(f,3,0)

%bos(g,0,4)*bos(f,3,0);
bos(f,3,0)*bos(f,0,0);


bos(f,3,0)*bos(f,0,0)

%bos(f,3,0)*bos(f,0,0);
bos(f,3,2)*bos(f,3,5);


bos(f,3,5)*bos(f,3,2)

%bos(f,3,5)*bos(f,3,2);

% 4.) ordering of inverse superfunctions;
% last index in bos objects denotes powers;
bos(f,0,3)*bos(k,0,2)*bos(zz,0,3,-1)*bos(k,0,2,-1);


bos(zz,0,3,-1)*bos(f,0,3)

%bos(zz,0,3,-1)*bos(f,0,3);
bos(c,0,3)*bos(b,0,2)*bos(a,0,3,-1)*bos(b,0,2,-1);


bos(c,0,3)*bos(a,0,3,-1)

%bos(c,0,3)*bos(a,0,3,-1);

% 5.) Demostration of inverse rule;
let inverse;


bos(f,0,3)**3*bos(k,3,1)**40*bos(f,0,3,-2);


bos(k,3,1,40)*bos(f,0,3,1)

%bos(k,3,1,40)*bos(f,0,3,1);
clearrules inverse;




% 6.) Demonstration of (susy) derivative operators;
% Up to now we did not decided on the chirality assumption
% so let us check first the tradicional algebra os susy derivative;
let trad;



%first susy derivative
der(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));


bos(g,3,1)*bos(f,0,3)*axp(bos(h,0,0))

-fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0))*der(1)

+fer(g,2,2)*fer(f,1,2)*axp(bos(h,0,0))

+fer(h,1,0)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0))


fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*del(1);


bos(g,3,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

+2*fer(g,2,1)*fer(f,1,2)*bos(f,0,2,-3)*axp(fer(k,1,2)*fer(h,2,1))

+fer(h,2,1)*fer(g,2,1)*bos(k,0,3)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

-fer(k,1,2)*fer(g,2,1)*bos(h,3,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

-del(1)*fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

sub(del=der,ws);


fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*der(1)


%second susy derivative
der(2)*fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0));


bos(kk,0,3)*bos(g,0,4)*axp(bos(f,3,0))

-fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0))*der(2)

+fer(g,2,3)*fer(f,1,1)*bos(kk,0,3)*axp(bos(f,3,0))

+fer(kk,2,3)*fer(g,2,3)*axp(bos(f,3,0))


fer(r,2,1)*bos(kk,3,4,-4)*axp(fer(f,1,2)*fer(g,2,1))*del(2);


bos(r,0,2)*bos(kk,3,4,-4)*axp( - fer(g,2,1)*fer(f,1,2))

+fer(r,2,1)*fer(f,1,2)*bos(kk,3,4,-4)*bos(g,0,2)*axp( - fer(g,2,1)*fer(f,1,2))

+fer(r,2,1)*fer(g,2,1)*bos(kk,3,4,-4)*bos(f,3,2)*axp( - fer(g,2,1)*fer(f,1,2))

-4*fer(r,2,1)*fer(kk,1,5)*bos(kk,3,4,-5)*axp( - fer(g,2,1)*fer(f,1,2))

-del(2)*fer(r,2,1)*bos(kk,3,4,-4)*axp( - fer(g,2,1)*fer(f,1,2))

sub(del=der,ws);


fer(r,2,1)*bos(kk,3,4,-4)*axp( - fer(g,2,1)*fer(f,1,2))*der(2)


%usual derivative;
d(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));


fer(f,1,3)*bos(g,3,1)*axp(bos(h,0,0))

+fer(f,1,2)*bos(g,3,2)*axp(bos(h,0,0))

+fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0))*d(1)

+fer(f,1,2)*bos(h,0,1)*bos(g,3,1)*axp(bos(h,0,0))

fer(g,2,1)*bos(f,0,2,-2)*axp(fer(h,1,2)*fer(k,2,1))*d(2);



-fer(g,2,2)*bos(f,0,2,-2)*axp( - fer(k,2,1)*fer(h,1,2))

+2*fer(g,2,1)*bos(f,0,3,1)*bos(f,0,2,-3)*axp( - fer(k,2,1)*fer(h,1,2))

+fer(k,2,2)*fer(h,1,2)*fer(g,2,1)*bos(f,0,2,-2)*axp( - fer(k,2,1)*fer(h,1,2))

+fer(k,2,1)*fer(h,1,3)*fer(g,2,1)*bos(f,0,2,-2)*axp( - fer(k,2,1)*fer(h,1,2))

+d(2)*fer(g,2,1)*bos(f,0,2,-2)*axp( - fer(k,2,1)*fer(h,1,2))

sub(d(2)=d(1),ws);


fer(g,2,1)*bos(f,0,2,-2)*axp( - fer(k,2,1)*fer(h,1,2))*d(1)


% 7.) the value of action of (susy) derivative;

xxx:=fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3));


xxx := fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

yyy:=fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3));


yyy := fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3))


%first susy derivative

pr(1,xxx);


bos(k,0,2,-2)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-2)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,1,2)*fer(f,1,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

pr(1,yyy);


bos(kk,3,1,-3)*bos(g,3,3)*axp(bos(f,0,2,-3))

+3*fer(g,2,3)*fer(f,1,2)*bos(kk,3,1,-3)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

-3*fer(kk,2,2)*fer(g,2,3)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))


%second susy2 derivative;
pr(2,xxx);



-bos(k,0,2,-2)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-2)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,2,2)*fer(f,1,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

pr(2,yyy);


bos(kk,3,1,-3)*bos(g,0,4)*axp(bos(f,0,2,-3))

+3*fer(g,2,3)*fer(f,2,2)*bos(kk,3,1,-3)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

+3*fer(kk,1,2)*fer(g,2,3)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))


% third susy2 derivative;

pr(3,xxx);



-fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(f,2,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(f,1,2)*bos(k,3,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(f,1,2)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(f,1,2)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*bos(k,0,2,-2)*bos(f,3,2)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(h,2,0)*bos(k,0,2,-2)*bos(f,0,3)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,2,4)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)

*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,0,4)

*axp(fer(h,2,0)*fer(aa,1,3))

-fer(h,1,1)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

+2*fer(k,2,2)*bos(k,0,2,-3)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,2,2)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-3)*bos(h,3,0)

*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,2,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,0,4)

*axp(fer(h,2,0)*fer(aa,1,3))

-6*fer(k,2,2)*fer(k,1,2)*fer(f,1,2)*bos(k,0,2,-4)*axp(fer(h,2,0)*fer(aa,1,3))

+2*fer(k,1,2)*bos(k,0,2,-3)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

+2*fer(k,1,2)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-3)*bos(h,0,1)

*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,1,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,3,3)

*axp(fer(h,2,0)*fer(aa,1,3))

pr(3,yyy);


3*fer(f,2,2)*bos(kk,3,1,-3)*bos(g,3,3)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

-3*fer(f,1,2)*bos(kk,3,1,-3)*bos(g,0,4)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

-3*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,3,2)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

+3*fer(g,2,3)*bos(kk,3,1,-4)*bos(kk,0,3)*axp(bos(f,0,2,-3))

-12*fer(g,2,3)*fer(f,2,2)*fer(f,1,2)*bos(kk,3,1,-3)*bos(f,0,2,-5)

*axp(bos(f,0,2,-3))

-9*fer(g,2,3)*fer(f,2,2)*fer(f,1,2)*bos(kk,3,1,-3)*bos(f,0,2,-8)

*axp(bos(f,0,2,-3))

+fer(g,1,4)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3))

-3*fer(kk,2,2)*bos(kk,3,1,-4)*bos(g,0,4)*axp(bos(f,0,2,-3))

-9*fer(kk,2,2)*fer(g,2,3)*fer(f,2,2)*bos(kk,3,1,-4)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))

-12*fer(kk,2,2)*fer(kk,1,2)*fer(g,2,3)*bos(kk,3,1,-5)*axp(bos(f,0,2,-3))

-3*fer(kk,1,2)*bos(kk,3,1,-4)*bos(g,3,3)*axp(bos(f,0,2,-3))

-9*fer(kk,1,2)*fer(g,2,3)*fer(f,1,2)*bos(kk,3,1,-4)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))


clearrules trad;


let chiral;


pr(3,xxx);



-fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(f,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(f,1,2)*bos(k,3,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(f,1,2)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(f,1,2)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,1,4)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)

*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,0,4)

*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,2,2)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-3)*bos(h,3,0)

*axp(fer(h,2,0)*fer(aa,1,3))

-6*fer(k,2,2)*fer(k,1,2)*fer(f,1,2)*bos(k,0,2,-4)*axp(fer(h,2,0)*fer(aa,1,3))

+2*fer(k,1,2)*bos(k,0,2,-3)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

+2*fer(k,1,2)*bos(k,0,2,-3)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,1,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,3,3)

*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,1,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,0,4)

*axp(fer(h,2,0)*fer(aa,1,3))

clearrules chiral;


let chiral1;


pr(3,xxx);


(

 -fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

 -fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

 +fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

 +fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

 -2*fer(f,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

 -4*fer(f,1,2)*bos(k,3,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

 +fer(f,1,2)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

 +fer(f,1,2)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

 -fer(f,1,2)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

 -fer(f,1,2)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

 -2*fer(h,2,1)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

 +2*fer(h,2,0)*fer(f,1,2)*fer(aa,1,4)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

 +fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,3,3)

 *axp(fer(h,2,0)*fer(aa,1,3))

 +fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*bos(aa,0,4)

 *axp(fer(h,2,0)*fer(aa,1,3))

 -fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,3,3)

 *axp(fer(h,2,0)*fer(aa,1,3))

 -fer(h,2,0)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,0,1)*bos(aa,0,4)

 *axp(fer(h,2,0)*fer(aa,1,3))

 -4*fer(k,2,2)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-3)*bos(h,3,0)

 *axp(fer(h,2,0)*fer(aa,1,3))

 +4*fer(k,2,2)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-3)*bos(h,0,1)

 *axp(fer(h,2,0)*fer(aa,1,3))

 -24*fer(k,2,2)*fer(k,1,2)*fer(f,1,2)*bos(k,0,2,-4)*axp(fer(h,2,0)*fer(aa,1,3))

 +4*fer(k,1,2)*bos(k,0,2,-3)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

 +4*fer(k,1,2)*bos(k,0,2,-3)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

 -4*fer(k,1,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,3,3)

 *axp(fer(h,2,0)*fer(aa,1,3))

 -4*fer(k,1,2)*fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-3)*bos(aa,0,4)

 *axp(fer(h,2,0)*fer(aa,1,3)))/2


clearrules chiral1;


let trad;


% usual derivative
pg(1,xxx);


fer(f,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(f,1,2)*bos(k,0,3,1)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(h,2,1)*fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

-fer(h,2,0)*fer(f,1,2)*fer(aa,1,4)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

pg(3,yyy);


fer(g,2,6)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3))

-9*fer(g,2,5)*bos(kk,3,2,1)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))

-9*fer(g,2,5)*bos(kk,3,1,-3)*bos(f,0,3,1)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

-9*fer(g,2,4)*bos(kk,3,3,1)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))

+36*fer(g,2,4)*bos(kk,3,2,2)*bos(kk,3,1,-5)*axp(bos(f,0,2,-3))

+54*fer(g,2,4)*bos(kk,3,2,1)*bos(kk,3,1,-4)*bos(f,0,3,1)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))

-9*fer(g,2,4)*bos(kk,3,1,-3)*bos(f,0,4,1)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

+36*fer(g,2,4)*bos(kk,3,1,-3)*bos(f,0,3,2)*bos(f,0,2,-5)*axp(bos(f,0,2,-3))

+27*fer(g,2,4)*bos(kk,3,1,-3)*bos(f,0,3,2)*bos(f,0,2,-8)*axp(bos(f,0,2,-3))

-3*fer(g,2,3)*bos(kk,3,4,1)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))

+36*fer(g,2,3)*bos(kk,3,3,1)*bos(kk,3,2,1)*bos(kk,3,1,-5)*axp(bos(f,0,2,-3))

+27*fer(g,2,3)*bos(kk,3,3,1)*bos(kk,3,1,-4)*bos(f,0,3,1)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))

-60*fer(g,2,3)*bos(kk,3,2,3)*bos(kk,3,1,-6)*axp(bos(f,0,2,-3))

-108*fer(g,2,3)*bos(kk,3,2,2)*bos(kk,3,1,-5)*bos(f,0,3,1)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))

+27*fer(g,2,3)*bos(kk,3,2,1)*bos(kk,3,1,-4)*bos(f,0,4,1)*bos(f,0,2,-4)

*axp(bos(f,0,2,-3))

-108*fer(g,2,3)*bos(kk,3,2,1)*bos(kk,3,1,-4)*bos(f,0,3,2)*bos(f,0,2,-5)

*axp(bos(f,0,2,-3))

-81*fer(g,2,3)*bos(kk,3,2,1)*bos(kk,3,1,-4)*bos(f,0,3,2)*bos(f,0,2,-8)

*axp(bos(f,0,2,-3))

-3*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,5,1)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

+36*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,4,1)*bos(f,0,3,1)*bos(f,0,2,-5)

*axp(bos(f,0,2,-3))

+27*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,4,1)*bos(f,0,3,1)*bos(f,0,2,-8)

*axp(bos(f,0,2,-3))

-60*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,3,3)*bos(f,0,2,-6)*axp(bos(f,0,2,-3))

-108*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,3,3)*bos(f,0,2,-9)*axp(bos(f,0,2,-3))

-27*fer(g,2,3)*bos(kk,3,1,-3)*bos(f,0,3,3)*bos(f,0,2,-12)*axp(bos(f,0,2,-3))


clear xxx,yyy;



% 8.)
% And now let us change traditional algebra on the chiral algebra;
clearrules trad;


let chiral;


% And now we compute the same derivative but in the chiral
% representation;

%first susy derivative
der(1)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0));



-fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0))*der(1)

+fer(h,1,0)*fer(f,1,2)*bos(g,3,1)*axp(bos(h,0,0))


fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*del(1);


bos(g,3,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

+2*fer(g,2,1)*fer(f,1,2)*bos(f,0,2,-3)*axp(fer(k,1,2)*fer(h,2,1))

-fer(k,1,2)*fer(g,2,1)*bos(h,3,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

-del(1)*fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))

sub(del=der,ws);


fer(g,2,1)*bos(f,0,2,-2)*axp(fer(k,1,2)*fer(h,2,1))*der(1)


%second susy derivative
der(2)*fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0));



-fer(g,2,3)*bos(kk,0,3)*axp(bos(f,3,0))*der(2)

+fer(g,2,3)*fer(f,2,1)*bos(kk,0,3)*axp(bos(f,3,0))

+fer(kk,2,3)*fer(g,2,3)*axp(bos(f,3,0))


fer(r,2,1)*bos(kk,3,4,-4)*axp(fer(f,1,2)*fer(g,2,1))*del(2);


fer(r,2,1)*fer(g,2,1)*bos(kk,3,4,-4)*bos(f,3,2)*axp( - fer(g,2,1)*fer(f,1,2))

+fer(r,2,1)*fer(g,2,1)*bos(kk,3,4,-4)*bos(f,0,3)*axp( - fer(g,2,1)*fer(f,1,2))

-4*fer(r,2,1)*fer(kk,2,5)*bos(kk,3,4,-5)*axp( - fer(g,2,1)*fer(f,1,2))

-del(2)*fer(r,2,1)*bos(kk,3,4,-4)*axp( - fer(g,2,1)*fer(f,1,2))

sub(del=der,ws);


fer(r,2,1)*bos(kk,3,4,-4)*axp( - fer(g,2,1)*fer(f,1,2))*der(2)

;



% 9.) the value of action of (susy) derivative;

xxx:=fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3));


xxx := fer(f,1,2)*bos(k,0,2,-2)*axp(fer(h,2,0)*fer(aa,1,3))

yyy:=fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3));


yyy := fer(g,2,3)*bos(kk,3,1,-3)*axp(bos(f,0,2,-3))


%first susy derivative

pr(1,xxx);



-fer(f,1,2)*fer(aa,1,3)*bos(k,0,2,-2)*bos(h,3,0)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,1,2)*fer(f,1,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

pr(1,yyy);


bos(kk,3,1,-3)*bos(g,3,3)*axp(bos(f,0,2,-3))

+3*fer(g,2,3)*fer(f,1,2)*bos(kk,3,1,-3)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))


%second susy2 derivative;
pr(2,xxx);



-bos(k,0,2,-2)*bos(f,3,2)*axp(fer(h,2,0)*fer(aa,1,3))

-bos(k,0,2,-2)*bos(f,0,3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-2)*bos(aa,3,3)*axp(fer(h,2,0)*fer(aa,1,3))

+fer(h,2,0)*fer(f,1,2)*bos(k,0,2,-2)*bos(aa,0,4)*axp(fer(h,2,0)*fer(aa,1,3))

-2*fer(k,2,2)*fer(f,1,2)*bos(k,0,2,-3)*axp(fer(h,2,0)*fer(aa,1,3))

pr(2,yyy);


3*fer(g,2,3)*fer(f,2,2)*bos(kk,3,1,-3)*bos(f,0,2,-4)*axp(bos(f,0,2,-3))

+3*fer(kk,2,2)*fer(g,2,3)*bos(kk,3,1,-4)*axp(bos(f,0,2,-3))


clear xxx,yyy;


% We return back to the traditional algebra;

clearrules chiral;


let trad;



% 10.) The components of super-objects;

xxx:=fer(f,2,3)*bos(g,3,2,2);


xxx := fer(f,2,3)*bos(g,3,2,2)


% all components;
fpart(xxx);


{gras(ff2,3)*fun(g1,2,2),

 fun(g1,2,2)*fun(f1,3)

 +2*gras(g2,3)*gras(ff2,3)*fun(g1,2,1),

 fun(g1,2,2)*fun(f0,4)

 -2*gras(g1,3)*gras(ff2,3)*fun(g1,2,1),

 gras(ff1,4)*fun(g1,2,2)

 -2*gras(ff2,3)*fun(g1,2,1)*fun(g0,3,1)

 +2*gras(g1,3)*fun(g1,2,1)*fun(f1,3)

 +2*gras(g2,3)*fun(g1,2,1)*fun(f0,4)

 -2*gras(g2,3)*gras(g1,3)*gras(ff2,3)}


%bosonic sector;
bpart(xxx);


{0,fun(g1,2,2)*fun(f1,3),fun(g1,2,2)*fun(f0,4),0}


%the given component
bf_part(xxx,0);


gras(ff2,3)*fun(g1,2,2)


%the given component in the bosonic sector;

b_part(xxx,0);


0

b_part(xxx,1);


fun(g1,2,2)*fun(f1,3)




clear zzz;


clearrules trad;


let chiral;


zzz:=bos(f,3,1,-1)*bos(g,0,1,2);


zzz := bos(g,0,1,2)*bos(f,3,1,-1)

b_part(zzz,0);


fun(g0,1,2)*fun(f1,1,f0,2,-1)

b_part(zzz,3);


(

 -fun(g0,1,2)*fun(f0,3,1)*fun(f1,1,f0,2,-2)

 +2*fun(g0,1,2)*fun(f1,2,1)*fun(f1,1,f0,2,-2)

 +8*fun(g1,1,1)*fun(g0,1,1)*fun(f1,1,f0,2,-1))/4

clearrules chiral;


let chiral1;


b_part(zzz,0);


(fun(g0,1,2)*fun(f1,1,-1))/2

b_part(zzz,3);


(

 -fun(g0,1,2)*fun(f1,1,-2)*fun(f0,3,1)

 +8*fun(g1,1,1)*fun(g0,1,1)*fun(f1,1,-1))/8

clearrules chiral1;


let trad;



%11 matrix represenattion of operators;
lax:=der(1)*der(2)+bos(u,0,0);


lax := bos(u,0,0)

       +der(1)*der(2)


macierz(lax,b,b);


mat((fun(u0,0),0,0,1),

    (0,0,0,0),

    (0,0,0,0),

    (fun(u1,0)

          2
     -d(1) ,0,0,fun(u0,0)))


macierz(lax,f,b);


mat((0,0,0,0),

    (fun(u0,0),0,0,d(1)),

    (

     -d(1),0,0,fun(u0,0)),

    (0,0,0,0))


macierz(lax,b,f);


mat((fun(u0,0),0,0,1),

    (gras(uu1,0),fun(u0,0),d(1),0),

    (gras(uu2,0),

                 -d(1),fun(u0,0),0),

    (fun(u1,0)

          2
     -d(1) ,

            -gras(uu2,0),gras(uu1,0),fun(u0,0)))


macierz(lax,f,f);


mat((0,fun(u0,0),1,0),

    (fun(u0,0),gras(uu1,0),0,d(1)),

    (

     -d(1),gras(uu2,0),0,fun(u0,0)),

    (

     -gras(uu2,0),fun(u1,0)

                       2
                  -d(1) ,fun(u0,0),gras(uu1,0)))



% 12.) Demonstration of chirality properties;
clearrules trad;


let chiral;


b_chiral:={f0};


b_chiral := {f0}

b_antychiral:={f1};


b_antychiral := {f1}

f_chiral:={f2};


f_chiral := {f2}

f_antychiral:={f3};


f_antychiral := {f3}

for k:=0:3 do  write fer(f0,k,0);


fer(f0,0,0)

0

fer(f0,2,0)

fer(f0,3,0)

for k:=0:3 do  write fer(f1,k,0);


fer(f1,0,0)

fer(f1,1,0)

0

fer(f1,3,0)

for k:=0:3 do  write fer(f2,k,0);


fer(f2,0,0)

fer(f2,1,0)

fer(f2,2,0)


-fer(f2,0,1)

for k:=0:3 do  write fer(f3,k,0);


fer(f3,0,0)

fer(f3,1,0)

fer(f3,2,0)

0

for k:=0:3 do  write bos(f1,k,0);


bos(f1,0,0)

bos(f1,1,0)

bos(f1,2,0)

0

for k:=0:3 do  write bos(f2,k,0);


bos(f2,0,0)

0

bos(f2,2,0)

bos(f2,3,0)

for k:=0:3 do  write bos(f2,k,0);


bos(f2,0,0)

0

bos(f2,2,0)

bos(f2,3,0)

for k:=0:3 do  write bos(f3,k,0);


bos(f3,0,0)

bos(f3,1,0)

0

bos(f3,3,0)


% 13.) Integrations;

d(-1)*xxx;


***** introduce the precision e.g. give the value of ww > 0 


%we have to declare ww;
ww:=2;


ww := 2


d(-1)*xxx;



                                6
-2*fer(f,2,4)*bos(g,3,4,2)*d(-1)

                                             5
+4*fer(f,2,4)*bos(g,3,4,1)*bos(g,3,3,1)*d(-1)

                                             4
-2*fer(f,2,4)*bos(g,3,4,1)*bos(g,3,2,1)*d(-1)

                                4
-2*fer(f,2,4)*bos(g,3,3,2)*d(-1)

                                             3
+4*fer(f,2,4)*bos(g,3,3,1)*bos(g,3,2,1)*d(-1)

                              2
-fer(f,2,4)*bos(g,3,2,2)*d(-1)

                                             2
-2*fer(f,2,3)*bos(g,3,3,1)*bos(g,3,2,1)*d(-1)

+fer(f,2,3)*bos(g,3,2,2)*d(-1)

xxx*d(-2);


       4
2*d(-2) *fer(f,2,5)*bos(g,3,3,1)*bos(g,3,2,1)

        3
+4*d(-2) *fer(f,2,4)*bos(g,3,3,1)*bos(g,3,2,1)

      2
+d(-2) *fer(f,2,4)*bos(g,3,2,2)

        2
+2*d(-2) *fer(f,2,3)*bos(g,3,3,1)*bos(g,3,2,1)

+d(-2)*fer(f,2,3)*bos(g,3,2,2)

d(-3)*xxx;


d(-3)*fer(f,2,3)*bos(g,3,2,2)


ww:=4;


ww := 4

d(-1)**5:=0;


     5
d(-1)  := 0
d(-2)**5:=0;


     5
d(-2)  := 0


d(-1)*yyy;


yyy*d(-1)

yyy*d(-2);


yyy*d(-2)


clear d(-1)**5,d(-2)**5;




on list;



% 14.) The accelerations of integrations;

clear ww;


ww:=3;


ww := 3

let drr;


let cutoff;


cut:=4;


cut := 4

d(-1)*xxx;



-fer(f,2,6)*bos(g,3,2,2)*dr(-4)

-6*fer(f,2,5)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-4)

+fer(f,2,5)*bos(g,3,2,2)*dr(-3)

-6*fer(f,2,4)*bos(g,3,4,1)*bos(g,3,2,1)*dr(-4)

-6*fer(f,2,4)*bos(g,3,3,2)*dr(-4)

+4*fer(f,2,4)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-3)

-fer(f,2,4)*bos(g,3,2,2)*dr(-2)

-2*fer(f,2,3)*bos(g,3,5,1)*bos(g,3,2,1)*dr(-4)

-6*fer(f,2,3)*bos(g,3,4,1)*bos(g,3,3,1)*dr(-4)

+2*fer(f,2,3)*bos(g,3,4,1)*bos(g,3,2,1)*dr(-3)

+2*fer(f,2,3)*bos(g,3,3,2)*dr(-3)

-2*fer(f,2,3)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-2)

+fer(f,2,3)*bos(g,3,2,2)*dr(-1)

d(-1)**2*yyy;


yyy*dr(-2)

clear ww,cut;


ww:=4;


ww := 4

cut:=5;


cut := 5

d(-1)**3*yyy;


yyy*dr(-3)

d(-1)*xxx;


fer(f,2,7)*bos(g,3,2,2)*dr(-5)

+8*fer(f,2,6)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-5)

-fer(f,2,6)*bos(g,3,2,2)*dr(-4)

+12*fer(f,2,5)*bos(g,3,4,1)*bos(g,3,2,1)*dr(-5)

+12*fer(f,2,5)*bos(g,3,3,2)*dr(-5)

-6*fer(f,2,5)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-4)

+fer(f,2,5)*bos(g,3,2,2)*dr(-3)

+8*fer(f,2,4)*bos(g,3,5,1)*bos(g,3,2,1)*dr(-5)

+24*fer(f,2,4)*bos(g,3,4,1)*bos(g,3,3,1)*dr(-5)

-6*fer(f,2,4)*bos(g,3,4,1)*bos(g,3,2,1)*dr(-4)

-6*fer(f,2,4)*bos(g,3,3,2)*dr(-4)

+4*fer(f,2,4)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-3)

-fer(f,2,4)*bos(g,3,2,2)*dr(-2)

+2*fer(f,2,3)*bos(g,3,6,1)*bos(g,3,2,1)*dr(-5)

+8*fer(f,2,3)*bos(g,3,5,1)*bos(g,3,3,1)*dr(-5)

-2*fer(f,2,3)*bos(g,3,5,1)*bos(g,3,2,1)*dr(-4)

+6*fer(f,2,3)*bos(g,3,4,2)*dr(-5)

-6*fer(f,2,3)*bos(g,3,4,1)*bos(g,3,3,1)*dr(-4)

+2*fer(f,2,3)*bos(g,3,4,1)*bos(g,3,2,1)*dr(-3)

+2*fer(f,2,3)*bos(g,3,3,2)*dr(-3)

-2*fer(f,2,3)*bos(g,3,3,1)*bos(g,3,2,1)*dr(-2)

+fer(f,2,3)*bos(g,3,2,2)*dr(-1)


clearrules cutoff;

clearrules drr;


clear cut,ww;



% it is possible to use directly accelerated integrations oprators dr;
ww:=4;


ww := 4

dr(-2)*fer(f,1,2)*bos(kk,0,2);


630*fer(f,1,6)*bos(kk,0,6)*dr(-10)

-280*fer(f,1,6)*bos(kk,0,5)*dr(-9)

+105*fer(f,1,6)*bos(kk,0,4)*dr(-8)

-30*fer(f,1,6)*bos(kk,0,3)*dr(-7)

+5*fer(f,1,6)*bos(kk,0,2)*dr(-6)

-280*fer(f,1,5)*bos(kk,0,6)*dr(-9)

+140*fer(f,1,5)*bos(kk,0,5)*dr(-8)

-60*fer(f,1,5)*bos(kk,0,4)*dr(-7)

+20*fer(f,1,5)*bos(kk,0,3)*dr(-6)

-4*fer(f,1,5)*bos(kk,0,2)*dr(-5)

+105*fer(f,1,4)*bos(kk,0,6)*dr(-8)

-60*fer(f,1,4)*bos(kk,0,5)*dr(-7)

+30*fer(f,1,4)*bos(kk,0,4)*dr(-6)

-12*fer(f,1,4)*bos(kk,0,3)*dr(-5)

+3*fer(f,1,4)*bos(kk,0,2)*dr(-4)

-30*fer(f,1,3)*bos(kk,0,6)*dr(-7)

+20*fer(f,1,3)*bos(kk,0,5)*dr(-6)

-12*fer(f,1,3)*bos(kk,0,4)*dr(-5)

+6*fer(f,1,3)*bos(kk,0,3)*dr(-4)

-2*fer(f,1,3)*bos(kk,0,2)*dr(-3)

+5*fer(f,1,2)*bos(kk,0,6)*dr(-6)

-4*fer(f,1,2)*bos(kk,0,5)*dr(-5)

+3*fer(f,1,2)*bos(kk,0,4)*dr(-4)

-2*fer(f,1,2)*bos(kk,0,3)*dr(-3)

+fer(f,1,2)*bos(kk,0,2)*dr(-2)


on time;


Time: 1217 ms  plus GC time: 16 ms

showtime;


Time: 0 ms

Time: 0 ms


dr(-3)*bos(g,3,1)*bos(ff,3,2);


3150*bos(g,3,5)*bos(ff,3,6)*dr(-11)

-1260*bos(g,3,5)*bos(ff,3,5)*dr(-10)

+420*bos(g,3,5)*bos(ff,3,4)*dr(-9)

-105*bos(g,3,5)*bos(ff,3,3)*dr(-8)

+15*bos(g,3,5)*bos(ff,3,2)*dr(-7)

-1260*bos(g,3,4)*bos(ff,3,6)*dr(-10)

+560*bos(g,3,4)*bos(ff,3,5)*dr(-9)

-210*bos(g,3,4)*bos(ff,3,4)*dr(-8)

+60*bos(g,3,4)*bos(ff,3,3)*dr(-7)

-10*bos(g,3,4)*bos(ff,3,2)*dr(-6)

+420*bos(g,3,3)*bos(ff,3,6)*dr(-9)

-210*bos(g,3,3)*bos(ff,3,5)*dr(-8)

+90*bos(g,3,3)*bos(ff,3,4)*dr(-7)

-30*bos(g,3,3)*bos(ff,3,3)*dr(-6)

+6*bos(g,3,3)*bos(ff,3,2)*dr(-5)

-105*bos(g,3,2)*bos(ff,3,6)*dr(-8)

+60*bos(g,3,2)*bos(ff,3,5)*dr(-7)

-30*bos(g,3,2)*bos(ff,3,4)*dr(-6)

+12*bos(g,3,2)*bos(ff,3,3)*dr(-5)

-3*bos(g,3,2)*bos(ff,3,2)*dr(-4)

+15*bos(g,3,1)*bos(ff,3,6)*dr(-7)

-10*bos(g,3,1)*bos(ff,3,5)*dr(-6)

+6*bos(g,3,1)*bos(ff,3,4)*dr(-5)

-3*bos(g,3,1)*bos(ff,3,3)*dr(-4)

+bos(g,3,1)*bos(ff,3,2)*dr(-3)

Time: 15 ms


showtime;


Time: 0 ms

Time: 0 ms

%if you try usual integration

d(-1)**3*bos(g,3,1)*bos(ff,3,2);



                               48
-bos(g,3,10)*bos(ff,3,38)*d(-1)

                                  47
+12*bos(g,3,10)*bos(ff,3,37)*d(-1)

                                  46
-78*bos(g,3,10)*bos(ff,3,36)*d(-1)

                                   45
+364*bos(g,3,10)*bos(ff,3,35)*d(-1)

                                    44
-1353*bos(g,3,10)*bos(ff,3,34)*d(-1)

                                    43
+4224*bos(g,3,10)*bos(ff,3,33)*d(-1)

                                     42
-11440*bos(g,3,10)*bos(ff,3,32)*d(-1)

                                     41
+27456*bos(g,3,10)*bos(ff,3,31)*d(-1)

                                     40
-59268*bos(g,3,10)*bos(ff,3,30)*d(-1)

                                      39
+116336*bos(g,3,10)*bos(ff,3,29)*d(-1)

                                      38
-209352*bos(g,3,10)*bos(ff,3,28)*d(-1)

                                      37
+347568*bos(g,3,10)*bos(ff,3,27)*d(-1)

                                      36
-534964*bos(g,3,10)*bos(ff,3,26)*d(-1)

                                      35
+766272*bos(g,3,10)*bos(ff,3,25)*d(-1)

                                       34
-1024464*bos(g,3,10)*bos(ff,3,24)*d(-1)

                                       33
+1281280*bos(g,3,10)*bos(ff,3,23)*d(-1)

                                       32
-1501566*bos(g,3,10)*bos(ff,3,22)*d(-1)

                                       31
+1650792*bos(g,3,10)*bos(ff,3,21)*d(-1)

                                       30
-1703636*bos(g,3,10)*bos(ff,3,20)*d(-1)

                                       29
+1650792*bos(g,3,10)*bos(ff,3,19)*d(-1)

                                       28
-1501566*bos(g,3,10)*bos(ff,3,18)*d(-1)

                                       27
+1281280*bos(g,3,10)*bos(ff,3,17)*d(-1)

                                       26
-1024464*bos(g,3,10)*bos(ff,3,16)*d(-1)

                                      25
+766272*bos(g,3,10)*bos(ff,3,15)*d(-1)

                                      24
-534964*bos(g,3,10)*bos(ff,3,14)*d(-1)

                                      23
+347568*bos(g,3,10)*bos(ff,3,13)*d(-1)

                                      22
-209352*bos(g,3,10)*bos(ff,3,12)*d(-1)

                                      21
+116336*bos(g,3,10)*bos(ff,3,11)*d(-1)

                                     20
-59268*bos(g,3,10)*bos(ff,3,10)*d(-1)

                                    19
+27456*bos(g,3,10)*bos(ff,3,9)*d(-1)

                                    18
-11440*bos(g,3,10)*bos(ff,3,8)*d(-1)

                                   17
+4224*bos(g,3,10)*bos(ff,3,7)*d(-1)

                                   16
-1353*bos(g,3,10)*bos(ff,3,6)*d(-1)

                                  15
+364*bos(g,3,10)*bos(ff,3,5)*d(-1)

                                 14
-78*bos(g,3,10)*bos(ff,3,4)*d(-1)

                                 13
+12*bos(g,3,10)*bos(ff,3,3)*d(-1)

                              12
-bos(g,3,10)*bos(ff,3,2)*d(-1)

                                44
-3*bos(g,3,9)*bos(ff,3,35)*d(-1)

                                 43
+33*bos(g,3,9)*bos(ff,3,34)*d(-1)

                                  42
-198*bos(g,3,9)*bos(ff,3,33)*d(-1)

                                  41
+858*bos(g,3,9)*bos(ff,3,32)*d(-1)

                                   40
-2970*bos(g,3,9)*bos(ff,3,31)*d(-1)

                                   39
+8646*bos(g,3,9)*bos(ff,3,30)*d(-1)

                                    38
-21846*bos(g,3,9)*bos(ff,3,29)*d(-1)

                                    37
+48906*bos(g,3,9)*bos(ff,3,28)*d(-1)

                                    36
-98406*bos(g,3,9)*bos(ff,3,27)*d(-1)

                                     35
+179850*bos(g,3,9)*bos(ff,3,26)*d(-1)

                                     34
-300894*bos(g,3,9)*bos(ff,3,25)*d(-1)

                                     33
+463554*bos(g,3,9)*bos(ff,3,24)*d(-1)

                                     32
-660594*bos(g,3,9)*bos(ff,3,23)*d(-1)

                                     31
+873774*bos(g,3,9)*bos(ff,3,22)*d(-1)

                                      30
-1075470*bos(g,3,9)*bos(ff,3,21)*d(-1)

                                      29
+1234002*bos(g,3,9)*bos(ff,3,20)*d(-1)

                                      28
-1321452*bos(g,3,9)*bos(ff,3,19)*d(-1)

                                      27
+1321452*bos(g,3,9)*bos(ff,3,18)*d(-1)

                                      26
-1234002*bos(g,3,9)*bos(ff,3,17)*d(-1)

                                      25
+1075470*bos(g,3,9)*bos(ff,3,16)*d(-1)

                                     24
-873774*bos(g,3,9)*bos(ff,3,15)*d(-1)

                                     23
+660594*bos(g,3,9)*bos(ff,3,14)*d(-1)

                                     22
-463554*bos(g,3,9)*bos(ff,3,13)*d(-1)

                                     21
+300894*bos(g,3,9)*bos(ff,3,12)*d(-1)

                                     20
-179850*bos(g,3,9)*bos(ff,3,11)*d(-1)

                                    19
+98406*bos(g,3,9)*bos(ff,3,10)*d(-1)

                                   18
-48906*bos(g,3,9)*bos(ff,3,9)*d(-1)

                                   17
+21846*bos(g,3,9)*bos(ff,3,8)*d(-1)

                                  16
-8646*bos(g,3,9)*bos(ff,3,7)*d(-1)

                                  15
+2970*bos(g,3,9)*bos(ff,3,6)*d(-1)

                                 14
-858*bos(g,3,9)*bos(ff,3,5)*d(-1)

                                 13
+198*bos(g,3,9)*bos(ff,3,4)*d(-1)

                                12
-33*bos(g,3,9)*bos(ff,3,3)*d(-1)

                               11
+3*bos(g,3,9)*bos(ff,3,2)*d(-1)

                                40
-6*bos(g,3,8)*bos(ff,3,32)*d(-1)

                                 39
+60*bos(g,3,8)*bos(ff,3,31)*d(-1)

                                  38
-330*bos(g,3,8)*bos(ff,3,30)*d(-1)

                                   37
+1320*bos(g,3,8)*bos(ff,3,29)*d(-1)

                                   36
-4230*bos(g,3,8)*bos(ff,3,28)*d(-1)

                                    35
+11412*bos(g,3,8)*bos(ff,3,27)*d(-1)

                                    34
-26730*bos(g,3,8)*bos(ff,3,26)*d(-1)

                                    33
+55440*bos(g,3,8)*bos(ff,3,25)*d(-1)

                                     32
-103230*bos(g,3,8)*bos(ff,3,24)*d(-1)

                                     31
+174300*bos(g,3,8)*bos(ff,3,23)*d(-1)

                                     30
-268818*bos(g,3,8)*bos(ff,3,22)*d(-1)

                                     29
+380760*bos(g,3,8)*bos(ff,3,21)*d(-1)

                                     28
-497310*bos(g,3,8)*bos(ff,3,20)*d(-1)

                                     27
+600660*bos(g,3,8)*bos(ff,3,19)*d(-1)

                                     26
-672210*bos(g,3,8)*bos(ff,3,18)*d(-1)

                                     25
+697824*bos(g,3,8)*bos(ff,3,17)*d(-1)

                                     24
-672210*bos(g,3,8)*bos(ff,3,16)*d(-1)

                                     23
+600660*bos(g,3,8)*bos(ff,3,15)*d(-1)

                                     22
-497310*bos(g,3,8)*bos(ff,3,14)*d(-1)

                                     21
+380760*bos(g,3,8)*bos(ff,3,13)*d(-1)

                                     20
-268818*bos(g,3,8)*bos(ff,3,12)*d(-1)

                                     19
+174300*bos(g,3,8)*bos(ff,3,11)*d(-1)

                                     18
-103230*bos(g,3,8)*bos(ff,3,10)*d(-1)

                                   17
+55440*bos(g,3,8)*bos(ff,3,9)*d(-1)

                                   16
-26730*bos(g,3,8)*bos(ff,3,8)*d(-1)

                                   15
+11412*bos(g,3,8)*bos(ff,3,7)*d(-1)

                                  14
-4230*bos(g,3,8)*bos(ff,3,6)*d(-1)

                                  13
+1320*bos(g,3,8)*bos(ff,3,5)*d(-1)

                                 12
-330*bos(g,3,8)*bos(ff,3,4)*d(-1)

                                11
+60*bos(g,3,8)*bos(ff,3,3)*d(-1)

                               10
-6*bos(g,3,8)*bos(ff,3,2)*d(-1)

                                 36
-10*bos(g,3,7)*bos(ff,3,29)*d(-1)

                                 35
+90*bos(g,3,7)*bos(ff,3,28)*d(-1)

                                  34
-450*bos(g,3,7)*bos(ff,3,27)*d(-1)

                                   33
+1650*bos(g,3,7)*bos(ff,3,26)*d(-1)

                                   32
-4860*bos(g,3,7)*bos(ff,3,25)*d(-1)

                                    31
+12060*bos(g,3,7)*bos(ff,3,24)*d(-1)

                                    30
-25980*bos(g,3,7)*bos(ff,3,23)*d(-1)

                                    29
+49500*bos(g,3,7)*bos(ff,3,22)*d(-1)

                                    28
-84510*bos(g,3,7)*bos(ff,3,21)*d(-1)

                                     27
+130510*bos(g,3,7)*bos(ff,3,20)*d(-1)

                                     26
-183510*bos(g,3,7)*bos(ff,3,19)*d(-1)

                                     25
+236070*bos(g,3,7)*bos(ff,3,18)*d(-1)

                                     24
-278760*bos(g,3,7)*bos(ff,3,17)*d(-1)

                                     23
+302760*bos(g,3,7)*bos(ff,3,16)*d(-1)

                                     22
-302760*bos(g,3,7)*bos(ff,3,15)*d(-1)

                                     21
+278760*bos(g,3,7)*bos(ff,3,14)*d(-1)

                                     20
-236070*bos(g,3,7)*bos(ff,3,13)*d(-1)

                                     19
+183510*bos(g,3,7)*bos(ff,3,12)*d(-1)

                                     18
-130510*bos(g,3,7)*bos(ff,3,11)*d(-1)

                                    17
+84510*bos(g,3,7)*bos(ff,3,10)*d(-1)

                                   16
-49500*bos(g,3,7)*bos(ff,3,9)*d(-1)

                                   15
+25980*bos(g,3,7)*bos(ff,3,8)*d(-1)

                                   14
-12060*bos(g,3,7)*bos(ff,3,7)*d(-1)

                                  13
+4860*bos(g,3,7)*bos(ff,3,6)*d(-1)

                                  12
-1650*bos(g,3,7)*bos(ff,3,5)*d(-1)

                                 11
+450*bos(g,3,7)*bos(ff,3,4)*d(-1)

                                10
-90*bos(g,3,7)*bos(ff,3,3)*d(-1)

                                9
+10*bos(g,3,7)*bos(ff,3,2)*d(-1)

                                 32
-12*bos(g,3,6)*bos(ff,3,26)*d(-1)

                                 31
+96*bos(g,3,6)*bos(ff,3,25)*d(-1)

                                  30
-432*bos(g,3,6)*bos(ff,3,24)*d(-1)

                                   29
+1440*bos(g,3,6)*bos(ff,3,23)*d(-1)

                                   28
-3864*bos(g,3,6)*bos(ff,3,22)*d(-1)

                                   27
+8736*bos(g,3,6)*bos(ff,3,21)*d(-1)

                                    26
-17136*bos(g,3,6)*bos(ff,3,20)*d(-1)

                                    25
+29664*bos(g,3,6)*bos(ff,3,19)*d(-1)

                                    24
-45876*bos(g,3,6)*bos(ff,3,18)*d(-1)

                                    23
+63936*bos(g,3,6)*bos(ff,3,17)*d(-1)

                                    22
-80736*bos(g,3,6)*bos(ff,3,16)*d(-1)

                                    21
+92736*bos(g,3,6)*bos(ff,3,15)*d(-1)

                                    20
-97104*bos(g,3,6)*bos(ff,3,14)*d(-1)

                                    19
+92736*bos(g,3,6)*bos(ff,3,13)*d(-1)

                                    18
-80736*bos(g,3,6)*bos(ff,3,12)*d(-1)

                                    17
+63936*bos(g,3,6)*bos(ff,3,11)*d(-1)

                                    16
-45876*bos(g,3,6)*bos(ff,3,10)*d(-1)

                                   15
+29664*bos(g,3,6)*bos(ff,3,9)*d(-1)

                                   14
-17136*bos(g,3,6)*bos(ff,3,8)*d(-1)

                                  13
+8736*bos(g,3,6)*bos(ff,3,7)*d(-1)

                                  12
-3864*bos(g,3,6)*bos(ff,3,6)*d(-1)

                                  11
+1440*bos(g,3,6)*bos(ff,3,5)*d(-1)

                                 10
-432*bos(g,3,6)*bos(ff,3,4)*d(-1)

                                9
+96*bos(g,3,6)*bos(ff,3,3)*d(-1)

                                8
-12*bos(g,3,6)*bos(ff,3,2)*d(-1)

                                 28
-12*bos(g,3,5)*bos(ff,3,23)*d(-1)

                                 27
+84*bos(g,3,5)*bos(ff,3,22)*d(-1)

                                  26
-336*bos(g,3,5)*bos(ff,3,21)*d(-1)

                                   25
+1008*bos(g,3,5)*bos(ff,3,20)*d(-1)

                                   24
-2436*bos(g,3,5)*bos(ff,3,19)*d(-1)

                                   23
+4956*bos(g,3,5)*bos(ff,3,18)*d(-1)

                                   22
-8736*bos(g,3,5)*bos(ff,3,17)*d(-1)

                                    21
+13536*bos(g,3,5)*bos(ff,3,16)*d(-1)

                                    20
-18648*bos(g,3,5)*bos(ff,3,15)*d(-1)

                                    19
+23016*bos(g,3,5)*bos(ff,3,14)*d(-1)

                                    18
-25536*bos(g,3,5)*bos(ff,3,13)*d(-1)

                                    17
+25536*bos(g,3,5)*bos(ff,3,12)*d(-1)

                                    16
-23016*bos(g,3,5)*bos(ff,3,11)*d(-1)

                                    15
+18648*bos(g,3,5)*bos(ff,3,10)*d(-1)

                                   14
-13536*bos(g,3,5)*bos(ff,3,9)*d(-1)

                                  13
+8736*bos(g,3,5)*bos(ff,3,8)*d(-1)

                                  12
-4956*bos(g,3,5)*bos(ff,3,7)*d(-1)

                                  11
+2436*bos(g,3,5)*bos(ff,3,6)*d(-1)

                                  10
-1008*bos(g,3,5)*bos(ff,3,5)*d(-1)

                                 9
+336*bos(g,3,5)*bos(ff,3,4)*d(-1)

                                8
-84*bos(g,3,5)*bos(ff,3,3)*d(-1)

                                7
+12*bos(g,3,5)*bos(ff,3,2)*d(-1)

                                 24
-10*bos(g,3,4)*bos(ff,3,20)*d(-1)

                                 23
+60*bos(g,3,4)*bos(ff,3,19)*d(-1)

                                  22
-210*bos(g,3,4)*bos(ff,3,18)*d(-1)

                                  21
+560*bos(g,3,4)*bos(ff,3,17)*d(-1)

                                   20
-1200*bos(g,3,4)*bos(ff,3,16)*d(-1)

                                   19
+2160*bos(g,3,4)*bos(ff,3,15)*d(-1)

                                   18
-3360*bos(g,3,4)*bos(ff,3,14)*d(-1)

                                   17
+4560*bos(g,3,4)*bos(ff,3,13)*d(-1)

                                   16
-5460*bos(g,3,4)*bos(ff,3,12)*d(-1)

                                   15
+5800*bos(g,3,4)*bos(ff,3,11)*d(-1)

                                   14
-5460*bos(g,3,4)*bos(ff,3,10)*d(-1)

                                  13
+4560*bos(g,3,4)*bos(ff,3,9)*d(-1)

                                  12
-3360*bos(g,3,4)*bos(ff,3,8)*d(-1)

                                  11
+2160*bos(g,3,4)*bos(ff,3,7)*d(-1)

                                  10
-1200*bos(g,3,4)*bos(ff,3,6)*d(-1)

                                 9
+560*bos(g,3,4)*bos(ff,3,5)*d(-1)

                                 8
-210*bos(g,3,4)*bos(ff,3,4)*d(-1)

                                7
+60*bos(g,3,4)*bos(ff,3,3)*d(-1)

                                6
-10*bos(g,3,4)*bos(ff,3,2)*d(-1)

                                20
-6*bos(g,3,3)*bos(ff,3,17)*d(-1)

                                 19
+30*bos(g,3,3)*bos(ff,3,16)*d(-1)

                                 18
-90*bos(g,3,3)*bos(ff,3,15)*d(-1)

                                  17
+210*bos(g,3,3)*bos(ff,3,14)*d(-1)

                                  16
-390*bos(g,3,3)*bos(ff,3,13)*d(-1)

                                  15
+606*bos(g,3,3)*bos(ff,3,12)*d(-1)

                                  14
-810*bos(g,3,3)*bos(ff,3,11)*d(-1)

                                  13
+930*bos(g,3,3)*bos(ff,3,10)*d(-1)

                                 12
-930*bos(g,3,3)*bos(ff,3,9)*d(-1)

                                 11
+810*bos(g,3,3)*bos(ff,3,8)*d(-1)

                                 10
-606*bos(g,3,3)*bos(ff,3,7)*d(-1)

                                 9
+390*bos(g,3,3)*bos(ff,3,6)*d(-1)

                                 8
-210*bos(g,3,3)*bos(ff,3,5)*d(-1)

                                7
+90*bos(g,3,3)*bos(ff,3,4)*d(-1)

                                6
-30*bos(g,3,3)*bos(ff,3,3)*d(-1)

                               5
+6*bos(g,3,3)*bos(ff,3,2)*d(-1)

                                16
-3*bos(g,3,2)*bos(ff,3,14)*d(-1)

                                 15
+12*bos(g,3,2)*bos(ff,3,13)*d(-1)

                                 14
-30*bos(g,3,2)*bos(ff,3,12)*d(-1)

                                 13
+60*bos(g,3,2)*bos(ff,3,11)*d(-1)

                                 12
-93*bos(g,3,2)*bos(ff,3,10)*d(-1)

                                 11
+120*bos(g,3,2)*bos(ff,3,9)*d(-1)

                                 10
-132*bos(g,3,2)*bos(ff,3,8)*d(-1)

                                 9
+120*bos(g,3,2)*bos(ff,3,7)*d(-1)

                                8
-93*bos(g,3,2)*bos(ff,3,6)*d(-1)

                                7
+60*bos(g,3,2)*bos(ff,3,5)*d(-1)

                                6
-30*bos(g,3,2)*bos(ff,3,4)*d(-1)

                                5
+12*bos(g,3,2)*bos(ff,3,3)*d(-1)

                               4
-3*bos(g,3,2)*bos(ff,3,2)*d(-1)

                              12
-bos(g,3,1)*bos(ff,3,11)*d(-1)

                                11
+3*bos(g,3,1)*bos(ff,3,10)*d(-1)

                               10
-6*bos(g,3,1)*bos(ff,3,9)*d(-1)

                                9
+10*bos(g,3,1)*bos(ff,3,8)*d(-1)

                                8
-12*bos(g,3,1)*bos(ff,3,7)*d(-1)

                                7
+12*bos(g,3,1)*bos(ff,3,6)*d(-1)

                                6
-10*bos(g,3,1)*bos(ff,3,5)*d(-1)

                               5
+6*bos(g,3,1)*bos(ff,3,4)*d(-1)

                               4
-3*bos(g,3,1)*bos(ff,3,3)*d(-1)

                             3
+bos(g,3,1)*bos(ff,3,2)*d(-1)

Time: 172 ms


showtime;


Time: 0 ms

Time: 0 ms


% then the time - diffrences is evident. In this example d(-1)
% integration is 10 times slower then  dr integrations.

off time;



let cutoff;


cut:=5;


cut := 5

dr(-2)*fer(f,1,2)*bos(aa,0,1);



-4*fer(f,1,5)*bos(aa,0,1)*dr(-5)

-12*fer(f,1,4)*bos(aa,0,2)*dr(-5)

+3*fer(f,1,4)*bos(aa,0,1)*dr(-4)

-12*fer(f,1,3)*bos(aa,0,3)*dr(-5)

+6*fer(f,1,3)*bos(aa,0,2)*dr(-4)

-2*fer(f,1,3)*bos(aa,0,1)*dr(-3)

-4*fer(f,1,2)*bos(aa,0,4)*dr(-5)

+3*fer(f,1,2)*bos(aa,0,3)*dr(-4)

-2*fer(f,1,2)*bos(aa,0,2)*dr(-3)

+fer(f,1,2)*bos(aa,0,1)*dr(-2)

dr(-3)*bos(g,3,1)*bos(bb,0,3);


6*bos(g,3,3)*bos(bb,0,3)*dr(-5)

+12*bos(g,3,2)*bos(bb,0,4)*dr(-5)

-3*bos(g,3,2)*bos(bb,0,3)*dr(-4)

+6*bos(g,3,1)*bos(bb,0,5)*dr(-5)

-3*bos(g,3,1)*bos(bb,0,4)*dr(-4)

+bos(g,3,1)*bos(bb,0,3)*dr(-3)

clear ww,cut;


ww:=6;


ww := 6

cut:=7;


cut := 7

dr(-3)*fer(k,2,3)*bos(h,0,2);


15*fer(k,2,7)*bos(h,0,2)*dr(-7)

+60*fer(k,2,6)*bos(h,0,3)*dr(-7)

-10*fer(k,2,6)*bos(h,0,2)*dr(-6)

+90*fer(k,2,5)*bos(h,0,4)*dr(-7)

-30*fer(k,2,5)*bos(h,0,3)*dr(-6)

+6*fer(k,2,5)*bos(h,0,2)*dr(-5)

+60*fer(k,2,4)*bos(h,0,5)*dr(-7)

-30*fer(k,2,4)*bos(h,0,4)*dr(-6)

+12*fer(k,2,4)*bos(h,0,3)*dr(-5)

-3*fer(k,2,4)*bos(h,0,2)*dr(-4)

+15*fer(k,2,3)*bos(h,0,6)*dr(-7)

-10*fer(k,2,3)*bos(h,0,5)*dr(-6)

+6*fer(k,2,3)*bos(h,0,4)*dr(-5)

-3*fer(k,2,3)*bos(h,0,3)*dr(-4)

+fer(k,2,3)*bos(h,0,2)*dr(-3)

dr(-4)*bos(h,0,3)*bos(k,0,2);



-20*bos(k,0,5)*bos(h,0,3)*dr(-7)

-60*bos(k,0,4)*bos(h,0,4)*dr(-7)

+10*bos(k,0,4)*bos(h,0,3)*dr(-6)

-60*bos(k,0,3)*bos(h,0,5)*dr(-7)

+20*bos(k,0,3)*bos(h,0,4)*dr(-6)

-4*bos(k,0,3)*bos(h,0,3)*dr(-5)

-20*bos(k,0,2)*bos(h,0,6)*dr(-7)

+10*bos(k,0,2)*bos(h,0,5)*dr(-6)

-4*bos(k,0,2)*bos(h,0,4)*dr(-5)

+bos(k,0,2)*bos(h,0,3)*dr(-4)


clear ww,cut;


clearrules cutoff;



% 15.) The combinations

%the combinations of dim 7 constructed from fields of
% the 2 ,3 dimensions, free  parameters are numerated by "a";

w_comb({{f,2,b},{g,3,b}},7,a,b);


a1*bos(f,3,4)

+a2*bos(f,3,2)*bos(f,0,0)

+a3*bos(f,3,1)*bos(f,3,0)

+a4*bos(f,3,1)*bos(f,0,1)

+a5*bos(f,3,0)*bos(f,0,2)

                         2
+a6*bos(f,3,0)*bos(f,0,0)

+a7*bos(f,0,5)

+a8*bos(f,0,3)*bos(f,0,0)

+a9*bos(f,0,2)*bos(f,0,1)

                          2
+a10*bos(f,0,1)*bos(f,0,0)

+a11*bos(g,3,3)

+a12*bos(g,3,1)*bos(f,0,0)

+a13*bos(g,3,0)*bos(f,3,0)

+a14*bos(g,3,0)*bos(f,0,1)

+a15*bos(g,3,0)*bos(g,0,0)

+a16*bos(g,0,4)

+a17*bos(g,0,2)*bos(f,0,0)

+a18*bos(g,0,1)*bos(f,3,0)

+a19*bos(g,0,1)*bos(f,0,1)

+a20*bos(g,0,1)*bos(g,0,0)

+a21*bos(g,0,0)*bos(f,3,1)

+a22*bos(g,0,0)*bos(f,0,2)

                          2
+a23*bos(g,0,0)*bos(f,0,0)

+a24*fer(f,2,2)*fer(f,2,0)

+a25*fer(f,2,2)*fer(f,1,0)

+a26*fer(f,2,1)*fer(f,1,1)

+a27*fer(f,2,0)*fer(f,1,2)

+a28*fer(f,2,0)*fer(f,1,0)*bos(f,0,0)

+a29*fer(f,1,2)*fer(f,1,0)

+a30*fer(g,2,1)*fer(f,2,0)

+a31*fer(g,2,1)*fer(f,1,0)

+a32*fer(g,2,0)*fer(f,2,1)

+a33*fer(g,2,0)*fer(f,1,1)

+a34*fer(g,2,0)*fer(g,1,0)

+a35*fer(g,1,1)*fer(f,2,0)

+a36*fer(g,1,1)*fer(f,1,0)

+a37*fer(g,1,0)*fer(f,2,1)

+a38*fer(g,1,0)*fer(f,1,1)

w_comb({{f,2,f},{g,3,f}},4,s,f);


s1*fer(f,3,1)

+s2*fer(f,0,2)

+s3*fer(g,3,0)

+s4*fer(g,0,1)


% and now compute the last example but withouth the (susy)divergence
%terms;

fcomb({{f,2,b},{g,3,b}},5,c,b);


c(1)*bos(f,3,0)*bos(f,0,0)

+c(2)*bos(f,0,1)*bos(f,0,0)

+c(3)*bos(g,0,0)*bos(f,0,0)

fcomb({{f,1,f}},4,r,f);


                          2
r(1)*fer(f,0,0)*bos(f,2,0)

+r(2)*fer(f,0,0)*bos(f,2,0)*bos(f,1,0)

                           2
+r(3)*fer(f,0,0)*bos(f,1,0)



% 16.) The element of pseudo - susy -differential algebra;

pse_ele(2,{{f,2,b}},c);


*** c already defined as operator 

c(2)*bos(f,0,0)

          2
+c(0)*d(1)

+c(1)*d(1)*der(1)*der(2)

pse_ele(3,{{f,2,b}},c);


*** c already defined as operator 

c(2)*bos(f,3,0)

+c(3)*bos(f,0,1)

+c(4)*bos(f,0,0)*d(1)

+c(5)*bos(f,0,0)*der(1)*der(2)

          3
+c(0)*d(1)

          2
+c(1)*d(1) *der(1)*der(2)

+c(6)*fer(f,2,0)*der(2)

+c(7)*fer(f,2,0)*der(1)

+c(8)*fer(f,1,0)*der(2)

+c(9)*fer(f,1,0)*der(1)

pse_ele(4,{{f,2,b}},c);


*** c already defined as operator 

c(2)*bos(f,3,1)

+bos(f,3,0)*(d(1)*c(3)

             +der(1)*der(2)*c(4))

+c(5)*bos(f,0,2)

+bos(f,0,1)*(d(1)*c(6)

             +der(1)*der(2)*c(7))

                2
+c(8)*bos(f,0,0)

                 2
+bos(f,0,0)*(d(1) *c(9)

             +d(1)*der(1)*der(2)*c(10))

+fer(f,2,1)*(der(2)*c(11)

             +der(1)*c(12))

+fer(f,2,0)*(d(1)*der(2)*c(13)

             +d(1)*der(1)*c(14))

+fer(f,1,1)*(der(2)*c(15)

             +der(1)*c(16))

+fer(f,1,0)*(d(1)*der(2)*c(17)

             +d(1)*der(1)*c(18))

     4
+d(1) *c(0)

     3
+d(1) *der(1)*der(2)*c(1)

pse_ele(3,{{f,1,b},{g,2,b}},r);


*** r already defined as operator 

r(2)*bos(f,3,1)

+r(3)*bos(f,3,0)*bos(f,0,0)

+bos(f,3,0)*(d(1)*r(4)

             +der(1)*der(2)*r(5))

+r(6)*bos(f,0,2)

+r(7)*bos(f,0,1)*bos(f,0,0)

+bos(f,0,1)*(d(1)*r(8)

             +der(1)*der(2)*r(9))

                 3
+r(10)*bos(f,0,0)

           2
+bos(f,0,0) *(d(1)*r(11)

              +der(1)*der(2)*r(12))

                 2
+bos(f,0,0)*(d(1) *r(13)

             +d(1)*der(1)*der(2)*r(14))

+r(15)*bos(g,3,0)

+r(16)*bos(g,0,1)

+r(17)*bos(g,0,0)*bos(f,0,0)

+bos(g,0,0)*(d(1)*r(18)

             +der(1)*der(2)*r(19))

+fer(f,2,1)*(der(2)*r(20)

             +der(1)*r(21))

+fer(f,2,0)*bos(f,0,0)*(der(2)*r(22)

   +der(1)*r(23))

+r(26)*fer(f,2,0)*fer(f,1,0)

+fer(f,2,0)*(d(1)*der(2)*r(24)

             +d(1)*der(1)*r(25))

+fer(f,1,1)*(der(2)*r(27)

             +der(1)*r(28))

+fer(f,1,0)*bos(f,0,0)*(der(2)*r(29)

   +der(1)*r(30))

+fer(f,1,0)*(d(1)*der(2)*r(31)

             +d(1)*der(1)*r(32))

+fer(g,2,0)*(der(2)*r(33)

             +der(1)*r(34))

+fer(g,1,0)*(der(2)*r(35)

             +der(1)*r(36))

     3
+d(1) *r(0)

     2
+d(1) *der(1)*der(2)*r(1)


% The components of the elements of pseudo - susy - differential algebra;

xxx:=pse_ele(2,{{f,1,b},{g,2,b}},r);


*** r already defined as operator 

xxx := r(2)*bos(f,3,0)

       +r(3)*bos(f,0,1)

                       2
       +r(4)*bos(f,0,0)

       +r(5)*bos(f,0,0)*d(1)

       +r(6)*bos(f,0,0)*der(1)*der(2)

       +r(7)*bos(g,0,0)

                 2
       +r(0)*d(1)

       +r(1)*d(1)*der(1)*der(2)

       +r(8)*fer(f,2,0)*der(2)

       +r(9)*fer(f,2,0)*der(1)

       +r(10)*fer(f,1,0)*der(2)

       +r(11)*fer(f,1,0)*der(1)


for k:=0:3 do write s_part(xxx,k);


r(2)*bos(f,3,0)

+r(3)*bos(f,0,1)

                2
+r(4)*bos(f,0,0)

+r(5)*bos(f,0,0)*d(1)

+r(7)*bos(g,0,0)

          2
+r(0)*d(1)

r(9)*fer(f,2,0)

+r(11)*fer(f,1,0)

r(8)*fer(f,2,0)

+r(10)*fer(f,1,0)

r(6)*bos(f,0,0)

+r(1)*d(1)


for k:=0:2 do write d_part(xxx,k);


r(2)*bos(f,3,0)

+r(3)*bos(f,0,1)

                2
+r(4)*bos(f,0,0)

+r(6)*bos(f,0,0)*der(1)*der(2)

+r(7)*bos(g,0,0)

+r(8)*fer(f,2,0)*der(2)

+r(9)*fer(f,2,0)*der(1)

+r(10)*fer(f,1,0)*der(2)

+r(11)*fer(f,1,0)*der(1)

r(5)*bos(f,0,0)

+r(1)*der(1)*der(2)

r(0)


for k:=0:2 do for l:=0:3 do write sd_part(xxx,l,k);


r(2)*bos(f,3,0)

+r(3)*bos(f,0,1)

                2
+r(4)*bos(f,0,0)

+r(7)*bos(g,0,0)

r(9)*fer(f,2,0)

+r(11)*fer(f,1,0)

r(8)*fer(f,2,0)

+r(10)*fer(f,1,0)

r(6)*bos(f,0,0)

r(5)*bos(f,0,0)

0

0

r(1)

r(0)

0

0

0


clear xxx;



% 17.) Projection onto invariant subspace;

xxx:=
w_comb({{f,1,b}},2,a,b)*d(1)+
w_comb({{f,1,b}},3,b,b)*der(1)*der(2)+
w_comb({{f,1,b}},5/2,c,b)*der(1)+
w_comb({{f,1,b}},3,ee,b)*d(1)^2+
w_comb({{f,1,b}},7/2,fe,b)*d(1)*der(2)+
w_comb({{f,1,b}},3,g,b)*der(1)*der(2)*d(1);


                       2
xxx := bos(f,3,1)*(d(1) *ee1

          +d(1)*der(1)*der(2)*g1

          +der(1)*der(2)*b1)

                                   2
       +bos(f,3,0)*bos(f,0,0)*(d(1) *ee2

          +d(1)*der(1)*der(2)*g2

          +der(1)*der(2)*b2)

       +a1*bos(f,3,0)*d(1)

                        2
       +bos(f,0,2)*(d(1) *ee3

          +d(1)*der(1)*der(2)*g3

          +der(1)*der(2)*b3)

                                   2
       +bos(f,0,1)*bos(f,0,0)*(d(1) *ee4

          +d(1)*der(1)*der(2)*g4

          +der(1)*der(2)*b4)

       +a2*bos(f,0,1)*d(1)

                  3      2
       +bos(f,0,0) *(d(1) *ee5

          +d(1)*der(1)*der(2)*g5

          +der(1)*der(2)*b5)

                     2
       +a3*bos(f,0,0) *d(1)

                                   2
       +fer(f,2,0)*fer(f,1,0)*(d(1) *ee6

          +d(1)*der(1)*der(2)*g6

          +der(1)*der(2)*b6)


for k:=0:2 do write rzut(xxx,k);


                2
bos(f,3,1)*(d(1) *ee1

            +d(1)*der(1)*der(2)*g1

            +der(1)*der(2)*b1)

                            2
+bos(f,3,0)*bos(f,0,0)*(d(1) *ee2

   +d(1)*der(1)*der(2)*g2

   +der(1)*der(2)*b2)

+a1*bos(f,3,0)*d(1)

                 2
+bos(f,0,2)*(d(1) *ee3

             +d(1)*der(1)*der(2)*g3

             +der(1)*der(2)*b3)

                            2
+bos(f,0,1)*bos(f,0,0)*(d(1) *ee4

   +d(1)*der(1)*der(2)*g4

   +der(1)*der(2)*b4)

+a2*bos(f,0,1)*d(1)

           3      2
+bos(f,0,0) *(d(1) *ee5

              +d(1)*der(1)*der(2)*g5

              +der(1)*der(2)*b5)

              2
+a3*bos(f,0,0) *d(1)

                            2
+fer(f,2,0)*fer(f,1,0)*(d(1) *ee6

   +d(1)*der(1)*der(2)*g6

   +der(1)*der(2)*b6)

                2
bos(f,3,1)*(d(1) *ee1

            +d(1)*der(1)*der(2)*g1

            +der(1)*der(2)*b1)

                            2
+bos(f,3,0)*bos(f,0,0)*(d(1) *ee2

   +d(1)*der(1)*der(2)*g2

   +der(1)*der(2)*b2)

+a1*bos(f,3,0)*d(1)

                 2
+bos(f,0,2)*(d(1) *ee3

             +d(1)*der(1)*der(2)*g3

             +der(1)*der(2)*b3)

                            2
+bos(f,0,1)*bos(f,0,0)*(d(1) *ee4

   +d(1)*der(1)*der(2)*g4

   +der(1)*der(2)*b4)

+a2*bos(f,0,1)*d(1)

           3      2
+bos(f,0,0) *(d(1) *ee5

              +d(1)*der(1)*der(2)*g5

              +der(1)*der(2)*b5)

              2
+a3*bos(f,0,0) *d(1)

                            2
+fer(f,2,0)*fer(f,1,0)*(d(1) *ee6

   +d(1)*der(1)*der(2)*g6

   +der(1)*der(2)*b6)

                2
bos(f,3,1)*(d(1) *ee1

            +d(1)*der(1)*der(2)*g1

            +der(1)*der(2)*b1)

                            2
+bos(f,3,0)*bos(f,0,0)*(d(1) *ee2

   +d(1)*der(1)*der(2)*g2

   +der(1)*der(2)*b2)

                 2
+bos(f,0,2)*(d(1) *ee3

             +d(1)*der(1)*der(2)*g3

             +der(1)*der(2)*b3)

                            2
+bos(f,0,1)*bos(f,0,0)*(d(1) *ee4

   +d(1)*der(1)*der(2)*g4

   +der(1)*der(2)*b4)

           3      2
+bos(f,0,0) *(d(1) *ee5

              +d(1)*der(1)*der(2)*g5

              +der(1)*der(2)*b5)

                            2
+fer(f,2,0)*fer(f,1,0)*(d(1) *ee6

   +d(1)*der(1)*der(2)*g6

   +der(1)*der(2)*b6)


clear xxx;



% 18.) Test for the adjoint operators;

cp(der(1));


*** d not found 

*** der not found 

*** del not found 


-der(1)

cp(der(1)*der(2));


d(1)

+der(1)*der(2)

clearrules trad;


let chiral1;


cp(der(3));


*** d not found 

*** der not found 

*** del not found 

der(3)

cp(der(1)*d(1));


d(1)*der(1)

clearrules chiral1;


let trad;


cp(d(1));


*** d not found 

*** der not found 

*** del not found 


-d(1)

cp(d(2));


*** d not found 

*** der not found 

*** del not found 


-d(2)

as:=fer(f,1,0)*d(-3)*fer(g,2,0)+fer(h,1,2)*d(-3)*fer(kk,2,1);


as := fer(f,1,0)*d(-3)*fer(g,2,0)

      +fer(h,1,2)*d(-3)*fer(kk,2,1)

cp(as);


*** d not found 

*** der not found 

*** del not found 

fer(g,2,0)*d(-3)*fer(f,1,0)

+fer(kk,2,1)*d(-3)*fer(h,1,2)

cp(as*as);


*** d not found 

*** der not found 

*** del not found 


-fer(g,2,0)*(d(-3)*fer(g,2,0)*fer(f,1,0)*d(-3)*fer(f,1,0)

             +d(-3)*fer(kk,2,1)*fer(f,1,0)*d(-3)*fer(h,1,2))

+fer(kk,2,1)*(d(-3)*fer(h,1,2)*fer(g,2,0)*d(-3)*fer(f,1,0)

              -d(-3)*fer(kk,2,1)*fer(h,1,2)*d(-3)*fer(h,1,2))


as:=fer(f,1,0);


as := fer(f,1,0)

cp(as);


fer(f,1,0)

cp(ws);


fer(f,1,0)


clear as;



as:=bos(f,0,0);


as := bos(f,0,0)

as1:=as*der(1);


as1 := bos(f,0,0)*der(1)

cp(as1);



-bos(f,0,0)*der(1)

-fer(f,1,0)

cp(ws);


*** d not found 

*** der not found 

*** del not found 

bos(f,0,0)*der(1)

cp(as1)+der(1)*as;


0


as2:=as*der(1)*der(2);


as2 := bos(f,0,0)*der(1)*der(2)

cp(as2);


bos(f,3,0)

+bos(f,0,0)*der(1)*der(2)

-fer(f,2,0)*der(1)

+fer(f,1,0)*der(2)

cp(ws);


*** d not found 

*** der not found 

*** del not found 

bos(f,0,0)*der(1)*der(2)

cp(as2) - der(1)*der(2)*as;


0



clear as;


as:=mat((fer(f,1,0)*der(1),bos(g,0,0)*d(-3)*bos(h,0,0)),
(fer(h,2,1),fer(h,1,2)*d(-3)*fer(k,2,3)));


      [fer(f,1,0)*der(1)  bos(g,0,0)*d(-3)*bos(h,0,0)]
as := [                                              ]
      [   fer(h,2,1)      fer(h,1,2)*d(-3)*fer(k,2,3)]


cp(as);


*** fer(h,2,1) not found 

mat((bos(f,0,1)

     -fer(f,1,0)*der(1),fer(h,2,1)),

    (

     -bos(h,0,0)*d(-3)*bos(g,0,0),fer(k,2,3)*d(-3)*fer(h,1,2)))


clear as;




% 19.) Analog of coeff

xxx:=pse_ele(2,{{f,1,b}},a);


xxx := a(2)*bos(f,3,0)

       +a(3)*bos(f,0,1)

                       2
       +a(4)*bos(f,0,0)

       +a(5)*bos(f,0,0)*d(1)

       +a(6)*bos(f,0,0)*der(1)*der(2)

                 2
       +a(0)*d(1)

       +a(1)*d(1)*der(1)*der(2)

       +a(7)*fer(f,2,0)*der(2)

       +a(8)*fer(f,2,0)*der(1)

       +a(9)*fer(f,1,0)*der(2)

       +a(10)*fer(f,1,0)*der(1)

yyy:=lyst(xxx);


yyy := {a(2)*bos(f,3,0),

        a(3)*bos(f,0,1),

                       2
        a(4)*bos(f,0,0) ,

        a(5)*bos(f,0,0)*d(1),

        a(6)*bos(f,0,0)*der(1)*der(2),

                 2
        a(0)*d(1) ,

        a(1)*d(1)*der(1)*der(2),

        a(7)*fer(f,2,0)*der(2),

        a(8)*fer(f,2,0)*der(1),

        a(9)*fer(f,1,0)*der(2),

        a(10)*fer(f,1,0)*der(1)}

zzz:=lyst1(xxx);


zzz := {a(2),

        a(3),

        a(4),

        a(5)*d(1),

        a(6)*der(1)*der(2),

                 2
        a(0)*d(1) ,

        a(1)*d(1)*der(1)*der(2),

        a(7)*der(2),

        a(8)*der(1),

        a(9)*der(2),

        a(10)*der(1)}

yyy:=lyst2(xxx);


yyy := {a(2),

        a(3),

        a(4),

        a(5),

        a(6),

        a(0),

        a(1),

        a(7),

        a(8),

        a(9),

        a(10)}

clear xxx,yyy,zzz;



% 20.) Simplifications;

% we would like to compute third generalizations of the SUSY KdV
% equation
% example from Z.Popowicz Phys.Lett.A.174 (1993) p.87

lax:=d(1)+d(-3)*der(1)*der(2)*bos(u,0,0);


lax := d(1)

       +d(-3)*bos(u,3,0)

       +d(-3)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*fer(u,2,0)*der(1)

       +d(-3)*fer(u,1,0)*der(2)

lb2:=lax^2;


lb2 := bos(u,3,0)

       +bos(u,0,0)*der(1)*der(2)

       -fer(u,2,0)*der(1)

       +fer(u,1,0)*der(2)

            2
       +d(1)

       +d(-3)*bos(u,3,0)*d(1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*der(1)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*der(2)

       +d(-3)*bos(u,0,0)*d(1)*der(1)*der(2)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -2*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

                                              2
       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

       -d(-3)*fer(u,2,0)*d(1)*der(1)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(1)

       +d(-3)*fer(u,1,0)*d(1)*der(2)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(1)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*d(1)

la2:=chan(lb2);


la2 := 2*bos(u,3,0)

                  2
       -bos(u,0,0)

       +2*bos(u,0,0)*der(1)*der(2)

       -2*fer(u,2,0)*der(1)

       +2*fer(u,1,0)*der(2)

            2
       +d(1)

       -d(-3)*bos(u,3,1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*der(1)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*der(2)

       +d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,0,1)*der(1)*der(2)

       +d(-3)*fer(u,2,1)*der(1)

       -d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -d(-3)*fer(u,1,1)*der(2)

       -d(-3)*fer(u,1,0)*bos(u,0,0)*der(1)

lb3:=lax*la2;


lb3 := bos(u,3,1)

       +bos(u,3,0)*(2*d(1)

          +d(-3)*bos(u,3,0)

          +d(-3)*bos(u,0,0)*der(1)*der(2)

          -d(-3)*fer(u,2,0)*der(1)

          +d(-3)*fer(u,1,0)*der(2))

       -bos(u,0,1)*bos(u,0,0)

       +bos(u,0,1)*der(1)*der(2)

                  2
       -bos(u,0,0) *d(1)

       +2*bos(u,0,0)*d(1)*der(1)*der(2)

       -fer(u,2,1)*der(1)

       -fer(u,2,0)*bos(u,0,0)*der(2)

       -2*fer(u,2,0)*d(1)*der(1)

       +fer(u,1,1)*der(2)

       -fer(u,1,0)*bos(u,0,0)*der(1)

       +2*fer(u,1,0)*d(1)*der(2)

            3
       +d(1)

                          2
       +2*d(-3)*bos(u,3,0)

                                     2
       -3*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(1)*der(2)

                             2
       +d(-3)*bos(u,3,0)*d(1)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*der(1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*der(2)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(1)*der(2)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*der(1)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(1)

       -2*d(-3)*bos(u,0,2)*bos(u,0,0)

       -4*d(-3)*bos(u,0,1)*bos(u,0,0)*d(1)

                        3
       -d(-3)*bos(u,0,0) *der(1)*der(2)

                          2     2
       -2*d(-3)*bos(u,0,0) *d(1)

                             2
       +d(-3)*bos(u,0,0)*d(1) *der(1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       +d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)

       -2*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*d(1)

                                                               2
       -d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

       +d(-3)*bos(u,0,0)*d(-3)*bos(u,0,3)

       +2*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(1)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*bos(u,3,0)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*der(1)*der(2)

                                              2
       +d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,1)*fer(u,1,0)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(1)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,1,1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,1,0)*d(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,1)

       -2*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(1)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*d(1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,1)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*d(1)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)*der(2)

       +2*d(-3)*fer(u,2,1)*fer(u,2,0)

       -2*d(-3)*fer(u,2,0)*bos(u,3,0)*der(1)

       -2*d(-3)*fer(u,2,0)*bos(u,0,1)*der(2)

                                     2
       +3*d(-3)*fer(u,2,0)*bos(u,0,0) *der(1)

       -2*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)*der(2)

       +6*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

                             2
       -d(-3)*fer(u,2,0)*d(1) *der(1)

       +d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

       -d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(1)

       +d(-3)*fer(u,2,0)*d(-3)*bos(u,0,2)*der(2)

       +d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*d(1)*der(2)

       +d(-3)*fer(u,2,0)*d(-3)*fer(u,2,2)

       +d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(1)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,3,0)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)

       +2*d(-3)*fer(u,1,0)*bos(u,3,0)*der(2)

       -2*d(-3)*fer(u,1,0)*bos(u,0,1)*der(1)

                                     2
       -3*d(-3)*fer(u,1,0)*bos(u,0,0) *der(2)

       -2*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)*der(1)

                             2
       +d(-3)*fer(u,1,0)*d(1) *der(2)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)

       -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(1)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*der(1)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(1)*der(1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*der(1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(1)*der(2)

la3:=chan(lb3);


la3 := bos(u,3,0)*(3*d(1)

          +d(-3)*bos(u,3,0)

          +d(-3)*bos(u,0,0)*der(1)*der(2)

          -d(-3)*fer(u,2,0)*der(1)

          +d(-3)*fer(u,1,0)*der(2))

                    2
       -3*bos(u,0,0) *d(1)

       +3*bos(u,0,0)*d(1)*der(1)*der(2)

       -3*fer(u,2,0)*bos(u,0,0)*der(2)

       -3*fer(u,2,0)*d(1)*der(1)

       -3*fer(u,1,0)*bos(u,0,0)*der(1)

       +3*fer(u,1,0)*d(1)*der(2)

            3
       +d(1)

       +d(-3)*bos(u,3,2)

                          2
       +2*d(-3)*bos(u,3,0)

                                     2
       -2*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*der(1)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*der(2)

       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(1)*der(2)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*der(1)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*der(2)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(1)

       -2*d(-3)*bos(u,0,2)*bos(u,0,0)

       +d(-3)*bos(u,0,2)*der(1)*der(2)

                        2
       -d(-3)*bos(u,0,1)

                        3
       -d(-3)*bos(u,0,0) *der(1)*der(2)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*bos(u,3,0)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*der(1)

       -d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*der(2)

       -d(-3)*fer(u,2,2)*der(1)

       +2*d(-3)*fer(u,2,1)*bos(u,0,0)*der(2)

       +d(-3)*fer(u,2,1)*fer(u,2,0)

       -2*d(-3)*fer(u,2,0)*bos(u,3,0)*der(1)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*der(2)

                                     2
       +2*d(-3)*fer(u,2,0)*bos(u,0,0) *der(1)

       +2*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,3,0)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(1)*der(2)

       -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*der(2)

       +d(-3)*fer(u,1,2)*der(2)

       +2*d(-3)*fer(u,1,1)*bos(u,0,0)*der(1)

       +d(-3)*fer(u,1,1)*fer(u,1,0)

       +2*d(-3)*fer(u,1,0)*bos(u,3,0)*der(2)

       +d(-3)*fer(u,1,0)*bos(u,0,1)*der(1)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *der(2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(1)*der(2)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*der(1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*der(2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,3,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(1)*der(2)

lax3:=rzut(la3,1);


lax3 := 3*bos(u,3,0)*d(1)

                     2
        -3*bos(u,0,0) *d(1)

        +3*bos(u,0,0)*d(1)*der(1)*der(2)

        -3*fer(u,2,0)*bos(u,0,0)*der(2)

        -3*fer(u,2,0)*d(1)*der(1)

        -3*fer(u,1,0)*bos(u,0,0)*der(1)

        +3*fer(u,1,0)*d(1)*der(2)

             3
        +d(1)

comm:=lax*lax3 - lax3*lax;


comm := 

        -bos(u,3,2)

        +bos(u,3,1)*d(1)

                     2
        -3*bos(u,3,0)

                                2
        +3*bos(u,3,0)*bos(u,0,0)

        -3*bos(u,3,0)*bos(u,0,0)*der(1)*der(2)

                        2
        -bos(u,3,0)*d(1)

        +3*bos(u,0,2)*bos(u,0,0)

        -bos(u,0,2)*der(1)*der(2)

        +bos(u,0,1)*d(1)*der(1)*der(2)

                     3
        +3*bos(u,0,0) *der(1)*der(2)

                     2     2
        +3*bos(u,0,0) *d(1)

                        2
        -bos(u,0,0)*d(1) *der(1)*der(2)

        +fer(u,2,2)*der(1)

        -3*fer(u,2,1)*bos(u,0,0)*der(2)

        -3*fer(u,2,1)*fer(u,2,0)

        -fer(u,2,1)*d(1)*der(1)

        +3*fer(u,2,0)*bos(u,3,0)*der(1)

                                2
        -3*fer(u,2,0)*bos(u,0,0) *der(1)

        +3*fer(u,2,0)*bos(u,0,0)*(d(1)*der(2)

           -d(-3)*bos(u,0,1)*der(1)

           -d(-3)*bos(u,0,0)*d(1)*der(1)

           -d(-3)*fer(u,1,1)

           -d(-3)*fer(u,1,0)*d(1))

                        2
        +fer(u,2,0)*d(1) *der(1)

        -fer(u,1,2)*der(2)

        -3*fer(u,1,1)*bos(u,0,0)*der(1)

        -3*fer(u,1,1)*fer(u,1,0)

        +fer(u,1,1)*d(1)*der(2)

        -3*fer(u,1,0)*bos(u,3,0)*der(2)

                                2
        +3*fer(u,1,0)*bos(u,0,0) *der(2)

        +3*fer(u,1,0)*bos(u,0,0)*(d(1)*der(1)

           +d(-3)*bos(u,0,1)*der(2)

           +d(-3)*bos(u,0,0)*d(1)*der(2)

           +d(-3)*fer(u,2,1)

           +d(-3)*fer(u,2,0)*d(1))

                        2
        -fer(u,1,0)*d(1) *der(2)

                           2
        +3*d(-3)*bos(u,3,0) *d(1)

                                      2
        -3*d(-3)*bos(u,3,0)*bos(u,0,0) *d(1)

        +3*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)*der(1)*der(2)

                              3
        +d(-3)*bos(u,3,0)*d(1)

        -3*d(-3)*bos(u,0,2)*bos(u,0,0)*d(1)

                                      2
        -6*d(-3)*bos(u,0,1)*bos(u,0,0) *der(1)*der(2)

                                           2
        -6*d(-3)*bos(u,0,1)*bos(u,0,0)*d(1)

                           3
        -3*d(-3)*bos(u,0,0) *d(1)*der(1)*der(2)

                           2     3
        -3*d(-3)*bos(u,0,0) *d(1)

                              3
        +d(-3)*bos(u,0,0)*d(1) *der(1)*der(2)

                                      2
        +3*d(-3)*fer(u,2,1)*bos(u,0,0) *der(1)

        +3*d(-3)*fer(u,2,1)*fer(u,2,0)*d(1)

        -3*d(-3)*fer(u,2,0)*bos(u,3,0)*d(1)*der(1)

        +6*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*der(1)

        -3*d(-3)*fer(u,2,0)*bos(u,0,1)*d(1)*der(2)

                                      2
        +6*d(-3)*fer(u,2,0)*bos(u,0,0) *d(1)*der(1)

                                           2
        -3*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1) *der(2)

        +6*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(1)

                              3
        -d(-3)*fer(u,2,0)*d(1) *der(1)

                                      2
        -3*d(-3)*fer(u,1,1)*bos(u,0,0) *der(2)

        +3*d(-3)*fer(u,1,1)*fer(u,1,0)*d(1)

        +3*d(-3)*fer(u,1,0)*bos(u,3,0)*d(1)*der(2)

        -6*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*der(2)

        -3*d(-3)*fer(u,1,0)*bos(u,0,1)*d(1)*der(1)

                                      2
        -6*d(-3)*fer(u,1,0)*bos(u,0,0) *d(1)*der(2)

                                           2
        -3*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1) *der(1)

                              3
        +d(-3)*fer(u,1,0)*d(1) *der(2)

com:=chan(comm);


com := 

       -d(-3)*bos(u,3,3)

       -6*d(-3)*bos(u,3,1)*bos(u,3,0)

                                     2
       +3*d(-3)*bos(u,3,1)*bos(u,0,0)

       -3*d(-3)*bos(u,3,1)*bos(u,0,0)*der(1)*der(2)

       +6*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)

       -3*d(-3)*bos(u,3,0)*bos(u,0,1)*der(1)*der(2)

       +3*d(-3)*bos(u,0,3)*bos(u,0,0)

       -d(-3)*bos(u,0,3)*der(1)*der(2)

       +3*d(-3)*bos(u,0,2)*bos(u,0,1)

                                     2
       +3*d(-3)*bos(u,0,1)*bos(u,0,0) *der(1)*der(2)

       +d(-3)*fer(u,2,3)*der(1)

       -3*d(-3)*fer(u,2,2)*bos(u,0,0)*der(2)

       -3*d(-3)*fer(u,2,2)*fer(u,2,0)

       +3*d(-3)*fer(u,2,1)*bos(u,3,0)*der(1)

       -3*d(-3)*fer(u,2,1)*bos(u,0,1)*der(2)

                                     2
       -3*d(-3)*fer(u,2,1)*bos(u,0,0) *der(1)

       -6*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)

       +3*d(-3)*fer(u,2,0)*bos(u,3,1)*der(1)

       -6*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*der(1)

       -6*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)

       -6*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)

       -d(-3)*fer(u,1,3)*der(2)

       -3*d(-3)*fer(u,1,2)*bos(u,0,0)*der(1)

       -3*d(-3)*fer(u,1,2)*fer(u,1,0)

       -3*d(-3)*fer(u,1,1)*bos(u,3,0)*der(2)

       -3*d(-3)*fer(u,1,1)*bos(u,0,1)*der(1)

                                     2
       +3*d(-3)*fer(u,1,1)*bos(u,0,0) *der(2)

       -3*d(-3)*fer(u,1,0)*bos(u,3,1)*der(2)

       +6*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*der(2)

result:=sub(der=del,com);


result := 

          -3*del(1)*del(2)*d(-3)*bos(u,3,1)*bos(u,0,0)

          -3*del(1)*del(2)*d(-3)*bos(u,3,0)*bos(u,0,1)

          -del(1)*del(2)*d(-3)*bos(u,0,3)

                                                      2
          +3*del(1)*del(2)*d(-3)*bos(u,0,1)*bos(u,0,0)

%the equation is
equ:=sub(del(1)=1,del(2)=1,d(-3)=1,result);


equ := 

       -3*bos(u,3,1)*bos(u,0,0)

       -3*bos(u,3,0)*bos(u,0,1)

       -bos(u,0,3)

                               2
       +3*bos(u,0,1)*bos(u,0,0)


clear lax,lb2,la2,lb3,la3,lax3,comm,com,result;



% we now compute the same but starting from
% different realizations of susy algebra
%
clearrules trad;


let chiral1;


lax:=d(1)+d(-3)*del(3)*bos(u,0,0);


lax := d(1)

       +del(3)*d(-3)*bos(u,0,0)

la2:=chan(lax^2);


la2 := bos(u,0,1)*d(-3)*bos(u,0,0)

                  2
       +bos(u,0,0)

            2
       +d(1)

       +2*del(3)*bos(u,0,0)

       +del(3)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -del(3)*d(-3)*bos(u,0,1)

       +2*del(2)*fer(u,1,0)*d(-3)*bos(u,0,0)

       +2*del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)

la3:=rzut(chan(lax*la2),0);


la3 := 6*bos(u,0,1)*bos(u,0,0)

                    2
       +3*bos(u,0,0) *d(1)

            3
       +d(1)

       +3*del(3)*bos(u,0,0)*d(1)

       +6*del(2)*fer(u,1,0)*bos(u,0,0)

       +6*del(1)*fer(u,2,0)*bos(u,0,0)

com:=chan(lax*la3-la3*lax);


com := 

       -3*del(3)*d(-3)*bos(u,3,1)*bos(u,0,0)

       -3*del(3)*d(-3)*bos(u,3,0)*bos(u,0,1)

       -del(3)*d(-3)*bos(u,0,3)

                                            2
       -3*del(3)*d(-3)*bos(u,0,1)*bos(u,0,0)

equ_chiral1:=sub(d(-3)=1,del(3)=1,com);


equ_chiral1 := 

               -3*bos(u,3,1)*bos(u,0,0)

               -3*bos(u,3,0)*bos(u,0,1)

               -bos(u,0,3)

                                       2
               -3*bos(u,0,1)*bos(u,0,0)

clear lax,lb2,la2,lb3,la3,lax3,lax,comm,com,result;


clearrules chiral1;


let trad;



% 21.) Conservation laws;
% we would like to check the conservations laws for our third
%generalization of susy kdv equation;
%

ham:=fcomb({{u,1,b}},3,a,b);


*** a already defined as operator 

ham := a(1)*bos(u,3,0)*bos(u,0,0)

                       3
       +a(2)*bos(u,0,0)


conserv:=dot_ham({{u,equ}},ham);


conserv := 

           -a(1)*bos(u,3,3)*bos(u,0,0)

           -9*a(1)*bos(u,3,1)*bos(u,3,0)*bos(u,0,0)

                                   3
           +3*bos(u,3,1)*bos(u,0,0) *(

              -3*a(2)

              +a(1))

                             2
           -3*a(1)*bos(u,3,0) *bos(u,0,1)

           -a(1)*bos(u,3,0)*bos(u,0,3)

                                              2
           +9*bos(u,3,0)*bos(u,0,1)*bos(u,0,0) *(

              -a(2)

              +a(1))

                                   2
           +3*bos(u,0,3)*bos(u,0,0) *(

              -a(2)

              +a(1))

           +3*a(1)*(bos(u,0,2)*bos(u,0,1)*bos(u,0,0))

                                         4
           +9*a(2)*(bos(u,0,1)*bos(u,0,0) )

           -3*a(1)*fer(u,2,2)*fer(u,2,0)*bos(u,0,0)

                                                   2
           -6*a(1)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)

                                                   2
           -6*a(1)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)

           -6*a(1)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)

           -3*a(1)*fer(u,1,2)*fer(u,1,0)*bos(u,0,0)

% we check now on susy-divergence behaviour;
%
az:=war(conserv,u);


az := {12*(3*a(2)

           +a(1)),

       6*(3*a(2)

          +a(1)),

       12*(

           -3*a(2)

           -a(1)),

       12*(

           -3*a(2)

           -a(1)),

       12*(

           -3*a(2)

           -a(1))}

solve(az);


Unknowns: {a(2),a(1)}

{{a(2)=(

        -arbcomplex(1))/3,a(1)=arbcomplex(1)}}

clear equ,ha,conserv,az;



% 22.) The residue of Lax operator
% we would like to find conservation laws for Lax susy KdV
% equation considered in the previous example
%
lax:=d(1)-d(-3)*del(1)*der(2)*bos(u,0,0);


lax := d(1)

       -del(1)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,0)

lb2:=lax^2;


lb2 := 

       -bos(u,0,0)*(d(-3)*bos(u,0,1)

          +d(-3)*bos(u,0,0)*d(1))

       -fer(u,2,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

            2
       +d(1)

       -del(1)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*d(-3)*bos(u,0,0)*d(1)*der(2)

       -del(1)*d(-3)*fer(u,2,0)*d(1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(1)

la2:=chan(lb2);


la2 := 

                  2
       -bos(u,0,0)

       -fer(u,2,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

            2
       +d(1)

       -2*del(1)*bos(u,0,0)*der(2)

       -2*del(1)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)

lb4:=la2^2;


lb4 := 

                               2
       -2*bos(u,3,0)*bos(u,0,0)

       +2*bos(u,3,0)*bos(u,0,0)*(d(-3)*bos(u,0,1)

          +d(-3)*bos(u,0,0)*d(1))

       -4*bos(u,0,2)*bos(u,0,0)

                    2
       -4*bos(u,0,1)

       -12*bos(u,0,1)*bos(u,0,0)*d(1)

       +bos(u,0,1)*(

          -d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

          +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

          +d(-3)*bos(u,0,2)

          +d(-3)*bos(u,0,1)*d(1)

          +d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          -d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

                  4
       +bos(u,0,0)

                    2     2
       -6*bos(u,0,0) *d(1)

       -fer(u,2,2)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -4*fer(u,2,1)*bos(u,0,0)*der(2)

       -fer(u,2,1)*fer(u,2,0)

       +fer(u,2,1)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +2*fer(u,2,0)*bos(u,3,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -3*fer(u,2,0)*bos(u,0,1)*der(2)

                             2
       +fer(u,2,0)*bos(u,0,0) *(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -5*fer(u,2,0)*bos(u,0,0)*d(1)*der(2)

       +6*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*(2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                           3
          +d(-3)*bos(u,0,0) *der(2)

                                2
          -d(-3)*bos(u,0,0)*d(1) *der(2)

          +2*d(-3)*fer(u,2,0)*bos(u,3,0)

                                        2
          +3*d(-3)*fer(u,2,0)*bos(u,0,0)

          -d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

          -d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

                                2
          -d(-3)*fer(u,2,0)*d(1)

          +2*d(-3)*fer(u,1,0)*bos(u,0,1)

          +2*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

          +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

          -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

          -d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

          -d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)

          -d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(1)

          -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

       -2*fer(u,1,1)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

                               2
       -4*fer(u,1,0)*bos(u,0,0) *der(2)

       +fer(u,1,0)*bos(u,0,0)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

            4
       +d(1)

       +del(1)*bos(u,3,1)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*bos(u,3,1)*d(-3)*fer(u,2,0)

       +5*del(1)*bos(u,3,0)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,2,1)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -del(1)*bos(u,0,2)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -3*del(1)*bos(u,0,1)*d(1)*der(2)

                           3
       +4*del(1)*bos(u,0,0) *der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,0,1)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,2,1)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                2
       -4*del(1)*bos(u,0,0)*d(1) *der(2)

       -del(1)*fer(u,2,2)

       -3*del(1)*fer(u,2,1)*d(1)

       +5*del(1)*fer(u,2,0)*bos(u,3,0)

                                      2
       +8*del(1)*fer(u,2,0)*bos(u,0,0)

       -2*del(1)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       -2*del(1)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

                                2
       -4*del(1)*fer(u,2,0)*d(1)

       +2*del(1)*fer(u,2,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

                                            2
       +2*del(1)*fer(u,2,0)*d(-3)*bos(u,0,0) *d(1)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *d(1)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*fer(u,1,1)*bos(u,0,0)

       +5*del(1)*fer(u,1,0)*bos(u,0,1)

       +5*del(1)*fer(u,1,0)*bos(u,0,0)*d(1)

       +2*del(1)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -2*del(1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       -2*del(1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

       -2*del(1)*fer(u,1,0)*d(-3)*bos(u,0,2)

       -2*del(1)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(1)

       -2*del(1)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -2*del(1)*d(-3)*bos(u,3,1)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)

       *fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                                3
       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

                                                     2
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1) *der(2)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                             2
       -3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       *d(1)

                                                     2
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(1)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*d(1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)

       *fer(u,2,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                            2
       -3*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                                    2
       +del(1)*d(-3)*bos(u,0,1)*d(1) *der(2)

                                          2
       -del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

                                    2
       +del(1)*d(-3)*fer(u,2,1)*d(1)

       -2*del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

                                                  2
       -2*del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0) *d(1)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)

       *fer(u,2,0)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *der(2)

       -2*del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)

       *fer(u,2,0)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*d(-3)*fer(u,2,0)*bos(u,3,1)

       -4*del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -2*del(1)*d(-3)*fer(u,1,1)*bos(u,0,1)

       -2*del(1)*d(-3)*fer(u,1,1)*bos(u,0,0)*d(1)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)*d(1)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

                                          3
       -del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)

                                               2
       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

kxk^3:=0;


   3
kxk  := 0

la4:=chan(lb4);


la4 := 

       -4*bos(u,0,2)*bos(u,0,0)

                    2
       -3*bos(u,0,1)

       -12*bos(u,0,1)*bos(u,0,0)*d(1)

       +bos(u,0,1)*(d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          -d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

                  4
       +bos(u,0,0)

                    2     2
       -6*bos(u,0,0) *d(1)

       -fer(u,2,2)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -4*fer(u,2,1)*bos(u,0,0)*der(2)

       -2*fer(u,2,1)*fer(u,2,0)

       +fer(u,2,1)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +2*fer(u,2,0)*bos(u,3,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -2*fer(u,2,0)*bos(u,0,1)*der(2)

                             2
       +fer(u,2,0)*bos(u,0,0) *(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -6*fer(u,2,0)*bos(u,0,0)*d(1)*der(2)

       +8*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*(2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*bos(u,0,2)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                           3
          +d(-3)*bos(u,0,0) *der(2)

          -d(-3)*fer(u,2,2)

          +2*d(-3)*fer(u,2,0)*bos(u,3,0)

                                        2
          +2*d(-3)*fer(u,2,0)*bos(u,0,0)

          -2*d(-3)*fer(u,1,1)*bos(u,0,0)

          -d(-3)*fer(u,1,0)*bos(u,0,1)

          -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

       -2*fer(u,1,1)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

                               2
       -4*fer(u,1,0)*bos(u,0,0) *der(2)

       +fer(u,1,0)*bos(u,0,0)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

            4
       +d(1)

       +del(1)*bos(u,3,1)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*bos(u,3,1)*d(-3)*fer(u,2,0)

       +6*del(1)*bos(u,3,0)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,2,1)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*bos(u,0,2)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -2*del(1)*bos(u,0,1)*d(1)*der(2)

                           3
       +4*del(1)*bos(u,0,0) *der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,0,1)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,2,1)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                2
       -4*del(1)*bos(u,0,0)*d(1) *der(2)

       -2*del(1)*fer(u,2,2)

       -2*del(1)*fer(u,2,1)*d(1)

       +6*del(1)*fer(u,2,0)*bos(u,3,0)

                                      2
       +8*del(1)*fer(u,2,0)*bos(u,0,0)

                                2
       -4*del(1)*fer(u,2,0)*d(1)

       -3*del(1)*fer(u,2,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*fer(u,1,1)*bos(u,0,0)

       +2*del(1)*fer(u,1,0)*bos(u,0,1)

       +6*del(1)*fer(u,1,0)*bos(u,0,0)*d(1)

       -2*del(1)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -3*del(1)*d(-3)*bos(u,3,1)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,1)*der(2)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)

       *fer(u,2,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                                3
       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,2)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                             2
       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)

       *fer(u,2,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*bos(u,0,3)*der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                            2
       -3*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,3)

       -2*del(1)*d(-3)*fer(u,2,1)*bos(u,3,0)

                                            2
       -3*del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

       +3*del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)

       *fer(u,2,0)

       -del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *der(2)

       -2*del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)

       *fer(u,2,0)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -3*del(1)*d(-3)*fer(u,2,0)*bos(u,3,1)

       -3*del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

       +3*del(1)*d(-3)*fer(u,1,2)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,1,1)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,2)

                                          3
       -del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)

lc4:=sub(kxk=1,qq=-3,sub(d(-3)=kxk*d(qq),la4));


lc4 := 

       -4*bos(u,0,2)*bos(u,0,0)

                    2
       -3*bos(u,0,1)

       -12*bos(u,0,1)*bos(u,0,0)*d(1)

       +bos(u,0,1)*(d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          -d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

                  4
       +bos(u,0,0)

                    2     2
       -6*bos(u,0,0) *d(1)

       -fer(u,2,2)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -4*fer(u,2,1)*bos(u,0,0)*der(2)

       -2*fer(u,2,1)*fer(u,2,0)

       +fer(u,2,1)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +2*fer(u,2,0)*bos(u,3,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -2*fer(u,2,0)*bos(u,0,1)*der(2)

                             2
       +fer(u,2,0)*bos(u,0,0) *(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -6*fer(u,2,0)*bos(u,0,0)*d(1)*der(2)

       +8*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*(2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*bos(u,0,2)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                           3
          +d(-3)*bos(u,0,0) *der(2)

          -d(-3)*fer(u,2,2)

          +2*d(-3)*fer(u,2,0)*bos(u,3,0)

                                        2
          +2*d(-3)*fer(u,2,0)*bos(u,0,0)

          -2*d(-3)*fer(u,1,1)*bos(u,0,0)

          -d(-3)*fer(u,1,0)*bos(u,0,1)

          -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

       -2*fer(u,1,1)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

                               2
       -4*fer(u,1,0)*bos(u,0,0) *der(2)

       +fer(u,1,0)*bos(u,0,0)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

            4
       +d(1)

       +del(1)*bos(u,3,1)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*bos(u,3,1)*d(-3)*fer(u,2,0)

       +6*del(1)*bos(u,3,0)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,2,1)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*bos(u,0,2)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -2*del(1)*bos(u,0,1)*d(1)*der(2)

                           3
       +4*del(1)*bos(u,0,0) *der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

                         2
       -del(1)*bos(u,0,0) *d(-3)*bos(u,0,1)*der(2)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,2,1)

                         2
       -del(1)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                2
       -4*del(1)*bos(u,0,0)*d(1) *der(2)

       -2*del(1)*fer(u,2,2)

       -2*del(1)*fer(u,2,1)*d(1)

       +6*del(1)*fer(u,2,0)*bos(u,3,0)

                                      2
       +8*del(1)*fer(u,2,0)*bos(u,0,0)

                                2
       -4*del(1)*fer(u,2,0)*d(1)

       -3*del(1)*fer(u,2,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       -del(1)*fer(u,2,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*fer(u,1,1)*bos(u,0,0)

       +2*del(1)*fer(u,1,0)*bos(u,0,1)

       +6*del(1)*fer(u,1,0)*bos(u,0,0)*d(1)

       -2*del(1)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +2*del(1)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -3*del(1)*d(-3)*bos(u,3,1)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,1)*der(2)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*der(2)

                                                3
       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,2)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                             2
       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +del(1)*d(-3)*bos(u,0,3)*der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                               2
       -del(1)*d(-3)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                            2
       -3*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,3)

       -2*del(1)*d(-3)*fer(u,2,1)*bos(u,3,0)

                                            2
       -3*del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

       +3*del(1)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -2*del(1)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       -3*del(1)*d(-3)*fer(u,2,0)*bos(u,3,1)

       -3*del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

       +3*del(1)*d(-3)*fer(u,1,2)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,1,1)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -del(1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,2)

                                          3
       -del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)

lb5:=lax*lc4;


                              2
lb5 := 2*bos(u,3,1)*bos(u,0,0)

       +bos(u,3,1)*bos(u,0,0)*(d(-3)*bos(u,0,1)

          +d(-3)*bos(u,0,0)*d(1))

       +4*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)

       +2*bos(u,3,0)*bos(u,0,0)*(d(-3)*bos(u,3,0)*bos(u,0,0)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

          -d(-3)*bos(u,0,2)

          -d(-3)*bos(u,0,1)*d(1))

       -6*bos(u,0,3)*bos(u,0,0)

       -10*bos(u,0,2)*bos(u,0,1)

       -20*bos(u,0,2)*bos(u,0,0)*d(1)

       +bos(u,0,2)*(d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          -d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

                     2
       -15*bos(u,0,1) *d(1)

                                3
       +12*bos(u,0,1)*bos(u,0,0)

                               2
       +2*bos(u,0,1)*bos(u,0,0) *(d(-3)*bos(u,0,1)

          +d(-3)*bos(u,0,0)*d(1))

       +bos(u,0,1)*bos(u,0,0)*(

                  2
          -30*d(1)

          -3*d(-3)*bos(u,0,1)*bos(u,0,0)

          -d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

          +2*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

          -d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0))

                    4
       +5*bos(u,0,0) *d(1)

                  3
       +bos(u,0,0) *(d(-3)*bos(u,3,0)*bos(u,0,0)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(1)

          -d(-3)*bos(u,0,2)

          -d(-3)*bos(u,0,1)*d(1)

          -d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          +d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

                     2     3
       -10*bos(u,0,0) *d(1)

       +bos(u,0,0)*(

          -3*d(-3)*bos(u,3,2)*bos(u,0,0)

          -6*d(-3)*bos(u,3,1)*bos(u,0,1)

          -3*d(-3)*bos(u,3,1)*bos(u,0,0)*d(1)

          -d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,3,1)*d(-3)*bos(u,0,2)

          +d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*d(1)

                             2
          +2*d(-3)*bos(u,3,0) *bos(u,0,0)

          -3*d(-3)*bos(u,3,0)*bos(u,0,2)

          -2*d(-3)*bos(u,3,0)*bos(u,0,1)*d(1)

                                      3
          +d(-3)*bos(u,3,0)*bos(u,0,0)

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

          -3*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)

          +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)

          +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*d(1)

                                                         2
          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

                                            3
          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *d(1)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,1,0)

                                                       2
          -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0) *der(2)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*der(2)

          +d(-3)*bos(u,0,4)

          +d(-3)*bos(u,0,3)*d(1)

                                        2
          -3*d(-3)*bos(u,0,2)*bos(u,0,0)

          +3*d(-3)*bos(u,0,2)*d(-3)*bos(u,0,1)*bos(u,0,0)

          -2*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

                             2
          -3*d(-3)*bos(u,0,1) *bos(u,0,0)

                           2
          -d(-3)*bos(u,0,1) *d(-3)*bos(u,0,1)

                           2
          -d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*d(1)

                                        2
          -3*d(-3)*bos(u,0,1)*bos(u,0,0) *d(1)

          -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,2)*fer(u,1,0)

          -d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*fer(u,2,0)

          +d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

          +d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          +3*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

          -d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)

          -d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*d(1)

          +d(-3)*fer(u,2,1)*fer(u,1,1)

          -d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)*der(2)

          -3*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,1)*bos(u,0,0)

          -3*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,1)

          -2*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)

          +d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

          -d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*fer(u,2,0)

          -3*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,2,1)

          +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -2*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,3,0)

                                                   2
          -3*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

          +d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

          +d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

          -d(-3)*fer(u,1,2)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*fer(u,1,2)*d(-3)*fer(u,2,1)

          -d(-3)*fer(u,1,2)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*fer(u,1,1)*bos(u,0,1)*der(2)

          +2*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

          +d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)*der(2)

                                            3
          +d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0) *der(2)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,2,2)

          +d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                         2
          +2*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

          -2*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*bos(u,0,0)

          -2*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,1)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

          +2*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,1,0)*bos(u,0,2)*der(2)

          +d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                      3
          +d(-3)*fer(u,1,0)*bos(u,0,0) *der(2))

       -fer(u,2,3)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -5*fer(u,2,2)*bos(u,0,0)*der(2)

       +fer(u,2,2)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +3*fer(u,2,1)*bos(u,3,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -5*fer(u,2,1)*bos(u,0,1)*der(2)

                               2
       +3*fer(u,2,1)*bos(u,0,0) *(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -10*fer(u,2,1)*bos(u,0,0)*d(1)*der(2)

       +10*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,1)*(2*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*der(2)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

          -d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*bos(u,0,2)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

                           3
          +d(-3)*bos(u,0,0) *der(2)

          -d(-3)*fer(u,2,2)

          +2*d(-3)*fer(u,2,0)*bos(u,3,0)

                                        2
          +2*d(-3)*fer(u,2,0)*bos(u,0,0)

          -2*d(-3)*fer(u,1,1)*bos(u,0,0)

          -d(-3)*fer(u,1,0)*bos(u,0,1)

          -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

          +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

       +3*fer(u,2,0)*bos(u,3,1)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       +10*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*der(2)

       +fer(u,2,0)*bos(u,3,0)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          -2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          -3*d(-3)*bos(u,0,1)*der(2)

          -3*d(-3)*fer(u,2,1)

          -3*d(-3)*fer(u,1,0)*bos(u,0,0))

       -5*fer(u,2,0)*bos(u,0,2)*der(2)

       +7*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -10*fer(u,2,0)*bos(u,0,1)*d(1)*der(2)

                                3
       +10*fer(u,2,0)*bos(u,0,0) *der(2)

                               2
       -3*fer(u,2,0)*bos(u,0,0) *(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +fer(u,2,0)*bos(u,0,0)*(

                  2
          -10*d(1) *der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,1)*d(-3)*bos(u,0,1)*der(2)

          +d(-3)*bos(u,0,1)*d(-3)*fer(u,2,1)

          +d(-3)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

          +d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

          +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

          +d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

          +3*d(-3)*fer(u,2,1)*bos(u,0,0)

          +3*d(-3)*fer(u,2,0)*bos(u,0,1)

          +2*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)

          +d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,2)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*d(1))

       +10*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)

       +10*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)

       +20*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(1)

       +fer(u,2,0)*fer(u,1,0)*(

          -3*d(-3)*fer(u,2,0)*fer(u,1,0)

          +2*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

          +2*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

          +3*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2))

       +fer(u,2,0)*(

          -3*d(-3)*bos(u,3,1)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

          +d(-3)*bos(u,3,1)*d(-3)*fer(u,2,1)

          +d(-3)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -2*d(-3)*bos(u,3,0)*bos(u,0,1)*der(2)

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*der(2)

                                            3
          -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,2)

          -2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                         2
          -2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

          +2*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

          +d(-3)*bos(u,0,3)*der(2)

                           2
          -d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                           2
          -d(-3)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                        2
          -3*d(-3)*bos(u,0,1)*bos(u,0,0) *der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

          +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          +d(-3)*fer(u,2,3)

          -2*d(-3)*fer(u,2,1)*bos(u,3,0)

                                        2
          -3*d(-3)*fer(u,2,1)*bos(u,0,0)

          -d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

          -d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

          +3*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

          -2*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

          -3*d(-3)*fer(u,2,0)*bos(u,3,1)

          -3*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

          +d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

          +3*d(-3)*fer(u,1,2)*bos(u,0,0)

          +3*d(-3)*fer(u,1,1)*bos(u,0,1)

          +d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

          -d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

          -2*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*fer(u,1,0)*bos(u,0,2)

                                      3
          -d(-3)*fer(u,1,0)*bos(u,0,0) )

       -3*fer(u,1,2)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -3*fer(u,1,1)*bos(u,0,1)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

                                2
       -10*fer(u,1,1)*bos(u,0,0) *der(2)

       +3*fer(u,1,1)*bos(u,0,0)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +fer(u,1,0)*bos(u,3,0)*bos(u,0,0)*(d(-3)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0))

       -10*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*der(2)

       +fer(u,1,0)*bos(u,0,1)*(d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,0,1)*der(2)

          +d(-3)*fer(u,2,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

                                2
       -10*fer(u,1,0)*bos(u,0,0) *d(1)*der(2)

       +2*fer(u,1,0)*bos(u,0,0)*(d(-3)*bos(u,3,1)*d(-3)*bos(u,0,0)*der(2)

          +d(-3)*bos(u,3,1)*d(-3)*fer(u,2,0)

          +d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

          +d(-3)*fer(u,2,0)*bos(u,3,0)

          +d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

          +d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*d(1)

          +d(-3)*fer(u,1,0)*bos(u,0,1)

          +d(-3)*fer(u,1,0)*bos(u,0,0)*d(1))

            5
       +d(1)

       +del(1)*bos(u,3,2)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*bos(u,3,2)*d(-3)*fer(u,2,0)

       +4*del(1)*bos(u,3,1)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,3,1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*bos(u,3,1)*d(-3)*fer(u,2,1)

       -del(1)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

                           2
       -2*del(1)*bos(u,3,0) *d(-3)*bos(u,0,0)*der(2)

                           2
       -2*del(1)*bos(u,3,0) *d(-3)*fer(u,2,0)

       +2*del(1)*bos(u,3,0)*bos(u,0,1)*der(2)

                                    2
       -del(1)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,0)*der(2)

                                    2
       -del(1)*bos(u,3,0)*bos(u,0,0) *d(-3)*fer(u,2,0)

       +6*del(1)*bos(u,3,0)*bos(u,0,0)*d(1)*der(2)

       -2*del(1)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*bos(u,3,0)*d(-3)*bos(u,0,2)*der(2)

                                          3
       -del(1)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

       +del(1)*bos(u,3,0)*d(-3)*fer(u,2,2)

       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                       2
       -2*del(1)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +2*del(1)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       +del(1)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       -del(1)*bos(u,0,3)*der(2)

       +2*del(1)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*bos(u,0,2)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -4*del(1)*bos(u,0,2)*d(1)*der(2)

                         2
       +del(1)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                         2
       +del(1)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                       2
       +10*del(1)*bos(u,0,1)*bos(u,0,0) *der(2)

       -2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       -del(1)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                                2
       -6*del(1)*bos(u,0,1)*d(1) *der(2)

                           3
       +4*del(1)*bos(u,0,0) *d(1)*der(2)

                                3
       -4*del(1)*bos(u,0,0)*d(1) *der(2)

       -del(1)*fer(u,2,3)

       -4*del(1)*fer(u,2,2)*d(1)

       +2*del(1)*fer(u,2,1)*bos(u,3,0)

                                      2
       +4*del(1)*fer(u,2,1)*bos(u,0,0)

       -del(1)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

                                2
       -6*del(1)*fer(u,2,1)*d(1)

       -del(1)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*fer(u,2,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -del(1)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       -del(1)*fer(u,2,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +4*del(1)*fer(u,2,0)*bos(u,3,1)

       +6*del(1)*fer(u,2,0)*bos(u,3,0)*d(1)

       +12*del(1)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

                                      2
       +8*del(1)*fer(u,2,0)*bos(u,0,0) *d(1)

       -del(1)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       +del(1)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                3
       -4*del(1)*fer(u,2,0)*d(1)

       +del(1)*fer(u,1,2)*bos(u,0,0)

       +3*del(1)*fer(u,1,1)*bos(u,0,1)

       +4*del(1)*fer(u,1,1)*bos(u,0,0)*d(1)

       -2*del(1)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,0)*der(2)

       -2*del(1)*fer(u,1,1)*fer(u,1,0)*d(-3)*fer(u,2,0)

       -del(1)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +2*del(1)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*fer(u,1,1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +del(1)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       -4*del(1)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +3*del(1)*fer(u,1,0)*bos(u,0,2)

       +8*del(1)*fer(u,1,0)*bos(u,0,1)*d(1)

                                      3
       -2*del(1)*fer(u,1,0)*bos(u,0,0)

                                           2
       +6*del(1)*fer(u,1,0)*bos(u,0,0)*d(1)

       -del(1)*d(-3)*bos(u,3,1)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,3,1)*bos(u,3,0)*d(-3)*fer(u,2,0)

                                            2
       -2*del(1)*d(-3)*bos(u,3,1)*bos(u,0,0) *d(-3)*bos(u,0,0)*der(2)

                                            2
       -2*del(1)*d(-3)*bos(u,3,1)*bos(u,0,0) *d(-3)*fer(u,2,0)

                                 2
       -6*del(1)*d(-3)*bos(u,3,0) *bos(u,0,0)*der(2)

                                 2
       +2*del(1)*d(-3)*bos(u,3,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)*der(2)

                                 2
       +2*del(1)*d(-3)*bos(u,3,0) *d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

                                 2
       +2*del(1)*d(-3)*bos(u,3,0) *d(-3)*bos(u,0,1)*der(2)

                                 2
       +2*del(1)*d(-3)*bos(u,3,0) *d(-3)*fer(u,2,1)

                                 2
       +2*del(1)*d(-3)*bos(u,3,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,2)*der(2)

       -4*del(1)*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       -4*del(1)*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,1)*d(1)*der(2)

                                            3
       -8*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *der(2)

                                            2
       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

                                            2
       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

                                            2
       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,1)*der(2)

                                            2
       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*fer(u,2,1)

                                            2
       +2*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                                 2
       +4*del(1)*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1) *der(2)

       +3*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*fer(u,2,1)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)*der(2)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*der(2)

                                                                 3
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,2)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                                              2
       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       -2*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)*der(2)

                                                2
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*der(2)

                                                2
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1) *d(-3)*fer(u,2,0)

                                                             2
       +3*del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0) *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       *der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,3)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*bos(u,3,0)

                                                             2
       +3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,0)

       -3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       *der(2)

       +3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,3,1)

       +3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)

       *fer(u,2,0)

       -3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,2)*bos(u,0,0)

       -3*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*bos(u,0,1)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *der(2)

       +2*del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       -del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,2)

                                                           3
       +del(1)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*d(-3)*bos(u,0,3)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,0,3)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                            2
       +8*del(1)*d(-3)*bos(u,0,2)*bos(u,0,0) *der(2)

       -del(1)*d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       -del(1)*d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       -del(1)*d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*fer(u,2,1)

       -del(1)*d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                                 2
       +5*del(1)*d(-3)*bos(u,0,1) *bos(u,0,0)*der(2)

                                          3
       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *d(-3)*bos(u,0,0)*der(2)

                                          3
       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *d(-3)*fer(u,2,0)

                                             2
       +18*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0) *d(1)*der(2)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,0)

       *der(2)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,1)*d(-3)*fer(u,2,0)

       -3*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)*der(2)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *fer(u,2,0)

                                                           3
       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,2)

       -3*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                                        2
       -2*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +2*del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,1)*bos(u,0,0)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *d(1)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)

       *fer(u,1,0)

       -del(1)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*der(2)

                               5
       -del(1)*d(-3)*bos(u,0,0) *der(2)

                                 3     2
       +6*del(1)*d(-3)*bos(u,0,0) *d(1) *der(2)

                                    4
       -del(1)*d(-3)*bos(u,0,0)*d(1) *der(2)

       +2*del(1)*d(-3)*fer(u,2,2)*bos(u,3,0)

                                            2
       +4*del(1)*d(-3)*fer(u,2,2)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,2)*bos(u,0,0)*d(-3)*bos(u,0,1)

       -del(1)*d(-3)*fer(u,2,2)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

       -del(1)*d(-3)*fer(u,2,2)*fer(u,2,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,2,2)*fer(u,2,0)*d(-3)*fer(u,2,0)

       +2*del(1)*d(-3)*fer(u,2,1)*bos(u,3,0)*d(1)

       +4*del(1)*d(-3)*fer(u,2,1)*bos(u,0,1)*bos(u,0,0)

                                            2
       +8*del(1)*d(-3)*fer(u,2,1)*bos(u,0,0) *d(1)

       -del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *d(1)

       +del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

       +del(1)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*d(1)

       -4*del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,0)

                                            2
       -6*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                        2
       -16*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

                                                 2
       +4*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(1)

       +3*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)

       *fer(u,1,0)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*der(2)

       -2*del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       *der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +10*del(1)*d(-3)*fer(u,2,0)*bos(u,0,2)*bos(u,0,0)

                                            2
       +3*del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)

       +22*del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*d(1)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*fer(u,1,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

                                            4
       -5*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)

                                          3
       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0) *d(-3)*bos(u,0,1)

                                          3
       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0) *d(-3)*bos(u,0,0)*d(1)

                                             2     2
       +12*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0) *d(1)

       +2*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)

       *bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       *d(1)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,3)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,2)*d(1)

                                                                        2
       +2*del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*d(1)

                                                           3
       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*bos(u,0,0) *d(1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)

       *fer(u,2,0)

       -del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*fer(u,1,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)

       *fer(u,2,0)

                                                                      2
       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

       *der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)

       *bos(u,3,0)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)

       *bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*d(1)

       +2*del(1)*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,1)*fer(u,1,0)

       +2*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*der(2)

       +2*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)

                                                       2
       +8*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0) *der(2)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)*der(2)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *fer(u,2,0)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,1)*der(2)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,2,1)

       -4*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*bos(u,0,1)

       *der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)

       *bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)

       *bos(u,3,0)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,1)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*d(1)

       +3*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,3,0)

       *bos(u,0,0)

       -del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,2)

       -del(1)*d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       *d(1)

                                    4
       -del(1)*d(-3)*fer(u,2,0)*d(1)

       -del(1)*d(-3)*fer(u,1,2)*fer(u,1,0)*d(-3)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,2)*fer(u,1,0)*d(-3)*fer(u,2,0)

       +2*del(1)*d(-3)*fer(u,1,1)*bos(u,3,0)*bos(u,0,0)

                                            2
       -2*del(1)*d(-3)*fer(u,1,1)*bos(u,0,0) *d(-3)*bos(u,0,1)

                                            2
       -2*del(1)*d(-3)*fer(u,1,1)*bos(u,0,0) *d(-3)*bos(u,0,0)*d(1)

       -4*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)*der(2)

       +2*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *der(2)

       +2*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)

       +2*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,1)*der(2)

       +2*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*fer(u,2,1)

       +2*del(1)*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,1)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,1,0)*bos(u,3,1)*d(-3)*bos(u,0,1)

       -del(1)*d(-3)*fer(u,1,0)*bos(u,3,1)*d(-3)*bos(u,0,0)*d(1)

       -6*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,1)

       -6*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)*d(1)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *d(1)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*bos(u,0,2)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*bos(u,0,1)*d(1)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *der(2)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,3)

       +4*del(1)*d(-3)*fer(u,1,0)*bos(u,0,2)*d(1)

                                                        2
       -16*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)*d(1)

                                                 2
       +6*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(1)

       +3*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,2,0)

       *fer(u,1,0)

       -del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*der(2)

       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       *der(2)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

                                            3
       -8*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(1)

                                            2
       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*bos(u,0,0)

                                            2
       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

                                            2
       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       *d(1)

                                            2
       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*bos(u,0,2)

                                            2
       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*bos(u,0,1)*d(1)

                                            2
       +2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,2,0)*fer(u,1,0)

                                            2
       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       *der(2)

                                            2
       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)

                                            2
       -2*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)*der(2)

                                                 3
       +4*del(1)*d(-3)*fer(u,1,0)*bos(u,0,0)*d(1)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,2)*bos(u,0,0)

       +6*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,1)*bos(u,0,1)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,1)*bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)*d(1)

                                                  2
       -2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0) *bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,2)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,1)*d(1)

                                                           3
       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       *d(1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)*d(1)

                                                                              2
       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

                                                                 3
       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0) *d(1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,1,0)

                                                                            2
       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       *der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,4)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,3)*d(1)

                                                             2
       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*bos(u,0,0)

       -3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*bos(u,0,0)

       *der(2)

                                                  2
       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1) *bos(u,0,0)

                                                2
       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,1)

                                                2
       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)*d(1)

                                                             2
       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0) *d(1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)

       *bos(u,0,0)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       *d(1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,2,0)

       *fer(u,1,0)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,2)*fer(u,1,0)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*fer(u,2,0)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       *der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*fer(u,2,1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       -3*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       *d(1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*fer(u,1,1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       *der(2)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,1)*bos(u,0,0)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,1)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       *d(1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)

       *fer(u,2,0)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*fer(u,2,0)

       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)

       *der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,2,1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)

       *bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,3,0)

                                                                        2
       +3*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)

       *bos(u,0,1)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*d(1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*bos(u,0,1)*der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*fer(u,2,1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*bos(u,0,1)*der(2)

       -2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       *der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)*der(2)

                                                                 3
       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0) *der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*bos(u,3,0)

                                                                              2
       -2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,1)*bos(u,0,0)

       +2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       *d(1)

       -2*del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)*der(2)

       +del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,2)*der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *bos(u,0,0)*der(2)

       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)

       *fer(u,2,0)

                                                           3
       -del(1)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0) *der(2)

lc5:=s_part(lb5,3);


lc5 := bos(u,3,2)*d(-3)*bos(u,0,0)

       +4*bos(u,3,1)*bos(u,0,0)

       +bos(u,3,1)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

                    2
       -2*bos(u,3,0) *d(-3)*bos(u,0,0)

       +2*bos(u,3,0)*bos(u,0,1)

                             2
       -bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,0)

       +6*bos(u,3,0)*bos(u,0,0)*d(1)

       +bos(u,3,0)*(

          -2*d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,0,2)

                           3
          -d(-3)*bos(u,0,0) )

       -bos(u,0,3)

       +2*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -4*bos(u,0,2)*d(1)

                  2
       +bos(u,0,1) *d(-3)*bos(u,0,0)

                                2
       +10*bos(u,0,1)*bos(u,0,0)

       +bos(u,0,1)*bos(u,0,0)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

                         2
       -6*bos(u,0,1)*d(1)

                    3
       +4*bos(u,0,0) *d(1)

                         3
       -4*bos(u,0,0)*d(1)

       -fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +fer(u,2,1)*(d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1))

       +fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -2*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,0)

       +fer(u,1,1)*(2*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       -d(-3)*bos(u,3,1)*bos(u,3,0)*d(-3)*bos(u,0,0)

                                     2
       -2*d(-3)*bos(u,3,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

                          2
       -6*d(-3)*bos(u,3,0) *bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*bos(u,0,2)

       -4*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*bos(u,0,1)*d(1)

                                     3
       -8*d(-3)*bos(u,3,0)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,1)

                                          2
       +4*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)

       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)

                                                          3
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)

                                         2
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)

                                                      2
       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*bos(u,0,3)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                     2
       +8*d(-3)*bos(u,0,2)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,1)

                          2
       +5*d(-3)*bos(u,0,1) *bos(u,0,0)

                                   3
       -d(-3)*bos(u,0,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

                                      2
       +18*d(-3)*bos(u,0,1)*bos(u,0,0) *d(1)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,0)

       -3*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                        5
       -d(-3)*bos(u,0,0)

                          3     2
       +6*d(-3)*bos(u,0,0) *d(1)

                             4
       -d(-3)*bos(u,0,0)*d(1)

       -d(-3)*fer(u,2,2)*fer(u,2,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +2*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                               2
       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                2
       +8*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*fer(u,1,2)*fer(u,1,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,1)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                                                     2
       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +2*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*bos(u,0,0)

       +3*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*bos(u,0,1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)

                                                          3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

la5:=lc5-sub(d(-3)=0,lc5);


la5 := bos(u,3,2)*d(-3)*bos(u,0,0)

       +bos(u,3,1)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

                    2
       -2*bos(u,3,0) *d(-3)*bos(u,0,0)

                             2
       -bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,0)

       +bos(u,3,0)*(

          -2*d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,0,2)

                           3
          -d(-3)*bos(u,0,0) )

       +2*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,0)

                  2
       +bos(u,0,1) *d(-3)*bos(u,0,0)

       +bos(u,0,1)*bos(u,0,0)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

       -fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +fer(u,2,1)*(d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1))

       +fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -2*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,0)

       +fer(u,1,1)*(2*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       -d(-3)*bos(u,3,1)*bos(u,3,0)*d(-3)*bos(u,0,0)

                                     2
       -2*d(-3)*bos(u,3,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

                          2
       -6*d(-3)*bos(u,3,0) *bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*bos(u,0,2)

       -4*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*bos(u,0,1)*d(1)

                                     3
       -8*d(-3)*bos(u,3,0)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,1)

                                          2
       +4*d(-3)*bos(u,3,0)*bos(u,0,0)*d(1)

       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)

                                                          3
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)

                                         2
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)

                                                      2
       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*bos(u,0,3)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                     2
       +8*d(-3)*bos(u,0,2)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,1)

                          2
       +5*d(-3)*bos(u,0,1) *bos(u,0,0)

                                   3
       -d(-3)*bos(u,0,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

                                      2
       +18*d(-3)*bos(u,0,1)*bos(u,0,0) *d(1)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,0)

       -3*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                        5
       -d(-3)*bos(u,0,0)

                          3     2
       +6*d(-3)*bos(u,0,0) *d(1)

                             4
       -d(-3)*bos(u,0,0)*d(1)

       -d(-3)*fer(u,2,2)*fer(u,2,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +2*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                               2
       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                2
       +8*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*fer(u,1,2)*fer(u,1,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,1)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                                                     2
       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +2*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*bos(u,0,0)

       +3*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*bos(u,0,1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)

                                                          3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

ld5:=chan(la5);


ld5 := bos(u,3,2)*d(-3)*bos(u,0,0)

       -4*bos(u,3,1)*bos(u,0,0)

       +bos(u,3,1)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

                    2
       -2*bos(u,3,0) *d(-3)*bos(u,0,0)

       -2*bos(u,3,0)*bos(u,0,1)

                             2
       -bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,0)

       +4*bos(u,3,0)*bos(u,0,0)*d(1)

       +bos(u,3,0)*(

          -2*d(-3)*bos(u,3,0)*bos(u,0,0)

          +d(-3)*bos(u,0,2)

                           3
          -d(-3)*bos(u,0,0) )

       +bos(u,0,3)

       +2*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -bos(u,0,2)*d(1)

                  2
       +bos(u,0,1) *d(-3)*bos(u,0,0)

       +bos(u,0,1)*bos(u,0,0)*(

          -2*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

          -d(-3)*bos(u,0,1))

                       2
       +bos(u,0,1)*d(1)

                    3
       +6*bos(u,0,0) *d(1)

                       3
       -bos(u,0,0)*d(1)

       -fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +fer(u,2,1)*(d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

          -d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1))

       +fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -2*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,0)

       +fer(u,1,1)*(2*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

          +d(-3)*fer(u,1,0)*bos(u,0,0))

       +4*d(-3)*bos(u,3,2)*bos(u,0,0)

       -d(-3)*bos(u,3,1)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +6*d(-3)*bos(u,3,1)*bos(u,0,1)

                                     2
       -2*d(-3)*bos(u,3,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

                          2
       -6*d(-3)*bos(u,3,0) *bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                          2
       +2*d(-3)*bos(u,3,0) *d(-3)*bos(u,0,1)

       +4*d(-3)*bos(u,3,0)*bos(u,0,2)

       -4*d(-3)*bos(u,3,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                     3
       -8*d(-3)*bos(u,3,0)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

                                     2
       +2*d(-3)*bos(u,3,0)*bos(u,0,0) *d(-3)*bos(u,0,1)

       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,1)

       +2*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,2)

                                                          3
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,3)

                                         2
       +d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1) *d(-3)*bos(u,0,0)

                                                      2
       +3*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       -d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -d(-3)*bos(u,0,4)

       +d(-3)*bos(u,0,3)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                     2
       +8*d(-3)*bos(u,0,2)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,2)*bos(u,0,0)*d(-3)*bos(u,0,1)

                          2
       +5*d(-3)*bos(u,0,1) *bos(u,0,0)

                                   3
       -d(-3)*bos(u,0,1)*bos(u,0,0) *d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,1)*d(-3)*bos(u,0,0)

       -3*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,1)

       +d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,2)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

                        5
       -d(-3)*bos(u,0,0)

       -d(-3)*fer(u,2,2)*fer(u,2,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,1)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +2*d(-3)*fer(u,2,1)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,3,0)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                               2
       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*bos(u,0,0)*d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)

                                                2
       +8*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,3,0)*d(-3)

       *bos(u,0,0)

       -4*d(-3)*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,2,0)*fer(u,1,0)*d(-3)*bos(u,0,0)*d(-3)*bos(u,3,0)*bos(u,0,0)

       -d(-3)*fer(u,1,2)*fer(u,1,0)*d(-3)*bos(u,0,0)

       -4*d(-3)*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*bos(u,0,0)

       +2*d(-3)*fer(u,1,1)*fer(u,1,0)*d(-3)*bos(u,0,1)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*bos(u,0,1)*d(-3)*fer(u,2,0)*d(-3)*bos(u,0,1)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

                                     2
       -2*d(-3)*fer(u,1,0)*bos(u,0,0) *d(-3)*fer(u,1,0)*bos(u,0,0)

                                                                     2
       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,3,0)*d(-3)*fer(u,1,0)*bos(u,0,1)

       +2*d(-3)*fer(u,1,0)*d(-3)*bos(u,0,2)*d(-3)*fer(u,2,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*bos(u,0,1)*bos(u,0,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,1)*d(-3)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*bos(u,0,0)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,1)*d(-3)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,3,0)*bos(u,0,0)*d(-3)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,2)*d(-3)*bos(u,0,0)

       +3*d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*bos(u,0,0)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,2,0)*bos(u,0,1)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,2)*d(-3)*bos(u,0,1)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*bos(u,0,1)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,2)

                                                          3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,1)*d(-3)*bos(u,0,0)

       -2*d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,3,0)*bos(u,0,0)

       +d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,2)

       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,1)*bos(u,0,0)*d(-3)*bos(u,0,0)

                                                    3
       -d(-3)*fer(u,1,0)*d(-3)*fer(u,1,0)*bos(u,0,0)

konserv:=sub(d(-3)=1,d_part(ld5,-1));


konserv := 5*bos(u,3,2)*bos(u,0,0)

           +5*bos(u,3,1)*bos(u,0,1)

                         2
           -10*bos(u,3,0) *bos(u,0,0)

           +5*bos(u,3,0)*bos(u,0,2)

                                    3
           -10*bos(u,3,0)*bos(u,0,0)

           -bos(u,0,4)

                                    2
           +10*bos(u,0,2)*bos(u,0,0)

                        2
           +5*bos(u,0,1) *bos(u,0,0)

                      5
           -bos(u,0,0)

           -5*fer(u,2,1)*fer(u,2,0)*bos(u,0,0)

                                               2
           +10*fer(u,2,0)*fer(u,1,0)*bos(u,0,0)

           -5*fer(u,1,1)*fer(u,1,0)*bos(u,0,0)

clear lax,lb2,la2,lb4,kxk,la4,lc4,lb5,lc5,la5,konserv;



%22.) The N=2 SuSy Boussinesq equation
% example from Z.Popowicz Phys.LettB.319 (1993) 478-484

clearrules trad;


let chiral;



lax:=del(1)*(d(1)^2+bos(j,0,0)*d(1)+bos(tt,0,0))*der(2);


lax := del(1)*bos(j,0,0)*d(1)*der(2)

       +del(1)*bos(tt,0,0)*der(2)

                   2
       +del(1)*d(1) *der(2)

la2:=del(1)*(d(1)+2*bos(j,0,0)/3)*der(2);


la2 := (2*del(1)*bos(j,0,0)*der(2)

        +3*del(1)*d(1)*der(2))/3

com:=sub(del(1)=1,der(2)=1,lax*la2-la2*lax);


com := (

        -2*bos(j,0,3)

        -2*bos(j,0,2)*bos(j,0,0)

        -3*bos(j,0,2)*d(1)

        -2*bos(j,0,1)*bos(j,0,0)*d(1)

        +3*bos(tt,0,2)

        +2*bos(tt,0,1)*bos(j,0,0)

        +6*bos(tt,0,1)*d(1)

        -2*bos(tt,0,0)*bos(j,0,1)

        -2*fer(j,2,1)*fer(j,1,0)

        +2*fer(tt,2,0)*fer(j,1,0)

        +2*fer(tt,1,0)*fer(j,2,0))/3

operator boss;


boss(j,t):=d_part(com,1);


boss(j,t) := (

              -3*bos(j,0,2)

              -2*bos(j,0,1)*bos(j,0,0)

              +6*bos(tt,0,1))/3

boss(tt,t):=d_part(com,0);


boss(tt,t) := (

               -2*bos(j,0,3)

               -2*bos(j,0,2)*bos(j,0,0)

               +3*bos(tt,0,2)

               +2*bos(tt,0,1)*bos(j,0,0)

               -2*bos(tt,0,0)*bos(j,0,1)

               -2*fer(j,2,1)*fer(j,1,0)

               +2*fer(tt,2,0)*fer(j,1,0)

               +2*fer(tt,1,0)*fer(j,2,0))/3


% let us shift bos(tt,0,0) to

bos(tt,0,0):=bos(tx,0,0)/2+bos(j,0,0)**2/6 + bos(j,0,1)/2;


bos(tt,0,0) := (3*bos(j,0,1)

                           2
                +bos(j,0,0)

                +3*bos(tx,0,0))/6

bos(tt,0,1):=pg(1,bos(tt,0,0));


bos(tt,0,1) := (3*bos(j,0,2)

                +2*bos(j,0,1)*bos(j,0,0)

                +3*bos(tx,0,1))/6

bos(tt,0,2):=pg(1,bos(tt,0,1));


bos(tt,0,2) := (3*bos(j,0,3)

                +2*bos(j,0,2)*bos(j,0,0)

                             2
                +2*bos(j,0,1)

                +3*bos(tx,0,2))/6

fer(tt,1,0):=pr(1,bos(tt,0,0));


fer(tt,1,0) := (3*fer(j,1,1)

                +2*fer(j,1,0)*bos(j,0,0)

                +3*fer(tx,1,0))/6

fer(tt,2,0):=pr(2,bos(tt,0,0));


fer(tt,2,0) := (3*fer(j,2,1)

                +2*fer(j,2,0)*bos(j,0,0)

                +3*fer(tx,2,0))/6


% then the equations of motion are;

bos(j,t):=boss(j,t);


bos(j,t) := bos(tx,0,1)

bos(tx,t):=2*(boss(tt,t) - boss(j,t)*bos(j,0,0)/3-
            pg(1,boss(j,t))/2);


bos(tx,t) := (

              -3*bos(j,0,3)

                                      2
              +2*bos(j,0,1)*bos(j,0,0)

              -6*bos(tx,0,0)*bos(j,0,1)

              -6*fer(j,2,1)*fer(j,1,0)

              -6*fer(j,2,0)*fer(j,1,1)

              +6*fer(tx,2,0)*fer(j,1,0)

              +6*fer(tx,1,0)*fer(j,2,0))/9


clear lax,la2;


clearrules chiral;


let trad;



%23.) the Jacobi identity;
% we will find the N=2 susy extension of the Virasoro algebra.
% First we found the most general form of the susy-pseudo-differential
% element of the dimension two.

vira:=pse_ele(2,{{f,1,b}},a);


*** a already defined as operator 

vira := a(2)*bos(f,3,0)

        +a(3)*bos(f,0,1)

                        2
        +a(4)*bos(f,0,0)

        +a(5)*bos(f,0,0)*d(1)

        +a(6)*bos(f,0,0)*der(1)*der(2)

                  2
        +a(0)*d(1)

        +a(1)*d(1)*der(1)*der(2)

        +a(7)*fer(f,2,0)*der(2)

        +a(8)*fer(f,2,0)*der(1)

        +a(9)*fer(f,1,0)*der(2)

        +a(10)*fer(f,1,0)*der(1)


% This vira should be antisymmetrical so we found

ewa:=vira+cp(vira);


*** d not found 

*** der not found 

*** del not found 

ewa := bos(f,3,0)*(

          -a(9)

          +a(8)

          +a(6)

          +2*a(2))

       +bos(f,0,1)*(a(10)

          +a(7)

          -a(5)

          +2*a(3))

                         2
       +2*a(4)*bos(f,0,0)

       +2*a(6)*(bos(f,0,0)*der(1)*der(2))

       -a(6)*fer(f,2,0)*der(1)

       +a(6)*fer(f,1,0)*der(2)

                   2
       +2*a(0)*d(1)


%we first solve ewa in order to found free coefficients;

load_package groebner;


adam:=groesolve(sub(der(1)=1,der(2)=1,d(1)=1,lyst1(ewa)));


adam := {{a(10)=

                -a(7)

                +a(5)

                -2*a(3),

          a(9)=a(8)

               +2*a(2),

          a(4)=0,

          a(0)=0,

          a(6)=0}}


% we define now the most general antisymmetrical susy-pseudo-symmetrical
% element of conformal dimension two.

vira:=sub(adam,vira);


vira := a(2)*bos(f,3,0)

        +a(3)*bos(f,0,1)

        +a(5)*bos(f,0,0)*d(1)

        +fer(f,2,0)*(der(2)*a(7)

           +der(1)*a(8))

        +fer(f,1,0)*(der(2)*a(8)

           +2*der(2)*a(2)

           -der(1)*a(7)

           +der(1)*a(5)

           -2*der(1)*a(3))

        +a(1)*d(1)*der(1)*der(2)


% we make additional assumption that our Poisson tensor vira should be O(2)
% invariant under the change of susy derivatives;

dad:=odwa(vira)-vira;


dad := fer(f,2,0)*(

          -2*der(2)*a(7)

          +der(2)*a(5)

          -2*der(2)*a(3)

          -2*der(1)*a(8)

          -2*der(1)*a(2))

       +fer(f,1,0)*(

          -2*der(2)*a(8)

          -2*der(2)*a(2)

          +2*der(1)*a(7)

          -der(1)*a(5)

          +2*der(1)*a(3))

factor der;


wyr1:=sub(der(1)=1,der(2)=1,lyst1(dad));


wyr1 := {

         -2*a(7)

         +a(5)

         -2*a(3),


         -2*(a(8)

             +a(2)),


         -2*(a(8)

             +a(2)),

         2*a(7)

         -a(5)

         +2*a(3)}

remfac der;


*** der not found 

dad:=groesolve(wyr1);


dad := {{a(8)=

              -a(2),a(7)=(a(5)

            -2*a(3))/2}}

vira:=sub(dad,vira);


vira := (2*a(2)*bos(f,3,0)

         +2*a(3)*bos(f,0,1)

         +2*a(5)*(bos(f,0,0)*d(1))

         +fer(f,2,0)*(der(2)*a(5)

            -2*der(2)*a(3)

            -2*der(1)*a(2))

         +fer(f,1,0)*(2*der(2)*a(2)

            +der(1)*a(5)

            -2*der(1)*a(3))

         +2*a(1)*(d(1)*der(1)*der(2)))/2

% we check wheather it is really O(2) invariant;
vira-odwa(vira);


0

% O.K
%so
%now we check the Jacobi identity

jjacob:=fjacob(vira,f);


jjacob := (4*a(3)*a(1)*(bos(#c,3,2)*bos(#b,0,0)*bos(#a,0,0))

           +4*a(5)*a(1)*(bos(#c,3,1)*bos(#b,0,1)*bos(#a,0,0))

           -4*a(2)*a(1)*bos(#c,0,3)*bos(#b,0,0)*bos(#a,0,0)

           +4*a(5)*a(1)*(bos(#c,0,1)*bos(#b,0,0)*bos(#a,3,1))

           +4*a(3)*a(1)*(bos(#c,0,0)*bos(#b,3,2)*bos(#a,0,0))

           +4*a(5)*a(1)*(bos(#c,0,0)*bos(#b,3,1)*bos(#a,0,1))

           -4*a(2)*a(1)*bos(#c,0,0)*bos(#b,0,3)*bos(#a,0,0)

           +4*a(3)*a(1)*(bos(#c,0,0)*bos(#b,0,0)*bos(#a,3,2))

           -4*a(2)*a(1)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,3)

           +24*a(3)*a(2)*(bos(f,3,1)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,0))

                  2
           -4*a(2) *bos(f,3,0)*bos(#c,3,0)*bos(#b,0,0)*bos(#a,0,0)

           +4*bos(f,3,0)*bos(#c,0,1)*bos(#b,0,0)*bos(#a,0,0)*a(2)*(a(5)

              +3*a(3))

                  2
           -4*a(2) *bos(f,3,0)*bos(#c,0,0)*bos(#b,3,0)*bos(#a,0,0)

           +4*bos(f,3,0)*bos(#c,0,0)*bos(#b,0,1)*bos(#a,0,0)*a(2)*(a(5)

              +3*a(3))

                  2
           -4*a(2) *bos(f,3,0)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,3,0)

           +4*bos(f,3,0)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,1)*a(2)*(a(5)

              +3*a(3))

                                                                   2
           +12*bos(f,0,2)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,0)*(a(3)

                   2
              -a(2) )

           +4*bos(f,0,1)*bos(#c,3,0)*bos(#b,0,0)*bos(#a,0,0)*a(2)*(a(5)

              -a(3))

           +4*bos(f,0,1)*bos(#c,0,1)*bos(#b,0,0)*bos(#a,0,0)*(2*a(5)*a(3)

                   2
              +a(3)

                     2
              -2*a(2) )

           +4*bos(f,0,1)*bos(#c,0,0)*bos(#b,3,0)*bos(#a,0,0)*a(2)*(a(5)

              -a(3))

           +4*bos(f,0,1)*bos(#c,0,0)*bos(#b,0,1)*bos(#a,0,0)*(2*a(5)*a(3)

                   2
              +a(3)

                     2
              -2*a(2) )

           +4*bos(f,0,1)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,3,0)*a(2)*(a(5)

              -a(3))

           +4*bos(f,0,1)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,1)*(2*a(5)*a(3)

                   2
              +a(3)

                     2
              -2*a(2) )

           +4*a(5)*a(2)*(bos(f,0,0)*bos(#c,3,1)*bos(#b,0,0)*bos(#a,0,0))

           +4*a(5)*a(3)*(bos(f,0,0)*bos(#c,0,2)*bos(#b,0,0)*bos(#a,0,0))

                  2
           +4*a(5) *(bos(f,0,0)*bos(#c,0,1)*bos(#b,0,1)*bos(#a,0,0))

                  2
           +4*a(5) *(bos(f,0,0)*bos(#c,0,1)*bos(#b,0,0)*bos(#a,0,1))

           +4*a(5)*a(2)*(bos(f,0,0)*bos(#c,0,0)*bos(#b,3,1)*bos(#a,0,0))

           +4*a(5)*a(3)*(bos(f,0,0)*bos(#c,0,0)*bos(#b,0,2)*bos(#a,0,0))

                  2
           +4*a(5) *(bos(f,0,0)*bos(#c,0,0)*bos(#b,0,1)*bos(#a,0,1))

           +4*a(5)*a(2)*(bos(f,0,0)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,3,1))

           +4*a(5)*a(3)*(bos(f,0,0)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,2))

           +4*a(2)*a(1)*(fer(#b,2,2)*fer(#a,2,0)*bos(#c,0,0))

           +2*fer(#b,2,2)*fer(#a,1,0)*bos(#c,0,0)*a(1)*(a(5)

              -2*a(3))

           +2*fer(#b,2,1)*fer(#a,2,0)*bos(f,0,0)*bos(#c,0,0)*a(5)*(a(5)

              -2*a(3))

           -4*a(5)*a(2)*fer(#b,2,1)*fer(#a,1,0)*bos(f,0,0)*bos(#c,0,0)

           +2*fer(#b,2,0)*fer(#a,2,0)*bos(f,3,0)*bos(#c,0,0)*a(2)*(a(5)

              -2*a(3))

                                                                2
           +fer(#b,2,0)*fer(#a,2,0)*bos(f,0,1)*bos(#c,0,0)*(a(5)

              -2*a(5)*a(3)

                     2
              +4*a(2) )

                                                                2
           +fer(#b,2,0)*fer(#a,1,0)*bos(f,3,0)*bos(#c,0,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3) )

           -4*a(3)*a(2)*fer(#b,2,0)*fer(#a,1,0)*bos(f,0,1)*bos(#c,0,0)

           +2*fer(#b,1,2)*fer(#a,2,0)*bos(#c,0,0)*a(1)*(

              -a(5)

              +2*a(3))

           +4*a(2)*a(1)*(fer(#b,1,2)*fer(#a,1,0)*bos(#c,0,0))

           +4*a(5)*a(2)*(fer(#b,1,1)*fer(#a,2,0)*bos(f,0,0)*bos(#c,0,0))

           +2*fer(#b,1,1)*fer(#a,1,0)*bos(f,0,0)*bos(#c,0,0)*a(5)*(a(5)

              -2*a(3))

           +fer(#b,1,0)*fer(#a,2,0)*bos(f,3,0)*bos(#c,0,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3) )

           +4*a(3)*a(2)*(fer(#b,1,0)*fer(#a,2,0)*bos(f,0,1)*bos(#c,0,0))

           +2*fer(#b,1,0)*fer(#a,1,0)*bos(f,3,0)*bos(#c,0,0)*a(2)*(a(5)

              -2*a(3))

                                                                2
           +fer(#b,1,0)*fer(#a,1,0)*bos(f,0,1)*bos(#c,0,0)*(a(5)

              -2*a(5)*a(3)

                     2
              +4*a(2) )

           +4*a(2)*a(1)*(fer(#c,2,2)*fer(#b,2,0)*bos(#a,0,0))

           +2*fer(#c,2,2)*fer(#b,1,0)*bos(#a,0,0)*a(1)*(a(5)

              -2*a(3))

           +2*fer(#c,2,1)*fer(#b,2,0)*bos(f,0,0)*bos(#a,0,0)*a(5)*(a(5)

              -2*a(3))

           -4*a(5)*a(2)*fer(#c,2,1)*fer(#b,1,0)*bos(f,0,0)*bos(#a,0,0)

           -4*a(2)*a(1)*fer(#c,2,0)*fer(#a,2,2)*bos(#b,0,0)

           +2*fer(#c,2,0)*fer(#a,2,1)*bos(f,0,0)*bos(#b,0,0)*a(5)*(

              -a(5)

              +2*a(3))

           +2*fer(#c,2,0)*fer(#a,2,0)*bos(f,3,0)*bos(#b,0,0)*a(2)*(

              -a(5)

              +2*a(3))

           +fer(#c,2,0)*fer(#a,2,0)*bos(f,0,1)*bos(#b,0,0)*(

                   2
              -a(5)

              +2*a(5)*a(3)

                     2
              -4*a(2) )

           +2*fer(#c,2,0)*fer(#a,1,2)*bos(#b,0,0)*a(1)*(a(5)

              -2*a(3))

           -4*a(5)*a(2)*fer(#c,2,0)*fer(#a,1,1)*bos(f,0,0)*bos(#b,0,0)

                                                                2
           +fer(#c,2,0)*fer(#a,1,0)*bos(f,3,0)*bos(#b,0,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3) )

           -4*a(3)*a(2)*fer(#c,2,0)*fer(#a,1,0)*bos(f,0,1)*bos(#b,0,0)

           +2*fer(#c,2,0)*fer(#b,2,0)*bos(f,3,0)*bos(#a,0,0)*a(2)*(a(5)

              -2*a(3))

                                                                2
           +fer(#c,2,0)*fer(#b,2,0)*bos(f,0,1)*bos(#a,0,0)*(a(5)

              -2*a(5)*a(3)

                     2
              +4*a(2) )

                                                                2
           +fer(#c,2,0)*fer(#b,1,0)*bos(f,3,0)*bos(#a,0,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3) )

           -4*a(3)*a(2)*fer(#c,2,0)*fer(#b,1,0)*bos(f,0,1)*bos(#a,0,0)

           +2*fer(#c,1,2)*fer(#b,2,0)*bos(#a,0,0)*a(1)*(

              -a(5)

              +2*a(3))

           +4*a(2)*a(1)*(fer(#c,1,2)*fer(#b,1,0)*bos(#a,0,0))

           +4*a(5)*a(2)*(fer(#c,1,1)*fer(#b,2,0)*bos(f,0,0)*bos(#a,0,0))

           +2*fer(#c,1,1)*fer(#b,1,0)*bos(f,0,0)*bos(#a,0,0)*a(5)*(a(5)

              -2*a(3))

           +2*fer(#c,1,0)*fer(#a,2,2)*bos(#b,0,0)*a(1)*(

              -a(5)

              +2*a(3))

           +4*a(5)*a(2)*(fer(#c,1,0)*fer(#a,2,1)*bos(f,0,0)*bos(#b,0,0))

           +fer(#c,1,0)*fer(#a,2,0)*bos(f,3,0)*bos(#b,0,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3) )

           +4*a(3)*a(2)*(fer(#c,1,0)*fer(#a,2,0)*bos(f,0,1)*bos(#b,0,0))

           -4*a(2)*a(1)*fer(#c,1,0)*fer(#a,1,2)*bos(#b,0,0)

           +2*fer(#c,1,0)*fer(#a,1,1)*bos(f,0,0)*bos(#b,0,0)*a(5)*(

              -a(5)

              +2*a(3))

           +2*fer(#c,1,0)*fer(#a,1,0)*bos(f,3,0)*bos(#b,0,0)*a(2)*(

              -a(5)

              +2*a(3))

           +fer(#c,1,0)*fer(#a,1,0)*bos(f,0,1)*bos(#b,0,0)*(

                   2
              -a(5)

              +2*a(5)*a(3)

                     2
              -4*a(2) )

           +fer(#c,1,0)*fer(#b,2,0)*bos(f,3,0)*bos(#a,0,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3) )

           +4*a(3)*a(2)*(fer(#c,1,0)*fer(#b,2,0)*bos(f,0,1)*bos(#a,0,0))

           +2*fer(#c,1,0)*fer(#b,1,0)*bos(f,3,0)*bos(#a,0,0)*a(2)*(a(5)

              -2*a(3))

                                                                2
           +fer(#c,1,0)*fer(#b,1,0)*bos(f,0,1)*bos(#a,0,0)*(a(5)

              -2*a(5)*a(3)

                     2
              +4*a(2) )

           +4*fer(f,2,1)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           -12*a(3)*a(2)*fer(f,2,1)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,0)

           +4*fer(f,2,1)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           -12*a(3)*a(2)*fer(f,2,1)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,0)

           +4*fer(f,2,1)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           -12*a(3)*a(2)*fer(f,2,1)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,0)

           +2*fer(f,2,0)*fer(#a,2,1)*bos(#c,0,0)*bos(#b,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +2*fer(f,2,0)*fer(#a,2,0)*bos(#c,0,1)*bos(#b,0,0)*a(5)*(a(5)

              -2*a(3))

           +4*fer(f,2,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,3,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,2,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,1)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           +2*fer(f,2,0)*fer(#a,1,1)*bos(#c,0,0)*bos(#b,0,0)*a(2)*(

              -a(5)

              -4*a(3))

           -4*a(5)*a(2)*fer(f,2,0)*fer(#a,1,0)*bos(#c,0,1)*bos(#b,0,0)

           +fer(f,2,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,3,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           -8*a(3)*a(2)*fer(f,2,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,1)

           +2*fer(f,2,0)*fer(#b,2,1)*bos(#c,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +4*fer(f,2,0)*fer(#b,2,0)*bos(#c,3,0)*bos(#a,0,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,2,0)*fer(#b,2,0)*bos(#c,0,1)*bos(#a,0,0)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           +2*fer(f,2,0)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,1)*a(5)*(a(5)

              -2*a(3))

           +2*fer(f,2,0)*fer(#b,1,1)*bos(#c,0,0)*bos(#a,0,0)*a(2)*(

              -a(5)

              -4*a(3))

           +fer(f,2,0)*fer(#b,1,0)*bos(#c,3,0)*bos(#a,0,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           -8*a(3)*a(2)*fer(f,2,0)*fer(#b,1,0)*bos(#c,0,1)*bos(#a,0,0)

           -4*a(5)*a(2)*fer(f,2,0)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,1)

           +2*fer(f,2,0)*fer(#c,2,1)*bos(#b,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +2*fer(f,2,0)*fer(#c,2,0)*bos(#b,0,1)*bos(#a,0,0)*a(5)*(a(5)

              -2*a(3))

           +4*fer(f,2,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,3,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,2,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,1)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           +2*fer(f,2,0)*fer(#c,1,1)*bos(#b,0,0)*bos(#a,0,0)*a(2)*(

              -a(5)

              -4*a(3))

           -4*a(5)*a(2)*fer(f,2,0)*fer(#c,1,0)*bos(#b,0,1)*bos(#a,0,0)

           +fer(f,2,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,3,0)*(

                   2
              -a(5)

              +4*a(5)*a(3)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           -8*a(3)*a(2)*fer(f,2,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,1)

           +12*a(3)*a(2)*(fer(f,1,1)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,0))

           +4*fer(f,1,1)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           +12*a(3)*a(2)*(fer(f,1,1)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,0))

           +4*fer(f,1,1)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           +12*a(3)*a(2)*(fer(f,1,1)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,0))

           +4*fer(f,1,1)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                   2
              +a(2) )

           +2*fer(f,1,0)*fer(#a,2,1)*bos(#c,0,0)*bos(#b,0,0)*a(2)*(a(5)

              +4*a(3))

           +4*a(5)*a(2)*(fer(f,1,0)*fer(#a,2,0)*bos(#c,0,1)*bos(#b,0,0))

                                                                2
           +fer(f,1,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,3,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3)

                     2
              -4*a(2) )

           +8*a(3)*a(2)*(fer(f,1,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,1))

           +2*fer(f,1,0)*fer(#a,1,1)*bos(#c,0,0)*bos(#b,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +2*fer(f,1,0)*fer(#a,1,0)*bos(#c,0,1)*bos(#b,0,0)*a(5)*(a(5)

              -2*a(3))

           +4*fer(f,1,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,3,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,1,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,1)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           +2*fer(f,1,0)*fer(#b,2,1)*bos(#c,0,0)*bos(#a,0,0)*a(2)*(a(5)

              +4*a(3))

                                                                2
           +fer(f,1,0)*fer(#b,2,0)*bos(#c,3,0)*bos(#a,0,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3)

                     2
              -4*a(2) )

           +8*a(3)*a(2)*(fer(f,1,0)*fer(#b,2,0)*bos(#c,0,1)*bos(#a,0,0))

           +4*a(5)*a(2)*(fer(f,1,0)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,1))

           +2*fer(f,1,0)*fer(#b,1,1)*bos(#c,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +4*fer(f,1,0)*fer(#b,1,0)*bos(#c,3,0)*bos(#a,0,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,1,0)*fer(#b,1,0)*bos(#c,0,1)*bos(#a,0,0)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) )

           +2*fer(f,1,0)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,1)*a(5)*(a(5)

              -2*a(3))

           +2*fer(f,1,0)*fer(#c,2,1)*bos(#b,0,0)*bos(#a,0,0)*a(2)*(a(5)

              +4*a(3))

           +4*a(5)*a(2)*(fer(f,1,0)*fer(#c,2,0)*bos(#b,0,1)*bos(#a,0,0))

                                                                2
           +fer(f,1,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,3,0)*(a(5)

              -4*a(5)*a(3)

                     2
              +4*a(3)

                     2
              -4*a(2) )

           +8*a(3)*a(2)*(fer(f,1,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,1))

           +2*fer(f,1,0)*fer(#c,1,1)*bos(#b,0,0)*bos(#a,0,0)*(a(5)*a(3)

                     2
              -2*a(3)

                     2
              +2*a(2) )

           +2*fer(f,1,0)*fer(#c,1,0)*bos(#b,0,1)*bos(#a,0,0)*a(5)*(a(5)

              -2*a(3))

           +4*fer(f,1,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,3,0)*a(2)*(

              -a(5)

              +2*a(3))

                                                                2
           +fer(f,1,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,1)*(a(5)

                     2
              -4*a(3)

                     2
              +4*a(2) ))/4


% we now check jjacob on the susy-divergence behaviour w.r. to the test
% superfunction !#a;

az:=war(jjacob,!#a);


az := {2*a(1)*(a(5)

               -a(3)),

       a(1)*(a(5)

             -a(3)),


       -2*a(2)*a(1),

       a(1)*(

             -a(5)

             +a(3)),


       -a(2)*a(1),

       2*a(1)*(

               -a(5)

               +a(3)),

       a(2)*a(1),

       2*a(2)*a(1),

       a(2)*(

             -a(5)

             +2*a(3)),

       a(2)*(a(5)

             -2*a(3)),

       a(5)*a(2),


              2
       -2*a(2) ,


       -a(5)*a(2),

             2
       2*a(2) ,

       2*a(5)*a(2),

       a(5)*a(2),


       -a(5)*a(2),


       -2*a(5)*a(2),

       2*a(2)*a(1),

       a(1)*(a(5)

             -a(3)),

       2*a(2)*a(1),


       -a(5)*a(2),

       2*a(2)*a(1),

       (a(2)*(a(5)

              -2*a(3)))/2,

            2
       (a(5)

        -3*a(5)*a(3)

               2
        +2*a(3)

               2
        +4*a(2) )/2,

       a(1)*(

             -a(5)

             +a(3)),

       a(5)*a(2),

       a(1)*(

             -a(5)

             +a(3)),

       2*a(2)*a(1),

       a(5)*a(2),

       2*a(2)*a(1),

       a(1)*(a(5)

             -a(3)),


       -a(5)*a(2),

       2*a(2)*a(1),

       (a(2)*(a(5)

              -2*a(3)))/2,

            2
       (a(5)

        -3*a(5)*a(3)

               2
        +2*a(3)

               2
        +4*a(2) )/2,

           2
       a(2) ,

       a(2)*(a(5)

             -a(3)),


            2
       -a(2) ,

       a(2)*(

             -a(5)

             +a(3)),

       (

             2
        -a(5)

        +3*a(5)*a(3)

               2
        -2*a(3)

               2
        +2*a(2) )/2,

       a(5)*a(2),

       (a(2)*(3*a(5)

              -4*a(3)))/2,

            2
       (a(5)

        -3*a(5)*a(3)

               2
        +2*a(3)

               2
        -2*a(2) )/2,


       -a(5)*a(2),

       (a(2)*(

              -3*a(5)

              +4*a(3)))/2,

       a(2)*(

             -a(5)

             +a(3)),

           2
       a(2) ,

       a(2)*(a(5)

             -a(3)),


            2
       -a(2) ,


       -a(5)*a(2),

       (a(2)*(

              -3*a(5)

              +4*a(3)))/2,

       (

             2
        -a(5)

        +3*a(5)*a(3)

               2
        -2*a(3)

               2
        +2*a(2) )/2,

       a(5)*a(2),

       (a(2)*(3*a(5)

              -4*a(3)))/2,

            2
       (a(5)

        -3*a(5)*a(3)

               2
        +2*a(3)

               2
        -2*a(2) )/2}

as:=groesolve(az);


as := {{a(1)=0,a(3)=a(5)/2,a(2)=0},

       {a(3)=a(5),a(2)=0,a(1)=arbcomplex(2)}}

array ew(3);



for k:=1:2 do ew(k):=part(as,k);



% as we see we have two different solutions
% first give us classical realizations of the Virasoro algebra
% (without the center term)  which is

sub(ew(1),vira);


(a(5)*bos(f,0,1)

 +2*a(5)*(bos(f,0,0)*d(1)))/2



% the second solution give us desired susy generalizations of
% Virasoro algebra

sub(ew(2),vira);


(2*a(5)*bos(f,0,1)

 +2*a(5)*(bos(f,0,0)*d(1))

 -a(5)*fer(f,2,0)*der(2)

 -a(5)*fer(f,1,0)*der(1)

 +2*arbcomplex(2)*(d(1)*der(1)*der(2)))/2


% the coefficient "a" could be absorbed by redefinations of
% bos(f,0,0)
% we check that previous result satisfies the antisymmetric requirements

ws + cp(ws);


*** d not found 

*** der not found 

*** del not found 

0


clearrules trad;


let chiral1 ;



% We check that for chiral1 realization the following operator
vira:=der(3)*d(1)+bos(j,0,1)+bos(j,0,0)*d(1)+
        fer(j,1,0)*der(2)+fer(j,2,0)*der(1);


vira := bos(j,0,1)

        +bos(j,0,0)*d(1)

        +fer(j,2,0)*der(1)

        +fer(j,1,0)*der(2)

        +d(1)*der(3)

% satisfy the Jacobi identity;
jjacob:=fjacob(vira,j);


jjacob := (2*bos(#c,3,2)*bos(#b,0,0)*bos(#a,0,0)

           +2*bos(#c,3,1)*bos(#b,0,1)*bos(#a,0,0)

           +2*bos(#c,0,1)*bos(#b,0,0)*bos(#a,3,1)

           +2*bos(#c,0,0)*bos(#b,3,2)*bos(#a,0,0)

           +2*bos(#c,0,0)*bos(#b,3,1)*bos(#a,0,1)

           +2*bos(#c,0,0)*bos(#b,0,0)*bos(#a,3,2)

           +6*bos(j,0,2)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,0)

           +6*bos(j,0,1)*bos(#c,0,1)*bos(#b,0,0)*bos(#a,0,0)

           +6*bos(j,0,1)*bos(#c,0,0)*bos(#b,0,1)*bos(#a,0,0)

           +6*bos(j,0,1)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,1)

           +2*bos(j,0,0)*bos(#c,0,2)*bos(#b,0,0)*bos(#a,0,0)

           +2*bos(j,0,0)*bos(#c,0,1)*bos(#b,0,1)*bos(#a,0,0)

           +2*bos(j,0,0)*bos(#c,0,1)*bos(#b,0,0)*bos(#a,0,1)

           +2*bos(j,0,0)*bos(#c,0,0)*bos(#b,0,2)*bos(#a,0,0)

           +2*bos(j,0,0)*bos(#c,0,0)*bos(#b,0,1)*bos(#a,0,1)

           +2*bos(j,0,0)*bos(#c,0,0)*bos(#b,0,0)*bos(#a,0,2)

           -2*fer(#b,2,2)*fer(#a,1,0)*bos(#c,0,0)

           +2*fer(#b,2,1)*fer(#a,1,0)*bos(j,0,0)*bos(#c,0,0)

           -fer(#b,2,0)*fer(#a,1,0)*bos(j,3,0)*bos(#c,0,0)

           +fer(#b,2,0)*fer(#a,1,0)*bos(j,0,1)*bos(#c,0,0)

           +2*fer(#b,1,2)*fer(#a,2,0)*bos(#c,0,0)

           +2*fer(#b,1,1)*fer(#a,2,0)*bos(j,0,0)*bos(#c,0,0)

           +fer(#b,1,0)*fer(#a,2,0)*bos(j,3,0)*bos(#c,0,0)

           +fer(#b,1,0)*fer(#a,2,0)*bos(j,0,1)*bos(#c,0,0)

           -2*fer(#c,2,2)*fer(#b,1,0)*bos(#a,0,0)

           +2*fer(#c,2,1)*fer(#b,1,0)*bos(j,0,0)*bos(#a,0,0)

           -2*fer(#c,2,0)*fer(#a,1,2)*bos(#b,0,0)

           -2*fer(#c,2,0)*fer(#a,1,1)*bos(j,0,0)*bos(#b,0,0)

           -fer(#c,2,0)*fer(#a,1,0)*bos(j,3,0)*bos(#b,0,0)

           -fer(#c,2,0)*fer(#a,1,0)*bos(j,0,1)*bos(#b,0,0)

           -fer(#c,2,0)*fer(#b,1,0)*bos(j,3,0)*bos(#a,0,0)

           +fer(#c,2,0)*fer(#b,1,0)*bos(j,0,1)*bos(#a,0,0)

           +2*fer(#c,1,2)*fer(#b,2,0)*bos(#a,0,0)

           +2*fer(#c,1,1)*fer(#b,2,0)*bos(j,0,0)*bos(#a,0,0)

           +2*fer(#c,1,0)*fer(#a,2,2)*bos(#b,0,0)

           -2*fer(#c,1,0)*fer(#a,2,1)*bos(j,0,0)*bos(#b,0,0)

           +fer(#c,1,0)*fer(#a,2,0)*bos(j,3,0)*bos(#b,0,0)

           -fer(#c,1,0)*fer(#a,2,0)*bos(j,0,1)*bos(#b,0,0)

           +fer(#c,1,0)*fer(#b,2,0)*bos(j,3,0)*bos(#a,0,0)

           +fer(#c,1,0)*fer(#b,2,0)*bos(j,0,1)*bos(#a,0,0)

           +4*fer(j,2,1)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,0)

           +4*fer(j,2,1)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,0)

           +4*fer(j,2,1)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,0)

           +2*fer(j,2,0)*fer(#a,1,1)*bos(#c,0,0)*bos(#b,0,0)

           +2*fer(j,2,0)*fer(#a,1,0)*bos(#c,0,1)*bos(#b,0,0)

           +fer(j,2,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,3,0)

           +3*fer(j,2,0)*fer(#a,1,0)*bos(#c,0,0)*bos(#b,0,1)

           +2*fer(j,2,0)*fer(#b,1,1)*bos(#c,0,0)*bos(#a,0,0)

           +fer(j,2,0)*fer(#b,1,0)*bos(#c,3,0)*bos(#a,0,0)

           +3*fer(j,2,0)*fer(#b,1,0)*bos(#c,0,1)*bos(#a,0,0)

           +2*fer(j,2,0)*fer(#b,1,0)*bos(#c,0,0)*bos(#a,0,1)

           +2*fer(j,2,0)*fer(#c,1,1)*bos(#b,0,0)*bos(#a,0,0)

           +2*fer(j,2,0)*fer(#c,1,0)*bos(#b,0,1)*bos(#a,0,0)

           +fer(j,2,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,3,0)

           +3*fer(j,2,0)*fer(#c,1,0)*bos(#b,0,0)*bos(#a,0,1)

           +4*fer(j,1,1)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,0)

           +4*fer(j,1,1)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,0)

           +4*fer(j,1,1)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,0)

           +2*fer(j,1,0)*fer(#a,2,1)*bos(#c,0,0)*bos(#b,0,0)

           +2*fer(j,1,0)*fer(#a,2,0)*bos(#c,0,1)*bos(#b,0,0)

           -fer(j,1,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,3,0)

           +3*fer(j,1,0)*fer(#a,2,0)*bos(#c,0,0)*bos(#b,0,1)

           +2*fer(j,1,0)*fer(#b,2,1)*bos(#c,0,0)*bos(#a,0,0)

           -fer(j,1,0)*fer(#b,2,0)*bos(#c,3,0)*bos(#a,0,0)

           +3*fer(j,1,0)*fer(#b,2,0)*bos(#c,0,1)*bos(#a,0,0)

           +2*fer(j,1,0)*fer(#b,2,0)*bos(#c,0,0)*bos(#a,0,1)

           +2*fer(j,1,0)*fer(#c,2,1)*bos(#b,0,0)*bos(#a,0,0)

           +2*fer(j,1,0)*fer(#c,2,0)*bos(#b,0,1)*bos(#a,0,0)

           -fer(j,1,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,3,0)

           +3*fer(j,1,0)*fer(#c,2,0)*bos(#b,0,0)*bos(#a,0,1))/2


az:=war(jjacob,!#a);


az := 0


%24 superintegration
clearrules chiral1;


let trad;




as:=s_int(0,bos(f,3,0)^2-bos(f,0,1)^2,{f});


as := 

      -bos(f,0,1)*bos(f,0,0)

                       2
      +d(-3)*bos(f,3,0)

      +d(-3)*bos(f,0,2)*bos(f,0,0)

as1:=sub(d(-3)=0,ws);


as1 := 

       -bos(f,0,1)*bos(f,0,0)

as2:=sub(d(-3)=1,as-as1);


                 2
as2 := bos(f,3,0)

       +bos(f,0,2)*bos(f,0,0)

as3:=s_int(1,as2,{f});


as3 := fer(f,2,0)*bos(f,3,0)

       +del(-1)*bos(f,0,2)*bos(f,0,0)

       -del(-1)*fer(f,2,1)*fer(f,2,0)

as4:=sub(del(-1)=0,ws);


as4 := fer(f,2,0)*bos(f,3,0)

as4:=sub(del(-1)=1,as3-as4);


as4 := bos(f,0,2)*bos(f,0,0)

       -fer(f,2,1)*fer(f,2,0)

as5:=s_int(2,as4,{f});


as5 := fer(f,2,1)*bos(f,0,0)


end;


Time for test: 15164 ms, plus GC time: 405 ms
@@@@@ Resources used: (15 82 258 1)
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/0000755000175000017500000000000011722677365021775 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/ludecom.red0000644000175000017500000003770711526203062024114 0ustar  giovannigiovannimodule ludecom;

%**********************************************************************%
%                                                                      %
% Computation of the LU decomposition of dense unsymmetric matrices    %
% containing either numeric entries or complex numbers with numeric    %
% coefficients.                                                        %
%                                                                      %
% Author: Matt Rebbeck, June 1994.                                     %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%                                                                      %
% NB: By using the same rounded number techniques as used in svd this  %
%     could be made a lot faster.                                      %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




%%%%%%%%%%%%%%%%%%%%%%%%%%% begin get_num_part %%%%%%%%%%%%%%%%%%%%%%%%%
%                                                                      %
% This bit of code is used in lu_decom, cholesky, and svd.             %
%                                                                      %

symbolic procedure get_num_part f;
  %
  % When comparing (ie: a < b) we need to get hold of the actual
  % numerical values. That's what this does.
  %
  % Nicked from H. Melenk's gnuplot code.
  %
  if f = 0 then f
   else if numberp f then float f
%   else if f='pi then 3.141592653589793238462643
%   else if f='e then 2.7182818284590452353602987
   else if atom f then f
   else if eqcar(f, '!:RD!:) then
          if atom cdr f then cdr f else bf2flr f
   else if eqcar(f, '!:DN!:) then rdwrap2 cdr f
   else if eqcar(f, 'MINUS) then
    begin scalar x;
       x := get_num_part cadr f;
       return if numberp x then minus float x else {'MINUS,x}
    end
   else if eqcar(f,'expt) then rdwrap!-expt f
   else get_num_part car f . get_num_part cdr f;



symbolic procedure rdwrap!-expt f;
% preserve integer second argument.
  if fixp caddr f then {'expt!-int,get_num_part cadr f,caddr f}
   else  {'expt,get_num_part cadr f, get_num_part caddr f};



symbolic procedure rdwrap2 f;
% Convert from domain to LISP evaluable value.
  if atom f then f else float car f * 10^cdr f;



symbolic procedure rdwrap!* f;
% convert a domain element to float.
  if null f then 0.0 else get_num_part f;



symbolic procedure expt!-int(a,b); expt(a,fix b);

%                                                                      %
%                                                                      %
%                                                                      %
%%%%%%%%%%%%%%%%%%%%%%%%%%% end get_num_part %%%%%%%%%%%%%%%%%%%%%%%%%%%



symbolic procedure lu_decom(in_mat);
  %
  % Runs the show!
  %
  begin
    scalar ans,I_turned_rounded_on;
    integer sq_size;
    if not matrixp(in_mat) then
     rederr "Error in lu_decom: non matrix input.";
    if not squarep(in_mat) then
     rederr "Error in lu_decom: input matrix should be square.";
    if not !*rounded then << I_turned_rounded_on := t; on rounded; >>;
    sq_size := first size_of_matrix(in_mat);
    if cx_test(in_mat,sq_size) then ans := compdet(in_mat)
     else ans := unsymdet(in_mat);
    if I_turned_rounded_on then off rounded;
    return ans;
  end;

flag('(lu_decom),'opfn);  % So it can be used from algebraic mode.



symbolic procedure cx_test(in_mat,sq_size);
  %
  % Tests to see if any elts are complex. (boolean).
  %
  begin
    scalar bool,elt;
    integer i,j;
    i := 1;
    while not bool and i<=sq_size do
    <<
      j := 1;
      while not bool and j<=sq_size do
      <<
        elt := getmat(in_mat,i,j);
        if algebraic(impart(elt)) neq 0 then bool := t;
        j := j+1;
      >>;
      i := i+1;
    >>;
    return bool;
  end;

flag('(cx_test),'boolean);



symbolic procedure unsymdet(mat1);
  %
  % LU decomposition is performed on the unsymmetric matrix A.
  % ie: A := LU.
  % The determinant (d1*2^d2) of A is also computed as a by product but
  % has been commented out as it is not necessary. A record of any
  % interchanges made to the rows of A is kept in int_vec[i] (i=1...n)
  % such that the i'th row and the int_vec[i]'th row were interchanged
  % at the i'th step.The procedure will fail if A, modified by rounding
  % errors, is singular or singular within the bounds of the machine
  % accuracy (ie: acc s.t. 1+acc > 1).
  %
  begin
    scalar x,y,in_mat,tmp,int_vec,L,U; %d1,d2,det;
    integer i,j,k,l,n;
    j := 1;
    in_mat := copy_mat(mat1);
    n := first size_of_matrix(in_mat);
    int_vec := mkvect(n-1);
    for i:=1:n do
    <<
      y := innerprod(1,1,n,0,row_vec(in_mat,i,n),row_vec(in_mat,i,n));
      putv(int_vec,i-1,{'quotient,1,{'sqrt,y}});
    >>;
%   d1 := 1;
%   d2 := 0;
    for k:=1:n do
    <<
      l := k;
      x := 0;
      for i:=k:n do
      <<
        y := innerprod(1,1,k-1,{'minus,getmat(in_mat,i,k)},
                       row_vec(in_mat,i,n),col_vec(in_mat,k,n));
        setmat(in_mat,i,k,{'minus,y});
        y := abs(get_num_part(reval{'times,y,getv(int_vec,i-1)}));
        if y>get_num_part(my_reval(x)) then
        <<
          x := y;
          l := i;
        >>;
      >>;
      if l neq k then
      <<
%       d1 := {'minus,d1};
        for j:=1:n do
        <<
          y := getmat(in_mat,k,j);
          setmat(in_mat,k,j,getmat(in_mat,l,j));
          setmat(in_mat,l,j,y);
        >>;
        putv(int_vec,l-1,getv(int_vec,k-1));;
      >>;
      putv(int_vec,k-1,l);
%     d1 := {'times,d1,getmat(in_mat,k,k)};
      if get_num_part(my_reval(x)) <
          get_num_part(reval{'times,8,rd!-tolerance!*}) then rederr
"Error in lu_decom: matrix is singular. LU decomposition not possible.";
%    while abs(get_num_part(reval(d1))) >= 1 do
%    <<
%      d1 := {'times,d1,0.0625};
%      d2 := d2+4;
%    >>;
%   while abs(get_num_part(reval(d1))) < 0.0625 do
%      <<
%        d1 := {'times,d1,16};
%        d2 := d2-4;
%      >>;
      x := {'quotient,{'minus,1},getmat(in_mat,k,k)};
      for j:=k+1:n do
      <<
        y := innerprod(1,1,k-1,{'minus,getmat(in_mat,k,j)},
                       row_vec(in_mat,k,n),col_vec(in_mat,j,n));
        setmat(in_mat,k,j,{'times,x,y});
      >>;
    >>;
    tmp := get_l_and_u(in_mat,n);
    L := first tmp;
    U := second tmp;
    % Compute determinant.
    %det := {'times,d1,{'expt,2,d2}};
    return {'list,L,U,int_vec};
  end;



symbolic procedure innerprod(l,s,u,c1,vec_a,vec_b);
  %
  % This procedure accumulates the sum of products vec_a*vec_b and adds
  % it to the initial value c1.  (ie: the scalar product).
  %
  begin
    scalar s1,d1;
    s1 := c1;
    d1 := s1;
    for k:=l step s until u do
    <<
      s1 := {'plus,s1,{'times,getv(vec_a,k),getv(vec_b,k)}};
      d1 := s1;
    >>;
    return d1;
  end;



symbolic procedure row_vec(in_mat,row_no,length_of);
  %
  % Converts matrix row into vector.
  %
  begin
    scalar row_vec;
    integer i;
    row_vec := mkvect(length_of);
    for i:=1:length_of do putv(row_vec,i,getmat(in_mat,row_no,i));
    return row_vec;
  end;



symbolic procedure col_vec(in_mat,col_no,length_of);
  %
  % Converts matrix column into vector.
  %
  begin
    scalar col_vec;
    integer i;
    col_vec := mkvect(length_of);
    for i:=1:length_of do putv(col_vec,i,getmat(in_mat,i,col_no));
    return col_vec;
  end;



symbolic procedure get_l_and_u(in_mat,sq_size);
  %
  % Takes the combined LU matrix and returns L and U.
  % sq_size is the no of rows (and columns) of in_mat.
  %
  begin
    scalar L,U;
    integer i,j;
    L := mkmatrix(sq_size,sq_size);
    U := mkmatrix(sq_size,sq_size);
    for i:=1:sq_size do
    <<
      for j:=1:i do
      <<
        setmat(L,i,j,getmat(in_mat,i,j));
      >>;
    >>;
    for i:=1:sq_size do
    <<
      setmat(U,i,i,1);
      for j:=i+1:sq_size do
      <<
        setmat(U,i,j,getmat(in_mat,i,j));
      >>;
    >>;
    return {L,U};
  end;



symbolic procedure compdet(mat1);
  %
  % LU decomposition is performed on the complex unsymmetric matrix A.
  % ie: A := LU.
  %
  % The calculation is computed in the nX2n matrix so that the general
  % element is a[i,2j-1]+i*a[i,2j]. A record of any interchanges made
  % to the rows of A is kept in int_vec[i] (i=1...n) such that the i'th
  % row and the int_vec[i]'th row were interchanged at the i'th step.
  % The determinant (detr+i*deti)*2^dete of A is also computed but has
  % been comented out as it is not necessary. The procedure will fail
  % if A, modified by rounding errors, is singular.
  %
  begin
    scalar x,y,in_mat,tmp,int_vec,L,U,p,pp,v,w,z; %detr,deti,dete,det;
    integer i,j,k,l,n;
    if algebraic (det(mat1)) = 0 then rederr
"Error in lu_decom: matrix is singular. LU decomposition not possible.";
    j := 1;
    n := first size_of_matrix(mat1);
    in_mat := im_uncompress(mat1,n);
    int_vec := mkvect(n-1);
    for i:=1:n do
    <<
      putv(int_vec,i-1,innerprod(1,1,n+n,0,row_vec(in_mat,i,n+n),
                                          row_vec(in_mat,i,n+n)));
    >>;
%    detr := 1;
%    deti := 0;
%    dete := 0;
    for k:=1:n do
    <<
      l := k;
      p := k+k;
      pp := p-1;
      z := 0;
      for i:=k:n do
      <<
        tmp := cxinnerprod(1,1,k-1,getmat(in_mat,i,pp),
               getmat(in_mat,i,p),re_row_vec(in_mat,i,n),
               cx_row_vec(in_mat,i,n),col_vec(in_mat,pp,n),
               col_vec(in_mat,p,n));
        x := first tmp;
        y := second tmp;
        setmat(in_mat,i,pp,x);
        setmat(in_mat,i,p,y);
        x := {'quotient,{'plus,{'expt,x,2},{'expt,y,2}},
                   getv(int_vec,i-1)};
        if get_num_part(reval(x))>get_num_part(reval(z)) then
        <<
          z := x;
          l := i;
        >>;
      >>;
      if l neq k then
      <<
%        detr := {'minus,detr};
%        deti := {'minus,deti};
        for j:=n+n step -1 until 1 do
        <<
          z := getmat(in_mat,k,j);
          setmat(in_mat,k,j,getmat(in_mat,l,j));
          setmat(in_mat,l,j,z);
        >>;
        putv(int_vec,l-1,getv(int_vec,k-1));;
      >>;
      putv(int_vec,k-1,l);
      x := getmat(in_mat,k,pp);
      y := getmat(in_mat,k,p);
      z := {'plus,{'expt,x,2},{'expt,y,2}};
%      w := {'plus,{'times,x,detr},{'minus,{'times,y,deti}}};
%      deti := {'plus,{'times,x,deti},{'times,y,detr}};
%      detr :=  w;
%      if abs(get_num_part(reval(detr)))= 1 then
%      <<
%        w := {'times,w,0.0625};
%        detr := {'times,detr,0.0625};
%        deti := {'times,deti,0.0625};
%        dete := {'plus,dete,4};
%      >>;
%      while abs(get_num_part(reval(w))) < 0.0625 do
%      <<
%        w := {'times,w,16};
%        detr := {'times,detr,16};
%        deti := {'times,deti,16};
%        dete := {'plus,dete,-4};
%      >>;
      for j:=k+1:n do
      <<
        p := j+j;
        pp := p-1;
        tmp := cxinnerprod(1,1,k-1,getmat(in_mat,k,pp),
               getmat(in_mat,k,p),re_row_vec(in_mat,k,n),
               cx_row_vec(in_mat,k,n),col_vec(in_mat,pp,n),
               col_vec(in_mat,p,n));
        v := first tmp;
        w := second tmp;
        setmat(in_mat,k,pp,{'quotient,{'plus,{'times,v,x},
               {'times,w,y}},z});
        setmat(in_mat,k,p,{'quotient,{'plus,{'times,w,x},
               {'minus,{'times,v,y}}},z});
      >>;
    >>;
    in_mat := im_compress(in_mat,n);
    tmp := get_l_and_u(in_mat,n);
    L := first tmp;
    U := second tmp;
    % Compute determinant.
    %det := {'times,{'plus,detr,{'times,'i,deti}},{'expt,2,dete}};
    return {'list,L,U,int_vec};
  end;



symbolic procedure cxinnerprod(l,s,u,cr,ci,vec_ar,vec_ai,vec_br,vec_bi);
  %
  % Computes complex innerproduct.
  %
  begin
    scalar h,dr,di;
    h := innerprod(l,s,u,{'minus,cr},vec_ar,vec_br);
    dr := innerprod(l,s,u,{'minus,h},vec_ai,vec_bi);
    h := innerprod(l,s,u,{'minus,ci},vec_ai,vec_br);
    di := {'minus,innerprod(l,s,u,h,vec_ar,vec_bi)};
    return {dr,di};
  end;



symbolic procedure cx_row_vec(in_mat,row_no,length_of);
  %
  % Takes uncompressed matrix and creates a vector consisting of the
  % complex elements of row (row_no).
  %
  begin
    scalar cx_row_vec;
    integer i;
    cx_row_vec := mkvect(length_of);
    for i:=1:length_of do putv(cx_row_vec,i,getmat(in_mat,row_no,2*i));
    return cx_row_vec;
  end;



symbolic procedure re_row_vec(in_mat,row_no,length_of);
  %
  % Takes uncompressed matrix and creates a vector consisting of the
  % real elements of row (row_no).
  %
  begin
    scalar re_row_vec;
    integer i;
    re_row_vec := mkvect(length_of);
    for i:=1:length_of do
     putv(re_row_vec,i,getmat(in_mat,row_no,2*i-1));
    return re_row_vec;
  end;



symbolic procedure im_uncompress(in_mat,n);
  %
  % Takes square(nXn) matrix containing imaginary elements and creates
  % a new nX2n matrix s.t. in_mat(i,j) is cx_mat(i,2j-1)+i*cx_mat(i,2j).
  %
  begin
    scalar cx_mat,tmp;
    integer i,j;
    cx_mat := mkmatrix(n,2*n);
    for i:=1:n do
    <<
      for j:=1:n do
      <<
        tmp := getmat(in_mat,i,j);
        setmat(cx_mat,i,2*j-1,algebraic repart(tmp));
        tmp := getmat(in_mat,i,j);
        setmat(cx_mat,i,2*j,algebraic impart(tmp));
      >>;
    >>;
    return cx_mat;
  end;



symbolic procedure im_compress(cx_mat,n);
  %
  % Performs the opposite to im_uncompress.
  %
  begin
    scalar comp_mat;
    integer i,j;
    comp_mat := mkmatrix(n,n);
    for i:=1:n do
    <<
      for j:=1:n do
      <<
        setmat(comp_mat,i,j,{'plus,getmat(cx_mat,i,2*j-1),
               {'times,'i,getmat(cx_mat,i,2*j)}});
      >>;
    >>;
    return comp_mat;
  end;




symbolic procedure convert(in_mat,int_vec);
  %
  % The lu decomposition algorithm may swap some of the rows of A such
  % that L * U does not equal A but a row rearrangement of A. The
  % lu_decom returns as a third argument a vector that describes which
  % rows have been swapped.
  %
  % Given a matrix A, then
  %  convert(first lu_decom(A) * second lu_decom(A),third lu_decom(A))
  % will return A.
  %
  % convert(A,third lu_decom(A)) will give you L * U.
  %
  begin
    scalar new_mat;
    integer i;
    if not matrixp(in_mat) then
     rederr "Error in convert(first argument): should be a matrix.";
    new_mat := copy_mat(in_mat);
    for i:=1:upbv(int_vec)+1 do
    <<
      if getv(int_vec,i-1) neq i then
       new_mat := swap_rows(new_mat,i,getv(int_vec,i-1));
    >>;
    return new_mat;
  end;

flag('(convert),'opfn);


endmodule;  % lu_decom.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/svd.red0000644000175000017500000004162011526203062023245 0ustar  giovannigiovannimodule svd;

%**********************************************************************%
%                                                                      %
% Computation of the Singular Value Decomposition of dense matrices    %
% containing numeric entries. Uses specific rounded number routines to %
% speed things up.                                                     %
%                                                                      %
% Author: Matt Rebbeck, June 1994.                                     %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




symbolic smacro procedure my_minus(u);
  %
  % Efficiently performs reval({'minus,u}).
  %
  if atom u then {'minus,u}
   else if car u = 'minus then cadr u
    else {'minus,u};



symbolic procedure svd(A);
  %
  % Computation of the singular values and complete orthogonal
  % decomposition of a real rectangular matrix A.
  %
  %      A = tp(U) diag(q) V,   U tp(U) = V tp(V) = I,
  %
  % and q contains the singular values along the diagonal.
  % (tp => transpose).
  %
  % Algorithm taken from "Linear Algebra"
  %                      J.H.Wilkinson & C.Reinsch
  %
  begin
    scalar ee,U,V,g,x,eps,tolerance,q,s,f,h,y,test_f_splitting,
           cancellation,test_f_convergence,convergence,c,z,denom,q_mat,
           I_rounded_turned_on,trans_done;
    integer i,j,k,l,l1,m,n;
    trans_done := I_rounded_turned_on := nil;
    if not !*rounded then << on rounded; I_rounded_turned_on := t; >>;

    if not matrixp(A) then
     rederr "Error in svd: non matrix input.";

    % The value of eps can be decreased to increase accuracy.
    % As usual, doing this will slow things down (and vice versa).
    % It should not be made smaller than the value of rd!-tolerance!*.
    eps := get_num_part(my_reval({'times,1.5,{'expt,10,-8}}));
    tolerance := get_num_part(my_reval({'expt,10,-31}));

    % Algorithm requires m >= n. If this is not the case then transpose
    % the input and swap U and V in the output (as A = tp(U) diag(q) V
    % but tp(A) = tp(V) diag(q) U  ).
    if row_dim(A) < column_dim(A) then
    << A := algebraic tp(A); trans_done := t; >>;

    m := row_dim(A);
    n := column_dim(A);

    U := rd_copy_mat(A);
    V := mkmatrix(n,n);
    ee := mkvect(n);
    q := mkvect(n);

    % Householder's reduction to bidiagonal form:
    g := x := 0;
    for i:=1:n do
    <<
      putv(ee,i,g);
      s := 0;
      l := i+1;
      for j:=i:m do s := specrd!:plus(s,specrd!:expt(getmat(U,j,i),2));
      if get_num_part(s) < tolerance then g := 0
      else
      <<
        f := getmat(U,i,i);
        if get_num_part(f)<0 then g := specrd!:sqrt(s)
         else g := my_minus(specrd!:sqrt(s));
        h := specrd!:plus(specrd!:times(f,g),my_minus(s));
        setmat(U,i,i,specrd!:plus(f,my_minus(g)));
        for j:=l:n do
        <<
          s := 0;
          for k:=i:m do
           s := specrd!:plus(s,specrd!:times(getmat(U,k,i),
                                             getmat(U,k,j)));
          f := specrd!:quotient(s,h);
          for k:=i:m do
           setmat(U,k,j,specrd!:plus(getmat(U,k,j),
                        specrd!:times(f,getmat(U,k,i))));
        >>;
      >>;
      putv(q,i,g);
      s := 0;
      for j:=l:n do s := specrd!:plus(s,specrd!:expt(getmat(U,i,j),2));
      if get_num_part(s) < tolerance then g := 0
      else
      <<
        f := getmat(U,i,i+1);
        if get_num_part(f)<0 then g := specrd!:sqrt(s)
         else g := my_minus(specrd!:sqrt(s));
        h := specrd!:plus(specrd!:times(f,g),my_minus(s));
        setmat(U,i,i+1,specrd!:plus(f,my_minus(g)));
        for j:=l:n do putv(ee,j,specrd!:quotient(getmat(U,i,j),h));
        for j:=l:m do
        <<
          s := 0;
          for k:=l:n do
           s := specrd!:plus(s,specrd!:times(getmat(U,j,k),
                                             getmat(U,i,k)));
          for k:=l:n do
           setmat(U,j,k,specrd!:plus(getmat(U,j,k),
                        specrd!:times(s,getv(ee,k))));
        >>;
      >>;
      y := specrd!:plus(abs(get_num_part(getv(q,i))),
                        abs(get_num_part(getv(ee,i))));
      if get_num_part(y) > get_num_part(x) then x := y;
    >>;

    % Accumulation of right hand transformations:
    for i:=n step -1 until 1 do
    <<
      if get_num_part(g) neq 0 then
      <<
        h := specrd!:times(getmat(U,i,i+1),g);
        for j:=l:n do setmat(V,j,i,specrd!:quotient(getmat(U,i,j),h));
        for j:=l:n do
        <<
          s := 0;
          for k:=l:n do
           s := specrd!:plus(s,specrd!:times(getmat(U,i,k),
                                             getmat(V,k,j)));
          for k:=l:n do
           setmat(V,k,j,specrd!:plus(getmat(V,k,j),
                        specrd!:times(s,getmat(V,k,i))));
        >>;
      >>;
      for j:=l:n do << setmat(V,i,j,0); setmat(V,j,i,0); >>;
      setmat(V,i,i,1);
      g := getv(ee,i);
      l := i;
    >>;

    % Accumulation of left hand transformations:
    for i:=n step -1 until 1 do
    <<
      l := i+1;
      g := getv(q,i);
      for j:=l:n do setmat(U,i,j,0);
      if get_num_part(g) neq 0 then
      <<
        h := specrd!:times(getmat(U,i,i),g);
        for j:=l:n do
        <<
          s := 0;
          for k:=l:m do
           s := specrd!:plus(s,specrd!:times(getmat(U,k,i),
                                             getmat(U,k,j)));
          f := specrd!:quotient(s,h);
          for k:=i:m do
           setmat(U,k,j,specrd!:plus(getmat(U,k,j),
                        specrd!:times(f,getmat(U,k,i))));
        >>;
        for j:=i:m do setmat(U,j,i,specrd!:quotient(getmat(U,j,i),g));
      >>
      else for j:=i:m do setmat(U,j,i,0);
      setmat(U,i,i,specrd!:plus(getmat(U,i,i),1));
    >>;

    % Diagonalisation of the bidiagonal form:
    eps := get_num_part(specrd!:times(eps,x));
    test_f_splitting := t;
    k := n;
    while k>=1 do
    <<
      convergence := nil;
      if test_f_splitting then
      <<
        l := k;
        test_f_convergence := cancellation := nil;
        while l>=1 and not (test_f_convergence or cancellation) do
        <<
          if abs(get_num_part(getv(ee,l))) <= eps
           then test_f_convergence := t
          else if abs(get_num_part(getv(q,l-1))) <= eps
           then cancellation := t
          else l := l-1;
        >>;
      >>;

      % Cancellation of e[l] if l>1:
      if not test_f_convergence then
      <<
        c := 0; s := 1; l1 := l-1;
        i := l;
        while i<=k and not test_f_convergence do
        <<
          f := specrd!:times(s,getv(ee,i));
          putv(ee,i,specrd!:times(c,getv(ee,i)));
          if abs(get_num_part(f)) <= eps then
           test_f_convergence := t
          else
          <<
            g := getv(q,i);
            h := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),
                                           specrd!:times(g,g)));
            putv(q,i,h);
            c := specrd!:quotient(g,h);
            s := specrd!:quotient(my_minus(f),h);
            for j:=1:m do
            <<
              y := getmat(U,j,l1);
              z := getmat(U,j,i);
              setmat(U,j,l1,specrd!:plus(specrd!:times(y,c),
                                         specrd!:times(z,s)));
              setmat(U,j,i,specrd!:difference(specrd!:times(z,c),
                                              specrd!:times(y,s)));
            >>;
            i := i+1;
          >>;
        >>;
      >>;
      z := getv(q,k);
      if l = k then convergence := t;

      if not convergence then
      <<
        % Shift from bottom 2x2 minor:
        x := getv(q,l);
        y := getv(q,k-1);
        g := getv(ee,k-1);
        h := getv(ee,k);
        f := specrd!:quotient(specrd!:plus(specrd!:times(
              specrd!:plus(y,my_minus(z)),specrd!:plus(y,z)),
               specrd!:times(specrd!:plus(g,my_minus(h)),
                specrd!:plus(g,h))),specrd!:times(
                 specrd!:times(2,h),y));
        g := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),1));
        % Needed to change < here to <=.
        if get_num_part(f)<=0 then
        denom := specrd!:plus(f,my_minus(g))
         else denom := specrd!:plus(f,g);
        f := specrd!:quotient(specrd!:plus(specrd!:times(
              specrd!:plus(x,my_minus(z)),specrd!:plus(x,z)),
               specrd!:times(h,specrd!:quotient(y,
                specrd!:plus(denom,my_minus(h))))),x);

        % Next QR transformation:
        c := s := 1;
        for i:=l+1:k do
        <<
          g := getv(ee,i);
          y := getv(q,i);
          h := specrd!:times(s,g);
          g := specrd!:times(c,g);
          z := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),
                                         specrd!:times(h,h)));
          putv(ee,i-1,z);
          c := specrd!:quotient(f,z);
          s := specrd!:quotient(h,z);
          f := specrd!:plus(specrd!:times(x,c),specrd!:times(g,s));
          g := specrd!:plus(specrd!:times(my_minus(x),s),
                            specrd!:times(g,c));
          h := specrd!:times(y,s);
          y := specrd!:times(y,c);
          for j:=1:n do
          <<
            x := getmat(V,j,i-1);
            z := getmat(V,j,i);
            setmat(V,j,i-1,specrd!:plus(specrd!:times(x,c),
                                        specrd!:times(z,s)));
            setmat(V,j,i,specrd!:difference(specrd!:times(z,c),
                                            specrd!:times(x,s)));
          >>;
          z := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),
                                         specrd!:times(h,h)));
          putv(q,i-1,z);
          c := specrd!:quotient(f,z);
          s := specrd!:quotient(h,z);
          f := specrd!:plus(specrd!:times(c,g),specrd!:times(s,y));
          x := specrd!:plus(specrd!:times(my_minus(s),g),
                            specrd!:times(c,y));
          for j:=1:m do
          <<
                y := getmat(U,j,i-1);
                z := getmat(U,j,i);
            setmat(U,j,i-1,specrd!:plus(specrd!:times(y,c),
                                        specrd!:times(z,s)));
            setmat(U,j,i,specrd!:difference(specrd!:times(z,c),
                                            specrd!:times(y,s)));
          >>;
        >>;
        putv(ee,l,0);
        putv(ee,k,f);
        putv(q,k,x);
      >>
      else % convergence:
      <<
        if get_num_part(z)<0 then
        <<
          % q[k] is made non-negative:
          putv(q,k,my_minus(z));
          for j:=1:n do setmat(V,j,k,my_minus(getmat(V,j,k)));
        >>;
        k := k-1;
      >>;
    >>;

    q_mat := q_to_diag_matrix(q);
    if I_rounded_turned_on then off rounded;
    if trans_done then
     return {'list,algebraic tp V,q_mat,algebraic tp U}
      else return {'list,algebraic tp U,q_mat,algebraic tp V};
  end;

flag('(svd),'opfn); % To make it available from algebraic (user) mode.



symbolic procedure q_to_diag_matrix(q);
  %
  % Converts q (a vector) to a diagonal matrix with the elements of
  % q on the diagonal.
  %
  begin
    scalar q_mat;
    integer i,sq_dim_q;
    sq_dim_q := upbv(q);
    q_mat := mkmatrix(sq_dim_q,sq_dim_q);
    for i:=1:sq_dim_q do setmat(q_mat,i,i,getv(q,i));
    return q_mat;
  end;


symbolic procedure pseudo_inverse(in_mat);
  %
  % Also known as the Moore-Penrose Inverse.
  %
  % Given the singular value decomposition A := tp(U) diag(q) V
  % the pseudo inverse A^(-1) is defined as
  %
  %   A^(-1) = tp(V) (diag(q))^(-1) U.
  %
  % NB: this can be quite handy as we can take the inverse of non
  % square matrices (A * pseudo_inverse(A) = identity).
  %
  begin
    scalar psu_inv,svd_list;
    svd_list := svd(in_mat);
    psu_inv := algebraic
                (tp(third svd_list)*(1/second svd_list)*first svd_list);
    return psu_inv;
  end;

flag('(pseudo_inverse),'opfn);



symbolic procedure rd_copy_mat(A);
  %
  % Creates a copy of the input matrix and returns it aswell as
  % reval-ing each elt to get them in !:rd!: form;
  %
  begin
    scalar C;
    integer row_dim,column_dim;
    row_dim := first size_of_matrix(A);
    column_dim := second size_of_matrix(A);
    C := mkmatrix(row_dim,column_dim);
    for i:=1:row_dim do
    <<
      for j:=1:column_dim do
      <<
        setmat(C,i,j,my_reval(getmat(A,i,j)));
      >>;
    >>;
    return C;
  end;



%
% All computation is done with rounded mode on and with all numbers
% in !:rd!: form. The following specrd!: functions makes the algebraic
% computation of these numbers very efficient.
%
symbolic procedure specrd!:times(u,v);
  begin
    scalar negsign;
    u := add_minus(u);
    v := add_minus(v);
    if eqcar(u,'minus) then << u := cadr u; negsign := t>>;
    if eqcar(v,'minus) then << v := cadr v; negsign := not negsign>>;
    if atom u then u := mkround float u;
    if atom v then v := mkround float v;
    return if negsign then list('minus,rd!:times(u,v))
            else rd!:times(u,v);
  end;



symbolic procedure specrd!:quotient(u,v);
  begin
    scalar negsign;
    u := add_minus(u);
    v := add_minus(v);
    if eqcar(u,'minus) then << u := cadr u; negsign := t>>;
    if eqcar(v,'minus) then << v := cadr v; negsign := not negsign>>;
    if atom u then u := mkround float u;
    if atom v then v := mkround float v;
    return if negsign then list('minus,rd!:quotient(u,v))
                else rd!:quotient(u,v);
  end;



symbolic procedure specrd!:expt(u,v);
  begin
    if (u = '(!:rd!: . 0.0) or u = 0) then return '(!:rd!: . 0.0);
    if eqcar(u,'minus) then u := ('!:rd!: . -cdadr u);
    if eqcar(v,'minus) then v := ('!:rd!: . -cdadr v);
    if atom u then u := mkround float u;
    if atom v then v := mkround float v;
    return rdexpt!*(u,v);
  end;



symbolic procedure specrd!:sqrt(u);
  specrd!:expt(u,0.5);



symbolic procedure specrd!:plus(u,v);
  begin
    scalar negsign;
    negsign := 0;
    u := add_minus(u);
    v := add_minus(v);
    if eqcar(u,'minus) then << u := cadr u; negsign := 1>>;
    if eqcar(v,'minus) then << v := cadr v; negsign := negsign +2>>;
    if atom u then u := mkround float u;
    if atom v then v := mkround float v;
    return if negsign = 0 then rd!:plus(u,v)
            else if negsign = 3 then list('minus,rd!:plus(u,v))
             else if negsign =2 then rd!:difference (u,v)
               else rd!:difference(v,u);
  end;


symbolic procedure specrd!:difference(u,v);
  begin
    scalar negsign;
    negsign := 0;
    u := add_minus(u);
    v := add_minus(v);
    if eqcar(u,'minus) then << u := cadr u; negsign := 1>>;
    if eqcar(v,'minus) then << v := cadr v; negsign := negsign +2>>;
    if atom u then u := mkround float u;
    if atom v then v := mkround float v;
    return if negsign = 0 then rd!:difference(u,v)
            else if negsign = 3 then list('minus,rd!:difference(u,v))
             else if negsign =2 then rd!:plus (u,v)
              else list('minus,rd!:plus(v,u));
  end;



symbolic procedure add_minus(u);
  %
  % Things like (!:rd!: . -0.12345) can cause problems as negsign does
  % not notice the negative. This function converts that to
  % {'minus,(!:rd!: . 0.12345)}. Unfortunately it slows things down but
  % it works.
  %
  begin
    if atom u then return u
    else if car u = '!:rd!: and cdr u >= 0 then return u
    else if car u = '!:rd!: and cdr u < 0 then
     return {'minus,('!:rd!: . abs(cdr u))}
    else if car u = 'minus and numberp cadr u then return u
    else if car u = 'minus and cdadr u < 0 then
     return ('!:rd!: . abs(cdadr u))
    else if car u = 'minus then return u
    else if cdr u < 0 then return {'minus,('!:rd!: . abs(cdr u))}
    else return u;
  end;



endmodule;  % svd.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/tadjoint.red0000644000175000017500000002020211526203062024256 0ustar  giovannigiovannimodule tadjoint;

%**********************************************************************%
%                                                                      %
% Calculation of the Triangularizing Adjoint for a given matrix A. The %
% Triangularizing Adjoint F is a lower triangular matrix.              %
%                                                                      %
% Author: Walter Tietze, July 1998                                  %
%                                                                      %
% The algorithm is due to Arne Storjohann, The Triangularizing Adjoint,%
% Institut f"ur Wissenschaftliches Rechnen, ETH Z"urich, Switzerland,  %
% http://www.inf.ethz.ch/personal/storjoha                              %
% Ref: See Arne's paper in the ISSAC 1997 proceedings                   %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic smacro procedure mksq!*mat in_mat;
%
% Converts entries in matrix to standard quotients.
%
begin scalar tmp_mat,out_mat;
   tmp_mat:= cdr in_mat;
   out_mat:= for each u in tmp_mat collect
               for each v in u collect
                 if atom v then v
                 else mk!*sq v;
   return 'mat . out_mat;
end;


symbolic smacro procedure reval!*mat in_mat;
%
% Revals the entries in matrix.
%
begin scalar tmp_mat,out_mat;
   tmp_mat:= cdr in_mat;
   out_mat:= for each u in tmp_mat collect
               for each v in u collect
                  my_reval v;
   return 'mat . out_mat;
end;


symbolic procedure triang_adjoint in_mat;
%
% Due to the algorithm of Arne Storjohann this function
% calculates the lower triangular matrix, the so-called
% triangularizing adjoint.
%
begin scalar u;
      if eqcar(u:=aeval(in_mat),'matrix) then u:=cadr u
      else u:=reval in_mat;
      if not matrixp(u) then
        rederr "Error in triang_adjoint: non matrix input."
      else if not squarep(u) then
        rederr "Error in triang_adjoint: input matrix should be square."
      else return matsm adtriang!* u;
end;

put('triang_adjoint,'rtypefn,'getrtypecar);


symbolic procedure adtriang!* in_mat;
%
% Strategy : Calculate the triangularizing adjoint by
% transforming in_mat to a matrix with lowest 2-potential
% dimension greater or equal to the dimension of in_mat.
%
(begin scalar mat_dim,tmp_mat,l,base;
      integer dim;
      on fast_la;
      dim:=cadr matlength in_mat;
      base:=logb(dim,2);
      mat_dim:= if base-floor(base)=0 then fix base
                else (floor(base) + 1);
      mat_dim:=2**mat_dim;
      if mat_dim>dim then
         tmp_mat:=extend(in_mat,mat_dim - dim,mat_dim - dim,0)
      else tmp_mat:=in_mat;
      tmp_mat:=adjoint!*lu(tmp_mat);
      l:= for i:=1:dim collect i;
      tmp_mat:=sub_matrix(tmp_mat,l,l);
 return tmp_mat;
end) where !*fast_la = !*fast_la;


symbolic procedure adjoint!*lu(in_mat);
%
% This function calculates iteratively the triangularizing
% adjoint.
%
begin scalar a1,a_tmp, a_tmp1, f1, a4!*,f4!*, subdim0, subdim1, l;
      integer determinant, dim, crrnt_dim;
      dim := cadr matlength in_mat;
      if dim < 2 then return 'mat . list({1});
      crrnt_dim := 1;
      f1:=list('mat,{1});
      while crrnt_dim < dim do
      begin
          subdim0:= for i:=1:crrnt_dim                 collect i;
          subdim1:= for i:=(crrnt_dim+1):(2*crrnt_dim) collect i;
          a1:=sub_matrix(in_mat,subdim0,subdim0);
          a1:=  reval!*mat a1;
          determinant:=0;
          for j:=1:(crrnt_dim) do
              determinant:={'plus,my_reval determinant, my_reval{'times,
                             getmat(f1,crrnt_dim,j),getmat(a1,j,crrnt_dim)}};
          if my_reval determinant = 0 then
              << a_tmp := sub_matrix(in_mat,append(subdim0,subdim1),subdim0);
                 if rank!-eval(list(a_tmp)) < crrnt_dim then
                   << f1:=extend(f1,crrnt_dim,crrnt_dim,0);
                      crrnt_dim:= 2*crrnt_dim;
                   >>
                 else
                   << if crrnt_dim=1 then
                         <>
                      else <>;
                   >>;
               >>
          else
            <<
               a4!*:= matinverse matsm a1;
               a_tmp:=sub_matrix(in_mat,subdim1,subdim0);
               a4!*:= multm(matsm a_tmp, a4!*);
               a4!* := for each u in a4!* collect
                          for each v in u collect
                             v:= negsq v;
               a_tmp1:='mat . a4!*;
               a_tmp:=sub_matrix(in_mat,subdim0,subdim1);
               a4!*:= multm(a4!*, matsm a_tmp);
               a4!*:= addm(a4!*,matsm sub_matrix(in_mat,subdim1,subdim1));
               a4!*:= 'mat . a4!*;
               f4!* := adjoint!*lu reval!*mat mksq!*mat a4!*;
               l:= for i:=1:crrnt_dim collect i;
               a_tmp := mult_rows(f4!*,l,determinant);
               a_tmp:=reval!*mat a_tmp;
               f1:=extend(f1,crrnt_dim,crrnt_dim,0);
               f1:=copy_into(a_tmp,f1,crrnt_dim+1,crrnt_dim+1);
               a_tmp:='mat . multm(matsm a_tmp,matsm mksq!*mat a_tmp1);
               a_tmp:=mksq!*mat a_tmp;
               f1:=copy_into(a_tmp,f1,crrnt_dim+1,1);
               crrnt_dim:=crrnt_dim*2;
            >>;
      end;
      return f1;
end;


symbolic procedure compose!*mat(in_mat,f1,subdim0,crrnt_dim);
%
% Due to the algorithm of Arne Storjohann this function
% determines the rows of the triangularizing adjoint which
% can be set equal to zero.
%
begin scalar tmp_mat,tmp_row,k;
      for i:=(2*crrnt_dim) step (-1) until crrnt_dim do
      begin
       k:= for j:=1:i collect j;
       if rank!-eval {sub_matrix(in_mat,k,subdim0)} < crrnt_dim then
          << f1:=extend(f1,crrnt_dim,crrnt_dim,0);
             for j:=(i+1):(2*crrnt_dim) do
             begin
                k:= append(k,{j});
                tmp_mat:=sub_matrix(in_mat,k,k);
                tmp_row:=adjoint_lst_row!*(tmp_mat,j);
                for l:=1:j do
                   setmat(f1,j,l,nth(cadr tmp_row,l));
             end;
             i:=crrnt_dim-1;
          >>
      end;
 return f1;
end;


symbolic procedure adjoint_lst_row!*(in_mat,len);
%
% Calculates one row for the triangularizing adjoint in
% last row of submatrix(len,len) of matrix in_mat.
%
begin
   scalar tmp_mat, adj_row,det;
   integer sign;
   if len=1 then return in_mat;
   for j:=1:len do
      begin
        sign := (-1)**(len+j);
        tmp_mat := minor(in_mat, j, len);
        if sign = -1 then
           det:= mk!*sq negsq(simpdet({tmp_mat}))
        else
           det:= mk!*sq simpdet({tmp_mat});
        adj_row:=append(adj_row,{det});
      end;
 return 'mat . {adj_row}
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/gramschm.red0000644000175000017500000001740511526203062024256 0ustar  giovannigiovannimodule gramchmd;

%**********************************************************************%
%                                                                      %
% Computation of the Gram Schmidt Orthonormalisation process. The      %
% input vectors are represented by lists.                              %
%                                                                      %
% Authors: Karin Gatermann (used symbolically in her symmetry package).%
%          Matt Rebbeck (first few lines of code that make it          %
%                        available from the user level).   May 1994.   %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




put('gram_schmidt,'psopfn,'gram_schmidt1); % To allow variable input.
symbolic procedure gram_schmidt1(vec_list);
  %
  % Can take a list of lists(which are representing vectors) or any
  % number of arguments each being a list(again which represent the
  % vectors).
  %
  % Karin used lists of standard quotient elements as vectors so a bit
  % of fiddling is required to get the input/output right.
  %
  begin
    scalar gs_list;
    % Deal with the possibility of the user entering a list of lists.
    if pairp vec_list and pairp car vec_list and caar vec_list = 'list
     and pairp cdar vec_list and pairp cadar vec_list
      and caadar vec_list = 'list
       then vec_list := cdar vec_list;
    vec_list := convert_to_sq(vec_list);
    % This bit does all the real work.
    gs_list := gram!+schmid(vec_list);
    return convert_from_sq(gs_list);
  end;



symbolic procedure convert_to_sq(vec_list);
  %
  % Takes algebraic list and converts to sq form for input into
  % GramSchmidt.
  %
  begin
    scalar sq_list;
    sq_list := for each list in vec_list collect
      for each elt in cdr list collect simp!* elt;
    return sq_list;
  end;



symbolic procedure convert_from_sq(sq_list);
  %
  % Converts sq_list to a readable (from algebraic mode) form.
  %
  begin
    scalar gs_list;
    gs_list := 'list.for each elt1 in sq_list collect
                'list.for each elt in elt1 collect prepsq elt;
    return gs_list;
  end;


%
% All the rest is Karin's.
%

symbolic procedure vector!+p(vector1);
  %
  % returns the length of a vector
  % vector -- list of sqs
  %
  begin
    if length(vector1)>0 then return t;
  end;



symbolic procedure get!+vec!+dim(vector1);
  %
  % returns the length of a vector
  % vector -- list of sqs
  %
  begin
    return length(vector1);
  end;



symbolic procedure get!+vec!+entry(vector1,elem);
  %
  % returns the length of a vector
  % vector -- list of sqs
  %
  begin
    return nth(vector1,elem);
  end;



symbolic procedure mk!+vec!+add!+vec(vector1,vector2);
  %
  % returns a vector= vector1+vector2 (internal structure)
  %
  begin
    scalar ent,res,h;
    res:=for ent:=1:get!+vec!+dim(vector1) collect
    <<
      h:= addsq(get!+vec!+entry(vector1,ent),
             get!+vec!+entry(vector2,ent));
      h:=subs2 h where !*sub2=t;
      h
    >>;
    return res;
  end;



symbolic procedure mk!+squared!+norm(vector1);
  %
  % returns a scalar= sum vector_i^2 (internal structure)
  %
  begin
    return mk!+inner!+product(vector1,vector1);
  end;



symbolic procedure my!+nullsq!+p(scal);
  %
  % returns true, if ths sq is zero
  %
  begin
    if null(numr( scal)) then return t;
  end;



symbolic procedure mk!+null!+vec(dimen);
  %
  % returns a vector of zeros
  %
  begin
    scalar nullsq,i,res;
    nullsq:=(nil ./ 1);
    res:=for i:=1:dimen collect nullsq;
    return res;
  end;



symbolic procedure null!+vec!+p(vector1);
  %
  % returns a true, if vector is the zero vector
  begin
    if my!+nullsq!+p(mk!+squared!+norm(vector1)) then return t;
  end;



symbolic procedure mk!+normalize!+vector(vector1);
  %
  % returns a normalized vector (internal structure)
  %
  begin
    scalar scalo,vecres;
    scalo:=simp!* {'sqrt, mk!*sq(mk!+squared!+norm(vector1))};
    if my!+nullsq!+p(scalo) then
     vecres:= mk!+null!+vec(get!+vec!+dim(vector1))
     else
     <<
       scalo:=simp prepsq scalo;
       scalo:=quotsq((1 ./ 1),scalo);
       vecres:= mk!+scal!+mult!+vec(scalo,vector1);
     >>;
    return vecres;
  end;



symbolic procedure mk!+Gram!+Schmid(vectorlist,vector1);
  %
  % returns a vectorlist of orthonormal vectors
  % assumptions: vectorlist is orthonormal basis, internal structure
  %
  begin
    scalar i,orthovec,scalo,vectors;
    orthovec:=vector1;
    for i:=1:(length(vectorlist)) do
    <<
      scalo:= negsq(mk!+inner!+product(orthovec,nth(vectorlist,i)));
      orthovec:=mk!+vec!+add!+vec(orthovec,
         mk!+scal!+mult!+vec(scalo,nth(vectorlist,i)));
    >>;
    orthovec:=mk!+normalize!+vector(orthovec);
    if null!+vec!+p(orthovec) then vectors:=vectorlist
     else vectors:=add!+vector!+to!+list(orthovec,vectorlist);
    return vectors;
  end;



symbolic procedure Gram!+Schmid(vectorlist);
  %
  % returns a vectorlist of orthonormal vectors
  %
  begin
    scalar ortholist,i;
    if length(vectorlist)<1
      then rederr "Error in Gram Schmidt: no input.";
    if vector!+p(car vectorlist) then ortholist:=nil
     else rederr "Error in Gram_schmidt: empty input.";
    for i:=1:length(vectorlist) do
     ortholist:=mk!+Gram!+Schmid(ortholist,nth(vectorlist,i));
    return ortholist;
  end;



symbolic procedure add!+vector!+to!+list(vector1,vectorlist);
  %
  % returns a list of vectors consisting of vectorlist
  % and the vector1 at the end
  % internal structure
  begin
    return append(vectorlist,list(vector1));
  end;



symbolic procedure mk!+inner!+product(vector1,vector2);
  %
  % returns the inner product of vector1 and vector2
  % (internal structure)
  %
  begin
    scalar z,sum,vec2;
    if not(get!+vec!+dim(vector1) = get!+vec!+dim(vector2)) then rederr
   "Error in Gram_schmidt: each list in input must be the same length.";
    sum:=(nil ./ 1);
    if !*complex then vec2:=mk!+conjugate!+vec(vector2)
     else vec2:=vector2;
    for z:=1:get!+vec!+dim(vector1) do
     sum:=addsq(sum,multsq(
            get!+vec!+entry(vector1,z),
            get!+vec!+entry(vec2,z)
                           )
                );
    sum:=subs2 sum where !*sub2=t;
    return sum;
  end;



symbolic procedure mk!+scal!+mult!+vec(scal1,vector1);
  %
  % returns a vector= scalar*vector (internal structure)
  %
  begin
    scalar entry,res,h;
    res:=for each entry in vector1 collect
    <<
      h:=multsq(scal1,entry);
      h:=subs2 h where !*sub2=t;
      h
    >>;
    return res;
  end;


endmodule;  % gram_schmidt.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/linalg.rlg0000644000175000017500000011722511527635055023752 0ustar  giovannigiovanniFri Feb 18 21:27:56 2011 run on win32
if lisp !*rounded then rounded_was_on := t 
 else rounded_was_on := nil;



mat1  := mat((1,2,3,4,5),(2,3,4,5,6),(3,4,5,6,7),(4,5,6,7,8),(5,6,7,8,9));


        [1  2  3  4  5]
        [             ]
        [2  3  4  5  6]
        [             ]
mat1 := [3  4  5  6  7]
        [             ]
        [4  5  6  7  8]
        [             ]
        [5  6  7  8  9]


mat2  := mat((1,1,1,1),(2,2,2,2),(3,3,3,3),(4,4,4,4));


        [1  1  1  1]
        [          ]
        [2  2  2  2]
mat2 := [          ]
        [3  3  3  3]
        [          ]
        [4  4  4  4]


mat3  := mat((x),(x),(x),(x));


        [x]
        [ ]
        [x]
mat3 := [ ]
        [x]
        [ ]
        [x]


mat4  := mat((3,3),(4,4),(5,5),(6,6));


        [3  3]
        [    ]
        [4  4]
mat4 := [    ]
        [5  5]
        [    ]
        [6  6]

 
mat5  := mat((1,2,1,1),(1,2,3,1),(4,5,1,2),(3,4,5,6));


        [1  2  1  1]
        [          ]
        [1  2  3  1]
mat5 := [          ]
        [4  5  1  2]
        [          ]
        [3  4  5  6]


mat6  := mat((i+1,i+2,i+3),(4,5,2),(1,i,0));


        [i + 1  i + 2  i + 3]
        [                   ]
mat6 := [  4      5      2  ]
        [                   ]
        [  1      i      0  ]


mat7  := mat((1,1,0),(1,3,1),(0,1,1));


        [1  1  0]
        [       ]
mat7 := [1  3  1]
        [       ]
        [0  1  1]


mat8  := mat((1,3),(-4,3));


        [1   3]
mat8 := [     ]
        [-4  3]


mat9 :=  mat((1,2,3,4),(9,8,7,6));


        [1  2  3  4]
mat9 := [          ]
        [9  8  7  6]


poly  := x^7+x^5+4*x^4+5*x^3+12;


         7    5      4      3
poly := x  + x  + 4*x  + 5*x  + 12

poly1 := x^2+x*y^3+x*y*z^3+y*x+2+y*3;


          2      3        3
poly1 := x  + x*y  + x*y*z  + x*y + 3*y + 2


on errcont;




% Basis matrix manipulations.

add_columns(mat1,1,2,5*y);


[1    5*y + 2    3  4  5]
[                       ]
[2   10*y + 3    4  5  6]
[                       ]
[3   15*y + 4    5  6  7]
[                       ]
[4  5*(4*y + 1)  6  7  8]
[                       ]
[5   25*y + 6    7  8  9]


add_rows(mat1,1,2,x);


[  1       2        3        4        5   ]
[                                         ]
[x + 2  2*x + 3  3*x + 4  4*x + 5  5*x + 6]
[                                         ]
[  3       4        5        6        7   ]
[                                         ]
[  4       5        6        7        8   ]
[                                         ]
[  5       6        7        8        9   ]



add_to_columns(mat1,3,1000);


[1  2  1003  4  5]
[                ]
[2  3  1004  5  6]
[                ]
[3  4  1005  6  7]
[                ]
[4  5  1006  7  8]
[                ]
[5  6  1007  8  9]


add_to_columns(mat1,{1,2,3},y);


[y + 1  y + 2  y + 3  4  5]
[                         ]
[y + 2  y + 3  y + 4  5  6]
[                         ]
[y + 3  y + 4  y + 5  6  7]
[                         ]
[y + 4  y + 5  y + 6  7  8]
[                         ]
[y + 5  y + 6  y + 7  8  9]


add_to_rows(mat1,2,1000);


[ 1     2     3     4     5  ]
[                            ]
[1002  1003  1004  1005  1006]
[                            ]
[ 3     4     5     6     7  ]
[                            ]
[ 4     5     6     7     8  ]
[                            ]
[ 5     6     7     8     9  ]


add_to_rows(mat1,{1,2,3},x);


[x + 1  x + 2  x + 3  x + 4  x + 5]
[                                 ]
[x + 2  x + 3  x + 4  x + 5  x + 6]
[                                 ]
[x + 3  x + 4  x + 5  x + 6  x + 7]
[                                 ]
[  4      5      6      7      8  ]
[                                 ]
[  5      6      7      8      9  ]



augment_columns(mat1,2);


[2]
[ ]
[3]
[ ]
[4]
[ ]
[5]
[ ]
[6]

  
augment_columns(mat1,{1,2,5});


[1  2  5]
[       ]
[2  3  6]
[       ]
[3  4  7]
[       ]
[4  5  8]
[       ]
[5  6  9]


stack_rows(mat1,3);


[3  4  5  6  7]

  
stack_rows(mat1,{1,3,5});


[1  2  3  4  5]
[             ]
[3  4  5  6  7]
[             ]
[5  6  7  8  9]

  

char_poly(mat1,x);


 3   2
x *(x  - 25*x - 50)


column_dim(mat2);


4

row_dim(mat1);


5


copy_into(mat7,mat1,2,3);


[1  2  3  4  5]
[             ]
[2  3  1  1  0]
[             ]
[3  4  1  3  1]
[             ]
[4  5  0  1  1]
[             ]
[5  6  7  8  9]


copy_into(mat7,mat1,5,5);

***** Error in copy_into: the matrix

[1  1  0]
[       ]
[1  3  1]
[       ]
[0  1  1]

      does not fit into

[1  2  3  4  5]
[             ]
[2  3  4  5  6]
[             ]
[3  4  5  6  7]
[             ]
[4  5  6  7  8]
[             ]
[5  6  7  8  9]

      at position 5,5.


diagonal(3);


[3]


% diagonal can take both a list of arguments or just the arguments.
diagonal({mat2,mat6});


[1  1  1  1    0      0      0  ]
[                               ]
[2  2  2  2    0      0      0  ]
[                               ]
[3  3  3  3    0      0      0  ]
[                               ]
[4  4  4  4    0      0      0  ]
[                               ]
[0  0  0  0  i + 1  i + 2  i + 3]
[                               ]
[0  0  0  0    4      5      2  ]
[                               ]
[0  0  0  0    1      i      0  ]


diagonal(mat1,mat2,mat5);


[1  2  3  4  5  0  0  0  0  0  0  0  0]
[                                     ]
[2  3  4  5  6  0  0  0  0  0  0  0  0]
[                                     ]
[3  4  5  6  7  0  0  0  0  0  0  0  0]
[                                     ]
[4  5  6  7  8  0  0  0  0  0  0  0  0]
[                                     ]
[5  6  7  8  9  0  0  0  0  0  0  0  0]
[                                     ]
[0  0  0  0  0  1  1  1  1  0  0  0  0]
[                                     ]
[0  0  0  0  0  2  2  2  2  0  0  0  0]
[                                     ]
[0  0  0  0  0  3  3  3  3  0  0  0  0]
[                                     ]
[0  0  0  0  0  4  4  4  4  0  0  0  0]
[                                     ]
[0  0  0  0  0  0  0  0  0  1  2  1  1]
[                                     ]
[0  0  0  0  0  0  0  0  0  1  2  3  1]
[                                     ]
[0  0  0  0  0  0  0  0  0  4  5  1  2]
[                                     ]
[0  0  0  0  0  0  0  0  0  3  4  5  6]



extend(mat1,3,2,x);


[1  2  3  4  5  x  x]
[                   ]
[2  3  4  5  6  x  x]
[                   ]
[3  4  5  6  7  x  x]
[                   ]
[4  5  6  7  8  x  x]
[                   ]
[5  6  7  8  9  x  x]
[                   ]
[x  x  x  x  x  x  x]
[                   ]
[x  x  x  x  x  x  x]
[                   ]
[x  x  x  x  x  x  x]



find_companion(mat5,x);


 2
x  - 2*x - 2


get_columns(mat1,1);


{

 [1]
 [ ]
 [2]
 [ ]
 [3]
 [ ]
 [4]
 [ ]
 [5]

 }

get_columns(mat1,{1,2});


{

 [1]
 [ ]
 [2]
 [ ]
 [3]
 [ ]
 [4]
 [ ]
 [5]

 ,

 [2]
 [ ]
 [3]
 [ ]
 [4]
 [ ]
 [5]
 [ ]
 [6]

 }

get_rows(mat1,3);


{

 [3  4  5  6  7]

 }

get_rows(mat1,{1,3});


{

 [1  2  3  4  5]

 ,

 [3  4  5  6  7]

 }


hermitian_tp(mat6);


[ - i + 1  4   1  ]
[                 ]
[ - i + 2  5   - i]
[                 ]
[ - i + 3  2   0  ]



% matrix_augment and matrix_stack can take both a list of arguments 
% or just the arguments.
matrix_augment({mat1,mat2});

***** Error in matrix_augment: 
***** all input matrices must have the same row dimension. 

matrix_augment(mat4,mat2,mat4);


[3  3  1  1  1  1  3  3]
[                      ]
[4  4  2  2  2  2  4  4]
[                      ]
[5  5  3  3  3  3  5  5]
[                      ]
[6  6  4  4  4  4  6  6]


matrix_stack(mat1,mat2);

***** Error in matrix_stack: 
***** all input matrices must have the same column dimension. 

matrix_stack({mat6,mat((z,z,z)),mat7});


[i + 1  i + 2  i + 3]
[                   ]
[  4      5      2  ]
[                   ]
[  1      i      0  ]
[                   ]
[  z      z      z  ]
[                   ]
[  1      1      0  ]
[                   ]
[  1      3      1  ]
[                   ]
[  0      1      1  ]



minor(mat1,2,3);


[1  2  4  5]
[          ]
[3  4  6  7]
[          ]
[4  5  7  8]
[          ]
[5  6  8  9]



mult_columns(mat1,3,y);


[1  2  3*y  4  5]
[               ]
[2  3  4*y  5  6]
[               ]
[3  4  5*y  6  7]
[               ]
[4  5  6*y  7  8]
[               ]
[5  6  7*y  8  9]


mult_columns(mat1,{2,3,4},100);


[1  200  300  400  5]
[                   ]
[2  300  400  500  6]
[                   ]
[3  400  500  600  7]
[                   ]
[4  500  600  700  8]
[                   ]
[5  600  700  800  9]


mult_rows(mat1,2,x);


[ 1    2    3    4    5 ]
[                       ]
[2*x  3*x  4*x  5*x  6*x]
[                       ]
[ 3    4    5    6    7 ]
[                       ]
[ 4    5    6    7    8 ]
[                       ]
[ 5    6    7    8    9 ]


mult_rows(mat1,{1,3,5},10);


[10  20  30  40  50]
[                  ]
[2   3   4   5   6 ]
[                  ]
[30  40  50  60  70]
[                  ]
[4   5   6   7   8 ]
[                  ]
[50  60  70  80  90]



pivot(mat1,3,3);


[  - 4     - 2        2       4   ]
[------  ------  0   ---     ---  ]
[  5       5          5       5   ]
[                                 ]
[  - 2     - 1        1       2   ]
[------  ------  0   ---     ---  ]
[  5       5          5       5   ]
[                                 ]
[  3       4     5    6       7   ]
[                                 ]
[  2       1          - 1     - 2 ]
[ ---     ---    0  ------  ------]
[  5       5          5       5   ]
[                                 ]
[  4       2          - 2     - 4 ]
[ ---     ---    0  ------  ------]
[  5       5          5       5   ]


rows_pivot(mat1,3,3,{1,5});


[  - 4     - 2        2       4   ]
[------  ------  0   ---     ---  ]
[  5       5          5       5   ]
[                                 ]
[  2       3     4    5       6   ]
[                                 ]
[  3       4     5    6       7   ]
[                                 ]
[  4       5     6    7       8   ]
[                                 ]
[  4       2          - 2     - 4 ]
[ ---     ---    0  ------  ------]
[  5       5          5       5   ]



remove_columns(mat1,3);


[1  2  4  5]
[          ]
[2  3  5  6]
[          ]
[3  4  6  7]
[          ]
[4  5  7  8]
[          ]
[5  6  8  9]


remove_columns(mat1,{2,3,4});


[1  5]
[    ]
[2  6]
[    ]
[3  7]
[    ]
[4  8]
[    ]
[5  9]


remove_rows(mat1,2);


[1  2  3  4  5]
[             ]
[3  4  5  6  7]
[             ]
[4  5  6  7  8]
[             ]
[5  6  7  8  9]


remove_rows(mat1,{1,3});


[2  3  4  5  6]
[             ]
[4  5  6  7  8]
[             ]
[5  6  7  8  9]


remove_rows(mat1,{1,2,3,4,5});

***** Warning in remove_rows:
      all the rows have been removed. Returning nil.


swap_columns(mat1,2,4);


[1  4  3  2  5]
[             ]
[2  5  4  3  6]
[             ]
[3  6  5  4  7]
[             ]
[4  7  6  5  8]
[             ]
[5  8  7  6  9]


swap_rows(mat1,1,2);


[2  3  4  5  6]
[             ]
[1  2  3  4  5]
[             ]
[3  4  5  6  7]
[             ]
[4  5  6  7  8]
[             ]
[5  6  7  8  9]


swap_entries(mat1,{1,1},{5,5});


[9  2  3  4  5]
[             ]
[2  3  4  5  6]
[             ]
[3  4  5  6  7]
[             ]
[4  5  6  7  8]
[             ]
[5  6  7  8  1]




% Constructors - functions that create matrices.

band_matrix(x,5);


[x  0  0  0  0]
[             ]
[0  x  0  0  0]
[             ]
[0  0  x  0  0]
[             ]
[0  0  0  x  0]
[             ]
[0  0  0  0  x]


band_matrix({x,y,z},6);


[y  z  0  0  0  0]
[                ]
[x  y  z  0  0  0]
[                ]
[0  x  y  z  0  0]
[                ]
[0  0  x  y  z  0]
[                ]
[0  0  0  x  y  z]
[                ]
[0  0  0  0  x  y]



block_matrix(1,2,{mat1,mat2});

***** Error in block_matrix: row dimensions of 
***** matrices into block_matrix are not compatible 

block_matrix(2,3,{mat2,mat3,mat2,mat3,mat2,mat2});


[1  1  1  1  x  1  1  1  1]
[                         ]
[2  2  2  2  x  2  2  2  2]
[                         ]
[3  3  3  3  x  3  3  3  3]
[                         ]
[4  4  4  4  x  4  4  4  4]
[                         ]
[x  1  1  1  1  1  1  1  1]
[                         ]
[x  2  2  2  2  2  2  2  2]
[                         ]
[x  3  3  3  3  3  3  3  3]
[                         ]
[x  4  4  4  4  4  4  4  4]



char_matrix(mat1,x);


[x - 1   -2     -3     -4     -5  ]
[                                 ]
[ -2    x - 3   -4     -5     -6  ]
[                                 ]
[ -3     -4    x - 5   -6     -7  ]
[                                 ]
[ -4     -5     -6    x - 7   -8  ]
[                                 ]
[ -5     -6     -7     -8    x - 9]



cfmat := coeff_matrix({x+y+4*z=10,y+x-z=20,x+y+4});


cfmat := {

          [4   1  1]
          [        ]
          [-1  1  1]
          [        ]
          [0   1  1]

          ,

          [z]
          [ ]
          [y]
          [ ]
          [x]

          ,

          [10]
          [  ]
          [20]
          [  ]
          [-4]

          }

first cfmat * second cfmat;


[x + y + 4*z]
[           ]
[ x + y - z ]
[           ]
[   x + y   ]


third cfmat;


[10]
[  ]
[20]
[  ]
[-4]



companion(poly,x);


[0  0  0  0  0  0  -12]
[                     ]
[1  0  0  0  0  0   0 ]
[                     ]
[0  1  0  0  0  0   0 ]
[                     ]
[0  0  1  0  0  0  -5 ]
[                     ]
[0  0  0  1  0  0  -4 ]
[                     ]
[0  0  0  0  1  0  -1 ]
[                     ]
[0  0  0  0  0  1   0 ]



hessian(poly1,{w,x,y,z});


[0        0              0           0   ]
[                                        ]
[                     2    3           2 ]
[0        2        3*y  + z  + 1  3*y*z  ]
[                                        ]
[      2    3                          2 ]
[0  3*y  + z  + 1      6*x*y      3*x*z  ]
[                                        ]
[           2              2             ]
[0     3*y*z          3*x*z       6*x*y*z]



hilbert(4,1);


[      1    1    1 ]
[ 1   ---  ---  ---]
[      2    3    4 ]
[                  ]
[ 1    1    1    1 ]
[---  ---  ---  ---]
[ 2    3    4    5 ]
[                  ]
[ 1    1    1    1 ]
[---  ---  ---  ---]
[ 3    4    5    6 ]
[                  ]
[ 1    1    1    1 ]
[---  ---  ---  ---]
[ 4    5    6    7 ]


hilbert(3,y+x);


[    - 1          - 1          - 1    ]
[-----------  -----------  -----------]
[ x + y - 2    x + y - 3    x + y - 4 ]
[                                     ]
[    - 1          - 1          - 1    ]
[-----------  -----------  -----------]
[ x + y - 3    x + y - 4    x + y - 5 ]
[                                     ]
[    - 1          - 1          - 1    ]
[-----------  -----------  -----------]
[ x + y - 4    x + y - 5    x + y - 6 ]



% NOTE WELL. The function tested here used to be called just "jacobian"
% however us of that name was in conflict with another Reduce package so
% now it is called mat_jacobian.
mat_jacobian({x^4,x*y^2,x*y*z^3},{w,x,y,z});


[      3                 ]
[0  4*x     0       0    ]
[                        ]
[     2                  ]
[0   y    2*x*y     0    ]
[                        ]
[      3     3          2]
[0  y*z   x*z    3*x*y*z ]



jordan_block(x,5);


[x  1  0  0  0]
[             ]
[0  x  1  0  0]
[             ]
[0  0  x  1  0]
[             ]
[0  0  0  x  1]
[             ]
[0  0  0  0  x]



make_identity(11);


[1  0  0  0  0  0  0  0  0  0  0]
[                               ]
[0  1  0  0  0  0  0  0  0  0  0]
[                               ]
[0  0  1  0  0  0  0  0  0  0  0]
[                               ]
[0  0  0  1  0  0  0  0  0  0  0]
[                               ]
[0  0  0  0  1  0  0  0  0  0  0]
[                               ]
[0  0  0  0  0  1  0  0  0  0  0]
[                               ]
[0  0  0  0  0  0  1  0  0  0  0]
[                               ]
[0  0  0  0  0  0  0  1  0  0  0]
[                               ]
[0  0  0  0  0  0  0  0  1  0  0]
[                               ]
[0  0  0  0  0  0  0  0  0  1  0]
[                               ]
[0  0  0  0  0  0  0  0  0  0  1]



on rounded;

 % makes things a bit easier to read.
random_matrix(3,3,100);


[ - 8.11911717343   - 75.7167729277    30.62058083   ]
[                                                    ]
[ - 50.0325962624   47.1655452861     35.8674263384  ]
[                                                    ]
[ - 49.3715543826   - 97.5563670864   - 18.8861862756]


on not_negative;


random_matrix(3,3,100);


[43.8999853223  33.7140980286   33.75065406 ]
[                                           ]
[49.7333355117  98.9642944905  58.5331568816]
[                                           ]
[39.9146060895  67.7954727837  24.8684367642]


on only_integer;


random_matrix(3,3,100);


[16  77  49]
[          ]
[28  84  51]
[          ]
[84  56  57]


on symmetric;


random_matrix(3,3,100);


[89  74  91]
[          ]
[74  95  41]
[          ]
[91  41  87]


off symmetric;


on upper_matrix;


random_matrix(3,3,100);


[41  3   8 ]
[          ]
[0   31  80]
[          ]
[0   0   12]


off upper_matrix;


on lower_matrix;


random_matrix(3,3,100);


[69  0   0 ]
[          ]
[34  87  0 ]
[          ]
[78  72  13]


off lower_matrix;


on imaginary;


off not_negative;


random_matrix(3,3,100);


[ - 95*i - 72   - 57*i + 59  52*i + 46]
[                                     ]
[ - 40*i - 54      70*i      39*i + 28]
[                                     ]
[ - 40*i + 45   28*i - 81    9*i + 74 ]


off rounded;



% toeplitz and vandermonde can take both a list of arguments or just 
% the arguments.
toeplitz({1,2,3,4,5});


[1  2  3  4  5]
[             ]
[2  1  2  3  4]
[             ]
[3  2  1  2  3]
[             ]
[4  3  2  1  2]
[             ]
[5  4  3  2  1]


toeplitz(x,y,z);


[x  y  z]
[       ]
[y  x  y]
[       ]
[z  y  x]



vandermonde({1,2,3,4,5});


[1  1  1    1    1 ]
[                  ]
[1  2  4    8   16 ]
[                  ]
[1  3  9   27   81 ]
[                  ]
[1  4  16  64   256]
[                  ]
[1  5  25  125  625]


vandermonde(x,y,z);


[       2]
[1  x  x ]
[        ]
[       2]
[1  y  y ]
[        ]
[       2]
[1  z  z ]



% kronecker_product

a1 := mat((1,2),(3,4),(5,6));


      [1  2]
      [    ]
a1 := [3  4]
      [    ]
      [5  6]


a2 := mat((1,x,1),(2,2,2),(3,3,3));


      [1  x  1]
      [       ]
a2 := [2  2  2]
      [       ]
      [3  3  3]



kronecker_product(a1,a2);


[1    x   1   2   2*x  2 ]
[                        ]
[2    2   2   4    4   4 ]
[                        ]
[3    3   3   6    6   6 ]
[                        ]
[3   3*x  3   4   4*x  4 ]
[                        ]
[6    6   6   8    8   8 ]
[                        ]
[9    9   9   12  12   12]
[                        ]
[5   5*x  5   6   6*x  6 ]
[                        ]
[10  10   10  12  12   12]
[                        ]
[15  15   15  18  18   18]



clear a1,a2;



% High level algorithms.

on rounded;

 % makes output easier to read.
ch := cholesky(mat7);


ch := {

       [1        0               0       ]
       [                                 ]
       [1  1.41421356237         0       ]
       [                                 ]
       [0  0.707106781187  0.707106781187]

       ,


       [1        1              0       ]
       [                                ]
       [0  1.41421356237  0.707106781187]
       [                                ]
       [0        0        0.707106781187]

       }

tp first ch - second ch;


[0  0  0]
[       ]
[0  0  0]
[       ]
[0  0  0]


tmp := first ch * second ch;


       [1   1   0]
       [         ]
tmp := [1  3.0  1]
       [         ]
       [0   1   1]


tmp - mat7;


[0  0  0]
[       ]
[0  0  0]
[       ]
[0  0  0]


off rounded;



gram_schmidt({1,0,0},{1,1,0},{1,1,1});


{{1,0,0},{0,1,0},{0,0,1}}

gram_schmidt({1,2},{3,4});


      1         2        2*sqrt(5)    - sqrt(5)
{{---------,---------},{-----------,------------}}
   sqrt(5)   sqrt(5)         5           5


on rounded;

 % again, makes large quotients a bit more readable.
% The algorithm used for lu_decom sometimes swaps the rows of the input 
% matrix so that (given matrix A, lu_decom(A) = {L,U,vec}), we find L*U 
% does not equal A but a row equivalent of it. The call convert(A,vec) 
% will return this row equivalent (ie: L*U = convert(A,vec)).
lu := lu_decom(mat5);


lu := {

       [4   0     0         0      ]
       [                           ]
       [1  0.75   0         0      ]
       [                           ]
       [1  0.75  2.0        0      ]
       [                           ]
       [3  0.25  4.0  4.33333333333]

       ,


       [1  1.25  0.25       0.5      ]
       [                             ]
       [0   1     1    0.666666666667]
       [                             ]
       [0   0     1          0       ]
       [                             ]
       [0   0     0          1       ]

       ,

       [3,3,3,4]}
 
mat5;


[1  2  1  1]
[          ]
[1  2  3  1]
[          ]
[4  5  1  2]
[          ]
[3  4  5  6]


tmp := first lu * second lu;


       [4  5.0   1   2.0]
       [                ]
       [1  2.0   1    1 ]
tmp := [                ]
       [1  2.0  3.0   1 ]
       [                ]
       [3  4.0  5.0  6.0]


tmp1 := convert(mat5,third lu);


        [4  5  1  2]
        [          ]
        [1  2  1  1]
tmp1 := [          ]
        [1  2  3  1]
        [          ]
        [3  4  5  6]


tmp - tmp1;


[0  0  0  0]
[          ]
[0  0  0  0]
[          ]
[0  0  0  0]
[          ]
[0  0  0  0]


% and the complex case...
lu1 := lu_decom(mat6);


lu1 := {

        [  1        0                      0                ]
        [                                                   ]
        [  4     - 4*i + 5                 0                ]
        [                                                   ]
        [i + 1      3       0.414634146341*i + 2.26829268293]

        ,


        [1  i                 0                ]
        [                                      ]
        [0  1  0.19512195122*i + 0.243902439024]
        [                                      ]
        [0  0                 1                ]

        ,

        [3,2,3]}

mat6;


[i + 1  i + 2  i + 3]
[                   ]
[  4      5      2  ]
[                   ]
[  1      i      0  ]


tmp := first lu1 * second lu1;


       [  1      i       0   ]
       [                     ]
tmp := [  4      5      2.0  ]
       [                     ]
       [i + 1  i + 2  i + 3.0]


tmp1 := convert(mat6,third lu1);


        [  1      i      0  ]
        [                   ]
tmp1 := [  4      5      2  ]
        [                   ]
        [i + 1  i + 2  i + 3]


tmp - tmp1;


[0  0  0]
[       ]
[0  0  0]
[       ]
[0  0  0]



mat9inv := pseudo_inverse(mat9);


           [ - 0.199999999996      0.100000000013   ]
           [                                        ]
           [ - 0.0499999999988    0.0500000000037   ]
mat9inv := [                                        ]
           [ 0.0999999999982     - 5.57819762603e-12]
           [                                        ]
           [  0.249999999995      - 0.0500000000148 ]


mat9 * mat9inv;


[ 0.999999999982    - 0.000000000055781934627]
[                                            ]
[5.5411231159e-12        1.00000000002       ]



simplex(min,2*x1+14*x2+36*x3,{-2*x1+x2+4*x3>=5,-x1-2*x2-3*x3<=2});


{45.0,{x1=0,x2=0,x3=1.25}}


simplex(max,10000 x1 + 1000 x2 + 100 x3 + 10 x4 + x5,{ x1 <= 1, 20 x1 +
 x2 <= 100, 200 x1 + 20 x2 + x3 <= 10000, 2000 x1 + 200 x2 + 20 x3 + x4
 <= 1000000, 20000 x1 + 2000 x2 + 200 x3 + 20 x4 + x5 <= 100000000});


{100000000,{x1=0,x2=0,x3=0,x4=0,x5=100000000.0}}


simplex(max, 5 x1 + 4 x2 + 3 x3,
           { 2 x1 + 3 x2 + x3 <= 5, 
             4 x1 + x2 + 2 x3 <= 11, 
             3 x1 + 4 x2 + 2 x3 <= 8 });


{13.0,{x1=2.0,x2=0,x3=1.0}}


simplex(min,3 x1 + 5 x2,{ x1 + 2 x2 >= 2, 22 x1 + x2 >= 3});


{5.04651162791,{x1=0.093023255813953,x2=0.95348837209302}}


simplex(max,10x+5y+5.5z,{5x+3z<=200,0.2x+0.1y+0.5z<=12,0.1x+0.2y+0.3z<=9,
                         30x+10y+50z<=1500});


{525.0,{x=40.0,y=25.0,z=0}}


%example of extra variables (>=0) being added.
simplex(min,x-y,{x>=-3});

*** Warning: variable y not defined in input. Has been defined as >=0.

***** Error in simplex: The problem is unbounded. 


% unfeasible as simplex algorithm implies all x>=0.
simplex(min,x,{x<=-100});


***** Error in simplex: Problem has no feasible solution. 


% three error examples.
simplex(maxx,x,{x>=5});


***** Error in simplex(first argument): must be either max or min. 

simplex(max,x,x>=5);


***** Error in simplex(third argument}: must be a list. 

simplex(max,x,{x<=y});


***** Error in simplex: The problem is unbounded. 


simplex(max, 346 X11 + 346 X12 + 248 X21 + 248 X22 + 399 X31 + 399 X32 + 
             200 Y11 + 200 Y12 + 75 Y21 + 75 Y22 + 2.35 Z1 + 3.5 Z2,
{ 
 4 X11 + 4 X12 + 2 X21 + 2 X22 + X31 + X32 + 250 Y11 + 250 Y12 + 125 Y21 + 
  125 Y22 <= 25000,
 X11 + X12 + X21 + X22 + X31 + X32 + 2 Y11 + 2 Y12 + Y21 + Y22 <= 300,
 20 X11 + 15 X12 + 30 Y11 + 20 Y21 + Z1 <= 1500,
 40 X12 + 35 X22 + 50 X32 + 15 Y12 + 10 Y22 + Z2  = 5000,
 X31  = 0,
 Y11 + Y12 <= 50,
 Y21 + Y22 <= 100
});


{99250.0,

 {y21=0,

  y22=0,

  x31=0,

  x11=75.0,

  z1=0,

  x21=225.0,

  z2=5000.0,

  x32=0,

  x22=0,

  x12=0,

  y12=0,

  y11=0}}



% from Marc van Dongen. Finding the first feasible solution for the 
% solution of systems of linear diophantine inequalities.
simplex(max,0,{
  3*X259+4*X261+3*X262+2*X263+X269+2*X270+3*X271+4*X272+5*X273+X229=2,
  7*X259+11*X261+8*X262+5*X263+3*X269+6*X270+9*X271+12*X272+15*X273+X229=4,
  2*X259+5*X261+4*X262+3*X263+3*X268+4*X269+5*X270+6*X271+7*X272+8*X273=1,
  X262+2*X263+5*X268+4*X269+3*X270+2*X271+X272+2*X229=1,
  X259+X262+2*X263+4*X268+3*X269+2*X270+X271-X273+3*X229=2,
  X259+2*X261+2*X262+2*X263+3*X268+3*X269+3*X270+3*X271+3*X272+3*X273+X229=1,
  X259+X261+X262+X263+X268+X269+X270+X271+X272+X273+X229=1});


{0,

 {x229=0.5,

  x259=0.5,

  x261=0,

  x262=0,

  x263=0,

  x268=0,

  x269=0,

  x270=0,

  x271=0,

  x272=0,

  x273=0}}


svd_ans := svd(mat8);


svd_ans := {

            [ 0.289784137735    0.957092029805]
            [                                 ]
            [ - 0.957092029805  0.289784137735]

            ,


            [5.1491628629       0      ]
            [                          ]
            [     0        2.9130948854]

            ,


            [ - 0.687215403194   0.726453707825  ]
            [                                    ]
            [ - 0.726453707825   - 0.687215403194]

            }

tmp := tp first svd_ans * second svd_ans * third svd_ans;


       [ 0.99999998509    2.9999999859 ]
tmp := [                               ]
       [ - 4.00000004924  2.99999995342]


tmp - mat8;


[ - 0.0000000149095977786   - 0.0000000141042777457]
[                                                  ]
[ - 0.0000000492430656251   - 0.000000046583274127 ]



mat9inv := pseudo_inverse(mat9);


           [ - 0.199999999996      0.100000000013   ]
           [                                        ]
           [ - 0.0499999999988    0.0500000000037   ]
mat9inv := [                                        ]
           [ 0.0999999999982     - 5.57819762603e-12]
           [                                        ]
           [  0.249999999995      - 0.0500000000148 ]


mat9 * mat9inv;


[ 0.999999999982    - 0.000000000055781934627]
[                                            ]
[5.5411231159e-12        1.00000000002       ]



% triang_adjoint(in_mat) calculates the
% triangularizing adjoint of in_mat

triang_adjoint(mat1);


[1   0  0   0  0]
[               ]
[-2  1  0   0  0]
[               ]
[-1  2  -1  0  0]
[               ]
[0   0  0   0  0]
[               ]
[0   0  0   0  0]


triang_adjoint(mat2);


[1   0  0  0]
[           ]
[-2  1  0  0]
[           ]
[0   0  0  0]
[           ]
[0   0  0  0]


triang_adjoint(mat5);


[1    0   0   0]
[              ]
[-1   1   0   0]
[              ]
[-3   3   0   0]
[              ]
[10  -12  -4  6]


triang_adjoint(mat6);


[   1       0      0  ]
[                     ]
[  -4     i + 1    0  ]
[                     ]
[4*i - 5    3    i - 3]


triang_adjoint(mat7);


[1    0    0]
[           ]
[-1   1    0]
[           ]
[1    - 1  2]


triang_adjoint(mat8);


[1  0]
[    ]
[4  1]


triang_adjoint(mat9);


***** Error in triang_adjoint: input matrix should be square. 


% testing triang_adjoint with random matrices

% the range of the integers is in one case from
% -1000 to 1000. in the other case it is from
% -1 to 1 so that the deteminant of the i-th
% submatrix equals very often to zero.

% random matrix contains arbitrary real values
off only_integer;


tmp:=random_matrix(5,5,1000);


tmp := mat(( - 558.996086656*i + 1.71931812953,76.9987188735*i + 1.19004104683,

             - 739.283479439*i - 1.32534106204,742.101952123*i + 1.35926854848,

            680.515777254*i + 1.56403177895),

           ( - 689.196170962*i + 1.49289170118,

             - 232.584493916*i - 1.38227180395,280.109305836*i + 1.38865247861,

            298.151479065*i - 1.19035182389, - 602.312143386*i - 1.82183796879),

           ( - 739.195910955*i - 1.45944960213,859.293884826*i + 1.70488070379,

            359.856032683*i - 1.2966991869, - 105.409833087*i - 1.9360631701,

            234.350529301*i - 1.15598520849),

           (155.629059348*i + 1.09264385739, - 16.1559469072*i - 1.9425176505,

            725.11578405*i - 1.05760723025,783.020942195*i - 1.28625265346,

             - 544.129360355*i + 1.74790906085),

           (373.562370318*i - 1.95218354686, - 722.109349973*i + 1.56309793677,

             - 746.664959169*i - 1.9915755693,186.154794517*i - 1.09842189916,

            435.90998986*i - 1.46175649496))


triang_adjoint tmp;


mat((1,0,0,0,0),

    (689.196170962*i - 1.49289170118, - 558.996086656*i + 1.71931812953,0,0,0),

    ( - 1253.37955588*i + 7.64148089854e+5, - 1516.42713845*i - 4.23429448803e+5

     ,1078.01877642*i - 1.830851973e+5,0,0),

      102791325687.0*i + 7.3752778526e+8
    (------------------------------------,
              i - 169.834887206

       - 3.66748178757e+10*i - 6.62162769101e+6
     -------------------------------------------,
                  i - 169.834887206

     9.85957444629e+7*i - 1.01033337718e+6,

      - 7.49414742893e+8*i - 2.25311577415e+6,0),

       - 547052849318.0*i + 4.06181988045e+13
    (-----------------------------------------,
                 i - 112.974983172

       - 141265342333.0*i + 4.13350560163e+12
     -----------------------------------------,
                 i - 112.974983172

      845804392649.0*i - 9.62488227345e+13
     --------------------------------------,
               i - 112.974983172

      876106032577.0*i - 2.66464796763e+13
     --------------------------------------,
               i - 112.974983172

      1.47617976407e+12*i - 1.66771384004e+14
     -----------------------------------------))
                 i - 169.834887206



tmp:=random_matrix(1,1,1000);


tmp := [ - 463.860434427*i + 1.35500571348]


triang_adjoint tmp;


[1]



% random matrix contains complex real values
on imaginary;


tmp:=random_matrix(5,5,1000);


tmp := mat((107.345792105*i - 1.98704739339,188.868545358*i + 1.22417796742,

             - 630.485915434*i + 1.32195292724,

             - 542.510039297*i - 1.94318764036,359.860945563*i - 1.69174206177),

           ( - 469.501213476*i - 1.17375946319, - 62.2197820375*i - 1.4051578261

            , - 98.6604380996*i + 1.64691610034,

             - 216.296595937*i + 1.56809020199,797.19877393*i - 1.31894550853),

           (2.07054207792*i + 1.3891068942,393.038868455*i - 1.60894498437,

             - 215.390393738*i - 1.00068640594,

             - 195.674928032*i + 1.22123114986,211.921323796*i - 1.42499533273),

           ( - 750.357435524*i - 1.19871674827,

             - 792.333836712*i - 1.63151974094, - 494.87049225*i + 1.99554801527

            ,638.173945822*i + 1.23793954612,111.418959978*i - 1.96273029328),

           ( - 255.359922267*i + 1.99035939892,

             - 575.376389757*i - 1.03533681609,463.961589382*i - 1.86476410547,

            83.8856338571*i + 1.10369785887, - 129.597812786*i - 1.4917934624))


triang_adjoint tmp;


mat((1,0,0,0,0),

    (469.501213476*i + 1.17375946319,107.345792105*i - 1.98704739339,0,0,0),

    (383.407897912*i + 1.84407237435e+5,1218.59364331*i + 41798.5118562,

     769.235159465*i - 81990.7504399,0,0),

       - 1.411092405e+10*i - 1.91497165215e+8
    (-----------------------------------------,
                 i - 106.587367245

       - 2.06157034475e+10*i + 1.09218575639e+8
     -------------------------------------------,
                  i - 106.587367245

      - 2.4008888901e+8*i + 13175.2571592,

      - 1.02728261373e+8*i + 9.22309484944e+5,0),

       - 203213290519.0*i - 3.07405185302e+12
    (-----------------------------------------,
                 i - 184.764270765

      311149245317.0*i + 2.05618234856e+13
     --------------------------------------,
               i - 184.764270765

      212889617996.0*i - 4.13210409411e+13
     --------------------------------------,
               i - 184.764270765

       - 7.79955805661e+10*i - 5.10418442965e+12
     --------------------------------------------,
                  i - 184.764270765

      7.62835257557e+10*i - 1.40944700076e+13
     -----------------------------------------))
                 i - 106.587367245



tmp:=random_matrix(1,1,1000);


tmp := [276.278111177*i + 1.74724262616]


triang_adjoint tmp;


[1]


off imaginary;



% random matrix contains rounded real values
on rounded;


tmp:=random_matrix(5,5,1000);


tmp := mat(( - 293.224093687, - 99.023221037, - 819.400851656,796.020234589,

            593.862087611),

           ( - 137.84203019,354.3234619, - 852.314261681, - 217.485901759,

            256.139775139),

           (324.37828726, - 56.5718498235, - 118.293003834,108.279501424,

            23.2385400299),

           ( - 976.556156754,684.207160793,146.328625386,502.848132905,

            312.766816689),

           (211.783458501,166.556239469,175.715904944,251.57997022,280.123720131

            ))


triang_adjoint tmp;


mat((1,0,0,0,0),

    (137.84203019, - 293.224093687,0,0,0),

    ( - 1.07136859076e+5, - 48709.2122316, - 1.17545737812e+5,0,0),

    (1.27980020917e+8, - 1.64635380167e+8,4.76863677307e+8,1.43208428244e+8,0),

    (5.82963241185e+10,3.9383738062e+10, - 437637051137.0, - 111757830528.0,

     261327212376.0))



tmp:=random_matrix(1,1,1000);


tmp := [406.584701921]


triang_adjoint tmp;


[1]


off rounded;



% random matrix contains only integer values
on only_integer;


tmp:=random_matrix(7,7,1000);


       [969   210    8    244   -887  -39   -916]
       [                                        ]
       [-774  296   -475  -694  -909  560    89 ]
       [                                        ]
       [-390  -559  -551  -567  241   -306  -655]
       [                                        ]
tmp := [-478  809   181   -987  -144  929   -886]
       [                                        ]
       [188   267   -778  660   374   590    30 ]
       [                                        ]
       [ 73   971   -946  -43   -215  386   -365]
       [                                        ]
       [-792  -852  558   -797  343   219   110 ]


triang_adjoint tmp;


mat((1,0,0,0,0,0,0),

    (774,969,0,0,0,0,0),

    (548106,459771,449364,0,0,0,0),

    (-108937808,399369604,-497500435,-461605941,0,0,0),

    (-386678984240,-1001551613816,454549593485,637690866447,433944480084,0,0),

    (-604165739229705,-320961967400919,-165015285307395,-1008712187269380,

     -1670995725485274,1433408878792557,0),

    (-181830640557070260,295390292387079435,816541226477288004,

     850494616785589377,458176543109779557,-1709784109660828152,

     -1475366833406131953))



tmp:=random_matrix(7,7,1);


       [0  0  0  0  0  0  0]
       [                   ]
       [0  0  0  0  0  0  0]
       [                   ]
       [0  0  0  0  0  0  0]
       [                   ]
tmp := [0  0  0  0  0  0  0]
       [                   ]
       [0  0  0  0  0  0  0]
       [                   ]
       [0  0  0  0  0  0  0]
       [                   ]
       [0  0  0  0  0  0  0]


triang_adjoint tmp;


[1  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]
[                   ]
[0  0  0  0  0  0  0]



% random matrix contains only complex integer
% values

on imaginary;


tmp:=random_matrix(5,5,1000);


tmp := mat((12*(38*i + 83),3*(153*i - 305),2*(141*i + 427), - 553*i + 617,

            3*(83*i + 157)),

           (164*i - 635, - 133*i + 991, - 373*i + 210,965*i - 608,2*(358*i - 55)

            ),

           ( - 230*i + 227,32*i + 339,2*(485*i - 219),707*i - 767, - 985*i - 51)

            ,

           ( - 609*i + 647, - 441*i + 187,930*i - 349,250*i - 211,274*i - 451),

           ( - 374*i - 135,793*i + 592, - 81*i - 1,89*i + 26,3*( - 40*i + 201)))


triang_adjoint tmp;


mat((1,0,0,0,0),

    ( - 164*i + 635,12*(38*i + 83),0,0,0),

    (293397*i - 414880,9*(14243*i - 47243),3*(253651*i + 180645),0,0),

       - 253324472288717*i + 71265413812547
    (---------------------------------------,
                253651*i + 180645

      2*( - 220885726602145*i - 1441709355714)
     ------------------------------------------, - 1436348339*i + 1393250309,
                 253651*i + 180645

     511458435*i - 1454012933,0),

      13983048003979950612955437881*i - 71498490838832832842693585028
    (-----------------------------------------------------------------,
                  65634686423804933*i - 9174596297286164

      89295323223054915316808489269*i - 37624299403809895760446255007
     -----------------------------------------------------------------,
                  65634686423804933*i - 9174596297286164

      2*( - 71881165390656818494884812727*i - 25318671134083617432051412624)
     ------------------------------------------------------------------------,
                      65634686423804933*i - 9174596297286164

      134577377248105484011524135103*i + 3495516738012600790097438251
     -----------------------------------------------------------------,
                  65634686423804933*i - 9174596297286164

      6*(65634686423804933*i - 9174596297286164)
     --------------------------------------------))
                  253651*i + 180645



tmp:=random_matrix(5,5,2);


       [i - 1   i      i       0       - (i + 1)]
       [                                        ]
       [  0     i     -1     - i + 1    i + 1   ]
       [                                        ]
tmp := [ -1     0      0     - i + 1      -1    ]
       [                                        ]
       [ -1     - i   - i      - i      i + 1   ]
       [                                        ]
       [i - 1   0    i + 1     -1         0     ]


triang_adjoint tmp;


[      1             0             0             0             0     ]
[                                                                    ]
[      0           i - 1           0             0             0     ]
[                                                                    ]
[  - (i + 1)       i + 1                                             ]
[------------     -------      - (i + 1)         0             0     ]
[   i - 1          i - 1                                             ]
[                                                                    ]
[  - (i + 1)                  2*(2*i + 1)       - 2*i                ]
[------------        0       -------------    --------         0     ]
[     i                          i - 1         i - 1                 ]
[                                                                    ]
[ 2*(3*i - 4)    2*(i + 2)    5*(3*i + 1)     - 7*i + 1    2*(i + 2) ]
[-------------  -----------  -------------  ------------  -----------]
[   4*i + 3        i - 1        4*i + 3       4*i + 3        i - 1   ]



% Predicates.

matrixp(mat1);


t

matrixp(poly);



squarep(mat2);


t

squarep(mat3);



symmetricp(mat1);


t

symmetricp(mat3);



if not rounded_was_on then off rounded;




END;


Time for test: 78 ms
@@@@@ Resources used: (0 1 57 9)
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/simplex.red0000644000175000017500000006367011526203062024143 0ustar  giovannigiovannimodule simplex;

% added a patch by Thomas Sturm and Andreas Dolzmann for Simplex1
% WN 21-Oct-1999
%**********************************************************************%
%                                                                      %
% Computation of the optimal value of an objective function given a    %
% number of linear inequalities using the SIMPLEX algorithm.           %
%                                                                      %
% Author: Matt Rebbeck, June 1994.                                     %
%                                                                      %
% Many of the ideas were taken from "Linear Programming" by            %
%                                                 M.J.Best & K. Ritter %
%                                                                      %
% Minor changes: Herbert Melenk, Jan 1995                              %
%                                                                      %
%   replacing first, second etc. by car, cadr                          %
%   converted big smacros to ordinary procedures                       %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


if not get('leq,'simpfn) then
<<
   algebraic operator <=;
   algebraic operator >=;
>>;

symbolic smacro procedure smplx_prepsq u;
  %
  % If u in (!*sq) standard quotient form then get !:rd!: part.
  %
  if atom u then u
  else if car u = 'minus and atom cadr u then u
  else if car u = 'minus and caadr u = '!*sq then {'minus,car cadadr u}
  else if car u = 'minus and caadr u = '!:rd!: then u
  else if car u = '!:rd!: then u
  else if car u = '!*sq then prepsq cadr u;



symbolic smacro procedure fast_row_dim(in_mat);
  %
  % Finds row dimension of a matrix with no error checking.
  %
  length in_mat #- 1;



symbolic smacro procedure fast_column_dim(in_mat);
  %
  % Finds column dimension of a matrix with no error checking.
  %
  length cadr in_mat;



symbolic smacro procedure fast_stack_rows(in_mat,row_list);
  %
  % row_list is always an integer in simplex.
  %
  'mat.{nth(cdr in_mat,row_list)};




symbolic smacro procedure fast_getmat(matri,i,j);
  %
  % Get matrix element (i,j).
  %
  fast_unchecked_getmatelem list(matri,i,j);



symbolic smacro procedure fast_my_letmtr(u,v,y);
  rplaca(pnth(nth(cdr y,car my_revlis cdr u),cadr my_revlis cdr u),v);



put('simplex,'psopfn,'simplex1);

symbolic procedure simplex1(input);
  %
  % The simplex problem is:
  %
  % min {c'x | Ax = b, x>=0},
  %
  % where Ax = b describes the linear equations and c is the function
  % that is to be optimised.
  %
  % This code implements the basic phaseI-phaseII revised simplex
  % algorithm. (phaseI checks for feasibility and phaseII finds the
  % optimal solution).
  %
  % A general idea of tha algorithm is as follows:
  %
  % 1: create phase 1 data.
  %
  %    Add slack and artificial variables to equations to create matrix
  %    A1. The initial basis (ib) consists of the numbers of the columns
  %    relating to the artificial variables. The basic feasible solution
  %    (xb) (if one exists) is  B^(-1)*b where b is the r.h.s. of the
  %    equations. Throughout, cb denotes the columns of the objective
  %    matrix corresponding to ib.
  %    This data goes to the revised simplex algorithm(2).
  %
  % 2: revised simplex:
  %
  %    step 1: Computation of search direction sb.
  %
  %    Compute u = -(B^(-1))'*cb, the smallest index k, and vk s.t.
  %
  %               vk = min{c(i) + A(i)'u | i not elt of ib}.
  %
  %    If vk>=0, stop with optimal solution xb = B^(-1)*b.
  %    If vk<0, set sb = B^(-1)*A(k) and go to step 2.
  %
  %    step 2: Computation of maximum feasible step size Ob.
  %
  %    If sb<=0 then rederr "Problem unbounded from below".
  %    If (sb)(i) >0 for at least one i, compute Ob and the smallest
  %      index l s.t.
  %
  %              (xb)(l)       { (xb)(i) |                      }
  %         Ob = ------- = min { ------  | all i with (sb)(i)>0 },
  %              (sb)(l)       { (sb)(i) |                      }
  %
  %    and go to step 3.
  %
  %    step3: Update.
  %
  %    Replace B^(-1) with [phiprm((B^(-1)',A(k),l)]', xb with B^(-1)*b
  %    and the l'th elt in ib with k. Compute cb'xb and go to step 1.
  %
  % 3: If we get this far (ie: we are feasible) then apply revised
  %    simplex to A (equations with slacks added), and the new xb,
  %    Binv, and ib.
  %
  %
  % Further details and far more advanced algorithms can be found
  % in almost any linear programming book. The above was adapted from
  % "Linear Programming"  M.J.Best and K. Ritter. To date, the code
  % contains no anti_cycling algorithm.
  %
  begin
    scalar max_or_min,objective,equation_list,tmp,A,b,obj_mat,X,A1,
           phase1_obj,ib,xb,Binv,simp_calc,phase1_obj_value,big,sum,
           stop,work,I_turned_rounded_on,ans_list,optimal_value;
    integer m,n,k,i,ell,no_coeffs,no_variables,equation_variables;
    max_or_min := reval car input;
    objective := reval cadr input;
    equation_list := normalize!-equationl reval caddr input;  % <--- patch
    if not !*rounded then << I_turned_rounded_on := t; on rounded; >>;

    if (max_or_min neq 'max) and (max_or_min neq 'min) then rederr
     "Error in simplex(first argument): must be either max or min.";

    if pairp equation_list and car equation_list = 'list then
     equation_list := cdr equation_list
     else rederr "Error in simplex(third argument}: must be a list.";

    % get rid of any two (or more) equal equations! Probably makes
    % things faster in general.
    tmp := unique_equation_list(equation_list);
    equation_list := car tmp;
    equation_variables := cadr tmp;

    % If r.h.s. and l.h.s. of inequalities are both <0 then multiply
    % by -1.
    equation_list := make_equations_positive(equation_list);

    % If there are variables in the objective function that are not in
    % the equation_list then add these variables to the equation list.
    % (They are added as variable>=0).
    equation_list :=
     add_not_defined_variables(objective,equation_list,
                               equation_variables);

    tmp := initialise(max_or_min,objective,equation_list);
    A := car tmp;
    b := cadr tmp;
    obj_mat := caddr tmp;
    X := cadddr tmp;
    % no_variables is the number of variables in the input equation
    % list. this is used in make_answer_list.
    no_variables := car cddddr tmp;

    % r.h.s. (i.e. b matrix) must be positive.
    tmp := check_minus_b(A,b);
    A := car tmp;
    b := cadr tmp;

    m := fast_row_dim(A);
    n := no_coeffs := fast_column_dim(A);

    tmp := create_phase1_A1_and_obj_and_ib(A);
    A1 := car tmp;
    phase1_obj := cadr tmp;
    ib := caddr tmp;
    xb := copy_mat(b);
    Binv := fast_make_identity(fast_row_dim(A));
    % Phase 1 data is now ready to go...

    simp_calc := simplex_calculation(phase1_obj,A1,b,ib,Binv,xb);

    phase1_obj_value := car simp_calc;
    xb := cadr simp_calc;
    Binv := cadddr(simp_calc);
    if get_num_part(phase1_obj_value) neq 0
     then rederr "Error in simplex: Problem has no feasible solution.";

    % Are any artificials still basic?
    for ell:=1:m do if nth(ib,ell) <= n then <<>>
    else
    <<
      % so here, an artificial is basic in row ell.
      big := -1;
      k := 0;
      stop := nil;
      i := 1;
      while i<=n and not stop do
      <<
        sum := get_num_part(smplx_prepsq(fast_getmat(reval
                {'times,fast_stack_rows(Binv,ell),
                 fast_augment_columns(A,i)},1,1)));
        if abs(sum) leq big then stop := t
        else
        <<
          big := abs(sum);
          k := i;
        >>;
        i := i+1;
      >>;
      if big geq 0 then <<>>
      else rederr {"Error in simplex: constraint",k," is redundant."};
      work := fast_augment_columns(A,k);
      Binv := phiprm(Binv,work,ell);
      nth(ib,ell) := k;
    >>;

    % Into Phase 2.
    simp_calc := simplex_calculation(obj_mat,A,b,ib,Binv,xb);
    optimal_value := car simp_calc;
    xb := cadr simp_calc;
    ib := caddr simp_calc;
    ans_list := make_answer_list(xb,ib,no_coeffs,X,no_variables);
    if I_turned_rounded_on then off rounded;
    if max_or_min = 'max then
     optimal_value := my_reval{'minus,optimal_value};
    return {'list,optimal_value,'list.ans_list};
  end;

flag('(simplex1),'opfn);

procedure normalize!-equationl(eql);
  if eqcar(eql , 'list) then
   'list . for each equ in cdr eql collect normalize!-equation equ
  else eql;

procedure normalize!-equation(equ);
   begin scalar lhs,b;
      lhs := numr subtrsq(simp cadr equ,simp caddr equ);
      b := negf abssummand lhs;
      return {car equ,prepf addf(lhs,b),prepf b}
   end;

procedure abssummand(f);
   if domainp f then f else if red f then abssummand red f;

symbolic procedure unique_equation_list(equation_list);
  %
  % Removes repititions in input. Also returns coeffecients in equation
  % list.
  %
  begin
    scalar unique_equation_list,coeff_list;
    for each equation in equation_list do
    <<
      if not intersection({equation},unique_equation_list) then
      <<
        unique_equation_list := append(unique_equation_list,{equation});
        coeff_list := union(coeff_list,get_coeffs(cadr equation));
      >>;
    >>;
    return {unique_equation_list,coeff_list};
  end;



symbolic procedure make_equations_positive(equation_list);
  %
  % If r.h.s. and l.h.s. of inequality are <0 then mult. both sides by
  % -1.
  %
  for each equation in equation_list collect
   if pairp cadr equation and caadr equation = 'minus and
      pairp caddr equation and caaddr equation = 'minus
    then {car equation,my_minus(cadr equation),my_minus(caddr equation)}
     else equation;



symbolic procedure add_not_defined_variables
                    (objective,equation_list,equation_variables);
  %
  % If variables in the objective have not been defined in the
  % inequalities(equation_list) then add them. They are added as
  % variable >= 0.
  %
  begin
    scalar obj_variables;
    obj_variables := get_coeffs(objective);
    if length obj_variables = length equation_variables then
     return equation_list;
    for each variable in obj_variables do
    <<
      if not intersection({variable},equation_variables) then
      <<
        prin2
         "*** Warning: variable ";
        prin2 variable;
        prin2t " not defined in input. Has been defined as >=0.";
       equation_list := append(equation_list,{{'geq,variable,0}});
      >>;
    >>;
    return equation_list;
  end;



symbolic procedure initialise(max_or_min,objective,equation_list);
  %
  % Creates A (with slack variables included), b (r.h.s. of equations),
  % the objective matrix (obj_mat) and X s.t. AX=b and
  % obj_mat * X = objective function.
  % Also returns the number of equations in the equation_list so we know
  % where to stop making answers in make_answer_list.
  %
  begin
    scalar more_init,A,b,obj_mat,X;
    integer no_variables;
    if max_or_min = 'max then
     objective := reval{'times,objective,-1};
    more_init := more_initialise(objective,equation_list);
    A := car more_init;
    b := cadr more_init;
    obj_mat := caddr more_init;
    X := cadddr more_init;
    no_variables := car cddddr more_init;
    return {A,b,obj_mat,X,no_variables};
  end;



symbolic procedure more_initialise(objective,equation_list);
  begin
    scalar objective,equation_list,non_slack_variable_list,obj_mat,
           no_of_non_slacks,tmp,variable_list,slack_equations,A,b,X;
    non_slack_variable_list :=
     get_preliminary_variable_list(equation_list);
    no_of_non_slacks := length non_slack_variable_list;
    tmp := add_slacks_to_equations(equation_list);
    slack_equations := car tmp;
    b := cadr tmp;
    variable_list := union(non_slack_variable_list,caddr tmp);
    tmp := get_X_and_obj_mat(objective,variable_list);
    X := car tmp;
    obj_mat := cadr tmp;
    A := simp_get_A(slack_equations,variable_list);
    return {A,b,obj_mat,X,no_of_non_slacks};
  end;



symbolic procedure check_minus_b(A,b);
  %
  % The algorithm requires the r.h.s. (i.e. the b matrix) to contain
  % only positive entries.
  %
  begin
    for i:=1:row_dim(b) do
    <<
      if get_num_part( reval getmat(b,i,1) ) < 0 then
      <<
        b := mult_rows(b,i,-1);
        A := mult_rows(A,i,-1);
      >>;
    >>;
    return {A,b};
  end;



symbolic procedure create_phase1_A1_and_obj_and_ib(A);
  begin
    scalar phase1_obj,A1,ib;
    integer column_dim_A1,column_dim_A,row_dim_A1,i;
    column_dim_A := fast_column_dim(A);
    % Add artificials to A.
    A1 := fast_matrix_augment({A,fast_make_identity(fast_row_dim(A))});
    column_dim_A1 := fast_column_dim(A1);
    row_dim_A1 := fast_row_dim(A1);
    phase1_obj := mkmatrix(1,fast_column_dim(A1));
    for i:=column_dim_A+1:fast_column_dim(A1) do
     fast_setmat(phase1_obj,1,i,1);
    ib := for i:=column_dim_A+1:fast_column_dim(A1) collect i;
    return {A1,phase1_obj,ib};
  end;



symbolic procedure simplex_calculation(obj_mat,A,b,ib,Binv,xb);
  %
  % Applies the revised simplex algorithm. See above for details.
  %
  begin
    scalar rs1,sb,rs2,rs3,u,continue,obj_value;
    integer k,iter,ell;
    obj_value := compute_objective(get_cb(obj_mat,ib),xb);
    while continue neq 'optimal do
    <<
      rs1 := rstep1(A,obj_mat,Binv,ib);
      sb := car rs1;
      k := cadr rs1;
      u := caddr rs1;
      continue := cadddr rs1;
      if continue neq 'optimal then
      <<
        rs2 := rstep2(xb,sb);
        ell := cadr rs2;
        rs3 := rstep3(xb,obj_mat,b,Binv,A,ib,k,ell);
        iter := iter + 1;
        Binv := car rs3;
        obj_value := cadr rs3;
        xb := caddr rs3;
      >>;
    >>;
    return {obj_value,xb,ib,Binv};
  end;



symbolic procedure get_preliminary_variable_list(equation_list);
  %
  % Gets all variables before slack variables are added.
  %
  begin
    scalar variable_list;
    for each equation in equation_list do
     variable_list := union(variable_list,get_coeffs(cadr equation));
    return variable_list;
  end;



symbolic procedure add_slacks_to_equations(equation_list);
  %
  % Takes list of equations (=, <=, >=) and adds required slack
  % variables. Also returns all the rhs integers in a column matrix,
  % and a list of the added slack variables.
  %
  begin
    scalar slack_list,rhs_mat,slack_variable,slack_variable_list;
    integer i,row;
    rhs_mat := mkmatrix(length equation_list,1);
    row := 1;
    for each equation in equation_list do
    <<
      if not numberp reval caddr equation then
      <<
        prin2 "***** Error in simplex(third argument): ";
        rederr "right hand side of each inequality must be a number";
      >>
      else fast_setmat(rhs_mat,row,1,caddr equation);

      row := row+1;

      %
      % Put in slack/surplus variables where required.
      %
      if car equation = 'geq then
      <<
        i := i+1;
        slack_variable := mkid('sl_var,i);
        equation := {'plus,{'minus,mkid('sl_var,i)},cadr equation};
        slack_variable_list := append(slack_variable_list,
                                      {slack_variable});
      >>
      else if car equation = 'leq then
      <<
        i := i+1;
        slack_variable := mkid('sl_var,i);
        equation := {'plus,mkid('sl_var,i),cadr equation};
        slack_variable_list := append(slack_variable_list,
                                      {slack_variable});
      >>
      else if car equation = 'equal then equation := cadr equation
      else
      <<
        prin2 "***** Error in simplex(third argument):";
        rederr "inequalities must contain either >=, <=, or =.";
      >>;

      slack_list := append(slack_list,{equation});
    >>;
    return {slack_list,rhs_mat,slack_variable_list};
  end;

flag('(add_slacks_to_list),'opfn);



symbolic procedure simp_get_A(slack_equations,variable_list);
  %
  % Extracts the A matrix from the slack equations.
  %
  begin
    scalar A,slack_elt,var_elt;
    integer row,col,length_slack_equations,length_variable_list;
    length_slack_equations := length slack_equations;
    length_variable_list := length variable_list;
    A := mkmatrix(length slack_equations,length variable_list);
    for row := 1:length_slack_equations do
    <<
      for col := 1:length_variable_list do
      <<
        slack_elt := nth(slack_equations,row);
        var_elt := nth(variable_list,col);
        fast_setmat(A,row,col,smplx_prepsq(
                               algebraic coeffn(slack_elt,var_elt,1)));
      >>;
    >>;
    return A;
  end;



symbolic procedure get_X_and_obj_mat(objective,variable_list);
  %
  % Converts the variable list into a matrix and creates the objective
  % matrix. This is the matrix s.t. obj_mat * X = objective function.
  %
  begin
    scalar X,obj_mat;
    integer i,length_variable_list,tmp;
    length_variable_list := length variable_list;
    X := mkmatrix(length_variable_list,1);
    obj_mat := mkmatrix(1,length_variable_list);
    for i := 1:length variable_list do
    <<
      fast_setmat(X,i,1,nth(variable_list,i));
      tmp := nth(variable_list,i);
      fast_setmat(obj_mat,1,i,algebraic coeffn(objective,tmp,1));
    >>;
    return {X,obj_mat};
  end;



symbolic procedure get_cb(obj_mat,ib);
  %
  % Gets hold of the columns of the objective matrix that are pointed
  % at in ib.
  %
  fast_augment_columns(obj_mat,ib);



symbolic procedure compute_objective(cb,xb);
  %
  % Objective value := cb * xb (both are matrices)
  %
  fast_getmat(reval {'times,cb,xb},1,1);



symbolic procedure rstep1(A,obj_mat,Binv,ib);
  %
  % Implements step 1 of the revised simplex algorithm.
  % ie: Computation of search direction sb.
  %
  % See above for details. (comments in simplex).
  %
  begin
    scalar u,sb,sum,i_in_ib;
    integer i,j,m,n,k,vkmin;
    m := fast_row_dim(A);
    n := fast_column_dim(A);
    u := mkmatrix(m,1);
    sb := mkmatrix(m,1);
    %  Compute u.
    u := reval {'times,{'minus,algebraic (tp(Binv))},
                algebraic tp(symbolic get_cb(obj_mat,ib))};
    k := 0;
    vkmin := 10^10;
    i := 1;
    for i:=1:n do
    <<
      i_in_ib := nil;
      % Check if i is in ib.
      for j:=1:m do
      <<
        if i = nth(ib,j) then i_in_ib := t;
      >>;
      if not i_in_ib then
      <<
        sum := specrd!:plus(smplx_prepsq(fast_getmat(obj_mat,1,i)),
                two_column_scalar_product(fast_augment_columns(A,i),u));
        % if i is not in ib.
        %sum := fast_getmat(obj_mat,1,i);
        %for p:=1:m do
        %<<
          %sum := reval
          % {'plus,sum,{'times,fast_getmat(A,p,i),fast_getmat(u,p,1)}};
        %>>;
        if get_num_part(sum) geq get_num_part(vkmin) then <<>>
        else
        <<
          vkmin := sum;
          k := i;
        >>;
      >>;
    >>;
    % Do we need a tolerance here?
    if get_num_part(vkmin) < 0 then
    <<
      % Form sb.
      for i:=1:m do
      <<
        sum := 0;
        for j:=1:m do sum := specrd!:plus(sum,
         specrd!:times(fast_getmat(Binv,i,j),fast_getmat(A,j,k)));
        fast_setmat(sb,i,1,sum);
      >>;
      return {sb,k,u,nil};
    >>
    else return {sb,k,u,'optimal};
  end;



symbolic procedure rstep2(xb,sb);
  %
  % step 2: Computation of maximum feasible step size Ob.
  %
  % see above for details. (comments in simplex).
  %
  begin
    scalar ratio;
    integer ell,sigb;
    sigb := 1*10^30;
    for i:=1:fast_row_dim(sb) do
    <<
      if get_num_part(my_reval fast_getmat(sb,i,1)) leq 0 then <<>>
      else
      <<
        ratio := specrd!:quotient(smplx_prepsq(fast_getmat(xb,i,1)),
                                  smplx_prepsq(fast_getmat(sb,i,1)));
        if get_num_part(ratio) geq get_num_part(sigb) then <<>>
        else
        <<
          sigb := ratio;
          ell := i;
        >>;
      >>;
    >>;
    if ell= 0 then
     rederr "Error in simplex: The problem is unbounded.";
    return {sigb,ell};
  end;



symbolic procedure rstep3(xb,obj_mat,b,Binv,A,ib,k,ell);
  %
  % step3: Update.
  %
  % see above for details. (comments in simplex).
  %
  begin
    scalar work,Binv;
    work := fast_augment_columns(A,k);
    Binv := phiprm(Binv,work,ell);
    xb := reval{'times,Binv,b};
    nth(ib,ell) := k;
    obj_mat := compute_objective(get_cb(obj_mat,ib),xb);
    return {Binv,obj_mat,xb};
  end;



symbolic procedure phiprm(Binv,D,ell);
  %
  % Replaces B^(-1) with [phi((B^(-1)',A(k),l)]'.
  %
  begin
    scalar sum,temp;
    integer m,j;
    m := fast_column_dim(Binv);
    sum := scalar_product(fast_stack_rows(Binv,ell),D);
%    if get_num_part(sum) = 0 then
%     rederr
%{"Error in simplex: new matrix would be singular. Inner product = 0."};
    if not zerop get_num_part(sum) then
     sum := specrd!:quotient(1,sum);
    Binv := fast_mult_rows(Binv,ell,sum);
    for j:=1:m do
    <<
      if j = ell then <<>>
      else
      <<
        temp := fast_getmat(reval{'times,fast_stack_rows(Binv,j),D},
                            1,1);
        Binv := fast_add_rows(Binv,ell,j,{'minus,temp});
      >>;
    >>;
    return Binv;
  end;



symbolic procedure make_answer_list(xb,ib,no_coeffs,X,no_variables);
  %
  % Creates a list of the values of the variables at the optimal
  % solution.
  %
  begin
    scalar x_mat,ans_list;
    integer i;
    x_mat := mkmatrix(1,no_coeffs);
    i := 1;
    for each elt in ib do
     <<
       if fast_getmat(xb,i,1) neq 0 then
        fast_setmat(x_mat,1,elt,fast_getmat(xb,i,1)); i := i+1;
     >>;
     ans_list := for i:=1:no_variables collect
                 {'equal,my_reval fast_getmat(X,i,1),
                 get_num_part(my_reval fast_getmat(x_mat,1,i))};
    return ans_list;
  end;



% Speed functions


symbolic procedure fast_add_rows(in_mat,r1,r2,mult1);
  %
  % Replaces row2 (r2) by mult1*r1 + r2 without messing around.
  %
  begin
    scalar new_mat,fast_getmatel;
    integer i,coldim;
    coldim := fast_column_dim(in_mat);
    new_mat := copy_mat(in_mat);
    if (my_reval mult1) = 0 then return new_mat;
    for i:=1:coldim do
    <<
      if not((fast_getmatel :=my_reval fast_getmat(new_mat,r1,i)) = 0)
      then fast_setmat(new_mat,r2,i,specrd!:plus(specrd!:times(
      smplx_prepsq(mult1),smplx_prepsq(fast_getmatel)),smplx_prepsq(
      fast_getmat(in_mat,r2,i))));
    >>;
    return new_mat;
  end;



symbolic procedure fast_augment_columns(in_mat,col_list);
  %
  % Quickly augments columns of in_mat specified in col_list.
  %
  if atom col_list then 'mat.for i:=1:fast_row_dim(in_mat)
                              collect {fast_getmat(in_mat,i,col_list)}
   else 'mat.for each row in cdr in_mat
              collect for each elt in col_list collect nth(row,elt);


symbolic procedure fast_matrix_augment(mat_list);
  %
  % As in linear_algebra package but doesn't produce !*sq output.
  %
  begin
  scalar ll,new_list;
    if length mat_list = 1 then return mat_list
     else
     <<
       new_list := {};
       for i:=1:fast_row_dim(car mat_list) do
       <<
         ll := {};
         for each mat1 in mat_list do ll := append(ll,nth(cdr mat1,i));
         new_list := append(new_list,{ll});
       >>;
       return 'mat.new_list;
     >>;
  end;



symbolic procedure fast_setmat(matri,i,j,val);
  %
  % Set matrix element (i,j) to val.
  %
  fast_my_letmtr(list(matri,i,j),val,matri);



symbolic procedure fast_unchecked_getmatelem u;
  nth(nth(cdr car u,cadr u),caddr u);



symbolic procedure fast_mult_rows(in_mat,row_list,mult1);
  %
  % In simplex row_list is always an integer.
  %
  begin
    scalar new_list,new_row;
    integer row_no;
    row_no := 1;
    for each row in cdr in_mat do
    <<
      if row_no neq row_list then new_list := append(new_list,{row})
      else
      <<
        new_row := for each elt in row collect
                    my_reval{'times,mult1,elt};
        new_list := append(new_list,{new_row});
      >>;
      row_no := row_no+1;
    >>;
    return 'mat.new_list;
  end;



symbolic procedure fast_make_identity(sq_size);
  %
  % Creates identity matrix.
  %
  'mat. (for i:=1:sq_size collect
           for j:=1:sq_size collect if i=j then 1 else 0);



symbolic procedure two_column_scalar_product(col1,col2);
  %
  % Calculates tp(col1)*col2.
  %
  % Uses sparsity efficiently.
  %
  begin
    scalar sum;
    sum := 0;
    for i:=1:length cdr col1 do
    <<
      if car nth(cdr col1,i)=0 or car nth(cdr col2,i)=0 then <<>>
       else
       sum := specrd!:plus(sum,specrd!:times(smplx_prepsq(
                           car nth(cdr col1,i)),smplx_prepsq(
                           car nth(cdr col2,i))));
    >>;
    return sum;
  end;



symbolic procedure scalar_product(row,col);
  %
  % Calculates row*col.
  %
  % Uses sparsity efficiently.
  %
  begin
    scalar sum;
    sum := 0;
    for i:=1:length cadr row do
    <<
      if nth(cadr row,i)=0 or car nth(cdr col,i)=0 then <<>>
       else
       sum := specrd!:plus(sum,
                           specrd!:times(smplx_prepsq(nth(cadr row,i)),
                                     smplx_prepsq(car nth(cdr col,i))));
    >>;
    return sum;
  end;


endmodule;  % simplex.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/linalg.red0000644000175000017500000020271711526203062023725 0ustar  giovannigiovannimodule linalg;   % The Linear Algebra package.

%**********************************************************************%
%                                                                      %
% Author: Matt Rebbeck, March-July 1994 (at ZIB).                      %
% Modifications by: Walter Tietze.
%                                                                      %
% Please report bugs to: Winfried Neun,                                %
%                        Konrad-Zuse-Zentrum                           %
%                           fuer Informationstechnik Berlin            %
%                        Heilbronner Str. 10                           %
%                        10711 Berlin - Wilmersdorf                    %
%                        Federal Republic of Germany                   %
%                                                                      %
%                (email) neun@sc.ZIB-Berlin.de                         %
%                                                                      %
%                                                                      %
%                                                                      %
% This package provides a selection of useful functions in the field   %
% of linear algebra:                                                   %
%                                                                      %
%   add_columns      add_rows       add_to_columns    add_to_rows      %
%   augment_columns  band_matrix    block_matrix      char_matrix      %
%   char_poly        cholesky       coeff_matrix      column_dim       %
%   companion        copy_into      diagonal          extend           %
%   get_columns      get_rows       gram_schmidt      hermitian_tp     %
%   hessian          hilbert        mat_jacobian      jordan_block     %
%   lu_decom         make_identity  matrix_augment    matrixp          %
%   matrix_stack     minor          mult_column       mult_row         %
%   pivot            pseudo_inverse random_matrix     remove_columns   %
%   remove_rows      row_dim        rows_pivot        simplex          %
%   squarep          stack_rows     sub_matrix        svd              %
%   swap_columns     swap_entries   swap_rows         symmetricp       %
%   toeplitz         vandermonde    kronecker_product                  %
%                                                                      %
%                                                                      %
%                                                                      %
% The package implements the following switches:                       %
%                                                                      %
%  imaginary     \                                                     %
%  lower_matrix   \                                                    %
%  not_negative    )  for details see the random_matrix comments.      %
%  only_integer   /                                                    %
%  upper_matrix  /                                                     %
%                                                                      %
%  fast_la  (see below).                                               %
%                                                                      %
%                                                                      %
%                                                                      %
% For further details about the linear algebra package see the         %
% linear_algebra.tex file.                                             %
%                                                                      %
%                                                                      %
%                                                                      %
% NB: The functions in this package are written to be used from the    %
% user level. Some of them may well need a bit of fiddling with to get %
% them to work from symbolic mode.                                     %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load_package matrix;

create!-package('(linalg lamatrix gramschm ludecom cholesky svd
                  simplex tadjoint), '(contrib linalg));

switch fast_la;  % If ON, then the following functions will be faster:

%   add_columns      add_rows         augment_columns  column_dim      %
%   copy_into        make_identity    matrix_augment   matrix_stack    %
%   minor            mult_column      mult_row         pivot           %
%   remove_columns   remove_rows      rows_pivot       squarep         %
%   stack_rows       sub_matrix       swap_columns     swap_entries    %
%   swap_rows        symmetricp                                        %

% This is basically done by removing some error checking and doesn't
% speed things up too much. You'll need to be making alot of calls to
% see the difference. If you get strange error messages with fast_la
% ON then thoroughly check your input.



symbolic smacro procedure my_reval(n);
  %
  % Only revals if it needs to.
  %
  if fixp(n) then n else reval(n);



symbolic procedure swap_elt(in_list,elt1,elt2);
  %
  % Swaps elt elt1 with elt elt2 in in_list.
  %
  % NB: destructive.
  %
  begin
    scalar bucket;
    bucket := nth(in_list,elt1);
    nth(in_list,elt1) := nth(in_list,elt2);
    nth(in_list,elt2) := bucket;
  end;



symbolic procedure row_dim(in_mat);
  %
  % Finds row dimension of a matrix.
  %
  begin
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in row_dim: input should be a matrix.";
    return first size_of_matrix(in_mat);
  end;



symbolic procedure column_dim(in_mat);
  %
  % Finds column dimension of a matrix.
  %
  begin
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in column_dim: input should be a matrix.";
    return second size_of_matrix(in_mat);
  end;

flag('(row_dim,column_dim),'opfn);



symbolic procedure matrixp(A);
  %
  % Tests if input is a matrix (boolean).
  %
  if not eqcar(A,'mat) then nil else t;

flag('(matrixp),'boolean);
flag('(matrixp),'opfn);



symbolic procedure size_of_matrix(A);
  %
  % Takes matrix and returns list {no. of rows, no. of columns}.
  %
  begin
    integer row_dim,column_dim;
    row_dim := -1 + length A;
    column_dim := length cadr A;
    return {row_dim,column_dim};
  end;



symbolic procedure companion(poly,x);
  %
  % Takes as input a monic univariate polynomial in a variable x.
  % Returns a companion matrix associated with the polynomial poly(x).
  %
  % If C := companion(p,x) and p is a0+a1*x+...+x^n (a univariate monic
  % polynomial), them C(i,n) = -coeff(p,x,i-1), C(i,i-1) = 1 (i=2..n)
  % and C(i,j) = 0 for all other i and j.
  %
  begin
    scalar mat1;
    integer n;
    n := deg(poly,x);
    if my_reval coeffn(poly,x,n) neq 1 then msgpri
      ("Error in companion(first argument): Polynomial",
      poly, "is not monic.",nil,t);

    mat1 := mkmatrix(n,n);
    setmat(mat1,1,n,{'minus,coeffn(poly,x,0)});
    for i:=2:n do
    <<
      setmat(mat1,i,i-1,1);
    >>;
    for j:=2:n do
    <<
      setmat(mat1,j,n,{'minus,coeffn(poly,x,j-1)});
    >>;
    return mat1;
  end;



symbolic procedure find_companion(R,x);
  %
  % Given a companion matrix, find_companion will return the associated
  % polynomial.
  %
  begin
    scalar  p;
    integer rowdim,k;
    if not matrixp(R) then rederr
     {"Error in find_companion(first argument): should be a matrix."};
    rowdim := row_dim(R);
    k := 2;
    while k<=rowdim and getmat(R,k,k-1)=1 do k:=k+1;
    p := 0;
    for j:=1:k-1 do
    <<
      p:={'plus,p,{'times,{'minus,getmat(R,j,k-1)},{'expt,x,j-1}}};
    >>;
    p := {'plus,p,{'expt,x,k-1}};
    return p;
  end;

flag('(companion,find_companion),'opfn);



symbolic procedure jordan_block(const,mat_dim);
  %
  % Takes a constant (const) and an integer (mat_dim) and creates
  % a jordan block of dimension mat_dim x mat_dim.
  %
  begin
    scalar JB;
    if not fixp mat_dim then rederr
     "Error in jordan_block(second argument): should be an integer.";
    JB := mkmatrix(mat_dim,mat_dim);
    for i:=1:mat_dim do
    <<
      for j:=1:mat_dim do
      <<
        if i=j then
        <<
          setmat(JB,i,j,const);
          if i>;
      >>;
    >>;
    return JB;
  end;

flag ('(jordan_block),'opfn);



symbolic procedure sub_matrix(A,row_list,col_list);
  %
  % Removes the sub_matrix from A consisting of the rows in row_list and
  % the columns in col_list. (Both row_list and col_list can be single
  % integer values).
  %
  begin
    scalar new_mat;
    if not !*fast_la and not matrixp(A) then rederr
     "Error in sub_matrix(first argument): should be a matrix.";
    new_mat := stack_rows(A,row_list);
    new_mat := augment_columns(new_mat,col_list);
    return new_mat;
  end;

% flag('(sub_matrix),'opfn);

rtypecar sub_matrix;


symbolic procedure copy_into(BB,AA,p,q);
  %
  % Copies matrix BB into AA with BB(1,1) at AA(p,q).
  %
  begin
    scalar A,B;
    integer m,n,r,c;
    if not !*fast_la then
    <<
      if not matrixp(BB) then rederr
       "Error in copy_into(first argument): should be a matrix.";
      if not matrixp(AA) then rederr
       "Error in copy_into(second argument): should be a matrix.";
      if not fixp p then rederr
       "Error in copy_into(third argument): should be an integer.";
      if not fixp q then rederr
       "Error in copy_into(fourth argument): should be an integer.";
      if p = 0 or q = 0 then
      <<
        prin2t
         "***** Error in copy_into: 0 is out of bounds for matrices.";
        prin2t
         "      The top left element is labelled (1,1) and not (0,0).";
        return;
      >>;
    >>;
    m := row_dim(AA);
    n := column_dim(AA);
    r := row_dim(BB);
    c := column_dim(BB);
    if not !*fast_la and (r+p-1>m or c+q-1>n) then
    <<
      % Only print offending matrices if they're not too big.
      if m*n<26 and r*c<26 then
      <<
        prin2t "***** Error in copy_into: the matrix";
        matpri(BB);
        prin2t "      does not fit into";
        matpri(AA);
        prin2  "      at position ";
        prin2 p;
        prin2 ",";
        prin2 q;
        prin2t ".";
        return;
      >>
      else
      <<
        prin2 "***** Error in copy_into: first matrix does not fit ";
        prin2 "      into second matrix at defined position.";
        return;
      >>;
    >>;
    A := mkmatrix(m,n);
    B := mkmatrix(r,c);
    for i:=1:m do
    <<
      for j:=1:n do
      <<
        setmat(A,i,j,getmat(AA,i,j));
      >>;
    >>;
    for i:=1:r do
    <<
      for j:=1:c do
      <<
        setmat(B,i,j,getmat(BB,i,j));
      >>;
    >>;
    for i:=1:r do
    <<
      for j:=1:c do
      <<
        setmat(A,p+i-1,q+j-1,getmat(B,i,j));
      >>;
    >>;
    return A;
  end;

flag ('(copy_into),'opfn);



symbolic procedure copy_mat(u);
   if pairp u then cons (copy_mat car u, copy_mat cdr u) else u;



put('diagonal,'psopfn,'diagonal1); % To allow variable input.
symbolic procedure diagonal1(mat_list);
  %
  % Can take either a list of arguments or the arguments seperately.
  %
  % Takes any number of either scalar entries or square matrices and
  % creates the diagonal.
  %
  begin
    scalar diag_mat;
    if pairp mat_list and pairp car mat_list and caar mat_list = 'list
     then mat_list := cdar mat_list;
    mat_list := for each elt in mat_list collect reval elt;
    for each elt in mat_list do
    <<
      if matrixp(elt) and not squarep(elt) then
      <<
        % Only print offending matrix if it's not too big.
        if row_dim(elt)<5 or column_dim(elt)> 5 then
        <<
          prin2t "***** Error in diagonal: ";
          matpri(elt);
          prin2t "      is not a square matrix.";
          rederr "";
        >>
        else
         rederr "Error in diagonal: input contains non square matrix.";
      >>;
    >>;
    diag_mat := diag({mat_list});
    return diag_mat;
  end;



symbolic procedure diag(uu);
  %
  % Takes square or scalar matrix entries and creates a matrix with
  % these matrices on the diagonal.
  %
  % What a horrible way to do it!
  %
  begin
    scalar bigA,arg,input,u;
    integer nargs,n,Aidx,stp,bigsize,smallsize;

    u := car uu;
    input := u;
    bigsize:=0;

    nargs:=length input;
    for i:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 or eqcar(arg,'quotient)
                 then bigsize:=bigsize+1
      else
      <<
        bigsize:=bigsize+row_dim(arg);
      >>;
      input := cdr input;
    >>;

    bigA := mkmatrix(bigsize,bigsize);
    Aidx:=1;
    input := u;
    for k:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 or eqcar(arg,'quotient) then
      <<
        setmat(bigA,Aidx,Aidx,arg);
        Aidx:=Aidx+1;
        input := cdr input;
      >>
      else
      <<
        smallsize:= row_dim(arg);
        stp:=smallsize+Aidx-1;
        for i:=Aidx:stp do
        <<
          for j:=Aidx:stp do
          <<
            arg:=car input;
            % Find (i-Aidx+1)'th row.
            arg := cdr arg;
            <<
              n:=1;
              while n < (i-Aidx+1) do
              <<
                arg := cdr arg;
                n:=n+1;
              >>;
            >>;
            arg := car arg;
            %
            %  Find (j-Aidx+1)'th column elt of i'th row.
            %
            <<
              n:=1;
              while n < (j-Aidx+1) do
              <<
                arg := cdr arg;
                n:=n+1;
              >>;
            >>;
            arg := car arg;

            setmat(bigA,i,j,arg);
          >>;
        >>;
        Aidx := Aidx+smallsize;
        input := cdr input;
      >>;
    >>;

    return biga;
  end;



symbolic procedure band_matrix(elt_list,sq_size);
  %
  % A square band matrix b is created. The elements of the diagonal
  % are the middle element of elt_list. The elements to the left are
  % used to fill the required number of subdiagonals and the elements
  % to the right the superdiagonals.
  %
  begin
    scalar band_matrix;
    integer i,j,no_elts,middle_pos;
    if not fixp sq_size then rederr
     "Error in band_matrix(second argument): should be an integer.";
    if atom elt_list then elt_list := {elt_list}
     else if car elt_list = 'list then elt_list := cdr elt_list
      else rederr
"Error in band_matrix(first argument): should be single value or list.";
    no_elts := length elt_list;
    if evenp no_elts then rederr
"Error in band matrix(first argument): number of elements must be odd.";
    middle_pos := reval{'quotient,no_elts+1,2};
    if my_reval middle_pos > sq_size then rederr
 "Error in band_matrix: too many elements. Band matrix is overflowing."
     else band_matrix := mkmatrix(sq_size,sq_size);
    for i:=1:sq_size do
    <<
      for j:=1:sq_size do
      <<
        if middle_pos-i+j > 0 and middle_pos-i+j <= no_elts then
        setmat(band_matrix,i,j,nth(elt_list,middle_pos-i+j));
      >>;
    >>;
    return band_matrix;
  end;

flag('(band_matrix),'opfn);



symbolic procedure make_identity(sq_size);
  %
  % Creates identity matrix.
  %
  if not !*fast_la and not fixp sq_size then
   rederr "Error in make_identity: non integer input."
   else 'mat. (for i:=1:sq_size collect
                 for j:=1:sq_size collect if i=j then 1 else 0);

flag('(make_identity),'opfn);



symbolic procedure squarep(in_mat);
  %
  % Tests matrix is square. (boolean).
  %
  begin
    scalar tmp;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in squarep: non matrix input";
    tmp := size_of_matrix(in_mat);
    if first tmp neq second tmp
     then return nil
      else return t;
  end;

flag('(squarep),'boolean);
flag('(squarep),'opfn);



symbolic procedure swap_rows(in_mat,row1,row2);
  %
  % Swaps row1 with rows.
  %
  begin
    scalar new_mat;
    integer rowdim;
    if not !*fast_la then
    <<
      if not matrixp in_mat then
       rederr "Error in swap_rows(first argument): should be a matrix.";
      rowdim := row_dim(in_mat);
      if not fixp row1 then rederr
       "Error in swap_rows(second argument): should be an integer.";
      if not fixp row2 then
     rederr "Error in swap_rows(third argument): should be an integer.";
      if row1>rowdim or row1=0 then rederr
  "Error in swap_rows(second argument): out of range for input matrix.";
      if row2>rowdim or row2=0 then rederr
  "Error in swap_rows(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_mat(in_mat);
    swap_elt(cdr new_mat,row1,row2);
    return new_mat;
  end;



symbolic procedure swap_columns(in_mat,col1,col2);
  %
  % Swaps col1 with col2.
  %
  begin
    scalar new_mat;
    integer coldim;
    if not !*fast_la then
    <<
      if not matrixp in_mat then rederr
       "Error in swap_columns(first argument): should be a matrix.";
      coldim := column_dim(in_mat);
      if not fixp col1 then rederr
       "Error in swap_columns(second argument): should be an integer.";
      if not fixp col2 then rederr
       "Error in swap_columns(third argument): should be an integer.";
      if col1>coldim or col1=0 then rederr
     "Error in swap_columns(second argument): out of range for matrix.";
      if col2>coldim or col2=0 then rederr
"Error in swap_columns(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_mat(in_mat);
    for each row in cdr new_mat do swap_elt(row,col1,col2);
    return new_mat;
  end;



symbolic procedure swap_entries(in_mat,entry1,entry2);
  %
  % Swaps the two entries in in_mat.
  %
  % entry1 and entry2 must be lists of the form
  % {row position,column position}.
  %
  begin
    scalar new_mat;
    integer rowdim,coldim;
    if not matrixp(in_mat) then rederr
     "Error in swap_entries(first argument): should be a matrix.";
    if atom entry1 or car entry1 neq 'list or length cdr entry1 neq 2
     then rederr
"Error in swap_entries(second argument): should be list of 2 elements."
     else entry1 := cdr entry1;
     if atom entry2 or car entry2 neq 'list or length cdr entry2 neq 2
      then rederr
"Error in swap_entries(third argument): should be a list of 2 elements."
      else entry2 := cdr entry2;
    if not !*fast_la then
    <<
      rowdim := row_dim(in_mat);
      coldim := column_dim(in_mat);
      if not fixp car entry1 then
      <<
        prin2  "***** Error in swap_entries(second argument): ";
        prin2t "      first element in list must be an integer.";
        return;
      >>;
      if not fixp cadr entry1 then
      <<
        prin2  "***** Error in swap_entries(second argument): ";
        prin2t "      second element in list must be an integer.";
        return;
      >>;
      if car entry1 > rowdim or car entry1 = 0 then
      <<
        prin2  "***** Error in swap_entries(second argument): ";
        prin2t "      first element is out of range for input matrix.";
      return;
      >>;
      if cadr entry1 > coldim or cadr entry1 = 0 then
      <<
        prin2  "***** Error in swap_entries(second argument): ";
        prin2t "      second element is out of range for input matrix.";
        return;
      >>;
      if not fixp car entry2 then
      <<
        prin2  "***** Error in swap_entries(third argument): ";
        prin2t "      first element in list must be an integer.";
        return;
      >>;
      if not fixp cadr entry2 then
      <<
        prin2  "***** Error in swap_entries(third argument): ";
        prin2t "      second element in list must be an integer.";
        return;
      >>;
      if car entry2 > rowdim or car entry2 = 0 then
      <<
        prin2  "***** Error in swap_entries(third argument): ";
        prin2t "      first element is out of range for input matrix.";
        return;
      >>;
      if cadr entry2 > coldim then
      <<
        prin2  "***** Error in swap_entries(third argument): ";
        prin2t "      second element is out of range for input matrix.";
        return;
      >>;
    >>;
    new_mat := copy_mat(in_mat);
    setmat(new_mat,car entry1,cadr entry1,
            getmat(in_mat,car entry2,cadr entry2));
    setmat(new_mat,car entry2,cadr entry2,
            getmat(in_mat,car entry1,cadr entry1));
  return new_mat;
  end;

% flag('(swap_rows,swap_columns,swap_entries),'opfn);

rtypecar swap_rows,swap_columns,swap_entries;


symbolic procedure get_rows(in_mat,row_list);
  %
  % Input is a matrix and either a single row number or a list of row
  % numbers.
  %
  % Extracts either a single row or a number of rows and returns them
  % in a list of row matrices.
  %
  begin
    integer rowdim,coldim;
    scalar ans,tmp;
    if not matrixp(in_mat) then
     rederr "Error in get_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in get_rows(second argument): ";
      prin2t "      should be either an integer or a list of integers.";
        return;
      >>;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    for each elt in row_list do
    <<
      if not fixp elt then rederr
       "Error in get_rows(second argument): contains non integer.";
      if elt>rowdim or elt=0 then
      <<
        prin2  "***** Error in get_rows(second argument): ";
        rederr
         "contains row number which is out of range for input matrix.";
      >>;
      tmp := 'mat.{nth(cdr in_mat,elt)};
      ans := append(ans,{tmp});
    >>;
    return 'list.ans;
  end;



symbolic procedure get_columns(in_mat,col_list);
  %
  % Input is a matrix and either a single column number or a list of
  % column numbers.
  %
  % Extracts either a single column or a series of adjacent columns and
  % returns them in a list of column matrices.
  %
  begin
    integer rowdim,coldim;
    scalar ans,tmp;
    if not matrixp(in_mat) then
     rederr "Error in get_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2 "***** Error in get_columns(second argument): ";
        prin2t
         "     should be either an integer or a list of integers.";
        return;
      >>;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    for each elt in col_list do
    <<
      if not fixp elt then rederr
       "Error in get_columns(second argument): contains non integer.";
      if elt>coldim or elt=0 then
      <<
        prin2 "***** Error in get_columns(second argument): ";
        rederr
       "contains column number which is out of range for input matrix.";
      >>;
      tmp := 'mat.for each row in cdr in_mat collect {nth(row,elt)};
      ans := append(ans,{tmp});
    >>;
    return 'list.ans;
  end;

flag('(get_rows,get_columns),'opfn);



symbolic procedure stack_rows(in_mat,row_list);
  %
  % Stacks all rows pointed to in row_list to form a new matrix.
  %
  % row_list can be either an integer or a list of integers.
  %
  begin
    if not !*fast_la and not matrixp in_mat then
     rederr "Error in stack_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list;
    return 'mat.for each elt in row_list collect nth(cdr in_mat,elt);
  end;



symbolic procedure augment_columns(in_mat,col_list);
  %
  % Augments all columns pointed to in col_list to form a new matrix.
  %
  % col_list can be either an integer or a list of integers.
  %
  begin
    if not !*fast_la and not matrixp in_mat then rederr
     "Error in augment_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list;
    return 'mat.for each row in cdr in_mat collect
                for each elt in col_list collect nth(row,elt);
  end;

% flag('(stack_rows,augment_columns),'opfn);

rtypecar stack_rows,augment_columns;


symbolic procedure add_rows(in_mat,r1,r2,mult1);
  %
  % Replaces row2 (r2) by mult1*r1 + r2.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    coldim := column_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp in_mat then
       rederr "Error in add_rows(first argument): should be a matrix.";
      rowdim := row_dim(in_mat);
      if not fixp r1 then
     rederr "Error in add_rows(second argument): should be an integer.";
      if not fixp r2 then
     rederr "Error in add_rows(third argument): should be an integer.";
      if r1>rowdim or r1=0 then rederr
   "Error in add_rows(second argument): out of range for input matrix.";
      if r2>rowdim or r2=0 then rederr
   "Error in add_rows(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_mat(in_mat);
    % Efficiency.
    if (my_reval mult1) = 0 then return new_mat;
    for i:=1:coldim do
     setmat(new_mat,r2,i,reval {'plus,{'times,mult1,
                          getmat(new_mat,r1,i)},getmat(in_mat,r2,i)});
    return new_mat;
  end;



symbolic procedure add_columns(in_mat,c1,c2,mult1);
  %
  % Replaces column2 (c2) by mult1*c1 + c2.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    rowdim := row_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp in_mat then
     rederr "Error in add_columns(first argument): should be a matrix.";
      coldim := column_dim(in_mat);
      if not fixp c1 then rederr
       "Error in add_columns(second argument): should be an integer.";
      if not fixp c2 then rederr
       "Error in add_columns(third argument): should be an integer.";
      if c1>coldim or c1=0 then rederr
"Error in add_columns(second argument): out of range for input matrix.";
      if c2>rowdim or c2=0 then rederr
 "Error in add_columns(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_mat(in_mat);
    % Why not be efficient.
    if (my_reval mult1) = 0 then return new_mat;
    for i:=1:rowdim do
      setmat(new_mat,i,c2,{'plus,{'times,mult1,getmat(new_mat,i,c1)},
                           getmat(in_mat,i,c2)});
    return new_mat;
  end;

% flag('(add_rows,add_columns),'opfn);

rtypecar add_rows,add_columns;


symbolic procedure add_to_rows(in_mat,row_list,value);
  %
  % Adds value to each element in each row in row_list.
  %
  % row_list can be either an integer or a list of integers.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    if not matrixp in_mat then
     rederr "Error in add_to_row(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in add_to_rows(second argument): ";
        prin2t "      should be either integer or a list of integers.";
        return;
      >>;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    new_mat := copy_mat(in_mat);
    for each row in row_list do
    <<
      if not fixp row then rederr
       "Error in add_to_row(second argument): should be an integer.";
      if row>rowdim or row=0 then
      <<
        prin2  "***** Error in add_to_rows(second argument): ";
        rederr "contains row which is out of range for input matrix.";
      >>;
      for i:=1:coldim do
       setmat(new_mat,row,i,{'plus,getmat(new_mat,row,i),value});
    >>;
    return new_mat;
  end;



symbolic procedure add_to_columns(in_mat,col_list,value);
  %
  % Adds value to each element in each column in col_list.
  %
  % col_list can be either an integer or a list of integers.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    if not matrixp in_mat then rederr
     "Error in add_to_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2  "***** Error in add_to_columns(second argument): ";
        prin2t "      should be either integer or list of integers.";
        return;
      >>;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    new_mat := copy_mat(in_mat);
    for each col in col_list do
    <<
      if not fixp col then rederr
      "Error in add_to_columns(second argument): should be an integer.";
      if col>coldim or col=0 then
      <<
        prin2  "***** Error in add_to_columns(second argument): ";
        rederr
         "contains column which is out of range for input matrix.";
      >>;
      for i:=1:rowdim do
       setmat(new_mat,i,col,{'plus,getmat(new_mat,i,col),value});
    >>;
    return new_mat;
  end;

% flag('(add_to_rows,add_to_columns),'opfn);

rtypecar add_to_rows,add_to_columns;


symbolic procedure mult_rows(in_mat,row_list,mult1);
  %
  % Replaces rows specified in row_list by row * mult1.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in mult_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    new_mat := copy_mat(in_mat);
    for each row in row_list do
    <<
      if not !*fast_la and not fixp row then rederr
       "Error in mult_rows(second argument): contains non integer.";
      if not !*fast_la and (row>rowdim or row=0) then
      <<
        prin2  "***** Error in mult_rows(second argument): ";
        rederr "contains row that is out of range for input matrix.";
      >>;
      for i:=1:coldim do
      <<
        setmat(new_mat,row,i,reval {'times,mult1,getmat(in_mat,row,i)});
      >>;
    >>;
    return new_mat;
  end;


symbolic procedure mult_columns(in_mat,column_list,mult1);
  %
  % Replaces columns specified in column_list by column * mult1.
  %
  begin
    scalar new_mat;
    integer i,rowdim,coldim;
    if not !*fast_la and not matrixp(in_mat) then
    rederr "Error in mult_columns(first argument): should be a matrix.";
    if atom column_list then column_list := {column_list}
    else if car column_list = 'list then column_list := cdr column_list;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    new_mat := copy_mat(in_mat);
    for each column in column_list do
    <<
      if not !*fast_la and not fixp column then rederr
       "Error in mult_columns(second argument): contains non integer.";
      if not !*fast_la and (column>coldim or column=0) then
      <<
        prin2  "***** Error in mult_columns(second argument): ";
        rederr "contains column that is out of range for input matrix.";
      >>;
      for i:=1:rowdim do
      <<
        setmat(new_mat,i,column,
               reval {'times,mult1,getmat(in_mat,i,column)});
      >>;
    >>;
    return new_mat;
  end;

% flag('(mult_rows,mult_columns),'opfn);

rtypecar mult_rows,mult_columns;


%%%%%%%%%%%%%%%%%%%%% matrix_augment/matrix_stack %%%%%%%%%%%%%%%%%%%%%%
put('matrix_augment,'psopfn,'matrix_augment1);
symbolic procedure matrix_augment1(matrices);
  %
  % Takes any number of matrices and joins them horizontally.
  %
  % Can take either a list of matrices or the matrices as seperate
  % arguments.
  %
  begin
    scalar mat_list,new_list,new_row;
    if pairp matrices and pairp car matrices and caar matrices = 'list
     then matrices := cdar matrices;
    if not !*fast_la then
    <<
      mat_list := for each elt in matrices collect reval elt;
      for each elt in mat_list do
        if not matrixp(elt) then
         rederr "Error in matrix_augment: non matrix in input.";
    >>;
    const_rows_test(mat_list);
    for i:=1:row_dim(first mat_list) do
    <<
      new_row := {};
      for each mat1 in mat_list do
       new_row := append(new_row,nth(cdr mat1,i));
      new_list := append(new_list,{new_row});
    >>;
    return 'mat.new_list;
  end;



put('matrix_stack,'psopfn,'matrix_stack1);
symbolic procedure matrix_stack1(matrices);
  %
  % Takes any number of matrices and joins them vertically.
  %
  % Can take either a list of matrices or the matrices as seperate
  % arguments.
  %
  begin
    scalar mat_list,new_list;
    if pairp matrices and pairp car matrices and caar matrices = 'list
     then matrices := cdar matrices;
    if not !*fast_la then
    <<
      mat_list := for each elt in matrices collect reval elt;
      for each elt in mat_list do
       if not matrixp(elt) then
        rederr "Error in matrix_stack: non matrix in input.";
    >>;
    const_columns_test(mat_list);
    for each mat1 in mat_list do new_list := append(new_list,cdr mat1);
    return 'mat.new_list;
  end;




symbolic procedure no_rows(mat_list);
  %
  % Takes list of matrices and sums the no. of rows.
  %
  for each mat1 in mat_list sum row_dim(mat1);




symbolic procedure no_cols(mat_list);
  %
  % Takes list of matrices and sums the no. of columns.
  %
  for each mat1 in mat_list sum column_dim(mat1);



symbolic procedure const_rows_test(mat_list);
  %
  % Tests that each matrix in mat_list has the same number of rows
  % (otherwise augmentation not possible).
  %
  begin
    integer i,listlen,rowdim;
    listlen := length(mat_list);
    rowdim := row_dim(car mat_list);
    i := 1;
    while i>;
    if i=listlen then return rowdim
     else
     <<
       prin2  "***** Error in matrix_augment: ";
       rederr "all input matrices must have the same row dimension.";
     >>;
  end;



symbolic procedure const_columns_test(mat_list);
  %
  % Tests that each matrix in mat_list has the same number of columns
  % (otherwise stacking not possible).
  %
  begin
    integer i,listlen,coldim;
    listlen := length(mat_list);
    coldim := column_dim(car mat_list);
    i := 1;
    while i>;
    if i=listlen then return coldim
     else
     <<
       prin2  "***** Error in matrix_stack: ";
       rederr
        "all input matrices must have the same column dimension.";
       return;
     >>;
  end;

%%%%%%%%%%%%%%%%%%%% end matrix_augment/matrix_stack %%%%%%%%%%%%%%%%%%%



%%%%%%%%%%%%%%%%%%%%%%%%%%% block_matrix %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure block_matrix(rows,cols,mat_list);
  %
  % Creates a matrix consisting of rows*cols matrices which are taken
  % sequentially from the mat_list.
  %
  begin
    scalar block_mat,row_list;
    integer rowdim,coldim,start_row,start_col,i,j;
    if not fixp rows then rederr
     "Error in block_matrix(first argument): should be an integer.";
    if rows=0 then
    <<
      prin2  "***** Error in block_matrix(first argument): ";
      prin2t "      should be an integer greater than 0.";
      return;
    >>;
    if not fixp cols then rederr
     "Error in block_matrix(second argument): should be an integer.";
    if cols=0 then
    <<
     prin2  "***** Error in block_matrix(second argument): ";
      prin2t "      should be an integer greater than 0.";
      return;
    >>;
    if matrixp mat_list then mat_list := {mat_list}
     else if pairp mat_list and car mat_list = 'list then
     mat_list := cdr mat_list
      else
      <<
        prin2  "***** Error in block_matrix(third argument): ";
        prin2t
        "      should be either a single matrix or a list of matrices.";
        return;
      >>;
    if rows*cols neq length mat_list then rederr
 "Error in block_matrix(third argument): Incorrect number of matrices.";
    row_list := create_row_list(rows,cols,mat_list);
    rowdim := check_rows(row_list);
    coldim := check_cols(row_list);
    block_mat := mkmatrix(rowdim,coldim);
    start_row := 1; start_col := 1;
    for i:=1:length row_list do
    <<
      for j:=1:cols do
      <<
        block_mat := copy_into(nth(nth(row_list,i),j),block_mat,
                                start_row,start_col);
        start_col := start_col + column_dim(nth(nth(row_list,i),j));
      >>;
      start_col := 1;
      start_row := start_row + row_dim(nth(nth(row_list,i),1));
    >>;
    return block_mat;
  end;

flag('(block_matrix),'opfn);



symbolic procedure create_row_list(rows,cols,mat_list);
  %
  % Takes mat_list and creates a list of rows elements each of which is
  % a list containing cols elements (ordering left to right).
  % eg: create_row_list(3,2,{a,b,c,d,e,f}) will return
  %     {{a,b},{c,d},{e,f}}.
  %
  begin
    scalar row_list,tmp_list;
    integer i,j,increment;
    increment := 1;
    for i:=1:rows do
    <<
      tmp_list := {};
      for j:=1:cols do
      <<
        tmp_list := append(tmp_list,{nth(mat_list,increment)});
        increment := increment + 1;
      >>;
      row_list := append(row_list,{tmp_list});
    >>;
    return row_list;
  end;



symbolic procedure check_cols(row_list);
  %
  % Checks each element in row_list has same number of columns.
  % Returns this number.
  %
  begin
    integer i,listlen;
    i := 1;
    listlen := length(row_list);
    while i>;
  end;



symbolic procedure check_rows(row_list);
  %
  % Checks all matrices in each element in row_list contains same
  % amount of rows.
  % Returns the sum of all of these row numbers (ie: number of rows
  % required in the block matrix).
  %
  begin
    integer i,listlen,rowdim,eltlen,j;
    i := 1;
    listlen := length(row_list);
    while i<=listlen do
    <<
      eltlen := length nth(row_list,i);
      j := 1;
      while j>;
      >>;
      rowdim := rowdim + row_dim(nth(nth(row_list,i),j));
      i := i+1;
    >>;
    return rowdim;
  end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%% end block_matrix %%%%%%%%%%%%%%%%%%%%%%%%%%


put('vandermonde,'psopfn,'vandermonde1);
symbolic procedure vandermonde1(variables);
  %
  % Input can be either a list or individual arguments.
  %
  % Creates the Vandermonde matrix.
  % ie: the square matrix in which the (i,j)'th entry is
  %     nth(variables,i)^(j-1).
  %
  begin
    scalar vand,in_list;
    integer i,j,sq_size;
    if pairp variables and pairp car variables
        and caar variables = 'list then variables := cdar variables;
    in_list := for each elt in variables collect my_reval elt;
    sq_size := length in_list;
    vand := mkmatrix(sq_size,sq_size);
    for i:=1:sq_size do
    <<
      for j:=1:sq_size do
      <<
        setmat(vand,i,j,
               reval{'expt,nth(in_list,i),{'plus,j,{'minus,1}}});
      >>;
    >>;
    return vand;
  end;



put('toeplitz,'psopfn,'toeplitz1);
symbolic procedure toeplitz1(variables);
  %
  % Input can be either a list or individual arguments.
  %
  % Creates the Toeplitz matrix.
  % ie: the square matrix in which the first element is placed on the
  % diagonal and the nth(variables,i) element is placed on the (i-1)
  % sub and super diagonals.
  %
  begin
    scalar toep,in_list;
    integer i,j,sq_size;
    if pairp variables and pairp car variables
        and caar variables = 'list then variables := cdar variables;
    in_list := for each elt in variables collect my_reval elt;
    sq_size := length in_list;
    toep := mkmatrix(sq_size,sq_size);
    for i:=1:sq_size do
    <<
      for j:=0:i-1 do
      <<
        setmat(toep,i,i-j,nth(in_list,j+1));
        setmat(toep,i-j,i,nth(in_list,j+1));
      >>;
    >>;
    return toep;
  end;

%%%%%%%%%%%%%%%%%%%%%%%%% kronecker_product %%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure kronecker_product(AA,BB);
  %
  % Copies matrix BB into AA with BB(1,1) at AA(p,q).
  %
  begin
    scalar A,B; integer m,n,r,c;
    if not !*fast_la then
    <<
      if not matrixp(aa) then rederr
     "Error in kronecker_product (first argument): should be a matrix.";
      if not matrixp(bb) then rederr
    "Error in kronecker_product (second argument): should be a matrix.";
    >>;
    m := row_dim(AA);
    n := column_dim(AA);
    r := row_dim(BB);
    c := column_dim(BB);

    A := mkmatrix(m*r,n*c);
    for i:=1:m do
     for j:=1:n do <<
         B := getmat(AA,i,j);
         for ii:=1:c do
           for jj := 1 : r do
                setmat(A,(i-1)*r+jj,(j-1)*c+ii,
                   reval list('times,b, getmat(bb,jj,ii)));
                >>;
    return A;
  end;

% flag('(kronecker_product),'opfn);

rtypecar kronecker_product;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% minor %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure minor(in_mat,row,col);
  %
  % Removes row (row) and column (col) from in_mat.
  %
  begin
    scalar min;
    if not !*fast_la then
    <<
      if not matrixp(in_mat) then
       rederr "Error in minor(first argument): should be a matrix.";
      if not fixp row then
       rederr "Error in minor(second argument): should be an integer.";
      if row>row_dim(in_mat) or row=0 then rederr
      "Error in minor(second argument): out of range for input matrix.";
      if not fixp col then
       rederr "Error in minor(third argument): should be an integer.";
      if col>column_dim(in_mat) or col=0 then rederr
      "Error in minor(second argument): out of range for input matrix.";
    >>;
    min := remove_rows(in_mat,row);
    min := remove_columns(min,col);
    return min;
  end;



symbolic procedure remove_rows(in_mat,row_list);
  %
  % Removes each row in row_list from in_mat.
  %
  % row_list can be either an integer or a list of integers.
  %
  begin
    scalar unique_row_list,new_list;
    integer rowdim,row;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in remove_rows(first argument): non matrix input.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in remove_rows(second argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;
    % Remove any repititions in row_list (I'm assuming here that if the
    % user has inputted the same row more than once then the meaning
    % is to only remove that row once).
    unique_row_list := {};
    for each row in row_list do
    <<
      if not intersection({row},unique_row_list) then
       unique_row_list := append(unique_row_list,{row});
    >>;
    rowdim := row_dim(in_mat);
    if not !*fast_la then
    <<
      for each row in unique_row_list do if not fixp row then rederr
       "Error in remove_rows(second argument): contains a non integer.";
%      rowdim := row_dim(in_mat);
%      coldim := column_dim(in_mat);
      for each row in unique_row_list do if row>rowdim or row=0 then
       rederr
"Error in remove_rows(second argument): out of range for input matrix.";
      if length unique_row_list = rowdim then
      <<
        prin2  "***** Warning in remove_rows:";
        prin2t "      all the rows have been removed. Returning nil.";
        return nil;
      >>;
    >>;
    for row:=1:rowdim do if not intersection({row},unique_row_list)
     then new_list := append(new_list,{nth(cdr in_mat,row)});
    return 'mat.new_list;
  end;




symbolic procedure remove_columns(in_mat,col_list);
  %
  % Removes each column in col_list from in_mat.
  %
  % col_list can be either an integer or a list of integers.
  %
  begin
    scalar unique_col_list,new_list,row_list;
    integer coldim,row,col;
    if not !*fast_la and not matrixp(in_mat) then rederr
     "Error in remove_columns(first argument): non matrix input.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2  "***** Error in remove_columns(second argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;

    % Remove any repititions in col_list (I'm assuming here that if the
    % user has inputted the same column more than once then the meaning
    % is to only remove that column once).
    unique_col_list := {};
    for each col in col_list do
    <<
      if not intersection({col},unique_col_list) then
       unique_col_list := append(unique_col_list,{col});
    >>;
    coldim := column_dim(in_mat);
    if not !*fast_la then
    <<
      for each col in unique_col_list do if not fixp col then rederr
    "Error in remove_columns(second argument): contains a non integer.";
      for each col in unique_col_list do if col>coldim or col=0 then
       rederr
   "Error in remove_columns(second argument): out of range for matrix.";
      if length unique_col_list = coldim then
      <<
        prin2  "***** Warning in remove_columns: ";
       prin2t "      all the columns have been removed. Returning nil.";
        return nil;
      >>;
    >>;
    for each row in cdr in_mat do
    <<
      row_list := {};
      for col:=1:coldim do
      <<
        if not intersection({col},unique_col_list)
         then row_list := append(row_list,{nth(row,col)});
      >> ;
      new_list := append(new_list,{row_list});
    >>;
    return 'mat.new_list;
  end;

flag('(minor,remove_rows,remove_columns),'opfn);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end  minor %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



%%%%%%%%%%%%%%%%% begin random_matrix/im_random_matrix %%%%%%%%%%%%%%%%%

switch imaginary;     % If ON, then random_matrix creates a random
                      % matrix with imaginary entries.

switch not_negative;  % If ON, then the random matrix functions create
                      % matrices with only positive entries. In the
                      % imaginary case, each entry x+iy will have x and
                      % y both > 0. Not that this really means a great
                      % deal mathematically apart from each guy sitting
                      % right up there in the top right hand corner of
                      % the argand plane but oh well.

switch only_integer;  % If ON, then the random matrix functions will
                      % create matrices with only integer entries. In
                      % the imaginary case, each entry x+iy will have
                      % x and y as integers.

switch symmetric;     % If ON, random matrix is symmetric.

switch upper_matrix;  % If ON, then the random matrix is an upper
                      % triagonal matrix.

switch lower_matrix;  % If ON, then the random matrix is a lower
                      % triagonal matrix.



symbolic procedure random_minus(limit);
  %
  % Creates random number in the range -limit < number < limit.
  %
  begin
    scalar r;
    r := random(limit);
    if evenp random(1000) then r := {'minus,r};
    return r
  end;



symbolic procedure random_make_minus(u);
  %
  % Randomly makes u negative.
  %
  if evenp random(1000) then {'minus,u} else u;



symbolic procedure random_matrix(rowdim,coldim,limit);
  %
  % Creates an rowdim by coldim matrix with random entries in the bound
  % -limit < entry < limit.
  %
  begin
    scalar randmat,random_decimal;
    integer i,j,start,current_precision;
    if !*lower_matrix and !*upper_matrix then
    <<
      prin2  "***** Error in random matrix: ";
     prin2t "      both upper_matrix and lower_matrix switches are on.";
      return;
    >>;
    if !*upper_matrix and !*symmetric then
    <<
      prin2  "***** Error in random_matriix: ";
      prin2t "      both upper_matrix and symmetric switches are on.";
      return;
    >>;
    if !*lower_matrix and !*symmetric then
    <<
      prin2  "***** Error in random_matrix: ";
      prin2t "      both lower_matrix and symmetric switches are on.";
      return;
    >>;
    if not fixp limit then limit := algebraic floor(abs(limit));
    if not fixp rowdim then rederr
     "Error in random_matrix(first argument): should be an integer.";
    if rowdim=0 then rederr
  "Error in random_matrix(first argument): should be integer > than 0.";
    if not fixp coldim then rederr
     "Error in random_matrix(second argument): should be an integer.";
    if coldim=0 then
    <<
      prin2  "***** Error in random_matrix(second argument): ";
      prin2t "      should be an integer greater than 0.";
      return;
    >>;
    current_precision := precision 0;
    if !*imaginary then randmat := im_random_matrix(rowdim,coldim,limit)
    else
    <<
      start := 1;
      randmat := mkmatrix(rowdim,coldim);
      for i:=1:rowdim do
     <<
        if !*symmetric or !*lower_matrix then coldim := i
        else if !*upper_matrix then start := i;
        for j:=start:coldim do
        begin
          scalar r1, r2;
          r1 := random(limit);
          r2 := random(10^current_precision);
          random_decimal := {'plus,r1,{'quotient,
                             r2,
                             10^current_precision}};
          if !*only_integer and !*not_negative then
             setmat(randmat,i,j,random(limit))
          else if !*only_integer then
             setmat(randmat,i,j,random_minus(limit))
          else if !*not_negative then
             setmat(randmat,i,j,random_decimal)
          else setmat(randmat,i,j,random_make_minus(random_decimal));
          if !*symmetric then setmat(randmat,j,i,getmat(randmat,i,j));
        end;
      >>;
    >>;
    return randmat;
  end;

flag('(random_matrix),'opfn);



symbolic procedure im_random_matrix(rowdim,coldim,limit);
  %
  % Creates an rowdim by coldim matrix with random imaginary entries.
  % The entrirs are of the form x+iy where x and y are in the bound
  % -limit < x,y < limit.
  %
  begin
    scalar randmat,random_decimal,im_random_decimal;
    integer i,j,start,current_precision;
    start := 1;
    current_precision := precision 0;
    randmat := mkmatrix(rowdim,coldim);
    for i:=1:rowdim do
    <<
      if !*symmetric or !*lower_matrix then coldim := i
       else if !*upper_matrix then start := i;
      for j:=start:coldim do
      begin
        scalar r1, r2;
        r1 := random(limit);
        r2 := random(10^current_precision);
        random_decimal := {'plus,1,{'quotient,
                            r2,
                            10^current_precision}};
        r1 := random(limit);
        r2 := random(10^current_precision);
        im_random_decimal := {'plus,r1,{'quotient,
                               r2,
                               10^current_precision}};
        if !*only_integer and !*not_negative then <<
           r1 := random(limit); r2 := random(limit);
           setmat(randmat,i,j,{'plus,r1, {'times,'i,r2}}) >>
        else if !*only_integer then <<
           r1 := random_minus(limit); r2 := random_minus(limit);
           setmat(randmat,i,j,{'plus,r1, {'times,'i,r2}}) >>
        else if !*not_negative then
           setmat(randmat,i,j,{'plus,random_decimal,
                                 {'times,'i,im_random_decimal}})
        else <<
           r1 := random_make_minus(random_decimal);
           r2 := random_make_minus(im_random_decimal);
           setmat(randmat,i,j,{'plus,r1, {'times,'i,r2}}) >>;
        if !*symmetric then setmat(randmat,j,i,getmat(randmat,i,j));
      end;
    >>;
    return randmat;
  end;

% flag('(im_random_matrix),'opfn);

rtypecar im_random_matrix;

%%%%%%%%%%%%%%%%%% end random_matrix/im_random_matrix %%%%%%%%%%%%%%%%%%



symbolic procedure extend(in_mat,rows,cols,entry);
  %
  % Extends in_mat by rows rows (!) and cols columns. New entries are
  % initialised to entry.
  %
  begin
    scalar ex_mat;
    integer rowdim,coldim,i,j;
    if not matrixp(in_mat) then
     rederr "Error in extend(first argument): should be a matrix.";
    if not fixp rows then
     rederr "Error in extend(second argument): should be an integer.";
    if not fixp cols then
     rederr "Error in extend(third argument): should be an integer.";
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    ex_mat := mkmatrix(rowdim+rows,coldim+cols);
    ex_mat := copy_into(in_mat,ex_mat,1,1);
    for i:=1:rowdim+rows do
    <<
      for j:=1:coldim+cols do
      <<
        if i<=rowdim and j<=coldim then <<>>
        else setmat(ex_mat,i,j,entry);
      >>;
    >>;
    return ex_mat;
  end;

flag('(extend),'opfn);

rtypecar extend;


%%%%%%%%%%%%%%%%%%%%% begin char_matrix/char_poly %%%%%%%%%%%%%%%%%%%%%%

symbolic procedure char_matrix(in_mat,lmbda);
  %
  % Create characteristic matrix. ie: C := lmbda*I - in_mat.
  % in_ mat must be square.
  %
  begin
    scalar carmat;
    integer rowdim;
    if not matrixp(in_mat) then
     rederr "Error in char_matrix(first argument): should be a matrix.";
    if not squarep(in_mat) then rederr
     "Error in char_matrix(first argument): must be a square matrix.";
    rowdim := row_dim(in_mat);
    carmat := {'plus,{'times,lmbda,make_identity(rowdim)},
               {'minus,in_mat}};
    return carmat;
  end;



symbolic procedure char_poly(in_mat,lmbda);
  %
  % Finds characteristic polynomial of matrix in_mat.
  % ie: det(lmbda*I - in_mat).
  %
  begin
    scalar chpoly,carmat;
    if not matrixp(in_mat) then
     rederr "Error in char_poly(first argument): should be a matrix.";
    carmat := char_matrix(in_mat,lmbda);
    chpoly := algebraic det(carmat);
    return chpoly;
  end;

flag('(char_matrix char_poly),'opfn);

%%%%%%%%%%%%%%%%%%%%%%%% end char_matrix/char_poly %%%%%%%%%%%%%%%%%%%%%



%%%%%%%%%%%%%%%%%%%%%%%%%% begin pivot/rows_pivot %%%%%%%%%%%%%%%%%%%%%%

symbolic procedure pivot(in_mat,pivot_row,pivot_col);
  %
  % Converts all elements in pivot column (apart from the one in pivot
  % row) to 0.
  %
  begin
    scalar piv_mat,ratio;
    integer i,j,rowdim,coldim;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in pivot(first argument): should be a matrix.";
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    if not !*fast_la then
    <<
    if not fixp pivot_row then
     rederr "Error in pivot(second argument): should be an integer.";
    if pivot_row>rowdim or pivot_row=0 then rederr
     "Error in pivot(second argument): out of range for input matrix.";
    if not fixp pivot_col then rederr
     "Error in pivot(third argument): should be an integer.";
    if pivot_col>coldim or pivot_col=0 then rederr
     "Error in pivot(third argument): out of range for input matrix.";
    if getmat(in_mat,pivot_row,pivot_col) = 0 then
     rederr "Error in pivot: cannot pivot on a zero entry.";
    >>;
    piv_mat := copy_mat(in_mat);
    piv_mat := copy_mat(in_mat);
    for i:=1:rowdim do
    <<
      for j:=1:coldim do
      <<
        if i = pivot_row then <<>>
        else
        <<
           ratio := {'quotient,getmat(in_mat,i,pivot_col),
                     getmat(in_mat,pivot_row,pivot_col)};
           setmat(piv_mat,i,j,{'plus,getmat(in_mat,i,j),{'minus,
                  {'times,ratio,getmat(in_mat,pivot_row,j)}}});
        >>;
      >>;
    >>;
    return piv_mat;
  end;



symbolic procedure rows_pivot(in_mat,pivot_row,pivot_col,row_list);
  %
  % Same as pivot but only rows a .. to .. b, where row_list = {a,b},
  % are changed.
  %
  % rows_pivot will work if row_list is just an integer.
  %
  begin
    scalar piv_mat,ratio;
    integer j,rowdim,coldim;
    rowdim := row_dim(in_mat);
    coldim := column_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp(in_mat) then
      rederr "Error in rows_pivot(first argument): should be a matrix.";
      rowdim := row_dim(in_mat);
      coldim := column_dim(in_mat);
      if not fixp pivot_row then
       rederr "Error in pivot(second argument): should be an integer.";
      if pivot_row>rowdim or pivot_row=0 then rederr
 "Error in rows_pivot(second argument): out of range for input matrix.";
      if not fixp pivot_col then
       rederr "Error in pivot(third argument): should be an integer.";
      if pivot_col>coldim or pivot_col=0 then rederr
  "Error in rows_pivot(third argument): out of range for input matrix.";
    >>;
    if atom row_list then row_list := {row_list}
     else if pairp row_list and car row_list = 'list
     then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in rows_pivot(fourth argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;
    if getmat(in_mat,pivot_row,pivot_col) = 0 then
     rederr "Error in rows_pivot: cannot pivot on a zero entry.";
    piv_mat := copy_mat(in_mat);
    for each elt in row_list do
    <<
      if not !*fast_la then
      <<
        if not fixp elt then rederr
         "Error in rows_pivot: fourth argument contains a non integer.";
        if elt>rowdim or elt=0 then
        <<
          prin2  "***** Error in rows_pivot(fourth argument): ";
          rederr "contains row which is out of range for input matrix.";
        >>;
      >>;
      for j:=1:coldim do
      <<
        if elt = pivot_row then <<>>
        else
        <<
           ratio := {'quotient,getmat(in_mat,elt,pivot_col),
                     getmat(in_mat,pivot_row,pivot_col)};
           setmat(piv_mat,elt,j,{'plus,getmat(in_mat,elt,j),{'minus,
                  {'times,ratio,getmat(in_mat,pivot_row,j)}}});
        >>;
      >>;
    >>;
    return piv_mat;
  end;

flag('(pivot,rows_pivot),'opfn);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%% end pivot/rows_pivot %%%%%%%%%%%%%%%%%%%%%



symbolic procedure mat_jacobian(exp_list,var_list);
  %
  % mat_jacobian(exp,var) computes the Jacobian matrix of exp w.r.t. var.
  % The (i,j)'th entry is diff(nth(exp,i),nth(var,j)).
  %
  begin
    scalar jac,exp1,var1;
    integer i,j,rowdim,coldim;
    if atom exp_list then exp_list := {exp_list}
     else if car exp_list neq 'list then rederr
     "Error in mat_jacobian(first argument): expressions must be in a list."
      else exp_list := cdr exp_list;
    if atom var_list then var_list := {var_list}
     else if car var_list neq 'list then rederr
      "Error in mat_jacobian(second argument): variables must be in a list."
      else var_list := cdr var_list;
    rowdim := length exp_list;
    coldim := length var_list;
    jac := mkmatrix(rowdim,coldim);
    for i:=1:rowdim do
    <<
      for j:=1:coldim do
      <<
        exp1 := nth(exp_list,i);
        var1 := nth(var_list,j);
        setmat(jac,i,j,algebraic df(exp1,var1));
      >>;
    >>;
    return jac;
  end;

flag('(mat_jacobian),'opfn);



symbolic procedure hessian(poly,variables);
  %
  % variables can be either a list or a single variable.
  %
  % A Hessian matrix is a matrix whose (i,j)'th entry is
  %       df(df(poly,nth(var,i)),nth(var,j))
  %
  % where df is the derivative.
  %
  begin
    scalar hess_mat,part1,part2,elt;
    integer row,col,sq_size;
    if atom variables then variables := {variables}
     else if car variables = 'list then variables := cdr variables
      else
      <<
        prin2  "***** Error in hessian(second argument): ";
        prin2t
     "      should be either a single variable or a list of variables.";
        return;
      >>;
    sq_size := length variables;
    hess_mat := mkmatrix(sq_size,sq_size);
    for row:=1:sq_size do
    <<
      for col:=1:sq_size do
      <<
        part1 := nth(variables,row);
        part2 := nth(variables,col);
        elt := algebraic df(df(poly,part1),part2);
        setmat(hess_mat,row,col,elt);
      >>;
    >>;
    return hess_mat;
  end;

flag('(hessian),'opfn);



symbolic procedure hermitian_tp(in_mat);
  %
  % Computes the Hermitian transpose (HT say) of in_mat.
  %
  % The (i,j)'th element of HT = conjugate of the (j,i)'th element of
  % in__mat.
  %
  begin
    scalar h_tp,element;
    integer row,col;
    if not matrixp(in_mat) then
     rederr "Error in hermitian_tp: non matrix input.";
    h_tp := algebraic tp(in_mat);
    for row:=1:row_dim(h_tp) do
    <<
      for col:=1:column_dim(h_tp) do
      <<
        element := getmat(h_tp,row,col);
        setmat(h_tp,row,col,
               algebraic (repart(element) - i*impart(element)));
      >>;
    >>;
    return h_tp;
  end;

flag('(hermitian_tp),'opfn);



symbolic procedure hilbert(sq_size,value);
  %
  % The Hilbert matrix is symmetric and the (i,j)'th entry in
  % 1/(i+j-x).
  %
  begin
    scalar hil_mat,denom;
    integer row,col;
    if not fixp sq_size or sq_size<1 then rederr
     "Error in hilbert(first argument): must be a positive integer.";
    hil_mat := mkmatrix(sq_size,sq_size);
    for row:=1:sq_size do
    <<
      for col:=1:sq_size do
      <<
        if (denom := reval{'plus,row,col,{'minus,value}}) = 0 then
         rederr "Error in hilbert: division by zero."
         else setmat(hil_mat,row,col,{'quotient,1,denom});
      >>;
    >>;
    return hil_mat;
  end;

flag('(hilbert),'opfn);



%%%%%%%%%%%%%%%%%%%%%%%% begin coeff_matrix  %%%%%%%%%%%%%%%%%%%%%%%%%%%

put('coeff_matrix,'psopfn,'coeff_matrix1); % To allow variable input.
symbolic procedure coeff_matrix1(equation_list);
  %
  % Given the system of linear equations, coeff_matrix returns {A,X,b}
  % s.t. AX = b.
  %
  % Input can be either a list of linear equations or the linear
  % equations as individual arguments.
  %
  begin
    scalar variable_list,A,X,b;
    if pairp car equation_list and caar equation_list = 'list then
     equation_list := cdar equation_list;
    equation_list := remove_equals(equation_list);
    variable_list := get_variable_list(equation_list);
    if variable_list = nil then
     rederr "Error in coeff_matrix: no variables in input.";
    check_linearity(equation_list,variable_list);
    A := get_A(equation_list,variable_list);
    X := get_X(variable_list);
    b := get_b(equation_list,variable_list);
    return {'list,A,X,b};
  end;



symbolic procedure remove_equals(equation_list);
  %
  % If any of the equations are equalities the equalities are removed
  % to leave a list of polynomials.
  %
  begin
     equation_list := for each equation in equation_list collect
      if pairp equation and car equation = 'equal then
       reval{'plus,cadr equation,{'minus,caddr equation}}
        else equation;
     return equation_list;
  end;



symbolic procedure get_variable_list(equation_list);
  %
  % Gets hold of all variables from the equations in equation_list.
  %
  begin
    scalar variable_list;
    for each equation in equation_list do
     variable_list := union(get_coeffs(equation),variable_list);
    return reverse variable_list;
  end;



symbolic procedure check_linearity(equation_list,variable_list);
  %
  % Checks that we really are dealing with a system of linear equations.
  %
  for each equation in equation_list do
  <<
    for each variable in variable_list do
    <<
      if deg(equation,variable) > 1 then
       rederr "Error in coeff_matrix: the equations are not linear.";
    >>;
  >>;



symbolic procedure get_A(equation_list,variable_list);
  begin
    scalar A,element,var_elt;
    integer row,col,length_equation_list,length_variable_list;
    length_equation_list := length equation_list;
    length_variable_list := length variable_list;
    A := mkmatrix(length equation_list,length variable_list);
    for row:=1:length_equation_list do
    <<
      for col:=1:length_variable_list do
      <<
        element := nth(equation_list,row);
        var_elt := nth(variable_list,col);
        setmat(A,row,col,algebraic coeffn(element,var_elt,1));
      >>;
    >>;
    return A;
  end;



symbolic procedure get_b(equation_list,variable_list);
  %
  % Puts the integer parts of all the equations into a column matrix.
  %
  begin
    scalar substitution_list,integer_list,b;
    integer length_integer_list,row;
    substitution_list :=
     'list.for each variable in variable_list collect
                                               {'equal,variable,0};
    integer_list := for each equation in equation_list collect
      algebraic sub(substitution_list,equation);
    length_integer_list := length integer_list;
    b := mkmatrix(length_integer_list,1);
    for row:=1:length_integer_list do
     setmat(b,row,1,-nth(integer_list,row));
    return b;
  end;



symbolic procedure get_X(variable_list);
  begin
    scalar X;
    integer row,length_variable_list;
    length_variable_list := length variable_list;
    X := mkmatrix(length_variable_list,1);
    for row := 1:length variable_list do
     setmat(X,row,1,nth(variable_list,row));
    return X;
  end;



symbolic procedure get_coeffs(poly);
  %
  % Gets all kernels in a poly.
  %
  begin
    scalar ker_list_num,ker_list_den;
    ker_list_num := kernels !*q2f simp reval num poly;
    ker_list_den := kernels !*q2f simp reval den poly;
    ker_list_num := union(ker_list_num,ker_list_den);
    return ker_list_num;
  end;

%%%%%%%%%%%%%%%%%%%%%%%%%% end coeff_matrix  %%%%%%%%%%%%%%%%%%%%%%%%%%%

% Smacro used in other modules.

symbolic smacro procedure my_revlis(u);
  %
  % As my_reval but for lists.
  %
  for each j in u collect my_reval(j);



endmodule;  %linear algebra.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/lamatrix.red0000644000175000017500000000636611526203062024302 0ustar  giovannigiovannimodule lmatrix;

%**********************************************************************%
%                                                                      %
% This module forms the ability for matrices to be passed locally.     %
%                                                                      %
% Authors: W. Neun (customised by Matt Rebbeck).                       %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


switch mod_was_on;  % Used internally to keep track of the modular
                    % switch.


symbolic procedure mkmatrix(n,m);
  %
  % Create an nXm matrix.
  %
   'mat . (for i:=1:n collect
           for j:=1:m collect 0);



symbolic procedure setmat(matri,i,j,val);
  %
  % Set matrix element (i,j) to val.
  %
  <<   if !*modular then << off modular; on mod_was_on; >>;
       i := my_reval i;
       j := my_reval j;
       my_letmtr(list(matri,i,j),val,matri);
       if !*mod_was_on then << on modular; off mod_was_on; >>;
       matri>>;



symbolic procedure getmat(matri,i,j);
  %
  % Get matrix element (i,j).
  %
  <<   if !*modular then << off modular; on mod_was_on; >>;
       i := my_reval i;
       j := my_reval j;
       if !*mod_was_on then << on modular; off mod_was_on; >>;
       unchecked_getmatelem list(matri,i,j)>>;



symbolic procedure unchecked_getmatelem u;
  begin scalar x;
         if not eqcar(x :=  car u,'mat)
          then  rerror(matrix,1,list("Matrix",car u,"not set"))
         else return nth(nth(cdr x,cadr u),caddr u);
   end;



symbolic procedure my_letmtr(u,v,y);
  %
  % Substitution for matrix elements with reval only when necessary.
  %
  begin
    scalar z;
    if not eqcar(y,'mat) then
     rerror(matrix,10,list("Matrix",car u,"not set"))
      else if not numlis (z := my_revlis cdr u) or length z neq 2
       then return errpri2(u,'hold);
    rplaca(pnth(nth(cdr y,car z),cadr z),v);
  end;


endmodule;  % lmatrix.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/linalg.tex0000644000175000017500000015550111526203062023751 0ustar  giovannigiovanni\documentstyle[11pt,reduce,fancyheadings]{article}
\title{A Linear Algebra package for \REDUCE{}}
\author{Matt Rebbeck \\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin}
\date{July 1994}

\def\foottitle{The Linear Algebra Package}
\pagestyle{fancy}
\lhead[]{{\footnotesize\leftmark}{}}
\rhead[]{\thepage}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\cfoot{}
\rfoot{\small\foottitle}

%decided against using these.
%\def\ltri{$\triangleleft$}
%\def\rtri{$\triangleright$}
%\newcommand{\tribound}[1]{\rtri#1\ltri}

\def\exprlist  {expr$_{1}$,expr$_{2}$, \ldots ,expr$_{{\tt n}}$}
\def\lineqlist {lin\_eqn$_{1}$,lin\_eqn$_{2}$, \ldots ,lin\_eqn$_{n}$}
\def\matlist   {mat$_{1}$,mat$_{2}$, \ldots ,mat$_{n}$}
\def\veclist   {vec$_{1}$,vec$_{2}$, \ldots ,vec$_{n}$}

\def\lazyfootnote{\footnote{If you're feeling lazy then the \{\}'s can 
                  be omitted.}}

\renewcommand{\thefootnote}{\fnsymbol{footnote}}

\begin{document}
\maketitle
\index{Linear Algebra package}

\section{Introduction}
This package provides a selection of functions that are useful 
in the world of linear algebra. These functions are described 
alphabetically in section 3 of this document and are labelled 3.1 to 
3.51. They can be classified into four sections(n.b: the numbers after 
the dots signify the function label in section 3).

Contributions to this package have been made by Walter Tietze (ZIB).

\subsection{Basic matrix handling}

\begin{center}
\begin{tabular}{l l l l l l}
add\_columns     & \ldots & 3.1  & 
add\_rows        & \ldots & 3.2  \\
add\_to\_columns & \ldots & 3.3  &
add\_to\_rows    & \ldots & 3.4  \\
augment\_columns & \ldots & 3.5  &
char\_poly       & \ldots & 3.9  \\
column\_dim      & \ldots & 3.12  &
copy\_into       & \ldots & 3.14 \\
diagonal         & \ldots & 3.15 &
extend           & \ldots & 3.16 \\
find\_companion  & \ldots & 3.17  &
get\_columns     & \ldots & 3.18 \\
get\_rows        & \ldots & 3.19 &
hermitian\_tp    & \ldots & 3.21 \\
matrix\_augment  & \ldots & 3.28 &
matrix\_stack    & \ldots & 3.30 \\
minor            & \ldots & 3.31 &
mult\_columns    & \ldots & 3.32 \\ 
mult\_rows       & \ldots & 3.33 &
pivot            & \ldots & 3.34 \\
remove\_columns  & \ldots & 3.37 &
remove\_rows     & \ldots & 3.38 \\
row\_dim         & \ldots & 3.39 &
rows\_pivot      & \ldots & 3.40 \\
stack\_rows      & \ldots & 3.43 &
sub\_matrix      & \ldots & 3.44 \\
swap\_columns    & \ldots & 3.46 &
swap\_entries    & \ldots & 3.47 \\
swap\_rows       & \ldots & 3.48 &
\end{tabular}
\end{center}

\subsection{Constructors}

Functions that create matrices.

\begin{center}
\begin{tabular}{l l l l l l}
band\_matrix       & \ldots & 3. 6 & 
block\_matrix      & \ldots & 3. 7 \\
char\_matrix       & \ldots & 3. 8 & 
coeff\_matrix      & \ldots & 3. 11 \\ 
companion          & \ldots & 3. 13 & 
hessian            & \ldots & 3. 22 \\
hilbert            & \ldots & 3. 23 & 
jacobian           & \ldots & 3. 24 \\
jordan\_block      & \ldots & 3. 25 & 
make\_identity     & \ldots & 3. 27 \\
random\_matrix     & \ldots & 3. 36 & 
toeplitz           & \ldots & 3. 50 \\
Vandermonde        & \ldots & 3. 51 &
Kronecker\_Product & \ldots & 3. 52  
\end{tabular}
\end{center}

\subsection{High level algorithms}

\begin{center}
\begin{tabular}{l l l l l l}
char\_poly       & \ldots & 3.9 & 
cholesky         & \ldots & 3.10 \\ 
gram\_schmidt    & \ldots & 3.20 & 
lu\_decom        & \ldots & 3.26 \\
pseudo\_inverse  & \ldots & 3.35 & 
simplex          & \ldots & 3.41 \\
svd              & \ldots & 3.45 & 
triang\_adjoint  & \ldots & 3.51
\end{tabular}
\end{center}

\vspace*{5mm}
There is a separate {\small NORMFORM}[1] package for computing 
the following matrix normal forms in \REDUCE.

\begin{center}
smithex, smithex\_int, frobenius, ratjordan, jordansymbolic, jordan.
\end{center}

\subsection{Predicates}

\begin{center}
\begin{tabular}{l l l l l l}
matrixp     & \ldots & 3.29 & 
squarep     & \ldots & 3.42 \\
symmetricp  & \ldots & 3.49 & 
\end{tabular}
\end{center}

\subsection*{Note on examples:} 

In the examples the matrix ${\cal A}$ will be 

\begin{flushleft}
\begin{math}
{\cal A} = \left( \begin{array}{ccc} 1 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 9
\end{array} \right)
\end{math}
\end{flushleft}


\subsection*{Notation}

Throughout ${\cal I}$ is used to indicate the identity matrix and 
${\cal A}^T$ to indicate the transpose of the matrix ${\cal A}$.

\section{Getting started}

If you have not used matrices within {\REDUCE} before then the 
following may be helpful.

\subsection*{Creating matrices}

Initialisation of matrices takes the following syntax:

{\tt mat1 := mat((a,b,c),(d,e,f),(g,h,i));}

will produce 

\begin{flushleft}
\begin{math}
mat1 := \left( \begin{array}{ccc} a & b & c \\ d & e & f \\ g & h & i
\end{array} \right)
\end{math}
\end{flushleft}

\subsection*{Getting at the entries}

The (i,$\,$j)'th entry can be accessed by:

{\tt mat1(i,j);}

\subsection*{Loading the linear\_algebra package}

The package is loaded by:

{\tt load\_package linalg;}


\section{What's available}

\subsection{add\_columns, add\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt add\_columns(${\cal A}$,c1,c2,expr);} 

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$ & :- & a matrix. \\
c1,c2      & :- & positive integers. \\
expr       & :- & a scalar expression. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
\parbox[t]{0.95\linewidth}{{\tt add\_columns} replaces column c2 of 
${\cal A}$ by expr $*$ column(${\cal A}$,c1) $+$ column(${\cal A}$,c2).}

{\tt add\_rows} performs the equivalent task on the rows of ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\begin{math}
\hspace*{0.16in}
\begin{array}{ccc}
{\tt add\_columns}({\cal A},1,2,x) & = & 
\left( \begin{array}{ccc} 1 & x+2 & 3 \\ 4 & 4*x+5 & 6 \\ 7 & 7*x+8 & 9
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\tt add\_rows}({\cal A},2,3,5) & = & 
\left( \begin{array}{ccc} 1 & 2 & 3 \\ 4 & 5 & 6 \\ 27 & 33 & 39 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt add\_to\_columns}, {\tt add\_to\_rows}, 
{\tt mult\_columns}, {\tt mult\_rows}.


\subsection{add\_rows}

\hspace*{0.175in} see: {\tt add\_columns}.


\subsection{add\_to\_columns, add\_to\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt add\_to\_columns(${\cal A}$,column\_list,expr);}

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$   &:-& a matrix. \\
column\_list &:-& a positive integer or a list of positive integers. \\
expr        &:-& a scalar expression.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt add\_to\_columns} adds expr to each column specified in 
column\_list of ${\cal A}$.  

{\tt add\_to\_rows} performs the equivalent task on the rows of 
${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}
\begin{array}{ccc}
{\tt add\_to\_columns}({\cal A},\{1,2\},10) & = & 
\left( \begin{array}{ccc} 11 & 12 & 3 \\ 14 & 15 & 6 \\ 17 & 18 & 9 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}
\begin{array}{ccc}
{\tt add\_to\_rows}({\cal A},2,-x) & = & 
\left( \begin{array}{ccc} 1 & 2 & 3 \\ -x+4 & -x+5 & -x+6 \\ 7 & 8 & 9 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} 
{\tt add\_columns}, {\tt add\_rows}, {\tt mult\_rows}, 
{\tt mult\_columns}.


\subsection{add\_to\_rows}

\hspace*{0.175in} see: {\tt add\_to\_columns}.


\subsection{augment\_columns, stack\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt augment\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$  &:-& a matrix. \\
column\_list &:-&  either a positive integer or a list of positive 
                   integers. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt augment\_columns} gets hold of the columns of ${\cal A}$ specified 
in column\_list and sticks them together. 

{\tt stack\_rows} performs the same task on rows of 
                ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\tt augment\_columns}({\cal A},\{1,2\}) & = & 
\left( \begin{array}{cc} 1 & 2 \\ 4 & 5 \\ 7 & 8  
\end{array} \right)  
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt stack\_rows}({\cal A},\{1,3\}) & = & 
\left( \begin{array}{ccc} 1 & 2 & 3 \\ 7 & 8 & 9
\end{array} \right)  
\end{array}  
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt get\_columns}, {\tt get\_rows}, 
{\tt sub\_matrix}.


\subsection{band\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt band\_matrix(expr\_list,square\_size);}

\hspace*{0.1in}
\begin{tabular}{l l l}
expr\_list  \hspace*{0.088in} &:-& \parbox[t]{.72\linewidth}
{either a single scalar expression or a list of an odd number of scalar
expressions.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
square\_size &:-& a positive integer.
\end{tabular}


{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt band\_matrix} creates a square matrix of dimension
                square\_size. The diagonal consists of the middle expr
                of the expr\_list. The exprs to the left of this fill
                the required number of sub\_diagonals and the exprs 
                to the right the super\_diagonals. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt band\_matrix}(\{x,y,z\},6) & = & 
\left( \begin{array}{cccccc} y & z & 0 & 0 & 0 & 0 \\ x & y & z & 0 & 0
& 0 \\ 0 & x & y & z & 0 & 0 \\ 0 & 0 & x & y & z & 0 \\ 0 & 0 & 0 & x &
 y & z \\ 0 & 0 & 0 & 0 & x & y 
\end{array} \right)
\end{array}  
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt diagonal}.


\subsection{block\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt block\_matrix(r,c,matrix\_list);}

\hspace*{0.1in}
\begin{tabular}{l l l}
r,c          &:-& positive integers. \\
matrix\_list &:-& a list of matrices. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt block\_matrix} creates a matrix that consists of r by c matrices 
filled from the matrix\_list row wise.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\cal B} = \left( \begin{array}{cc} 1 & 0 \\ 0 & 1
\end{array} \right), & 
{\cal C} = \left( \begin{array}{c} 5 \\ 5
\end{array} \right), &
{\cal D} = \left( \begin{array}{cc} 22 & 33 \\ 44 & 55
\end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.175in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt block\_matrix}(2,3,\{{\cal B,C,D,D,C,B}\}) & = & 
\left( \begin{array}{ccccc} 1 & 0 & 5 & 22 & 33 \\ 0 & 1 & 5 & 44 & 55 
\\
22 & 33 & 5 & 1 & 0 \\ 44 & 55 & 5 & 0 & 1
\end{array} \right)  
\end{array}  
\end{math}  
\end{flushleft}


\subsection{char\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt char\_matrix(${\cal A},\lambda$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a square matrix. \\
$\lambda$  &:-& a symbol or algebraic expression. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt char\_matrix} creates the characteristic matrix ${\cal C}$ of 
${\cal A}$.

This is ${\cal C} = \lambda * {\cal I} - {\cal A}$. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt char\_matrix}({\cal A},x) & = & 
\left( \begin{array}{ccc} x-1 & -2 & -3 \\ -4 & x-5 & -6 \\ -7 & -8 & 
x-9 
\end{array} \right)  
\end{array}  
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt char\_poly}. 


\subsection{char\_poly}

%{\bf How to use it:}

\hspace*{0.175in} {\tt char\_poly(${\cal A},\lambda$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a square matrix. \\
$\lambda$ &:-& a symbol or algebraic expression.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt char\_poly} finds the characteristic polynomial of
                ${\cal A}$.  

This is the determinant of $\lambda * {\cal I} - {\cal A}$.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in}
{\tt char\_poly({\cal A},$x$) $= x^3-15*x^2-18*x$} 

{\bf Related functions:}

\hspace*{0.175in} {\tt char\_matrix}. 


\subsection{cholesky}

%{\bf How to use it:}

\hspace*{0.175in} {\tt cholesky(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a positive definite matrix containing numeric entries.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt cholesky} computes the cholesky decomposition of ${\cal A}$.

It returns \{${\cal L,U}$\} where ${\cal L}$
is a lower matrix, ${\cal U}$ is an upper matrix, \\ ${\cal A} = 
{\cal LU}$, and ${\cal U} = {\cal L}^T$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal F} = \left( \begin{array}{ccc} 1 & 1 & 0 \\ 1 & 3 & 1 \\ 0 & 1 & 
1
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt cholesky}$({\cal F}) & = & 
\left\{ \left( \begin{array}{ccc} 1 & 0 & 0 \\ 1 & \sqrt{2} & 0 \\ 
0 & \frac{1}{\sqrt{2}} & \frac{1}{\sqrt{2}} \end{array} \right), \left( 
\begin{array}{ccc} 1 & 1 & 0 \\ 0 & \sqrt{2} & \frac{1}{\sqrt{2}} \\ 0 
& 0 & \frac{1}{\sqrt{2}} \end{array} \right)
\right\} \end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt lu\_decom}.


\subsection{coeff\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt coeff\_matrix(\{\lineqlist{}\});} 
\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\lineqlist  &:-& \parbox[t]{.435\linewidth}{linear equations. Can be 
of the form {\it equation $=$ number} or just {\it equation}.}
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt coeff\_matrix} creates the coefficient matrix 
                ${\cal C}$ of the linear equations. 

It returns \{${\cal C,X,B}$\} such that ${\cal CX} = {\cal B}$.

\end{addtolength}


{\bf Examples:}

\begin{math}
\hspace*{0.175in}
{\tt coeff\_matrix}(\{x+y+4*z=10,y+x-z=20,x+y+4\}) =  
\end{math}

\vspace*{0.1in}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
\left\{ \left( \begin{array}{ccc} 4 & 1 & 1 \\ -1 & 1 & 1 \\ 0 & 1 & 1 
\end{array} \right), \left( \begin{array}{c} z \\ y \\ x \end{array} 
\right), \left( \begin{array}{c} 10 \\ 20 \\ -4 
\end{array} \right) \right\} 
\end{math}  
\end{flushleft}

\subsection{column\_dim, row\_dim}

%{\bf How to use it:}

\hspace*{0.175in} {\tt column\_dim(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt column\_dim} finds the column dimension of 
                ${\cal A}$. 

\hspace*{0.175in} {\tt row\_dim} finds the row dimension of ${\cal A}$.

{\bf Examples:}

\hspace*{0.175in}
{\tt column\_dim}(${\cal A}$) = 3

\subsection{companion}

%{\bf How to use it:}

\hspace*{0.175in} {\tt companion(poly,x);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
poly &:-& a monic univariate polynomial in x. \\
x    &:-& the variable.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}


\begin{addtolength}{\leftskip}{0.22in}
                {\tt companion} creates the companion matrix ${\cal C}$
                of poly. 

This is the square matrix of dimension n, where n is the degree of poly 
w.r.t. x.

The entries of ${\cal C}$ are: 
                ${\cal C}$(i,n) = -coeffn(poly,x,i-1) for i = 1 
                \ldots n, ${\cal C}$(i,i-1) = 1 for i = 2 \ldots n and 
                the rest are 0.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt companion}(x^4+17*x^3-9*x^2+11,x) & = & 
\left( \begin{array}{cccc} 0 & 0 & 0 & -11 \\ 1 & 0 & 0 & 0 \\ 
0 & 1 & 0 & 9 \\ 0 & 0 & 1 & -17 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt find\_companion}.


\subsection{copy\_into}

%{\bf How to use it:}

\hspace*{0.175in} {\tt copy\_into(${\cal A,B}$,r,c);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A,B}$ &:-& matrices. \\
r,c          &:-& positive integers. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt copy\_into} copies matrix ${\cal A}$ into 
                ${\cal B}$ with ${\cal A}$(1,1) at ${\cal B}$(r,c).

{\bf Examples:} 

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal G} = \left( \begin{array}{cccc} 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 \\
0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt copy\_into}({\cal A,G},1,2) & = & 
\left( \begin{array}{cccc} 0 & 1 & 2 & 3 \\ 0 & 4 & 5 & 6 \\ 0 & 7 & 8 
& 9 \\ 0 & 0 & 0 & 0  
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt augment\_columns}, {\tt extend}, {\tt matrix\_augment}, 
{\tt matrix\_stack}, {\tt stack\_rows}, {\tt sub\_matrix}.

\end{addtolength}


\subsection{diagonal}

%{\bf How to use it:}

\hspace*{0.175in} {\tt diagonal(\{\matlist{}\});}\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\matlist &:-& \parbox[t]{.58\linewidth}{each can be either a scalar 
expr or a square matrix. }
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt diagonal} creates a matrix that contains the 
input on the diagonal.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal H} = \left( \begin{array}{cc} 66 & 77 \\ 88 & 99
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt diagonal}(\{{\cal A},x,{\cal H}\}) & = & 
\left( \begin{array}{cccccc} 1 & 2 & 3 & 0 & 0 & 0 \\ 4 & 5 & 6 & 0 & 0
& 0 \\ 7 & 8 & 9 & 0 & 0 & 0 \\ 0 & 0 & 0 & x & 0 & 0 \\ 0 & 0 & 0 & 0 
& 66 & 77 \\ 0 & 0 & 0 & 0 & 88 & 99 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt jordan\_block}.


\subsection{extend}

%{\bf How to use it:}

\hspace*{0.175in} {\tt extend(${\cal A}$,r,c,expr);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix. \\
r,c        &:-& positive integers. \\
expr      &:-& algebraic expression or symbol.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt extend} returns a copy of ${\cal A}$ that has been 
                extended by r rows and c columns. The new entries are
                made equal to expr.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt extend}({\cal A},1,2,x) & = & 
\left( \begin{array}{ccccc} 1 & 2 & 3 & x & x \\ 4 & 5 & 6 & x & x
\\ 7 & 8 & 9 & x & x \\ x & x & x & x & x 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\begin{addtolength}{\leftskip}{0.22in}
\parbox[t]{0.95\linewidth}{{\tt copy\_into}, {\tt matrix\_augment}, 
{\tt matrix\_stack}, {\tt remove\_columns}, {\tt remove\_rows}.}

\end{addtolength}


\subsection{find\_companion}

\hspace*{0.175in} {\tt find\_companion(${\cal A}$,x);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix. \\
x          &:-& the variable.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
  Given a companion matrix, {\tt find\_companion} finds the polynomial 
from which it was made.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal C} = \left( \begin{array}{cccc} 0 & 0 & 0 & -11 \\ 1 & 0 & 0 & 0 
\\ 0 & 1 & 0 & 9 \\ 0 & 0 & 1 & -17 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{3mm}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\tt find\_companion}({\cal C},x) = x^4+17*x^3-9*x^2+11
\end{math}  
\end{flushleft}

\vspace*{3mm}

{\bf Related functions:}

\hspace*{0.175in} {\tt companion}.

\subsection{get\_columns, get\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt get\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix. \\
c          &:-& either a positive integer or a list of positive 
                integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt get\_columns} removes the columns of ${\cal A}$ specified in 
                column\_list and returns them as a list of column 
                matrices. 

\end{addtolength}
\hspace*{0.175in} {\tt get\_rows} performs the same task on the rows of 
                ${\cal A}$. 

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt get\_columns}({\cal A},\{1,3\}) & = & 
\left\{ 
        \left( \begin{array}{c} 1 \\ 4 \\ 7 \end{array} \right),
        \left( \begin{array}{c} 3 \\ 6 \\ 9 \end{array} \right) 
\right\} 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt get\_rows}({\cal A},2) & = & 
\left\{ 
        \left( \begin{array}{ccc} 4 & 5 & 6 \end{array} \right)
\right\} 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt augment\_columns}, {\tt stack\_rows}, 
{\tt sub\_matrix}.


\subsection{get\_rows}

\hspace*{0.175in} see: {\tt get\_columns}.


\subsection{gram\_schmidt}

%{\bf How to use it:}

\hspace*{0.175in} {\tt gram\_schmidt(\{\veclist{}\});} \lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\veclist &:-& \parbox[t]{.62\linewidth}{linearly independent vectors.
                             Each vector must be written as a list, 
                             eg:\{1,0,0\}. }
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt gram\_schmidt} performs the gram\_schmidt 
                orthonormalisation on the input vectors. 

It returns a list of orthogonal normalised vectors.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in}
{\tt gram\_schmidt(\{\{1,0,0\},\{1,1,0\},\{1,1,1\}\})} = 
\{\{1,0,0\},\{0,1,0\},\{0,0,1\}\}

\hspace*{0.175in}
{\tt gram\_schmidt(\{\{1,2\},\{3,4\}\})} $= 
\{\{ \frac{1}{{\sqrt{5}}} , \frac{2}{\sqrt{5}} \},
\{ \frac{2*\sqrt{5}}{5} , \frac{-\sqrt{5}}{5} \}\}$

\subsection{hermitian\_tp}

%{\bf How to use it:}

\hspace*{0.175in} {\tt hermitian\_tp(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt hermitian\_tp} computes the hermitian transpose of 
                ${\cal A}$. 

This is a matrix in which the (i,$\,$j)'th entry is the conjugate of 
the (j,$\,$i)'th entry of ${\cal A}$. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal J} = \left( \begin{array}{ccc} i+1 & i+2 & i+3 \\ 4 & 5 & 2 \\ 1 &
i & 0 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt hermitian\_tp}({\cal J}) & = & 
\left( \begin{array}{ccc} -i+1 & 4 & 1 \\ -i+2 & 5 & -i \\-i+3 & 2 & 0
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}                   

{\bf Related functions:}

\hspace*{0.175in} {\tt tp}\footnote{standard reduce call for the 
transpose of a matrix - see {\REDUCE} User's Manual[2].}.


\subsection{hessian}

%{\bf How to use it:}

\hspace*{0.175in} {\tt hessian(expr,variable\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr           &:-& a scalar expression. \\
variable\_list &:-& either a single variable or a list of variables.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt hessian} computes the hessian matrix of expr w.r.t.
                the varibles in variable\_list. 

This is an n by n matrix
                where n is the number of variables and the (i,$\,$j)'th 
                entry is df(expr,variable\_list(i),variable\_list(j)).

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt hessian}(x*y*z+x^2,\{w,x,y,z\}) & = & 
\left( \begin{array}{cccc} 0 & 0 & 0 & 0 \\ 0 & 2 & z & y \\ 0 & z & 0 
& x \\ 0 & y & x & 0
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}


{\bf Related functions:}

\hspace*{0.175in} {\tt df}\footnote{standard reduce call for 
differentiation - see {\REDUCE} User's Manual[2]}.


\subsection{hilbert}

%{\bf How to use it:}

\hspace*{0.175in} {\tt hilbert(square\_size,expr);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
square\_size &:-& a positive integer. \\
expr         &:-& an algebraic expression.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt hilbert} computes the square hilbert matrix of 
                dimension square\_size. 

This is the symmetric matrix in
                which the (i,$\,$j)'th entry is 1/(i+j-expr).

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt hilbert}(3,y+x) & = & 
\left( \begin{array}{ccc} \frac{-1}{x+y-2} & \frac{-1}{x+y-3} 
& \frac{-1}{x+y-4} \\ \frac{-1}{x+y-3} & \frac{-1}{x+y-4} & 
\frac{-1}{x+y-5} \\ \frac{-1}{x+y-4} & \frac{-1}{x+y-5} & 
\frac{-1}{x+y-6} 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}


\subsection{jacobian}

%{\bf How to use it:}

\hspace*{0.175in} {\tt jacobian(expr\_list,variable\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr\_list   \hspace*{0.175in}  &:-& \parbox[t]{.72\linewidth}{either a 
single algebraic expression or a list of algebraic expressions.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
variable\_list &:-& either a single variable or a list of variables.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt jacobian} computes the jacobian matrix of expr\_list w.r.t. 
variable\_list. 

This is a matrix whose (i,$\,$j)'th entry is df(expr\_list(i),
variable\_list(j)).

The matrix is n by m where n is the 
                number of variables and m the number of expressions.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in} 
{\tt jacobian(\{$x^4,x*y^2,x*y*z^3$\},\{$w,x,y,z$\})} = 

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}        
\left( \begin{array}{cccc} 0 & 4*x^3 & 0 & 0 \\ 0 & y^2 & 2*x*y & 0 \\ 
0 & y*z^3 & x*z^3 & 3*x*y*z^2 
\end{array} \right)
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt hessian}, {\tt df}\footnote{standard reduce call 
for differentiation - see {\REDUCE} User's Manual[2].}.


\subsection{jordan\_block}

%{\bf How to use it:}

\hspace*{0.175in} {\tt jordan\_block(expr,square\_size);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr        &:-& an algebraic expression or symbol. \\
square\_size &:-& a positive integer.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt jordan\_block} computes the square jordan block matrix ${\cal J}$
                of dimension square\_size. 

The entries of ${\cal J}$ are:
                ${\cal J}$(i,i) = expr for i=1 
                \ldots n, ${\cal J}$(i,i+1) = 1 for i=1 
                \ldots n-1, and all other entries are 0.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt jordan\_block(x,5)} & = & 
\left( \begin{array}{ccccc} x & 1 & 0 & 0 & 0 \\ 0 & x & 1 & 0 & 0 \\ 0 
& 0 & x & 1 & 0 \\ 0 & 0 & 0 & x & 1 \\ 0 & 0 & 0 & 0 & x
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt diagonal}, {\tt companion}.


\subsection{lu\_decom}

%{\bf How to use it:}

\hspace*{0.175in} {\tt lu\_decom(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& \parbox[t]{.848\linewidth}{a matrix containing either 
numeric entries or imaginary entries with numeric coefficients.}
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
              {\tt lu\_decom} performs LU decomposition on ${\cal A}$,
              ie: it returns \{${\cal L,U}$\} where ${\cal L}$
              is a lower diagonal matrix, ${\cal U}$ an upper diagonal
              matrix and ${\cal A} = {\cal LU}$.

\end{addtolength}

{\bf caution:}

\begin{addtolength}{\leftskip}{0.22in}
The algorithm used can swap the rows of ${\cal A}$ 
                during the calculation. This means that ${\cal LU}$ does
                not equal ${\cal A}$ but a row equivalent of it. Due to
                this, {\tt lu\_decom} returns \{${\cal L,U}$,vec\}. The
                call {\tt convert(${\cal A}$,vec)} will return the 
                matrix that has been decomposed, ie: ${\cal LU} = $
                {\tt convert(${\cal A}$,vec)}.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal K} = \left( \begin{array}{ccc} 1 & 3 & 5 \\ -4 & 3 & 7 \\ 8 & 6 & 
4
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{cccc}
${\tt lu} := {\tt lu\_decom}$({\cal K}) & = & 
\left\{ 
        \left( \begin{array}{ccc} 8 & 0 & 0 \\ -4 & 6 & 0 \\ 1 & 2.25 & 
1.125 1 \end{array} \right), 
        \left( \begin{array}{ccc} 1 & 0.75 & 0.5 \\ 0 & 1 & 1.5 \\ 0 & 
0 & 1 \end{array} \right), 
	[\; 3 \; 2 \; 3 \; ]
\right\} 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt first lu * second lu}$ & = & 
        \left( \begin{array}{ccc} 8 & 6 & 4 \\ -4 & 3 & 7 \\ 1 & 3 & 5
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt convert(${\cal K}$,third lu}$) \hspace*{0.055in} & = & 
        \left( \begin{array}{ccc} 8 & 6 & 4 \\ -4 & 3 & 7 \\ 1 & 3 & 5
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.5in}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal P} = \left( \begin{array}{ccc} i+1 & i+2 & i+3 \\ 4 & 5 & 2 \\ 1 
& i & 0
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{eqnarray}
\hspace*{0.22in}
{\tt lu} := {\tt lu\_decom}({\cal P}) & = & 
\left\{ 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 4 & -4*i+5 & 0 \\ i+1 & 
3 & 0.41463*i+2.26829 \end{array} \right), \right. \nonumber \\ & & 
\left. \: \; \,  \left( \begin{array}{ccc} 1 & i & 0 \\ 0 & 1 & 
0.19512*i+0.24390 \\ 0 & 0 & 1 \end{array} \right), \hspace*{0.05in} 
[\; 3 \; 2 \; 3 \;] \hspace*{0.05in}
\right\} \nonumber
\end{eqnarray}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt first lu * second lu}$ & = & 
        \left( \begin{array}{ccc} 1 & i & 0 \\ 4 & 5 & 2 \\ i+1 & i+2 &
i+3 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt convert({\cal P},third lu}$) \hspace*{0.1in} & = & \left( 
\begin{array}{c c c} 1 & i & 0 \\ 4 & 5 & 2 \\ i+1 & i+2 & i+3 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt cholesky}.


\subsection{make\_identity}

%{\bf How to use it:}

\hspace*{0.175in} {\tt make\_identity(square\_size);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
square\_size &:-& a positive integer.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt make\_identity} creates the identity matrix of 
                dimension square\_size.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt make\_identity}(4) & = & 
        \left( \begin{array}{cccc} 1 & 0 & 0 & 0 \\ 0 & 1 & 0 & 0 \\ 0 
& 0 & 1 & 0 \\ 0 & 0 & 0 & 1
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt diagonal}.


\subsection{matrix\_augment, matrix\_stack}

%{\bf How to use it:}

\hspace*{0.175in} {\tt matrix\_augment(\{\matlist\});}\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\matlist &:-& matrices.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt matrix\_augment} sticks the matrices in 
                  matrix\_list together horizontally. 

\hspace*{0.175in} 
{\tt matrix\_stack} sticks the matrices in matrix\_list 
                together vertically.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt matrix\_augment}(\{{\cal A,A}\}) & = & 
        \left( \begin{array}{cccccc} 1 & 2 & 3 & 1 & 2 & 3 \\ 4 & 4 & 6 
& 4 & 5 & 6 \\ 7 & 8 & 9 & 7 & 8 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt matrix\_stack}(\{{\cal A,A}\}) & = & 
        \left( \begin{array}{ccc} 1 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 9 
\\ 1 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 9 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt augment\_columns}, {\tt stack\_rows}, 
{\tt sub\_matrix}.


\subsection{matrixp}

%{\bf How to use it:}

\hspace*{0.175in} {\tt matrixp(test\_input);}

\hspace*{0.1in}  
\begin{tabular}{l l l}
test\_input &:-& anything you like.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt matrixp} is a boolean function that returns t if 
                the input is a matrix and nil otherwise.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in} {\tt matrixp}(${\cal A}$) = t 

\hspace*{0.175in} {\tt matrixp}(doodlesackbanana) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt squarep}, {\tt symmetricp}.


\subsection{matrix\_stack}

\hspace*{0.175in} see: {\tt matrix\_augment}.


\subsection{minor}

%{\bf How to use it:}

\hspace*{0.175in} {\tt minor(${\cal A}$,r,c);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix. \\
r,c        &:-& positive integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt minor} computes the (r,c)'th minor of ${\cal A}$.
 
                This is created by removing the r'th row and the c'th 
                column from ${\cal A}$.

\end{addtolength}
                
{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt minor}({\cal A},1,3) & = & 
        \left( \begin{array}{cc} 4 & 5 \\ 7 & 8
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt remove\_columns}, {\tt remove\_rows}.


\subsection{mult\_columns, mult\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt mult\_columns(${\cal A}$,column\_list,expr);}

\hspace*{0.1in}  
\begin{tabular}{l l l}
${\cal A}$   &:-& a matrix. \\
column\_list &:-& a positive integer or a list of positive integers. \\
expr        &:-& an algebraic expression.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt mult\_columns} returns a copy of ${\cal A}$ in which
                the columns specified in column\_list have been 
multiplied by expr. 

{\tt mult\_rows} performs the same task on the rows of ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt mult\_columns}({\cal A},\{1,3\},x) & = & 
        \left( \begin{array}{ccc} x & 2 & 3*x \\ 4*x & 5 & 6*x \\ 7*x & 
8 & 9*x 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt mult\_rows}({\cal A},2,10) & = & 
        \left( \begin{array}{ccc} 1 & 2 & 3 \\ 40 & 50 & 60 \\ 7 & 8 & 
9 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt add\_to\_columns}, {\tt add\_to\_rows}.


\subsection{\tt mult\_rows}

\hspace*{0.175in} see: {\tt mult\_columns}.


\subsection{pivot}

%{\bf How to use it:}

\hspace*{0.175in} {\tt pivot(${\cal A}$,r,c);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix. \\
r,c        &:-& positive integers such that ${\cal A}$(r,c) neq 0.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt pivot} pivots ${\cal A}$ about its (r,c)'th entry.
 
To do this, multiples of the r'th row are added to every
     other row in the matrix. 

This means that the c'th column
                will be 0 except for the (r,c)'th entry. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt pivot}({\cal A},2,3) & = & 
        \left( \begin{array}{ccc} -1 & -0.5 & 0 \\ 4 & 5 & 6 \\ 1 & 0.5 
& 0
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt rows\_pivot}.


\subsection{pseudo\_inverse}

%{\bf How to use it:}

\hspace*{0.175in} {\tt pseudo\_inverse(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt pseudo\_inverse}, also known as the Moore-Penrose inverse, computes
the pseudo inverse of ${\cal A}$. 

Given the singular value decomposition of ${\cal A}$, i.e: ${\cal A} = 
{\cal U} 
\sum {\cal V}^T$, then the pseudo inverse ${\cal A}^{-1}$ is defined 
by ${\cal A}^{-1} = {\cal V}^T \sum^{-1} {\cal U}$.

Thus ${\cal A}$ $ * $ {\tt pseudo\_inverse}$({\cal A}) = {\cal I}$.

\end{addtolength}

{\bf Examples:}

% \begin{flushleft}
% \hspace*{0.175in}
% \begin{math}
% {\cal R} = \left( \begin{array}{cccc} 1 & 2 & 3 & 4 \\ 9 & 8 & 7 & 6
% \end{array} \right)
% \end{math}
% \end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt pseudo\_inverse}({\cal A}) & = & 
        \left( \begin{array}{cc} -0.2 & 0.1 \\ -0.05 & 0.05 \\ 0.1 & 0 
\\ 0.25 & -0.05 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt svd}.

\subsection{random\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt random\_matrix(r,c,limit);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
r,c,$\,$limit &:-& positive integers. \\
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt random\_matrix} creates an r by c matrix with random
                entries in the range $-$limit $<$ entry $<$ limit.

\end{addtolength}

{\bf switches:}

\hspace*{0.1in} 
\begin{tabular}{l l l}
{\tt imaginary} \hspace*{0.175in} &:-& \parbox[t]{0.685\linewidth}{if 
on then matrix entries are x+i$*$y where $-$limit $<$ x,y $<$ limit.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
{\tt not\_negative} &:-& \parbox[t]{0.685\linewidth}{if on then 0 $<$ 
entry $<$ limit. In the imaginary case we have 0 $<$ x,y $<$ limit.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
{\tt only\_integer} &:-& \parbox[t]{0.685\linewidth}{if on then each 
entry is an integer. In the imaginary case x and y are integers.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
{\tt symmetric} &:-& if on then the matrix is symmetric. \\
{\tt upper\_matrix} &:-& \parbox[t]{0.685\linewidth}{if on then the 
matrix is upper triangular.} \\
{\tt lower\_matrix} &:-& if on then the matrix is lower triangular.
\end{tabular}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt random\_matrix}(3,3,10) & = & 
        \left( \begin{array}{ccc} -4.729721 & 6.987047 & 7.521383 \\
- 5.224177 & 5.797709 & - 4.321952 \\
- 9.418455 & - 9.94318 & - 0.730980
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.2in}
\hspace*{0.165in}
{\tt on only\_integer, not\_negative, upper\_matrix, imaginary;}
\begin{flushleft}  
\hspace*{0.12in}
\begin{math}        
\begin{array}{ccc}
{\tt random\_matrix}(4,4,10) & = & 
\left( \begin{array}{cccc} 2*i+5 & 3*i+7 & 7*i+3 & 6 \\ 0 & 2*i+5 & 
5*i+1 & 2*i+1 \\ 0 & 0 & 8 & i \\ 0 & 0 & 0& 5*i+9 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}


\subsection{remove\_columns, remove\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt remove\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$   &:-& a matrix. \\
column\_list &:-& either a positive integer or a list of 
                  positive integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt remove\_columns} removes the columns specified in
                column\_list from ${\cal A}$. 

\hspace*{0.175in} {\tt remove\_rows} performs the same task on the rows 
                of ${\cal A}$.

{\bf Examples:} 

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt remove\_columns}({\cal A},2) & = & 
        \left( \begin{array}{cc} 1 & 3 \\ 4 & 6 \\ 7 & 9  
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt remove\_rows}({\cal A},\{1,3\}) & = & 
        \left( \begin{array}{ccc} 4 & 5 & 6
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}


{\bf Related functions:}

\hspace*{0.175in} {\tt minor}.


\subsection{remove\_rows}

\hspace*{0.175in} see: {\tt remove\_columns}.


\subsection{row\_dim}

\hspace{0.175in} see: {\tt column\_dim}.


\subsection{rows\_pivot}

%{\bf How to use it:}

\hspace*{0.175in} {\tt rows\_pivot(${\cal A}$,r,c,\{row\_list\});}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix. \\
r,c        &:-& positive integers such that ${\cal A}$(r,c) neq 0.\\
row\_list  &:-& positive integer or a list of positive integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt rows\_pivot} performs the same task as {\tt pivot} but applies 
the pivot only to the rows specified in row\_list.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal N} = \left( \begin{array}{ccc} 1 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 
9 \\1 & 2 & 3 \\ 4 & 5 & 6
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt rows\_pivot}({\cal N},2,3,\{4,5\}) & = & \left( \begin{array}
{c c c}1 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 9 \\ -0.75 & 0 & 0.75 \\ 
-0.375 & 0 & 0.375 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt pivot}.


\subsection{simplex}

%{\bf How to use it:}

\hspace*{0.175in} {\tt simplex(max/min,objective function,\{linear 
inequalities\});}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
max/min             & :- & \parbox[t]{.63\linewidth}{either max or min 
                           (signifying maximise and minimise).} \\
objective function  & :- & the function you are maximising or 
                           minimising. \\
linear inequalities & :- & \parbox[t]{.63\linewidth}{the constraint 
                           inequalities. Each one must be of the form 
                           {\it sum of variables ($<=,=,>=$) number}.}
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt simplex} applies the revised simplex algorithm to find the 
optimal(either maximum or minimum) value of the objective function 
under the linear inequality constraints.

It returns \{optimal value,\{ values of variables at this optimal\}\}.

The algorithm implies that all the variables are non-negative.

\end{addtolength}

{\bf Examples:}

\begin{addtolength}{\leftskip}{0.22in}
%\begin{math}
{\tt simplex($max,x+y,\{x>=10,y>=20,x+y<=25\}$);}
%\end{math}

{\tt ***** Error in simplex: Problem has no feasible solution.}

\vspace*{0.2in}

\parbox[t]{0.96\linewidth}{\tt simplex($max,10x+5y+5.5z,\{5x+3z<=200,
x+0.1y+0.5z<=12$,\\
\hspace*{0.55in} $0.1x+0.2y+0.3z<=9, 30x+10y+50z<=1500\}$);}

\vspace*{0.1in}
{\tt $\{525.0,\{x=40.0,y=25.0,z=0\}$\}}

\end{addtolength}


\subsection{squarep}

%{\bf How to use it:}

\hspace*{0.175in} {\tt squarep(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt squarep} is a boolean function that returns t if 
                the matrix is square and nil otherwise.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal L} = \left( \begin{array}{ccc} 1 & 3 & 5 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\hspace*{0.175in} {\tt squarep}(${\cal A}$) = t 

\hspace*{0.175in} {\tt squarep}(${\cal L}$) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt matrixp}, {\tt symmetricp}.


\subsection{stack\_rows}

\hspace*{0.175in} see: {\tt augment\_columns}.


\subsection{sub\_matrix}

%{\bf How to use it:}

\hspace*{0.175in} {\tt sub\_matrix(${\cal A}$,row\_list,column\_list);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$              &:-& a matrix. \\
row\_list, column\_list &:-& \parbox[t]{.605\linewidth}{either a 
positive integer or a list of positive integers.}
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}


\begin{addtolength}{\leftskip}{0.22in}

{\tt sub\_matrix} produces the matrix consisting of the
              intersection of the rows specified in row\_list and the 
columns specified in column\_list. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt sub\_matrix}({\cal A},\{1,3\},\{2,3\}) & = & 
        \left( \begin{array}{cc} 2 & 3 \\ 8 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt augment\_columns}, {\tt stack\_rows}.


\subsection{svd (singular value decomposition)}

%{\bf How to use it:}

\hspace*{0.175in} {\tt svd(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix containing only numeric entries.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt svd} computes the singular value decomposition of ${\cal A}$. 

It returns \{${\cal U},\sum,{\cal V}$\} where ${\cal A} = {\cal U} 
\sum {\cal V}^T$ and $\sum = diag(\sigma_{1}, \ldots ,\sigma_{n}). \; 
\sigma_{i}$ for $i= (1 \ldots n)$ are the singular values of ${\cal A}$.
 

n is the column dimension of ${\cal A}$.

The singular values of ${\cal A}$ are the non-negative square roots of 
the eigenvalues of ${\cal A}^T {\cal A}$. 

${\cal U}$ and ${\cal V}$ are such that ${\cal UU}^T = {\cal VV}^T = 
{\cal V}^T {\cal V} = {\cal I}_n$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal Q} = \left( \begin{array}{cc} 1 & 3 \\ -4 & 3 
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{eqnarray}
\hspace*{0.1in}
{\tt svd({\cal Q})} & = & 
\left\{ 
        \left( \begin{array}{cc} 0.289784 & 0.957092 \\ -0.957092 & 
0.289784 \end{array} \right), \left( \begin{array}{cc} 5.149162 & 0 \\ 
0 & 2.913094 \end{array} \right), \right. \nonumber \\ & & \left. \: \; 
\, \left( \begin{array}{cc} -0.687215 & 0.726453 \\ -0.726453 & 
-0.687215 \end{array} \right)       
\right\} \nonumber
\end{eqnarray}


\subsection{swap\_columns, swap\_rows}

%{\bf How to use it:}

\hspace*{0.175in} {\tt swap\_columns(${\cal A}$,c1,c2);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a matrix. \\
c1,c1      &:-& positive integers. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} 
{\tt swap\_columns} swaps column c1 of ${\cal A}$ with column c2. 

\hspace*{0.175in} {\tt swap\_rows} performs the same task on 2 rows of 
                ${\cal A}$.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt swap\_columns}({\cal A},2,3) & = & 
        \left( \begin{array}{ccc} 1 & 3 & 2 \\ 4 & 6 & 5 \\ 7 & 9 & 8
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt swap\_entries}.


\subsection{swap\_entries}

%{\bf How to use it:}

\hspace*{0.175in} {\tt swap\_entries(${\cal A}$,\{r1,c1\},\{r2,c2\});}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$  &:-& a matrix. \\
r1,c1,r2,c2 &:-& positive integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt swap\_entries} swaps ${\cal A}$(r1,c1) with 
                ${\cal A}$(r2,c2).

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt swap\_entries}({\cal A},\{1,1\},\{3,3\}) & = & 
        \left( \begin{array}{ccc} 9 & 2 & 3 \\ 4 & 5 & 6 \\ 7 & 8 & 1
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt swap\_columns}, {\tt swap\_rows}.


\subsection{swap\_rows}

\hspace*{0.175in} see: {\tt swap\_columns}.


\subsection{symmetricp}

%{\bf How to use it:}

\hspace*{0.175in} {\tt symmetricp(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt symmetricp} is a boolean function that returns t if the 
                matrix is symmetric and nil otherwise.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal M} = \left( \begin{array}{cc} 1 & 2 \\ 2 & 1 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\hspace*{0.175in} {\tt symmetricp}(${\cal A}$) = nil 

\hspace*{0.175in} {\tt symmetricp}(${\cal M}$) = t

{\bf Related functions:}

\hspace*{0.175in} {\tt matrixp}, {\tt squarep}.


\subsection{toeplitz}

%{\bf How to use it:}

\hspace*{0.175in} {\tt toeplitz(\{\exprlist{}\});} \lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\exprlist{} &:-& algebraic expressions.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt toeplitz} creates the toeplitz matrix from the 
                expression list. 

This is a square symmetric matrix in 
                which the first expression is placed on the diagonal 
                and the i'th expression is placed on the (i-1)'th sub 
                and super diagonals.

It has dimension n where n is the 
                number of expressions.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt toeplitz}(\{w,x,y,z\}) & = & 
        \left( \begin{array}{cccc} w & x & y & z \\ x & w & x & y \\
      y & x & w & x \\ z & y & x & w
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\subsection{triang\_adjoint}

%{\bf How to use it:}
\hspace*{0.175in} {\tt triang\_adjoint(${\cal A}$);}

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$  &:-& a matrix.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}


\begin{addtolength}{\leftskip}{0.22in}
{\tt triang\_adjoint} computes the triangularizing adjoint ${\cal F}$ of
matrix ${\cal A}$ due to the algorithm of Arne Storjohann. ${\cal F}$ is
lower triangular matrix and the resulting matrix ${\cal T}$ of
${\cal F * A = T}$ is upper triangular with the property that the $i$-th
entry in the diagonal of ${\cal T}$ is the determinant of the principal
$i$-th submatrix of the matrix ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\tt triang\_adjoint}({\cal A}) & = &
\left( \begin{array}{ccc} 1 & 0 & 0 \\ -4 & 1 & 0 \\ -3 & 6 & -3
\end{array} \right)
\end{array}
\end{math}
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\cal F} * {\cal A} & = &
\left( \begin{array}{ccc} 1 & 2 & 3 \\ 0 & -3 & -6 \\ 0 & 0 & 0
\end{array} \right)
\end{array}
\end{math}
\end{flushleft}

\subsection{Vandermonde}

%{\bf How to use it:}

\hspace*{0.175in} {\tt vandermonde}(\{\exprlist{}\}); \addtocounter
{footnote}{-1}\footnotemark
%\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\exprlist{} &:-& algebraic expressions.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}  

\begin{addtolength}{\leftskip}{0.22in}
{\tt Vandermonde} creates the Vandermonde matrix from
                the expression list. 

This is the square matrix in which
                the (i,$\,$j)'th entry is expr\_list(i) $^{(j-1)}$.

It has dimension n where n is the number of expressions.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt vandermonde}(\{x,2*y,3*z\}) & = & 
        \left( \begin{array}{ccc} 1 & x & x^2 \\ 1 & 2*y & 4*y^2 \\ 1 
& 3*z & 9*z^2 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\subsection{kronecker\_product}

\hspace*{0.175in} {\tt kronecker\_product}($Mat_1,Mat_2$)

\hspace*{0.1in}
\begin{tabular}{l l l}
$Mat_1,Mat_2$ &:-& Matrices
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt kronecker\_product} creates a matrix containing the Kronecker product 
(also called {\tt direct product} or {\tt tensor product}) of its arguments.

\end{addtolength}

{\bf Examples:}
\begin{verbatim}
a1 := mat((1,2),(3,4),(5,6))$
a2 := mat((1,1,1),(2,z,2),(3,3,3))$
kronecker_product(a1,a2);
\end{verbatim}
\begin{flushleft}
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
\left( \begin{array}{cccccc} 1 & 1 & 1 & 2 & 2 & 2 \\
2 &  z & 2 & 4  &2*z &4 \\
3 &  3 & 3 & 6  & 6  &6 \\
3 &  3 & 3 & 4  & 4  &4 \\
6 & 3*z& 6 & 8  &4*z &8 \\
9 &  9 & 9 & 12 &12  &12\\
5 &  5 & 5 & 6  & 6  &6 \\
10 &5*z& 10& 12 &6*z &12 \\ 
15 &15 & 15& 18 &18  &18 \end{array} \right)
\end{array}
\end{math}
\end{flushleft}

\section{Fast Linear Algebra}

By turning the {\tt fast\_la} switch on, the speed of the following 
functions will be increased:

\begin{tabular}{l l l l}
   add\_columns    & add\_rows      & augment\_columns & column\_dim  \\
   copy\_into      & make\_identity & matrix\_augment  & matrix\_stack\\
   minor           & mult\_column   &  mult\_row       & pivot        \\
   remove\_columns & remove\_rows   & rows\_pivot      & squarep      \\
   stack\_rows     & sub\_matrix    & swap\_columns    & swap\_entries\\
   swap\_rows      & symmetricp                                     
\end{tabular}

The increase in speed will be insignificant unless you are making a 
significant number(i.e: thousands) of calls. When using this switch, 
error checking is minimised. This means that illegal input may give
strange error messages. Beware.

\newpage

\section{Acknowledgments}

Many of the ideas for this package came from the Maple[3] Linalg package
[4].

The algorithms for {\tt cholesky}, {\tt lu\_decom}, and {\tt svd} are 
taken from the book Linear Algebra - J.H. Wilkinson \& C. Reinsch[5].

The {\tt gram\_schmidt} code comes from Karin Gatermann's Symmetry 
package[6] for {\REDUCE}.


\begin{thebibliography}{}
\bibitem{matt} Matt Rebbeck: NORMFORM: A {\REDUCE} package for the 
computation of various matrix normal forms. ZIB, Berlin. (1993)
\bibitem{Reduce} Anthony C. Hearn: {\REDUCE} User's Manual 3.6.
	RAND (1995)
\bibitem{Maple} Bruce W. Char\ldots [et al.]: Maple (Computer 
        Program). Springer-Verlag (1991)
\bibitem{linalg} Linalg - a linear algebra package for Maple[3].
\bibitem{WiRe} J. H. Wilkinson \& C. Reinsch: Linear Algebra 
(volume II). Springer-Verlag (1971)
\bibitem{gat} Karin Gatermann: Symmetry: A {\REDUCE} package for the 
computation of linear representations of groups. ZIB, Berlin. (1992)
\end{thebibliography}

\end{document}



mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/cholesky.red0000644000175000017500000001176711526203062024303 0ustar  giovannigiovannimodule cholesky;

%**********************************************************************%
%                                                                      %
% Computation of the Cholesky decomposition of dense positive definite %
% matrices containing numeric entries.                                 %
%                                                                      %
% Author: Matt Rebbeck, May 1994.                                      %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%                                                                      %
% NB: By using the same rounded number techniques as used in svd this  %
%     could be made a lot faster.                                      %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




symbolic procedure cholesky(mat1);
  %
  % A must be a positive definite symmetric matrix.
  %
  % LU decomposition of matrix A. ie: A=LU, where U is the transpose
  % of L. The determinant of A is also computed as a side effect but
  % has been commented out as it is not necessary. The procedure will
  % fail if A is unsymmetric. It will also fail if A, modified by
  % rounding errors, is not positive definite.
  %
  % The reciprocals of the diagonal elements are stored in p and the
  % matrix is then 'dragged' out and 'glued' back together in get_l.
  %
  %
  begin
    scalar x,p,in_mat,L,U,I_turned_rounded_on;  % d1,d2;
    integer i,j,n;
    if not !*rounded then << I_turned_rounded_on := t; on rounded; >>;
    if not matrixp(mat1) then
     rederr "Error in cholesky:  non matrix input.";
    if not symmetricp(mat1) then
     rederr "Error in cholesky: input matrix is not symmetric.";
    in_mat := copy_mat(mat1);
    n := first size_of_matrix(in_mat);
    p := mkvect(n);
%    d1 := 1;
%    d2 := 0;
    for i:=1:n do
    <<
      for j:=i:n do
      <<
        x := innerprod(1,1,i-1,{'minus,getmat(in_mat,i,j)},
                       row_vec(in_mat,i,n),row_vec(in_mat,j,n));
        x := reval{'minus,x};
        if j=i then
        <<
%          d1 := reval{'times,d1,x};
          if get_num_part(my_reval(x))<=0 then rederr
           "Error in cholesky: input matrix is not positive definite.";
%          while abs(get_num_part(d1)) >= 1 do
%          <<
%            d1 := reval{'times,d1,0.0625};
%            d2 := d2+4;
%          >>;
%          while abs(get_num_part(d1)) < 0.0625 do
%          <<
%            d1 := reval{'times,d1,16};
%            d2 := d2-4;
%          >>;
          putv(p,i,reval{'quotient,1,{'sqrt,x}});
        >>
        else
        <<
          setmat(in_mat,j,i,reval{'times,x,getv(p,i)});
        >>;
      >>;
    >>;
    L := get_l(in_mat,p,n);
    U := algebraic tp(L);
    if I_turned_rounded_on then off rounded;
    return {'list,L,U};
  end;

flag('(cholesky),'opfn);  % So it can be used from algebraic mode.



symbolic procedure get_l(in_mat,p,sq_size);
  %
  % Pulls out L from in_mat and p.
  %
  begin
    scalar L;
    integer i,j;
    L := mkmatrix(sq_size,sq_size);
    for i:=1:sq_size do
    <<
      setmat(L,i,i,{'quotient,1,getv(p,i)});
      for j:=1:i-1 do
      <<
        setmat(L,i,j,getmat(in_mat,i,j));
      >>;
    >>;
    return L;
  end;



symbolic procedure symmetricp(in_mat);
  %
  % Checks input is symmetric. ie: transpose(A) = A. (boolean).
  %
  if algebraic (tp(in_mat)) neq in_mat then nil else t;

flag('(symmetricp),'boolean);
flag('(symmetricp),'opfn);


endmodule;  % cholesky.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/linalg/linalg.tst0000644000175000017500000001671711526203062023770 0ustar  giovannigiovanniif lisp !*rounded then rounded_was_on := t 
 else rounded_was_on := nil;

mat1  := mat((1,2,3,4,5),(2,3,4,5,6),(3,4,5,6,7),(4,5,6,7,8),(5,6,7,8,9));
mat2  := mat((1,1,1,1),(2,2,2,2),(3,3,3,3),(4,4,4,4));
mat3  := mat((x),(x),(x),(x));
mat4  := mat((3,3),(4,4),(5,5),(6,6)); 
mat5  := mat((1,2,1,1),(1,2,3,1),(4,5,1,2),(3,4,5,6));
mat6  := mat((i+1,i+2,i+3),(4,5,2),(1,i,0));
mat7  := mat((1,1,0),(1,3,1),(0,1,1));
mat8  := mat((1,3),(-4,3));
mat9 :=  mat((1,2,3,4),(9,8,7,6));
poly  := x^7+x^5+4*x^4+5*x^3+12;
poly1 := x^2+x*y^3+x*y*z^3+y*x+2+y*3;

on errcont;


% Basis matrix manipulations.

add_columns(mat1,1,2,5*y);
add_rows(mat1,1,2,x);

add_to_columns(mat1,3,1000);
add_to_columns(mat1,{1,2,3},y);
add_to_rows(mat1,2,1000);
add_to_rows(mat1,{1,2,3},x);

augment_columns(mat1,2);  
augment_columns(mat1,{1,2,5});
stack_rows(mat1,3);  
stack_rows(mat1,{1,3,5});  

char_poly(mat1,x);

column_dim(mat2);
row_dim(mat1);

copy_into(mat7,mat1,2,3);
copy_into(mat7,mat1,5,5);

diagonal(3);
% diagonal can take both a list of arguments or just the arguments.
diagonal({mat2,mat6});
diagonal(mat1,mat2,mat5);

extend(mat1,3,2,x);

find_companion(mat5,x);

get_columns(mat1,1);
get_columns(mat1,{1,2});
get_rows(mat1,3);
get_rows(mat1,{1,3});

hermitian_tp(mat6);

% matrix_augment and matrix_stack can take both a list of arguments 
% or just the arguments.
matrix_augment({mat1,mat2});
matrix_augment(mat4,mat2,mat4);
matrix_stack(mat1,mat2);
matrix_stack({mat6,mat((z,z,z)),mat7});

minor(mat1,2,3);

mult_columns(mat1,3,y);
mult_columns(mat1,{2,3,4},100);
mult_rows(mat1,2,x);
mult_rows(mat1,{1,3,5},10);

pivot(mat1,3,3);
rows_pivot(mat1,3,3,{1,5});

remove_columns(mat1,3);
remove_columns(mat1,{2,3,4});
remove_rows(mat1,2);
remove_rows(mat1,{1,3});
remove_rows(mat1,{1,2,3,4,5});

swap_columns(mat1,2,4);
swap_rows(mat1,1,2);
swap_entries(mat1,{1,1},{5,5});


% Constructors - functions that create matrices.

band_matrix(x,5);
band_matrix({x,y,z},6);

block_matrix(1,2,{mat1,mat2});
block_matrix(2,3,{mat2,mat3,mat2,mat3,mat2,mat2});

char_matrix(mat1,x);

cfmat := coeff_matrix({x+y+4*z=10,y+x-z=20,x+y+4});
first cfmat * second cfmat;
third cfmat;

companion(poly,x);

hessian(poly1,{w,x,y,z});

hilbert(4,1);
hilbert(3,y+x);

% NOTE WELL. The function tested here used to be called just "jacobian"
% however us of that name was in conflict with another Reduce package so
% now it is called mat_jacobian.
mat_jacobian({x^4,x*y^2,x*y*z^3},{w,x,y,z});

jordan_block(x,5);

make_identity(11);

on rounded; % makes things a bit easier to read.
random_matrix(3,3,100);
on not_negative;
random_matrix(3,3,100);
on only_integer;
random_matrix(3,3,100);
on symmetric;
random_matrix(3,3,100);
off symmetric;
on upper_matrix;
random_matrix(3,3,100);
off upper_matrix;
on lower_matrix;
random_matrix(3,3,100);
off lower_matrix;
on imaginary;
off not_negative;
random_matrix(3,3,100);
off rounded;

% toeplitz and vandermonde can take both a list of arguments or just 
% the arguments.
toeplitz({1,2,3,4,5});
toeplitz(x,y,z);

vandermonde({1,2,3,4,5});
vandermonde(x,y,z);

% kronecker_product

a1 := mat((1,2),(3,4),(5,6));
a2 := mat((1,x,1),(2,2,2),(3,3,3));

kronecker_product(a1,a2);

clear a1,a2;

% High level algorithms.

on rounded; % makes output easier to read.
ch := cholesky(mat7);
tp first ch - second ch;
tmp := first ch * second ch;
tmp - mat7;
off rounded;

gram_schmidt({1,0,0},{1,1,0},{1,1,1});
gram_schmidt({1,2},{3,4});

on rounded; % again, makes large quotients a bit more readable.
% The algorithm used for lu_decom sometimes swaps the rows of the input 
% matrix so that (given matrix A, lu_decom(A) = {L,U,vec}), we find L*U 
% does not equal A but a row equivalent of it. The call convert(A,vec) 
% will return this row equivalent (ie: L*U = convert(A,vec)).
lu := lu_decom(mat5); 
mat5;
tmp := first lu * second lu;
tmp1 := convert(mat5,third lu);
tmp - tmp1;
% and the complex case...
lu1 := lu_decom(mat6);
mat6;
tmp := first lu1 * second lu1;
tmp1 := convert(mat6,third lu1);
tmp - tmp1;

mat9inv := pseudo_inverse(mat9);
mat9 * mat9inv;

simplex(min,2*x1+14*x2+36*x3,{-2*x1+x2+4*x3>=5,-x1-2*x2-3*x3<=2});

simplex(max,10000 x1 + 1000 x2 + 100 x3 + 10 x4 + x5,{ x1 <= 1, 20 x1 +
 x2 <= 100, 200 x1 + 20 x2 + x3 <= 10000, 2000 x1 + 200 x2 + 20 x3 + x4
 <= 1000000, 20000 x1 + 2000 x2 + 200 x3 + 20 x4 + x5 <= 100000000});

simplex(max, 5 x1 + 4 x2 + 3 x3,
           { 2 x1 + 3 x2 + x3 <= 5, 
             4 x1 + x2 + 2 x3 <= 11, 
             3 x1 + 4 x2 + 2 x3 <= 8 });

simplex(min,3 x1 + 5 x2,{ x1 + 2 x2 >= 2, 22 x1 + x2 >= 3});

simplex(max,10x+5y+5.5z,{5x+3z<=200,0.2x+0.1y+0.5z<=12,0.1x+0.2y+0.3z<=9,
                         30x+10y+50z<=1500});

%example of extra variables (>=0) being added.
simplex(min,x-y,{x>=-3});

% unfeasible as simplex algorithm implies all x>=0.
simplex(min,x,{x<=-100});

% three error examples.
simplex(maxx,x,{x>=5});
simplex(max,x,x>=5);
simplex(max,x,{x<=y});

simplex(max, 346 X11 + 346 X12 + 248 X21 + 248 X22 + 399 X31 + 399 X32 + 
             200 Y11 + 200 Y12 + 75 Y21 + 75 Y22 + 2.35 Z1 + 3.5 Z2,
{ 
 4 X11 + 4 X12 + 2 X21 + 2 X22 + X31 + X32 + 250 Y11 + 250 Y12 + 125 Y21 + 
  125 Y22 <= 25000,
 X11 + X12 + X21 + X22 + X31 + X32 + 2 Y11 + 2 Y12 + Y21 + Y22 <= 300,
 20 X11 + 15 X12 + 30 Y11 + 20 Y21 + Z1 <= 1500,
 40 X12 + 35 X22 + 50 X32 + 15 Y12 + 10 Y22 + Z2  = 5000,
 X31  = 0,
 Y11 + Y12 <= 50,
 Y21 + Y22 <= 100
});


% from Marc van Dongen. Finding the first feasible solution for the 
% solution of systems of linear diophantine inequalities.
simplex(max,0,{
  3*X259+4*X261+3*X262+2*X263+X269+2*X270+3*X271+4*X272+5*X273+X229=2,
  7*X259+11*X261+8*X262+5*X263+3*X269+6*X270+9*X271+12*X272+15*X273+X229=4,
  2*X259+5*X261+4*X262+3*X263+3*X268+4*X269+5*X270+6*X271+7*X272+8*X273=1,
  X262+2*X263+5*X268+4*X269+3*X270+2*X271+X272+2*X229=1,
  X259+X262+2*X263+4*X268+3*X269+2*X270+X271-X273+3*X229=2,
  X259+2*X261+2*X262+2*X263+3*X268+3*X269+3*X270+3*X271+3*X272+3*X273+X229=1,
  X259+X261+X262+X263+X268+X269+X270+X271+X272+X273+X229=1});

svd_ans := svd(mat8);
tmp := tp first svd_ans * second svd_ans * third svd_ans;
tmp - mat8;

mat9inv := pseudo_inverse(mat9);
mat9 * mat9inv;

% triang_adjoint(in_mat) calculates the
% triangularizing adjoint of in_mat

triang_adjoint(mat1);
triang_adjoint(mat2);
triang_adjoint(mat5);
triang_adjoint(mat6);
triang_adjoint(mat7);
triang_adjoint(mat8);
triang_adjoint(mat9);

% testing triang_adjoint with random matrices

% the range of the integers is in one case from
% -1000 to 1000. in the other case it is from
% -1 to 1 so that the deteminant of the i-th
% submatrix equals very often to zero.

% random matrix contains arbitrary real values
off only_integer;
tmp:=random_matrix(5,5,1000);
triang_adjoint tmp;

tmp:=random_matrix(1,1,1000);
triang_adjoint tmp;

% random matrix contains complex real values
on imaginary;
tmp:=random_matrix(5,5,1000);
triang_adjoint tmp;

tmp:=random_matrix(1,1,1000);
triang_adjoint tmp;
off imaginary;

% random matrix contains rounded real values
on rounded;
tmp:=random_matrix(5,5,1000);
triang_adjoint tmp;

tmp:=random_matrix(1,1,1000);
triang_adjoint tmp;
off rounded;

% random matrix contains only integer values
on only_integer;
tmp:=random_matrix(7,7,1000);
triang_adjoint tmp;

tmp:=random_matrix(7,7,1);
triang_adjoint tmp;

% random matrix contains only complex integer
% values

on imaginary;
tmp:=random_matrix(5,5,1000);
triang_adjoint tmp;

tmp:=random_matrix(5,5,2);
triang_adjoint tmp;

% Predicates.

matrixp(mat1);
matrixp(poly);

squarep(mat2);
squarep(mat3);

symmetricp(mat1);
symmetricp(mat3);

if not rounded_was_on then off rounded;


END;


mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/0000755000175000017500000000000011722677357021437 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide1.red0000644000175000017500000000255611526203062023107 0ustar  giovannigiovannimodule fide1;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(fide1 expres iimet),'(contrib fide));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide.rlg0000644000175000017500000031513511527635055023054 0ustar  giovannigiovanniFri Feb 18 21:27:51 2011 run on win32
%***********************************************************************
%*****                                                             *****
%***** Package  F I D E - Test Examples Ver. 1.1.2 May 29,1995     *****
%*****                                                             *****
%***********************************************************************
%***********************************************************************
%*****                                                             *****
%*****    T e s t     Examples   ---   Module    E X P R E S       *****
%*****                                                             *****
%***********************************************************************

let cos th**2=1 - sin th**2,
    cos fi**2=1 - sin fi**2;


factor df;


on rat;


for all x,y let diff(x,y)=df(x,y);


depend u,r,th,fi;


depend v,r,th,fi;


depend f,r,th,fi;


depend w,r,th,fi;


% Spherical coordinate system
scalefactors 3,r*sin th*cos fi,r*sin th*sin fi,r*cos th,r,th,fi;


tensor a1,a2,a3,a4,a5;


vectors u,v;


dyads w;


a1:=grad f;

a1:= ( df(f,r) , 

        df(f,th)
       ---------- , 
           r

        df(f,fi)
       ----------- ) 
        sin(th)*r


a2:=div u;

     df(u(3),fi)     df(u(2),th)                  cos(th)*u(2) + 2*sin(th)*u(1)
a2:=------------- + ------------- + df(u(1),r) + -------------------------------
      sin(th)*r           r                                 sin(th)*r


a3:=curl v;

        df(v(3),th)      - df(v(2),fi)     cos(th)*v(3)
a3:= ( ------------- + ---------------- + -------------- , 
             r            sin(th)*r         sin(th)*r

                        df(v(1),fi)      - v(3)
        - df(v(3),r) + ------------- + --------- , 
                         sin(th)*r         r

                      - df(v(1),th)     v(2)
       df(v(2),r) + ---------------- + ------ ) 
                           r             r


a4:=lapl v;

         - 2*df(v(3),fi)      - 2*df(v(2),th)     df(v(1),fi,2)
a4:= ( ------------------ + ------------------ + --------------- + df(v(1),r,2)
                    2                2                    2  2
           sin(th)*r                r              sin(th) *r

           2*df(v(1),r)     df(v(1),th,2)     df(v(1),th)*cos(th)
        + -------------- + --------------- + ---------------------
                r                 2                        2
                                 r                sin(th)*r

           2*(cos(th)*v(2) + sin(th)*v(1))
        - --------------------------------- , 
                              2
                     sin(th)*r

         - 2*df(v(3),fi)*cos(th)     df(v(2),fi,2)
       -------------------------- + --------------- + df(v(2),r,2)
                     2  2                    2  2
              sin(th) *r              sin(th) *r

           2*df(v(2),r)     df(v(2),th,2)     df(v(2),th)*cos(th)
        + -------------- + --------------- + ---------------------
                r                 2                        2
                                 r                sin(th)*r

           2*df(v(1),th)        - v(2)
        + --------------- + ------------- , 
                 2                  2  2
                r            sin(th) *r

        df(v(3),fi,2)                    2*df(v(3),r)     df(v(3),th,2)
       --------------- + df(v(3),r,2) + -------------- + ---------------
                2  2                          r                 2
         sin(th) *r                                            r

           df(v(3),th)*cos(th)     2*df(v(2),fi)*cos(th)     2*df(v(1),fi)
        + --------------------- + ----------------------- + ---------------
                        2                      2  2                    2
               sin(th)*r                sin(th) *r            sin(th)*r

              - v(3)
        + ------------- ) 
                  2  2
           sin(th) *r


a3:=2*a3+a4;

         - 2*df(v(3),fi)     2*df(v(3),th)      - 2*df(v(2),fi)
a3:= ( ------------------ + --------------- + ------------------
                    2              r              sin(th)*r
           sin(th)*r

            - 2*df(v(2),th)     df(v(1),fi,2)                    2*df(v(1),r)
        + ------------------ + --------------- + df(v(1),r,2) + --------------
                   2                    2  2                          r
                  r              sin(th) *r

           df(v(1),th,2)     df(v(1),th)*cos(th)
        + --------------- + ---------------------
                 2                        2
                r                sin(th)*r

           2*(cos(th)*v(3)*r - cos(th)*v(2) - sin(th)*v(1))
        + -------------------------------------------------- , 
                                       2
                              sin(th)*r

         - 2*df(v(3),fi)*cos(th)                    df(v(2),fi,2)
       -------------------------- - 2*df(v(3),r) + ---------------
                     2  2                                   2  2
              sin(th) *r                             sin(th) *r

                          2*df(v(2),r)     df(v(2),th,2)
        + df(v(2),r,2) + -------------- + ---------------
                               r                 2
                                                r

           df(v(2),th)*cos(th)     2*df(v(1),fi)     2*df(v(1),th)
        + --------------------- + --------------- + ---------------
                        2            sin(th)*r             2
               sin(th)*r                                  r

                       2
            - 2*sin(th) *v(3)*r - v(2)
        + ----------------------------- , 
                          2  2
                   sin(th) *r

        df(v(3),fi,2)                    2*df(v(3),r)     df(v(3),th,2)
       --------------- + df(v(3),r,2) + -------------- + ---------------
                2  2                          r                 2
         sin(th) *r                                            r

           df(v(3),th)*cos(th)     2*df(v(2),fi)*cos(th)
        + --------------------- + ----------------------- + 2*df(v(2),r)
                        2                      2  2
               sin(th)*r                sin(th) *r

                                                           2
           2*df(v(1),fi)      - 2*df(v(1),th)     2*sin(th) *v(2)*r - v(3)
        + --------------- + ------------------ + -------------------------- ) 
                     2              r                          2  2
            sin(th)*r                                   sin(th) *r


a5:=lapl f;

     df(f,fi,2)                  2*df(f,r)     df(f,th,2)     df(f,th)*cos(th)
a5:=------------- + df(f,r,2) + ----------- + ------------ + ------------------
            2  2                     r              2                     2
     sin(th) *r                                    r             sin(th)*r


a1:=a1+div w;

        df(w(3,1),fi)     df(w(2,1),th)
a1:= ( --------------- + --------------- + df(w(1,1),r) + df(f,r)
          sin(th)*r             r

           cos(th)*w(2,1) - sin(th)*w(3,3) - sin(th)*w(2,2) + 2*sin(th)*w(1,1)
        + ---------------------------------------------------------------------
                                        sin(th)*r

        , 

        df(w(3,2),fi)     df(w(2,2),th)                    df(f,th)
       --------------- + --------------- + df(w(1,2),r) + ---------- + 
          sin(th)*r             r                             r

         - cos(th)*w(3,3) + cos(th)*w(2,2) + sin(th)*w(2,1) + 2*sin(th)*w(1,2)
       ------------------------------------------------------------------------
                                      sin(th)*r

        , 

        df(w(3,3),fi)     df(w(2,3),th)                    df(f,fi)
       --------------- + --------------- + df(w(1,3),r) + -----------
          sin(th)*r             r                          sin(th)*r

           cos(th)*w(3,2) + cos(th)*w(2,3) + sin(th)*w(3,1) + 2*sin(th)*w(1,3)
        + ---------------------------------------------------------------------
                                        sin(th)*r

     ) 


a1:=u.dyad((a,0,1),(1,b,3),(0,c,d));

a1:= ( u(2) + u(1)*a , 

       u(3)*c + u(2)*b , 

       u(3)*d + 3*u(2) + u(1) ) 


a2:=vect(a,b,c);

a2:= ( a , 

       b , 

       c ) 


a1.a2;

                                     2                    2
u(3)*b*c + u(3)*c*d + u(2)*a + u(2)*b  + 3*u(2)*c + u(1)*a  + u(1)*c


%  Scalar product
u.v;

u(3)*v(3) + u(2)*v(2) + u(1)*v(1)


%  Vector product
u?v;

 (  - u(3)*v(2) + u(2)*v(3) , 

   u(3)*v(1) - u(1)*v(3) , 

    - u(2)*v(1) + u(1)*v(2) ) 


%  Dyadic
u&v;

 (  ( u(1)*v(1) , 

      u(1)*v(2) , 

      u(1)*v(3) )  , 

    ( u(2)*v(1) , 

      u(2)*v(2) , 

      u(2)*v(3) )  , 

    ( u(3)*v(1) , 

      u(3)*v(2) , 

      u(3)*v(3) )  ) 


%  Directional derivative
dirdf(u,v);

    df(v(1),fi)*u(3)                       df(v(1),th)*u(2)
 ( ------------------ + df(v(1),r)*u(1) + ------------------
       sin(th)*r                                  r

       u(3)*v(3) + u(2)*v(2)
    - ----------------------- , 
                 r

    df(v(2),fi)*u(3)                       df(v(2),th)*u(2)
   ------------------ + df(v(2),r)*u(1) + ------------------
       sin(th)*r                                  r

        - cos(th)*u(3)*v(3) + sin(th)*u(2)*v(1)
    + ------------------------------------------ , 
                      sin(th)*r

    df(v(3),fi)*u(3)                       df(v(3),th)*u(2)
   ------------------ + df(v(3),r)*u(1) + ------------------
       sin(th)*r                                  r

       u(3)*(cos(th)*v(2) + sin(th)*v(1))
    + ------------------------------------ ) 
                   sin(th)*r


clear a1,a2,a3,a4,a5,u,v,w;


for all x,y clear diff(x,y);


clear cos th**2,
      cos fi**2;


remfac df;


off rat;


scalefactors 3,x,y,z,x,y,z;



%***********************************************************************
%*****                                                             *****
%*****      T e s t     Examples   ---   Module    I I M E T       *****
%*****                                                             *****
%***********************************************************************

% Example I.1 - 1-D Lagrangian Hydrodynamics

off exp;


factor diff;


on rat,eqfu;



% Declare which indexes will be given to coordinates
coordinates x,t into j,m;



% Declares uniform grid in x coordinate
grid uniform,x;



% Declares dependencies of functions on coordinates
dependence eta(t,x),v(t,x),eps(t,x),p(t,x);



% Declares p as known function
given p;



same eta,v,p;



iim a, eta,diff(eta,t)-eta*diff(v,x)=0,
    v,diff(v,t)+eta/ro*diff(p,x)=0,
    eps,diff(eps,t)+eta*p/ro*diff(v,x)=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(eta,t) - diff(v,x)*eta    =    0

 diff(p,x)*eta
--------------- + diff(v,t)    =    0
      ro

               diff(v,x)*eta*p
diff(eps,t) + -----------------    =    0
                     ro


 Backtracking needed in grid optimalization
0 interpolations are needed in x coordinate
  Equation for eta variable is integrated in half grid point
  Equation for v variable is integrated in half grid point
  Equation for eps variable is integrated in half grid point
0 interpolations are needed in t coordinate
  Equation for eta variable is integrated in half grid point
  Equation for v variable is integrated in half grid point
  Equation for eps variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

(4*(eta(j,m + 1) - eta(j,m) - eta(j + 1,m) + eta(j + 1,m + 1))*hx - (

    (eta(j + 1,m + 1) + eta(j,m + 1))*(v(j + 1,m + 1) - v(j,m + 1))

     + (eta(j + 1,m) + eta(j,m))*(v(j + 1,m) - v(j,m)))*(ht(m + 1) + ht(m)))/(4

   *(ht(m + 1) + ht(m))*hx)   =   0


(4*(v(j,m + 1) - v(j,m) - v(j + 1,m) + v(j + 1,m + 1))*hx*ro + (

    (eta(j + 1,m + 1) + eta(j,m + 1))*(p(j + 1,m + 1) - p(j,m + 1))

     + (eta(j + 1,m) + eta(j,m))*(p(j + 1,m) - p(j,m)))*(ht(m + 1) + ht(m)))/(4

   *(ht(m + 1) + ht(m))*hx*ro)   =   0


(4*(eps(j,m + 1) - eps(j,m) - eps(j + 1,m) + eps(j + 1,m + 1))*hx*ro + (

    (eta(j + 1,m + 1)*p(j + 1,m + 1) + eta(j,m + 1)*p(j,m + 1))

    *(v(j + 1,m + 1) - v(j,m + 1))

     + (eta(j + 1,m)*p(j + 1,m) + eta(j,m)*p(j,m))*(v(j + 1,m) - v(j,m)))

 *(ht(m + 1) + ht(m)))/(4*(ht(m + 1) + ht(m))*hx*ro)   =   0




clear a;


clearsame;


cleargiven;



%***********************************************************************

% Example  I.2 - How other functions (here sin, cos) can be used in
%                discretized terms

diffunc sin,cos;


difmatch all,diff(u*sin x,x),u=one,2,(u(i+1)*sin x(i+1)-u(i-1)
                   *sin x(i-1))/(dim1+dip1),
                 u=half,0,(u(i+1/2)*sin x(i+1/2)-u(i-1/2)*sin x(i-1/2))
                   /di;


difmatch all,cos x*diff(u,x,2),u=one,0,cos x i*(u(i+1)-2*u(i)+u(i-1))
                   /di^2,
                 u=half,3,(u(i+3/2)-u(i+1/2))/dip2/2 -
                          (u(i-1/2)-u(i-3/2))/dim2/2;


off exp;


coordinates x,t into j,m;


grid uniform,x,t;


dependence u(x,t),v(x,t);


iim a,u,diff(u,t)+diff(u,x)+cos x*diff(v,x,2)=0,
      v,diff(v,t)+diff(sin x*u,x)=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(u,t) + diff(u,x) + diff(v,x,2)*cos(x)    =    0

diff(sin(x)*u,x) + diff(v,t)    =    0


0 interpolations are needed in x coordinate
  Equation for u variable is integrated in half grid point
  Equation for v variable is integrated in half grid point
0 interpolations are needed in t coordinate
  Equation for u variable is integrated in half grid point
  Equation for v variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

           2*j + 1              2*j + 1           2*j + 3
 - ((2*(v(---------,m + 1) + v(---------,m)) - v(---------,m)
              2                    2                 2

           2*j + 3              2*j - 1          2*j - 1
      - v(---------,m + 1) - v(---------,m) - v(---------,m + 1))
              2                    2                2

            2*j + 1
    *cos(x(---------))*ht + (
               2

       (u(j,m + 1) + u(j,m) - u(j + 1,m) - u(j + 1,m + 1))*ht

                                                                              2
        - (u(j,m + 1) - u(j,m) - u(j + 1,m) + u(j + 1,m + 1))*hx)*hx)/(2*ht*hx )

   =   0


( - ((u(j,m + 1) + u(j,m))*sin(x(j))*ht

              2*j + 1              2*j + 1
      - 2*(v(---------,m + 1) - v(---------,m))*hx)
                 2                    2

  + (u(j + 1,m + 1) + u(j + 1,m))*sin(x(j + 1))*ht)/(2*ht*hx)   =   0



clear a;



%***********************************************************************

% Example I.3 - Schrodinger equation

factor diff;


coordinates t,x into m,j;


grid uniform,x,t;


dependence ur(x,t),ui(x,t);


same ui,ur;


iim a,ur,-diff(ui,t)+1/2*diff(ur,x,2)+(ur**2+ui**2)*ur=0,
       ui,diff(ur,t)+1/2*diff(ui,x,2)+(ur**2+ui**2)*ui=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

                 diff(ur,x,2)                   2     2
 - diff(ui,t) + --------------    =     - ur*(ui  + ur )
                      2

 diff(ui,x,2)                                2     2
-------------- + diff(ur,t)    =     - ui*(ui  + ur )
      2


0 interpolations are needed in t coordinate
  Equation for ur variable is integrated in half grid point
  Equation for ui variable is integrated in half grid point
0 interpolations are needed in x coordinate
  Equation for ur variable is integrated in one grid point
  Equation for ui variable is integrated in one grid point

         Equations after Discretization Using IIM :
         ==========================================

((ur(m,j + 1) - 2*ur(m,j) + ur(m,j - 1) - 2*ur(m + 1,j) + ur(m + 1,j + 1)

                                                       2          2
   + ur(m + 1,j - 1))*ht - 4*(ui(m + 1,j) - ui(m,j))*hx )/(4*ht*hx )   =   

               3          3          2                      2
    ur(m + 1,j)  + ur(m,j)  + ui(m,j) *ur(m,j) + ui(m + 1,j) *ur(m + 1,j)
 - -----------------------------------------------------------------------
                                      2


((ui(m,j + 1) - 2*ui(m,j) + ui(m,j - 1) - 2*ui(m + 1,j) + ui(m + 1,j + 1)

                                                       2          2
   + ui(m + 1,j - 1))*ht + 4*(ur(m + 1,j) - ur(m,j))*hx )/(4*ht*hx )   =   

                2              2                        2          2
    (ui(m + 1,j)  + ur(m + 1,j) )*ui(m + 1,j) + (ui(m,j)  + ur(m,j) )*ui(m,j)
 - ---------------------------------------------------------------------------
                                        2



clear a;


clearsame;



%***********************************************************************

% Example I.4 - Vector calculus in p.d.e. input
%               cooperation with expres module
%               2-D hydrodynamics

scalefactors 2,x,y,x,y;


vectors u;


off exp,twogrid;


on eqfu;


factor diff,ht,hx,hy;


coordinates x,y,t into j,i,m;


grid uniform,x,y,t;


dependence n(t,x,y),u(t,x,y),p(t,x,y);


iim a,n,diff(n,t)+u.grad n+n*div u=0,
     u,m*n*(diff(u,t)+u.grad u)+grad p=vect(0,0),
     p,3/2*(diff(p,t)+u.grad p)+5/2*p*div u=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(n,t) + diff(n,x)*u1 + diff(n,y)*u2 + diff(u1,x)*n + diff(u2,y)*n    =    0

diff(p,x) + diff(u1,t)*m*n + diff(u1,x)*m*n*u1 + diff(u1,y)*m*n*u2    =    0

diff(p,y) + diff(u2,t)*m*n + diff(u2,x)*m*n*u1 + diff(u2,y)*m*n*u2    =    0

 3*diff(p,t)     3*diff(p,x)*u1     3*diff(p,y)*u2     5*diff(u1,x)*p
------------- + ---------------- + ---------------- + ----------------
      2                2                  2                  2

    5*diff(u2,y)*p
 + ----------------    =    0
          2


0 interpolations are needed in x coordinate
  Equation for n variable is integrated in half grid point
  Equation for u1 variable is integrated in half grid point
  Equation for u2 variable is integrated in half grid point
  Equation for p variable is integrated in half grid point
0 interpolations are needed in y coordinate
  Equation for n variable is integrated in half grid point
  Equation for u1 variable is integrated in half grid point
  Equation for u2 variable is integrated in half grid point
  Equation for p variable is integrated in half grid point
0 interpolations are needed in t coordinate
  Equation for n variable is integrated in half grid point
  Equation for u1 variable is integrated in half grid point
  Equation for u2 variable is integrated in half grid point
  Equation for p variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

   -1   -1
(hy  *hx  *(n(j + 1,i + 1,m + 1)*u1(j + 1,i + 1,m + 1)*hy

             + n(j + 1,i + 1,m + 1)*u2(j + 1,i + 1,m + 1)*hx

             + n(j + 1,i + 1,m)*u1(j + 1,i + 1,m)*hy

             + n(j + 1,i + 1,m)*u2(j + 1,i + 1,m)*hx

             + n(j + 1,i,m + 1)*u1(j + 1,i,m + 1)*hy

             - n(j + 1,i,m + 1)*u2(j + 1,i,m + 1)*hx

             + n(j + 1,i,m)*u1(j + 1,i,m)*hy - n(j + 1,i,m)*u2(j + 1,i,m)*hx

             - n(j,i + 1,m + 1)*u1(j,i + 1,m + 1)*hy

             + n(j,i + 1,m + 1)*u2(j,i + 1,m + 1)*hx

             - n(j,i + 1,m)*u1(j,i + 1,m)*hy + n(j,i + 1,m)*u2(j,i + 1,m)*hx

             - n(j,i,m + 1)*u1(j,i,m + 1)*hy - n(j,i,m + 1)*u2(j,i,m + 1)*hx

                                                                      -1
             - n(j,i,m)*u1(j,i,m)*hy - n(j,i,m)*u2(j,i,m)*hx))/4 + (ht  *(

      n(j,i,m + 1) - n(j,i,m) - n(j,i + 1,m) + n(j,i + 1,m + 1) - n(j + 1,i,m)

       + n(j + 1,i,m + 1) - n(j + 1,i + 1,m) + n(j + 1,i + 1,m + 1)))/4   =   0


   -1
(hx  *((n(j + 1,i,m + 1)*u1(j + 1,i,m + 1) + n(j,i,m + 1)*u1(j,i,m + 1))

       *(u1(j + 1,i,m + 1) - u1(j,i,m + 1)) + 

       (n(j + 1,i,m)*u1(j + 1,i,m) + n(j,i,m)*u1(j,i,m))

       *(u1(j + 1,i,m) - u1(j,i,m)) + 

       (n(j + 1,i + 1,m)*u1(j + 1,i + 1,m) + n(j,i + 1,m)*u1(j,i + 1,m))

       *(u1(j + 1,i + 1,m) - u1(j,i + 1,m)) + (

          n(j + 1,i + 1,m + 1)*u1(j + 1,i + 1,m + 1)

           + n(j,i + 1,m + 1)*u1(j,i + 1,m + 1))

                                                               -1   -1   -1
       *(u1(j + 1,i + 1,m + 1) - u1(j,i + 1,m + 1)))*m)/8 + (hy  *hx  *ht  *(((

            (n(j,i + 1,m + 1) + n(j,i + 1,m))

            *(u1(j,i + 1,m + 1) - u1(j,i + 1,m))

             + (n(j,i,m + 1) + n(j,i,m))*(u1(j,i,m + 1) - u1(j,i,m)) + 

            (n(j + 1,i,m + 1) + n(j + 1,i,m))

            *(u1(j + 1,i,m + 1) - u1(j + 1,i,m)) + 

            (n(j + 1,i + 1,m + 1) + n(j + 1,i + 1,m))

            *(u1(j + 1,i + 1,m + 1) - u1(j + 1,i + 1,m)))*hx*m + 2*(

            p(j + 1,i,m + 1) + p(j + 1,i,m) + p(j + 1,i + 1,m)

             + p(j + 1,i + 1,m + 1)

             - (p(j,i,m + 1) + p(j,i,m) + p(j,i + 1,m) + p(j,i + 1,m + 1)))*ht)

      *hy + ((n(j,i + 1,m + 1)*u2(j,i + 1,m + 1) + n(j,i,m + 1)*u2(j,i,m + 1))

             *(u1(j,i + 1,m + 1) - u1(j,i,m + 1)) + 

             (n(j,i + 1,m)*u2(j,i + 1,m) + n(j,i,m)*u2(j,i,m))

             *(u1(j,i + 1,m) - u1(j,i,m)) + 

             (n(j + 1,i + 1,m)*u2(j + 1,i + 1,m) + n(j + 1,i,m)*u2(j + 1,i,m))

             *(u1(j + 1,i + 1,m) - u1(j + 1,i,m)) + (

                n(j + 1,i + 1,m + 1)*u2(j + 1,i + 1,m + 1)

                 + n(j + 1,i,m + 1)*u2(j + 1,i,m + 1))

             *(u1(j + 1,i + 1,m + 1) - u1(j + 1,i,m + 1)))*ht*hx*m))/8   =   0


   -1   -1
(hy  *hx  *(((n(j + 1,i,m + 1)*u1(j + 1,i,m + 1) + n(j,i,m + 1)*u1(j,i,m + 1))

             *(u2(j + 1,i,m + 1) - u2(j,i,m + 1)) + 

             (n(j + 1,i,m)*u1(j + 1,i,m) + n(j,i,m)*u1(j,i,m))

             *(u2(j + 1,i,m) - u2(j,i,m)) + 

             (n(j + 1,i + 1,m)*u1(j + 1,i + 1,m) + n(j,i + 1,m)*u1(j,i + 1,m))

             *(u2(j + 1,i + 1,m) - u2(j,i + 1,m)) + (

                n(j + 1,i + 1,m + 1)*u1(j + 1,i + 1,m + 1)

                 + n(j,i + 1,m + 1)*u1(j,i + 1,m + 1))

             *(u2(j + 1,i + 1,m + 1) - u2(j,i + 1,m + 1)))*hy + (

               (n(j,i + 1,m + 1)*u2(j,i + 1,m + 1) + n(j,i,m + 1)*u2(j,i,m + 1))

               *(u2(j,i + 1,m + 1) - u2(j,i,m + 1)) + 

               (n(j,i + 1,m)*u2(j,i + 1,m) + n(j,i,m)*u2(j,i,m))

               *(u2(j,i + 1,m) - u2(j,i,m)) + 

               (n(j + 1,i + 1,m)*u2(j + 1,i + 1,m) + n(j + 1,i,m)*u2(j + 1,i,m))

               *(u2(j + 1,i + 1,m) - u2(j + 1,i,m)) + (

                  n(j + 1,i + 1,m + 1)*u2(j + 1,i + 1,m + 1)

                   + n(j + 1,i,m + 1)*u2(j + 1,i,m + 1))

                                                                              -1
               *(u2(j + 1,i + 1,m + 1) - u2(j + 1,i,m + 1)))*hx)*m)/8 + ( - hy

      -1
   *ht  *(2*(p(j,i,m + 1) + p(j,i,m) - p(j,i + 1,m) - p(j,i + 1,m + 1)

              + p(j + 1,i,m) + p(j + 1,i,m + 1) - p(j + 1,i + 1,m)

              - p(j + 1,i + 1,m + 1))*ht - ((n(j,i + 1,m + 1) + n(j,i + 1,m))

             *(u2(j,i + 1,m + 1) - u2(j,i + 1,m))

              + (n(j,i,m + 1) + n(j,i,m))*(u2(j,i,m + 1) - u2(j,i,m)) + 

             (n(j + 1,i,m + 1) + n(j + 1,i,m))

             *(u2(j + 1,i,m + 1) - u2(j + 1,i,m)) + 

             (n(j + 1,i + 1,m + 1) + n(j + 1,i + 1,m))

             *(u2(j + 1,i + 1,m + 1) - u2(j + 1,i + 1,m)))*hy*m))/8   =   0


   -1   -1
(hy  *hx  *(3*((p(j + 1,i,m + 1) - p(j,i,m + 1))

               *(u1(j + 1,i,m + 1) + u1(j,i,m + 1))

                + (p(j + 1,i,m) - p(j,i,m))*(u1(j + 1,i,m) + u1(j,i,m)) + 

               (p(j + 1,i + 1,m) - p(j,i + 1,m))

               *(u1(j + 1,i + 1,m) + u1(j,i + 1,m)) + 

               (p(j + 1,i + 1,m + 1) - p(j,i + 1,m + 1))

               *(u1(j + 1,i + 1,m + 1) + u1(j,i + 1,m + 1)))*hy + 2*(

               4*p(j + 1,i + 1,m + 1)*u2(j + 1,i + 1,m + 1)

                - p(j + 1,i + 1,m + 1)*u2(j + 1,i,m + 1)

                + 4*p(j + 1,i + 1,m)*u2(j + 1,i + 1,m)

                - p(j + 1,i + 1,m)*u2(j + 1,i,m)

                + p(j + 1,i,m + 1)*u2(j + 1,i + 1,m + 1)

                - 4*p(j + 1,i,m + 1)*u2(j + 1,i,m + 1)

                + p(j + 1,i,m)*u2(j + 1,i + 1,m) - 4*p(j + 1,i,m)*u2(j + 1,i,m)

                + 4*p(j,i + 1,m + 1)*u2(j,i + 1,m + 1)

                - p(j,i + 1,m + 1)*u2(j,i,m + 1) + 4*p(j,i + 1,m)*u2(j,i + 1,m)

                - p(j,i + 1,m)*u2(j,i,m) + p(j,i,m + 1)*u2(j,i + 1,m + 1)

                - 4*p(j,i,m + 1)*u2(j,i,m + 1) + p(j,i,m)*u2(j,i + 1,m)

                - 4*p(j,i,m)*u2(j,i,m))*hx + 5*(

               (p(j + 1,i,m + 1) + p(j,i,m + 1))

               *(u1(j + 1,i,m + 1) - u1(j,i,m + 1))

                + (p(j + 1,i,m) + p(j,i,m))*(u1(j + 1,i,m) - u1(j,i,m)) + 

               (p(j + 1,i + 1,m) + p(j,i + 1,m))

               *(u1(j + 1,i + 1,m) - u1(j,i + 1,m)) + 

               (p(j + 1,i + 1,m + 1) + p(j,i + 1,m + 1))

                                                                            -1
               *(u1(j + 1,i + 1,m + 1) - u1(j,i + 1,m + 1)))*hy))/16 + (3*ht  *(

      p(j,i,m + 1) - p(j,i,m) - p(j,i + 1,m) + p(j,i + 1,m + 1) - p(j + 1,i,m)

       + p(j + 1,i,m + 1) - p(j + 1,i + 1,m) + p(j + 1,i + 1,m + 1)))/8   =   0



clear a,u;



%***********************************************************************

% Example I.5 - 1-D hydrodynamics up to 3-rd moments (heat flow)

coordinates x,t into j,m;


grid uniform,x,t;


dependence n(x,t),u(x,t),tt(x,t),p(x,t),q(x,t);


iim a, n,diff(n,t)+u*diff(n,x)+diff(u,x)=0,
    u,n*m*(diff(u,t)+u*diff(u,x))+k*diff(n*tt,x)+diff(p,x)=0,
    tt,3/2*k*n*(diff(tt,t)+u*diff(tt,x))+n*k*tt*diff(u,x)+1/2*p
       *diff(u,x)+diff(q,x)=0,
    p,diff(p,t)+u*diff(p,x)+p*diff(u,x)+n*k*tt*diff(u,x)+2/5*diff(q,x)
       =0,
    q,diff(q,t)+u*diff(q,x)+q*diff(u,x)+5/2*n*k**2*tt/m*diff(tt,x)+n*k
       *tt*diff(p,x)-p*diff(p,x)=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(n,t) + diff(n,x)*u + diff(u,x)    =    0

diff(n*tt,x)*k + diff(p,x) + diff(u,t)*m*n + diff(u,x)*m*n*u    =    0

             3*diff(tt,t)*k*n     3*diff(tt,x)*k*n*u
diff(q,x) + ------------------ + --------------------
                    2                     2

    diff(u,x)*(2*k*n*tt + p)
 + --------------------------    =    0
               2

                           2*diff(q,x)
diff(p,t) + diff(p,x)*u + ------------- + diff(u,x)*(k*n*tt + p)    =    0
                                5

                                                                  2
                                                    5*diff(tt,x)*k *n*tt
diff(p,x)*(k*n*tt - p) + diff(q,t) + diff(q,x)*u + ----------------------
                                                            2*m

 + diff(u,x)*q    =    0


0 interpolations are needed in x coordinate
  Equation for n variable is integrated in half grid point
  Equation for u variable is integrated in half grid point
  Equation for tt variable is integrated in half grid point
  Equation for p variable is integrated in half grid point
  Equation for q variable is integrated in half grid point
0 interpolations are needed in t coordinate
  Equation for n variable is integrated in half grid point
  Equation for u variable is integrated in half grid point
  Equation for tt variable is integrated in half grid point
  Equation for p variable is integrated in half grid point
  Equation for q variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

   -1
(hx  *((n(j + 1,m + 1) - n(j,m + 1))*(u(j + 1,m + 1) + u(j,m + 1))

        + (n(j + 1,m) - n(j,m))*(u(j + 1,m) + u(j,m))

        + 2*(u(j + 1,m + 1) + u(j + 1,m) - (u(j,m + 1) + u(j,m)))))/4

      -1
    ht  *(n(j,m + 1) - n(j,m) - n(j + 1,m) + n(j + 1,m + 1))
 + ----------------------------------------------------------   =   0
                               2


      -1
( - hx  *(n(j,m + 1)*tt(j,m + 1) + n(j,m)*tt(j,m) - n(j + 1,m)*tt(j + 1,m)

                                                       -1   -1
           - n(j + 1,m + 1)*tt(j + 1,m + 1))*k)/2 + (hx  *ht  *((

         (n(j + 1,m + 1) + n(j + 1,m))*(u(j + 1,m + 1) - u(j + 1,m))

          + (n(j,m + 1) + n(j,m))*(u(j,m + 1) - u(j,m)))*hx*m

       + 2*(p(j + 1,m + 1) + p(j + 1,m) - (p(j,m + 1) + p(j,m)))*ht + (

         (n(j + 1,m + 1)*u(j + 1,m + 1) + n(j,m + 1)*u(j,m + 1))

         *(u(j + 1,m + 1) - u(j,m + 1))

          + (n(j + 1,m)*u(j + 1,m) + n(j,m)*u(j,m))*(u(j + 1,m) - u(j,m)))*ht*m)

   )/4   =   0


   -1
(hx  *((n(j + 1,m + 1)*tt(j + 1,m + 1) + n(j,m + 1)*tt(j,m + 1))

       *(u(j + 1,m + 1) - u(j,m + 1))

        + (n(j + 1,m)*tt(j + 1,m) + n(j,m)*tt(j,m))*(u(j + 1,m) - u(j,m)))*k)/4 

     -1   -1
+ (hx  *ht  *(((p(j + 1,m + 1) + p(j,m + 1))*(u(j + 1,m + 1) - u(j,m + 1))

                + (p(j + 1,m) + p(j,m))*(u(j + 1,m) - u(j,m))

                + 4*(q(j + 1,m + 1) + q(j + 1,m) - (q(j,m + 1) + q(j,m))))*ht + 

              3*((n(j + 1,m + 1) + n(j + 1,m))*(tt(j + 1,m + 1) - tt(j + 1,m))

                  + (n(j,m + 1) + n(j,m))*(tt(j,m + 1) - tt(j,m)))*hx*k + 3*(

                 (n(j + 1,m + 1)*u(j + 1,m + 1) + n(j,m + 1)*u(j,m + 1))

                 *(tt(j + 1,m + 1) - tt(j,m + 1)) + 

                 (n(j + 1,m)*u(j + 1,m) + n(j,m)*u(j,m))*(tt(j + 1,m) - tt(j,m))

                 )*ht*k))/8   =   0


   -1
(hx  *(5*((n(j + 1,m + 1)*tt(j + 1,m + 1) + n(j,m + 1)*tt(j,m + 1))

          *(u(j + 1,m + 1) - u(j,m + 1))

           + (n(j + 1,m)*tt(j + 1,m) + n(j,m)*tt(j,m))*(u(j + 1,m) - u(j,m)))*k 

       + 2*(5*p(j + 1,m + 1)*u(j + 1,m + 1) + 5*p(j + 1,m)*u(j + 1,m)

             - 5*p(j,m + 1)*u(j,m + 1) - 5*p(j,m)*u(j,m) + 2*q(j + 1,m + 1)

             + 2*q(j + 1,m) - 2*q(j,m + 1) - 2*q(j,m))))/20

      -1
    ht  *(p(j,m + 1) - p(j,m) - p(j + 1,m) + p(j + 1,m + 1))
 + ----------------------------------------------------------   =   0
                               2


      -1
( - hx  *(2*((p(j + 1,m + 1) + p(j,m + 1))*(p(j + 1,m + 1) - p(j,m + 1))

              + (p(j + 1,m) + p(j,m))*(p(j + 1,m) - p(j,m)) - 2*(

                q(j + 1,m + 1)*u(j + 1,m + 1) + q(j + 1,m)*u(j + 1,m)

                 - q(j,m + 1)*u(j,m + 1) - q(j,m)*u(j,m)))*m - 5*(

             (n(j + 1,m + 1)*tt(j + 1,m + 1) + n(j,m + 1)*tt(j,m + 1))

             *(tt(j + 1,m + 1) - tt(j,m + 1)) + 

             (n(j + 1,m)*tt(j + 1,m) + n(j,m)*tt(j,m))*(tt(j + 1,m) - tt(j,m)))

            2
          *k  - 2*((n(j + 1,m + 1)*tt(j + 1,m + 1) + n(j,m + 1)*tt(j,m + 1))

             *(p(j + 1,m + 1) - p(j,m + 1))

              + (n(j + 1,m)*tt(j + 1,m) + n(j,m)*tt(j,m))*(p(j + 1,m) - p(j,m)))

          *k*m))/(8*m)

      -1
    ht  *(q(j,m + 1) - q(j,m) - q(j + 1,m) + q(j + 1,m + 1))
 + ----------------------------------------------------------   =   0
                               2



clear a;



remfac diff,ht,hx,hy;


on exp;


off rat;



%***********************************************************************
%*****                                                             *****
%*****     T e s t     Examples   ---   Module    A P P R O X      *****
%*****                                                             *****
%***********************************************************************

% Example A.1

coordinates x,t into j,n;


maxorder t=2,x=3;


functions u,v;


approx( (u(n+1/2)-u(n-1/2))/ht=(v(n+1/2,j+1/2)-v(n+1/2,j-1/2)
                               +v(n-1/2,j+1/2)-v(n-1/2,j-1/2))/(2*hx) );


 Difference scheme approximates differential equation df(u,t)=df(v,x)

 with orders of approximation:

  2
hx

  2
ht


% Example A.2

maxorder t=3,x=3;


approx( (u(n+1)-u(n))/ht=(u(n+1,j+1/2)-u(n+1,j-1/2)
                               +u(n,j+1/2)-u(n,j-1/2))/(2*hx) );


 Difference scheme approximates differential equation df(u,t)=df(u,x)

 with orders of approximation:

  2
hx

ht


% Example A.3

maxorder t=2,x=3;


center t=1/2;


approx( (u(n+1)-u(n))/ht=(v(n+1,j+1/2)-v(n+1,j-1/2)
                               +v(n,j+1/2)-v(n,j-1/2))/(2*hx) );


 Difference scheme approximates differential equation df(u,t)=df(v,x)

 with orders of approximation:

  2
hx

  2
ht


% Example A.4

approx( u(n+1)/ht=(v(n+1,j+1/2)-v(n+1,j-1/2)
                               +v(n,j+1/2)-v(n,j-1/2))/(2*hx) );


 Reformulate difference scheme, grid steps remain in denominators

 Difference scheme approximates differential equation 0=df(v,x)

 with orders of approximation:

  2
hx

  -1
ht


% Example A.5

maxorder t=3,x=3;


approx( (u(n+1)-u(n))/ht=(u(n+1,j+1/2)-u(n+1,j-1/2))/hx);


 Difference scheme approximates differential equation df(u,t)=df(u,x)

 with orders of approximation:

  2
hx

ht


% Example A.6

approx( (u(n+1)-u(n))/ht=(u(n+1/2,j+1/2)-u(n+1/2,j-1/2))/hx);


 Difference scheme approximates differential equation df(u,t)=df(u,x)

 with orders of approximation:

  2
hx

  2
ht


% Example A.7;

maxorder x=4;


approx((u(n+1)-u(n))/ht=(u(n+1/2,j+1)-2*u(n+1/2,j)+u(n+1/2,j-1))/hx**2);


 Difference scheme approximates differential equation df(u,t)=df(u,x,2)

 with orders of approximation:

  2
hx

  2
ht


%***********************************************************************
%*****                                                             *****
%*****     T e s t     Examples   ---   Module    C H A R P O L    *****
%*****                                                             *****
%***********************************************************************

% Example C.1

coordinates t,x into i,j;


grid uniform,t,x;


let cos ax**2=1-sin ax**2;


unfunc u,v;


matrix aa(1,2),bb(2,2);


aa(1,1):=(u(i+1)-u(i))/ht+(v(j+1)-v(j))/hx$


aa(1,2):=(v(i+1)-v(i))/ht+(u(j+1/2)-u(j-1/2))/hx$


bb:=ampmat aa;


       kx*hx
ax := -------
         2


      [hx  0 ]
h1 := [      ]
      [0   hx]


      [       hx          2*sin(ax)*ht*( - i*cos(ax) + sin(ax))]
h0 := [                                                        ]
      [ - 2*i*sin(ax)*ht                   hx                  ]


      [                      2*sin(ax)*ht*( - i*cos(ax) + sin(ax)) ]
      [         1           ---------------------------------------]
      [                                       hx                   ]
bb := [                                                            ]
      [  - 2*i*sin(ax)*ht                                          ]
      [-------------------                     1                   ]
      [        hx                                                  ]


bb:=denotemat bb;


      [  1     ai12*i + ar12]
bb := [                     ]
      [ai21*i        1      ]


factor lam;


pol:=charpol bb;


          2
pol := lam  - 2*lam + ai12*ai21 - i*ai21*ar12 + 1

prdenot;


                  2
         2*sin(ax) *ht
ar12 := ---------------
              hx

          - 2*cos(ax)*sin(ax)*ht
ai12 := -------------------------
                   hx

          - 2*sin(ax)*ht
ai21 := -----------------
               hx

cleardenot;


clear aa,bb,pol;



%***********************************************************************

% Example C.2 : Reprint Vorozcov, Ganza, Mazurik: Simvolno-cislennyj
%               interfejs.  v zadacach ..., Novosibirsk 1986,  p.47.

unfunc u;


matrix aa(1,1),bb(1,1);


aa(1,1):=(u(i+1)-u(i))/ht+a*(u(j)-u(j-1))/hx$


bb:=ampmat aa;


ax := kx*hx


h1 := [hx]


h0 := [cos(ax)*a*ht - i*sin(ax)*a*ht - a*ht + hx]


      [ cos(ax)*a*ht - i*sin(ax)*a*ht - a*ht + hx ]
bb := [-------------------------------------------]
      [                    hx                     ]


bb:=denotemat bb;


bb := [ai11*i + ar11]


pol:=charpol bb;


pol := lam - i*ai11 - ar11

prdenot;


         cos(ax)*a*ht - a*ht + hx
ar11 := --------------------------
                    hx

          - sin(ax)*a*ht
ai11 := -----------------
               hx

cleardenot;


clear aa,bb,pol;



%***********************************************************************

% Example C.3 : Reprint Vorozcov, Ganza, Mazurik: Simvolno-cislennyj
%               interfejs.  v zadacach ..., Novosibirsk 1986,  p.52.

coordinates t,x into m,j;


unfunc u,r;


matrix aa(1,2),bb(2,2);


aa(1,1):=(r(m+1)-r(m))/ht+u0*(r(m+1,j+1)-r(m+1,j-1))/2/hx
                         +r0*(u(m+1,j+1)-u(m+1,j-1))/2/hx$


aa(1,2):=(u(m+1)-u(m))/ht+u0*(u(m+1,j+1)-u(m+1,j-1))/2/hx
                         +c0**2/r0*(r(m,j+1)-u(m,j-1))/2/hx$


bb:=ampmat aa;


ax := kx*hx


      [      i*sin(ax)*ht*r0        i*sin(ax)*ht*u0 + hx]
h1 := [                                                 ]
      [2*r0*(i*sin(ax)*ht*u0 + hx)           0          ]


h0 := mat((0,hx),

                     2                  2
          (cos(ax)*c0 *ht - i*sin(ax)*c0 *ht + 2*hx*r0,

             2
           c0 *ht*( - cos(ax) - i*sin(ax))))


                           2                2
             - i*cos(ax)*c0 *ht - sin(ax)*c0 *ht - 2*i*hx*r0
bb := mat((--------------------------------------------------,
                      2*r0*(sin(ax)*ht*u0 - i*hx)

              2
            c0 *ht*(i*cos(ax) - sin(ax))
           ------------------------------),
            2*r0*(sin(ax)*ht*u0 - i*hx)

                                    2                2
            sin(ax)*ht*(i*cos(ax)*c0 *ht + sin(ax)*c0 *ht + 2*i*hx*r0)
          (------------------------------------------------------------,(
                          2   2   2                            2
                2*(sin(ax) *ht *u0  - 2*i*sin(ax)*ht*hx*u0 - hx )

                                     2   2          2   2   2
               - i*cos(ax)*sin(ax)*c0 *ht  + sin(ax) *c0 *ht

                                            2
               - 2*i*sin(ax)*ht*hx*u0 - 2*hx )/(2

                       2   2   2                            2
              *(sin(ax) *ht *u0  - 2*i*sin(ax)*ht*hx*u0 - hx ))))


bb:=denotemat bb;


      [ai11*i + ar11  ai12*i + ar12]
bb := [                            ]
      [ai21*i + ar21  ai22*i + ar22]


pol:=charpol bb;


          2
pol := lam  + lam*( - i*ai11 - i*ai22 - ar11 - ar22) - ai11*ai22 + i*ai11*ar22

        + ai12*ai21 - i*ai12*ar21 - i*ai21*ar12 + i*ai22*ar11 + ar11*ar22

        - ar12*ar21

prdenot;


              2
          - c0
ar11 := ---------
         2*r0*u0

                      2           2
          - cos(ax)*c0 *ht*u0 - c0 *hx - 2*hx*r0*u0
ai11 := --------------------------------------------
               2*r0*u0*(sin(ax)*ht*u0 - hx*i)

              2
          - c0
ar12 := ---------
         2*r0*u0

              2
            c0 *(cos(ax)*ht*u0 - hx)
ai12 := --------------------------------
         2*r0*u0*(sin(ax)*ht*u0 - hx*i)

                     2   2   2
              sin(ax) *c0 *ht
ar21 := ----------------------------
                   2   2   2     2
         2*(sin(ax) *ht *u0  - hx )

                                    2   2   3   2             2      2
ai21 := (sin(ax)*ht*(cos(ax)*sin(ax) *c0 *ht *u0  - cos(ax)*c0 *ht*hx

                        2   2   2                  2   2         2       3
             + 2*sin(ax) *c0 *ht *hx*u0 + 2*sin(ax) *ht *hx*r0*u0  - 2*hx *r0))/

                   4   4   4            3   3        3            2   2   2   2
        (2*(sin(ax) *ht *u0  - 2*sin(ax) *ht *hx*i*u0  - 2*sin(ax) *ht *hx *u0

                              3          4
             + 2*sin(ax)*ht*hx *i*u0 + hx ))

                 2   2   2       2
          sin(ax) *c0 *ht  - 2*hx
ar22 := ----------------------------
                   2   2   2     2
         2*(sin(ax) *ht *u0  - hx )

                                       2   2   3   2             2      2
ai22 := (sin(ax)*ht*( - cos(ax)*sin(ax) *c0 *ht *u0  + cos(ax)*c0 *ht*hx

                        2   2   2                  2   2      3       3
             + 2*sin(ax) *c0 *ht *hx*u0 - 2*sin(ax) *ht *hx*u0  - 2*hx *u0))/(2*

                   4   4   4            3   3        3            2   2   2   2
           (sin(ax) *ht *u0  - 2*sin(ax) *ht *hx*i*u0  - 2*sin(ax) *ht *hx *u0

                              3          4
             + 2*sin(ax)*ht*hx *i*u0 + hx ))

cleardenot;


clear aa,bb,pol;



%***********************************************************************

% Example C.4 : Richtmyer, Morton: Difference methods for initial value
%               problems, &10.3.  p.262

coordinates t,x into n,j;


unfunc v,w;


matrix aa(1,2),bb(2,2);


aa(1,1):=(v(n+1)-v(n))/ht-c*(w(j+1/2)-w(j-1/2)+
                             w(n+1,j+1/2)-w(n+1,j-1/2))/(2*hx)$


aa(1,2):=(w(n+1,j-1/2)-w(n,j-1/2))/ht-c*(v(n+1,j)-v(n+1,j-1)+
                                         v(j)-v(j-1))/(2*hx)$


bb:=ampmat aa;


       kx*hx
ax := -------
         2


      [                 hx                        - i*sin(ax)*c*ht    ]
h1 := [                                                               ]
      [sin(ax)*c*ht*( - i*cos(ax) - sin(ax))  hx*(cos(ax) - i*sin(ax))]


      [                hx                       i*sin(ax)*c*ht     ]
h0 := [                                                            ]
      [sin(ax)*c*ht*(i*cos(ax) + sin(ax))  hx*(cos(ax) - i*sin(ax))]


      [           2  2   2     2                             ]
      [  - sin(ax) *c *ht  + hx       2*i*sin(ax)*c*ht*hx    ]
      [--------------------------   -----------------------  ]
      [         2  2   2     2              2  2   2     2   ]
      [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]
bb := [                                                      ]
      [                                       2  2   2     2 ]
      [   2*i*sin(ax)*c*ht*hx        - sin(ax) *c *ht  + hx  ]
      [ -----------------------    --------------------------]
      [         2  2   2     2              2  2   2     2   ]
      [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]


bb:=denotemat bb;


      [ ar11   ai12*i]
bb := [              ]
      [ai21*i   ar22 ]


pol:=charpol bb;


          2
pol := lam  - lam*(ar11 + ar22) + ai12*ai21 + ar11*ar22

prdenot;


                   2  2   2     2
          - sin(ax) *c *ht  + hx
ar11 := --------------------------
                 2  2   2     2
          sin(ax) *c *ht  + hx

           2*sin(ax)*c*ht*hx
ai12 := -----------------------
                2  2   2     2
         sin(ax) *c *ht  + hx

           2*sin(ax)*c*ht*hx
ai21 := -----------------------
                2  2   2     2
         sin(ax) *c *ht  + hx

                   2  2   2     2
          - sin(ax) *c *ht  + hx
ar22 := --------------------------
                 2  2   2     2
          sin(ax) *c *ht  + hx

cleardenot;


clear aa,bb,pol;



%***********************************************************************

% Example C.5: Mazurik: Algoritmy resenia zadaci..., Preprint no.24-85,
%               AN USSR SO, Inst. teor. i prikl. mechaniky, p.34

coordinates t,x,y into n,m,k;


grid uniform,t,x,y;


unfunc u1,u2,u3;


matrix aa(1,3),bb(3,3);


aa(1,1):=(u1(n+1)-u1(n))/ht+c/2*((-u1(m-1)+2*u1(m)-u1(m+1))/hx +
         (u2(m+1)-u2(m-1))/hx - (u1(k-1)-2*u1(k)+u1(k+1))/hy +
         (u3(k+1)-u3(k-1))/hy)$


aa(1,2):=(u2(n+1)-u2(n))/ht+c/2*((u1(m+1)-u1(m-1))/hx -
         (u2(m-1)-2*u2(m)+u2(m+1))/hx)$


aa(1,3):=(u3(n+1)-u3(n))/ht + c/2*((u1(k+1)-u1(k-1))/hy -
         (u3(k-1)-2*u3(k)+u3(k+1))/hy)$


off prfourmat;


bb:=ampmat aa;


ax := kx*hx


ay := ky*hy


            cos(ax)*c*ht*hy + cos(ay)*c*ht*hx - c*ht*hx - c*ht*hy + hx*hy
bb := mat((---------------------------------------------------------------,
                                        hx*hy

             - i*sin(ax)*c*ht    - i*sin(ay)*c*ht
           -------------------,-------------------),
                   hx                  hy

             - i*sin(ax)*c*ht   cos(ax)*c*ht - c*ht + hx
          (-------------------,--------------------------,0),
                   hx                      hx

             - i*sin(ay)*c*ht     cos(ay)*c*ht - c*ht + hy
          (-------------------,0,--------------------------))
                   hy                        hy


pol:=charpol bb;


           3   2   2      2
pol := (lam *hx *hy  + lam *hx*hy*( - 2*cos(ax)*c*ht*hy - 2*cos(ay)*c*ht*hx

            + 2*c*ht*hx + 2*c*ht*hy - 3*hx*hy) + lam*(

                              2   2                    2   2
           3*cos(ax)*cos(ay)*c *ht *hx*hy - 3*cos(ax)*c *ht *hx*hy

                         2   2   2                       2          2  2   2   2
            - 2*cos(ax)*c *ht *hy  + 4*cos(ax)*c*ht*hx*hy  + cos(ay) *c *ht *hx

                         2   2   2              2   2
            - 2*cos(ay)*c *ht *hx  - 3*cos(ay)*c *ht *hx*hy

                               2             2  2   2   2    2   2   2
            + 4*cos(ay)*c*ht*hx *hy + sin(ay) *c *ht *hx  + c *ht *hx

                 2   2            2   2   2            2                  2
            + 3*c *ht *hx*hy + 2*c *ht *hy  - 4*c*ht*hx *hy - 4*c*ht*hx*hy

                  2   2                   2  3   3
            + 3*hx *hy ) - cos(ax)*cos(ay) *c *ht *hx

                              3   3                         3   3
         + 2*cos(ax)*cos(ay)*c *ht *hx + 2*cos(ax)*cos(ay)*c *ht *hy

                              2   2                        2  3   3
         - 3*cos(ax)*cos(ay)*c *ht *hx*hy - cos(ax)*sin(ay) *c *ht *hx

                    3   3                 3   3                 2   2
         - cos(ax)*c *ht *hx - 2*cos(ax)*c *ht *hy + 3*cos(ax)*c *ht *hx*hy

                      2   2   2                       2          2  3   3
         + 2*cos(ax)*c *ht *hy  - 2*cos(ax)*c*ht*hx*hy  + cos(ay) *c *ht *hx

                  2  2   2   2              3   3                 3   3
         - cos(ay) *c *ht *hx  - 2*cos(ay)*c *ht *hx - 2*cos(ay)*c *ht *hy

                      2   2   2              2   2                          2
         + 2*cos(ay)*c *ht *hx  + 3*cos(ay)*c *ht *hx*hy - 2*cos(ay)*c*ht*hx *hy

                  2  3   3             2  2   2   2    3   3         3   3
         + sin(ay) *c *ht *hx - sin(ay) *c *ht *hx  + c *ht *hx + 2*c *ht *hy

            2   2   2      2   2            2   2   2            2
         - c *ht *hx  - 3*c *ht *hx*hy - 2*c *ht *hy  + 2*c*ht*hx *hy

                       2     2   2     2   2
         + 2*c*ht*hx*hy  - hx *hy )/(hx *hy )

let
  cos ax=cos ax2**2-sin ax2**2,
  cos ay=cos ay2**2-sin ay2**2,
  sin ax=2*sin ax2*cos ax2,
  sin ay=2*sin ay2*cos ay2,
  cos ax2**2=1-sin ax2**2,
  cos ay2**2=1-sin ay2**2,
  sin ax2=s1,
  sin ay2=s2,
  hx=c*ht/cap1,
  hy=c*ht/cap2;


order s1,s2;


pol:=pol;


          3      2      2            2                       2   2
pol := lam  + lam *(4*s1 *cap1 + 4*s2 *cap2 - 3) + lam*(12*s1 *s2 *cap1*cap2

                 2     2       2            2     2       2
           + 4*s1 *cap1  - 8*s1 *cap1 + 4*s2 *cap2  - 8*s2 *cap2 + 3)

              2   2     2            2   2          2        2   2
        + 8*s1 *s2 *cap1 *cap2 + 8*s1 *s2 *cap1*cap2  - 12*s1 *s2 *cap1*cap2

              2     2       2            2     2       2
        - 4*s1 *cap1  + 4*s1 *cap1 - 4*s2 *cap2  + 4*s2 *cap2 - 1

clear cos ax,cos ay,sin ax,sin ay,cos ax2**2,cos ay2**2,sin ax2,sin ay2,
      hx,hy;


pol:=complexpol pol;


         2   2
 If  8*s1 *s2 *cap1*cap2*(cap1 + cap2)  =  0  and  0

  =  0  , a root of the polynomial is equal to 1.

          3      2      2            2                       2   2
pol := lam  + lam *(4*s1 *cap1 + 4*s2 *cap2 - 3) + lam*(12*s1 *s2 *cap1*cap2

                 2     2       2            2     2       2
           + 4*s1 *cap1  - 8*s1 *cap1 + 4*s2 *cap2  - 8*s2 *cap2 + 3)

              2   2     2            2   2          2        2   2
        + 8*s1 *s2 *cap1 *cap2 + 8*s1 *s2 *cap1*cap2  - 12*s1 *s2 *cap1*cap2

              2     2       2            2     2       2
        - 4*s1 *cap1  + 4*s1 *cap1 - 4*s2 *cap2  + 4*s2 *cap2 - 1

pol1:=hurw pol;


             3   2   2                                2         2   2     2
pol1 := 8*lam *s1 *s2 *cap1*cap2*(cap1 + cap2) + 8*lam *( - 3*s1 *s2 *cap1 *cap2

                  2   2          2       2   2               2     2     2     2
            - 3*s1 *s2 *cap1*cap2  + 3*s1 *s2 *cap1*cap2 + s1 *cap1  + s2 *cap2

                          2   2     2            2   2          2
           ) + 8*lam*(3*s1 *s2 *cap1 *cap2 + 3*s1 *s2 *cap1*cap2

                  2   2                 2     2       2            2     2
            - 6*s1 *s2 *cap1*cap2 - 2*s1 *cap1  + 2*s1 *cap1 - 2*s2 *cap2

                  2                 2   2     2          2   2          2
            + 2*s2 *cap2) + 8*( - s1 *s2 *cap1 *cap2 - s1 *s2 *cap1*cap2

                  2   2               2     2       2          2     2
            + 3*s1 *s2 *cap1*cap2 + s1 *cap1  - 2*s1 *cap1 + s2 *cap2

                  2
            - 2*s2 *cap2 + 1)

denotid cp;


pol:=denotepol pol;


          3      2
pol := lam  + lam *cpr02 + lam*cpr01 + cpr00

prdenot;


             2   2     2            2   2          2        2   2
cpr00 := 8*s1 *s2 *cap1 *cap2 + 8*s1 *s2 *cap1*cap2  - 12*s1 *s2 *cap1*cap2

                2     2       2            2     2       2
          - 4*s1 *cap1  + 4*s1 *cap1 - 4*s2 *cap2  + 4*s2 *cap2 - 1

cpr01 := 

     2   2                 2     2       2            2     2       2
12*s1 *s2 *cap1*cap2 + 4*s1 *cap1  - 8*s1 *cap1 + 4*s2 *cap2  - 8*s2 *cap2 + 3

             2            2
cpr02 := 4*s1 *cap1 + 4*s2 *cap2 - 3

cleardenot;


clear aa,bb,pol,pol1;



%***********************************************************************

% Example C.6 : Lax-Wendrov (V. Ganzha)

coordinates t,x,y into n,m,k;


grid uniform,t,x,y;


let cos ax**2=1-sin ax**2,
    cos ay**2=1-sin ay**2;


unfunc u1,u2,u3,u4;


matrix aa(1,4),bb(4,4);


aa(1,1):=4*(u1(n+1)-u1(n))/ht+
         (w*(u1(m+2)-u1(m-2)+u1(m+1,k+1)+u1(m+1,k-1)-
         u1(m-1,k+1)-u1(m-1,k-1))+p*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+
         v*(u1(m+1,k+1)+u1(m-1,k+1)-
         u1(m+1,k-1)-u1(m-1,k-1)+u1(k+2)-u1(k-2))+p*(u3(m+1,k+1)+
         u3(m-1,k+1)-u3(m+1,k-1)-u3(m-1,k-1)+u3(k+2)-u3(k-2)))/hx+ht*
         (2*w**2*(-u1(m+2)+2*u1(m)-u1(m-2))+4*w*p*(-u2(m+2)+2*u2(m)-
         u2(m-2))+2*(-u4(m+2)+2*u4(m)-u4(m-2))+2*v**2*(-u1(k+2)+
         2*u1(k)-u1(k-2))+4*v*p*(u3(k+2)+2*u3(k)-u3(k-2))+2*(-u4(k+2)+
         2*u4(k)-u4(k-2))+4*w*v*(-u1(m+1,k+1)+u1(m+1,k-1)+u1(m-1,k+1)-
         u1(m-1,k-1))+4*p*v*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+4*w*p*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)-
         u3(m-1,k-1)))/hx/hx$


aa(1,2):=4*p*(u2(n+1)-u2(n))/ht+
       (w*p*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+u4(m+2)-u4(m-2)+
         u4(m+1,k+1)+
         u4(m+1,k-1)-u4(m-1,k+1)-u4(m-1,k-1)+
         p*v*(u2(m+1,k+1)+u2(m-1,k+1)+
         u2(k+2)-u2(k-2)-u2(m+1,k-1)-u2(m-1,k-1)))/hx+ht*(2*w**2*p*
         (-u2(m+2)+2*u2(m)-u2(m-2))+2*p*c**2*(-u2(m+2)+2*u2(m)-u2(m-2))
         +4*w*(-u4(m+2)+2*u4(m)-u4(m-2))+2*p*v**2*(-u2(k+2)+2*u2(k)-
         u2(k-2))+4*w*p*v*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+2*p*c**2*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)
         -u3(m-1,k-1))+4*v*(-u4(m+1,k+1)+u4(m+1,k-1)+u4(m-1,k+1)-
         u4(m-1,k-1)))/hx/hx$


aa(1,3):=4*p*(u3(n+1)-u3(n))/ht+(w*p*(u3(m+2)-u3(m-2)+u3(m+1,k+1)+
         u3(m+1,k-1)-u3(m-1,k+1)-u3(m-1,k-1))+u4(k+2)-u4(k-2)+
         u4(m+1,k+1)-u4(m+1,k-1)+u4(m-1,k+1)-u4(m-1,k-1)+
         p*v*(u3(m+1,k+1)+u3(m-1,k+1)+u3(k+2)-u3(k-2)-u3(m+1,k-1)-
         u3(m-1,k-1)))/hx+ht*(2*w**2*p*(-u3(m+2)+2*u3(m)-u3(m-2))+
         2*p*c**2*(-u3(k+2)+2*u3(k)-u3(k-2))+4*v*(-u4(k+2)+
         2*u4(k)-u4(k-2))+2*p*v**2*(-u3(k+2)+2*u3(k)-u3(k-2))+
         4*w*p*v*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)-
         u3(m-1,k-1))+2*p*c**2*(-u2(m+1,k+1)+u2(m+1,k-1)+
         u2(m-1,k+1)-u2(m-1,k-1))+4*w*(u4(m+1,k+1)+u4(m+1,k-1)+
         u4(m-1,k+1)-u4(m-1,k-1)))/hx/hx$


aa(1,4):=4*(u4(n+1)-u4(n))/ht+(p*c**2*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+w*(u4(m+2)-
         u4(m-2)+u4(m+1,k+1)+u4(m+1,k-1)-u4(m-1,k+1)-u4(m-1,k-1))+
         +p*c**2*(u3(m+1,k+1)+u3(m-1,k+1)-u3(m+1,k-1)-
         u3(m-1,k-1)+u3(k+2)-u3(k-2))+v*(u4(m+1,k+1)+u4(m-1,k+1)-
         u4(m+1,k-1)-u4(m-1,k-1)+u4(k+2)-u4(k-2)))/hx+ht*
         (2*w**2*(-u4(m+2)+2*u4(m)-u4(m-2))+4*w*p*c**2*(-u2(m+2)+
         2*u2(m)-u2(m-2))+2*c**2*(-u4(m+2)+2*u4(m)-u4(m-2))+
         4*p*v*c**2*(-u3(k+2)+2*u3(k)-u3(k-2))+2*c**2*(-u4(k+2)+
         2*u4(k)-u4(k-2))+2*v**2*(-u4(k+2)+2*u4(k)-u4(k-2))+
         4*p*v*c**2*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+4*w*p*c**2*(-u3(m+1,k+1)+u3(m+1,k-1)+
         u3(m-1,k+1)-u3(m-1,k-1))+4*w*v*(-u4(m+1,k+1)+
         u4(m+1,k-1)+u4(m-1,k+1)-u4(m-1,k-1)))/hx/hx$


bb:=ampmat aa;


ax := kx*hx


ay := ky*hy


bb := mat((( - i*cos(ax)*sin(ax)*ht*hx*w - i*cos(ax)*sin(ay)*ht*hx*v

             - i*cos(ay)*sin(ax)*ht*hx*w - i*cos(ay)*sin(ay)*ht*hx*v

                        2   2  2                       2                2   2  2
             - 2*sin(ax) *ht *w  - 4*sin(ax)*sin(ay)*ht *v*w - 2*sin(ay) *ht *v

                 2    2
             + hx )/hx ,(sin(ax)*ht*p*( - i*cos(ax)*hx - i*cos(ay)*hx

                                                        2
                  - 4*sin(ax)*ht*w - 4*sin(ay)*ht*v))/hx ,(ht*p*(

                  - i*cos(ax)*sin(ay)*hx - 4*i*cos(ay)*sin(ay)*ht*v

                                                                               2
                  - i*cos(ay)*sin(ay)*hx - 4*sin(ax)*sin(ay)*ht*w - 2*ht*v))/hx

                    2         2          2
              - 2*ht *(sin(ax)  + sin(ay) )
           ,--------------------------------),
                            2
                          hx

          (0,( - i*cos(ax)*sin(ax)*ht*hx*w - i*cos(ax)*sin(ay)*ht*hx*v

               - i*cos(ay)*sin(ax)*ht*hx*w - i*cos(ay)*sin(ay)*ht*hx*v

                          2  2   2            2   2  2
               - 2*sin(ax) *c *ht  - 2*sin(ax) *ht *w

                                     2                2   2  2     2    2
               - 4*sin(ax)*sin(ay)*ht *v*w - 2*sin(ay) *ht *v  + hx )/hx ,

                                  2   2
             - 2*sin(ax)*sin(ay)*c *ht
           -----------------------------,(sin(ax)*ht*( - i*cos(ax)*hx
                          2
                        hx

                                                                        2
                  - i*cos(ay)*hx - 4*sin(ax)*ht*w - 4*sin(ay)*ht*v))/(hx *p)),

                                    2   2
               - 2*sin(ax)*sin(ay)*c *ht
          (0,-----------------------------,( - i*cos(ax)*sin(ax)*ht*hx*w
                            2
                          hx

               - i*cos(ax)*sin(ay)*ht*hx*v - i*cos(ay)*sin(ax)*ht*hx*w

                                                      2   2  2
               - i*cos(ay)*sin(ay)*ht*hx*v - 2*sin(ax) *ht *w

                                     2                2  2   2
               - 4*sin(ax)*sin(ay)*ht *v*w - 2*sin(ay) *c *ht

                          2   2  2     2    2
               - 2*sin(ay) *ht *v  + hx )/hx ,(ht*( - 2*cos(ax)*cos(ay)*ht*w

                  - 2*i*cos(ax)*sin(ay)*ht*w - i*cos(ax)*sin(ay)*hx

                  - 2*i*cos(ay)*sin(ax)*ht*w - i*cos(ay)*sin(ay)*hx

                                                      2           2
                  - 2*sin(ax)*sin(ay)*ht*w - 4*sin(ay) *ht*v))/(hx *p)),

                       2
          (0,(sin(ax)*c *ht*p*( - i*cos(ax)*hx - i*cos(ay)*hx - 4*sin(ax)*ht*w

                                       2           2
                  - 4*sin(ay)*ht*v))/hx ,(sin(ay)*c *ht*p*( - i*cos(ax)*hx

                                                                       2
                  - i*cos(ay)*hx - 4*sin(ax)*ht*w - 4*sin(ay)*ht*v))/hx ,(

               - i*cos(ax)*sin(ax)*ht*hx*w - i*cos(ax)*sin(ay)*ht*hx*v

               - i*cos(ay)*sin(ax)*ht*hx*w - i*cos(ay)*sin(ay)*ht*hx*v

                          2  2   2            2   2  2
               - 2*sin(ax) *c *ht  - 2*sin(ax) *ht *w

                                     2                2  2   2
               - 4*sin(ax)*sin(ay)*ht *v*w - 2*sin(ay) *c *ht

                          2   2  2     2    2
               - 2*sin(ay) *ht *v  + hx )/hx ))


let
  sin(ax)=s1,
  cos(ax)=c1,
  sin(ay)=s2,
  cos(ay)=c2,
  w=k1*hx/ht,
  v=k2*hx/ht,
  c=k3*hx/ht,
  ht=r1*hx;


denotid a;


bb:=denotemat bb;


      [ai11*i + ar11  ai12*i + ar12  ai13*i + ar13      ar14     ]
      [                                                          ]
      [      0        ai22*i + ar22      ar23       ai24*i + ar24]
bb := [                                                          ]
      [      0            ar32       ai33*i + ar33  ai34*i + ar34]
      [                                                          ]
      [      0        ai42*i + ar42  ai43*i + ar43  ai44*i + ar44]


clear sin ax,cos ax,sin ay,cos ay,w,v,c,ht;


pol:=charpol bb;


          4      3
pol := lam  + lam

       *( - i*ai11 - i*ai22 - i*ai33 - i*ai44 - ar11 - ar22 - ar33 - ar44) + 

          2
       lam *( - ai11*ai22 - ai11*ai33 - ai11*ai44 + i*ai11*ar22 + i*ai11*ar33

              + i*ai11*ar44 - ai22*ai33 - ai22*ai44 + i*ai22*ar11 + i*ai22*ar33

              + i*ai22*ar44 + ai24*ai42 - i*ai24*ar42 - ai33*ai44 + i*ai33*ar11

              + i*ai33*ar22 + i*ai33*ar44 + ai34*ai43 - i*ai34*ar43

              - i*ai42*ar24 - i*ai43*ar34 + i*ai44*ar11 + i*ai44*ar22

              + i*ai44*ar33 + ar11*ar22 + ar11*ar33 + ar11*ar44 + ar22*ar33

              + ar22*ar44 - ar23*ar32 - ar24*ar42 + ar33*ar44 - ar34*ar43) + lam

       *(i*ai11*ai22*ai33 + i*ai11*ai22*ai44 + ai11*ai22*ar33 + ai11*ai22*ar44

          - i*ai11*ai24*ai42 - ai11*ai24*ar42 + i*ai11*ai33*ai44

          + ai11*ai33*ar22 + ai11*ai33*ar44 - i*ai11*ai34*ai43 - ai11*ai34*ar43

          - ai11*ai42*ar24 - ai11*ai43*ar34 + ai11*ai44*ar22 + ai11*ai44*ar33

          - i*ai11*ar22*ar33 - i*ai11*ar22*ar44 + i*ai11*ar23*ar32

          + i*ai11*ar24*ar42 - i*ai11*ar33*ar44 + i*ai11*ar34*ar43

          + i*ai22*ai33*ai44 + ai22*ai33*ar11 + ai22*ai33*ar44

          - i*ai22*ai34*ai43 - ai22*ai34*ar43 - ai22*ai43*ar34 + ai22*ai44*ar11

          + ai22*ai44*ar33 - i*ai22*ar11*ar33 - i*ai22*ar11*ar44

          - i*ai22*ar33*ar44 + i*ai22*ar34*ar43 - i*ai24*ai33*ai42

          - ai24*ai33*ar42 - ai24*ai42*ar11 - ai24*ai42*ar33 + ai24*ai43*ar32

          + i*ai24*ar11*ar42 - i*ai24*ar32*ar43 + i*ai24*ar33*ar42

          - ai33*ai42*ar24 + ai33*ai44*ar11 + ai33*ai44*ar22 - i*ai33*ar11*ar22

          - i*ai33*ar11*ar44 - i*ai33*ar22*ar44 + i*ai33*ar24*ar42

          + ai34*ai42*ar23 - ai34*ai43*ar11 - ai34*ai43*ar22 + i*ai34*ar11*ar43

          + i*ai34*ar22*ar43 - i*ai34*ar23*ar42 + i*ai42*ar11*ar24

          - i*ai42*ar23*ar34 + i*ai42*ar24*ar33 + i*ai43*ar11*ar34

          + i*ai43*ar22*ar34 - i*ai43*ar24*ar32 - i*ai44*ar11*ar22

          - i*ai44*ar11*ar33 - i*ai44*ar22*ar33 + i*ai44*ar23*ar32

          - ar11*ar22*ar33 - ar11*ar22*ar44 + ar11*ar23*ar32 + ar11*ar24*ar42

          - ar11*ar33*ar44 + ar11*ar34*ar43 - ar22*ar33*ar44 + ar22*ar34*ar43

          + ar23*ar32*ar44 - ar23*ar34*ar42 - ar24*ar32*ar43 + ar24*ar33*ar42)

        + ai11*ai22*ai33*ai44 - i*ai11*ai22*ai33*ar44 - ai11*ai22*ai34*ai43

        + i*ai11*ai22*ai34*ar43 + i*ai11*ai22*ai43*ar34 - i*ai11*ai22*ai44*ar33

        - ai11*ai22*ar33*ar44 + ai11*ai22*ar34*ar43 - ai11*ai24*ai33*ai42

        + i*ai11*ai24*ai33*ar42 + i*ai11*ai24*ai42*ar33 - i*ai11*ai24*ai43*ar32

        - ai11*ai24*ar32*ar43 + ai11*ai24*ar33*ar42 + i*ai11*ai33*ai42*ar24

        - i*ai11*ai33*ai44*ar22 - ai11*ai33*ar22*ar44 + ai11*ai33*ar24*ar42

        - i*ai11*ai34*ai42*ar23 + i*ai11*ai34*ai43*ar22 + ai11*ai34*ar22*ar43

        - ai11*ai34*ar23*ar42 - ai11*ai42*ar23*ar34 + ai11*ai42*ar24*ar33

        + ai11*ai43*ar22*ar34 - ai11*ai43*ar24*ar32 - ai11*ai44*ar22*ar33

        + ai11*ai44*ar23*ar32 + i*ai11*ar22*ar33*ar44 - i*ai11*ar22*ar34*ar43

        - i*ai11*ar23*ar32*ar44 + i*ai11*ar23*ar34*ar42 + i*ai11*ar24*ar32*ar43

        - i*ai11*ar24*ar33*ar42 - i*ai22*ai33*ai44*ar11 - ai22*ai33*ar11*ar44

        + i*ai22*ai34*ai43*ar11 + ai22*ai34*ar11*ar43 + ai22*ai43*ar11*ar34

        - ai22*ai44*ar11*ar33 + i*ai22*ar11*ar33*ar44 - i*ai22*ar11*ar34*ar43

        + i*ai24*ai33*ai42*ar11 + ai24*ai33*ar11*ar42 + ai24*ai42*ar11*ar33

        - ai24*ai43*ar11*ar32 + i*ai24*ar11*ar32*ar43 - i*ai24*ar11*ar33*ar42

        + ai33*ai42*ar11*ar24 - ai33*ai44*ar11*ar22 + i*ai33*ar11*ar22*ar44

        - i*ai33*ar11*ar24*ar42 - ai34*ai42*ar11*ar23 + ai34*ai43*ar11*ar22

        - i*ai34*ar11*ar22*ar43 + i*ai34*ar11*ar23*ar42 + i*ai42*ar11*ar23*ar34

        - i*ai42*ar11*ar24*ar33 - i*ai43*ar11*ar22*ar34 + i*ai43*ar11*ar24*ar32

        + i*ai44*ar11*ar22*ar33 - i*ai44*ar11*ar23*ar32 + ar11*ar22*ar33*ar44

        - ar11*ar22*ar34*ar43 - ar11*ar23*ar32*ar44 + ar11*ar23*ar34*ar42

        + ar11*ar24*ar32*ar43 - ar11*ar24*ar33*ar42

denotid cp;


pol:=denotepol pol;


          4      3                        2
pol := lam  + lam *(cpi03*i + cpr03) + lam *(cpi02*i + cpr02)

        + lam*(cpi01*i + cpr01) + cpi00*i + cpr00

pol:=complexpol pol;


 If  cpr00 + cpr01 + cpr02 + cpr03 + 1  =  0  and  cpi00 + cpi01 + cpi02 + cpi03

  =  0  , a root of the polynomial is equal to 1.

          8        7            6       2                  2
pol := lam  + 2*lam *cpr03 + lam *(cpi03  + 2*cpr02 + cpr03 )

               5
        + 2*lam *(cpi02*cpi03 + cpr01 + cpr02*cpr03)

             4                       2                                  2
        + lam *(2*cpi01*cpi03 + cpi02  + 2*cpr00 + 2*cpr01*cpr03 + cpr02 )

               3
        + 2*lam *(cpi00*cpi03 + cpi01*cpi02 + cpr00*cpr03 + cpr01*cpr02)

             2                       2                        2
        + lam *(2*cpi00*cpi02 + cpi01  + 2*cpr00*cpr02 + cpr01 )

                                                   2        2
        + 2*lam*(cpi00*cpi01 + cpr00*cpr01) + cpi00  + cpr00

denotid rp;


pol:=denotepol pol;


          8      7            6            5            4            3
pol := lam  + lam *rpr07 + lam *rpr06 + lam *rpr05 + lam *rpr04 + lam *rpr03

             2
        + lam *rpr02 + lam*rpr01 + rpr00

prdenot;


               2   2                       2   2
ar11 :=  - 2*s1 *k1  - 4*s1*s2*k1*k2 - 2*s2 *k2  + 1

ai11 :=  - (s1*c1*k1 + s1*c2*k1 + s2*c1*k2 + s2*c2*k2)

ar12 :=  - 4*s1*p*r1*(s1*k1 + s2*k2)

ai12 :=  - s1*p*r1*(c1 + c2)

ar13 := 2*p*r1*( - 2*s1*s2*k1 - k2)

ai13 := s2*p*r1*( - c1 - 4*c2*k2 - c2)

               2    2     2
ar14 :=  - 2*r1 *(s1  + s2 )

               2   2       2   2                       2   2
ar22 :=  - 2*s1 *k1  - 2*s1 *k3  - 4*s1*s2*k1*k2 - 2*s2 *k2  + 1

ai22 :=  - (s1*c1*k1 + s1*c2*k1 + s2*c1*k2 + s2*c2*k2)

                     2
ar23 :=  - 2*s1*s2*k3

          - 4*s1*r1*(s1*k1 + s2*k2)
ar24 := ----------------------------
                     p

          - s1*r1*(c1 + c2)
ai24 := --------------------
                 p

                     2
ar32 :=  - 2*s1*s2*k3

               2   2                       2   2       2   2
ar33 :=  - 2*s1 *k1  - 4*s1*s2*k1*k2 - 2*s2 *k2  - 2*s2 *k3  + 1

ai33 :=  - (s1*c1*k1 + s1*c2*k1 + s2*c1*k2 + s2*c2*k2)

                                 2
         2*r1*( - s1*s2*k1 - 2*s2 *k2 - c1*c2*k1)
ar34 := ------------------------------------------
                            p

         r1*( - 2*s1*c2*k1 - 2*s2*c1*k1 - s2*c1 - s2*c2)
ai34 := -------------------------------------------------
                                p

                   2
          - 4*s1*k3 *p*(s1*k1 + s2*k2)
ar42 := -------------------------------
                      r1

                 2
          - s1*k3 *p*(c1 + c2)
ai42 := -----------------------
                  r1

                   2
          - 4*s2*k3 *p*(s1*k1 + s2*k2)
ar43 := -------------------------------
                      r1

                 2
          - s2*k3 *p*(c1 + c2)
ai43 := -----------------------
                  r1

               2   2       2   2                       2   2       2   2
ar44 :=  - 2*s1 *k1  - 2*s1 *k3  - 4*s1*s2*k1*k2 - 2*s2 *k2  - 2*s2 *k3  + 1

ai44 :=  - (s1*c1*k1 + s1*c2*k1 + s2*c1*k2 + s2*c2*k2)

cpr00 := ai11*ai22*ai33*ai44 - ai11*ai22*ai34*ai43 - ai11*ai22*ar33*ar44

          + ai11*ai22*ar34*ar43 - ai11*ai24*ai33*ai42 - ai11*ai24*ar32*ar43

          + ai11*ai24*ar33*ar42 - ai11*ai33*ar22*ar44 + ai11*ai33*ar24*ar42

          + ai11*ai34*ar22*ar43 - ai11*ai34*ar23*ar42 - ai11*ai42*ar23*ar34

          + ai11*ai42*ar24*ar33 + ai11*ai43*ar22*ar34 - ai11*ai43*ar24*ar32

          - ai11*ai44*ar22*ar33 + ai11*ai44*ar23*ar32 - ai22*ai33*ar11*ar44

          + ai22*ai34*ar11*ar43 + ai22*ai43*ar11*ar34 - ai22*ai44*ar11*ar33

          + ai24*ai33*ar11*ar42 + ai24*ai42*ar11*ar33 - ai24*ai43*ar11*ar32

          + ai33*ai42*ar11*ar24 - ai33*ai44*ar11*ar22 - ai34*ai42*ar11*ar23

          + ai34*ai43*ar11*ar22 + ar11*ar22*ar33*ar44 - ar11*ar22*ar34*ar43

          - ar11*ar23*ar32*ar44 + ar11*ar23*ar34*ar42 + ar11*ar24*ar32*ar43

          - ar11*ar24*ar33*ar42

cpi00 :=  - ai11*ai22*ai33*ar44 + ai11*ai22*ai34*ar43 + ai11*ai22*ai43*ar34

          - ai11*ai22*ai44*ar33 + ai11*ai24*ai33*ar42 + ai11*ai24*ai42*ar33

          - ai11*ai24*ai43*ar32 + ai11*ai33*ai42*ar24 - ai11*ai33*ai44*ar22

          - ai11*ai34*ai42*ar23 + ai11*ai34*ai43*ar22 + ai11*ar22*ar33*ar44

          - ai11*ar22*ar34*ar43 - ai11*ar23*ar32*ar44 + ai11*ar23*ar34*ar42

          + ai11*ar24*ar32*ar43 - ai11*ar24*ar33*ar42 - ai22*ai33*ai44*ar11

          + ai22*ai34*ai43*ar11 + ai22*ar11*ar33*ar44 - ai22*ar11*ar34*ar43

          + ai24*ai33*ai42*ar11 + ai24*ar11*ar32*ar43 - ai24*ar11*ar33*ar42

          + ai33*ar11*ar22*ar44 - ai33*ar11*ar24*ar42 - ai34*ar11*ar22*ar43

          + ai34*ar11*ar23*ar42 + ai42*ar11*ar23*ar34 - ai42*ar11*ar24*ar33

          - ai43*ar11*ar22*ar34 + ai43*ar11*ar24*ar32 + ai44*ar11*ar22*ar33

          - ai44*ar11*ar23*ar32

cpr01 := ai11*ai22*ar33 + ai11*ai22*ar44 - ai11*ai24*ar42 + ai11*ai33*ar22

          + ai11*ai33*ar44 - ai11*ai34*ar43 - ai11*ai42*ar24 - ai11*ai43*ar34

          + ai11*ai44*ar22 + ai11*ai44*ar33 + ai22*ai33*ar11 + ai22*ai33*ar44

          - ai22*ai34*ar43 - ai22*ai43*ar34 + ai22*ai44*ar11 + ai22*ai44*ar33

          - ai24*ai33*ar42 - ai24*ai42*ar11 - ai24*ai42*ar33 + ai24*ai43*ar32

          - ai33*ai42*ar24 + ai33*ai44*ar11 + ai33*ai44*ar22 + ai34*ai42*ar23

          - ai34*ai43*ar11 - ai34*ai43*ar22 - ar11*ar22*ar33 - ar11*ar22*ar44

          + ar11*ar23*ar32 + ar11*ar24*ar42 - ar11*ar33*ar44 + ar11*ar34*ar43

          - ar22*ar33*ar44 + ar22*ar34*ar43 + ar23*ar32*ar44 - ar23*ar34*ar42

          - ar24*ar32*ar43 + ar24*ar33*ar42

cpi01 := ai11*ai22*ai33 + ai11*ai22*ai44 - ai11*ai24*ai42 + ai11*ai33*ai44

          - ai11*ai34*ai43 - ai11*ar22*ar33 - ai11*ar22*ar44 + ai11*ar23*ar32

          + ai11*ar24*ar42 - ai11*ar33*ar44 + ai11*ar34*ar43 + ai22*ai33*ai44

          - ai22*ai34*ai43 - ai22*ar11*ar33 - ai22*ar11*ar44 - ai22*ar33*ar44

          + ai22*ar34*ar43 - ai24*ai33*ai42 + ai24*ar11*ar42 - ai24*ar32*ar43

          + ai24*ar33*ar42 - ai33*ar11*ar22 - ai33*ar11*ar44 - ai33*ar22*ar44

          + ai33*ar24*ar42 + ai34*ar11*ar43 + ai34*ar22*ar43 - ai34*ar23*ar42

          + ai42*ar11*ar24 - ai42*ar23*ar34 + ai42*ar24*ar33 + ai43*ar11*ar34

          + ai43*ar22*ar34 - ai43*ar24*ar32 - ai44*ar11*ar22 - ai44*ar11*ar33

          - ai44*ar22*ar33 + ai44*ar23*ar32

cpr02 :=  - ai11*ai22 - ai11*ai33 - ai11*ai44 - ai22*ai33 - ai22*ai44

          + ai24*ai42 - ai33*ai44 + ai34*ai43 + ar11*ar22 + ar11*ar33

          + ar11*ar44 + ar22*ar33 + ar22*ar44 - ar23*ar32 - ar24*ar42

          + ar33*ar44 - ar34*ar43

cpi02 := ai11*ar22 + ai11*ar33 + ai11*ar44 + ai22*ar11 + ai22*ar33 + ai22*ar44

          - ai24*ar42 + ai33*ar11 + ai33*ar22 + ai33*ar44 - ai34*ar43

          - ai42*ar24 - ai43*ar34 + ai44*ar11 + ai44*ar22 + ai44*ar33

cpr03 :=  - (ar11 + ar22 + ar33 + ar44)

cpi03 :=  - (ai11 + ai22 + ai33 + ai44)

              2        2
rpr00 := cpi00  + cpr00

rpr01 := 2*(cpi00*cpi01 + cpr00*cpr01)

                              2                        2
rpr02 := 2*cpi00*cpi02 + cpi01  + 2*cpr00*cpr02 + cpr01

rpr03 := 2*(cpi00*cpi03 + cpi01*cpi02 + cpr00*cpr03 + cpr01*cpr02)

                              2                                  2
rpr04 := 2*cpi01*cpi03 + cpi02  + 2*cpr00 + 2*cpr01*cpr03 + cpr02

rpr05 := 2*(cpi02*cpi03 + cpr01 + cpr02*cpr03)

              2                  2
rpr06 := cpi03  + 2*cpr02 + cpr03

rpr07 := 2*cpr03

cleardenot;


clear aa,bb,pol;



%***********************************************************************
%*****                                                             *****
%*****      T e s t     Examples   ---   Module    H U R W P       *****
%*****                                                             *****
%***********************************************************************

% Example H.1

x0:=lam-1;


x0 := lam - 1

x1:=lam-(ar+i*ai);


x1 := lam - (ai*i + ar)

x2:=lam-(br+i*bi);


x2 := lam - (bi*i + br)

x3:=lam-(cr+i*ci);


x3 := lam - (ci*i + cr)

hurwitzp x1;

Necessary and sufficient conditions are:
 - ar  >  0


cond


% Example H.2

x:=hurw(x0*x1);


x := 2*lam*( - ai*i - ar + 1) + 2*(ai*i + ar + 1)

hurwitzp x;

Necessary and sufficient conditions are:
        2     2
4*( - ai  - ar  + 1)  >  0


cond


% Example H.3

x:=(x1*x2);


        2
x := lam  - lam*(ai*i + ar + bi*i + br) - ai*bi + ai*br*i + ar*bi*i + ar*br

hurwitzp x;

Necessary and sufficient conditions are:
 - (ar + br)  >  0

         2               2               2     2
ar*br*(ai  - 2*ai*bi + ar  + 2*ar*br + bi  + br )  >  0


cond


% Example H.4

x:=(x1*x2*x3);


        3      2
x := lam  - lam *(ai*i + ar + bi*i + br + ci*i + cr) + lam*( - ai*bi + ai*br*i

         - ai*ci + ai*cr*i + ar*bi*i + ar*br + ar*ci*i + ar*cr - bi*ci + bi*cr*i

         + br*ci*i + br*cr) + ai*bi*ci*i + ai*bi*cr + ai*br*ci - ai*br*cr*i

      + ar*bi*ci - ar*bi*cr*i - ar*br*ci*i - ar*br*cr

hurwitzp x;

Necessary and sufficient conditions are:
 - (ar + br + cr)  >  0

  2           2                                           3        3
ai *ar*br + ai *ar*cr - 2*ai*ar*bi*br - 2*ai*ar*ci*cr + ar *br + ar *cr

       2   2       2             2   2        2           3          2
 + 2*ar *br  + 4*ar *br*cr + 2*ar *cr  + ar*bi *br + ar*br  + 4*ar*br *cr

             2        2           3     2                           3
 + 4*ar*br*cr  + ar*ci *cr + ar*cr  + bi *br*cr - 2*bi*br*ci*cr + br *cr

       2   2        2           3
 + 2*br *cr  + br*ci *cr + br*cr   >  0

               4   2       4           4   2       4           4   2     4   2
ar*br*cr*( - ai *bi  + 2*ai *bi*ci - ai *br  - 2*ai *br*cr - ai *ci  - ai *cr

                 3   3       3   2          3      2       3
           + 2*ai *bi  - 2*ai *bi *ci + 2*ai *bi*br  + 4*ai *bi*br*cr

                 3      2       3      2       3   2          3
           - 2*ai *bi*ci  + 2*ai *bi*cr  + 2*ai *br *ci + 4*ai *br*ci*cr

                 3   3       3      2       2   2   2       2   2
           + 2*ai *ci  + 2*ai *ci*cr  - 2*ai *ar *bi  + 4*ai *ar *bi*ci

                 2   2   2       2   2             2   2   2       2   2   2
           - 2*ai *ar *br  - 4*ai *ar *br*cr - 2*ai *ar *ci  - 2*ai *ar *cr

                 2      2          2      2          2
           - 2*ai *ar*bi *br - 2*ai *ar*bi *cr + 4*ai *ar*bi*br*ci

                 2                   2      3       2      2
           + 4*ai *ar*bi*ci*cr - 2*ai *ar*br  - 6*ai *ar*br *cr

                 2         2       2         2       2      2          2      3
           - 2*ai *ar*br*ci  - 6*ai *ar*br*cr  - 2*ai *ar*ci *cr - 2*ai *ar*cr

               2   4       2   3          2   2   2       2   2
           - ai *bi  - 2*ai *bi *ci - 2*ai *bi *br  - 2*ai *bi *br*cr

                 2   2   2       2   2   2       2      2          2
           + 6*ai *bi *ci  - 2*ai *bi *cr  - 2*ai *bi*br *ci - 8*ai *bi*br*ci*cr

                 2      3       2         2     2   4       2   3
           - 2*ai *bi*ci  - 2*ai *bi*ci*cr  - ai *br  - 2*ai *br *cr

                 2   2   2       2   2   2       2      2          2      3
           - 2*ai *br *ci  - 2*ai *br *cr  - 2*ai *br*ci *cr - 2*ai *br*cr

               2   4       2   2   2     2   4          2   3          2   2
           - ai *ci  - 2*ai *ci *cr  - ai *cr  + 2*ai*ar *bi  - 2*ai*ar *bi *ci

                    2      2          2                   2      2
           + 2*ai*ar *bi*br  + 4*ai*ar *bi*br*cr - 2*ai*ar *bi*ci

                    2      2          2   2             2
           + 2*ai*ar *bi*cr  + 2*ai*ar *br *ci + 4*ai*ar *br*ci*cr

                    2   3          2      2             3                2
           + 2*ai*ar *ci  + 2*ai*ar *ci*cr  + 4*ai*ar*bi *cr + 4*ai*ar*bi *br*ci

                       2                      2                      2
           - 8*ai*ar*bi *ci*cr + 4*ai*ar*bi*br *cr - 8*ai*ar*bi*br*ci

                             2                2                   3
           + 8*ai*ar*bi*br*cr  + 4*ai*ar*bi*ci *cr + 4*ai*ar*bi*cr

                       3                2                      3
           + 4*ai*ar*br *ci + 8*ai*ar*br *ci*cr + 4*ai*ar*br*ci

                             2          4             3   2          3   2
           + 4*ai*ar*br*ci*cr  + 2*ai*bi *ci - 2*ai*bi *ci  + 2*ai*bi *cr

                    2   2             2                   2   3
           + 4*ai*bi *br *ci + 4*ai*bi *br*ci*cr - 2*ai*bi *ci

                    2      2             2   2             2   2
           - 2*ai*bi *ci*cr  - 2*ai*bi*br *ci  + 2*ai*bi*br *cr

                          2                   3             4             2   2
           + 4*ai*bi*br*ci *cr + 4*ai*bi*br*cr  + 2*ai*bi*ci  + 4*ai*bi*ci *cr

                       4          4             3                2   3
           + 2*ai*bi*cr  + 2*ai*br *ci + 4*ai*br *ci*cr + 2*ai*br *ci

                    2      2     4   2       4           4   2       4
           + 2*ai*br *ci*cr  - ar *bi  + 2*ar *bi*ci - ar *br  - 2*ar *br*cr

               4   2     4   2       3   2          3   2          3
           - ar *ci  - ar *cr  - 2*ar *bi *br - 2*ar *bi *cr + 4*ar *bi*br*ci

                 3                3   3       3   2          3      2
           + 4*ar *bi*ci*cr - 2*ar *br  - 6*ar *br *cr - 2*ar *br*ci

                 3      2       3   2          3   3     2   4       2   3
           - 6*ar *br*cr  - 2*ar *ci *cr - 2*ar *cr  - ar *bi  + 2*ar *bi *ci

                 2   2   2       2   2             2   2   2       2   2   2
           - 2*ar *bi *br  - 6*ar *bi *br*cr - 2*ar *bi *ci  - 2*ar *bi *cr

                 2      2          2                   2      3
           + 2*ar *bi*br *ci + 8*ar *bi*br*ci*cr + 2*ar *bi*ci

                 2         2     2   4       2   3          2   2   2
           + 2*ar *bi*ci*cr  - ar *br  - 6*ar *br *cr - 2*ar *br *ci

                  2   2   2       2      2          2      3     2   4
           - 10*ar *br *cr  - 6*ar *br*ci *cr - 6*ar *br*cr  - ar *ci

                 2   2   2     2   4          4             3
           - 2*ar *ci *cr  - ar *cr  - 2*ar*bi *cr + 4*ar*bi *ci*cr

                    2   2             2      2          2      2
           - 4*ar*bi *br *cr - 2*ar*bi *br*ci  - 6*ar*bi *br*cr

                    2   2             2   3             2                      3
           - 2*ar*bi *ci *cr - 2*ar*bi *cr  + 4*ar*bi*br *ci*cr + 4*ar*bi*br*ci

                             2          4             3   2          3   2
           + 4*ar*bi*br*ci*cr  - 2*ar*br *cr - 2*ar*br *ci  - 6*ar*br *cr

                    2   2             2   3             4             2   2
           - 6*ar*br *ci *cr - 6*ar*br *cr  - 2*ar*br*ci  - 4*ar*br*ci *cr

                       4     4   2     4   2       3   3       3      2
           - 2*ar*br*cr  - bi *ci  - bi *cr  + 2*bi *ci  + 2*bi *ci*cr

                 2   2   2       2   2   2       2      2          2      3
           - 2*bi *br *ci  - 2*bi *br *cr  - 2*bi *br*ci *cr - 2*bi *br*cr

               2   4       2   2   2     2   4          2   3          2      2
           - bi *ci  - 2*bi *ci *cr  - bi *cr  + 2*bi*br *ci  + 2*bi*br *ci*cr

               4   2     4   2       3   2          3   3     2   4
           - br *ci  - br *cr  - 2*br *ci *cr - 2*br *cr  - br *ci

                 2   2   2     2   4
           - 2*br *ci *cr  - br *cr )  >  0


cond

clear x,x0,x1,x2,x3;



%***********************************************************************
%*****                                                             *****
%*****    T e s t     Examples   ---   Module    L I N B A N D     *****
%*****                                                             *****
%***********************************************************************

on evallhseqp;

  % So both sides of equations evaluate.

% Example L.1

operator v;


off echo;

      dimension u(200),v(200),acof(200,3),arhs(200),xl(200,3)
      dx=5.0e-2
      x=0.1
      do 25001 i=1,101
          v(i)=x**2/2.0
          x=x+dx
25001 continue
      iacof=200
      iarhs=200
      n=1
      ad(n)=1.0
      aucd(n)=0.0
      arhs(n)=v(1)
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n)=1.0
      arhs(n)=v(3)-(2.0*v(2))+v(1)
      do 25002 k=3,99,1
          n=n+1
          alcd(n)=1.0
          ad(n)=-2.0
          aucd(n)=1.0
          arhs(n)=v(k-1)+v(k+1)-(2.0*v(k))
25002 continue
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n)=1.0
      arhs(n)=v(101)-(2.0*v(100))+v(99)
      n=n+1
      alcd(n)=0.0
      ad(n)=1.0
      arhs(n)=v(101)
      call dgtsl(n,alcd,ad,aucd,arhs,ier)
c  n is number of equations
c  alcd,ad,aucd,arhs are arrays of dimension at least (n)
c  if (ier.ne.0) matrix acof is algorithmically singular
      if(ier.ne.0) call errout
      n=1
      u(1)=arhs(n)
      n=n+1
      u(2)=arhs(n)
      do 25003 k=3,99,1
          n=n+1
          u(k)=arhs(n)
25003 continue
      n=n+1
      u(100)=arhs(n)
      n=n+1
      u(101)=arhs(n)
      amer=0.0
      arer=0.0
      do 25004 i=1,101
          am=abs(real(u(i)-v(i)))
          ar=am/v(i)
          if(am.gt.amer) amer=am
          if(ar.gt.arer) arer=ar
25004 continue
      write(*,100)amer,arer
      stop
100     format(' max. abs. error = ',e12.2,' max. rel. error = ',e12.2)
      end


%***********************************************************************

% Example L.2

on nag;


off echo;

      dimension u(200),v(200),acof(200,3),arhs(200),xl(200,3)
      dx=5.0e-2
      x=0.1
      do 25005 i=1,101
          v(i)=x**2/2.0
          x=x+dx
25005 continue
      iacof=200
      iarhs=200
      n=1
      ad(n)=1.0
      aucd(n+1)=0.0
      arhs(n)=v(1)
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n+1)=1.0
      arhs(n)=v(3)-(2.0*v(2))+v(1)
      do 25006 k=3,99,1
          n=n+1
          alcd(n)=1.0
          ad(n)=-2.0
          aucd(n+1)=1.0
          arhs(n)=v(k-1)+v(k+1)-(2.0*v(k))
25006 continue
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n+1)=1.0
      arhs(n)=v(101)-(2.0*v(100))+v(99)
      n=n+1
      alcd(n)=0.0
      ad(n)=1.0
      arhs(n)=v(101)
      ier=0
      call f01lef(n,ad,0.,aucd,alcd,1.e-10,au2cd,in,ier)
c  n is number of equations
c  alcd,ad,aucd,au2cd,arhs are arrays of dimension at least (n)
c  in is integer array of dimension at least (n)
      if(ier.ne.0 .or. in(n).ne.0) call errout
      call f04lef(1,n,ad,aucd,alcd,au2cd,in,arhs,0.,ier)
      if(ier.ne.0) call errout
      n=1
      u(1)=arhs(n)
      n=n+1
      u(2)=arhs(n)
      do 25007 k=3,99,1
          n=n+1
          u(k)=arhs(n)
25007 continue
      n=n+1
      u(100)=arhs(n)
      n=n+1
      u(101)=arhs(n)
      amer=0.0
      arer=0.0
      do 25008 i=1,101
          am=abs(real(u(i)-v(i)))
          ar=am/v(i)
          if(am.gt.amer) amer=am
          if(ar.gt.arer) arer=ar
25008 continue
      write(*,100)amer,arer
      stop
100     format(' max. abs. error = ',e12.2,' max. rel. error = ',e12.2)
      end


%***********************************************************************

% Example L.3

on imsl;


off echo,nag;

      dimension u(200),v(200),acof(200,3),arhs(200),xl(200,3)
      dx=5.0e-2
      x=0.1
      do 25009 i=1,101
          v(i)=x**2/2.0
          x=x+dx
25009 continue
      iacof=200
      iarhs=200
      n=1
      acof(n,1)=0.0
      acof(n,2)=1.0
      acof(n,3)=0.0
      arhs(n)=v(1)
      n=n+1
      acof(n,1)=1.0
      acof(n,2)=-2.0
      acof(n,3)=1.0
      arhs(n)=v(3)-(2.0*v(2))+v(1)
      do 25010 k=3,99,1
          n=n+1
          acof(n,1)=1.0
          acof(n,2)=-2.0
          acof(n,3)=1.0
          arhs(n)=v(k-1)+v(k+1)-(2.0*v(k))
25010 continue
      n=n+1
      acof(n,1)=1.0
      acof(n,2)=-2.0
      acof(n,3)=1.0
      arhs(n)=v(101)-(2.0*v(100))+v(99)
      n=n+1
      acof(n,1)=0.0
      acof(n,2)=1.0
      acof(n,3)=0.0
      arhs(n)=v(101)
      call leqt1b(acof,n,1,1,iacof,arhs,1,iarhs,0,xl,ier)
c  iacof is actual 1-st dimension of the acof array
c  iarhs is actual 1-st dimension of the arhs array
c  xl is working array with size n*(nlc+1)
c  where n is number of equations nlc number of lower
c  codiagonals
c  if ier=129( .ne.0) matrix acof is algorithmically singular
      if(ier.ne.0) call errout
      n=1
      u(1)=arhs(n)
      n=n+1
      u(2)=arhs(n)
      do 25011 k=3,99,1
          n=n+1
          u(k)=arhs(n)
25011 continue
      n=n+1
      u(100)=arhs(n)
      n=n+1
      u(101)=arhs(n)
      amer=0.0
      arer=0.0
      do 25012 i=1,101
          am=abs(real(u(i)-v(i)))
          ar=am/v(i)
          if(am.gt.amer) amer=am
          if(ar.gt.arer) arer=ar
25012 continue
      write(*,100)amer,arer
      stop
100     format(' max. abs. error = ',e12.2,' max. rel. error = ',e12.2)
      end


%***********************************************************************

% Example L.4

on essl;


off echo,imsl;

      dimension u(200),v(200),acof(200,3),arhs(200),xl(200,3)
      dx=5.0e-2
      x=0.1
      do 25013 i=1,101
          v(i)=x**2/2.0
          x=x+dx
25013 continue
      iacof=200
      iarhs=200
      n=1
      ad(n)=1.0
      aucd(n)=0.0
      arhs(n)=v(1)
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n)=1.0
      arhs(n)=v(3)-(2.0*v(2))+v(1)
      do 25014 k=3,99,1
          n=n+1
          alcd(n)=1.0
          ad(n)=-2.0
          aucd(n)=1.0
          arhs(n)=v(k-1)+v(k+1)-(2.0*v(k))
25014 continue
      n=n+1
      alcd(n)=1.0
      ad(n)=-2.0
      aucd(n)=1.0
      arhs(n)=v(101)-(2.0*v(100))+v(99)
      n=n+1
      alcd(n)=0.0
      ad(n)=1.0
      arhs(n)=v(101)
      call dgtf(n,alcd,ad,aucd,af,ipvt)
c  n is number of equations
c  alcd,ad,aucd,af,arhs are arrays of dimension at least (n)
c  these arrays are double precision type
c  for single precision change dgtf to sgtf and dgts to sgts
c  ipvt is integer array of dimension at least (n+3)/8
      call dgts(n,alcd,ad,aucd,af,ipvt,arhs)
      n=1
      u(1)=arhs(n)
      n=n+1
      u(2)=arhs(n)
      do 25015 k=3,99,1
          n=n+1
          u(k)=arhs(n)
25015 continue
      n=n+1
      u(100)=arhs(n)
      n=n+1
      u(101)=arhs(n)
      amer=0.0
      arer=0.0
      do 25016 i=1,101
          am=abs(real(u(i)-v(i)))
          ar=am/v(i)
          if(am.gt.amer) amer=am
          if(ar.gt.arer) arer=ar
25016 continue
      write(*,100)amer,arer
      stop
100     format(' max. abs. error = ',e12.2,' max. rel. error = ',e12.2)
      end

off essl;



%***********************************************************************
%*****                                                             *****
%*****      T e s t     Complex Examples   ---   More Modules      *****
%*****                                                             *****
%***********************************************************************

% Example M.1

off exp;


coordinates t,x into n,j;


grid uniform,x,t;


dependence v(t,x),w(t,x);


isgrid v(x..one),w(x..half);


iim aa, v, diff(v,t)=c*diff(w,x),
        w, diff(w,t)=c*diff(v,x);


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(v,t) - diff(w,x)*c    =    0

 - diff(v,x)*c + diff(w,t)    =    0


0 interpolations are needed in t coordinate
  Equation for v variable is integrated in half grid point
  Equation for w variable is integrated in half grid point
0 interpolations are needed in x coordinate
  Equation for v variable is integrated in one grid point
  Equation for w variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

       2*j - 1          2*j + 1              2*j + 1              2*j - 1
((w(n,---------) - w(n,---------) - w(n + 1,---------) + w(n + 1,---------))*c
          2                2                    2                    2

 *ht + 2*(v(n + 1,j) - v(n,j))*hx)/(2*ht*hx)   =   0


( - (v(n,j + 1) - v(n,j) - v(n + 1,j) + v(n + 1,j + 1))*c*ht

                2*j + 1          2*j + 1
  + 2*(w(n + 1,---------) - w(n,---------))*hx)/(2*ht*hx)   =   0
                   2                2



on exp;


center t=1/2;


functions v,w;


approx( aa(0,0)=aa(0,1));


 Difference scheme approximates differential equation df(v,t) - df(w,x)*c=0

 with orders of approximation:

  2
ht

  2
hx

center x=1/2;


approx( aa(1,0)=aa(1,1));


 Difference scheme approximates differential equation  - df(v,x)*c + df(w,t)=0

 with orders of approximation:

  2
ht

  2
hx

let cos ax**2=1-sin ax**2;


unfunc v,w;


matrix a(1,2),b(2,2),bt(2,2);


a(1,1):=aa(0,0);


                                                    2*j - 1
a(1,1) := (2*v(n + 1,j)*hx - 2*v(n,j)*hx + w(n + 1,---------)*c*ht
                                                       2

                       2*j + 1               2*j - 1
            - w(n + 1,---------)*c*ht + w(n,---------)*c*ht
                          2                     2

                   2*j + 1
            - w(n,---------)*c*ht)/(2*ht*hx)
                      2

a(1,2):=aa(1,0);


a(1,2) := ( - v(n + 1,j + 1)*c*ht + v(n + 1,j)*c*ht - v(n,j + 1)*c*ht

                                       2*j + 1               2*j + 1
            + v(n,j)*c*ht + 2*w(n + 1,---------)*hx - 2*w(n,---------)*hx)/(2*ht
                                          2                     2

             *hx)

off prfourmat;


b:=ampmat a;


       kx*hx
ax := -------
         2


     [           2  2   2     2                             ]
     [  - sin(ax) *c *ht  + hx       2*i*sin(ax)*c*ht*hx    ]
     [--------------------------   -----------------------  ]
     [         2  2   2     2              2  2   2     2   ]
     [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]
b := [                                                      ]
     [                                       2  2   2     2 ]
     [   2*i*sin(ax)*c*ht*hx        - sin(ax) *c *ht  + hx  ]
     [ -----------------------    --------------------------]
     [         2  2   2     2              2  2   2     2   ]
     [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]


clear a,aa;


factor lam;


pol:=charpol b;


           2         4  4   4            2  2   2   2     4
pol := (lam *(sin(ax) *c *ht  + 2*sin(ax) *c *ht *hx  + hx )

                         4  4   4     4           4  4   4
         + 2*lam*(sin(ax) *c *ht  - hx ) + sin(ax) *c *ht

                    2  2   2   2     4          4  4   4            2  2   2   2
         + 2*sin(ax) *c *ht *hx  + hx )/(sin(ax) *c *ht  + 2*sin(ax) *c *ht *hx

               4
           + hx )

pol:=troot1 pol;


                 2  2   2
        4*sin(ax) *c *ht
 If  -----------------------  =  0  and  0
             2  2   2     2
      sin(ax) *c *ht  + hx

  =  0  , a root of the polynomial is equal to 1.

           2         4  4   4            2  2   2   2     4
pol := (lam *(sin(ax) *c *ht  + 2*sin(ax) *c *ht *hx  + hx )

                         4  4   4     4           4  4   4
         + 2*lam*(sin(ax) *c *ht  - hx ) + sin(ax) *c *ht

                    2  2   2   2     4          4  4   4            2  2   2   2
         + 2*sin(ax) *c *ht *hx  + hx )/(sin(ax) *c *ht  + 2*sin(ax) *c *ht *hx

               4
           + hx )

pol:=hurw num pol;


pol := 

     2        2  2   2         2  2   2     2        2         2  2   2     2
4*lam *sin(ax) *c *ht *(sin(ax) *c *ht  + hx ) + 4*hx *(sin(ax) *c *ht  + hx )

hurwitzp pol;

Necessary and sufficient conditions are:
         2
       hx
-----------------  >  0
        2  2   2
 sin(ax) *c *ht


cond

bt:=tcon b;


      [           2  2   2     2                             ]
      [  - sin(ax) *c *ht  + hx       - 2*sin(ax)*c*ht*hx*i  ]
      [--------------------------   ------------------------ ]
      [         2  2   2     2              2  2   2     2   ]
      [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]
bt := [                                                      ]
      [                                       2  2   2     2 ]
      [   - 2*sin(ax)*c*ht*hx*i      - sin(ax) *c *ht  + hx  ]
      [ ------------------------   --------------------------]
      [         2  2   2     2              2  2   2     2   ]
      [  sin(ax) *c *ht  + hx        sin(ax) *c *ht  + hx    ]


bt*b;


[1  0]
[    ]
[0  1]


bt*b-b*bt;


[0  0]
[    ]
[0  0]


clear aa,a,b,bt;



%***********************************************************************

% Example M.2 : Richtmyer, Morton: Difference methods for initial value
%               problems, &10.2.  p.261

coordinates t,x into n,j;


grid uniform,t,x;


let cos ax**2=1-sin ax**2;


unfunc v,w;


matrix a(1,2),b(2,2),bt(2,2);


a(1,1):=(v(n+1)-v(n))/ht-c*(w(j+1/2)-w(j-1/2))/hx$


a(1,2):=(w(n+1,j-1/2)-w(n,j-1/2))/ht-c*(v(n+1,j)-v(n+1,j-1))/hx$


off prfourmat;


b:=ampmat a;


       kx*hx
ax := -------
         2


     [                          2*i*sin(ax)*c*ht      ]
     [        1                ------------------     ]
     [                                 hx             ]
     [                                                ]
b := [                                 2  2   2     2 ]
     [ 2*i*sin(ax)*c*ht     - 4*sin(ax) *c *ht  + hx  ]
     [------------------  ----------------------------]
     [        hx                        2             ]
     [                                hx              ]


clear a;


factor lam;


pol:=charpol b;


           2   2                   2  2   2     2      2
        lam *hx  + 2*lam*(2*sin(ax) *c *ht  - hx ) + hx
pol := --------------------------------------------------
                                2
                              hx

pol:=hurw num pol;


            2        2  2   2                2  2   2     2
pol := 4*lam *sin(ax) *c *ht  + 4*( - sin(ax) *c *ht  + hx )

hurwitzp pol;

Necessary and sufficient conditions are:
           2  2   2     2
  - sin(ax) *c *ht  + hx
--------------------------  >  0
            2  2   2
     sin(ax) *c *ht


cond

bt:=tcon b;


      [                            - 2*sin(ax)*c*ht*i     ]
      [          1               ---------------------    ]
      [                                   hx              ]
      [                                                   ]
bt := [                                    2  2   2     2 ]
      [  - 2*sin(ax)*c*ht*i     - 4*sin(ax) *c *ht  + hx  ]
      [---------------------  ----------------------------]
      [         hx                          2             ]
      [                                   hx              ]


bt*b;


[          2  2   2     2                           3  3   3                  ]
[ 4*sin(ax) *c *ht  + hx                   8*sin(ax) *c *ht *i                ]
[-------------------------                ---------------------               ]
[             2                                      3                        ]
[           hx                                     hx                         ]
[                                                                             ]
[             3  3   3                 4  4   4            2  2   2   2     4 ]
[  - 8*sin(ax) *c *ht *i     16*sin(ax) *c *ht  - 4*sin(ax) *c *ht *hx  + hx  ]
[------------------------   --------------------------------------------------]
[            3                                       4                        ]
[          hx                                      hx                         ]


bt*b-b*bt;


[                                      3  3   3   ]
[                            16*sin(ax) *c *ht *i ]
[            0              ----------------------]
[                                      3          ]
[                                    hx           ]
[                                                 ]
[              3  3   3                           ]
[  - 16*sin(ax) *c *ht *i                         ]
[-------------------------            0           ]
[             3                                   ]
[           hx                                    ]


clear a,b,bt;



%***********************************************************************

% Example M.3: Mazurik: Algoritmy resenia zadaci..., preprint no.24-85,
%               AN USSR SO, Inst. teor. i prikl. mechaniky, p.34

operator v1,v2;


matrix a(1,3),b(3,3),bt(3,3);


a(1,1):=(p(n+1)-p(n))/ht+c/2*((-p(m-1)+2*p(m)-p(m+1))/hx +
         (v1(m+1)-v1(m-1))/hx - (p(k-1)-2*p(k)+p(k+1))/hy +
         (v2(k+1)-v2(k-1))/hy)$


a(1,2):=(v1(n+1)-v1(n))/ht+c/2*((p(m+1)-p(m-1))/hx -
         (v1(m-1)-2*v1(m)+v1(m+1))/hx)$


a(1,3):=(v2(n+1)-v2(n))/ht + c/2*((p(k+1)-p(k-1))/hy -
         (v2(k-1)-2*v2(k)+v2(k+1))/hy)$


coordinates t,x,y into n,m,k;


functions p,v1,v2;


for k:=1:3 do approx(a(1,k)=0);


 Difference scheme approximates differential equation 

df(p,t) + df(v1,x)*c + df(v2,y)*c=0

 with orders of approximation:

  2
ht

hx

hy

 Difference scheme approximates differential equation df(p,x)*c + df(v1,t)=0

 with orders of approximation:

  2
ht

hx

1

 Difference scheme approximates differential equation df(p,y)*c + df(v2,t)=0

 with orders of approximation:

  2
ht

1

hy

grid uniform,t,x,y;


unfunc p,v1,v2;


hy:=hx;


hy := hx

off prfourmat;


b:=ampmat a;


ax := kx*hx


ay := ky*hy


           cos(ax)*c*ht + cos(ay)*c*ht - 2*c*ht + hx    - i*sin(ax)*c*ht
b := mat((-------------------------------------------,-------------------,
                              hx                              hx

            - i*sin(ay)*c*ht
          -------------------),
                  hx

            - i*sin(ax)*c*ht   cos(ax)*c*ht - c*ht + hx
         (-------------------,--------------------------,0),
                  hx                      hx

            - i*sin(ay)*c*ht     cos(ay)*c*ht - c*ht + hx
         (-------------------,0,--------------------------))
                  hx                        hx


pol:=charpol b;


           3   3      2   2
pol := (lam *hx  + lam *hx *( - 2*cos(ax)*c*ht - 2*cos(ay)*c*ht + 4*c*ht - 3*hx)

                                      2   2              2   2
         + lam*hx*(3*cos(ax)*cos(ay)*c *ht  - 5*cos(ax)*c *ht

                                             2   2
            + 4*cos(ax)*c*ht*hx - 5*cos(ay)*c *ht  + 4*cos(ay)*c*ht*hx

                 2   2                   2                       3   3
            + 7*c *ht  - 8*c*ht*hx + 3*hx ) + 4*cos(ax)*cos(ay)*c *ht

                              2   2                 3   3              2   2
         - 3*cos(ax)*cos(ay)*c *ht *hx - 4*cos(ax)*c *ht  + 5*cos(ax)*c *ht *hx

                            2              3   3              2   2
         - 2*cos(ax)*c*ht*hx  - 4*cos(ay)*c *ht  + 5*cos(ay)*c *ht *hx

                            2      3   3      2   2               2     3    3
         - 2*cos(ay)*c*ht*hx  + 4*c *ht  - 7*c *ht *hx + 4*c*ht*hx  - hx )/hx

let
  cos ax=cos ax2**2-sin ax2**2,
  cos ay=cos ay2**2-sin ay2**2,
  sin ax=2*sin ax2*cos ax2,
  sin ay=2*sin ay2*cos ay2,
  cos ax2**2=1-sin ax2**2,
  cos ay2**2=1-sin ay2**2,
  sin ax2=s1,
  sin ay2=s2,
  hx=c*ht/cap;


factor lam;


order s1,s2;


pol:=troot1 pol;


          2   2    3
 If  16*s1 *s2 *cap   =  0  and  0

  =  0  , a root of the polynomial is equal to 1.

          3      2      2           2
pol := lam  + lam *(4*s1 *cap + 4*s2 *cap - 3) + lam

              2   2    2       2    2       2           2    2       2
       *(12*s1 *s2 *cap  + 4*s1 *cap  - 8*s1 *cap + 4*s2 *cap  - 8*s2 *cap + 3)

               2   2    3        2   2    2       2    2       2
        + 16*s1 *s2 *cap  - 12*s1 *s2 *cap  - 4*s1 *cap  + 4*s1 *cap

              2    2       2
        - 4*s2 *cap  + 4*s2 *cap - 1

clear cos ax,cos ay,sin ax,sin ay,cos ax2**2,cos ay2**2,sin ax2,sin ay2,
      hx,hy;


pol:=hurw num pol;


             3   2   2    3
pol := 16*lam *s1 *s2 *cap

               2    2         2   2           2   2     2     2
        + 8*lam *cap *( - 6*s1 *s2 *cap + 3*s1 *s2  + s1  + s2 ) + 16*lam*cap

             2   2    2       2   2         2         2     2         2
       *(3*s1 *s2 *cap  - 3*s1 *s2 *cap - s1 *cap + s1  - s2 *cap + s2 ) + 8*(

                 2   2    3       2   2    2     2    2       2         2    2
           - 2*s1 *s2 *cap  + 3*s1 *s2 *cap  + s1 *cap  - 2*s1 *cap + s2 *cap

                 2
           - 2*s2 *cap + 1)

hurwitzp pol;

If we denote:
           2   2    3
 (1)  16*s1 *s2 *cap   >  0

           2         2   2           2   2     2     2
 (2)  8*cap *( - 6*s1 *s2 *cap + 3*s1 *s2  + s1  + s2 )  >  0

                  2   2    2       2   2         2         2     2         2
 (3)  16*cap*(3*s1 *s2 *cap  - 3*s1 *s2 *cap - s1 *cap + s1  - s2 *cap + s2 )

  >  0

                2   2    3       2   2    2     2    2       2         2    2
 (4)  8*( - 2*s1 *s2 *cap  + 3*s1 *s2 *cap  + s1 *cap  - 2*s1 *cap + s2 *cap

                2
          - 2*s2 *cap + 1)  >  0

           2         2   2           2   2     2     2
 (5)  8*cap *( - 6*s1 *s2 *cap + 3*s1 *s2  + s1  + s2 )  >  0

             3          4   4    3        4   4    2       4   4
 (6)  128*cap *( - 16*s1 *s2 *cap  + 24*s1 *s2 *cap  - 9*s1 *s2 *cap

                       4   2    2        4   2           4   2     4         4
                 + 8*s1 *s2 *cap  - 10*s1 *s2 *cap + 3*s1 *s2  - s1 *cap + s1

                       2   4    2        2   4           2   4       2   2
                 + 8*s1 *s2 *cap  - 10*s1 *s2 *cap + 3*s1 *s2  - 2*s1 *s2 *cap

                     2   2     4         4
                 + s1 *s2  - s2 *cap + s2 )  >  0

              3       6   6    6        6   6    5        6   6    4
 (7)  1024*cap *(32*s1 *s2 *cap  - 96*s1 *s2 *cap  + 90*s1 *s2 *cap

                         6   6    3        6   4    5         6   4    4
                  - 27*s1 *s2 *cap  - 32*s1 *s2 *cap  + 100*s1 *s2 *cap

                         6   4    3        6   4    2        6   2    4
                  - 93*s1 *s2 *cap  + 27*s1 *s2 *cap  + 10*s1 *s2 *cap

                         6   2    3        6   2    2       6   2         6    3
                  - 31*s1 *s2 *cap  + 26*s1 *s2 *cap  - 6*s1 *s2 *cap - s1 *cap

                        6    2       6            4   6    5         4   6    4
                  + 3*s1 *cap  - 2*s1 *cap - 32*s1 *s2 *cap  + 100*s1 *s2 *cap

                         4   6    3        4   6    2        4   4    4
                  - 93*s1 *s2 *cap  + 27*s1 *s2 *cap  + 20*s1 *s2 *cap

                         4   4    3        4   4    2        4   4
                  - 76*s1 *s2 *cap  + 73*s1 *s2 *cap  - 21*s1 *s2 *cap

                        4   2    3        4   2    2        4   2
                  - 3*s1 *s2 *cap  + 16*s1 *s2 *cap  - 14*s1 *s2 *cap

                        4   2     4         4        2   6    4
                  + 3*s1 *s2  - s1 *cap + s1  + 10*s1 *s2 *cap

                         2   6    3        2   6    2       2   6
                  - 31*s1 *s2 *cap  + 26*s1 *s2 *cap  - 6*s1 *s2 *cap

                        2   4    3        2   4    2        2   4
                  - 3*s1 *s2 *cap  + 16*s1 *s2 *cap  - 14*s1 *s2 *cap

                        2   4       2   2         2   2     6    3       6    2
                  + 3*s1 *s2  - 2*s1 *s2 *cap + s1 *s2  - s2 *cap  + 3*s2 *cap

                        6         4         4
                  - 2*s2 *cap - s2 *cap + s2 )  >  0

 (c1)   (1) AND (2) AND (4)

 (c2)   (1) AND (3) AND (4)

 (d1)   (5) AND (7)

 (d2)   (6)

Necessary and sufficient conditions are:
  (  (C1)  OR  (C2)  )  AND  (  (D1)  OR  (D2)  )

cond

bt:=tcon b;


            cos(ax)*c*ht + cos(ay)*c*ht - 2*c*ht + hx   sin(ax)*c*ht*i
bt := mat((-------------------------------------------,----------------,
                               hx                             hx

            sin(ay)*c*ht*i
           ----------------),
                  hx

            sin(ax)*c*ht*i   cos(ax)*c*ht - c*ht + hx
          (----------------,--------------------------,0),
                  hx                    hx

            sin(ay)*c*ht*i     cos(ay)*c*ht - c*ht + hx
          (----------------,0,--------------------------))
                  hx                      hx


bt*b;


                         2   2              2   2
mat(((2*cos(ax)*cos(ay)*c *ht  - 4*cos(ax)*c *ht  + 2*cos(ax)*c*ht*hx

                    2   2                          2   2                 2    2
       - 4*cos(ay)*c *ht  + 2*cos(ay)*c*ht*hx + 6*c *ht  - 4*c*ht*hx + hx )/hx ,

               2   2                               2   2
      sin(ax)*c *ht *i*( - cos(ay) + 1)   sin(ay)*c *ht *i*( - cos(ax) + 1)
     -----------------------------------,-----------------------------------),
                       2                                   2
                     hx                                  hx

               2   2
      sin(ax)*c *ht *i*(cos(ay) - 1)
    (--------------------------------,
                     2
                   hx

                    2   2                          2   2                 2
       - 2*cos(ax)*c *ht  + 2*cos(ax)*c*ht*hx + 2*c *ht  - 2*c*ht*hx + hx
     ----------------------------------------------------------------------,
                                        2
                                      hx

                       2   2
      sin(ax)*sin(ay)*c *ht
     ------------------------),
                 2
               hx

               2   2                                    2   2
      sin(ay)*c *ht *i*(cos(ax) - 1)   sin(ax)*sin(ay)*c *ht
    (--------------------------------,------------------------,
                     2                            2
                   hx                           hx

                    2   2                          2   2                 2
       - 2*cos(ay)*c *ht  + 2*cos(ay)*c*ht*hx + 2*c *ht  - 2*c*ht*hx + hx
     ----------------------------------------------------------------------))
                                        2
                                      hx


bt*b-b*bt;


                   2   2
        2*sin(ax)*c *ht *i*( - cos(ay) + 1)
mat((0,-------------------------------------,
                          2
                        hx

                 2   2
      2*sin(ay)*c *ht *i*( - cos(ax) + 1)
     -------------------------------------),
                        2
                      hx

                 2   2
      2*sin(ax)*c *ht *i*(cos(ay) - 1)
    (----------------------------------,0,0),
                      2
                    hx

                 2   2
      2*sin(ay)*c *ht *i*(cos(ax) - 1)
    (----------------------------------,0,0))
                      2
                    hx


clear a,b,bt,pol;



%***********************************************************************

end;


Time for test: 265 ms
@@@@@ Resources used: (1 2 144 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/discret.red0000644000175000017500000001300711526203062023545 0ustar  giovannigiovannimodule discret; % Data for discretization.

% Author: Richard Liska.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

difmatch all,1,
  0,1$
difmatch all,u,
  u=one,0,
    u(i),
  u=half,0,
    (u(i-1/2)+u(i+1/2))/2$
difmatch all,diff(u,x),
  u=one,2,
    (u(i+1)-u(i-1))/(dip1+dim1),
  u=half,0,
    (u(i+1/2)-u(i-1/2))/di$
difmatch all,diff(u,x,2),
  u=one,0,
    ((u(i+1)-u(i))/dip1-(u(i)-u(i-1))/dim1)/di,
  u=half,2,
    ((u(i+3/2)-u(i+1/2))/dip2-(u(i-1/2)-u(i-3/2))/dim2)/(dip1+dim1)$
difmatch all,u*v,
  u=one,v=one,0,
    u(i)*v(i),
  u=one,v=half,0,
    u(i)*(v(i-1/2)+v(i+1/2))/2,
  u=half,v=one,0,
    (u(i-1/2)+u(i+1/2))/2*v(i),
  u=half,v=half,0,
    (u(i-1/2)*v(i-1/2)+u(i+1/2)*v(i+1/2))/2$
difmatch all,u**n,
  u=one,0,
    u(i)**n,
  u=half,0,
    (u(i-1/2)**n+u(i+1/2)**n)/2$
difmatch all,u*v**n,
  u=one,v=one,0,
    u(i)*v(i)**n,
  u=one,v=half,0,
    u(i)*(v(i-1/2)**n+v(i+1/2)**n)/2,
  u=half,v=one,0,
    (u(i-1/2)+u(i+1/2))/2*v(i)**n,
  u=half,v=half,0,
    (u(i-1/2)*v(i-1/2)**n+u(i+1/2)*v(i+1/2)**n)/2$
difmatch all,u*v*w,
  u=one,v=one,w=one,0,
    u(i)*v(i)*w(i),
  u=one,v=one,w=half,0,
    u(i)*v(i)*(w(i+1/2)+w(i-1/2))/2,
  u=one,v=half,w=one,0,
    u(i)*(v(i-1/2)+v(i+1/2))/2*w(i),
  u=one,v=half,w=half,0,
    u(i)*(v(i-1/2)*w(i-1/2)+v(i+1/2)*w(i+1/2))/2,
  u=half,v=one,w=one,0,
    (u(i-1/2)+u(i+1/2))/2*v(i)*w(i),
  u=half,v=one,w=half,0,
    (u(i-1/2)*w(i-1/2)+u(i+1/2)*w(i+1/2))/2*v(i),
  u=half,v=half,w=one,0,
    (u(i-1/2)*v(i-1/2)+u(i+1/2)*v(i+1/2))/2*w(i),
  u=half,v=half,w=half,0,
    (u(i-1/2)*v(i-1/2)*w(i-1/2)+u(i+1/2)*v(i+1/2)*w(i+1/2))/2$
difmatch all,v*diff(u,x),
  u=one,v=one,2,
    v(i)*(u(i+1)-u(i-1))/(dip1+dim1),
  u=one,v=half,2,
    (v(i+1/2)+v(i-1/2))/2*(u(i+1)-u(i-1))/(dip1+dim1),
  u=half,v=one,0,
    v(i)*(u(i+1/2)-u(i-1/2))/di,
  u=half,v=half,0,
    (v(i+1/2)+v(i-1/2))/2*(u(i+1/2)-u(i-1/2))/di$
difmatch all,v*w*diff(u,x),
  u=one,v=one,w=one,2,
    v(i)*w(i)*(u(i+1)-u(i-1))/(dip1+dim1),
  u=one,v=one,w=half,2,
    v(i)*(w(i-1/2)+w(i+1/2))/2*(u(i+1)-u(i-1))/(dip1+dim1),
  u=one,v=half,w=one,2,
    (v(i+1/2)+v(i-1/2))/2*w(i)*(u(i+1)-u(i-1))/(dip1+dim1),
  u=one,v=half,w=half,2,
    (v(i+1/2)*w(i+1/2)+v(i-1/2)*w(i-1/2))/2*(u(i+1)-u(i-1))/(dip1+dim1),
  u=half,v=one,w=one,0,
    v(i)*w(i)*(u(i+1/2)-u(i-1/2))/di,
  u=half,v=one,w=half,0,
    v(i)*(w(i-1/2)+w(i+1/2))/2*(u(i+1/2)-u(i-1/2))/di,
  u=half,v=half,w=one,0,
    (v(i+1/2)+v(i-1/2))/2*w(i)*(u(i+1/2)-u(i-1/2))/di,
  u=half,v=half,w=half,0,
    (v(i+1/2)*w(i+1/2)+v(i-1/2)*w(i-1/2))/2*(u(i+1/2)-u(i-1/2))/di$
difmatch all,x*u,
  u=one,0,
    x(i)*u(i),
  u=half,1,
    (x(i-1/2)*u(i-1/2)+x(i+1/2)*u(i+1/2))/2$
difmatch all,u/x**n,
  u=one,0,
    u(i)/x(i)**n,
  u=half,0,
    (u(i-1/2)/x(i-1/2)**n+u(i+1/2)/x(i+1/2)**n)/2$
difmatch all,u*v/x**n,
  u=one,v=one,0,
    u(i)*v(i)/x(i)**n,
  u=one,v=half,0,
    u(i)*(v(i-1/2)+v(i+1/2))/2/x(i)**n,
  u=half,v=one,0,
    (u(i-1/2)+u(i+1/2))/2*v(i)/x(i)**n,
  u=half,v=half,0,
    (u(i-1/2)*v(i-1/2)/x(i-1/2)**n+u(i+1/2)*v(i+1/2)/x(i+1/2)**n)/2$
difmatch all,diff(x**n*u,x)/x**n,
  u=one,2,
    (x(i+1)**n*u(i+1)-x(i-1)**n*u(i-1))/x(i)**n/(dim1+dip1),
  u=half,0,
    (x(i+1/2)**n*u(i+1/2)-x(i-1/2)**n*u(i-1/2))/di/x(i)**n$
difmatch all,diff(u*v,x),
  u=one,v=one,4,
    (u(i+1)*v(i+1)-u(i-1)*v(i-1))/(dim1+dip1),
  u=one,v=half,2,
    ((u(i+1)+u(i))/2*v(i+1/2)-(u(i-1)+u(i))/2*v(i-1/2))/di,
  u=half,v=one,2,
    ((v(i+1)+v(i))/2*u(i+1/2)-(v(i-1)+v(i))/2*u(i-1/2))/di,
  u=half,v=half,0,
    (u(i+1/2)*v(i+1/2)-u(i-1/2)*v(i-1/2))/di$
difmatch all,diff(u*v,x)/x**n,
  u=one,v=one,4,
    (u(i+1)*v(i+1)-u(i-1)*v(i-1))/x(i)**n/(dim1+dip1),
  u=one,v=half,2,
    ((u(i+1)+u(i))/2*v(i+1/2)-(u(i-1)+u(i))/2*v(i-1/2))/x(i)**n/di,
  u=half,v=one,2,
    ((v(i+1)+v(i))/2*u(i+1/2)-(v(i-1)+v(i))/2*u(i-1/2))/x(i)**n/di,
  u=half,v=half,0,
    (u(i+1/2)*v(i+1/2)-u(i-1/2)*v(i-1/2))/x(i)**n/di$
difmatch all,diff(u*diff(v,x),x)/x**n,
  u=half,v=one,0,
   (u(i+1/2)*(v(i+1)-v(i))/dip1-u(i-1/2)*(v(i)-v(i-1))/dim1)/di/x(i)**n,
  u=half,v=half,2,
    (u(i+1/2)*(v(i+3/2)-v(i-1/2))/(di+dip2)-u(i-1/2)*(v(i+1/2)-
       v(i-3/2))/(di+dim2))/di/x(i)**n,
  u=one,v=one,2,
    ((u(i+1)+u(i))/2*(v(i+1)-v(i))/dip1-(u(i)+u(i-1))/2*(v(i)-v(i-1))
       /dim1)/di/x(i)**n,
  u=one,v=half,4,
    ((u(i+1)+u(i))/2*(v(i+3/2)-v(i-1/2))/(di+dip2)-
     (u(i)+u(i-1))/2*(v(i+1/2)-v(i-3/2))/(di+dim2))/di/x(i)**n$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/charpol.red0000644000175000017500000002440711526203062023546 0ustar  giovannigiovannimodule charpol;

% Author: R. Liska.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version REDUCE 3.6     05/1991.

fluid '(!*exp !*gcd !*prfourmat)$

switch prfourmat$
!*prfourmat:=t$

procedure coefc1 uu$
begin
  scalar lco,l,u,v,a$
  u:=car uu$
  v:=cadr uu$
  a:=caddr uu$
  lco:=aeval list('coeff,u,v)$
  lco:=cdr lco$
  l:=length lco - 1$
  for i:=0:l do
    <>$
  return (l . 1)
end$

deflist('((coefc1 coefc1)),'simpfn)$

global '(cursym!* coords!* icoords!* unvars!*)$

icoords!*:='(i j k l m n i1 j1 k1 l1 m1 n1)$

flag('(tcon unit charmat ampmat denotemat),'matflg)$

put('unit,'rtypefn,'getrtypecar)$
put('charmat,'rtypefn,'getrtypecar)$
put('ampmat,'rtypefn,'getrtypecar)$
put('denotemat,'rtypefn,'getrtypecar)$

procedure unit u$
generateident length matsm u$

procedure charmat u$
matsm list('difference,list('times,'lam,list('unit,u)),u)$

procedure charpol u$
begin
  scalar x,complexx;
  complexx:=!*complex;
  algebraic on complex;
  x:=simp list('det,list('charmat,carx(u,'charpol)))$
  if null complexx then algebraic off complex;
  return x
end;

put('charpol,'simpfn,'charpol)$

algebraic$
korder lam$

procedure re(x)$
sub(i=0,x)$

procedure im(x)$
(x-re(x))/i$

procedure con(x)$
sub(i=-i,x)$

procedure complexpol x$
begin
  scalar y$
  y:=troot1 x$
  return if im y=0 then y
           else y*con y
end$

procedure troot1 x$
begin
  scalar y$
  y:=x$
  while not(sub(lam=0,y)=y) and sub(lam=1,y)=0 do y:=y/(lam-1)$
  x:=sub(lam=1,y)$
  if not(numberp y or (numberp num y and numberp den y)) then
      write " If  ",re x,"  =  0  and  ",im x,
            "  =  0  , a root of the polynomial is equal to 1."$
  return y
end$

procedure hurw(x)$
% X is a polynomial in LAM, all its roots are |LAMI|<1 <=> for all roots
% of the polynomial HURW(X) holds RE(LAMI)<0.
(lam-1)**deg(num x,lam)*sub(lam=(lam+1)/(lam-1),x)$

symbolic$

procedure unfunc u$
<>$

put('unfunc,'stat,'rlis)$

global '(denotation!* denotid!*)$
denotation!*:=nil$
denotid!*:='a$

procedure denotid u$
<>$

put('denotid,'stat,'rlis)$

procedure cleardenot$
denotation!*:=nil$

put('cleardenot,'stat,'endstat)$
flag('(cleardenot),'eval)$

algebraic$
array cofpol!*(20)$

procedure denotepol u$
begin
  scalar nco,dco$
  dco:=den u$
  u:=num u$
  nco:=coefc1 (u,lam,cofpol!*)$
  for j:=0:nco do cofpol!*(j):=cofpol!*(j)/dco$
  denotear nco$
  u:=for j:=0:nco sum lam**j*cofpol!*(j)$
  return u
end$

symbolic$

put('denotear,'simpfn,'denotear)$

procedure denotear u$
begin
  scalar nco,x$
  nco:=car u$
  for i:=0:nco do
    <>$
  return (nil .1)
end$

procedure denotemat u$
begin
  scalar i,j,x$
  i:=0$
  x:=for each a in  matsm u collect
       <> >>$
  return x
end$

procedure denote(u,i,j)$
% U is prefix form, I,J are integers
begin
  scalar reu,imu,ireu,iimu,eij,fgcd$
  if atom u then return simp u$
  fgcd:=!*gcd$
  !*gcd:=t$
  reu:=simp!* list('re,u)$
  imu:=simp!* list('im,u)$
  !*gcd:=fgcd$
  eij:=append(explode i,explode j)$
  ireu:=intern compress append(append(explode denotid!* ,'(r)),eij)$
  iimu:=intern compress append(append(explode denotid!* ,'(i)),eij)$
  if car reu then insdenot(ireu,reu)$
  if car imu then insdenot(iimu,imu)$
  return simp list('plus,
                   if car reu then ireu
                     else 0,
                   list('times,
                        'i,
                        if car imu then iimu
                          else 0))
end$

procedure insdenot(iden,u)$
denotation!*:=(u . iden) . denotation!*$

procedure prdenot$
for each a in reverse denotation!* do
  assgnpri(list('!*sq,car a,t),list cdr a,'only)$

put('prdenot,'stat,'endstat)$
flag('(prdenot),'eval)$

procedure ampmat u$
begin
  scalar x,i,h1,h0,un,rh1,rh0,ru,ph1,ph0,!*exp,!*gcd,complexx$
  complexx:=!*complex;
  !*exp:=t$
  fouriersubs()$
  u:=car matsm u$
  x:=for each a in coords!* collect if a='t then 0
                                      else list('times,
                                                tcar get(a,'index),
                                                get(a,'wave),
                                                get(a,'step))$
  x:=list('expp,'plus . x)$
  x:=simp x$
  u:=for each a in u collect resimp quotsq(a,x)$
  gonsubs()$
  algebraic on complex;
  u:=for each a in u collect resimp a$
  remfourier()$
a:if null u then go to d$
  ru:=caar u$
  un:=unvars!*$
  i:=1$
b:if un then go to c$
  rh1:=reverse rh1$
  rh0:=reverse rh0$
  h1:=rh1 . h1$
  h0:=rh0 . h0$
  rh0:=rh1:=nil$
  u:=cdr u$
  go to a$
c:rh1:=coefck(ru,list('u1!*,i)) . rh1$
  rh0:=negsq coefck(ru,list('u0!*,i)) . rh0$
  un:=cdr un$
  i:=i+1$
  go to b$
d:h1:=reverse h1$
  h0:=reverse h0$
  if !*prfourmat then
      <>$
  !*gcd:=t;
  x:=if length h1=1 then list list quotsq(caar h0,caar h1)
       else lnrsolve(h1,h0)$
  if null complexx then algebraic off complex;
  return x
end$

procedure coefck(x,y)$
% X is standard form, Y is prefix form, returns coefficient of Y
% appearing in X, i.e. X contains COEFCK(X,Y)*Y
begin
  scalar ky,xs$
  ky:=!*a2k y$
  xs:=car subf(x,list(ky . 0))$
  xs:=addf(x,negf xs)$
  if null xs then return(nil . 1)$
  xs:=quotf1(xs,!*k2f ky)$
  return if null xs then <>
           else !*f2q xs
end$

procedure simpfour u$
begin
  scalar nrunv,x,ex,arg,mv,cor,incr,lcor$
  nrunv:=get(car u,'nrunvar)$
a:u:=cdr u$
  if null u then go to r$
  arg:=simp car u$
  mv:=mvar car arg$
  if not atom mv or not numberp cdr arg then return msgpri
      ("Bad index ",car u,nil,nil,'hold)$
  cor:=tcar get(mv,'coord)$
  if not(cor member coords!*) then return msgpri
      ("Term ",car u," contains non-coordinate ",mv,'hold)$
  if cor member lcor then return msgpri
      ("Term ",car u," means second appearance of coordinate ",cor,
       'hold)$
  if not(cor='t) and cdr arg>get(cor,'maxden)
    then put(cor,'maxden,cdr arg)$
  lcor:=cor . lcor$
  incr:=addsq(arg,negsq !*k2q mv)$
  if not flagp(cor,'uniform) then return lprie
      ("Non-uniform grids not yet supported")$
  if cor='t then go to ti$
  ex:=list('times,car u,get(cor,'step),get(cor,'wave)) . ex$
  go to a$
ti:if null car incr then x:=list('u0!*,nrunv)
    else if incr= 1 . 1 then x:=list('u1!*,nrunv)
    else return lprie "Scheme is not twostep in time"$
  go to a$
r:for each a in setdiff(coords!*,lcor) do
    if a='t then x:=list('u0!*,nrunv)
      else ex:=list('times,tcar get(a,'index),get(a,'step),get(a,'wave))
                  . ex$
  return simp list('times,x,list('expp,'plus . ex))
end$

procedure fouriersubs$
begin
  scalar x,i$
  for each a in '(expp u1!* u0!*) do put(a,'simpfn,'simpiden)$
  x:=unvars!*$
  i:=1$
a:if null x then go to b$
  put(car x,'nrunvar,i)$
  i:=i+1$
  x:=cdr x$
  go to a$
b:flag(unvars!*,'full)$
  for each a in unvars!* do put(a,'simpfn,'simpfour)$
  for each a in coords!* do
    if not(a='t) then
    <>$
  algebraic for all z,y,v let
    expp((z+y)/v)=expp(z/v)*expp(y/v),
    expp(z+y)=expp z*expp y
end$

procedure gonsubs$
begin
  scalar xx$
  algebraic for all z,y,v clear expp((z+y)/v),expp(z+y)$
  for each a in coords!* do
    if not(a='t) then
      <>$
  algebraic for all x let expp x=cos x+i*sin x$
  algebraic for all x,n such that numberp n and n>1 let
    sin(n*x)=sin x*cos((n-1)*x)+cos x*sin((n-1)*x),
    cos(n*x)=cos x*cos((n-1)*x)-sin x*sin((n-1)*x)$
  for each a in unvars!* do
    <>
end$

procedure remfourier$
<1 clear
    sin(n*x),cos(n*x)$
  for each a in coords!* do
    if not(a='t) then
    <> >>$

operator numberp$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/iimet.red0000644000175000017500000016055211526203062023227 0ustar  giovannigiovannimodule iimet;

% Author: R. Liska
% Version REDUCE 3.6  05/1991$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(cursym!* !*val dimension!*)$
fluid '(!*exp alglist!*)$

symbolic procedure array u$
begin
  scalar msg,erfg$
  msg:=!*msg$
  !*msg:=nil$
  erfg:=erfg!*$
  erfg!*:=nil$
  arrayfn('symbolic,
          for each a in u collect(car a . sub1lis cdr a) )$
  erfg!*:=erfg$
  !*msg:=msg
end$

symbolic procedure sub1lis u$
   if null u then nil else ((car u - 1) . sub1lis cdr u)$

sfprod!*:=1$

global'(date!*!*)$

date!*!*:= "IIMET Ver 1.1.2"$

put('version,'stat,'rlis)$

put('diff,'simpfn,'simpiden)$

global '(coords!* icoords!* dvars!* grids!* given!* same!*
         difml!* iobjs!* !*twogrid !*eqfu !*fulleq !*centergrid)$

switch twogrid,eqfu,fulleq,centergrid$

!*twogrid:=t$      %  Given functions can be on both grids.
!*eqfu:=nil$       %  During pattern matching the given and
                   %  looked for functions are different.
!*fulleq:=t$       %  Optimalization is performed on both sides of PDE.
!*centergrid:=t$   %  Centers of grid cells are in points I
                   %  (otherwise in I+1/2).

icoords!*:='(i j k l m n i1 j1 k1 l1 m1 n1)$
%  Indices which are given implicit.

procedure coordfn$
% Stat procedure of the COORDINATES statement, which defines indexes
% of coordinates.
begin
  scalar cor,icor$
  flag('(into),'delim)$
  cor:=remcomma xread nil$
  remflag('(into),'delim)$
  if cursym!* eq 'into then
      icor:=remcomma xread nil
    else if cursym!* eq '!*semicol!* then
      icor:=icoords!*
    else return symerr('coordfn,t)$
  return list('putcor,
              mkquote cor,
              mkquote icor)
end$

put('coordinates,'stat,'coordfn)$
flag('(putcor),'nochange)$

procedure putcor(u,v)$
begin
  scalar j$
  j:=1$
  coords!*:=u$
  while u do
    <>
end$

procedure tcar u$
if pairp u then car u
  else u$

procedure grid u$
%  Procedure definning the statement GRID.
eval list(get(car u,'grid),
          mkquote cdr u)$

put('grid,'stat,'rlis)$
put('uniform,'grid,'gridunif)$

procedure gridunif u$
flag(u,'uniform)$

procedure dependence u$
%  Procedure definning the statemnt DEPENDENCE.
begin
  scalar x,y,z,gg,l,te,yy,y1,yl$
  if null coords!* then rederr
       " Coordinates have not been defined yet"$
  gg:=explode '!*grid$
  l:=list(length coords!* + 1)$
a:x:=car u$
  y:=car x$
  if idp y then if not(y memq dvars!*) then dvars!*:=y . dvars!*
                  else nil
    else return msgpri(" Variable ",y," must be identifier",nil,
                       'hold)$
  z:=cdr x$
  x:=car z$
  if not numberp x then go to b$
  if x=1 then apply('vectors,list y)
    else if x=2 then apply('dyads,list y)
    else if x=0 then t
    else return errpri2(car u,'hold)$
  z:=cdr z$
b:yl:=nil$
  yy:=explode y$
  te:=aeval y$
  if eqcar(te,'tensor) then te:=caddr te
    else te:=nil$
  if te=1 then
      for i:=1:dimension!* do
        <>
    else if te=2 then
      for i:=1:dimension!* do
        for j:=1:dimension!* do
          <>
    else
      <>$
  for each a in yl do put(a,'simpfn, 'simpiden)$
  put(y,'names,reverse yl)$
  if te member '(1 2) then
      <>$
  for each v in z do
    if v memq coords!* then
        for each w in yl do depend1(w,v,t)
      else msgpri(" Identifier ",v," is not coordinate",nil,'hold)$
  u:=cdr u$
  if u then go to a$
  return nil
end$

put('dependence,'stat,'rlis)$

procedure given u$
begin
  scalar x,xnam$
a:x:=car u$
  xnam:=get(x,'names)$
  if not idp x then msgpri
       (" Variable ",x," must be identifier",nil,'hold)
    else if xnam then given!* := union(xnam,given!*)
    else msgpri
       (" Identifier ",x," is not variable",nil,'hold)$
  u:=cdr u$
  if u then go to a$
  return nil
end$

put('given,'stat,'rlis)$

procedure cleargiven$
<>$

put('cleargiven,'stat,'endstat)$
flag('(cleargiven),'eval)$

newtok'(( !. !. ) isgr)$
algebraic infix ..$
grids!* := '(one half)$

procedure trlis$
% Stat procedure of the statement ISGRID.
begin
  scalar x$
  put('!*,'newnam,'tims)$
  x:=rlis()$
  remprop('!*,'newnam)$
  return x
end$

procedure formtr(u,vars,mode)$
list('isgrid,mkquote cdr u)$

procedure isgrid u$
% Procedure definning the statement ISGRID.
begin
  scalar x,y,z,z1,te,gd,lz,lz1$
a:x:=car u$
  y:=car x$
  x:=cdr x$
  if not(y memq dvars!*) then return msgpri
      (" Identifier ",y," is not variable",nil,'hold)$
  if null x then go to er$
  te:=aeval y$
  te:=if eqcar(te,'tensor) then caddr te
        else nil$
  if (te=1 and null atom x and fide_indexp car x and gridp cdr x) or
     (te=2 and null atom x and fide_indexp car x and null atom cdr x
      and fide_indexp cadr x and gridp cddr x) or
     ((te=0 or null te) and null atom x and gridp x) then t
    else go to er$
  if te=1 then
      <>
    else if te=2 then
      <>
    else for each c in x do
        setel(list(get(y,'grid),car c),cadr c . nil)$
  u:=cdr u$
  if u then go to a$
  return nil$
er:errpri2(car u,'hold)
end$

put('isgrid,'stat,'trlis)$
put('isgrid,'formfn,'formtr)$

procedure fide_indexp u$
u eq 'tims or (numberp u and 0>$
  x:=same!*$
a:y:=car x$
  z:=u$
  bo:=nil$
  while z and not bo do
    <>$
  if bo then go to b$
  x:=cdr x$
  if x then go to a$
  same!*:= u . same!*$
  return nil$
b:rplaca(x,union(y,u))$
  return nil
end$

put('same,'stat,'rlis)$

procedure clearsame$
same!*:=nil$

put('clearsame,'stat,'endstat)$
flag('(clearsame),'eval)$

procedure mksame$
begin
  scalar x,y,z,yy,bo$
  x:=expndsame()$
a:y:=car x$
  yy:=y$
  while yy and not(car yy memq unvars) do yy:=cdr yy$
  if null yy then
       <>$
  if y neq yy then
      <>$
  z:=car y$
  yy:=cdr y$
  put(z,'sames,yy)$
  novars:=union(novars,yy)$
  for each a in cdr y do
  % Testing if A has appeared in the statement DEPENDENCE
    if not get(a,'grid) then msgpri
        (" Identifier ",a," is not variable",nil,'hold)
      else put(a,'same,z)$
  for i:=1:length coords!* do
    <>$
      if bo then filgrid(y,bo,i) >>$
b:x:=cdr x$
  if x then go to a$
  sunvars:=setdiff(unvars,novars)$
  return unvars
end$

procedure filgrid(y,bo,i)$
% Filling up after finding ISGRID according to SAME
begin
  scalar yy,bg$
  yy:=y$
  while yy do
    <>
end$

procedure expndsame$
% Extending SAME!* by new identifiers for vectors and tensors
begin
  scalar x,y,sam$
  x:=same!*$
a:y:=for each a in car x join copy1 get(a,'names)$
  sam:=y . sam$
  x:=cdr x$
  if x then go to a$
  return sam
end$

procedure copy1 u$
if null u then nil
  else if atom u then u
  else car u . copy1 cdr u$

procedure nrsame$
% Changing the numbering of variables according to SAME
for each a in sunvars do
  begin
    scalar x,nx$
    x:=get(a,'sames)$
    if x then
        <>$
    return nil
  end$

procedure iim u$
% Procedure defines the statement IIM
begin
  scalar xx,xxx,be,beb1,val,twogr$
  iim1 u$
  iobjs!*:=append(unvars,append(coords!*,given!*))$
  val:=!*val$
  !*val:=nil$
  novars:=sunvars:=nil$
  if same!* then mksame() else sunvars:=unvars$
  twogr:=!*twogrid$
  xxx:=setdiff(given!*,novars)$
  if !*twogrid then
      if null xxx then !*twogrid:=nil
        else flag(xxx,'twogrid)
    else sunvars:=union(sunvars,xxx)$
  flag(given!*,'noeq)$
  xxx:=0$                %  Numbering of variables and equation
  for each a in sunvars do
    <>$
  if same!* then nrsame()$
  xxx:=0$
  for each a in unvars do
    <>$
  lun:=length unvars-1$
  lsun:=length sunvars-1$
  eval list('array,mkquote list('!*f2 . add1lis list(lun,lsun,1)))$
  xxx:=coords!*$
d:coord:=car xxx$
  icor:=tcar get(coord,'index)$
  difml!*:=nil$
  for i:=0:10 do difml!*:=append(difml!*,
       for each a in getel list('difm!*,i) collect
           if (xx:=atsoc(coord,cdr a)) then car a . cdr xx
             else if (xx:=atsoc('all,cdr a)) then car a . cdr xx
             else nil )$
  difml!*:=for each a on difml!* join if null car a then nil
                                        else list car a$
  if !*twogrid then difml!*:=
      for each a in difml!* collect
        if (xx:=caadr a) and (!*eqfu or memq(caar xx,'(f g))) then
            (car a . extdif(cdr a,nil))
          else a$
  be:=iim2 ()$
  iim21 be$
  if car be then beb1:=iim22 be
    else beb1:=list(car be,cadr be,car be)$
  if not fixp intp then msgpri(" INTP after heuristic search ",
            nil,list("is not a number, INTP=",intp),nil,nil)$
  if not(intp=0) then iim3 beb1$
  iim4 ()$
  xxx:=cdr xxx$
  if xxx then go to d$
  iim5 ()$
  for each a in '(rtype avalue dimension) do remprop('!*f2,a)$
  !*val:=val$ !*twogrid:=twogr$
  return nil
end$

procedure extdif(x,lg)$
% Performs corrections of diff. schemes for given functions on
% two grids - everytime chooses the scheme with minimal penalty.
% LG - list of all terms from (U V W F G), which has been in X
%      already changed and choosen.
begin
  scalar olds,news,y,gy,xx,lgrid,gg,g1$
  lgrid:=get('difm!*,'grids)$
  gy:=caar x$
  gg:=gy$
  for each a in lg do gg:=delete(atsoc(a,gg),gg)$
  if gg then gg:=caar gg
    else return x$
  x:=for each a in x collect a$
a:xx:=x$
  y:=car x$
  gy:=car y$
  g1:=atsoc(gg,gy)$
  gy:=(gg . gnot cdr g1) . delete(g1,gy)$
  gy:=acmemb(gy,lgrid)$
  while cdr xx and not eqcar(cadr xx,gy) do xx:=cdr xx$
  if cdr xx then
      < cadadr xx
              or (cadr y=cadadr xx
                     and sublength caddr y > sublength car cddadr xx)
             then cadr xx
             else y$
        rplacd(xx,cddr xx) >>
    else olds:=y . olds$
  gy:=car y$
  g1:=atsoc(gg,gy)$
  gy:=delete(g1,gy)$
  if null gy then t
    else if (xx:=acmemb(gy,lgrid)) then gy:=xx
    else nconc(lgrid, list gy)$
  y:=gy . cdr y$
  news:=y . news$
  x:=cdr x$
  if x then go to a$
  if(xx:=caar news) and (!*eqfu or memq(caar xx,'(f g))) then
      <>$
  return nconc(olds,news)
end$

procedure sublength u$
if atom u then 0
  else length u + sublengthca u$

procedure sublengthca u$
if null u then 0
  else sublength car u + sublengthca cdr u$

procedure iim1 u$
% Checks the syntax of the IIM statement, calculates scalar PDEs,
% vector and tensor equations are expanded to scalar components.
begin
  scalar x,xx,e,te,exp$
  terpri()$
  prin2t"*****************************"$
  prin2 "*****      Program      *****          "$
  prin2t date!*!*$
  prin2t"*****************************"$
  exp:=!*exp$
  !*exp:=t$
  rhs:=lhs:=unvars:=nil$
  if null coords!* then return lprie " Coordinates defined not yet"$
  if null dvars!* then return lprie " Variables defined not yet"$
  for each v in dvars!* do
    if eqcar((te:=aeval v),'tensor) and caddr te member '(1 2) then
        <>$
  if atom u or not idp car u then return errpri2(u,'hold)$
  resar:=car u$
  u:=cdr u$
a:if atom u or atom cdr u then return errpri2(u,'hold)$
  x:=car u$
  if not idp x then return msgpri
      (" Parameter ",x," must be identifier",nil,'hold)
    else if not(x memq dvars!*) then return msgpri
      (" Identifier ",x," is not variable",nil,'hold)
    else if x memq unvars then return msgpri
      (" Variable ",x," has second appearance",nil,'hold)
    else if x memq given!* then return msgpri
      (" Variable ",x," cannot be declared given",nil,'hold)
    else unvars:=x . unvars$
  e:=cadr u$
  if not eqexpr e then return msgpri
      (" Parameter ",e," must be equation",nil,'hold)
    else e:=aeval list('times,
                       list('difference,cadr e,caddr e),
                       sfprod!*)$
  if atom e then return msgpri
      (" Equation ",e," must be P.D.E.",nil,'hold)$
  te:=aeval x$
  te:=if eqcar(te,'tensor) then caddr te
        else nil$
  if(te=1 and car e eq 'tensor and caddr e=1) or
    (te=2 and car e eq 'tensor and caddr e=2) or
    (null te and car e eq 'tensor and caddr e=0) then
      e:=cadddr e   %  Necessary to carrect after change in EXPRESS
    else if null te and car e eq '!*sq then e:=cadr e
    else return msgpri
      (" Tensor order of",x," does not correspond to order of ",e,
       'hold)$
  lhs:=e . lhs$
  u:=cddr u$
  if u then go to a$
  for each v in dvars!* do
    if eqcar((te:=aeval v),'tensor) and caddr te member '(1 2) then
        remprop(v,'kvalue)$
b:x:=car unvars$
  e:=car lhs$  %  Transformation of vectors and tensor into components
  te:=aeval x$
  te:=if eqcar(te,'tensor) then caddr te
        else nil$
  if te=1 then rhs:=append(e,rhs)
    else if te=2 then for each a in reverse e do
                        rhs:=append(a,rhs)
    else rhs:=e . rhs$
  xx:=append(get(x,'names),xx)$  %  Add the checking if given equation
  unvars:=cdr unvars$            %  solves given variable (tensor var.)
  lhs:=cdr lhs$
  if unvars then go to b$
  unvars:=xx$
  lhs:=rhs$
  put('diff,'simpfn,'zero)$      %  Splitting left and right hand side
  alglist!*:=nil . nil$          %  All derivatives go to left h.s.
  rhs:=for each a in rhs collect resimp a$
  put('diff,'simpfn,'simpiden)$
  alglist!*:=nil . nil$
  x:=lhs$
  xx:=rhs$
  terpri()$
  prin2t "      Partial Differential Equations"$
  prin2t "      =============================="$
  terpri()$
c:rplaca(xx,negsq car xx)$
  rplaca(x,prepsq!* addsq(car x,car xx))$
  rplaca(xx,prepsq!* car xx)$
  maprin car x$
  prin2!* "    =    "$
  maprin car xx$
  terpri!* t$
  rplaca(x,prepsq simp car x)$
  rplaca(xx,prepsq simp car xx)$
  x:=cdr x$
  xx:=cdr xx$
  if x then go to c$
  terpri()$
  x:=length lhs-1$
  if x=0 then eval list('array, mkquote list(resar . add1lis list(1)))
    else eval list('array,mkquote list(resar . add1lis list(x,1)))$
  !*exp:=exp$
  return nil
end$

procedure iim2$
% Defines the steps of the grid, splits variables to free and predefined
% grid in actual coordinate.
begin
  scalar b,e,xx,dihalf,dione,dihalfc$
  e:=append(explode 'h,explode coord)$
  e:=intern compress e$
  if flagp(coord,'uniform) then hi:=hip1:=him1:=him2:=e
    else <>$
  dihalf:=list(
        'di . list('quotient,
                   list('plus,him1,hi),
                   2),
        'dim1 . him1,
        'dip1 . hi,
        'dim2 . list('quotient,
                     list('plus,him2,him1),
                     2),
        'dip2 . list('quotient,
                     list('plus,hi,hip1),
                     2))$
  dihalfc:=list(
        'di . list('quotient,
                   list('plus,hip1,hi),
                   2),
        'dim1 . hi,
        'dip1 . hip1,
        'dim2 . list('quotient,
                     list('plus,hi,him1),
                     2),
        'dip2 . list('quotient,
                     list('plus,hip2,hip1),
                     2))$
  dione:=list(
        'di . hi,
        'dim1 . list('quotient,
                     list('plus,him1,hi),
                     2),
        'dip1 . list('quotient,
                     list('plus,hi,hip1),
                     2),
        'dim2 . him1,
        'dip2 . hip1)$
  put('steps,'one,
      ('i . icor) . (if !*centergrid then dione else dihalf))$
  put('steps,'half,
      ('i . list('plus,
                 icor,
                 '(quotient 1 2))) . (if !*centergrid then dihalfc
                                        else dione))$
  ncor:=get(coord,'ngrid)$     % Number of the COODR coordinate
  e:=nil$
  for each a in sunvars do     % Splitting of variables with predefined
                               % grid.
    if (xx:=getel list(get(a,'grid),ncor))
            and car xx then e:=a . e$
  b:=setdiff(sunvars,e)$
  return list(b,e)
end$

procedure filfree(var,vgrid,freelst,pgr,peq)$
begin
  scalar x,nx,grn,nv,ng,ngrn,g1,g2,saml,bsam,asam,egrid$
  x:=ngetvar (var,'nrvar)$
c:put(var,pgr,vgrid)$
  egrid:=vgrid$
  if flagp(var,'noeq) then go to d$
  nx:=ngetvar (var,'nreq)$
% calulating in which point will be the euation for VAR integrated
  if egrid:=get(var,coord) then go to a
    else egrid:=vgrid$
  put('f2val,'free,'f2vzero)$
  if (g1:=f2eval(nx,x,0)) > (g2:=f2eval(nx,x,1)) then
      egrid:=gnot vgrid$
  if not(g1=g2) then go to a$
  put('f2val,'free,'f2vmin)$
  if(g1:=f2eval(nx,x,0)) > (g2:=f2eval(nx,x,1)) then
      egrid:=gnot vgrid$
  if not(g1=g2) then go to a$
  put('f2val,'free,'f2vmax)$
  if (g1:=f2eval(nx,x,0)) > (g2:=f2eval(nx,x,1)) then
      egrid:=gnot vgrid$
a:put(var,peq,egrid)$
% Penalties for free variables in the equation for VAR
  grn:=gnot egrid$
  ng:=ngrid egrid$
  ngrn:=ngrid grn$
  for each a in freelst do
    <>$
  if bsam then go to d$
  saml:=get(var,'sames)$
  bsam:=t$
d:if null saml then go to b$
  var:=car saml$
  saml:=cdr saml$
  go to c$
b:return egrid
end$

procedure f2eval(i,j,k)$
eval getel list('!*f2,i,j,k)$

procedure f2plus(i,j,k,l)$
% Procedure fills F2(I,J,K) with the number F2(I,J,K)+L$
begin
  scalar ma,x,y$
  if pairp l then
      if length car l=2 and cadr l=caddr l then l:=cadr l
        else if length l=3 and cadr l=caddr l and cadr l=cadddr l and
                cadr l=car cddddr l then l:=cadr l$
  ma:=list('!*f2,i,j,k)$
  x:=getel ma$
  if numberp l then
      if numberp x then setel(ma,x+l)
        else rplaca(x,car x+l)
    else
      if numberp x then setel(ma,list(x,l))
        else if (y:=assoc(car l,cdr x)) then
                 <>>>
               else rplacd(x,(l . cdr x))
end$

procedure f2var u$
% Forms the elements of array !*F2 into the form
%               (FPLUS  {(F2VAL U V N1 N2)})
if numberp u then u
  else ('fplus .
            car u . for each a in cdr u collect
                      list('f2val,car a,cdr a) )$

macro procedure f2val x$
% Evaluates the expression (F2VAL ...)
begin
  scalar us,ns,u,v,w,n1,n2,n3,n4,gu,gv,gw$
  x:=cdr x;
  us:=car x$
  ns:=cadr x$
  u:=car us$
  v:=cadr us$
  n1:=car ns$
  n2:= cadr ns$
  gu:=get(u,xxgrid)$
  gv:=get(v,xxgrid)$
  if cddr us then
      <>$
  return mkquote
    if w then
        if gu and gv and gw then
            if gu eq gv and gu eq gw then n1
              else if gu eq gv then n2
              else if gu eq gw then n3
              else if gv eq gw then n4
              else apply(get('f2val,'free),list(us,ns))
          else if gu and gv then
            if gu eq gv then aplf2val(u,w,n1,n2)
              else aplf2val(u,w,n3,n4)
          else if gu and gw then
            if gu eq gw then aplf2val(u,v,n1,n3)
              else aplf2val(u,v,n2,n4)
          else if gv and gw then
            if gv eq gw then aplf2val(u,v,n1,n4)
              else aplf2val(u,v,n2,n3)
          else apply(get('f2val,'free),list(us,ns))
      else if gu and gv then
        if gu eq gv then n1
          else n2
      else apply(get('f2val,'free),list(us,ns))
end$

procedure aplf2val(u,v,n1,n2)$
apply(get('f2val,'free),list(list(u,v),list(n1,n2)))$

macro procedure fplus u$
% Evaluates the expression (FPLUS ...)
begin
  scalar x,y,z$
  u:=cdr u;
  y:=car u$
a:u:=cdr u$
  z:=eval car u$
  if numberp z then y:=y+z
    else x:=z . x$
  if cdr u then go to a$
  return mkquote
    if x then ('fplus . y . x)
      else y
end$

procedure cfplus2(u,v)$
% Adds the expressions of type (FPLUS ...).
% Destroys U, does not destroy V.
begin
  scalar f2v$
  f2v:=get('f2val,'free)$
  put('f2val,'free,'f2vunchange)$
  if not fixp u then u:=eval u$
  if not fixp v then v:=eval v$
  put('f2val,'free,f2v)$
  return
    if fixp u then
        if fixp v then (u + v)
          else ('fplus . (cadr v+u) . cddr v)
      else if numberp v then <>
      else <>
end$

procedure f2vunchange(us,ns)$
list('f2val,us,ns)$

procedure f2vzero(us,ns)$
0$

procedure f2vplus(us,ns)$
eval('plus . ns)$

procedure f2vmax(us,ns)$
eval('max . ns)$

procedure f2vmin(us,ns)$
eval('min . ns)$

put('f2val,'fselect,'f2vplus)$
put('f2val,'fgrid,'f2vmin)$

procedure iim21 u$
% Fills the array !*F2 according to the system of PDE and penalties
% given.
% Fills the properties NONE,NHALF (FONE,FHALF) of free variables.
% According to predefined variables filles the properties XGRID and EQ
% of predefined variables.
begin
  scalar b,e,lh,lhe,xx,rh,bdef$
  b:=car u$            % Free vars
  e:=cadr u$           % Predefined vars
  for i:=0:lun do
    for j:=0:lsun do   % Filling the array F2
      <>$
  nvar:=0$             % Number of actual variable
  lh:=lhs$
  rh:=rhs$
  interpolp:=nil$
  put('intt,'simpfn,'simpiden)$
a:lhe:=car lh$         % Actual equation
  lhe:=formlnr list('intt,lhe,coord)$
  rplaca(lh,lhe)$
  bdef:=t$
  for each var in sunvars do
    if get(var,coord) then t
      else bdef:=nil$
  if null b and bdef then go to c$
      % If there are no free variables it is not necessary to fill
      % the array F2 - no optimalization is necessary -> To use this
      % statement, we have to test if we know in which point (over
      % which interval) will all equation be integrated (discretized).
  put('intt,'simpfn,'simpintt)$
  alglist!*:=nil . nil$
  simp lhe$
  put('intt,'simpfn,'simpiden)$
  if !*fulleq then     % Optimalizatioon is performed for both sides of
      <>$
c:nvar:=nvar+1$
  lh:=cdr lh$
  if lh then go to a$
  for i:=0:lun do
    for j:=0:lsun do
      for k:=0:1 do
        setel(list('!*f2,i,j,k),f2var getel list('!*f2,i,j,k))$
  xxgrid:='xgrid$
  for each a in b do
    <>$
  for each a in e do    % Predefined variables
    filfree(a,car getel list(get(a,'grid),ncor),b,'xgrid,'eq)$
  % Predefined penalties
  intp:=0$
  for each a in e do
    if a memq unvars then
        <>$
  for each a in b do
    <>$
  return nil
end$

procedure iim22 u$
begin
  scalar b,e,bb,b1,b2,x,xx,x1,nv,g1,g2$
  b:=car u$
  e:=cadr u$
  bb:=b$             % Heuristic determination of grids for
                     % variables from B
f:x:=car bb$         % Chose the next variable X
  put('f2val,'free,get('f2val,'fselect))$
  xx:=abs(eval get(x,'none)-eval get(x,'nhalf))$
  b2:=cdr bb$
  while b2 do
    if xx<(x1:=abs(eval get(car b2,'none)-eval get(car b2,'nhalf)))
        then <>
      else b2:=cdr b2$
  b1:=x . b1$       %  List of variables subsequently choosen from B
  bb:=delete(x,bb)$ %  List of variables remaining in B
  put('f2val,'free,get('f2val,'fgrid))$
  put(x,'xgrid,'one)$
  g1:=eval get(x,'none)$
  put(x,'xgrid,'half)$
  g2:=eval get(x,'nhalf)$
  if g1>g2 then xx:='half
    else xx:='one$
  filfree(x,xx,bb,'xgrid,'eq)$
  intpgplus(x,xx)$
  for each ax in (x . get(x,'sames)) do
    if ax memq unvars then
    <>$
  if bb then go to f$
  return list(b,e,b1)
end$

procedure intpfplus(nx1,a,n)$
intp:=cfplus2(intp,getel list('!*f2,nx1,ngetvar(a,'nrvar),n))$

procedure intpgplus(a,ga)$
intp:=cfplus2(intp,get(a,ngrid ga))$

procedure iim3 u$
begin
  scalar b,e,b1,bb$
  prin2t" Backtracking needed in grid optimalization"$
  b:=car u$         % Free vars
  e:=cadr u$        % Predefined vars
  b1:=caddr u$
  for each a in b do        % Full search - bactracking
    <>$
  xxgrid:='bxgrid$
  nbxgrid(e,'bxgrid,'beq,'xgrid,'eq)$
  put('f2val,'free,'f2vunchange)$
  varyback(b1,nil)$
  for each a in union(unvars,given!*) do
    <>$
  return nil
end$

procedure nbxgrid(u,ng,ne,og,oe)$
for each a in u do
  for each b in (a . get(a,'sames)) do
    <>$

procedure varyback(bb,b1)$
% Performs full search of BB. B1 is B-BB. N is the number of
% interpolations performed up to now.
if null bb then
    begin
      scalar none,nhalf,n,eqg,i,j$
      n:=0$
      for each a in unvars do
        <>$
          put(a,'beq,if (eqg:=get(a,coord)) then eqg
                       else if none<=nhalf then 'one
                       else 'half)$
          n:=n + if eqg then
                     if eqg eq 'one then none
                       else if eqg eq 'half then nhalf
                       else <>
                   else if none<=nhalf then none
                   else nhalf >>$
      if n>
    end
  else if intp=0 then t
  else <>$

procedure varb(bb,b1,xx)$
% Subprocedure of VARYBACK procedure
% In BB are temporary free variables
% In B1 are temporary predefined variables (over BXGRID property)
begin
  scalar x$
  x:=car bb$
  for each a in (x . get(x,'sames)) do
    put(a,'bxgrid,xx)$
  return varyback(cdr bb,x . b1)
end$

procedure iim4$
begin
  scalar lh,rh,x,lhe,var$
  intp:=intp/6$
  prin2 intp$
  prin2 " interpolations are needed in "$
  prin2 coord$
  prin2t " coordinate"$
  for each a in unvars do
    <>$
  interpolp:=t$
  put('intt,'simpfn,'simpinterpol)$
  lh:=lhs$
  rh:=rhs$
  x:=unvars$
j:var:=car x$
  gvar:=get(var,'eq)$
  lhe:=car lh$
  alglist!*:=nil . nil$
  lhe:=prepsq simp lhe$
  rplaca(lh,lhe)$
  lhe:=car rh$
  lhe:=formlnr list('intt,lhe,coord)$
  lhe:=prepsq simp lhe$
  rplaca(rh,lhe)$
  x:=cdr x$
  lh:=cdr lh$
  rh:=cdr rh$
  if x then go to j$
  put('intt,'simpfn,'simpiden)$
  return lhs
end$

procedure iim5$
begin
  scalar lh,rh,val,nreq,ar$
  val:=!*val$
  !*val:=nil$
  for each a in union(union(unvars,sunvars),given!*) do
    <>$
  remflag(given!*,'twogrid)$
  remflag(given!*,'noeq)$
  terpri()$
  prin2t "         Equations after Discretization Using IIM :"$
  prin2t "         =========================================="$
  terpri()$
  lh:=lhs$
  rh:=rhs$
  nreq:=0$
k:rplaca(lh,prepsq!* simp!* car lh)$
  maprin car lh$
  prin2!* "   =   "$
  rplaca(rh,prepsq!* simp!* car rh)$
  maprin car rh$
  terpri!* t$
  terpri()$
  ar:=if null cdr lhs then list(resar,0) else list(resar,nreq,0)$
  setel(ar,car lh)$
  ar:=if null cdr lhs then list(resar,1) else list(resar,nreq,1)$
  setel(ar,car rh)$
  lh:=cdr lh$
  rh:=cdr rh$
  nreq:=nreq+1$
  if lh then go to k$
  !*val:=val$
  return nil
end$

put('iim,'stat,'rlis)$

array difm!*(10)$

procedure iscomposedof(x,objs,ops)$
if null x then nil
  else if atom x then if idp x then memq(x,objs)
                        else if fixp x then t
                        else nil
  else if idp car x and car x memq ops and cdr x then
            iscompos(cdr x,objs,ops)
  else nil$

procedure iscompos(x,objs,ops)$
if null x then t
  else if idp car x then car x memq objs and iscompos(cdr x,objs,
                                                       ops)
  else if numberp car x then iscompos(cdr x,objs,ops)
  else if atom car x then nil
  else if idp caar x then caar x memq ops and cdar x and
                iscompos(cdar x,objs,ops) and iscompos(cdr x,objs,ops)
  else nil$

global'(difconst!* diffuncs!*)$
difconst!* := '(i n di dim1 dip1 dim2 dip2)$
diffuncs!*:=nil$

procedure difconst u$
difconst!* := append(u,difconst!*)$

put('difconst,'stat,'rlis)$

procedure diffunc u$
<>$

put('diffunc,'stat,'rlis)$

procedure matchdfunc(u,v)$
begin
  scalar x,y$
  return
    if null u and null v then list t
      else if null u or null v then nil
      else if (x:=matcheq(car u,car v)) and (y:=matchdfunc(cdr u,cdr v))
        then union(x,y)
      else nil
end$

procedure difmatch u$
begin
  scalar l,gds,gdsf,pl,x,dx,y,z,coor$
  coor:=car u$
  if not atom coor then go to er$
  u:=cdr u$
  x:=car u$
  if not iscomposedof(x,'(u f x n v w g),
       append(diffuncs!*,'(diff times expt quotient recip)))then
      go to er$
  x:=prepsq simp x$
  l:=if atom x then 0 else length x$
  x:=x . nil$
  if null(y:=getel list('difm!*,l)) then setel(list('difm!*,l),list x)
    else if (z:=assoc(car x,y)) then x:=z
    else nconc(y,list x)$
  y:=cdr u$
a:gds:=nil$
  gdsf:=nil$
  if not eqexpr car y then go to b$
a1:if not(cadar y memq '(u v w f g) and caddar y memq grids!*) then
                                                        go to er$
  if cadar y memq '(f g) then gdsf:=(cadar y . caddar y) . gdsf
    else gds:=(cadar y . caddar y) . gds$
  y:=cdr y$
  if null y then go to er$
  if eqexpr car y then go to a1$
b:if not fixp car y then go to er$
  pl:=car y$
  y:=cdr y$
  if null y then go to er$
  if not iscomposedof(car y,difconst!*,append(diffuncs!*,'(u x f v w
     g plus minus difference times quotient recip expt)))then go to er$
  dx:=car y$
  y:=cdr y$
  gds:=nconc(gdsf,gds)$
  defdfmatch(x,gds,pl,list dx,coor)$
  if y then go to a$
  return nil$
er:errpri2(y,'hold)
end$

procedure defdfmatch(x,gds,pl,dx,coor)$
begin
  scalar y,z,yy$
  y:=get('difm!*,'grids)$
  if null y then put('difm!*,'grids,list gds)
    else if null gds then t
    else if (z:=acmemb(gds,y)) then gds:=z
    else nconc(y,list gds)$
  y:=cdr x$
  if y then
      if (yy:=atsoc(coor,y)) then
          if (z:=assoc(gds,cdr yy)) then
              <>
            else nconc(cdr yy,list(gds . (pl . dx)))
        else nconc(y,list(coor . list(gds . (pl . dx))))
    else rplacd(x,list(coor . list(gds . (pl . dx))))$
  return y
end$

deflist('((difmatch rlis) (cleardifmatch endstat)),'stat)$

procedure cleardifmatch$
for i:=0:10 do difm!*(i):=nil$

flag('(cleardifmatch),'eval)$

procedure acmemb(u,v)$
if null v then nil
  else if aceq(u,car v) then car v
  else acmemb(u,cdr v)$

procedure aceq(u,v)$
if null u then null v
  else if null v then nil
  else if car u member v then aceq(cdr u,delete(car u,v))
  else nil$

procedure matcheq(u,v)$
if null u or null v then nil
  else if numberp u then if u=v then list t else nil
  else if atom u then
    begin
      scalar x$
      x:=eval list(get(u,'matcheq),mkquote u,mkquote
                       (if atom v then list v else v))$
      return
        if x then x
          else if null !*exp and pairp v and car v memq
                  '(plus difference) then matchlinear(u,v)
          else nil
    end
  else if atom v then nil
  else if atom car u and car u eq car v then
      eval list(get(car u,'matcheq),mkquote cdr u,mkquote cdr v)
  else if null !*exp and car v memq'(plus difference)
       and car u eq 'diff then
      matchlinear(u,v)
  else nil$

algebraic operator matchplus$

fluid'(uu vv)$

procedure matchlinear(u,v)$
% Construction for OFF EXP and second and next coordinates
begin
  scalar x,uu,vv,alg$
  if not atom u then return
      if car u eq 'diff then matchlindf(u,v)
        else if car u eq 'times then matchlintimes(u,v)
        else nil$
  uu:=u$
  vv:='first$
  x:=formlnr list('matchplus,v,coord)$
  put('matchplus,'simpfn,'matchp)$
  alg:=alglist!*$
  alglist!*:=nil . nil$
  simp x$
  alglist!*:=alg$
  put('matchplus,'simpfn,'simpiden)$
  return
    if vv then list(u .  (if interpolp then v else vv))
      else nil
end$

procedure matchp y$
begin
  scalar x$
  if null vv then return(nil . 1)$
  x:=matcheq(uu,car y)$
  if null x then return
      begin
        vv:=nil$
        return(nil . 1)
      end$
  if vv eq 'first then return
      begin
        vv:=cdar x$
        return (nil . 1)
      end$
  if mainvareq(vv,cdar x) then return (nil . 1)$
  vv:=nil$
  return(nil . 1)
end$

unfluid '(uu vv)$

procedure mainvareq(x,y)$
if atom x then eq(x,y)
  else if car x memq iobjs!* then eq(car x,car y)
  else if car x memq '(diff expt) then
    (car y eq car x and mainvareq(cadr x,cadr y) and cddr x=cddr y)
  else nil$

procedure tlist x$
if atom x then list x
  else x$

procedure matchlindf(u,v)$
begin
  scalar x,y,b$
  x:=for each a in cdr v collect fsamedf a$
  y:=cdar x$
  if null y then return nil$
  x:=for each a in x collect if y=cdr a then car a
                               else b:=t$
  if b then return nil$
  x:=(car v . x) . y$
  return matchdf(cdr u,x)
end$

procedure fsamedf u$
begin
  scalar x$
  return
    if atom u then nil . nil
      else if car u eq 'minus then
        <>
      else if car u eq 'diff then cadr u . cddr u
      else if car u eq 'times then
        begin
          scalar y,z$
          x:=cdr u$
        a:if null x or y=t then go to b$
          if numberp car x then z:=car x . z
            else if eqcar(car x,'diff) then
              <>
            else if depends(car x,coord) then y:=t
            else z:=car x . z$
          x:=cdr x$
          go to a$
        b:return if y=t then nil . nil
                   else ('times . z) . y
        end
    else nil . nil
end$

procedure matchlintimes(u,v)$
begin
  scalar x,y,z$
  y:=cadr v$
  if eqcar(y,'times) then y:=cdr y
    else if eqcar(y,'minus) and eqcar(cadr y,'times)
     then y:=  (-1) . cdadr y
    else return nil$
  x:=for each a in cdr v collect
       if eqcar(a,'times) then <>
         else if eqcar(a,'minus) and eqcar(cadr a,'times) then
           <>
         else y:=nil$
  if null y then return nil$
  x:=for each a in x collect <>$
  x:=car v . x$
  return matchtimes(cdr u,x . y)
end$

procedure intersect(u,v)$
if null u or null v then nil
  else if member(car u,v) then car u . intersect(cdr u,v)
  else intersect(cdr u,v)$

procedure matchu(u,v)$
if car v memq unvars or (!*eqfu and car v memq given!*) then list(u . v)
  else if car v eq 'diff and not(coord memq cddr v)
                and matcheq(u,tlist cadr v)
           then list(u . (car v . (tlist cadr v . cddr v)))
  else if car v eq 'times then
% Product can be inside brackets or in DIFF
    begin
      scalar x,b1,vv$
      x:=for each a in cdr v collect a$   % To allow RPLACA
      vv:=car v . x$
      b1:=0$
      while x and b1<2 do
        <>$
          x:=cdr x >>$
      return if b1=0 or b1>1 then nil
               else (u . vv)
    end
  else nil$

put('u,'matcheq,'matchu)$
put('v,'matcheq,'matchu)$
put('w,'matcheq,'matchu)$

procedure matchf(u,v)$
if car v memq given!* then list(u . v)
  else if car v eq 'diff and not(coord memq cddr v)
                and matchf(u,tlist cadr v)
           then list(u . (car v . (tlist cadr v . cddr v)))
  else nil$

put('f,'matcheq,'matchf)$
put('g,'matcheq,'matchf)$

procedure matchx(u,v)$
if car v eq coord then list t
  else nil$

put('x,'matcheq,'matchx)$

procedure matchtimes(u,v)$
begin
  scalar bool,bo,x,y,y1,asl$
  x:=u$
a:y:=t . v$
d:bool:=nil$
  while not bool and cdr y do
    <>$
  if null bool then go to b$
  bo:=bool$
c: if not atom bo and not atom car bo then y1:=atsoc(caar bo,asl)
    else y1 := nil$
  if y1 and not(y1=car bo) then go to d$
  bo:=cdr bo$
  if bo then go to c$
  v:=delete(car y,v)$
  x:=cdr x$
  asl:=union(bool,asl)$
  if x then go to a$
  if v then return nil$
  return asl$
b:return if null cdr v and cdr x then
             if y:=matcheq('times . x,car v) then union(asl,y)
               else nil
           else nil
end$

put('times,'matcheq,'matchtimes)$

procedure matchexpt(u,v)$
if fixp cadr u then
    if cadr u=cadr v then matcheq(car u,car v)
      else nil
  else if cadr u='n then
      begin
        scalar x$
        x:=matcheq(car u,car v)$
        return if x then (('n . cadr v) . x)
                 else nil
      end
  else nil$

put('expt,'matcheq,'matchexpt)$

procedure matchquot(u,v)$
begin
  scalar man,mad$
  return if(man:=matcheq(car u,car v))
              and (mad:=matcheq(cadr u,cadr v)) then
             union(man,mad)
           else nil
end$

put('quotient,'matcheq,'matchquot)$

procedure matchrecip(u,v)$
matcheq(car u,car v)$

put('recip,'matcheq,'matchrecip)$

procedure matchdf(u,v)$
begin
  scalar x,asl,y$
  asl:=matcheq(car u,car v)$
  if null asl then return nil$
  y:=x:=append(cdr v,nil)$
  while x and car x neq coord do x:=cdr x$
  if null x then return nil
    else if null cddr u then
             if null cdr x or idp cadr x then go to df1
                 else return nil
      else if cdr x and caddr u=cadr x then t
      else return nil$
  rplacd(x,cddr x)$
df1:y:=delete(coord,y)$
  if null y or null interpolp then return asl
%  !!! Be aware !!! in mixed derivations of product
    else return list(car u . ('diff . (cdar asl . y)))
end$

put('diff,'matcheq,'matchdf)$

procedure finddifm u$
begin
  scalar x,v,asl,eqfu,b,bfntwo,bftwo1$
  eqfu:=!*eqfu$
  if eqfu then !*eqfu:=nil$
a:x:=t . difml!*$
  bftwo1:=bfntwo$
  bfntwo:=nil$
  if !*eqfu then b:=t$
  while cdr x and not asl do
    <>$
  !*eqfu:=eqfu$
  if null asl then
      if null b and eqfu then go to a
    else go to nm$
  return list(('x . coord) . delete(t,asl),cdar x)$
nm:if eqcar(u,'times) and null !*exp then
       <>$
  msgpri(" Matching of ",u," term not find ",nil,'hold)$
  if bfntwo or bftwo1 then
       lprie(" Variable of type F not defined on grids in DIFMATCH")$
  return nil
end$

procedure tdifpair x$
% From CDR ATSOC(.,ASL) makes an atom - free variable
<>   % patch
        else x:=cadr x$
  if pairp x then x:=car x$
  x >>$

procedure simpintt u$
begin
  scalar asl,agdsl,l,x,nv,y,x1,y1,nv1,n1,n2,nn1,nn2,
         x2,y2,nv2,n3,n4,n5,n6,lgrids,gds$
  u:=prepsq simp car u$
  if u=1
        then go to r$
  asl:=finddifm u$
  if null asl or eqcar(asl,'special) then go to r$
  agdsl:=cadr asl$              % List from DIFML!*
  asl:=car asl$                 % ASOC. list of assignments
  gds:=caar agdsl$
  l:=length gds$
  if l=0 then go to r$
a:y:=caar gds$
  x:=atsoc(y,asl)$
  if null x then go to er1$
  x:=tdifpair cdr x$
  if !*twogrid and flagp(x,'twogrid) then
      if l=1 then go to r
        else <>$
  nv:=ngetvar(x,'nrvar)$
  if l=1 then go to l1
    else go to l2$
l1:x:=assoc(list(y . 'one),agdsl)$
  if null x then go to er2$
  f2plus(nvar,nv,0,6*cadr x)$
  x:=assoc(list(y . 'half),agdsl)$
  if null x then go to er2$
  f2plus(nvar,nv,1,6*cadr x)$
  go to r$
l2:y1:=caadr gds$
  x1:=atsoc(y1,asl)$
  if null x1 then go to er1$
  x1:=tdifpair cdr x1$
  if !*twogrid and flagp(x1,'twogrid) then
      if l=2 then go to l1
        else <>$
  nv1:=ngetvar(x1,'nrvar)$
  lgrids:=get('difm!*,'grids)$
  if l=3 then go to l3
    else if l>3  then go to er$
l20:n1:=atsoc(acmemb(list(y . 'one,y1 . 'one),lgrids),agdsl)$
  n2:=atsoc(acmemb(list(y . 'one,y1 . 'half),lgrids),agdsl)$
  nn1:=atsoc(acmemb(list(y . 'half,y1 . 'half),lgrids),agdsl)$
  nn2:=atsoc(acmemb(list(y . 'half,y1 . 'one),lgrids),agdsl)$
  if n1 and n2 and nn1 and nn2 then t
    else go to er2$
  n1:=cadr n1$
  n2:=cadr n2$
  nn1:=cadr nn1$
  nn2:=cadr nn2$
l21:add2sint(nv,nv1,x,x1,n1,n2,nn1,nn2)$
  go to r$
l3:y2:=caaddr gds$
  x2:=atsoc(y2,asl)$
  if null x2 then go to er1$
  x2:=tdifpair cdr x2$
  if !*twogrid and flagp(x2,'twogrid) then go to l20$
  nv2:=ngetvar(x2,'nrvar)$
  n1:=atsoc(acmemb(list(y . 'one,y1 . 'one,y2 . 'one),lgrids),agdsl)$
  n2:=atsoc(acmemb(list(y . 'half,y1 . 'half,y2 . 'half),lgrids),agdsl)$
  nn1:=atsoc(acmemb(list(y . 'one,y1 . 'one,y2 . 'half),lgrids),agdsl)$
  nn2:=atsoc(acmemb(list(y . 'half,y1 . 'half,y2 . 'one),lgrids),agdsl)$
  n3:=atsoc(acmemb(list(y . 'one,y1 . 'half,y2 . 'one),lgrids),agdsl)$
  n4:=atsoc(acmemb(list(y . 'half,y1 . 'one,y2 . 'half),lgrids),agdsl)$
  n5:=atsoc(acmemb(list(y . 'one,y1 . 'half,y2 . 'half),lgrids),agdsl)$
  n6:=atsoc(acmemb(list(y . 'half,y1 . 'one,y2 . 'one),lgrids),agdsl)$
  if n1 and n2 and nn1 and nn2 and n3 and n4 and n5 and n6 then t
    else go to er2$
  n1:=cadr n1$
  n2:= cadr n2$
  nn1:=cadr nn1$
  nn2:=cadr nn2$
  n3:=cadr n3$
  n4:=cadr n4$
  n5:=cadr n5$
  n6:=cadr n6$
  if n1=nn1 and n2=nn2 and n3=n5 and n4=n6 then
      <>
    else if n1=n3 and n2=n4 and nn1=n5 and nn2=n6 then
      <>
    else if n1=n6 and n2=n5 and nn1=n4 and nn2=n3 then
      <>$
  add3sint(nv,nv1,nv2,x,x1,x2,n1,n2,n3,n4,n5,n6,nn1,nn2)$
r:return (nil . 1)$
er:msgpri(nil,l," Free vars not yet implemented ",nil,'hold)$
  go to r$
er1:msgpri(" Failed matching of variables in  ",
        u,list(asl,agdsl),nil,'hold)$
  go to r$
er2:msgpri(" All grids not given for term  ",u,list(asl,agdsl),
                   nil,'hold)$
  go to r
end$

procedure add2sint(nv,nv1,x,x1,n1,n2,nn1,nn2)$
begin
% Enhansment for symmetries, when only one variable influence
  if n1=n2 and nn1=nn2 then
      <>
    else if n1=nn2 and n2=nn1 then
      <>$
  n1:=3*n1$
  n2:=3*n2$
  nn1:=3*nn1$
  nn2:=3*nn2$
  x:=list(x,x1)$
  f2plus(nvar,nv,0,list(x,n1,n2))$
  f2plus(nvar,nv,1,list(x,nn1,nn2))$
  x:=reverse x$
  f2plus(nvar,nv1,0,list(x,n1,nn2))$
  f2plus(nvar,nv1,1,list(x,nn1,n2))$
  return
end$

procedure add3sint(nv,nv1,nv2,x,x1,x2,n1,n2,n3,n4,n5,n6,nn1,nn2)$
begin
  n1:=2*n1$
  n2:=2*n2$
  nn1:=2*nn1$
  nn2:=2*nn2$
  n3:=2*n3$
  n4:=2*n4$
  n5:=2*n5$
  n6:=2*n6$
  x:=list(x,x1,x2)$
  f2plus(nvar,nv,0,list(x,n1,nn1,n3,n5))$
  f2plus(nvar,nv,1,list(x,n2,nn2,n4,n6))$
  f2plus(nvar,nv1,0,list(x,n1,nn1,n4,n6))$
  f2plus(nvar,nv1,1,list(x,n2,nn2,n3,n5))$
  f2plus(nvar,nv2,0,list(x,n1,nn2,n3,n6))$
  f2plus(nvar,nv2,1,list(x,n2,nn1,n4,n5))$
  return
end$

procedure simpinterpol u$
begin
  scalar asl,agdsl,gds,x,y,xx,a$
  u:=prepsq simp car u$
  if eqcar(u,'diff) and not(coord memq cddr u) then
%  !!!! Be aware  !!!! could not work for mixed derivatives
      return <>$
  asl:=finddifm u$
  if null asl then return (nil . 1)
    else if eqcar(asl,'special) then return cdr asl$
  agdsl:=cadr asl$   %  Actual list from DIFML!*, contains definition
                     %  of grid, penalty and diff. scheme
  asl:=car asl$      %  Assoc. list of assignments of variables X,U,V,W
                     %  to actual variables
  if not(gvar memq grids!*) then go to erg$
  asl:=append(asl,get('steps,gvar))$   % Adding DIM1, DIP1 ... to assoc.
                                       % list
  if null caar agdsl then return simp sublap(asl,caddar agdsl)$  % For
  a:=caar agdsl$                       % DIFMATCH without def. grids
b:if null a then go to c$
  y:=caar a$
  x:=atsoc(y,asl)$
  if null x then go to er1$            % GDS is assoc. list of actual
  xx:=cdr x$                           % assignments of grids to
  x:=getgrid xx$                       % variables U, V
  if gvar eq 'half then x:=gnot x$
  if !*twogrid and twogridp xx then t
    else gds:=(y . x) . gds$
  a:=cdr a$
  go to b$
c:if null gds then go to a$      % For given functions which can be on
  y:=get('difm!*,'grids)$        % both grids
  x:=acmemb(gds,y)$              % Unique GDS
  if null x then go to er1$
  gds:=x$
a:x:=assoc(gds,agdsl)$
  if null x then go to erg$
  x:=caddr x$                    % Actual difference scheme
  return simp sublap(asl,x)$
er1:msgpri(" Failed matching of ",u,list(asl,agdsl,gds),nil,
                  'hold)$
  return (nil . 1)$
erg:msgpri(" Bad grids ",u,list(asl,agdsl,gds),nil,'hold)$
  return (nil . 1)
end$

procedure twogridp u$
% Checks if prefix form U can be on both grids
begin
  scalar x$
  return
    if atom u then
        if flagp(u,'twogrid) then
            if !*twogrid and u memq given!* and
               getel list(get(u,'grid),ncor) then nil
              else t
          else nil
      else if flagp(car u,'twogrid) then
        if !*twogrid and car u memq given!* and
           getel list(get(car u,'grid),ncor) then nil
          else t
      else if car u memq '(diff plus difference) then twogridp cadr u
      else if car u eq 'times then twogridpti cdr u
      else nil
end$

procedure twogridpti u$
begin
  scalar x$
a:x:=twogridp car u$
  if x then return x$
  u:=cdr u$
  if u then go to a$
  return nil
end$


procedure getgrid u$
begin
  scalar x$
  return
    if atom u then
        if x:=get(u,'xgrid) then x
          else if !*twogrid and u memq given!* and
                  (x:=getel list(get(u,'grid),ncor)) then car x
          else nil
      else if (x:=get(car u,'xgrid)) then x
      else if !*twogrid and car u memq given!* and
               (x:=getel list(get(car u,'grid),ncor)) then car x
      else if car u eq 'diff then
               if atom cadr u then getgrid cadr u
                %else if caadr u eq 'times then           % probably can
                %         if (x:=getgrid cadadr u) then x % be deleted
                %           else getgrid caddr cadr u     % !!!!!"!!!
                 else getgrid cadr u
      else if car u memq '(plus difference) then getgrid cadr u
      else if car u eq 'times then getgti cdr u
      else nil
end$

procedure getgti u$
begin
  scalar x$
a:x:=getgrid car u$
  if x then return x$
  u:=cdr u$
  if u then go to a$
  return nil
end$

procedure sublap(u,v)$
% U is assoc. list, V is pattern diff. scheme
% Performs substitution of assod. list into the diff. scheme
begin
  scalar x$
  return
    if null u or null v then v
      else if atom v then
        if numberp v then v
          else if x:=atsoc(v,u) then cdr x
          else v
      else if flagp(car v,'app) then sublap1(u,v)
      else (sublap(u,car v) . sublap(u,cdr v))
end$

flag('(u f v w x g),'app)$

procedure sublap1(u,v)$
begin
  scalar x,y$
  x:=atsoc(car v,u)$
  if null x then return msgpri(" Substitution for ",v," not find",
                               nil,'hold)$
  x:=cdr x$
  y:=for each a in cdr v collect irev sublap(u,a)$
  return
    if eqcar(x,'diff) then ('diff . (subappend(cadr x,y) . cddr x))
      else subappend(x,y)
end$

procedure subappend(x,y)$
if atom x then if x memq iobjs!* and depends(x,coord) then (x . y)
                 else x
  else if car x memq iobjs!* and depends(car x,coord) then append(x,y)
         else (car x . for each a in cdr x collect subappend(a,y) )$

procedure irev u$
begin
  u:=simp u$
  return
    if cdaaar u=1 and cdaar u=cdr u and fixp cdar u then
        if cdr u=1 then
            if cdar u<0 then list('difference,
                                   caaaar u,
                                   -cdar u)
               else list('plus,
                         caaaar u,
                         cdar u)
           else if cdar u<0 then list('difference,
                                      caaaar u,
                                      list('quotient,
                                           -cdar u,
                                           cdr u))
                  else list('plus,
                            caaaar u,
                            list('quotient,
                                 cdar u,
                                 cdr u))
      else prepsq u
end$

unfluid '(coord unvars sunvars interpolp novars ncor nvar intp icor gvar
        hi hip1 hip2 him1 him2 lhs rhs lsun lun xxgrid resar)$


procedure gentempst$
list('gentemp,xread t)$

put('gentemp,'stat,'gentempst)$
put('gentemp,'formfn,'formgentran)$

put('outtemp,'stat,'endstat)$
flag('(outtemp),'eval)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/hurwp.red0000644000175000017500000002516311526203062023263 0ustar  giovannigiovannimodule hurwp;

% Author: R. Liska.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version REDUCE 3.6     05/1991

global '(ofl!* mlist!*)$
fluid '(!*exp !*gcd)$

flag('(tcon),'matflg)$
put('tcon,'msimpfn,'tcon)$
put('tcon,'rtypefn,'getrtypecar)$

procedure tcon u$
% Calculates complex conjugate and transpose matrix
begin
  scalar v,b$
  v:=matsm list('tp,u)$
  for each a in v do
    <> >>$
  return v
end$

algebraic$
korder lam$

symbolic$

global '(positive!* userpos!* userneg!* !*pfactor)$
!*pfactor:=nil$

procedure positivep u$
% U is prefix form. Procedure tests if U>0, eventually writes this
% condition and puts U into POSITIVE!*. If U<=0 then returns NIL,
% if U>0 then T, in other cases 'COND.
% If it does not know if U>0 and program is running in interactive
% mode it asks user if U>0 and return value is based on user reply.
if numberp u then
    if u>0 then t
      else nil
  else if eqcar(u,'!*sq) and fixp caadr u and fixp cdadr u then
           if caadr u*cdadr u>0 then t
             else nil
  else
    begin
      scalar x,exp$
      exp:=!*exp$
      if !*pfactor and
             member('factor,mlist!*) then
           <>$
      u:=prepsq!* simp u$
      !*exp:=exp$
      x:=if terminalp() and null ofl!* then
             begin
               scalar y,z$
               prin2!* "Is it true, that  "$
               maprin u$
               prin2!* "  >  0    ?"$
             a:prin2!* "  Reply (Y/N/?)"$
               terpri!* t$
               y:=read()$
               if y eq 'y then <>
                 else if y eq 'n
                  then <>
                 else if y eq '? then z:='cond
                 else go to a$
               return z
             end
           else 'cond$
      if x eq 'cond then
          if null positive!* then positive!*:= list (1 . u)
            else positive!* := ((caar positive!* + 1) . u) . positive!*$
      return x
    end$

global'(hconds!*)$

algebraic$
array cof(20),fcof(20)$
share hconds!*$

procedure ppfactor x$
begin
  scalar d,n,de$
  d:= old_factorize(num x)$
  n:=for each a in d product a$
  if den x=1 then return n$
  d:= old_factorize(den x)$
  de:=for each a in d product a$
  return (n/de)
end$

procedure hurwitzp u$
% U is a polynomial in LAM. Procedure tests if it is Hurwitz polynomial
% i.e. for all its rools LAMI holds RE(LAMI)<0.
% Returned values: YES  - definitely yes
%                  NO   - definitely no
%                  COND - if conditions holds (all members of POSITIVE!*
%                         are >0)
if im u=0 then rehurwp u
  else cohurwp u$

symbolic$

procedure coef1(u,v,a)$
begin
  scalar lco,l$
  lco:=aeval list('coeff,u,v)$
  lco:=cdr lco$
  l:=length lco - 1$
  for i:=0:l do
    <>$
  return l
end$

procedure rehurwp u$
begin
  scalar deg,hurp,gcd$
  gcd:=!*gcd$
  !*gcd:=t$
  deg:=coef1(car u,'lam,'cof)$
  if deg=0 then return typerr(u,"Polynomial in LAM")$
  positive!* := userpos!* := userneg!* := nil$
  if deg <= 2 then
      <>
    else hurp:=rehurwp1 deg$
  !*gcd:=gcd$
  return rethurp hurp
end$

procedure rethurp hurp$
<>$

put('rehurwp,'simpfn,'rehurwp)$

procedure cohurwp u$
begin
  scalar deg$
  u:=reval list('sub,'(equal lam (times i lam)),car u)$
  deg:=coef1(u,'lam,'cof)$
  if deg=0 then return typerr(u,"Polynomial in LAM")$
  positive!* := userpos!* := userneg!* :=nil$
  if aeval list('im,getel list('cof,deg))=0 then
        for j:= 0:deg do setel(list('cof,j),
                              aeval list('times,'i,getel list('cof,j)))$
  return rethurp cohurwp1 (deg)
end$

put('cohurwp,'simpfn,'cohurwp)$

procedure rehurwp1 deg$
begin
  scalar i,bai,bdi,x,lich,sud,bsud,matr,hmat,csud,clich,dsud,dlich$
a:i:=deg$
  csud:=clich:=nil$
  bsud:=t$
b:x:=positivep getel list('cof,i)$
  if null x then go to c
    else if x eq t then bai:=t
    else if x eq 'cond then
      if i=deg or i=0 then <>
        else if bsud then csud:=caar positive!* . csud
        else clich:=caar positive!* . clich$
  i:=i-1$
  bsud:=not bsud$
  if i>=0 then go to b$
  go to d$
  % Change of sign AI = - AI
c:if bai or bdi then go to n
    else bai:=t$
  for i:=0:deg do setel(list('cof,i),
                        aeval list('minus,getel list('cof,i)))$
  go to a$
  % Checking DI > 0 - Hurwitz determinants
  % Splitting to odd and even coeffs. AI, A0 is coeff. by LAM**DEG
d:bsud:=t$
  for i:=deg step -1 until 0 do
    <>$
  sud:=reverse sud$
  lich:=reverse lich$
  % Filling of SUD and LICH on the length DEG by zeroes from right
  sud:=filzero(sud,deg)$
  lich:=filzero(lich,deg)$
  dsud:=dlich:=nil$
  matr:=nil$
  i:=1$
  bsud:=nil$
d1:matr:=nconc(matr,list lich)$
  lich:=(nil . 1) . lich$
d2:hmat:=cutmat(matr,i)$
  x:=mk!*sq detq hmat$
  x:=positivep x$  % Necessary to add storing of odd and even DIs
  if null x then
      if bsud then go to n
        else go to c
    else if x eq t and not bsud then bdi:=t
    else if x eq 'cond then
      if bsud then dsud:=caar positive!* . dsud
        else dlich:=caar positive!* . dlich$
  i:=i+1$
  bsud:=not bsud$
  if i>deg then go to k$
  if not bsud then go to d1$
  matr:=nconc(matr,list sud)$
  sud:=(nil . 1) . sud$
  go to d2$
n:return nil$
k:if null positive!* or ((null csud or null clich) and
                         (null dsud or null dlich))
      then return <>$
  prin2t "If we denote:"$
  printcond(t)$
  printdef('c1,clich:=reverse clich)$
  printdef('c2,csud:=reverse csud)$
  printdef('d1,dlich:=reverse dlich)$
  printdef('d2,dsud:=reverse dsud)$
  prin2t "Necessary and sufficient conditions are:"$
  prin2t if null csud or null clich then         "  (D1)  OR  (D2)"
           else if null dsud or null dlich then  "  (C1)  OR  (C2)"
           else "  (  (C1)  OR  (C2)  )  AND  (  (D1)  OR  (D2)  )"$
  printuser()$
  return 'cond
end$

procedure printcond(x)$
<>$
      maprin cdr a$
      prin2!* "  >  0"$
      terpri!* t >>$
  if not x then printuser() >>$

procedure printuser()$
if userpos!* or userneg!* then
    <  0"$
                                   terpri!* t >>$
      for each a in userneg!* do <> >>$

procedure printdef(x,y)$
if y then
    <>$
      terpri!* t >>$

procedure filzero(x,n)$
% Adds zeros (in S.Q. form) to the list X from right on the length N
begin
  scalar y,i$
  y:=x$
  i:=1$
  if null x then return typerr(x,"Empty list")$
  while cdr y do
    <>$
  while i>$
  return x
end$

procedure cutmat(x,n)$
% From each member of list X, i.e. row of a matrix, remains
% the first N elements
for each a in x collect cutrow(a,n)$

procedure cutrow(y,n)$
begin
  scalar i,z,zz$
  i:=1$
  z:=list car y$
  zz:=z$
  y:=cdr y$
  while i>$
  return z
end$

procedure cohurwp1 (deg)$
begin
  scalar k,x,y,ak,bk,akk,bkk,matr,hmat$
  % Splitting on RE and IM part
  for j:=0:deg do
    <>$
  % Construction of coeffs. AI, BI
  positive!*:=userpos!*:=userneg!*:=nil$
  akk:=filzero(ak,2*deg)$
  bkk:=filzero(bk,2*deg)$
  k:=2$
d1:matr:=nconc(matr,list akk)$
  matr:=nconc(matr,list bkk)$
  akk:=(nil . 1) . akk$
  bkk:=(nil . 1) . bkk$
  hmat:=cutmat(matr,k)$
  x:=mk!*sq detq hmat$
  x:=positivep x$
  if null x then go to n$
  if k=2*deg then go to ko$
  k:=k+2$
  go to d1$
n:return nil$
ko:printcond(nil)$
  return t
end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/approx.red0000644000175000017500000001403311526203062023421 0ustar  giovannigiovannimodule approx;

% Author: R. Liska$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version REDUCE 3.6     05/1991$

fluid '(!*prapprox)$

switch prapprox$
!*prapprox:=nil$

global '(cursym!* coords!* icoords!* functions!* hipow!* lowpow!*)$
%  Implicitely given indices
icoords!*:='(i j k l m n i1 j1 k1 l1 m1 n1)$

algebraic$

procedure fact(n)$
if n=0 then 1
  else n*fact(n-1)$

procedure taylor(fce,var,step,ord)$
if step=0 or ord=0 then fce
  else fce+for j:=1:ord sum step**j/fact(j)*df(fce,var,j)$

symbolic$

procedure maxorder u$
begin
  scalar movar,var$
a:movar:=car u$
  if not eqexpr movar then return errpri2(movar,'hold)$
  movar:=cdr movar$
  var:=car movar$
  movar:=reval cadr movar$
  if not atom var or not(var memq coords!*) then return msgpri(
        " Parameter ",var," must be coordinate",nil,'hold)
    else if not fixp movar then return msgpri(
        " Parameter ", movar," must be integer",nil,'hold)
    else put(var,'maxorder,movar)$
  u:=cdr u$
  if u then go to a$
  return nil
end$

put('maxorder,'stat,'rlis)$

procedure center u$
begin
  scalar movar,var$
a:movar:=car u$
  if not eqexpr movar then return errpri2(movar,'hold)$
  movar:=cdr movar$
  var:=car movar$
  movar:=reval cadr movar$
  if not atom var or not(var memq coords!*) then return msgpri(
        " Parameter ",var," must be coordinate",nil,'hold)
    else if not(fixp movar or (eqcar(movar,'quotient) and
           (fixp cadr movar or
            (eqcar(cadr movar,'minus) and fixp cadadr movar))
                        and fixp caddr movar)) then return msgpri(
        " Parameter ", movar," must be integer or rational number",nil,
        'hold)
    else put(var,'center,movar)$
  u:=cdr u$
  if u then go to a$
  return nil
end$

put('center,'stat,'rlis)$

procedure functions u$
<>$

put('functions,'stat,'rlis)$

procedure simptaylor u$
begin
  scalar ind,var,movar,step,fce,ifce$
  fce:=car u$
  if null cdr u then return simp fce$
  ifce:=cadr u$
  if cddr u then fce:= fce . cddr u$
  ind:=mvar numr simp ifce$
  var:=tcar get(ind,'coord)$
  step:=reval list('difference,
                   ifce,
                   list('plus,
                        if (movar:=get(var,'center)) then movar
                          else 0,
                        ind))$
  step:=list('times,
             step,
             get(var,'gridstep))$
  movar:=if (movar:=get(var,'maxorder)) then movar
           else 3$
  return simp list('taylor,
                   fce,
                   var,
                   step,
                   movar)
end$

algebraic$

procedure approx difsch$
begin
  scalar ldifsch,rdifsch,nrcoor,coors,rest,ldifeq,rdifeq,alglist!*$
  symbolic
    <>$
      flag(functions!*,'full)$
      for each a in coords!* do put(a,'gridstep, intern compress append
                           (explode 'h,explode a))$
      nrcoor:=length coords!* - 1$
      eval list('array,
                mkquote list('steps . add1lis list(nrcoor)))$
      coors:=coords!*$
      for j:=0:nrcoor do
        <>  >>$
  ldifsch:=lhs difsch$
  rdifsch:=rhs difsch$
  ldifeq:=ldifsch$
  rdifeq:=rdifsch$
  ldifeq:=substeps(ldifeq)$
  rdifeq:=substeps(rdifeq)$
  rest:=ldifsch-ldifeq-rdifsch+rdifeq$
  for j:=0:nrcoor do
    steps(j):=steps(j)**minorder(rest,steps(j))$
  write " Difference scheme approximates differential equation ",
     ldifeq=rdifeq$
  write " with orders of approximation:"$
  on div$
  for j:=0:nrcoor do write steps(j)$
  off div$
  symbolic if !*prapprox
     then algebraic write " Rest of approximation : ",rest$
  symbolic
    <>$
      remflag(functions!*,'full)>>$
  clear steps
end$

procedure substeps u$
begin
  scalar step,nu,du$
  nu:=num u$
  du:=den u$
  symbolic for each a in coords!* do
    <>$
  symbolic rmsubs()$
  nu:=nu$
  du:=du$
  symbolic for each a in coords!* do
    <>$
  symbolic rmsubs()$
  if du=0 then <>
    else u:=nu/du$
  return u
end$

procedure minorder(pol,var)$
begin
  scalar lcofs,mord$
  coeff(den pol,var)$
  mord:=-hipow!*$
  lcofs := rest coeff(num pol,var)$
  if not(mord=0) then return (mord+lowpow!*)$
  mord:=1$
a:if lcofs={} then return 0
    else if first lcofs=0 then lcofs:=rest lcofs
    else return mord$
  mord:=mord+1$
  go to a
end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide.red0000644000175000017500000000734311526203062023025 0ustar  giovannigiovannimodule fide; % FInite difference method for partial Differential Eqn
             % systems.

% Author: Richard Liska.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version: 1.1.2 for REDUCE 3.6, May 29, 1995.

%***********************************************************************
%**  (C) 1991-1995, Richard Liska                                     **
%**      Faculty of Nuclear Science and Physical Engineering          **
%**      Technical University of Prague                               **
%**      Brehova 7                                                    **
%**      115 19 Prague 1                                              **
%**      Czech Republic                                               **
%**      Email: Richard Liska              **
%**  This package can be distributed through REDUCE Network Library.  **
%***********************************************************************

% The FIDE package consists of the following modules:
%
%  DISCRET rules for discretization.
%  EXPRES  for transforming PDES into any orthogonal coordinate system.
%  IIMET   for discretization of PDES by integro-interpolation method.
%  APPROX  for determining the order of approximation of difference
%          scheme
%  CHARPOL for calculation of amplification matrix and characteristic
%          polynomial of difference scheme, which are needed in Fourier
%          stability analysis.
%  HURWP   for polynomial roots locating necessary in verifying the von
%          Neumann stability condition.
%  LINBAND for generating the block of FORTRAN code, which solves a
%          system of linear algebraic equations with band matrix
%          appearing quite often in difference schemes.
%

% Changes since version 1.1:
% Patches in SIMPINTERPOL and SIMPINTT               13/06/91
% Patch in TDIFPAIR                                  08/07/91
% Two FEXPR routines F2VAL, FPLUS changed to MACROs  17/03/92
% Patches in IIM1, AMPMAT, HURW, CHARPOL for 3.5     01/11/93
% Version 1.1.1 of the FIDE package is the result of porting the FIDE
% package version 1.1.0 to REDUCE 3.5.
% Infix uses of NOT removed (not a memq b  ->  not(a memq b) ) ACH
% MAP* functions replaced by FOR EACH syntax         16/03/94
% Version 1.1.2 of the FIDE package is the result of porting the FIDE
% package version 1.1.1 to REDUCE 3.6.


create!-package('(fide discret approx charpol hurwp linband),
                '(contrib fide));

load!-package 'matrix;

load!-package 'fide1;   % We need this loaded.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/expres.red0000644000175000017500000006536611526203062023435 0ustar  giovannigiovannimodule expres$

% Author: R. Liska

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version REDUCE 3.6    05/1991

global '(!*outp)$                  % declarations for 3.4
fluid '(!*wrchri orig!* posn!*)$

switch wrchri$

global '(olddimension!* dimension!* coordindx!* cyclic1!* cyclic2!*
         sfprod!* nscal!*)$

flag('(share),'eval)$    % So that SHARE recognized by FASL.

share olddimension!*,dimension!*,coordindx!*,cyclic1!*,cyclic2!*,
         sfprod!*,nscal!*$

!*precise := nil;   % Needed in this module.

nscal!*:=0$

put('tensor,'tag,'tens)$
put('tensor,'fn,'tensfn)$
put('tensor,'evfn,'expres)$
put('tens,'prifn,'tenspri)$
flag('(tensor),'sprifn)$
put('tens,'setprifn,'settenspri)$
put('tensor,'typeletfn,'tenslet)$

symbolic procedure ptensor x$
   'tensor$

symbolic procedure poptensor u$
   if null u then 'tensor else nil$

deflist('((tensor ptensor)
          (tensop poptensor)
          (df getrtypecar)
          (diff getrtypecar)
           (!& ptensor)
          (!# ptensor)
          (!? ptensor)
          (grad ptensor)
          (div ptensor)
          (lapl ptensor)
          (curl ptensor)
          (vect ptensor)
          (dyad ptensor)
          (dirdf ptensor)),'rtypefn)$
put('cons,'rtypefn,'getrtypecons)$
put('rcons,'evfn,'evrcons)$
remprop('cons,'psopfn)$

symbolic procedure getrtypecons u$
if getrtypecar u eq 'tensor then 'tensor
  else 'rcons$

symbolic procedure evrcons(u,v)$
rcons cdr u$

symbolic procedure tensor u$
for each a in u do
  <>$

deflist('((tensor rlis)),'stat)$

symbolic procedure tenslet(u,v,typu,b,typv)$
if not atom u then lprie list(" Non atom tensor variable ",u)
  else if b then
     <>
  else
    <>$

%======================================================================
%  Data structure for tensor quantities
%  ====================================
%  (tensor nr rnk val car !*sqvar!*)
%  nr   -  integer, should be equal to actual nscal!*, otherwise
%          the quantity has been defined in previous coor. system
%          number of coordinate system
%  rnk  -  integer, 0,1,2
%          rank of the tensor
%          0 - scalar
%          1 - vertor
%          2 - dyad (matrix)
%  val  -  value
%          s.q.                   for rnk = 0
%          list of s.q.s          for rnk = 1
%          list of lists of s.q.s for rnk = 2
%  !*sqvar!* used in resimplification routine
%======================================================================
%  Smacro definitions for access of data structure subparts
%======================================================================

smacro procedure tensrnk u$
% determines rank from cddr of datastructure
car u$

smacro procedure tensval u$
% determines value from cddr of datastructure
cadr u$

symbolic procedure mktensor(rnk,u)$
'tensor . nscal!* . rnk . u . if !*resubs then !*sqvar!* else list nil$

symbolic procedure settenspri(u,v)$
if not atom u then lprie list(" Non-atom tensor variable ",u)
  else <>$

symbolic procedure tenspri u$
begin
  scalar rnk$
  u:=cddr u$
  rnk:=car u$
  u:=cadr u$
  if rnk=0 then
      <>
    else if rnk=1 then
      <>
    else if rnk=2 then
      <>$
        prin2!* " ) "$
        orig!*:=0$
        terpri!* t >>
    else lprie list(" Can't print tensor ",u," with rank ",rnk)
end$

symbolic procedure tenspri1 u$
<>$
  orig!*:=orig!* - 3$
  prin2!* " ) " >>$

symbolic procedure pmaprin u$
maprin(!*outp:=prepsq!*  u)$

symbolic procedure updatedimen()$
if olddimension!* = dimension!* then t
  else
    <>
        else lprie list(" Can't handle dimension = ",dimension!*)$
      olddimension!* := dimension!* >>$

symbolic procedure expres(expn,v)$
express expn$

symbolic procedure resimptens u$
mktensor(caddr u,if caddr u=0 then resimp cadddr u
                   else if caddr u=1 then for each a in cadddr u collect
                                                      resimp a
                   else if caddr u=2 then
                     for each a in cadddr u collect
                       for each b in a collect resimp b
                   else lprie list("Can't handle tensor ",u,
                                   " with rank ",caddr u))$

symbolic procedure express expn$
begin
  scalar lst,matrx,rnk,opexpress$
  if not atom expn then go to op$
  if get(expn,'rtype) eq 'tensop and (rnk:=get(expn,'avalue)) and
        car rnk memq '(tensor tensop) and (rnk:=cadr rnk) then return
      if cadr rnk=nscal!* then
          if car cddddr rnk then rnk
            else resimptens rnk
        else lprie list(" You must rebind tensor ",expn,
            " in the new coordinate system")$
  return mktensor(0,simp!* expn)$
op:if car expn = 'vect then return mktensor
       (1,testdim1 for each a in cdr expn collect simp!* a)
     else if car expn = 'dyad then return mktensor
       (2,testdim2 for each a in cdr expn collect
                     for each b in a collect simp!* b)
     else if car expn eq 'tensor then return
       if cadr expn=nscal!* then
           if car cddddr expn then expn
             else resimptens expn
         else lprie list(" You must rebind tensor ",expn,
             " in the new coordinate system")$
  lst:=for each a in cdr expn collect cddr express a$
  if (opexpress:=get(car expn,'express)) then
      <>$
  if get(car expn,'simpfn) then return mktensor(0,simp(
      car expn . for each a in lst collect
                       if car a=0 then list('!*sq,cdr a,nil)
                         else typerr(expn," well formed scalar ") ))$
  lst:=for each a in lst collect
               if car a=0 then prepsq cdr a
                 else typerr(expn," well formed tensor")$
  return mktensor(0,!*k2q(car expn.lst))
end$

procedure testdim1 u$
if length u=dimension!* then u
  else <>$

procedure testdim2 u$
begin
  scalar x$
  if length u = dimension!* then t
    else go to er$
  x:=u$
a:if length car u = dimension!* then t
    else go to er$
  x:=cdr x$
  if x then go to a$
  return u$
er:lprie "Bad number of dyad components"$
  return u
end$

%======================================================================
%  Procedures in EXPRESS properties of operators are returning
%  (rnk val), their argument is list of (rnk val)

symbolic procedure vectors arglist$
for each i in arglist do
  <>$

deflist('((vectors rlis)),'stat)$

symbolic procedure dyads arglist$
for each i in arglist do
  <>$

deflist('((dyads rlis)),'stat)$

symbolic procedure plusexpress u$
begin
  scalar z$
  z:=car u$
a:u:=cdr u$
  if null u then return z$
  z:=plus2ex(z,car u)$
  go to a
end$

put('plus,'express,'plusexpress)$

symbolic procedure plus2ex(x,y)$
begin
  scalar mtx,mty,slx,sly,rnk,ans,ans1$
  rnk:=tensrnk x$
  if not(rnk=tensrnk y) then lprie "Tensor mishmash"$
  if rnk=0 then return list(rnk,addsq(cadr x,cadr y))
    else if rnk=1 then
             <>$
               ans:= list(1,reverse ans) >>
    else if rnk=2 then
             <>$
                   ans:=reverse ans1 . ans$
                   mtx:=cdr mtx$
                   mty:=cdr mty>>$
               ans:=list(2,reverse ans) >>$
  return ans
end$

symbolic procedure timesexpress u$
begin
  scalar z$
  z:=car u$
a:u:=cdr u$
  if null u then return z$
  z:=times2ex(z,car u)$
  go to a
end$

put('times,'express,'timesexpress)$

symbolic procedure times2ex(x,y)$
begin
  scalar rnkx,rnky$
  rnkx:=tensrnk x$
  rnky:=tensrnk y$
  return
    if rnkx=0 then list(rnky,times0ex(tensval x,tensval y,rnky))
      else if rnky=0 then list(rnkx,times0ex(tensval y,tensval x,rnkx))
      else lprie " Tensor mishmash "
end$

symbolic procedure times0ex(x,y,rnk)$
if rnk=0 then multsq(x,y)
  else if rnk=1 then
    for each a in y collect multsq(x,a)
  else if rnk=2 then
    for each a in y collect
      for each b in a collect multsq(x,b)
  else lprie " Tensor mishmash "$

symbolic procedure minusexpress expn$
timesexpress list(list(0,cons(-1,1)),car expn)$

put('minus,'express,'minusexpress)$

symbolic procedure differenceexpress expn$
plusexpress list(car expn,minusexpress list cadr expn)$

put('difference,'express,'differenceexpress)$

symbolic procedure quotientexpress expn$
if tensrnk cadr expn = 0 then
    times2ex(list(0,simp!* list('recip,prepsq tensval cadr expn)),
             car expn)
  else lprie " Tensor mishmash "$

put('quotient,'express,'quotientexpress)$

symbolic procedure exptexpress expn$
if tensrnk car expn=0 and tensrnk cadr expn = 0 then
    list(0,simp!* list('expt,
                       prepsq tensval car expn,
                       prepsq tensval cadr expn))
  else lprie " Tensor mishmash "$

put('expt,'express,'exptexpress)$

symbolic procedure recipexpress expn$
if tensrnk car expn = 0 then
    list(0,simp!* list('recip,
                       prepsq tensval car expn))
  else lprie " Tensor mishmash "$

put('recip,'express,'recipexpress)$

symbolic procedure inprodexpress expn$
begin
  scalar arg1,arg2,rnk1,rnk2$
  arg1:=tensval car expn$
  arg2:=tensval cadr expn$
  rnk1:=tensrnk car expn$
  rnk2:=tensrnk cadr expn$
  return
    if rnk1=1 then inprod1ex(arg1,arg2,rnk2)
      else if rnk1=2 then inprod2ex(arg1,arg2,rnk2)
      else lprie " Tensor mishmash "
end$

put('cons,'express,'inprodexpress)$

symbolic procedure inprod1ex(x,y,rnk)$
begin
  scalar lstx,lsty,mty,z,zz$
  lstx:=x$
  lsty:=y$
  if rnk=1 then
      <>$
        z:=list(0,z)>>
    else if rnk=2 then
      <>$
            z:=nconc(z,list zz) >>$
        z:=list(1,z)>>
    else lprie " Tensor mishmash "$
  return z
end$

symbolic procedure inprod2ex(x,y,rnk)$
begin
  scalar mtx,z$
  mtx:=x$
  if rnk=1 then
      while mtx do
        <>
    else if rnk=2 then
      while mtx do
        <>
    else lprie " Tensor mishmash "$
  return list(rnk,z)
end$

symbolic procedure outexpress expn$
begin
  scalar x,y,z$
  x:=tensval car expn$
  y:=tensval cadr expn$
  if tensrnk car expn=1 and tensrnk cadr expn=1 and null cddr expn then
      for each i in x do z:=(for each a in y collect multsq(a,i) ) . z
    else lprie list(" Outer product of ",expn)$
  return list(2,reverse z)
end$

put('!&,'express,'outexpress)$
flag('(!&),'tensfn)$

symbolic procedure copy2(x,p)$
if null x then nil else
if p then copy2(car x,nil) . copy2(cdr x,t)
  else car x . copy2(cdr x,nil)$

symbolic procedure listar(arg,j)$
if j=1 then car arg
  else if j=2 then cadr arg
  else if j=3 then caddr arg
  else lprie list(" LISTAR ",arg,j)$

symbolic procedure listarsq(arg,j)$
prepsq listar(arg,j)$

symbolic procedure dinprod expn$
begin
  scalar x,y,z,xx,yy$
  x:=tensval car expn$
  y:=copy2(tensval cadr expn,t)$
  z:=nil . 1$
  if not(tensrnk car expn=2 and tensrnk cadr expn=2 and null cddr expn)
      then lprie list(" D-scalar product of ",expn)$
a:if null x and null y then go to d
    else if null x or null y then go to er$
  xx:=car x$
  yy:=car y$
b:if null xx and null yy then go to c
    else if null xx or null yy then go to er$
  z:=addsq(z,multsq(car xx,car yy))$
  xx:=cdr xx$
  yy:=cdr yy$
  go to b$
c:x:=cdr x$
  y:=cdr y$
  go to a$
d:return list(0,z)$
er:lprie list(" EXPRESS error ",expn," D-S dyads of dif. size")
end$

put('!#,'express,'dinprod)$
put('hash,'express,'dinprod)$
put('hash,'rtypefn,'ptensor)$

symbolic procedure antisymsum(u,v)$
if dimension!* = 2 then difmul(car u,cadr u,cadr v,car v)
  else if dimension!* = 3 then list
      (difmul(cadr u,caddr u,caddr v,cadr v),
       difmul(caddr u,car u,car v,caddr v),
       difmul(car u,cadr u,cadr v,car v))
  else lprie list(" ANTISYMSUM ",u,v)$

symbolic procedure difmul(a,b,c,d)$
% A*C-B*D$
addsq(multsq(a,c),negsq multsq(b,d))$

symbolic procedure vectprod expn$
begin
  scalar x,y,rnx,rny$
  x:=tensval car expn$
  y:=tensval cadr expn$
  rnx:=tensrnk car expn$
  rny:=tensrnk cadr expn$
  if rnx=1 and rny=1 then return
      list(dimension!* - 2,antisymsum(x,y))
    else if rnx=2 and rny=1 then return
      list(dimension!* - 1,for each a in x collect antisymsum(a,y) )
    else if rnx=1 and rny=2 then return
      list(dimension!* - 1,
           if dimension!*=3 then
               tp1 copy2(for each a in tp1(copy2(y,t)) collect
                         antisymsum(x,a),t)
             else for each a in tp1(copy2(y,t)) collect
                         antisymsum(x,a) )
    else lprie list(" VECTPROD of ",expn)
end$

put('!?,'express,'vectprod)$

algebraic operator diff$

symbolic procedure gradexpress expn$
begin
  scalar arg,vt,ans,row,z$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  if vt=0 then
      for each i in coordindx!* do
        ans:=simp!* list('quotient,
                       list('diff,
                            list('!*sq,arg,nil),
                            getel list('coordinats,i)),
                       getel list('sf,i)) . ans
    else if vt=1 then
      for each i in coordindx!* do
        <>$
          ans:=row . ans>>
    else lprie list(" GRAD of ",expn)$
  return list(vt+1,ans)
end$

put('grad,'express,'gradexpress)$

symbolic procedure divexpress expn$
begin
  scalar arg,vt,ans,z$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  if vt=1 then
      <>
    else if vt=2 then
      for each i in coordindx!* do
        <>$
          ans:=simp!*('plus.z) . ans>>
    else lprie list(" DIV of ",expn)$
  return list(vt-1,ans)
end$

put('div,'express,'divexpress)$

symbolic procedure laplexpress expn$
begin
  scalar arg,vt,ans$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  if vt=0 then
      <>
    else if vt=1 then
        ans:=divexpress list gradexpress expn
    else lprie list(" LAPLACIAN of ",expn)$
  return ans
end$

put('lapl,'express,'laplexpress)$

symbolic procedure curlexpress expn$
begin
  scalar arg,vt,ans,ic1,ic2$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  if vt=1 then
      for each i in (if dimension!* = 3 then coordindx!*
                       else '(1) ) do
        <>
    else lprie list(" CURL of ",expn)$
  return (if dimension!* = 3 then list(1,ans)
            else list(0,car ans))
end$

put('curl,'express,'curlexpress)$
flag('(cons grad div lapl curl tens vect dyad dirdf !& !# !?)
     ,'tensfn)$

symbolic procedure exscalval u$
begin
  scalar fce,args$
  fce:=car u$
  args:=for each a in cdr u collect cddr express a$
  fce:=eval(get(fce,'express) . list mkquote args)$
  if car fce=0 then return cadr fce
    else typerr(u," is not scalar ")$
  return (nil . 1)
end$

algebraic$

infix #,?,&$
precedence .,**$
precedence #,.$
precedence ?,#$
precedence &,?$

symbolic flag('(cons !# !? div lapl curl dirdf),'full)$
symbolic for each a in '(cons !# !? div lapl curl dirdf)
   do put(a,'simpfn,'exscalval)$

symbolic procedure scalefactors transf$
begin
  scalar var$
  dimension!*:=car transf$
  transf:=cdr transf$
  if dimension!*=2 then
      <>
    else if dimension!*:=3 then
      <>
    else lprie list(" Can't handle dimension = ",dimension!*)$
  if dimension!*=length var then t
    else lprie list(" Transformation ",transf,var)$
  for i:=1:dimension!* do
    setel(list('coordinats,i),listar(var,i))$
  for row:=1:dimension!* do
    for col:=1:dimension!* do
      setel(list('jacobian,row,col),
            aeval list('df,
                       listar(transf,col),
                       getel list('coordinats ,row)))$
  updatedimen()$
  rscale()
end$

deflist('((scalefactors rlis)),'stat)$

flag('(remd),'eval);
remd 'jacobian; remprop('jacobian,'opfn);   % For bootstrapping.

array jacobian(3,3),coordinats (3),sf(3),christoffel(3,3,3)$

procedure rscale()$
begin
  sfprod!*:=1$
  nscal!*:=nscal!* + 1$
  for row:=1:dimension!* do
    <>$
      sf(row):=sqrt gcov(row,row)$
      sfprod!*:=sfprod!* *sf(row)>>$
  on nero$
  for i:=1:dimension!* do for j:=1:dimension!* do
    for k:=1:dimension!* do begin christoffel(i,j,k):=
      ((if i=j then df(sf(j),coordinats (k)) else 0)
      -(if i=k then df(sf(k),coordinats (j)) else 0))
      /(sf(j)*sf(k))$
      if wrchri(a)=0 then write christoffel(i,j,k):=
          christoffel(i,j,k)   end$
  off nero
end$

procedure gcov(j,k)$
for l:=1:dimension!* sum jacobian(j,l)*jacobian(k,l)$

symbolic$

symbolic procedure simpwrchri u$
if !*wrchri then nil . 1
  else 1 . 1$

put('wrchri,'simpfn,'simpwrchri)$

symbolic procedure rmat$
'dyad . cdr matstat()$

symbolic procedure formdyad(u,v,m)$
'list . mkquote 'dyad . cddr formmat(u,v,m)$

put('dyad,'stat,'rmat)$
put('dyad,'formfn,'formdyad)$

symbolic procedure dirdfexpress expn$
begin
  scalar arg,vt,direc,ans,z,dj,di,argj,sfj,sfi,cooj$
  arg:=cadr expn$
  vt:=tensrnk arg$
  direc:=car expn$
  if not (tensrnk direc=1) then return
      lprie list (" Direction in DIRDF is not a vector ",expn)$
  if vt=0 then return inprodexpress list (direc,
                         gradexpress list arg)$
  arg:=tensval arg$
  direc:=tensval direc$
  if not(vt=1) then return
      lprie list (" Argument of DIRDF is dyadic ",expn)$
  for each i in coordindx!* do
    <>$
      z:='plus . z$
      z:=simp!* z$
      ans:=z . ans >>$
  return list(1,ans)
end$

put('dirdf,'express,'dirdfexpress)$

symbolic procedure dfexpress expn$
begin
  scalar arg,vt,rest$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  rest:=cdr expn$
  rest:=for each a in rest collect
          if tensrnk a=0 then
              if atom tensval a then tensval a
                else if cdr tensval a=1 and numberp car tensval a
                       then car tensval a
                else !*q2k tensval a
            else lprie list(" Bad arg of DF ",expn)$
  if vt=0 then return list(0,simpdf(list('!*sq,arg,t) . rest))
    else if vt=1 then return list(1,for each a in arg collect
                                       simpdf(list('!*sq,a,t) . rest) )
    else if vt=2 then return list(2,for each a in arg collect
                                      for each b in a collect
                                        simpdf(list('!*sq,b,t) . rest) )
    else lprie list(" Bad tensor in DF ",expn)
end$

put('df,'express,'dfexpress)$

symbolic procedure diffexpress expn$
begin
  scalar arg,vt,rest$
  arg:=tensval car expn$
  vt:=tensrnk car expn$
  rest:=cdr expn$
  rest:=for each a in rest collect
             if tensrnk a=0 then
                 if atom tensval a then tensval a
                   else if cdr tensval a=1 and numberp car tensval a
                    then car tensval a
                   else !*q2k tensval a
               else lprie list(" Bad arg of DIFF ",expn)$
  if vt=0 then return list(0,simp('diff . (prepsq arg . rest)))
    else if vt=1 then return list(1,for each a in arg collect
                                    simp('diff . (prepsq a . rest)) )
    else if vt=2 then return list(2,for each a in arg collect
                                      for each b in a collect
                                        simp('diff . (prepsq b . rest)))
    else lprie list(" Bad tensor in DIFF ",expn)
end$

put('diff,'express,'diffexpress)$

remprop('diff,'number!-of!-args);  % Until we understand what's up.

algebraic$

scalefactors 3,x,y,z,x,y,z$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/linband.red0000644000175000017500000005302011526203062023516 0ustar  giovannigiovannimodule linband;

% Author: R. Liska

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version REDUCE 3.6     05/1991

% GENTRAN package has to be loaded prior to this module

global'(fortcurrind!* genstmtnum!* genstmtincr!*)$
fluid'(!*period)$            % declaration for 3.4

fluid'(!*imsl !*nag !*essl)$

switch imsl,nag,essl$
!*imsl:=nil$
!*nag:=nil$
!*essl:=nil$

procedure ison x$
if eval x then 1
  else 0$

operator ison$

if null getd 'gentempst then
procedure gentempst$
list('gentemp,xread t)$

global'(temp!*)$
temp!*:=nil$

procedure gentemp u$
<>$

put('gentemp,'stat,'gentempst)$
put('gentemp,'formfn,'formgentran)$
load!-package 'gentran;

procedure outtemp$
begin
  scalar period,fortind$
  period:=!*period$
  fortind:=fortcurrind!*$
  for each a in reverse temp!* do
    <>$
  temp!* := nil$
  !*period:=period$
  fortcurrind!*:=fortind$
  return nil
end$

put('outtemp,'stat,'endstat)$
flag('(outtemp),'eval)$

algebraic$

procedure genlinbandsol(nlc,nuc,system)$
% Generates FORTRAN program for solving of linear algebraic system
% of equations with band matrix with NLC lower codiagonals and NUC
% upper codiagonals.
begin
  scalar pvars,svars,vareq,fveq$
  %  PVARS  - list of variables before actual variable
  %  SVARS  - list of variables after actual variable
  %  VAREQ  - actual v-equation (list {variable equation})
  symbolic
    <>$
  system:=expanddo(nlc,nuc,system)$
  vareq:=first system$
  pvars:={}$
  svars:=findsvars(nuc,vareq,system)$
  off period$
  gentran n:=1$
  gentemp n:=1$
  on period$
  ncol!*:=nlc+nuc+1$
  for i:=1:nlc do
    <>$
  while length svars=nuc do
    <>$
  for i:=1:nuc do
    <> >>$
  off period$
  if ison !*imsl = 1 then pvars:=gencall!-imsl(nlc,nuc)
    else if ison !*nag = 1 then pvars:=gencall!-nag(nlc,nuc)
    else if ison !*essl= 1 then pvars:=gencall!-essl(nlc,nuc)
    else pvars:=gencall!-linpack(nlc,nuc)$
  on period$
  outtemp$
  symbolic <>
end$

procedure gencall!-imsl (nlc,nuc)$
gentran
  <>$

procedure gencall!-linpack(nlc,nuc)$
if ncol!*=3 and nlc=1 then gencall!-linpack!-trid(nlc,nuc)
  else gentran
  <= n",cr!*$
    literal "c     iacof >= ",eval(nlc+ncol!*),cr!*$
    literal "c  ipvt is array of dimension at least (n)",cr!*$
    literal "c  if (ier.ne.0) matrix acof is algorithmically singular",
              cr!*$
    literal tab!*,"if(ier.ne.0) call errout",cr!*$
    literal tab!*,"call dgbsl(acof,iacof,n,",eval nlc,",",eval nuc,
            ",ipvt,arhs,0)",cr!*>>$

procedure gencall!-linpack!-trid(nlc,nuc)$
gentran
  <>$

procedure gencall!-essl(nlc,nuc)$
if ncol!*=3 and nlc=1 then gencall!-essl!-trid(nlc,nuc)
  else gentran
  <= n",cr!*$
    literal "c     iacof >= ",eval(nlc+ncol!*+15),cr!*$
    literal "c  arhs is array of dimension at least (n)",cr!*$
    literal "c  ipvt is integer array of dimension at least (n)",cr!*$
    literal tab!*,"call dgbs(acof,iacof,n,",eval nlc,",",eval nuc,
            ",ipvt,arhs)",cr!*>>$

procedure gencall!-essl!-trid(nlc,nuc)$
gentran
  <>$

procedure gencall!-nag(nlc,nuc)$
if ncol!*=3 and nlc=1 then gencall!-nag!-trid(nlc,nuc)
  else gentran
  <= n",cr!*$
    literal "c      iacof >= min(n,",eval ncol!*,")",cr!*$
    literal "c  al is array of dimension (ial,p), p >= n",cr!*$
    literal "c      ial >= max(1,",eval nlc,")",cr!*$
    literal "c  in is integer array of dimension at least (n)",cr!*$
    literal tab!*,"if(ier.ne.0) call errout",cr!*$
    literal tab!*,"call f04ldf(n,",eval nlc,",",eval nuc,
            ",1,acof,iacof,al,ial,in,arhs,iarhs,ier)",cr!*$
    literal "c  arhs is array of dimension (iarhs), iarhs >= n",cr!*$
    literal tab!*,"if(ier.ne.0) call errout",cr!* >>$

procedure gencall!-nag!-trid(nlc,nuc)$
gentran
  <>$

procedure gennp1$
<>$

% Definition of operator SUBE

symbolic$

symbolic procedure simpsube u$
begin
  scalar x$
a:if null cdr u then go to d
    else if null eqexpr car u then errpri2(car u,t)$
  x:=list('equal,reval cadar u,caddar u) . x$
  u:=cdr u$
  go to a$
d:x:=reverse(car u . x)$
  x:=subeval x$
  return x
end$

symbolic put('sube,'psopfn,'simpsube)$

algebraic$

% Procedures FFRRST etc.

procedure ffst u$
first first u$
procedure frst u$
first rest u$
procedure rfst u$
rest first u$
procedure rrst u$
rest rest u$

procedure fffst u$
first ffst u$
procedure ffrst u$
first frst u$
procedure frfst u$
first rfst u$
procedure frrst u$
first rrst u$
procedure rffst u$
rest ffst u$
procedure rfrst u$
rest frst u$
procedure rrfst u$
rest rfst u$
procedure rrrst u$
rest rrst u$

procedure ffffst u$
ffst ffst u$
procedure fffrst u$
ffst frst u$
procedure ffrfst u$
ffst rfst u$
procedure ffrrst u$
ffst rrst u$
procedure frffst u$
frst ffst u$
procedure frfrst u$
frst frst u$
procedure frrfst u$
frst rfst u$
procedure frrrst u$
frst rrst u$
procedure rfffst u$
rfst ffst u$
procedure rffrst u$
rfst frst u$
procedure rfrfst u$
rfst rfst u$
procedure rfrrst u$
rfst rrst u$
procedure rrffst u$
rrst ffst u$
procedure rrfrst u$
rrst frst u$
procedure rrrfst u$
rrst rfst u$
procedure rrrrst u$
rrst rrst u$

procedure findsvars(nuc,vareq,system)$
% Looks for NUC next variables in SYSTEM
% VAREQ is actual v-equation
if ffst system=do then findsvarsdo(nuc,vareq,first system)
  else findsvars1(nuc,rest system)$

procedure findsvars1(nuc,system)$
% Substitutes values for loop variable
if nuc=0 or system={} then {}
  else if ffst system=do then fsvars1do(nuc,first system)
  else ffst system . findsvars1(nuc-1,rest system)$

procedure fsvars1do(nuc,cykl)$
% Substitutes into the loop CYKL
begin
  scalar id,from,step,syst,x,y$
  cykl:=rest cykl$
  syst:=first cykl$
  id:=first syst$
  from:=frst syst$
  step:=frrrst syst$
  syst:=rest cykl$
  x:={}$
a:y:=sube(id=from,ffst syst)$
  x:=y . x$
  nuc:=nuc-1$
  if nuc=0 then go to r$
  syst:=rest syst$
  if not(syst={}) then go to a$
  syst:=rest cykl$
  from:=from+step$
  go to a$
r:x:=reverse x$
  return x
end$

procedure findsvarsdo(nuc,vareq,cykl)$
% Does not substitute for loop variable, only increases it
% by STEP if it is necessary
begin
  scalar id,add1,step,syst,x,y$
  cykl:=rest cykl$
  syst:=first cykl$
  id:=first syst$
  step:=frrrst syst$
  syst:=rest cykl$
  while not(first vareq=ffst syst and rest vareq=rfst syst)
     do syst:=rest syst$
  syst:=rest syst$
  add1:=0$
  x:={}$
a:if syst={} then go to b$
  y:=sube(id=id+add1,ffst syst)$
  x:=y . x$
  nuc:=nuc-1$
  if nuc=0 then go to r$
  syst:=rest syst$
  go to a$
b:syst:=rest cykl$
  add1:=add1+step$
  go to a$
r:x:=reverse x$
  return x
end$

procedure expanddo(nlc,nuc,system)$
% Every loop in SYSTEM is expanded so that more than or equal to
% NLC first elements and more than or equal NUC last elements are
% excluded from the loop, and changes the parameters of loop so
% that its meaning remains the same
begin
  scalar x$
  x:={}$
a:if system={} then go to r$
  if ffst system=do then x:=append(expddo(nlc,nuc,first system),x)
    else x:=first system . x$
  system:=rest system$
  go to a$
r:x:=reverse x$
  return x
end$

procedure expddo(nlc,nuc,cykl)$
% Performs the expansion of the loop CYKL - returns reverse list
begin
  scalar id,from,to1,step,syst,lsyst,ns,x,y,bn$
  cykl:=rest cykl$
  syst:=first cykl$
  id:=first syst$
  from:=frst syst$
  to1:=frrst syst$
  step:=frrrst syst$
  syst:=rest cykl$
  lsyst:=length syst$
  ns:=quotient1(nlc,lsyst)$
  if nlc>ns*lsyst then ns:=ns+1$
  bn:=0$
  x:={}$
a:y:=sube(id=from,ffst syst) . sube(id=from,frfst syst) . {}$
  x:=y . x$
  syst:=rest syst$
  if not(syst={}) then go to a$
  ns:=ns-1$
  from:=from+step$
  if ns=0 then go to b$
  syst:=rest cykl$
  go to a$
b:if bn=1 then go to r$
  syst:=rest cykl$
  ns:=quotient1(nuc,lsyst)$
  if nuc>ns*lsyst then ns:=ns+1$
  to1:=to1-ns*step$
  y:=do . (id . from . to1 . step . {}) . syst$
  x:=y . x$
  from:=to1+step$
  bn:=1$
  go to a$
r:return x
end$

symbolic procedure quotient1(u,v)$
quotient(u,v)$

symbolic operator quotient1$
operator acof,arhs$

procedure genvareq(pvars,svars,vareq,nlc,nzero,mode)$
if ison !*imsl = 1 then
       genvareq!-imsl(pvars,svars,vareq,nlc,nzero,mode)
  else if ison !*nag = 1 then
       genvareq!-nag(pvars,svars,vareq,nlc,nzero,mode)
  else genvareq!-linpack(pvars,svars,vareq,nlc,nzero,mode)$

procedure genvareq!-imsl(pvars,svars,vareq,nlc,nzero,mode)$
% Generates N-th row of coeff. matrix ACOF and right hand side ARHS
% according to the v-equation VAREQ.
% NZERO is number of zeroes before or after (according to MODE).
% Matrix ACOF is transformed to IMSL band matrix storage.
begin
  integer j$
  scalar var,rhside,lhside,x,y$
  if not(length pvars + length svars+1+nzero=ncol!*) then return
      write" Unconsistent PVARS:",pvars," SVARS:",svars," NZERO:",nzero$
  var:=first vareq$
  vareq:=frst vareq$
  rhside:=rhs vareq$
  lhside:=lhs vareq$
  j:=1$
  x:=0$
  if mode=pfix!* then while j<=nzero do
      <>$
  for each a in pvars do
    <>$
  y:=lincof(lhside,var)$
  x:=x+var*y$
  gentran acof(n,eval j):=:y$
  j:=j+1$
  for each a in svars do
    <>$
  if mode=sfix!* then while j<=ncol!* do
      <>$
  gentran arhs(n):=:rhside$
  gentemp eval(var):=arhs(n)$
  if not(x-lhside=0) then write " For equation ",vareq," given only ",
      "variables ",pvars,svars,var$
  return
end$

procedure genvareq!-linpack(pvars,svars,vareq,nlc,nzero,mode)$
% Generates N-th row of coeff. matrix ACOF and right hand side ARHS
% according to the v-equation VAREQ.
% NZERO is number of zeroes before or after (according to MODE).
% Matrix ACOF is transformed to LINPACK band matrix storage.
% NCOL!* is the band width.
begin
  integer j,jj,nn$
  scalar var,rhside,lhside,x,y$
  if not(length pvars + length svars+1+nzero=ncol!*) then return
      write" Unconsistent PVARS:",pvars," SVARS:",svars," NZERO:",nzero$
  if nlc=1 and ncol!*=3 then return
         genvareq!-linpack!-trid(pvars,svars,vareq,nlc,nzero,mode)$
  var:=first vareq$
  vareq:=frst vareq$
  rhside:=rhs vareq$
  lhside:=lhs vareq$
  j:=n-nlc$
  jj:=1$
  nn:=ncol!*+nlc$
  x:=0$
  if mode=pfix!* then while jj<=nzero do
      <>$
  for each a in pvars do
    <>$
  y:=lincof(lhside,var)$
  x:=x+var*y$
  gentran acof(nn,j)::=:y$
  nn:=nn-1$
  j:=j+1$
  for each a in svars do
    <>$
  gentran arhs(n):=:rhside$
  gentemp eval(var):=arhs(n)$
  if not(x-lhside=0) then write " For equation ",vareq," given only ",
      "variables ",pvars,svars,var$
  return
end$

procedure genvareq!-linpack!-trid(pvars,svars,vareq,nlc,nzero,mode)$
begin
  scalar var,rhside,lhside,x,y$
  var:=first vareq$
  vareq:=frst vareq$
  rhside:=rhs vareq$
  lhside:=lhs vareq$
  x:=0$
  for each a in pvars do
    <>$
  y:=lincof(lhside,var)$
  x:=x+var*y$
  gentran ad(n):=:y$
  for each a in svars do
    <>$
  gentran arhs(n):=:rhside$
  gentemp eval(var):=arhs(n)$
  if not(x-lhside=0) then write " For equation ",vareq," given only ",
      "variables ",pvars,svars,var$
  return
end$

procedure genvareq!-nag(pvars,svars,vareq,nlc,nzero,mode)$
% Generates N-th row of coeff. matrix ACOF and right hand side ARHS
% according to the v-equation VAREQ.
% NZERO is number of zeroes before or after (according to MODE).
% Matrix ACOF is transformed to NAG band matrix storage.
% NCOL!* is the band width.
begin
  integer j$
  scalar var,rhside,lhside,x,y$
  if not(length pvars + length svars+1+nzero=ncol!*) then return
      write" Unconsistent PVARS:",pvars," SVARS:",svars," NZERO:",nzero$
  if nlc=1 and ncol!*=3 then return
         genvareq!-nag!-trid(pvars,svars,vareq,nlc,nzero,mode)$
  var:=first vareq$
  vareq:=frst vareq$
  rhside:=rhs vareq$
  lhside:=lhs vareq$
  j:=1$
  x:=0$
  for each a in pvars do
    <>$
  y:=lincof(lhside,var)$
  x:=x+var*y$
  gentran acof(eval j,n):=:y$
  j:=j+1$
  for each a in svars do
    <>$
  gentran arhs(n):=:rhside$
  gentemp eval(var):=arhs(n)$
  if not(x-lhside=0) then write " For equation ",vareq," given only ",
      "variables ",pvars,svars,var$
  return
end$

procedure genvareq!-nag!-trid(pvars,svars,vareq,nlc,nzero,mode)$
begin
  scalar var,rhside,lhside,x,y$
  var:=first vareq$
  vareq:=frst vareq$
  rhside:=rhs vareq$
  lhside:=lhs vareq$
  x:=0$
  for each a in pvars do
    <>$
  y:=lincof(lhside,var)$
  x:=x+var*y$
  gentran ad(n):=:y$
  for each a in svars do
    <>$
  gentran arhs(n):=:rhside$
  gentemp eval(var):=arhs(n)$
  if not(x-lhside=0) then write " For equation ",vareq," given only ",
      "variables ",pvars,svars,var$
  return
end$

procedure lincof(expre,ker)$
% Expression EXPRE is linear in kernel KER.
% Returns coeff. of KER in EXPRE.
(expre-sube(ker=0,expre))/ker$

stackdolabel!*:={}$

procedure nextvareqsys(vareq,system)$
% Looks for the next v-equation. Returns the new v-equation . SYSTEM.
% During get into the loop generates the beginning of the loop,
% during get out of the loop generates end of the loop.
if rest system={} then {} . {}
  else if ffst system=do then nextvesdo(vareq,system)
  else if ffrst system=do then nextvesdofst(rest system)
  else frst system . rest system$

procedure nextvesdofst(system)$
% Get into the loop
begin
  scalar id,from,to1,step$
  id:=frfst system$
  from:=frst id$
  to1:=frrst id$
  step:=frrrst id$
  id:=first id$
  genstmtnum!*:=genstmtnum!*+genstmtincr!*$
  gentran literal tab!*,"do ",eval(genstmtnum!*)," ",eval(id),"=",
          eval(from),",",eval(to1),",",eval(step),cr!*$
  stackdolabel!*:=genstmtnum!* . stackdolabel!*$
  genstmtnum!*:=genstmtnum!*+genstmtincr!*$
  gentemp <>$
  fortcurrind!*:=fortcurrind!* + 4$
  stackdolabel!*:=genstmtnum!* . stackdolabel!*$
  id:=frrfst system . system$
  return id
end$

procedure nextvesdo(vareq,system)$
% SYSTEM begins with a loop - test on the end of loop.
% Suppose that after the loop cannot be another loop, which
% follows from EXPANDDO.
begin
  scalar vareqs$
  vareqs:=rrfst system$
  while not(first vareq=ffst vareqs and rest vareq=rfst vareqs) and
        not(rest vareqs={}) do vareqs:=rest vareqs$
  vareqs:=rest vareqs$
  if vareqs={} then
    % end of loop
      <>$
        stackdolabel!*:=rest stackdolabel!*$
        gentran literal eval first stackdolabel!*,tab!*,"continue",cr!*$
        stackdolabel!*:=rest stackdolabel!*$
        vareqs:=frst system . rest system >>
    else vareqs:=first vareqs . system$
  return vareqs
end$

procedure findpvars(nlc,cykl)$
% Looks for NLC previous variables during geting into the loop
begin
  scalar id,step$
  id:=frst cykl$
  step:=frrrst id$
  id:=first id$
  cykl:=reverse rrst cykl$
  id:=reverse fsvars1do(nlc,
                       do . (id . (id-step) . 0 . (-step) . {}) . cykl)$
  return id
end$

procedure lastvars(nlc,cykl)$
% Looks for the NLC last variables of the loop CYKL
begin
  scalar id,step,to1$
  id:=frst cykl$
  to1:=frrst id$
  step:=frrrst id$
  id:=first id$
  cykl:=reverse rrst cykl$
  id:=reverse fsvars1do(nlc,do . (id . to1 . 0 . (-step) . {}) . cykl)$
  return id
end$

symbolic$
flag('(ffst frst rfst rrst fffst ffrst frfst frrst rffst rfrst rrfst
     rrrst ffffst fffrst ffrfst ffrrst frffst frfrst frrfst frrrst
     rfffst rffrst rfrfst rfrrst rrffst rrfrst rrrfst rrrrst
     findsvars findsvars1 fsvars1do findsvarsdo expanddo expddo
     genvareq nextvareqsys nextvesdofst nextvesdo findpvars lastvars),
     'noval)$

procedure equalaeval u$
'equal . aevlis u$

procedure aevlis u$
for each a in u collect aeval a$

procedure listnoeval(u,v)$
if atom u then listnoeval(cadr get(u,'avalue),v)
  else u$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide.txt0000644000175000017500000022461511526203062023075 0ustar  giovannigiovanni












                             F  I  D  E
                             ==========




                  A REDUCE package for automation of

                 FInite difference method for partial

                     Differential Equation solving






                              Version 1.1




                             User's Manual
                             -------------




                              Richard Liska




          Faculty of Nuclear Science and Physical Engineering
                    Technical University of Prague
              Brehova 7, 115 19 Prague 1, Czechoslovakia
                     E-mail: tjerl@cspuni12.bitnet (EARN)
                     Fax: (42 - 2) 84 73 54
                     Tel: (42 - 2) 84 77 86



                                May 1991




                                         1









                               Abstract
                               --------


     The FIDE  package performs  automation of  the process of numerical
solving  partial  differential  equations  systems  (PDES)  by  means of
computer algebra.  For PDES solving finite difference method is applied.
The  computer  algebra  system  REDUCE  and  the  numerical  programming
language FORTRAN  are used in the presented methodology. The main aim of
this methodology is to  speed  up  the  process  of  preparing numerical
programs for  solving PDES.  This process is quite often, especially for
complicated systems, a tedious and time consuming task.
     In the process  one  can  find  several  stages  in  which computer
algebra  can  be  used  for  performing routine analytical calculations,
namely: transforming differential  equations  into  different coordinate
systems,   discretization   of   differential   equations,  analysis  of
difference  schemes  and  generation  of  numerical  programs.  The FIDE
package consists of the following modules:

  EXPRES  for transforming PDES into any orthogonal coordinate system.
  IIMET   for discretization of PDES by integro-interpolation method.
  APPROX  for determining the order of approximation of difference
          scheme.
  CHARPOL for calculation of amplification matrix and characteristic
          polynomial of difference scheme, which are needed in Fourier
          stability analysis.
  HURWP   for polynomial roots locating necessary in verifying the von
          Neumann stability condition.
  LINBAND for generating the block of FORTRAN code, which solves a
          system of linear algebraic equations with band matrix
          appearing quite often in difference schemes.

     Version  1.1  of  the  FIDE  package  is the result of porting FIDE
package to REDUCE 3.4. In comparison with Version 1.0 some features  has
been changed  in the  LINBAND module  (possibility to  interface several
numerical libraries).





References
----------

[1] R. Liska, L. Drska: FIDE: A REDUCE package for automation of  FInite
      difference method for  solving pDE. In  ISSAC '90, Proceedings  of
      the International Symposium on Symbolic and Algebraic Computation,
      Ed. S. Watanabe, M. Nagata. p. 169-176, ACM Press, Addison Wesley,
      New York 1990.


                                         2



                    Table of contents
                    =================

1   E X P R E S                                                      4

1.1 The specification of the coordinate system.......................4
1.2 The declaration of tensor quantities.............................5
1.3 New infix operators..............................................5
1.4 New prefix operators.............................................5
1.5 Tensor expressions...............................................6
1.6 Assigning statement..............................................7

2   I I M E T                                                        8

2.1 Specification of the coordinates and the indices
    corresponding to them............................................8
2.2 Difference grids.................................................9
2.3 Declaring the dependence of functions on coordinates............10
2.4 Functions and difference grids..................................11
2.5 Equations and difference grids..................................12
2.6 Discretization of basic terms...................................13
2.7 Discretization of a system of equations.........................18
2.8 Error messages..................................................20

3   A P P R O X                                                     21

3.1 Specification of the coordinates and the indices
    corresponding to them...........................................21
3.2 Specification of the Taylor expansion...........................21
3.3 Function declaration............................................22
3.4 Order of accuracy determination.................................23

4   C H A R P O L                                                   24

4.1 Commands common with the IIMET module...........................24
4.2 Function declaration............................................24
4.3 Amplification matrix............................................25
4.4 Characteristic polynomial.......................................26
4.5 Automatic denotation............................................26

5   H U R W P                                                       28

5.1 Conformal mapping...............................................28
5.2 Investigation of polynomial roots...............................28

6   L I N B A N D                                                   30

6.1 Program generation..............................................30
6.2 Choosing the numerical library..................................32
6.3 Completion of the generated code................................32






                                         3















                            1   E X P R E S
                                ===========



                A Module for Transforming Differential
         Operators and Equations into an Arbitrary Orthogonal
                           Coordinate System



     This module  makes it  possible to  express various scalar, vector,
and tensor differential equations  in any  orthogonal coordinate system.
All transformations  needed are  executed automatically according to the
coordinate  system  given  by  the  user.  The  module  was  implemented
according to the similar MACSYMA module from [1].


1.1 The specification of the coordinate system
    ------------------------------------------

     The coordinate system is specified using the following statement:

  SCALEFACTORS ,,...,,,...,;
   ::= 2 | 3                       coordinate system dimension
   ::= "algebraic expression"   the expression of the i-th
                                      Cartesian coordinate in new
                                      coordinates
   ::= "identifier"            the i-th new coordinate

All evaluated  quantities are transformed into the coordinate system set
by the last SCALEFACTORS statement. By default, if this statement is not
applied, the  three-dimensional Cartesian coordinate system is employed.
During the evaluation of SCALEFACTORS statement the metric coefficients,
i.e. scale  factors SF(i),  of a  defined coordinate system are computed
and printed. If the WRCHRI switch  is ON,  then the  nonzero Christoffel
symbols of the coordinate system are printed too. By  default the WRCHRI
switch is OFF.






                                         4






1.2 The declaration of tensor quantities
    ------------------------------------

     Tensor  quantities  are  represented  by  identifiers.  The VECTORS
declaration declares  the identifiers  as vectors, the DYADS declaration
declares the identifiers as dyads. i.e. two-dimensional tensors, and the
TENSOR  declaration  declares  the  identifiers as tensor variables. The
declarations have the following syntax:

   ,,...,;
   ::= VECTORS | DYADS | TENSOR
   ::= "identifier"

The value of the identifier V declared as vector in  the two-dimensional
coordinate  system  is  (V(1),  V(2)),  where V(i) are the components of
vector V. The value of the identifier T declared as a dyad  is ((T(1,1),
T(1,2)), (T(2,1),  T(2,2))). The value of the tensor variable can be any
tensor (see below). Tensor variables  can  be  used  only  for  a single
coordinate  system,  after  the  coordinate  system  redefining by a new
SCALEFACTORS statement, the tensor variables have to be re-defined using
the assigning statement.


1.3 New infix operators
    -------------------

     For  four  different  products  between  the tensor quantities, new
infix operators have been  introduced  (in  the  explaining  examples, a
two-dimensional  coordinate  system,  vectors  U,  V, and dyads T, W are
considered):

  .  - scalar product                U.V = U(1)*V(1)+U(2)*V(2)
  ?  - vector product                U?V = U(1)*V(2)-U(2)*V(1)
  &  - outer product                 U&V = ((U(1)*V(1),U(1)*V(2)),
                                            (U(2)*V(1),U(2)*V(2)))
  #  - double scalar product         T#W = T(1,1)*W(1,1)+T(1,2)*W(1,2)+
                                           T(2,1)*W(2,1)+T(2,2)*W(2,2)

The other usual arithmetic infix operators +, -,  *, **  can be  used in
all situations  that have  sense (e.g. vector addition, a multiplication
of a tensor by a scalar, etc.).


1.4 New prefix operators
    --------------------

     New  prefix  operators  have  been  introduced  to  express  tensor
quantities  in  its  components  and the differential operators over the
tensor quantities:

  VECT  - the explicit expression of a vector in its components
  DYAD  - the explicit expression of a dyad in its components

                                         5






  GRAD  - differential operator of gradient
  DIV   - differential operator of divergence
  LAPL  - Laplace's differential operator
  CURL  - differential operator of curl
  DIRDF - differential operator of the derivative in direction
          (1st argument is the directional vector)

The results  of the  differential operators  are written  using the DIFF
operator.  DIFF(,)  expresses the derivative of 
with respect to the  coordinate . This  operator is  not further
simplified. If  the user wants to make it simpler as common derivatives,
he performs the following declaration:

  FOR ALL X,Y LET DIFF(X,Y) = DF(X,Y);  .

Then, however, we must realize that if the scalars or  tensor quantities
do not directly explicitly depend on the coordinates, their dependencies
have  to  be  declared  using  the  DEPEND  statements,   otherwise  the
derivative will  be evaluated  to zero.  The dependence of all vector or
dyadic components (as dependence of the name of  vector or  dyad) has to
appear  before  VECTORS  or  DYADS  declarations,  otherwise after these
declarations one has to declare the dependencies of  all components. For
formulating  the   explicit  derivatives   of  tensor  expressions,  the
differentiation operator DF can be used  (e.g. the  differentiation of a
vector in its components).


1.5 Tensor expressions
    ------------------

     Tensor expressions  are the  input into  the EXPRES  module and can
have a variety of forms. The output is then the formulation of the given
tensor expression  in the  specified coordinate system. The most general
form of a  tensor  expression    is  described  as  follows (the
conditions  (d=i)  represent  the  limitation  on  the  dimension of the
coordinate system equalling i):

   ::=  |  | 
   ::= "algebraic expression, can contain " |
               "tensor variable with scalar value" |
               . | # |
               (d=2)? | DIV  |
               LAPL  | (d=2) ROT  |
               DIRDF(,)
   ::= "identifier declared by VECTORS statement" |
               "tensor variable with vector value" |
               VECT(,...,) | - |
               + | - |
               * | / |
               . | . | (d=3)
               ? | (d=2) ? |
               (d=2) ? | GRAD  |

                                         6






               DIV  | LAPL  | (d=3) ROT  |
               DIRDF(,) | DF(,"usual
               further arguments")
      ::= "identifier declared by DYADS statement" |
               "tensor variable with dyadic value" |
               DYAD((,...,),...,(,
               ...,)) | - | + |
               - | * | /
               | . | & |
               (d=3) ? | (d=3) ? |
               GRAD  | DF(,"usual further arguments")


1.6 Assigning statement
    -------------------

     The assigning statement for  tensor variables  has a  usual syntax,
namely:

   := 
   ::= "identifier declared TENSOR"  .

The assigning  statement assigns  the tensor  variable the  value of the
given tensor expression,  formulated  in  the  given  coordinate system.
After a change of the coordinate system, the tensor variables have to be
redefined.



References
----------

[1] M. C. Wirth, On the Automation of Computational Physics. PhDr
          Thesis. Report UCRL-52996, Lawrence Livermore National
          Laboratory, Livermore, 1980.


















                                         7















                             2   I I M E T
                                 =========



                 A Module for Discretizing the Systems
                   of Partial Differential Equations



     This program module makes it possible  to discretize  the specified
system of partial differential equations using the integro-interpolation
method,  minimizing  the  number  of  the  used  interpolations  in each
independent variable.  It can  be used for non-linear systems and vector
or tensor variables as well.  The user specifies the way of discretizing
individual terms  of differential equations, controls the discretization
and obtains various difference schemes according to his own wish.


2.1 Specification of the coordinates and the indices corresponding
    to them
    --------------------------------------------------------------

     The independent variables of differential equations  will be called
coordinates.  The  names  of  the  coordinates and the indices that will
correspond to the particular  coordinates in  the difference  scheme are
defined using the COORDINATES statement:

  COORDINATES  {,} [ INTO
             {,}];
   ::= "identifier"  - the name of the coordinate
   ::= "identifier"       - the name of the index

This statement  specifies that the  will correspond to the
. A new COORDINATES statement cancels the  definitions given by
the preceding  COORDINATES statement.  If the  part [  INTO ... ] is not
included in the statement, the  statement  assigns  the  coordinates the
indices I, J, K, L, M, N, respectively. If it is included, the number of
coordinates and the number of indices should be the same.





                                         8






2.2 Difference grids
    ----------------

     In the discretization, orthogonal  difference  grids  are employed.
In addition to the basic grid, called the integer one, there is another,
the half-integer grid in each coordinate, whose cellular boundary points
lie in  the centers of the cells of the integer grid. The designation of
the  cellular  separating  points  and  centers  is  determined  by  the
CENTERGRID switch:  if it is ON and the index in the given coordinate is
I, the centers of the grid cells are designated by indices I, I + 1,...,
and the  boundary points of the cells by indices I + 1/2,..., if, on the
contrary, the switch is OFF,  the  cellular  centers  are  designated by
indices I  + 1/2,...,  and the  boundary points  by indices I, I + 1,...
(see Fig. 2.1).


                                         ON CENTERGRID
  I-1/2     I       I+1/2          I+1            I+3/2
---|--------|--------|--------------|--------------|----
   I       I+1/2    I+1            I+3/2          I+2
                                         OFF CENTERGRID

              Figure 2.1 Types of grid


In the case of  ON CENTERGRID,  the indices  i,i+1,i-1... thus designate
the centers  of the cells of the integer grid and the boundary points of
the cells of the half-integer grid, and, similarly,  in the  case of OFF
CENTERGRID,  the  boundaries  of  the  cells of the integer grid and the
central points of the half-integer grid. The meaning of the  integer and
half-integer  grids  depends  on  the CENTERGRID switch in the described
way. After the package is loaded, the CENTERGRID is ON.  Obviously, this
switch is significant only for non-uniform grids with a variable size of
each cell.
     The grids can be uniform, i.e. with a constant cell size - the step
of the grid. The following statement:

  GRID UNIFORM,{,};

defines  uniform  grids  in  all  coordinates  occurring  in  it.  Those
coordinates that do not occur in the GRID UNIFORM statement are supposed
to have non-uniform grids.
     In the  outputs, the grid step is designated by the identifier that
is made by putting the character  H before  the name  of the coordinate.
For a  uniform grid, this identifier (e.g. for the coordinate X the grid
step HX) has the meaning of a step of an  integer or  half-integer grids
that  are  identical.  For  a  non-uniform  grid,  this identifier is an
operator and has the  meaning of  a step  of an  integer grid,  i.e. the
length  of  a  cell  whose  center  (in  the  case  of ON CENTERGRID) or
beginning (in the case of OFF  CENTERGRID)  is  designated  by  a single
argument  of  this  operator.  For  each  coordinate s designated by the


                                         9






identifier i, this step of the  integer non-uniform  grid is  defined as
follows:

  Hs(i+j) = s(i+j+1/2) - s(i+j-1/2)      at ON CENTERGRID
  Hs(i+j) = s(i+j+1) - s(i+j)            at OFF CENTERGRID

for all integers j (s(k) designates the value of the coordinate s in the
cellular boundary point subscripted with the index k). The steps  of the
half-integer non-uniform grid are not applied in outputs.


2.3 Declaring the dependence of functions on coordinates
    ----------------------------------------------------

     In  the  system  of  partial  differential  equations, two types of
functions, in other words dependent  variables  can  occur:  namely, the
given  functions,  whose  values  are  known  before the given system is
solved, and the sought functions, whose  values are  not available until
the system  of equations is solved. The functions can be scalar, vector,
or tensor, for vector or tensor  functions the  EXPRES module  has to be
applied at  the same  time. The  names of  the functions employed in the
given system and their dependence on the coordinates are specified using
the DEPENDENCE statement.

  DEPENDENCE {,};
   ::= ([],{,
                   })
   ::= "identifier"  - the name of the function
   ::= 1|2 tensor order of the function (the value of
              the function is 1 - vector, 2 - dyad (two-
              dimensional tensor))

Every   in the  statement determines  on which 
the  depends. If the tensor  of the function  occurs in
the ,  the  is declared as a vector or a dyad. If,
however, the  has  been  declared  by  the  VECTORS  and DYADS
statements of  the EXPRES  module, the  user need not present the tensor
. By default, a function without  any declaration  is regarded as
scalar. In the discretization, all scalar components of tensor functions
are replaced by  identifiers  that  arise  by  putting  successively the
function name  and the  individual indices  of the given component (e.g.
the tensor component T(1,2), written in the EXPRES module as  T(1,2), is
represented by  the identifier  T12). Before the DEPENDENCE statement is
executed, the coordinates  have  to  be  defined  using  the COORDINATES
statement. There  may be  several DEPENDENCE  statements. The DEPENDENCE
statement cancels all preceding determinations of which grids  are to be
used for differentiating the function or the equation for this function.
These determinations can be  either  defined  by  the  ISGRID  or GRIDEQ
statements, or computed in the evaluation of the IIM statement.
     The GIVEN statement:

  GIVEN {,};

                                        10







declares all  functions included  in it  as given functions whose values
are known to the user or can be computed. The CLEARGIVEN statement:

  CLEARGIVEN;

cancels all preceding GIVEN declarations. If  the TWOGRID  switch is ON,
the given  functions can  be differentiated  both on the integer and the
half-integer grids. If the TWOGRID switch is OFF, any given function can
be differentiated  only on  one grid.  After the  package is loaded, the
TWOGRID is ON.


2.4 Functions and difference grids
    ------------------------------

     Every scalar function or scalar component of a  vector or  a dyadic
function occurring  in the  discretized system can be discretized in any
of the coordinates either on the  integer or  half-integer grid.  One of
the tasks  of the  IIMET module  is to  find the optimum distribution of
each of these dependent variables  of  the  system  on  the  integer and
half-integer grids  in all variables so that the number of the performed
interpolations in the integro-interpolation method will be minimal.
     Using the statement

  SAME {,};

all functions given in one of these declarations will be  discretized on
the same  grids in all coordinates. In each SAME statement, at least one
of these functions in one SAME statement must be the sought one.  If the
given function occurs in the SAME statement, it will be discretized only
on one grid, regardless of the state of the TWOGRID switch. If  a vector
or a  dyadic function  occurs in  the SAME statement, what has been said
above relates to all  its  scalar  components.  There  are  several SAME
statements that can be presented. All SAME statements can be canceled by
the following statement:

  CLEARSAME;

The SAME statement can be successfully used, for example, when the given
function depends  on the  function sought  in a  complicated manner that
cannot be  included  either  in  the  differential  equation  or  in the
difference scheme explicitly, and when both the functions are desired to
be discretized in the same points so that the user will not be forced to
execute the interpolation during the evaluation of the given function.
     In  some  cases,  it  is  convenient  too to specify directly which
variable on which grid is to be discretized,  for which  case the ISGRID
statement is applied:

  ISGRID {,};
   ::= ([,]{,})
   ::=  .. ,

                                        11






   ::= ONE | HALF            designation of the integer
                                   (ONE) and half-integer (HALF)
                                   grids
   ::=  |        for the vector 
                  ,  for the dyadic 
                                   it is not presented for the
                                   scalar 
   ::= *| "natural number from 1 to the space dimension
                the space dimension is specified in the EXPRES
                module by the SCALEFACTORS statement, * means all
                components

The statement  defines that the given functions or their components will
be discretized in the specified coordinates  on the  specified grids, so
that, for example, the statement ISGRID U (X..ONE,Y..HALF), V(1,Z..ONE),
T(*,1,X..HALF); defines that scalar U will be discretized on the integer
grid in  the coordinate X, and on the half-integer one in the coordinate
Y, the first component of vector V will  be on  the integer  grid in the
coordinate  Z,  and  the  first  column  of  tensor  T  will  be  on the
half-integer grid in the  coordinate  X.  The  ISGRID  statement  can be
applied  more  times.  The  functions  used in this statement have to be
declared before by the DEPENDENCE statement.


2.5 Equations and difference grids
    ------------------------------

     Every equation of the system of  partial differential  equations is
an equation  for some  sought function (specified in the IIM statement).
The correspondence between the sought  functions  and  the  equations is
mutually  unambiguous.   The  GRIDEQ  statement  makes  it  possible  to
determine on which grid  an individual  equation will  be discretized in
some or all coordinates

  GRIDEQ {,};
   ::= ({,})

Every  equation  can  be  discretized  in  any  coordinate either on the
integer   or   half-integer   grid.   This   statement   determines  the
discretization of the equations given by the functions included in it in
given coordinates, on given grids.  The  meaning  of  the  fact  that an
equation is discretized on a certain grid is as follows: index I used in
the DIFMATCH statements (discussed in the following section), specifying
the discretization  of the basic terms, will be located in the center of
the cell of this  grid,  and  indices  I+1/2,  I-1/2  from  the DIFMATCH
statement on the boundaries of the cell of this grid. The actual name of
the index in the  given coordinate  is determined  using the COORDINATES
statement, and its location on the grid is set by the CENTERGRID switch.





                                        12






2.6 Discretization of basic terms
    -----------------------------

     The discretization of a system of partial differential equations is
executed successively in individual  coordinates. In  the discretization
of an  equation in  one coordinate,  the equation is linearized into its
basic terms first that will be discretized independently then.   If D is
the  designation  for  the  discretization operator in the coordinate x,
this linearization obeys the following rules:

  1. D(a+b) = D(a)+D(b)
  2. D(-a)  = -D(a)
  3. D(p.a) = p.D(a)        (p does not depend on the coordinate x)
  4. D(a/p) = D(a)/p

     The linearization lasts as long  as  some  of  these  rules  can be
applied.   The   basic   terms   that  must  be  discretized  after  the
linearization have then the forms of the following quantities:

  1. The actual coordinate in which the discretization is performed.
  2. The sought function.
  3. The given function.
  4. The product of the quantities 1 - 7.
  5. The quotient of the quantities 1 - 7.
  6. The natural power of the quantities 1 - 7.
  7. The derivative of the quantities 1 - 7 with respect to the
     actual coordinate.

The way of discretizing these basic  terms, while  the functions  are on
integer  and  half-integer  grids,  is  determined  using  the  DIFMATCH
statement:

  DIFMATCH ,,{{,}
           , };
   ::= ALL | "identifier" - the coordinate name from
                                        the COORDINATES statement
   ::= |
       |
       | *
       | / |
        ** |
       DIFF(,[,])|
       ({,})
   ::= X
   ::= U | V | W
   ::= F | G
   ::= N | "integer greater than 1"
   ::= "integer greater than 2"
   ::= =
   ::= |
                         

                                        13






   ::= "non-negative integer"
   ::= ()|
                "natural number"|DI|DIM1|DIP1|DIM2|DIP2|
                 | -  |
                 +  |
                 *  |
                 /  |
                () |
                 **
   ::= X | U | V | W | F | G
   ::=  |
                          +  |
                          - 
   ::= I
   = "rational number"
  DIFCONST {,};
   ::= "identifier" - the constant parameter of
                                     the difference scheme.
  DIFFUNC {,};
   ::= "identifier" - prefix operator, that can
                appear in discretized equations (e.g. SIN).

The first parameter of the DIFMATCH statement determines  the coordinate
for which the discretization defined in it is valid. If ALL is used, the
discretization  will   be   valid   for   all   coordinates,   and  this
discretization is  accepted when  it has  been checked whether there has
been no other discretization  defined for  the given  coordinate and the
given  pattern  term.  Each  pattern  sought  function, occurring in the
pattern term, must be included in  the specification  of the  grids. The
pattern  given  functions  from  the  pattern term can occur in the grid
specification, but in some cases  (see  below)  need  not.  In  the grid
specification the  maximum number  of 3 pattern functions may occur. The
discretization  of  each  pattern  term  has  to  be  specified  in  all
combinations   of   the   pattern   functions   occurring  in  the  grid
specification, on the  integer  and  half-integer  grids,  that  is 2**n
variants   for   the   grid   specification  with  n  pattern  functions
(n=0,1,2,3). The discretized term is the  discretization of  the pattern
term in  the pattern  coordinate X in the point X(I) on the pattern grid
(see  Fig.  2.2),  and  the  pattern  functions  occurring  in  the grid
specification are  in the  discretized term on the respective grids from
this  specification  (to  the  discretized  term  corresponds  the  grid
specification preceding it).

                                            integer grid
        X(I-1)                X(I)               X(I+1)
          |        DIM1        |       DIP1        |
---|------|------|-------------|-------------|-----|-----|---
   |    DIM2     |            DI             |    DIP2   |
 X(I-3/2)      X(I-1/2)                    X(I+1/2)     X(I+3/2)
                                            half-integer grid

                 Figure 2.2 Pattern grid

                                        14







The pattern grid steps defined as

  DIM2 = X(I - 1/2) - X(I - 3/2)
  DIM1 = X(I) - X(I - 1)
  DI   = X(I + 1/2) - X(I - 1/2)
  DIP1 = X(I + 1) - X(I)
  DIP2 = X(I + 3/2) - X(I + 1/2)

can occur in the discretized term.
     In  the  integro-interpolation  method,  the  discretized  term  is
specified by the integral

  =1/(X(I+1/2)-X(I-1/2))*DINT(X(I-1/2),X(I+1/2),
                                                ,X),

where DINT is operator of definite integration DINT(from,  to, function,
variable).   The   number   of   interpolations   determines   how  many
interpolations were needed for  calculating this  integral in  the given
discrete form (the function on the integer or half-integer grid). If the
integro-interpolation method is not used,  the  more  convenient  is the
distribution of the functions on the half-integer and integer grids, the
smaller number is chosen by the user.  The parameters  of the difference
scheme defined  by the  DIFCONST statement  can occur in the discretized
expression  too  (for  example,  the  implicit-explicit  scheme  on  the
implicit layer  multiplied by  the constant C and on the explicit one by
(1-C)).  As a matter of fact, all DIFMATCH statements  create a  base of
pattern  terms  with  the  rules  of  how  to  discretize these terms in
individual coordinates under the assumption that the functions occurring
in  the   pattern  terms  are  on  the  grids  determined  in  the  grid
specification (all combinations must be included).
     The DIFMATCH statement does not check whether the  discretized term
is actually  the discretization  of the  pattern term  or whether in the
discretized term occur the functions from the grid  specification on the
grids  given  by  this  specification.  An  example can be the following
definition of the discretization of the first and  second derivatives of
the sought function in the coordinate R on a uniform grid:

  DIFMATCH R,DIFF(U,X),U=ONE,2,(U(I+1)-U(I-1))/(2*DI);
                         U=HALF,0,(U(I+1/2)-U(I-1/2))/DI;
  DIFMATCH R,DIFF(U,X,2),U=ONE,0,(U(I+1)-2*U(I)+U(I-1))/DI**2,
    U=HALF,2,(U(I+3/2)-U(I+1/2)-U(I-1/2)+U(I-3/2))/(2*DI**2);

     All DIFMATCH statements can be cleared by the statement

  CLEARDIFMATCH;

After this statement user has to supply its own DIFMATCH statements.
     But now back to the discretizing of the basic terms obtained by the
linearization of the partial differential equation, as mentioned  at the
beginning of  this section.  Using the  method of  pattern matching, for
each basic term a term representing its pattern is found in the  base of

                                        15






pattern  terms  (specified  by  the  DIFMATCH  statements).  The pattern
matching obeys the following rules:

  1. The  pattern for  the coordinate  in which  the discretization is
  executed is the pattern coordinate X.

  2.  The  pattern  for  the  sought  function  is some pattern sought
  function, and this correspondence is mutually unambiguous.

  3.  The  pattern  for  the  given  function  is  some  pattern given
  function, or,  in case  the EQFU  switch is  ON, some pattern sought
  function, and, again, the correspondence  of  the  pattern  with the
  given  function  is  mutually  unambiguous  (after  loading the EQFU
  switch is ON).

  4. The pattern for the products of quantities is the  product of the
  patterns of these quantities, irrespective of their sequence.

  5. The pattern for the quotient of quantities is the quotient of the
  patterns of these quantities.

  6. The pattern for the natural power of a quantity is the same power
  of the  pattern of  this quantity or the power of this quantity with
  the pattern exponent N.

  7. The pattern for the derivative of a quantity with  respect to the
  coordinate in which the discretization is executed is the derivative
  of  the  pattern  of  this  quantity  with  respect  to  the pattern
  coordinate X of the same order of differentiation.

  8. The  pattern for  the sum  of the  quantities that  have the same
  pattern with the identical  correspondence of  functions and pattern
  functions is  this common  pattern (so that it will not be necessary
  to multiply the parentheses during discretizing the products  in the
  second and further coordinates).

When  matching  the  pattern  of  one  basic term, the program finds the
pattern term and the functions corresponding  to the  pattern functions,
maybe also  the exponent  corresponding to the pattern exponent N. After
determining on which grids the individual  functions and  the individual
equations  will  be  discretized,  which  will  be discussed in the next
section, the program finds in the pattern term base the discretized term
either with  pattern functions  on the  same grids  as are the functions
from the basic  term  corresponding  to  them  in  case  that  the given
equation  is  differentiated  on  the  integer  grid,  or  with  pattern
functions on inverse grids  (an inverse  integer grid  is a half-integer
grid, and  vice versa)  compared with  those used for the functions from
the basic term corresponding to  them  in  case  the  given  equation is
differentiated  on  the  half-integer  grid (the discretized term in the
DIFMATCH statement is expressed in the point X(I),  i.e. on  the integer
grid,  and  holds  for  the  discretizing of the equation on the integer
grid; with regard to the substitutions for the pattern index I mentioned

                                        16






later, it is possible to proceed in this way and not necessary to define
the discretization in the points X(I+1/2) too, i.e.  on the half-integer
grid). The program replaces in the thus obtained discretized term:

  1.  The  pattern  coordinate  X  with the particular coordinate s in
  which the discretization is actually performed.

  2. The pattern index I and the grid steps DIM2, DIM1, DI, DIP1, DIP2
  with the expression given in table 2.1 according to the state of the
  CENTERGRID switch and to the  fact  whether  the  given  equation is
  discretized  on  the  integer  or  half-integer grid (i is the index
  corresponding to  the  coordinate  s  according  to  the COORDINATES
  statement, the grid steps were defined in section 2.2)

  3. The  pattern functions  with the corresponding functions from the
  basic  term  and,   possibly,   the   pattern   exponent   with  the
  corresponding exponent from the basic term.

--------------------------------------------------------------------
|                   the equation discretized on                    |
|          the integer grid         |    the half-integer grid     |
|        CENTERGRID      |CENTERGRID|CENTERGRID|     CENTERGRID    |
|           OFF          |   ON     |   OFF    |         ON        |
|------------------------------------------------------------------|
| I  |            i                 |            i+1/2             |
|----|-------------------------------------------------------------|
|DIM2|(Hs(i-2)+Hs(i-1))/2|     Hs(i-1)         |(Hs(i-1)+Hs(i))/2  |
|DIM1|      Hs(i-1)      | (Hs(i-1)+Hs(i))/2   |      Hs(i)        |
|DI  |(Hs(i-1)+Hs(i))/2  |     Hs(i)           |(Hs(i)+Hs(i+1))/2  |
|DIP1|      Hs(i)        | (Hs(i)+Hs(i+1))/2   |      Hs(i+1)      |
|DIP2|(Hs(i)+Hs(i+1))/2  |     Hs(i+1)         |(Hs(i+1)+Hs(i+2))/2|
--------------------------------------------------------------------

        Table 2.1  Values of the pattern index and
                   the pattern grid steps.

     More details  will be  given now to the discretization of the given
functions and  its specification.  The given  function may  occur in the
SAME statement, which makes it bound with some sought function, in other
words it can be discretized only on one grid. This means that  all basic
terms, in  which this  function occurs, must have their pattern terms in
whose discretization definitions by  the DIFMATCH  statement the pattern
function corresponding  to the  mentioned given function has to occur in
the grid specification. If the given function does not occur in the SAME
statement and the TWOGRID switch is OFF, i.e. it can be discretized only
on one grid again, the same holds true. If, however,  the given function
does not  occur in the SAME statement and the TWOGRID switch is ON, i.e.
it can be discretized simultaneously on the integer and the half-integer
grids, then  the basic  terms of  the equations  including this function
have their pattern terms in whose discretization definitions the pattern
function corresponding to the mentioned given function need not occur in
the grid specification.  If, however,  in  spite  of  all,  this pattern

                                        17






function  in  the  discretization  definition  does  occur  in  the grid
specification,  it  is  the  alternative  with   a  smaller   number  of
interpolations occurring  in the DIFMATCH statement that is selected for
each particular basic  term  with  a  corresponding  pattern  (the given
function can be on the integer or half-integer grid).
     Before the  discretization is  executed, it  is necessary to define
using the DIFMATCH statements  the discretization  of all  pattern terms
that are  the patterns  of all basic terms of all equations appearing in
the discretized  system in  all coordinates.  The fact  that the pattern
terms  of  the  basic  terms  of  partial  equations occur repeatedly in
individual systems has made it  possible  to  create  a  library  of the
discretizations  of   the  basic   types  of  pattern  terms  using  the
integro-interpolation method. This library  is a  component part  of the
IIMET module (in its end) and makes work easier for those users who find
the  pattern  matching  mechanism  described  here  too  difficult.  New
DIFMATCH statements  have to  be created  by those  whose equations will
contain a basic term  having no  pattern in  this library,  or those who
need  another  method  to  perform  the  discretization.  The  described
implemented algorithm  of discretizing  the basic  terms is sufficiently
general  to  enable  the  use  of  a  nearly arbitrary discretization on
orthogonal grids.


2.7 Discretization of a system of equations
    ---------------------------------------

     All statements influencing the run of  the discretization  that one
want use  in this  run have  to be executed before the discretization is
initiated. The COORDINATES, DEPENDENCE, and DIFMATCH  statements have to
occur  in  all  applications.  Further,  if necessary, the GRID UNIFORM,
GIVEN, ISGRID,  GRIDEQ, SAME,  and DIFCONST  statements can  be used, or
some of  the CENTREGRID,  TWOGRID, EQFU, and FULLEQ switches can be set.
Only  then  the  discretization  of  a  system  of  partial differential
equations can be started using the IIM statement:

  IIM {,,};
   ::= "identifier" - the name of the array for storing
                             the result
   ::= "identifier" - the name of the function
                        whose behavior is described by the
                        equation
   ::=  = 
   ::= "algebraic expression" , the derivatives are
                  designated by the DIFF operator
   ::= "algebraic expression"

Hence, in the IIM statement the name of the array in which the resulting
difference schemes will  be  stored,  and  the  pair  sought  function -
equation, which  describes this  function, are specified. The meaning of
the relation  between the  sought function  and its  equation during the
discretization lies in the fact that the sought function is preferred in
its equation so that the interpolation  is  not,  if  possible,  used in

                                        18






discretizing  the  terms  of  this  equation  that  contain  it.  In the
equations, the functions and the coordinates appear as  identifiers. The
identifiers that  have not  been declared as functions by the DEPENDENCE
statement or as coordinates by the COORDINATES statement  are considered
constants independent  of the  coordinates. The  partial derivatives are
expressed by the DIFF operator that has the same syntax  as the standard
differentiation operator  DF.   The functions and the equations can also
have the vector or tensor character. If these  non-scalar quantities are
applied,  the  EXPRES  module  has  to  be  used together with the IIMET
module, and also non-scalar  differential operators  such as  GRAD, DIV,
etc. can be employed.
     The sequence  performed by the program in the discretization can be
briefly summed up in the following items:

  1. If there are  non-scalar functions  or equations  in a  system of
  equations, they  are automatically  converted into scalar quantities
  by means of the EXPRES module.

  2.  In   each  equation,   the  terms   containing  derivatives  are
  transferred to  the left side, and the other terms to the right side
  of the equation.

  3. For each coordinate, with respect to the  sequence in  which they
  occur in the COORDINATES statement, the following is executed:

  a) It  is determined  on which grids all functions and all equations
  in the actual coordinate will be discretized, and simultaneously the
  limits  are  kept  resulting  from  the  ISGRID,  GRIDEQ,  and  SAME
  statements if they were used. Such  a distribution  of functions and
  equations on  the grids is selected among all possible variants that
  ensures the minimum sum of all numbers of the interpolations  of the
  basic terms  (specified by  the DIFMATCH statement) of all equations
  if the FULLEQ switch is ON, or of all left sides of the equations if
  the FULLEQ  switch is  OFF (after  the loading  the FULLEQ switch is
  ON).

  b) The  discretization  itself  is  executed,  as  specified  by the
  DIFMATCH statements.

  4. If the array name is A, then if there is only one scalar equation
  in the IIM statement, the discretized left side of this  equation is
  stored in  A(0) and  the discretized  right side  in A(1) (after the
  transfer mentioned in item  2), if  there are  more scalar equations
  than one  in the  IIM statement, the discretization of the left side
  of  the  i-th  scalar   equation  is   stored  in   A(i,0)  and  the
  discretization of the right side in A(i,1).

The IIM  statement can  be used  more times  during one program run, and
between its calls, the discretizing process  can be  altered using other
statements of this module.



                                        19






2.8 Error messages
    --------------

     The IIMET  module provides error messages in the case of the user's
errors. Similarly as in the REDUCE system, the error reporting is marked
with five  stars :  "*****" on  the line  start. Some error messages are
identical with those of  the REDUCE  system. Here  are given  some other
error messages that require a more detailed explanation:

***** Matching of X term not found
        - the discretization of the pattern term that is the pattern of
          the basic term printed on the place X has not been
          defined (using the DIFMATCH statement)
***** Variable of type F not defined on grids in DIFMATCH
        - in the definition of the discretizing of the pattern term
          the given functions were not used in the grid
          specification and are needed now
***** X Free vars not yet implemented
        - in the grid specification in the DIFMATCH statement
          more than 3 pattern functions were used
***** All grids not given for term X
        - in the definition of the discretization of the pattern of
          the basic term printed on the place X not all
          necessary combinations of the grid specification
          of the pattern functions were presented




























                                        20















                            3   A P P R O X
                                ===========




             A Module for Determining the Precision Order
                       of the Difference Scheme



     This  module  makes  it  possible  to  determine  the  differential
equation that is solved by the given difference scheme, and to determine
the order  of accuracy  of the solution of this scheme in the grid steps
in individual coordinates. The  discrete  function  values  are expanded
into the Taylor series in the specified point.


3.1 Specification of the coordinates and the indices
    corresponding to them
    ------------------------------------------------

     The COORDINATES  statement, described  in the  IIMET module manual,
specifying the coordinates and the indices corresponding to  them is the
same  for  this  program  module  as  well.  It has the same meaning and
syntax. The  present  module  version  assumes  a  uniform  grid  in all
coordinates. The  grid step  in the  input difference  schemes has to be
designated by an identifier consisting of the character  H and  the name
of the coordinate, e.g. the step of the coordinate X is HX.


3.2 Specification of the Taylor expansion
    -------------------------------------

     In the  determining of the approximation order, all discrete values
of the functions are expanded into the Taylor series in all coordinates.
In order  to determine  the Taylor  expansion, the program needs to know
the point in which it performs this expansion,  and the  number of terms
in the Taylor series in individual coordinates. The center of the Taylor
expansion is specified by the CENTER statement and  the number  of terms
in  the   Taylor  series  in  individual  coordinates  by  the  MAXORDER
statement:


                                        21






  CENTER 
    {,
    };
  
     ::=  = 
   ::= "rational number"
  MAXORDER {,};
   ::=  = 
   ::= "natural number"

The increment in the CENTER statement determines that the center  of the
Taylor expansion  in the given coordinate will be in the point specified
by the index I + , where I is the index corresponding to this
coordinate, defined  using the COORDINATES statement, e.g. the following
example

  COORDINATE T,X INTO N,J;
  CENTER T = 1/2, X = 1;
  MAXORDER T = 2, X = 3;

specifies that the center of the Taylor expansion  will be  in the point
(t(n+1/2),x(j+1)) and  that until the second derivatives with respect to
t (second powers of ht) and until the third derivatives  with respect to
x (third  powers of  hx) the expansion will be performed. The CENTER and
MAXORDER statements can be placed only after the  COORDINATES statement.
If the center of the Taylor expansion is not defined in some coordinate,
it is supposed to be in the point given by the index  of this coordinate
(i.e.  zero  increment).  If  the  number  of  the  terms  of the Taylor
expansion is not defined in some coordinate, the  expansion is performed
until the third derivatives with respect to this coordinate.


3.3 Function declaration
    --------------------

     All functions  whose discrete  values are  to be  expanded into the
Taylor series must be declared using the FUNCTIONS statement:

  FUNCTIONS {,};
   ::= "identifier"

In the specification of the difference scheme, the functions are used as
operators with one or more arguments, designating the discrete values of
the functions. Each argument is the  sum of  the coordinate  index (from
the  COORDINATES  statement)  and  a  rational  number. If some index is
omitted in  the  arguments  of  a  function,  this  functional  value is
supposed to lie in the point in which the Taylor expansion is performed,
as specified by the CENTER statement. In other words, if the COORDINATES
and CENTER statements, shown in the example in the previous section, are
valid, then it holds that U(N+1) = U(N+1,J+1) and U(J-1) = U(N+1/2,J-1).
The  FUNCTIONS  statement  can  declare  both  the  sought and the known
functions for the expansion.




                                        22






3.4 Order of accuracy determination
    -------------------------------

     The order of accuracy of the difference scheme is determined by the
APPROX statement:

  APPROX ();
   ::=   = 
   ::= "algebraic expression"

In the  difference scheme  occur the  functions in the form described in
the  preceding  section,  the  coordinate  indices  and  the  grid steps
described  in  section  3.1,  and  the  other symbolic parameters of the
difference scheme. The APPROX statement expands  all discrete  values of
the functions declared in the FUNCTIONS statement into the Taylor series
in all coordinates (the point in which the Taylor expansion is performed
is specified  by the  CENTER statement,  and the number of the expansion
terms by the MAXORDER  statement), substitutes  the expansions  into the
difference  scheme,  which  gives  a modified differential equation. The
modified differential equation, containing the  grid  steps  too,  is an
equation that  is really solved by the difference scheme (into the given
orders in the grid steps).
     The partial differential equation,  whose solution  is approximated
by the  difference scheme,  is determined by replacing the grid steps by
zeros and is displayed after the following message:

  "Difference scheme approximates differential equation"

Then the following message is displayed:

  "with orders of approximation:"

and the lowest powers  (except  for  zero)  of  the  grid  steps  in all
coordinates,  occurring   in  the  modified  differential  equation  are
written. If the PRAPPROX  switch is  ON, then  the rest  of the modified
differential equation is printed. If this rest is added to the left hand
side of the  approximated  differential  equation,  one  obtain modified
equation. By  default the  PRAPPROX switch is OFF. If the grid steps are
found in some denominator in the modified equation, i.e. with a negative
exponent, the  following message  is written, preceding the approximated
differential equation:

  "Reformulate difference scheme, grid steps remain in denominator"

and the approximated differential  equation is  not correctly determined
(one of  its sides is zero). Generally, this message means that there is
a term in the difference scheme that is not a  difference replacement of
the  derivative,  i.e.  the  ratio  of  the  differences of the discrete
function values and the discrete values of the coordinates (the steps of
the difference grid). The user, however, must realize that in some cases
such a term occurs purposefully in  the difference  scheme (e.g.  on the
grid boundary to keep the scheme conservative).

                                        23















                           4   C H A R P O L
                               =============



           A Module for Calculating the Amplification Matrix
               and the Characteristic Polynomial of the
                           Difference Scheme



     This program  module is  used for  the first  step of the stability
analysis  of  the  difference  scheme  using  the  Fourier   method.  It
substitutes   the   Fourier   components  into  the  difference  scheme,
calculates the amplification matrix  of the  scheme for  transition from
one time layer to another, and computes the characteristic polynomial of
this matrix.


4.1 Commands common with the IIMET module
    -------------------------------------

     The COORDINATES and GRID UNIFORM statements, described in the IIMET
module  manual,  are  applied  in  this  module as well, having the same
meaning and syntax. The time coordinate is assumed  to be  designated by
the identifier T. The present module version requires all coordinates to
have uniform grids, i.e. to be declared in  the GRID  UNIFORM statement.
The grid  step in  the input  difference schemes has to be designated by
the identifier consisting  of  the  character  H  and  the  name  of the
coordinate, e.g. the step of the time coordinate T is HT.


4.2 Function declaration
    --------------------

     The  UNFUNC  statement  declares  the names of the sought functions
used in the difference scheme:

  UNFUNC {,}
   ::= "identifier" - the name of the sought function

The functions are used in the difference schemes  as operators  with one
or  more  arguments  for  designating the discrete function values. Each

                                        24






argument is the sum of the index (from the COORDINATES  statement) and a
rational number.  If some  index is  omitted in  the function arguments,
this function value is supposed to  lie in  the point  specified only by
this index,  which means that, with the indices N and J and the function
U, it holds that U(N+1) =  U(N+1,J) and  U(J-1) =  U(N,J-1). As two-step
(in time)  difference schemes may be used only, the time index may occur
either completely alone in the arguments, or in the sum with a one.


4.3 Amplification matrix
    --------------------

     The AMPMAT matrix operator computes the  amplification matrix  of a
two-step difference  scheme. Its argument is an one column matrix of the
dimension  (1,k),  where  k  is  the  number  of  the  equations  of the
difference scheme, that contains the difference equations of this scheme
as algebraic expressions equal to the difference of  the right  and left
sides  of  the  difference  equations.  The  value  of the AMPMAT matrix
operator is the square  amplification  matrix  of  the  dimension (k,k).
During the  computation of the amplification matrix, two new identifiers
are created for each spatial coordinate. The identifier  made up  of the
character K and the name of the coordinate represents the wave number in
this coordinate, and the identifier made up of  the character  A and the
name of  the coordinate  represents the  product of this wave number and
the grid step in this coordinate divided by the least common multiple of
all  denominators  occurring  in  the  scheme  in  the function argument
containing the index of this coordinate.  On the  output an  equation is
displayed defining the latter identifier. For example, if in the case of
function U and index J in the coordinate  X the  expression U(J+1/2) has
been used in the scheme (and, simultaneously, no denominator higher than
2 has occurred in the  arguments  with  J),  the  following  equation is
displayed: AX: = (KX*HX)/2. The definition of these quantities As allows
to express every sum occurring in  the argument  of the  exponentials as
the  sum  of  these  quantities  multiplied by integers, so that after a
transformation, the amplification matrix  will contain  only sin(As) and
cos(As) (for  all spatial  coordinates s).  The AMPMAT operator performs
these transformations  automatically.  If  the  PRFOURMAT  switch  is ON
(after the  loading it is ON), the matrices H0 and H1 (the amplification
matrix is equal to -H1**(-1)*H0) are displayed during  the evaluation of
the AMPMAT  operator. These  matrices can be used for finding a suitable
substitution for the goniometric functions in the next run for a greater
simplification.
     The  TCON  matrix  operator  transforms  the  square  matrix into a
Hermit-conjugate matrix,  i.e. a  transposed and  complex conjugate one.
Its argument  is the  square matrix  and its  value is  Hermit-conjugate
matrix of the argument. The Hermit-conjugate matrix is  used for testing
the  normality   and  unitarity  of  the  amplification  matrix  in  the
determining of the sufficient stability condition.





                                        25






4.4 Characteristic polynomial
    -------------------------

     The CHARPOL operator calculates  the  characteristic  polynomial of
the given  square matrix.  The variable of the characteristic polynomial
is designated by the LAM identifier. The operator has one  argument, the
square matrix, and its value is its characteristic polynomial in LAM.


4.5 Automatic denotation
    --------------------

     Several  statements  and  procedures  are  designed  for  automatic
denotation of some parts of algebraic  expressions by  identifiers. This
denotation is namely useful when we obtain very large expressions, which
cannot fit into the available  memory.  We  can  denote  subparts  of an
expression from the previous step of calculation by identifiers, replace
these  subparts   by  these   identifiers  and   continue  the  analytic
calculation  only  with  these  identifiers.  Every  time  we  use  this
technique we have to explicitly survive  in processed  expressions those
algebraic quantities  which will  be necessary in the following steps of
calculation. The process  of  denotation  and  replacement  is performed
automatically and  the algebraic  values which  are denoted by these new
identifiers can be  written  out  at  any  time.  We  describe  how this
automatic denotation can be used.
     The  statement  DENOTID  defines  the  beginning  letters  of newly
created identifiers. Its syntax is

  DENOTID ;
   ::= "identifier"

After this  statement  the  new  identifiers  created  by  the operators
DENOTEPOL and  DENOTEMAT will  begin with  the letters of the identifier
 used in this statement. Without using any DENOTID statement all new
identifiers  will  begin  with  one  letter  A.  We  suggest to use this
statement every time before using operators DENOTEPOL or  DENOTEMAT with
some new  identifier and to choose identifiers used in this statement in
such a way that the newly  created  identifiers  are  not  equal  to any
identifiers used in the expressions you are working with.
     The operator  DENOTEPOL has  one argument, a polynomial in LAM, and
denotes  the  real  and  imaginary  part  of  its  coefficients  by  new
identifiers. The  real part of the j-th LAM power coefficient is denoted
by the identifier R0j and the imaginary part by I0j,  where 
is the  identifier used in the last DENOTID statement. The denotation is
done only for non-numeric  coefficients. The  value of  this operator is
the  polynomial  in  LAM  with  coefficients  constructed  from  the new
identifiers.  The  algebraic  expressions  which  are  denoted  by these
identifiers are  stored as  LISP data structure standard quotient in the
LISP variable DENOTATION!* (assoc. list).
     The operator DENOTEMAT has one argument, a matrix,  and denotes the
real and  imaginary parts  of its  elements. The  real part of the (j,k)
matrix element is denoted  by the  identifier Rjk  and the imaginary

                                        26






part  by  Ijk.  The  returned  value of the operator is the original
matrix with non-numeric elements replaced by Rjk +  I*Ijk. Other
matters are the same as for the DENOTEPOL operator.
     The statement PRDENOT has the syntax

  PRDENOT;

and writes  from the  variable DENOTATION!*  the definitions  of all new
identifiers introduced  by the  DENOTEPOL and  DENOTEMAT operators since
the last  call of  CLEARDENOT statement (or program start) in the format
defined by  the  present  setting  of  output  control  declarations and
switches. The  definitions are  written   in the same order as they have
been  entered,  so  that  the  definitions  of  the  first  DENOTEPOL or
DENOTEMAT operators  are written  first. This order guarantees that this
statement can be utilized  directly to  generate a  semantically correct
numerical program  (the identifiers from the first denotation can appear
in the second one, etc.).
     The statement CLEARDENOT with the syntax

  CLEARDENOT;

clears the variable DENOTATION!*, so that all denotations  saved earlier
by the  DENOTEPOL and DENOTEMAT operators in this variable are lost. The
PRDENOT statement succeeding this statement writes nothing.





























                                        27















                             5   H U R W P
                                 =========



                A Module for Polynomial Roots Locating



     This module is used  for verifying  the stability  of a polynomial,
i.e. for  verifying if  all roots  of a  polynomial lie in a unit circle
with its center  in  the  origin.  By  investigating  the characteristic
polynomial  of  the  difference  scheme,  the  user  can  determine  the
conditions of the stability of this scheme.


5.1 Conformal mapping
    -----------------

     The HURW  operator  transforms  a  polynomial  using  the conformal
mapping LAM=(z+1)/(z-1).  Its argument  is a  polynomial in  LAM and its
value is a transformed polynomial in LAM (LAM=z).  If P is  a polynomial
in LAM,  then it holds: all roots LAM1i of the polynomial P are in their
absolute values smaller than one, i.e. |LAM1i|<1, iff the real  parts of
all  roots  LAM2i  of  the  HURW(P)  polynomial  are  negative,  i.e. Re
(LAM2i)<0.
     The elimination of the unit polynomial roots (LAM=1),  which has to
occur before  the conformal  transformation is performed, is made by the
TROOT1 operator. The argument of this  operator is  a polynomial  in LAM
and its  value is  a polynomial  in LAM not having its root equal to one
any more. Mostly, the investigated polynomial has some  more parameters.
For some  special values  of those parameters, the polynomial may have a
unit root.  During the evaluation of the TROOT1 operator,  the condition
concerning  the  polynomial  parameters  is  displayed,  and  if  it  is
fulfilled, the resulting polynomial has a unit root.


5.2 Investigation of polynomial roots
    ---------------------------------

     The HURWITZP operator checks  whether a  polynomial is  the Hurwitz
polynomial, i.e.  whether all  its roots  have negative  real parts. The
argument of the HURWITZP operator is  a polynomial  in LAM  with real or

                                        28






complex  coefficients,  and  its  value  is  YES  if the argument is the
Hurwitz polynomial.  It  is  NO  if  the  argument  is  not  the Hurwitz
polynomial, and COND if it is the Hurwitz polynomial when the conditions
displayed by the HURWITZP  operator during  its analysis  are fulfilled.
These  conditions  have  the  form of inequalities and contain algebraic
expressions made up of the polynomial coefficients. The  conditions have
to  be  valid  either  simultaneously,  or  they  are  designated  and a
proposition is created from them by the AND and OR  logic operators that
has  to  be  fulfilled  (it  is  the condition concerning the parameters
occurring in the polynomial  coefficient)  by  a  polynomial  to  be the
Hurwitz one. This proposition is the sufficient condition, the necessary
condition is the fulfillment of all the inequalities displayed.
     If the HURWITZP  operator  is  called  interactively,  the  user is
directly  asked  if  the  inequalities  are  or  are not valid. The user
responds "Y" if the displayed inequality is valid, "N" if it is not, and
"?" if he does not know whether the inequality is true or not.





































                                        29















                           6   L I N B A N D
                               =============



            A Module for Generating the Numeric Program for
            Solving a System of Linear Algebraic Equations
                           with Band Matrix



     The LINBAND  module generates  the numeric  program in  the FORTRAN
language, which solves a system of linear algebraic equations with  band
matrix using  the routine  from the  LINPACK, NAG  ,IMSL or ESSL program
library.  As  input data only  the system of  equations is given  to the
program.   Automatically,  the  statements  of  the FORTRAN language are
generated that fill the band  matrix of the system in  the corresponding
memory mode of chosen library, call the solving routine, and assign  the
chosen variables to the solution of  the system. The module can be  used
for solving linear difference schemes often having the band matrix.


6.1 Program generation
    ------------------

     The  program   in  the   FORTRAN  language   is  generated  by  the
GENLINBANDSOL statement (the  braces  in  this  syntax  definition occur
directly  in  the  program  and  do  not  have  the usual meaning of the
possibility of repetition, they designate REDUCE lists):

  GENLINBANDSOL (,,{});
   ::= "natural number"
   ::= "natural number"
   ::=  | ,
  ::= {,} | 
   ::= "kernel"
   ::=  = 
   ::= "algebraic expression"
   ::= "algebraic expression"
   ::= {DO,{,,,},}
   ::= "identifier"
   ::= 


                                        30






   ::= 
   ::= 
   ::= "algebraic expression" with natural value
                                        (evaluated in FORTRAN)
   ::=  | ,
   ::= {,}

The first and second  argument of the GENLINBANDSOL  statement specifies
the  number  of  the  lower  (below  the  main  diagonal)  and the upper
diagonals  of  the  band  matrix  of  the  system.  The system of linear
 algebraic equations is specified by means of lists expressed by  braces
{ } in the  REDUCE system. The variables  of the equation system  can be
identifiers, but most  probably they are  operators with an  argument or
with arguments that are analogous to array in FORTRAN. The left side  of
each equation has  to be a  linear combination of  the system variables,
the right side, on the contrary, is not allowed to contain any variables
of the system.  The sequence of  the band matrix  lines is given  by the
sequence  of  the  equations,  and  the  sequence  of the columns by the
sequence of the variables in the list describing the equation system.
     The meaning  of the  loop in  the system list is similar to that of
the DO loop  of  the  FORTRAN  language.  The  individual  variables and
equations described by the loop are obtained as follows:

  1.  = .
  2.  The    value  is  substituted  into the variables and
  equations of the  loop,  by  which  further  variables and
  equations of the system are obtained.
  3.  is increased by .
  4. If  is less or equal , then go to step 2, else all
  variables and equations described  by  the  loop  have  already been
  obtained.

The variables  and equations  of the system included in the loop usually
contain the loop parameter, which mostly occur in the operator arguments
in the REDUCE language, or in the array indices in the FORTRAN language.
     If NL  = , NU = , and for some loop F = , T
= , S =  and  N is  the number  of the  equations in  the loop
, it has to be true that

  UP(NL/N) + UP(NU/N) < DOWN((T-F)/S)

where UP  represents the  rounding-off to  a higher  natural number, and
DOWN the rounding-off to a lower natural number. With regard to the fact
that, for  example, the last variable before the loop is not required to
equal the last variable  from  the  loop  system,  into  which  the loop
parameter equal  to F-S  is substituted,  when the  band matrix is being
constructed, from the FORTRAN loop that corresponds to the loop from the
specification   of   the   equation   system,  at  least  the  first  NL
variables-equations have to be moved to precede the FORTRAN loop, and at



                                        31






least the  last NU  variables-equations have  to be moved to follow this
loop in order that the correspondence  of the  system variables  in this
loop  with  the  system  variables  before  and  after this loop will be
secured. And this move requires  the  above  mentioned  condition  to be
fulfilled.   As, in  most cases, NL/N and NU/N are small with respect to
(T-F)/S, this condition does not represent any considerable constrain.
     The loop parameters , , and  can be natural numbers
or expressions that must have natural  values in the run of the  FORTRAN
program.


6.2 Choosing the numerical library
    ------------------------------

     The user can choose the routines of which numerical library will be
used in the generated FORTRAN  code.  The supported numerical  libraries
are:   LINPACK,  NAG,  IMSL  and  ESSL  (IBM  Engineering and Scientific
Subroutine Library) . The routines DGBFA, DGBSL (band solver) and  DGTSL
(tridiagonal solver)  are used  from the  LINPACK library,  the routines
F01LBF, F04LDF (band solver) and F01LEF, F04LEF (tridiagonal solver) are
used from  the NAG  library, the  routine LEQT1B  is used  from the IMSL
library  and  the  routines  DGBF,  DGBS  (band  solver)  and DGTF, DGTS
(tridiagonal solver)  are used  from the  ESSL library.   By default the
 LINPACK library  routines are  used. The  using of  other libraries  is
controlled by the switches NAG,IMSL and ESSL. All these switches are  by
default OFF. If the switch IMSL  is ON then the IMSL library  routine is
used. If  the switch  IMSL is  OFF and  the switch  NAG is  ON then  NAG
library routines are used. If the switches IMSL and NAG are OFF and  the
switch ESSL is ON then the  ESSL library is used. During generating  the
code using LINPACK, NAG or  ESSL libraries the special routines  are use
for systems with tridiagonal  matrices, because tridiagonal solvers  are
faster than the band matrix solvers.


6.3 Completion of the generated code
    --------------------------------

     The GENLINBANDSOL statement generates a block  of FORTRAN  code ( a
block of  statements of the FORTRAN language) that performs the solution
of the given system of linear algebraic equations. In order  to be used,
this  block  of  code  has  to  be  completed with some declarations and
statements, thus getting  a  certain  envelope  that  enables  it  to be
integrated into the main program.
     In order  to be able to work, the generated block of code has to be
preceded by:

  1. The declaration  of arrays as  described by the  comments generated
  into the FORTRAN code (near the calling of library routines)

  2. The assigning  the values to  the integer variables  describing the
  real  dimensions  of  used  arrays  (again  as  described in generated
  FORTRAN comments)

                                        32






  3. The filling of the variables that can occur in the loop parameters.

  4. The filling or declaration of all variables and arrays occurring in
  the system equations, except for the variables of the system of linear
  equations.

  5. The definition of subroutine ERROUT the call to which is  generated
  after some routines found that the matrix is algorithmically singular

     The  mentioned  envelope  for  the  generated  block can be created
manually, or directly using  the GENTRAN program package  for generating
numeric programs. The  LINBAND module itself  uses the GENTRAN  package,
and the  GENLINBANDSOL statement  can be  applied directly  in the input
files of the GENTRAN package (template processing). The GENTRAN  package
has to be loaded prior to loading of the LINBAND module.
     The  generated  block  of  FORTRAN  code  has to be linked with the
routines from chosen numerical library.







References
----------

[1] R. Liska:  Numerical Code Generation  for Finite Difference  Schemes
     Solving.   In  IMACS  World  Congress  on  Computation  and Applied
     Mathematics. Dublin, July 22-26, 1991, Dublin,(In press).























                                        33

mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide1.rlg0000644000175000017500000000007711526203062023115 0ustar  giovannigiovanni% Tests of fide1.

% There are none at the present time.

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide.tst0000644000175000017500000004764611526203062023077 0ustar  giovannigiovanni%***********************************************************************
%*****                                                             *****
%***** Package  F I D E - Test Examples Ver. 1.1.2 May 29,1995     *****
%*****                                                             *****
%***********************************************************************
%***********************************************************************
%*****                                                             *****
%*****    T e s t     Examples   ---   Module    E X P R E S       *****
%*****                                                             *****
%***********************************************************************

let cos th**2=1 - sin th**2,
    cos fi**2=1 - sin fi**2;
factor df;
on rat;
for all x,y let diff(x,y)=df(x,y);
depend u,r,th,fi;
depend v,r,th,fi;
depend f,r,th,fi;
depend w,r,th,fi;
% Spherical coordinate system
scalefactors 3,r*sin th*cos fi,r*sin th*sin fi,r*cos th,r,th,fi;
tensor a1,a2,a3,a4,a5;
vectors u,v;
dyads w;
a1:=grad f;
a2:=div u;
a3:=curl v;
a4:=lapl v;
a3:=2*a3+a4;
a5:=lapl f;
a1:=a1+div w;
a1:=u.dyad((a,0,1),(1,b,3),(0,c,d));
a2:=vect(a,b,c);
a1.a2;
%  Scalar product
u.v;
%  Vector product
u?v;
%  Dyadic
u&v;
%  Directional derivative
dirdf(u,v);
clear a1,a2,a3,a4,a5,u,v,w;
for all x,y clear diff(x,y);
clear cos th**2,
      cos fi**2;
remfac df;
off rat;
scalefactors 3,x,y,z,x,y,z;

%***********************************************************************
%*****                                                             *****
%*****      T e s t     Examples   ---   Module    I I M E T       *****
%*****                                                             *****
%***********************************************************************

% Example I.1 - 1-D Lagrangian Hydrodynamics

off exp;
factor diff;
on rat,eqfu;

% Declare which indexes will be given to coordinates
coordinates x,t into j,m;

% Declares uniform grid in x coordinate
grid uniform,x;

% Declares dependencies of functions on coordinates
dependence eta(t,x),v(t,x),eps(t,x),p(t,x);

% Declares p as known function
given p;

same eta,v,p;

iim a, eta,diff(eta,t)-eta*diff(v,x)=0,
    v,diff(v,t)+eta/ro*diff(p,x)=0,
    eps,diff(eps,t)+eta*p/ro*diff(v,x)=0;

clear a;
clearsame;
cleargiven;

%***********************************************************************

% Example  I.2 - How other functions (here sin, cos) can be used in
%                discretized terms

diffunc sin,cos;
difmatch all,diff(u*sin x,x),u=one,2,(u(i+1)*sin x(i+1)-u(i-1)
                   *sin x(i-1))/(dim1+dip1),
                 u=half,0,(u(i+1/2)*sin x(i+1/2)-u(i-1/2)*sin x(i-1/2))
                   /di;
difmatch all,cos x*diff(u,x,2),u=one,0,cos x i*(u(i+1)-2*u(i)+u(i-1))
                   /di^2,
                 u=half,3,(u(i+3/2)-u(i+1/2))/dip2/2 -
                          (u(i-1/2)-u(i-3/2))/dim2/2;
off exp;
coordinates x,t into j,m;
grid uniform,x,t;
dependence u(x,t),v(x,t);
iim a,u,diff(u,t)+diff(u,x)+cos x*diff(v,x,2)=0,
      v,diff(v,t)+diff(sin x*u,x)=0;
clear a;

%***********************************************************************

% Example I.3 - Schrodinger equation

factor diff;
coordinates t,x into m,j;
grid uniform,x,t;
dependence ur(x,t),ui(x,t);
same ui,ur;
iim a,ur,-diff(ui,t)+1/2*diff(ur,x,2)+(ur**2+ui**2)*ur=0,
       ui,diff(ur,t)+1/2*diff(ui,x,2)+(ur**2+ui**2)*ui=0;
clear a;
clearsame;

%***********************************************************************

% Example I.4 - Vector calculus in p.d.e. input
%               cooperation with expres module
%               2-D hydrodynamics

scalefactors 2,x,y,x,y;
vectors u;
off exp,twogrid;
on eqfu;
factor diff,ht,hx,hy;
coordinates x,y,t into j,i,m;
grid uniform,x,y,t;
dependence n(t,x,y),u(t,x,y),p(t,x,y);
iim a,n,diff(n,t)+u.grad n+n*div u=0,
     u,m*n*(diff(u,t)+u.grad u)+grad p=vect(0,0),
     p,3/2*(diff(p,t)+u.grad p)+5/2*p*div u=0;
clear a,u;

%***********************************************************************

% Example I.5 - 1-D hydrodynamics up to 3-rd moments (heat flow)

coordinates x,t into j,m;
grid uniform,x,t;
dependence n(x,t),u(x,t),tt(x,t),p(x,t),q(x,t);
iim a, n,diff(n,t)+u*diff(n,x)+diff(u,x)=0,
    u,n*m*(diff(u,t)+u*diff(u,x))+k*diff(n*tt,x)+diff(p,x)=0,
    tt,3/2*k*n*(diff(tt,t)+u*diff(tt,x))+n*k*tt*diff(u,x)+1/2*p
       *diff(u,x)+diff(q,x)=0,
    p,diff(p,t)+u*diff(p,x)+p*diff(u,x)+n*k*tt*diff(u,x)+2/5*diff(q,x)
       =0,
    q,diff(q,t)+u*diff(q,x)+q*diff(u,x)+5/2*n*k**2*tt/m*diff(tt,x)+n*k
       *tt*diff(p,x)-p*diff(p,x)=0;
clear a;

remfac diff,ht,hx,hy;
on exp;
off rat;

%***********************************************************************
%*****                                                             *****
%*****     T e s t     Examples   ---   Module    A P P R O X      *****
%*****                                                             *****
%***********************************************************************

% Example A.1

coordinates x,t into j,n;
maxorder t=2,x=3;
functions u,v;
approx( (u(n+1/2)-u(n-1/2))/ht=(v(n+1/2,j+1/2)-v(n+1/2,j-1/2)
                               +v(n-1/2,j+1/2)-v(n-1/2,j-1/2))/(2*hx) );

% Example A.2

maxorder t=3,x=3;
approx( (u(n+1)-u(n))/ht=(u(n+1,j+1/2)-u(n+1,j-1/2)
                               +u(n,j+1/2)-u(n,j-1/2))/(2*hx) );

% Example A.3

maxorder t=2,x=3;
center t=1/2;
approx( (u(n+1)-u(n))/ht=(v(n+1,j+1/2)-v(n+1,j-1/2)
                               +v(n,j+1/2)-v(n,j-1/2))/(2*hx) );

% Example A.4

approx( u(n+1)/ht=(v(n+1,j+1/2)-v(n+1,j-1/2)
                               +v(n,j+1/2)-v(n,j-1/2))/(2*hx) );

% Example A.5

maxorder t=3,x=3;
approx( (u(n+1)-u(n))/ht=(u(n+1,j+1/2)-u(n+1,j-1/2))/hx);

% Example A.6

approx( (u(n+1)-u(n))/ht=(u(n+1/2,j+1/2)-u(n+1/2,j-1/2))/hx);

% Example A.7;

maxorder x=4;
approx((u(n+1)-u(n))/ht=(u(n+1/2,j+1)-2*u(n+1/2,j)+u(n+1/2,j-1))/hx**2);

%***********************************************************************
%*****                                                             *****
%*****     T e s t     Examples   ---   Module    C H A R P O L    *****
%*****                                                             *****
%***********************************************************************

% Example C.1

coordinates t,x into i,j;
grid uniform,t,x;
let cos ax**2=1-sin ax**2;
unfunc u,v;
matrix aa(1,2),bb(2,2);
aa(1,1):=(u(i+1)-u(i))/ht+(v(j+1)-v(j))/hx$
aa(1,2):=(v(i+1)-v(i))/ht+(u(j+1/2)-u(j-1/2))/hx$
bb:=ampmat aa;
bb:=denotemat bb;
factor lam;
pol:=charpol bb;
prdenot;
cleardenot;
clear aa,bb,pol;

%***********************************************************************

% Example C.2 : Reprint Vorozcov, Ganza, Mazurik: Simvolno-cislennyj
%               interfejs.  v zadacach ..., Novosibirsk 1986,  p.47.

unfunc u;
matrix aa(1,1),bb(1,1);
aa(1,1):=(u(i+1)-u(i))/ht+a*(u(j)-u(j-1))/hx$
bb:=ampmat aa;
bb:=denotemat bb;
pol:=charpol bb;
prdenot;
cleardenot;
clear aa,bb,pol;

%***********************************************************************

% Example C.3 : Reprint Vorozcov, Ganza, Mazurik: Simvolno-cislennyj
%               interfejs.  v zadacach ..., Novosibirsk 1986,  p.52.

coordinates t,x into m,j;
unfunc u,r;
matrix aa(1,2),bb(2,2);
aa(1,1):=(r(m+1)-r(m))/ht+u0*(r(m+1,j+1)-r(m+1,j-1))/2/hx
                         +r0*(u(m+1,j+1)-u(m+1,j-1))/2/hx$
aa(1,2):=(u(m+1)-u(m))/ht+u0*(u(m+1,j+1)-u(m+1,j-1))/2/hx
                         +c0**2/r0*(r(m,j+1)-u(m,j-1))/2/hx$
bb:=ampmat aa;
bb:=denotemat bb;
pol:=charpol bb;
prdenot;
cleardenot;
clear aa,bb,pol;

%***********************************************************************

% Example C.4 : Richtmyer, Morton: Difference methods for initial value
%               problems, &10.3.  p.262

coordinates t,x into n,j;
unfunc v,w;
matrix aa(1,2),bb(2,2);
aa(1,1):=(v(n+1)-v(n))/ht-c*(w(j+1/2)-w(j-1/2)+
                             w(n+1,j+1/2)-w(n+1,j-1/2))/(2*hx)$
aa(1,2):=(w(n+1,j-1/2)-w(n,j-1/2))/ht-c*(v(n+1,j)-v(n+1,j-1)+
                                         v(j)-v(j-1))/(2*hx)$
bb:=ampmat aa;
bb:=denotemat bb;
pol:=charpol bb;
prdenot;
cleardenot;
clear aa,bb,pol;

%***********************************************************************

% Example C.5: Mazurik: Algoritmy resenia zadaci..., Preprint no.24-85,
%               AN USSR SO, Inst. teor. i prikl. mechaniky, p.34

coordinates t,x,y into n,m,k;
grid uniform,t,x,y;
unfunc u1,u2,u3;
matrix aa(1,3),bb(3,3);
aa(1,1):=(u1(n+1)-u1(n))/ht+c/2*((-u1(m-1)+2*u1(m)-u1(m+1))/hx +
         (u2(m+1)-u2(m-1))/hx - (u1(k-1)-2*u1(k)+u1(k+1))/hy +
         (u3(k+1)-u3(k-1))/hy)$
aa(1,2):=(u2(n+1)-u2(n))/ht+c/2*((u1(m+1)-u1(m-1))/hx -
         (u2(m-1)-2*u2(m)+u2(m+1))/hx)$
aa(1,3):=(u3(n+1)-u3(n))/ht + c/2*((u1(k+1)-u1(k-1))/hy -
         (u3(k-1)-2*u3(k)+u3(k+1))/hy)$
off prfourmat;
bb:=ampmat aa;
pol:=charpol bb;
let
  cos ax=cos ax2**2-sin ax2**2,
  cos ay=cos ay2**2-sin ay2**2,
  sin ax=2*sin ax2*cos ax2,
  sin ay=2*sin ay2*cos ay2,
  cos ax2**2=1-sin ax2**2,
  cos ay2**2=1-sin ay2**2,
  sin ax2=s1,
  sin ay2=s2,
  hx=c*ht/cap1,
  hy=c*ht/cap2;
order s1,s2;
pol:=pol;
clear cos ax,cos ay,sin ax,sin ay,cos ax2**2,cos ay2**2,sin ax2,sin ay2,
      hx,hy;
pol:=complexpol pol;
pol1:=hurw pol;
denotid cp;
pol:=denotepol pol;
prdenot;
cleardenot;
clear aa,bb,pol,pol1;

%***********************************************************************

% Example C.6 : Lax-Wendrov (V. Ganzha)

coordinates t,x,y into n,m,k;
grid uniform,t,x,y;
let cos ax**2=1-sin ax**2,
    cos ay**2=1-sin ay**2;
unfunc u1,u2,u3,u4;
matrix aa(1,4),bb(4,4);
aa(1,1):=4*(u1(n+1)-u1(n))/ht+
         (w*(u1(m+2)-u1(m-2)+u1(m+1,k+1)+u1(m+1,k-1)-
         u1(m-1,k+1)-u1(m-1,k-1))+p*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+
         v*(u1(m+1,k+1)+u1(m-1,k+1)-
         u1(m+1,k-1)-u1(m-1,k-1)+u1(k+2)-u1(k-2))+p*(u3(m+1,k+1)+
         u3(m-1,k+1)-u3(m+1,k-1)-u3(m-1,k-1)+u3(k+2)-u3(k-2)))/hx+ht*
         (2*w**2*(-u1(m+2)+2*u1(m)-u1(m-2))+4*w*p*(-u2(m+2)+2*u2(m)-
         u2(m-2))+2*(-u4(m+2)+2*u4(m)-u4(m-2))+2*v**2*(-u1(k+2)+
         2*u1(k)-u1(k-2))+4*v*p*(u3(k+2)+2*u3(k)-u3(k-2))+2*(-u4(k+2)+
         2*u4(k)-u4(k-2))+4*w*v*(-u1(m+1,k+1)+u1(m+1,k-1)+u1(m-1,k+1)-
         u1(m-1,k-1))+4*p*v*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+4*w*p*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)-
         u3(m-1,k-1)))/hx/hx$
aa(1,2):=4*p*(u2(n+1)-u2(n))/ht+
       (w*p*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+u4(m+2)-u4(m-2)+
         u4(m+1,k+1)+
         u4(m+1,k-1)-u4(m-1,k+1)-u4(m-1,k-1)+
         p*v*(u2(m+1,k+1)+u2(m-1,k+1)+
         u2(k+2)-u2(k-2)-u2(m+1,k-1)-u2(m-1,k-1)))/hx+ht*(2*w**2*p*
         (-u2(m+2)+2*u2(m)-u2(m-2))+2*p*c**2*(-u2(m+2)+2*u2(m)-u2(m-2))
         +4*w*(-u4(m+2)+2*u4(m)-u4(m-2))+2*p*v**2*(-u2(k+2)+2*u2(k)-
         u2(k-2))+4*w*p*v*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+2*p*c**2*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)
         -u3(m-1,k-1))+4*v*(-u4(m+1,k+1)+u4(m+1,k-1)+u4(m-1,k+1)-
         u4(m-1,k-1)))/hx/hx$
aa(1,3):=4*p*(u3(n+1)-u3(n))/ht+(w*p*(u3(m+2)-u3(m-2)+u3(m+1,k+1)+
         u3(m+1,k-1)-u3(m-1,k+1)-u3(m-1,k-1))+u4(k+2)-u4(k-2)+
         u4(m+1,k+1)-u4(m+1,k-1)+u4(m-1,k+1)-u4(m-1,k-1)+
         p*v*(u3(m+1,k+1)+u3(m-1,k+1)+u3(k+2)-u3(k-2)-u3(m+1,k-1)-
         u3(m-1,k-1)))/hx+ht*(2*w**2*p*(-u3(m+2)+2*u3(m)-u3(m-2))+
         2*p*c**2*(-u3(k+2)+2*u3(k)-u3(k-2))+4*v*(-u4(k+2)+
         2*u4(k)-u4(k-2))+2*p*v**2*(-u3(k+2)+2*u3(k)-u3(k-2))+
         4*w*p*v*(-u3(m+1,k+1)+u3(m+1,k-1)+u3(m-1,k+1)-
         u3(m-1,k-1))+2*p*c**2*(-u2(m+1,k+1)+u2(m+1,k-1)+
         u2(m-1,k+1)-u2(m-1,k-1))+4*w*(u4(m+1,k+1)+u4(m+1,k-1)+
         u4(m-1,k+1)-u4(m-1,k-1)))/hx/hx$
aa(1,4):=4*(u4(n+1)-u4(n))/ht+(p*c**2*(u2(m+2)-u2(m-2)+u2(m+1,k+1)+
         u2(m+1,k-1)-u2(m-1,k+1)-u2(m-1,k-1))+w*(u4(m+2)-
         u4(m-2)+u4(m+1,k+1)+u4(m+1,k-1)-u4(m-1,k+1)-u4(m-1,k-1))+
         +p*c**2*(u3(m+1,k+1)+u3(m-1,k+1)-u3(m+1,k-1)-
         u3(m-1,k-1)+u3(k+2)-u3(k-2))+v*(u4(m+1,k+1)+u4(m-1,k+1)-
         u4(m+1,k-1)-u4(m-1,k-1)+u4(k+2)-u4(k-2)))/hx+ht*
         (2*w**2*(-u4(m+2)+2*u4(m)-u4(m-2))+4*w*p*c**2*(-u2(m+2)+
         2*u2(m)-u2(m-2))+2*c**2*(-u4(m+2)+2*u4(m)-u4(m-2))+
         4*p*v*c**2*(-u3(k+2)+2*u3(k)-u3(k-2))+2*c**2*(-u4(k+2)+
         2*u4(k)-u4(k-2))+2*v**2*(-u4(k+2)+2*u4(k)-u4(k-2))+
         4*p*v*c**2*(-u2(m+1,k+1)+u2(m+1,k-1)+u2(m-1,k+1)-
         u2(m-1,k-1))+4*w*p*c**2*(-u3(m+1,k+1)+u3(m+1,k-1)+
         u3(m-1,k+1)-u3(m-1,k-1))+4*w*v*(-u4(m+1,k+1)+
         u4(m+1,k-1)+u4(m-1,k+1)-u4(m-1,k-1)))/hx/hx$
bb:=ampmat aa;
let
  sin(ax)=s1,
  cos(ax)=c1,
  sin(ay)=s2,
  cos(ay)=c2,
  w=k1*hx/ht,
  v=k2*hx/ht,
  c=k3*hx/ht,
  ht=r1*hx;
denotid a;
bb:=denotemat bb;
clear sin ax,cos ax,sin ay,cos ay,w,v,c,ht;
pol:=charpol bb;
denotid cp;
pol:=denotepol pol;
pol:=complexpol pol;
denotid rp;
pol:=denotepol pol;
prdenot;
cleardenot;
clear aa,bb,pol;

%***********************************************************************
%*****                                                             *****
%*****      T e s t     Examples   ---   Module    H U R W P       *****
%*****                                                             *****
%***********************************************************************

% Example H.1

x0:=lam-1;
x1:=lam-(ar+i*ai);
x2:=lam-(br+i*bi);
x3:=lam-(cr+i*ci);
hurwitzp x1;

% Example H.2

x:=hurw(x0*x1);
hurwitzp x;

% Example H.3

x:=(x1*x2);
hurwitzp x;

% Example H.4

x:=(x1*x2*x3);
hurwitzp x;
clear x,x0,x1,x2,x3;

%***********************************************************************
%*****                                                             *****
%*****    T e s t     Examples   ---   Module    L I N B A N D     *****
%*****                                                             *****
%***********************************************************************

on evallhseqp;  % So both sides of equations evaluate.

% Example L.1

operator v;
off echo;
gentran
<> >>$
off period;
gentran
<>$
on period;
genlinbandsol(1,1,{{u(1),u(1)=v(1)},{do,{k,2,100,1 },{u(k),u(k+1)-
   2*u(k)+u(k-1)=v(k+1)-2*v(k)+v(k-1)}},{u(101),u(101)=v(101)}})$
gentran
  <>$
    literal tab!*,"write(*,100)amer,arer",cr!*$
    literal tab!*,"stop",cr!*$
    literal "100     format(' max. abs. error = ',e12.2,",
            "' max. rel. error = ',e12.2)",cr!*$
    literal tab!*,"end",cr!* >>$
on echo;

%***********************************************************************

% Example L.2

on nag;
off echo;
gentran
<> >>$
off period;
gentran
<>$
on period;
genlinbandsol(1,1,{{u(1),u(1)=v(1)},{do,{k,2,100,1 },{u(k),u(k+1)-
   2*u(k)+u(k-1)=v(k+1)-2*v(k)+v(k-1)}},{u(101),u(101)=v(101)}})$
gentran
  <>$
    literal tab!*,"write(*,100)amer,arer",cr!*$
    literal tab!*,"stop",cr!*$
    literal "100     format(' max. abs. error = ',e12.2,",
            "' max. rel. error = ',e12.2)",cr!*$
    literal tab!*,"end",cr!* >>$
on echo;

%***********************************************************************

% Example L.3

on imsl;
off echo,nag;
gentran
<> >>$
off period;
gentran
<>$
on period;
genlinbandsol(1,1,{{u(1),u(1)=v(1)},{do,{k,2,100,1 },{u(k),u(k+1)-
   2*u(k)+u(k-1)=v(k+1)-2*v(k)+v(k-1)}},{u(101),u(101)=v(101)}})$
gentran
  <>$
    literal tab!*,"write(*,100)amer,arer",cr!*$
    literal tab!*,"stop",cr!*$
    literal "100     format(' max. abs. error = ',e12.2,",
            "' max. rel. error = ',e12.2)",cr!*$
    literal tab!*,"end",cr!* >>$
on echo;

%***********************************************************************

% Example L.4

on essl;
off echo,imsl;
gentran
<> >>$
off period;
gentran
<>$
on period;
genlinbandsol(1,1,{{u(1),u(1)=v(1)},{do,{k,2,100,1 },{u(k),u(k+1)-
   2*u(k)+u(k-1)=v(k+1)-2*v(k)+v(k-1)}},{u(101),u(101)=v(101)}})$
gentran
  <>$
    literal tab!*,"write(*,100)amer,arer",cr!*$
    literal tab!*,"stop",cr!*$
    literal "100     format(' max. abs. error = ',e12.2,",
            "' max. rel. error = ',e12.2)",cr!*$
    literal tab!*,"end",cr!* >>$
on echo;
off essl;

%***********************************************************************
%*****                                                             *****
%*****      T e s t     Complex Examples   ---   More Modules      *****
%*****                                                             *****
%***********************************************************************

% Example M.1

off exp;
coordinates t,x into n,j;
grid uniform,x,t;
dependence v(t,x),w(t,x);
isgrid v(x..one),w(x..half);
iim aa, v, diff(v,t)=c*diff(w,x),
        w, diff(w,t)=c*diff(v,x);
on exp;
center t=1/2;
functions v,w;
approx( aa(0,0)=aa(0,1));
center x=1/2;
approx( aa(1,0)=aa(1,1));
let cos ax**2=1-sin ax**2;
unfunc v,w;
matrix a(1,2),b(2,2),bt(2,2);
a(1,1):=aa(0,0);
a(1,2):=aa(1,0);
off prfourmat;
b:=ampmat a;
clear a,aa;
factor lam;
pol:=charpol b;
pol:=troot1 pol;
pol:=hurw num pol;
hurwitzp pol;
bt:=tcon b;
bt*b;
bt*b-b*bt;
clear aa,a,b,bt;

%***********************************************************************

% Example M.2 : Richtmyer, Morton: Difference methods for initial value
%               problems, &10.2.  p.261

coordinates t,x into n,j;
grid uniform,t,x;
let cos ax**2=1-sin ax**2;
unfunc v,w;
matrix a(1,2),b(2,2),bt(2,2);
a(1,1):=(v(n+1)-v(n))/ht-c*(w(j+1/2)-w(j-1/2))/hx$
a(1,2):=(w(n+1,j-1/2)-w(n,j-1/2))/ht-c*(v(n+1,j)-v(n+1,j-1))/hx$
off prfourmat;
b:=ampmat a;
clear a;
factor lam;
pol:=charpol b;
pol:=hurw num pol;
hurwitzp pol;
bt:=tcon b;
bt*b;
bt*b-b*bt;
clear a,b,bt;

%***********************************************************************

% Example M.3: Mazurik: Algoritmy resenia zadaci..., preprint no.24-85,
%               AN USSR SO, Inst. teor. i prikl. mechaniky, p.34

operator v1,v2;
matrix a(1,3),b(3,3),bt(3,3);
a(1,1):=(p(n+1)-p(n))/ht+c/2*((-p(m-1)+2*p(m)-p(m+1))/hx +
         (v1(m+1)-v1(m-1))/hx - (p(k-1)-2*p(k)+p(k+1))/hy +
         (v2(k+1)-v2(k-1))/hy)$
a(1,2):=(v1(n+1)-v1(n))/ht+c/2*((p(m+1)-p(m-1))/hx -
         (v1(m-1)-2*v1(m)+v1(m+1))/hx)$
a(1,3):=(v2(n+1)-v2(n))/ht + c/2*((p(k+1)-p(k-1))/hy -
         (v2(k-1)-2*v2(k)+v2(k+1))/hy)$
coordinates t,x,y into n,m,k;
functions p,v1,v2;
for k:=1:3 do approx(a(1,k)=0);
grid uniform,t,x,y;
unfunc p,v1,v2;
hy:=hx;
off prfourmat;
b:=ampmat a;
pol:=charpol b;
let
  cos ax=cos ax2**2-sin ax2**2,
  cos ay=cos ay2**2-sin ay2**2,
  sin ax=2*sin ax2*cos ax2,
  sin ay=2*sin ay2*cos ay2,
  cos ax2**2=1-sin ax2**2,
  cos ay2**2=1-sin ay2**2,
  sin ax2=s1,
  sin ay2=s2,
  hx=c*ht/cap;
factor lam;
order s1,s2;
pol:=troot1 pol;
clear cos ax,cos ay,sin ax,sin ay,cos ax2**2,cos ay2**2,sin ax2,sin ay2,
      hx,hy;
pol:=hurw num pol;
hurwitzp pol;
bt:=tcon b;
bt*b;
bt*b-b*bt;
clear a,b,bt,pol;

%***********************************************************************

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/fide/fide.hlp0000644000175000017500000001016011526203062023025 0ustar  giovannigiovanni\chapter[FIDE: Finite differences for PDEs]%
        {FIDE: Finite difference method for partial differential equations}
\label{FIDE}
\typeout{[FIDE: Finite differences for PDEs]}

{\footnotesize
\begin{center}
Richard Liska \\
Faculty of Nuclear Science and Physical Engineering \\
Technical University of Prague \\
Brehova 7, 115 19 Prague 1, Czech Republic \\[0.05in]
e--mail: tjerl@aci.cvut.cz
\end{center}
}

\ttindex{FIDE}

The FIDE package performs automation of the process of numerical
solving partial differential equations systems (PDES) by generating
finite difference methods.  In the process one can find several stages
in which computer algebra can be used for performing routine
analytical calculations, namely: transforming differential equations
into different coordinate systems, discretisation of differential
equations, analysis of difference schemes and generation of numerical
programs.  The FIDE package consists of the following modules:

\begin{description}
\item[EXPRES]  for transforming PDES into any orthogonal coordinate system.
\item[IIMET]   for discretisation of PDES by integro-interpolation method.
\item[APPROX]  for determining the order of approximation of
difference scheme.
\item[CHARPOL] for calculation of amplification matrix and
characteristic polynomial of difference scheme, which are needed in
Fourier stability analysis.\
\item[HURWP] for polynomial roots locating necessary in verifying the
von Neumann stability condition.
\item[LINBAND] for generating the block of FORTRAN code, which solves
a system of linear algebraic equations with band matrix appearing
quite often in difference schemes.
\end{description}

For more details on this package are given in the FIDE documentation,
and in the examples.  A flavour of its capabilities can be seen from
the following simple example.

\begin{verbatim}
off exp;

factor diff;

on rat,eqfu;

% Declare which indexes will be given to coordinates
coordinates x,t into j,m;

% Declares uniform grid in x coordinate
grid uniform,x;

% Declares dependencies of functions on coordinates
dependence eta(t,x),v(t,x),eps(t,x),p(t,x);

% Declares p as known function
given p;

same eta,v,p;

iim a, eta,diff(eta,t)-eta*diff(v,x)=0,
    v,diff(v,t)+eta/ro*diff(p,x)=0,
    eps,diff(eps,t)+eta*p/ro*diff(v,x)=0;


*****************************
*****      Program      *****          IIMET Ver 1.1.2
*****************************

      Partial Differential Equations
      ==============================

diff(eta,t) - diff(v,x)*eta    =    0

 diff(p,x)*eta
--------------- + diff(v,t)    =    0
      ro

               diff(v,x)*eta*p
diff(eps,t) + -----------------    =    0
                     ro


 Backtracking needed in grid optimalization
0 interpolations are needed in x coordinate
  Equation for eta variable is integrated in half grid point
  Equation for v variable is integrated in half grid point
  Equation for eps variable is integrated in half grid point
0 interpolations are needed in t coordinate
  Equation for eta variable is integrated in half grid point
  Equation for v variable is integrated in half grid point
  Equation for eps variable is integrated in half grid point

         Equations after Discretization Using IIM :
         ==========================================

(4*(eta(j,m + 1) - eta(j,m) - eta(j + 1,m)

     + eta(j + 1,m + 1))*hx - (

    (eta(j + 1,m + 1) + eta(j,m + 1))

    *(v(j + 1,m + 1) - v(j,m + 1))

     + (eta(j + 1,m) + eta(j,m))*(v(j + 1,m) - v(j,m)))

 *(ht(m + 1) + ht(m)))/(4*(ht(m + 1) + ht(m))*hx)   =   0


(4*(v(j,m + 1) - v(j,m) - v(j + 1,m) + v(j + 1,m + 1))*hx*ro

  + ((eta(j + 1,m + 1) + eta(j,m + 1))

     *(p(j + 1,m + 1) - p(j,m + 1))

      + (eta(j + 1,m) + eta(j,m))*(p(j + 1,m) - p(j,m)))

 *(ht(m + 1) + ht(m)))/(4*(ht(m + 1) + ht(m))*hx*ro)   =   0


(4*(eps(j,m + 1) - eps(j,m) - eps(j + 1,m)

     + eps(j + 1,m + 1))*hx*ro + ((

       eta(j + 1,m + 1)*p(j + 1,m + 1)

        + eta(j,m + 1)*p(j,m + 1))

    *(v(j + 1,m + 1) - v(j,m + 1)) +

    (eta(j + 1,m)*p(j + 1,m) + eta(j,m)*p(j,m))

    *(v(j + 1,m) - v(j,m)))*(ht(m + 1) + ht(m)))/(4

   *(ht(m + 1) + ht(m))*hx*ro)   =   0


clear a;

clearsame;

cleargiven;
\end{verbatim}

mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/0000755000175000017500000000000011722677357021637 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/arith/crelem.red0000644000175000017500000002130411526203062023556 0ustar  giovannigiovannimodule crelem; % Complex elementary functions for complex rounded.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


imports !*rd2cr, bflessp, bfminusp, cr!:differ, cr!:minus, cr!:plus,
        cr!:quotient, cr!:times, cr!:zerop, cr2i!*, crhalf!*, cri!*,
        cri!/2, crprcd, crrl, deg2rad!*, gf2cr!:, gfsqrt, i2cr!*,
        i2rd!*, mkcr, rad2deg!*, rd!:minus, rd!:quotient, rd!:times,
        rdatan2!*, rdatan2d!*, rdcos!*, rdcosd!*, rdcosh!*, rde!*,
        rdexp!*, rdhalf!*, rdhypot!*, rdlog!*, rdone!*, rdpi!*,
        rdsin!*, rdsind!*, rdsinh!*, rdtwo!*, rdzero!*, retag,
        round!*, tagim, tagrl;

fluid '(!*!*roundbf);

global '(!!flprec !!rdprec bfz!* bftwo!* bfone!* bfhalf!*);

deflist('((expt crexpt!*) (sin crsin!*) (cos crcos!*) (tan crtan!*)
          (asin crasin!*) (acos cracos!*) (atan cratan!*)
          (cot crcot!*) (acot cracot!*) (sec crsec!*) (asec crasec!*)
          (csc crcsc!*) (acsc cracsc!*) (sinh crsinh!*) (cosh crcosh!*)
          (asinh crasinh!*) (acosh cracosh!*) (tanh crtanh!*)
          (coth crcoth!*) (atanh cratanh!*) (acoth cracoth!*)
          (sech crsech!*) (csch crcsch!*) (asech crasech!*)
          (acsch cracsch!*) (atan2 cratan2!*) (arg crarg!*)
          (sqrt crsqrt!*) (norm crnorm!*) (arg crarg!*) (log crlog!*)
          (exp crexp!*) (logb crlogb!*) (e cre!*) (pi crpi!*)),'!:cr!:);

% deflist('((sind crsind!*) (cosd crcosd!*) (tand crtand!*)
%           (asind crasind!*) (acosd cracosd!*) (atand cratand!*)
%           (cotd crcotd!*) (acotd cracotd!*) (secd crsecd!*)
%           (cscd crcscd!*) (acscd cracscd!*)
%           (asecd crasecd!*) (argd crargd!*)),'!:cr!:);

symbolic procedure cre!*; mkcr(rde!*(),rdzero!*());

symbolic procedure crpi!*; mkcr(rdpi!*(),rdzero!*());

symbolic procedure crexpt!*(u,v);
   if cr!:zerop(cr!:differ(v,crhalf!*())) then crsqrt!* u
   else crexp!* cr!:times(v,crlog!* u);

symbolic procedure crnorm!* u; rdhypot!*(tagrl u,tagim u);

symbolic procedure crarg!* u; rdatan2!*(tagim u,tagrl u);

% symbolic procedure crargd!* u; rdatan2d!*(tagim u,tagrl u);

symbolic procedure crsqrt!* u; gf2cr!: gfsqrt crprcd u;

symbolic procedure crr2d!* u; mkcr(rad2deg!* tagrl u,rad2deg!* tagim u);

symbolic procedure crd2r!* u; mkcr(deg2rad!* tagrl u,deg2rad!* tagim u);

symbolic procedure crsin!* u;
   mkcr(rd!:times(rdsin!* rl,rdcosh!* im),
        rd!:times(rdcos!* rl,rdsinh!* im))
    where rl=tagrl u,im=tagim u;

% symbolic procedure crsind!* u;
%    mkcr(rd!:times(rdsind!* rl,rdcosh!* deg2rad!* im),
%         rd!:times(rdcos!* rl,rdsinh!* deg2rad!* im))
%     where rl=tagrl u,im=tagim u;

symbolic procedure crcos!* u;
   mkcr(rd!:times(rdcos!* rl,rdcosh!* im),
        rd!:minus rd!:times(rdsin!* rl,rdsinh!* im))
    where rl=tagrl u,im=tagim u;

% symbolic procedure crcosd!* u;
%    mkcr(rd!:times(rdcosd!* rl,rdcosh!* deg2rad!* im),
%         rd!:minus rd!:times(rdsind!* rl,rdsinh!* deg2rad!* im))
%     where rl=tagrl u,im=tagim u;

symbolic procedure crtan!* u;
   cr!:times(cri!*(),cr!:quotient(cr!:differ(y,x),cr!:plus(y,x)))
   where x=crexp!*(cr!:times(cr2i!*(),u)),y=i2cr!* 1;

% symbolic procedure crtand!* u;
%    cr!:times(cri!*(),cr!:quotient(cr!:differ(y,x),cr!:plus(y,x)))
%    where x=crexp!*(cr!:times(cr2i!*(),crd2r!* u)),y=i2cr!* 1;

symbolic procedure crcot!* u;
   cr!:times(cri!*(),cr!:quotient(cr!:plus(x,y),cr!:differ(x,y)))
   where x=crexp!*(cr!:times(cr2i!*(),u)),y=i2cr!* 1;

% symbolic procedure crcotd!* u;
%    cr!:times(cri!*(),cr!:quotient(cr!:plus(x,y),cr!:differ(x,y)))
%    where x=crexp!*(cr!:times(cr2i!*(),crd2r!* u)),y=i2cr!* 1;

symbolic procedure cratan2!*(y,x);
    begin scalar q,p;
       q := crsqrt!* cr!:plus(cr!:times(y,y),cr!:times(x,x));
      if cr!:zerop q then error(0,list("invalid arguments to ",'atan2));
       y := cr!:quotient(y,q); x := cr!:quotient(x,q); p := rdpi!*();
       if cr!:zerop x then
          <>;
       q := cratan!* cr!:quotient(y,x);
       if bfminusp retag crrl x then
          <
    >;
          %  bfzp x is probably impossible?
       return q end;

symbolic procedure crlog!* u;
   mkcr(rdlog!* crnorm!* u,crarg!* u);

symbolic procedure crlogb!*(u,b); cr!:quotient(crlog!* u,crlog!* b);

symbolic procedure timesi!* u; cr!:times(cri!*(),u);

symbolic procedure crasin!* u; cr!:minus timesi!* crasinh!* timesi!* u;

% symbolic procedure crasind!* u;
%    crr2d!* cr!:minus timesi!* crasinh!* timesi!* u;

symbolic procedure cracos!* u;
   cr!:plus(cr!:times(crhalf!*(),crpi!*()),
      timesi!* crasinh!* timesi!* u);

% symbolic procedure cracosd!* u;
%    crr2d!* cr!:plus(cr!:times(crhalf!*(),crpi!*()),
%       timesi!* crasinh!* timesi!* u);

symbolic procedure cratan!* u;
   cr!:times(cri!/2(),crlog!* cr!:quotient(
      cr!:plus(cri!*(),u),cr!:differ(cri!*(),u)));

% symbolic procedure cratand!* u;
%    crr2d!* cr!:times(cri!/2(),crlog!* cr!:quotient(
%       cr!:plus(cri!*(),u),cr!:differ(cri!*(),u)));

symbolic procedure cracot!* u;
   cr!:times(cri!/2(),crlog!* cr!:quotient(
      cr!:differ(u,cri!*()),cr!:plus(cri!*(),u)));

% symbolic procedure cracotd!* u;
%    crr2d!* cr!:times(cri!/2(),crlog!* cr!:quotient(
%       cr!:differ(u,cri!*()),cr!:plus(cri!*(),u)));

symbolic procedure crsec!* u; cr!:quotient(i2cr!* 1,crcos!* u);

% symbolic procedure crsecd!* u;
%    cr!:quotient(i2cr!* 1,crcos!* crd2r!* u);

symbolic procedure crcsc!* u; cr!:quotient(i2cr!* 1,crsin!* u);

% symbolic procedure crcscd!* u;
%   cr!:quotient(i2cr!* 1,crsin!* crd2r!* u);

symbolic procedure crasec!* u; cracos!* cr!:quotient(i2cr!* 1,u);

% symbolic procedure crasecd!* u;
%   crr2d!* cracos!* cr!:quotient(i2cr!* 1,u);

symbolic procedure cracsc!* u; crasin!* cr!:quotient(i2cr!* 1,u);

% symbolic procedure cracscd!* u;
%   crr2d!* crasin!* cr!:quotient(i2cr!* 1,u);

symbolic procedure crsinh!* u;
   cr!:times(crhalf!*(),cr!:differ(y,cr!:quotient(i2cr!* 1,y)))
   where y=crexp!* u;

symbolic procedure crcosh!* u;
   cr!:times(crhalf!*(),cr!:plus(y,cr!:quotient(i2cr!* 1,y)))
   where y=crexp!* u;

symbolic procedure crtanh!* u;
   cr!:quotient(cr!:differ(x,y),cr!:plus(x,y))
   where x=crexp!*(cr!:times(i2cr!* 2,u)),y=i2cr!* 1;

symbolic procedure crcoth!* u;
   cr!:quotient(cr!:plus(x,y),cr!:differ(x,y))
   where x=crexp!*(cr!:times(i2cr!* 2,u)),y=i2cr!* 1;

symbolic procedure crsech!* u;
   cr!:quotient(i2cr!* 2,cr!:plus(y,cr!:quotient(i2cr!* 1,y)))
   where y=crexp!* u;

symbolic procedure crcsch!* u;
   cr!:quotient(i2cr!* 2,cr!:differ(y,cr!:quotient(i2cr!* 1,y)))
   where y=crexp!* u;

symbolic procedure crasinh!* u;
   crlog!* cr!:plus(u,
      if bflessp(round!* crnorm!* u,rdtwo!*())
         then crsqrt!* cr!:plus(i2cr!* 1,s)
         else cr!:times(u,
            crsqrt!* cr!:plus(i2cr!* 1,cr!:quotient(i2cr!* 1,s))))
   where s=cr!:times(u,u);

symbolic procedure cracosh!* u;
   crlog!* cr!:plus(u,crsqrt!* cr!:differ(cr!:times(u,u),i2cr!* 1));

symbolic procedure cratanh!* u;
   cr!:times(crhalf!*(),crlog!* cr!:quotient(cr!:plus(i2cr!* 1,u),
      cr!:differ(i2cr!* 1,u)));

symbolic procedure cracoth!* u;
   cr!:times(crhalf!*(),crlog!* cr!:quotient(cr!:plus(i2cr!* 1,u),
      cr!:differ(u,i2cr!* 1)));

symbolic procedure crasech!* u; cracosh!* cr!:quotient(i2cr!* 1,u);

symbolic procedure cracsch!* u; crasinh!* cr!:quotient(i2cr!* 1,u);

symbolic procedure crexp!* u;
   <>
   where r=rdexp!* tagrl u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/math.red0000644000175000017500000007441611526203062023254 0ustar  giovannigiovannimodule math;  % Mathematical Package for REDUCE.

% Author: Stanley L. Kameny ,
% and Arthur C. Norman.

% Modifications by: John Abbott.

% Version and Date:  Mod 1.63, 23 June 1993.

% Copyright (c) 1987, 1988, 1989, 1990, 1991, 1993 Stanley L. Kameny.
% All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*******************************************************************
%**                                                               **
%**  This math package will compute the floating point values of  **
%**  the usual elementary functions, namely:                      **
%**     sin     asin     sind    asind     sinh    asinh          **
%**     cos     acos     cosd    acosd     cosh    acosh          **
%**     tan     atan     tand    atand     tanh    atanh          **
%**     cot     acot     cotd    acotd     coth    acoth          **
%**     sec     asec     secd    asecd     sech    asech          **
%**     csc     acsc     cscd    acscd     csch    acsch          **
%**             atan2            atan2d                           **
%**     exp     ln       sqrt    factorial                        **
%**     expt    log      cbrt                                     **
%**     logb    hypot                                             **
%**     log10   floor                                             **
%**             ceiling                                           **
%**             round                                             **
%**                                                               **
%**  All functions are computed to the accuracy of the floating-  **
%**  point precision of the system set up at the time.            **
%**                                                               **
%*******************************************************************

% Revisions:

%     1 May 93  expt improved; fix2 eliminated (not needed).
%    15 Sep 92  expt, hypot, log improved. factorial added.
%    25 May 91  atan2d added.  Function list updated.
%     6 Feb 90  exp, expt, and hyperbolic functions improved.
%     6 Nov 90  find!!nfpd improved; fl2int eliminated (now in bfauxil.)
%    31 Mar 90  fl2int speeded up for very large argument.
%    25 Feb 90  expt modified.
%    15 Oct 89  atan2 and sind,asind family added.
%     8 Oct 89  !!scalsintan,sqrt,expt,and hyperbolics modified.
%     8 Oct 89  hypot,floor,ceiling,round added
%    26 Aug 89  zerop test used in expt
%    20 Jul 89  !!scalsintan revised: same limits for deg and rad
%    17 May 89  find!!nfpd revised (for binary or decimal floats)
%    18 Apr 89  global log10 -> logten (to avoid name conflict)
%    18 Apr 89  !!scalsintan revised (per: Rainer Schoepf)
%    27 Nov 88  log,expt,sqrt revised for speed
%     5 Jun 88  log -> log10; ln -> log; exptfp -> expt (revised)
%    11 Nov 87  hyperbolic fns rewritten: speeded up; improved
%     6 Nov 87  ln,atan rewritten: speeded up. sq!-1  eliminated
%    30 Oct 87  sin,(cos),tan,(cot),exp  rewritten; speeded up

%*******************************************************************
%**                       Basic functions                         **
%*******************************************************************

exports acos, acosd, acosh, acot, acotd, acoth, acsc, acscd, acsch,
        asec, asecd, asech, asin, asind, asinh, atan, atan2, atan2d,
        atand, atanh, cbrt, ceiling, cos, cosd, cosh, cot, cotd, coth,
        csc, cscd, csch, exp, factorial, floor, hypot, log, log10,
        logb, sec, secd, sech, sin, sind, sinh, sqrt, tan, tand, tanh,
        terrlst;

imports !!shbinflp, fl2int, geq, leq, neq, rerror, sgn;

global '(math!!label);
math!!label := "Math package mod 1.7, 1 May 93";

symbolic procedure terrlst (x,y); error(0,list(x," invalid for ",y));

global '(!!nfpd !!flint !!epsqrt !!flprec !!floatbits);

if not !!nfpd then flag('(!!nfpd),'share);

symbolic procedure sqrt x;
 % Computes sqrt x by Newton's method, avoiding magnitude problems.
   if x<0 then terrlst(x,'sqrt) else
   begin  scalar trv,nx,g,l,o,c1,c2,f1; f1 := nx := o := 1.0;
          if (x := float x)=0.0 or x=o then return x;
          if x>;
          c1 := 8192.0; c2 := c1*c1;
          while x>c2 do <>;
    loop: trv := nx; nx := (trv + x/trv)/2;
          if g and nx>=trv then go to ret;
          g := t; go to loop;
     ret: nx := nx*f1; return if l then o/nx else nx end;

symbolic procedure cbrt x;
   begin scalar s,l,o,g,trv,nx,c1,c2,f1; f1 := nx := o := 1.0;
         if (x := float x)=0.0 or abs x=o then return x
         else if x<0 then x := -x else s := t;
         if x> else if x=o then go to ret;
         c1 := 1024.0; c2 := c1*c1*c1;
         while x>c2 do <>;
   loop: trv := nx; nx := trv/1.5+x/(trv*trv*3);
         if g and nx>=trv then go to ret;
         g := t; go to loop;
    ret: nx := nx*f1; if l then nx := o/nx;
         return if s then nx else -nx end;

symbolic procedure hypot(p,q);
   % Hypot(p,q)=sqrt(p*p+q*q) but avoids intermediate overflow.
   begin scalar r;
         if (p := float p)<0 then p := -p;
         if (q := float q)<0 then q := -q;
         if zerop p then return q
         else if zerop q then return p
         else if p>;
         if p+q=p then return p else r := q/p;
         return if r= 0 then n else n - 1)
       where n = fix x;

symbolic procedure ceiling x;
   % Returns the smallest integer greater than or equal to X.
   % Note the trickiness to compensate for fact that (unlike APL's
   % "FLOOR" function) FIX truncates towards zero.
   if fixp x then x
    else (if x = float n then n else if x >= 0 then n+1 else n)
       where n = fix x;

symbolic procedure round x;
   % Rounds to the closest integer.
   % Kind of sloppy -- it's biased when the digit causing rounding is a
   % five.  (Changed to work properly for X<0.  SLK)
   if fixp x then x else if x<0 then -round(-x) else floor(x+0.5);

symbolic procedure rounddec (x,p);
   % Rounds x to p decimal places, unless x must already be an integer.
   if abs x>=!!flint then x
    else  begin scalar xl,xr,sc;
            sc := 10.0**p; xl := fix(x := x*sc); xr := x - xl;
            if x>0 and xr>=0.5 then xl := xl+1;
            if x<0 and xr<-0.5 then xl := xl - 1;
            return xl/sc
          end;

global '(log2 sq2 sq2!-1 logsq2 logten log1000 log1e9);
global '(log1e81 log1e27);

sq2 := sqrt 2.0; sq2!-1 := 1/(1+sq2);

symbolic procedure log x;
   begin scalar s,lx; integer p;
      if fixp(x) and (lx := ilog2(x)) > !!floatbits
        then return log2*(lx - !!floatbits)
                      + log(x/2^(lx - !!floatbits))
       else if (x := float x)<=0.0 then terrlst(x,'log)
       else if x - 1<0 then x := 1/x else s := t;
      lx := 0.0;
      while x>1.0e81 do <>;
      while x>1.0e27 do <>;
      while x>1.0e9 do <>;
      while x>1000 do <>;
      while x>10 do <>;
      while x>2 do <>;
      if x>sq2 then <>;
      lx := lx+sclogx!-1(x - 1);
      return if s then lx else -lx end;

symbolic procedure sclogx!-1 x;
   begin scalar tx,px,lx,st,sl; integer p;
         tx := px := x; p := 1; lx := 0.0;
         st := x*(1 - x/2);
         while st+abs tx>st do
            <>;
         for each i in sl do lx := lx+i;
         return lx end;

log2 := 2*(logsq2 := sclogx!-1 sq2!-1);
log1e81 := 3*(log1e27 := 3*(log1e9 := 3*(log1000 :=
  3*(logten := log 10.0))));

global '(!!pilist);

global(!!pilist := '(!!pii !!pii2 !!pii3 !!pii4 !!pii6 !!twopi
                     !!rad2deg !!deg2rad));

remflag(!!pilist,'reserved);

symbolic procedure atan x;
   begin scalar arg,term,termp,trv,s,g,y;
      integer p;
      if (x := float x)< 0 then x := -x
       else s := t;
      if x > 1 then x:=1/x else g:=t;
      if x < !!epsqrt then go to quad;
      term := if x<0.43 then (arg := x)
         else (arg := x/(1+sqrt(1+x*x)))*2;
      arg := arg*arg; p := 1; trv := (termp := term)*(1 - arg/3);
      while trv+abs termp >trv do
        <>;
      x := 0;
      for each i in y do x := x+i;
quad: if not g then x := !!pii2 - x;
      if not s then x := -x;
      return x end;

symbolic procedure atand x; !!rad2deg * atan x;

!!twopi := 2*(!!pii := 2*(!!pii2 := 2*(!!pii4:=atan 1.0)));
!!pii3 := 2*(!!pii6 := !!pii2/3);
!!deg2rad:=!!pii4/45; !!rad2deg:=45/!!pii4;

flag(!!pilist,'reserved);

fluid '(!*ddf!* !*df!* !*sf!* !*qf!*);

symbolic procedure sin x;
  begin scalar !*sf!*,!*qf!*;integer p;
   % test for 90 deg -> 1.0
      x := !!scalsintan(x,t);
      if !*qf!* then <>;
   % for x>45, compute cos of complement, else compute sin.
      if x>!!pii4 then x := !!pii2 - x else p := 1;
      x := !!sints(x,p);
   ret: return if !*sf!* then x else -x end;

symbolic procedure sind x;
  begin scalar !*sf!*,!*qf!*;integer p;
   % test for 90 deg -> 1.0
      x := !!scalsintand(x,t);
      if !*qf!* then <>;
   % for x>45, compute cos of complement, else compute sin.
      if x>45.0 then x := 90.0 - x else p := 1;
      x := !!sints(x*!!deg2rad,p);
   ret: return if !*sf!* then x else -x end;

symbolic procedure tan x;
   begin scalar y,inv,!*sf!*,!*qf!*;
      y:=x; x:= !!scalsintan(x,nil);
      if !*qf!* then terrlst(y,'tan);
      if x>!!pii4 then x := !!pii2 - x else inv := t;
 % For scaled x>45, compute cot else compute tan.
      if x>!!epsqrt then <>;
      if not inv then x := 1/x;
      return if !*sf!* then -x else x end;

symbolic procedure tand x;
   begin scalar y,inv,!*sf!*,!*qf!*;
      y:=x; x:= !!scalsintand(x,nil);
      if !*qf!* then terrlst(y,'tand);
      if x>45.0 then x := 90.0 - x else inv := t;
 % For scaled x>45, compute cot else compute tan.
      x := x*!!deg2rad;
      if x>!!epsqrt then <>;
      if not inv then x := 1.0/x;
      return if !*sf!* then -x else x end;

global '(max!-trig!-fact); max!-trig!-fact := 10**(!!nfpd/2);

fluid '(!:prec!:);

symbolic procedure !!scalsintan(x,w);
% x is scaled to 0<=x<=90 deg, with !*sf!* = {sin>0 or tan<0}.
% w true for sin, false for tan.
%modified to avoid infinite loop for large x, after Rainer Schoepf's
%suggestion, adjusted so degree and radian input agrees- SLK.
   begin scalar xf,x0;
      if x<0 then x := -x else !*sf!* := t; x0 := x;
      if (xf := fix(x/!!twopi))>max!-trig!-fact then
         terrlst(if !*sf!* then x else -x,if w then 'sin else 'tan);
      x := x - float xf * !!twopi;
      if x>!!pii then (if w then
           <>
       else x := x - !!pii);
      if x>!!pii2 then x:=!!pii - x
       else if not w then !*sf!*:=not !*sf!*;
      !*qf!* := x>=!!pii2;
 % the remaining tests and scaling are done separately by sin and tan
      if x0 or tan<0}.
% w true for sin, false for tan.
%modified to avoid infinite loop for large x, after Rainer Schoepf's
%suggestion, adjusted so degree and radian input agrees- SLK.
   begin scalar xf,x0;
      if x<0 then x := -x else !*sf!* := t; x0 := x;
      if (xf := fix(x/360.0))>max!-trig!-fact then
         terrlst(if !*sf!* then x else -x,if w then 'sin else 'tan);
      x := x - float xf * 360.0;
      if x>180.0 then (if w then
           <> else x:= x - 180.0);
      if x>90.0 then x:=180.0 - x else if not w then !*sf!*:=not !*sf!*;
      !*qf!* := x>=90.0;
 % the remaining tests and scaling are done separately by sin and tan
      if x st do
           <>;
        x:=0.0;
        for each i in sl do x:=x+i;
        return x end;

symbolic procedure !!sinhts x;
 % Does the actual computation of the sinh for 0 st do
           <>;
        x := 0.0;
        for each i in sl do x := x+i;
        return x end;

global '(!!ee);

symbolic procedure exp v;
   begin scalar d,nr,mr,fr,st;integer p,ip;
         mr := fr := 1.0; v := float v;
         if abs v>1 then <>;
         if abs v>0.5 then v := v/2 else d := t;
         if v=0.0 then go to ret;
         st := mr+v;
         while st+abs mr > st do
               <>;
         mr := 0.0;
         for each i in nr do mr := mr+i;
    ret: if not d then mr := mr*mr;
         return fr*mr end;

remflag('(!!ee),'reserved); !!ee := exp 1.0; flag('(!!ee),'reserved);

put('expt,'number!-of!-args,2);

% NOTE that any Lisp system with a very good implementation of EXPT is
% entitled to replace the following definition of EXPT with it, but they
% should also arrange that fexpt gets redirected to the same good
% built-in function.

symbolic procedure iexpt(x,n);
   % Calculate x**n where n is a strictly positive integer.  This uses
   % repeated squaring.  It is appropriate for use when x is an integer,
   % and can be used for floating x provided that n is not too large.
   % John Abbott reported some slow calculations.  He added: The
   % problem is the line containing "lshift".  I tried replacing
   % remainder(x,2)=0 with evenp(x), and that made it go about twice as
   % fast.  Then I removed the line altogether, and the problem went
   % away.  I think that line would be useful only if n is quite large
   % and x is divisible by a moderately high power of 2.
   if not (n > 0) then error(0, "iexpt argument <= 0")
    else if n=1 or x=1 then x
%   else if fixp x and remainder(x,2)=0 then lshift(iexpt(x/2,n),n)
    else if remainder(n,2)=0 then (y*y) where y=iexpt(x,n/2)
%   else if evenp n then (y*y) where y=iexpt(x,n/2)
    else (x*y*y) where y=iexpt(x,(n - 1)/2) ;

symbolic procedure expt(x,y);
   % Computes x**y.  Valid for any x provided that y is an integer,
   % but only for positive x if y is floating.
   begin integer iy,p; scalar sy,fy,r;
      % Some of the initial tests here are subsumed by those in rexpt,
      % and could be removed - but I prefer to implement a proper
      % general version of expt, even though doing so adds (slightly)
      % to the cost of using this portable version.  Note that getting
      % accurate answers from expt in a portable way is a real pain,
      % and I will not do a 100% good job here... see Cody and Waite
      % for a discussion of the issues involved.
      if zerop y then
         if zerop x then error(0,"0**0 undefined")
          else return if floatp x or floatp y then 1.0 else 1
       else if zerop x then
         if y>0 then return if floatp x or floatp y then 0.0 else 0
          else error(0,"divide by zero in EXPT")
       else if fixp y then
         return if fixp x then
                  if y < 0 then 0 else if x = 1 then 1 else iexpt(x,y)
      % See comments with the function FEXPT for an explanation of the
      % tests here - I deem exponents of less than 50 to be small
      % enough to handle the simple (and cheap) way.
                   else if y > 50 then fexpt(x, y)
                   else if y > 0 then iexpt(x, y)
                   else if y < -50 then 1.0/fexpt(x,-y)
                 else 1.0/iexpt(x,-y);
      % Since y is floating, float x if fixed.
      if fixp x then x := float x;
      if x<0.0 then
        error(0,"attempt to raise negative value to floating power");
      % Record the sign of y, but do not invert x yet, since it is
      % important not to corrupt the value of x by even one unit in the
      % last place.  Note that this will leave me with a risk that
      % (e.g.) 10.0**(-1000.0) will try to compute 10.0**1000.0 (which
      % will overflow) and only then take its reciprocal, while
      % possible had I inverted x here I would have had a silent
      % arithmetic underflow.  For now I will argue that arithmetic
      % underflow is really an error too and that the exception
      % deserved to be raised.
      if y < 0.0 then <>;
      % Still use multiplication if y has integral value.
      iy := fix y;
      fy := float iy;
      if y = fy then <<
         if iy > 50 then x := fexpt(x, iy)
          else x := iexpt(x, iy);
         if sy then return 1.0/x
          else return x>>;
      % For x fairly close to 1.0 and smallish values of y I can use
      % the simple formula with exp and log, and I will not lose
      % overmuch accuracy.  The limits I apply here are a compromise
      % between wanting to use this cheap recipe as often as possible
      % and the desire to get best possible accuracy.
      if 0.1 < x and x < 10.0 and y < 5.0
        then <>;
      % Now scale x as 2^p * something
      p := 0;
      while x < 0.005524 do <>;
      while x < 0.707106781 do <>;
      while x >= 181.02 do <>;
      while x >= 1.414213562 do <>;
      % Now x is in the range 0.707 <= x < 1.414, so log x is fairly
      % small.  I can compute x**iy my multiplication, x**(y - iy) by
      % logs, and that just leaves 2**(y*p) to worry about.
      if (y - fy) > 0.5 then <>;
      r := exp((y - fy)*log x);
      if iy > 50 then r := r*fexpt(x, iy)
       else if iy > 0 then r := r*iexpt(x, iy);
      y := p*y;
      iy := fix y;
      fy := y - float iy; % fractional part of y.
      % Now I need to compute 2**iy * 2**fy.
      r := r * exp(fy*log2);
      % I can afford to use iexpt() here since powers of 2.0 have exact
      % representations as floats (with binary machines!) so there
      % should be no rounding errors in what follows.
      if iy > 0 then r := r*iexpt(2.0, iy)
       else if iy < 0 then r := r*iexpt(0.5, -iy);
      if sy then r := 1.0/r;
      return r
   end;

Comment
   Consider the calculation z = 1.01 ** 16384.  I have chosen the
   exponent to be a power of 2 for simplicity of explanation, but other
   values will suffer the same way.  The value of z will be computed as
   (1.01*1.01) raised to the power 8192.  The multiplication 1.01*1.01
   will introduce an error of about e = 1/2 unit in the last place
   (around 1.0e-16 perhaps).  If all calculations after that very first
   multiplication are then performed exactly, the final result (6.3e70
   or so) will have a relative error of around 8000 units in the last
   place.  To avoid this sort of trouble it is necessary to use extra
   precision in the multiplications - something that slows us down but
   which is needed.  I only use this expensive code if I am going to
   raise a float to a power greater than 50 (a rather arbitrary
   cut-off) so that speed of calculation involving small powers is not
   hurt too badly;

symbolic procedure fsplit x;
   % This decomposes a floating point value x into two parts x1 and x2
   % such that x = x1+x2 and x1 is a number with at most 12 significant
   % bits in its mantissa.  I choose to keep 12 bits here since I then
   % expect (i.e., REQUIRE) that products of pairs of such numbers get
   % formed without any rounding at all.  This should be so even on
   % IEEE single precision arithmetic (25 bits of mantissa).  For IBM
   % mainframe single precision even more effort would be needed.
   begin scalar xx, n;
      if x = 0.0 then return (0.0 . 0.0);
      xx := x; n := 1.0;
      if x < 0.0 then xx := -xx;
      while xx < 8.0 do << xx := xx*256.0; n := n*256.0>>;
      while xx < 2048.0 do << xx := xx*2.0; n := n*2.0>>;
      while xx >= 4096.0 do << xx := xx*0.5; n := n*0.5>>;
      xx := float fix xx/n;
      if x < 0.0 then xx := -xx;
      return (xx . (x - xx))
   end;

symbolic procedure f_multiply(a, b);
   % a and b are split-up floating point values as generated by fsplit.
   % Multiply them together and return the result as an fsplit-num.
   begin scalar h, l;
      h := fsplit(car a*car b);
      l := cdr h + car a*cdr b + (car b + cdr b)*cdr a;
      return (car h . l)
   end;

symbolic procedure fexpt(x, n);
   % Like iexpt, this raises x to the (positive integer) power n.  But
   % it uses fplit-num arithmetic to get about 12 bits of extra
   % precision in the calculation, which should preserve reasonable
   % accuracy until n gets to be much bigger than 5000.
   begin scalar w;
      w := fexpt1(fsplit x, n);
      return car w + cdr w
   end;

symbolic procedure fexpt1(x, n);
   % Calculate x**n where n is a strictly positive integer, using extra
   % precision arithmetic.
   if not (n > 0) then error(0, "fexpt1 argument <= 0")
    else if n = 1 then x
    else if remainder(n, 2) = 0 then fexpt1(f_multiply(x, x), n/2)
    else f_multiply(x, fexpt1(f_multiply(x, x), (n - 1)/2));

symbolic procedure rexpt(x,y);
   % Computes x**y in for argument sets that yield real values.  In
   % particular if x is negative but y is a floating point value that
   % is sufficiently close to a rational number then a real result will
   % be computed, where the system-level expt function might have
   % reported an error.  This also picks up various marginal or error
   % cases (e.g. 0**0) so that their treatment is precisely defined in
   % REDUCE.
   begin scalar s,q; integer p;
      if zerop y then
         if zerop x then error(0,"0**0 undefined")
         else return if floatp x or floatp y then 1.0 else 1
      else if zerop x then
         if y>0 then return if floatp x or floatp y then 0.0 else 0
         else error(0,"divide by zero in EXPT")
      else if fixp y then <<
         if fixp x then <<
            if y<0 then return 0
            else if x = 1 then return 1
            else return iexpt(x, y) >>;
      % Floating numbers raised to integer powers are still pretty
      % painful.  If the base is negative then the sign of the result
      % depends on whether the power was odd or even.  For large
      % exponents I use fexpt() for extra accuracy (but at significant
      % extra cost).
         s := 0;
         if y < 0 then <>;
         if x < 0 then <>;
         if y > 50 then x := fexpt(x, y) else x := iexpt(x, y);
         if s=1 or s=3 then x := 1.0/x;
         if s>1 and remainder(y,2) neq 0 then x := -x;
         return x>>;
      % Since y is floating, float x if fixed.
      if fixp x then x := float x;
      % Invert here if exponent is negative float.
      if y<0.0 then <>;
      % Still use integer exponentiation if y has integral value.
      if zerop(y - (p := fix y)) then return iexpt(x, p);
      % If x < 0 then x**y only yields a real result if y is a rational
      % number.  We already know that y is not an integer, so call
      % ft2rn1 to see if a good rational approximation to y exists.  A
      % previous version of this code called ft2rn1 for all floating
      % point values of y and then used combination sof sqrt/cbrt to
      % evaluate x**y in some cases.  This version bets that the cost
      % of ft2rn1 would exceed the savings of using sqrt, and so only
      % does the expensive thing when x < 0 and thus when there might
      % otherwise have been an error.
      if x<0.0 then <<
         q := ft2rn1 y; p := car q; q := cdr q;
         x := -x;
         if not(abs p<10 or q<10
             or 2*max(length explode q,length explode p) < !!flprec+1)
             or remainder(q,2)=0
               then error (0,list (-x,"**",y," not real"))
           else if remainder(p,2)=1 then s := t >>;
      x := expt(x, y);     % Use the lower level expt function
      return (if s then -x else x)
 end;

symbolic procedure ft2rn1 n;
  if n < 0.0 then ((-car r) . cdr r) where r = ft2rn2(-n)
   else ft2rn2 n;

symbolic procedure ft2rn2 n;
  % Here, the positive input n is a float.
   begin scalar a,p0,p1,q0,q1,w,nn,r0,r1,flpr;
      flpr := abs n*100.0/!!flint;
      a := fix n;
      nn := n - a;
      p0 := 1; p1 := a; q0 := 0; q1 := 1;
      r0 := n + 1.0;
 top: r1 := abs(n - float p1/float q1);
      if nn=0.0 or r1=0.0 or not (r1 > flpr) then return p1 . q1
       else if not (r1 < r0) then return p0 . q0;
      nn := 1.0/nn;
      a := fix nn;
      nn := nn - a;
      w := p0 + a*p1; p0 := p1; p1 := w;
      w := q0 + a*q1; q0 := q1; q1 := w;
      r0 := r1;
      go to top
  end;


%**********************************************************************
%**             Functions derived from basic functions               **
%**********************************************************************

symbolic procedure cos x; sin(!!pii2 - x);

symbolic procedure cot x; tan(!!pii2 - x);

symbolic procedure sec x; 1.0/cos x;

symbolic procedure csc x; 1.0/sin x;

symbolic procedure acot x; !!pii2 - atan x;

symbolic procedure asin x;
   if abs x<1 then
      atan(if abs x1 then terrlst (x,'asin)
   else if x>0 then !!pii2 else -!!pii2;

symbolic procedure acos x; !!pii2 - asin x;

symbolic procedure acsc x;
   if abs x>=1 then asin(1.0/x) else terrlst(x,'acsc);

symbolic procedure asec x;
   if abs x<1 then terrlst(x,'asec) else !!pii2 - asin(1.0/x);

symbolic procedure cosd x; sind(90.0 - x);

symbolic procedure cotd x; tand(90.0 - x);

symbolic procedure secd x; 1/cosd x;

symbolic procedure cscd x; 1/sind x;

symbolic procedure acotd x; 90.0 - atand x;

symbolic procedure asind x; !!rad2deg * asin x;

symbolic procedure acosd x; 90.0 - asind x;

symbolic procedure acscd x;
   if abs x>=1 then asind(1.0/x) else terrlst(x,'acscd);

symbolic procedure asecd x;
   if abs x<1 then terrlst(x,'asecd) else 90.0 - asind(1.0/x);

symbolic procedure sinh x;
   begin scalar s;
      if x<0.0 then x:=-x else s:=t;
      if (x := float x)<0.91 then <>;
      x := exp(-x); x := (1.0/x - x)/2;
 ret: return if s then x else -x end;

symbolic procedure cosh x; <>;

symbolic procedure tanh x;
   if x<0.0 then -tanh(-x) else
      <>;

symbolic procedure coth x;
   if x<0.0 then -coth(-x) else
      <>;

symbolic procedure asinh x; begin scalar s;
   if x<0 then x:=-x else s:=t;
   x:=if x=1 then terrlst(x,'atanh)
   else if abs x1 then terrlst(x,'asech) else acosh (1.0/x);

symbolic procedure acsch x;
   if (x:= float x)=0.0 then terrlst(x,'acsch) else asinh(1/x);

symbolic procedure ln x; log x;

symbolic procedure log10 x;
   if x>0 then log x/logten else terrlst(x,'logten);

symbolic procedure logb (x,b); %log x to base b;
   begin scalar a,s; a:=x>0; s:=not(b<=0 or zerop(b - 1));
         if a and s then return log x/log b
         else terrlst((if a then list ('base,b)
            else if s then list('arg,x) else list(x,b)),'logb) end;

symbolic procedure atan2(y,x);
   if zerop x then !!pii2*sgn y else
   <<(if x>0 then a else if y<0 then a - !!pii else a+!!pii)
     where a=atan(y/x)>>;

symbolic procedure atan2d(y,x);
   if zerop x then 90.0*sgn y else
   <<(if x>0 then a else if y<0 then a - 180.0 else a+180.0)
     where a=!!rad2deg*atan(y/x)>>;

% A numerical factorial function.

symbolic procedure factorial n;
   if not fixp n or n<0
     then rerror(arith,4,list(n,"invalid factorial argument"))
    else nfactorial n;

symbolic procedure nfactorial n;
   % Numerical factorial function.  It is assumed that n is numerical
   % and non-negative.
   if n>20 then fac!-part(1,n)
    else begin scalar m;
       m:=1;
       for i:=1:n do m:=m*i;
       return m;
     end;

symbolic procedure fac!-part (m,n);
    if m=n then m
     else if m=n - 1 then m*n
     else (fac!-part(m,p)*fac!-part(p+1,n)) where p=(m+n)/2;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/bfelem.red0000644000175000017500000010571411526203062023551 0ustar  giovannigiovannimodule bfelem;  % Bigfloat elementary constants and functions.

% Last change date: 1 Jan 1993.

% Author: T. Sasaki, 1979.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn, Jed B. Marti, Stanley L. Kameny.
% Changed for binary arithmetic by Iain Beckingham and Rainer M. Schoepf

exports !:cbrt10, !:cbrt2, !:cbrt3, !:cbrt5, !:cbrte, !:cbrtpi,
        !:e, !:log10, !:log2, !:log3, !:log5, !:logpi, !:pi, !:sqrt10,
        !:sqrt2, !:sqrt3, !:sqrt5, !:sqrte, !:sqrtpi, acos!*,
        asin!*, atan!*, cos!*, e!*,
        exp!*, exp!:, get!:const, log!*, log!:, pi!*,
        sin!*, sqrt!:, tan!*;

imports !*q2f, abs!:, bflerrmsg, bfp!:, bfzerop!:, conv!:bf2i,
        conv!:mt, cut!:ep, cut!:mt, decimal2internal, difference!:,
        divide!:, ep!:, equal!:, geq, greaterp!:, i2bf!:, leq, lessp!:,
        lshift, make!:ibf, minus!:, minusp!:, mksq, mt!:, multd, neq,
        numr, order!:, plus!:, preci!:, quotient!:, round!:mt, simp,
        texpt!:, texpt!:any, times!:;


fluid '(!:prec!: !:bprec!: !!scls !!sclc);

global '(bfsaveprec!*);

global '(bfz!* bfhalf!* bfone!* bftwo!* bfthree!* bffive!* bften!*
         !:bf!-0!.0625 !:bf!-0!.25 !:bf0!.419921875);

% *** Tables for Elementary Function and Constant Values ***

symbolic procedure allfixp l;
   % Returns T if all of L are FIXP.
   null l or fixp car l and allfixp cdr l;

symbolic procedure read!:lnum(l);
% This function reads a long number "n" represented by a list in a way
% described below, and constructs a BIG-FLOAT representation of "n".
% L is a list of integers, the first element of which gives the order of
% "n" and all the next elements when concatenated give the mantissa of
% "n".
% **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1).
% **** Except for the first element, all integers in L
% ****      should not begin with "0" because some
% ****      systems suppress leading zeros.
% JBM: Fix some kludgy coding here.
% JBM: Add BFSAVEPREC!* precision saver.
if not allfixp l then bflerrmsg 'read!:lnum
 else begin scalar mt, ep, k, sign, u, v, dcnt;
          mt := dcnt := 0;      %JBM
%          ep := car(u := l) + 1;   %JBM
          u := l;
          ep := add1 car u;
          sign := if minusp cadr l then -1 else 1;   %JBM
          while u:=cdr u do
            << k := length explode(v := abs car u);  %JBM
%               k := 0;  %JBM
%               while v do << k := k + 1; v := cdr v >>;  %JBM
               mt := mt * 10**k + v; %JBM
               ep := ep - k;
               dcnt := dcnt +  k;    % JBM
               if bfsaveprec!* and dcnt > bfsaveprec!* then  %JBM
                  u := '(nil) >>;     %JBM
          return decimal2internal (sign * mt, ep)
                   where !:bprec!: := msd!: mt;
    end;


%symbolic procedure bfexpt!:(u,v);
%   % Calculates u**v, including case u<0.
%   if minusp!: u
%     then multd(texpt!:any(minus!: u,v),
%                !*q2f if null numr simp list('difference,v,
%                                             '(quotient 1 2))
%                        then simp 'i
%                       else mksq(list('expt,'(minus 1),v),1))
%    else texpt!:any(u,v);

symbolic procedure exp!* u; exp!:(u,!:bprec!:);

symbolic procedure log!* u; log!:(u,!:bprec!:);

symbolic procedure sin!* u; sin!:(u,!:bprec!:);

symbolic procedure cos!* u; cos!:(u,!:bprec!:);

symbolic procedure tan!* u; tan!:(u,!:bprec!:);

symbolic procedure asin!* u; asin!:(u,!:bprec!:);

symbolic procedure acos!* u; acos!:(u,!:bprec!:);

symbolic procedure atan!* u; atan!:(u,!:bprec!:);

symbolic procedure sqrt!* u; sqrt!:(u,!:bprec!:);

symbolic procedure pi!*;
   if !:prec!:>1000 then !:bigpi !:bprec!: else !:pi !:bprec!:;

symbolic procedure e!*; !:e !:bprec!:;


%*************************************************************
%**                                                         **
%** 3-1. Elementary CONSTANTS.                              **
%**                                                         **
%*************************************************************

symbolic procedure !:pi k;
% This function calculates the value of the circular
%      constant "PI", with the precision K, by
%      using Machin's well known identity:
%         PI = 16*atan(1/5) - 4*atan(1/239).
%      Calculation is performed mainly on integers.
% K is a positive integer.
if not fixp k or k <= 0 then bflerrmsg '!:pi
 else
    begin integer k3,s,ss,m,n,x,test;  scalar u;
          u := get!:const('!:pi, k);
% The original version of this code used the string "NOT FOUND" as the
% marker value that get!;const could return. An effect of that was two
% very minor uglinesses. Firstly there will have been multiple copies of
% the string using up space, and secondly it relied on NEQ being the
% converse of EQUAL not EQ and that that then checked string contents.
% By using a symbol 'not_found there will be a very very minor improvement
% in both speed and code clarity! 
          if u neq 'not_found then return u;
          ss := n := 2 ** (k3 := k + 3) / 5;
          x := -5 ** 2;
          m := 1;
          while n neq 0 do <>;
          s := n := 2 ** k3 / 239;
          x := -239 ** 2;
          m := 1;
          while n neq 0 do << n := n / x; s := s + n / (m := m + 2) >>;
          u := round!:mt(make!:ibf(test := 16 * ss - 4 * s, - k3), k);
          save!:const('!:pi, u);
          return u;
    end;

symbolic procedure !:bigpi k;
% This function calculates the value of the circular
%      constant "PI", with the binary precision K, by the
%      arithmetic-geometric mean method.  (See,
%      R. Brent, JACM Vol.23, #2, pp.242-251(1976).)
% K is a positive integer.
% **** This function should be used only when you
% ****      need "PI" of precision higher than 1000.
if not fixp k or k <= 0 then bflerrmsg '!:bigpi
 else begin integer k7, n;  scalar dcut, half, x, y, u, v;
          u := get!:const('!:pi, k);
          if u neq 'not_found then return u;
          k7 := k + 7;
          half := bfhalf!*;    %JBM
          dcut := make!:ibf(2, - k7);
          n := 1;
          x := bfone!*;
          y := divide!:(x, !:sqrt2 k7, k7);
          u := !:bf!-0!.25;    %JBM
          while greaterp!:(abs!: difference!:(x, y), dcut) do
            << v := x;
               x := times!:(plus!:(x, y), half);
               y := sqrt!:(cut!:ep(times!:(y, v), - k7), k7);
               v := difference!:(x, v);
               v := times!:(times!:(v, v),i2bf!: n);
               u := difference!:(u, cut!:ep(v, - k7));
               n := 2*n>> ;
          v := cut!:mt(texpt!:(plus!:(x, y), 2), k7);
          u := divide!:(v, times!:(i2bf!: 4, u), k);
          save!:const('!:pi, u);
          return u;
    end;

symbolic procedure !:e k;
% This function calculates the value of "e", the base
%      of the natural logarithm, with the binary precision K,
%      by summing the Taylor series for exp(x=1).
%      Calculation is performed mainly on integers.
% K is a positive integer.
if not fixp k or k <= 0 then bflerrmsg '!:e
 else begin integer k7, ans, m, n;  scalar u;
          u := get!:const('!:e, k);
          if u neq 'not_found then return u;
          k7 := k + 7;
          m := 1;
          n := lshift (1, k7); % 2**k7
          ans := 0;
          while n neq 0  do ans := ans + (n := n / (m := m + 1));
          ans := ans + lshift (1, k7 + 1); % 2 * 2**k7
          u := round!:mt(make!:ibf(ans, - k7), k);
          save!:const('!:e2, u);
          return u;
       end;

symbolic procedure !:e0625(k);
% This function calculates exp(0.0625), the value of the
%      exponential function at the point 0.0625, with
%      the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:e0625, k);
  if u neq 'not_found then return u;
  u := exp!:(!:bf!-0!.0625, k);    %JBM
  save!:const('!:e0625, u);
  return u;
end;

symbolic procedure !:log2 k;
% This function calculates log(2), the natural
%      logarithm of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log2, k);
  if u neq 'not_found then return u;
  u := log!:(bftwo!*, k);
  save!:const('!:log2, u);
  return u;
end;

symbolic procedure !:log3 k;
% This function calculates log(3), the natural
%      logarithm of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log3, k);
  if u neq 'not_found then return u;
  u := log!:(bfthree!*, k);
  save!:const('!:log3, u);
  return u;
end;

symbolic procedure !:log5 k;
% This function calculates log(5), the natural
%      logarithm of 5, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log5, k);
  if u neq 'not_found then return u;
  u := log!:(bffive!*, k);
  save!:const('!:log5, u);
  return u;
end;

symbolic procedure !:log10 k;
% This function calculates log(10), the natural
%      logarithm of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:log10,  k);
  if u neq 'not_found then return u;
  u := log!:(bften!*, k);
  save!:const('!:log10, u);
  return u;
end;

symbolic procedure !:logpi k;
% This function calculates log(PI), the natural
%      logarithm of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:logpi, k);
  if u neq 'not_found then return u;
  u := log!:(!:pi(k + 2), k);
  save!:const('!:logpi, u);
  return u
end;

symbolic procedure !:sqrt2(k);
% This function calculates SQRT(2), the square root
%      of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt2, k);
  if u neq 'not_found then return u;
  u := sqrt!:(bftwo!*, k);
  save!:const('!:sqrt2, u);
  return u;
end;

symbolic procedure !:sqrt3(k);
% This function calculates SQRT(3), the square root
%      of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u:=get!:const('!:sqrt3, k);
  if u neq 'not_found then return u;
  u := sqrt!:(bfthree!*, k);
  save!:const('!:sqrt3, u);
  return u;
end;

symbolic procedure !:sqrt5 k;
% This function calculates SQRT(5), the square root
%      of 5, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt5, k);
  if u neq 'not_found then return u;
  u := sqrt!:(bffive!*, k);
  save!:const('!:sqrt5, u);
  return u;
end;

symbolic procedure !:sqrt10 k;
% This function calculates SQRT(10), the square root
%      of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrt10, k);
  if u neq 'not_found then return u;
  u := sqrt!:(bften!*, k);
  save!:const('!:sqrt10, u);
  return u;
end;

symbolic procedure !:sqrtpi k;
% This function calculates SQRT(PI), the square root
%      of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:sqrtpi, k);
  if u neq 'not_found then return u;
  u := sqrt!:(!:pi(k + 2), k);
  save!:const('!:sqrtpi, u);
  return u;
end;

symbolic procedure !:sqrte k;
% This function calculates SQRT(e), the square root
%      of "e", with the precision K.
% K is a positive integer.
begin scalar u;
  u:=get!:const('!:sqrte, k);
  if u neq 'not_found then return u;
  u := sqrt!:(!:e(k + 2), k);
  save!:const('!:sqrte, u);
  return u;
end;

symbolic procedure !:cbrt2 k;
% This function calculates CBRT(2), the cube root
%      of 2, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt2, k);
  if u neq 'not_found then return u;
  u := cbrt!:(bftwo!*, k);
  save!:const('!:cbrt2, u);
  return u;
end;

symbolic procedure !:cbrt3 k;
% This function calculates CBRT(3), the cube root
%      of 3, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt3, k);
  if u neq 'not_found then return u;
  u := cbrt!:(bfthree!*, k);
  save!:const('!:cbrt3, u);
  return u;
end;

symbolic procedure !:cbrt5 k;
% This function calculates CBRT(5), the cube root
%    of 5, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt5, k);
  if u neq 'not_found then return u;
  u := cbrt!:(bffive!*, k);
  save!:const('!:cbrt5, u);
  return u;
end;

symbolic procedure !:cbrt10 k;
% This function calculates CBRT(10), the cube root
%      of 10, with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrt10, k);
  if u neq 'not_found then return u;
  u := cbrt!:(bften!*, k);
  save!:const('!:cbrt10, u);
  return u;
end;

symbolic procedure !:cbrtpi k;
% This function calculates CBRT(PI), the cube root
%      of "PI", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrtpi, k);
  if u neq 'not_found then return u;
  u := cbrt!:(!:pi(k + 2), k);
  save!:const('!:cbrtpi, u);
  return u;
end;

symbolic procedure !:cbrte k;
% This function calculates CBRT(e), the cube root
%      of "e", with the precision K.
% K is a positive integer.
begin scalar u;
  u := get!:const('!:cbrte, k);
  if u neq 'not_found then return u;
  u := cbrt!:(!:e(k + 2), k);
  save!:const('!:cbrte, u);
  return u;
end;

%*************************************************************
%**                                                         **
%** 3-2. Routines for saving CONSTANTS.                     **
%**                                                         **
%*************************************************************

symbolic procedure get!:const(cnst, k);
% This function returns the value of constant CNST
%      of the precision K, if it was calculated
%      previously with, at least, the precision K,
%      else it returns 'not_found.
% CNST is the name of the constant (to be quoted).
% K is a positive integer.
  if atom cnst and fixp k and k > 0 then
    begin scalar u;
          u := get(cnst, 'save!:c);
          if null u or car u < k then return 'not_found
           else if car u = k then return cdr u
                             else return round!:mt(cdr u, k);
    end
   else bflerrmsg 'get!:const$

symbolic procedure save!:const(cnst, nmbr);
% This function saves the value of constant CNST
%      for the later use.
% CNST is the name of the constant (to be quoted).
% NMBR is a BIG-FLOAT representation of the value.
  if atom cnst and bfp!: nmbr then
       put(cnst, 'save!:c, preci!: nmbr . nmbr)
   else bflerrmsg 'save!:const$

symbolic procedure set!:const(cnst, l);
% This function sets the value of constant CNST.
% CNST is the name of the constant (to be quoted).
% L is a list of integers, which represents the
%      value of the constant in the way described
%      in the function READ!:LNUM.
     save!:const(cnst, read!:lnum l)$


% Setting the constants.

set!:const( '!:pi    , '( 0   3141 59265 35897 93238 46264
     33832 79502 88419 71693 99375 105820 9749 44592 30781
     64062 86208 99862 80348 25342 11706 79821 48086 51328
     23066 47093 84460 95505 82231 72535 94081 28481 1174
    5028410 2701 93852 11055 59644 62294 89549 30381 96442
     88109 8) )$

set!:const( '!:e     , '( 0   2718 28182 84590 45235 36028
     74713 52662 49775 72470 93699 95957 49669 67627 72407
     66303 53547 59457 13821 78525 16642 74274 66391 93200
     30599 21817 41359 66290 43572 90033 42952 60595 63073
     81323 28627 943490 7632 33829 88075 31952 510190 1157
     38341 9) )$

set!:const( '!:e0625   , '( 0 1064 49445 89178 59429 563390
      5946 42889 673100 7254 43649 35330 151930 7510 63556
     39368 2816600 633 42934 35506 87662 43755 1) );

set!:const( '!:log2  , '(-1   6931 47180 55994 53094 17232
     12145 81765 68075 50013 43602 55254 1206 800094 93393
     62196 96947 15605 86332 69964 18687 54200 2) )$

set!:const( '!:log3  , '( 0   1098 61228 866810 9691 39524
     52369 22525 70464 74905 57822 74945 17346 94333 63749
     42932 18608 96687 36157 54813 73208 87879 7) )$

set!:const( '!:log5  , '( 0   1609 43791 2434100 374 60075
     93332 26187 63952 56013 54268 51772 19126 47891 47417
     898770 7657 764630 1338 78093 179610 7999 7) )$

set!:const( '!:log10 , '( 0   2302 58509 29940 456840 1799
     14546 84364 20760 11014 88628 77297 60333 27900 96757
     26096 77352 48023 599720 5089 59829 83419 7) )$

set!:const( '!:logpi , '( 0   1144 72988 5849400 174 14342
     73513 53058 71164 72948 12915 31157 15136 23071 47213
     77698 848260 7978 36232 70275 48970 77020 1) )$

set!:const( '!:sqrt2 , '( 0   1414 21356 23730 95048 80168
     872420 96980 7856 96718 75376 94807 31766 79737 99073
     24784 621070 38850 3875 34327 64157 27350 1) )$

set!:const( '!:sqrt3 , '( 0   17320 5080 75688 77293 52744
     634150 5872 36694 28052 53810 38062 805580 6979 45193
     301690 88000 3708 11461 86757 24857 56756 3) )$

set!:const( '!:sqrt5 , '( 0   22360 6797 74997 89696 40917
     36687 31276 235440 6183 59611 52572 42708 97245 4105
    209256 37804 89941 441440 8378 78227 49695 1) )$

set!:const( '!:sqrt10, '( 0   3162 277660 1683 79331 99889
     35444 32718 53371 95551 39325 21682 685750 4852 79259
     44386 39238 22134 424810 8379 30029 51873 47))$

set!:const( '!:sqrtpi, '( 0   1772 453850 9055 16027 29816
     74833 41145 18279 75494 56122 38712 821380 7789 85291
     12845 91032 18137 49506 56738 54466 54162 3) )$

set!:const( '!:sqrte , '( 0   1648 721270 7001 28146 8486
    507878 14163 57165 3776100 710 14801 15750 79311 64066
     10211 94215 60863 27765 20056 36664 30028 7) )$

set!:const( '!:cbrt2 , '( 0   1259 92104 98948 73164 7672
    106072 78228 350570 2514 64701 5079800 819 75112 15529
     96765 13959 48372 93965 62436 25509 41543 1) )$

set!:const( '!:cbrt3 , '( 0   1442 249570 30740 8382 32163
     83107 80109 58839 18692 53499 35057 75464 16194 54168
     75968 29997 33985 47554 79705 64525 66868 4) )$

set!:const( '!:cbrt5 , '( 0   1709 97594 66766 96989 35310
     88725 43860 10986 80551 105430 5492 43828 61707 44429
     592050 4173 21625 71870 10020 18900 220450 ) )$

set!:const( '!:cbrt10, '( 0   2154 4346900 318 83721 75929
     35665 19350 49525 93449 42192 10858 24892 35506 34641
     11066 48340 80018 544150 3543 24327 61012 6) )$

set!:const( '!:cbrtpi, '( 0   1464 59188 75615 232630 2014
     25272 63790 39173 85968 55627 93717 43572 55937 13839
     36497 98286 26614 56820 67820 353820 89750 ) )$

set!:const( '!:cbrte , '( 0   1395 61242 50860 89528 62812
     531960 2586 83759 79065 15199 40698 26175 167060 3173
     90156 45951 84696 97888 17295 83022 41352 1) )$


%*************************************************************
%**                                                         **
%** 4-1. Elementary FUNCTIONS.                              **
%**                                                         **
%*************************************************************

symbolic procedure sqrt!:(x, k);
% This function calculates SQRT(x), the square root
%      of "x", with the binary precision K, by Newton's
%      iteration method.
% X is a BIG-FLOAT representation of "x", x >= 0.
% K is a positive integer.
  if minusp!: x or not fixp k or k <= 0 then bflerrmsg 'sqrt!:
    else if bfzerop!: x then bfz!*
    else begin integer k7,ncut,nfig;  scalar dcut,half,dy,y,y0,u;
          k7 := k + 7;
          ncut := k7 - (order!: x + 1) / 2;
          half := bfhalf!*;    %JBM
          dcut := make!:ibf(2, - ncut);
          dy := make!:ibf(4, - ncut);
          %y0 := incprec!:(x,1);
          y0 := conv!:mt(x, 2);
          if remainder(ep!: y0, 2) = 0 then
                y0 := make!:ibf((2 + 3 * mt!: y0)/5,  ep!: y0/2)
           else y0 := make!:ibf((9 + 5 * mt!: y0)/10, (ep!: y0 - 1)/2);
          nfig := 1;
          while nfig < k7 or greaterp!:(abs!: dy, dcut) do
            << if (nfig := 2 * nfig) > k7 then nfig := k7;
               u := divide!:(x, y0, nfig);
               y := times!:(plus!:(y0, u), half);
               dy := difference!:(y, y0);
               y0 := y >>;
          return round!:mt(y, k);
    end;


symbolic procedure cbrt!:(x, k);
% This function calculates CBRT(x), the cube root
%      of "x", with the binary precision K, by Newton's
%      iteration method.
% X is a BIG-FLOAT representation of any real "x".
% K is a positive integer.
   if not fixp k or k <= 0 then bflerrmsg 'cbrt!:
   else if bfzerop!: x then bfz!*
   else if minusp!: x then minus!: cbrt!:(minus!: x, k)
   else begin integer k7, ncut, nfig, j;  scalar dcut, thre, dy, y, u;
          k7 := k + 7;
          ncut := k7 - (order!: x + 2) / 3;
          thre := bfthree!*;
          dcut := make!:ibf(2, - ncut);
          dy := make!:ibf(4, - ncut);
          y := conv!:mt(x, 3);
          if (j := remainder(ep!: y, 3)) = 0 then
               y := make!:ibf((12 + mt!: y ) / 10, ep!: y / 3)
           else if j = 1 or j = -2 then
                y := make!:ibf((17 + 4 * mt!: y)/16, (ep!: y - 1)/3)
           else y := make!:ibf((15 + 4 * mt!: y)/12, (ep!: y - 2)/3);
          nfig := 1;
          while nfig < k7 or greaterp!:(abs!: dy, dcut) do
            << if (nfig := 2 * nfig) > k7 then nfig := k7;
               u := cut!:mt(times!:(y, y), nfig);
               u := divide!:(x, u, nfig);
               j := order!:(u := difference!:(u, y)) + ncut - k7;
               dy := divide!:(u, thre, max(1, nfig + j));
               y := plus!:(y, dy) >>;
          return round!:mt(y, k);
    end;


symbolic procedure exp!:(x, k);
% This function calculates exp(x), the value of
%      the exponential function at the point "x",
%      with the binary precision K, by summing terms of
%      the Taylor series for exp(z), 0 < z < 1.
% X is a BINARY BIG-FLOAT representation of any real "x".
% K is a positive integer.
   if not fixp k or k <= 0 then bflerrmsg 'exp!:
   else if bfzerop!: x then bfone!*
   else begin integer k7, m;  scalar q, r, y, yq, yr;
          q := i2bf!:(m := conv!:bf2i(y := abs!: x));
          r := difference!:(y, q);
          k7 := k + msd!: m + 7;
          r := difference!:(y, q);
          if bfzerop!: q then yq := bfone!*
           else (yq := texpt!:(!:e k7, m) where !:bprec!: := k7);
          if bfzerop!: r then yr:=bfone!*
           else begin integer j, n;  scalar dcut, fctrial, ri, tm;
              dcut := make!:ibf(2, - k7);
              yr := ri := tm := bfone!*;
              m := 1;
              j := 0;
              while greaterp!:(tm, dcut) do
                << fctrial := i2bf!:(m := m * (j := j + 1));
                   ri := cut!:ep(times!:(ri, r), - k7);
                   n := max(1, k7 - order!: fctrial + order!: ri);
                   tm := divide!:(ri, fctrial, n);
                   yr := plus!:(yr,tm);
                   if remainder(j,10)=0 then yr := cut!:ep(yr, - k7) >>;
        end;
          y := cut!:mt(times!:(yq, yr), k + 1);
          return (if minusp!: x then divide!:(bfone!*, y, k)
                  else round!:mt (y,k));
    end;


symbolic procedure log!:(x, k);
% This function calculates log(x), the value of the
%      logarithmic function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for log(1+z), 0 < z < 0.10518.
% X is a BIG-FLOAT representation of "x", x > 0.
% K is a positive integer.
   if minusp!: x or bfzerop!: x or
     not fixp k or k <= 0 then bflerrmsg 'log!:
   else if equal!:(x,bfone!*) then bfz!*
   else begin integer k7,m;  scalar eee,es,sign,l,y,z;
          k7 := k + 7;
          eee := !:e k7;
          es := !:e0625 k7;
          if greaterp!:(x, bfone!*) then << sign := bfone!*; y := x >>
           else <>;
          if lessp!:(y, eee) then << m := 0; z := y >>
           else << if (m := (order!: y * 69) / 100) = 0 then z := y
                    else (z := divide!:(y, texpt!:(eee, m), k7)
                             where !:bprec!: := k7);
                    while greaterp!:(z, eee) do
                       << m := m+1; z := divide!:(z, eee, k7) >> >>;
          l := i2bf!: m;
          y := !:bf!-0!.0625;
          while greaterp!:(z, es) do
            << l := plus!:(l, y); z := divide!:(z, es, k7) >>;
          z := difference!:(z, bfone!*);
        begin integer n;  scalar dcut, tm, zi;
              y := tm := zi := z;
              z := minus!: z;
              dcut := make!:ibf(2, - k7);
              m := 1;
              while greaterp!:(abs!: tm, dcut) do
               << zi := cut!:ep(times!:(zi, z), - k7);
                  n := max(1, k7 + order!: zi);
                  tm := divide!:(zi,i2bf!:(m := m + 1), n);
                  y := plus!:(y, tm);
                  if zerop remainder(m,10) then y := cut!:ep(y,-k7)>>;
        end;
          y := plus!:(y, l);
          return round!:mt(times!:(sign, y), k);
    end;


symbolic procedure sin!:(x, k);
% This function calculates sin(x), the value of
%      the sine function at the point "x", with
%      the binary precision K, by summing terms of the
%      Taylor series for sin(z), 0 < z < PI/4.
% X is a BIG-FLOAT representation of any real "x".
% K is a positive integer.  (revised SLK)                         %<===
   if not fixp k or k <= 0 then bflerrmsg 'sin!:
   else if bfzerop!: x then bfz!*
   else if minusp!: x then minus!: sin!:(minus!: x, k)
   else begin integer k7, m;  scalar pi4, sign, q, r, y, !!scls;  %<===
           k7 := k + 7;
          m := preci!: x;
          pi4 := times!:(!:pi(k7 + m), !:bf!-0!.25);
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          sign := bfone!*;
          if m >= 8 then m := remainder(m, 8);
          if m >= 4 then << sign := minus!: sign; m := m - 4>>;
          if m = 0 then <>                  %<===
           else if onep m then go to m1
           else if m = 2 then go to m2
           else go to m3;;
      m1: r := cut!:mt(difference!:(pi4, r), k7);
          return times!:(sign, cos!:(r, k));
      m2: r := cut!:mt(r, k7);
          return times!:(sign, cos!:(r, k));
      m3: r := cut!:mt(difference!:(pi4, r), k7); !!scls := x;     %<===
    sn: x := if !!sclc then !!sclc else !!scls;                    %<===
        if x and lessp!:(r,times!:(x,make!:ibf(1, 3 - k)))         %<===
          then return bfz!* else                                   %<===
        begin integer j, n, ncut;  scalar dcut, fctrial, ri, tm;
              ncut := k7 - min(0, order!: r + 1);
              dcut := make!:ibf(2, - ncut);
              y := ri := tm := r;
              r := minus!: cut!:ep(times!:(r, r), - ncut);
              m := j := 1;
              while greaterp!:(abs!: tm, dcut) do
               << j := j + 2;
                  fctrial := i2bf!:(m := m*j*(j - 1));
                  ri := cut!:ep(times!:(ri, r), - ncut);
                  n := max(1,k7 - order!: fctrial + order!: ri);
                  tm := divide!:(ri, fctrial, n);
                  y := plus!:(y, tm);
                  if zerop remainder(j,20) then y := cut!:ep(y,-ncut)>>;
        end;
          return round!:mt(times!:(sign, y), k);
    end;

symbolic procedure cos!:(x, k);
% This function calculates cos(x), the value of
%      the cosine function at the point "x", with
%      the binary precision K, by summing terms of the
%      Taylor series for cos(z), 0 < z < PI/4.
% X is a BIG-FLOAT representation of any real "x".
% K is a positive integer.  (revised SLK)                          %<===
   if not fixp k or k <= 0 then bflerrmsg 'cos!:
    else if bfzerop!: x then bfone!*
    else if minusp!: x then cos!:(minus!: x, k)
    else begin integer k7, m;  scalar pi4, sign, q, r, y, !!sclc;  %<===
          k7 := k + 7;
          m := preci!: x;
          pi4 := times!:(!:pi(k7 + m), !:bf!-0!.25);
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          sign := bfone!*;
          if m >= 8 then m := remainder(m, 8);
          if m >= 4 then << sign := minus!: sign; m := m - 4 >>;
          if m >= 2 then sign := minus!: sign;
          if m = 0 then go to cs
           else if m = 1 then go to m1
           else if m = 2 then go to m2
           else go to m3;
      m1: r := cut!:mt(difference!:(pi4, r), k7); !!sclc := x;     %<===
          return times!:(sign, sin!:(r, k));
      m2: r := cut!:mt(r, k7); !!sclc := x;                        %<===
          return times!:(sign, sin!:(r, k));
      m3: r := cut!:mt(difference!:(pi4, r), k7);
    cs: begin integer j, n;  scalar dcut, fctrial, ri, tm;
              dcut := make!:ibf(2, - k7);
              y := ri := tm := bfone!*;
              r := minus!: cut!:ep(times!:(r, r), - k7);
              m := 1;
              j := 0;
              while greaterp!:(abs!: tm, dcut) do
               << j := j + 2;
                  fctrial := i2bf!:(m := m * j * (j - 1));
                  ri := cut!:ep(times!:(ri, r), - k7);
                  n := max(1, k7 - order!: fctrial + order!: ri);
                  tm := divide!:(ri, fctrial, n);
                  y := plus!:(y, tm);
                  if zerop remainder(j,20) then y := cut!:ep(y,-k7)>>;
        end;
          return round!:mt(times!:(sign, y), k);
    end;

symbolic procedure tan!:(x, k);
% This function calculates tan(x), the value of
%      the tangent function at the point "x",
%      with the binary precision K, by calculating
%         sin(x)  or  cos(x) = sin(PI/2-x).
% X is a BIG-FLOAT representation of any real "x",
% K is a positive integer.
   if not fixp k or k <= 0 then bflerrmsg 'tan!:
   else if bfzerop!: x then bfz!*
   else if minusp!: x then minus!: tan!:(minus!: x, k)
   else begin integer k7, m;  scalar pi4, sign, q, r;
          k7 := k + 7;
          m := preci!: x;
          pi4 := times!:(!:pi(k7 + m), !:bf!-0!.25);
          if lessp!:(x, pi4) then << m := 0; r := x >>
           else << m := conv!:bf2i(q := quotient!:(x, pi4));
                   r := difference!:(x, times!:(q, pi4)) >>;
          if m >= 4 then m := remainder(m, 4);
          if m >= 2 then sign := minus!: bfone!* else sign := bfone!*;
          if m = 1 or m = 3 then r := difference!:(pi4, r);
          r := cut!:mt(r, k7);
          if m = 0 or m = 3 then go to m03 else go to m12;
     m03: r := sin!:(r, k7);
          q := difference!:(bfone!*, times!:(r, r));
          q := sqrt!:(cut!:mt(q, k7), k7);
          return times!:(sign, divide!:(r, q, k));
     m12: r := sin!:(r, k7);
          q := difference!:(bfone!*, times!:(r, r));
          q := sqrt!:(cut!:mt(q, k7), k7);
          return times!:(sign, divide!:(q, r, k));
    end;

symbolic procedure asin!:(x, k);
% This function calculates asin(x), the value of
%      the arcsine function at the point "x",
%      with the binary precision K, by calculating
%         atan(x/SQRT(1-x**2))  by ATAN!:.
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of "x", IxI <= 1;
% K is a positive integer.
   if greaterp!:(abs!: x, bfone!*) or
     not fixp k or k <= 0 then bflerrmsg 'asin!:
   else if minusp!: x then minus!: asin!:(minus!: x, k)
   else begin integer k7;  scalar y;
          k7 := k + 7;
          if lessp!:(difference!:(bfone!*, x), make!:ibf(2, - k7))
            then return round!:mt(times!:(!:pi add1 k,bfhalf!*),k);
                 %JBM
          y := cut!:mt(difference!:(bfone!*, times!:(x, x)), k7);
          y := divide!:(x, sqrt!:(y, k7), k7);
          return atan!:(y, k);
    end;

symbolic procedure acos!:(x, k);
% This function calculates acos(x), the value of
%      the arccosine function at the point "x",
%      with the precision K, by calculating
%         atan(SQRT(1-x**2)/x)  if  x > 0  or
%         atan(SQRT(1-x**2)/x) + PI  if  x < 0.
%      The answer is in the range [0 , PI].
% X is a BIG-FLOAT representation of "x", IxI <= 1.
% K is a positive integer.
   if greaterp!:(abs!: x, bfone!*) or
     not fixp k or k <= 0 then bflerrmsg 'acos!:
   else begin integer k7;  scalar y;
          k7 := k + 7;
          if lessp!:(abs!: x, make!:ibf(2, - k7))  %%%%% 5 * base = 5*2
           then return round!:mt(times!:(!:pi add1 k,bfhalf!*),k);
                %JBM
          y := difference!:(bfone!*, times!:(x, x));
          y := cut!:mt(y, k7);
          y := divide!:(sqrt!:(y, k7), abs!: x, k7);
          return (if minusp!: x then
                   round!:mt(difference!:(!:pi(k + 1), atan!:(y, k)), k)
                  else atan!:(y, k) );
    end;

symbolic procedure atan!:(x, k);
% This function calculates atan(x), the value of the
%      arctangent function at the point "x", with
%      the precision K, by summing terms of the
%      Taylor series for atan(z)  if  0 < z < 0.419921875.
%      Otherwise the following identities are used:
%         atan(x) = PI/2 - atan(1/x)  if  1 < x  and
%         atan(x) = 2*atan(x/(1+SQRT(1+x**2)))
%            if  0.419921875 <= x <= 1.
%      The answer is in the range [-PI/2 , PI/2].
% X is a BIG-FLOAT representation of any real "x".
% K is a positive integer.
   if not fixp k or k <= 0 then bflerrmsg 'atan!:
   else if bfzerop!: x then bfz!*
   else if minusp!: x then minus!: atan!:(minus!: x, k)
   else begin integer k7;  scalar pi4, y, z;
          k7 := k + 7;
          pi4 := times!:(!:pi k7, !:bf!-0!.25);    %JBM
          if equal!:(x, bfone!*) then return round!:mt(pi4, k);
          if greaterp!:(x, bfone!*) then return
           round!:mt(difference!:(plus!:(pi4, pi4),
                               atan!:(divide!:(bfone!*,x,k7),k + 1)),k);
          if lessp!:(x, !:bf0!.419921875) then go to at;
          y := plus!:(bfone!*, cut!:mt(times!:(x, x), k7));
          y := plus!:(bfone!*, sqrt!:(y, k7));
          y := atan!:(divide!:(x, y, k7), k + 1);
          return round!:mt(times!:(y, bftwo!*), k);
    at: begin integer m, n, ncut;  scalar dcut, tm, zi;
              ncut := k7 - min(0, order!: x + 1);
              y := tm := zi := x;
              z := minus!: cut!:ep(times!:(x, x), - ncut);
              dcut := make!:ibf(2, - ncut);
              m := 1;
              while greaterp!:(abs!: tm, dcut) do
               << zi := cut!:ep(times!:(zi, z), - ncut);
                  n := max(1, k7 + order!: zi);
                  tm := divide!:(zi, i2bf!:(m := m + 2), n);
                  y := plus!:(y, tm);
                  if zerop remainder(m,20) then y := cut!:ep(y,-ncut)>>;
        end;
          return round!:mt(y, k)
    end;

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/rdelem.red0000644000175000017500000004744111526203062023571 0ustar  giovannigiovannimodule rdelem;  % Elementary functions in rounded domain.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


exports deg2rad!*, quotient!:, rad2deg!*, rdacos!*, rdacosd!*,
        rdacosh!*, rdacot!*, rdacotd!*, rdacoth!*, rdacsc!*, rdacscd!*,
        rdacsch!*, rdarg!*, rdasec!*, rdasecd!*, rdasech!*, rdasin!*,
        rdasind!*, rdasinh!*, rdatan!*, rdatan2!*, rdatan2d!*,
        rdatand!*, rdatanh!*, rdcbrt!*, rdcos!*, rdcosd!*, rdcosh!*,
        rdcot!*, rdcotd!*, rdcoth!*, rdcsc!*, rdcscd!*, rdcsch!*,
        rde!*, rdexp!*, rdexpt!*, rdhalf!*, rdhypot!*, rdlog!*,
        rdlog10!*, rdlogb!*, rdnorm!*, rdone!*, rdpi!*, rdsec!*,
        rdsecd!*, rdsech!*, rdsin!*, rdsind!*, rdsinh!*,
        rdsqrt!*, rdtan!*, rdtand!*, rdtanh!*, rdtwo!*, rdzero!*,
        texpt!:, texpt!:any;

imports !*f2q, abs!:, acos, acos!*, acosd, acosh, acot, acotd, acoth,
        acsc, acscd, acsch, asec, asecd, asech, asin, asin!*, asind,
        asinh, atan, atan!*, atan2, atan2d, atand, atanh, bflerrmsg,
        bfloat, bfp!:, bfsqrt, cbrt, conv!:bf2i, conv!:bf2i, conv!:mt,
        convprec, cos, cos!*, cosd, cosh, cot, cotd, coth, csc, cscd,
        csch, difbf, divbf, e!*, ep!:, eqcar, equal!:, exp, exp!*,
        exp!:, exptbf, geq, greaterp!:, hypot, i2rd!*, incprec!:,
        invbf, leq, leq!:, lessp!:, log, log!*, log10, log!:,
        logb, logfp, lshift, make!:ibf, minus!:, minusp!:, mk!*sq,
        mkround, mt!:, neq, pi!*, plubf, preci!:, rd!:minus,
        rd!:minusp, read!:num, rndbfon, round!*, round!:last,
        round!:mt, sec, secd, sech, sgn, simprd, sin, sin!*, sind,
        sinh, sqrt, sqrt!:, tan, tan!*, tand, tanh, terrlst, timbf,
        times!:;

fluid '(!:prec!: !:bprec!: !*!*roundbf);

global '(bfz!* bfone!* bften!* bfhalf!* !:180!* !:bf1!.5!* bfthree!*
 !:bf60!* epsqrt!* bftwo!* !!pii !!flprec !!rdprec !!shbinfl
 pi!/180 !180!/pi !!ee !!maxarg);

pi!/180 := !!pii/180;  !180!/pi := 180/!!pii;

fluid '(!*numval);

deflist('((exp rdexp!*) (expt rdexpt!*) (log rdlog!*) (sin rdsin!*)
   (cos rdcos!*) (tan rdtan!*) (asin rdasin!*) (acos rdacos!*)
   (atan rdatan!*) (sqrt rdsqrt!*) (sinh rdsinh!*) (cosh rdcosh!*)
   (sec rdsec!*) (csc rdcsc!*) (cot rdcot!*) (tanh rdtanh!*)
   (coth rdcoth!*) (sech rdsech!*) (csch rdcsch!*) (asinh rdasinh!*)
   (acosh rdacosh!*) (acot rdacot!*) (asec rdasec!*) (acsc rdacsc!*)
   (atanh rdatanh!*) (acoth rdacoth!*) (asech rdasech!*)
   (acsch rdacsch!*) (logb rdlogb!*) (log10 rdlog10!*) (ln rdlog!*)
   (atan2 rdatan2!*) (hypot rdhypot!*) % (cbrt rdcbrt!*)
   (deg2rad deg2rad!*) (rad2deg rad2deg!*) (deg2dms deg2dms!*)
   (rad2dms rad2dms!*) (dms2deg dms2deg!*) (dms2rad dms2rad!*)
   (norm rdnorm!*) (arg rdarg!*) (e rde!*) (pi rdpi!*)),
   '!:rd!:);

% deflist('((sind rdsind!*) (cosd rdcosd!*) (asind rdasind!*) (acosd
%    rdacosd!*) (tand rdtand!*) (cotd rdcotd!*) (atand rdatand!*) (acotd
%    rdacotd!*) (secd rdsecd!*) (cscd rdcscd!*) (asecd rdasecd!*) (acscd
%    rdacscd!*) (atan2d rdatan2d!*)),'!:rd!:);



for each n in '(exp sin cos tan asin acos atan sinh cosh  % log
    sec csc cot tanh coth sech csch asinh acosh acot asec acsc atanh
    acoth asech acsch logb log10 ln atan2 hypot
%   sind cosd asind acosd tand cotd atand acotd secd cscd asecd acscd
%   atan2d cbrt
    deg2rad rad2deg deg2dms rad2dms dms2deg dms2rad norm arg argd)
       do put(n,'simpfn,'simpiden);

flag('(dms2deg dms2rad),'listargp);

deflist('((dms2deg!* simpdms) (dms2rad!* simpdms)), 'simparg);

deflist('((atan2 2) (hypot 2) (atan2d 2) (logb 2)),
  'number!-of!-args);

flag('(acsc sind asind tand atand cotd acotd cscd acscd csch
       acsch deg2rad rad2deg),'odd);   % sgn.

flag('(cosd secd),'even);

flag('(cotd sech),'nonzero);

symbolic procedure rdexp!* u; mkround
  (if not atom x then exp!* x
   else if x>!!maxarg then <>
   else if x<-!!maxarg then 0.0 else exp x)
   where x=convprec u;

symbolic procedure rdsqrt!* u;
   mkround(if atom x then sqrt x else bfsqrt x)
   where x=convprec u;

symbolic procedure rdexpt!*(u,v);
   mkround
     (if not atom x then texpt!:any(x,y) else
       if zerop x then if zerop y then rederr "0**0 formed" else u else
      ((if z>!!maxarg then <>
        else if z<-!!maxarg then 0.0 else rexpt(x,y))
        where z=y*logfp bfloat abs x))
      where x=convprec u,y=convprec v;

symbolic procedure rdlog!* u;
   mkround(if atom x then log x else log!* x)
   where x=convprec u;

% symbolic procedure rdsgn!* u;
%   (if atom x then sgn x else sgn mt!: x) where x=round!* u;

symbolic procedure rdatan2!*(u,v);
   if !:zerop u and !:zerop v
     then rerror(arith,8,"0/0 formed")
    else (mkround(if atom x then atan2(x,y) else atan2!*(x,y))
          where x=convprec u,y=convprec v);

% symbolic procedure rdatan2d!*(u,v);
%    mkround(if atom x then atan2d(x,y) else rad2deg!: atan2!*(x,y))
%    where x=convprec u,y=convprec v;

symbolic procedure atan2!*(y,x);
   if mt!: x=0 then if (y := mt!: y)=0 then bfz!* else
      <>
   else <<(if mt!: x>0 then a
      else if mt!: y<0 then difbf(a,pi!*())
         else plubf(a,pi!*()))
     where a=atan!* divbf(y,x)>>;

% symbolic procedure atan2d!*(y,x);
%    if mt!: x=0 then if (y := mt!: y)=0 then bfz!* else
%       <>
%    else <<(if mt!: x>0 then a
%       else if mt!: y<0 then difbf(a,!:180!*) else plubf(a,!:180!*))
%      where a=rad2deg!: atan!* divbf(y,x)>>;

symbolic procedure rde!*; mkround if !*!*roundbf then e!*() else !!ee;

symbolic procedure rdpi!*;
   mkround if !*!*roundbf then pi!*() else !!pii;

symbolic procedure pi!/2!*; timbf(bfhalf!*,pi!*());

symbolic procedure deg2rad!* u;
   mkround(if atom x then deg2rad x else deg2rad!: x)
   where x=convprec u;

symbolic procedure rad2deg!* u;
   mkround(if atom x then rad2deg x else rad2deg!: x)
   where x=convprec u;

symbolic procedure deg2rad x; x*pi!/180;

symbolic procedure rad2deg x; x*!180!/pi;

symbolic procedure deg2rad!: x; divbf(timbf(x,pi!*()),!:180!*);

symbolic procedure rad2deg!: x; divbf(timbf(x,!:180!*),pi!*());

symbolic procedure rdsin!* u;
   mkround (if atom x then sin x else sin!* x)
   where x=convprec u;

% symbolic procedure rdsind!* u;
%    mkround (if atom x then sind x else sin!* deg2rad!: x)
%    where x=convprec u;

symbolic procedure rdcos!* u;
   mkround(if atom x then cos x else cos!* x)
   where x=convprec u;

% symbolic procedure rdcosd!* u;
%    mkround(if atom x then cosd x else cos!* deg2rad!: x)
%   where x=convprec u;

symbolic procedure rdtan!* u;
   mkround(if atom x then tan x else tan!* x)
   where x=convprec u;

% symbolic procedure rdtand!* u;
%    mkround(if atom x then tand x else tan!* deg2rad!: x)
%   where x=convprec u;

symbolic procedure rdasin!* u;
   mkround(if atom x then asin x else asin!* x)
   where x=convprec u;

% symbolic procedure rdasind!* u;
%    mkround(if atom x then asind x else rad2deg!: asin!* x)
%    where x=convprec u;

symbolic procedure rdacos!* u;
   mkround(if atom x then acos x else acos!* x)
   where x=convprec u;

% symbolic procedure rdacosd!* u;
%    mkround(if atom x then acosd x else rad2deg!: acos!* x)
%    where x=convprec u;

symbolic procedure rdatan!* u;
   mkround(if atom x then atan x else atan!* x)
   where x=convprec u;

% symbolic procedure rdatand!* u;
%    mkround(if atom x then atand x else rad2deg!: atan!* x)
%   where x=convprec u;

symbolic procedure rdsinh!* u;
   mkround(if atom x then sinh x else sinh!* x)
   where x=convprec u;

symbolic procedure rdcosh!* u;
   mkround(if atom x then cosh x else cosh!* x)
   where x=convprec u;

% these redefine functions that are in bfelem, and are faster.

symbolic procedure sinh!* x;
   timbf(bfhalf!*,difbf(y,invbf y)) where y=exp!* x;

symbolic procedure cosh!* x;
   timbf(bfhalf!*,plubf(y,invbf y)) where y=exp!* x;


% no bfelem functions after this point.

symbolic procedure rdsec!* u;
   mkround(if atom x then sec x else invbf cos!* x)
   where x=convprec u;

% symbolic procedure rdsecd!* u;
%    mkround(if atom x then secd x else invbf cos!* deg2rad!: x)
%    where x=convprec u;

symbolic procedure rdcsc!* u;
   mkround(if atom x then csc x else invbf sin!* x)
   where x=convprec u;

% symbolic procedure rdcscd!* u;
%    mkround(if atom x then cscd x else invbf sin!* deg2rad!: x)
%   where x=convprec u;

symbolic procedure rdcot!* u;
   mkround(if atom x then cot x else tan!* difbf(pi!/2!*(),x))
   where x=convprec u;

% symbolic procedure rdcotd!* u;
%   mkround(if atom x then cotd x else tan!* difbf(pi!/2!*(),
%           deg2rad!: x))
%    where x=convprec u;

symbolic procedure rdtanh!* u;
   mkround(if atom x then tanh x else divbf(sinh!* x,cosh!* x))
   where x=convprec u;

symbolic procedure rdcoth!* u;
   mkround(if atom x then coth x else divbf(cosh!* x,sinh!* x))
   where x=convprec u;

symbolic procedure rdsech!* u;
   mkround(if atom x then sech x else invbf cosh!* x)
   where x=convprec u;

symbolic procedure rdcsch!* u;
   mkround(if atom x then csch x else invbf sinh!* x)
   where x=convprec u;

symbolic procedure rdasinh!* u;
   mkround(if atom x then asinh x else asinh!* x)
   where x=convprec u;

symbolic procedure rdacosh!* u;
   mkround(if atom x then acosh x else acosh!* x)
   where x=convprec u;

symbolic procedure asinh!* x; begin scalar s;
   if minusp!: x then x := minus!: x else s := t;
   x := if leq!:(x,epsqrt!*) then x
      else log!* plubf(x,
         if lessp!:(x,bftwo!*) then bfsqrt plubf(timbf(x,x),bfone!*)
         else if lessp!:(invbf x,epsqrt!*) then x
         else timbf(x,bfsqrt plubf(bfone!*,divbf(bfone!*,timbf(x,x)))));
   return if s then x else minus!: x end;

symbolic procedure acosh!* x;
   if lessp!:(x,bfone!*) then terrlst(x,'acosh)
   else log!* plubf(x,if leq!:(invbf x,epsqrt!*) then x
      else timbf(x,bfsqrt difbf(bfone!*,divbf(bfone!*,timbf(x,x)))));

symbolic procedure rdacot!* u;
   mkround(if atom x then acot x
      else difbf(pi!/2!*(),atan!* x))
   where x=convprec u;

% symbolic procedure rdacotd!* u;
%   mkround(if atom x then acotd x
%       else rad2deg!: difbf(pi!/2!*(),atan!* x))
%    where x=convprec u;

symbolic procedure rdasec!* u;  % not yet
   mkround(if atom x then asec x else
      difbf(pi!/2!*(),asin!* invbf x))
   where x=convprec u;

% symbolic procedure rdasecd!* u;  % not yet
%    mkround(if atom x then asecd x else
%       rad2deg!: difbf(pi!/2!*(),asin!* invbf x))
%    where x=convprec u;

symbolic procedure rdacsc!* u;
   mkround(if atom x then acsc x else asin!* invbf x)
   where x=convprec u;

% symbolic procedure rdacscd!* u;
%   mkround(if atom x then acscd x else rad2deg!: asin!* invbf x)
%   where x=convprec u;

symbolic procedure rdatanh!* u;
   mkround(if atom x then atanh x else atanh!* x)
   where x=convprec u;

symbolic procedure atanh!* x;
   if not greaterp!:(bfone!*,abs!: x) then terrlst(x,'atanh)
   else if leq!:(abs!: x,epsqrt!*) then x
   else timbf(bfhalf!*,
      log!* divbf(plubf(bfone!*,x),difbf(bfone!*,x)));

symbolic procedure rdacoth!* u;
   mkround(if atom x then acoth x else atanh!* invbf x)
   where x=convprec u;

symbolic procedure rdasech!* u;   % not from here down
   mkround(if atom x then asech x
      else if leq!:(x,bfz!*) or greaterp!:(x,bfone!*)
         then terrlst(x,'asech) else acosh!* invbf x)
   where x=convprec u;

symbolic procedure rdacsch!* u;
   mkround(if atom x then acsch x
      else if mt!: x=0 then terrlst(x,'acsh) else asinh!* invbf x)
   where x=convprec u;

symbolic procedure rdlogb!*(u,v);
   mkround(if atom x then logb(x,b) else logb!*(x,b))
   where x=convprec u,b=convprec v;

symbolic procedure rdlog10!* u;
   mkround(if atom x then log10 x else logb!*(x,bften!*))
   where x=convprec u;

symbolic procedure logb!* (x,b); %log x to base b;
   begin scalar a,s;
      a := greaterp!:(x,bfz!*);
      s := not(leq!:(b,bfz!*) or equal!:(b,bfone!*));
      if a and s then return divbf(log!* x,log!* b)
         else terrlst((if a then list ('base,b)
            else if s then list('arg,x) else list(x,b)),'logb) end;

% symbolic procedure rdcbrt!* u;
%    mkround(if atom x then cbrt x else cbrt!* x)
%    where x=convprec u;

% symbolic procedure cbrt!* x;
%    begin scalar s,l,g,u,nx,r; u := bfone!*;
%          if mt!: x=0 or equal!:(abs!: x,u) then return x
%          else if minusp!: x then x := minus!: x else s := t;
%          if lessp!:(x,u) then <>
%             else if equal!:(x,u) then go to ret;
%          nx := '!:bf!: .
%             <>;
%    loop: r := nx;
%          nx := plubf(divbf(r,!:bf1!.5!*),
%             divbf(x,timbf(r,timbf(r,bfthree!*))));
%          if g and leq!:(r,nx) then go to ret;
%          g := t; go to loop;
%     ret: if l then nx := divbf(u,nx);
%          return if s then nx else minus!: nx end;

symbolic procedure rdhypot!*(u,v);
   mkround(if atom p then hypot(p,q) else hypot!*(p,q))
   where p=convprec u,q=convprec v;

symbolic procedure hypot!*(p,q);
 % Hypot(p,q)=sqrt(p*p+q*q) but avoids intermediate swell.
 begin scalar r;
   if minusp!: p then p := minus!: p; if minusp!: q then q := minus!: q;
   if mt!: p=0 then return q else if mt!: q=0 then return p
   else if lessp!:(p,q) then <>;
   r := divbf(q,p);
   return if lessp!:(r,epsqrt!*) then p
      else timbf(p,bfsqrt plubf(bfone!*,timbf(r,r))) end;

symbolic procedure simpdms l;
   % Converts argument of form ({d,m,s}) to rd ((d m s)) if possible.
   if cdr l or atom (l := car l) or not eqcar(l,'list)
      or length l neq 4 then nil else
   begin scalar fl;
      l := for each a in cdr l collect
          if not (null(a := simprd list a) and (fl := t))
             then a := car a;
      if not fl then return list l end;

symbolic procedure round2a!* a; if atom a then a else round!* a;

symbolic procedure dms2rad!* u; deg2rad!* dms2deg!* u;

symbolic procedure dms2deg!* u;
   mkround(if atom caddr l then dms2deg l else dms2deg!: l)
   where l=list(round2a!* car u,round2a!* cadr u,round!* caddr u);

symbolic procedure dms2deg l; ((caddr l/60.0+cadr l)/60.0+car l);

symbolic procedure dms2deg!: l;
   plubf(bfloat car l,divbf(plubf(bfloat cadr l,
      divbf(bfloat caddr l,!:bf60!*)),!:bf60!*));

symbolic procedure rad2dms x; deg2dms rad2deg x;

symbolic procedure rad2dms!* u; deg2dms!* rad2deg!* u;

symbolic procedure deg2dms!* u;
   mklist3!*(if atom x then deg2dms x else deg2dms!: x)
   where x=round2a!* u;

symbolic procedure mklist3!* x; % floats seconds if not integer.
   'list . list(car x,cadr x,
      <<(if atom s and zerop(s-fix s) then fix s
         else if not atom s and integerp!: s then conv!:bf2i s
         else mk!*sq !*f2q mkround s) where s=caddr x>>);

symbolic procedure deg2dms x; % dms output in form list(d,m,s);
   begin integer d,m;
%     m := fix(x := 60.0*(x-(d := fix2 x)));
      m := fix(x := 60.0*(x-(d := fix x)));
      return list(d,m,60.0*(x-m)) end;

symbolic procedure deg2dms!: x; % dms output in form list(d,m,s).
   begin integer d,m;
      d := conv!:bf2i x;
      m := conv!:bf2i(x := timbf(!:bf60!*,difbf(x,bfloat d)));
      return list(d,m,timbf(!:bf60!*,difbf(x,bfloat m))) end;

symbolic procedure rdnorm!* u; if rd!:minusp u then rd!:minus u else u;

symbolic procedure rdarg!* u;
   if rd!:minusp u then rdpi!*() else rdzero!*();

% the following bfloat definitions are needed in addition to files
% smbflot and bfelem.red to support rdelem.

global '(!:bfone!* bftwo!* bfhalf!* bfz!* !:bf!-0!.25);

symbolic procedure rdone!*; if !*!*roundbf then bfone!* else 1.0;

symbolic procedure rdtwo!*; if !*!*roundbf then bftwo!* else 2.0;

symbolic procedure rdhalf!*; if !*!*roundbf then bfhalf!* else 0.5;

symbolic procedure rdzero!*; if !*!*roundbf then bfz!* else 0.0;

symbolic procedure texpt!:(nmbr, k);
% This function calculates the Kth power of "n" up to the
% binary precision specified by !:BPREC!:. %SK
% NMBR is a BINARY BIG-FLOAT representation of "n" and K an integer.
   if not fixp k then bflerrmsg 'texpt!:  % use texpt!:any in this case.
    else if k=0 then bfone!*
    else if k=1 then nmbr
    else if k<0 then invbf texpt!:(nmbr,-k) %SK
    else exptbf(nmbr,k,bfone!*); %SK

symbolic procedure quotient!:(n1, n2);
% This function calculates the integer quotient of "n1"
%      and "n2", just as the "QUOTIENT" for integers does.
% **** For calculating the quotient up to a necessary
% ****      precision, please use DIVIDE!:.
% N1 and N2 are BIG-FLOAT representations of "n1" and "n2".
begin integer e1, e2;
  if (e1 := ep!: n1) = (e2 := ep!: n2) then return
             make!:ibf(mt!: n1 / mt!: n2, 0)
   else if e1 > e2 then return
             quotient!:(incprec!:(n1, e1 - e2) , n2)
   else return
             quotient!:(n1, incprec!:(n2, e2 - e1));
end$

symbolic procedure texpt!:any(x, y);
  %modified by SK to use bfsqrt and exp!*, invbf and timbf.
% This function calculates the power x**y, where "x"
%      and "y" are any numbers.  The precision of
%      the result is specified by !:PREC!:. % SK
% **** For a negative "x", this function returns
% ****      -(-x)**y unless "y" is an integer.
% X is a BIG-FLOAT representation of "x".
% Y is either an integer, a floating-point number,
%      or a BIG-FLOAT number, i.e., a BIG-FLOAT
%      representation of "y".
    if equal!:(x,e!*()) then exp!* bfloat y
    else if fixp y then texpt!:(x, y)
    else if integerp!: y then texpt!:(x,conv!:bf2i y)
    else if not(bfp!: y or bfp!:(y := read!:num y))
     then bflerrmsg 'texpt!:any     % read!:num probably not necessary.
    else if minusp!: y then invbf texpt!:any(x,minus!: y) %SK
    else if equal!:(y,bfhalf!*) then bfsqrt x   %SK
    else if equal!:(y,!:bf!-0!.25) then bfsqrt bfsqrt x   %SK
    else begin integer n;  scalar xp, yp;
          n := (if !:bprec!: then !:bprec!:
                else max(preci!: x, preci!: y));
%          if minusp!: x then xp:=minus!: x else xp := x;
          if minusp!: x then bflerrmsg 'texpt!:any
           else xp := x;
          if integerp!: times!:(y,bftwo!*) then
             << xp := incprec!:(xp, 1);
                yp := texpt!:(xp, conv!:bf2i y);
                yp := times!:(yp, sqrt!:(xp, n + 1));
                yp := round!:mt(yp, n) >>
          else
             << yp := timbf(y, log!:(xp, n + 1)); %SK
                yp := exp!:(yp, n) >>;
          return (if minusp!: x then minus!: yp else yp);
     end;

symbolic procedure integerp!: x;
% This function returns T if X is a BINARY BIG-FLOAT
%      representing an integer, else it returns NIL.
% X is any LISP entity.
bfp!: x and
  (ep!: x >= 0 or
    preci!: x > - ep!: x and remainder(mt!: x,lshift(1,-ep!: x)) = 0);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/arith.rlg0000644000175000017500000007675011527635055023463 0ustar  giovannigiovanniFri Feb 18 21:27:12 2011 run on win32
% Tests of REDUCE Arithmetic.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Copyright (c) 1987, 1988, 1989, 1991, Stanley L. Kameny.
% Copyright (c) 1998, Anthony C. Hearn.
% All Rights Reserved.

% This test file is a combination of three tests files from versions
% 3.6 or earlier: math, rounded and complex.


% Simple tests of rounded arithmetic.

% Tests in the exact mode.

x := 1/2;


      1
x := ---
      2


y := x + 0.7;


      6
y := ---
      5


% Tests in approximate mode.

on rounded;



y;


1.2
   % As expected not converted to approximate form.

z := y+1.2;


z := 2.4


z/3;


0.8


% Let's raise this to a high power.

ws^24;


0.00472236648287


% Now a high exponent value.

% 10.2^821;

% Elementary function evaluation.

cos(pi);


 - 1


symbolic ws;


(!*sq ((!:rd!: . -1.0) . 1) t)


z := sin(pi);


z := 1.22460635382e-16


symbolic ws;


(!*sq ((!:rd!: . 1.2246063538224e-16) . 1) t)


% Handling very small quantities.

% With normal defaults, underflows are converted to 0.

exp(-100000.1**2);


0


% However, if you really want that small number, roundbf can be used.

on roundbf;



exp(-100000.1**2);


1.18441281937e-4342953505


off roundbf;



% Now let us evaluate pi.

pi;


3.14159265359


% Let us try a higher precision.

prec0 := precision 50;


prec0 := 12


pi;


3.1415926535897932384626433832795028841971693993751


% Now find the cosine of pi/6.

cos(ws/6);


0.86602540378443864676372317075293618347140262690519


% This should be the sqrt(3)/2.

ws**2;


0.75



% Here are some well known examples which show the power of this system.

precision 10;


50


% This should give the usual default again.

let xx=e**(pi*sqrt(163));



let yy=1-2*cos((6*log(2)+log(10005))/sqrt(163));



% First notice that xx looks like an integer.

xx;


2.625374126e+17


% And that yy looks like zero.

yy;


0


% But of course it's an illusion.

precision 50;


10


xx;


2.6253741264076874399999999999925007259719818568888e+17


yy;


 - 1.2815256559456092775159749532170513334408547400481e-16


% Now let's look at an unusual way of finding an old friend.

procedure agm;
   begin scalar a,b,u,x,y,p,pn;
      a := 1; b := 1/sqrt 2; u:= 1/4; x := 1$ pn := 4;
      repeat <
    ",sind float i**2+cosd float i**2;
                       terpr(i,4)>>;

  0->1.0
  1->1.0  2->1.0  3->1.0  4->1.0
  5->1.0  6->1.0  7->1.0  8->1.0
  9->1.0  10->1.0  11->1.0  12->1.0
  13->1.0  14->1.0  15->1.0  16->1.0
  17->1.0  18->1.0  19->1.0  20->1.0
  21->1.0  22->1.0  23->1.0  24->1.0
  25->1.0  26->1.0  27->1.0  28->1.0
  29->1.0  30->1.0  31->1.0  32->1.0
  33->1.0  34->1.0  35->1.0  36->1.0
  37->1.0  38->1.0  39->1.0  40->1.0
  41->1.0  42->1.0  43->1.0  44->1.0
  45->1.0
nil


% #2: Quadrant test of sind, cosd: proper answers + +,+ -,- -,- +.

begin scalar a;
    a:= sind 45.0;
    for i:= 0.0:3.0 do
       <>
  end$

 1.0 1.0
 1.0 -1.0
 -1.0 -1.0
 -1.0 1.0


% #3: Scaling test: all values should be 1 exactly.

begin scalar a; a:= cosd 60.0;
%  for i:= -10.0:10.0 do write fix(cosd(60+i*360)/a)," "
   for i:= -10.0:10.0 do write round(cosd(60+i*360)/a)," "
 end$

1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 

% #4: Test of radians -> degrees evaluation: ideal values 1.0.

array a(6)$



begin
   for i:=1:6 do  a(i):=sind(15.0*i);
   for i:=1:6 do <>
 end$

1.0  1.0  1.0  
1.0  1.0  1.0  


% #5: Test of tand*cotd: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>;
   terpri()
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  


% #6: Test of secd**2-tand**2: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  

% #7: Test of cscd**2-cotd**2: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  

% #8: Test of asind+acosd: ideal values 1.0.

begin write "sind and cosd"; terpri();
   for i:=-10:10 do
      <>;
   write "sin and cos";terpri();
   for i:=-10:10 do
      <>
 end$

sind and cosd
1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
sin and cos
1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #9: Test of atand+acotd: ideal values 1.0.

begin scalar x; write "tand, atand and acotd"; terpri();
   for i:=-80 step 10 until 80 do
   <>;
     terpri();
   write "tan, atan and acot";terpri();
   for i:=-80 step 10 until 80 do
      <>
 end$

tand, atand and acotd
1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  
tan, atan and acot
1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  

% #10: Test of atand tand: ideal values i for i:=-9:89.

begin
   for i:=-9:89 do
      <",if i=0 then 1.0 else atand tand float i;
        terpr(i,4)>>
 end$

 -9->-9.0 -8->-8.0
 -7->-7.0 -6->-6.0 -5->-5.0 -4->-4.0
 -3->-3.0 -2->-2.0 -1->-1.0 0->1.0
 1->1.0 2->2.0 3->3.0 4->4.0
 5->5.0 6->6.0 7->7.0 8->8.0
 9->9.0 10->10.0 11->11.0 12->12.0
 13->13.0 14->14.0 15->15.0 16->16.0
 17->17.0 18->18.0 19->19.0 20->20.0
 21->21.0 22->22.0 23->23.0 24->24.0
 25->25.0 26->26.0 27->27.0 28->28.0
 29->29.0 30->30.0 31->31.0 32->32.0
 33->33.0 34->34.0 35->35.0 36->36.0
 37->37.0 38->38.0 39->39.0 40->40.0
 41->41.0 42->42.0 43->43.0 44->44.0
 45->45.0 46->46.0 47->47.0 48->48.0
 49->49.0 50->50.0 51->51.0 52->52.0
 53->53.0 54->54.0 55->55.0 56->56.0
 57->57.0 58->58.0 59->59.0 60->60.0
 61->61.0 62->62.0 63->63.0 64->64.0
 65->65.0 66->66.0 67->67.0 68->68.0
 69->69.0 70->70.0 71->71.0 72->72.0
 73->73.0 74->74.0 75->75.0 76->76.0
 77->77.0 78->78.0 79->79.0 80->80.0
 81->81.0 82->82.0 83->83.0 84->84.0
 85->85.0 86->86.0 87->87.0 88->88.0
 89->89.0

% #11: Test of acot cotd: ideal values 10*i for i:=1:17.

begin
   for i:=10 step 10 until 170 do
   <",acotd cotd i; terpr(i,40)>>; terpri();terpri() end$

 10->10.0 20->20.0 30->30.0 40->40.0
 50->50.0 60->60.0 70->70.0 80->80.0
 90->90.0 100->100.0 110->110.0 120->120.0
 130->130.0 140->140.0 150->150.0 160->160.0
 170->170.0



% #12: Test of asind sind: ideal values 10*i for i:=-9:9.

begin
   for i:=-90 step 10 until 90 do
      <",asind sind float i; terpr(i,40)>>
 end$

 -90->-90.0 -80->-80.0
 -70->-70.0 -60->-60.0 -50->-50.0 -40->-40.0
 -30->-30.0 -20->-20.0 -10->-10.0 0->0.0
 10->10.0 20->20.0 30->30.0 40->40.0
 50->50.0 60->60.0 70->70.0 80->80.0
 90->90.0

% #13: Test of acosd cosd: ideal values 10*i for i:=1:18.

begin
   for i:=10 step 10 until 180 do
      <",acosd cosd float i; terpr(i,40)>>
 end$

 10->10.0 20->20.0 30->30.0 40->40.0
 50->50.0 60->60.0 70->70.0 80->80.0
 90->90.0 100->100.0 110->110.0 120->120.0
 130->130.0 140->140.0 150->150.0 160->160.0
 170->170.0 180->180.0

% #14: Test of acscd cscd: ideal values 10*i for i:=-9:9, except
%       error for i=0.

begin
   for i:=-90 step 10 until 90 do
      <",if i=0 then "error" else acscd cscd float i;
        terpr(i,40)>>
 end$

 -90->-90.0 -80->-80.0
 -70->-70.0 -60->-60.0 -50->-50.0 -40->-40.0
 -30->-30.0 -20->-20.0 -10->-10.0 0->error
 10->10.0 20->20.0 30->30.0 40->40.0
 50->50.0 60->60.0 70->70.0 80->80.0
 90->90.0

% #15: Test of asecd secd: ideal values 10*i for i :=0:18. except
%       error for i=9.

begin
   for i:=0 step 10 until 180 do
      <",if i=90 then "error" else asecd secd float i;
        terpr(i,40)>>
 end$

 0->0.0
 10->10.0 20->20.0 30->30.0 40->40.0
 50->50.0 60->60.0 70->70.0 80->80.0
 90->error 100->100.0 110->110.0 120->120.0
 130->130.0 140->140.0 150->150.0 160->160.0
 170->170.0 180->180.0

%*********************************************************************
%**  ===Exp,Log,Sqrt,Cbrt, and Expt  Function tests===
%*********************************************************************

% #16: Test of properties of exp function: ideal results 1.0.

array b(5)$



begin scalar x; x:=0;
   write "multiplicative property";terpri();
   for i:=0:5 do b(i):=1+i/6.0; for i:=0:5 do for j:=i:5 do
      <>
 end$

multiplicative property
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0

% #17: Various properties of exp: ideal results 1.0.

begin write "inverse property"$ terpri()$
   for i:=1:5 do write "  ",exp(b(i))*exp(-b(i));terpri();
   write "squares"; terpri();
      for i:=-10:10 do
         <>;
   write "cubes"; terpri();
      for i:=-10:10 do
         <>
 end$

inverse property
  1.0  1.0  1.0  1.0  1.0
squares
  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
cubes
  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0
  1.0  1.0  1.0  1.0  1.0


% #18: Test of log exp: ideal results 1.0.

begin for i:=-5:5 do
   <>
 end$

1.0  
1.0  1.0  1.0  1.0  0/0  
1.0  1.0  1.0  1.0  1.0  


% #19: Test of log10 expt(10.0,i): ideal results 1.0.

begin scalar i; write "small values i:=-5:5"; terpri();
   for j:=-5:5 do
      <>;
   write "large i=2**j where j:=0:6"; terpri();
   for j:=0:5 do
      <>;
        terpri();
        write "noninteger values of i=j/10.0 where j:=1:20";terpri();
        for j:=1:20 do
            <>
 end$

small values i:=-5:5
1.0  
1.0  1.0  1.0  1.0  zero  
1.0  1.0  1.0  1.0  1.0  
large i=2**j where j:=0:6
1.0  
1.0  1.0  1.0  1.0  1.0  

noninteger values of i=j/10.0 where j:=1:20
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #20: Test of properties of expt(x,i)*(expt(x,-i). ideal result 1.0.

begin integer j;
   for x:=2:6 do for i:=2:6 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #21: Test of expt(-x,i)/expt(x,i) for fractional i.

begin integer j,k; write "odd numerator. ideal result -1.0"; terpri();
   for i:=1:10 do
      <>;
   write "even numerator. ideal result 1.0"; terpri();
   for i:=1:10 do
      <>
 end$

odd numerator. ideal result -1.0
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
even numerator. ideal result 1.0
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #22: Test of properties of ln or log or logb:
%      inverse argument: ideal result -1.0.

begin integer x;
   for i:=2:5 do for j:= 2:10 do
      <>
 end$

-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  -1.0  -1.0  -1.0  -1.0  
-1.0  

% #23: Test of log(a*b) = log a+log b: ideal result 1.0.

begin integer x;
   for i:=1:5 do for j:=i:5 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #24: Test of sqrt x*sqrt x/x for x:=5i*(5i/3)**i where i:=1:20
%      (test values strictly arbitrary): ideal results 1.0.

begin scalar x,s;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #25: Test of cbrt x**3/x for x:=5i*(5i/3)**i where i:=-9:10
%      (test values strictly arbitrary):ideal results 1.0.

begin scalar x,s;
   for i:=-9:10 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


%*********************************************************************
%**  ===Hyperbolic Function Tests===
%*********************************************************************

% #26: Test of sinh x+ cosh x= exp x: ideal results 1.0.

begin scalar x;
   for i:=1:10 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #27: Test of cosh x-sinh x= exp(-x): ideal results 1.0.

begin scalar x;
   for i:=1:10 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #28: Test of (cosh x)**2-(sinh x)**2: ideal results 1.0.

begin scalar x$
   for i:=1:10 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #29: Test of tanh*cosh/sinh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #30: Test of tanh*coth: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #31: Test of sech*cosh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #32: Test of csch*sinh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #33: Test of asinh sinh: ideal results 1.0.

begin scalar x; for i:=1:20 do
   <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #34: Test of acosh cosh: ideal results 1.0.  However, acosh x
%      loses accuracy as x -> 1 since d/dx cosh x -> 0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  0.99999999999999  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #35: Test of cosh acosh:ideal results 1.0.

begin scalar x;
   for i:=1:50 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #36: Test of atanh tanh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #37: Test of acoth coth: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #38: Test of asech sech: ideal results 1.0.  However, asech x
%      loses accuracy as x -> 1 since d/dx sech x -> 0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  0.99999999999999  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


% #39: Test of acsch csch: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1  
1.0  1.0  1.0  1.0  1.0  
1.0  1.0  1.0  1.0  1.0  


end;


Time for test: 31 ms, plus GC time: 16 ms
@@@@@ Resources used: (0 0 59 71)
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/rounded.red0000644000175000017500000004604711526203062023762 0ustar  giovannigiovannimodule rounded; % *** Support for Arbitrary Rounded Arithmetic.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Last updated: 23 June 1993.

% Copyright (c) 2000, Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment this module defines a rounded object as a list with two fields:

      (.).

The  depends on the precision.  It is either a floating point
number or the stripped bfloat (mt . ep);

exports chkint!*, chkrn!*, convprec, convprec!*, deg2rad!*,
        i2rd!*, logfp, mkround, rd!:difference, rd!:minus, rd!:minusp,
        rd!:onep, rd!:plus, rd!:prep, rd!:prin, rd!:quotient,
        rd!:simp, rd!:times, rd!:zerop, rdprep1, rdqoterr, rdzchk,
        rndbfon, round!*, roundbfoff, roundbfon, roundconstants,
        safe!-fp!-times;

imports !*d2q, !:difference, !:minus, !:minusp, !:zerop, abs!:, aeval,
        apply1, bf2flr, bfdiffer, bfexplode0, bfinverse, bflessp,
        bfloat, bfminus, bfminusp, bfprin!:, bftrim!:, bfzerop!:,
        bfzp, ceiling, copyd, deg2rad!*, difbf, divbf, dmoderr,
        ep!:, eqcar, equal!:, errorp, errorset!*, fl2int,
        fl2rd, float!-bfp, floor, ft2rn1, geq, greaterp!:, grpbf,
        i2bf!:, initdmode, invbf, leq, lessp!:, log, lprim, lshift,
        make!:ibf, make!:rd, minus!:, minusp!:, mkquote, msgpri, mt!:,
        neq, normbf, off1, on1, over, plubf, preci!:, r2bf, rd2fl,
        rd!:forcebf, realrat, rerror, retag, rmsubs, round!:mt, setk,
        sqrt, timbf, times!:, union;

fluid '(!:prec!: !:bprec!: !:print!-prec!: minprec!# rootacc!#!#);

fluid '(dmode!* !*bfspace !*numval !*roundbf !*!*roundbf !*norndbf);

fluid '(!*noconvert);

global '(bfone!* epsqrt!* log2of10);

global '(domainlist!* !!nfpd !!nbfpd !!flprec !!rdprec mxflbf!!
         mnflbf!!);

global '(!!plumax !!plumin !!timmax !!timmin !!maxflbf !!minflbf
         !!fleps1 !!fleps2 !!flint !!maxbflexp log2 !!maxarg);

global '(rd!-tolerance!* cr!-tolerance!* yy!! bfz!* !!smlsin);

switch rounded;

%Set value for !!flprec. It never changes.
!!flprec := !!nfpd - 3;

!!smlsin := 10.0^-(2+!!flprec);

symbolic procedure logfp x;
  % floating log of x**(1/n) using bfloat logic as boost.
  (log(m/float lshift(1,p))+(p+ep!: x)*log2)
    where p=(preci!: x - 1) where m=mt!: x;

symbolic procedure roundconstants;
   <>;

switch bfspace,numval,roundbf; % norndbf.

!*bfspace := nil;
!*numval := t;

put('roundbf,'simpfg,'((t (roundbfon)) (nil (roundbfoff))));

symbolic procedure roundbfon; !*!*roundbf := t;

symbolic procedure roundbfoff; !*!*roundbf := !!rdprec > !!flprec;

%  put('rounded,'package!-name,'arith);  % Use if ARITH autoloaded.

domainlist!* := union('(!:rd!:),domainlist!*);

put('rounded,'tag,'!:rd!:);
put('!:rd!:,'dname,'rounded);
flag('(!:rd!:),'field);
put('!:rd!:,'i2d,'i2rd!*);
put('!:rd!:,'minusp,'rd!:minusp);
put('!:rd!:,'plus,'rd!:plus);
put('!:rd!:,'times,'rd!:times);
put('!:rd!:,'difference,'rd!:difference);
put('!:rd!:,'quotient,'rd!:quotient);
put('!:rd!:,'zerop,'rd!:zerop);
put('!:rd!:,'onep,'rd!:onep);
put('!:rd!:,'prepfn,'rd!:prep);
put('!:rd!:,'prifn,'rd!:prin);
put('!:rd!:,'minus,'rd!:minus);
put('!:rd!:,'rootfn,'rd!:root);
put('!:rd!:,'!:rn!:,'!*rd2rn);
put('!:rn!:,'!:rd!:,'!*rn2rd);

symbolic procedure round!* x;
   % Returns actual number representation, as either float or bfloat.
%   retag cdr x;
   if float!-bfp x then rd2fl x else x;

symbolic procedure mkround u;
   % inverse operation to round!*, i.e. tags a naked float
   if atom u then make!:rd u else u;

%symbolic procedure roundbfp; !*roundbf or !!rdprec > !!flprec;

symbolic procedure print!-precision n;
   % Set the system printing precision !:print!-prec!:.
   % Returns previous value.
   begin scalar oldprec;
      if n=0 then return !:print!-prec!:;
      if n<0 then
         << oldprec := !:print!-prec!:;
            !:print!-prec!: := nil;
            return oldprec >>;
      if n > !:prec!: then
         << msgpri(nil,"attempt to set print!-precision greater than",
                       "precision ignored",nil,nil);
            return nil >>;
      oldprec := !:print!-prec!:;
      !:print!-prec!: := n;
      return oldprec
   end;

symbolic procedure print_precision n;
   % Alternative name.
   print!-precision n;

symbolic procedure precision0 n;
  % called from algebraic call of precision.
   if n member '((nil) () (reset))
      then <>
   else if cdr n
     or not numberp(n := prepsq simp!* aeval {'fix,prepsq simp!* car n})
     or n<0 then
       rerror(arith,5,"positive numeric value or `RESET' required")
   else <0 then rootacc!#!# := max(n,6); precision n>>;

put('precision,'psopfn,'precision0);

symbolic procedure precision n;
   % Set the system precision !!rdprec, bfloat precision !:prec!:,
   % and rd!:onep tolerance. Returns previous value.
   <>;

log2of10 := log 10 / log 2;

symbolic procedure decprec2internal p;
   ceiling(p * log2of10) + 3;

% symbolic procedure internal2decprec p;
%    floor ((p - 3) / log2of10);

symbolic procedure precision1(n,bool);
   begin scalar oldprec;
      if n=0 then return !!rdprec;
      if bool then rmsubs();  % So that old results are resimplified.
      oldprec := !!rdprec;
      !:prec!: :=
        (!!rdprec := if !*roundbf then n else max(n,minprec!#))+2;
      if !:print!-prec!: and n < !:print!-prec!:+2
         then !:print!-prec!: := nil; %unset
      !:bprec!: := decprec2internal !:prec!:;
      epsqrt!* := make!:ibf(1, -!:bprec!:/2);
      rd!-tolerance!* := make!:ibf(1, 6-!:bprec!:);
      cr!-tolerance!* := make!:ibf(1, 2*(6-!:bprec!:));
%     if !!rdprec <= !!flprec then
%        <>;
      !*!*roundbf := !!rdprec > !!flprec or !*roundbf;
      return oldprec end;

flag('(print!-precision),'opfn); % Symbolic operator print!-precision.
flag('(print_precision),'opfn);  % Symbolic operator print_precision.

symbolic procedure !*rd2rn x;
 % Converts a rounded number N into a rational to the system precision.
 % Elegant form: uses both rd2rn1 and realrat... and choses the best,
 %  but uses a heuristic to avoid the extra work when not needed.
   begin scalar n,p,r,r1,r2,d1,d2,ov;
     if rd!:zerop x then return '!:rn!: . (0 . 1);
     p := precision 0;
     r := rd2rn1 x;
     r1 := '!:rn!: . r;
     if abs car r<10 or cdr r<10
       or 2*max(length explode cdr r,length explode abs car r)>>>;

symbolic procedure i2rd!* u;
% Converts integer U to tagged rounded form.
 mkround chkint!* u;

symbolic procedure chkint!* u;
    if !*!*roundbf then bfloat u else
     ((if floatp u then u   % Added by ACN to make i2rd!* work with floats.
       else if msd!: x <= !!maxbflexp then float u
       else <>) where x=abs u);

mnflbf!! := invbf(mxflbf!! := make!:ibf (1, 800));

symbolic procedure chkrn!* u;
   if !*!*roundbf then u else bf2flck u;

symbolic procedure bf2flck u;
   if !*!*roundbf then u
   else if mt!: u=0 then 0.0 else
    ((if not grpbf(!!minflbf,r) and not grpbf(r,!!maxflbf)
         then bf2flr u
      else <>) where r := abs!: u);

symbolic procedure convchk x;
   if !*!*roundbf then if atom x then bfloat x else x
   else if atom x then x else bf2flck x;

symbolic procedure convprec!* u;
   convchk retag u;

symbolic procedure convprec u; convchk round!* u;

symbolic procedure rd!:minusp u;
  % bfminusp round!* u;
   if float!-bfp u then minusp rd2fl u else minusp!: u;

symbolic procedure convprc2(u,v);
   <> else u>>;

symbolic procedure rdzchk(u,x,y);
 if atom u then
    if u=0.0 or x>0.0 and y>0.0 or x<0.0 and y<0.0 then u
    else if abs u<(abs x)*!!fleps1 then 0.0 else u
 else
    if mt!: u=0 or mt!: x>0 and mt!: y>0 or mt!: x<0 and mt!: y<0 then u
    else if lessp!:(abs!: u,times!:(abs!: x,rd!-tolerance!*)) then bfz!*
    else u;

symbolic procedure rd!:plus(u,v);
  (if not !*!*roundbf and atom cdr u and atom cdr v
      and (z := safe!-fp!-plus(cdr u,cdr v)) then make!:rd z else
   begin scalar x,y;
      x := convprc2(u,v); y := yy!!;
      u := if not atom x then plubf(x,y) else
         <>
             else car z>>;
      return mkround rdzchk(u,x,y) end) where z=nil;

symbolic procedure rd!:difference(u,v);
  (if not !*!*roundbf and atom cdr u and atom cdr v
      and (z := safe!-fp!-plus(cdr u,-cdr v)) then make!:rd z else
   begin scalar x,y;
      x := convprc2(u,v); y := yy!!;
      u := if not atom x then difbf(x,y) else
         <>
             else car z>>;
      return mkround rdzchk(u,x,if atom y then -y else minus!: y) end)
   where z=nil;

symbolic procedure rd!:times(u,v);
  (if not !*!*roundbf and atom cdr u and atom cdr v
      and (z := safe!-fp!-times(cdr u,cdr v)) then make!:rd z else
   begin scalar x,y;
      x := convprc2(u,v); y := yy!!;
      return mkround if not atom x then timbf(x,y) else
         <>
              else car z>> end) where z=nil;

symbolic procedure rd!:quotient(u,v);
  if !:zerop v then rerror(arith,7,"division by zero") else
  (if not !*!*roundbf and atom cdr u and atom cdr v
      and (z := safe!-fp!-quot(cdr u,cdr v)) then make!:rd z else
   begin scalar x,y;
      x := convprc2(u,v); y := yy!!;
      if atom x and zerop y then rdqoterr();
      return mkround if not atom x then
         if mt!: y=0 then rdqoterr() else divbf(x,y)
         else
           <>
                else car z>> end) where z=nil;

symbolic procedure rdqoterr; error(0,"zero divisor in quotient");

% symbolic procedure safe!-fp!-plus(x,y);
%    if zerop x then y else if zerop y then x else
%    begin scalar u;
%       if x>0.0 and y>0.0 then
%          if x0.0 and y>0.0 or x<0.0 and y<0.0 then u
%         else if abs u<(abs x)*!!fleps1 then 0.0 else u end;

symbolic procedure safe!-fp!-plus(x,y);
   if zerop x then y
    else if zerop y then x
    else if x>0.0 and y>0.0
     then if x=1.0 and u<=!!timmax then
         if v<=!!timmax then go to ret else return nil;
      if u>!!timmax then if v<=1.0 then go to ret else return nil;
      if u<1.0 and u>=!!timmin then
         if v>=!!timmin then go to ret else return nil;
      if u=1.0 and u<=!!timmax then
         if v>=!!timmin then go to ret else return nil;
      if u>!!timmax then if v>=1.0 then go to ret else return nil;
      if u<1.0 and u>=!!timmin then
         if v<=!!timmax then go to ret else return nil;
      if u1.0 then return nil;
 ret: return quotient(x,y) end;

symbolic procedure rd!:zerop u;
  % bfzp round!* u;
   if float!-bfp u then zerop rd2fl u else mt!: u = 0;

symbolic procedure rd!:minus u;
  % mkround bfminus round!* u;
   if float!-bfp u then fl2rd (- rd2fl u) else minus!: u;

symbolic procedure rd!:onep u;
   % We need the tolerance test since some LISPs (e.g. PSL) can print
   % a number as 1.0, but it doesn't equal 1.0!
   if float!-bfp u then abs(1.0 - rd2fl u) :rd: in all dmodes, dmode!* must be used to
% determine whether to round to current precision,  but input never gets
% truncated, since precision is always increased at input time.
% to avoid inaccuracies in floating point representation, rd!:prep
% returns values in bfloat format.

symbolic procedure rd!:prep u;
   if !*noconvert then rdprep1 u
    else if rd!:onep u then 1
   else if rd!:onep rd!:minus u then -1 else rdprep1 u;

%symbolic procedure rdprep1 u;
%   if float!-bfp u then
%     if not dmode!* memq '(!:rd!: !:cr!:) or !*!*roundbf
%       then round!:mt(bfloat rd2fl u,min(!:bprec!:,!!nbfpd))
%      else if !:bprec!:>!!nbfpd then u
%      else fl2rd bf2flr round!:mt(bfloat rd2fl u,!:bprec!:)
%    else round!:mt(u,!:bprec!:);

symbolic procedure rdprep1 u;
   % Using cdr u to get actual float leads to various glitches.
   if float!-bfp u then u else round!:mt(u,!:bprec!:);

symbolic procedure rd!:prin u;
  % Printed output is rounded to 2 fewer places than internal value.
   bfprin!: bftrim!: rd!:forcebf u;

symbolic procedure rd!:explode u;
   bfexplode0 bftrim!: rd!:forcebf u;

initdmode 'rounded;

put('evalf,'psopfn,'evalf0);

procedure evalf0(u);
   % Return first argument as a float wrt. the current precision even
   % with off rounded. Optional second argument overrides the current
   % precision.
   begin scalar sp,w;
      if cdr u then
	 sp := precision0 cdr u;
      if !*rounded then
      	 w := aeval car u
      else <<
      	 on1 'rounded;
      	 w := aeval car u;
      	 off1 'rounded;
      >>;
      if cdr u then <<
	 if cadr u > sp then <<
	    prin2 "*** required accuracy exceeds current precision (";
	    prin2 sp;
	    prin2t ")";
 	    prin2t "*** printing with required accuracy ...";
	    mathprint w;
	    prin2t "*** finished printing"
	 >>;
	 precision0 {sp}
      >>;
      return w
   end;

put('evalnum,'psopfn,'evalnum0);

procedure evalnum0(u);
   % Return the exact algebraic representation of the first argument
   % rounded to the current precision. Optional second argument
   % overrides the current precision.
   begin scalar sp,w;
      if cdr u then
	 sp := precision0 cdr u;
      if !*rounded then
      	 w := aeval car u
      else <<
      	 on1 'rounded;
      	 w := aeval car u;
      	 off1 'rounded;
      	 w := aeval w
      >>;
      if cdr u then
      	 precision0 {sp};
      return w
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/bfauxil.red0000644000175000017500000004157611526203062023756 0ustar  giovannigiovannimodule bfauxil; % Support for the roots package and ROUNDED domain.

% Author: Stanley L. Kameny .
% Definitions of ilog2, irootn, icbrt, isqrt and support supplied by
% John Abbott.

% Copyright (c) 1988,1989,1990. Stanley L. Kameny. All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment   support for modules allroot and isoroot, and for ROUNDED
 domain logic;

exports !!shbinflp, bf2flr, bfdiffer, bfdivide, bfinverse, bflessp,
        bfminus, bfsqrt, cflot, conv!:bf2i, difbf, exptbf, fl2int,
        gf2bf, gf2fl, gfdiffer, gfdot, gfminus, gfplus, gfquotient,
        gfsqrt, gftimes, grpbf, icbrt, ilog2, invbf, irootn, isqrt,
        normbf, plubf, r2bf, r2fl, realrat;

imports abs!:, ashift, bflerrmsg, bfloat, bfminusp, bfnzp, bfp!:,
        bfzerop!:, bfzp, conv!:mt, cut!:ep, decprec!:, difference!:,
        divbf, divide!:, ep!:, eqcar, error1, errorp, errorset!*,
        evenp, fl2bf, gcdn, geq, gfim, gfrl, gfzerop, greaterp!:,
        hypot, i2bf!:, leq, lshift, make!:ibf, minus!:, minusp!:,
        msd!:, mt!:, order!:, plus!:, preci!:, read!:num, rndpwr,
        round!:mt, sgn, sqrt, terrlst, timbf, times!:, typerr;

fluid '(!:prec!: !:bprec!:);

global '(bfone!* bfhalf!* bfz!*);

global '(!!nfpd !!nbfpd !!shbinfl vv!! !!flbint);


global '(!!minflbf !!maxflbf);

symbolic procedure normbf x;
   begin scalar mt,s,r;integer ep,ep1;
      if (mt := mt!: x)=0 then go to ret;
      if mt<0 then <>;
      ep := ep!: x;
      while remainder(mt,1073741824)=0 do << % 2**30
        mt := lshift(mt,-30);
        ep := ep+30 >>;
      while remainder(mt,256)=0 do <<
        mt := lshift(mt,-8);
        ep := ep+8 >>;
      while not oddintp mt do <<
        mt := lshift(mt,-1);
        ep := ep+1>>;
      if s then mt := -mt;
ret:    return make!:ibf(mt,ep) end;

%symbolic procedure divbf(u,v); normbf divide!:(u,v,!:bprec!:);

symbolic procedure bfdivide(u,v);
   if atom u then u/v else divbf(u,v);

%symbolic procedure timbf(u,v); rndpwr times!:(u,v);

symbolic procedure bftimes(u,v); if atom u then u*v else timbf(u,v);

symbolic procedure plubf(a,b);
% this function calculates the normalized rounded sum of a and b,
% but avoids generating large numbers if magnitude difference is large.
  rndpwr
    begin scalar ma,mb,ea,eb,d,ld,p;
      if (ma:=mt!: a)=0 then return b;
      if (mb:=mt!: b)=0 then return a;
      if (d := (ea := ep!: a)-(eb := ep!: b))=0
        then return make!:ibf(ma+mb,ea);
      ld := d+msd!: abs ma - msd!: abs mb;
      p := !:bprec!:+1;
      if ld>p then return a;
      if ld<-p then return b;
      if d>0 then return make!:ibf(ashift(ma,d)+mb,eb)
        else return make!:ibf(ma+ashift(mb,-d),ea) end;

symbolic procedure bfplus(u,v); if atom u then u+v else plubf(u,v);

symbolic procedure difbf(a,b);
% this function calculates the normalized rounded difference of a and b,
% but avoids generating large numbers if magnitude difference is large.
  rndpwr
    begin scalar ma,mb,ea,eb,d,ld,p;
      if (ma:=mt!: a)=0 then return minus!: b;
      if (mb:=mt!: b)=0 then return a;
      if (d := (ea := ep!: a)-(eb := ep!: b))=0
        then return make!:ibf(ma - mb,ea);
      ld := d+msd!: abs ma - msd!: abs mb;
      p := !:bprec!:+1;
      if ld>p then return a;
      if ld<-p then return minus!: b;
      if d>0 then return make!:ibf(ashift(ma,d) - mb,eb)
        else return make!:ibf(ma - ashift(mb,-d),ea) end;

symbolic procedure bfdiffer(u,v); if atom u then u - v else difbf(u,v);

symbolic procedure invbf u; divbf(bfone!*,u);

symbolic procedure bfinverse u; if atom u then 1.0/u else invbf u;

symbolic procedure bfminus u; if atom u then -u else minus!: u;

symbolic procedure bflessp(a,b); if atom a then a b, but avoids generating large numbers
  % if magnitude difference is large.
   <0
     else if ma>0 and mb<0 then t
     else if ma<0 and mb>0 then nil
     else (if do>0 then ma>0           % the case |a| > |b|
            else if do<0 then ma<0     % the case |a| < |b|
            else if de=0 then ma>mb    % exponents are the same
            else if de>0 then ashift(ma,de)>mb
            else ma>ashift(mb,-de))
          where do=order!: a - order!: b,
                de=ep!: a - ep!: b>>
    where ma=mt!: a,mb=mt!: b;

%symbolic procedure bfminusp u; if atom u then minusp u else minusp!: u;

%symbolic procedure bfzp u; if atom u then zerop u else mt!: u=0;

%symbolic procedure bf!:zerop u; if atom u then zerop u else mt!: u=0;

%symbolic procedure bfnzp u; not bfzp u;

%symbolic procedure bfloat x; if floatp x then fl2bf x else
%normbf(if atom x then if fixp x then i2bf!: x else read!:num x else x);

symbolic procedure !!shbinflp;
   begin integer n; vv!! := 9.0;
     while n<300 and not errorp errorset!*('(vv!!!*1e10),nil)
        do n := n+10;
     return n<300 end;

symbolic procedure vv!!!*1e10; vv!! := vv!!*1.0e10;

symbolic (!!shbinfl := !!shbinflp());

symbolic procedure bfsqrt x;
 % computes sqrt x by Newton's method.
  if minusp!: x then terrlst(x,'bfsqrt) else
  begin  scalar nx,dx,dc,k7,nf;
         if bfzerop!: x then return bfz!*;
         k7 := !:bprec!: + 7;
         dc := make!:ibf (1, (-k7+(order!: x + 10)/2));
         nx := if not oddintp ep!:(nx := conv!:mt(x,2))
            then make!:ibf((2+3*mt!: nx)/5, (ep!: nx/2))
            else make!:ibf((9+5*mt!: nx)/10, ((ep!: nx - 1)/2));
         nf := 1;
   loop: if (nf := 2*nf)>k7 then nf := k7;
         dx := times!:(bfhalf!*,plus!:(divide!:(x,nx,nf),nx));
         if nf>=k7 and not greaterp!:(abs!: difference!:(dx,nx),dc)
            then return rndpwr nx;
         nx := dx; go to loop end;

symbolic procedure realrat x;
   begin scalar d,g;
         if bfp!: x then go to bf;
         if eqcar(x,'quotient) then
            if fixp cadr x and fixp caddr x then
               <>
            else x := cadr x/caddr x;
         if zerop x then return (0 . 1);
         if not floatp x then return (x . 1);
         x := bfloat x;
     bf: d := cddr(x := normbf x); x := cadr x;
         if x=0 then return (0 . 1);
         if d< 0 then d := lshift(1,-d)
          else <>;
    ret: g := gcdn(abs x,d); return (x/g) . (d/g) end;

remflag ('(fl2int),'lose);

symbolic procedure fl2int x;
   <>;

flag ('(fl2int),'lose);

symbolic procedure cflot x;
   if floatp x then x else if atom x then float x else bf2flr x;

symbolic procedure conv!:bf2i nmbr;
% This function converts a , i.e., a BINARY BIG-FLOAT
%      representation of "n", to an integer.  The result
%      is the integer part of "n".
% **** For getting the nearest integer to "n", please use
% ****      the combination MT!:( CONV!:EP(NMBR,0)).
% NMBR is a BIG-FLOAT representation of the number "n".
%   if ep!:(nmbr := cut!:ep(nmbr, 0)) = 0 then mt!: nmbr
%    else
     ashift (mt!: nmbr, ep!: nmbr);

symbolic procedure bf2flr u;
   % u is always bigfloat.
   % Converts bfloat to float by rounding at !!nbfpd binary digits.
   % We use error1 rather than rerror, because we want to catch such an
   % error in an errorset.
   begin scalar ep,m,y;
      if bfzerop!: u then return 0.0;
      ep := ep!:(u := round!:mt(u,!!nbfpd));
      if grpbf(!!minflbf,y := abs!: u) or grpbf(y,!!maxflbf)
        then error1();
      if ep<0 then <>;
      ep := 2.0**ep;
      if ep = 0.0 then error1(); % underflow
      return if not m then ep * mt!: u else ep * mt!: u / !!flbint
   end;

symbolic procedure gf2fl a; % force into float format.
   if atom a then a else if bfp!: a then bf2flr a
      else (gf2fl car a) . gf2fl cdr a;

symbolic procedure gf2bf a; if a then % force into bfloat format.
   if atom a then bfloat a else if bfp!: a then a
      else (gf2bf car a) . gf2bf cdr a;

symbolic procedure r2bf u;
  % translate any real number object to bigfloat.
    if atom u then bfloat u
       else if bfp!: u then u
       else if numberp car u then divbf(i2bf!: car u,i2bf!: cdr u)
       else if eqcar(u,'quotient) then
            divbf(i2bf!: cadr u,i2bf!: caddr u)
       else if eqcar(u,'!:rn!:) then r2bf cdr u
       else r2bf cadr u;

symbolic procedure r2fl u;
 % translate any real number object to float.
   if u=0 then 0.0
      else if atom u then float u
      else if numberp car u then (float car u)/cdr u
      else if eqcar(u,'quotient) then (float cadr u)/caddr u
      else if bfp!: u then bf2flr u
      else if eqcar(u,'!:rn!:) then r2fl cdr u
      else r2fl cadr u;

symbolic procedure gfplus(u,v);
   if atom car u then gffplus(u,v) else gbfplus(u,v);

symbolic procedure gffplus(u,v); (car u+car v) . (cdr u+cdr v);

symbolic procedure gbfplus(u,v);
   (plubf(car u,car v)) . plubf(cdr u,cdr v);

symbolic procedure gfdiffer(u,v);
   if atom car u then gffdiff(u,v) else gbfdiff(u,v);

symbolic procedure gffdiff(u,v); (car u - car v) . (cdr u - cdr v);

symbolic procedure gbfdiff(u,v);
   (difbf(car u,car v)) . difbf(cdr u,cdr v);

symbolic procedure gftimes(u,v);
   if atom car u then gfftimes(u,v) else gbftimes(u,v);

symbolic procedure gfftimes(u,v);
   begin scalar ru,iu,rv,iv;
         ru := car u; iu := cdr u; rv := car v; iv := cdr v;
         return (ru*rv - iu*iv) . (ru*iv+iu*rv) end;

symbolic procedure gbftimes(u,v);
   begin scalar ru,iu,rv,iv;
         ru := car u; iu := cdr u; rv := car v; iv := cdr v;
         return (difbf(timbf(ru,rv),timbf(iu,iv))) .
            plubf(timbf(ru,iv),timbf(iu,rv)) end;

symbolic procedure gfquotient(u,v);
   if atom car u then gffquot(u,v) else gbfquot(u,v);

symbolic procedure gffquot(u,v);
   begin scalar ru,iu,rv,iv,d;
         ru := car u; iu := cdr u; rv := car v; iv := cdr v;
         d := rv*rv+iv*iv;
         return ((ru*rv+iu*iv)/d) . ((iu*rv - ru*iv)/d) end;

symbolic procedure gbfquot(u,v);
   begin scalar ru,iu,rv,iv,d;
         ru := car u; iu := cdr u; rv := car v; iv := cdr v;
         d := plubf(timbf(rv,rv),timbf(iv,iv));
         return divbf(plubf(timbf(ru,rv),timbf(iu,iv)),d) .
            divbf(difbf(timbf(iu,rv),timbf(ru,iv)),d) end;

symbolic procedure gfminus u; (bfminus car u) . (bfminus cdr u);

symbolic procedure gfrotate u; (bfminus cdr u) . (car u);

%symbolic procedure gfrl u; car u;

%symbolic procedure gfim u; cdr u;

%symbolic procedure gfzerop u;
%   if not atom gfrl u then mt!: gfrl u = 0 and mt!: gfim u = 0
%      else equal(u,(0.0 . 0.0));

symbolic procedure gfdot(u,v);
   if atom car u then gffdot(u,v) else gbfdot(u,v);

symbolic procedure gffdot(u,v); car u*car v+cdr u*cdr v;

symbolic procedure gbfdot(u,v);
   plubf(timbf(car u,car v),timbf(cdr u,cdr v));

symbolic procedure gfrsq u; gfdot(u,u);

symbolic procedure gffrsq u; car u*car u+cdr u*cdr u;

symbolic procedure gbfrsq u;
   plubf(timbf(car u,car u),timbf(cdr u,cdr u));

symbolic procedure gffmult(r,u); (r*car u) . (r*cdr u);

symbolic procedure gffsqrt x;
   begin scalar x0,nx,xd,xd0,rl,im; rl := gfrl x; im := gfim x;
     rl := sqrt(hypot(rl,im)/2+rl/2); im := im/(2*rl); nx := rl . im;
     repeat
       <>
     until xd0 and xd0 - xd<=0.0; return x0 end;

symbolic procedure gbfmult(r,u);
   <>;

symbolic procedure gbfsqrt x;
   begin scalar x0,nx,xd,xd0,rl;
     nx :=
      <>;
     repeat
       <>
     until xd0 and mt!: difbf(xd0,xd)<=0; return x0 end;

symbolic smacro procedure rl2gfc x;
   x . if atom x then 0.0 else bfz!*;

symbolic procedure gfsqrt x;
 % computes gfsqrt x by Newton's method, for both gf and gbf.
   begin scalar xn,neg,negi;
         if gfzerop x then return x;
         if bfminusp gfrl x
           then <>;
         if bfzp gfim x then
            <>;
         xn := if atom gfrl x then gffsqrt x else gbfsqrt x;
         if negi then xn := gfminus xn;
    ret: return if neg then gfrotate xn else xn end;

symbolic procedure sgn x; if x>0 then 1 else if x<0 then -1 else 0;

symbolic procedure exptbf(x,n,a);
  % Computes a*x**n in bfloat arithmetic for positive x
  % and positive integer n.
   begin
  lp: if oddintp n then a := timbf(a,x); % not evenp n
      n := lshift (n, -1);
      if n=0 then return a;
      x := timbf(x,x); go to lp end;

symbolic procedure icbrt(x);
   % x is a number : result is integer s approx cube root of x,
   % i.e. if x > 0 then s**3 <= n < (s+1)**3 o/w s**3 >= n > (s-1)**3.
   irootn(fix2(x),3);

symbolic procedure fix2 x; if fixp x then x else fl2int x;

symbolic procedure ilog2 n;
   % n is an integer.  Result is an integer r, s.t. 2**r <= abs(n)
   %  < 2**(r+1).
   begin scalar ans, powers!-of!-2, pwr;
      if n<=0 then terrlst(n,'ilog2);
      pwr := 2;
      powers!-of!-2 := pwr . nil;
      while n>pwr do
         <>;
      ans := 0;
      while(pwr := car(powers!-of!-2)) neq 2 do
        <= pwr then << n := n/pwr; ans := ans + 1; >>;
          ans := ans*2>>;
      if n >= 2 then ans := ans + 1;
      return ans
   end;

symbolic procedure isqrt(x);
   % x is a number : result is integer s approx square root of x,
   % i.e. if x > 0 then s**2 <= n < (s+1)**2 o/w s**2 >= n > (s-1)**2.
   if x<=0 then terrlst(x,'isqrt) else irootn(fix2(x), 2);

symbolic procedure qroundup(m,n);
   % m, n are integers, n>0 : result is least integer >= m/n.
   if m<0 then -((-m)/n) else (m+n-1)/n;

symbolic procedure irootn(n,r);
    % n, r are integers : result is integer s approx r'th root of n,
    % i.e. if n > 0 then s**r <= n < (s+1)**r o/w s**r >= n > (s-1)**r.
    if not fixp n then typerr(n,"integer")
     else if not fixp r or r<=0 then typerr(r,"positive integer")
     else if n<0
      then if evenp r then typerr(r,"odd integer") else -irootn(-n,r)
     else if r = 1 then n
     else if n = 0 then 0
     else begin scalar ans;
             ans := irootn1(n,r,ilog2 n,(ilog2 r)/2);
             if ans**r>n then return ans - 1 else return ans
       end;

symbolic procedure irootn!-power2(p, q);
   % p, q are positive integers.
   % Result is an integer (slightly) greater than 2**(p/q).
   % Uses the first few terms of the Taylor expansion (tweaked a bit).
   % Error (of numans/denans) is at most 0.03%.
   begin scalar whole!-part, p1, numans, denans;
      whole!-part := (p+q/2)/q;
      p1 := p-q*whole!-part;
      numans := q^3/100 + 1000*q^3 + 693*q^2*p1 + 243*q*p1^2 + 57*p1^3;
      denans := 1000*q^3;
      return 1+ (2^whole!-part * numans)/denans
      % add 1 to force rounding up
   end;

symbolic procedure irootn1(n,r,logn,xs);
   % n, r integers >0, logn is ilog2(n), xs is the excess # bits in the
   % top 1/2.
   % result is s, s.t. s**r <= n < (s+1)**r or (s-1)**r <= n < s**r.
   begin scalar x, upb, size, tmp;
      size := logn / r;
      if size < 17 then upb := irootn!-power2(1+logn, r)
       else <>;
      repeat <>
         until upb >= x;
      return x
   end;

put('irootn,'number!-of!-args,2);   %  For VALUECHK.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/paraset.red0000644000175000017500000000676311526203062023762 0ustar  giovannigiovannimodule paraset;   % Parameter determining module.

% Author: Stanley L. Kameny.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Last change date: 23 June 1993.

% Paraset.red determines the parameters !!nfpd, !!nbfpd, and !!maxbflexp
% for floating point numbers.  !!nfpd, !!nbfpd, and !!maxbflexp are
% computed at load, but !!maxbflexp may have to be fixed up at run time
% if !!flexperr is true.

imports errorp, errorset!*, neq, roundconstants;

exports !!mfefix, find!!nbfpd, find!!nfpd, infinityp;

global '(!!nfpd !!nbfpd !!!~xx !!yy !!maxbflexp !!flexperr !!plumax
         !!epsqrt !!flint !!flbint !!floatbits);

flag('(!!nfpd !!nbfpd !!maxflexp),'share);

symbolic procedure find!!nfpd;
   begin scalar x,y,z;integer i; x:=y:=9.0;
      repeat <> until (z := x+1.0)=x;
      if 10.0*fix(z/10) - 1.0 neq x then i := i - 1;
      return !!nfpd:=i end;

symbolic procedure find!!nbfpd;
   begin scalar x,y,z;integer i; x:=y:=1.0;
      repeat <> until (z := x+1.0)=x;
      if 2.0*fix(z/2) - 1.0 neq x then i := i-1;
      return !!nbfpd:=i end;

symbolic procedure find!!maxbflexp;
   begin scalar z; integer n;
      !!!~xx := 1.0;
      while not errorp
       (z := errorset!*(
          '(progn (setq !!yy (plus 1.0 (times !!!~xx 2.0)))
                  (and (not (infinityp !!yy))
                       (greaterp !!yy !!!~xx))),nil))
         and car z do
            <>;
      !!flexperr := not errorp z and not car z;
      return !!maxbflexp := n end;

symbolic procedure infinityp u;
   % Check for a representation of an IEEE floating point infinity.
   not(x eq '!- or digit x) where x=car explode u;

symbolic procedure !!mfefix;
  <>;
        !!maxbflexp := !!maxbflexp - n;
      end;
    if not !!plumax then roundconstants()>>;

find!!nfpd(); find!!nbfpd();
find!!maxbflexp();

!!epsqrt := 10.0**((-1 - !!nfpd)/2);

!!flint := 10.0**!!nfpd;

!!flbint := 2.0 ** !!nbfpd;

!!floatbits := (10*(!!nfpd + 1))/3;  % Smallest power of 2 that does
               % not fit in mantissa.  Note that 10/3 > log(10)/log(2).

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/smlbflot.red0000644000175000017500000005631711526203062024145 0ustar  giovannigiovannimodule smlbflot;   % Basic support for bigfloat arithmetic.

% Authors: S.L. Kameny and T. Sasaki.
% Modified for binary bigfloat arithmetic by Iain Beckingham and Rainer
% Schoepf.
% Modified for double precision printing by Herbert Melenk.
% Modified to allow *very* large numbers to be compressed (for PSL) by
% Winfried Neun.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Last change made Oct 6, 1999.

exports abs!:, bfexplode0, bflerrmsg, bfprin!:, bftrim!:, bfzerop!:,
        conv!:mt, cut!:ep, cut!:mt, decimal2internal, decprec!:,
        difference!:, divide!:, equal!:, fl2bf, greaterp!:, incprec!:,
        leq!:, lessp!:, max!:, max!:, max2!:, min!:, min2!:, minus!:,
        minusp!:, order!:, plus!:, read!:num, round!:mt, round!:last,
        times!:;

imports aconc, ashift, bfp!:, ceiling, conv!:bf2i, ep!:, eqcar, floor,
        geq, i2bf!:, leq, lshift, make!:ibf, msd!:, mt!:, neq, normbf,
        oddintp, preci!:, precision, prin2!*, rerror, retag, reversip;

fluid '(!*bfspace !*fullprec !*nat !:prec!: !:bprec!: !:print!-prec!:
        !:upper!-sci!: !:lower!-sci!:);

global '(!!nfpd !!nbfpd bften!* bfz!* fort_exponent);

switch bfspace,fullprec;

flag('(fort_exponent),'share);

!*bfspace := nil;

% !*fullprec := t;

!:lower!-sci!: := 10;

!:upper!-sci!: := 5;

symbolic procedure bflerrmsg u;
   % Revised error message for BFLOAT module, using error, not rederr.
   error(0,{"Invalid argument to",u});

symbolic procedure bfzerop!: u;
   % This is possibly too restricted a definition.
   mt!: u = 0;

symbolic procedure fl2bf x;
  (if zerop x then bfz!* else
   begin scalar s,r; integer d;
     if x<0 then <>;
     % convert x to an integer equivalent;
      r := normbf read!:num x;
      d := ep!: r+msd!: mt!: r;
      x := x*2.0**-d; x := x + 0.5/2**!:bprec!:;
      x := fix(x*2**!:bprec!:);
      return make!:ibf (if s then -x else x, d - !:bprec!:) end)
        where !:bprec!:=!!nbfpd;

symbolic procedure bfprin!: u;
%  if preci!: u>!!nbfpd then bfprin0 u
%   else (bfprin0 u where !*bfspace=nil);
   bfprin0 u;

symbolic procedure divide!-by!-power!-of!-ten (x, n);
  if n < 0 then bflerrmsg 'divide!-by!-power!-of!-ten
   else <<
     while n > 0 do <<
       if oddintp n then x := normbf divide!: (x, f, !:bprec!:);
       n := lshift (n, -1);
       f := normbf cut!:mt (times!: (f, f), !:bprec!:) >>;
     x >> where f := bften!*;

symbolic procedure multiply!-by!-power!-of!-ten (x, n);
  if n < 0 then bflerrmsg 'multiply!-by!-power!-of!-ten
   else <<
     while n > 0 do <<
       if oddintp n then x := normbf times!: (x, f);
       n := lshift (n, -1);
       f := normbf cut!:mt (times!: (f, f), !:bprec!:) >>;
     normbf cut!:mt (x, !:bprec!:) >> where f := bften!*;

global '(log2of10);

symbolic procedure round!:dec (x, p);
  %
  % rounds bigfloat x to p decimal places
  %
  begin scalar setpr; integer m, ex;
    if null p then p := if !:print!-prec!: then !:print!-prec!:
                         else !:prec!: - 2
     else if p > precision 0 then setpr := precision p;
    x := round!:dec1 (x,p);
    m := car x; ex := cdr x;
    x := i2bf!: m;
    if ex < 0 then x := divide!-by!-power!-of!-ten (x, -ex)
     else if ex > 0 then x := multiply!-by!-power!-of!-ten (x, ex);
    if setpr then precision setpr;
    return round!:mt (x, ceiling (p * log2of10))
  end;

symbolic procedure round!:dec1 (x, p);
  %
  % rounds bigfloat x to p decimal places
  % returns pair (m . ex) of mantissa and exponent to base 10,
  % m having exactly p digits
  % performs all calculations at at least current precision,
  % but increases the precision of the calculations to log10(x)
  % if this is larger
  %
  if bfzerop!: x then cdr x
   else (begin scalar exact, lo, sign; integer ex, k, m, n, l;
    %
    % We need to calculate the number k so that 10^(k+1) > |x| >= 10^k
    %  k = floor (log10 |x|) = floor (log2 |x| / log2of10);
    % We can easily compute n so that 2^(n+1) > |x| >= 2^n,
    %  i.e., n = floor (log2 |x|), since this is just order!:(x).
    % Since n+1 > log2 |x| >= n, it follows that
    %  floor ((n+1) / log2of10) >= k >= floor (n / log2of10)
    % I.e., if both bounds agree, we know k, otherwise we have to check.
    %
    if mt!: x < 0 then <>;
    n := order!: x;
    %
    % The division by log2of10 has to be done with precision larger than
    % the precision of n. In particular, log2of10 has to be calculated
    % to a larger precision.  Instead of dividing by log2of10, we
    % multiply by log10of2.
    %
    l := msd!: abs n;
    <>
        where !:bprec!: := max (!!nbfpd, l + 7);
    %
    % For the following calculation the precision must be increased by
    % the precision of n. The is necessary to ensure that the mantissa
    % is calculated correctly for large values of the exponent. This is
    % due to the fact that if we multiply the number x by 10^n its
    % precision will be decreased by n.
    %
    !:bprec!: := !:bprec!: + l;
    %
    % since conv!:bf2i rounds always towards 0, we must correct for n<0
    %
    if n < 0 then k := k - 1;
    ex := k - p + 1;
    if ex < 0 then x := multiply!-by!-power!-of!-ten (x, -ex)
     else if ex > 0 then x := divide!-by!-power!-of!-ten (x, ex);
    if exact then nil
     else <>
             else if l > p then <>>>;
    %
    % do rounding
    %
    x := plus!:(x, bfhalf!*);
    % Add an "epsilon" just to be sure (e.g., for on complex,rounded;
    % print_precision 15; 3.23456789012345+7).
    x := plus!:(x,fl2bf(0.1^18));
    m := conv!:bf2i x;
    if length explode m > p then <>;
    if sign then m := -m;
    return (m . ex);
  end) where !:bprec!: := !:bprec!:;

% symbolic procedure internal2decimal (x, p);
  %
  % converts bigfloat x to decimal format, with precision p
  % Result is a pair (m . e), so that x = m*10^e, with
  % m having exactly p decimal digits.
  % Calculation is done with the current precision,
  % but at least with p + 2.
  %
%   begin scalar setpr;
%     if null p then p := if !:print!-prec!: then !:print!-prec!:
%                          else !:prec!: - 2
%      else if p > precision 0 then setpr := precision p;
%     x := round!:dec1 (x,p);
%     if setpr then precision setpr;
%     return x
%   end;


symbolic procedure bfprin0 u;
  begin scalar r; integer m, ex;
    r := round!:dec1 (u, if !:print!-prec!: then !:print!-prec!:
                          else !:prec!: - 2);
    m := car r; ex := cdr r;
    bfprin0x (m, ex)
  end;

symbolic procedure bfprin0x(m,ex);
  begin scalar lst; integer dotpos;
    lst := bfexplode0x(m,ex);
    ex := cadr lst;
    dotpos := caddr lst;
    lst := car lst;
    return bfprin!:lst (lst,ex,dotpos)
  end;

symbolic procedure bfexplode0 u;
  % returns a list (lst ex dotpos) where
  %  lst    = list of characters in mantissa
  %            (ie optional sign and digits)
  %  ex     = decimal exponent
  %  dotpos = position of decimal point in lst
  %            (note that the sign is counted)
  begin scalar r; integer m, ex;
    r := round!:dec1 (u,if !:print!-prec!: then !:print!-prec!:
                         else !:prec!: - 2);
    m := car r; ex := cdr r;
    return bfexplode0x (m, ex)
  end;


symbolic procedure bfexplode0x (m, ex);
  begin scalar lst, s; integer dotpos, l;
    if m<0 then <>;
    lst := explode m;
    l := length lst;
    if ex neq 0 and (l+ex < -!:lower!-sci!: or l+ex > !:upper!-sci!:)
      then <>
     else < l - 1
              %
              % add dotpos - l + 1 zeroes at the end
              %
              then lst := nconc!*(lst,nlist('!0,dotpos - l + 1))
             else while dotpos < 1 do <>;
    if null !*fullprec
      then < dotpos + 1 do
                lst := cdr lst;
             lst := reversip lst>>;
    return {lst, ex, dotpos}
  end;

symbolic procedure bfprin!:lst (lst, ex, dotpos);
  begin scalar result,ee,w; integer j;
    ee:='E;
    if !*fort and liter(w:=reval fort_exponent) then ee:=w else w:=nil;
    if car lst eq '!- and dotpos = 1 then <>;
    if ex neq 0 then if car lst eq '!- then <>
                      else <>
     else if dotpos = length lst then dotpos := -1;
    for each char in lst do <<
      result := char . result; j := j + 1; dotpos := dotpos - 1;
      if j=5 then <>;
      if j=5 then <>
     else if j=1 then <>
     else if j=2
      then <>
     else if j=3 then <>
     else if j=4 then <>;
    lst := if ex > 0 then '!+ . explode ex else explode ex;
    for each char in lst do <<
      result := char . result; j := j + 1;
      if j=5 then <>;
       return (reversip aa) . li
    end;

symbolic procedure scientific_notation n;
   begin scalar oldu,oldl;
     oldu := !:upper!-sci!:; oldl := !:lower!-sci!: + 1;
     if fixp n
       then <<
         if n<0
           then rerror(arith,1,
                       {"Invalid argument to scientific_notation:",n});
         !:lower!-sci!: := n - 1; !:upper!-sci!: := n;
      >>
      else if eqcar(n,'list) and length n=3
       then if not (fixp cadr n and fixp caddr n)
              then rerror(arith,2,
                        {"Invalid argument to scientific_notation:",n})
             else <>;
     return {'list,oldu,oldl}   % Return previous range.
  end;

flag('(scientific_notation), 'opfn);

symbolic procedure order!: nmbr;
   % This function counts the order of a number "n".  NMBR is a bigfloat
   %  representation of "n".
   % **** ORDER(n)=k if 2**k <= ABS(n) < 2**(k+1)
   % ****     when n is not 0, and ORDER(0)=0.
   %
   if mt!: nmbr = 0 then 0 else preci!: nmbr + ep!: nmbr - 1;

symbolic smacro procedure decprec!:(nmbr, k);
   make!:ibf(ashift(mt!: nmbr,-k), ep!: nmbr + k);

symbolic smacro procedure incprec!:(nmbr, k);
   make!:ibf(ashift(mt!: nmbr,k), ep!: nmbr - k);

symbolic procedure conv!:mt(nmbr, k);
   % This function converts a number "n" to an equivalent number of
   % binary precision K by rounding "n" or adding "0"s to "n".
   % NMBR is a binary bigfloat representation of "n".
   %  K is a positive integer.
   if bfp!: nmbr and fixp k and k > 0
     then if (k := preci!: nmbr - k) = 0 then nmbr
           else if k < 0 then incprec!:(nmbr, -k)
           else round!:last(decprec!:(nmbr, k - 1))
    else bflerrmsg 'conv!:mt;

symbolic procedure round!:mt(nmbr, k);
   % This function rounds a number "n" at the (K+1)th place and returns
   % an equivalent number of binary precision K if the precision of "n"
   % is greater than K, else it returns the given number unchanged.
   % NMBR is a bigfloat representation of "n".  K is a positive integer.
   if bfp!: nmbr and fixp k and k > 0 then
      if (k := preci!: nmbr - k - 1) < 0 then nmbr
      else if k = 0 then round!:last nmbr
      else round!:last decprec!:(nmbr, k)
   else bflerrmsg 'round!:mt;

symbolic procedure round!:ep(nmbr, k);
% This function rounds a number "n" and returns an
%      equivalent number having the exponent K if
%      the exponent of "n" is less than K, else
%      it returns the given number unchanged.
% NMBR is a BINARY BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
  if bfp!: nmbr and fixp k then
    if (k := k - 1 - ep!: nmbr) < 0 then nmbr
      else if k = 0 then round!:last nmbr
      else round!:last decprec!:(nmbr, k)
   else bflerrmsg 'round!:ep$

symbolic procedure round!:last nmbr;
   % This function rounds a number "n" at its last place.
   % NMBR is a binary bigfloat representation of "n".
   << if m < 0 then << m := -m; s := t >>;
      m := if oddintp m then lshift (m, -1) + 1
            else lshift (m, -1);
      if s then m := -m;
      make!:ibf (m, e) >>
       where m := mt!: nmbr, e := ep!: nmbr + 1, s := nil;

symbolic procedure cut!:mt(nmbr,k);
% This function returns a given number "n" unchanged
%      if its binary precision is not greater than K, else it
%      cuts off its mantissa at the (K+1)th place and
%      returns an equivalent number of precision K.
% **** CAUTION!  No rounding is made.
% NMBR is a BINARY BIG-FLOAT representation of "n".
% K is a positive integer.
  if bfp!: nmbr and fixp k and k > 0 then
     if (k := preci!: nmbr - k) <= 0 then nmbr
             else decprec!:(nmbr, k)
   else bflerrmsg 'cut!:mt$

symbolic procedure cut!:ep(nmbr, k);
% This function returns a given number "n" unchanged
%      if its exponent is not less than K, else it
%      cuts off its mantissa and returns an equivalent
%      number of exponent K.
% **** CAUTION!  No rounding is made.
% NMBR is a BINARY BIG-FLOAT representation of "n".
% K is an integer (positive or negative).
  if bfp!: nmbr and fixp k then
     if (k := k - ep!: nmbr) <= 0 then nmbr
        else decprec!:(nmbr, k)
   else bflerrmsg 'cut!:ep$

symbolic procedure bftrim!: v;
   normbf round!:mt(v,!:bprec!: - 3);

symbolic procedure decimal2internal (base10,exp10);
  if exp10 >= 0 then i2bf!: (base10 * 10**exp10)
   else divide!-by!-power!-of!-ten (i2bf!: base10, -exp10);

symbolic procedure read!:num(n);
   % This function reads a number or a number-like entity N
   %      and constructs a bigfloat representation of it.
   % N is an integer, a floating-point number, or a string
   %      representing a number.
   % **** If the system does not accept or may incorrectly
   % ****      accept the floating-point numbers, you can
   % ****      input them as strings such as "1.234E-56",
   % ****      "-78.90 D+12" , "+3456 B -78", or "901/234".
   % **** A rational number in a string form is converted
   % ****      to a bigfloat of precision !:PREC!: if
   % ****      !:PREC!: is not NIL, else the precision of
   % ****      the result is set 170.
   % **** Some systems set the maximum size of strings.  If
   % ****      you want to input long numbers exceeding
   % ****      such a maximum size, please use READ!:LNUM.
   if fixp n then make!:ibf(n, 0)
    else if not(numberp n or stringp n) then bflerrmsg 'read!:num
    else begin integer j,m,sign;  scalar ch,u,v,l,appear!.,appear!/;
          j := m := 0;
          sign := 1;
          u := v := appear!. := appear!/ := nil;
          l := explode n;
    loop: ch := car l;
          if digit ch then << u := ch . u; j := j + 1 >>
           else if ch eq '!. then << appear!. := t; j := 0 >>
           else if ch eq '!/ then << appear!/ := t; v := u; u := nil >>
           else if ch eq '!- then sign := -1
           else if ch memq '(!E !D !B !e !d !b) then go to jump;  %JBM
           if l := cdr l then goto loop else goto make;
    jump: while l := cdr l do
            <>;
          l := reverse v;
          % Was erroneously smallcompress.
          if car l eq '!- then m := - compress cdr l
                          else m:= compress l;
    make: u := reverse u;
          v := reverse v;
          if appear!/ then
            return conv!:r2bf(make!:ratnum(sign*compress v,compress u),
                              if !:bprec!: then !:bprec!: else 170);
          if appear!. then j := - j else j := 0;
          if sign = 1 then u := compress u else u := - compress u;
          return round!:mt (decimal2internal (u, j + m), !:bprec!:)
                   where !:bprec!: := if !:bprec!: then !:bprec!:
                                       else msd!: abs u
    end;

symbolic procedure abs!: nmbr;
   % This function makes the absolute value of "n".  N is a binary
   % bigfloat representation of "n".
   if mt!: nmbr > 0 then nmbr else make!:ibf(- mt!: nmbr, ep!: nmbr);

symbolic procedure minus!: nmbr;
   % This function makes the minus number of "n".  N is a binary
   % bigfloat representation of "n".
   make!:ibf(- mt!: nmbr, ep!: nmbr);

symbolic procedure plus!:(n1,n2);
   begin scalar m1,m2,e1,e2,d; return
      if (m1 := mt!: n1)=0 then n2
      else if (m2 := mt!: n2)=0 then n1
      else if (d := (e1 := ep!: n1)-(e2 := ep!: n2))=0
         then make!:ibf(m1+m2, e1)
      else if d>0 then make!:ibf(ashift(m1,d)+m2,e2)
      else make!:ibf(m1+ashift(m2,-d),e1) end;

symbolic procedure difference!:(n1,n2);
   begin scalar m1,m2,e1,e2,d; return
      if (m1 := mt!: n1)=0 then minus!: n2
      else if (m2 := mt!: n2)=0 then n1
      else if (d := (e1 := ep!: n1)-(e2 := ep!: n2))=0
         then make!:ibf(m1 - m2, e1)
      else if d>0 then make!:ibf(ashift(m1,d) - m2,e2)
      else make!:ibf(m1 - ashift(m2,-d),e1) end;

symbolic procedure times!:(n1, n2);
   % This function calculates the product of "n1" and "n2".
   % N1 and N2 are bigfloat representations of "n1" and "n2".
   make!:ibf(mt!: n1 * mt!: n2, ep!: n1 + ep!: n2);

symbolic procedure divide!:(n1,n2,k);
   % This function calculates the quotient of "n1" and "n2", with the
   % precision K, by rounding the ratio of "n1" and "n2" at the (K+1)th
   % place.  N1 and N2 are bigfloat representations of "n1" and "n2".
   % K is any positive integer.
   begin
      n1 := conv!:mt(n1, k + preci!: n2 + 1);
      n1 := make!:ibf(mt!: n1 / mt!: n2, ep!: n1 - ep!: n2);
      return round!:mt(n1, k)
   end;

symbolic procedure max2!:(a,b);
   % This function returns the larger of "n1" and "n2".
   % N1 and N2 are bigfloat representations of "n1" and "n2".
   if greaterp!:(a,b) then a else b;

macro procedure max!: x; expand(cdr x,'max2!:);

symbolic procedure min2!:(a,b);
   % This function returns the smaller of "n1" and "n2".
   % N1 and N2 are binary bigfloat representations of "n1" and "n2".
   if greaterp!:(a,b) then b else a;

macro procedure min!: x; expand(cdr x,'min2!:);

symbolic procedure greaterp!:(a,b);
% this function calculates the a > b, but avoids
% generating large numbers if magnitude difference is large.
     if ep!: a=ep!: b then mt!: a>mt!: b else
       (((if d=0 then ma>mb else
          ((if d>p2 then ma>0 else if d<-p2 then mb<0
            else if d>0 then ashift(ma,d)>mb
            else ma>ashift(mb,-d))
          where p2=2*!:bprec!:))
         where d=ep!: a - ep!: b, ma=mt!: a, mb=mt!: b)
        where a= normbf a, b=normbf b);

symbolic procedure equal!:(a,b);
  %tests bfloats for a=b rapidly without generating digits. %SK
   zerop mt!: a and zerop mt!: b or
   ep!:(a := normbf a)=ep!:(b := normbf b) and mt!: a=mt!: b;

symbolic procedure lessp!:(n1, n2);
   % This function returns T if "n1" < "n2" else returns NIL.
   % N1 and N2 are bigfloat representations of "n1" and "n2".
   greaterp!:(n2, n1);

symbolic procedure leq!:(n1, n2);
   % This function returns T if "n1" <= "n2" else returns NIL.
   % N1 and N2 are bigfloat representations of "n1" and "n2".
   not greaterp!:(n1, n2);

symbolic procedure minusp!: x;
   % This function returns T if "x"<0 else returns NIL.
   % X is any Lisp entity.
   bfp!: x and mt!: x < 0;

symbolic procedure make!:ratnum(nm,dn);
   % This function constructs an internal representation
   %      of a rational number composed of the numerator
   %      NM and the denominator DN.
   % NM and DN are any integers (positive or negative).
   % **** Four routines in this section are temporary.
   % ****      That is, if your system has own routines
   % ****      for rational number arithmetic, you can
   % ****      accommodate our system to yours only by
   % ****      redefining these four routines.
   if zerop dn then rerror(arith,3,"Zero divisor in make:ratnum")
    else if dn > 0 then '!:ratnum!: . (nm . dn)
    else '!:ratnum!: . (-nm . -dn);

symbolic procedure ratnump!:(x);
   % This function returns T if X is a rational number
   % representation, else NIL.
   % X is any Lisp entity.
   eqcar(x,'!:ratnum!:);                   %JBM Change to EQCAR.

symbolic smacro procedure numr!: rnmbr;
   % This function selects the numerator of a rational number "n".
   % RNMBR is a rational number representation of "n".
   cadr rnmbr;

symbolic smacro procedure denm!: rnmbr;
   % This function selects the denominator of a rational number "n".
   % RNMBR is a rational number representation of "n".
   cddr rnmbr;

symbolic procedure conv!:r2bf(rnmbr,k);
   % This function converts a rational number RNMBR to a bigfloat of
   % precision K, i.e., a bigfloat representation with a given
   % precision.  RNMBR is a rational number representation.  K is a
   % positive integer.
   if ratnump!: rnmbr and fixp k and k > 0
     then divide!:(make!:ibf( numr!: rnmbr, 0),
                   make!:ibf( denm!: rnmbr, 0),k)
    else bflerrmsg 'conv!:r2bf;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/arith.tst0000644000175000017500000004611311526203062023463 0ustar  giovannigiovanni% Tests of REDUCE Arithmetic.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Copyright (c) 1987, 1988, 1989, 1991, Stanley L. Kameny.
% Copyright (c) 1998, Anthony C. Hearn.
% All Rights Reserved.

% This test file is a combination of three tests files from versions
% 3.6 or earlier: math, rounded and complex.


% Simple tests of rounded arithmetic.

% Tests in the exact mode.

x := 1/2;

y := x + 0.7;

% Tests in approximate mode.

on rounded;

y;   % As expected not converted to approximate form.

z := y+1.2;

z/3;

% Let's raise this to a high power.

ws^24;

% Now a high exponent value.

% 10.2^821;

% Elementary function evaluation.

cos(pi);

symbolic ws;

z := sin(pi);

symbolic ws;

% Handling very small quantities.

% With normal defaults, underflows are converted to 0.

exp(-100000.1**2);

% However, if you really want that small number, roundbf can be used.

on roundbf;

exp(-100000.1**2);

off roundbf;

% Now let us evaluate pi.

pi;

% Let us try a higher precision.

prec0 := precision 50;

pi;

% Now find the cosine of pi/6.

cos(ws/6);

% This should be the sqrt(3)/2.

ws**2;


% Here are some well known examples which show the power of this system.

precision 10;

% This should give the usual default again.

let xx=e**(pi*sqrt(163));

let yy=1-2*cos((6*log(2)+log(10005))/sqrt(163));

% First notice that xx looks like an integer.

xx;

% And that yy looks like zero.

yy;

% But of course it's an illusion.

precision 50;

xx;

yy;

% Now let's look at an unusual way of finding an old friend.

procedure agm;
   begin scalar a,b,u,x,y,p,pn;
      a := 1; b := 1/sqrt 2; u:= 1/4; x := 1$ pn := 4;
      repeat <
    ",sind float i**2+cosd float i**2;
                       terpr(i,4)>>;

% #2: Quadrant test of sind, cosd: proper answers + +,+ -,- -,- +.

begin scalar a;
    a:= sind 45.0;
    for i:= 0.0:3.0 do
       <>
  end$

% #3: Scaling test: all values should be 1 exactly.

begin scalar a; a:= cosd 60.0;
%  for i:= -10.0:10.0 do write fix(cosd(60+i*360)/a)," "
   for i:= -10.0:10.0 do write round(cosd(60+i*360)/a)," "
 end$

% #4: Test of radians -> degrees evaluation: ideal values 1.0.

array a(6)$

begin
   for i:=1:6 do  a(i):=sind(15.0*i);
   for i:=1:6 do <>
 end$

% #5: Test of tand*cotd: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>;
   terpri()
 end$

% #6: Test of secd**2-tand**2: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>
 end$

% #7: Test of cscd**2-cotd**2: ideal values 1.0.

begin
   for i:=5 step 5 until 85 do
      <>
 end$

% #8: Test of asind+acosd: ideal values 1.0.

begin write "sind and cosd"; terpri();
   for i:=-10:10 do
      <>;
   write "sin and cos";terpri();
   for i:=-10:10 do
      <>
 end$

% #9: Test of atand+acotd: ideal values 1.0.

begin scalar x; write "tand, atand and acotd"; terpri();
   for i:=-80 step 10 until 80 do
   <>;
     terpri();
   write "tan, atan and acot";terpri();
   for i:=-80 step 10 until 80 do
      <>
 end$

% #10: Test of atand tand: ideal values i for i:=-9:89.

begin
   for i:=-9:89 do
      <",if i=0 then 1.0 else atand tand float i;
        terpr(i,4)>>
 end$

% #11: Test of acot cotd: ideal values 10*i for i:=1:17.

begin
   for i:=10 step 10 until 170 do
   <",acotd cotd i; terpr(i,40)>>; terpri();terpri() end$

% #12: Test of asind sind: ideal values 10*i for i:=-9:9.

begin
   for i:=-90 step 10 until 90 do
      <",asind sind float i; terpr(i,40)>>
 end$

% #13: Test of acosd cosd: ideal values 10*i for i:=1:18.

begin
   for i:=10 step 10 until 180 do
      <",acosd cosd float i; terpr(i,40)>>
 end$

% #14: Test of acscd cscd: ideal values 10*i for i:=-9:9, except
%       error for i=0.

begin
   for i:=-90 step 10 until 90 do
      <",if i=0 then "error" else acscd cscd float i;
        terpr(i,40)>>
 end$

% #15: Test of asecd secd: ideal values 10*i for i :=0:18. except
%       error for i=9.

begin
   for i:=0 step 10 until 180 do
      <",if i=90 then "error" else asecd secd float i;
        terpr(i,40)>>
 end$

%*********************************************************************
%**  ===Exp,Log,Sqrt,Cbrt, and Expt  Function tests===
%*********************************************************************

% #16: Test of properties of exp function: ideal results 1.0.

array b(5)$

begin scalar x; x:=0;
   write "multiplicative property";terpri();
   for i:=0:5 do b(i):=1+i/6.0; for i:=0:5 do for j:=i:5 do
      <>
 end$

% #17: Various properties of exp: ideal results 1.0.

begin write "inverse property"$ terpri()$
   for i:=1:5 do write "  ",exp(b(i))*exp(-b(i));terpri();
   write "squares"; terpri();
      for i:=-10:10 do
         <>;
   write "cubes"; terpri();
      for i:=-10:10 do
         <>
 end$

% #18: Test of log exp: ideal results 1.0.

begin for i:=-5:5 do
   <>
 end$

% #19: Test of log10 expt(10.0,i): ideal results 1.0.

begin scalar i; write "small values i:=-5:5"; terpri();
   for j:=-5:5 do
      <>;
   write "large i=2**j where j:=0:6"; terpri();
   for j:=0:5 do
      <>;
        terpri();
        write "noninteger values of i=j/10.0 where j:=1:20";terpri();
        for j:=1:20 do
            <>
 end$

% #20: Test of properties of expt(x,i)*(expt(x,-i). ideal result 1.0.

begin integer j;
   for x:=2:6 do for i:=2:6 do
      <>
 end$

% #21: Test of expt(-x,i)/expt(x,i) for fractional i.

begin integer j,k; write "odd numerator. ideal result -1.0"; terpri();
   for i:=1:10 do
      <>;
   write "even numerator. ideal result 1.0"; terpri();
   for i:=1:10 do
      <>
 end$

% #22: Test of properties of ln or log or logb:
%      inverse argument: ideal result -1.0.

begin integer x;
   for i:=2:5 do for j:= 2:10 do
      <>
 end$

% #23: Test of log(a*b) = log a+log b: ideal result 1.0.

begin integer x;
   for i:=1:5 do for j:=i:5 do
      <>
 end$

% #24: Test of sqrt x*sqrt x/x for x:=5i*(5i/3)**i where i:=1:20
%      (test values strictly arbitrary): ideal results 1.0.

begin scalar x,s;
   for i:=1:20 do
      <>
 end$

% #25: Test of cbrt x**3/x for x:=5i*(5i/3)**i where i:=-9:10
%      (test values strictly arbitrary):ideal results 1.0.

begin scalar x,s;
   for i:=-9:10 do
      <>
 end$

%*********************************************************************
%**  ===Hyperbolic Function Tests===
%*********************************************************************

% #26: Test of sinh x+ cosh x= exp x: ideal results 1.0.

begin scalar x;
   for i:=1:10 do
      <>
 end$

% #27: Test of cosh x-sinh x= exp(-x): ideal results 1.0.

begin scalar x;
   for i:=1:10 do
      <>
 end$

% #28: Test of (cosh x)**2-(sinh x)**2: ideal results 1.0.

begin scalar x$
   for i:=1:10 do
      <>
 end$

% #29: Test of tanh*cosh/sinh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #30: Test of tanh*coth: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #31: Test of sech*cosh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #32: Test of csch*sinh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #33: Test of asinh sinh: ideal results 1.0.

begin scalar x; for i:=1:20 do
   <>
 end$

% #34: Test of acosh cosh: ideal results 1.0.  However, acosh x
%      loses accuracy as x -> 1 since d/dx cosh x -> 0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #35: Test of cosh acosh:ideal results 1.0.

begin scalar x;
   for i:=1:50 do
      <>
 end$

% #36: Test of atanh tanh: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #37: Test of acoth coth: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #38: Test of asech sech: ideal results 1.0.  However, asech x
%      loses accuracy as x -> 1 since d/dx sech x -> 0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

% #39: Test of acsch csch: ideal results 1.0.

begin scalar x;
   for i:=1:20 do
      <>
 end$

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/arith.red0000644000175000017500000001547511526203062023432 0ustar  giovannigiovannimodule arith;  % Header module for real arith package.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Last updated Dec 14, 1992

% Assumptions being made on the underlying arithmetic:
%
% (1) The integer arithmetic is binary.
%
% (2) It is possible to convert any lisp float into an integer
%     by applying fix, and this yields the result with the full
%     precision of the float.
%


create!-package('(arith smlbflot bfauxil paraset math rounded comprd
                  rdelem crelem bfelem), nil);

flag('(arith),'core_package);

exports ashift, bfloat, bfminusp, bfnzp, bfp!:, bfzp, crim, crrl,
        divbf, ep!:, gfzerop, i2bf!:, lshift, make!:cr, make!:ibf,
        make!:rd, msd!:, mt!:, oddintp, preci!:, rdp, retag, rndpwr,
        sgn, tagrl, tagim, timbf;

imports eqcar, round!:mt;

fluid '(!*noconvert !:bprec!: dmode!*);

switch noconvert;

symbolic smacro procedure mt!: u;
   % This function selects the mantissa of U, a binary bigfloat
   % representation of a number.
   cadr u;

symbolic smacro procedure ep!: u;
   % This function selects the exponent of U, a binary bigfloat
   % representation of a number.
   cddr u;

symbolic smacro procedure make!:ibf (mt, ep);
   '!:rd!: . (mt . ep);

symbolic smacro procedure i2bf!: u; make!:ibf (u, 0);

symbolic smacro procedure make!:rd u;
   '!:rd!: . u;

symbolic smacro procedure rdp x;
   % This function returns true if X is a rounded number
   % representation, else NIL.  X is any Lisp entity.
   eqcar(x,'!:rd!:);

symbolic smacro procedure float!-bfp x; atom cdr x;

symbolic smacro procedure rd2fl x; cdr x;

symbolic smacro procedure fl2rd x; make!:rd x;

symbolic smacro procedure bfp!:(x);
   % This function returns true if X is a binary bigfloat
   % representation, else NIL.  X is any Lisp entity.
   rdp x and not float!-bfp x;

symbolic smacro procedure retag u;
   if atom u then u else '!:rd!: . u;

symbolic smacro procedure rndpwr j; normbf round!:mt(j,!:bprec!:);

symbolic procedure msd!: m;
  % returns the position n of the most significant (binary) digit
  % of a positive binary integer m, i.e. floor(log2 m) + 1
  begin integer i,j,k;
    j := m;
    while (j := ((k := j) / 65536)) neq 0 do i := i + 16;
    j := k;
    while (j := ((k := j) / 256)) neq 0 do i := i + 8;
    j := k;
    while (j := ((k := j) / 16)) neq 0 do i := i + 4;
    j := k;
    while (j := ((k := j) / 2)) neq 0 do i := i + 1;
    return (i + 1);
  end;

symbolic procedure ashift(m,d);
   % This procedure resembles loosely an arithmetic shift.
   %  It returns m*2**d
   if d=0 then m
    else if d<0 then m/2**(-d)
    else m*2**d;

symbolic procedure lshift(m,d);
   % Variant of ashift that is called ONLY when m>=0.
   %  This should be redefined for Lisp systems that provide
   %  an efficient logical shift.
   ashift(m,d);

symbolic smacro procedure oddintp n; not evenp n;

symbolic smacro procedure preci!: nmbr;
   % This function counts the precision of a number "n". NMBR is a
   % binary bigfloat representation of "n".
   msd!: abs mt!: nmbr;


symbolic smacro procedure divbf(u,v); normbf divide!:(u,v,!:bprec!:);

symbolic smacro procedure timbf(u,v); rndpwr times!:(u,v);

symbolic smacro procedure bfminusp u;
  if atom u then minusp u else minusp!: u;

symbolic smacro procedure bfzp u;
  if atom u then zerop u else mt!: u=0;

symbolic smacro procedure bfnzp u; not bfzp u;

symbolic smacro procedure bfloat x;
  if floatp x then fl2bf x
   else normbf(if not atom x then x
                else if fixp x then i2bf!: x
                else read!:num x);

symbolic smacro procedure rdfl2rdbf x; fl2bf rd2fl x;

symbolic smacro procedure rd!:forcebf x;
   % forces rounded number x to binary bigfloat representation
   if float!-bfp x then rdfl2rdbf x else x;

symbolic smacro procedure crrl x; cadr x;

symbolic smacro procedure crim x; cddr x;

symbolic smacro procedure make!:cr (re,im);
   '!:cr!: . (re . im);

symbolic smacro procedure crp x;
   % This function returns true if X is a complex rounded number
   % representation, else NIL.  X is any Lisp entity.
   eqcar(x,'!:cr!:);

symbolic smacro procedure tagrl x; make!:rd crrl x;

symbolic smacro procedure tagim x; make!:rd crim x;

symbolic smacro procedure gfrl u; car u;

symbolic smacro procedure gfim u; cdr u;

symbolic smacro procedure mkgf (rl,im); rl . im;

symbolic smacro procedure gfzerop u;
  if not atom gfrl u then mt!: gfrl u = 0 and mt!: gfim u = 0
   else u = '(0.0 . 0.0);

% symbolic smacro procedure sgn x;
%   if x>0 then 1 else if x<0 then -1 else 0;


global '(bfz!* bfhalf!* bfone!* bftwo!* bfthree!* bffive!* bften!*
         !:bf60!* !:180!* !:bf1!.5!*);

global '(!:bf!-0!.25        %0.25
         !:bf!-0!.0625      %0.0625
         !:bf0!.419921875   %0.419921875
        );

%Miscellaneous constants

bfz!* := make!:ibf(0,0);

bfhalf!* := make!:ibf(1,-1);

bfone!* := make!:ibf(1,0);

!:bf1!.5!* := make!:ibf (3, -1);

bftwo!* := make!:ibf (2, 0);

bfthree!* := make!:ibf (3, 0);

bffive!* := make!:ibf (5, 0);

bften!* := make!:ibf (5, 1);

!:bf60!* := make!:ibf (15, 2);

!:180!* := make!:ibf (45, 2);

!:bf!-0!.25 := make!:ibf(1,-2);

!:bf!-0!.0625 := make!:ibf (1, -4);

!:bf0!.419921875 := make!:ibf(215, -9);

% These need to be added to other modules.

symbolic procedure dn!:simp u;
  if car u = 0 then nil ./ 1
   else if u = '(10 . -1) and null !*noconvert then 1 ./ 1
   else if dmode!* memq '(!:rd!: !:cr!:)
    then rd!:simp cdr decimal2internal (car u, cdr u)
   else if cdr u >= 0 then !*f2q (car u * 10**cdr u)
   else simp {'quotient, car u, 10**(-cdr u)};

put ('!:dn!:, 'simpfn, 'dn!:simp);

symbolic procedure dn!:prin u;
  bfprin0x (cadr u, cddr u);

put ('!:dn!:, 'prifn, 'dn!:prin);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/comprd.red0000644000175000017500000002510411526203062023575 0ustar  giovannigiovannimodule comprd; % *** Support for Complex Rounded Arithmetic.

% Authors: Anthony C. Hearn and Stanley L. Kameny.

% Last updated: 23 June 1993.

% Copyright (c) 1989, 1993 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


Comment this module defines a complex rounded as:

  (. ( . >)  or  ('!:cr!: . (rl . im))

The  depends on the precision.  It is either a floating point
number or the stripped bfloat (mt . ep);


exports !*cr2crn, !*cr2rd, !*cr2rn, !*crn2cr, !*gi2cr, !*rd2cr,
        !*rn2cr, cr!:differ, cr!:minus, cr!:minusp, cr!:onep,
        cr!:plus, cr!:prep, cr!:prin, cr!:quotient, cr!:times,
        cr!:zerop, cr2i!*, crhalf!*, cri!*, cri!/2, crone!*, crprcd,
        gf2cr!:, i2cr!*, mkcr;

imports bfloat, bfnzp, bftrim!:, bfzp, chkint!*, chkrn!*, convprec,
        convprec!*, crim, crrl, ep!:, errorp, errorset!*,
        gf2bf, gfdiffer, gfminus, gfplus, gfquotient, gftimes,
        gfzerop, initdmode, leq, lessp!:, make!:cr, make!:rd, maprin,
        mkcrn, mkquote, mkrn, mkround, normbf, over, plubf, preci!:,
        prin2!*, r2bf, rd!:minus, rd!:minusp, rd!:onep, rd!:prep,
        rd!:zerop, rdprep1, rdhalf!*, rdone!*, rdqoterr, rdtwo!*,
        rdzchk, rdzero!*, realrat, retag, rndbfon, round!:mt,
        safe!-fp!-plus, safe!-fp!-times, timbf, union;

fluid '(!:prec!: !:bprec!:);

global '(bfone!* epsqrt!*);

fluid '(dmode!* !*bfspace !*numval !*roundbf !*!*roundbf);

global '(cr!-tolerance!* domainlist!* !!nfpd !!flprec !!rdprec bfz!*
         yy!!);

domainlist!* := union('(!:cr!:),domainlist!*);

fluid '(!*complex!-rounded);

put('complex!-rounded,'tag,'!:cr!:);
put('!:cr!:,'dname,'complex!-rounded);
flag('(!:cr!:),'field);
put('!:cr!:,'i2d,'i2cr!*);
put('!:cr!:,'plus,'cr!:plus);
put('!:cr!:,'times,'cr!:times);
put('!:cr!:,'difference,'cr!:differ);
put('!:cr!:,'quotient,'cr!:quotient);
put('!:cr!:,'zerop,'cr!:zerop);
put('!:cr!:,'onep,'cr!:onep);
put('!:cr!:,'prepfn,'cr!:prep);
put('!:cr!:,'prifn,'cr!:prin);
put('!:cr!:,'minus,'cr!:minus);
put('!:cr!:,'minusp,'cr!:minusp);
% put('!:cr!:,'rationalizefn,'girationalize!:);  % Needs something
                                                 % different.
put('!:cr!:,'!:rn!:,'!*cr2rn);
put('!:rn!:,'!:cr!:,'!*rn2cr);
put('!:rd!:,'!:cr!:,'!*rd2cr);
put('!:cr!:,'!:rd!:,'!*cr2rd);
put('!:cr!:,'!:crn!:,'!*cr2crn);
put('!:crn!:,'!:cr!:,'!*crn2cr);
put('!:gi!:,'!:cr!:,'!*gi2cr);
put('!:cr!:,'cmpxfn,'mkcr);
put('!:cr!:,'ivalue,'mkdcrn);
put('!:cr!:,'realtype,'!:rd!:);
put('!:rd!:,'cmpxtype,'!:cr!:);

symbolic procedure cr!:minusp u;
   (if atom x then zerop y and x<0 else zerop car y and car x<0)
    where x=cadr u,y=cddr u;

symbolic procedure striptag u; if atom u then u else cdr u;

symbolic procedure mkcr(u,v); make!:cr (striptag u, striptag v);

symbolic procedure gf2cr!: x;
   make!:cr (striptag car x, striptag cdr x);

symbolic procedure crprcd u;
   (rl . im) where rl=convprec!* crrl u,im=convprec!* crim u;

symbolic procedure crprcd2(x,y);
   <>;

% simp must call convprec!*, since precision may have changed.
symbolic procedure cr!:simp u; (gf2cr!: crprcd u) ./ 1;

put('!:cr!:,'simpfn,'cr!:simp);

%symbolic procedure mkdcr u; cri!*() ./ 1;

symbolic procedure i2cr!* u;
   %converts integer U to tagged cr form.
   <>;

symbolic procedure trimcrrl n; trimcr crrl n;

symbolic procedure trimcr n;
   bftrim!: if atom n then bfloat n else retag n;

symbolic procedure cr2rderr;
   error(0,
   "complex to real type conversion requires zero imaginary part");

symbolic procedure !*cr2rn n;
   % Converts a cr number n into a rational if possible.
   if bfnzp retag crim n then cr2rderr() else
   <>;

symbolic procedure !*rn2cr u;
   % Converts the (tagged) rational u/v into a (tagged) rounded complex
   % number to the system precision.
   <>;

symbolic procedure !*cr2crn u;
   % Converts a (tagged) cr number u into a (tagged) crn.
   mkcrn(realrat trimcrrl u,realrat trimcr crim u);

symbolic procedure !*crn2cr u;
   % Converts a (tagged) crn number u into a (tagged) cr.
    mkcr(rl,if !*roundbf then bfloat im else im)
     where rl=chkrn!* r2bf cadr u where im=chkrn!* r2bf cddr u;

symbolic procedure !*cr2rd n;
   if bfnzp retag crim n then cr2rderr() else make!:rd crrl n;

symbolic procedure !*rd2cr u;
   mkcr(x,if atom x then 0.0 else bfz!*) where x=convprec u;

symbolic procedure !*gi2cr u;
   mkcr(rl,if !*roundbf then bfloat im else im)
    where rl=chkint!* cadr u where im=chkint!* cddr u;

symbolic procedure bfrsq u;
   (if atom x then x*x+y*y else plubf(timbf(x,x),timbf(y,y)))
    where x=car u,y=cdr u;

symbolic procedure crzchk(u,x,y);
 begin
    if atom car u then
      if bfrsq u<(bfrsq x)*!!fleps2 then return 0.0 . 0.0 else go to ck;
    if lessp!:(bfrsq u,timbf(bfrsq x,cr!-tolerance!*)) then
      return bfz!* . bfz!*;
ck: return rdzchk(car u,car x,car y) . rdzchk(cdr u,cdr x,cdr y) end;

symbolic procedure cr!:plus(u,v);
 begin scalar x,y; x := crprcd2(u,v); y := yy!!;
   u := if !*!*roundbf then gfplus(x,y)
        else if (v := safe!-crfp!-plus(x,y)) then v else
     ((if errorp r then
       <> else car r)
     where r=errorset(list('gfplus,mkquote x,mkquote y),nil,nil));
   return gf2cr!: crzchk(u,x,y) end;

symbolic procedure cr!:differ(u,v);
 begin scalar x,y; x := crprcd2(u,v); y := yy!!;
   u := if !*!*roundbf then gfdiffer(x,y)
        else if (v := safe!-crfp!-diff(x,y)) then v else
     ((if errorp r then
       <> else car r)
     where r=errorset(list('gfdiffer,mkquote x,mkquote y),nil,nil));
   return gf2cr!: crzchk(u,x,gfminus y) end;

symbolic procedure cr!:times(u,v);
 gf2cr!:
 (if !*!*roundbf then gftimes(x,yy!!)
  else if (u := safe!-crfp!-times(x,yy!!)) then u else
 ((if errorp r then <>
      else car r)
    where r=errorset!*(list('gftimes,mkquote x,mkquote yy!!),nil)))
   where x=crprcd2(u,v);

symbolic procedure cr!:quotient(u,v);
 gf2cr!:
 (if gfzerop yy!! then rdqoterr()
  else if !*!*roundbf then gfquotient(x,yy!!)
  else if (u := safe!-crfp!-quot(x,yy!!)) then u else
 ((if errorp r then
      <> else car r)
    where r=errorset!*(list('gfquotient,mkquote x,mkquote yy!!),nil)))
   where x=crprcd2(u,v);

symbolic procedure safe!-crfp!-plus(u,v);
   (if x and y then crzchk(x . y,u,v))
   where x=safe!-fp!-plus(car u,car v),y=safe!-fp!-plus(cdr u,cdr v);

symbolic procedure safe!-crfp!-diff(u,v);
   (if x and y then crzchk(x . y,u,gfminus v))
   where x=safe!-fp!-plus(car u,-car v),y=safe!-fp!-plus(cdr u,-cdr v);

symbolic procedure safe!-crfp!-times(u,v);
   begin scalar ru,iu,rv,iv,a,b;
      ru := car u; iu := cdr u; rv := car v; iv := cdr v;
      if not (a := safe!-fp!-times(ru,rv)) or
         not (b := safe!-fp!-times(iu,iv)) then return nil;
      if not(u := safe!-fp!-plus(a,-b)) then return nil;
      u := rdzchk(u,a,-b);
      if not (a := safe!-fp!-times(ru,iv)) or
         not (b := safe!-fp!-times(iu,rv)) then return nil;
      if not(v := safe!-fp!-plus(a,b)) then return nil;
      return u . rdzchk(v,a,b) end;

symbolic procedure safe!-crfp!-quot(u,v);
  % compute u * inverse v.
   begin scalar ru,iu,rv,iv,a,b,dd;
      ru := car u; iu := cdr u; rv := car v; iv := cdr v;
      if not (a := safe!-fp!-times(rv,rv)) or
         not (b := safe!-fp!-times(iv,iv)) or
         not (dd := safe!-fp!-plus(a,b)) then return nil;
      rv := rv/dd; iv := iv/dd;
      if not (a := safe!-fp!-times(ru,rv)) or
         not (b := safe!-fp!-times(iu,iv)) or
         not (u := safe!-fp!-plus(a,b)) then return nil;
      u := rdzchk(u,a,b);
      if not (a := safe!-fp!-times(ru,-iv)) or
         not (b := safe!-fp!-times(iu,rv)) or
         not (v := safe!-fp!-plus(a,b)) then return nil;
      return u . rdzchk(v,a,b) end;

symbolic procedure cr!:minus u; gf2cr!: gfminus crprcd u;

symbolic procedure cr!:zerop u;
   bfzp retag crrl u and bfzp retag crim u;

symbolic procedure cr!:onep u;
   bfzp retag crim u and rd!:onep mkround retag crrl u;

% prep works entirely in bfloat, to avoid floating point conversion
% errors.

symbolic procedure cr!:prep u;
   crprep1((rd!:prep tagrl u) . rd!:prep tagim u);

symbolic procedure crprep1 u;
 % a and d are 1,-1,or rounded.
  (if not numberp d and rd!:zerop d then a else
     <> >>) where a=car u,d=cdr u;

symbolic procedure crprimp u;
   if u=1 then 'i else if u= -1 then {'minus,'i} else {'times,u,'i};

symbolic procedure cr!:prin v;
   if atom (v := cr!:prep v)
     or car v eq 'times or car v memq domainlist!*
      then maprin v
    else <>;

initdmode 'complex!-rounded;

symbolic procedure crone!*; mkcr(rdone!*(),rdzero!*());

symbolic procedure crhalf!*; mkcr(rdhalf!*(),rdzero!*());

symbolic procedure cri!*; mkcr(rdzero!*(),rdone!*());

symbolic procedure cri!/2; mkcr(rdzero!*(),rdhalf!*());

symbolic procedure cr2i!*; mkcr(rdzero!*(),rdtwo!*());

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/arith/load.red0000644000175000017500000000303311526203062023225 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

on comp;

off usermode;

lisp compiletime load "fast-math";

in "../build/psl.red"$
in "arith.red"$
in "smlbflot.red"$
in "bfauxil.red"$
in "paraset.red"$
in "math.red"$
in "rounded.red"$
in "comprd.red"$
in "rdelem.red"$
in "crelem.red"$
in "bfelem.red"$

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/0000755000175000017500000000000011722677362022205 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/rataprx.rlg0000644000175000017500000005010011527635055024364 0ustar  giovannigiovanniFri Feb 18 21:28:57 2011 run on win32
% Tests of the rataprx package.

% Authors: Lisa Temme, Wolfram Koepf (koepf@zib.de)

% periodic decimal representations
rational2periodic(1/3);


  _
0.3

periodic2rational(ws);


 1
---
 3

rational2periodic(-1/3);


   _
-0.3

periodic2rational(ws);


  - 1
------
  3

rational2periodic(1.2/3);


   
0.4

periodic2rational(ws);


 2
---
 5

rational2periodic(1/3.4);


  ________________
0.2941176470588235

periodic2rational(ws);


 5
----
 17

rational2periodic(1.2/3.4);


  ________________
0.3529411764705882

periodic2rational(ws);


 6
----
 17

rational2periodic(352673/3124);


periodic({11289,100},{1,

            4,

            8,

            5,

            2,

            7,

            5,

            2,

            8,

            8,

            0,

            9,

            2,

            1,

            8,

            9,

            5,

            0,

            0,

            6,

            4,

            0,

            2,

            0,

            4,

            8,

            6,

            5,

            5,

            5,

            6,

            9,

            7,

            8,

            2,

            3,

            3,

            0,

            3,

            4,

            5,

            7,

            1,

            0,

            6,

            2,

            7,

            4,

            0,

            0,

            7,

            6,

            8,

            2,

            4,

            5,

            8,

            3,

            8,

            6,

            6,

            8,

            3,

            7,

            3,

            8,

            7,

            9,

            6,

            4})

periodic2rational(ws);


 352673
--------
  3124

rational2periodic(53765/5216);


periodic({1030770,100000},{7,

            0,

            5,

            5,

            2,

            1,

            4,

            7,

            2,

            3,

            9,

            2,

            6,

            3,

            8,

            0,

            3,

            6,

            8,

            0,

            9,

            8,

            1,

            5,

            9,

            5,

            0,

            9,

            2,

            0,

            2,

            4,

            5,

            3,

            9,

            8,

            7,

            7,

            3,

            0,

            0,

            6,

            1,

            3,

            4,

            9,

            6,

            9,

            3,

            2,

            5,

            1,

            5,

            3,

            3,

            7,

            4,

            2,

            3,

            3,

            1,

            2,

            8,

            8,

            3,

            4,

            3,

            5,

            5,

            8,

            2,

            8,

            2,

            2,

            0,

            8,

            5,

            8,

            8,

            9,

            5})

periodic2rational(ws);


 53765
-------
 5216


% continued fractions
% of numbers
cfrac pi;


  1146408
{---------,
  364913

                               1
 3 + ------------------------------------------------------}
                                 1
      7 + ------------------------------------------------
                                    1
           15 + -----------------------------------------
                                      1
                 1 + -----------------------------------
                                         1
                      292 + ---------------------------
                                           1
                             1 + ---------------------
                                             1
                                  1 + ---------------
                                               1
                                       1 + ---------
                                                 1
                                            2 + ---
                                                 1

cfrac(pi,3);


  355             1
{-----,3 + ----------------}
  113               1
            7 + ----------
                       1
                 15 + ---
                       1

cfrac(pi,20);


  1146408
{---------,
  364913

                               1
 3 + ------------------------------------------------------}
                                 1
      7 + ------------------------------------------------
                                    1
           15 + -----------------------------------------
                                      1
                 1 + -----------------------------------
                                         1
                      292 + ---------------------------
                                           1
                             1 + ---------------------
                                             1
                                  1 + ---------------
                                               1
                                       1 + ---------
                                                 1
                                            2 + ---
                                                 1

oldprec:=precision 20;


oldprec := 12

cfrac pi;


          14885392687
contfrac(-------------,{3,
          4738167652

            {1,7},

            {1,15},

            {1,1},

            {1,292},

            {1,1},

            {1,1},

            {1,1},

            {1,2},

            {1,1},

            {1,3},

            {1,1},

            {1,14},

            {1,2},

            {1,1},

            {1,1},

            {1,2},

            {1,2},

            {1,2},

            {1,2}})

cfrac(pi^2);


          27053934029
contfrac(-------------,{9,
          2741136618

            {1,1},

            {1,6},

            {1,1},

            {1,2},

            {1,47},

            {1,1},

            {1,8},

            {1,1},

            {1,1},

            {1,2},

            {1,2},

            {1,1},

            {1,1},

            {1,8},

            {1,3},

            {1,1},

            {1,10},

            {1,5},

            {1,1},

            {1,3}})

cfrac(pi*e*sqrt(2));


          22809995021
contfrac(-------------,{12,
          1888712428

            {1,12},

            {1,1},

            {1,68},

            {1,1},

            {1,3},

            {1,1},

            {1,2},

            {1,1},

            {1,6},

            {1,1},

            {1,15},

            {1,1},

            {1,5},

            {1,1},

            {1,1},

            {1,2},

            {1,1},

            {1,8},

            {1,2}})

precision oldprec;


20


% of rational functions
cfrac((x+2/3)^2/(6*x-5),x);


     2
  9*x  + 12*x + 4
{-----------------,
     54*x - 45

  6*x + 13          1
 ---------- + -------------}
     36         24*x - 20
               -----------
                    9

cfrac((x+2/3)^2/(6*x-5),x,0);


  6*x + 13   6*x + 13
{----------,----------}
     36         36

cfrac((x+2/3)^2/(6*x-5),x,1);


     2
  9*x  + 12*x + 4
{-----------------,
     54*x - 45

  6*x + 13          1
 ---------- + -------------}
     36         24*x - 20
               -----------
                    9

cfrac((x+2/3)^2/(6*x-5),x,10);


     2
  9*x  + 12*x + 4
{-----------------,
     54*x - 45

  6*x + 13          1
 ---------- + -------------}
     36         24*x - 20
               -----------
                    9

cfrac((x*8-7/2)^4/(x^5-2/3),x);


          4           3           2
  196608*x  - 344064*x  + 225792*x  - 65856*x + 7203
{----------------------------------------------------,
                          5
                      48*x  - 32

     4*x + 7        524288*x - 458752        144060*x - 574709
 1/(--------- + 1/(------------------- + 1/(------------------- + 1/(
      16384                245                   29503488

              1428871832845410168479416320*x + 5604409773009942380402638848
             --------------------------------------------------------------- + 1
                               110370509467032373008840289

             /(4638094170692621015213105500565148574652*x

                - 3747067916403980284808800355871185905903)/365473525943308099\
             0834049614798549893120))))}

cfrac((x*8-7/2)^4/(x^5-2/3),x,2);


   524288*x - 458752
{---------------------,
       2
  128*x  + 112*x + 49

                  1
 -----------------------------------}
   4*x + 7              1
  --------- + ---------------------
    16384       524288*x - 458752
               -------------------
                       245


% of analytic functions
cfrac(e^x,x,10);


      5       4        3         2
   - x  - 30*x  - 420*x  - 3360*x  - 15120*x - 30240
{----------------------------------------------------,
    5       4        3         2
   x  - 30*x  + 420*x  - 3360*x  + 15120*x - 30240

                                  x
 1 + ------------------------------------------------------------}
                                    - x
      1 + ------------------------------------------------------
                                      x
           2 + ------------------------------------------------
                                        - x
                3 + ------------------------------------------
                                          x
                     2 + ------------------------------------
                                            - x
                          5 + ------------------------------
                                              x
                               2 + ------------------------
                                                - x
                                    7 + ------------------
                                                  x
                                         2 + ------------
                                                    - x
                                              9 + ------
                                                    2

% default order is 4
cfrac(e^x,x);


   3      2
  x  + 9*x  + 36*x + 60
{-----------------------,
       2
    3*x  - 24*x + 60

                  x
 1 + ---------------------------}
                   - x
      1 + ---------------------
                      x
           2 + ---------------
                       - x
                3 + ---------
                          x
                     2 + ---
                          5

cfrac(x^2/(x-1)*e^x,x);


   6      4    2
  x  + 3*x  + x
{----------------,
     4    2
  3*x  - x  - 1

                2
             - x
 ----------------------------}
                   2
              - 2*x
  1 + ----------------------
                   2
                  x
       1 + ----------------
                     2
                    x
            1 + ----------
                       2
                      x
                 1 + ----
                      1

cfrac(x^2/(x-1)*e^x,x,2);


      2
     x
{----------,
     2
  2*x  - 1

          2
       - x
 ---------------}
             2
        - 2*x
  1 + ---------
          1

cfrac(atan(x),x,10);


               9            7             5             3
       307835*x  + 4813380*x  + 19801782*x  + 29609580*x  + 14549535*x
{----------------------------------------------------------------------------,
         10            8            6             4             2
  19845*x   + 1091475*x  + 9459450*x  + 28378350*x  + 34459425*x  + 14549535

                                 x
 -----------------------------------------------------------------}
                                   2
                                  x
  1 + -----------------------------------------------------------
                                      2
                                   4*x
       3 + -----------------------------------------------------
                                        2
                                     9*x
            5 + -----------------------------------------------
                                           2
                                       16*x
                 7 + -----------------------------------------
                                             2
                                         25*x
                      9 + -----------------------------------
                                               2
                                           36*x
                           11 + ----------------------------
                                                  2
                                              49*x
                                 13 + ---------------------
                                                    2
                                                64*x
                                       15 + --------------
                                                       2
                                                   81*x
                                             17 + -------
                                                    19

cfrac(asin(x),x,5);


         5           3
  69049*x  - 717780*x  + 922320*x
{---------------------------------,
          4           2
  145125*x  - 871500*x  + 922320

                    x
 ----------------------------------------}
                        2
                     - x
  1 + ----------------------------------
                            2
                      - 17*x
       6 + ----------------------------
                               2
                        - 549*x
            10 + ---------------------
                                   2
                          - 69049*x
                  238 + -------------
                            1098


% not implemented
cfrac(log(x),x,4);


***** not yet implemented 

cfrac(asech(x),x,5);


***** not yet implemented 

cfrac(sin sqrt x,x,4);


***** not yet implemented 

% wrong input
cfrac(1,x);


cfrac(1,x)

cfrac(x,x,x);


cfrac(x,x,x)

cfrac(x,x,x,5);


cfrac(x,x,x,5)


% Pade representations
pade(sin(x),x,0,3,3);


          2
 x*( - 7*x  + 60)
------------------
       2
   3*(x  + 20)

pade(tanh(x),x,0,5,5);


     4        2
 x*(x  + 105*x  + 945)
-----------------------
      4       2
 15*(x  + 28*x  + 63)

pade(atan(x),x,0,5,5);


        4        2
 x*(64*x  + 735*x  + 945)
--------------------------
         4       2
 15*(15*x  + 70*x  + 63)

pade(1/(x*sin(x)),x,0,3,2);


  2
 x  + 6
--------
     2
  6*x

pade(sin(x)/x^2,x,0,10,1);


     10        8         6           4            2
  - x   + 110*x  - 7920*x  + 332640*x  - 6652800*x  + 39916800
---------------------------------------------------------------
                          39916800*x

pade(sin(x)/x^2,x,0,10,2);


     10        8         6           4            2
  - x   + 110*x  - 7920*x  + 332640*x  - 6652800*x  + 39916800
---------------------------------------------------------------
                          39916800*x

pade(sin(x)/x^2,x,0,10,3);


        10         8           6             4              2
  - 23*x   + 4620*x  - 451440*x  + 22619520*x  - 498960000*x  + 3113510400
---------------------------------------------------------------------------
                                        2
                           19958400*x*(x  + 156)

pade(exp(x),x,0,10,10);


  10        9         8           7            6             5               4
(x   + 110*x  + 5940*x  + 205920*x  + 5045040*x  + 90810720*x  + 1210809600*x

                 3                2                                    10
  + 11762150400*x  + 79394515200*x  + 335221286400*x + 670442572800)/(x

           9         8           7            6             5               4
    - 110*x  + 5940*x  - 205920*x  + 5045040*x  - 90810720*x  + 1210809600*x

                   3                2
    - 11762150400*x  + 79394515200*x  - 335221286400*x + 670442572800)

pade(sin(x),x,0,20,20);


                                                                 18
(420*x*( - 1670454796485655407005204111896505853962882149730473*x

                                                                    16
         + 3750723201144687025399857898162770954823924964685652842*x

                                                                       14
         - 3582506072289078352047596683909246967322825072732178695360*x

                                                                          12
         + 1869589702800106132374452333905246037435005346891034203856000*x

                                                                            10
         - 573228615690533362277150976788354558105622438150759712792761600*x

                                                                               8
         + 103954806107838160002753187442833010398502453693126706480803904000*x

         - 10728835421367893971671793497263049404983813914658053829579862016000

          6
        *x  + 

                                                                               4
        575186523659337692549014637994968894181652462542936979129823993856000*x

         - 

        13299404753182468245973779380302173780050163417906548608594453340160000

          2
        *x  + 8461166135144631096871438729757765368229020614386275136075764211\
                                                                   20
        7120000))/(9703514253649496804459335098386178033709237613*x

                                                          18
    + 26693188916859840432281615685297667671827346329880*x

                                                             16
    + 40131841713883475746635715860433350742371877282920840*x

                                                                14
    + 42773075706893663042738071933996865427898294402559424000*x

                                                                   12
    + 35329791607150874190393563954056763271257094118524405024000*x

                                                                      10
    + 23367407211060385995097426988941972393423826920849430345472000*x

                                                                         8
    + 12411237061763347778639777646354605230793727402242210950475520000*x

                                                                           6
    + 5182014156622335713728846799235531962702355938650410017404846080000*x

                                                                              4
    + 1615241584293926563589087600285609358152611856120931412435087564800000*x  

                                                                               2
   + 337066298264605104501019771103522770139245794549642179643364545331200000*x

    + 35536897767607450606860042664982614546561886580422355571518209689190400000

   )

% no Pade Approximation exists 
pade(exp(1/x),x,0,5,5);


***** no Pade Approximation exists 

% wrong order
pade(sin(x)/x^2,x,0,10,0);


***** Pade Approximation of this order does not exist 

% not implemented
pade(factorial(x),x,1,3,3);


***** not yet implemented 

% extended Pade representations
pade(asech(x),x,0,3,3);


              2                        2                 2
  - 3*log(x)*x  + 8*log(x) + 3*log(2)*x  - 8*log(2) + 2*x
-----------------------------------------------------------
                            2
                         3*x  - 8

taylor(ws-asech(x),x,0,10);


               11       13    6     43    8    1611    10      11
log(x)*(0 + O(x  )) + (-----*x  + ------*x  + -------*x   + O(x  ))
                        768        2048        81920

pade(sin(sqrt(x)),x,0,3,3);


                 3            2
 sqrt(x)*(56447*x  - 4851504*x  + 132113520*x - 885487680)
-----------------------------------------------------------
               3         2
       7*(179*x  - 7200*x  - 2209680*x - 126498240)

taylor(ws-sin(sqrt(x)),x,0,10);


        1        13/2         1399187         15/2
 - ------------*x     + --------------------*x
    6227020800           229747925062656000

          1364974757          17/2           12300718539103          19/2
 - -------------------------*x     + ------------------------------*x
    10397012600785434624000           6310321239870308548952064000

      21/2
 + O(x    )


end;


Time for test: 329 ms, plus GC time: 15 ms
@@@@@ Resources used: (0 3 24 6)
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/pade.red0000644000175000017500000001100011526203062023562 0ustar  giovannigiovannimodule pade;  % Pade' Approximations.

% Author: Lisa Temme

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date: 15/6/95.

algebraic;

load taylor;

load solve;

%**************
%%Include a boolean function to check for taylor expression
procedure taylorp(x);
   lisp eqcar(x,'taylor);



%% Input my code for the Pade Function

procedure pade(f, x, h, n, d);

% f is function to be approximated
% x is function variable
% h is point at which approximation is evaluated
% n is degree (wanted) of numerator of rational function approximation
% d is degree (wanted) of denominator of rational function approximation

   begin
     scalar y,g,numer,denom, num_var_list, den_var_list, variable_list,
            tay_expsn,tay_output,poly_taylor,coeff_list,j, k, kk, a, b,
            new_list,answer,part_answer,count,zero_check_list,p,q,r;

%check to see if input is rational
%if so larger degrees of n & d will return input
     if type_ratpoly(f,x) AND deg(num f,x)<=n AND deg(den f,x)<=d
     then return f
     else
     << y := lisp gensym();            %declare y as local variable
             lisp(a:=  gensym());                       %\  declare
        lisp(b:=  gensym());                       % | a and b
        lisp eval list ('operator,mkquote list a); % | as local
        lisp eval list ('operator,mkquote list b); %/  operators

        g := sub(x=y+h,f);            %rewrite f in terms of y at 0

        numer :=  for k:=0:n sum a(k)*y^k;
        denom :=  for j:=0:d sum b(j)*y^j;
        num_var_list := for k:=0:n collect a(k);
        den_var_list := for j:=0:d collect b(j);
        variable_list := append(num_var_list,den_var_list);

        tay_expsn  := taylor(g, y,0,n+d);
        tay_output := taylortostandard(tay_expsn);
        if NOT(freeof(tay_output,df)) then rederr "not yet implemented"
        %Some Taylor Expansions do not exist at present.

        else
        << poly_taylor :=
              denom*(num tay_output) - numer*(den tay_output);
           coeff_list := COEFF(poly_taylor,y);

           if (n+d+1)>length(coeff_list)
           %Only consider first n+d+1 coefficients at most.

           then new_list := coeff_list
           else new_list :=
                   for kk:= 1:n+d+1 collect part(coeff_list,kk);

           part_answer := solve(new_list,variable_list);
           count :=0;
           zero_check_list :=
               for each r in
               (for each q in
                (for p:=n+2:n+d+2 collect part(first part_answer,p))
                                   collect part(q,2))
                                    do <>;

           %if all the coefficients of the denominator are zero
           if count=d+1
           then rederr "Pade Approximation of this order does not exist"

           else
           << answer:= sub(part_answer, numer/denom);
              %if Pade would be returned as a Taylor expansion
              if taylorp answer
              then rederr "no Pade Approximation exists"
%following commented out as not sure it is necessary
%                else
%                << if length answer=0
%                   then
%               rederr "Pade Approximation of this order does not exist"
              else return  sub(y=x,answer)
%                >>;
           >>;
        >>;
   >>;
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/contfr.red0000644000175000017500000000621511526203062024160 0ustar  giovannigiovannimodule contfr;  % Simultaneous approximation of a real number by a
                % continued fraction and a rational number with optional
                % user controlled precision (upper bound for numerator).

% Author: Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure contfract2 (u,b1);
 % compute continued fraction until either numerator exceeds b1
 % or approximation has reached system precision.
  begin scalar b0,l,a,b,g,gg,ggg,h,hh,hhh;
    b:= u; g:=0; gg:=1; h:=1; hh:=0;
    if null b1 then b0:= absf !:times(b,!:expt(10,- precision 0));
  loop:
    a:=rd!-fix b;
    ggg:=a*gg + g;
    hhh:=a*hh + h;
    if b1 and abs hhh > b1 then goto ret;
    g := gg; gg:=ggg; h:=hh; hh:=hhh;
    l:=a.l;
    b:=!:difference(b,a);
    if null b
      or !:lessp(absf !:difference(!:quotient(i2rd!* gg,i2rd!* hh),u),
                 b0)
         then go to ret;
    b:=!:quotient(1,b);
    go to loop;
  ret:
    return  (gg . hh) . reversip l
  end;

symbolic procedure !:lessp(u,v); !:minusp !:difference(u,v);

symbolic procedure rd!-fix u;
   if atom cdr u then fix cdr u else ashift(cadr u,cddr u);

symbolic procedure contfract1(u,b);
  begin scalar oldmode,v;
   if eqcar(v:=u,'!:rd!:) then goto c;
   oldmode := get(dmode!*,'dname).!*rounded;
   if car oldmode then setdmode(car oldmode,nil);
   setdmode('rounded,t); !*rounded := t;
   v:=reval u;
   setdmode('rounded,nil);
   if car oldmode then setdmode(car oldmode,t);
   !*rounded:=cdr oldmode;
   if eqcar(v,'minus) and (numberp cadr v or eqcar(cadr v,'!:rd!:))
     then v:=!:minus cadr v;
   if fixp v then return (v . 1).{v};
   if not eqcar(v,'!:rd!:) then
     typerr(u,"continued fraction argument");
 c:
   return contfract2(v,b);
  end;

symbolic procedure cont!-fract u;
   <>;

put('continued_fraction,'psopfn,'cont!-fract);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/primitive.red0000644000175000017500000000541111526203062024672 0ustar  giovannigiovannimodule primitive; % Include primitive module alterations to solve.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*cramer bareiss!-step!-size!*);

symbolic procedure primitivesf(xl,vl);
   % xl:list of sf, vl:list of kernel -> primitivesf:sf
   % Returns each x in xl divided by gcd of the coefficients of vl.
   % x is ordered wrt vl, and linear in vl.
   foreach x in xl collect
      quotf!*(x,coeffgcd(x,vl));

symbolic procedure coeffgcd(x,vl);
   % x:sf, vl:list of kernel -> coeffgcd:sf
   % returns gcd of coefficients of vl (including degree 0) in x
   if domainp x or not(mvar x memq vl) then x
   else if null red x then lc x
   else gcdf(lc x,coeffgcd(red x,vl));

symbolic procedure solvelnrsys(exlis,varlis);
   % exlis: list of sf, varlis: list of kernel
   % -> solvelnrsys: tagged solution list
   % Check the system for sparsity, then decide whether to use the
   % Cramer or Bareiss method.  Using the Bareiss method on sparse
   % systems, 4-step elimination seems to be faster than 2-step.
   % The Bareiss code is not good at handling surds at the moment,
   % hence exptexpflistp test.
   begin scalar w,method;
   exlis := primitivesf(exlis,varlis);
   if w := solvesparsecheck(exlis,varlis) then exlis := w
     else exlis := exlis . varlis;
   if null !*cramer and null exptexpflistp exlis
      then method := 'solvebareiss
     else method := 'solvecramer;
   exlis := apply2(method,car exlis,cdr exlis)
               where bareiss!-step!-size!* = if w then 4 else 2;
   return solvesyspost(exlis,varlis);
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/rataprx.tex0000644000175000017500000002513711526203062024400 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\bf Rational Approximations Package for REDUCE}}
\author{Lisa Temme\\Wolfram Koepf\\ e-mail: {\tt koepf@zib.de}}
\date{August 1995 : ZIB Berlin}
\begin{document}
\maketitle

\section{Periodic Decimal Representation}

The division of one integer by another often results in
a period in the decimal part. The {\tt rational2periodic}
function in this package can recognise and represent
such an answer in a periodic representation. The inverse
function, {\tt periodic2rational}, can also convert a
periodic representation back to a rational number.\\


\begin{tabbing}
{\bf \underline{Periodic Representation of a Rational Number}}\\ \\


{\bf SYNTAX:} \hspace{3mm} 
     \= {\tt rational2periodic(n);}\\ \\

{\bf INPUT:}  
     \> {\tt n} \hspace{3mm} is a rational number\\ \\

{\bf RESULT:}
     \> {\tt periodic(\{a,b\} , \{c1,...,cn\})} \\ \\
     \> where  {\tt a/b} is the non-periodic part\\
     \> and {\tt c1,...,cn} are the digits of the periodic part.\\ \\


{\bf EXAMPLE:}
    \> $59/70$ written as $0.8\overline{428571}$\\
    \>  {\tt 1: rational2periodic(59/70);}\\ \\
    \> {\tt periodic(\{8,10\},\{4,2,8,5,7,1\})}\\ \\


{\bf \underline{Rational Number of a Periodic Representation}}\\ \\


{\bf SYNTAX:}
     \> {\tt periodic2rational(periodic(\{a,b\},\{c1,...,cn\}))}\\
     \> {\tt periodic2rational(\{a,b\},\{c1,...,cn\})}\\ \\


{\bf INPUT:}
     \> \hspace{15mm} {\tt a} \hspace{3mm}\= is an integer\\
     \> \hspace{15mm} {\tt b}             \> is $1$, $-1$ or an 
                                             integer multiple of $10$\\
     \> {\tt c1,...,cn}               \> is a list of positive digits\\ \\

{\bf RESULT:}
     \> A rational number.\\ \\

{\bf EXAMPLE:}
    \> $0.8\overline{428571}$ written as $59/70$ \\
    \> {\tt 2: periodic2rational(periodic(\{8,10\},\{4,2,8,5,7,1\}));}
\\ \\
    \> \hspace{1mm} {\tt 59}\\
    \> {\tt ----}\\
    \> \hspace{1mm} {\tt 70}\\ \\
    \> {\tt 3: periodic2rational(\{8,10\},\{4,2,8,5,7,1\});}
\\ \\
    \> \hspace{1mm} {\tt 59}\\
    \> {\tt ----}\\
    \> \hspace{1mm} {\tt 70}
\end{tabbing}

Note that if {\tt a} is zero, {\tt b} will indicate how many places
after the decimal point that the period occurs. Note also that if the answer
is negative then this will be indicated by the sign of {\tt a} (unless
{\tt a} is zero in which case it is indicated by the sign of {\tt b}).
\\ \\


{\bf ERROR MESSAGE}\\

{\tt ***** operator to be used in off rounded mode}\\

The periodicity of a function can only be recognised in
the {\tt off rounded} mode. This is also true for the inverse
procedure.\\ \\





{\large\bf EXAMPLES}\\
\begin{verbatim}
4: rational2periodic(1/3);

periodic({0,1},{3})

5: periodic2rational(ws);

 1
---
 3

6: periodic2rational({0,1},{3});

 1
---
 3

7: rational2periodic(-1/6);

periodic({-1,10},{6})

8: periodic2rational(ws);

  - 1
------
  6

9: rational2periodic(6/17);

periodic({0,1},{3,5,2,9,4,1,1,7,6,4,7,0,5,8,8,2})

10: periodic2rational(ws);

 6
----
 17

11: rational2periodic(352673/3124);

periodic({11289,100},{1,4,8,5,2,7,5,2,8,8,0,9,2,1,8,9,5,0,0,6,
                      4,0,2,0,4,8,6,5,5,5,6,9,7,8,2,3,3,0,3,4,
                      5,7,1,0,6,2,7,4,0,0,7,6,8,2,4,5,8,3,8,6,
                      6,8,3,7,3,8,7,9,6,4})

12: periodic2rational(ws);

 352673
--------
  3124

\end{verbatim}
%\newpage
\section{Continued Fractions}


A continued fraction (see ~\cite{PA} \S 4.2) has the general form
{\Large
\[b_0 + \frac{a_1}{b_1 +
         \frac{a_2}{b_2+
          \frac{a_3}{b_3 + \ldots
        }}}
\;.\]
}

A more compact way of writing this is as
\[b_0 + \frac{a_1|}{|b_1} + \frac{a_2|}{|b_2} + \frac{a_3|}{|b_3} + \ldots\,.\]
\\

This is represented in {\small REDUCE} as
\[{\tt
   contfrac({\sl Rational\hspace{2mm} approximant},
                \{b0, \{a1,b1\}, \{a2,b2\},.....\})
}\]

\begin{tabbing}
\\
{\bf SYNTAX:} \hspace{5mm} 
\= {\tt cfrac(number);}\\
\> {\tt cfrac(number,length);}\\
\> {\tt cfrac(f, var);}\\
\> {\tt cfrac(f, var, length);}\\ \\

{\bf INPUT:}
\> {\tt number} \hspace{3mm} \= is any real number\\
\> {\tt f}                   \> is a function\\
\> {\tt var}                 \> is the function variable\\
%\> {\tt length}              \> is the upper bound of the number\\ 
%\>                           \> of \{ai,bi\} returned (optional)\\ \\
\end{tabbing}

{\bf Optional Argument: {\tt length}}\\

The {\tt length} argument is optional. 
For an NON-RATIONAL function input the {\tt length} argument specifies
the number of ordered pairs, $\{a_i,b_i\}$, to be 
returned. It's default value is five.
For a RATIONAL function input the
{\tt length} argument can only truncate the answer, it cannot
return additional pairs even if the precision is increased.
The default value is the complete continued fraction of the
rational input. For a NUMBER input the default value is 
dependent on the precision of the session, and the
{\tt length} argument will only take effect if it has a smaller
value than that of the number of ordered pairs which the default
value would return.\\ \\



%\newpage
\large{{\bf EXAMPLES}}\\ \\
\begin{verbatim}
13: cfrac(23.696);

          2962
contfrac(------,{23,{1,1},{1,2},{1,3},{1,2},{1,5}})
          125


14: cfrac(23.696,3);

          237
contfrac(-----,{23,{1,1},{1,2},{1,3}})
          10

15: cfrac pi;


          1146408
contfrac(---------,
          364913

         {3,{1,7},{1,15},{1,1},{1,292},{1,1},{1,1},{1,1},{1,2},{1,1}})

16: cfrac(pi,3);

          355
contfrac(-----,{3,{1,7},{1,15},{1,1}})
          113

17: cfrac(pi*e*sqrt(2),4);

          10978
contfrac(-------,{12,{1,12},{1,1},{1,68},{1,1}})
           909

18: cfrac((x+2/3)^2/(6*x-5),x,1);

             2
          9*x  + 12*x + 4    6*x + 13      24*x - 20
contfrac(-----------------,{----------,{1,-----------}})
             54*x - 45          36             9

19: cfrac((x+2/3)^2/(6*x-5),x,10);

             2
          9*x  + 12*x + 4    6*x + 13      24*x - 20
contfrac(-----------------,{----------,{1,-----------}})
             54*x - 45          36             9


20: cfrac(e^x,x);



           3      2
          x  + 9*x  + 36*x + 60
contfrac(-----------------------,{1,{x,1},{ - x,2},{x,3},{ - x,2},{x,5}})
               2
            3*x  - 24*x + 60

21: cfrac(x^2/(x-1)*e^x,x);

           6      4    2
          x  + 3*x  + x
contfrac(----------------,{0,
             4    2
          3*x  - x  - 1

                 2            2       2       2       2
            { - x ,1}, { - 2*x ,1}, {x ,1}, {x ,1}, {x ,1}})

22: cfrac(x^2/(x-1)*e^x,x,2);

             2
             x              2           2
contfrac(----------,{0,{ - x ,1},{ - 2*x ,1}})
             2
          2*x  - 1

\end{verbatim}

%\newpage
\section{Pad\'{e} Approximation}


The Pad\'{e} approximant represents a function by the ratio of two 
polynomials. The coefficients of the powers occuring in the polynomials 
are determined by the coefficients in the Taylor series
expansion of the function (see ~\cite{PA}). Given a power series
\[ f(x) = c_0 + c_1 (x-h) + c_2 (x-h)^2 \ldots \]
and the degree of numerator, $n$, and of the denominator, $d$,
the {\tt pade} function finds the unique coefficients 
$a_i,\, b_i$ in the Pad\'{e} approximant 
\[ \frac{a_0+a_1 x+ \cdots + a_n x^n}{b_0+b_1 x+ \cdots + b_d x^d} \; .\]
\\ \\

\begin{tabbing}
{\bf SYNTAX:} \hspace{5mm}\= {\tt pade(f, x, h, n, d);}\\ \\

{\bf INPUT:}
\> {\tt f} \hspace{3mm} \= is the funtion to be approximated\\
\> {\tt x}             \> is the function variable\\
\> {\tt h}             \> is the point at which the approximation is\\ 
\>                     \> evaluated\\
\> {\tt n}             \> is the (specified) degree of the numerator\\
\> {\tt d}             \> is the (specified) degree of the denominator\\ \\


{\bf RESULT:} 
\> Pad\a'{e} Approximant, ie. a rational function.\\ \\
\end{tabbing}


{\bf ERROR MESSAGES}\\

{\tt ***** not yet implemented}\\

The Taylor series expansion for the function, f, has not yet
been implemented in the {\small REDUCE} Taylor Package.\\ \\


{\tt ***** no Pade Approximation exists}\\

A Pad\'{e} Approximant of this function does not exist.\\ \\

\newpage
{\tt ***** Pade Approximation of this order does not exist}\\

A Pad\'{e} Approximant of this order (ie. the specified
numerator and denominator orders) does not exist but one
of a different order may exist.\\ \\


\large{{\bf EXAMPLES}}

\begin{verbatim}

23: pade(sin(x),x,0,3,3);

          2
 x*( - 7*x  + 60)
------------------
       2
   3*(x  + 20)

24: pade(tanh(x),x,0,5,5);

     4        2
 x*(x  + 105*x  + 945)
-----------------------
      4       2
 15*(x  + 28*x  + 63)

25: pade(atan(x),x,0,5,5);

        4        2
 x*(64*x  + 735*x  + 945)
--------------------------
         4       2
 15*(15*x  + 70*x  + 63)

26: pade(exp(1/x),x,0,5,5);

***** no Pade Approximation exists

27: pade(factorial(x),x,1,3,3);

***** not yet implemented

28: pade(asech(x),x,0,3,3);

            2                        2                 2
- 3*log(x)*x  + 8*log(x) + 3*log(2)*x  - 8*log(2) + 2*x
--------------------------------------------------------
                          2
                       3*x  - 8

29: taylor(ws-asech(x),x,0,10);

               11  
log(x)*(0 + O(x  ))

     13    6     43    8    1611    10      11
 + (-----*x  + ------*x  + -------*x   + O(x  ))
     768        2048        81920

30: pade(sin(x)/x^2,x,0,10,0);

***** Pade Approximation of this order does not exist

31:  pade(sin(x)/x^2,x,0,10,2);

     10        8         6           4            2
( - x   + 110*x  - 7920*x  + 332640*x  - 6652800*x

  + 39916800)/(39916800*x)

32: pade(exp(x),x,0,10,10);



  10        9         8           7            6
(x   + 110*x  + 5940*x  + 205920*x  + 5045040*x

              5               4                3
  + 90810720*x  + 1210809600*x  + 11762150400*x

                 2
  + 79394515200*x  + 335221286400*x + 670442572800)/

      10        9         8           7            6
    (x   - 110*x  + 5940*x  - 205920*x  + 5045040*x

                     5               4
         - 90810720*x  + 1210809600*x 

                        3               2
         - 11762150400*x + 79394515200*x  

         - 335221286400*x + 670442572800)

33: pade(sin(sqrt(x)),x,0,3,3);
        
(sqrt(x)*
            3            2
  (56447*x  - 4851504*x  + 132113520*x - 885487680))\

              3         2
    (7*(179*x  - 7200*x  - 2209680*x - 126498240))
\end{verbatim}


\begin{thebibliography}{9}
\bibitem{PA} Baker(Jr.), George A. and Graves-Morris, Peter:\\
{\it Pad\'{e} Approximants, Part I: Basic Theory},
(Encyclopedia of mathematics and its applications, Vol 13,
Section: Mathematics of physics),
Addison-Wesley Publishing Company, Reading, Massachusetts, 1981.
\end{thebibliography}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/rataprx.red0000644000175000017500000000346711526203062024354 0ustar  giovannigiovannimodule rataprx;  % Rational Approximations Package.

% Author: Lisa Temme (Student of the University of Bath in
%                     placement at ZIB Berlin)

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Send questions or comments to Winfried Neun (neun@zib.de), please.

% This package consists of: Periodic Decimal Representation;
%                           Generalized Continued Fractions;
%                           Continued Fractions for numbers;
%                           Pade Function.

create!-package('(rataprx decrep contfrac contfr primitive pade),nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/rataprx.tst0000644000175000017500000000323311526203062024403 0ustar  giovannigiovanni% Tests of the rataprx package.

% Authors: Lisa Temme, Wolfram Koepf (koepf@zib.de)

% periodic decimal representations
rational2periodic(1/3);
periodic2rational(ws);
rational2periodic(-1/3);
periodic2rational(ws);
rational2periodic(1.2/3);
periodic2rational(ws);
rational2periodic(1/3.4);
periodic2rational(ws);
rational2periodic(1.2/3.4);
periodic2rational(ws);
rational2periodic(352673/3124);
periodic2rational(ws);
rational2periodic(53765/5216);
periodic2rational(ws);

% continued fractions
% of numbers
cfrac pi;
cfrac(pi,3);
cfrac(pi,20);
oldprec:=precision 20;
cfrac pi;
cfrac(pi^2);
cfrac(pi*e*sqrt(2));
precision oldprec;

% of rational functions
cfrac((x+2/3)^2/(6*x-5),x);
cfrac((x+2/3)^2/(6*x-5),x,0);
cfrac((x+2/3)^2/(6*x-5),x,1);
cfrac((x+2/3)^2/(6*x-5),x,10);
cfrac((x*8-7/2)^4/(x^5-2/3),x);
cfrac((x*8-7/2)^4/(x^5-2/3),x,2);

% of analytic functions
cfrac(e^x,x,10);
% default order is 4
cfrac(e^x,x);
cfrac(x^2/(x-1)*e^x,x);
cfrac(x^2/(x-1)*e^x,x,2);
cfrac(atan(x),x,10);
cfrac(asin(x),x,5);

% not implemented
cfrac(log(x),x,4);
cfrac(asech(x),x,5);
cfrac(sin sqrt x,x,4);
% wrong input
cfrac(1,x);
cfrac(x,x,x);
cfrac(x,x,x,5);

% Pade representations
pade(sin(x),x,0,3,3);
pade(tanh(x),x,0,5,5);
pade(atan(x),x,0,5,5);
pade(1/(x*sin(x)),x,0,3,2);
pade(sin(x)/x^2,x,0,10,1);
pade(sin(x)/x^2,x,0,10,2);
pade(sin(x)/x^2,x,0,10,3);
pade(exp(x),x,0,10,10);
pade(sin(x),x,0,20,20);
% no Pade Approximation exists 
pade(exp(1/x),x,0,5,5);
% wrong order
pade(sin(x)/x^2,x,0,10,0);
% not implemented
pade(factorial(x),x,1,3,3);
% extended Pade representations
pade(asech(x),x,0,3,3);
taylor(ws-asech(x),x,0,10);
pade(sin(sqrt(x)),x,0,3,3);
taylor(ws-sin(sqrt(x)),x,0,10);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/decrep.red0000644000175000017500000002446211526203062024133 0ustar  giovannigiovannimodule decrep;  % Periodic Decimal Representation.

% Author: Lisa Temme

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date:   August 1995.

algebraic;

% Procedure to check if an argument is a list.

procedure paarp(x); lisp eqcar(x,'list);

procedure tidy(u);
   % tidy {wholepart, {non_recursive_decimal_part},
   %    {recursive_decimal_part}}
   % to {{num_non_per_part, den_non_per_part}, {recursive_decimal_part}}
  begin
   scalar a, b, b1, c, num_non_per_part, den_non_per_part;

    a := part(u,1);
    b := part(u,2);
    c := part(u,3);  %recursive part

    if length(b)=0 then << b1 := 0 >>
    else b1 := digits2number(b);

%%match -ve value
    if a<0
    then num_non_per_part :=a*(10^length(b)) - b1
    else num_non_per_part :=a*(10^length(b)) + b1;

    den_non_per_part := 10^length(b);

    return list(list(num_non_per_part, den_non_per_part), c)
  end;

%******************

procedure digits2number(x);
%%convert an list of digits to a number
  begin
     scalar j, number, !*rounded, dmode!*;

     if x={} OR NOT(paarp x)  %check for empty list OR non-list
     then rederr
     "argument of digits2number should be list of non-negative digits";

     number := part(x,1);

     for j:=1:(length(x)-1) do
     <<
        if (numberp(part(x,j)) and part(x,j)>0 and part(x,j)<10)
           OR part(x,j)=0
        then number := number*10 + part(x,j+1)
        else rederr
       "argument of digits2number should be list of non-negative digits"
     >>;
     return number
  end;


procedure number2digits(n);
%%convert a number to a list of digits
  begin
    scalar number, list_of_ints, tmp, next_number, flg,
           !*rounded, dmode!*;

    flg := 0;

%%check for integer argument
    if NOT(fixp n) then
         rederr "argument must be an integer";

%%match -ve Input => -ve Output
    if n<0 then << flg:=1; n:=-n >>;

%%match zero Input => zero Output
    if n=0 then return {0}
           else list_of_ints := {};

    tmp := n;
    while tmp>0 do
       <<  next_number := remainder(tmp,10);
           list_of_ints := next_number.list_of_ints;
            tmp := (tmp - next_number)/10
       >>;

%%match -ve Input => -ve Output
    if flg=1
    then return append(list(- first list_of_ints), rest list_of_ints)
    else return list_of_ints;

%    if flg=1 then return list("-",list_of_ints)
%             else return list_of_ints;
  end;

%***********************
operator periodic;

procedure rational2periodic(xx);
%%gives periodic decimal representation of integer division
 %%check to see if rounded switch is off
  if lisp !*rounded
  then rederr "operator to be used in off rounded mode"
  else
  < -ve Output
      negflg := 0;
      if xx<0
      then
        << n_repr := append(list(- first number2digits(n)),
                                    rest number2digits(n));
           negflg := negflg + 1
        >>
      else n_repr := number2digits(n);

%%calculate before decimal point
    answer := {};
    numerator := first(n_repr);
    while length(n_repr) >1 do
    <<
      n_repr := rest n_repr;
      answer := ((numerator - remainder(numerator, m))/m).answer;
      numerator := remainder(numerator, m) * 10 + first n_repr
    >>;
    answer := ((numerator - remainder(numerator, m))/m).answer ;
    wholepart := digits2number(reverse(answer));

%%calculate first decimal digit
    numerator := remainder(numerator,m)*10;
    numb := (numerator - remainder(numerator, m))/m;
    remd := remainder(numerator, m);
    z := {};
    numerator := remd*10;

%%calculate decimal part & check for recursion
    while length(nexttry(numb, remd, z)) neq 2
    do
    << z := {numb, remd}.z;
       numb := (numerator - remainder(numerator, m))/m;
       remd := remainder(numerator,m);
       numerator   := remd*10;
    >>;

%%nexttry returns either {} or {decimal_ans, recurrence}
    nexttryresult := nexttry(numb, remd, z);

%%put result in form
%% { {numerator non-periodic part, denominator non-periodic part},
%%                                                       {period} }

    %%match -ve Input => -ve Output
    if negflg neq 0
    then
      << if wholepart=0
         then
           << partresult := tidy(list(wholepart,
                                       first(nexttryresult),
                                       second(nexttryresult)));

              if length(first(nexttryresult))=0
              then
                << result := list(first  first partresult,
                                  - second first partresult).
                             rest partresult;
                >>
              else
                << result := list(-first  first partresult,
                                   second first partresult).
                             rest partresult
                >>;
           >>
         else
           << partresult := tidy(list(wholepart,
                                       first(nexttryresult),
                                       second(nexttryresult)));

              result := list(-first  first partresult,
                              second first partresult).
                        rest partresult
           >>;
      >>
    else
      << result := tidy(list(wholepart,
                             first(nexttryresult),
                             second(nexttryresult)))
      >>;

%return result;
    return periodic(first result, second result);
  end
  >>;


procedure nexttry(x,y,z);
%%compare {x,y} with z (the list of previous ordered pairs {x,y})
  begin
   scalar recurrence, decimal_ans, num_rem, ans, h, k, j,
          !*rounded, dmode!*; %added dmode!* here

     recurrence :={};
     decimal_ans := {};
     num_rem := {x,y};
     ans := {};
     h:=0;
     k := length(z);

%%look through z to see if {x,y} has already occured
     while (k>0 and h=0) do
     <<
        if num_rem = part(z,k) then
        <<
           for j := 1:k do recurrence  := first(part(z,j)).recurrence;
           for j := k+1:length(z)
                        do decimal_ans := first(part(z,j)).decimal_ans;
           h:=1;
        >>;
     k := k-1;
     if h=1 then ans := list(decimal_ans,recurrence)
     >>;

%%return list(decimal_ans,recurrence)
    return ans
  end;



operator periodic2rational;

%% Ruleset to allow two types of periodic input.
per2ratRULES :=
{
    periodic2rational(periodic(~x,~y)) => periodic2rational(x,y)
                                          when paarp x and length x=2
                                                       and paarp y,

    periodic2rational(~x,~y) => per2rat(x,y)
                                when paarp x and length x=2
                                             and paarp y

};
let per2ratRULES;



%% Procedure to convert a periodic representation to a rational one.
procedure per2rat(ab,c);
 %%check to see if rounded switch is off
  if lisp !*rounded
  then rederr "operator to be used in off rounded mode"
  else
  <>;

      if NOT(fixp b) OR
         ( (remainder(b,10) neq 0)  AND (b neq 1) AND (b neq -1) )
      then rederr "denominator must be 1, -1 or a multiple of 10";

      if length c = 0 then number_c = 0
      else number_c := digits2number c;

      power := length c;

      fract := a/b + 1/b*(number_c/10^power*(1/(1-1/10^power)));

      return fract

    end
  >>;

% printers

symbolic procedure print_periodic (u);

   if not(!*nat) or
        (length caddr u + 10) > (linelength nil) then 'failed else

   begin scalar oo,x,intpart,intstring,l1,l2,perio,minussign;

    intpart := cdr cadr u;
    if cadr intpart= (-1) then
        << minussign := t; intpart := list (car intpart, 1)>>;
    if car intpart < 0 then
        << minussign := t;
           intpart := list (-(car intpart),cadr intpart)>>;
    intstring :=  explode car intpart;
    l1 := length intstring;
    l2 := length explode cadr intpart;

    perio   := cdr caddr u;
    ycoord!* := ycoord!* +1;
    oo := posn!*;
    ymax!* := max(ymax!*,ycoord!*);
    x:= max(l1,l2);
    if minussign then x  := x + 1;
    for i:=0:x do prin2!* " ";
    x := for each q in perio sum length explode q;
    if not(caddr u = '(list 0)) then
            for i:=1:x do prin2!* "_";

    posn!* := oo;
    ycoord!* := ycoord!* -1;
    if minussign then prin2!* "-";

    if l1 < l2 then <> else
      while l1 > 0 do <<
        prin2!* car intstring;
        intstring := cdr intstring;
        l1 := l1 -1;
        if l1 < l2 then << l1 := 0; l2 := l2 -1;  prin2!* ".">>;
        >>;
    while l2 > 0 do <<
        if intstring then <>
                else prin2!* '!0;
        l2 := l2 -1 >>;

    if not(caddr u = '(list 0)) then for each q in perio do prin2!* q;
    return t;
end;

put('periodic,'prifn,'print_periodic);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/rataprx/contfrac.red0000644000175000017500000003630011526203062024462 0ustar  giovannigiovannimodule contfrac;  % Continued fractions.

% Author: Lisa Temme

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date:   August 1995.

% Code to check for rational polynomials.

% polynomials and rational functions
% by Winfried Neun

symbolic procedure PolynomQQQ (x);

(if fixp xx then 1 else
 if not onep denr (xx := cadr xx) then NIL
 else begin scalar kerns,kern,aa,var,fform,mvv,degg;

 fform := sfp  mvar  numr xx;
 var := reval cadr x;
 if fform then << xx := numr xx;
    while (xx neq 1) do
     << mvv :=  mvar  xx;
        degg := ldeg  xx;
        xx   := lc  xx;
        if domainp mvv then <> >> else
        kerns := append ( append (kernels mvv,kernels degg),kerns) >> >>
   else kerns := kernels !*q2f xx;

 aa: if null kerns then return 1;
     kern := first kerns;
     kerns := cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end) where xx = aeval(car x);

put('PolynomQQ,'psopfn,'polynomQQQ);

symbolic procedure ttttype_ratpoly(u);
  ( if fixp xx then 1 else
        if not eqcar (xx , '!*sq) then nil
          else and(polynomQQQ(list(mk!*sq (numr cadr xx ./ 1),
                   reval cadr u)),
                  polynomQQQ(list(mk!*sq (denr cadr xx ./ 1),
                   reval cadr u)))
 ) where xx = aeval(car u);

flag ('(type_ratpoly),'boolean);

put('type_ratpoly,'psopfn,'ttttype_ratpoly);

symbolic procedure type_ratpoly(f,z);
    ttttype_ratpoly list(f,z);


%% To combine number, rational and non-rational approaches
%% (including truncated versions) include the following
%% boolean returns and the cfracrules rulelist.

flag ('(vari),'boolean);

symbolic procedure vari(x);
   idp x;

procedure polynomialp(u,x);
  if den u = 1 and (freeof (u,x) or deg(u,x) >= 1 ) then t else nil;

flag ('(polynomialp),'boolean);

algebraic;

operator cfrac;

operator contfrac;

procedure a_constant (x);
  lisp constant_exprp (x);

cfracrules :=
{ cfrac (~x) => (begin scalar cf, pt2, q, res;
                       cf  := continued_fraction x;
                       pt2 := part(cf,2);
                       res := for q := 2:(length pt2)
                              collect append({1},{part(pt2,q)});
                       return contfrac(part(cf,1),
                                   append({part(pt2,1)},res));
                 end)
                when a_constant(x),

  cfrac (~x,~s) => (begin scalar kk, cf, cf1, pt2, cf2, cf3,
                                 bs, m, p, q, res;
                          cf := continued_fraction(x);
                          pt2 := part(cf,2);
                          if s>=length(part(cf,2))
                          then
                          << cf1 :=
                                for q:=2:(length pt2)
                                collect append({1},{part(pt2,q)});
                             res := contfrac(part(cf,1),
                                             append({part(pt2,1)},cf1));
                          >>
                          else
                          << cf2 :=
                              for kk:=1:s+1
                              collect part(pt2,kk);
                             bs  := part(cf2,s+1);
                              for m:= s step -1 until 1
                              do bs := part(cf2,m)+1/bs;
                             cf3 :=
                              for p:=2:(length cf2)
                              collect append({1},{part(cf2,p)});
                             res:=contfrac(bs,append({part(cf2,1)},cf3))
                          >>;
                      %%  res := continued_fraction(x,s);
                          return res;
                    end)
                   when a_constant(x) and numberp s,

  cfrac (~x,~s) => (begin scalar cf, pt2, q, r, res;
                          cf  := cfracall(x,s);
                          pt2 := part(cf,2);
                          if type_ratpoly(x,s)
                          then
                          <>
                          else
                          <>;
                          return contfrac(part(cf,1),
                                      append({part(pt2,1)},res));
                    end)
                   when not numberp x and vari s,

  cfrac(~a,~b,~c) => (begin scalar cf, pt2, q, res;
                            cf  := cfrac_ratpoly(a,b,c);
                            pt2 := part(cf,2);
                            res :=
                               for q:=2:(length pt2)
                               collect append({1},{part(pt2, q)});
                            return contfrac(part(cf,1),
                                        append({part(pt2,1)},res));
                      end)
                     when numberp c and  vari b
                      and type_ratpoly(a,b),

  cfrac(~a,~b,~c) => (begin scalar cf, pt2, q, res;
                          cf  := cfrac_nonratpoly(a,b,c);
                          pt2 := part(cf, 2);
                          res :=
                             for q:=2:length(pt2)
                             collect list(num(part(pt2,q)),
                                          den(part(pt2,q)));
                          return contfrac(part(cf,1),
                                      append({part(pt2,1)},res));
                      end)
                     when numberp c and  vari b
                      and NOT(type_ratpoly(a,b))%,

};

let cfracrules;

% LOAD Taylor Package for non-rationals

load taylor;


%INPUT my code for rational polynomials

procedure cfracall(rat_poly,var);
  begin
    scalar top_poly, bot_poly, euclidslist, ld_return;

    if type_ratpoly(rat_poly,var)
    then
      << top_poly := num rat_poly;
         bot_poly := den rat_poly;
         euclidslist := {};

         while part(longdiv(top_poly, bot_poly, var),2) neq 0 do
         <<
            ld_return := longdiv(top_poly, bot_poly, var);
            top_poly := bot_poly;
            bot_poly := part(ld_return,2);
            euclidslist := part(ld_return,1).euclidslist;
         >>;
         euclidslist := part(longdiv(top_poly, bot_poly, var),1)
                           . euclidslist;
         return list(inv_cfracall(reverse(euclidslist)),
                     reverse(euclidslist));
      >>
    else
      << return cfrac_nonratpoly(rat_poly,var,5)
      >>;
  end;


%************
%INPUT my code for rational polynomials (truncated)

procedure cfrac_ratpoly(rat_poly,var,number);
  begin
    scalar top_poly, bot_poly, euclidslist, ld_return, k;

    if type_ratpoly(rat_poly,var)
    then
      << top_poly := num rat_poly;
         bot_poly := den rat_poly;
         euclidslist := {};

         k:=number; %-1;
         while part(longdiv(top_poly, bot_poly, var),2) neq 0
               and k neq 0
         do
         <<
            ld_return := longdiv(top_poly, bot_poly, var);
            top_poly := bot_poly;
            bot_poly := part(ld_return,2);
            euclidslist := part(ld_return,1).euclidslist;
            k := k-1;
         >>;
         euclidslist := part(longdiv(top_poly, bot_poly, var),1)
                             . euclidslist;
         return list(inv_cfracall(reverse(euclidslist)),
                     reverse(euclidslist));
      >>
    else
      << return cfrac_nonratpoly(rat_poly,var,number)
      >>;
  end;



procedure longdiv(poly1, poly2,x);
  begin
    scalar numer, denom, div, div_list, elmt, flag, rem, answer;
%longdiv called by cfracall so poly2 will never be zero.

    %on rounded;
    numer := poly1;
    denom := poly2;
    div_list := {};
    div := 0;
    flag := 0;
    answer := 0;

    if   longdivdeg(numer,x) < longdivdeg(denom,x)
    then rem := numer
    else
    <<
    while (longdivdeg(numer,x) >= longdivdeg(denom,x)) AND flag neq 1 do
     <<
        if longdivlterm(numer,x) = 0
        then
          << div := numer/denom;
             rem :=0;
             flag :=1;
          >>
        else
          << div := longdivlterm(numer,x)/longdivlterm(denom,x);
             numer := numer - denom*div;
             rem := numer;
          >>;
        div_list := div.div_list;
     >>;
    answer := for each elmt in div_list sum elmt;
    >>;
    return list(answer,rem)
  end;


procedure longdivdeg(i_p,i_p_var);
  begin scalar a;
    a:= if   numberp(den(i_p))
        then deg(i_p*den(i_p),i_p_var);
    return a
  end;


procedure longdivlterm(i_p,i_p_var);
  begin scalar b;
    b := if   numberp(den(i_p))
         then lterm(den(i_p)*i_p,i_p_var)/den(i_p);
    return b
 end;
%****************



%Check for a polynomial
%%  flag ('(type_poly),'boolean);
%%  put('type_poly,'psopfn,'PolynomQQQ);


%INPUT my code for non-rationals

procedure cfrac_nonratpoly(nonrat,x,n);
  begin
    scalar hh,g, a_0, a_1, coeff_list, flag1, flag2,
           k, j, h, oneplus, xover;

    g := taylor(nonrat,x,0,2*n);

    h := 1;
    k:=n;
    if taylorp(taylortostandard g)
    then rederr "not yet implemented"
    else
    <<
%%CHANGE TO: if not type_poly then ERROR
%Include error here so that COEFF can be used in while condition
    if not type_ratpoly(taylortostandard g,x)
       or (type_ratpoly(taylortostandard g,x) and
           not(freeof(den(taylortostandard g),x)))
    then
       rederr "not yet implemented";
    while (length(coeff(taylortostandard g, x)) >1 and k>=0) do %0) do
     <<
%%CHANGE TO: if not type_poly then ERROR
%Include error here so that each time a new "g" is generated
% it will be checked to see if it is a polynomial
       if not type_ratpoly(taylortostandard g,x)
           or (type_ratpoly(taylortostandard g,x) and
               not(freeof(den(taylortostandard g),x)))
       then
           rederr "not yet implemented";
       a_0 :=  first coeff(taylortostandard g, x);
       a_1 := second coeff(taylortostandard g, x);

       if   flag1 =0
       then
         << coeff_list := {a_0};
            flag1 := 1;
         >>
       else
         << if a_1 neq 0
            then
              << g := taylorcombine(a_1*taylor(x^h,x,0,2*n)/(g - a_0));
                 coeff_list := (a_1*x^h).coeff_list;
              >>
            else
              << j := 2;
                 while j <= length coeff(taylortostandard g, x)
                    and flag2=0 do
                 <<
                    if coeffn(taylortostandard g, x, j) neq 0
                    then << a_n := coeffn(taylortostandard g, x, j);
                            flag2 := 1;
                         >>
                    else j := j+1;

                 >>;
                 coeff_list := (a_n*x^j).coeff_list;
                 g := taylorcombine(a_n*taylor(x^j,x,0,2*n)/(g - a_0));
                 flag2 := 0;
                 h := j
              >>;
          >>;
        k := k-1;
     >>;
%% %"1+" form
%%     oneplus := list(inv_cfrac_nonratpoly1(reverse(coeff_list)),
%%                                      reverse(coeff_list));

%"x/" form
    xover:= list(inv_cfrac_nonratpoly2(adaptcfrac(reverse(coeff_list))),
                                   adaptcfrac(reverse(coeff_list)));
    return xover  %% list(oneplus,xover)
    >>;
  end;
%***************




%INPUT my code for different representation of cfrac_nonratpoly


procedure adaptcfrac(l_list);
  begin
    scalar h, l, k, n, m, new_list;

    new_list := {};
    if length l_list < 3 then return l_list
    else
      << h := first l_list;
         l := second l_list;
         k := 2;
         while length l_list >= k do
         <<
            n := num l;
            d := den l;
            new_list := (n/d).new_list;
            k := k+1;
            if length l_list >= k
            then
              << l := part(l_list, k);
                 l := d*l
              >>;
         >>;
      >>;
    return h.reverse(new_list)
  end;



procedure inv_cfrac_nonratpoly1(c_list);
  begin
    scalar ans, j, expan;

    j := length c_list;
    if j < 3
    then
      << ans := for each m in c_list sum m;
         return ans;
      >>
    else
      << for k:=j step -1 until 2
         do <<   if k=j
               then expan := part(c_list,k)
               else expan := part(c_list,k) / (1 + expan);
            >>;
         expan := part(c_list,1) + expan;

         return expan
      >>;
  end;



procedure inv_cfrac_nonratpoly2(c_list);
  begin
    scalar ans, j, expan;

    j := length c_list;
    if j < 3
    then
      << ans := for each m in c_list sum m;
         return ans;
      >>
    else
      << for k:=j step -1 until 2
         do <<   if k=j
               then expan := part(c_list,k)
               else expan :=
                    num(part(c_list,k)) / (den(part(c_list,k)) + expan);
            >>;
         expan := part(c_list,1) + expan;

         return expan
      >>;
  end;

procedure inv_cfracall(c_list);
  begin
    scalar ans, j;

    j := length c_list;
    if j=0 then return {}
    else
    <<   if j=1
       then ans := part(c_list,1)
       else
         << ans := part(c_list,j);
            for k:=j-1 step -1 until 1
             do << ans := part(c_list,k) + 1/ans >>;
         >>;
    >>;
    return ans
  end;

symbolic procedure print!-contfract(x);

% printing continued fractions

  begin scalar xx,xxx;
    if null !*nat or atom x or length x < 3
        or not eqcar(caddr x,'list)
        then return 'failed;
    xx := reverse cddr caddr x;
    if length xx > 12 then  return 'failed;
    if xx then
     <> else maprin list('list,cadr x,cadr caddr x);
    return t;
   end;

put('contfrac,'prifn,'print!-contfract);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/0000755000175000017500000000000011722677364022026 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/dipoly1.red0000644000175000017500000003073711526203062024073 0ustar  giovannigiovannimodule dipoly1;% Distributive polynomial algorithms.

% Authors: R. Gebauer, A. C. Hearn, H. Kredel.
% Modification for REDUCE > 3.3: H. Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modification of the function 'dipprodin' by Arthur Norman (august 2002,
% REDUCE 3.7).

fluid'(dipvars!* dipzero);

symbolic procedure dipconst!? p;
 not dipzero!? p and dipzero!? dipmred p and evzero!? dipevlmon p;

symbolic procedure terprit n;for i:=1:n do terpri();

symbolic procedure dfcprint pl;
% h polynomial factor list of distributive polynomials print.
for each p in pl do dfcprintin p;

symbolic procedure dfcprintin p;
% factor with exponent print.
(if cdr p neq 1 then <> else <>)
      where p1:= dipmonic a2dip prepf car p;

symbolic procedure dfcprin p;
% print content,factors and exponents of factorized polynomial p.
<>;

symbolic procedure dipprint1(u,v);
%     Prints a distributive polynomial in infix form.
%     U is a distributive form. V is a flag which is true if a term
%     has preceded current form
   if dipzero!? u then if null v then dipprin2 0 else nil
    else begin scalar bool,w;
       w := diplbc u;
       if bcminus!? w then <>;
       if bool then dipprin2 " - " else if v then dipprin2 " + ";
       (if not bcone!? w or evzero!? x then <>
         else dipevlpri(x,nil))
           where x = dipevlmon u;
       dipprint1(dipmred u,t) end;

symbolic procedure dipprin2 u;
%   Prints u, preceding by two EOL's if we have reached column 70
   <69 then <>; prin2 u>>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/dipvars.red0000644000175000017500000000351611526203062024155 0ustar  giovannigiovannimodule dipvars;

% Determine distributive polynomial variables in a prefix form

% Authors: R. Gebauer, A. C. Hearn, H. Kredel

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure dipvars u;
%   Returns list of variables in prefix form u
   dipvars1(u,nil);

symbolic procedure dipvars1(u,v);
   if atom u then if constantp u or u memq v then v else u . v
    else if idp car u and get(car u,'dipfn)
     then dipvarslist(cdr u,v)
    else if u memq v then v
    else u . v;

symbolic procedure dipvarslist(u,v);
   if null u then v
    else dipvarslist(cdr u,union(dipvars car u,v));

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/dipoly.red0000644000175000017500000001176611526203062024013 0ustar  giovannigiovannimodule dipoly;% Header module for dipoly package .

% Authors : R . Gebauer,A . C . Hearn,H . Kredel,
%
% Significant modifications : H . Melenk .
%
% Modifications :
%
% 14-Dec-1994(HM):  Term order GRADED added .
%
% 17-Sep-1994(HM):  The ideal variables are now declared in the TORDER
%                    statement .  The calling conventions can be still
%                    used,but are removed from the documents .
%
% 12-Sep-1994(HM):  Make the base coefficient arithmatic call subs2 if
%                    the switch *bcsub2 is on .  This is turned on if
%                    there are roots in the coefficient domain .  Without
%                    subs2 the zero detection would be incomplete in
%                    such cases .
%                    Term order MATRIX added .
%
%  5-Jun-1994(HM):  Introduced zero divisor list for the base
%                    coefficients .  These are polynomial variants of let
%                    rules which Groebner has found for the parameters .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% For the time being,this contains the smacros that used to be in
% consel,and repeats those in bcoeff .

%----------------------------------------------------------------

% For compatibility with REDUCE 3 . 5 :

fluid'(bczerodivl!* compiled!-orders!* dipevlist!* dipsortmode!* dipsortevcomp!*
 dipvars!* dmode!* dipvars!* dipzero global!-dipvars!* intvdpvars!* olddipsortmode!*
 intvdpvars!* olddipsortmode!* pcount!* secondvalue!* vdpsfsortmode!* vdpmatrix!*
 vdpsortextension!* vdpsortmode!* vdplastvar!* vdpvars!* !*balanced_mod !*bcsubs2
 !*gcd !*grmod!* !*groebdivide !*groebsubs !*groebrm !*gsugar !*trgroeb !*trgroebs
 !*vdpinteger
 !*notestparameters);

global'(groebmonfac vdpprintmax);

%----------------------------------------------------------------

% Constructors and selectors for a distributed polynomial form .

% A distributive polynomial has the following informal syntax :
%
%    ::= dipzero
%                |  .  . 

% Vdp2dip modules included .  They could be in a separate package .

create!-package('(dipoly a2dip bcoeff dip2a dipoly1 dipvars
                  expvec torder vdp2dip vdpcom condense dipprint),
                '(contrib dipoly));

put('dipoly,'version,4.1);

% define dipzero='nil;

fluid'(dipzero pi);
% Until we understand how to define something to nil .

smacro procedure dipzero!? u;null u;

smacro procedure diplbc p;
% Distributive polynomial leading base coefficient.
% p is a distributive polynomial . diplbc(p)  returns
% the leading base coefficient of p.
 cadr p;

smacro procedure dipmoncomp(a,e,p);
% Distributive polynomial monomial composition . a is a base
% coefficient,e is an exponent vector and p is a
% distributive polynomial . dipmoncomp( a,e,p)returns a dis-
% tributive polynomial with p as monomial reductum,e as
% exponent vector of the leading monomial and a as leading
% base coefficient.
   e.a.p;

smacro procedure dipevlmon p;
% Distributive polynomial exponent vector leading monomial .
% p is a distributive polynomial . dipevlmon(p)returns the
% exponent vector of the leading monomial of p.
 car p;

smacro procedure dipfmon(a,e);
% Distributive polynomial from monomial . a is a base coefficient
% and e is an exponent vector . dipfmon(a,e)returns a
% distributive polynomial with e as exponent vector and
% a as base coefficient.
 e.a.dipzero;

smacro procedure dipnov p;
% Distributive polynomial number of variables . p is a distributive
% polynomial . dipnov(p)returns a digit,the number of variables
% of the distributive polynomial p.
 length car p;

smacro procedure dipmred p;
% Distributive polynomial reductum . p is a distributive polynomial
% dipmred(p)returns the reductum of the distributive polynomial p,
% a distributive polynomial.
 cddr p;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/vdp2dip1.red0000644000175000017500000005342411526203062024141 0ustar  giovannigiovannimodule vdp2dip1;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface for DIPOLY polynomials as records (objects).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

fluid'(intvdpvars!* vdpvars!* secondvalue!* vdpsfsortmode!* !*groebrm
        !*vdpinteger !*trgroeb !*trgroebs !*groebdivide pcount!*
        !*groebsubs);

fluid'(vdpsortmode!*);

global'(vdpprintmax groebmonfac);
flag('(vdpprintmax),'share);

fluid'(dipvars!* !*vdpinteger);

symbolic procedure dip2vdp u;
 % is unsed when u can be empty
   (if dipzero!? uu then makeVdp(a2bc 0,nil,nil)
                    else makeVdp(diplbc uu,dipevlmon uu,uu))
           where uu = if !*groebsubs then dipsubs2 u else u;


% some simple mappings

smacro procedure makedipzero(); nil;

symbolic procedure vdpredzero!? u; dipzero!? dipmred vdppoly u;

symbolic procedure vbczero!? u; bczero!? u;

symbolic procedure vbcnumber u;
       if  pairp u and numberp car u and 1=cdr u then cdr u else nil;

symbolic procedure vbcfi u; bcfi u;

symbolic procedure a2vbc u; a2bc u;

symbolic procedure vbcquot(u,v); bcquot(u,v);

symbolic procedure vbcneg u; bcneg u;

symbolic procedure vbcabs u; if vbcminus!? u then bcneg u else u;

symbolic procedure vbcone!? u; bcone!? u;

symbolic procedure vbcprod (u,v); bcprod(u,v);

 % initializing vdp-dip polynomial package
symbolic procedure vdpinit2(vars);
  begin scalar oldorder;
    oldorder:=kord!*;
    if null vars then rerror(dipoly,8,"Vdpinit: vdpvars not set");
    vdpvars!*:=dipvars!*:=vars;
    torder2 vdpsortmode!*;
    return oldorder end;

symbolic procedure vdpred u;
    (if dipzero!? r then makevdp(nil ./ nil,nil,makedipzero())
                   else makevdp(diplbc r,dipevlmon r,r))
       where  r = dipmred vdppoly u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  coefficient handling; here we assume that coefficients are
%  standard quotients;
%

symbolic procedure vbcgcd (u,v);
     if denr u = 1 and denr v = 1 then
       if fixp u and fixp numr v then gcdn(numr u,numr v)  ./ 1
            else gcdf!*(numr u,numr v) ./ 1
     else 1 ./ 1;

% the following functions must be redefinable
symbolic procedure vbcplus!? u; (numberp v and v>0) where v = numr u;
symbolic procedure bcplus!? u; (numberp v and v>0) where v = numr u;

symbolic procedure vbcminus!? u;
       (numberp v and v<0) where v = numr u;

symbolic procedure vbcinv u; bcinv u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  conversion between forms, vdps and prefix expressions
%

% prefix to vdp
symbolic procedure a2vdp u;
     if u=0 or null u then makevdp(nil ./ nil,nil,makedipzero())
     else (makevdp(diplbc r,dipevlmon r,r)  where  r = a2dip u);

% vdp to prefix
symbolic procedure vdp2a u; dip2a vdppoly u;

symbolic procedure vbc2a u; bc2a  u;

% form to vdp
symbolic procedure f2vdp(u);
     if u=0 or null u then makevdp(nil ./ nil,nil,makedipzero())
     else (makevdp(diplbc r,dipevlmon r,r)  where  r = f2dip u);

% vdp to form
symbolic procedure vdp2f u; dip2f vdppoly u;

% vdp from monomial
symbolic procedure vdpfmon (coef,vev);
                 makevdp(coef,vev,dipfmon(coef,vev));

% add a monomial to a vdp in front (new vev and coeff)
symbolic procedure vdpmoncomp(coef,vev,vdp);
   if vdpzero!? vdp then vdpfmon(coef,vev) else
   if vbczero!? coef then vdp else
   makevdp(coef,vev,dipmoncomp(coef,vev,vdppoly vdp));

%add a monomial to the end of a vdp (vev remains unchanged)
symbolic procedure vdpappendmon(vdp,coef,vev);
   if vdpzero!? vdp then vdpfmon(coef,vev) else
   if vbczero!? coef then vdp else
   makevdp(vdpLbc vdp,vdpevlmon vdp,
            dipsum(vdppoly vdp,dipfmon(coef,vev)));

% add monomial to vdp, place of new monomial still unknown
symbolic procedure vdpmonadd(coef,vev,vdp);
    if vdpzero!? vdp then vdpfmon(coef,vev) else
   (if c = 1 then vdpmoncomp(coef,vev,vdp) else
    if c = -1 then makevdp (vdplbc vdp,vdpevlmon vdp,
                               dipsum(vdppoly vdp,dipfmon(coef,vev)))
    else vdpsum(vdp,vdpfmon(coef,vev))
   ) where c = vevcomp(vev,vdpevlmon vdp);

symbolic procedure vdpzero(); a2vdp 0;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  comparing of exponent vectors
%
%

symbolic procedure vdpvevlcomp (p1,p2);
                  dipevlcomp (vdppoly p1,vdppoly p2);
symbolic procedure vevilcompless!?(e1,e2); 1 = evilcomp(e2,e1);
symbolic procedure vevilcomp (e1,e2); evilcomp (e1,e2);
symbolic procedure vevcompless!?(e1,e2); 1 = evcomp(e2,e1);
symbolic procedure vevcomp (e1,e2); evcomp (e1,e2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  routines traversing the "coefficients"
%

% CONTENT of a vdp
% The content is the gcd of all coefficients.

symbolic procedure vdpcontent d;
     if vdpzero!? d then a2bc 0 else
     <>;

symbolic procedure vdpcontent1(d,c); dipnumcontent(vdppoly d,c);

symbolic procedure dipnumcontent(d,c);
     if bcone!? c or dipzero!? d then c
     else dipnumcontent(dipmred d,vbcgcd(c,diplbc d));

symbolic procedure dipcontenti p;
% the content is a pair of the lcm of the coefficients and the
% exponent list of the common monomial factor.
   if dipzero!? p then 1 else
   (if dipzero!? rp then diplbc p .  (if !*groebrm then dipevlmon p else nil)
      else dipcontenti1(diplbc p, if !*groebrm then dipevlmon p else nil,rp) )
                           where rp=dipmred p;

symbolic procedure dipcontenti1 (n,ev,p1);
   if dipzero!? p1 then n . ev
   else begin scalar nn;
             nn:=vbcgcd (n,diplbc p1);
             if ev then ev:=dipcontevmin(dipevlmon p1,ev);
             if bcone!? nn and null ev then return nn . nil
                       else return dipcontenti1 (nn,ev,dipmred p1) end;

% CONTENT and MONFAC (if groebrm on)
symbolic procedure vdpcontenti d;
       vdpcontent d . if !*groebrm then vdpmonfac d else nil;

symbolic procedure vdpmonfac d; dipmonfac vdppoly d;

symbolic procedure dipmonfac p;
% exponent list of the common monomial factor.
   if dipzero!? p or not !*groebrm then evzero()
   else (if dipzero!? rp then dipevlmon p
         else dipmonfac1(dipevlmon p,rp) ) where rp=dipmred p;

symbolic procedure dipmonfac1(ev,p1);
   if dipzero!? p1 or evzero!? ev then ev
   else dipmonfac1(dipcontevmin(ev,dipevlmon p1),dipmred p1);

% vdpCoeffcientsfromdomain!?
symbolic procedure vdpcoeffcientsfromdomain!? w;
          dipcoeffcientsfromdomain!? vdppoly w;

symbolic procedure dipcoeffcientsfromdomain!? w;
      if dipzero!? w then t else
      (if denr v = 1 and domainp numr v then
              dipcoeffcientsfromdomain!? dipmred w
            else nil) where v =diplbc w;

symbolic procedure vdplength f; diplength vdppoly f;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  polynomial operations:
%             coefficient normalization and reduction of monomial
%             factors
%

symbolic procedure vdpequal(p1,p2);
     p1 eq p2
     or (n1 and n1 = n2   % number comparison is faster most times
     or dipequal(vdppoly p1,vdppoly p2)
           where n1 = vdpgetprop(p1,'number),
                 n2 = vdpgetprop(p2,'number));

symbolic procedure dipequal(p1,p2);
    if dipzero!? p1 then dipzero!? p2
    else if dipzero!? p2 then nil
    else diplbc p1 = diplbc p2
     and evequal(dipevlmon p1,dipevlmon p2)
     and dipequal(dipmred p1,dipmred p2);

symbolic procedure evequal(e1,e2);
   % test equality with variable length exponent vectors
     if null e1 and null e2 then t
     else if null e1 then evequal('(0),e2)
     else if null e2 then evequal(e1,'(0))
     else 0=(car e1 #- car e2) and evequal(cdr e1,cdr e2);

symbolic procedure vdplcm p; diplcm vdppoly p;

symbolic procedure vdprectoint(p,q); dip2vdp diprectoint(vdppoly p,q);

symbolic procedure vdpsimpcont(p);
          begin scalar r;
              r:=vdppoly p;
              if dipzero!? r then return p;
              r:=dipsimpcont r;
              p:=dip2vdp cdr r;  % the polynomial
              r:=car r;          % the monomial factor if any
              if not evzero!? r then vdpputprop(p,'monfac,r);
              return p end;

symbolic procedure dipsimpcont  (p);
    if !*vdpinteger or not !*groebdivide  then dipsimpconti p
                          else dipsimpcontr p;

% routines for integer coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure dipsimpconti (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar co,lco,res,num;
    if dipzero!?  p then return nil . p;
    co:=bcfi 1;
    co:=if !*groebdivide then dipcontenti p
             else if !*groebrm then co . dipmonfac p
             else co . nil;
    num:=car co;
    if not bcplus!? num then num:=bcneg num;
    if not bcplus!? diplbc p then num:=bcneg num;
    if bcone!? num  and cdr co = nil  then return nil . p;
    lco:=cdr co;
    if groebmonfac neq 0  then lco:=dipcontLowerEv cdr co;
    res:=p;
    if not(bcone!? num and lco = nil) then
                 res:=dipreduceconti (p,num,lco);
    if null cdr co then return nil . res;
    lco:=evdif(cdr co,lco);
    return(if lco and not evzero!? evdif(dipevlmon res,lco)
                           then lco else nil).res end;

symbolic procedure vdpreduceconti (p,co,vev);
%  divide polynomial p by monomial from co and vev
        vdpdivmon(p,co,vev);

%  divide all coefficients of p by cont
symbolic procedure dipreduceconti (p,co,ev);
    if dipzero!? p then makedipzero() else
           dipmoncomp ( bcquot (diplbc p,co),
                        if ev then evdif(dipevlmon p,ev) else dipevlmon p,
                        dipreduceconti (dipmred p,co,ev));

% routines for rational coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure dipsimpcontr (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar co,lco,res;
    if dipzero!?  p then return nil . p;
    co:=dipcontentr p;
    if bcone!? diplbc p  and co = nil  then return nil . p;
    lco:=dipcontLowerEv co;
    res:=p;
    if not(bcone!? diplbc p and lco = nil) then
               res:=dipreducecontr (p,bcinv diplbc p,lco);
    return (if co then evdif(co,lco) else nil) . res end;

symbolic procedure dipcontentr p;
% the content is the exponent list of the common monomial factor.
   (if dipzero!? rp then (if !*groebrm then dipevlmon p else nil) else
    dipcontentr1(if !*groebrm then dipevlmon p else nil,rp) )
                          where rp=dipmred p;

symbolic procedure dipcontentr1 (ev,p1);
   if dipzero!? p1 then ev
      else begin
             if ev then ev:=dipcontEvMin(dipevlmon p1,ev);
             if null ev then return nil
                       else return dipcontentr1 (ev,dipmred p1) end;

%  divide all coefficients of p by cont
symbolic procedure dipreducecontr (p,co,ev);
    if dipzero!? p then makedipzero() else
           dipmoncomp ( bcprod (diplbc p,co),
                        if ev then evdif(dipevlmon p,ev) else dipevlmon p,
                        dipreducecontr (dipmred p,co,ev));

symbolic procedure dipcontevmin (e1,e2);
% calculates the minimum of two exponents; if one is shorter, trailing
% zeroes are assumed.
% e1 is an exponent vector. e2 is a list of exponents
    begin scalar res;
       while e1 and e2 do
          <>;
       while res and 0=car res do res:=cdr res;
       return reversip res end;

symbolic procedure dipcontlowerev (e1);
% subtract a 1 from those elements of an exponent vector which
% are greater  than 1.
% e1 is a list of exponents, the result is an exponent vector.
    begin scalar res;
       while e1 do
          <>;
       while res and 0 = car res do res:=cdr res;
            if res and !*trgroebs then
                   <>;
       return reversip res end;

% routine for the non-integer case (we can divide coefficients):

remflag('(dipmonic),'lose);

symbolic procedure  dipmonic p;
%  divide the polynomial by the leading coefficient, so that the
%  new leading coefficient will be == 1
   if dipzero!? p then p else dipbcprod(p,bcinv diplbc p);

flag('(dipmonic),'lose);

symbolic procedure dipappendmon(dip,bc,ev); append(dip,dipfmon(bc,ev));

smacro procedure dipnconcmon(dip,bc,ev); nconc(dip,dipfmon(bc,ev));

smacro procedure dipnconcdip(dip1,dip2); nconc(dip1,dip2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  basic polynomial arithmetic:
%

symbolic procedure vdpsum(d1,d2); dip2vdp dipsum(vdppoly d1,vdppoly d2);

symbolic procedure vdpdif(d1,d2); dip2vdp dipdif(vdppoly d1,vdppoly d2);

symbolic procedure vdpprod(d1,d2); dip2vdp dipprod(vdppoly d1,vdppoly d2);

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  linear combination: the Buchberger Workhorse
%
% LCOMB1: calculate mon1 * vdp1 + mon2 * vdp2
symbolic procedure vdpilcomb1(d1,vbc1,vev1,d2,vbc2,vev2);
 dip2vdp dipILcomb1 (vdppoly d1,vbc1,vev1,vdppoly d2,vbc2,vev2);

symbolic procedure dipilcomb1 (p1,bc1,ev1,p2,bc2,ev2);
% same asl dipILcomb, exponent vectors multiplied in already
   begin scalar ep1,ep2,sl,res,sum,z1,z2,p1new,p2new,lptr,bptr;
       z1:=not evzero!? ev1; z2:=not evzero!? ev2;
       p1new:=p2new:=t;
       lptr:=bptr:=res:=makedipzero();
 loop:
       if p1new then
       << if dipzero!? p1 then
              return if dipzero!? p2 then res else
                     dipnconcdip(res, dipprod(p2,dipfmon(bc2,ev2)));
          ep1:=dipevlmon p1;
          if z1 then ep1:=evsum(ep1,ev1);
          p1new:=nil>>;
       if p2new then
       << if dipzero!? p2 then
              return dipnconcdip(res, dipprod(p1,dipfmon(bc1,ev1)));
          ep2:=dipevlmon p2;
          if z2 then ep2:=evsum(ep2,ev2);
          p2new:=nil>>;
        sl:=evcomp(ep1, ep2);
        if sl = 1 then
                      << lptr:=dipnconcmon (bptr,
                                              bcprod(diplbc p1,bc1),
                                              ep1);
                         bptr:=dipmred lptr;
                         p1:=dipmred p1; p1new:=t >>
        else if sl = -1 then
                      << lptr:=dipnconcmon (bptr,
                                              bcprod(diplbc p2,bc2),
                                              ep2);
                         bptr:=dipmred lptr;
                         p2:=dipmred p2; p2new:=t >>
        else
                      << sum:=bcsum (bcprod(diplbc p1,bc1),
                                       bcprod(diplbc p2,bc2));
                         if not bczero!? sum then
                             <<   lptr:=dipnconcmon(bptr,sum,ep1);
                                  bptr:=dipmred lptr>>;
                         p1:=dipmred p1; p2:=dipmred p2;
                         p1new:=p2new:=t >>;
        if dipzero!? res then <>; % initial
        goto loop end;

symbolic procedure vdpvbcprod(p,a); dip2vdp dipbcprod(vdppoly p,a);

symbolic procedure vdpdivmon(p,c,vev);
   dip2vdp dipdivmon(vdppoly p,c,vev);

symbolic procedure dipdivmon(p,bc,ev);
    % divides a polynomial by a monomial
    % we are sure that the monomial ev is a factor of p
    if dipzero!? p
         then makedipzero()
         else
           dipmoncomp ( bcquot(diplbc p,bc),
                        evdif(dipevlmon p,ev),
                        dipdivmon (dipmred p,bc,ev));

symbolic procedure vdpcancelmvev(f,vev);
     dip2vdp dipcancelmev(vdppoly f,vev);

symbolic procedure dipcancelmev(f,ev);
    % cancels all monomials in f which are multiples of ev
      dipcancelmev1(f,ev,makedipzero());

symbolic procedure dipcancelmev1(f,ev,res);
    if dipzero!? f then res
    else if evmtest!?(dipevlmon f,ev) then
                       dipcancelmev1(dipmred f,ev,res)
     else dipcancelmev1(dipmred f,ev,
                         dipnconcmon(res,diplbc f,dipevlmon f));

% some prehistoric routines needed in resultant operation
symbolic procedure vevsum0(n,p);
% exponent vector sum version 0. n is the length of vdpvars!*.
% p is a distributive polynomial.
  if vdpzero!? p then vevzero1 n else vevsum(vdpevlmon p, vevsum0(n,vdpred p));

symbolic procedure vevzero1 n;
% Returns the exponent vector power representation
% of length n for a zero power.
  begin scalar x;
   for i:=1: n do << x:=0 . x >>;
  return x end;

symbolic procedure vdpresimp u;
   % fi domain changes, the coefficients have to be resimped
   dip2vdp dipresimp vdppoly u;

symbolic procedure dipresimp u;
   if null u then nil else
   (for each x in u collect
      <>
      ) where toggle = t;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% printing of polynomials
%

symbolic procedure vdpprint u; <>;

symbolic procedure vdpprin2 u;
   <<(if x then <>)
                 where x=vdpGetProp(u,'number);
      vdpprint1(u,nil,vdpprintmax)>>;

symbolic procedure vdpprint1(u,v,max); vdpprint1x(vdppoly u,v,max);

symbolic procedure vdpprint1x(u,v,max);
%   /* Prints a distributive polynomial in infix form.
%     U is a distributive form. V is a flag which is true if a term
%     has preceded current form
%     max limits the number of terms to be printed
   if dipzero!? u then if null v then dipprin2 0 else nil
    else if max = 0 then   % maximum of terms reached
              << terpri();
                 prin2 " ### etc (";
                 prin2 diplength u;
                 prin2 " terms) ###";
                 terpri()>>
    else begin scalar bool,w;
       w:=diplbc u;
       if bcminus!? w then <>;
       if bool then dipprin2 " - " else if v then dipprin2 " + ";
       (if not bcone!? w or evzero!? x then<>
         else dipevlpri(x,nil))
           where x = dipevlmon u;
       vdpprint1x(dipmred u,t, max - 1) end;

symbolic procedure dipprin2 u;
   <69 then terprit 2 ; prin2 u>>;

symbolic procedure vdpsave u; u;

%   switching between term order modes

symbolic procedure torder2 u; dipsortingmode u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% additional conversion utilities

% conversion dip to standard form / standard quotient

symbolic procedure dip2f u;
      (if denr v neq 1 then
        <>
       else numr v) where v = dip2sq u;

symbolic procedure dip2sq u;
   % convert a dip into a standard quotient.
     if dipzero!? u then nil ./ 1
     else addsq(diplmon2sq(diplbc u,dipevlmon u),dip2sq dipmred u);

symbolic procedure diplmon2sq(bc,ev);
   %convert a monomial into a standard quotient.
     multsq(bc,dipev2f(ev,dipvars!*) ./ 1);

symbolic procedure dipev2f(ev,vars);
     if null ev then 1
     else if car ev = 0 then dipev2f(cdr ev,cdr vars)
     else multf(car vars .** car ev .* 1 .+ nil,
                dipev2f(cdr ev,cdr vars));

% evaluate SUBS2 for the coefficients of a dip

symbolic procedure dipsubs2 u;
   begin scalar v,secondvalue!*;
      secondvalue!*:=1 ./ 1;
      v:=dipsubs21 u;
      return diprectoint(v,secondvalue!*) end;

symbolic procedure dipsubs21 u;
   begin scalar c;
      if dipzero!? u then return u;
      c:=groebsubs2 diplbc u;
      if null numr c then return dipsubs21 dipmred u;
      if not(denr c = 1) then
          secondvalue!*:=bclcmd(c,secondvalue!*);
      return dipmoncomp(c,dipevlmon u,dipsubs21 dipmred u) end;

% conversion standard form to dip

symbolic procedure f2dip u; f2dip1(u,evzero(),1 ./ 1);

symbolic procedure f2dip1 (u,ev,bc);
  % f to dip conversion: scan the standard form. ev
  % and bc are the exponent and coefficient parts collected
  % so far from higher parts.
   if null u then nil
   else if domainp u then dipfmon(multsq(bc,u ./ 1),ev)
   else dipsum(f2dip2(mvar u,ldeg u,lc u,ev,bc),
               f2dip1(red u,ev,bc));

symbolic procedure f2dip2(var,dg,c,ev,bc);
  % f to dip conversion:
  % multiply leading power either into exponent vector
  % or into the base coefficient.
   <>
           where ev1=if memq(var,dipvars!*) then
                evinsert(ev,var,dg,dipvars!*) else nil;

symbolic procedure evinsert(ev,v,dg,vars);
   % f to dip conversion:
   % Insert the "dg" into the ev in the place of variable v.
     if null ev or null vars then nil
     else if car vars eq v then dg . cdr ev
     else car ev . evinsert(cdr ev,v,dg,cdr vars);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/bcoeff.red0000644000175000017500000002000111526203062023715 0ustar  giovannigiovannimodule bcoeff;% Computation of base coefficients.

% Definitions of base coefficient operations for distributive
% polynomial package.  Fields and rings are supported as coefficient
% domains. Side relations (computing modulo an ideal) are supported
% if the list bczerodivl is non-zero.
%
% In this module, a standard quotient coefficient is assumed, unless
% !*grmod!* is true, in which case it is a small modular number.

% Authors: R. Gebauer, A. C. Hearn, H. Kredel

% H. Melenk: added routines for faster computation with
% quotients representing integers.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure bcint2op(a1,a2,op);
 if null dmode!* and
    1=denr a1 and numberp (a1:=numr a1) and
    1=denr a2 and numberp (a2:=numr a2) and
    (a1:=if op = 'times then a1*a2 else
           if op = 'plus  then a1+a2 else apply2(op,a1,a2)) then
    ((if a1=0 then nil else a1) ./ 1);

fluid'(!*nat);

% The following two could be smacros.  However, they would then need to
% be included in dipoly, thus destroying the modularity of the base
% coefficient code.

symbolic procedure bcminus!? u;
%    Boolean function. Returns true if u is a negative base coeff
    null !*grmod!* and minusf numr u;

symbolic procedure bczero!? u;
%    Returns a boolean expression, true if the base coefficient u is
%    zero
    if !*grmod!* then eqn(u,0) else null numr u;

symbolic procedure bcfd a;
%    Base coefficient from domain. a is a domain element. bcfd(a)
%    returns the base coefficient a.
     if null !*grmod!* then mkbc(a,1)
      else if fixp a then bcfi a
      else if not(car a eq '!:mod!:)
       then rederr list("Invalid modular coefficient",a)
      else bcfi cdr a;

symbolic procedure bcfi a;
%    Base coefficient from integer. a is an integer. bcfi(a)
%    returns the base coefficient a.
   (if u<0 then if !*balanced_mod and u+u > - current!-modulus then u
            else u #+ current!-modulus
     else if !*balanced_mod and u+u > current!-modulus
      then u #- current!-modulus
     else u) where u=remainder(a,current!-modulus);

symbolic procedure bcdomain!? u;
%  True if base coefficient u is a domain element.
   !*grmod!* or (denr u =1 and domainp numr u);

symbolic procedure bclcmd(u,v);
% Base coefficient least common multiple of denominators.
% u and v are two base coefficients. bclcmd(u,v) calculates the
% least common multiple of the denominator of u and the
% denominator of v and returns a base coefficient of the form
% 1/lcm(denom u,denom v).
  if bczero!? u then mkbc(1,denr v)
   else if bczero!? v then mkbc(1,denr u)
   else mkbc(1,multf(quotfx(denr u,gcdf(denr u,denr v)),denr v));

symbolic procedure bclcmdprod(u,v);
% Base coefficient least common multiple denominator product.
% u is a basecoefficient of the form 1/integer. v is a base
% coefficient. bclcmdprod(u,v) calculates (denom u/denom v)*nom v/1
% and returns a base coefficient.
  mkbc(multf(quotfx(denr u,denr v),numr v),1);

symbolic procedure bcone!? u;
%    Base coefficient one. u is a base coefficient.
%    bcone!?(u) returns a boolean expression, true if the
%    base coefficient u is equal 1.
   if !*grmod!* then eqn(u,1) else denr u = 1 and numr u = 1;

symbolic procedure bcinv u;
%    Base coefficient inverse. u is a base coefficient.
%    bcinv(u) calculates 1/u and returns a base coefficient.
   if !*grmod!*
     then if !*balanced_mod
            then (if v+v>current!-modulus then v #- current!-modulus
                   else v) where v= modular!-reciprocal u
           else reciprocal!-by!-gcd(current!-modulus,u,0,1)
    else invsq u;

symbolic procedure bcneg u;
%    Base coefficient negative. u is a base coefficient.
%    bcneg(u) returns the negative of the base coefficient
%    u, a base coefficient.
   if !*grmod!* then if eqn(u,0) then u else current!-modulus #- u
    else negsq u;

symbolic procedure bcprod (u,v);
%    Base coefficient product. u and v are base coefficients.
%    bcprod(u,v) calculates u*v and returns a base coefficient.
   if !*grmod!* then bcfi(u*v)
    else bcint2op(u,v,'times) or bccheckz multsq(u,v);

symbolic procedure mkbc (u,v);
<>;

if null getd 'quotientx then copyd('quotientx,'quotient);

symbolic procedure bcquot(u,v);
%    Base coefficient quotient. u and v are base coefficients.
%    bcquot(u,v) calculates u/v and returns a base coefficient.
  if !*grmod!*
    then bcfi(u*modular!-reciprocal v)
   else if !*vdpinteger then
     (bcint2op(u,v,'quotientx) or !*f2q quotfx(numr u,numr v))
   else quotsq(u,v);

symbolic procedure bcsum(u,v);
%    Base coefficient sum. u and v are base coefficients.
%    bcsum(u,v) calculates u+v and returns a base coefficient.
   if !*grmod!* then bcfi(u+v)
    else bcint2op(u,v,'plus2) or bccheckz addsq(u,v);

symbolic procedure bccheckz u;
% Reduce a sum/difference result by members of bczerodivl!*.
   if null numr u then u else if !*bcsubs2 then subs2 u else
 <>;n./d>>
     where l=bczerodivl!*,n=numr u,d=denr u;

symbolic procedure bcdif(u,v);
%    Base coefficient difference. u and v are base coefficients.
%    bcdif(u,v) calculates u-v and returns a base coefficient.
   if !*grmod!* then bcfi(u - v)
    else bcint2op(u,v,'difference) or bcsum(u,bcneg v);

symbolic procedure bcpow(u,n);
%    Returns the base coefficient u raised to the nth power, where
%    n is an integer
   if !*grmod!* then modular!-expt(u,n) else exptsq(u,n);

symbolic procedure a2bc u;
%   Converts the algebraic (kernel) u into a base coefficient.
   if !*grmod!*
     then if not domainp u then rederr list ( " Invalid coefficient " , u )
           else bcfd u
    else simp!* u;

symbolic procedure bc2a u;
%    Returns the prefix equivalent of the base coefficient u
   if !*grmod!* then u else prepsq u;

fluid'(!*groebigpos !*groebigneg !*groescale);
!*groescale:=20;!*groebigpos:= 10** !*groescale;!*groebigneg:=- 10** !*groescale;

symbolic procedure bcprin u;
%    Prints a base coefficient in infix form
   if !*grmod!* then prin2 u else
   begin scalar nat;
      nat:=!*nat;
      !*nat:=nil;
      if cdr u = 1 and numberp car u and
           (car u>!*groebigpos or car u> else sqprint u;
      !*nat:=nat end;

symbolic procedure bcprin2big u;
    <>;bcprin2big1(u,0)>>;

symbolic procedure bcprin2big1 (u,n);
    if u>!*groebigpos then
             bcprin2big1 (u/!*groebigpos,n#+!*groescale)
      else <>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/vdp3dip.red0000644000175000017500000010042711526203062024055 0ustar  giovannigiovannimodule vdp2dip;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface for Virtual Distributive Polynomials (VDP)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% "Distributive representation" with respect to  a given set of
% variables  ("vdpvars") means for a polynomial, that the polynomial
% is regarded as  a sequence of monomials, each of which is a
% product of a "coefficient"  and of some powers of the variables.
% This internal representation is  very closely connected to the
% standard external (printed) representation of a  polynomial in
% REDUCE if nothing is factored out. The monomials are logically
% ordered by a term order mode based on the  ordering which is
% given bye the sequence "vdpvars"; with respect to this  ordering
% the representation of a polynomial is unique. The "highest" term
%  is the car one. Monomials are represented by their coefficient
% ("vbc") and by  a vector of the exponents("vev") (in the order
% corresponding to the  vector vars). The distributive representation
% is good for those algorithms, which  base their decisions on the
% complete ledading monomial:  this representation guarantees a
% fast and uniform access to the car monomial and to the reductum
% (the cdr of the polynomial beginning with the cadr monomial).
% The algorithms of the Groebner package are of this type.  The
% interface defines the distributive polynomials as abstract data
% objects via their acess functions. These functions map the
% distributive operations to an arbitrary real data structure
% ("virtual"). The mapping of the access functions to an actual
% data structure is cdrricted only by the demand, that the typical
% "distributive operations" be efficient.  Additionally to the
% algebraic value a VDP object has a property list. So the algorithms
% using the  VDP interface can assign name-value-pairs to individual
% polynomials. The interface is defined by a set of routines which
% create and handle the distributive polynomials. In general the
% first letters of the routine name classifies the data its works on:

%   vdp...      complete virt. polynomial objects
%   vbc...      virt. base coefficients
%   vev...      virt. exponent vectors

% 0. general control
%
%   vdpinit(dv) initialises the vdp package for the variables
%              given in the list "dv". vdpinit modifies the
%              torder and returns the prvevious torder as its
%              result. vdpinit sets the global variable
%              vdpvars!*;

% 1. conversion
%
%   a2vdp      algebraic (prefix) to vdp
%   f2vdp      standard form to vdp
%   a2vbc      algebraic (prefix) to vbc
%   vdp2a      vdp to algebraic (prefix)
%   vdp2f      vdp to standard form
%   vbc2a      vbc to algebraic (prefix)

% 2. composing/decomposing
%
%   vdpfmon    make a vdp from a vbc and an vev
%   vdpMonComp add a monomial (vbc and vev) to the front of a vdp
%   vdpAppendMon add a monomial (vbc and vev) to the bottom of a vdp
%   vdpAppendVdp concat two vdps
%
%   vdpLbc     extract leading vbc
%   vdpevlmon  extract leading vev
%   vdpred     reductum of vdp
%   vdplastmon last monomial of polynomial
%   vevnth      nth element from exponent vector

% 3. testing
%
%   vdpZero?    test vdp = 0
%   vdpredZero!? test rductum of vdp = 0
%   vdpOne?     test vdp = 1
%   vevZero?    test vev = (0 0 ... 0)
%   vbczero?    test vbc = 0
%   vbcminus?   test vbc <= 0 (not decidable for algebraic vbcs)
%   vbcplus?    test vbc >= 0 (not decidable for algebraic vbcs)
%   vbcone!?    test vbc = 1
%   vbcnumberp  test vbc is a numeric value
%   vevdivides? test if vev1 < vev2 elementwise
%   vevlcompless?  test ordering vev1 < vev2
%   vdpvevlcomp    calculate ordering vev1 / vev1: -1, 0 or +1
%   vdpEqual   test vdp1 = vdp2
%   vdpMember  member based on "vdpEqual"
%   vevequal    test vev1 = vev2

% 4. arithmetic
%
% 4.1 vdp arithmetic
%
%  vdpsum       vdp + vdp
%               special routines for monomials: see above (2.)
%  vdpdif       vdp - vdp
%  vdpprod      vdp * vdp
%  vdpvbcprod   vbc * vdp
%  vdpDivMon    vdp / (vbc,vev)  divisability presumed
%  vdpCancelvev substitute all multiples of monomial (1,vev) in vdp by 0
%  vdpLcomb1    vdp1*(vbc1,vev1) + vdp2*(vbc2,vev2)
%  vdpContent   calculate gcd over all vbcs

% 4.2 vbc arithmetic
%
%  vbcsum       vbc1 + vbc2
%  vbcdif       vbc1 - vbc2
%  vbcneg       - vbc
%  vbcprod      vbc1 * vbc2
%  vbcquot      vbc1 / vbc2     divisability assumed if domain = ring
%  vbcinv       1 / vbc        only usable in field
%  vbcgcd       gcd(vbc1,vbc2)  only usable in Euclidean field

% 4.2 vev arithmetic
%
% vevsum        vev1 + vev2 elementwise
% vevdif        vev1 - vev2 elementwise
% vevtdeg       sum over all exponents
% vevzero       generate a zero vev

% 5. auxiliary
%
% vdpputprop   assign indicator-value-pair to vdp
%              the property "number" is used for printing.
% vdpgetprop   read value of indicator from vdp
% vdplsort     sort list of polynomials with respect to ordering
% vdplsortIn   sort a vdp into a sorted list of vdps
% vdpprint     print a vdp together with its number
% vdpcondense  replace exponent vectors by equal objects from
%              global list dipevlist!* in order to save memory

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% RECORD STRUCTURE
%
% a virtual polynomial here is a record (list) with the entries
%    ('vdp   
     )
%
%     'vdp        a type tag
%      the exponents of the variables in the leading
%                 leading monomial; the positions correspond to
%                 the positions in vdpvars!*. Trailing zeroes
%                 can be omitted.
%
%         the "coefficient" of the leading monomial, which
%                 in general is a standard form.
%
%           the complete polynomial, e.g. as REDUCE standard form.
%
%          an asso list for the properties of the polynomial
%
% The components should not be manipulated only via the interface
% functions and macros, so that application programs remain
% independent from the internal representation.
% The only general assumption made on  is, that the zero
% polynomial is represented as NIL. That is the case e.g. for both,
% REDUCE standard forms and DIPOLYs.

% Conventions for the usage:
% -------------------------
%
%    vdpint has to be called prveviously to all vdp calls. The list of
%    vdp paraemters is passed to vdpinit. The value of vdpvars!*
%    and the current torder must remain unmodfied afterwards.
%    usual are simple id's, e.g.
%
%
% Modifications to vdpvars!* during calculations
% ----------------------------------------------
%
% This mapping of vdp operations to standard forms offers the
% ability to enlarge vdpvars during the calculation in order
% to add new (intermediate) variables. Basis is the convention,
% that exponent vectors logically have an arbitrary number
% of trailing zeros. All routines processing exponent vectors
% are able to handle varying length of exponent vectors.
% A new call to vdpinit is necessary.
%
% During calculation vdpvars may be enlarged (new variables
% suffixed) without needs to modify existing polynomials; only
% korder has to be set to the new variable sequence.
% modifications to the sequence in vdpvars requires a
% new call to vdpinit  and a reordering of exisiting
% polynomials, e.g. by
%          vdpint newvdpvars;
%          f2vdp vdp2f p1; f2vdp vdp2f p2; .....

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DECLARATION SECTION
%
%  this module must be present during code generation for modules
%  using the vdp - sf interface

fluid '(vdpvars!* intvdpvars!* secondvalue!* vdpsortmode!* !*groebrm
        !*vdpinteger !*trgroeb !*trgroebs !*groebdivide pcount!*
        !*gsugar dipevlist!* !*gcd);

global '(vdpprintmax groebmonfac);

flag('(vdpprintmax),'share);

% basic internal constructor of vdp-record
smacro procedure makevdp (vbc,vev,form); list('vdp,vev,vbc,form,nil);

% basic selectors (conversions)

smacro procedure vdppoly u; cadr cddr u;

smacro procedure vdplbc u; caddr u;

smacro procedure vdpevlmon u; cadr u;

% basic tests

smacro procedure vdpzero!? u;
    null u or null vdppoly u;

smacro procedure vevzero!? u;
    null u or (car u = 0 and vevzero!?1 cdr u);

smacro procedure vdpone!? p;
     not vdpzero!? p and vevzero!? vdpevlmon p;

% base coefficients

%  manipulating of exponent vectors

smacro procedure vevdivides!? (vev1,vev2);
        vevmtest!?(vev2,vev1);

smacro procedure vevzero();
        vevmaptozero1(vdpvars!*,nil);

smacro procedure vdpnumber f; vdpgetprop(f,'number) ;

% the code for checkpointing is factored out
% This version: NO CHECKPOINT FACILITY

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface for DIPOLY polynomials as records (objects).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

fluid '(intvdpvars!* vdpvars!* secondvalue!* vdpsfsortmode!* !*groebrm
        !*vdpinteger !*trgroeb !*trgroebs !*groebdivide pcount!*
        !*groebsubs);

fluid '(vdpsortmode!*);

global '(vdpprintmax groebmonfac);
flag('(vdpprintmax),'share);

fluid '(dipvars!* !*vdpinteger);

symbolic procedure dip2vdp u;
 % Is used when u can be empty.
   (if dipzero!? uu then makevdp(a2bc 0,nil,nil)
                    else makevdp(diplbc uu,dipevlmon uu,uu))
           where uu = if !*groebsubs then dipsubs2 u else u;

% some simple mappings

smacro procedure makedipzero(); nil;

symbolic procedure vdpredzero!? u; dipzero!? dipmred vdppoly u;

symbolic procedure vdplastmon u;
 % Return bc . ev of last monomial of u.
  begin
    u:=vdppoly u;
    if dipzero!? u then return nil;
    while not dipzero!? u and not dipzero!? dipmred u do
        u:=dipmred u;
    return diplbc u . dipevlmon u end;

symbolic procedure vbczero!? u; bczero!? u;

symbolic procedure vbcnumber u;
       if  pairp u and numberp car u and 1=cdr u then cdr u else nil;

symbolic procedure vbcfi u; bcfd u;

symbolic procedure a2vbc u; a2bc u;

symbolic procedure vbcquot(u,v); bcquot(u,v);

symbolic procedure vbcneg u; bcneg u;

symbolic procedure vbcabs u; if vbcminus!? u then bcneg u else u;

symbolic procedure vbcone!? u; bcone!? u;

symbolic procedure vbcprod (u,v); bcprod(u,v);

 % initializing vdp-dip polynomial package
symbolic procedure vdpinit2(vars);
  begin scalar oldorder;
    vdpcleanup();
    oldorder := kord!*;
    if null vars then rerror(dipoly,8,"Vdpinit: vdpvars not set");
    vdpvars!* := dipvars!* := vars;
    torder2 vdpsortmode!*;
    return oldorder end;

symbolic procedure vdpcleanup();
   dipevlist!*:={nil};

symbolic procedure vdpred u;
   begin scalar r,s;
     r:=dipmred vdppoly u;
     if dipzero!? r then return makevdp(nil ./ nil,nil,makedipzero());
     r:=makevdp(diplbc r,dipevlmon r,r);
     if !*gsugar and (s:=vdpgetprop(u,'sugar)) then gsetsugar(r,s);
     return r end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  coefficient handling; here we assume that coefficients are
%  standard quotients;
%

symbolic procedure vbcgcd (u,v);
begin scalar x;
     if not vbcsize(u, -70) or not vbcsize(v, -70)
        then return '(1 . 1);
     x := if denr u = 1 and denr v = 1 then
       if fixp numr u and fixp numr v then gcdn(numr u,numr v)  ./ 1
            else gcdf!*(numr u,numr v) ./ 1
     else 1 ./ 1;
      return x end;

symbolic procedure vbcsize(u, n);
    if n #> -1 then nil
    else if atom u then n
    else
     begin
         n := vbcsize(car u, n #+ 1);
         if null n then return nil;
         return vbcsize(cdr u, n) end;

% the following functions must be redefinable
symbolic procedure vbcplus!? u; (numberp v and v>0) where v = numr u;
symbolic procedure bcplus!? u; (numberp v and v>0) where v = numr u;

symbolic procedure vbcminus!? u;
       (numberp v and v<0) where v = numr u;

symbolic procedure vbcinv u; bcinv u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  conversion between forms, vdps and prefix expressions
%

% prefix to vdp
symbolic procedure a2vdp u;
     if u=0 or null u then makevdp(nil ./ nil,nil,makedipzero())
     else (makevdp(diplbc r,dipevlmon r,r)  where  r = a2dip u);

% vdp to prefix
symbolic procedure vdp2a u; dip2a vdppoly u;

symbolic procedure vbc2a u; bc2a  u;

% form to vdp
symbolic procedure f2vdp(u);
     if u=0 or null u then makevdp(nil ./ nil,nil,makedipzero())
     else (makevdp(diplbc r,dipevlmon r,r)  where  r = f2dip u);

% vdp to form
symbolic procedure vdp2f u; dip2f vdppoly u;

% vdp from monomial
symbolic procedure vdpfmon (coef,vev);
   begin scalar r;
    r:= makevdp(coef,vev,dipfmon(coef,vev));
    if !*gsugar then gsetsugar(r,vevtdeg vev);
    return r end;

% add a monomial to a vdp in front (new vev and coeff)
symbolic procedure vdpmoncomp(coef,vev,vdp);
   if vdpzero!? vdp then vdpfmon(coef,vev)
         else
   if vbczero!? coef then vdp
         else
   makevdp(coef,vev,dipmoncomp(coef,vev,vdppoly vdp));

%add a monomial to the end of a vdp (vev remains unchanged)
symbolic procedure vdpappendmon(vdp,coef,vev);
   if vdpzero!? vdp then vdpfmon(coef,vev)
         else
   if vbczero!? coef then vdp
         else
   makevdp(vdplbc vdp,vdpevlmon vdp,
            dipsum(vdppoly vdp,dipfmon(coef,vev)));

symbolic procedure vdpzero(); a2vdp 0;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  comparing of exponent vectors
%
%

symbolic procedure vdpvevlcomp (p1,p2);
                  dipevlcomp (vdppoly p1,vdppoly p2);
symbolic procedure vevilcompless!?(e1,e2); 1 = evilcomp(e2,e1);
symbolic procedure vevilcomp (e1,e2); evilcomp (e1,e2);
symbolic procedure vevcompless!?(e1,e2); 1 = evcomp(e2,e1);
symbolic procedure vevcomp (e1,e2); evcomp (e1,e2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  routines traversing the "coefficients"
%

% CONTENT of a vdp
% The content is the gcd of all coefficients.

symbolic procedure vdpcontent d;
     if vdpzero!? d then a2bc 0 else
     <>;

symbolic procedure vdpcontent1(d,c); dipnumcontent(vdppoly d,c);

symbolic procedure dipnumcontent(d,c);
     if bcone!? c or dipzero!? d then c
     else dipnumcontent(dipmred d,vbcgcd(c,diplbc d));

symbolic procedure dipcontenti p;
% the content is a pair of the lcm of the coefficients and the
% exponent list of the common monomial factor.
   if dipzero!? p then 1 else
   (if dipzero!? rp then diplbc p .
                             (if !*groebrm then dipevlmon p else nil)
      else
    dipcontenti1(diplbc p,
                 if !*groebrm then dipevlmon p else nil,rp) )
                           where rp=dipmred p;

symbolic procedure dipcontenti1 (n,ev,p1);
   if dipzero!? p1 then n . ev
   else begin scalar nn;
             nn := vbcgcd (n,diplbc p1);
             if ev then ev := dipcontevmin(dipevlmon p1,ev);
             if bcone!? nn and null ev then return nn . nil
                       else return dipcontenti1 (nn,ev,dipmred p1) end;

% CONTENT and MONFAC (if groebrm on)
symbolic procedure vdpcontenti d;
       vdpcontent d . if !*groebrm then vdpmonfac d else nil;

symbolic procedure vdpmonfac d; dipmonfac vdppoly d;

symbolic procedure dipmonfac p;
% exponent list of the common monomial factor.
   if dipzero!? p or not !*groebrm then evzero()
   else (if dipzero!? rp then dipevlmon p
         else dipmonfac1(dipevlmon p,rp) ) where rp=dipmred p;

symbolic procedure dipmonfac1(ev,p1);
   if dipzero!? p1 or evzero!? ev then ev
   else dipmonfac1(dipcontevmin(ev,dipevlmon p1),dipmred p1);

% vdpCoeffcientsFromDomain!?
symbolic procedure vdpcoeffcientsfromdomain!? w;
          dipcoeffcientsfromdomain!? vdppoly w;

symbolic procedure dipcoeffcientsfromdomain!? w;
      if dipzero!? w then t else
     (if bcdomain!? v then dipcoeffcientsfromdomain!? dipmred w
       else nil) where v =diplbc w;

symbolic procedure vdplength f; diplength vdppoly f;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  polynomial operations:
%             coefficient normalization and reduction of monomial
%             factors
%

symbolic procedure vdpequal(p1,p2);
     p1 eq p2
     or (n1 and n1 = n2   % number comparison is faster most times
     or dipequal(vdppoly p1,vdppoly p2)
           where n1 = vdpgetprop(p1,'number),
                 n2 = vdpgetprop(p2,'number));

symbolic procedure dipequal(p1,p2);
    if dipzero!? p1 then dipzero!? p2
    else if dipzero!? p2 then nil
    else diplbc p1 = diplbc p2
     and evequal(dipevlmon p1,dipevlmon p2)
     and dipequal(dipmred p1,dipmred p2);

symbolic procedure evequal(e1,e2);
   % test equality with variable length exponent vectors
     if null e1 and null e2 then t
     else if null e1 then evequal('(0),e2)
     else if null e2 then evequal(e1,'(0))
     else 0=(car e1 #- car e2) and evequal(cdr e1,cdr e2);

symbolic procedure vdplcm p; diplcm vdppoly p;

symbolic procedure vdprectoint(p,q); dip2vdp diprectoint(vdppoly p,q);

symbolic procedure vdpsimpcont(p);
          begin scalar r,q;
              q := vdppoly p;
              if dipzero!? q then return p;
              r := dipsimpcont q;
              p := dip2vdp cdr r;  % the polynomial
              r := car r;          % the monomial factor if any
              if not evzero!? r and (dipmred q or evtdeg r>1)
                then vdpputprop(p,'monfac,r);
              return p end;

symbolic procedure dipsimpcont  (p);
    if !*vdpinteger or not !*groebdivide  then dipsimpconti p
                          else dipsimpcontr p;

% routines for integer coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure dipsimpconti (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar co,lco,res,num;
    if dipzero!?  p then return nil . p;
    co := bcfd 1;
    co := if !*groebdivide then dipcontenti p
             else if !*groebrm then co . dipmonfac p
             else co . nil;
    num := car co;
    if not bcplus!? num then num := bcneg num;
    if not bcplus!? diplbc p then num := bcneg num;
    if bcone!? num  and cdr co = nil  then return nil . p;
    lco := cdr co;
    if groebmonfac neq 0  then lco := dipcontlowerev cdr co;
    res := p;
    if not(bcone!? num and lco = nil) then
                 res := dipreduceconti (p,num,lco);
    if null cdr co then return nil . res;
    lco := evdif(cdr co,lco);
    return(if lco and not evzero!? evdif(dipevlmon res,lco)
                           then lco else nil).res end;

symbolic procedure vdpreduceconti (p,co,vev);
%  divide polynomial p by monomial from co and vev
        vdpdivmon(p,co,vev);

%  divide all coefficients of p by cont
symbolic procedure dipreduceconti (p,co,ev);
    if dipzero!? p
         then makedipzero()
         else
           dipmoncomp ( bcquot (diplbc p,co),
                        if ev then evdif(dipevlmon p,ev)
                              else dipevlmon p,
                        dipreduceconti (dipmred p,co,ev));

% routines for rational coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure dipsimpcontr (p);
%   calculate the contents of p and divide all coefficients by it
  begin scalar co,lco,res;
    if dipzero!?  p then return nil . p;
    co := dipcontentr p;
    if bcone!? diplbc p  and co = nil  then return nil . p;
    lco := dipcontlowerev co;
    res := p;
    if not(bcone!? diplbc p and lco = nil) then
               res := dipreducecontr (p,bcinv diplbc p,lco);
    return (if co then evdif(co,lco) else nil) . res end;

symbolic procedure dipcontentr p;
% the content is the exponent list of the common monomial factor.
   (if dipzero!? rp then
                            (if !*groebrm then dipevlmon p else nil)
      else
    dipcontentr1(if !*groebrm then dipevlmon p else nil,rp) )
                          where rp=dipmred p;

symbolic procedure dipcontentr1 (ev,p1);
   if dipzero!? p1 then ev
      else begin
             if ev then ev := dipcontevmin(dipevlmon p1,ev);
             if null ev then return nil
                       else return dipcontentr1 (ev,dipmred p1) end;

%  divide all coefficients of p by cont
symbolic procedure dipreducecontr (p,co,ev);
    if dipzero!? p
         then makedipzero()
         else
           dipmoncomp ( bcprod (diplbc p,co),
                        if ev then evdif(dipevlmon p,ev)
                              else dipevlmon p,
                        dipreducecontr (dipmred p,co,ev));

symbolic procedure dipcontevmin (e1,e2);
% calculates the minimum of two exponents; if one is shorter, trailing
% zeroes are assumed.
% e1 is an exponent vector. e2 is a list of exponents
    begin scalar res;
       while e1 and e2 do
          <>;
       while res and 0=car res do res := cdr res;
       return reversip res end;

symbolic procedure dipcontlowerev (e1);
% subtract a 1 from those elements of an exponent vector which
% are greater  than 1.
% e1 is a list of exponents, the result is an exponent vector.
    begin scalar res;
       while e1 do
          <>;
       while res and 0 = car res do res := cdr res;
            if res and !*trgroebs then
                   <>;
       return  reversip res end;

symbolic procedure dipappendmon(dip,bc,ev); append(dip,dipfmon(bc,ev));

smacro procedure dipnconcmon(dip,bc,ev); nconc(dip,dipfmon(bc,ev));

smacro procedure dipnconcdip(dip1,dip2); nconc(dip1,dip2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  basic polynomial arithmetic:
%

symbolic procedure vdpsum(d1,d2);
   begin scalar r;
     r:=dip2vdp dipsum(vdppoly d1,vdppoly d2);
     if !*gsugar then gsetsugar(r,max(gsugar d1,gsugar d2));
     return r end;

symbolic procedure vdpdif(d1,d2);
   begin scalar r;
     r:= dip2vdp dipdif(vdppoly d1,vdppoly d2);
     if !*gsugar then gsetsugar(r,max(gsugar d1,gsugar d2));
     return r end;

symbolic procedure vdpprod(d1,d2);
   begin scalar r;
     r:= dip2vdp dipprod(vdppoly d1,vdppoly d2);
     if !*gsugar then gsetsugar(r,gsugar d1 + gsugar d2);
     return r end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  linear combination: the Buchberger Workhorse
%
% LCOMB1: calculate mon1 * vdp1 + mon2 * vdp2
symbolic procedure vdpilcomb1(d1,vbc1,vev1,d2,vbc2,vev2);
 begin scalar r;
  r:=
 dip2vdp dipilcomb1 (vdppoly d1,vbc1,vev1,vdppoly d2,vbc2,vev2);
  if !*gsugar then gsetsugar(r,max(gsugar d1+vevtdeg vev1,
                                   gsugar d2+vevtdeg vev2));
  return r end;

symbolic procedure dipilcomb1 (p1,bc1,ev1,p2,bc2,ev2);
% same asl dipILcomb, exponent vectors multiplied in already
begin scalar gcd;
   gcd := !*gcd;
return
   begin scalar ep1,ep2,sl,res,sum,z1,z2,p1new,p2new,lptr,bptr,c,!*gcd;
       !*gcd := if vbcsize(bc1,-70) and vbcsize(bc2,-70)then gcd;
       z1 := not evzero!? ev1; z2 := not evzero!? ev2;
       p1new := p2new := t;
       lptr := bptr := res := makedipzero();
 loop:
       if p1new then
       << if dipzero!? p1 then
              return if dipzero!? p2 then res else
                     dipnconcdip(res, dipprod(p2,dipfmon(bc2,ev2)));
          ep1 := dipevlmon p1;
          if z1 then ep1 := evsum(ep1,ev1);
          p1new := nil;>>;
       if p2new then
       << if dipzero!? p2 then
              return dipnconcdip(res, dipprod(p1,dipfmon(bc1,ev1)));
          ep2 := dipevlmon p2;
          if z2 then ep2 := evsum(ep2,ev2);
          p2new := nil; >>;
        sl := evcomp(ep1, ep2);
        if sl = 1 then
                << if !*gcd and not vbcsize(diplbc p1, -70)
                             then !*gcd := nil;
                   c := bcprod(diplbc p1,bc1);
                   if not bczero!? c then
                   <>;
                   p1 := dipmred p1; p1new := t;
                >>
        else if sl = -1 then
                << if !*gcd and not vbcsize(diplbc p2, -70)
                              then !*gcd := nil;
                   c := bcprod(diplbc p2,bc2);
                   if not bczero!? c then
                   <>;
                   p2 := dipmred p2; p2new := t;
                >>
        else
                << if !*gcd and (not vbcsize(diplbc p1,-70) or
                      not vbcsize(diplbc p2,-70)) then !*gcd := nil;
                   sum := bcsum (bcprod(diplbc p1,bc1),
                                 bcprod(diplbc p2,bc2));
                   if not bczero!? sum then
                       <<   lptr := dipnconcmon(bptr,sum,ep1);
                            bptr := dipmred lptr>>;
                   p1 := dipmred p1; p2 := dipmred p2;
                   p1new := p2new := t;
                >>;
        if dipzero!? res then <>; % initial
        goto loop;
 end;
end;

symbolic procedure vdpvbcprod(p,a);
   (if !*gsugar then gsetsugar(q,gsugar p) else q)
       where q=dip2vdp dipbcprod(vdppoly p,a);

symbolic procedure vdpdivmon(p,c,vev);
   (if !*gsugar then gsetsugar(q,gsugar p) else q)
       where q=dip2vdp dipdivmon(vdppoly p,c,vev);

symbolic procedure dipdivmon(p,bc,ev);
    % divides a polynomial by a monomial
    % we are sure that the monomial ev is a factor of p
    if dipzero!? p
         then makedipzero()
         else
           dipmoncomp ( bcquot(diplbc p,bc),
                        evdif(dipevlmon p,ev),
                        dipdivmon (dipmred p,bc,ev));

symbolic procedure vdpcancelmvev(p,vev);
    (if !*gsugar then gsetsugar(q,gsugar p) else q)
       where q=dip2vdp dipcancelmev(vdppoly p,vev);

symbolic procedure dipcancelmev(f,ev);
    % cancels all monomials in f which are multiples of ev
      dipcancelmev1(f,ev,makedipzero());

symbolic procedure dipcancelmev1(f,ev,res);
    if dipzero!? f then res
    else if evmtest!?(dipevlmon f,ev) then
                       dipcancelmev1(dipmred f,ev,res)
     else dipcancelmev1(dipmred f,ev,
       %                 dipAppendMon(res,diplbc f,dipevlmon f));
                         dipnconcmon(res,diplbc f,dipevlmon f));

% some prehistoric routines needed in resultant operation
symbolic procedure vevsum0(n,p);
% exponent vector sum version 0. n is the length of vdpvars!*.
% p is a distributive polynomial.
  if vdpzero!? p then vevzero1 n else
  vevsum(vdpevlmon p, vevsum0(n,vdpred p));

symbolic procedure vevzero1 n;
% Returns the exponent vector power representation
% of length n for a zero power.
  begin scalar x;
   for i:=1: n do << x := 0 . x >>;
  return x end;

symbolic procedure vdpresimp u;
   % fi domain changes, the coefficients have to be resimped
   dip2vdp dipresimp vdppoly u;

symbolic procedure dipresimp u;
   if null u then nil else
   (for each x in u collect
      <>
      ) where toggle = t;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% printing of polynomials
%

symbolic procedure vdpprin2t u; << vdpprint1(u,nil,9999); terpri()>>;

symbolic procedure vdpprint u; <>;

symbolic procedure vdpprin2 u;
   <<(if x then <>;
                  prin2 "):  ">>)
                 where x=vdpgetprop(u,'number),
                       s=vdpgetprop(u,'sugar);
      vdpprint1(u,nil,vdpprintmax)>>;

symbolic procedure vdpprint1(u,v,max); vdpprint1x(vdppoly u,v,max);

symbolic procedure vdpprint1x(u,v,max);
%   /* Prints a distributive polynomial in infix form.
%     U is a distributive form. V is a flag which is true if a term
%     has preceded current form
%     max limits the number of terms to be printed
   if dipzero!? u then if null v then dipprin2 0 else nil
    else if max = 0 then   % maximum of terms reached
              << terpri();
                 prin2 " ### etc (";
                 prin2 diplength u;
                 prin2 " terms) ###";
                 terpri()>>
    else begin scalar bool,w;
       w := diplbc u;
       if bcminus!? w then <>;
       if bool then dipprin2 " - " else if v then dipprin2 " + ";
       (if not bcone!? w or evzero!? x then<>
         else dipevlpri(x,nil))
           where x = dipevlmon u;
       vdpprint1x(dipmred u,t, max - 1) end;

symbolic procedure dipprin2 u;
   <69 then terprit 2 ; prin2 u>>;

symbolic procedure vdpsave u; u;

%   switching between term order modes

symbolic procedure torder2 u; dipsortingmode u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% additional conversion utilities

% conversion dip to standard form / standard quotient

symbolic procedure dip2f u;
      (if denr v neq 1 then
        <>
       else numr v) where v = dip2sq u;

symbolic procedure dip2sq u;
   % convert a dip into a standard quotient.
     if dipzero!? u then nil ./ 1
     else addsq(diplmon2sq(diplbc u,dipevlmon u),dip2sq dipmred u);

symbolic procedure diplmon2sq(bc,ev);
   %convert a monomial into a standard quotient.
     multsq(bc,dipev2f(ev,dipvars!*) ./ 1);

symbolic procedure dipev2f(ev,vars);
     if null ev then 1
     else if car ev = 0 then dipev2f(cdr ev,cdr vars)
     else multf(car vars .** car ev .* 1 .+ nil,
                dipev2f(cdr ev,cdr vars));

% evaluate SUBS2 for the coefficients of a dip

symbolic procedure dipsubs2 u;
   begin scalar v,secondvalue!*;
      secondvalue!* := 1 ./ 1;
      v := dipsubs21 u;
      return diprectoint(v,secondvalue!*) end;

symbolic procedure dipsubs21 u;
   begin scalar c;
      if dipzero!? u then return u;
      c := groebsubs2 diplbc u;
      if null numr c then return dipsubs21 dipmred u;
      if not(denr c = 1) then
          secondvalue!* := bclcmd(c,secondvalue!*);
      return dipmoncomp(c,dipevlmon u,dipsubs21 dipmred u) end;

% conversion standard form to dip

symbolic procedure f2dip u; f2dip1(u,evzero(),bcfd 1);

symbolic procedure f2dip1 (u,ev,bc);
  % f to dip conversion: scan the standard form. ev
  % and bc are the exponent and coefficient parts collected
  % so far from higher parts.
   if null u then nil
   else if domainp u then dipfmon(bcprod(bc,bcfd u),ev)
   else dipsum(f2dip2(mvar u,ldeg u,lc u,ev,bc),
               f2dip1(red u,ev,bc));

symbolic procedure f2dip2(var,dg,c,ev,bc);
  % f to dip conversion:
  % multiply leading power either into exponent vector
  % or into the base coefficient.
   <>
           where ev1=if memq(var,dipvars!*) then
                evinsert(ev,var,dg,dipvars!*) else nil;

symbolic procedure evinsert(ev,v,dg,vars);
   % f to dip conversion:
   % Insert the "dg" into the ev in the place of variable v.
     if null ev or null vars then nil
     else if car vars eq v then dg . cdr ev
     else car ev . evinsert(cdr ev,v,dg,cdr vars);

symbolic procedure vdpcondense f;
   dipcondense car cdddr f;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/dip2a.red0000644000175000017500000000424211526203062023501 0ustar  giovannigiovannimodule dip2a;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Functions for converting distributive forms into prefix forms

%Authors: R. Gebauer, A. C. Hearn, H. Kredel

symbolic procedure dip2a u;
%    Returns prefix equivalent of distributive polynomial u.
   if dipzero!? u then 0 else dipreplus dip2a1 u;

symbolic procedure dip2a1 u;
   if dipzero!? u then nil
    else ((if bcminus!? x then list('minus,dipretimes(bc2a bcneg x.y))
           else dipretimes(bc2a x.y))
         where x = diplbc u, y = expvec2a dipevlmon u)
           .dip2a1 dipmred u;

symbolic procedure dipreplus u;
   if atom u then u else if null cdr u then car u else 'plus . u;

symbolic procedure dipretimes u;
%   /* U is a list of prefix expressions the first of which is a number.
%     Result is prefix representation for their product*/
   if car u = 1 then if cdr u then dipretimes cdr u else 1
    else if null cdr u then car u
    else 'times.u;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/vdpcom.red0000644000175000017500000002733511526203062024002 0ustar  giovannigiovannimodule vdpcom;

% Common routines to all vdp mappings.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


flag('(vdpprintmax),'share);
vdpprintmax:=5;

% Repeat of smacros defined in vdp2dip.

smacro procedure vdppoly u;cadr cddr u;

smacro procedure vdpzero!? u;null u or null vdppoly u;

smacro procedure vdpevlmon u;cadr u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  manipulating of exponent vectors
%

symbolic procedure vevnth(a,n);
% Extract nth element from 'a'.
if null a then 0 else if n=1 then car a else vevnth(cdr a,n #- 1);

% Unrolled code for zero test(very often called).
smacro procedure vevzero!? u;
  null u or(car u=0 and vevzero!?1 cdr u);

symbolic procedure vevzero!?1 u;
 null u or(car u=0 and vevzero!? cdr u);

symbolic procedure veveq(vev1,vev2);
 if null vev1 then vevzero!? vev2
 else if null vev2 then vevzero!? vev1
 else(car vev1=car vev2 and vevequal(cdr vev1,vev2));

symbolic procedure vevmaptozero e;
% Generate an exponent vector with same length as e and zeros only.
 vevmaptozero1(e,nil);

symbolic procedure vevmaptozero1(e,vev);
 if null e then vev else vevmaptozero1(cdr e,0 .vev);

symbolic procedure vevmtest!?(e1,e2);
% Exponent vector multiple test.'e1' and 'e2' are compatible exponent
% vectors.vevmtest?(e1,e2) returns a boolean expression.
% True if exponent vector 'e1' is a multiple of exponent
%    vector 'e2', else false.
 if null e2 then t else if null e1 then if vevzero!? e2 then t else nil
 else not(car e1 #< car e2)and vevmtest!?(cdr e1,cdr e2);

symbolic procedure vevlcm(e1,e2);
% Exponent vector least common multiple.'e1' and 'e2' are
% exponent vectors.'vevlcm(e1,e2)' computes the least common
% multiple of the exponent vectors 'e1' and 'e2', and returns
% an exponent vector.
 begin scalar x;
  while e1 and e2 do
  < car e2 then car e1 else car e2).x;
   e1:=cdr e1;e2:=cdr e2>>;
  x:=reversip x;
  if e1 then x:=nconc(x,e1)else if e2 then x:=nconc(x,e2);
  return x end;

symbolic procedure vevmin(e1,e2);
% Exponent vector minima.
 begin scalar x;
  while e1 and e2 do
  <>;
  while x and 0=car x do x:=cdr x;% Cut trailing zeros.
  return reversip x end;

symbolic procedure vevsum(e1,e2);
% Exponent vector sum.'e1' and 'e2' are exponent vectors.
% 'vevsum(e1,e2)' calculates the sum of the exponent vectors
% 'e1' and 'e2' componentwise and returns an exponent vector.
 begin scalar x;
  while e1 and e2 do
  <>;
   x:=reversip x;
   if e1 then x:=nconc(x,e1)else if e2 then x:=nconc(x,e2);
   return x end;

symbolic procedure vevtdeg u;
% Calculate the total degree of u.
 if null u then 0 else car u #+ vevtdeg cdr u;

symbolic procedure vdptdeg u;
 if vdpzero!? u then 0 else
  max(vevtdeg vdpevlmon u,vdptdeg vdpred u);

symbolic procedure vevdif(ee1,ee2);
% Exponent vector difference.'e1' and 'e2' are exponent
% vectors.'vevdif(e1,e2)' calculates the difference of the
% exponent vectors componentwise and returns an exponent vector.
 begin scalar x,y,break,e1,e2;
  e1:=ee1;e2:=ee2;
  while e1 and e2 and not break do
  <>;
  if break or(e2 and not vevzero!? e2)then
  <>;
  return nconc(reversip x,e1)end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Numbering of polynomials.
%

symbolic procedure vdpenumerate f;
% 'f' is a temporary result.Prepare it for medium range storage
% and sign a number.
 if vdpzero!? f then f else
 <>;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% SUGAR of polynomials.
%

symbolic procedure gsugar p;
 if !*gsugar then
(( s or
   <>
  )where s= if vdpzero!? p then 0 else vdpgetprop(p,'sugar));

symbolic procedure gsetsugar(p,s);
 !*gsugar and vdpputprop(p,'sugar,s or vdptdeg p)or p;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Operations on sets of polynomials.
%

symbolic procedure vdpmember(p1,l);
% Test membership of a polynomial in a list of polys.
 if null l then nil else
 if vdpequal(p1,car l)then l else vdpmember(p1,cdr l);

symbolic procedure vdpunion(s1,s2);
% 's1' and 's2' are two sets of polynomials;
% union of the sets using vdpMember as crit.
 if null s1 then s2 else
 if vdpmember(car s1,s2)then vdpunion(cdr s1,s2)
  else car s1.vdpunion(cdr s1,s2);

symbolic procedure vdpintersection(s1,s2);
% 's1' and 's2' are two sets of polynomials;
% intersection of the sets using vdpmember as crit.
 if null s1 then nil else
 if vdpmember(car s1,s2)then car s1.vdpunion(cdr s1,s2)
  else vdpunion(cdr s1,s2);

symbolic procedure vdpsetequal!?(s1,s2);
% Tests if 's1' and 's2' have the same polynomials as members.
 if not(length s1=length s2)then nil
  else vdpsetequal!?1(s1,append(s2,nil));

symbolic procedure vdpsetequal!?1(s1,s2);
% Destroys its second parameter(is therefore copied when called).
 if null s1 and null s2 then t else
 if null s1 or null s2 then nil else
(if hugo then vdpsetequal!?1(cdr s1,groedeletip(car hugo,s2))
  else nil)where hugo=vdpmember(car s1,s2);

symbolic procedure vdpsortedsetequal!?(s1,s2);
% Tests if 's1' and 's2' have the same polynomials as members
% here assuming, that both sets are sorted by the same principles.
 if null s1 and null s2 then t else if null s1 or null s2 then nil else
 if vdpequal(car s1,car s2)then
  vdpsortedsetequal!?(cdr s1,cdr s2)else nil;

symbolic procedure vdpdisjoint!?(s1,s2);
% 's1' and 's2' are two sets of polynomials;
% test that there are no common members.
 if null s1 then t else
 if vdpmember(car s1,s2)then nil else vdpdisjoint!?(cdr s1,s2);

symbolic procedure vdpsubset!?(s1,s2);
 not(length s1 > length s2)and vdpsubset!?1(s1,s2);

symbolic procedure vdpsubset!?1(s1,s2);
% 's1' and 's2' are two sets of polynomials.
% Test if 's1' is subset of 's2'.
 if null s1 then t else
 if vdpmember(car s1,s2)then vdpsubset!?1(cdr s1,s2)else nil;

symbolic procedure vdpdeletemember(p,l);
% Delete polynomial 'p' from list 'l'.
 if null l then nil else
 if vdpequal(p,car l)then vdpdeletemember(p,cdr l)
  else car l.vdpdeletemember(p,cdr l);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Sorting of polynomials.
%

symbolic procedure vdplsort pl;
% Distributive polynomial list sort.'pl' is a list of
% distributive polynomials.'vdplsort(pl)' returns the
% sorted distributive polynomial list of pl.
 sort(pl,function vdpvevlcomp);

symbolic procedure vdplsortin(p,pl);
% 'p' is a polynomial, 'pl' is a list of polynomials.
% 'p' is inserted into 'pl' at its place determined by vevlcompless?.
% The result is the updated pl.
 if null pl then{p}else<>;

symbolic procedure vdplsortin1(p,pl,oldpl);
 if null pl then cdr oldpl:= p.nil
  else if vevcompless!?(vdpevlmon p,vdpevlmon car pl)
   then  vdplsortin1(p,cdr pl,pl)
  else <>;

symbolic procedure vdplsortinreplacing(po,pl);
% 'po' is a polynomial, 'pl' is a linear list of polynomials(sorted).
% 'po' is inserted into 'pl' at its place determined by 'vevlcompless?'.
% If there is a multiple of the first exponent of a polynomial in 'pl',
% this one is deleted from 'pl'.The result is the updated 'pl'.
% 'opl' is the initial value of 'pl',(initial multiples of 'po' are
% removed);'oopl' a working version of 'opl'.
 begin scalar oopl,opl;if pl then go to bb;
aa : return po.nil;
bb : if vevdivides!?(vdpevlmon po,vdpevlmon car pl)then
  <>;
  opl:=pl;
cc : if null pl then
    <>;
  if not(pl eq opl)and vevdivides!?(vdpevlmon po,vdpevlmon car pl)then
   <>
        else <>; go to cc>>;
  if vevcompless!?(vdpevlmon po,vdpevlmon car pl)then
  <>;
   cdr pl:=car pl.cdr pl;car pl:=po;% Insert 'po'.
  return opl end;

symbolic procedure lastpair1 opl;
% Determine the last full pair(the 'cdr' non-nil)of the linear list
% 'opl';if the routine is called with 'nil' or cdr='nil',
% return 't'.
 if null opl or null cdr opl then t else
  <>;

symbolic procedure countlastvar(a,m);
% Count the monomials with the last variable of a vdp-polynomial
% 'a';'m' determines, whether the first('m' is true)non-factor
% of the last variable leads to the result '0';if the polynomial has more
% than 25 elements, return '0' if 'm' is false or if the polynomial has
% more than 25 terms(divisible by the last variable).
 begin integer n,nn;a:=vdppoly a;
aa: if atom a then return n;
  nn:=nn #+ 1;if nn #> 25 then return 0;n:=n #+ 1;
  if countlastvar1 dipevlmon a #< 1 then(if m then return 0 else n:=0);
  a:=dipmred a;go to aa end;

symbolic procedure countlastvar1 b;
 begin scalar n;n:=1;
aa : if atom b then return 0 else if n=vdplastvar!* then return car b;
  b:=cdr b;n:=n #+ 1;go to aa end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Property lists for polynomials.
%

symbolic procedure vdpputprop(poly,prop,val);
 begin scalar c,p;
  if not pairp poly or not pairp(c:=cdr poly)or not pairp(c:=cdr c)
   or not pairp(c:=cdr c)or not pairp(c:=cdr c)
    then rerror(dipoly,6,
    {"vdpputprop given a non-vdp as 1st parameter",poly,prop,val});
  p:=assoc(prop,car c);
  if p then rplacd(p,val)else rplaca(c,(prop.val).car c);
  return poly end;

symbolic procedure vdpgetprop(poly,prop);
 if null poly then nil  % nil is a legal variant of vdp=0
  else if not eqcar(poly,'vdp)
    then rerror( dipoly,7,
    {"vdpgetprop given a non-vdp as 1st parameter",
      poly,prop})
  else(if p then cdr p else nil)
      where p=assoc(prop,cadr cdddr poly);

symbolic procedure vdpremallprops u;
 begin scalar c;
 if not(not pairp u or not pairp(c:=cdr u)or not pairp(c:=cdr c)
  or not pairp(c:=cdr c)or not pairp(c:=cdr c))
   then rplaca(c,nil);return u end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Groebner interface to power substitution.
%

fluid'(!*sub2);

symbolic procedure groebsubs2 q;(subs2 q)where !*sub2=t;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% And a special print.
%

symbolic procedure vdpprintshort u;
 begin scalar m;
  m:=vdpprintmax;vdpprintmax:= 2;vdpprint u;vdpprintmax:=m end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/condense.red0000644000175000017500000000330411526203062024276 0ustar  giovannigiovannimodule condense;  % unify exponent vectors for lower memory consumption.

% Author: Herbert Melenk

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


dipevlist!*:={nil};

symbolic procedure dipcondense f;
 begin scalar dl,ev;
  dl:=dipevlist!*;
  while f do
  <> end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/torder.red0000644000175000017500000004215611526203062024007 0ustar  giovannigiovannimodule torder; % Term order modes for distributive polynomials.
               % H. Melenk, ZIB Berlin.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The routines of this module should be coded as efficiently as
% possible.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%   switching between term order modes: TORDER statement.
%

global!-dipvars!*:='(list);

symbolic procedure torder u;
  begin scalar oldmode,oldex,oldvars,w;
   oldmode:=vdpsortmode!*; oldex:=vdpsortextension!*;
   oldvars:=global!-dipvars!*;
   global!-dipvars!*:='(list);
 a:
   w:=reval car u; u:=cdr u;
   if eqcar(w,'list) and null u then<>;
   if eqcar(w,'list) then
   <>;
   vdpsortmode!*:=w;
%  dipsortevcomp!*:=get(w, 'evcomp);
   vdpsortextension!*:=for each x in u join
     (if eqcar(x:=reval x,'list) then cdr x else {x});
   if flagp(vdpsortmode!*,'dipsortextension) and null vdpsortextension!*
     then rederr "term order needs additional parameter(s)";
   return 'list . oldvars . oldmode . oldex end ;

remprop('torder,'number!-of!-args);

put('torder,'psopfn,'torder);

symbolic procedure dipsortingmode u;
%   Sets the exponent vector sorting mode. Returns the previous mode
    begin scalar x,z;
       if not idp u or not flagp(u,'dipsortmode)
            then return typerr(u,"term ordering mode");
       x:=dipsortmode!*; dipsortmode!*:=u;
           % saves thousands of calls to GET;
       dipsortevcomp!*:=get(dipsortmode!*,'evcomp);
       if not getd dipsortevcomp!* then
          rerror(dipoly,2,
                 "No compare routine for term order mode found");
       if (z:=get(dipsortmode!*,'evcompinit)) then apply(z,nil);
       if (z:=get(dipsortmode!*,'evlength)) and z neq length dipvars!*
          then rederr
                  "wrong variable number for fixed length term order";
       vdplastvar!*:=length dipvars!* ;
       return x end ;

flag('(lex gradlex revgradlex),'dipsortmode);

put('lex,'evcomp,'evlexcomp);

put('gradlex,'evcomp,'evgradlexcomp);

put('revgradlex,'evcomp,'evrevgradlexcomp);

symbolic procedure evcompless!?(e1,e2);
%    Exponent vector compare less. e1, e2 are exponent vectors
%    in some order. Evcompless? is a boolean function which returns
%    true if e1 is ordered less than e2 .
%    Mapped to evcomp .
    1=evcomp(e2,e1) ;

symbolic procedure evcomp (e1,e2);
%   Exponent vector compare. e1, e2 are exponent vectors in some
%    order.  Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is
%    equal exponent vector e2, the digit 1 if e1 is greater than e2,
%    else the digit -1. This function is assigned a value by the
%    ordering mechanism, so is dummy for now .
% IDapply would be better here, but is not within standard LISP!
   apply(dipsortevcomp!*,list(e1,e2)) ;

symbolic procedure evlexcomp (e1,e2);
%    Exponent vector lexicographical compare. The
%    exponent vectors e1 and e2 are in lexicographical
%    ordering. evLexComp(e1,e2) returns the digit 0 if exponent
%    vector e1 is equal exponent vector e2, the digit 1 if e1 is
%    greater than e2, else the digit -1.
   if null e1 then 0
    else if null e2 then evlexcomp(e1,'(0))
    else if car e1 #= car e2 then evlexcomp(cdr e1,cdr e2)
    else if car e1 #> car e2 then 1
    else -1 ;

symbolic procedure evinvlexcomp (e1,e2);
%   Exponent vector inverse lexicographical compare .
   if null e1 then
      if null e2 then 0 else evinvlexcomp('(0),e2)
    else if null e2 then evlexcomp(e1,'(0))
    else if car e1 #= car e2 then evinvlexcomp(cdr e1,cdr e2)
    else (if not(n#=0) then n
%         else if car e2 #= car e1 then 0
          else if car e2 #> car e1 then 1
          else -1) where n=evinvlexcomp(cdr e1,cdr e2);

symbolic procedure evgradlexcomp (e1,e2);
%    Exponent vector graduated lex compare.
%    The exponent vectors e1 and e2 are in graduated lex
%    ordering. evGradLexComp(e1,e2) returns the digit 0 if exponent
%    vector e1 is equal exponent vector e2, the digit 1 if e1 is
%    greater than e2, else the digit -1.
   if null e1 then 0
    else if null e2 then evgradlexcomp(e1,'(0))
    else if car e1 #= car e2 then evgradlexcomp(cdr e1, cdr e2)
    else (if te1#=te2 then if car e1 #> car e2 then 1 else -1
          else if te1 #> te2 then 1 else -1)
          where te1=evtdeg e1, te2=evtdeg e2;

symbolic procedure evrevgradlexcomp (e1,e2);
%    Exponent vector reverse graduated lex compare.
%    The exponent vectors e1 and e2 are in reverse graduated lex
%    ordering. evRevGradLexcomp(e1,e2) returns the digit 0 if exponent
%    vector e1 is equal exponent vector e2, the digit 1 if e1 is
%    greater than e2, else the digit -1.
   if null e1 then 0
    else if null e2 then evrevgradlexcomp(e1,'(0))
    else if car e1 #= car e2 then evrevgradlexcomp(cdr e1, cdr e2)
    else (if te1 #= te2 then evinvlexcomp(e1,e2)
          else if te1 #> te2 then 1 else -1)
          where te1=evtdeg e1, te2=evtdeg e2;

symbolic procedure evtdeg e1;
%    Exponent vector total degree. e1 is an exponent vector.
%    evtdeg(e1) calculates the total degree of the exponent
%    e1 and returns an integer.
   (<>; x>>) where x=0;

% The following section contains additional term order modes.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  gradlexgradlex
%
%  this order can have several steps
%      torder gradlexgradlex,3,2,4;
%

flag ('(gradlexgradlex),'dipsortmode);
flag ('(gradlexgradlex),'dipsortextension);
put('gradlexgradlex,'evcomp,'evgradgradcomp);

symbolic procedure evgradgradcomp (e1,e2);
      evgradgradcomp1 (e1,e2,car vdpsortextension!*,
                             cdr vdpsortextension!*);

symbolic procedure evgradgradcomp1 (e1,e2,n,nl);
   if null e1 then 0
    else if null e2 then evgradgradcomp1(e1,'(0),n,nl)
    else if n#=0 then if null nl then evgradlexcomp(e1,e2)
                   else evgradgradcomp1 (e1,e2,car nl,cdr nl)
    else if car e1 #= car e2 then
              evgradgradcomp1(cdr e1,cdr e2,n#-1,nl)
    else (if te1 #= te2 then if car e1 #> car e2 then 1 else -1
           else if te1 #> te2 then 1 else -1)
          where te1=evpartdeg(e1,n), te2=evpartdeg(e2,n);

symbolic procedure evpartdeg(e1,n); evpartdeg1(e1,n,0);

symbolic procedure evpartdeg1(e1,n,sum);
     if n #= 0 or null e1 then sum
      else evpartdeg1(cdr e1,n #-1, car e1 #+ sum);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  gradlexrevgradlex
%
%

flag ('(gradlexrevgradlex),'dipsortmode);
flag ('(gradlexrevgradlex),'dipsortextension);
put('gradlexrevgradlex,'evcomp,'evgradrevgradcomp);

symbolic procedure evgradrevgradcomp (e1,e2);
      evgradrevgradcomp1 (e1,e2,car vdpsortextension!*);

symbolic procedure evgradrevgradcomp1 (e1,e2,n);
   if null e1 then 0
    else if null e2 then evgradrevgradcomp1(e1,'(0),n)
    else if n#=0 then evrevgradlexcomp(e1,e2)
    else if car e1 #= car e2 then evgradrevgradcomp1(cdr e1,cdr e2,n#-1)
    else (if te1 #= te2 then if car e1 #< car e2 then 1 else -1
           else if te1 #> te2 then 1 else -1)
          where te1=evpartdeg(e1,n), te2=evpartdeg(e2,n);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  LEXGRADLEX
%
%

flag ('(lexgradlex),'dipsortmode);
flag ('(lexgradlex),'dipsortextension);
put('lexgradlex,'evcomp,'evlexgradlexcomp);

symbolic procedure evlexgradlexcomp (e1,e2);
      evlexgradlexcomp1 (e1,e2,car vdpsortextension!*);

symbolic procedure evlexgradlexcomp1 (e1,e2,n);
   if null e1 then (if evzero!? e2 then 0 else -1)
    else if null e2 then evlexgradlexcomp1(e1,'(0),n)
    else if n#=0 then evgradlexcomp(e1,e2)
    else if car e1 #= car e2 then evlexgradlexcomp1(cdr e1,cdr e2,n#-1)
    else if car e1 #> car e2 then 1 else -1;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  LEXREVGRADLEX
%
%

flag ('(lexrevgradlex),'dipsortmode);
flag ('(lexrevgradlex),'dipsortextension);
put('lexrevgradlex,'evcomp,'evlexrevgradlexcomp);

symbolic procedure evlexrevgradlexcomp (e1,e2);
      evlexrevgradlexcomp1 (e1,e2,car vdpsortextension!*);

symbolic procedure evlexrevgradlexcomp1 (e1,e2,n);
   if null e1 then (if evzero!? e2 then 0 else -1)
    else if null e2 then evlexrevgradlexcomp1(e1,'(0),n)
    else if n#=0 then evrevgradlexcomp(e1,e2)
    else if car e1 #= car e2 then
                   evlexrevgradlexcomp1(cdr e1,cdr e2,n#-1)
    else if car e1 #> car e2 then 1 else -1;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  WEIGHTED
%
%

flag ('(weighted),'dipsortmode);
flag ('(weighted),'dipsortextension);
put('weighted,'evcomp,'evweightedcomp);

symbolic procedure evweightedcomp (e1,e2);
     (if dg1 #= dg2 then evlexcomp(e1,e2) else
      if dg1 #> dg2 then 1 else -1
       ) where dg1=evweightedcomp2(0,e1,vdpsortextension!*),
               dg2=evweightedcomp2(0,e2,vdpsortextension!*);

symbolic procedure evweightedcomp1 (e,w); evweightedcomp2(0, e, w);

symbolic procedure evweightedcomp2 (n,e,w);
  % scalar product of exponent and weight vector
   if null e then n else
   if null w then evweightedcomp2(n, e, '(1 1 1 1 1)) else
   if car w=0 then evweightedcomp2(n, cdr e, cdr w) else
   if car w=1 then evweightedcomp2(n #+ car e, cdr e, cdr w) else
   evweightedcomp2(car e #* car w #+ n, cdr e, cdr w);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  GRADED term order
%     cascading a graded sorting with another term order.
%
%  The grade of a term is defined as a scalar product of the exponent
%  vector and a grade vector which contains non-negative integers.
%  In contrast to a weight vector the grade vector may contain also
%  zeros. A vector of ones is used if no vector is given explicitly.
%

fluid '(gradedrec!*);

flag ('(graded),'dipsortmode);
flag ('(graded),'dipsortextension);
put('graded,'evcomp,'evgradedcomp);
put('graded,'evcompinit,'evgradedinit);

symbolic procedure evgradedinit();
  begin scalar w,gvect,vse;
    vse:=vdpsortextension!*;
    while pairp vdpsortextension!* and numberp car vdpsortextension!*
      do <>;
    if vdpsortextension!* then
       <>
      else w:='lex;
    dipsortingmode w;
    gradedrec!*:={reversip gvect,dipsortevcomp!*,vdpsortextension!*};
    dipsortevcomp!*:='evgradedcomp;
    dipsortmode!*:='graded;
    vdpsortextension!*:=vse end;

symbolic procedure evgradedcomp (e1,e2);
     (if dg1 #= dg2 then
           apply(cadr gradedrec!*,{e1,e2})
              where vdpsortextension!*=caddr gradedrec!*
        else
      if dg1 #> dg2 then 1 else -1
       ) where dg1=ev!-gamma e1,  dg2=ev!-gamma e2;

symbolic procedure ev!-gamma(ev);
  % compute the grade of an exponent vector;
    evweightedcomp1 (ev,
         if dipsortmode!*='graded then car gradedrec!* else
         if dipsortmode!*='weighted then vdpsortextension!* else nil);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% MATRIX
%
%

% In the following routines I assume that 99 percent of the matrix
% entries will be 0 or 1 such that the special branches for these
% numbers makes sense. We save lots of memory read and
% multiplication is needed only entries other than 0 and 1.
%
% I could do the same optimization step for -1, but I don't
% expect that many people will use term orders with negative
% numbers.
%
% This package includes a compilation mode for matrix term orders
% for fixed length variable lists. Compilation is done implicilty
% when *comp is on, or explicitly by callint torder_compile.

flag ('(matrix),'dipsortmode);
flag ('(matrix),'dipsortextension);
put('matrix,'evcomp,'evmatrixcomp);
put('matrix,'evcompinit,'evmatrixinit);

symbolic procedure evmatrixcomp(e1,e2); evmatrixcomp1(e1,e2,vdpmatrix!*);

symbolic procedure evmatrixcomp1(e1,e2,m);
   if null m then 0 else
   (if w1 #= w2 then evmatrixcomp1(e1,e2,cdr m) else % #=
    if w1 #> w2 then 1 else -1)
  where
    w1= evmatrixcomp2 (e1,car m,0),
    w2= evmatrixcomp2 (e2,car m,0);

symbolic procedure evmatrixcomp2(e,l,w);
   if null e or null l then w else
  (if l1 #= 0 then
      evmatrixcomp2(cdr e,cdr l,w) else
   if l1 #= 1 then
      evmatrixcomp2(cdr e,cdr l,w #+ car e)
   else evmatrixcomp3(e,l1,l,w)) where l1=car l;

symbolic procedure evmatrixcomp3(e,l1,l,w);
   evmatrixcomp2(cdr e,cdr l,w #+ car e #* l1);

symbolic procedure evmatrixinit1(w,mode);
  begin scalar m,mm;
   if not eqcar(w,'mat) or
      mode and length cadr w neq length dipvars!* then
           typerr(w,"term order matrix for". dipvars!*);
   for each row in cdr w do
    <>;
   m:=reversip m; mm:=reversip mm;
   if m neq vdpmatrix!* then
    < length cdr w then
           lprim "Warning: non-square matrix used in torder"
      else if 0=reval{'det,w} then
           typerr(w,"term order (singular matrix)");
      if not evmatrixcheck mm then
           typerr(w,"term order (non admissible)")
     >>;
   return m end;

symbolic procedure evmatrixinit();
  begin scalar c,m,w;
   w:=reval car vdpsortextension!*;
   m:=evmatrixinit1(w,t);
   if (c:=assoc(m,compiled!-orders!*)) then
      dipsortevcomp!*:=cdr c else
    if !*comp then dipsortevcomp!*:=evmatrixcompile m;
   vdpmatrix!*:=m end;

symbolic procedure evmatrixcheck m;
 % Check the usability of the term order matrix: the
 % top elements of each column must be positive. This
 % approach goes back to a recommendation of J. Apel.
  begin scalar bad,c,w;
    integer i,j,r;
      r:=length m;
      for i:=1:length car m do
      <>
       >>;
      return not bad end;

symbolic procedure evmatrixcompile m;
  begin scalar w;
    w:= evmatrixcompile1 m;
    putd(car w,'expr,caddr w);
    compiled!-orders!*:=(m.car w).compiled!-orders!*;
    return car w end;

symbolic procedure evmatrixcompile1 m;
  begin scalar c,n,x,w,lvars,code;
     integer ld,p,k;
    for each row in m do k:=max(k,length row);
    lvars:=for i:=1:k collect gensym();
    code:={{'setq,car lvars,
                '(idifference (car e1) (car e2))}};
    ld:=1;
    for each row in m do
    <>;
          % collect the terms of the row sum
        x:=nth(lvars,p);
        if c=-1 then x:={'iminus,x} else
        if c neq 1 then x:={'itimes,c,x};
        w:=if w then {'iplus2,x,w} else x >>;
      >>;
      if not atom w then
      <>;
      code:=append(code,
       {{'cond,{{'iequal,w,0},t},
               {{'igreaterp,w,0},'(return 1)},
               '(t (return -1))}}); >>;
     % common trailor
    code:=append(code,'((return 0)));
    n:=gensym();
    return {n,k,evform {'lambda,'(e1 e2), 'prog.('w.lvars). code}} end;

symbolic procedure evform(u);
  % Let form play on the generated code.
    form1(u,nil,'symbolic);

symbolic procedure torder_compile_form(w,c,m);
  begin scalar n;
     if length w < 3 then rederr "illegal arguments";
     m:=evmatrixinit1(eval form caddr w,nil);
     c:=evmatrixcompile1 m;
     n:=eval form cadr w;
     return
      {'progn,
        {'putd,mkquote n,mkquote 'expr,mkquote caddr c},
        {'setq,'compiled!-orders!*,
             {'cons,{'cons,mkquote m,mkquote n}, 'compiled!-orders!*}},
        {'put,mkquote n,''evcomp,mkquote n},
        {'put,mkquote n,''evlength,cadr c},
        {'flag,mkquote{n},''dipsortmode}, mkquote n} end;

put('torder_compile,'formfn,'torder_compile_form);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/expvec.red0000644000175000017500000001636011526203062024000 0ustar  giovannigiovannimodule expvec;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Specific support for distributive polynomial exponent vectors

%  Authors: R. Gebauer, A. C. Hearn, H. Kredel

%   We assume here that an exponent vector is a list of integers.  This
%   version uses small integer arithmetic on the individual exponents
%   and assumes that a compiled function can be dynamically redefined

%   Modification H. Melenk (August 1988)
%   1. Most ev-routines handle exponent vectors with variable length:
%      the convention is, that trailing zeros may be omitted.
%   2. evcompless!? is mapped to evcomp such that each term order mode
%      is supported by exactly one procedure entry.
%   3. complete exponent vector compare collected in separate module
%      TORDER (TORD33)

symbolic procedure evperm (e1,n);
%   Exponent vector permutation. e1 is an exponent vector, n is a
%    index list , a list of digits. evperm(e1,n) returns a list e1
%    permuted in respect to n.
     if null n then nil
        else evnth(e1, car n) . evperm(e1, cdr n);

symbolic procedure evcons (e1,e2);
%    Exponent vector construct. e1 and e2 are exponents. evcons(e1,e2)
%    constructs an exponent vector.
     e1 . e2;

symbolic procedure evnth (e1,n);
%    Exponent vector n-th element. e1 is an exponent vector, n is a
%    digit. evnth(e1,n) returns the n-th element of e1, an exponent.
     if null e1 then 0 else
     if n = 1 then evfirst e1 else evnth(evred e1, n - 1);

symbolic procedure evred e1;
%    Exponent vector reductum. e1 is an exponent vector. evred(e1)
%    returns the reductum of the exponent vector e1.
     if e1 then cdr e1 else NIL;

symbolic procedure evfirst e1;
%    Exponent vector first. e1 is an exponent vector. evfirst(e1)
%   returns the first element of the exponent vector e1, an exponent.
     if e1 then car e1 else 0;

symbolic procedure evsum0(n,p);
% exponent vector sum version 0. n is the length of dipvars!*.
% p is a distributive polynomial.
  if dipzero!? p then evzero1 n else
  evsum(dipevlmon p, evsum0(n,dipmred p));

symbolic procedure evzero1 n;
% Returns the exponent vector power representation
% of length n for a zero power.
  begin scalar x;
   for i:=1:n do <>;
  return x
  end;

symbolic procedure indexcpl(ev,n);
% returns a list of indexes of non zero exponents.
  if null ev then ev else(if car ev = 0 then
                            indexcpl(cdr ev,n + 1) else
    (n . indexcpl(cdr ev,n + 1)));

symbolic procedure evzer1!? e;
% returns a boolean expression. true if e is null else false.
  null e;

symbolic procedure evzero!? e;
%   Returns a boolean expression. True if all exponents are zero
   null e or car e = 0 and evzero!? cdr e;

symbolic procedure evzero;
%   Returns the exponent vector representation for a zero power
% for i:=1:length dipvars!* collect 0;
   begin scalar x;
      for i:=1:length dipvars!* do <>;
      return x end;

symbolic procedure mkexpvec u;
%   Returns an exponent vector with a 1 in the u place
   if not(u member dipvars!*) then typerr(u,"dipoly variable")
    else for each x in dipvars!* collect if x eq u then 1 else 0;

symbolic procedure evlcm (e1,e2);
%    Exponent vector least common multiple. e1 and e2 are
%    exponent vectors. evlcm(e1,e2) computes the least common
%    multiple of the exponent vectors e1 and e2, and returns
%    an exponent vector.
   % for each lpart in e1 each rpart in e2 collect
   %     if lpart #> rpart then lpart else rpart;
   begin scalar x;
      while e1 and e2 do
         < car e2 then car e1 else car e2) . x;
           e1:=cdr e1;e2:=cdr e2>>;
      return reversip x
   end;

symbolic procedure evmtest!? (e1,e2);
%    Exponent vector multiple test. e1 and e2 are compatible exponent
%    vectors. evmtest!?(e1,e2) returns a boolean expression.
%    True if exponent vector e1 is a multiple of exponent
%    vector e2, else false.
   if e1 and e2 then not(car e1 #< car e2) and evmtest!?(cdr e1,cdr e2)
   else  evzero!? e2;

symbolic procedure evsum (e1,e2);
%    Exponent vector sum. e1 and e2 are exponent vectors.
%    evsum(e1,e2) calculates the sum of the exponent vectors.
%    e1 and e2 componentwise and returns an exponent vector.
   % for each lpart in e1 each rpart in e2 collect lpart #+ rpart;
     begin scalar x;
      while e1 and e2 do
         <>;
      x:= reversip x;
      return if e1 then nconc(x,e1) else
             if e2 then nconc(x,e2) else x;
   end;

symbolic procedure evdif (e1,e2);
%    Exponent vector difference. e1 and e2 are exponent
%    vectors. evdif(e1,e2) calculates the difference of the
%    exponent vectors e1 and e2 componentwise and returns an
%    exponent vector.
   % for each lpart in e1 each rpart in e2 collect lpart #- rpart;
   begin scalar x;
      while e2 do
         < 1 then <>;
           dipevlpri1(cdr e,cdr u,t)>>;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/a2dip.red0000644000175000017500000001131611526203062023501 0ustar  giovannigiovannimodule a2dip;
% Convert an algebraic (prefix) form to distributive polynomial

% Authors: R. Gebauer, A. C. Hearn, H. Kredel

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% Repeat of smacros defined in vdp2dip.

smacro procedure dipfmon(a,e);
   e . a . nil;

smacro procedure vevzero!? u;
   null u or(car u=0 and vevzero!?1 cdr u);

symbolic procedure a2dip u;
%     Converts the algebraic (prefix) form u to a distributive poly.
%     We assume that all variables used have been previously
%     defined in dipvars!*, but a check is also made for this
if atom u then a2dipatom u
    else if not atom car u or not idp car u
     then typerr(car u,"dipoly operator")
       % Handling expt separately because the exponents should
       % not be simplified as domain elements.
    else if car u='expt
     then if vevzero!? car a2dip cadr u and vevzero!? car a2dip caddr u
	    then dipfmon(simp!* u,evzero())
	   else dipfnpow(a2dip cadr u,caddr u)
    else (if x then apply(x,list for each y in cdr u collect a2dip y)
         else a2dipatom u)
          where x=get(car u,'dipfn);

symbolic procedure a2dipatom u;
%   Converts the atom (or kernel) u into a distributive polynomial
if u=0 then dipzero
    else if numberp u or not(u member dipvars!*)
      then dipfmon(a2bc u,evzero())
    else dipfmon(a2bc 1,mkexpvec u);

symbolic procedure dipfnsum u;
%    U is a list of dip expressions. Result is the distributive poly
%    representation for the sum
(<>)where x=car u;

put('plus,'dipfn,'dipfnsum);

symbolic procedure dipfnprod u;
%    U is a list of dip expressions. Result is the distributive poly
%    representation for the product
%    Maybe we should check for a zero
(<>)where x=car u;

put('times,'dipfn,'dipfnprod);

symbolic procedure dipfndif u;
%    U is a list of two dip expressions. Result is the distributive
%    polynomial representation for the difference
dipsum(car u,dipneg cadr u);

put('difference,'dipfn,'dipfndif);

symbolic procedure dipfnpow(v,n);
%  V is a dip. Result is the distributive poly v**n.
(if not fixp n or n<0
     then typerr(n,"distributive polynomial exponent")
    else if n=0 then if dipzero!? v then rerror(dipoly,1,"0**0 invalid")
                  else w
    else if dipzero!? v or n=1 then v
    else if dipzero!? dipmred v
     then dipfmon(bcpow(diplbc v,n),intevprod(n,dipevlmon v))
    else <0 do
         <0 then v:=dipprod(v,v)>>;
         w>>)
    where w:=dipfmon(a2bc 1,evzero());

% put('expt,'dipfn,'dipfnpow);

symbolic procedure dipfnneg u;
%    U is a list of one dip expression. Result is the distributive
%    polynomial representation for the negative
(if dipzero!? v then v
    else dipmoncomp(bcneg diplbc v,dipevlmon v,dipmred v))
    where v=car u;

put('minus,'dipfn,'dipfnneg);

symbolic procedure dipfnquot u;
%    U is a list of two dip expressions. Result is the distributive
%    polynomial representation for the quotient
if dipzero!? cadr u or not dipzero!? dipmred cadr u
       or not evzero!? dipevlmon cadr u
       or (!*vdpinteger and not bcone!? diplbc cadr u)
      then typerr(dip2a cadr u,"distributive polynomial denominator")
    else dipfnquot1(car u,diplbc cadr u);

symbolic procedure dipfnquot1(u,v);
if dipzero!? u then u
    else dipmoncomp(bcquot(diplbc u,v),
                dipevlmon u,
                dipfnquot1(dipmred u,v));

put('quotient,'dipfn,'dipfnquot);

endmodule;;end ;
mathpiper-0.81f+svn4469+dfsg3/src/packages/dipoly/vdp2dip.red0000644000175000017500000007572211526203062024065 0ustar  giovannigiovannimodule vdp2dip;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% interface for Virtual Distributive Polynomials(VDP)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% "Distributive representation" with respect to a given set of
% variables(" vdpvars ")means for a polynomial, that the polynomial
% is regarded as  a sequence of monomials, each of which is a
% product of a " coefficient " and of some powers of the variables.
% This internal representation is very closely connected to the
% standard external(printed)representation of a polynomial in
% REDUCE if nothing is factored out. The monomials are logically
% ordered by a term order mode based on the ordering which is
% given bye the sequence " vdpvars ";with respect to this ordering
% the representation of a polynomial is unique. The " highest " term
% is the car one. Monomials are represented by their coefficient
%(" vbc ")and by a vector of the exponents(" vev ")(in the order
% corresponding to the vector vars). The distributive representation
% is good for those algorithms,which base their decisions on the
% complete ledading monomial: this representation guarantees a
% fast and uniform access to the car monomial and to the reductum
%(the cdr of the polynomial beginning with the cadr monomial).
% The algorithms of the Groebner package are of this type. The
% interface defines the distributive polynomials as abstract data
% objects via their acess functions. These functions map the
% distributive operations to an arbitrary real data structure
%(" virtual "). The mapping of the access functions to an actual
% data structure is restricted only by the demand,that the typical
% " distributive operations " be efficient. Additionally to the
% algebraic value a VDP object has a property list. So the algorithms
% using the VDP interface can assign name - value - pairs to individual
% polynomials. The interface is defined by a set of routines which
% create and handle the distributive polynomials. In general the
% first letters of the routine name classifies the data its works on:
%
%   vdp...      complete virtual polynomial objects
%   vbc...      virtual base coefficients
%   vev...      virtual exponent vectors
%
% 0. general control
%
%   vdpinit(dv)initialises the vdp package for the variables
%              given in the list 'dv'. vdpinit modifies the
%              torder and returns the prvevious torder as its
%              result. 'vdpinit' sets the global variable
%              'vdpvars!*'.
%
% 1. Conversion
%
%   a2vdp      Algebraic(prefix)to vdp.
%   f2vdp      Standard form to vdp.
%   a2vbc      Algebraic(prefix)to vbc.
%   vdp2a      Vdp to algebraic(prefix).
%   vdp2f      Vdp to standard form.
%   vbc2a      Vbc to algebraic(prefix).
%
% 2. Composing/decomposing
%
%   vdpfmon    Make a vdp from a vbc and an vev.
%   vdpmoncomp Add a monomial(vbc and vev)to the front of a vdp.
%   vdpappendmon Add a monomial(vbc and vev)to the bottom of a vdp.
%   vdpmonadd  Add a monomial(vbc and vev)to a vdp,not yet
%              knowing the place of the insertiona.
%   vdpappendvdp Concat two vdps.
%
%   vdplbc     Extract leading vbc.
%   vdpevlmon  Extract leading vev.
%   vdpred     Reductum of vdp.
%   vdplastmon Last monomial of polynomial.
%   vevnth     Nth element from exponent vector.
%
% 3. Testing
%
%   vdpzero?    Test vdp = 0.
%   vdpredzero!? Test rductum of vdp = 0.
%   vdpone?     Test vdp = 1.
%   vevzero?    Test vev =(0 0 ... 0).
%   vbczero?    Test vbc = 0.
%   vbcminus?   Test vbc <= 0(not decidable for algebraic vbcs).
%   vbcplus?    Test vbc >= 0(not decidable for algebraic vbcs).
%   vbcone!?    Test vbc = 1.
%   vbcnumberp  Test vbc is a numeric value.
%   vevdivides? Test if vev1 < vev2 elementwise.
%   vevlcompless?  Test ordering vev1 < vev2.
%   vdpvevlcomp    Calculate ordering vev1 / vev1 : -1, 0 or +1.
%   vdpequal   Test vdp1 = vdp2.
%   vdpmember  Member based on " vdpequal ".
%   vevequal   Test vev1 = vev2.
%
% 4. Arithmetic
%
% 4.1 Vdp arithmetic
%
%  vdpsum       vdp + vdp
%               Special routines for monomials : see above(2.).
%  vdpdif       vdp - vdp.
%  vdpprod      vdp * vdp.
%  vdpvbcprod   vbc * vdp.
%  vdpdivmon    vdp /(vbc,vev) divisability presumed.
%  vdpcancelvev Substitute all multiples of monomial(1,vev)in vdp by 0.
%  vdlLcomb1    vdp1 *(vbc1,vev1)+ vdp2 *(vbc2,vev2).
%  vdpcontent   Calculate gcd over all vbcs.
%
% 4.2 Vbc arithmetic
%
%  vbcsum       vbc1 + vbc2.
%  vbcdif       vbc1 - vbc2.
%  vbcneg       - vbc.
%  vbcprod      vbc1 * vbc2.
%  vbcquot      vbc1 / vbc2     Divisability assumed if domain = ring.
%  vbcinv       1 / vbc         Only usable in field.
%  vbcgcd       gcd(vbc1,vbc2)  Only usable in Euclidean field.
%
% 4.2 Vev arithmetic
%
% vevsum        vev1 + vev2 Elementwise.
% vevdif        vev1 - vev2 Elementwise.
% vevtdeg       Sum over all exponents.
% vevzero       Generate a zero vev.
%
% 5. Auxiliary
%
% vdpputprop   Assign indicator - value - pair to vdp.
%              The property " number " is used for printing.
% vdpgetprop   Read value of indicator from vdp.
% vdplsort     Sort list of polynomials with respect to ordering.
% vdplsortin   Sort a vdp into a sorted list of vdps.
% vdpprint     Print a vdp together with its number.
% vdpprin2t    Print a vdp " naked ".
% vdpprin3t    Print a vdp with closing ";".
% vdpcondense  Replace exponent vectors by equal objects from
%              global list dipevlist!* in order to save memory.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% RECORD STRUCTURE
%
% A virtual polynomial here is a record(list) with the entries
%  ('vdp < vdpevlmon > < vdplbc > < form > < plist >)
%
%    ' vdp        A type tag;
%     < vdpevlmon > the exponents of the variables in the
%                 leading monomial;the positions correspond to
%                 the positions in vdpvars!*. Trailing zeroes
%                 can be omitted.
%
%     < lcoeff >  The " coefficient " of the leading monomial,which
%                 in general is a standard form.
%
%     < form >    The complete polynomial,e.g. as REDUCE standard form.
%
%     < plist >   An asso list for the properties of the polynomial.
%
% The components should not be manipulated only via the interface
% functions and macros,so that application programs remain
% independent from the internal representation.
% The only general assumption made on < form > is,that the zero
% polynomial is represented as NIL. That is the case e. g. for both,
% REDUCE standard forms and DIPOLYs.
%
% Conventions for the usage:
% -------------------------
%
%    vdpint has to be called prveviously to all vdp calls. The list of
%    vdp paraemters is passed to vdpinit. The value of vdpvars!*
%    and the current torder must remain unmodfied afterwards.
%    usual are simple id's,e.g.
%
% Modifications to vdpvars!* during calculations
% ----------------------------------------------
%
% This mapping of vdp operations to standard forms offers the
% ability to enlarge vdpvars during the calculation in order
% to add new(intermediate)variables. Basis is the convention,
% that exponent vectors logically have an arbitrary number
% of trailing zeros. All routines processing exponent vectors
% are able to handle varying length of exponent vectors.
% A new call to vdpinit is necessary.
%
% During calculation vdpvars may be enlarged(new variables
% suffixed)without needs to modify existing polynomials;only
% korder has to be set to the new variable sequence.
% modifications to the sequence in vdpvars requires a
% new call to vdpinit  and a reordering of exisiting
% polynomials,e.g. by
%          vdpint newvdpvars;
%          f2vdp vdp2f p1;f2vdp vdp2f p2;.....

% Modification 14.9.2004:
% ----------------------
% Test parmeter expresssions (including the parameters of the coefficient
% functions) for the non-occurrence of groebner variables.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% DECLARATION SECTION
%
%  This module must be present during code generation for modules
%  using the vdp - sf interface.

global '(vdpprintmax groebmonfac);

flag('(vdpprintmax),'share);

% Basic internal constructor of vdp-record:

smacro procedure makevdp(vbc,vev,form);
 {'vdp,vev,vbc,form,nil};

% Basic selectors(conversions):

smacro procedure vdppoly u;cadr cddr u;

smacro procedure vdplbc u;caddr u;

smacro procedure vdpevlmon u;cadr u;

% Basic tests:

smacro procedure vdpzero!? u;null u or null vdppoly u;

smacro procedure vevzero!? u;
 null u or(car u=0 and vevzero!?1 cdr u);

smacro procedure vdpone!? p;
 not vdpzero!? p and vevzero!? vdpevlmon p;

% Manipulating of exponent vectors.

smacro procedure vevdivides!?(vev1,vev2);vevmtest!?(vev2,vev1);

smacro procedure vevzero();vevmaptozero1(vdpvars!*,nil);

smacro procedure vdpnumber f;vdpgetprop(f,'number);

% The code for checkpointing is factored out.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Interface for DIPOLY polynomials as records(objects).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

flag('(vdpprintmax),'share);

symbolic procedure dip2vdp u;
 % Is used when u can be empty.
 (if dipzero!? uu then makevdp(a2bc 0,nil,nil)
                    else makevdp(diplbc uu,dipevlmon uu,uu))
           where uu=if !*groebsubs then dipsubs2 u else u;

% Some simple mappings:

smacro procedure makedipzero();nil;

symbolic procedure vdpredzero!? u;dipzero!? dipmred vdppoly u;

symbolic procedure vdplastmon u;
 % Return bc. ev of last monomial of u.
  begin u:=vdppoly u;
    if dipzero!? u then return nil;
    while not dipzero!? u and not dipzero!? dipmred u do u:=dipmred u;
    return diplbc u.dipevlmon u end;

symbolic procedure vbczero!? u;bczero!? u;

symbolic procedure vbcnumber u;
 if pairp u and numberp car u and 1=cdr u then cdr u else nil;

symbolic procedure vbcfi u;bcfd u;

symbolic procedure a2vbc u;a2bc u;

symbolic procedure vbcquot(u,v);bcquot(u,v);

symbolic procedure vbcneg u;bcneg u;

symbolic procedure vbcabs u;if vbcminus!? u then bcneg u else u;

symbolic procedure vbcone!? u;bcone!? u;

symbolic procedure vbcprod(u,v);bcprod(u,v);

% Initializing vdp - dip polynomial package.
symbolic procedure vdpinit2 vars;
 begin scalar oldorder;vdpcleanup();
  oldorder:=kord!*;
  if null vars then rerror(dipoly,8,"vdpinit: vdpvars not set");
  vdpvars!*:=dipvars!*:=vars;torder2 vdpsortmode!*;
  return oldorder end;

symbolic procedure vdpcleanup();dipevlist!*:={nil};

symbolic procedure vdpred u;
 begin scalar r,s;r:=dipmred vdppoly u;
  if dipzero!? r then return makevdp(nil ./ nil,nil,makedipzero());
  r:=makevdp(diplbc r,dipevlmon r,r);
  if !*gsugar and(s:=vdpgetprop(u,'sugar))then gsetsugar(r,s);
  return r end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Coefficient handling;here we assume that coefficients are
%  standard quotients.
%

symbolic procedure vbcgcd(u,v);
begin scalar x;
 if not vbcsize(u,-100)or not vbcsize(v,-100)
  then return '(1 . 1);
  x:=if denr u=1 and denr v=1 then
   if fixp numr u and fixp numr v then gcdn(numr u,numr v) ./ 1
            else gcdf!*(numr u,numr v)./ 1
    else 1 ./ 1;
  return x end;

symbolic procedure vbcsize(u,n);
 if n #> -1 then nil
  else if atom u then n
  else begin n:=vbcsize(car u,n #+ 1);
  if null n then return nil;return vbcsize(cdr u,n)end;

% Cofactors: compute(q,v)such that q*a=v*b.

symbolic procedure vbc!-cofac(bc1,bc2);
% Compute base coefficient cofactors.
<>
  where gcd=vbcgcd(bc1,bc2);

symbolic procedure vev!-cofac(ev1,ev2);
% Compute exponent vector cofactors.
(vevdif(lcm,ev1).vevdif(lcm,ev2))
 where lcm=vevlcm(ev1,ev2);

% The following functions must be redefinable.

symbolic procedure vbcplus!? u;(numberp v and v > 0)where v=numr u;

symbolic procedure bcplus!? u;(numberp v and v > 0)where v=numr u;

symbolic procedure vbcminus!? u;(numberp v and v < 0)where v=numr u;

symbolic procedure vbcinv u;bcinv u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Conversion between forms, vdps and prefix expressions.
%

% Prefix to vdp.
symbolic procedure a2vdp u;
 if u=0 or null u then makevdp(nil./1,nil,makedipzero())
  else(makevdp(diplbc r,dipevlmon r,r)where r=a2dip u);

% Vdp to prefix.
symbolic procedure vdp2a u;dip2a vdppoly u;

symbolic procedure vbc2a u;bc2a u;

% Form to vdp.
symbolic procedure f2vdp u;
 if u=0 or null u then makevdp(nil./1,nil,makedipzero())
  else(makevdp(diplbc r,dipevlmon r,r)where r=f2dip u);

% Vdp to form.
symbolic procedure vdp2f u;dip2f vdppoly u;

% Vdp from monomial.
symbolic procedure vdpfmon(coef,vev);
 begin scalar r;r:=makevdp(coef,vev,dipfmon(coef,vev));
  if !*gsugar then gsetsugar(r,vevtdeg vev);return r end;

% Add a monomial to a vdp in front(new vev and coeff).
symbolic procedure vdpmoncomp(coef,vev,vdp);
 if vdpzero!? vdp then vdpfmon(coef,vev)
  else if vbczero!? coef then vdp
  else makevdp(coef,vev,dipmoncomp(coef,vev,vdppoly vdp));

% Add a monomial to the end of a vdp(vev remains unchanged).
symbolic procedure vdpappendmon(vdp,coef,vev);
 if vdpzero!? vdp then vdpfmon(coef,vev)
  else if vbczero!? coef then vdp
  else makevdp(vdplbc vdp,vdpevlmon vdp,dipsum(vdppoly vdp,dipfmon(coef,vev)));

% Add monomial to vdp;place of new monomial still unknown.
symbolic procedure vdpmonadd(coef,vev,vdp);
 if vdpzero!? vdp then vdpfmon(coef,vev)else
(if c=1 then vdpmoncomp(coef,vev,vdp)else
  if c=-1 then makevdp(vdplbc vdp,vdpevlmon vdp,
                               dipsum(vdppoly vdp,dipfmon(coef,vev)))
  else vdpsum(vdp,vdpfmon(coef,vev))
)where c=vevcomp(vev,vdpevlmon vdp);

symbolic procedure vdpzero();a2vdp 0;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Comparing of exponent vectors:
%

symbolic procedure vdpvevlcomp(p1,p2);dipevlcomp(vdppoly p1,vdppoly p2);

symbolic procedure vevilcompless!?(e1,e2);1=evilcomp(e2,e1);

symbolic procedure vevilcomp(e1,e2);evilcomp(e1,e2);

symbolic procedure vevcompless!?(e1,e2);1=evcomp(e2,e1);

symbolic procedure vevcomp(e1,e2);evcomp(e1,e2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Routines traversing the " coefficients ";
%
% CONTENT of a vdp:
% The content is the gcd of all coefficients.

symbolic procedure vdpcontent d;
 if vdpzero!? d then a2bc 0 else
 <>;

symbolic procedure vdpcontent1(d,c);dipnumcontent(vdppoly d,c);

symbolic procedure dipnumcontent(d,c);
 if bcone!? c or dipzero!? d then c
  else dipnumcontent(dipmred d,vbcgcd(c,diplbc d));

symbolic procedure dipcontenti p;
% The content is a pair of the lcm of the coefficients and the
% exponent list of the common monomial factor.
 if dipzero!? p then 1 else
(if dipzero!? rp then diplbc p.
 (if !*groebrm then dipevlmon p else nil)
   else dipcontenti1(diplbc p, if !*groebrm then dipevlmon p else nil,rp))
     where rp=dipmred p;

symbolic procedure dipcontenti1(n,ev,p1);
 if dipzero!? p1 then n.ev
  else begin scalar nn;nn:=vbcgcd(n,diplbc p1);
 if ev then ev:=dipcontevmin(dipevlmon p1,ev);
 if bcone!? nn and null ev then return nn.nil
  else return dipcontenti1(nn,ev,dipmred p1)end;

% CONTENT and MONFAC(if groebrm is on).
symbolic procedure vdpcontenti d;
 vdpcontent d.if !*groebrm then vdpmonfac d else nil;

symbolic procedure vdpmonfac d;dipmonfac vdppoly d;

symbolic procedure dipmonfac p;
% Exponent list of the common monomial factor.
 if dipzero!? p or not !*groebrm then evzero()
  else(if dipzero!? rp then dipevlmon p
  else dipmonfac1(dipevlmon p,rp))where rp=dipmred p;

symbolic procedure dipmonfac1(ev,p1);
 if dipzero!? p1 or evzero!? ev then ev
  else dipmonfac1(dipcontevmin(ev,dipevlmon p1),dipmred p1);

% vdpcoeffcientsfromdomain?
symbolic procedure vdpcoeffcientsfromdomain!? w;
 dipcoeffcientsfromdomain!? vdppoly w;

symbolic procedure dipcoeffcientsfromdomain!? w;
 if dipzero!? w then t else
(if bcdomain!? v then dipcoeffcientsfromdomain!? dipmred w
     else nil)where v=diplbc w;

symbolic procedure vdplength f;diplength vdppoly f;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Polynomial operations:
%             coefficient normalization and reduction of monomial factors.
%

symbolic procedure vdpequal(p1,p2);
 p1 eq p2
 or(n1 and n1=n2   % number comparison is faster most times
 or dipequal(vdppoly p1,vdppoly p2)
  where n1=vdpgetprop(p1,'number),n2=vdpgetprop(p2,'number));

symbolic procedure dipequal(p1,p2);
 if dipzero!? p1 then dipzero!? p2 else if dipzero!? p2 then nil
  else diplbc p1=diplbc p2 and evequal(dipevlmon p1,dipevlmon p2)
   and dipequal(dipmred p1,dipmred p2);

symbolic procedure evequal(e1,e2);
% Test equality with variable length exponent vectors.
 if null e1 and null e2 then t
  else if null e1 then evequal('(0),e2)
  else if null e2 then evequal(e1,'(0))
  else 0=(car e1 #- car e2)and evequal(cdr e1,cdr e2);

symbolic procedure vdplcm p;diplcm vdppoly p;

symbolic procedure vdprectoint(p,q);dip2vdp diprectoint(vdppoly p,q);

symbolic procedure vdpsimpcont(p);
 begin scalar r,q;q:=vdppoly p;
  if dipzero!? q then return p;r:=dipsimpcont q;
  p:=dip2vdp cdr r;% the polynomial
  r:=car r;      % the monomial factor if any
  if not evzero!? r and(dipmred q or evtdeg r>1)
   then vdpputprop(p,'monfac,r);return p end;

symbolic procedure dipsimpcont(p);
 if !*vdpinteger or not !*groebdivide  then dipsimpconti p else dipsimpcontr p;

% Routines for integer coefficient case:
% calculation of contents and dividing all coefficients by it.

symbolic procedure dipsimpconti p;
% Calculate the contents of p and divide all coefficients by it.
 begin scalar co,lco,res,num;
 if dipzero!? p then return nil.p;co:=bcfd 1;
 co:=if !*groebdivide then dipcontenti p
   else if !*groebrm then co.dipmonfac p else co.nil;
 num:=car co;
 if not bcplus!? num then num:=bcneg num;
 if not bcplus!? diplbc p then num:=bcneg num;
 if bcone!? num and cdr co=nil then return nil.p;
 lco:=cdr co;
 if groebmonfac neq 0 then lco:=dipcontlowerev cdr co;
 res:=p;
 if not(bcone!? num and lco=nil)then res:=dipreduceconti(p,num,lco);
 if null cdr co then return nil.res;
 lco:=evdif(cdr co,lco);
 return(if lco and not evzero!? evdif(dipevlmon res,lco)
            then lco else nil).res end;

symbolic procedure vdpreduceconti(p,co,vev);
% Divide polynomial p by monomial from co and vev.
 vdpdivmon(p,co,vev);

% Divide all coefficients of p by cont.

symbolic procedure dipreduceconti(p,co,ev);
 if dipzero!? p then makedipzero()
  else dipmoncomp(bcquot(diplbc p,co),
                    if ev then evdif(dipevlmon p,ev)
                     else dipevlmon p,dipreduceconti(dipmred p,co,ev));

% Routines for rational coefficient case:
% calculation of contents and dividing all coefficients by it

symbolic procedure dipsimpcontr p;
% Calculate the contents of p and divide all coefficients by it.
 begin scalar co,lco,res;
  if dipzero!? p then return nil.p;
  co:=dipcontentr p;
  if bcone!? diplbc p and co=nil then return nil.p;
  lco:=dipcontlowerev co;res:=p;
  if not(bcone!? diplbc p and lco=nil)then
   res:=dipreducecontr(p,bcinv diplbc p,lco);
  return(if co then evdif(co,lco)else nil).res end;

symbolic procedure dipcontentr p;
% The content is the exponent list of the common monomial factor.
(if dipzero!? rp then (if !*groebrm then dipevlmon p else nil)
   else dipcontentr1(if !*groebrm then dipevlmon p else nil,rp))
    where rp=dipmred p;

symbolic procedure dipcontentr1(ev,p1);
 if dipzero!? p1 then ev
  else begin
        if ev then ev:=dipcontevmin(dipevlmon p1,ev);
        if null ev then return nil
         else return dipcontentr1(ev,dipmred p1)end;

% Divide all coefficients of p by cont.

symbolic procedure dipreducecontr(p,co,ev);
 if dipzero!? p then makedipzero()
  else dipmoncomp(bcprod(diplbc p,co),if ev then evdif(dipevlmon p,ev)
                         else dipevlmon p,dipreducecontr(dipmred p,co,ev));

symbolic procedure dipcontevmin(e1,e2);
% Calculates the minimum of two exponents;if one is shorter, trailing
% zeroes are assumed.
% e1 is an exponent vector.e2 is a list of exponents
 begin scalar res;
  while e1 and e2 do
  <>;
  while res and 0=car res do res:=cdr res;
  return reversip res end;

symbolic procedure dipcontlowerev e1;
% Subtract a 1 from those elements of an exponent vector which
% are greater  than 1.
% e1 is a list of exponents,the result is an exponent vector.
 begin scalar res;
  while e1 do
  <>;
   while res and 0=car res do res:=cdr res;
   if res and !*trgroebs then
   <>;
   return reversip res end;

symbolic procedure dipappendmon(dip,bc,ev);append(dip,dipfmon(bc,ev));

smacro procedure dipnconcmon(dip,bc,ev);nconc(dip,dipfmon(bc,ev));

smacro procedure dipappenddip(dip1,dip2);append(dip1,dip2);

smacro procedure dipnconcdip(dip1,dip2);nconc(dip1,dip2);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  Basic polynomial arithmetic:
%

symbolic procedure vdpsum(d1,d2);
 begin scalar r;
  r:=dip2vdp dipsum(vdppoly d1,vdppoly d2);
  if !*gsugar then gsetsugar(r,max(gsugar d1,gsugar d2));return r end;

symbolic procedure vdpdif(d1,d2);
 begin scalar r;
  r:=dip2vdp dipdif(vdppoly d1,vdppoly d2);
  if !*gsugar then gsetsugar(r,max(gsugar d1,gsugar d2));return r end;

symbolic procedure vdpprod(d1,d2);
 begin scalar r;
  r:= dip2vdp dipprod(vdppoly d1,vdppoly d2);
  if !*gsugar then gsetsugar(r,gsugar d1 + gsugar d2);return r end;

% % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
%
%  Linear combination: the Buchberger workhorse.
%
% LCOMB1: calculate mon1 * vdp1 + mon2 * vdp2.

symbolic procedure vdpilcomb1(d1,vbc1,vev1,d2,vbc2,vev2);
 begin scalar r;
  r:=
 dip2vdp dipilcomb1(vdppoly d1,vbc1,vev1,vdppoly d2,vbc2,vev2);
  if !*gsugar then gsetsugar(r,max(gsugar d1 + vevtdeg vev1,
                                   gsugar d2 + vevtdeg vev2));return r end;

symbolic procedure dipilcomb1(p1,bc1,ev1,p2,bc2,ev2);
% Same as dipILcomb, exponent vectors multiplied in already.
begin scalar gcd;
 gcd:=!*gcd;
return
 begin scalar ep1,ep2,sl,res,sum,z1,z2,p1new,p2new,
  lptr,bptr,c,!*gcd;
  !*gcd:=if vbcsize(bc1,-100)and vbcsize(bc2,-100)then gcd;
  z1:=not evzero!? ev1;z2:=not evzero!? ev2;
  p1new:=p2new:=t;
  lptr:=bptr:=res:=makedipzero();
 loop:
  if p1new then
  <>;
   if p2new then
   <>;
    sl:=evcomp(ep1,ep2);
    if sl=1 then
    <>;
       p1:=dipmred p1;p1new:=t;
    >> else if sl=-1 then
     <>;
           p2:=dipmred p2;p2new:=t>>
        else
         <>;
              p1:=dipmred p1;p2:=dipmred p2;p1new:=p2new:=t>>;
        if dipzero!? res then <>;% initial
        goto loop end;end;

symbolic procedure vdpvbcprod(p,a);
(if !*gsugar then gsetsugar(q,gsugar p)else q)
       where q=dip2vdp dipbcprod(vdppoly p,a);

symbolic procedure vdpdivmon(p,c,vev);
(if !*gsugar then gsetsugar(q,gsugar p)else q)
       where q=dip2vdp dipdivmon(vdppoly p,c,vev);

symbolic procedure dipdivmon(p,bc,ev);
% Divides a polynomial by a monomial;
% we are sure that the monomial ev is a factor of p.
 if dipzero!? p then makedipzero()
  else dipmoncomp(bcquot(diplbc p,bc),evdif(dipevlmon p,ev),
                        dipdivmon(dipmred p,bc,ev));

symbolic procedure vdpcancelmvev(p,vev);
(if !*gsugar then gsetsugar(q,gsugar p)else q)
  where q=dip2vdp dipcancelmev(vdppoly p,vev);

symbolic procedure dipcancelmev(f,ev);
% Cancels all monomials in f which are multiples of ev
 dipcancelmev1(f,ev,makedipzero());

symbolic procedure dipcancelmev1(f,ev,res);
 if dipzero!? f then res
  else if evmtest!?(dipevlmon f,ev)then dipcancelmev1(dipmred f,ev,res)
     else dipcancelmev1(dipmred f,ev,
       %                 dipappendmon(res,diplbc f,dipevlmon f));
                         dipnconcmon(res,diplbc f,dipevlmon f));

% Some prehistoric routines needed in resultant operation

symbolic procedure vevsum0(n,p);
% Exponent vector sum version 0 . n is the length of vdpvars!*.
% p is a distributive polynomial.
  if vdpzero!? p then vevzero1 n else vevsum(vdpevlmon p,vevsum0(n,vdpred p));

symbolic procedure vevzero1 n;
% Returns the exponent vector power representation
% of length n for a zero power.
 begin scalar x;for i:=1:n do x:=0 . x;return x end;

symbolic procedure vdpresimp u;
% if domain changes,the coefficients have to be resimped
 dip2vdp dipresimp vdppoly u;

symbolic procedure dipresimp u;
 if null u then nil else
(for each x in u collect
     <>)where toggle = t;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% printing of polynomials
%

symbolic procedure vdpprin2t u;<>;

symbolic procedure vdpprin3t u;<>;

symbolic procedure vdpprint u;<>;

symbolic procedure vdpprin2 u;
 <<(if x then <>;prin2 "):  ">>)
    where x=vdpgetprop(u,'number),s= vdpgetprop(u,'sugar);
   vdpprint1(u,nil,vdpprintmax)>>;

symbolic procedure vdpprint1(u,v,max);vdpprint1x(vdppoly u,v,max);

symbolic procedure vdpprint1x(u,v,max);
% Prints a distributive polynomial in infix form.
% U is a distributive form. V is a flag which is true if a term
% has preceded current form
% max limits the number of terms to be printed
  if dipzero!? u then if null v then dipprin2 0 else nil
    else if max=0 then   % maximum of terms reached
     <>
    else begin scalar bool,w;
       w:=diplbc u;
       if bcminus!? w then<>;
       if bool then dipprin2 " - " else if v then dipprin2 " + ";
      (if not bcone!? w or evzero!? x then<>
         else dipevlpri(x,nil))
           where x=dipevlmon u;
       vdpprint1x(dipmred u,t,max - 1)end;

symbolic procedure dipprin2 u;<69 then terprit 2;prin2 u>>;

symbolic procedure vdpsave u;u;

% switching between term order modes

symbolic procedure torder2 u;dipsortingmode u;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% additional conversion utilities

% conversion dip to standard form / standard quotient

symbolic procedure dip2f u;
(if denr v neq 1 then
  <>
       else numr v) where v=dip2sq u;

symbolic procedure dip2sq u;
% Convert a dip into a standard quotient.
 if dipzero!? u then nil ./ 1
  else addsq(diplmon2sq(diplbc u,dipevlmon u), dip2sq dipmred u);

symbolic procedure diplmon2sq(bc,ev);
% Convert a monomial into a standard quotient.
 multsq(bc,dipev2f(ev,dipvars!*)./ 1);

symbolic procedure dipev2f(ev,vars);
 if null ev then 1
  else if car ev=0 then dipev2f(cdr ev,cdr vars)
     else multf(car vars .** car ev .* 1 .+ nil,dipev2f(cdr ev,cdr vars));

% evaluate SUBS2 for the coefficients of a dip

symbolic procedure dipsubs2 u;
 begin scalar v,secondvalue!*;
  secondvalue!*:=1 ./ 1;v:=dipsubs21 u;
  return diprectoint(v,secondvalue!*)end;

symbolic procedure dipsubs21 u;
 if dipzero!? u then u else
 begin scalar c;c:=groebsubs2 diplbc u;
  if null numr c then return dipsubs21 dipmred u;
  if not(denr c=1)then secondvalue!*:=bclcmd(c,secondvalue!*);
  return dipmoncomp(c,dipevlmon u,dipsubs21 dipmred u)end;

% conversion standard form to dip

symbolic procedure f2dip u;f2dip1(u,evzero(),bcfd 1);

symbolic procedure f2dip1(u,ev,bc);
% f to dip conversion : scan the standard form. ev
% and bc are the exponent and coefficient parts collected
% so far from higher parts.
 if null u then nil
  else if domainp u then<>
  else dipsum(f2dip2(mvar u,ldeg u,lc u,ev,bc),f2dip1(red u,ev,bc));

symbolic procedure f2dip11 b;
% Test, if the function names and the parameters of coefficient
% functions are free of Groebner variables.
 !*notestparameters or
 <>;

symbolic procedure rlispmain;
  begin scalar l;
    rlispscantable!* := mkvect 128;
    l := '(17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11
           11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11
           11 11 13 11 11 11 20 11 00 01 02 03 04 05 06 07 08 09 13 11
           13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10
           10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10
           10 10 10 11 11 11 11 11 rlispdipthong);
    for i:=0:128 do <>;
    currentreadmacroindicator!* := 'rlispreadmacro;
    currentscantable!* := rlispscantable!*;
    errout!* := 1;  % Errors to standard output, not special stream;
    lispeval '(begin);
    currentscantable!* := lispscantable!*; % But Slisp should use same
                                           % syntax as RLISP?
    standardlisp()
  end;

copyd('rdf,'dskin);       % CSL has a nicer name for this.

flag('(dskin rdf savesystem reclaim),'opfn);

flag('(dskin rdf savesystem),'noval);

% The following two statements are commented out to encourage algebraic
% mode users to use load_package and thus pick up any patches installed.

% flag('(load reload),'noform);

% deflist('((load rlis) (reload rlis)),'stat);

flag('(tr trst untr untrst),'noform);

deflist('((tr rlis) (trst rlis) (untr rlis) (untrst rlis)),'stat);

% Allow for direct calls to some UNIX and PSL functions.

flag('(pwd cd setenv getenv set!-heap!-size set!-bndstk!-size
       set_heap_size set_bndstk_size),'opfn);

if getd 'set!-heap!-size then copyd('set_heap_size,'set!-heap!-size);
if getd 'set!-bndstk!-size
  then copyd('set_bndstk_size,'set!-bndstk!-size);


% The following is PSL 3.4 specific.

switch fulltrace;   % Prevents node renaming in trace output.

!*fulltrace := t;   % Since we usually want it this way.

Comment The global variable ESC* is used by the interactive string
editor (defined in CEDIT) as a terminator for input strings.  In PSL
we use the escape character;

esc!* := intern int2id 27;


% The following are compiler switches.

fluid '(!*pgwd !*plap !*pwrds !*pcmac);

flag('(pgwd plap pwrds pcmac),'switch);


Comment The following declarations are needed to build various modules;

flag('(fl2int),'lose);                  % Used in MATH.

flag('(nth pnth spaces subla),'lose);   % Used in ALG1.

flag('(explode2 explode21),'lose);      % Used in RPRINT.

flag('(flag1 remflag1),'lose);          % Used in RCREF.

flag('(vector2list),'lose);             % Used in HILBERTS.

flag('(lconc tconc adjoin list2set deliqp1 deliqp),'lose);
                                        % Used in ASSIST.

deflist('((imports rlis)),'stat);   % Needed for ~imports to work.

% if null getd 'concat2 then <>;
   % In case this file loaded more than once.

symbolic procedure concat2(u,v); concat(u,v);

% Used by patching mechanism.

symbolic procedure dated!-gensym u; gensym();

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/autopatch.red0000644000175000017500000001254111526203062024707 0ustar  giovannigiovannimodule autopatch; % Fetch and update patches fasl file.

% Author: Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn.

% February 2011 - with the Sourceforge release the patch scheme that was
% very useful in earlier times is no longer as valuable, and so to avoid
% confusion is being retired.   Arthur Norman

% fluid '(!*home lispsystem!*);
%
% global '(patch!-url!-list!* personal!-dir!*);
%
% symbolic procedure add!_patch!_url u;
%   patch!-url!-list!* := u . patch!-url!-list!*;
%
% add!_patch!_url "http://reduce-algebra.com/support/patches/patches.fsl";
%
% symbolic procedure get!-checksum file;
%    begin scalar file1; integer c,checksum;
%       if not filep file then return nil;
%       file1 := binopen(file,'input);
%       for i := 1:16 do <>;
%       return checksum
%    end;
%
% symbolic procedure
%       write!-patch!-file(dir,checksum,remote!-file,remote!-checksum);
%    begin scalar p,w; integer c;
%       % Read rest of remote file.
%       while (c := readb remote!-file) neq !$eof!$ do p := c . p;
%       close remote!-file;
%       % Transcribe remote file data into a string.
%       w := make!-simple!-string length p;
%       c := -1;
%       for each x in reversip p do putv!-char(w,c := c + 1,x);
%       % Check checksum of data as fetched.
%       if md5 w neq remote!-checksum
%         then rederr "Checksum on fetched patches is incorrect";
%       % Write out updated file.
%       p := concat(dir,"/patches.fsl");
%       if filep p then rename!-file(p,concat(dir,"/patches.old"));
%       binary_open_output p;
%       for each x in reversip checksum do binary_prinbyte x;
%       for i := 0:upbv w do binary_prinbyte scharn(w,i);
%       binary_close_output()
%    end;
%
% symbolic procedure rename!-home!-patch!-file;
%    (filep x and rename!-file(x,concat(personal!-dir!*,"/patches.old")))
%       where x = concat(personal!-dir!*,"/patches.fsl");
%
% symbolic procedure update!_reduce;
%    begin scalar c,lisp!-d,p,remote,w; integer remote!-checksum;
%       if memq('demo, lispsystem!*)
%         then rederr "Update service not available in demo version";
%       lisp!-d := get!-lisp!-directory();
%    % Find a site with the updates.
%       w := patch!-url!-list!*;
%       while null remote and w do <>;
%       if null remote
%         then <>;
%          return nil>>;
%    % Fetch 16 bytes of checksum from the start of update file.
%       for i := 1:16 do <>;
%    % Install updated file if needed.
%       if !*home
%         then <>;
%                write!-patch!-file(personal!-dir!*,p,remote,remote!-checksum)>>
%        else if remote!-checksum =
%              get!-checksum concat(lisp!-d,"/patches.fsl")
%         then <>
%        else if not file!-writeablep lisp!-d
%         then rederr list("Cannot write to",lisp!-d)
%        else <>;
%    % Load new patch file;
%     load!-patches!-file()
%   end;
%
% flag('(update!_reduce),'opfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/fastmod.red0000644000175000017500000001337111526203062024356 0ustar  giovannigiovannimodule fastmod; % fast computation with modular numbers.

% Author: Herbert Melenk .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%
%    ( a * b ) mod current!-modulus
%
% in one call with double length intermediate result, avoiding
% conversion to bignums. Significant speedup for e.g. factorizer.

remflag('(modular!-times general!-modular!-times),'lose);

compiletime
<<
  if memq('nbig30a,options!*) or
     memq('nbig0,options!*) then load muls else load muls32;
  slow_wquotientdouble := memq('mips,lispsystem!*) or
                          memq('ultrasparc,lispsystem!*);
>>;

fluid '(!*second!-value!* current!-modulus);

remflag('(modular!-times general!-modular!-times),'lose);

% Routines from smallmod.red and genmod.red

compiletime if slow_wquotientdouble then
     flag('(modular!-times),'lose);

symbolic procedure modular!-times(a,b);
   begin scalar q;
    q:=wtimesdouble(a,b); % upper part in second value.
    wquotientdouble(!*second!-value!*,q,current!-modulus);
                          % remainder in second value.
    return !*second!-value!*;
   end;

compiletime if slow_wquotientdouble then
     remflag('(modular!-times),'lose)
       else
     flag('(modular!-times),'lose);

symbolic procedure modular!-times(a,b);
 % for systems where single divide is substantially faster than
 % double divide.
   begin scalar q;
    q:=wtimesdouble(a,b); % upper part in second value.
    if weq(!*second!-value!*,0) and wgreaterp(q,0) then
        return wremainder(q,current!-modulus);
    wquotientdouble(!*second!-value!*,q,current!-modulus);
                          % remainder in second value.
    return !*second!-value!*;
   end;

compiletime if not memq('ultrasparc,lispsystem!*) then
               flag('(modular!-times),'lose);

symbolic procedure modular!-times(a,b);
  begin scalar q;
     q:=times2(a,b);
     return remainder(q,current!-modulus);
  end;

compiletime remflag('(modular!-times),'lose);


symbolic procedure general!-modular!-times(a,b);
  % Use fast function if all operands are inums.
   if weq(0,iplus2(tag a,iplus2(tag b,tag current!-modulus)))
      then modular!-times(a,b) else general!-modular!-times!*(a,b);

symbolic procedure general!-modular!-times!*(a,b);
  begin scalar result;
     result:=remainder(a*b,current!-modulus);
     if result<0
       then result := result+current!-modulus;  %can this happen?
     return result
  end;

flag ('(modular!-times general!-modular!-times),'lose);

% Routines from factor/VECPOLY.red.
% Smallmod arithmetic never allocates heap space such
% that vector base addresses remain valid and subsequent
% vector access can be transformed into index incremental.

remflag('(times!-in!-vector remainder!-in!-vector),'lose);

SYMBOLIC PROCEDURE TIMES!-IN!-VECTOR(A,DA,B,DB,C);
% Put the product of A and B into C and return its degree.
% C must not overlap with either A or B;
  BEGIN
    SCALAR DC,IC,W,lc,lb;
    IF ilessp(DA,0) OR ilessp(DB,0) THEN RETURN MINUS!-ONE;
    DC:=iplus2(DA,DB);
    FOR I:=0:DC DO PUTV(C,I,0);
    FOR IA:=0:DA DO <<
      W:=GETV(A,IA);
      lb := loc igetv(b,0);
      lc := loc igetv(c,ia);
      FOR IB:=0:DB DO <<
        IC:=iplus2(IA,IB);

     %  PUTV(C,IC,MODULAR!-PLUS(GETV(C,IC),
     %    MODULAR!-TIMES(W,GETV(B,IB))))

        putmem(lc,MODULAR!-PLUS(getmem lc,
          MODULAR!-TIMES(W,getmem lb)));
        lb := iplus2(lb,addressingunitsperitem);
        lc := iplus2(lc,addressingunitsperitem);

      >> >>;
    RETURN DC
  END;

SYMBOLIC PROCEDURE REMAINDER!-IN!-VECTOR(A,DA,B,DB);
% Overwrite the vector A with the remainder when A is
% divided by B, and return the degree of the result;
  BEGIN
    SCALAR DELTA,DB!-1,RECIP!-LC!-B,W,la,lb;
    IF DB=0 THEN RETURN MINUS!-ONE
    ELSE IF DB=MINUS!-ONE THEN ERRORF "ATTEMPT TO DIVIDE BY ZERO";
    RECIP!-LC!-B:=MODULAR!-MINUS MODULAR!-RECIPROCAL GETV(B,DB);
    DB!-1:=isub1 DB; % Leading coeff of B treated specially, hence this;
    WHILE NOT ilessp(DELTA:=idifference(DA,DB),0) DO <<
      W:=MODULAR!-TIMES(RECIP!-LC!-B,GETV(A,DA));
      la := loc(igetv(a,delta)); lb:= loc(igetv(b,0));
      FOR I:=0:DB!-1 DO

       %PUTV(A,I#+DELTA,MODULAR!-PLUS(GETV(A,I#+DELTA),
       %  MODULAR!-TIMES(GETV(B,I),W)));

       <>;

      DA:=isub1 DA;
      WHILE NOT ilessp(DA,0) AND GETV(A,DA)=0 DO DA:=isub1 DA >>;
    RETURN DA
  END;

flag('(times!-in!-vector remainder!-in!-vector),'lose);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/pslprolo.red0000644000175000017500000000637111526203062024575 0ustar  giovannigiovanni% module pslprolo;   % PSL dependent code for REDUCE.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This file defines functions, variables and declarations needed to
% make REDUCE and the underlying PSL system compatible, and which need
% to be input before the system independent REDUCE source is loaded.

% Support for package creation.

symbolic procedure create!-package(u,v);
   % Make module list u into a package with path v.
   % Second argument is no longer used.
   if null idp car u then typerr(car u,"package name")
    else progn(put(car u,'package,u),
%          put(car u,'path,if null v then list car u else v),
           car u);

% create!-package('(pslprolo),nil);

% Code for resolving aliasing name conflicts.

fluid '(!*quotenewnam);

symbolic procedure define!-alias!-list u;
   begin scalar x;
   a: if null u then return nil;
      x := intern compress append(explode '!~,explode car u);
      put(car u,'newnam,x);
      put(x,'oldnam,car u);
      put(car u,'quotenewnam,x);
      u := cdr u;
      go to a
   end;


% PSL doesn't need PRINTPROMPT.

remflag('(printprompt),'lose);

symbolic procedure printprompt u; nil;

flag('(printprompt),'lose);

flag('(gcdn),'lose);     % Defined in bignum package.

flag('(aconc atsoc copy delasc eqcar geq lastpair leq mkquote neq
       prin2t reversip rplacw putc yesp),'lose);

flag('(rblock foreach lprim repeat while),'user); % permits redefinition

% The following assignment is done this way for bootstrapping.

flag('(set),'eval);

set('!*quotenewnam,nil);

define!-alias!-list
      '(arrayp do for on off let clear flatten imports
        indx mkid mkvec vector editf spaces2 prettyprint);

set('!*quotenewnam,t);

remflag('(set),'eval);


% Resolution of non-local variable definitions.

% The following PSL variables differ from the Standard LISP Report

remprop('!*comp,'vartype);

remprop('!*raise,'vartype);

% The following are not in the Standard LISP Report, but differ from
% usual REDUCE usage.

remprop('cursym!*,'vartype);

% endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/cslprolo.red0000644000175000017500000001073411526203062024556 0ustar  giovannigiovanni% module cslprolo;   % CSL dependent code for REDUCE.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This file defines functions, variables and declarations needed to
% make REDUCE and the underlying CSL system compatible, and which need
% to be input before the system independent REDUCE source is loaded.

% Support for package creation.

symbolic procedure create!-package(u,v);
   % Make module list u into a package with path v.
   % Second argument is no longer used.
   if null idp car u then typerr(car u,"package name")
    else progn(put(car u,'package,u),
%          put(car u,'path,if null v then list car u else v),
           car u);

% create!-package('(cslprolo),nil);

symbolic procedure evload l;
% This is coded out as an explicit loop because it is processed rather
% early in the bootstrap sequence, and the nicer syntax I might prefer
% to use may not be stable...
  begin
top: if null l then return nil;
     load!-module car l;
     l := cdr l;
     go to top
  end;

%
% Well you might wonder... this is in cslprolo.red AND in cslrend.red.
% The reason is that it is needed early if rlisp is to be patchable. It
% is needed AFTER rlisp.red has been loaded because the first time in
% the bootstrap-build that RLISP is loaded no attention is given to LOSE
% properties (this is a REAL misery) so the definition must be put in
% place on top of the incorrect one builty by RLISP the first time
% around.
%

remflag('(copyd), 'lose);

symbolic procedure copyd(new,old);
% Copy the function definition from old id to new.
   begin scalar x;
      x := getd old;
% If loading with !*savedef = '!*savedef then the actual definitions
% do not get loaded, but the source forms do...
      if null x then progn(
        if not (!*savedef = '!*savedef)
          then rerror('rlisp,1,list(old,"has no definition in copyd")) )
      else progn(putd(new,car x,cdr x),
                 if flagp(old, 'lose) then flag(list new, 'lose) );
% The transfer of the saved definition is needed if the REDUCE "patch"
% mechanism is to work fully properly.
      if (x := get(old, '!*savedef)) then put(new, '!*savedef, x);
      return new
   end;

flag('(copyd), 'lose);

% The following are built into CSL and so any definition found within
% the REDUCE sources should be viewed as "portability" but should be ignored.

flag('(atsoc copy eqcar gcdn geq lastpair leq mkquote neq reversip
       rplacw iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp
       idifference iquotient iremainder ilessp igreaterp ileq igeq
       izerop ionep apply1 apply2 apply3 modular!-difference
       modular!-minus modular!-number modular!-plus modular!-quotient
       modular!-reciprocal modular!-times modular!-expt set!-small!-modulus
       acos acosd acosh acot acotd acoth acsc acscd acsch asec asecd
       asech asin asind asinh atan atand atan2 atan2d atanh cbrt cos
       cosd cosh cot cotd coth csc cscd csch exp expt hypot ln log
       logb log10 sec secd sech sin sind sinh sqrt tan tand tanh fix
       ceiling floor round clrhash puthash gethash remhash
       princ!-upcase princ!-downcase union intersection
       safe!-fp!-plus safe!-fp!-times safe!-fp!-quot threevectorp
       sort stable!-sort stable!-sortip lengthc),'lose);


!*argnochk := t;

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/remake.red0000644000175000017500000001340111526203062024157 0ustar  giovannigiovannimodule remake; % Update the fasl loading version and cross-reference of
               % a given file.

% Authors: Martin L. Griss and Anthony C. Hearn.
% Modified by ACN for the Sourceforge version...

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*break
        !*cref
        !*crefchk
        !*faslp
        !*forcecompile
        !*int
        !*loadall
        !*usermode
        !*writingfaslfile
        lispsystem!*);

global '(!*argnochk nolist!* loaded!-modules!*);

symbolic procedure psl!-file!-write!-date u;
   % Returns write date of file u as an integer.
   (if null x then rederr list("file not found:",u)
    else cddr assoc('writetime,x))
   where x = filestatus(u,nil);

symbolic procedure olderfaslp(u,v);
   if 'psl memq lispsystem!*
     then null filep u
        or psl!-file!-write!-date u < psl!-file!-write!-date v
    else if null filedate v then rederr list("Missing file",v)
    else null modulep u or datelessp(modulep u,filedate v);

% Code for updating cross reference information.

nolist!* := append('(module endmodule),nolist!*);

% +++++ The cross-referencing capability probably no longer works.

symbolic procedure update!-cref x;
   % Updates cross-reference for x (module . path).
   begin scalar y,z;
      y := concat2("$rcref/",concat2(mkfil car x,".crf"));
      z := module2!-to!-file(car x,get(cdr x,'path));
      if olderfaslp(y,z) or !*forcecompile
        then <>
%                then errorprintf("***** Error during cref of %w%n",x)>>
   end;

symbolic procedure upd!-cref1(u,v,w);
   begin scalar !*break,!*cref,!*int,!*usermode,ochan,oldochan,oldll;
      lprim list("Cross referencing",u,"...");
%     prin2t bldmsg("*** Cross referencing %w ...",u);
      ochan := open(w,'output);
      oldochan := wrs ochan;
      oldll := linelength 75;
      crefon();   % this is entry point to cref routines
      !*cref := t;
      infile v;
      !*cref := nil;
      crefoff();
      close ochan;
      wrs oldochan;
      linelength oldll
   end;


% Support for packages directory.

symbolic procedure package!-remake x;
   (if y then package!-remake2(x,y) else package!-remake2(x,x))
   where y=get(x,'folder);

symbolic procedure package!-remake2(u,v);
   begin scalar y;
%     if !*crefchk then update!-cref2(u . v);
      update!-fasl2(u . v);
      evload list u;
      loaded!-modules!* := union(loaded!-modules!*, list u);
      y := get(u,'package);
      if y then y := cdr y;
      for each j in y do
         <>
         >>
   end;

symbolic procedure update!-fasl2 x;
   begin scalar y,z;
      if 'psl memq lispsystem!*
        then y := concat2("$fasl/", concat2(mkfil car x, ".b"))
       else y := car x;
      z := module2!-to!-file(car x,cdr x);
      if olderfaslp(y,z) or !*forcecompile
        then <>>>
   end;

symbolic procedure upd!-fasl1(u,v,w);
   % We rebind *fastfor here because it's the only case of "compiletime"
   % at the moment (!).
   begin scalar !*fastfor,!*lower,!*usermode,!*quiet!_faslout,!*break,x;
      !*faslp := t;
      !*quiet!_faslout := t;
      if not('psl memq lispsystem!*) then !*lower := t;
      if !*loadall and w neq u then <<
         evload list w;
         loaded!-modules := union(loaded!-modules!*, list w) >>;
      if x := get(u,'compiletime)
        then <>;
      u := mkfil u;
      lprim list("Compiling",u,"...");
%     prin2t bldmsg("*** Compiling %w ...",u);
      terpri();
      if 'psl memq lispsystem!*
        then lispeval list('faslout, concat2("$fasl/",u))
       else lispeval list('faslout,u);
      infile v;
      lispeval '(faslend)
   end;

symbolic procedure module2!-to!-file(u,v);
   % Converts the module u in package directory v to a fully rooted file
   % name.
   concat2("$reduce/packages/",concat2(mkfil v,
          concat2("/",concat2(mkfil u,".red"))));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/psl.red0000644000175000017500000003375111526203062023523 0ustar  giovannigiovannimodule psl;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


imports big2sys, bigp, floatloworder, floathighorder, gtneg, gtpos,
        i2bf!:, idifference, igetv, ilessp, iminus, inf, iplus, isub1,
        itimes, land, lshift, make!:ibf, neq, sys2int, trimbignum,
        vecinf, veclen, wand, wdifference, wminus, wor, wplus2, wputv,
        wquotient, wshift;

exports ashift, msd!:, fl2bf, integerp!:, normbf, oddintp, preci!:;

fluid '(bbits!*);

global '(bfz!* bitsperword);

compiletime
  global '(!!fleps1exp !!plumaxexp !!pluminexp !!timmaxexp !!timminexp);

remflag ('(ashift msd!: fl2bf ff0 ff1
           bf!-bits bf!-bits!-mask integerp!: normbf oddintp preci!:),
         'lose);

flag('(cond),'eval);   % Enable conditional compilation.

%-------------------------------------------------------------------

% The following routines support fast float operations by exploiting
% the IEEE number format explicitly.

compiletime
 if 'ieee member lispsystem!* then
   remflag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot),'lose)
     else
   flag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot),'lose);

% Currently 32 and 64 bit IEEE machines are supported.
%
% The following macros assume that on 64 bit machines floathighorder
% and floatloworder both load the full 64 bit floating point number.

compiletime
<<
  define!-constant(ieeeshift,12 - bitsperword);  % 32 bits:-20
  define!-constant(signshift,1 - bitsperword);   % 32 bits:-31
  define!-constant(ieeebias,1023);
  define!-constant(ieeemask,2047);
  ds(floathiword,x(),floathighorder inf x);
  ds(floatloword,x(),floatloworder inf x);

  if bitsperword=32 then
  <<
    ds(ieeezerop,u(), weq(0,floathiword u) and weq(0,floatloword u));
    ds(ieeeequal,u(v),
           weq(floathiword u,floathiword v)
       and weq(floatloword u,floatloword v));
    ds(ieeemant,f(),
       (lor(lshift(
               wor(wshift(wand (floathiword f, 1048575), % 16#FFFFF
                          6),
                   wshift(lf,-26)),
               26),
               wand(lshift(-1,-6), lf))
         where lf := floatloword f));
   >>
   else if bitsperword=64 then
   <<
    ds(ieeezerop,u(), weq(0,floathiword u));
    ds(ieeeequal,u(v), weq(floathiword u,floathiword v));
    ds(ieeemant,f(), wand (floathiword f,
                           4503599627370495)); % 16#FFFFFFFFFFFFF
 >>
   else error(99,"#### unknown bit size");

  ds(ieeeexpt,u(),
      wdifference(wand(ieeemask,
                       wshift(floathiword u,ieeeshift)),
                 ieeebias));
  ds(ieeesign,u(),wshift(floathiword u,signshift));
     % ieeemant is the mantissa part of the upper 32 bit group.

  define!-constant(!!plumaxexp,1018);
  define!-constant(!!pluminexp,-979);
  define!-constant(!!timmaxexp,509);
  define!-constant(!!timminexp,-510);
  define!-constant(!!fleps1exp,-40)
>>;

symbolic procedure safe!-fp!-plus(x,y);
   if ieeezerop x then y
    else if ieeezerop y then x
    else begin scalar u,ex,ey,sx,sy;
            ex := ieeeexpt x;
            ey := ieeeexpt y;
            if (sx := ieeesign x) eq (sy := ieeesign y)
              then if ilessp(ex,!!plumaxexp) and ilessp(ey,!!plumaxexp)
                    then go to ret else return nil;
            if ilessp(ex,!!pluminexp) and ilessp(ey,!!pluminexp)
              then return nil;
          ret:
            u := floatplus2(x,y);
        return
            if sx eq sy or ieeezerop u then u
             else if ilessp(ieeeexpt u,iplus2(ex,!!fleps1exp)) then 0.0
             else u
         end;

symbolic procedure safe!-fp!-times(x,y);
   if ieeezerop x or ieeezerop y then 0.0
    else if ieeeequal(x,1.0) then y
    else if ieeeequal(y,1.0) then x
    else begin scalar u,v;
            u := ieeeexpt x;
            v := ieeeexpt y;
            if igreaterp(u,!!timmaxexp)
              then if ilessp(v,0) then go to ret else return nil;
            if igreaterp(u,0)
              then if ilessp(v,!!timmaxexp) then go to ret
                    else return nil;
            if igreaterp(u,!!timminexp)
              then if igreaterp(v,!!timminexp) then go to ret
                    else return nil;
            if ilessp(v,0) then return nil;
          ret:
            return floattimes2(x,y)
         end;

symbolic procedure safe!-fp!-quot(x,y);
   if ieeezerop y then rdqoterr()
    else if ieeezerop x then 0.0
    else if ieeeequal(y,1.0) then x
    else begin scalar u,v;
            u := ieeeexpt x;
            v := ieeeexpt y;
            if igreaterp(u,!!timmaxexp)
              then if igreaterp(v,0) then go to ret
                    else return nil;
            if igreaterp(u,0)
              then if igreaterp(v,!!timminexp) then go to ret
                    else return nil;
            if igreaterp(u,!!timminexp)
              then if ilessp(v,!!timmaxexp) then go to ret
                    else return nil;
            if igreaterp(v,0) then return nil;
          ret:
            return floatquotient(x,y)
         end;

compiletime
 if 'ieee member lispsystem!* then
  flag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot),'lose)
   else
  remflag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot),'lose);

%---------------------------------------------------------------

deflist('((iminus iminus)),'unary);

symbolic smacro procedure ashift (m,d);
  if negintp m then -lshift(-m,d) else lshift(m,d);

symbolic smacro procedure oddintp x;
   wand(if bigp x then wgetv(inf x,2)
         else if fixnp x then fixval inf x
         else x,1) eq 1;

symbolic macro procedure bf!-bits (x); {'quote, bbits!*};

%symbolic macro procedure bf!-bits!-mask (x);
%   {'quote, lshift(1, bf!-bits()) - 1};

%symbolic procedure ff1 (w,n);
%  if n eq 0 then w else
%  if wshift (w, wminus n) eq 0 then
%        ff1 (w,wquotient(n,2))
%    else iplus2(ff1 (wshift (w, wminus n),wquotient(n,2)),n) ;

symbolic smacro procedure ff1 (ww,nn);
  <>;   % Iplus2 etc. used for
      n := wquotient (n,2)                % bootstrapping.
    >>;
    iplus2(y,w) >>
    where w=ww,n=nn,x=nil,y=0;

%symbolic procedure ff0 (w,n);
%%   returns the number of 0 bits at the least significant end
%  if n eq 0 then w else
%   begin scalar lo;
%     lo := wand(w,isub1 wshift(1,n));
%  return if lo eq 0
%           then iplus2(n,ff0 (wshift(w,wminus n),wquotient(n,2)))
%          else ff0 (lo,wquotient(n,2)) ;
%  end;

comment ff0 determines the number of 0 bits at the least significant
        end of an integer, ie. the largest power of two by which the
        integer is divisible;

compiletime put('hu_hu_hu,'opencode,'((!*move (reg 1) (reg 1))));

symbolic smacro procedure ff0 (ww,nn);
  <>;           % Iplus2 etc. used for
      n := wquotient (n,2)                % bootstrapping.
    >>;
    if not eq(w,0) then << w := 17; hu_hu_hu (w); y >> else iadd1 y >>
                    % we have to destroy w for gc !!
    where w=ww,n=nn,lo=nil,y=0;

% use wshift(bitsperword,-1) rather than bitsperword/2 as the former
% is open compiled


comment we split msd!: into two parts: one for bignums, one for
        machine words. That will greatly reduce the size of preci!:
        below;

symbolic smacro procedure word!-msd!: u;
   ff1(u,wshift(bitsperword,-1));

symbolic smacro procedure big!-msd!: u;
   iplus2(itimes2(bf!-bits(),isub1 s),word!-msd!: igetv(u,s))
       where s := veclen vecinf u;

symbolic smacro procedure msd!: u;
   if bigp u then big!-msd!: u
    else if fixnp u then word!-msd!: fixval inf u
    else word!-msd!: u;

%symbolic smacro procedure msd!: u;
%  % returns the most significant (binary) digit of a positive integer u
%  if bigp u
%    then iplus2(itimes2(bf!-bits(),isub1 s),
%                ff1(igetv(u,s),wshift(bitsperword,-1)))
%       where s := veclen vecinf u
%   else if fixnp u then ff1 (fixval inf u,wshift(bitsperword,-1))
%   else ff1 (u,wshift(bitsperword,-1));

symbolic smacro procedure mt!: u; cadr u;
symbolic smacro procedure ep!: u; cddr u;

symbolic smacro procedure preci!: nmbr;
   % This function counts the precision of a number "n". NMBR is a
   % binary bigfloat representation of "n".
   % msd!: abs mt!: nmbr
   (if bigp m then big!-msd!: m
     else if fixnp m
      then (word!-msd!:(if iminusp n then iminus n else n)
                         where n = fixval inf m)
     else if iminusp m then word!-msd!:(iminus m)
     else word!-msd!: m)
    where m = mt!: nmbr;

%symbolic smacro procedure preci!: nmbr;
%   % This function counts the precision of a number "n". NMBR is a
%   % binary bigfloat representation of "n".
%   % msd!: abs mt!: nmbr
%   (if bigp m then msd!: m
%     else if fixnp m
%      then (ff1(if iminusp n then iminus n else n,
%                wshift(bitsperword,-1))
%              where n = fixval inf m)
%     else if iminusp m then ff1(iminus m,wshift(bitsperword,-1))
%     else ff1(m,wshift(bitsperword,-1)))
%    where m = mt!: nmbr;

symbolic smacro procedure make!:ibf (mt, ep);
  '!:rd!: . (mt . ep);

if not('ieee memq lispsystem!*) then
     flag('(fl2bf),'lose);

!#if (eq bitsperword 64)

symbolic procedure fl2bf f;
  % u is a floating point number
  % result is a binary bigfloat
  if fixp f then i2bf!: f
   else begin scalar m,e;
      m := ieeemant f;
      e := ieeeexpt f;
      % if exponent <> -1023 add 16#10000000000000, implicit highest bit
      if e neq  -1023 then m := lor (m, lshift(1,52));
      return
        if izerop m then bfz!*
         else normbf make!:ibf (if ieeesign f eq 1 then -m else m,
                                idifference(e,52))
     end;

!#else

symbolic procedure fl2bf f;
  % u is a floating point number
  % result is a binary bigfloat
  if fixp f then i2bf!: f
   else begin scalar m,e;
      m:=
        lor(lshift(
               wor(wshift(wand (floathiword f, 1048575), % 16#FFFFF
                          6),
                   wshift(floatloword f,-26)),
               26),
            wand(lshift(-1,-6), floatloword f));
      %% m := ieeemant f;
      e := ieeeexpt f;
      % if exponent <> -1023 add 16#10000000000000, implicit highest bit
      if e neq  -1023 then m := lor (m, lshift(1,52));
      return
        if izerop m then bfz!*
         else normbf make!:ibf (if ieeesign f eq 1 then -m else m,
                                idifference(e,52))
     end;

!#endif

symbolic procedure normbf x;
   begin scalar mt,s;integer ep,ep1;
      if (mt := mt!: x)=0 then go to ret;
      if mt<0 then <>;
      ep := ep!: x;
%      ep1 := remainder(ep,bf!-bits());
%      if ep1 < 0 then ep1 := ep1 + bf!-bits();
%      if ep1 neq 0 then <>;
      while bigp mt and wgetv(inf mt,2) eq 0 do <<
        mt := lshift(mt,-bf!-bits());
        ep := ep+bf!-bits() >>;
      ep1 := ff0(if bigp mt then wgetv(inf mt,2)
                  else if fixnp mt then fixval inf mt
                  else mt,wshift(bitsperword,-1));
      if not (ep1 eq 0) then <>;
      if s then mt := -mt;
ret:    return make!:ibf(mt,ep) end;

%symbolic procedure normbf x;
%   begin scalar mt,s;integer ep,ep1;
%      if (mt := mt!: x)=0 then go to ret;
%      if mt<0 then <>;
%      ep := ep!: x;
%      while bigp mt and land(mt,bf!-bits!-mask())=0 do <<
%        mt := lshift(mt,-bf!-bits());
%        ep := ep+bf!-bits() >>;
%      while land(mt,255)=0 do <<
%        mt := lshift(mt,-8);
%        ep := ep+8 >>;
%      while land(mt,1)=0 do <<
%        mt := lshift(mt,-1);
%        ep := ep+1>>;
%%      ep1 := remainder(ep,bf!-bits());
%%      if ep1 < 0 then ep1 := ep1 + bf!-bits();
%%      if ep1 neq 0 then <>;
%      if s then mt := -mt;
%ret:    return make!:ibf(mt,ep) end;

symbolic procedure integerp!: x;
% This function returns T if X is a BINARY BIG-FLOAT
%      representing an integer, else it returns NIL.
% X is any LISP entity.
bfp!: x and
  (ep!: x >= 0 or
    preci!: x > - ep!: x and
      land(abs mt!: x,lshift(2,-ep!: x) - 1) = 0);

flag ('(ashift lshift msd!: fl2bf ff0 ff1
        bf!-bits bf!-bits!-mask integerp!: normbf oddintp preci!:),
      'lose);

if not('ieee memq lispsystem!*) then remflag('(fl2bf),'lose);

% This belong in $pxu/nbig30a.

symbolic(bigfloathi!* :=  (2 ** 53 - 1) * 2 ** 971);

symbolic(bigfloatlow!* := - bigfloathi!*);

remflag('(cond),'eval);



% HP-Risc and IBM RS architectures need special handling of fltinf in
% fastmath.red

if 'HP!-Risc member lispsystem!* then
   <>;

if 'IBMRS member lispsystem!* then
   <>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/csl.red0000644000175000017500000002260211526203062023477 0ustar  giovannigiovannimodule csl;  % Support for fast floating point arithmetic in CSL.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


imports ash, ash1, logand, msd;

exports msd!:;

fluid '(!!nbfpd);

remflag ('(fl2bf msd!: fix2 rndpwr timbf),'lose);

symbolic smacro procedure fix2 u; fix u;

symbolic smacro procedure lshift(m,d); ash(m,d);

symbolic smacro procedure ashift(m,d); ash1(m,d);

symbolic smacro procedure land(a,b); logand(a,b);

symbolic smacro procedure msd!: u; msd u;

symbolic smacro procedure make!:ibf (mt, ep);
  '!:rd!: . (mt . ep);

fluid '(!:bprec!:);

symbolic smacro procedure rndpwr j;
  begin
    scalar !#w;   % I use an odd name here to avoid clashes (smacro)
%   !#w := mt!: j;
    !#w := cadr j;
    if !#w = 0 then return make!:ibf(0, 0);
    !#w := inorm(!#w, !:bprec!:);
%   return make!:ibf(car !#w, cdr !#w + ep!: j)
    return make!:ibf(car !#w, cdr !#w + cddr j)
  end;

% This is introduced as a privately-named function and an associated
% smacro to avoid unwanted interactions between 3 versions of this
% function: the one here, the version of this code compiled into C, and
% the original version in arith.red.  Note thus that CSL_normbf is not
% flagged as 'lose here (but it will be when a version compiled into
% C exists), and the standard version of normbf will still get compiled
% in arith.red, but all references to it will get turned into calls
% to CSL_normbf.  The SMACRO does not need a 'lose flag either.

symbolic procedure CSL_normbf x;
   begin
      scalar mt,s;
      integer ep;
% Note I write out mt!: and ep!: here because the smacros for them are
% not yet available.
      if (mt := cadr x)=0 then return '(!:rd!: 0 . 0);
      if mt<0 then <>;
      ep := lsd mt;
      mt := lshift(mt, -ep);
      if s then mt := -mt;
      ep := ep + cddr x;
      return make!:ibf(mt,ep)
   end;

symbolic smacro procedure normbf x; CSL_normbf x;

symbolic procedure CSL_timbf(u, v);
  begin
     scalar m;
%    m := mt!: u * mt!: v;
     m := cadr u * cadr v;
     if m = 0 then return '(!:rd!: 0 . 0);
     m := inorm(m, !:bprec!:);
%    return make!:ibf(car m, cdr m + ep!: u + ep!: v)
     return make!:ibf(car m, cdr m + cddr u + cddr v)
  end;

symbolic smacro procedure timbf(u, v); CSL_timbf(u, v);

symbolic procedure fl2bf x;
  begin scalar u;
    u := frexp x;
    x := cdr u; % mantissa between 0.5 and 1
    u := car u; % exponent
    x := fix(x*2**!!nbfpd);
    return normbf make!:ibf(x,u-!!nbfpd)
  end;

flag ('(fl2bf msd!: fix2 rndpwr timbf), 'lose);

set!-print!-precision 14;

% The following definition is appropriate for MSDOS, and the value of
% !!maxbflexp should be OK for all IEEE systems. BEWARE if you have a
% computer with non-IEEE arithmetic, and worry a bit about !!flexperr
% (which is hardly ever used anyway...).
% I put this here to avoid having arith.red do a loop that is terminated
% by a floating point exception, since as of Nov 1994 CSL built using
% Watcom C 10.0a can not recover from such errors more than (about) ten
% times in any one run - this avoids that during system building.

global '(!!flexperr !!!~xx !!maxbflexp);

remflag('(find!!maxbflexp), 'lose);

symbolic procedure find!!maxbflexp();
  << !!flexperr := t;
     !!!~xx := expt(2.0, 1023);
     !!maxbflexp := 1022 >>;

flag('(find!!maxbflexp), 'lose);

remflag('(copyd), 'lose);

symbolic procedure copyd(new,old);
% Copy the function definition from old id to new.
   begin scalar x;
      x := getd old;
% If loading with !*savedef = '!*savedef then the actual definitions
% do not get loaded, but the source forms do...
      if null x then <<
        if not (!*savedef = '!*savedef)
          then rerror('rlisp,1,list(old,"has no definition in copyd"))>>
      else << putd(new,car x,cdr x);
              if flagp(old, 'lose) then flag(list new, 'lose) >>;
% The transfer of the saved definition is needed if the REDUCE "patch"
% mechanism is to work fully properly.
      if (x := get(old, '!*savedef)) then put(new, '!*savedef, x);
      return new
   end;

flag('(copyd), 'lose);

smacro procedure int2id x; compress list('!!, x);
smacro procedure id2int x; car explode2n x;

smacro procedure bothtimes x; eval!-when((compile load eval), x);
smacro procedure compiletime x; eval!-when((compile eval), x);
smacro procedure loadtime x; eval!-when((load eval), x);

smacro procedure csl x; x;
smacro procedure psl x; nil;

symbolic macro procedure printf u;
  list('printf1, cadr u, 'list . cddr u);

symbolic procedure printf1(fmt, args);
% this is the inner works of print formatting.
% the special sequences that can occur in format strings are
%       %b    do that many spaces
%       %c    next arg is a numeric character code. display character
%       %d    print an integer (actually just the same as %w)
% *     %f    do a terpri() unless posn()=0
%       %l    prin2 items from given list, blank separated
% *     %n    do a terpri()
%       %o    print in octal
%       %p    print using prin1
%       %t    do a ttab to move to given column
%       %w    use prin2
%       %x    print in hexadecimal
% *     %%    print a '%' character (items marked * do not use an arg).
% All except those marked with "*" use an argument.
  begin
    scalar a, c;
    fmt := explode2 fmt;
    while fmt do <<
      c := car fmt;
      fmt := cdr fmt;
      if c = '!% then <<
         c := car fmt;
         fmt := cdr fmt;
         if c = '!f then << if not zerop posn() then terpri() >>
         else if c = '!n then terpri()
         else if c = '!% then prin2 c
         else <<
            a := car args;
            args := cdr args;
            if c = '!b then spaces a
            else if c = '!c then tyo a
            else if c = '!l then <<
               if not atom a then <<
                  prin2 car a;
                  for each w in cdr a do << prin2 " "; prin2 w >> >> >>
            else if c = '!o then prinoctal a
            else if c = '!p then prin1 a
            else if c = '!t then ttab a
            else if c = '!w or c = '!d or c = '!s then prin2 a
            else if c = '!x then prinhex a
            else rerror('cslrend,1,list(c,"bad format character")) >> >>
      else prin2 c >>
  end;

% The format options with bldmsg are intended to match those used
% with printf. If I had make!-string!-output!-stream() available in
% Standard Lisp mode it would let me use one copy of this code and things
% would thus be tidier!

symbolic macro procedure bldmsg u;
  list('bldmsg1, cadr u, 'list . cddr u);

symbolic procedure bldstring r;
% Could possibly be (list!-to!-string nreverse r) ???
  begin
    scalar w;
    w := '(!");
    while r do <<
       w := car r . w;
       if car r eq '!" then w := '!" . w;
       r := cdr r >>;
    return compress ('!" . w)
  end;

symbolic procedure bldcolumn(s, n);
  if null s or eqcar(s, !$eol!$) then n
  else bldcolumn(cdr s, n+1);

symbolic procedure bldmsg1(fmt, args);
  begin
    scalar a, c, r;
    fmt := explode2 fmt;
    while fmt do <<
      c := car fmt;
      fmt := cdr fmt;
      if c = '!% then <<
         c := car fmt;
         fmt := cdr fmt;
         if c = '!f then <<
             if not zerop bldcolumn(r, 0) then r := !$eol!$ . r >>
         else if c = '!n then r := !$eol!$ . r
         else if c = '!% then r := c . r
         else <<
            a := car args;
            args := cdr args;
            if c = '!b then for i := 1:a do r := '!  . r
            else if c = '!c then r := a . r
            else if c = '!l then <<
               if not atom a then <<
                  r := append(reverse explode2 car a, r);
                  for each w in cdr a do <<
                     r := '!  . r;
                     r := append(reverse explode2 w, r) >> >> >>
            else if c = '!o then r := append(reverse explodeoctal a, r)
            else if c = '!p then r := append(reverse explode a, r)
            else if c = '!t then while bldcolumn(r, 0)> >>
      else r := c . r >>;
    return bldstring r
  end;

put('gc, 'simpfg, '((t (verbos t)) (nil (verbos nil))));

switch gc;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/patches.red0000644000175000017500000000325011526203062024343 0ustar  giovannigiovannimodule patches; % Patches to correct problems in current release.

% Author: Anthony C. Hearn.

% Copyright (c) 1999 Anthony C. Hearn.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% With the full source available to everybody the value of distributing
% a separate module of patches is no longer that high, so this file is
% a bit of a dinosaur.

global '(patch!-date!*);

% patch!-date!* := "15-Apr-1999";

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/compat.red0000644000175000017500000000424111526203062024200 0ustar  giovannigiovanniMODULE COMPAT;

% Author: Anthony C. Hearn;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


FLUID '(!*USERMODE);

GLOBAL '(SPARE!*);

SPARE!* := 10;

% This file defines functions and variables that are needed to
% make REDUCE and the underlying PSL system compatible. It should
% be loaded as the first file whenever REDUCE services are required.

% Definitions of functions already defined in PSL

% PSL doesn't need PRINTPROMPT

REMFLAG('(PRINTPROMPT),'LOSE);

symbolic procedure printprompt u; nil;

flag('(printprompt),'lose);

% The following are all supported by PSL:

flag('(atsoc eqcar delasc mkquote aconc prin2t reversip union geq leq
        neq putc yesp),
      'lose);

flag('(rblock for foreach lprim repeat while),'user);  % to permit redef

symbolic procedure !*s2i u; u;

% These are needed until the PSL syslisp and trace modules are changed:

symbolic procedure definebop u; u;

symbolic procedure definerop u; u;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/support/smacros.red0000755000175000017500000020476511526203062024404 0ustar  giovannigiovanni% smacros.red - automatically generated from other source files

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic smacro procedure !*!*a2i(u,vars); 
   if intexprnp(u,vars) then u else {'ieval,u};


symbolic smacro procedure !*!*s2a(u,vars); u;


symbolic smacro procedure !*!*s2i(u,vars); if fixp u then u else {'!*s2i,u};


symbolic smacro procedure !*i2gi u; cons('!:gi!:,cons(u,0));


symbolic smacro procedure !*i2rn u; cons('!:rn!:,cons(u,1));


symbolic smacro procedure !*n2f u; if zerop u then nil else u;


symbolic smacro procedure !*s2i u; if fixp u then u else typerr(u,"integer");


symbolic smacro procedure !*sqprint u; sqprint cadr u;


symbolic smacro procedure !:gi!:unitconv(u,v); 
   unitconv(u,v,get('!:gi!:,'units));


symbolic smacro procedure !:minusp u; 
   if atom u then minusp u else apply1(get(car u,'minusp),u);


symbolic smacro procedure !:onep u; 
   if atom u then onep u else apply1(get(car u,'onep),u);


symbolic smacro procedure !:rn2rd x; 
   if and(!*roundall,!*rounded) then !*rn2rd x else x;


symbolic smacro procedure abs!: nmbr; 
   if greaterp(cadr nmbr,0) then nmbr
    else cons('!:rd!:,cons(minus cadr nmbr,cddr nmbr));


symbolic smacro procedure absf u; if minusf u then negf u else u;


symbolic smacro procedure aconc(u,v); nconc(u,{v});


symbolic smacro procedure aconc!*(u,v); nconc(u,{v});


symbolic smacro procedure acos!* u; acos!:(u,!:bprec!:);


symbolic smacro procedure addcomment u; setq(cursym!*,u);


symbolic smacro procedure adddm!*(u,v); 
   if null u then v else if null v then u else adddm(u,v);


symbolic smacro procedure algid(u,vars); 
   if or(atsoc(u,vars),flagp(u,'share)) then u else mkquote u;


symbolic smacro procedure algmodep u; 
   and(not atom u,memq(car u,'(aeval aeval!*)));


symbolic smacro procedure applmacro(u,v,w); apply1(u,cons(w,v));


symbolic smacro procedure arbstat; 
   <>;


symbolic smacro procedure argsofopr u; get(u,'number!-of!-args);


symbolic smacro procedure arraychk u; if null u then 'array else nil;


symbolic smacro procedure arraylength u; cons('list,get(u,'dimension));


symbolic smacro procedure arrayp u; eq(get(u,'rtype),'array);


symbolic smacro procedure asin!* u; asin!:(u,!:bprec!:);


symbolic smacro procedure atan!* u; atan!:(u,!:bprec!:);


symbolic smacro procedure bfdiffer(u,v); 
   if atom u then difference(u,v) else difbf(u,v);


symbolic smacro procedure bfdivide(u,v); 
   if atom u then quotient(u,v) else csl_normbf divide!:(u,v,!:bprec!:);


symbolic smacro procedure bflerrmsg u; error(0,{"Invalid argument to",u});


symbolic smacro procedure bflessp(a,b); 
   if atom a then lessp(a,b) else grpbf(b,a);


symbolic smacro procedure bfplus(u,v); 
   if atom u then plus2(u,v) else plubf(u,v);


symbolic smacro procedure bfprin!: u; bfprin0 u;


symbolic smacro procedure bftimes(u,v); 
   if atom u then times2(u,v) else csl_timbf(u,v);


symbolic smacro procedure bftrim!: v; 
   csl_normbf round!:mt(v,difference(!:bprec!:,3));


symbolic smacro procedure bfzerop!: u; equal(cadr u,0);


symbolic smacro procedure boolvalue!* u; and(u,null equal(u,0));


symbolic smacro procedure breakp u; 
   member(u,'(!< !> !; !: != !) !+ !- !, !' !"));


symbolic smacro procedure bye; <>;


symbolic smacro procedure c!-end; c!-end1 t;


symbolic smacro procedure c!:atomcar x; 
   and(or(eqcar(x,'cons),eqcar(x,'list)),not null cdr x,
       c!:certainlyatom cadr x);


symbolic smacro procedure c!:ccall(fn,args,env); c!:ccall1(fn,args,env);


symbolic smacro procedure c!:ccatch(u,env); error(0,"catch");


symbolic smacro procedure c!:ccompile_let(u,env); error(0,"compiler-let");


symbolic smacro procedure c!:cde(u,env); error(0,"de");


symbolic smacro procedure c!:cdeclare(u,env); error(0,"declare");


symbolic smacro procedure c!:cdefun(u,env); error(0,"defun");


symbolic smacro procedure c!:ceval_when(u,env); error(0,"eval-when");


symbolic smacro procedure c!:cflet(u,env); error(0,"flet");


symbolic smacro procedure c!:clabels(u,env); error(0,"labels");


symbolic smacro procedure c!:clet(x,env); 
   c!:cval(c!:expand!-let(cadr x,cddr x),env);


symbolic smacro procedure c!:clet!*(x,env); 
   c!:cval(c!:expand!-let!*(cadr x,cddr x),env);


symbolic smacro procedure c!:cmacrolet(u,env); error(0,"macrolet");


symbolic smacro procedure c!:cmultiple_value_call(u,env); 
   error(0,"multiple_value_call");


symbolic smacro procedure c!:cmultiple_value_prog1(u,env); 
   error(0,"multiple_value_prog1");


symbolic smacro procedure c!:comassoc x; 
   if or(c!:certainlyatom cadr x,c!:atomkeys caddr x) then cons('atsoc,cdr x)
    else nil;


symbolic smacro procedure c!:comdelete x; 
   if or(c!:certainlyatom cadr x,c!:atomlist caddr x) then cons('deleq,cdr x)
    else nil;


symbolic smacro procedure c!:commember x; 
   if or(c!:certainlyatom cadr x,c!:atomlist caddr x) then cons('memq,cdr x)
    else nil;


symbolic smacro procedure c!:comsublis x; 
   if c!:atomkeys cadr x then cons('subla,cdr x) else nil;


symbolic smacro procedure c!:concat(a,b); 
   compress cons('!",append(explode2 a,append(explode2 b,'(!"))));


symbolic smacro procedure c!:cprog!*(u,env); error(0,"prog*");


symbolic smacro procedure c!:cprogv(u,env); error(0,"progv");


symbolic smacro procedure c!:cspecform(x,env); error(0,{"special form",x});


symbolic smacro procedure c!:ctestnull(x,env,d1,d2); 
   c!:cjumpif(cadr x,env,d2,d1);


symbolic smacro procedure c!:cthe(u,env); c!:cval(caddr u,env);


symbolic smacro procedure c!:cthrow(u,env); error(0,"throw");


symbolic smacro procedure c!:cunwind_protect(u,env); error(0,"unwind_protect");


symbolic smacro procedure c!:has_calls(a,b); 
   begin scalar visited; return c!:has_calls_1(a,b) end;


symbolic smacro procedure c!:insert1(a,b); if memq(a,b) then b else cons(a,b);


symbolic smacro procedure c!:is_fixnum x; 
   and(fixp x,geq(x,minus 134217728),leq(x,134217727));


symbolic smacro procedure c!:locally_bound(x,env); atsoc(x,car env);


symbolic smacro procedure c!:newreg; 
   begin scalar r; 
      setq(r,c!:my_gensym()); 
      setq(registers,cons(r,registers)); 
      return r
   end;


symbolic smacro procedure c!:one_operand op; 
   <>;


symbolic smacro procedure c!:outop(a,b,c,d); 
   if current_block
     then setq(current_contents,cons({a,b,c,d},current_contents));


symbolic smacro procedure c!:passoc(op,r1,r2,r3,depth); 
   c!:printf1("    %v = Lassoc(nil, %v, %v);\n",{r1,r2,r3});


symbolic smacro procedure c!:patom(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (consp(%v) ? nil : lisp_true);\n",{r1,r3});


symbolic smacro procedure c!:patsoc(op,r1,r2,r3,depth); 
   c!:printf1("    %v = Latsoc(nil, %v, %v);\n",{r1,r2,r3});


symbolic smacro procedure c!:peq(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (%v == %v ? lisp_true : nil);\n",{r1,r2,r3});


symbolic smacro procedure c!:pequal(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (equal(%v, %v) ? lisp_true : nil);\n",{r1,r2,r3,r2,r3});


symbolic smacro procedure c!:pfixp(op,r1,r2,r3,depth); 
   c!:printf1("    %v = integerp(%v);\n",{r1,r3});


symbolic smacro procedure c!:pfluidbind(op,r1,r2,r3,depth); nil;


symbolic smacro procedure c!:pget(op,r1,r2,r3,depth); 
   c!:printf1("    %v = get(%v, %v);\n",{r1,r2,r3});


symbolic smacro procedure c!:piadd1(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (Lisp_Object)((int32_t)(%v) + 0x10);\n",{r1,r3});


symbolic smacro procedure c!:pidifference(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (Lisp_Object)(int32_t)((int32_t)%v - (int32_t)%v + TAG_F
IXNUM);\n",{r1,r2,r3});


symbolic smacro procedure c!:pifatom(s,depth); c!:printf1("!consp(%v)",{car s});


symbolic smacro procedure c!:pifeq(s,depth); 
   c!:printf1("%v == %v",{car s,cadr s});


symbolic smacro procedure c!:pifequal(s,depth); 
   c!:printf1("equal(%v, %v)",{car s,cadr s,car s,cadr s});


symbolic smacro procedure c!:pifigreaterp(s,depth); 
   c!:printf1("((int32_t)(%v)) > ((int32_t)(%v))",{car s,cadr s});


symbolic smacro procedure c!:pifilessp(s,depth); 
   c!:printf1("((int32_t)(%v)) < ((int32_t)(%v))",{car s,cadr s});


symbolic smacro procedure c!:pifizerop(s,depth); 
   c!:printf1("(%v) == 1",{car s});


symbolic smacro procedure c!:pifnull(s,depth); c!:printf1("%v == nil",{car s});


symbolic smacro procedure c!:pifnumber(s,depth); 
   c!:printf1("is_number(%v)",{car s});


symbolic smacro procedure c!:pifsymbol(s,depth); 
   c!:printf1("symbolp(%v)",{car s});


symbolic smacro procedure c!:pigreaterp(op,r1,r2,r3,depth); 
   c!:printf1("    %v = ((intptr_t)%v > (intptr_t)%v) ? lisp_true : nil;\n",
              {r1,r2,r3});


symbolic smacro procedure c!:pilessp(op,r1,r2,r3,depth); 
   c!:printf1("    %v = ((intptr_t)%v < (intptr_t)%v) ? lisp_true : nil;\n",
              {r1,r2,r3});


symbolic smacro procedure c!:piminus(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (Lisp_Object)(2-((int32_t)(%v)));\n",{r1,r3});


symbolic smacro procedure c!:piminusp(op,r1,r2,r3,depth); 
   c!:printf1("    %v = ((intptr_t)(%v) < 0 ? lisp_true : nil);\n",{r1,r3});


symbolic smacro procedure c!:piplus2(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (Lisp_Object)(int32_t)((int32_t)%v + (int32_t)%v - TAG_F
IXNUM);\n",{r1,r2,r3});


symbolic smacro procedure c!:pisub1(op,r1,r2,r3,depth); 
   c!:printf1("    %v = (Lisp_Object)((int32_t)(%v) - 0x10);\n",{r1,r3});


symbolic smacro procedure c!:pitimes2(op,r1,r2,r3,depth); 
   c!:printf1("    %v = fixnum_of_int((int32_t)(int_of_fixnum(%v) * int_of_fixnu
m(%v)));\n",{r1,r2,r3});


symbolic smacro procedure c!:pldrglob(op,r1,r2,r3,depth); 
   c!:printf1("    %v = qvalue(elt(env, %s)); %>;


symbolic smacro procedure c!:pqputv(op,r1,r2,r3,depth); 
   <>;


symbolic smacro procedure c!:preloadenv(op,r1,r2,r3,depth); 
   c!:printf1("    env = stack[%s];\n",{minus reloadenv});


symbolic smacro procedure c!:pstrglob(op,r1,r2,r3,depth); 
   c!:printf1("    qvalue(elt(env, %s)) = %v; %>;


symbolic smacro procedure c!:valid_fndef(args,body); 
   if or(memq('!&optional,args),memq('!&rest,args)) then nil
    else c!:valid_list body;


symbolic smacro procedure c!:valid_let x; 
   if null x then t
    else if not c!:valid_cond car x then nil else c!:valid_list cdr x;


symbolic smacro procedure c!:valid_prog x; c!:valid_list cdr x;


symbolic smacro procedure c!:valid_quote x; t;


symbolic smacro procedure c!:valid_specform x; nil;


symbolic smacro procedure c_end; 
   begin 
      if null s!:cmod_name then return nil; 
      s!:cend(); 
      setq(dfprint!*,s!:dfprintsave); 
      setq(!*defn,nil); 
      setq(!*comp,cdr s!:cmod_name); 
      setq(s!:cmod_name,nil); 
      return nil
   end;


symbolic smacro procedure cdarx u; cdr carx(u,'cdar);


symbolic smacro procedure cflot x; 
   if floatp x then x else if atom x then float x else bf2flr x;


symbolic smacro procedure chkrn!* u; if !*!*roundbf then u else bf2flck u;


symbolic smacro procedure choose(x,n); quotient(perm(x,n),factorial x);


symbolic smacro procedure clear_source_database; 
   <>;


symbolic smacro procedure clfarg; setq(farglist!*,nil);


symbolic smacro procedure clogsq x; cons(clogf car x,clogf cdr x);


symbolic smacro procedure comfac!-to!-poly u; if null car u then cdr u else {u};


symbolic smacro procedure comm_kernels u; comm_kernels1(u,nil);


symbolic smacro procedure compile!-file!*(fromfile,!&optional,tofile); 
   s!:compile!-file!*(fromfile,tofile,t,t);


symbolic smacro procedure concat(u,v); 
   compress cons('!",append(explode2 u,nconc(explode2 v,{'!"})));


symbolic smacro procedure concat2(u,v); concat(u,v);


symbolic smacro procedure condterpri; 
   and(!*output,!*echo,!*extraecho,
       or(null !*int,ifl!*),null !*defn,null !*demo,terpri());


symbolic smacro procedure conv!:bf2i nmbr; ash1(cadr nmbr,cddr nmbr);


symbolic smacro procedure convertmode(exprn,vars,target,source); 
   convertmode1(form1(exprn,vars,source),vars,target,source);


symbolic smacro procedure convprec!* u; 
   convchk (if atom u then u else cons('!:rd!:,u));


symbolic smacro procedure cos!* u; cos!:(u,!:bprec!:);


symbolic smacro procedure cr2rderr; 
   error(0,"complex to real type conversion requires zero imaginary part");


symbolic smacro procedure crarg!* u; 
   rdatan2!*(cons('!:rd!:,cddr u),cons('!:rd!:,cadr u));


symbolic smacro procedure crlogb!*(u,b); cr!:quotient(crlog!* u,crlog!* b);


symbolic smacro procedure crn!:minusp u; and(equal(caddr u,0),minusp caadr u);


symbolic smacro procedure crn!:onep u; 
   and(equal(car cddr u,0),equal(cadr u,'(1 . 1)));


symbolic smacro procedure crn!:prep u; 
   crnprep1 cons(cons('!:rn!:,cadr u),cons('!:rn!:,cddr u));


symbolic smacro procedure crn!:simp u; cons(cons('!:crn!:,u),1);


symbolic smacro procedure crn!:zerop u; 
   and(equal(car cadr u,0),equal(car cddr u,0));


symbolic smacro procedure crnorm!* u; 
   rdhypot!*(cons('!:rd!:,cadr u),cons('!:rd!:,cddr u));


symbolic smacro procedure crprcd u; 
   (lambda(rl,im); cons(rl,im))(convprec!* cadr u,convprec!* cddr u);


symbolic smacro procedure cutf(u,x,n); if ilessp(n,1) then u else cutf1(u,x,n);


symbolic smacro procedure dated!-gensym u; dated!-name u;


symbolic smacro procedure dcombine!*(u,v,w); 
   if and(atom u,atom v) then apply2(w,u,v) else dcombine(u,v,w);


symbolic smacro procedure decomposef1(f,msg); decomposef2(cons(f,1),msg);


symbolic smacro procedure decomposegensym; 
   compress append('(!! !d !! c !! !.),
                   explode2 setq(decomposegensym!*,plus2(decomposegensym!*,1)));


symbolic smacro procedure decprec2internal p; 
   plus2(ceiling times2(p,log2of10),3);


symbolic smacro procedure deg2rad x; times2(x,pi!/180);


symbolic smacro procedure delcp u; flagp(u,'delchar);


symbolic smacro procedure den u; mk!*sq cons(cdr simp!* u,1);


symbolic smacro procedure deox u; proceox0(car u,'expr,cadr u,caddr u);


symbolic smacro procedure dimension u; get(u,'dimension);


symbolic smacro procedure dmconv0 dmd; 
   setq(dmd!*,
        if null dmd then '!:rn!:
         else if eq(dmd,'!:gi!:) then '!:crn!:
         else dmd);


symbolic smacro procedure dms2deg l; 
   plus2(quotient(plus2(quotient(caddr l,60.0),cadr l),60.0),car l);


symbolic smacro procedure dms2rad!* u; deg2rad!* dms2deg!* u;


symbolic smacro procedure dn!:prin u; bfprin0x(cadr u,cddr u);


symbolic smacro procedure doindex u; setprifn(u,'indexprin);


symbolic smacro procedure donoargs u; setprifn(u,'noargsprin);


symbolic smacro procedure down u; factor1(u,t,'dnl!*);


symbolic smacro procedure downpower(pol,n); downpower1(pol,caaar pol,n);


symbolic smacro procedure dsox u; proceox0(car u,'smacro,cadr u,caddr u);


symbolic smacro procedure e!*; !:e !:bprec!:;


symbolic smacro procedure emtch u; 
   if atom u then u else (lambda x; if x then x else u) opmtch u;


symbolic smacro procedure endstat; 
   begin scalar x; setq(x,cursym!*); comm1 'end; return {x} end;


symbolic smacro procedure eofcheck; 
   and(eq(program!*,!$eof!$),equal(ttype!*,3),setq(eof!*,plus2(eof!*,1)));


symbolic smacro procedure eqexpr u; 
   and(not atom u,flagp(car u,'equalopr),cddr u,null cdddr u);


symbolic smacro procedure eqnerr u; typerr(u,"equation");


symbolic smacro procedure eqnlength u; length cdr u;


symbolic smacro procedure equalreplaceby u; cons('replaceby,u);


symbolic smacro procedure errorp u; or(atom u,cdr u);


symbolic smacro procedure errorset!*(u,v); errorset(u,v,!*backtrace);


symbolic smacro procedure errpri1 u; 
   msgpri("Substitution for",u,"not allowed",nil,t);


symbolic smacro procedure errpri2(u,v); 
   msgpri("Syntax error:",u,"invalid",nil,v);


symbolic smacro procedure evalleq(u,v); not evalgreaterp(u,v);


symbolic smacro procedure evallessp(u,v); evalgreaterp(v,u);


symbolic smacro procedure evalneq(u,v); not evalequal(u,v);


symbolic smacro procedure evalwhereexp u; 
   evalletsub({cdar u,{'aeval,mkquote {'aeval,carx(cdr u,'where)}}},nil);


symbolic smacro procedure exchk u; exchk1(u,nil,nil,nil);


symbolic smacro procedure exp!* u; exp!:(u,!:bprec!:);


symbolic smacro procedure expchk u; if !*exp then u else offexpchk u;


symbolic smacro procedure explodex u; 
   if numberp u then explode u
    else if stringp u then reversip cdr reversip cdr explode u
    else explodex1 explode u;


symbolic smacro procedure exports u; 
   begin setq(exportslist!*,union(u,exportslist!*)) end;


symbolic smacro procedure exppri(u,v); assgnpri(u,nil,v);


symbolic smacro procedure exptchksq u; 
   if null !*combineexpt then u else multsq(exptchk car u,invsq exptchk cdr u);


symbolic smacro procedure exptmod!:(u,n); 
   !*modular2f general!-modular!-expt(cdr u,n);


symbolic smacro procedure expttermp(u,v); 
   if eqcar(u,'expt) then expttermp1(cadr u,v) else expttermp1(u,v);


symbolic smacro procedure fac!-merge(u,v); 
   cons(multf(car u,car v),append(cdr u,cdr v));


symbolic smacro procedure factor u; factor1(u,t,'factors!*);


symbolic smacro procedure factor!-coeffs u; {1,u};


symbolic smacro procedure factorize!-form!-recursion u; fctrf1 u;


symbolic smacro procedure fancy!-begin; {fancy!-pos!*,fancy!-line!*};


symbolic smacro procedure fancy!-condpri0 u; fancy!-condpri(u,0);


symbolic smacro procedure fancy!-end(r,s); 
   <>; 
     r>>;


symbolic smacro procedure fancy!-fail(pos,fl); 
   <>;


symbolic smacro procedure fancy!-last!-symbol; 
   if fancy!-line!* then car fancy!-line!*;


symbolic smacro procedure fancy!-matpri u; fancy!-matpri1(cdr u,nil);


symbolic smacro procedure fancy!-partialdfpri(u,l); 
   fancy!-dfpri0(u,l,'partial!-df);


symbolic smacro procedure fancy!-prin2 u; fancy!-prin2!*(u,nil);


symbolic smacro procedure fancy!-prin2number u; 
   if testing!-width!* then fancy!-prin2!*(u,t)
    else fancy!-prin2number1 (if atom u then explode2 u else u);


symbolic smacro procedure fancy!-print!-function!-arguments u; 
   fancy!-in!-brackets(and(u,{'fancy!-inprint,mkquote '!*comma!*,0,mkquote u}),
                       '!(,'!));


symbolic smacro procedure fancy!-print!-indexlist l; 
   fancy!-print!-indexlist1(l,'!_,nil);


symbolic smacro procedure fancy!-prodpri(u,p); fancy!-sumpri!*(u,p,'prod);


symbolic smacro procedure fancy!-revalpri u; 
   fancy!-maprin0 fancy!-unquote cadr u;


symbolic smacro procedure fancy!-setmatpri(u,v); fancy!-matpri1(cdr v,u);


symbolic smacro procedure fancy!-sqreform u; prepsq!* sqhorner!* cadr u;


symbolic smacro procedure fancy!-sqrtpri u; fancy!-sqrtpri!*(cadr u,2);


symbolic smacro procedure fancy!-sumpri(u,p); fancy!-sumpri!*(u,p,'sum);


symbolic smacro procedure fexpt(x,n); 
   begin scalar w; setq(w,fexpt1(fsplit x,n)); return plus2(car w,cdr w) end;


symbolic smacro procedure fieldp u; and(not atom u,flagp(car u,'field));


symbolic smacro procedure fillin u; if null u then nil else fillin1(u,caar u);


symbolic smacro procedure find!!maxbflexp; 
   <>;


symbolic smacro procedure first x; car x;


symbolic smacro procedure flagop u; begin flag(u,'flagop); rlistat u end;


symbolic smacro procedure foprin op; 
   (lambda x; if null x then fprin2!* op else fprin2!* x) get(op,'prtch);


symbolic smacro procedure formclear(u,vars,mode); 
   {'clear,formclear1(cdr u,vars,mode)};


symbolic smacro procedure formcond(u,vars,mode); 
   cons('cond,formcond1(cdr u,vars,mode));


symbolic smacro procedure formlet(u,vars,mode); 
   {'let,formlet1(cdr u,vars,mode)};


symbolic smacro procedure formmatch(u,vars,mode); 
   {'match,formlet1(cdr u,vars,mode)};


symbolic smacro procedure formpatch(u,vars,mode); cons('progn,cdr u);


symbolic smacro procedure formprog(u,vars,mode); 
   make_prog_declares(cadr u,formprog1(cddr u,pairvars(cadr u,vars,mode),mode));


symbolic smacro procedure formprogn(u,vars,mode); 
   cons('progn,formclis(cdr u,vars,mode));


symbolic smacro procedure formrederr(u,vars,mode); 
   {'rederr,formc!*(cadr u,vars,mode)};


symbolic smacro procedure formreturn(u,vars,mode); 
   {'return,formc(cadr u,vars,mode)};


symbolic smacro procedure formsaveas(u,vars,mode); 
   {'saveas,formclear1(cdr u,vars,mode)};


symbolic smacro procedure fourth x; cadddr x;


symbolic smacro procedure freeof(u,v); 
   not or(smember(v,u),member(v,assoc(u,depl!*)));


symbolic smacro procedure fterpri u; 
   <>;


symbolic smacro procedure gbfdiff(u,v); 
   cons(difbf(car u,car v),difbf(cdr u,cdr v));


symbolic smacro procedure gbfdot(u,v); 
   plubf(csl_timbf(car u,car v),csl_timbf(cdr u,cdr v));


symbolic smacro procedure gbfplus(u,v); 
   cons(plubf(car u,car v),plubf(cdr u,cdr v));


symbolic smacro procedure gbfrsq u; 
   plubf(csl_timbf(car u,car u),csl_timbf(cdr u,cdr u));


symbolic smacro procedure gcdfd(u,v); 
   if flagp(dmode!*,'field) then 1 else gcdfd1(u,v);


symbolic smacro procedure general!-modular!-minus a; 
   if equal(a,0) then a else difference(current!-modulus,a);


symbolic smacro procedure general!-modular!-quotient(a,b); 
   general!-modular!-times(a,general!-modular!-reciprocal b);


symbolic smacro procedure genvar; 
   intern compress append(explode svar,explode setq(scountr,plus2(scountr,1)));


symbolic smacro procedure getinfix u; 
   begin scalar x; return if setq(x,get(u,'prtch)) then x else u end;


symbolic smacro procedure getrtypecar u; getrtype car u;


symbolic smacro procedure gettransferfn(u,v); 
   (lambda x; if x then x else dmoderr(u,v)) get(u,v);


symbolic smacro procedure gffdiff(u,v); 
   cons(difference(car u,car v),difference(cdr u,cdr v));


symbolic smacro procedure gffdot(u,v); 
   plus2(times2(car u,car v),times2(cdr u,cdr v));


symbolic smacro procedure gffmult(r,u); cons(times2(r,car u),times2(r,cdr u));


symbolic smacro procedure gffplus(u,v); 
   cons(plus2(car u,car v),plus2(cdr u,cdr v));


symbolic smacro procedure gffrsq u; 
   plus2(times2(car u,car u),times2(cdr u,cdr u));


symbolic smacro procedure gfminus u; cons(bfminus car u,bfminus cdr u);


symbolic smacro procedure gfplus(u,v); 
   if atom car u then gffplus(u,v) else gbfplus(u,v);


symbolic smacro procedure gfquotient(u,v); 
   if atom car u then gffquot(u,v) else gbfquot(u,v);


symbolic smacro procedure gfrotate u; cons(bfminus cdr u,car u);


symbolic smacro procedure gfrsq u; gfdot(u,u);


symbolic smacro procedure gftimes(u,v); 
   if atom car u then gfftimes(u,v) else gbftimes(u,v);


symbolic smacro procedure giminusp!: u; 
   if equal(cadr u,0) then minusp cddr u else minusp cadr u;


symbolic smacro procedure gintequiv!: u; 
   if equal(cddr u,0) then cadr u else nil;


symbolic smacro procedure gionep!: u; and(equal(cadr u,1),equal(cddr u,0));


symbolic smacro procedure giprim im; if equal(im,1) then 'i else {'times,im,'i};


symbolic smacro procedure gizerop!: u; and(equal(cadr u,0),equal(cddr u,0));


symbolic smacro procedure gostat; 
   begin scalar var; 
      setq(var,if eq(scan(),'to) then scan() else cursym!*); 
      scan(); 
      return {'go,var}
   end;


symbolic smacro procedure gox u; <>;


symbolic smacro procedure greaterpcdr(a,b); greaterp(cdr a,cdr b);


symbolic smacro procedure hashtagged!-name(base,value); 
   intern list!-to!-string append(explodec base,cons('!_,s!:stamp md60 value));


symbolic smacro procedure icbrt x; irootn(fix x,3);


symbolic smacro procedure idcompare(u,v); idcomp1(explode2 u,explode2 v);


symbolic smacro procedure identity(u,vars); u;


symbolic smacro procedure igetv(u,v); getv(u,v);


symbolic smacro procedure imports u; 
   begin setq(importslist!*,union(u,importslist!*)) end;


symbolic smacro procedure in u; in_non_empty_list u;


symbolic smacro procedure infinityp u; 
   (lambda x; not or(eq(x,'!-),digit x)) car explode u;


symbolic smacro procedure initrlisp; 
   <>;


symbolic smacro procedure intconv x; 
   if or(null dmode!*,memq(dmode!*,'(!:rd!: !:cr!:))) then x
    else apply1(get(dmode!*,'i2d),x);


symbolic smacro procedure internal!-primep n; 
   if greaterp(n,largest!-small!-modulus) then general!-primep n
    else small!-primep n;


symbolic smacro procedure invbf u; csl_normbf divide!:(bfone!*,u,!:bprec!:);


symbolic smacro procedure iputv(u,v,w); putv(u,v,w);


symbolic smacro procedure iroot(n,r); 
   begin scalar tmp; 
      setq(tmp,irootn(n,r)); 
      return if equal(expt(tmp,r),n) then tmp else nil
   end;


symbolic smacro procedure kernels u; kernels1(u,nil);


symbolic smacro procedure labox u; <>;


symbolic smacro procedure lengthcdr u; length cdr u;


symbolic smacro procedure leq!:(n1,n2); not greaterp!:(n1,n2);


symbolic smacro procedure lessp!:(n1,n2); greaterp!:(n2,n1);


symbolic smacro procedure lesspcar(a,b); lessp(car a,car b);


symbolic smacro procedure lesspcdadr(a,b); lessp(cdadr a,cdadr b);


symbolic smacro procedure lesspcdr(a,b); lessp(cdr a,cdr b);


symbolic smacro procedure lhs u; lhs!-rhs(u,'cadr);


symbolic smacro procedure linfacf u; trykrf(u,'(0 1));


symbolic smacro procedure lispeval u; eval u;


symbolic smacro procedure load!-latest!-patches; load!-patches!-file();


symbolic smacro procedure log!* u; log!:(u,!:bprec!:);


symbolic smacro procedure logarg(a,c); if equal(c,1) then a else {'expt,a,c};


symbolic smacro procedure lprim u; and(!*msg,lpriw("***",u));


symbolic smacro procedure makearbcomplex; 
   begin scalar ans; 
      setq(!!arbint,plus2(!!arbint,1)); 
      setq(ans,car simp!* {'arbcomplex,!!arbint}); 
      return ans
   end;


symbolic smacro procedure makelist u; cons('list,u);


symbolic smacro procedure maprin u; 
   if outputhandler!* then apply2(outputhandler!*,'maprin,u)
    else if not overflowed!* then maprint(u,0);


symbolic smacro procedure mathprint l; <>;


symbolic smacro procedure max2!:(a,b); if greaterp!:(a,b) then a else b;


symbolic smacro procedure mchkopt(u,v); 
   (lambda o; if o then mchkopt1(u,v,o)) get(car v,'optional);


symbolic smacro procedure mconv v; <>;


symbolic smacro procedure min2!:(a,b); if greaterp!:(a,b) then b else a;


symbolic smacro procedure minus!: nmbr; 
   cons('!:rd!:,cons(minus cadr nmbr,cddr nmbr));


symbolic smacro procedure minusp!: x; 
   and(and(eqcar(x,'!:rd!:),not atom cdr x),lessp(cadr x,0));


symbolic smacro procedure mkabsf0 u; simp {'abs,mk!*sq cons(u,1)};


symbolic smacro procedure mkblock(u,v); cons('rblock,cons(u,v));


symbolic smacro procedure mkcrn(u,v); cons('!:crn!:,cons(u,v));


symbolic smacro procedure mkdcrn u; 
   cons(cons('!:crn!:,cons(cons(0,1),cons(1,1))),1);


symbolic smacro procedure mkdgi u; cons(cons('!:gi!:,cons(0,1)),1);


symbolic smacro procedure mkdmoderr(u,v); 
   {'lambda,'(!*x!*),{'dmoderr,mkquote u,mkquote v}};


symbolic smacro procedure mkexpt(u,n); if equal(n,1) then u else {'expt,u,n};


symbolic smacro procedure mkgi(re,im); cons('!:gi!:,cons(re,im));


symbolic smacro procedure mkprog(u,v); cons('prog,cons(u,v));


symbolic smacro procedure mkround u; if atom u then cons('!:rd!:,u) else u;


symbolic smacro procedure mksetshare(u,v); 
   mksetq(u,{'progn,'(setq alglist!* (cons nil nil)),v});


symbolic smacro procedure mksp(u,p); getpower(fkern u,p);


symbolic smacro procedure mkstrng u; u;


symbolic smacro procedure mktimes u; 
   if null cdr u then car u else cons('times,u);


symbolic smacro procedure mkvar(u,v); u;


symbolic smacro procedure mod!-error u; 
   typerr(u,{"expression mod",current!-modulus});


symbolic smacro procedure moddifference!:(u,v); 
   !*modular2f general!-modular!-difference(cdr u,cdr v);


symbolic smacro procedure moddivide!:(u,v); cons(!*i2mod 0,u);


symbolic smacro procedure modgcd!:(u,v); !*i2mod 1;


symbolic smacro procedure modminusp!: u; 
   if !*balanced_mod then greaterp(times2(2,cdr u),current!-modulus) else nil;


symbolic smacro procedure modonep!: u; equal(cdr u,1);


symbolic smacro procedure modplus!:(u,v); 
   !*modular2f general!-modular!-plus(cdr u,cdr v);


symbolic smacro procedure modprep!: u; cdr u;


symbolic smacro procedure modquotient!:(u,v); 
   !*modular2f general!-modular!-times(cdr u,
                                       general!-modular!-reciprocal cdr v);


symbolic smacro procedure modtimes!:(u,v); 
   !*modular2f general!-modular!-times(cdr u,cdr v);


symbolic smacro procedure modzerop!: u; equal(cdr u,0);


symbolic smacro procedure mprino u; mprino1(u,{0,0});


symbolic smacro procedure multdm!*(u,v); 
   if or(null u,null v) then nil else multdm(u,v);


symbolic smacro procedure multsq!*(u,v); 
   if !*intflag!* then !*multsq(u,v) else multsq(u,v);


symbolic smacro procedure mvar_member(u,v); 
   or(equal(u,v),and(null atom v,arglist_member(u,cdr v)));


symbolic smacro procedure name!-for!-patched!-version(name,extra); 
   if member('psl,lispsystem!*) then gensym1 'g
    else hashtagged!-name(name,extra);


symbolic smacro procedure nconc!*(u,v); nconc(u,v);


symbolic smacro procedure negnumberchk u; 
   if and(eqcar(u,'minus),numberp cadr u) then minus cadr u else u;


symbolic smacro procedure negsq u; cons(negf car u,cdr u);


symbolic smacro procedure newvar u; 
   if not idp u then typerr(u,"free variable")
    else intern compress append(explode '!=,explode u);


symbolic smacro procedure noargsprin u; 
   if or(not !*nat,!*fort) then 'failed
    else <>;


symbolic smacro procedure noncom1 u; <>;


symbolic smacro procedure noncomfp u; and(!*ncmp,noncomfp1 u);


symbolic smacro procedure noncomp u; and(!*ncmp,noncomp1 u);


symbolic smacro procedure noncomp!* u; 
   or(noncomp u,and(eqcar(u,'expt),noncomp cadr u));


symbolic smacro procedure nth(u,n); car pnth(u,n);


symbolic smacro procedure num u; mk!*sq cons(car simp!* u,1);


symbolic smacro procedure oem!-supervisor; print eval read();


symbolic smacro procedure off1 u; onoff(u,nil);


symbolic smacro procedure offindex u; setprifn(u,nil);


symbolic smacro procedure offmoderr(u,y); 
   lpriw("***",{"Failed attempt to turn off",u,"when",y,"is on"});


symbolic smacro procedure offnoargs u; setprifn(u,nil);


symbolic smacro procedure omark u; <>;


symbolic smacro procedure omarko u; omark {u,0};


symbolic smacro procedure on1 u; onoff(u,t);


symbolic smacro procedure operatorp u; eq(gettype u,'operator);


symbolic smacro procedure ord2(u,v); if ordp(u,v) then {u,v} else {v,u};


symbolic smacro procedure order!: nmbr; 
   if equal(cadr nmbr,0) then 0
    else plus2(msd abs cadr nmbr,difference(cddr nmbr,1));


symbolic smacro procedure ordopcar(a,b); ordop(car a,car b);


symbolic smacro procedure ordpv(u,v); ordpv1(u,v,minus 1,upbv u,upbv v);


symbolic smacro procedure out u; out_non_empty_list u;


symbolic smacro procedure parterr(u,v); 
   msgpri("Expression",u,"does not have part",v,t);


symbolic smacro procedure parterr2(u,v); 
   <>;


symbolic smacro procedure patches!-load!-check(u,v); 
   begin 
      put(u,'patchfn,v); 
      if memq(u,loaded!-packages!*) then install!-patches u
   end;


symbolic smacro procedure pause; 
   if null !*int then nil
    else if eq(key!*,'pause) then pause1 nil
    else pause1 nil;


symbolic smacro procedure pi!*; 
   if greaterp(!:prec!:,1000) then !:bigpi !:bprec!: else !:pi !:bprec!:;


symbolic smacro procedure pi!/2!*; csl_timbf(bfhalf!*,pi!*());


symbolic smacro procedure posintegerp u; and(fixp u,greaterp(u,0));


symbolic smacro procedure positive!-powp u; 
   and(not atom car u,memq(caar u,'(abs norm)));


symbolic smacro procedure powers form; powers0(form,nil);


symbolic smacro procedure praddf(u,v); 
   cons(addf(car u,car v),addf(cdr u,cdr v));


symbolic smacro procedure precmsg pr; 
   if greaterp(pr,!!rdprec)
     then <>;


symbolic smacro procedure prepd1 u; 
   if atom u then u else apply1(get(car u,'prepfn),u);


symbolic smacro procedure prepexpt u; if equal(caddr u,1) then cadr u else u;


symbolic smacro procedure prepf u; 
   (lambda x; if null x then 0 else replus x) prepf1(u,nil);


symbolic smacro procedure prepreform u; prepreform1(u,append(ordl!*,factors!*));


symbolic smacro procedure prepsq u; 
   if null car u then 0 else sqform(u,function prepf);


symbolic smacro procedure prepsq!*2 u; replus prepsq!*1(u,1,nil);


symbolic smacro procedure prepsqx u; if !*intstr then prepsq!* u else prepsq u;


symbolic smacro procedure prepsqyy u; 
   if eqcar(u,'!*sq) then prepsqxx cadr u else u;


symbolic smacro procedure prettyprint x; 
   <>;


symbolic smacro procedure prim!-part u; quotf1(u,comfac!-to!-poly comfac u);


symbolic smacro procedure prin20x u; 
   if rprifn!* then apply1(rprifn!*,u) else prin2 u;


symbolic smacro procedure prin2t u; <>;


symbolic smacro procedure prin2x u; setq(outl!*,cons(u,outl!*));


symbolic smacro procedure princl x; s!:prinl0(x,function princ);


symbolic smacro procedure prinl x; s!:prinl0(x,function prin);


symbolic smacro procedure prinsf u; if null u then prin2!* 0 else xprinf2 u;


symbolic smacro procedure print_format(f,pat); 
   put(car f,'print!-format,cons(cons(cdr f,pat),get(car f,'print!-format)));


symbolic smacro procedure print_precision n; print!-precision n;


symbolic smacro procedure printcl x; <>;


symbolic smacro procedure printl x; <>;


symbolic smacro procedure printprompt u; nil;


symbolic smacro procedure printsf u; <>;


symbolic smacro procedure printsq u; <>;


symbolic smacro procedure procstat; procstat1 nil;


symbolic smacro procedure prop x; plist x;


symbolic smacro procedure putc(a,b,c); put(a,b,c);


symbolic smacro procedure quadfacf u; trykrf(u,'(-1 0 1));


symbolic smacro procedure quit; <>;


symbolic smacro procedure quoteequation u; 'equation;


symbolic smacro procedure quotelist u; 'list;


symbolic smacro procedure quotfx(u,v); 
   if or(null !*exp,null !*mcd) then quotf(u,v) else quotfx1(u,v);


symbolic smacro procedure quotodd(p,q); 
   if and(atom p,atom q) then int!-equiv!-chk mkrn(p,q) else lowest!-terms(p,q);


symbolic smacro procedure quotox u; 
   if stringp u then prinox u else <>;


symbolic smacro procedure quotsq(u,v); multsq(u,invsq v);


symbolic smacro procedure rad2deg x; times2(x,!180!/pi);


symbolic smacro procedure rad2deg!: x; 
   csl_normbf divide!:(csl_timbf(x,!:180!*),pi!*(),!:bprec!:);


symbolic smacro procedure rad2dms x; deg2dms rad2deg x;


symbolic smacro procedure rad2dms!* u; deg2dms!* rad2deg!* u;


symbolic smacro procedure raddsq(u,n); simpexpt {mk!*sq u,{'quotient,1,n}};


symbolic smacro procedure ratnump!: x; eqcar(x,'!:ratnum!:);


symbolic smacro procedure rd2rn1 n; 
   if atom cdr n then ft2rn1 cdr n else bf2rn1 n;


symbolic smacro procedure rd!:explode u; 
   bfexplode0 bftrim!: (if atom cdr u then fl2bf cdr u else u);


symbolic smacro procedure rd!:minus u; 
   if atom cdr u then cons('!:rd!:,minus cdr u) else minus!: u;


symbolic smacro procedure rd!:minusp u; 
   if atom cdr u then minusp cdr u else minusp!: u;


symbolic smacro procedure rd!:onep u; 
   if atom cdr u then lessp(abs difference(1.0,cdr u),!!fleps1)
    else equal!:(bfone!*,bftrim!: u);


symbolic smacro procedure rd!:prin u; 
   bfprin!: bftrim!: (if atom cdr u then fl2bf cdr u else u);


symbolic smacro procedure rd!:zerop u; 
   if atom cdr u then zerop cdr u else equal(cadr u,0);


symbolic smacro procedure rdacos!* u; 
   (lambda x; mkround (if atom x then acos x else acos!* x)) convprec u;


symbolic smacro procedure rdacosh!* u; 
   (lambda x; mkround (if atom x then acosh x else acosh!* x)) convprec u;


symbolic smacro procedure rdacot!* u; 
   (lambda x; mkround (if atom x then acot x else difbf(pi!/2!*(),atan!* x)))
    convprec u;


symbolic smacro procedure rdacoth!* u; 
   (lambda x; mkround (if atom x then acoth x else atanh!* invbf x)) convprec u;


symbolic smacro procedure rdacsc!* u; 
   (lambda x; mkround (if atom x then acsc x else asin!* invbf x)) convprec u;


symbolic smacro procedure rdasec!* u; 
   (lambda x; 
       mkround (if atom x then asec x else difbf(pi!/2!*(),asin!* invbf x)))
    convprec u;


symbolic smacro procedure rdasin!* u; 
   (lambda x; mkround (if atom x then asin x else asin!* x)) convprec u;


symbolic smacro procedure rdasinh!* u; 
   (lambda x; mkround (if atom x then asinh x else asinh!* x)) convprec u;


symbolic smacro procedure rdatan!* u; 
   (lambda x; mkround (if atom x then atan x else atan!* x)) convprec u;


symbolic smacro procedure rdatanh!* u; 
   (lambda x; mkround (if atom x then atanh x else atanh!* x)) convprec u;


symbolic smacro procedure rdcos!* u; 
   (lambda x; mkround (if atom x then cos x else cos!* x)) convprec u;


symbolic smacro procedure rdcosh!* u; 
   (lambda x; mkround (if atom x then cosh x else cosh!* x)) convprec u;


symbolic smacro procedure rde!*; mkround (if !*!*roundbf then e!*() else !!ee);


symbolic smacro procedure rdhalf!*; if !*!*roundbf then bfhalf!* else 0.5;


symbolic smacro procedure rdlog!* u; 
   (lambda x; mkround (if atom x then log x else log!* x)) convprec u;


symbolic smacro procedure rdlog10!* u; 
   (lambda x; mkround (if atom x then log10 x else logb!*(x,bften!*)))
    convprec u;


symbolic smacro procedure rdnorm!* u; if rd!:minusp u then rd!:minus u else u;


symbolic smacro procedure rdone!*; if !*!*roundbf then bfone!* else 1.0;


symbolic smacro procedure rdpi!*; 
   mkround (if !*!*roundbf then pi!*() else !!pii);


symbolic smacro procedure rdprep1 u; 
   if atom cdr u then u else round!:mt(u,!:bprec!:);


symbolic smacro procedure rdqoterr; error(0,"zero divisor in quotient");


symbolic smacro procedure rdsec!* u; 
   (lambda x; mkround (if atom x then sec x else invbf cos!* x)) convprec u;


symbolic smacro procedure rdsech!* u; 
   (lambda x; mkround (if atom x then sech x else invbf cosh!* x)) convprec u;


symbolic smacro procedure rdsqrt!* u; 
   (lambda x; mkround (if atom x then sqrt x else bfsqrt x)) convprec u;


symbolic smacro procedure rdtwo!*; if !*!*roundbf then bftwo!* else 2.0;


symbolic smacro procedure rdzero!*; if !*!*roundbf then bfz!* else 0.0;


symbolic smacro procedure recursiveerror u; 
   msgpri(nil,u,"improperly defined in terms of itself",nil,t);


symbolic smacro procedure red!-char!-downcase u; 
   (lambda x; if x then cdr x else u) atsoc(u,charassoc!*);


symbolic smacro procedure red!-char!-upcase u; 
   (lambda x; if x then car x else u) rassoc(u,charassoc!*);


symbolic smacro procedure rederr u; 
   begin if not !*protfg then lprie u; error1() end;


symbolic smacro procedure remcomma u; 
   if eqcar(u,'!*comma!*) then cdr u else {u};


symbolic smacro procedure remfac u; factor1(u,nil,'factors!*);


symbolic smacro procedure reordsq u; cons(reorder car u,reorder cdr u);


symbolic smacro procedure rerror(packagename,number,message); 
   <>;


symbolic smacro procedure resetparser; if null !*slin then comm1 t;


symbolic smacro procedure resimpcar u; resimp car u;


symbolic smacro procedure rest x; cdr x;


symbolic smacro procedure revalpri u; maprin eval cadr u;


symbolic smacro procedure revalruletst u; 
   (lambda v; if neq(u,v) then let1 {v} else typerr(u,"rule list")) reval u;


symbolic smacro procedure reversip!* u; reversip u;


symbolic smacro procedure revop1 u; 
   if !*val then cons(car u,revlis cdr u) else u;


symbolic smacro procedure revpr u; cons(cdr u,car u);


symbolic smacro procedure rhs u; lhs!-rhs(u,'caddr);


symbolic smacro procedure rlispmain; lispeval '(begin);


symbolic smacro procedure rlistatp u; member(get(u,'stat),'(endstat rlis));


symbolic smacro procedure rmplus u; if eqcar(u,'plus) then cdr u else {u};


symbolic smacro procedure rmsubs; 
   begin 
      rplaca(!*sqvar!*,nil); 
      setq(!*sqvar!*,{t}); 
      setq(alglist!*,cons(nil,nil))
   end;


symbolic smacro procedure rnchoose!*(x,n); choose(rnfixchk x,rnfixchk n);


symbolic smacro procedure rnfix!* x; quotient(cadr x,cddr x);


symbolic smacro procedure rnilog2!* x; ilog2 rnfix!* x;


symbolic smacro procedure rnirootn!*(x,n); irootn(rnfix!* x,rnfixchk n);


symbolic smacro procedure rnminus!: u; cons(car u,cons(!:minus cadr u,cddr u));


symbolic smacro procedure rnonep!: u; and(equal(cadr u,1),equal(cddr u,1));


symbolic smacro procedure rnperm!*(x,n); perm(rnfixchk x,rnfixchk n);


symbolic smacro procedure rnprin u; 
   <>;


symbolic smacro procedure rnquotient!:(u,v); 
   mkrn(times2(cadr u,cddr v),times2(cddr u,cadr v));


symbolic smacro procedure rntimes!:(u,v); 
   mkrn(times2(cadr u,cadr v),times2(cddr u,cddr v));


symbolic smacro procedure rnzerop!: u; equal(cadr u,0);


symbolic smacro procedure round!* x; if atom cdr x then cdr x else x;


symbolic smacro procedure round2a!* a; if atom a then a else round!* a;


symbolic smacro procedure roundbfoff; 
   setq(!*!*roundbf,greaterp(!!rdprec,!!flprec));


symbolic smacro procedure roundbfon; setq(!*!*roundbf,t);


symbolic smacro procedure rplaca!*(u,v); rplaca(u,v);


symbolic smacro procedure rplacd!*(u,v); rplacd(u,v);


symbolic smacro procedure rread; <>;


symbolic smacro procedure rsverr x; 
   rerror('rlisp,13,{x,"is a reserved identifier"});


symbolic smacro procedure rtypepart u; 
   if getrtypecar u then 'yetunknowntype else nil;


symbolic smacro procedure rule_error u; rederr {"error in rule:",u,"illegal"};


symbolic smacro procedure s!:alwayseasy x; t;


symbolic smacro procedure s!:comdeclare(x,env,context); 
   begin if !*pwrds then <>
   end;


symbolic smacro procedure s!:comgetv(x,env,context); 
   if !*carcheckflag then s!:comcall(x,env,context)
    else s!:comval(cons('qgetv,cdr x),env,context);


symbolic smacro procedure s!:comiplus(x,env,context); 
   s!:comval(expand(cdr x,'iplus2),env,context);


symbolic smacro procedure s!:comitimes(x,env,context); 
   s!:comval(expand(cdr x,'itimes2),env,context);


symbolic smacro procedure s!:comlet(x,env,context); 
   s!:comval(cons('progn,s!:expand_let(cadr x,cddr x)),env,context);


symbolic smacro procedure s!:complus(x,env,context); 
   s!:comval(expand(cdr x,'plus2),env,context);


symbolic smacro procedure s!:comquote(x,env,context); 
   if leq(context,1) then s!:loadliteral(cadr x,env);


symbolic smacro procedure s!:comreturn(x,env,context); 
   s!:comreturn!-from(cons('return!-from,cons(nil,cdr x)),env,context);


symbolic smacro procedure s!:comspecform(x,env,context); 
   error(0,{"special form",x});


symbolic smacro procedure s!:comthe(x,env,context); 
   s!:comval(caddr x,env,context);


symbolic smacro procedure s!:comtimes(x,env,context); 
   s!:comval(expand(cdr x,'times2),env,context);


symbolic smacro procedure s!:comunless(x,env,context); 
   s!:comwhen(list!*('when,{'not,cadr x},cddr x),env,context);


symbolic smacro procedure s!:cout0 u; s!:cout1(u,nil);


symbolic smacro procedure s!:do!-endtest u; if null u then nil else car u;


symbolic smacro procedure s!:do!-result u; if null u then nil else cdr u;


symbolic smacro procedure s!:easyifarg x; 
   or(null cdr x,and(null cddr x,s!:iseasy cadr x));


symbolic smacro procedure s!:endlist l; setq(pendingrpars,cons(l,pendingrpars));


symbolic smacro procedure s!:eval_to_car_eq_safe x; 
   and(or(eqcar(x,'cons),eqcar(x,'list)),not null cdr x,
       s!:eval_to_eq_safe cadr x);


symbolic smacro procedure s!:eval_to_car_eq_unsafe x; 
   and(or(eqcar(x,'cons),eqcar(x,'list)),not null cdr x,
       s!:eval_to_eq_unsafe cadr x);


symbolic smacro procedure s!:expandblock u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:expanddeclare u; u;


symbolic smacro procedure s!:expandeval!-when u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:expandfletvars b; 
   cons(car b,cons(cadr b,s!:fully_macroexpand_list cddr b));


symbolic smacro procedure s!:expandfunction u; u;


symbolic smacro procedure s!:expandgo u; u;


symbolic smacro procedure s!:expandlabels u; s!:expandflet u;


symbolic smacro procedure s!:expandlet!* u; s!:expandlet u;


symbolic smacro procedure s!:expandmacrolet u; s!:expandflet u;


symbolic smacro procedure s!:expandmv!-call u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:expandprog u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:expandprogv u; 
   cons(car u,cons(cadr u,cons(caddr u,s!:fully_macroexpand_list cadddr u)));


symbolic smacro procedure s!:expandreturn!-from u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:expandtagbody u; s!:fully_macroexpand_list u;


symbolic smacro procedure s!:expandthe u; 
   cons(car u,cons(cadr u,s!:fully_macroexpand_list cddr u));


symbolic smacro procedure s!:explodes x; explode x;


symbolic smacro procedure s!:fslout0 u; s!:fslout1(u,nil);


symbolic smacro procedure s!:negate_jump x; 
   if atom x then get(x,'negjump) else rplaca(x,get(car x,'negjump));


symbolic smacro procedure s!:prinhex1 n; 
   princ schar("0123456789abcdef",logand(n,15));


symbolic smacro procedure s!:prinhex2 n; 
   <>;


symbolic smacro procedure s!:prinhex4 n; 
   <>;


symbolic smacro procedure s!:quotep x; 
   and(!*quotes,not atom x,equal(car x,'quote),not atom cdr x,null cddr x);


symbolic smacro procedure s!:r2i2when(name,args,b,lab,v); 
   cons(car b,s!:r2i2progn(name,args,cdr b,lab,v));


symbolic smacro procedure s!:r2iwhen(name,args,b,lab,v); 
   cons(car b,s!:r2iprogn(name,args,cdr b,lab,v));


symbolic smacro procedure s!:testneq(neg,x,env,lab); 
   s!:testequal(not neg,cons('equal,cdr x),env,lab);


symbolic smacro procedure s!:testnot(neg,x,env,lab); 
   s!:jumpif(not neg,cadr x,env,lab);


symbolic smacro procedure safe!-putd(name,type,body); 
   if getd name then lprim {"Autoload stub for",name,"not defined"}
    else putd(name,type,body);


symbolic smacro procedure savesession u; preserve 'begin;


symbolic smacro procedure sdl2sq(vd,sdl); 
   if equal(cdr vd,1) then univsdl2sq(caar vd,sdl) else mulvsdl2sq(vd,sdl);


symbolic smacro procedure searchtm term; 
   if or(atom term,atom car term) then nil
    else cons(caar term,searchpl cdr term);


symbolic smacro procedure second x; cadr x;


symbolic smacro procedure set!-modulus p; set!-general!-modulus p;


symbolic smacro procedure set!:const(cnst,l); save!:const(cnst,read!:lnum l);


symbolic smacro procedure setcloc!*; 
   setq(cloc!*,if null ifl!* then nil else cons(car ifl!*,cons(1,curline!*)));


symbolic smacro procedure setifngfl(v,y); 
   <>;


symbolic smacro procedure sfp u; and(not atom u,not atom car u);


symbolic smacro procedure sfpf u; and(not or(atom u,atom car u),sfp caaar u);


symbolic smacro procedure sgn x; 
   if greaterp(x,0) then 1 else if lessp(x,0) then minus 1 else 0;


symbolic smacro procedure showrulesdfn opr; 
   append(showrulesdfn1 opr,showrulesdfn2 opr);


symbolic smacro procedure shut u; shut_non_empty_list u;


symbolic smacro procedure sign!-of u; 
   (lambda s; and(numberp s,s)) car simp!-sign {u};


symbolic smacro procedure simp!*sq u; 
   if and(cadr u,null !*resimp) then car u else resimp1 car u;


symbolic smacro procedure simpcar u; simp car u;


symbolic smacro procedure simpconj u; conjsq simp!* car u;


symbolic smacro procedure simpexpon u; simpexpon1(u,'simp!*);


symbolic smacro procedure simpmax u; 
   s_simpmaxmin('max,function evalgreaterp,u,nil);


symbolic smacro procedure simpmin u; 
   s_simpmaxmin('min,function evallessp,u,nil);


symbolic smacro procedure sin!* u; sin!:(u,!:bprec!:);


symbolic smacro procedure sinh!* x; 
   (lambda y; csl_timbf(bfhalf!*,difbf(y,invbf y))) exp!* x;


symbolic smacro procedure sinitl u; set(u,eval get(u,'initl));


symbolic smacro procedure sort(l,pred); stable!-sortip(append(l,nil),pred);


symbolic smacro procedure sort!-factors l; sort(l,function orderfactors);


symbolic smacro procedure sortip(l,pred); stable!-sortip(l,pred);


symbolic smacro procedure split!-comfac!-part u; split!-comfac(u,1,1);


symbolic smacro procedure sq_member(u,v); 
   or(sf_member(u,car v),sf_member(u,cdr v));


symbolic smacro procedure sqrt!* u; sqrt!:(u,!:bprec!:);


symbolic smacro procedure ss2sf s; 
   if or(atom s,atom car s) then s else sdl2sq(car s,sdlist cadr xx2lx s);


symbolic smacro procedure stable!-sort(l,pred); 
   stable!-sortip(append(l,nil),pred);


symbolic smacro procedure strangeop u; nil;


symbolic smacro procedure string!-downcase u; 
   compress cons('!",append(explode2lc u,'(!")));


symbolic smacro procedure stringox u; 
   <>;


symbolic smacro procedure striptag u; if atom u then u else cdr u;


symbolic smacro procedure subs3f u; subs3f1(u,!*match,t);


symbolic smacro procedure take!-impart u; cons(impartf car u,cdr u);


symbolic smacro procedure take!-realpart u; cons(repartf car u,cdr u);


symbolic smacro procedure tan!* u; tan!:(u,!:bprec!:);


symbolic smacro procedure terminalp; and(!*int,null ifl!*);


symbolic smacro procedure terms u; 
   <>;


symbolic smacro procedure terpri0x; 
   if rterfn!* then lispeval {rterfn!*} else terpri();


symbolic smacro procedure terrlst(x,y); error(0,{x," invalid for ",y});


symbolic smacro procedure test_package m; 
   <>;


symbolic smacro procedure texmacsp; if getenv "TEXMACS_REDUCE_PATH" then t;


symbolic smacro procedure third x; caddr x;


symbolic smacro procedure tildepri u; <>;


symbolic smacro procedure times!:(n1,n2); 
   cons('!:rd!:,cons(times2(cadr n1,cadr n2),plus2(cddr n1,cddr n2)));


symbolic smacro procedure timesi!* u; cr!:times(cri!*(),u);


symbolic smacro procedure timesip x; and(eqcar(x,'times),memq('i,cdr x));


symbolic smacro procedure tm_coloredp ec; eqcar(ec,car tm_bprompt());


symbolic smacro procedure tm_compute!-prompt!-string(count,level); 
   tm_color tm_compute!-prompt!-string!-orig(count,level);


symbolic smacro procedure tm_eprompt; {'!],'!\,'! ,compress {'!!,5}};


symbolic smacro procedure tm_pruneltail(l,l1); 
   reversip tm_prunelhead(reversip l,l1);


symbolic smacro procedure tm_pslp; memq('psl,lispsystem!*);


symbolic smacro procedure tms u; tmsf car simp!* u;


symbolic smacro procedure tmsf!* u; 
   if and(numberp u,equal(abs fix u,1)) then 0 else tmsf u;


symbolic smacro procedure to(u,p); cons(u,p);


symbolic smacro procedure tokbquote; 
   begin 
      setq(crchar!*,readch1()); 
      setq(nxtsym!*,{'backquote,rread()}); 
      setq(ttype!*,3); 
      return nxtsym!*
   end;


symbolic smacro procedure token; token1();


symbolic smacro procedure toknump x; 
   or(numberp x,eqcar(x,'!:dn!:),eqcar(x,'!:int!:));


symbolic smacro procedure tokquote; 
   begin 
      setq(crchar!*,readch1()); 
      setq(nxtsym!*,mkquote rread()); 
      setq(ttype!*,4); 
      return nxtsym!*
   end;


symbolic smacro procedure traceset l; mapc(l,function traceset1);


symbolic smacro procedure treesizep(u,n); equal(treesizep1(u,n),0);


symbolic smacro procedure trimcrrl n; trimcr cadr n;


symbolic smacro procedure tstpolyarg(y,u); 
   and(null !*ratarg,neq(y,1),typerr(prepsq u,"polynomial"));


symbolic smacro procedure univariatep pol; 
   and(not or(atom pol,atom car pol),univariatep1(pol,caaar pol));


symbolic smacro procedure unreval u; 
   if or(atom u,null memq(car u,'(aeval reval))) then u else cadr u;


symbolic smacro procedure untraceset l; mapc(l,function untraceset1);


symbolic smacro procedure up u; factor1(u,t,'upl!*);


symbolic smacro procedure uppower(pol,var,n); 
   if equal(caaar pol,var) then uppower1(pol,var,n) else uppower2(pol,var,n);


symbolic smacro procedure validrule u; 
   (lambda x; if null x then nil else {x}) validrule1 u;


symbolic smacro procedure varname u; 
   if not idp car u then typerr(car u,"identifier") else setq(varnam!*,car u);


symbolic smacro procedure varss(v,d); 
   cons(cons(cons(v,nil),1),cons(cons(cons(cons(d,nil),1),nil),1));


symbolic smacro procedure vv!!!*1e10; setq(vv!!,times2(vv!!,10000000000.0));


symbolic smacro procedure writepri(u,v); assgnpri(eval u,nil,v);


symbolic smacro procedure xprinf(u,flg,w); 
   begin and(flg,prin2!* "("); xprinf2 u; and(flg,prin2!* ")") end;


symbolic smacro procedure xread u; 
   begin 
    a: 
      scan(); 
      if and(!*eoldelimp,eq(cursym!*,'!*semicol!*)) then go to a; 
      return xread1 u
   end;


symbolic smacro procedure xsimp u; expchk simp!* u;


symbolic smacro procedure xxsort l; 
   sort(l,function (lambda(a,b); lessp(termorder(car a,car b),0)));


symbolic smacro procedure yetunknowntypeeval(u,v); 
   reval1(eval!-yetunknowntypeexpr(u,v),v);


symbolic smacro procedure zfactor n; zfactor1(n,t);


symbolic smacro procedure znumrnil u; if znumr u then cons(nil,1) else u;


symbolic smacro procedure !*cr2crn u; 
   mkcrn(realrat trimcrrl u,realrat trimcr cddr u);


symbolic smacro procedure !*crn2rd n; 
   if not equal(car cddr n,0) then cr2rderr() else mkround chkrn!* r2bf cadr n;


symbolic smacro procedure !*crn2rn n; 
   if not equal(car cddr n,0) then cr2rderr() else cons('!:rn!:,cadr n);


symbolic smacro procedure !*ff2a(u,v); 
   (lambda x; if wtl!* then prepsq x else mk!*sq x) cancel cons(u,v);


symbolic smacro procedure !*gi2crn u; mkcrn(cons(cadr u,1),cons(cddr u,1));


symbolic smacro procedure !*i2mod u; !*modular2f general!-modular!-number u;


symbolic smacro procedure !*q2a1(u,v); if null v then mk!*sq u else prepsqxx u;


symbolic smacro procedure !*q2f u; 
   if equal(cdr u,1) then car u else typerr(prepsq u,'polynomial);


symbolic smacro procedure !*q2k u; 
   if kernp u then caaar car u else typerr(prepsq u,'kernel);


symbolic smacro procedure !*rd2crn u; 
   (lambda x; mkcrn(realrat x,cons(0,1))) round!* u;


symbolic smacro procedure !*rn2crn u; mkcrn(cdr u,cons(0,1));


symbolic smacro procedure !*rn2rd u; mkround chkrn!* r2bf cdr u;


symbolic smacro procedure add2inputbuf(u,mode); 
   begin 
      if or(null terminalp(),!*nosave!*) then return nil; 
      setq(inputbuflis!*,cons({statcounter,mode,u},inputbuflis!*))
   end;


symbolic smacro procedure aevalox u; mprino aevalox1 car u;


symbolic smacro procedure arrayeval(u,v); 
   if not atom u then rerror('rlisp,24,"Array arithmetic not defined") else u;


symbolic smacro procedure bfinverse u; 
   if atom u then quotient(1.0,u) else invbf u;


symbolic smacro procedure bfminus u; if atom u then minus u else minus!: u;


symbolic smacro procedure blocktyperr u; 
   rerror('rlisp,8,{u,"invalid except at head of block"});


symbolic smacro procedure bool!-eval u; lispeval u;


symbolic smacro procedure boolvalpri u; maprin cadr u;


symbolic smacro procedure c!:narg(x,env); 
   c!:cval(expand(cdr x,get(car x,'c!:binary_version)),env);


symbolic smacro procedure carx(u,v); 
   if null cdr u then car u
    else rerror('alg,5,{"Wrong number of arguments to",v});


symbolic smacro procedure chars2 u; chars21(u,0);


symbolic smacro procedure command1; 
   begin scan(); setcloc!*(); setq(key!*,cursym!*); return xread1 nil end;


symbolic smacro procedure convprec u; convchk round!* u;


symbolic smacro procedure cosh!* x; 
   (lambda y; csl_timbf(bfhalf!*,plubf(y,invbf y))) exp!* x;


symbolic smacro procedure cracsch!* u; crasinh!* cr!:quotient(i2cr!* 1,u);


symbolic smacro procedure crasec!* u; cracos!* cr!:quotient(i2cr!* 1,u);


symbolic smacro procedure crasech!* u; cracosh!* cr!:quotient(i2cr!* 1,u);


symbolic smacro procedure crasin!* u; cr!:minus timesi!* crasinh!* timesi!* u;


symbolic smacro procedure crcoth!* u; 
   (lambda(x,y); cr!:quotient(cr!:plus(x,y),cr!:differ(x,y)))
   (crexp!* cr!:times(i2cr!* 2,u),i2cr!* 1);


symbolic smacro procedure crcsc!* u; cr!:quotient(i2cr!* 1,crsin!* u);


symbolic smacro procedure crcsch!* u; 
   (lambda y; cr!:quotient(i2cr!* 2,cr!:differ(y,cr!:quotient(i2cr!* 1,y))))
    crexp!* u;


symbolic smacro procedure crsec!* u; cr!:quotient(i2cr!* 1,crcos!* u);


symbolic smacro procedure crsech!* u; 
   (lambda y; cr!:quotient(i2cr!* 2,cr!:plus(y,cr!:quotient(i2cr!* 1,y))))
    crexp!* u;


symbolic smacro procedure crsinh!* u; 
   (lambda y; cr!:times(crhalf!*(),cr!:differ(y,cr!:quotient(i2cr!* 1,y))))
    crexp!* u;


symbolic smacro procedure crtanh!* u; 
   (lambda(x,y); cr!:quotient(cr!:differ(x,y),cr!:plus(x,y)))
   (crexp!* cr!:times(i2cr!* 2,u),i2cr!* 1);


symbolic smacro procedure deg2dms!* u; 
   (lambda x; mklist3!* (if atom x then deg2dms x else deg2dms!: x))
    round2a!* u;


symbolic smacro procedure deg2rad!: x; 
   csl_normbf divide!:(csl_timbf(x,pi!*()),!:180!*,!:bprec!:);


symbolic smacro procedure dmoderr(u,v); 
   rerror('poly,10,
          {"Conversion between",
           get(u,'dname),"and",
           get(v,'dname),"not defined"});


symbolic smacro procedure errach u; 
   begin 
      terpri!* t; 
      lprie "CATASTROPHIC ERROR *****"; 
      printty u; 
      lpriw(" ",nil); 
      rerror('alg,4,
             
         "Please report output and input listing on the sourceforge bug tracker"
)
   end;


symbolic smacro procedure evalgeq(u,v); not evallessp(u,v);


symbolic smacro procedure expread; xread t;


symbolic smacro procedure fancy!-boolvalpri u; fancy!-maprin0 cadr u;


symbolic smacro procedure fancy!-mode u; 
   begin scalar m; 
      setq(m,lispeval u); 
      if eqcar(m,'!*sq) then setq(m,reval m); 
      return m
   end;


symbolic smacro procedure formlog2 sf; 
   cons(cons(mksp({'log,prepf sf},1),1),nil);


symbolic smacro procedure gf2cr!: x; 
   cons('!:cr!:,cons(striptag car x,striptag cdr x));


symbolic smacro procedure gfdiffer(u,v); 
   if atom car u then gffdiff(u,v) else gbfdiff(u,v);


symbolic smacro procedure gfdot(u,v); 
   if atom car u then gffdot(u,v) else gbfdot(u,v);


symbolic smacro procedure gidifference!:(u,v); 
   mkgi(difference(cadr u,cadr v),difference(cddr u,cddr v));


symbolic smacro procedure giplus!:(u,v); 
   mkgi(plus2(cadr u,cadr v),plus2(cddr u,cddr v));


symbolic smacro procedure i2crn!* u; mkcrn(cons(u,1),cons(0,1));


symbolic smacro procedure i2rd!* u; mkround chkint!* u;


symbolic smacro procedure idsort u; sort(u,function idcompare);


symbolic smacro procedure ieval u; !*s2i reval u;


symbolic smacro procedure initreduce; initrlisp();


symbolic smacro procedure isqrt x; 
   if leq(x,0) then terrlst(x,'isqrt) else irootn(fix x,2);


symbolic smacro procedure korder u; 
   <>;


symbolic smacro procedure lambdox u; 
   begin 
      omark '(m u); 
      setq(curmark,plus2(curmark,1)); 
      procox1('lambda,car u,cadr u)
   end;


symbolic smacro procedure let u; let0 u;


symbolic smacro procedure lispapply(u,v); 
   if null atom u then rerror('rlisp,2,{"Apply called with non-id arg",u})
    else apply(u,v);


symbolic smacro procedure lxsort l; 
   sort(l,function (lambda(a,b); lessp(termorder1(car a,car b),0)));


symbolic smacro procedure mkcr(u,v); cons('!:cr!:,cons(striptag u,striptag v));


symbolic smacro procedure mkfil u; 
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase u;


symbolic smacro procedure mkrootlsq(u,n); 
   if null u then !*d2q 1
    else if null !*reduced then mkrootsq(reval retimes u,n)
    else mkrootlsq1(u,n);


symbolic smacro procedure modcnv u; 
   rerror('poly,13,
          {"Conversion between modular integers and",
           get(car u,'dname),"not defined"});


symbolic smacro procedure noncomdel(u,v); 
   if null noncomp!* u then delete(u,v) else noncomdel1(u,v);


symbolic smacro procedure oblist; 
   sort(s!:oblist1(getv(!*package!*,1),nil),function orderp);


symbolic smacro procedure precision n; 
   <>;


symbolic smacro procedure prepcadr u; prepsq cadr u;


symbolic smacro procedure quotfxerr(u,v); rederr "exact division failed";


symbolic smacro procedure rad2deg!* u; 
   (lambda x; mkround (if atom x then rad2deg x else rad2deg!: x)) convprec u;


symbolic smacro procedure rd!:prep u; 
   if !*noconvert then rdprep1 u
    else if rd!:onep u then 1
    else if rd!:onep rd!:minus u then minus 1
    else rdprep1 u;


symbolic smacro procedure rdarg!* u; 
   if rd!:minusp u then rdpi!*() else rdzero!*();


symbolic smacro procedure rdcot!* u; 
   (lambda x; mkround (if atom x then cot x else tan!* difbf(pi!/2!*(),x)))
    convprec u;


symbolic smacro procedure rdcsc!* u; 
   (lambda x; mkround (if atom x then csc x else invbf sin!* x)) convprec u;


symbolic smacro procedure rdcsch!* u; 
   (lambda x; mkround (if atom x then csch x else invbf sinh!* x)) convprec u;


symbolic smacro procedure rdsin!* u; 
   (lambda x; mkround (if atom x then sin x else sin!* x)) convprec u;


symbolic smacro procedure rdsinh!* u; 
   (lambda x; mkround (if atom x then sinh x else sinh!* x)) convprec u;


symbolic smacro procedure rdtan!* u; 
   (lambda x; mkround (if atom x then tan x else tan!* x)) convprec u;


symbolic smacro procedure remf(u,v); 
   if null v then rerror('poly,201,"Zero divisor") else cdr qremf(u,v);


symbolic smacro procedure s!:cancel_local_decs w; unfluid w;


symbolic smacro procedure sfchk u; if sfp u then prepf u else u;


symbolic smacro procedure simpdiff u; 
   <>;


symbolic smacro procedure !*a2f u; !*q2f simp!* u;


symbolic smacro procedure !*q2a u; !*q2a1(u,!*nosq);


symbolic smacro procedure !*rd2cr u; 
   (lambda x; mkcr(x,if atom x then 0.0 else bfz!*)) convprec u;


symbolic smacro procedure cr2i!*; mkcr(rdzero!*(),rdtwo!*());


symbolic smacro procedure cr!:prep u; 
   crprep1 cons(rd!:prep cons('!:rd!:,cadr u),rd!:prep cons('!:rd!:,cddr u));


symbolic smacro procedure cr!:simp u; cons(gf2cr!: crprcd u,1);


symbolic smacro procedure cracsc!* u; crasin!* cr!:quotient(i2cr!* 1,u);


symbolic smacro procedure cre!*; mkcr(rde!*(),rdzero!*());


symbolic smacro procedure crhalf!*; mkcr(rdhalf!*(),rdzero!*());


symbolic smacro procedure cri!*; mkcr(rdzero!*(),rdone!*());


symbolic smacro procedure cri!/2; mkcr(rdzero!*(),rdhalf!*());


symbolic smacro procedure crlog!* u; mkcr(rdlog!* crnorm!* u,crarg!* u);


symbolic smacro procedure crone!*; mkcr(rdone!*(),rdzero!*());


symbolic smacro procedure crpi!*; mkcr(rdpi!*(),rdzero!*());


symbolic smacro procedure crr2d!* u; 
   mkcr(rad2deg!* cons('!:rd!:,cadr u),rad2deg!* cons('!:rd!:,cddr u));


symbolic smacro procedure crsqrt!* u; gf2cr!: gfsqrt crprcd u;


symbolic smacro procedure deg2rad!* u; 
   (lambda x; mkround (if atom x then deg2rad x else deg2rad!: x)) convprec u;


symbolic smacro procedure formlog sf; 
   if null cdr sf then formlogterm sf else cons(formlog2 sf,1);


symbolic smacro procedure cracos!* u; 
   cr!:plus(cr!:times(crhalf!*(),crpi!*()),timesi!* crasinh!* timesi!* u);


symbolic smacro procedure cracosh!* u; 
   crlog!* cr!:plus(u,crsqrt!* cr!:differ(cr!:times(u,u),i2cr!* 1));


symbolic smacro procedure cracot!* u; 
   cr!:times(cri!/2(),
             crlog!* cr!:quotient(cr!:differ(u,cri!*()),cr!:plus(cri!*(),u)));


symbolic smacro procedure cracoth!* u; 
   cr!:times(crhalf!*(),
             crlog!* cr!:quotient(cr!:plus(i2cr!* 1,u),cr!:differ(u,i2cr!* 1)));


symbolic smacro procedure cratan!* u; 
   cr!:times(cri!/2(),
             crlog!* cr!:quotient(cr!:plus(cri!*(),u),cr!:differ(cri!*(),u)));


symbolic smacro procedure cratanh!* u; 
   cr!:times(crhalf!*(),
             crlog!* cr!:quotient(cr!:plus(i2cr!* 1,u),cr!:differ(i2cr!* 1,u)));


symbolic smacro procedure crcosh!* u; 
   (lambda y; cr!:times(crhalf!*(),cr!:plus(y,cr!:quotient(i2cr!* 1,y))))
    crexp!* u;


symbolic smacro procedure crd2r!* u; 
   mkcr(deg2rad!* cons('!:rd!:,cadr u),deg2rad!* cons('!:rd!:,cddr u));


symbolic smacro procedure crexpt!*(u,v); 
   if cr!:zerop cr!:differ(v,crhalf!*()) then crsqrt!* u
    else crexp!* cr!:times(v,crlog!* u);


end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/support/entry.red0000644000175000017500000002354511526203062024066 0ustar  giovannigiovannimodule entry;   % Entry points for self-loading modules.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Using a modified version of the defautoload function of Eric Benson
% and Martin L. Griss.

% Extended for algebraic operators and values by Herbert Melenk.

fluid '(varstack!*);

if getd 'create!-package then create!-package('(entry),'(build));

symbolic procedure safe!-putd(name,type,body);
   % So that stubs will not clobber REAL entries preloaded.
   if getd name then lprim list("Autoload stub for",name,"not defined")
    else putd(name,type,body);

smacro procedure mkfunction u; list('function,u);

symbolic macro procedure defautoload u;
% (defautoload name), (defautoload name loadname),
% (defautoload name loadname fntype), or
% (defautoload name loadname fntype numargs)
% Default is 1 Arg EXPR in module of same name.
  begin scalar name,numargs,loadname,fntype;
    u := cdr u;
    name := car u;
    u := cdr u;
    if u then <> else loadname := name;
    if eqcar(name, 'quote) then name := cadr name;
    if atom loadname then loadname := list loadname
     else if car loadname eq 'quote then loadname := cadr loadname;
    if u then <> else fntype := 'expr;
    if u then numargs := car u else numargs := 1;
    u := if numargs=0 then nil
          else if numargs=1 then '(x1)
          else if numargs=2 then '(x1 x2)
          else if numargs=3 then '(x1 x2 x3)
          else if numargs=4 then '(x1 x2 x3 x4)
          else error(99,list(numargs,"too large in DEFAUTOLOAD"));
    name := mkquote name;
    return
       list('progn,
            list('put,name,mkquote 'number!-of!-args,numargs),
            list('safe!-putd,
                 name,
                 mkquote fntype,
                 mkfunction
                    list('lambda, u,
                         'progn .
                             aconc(for each j in loadname
                                      collect
                                         list('load!-package,mkquote j),
                                   list('lispapply,name,'list . u)))))
  end;

% Autoload support for algebraic operators and values.
%
%    defautoload_operator(opname,package);
%    defautoload_value(varname,package);
%

symbolic macro procedure defautoload_operator u;
  begin scalar name,package;
    name := cadr u; package := caddr u;
    return subla(list('name.name,'package.package),
     '(progn
        (flag '(name) 'full)
        (put 'name 'simpfn
          '(lambda(x)(autoload_operator!* 'name 'package x)))))
  end;

symbolic procedure autoload_operator!*(o,p,x);
   begin scalar varstack!*;
     remflag(list o,'full);
     remprop(o,'simpfn);
     if pairp p then for each pp in p do load!-package pp
        else load!-package p;
     return simp x;
   end;

symbolic macro procedure defautoload_value u;
  begin scalar name,package;
    u:=cdr u; name := car u; u:=cdr u; package := car u;
    return subla(list('name.name,'package.package),
     '(progn
        (put 'name 'avalue
          '(autoload_value!* name package))))
  end;

symbolic procedure autoload_value!*(u,v);
   begin scalar name,p,x,varstack!*;
     x:=get(u,'avalue);
     name := cadr x; p := caddr x;
     remprop(name,'avalue);
     load!-package p;
     return reval1(name,v);
   end;

put('autoload_value!*,'evfn,'autoload_value!*);

comment Actual Entry Point Definitions;

% Compiler and LAP entry points.

defautoload(compile,compiler);

if 'psl memq lispsystem!* then defautoload(lap,compiler)
 else defautoload(faslout,compiler);


% Cross-reference module entry points.

remd 'crefon;  % don't use PSL version

put('cref,'simpfg,'((t (crefon)) (nil (crefoff))));

defautoload(crefon,rcref,expr,0);


% Input editor entry points.

defautoload cedit;

defautoload(display,cedit);

put('display,'stat,'rlis);

defautoload(editdef,cedit);

put('editdef,'stat,'rlis);


% Factorizer module entry points.

switch trfac, trallfac;

remprop('factor,'stat);

defautoload(ezgcdf,ezgcd,expr,2);

defautoload(factorize!-primitive!-polynomial,factor);

defautoload(pfactor,factor,expr,2);

defautoload(simpnprimitive,factor);

put('nprimitive,'simpfn,'simpnprimitive);

put('factor,'stat,'rlis);


% FASL module entry points.

flag('(faslout),'opfn);

flag('(faslout),'noval);


% High energy physics module entry points.

remprop('index,'stat); remprop('mass,'stat);

remprop('mshell,'stat); remprop('vecdim,'stat);

remprop('vector,'stat);

defautoload(index,hephys);

defautoload(mass,hephys);

defautoload(mshell,hephys);

defautoload(vecdim,hephys);

defautoload(vector,hephys);

put('index,'stat,'rlis);

put('mshell,'stat,'rlis);

put('mass,'stat,'rlis);

put('vecdim,'stat,'rlis);

put('vector,'stat,'rlis);


% Integrator module entry points.

fluid '(!*trint);

switch trint;

defautoload(simpint,int);

put('int,'simpfn,'simpint);

put('algint,'simpfg,'((t (load!-package 'algint))));


% Matrix module entry points.

switch cramer;

put('cramer,'simpfg,
    '((t (put 'mat 'lnrsolvefn 'clnrsolve)
     (put 'mat 'inversefn 'matinv))
      (nil (put 'mat 'lnrsolvefn 'lnrsolve)
       (put 'mat 'inversefn 'matinverse))));

defautoload(detq,'(matrix)); % Used by high energy physics package.

defautoload(matp,'(matrix));

defautoload(matrix,'(matrix));

put('matrix,'stat,'rlis);

flag('(mat),'struct);

put('mat,'formfn,'formmat);

defautoload(formmat,'(matrix),expr,3);

defautoload(generateident,'(matrix));

defautoload(lnrsolve,'(matrix),expr,2);

defautoload(simpresultant,'(matrix));

defautoload(resultant,'(matrix),expr,3);

put('resultant,'simpfn,'simpresultant);

defautoload(nullspace!-eval,matrix);

put('nullspace,'psopfn,'nullspace!-eval);

% ODESolve entry point.

put('odesolve,'psopfn,'odesolve!-eval);

defautoload(odesolve!-eval,odesolve);

% Plot entry point.

put('plot,'psopfn,'(lambda(u) (load!-package 'gnuplot) (ploteval u)));

% Prettyprint module entry point (built into CSL).

if 'psl memq lispsystem!* then defautoload(prettyprint,pretty);

% Print module entry point.

% defautoload(horner,scope);

% global '(!*horner);

% switch horner;


% Rprint module entry point.

defautoload rprint;


% SOLVE module entry points.

defautoload(solveeval,solve);

defautoload(solve0,solve,expr,2);

% defautoload(solvelnrsys,solve,expr,2);      % Used by matrix routines.

% defautoload(!*sf2ex,solve,expr,2);   % Used by matrix routines.

put('solve,'psopfn,'solveeval);

switch allbranch,arbvars,fullroots,multiplicities,nonlnr,solvesingular;
%      varopt;

% Default values.

!*allbranch     := t;
!*arbvars       := t;
!*solvesingular := t;

put('arbint,'simpfn,'simpiden);

% Since the following three switches are set on in the solve module,
% they must first load that module if they are initially turned off.

put('nonlnr,'simpfg,'((nil (load!-package 'solve))));

put('allbranch,'simpfg,'((nil (load!-package 'solve))));

put('solvesingular,'simpfg,'((nil (load!-package 'solve))));


% Root finding package entry points.

defautoload roots;

defautoload(gfnewt,roots);

defautoload(gfroot,roots);

defautoload(root_val,roots);

defautoload(firstroot,roots);

defautoload(rlrootno,roots2);

defautoload(realroots,roots2);

defautoload(isolater,roots2);

defautoload(nearestroot,roots2);

defautoload(sturm0,roots2);

defautoload(multroot1,roots2);

for each n in '(roots rlrootno realroots isolater firstroot
                nearestroot gfnewt gfroot root_val)
   do put(n,'psopfn,n);

put('sturm,'psopfn,'sturm0);

switch trroot,rootmsg;

put('multroot,'psopfn,'multroot1);

switch fullprecision,compxroots;

% Limits entry points.

for each c in '(limit limit!+ limit!-) do
   <>;

defautoload(simplimit,limits);

% Partial fractions entry point.

defautoload(pf,pf,expr,2);

symbolic operator pf;


% Sum entry points.

defautoload(simp!-sum,sum);
defautoload(simp!-sum0,sum,expr,2);

put('sum,'simpfn,'simp!-sum);

defautoload(simp!-prod,sum);

put('prod,'simpfn,'simp!-prod);

switch zeilberg;

% Taylor entry points

put('taylor,'simpfn,'simptaylor);

defautoload(simptaylor,taylor);

% Trigsimp  entry points

put('trigsimp,'psopfn,'trigsimp!*);

defautoload(trigsimp!*,trigsimp);

% Specfn entry points

defautoload_operator(besselj,(specfn specbess));
defautoload_operator(bessely,(specfn specbess));
defautoload_operator(besseli,(specfn specbess));
defautoload_operator(besselk,(specfn specbess));
defautoload_operator(hankel1,(specfn specbess));
defautoload_operator(gamma,(specfn sfgamma));
defautoload_operator(binomial,specfn);

% Debug module entry points.

% if not(systemname!* eq 'ibm) then defautoload(embfn,debug,expr,3);


% Specfn entry points.

defautoload_operator(lambert_w,(specfn specbess));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/smacros0.red0000755000175000017500000000304211526203062024445 0ustar  giovannigiovanni% smacros.red - automatically generated from other source files

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% This file is one that can be copied to become just smacros.red in case
% you want a version with no "extra" smacros. Eg because you are concerned
% that use of extra smacros has introcuced bugs.

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/support/build.red0000644000175000017500000001002711526203062024013 0ustar  giovannigiovanni% module build;  % Code to help with bootstrapping REDUCE from Lisp.


% Author: Anthony C. Hearn.
% Modified by ACN for the Sourceforge version

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The baroque syntax in this file is a consequence of the bootstrapping
% process.

global '(loaded!-packages!*);

% A few functions will appear again in remake.red, and xslrend.red but
% they are needed at this stage during the bootstrap build of REDUCE.
% So perhaps to avoid repetition I could find somewhere even earlier to
% include it, but for now there is repetition to should be kept in step.


% Since some of the early modules may have tabs in them, we must redefine
% seprp.

symbolic procedure seprp u;
    or(eq(u,'! ),eq(u,'!	),eq(u,!$eol!$));

symbolic procedure mkfil u;
   % Converts file descriptor U into valid system filename.
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase u;

symbolic procedure string!-downcase u;
   begin scalar z;
      if not stringp u then u := '!" . append(explode2 u,'(!"))
      else u := explode u;
% This has to be written in the bootstrap kernel of the RLISP language
% and so looks a little ugly.
   a: if null u then return compress reverse z;
      z := red!-char!-downcase car u . z;
      u := cdr u;
      go to a;
   end;

fluid '(charassoc!*);

symbolic procedure red!-char!-downcase u;
   begin scalar x;
      x := atsoc(u,charassoc!*);
      if x then return cdr x
      else return u;
   end;

charassoc!* :=
         '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e) (!F . !f)
           (!G . !g) (!H . !h) (!I . !i) (!J . !j) (!K . !k) (!L . !l)
           (!M . !m) (!N . !n) (!O . !o) (!P . !p) (!Q . !q) (!R . !r)
           (!S . !s) (!T . !t) (!U . !u) (!V . !v) (!W . !w) (!X . !x)
           (!Y . !y) (!Z . !z));

symbolic procedure concat(u,v);
   compress('!" . append(explode2 u,nconc(explode2 v,list '!")));

% End of fudges. Note that this file is only used while bootstrapping so the
% redundant or non-optimised versions here do not persist into the final image.

symbolic procedure module2!-to!-file(u,v);
   % Converts the module u in package directory v to a fully rooted file
   % name.
   concat("$reduce/packages/",concat(mkfil v,
          concat("/",concat(mkfil u,".red"))));

symbolic procedure inmodule(u,v);
   begin
      u := open(module2!-to!-file(u,v),'input);
      v := rds u;
      cursym!* := '!*semicol!*;
   a: if eq(cursym!*,'end) then return progn(rds v, close u);
      prin2 eval form xread nil;
      go to a;
   end;

symbolic procedure load!-package!-sources(u,v);
   begin scalar !*int,!*echo,w;
      inmodule(u,v);
      if (w := get(u,'package)) then w := cdr w;
   a: if w then progn(inmodule(car w,v), w := cdr w, go to a);
      loaded!-packages!* := u . loaded!-packages!*;
   end;

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/cslrend.red0000644000175000017500000007714311570333441024366 0ustar  giovannigiovannimodule cslrend; % CSL REDUCE "back-end".

% Authors: Martin L. Griss and Anthony C. Hearn.
% Modified by Arthur Norman for use with CSL.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(cslrend csl),nil);

fluid '(!*break
        !*echo
        !*eolinstringok
        !*int
        !*mode
        !*raise
        !*lower
        !*keepsqrts
        outputhandler!*
        lispsystem!*);

global '(!$eol!$
         !*extraecho
         cr!*
         crchar!*
         date!*
         esc!*
         ff!*
         ifl!*
         ipl!*
         largest!-small!-modulus
         ofl!*
         spare!*
         statcounter
         crbuflis!*
         tab!*
         version!*
         author1!*
         author2!*
         loadable!-packages!*
         switches!*
         symchar!*);

author1!* := "A C Hearn, 2008";
author2!* := "Codemist Ltd, 2008";

% Lists of packages & switches updated July 2010

% Some of the "packages" listed here may be pre-loaded when Reduce starts,
% and some may really be internal utilities where it does not make sense
% for an end-user to load them. But these are the names used with the
% "create!-package" facility.

loadable!-packages!* := '(
acfsf         alg            algint         arith          arnum
assist        atensor        avector        boolean        camal
cantens       cedit          cgb            changevr       cl
compact       conlaw         crack          cvit           dcfsf
defint        desir          dfpart         dipoly         dummy
dvfsf         eds            excalc         ezgcd          factor
fide          fide1          fmprint        fps            ftr
gentran       gnuplot        groebner       groebnr2       groext
guardian      hephys         ibalp          ideals         ineq
int           invbase        laplace        lie            liepde
linalg        mathmlom       mathpr         matrix         misc
mma           modsr          module         mri            mrvlimit
ncpoly        noncom2        normform       numeric        odesolve
ofsf          orthovec       pasf           physop         plot
pm            poly           pretty         qepcad         qqe
qqe_ofsf      randpoly       rataprx        ratint         rcref
reacteqn      redlog         reduce4        reset          residue
rlfi          rlisp          rlisp88        rltools        roots
roots2        rprint         rsolve         scope          sets
sfgamma       solve          sparse         spde           specbess
specfaux      specfn         specfn2        sum            symmetry
tables        talp           taylor         tmprint        tplp
tps           tri            trigint        trigsimp       trigsimp
utf8          wu             xcolor         xideal         zeilberg
ztrans);

% This amazingly long list of switches was created as a by-product
% of building the bootstrap version of Reduce. In that build use of
% the directive that introduces switches is logged. Not all of these switches
% are really aimed at the general public, and almost all only apply when
% some particular module is loaded.

switches!* := '(
acinfo          adjprec         again           algint          algpri
allbranch       allfac          allowdfint      allpoly         anticom
arbvars         arnum           asterisk        backtrace       balanced_mod
balanced_was_on batch_mode      bcsimp          bezout          bfspace
boese           both            carcheckflag    carefuleq       centergrid
cgbcheckg       cgbcontred      cgbcounthf      cgbfaithful     cgbfullred
cgbgs           cgbreal         cgbsgreen       cgbstat         cgbupdb
cgbverbose      coates          combineexpt     combinelogs     commutedf
commuteint      comp            complex         compxroots      contract
cramer          cref            cvit            debug           debug_times
defn            demo            derexp          detectunits     dfint
dfprint         diffsoln        dispjacobian    distribute      div
dolzmann        double          dqegradord      dqeoptqelim     dqeoptsimp
dqeverbose      dummypri        dzopt           echo            edsdebug
edsdisjoint     edssloppy       edsverbose      eqfu            errcont
essl            evallhseqp      exdelt          exp             expanddf
expandexpt      expandlogs      ezgcd           f90             factor
factorprimes    factorunits     failhard        fancy           fancy_tex
fast_la         fastfor         faststructs     fastvector      fort
fortupper       fourier         ftch            fulleq          fullpoly
fullprec        fullprecision   fullroots       gbltbasis       gc
gcd             gdqe            gdsmart         gendecs         genpos
gentranopt      gentranseg      getdecs         gltbasis        groebfac
groebfullreduction              groebopt        groebprot       groebrm
groebstat       groebweak       gsugar          guardian        hack
hardzerotest    heugcd          horner          hyperbolic
ibalp_kapurdisablegb
ibalp_kapurgb   ibalp_kapurgbdegd               ibalpbadvarsel  ifactor
imaginary       imsl            inputc          instantiate     int
int_test        intern          intstr          kacem           keepdecs
lasimp          latex           lcm             lessspace       lexefgb
lhyp            limitedfactors  list            listargs        lmon
looking_good    lower           lower_matrix    lpdocoeffnorm   lpdodf
lpdotrsym       ltrig           makecalls       mathml          mcd
mod_was_on      modular         msg             multiplicities  multiroot
mymatch         nag             nat             native_code     nero
nested          noacn           noarg           nocommutedf     nocompile
noconvert       noetherian      noint           nointint        nolnr
nonlnr          nopowers        nosplit         nosturm         not_negative
notailcall      novarmsg        numval          odesolve_basis  odesolve_check
odesolve_diff   odesolve_equidim_y              odesolve_expand
odesolve_explicit               odesolve_fast   odesolve_full
odesolve_implicit
odesolve_noint  odesolve_norecurse              odesolve_noswap
odesolve_simp_arbparam          odesolve_verbose                onespace
only_integer    optdecs         ord             outerzeroscheck output
overview        partialint      partialintdf    partialintint   period
pgwd            plap            plotkeep        plotusepipe     prapprox
precise         precise_complex prefix          pret            prfourmat
pri             priall          primat          prlinineq       promptnumbers
psen            pvector         pwrds           qgosper_down
qgosper_specialsol
qsum_nullspace  qsum_trace      qsumrecursion_certificate
qsumrecursion_down
qsumrecursion_exp               qsumrecursion_profile           quotenewnam
r2i             raise           ranpos          rat             ratarg
rational        rationalize     ratpri          ratroot         red_total
redfront_mode   reduce4         reduced         revpri          rladdcond
rlanuexdebug    rlanuexdifferentroots           rlanuexgcdnormalize
rlanuexpsremseq rlanuexsgnopt   rlanuexverbose  rlbnfsac        rlbnfsm
rlbqlimits      rlbrop          rlcadans        rlcadaproj      rlcadaprojalways
rlcadbaseonly   rlcaddebug      rlcaddecdeg     rlcaddnfformula rlcadextonly
rlcadfac        rlcadfasteval   rlcadfulldimonly                rlcadhongproj
rlcadisoallroots                rlcadmc3        rlcadmcproj     rlcadpartial
rlcadpbfvs      rlcadpreponly   rlcadprojonly   rlcadrawformula rlcadrmwc
rlcadte         rlcadtree2dot   rlcadtrimtree   rlcadtv         rlcadverbose
rldavgcd        rlenffac        rlenffacne      rlgsbnf         rlgserf
rlgsprod        rlgsrad         rlgsred         rlgssub         rlgsutord
rlgsvb          rlhqeconnect    rlhqedim0       rlhqegbdimmin   rlhqegbred
rlhqestrconst   rlhqetfcfast    rlhqetfcfullsplit               rlhqetfcsplit
rlhqetheory     rlhqevarsel     rlhqevarselx    rlhqevb         rlidentify
rlisp88         rlkapurchkcont  rlkapurchktaut  rlmrivb         rlmrivb2
rlmrivbio       rlnzden         rlopt1s         rlourdet        rlparallel
rlpasfbapprox   rlpasfconf      rlpasfdnffirst  rlpasfexpand    rlpasfgauss
rlpasfgc        rlpasfsc        rlpasfses       rlpasfsimplify  rlpasfvb
rlpcprint       rlpcprintall    rlplsimpl       rlposden        rlpqeold
rlpscsgen       rlqeaprecise    rlqeasri        rlqedfs         rlqefb
rlqefilterbounds                rlqegen1        rlqegenct       rlqegsd
rlqeheu         rlqelog         rlqepnf         rlqeprecise     rlqeqsc
rlqesqsc        rlqesr          rlqesubi        rlqevarsel      rlqevarseltry
rlrealtime      rlresi          rlsetequalqhash rlsiatadv       rlsichk
rlsid           rlsiexpl        rlsiexpla       rlsifac         rlsifaco
rlsiidem        rlsimpl         rlsimplfloor    rlsipd          rlsiplugtheo
rlsipo          rlsipw          rlsism          rlsiso          rlsitsqspl
rlsiverbose     rlsmprint       rlsusi          rlsusiadd       rlsusigs
rlsusimult      rltabib         rltnft          rlverbose       rlvmatvb
rlxopt          rlxoptpl        rlxoptri        rlxoptric       rlxoptrir
rlxoptsb        rlxoptses       rootmsg         roundall        roundbf
rounded         rtrace          save_native     saveactives     savedef
savesfs         savestructr     semantic        sfto_musser     sfto_tobey
sfto_yun        show_grid       sidrel          simpnoncomdf    solvesingular
spec            specification   strip_native    symmetric       talpqegauss
talpqp          taylorautocombine               taylorautoexpand
taylorkeeporiginal              taylornocache   taylorprintorder
tdusetorder     tensor          test_plot       testecho        tex
texbreak        texindent       time            tr_lie          tra
tracefps        tracelimit      traceratint     tracespecfns    tracetrig
trallfac        trchrstrem      trcompact       trdesir         trdint
trfac           trfield         trgroeb         trgroeb1        trgroebr
trgroebs        trham           trigform        trint           trinvbase
trlinineq       trlinineqint    trlinrec        trmin           trnonlnr
trnumeric       trode           trplot          trpm            trroot
trsolve         trsum           trtaylor        trwu            trxideal
trxmod          twogrid         twosided        unsafecar       upper_matrix
useold          usetaylor       usez            utf8            utf82d
utf82dround     utf8diffquot    utf8exp         utf8expall      utf8pad
varopt          vectorc         verbatim        verboseload     vtrace
web             windexpri       wrchri          xfullreduce     xpartialint
xpartialintdf   xpartialintint  zb_factor       zb_inhomogeneous
zb_proof        zb_timer        zb_trace        zeilberg);

% Constants used in scanner.

flag('(define!-constant),'eval);

cr!* := compress(list('!!, special!-char 6));   % carriage return
ff!* := compress(list('!!, special!-char 5));   % form feed
tab!*:= compress(list('!!, special!-char 3));   % tab key


% One inessential reference to REVERSIP in this module (left unchanged).

% This file defines the system dependent code necessary to run REDUCE
% under CSL.

Comment The following functions, which are referenced in the basic
REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to
complete the definition of REDUCE:

        BYE
        EVLOAD
        ERROR1
        FILETYPE
        MKFIL
        ORDERP
        QUIT
        SEPRP
        SETPCHAR.

Prototypical descriptions of these functions are as follows;

remprop('bye,'stat);

symbolic procedure bye;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <>;

deflist('((bye endstat)),'stat);

remprop('quit,'stat);

symbolic procedure quit;
   %Returns control to the computer's operating system command level.
   %The current REDUCE job cannot be restarted;
   <>;

deflist('((quit endstat)),'stat);

% evload is now defined in cslprolo.red - this has to be the case
% so it can be used (via load_package) to load rlisp and cslrend.
% symbolic procedure evload l;
%   for each m in l do load!-module m;

symbolic procedure seprp u;
   % Returns true if U is a blank, end-of-line, tab, carriage return or
   % form feed.  This definition replaces the one in the BOOT file.
   u eq '!  or u eq tab!* or u eq !$eol!$ or u eq ff!* or u eq cr!*;

symbolic procedure filetype u;
   % Determines if string U has a specific file type.
   begin scalar v,w;
      v := cdr explode u;
      while v and not(car v eq '!.) do
        <) do v := cdr v;
          v := cdr v>>;
      if null v then return nil;
      v := cdr v;
      while v and not(car v eq '!") do <>;
      return intern compress reversip w
   end;

symbolic procedure mkfil u;
   % Converts file descriptor U into valid system filename.
   if stringp u then u
    else if not idp u then typerr(u,"file name")
    else string!-downcase u;


Comment The following functions are only referenced if various flags are
set, or the functions are actually defined. They are defined in another
module, which is not needed to build the basic system. The name of the
flag follows the function name, enclosed in parentheses:

        CEDIT (?)
        COMPD (COMP)
        EDIT1   This function provides a link to an editor. However, a
                definition is not necessary, since REDUCE checks to see
                if it has a function value.
        EMBFN (?)
        EZGCDF (EZGCD)
        PRETTYPRINT (DEFN --- also called by DFPRINT)
                This function is used in particular for output of RLISP
                expressions in LISP syntax. If that feature is needed,
                and the prettyprint module is not available, then it
                should be defined as PRINT
        RPRINT (PRET)
        TIME (TIME) returns elapsed time from some arbitrary initial
                    point in milliseconds;



Comment The following operator is used to save a REDUCE session as a
file for later use;

symbolic procedure savesession u;
   preserve('begin);

flag('(savesession),'opfn);

flag('(savesession),'noval);


Comment make "system" available as an operator;

flag('(system),'opfn);

flag('(system),'noval);


Comment to make "faslend" an endstat;

put('faslend,'stat,'endstat);


Comment The current REDUCE model allows for the availability of fast
arithmetical operations on small integers (called "inums").  All modern
LISPs provide such support.  However, the program will still run without
these constructs.  The relevant functions that should be defined for
this purpose are as follows;

flag('(iplus itimes iplus2 itimes2 iadd1 isub1 iminus iminusp
       idifference iquotient iremainder ilessp igreaterp ileq igeq
       izerop ionep apply1 apply2 apply3), 'lose);

Comment There are also a number of system constants required for each
implementation. In systems that don't support inums, the equivalent
single precision integers should be used;

% LARGEST!-SMALL!-MODULUS is the largest power of two that can
% fit in the fast arithmetic (inum) range of the implementation.
% This is constant for the life of the system and could be
% compiled in-line if the compiler permits it.

% As of December 2010 CSL will actually support up to 2^27, but until
% people have had several months to install a newly compiled CSL I will
% restrict myself to the limit that applied up until them.

largest!-small!-modulus := 2**24 - 1;

flag('(modular!-difference modular!-minus modular!-number
       modular!-plus modular!-quotient modular!-reciprocal
       modular!-times modular!-expt set!-small!-modulus
       safe!-modular!-reciprocal), 'lose);

% See comments about gensym() below - which apply also to the
% effects of having different random number generators in different
% host Lisp systems.
% From 3.5 onwards (with a new random generator built into the
% REDUCE sources) I am happy to use the portable version.

% flag('(random next!-random!-number), 'lose);

set!-small!-modulus 3;

% The following are now built into CSL, where by using the C library
% and (hence?) maybe low level tricks or special floating point
% microcode things can go fast.

flag('(acos acosd acosh acot acotd acoth acsc acscd acsch asec asecd
       asech asin asind asinh atan atand atan2 atan2d atanh cbrt cos
       cosd cosh cot cotd coth csc cscd csch exp expt hypot ln log
       logb log10 sec secd sech sin sind sinh sqrt tan tand tanh fix
       ceiling floor round clrhash puthash gethash remhash), 'lose);

% remflag('(int!-gensym1),'lose);

% symbolic procedure int!-gensym1 u;
% In Codemist Lisp compress interns - hence version in int.red may
% not work.  However, it seems to be ok for now.
%   gensym1 u;

% flag('(int!-gensym1),'lose);


global '(loaded!-packages!* no!_init!_file personal!-dir!*);

personal!-dir!* := "$HOME";

% symbolic procedure load!-patches!-file;
%    begin scalar !*redefmsg,file,x; % Avoid redefinition messages.
%       if memq('demo, lispsystem!*) then return;
%       if filep(file := concat(personal!-dir!*,"/patches.fsl")) then nil
%        else if filep(file :=
%           concat(get!-lisp!-directory(),"/patches.fsl"))
%         then nil
%        else return nil;
%       x := binopen(file,'input);
%       for i := 1:16 do readb x; % Skip checksum stuff.
%       load!-module x;   % Load patches.
%       close x;
%       if patch!-date!*
%         then startup!-banner concat(version!*,concat(", ",concat(date!*,
%                 concat(", patched to ",concat(patch!-date!*," ...")))));
%       for each m in loaded!-packages!* do
%          if (x := get(m,'patchfn)) then apply(x,nil)
%    end;
%
% % For compatibility with older versions.
%
% symbolic procedure load!-latest!-patches;
%    load!-patches!-file();

Comment We need to define a function BEGIN, which acts as the top-level
call to REDUCE, and sets the appropriate variables;

remflag('(begin),'go);

symbolic procedure begin;
  begin
     scalar w,!*redefmsg;
     !*echo := not !*int;
     !*extraecho := t;
     if modulep 'tmprint then <<
        w := verbos 0;
        load!-module 'tmprint;
        verbos w;
        if outputhandler!* = 'fancy!-output then fmp!-switch nil >>;
% If invoked from texmacs do something special...
     if getd 'fmp!-switch and member('texmacs, lispsystem!*) then <<
         w := verbos 0;
         fmp!-switch t;
         off1 'promptnumbers;
         verbos w >>
% If the tmprint module is loaded and I have a window that can support it
% I will display things in a "fancy" way within the CSL world.
     else if getd 'fmp!-switch then <<
        if member('showmath, lispsystem!*) then fmp!-switch t
        else if outputhandler!* = 'fancy!-output then fmp!-switch nil >>;
     ifl!* := ipl!* := ofl!* := nil;
     if date!* then <<
        verbos nil;
% The linelength may need to be adjusted if we are running in a window.
% To cope with this, CSL allows (linelength t) to set a "default" line
% length that can even vary as window sizes are changed. An attempt
% will be made to ensure that it is 80 at the start of a run, but
% (linelength nil) can return varying values as the user re-sizes the
% main window (in some versions of CSL). However this is still not
% perfect! The protocol
%   old := linelength nil;
%   
%   linelength old;
% can not restore the variability characteristic. However I make
%   old := linelength n; % n numeric or T
%   ...
%   linelength old;
% preserve things by returning T from (linelength n) in relevant cases.
        linelength t;
% The next four lines have been migrated into the C code in "restart.c"
% so that some sort of information gets back to the user nice and early.
%       prin2 version!*;
%       prin2 ", ";
%       prin2 date!*;
%       prin2t " ...";
        if getd 'addsq then <<
% I assume here that this is an algebra system if ADDSQ is defined, and
% in that case process an initialisation file. Starting up without ADDSQ
% defined means I either have just RLISP built or I am in the middle of
% some bootstrap process. Also if a variable no_init_file is set to TRUE
% then I avoid init file processing.
           !*mode := 'algebraic;
           if null no!_init!_file then begin
              scalar name;
              name := assoc('shortname, lispsystem!*);
              if atom name then name := "reduce"
              else name := list!-to!-string explode2lc cdr name;
              erfg!* := nil;
              read!-init!-file name end >>
        else !*mode := 'symbolic;
        % date!* := nil;
        >>;
% % If there is a patches module that is later than one that I currently
% % have installed then load it up now.
%      if version!* neq "REDUCE Development Version"
%        then load!-patches!-file();
     w := assoc('opsys, lispsystem!*);
     if not atom w then w := cdr w;
% For MOST systems I will let ^G (bell) be the escape character, but
% under win32 I use that as an interrupt character, and so there I go
% back and use ESC instead.  I do the check at BEGIN time rather than
% further out so that common checkpoint images can be used across
% systems.
     esc!*:= compress list('!!,
                special!-char (if w = 'win32 then 10 else 9));
     while errorp errorset('(begin1), !*backtrace, !*backtrace) do nil;
     prin2t "Leaving REDUCE ... "
  end;

flag('(begin),'go);


% ====================== Implements a REP for MPReduceJS.
remflag('(beginmpreduce),'go);

symbolic procedure beginmpreduce;
  begin
     scalar w,!*redefmsg;
     !*echo := not !*int;
     !*extraecho := t;
     if modulep 'tmprint then <<
        w := verbos 0;
        load!-module 'tmprint;
        verbos w;
        if outputhandler!* = 'fancy!-output then fmp!-switch nil >>;
% If invoked from texmacs do something special...
     if getd 'fmp!-switch and member('texmacs, lispsystem!*) then <<
         w := verbos 0;
         fmp!-switch t;
         off1 'promptnumbers;
         verbos w >>
% If the tmprint module is loaded and I have a window that can support it
% I will display things in a "fancy" way within the CSL world.
     else if getd 'fmp!-switch then <<
        if member('showmath, lispsystem!*) then fmp!-switch t
        else if outputhandler!* = 'fancy!-output then fmp!-switch nil >>;
     ifl!* := ipl!* := ofl!* := nil;
     if date!* then <<
        verbos nil;
% The linelength may need to be adjusted if we are running in a window.
% To cope with this, CSL allows (linelength t) to set a "default" line
% length that can even vary as window sizes are changed. An attempt
% will be made to ensure that it is 80 at the start of a run, but
% (linelength nil) can return varying values as the user re-sizes the
% main window (in some versions of CSL). However this is still not
% perfect! The protocol
%   old := linelength nil;
%   
%   linelength old;
% can not restore the variability characteristic. However I make
%   old := linelength n; % n numeric or T
%   ...
%   linelength old;
% preserve things by returning T from (linelength n) in relevant cases.
        linelength t;
% The next four lines have been migrated into the C code in "restart.c"
% so that some sort of information gets back to the user nice and early.
%       prin2 version!*;
%       prin2 ", ";
%       prin2 date!*;
%       prin2t " ...";
        if getd 'addsq then <<
% I assume here that this is an algebra system if ADDSQ is defined, and
% in that case process an initialisation file. Starting up without ADDSQ
% defined means I either have just RLISP built or I am in the middle of
% some bootstrap process. Also if a variable no_init_file is set to TRUE
% then I avoid init file processing.
           !*mode := 'algebraic;
           if null no!_init!_file then begin
              scalar name;
              name := assoc('shortname, lispsystem!*);
              if atom name then name := "reduce"
              else name := list!-to!-string explode2lc cdr name;
              erfg!* := nil;
              read!-init!-file name end >>
        else !*mode := 'symbolic;
        % date!* := nil;
        >>;
% % If there is a patches module that is later than one that I currently
% % have installed then load it up now.
%      if version!* neq "REDUCE Development Version"
%        then load!-patches!-file();
     w := assoc('opsys, lispsystem!*);
     if not atom w then w := cdr w;
% For MOST systems I will let ^G (bell) be the escape character, but
% under win32 I use that as an interrupt character, and so there I go
% back and use ESC instead.  I do the check at BEGIN time rather than
% further out so that common checkpoint images can be used across
% systems.
     esc!*:= compress list('!!,
                special!-char (if w = 'win32 then 10 else 9));
     
  end;

flag('(beginmpreduce),'go);


symbolic procedure mpreduceeval; errorset('(begin1), !*backtrace, !*backtrace) ;

% ==================

% The following function is used in some CSL-specific operations. It is
% also defined in util/rprint, but is repeated here to avoid loading
% that module unnecessarily, and because the definition given there is
% rather PSL specific.

remflag('(string!-downcase),'lose);

symbolic procedure string!-downcase u;
   compress('!" . append(explode2lc u,'(!")));

% princ!-upcase and princ!-downcase are used for fortran output

flag('(string!-downcase princ!-upcase princ!-downcase),'lose);

% This function is used in Rlisp '88.

symbolic procedure igetv(u,v); getv(u,v);

symbolic procedure iputv(u,v,w); putv(u,v,w);

% The following functions are NOT in Standard Lisp and should NOT be
% used anywhere in the REDUCE sources, but the amount of trouble I have
% had with places where they do creep in has encouraged me to define
% them here anyway and put up with the (small) waste of space.

symbolic procedure first x; car x;

symbolic procedure second x; cadr x;

symbolic procedure third x; caddr x;

symbolic procedure fourth x; cadddr x;

symbolic procedure rest x; cdr x;


Comment Initial setups for REDUCE;

spare!* := 0;    % We need this for bootstrapping.

symchar!* := t;  % Changed prompt when in symbolic mode.


% PSL has gensyms with names g0001, g0002 etc., and in a few places
% REDUCE will insert gensyms into formulae in such a way that their
% names can influence the ordering of terms.  The next fragment of
% commented out code make CSL use similar names (but interned).  This
% is not sufficient to guarantee a match with PSL though, since in (for
% instance) the code
%      list(gensym(), gensym(), gensym())
% there is no guarantee which gensym will have the smallest serial
% number.  Also if !*comp is true and the user defines a procedure it is
% probable that the compiler does a number (just how many we do not
% wish to say) of calls to gensym, upsetting the serial number
% sequence.  Thus other ways of ensuring consistent output from REDUCE
% are needed.

%- global '(gensym!-counter);

%- gensym!-counter := 1;

%- symbolic procedure reduce!-gensym();
%-   begin
%-     scalar w;
%-     w := explode gensym!-counter;
%-     gensym!-counter := gensym!-counter+1;
%-     while length w < 4 do w := '!0 . w;
%-     return compress ('g . w)
%-   end;

%- remflag('(gensym), 'lose);
%- remprop('gensym, 's!:builtin0);

%- smacro procedure gensym();
%-    reduce!-gensym();

% However, the current CSL gensym uses an upper case G as the root,
% which causes inconsistencies in some tests (e.g., int and qsum).
% This definition cures that.

symbolic smacro procedure gensym; gensym1 'g;


symbolic procedure initreduce;
   initrlisp();   % For compatibility.

symbolic procedure initrlisp;
  % Initial declarations for REDUCE
  <>;

symbolic procedure rlispmain;
    lispeval '(begin);

flag('(rdf preserve reclaim),'opfn);

flag('(rdf preserve),'noval);

flag('(load reload),'noform);

deflist('((load rlis) (reload rlis)),'stat);

symbolic macro procedure load x; PSL!-load(cdr x, nil);
symbolic macro procedure reload x; PSL!-load(cdr x, t);

global '(PSL!-loaded!*);
PSL!-loaded!* := nil;

symbolic procedure PSL!-load(mods, reloadp);
  for each x in mods do <<
    if reloadp or not member(x, PSL!-loaded!*) then <<
%      load!-module x;
       load!-package x;
       PSL!-loaded!* := union(list x, PSL!-loaded!*) >> >>;

symbolic macro procedure tr x;
   list('trace, list('quote, cdr x));

symbolic macro procedure untr x;
   list('untrace, list('quote, cdr x));

symbolic macro procedure trst x;
   list('traceset, list('quote, cdr x));

symbolic macro procedure untrst x;
   list('untraceset, list('quote, cdr x));

flag('(tr untr
      trst untrst
      ),'noform);

deflist('((tr rlis)     (trst rlis)
          (untr rlis)   (untrst rlis)
         ),'stat);

symbolic procedure prop x; plist x;  % Yukky PSL compatibility.

Comment The following declarations are needed to build various modules;

flag('(mkquote spaces subla boundp error1),'lose);

% The exact order of items in the lists produced by these is important
% to REDUCE.
flag('(union intersection), 'lose);

flag('(safe!-fp!-plus safe!-fp!-times safe!-fp!-quot
    ), 'lose);

% I USED to flag ordp as LOSE, but there are three different definitions in
% different places within Reduce and the LOSE mechanism is not quite
% refined enough to allow for the single one of them that has a version
% built into CSL directly.

flag('(threevectorp), 'lose);

deflist('((imports rlis)),'stat);

flag('(sort stable!-sort stable!-sortip),'lose);

% We also need this.

flag('(lengthc),'lose);

symbolic procedure concat2(u,v); concat(u,v);

symbolic procedure concat(u,v);
   % This would be better supported at a lower level.
   compress('!" . append(explode2 u,nconc(explode2 v,list '!")));

% Used by patching mechanism.
%
% Note that DESPITE the name this MUST be an interned symbol not a
% gensym since it will be used as the name of a function written out
% using FASLOUT and later re-loaded: gensym identities can not survive
% this transition.  The symbols created by dated!-name are almost
% always going to avoid clashes - see commentary in the CSL source file
% "extras.red" for an explanation.

symbolic procedure dated!-gensym u; dated!-name u;

% The following is intended to run the test on a single package.
% In due course I will improve it so it also checks the output,
% but even as it is I find it useful to be able to say
%        test_package solve;
% to test the solve package (etc).

symbolic procedure test_package m;
 << load!-module 'remake;
    test_a_package list m;
    0 >>; % because test_a_package restarts Reduce the result here should
          % never actually end up being delivered.

flag('(test_package), 'opfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/clrend.red0000644000175000017500000001237111526203062024167 0ustar  giovannigiovannimodule rend; % CL REDUCE "back-end".

% Copyright (c) 1993 RAND.  All Rights Reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(lispsystem!*);

lispsystem!* := '(cl);

symbolic procedure delcp u;
   % Returns true if U is a semicolon, dollar sign, or other delimiter.
   % This definition replaces one in the BOOT file.
   u eq '!; or u eq '!$;

symbolic procedure seprp u;
   % Returns true if U is a blank or other separator (eg, tab or ff).
   % This definition replaces one in the BOOT file.
     u eq '!  or u eq '!	 or u eq !$eol!$;

% Common LISP specific definitions.

flag('(load),'opfn);

% The next one is added since it is a familiar name for this operation.

symbolic procedure prop u; symbol!-plist u;

% A machine independent traceset. Tr and untr are defined in clend.lisp.

symbolic procedure traceset1 u;
   if atom u then u
    else if car u eq 'setq
     then list('progn,
               list('prin2,mkquote cadr u),
               '(prin2 " := "),
               u,
               list('prin2t,cadr u))
    else traceset1 car u . traceset1 cdr u;

symbolic procedure traceset u;
   if get(u,'original!-defn) then lprim list(u,"already traceset")
    else (if not x or not(eqcar(cdr x,'lambda)
                       or eqcar(cdr x,'lambda!-closure))
            then lprim list(u,"has wrong form for traceset")
           else <>)
          where x=getd u;

symbolic procedure untraceset u;
   (if x
      then <>
     else lprim list(u,"not traceset"))
    where x=get(u,'original!-defn);

symbolic procedure trst u; for each x in u do traceset x;

symbolic procedure untrst u; for each x in u do untraceset x;

deflist('((tr rlis) (untr rlis) (trst rlis) (untrst rlis)),'stat);


% The following function is necessary in Common Lisp startup sequence,
% since initial packages are not loaded with load-package.

symbolic procedure fixup!-packages!*;
   for each x in '(rlisp clrend entry poly arith alg mathpr) do
      if not(x memq loaded!-packages!*)
        then <>;


% The FACTOR module also requires a definition for GCTIME. Since this
% is currently undefined in CL, we provide the following definition.

symbolic procedure gctime; 0;

% yesp1 is more or less equivalent to y-or-n-p.

remflag('(yesp1),'lose);

symbolic procedure yesp1; y!-or!-n!-p();

flag('(yesp1),'lose);

% The Common Lisp TOKEN function returns tokens rather than characters,
% so CEDIT must be modified.

remflag('(cedit),'lose);

symbolic procedure cedit n;
   begin scalar x,ochan;
      if null terminalp() then rederr "Edit must be from a terminal";
      ochan := wrs nil;
      if n eq 'fn then x := reversip crbuf!*
       else if null n
        then if null crbuflis!*
               then <>
              else x := cdar crbuflis!*
       else if (x := assoc(car n,crbuflis!*))
        then x := cedit0(cdr x,car n)
       else <>;
      crbuf!* := nil;
      % Following line changed for CL version.
      x := foreach y in x conc explodec y;
      terpri();
      editp x;
      terpri();
      x := cedit1 x;
      wrs ochan;
      if x eq 'failed then nil
      % Following changed for CL version.
      else
        crbuf1!* := compress(append('(!") ,
                                       append(x, '(!" ))));
   end;

flag('(cedit),'lose);

% FLOOR is already defined.

flag('(floor),'lose);

% CL doesn't like '(function ...) in defautoload (module entry).

remflag('(mkfunction),'lose);

smacro procedure mkfunction u; mkquote u;

flag('(mkfunction),'lose);

% This function is used in Rlisp '88.

symbolic procedure igetv(u,v); getv(u,v);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/support.red0000644000175000017500000000305211526203062024430 0ustar  giovannigiovanni% module support;   % Support files for REDUCE build.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

!#if (memq 'psl lispsystem!*)
     create!-package('(support pslrend compat fastmath compat psl entry pslprolo),
                    NIL);

% This file is temporarily empty.

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/support/fastmath.red0000644000175000017500000001475311526203062024535 0ustar  giovannigiovannimodule fastmath;  % Definitions of key functions in the math module of
                  % arith.red using C versions.  This file should be
                  % loaded into REDUCE before the math module is loaded.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!!deg2rad !!rad2deg !!floatbits);

compiletime
  global '(!!fleps1exp !!plumaxexp !!pluminexp !!timmaxexp !!timminexp);

symbolic smacro procedure degreestoradians x; times2(x,!!deg2rad);

symbolic smacro procedure radianstodegrees x; times2(x,!!rad2deg);

remflag('(sin cos tan sind cosd tand cotd secd cscd asin acos atan
       asecd acscd atan2d atan2 sqrt exp log hypot cosh sinh tanh),
      'lose);

% ***** REMOVE THE FOLLOWING LINE WHEN FLOAT.C/EXTERNALS.SL UPDATED.

flag('(hypot cosh sinh tanh),'lose);

% ***** REMOVE THE FOLLOWING LINE WHEN WE KNOW HOW TO HANDLE COMPLEX
%       VALUES FOR ACOS, ASIN.

flag('(acos asin),'lose);

% Trig functions in radians.

symbolic procedure cos x;
   begin scalar result;
      x := float x;    % We put this here to make sure no GC can happen
                       % between gtfltn and mkfltn.
      result := gtfltn();
      uxcos(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure sin x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxsin(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure tan x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxtan(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure acos x;
   begin scalar result;
      if abs x> 1.0
        then error(99,list("argument to ACOS too large:",x));
      x := float x;
      result := gtfltn();
      uxacos(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure asin x;
   begin scalar result;
      if abs x> 1.0
        then error(99,list("argument to ASIN too large:",x));
      x := float x;
      result := gtfltn();
      uxasin(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure atan x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxatan(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure atan2(y,x);
   begin scalar result;
      x := float x;
      y := float y;
      result := gtfltn();
      uxatan2(floatbase result,floatbase fltinf y,floatbase fltinf x);
      return mkfltn result
   end;

% ASEC defined in math.red.


% Trig functions in degrees.

symbolic procedure sind x;
   sin degreestoradians x;

symbolic procedure cosd x;
   cos degreestoradians x;

symbolic procedure tand x;
   tan degreestoradians x;

symbolic procedure cotd x;
   cot degreestoradians x;

symbolic procedure secd x;
   sec degreestoradians x;

symbolic procedure cscd x;
   csc degreestoradians x;

symbolic procedure asecd x;
   radianstodegrees asec x;

symbolic procedure acscd x;
   radianstodegrees acsc x;

symbolic procedure atan2d(y,x);
   radianstodegrees atan2(y,x);


% Exponential, logarithm, power, square root, hypotenuse.

symbolic procedure exp x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxexp(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure log x;
   begin scalar result, ilog2x;
      if x <= 0.0
        then error(99,list("non-positive argument to LOG:",x))
       else if fixp(x) and (ilog2x:=ilog2(x)) > !!floatbits
        then return log2*(ilog2x - !!floatbits)
                 + log(x/2^(ilog2x - !!floatbits));
      x := float x;
      result := gtfltn();
      uxlog(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

% LOG10 in math.red.

symbolic procedure sqrt x;
   begin scalar result;
      if x < 0.0
        then error(99,list("negative argument to SQRT:",x));
      x := float x;
      result := gtfltn();
      uxsqrt(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure hypot(x,y);
   begin scalar result;
      x := float x;
      y := float y;
      result := gtfltn();
      uxhypot(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;


% Hyperbolic functions.

symbolic procedure cosh x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxcosh(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure sinh x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxsinh(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

symbolic procedure tanh x;
   begin scalar result;
      x := float x;
      result := gtfltn();
      uxtanh(floatbase result,floatbase fltinf x);
      return mkfltn result
   end;

(for each u in
   '(sin cos tan sind cosd tand cotd secd cscd asin acos atan
     asecd acscd atan2d atan2 sqrt exp log hypot cosh sinh tanh)
          do
     if getd intern bldmsg("%w%w",'ux,u) then flag(list u,'lose)
   ) where !*lower=nil;


% ***** REMOVE THE FOLLOWING LINE WHEN FLOAT.C/EXTERNALS.SL UPDATED.

REMFLAG('(HYPOT COSH SINH TANH),'LOSE);

% ***** REMOVE THE FOLLOWING LINE WHEN WE KNOW HOW TO HANDLE COMPLEX
%       VALUES FOR ACOS, ASIN.

REMFLAG('(ACOS ASIN),'LOSE);

remflag('(cond),'eval);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/0000755000175000017500000000000011722677361022020 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/splinalg.red0000644000175000017500000017634011526203062024321 0ustar  giovannigiovanni%***********************************************************************
%=======================================================================
%
% Code for the Linear Algebra for Sparse Matrices Package.
%
% Author: Stephen Scowcroft.                           Date: June 1995
%
%=======================================================================
%***********************************************************************

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module splinalg;

% This is the beginning of a Linear Algebra Package for Sparse Matrices.
% It stems from the present Linear Algebra Package for Matrices and
% will hopefully be incorporated into it to produce a new MATRIX
% package.

switch fast_la;  % If ON, then the following functions will be faster:

% spadd_columns    spadd_rows       spaugment_columns  spcolumn_dim    %
% spcopy_into      spmake_identity  spmatrix_augment   spmatrix_stack  %
% spminor          spmult_column    spmult_row         sppivot         %
% spremove_columns spremove_rows    sprows_pivot       spsquarep       %
% spstack_rows     spsub_matrix     spswap_columns     spswap_entries  %
% spswap_rows      spsymmetricp                                        %

% This is basically done by removing some error checking and doesn't
% speed things up too much. You'll need to be making alot of calls to
% see the difference. If you get strange error messages with fast_la
% ON then thoroughly check your input.

% Creates an identity matrix of dimension size.

symbolic procedure spmake_identity(size);
 begin scalar tm;
  if not !*fast_la and not fixp size then
     rederr "Error in spmake_identity: non integer input.";
  tm:=list('sparsemat,mkvect(size),list('spm,size,size));
    for i :=size step -1 until 1 do
    <>;
  return tm;
 end;

flag('(spmake_identity),'opfn);

% Finds the row-wise dimension of a matrix.

symbolic procedure sprow_dim(u);
 begin scalar res;
  if not !*fast_la and not matrixp(u) then
     rederr "Error in sprow_dim: input should be a matrix.";
  res := cadr spmatlength(u);
  return res;
 end;

% Finds the column-wise dimension of a matrix.

symbolic procedure spcol_dim(u);
 begin scalar res;
  if not !*fast_la and not matrixp(u) then
     rederr "Error in spcol_dim: input should be a matrix.";
  res := caddr spmatlength(u);
  return res;
 end;

flag('(sprow_dim,spcol_dim),'opfn);

% Test if input is a matrix or sparse matrix (boolean)
% Whether id is a gerneric matrix.

symbolic procedure matrixp(u);
 begin;
  if not pairp u then u:=reval u;
  if not eqcar(u,'mat) and not eqcar(u,'sparsemat) then return nil
   else return t;
 end;

flag('(matrixp),'boolean);
flag('(matrixp),'opfn);

% Test to see if input is a sparse matrix or not. (boolean)

symbolic procedure sparsematp(u);
 if not eqcar(u,'sparsemat) then nil
  else t;

flag('(sparsematp),'boolean);
flag('(sparsematp),'opfn);

% Tests matrix is square. (boolean).

symbolic procedure squarep(u);
begin
    scalar tmp;
    if not !*fast_la and not matrixp(u) then
     rederr "Error in squarep: non matrix input";
    if sparsematp(u) then tmp := cdr spmatlength(u)
     else tmp:=size_of_matrix(u);
    if car tmp neq cadr tmp
     then return nil
      else return t;
  end;

flag('(squarep),'boolean);
flag('(squarep),'opfn);

% Checks input is symmetric. ie: transpose(A) = A. (boolean).

symbolic procedure symmetricp(u);
  if eqcar(u,'sparsemat) then
   if smtp (u,nil) neq u then nil else t
  else
  if algebraic (tp(u)) neq u then nil else t;

flag('(symmetricp),'boolean);
flag('(symmetricp),'opfn);

% Takes a constant (const) and an integer (mat_dim) and creates
% a jordan block of dimension mat_dim x mat_dim.

symbolic procedure spjordan_block(const,mat_dim);
 begin scalar tm;
  tm :=mkempspmat(mat_dim,list('spm,mat_dim,mat_dim));
  if not fixp mat_dim then rederr
     "Error in spjordan_block(second argument): should be an integer.";
  for i:=mat_dim step -1 until 1 do
    <>;
    return tm;
  end;

flag ('(spjordan_block),'opfn);

% Removes row (row) and column (col) from in_mat.

symbolic procedure spminor(list,row,col);
 begin scalar len,lena,lenb,rlist;
  len:=caddr list;
  rlist :=copy_vect(list,nil);
  lena := cadr len;
  lenb := caddr len;
  if not matrixp(list) then
    rederr "Error in spminor(first argument): should be a matrix.";
  if not fixp row then
    rederr "Error in spminor(second argument): should be an integer.";
  if not fixp col then
    rederr "Error in spminor(third argument): should be an integer.";
  if not (row > 0 and row < lena + 1)
    then rerror(matrix,20,"Row number out of range");
  if not (col > 0 and col < lenb + 1)
   then rerror(matrix,21,"Column number out of range");

  spremrow(row,rlist);
  spremcol(col,rlist);
  rlist := rewrite(rlist,lena-1,row,col);
  return rlist;
 end;

flag('(spminor),'opfn);

% A square band matrix b is created. The elements of the diagonal
% are the middle element of elt_list. The elements to the left are
% used to fill the required number of subdiagonals and the elements
% to the right the superdiagonals.

symbolic procedure spband_matrix(elt_list,sq_size);
  begin scalar tm;
    integer i,j,it,no_elts,middle_pos;
    tm:=mkempspmat(sq_size,list('spm,sq_size,sq_size));
     if not fixp sq_size then rederr
     "Error in spband_matrix(second argument): should be an integer.";
    if atom elt_list then elt_list := {elt_list}
     else if car elt_list = 'list then elt_list := cdr elt_list
      else rederr
"Error in spband_matrix(first argument): should be single value or list.";
    no_elts := length elt_list;
    if evenp no_elts then rederr
"Error in spband matrix(first argument): number of elements must be odd.";
    middle_pos := reval{'quotient,no_elts+1,2};
    if my_reval middle_pos > sq_size then rederr
 "Error in spband_matrix: too many elements. Band matrix is overflowing.";
    it:=2;
    for i:=1:sq_size do
    << if i<=middle_pos then j:=1
        else j:=it;
       while middle_pos-i+j > 0 and
            j<=sq_size and middle_pos-i+j <= no_elts do
       <<
           letmtr3(list(tm,i,j),nth(elt_list,middle_pos-i+j),tm,nil);
           j:=j+1;
       >>;
        if i>middle_pos then it:=it+1;
    >>;
    return tm;
  end;

flag('(spband_matrix),'opfn);

% Stacks all rows pointed to in row_list to form a new matrix.
%
% row_list can be either an integer or a list of integers.

symbolic procedure spstack_rows(in_mat,row_list);
  begin scalar tl,rlist,res,list;
    integer rowdim,cnt,coldim;
    list:=in_mat;
    cnt:=1;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in spstack_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in spstack_rows(second argument): ";
      prin2t "      should be either an integer or a list of integers.";
        return;
      >>;
    coldim := spcol_dim(in_mat);
    rowdim := sprow_dim(in_mat);
    tl:=list('smp,length(row_list), coldim);
    res:=mkempspmat(length(row_list),tl);
   for each elt in row_list do
    <<
      if not fixp elt then rederr
       "Error in spstack_rows(second argument): contains non integer.";
      if elt>rowdim or elt=0 then
      <<
        prin2  "***** Error in spstack_rows(second argument): ";
        rederr "contains row number which is out of range for input matrix.";
      >>;
      rlist:= findrow(list,elt);
       if rlist = nil then cnt := cnt + 1
        else
         << letmtr3(list(res,cnt),rlist,res,nil);
            cnt := cnt + 1
         >>;
      >>;
    return res;
  end;

% Augments all columns pointed to in col_list to form a new matrix.
%
% col_list can be either an integer or a list of integers.

symbolic procedure spaugment_columns(in_mat,col_list);
  begin
    integer cnt,coldim,rcnt,rowdim;
    scalar tl,rlist,res,list,rrlist,colist,val,res1;
    list:=in_mat;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in spaugment_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2 "***** Error in spaugment_columns(second argument): ";
        prin2t
         "     should be either an integer or a list of integers.";
        return;
      >>;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    cnt:=1;
    rcnt:=1;
    tl := list('spm,rowdim,length(col_list));
    res:=mkempspmat(rowdim,tl);
    for each elt in col_list do
    << if not fixp elt then rederr
   "Error in spaugment_columns(second argument): contains non integer.";
       if elt>coldim or elt=0 then
       << prin2 "***** Error in spaugment_columns(second argument): ";
          rederr
       "contains column number which is out of range for input matrix.";
       >>;
     >>;
      for i:=1:rowdim do
      << rrlist:=findrow(list,i);
        if rrlist then
         <>;
            >>;
            if rlist then
             letmtr3(list(res,i),list(nil) . reverse rlist,res,nil);
            rlist := nil;
            cnt := 1;
         >>;
        >>;
    return res;
  end;

flag('(spstack_rows,spaugment_columns),'opfn);


% Input is a matrix and either a single row number or a list of row
% numbers.
%
% Extracts either a single row or a number of rows and returns them
% in a list of row matrices.

symbolic procedure spget_rows(in_mat,row_list);
  begin scalar tl,he,rlist,res,list,rlist1;
    integer rowdim,cnt,coldim;
    coldim:= spcol_dim(in_mat);
    tl:=list('spm,length(row_list), coldim);
    list:=in_mat;
    cnt:=1;
    if not matrixp(in_mat) then
     rederr "Error in spget_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in spget_rows(second argument): ";
      prin2t "      should be either an integer or a list of integers.";
        return;
      >>;
    rowdim := sprow_dim(in_mat);
   for each elt in row_list do
    <<
      if not fixp elt then rederr
       "Error in spget_rows(second argument): contains non integer.";
      if elt>rowdim or elt=0 then
      <<
        prin2  "***** Error in spget_rows(second argument): ";
        rederr "contains row number which is out of range for input matrix.";
      >>;
      rlist:= findrow(list,elt);
       if rlist = nil then nil
        else
         << rlist1:= mkempspmat(1,list('spm,1,coldim));
            letmtr3(list(rlist1,1),rlist,rlist1,nil);
            res:=append(res,{rlist1});
         >>;
      >>;

    return 'list.res;
  end;


% Input is a matrix and either a single column number or a list of
% column numbers.
%
% Extracts either a single column or a series of adjacent columns and
% returns them in a list of column matrices.

symbolic procedure spget_columns(in_mat,col_list);
  begin
    integer coldim,rcnt,rowdim;
    scalar tl,rlist,res,list,nlist,rrlist,colist,val,res1;
    rowdim:= sprow_dim(in_mat);
    tl := list('spm,rowdim,length col_list);
    list:=in_mat;
    if not matrixp(in_mat) then
     rederr "Error in spget_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2 "***** Error in spget_columns(second argument): ";
        prin2t
         "     should be either an integer or a list of integers.";
        return;
      >>;
    coldim := spcol_dim(in_mat);
    rcnt:=1;
    for each elt in col_list do
     << if not fixp elt then rederr
         "Error in spget_columns(second argument): contains non integer.";
        if elt>coldim or elt=0 then
          << prin2 "***** Error in get_columns(second argument): ";
              rederr
             "contains column number which is out of range for input matrix.";
          >>;
      >>;
     for each elt in col_list do
     <>;
              >>;
          >>;
            res := append(res,{rlist});
            rlist := nil;
            rcnt := 1;
       >>;
    return 'list.res;
  end;

flag('(spget_rows,spget_columns),'opfn);

% Removes each row in row_list from in_mat.
%
% row_list can be either an integer or a list of integers.

symbolic procedure spremove_rows(in_mat,row_list);
  begin
    scalar unique_row_list,list,tl;
    integer rowdim,row,cnt;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in spremove_rows(first argument): non matrix input.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in spremove_rows(second argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;
    % Remove any repititions in row_list (I'm assuming here that if the
    % user has inputted the same row more than once then the meaning
    % is to only remove that row once).
    unique_row_list := {};
    for each row in row_list do
    <<
      if not intersection({row},unique_row_list) then
       unique_row_list := append(unique_row_list,{row});
    >>;
    rowdim := sprow_dim(in_mat);
    if not !*fast_la then
    <<
      for each row in unique_row_list do if not fixp row then rederr
       "Error in spremove_rows(second argument): contains a non integer.";
      for each row in unique_row_list do if row>rowdim or row=0 then
       rederr
"Error in spremove_rows(second argument): out of range for input matrix.";
      if length unique_row_list = rowdim then
      <<
        prin2  "***** Warning in spremove_rows:";
        prin2t "      all the rows have been removed. Returning nil.";
        return nil;
      >>;
    >>;
       cnt:=0;
    tl:=list('spm,rowdim - length unique_row_list,spcol_dim(in_mat));
    list:=copy_vect(in_mat,tl);
     for each elt in unique_row_list do
      << spremrow(elt-cnt,list);
         list := rewrite(list,rowdim,elt-cnt,0);
         cnt := cnt + 1
       >>;
     return list;
  end;

% Removes each column in col_list from in_mat.
%
% col_list can be either an integer or a list of integers.

symbolic procedure spremove_columns(in_mat,col_list);
  begin
    scalar unique_col_list,tl,list;
    integer coldim,col,cnt;
    if  not !*fast_la and not matrixp(in_mat) then rederr
     "Error in spremove_columns(first argument): non matrix input.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2  "***** Error in spremove_columns(second argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;

    % Remove any repititions in col_list (I'm assuming here that if the
    % user has inputted the same column more than once then the meaning
    % is to only remove that column once).
    unique_col_list := {};
    for each col in col_list do
    <<
      if not intersection({col},unique_col_list) then
       unique_col_list := append(unique_col_list,{col});
    >>;
    coldim := spcol_dim(in_mat);
   if not !*fast_la then
    <<
      for each col in unique_col_list do if not fixp col then rederr
    "Error in spremove_columns(second argument): contains a non integer.";
      for each col in unique_col_list do if col>coldim or col=0 then
       rederr
   "Error in spremove_columns(second argument): out of range for matrix.";
      if length unique_col_list = coldim then
      <<
        prin2  "***** Warning in spremove_columns: ";
       prin2t "      all the columns have been removed. Returning nil.";
        return nil;
      >>;
    >>;
     cnt:=0;
     tl:=list('spm,sprow_dim(in_mat), coldim - length unique_col_list);
     list := copy_vect(in_mat,tl);
     for each elt in unique_col_list do
      << spremcol(elt-cnt,list);
         list := rewrite(list,coldim,0,elt-cnt);
         cnt := cnt + 1;
      >>;
     return list;

  end;


flag('(spremove_rows,spremove_columns),'opfn);

  % Creates a matrix consisting of rows*cols matrices which are taken
  % sequentially from the mat_list.

symbolic procedure spblock_matrix(rows,cols,mat_list);
  begin
    scalar block_mat,row_list;
    integer rowdim,coldim,start_row,start_col,i,j;
    if not fixp rows then rederr
     "Error in block_matrix(first argument): should be an integer.";
    if rows=0 then
    <<
      prin2  "***** Error in spblock_matrix(first argument): ";
      prin2t "      should be an integer greater than 0.";
      return;
    >>;
    if not fixp cols then rederr
     "Error in spblock_matrix(second argument): should be an integer.";
    if cols=0 then
    <<
     prin2  "***** Error in spblock_matrix(second argument): ";
      prin2t "      should be an integer greater than 0.";
      return;
    >>;
    if matrixp mat_list then mat_list := {mat_list}
     else if pairp mat_list and car mat_list = 'list then
     mat_list := cdr mat_list
      else
      <<
        prin2  "***** Error in spblock_matrix(third argument): ";
        prin2t
        "      should be either a single matrix or a list of matrices.";
        return;
      >>;
    if rows*cols neq length mat_list then rederr
 "Error in spblock_matrix(third argument): Incorrect number of matrices.";
    row_list := spcreate_row_list(rows,cols,mat_list);
    rowdim := spcheck_rows(row_list);
    coldim := spcheck_cols(row_list);
    block_mat := mkempspmat(rowdim,list('spm,rowdim,coldim));
    start_row := 1; start_col := 1;
    for i:=1:length row_list do
    <<
      for j:=cols step -1 until 1 do
      <<
        block_mat := spcopy_into(nth(nth(row_list,i),j),block_mat,
                                start_row,start_col);
        start_col := start_col + spcol_dim(nth(nth(row_list,i),j));
      >>;
      start_col := 1;
      start_row := start_row + sprow_dim(nth(nth(row_list,i),1));
    >>;
    return block_mat;
  end;

flag('(spblock_matrix),'opfn);

symbolic procedure spcreate_row_list(rows,cols,mat_list);
  %
  % Takes mat_list and creates a list of rows elements each of which is
  % a list containing cols elements (ordering left to right).
  % eg: create_row_list(3,2,{a,b,c,d,e,f}) will return
  %     {{a,b},{c,d},{e,f}}.
  %
  begin
    scalar row_list,tmp_list,list;
    integer i,j,increment;
    increment := 1;
    for i:=1:rows do
    <<
      tmp_list := {};
      for j:=1:cols do
      <>;
      row_list := append(row_list,{tmp_list});
    >>;
    return row_list;
  end;


symbolic procedure spcheck_rows(row_list);
  %
  % Checks all matrices in each element in row_list contains same
  % amount of rows.
  % Returns the sum of all of these row numbers (ie: number of rows
  % required in the block matrix).
  %
  begin
    integer i,listlen,rowdim,eltlen,j;
    i := 1;
    listlen := length(row_list);
    while i<=listlen do
    <<
      eltlen := length nth(row_list,i);
      j := 1;
      while j>;
      >>;
      rowdim := rowdim + sprow_dim(nth(nth(row_list,i),j));
      i := i+1;
    >>;
    return rowdim;
  end;

symbolic procedure spcheck_cols(row_list);
  %
  % Checks each element in row_list has same number of columns.
  % Returns this number.
  %
  begin
    integer i,listlen;
    i := 1;
    listlen := length(row_list);
    while i>;
  end;

symbolic procedure spno_rows(mat_list);
  %
  % Takes list of matrices and sums the no. of rows.
  %
  for each mat1 in mat_list sum sprow_dim(mat1);




symbolic procedure spno_cols(mat_list);
  %
  % Takes list of matrices and sums the no. of columns.
  %
  for each mat1 in mat_list sum spcol_dim(mat1);

% Copies matrix BB into AA with BB(1,1) at AA(p,q).

symbolic procedure spcopy_into(BB,AA,p,q);
  begin
    scalar A,B;
    integer m,n,r,c,val,j,col;
    if not !*fast_la then
    <<
      if not matrixp(BB) then rederr
       "Error in spcopy_into(first argument): should be a matrix.";
      if not matrixp(AA) then rederr
       "Error in spcopy_into(second argument): should be a matrix.";
      if not fixp p then rederr
       "Error in spcopy_into(third argument): should be an integer.";
      if not fixp q then rederr
       "Error in spcopy_into(fourth argument): should be an integer.";
      if p = 0 or q = 0 then
      <<
        prin2t
         "***** Error in spcopy_into: 0 is out of bounds for matrices.";
        prin2t
         "      The top left element is labelled (1,1) and not (0,0).";
        return;
      >>;
    >>;
    if not sparsematp(BB) then BB:=sptransmat(BB);
    m := sprow_dim(AA);
    n := spcol_dim(AA);
    r := sprow_dim(BB);
    c := spcol_dim(BB);
    if not !*fast_la and (r+p-1>m or c+q-1>n) then
    <<
      % Only print offending matrices if they're not too big.
      if m*n<26 and r*c<26 then
      <<
        prin2t "***** Error in spcopy_into: the matrix";
        myspmatpri2(BB);
        prin2t "      does not fit into";
        myspmatpri2(AA);
        prin2  "      at position ";
        prin2 p;
        prin2 ",";
        prin2 q;
        prin2t ".";
        return;
      >>
      else       <<
        prin2 "***** Error in spcopy_into: first matrix does not fit ";
        prin2 "      into second matrix at defined position.";
        return;
      >>;
    >>;
    a := copy_vect(aa,list('spm,m,n));
    for i:=r step -1 until 1 do
    << col:=findrow(bb,i);
       if col then
       <>;
       >>;
    >>;
    return a;
  end;

flag ('(spcopy_into),'opfn);

% Swaps row1 with row2.

symbolic procedure swaprow(ilist,row1,row2,len);
 begin scalar r1,r2,rlist,nlist,alist,a,b,cnt,aa,bb,list;
  list:=ilist;
  r1:=assoc(row1,list);
  r2:=assoc(row2,list);
  if r1=nil and not (r2 = nil)
    then << a:= row1; aa:=(row1 . cdr r2); b:=car r2>>
   else if r2 = nil and not (r1=nil)
     then << b:=row2; bb:=(row2 . cdr r1); a:=car r1>>
    else if not(r1=nil and r2=nil) then <>
     else cnt :=len + 1;
   cnt := 1;
   while not (cnt = len +1) do
    << if list = nil then alist := list(list)
        else alist:=car list;
       if car alist = a then
        << if r2 = nil then
            << if cnt = b then <>
                else if cnt = a then << nlist := nlist;
                                       list:=cdr list>>;
            >>
            else
             << rlist := (a . cdr r2);
                nlist := rlist . nlist;
                list := cdr list
             >>;
        >>
       else if car alist = b then
        << if r1 = nil then
            << if cnt = a then <>
                else if cnt=b then << nlist := nlist;
                                       list:=cdr list>>;
            >>
            else
             << rlist := (b . cdr r1);
                nlist := rlist . nlist;
                list := cdr list
             >>;
        >>
       else if r1=nil and not(cnt = len+1) and cnt = a  then
        nlist := aa . nlist
       else if r2=nil and not (cnt = len+1) and cnt = b  then
        nlist := bb . nlist
       else
        << if alist = '(nil) then nil
           else << nlist := alist . nlist;
                    list := cdr list>>
        >>;
        cnt := cnt + 1;
      >>;
   if nlist = nil then return ilist
    else return reverse nlist;
 end;


symbolic procedure spswap_rows(in_mat,row1,row2);
  begin
    scalar new_mat,list,pp,r1,r2;
    integer rowdim;
    list := copy_vect(in_mat,nil);
   % if not !*fast_la then  use later
    <<
      if not matrixp in_mat then
       rederr "Error in spswap_rows(first argument): should be a matrix.";
      rowdim := sprow_dim(in_mat);
      if not fixp row1 then rederr
       "Error in spswap_rows(second argument): should be an integer.";
      if not fixp row2 then
     rederr "Error in spswap_rows(third argument): should be an integer.";
      if row1>rowdim or row1=0 then rederr
  "Error in spswap_rows(second argument): out of range for input matrix.";
      if row2>rowdim or row2=0 then rederr
  "Error in spswap_rows(third argument): out of range for input matrix.";
    >>;
    if row1 < row2 then nil else <>;
    r1:=findrow(list,row1);
    r2:=findrow(list,row2);
    letmtr3(list(list,row1),r2,list,nil);
    letmtr3(list(list,row2),r1,list,nil);
    return list;
  end;

% Swaps col1 with col2.

symbolic procedure swapcol(ilist,col1,col2,len);
 begin scalar c1,c2,rlist,nlist,alist,a,b,aa,bb,cnt,rown,list,row;
  cnt := 1;
  for i:=len step -1 until 1 do
   << row:=findrow(ilist,i);
      if not (row=nil) then
      <<
      c1:=atsoc(col1,row);
      c2:=atsoc(col2,row);
      if c1=nil and not (c2 = nil)
        then << a:= col1; aa:=(col1 . cdr c2); b:=car c2>>
       else if c2 = nil and not (c1=nil)
        then << b:=col2; bb:=(col2 . cdr c1); a:=car c1>>
        else if not(c1=nil and c2=nil) then <>
         else cnt :=len + 1;
      rown:=i;
      list :=cdr row;
   while not (cnt = len + 1) do
    << if list = nil then alist:=list(list)
        else alist:=car list;
       if car alist = a then
        << if c2 = nil then
            << if cnt = b then <>
               else if cnt = a then <>;
            >>
            else
             <<  rlist := (a . cdr c2);
                 nlist := rlist . nlist;
                 list := cdr list
             >>
        >>
       else if car alist = b then
        << if c1 = nil then
            << if cnt = a then <>
                else if cnt = b then <>;
             >>
            else
             << rlist := (b . cdr c1);
                nlist := rlist . nlist;
                list := cdr list
             >>
        >>
      else if c1 = nil and not(cnt = len+1) and cnt = a  then
        nlist := aa . nlist
       else if c2 = nil and not (cnt = len+1) and cnt = b  then
        nlist := bb . nlist
       else
        << if alist = '(nil) then nil
            else
             << nlist := alist . nlist;
                list := cdr list>>;
        >>;
        cnt:=cnt + 1;
      >>;
    if nlist = nil then letmtr3(list(ilist,rown),list(nil) . list,ilist,nil)
     else letmtr3(list(ilist,rown),list(nil) . reverse nlist,ilist,nil);
    nlist := nil;
    cnt :=1;
    >>;
   >>;
    return ilist;
  end;


symbolic procedure spswap_cols(in_mat,col1,col2);
  begin
    scalar new_mat,list,pp;
    integer coldim;
    list:=copy_vect(in_mat,nil);
    if not !*fast_la then
    <<
      if not matrixp in_mat then rederr
       "Error in spswap_columns(first argument): should be a matrix.";
      coldim := spcol_dim(in_mat);
      if not fixp col1 then rederr
       "Error in spswap_columns(second argument): should be an integer.";
      if not fixp col2 then rederr
       "Error in spswap_columns(third argument): should be an integer.";
      if col1>coldim or col1=0 then rederr
     "Error in spswap_columns(second argument): out of range for matrix.";
      if col2>coldim or col2=0 then rederr
"Error in spswap_columns(third argument): out of range for input matrix.";
    >>;
  if col1 < col2 then nil else <>;
    new_mat := swapcol(list,col1,col2,caddr caddr in_mat);
    return new_mat;
  end;

% Swaps the two entries in in_mat.
%
% entry1 and entry2 must be lists of the form
% {row position,column position}.

symbolic procedure spswap_entries(in_mat,entry1,entry2);
  begin
    scalar new_mat;
    integer rowdim,coldim,val1,val2;
    if not matrixp(in_mat) then rederr
     "Error in spswap_entries(first argument): should be a matrix.";
    if atom entry1 or car entry1 neq 'list or length cdr entry1 neq 2
     then rederr
"Error in spswap_entries(second argument): should be list of 2 elements."
     else entry1 := cdr entry1;
     if atom entry2 or car entry2 neq 'list or length cdr entry2 neq 2
      then rederr
"Error in spswap_entries(third argument): should be a list of 2 elements."
      else entry2 := cdr entry2;
    if not !*fast_la then
    <<
      rowdim := sprow_dim(in_mat);
      coldim := spcol_dim(in_mat);
      if not fixp car entry1 then
      <<
        prin2  "***** Error in spswap_entries(second argument): ";
        prin2t "      first element in list must be an integer.";
        return;
      >>;
      if not fixp cadr entry1 then
      <<
        prin2  "***** Error in spswap_entries(second argument): ";
        prin2t "      second element in list must be an integer.";
        return;
      >>;
      if car entry1 > rowdim or car entry1 = 0 then
      <<
        prin2  "***** Error in spswap_entries(second argument): ";
        prin2t "      first element is out of range for input matrix.";
      return;
      >>;
      if cadr entry1 > coldim or cadr entry1 = 0 then
      <<
        prin2  "***** Error in spswap_entries(second argument): ";
        prin2t "      second element is out of range for input matrix.";
        return;
      >>;
      if not fixp car entry2 then
      <<
        prin2  "***** Error in spswap_entries(third argument): ";
        prin2t "      first element in list must be an integer.";
        return;
      >>;
      if not fixp cadr entry2 then
      <<
        prin2  "***** Error in spswap_entries(third argument): ";
        prin2t "      second element in list must be an integer.";
        return;
      >>;
      if car entry2 > rowdim or car entry2 = 0 then
      <<
        prin2  "***** Error in spswap_entries(third argument): ";
        prin2t "      first element is out of range for input matrix.";
        return;
      >>;
      if cadr entry2 > coldim then
      <<
        prin2  "***** Error in spswap_entries(third argument): ";
        prin2t "      second element is out of range for input matrix.";
        return;
      >>;
    >>;
    new_mat := copy_vect(in_mat,nil);
    val1:=findelem2(new_mat,car entry1,cadr entry1);
    val2:=findelem2(new_mat,car entry2,cadr entry2);
  %  if not (val2=0) then
    letmtr3(list(new_mat,car entry1,cadr entry1),val2,new_mat,nil);
   % if not (val1=0) then
    letmtr3(list(new_mat,car entry2,cadr entry2),val1,new_mat,nil);
  return new_mat;
  end;

flag('(spswap_rows,spswap_cols,spswap_entries),'opfn);

% Takes any number of matrices and joins them horizontally.
%
% Can take either a list of matrices or the matrices as seperate
% arguments.

% This function expands the columns of a matrix in ordere to augment it.

% A Further RE-WRITE function.
% Used to re-create elongated matrices.

symbolic procedure rewrite2(list,num);
 begin scalar val,oldcol,newcol,nlist;
  for each col in list do
   << val:=cdr col;
      oldcol:=car col;
      oldcol:=oldcol+num;
      newcol:=(oldcol . val);
      nlist:=newcol . nlist;
   >>;
  return reverse nlist;
  end;

symbolic procedure expan2(mlist,row,list);
 begin scalar rows,cols,rown,newcols,newrows,rlist,cnt,size;
  for i:=1:row do
  <>
                else <<
                       cols:=rewrite2(cols,cnt);
                       newcols:=append(newcols,cols);
                       cnt:=cnt + size;
                     >>;
             >>;
    >>;
     if not (newcols=nil) then
      <<
         letmtr3(list(list,i),list(nil) . newcols,list,nil);
      >>;
     newcols:=nil;
   >>;
  return list;
 end;

put('spmatrix_augment,'psopfn,'spmatrix_augment1);

symbolic procedure spmatrix_augment1(matrices);
  begin
    scalar mat_list,mat1,new_list,he,tl,num,row,col,list;
    integer cnt;
    if pairp matrices and pairp car matrices and caar matrices = 'list
     then matrices := cdar matrices;
    if not !*fast_la then
    <<
      mat_list := for each elt in matrices collect
         <>;
      for each elt in mat_list do
        if not matrixp(elt) then
         rederr "Error in spmatrix_augment: non matrix in input.";
    >>;
    spconst_rows_test(mat_list);
    mat1:=car mat_list;
    row:=sprow_dim(mat1);
    for each mat1 in mat_list do
    <>;
    col:=cnt;
    list:=mkempspmat(row,list('spm,row,col));
    new_list:=expan2(mat_list,row,list);
    return new_list;
  end;

% Takes any number of matrices and joins them vertically.
%
% Can take either a list of matrices or the matrices as seperate
% arguments.

put('spmatrix_stack,'psopfn,'spmatrix_stack1);

symbolic procedure spmatrix_stack1(matrices);
  begin
    scalar mat_list,new_list,he,tl,nam,row,col,list;
    integer cnt;
    if pairp matrices and pairp car matrices and caar matrices = 'list
     then matrices := cdar matrices;
    if not !*fast_la then
    <<
      mat_list := for each elt in matrices collect
       <>;
      for each elt in mat_list do
       if not matrixp(elt) then
        rederr "Error in spmatrix_stack: non matrix in input.";
    >>;
    spconst_columns_test(mat_list);
    col:=spcol_dim(car mat_list);
    for each mat1 in mat_list do
     << row:=sprow_dim(mat1);
        cnt := cnt + row;
     >>;
    row:=cnt;
    new_list:=mkempspmat(row,list('spm,row,col));
    cnt:=1;
    for each mat1 in mat_list do
    << row:=sprow_dim(mat1);
       for i:=1:row do
       << he:=findrow(mat1,i);
          if he then
            letmtr3(list(new_list,cnt),he,new_list,nil);
          cnt:=cnt+1;
        >>;
    >>;
    return new_list;
  end;

symbolic procedure spconst_rows_test(mat_list);
  %
  % Tests that each matrix in mat_list has the same number of rows
  % (otherwise augmentation not possible).
  %
  begin
    integer i,listlen,rowdim;
    listlen := length(mat_list);
    rowdim := sprow_dim(car mat_list);
    i := 1;
    while i>;
    if i=listlen then return rowdim
     else
     <<
       prin2  "***** Error in spmatrix_augment: ";
       rederr "all input matrices must have the same row dimension.";
     >>;
  end;



symbolic procedure spconst_columns_test(mat_list);
  %
  % Tests that each matrix in mat_list has the same number of columns
  % (otherwise stacking not possible).
  %
  begin
    integer i,listlen,coldim;
    listlen := length(mat_list);
    coldim := spcol_dim(car mat_list);
    i := 1;
    while i>;
    if i=listlen then return coldim
     else
     <<
       prin2  "***** Error in spmatrix_stack: ";
       rederr
        "all input matrices must have the same column dimension.";
       return;
     >>;
  end;

% Extends in_mat by rows rows (!) and cols columns. New entries are
% initialised to entry.

symbolic procedure spextend(in_mat,rows,cols,entry);
  begin
    scalar ex_mat;
    integer rowdim,coldim,i,j;
    if not matrixp(in_mat) then
     rederr "Error in spextend(first argument): should be a matrix.";
    if not fixp rows then
     rederr "Error in spextend(second argument): should be an integer.";
    if not fixp cols then
     rederr "Error in spextend(third argument): should be an integer.";
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    ex_mat := mkempspmat(rowdim+rows,list('smp,rowdim+rows,coldim+cols));
    ex_mat := spcopy_into(in_mat,ex_mat,1,1);
    for i:=rowdim+rows step -1 until rowdim+1 do
    <<
      for j:=coldim+cols step -1 until coldim+1 do
      <<
        letmtr3(list(ex_mat,i,j),entry,ex_mat,nil);
      >>;
    >>;
    return ex_mat;
  end;

flag('(spextend),'opfn);

% Can take either a list of arguments or the arguments seperately.
%
% Takes any number of either scalar entries or square matrices and
% creates the diagonal.

put('spdiagonal,'psopfn,'spdiagonal1); % To allow variable input.

symbolic procedure spdiagonal1(mat_list);
  begin
    scalar diag_mat;
     if pairp mat_list and pairp car mat_list and caar mat_list = 'list
     then mat_list := cdar mat_list;
    mat_list := for each elt in mat_list collect
                 << if not (sparsematp(aeval elt)) and not numberp elt
                        then sptransmat elt
                     else reval elt
                  >>;
    for each elt in mat_list do
    <<
      if matrixp(elt) and not squarep(elt) then
      <<
        % Only print offending matrix if it's not too big.
        if sprow_dim(elt)<5 or spcol_dim(elt)> 5 then
        <<
          prin2t "***** Error in spdiagonal: ";
          myspmatpri2(elt);
          prin2t "      is not a square matrix.";
          rederr "";
        >>
        else
         rederr "Error in spdiagonal: input contains non square matrix.";
      >>;
    >>;
    diag_mat := spdiag({mat_list});
    return diag_mat;
  end;

symbolic procedure spdiag(uu);
  %
  % Takes square or scalar matrix entries and creates a matrix with
  % these matrices on the diagonal.
  %
  begin
    scalar bigA,arg,input,u,val,a,b,col,j;
    integer nargs,Aidx,stp,bigsize,smallsize;

    u := car uu;
    input := u;
    bigsize:=0;

    nargs:=length input;
    for i:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 then bigsize:=bigsize+1
      else
      <<
        bigsize:=bigsize+sprow_dim(arg);
      >>;
      input := cdr input;
    >>;

    bigA := mkempspmat(bigsize,list('spm,bigsize,bigsize));
    Aidx:=1;
    input := u;
    for k:=1:nargs do
    <<
      arg:=car input;
      % If scalar entry.
      if algebraic length(arg) = 1 then
      <<
        letmtr3(list(bigA,Aidx,Aidx),arg,bigA,nil);
        Aidx:=Aidx+1;
        input := cdr input;
      >>
      else
      <<
        smallsize:= sprow_dim(arg);
        stp:=smallsize+Aidx-1;
        a:=1;
        for i:=Aidx:stp do
        << col:=findrow(arg,a);
           if col then
           << for each xx in cdr col do
              << val:=cdr xx;
                   j:=(Aidx-1)+car xx;
                 letmtr3(list(bigA,i,j),val,bigA,nil);
              >>;
           >>;
               a:=a+1;
        >>;
        Aidx := Aidx+smallsize;
        input := cdr input;
      >>;
    >>;

    return biga;
  end;

% Replaces row2 (r2) by mult1*r1 + r2.

symbolic procedure spadd_rows(in_mat,r1,r2,mult1);
  begin
    scalar new_mat,val,val1,val2,row1,row2;
    integer i,rowdim,coldim;
    coldim := spcol_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp in_mat then
       rederr "Error in spadd_rows(first argument): should be a matrix.";
      rowdim := sprow_dim(in_mat);
      if not fixp r1 then
     rederr "Error in spadd_rows(second argument): should be an integer.";
      if not fixp r2 then
     rederr "Error in spadd_rows(third argument): should be an integer.";
      if r1>rowdim or r1=0 then rederr
   "Error in spadd_rows(second argument): out of range for input matrix.";
      if r2>rowdim or r2=0 then rederr
   "Error in spadd_rows(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_vect(in_mat,nil);
    % Efficiency.
    if (my_reval mult1) = 0 then return new_mat;
    row1:=findrow(in_mat,r1);
    row2:=findrow(in_mat,r2);
    for each xx in cdr row1 do
    << i:=car xx;
       val1:=cdr xx;
       val2:=atsoc(i,row2);
       val:=reval {'times,mult1,val1};
       if val2 then
        <>
        else letmtr3(list(new_mat,r2,i),val,new_mat,nil);
     >>;
    return new_mat;
  end;

% Replaces column2 (c2) by mult1*c1 + c2.

symbolic procedure spadd_columns(in_mat,c1,c2,mult1);
  begin
    scalar new_mat,val;
    integer i,rowdim,coldim;
    rowdim := sprow_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp in_mat then
     rederr "Error in spadd_columns(first argument): should be a matrix.";
      coldim := spcol_dim(in_mat);
      if not fixp c1 then rederr
       "Error in spadd_columns(second argument): should be an integer.";
      if not fixp c2 then rederr
       "Error in spadd_columns(third argument): should be an integer.";
      if c1>coldim or c1=0 then rederr
"Error in spadd_columns(second argument): out of range for input matrix.";
      if c2>rowdim or c2=0 then rederr
 "Error in spadd_columns(third argument): out of range for input matrix.";
    >>;
    new_mat := copy_vect(in_mat,nil);
    if (my_reval mult1) = 0 then return new_mat;
    for i:=1:rowdim do
    <>;
    return new_mat;
  end;

flag('(spadd_rows,spadd_columns),'opfn);

% Adds value to each element in each row in row_list.
%
% row_list can be either an integer or a list of integers.

symbolic procedure spadd_to_rows(in_mat,row_list,value);
  begin
    scalar new_mat,col,val;
    integer i,rowdim,coldim;
    if not matrixp in_mat then
     rederr "Error in spadd_to_row(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in spadd_to_rows(second argument): ";
        prin2t "      should be either integer or a list of integers.";
        return;
      >>;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    new_mat := copy_vect(in_mat,nil);
    for each row in row_list do
    <<
      if not fixp row then rederr
       "Error in spadd_to_row(second argument): should be an integer.";
      if row>rowdim or row=0 then
      <<
        prin2  "***** Error in spadd_to_rows(second argument): ";
        rederr "contains row which is out of range for input matrix.";
      >>;
     >>;
     for each row in row_list do
      <>;
       >>;
     >>;
    return new_mat;
  end;

symbolic procedure spadd_to_columns(in_mat,col_list,value);
  %
  % Adds value to each element in each column in col_list.
  %
  % col_list can be either an integer or a list of integers.
  %
  begin
    scalar new_mat,col,val;
    integer i,rowdim,coldim;
    if not matrixp in_mat then rederr
     "Error in spadd_to_columns(first argument): should be a matrix.";
    if atom col_list then col_list := {col_list}
     else if car col_list = 'list then col_list := cdr col_list
      else
      <<
        prin2  "***** Error in spadd_to_columns(second argument): ";
        prin2t "      should be either integer or list of integers.";
        return;
      >>;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    new_mat := copy_vect(in_mat,nil);
    for each col in col_list do
    <<
      if not fixp col then rederr
      "Error in spadd_to_columns(second argument): should be an integer.";
      if col>coldim or col=0 then
      <<
        prin2  "***** Error in spadd_to_columns(second argument): ";
        rederr
         "contains column which is out of range for input matrix.";
      >>;
    >>;
      for i:=1:rowdim do
      <>
           else letmtr3(list(new_mat,i,xx),value,new_mat,nil);
       >>;
      >>;
    return new_mat;
  end;

flag('(spadd_to_rows,spadd_to_columns),'opfn);

% Replaces rows specified in row_list by row * mult1.

symbolic procedure spmult_rows(in_mat,row_list,mult1);
  begin
    scalar new_mat,col;
    integer i,rowdim,coldim,val;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in spmult_rows(first argument): should be a matrix.";
    if atom row_list then row_list := {row_list}
     else if car row_list = 'list then row_list := cdr row_list;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    new_mat := copy_vect(in_mat,nil);
    for each row in row_list do
    <<
      if not !*fast_la and not fixp row then rederr
       "Error in spmult_rows(second argument): contains non integer.";
      if not !*fast_la and (row>rowdim or row=0) then
      <<
        prin2  "***** Error in spmult_rows(second argument): ";
        rederr "contains row that is out of range for input matrix.";
      >>;
      col:=findrow(in_mat,row);
      if col then
      <>;
      >>;
    >>;
    return new_mat;
  end;

% Replaces columns specified in column_list by column * mult1.

symbolic procedure spmult_columns(in_mat,column_list,mult1);
  begin
    scalar new_mat,col;
    integer i,rowdim,coldim,val;
    if not !*fast_la and not matrixp(in_mat) then
    rederr "Error in spmult_columns(first argument): should be a matrix.";
    if atom column_list then column_list := {column_list}
    else if car column_list = 'list then column_list := cdr column_list;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    new_mat := copy_vect(in_mat,nil);
    for each column in column_list do
    <<
      if not !*fast_la and not fixp column then rederr
       "Error in spmult_columns(second argument): contains non integer.";
      if not !*fast_la and (column>coldim or column=0) then
      <<
        prin2  "***** Error in spmult_columns(second argument): ";
        rederr "contains column that is out of range for input matrix.";
      >>;
     >>;
      for i:=1:rowdim do
      << col:=findrow(in_mat,i);
         if col then
         <>;
         >>;
       >>;
    return new_mat;
  end;

flag('(spmult_rows,spmult_columns),'opfn);

% Create characteristic matrix. ie: C := lmbda*I - in_mat.
% in_ mat must be square.

symbolic procedure spchar_matrix(in_mat,lmbda);
  begin
    scalar charmat;
    integer rowdim;
    if not matrixp(in_mat) then
     rederr "Error in spchar_matrix(first argument): should be a matrix.";
    if not squarep(in_mat) then rederr
     "Error in spchar_matrix(first argument): must be a square matrix.";
    rowdim := sprow_dim(in_mat);
    charmat := {'plus,{'times,lmbda,spmake_identity(rowdim)},
               {'minus,in_mat}};
    return charmat;
  end;

% Finds characteristic polynomial of matrix in_mat.
% ie: det(lmbda*I - in_mat).

symbolic procedure spchar_poly(in_mat,lmbda);
  begin
    scalar chpoly,carmat;
    if not matrixp(in_mat) then
     rederr "Error in spchar_poly(first argument): should be a matrix.";
    carmat := spchar_matrix(in_mat,lmbda);
    chpoly := algebraic det(carmat);
    return chpoly;
  end;

flag('(spchar_matrix,spchar_poly),'opfn);

% Computes the Hermitian transpose (HT say) of in_mat.
%
% The (i,j)'th element of HT = conjugate of the (j,i)'th element of
% in__mat.

symbolic procedure sphermitian_tp(in_mat);
  begin
    scalar h_tp,element;
    integer ii,row,col;
    if not matrixp(in_mat) then
     rederr "Error in sphermitian_tp: non matrix input.";
    h_tp := algebraic tp(in_mat);
    for row:=1:sprow_dim(h_tp) do
    <>;
      >>;
     >>;
    return h_tp;
  end;

flag('(sphermitian_tp),'opfn);

% Removes the sub_matrix from A consisting of the rows in row_list and
% the columns in col_list. (Both row_list and col_list can be single
% integer values).

symbolic procedure spsub_matrix(A,row_list,col_list);
  begin
    scalar new_mat;
    if not !*fast_la and not matrixp(A) then rederr
     "Error in spsub_matrix(first argument): should be a matrix.";
    new_mat := spstack_rows(A,row_list);
    new_mat := spaugment_columns(new_mat,col_list);
    return new_mat;
  end;

flag('(spsub_matrix),'opfn);

% Converts all elements in pivot column (apart from the one in pivot
% row) to 0.

symbolic procedure sppivot(in_mat,pivot_row,pivot_col);
  begin
    scalar piv_mat,ratio,val,col,val1,val2;
    integer i,j,rowdim,coldim;
    if not !*fast_la and not matrixp(in_mat) then
     rederr "Error in sppivot(first argument): should be a matrix.";
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    if not !*fast_la then
    <<
    if not fixp pivot_row then
     rederr "Error in sppivot(second argument): should be an integer.";
    if pivot_row>rowdim or pivot_row=0 then rederr
     "Error in sppivot(second argument): out of range for input matrix.";
    if not fixp pivot_col then rederr
     "Error in sppivot(third argument): should be an integer.";
    if pivot_col>coldim or pivot_col=0 then rederr
     "Error in sppivot(third argument): out of range for input matrix.";
    if findelem2(in_mat,pivot_row,pivot_col) = 0 then
     rederr "Error in sppivot: cannot pivot on a zero entry.";
    >>;
    piv_mat := copy_vect(in_mat,nil);
    val2:=findelem2(in_mat,pivot_row,pivot_col);
    for i:=1:rowdim do
    << col:=findrow(in_mat,i);
       val1:=atsoc(pivot_col,col);
       if val1 then val1:=cdr val1;
       ratio := reval {'quotient,val1,val2};
       if col then
       <>
           else
           <>;
        >>;
      >>;
    >>;
    return piv_mat;
  end;

% Same as pivot but only rows a .. to .. b, where row_list = {a,b},
% are changed.
%
% rows_pivot will work if row_list is just an integer.

symbolic procedure sprows_pivot(in_mat,pivot_row,pivot_col,row_list);
  begin
    scalar piv_mat,ratio,val,col,val1,val2;
    integer j,rowdim,coldim;
    rowdim := sprow_dim(in_mat);
    coldim := spcol_dim(in_mat);
    if not !*fast_la then
    <<
      if not matrixp(in_mat) then
      rederr "Error in sprows_pivot(first argument): should be a matrix.";
      if not fixp pivot_row then
       rederr "Error in sprows_pivot(second argument): should be an integer.";
      if pivot_row>rowdim or pivot_row=0 then rederr
 "Error in sprows_pivot(second argument): out of range for input matrix.";
      if not fixp pivot_col then
       rederr "Error in sprows_pivot(third argument): should be an integer.";
      if pivot_col>coldim or pivot_col=0 then rederr
  "Error in sprows_pivot(third argument): out of range for input matrix.";
    >>;
    if atom row_list then row_list := {row_list}
     else if pairp row_list and car row_list = 'list
     then row_list := cdr row_list
      else
      <<
        prin2  "***** Error in sprows_pivot(fourth argument): ";
        prin2t
         "      should be either an integer or a list of integers.";
        return;
      >>;
    if findelem2(in_mat,pivot_row,pivot_col) = 0 then
     rederr "Error in sprows_pivot: cannot pivot on a zero entry.";
    piv_mat := copy_vect(in_mat,nil);
     val2:=findelem2(in_mat,pivot_row,pivot_col);
    for each elt in row_list do
    <<
      if not !*fast_la then
      <<
        if not fixp elt then rederr
         "Error in sprows_pivot: fourth argument contains a non integer.";
        if elt>rowdim or elt=0 then
        <<
          prin2  "***** Error in sprows_pivot(fourth argument): ";
          rederr "contains row which is out of range for input matrix.";
        >>;
      >>;
      if elt = pivot_row then nil
       else ratio := reval {'quotient,findelem2(in_mat,elt,pivot_col),val2};
       col:=findrow(in_mat,elt);
       if col then
       <>;
        >>;
      >>;
    return piv_mat;
  end;

flag('(sppivot,sprows_pivot),'opfn);

% jacobian(exp,var) computes the Jacobian matrix of exp w.r.t. var.
% The (i,j)'th entry is diff(nth(exp,i),nth(var,j)).

symbolic procedure spjacobian(exp_list,var_list);
  begin
    scalar jac,exp1,var1,val;
    integer i,j,rowdim,coldim;
    if atom exp_list then exp_list := {exp_list}
     else if car exp_list neq 'list then rederr
     "Error in spjacobian(first argument): expressions must be in a list."
      else exp_list := cdr exp_list;
    if atom var_list then var_list := {var_list}
     else if car var_list neq 'list then rederr
      "Error in jacobian(second argument): variables must be in a list."
      else var_list := cdr var_list;
    rowdim := length exp_list;
    coldim := length var_list;
    jac := mkempspmat(rowdim,list('spm,rowdim,coldim));
    for i:=1:rowdim do
    <<
      for j:=1:coldim do
      <<
        exp1 := nth(exp_list,i);
        var1 := nth(var_list,j);
        val:= algebraic df(exp1,var1);
        if val = 0 then nil
         else letmtr3(list(jac,i,j),val,jac,nil);
      >>;
    >>;
    return jac;
  end;

flag('(spjacobian),'opfn);

% variables can be either a list or a single variable.
%
% A Hessian matrix is a matrix whose (i,j)'th entry is
%       df(df(poly,nth(var,i)),nth(var,j))
%
% where df is the derivative.

symbolic procedure sphessian(poly,variables);
  begin
    scalar hess_mat,part1,part2,elt;
    integer row,col,sq_size;
    if atom variables then variables := {variables}
     else if car variables = 'list then variables := cdr variables
      else
      <<
        prin2  "***** Error in sphessian(second argument): ";
        prin2t
     "      should be either a single variable or a list of variables.";
        return;
      >>;
    sq_size := length variables;
    hess_mat := mkempspmat(sq_size,list('spm,sq_size,sq_size));
    for row:=1:sq_size do
    <<
      for col:=1:sq_size do
      <<
        part1 := nth(variables,row);
        part2 := nth(variables,col);
        elt := algebraic df(df(poly,part1),part2);
        if elt = 0 then nil
         else letmtr3(list(hess_mat,row,col),elt,hess_mat,nil);
      >>;
    >>;
    return hess_mat;
  end;

flag('(sphessian),'opfn);

% Given the system of linear equations, coeff_matrix returns {A,X,b}
% s.t. AX = b.
%
% Input can be either a list of linear equations or the linear
% equations as individual arguments.

% To allow variable input.
put('spcoeff_matrix,'psopfn,'spcoeff_matrix1);

symbolic procedure spcoeff_matrix1(equation_list);
  begin
    scalar variable_list,A,X,b;
    if pairp car equation_list and caar equation_list = 'list then
     equation_list := cdar equation_list;
    equation_list := remove_equals(equation_list);
    variable_list := get_variable_list(equation_list);
    if variable_list = nil then
     rederr "Error in spcoeff_matrix: no variables in input.";
    check_linearity(equation_list,variable_list);
    A := spget_A(equation_list,variable_list);
    X := spget_X(variable_list);
    b := spget_b(equation_list,variable_list);
    return {'list,A,X,b};
  end;

symbolic procedure remove_equals(equation_list);
  %
  % If any of the equations are equalities the equalities are removed
  % to leave a list of polynomials.
  %
  begin
     equation_list := for each equation in equation_list collect
      if pairp equation and car equation = 'equal then
       reval{'plus,cadr equation,{'minus,caddr equation}}
        else equation;
     return equation_list;
  end;

symbolic procedure get_variable_list(equation_list);
  %
  % Gets hold of all variables from the equations in equation_list.
  %
  begin
    scalar variable_list;
    for each equation in equation_list do
     variable_list := union(get_coeffs(equation),variable_list);
    return reverse variable_list;
  end;



symbolic procedure check_linearity(equation_list,variable_list);
  %
  % Checks that we really are dealing with a system of linear equations.
  %
  for each equation in equation_list do
  <<
    for each variable in variable_list do
    <<
      if deg(equation,variable) > 1 then
       rederr "Error in spcoeff_matrix: the equations are not linear.";
    >>;
  >>;



symbolic procedure spget_A(equation_list,variable_list);
  begin
    scalar A,element,var_elt,val;
    integer row,col,length_equation_list,length_variable_list;
    length_equation_list := length equation_list;
    length_variable_list := length variable_list;
    A := mkempspmat(length equation_list,
             list('spm,length equation_list,length variable_list));
    for row:=1:length_equation_list do
    <<
      for col:=1:length_variable_list do
      <<
        element := nth(equation_list,row);
        var_elt := nth(variable_list,col);
        val:=algebraic coeffn(element,var_elt,1);
        if val = 0 then nil
         else letmtr3(list(A,row,col),val,A,nil);
      >>;
    >>;
    return A;
  end;

symbolic procedure spget_b(equation_list,variable_list);
  %
  % Puts the integer parts of all the equations into a column matrix.
  %
  begin
    scalar substitution_list,integer_list,b;
    integer length_integer_list,row;
    substitution_list :=
     'list.for each variable in variable_list collect
                                               {'equal,variable,0};
    integer_list := for each equation in equation_list collect
      algebraic sub(substitution_list,equation);
    length_integer_list := length integer_list;
    b := mkempspmat(length_integer_list,list('spm,length_integer_list,1));
    for row:=1:length_integer_list do
     letmtr3(list(b,row,1),-nth(integer_list,row),b,nil);
    return b;
  end;



symbolic procedure spget_X(variable_list);
  begin
    scalar X;
    integer row,length_variable_list;
    length_variable_list := length variable_list;
    X := mkempspmat(length_variable_list,list('spm,length_variable_list,1));
    for row := 1:length variable_list do
     letmtr3(list(X,row,1),nth(variable_list,row),x,nil);
    return X;
  end;



symbolic procedure get_coeffs(poly);
  %
  % Gets all kernels in a poly.
  %
  begin
    scalar ker_list_num,ker_list_den;
    ker_list_num := kernels !*q2f simp reval num poly;
    ker_list_den := kernels !*q2f simp reval den poly;
    ker_list_num := union(ker_list_num,ker_list_den);
    return ker_list_num;
  end;

% Takes as input a monic univariate polynomial in a variable x.
% Returns a companion matrix associated with the polynomial poly(x).
%
% If C := companion(p,x) and p is a0+a1*x+...+x^n (a univariate monic
% polynomial), them C(i,n) = -coeff(p,x,i-1), C(i,i-1) = 1 (i=2..n)
% and C(i,j) = 0 for all other i and j.

symbolic procedure spcompanion(poly,x);
  begin
    scalar mat1;
    integer n,val;
    n := deg(poly,x);
    if my_reval coeffn(poly,x,n) neq 1 then msgpri
      ("Error in spcompanion(first argument): Polynomial",
      poly, "is not monic.",nil,t);

    mat1 := mkempspmat(n,list('smp,n,n));
    val:=coeffn(poly,x,0);
    if val=0 then nil
     else letmtr3(list(mat1,1,n),{'minus,val},mat1,nil);
    for i:=2:n do
    <<
      letmtr3(list(mat1,i,i-1),1,mat1,nil);
    >>;
    for j:=2:n do
    << val:=coeffn(poly,x,j-1);
       if val = 0 then nil
        else letmtr3(list(mat1,j,n),{'minus,val},mat1,nil);
    >>;
    return mat1;
  end;

% Given a companion matrix, find_companion will return the associated
% polynomial.

symbolic procedure spfind_companion(R,x);
  begin
    scalar  p;
    integer rowdim,k;
    if not matrixp(R) then rederr
     {"Error in spfind_companion(first argument): should be a matrix."};
    rowdim := sprow_dim(R);
    k := 2;
    while k<=rowdim and findelem2(R,k,k-1)=1 do k:=k+1;
    p := 0;
    for j:=1:k-1 do
    <<
      p:={'plus,p,{'times,{'minus,findelem2(R,j,k-1)},{'expt,x,j-1}}};
    >>;
    p := {'plus,p,{'expt,x,k-1}};
    return p;
  end;

flag('(spcompanion,spfind_companion),'opfn);

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

%in "splu_decomp.red";
%in "spsvd.red";
%in "spcholesky.red";
%in "spgramshm.red";


mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/spgrmshm.red0000644000175000017500000001067511526203062024346 0ustar  giovannigiovanni%**********************************************************************%
%                                                                      %
% Computation of the Gram Schmidt Orthonormalisation process. The      %
% input vectors are represented by lists.                              %
%                                                                      %
% Authors: Karin Gatermann (used symbolically in her symmetry package).%
%          Matt Rebbeck (first few lines of code that make it          %
%                        available from the user level).   May 1994.   %
%                                                                      %
% Extended by Stephen Scowcroft (June 1995) so that Sparse Vectors can %
% can be used.                                                         %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module spgrmshm;

symbolic procedure spgram_schmidt(vec_list);
  %
  % Can take a list of lists(which are representing vectors) or any
  % number of arguments each being a list(again which represent the
  % vectors).
  %
  % Karin used lists of standard quotient elements as vectors so a bit
  % of fiddling is required to get the input/output right.
  %
  begin
    scalar gs_list;
    vec_list:=cdr vec_list;
    % Deal with the possibility of the user entering a list of lists.
    if pairp vec_list and pairp car vec_list and caar vec_list = 'list
     and pairp cdar vec_list and pairp cadar vec_list
      and caadar vec_list = 'list
       then vec_list := cdar vec_list;
    vec_list := spconvert_to_sq(vec_list);
    % This bit does all the real work.
    gs_list := gram!+schmid(vec_list);
    return spconvert_from_sq(gs_list);
  end;

flag('(spgram_schmidt),'opfn);

symbolic procedure spconvert_to_sq(vec_list);
  %
  % Takes algebraic list and converts to sq form for input into
  % GramSchmidt.
  %
  begin
    scalar sq_list,val,res;
   for each list in vec_list do
   <>;
       >>;
      sq_list:=append(sq_list,list(reverse res));
      res:=nil;
    >>;

    return sq_list;
  end;

symbolic procedure spconvert_from_sq(sq_list);
  %
  % Converts sq_list to a readable (from algebraic mode) form.
  %
  begin
    scalar gs_list,cnt,res,val,len;
    for each elt1 in sq_list do
    << cnt:=0;
       len:=length elt1;
       res:=mkempspmat(len,list('spm,len,1));
      for each elt in elt1 do
       << val:=prepsq elt;
          if not (val = 0) then
           letmtr3(list(res,cnt:=cnt+1),list(nil) . list((1 . val)),res,nil)
           else cnt:=cnt+1;
       >>;
       gs_list:=append(gs_list,{res});
       res:=nil;
     >>;
    return 'list . gs_list;
  end;

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/spludcmp.red0000644000175000017500000003613611526203062024335 0ustar  giovannigiovanni%**********************************************************************%
%======================================================================%
%                                                                      %
% Computation of the LU decomposition of sparse unsymmetric matrices   %
% containing either numeric entries or complex numbers with numeric    %
% coefficients.                                                        %
%                                                                      %
% Author: Stephen Scowcroft                       Date: June 1995.     %
%          (based on code by Matt Rebbeck.)                            %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%                                                                      %
% NB: By using the same rounded number techniques as used in spsvd this%
%     could be made a lot faster.                                      %
%                                                                      %
%======================================================================%
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module spludcmp;

symbolic procedure splu_decom(in_mat);
  %
  % Runs the show!
  %
  begin
    scalar ans,I_turned_rounded_on;
    integer sq_size;
    if not matrixp(in_mat) then
     rederr "Error in splu_decom: non matrix input.";
    if not squarep(in_mat) then
     rederr "Error in splu_decom: input matrix should be square.";
    if not !*rounded then << I_turned_rounded_on := t; on rounded; >>;
    sq_size := sprow_dim(in_mat);
    if spcx_test(in_mat,sq_size) then ans := spcompdet(in_mat)
     else ans := spunsymdet(in_mat);
    if I_turned_rounded_on then off rounded;
    return ans;
  end;

flag('(splu_decom),'opfn);  % So it can be used from algebraic mode.

symbolic procedure spcx_test(in_mat,sq_size);
  %
  % Tests to see if any elts are complex. (boolean).
  %
  begin
    scalar bool,elt,col,val;
    integer i;
    i := 1;
    while not bool and i<=sq_size do
    << col:=findrow(in_mat,i);
      if not (col=nil) then
      << for each xx in cdr col do
          << elt := cdr xx;
             val:=algebraic impart(elt);
          if val neq 0 then <>;
           >>;
      >>;
      i := i+1;
    >>;
    return bool;
  end;

flag('(spcx_test),'boolean);

symbolic procedure spunsymdet(mat1);
  %
  % LU decomposition is performed on the unsymmetric matrix A.
  % ie: A := LU.
  % A record of any interchanges made to the rows of A is kept in
  % int_vec[i] (i=1...n) such that the i'th row and the int_vec[i]'th
  % row were interchanged at the i'th step.The procedure will fail if A,
  % modified by rounding errors, is singular or singular within the
  % bounds of the machine accuracy (ie: acc s.t. 1+acc > 1).
  %
  begin
    scalar x,y,in_mat,tmp,int_vec,L,U,col,tp_mat1,tp_mat2,val,col2;
    integer i,j,k,l,n;
    j := 1;
    in_mat := copy_vect(mat1,nil);
    n := sprow_dim(in_mat);
    int_vec := mkvect(n-1);
    for i:=1:n do
    << col:=findrow(in_mat,i);
      if col=nil then col:=list(nil);
      y := spinnerprod(1,1,n,0,col,col);
      putv(int_vec,i-1,{'quotient,1,{'sqrt,y}});
    >>;
    for k:=1:n do
    << tp_mat1:=copy_vect(smtp (in_mat,nil),nil);
      l := k;
      x := 0;
      col:=findrow(tp_mat1,k);
      if not (col=nil) then
      <=k then
        << y := spinnerprod(1,1,k-1,{'minus,val},findrow(in_mat,i),col);
        letmtr3(list(in_mat,i,k),reval {'minus,y},in_mat,nil);
        y := abs(get_num_part(reval{'times,y,getv(int_vec,i-1)}));
        if y>get_num_part(my_reval(x)) then
        <<
          x := y;
          l := i;
        >>;
        >>;
       >>;
       >>;
      if l neq k then
      << col:=findrow(in_mat,k);
         letmtr3(list(in_mat,k),findrow(in_mat,l),in_mat,nil);
         letmtr3(list(in_mat,l),col,in_mat,nil);
         putv(int_vec,l-1,getv(int_vec,k-1));
      >>;
      putv(int_vec,k-1,l);
      if get_num_part(my_reval(x)) <
          get_num_part(reval{'times,8,rd!-tolerance!*}) then rederr
"Error in splu_decom: matrix is singular. LU decomposition not possible.";
      x := {'quotient,{'minus,1},findelem2(in_mat,k,k)};
      tp_mat1:=copy_vect(smtp (in_mat,nil),nil);
      col:=findrow(in_mat,k);
      for each xx in cdr col do
      << j:=car xx;
         val := cdr xx;
         if j>=k+1 then
         <>;
      >>;
    >>;
    tmp := spget_l_and_u(in_mat,n);
    L := car tmp;
    U := cadr tmp;
    return {'list,L,U,int_vec};
  end;

symbolic procedure spinnerprod(l,s,u,c1,rowa,rowb);
  %
  % This procedure accumulates the sum of products vec_a*vec_b and adds
  % it to the initial value c1.  (ie: the scalar product).
  %
  begin
    scalar s1,d1,val1,val2,j;
    s1 := c1;
    d1 := s1;
    for each xx in cdr rowa do
    << j:=car xx;
       if j=nil then j:=0;
       val1:=cdr xx;
       if val1=nil or val1=list(nil) then val1:=0;
       if j<=u then
       << val2:=atsoc(j,rowb);
          if val2=nil or (val2=list(nil)) then nil
           else
          << s1 := {'plus,s1,{'times,val1,cdr val2}};
             d1:=s1;
          >>;
        >>;
     >>;
    return d1;
  end;



symbolic procedure spget_l_and_u(in_mat,sq_size);
  %
  % Takes the combined LU matrix and returns L and U.
  % sq_size is the no of rows (and columns) of in_mat.
  %
  begin
    scalar L,U,col;
    integer i,j,val;
    L := mkempspmat(sq_size,list('spm,sq_size,sq_size));
    U := mkempspmat(sq_size,list('spm,sq_size,sq_size));
    for i:=1:sq_size do
    << letmtr3(list(U,i,i),1,U,nil);
       col:=findrow(in_mat,i);
       for each xx in cdr col do
       << j:=car xx;
         val:=cdr xx;
         if j<=i then
         << letmtr3(list(L,i,j),val,L,nil)>>
         else if j>=i+1 then
         << letmtr3(list(U,i,j),val,U,nil)>>;
       >>;
    >>;
    return {L,U};
  end;


symbolic procedure spcompdet(mat1);
  %
  % LU decomposition is performed on the complex unsymmetric matrix A.
  % ie: A := LU.
  %
  % The calculation is computed in the nX2n matrix so that the general
  % element is a[i,2j-1]+i*a[i,2j]. A record of any interchanges made
  % to the rows of A is kept in int_vec[i] (i=1...n) such that the i'th
  % row and the int_vec[i]'th row were interchanged at the i'th step.
  % The determinant (detr+i*deti)*2^dete of A is also computed but has
  % been comented out as it is not necessary. The procedure will fail
  % if A, modified by rounding errors, is singular.
  %
  begin
    scalar x,y,in_mat,tmp,int_vec,L,U,p,pp,v,w,z,col,tp_mat1,rcol,recol,
           re,icol,imcol,im,rval,ival,rl,il,cl;
    integer i,j,k,l,n;
    if algebraic (det(mat1)) = 0 then rederr
"Error in splu_decom: matrix is singular. LU decomposition not possible.";
    j := 1;
    n := sprow_dim(mat1);
    in_mat := spim_uncompress(mat1,n);
    int_vec := mkvect(n-1);
    for i:=1:n do
    <>;
    for k:=1:n do
    <=k then
         << tmp := spcxinnerprod(1,1,k-1,rval,ival,spre_row_vec(cdr col),
                    spcx_row_vec(cddr col),findrow(tp_mat1,pp),
                    findrow(tp_mat1,p));
        x := car tmp;
        y := cadr tmp;
        letmtr3(list(in_mat,i,pp), reval x,in_mat,'cx);
        letmtr3(list(in_mat,i,p),reval y,in_mat,'cx);
        x := {'quotient,{'plus,{'expt,x,2},{'expt,y,2}},
                   getv(int_vec,i-1)};
        if get_num_part(reval(x))>get_num_part(reval(z)) then
        <<
          z := x;
          l := i;
        >>;
       >>;
        recol:=cdr recol;
        imcol:=cdr imcol;
      >>;
      >>;
      if l neq k then
      << col:=findrow(in_mat,k);
         letmtr3(list(in_mat,k),findrow(in_mat,l),in_mat,'cx);
         letmtr3(list(in_mat,l),col,in_mat,'cx);
         putv(int_vec,l-1,getv(int_vec,k-1));;
      >>;
      putv(int_vec,k-1,l);
      col:=findrow(in_mat,k);
      if col then col:=cdr col;
      tp_mat1:=copy_vect(smtp (in_mat,'cx),nil);
      x := atsoc(pp,col);
      if x then x:=cdr x;
       if x=list nil then x:=0;
      y := atsoc(p,col);
      if y then y:=cdr y;
       if y=list nil then y:=0;
      z := {'plus,{'expt,x,2},{'expt,y,2}};
      cl:=col;
      while col do
      << rcol:= car col;
           re:= car rcol;
         rval:= cdr rcol;
         if rval=list nil then rval:=0;
         icol:=cadr col;
           im:=car icol;
         ival:=cdr icol;
         if ival=list nil then ival:=0;
            j:=im / 2;
        if j>=k+1 then
       << p := j+j;
          pp := p-1;
         tmp := spcxinnerprod(1,1,k-1,rval,ival,
                  spre_row_vec(cl),spcx_row_vec(cdr cl),
                   findrow(tp_mat1,pp),findrow(tp_mat1,p));
        v := car tmp;
        w := cadr tmp;
        letmtr3(list(in_mat,k,pp), reval {'quotient,{'plus,{'times,v,x},
               {'times,w,y}},z},in_mat,'cx);
        letmtr3(list(in_mat,k,p), reval {'quotient,{'plus,{'times,w,x},
               {'minus,{'times,v,y}}},z},in_mat,'cx);
      >>;
      col:=cddr col;
    >>;
   >>;
    in_mat := spim_compress(in_mat,n);
    tmp := spget_l_and_u(in_mat,n);
    L := car tmp;
    U := cadr tmp;
    return {'list,L,U,int_vec};
  end;

symbolic procedure spcxinnerprod(l,s,u,cr,ci,vec_ar,vec_ai,vec_br,vec_bi);
  %
  % Computes complex innerproduct.
  %
  begin
    scalar h,dr,di;
    h := spinnerprod(l,s,u,{'minus,cr},vec_ar,vec_br);
    dr := spinnerprod(l,s,u,{'minus,h},vec_ai,vec_bi);
    h := spinnerprod(l,s,u,{'minus,ci},vec_ai,vec_br);
    di := {'minus,spinnerprod(l,s,u,h,vec_ar,vec_bi)};
    return {dr,di};
  end;



symbolic procedure spcx_row_vec(list);
  %
  % Takes uncompressed matrix and creates a list consisting of the
  % complex elements of a row.
  %
  begin
    scalar imcol,nlist,val;
    integer coln;
    while list do
    << imcol:=car list;
         val:=cdr imcol;
        coln:=car imcol;
        coln:=coln / 2;
       imcol:= coln . val;
       nlist := imcol . nlist;
        if cdr list then list := cddr list
         else list:=cdr list;
     >>;
    return list(nil) . reverse nlist;
  end;



symbolic procedure spre_row_vec(list);
  %
  % Takes uncompressed matrix and creates a list consisting of the
  % real elements a row.
  %
  begin
    scalar recol,nlist,val;
    integer coln;
    while list do
    << recol:=car list;
        coln:=car recol;
        coln:= (coln + 1) / 2;
         val:=cdr recol;
       recol:=coln . val;
       nlist:=recol . nlist;
        list:=cddr list;
    >>;
    return list(nil) . reverse nlist;
  end;

symbolic procedure spim_uncompress(in_mat,n);
  %
  % Takes square(nXn) matrix containing imaginary elements and creates
  % a new nX2n matrix s.t. in_mat(i,j) is cx_mat(i,2j-1)+i*cx_mat(i,2j).
  %
  begin
    scalar cx_mat,tmp,col,val1,val2;
    integer i,j;
    cx_mat := mkempspmat(n,list('spm,n,2*n));
    for i:=1:n do
    << col:=findrow(in_mat,i);
       for each xx in cdr col do
       << j:=car xx;
          tmp:=cdr xx;
          val1:=algebraic repart(tmp);
          val2:=algebraic impart(tmp);
        letmtr3(list(cx_mat,i,2*j-1),val1,cx_mat,'cx);
        letmtr3(list(cx_mat,i,2*j),val2,cx_mat,'cx);
      >>;
    >>;
    return cx_mat;
  end;



symbolic procedure spim_compress(cx_mat,n);
  %
  % Performs the opposite to im_uncompress.
  %
  begin
    scalar comp_mat,col,val1,val2,col1,col2;
    integer i,j;
    comp_mat := mkempspmat(n,list('spm,n,n));
    for i:=1:n do
    << col:=findrow(cx_mat,i);
       if col then col:=cdr col;
       while col do
       <>;
    >>;
    return comp_mat;
  end;

symbolic procedure spconvert(in_mat,int_vec);
  %
  % The lu decomposition algorithm may swap some of the rows of A such
  % that L * U does not equal A but a row rearrangement of A. The
  % lu_decom returns as a third argument a vector that describes which
  % rows have been swapped.
  %
  % Given a matrix A, then
  %  convert(first lu_decom(A) * second lu_decom(A),third lu_decom(A))
  % will return A.
  %
  % convert(A,third lu_decom(A)) will give you L * U.
  %
  begin
    scalar new_mat;
    integer i;
    if not matrixp(in_mat) then
     rederr "Error in convert(first argument): should be a matrix.";
    new_mat := copy_vect(in_mat,nil);
    for i:=1:upbv(int_vec)+1 do
    <<
      if getv(int_vec,i-1) neq i then
       new_mat := spswap_rows(new_mat,i,getv(int_vec,i-1));
    >>;
    return new_mat;
  end;

flag('(spconvert),'opfn);

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/sparse.tst0000644000175000017500000001214311526203062024033 0ustar  giovannigiovanni% Test file for Sparse Matrices and the Linear Algebra Package for
% Sparse Matrices.

% Author: Stephen Scowcroft.                    Date: June 1995.

% Firstly, the matrices need to be created.

% This is the standard way to create a sparse matrix.

% Create a sparse matrix.

sparse mat1(5,5);

%Fill the sparse matrix with data

mat1(1,1):=2;
mat1(2,2):=4;
mat1(3,3):=6;
mat1(4,4):=8;
mat1(5,5):=10;

sparse mat4(5,5);

mat4(1,1):=x;
mat4(2,2):=x;
mat4(3,3):=x;
mat4(4,4):=x;
mat4(5,5):=x;

% A small function to automatically fill a sparse matrix with data.

procedure makematsp(nam,row);
 begin; 
  sparse nam(row,row);
    for i := 1:row do <>
 end;

clear mat2;
makematsp(mat2,100);

% Matrices created in the standard Matrix way.

zz1:=mat((1,2),(3,4));
zz2:=mat((x,x),(x,x));
zz3:=mat((i+1,i+2,i+3),(4,5,2),(1,i,0));

% I have taken advantage of the Linear Algebra Package (Matt Rebbeck)
% in order to create some Sparse Matrices.

mat3:=diagonal(zz1,zz1,zz1);
mat5:=band_matrix({1,3,1},100)$
mat6:=diagonal(zz3,zz3);
mat7:=band_matrix({a,b,c},4);

% These are then "translated" into the Sparse operator using the 
% function transmat.
% This is a destructive function in the sense that the matrices are no
% longer of type 'matrix but are now 'sparse.

transmat mat3;
transmat mat5;
transmat mat6;
transmat mat7;

poly  := x^7+x^5+4*x^4+5*x^3+12;
poly1 := x^2+x*y^3+x*y*z^3+y*x+2+y*3;

% Firstly some basic matrix operations.
% These are the same as the present matrix package

mat1^-1;
mat4^-1;
mat2 + mat5$
mat2 - mat5$
mat1-mat1;
mat4 + mat1;
mat4 * mat1;

2*mat1 + (3*mat4 + mat1);
% It is also possible to combine both 'matrix and 'sparse type matrices
% in these operations.

pp:=band_matrix({1,3,1},100)$
mat5*pp;

mat5^2$

det(mat1);
det(mat4);
trace(mat1);
trace(mat4);

rank(mat1);
rank mat5;

tp(mat3);

spmateigen(mat3,eta);

% Next, tests for the Linear Algebra Package for Sparse Matrices.

%Basic matrix manipulations.

spadd_columns(mat1,1,2,5*y);
spadd_rows(mat1,1,2,x);

spadd_to_columns(mat1,3,1000);
spadd_to_columns(mat5,{1,2,3},y)$
spadd_to_rows(mat1,2,1000);
spadd_to_rows(mat5,{1,2,3},x)$

spaugment_columns(mat3,2);  
spaugment_columns(mat1,{1,2,5});
spstack_rows(mat1,3);  
spstack_rows(mat1,{1,3,5});  

spchar_poly(mat1,x);

spcol_dim(mat2);
sprow_dim(mat1);

spcopy_into(mat7,mat1,2,2);
spcopy_into(mat7,mat1,5,5);
spcopy_into(zz1,mat1,1,1);

spdiagonal(3);
% spdiagonal can take both a list of arguments or just the arguments.
spdiagonal({mat2,mat5})$
spdiagonal(mat2,mat5)$
% spdiagonal can also take a mixture of 'sparse and 'matrix types.
spdiagonal(zz1,mat4,zz1);

spextend(mat1,3,2,x);

spfind_companion(mat5,x);

spget_columns(mat1,1);
spget_columns(mat1,{1,2});
spget_rows(mat1,3);
spget_rows(mat1,{1,3});

sphermitian_tp(mat6);

% matrix_augment and matrix_stack can take both a list of arguments 
% or just the arguments.

spmatrix_augment({mat1,mat1});
spmatrix_augment(mat5,mat2,mat5)$
spmatrix_stack(mat2,mat2)$

spminor(mat1,2,3);

spmult_columns(mat1,3,y);
spmult_columns(mat2,{2,3,4},100)$
spmult_rows(mat2,2,x);
spmult_rows(mat1,{1,3,5},10);

sppivot(mat3,3,3);
sprows_pivot(mat3,1,1,{2,4});

spremove_columns(mat1,3);
spremove_columns(mat3,{2,3,4});
spremove_rows(mat1,2);
spremove_rows(mat2,{1,3})$
spremove_rows(mat1,{1,2,3,4,5});

spswap_cols(mat1,2,4);
spswap_rows(mat5,1,2)$
spswap_entries(mat1,{1,1},{5,5});



% Constructors - functions that create matrices.

spband_matrix(x,500)$
spband_matrix({x,y,z},6000)$

spblock_matrix(1,2,{mat1,mat1});
spblock_matrix(2,3,{mat3,mat6,mat3,mat6,mat3,mat6});

spchar_matrix(mat3,x);

cfmat := spcoeff_matrix({y+4*+-5*w=10,y-z=20,y+4+3*z,w+x+50});
first cfmat * second cfmat;
third cfmat;

spcompanion(poly,x);

sphessian(poly1,{w,x,y,z});

spjacobian({x^4,x*y^2,x*y*z^3},{w,x,y,z});

spjordan_block(x,500)$

spmake_identity(1000)$

on rounded; % makes output easier to read.
ch := spcholesky(mat1);
tp first ch - second ch;
tmp := first ch * second ch;
tmp - mat1;
off rounded;

% The gram schmidt functions takes a list of vectors.
% These vectors are matrices of type 'sparse with column dimension 1.

%Create the "vectors".
sparse a(4,1);
sparse b(4,1);
sparse c(4,1);
sparse d(4,1);

%Fill the "vectors" with data.
a(1,1):=1;
b(1,1):=1;
b(2,1):=1;
c(1,1):=1;
c(2,1):=1;
c(3,1):=1;
d(1,1):=1;
d(2,1):=1;
d(3,1):=1;
d(4,1):=1;

spgram_schmidt({{a},{b},{c},{d}});

on rounded; % again, makes large quotients a bit more readable.
% The algorithm used for splu_decom sometimes swaps the rows of the 
% input matrix so that (given matrix A, splu_decom(A) = {L,U,vec}), 
% we find L*U does not equal A but a row equivalent of it. The call 
% spconvert(A,vec) will return this row equivalent 
% (ie: L*U = convert(A,vec)).
lu := splu_decom(mat5)$
tmp := first lu * second lu$
tmp1 := spconvert(mat5,third lu);
tmp - tmp1;
% and the complex case..
on complex;
lu1 := splu_decom(mat6);
mat6;
tmp := first lu1 * second lu1;
tmp1 := spconvert(mat6,third lu1);
tmp - tmp1;
off complex;

mat3inv := sppseudo_inverse(mat3);
mat3 * mat3inv;


% Predicates.

matrixp(mat1);
matrixp(poly);

squarep(mat2);
squarep(mat3);

symmetricp(mat1);
symmetricp(mat3);

sparsematp(mat1);
sparsematp(poly);

off rounded;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/sparse.tex0000644000175000017500000013305111526203062024023 0ustar  giovannigiovanni\documentstyle[11pt,reduce,fancyheadings]{article}
\title{The Sparse Matrices Package. \\
Sparse Matrix Calculations and a Linear Algebra Package for Sparse 
Matrices in \REDUCE{}}
\author{Stephen Scowcroft \\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin}
\date{June 1995}

\def\foottitle{The Sparse Matrices Package}
\pagestyle{fancy}
\lhead[]{{\footnotesize\leftmark}{}}
\rhead[]{\thepage}
\setlength{\headrulewidth}{0.6pt}
\setlength{\footrulewidth}{0.6pt}
\cfoot{}
\rfoot{\small\foottitle}

\def\exprlist  {expr$_{1}$,expr$_{2}$, \ldots ,expr$_{{\tt n}}$}
\def\lineqlist {lin\_eqn$_{1}$,lin\_eqn$_{2}$, \ldots ,lin\_eqn$_{n}$}
\def\matlist   {mat$_{1}$,mat$_{2}$, \ldots ,mat$_{n}$}
\def\veclist   {vec$_{1}$,vec$_{2}$, \ldots ,vec$_{n}$}

\def\lazyfootnote{\footnote{The \{\}'s can be omitted.}}

\renewcommand{\thefootnote}{\fnsymbol{footnote}}

\begin{document}
\maketitle
\index{Linear Algebra package}

\section{Introduction}
A very powerful feature of \REDUCE{} is the ease with which matrix 
calculations can be performed.
This package extends the available matrix feature to enable calculations
with sparse matrices. This package also provides a selection of 
functions that are useful in the world of linear algebra with respect to
sparse matrices.

\subsection*{Loading the Package}
The package is loaded by: {\tt load\_package sparse;}

\section{Sparse Matrix Calculations}
To extend the the syntax to this class of calculations we need to add an
expression type {\tt sparse}.

\subsection{Sparse Variables}
An identifier may be declared a sparse variable by the declaration
{\tt SPARSE}.
The size of the sparse matrix must be declared explicitly in the matrix
declaration. For example,
\begin{verbatim}
sparse aa(10,1),bb(200,200);
\end{verbatim}
declares {\tt AA} to be a 10 x 1 (column) sparse matrix and {\tt Y} to 
be a 200 x 200 sparse matrix.
The declaration {\tt SPARSE} is similar to the declaration {\tt MATRIX}.
Once a symbol is declared to name a sparse matrix, it can not also be 
used to name an array, operator, procedure, or used as an ordinary 
variable. For more information see the Matrix Variables section in The
\REDUCE {} User's Manual[2].

\subsection{Assigning Sparse Matrix Elements}
Once a matix has been declared a sparse matrix all elements of the 
matrix are initialized to 0. Thus when a sparse matrix is initially 
referred to the message
\begin{verbatim}
"The matrix is dense, contains only zeros"
\end{verbatim}
is returned. When printing out a matrix only the non-zero elements are 
printed. This is due to the fact that only the non-zero elements of the 
matrix are stored. 
To assign the elements of the declared matrix we use the following 
syntax. Assuming {\tt AA} and {\tt BB} have been declared as spasre 
matrices, we simply write,
\begin{verbatim}
aa(1,1):=10;
bb(100,150):=a;
\end{verbatim}
etc. This then sets the element in the first row and first column to 10,
or the element in the 100th row and 150th column to {\tt a}.

\subsection{Evaluating Sparse Matrix Elements}
Once an element of a sparse matrix has been assingned, it may be referred
to in standard array element notation. Thus {\tt aa(2,1)} refers to the 
element in the second row and first column of the sparse matrix {\tt AA}.

\section{Sparse Matrix Expressions}
These follow the normal rules of matrix algebra. Sums and products must 
be of compatible size; otherwise an error will result during evaluation.
Similarly, only square matrices may be raised to a power.
A negative power is computed as the inverse of the matrix raised to the
corresponding positive power. For more information and the syntax for 
matrix algebra see the Matrix Expressions section in The \REDUCE{} 
User's Manual[2].

\section{Operators with Sparse Matrix Arguments}
The operators in the Sparse Matix Package are the same as those in the
Matrix Packge with the exception that the {\tt NULLSPACE} operator is 
not defined. See section Operators with Matrix Arguments in The 
\REDUCE{} User's Manual[2] for more details.
\subsection{Examples}
In the examples the matrix ${\cal AA}$ will be 

\begin{flushleft}
\begin{math}
{\cal AA} = \left( \begin{array}{cccc} 1 & 0 & 0 & 0 \\ 0 & 3 & 0 & 0 \\ 
0 & 0 & 5 & 0 \\ 0 & 0 & 0 & 9
\end{array} \right)
\end{math}
\end{flushleft}
\begin {verbatim}
det ppp;

135

trace ppp;

18

rank ppp;

4

spmateigen(ppp,eta);

{{eta - 1,1,

  spm(1,1) := arbcomplex(4)$
  },

 {eta - 3,1,

  spm(2,1) := arbcomplex(5)$
  },

 {eta - 5,1,

  spm(3,1) := arbcomplex(6)$
  },

 {eta - 9,1,

  spm(4,1) := arbcomplex(7)$
  }}
\end{verbatim}

\section{The Linear Algebra Package for Sparse Matrices}
This package is an extension of the Linear Algebra Package for \REDUCE{}.[1]
These functions are described 
alphabetically in section 6 of this document and are labelled 6.1 to 
6.47. They can be classified into four sections(n.b: the numbers after 
the dots signify the function label in section 6).
\subsection{Basic matrix handling}
\begin{center}
\begin{tabular}{l l l l l l}
spadd\_columns     & \ldots & 6.1  & 
spadd\_rows        & \ldots & 6.2  \\
spadd\_to\_columns & \ldots & 6.3  &
spadd\_to\_rows    & \ldots & 6.4  \\
spaugment\_columns & \ldots & 6.5  &
spchar\_poly       & \ldots & 6.9  \\
spcol\_dim      & \ldots & 6.12  &
spcopy\_into       & \ldots & 6.14 \\
spdiagonal         & \ldots & 6.15 &
spextend           & \ldots & 6.16 \\
spfind\_companion  & \ldots & 6.17  &
spget\_columns     & \ldots & 6.18 \\
spget\_rows        & \ldots & 6.19 &
sphermitian\_tp    & \ldots & 6.21 \\
spmatrix\_augment  & \ldots & 6.27 &
spmatrix\_stack    & \ldots & 6.29 \\
spminor            & \ldots & 6.30 &
spmult\_columns    & \ldots & 6.31 \\ 
spmult\_rows       & \ldots & 6.32 &
sppivot            & \ldots & 6.33 \\
spremove\_columns  & \ldots & 6.35 &
spremove\_rows     & \ldots & 6.36 \\
sprow\_dim         & \ldots & 6.37 &
sprows\_pivot      & \ldots & 6.38 \\
spstack\_rows      & \ldots & 6.41 &
spsub\_matrix      & \ldots & 6.42 \\
spswap\_columns    & \ldots & 6.44 &
spswap\_entries    & \ldots & 6.45 \\
spswap\_rows       & \ldots & 6.46 &
\end{tabular}
\end{center}

\subsection{Constructors}

Functions that create sparse matrices.

\begin{center}
\begin{tabular}{l l l l l l}
spband\_matrix       & \ldots & 6. 6 & 
spblock\_matrix      & \ldots & 6. 7 \\
spchar\_matrix       & \ldots & 6. 8 & 
spcoeff\_matrix      & \ldots & 6. 11 \\ 
spcompanion          & \ldots & 6. 13 & 
sphessian            & \ldots & 6. 22 \\
spjacobian           & \ldots & 6. 23 &
spjordan\_block      & \ldots & 6. 24 \\ 
spmake\_identity     & \ldots & 6. 26 &
\end{tabular}
\end{center}

\subsection{High level algorithms}

\begin{center}
\begin{tabular}{l l l l l l}
spchar\_poly       & \ldots & 6.9 & 
spcholesky         & \ldots & 6.10 \\ 
spgram\_schmidt    & \ldots & 6.20 & 
splu\_decom        & \ldots & 6.25 \\
sppseudo\_inverse  & \ldots & 6.34 & 
svd                & \ldots & 6.43 
\end{tabular}
\end{center}

\subsection{Predicates}

\begin{center}
\begin{tabular}{l l l l l l}
matrixp     & \ldots & 6.28 & 
sparsematp  & \ldots & 6.39 \\
squarep     & \ldots & 6.40 &
symmetricp  & \ldots & 6.47 
\end{tabular}
\end{center}

\subsection*{Note on examples:} 

In the examples the matrix ${\cal A}$ will be 

\begin{flushleft}
\begin{math}
{\cal A} = \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9
\end{array} \right)
\end{math}
\end{flushleft}
Unfortunately, due to restrictions of size, it is not practical to use
``large'' sparse matrices in the examples. As a result the examples 
shown may appear trivial, but they give an idea of how the functions 
work.  

\subsection*{Notation}

Throughout ${\cal I}$ is used to indicate the identity matrix and 
${\cal A}^T$ to indicate the transpose of the matrix ${\cal A}$.

\section{Available Functions}

\subsection{spadd\_columns, spadd\_rows}

\hspace*{0.175in} {\tt spadd\_columns(${\cal A}$,c1,c2,expr);} 

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$ & :- & a sparse matrix. \\
c1,c2      & :- & positive integers. \\
expr       & :- & a scalar expression. 
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
\parbox[t]{0.95\linewidth}{{\tt spadd\_columns} replaces column c2 of 
${\cal A}$ by expr $*$ column(${\cal A}$,c1) $+$ column(${\cal A}$,c2).}

{\tt spadd\_rows} performs the equivalent task on the rows of ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\begin{math}
\hspace*{0.16in}
\begin{array}{ccc}
{\tt spadd\_columns}({\cal A},1,2,x) & = & 
\left( \begin{array}{ccc} 1 & x & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\tt spadd\_rows}({\cal A},2,3,5) & = & 
\left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 25 & 9 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spadd\_to\_columns}, {\tt spadd\_to\_rows}, 
{\tt spmult\_columns}, {\tt spmult\_rows}.


\subsection{spadd\_rows}

\hspace*{0.175in} see: {\tt spadd\_columns}.


\subsection{spadd\_to\_columns, spadd\_to\_rows}

\hspace*{0.175in} {\tt spadd\_to\_columns(${\cal A}$,column\_list,expr);}

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$   &:-& a sparse matrix. \\
column\_list &:-& a positive integer or a list of positive integers. \\
expr        &:-& a scalar expression.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spadd\_to\_columns} adds expr to each column specified in 
column\_list of ${\cal A}$.  

{\tt spadd\_to\_rows} performs the equivalent task on the rows of 
${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}
\begin{array}{ccc}
{\tt spadd\_to\_columns}({\cal A},\{1,2\},10) & = & 
\left( \begin{array}{ccc} 11 & 10 & 0 \\ 10 & 15 & 0 \\ 10 & 10 & 9 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}
\begin{array}{ccc}
{\tt spadd\_to\_rows}({\cal A},2,-x) & = & 
\left( \begin{array}{ccc} 1 & 0 & 0 \\ -x & -x+5 & -x \\ 0 & 0 & 9 
\end{array} \right)  
\end{array}
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} 
{\tt spadd\_columns}, {\tt spadd\_rows}, {\tt spmult\_rows}, 
{\tt spmult\_columns}.


\subsection{spadd\_to\_rows}

\hspace*{0.175in} see: {\tt spadd\_to\_columns}.


\subsection{spaugment\_columns, spstack\_rows}

\hspace*{0.175in} {\tt spaugment\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in}
\begin{tabular}{l l l}
${\cal A}$  &:-& a sparse matrix. \\
column\_list &:-&  either a positive integer or a list of positive 
                   integers. 
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spaugment\_columns} gets hold of the columns of ${\cal A}$ specified 
in column\_list and sticks them together. 

{\tt spstack\_rows} performs the same task on rows of 
                ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}
\begin{array}{ccc}
{\tt spaugment\_columns}({\cal A},\{1,2\}) & = & 
\left( \begin{array}{cc} 1 & 0 \\ 0 & 5 \\ 0 & 0  
\end{array} \right)  
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spstack\_rows}({\cal A},\{1,3\}) & = & 
\left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 0 & 9
\end{array} \right)  
\end{array}  
\end{math}
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spget\_columns}, {\tt spget\_rows}, 
{\tt spsub\_matrix}.


\subsection{spband\_matrix}

\hspace*{0.175in} {\tt spband\_matrix(expr\_list,square\_size);}

\hspace*{0.1in}
\begin{tabular}{l l l}
expr\_list  \hspace*{0.088in} &:-& \parbox[t]{.72\linewidth}
{either a single scalar expression or a list of an odd number of scalar
expressions.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
square\_size &:-& a positive integer.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt spband\_matrix} creates a sparse square matrix of 
                dimension square\_size. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spband\_matrix}(\{x,y,z\},6) & = & 
\left( \begin{array}{cccccc} y & z & 0 & 0 & 0 & 0 \\ x & y & z & 0 & 0
& 0 \\ 0 & x & y & z & 0 & 0 \\ 0 & 0 & x & y & z & 0 \\ 0 & 0 & 0 & x &
 y & z \\ 0 & 0 & 0 & 0 & x & y 
\end{array} \right)
\end{array}  
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt spdiagonal}.


\subsection{spblock\_matrix}

\hspace*{0.175in} {\tt spblock\_matrix(r,c,matrix\_list);}

\hspace*{0.1in}
\begin{tabular}{l l l}
r,c          &:-& positive integers. \\
matrix\_list &:-& a list of matrices of either sparse or matrix type. 
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spblock\_matrix} creates a sparse matrix that consists of r by c matrices 
filled from the matrix\_list row wise.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\cal B} = \left( \begin{array}{cc} 1 & 0 \\ 0 & 1
\end{array} \right), & 
{\cal C} = \left( \begin{array}{c} 5 \\ 0
\end{array} \right), &
{\cal D} = \left( \begin{array}{cc} 22 & 0 \\ 0 & 0
\end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.175in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spblock\_matrix}(2,3,\{{\cal B,C,D,D,C,B}\}) & = & 
\left( \begin{array}{ccccc} 1 & 0 & 5 & 22 & 0 \\ 0 & 1 & 0 & 0 & 0 
\\
22 & 0 & 5 & 1 & 0 \\ 0 & 0 & 0 & 0 & 1
\end{array} \right)  
\end{array}  
\end{math}  
\end{flushleft}


\subsection{spchar\_matrix}

\hspace*{0.175in} {\tt spchar\_matrix(${\cal A},\lambda$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a square sparse matrix. \\
$\lambda$  &:-& a symbol or algebraic expression. 
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spchar\_matrix} creates the characteristic matrix ${\cal C}$ of 
${\cal A}$.

This is ${\cal C} = \lambda * {\cal I} - {\cal A}$. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spchar\_matrix}({\cal A},x) & = & 
\left( \begin{array}{ccc} x-1 & 0 & 0 \\ 0 & x-5 & 0 \\ 0 & 0 & x-9 
\end{array} \right)  
\end{array}  
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spchar\_poly}. 


\subsection{spchar\_poly}

\hspace*{0.175in} {\tt spchar\_poly(${\cal A},\lambda$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse square matrix. \\
$\lambda$ &:-& a symbol or algebraic expression.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spchar\_poly} finds the characteristic polynomial of
                ${\cal A}$.  

This is the determinant of $\lambda * {\cal I} - {\cal A}$.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in}
{\tt spchar\_poly({\cal A},$x$) $= x^3-15*x^2-59*x-45$} 

{\bf Related functions:}

\hspace*{0.175in} {\tt spchar\_matrix}. 


\subsection{spcholesky}

\hspace*{0.175in} {\tt spcholesky(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a positive definite sparse matrix containing numeric entries.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spcholesky} computes the cholesky decomposition of ${\cal A}$.

It returns \{${\cal L,U}$\} where ${\cal L}$
is a lower matrix, ${\cal U}$ is an upper matrix, \\ ${\cal A} = 
{\cal LU}$, and ${\cal U} = {\cal L}^T$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal F} = \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 
9
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt cholesky}$({\cal F}) & = & 
\left\{ \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & \sqrt{5} 
& 0 \\ 
0 & 0& 3 \end{array} \right), \left( 
\begin{array}{ccc} 1 & 0 & 0 \\ 0 & \sqrt{5} & 0 \\ 0 
& 0 & 3 \end{array} \right)
\right\} \end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt splu\_decom}.


\subsection{spcoeff\_matrix}

\hspace*{0.175in} {\tt spcoeff\_matrix(\{\lineqlist{}\});} 

\hspace*{0.1in} 
\begin{tabular}{l l l}
\lineqlist  &:-& \parbox[t]{.435\linewidth}{linear equations. Can be 
of the form {\it equation $=$ number} or just {\it equation}.}
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spcoeff\_matrix} creates the coefficient matrix 
                ${\cal C}$ of the linear equations. 

It returns \{${\cal C,X,B}$\} such that ${\cal CX} = {\cal B}$.

\end{addtolength}


{\bf Examples:}

\begin{math}
\hspace*{0.175in}
{\tt spcoeff\_matrix}(\{y-20*w=10,y-z=20,y+4+3*z,w+x+50\}) =  
\end{math}

\vspace*{0.1in}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
\left\{ \left( \begin{array}{cccc} 1 & -20 & 0 & 0 \\ 1 & 0 & -1 & 0 \\
 1 & 0 & 3 & 0 \\ 0 & 1 & 0 & 1 
\end{array} \right), \left( \begin{array}{c} y \\ w \\ z \\ x \end{array} 
\right), \left( \begin{array}{c} 10 \\ 20 \\ -4 \\ 50
\end{array} \right) \right\} 
\end{math}  
\end{flushleft}

\subsection{spcol\_dim, sprow\_dim}

\hspace*{0.175in} {\tt column\_dim(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix.
\end{tabular}

{\bf Synopsis:} 

\hspace*{0.175in} {\tt spcol\_dim} finds the column dimension of 
                ${\cal A}$. 

\hspace*{0.175in} {\tt sprow\_dim} finds the row dimension of ${\cal A}$.

{\bf Examples:}

\hspace*{0.175in}
{\tt spcol\_dim}(${\cal A}$) = 3

\subsection{spcompanion}

\hspace*{0.175in} {\tt spcompanion(poly,x);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
poly &:-& a monic univariate polynomial in x. \\
x    &:-& the variable.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt spcompanion} creates the companion matrix ${\cal C}$
                of poly. 

This is the square matrix of dimension n, where n is the degree of poly 
w.r.t. x.

The entries of ${\cal C}$ are: 
                ${\cal C}$(i,n) = -coeffn(poly,x,i-1) for i = 1 
                \ldots n, ${\cal C}$(i,i-1) = 1 for i = 2 \ldots n and 
                the rest are 0.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spcompanion}(x^4+17*x^3-9*x^2+11,x) & = & 
\left( \begin{array}{cccc} 0 & 0 & 0 & -11 \\ 1 & 0 & 0 & 0 \\ 
0 & 1 & 0 & 9 \\ 0 & 0 & 1 & -17 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spfind\_companion}.


\subsection{spcopy\_into}

\hspace*{0.175in} {\tt spcopy\_into(${\cal A,B}$,r,c);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A,B}$ &:-& matrices of type sparse or matrix. \\
r,c          &:-& positive integers. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt spcopy\_into} copies matrix ${\cal A}$ into 
                ${\cal B}$ with ${\cal A}$(1,1) at ${\cal B}$(r,c).

{\bf Examples:} 

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal G} = \left( \begin{array}{cccc} 0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0 \\
0 & 0 & 0 & 0 \\ 0 & 0 & 0 & 0
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spcopy\_into}({\cal A,G},1,2) & = & 
\left( \begin{array}{cccc} 0 & 1 & 0 & 0 \\ 0 & 0 & 5 & 0 \\ 0 & 0 & 0 
& 9 \\ 0 & 0 & 0 & 0  
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spaugment\_columns}, {\tt spextend}, {\tt spmatrix\_augment}, 
{\tt spmatrix\_stack}, {\tt spstack\_rows}, {\tt spsub\_matrix}.

\end{addtolength}


\subsection{spdiagonal}

\hspace*{0.175in} {\tt spdiagonal(\{\matlist{}\});}\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\matlist &:-& \parbox[t]{.58\linewidth}{each can be either a scalar 
expr or a square matrix of sparse or matrix type. }
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\hspace*{0.175in} {\tt spdiagonal} creates a sparse matrix that contains the 
input on the diagonal.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal H} = \left( \begin{array}{cc} 66 & 77 \\ 88 & 99
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spdiagonal}(\{{\cal A},x,{\cal H}\}) & = & 
\left( \begin{array}{cccccc} 1 & 0 & 0 & 0 & 0 & 0 \\ 0 & 5 & 0 & 0 & 0
& 0 \\ 0 & 0 & 9 & 0 & 0 & 0 \\ 0 & 0 & 0 & x & 0 & 0 \\ 0 & 0 & 0 & 0 
& 66 & 77 \\ 0 & 0 & 0 & 0 & 88 & 99 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\hspace*{0.175in} {\tt spjordan\_block}.


\subsection{spextend}

\hspace*{0.175in} {\tt spextend(${\cal A}$,r,c,expr);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix. \\
r,c        &:-& positive integers. \\
expr      &:-& algebraic expression or symbol.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
                {\tt spextend} returns a copy of ${\cal A}$ that has been 
                extended by r rows and c columns. The new entries are
                made equal to expr.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spextend}({\cal A},1,2,0) & = & 
\left( \begin{array}{ccccc} 1 & 0 & 0 & 0 & 0 \\ 0 & 5 & 0 & 0 & 0
\\ 0 & 0 & 9 & 0 & 0 \\ 0 & 0 & 0 & 0 & 0 
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:} 

\begin{addtolength}{\leftskip}{0.22in}
\parbox[t]{0.95\linewidth}{{\tt spcopy\_into}, {\tt spmatrix\_augment}, 
{\tt spmatrix\_stack}, {\tt spremove\_columns}, {\tt spremove\_rows}.}

\end{addtolength}


\subsection{spfind\_companion}

\hspace*{0.175in} {\tt spfind\_companion(${\cal A}$,x);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix. \\
x          &:-& the variable.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
  Given a sparse companion matrix, {\tt spfind\_companion} finds the polynomial 
from which it was made.

\end{addtolength}


{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal C} = \left( \begin{array}{cccc} 0 & 0 & 0 & -11 \\ 1 & 0 & 0 & 0 
\\ 0 & 1 & 0 & 9 \\ 0 & 0 & 1 & -17 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{3mm}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\tt spfind\_companion}({\cal C},x) = x^4+17*x^3-9*x^2+11
\end{math}  
\end{flushleft}

\vspace*{3mm}

{\bf Related functions:}

\hspace*{0.175in} {\tt spcompanion}.

\subsection{spget\_columns, spget\_rows}

\hspace*{0.175in} {\tt spget\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix. \\
c          &:-& either a positive integer or a list of positive 
                integers.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spget\_columns} removes the columns of ${\cal A}$ specified in 
                column\_list and returns them as a list of column 
                matrices. 

\end{addtolength}
\hspace*{0.175in} {\tt spget\_rows} performs the same task on the rows of 
                ${\cal A}$. 

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spget\_columns}({\cal A},\{1,3\}) & = & 
\left\{ 
        \left( \begin{array}{c} 1 \\ 0 \\ 0 \end{array} \right),
        \left( \begin{array}{c} 0 \\ 0 \\ 9 \end{array} \right) 
\right\} 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spget\_rows}({\cal A},2) & = & 
\left\{ 
        \left( \begin{array}{ccc} 0 & 5 & 0 \end{array} \right)
\right\} 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spaugment\_columns}, {\tt spstack\_rows}, 
{\tt spsub\_matrix}.


\subsection{spget\_rows}

\hspace*{0.175in} see: {\tt spget\_columns}.


\subsection{spgram\_schmidt}

\hspace*{0.175in} {\tt spgram\_schmidt(\{\veclist{}\});}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\veclist &:-& \parbox[t]{.62\linewidth}{linearly independent vectors.
                             Each vector must be written as a list of
predefined sparse (column) matrices, eg: sparse a(4,1);, a(1,1):=1;}
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spgram\_schmidt} performs the gram\_schmidt 
                orthonormalisation on the input vectors. 

It returns a list of orthogonal normalised vectors.

\end{addtolength}

{\bf Examples:}

Suppose a,b,c,d correspond to sparse matrices representing the following
lists:-  \{\{1,0,0,0\},\{1,1,0,0\},\{1,1,1,0\},\{1,1,1,1\}\}.

{\tt spgram\_schmidt(\{\{a\},\{b\},\{c\},\{d\}\})} = 
\{\{1,0,0,0\},\{0,1,0,0\},\{0,0,1,0\},\{0,0,0,1\}\}

\subsection{sphermitian\_tp}

\hspace*{0.175in} {\tt sphermitian\_tp(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix. 
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
                {\tt sphermitian\_tp} computes the hermitian transpose of 
                ${\cal A}$. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}  
{\cal J} = \left( \begin{array}{ccc} i+1 & i+2 & i+3 \\ 0 & 0 & 0 \\ 0 &
i & 0 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt sphermitian\_tp}({\cal J}) & = & 
\left( \begin{array}{ccc} -i+1 & 0 & 0 \\ -i+2 & 0 & -i \\-i+3 & 0 & 0
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}                   

{\bf Related functions:}

\hspace*{0.175in} {\tt tp}\footnote{standard reduce call for the 
transpose of a matrix - see {\REDUCE} User's Manual[2].}.


\subsection{sphessian}

\hspace*{0.175in} {\tt sphessian(expr,variable\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr           &:-& a scalar expression. \\
variable\_list &:-& either a single variable or a list of variables.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
                {\tt sphessian} computes the hessian matrix of expr w.r.t.
                the variables in variable\_list. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt sphessian}(x*y*z+x^2,\{w,x,y,z\}) & = & 
\left( \begin{array}{cccc} 0 & 0 & 0 & 0 \\ 0 & 2 & z & y \\ 0 & z & 0 
& x \\ 0 & y & x & 0
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}


\subsection{spjacobian}

\hspace*{0.175in} {\tt spjacobian(expr\_list,variable\_list);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr\_list   \hspace*{0.175in}  &:-& \parbox[t]{.72\linewidth}{either a 
single algebraic expression or a list of algebraic expressions.} 
\end{tabular}

\vspace*{0.04in}
\hspace*{0.1in}
\begin{tabular}{l l l}
variable\_list &:-& either a single variable or a list of variables.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spjacobian} computes the jacobian matrix of expr\_list w.r.t. 
variable\_list. 

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in} 
{\tt spjacobian(\{$x^4,x*y^2,x*y*z^3$\},\{$w,x,y,z$\})} = 

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.175in}
\begin{math}        
\left( \begin{array}{cccc} 0 & 4*x^3 & 0 & 0 \\ 0 & y^2 & 2*x*y & 0 \\ 
0 & y*z^3 & x*z^3 & 3*x*y*z^2 
\end{array} \right)
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt sphessian}, {\tt df}\footnote{standard reduce call 
for differentiation - see {\REDUCE} User's Manual[2].}.


\subsection{spjordan\_block}

\hspace*{0.175in} {\tt spjordan\_block(expr,square\_size);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
expr        &:-& an algebraic expression or symbol. \\
square\_size &:-& a positive integer.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spjordan\_block} computes the square jordan block matrix ${\cal J}$
                of dimension square\_size. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}        
\begin{array}{ccc}
{\tt spjordan\_block(x,5)} & = & 
\left( \begin{array}{ccccc} x & 1 & 0 & 0 & 0 \\ 0 & x & 1 & 0 & 0 \\ 0 
& 0 & x & 1 & 0 \\ 0 & 0 & 0 & x & 1 \\ 0 & 0 & 0 & 0 & x
\end{array} \right)
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spdiagonal}, {\tt spcompanion}.


\subsection{splu\_decom}

%{\bf How to use it:}

\hspace*{0.175in} {\tt splu\_decom(${\cal A}$);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& \parbox[t]{.848\linewidth}{a sparse matrix containing either 
numeric entries or imaginary entries with numeric coefficients.}
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
              {\tt splu\_decom} performs LU decomposition on ${\cal A}$,
              ie: it returns \{${\cal L,U}$\} where ${\cal L}$
              is a lower diagonal matrix, ${\cal U}$ an upper diagonal
              matrix and ${\cal A} = {\cal LU}$.

\end{addtolength}

{\bf caution:}

\begin{addtolength}{\leftskip}{0.22in}
The algorithm used can swap the rows of ${\cal A}$ 
                during the calculation. This means that ${\cal LU}$ does
                not equal ${\cal A}$ but a row equivalent of it. Due to
                this, {\tt splu\_decom} returns \{${\cal L,U}$,vec\}. The
                call {\tt spconvert(${\cal A}$,vec)} will return the 
                sparse matrix that has been decomposed, ie: ${\cal LU} = $
                {\tt spconvert(${\cal A}$,vec)}.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal K} = \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{cccc}
${\tt lu} := {\tt splu\_decom}$({\cal K}) & = & 
\left\{ 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9 \end{array} \right), 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 1 & 0 \\ 0 & 0 & 1 
\end{array} \right), 
	[\; 1 \; 2 \; 3 \; ]
\right\} 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt first lu * second lu}$ & = & 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
${\tt convert(${\cal K}$,third lu}$) \hspace*{0.055in} & = & 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spcholesky}.


\subsection{spmake\_identity}

\hspace*{0.175in} {\tt spmake\_identity(square\_size);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
square\_size &:-& a positive integer.
\end{tabular}

{\bf Synopsis:} 

\hspace*{0.175in} {\tt spmake\_identity} creates the identity matrix of 
                dimension square\_size.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spmake\_identity}(4) & = & 
        \left( \begin{array}{cccc} 1 & 0 & 0 & 0 \\ 0 & 1 & 0 & 0 \\ 0 
& 0 & 1 & 0 \\ 0 & 0 & 0 & 1
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spdiagonal}.


\subsection{spmatrix\_augment, spmatrix\_stack}

\hspace*{0.175in} {\tt spmatrix\_augment(\{\matlist\});}\lazyfootnote{}

\hspace*{0.1in} 
\begin{tabular}{l l l}
\matlist &:-& matrices.
\end{tabular}

{\bf Synopsis:} 

\hspace*{0.175in} {\tt spmatrix\_augment} joins the matrices in 
                  matrix\_list together horizontally. 

\hspace*{0.175in} 
{\tt spmatrix\_stack} joins the matrices in matrix\_list 
                together vertically.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spmatrix\_augment}(\{{\cal A,A}\}) & = & 
        \left( \begin{array}{cccccc} 1 & 0 & 0 & 1 & 0 & 0 \\ 0 & 5 & 0 
& 0 & 5 & 0 \\ 0 & 0 & 9 & 0 & 0 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spmatrix\_stack}(\{{\cal A,A}\}) & = & 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9 
\\ 1 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spaugment\_columns}, {\tt spstack\_rows}, 
{\tt spsub\_matrix}.


\subsection{matrixp}

%{\bf How to use it:}

\hspace*{0.175in} {\tt matrixp(test\_input);}

\hspace*{0.1in}  
\begin{tabular}{l l l}
test\_input &:-& anything you like.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt matrixp} is a boolean function that returns t if 
                the input is a matrix of type sparse or matrix and nil otherwise.

\end{addtolength}

{\bf Examples:}

\hspace*{0.175in} {\tt matrixp}(${\cal A}$) = t 

\hspace*{0.175in} {\tt matrixp}(doodlesackbanana) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt squarep}, {\tt symmetricp}, {\tt sparsematp}.


\subsection{spmatrix\_stack}

\hspace*{0.175in} see: {\tt spmatrix\_augment}.


\subsection{spminor}

\hspace*{0.175in} {\tt spminor(${\cal A}$,r,c);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a sparse matrix. \\
r,c        &:-& positive integers.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
                {\tt spminor} computes the (r,c)'th minor of ${\cal A}$.
 
\end{addtolength}
                
{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spminor}({\cal A},1,3) & = & 
        \left( \begin{array}{cc} 0 & 5 \\ 0 & 0
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spremove\_columns}, {\tt spremove\_rows}.


\subsection{spmult\_columns, spmult\_rows}

\hspace*{0.175in} {\tt spmult\_columns(${\cal A}$,column\_list,expr);}

\hspace*{0.1in}  
\begin{tabular}{l l l}
${\cal A}$   &:-& a sparse matrix. \\
column\_list &:-& a positive integer or a list of positive integers. \\
expr        &:-& an algebraic expression.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt spmult\_columns} returns a copy of ${\cal A}$ in which
                the columns specified in column\_list have been 
multiplied by expr. 

{\tt spmult\_rows} performs the same task on the rows of ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spmult\_columns}({\cal A},\{1,3\},x) & = & 
        \left( \begin{array}{ccc} x & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 9*x 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spmult\_rows}({\cal A},2,10) & = & 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 50 & 0 \\ 0 & 0 & 
9 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spadd\_to\_columns}, {\tt spadd\_to\_rows}.


\subsection{\tt spmult\_rows}

\hspace*{0.175in} see: {\tt spmult\_columns}.


\subsection{sppivot}

\hspace*{0.175in} {\tt sppivot(${\cal A}$,r,c);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a sparse matrix. \\
r,c        &:-& positive integers such that ${\cal A}$(r,c) neq 0.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt sppivot} pivots ${\cal A}$ about it's (r,c)'th entry. 
 
To do this, multiples of the r'th row are added to every
     other row in the matrix. 

This means that the c'th column
                will be 0 except for the (r,c)'th entry. 

\end{addtolength}

{\bf Related functions:}

\hspace*{0.175in} {\tt sprows\_pivot}.


\subsection{sppseudo\_inverse}

\hspace*{0.175in} {\tt sppseudo\_inverse(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a sparse matrix.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt sppseudo\_inverse}, also known as the Moore-Penrose inverse, computes
the pseudo inverse of ${\cal A}$. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal R} = \left( \begin{array}{cccc} 0 & 0 & 3 & 0 \\ 9 & 0 & 7 & 0
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt sppseudo\_inverse}({\cal R}) & = & 
        \left( \begin{array}{cc} -0.26 & 0.11 \\ 0 & 0 \\ 0.33 & 0 
\\ 0.25 & -0.05 
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spsvd}.

\subsection{spremove\_columns, spremove\_rows}

\hspace*{0.175in} {\tt spremove\_columns(${\cal A}$,column\_list);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$   &:-& a sparse matrix. \\
column\_list &:-& either a positive integer or a list of 
                  positive integers.
\end{tabular}

{\bf Synopsis:}

\hspace*{0.175in} {\tt spremove\_columns} removes the columns specified in
                column\_list from ${\cal A}$. 

\hspace*{0.175in} {\tt spremove\_rows} performs the same task on the rows 
                of ${\cal A}$.

{\bf Examples:} 

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spremove\_columns}({\cal A},2) & = & 
        \left( \begin{array}{cc} 1 & 0 \\ 0 & 0 \\ 0 & 9  
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spremove\_rows}({\cal A},\{1,3\}) & = & 
        \left( \begin{array}{ccc} 0 & 5 & 0
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}


{\bf Related functions:}

\hspace*{0.175in} {\tt spminor}.


\subsection{spremove\_rows}

\hspace*{0.175in} see: {\tt spremove\_columns}.


\subsection{sprow\_dim}

\hspace{0.175in} see: {\tt spcolumn\_dim}.


\subsection{sprows\_pivot}

\hspace*{0.175in} {\tt sprows\_pivot(${\cal A}$,r,c,\{row\_list\});}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a sparse matrix. \\
r,c        &:-& positive integers such that ${\cal A}$(r,c) neq 0.\\
row\_list  &:-& positive integer or a list of positive integers.
\end{tabular}

{\bf Synopsis:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt sprows\_pivot} performs the same task as {\tt sppivot} but applies 
the pivot only to the rows specified in row\_list.

\end{addtolength}

{\bf Related functions:}

\hspace*{0.175in} {\tt sppivot}.

\subsection{sparsematp}

\hspace*{0.175in} {\tt sparsematp(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt sparsematp} is a boolean function that returns t if 
                the matrix is declared sparse and nil otherwise.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
{\cal L}:= {\tt mat((1,2,3),(4,5,6),(7,8,9));}
\end{flushleft}

\vspace*{0.1in}

\hspace*{0.175in} {\tt sparsematp}(${\cal A}$) = t 

\hspace*{0.175in} {\tt sparsematp}(${\cal L}$) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt matrixp}, {\tt symmetricp}, {\tt squarep}.


\subsection{squarep}

\hspace*{0.175in} {\tt squarep(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix.
\end{tabular}

{\bf Synopsis:} 

\begin{addtolength}{\leftskip}{0.22in}
{\tt squarep} is a boolean function that returns t if 
                the matrix is square and nil otherwise.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal L} = \left( \begin{array}{ccc} 1 & 3 & 5 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\hspace*{0.175in} {\tt squarep}(${\cal A}$) = t 

\hspace*{0.175in} {\tt squarep}(${\cal L}$) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt matrixp}, {\tt symmetricp}, {\tt sparsematp}.


\subsection{spstack\_rows}

\hspace*{0.175in} see: {\tt spaugment\_columns}.


\subsection{spsub\_matrix}

\hspace*{0.175in} {\tt spsub\_matrix(${\cal A}$,row\_list,column\_list);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$              &:-& a sparse matrix. \\
row\_list, column\_list &:-& \parbox[t]{.605\linewidth}{either a 
positive integer or a list of positive integers.}
\end{tabular}

{\bf Synopsis:} 


\begin{addtolength}{\leftskip}{0.22in}

{\tt spsub\_matrix} produces the matrix consisting of the
              intersection of the rows specified in row\_list and the 
columns specified in column\_list. 

\end{addtolength}

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spsub\_matrix}({\cal A},\{1,3\},\{2,3\}) & = & 
        \left( \begin{array}{cc} 5 & 0\\ 0 & 9
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spaugment\_columns}, {\tt spstack\_rows}.


\subsection{spsvd (singular value decomposition)}

\hspace*{0.175in} {\tt spsvd(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a sparse matrix containing only numeric entries.
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt spsvd} computes the singular value decomposition of ${\cal A}$. 

It returns \{${\cal U},\sum,{\cal V}$\} where ${\cal A} = {\cal U} 
\sum {\cal V}^T$ and $\sum = diag(\sigma_{1}, \ldots ,\sigma_{n}). \; 
\sigma_{i}$ for $i= (1 \ldots n)$ are the singular values of ${\cal A}$.
 

n is the column dimension of ${\cal A}$.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal Q} = \left( \begin{array}{cc} 1 & 0 \\ 0 & 3 
\end{array} \right)
\end{math}  
\end{flushleft}

\begin{eqnarray}
\hspace*{0.1in}
{\tt svd({\cal Q})} & = & 
\left\{ 
        \left( \begin{array}{cc} -1 & 0 \\ 0 & 0 \end{array} \right), 
\left( \begin{array}{cc} 1.0 & 0 \\ 0 & 5.0 \end{array} \right), 
\right. \nonumber \\ & & \left. \: \; 
\, \left( \begin{array}{cc} -1 & 0 \\ 0 & -1 \end{array} \right)       
\right\} \nonumber \end{eqnarray}

\subsection{spswap\_columns, spswap\_rows}

\hspace*{0.175in} {\tt spswap\_columns(${\cal A}$,c1,c2);}

\hspace*{0.1in} 
\begin{tabular}{l l l}
${\cal A}$ &:-& a sparse matrix. \\
c1,c1      &:-& positive integers. 
\end{tabular}

{\bf Synopsis:} 

\hspace*{0.175in} 
{\tt spswap\_columns} swaps column c1 of ${\cal A}$ with column c2. 

\hspace*{0.175in} {\tt spswap\_rows} performs the same task on 2 rows of 
                ${\cal A}$.

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spswap\_columns}({\cal A},2,3) & = & 
        \left( \begin{array}{ccc} 1 & 0 & 0 \\ 0 & 0 & 5 \\ 0 & 9 & 0
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spswap\_entries}.


\subsection{swap\_entries}

\hspace*{0.175in} {\tt spswap\_entries(${\cal A}$,\{r1,c1\},\{r2,c2\});}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$  &:-& a sparse matrix. \\
r1,c1,r2,c2 &:-& positive integers.
\end{tabular}

{\bf Synopsis:} 

\hspace*{0.175in} {\tt spswap\_entries} swaps ${\cal A}$(r1,c1) with 
                ${\cal A}$(r2,c2).

{\bf Examples:}

\begin{flushleft}  
\hspace*{0.1in}
\begin{math}  
\begin{array}{ccc}
{\tt spswap\_entries}({\cal A},\{1,1\},\{3,3\}) & = & 
        \left( \begin{array}{ccc} 9 & 0 & 0 \\ 0 & 5 & 0 \\ 0 & 0 & 1
 \end{array} \right) 
\end{array}
\end{math}  
\end{flushleft}

{\bf Related functions:}

\hspace*{0.175in} {\tt spswap\_columns}, {\tt spswap\_rows}.


\subsection{spswap\_rows}

\hspace*{0.175in} see: {\tt spswap\_columns}.


\subsection{symmetricp}

%{\bf How to use it:}

\hspace*{0.175in} {\tt symmetricp(${\cal A}$);}

\hspace*{0.1in}  
\begin{tabular}{l l l} 
${\cal A}$ &:-& a matrix. 
\end{tabular}

{\bf Synopsis:} %{\bf What it does:}

\begin{addtolength}{\leftskip}{0.22in}
{\tt symmetricp} is a boolean function that returns t if the 
                matrix is symmetric and nil otherwise.

\end{addtolength}

{\bf Examples:}

\begin{flushleft}
\hspace*{0.175in}
\begin{math}  
{\cal M} = \left( \begin{array}{cc} 1 & 2 \\ 3 & 4 
\end{array} \right)
\end{math}  
\end{flushleft}

\vspace*{0.1in}

\hspace*{0.175in} {\tt symmetricp}(${\cal A}$) = t 

\hspace*{0.175in} {\tt symmetricp}(${\cal M}$) = nil

{\bf Related functions:}

\hspace*{0.175in} {\tt matrixp}, {\tt squarep}, {\tt sparsematp}.

\section{Fast Linear Algebra}

By turning the {\tt fast\_la} switch on, the speed of the following 
functions will be increased:

\begin{tabular}{l l l l}
spadd\_columns    & spadd\_rows      & spaugment\_columns & spcol\_dim  \\
spcopy\_into      & spmake\_identity & spmatrix\_augment  & spmatrix\_stack\\
spminor           & spmult\_column   &  spmult\_row       & sppivot        \\
spremove\_columns & spremove\_rows   & sprows\_pivot      & squarep      \\
spstack\_rows     & spsub\_matrix    & spswap\_columns    & spswap\_entries\\
spswap\_rows      & symmetricp                                     
\end{tabular}

The increase in speed will be insignificant unless you are making a 
significant number(i.e: thousands) of calls. When using this switch, 
error checking is minimised. This means that illegal input may give
strange error messages. Beware.

\section{Acknowledgments}
This package is an extention of the code from the Linear Algebra Package
for \REDUCE{} by Matt Rebbeck[1].

The algorithms for {\tt spcholesky}, {\tt splu\_decom}, and {\tt spsvd} are 
taken from the book Linear Algebra - J.H. Wilkinson \& C. Reinsch[3].

The {\tt spgram\_schmidt} code comes from Karin Gatermann's Symmetry 
package[4] for {\REDUCE}.


\begin{thebibliography}{}
\bibitem{matt} Matt Rebbeck: A Linear Algebra Package for {\REDUCE}, ZIB
, Berlin. (1994)
\bibitem{Reduce} Anthony C. Hearn: {\REDUCE} User's Manual 3.6.
	RAND (1995)
\bibitem{WiRe} J. H. Wilkinson \& C. Reinsch: Linear Algebra 
(volume II). Springer-Verlag (1971)
\bibitem{gat} Karin Gatermann: Symmetry: A {\REDUCE} package for the 
computation of linear representations of groups. ZIB, Berlin. (1992)
\end{thebibliography}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/sparse.red0000644000175000017500000000303611526203062023774 0ustar  giovannigiovannimodule sparse;  % Header for Sparse Matrix package.

% Author: Stephen Scowcroft.  Date: June 1995.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


load_package linalg;

create!-package('(sparse sparsmat spmateig splinalg spludcmp spchlsky
                  spsvd spgrmshm),'(contrib linalg));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/sparse.rlg0000644000175000017500000010203711527635055024023 0ustar  giovannigiovanniFri Feb 18 21:27:59 2011 run on win32
% Test file for Sparse Matrices and the Linear Algebra Package for
% Sparse Matrices.

% Author: Stephen Scowcroft.                    Date: June 1995.

% Firstly, the matrices need to be created.

% This is the standard way to create a sparse matrix.

% Create a sparse matrix.

sparse mat1(5,5);



%Fill the sparse matrix with data

mat1(1,1):=2;


mat1(1,1) := 2

mat1(2,2):=4;


mat1(2,2) := 4

mat1(3,3):=6;


mat1(3,3) := 6

mat1(4,4):=8;


mat1(4,4) := 8

mat1(5,5):=10;


mat1(5,5) := 10


sparse mat4(5,5);



mat4(1,1):=x;


mat4(1,1) := x

mat4(2,2):=x;


mat4(2,2) := x

mat4(3,3):=x;


mat4(3,3) := x

mat4(4,4):=x;


mat4(4,4) := x

mat4(5,5):=x;


mat4(5,5) := x


% A small function to automatically fill a sparse matrix with data.

procedure makematsp(nam,row);
 begin; 
  sparse nam(row,row);
    for i := 1:row do <>
 end;


makematsp


clear mat2;


makematsp(mat2,100);



% Matrices created in the standard Matrix way.

zz1:=mat((1,2),(3,4));


       [1  2]
zz1 := [    ]
       [3  4]


zz2:=mat((x,x),(x,x));


       [x  x]
zz2 := [    ]
       [x  x]


zz3:=mat((i+1,i+2,i+3),(4,5,2),(1,i,0));


       [i + 1  i + 2  i + 3]
       [                   ]
zz3 := [  4      5      2  ]
       [                   ]
       [  1      i      0  ]



% I have taken advantage of the Linear Algebra Package (Matt Rebbeck)
% in order to create some Sparse Matrices.

mat3:=diagonal(zz1,zz1,zz1);


        [1  2  0  0  0  0]
        [                ]
        [3  4  0  0  0  0]
        [                ]
        [0  0  1  2  0  0]
mat3 := [                ]
        [0  0  3  4  0  0]
        [                ]
        [0  0  0  0  1  2]
        [                ]
        [0  0  0  0  3  4]


mat5:=band_matrix({1,3,1},100)$


mat6:=diagonal(zz3,zz3);


        [i + 1  i + 2  i + 3    0      0      0  ]
        [                                        ]
        [  4      5      2      0      0      0  ]
        [                                        ]
        [  1      i      0      0      0      0  ]
mat6 := [                                        ]
        [  0      0      0    i + 1  i + 2  i + 3]
        [                                        ]
        [  0      0      0      4      5      2  ]
        [                                        ]
        [  0      0      0      1      i      0  ]


mat7:=band_matrix({a,b,c},4);


        [b  c  0  0]
        [          ]
        [a  b  c  0]
mat7 := [          ]
        [0  a  b  c]
        [          ]
        [0  0  a  b]



% These are then "translated" into the Sparse operator using the 
% function transmat.
% This is a destructive function in the sense that the matrices are no
% longer of type 'matrix but are now 'sparse.

transmat mat3;


transmat mat5;


transmat mat6;


transmat mat7;



poly  := x^7+x^5+4*x^4+5*x^3+12;


         7    5      4      3
poly := x  + x  + 4*x  + 5*x  + 12

poly1 := x^2+x*y^3+x*y*z^3+y*x+2+y*3;


          2      3        3
poly1 := x  + x*y  + x*y*z  + x*y + 3*y + 2


% Firstly some basic matrix operations.
% These are the same as the present matrix package

mat1^-1;



             1
spm(1,1) := ---$
             2

             1
spm(2,2) := ---$
             4

             1
spm(3,3) := ---$
             6

             1
spm(4,4) := ---$
             8

             1
spm(5,5) := ----$
             10

mat4^-1;



             1
spm(1,1) := ---$
             x

             1
spm(2,2) := ---$
             x

             1
spm(3,3) := ---$
             x

             1
spm(4,4) := ---$
             x

             1
spm(5,5) := ---$
             x

mat2 + mat5$


mat2 - mat5$


mat1-mat1;


"Empty Matrix"

mat4 + mat1;



spm(1,1) := x + 2$

spm(2,2) := x + 4$

spm(3,3) := x + 6$

spm(4,4) := x + 8$

spm(5,5) := x + 10$

mat4 * mat1;



spm(1,1) := 2*x$

spm(2,2) := 4*x$

spm(3,3) := 6*x$

spm(4,4) := 8*x$

spm(5,5) := 10*x$


2*mat1 + (3*mat4 + mat1);



spm(1,1) := 3*(x + 2)$

spm(2,2) := 3*(x + 4)$

spm(3,3) := 3*(x + 6)$

spm(4,4) := 3*(x + 8)$

spm(5,5) := 3*(x + 10)$

% It is also possible to combine both 'matrix and 'sparse type matrices
% in these operations.

pp:=band_matrix({1,3,1},100)$


mat5*pp;



spm(1,1) := 10$

spm(1,2) := 6$

spm(1,3) := 1$

spm(2,1) := 6$

spm(2,2) := 11$

spm(2,3) := 6$

spm(2,4) := 1$

spm(3,1) := 1$

spm(3,2) := 6$

spm(3,3) := 11$

spm(3,4) := 6$

spm(3,5) := 1$

spm(4,2) := 1$

spm(4,3) := 6$

spm(4,4) := 11$

spm(4,5) := 6$

spm(4,6) := 1$

spm(5,3) := 1$

spm(5,4) := 6$

spm(5,5) := 11$

spm(5,6) := 6$

spm(5,7) := 1$

spm(6,4) := 1$

spm(6,5) := 6$

spm(6,6) := 11$

spm(6,7) := 6$

spm(6,8) := 1$

spm(7,5) := 1$

spm(7,6) := 6$

spm(7,7) := 11$

spm(7,8) := 6$

spm(7,9) := 1$

spm(8,6) := 1$

spm(8,7) := 6$

spm(8,8) := 11$

spm(8,9) := 6$

spm(8,10) := 1$

spm(9,7) := 1$

spm(9,8) := 6$

spm(9,9) := 11$

spm(9,10) := 6$

spm(9,11) := 1$

spm(10,8) := 1$

spm(10,9) := 6$

spm(10,10) := 11$

spm(10,11) := 6$

spm(10,12) := 1$

spm(11,9) := 1$

spm(11,10) := 6$

spm(11,11) := 11$

spm(11,12) := 6$

spm(11,13) := 1$

spm(12,10) := 1$

spm(12,11) := 6$

spm(12,12) := 11$

spm(12,13) := 6$

spm(12,14) := 1$

spm(13,11) := 1$

spm(13,12) := 6$

spm(13,13) := 11$

spm(13,14) := 6$

spm(13,15) := 1$

spm(14,12) := 1$

spm(14,13) := 6$

spm(14,14) := 11$

spm(14,15) := 6$

spm(14,16) := 1$

spm(15,13) := 1$

spm(15,14) := 6$

spm(15,15) := 11$

spm(15,16) := 6$

spm(15,17) := 1$

spm(16,14) := 1$

spm(16,15) := 6$

spm(16,16) := 11$

spm(16,17) := 6$

spm(16,18) := 1$

spm(17,15) := 1$

spm(17,16) := 6$

spm(17,17) := 11$

spm(17,18) := 6$

spm(17,19) := 1$

spm(18,16) := 1$

spm(18,17) := 6$

spm(18,18) := 11$

spm(18,19) := 6$

spm(18,20) := 1$

spm(19,17) := 1$

spm(19,18) := 6$

spm(19,19) := 11$

spm(19,20) := 6$

spm(19,21) := 1$

spm(20,18) := 1$

spm(20,19) := 6$

spm(20,20) := 11$

spm(20,21) := 6$

spm(20,22) := 1$

spm(21,19) := 1$

spm(21,20) := 6$

spm(21,21) := 11$

spm(21,22) := 6$

spm(21,23) := 1$

spm(22,20) := 1$

spm(22,21) := 6$

spm(22,22) := 11$

spm(22,23) := 6$

spm(22,24) := 1$

spm(23,21) := 1$

spm(23,22) := 6$

spm(23,23) := 11$

spm(23,24) := 6$

spm(23,25) := 1$

spm(24,22) := 1$

spm(24,23) := 6$

spm(24,24) := 11$

spm(24,25) := 6$

spm(24,26) := 1$

spm(25,23) := 1$

spm(25,24) := 6$

spm(25,25) := 11$

spm(25,26) := 6$

spm(25,27) := 1$

spm(26,24) := 1$

spm(26,25) := 6$

spm(26,26) := 11$

spm(26,27) := 6$

spm(26,28) := 1$

spm(27,25) := 1$

spm(27,26) := 6$

spm(27,27) := 11$

spm(27,28) := 6$

spm(27,29) := 1$

spm(28,26) := 1$

spm(28,27) := 6$

spm(28,28) := 11$

spm(28,29) := 6$

spm(28,30) := 1$

spm(29,27) := 1$

spm(29,28) := 6$

spm(29,29) := 11$

spm(29,30) := 6$

spm(29,31) := 1$

spm(30,28) := 1$

spm(30,29) := 6$

spm(30,30) := 11$

spm(30,31) := 6$

spm(30,32) := 1$

spm(31,29) := 1$

spm(31,30) := 6$

spm(31,31) := 11$

spm(31,32) := 6$

spm(31,33) := 1$

spm(32,30) := 1$

spm(32,31) := 6$

spm(32,32) := 11$

spm(32,33) := 6$

spm(32,34) := 1$

spm(33,31) := 1$

spm(33,32) := 6$

spm(33,33) := 11$

spm(33,34) := 6$

spm(33,35) := 1$

spm(34,32) := 1$

spm(34,33) := 6$

spm(34,34) := 11$

spm(34,35) := 6$

spm(34,36) := 1$

spm(35,33) := 1$

spm(35,34) := 6$

spm(35,35) := 11$

spm(35,36) := 6$

spm(35,37) := 1$

spm(36,34) := 1$

spm(36,35) := 6$

spm(36,36) := 11$

spm(36,37) := 6$

spm(36,38) := 1$

spm(37,35) := 1$

spm(37,36) := 6$

spm(37,37) := 11$

spm(37,38) := 6$

spm(37,39) := 1$

spm(38,36) := 1$

spm(38,37) := 6$

spm(38,38) := 11$

spm(38,39) := 6$

spm(38,40) := 1$

spm(39,37) := 1$

spm(39,38) := 6$

spm(39,39) := 11$

spm(39,40) := 6$

spm(39,41) := 1$

spm(40,38) := 1$

spm(40,39) := 6$

spm(40,40) := 11$

spm(40,41) := 6$

spm(40,42) := 1$

spm(41,39) := 1$

spm(41,40) := 6$

spm(41,41) := 11$

spm(41,42) := 6$

spm(41,43) := 1$

spm(42,40) := 1$

spm(42,41) := 6$

spm(42,42) := 11$

spm(42,43) := 6$

spm(42,44) := 1$

spm(43,41) := 1$

spm(43,42) := 6$

spm(43,43) := 11$

spm(43,44) := 6$

spm(43,45) := 1$

spm(44,42) := 1$

spm(44,43) := 6$

spm(44,44) := 11$

spm(44,45) := 6$

spm(44,46) := 1$

spm(45,43) := 1$

spm(45,44) := 6$

spm(45,45) := 11$

spm(45,46) := 6$

spm(45,47) := 1$

spm(46,44) := 1$

spm(46,45) := 6$

spm(46,46) := 11$

spm(46,47) := 6$

spm(46,48) := 1$

spm(47,45) := 1$

spm(47,46) := 6$

spm(47,47) := 11$

spm(47,48) := 6$

spm(47,49) := 1$

spm(48,46) := 1$

spm(48,47) := 6$

spm(48,48) := 11$

spm(48,49) := 6$

spm(48,50) := 1$

spm(49,47) := 1$

spm(49,48) := 6$

spm(49,49) := 11$

spm(49,50) := 6$

spm(49,51) := 1$

spm(50,48) := 1$

spm(50,49) := 6$

spm(50,50) := 11$

spm(50,51) := 6$

spm(50,52) := 1$

spm(51,49) := 1$

spm(51,50) := 6$

spm(51,51) := 11$

spm(51,52) := 6$

spm(51,53) := 1$

spm(52,50) := 1$

spm(52,51) := 6$

spm(52,52) := 11$

spm(52,53) := 6$

spm(52,54) := 1$

spm(53,51) := 1$

spm(53,52) := 6$

spm(53,53) := 11$

spm(53,54) := 6$

spm(53,55) := 1$

spm(54,52) := 1$

spm(54,53) := 6$

spm(54,54) := 11$

spm(54,55) := 6$

spm(54,56) := 1$

spm(55,53) := 1$

spm(55,54) := 6$

spm(55,55) := 11$

spm(55,56) := 6$

spm(55,57) := 1$

spm(56,54) := 1$

spm(56,55) := 6$

spm(56,56) := 11$

spm(56,57) := 6$

spm(56,58) := 1$

spm(57,55) := 1$

spm(57,56) := 6$

spm(57,57) := 11$

spm(57,58) := 6$

spm(57,59) := 1$

spm(58,56) := 1$

spm(58,57) := 6$

spm(58,58) := 11$

spm(58,59) := 6$

spm(58,60) := 1$

spm(59,57) := 1$

spm(59,58) := 6$

spm(59,59) := 11$

spm(59,60) := 6$

spm(59,61) := 1$

spm(60,58) := 1$

spm(60,59) := 6$

spm(60,60) := 11$

spm(60,61) := 6$

spm(60,62) := 1$

spm(61,59) := 1$

spm(61,60) := 6$

spm(61,61) := 11$

spm(61,62) := 6$

spm(61,63) := 1$

spm(62,60) := 1$

spm(62,61) := 6$

spm(62,62) := 11$

spm(62,63) := 6$

spm(62,64) := 1$

spm(63,61) := 1$

spm(63,62) := 6$

spm(63,63) := 11$

spm(63,64) := 6$

spm(63,65) := 1$

spm(64,62) := 1$

spm(64,63) := 6$

spm(64,64) := 11$

spm(64,65) := 6$

spm(64,66) := 1$

spm(65,63) := 1$

spm(65,64) := 6$

spm(65,65) := 11$

spm(65,66) := 6$

spm(65,67) := 1$

spm(66,64) := 1$

spm(66,65) := 6$

spm(66,66) := 11$

spm(66,67) := 6$

spm(66,68) := 1$

spm(67,65) := 1$

spm(67,66) := 6$

spm(67,67) := 11$

spm(67,68) := 6$

spm(67,69) := 1$

spm(68,66) := 1$

spm(68,67) := 6$

spm(68,68) := 11$

spm(68,69) := 6$

spm(68,70) := 1$

spm(69,67) := 1$

spm(69,68) := 6$

spm(69,69) := 11$

spm(69,70) := 6$

spm(69,71) := 1$

spm(70,68) := 1$

spm(70,69) := 6$

spm(70,70) := 11$

spm(70,71) := 6$

spm(70,72) := 1$

spm(71,69) := 1$

spm(71,70) := 6$

spm(71,71) := 11$

spm(71,72) := 6$

spm(71,73) := 1$

spm(72,70) := 1$

spm(72,71) := 6$

spm(72,72) := 11$

spm(72,73) := 6$

spm(72,74) := 1$

spm(73,71) := 1$

spm(73,72) := 6$

spm(73,73) := 11$

spm(73,74) := 6$

spm(73,75) := 1$

spm(74,72) := 1$

spm(74,73) := 6$

spm(74,74) := 11$

spm(74,75) := 6$

spm(74,76) := 1$

spm(75,73) := 1$

spm(75,74) := 6$

spm(75,75) := 11$

spm(75,76) := 6$

spm(75,77) := 1$

spm(76,74) := 1$

spm(76,75) := 6$

spm(76,76) := 11$

spm(76,77) := 6$

spm(76,78) := 1$

spm(77,75) := 1$

spm(77,76) := 6$

spm(77,77) := 11$

spm(77,78) := 6$

spm(77,79) := 1$

spm(78,76) := 1$

spm(78,77) := 6$

spm(78,78) := 11$

spm(78,79) := 6$

spm(78,80) := 1$

spm(79,77) := 1$

spm(79,78) := 6$

spm(79,79) := 11$

spm(79,80) := 6$

spm(79,81) := 1$

spm(80,78) := 1$

spm(80,79) := 6$

spm(80,80) := 11$

spm(80,81) := 6$

spm(80,82) := 1$

spm(81,79) := 1$

spm(81,80) := 6$

spm(81,81) := 11$

spm(81,82) := 6$

spm(81,83) := 1$

spm(82,80) := 1$

spm(82,81) := 6$

spm(82,82) := 11$

spm(82,83) := 6$

spm(82,84) := 1$

spm(83,81) := 1$

spm(83,82) := 6$

spm(83,83) := 11$

spm(83,84) := 6$

spm(83,85) := 1$

spm(84,82) := 1$

spm(84,83) := 6$

spm(84,84) := 11$

spm(84,85) := 6$

spm(84,86) := 1$

spm(85,83) := 1$

spm(85,84) := 6$

spm(85,85) := 11$

spm(85,86) := 6$

spm(85,87) := 1$

spm(86,84) := 1$

spm(86,85) := 6$

spm(86,86) := 11$

spm(86,87) := 6$

spm(86,88) := 1$

spm(87,85) := 1$

spm(87,86) := 6$

spm(87,87) := 11$

spm(87,88) := 6$

spm(87,89) := 1$

spm(88,86) := 1$

spm(88,87) := 6$

spm(88,88) := 11$

spm(88,89) := 6$

spm(88,90) := 1$

spm(89,87) := 1$

spm(89,88) := 6$

spm(89,89) := 11$

spm(89,90) := 6$

spm(89,91) := 1$

spm(90,88) := 1$

spm(90,89) := 6$

spm(90,90) := 11$

spm(90,91) := 6$

spm(90,92) := 1$

spm(91,89) := 1$

spm(91,90) := 6$

spm(91,91) := 11$

spm(91,92) := 6$

spm(91,93) := 1$

spm(92,90) := 1$

spm(92,91) := 6$

spm(92,92) := 11$

spm(92,93) := 6$

spm(92,94) := 1$

spm(93,91) := 1$

spm(93,92) := 6$

spm(93,93) := 11$

spm(93,94) := 6$

spm(93,95) := 1$

spm(94,92) := 1$

spm(94,93) := 6$

spm(94,94) := 11$

spm(94,95) := 6$

spm(94,96) := 1$

spm(95,93) := 1$

spm(95,94) := 6$

spm(95,95) := 11$

spm(95,96) := 6$

spm(95,97) := 1$

spm(96,94) := 1$

spm(96,95) := 6$

spm(96,96) := 11$

spm(96,97) := 6$

spm(96,98) := 1$

spm(97,95) := 1$

spm(97,96) := 6$

spm(97,97) := 11$

spm(97,98) := 6$

spm(97,99) := 1$

spm(98,96) := 1$

spm(98,97) := 6$

spm(98,98) := 11$

spm(98,99) := 6$

spm(98,100) := 1$

spm(99,97) := 1$

spm(99,98) := 6$

spm(99,99) := 11$

spm(99,100) := 6$

spm(100,98) := 1$

spm(100,99) := 6$

spm(100,100) := 10$


mat5^2$



det(mat1);


3840

det(mat4);


 5
x

trace(mat1);


30

trace(mat4);


5*x


rank(mat1);


5

rank mat5;


100


tp(mat3);



spm(1,1) := 1$

spm(1,2) := 3$

spm(2,1) := 2$

spm(2,2) := 4$

spm(3,3) := 1$

spm(3,4) := 3$

spm(4,3) := 2$

spm(4,4) := 4$

spm(5,5) := 1$

spm(5,6) := 3$

spm(6,5) := 2$

spm(6,6) := 4$


spmateigen(mat3,eta);


     2
{{eta  - 5*eta - 2,3,

               2*arbcomplex(1)*(eta + 1)
  spm(1,1) := ---------------------------$
                       5*eta + 1

  spm(2,1) := arbcomplex(1)$

               2*arbcomplex(2)*(eta + 1)
  spm(3,1) := ---------------------------$
                       5*eta + 1

  spm(4,1) := arbcomplex(2)$

               2*arbcomplex(3)*(eta + 1)
  spm(5,1) := ---------------------------$
                       5*eta + 1

  spm(6,1) := arbcomplex(3)$
  }}


% Next, tests for the Linear Algebra Package for Sparse Matrices.

%Basic matrix manipulations.

spadd_columns(mat1,1,2,5*y);



spm(1,1) := 2$

spm(1,2) := 10*y$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$

spadd_rows(mat1,1,2,x);



spm(1,1) := 2$

spm(2,1) := 2*x$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$


spadd_to_columns(mat1,3,1000);



spm(1,1) := 2$

spm(1,3) := 1000$

spm(2,2) := 4$

spm(2,3) := 1000$

spm(3,3) := 1006$

spm(4,3) := 1000$

spm(4,4) := 8$

spm(5,3) := 1000$

spm(5,5) := 10$

spadd_to_columns(mat5,{1,2,3},y)$


spadd_to_rows(mat1,2,1000);



spm(1,1) := 2$

spm(2,1) := 1000$

spm(2,2) := 1004$

spm(2,3) := 1000$

spm(2,4) := 1000$

spm(2,5) := 1000$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$

spadd_to_rows(mat5,{1,2,3},x)$



spaugment_columns(mat3,2);



spm(1,1) := 2$

spm(2,1) := 4$
  
spaugment_columns(mat1,{1,2,5});



spm(1,1) := 2$

spm(2,2) := 4$

spm(5,3) := 10$

spstack_rows(mat1,3);



spm(1,3) := 6$
  
spstack_rows(mat1,{1,3,5});



spm(1,1) := 2$

spm(2,3) := 6$

spm(3,5) := 10$
  

spchar_poly(mat1,x);


 5       4        3         2
x  - 30*x  + 340*x  - 1800*x  + 4384*x - 3840


spcol_dim(mat2);


100

sprow_dim(mat1);


5


spcopy_into(mat7,mat1,2,2);



spm(1,1) := 2$

spm(2,2) := b$

spm(2,3) := c$

spm(3,2) := a$

spm(3,3) := b$

spm(3,4) := c$

spm(4,3) := a$

spm(4,4) := b$

spm(4,5) := c$

spm(5,4) := a$

spm(5,5) := b$

spcopy_into(mat7,mat1,5,5);

***** Error in spcopy_into: the matrix

spm(1,1) := b$

spm(1,2) := c$

spm(2,1) := a$

spm(2,2) := b$

spm(2,3) := c$

spm(3,2) := a$

spm(3,3) := b$

spm(3,4) := c$

spm(4,3) := a$

spm(4,4) := b$
      does not fit into

spm(1,1) := 2$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$
      at position 5,5.

spcopy_into(zz1,mat1,1,1);



spm(1,1) := 1$

spm(1,2) := 2$

spm(2,1) := 3$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$


spdiagonal(3);



spm(1,1) := 3$

% spdiagonal can take both a list of arguments or just the arguments.
spdiagonal({mat2,mat5})$


spdiagonal(mat2,mat5)$


% spdiagonal can also take a mixture of 'sparse and 'matrix types.
spdiagonal(zz1,mat4,zz1);



spm(1,1) := 1$

spm(1,2) := 2$

spm(2,1) := 3$

spm(2,2) := 4$

spm(3,3) := x$

spm(4,4) := x$

spm(5,5) := x$

spm(6,6) := x$

spm(7,7) := x$

spm(8,8) := 1$

spm(8,9) := 2$

spm(9,8) := 3$

spm(9,9) := 4$


spextend(mat1,3,2,x);



spm(1,1) := 2$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 10$

spm(6,6) := x$

spm(6,7) := x$

spm(7,6) := x$

spm(7,7) := x$

spm(8,6) := x$

spm(8,7) := x$


spfind_companion(mat5,x);


 98   2
x  *(x  - 3*x - 1)


spget_columns(mat1,1);


{

 spm(1,1) := 2$
 }

spget_columns(mat1,{1,2});


{

 spm(1,1) := 2$
 ,

 spm(2,1) := 4$
 }

spget_rows(mat1,3);


{

 spm(1,3) := 6$
 }

spget_rows(mat1,{1,3});


{

 spm(1,1) := 2$
 ,

 spm(1,3) := 6$
 }


sphermitian_tp(mat6);



spm(1,1) :=  - i + 1$

spm(1,2) := 4$

spm(1,3) := 1$

spm(2,1) :=  - i + 2$

spm(2,2) := 5$

spm(2,3) :=  - i$

spm(3,1) :=  - i + 3$

spm(3,2) := 2$

spm(4,4) :=  - i + 1$

spm(4,5) := 4$

spm(4,6) := 1$

spm(5,4) :=  - i + 2$

spm(5,5) := 5$

spm(5,6) :=  - i$

spm(6,4) :=  - i + 3$

spm(6,5) := 2$


% matrix_augment and matrix_stack can take both a list of arguments 
% or just the arguments.

spmatrix_augment({mat1,mat1});



spm(1,1) := 2$

spm(1,6) := 2$

spm(2,2) := 4$

spm(2,7) := 4$

spm(3,3) := 6$

spm(3,8) := 6$

spm(4,4) := 8$

spm(4,9) := 8$

spm(5,5) := 10$

spm(5,10) := 10$

spmatrix_augment(mat5,mat2,mat5)$


spmatrix_stack(mat2,mat2)$



spminor(mat1,2,3);



spm(1,1) := 2$

spm(3,3) := 8$

spm(4,4) := 10$


spmult_columns(mat1,3,y);



spm(1,1) := 2$

spm(2,2) := 4$

spm(3,3) := 6*y$

spm(4,4) := 8$

spm(5,5) := 10$

spmult_columns(mat2,{2,3,4},100)$


spmult_rows(mat2,2,x);



spm(1,1) := 1$

spm(2,2) := 2*x$

spm(3,3) := 3$

spm(4,4) := 4$

spm(5,5) := 5$

spm(6,6) := 6$

spm(7,7) := 7$

spm(8,8) := 8$

spm(9,9) := 9$

spm(10,10) := 10$

spm(11,11) := 11$

spm(12,12) := 12$

spm(13,13) := 13$

spm(14,14) := 14$

spm(15,15) := 15$

spm(16,16) := 16$

spm(17,17) := 17$

spm(18,18) := 18$

spm(19,19) := 19$

spm(20,20) := 20$

spm(21,21) := 21$

spm(22,22) := 22$

spm(23,23) := 23$

spm(24,24) := 24$

spm(25,25) := 25$

spm(26,26) := 26$

spm(27,27) := 27$

spm(28,28) := 28$

spm(29,29) := 29$

spm(30,30) := 30$

spm(31,31) := 31$

spm(32,32) := 32$

spm(33,33) := 33$

spm(34,34) := 34$

spm(35,35) := 35$

spm(36,36) := 36$

spm(37,37) := 37$

spm(38,38) := 38$

spm(39,39) := 39$

spm(40,40) := 40$

spm(41,41) := 41$

spm(42,42) := 42$

spm(43,43) := 43$

spm(44,44) := 44$

spm(45,45) := 45$

spm(46,46) := 46$

spm(47,47) := 47$

spm(48,48) := 48$

spm(49,49) := 49$

spm(50,50) := 50$

spm(51,51) := 51$

spm(52,52) := 52$

spm(53,53) := 53$

spm(54,54) := 54$

spm(55,55) := 55$

spm(56,56) := 56$

spm(57,57) := 57$

spm(58,58) := 58$

spm(59,59) := 59$

spm(60,60) := 60$

spm(61,61) := 61$

spm(62,62) := 62$

spm(63,63) := 63$

spm(64,64) := 64$

spm(65,65) := 65$

spm(66,66) := 66$

spm(67,67) := 67$

spm(68,68) := 68$

spm(69,69) := 69$

spm(70,70) := 70$

spm(71,71) := 71$

spm(72,72) := 72$

spm(73,73) := 73$

spm(74,74) := 74$

spm(75,75) := 75$

spm(76,76) := 76$

spm(77,77) := 77$

spm(78,78) := 78$

spm(79,79) := 79$

spm(80,80) := 80$

spm(81,81) := 81$

spm(82,82) := 82$

spm(83,83) := 83$

spm(84,84) := 84$

spm(85,85) := 85$

spm(86,86) := 86$

spm(87,87) := 87$

spm(88,88) := 88$

spm(89,89) := 89$

spm(90,90) := 90$

spm(91,91) := 91$

spm(92,92) := 92$

spm(93,93) := 93$

spm(94,94) := 94$

spm(95,95) := 95$

spm(96,96) := 96$

spm(97,97) := 97$

spm(98,98) := 98$

spm(99,99) := 99$

spm(100,100) := 100$

spmult_rows(mat1,{1,3,5},10);



spm(1,1) := 20$

spm(2,2) := 4$

spm(3,3) := 60$

spm(4,4) := 8$

spm(5,5) := 100$


sppivot(mat3,3,3);



spm(1,1) := 1$

spm(1,2) := 2$

spm(2,1) := 3$

spm(2,2) := 4$

spm(3,3) := 1$

spm(3,4) := 2$

spm(4,4) := -2$

spm(5,5) := 1$

spm(5,6) := 2$

spm(6,5) := 3$

spm(6,6) := 4$

sprows_pivot(mat3,1,1,{2,4});



spm(1,1) := 1$

spm(1,2) := 2$

spm(2,2) := -2$

spm(3,3) := 1$

spm(3,4) := 2$

spm(4,3) := 3$

spm(4,4) := 4$

spm(5,5) := 1$

spm(5,6) := 2$

spm(6,5) := 3$

spm(6,6) := 4$


spremove_columns(mat1,3);



spm(1,1) := 2$

spm(2,2) := 4$

spm(4,3) := 8$

spm(5,4) := 10$

spremove_columns(mat3,{2,3,4});



spm(1,1) := 1$

spm(2,1) := 3$

spm(5,2) := 1$

spm(5,3) := 2$

spm(6,2) := 3$

spm(6,3) := 4$

spremove_rows(mat1,2);



spm(1,1) := 2$

spm(2,3) := 6$

spm(3,4) := 8$

spm(4,5) := 10$

spremove_rows(mat2,{1,3})$


spremove_rows(mat1,{1,2,3,4,5});

***** Warning in spremove_rows:
      all the rows have been removed. Returning nil.


spswap_cols(mat1,2,4);



spm(1,1) := 2$

spm(2,4) := 4$

spm(3,3) := 6$

spm(4,2) := 8$

spm(5,5) := 10$

spswap_rows(mat5,1,2)$


spswap_entries(mat1,{1,1},{5,5});



spm(1,1) := 10$

spm(2,2) := 4$

spm(3,3) := 6$

spm(4,4) := 8$

spm(5,5) := 2$




% Constructors - functions that create matrices.

spband_matrix(x,500)$


spband_matrix({x,y,z},6000)$



spblock_matrix(1,2,{mat1,mat1});



spm(1,1) := 2$

spm(1,6) := 2$

spm(2,2) := 4$

spm(2,7) := 4$

spm(3,3) := 6$

spm(3,8) := 6$

spm(4,4) := 8$

spm(4,9) := 8$

spm(5,5) := 10$

spm(5,10) := 10$

spblock_matrix(2,3,{mat3,mat6,mat3,mat6,mat3,mat6});



spm(1,1) := 1$

spm(1,2) := 2$

spm(1,7) := i + 1$

spm(1,8) := i + 2$

spm(1,9) := i + 3$

spm(1,13) := 1$

spm(1,14) := 2$

spm(2,1) := 3$

spm(2,2) := 4$

spm(2,7) := 4$

spm(2,8) := 5$

spm(2,9) := 2$

spm(2,13) := 3$

spm(2,14) := 4$

spm(3,3) := 1$

spm(3,4) := 2$

spm(3,7) := 1$

spm(3,8) := i$

spm(3,15) := 1$

spm(3,16) := 2$

spm(4,3) := 3$

spm(4,4) := 4$

spm(4,10) := i + 1$

spm(4,11) := i + 2$

spm(4,12) := i + 3$

spm(4,15) := 3$

spm(4,16) := 4$

spm(5,5) := 1$

spm(5,6) := 2$

spm(5,10) := 4$

spm(5,11) := 5$

spm(5,12) := 2$

spm(5,17) := 1$

spm(5,18) := 2$

spm(6,5) := 3$

spm(6,6) := 4$

spm(6,10) := 1$

spm(6,11) := i$

spm(6,17) := 3$

spm(6,18) := 4$

spm(7,1) := i + 1$

spm(7,2) := i + 2$

spm(7,3) := i + 3$

spm(7,7) := 1$

spm(7,8) := 2$

spm(7,13) := i + 1$

spm(7,14) := i + 2$

spm(7,15) := i + 3$

spm(8,1) := 4$

spm(8,2) := 5$

spm(8,3) := 2$

spm(8,7) := 3$

spm(8,8) := 4$

spm(8,13) := 4$

spm(8,14) := 5$

spm(8,15) := 2$

spm(9,1) := 1$

spm(9,2) := i$

spm(9,9) := 1$

spm(9,10) := 2$

spm(9,13) := 1$

spm(9,14) := i$

spm(10,4) := i + 1$

spm(10,5) := i + 2$

spm(10,6) := i + 3$

spm(10,9) := 3$

spm(10,10) := 4$

spm(10,16) := i + 1$

spm(10,17) := i + 2$

spm(10,18) := i + 3$

spm(11,4) := 4$

spm(11,5) := 5$

spm(11,6) := 2$

spm(11,11) := 1$

spm(11,12) := 2$

spm(11,16) := 4$

spm(11,17) := 5$

spm(11,18) := 2$

spm(12,4) := 1$

spm(12,5) := i$

spm(12,11) := 3$

spm(12,12) := 4$

spm(12,16) := 1$

spm(12,17) := i$


spchar_matrix(mat3,x);



spm(1,1) := x - 1$

spm(1,2) := -2$

spm(2,1) := -3$

spm(2,2) := x - 4$

spm(3,3) := x - 1$

spm(3,4) := -2$

spm(4,3) := -3$

spm(4,4) := x - 4$

spm(5,5) := x - 1$

spm(5,6) := -2$

spm(6,5) := -3$

spm(6,6) := x - 4$


cfmat := spcoeff_matrix({y+4*+-5*w=10,y-z=20,y+4+3*z,w+x+50});


{

 spm(1,1) := 1$

 spm(1,2) := -20$

 spm(2,1) := 1$

 spm(2,3) := -1$

 spm(3,1) := 1$

 spm(3,3) := 3$

 spm(4,2) := 1$

 spm(4,4) := 1$
 ,

 spm(1,1) := y$

 spm(2,1) := w$

 spm(3,1) := z$

 spm(4,1) := x$
 ,

 spm(1,1) := 10$

 spm(2,1) := 20$

 spm(3,1) := -4$

 spm(4,1) := -50$
cfmat :=  }

first cfmat * second cfmat;



spm(1,1) :=  - 20*w + y$

spm(2,1) := y - z$

spm(3,1) := y + 3*z$

spm(4,1) := w + x$

third cfmat;



spm(1,1) := 10$

spm(2,1) := 20$

spm(3,1) := -4$

spm(4,1) := -50$


spcompanion(poly,x);



spm(1,7) := -12$

spm(2,1) := 1$

spm(3,2) := 1$

spm(4,3) := 1$

spm(4,7) := -5$

spm(5,4) := 1$

spm(5,7) := -4$

spm(6,5) := 1$

spm(6,7) := -1$

spm(7,6) := 1$


sphessian(poly1,{w,x,y,z});



spm(2,2) := 2$

               2    3
spm(2,3) := 3*y  + z  + 1$

                 2
spm(2,4) := 3*y*z $

               2    3
spm(3,2) := 3*y  + z  + 1$

spm(3,3) := 6*x*y$

                 2
spm(3,4) := 3*x*z $

                 2
spm(4,2) := 3*y*z $

                 2
spm(4,3) := 3*x*z $

spm(4,4) := 6*x*y*z$


spjacobian({x^4,x*y^2,x*y*z^3},{w,x,y,z});



               3
spm(1,2) := 4*x $

             2
spm(2,2) := y $

spm(2,3) := 2*x*y$

               3
spm(3,2) := y*z $

               3
spm(3,3) := x*z $

                   2
spm(3,4) := 3*x*y*z $


spjordan_block(x,500)$



spmake_identity(1000)$



on rounded;

 % makes output easier to read.
ch := spcholesky(mat1);


{

 spm(1,1) := 1.41421356237$

 spm(2,2) := 2.0$

 spm(3,3) := 2.44948974278$

 spm(4,4) := 2.82842712475$

 spm(5,5) := 3.16227766017$
 ,

 spm(1,1) := 1.41421356237$

 spm(2,2) := 2.0$

 spm(3,3) := 2.44948974278$

 spm(4,4) := 2.82842712475$

 spm(5,5) := 3.16227766017$
ch :=  }

tp first ch - second ch;


"Empty Matrix"

tmp := first ch * second ch;



spm(1,1) := 2.0$

spm(2,2) := 4.0$

spm(3,3) := 6.0$

spm(4,4) := 8.0$

spm(5,5) := 10.0$
tmp := 

tmp - mat1;


"Empty Matrix"

off rounded;



% The gram schmidt functions takes a list of vectors.
% These vectors are matrices of type 'sparse with column dimension 1.

%Create the "vectors".
sparse a(4,1);


sparse b(4,1);


sparse c(4,1);


sparse d(4,1);



%Fill the "vectors" with data.
a(1,1):=1;


a(1,1) := 1

b(1,1):=1;


b(1,1) := 1

b(2,1):=1;


b(2,1) := 1

c(1,1):=1;


c(1,1) := 1

c(2,1):=1;


c(2,1) := 1

c(3,1):=1;


c(3,1) := 1

d(1,1):=1;


d(1,1) := 1

d(2,1):=1;


d(2,1) := 1

d(3,1):=1;


d(3,1) := 1

d(4,1):=1;


d(4,1) := 1


spgram_schmidt({{a},{b},{c},{d}});


{

 spm(1,1) := 1$
 ,

 spm(2,1) := 1$
 ,

 spm(3,1) := 1$
 ,

 spm(4,1) := 1$
 }


on rounded;

 % again, makes large quotients a bit more readable.
% The algorithm used for splu_decom sometimes swaps the rows of the 
% input matrix so that (given matrix A, splu_decom(A) = {L,U,vec}), 
% we find L*U does not equal A but a row equivalent of it. The call 
% spconvert(A,vec) will return this row equivalent 
% (ie: L*U = convert(A,vec)).
lu := splu_decom(mat5)$


tmp := first lu * second lu$


tmp1 := spconvert(mat5,third lu);



spm(1,1) := 3$

spm(1,2) := 1$

spm(2,1) := 1$

spm(2,2) := 3$

spm(2,3) := 1$

spm(3,2) := 1$

spm(3,3) := 3$

spm(3,4) := 1$

spm(4,3) := 1$

spm(4,4) := 3$

spm(4,5) := 1$

spm(5,4) := 1$

spm(5,5) := 3$

spm(5,6) := 1$

spm(6,5) := 1$

spm(6,6) := 3$

spm(6,7) := 1$

spm(7,6) := 1$

spm(7,7) := 3$

spm(7,8) := 1$

spm(8,7) := 1$

spm(8,8) := 3$

spm(8,9) := 1$

spm(9,8) := 1$

spm(9,9) := 3$

spm(9,10) := 1$

spm(10,9) := 1$

spm(10,10) := 3$

spm(10,11) := 1$

spm(11,10) := 1$

spm(11,11) := 3$

spm(11,12) := 1$

spm(12,11) := 1$

spm(12,12) := 3$

spm(12,13) := 1$

spm(13,12) := 1$

spm(13,13) := 3$

spm(13,14) := 1$

spm(14,13) := 1$

spm(14,14) := 3$

spm(14,15) := 1$

spm(15,14) := 1$

spm(15,15) := 3$

spm(15,16) := 1$

spm(16,15) := 1$

spm(16,16) := 3$

spm(16,17) := 1$

spm(17,16) := 1$

spm(17,17) := 3$

spm(17,18) := 1$

spm(18,17) := 1$

spm(18,18) := 3$

spm(18,19) := 1$

spm(19,18) := 1$

spm(19,19) := 3$

spm(19,20) := 1$

spm(20,19) := 1$

spm(20,20) := 3$

spm(20,21) := 1$

spm(21,20) := 1$

spm(21,21) := 3$

spm(21,22) := 1$

spm(22,21) := 1$

spm(22,22) := 3$

spm(22,23) := 1$

spm(23,22) := 1$

spm(23,23) := 3$

spm(23,24) := 1$

spm(24,23) := 1$

spm(24,24) := 3$

spm(24,25) := 1$

spm(25,24) := 1$

spm(25,25) := 3$

spm(25,26) := 1$

spm(26,25) := 1$

spm(26,26) := 3$

spm(26,27) := 1$

spm(27,26) := 1$

spm(27,27) := 3$

spm(27,28) := 1$

spm(28,27) := 1$

spm(28,28) := 3$

spm(28,29) := 1$

spm(29,28) := 1$

spm(29,29) := 3$

spm(29,30) := 1$

spm(30,29) := 1$

spm(30,30) := 3$

spm(30,31) := 1$

spm(31,30) := 1$

spm(31,31) := 3$

spm(31,32) := 1$

spm(32,31) := 1$

spm(32,32) := 3$

spm(32,33) := 1$

spm(33,32) := 1$

spm(33,33) := 3$

spm(33,34) := 1$

spm(34,33) := 1$

spm(34,34) := 3$

spm(34,35) := 1$

spm(35,34) := 1$

spm(35,35) := 3$

spm(35,36) := 1$

spm(36,35) := 1$

spm(36,36) := 3$

spm(36,37) := 1$

spm(37,36) := 1$

spm(37,37) := 3$

spm(37,38) := 1$

spm(38,37) := 1$

spm(38,38) := 3$

spm(38,39) := 1$

spm(39,38) := 1$

spm(39,39) := 3$

spm(39,40) := 1$

spm(40,39) := 1$

spm(40,40) := 3$

spm(40,41) := 1$

spm(41,40) := 1$

spm(41,41) := 3$

spm(41,42) := 1$

spm(42,41) := 1$

spm(42,42) := 3$

spm(42,43) := 1$

spm(43,42) := 1$

spm(43,43) := 3$

spm(43,44) := 1$

spm(44,43) := 1$

spm(44,44) := 3$

spm(44,45) := 1$

spm(45,44) := 1$

spm(45,45) := 3$

spm(45,46) := 1$

spm(46,45) := 1$

spm(46,46) := 3$

spm(46,47) := 1$

spm(47,46) := 1$

spm(47,47) := 3$

spm(47,48) := 1$

spm(48,47) := 1$

spm(48,48) := 3$

spm(48,49) := 1$

spm(49,48) := 1$

spm(49,49) := 3$

spm(49,50) := 1$

spm(50,49) := 1$

spm(50,50) := 3$

spm(50,51) := 1$

spm(51,50) := 1$

spm(51,51) := 3$

spm(51,52) := 1$

spm(52,51) := 1$

spm(52,52) := 3$

spm(52,53) := 1$

spm(53,52) := 1$

spm(53,53) := 3$

spm(53,54) := 1$

spm(54,53) := 1$

spm(54,54) := 3$

spm(54,55) := 1$

spm(55,54) := 1$

spm(55,55) := 3$

spm(55,56) := 1$

spm(56,55) := 1$

spm(56,56) := 3$

spm(56,57) := 1$

spm(57,56) := 1$

spm(57,57) := 3$

spm(57,58) := 1$

spm(58,57) := 1$

spm(58,58) := 3$

spm(58,59) := 1$

spm(59,58) := 1$

spm(59,59) := 3$

spm(59,60) := 1$

spm(60,59) := 1$

spm(60,60) := 3$

spm(60,61) := 1$

spm(61,60) := 1$

spm(61,61) := 3$

spm(61,62) := 1$

spm(62,61) := 1$

spm(62,62) := 3$

spm(62,63) := 1$

spm(63,62) := 1$

spm(63,63) := 3$

spm(63,64) := 1$

spm(64,63) := 1$

spm(64,64) := 3$

spm(64,65) := 1$

spm(65,64) := 1$

spm(65,65) := 3$

spm(65,66) := 1$

spm(66,65) := 1$

spm(66,66) := 3$

spm(66,67) := 1$

spm(67,66) := 1$

spm(67,67) := 3$

spm(67,68) := 1$

spm(68,67) := 1$

spm(68,68) := 3$

spm(68,69) := 1$

spm(69,68) := 1$

spm(69,69) := 3$

spm(69,70) := 1$

spm(70,69) := 1$

spm(70,70) := 3$

spm(70,71) := 1$

spm(71,70) := 1$

spm(71,71) := 3$

spm(71,72) := 1$

spm(72,71) := 1$

spm(72,72) := 3$

spm(72,73) := 1$

spm(73,72) := 1$

spm(73,73) := 3$

spm(73,74) := 1$

spm(74,73) := 1$

spm(74,74) := 3$

spm(74,75) := 1$

spm(75,74) := 1$

spm(75,75) := 3$

spm(75,76) := 1$

spm(76,75) := 1$

spm(76,76) := 3$

spm(76,77) := 1$

spm(77,76) := 1$

spm(77,77) := 3$

spm(77,78) := 1$

spm(78,77) := 1$

spm(78,78) := 3$

spm(78,79) := 1$

spm(79,78) := 1$

spm(79,79) := 3$

spm(79,80) := 1$

spm(80,79) := 1$

spm(80,80) := 3$

spm(80,81) := 1$

spm(81,80) := 1$

spm(81,81) := 3$

spm(81,82) := 1$

spm(82,81) := 1$

spm(82,82) := 3$

spm(82,83) := 1$

spm(83,82) := 1$

spm(83,83) := 3$

spm(83,84) := 1$

spm(84,83) := 1$

spm(84,84) := 3$

spm(84,85) := 1$

spm(85,84) := 1$

spm(85,85) := 3$

spm(85,86) := 1$

spm(86,85) := 1$

spm(86,86) := 3$

spm(86,87) := 1$

spm(87,86) := 1$

spm(87,87) := 3$

spm(87,88) := 1$

spm(88,87) := 1$

spm(88,88) := 3$

spm(88,89) := 1$

spm(89,88) := 1$

spm(89,89) := 3$

spm(89,90) := 1$

spm(90,89) := 1$

spm(90,90) := 3$

spm(90,91) := 1$

spm(91,90) := 1$

spm(91,91) := 3$

spm(91,92) := 1$

spm(92,91) := 1$

spm(92,92) := 3$

spm(92,93) := 1$

spm(93,92) := 1$

spm(93,93) := 3$

spm(93,94) := 1$

spm(94,93) := 1$

spm(94,94) := 3$

spm(94,95) := 1$

spm(95,94) := 1$

spm(95,95) := 3$

spm(95,96) := 1$

spm(96,95) := 1$

spm(96,96) := 3$

spm(96,97) := 1$

spm(97,96) := 1$

spm(97,97) := 3$

spm(97,98) := 1$

spm(98,97) := 1$

spm(98,98) := 3$

spm(98,99) := 1$

spm(99,98) := 1$

spm(99,99) := 3$

spm(99,100) := 1$

spm(100,99) := 1$

spm(100,100) := 3$
tmp1 := 

tmp - tmp1;


"Empty Matrix"

% and the complex case..
on complex;


*** Domain mode rounded changed to complex-rounded 

lu1 := splu_decom(mat6);


{

 spm(1,1) := 1$

 spm(2,1) := 4$

 spm(2,2) := 5 - 4*i$

 spm(3,1) := 1 + i$

 spm(3,2) := 3$

 spm(3,3) := 2.26829268293 + 0.414634146341*i$

 spm(4,4) := 1$

 spm(5,4) := 4$

 spm(5,5) := 5 - 4*i$

 spm(6,4) := 1 + i$

 spm(6,5) := 3$

 spm(6,6) := 2.26829268293 + 0.414634146341*i$
 ,

 spm(1,1) := 1$

 spm(1,2) := i$

 spm(2,2) := 1$

 spm(2,3) := 0.243902439024 + 0.19512195122*i$

 spm(3,3) := 1$

 spm(4,4) := 1$

 spm(4,5) := i$

 spm(5,5) := 1$

 spm(5,6) := 0.243902439024 + 0.19512195122*i$

 spm(6,6) := 1$
lu1 :=  ,[3,2,3,6,5,6]}

mat6;



spm(1,1) := i + 1$

spm(1,2) := i + 2$

spm(1,3) := i + 3$

spm(2,1) := 4$

spm(2,2) := 5$

spm(2,3) := 2$

spm(3,1) := 1$

spm(3,2) := i$

spm(4,4) := i + 1$

spm(4,5) := i + 2$

spm(4,6) := i + 3$

spm(5,4) := 4$

spm(5,5) := 5$

spm(5,6) := 2$

spm(6,4) := 1$

spm(6,5) := i$

tmp := first lu1 * second lu1;



spm(1,1) := 1$

spm(1,2) := i$

spm(2,1) := 4$

spm(2,2) := 5$

spm(2,3) := 2.0$

spm(3,1) := 1 + i$

spm(3,2) := 2 + i$

spm(3,3) := 3.0 + i$

spm(4,4) := 1$

spm(4,5) := i$

spm(5,4) := 4$

spm(5,5) := 5$

spm(5,6) := 2.0$

spm(6,4) := 1 + i$

spm(6,5) := 2 + i$

spm(6,6) := 3.0 + i$
tmp := 

tmp1 := spconvert(mat6,third lu1);



spm(1,1) := 1$

spm(1,2) := i$

spm(2,1) := 4$

spm(2,2) := 5$

spm(2,3) := 2$

spm(3,1) := i + 1$

spm(3,2) := i + 2$

spm(3,3) := i + 3$

spm(4,4) := 1$

spm(4,5) := i$

spm(5,4) := 4$

spm(5,5) := 5$

spm(5,6) := 2$

spm(6,4) := i + 1$

spm(6,5) := i + 2$

spm(6,6) := i + 3$
tmp1 := 

tmp - tmp1;


"Empty Matrix"

off complex;


*** Domain mode complex-rounded changed to rounded 


mat3inv := sppseudo_inverse(mat3);



spm(1,1) :=  - 2.0$

spm(1,2) := 1$

spm(2,1) := 1.5$

spm(2,2) :=  - 0.5$

spm(3,3) :=  - 2.0$

spm(3,4) := 1$

spm(4,3) := 1.5$

spm(4,4) :=  - 0.5$

spm(5,5) :=  - 2.0$

spm(5,6) := 1$

spm(6,5) := 1.5$

spm(6,6) :=  - 0.5$
mat3inv := 

mat3 * mat3inv;



spm(1,1) := 1$

spm(2,2) := 1$

spm(3,3) := 1$

spm(4,4) := 1$

spm(5,5) := 1$

spm(6,6) := 1$



% Predicates.

matrixp(mat1);


t

matrixp(poly);



squarep(mat2);


t

squarep(mat3);


t


symmetricp(mat1);


t

symmetricp(mat3);



sparsematp(mat1);


t

sparsematp(poly);



off rounded;



end;


Time for test: 125 ms
@@@@@ Resources used: (0 2 41 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/spchlsky.red0000644000175000017500000001214211526203062024335 0ustar  giovannigiovanni%**********************************************************************%
%                                                                      %
% Computation of the Cholesky decomposition of sparse positive definite%
% matrices containing numeric entries.                                 %
%                                                                      %
% Author: Stephen Scowcroft                       Date:  June 1995     %
%           (based on code by Matt Rebbeck)                            %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%                                                                      %
% NB: By using the same rounded number techniques as used in spsvd this%
%     could be made a lot faster.                                      %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module spchlsky;

symbolic procedure spcholesky(mat1);
  %
  % A must be a positive definite symmetric matrix.
  %
  % LU decomposition of matrix A. ie: A=LU, where U is the transpose
  % of L. The procedure will fail if A is unsymmetric.
  % It will also fail if A, modified by rounding errors, is not positive
  % definite.
  %
  % The reciprocals of the diagonal elements are stored in p and the
  % matrix is then 'dragged' out and 'glued' back together in get_l.
  %
  %
  begin
    scalar col,x,p,in_mat,L,U,I_turned_rounded_on,val;
    integer i,j,n;
    if not !*rounded then << I_turned_rounded_on := t; on rounded; >>;
    if not matrixp(mat1) then
     rederr "Error in spcholesky:  non matrix input.";
    if not symmetricp(mat1) then
     rederr "Error in spcholesky: input matrix is not symmetric.";
    in_mat := copy_vect(mat1,nil);
    n := sprow_dim(in_mat);
    p := mkvect(n);
    for i:=1:n do
    << col:=findrow(in_mat,i);
       if col=nil then col:=list(list(nil),list(nil));
       for each xx in cdr col do
       << if xx='(nil) then <>
           else << j:=car xx; val:=cdr xx;>>;
        if j>=i then
        << x := spinnerprod(1,1,i-1,{'minus,val},col,findrow(in_mat,j));
           x := reval{'minus,x};
           if j=i then
           <<
             if get_num_part(my_reval(x))<=0 then rederr
              "Error in spcholesky: input matrix is not positive definite.";
             putv(p,i,reval{'quotient,1,{'sqrt,x}});
           >>
           else
           <<
             letmtr3(list(in_mat,j,i),reval {'times,x,getv(p,i)},in_mat,nil);
           >>;
         >>;
       >>;
      >>;
    L := spget_l(in_mat,p,n);
    U := algebraic tp(L);
    if I_turned_rounded_on then off rounded;
    return {'list,L,U};
  end;

flag('(spcholesky),'opfn);  % So it can be used from algebraic mode.



symbolic procedure spget_l(in_mat,p,sq_size);
  %
  % Pulls out L from in_mat and p.
  %
  begin
    scalar L,col;
    integer i,j,val;
    L := mkempspmat(sq_size,list('spm,sq_size,sq_size));
    for i:=1:sq_size do
    <<
      letmtr3(list(L,i,i), reval {'quotient,1,getv(p,i)},L,nil);
      col:=findrow(in_mat,i);
      for each xx in cdr col do
       << j:=car xx;
          val:=cdr xx;
          if j>;
       >>;
    >>;
    return L;
  end;

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/spsvd.red0000644000175000017500000004355511526203062023650 0ustar  giovannigiovanni%**********************************************************************%
%                                                                      %
% Computation of the Singular Value Decomposition of sparse matrices   %
% containing numeric entries. Uses specific rounded number routines to %
% speed things up.                                                     %
%                                                                      %
% Author: Stephen Scowcroft.                   Date: June 1995         %
%          (based on code by Matt Rebbeck)                             %
%                                                                      %
% The algorithm was taken from "Linear Algebra" - J.H.Wilkinson        %
%                                                  & C. Reinsch        %
%                                                                      %
%**********************************************************************%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module spsvd;

symbolic procedure spsvd(A);
  %
  % Computation of the singular values and complete orthogonal
  % decomposition of a real rectangular matrix A.
  %
  %      A = tp(U) diag(q) V,   U tp(U) = V tp(V) = I,
  %
  % and q contains the singular values along the diagonal.
  % (tp => transpose).
  %
  %
  begin
    scalar ee,U,V,g,x,eps,tolerance,q,s,f,h,y,test_f_splitting,
           cancellation,test_f_convergence,convergence,c,z,denom,q_mat,
           I_rounded_turned_on,trans_done,val,val2,cols,cols2,tmpu
           ,tmpv;
    integer i,j,k,l,l1,m,n;
    trans_done := I_rounded_turned_on := nil;
    if not !*rounded then << on rounded; I_rounded_turned_on := t; >>;

    if not matrixp(A) then
     rederr "Error in spsvd: non matrix input.";

    % The value of eps can be decreased to increase accuracy.
    % As usual, doing this will slow things down (and vice versa).
    % It should not be made smaller than the value of rd!-tolerance!*.
    eps := get_num_part(my_reval({'times,1.5,{'expt,10,-8}}));
    tolerance := get_num_part(my_reval({'expt,10,-31}));

    % Algorithm requires m >= n. If this is not the case then transpose
    % the input and swap U and V in the output (as A = tp(U) diag(q) V
    % but tp(A) = tp(V) diag(q) U  ).
    if sprow_dim(A) < spcol_dim(A) then
    << A := algebraic tp(A); trans_done := t; >>;

    m := sprow_dim(A);
    n := spcol_dim(A);

    U := copy_vect(A,nil);
    V := mkempspmat(n,list('spm,n,n));
    ee := mkvect(n);
    q := mkvect(n);

    % Householder's reduction to bidiagonal form:
    g := x := 0;
    for i:=1:n do
    <=i and j<=m then
          s := specrd!:plus(s,specrd!:expt(val,2));
        >>;
      >>;
      if get_num_part(s) < tolerance then g := 0
      else
      <<
        f := findelem2(U,i,i);
        if get_num_part(f)<0 then g := specrd!:sqrt(s)
           else g := my_minus(specrd!:sqrt(s));
          h := specrd!:plus(specrd!:times(f,g),my_minus(s));
          letmtr3(list(U,i,i),specrd!:plus(f,my_minus(g)),u,nil);
         tmpu:=copy_vect(smtp (u,nil),nil);
         cols:=findrow(tmpu,i);
         for j:=l:n do
         <=i and k<=m then
              <>;
           >>;
           f := specrd!:quotient(s,h);
           for each xx in cdr cols do
           <=i and k<=m then
              <>;
            >>;
           >>;
           tmpu:=copy_vect(smtp (u,nil),nil);
            cols:=findrow(tmpu,i);
           for each xx in cdr cols do
           <=i and j<=m then
               letmtr3(list(U,j,i),specrd!:quotient(val,g),u,nil);
           >>;
         >>
       else for each xx in cdr cols do
         << j:=car xx;
            if j>=i and j<=m then letmtr3(list(U,j,i),0,u,nil);
         >>;
 letmtr3(list(U,i,i),specrd!:plus(findelem2(U,i,i),1),u,nil);
>>;

    % Diagonalisation of the bidiagonal form:
    eps := get_num_part(specrd!:times(eps,x));
    test_f_splitting := t;
    k := n;
    while k>=1 do
    <<
      convergence := nil;
      if test_f_splitting then
      <<
        l := k;
        test_f_convergence := cancellation := nil;
        while l>=1 and not (test_f_convergence or cancellation) do
        <<
          if abs(get_num_part(getv(ee,l))) <= eps
           then test_f_convergence := t
          else if abs(get_num_part(getv(q,l-1))) <= eps
           then cancellation := t
          else l := l-1;
        >>;
      >>;
     tmpu:=copy_vect(smtp (u,nil),nil);
      % Cancellation of e[l] if l>1:
      if not test_f_convergence then
      <<
        c := 0; s := 1; l1 := l-1;
        i := l;
        while i<=k and not test_f_convergence do
        <>;
            >>;
            i := i+1;
          >>;
        >>;
      >>;
      z := getv(q,k);
      if l = k then convergence := t;

      if not convergence then
      <<
        % Shift from bottom 2x2 minor:
        x := getv(q,l);
        y := getv(q,k-1);
        g := getv(ee,k-1);
        h := getv(ee,k);
        f := specrd!:quotient(specrd!:plus(specrd!:times(
              specrd!:plus(y,my_minus(z)),specrd!:plus(y,z)),
               specrd!:times(specrd!:plus(g,my_minus(h)),
                specrd!:plus(g,h))),specrd!:times(
                 specrd!:times(2,h),y));
        g := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),1));
        % Needed to change < here to <=.
        if get_num_part(f)<=0 then
        denom := specrd!:plus(f,my_minus(g))
         else denom := specrd!:plus(f,g);
        f := specrd!:quotient(specrd!:plus(specrd!:times(
              specrd!:plus(x,my_minus(z)),specrd!:plus(x,z)),
               specrd!:times(h,specrd!:quotient(y,
                specrd!:plus(denom,my_minus(h))))),x);

        % Next QR transformation:
        c := s := 1;
        for i:=l+1:k do
        <>;
          z := specrd!:sqrt(specrd!:plus(specrd!:times(f,f),
                                         specrd!:times(h,h)));
          putv(q,i-1,z);
          c := specrd!:quotient(f,z);
          s := specrd!:quotient(h,z);
          f := specrd!:plus(specrd!:times(c,g),specrd!:times(s,y));
          x := specrd!:plus(specrd!:times(my_minus(s),g),
                            specrd!:times(c,y));
          for j:=1:m do
          <<  y := findelem2(U,j,i-1);
              z := findelem2(u,j,i);
              letmtr3(list(U,j,i-1),specrd!:plus(specrd!:times(y,c),
                                        specrd!:times(z,s)),u,nil);
              letmtr3(list(U,j,i),specrd!:difference(specrd!:times(z,c),
                                            specrd!:times(y,s)),u,nil);
           >>;
        >>;
        putv(ee,l,0);
        putv(ee,k,f);
        putv(q,k,x);
      >>
      else % convergence:
      <>;
         >>;
        k := k-1;
      >>;
    >>;

    q_mat := spq_to_diag_matrix(q);
    if I_rounded_turned_on then off rounded;
    v:=spden_to_sp(v); % to print it out in Sparse manner
    u:=spden_to_sp(u);
    if trans_done then
     return {'list,algebraic tp V,q_mat,algebraic tp U}
      else return {'list,algebraic tp U,q_mat,algebraic tp V};
  end;

flag('(spsvd),'opfn); % To make it available from algebraic (user) mode.

symbolic procedure spq_to_diag_matrix(q);
  %
  % Converts q (a vector) to a diagonal matrix with the elements of
  % q on the diagonal.
  %
  begin
    scalar q_mat;
    integer i,sq_dim_q,val;
    sq_dim_q := upbv(q);
    q_mat := mkempspmat(sq_dim_q,list('spm,sq_dim_q,sq_dim_q));
    for i:=1:sq_dim_q do
     << val:=getv(q,i);
        if val='(!:rd!: . 0.0) then nil
         else letmtr3(list(q_mat,i,i),val,q_mat,nil);
     >>;
    return q_mat;
  end;

% The lists are then re-written into desired sparse list format ready
% for printing.

symbolic procedure spden_to_sp(list);
 begin scalar tl,nmat,val,cols,j;
  tl:=caddr list;
  nmat:=mkempspmat(cadr tl,tl);
  for i:=1:cadr tl do
  << cols:=findrow(list,i);
     for each xx in cdr cols do
     <>;
    >>;
    return C;
  end;


symbolic procedure sppseudo_inverse(in_mat);
  %
  % Also known as the Moore-Penrose Inverse.
  %
  % Given the singular value decomposition A := tp(U) diag(q) V
  % the pseudo inverse A^(-1) is defined as
  %
  %   A^(-1) = tp(V) (diag(q))^(-1) U.
  %
  % NB: this can be quite handy as we can take the inverse of non
  % square matrices (A * pseudo_inverse(A) = identity).
  %
  begin
    scalar psu_inv,svd_list,a,b,c;
    svd_list := cdr spsvd(in_mat);
         a:=car svd_list;
         c:=caddr svd_list;
         b:=cadr svd_list;
         c:=algebraic tp c;
         b:=algebraic (1/b);
    psu_inv := algebraic (c * b * a);
    return psu_inv;
  end;

flag('(sppseudo_inverse),'opfn);

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/spmateig.red0000644000175000017500000001772211526203062024317 0ustar  giovannigiovanni%***********************************************************************
%=======================================================================
%
% Code for the extension of the Matrix Package to include Sparse
% Matrices.
%
% The following code is for the functions to calculate eigenvalues and
% the rank of sparse matrices.
%
% Author: Stephen Scowcroft.                           Date: June 1995
%
%=======================================================================
%***********************************************************************

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module spmateig;

% Based on the current eigenvalue code.

symbolic procedure spmateigen(u,eival);
%    U is a matrix form, eival an indeterminate naming the eigenvalues.
%    Result is a list of lists:
%      {{eival-eq1,multiplicity1,eigenvector1},....},
%    where eival-eq is a polynomial and eigenvector is a matrix.
%    How much should we attempt to solve the eigenvalue eq.? sqfr?
%    Sqfr is necessary if we want to have the full eigenspace. If there
%    are multiple roots another pass through eigenvector calculation
%    is needed(done).
%    We should actually perform the calculations in the extension
%    field generated by the eigenvalue equation(done inside).
  begin scalar arbvars,exu,sgn,q,r,s,x,y,z,eivec,!*factor,!*sqfree,
               !*exp,val,res,res1,rl;
        integer l,cnt;
     !*exp := t;
     if not(getrtype u eq 'sparse) then typerr(u,"sparse matrix");
     eival := !*a2k eival;
     kord!* := eival . kord!*;
     rl:=sprow_dim(u);
     exu := spmateigen1(spmatsm u,eival);
     q := car exu;
     y := cadr exu;
     z := caddr exu;
     exu := cdddr exu;
     !*sqfree := t;
     for each j in cdr fctrf numr subs2(lc z ./ 1)
          do if null domainp car j and mvar car j eq eival
                then s := (if null red car j
                              then !*k2f mvar car j . (ldeg car j*cdr j)
                            else j) . s;
     for each j in q
       do (if x then rplacd(x,cdr x + cdr j)
             else s := (y . cdr j) . s)
            where x := assoc(y,s) where y := absf reorder car j;
     l := length s;
     r := 'list .
       for each j in s collect
     <>;
       arbvars := nil;
       for each k in lpow z do
          if (y=1) or null(k member lpow y) then
         arbvars := (k . makearbcomplex()) . arbvars;
       sgn := (y=1) or evenp length lpow y;
       cnt:=0;
       for each k in lpow z do
        << if x := assoc(k,arbvars) then
              res:=list(cnt:=cnt+1,(1 . mvar cdr x))
            else
             << val:= mkgleig(k,y,sgn := not sgn,arbvars);
                if (val=simp 0) then cnt:=cnt+1
                 else res:=list(cnt:=cnt+1,(1 . prepsq!* val));
             >>;
          if res=nil then nil
           else << res1:=append(res1,list(res));
                   res:=nil;
                   eivec:=mkempspmat(rl,list('spm,rl,1));
                     for i:=1:rl do
                      <>;
                >>;
          >>;
        res1:=nil;
       list('list,prepsq!*(car j ./ 1),cdr j,eivec)>>;
     kord!* := cdr kord!*;
     return r
   end;

symbolic procedure spmateigen1(u,eival);
   begin scalar diag,q,x,y,z,w,j,res; integer l,lm,m,cc;
      lm := spcol_dim(u);
      z := 1;
     for rr:=1:sprow_dim(u) do
     << y := 1;
       diag:=nil;
       cc:=findrow(u,rr);
      if not (cc=nil) then
      <>;
      >>;
        m := lm;
        l := l + 1;
        x := nil;
       if cc=nil then cc:=list(list(nil),list(nil));
      for each xx in reverse cdr cc do
        <>
   end;


put('rank,'psopfn,'rank!-eval);

% The function to calculate the rank.
% Based on the matrix rank function.

symbolic procedure sprank!-matrix u;
 begin scalar x,y,z,w,j,cc; integer m,n;
   z := 1;
   for rr:=1:sprow_dim(u) do
   << y := 1;
      cc:=findrow(u,rr);
      if not (cc=nil) then
      <>;
      >>;
      m := 1;
      x := nil;
      if not (cc=nil) then
      <>;
      >>;
      if y := c!:extmult(x,z) then <>;
    >>;
     return n
    end;

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************




mathpiper-0.81f+svn4469+dfsg3/src/packages/sparse/sparsmat.red0000644000175000017500000012414311526203062024334 0ustar  giovannigiovanni%***********************************************************************
%=======================================================================
%
% Code for the extension of the Matrix Package to include Sparse
% Matrices.
%
% Author: Stephen Scowcroft.                           Date: June 1995
%
%=======================================================================
%***********************************************************************

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


module sparsmat;

% This is an important line of code as it changes the way in which the
% current matrix package is evaluated (i.e through my function instead
% of matsm!*)

put('matrix,'evfn,'spmatsm!*);

% This is the function to create a matrix and declare it a sparse
% variable

symbolic procedure sparse u;
   % Declares list U as Sparse matrices.
   begin scalar v,w,x;
        for each j in u do
           if atom j then if null (x := gettype j)
                            then put(j,'rtype,'sparse)
                           else if x eq 'sparse
                            then <>
                           else typerr(list(x,j),"sparse")
            else if not idp car j
                   or length (v := revlis cdr j) neq 2
                   or not natnumlis v
             then errpri2(j,'hold)
            else if not (x := gettype car j) or x eq 'sparse
             then <>
            else typerr(list(x,car j),"sparse")
   end;


 symbolic procedure natnumlis u;
   % True if U is a list of natural numbers.
   null u or fixp car u and car u>0 and natnumlis cdr u;

rlistat '(sparse);

%put('sparsemat,'stat,'matstat);

% symbolic procedure formmat(u,vars,mode);
%   'list . mkquote car u
%     . for each x in cdr u collect('list . formlis(x,vars,mode));

% put('sparsemat,'formfn,'spformmat);

% put('sparsemat,'i2d,'spmkscalmat);

% put('sparsemat,'lnrsolvefn,'splnrsolve);

put('sparsemat,'rtypefn,'spquotematrix);

symbolic procedure spquotematrix u; 'sparse;

flag('(sparsemat tp),'spmatflg);

flag('(sparsemat),'noncommuting);

put('sparsemat,'prifn,'myspmatpri2);

flag('(sparsemat),'struct);      % for parsing

put('sparse,'fn,'spmatflg);

put('sparse,'evfn,'spmatsm!*);

flag('(sparse),'prifn);

put('sparse,'tag,'sparsemat);

put('sparse,'lengthfn,'spmatlength);

put('sparse,'getelemfn,'getspmatelem2);

put('sparse,'setelemfn,'setspmatelem2);

% This is a temporary function and will hopefully replace matsm!*
% i.e put('matrix,'evfn,'spmatsm!*);

symbolic procedure spmatsm!*(u,v);
begin scalar x;
% if pairp u
 << x:=spmatsm u;
      if eqcar(x,'sparsemat) then return x
       else return matsm!*1 x;
  >>
%   else << return cadr get(u,'avalue)>>;

end;


symbolic procedure spmkscalmat u;
   % Converts id u to 1 by 1 matrix.
   list('sparsemat,list('spm,1,1));

% A sorting function to include row elements in the sparse matrix list.

symbolic procedure sortrowelem (row,u,val,y,len);
 begin scalar x,v,elem,lis;
  v:=u;
  x:=u;
  lis:=u;
   while elem = nil do
  <<
    if v = nil then
           <>
     else if not (car v=nil) then
      << if row < caar v then
         << if car v = car lis then
             rplacd(y,append(list((row . list val) . v),list(len)))
             else rplacd(x,rplacd(list(row . (list val)),v)); elem:=t>>
        else if row > caar v then <>
      >>
      else <>;
  >>;
  end;

% A sorting function to include column elements in the sparse matrix list.

symbolic procedure sortcolelem (col,u,val);
 begin scalar v,elem;
  v:=cdr u;
   while elem = nil do
  <<
    if v=nil then <>
      else if col < caar v then <>
      else if col > caar v then <>;
  >>;
  end;

% This function returns the length of a sparse matrix.
% It replaces the old lengthreval function and extends it for Sparse.

symbolic procedure lengthreval u;
   begin scalar v,w,x;
      if length u neq 1
        then rerror(alg,11,
                    "LENGTH called with wrong number of arguments");
      u := car u;
      if idp u and arrayp u then return 'list . get(u,'dimension);
      v := aeval u;
      if (w := getrtype v) and (x := get(w,'lengthfn))
        then if w = 'sparse then return apply1(x,u)
               else return apply1(x,v)
       else if atom v then return 1
       else if not idp car v or not(x := get(car v,'lengthfn))
        then if w
          then lprie list("LENGTH not defined for argument of type",w)
         else typerr(u,"LENGTH argument")
       else return apply1(x,cdr v)
   end;

symbolic procedure spmatlength u;
 begin scalar y,x;
  if pairp u then x := u
   else x := cadr get(u,'avalue);
  y := cdr caddr x;
   if not eqcar(x,'sparsemat) then rerror(matrix,2,list("Matrix",u,"not set"))
    else return list('list,car y,cadr y);
   end;

% This enables elements of the sparse matrix to be obtained.

symbolic procedure getspmatelem2(u);
   begin scalar x,y;
      x := get(car u,'avalue);
      y:= cdr caddr cadr x;
      if null x or not(car x eq 'sparse) then typerr(car u,"sparse")
       else if not eqcar(x := cadr x,'sparsemat)
        then if idp x
         then return getmatelem2(x . cdr u)
         else rerror(matrix,1,list("Matrix",car u,"not set"))
        else if not numlis (u := revlis cdr u) or length u neq 2
         then errpri2(x . u,t)
        else if car u > car y or cadr u > cadr y then
         typerr( car u,"The dimensions are wrong - matrix unaligned")
         else return findelem2(x,car u,cadr u);
   end;

% This is the finding function. It it used throughout the entire Sparse
% Matrix package.

symbolic procedure findelem2 (x,row,col);
begin scalar list,rlist,colist,res;
 if pairp x and car x eq 'sparsemat then list:=(cadr x)
  else list := x;
 rlist:=getv(list,row);
 colist:=atsoc(col,rlist);
  if colist =nil then res:=0
   else res:=cdr colist;
return res;
end;

symbolic procedure findrow(x,row);
begin scalar list,rlist;
 if pairp x and car x eq 'sparsemat then list:=(cadr x)
  else list := x;
 rlist:=getv(list,row);
 return rlist;
end;

symbolic procedure mkempspmat(row,len);
 begin scalar res;
  res:=list('sparsemat,mkvect(row),len);
  return res;
 end;

symbolic procedure copy_vect(list,len);
 begin scalar oldvec,newvec;
  oldvec:=cadr list;
% newvec:=totalcopy(oldvec);
  newvec:=fullcopy(oldvec);
  %for i:=1:num do
  %<< %putv(newvec,i,getv(oldvec,i))>>;
 if not len then len:=caddr list;
 return list('sparsemat,
     newvec,len);
 end;

symbolic procedure fullcopy s;
   % A subset of the PSL totalcopy function.
   if pairp s then fullcopy car s . fullcopy cdr s
    else if vectorp s then
        begin scalar cop; integer si;
        si:=upbv s;
        cop:=mkvect si;
        for i:=0:si do putv(cop,i,fullcopy getv(s,i));
        return cop end
    else s;

% This is a very useful function and most of the matrix arithmetic
% functions rely on it.
% It enables me to rebuild a list of type Sparse having performed
% various functions on the old list.
% It is non-destructive.

symbolic procedure letmtr3(u,v,y,typ);
  begin scalar z,rowelem,colelem,len,list;
    %if length y=2 then len:=cadr y
    % else
    len:=caddr y;
    if cddr u=nil then
      << if not eqcar(y,'sparsemat)
      then rerror(matrix,10,list("Matrix",car u,"not set"))
         else if not numlis (z := revlis cdr u) or length z neq 1
           then return errpri2(u,'hold);
         putv(cadr y,cadr u,v);>>
    else
    <<
    if not eqcar(y,'sparsemat)
      then rerror(matrix,10,list("Matrix",car u,"not set"))
         else if not numlis (z := revlis cdr u) or length z neq 2
           then return errpri2(u,'hold);
        rowelem:=getv(cadr y,car z);
            if rowelem =nil then
             << if v=0 and not (typ='cx) then nil
                 else putv(cadr y,car z,list(list(nil),(cadr z . v)));>>
                  else <>
                           else rplacd(rowelem,
                                   cdr delete(colelem,rowelem));
                         >>
                else rplacd(colelem,v);>>;
                  >>;
               >>;
    end;


% This enables sparse matrices to be created.
% Data is stored in a list by row with additional column and value pairs.

symbolic procedure setspmatelem2(u,v);
   begin scalar x,y,p;
     x := cadr get(car u,'avalue);
     y := cdr caddr x;
     p := revlis cdr u;
     if null x then typerr(car u,"matrix")
      else if car p > car y or cadr p > cadr y then
        typerr(car u,"The dimensions are wrong - matrix unaligned")
      else return letmtr3(u,v,x,nil);
   end;

% This is my sparse matrix printer.
%It will print out the single elements of the matrix.

symbolic procedure empty(vec,val);
 begin scalar res,i;
  i:=1;
  while not res and not (i=val+1) do
  << if not (getv(vec,i) = nil) then res:=t;
      i:=i+1;
  >>;
  return res;
 end;

% This is my sparse matrix printer.
% It will print out the single elements of the matrix.

symbolic procedure sparpri(u,i,nam);
 begin scalar val,row;
  val:=u;
  row:=i;
  for each x in val do
   << writepri(list('quote,list('setq, list(nam,row,(car x)), cdr x)),
                'first);
      writepri(''!$, 'last)
   >>;
 end;

symbolic procedure myspmatpri2(u);
 begin scalar matr,nam,list,fl;
 % if   then print("The matrix is dense, contains only zeros")
  % else
    << matr:= cadr u;
       nam:='spm;
       fl:=empty(matr,cadr caddr u);
       %for i:=1:cadr caddr u do
       %<< if not (getv(matr,i) = nil) then fl:=t;>>;
       if fl then
       << for i:=1:cadr caddr u do
           <>;
       >>
        else print "Empty Matrix";
     >>;
 end;


% This function returns the transpose of the sparse matrix.
% It should replace the current tp function as it is an extension to
% include the transpose of Sparse Matrices.

symbolic procedure smtp(u,typ);
  begin scalar x,tm,row,newcol,newrow,val,len,col,rows;
  if atom u then <>
   else if eqcar(u,'sparsemat) then <>
    else <>;
   row:=cadr len;
   col:=caddr len;
   tm:=mkempspmat(col,list('spm,col,row));
    if not eqcar(x,'sparsemat) then rerror(matrix,2,list("Matrix",u,"not set"))
    else for i:=1:row do
     << rows:=findrow(x,i);
        if not (rows=nil) then
        << newcol:=i;
           for each cols in cdr rows  do
            << newrow:=car cols;
               val:=cdr cols;
               letmtr3(list(tm,newrow,newcol), val, tm,typ)
            >>;
        >>;
       >>;
   return tm;
   end;

symbolic procedure tp u;
 if checksp(u) = 'sparse then smtp (spmatsm u,nil)
   else tp1 spmatsm u;


% put('tp2, 'psopfn, 'smtp);



% This function transforms a matrix of MATRIX type into one of SPARSE
% MATRIX type. It is destructive.
% It is very useful for creating Sparse Matrices as one can utilise all
% the matrix facilities and then convert to Sparse form.

symbolic procedure transmat1(u);
  begin scalar vec,v,x,rcnt,ccnt,elem,row,rlist;
   x:= cdr aeval (car u);
   rcnt:=0;
   ccnt:=0;
   v:=cdr matlength aeval(car u);
   vec:=mkempspmat(car v,('spm . v));
   rlist:=list(list(nil));
   for each rows in x do
    << row:=rows;
       rcnt:=rcnt + 1;
       for each cols in row do
        <<  elem:=cols;
            ccnt:=ccnt + 1;
            if elem = 0 then nil
             else rlist:=(ccnt . elem) . rlist
        >>;
        rlist:=reverse (rlist);
        if not (rlist=list(list(nil))) then
           letmtr3(list(vec,rcnt),rlist,vec,nil);
%)putv(vec,rcnt,rlist);
        ccnt:=0;
        rlist:=list(list nil);
    >>;
    put(car u,'avalue,list('sparse, vec));
    put(car u,'rtype,'sparse);
  end;

put('transmat,'psopfn,'transmat1);

% This is a funtion to transform matrix types into sparse types.
% It is non-destructive.
% This is used when performing matrix calculations of matrices of
% 'sparse and 'matrix type.

symbolic procedure sptransmat(u);
 begin scalar v,x,rcnt,ccnt,elem,row,rlist,vec;
   if pairp u then << x:=u; v:=cdr matlength u>>
    else << x:= aeval (u); v:=cdr matlength aeval(u)>>;
   rcnt:=0;
   ccnt:=0;
   vec:=mkempspmat(car v,('spm . v));
   rlist:=list(list nil);
   for each rows in cdr x do
    << row:=rows;
       rcnt:=rcnt + 1;
       for each cols in row do
        <<  elem:=cols;
            ccnt:=ccnt + 1;
            if elem = 0 then nil
             else rlist:=(ccnt . elem) . rlist
        >>;
        rlist:=reverse(rlist);
        if not (rlist=list(list(nil))) then
          letmtr3(list(vec,rcnt),rlist,vec,nil);
        ccnt:=0;
        rlist:=list(list nil);
    >>;
    return vec;
  end;

symbolic procedure trans(u);
 begin scalar x,res;
  while u do
  << x:=checksp(car u);
     if x=nil or x='sparse then <>
      else if x='matrix then
      << if pairp car u then
          << if caar u='mat then res:=sptransmat car u . res
              else res:=trans car u . res;
          >>
          else res:=sptransmat car u . res;
          u:=cdr u;
      >>
       else <>;
  >>;
   return reverse res;
 end;

% It is hoped that this will eventually replace the present matsm in
% the matrix package.
% This might be impossible due to the fact that some of the hierarchical
% REDUCE functions instinctively call matsm (rather than spmatsm).
% Perhaps it will be better to work along side matsm (is similar).

symbolic procedure spmatsm u;
   begin scalar x,y,r;
   %if pairp u and not cdr u = nil then spmatsm(cdr u)
   % else
       if pairp u then
        << if eqcar(u,'sparsemat) then r:='sparse
        else if checksp(u) = 'sparse then r :='sparse
         else if checksp(u) = 'matrix then r:='matrix
          else <>;
   if length x = 1 then return car x
    else return x
   end;

%symbolic procedure spmatsm!*1 u;
%   begin
%    if eqcar(u, 'sparsemat) then u:=u
%      else <<
%      % We use subs2!* to make sure each element simplified fully.
%      u := 'mat . for each j in u collect
%                     for each k in j collect !*q2a subs2!* k>>;
%      !*sub2 := nil;   % Since all substitutions done.
%      return u
%   end;

% This is to replace the current matsm1 function.
% Extend to include sparse matrices.

symbolic procedure matsm1 u;
   %returns matrix canonical form for matrix symbol product U;
   begin scalar x,y,z,len; integer n;
    a:  if null u then return z
         else if eqcar(car u,'!*div) then
          << if length u=1 then go to d
              else if length u=2 and caar cdr u='sparsemat
               then <>
              else go to d;
          >>
         else if atom car u then go to er
         else if caar u eq 'mat then go to c1
         else if caar u eq 'sparsemat and length u = 1
                  then <>
         else if caar u eq 'sparsemat and length u = 2 then
         << if eqcar(car reverse u,'!*div) then
             << u:=reverse u; z:=cdr u; go to d>>
             else <>;
         >>
         else if caar u eq 'sparsemat then
                       <>
         else x := lispapply(caar u,cdar u);
    b:  z := if null z then x
              else if null cdr z and null cdar z then multsm(caar z,x)
              else multm(x,z);
    c:  u := cdr u;
        go to a;
    c1: if not lchk cdar u then rerror(matrix,3,"Matrix mismatch");
        x := for each j in cdar u collect
                for each k in j collect xsimp k;
        go to b;
    d: if checksp(cadar u) = 'sparse then
         <<  y := spmatsm cadar u;
             len:= cdar reverse y;
              if not(car len = cadr len) then
                rerror(matrix,4,"Non square matrix")
         >>
        else
         << y:= matsm cadar u;
            if (n := length car y) neq length y
             then rerror(matrix,4,"Non square matrix")
            else if (z and n neq length z)
             then rerror(matrix,5,"Matrix mismatch")
            else if cddar u then go to h
            else if null cdr y and null cdar y then go to e
         >>;
        x := subfg!*;
        subfg!* := nil;
        if null z then z := apply1(get('mat,'inversefn),y)
         else if caar z = 'sparsemat then
          << z:=list spmultm(car apply1(get('mat,'inversefn),y),z);
             u:=cdr u;
          >>
         else if null(x := get('mat,'lnrsolvefn))
          then z := multm(apply1(get('mat,'inversefn),y),z)
         else z := apply2(get('mat,'lnrsolvefn),y,z);
        subfg!* := x;
        % Make sure there are no power substitutions.
        if caar z = 'sparsemat then z:=z
        else
        z := for each j in z collect for each k in j collect
                 <>;
        go to c;
    e:  if null caaar y then rerror(matrix,6,"Zero divisor");
        y := revpr caar y;
        z := if null z then list list y else multsm(y,z);
        go to c;
     h: if null z then z := generateident n;
        go  to c;
    er: rerror(matrix,7,list("Matrix",car u,"not set"))
   end;

% To replace current function.
% Extended for sparse matrices.

symbolic procedure multsm(u,v);
 begin;
   %returns product of standard quotient U and matrix standard form V;
   if not (length v=1) and car v ='sparsemat then v:=list v;
   if u = (1 ./ 1) then return v
    else if caar v = 'sparsemat then return spmultsm(u,car v)
    else return for each j in v collect for each k in j collect multsq(u,k);
 end;

% This is the matrix multiplier function for Sparse Matrices and a
% single multiplier.

symbolic procedure spmultsm(u,v);
  begin scalar len,tm,row,col,newval,val,rows;
   len:= caddr v;
   tm:=mkempspmat(cadr len,len);
   for i:=1: cadr len do
   << rows:=findrow(v,i);
      row := i;
       if not (rows=nil) then
       << for each cols in cdr rows do
          << col:=car cols;
             val:=simp cdr cols;
             newval:=multsq(u,val);
             newval:=mk!*sq(newval);
             if not (newval = 0) then
             letmtr3(list(tm,row,col),newval,tm,nil);
          >>;
       >>;
     >>;
   return list(tm);
  end;

% To replace current function
% Extended for Sparse Matrices.

symbolic procedure addm(u,v);
   % Returns sum of two matrix canonical forms U and V.
   % Returns U + 0 as U. Patch by Francis Wright.
 begin scalar res;
   if not (length u=1) and car u='sparsemat then u:=list u;
   if not (length v=1) and car v='sparsemat then v:=list v;
   if caar u = 'sparsemat and caar v = 'sparsemat then
      res:=smaddm(car u,car v)
   else
   if v = '(((nil . 1))) then u else       % FJW.
   res:=for each j in addm1(u,v,function cons)
           collect addm1(car j,cdr j,function addsq);
   return res;
 end;

% To replace current function
% Extended for Sparse Matrices.

symbolic procedure addm1(u,v,w);
   if null u and null v then nil
    else if null u or null v then rerror(matrix,8,"Matrix mismatch")
    else apply2(w,car u,car v) . addm1(cdr u,cdr v,w);

% This function is part of the matrix addition code.

symbolic procedure smaddm(u,v);
 begin scalar lena,lenb,len;
  len:= caddr v;
  lena:= cdr caddr u;
  lenb:= cdr caddr v;
   if not (lena = lenb) then rerror(matrix,8,"Matrix mismatch")
    else return smaddm2(u,v,len);
 end;

% This is the function which performs the matrix addition for Sparse
% matrices.

symbolic procedure smaddm2(u,v,lena);
 begin scalar tm,rowas,rowbs,rowa,rowb,rowna,rownb,val1,val2,j,newval;
   rowas := u;
   rowbs := v;
   tm:=copy_vect(rowbs,nil);
   for i:=1:cadr lena do
  << rowa:=findrow(rowas,i);
     rowna:=i;
     rowb:=findrow(rowbs,i);
     rownb:=i;
     if not (rowa=nil) then
     << for each xx in cdr rowa do
        << j:=car xx;
           val1:=cdr xx;
           val2:=atsoc(j,rowb);
           if val2=nil then
           << letmtr3(list(tm,i,j),val1,tm,nil)>>
           else
            <>;
         >>;
       >>;
    >>;
   return tm;
 end;

%This is now redundent code.

symbolic procedure smaddm1(u,v,lena);
 begin scalar tm,rowas,rowbs,rowa,rowb,cola,colb,colas,colbs,cols,
              col,newval,vala,valb,val,colna,colnb,rowna,rownb;
   tm:=mkempspmat(cadr lena,lena);
   rowas := cadr u;
   rowbs := cadr v;
  for i:=1:cadr lena do
  << rowa:=findrow(rowas,i);
     rowna:=i;
     rowb:=findrow(rowbs,i);
     rownb:=i;
    while not (rowa=nil or rowb=nil) do
    <<
    if rowna = rownb then
      <>
         else if colna > colnb then
           <>
         else
           <>;
        >>;
        if not (colas = nil) then
         <>;
         >>
        else if not (colbs = nil) then
         <>;
          >>;
         rowa:=nil;
         rowb:=nil;
        >>
      else if rowna > rownb then
        <>;
           rowb:=nil;
        >>
      else
        <>;
            rowa:=nil;
        >>;
    >>;
   if not (rowa = nil) then
     <>;
      >>
     else if not(rowb=nil) then
     <>;
     >>;
  >>;
   return tm;
  end;

% This is to perform matrix multiplication of Sparse Matrices.

symbolic procedure spmultm(u,v);
 begin scalar lena,lenb,nlen;
  if not (cdr v = nil) then<< v:=list(spmultm(car v,cdr v));
                               return spmultm(u,v)>>
   else
  <<
  lena:=caddr car v;
  lenb:=caddr u;
  nlen:=list('spm,cadr lena,caddr lenb);
 if not (caddr lena = cadr lenb) then rerror(matrix,8,"Matrix mismatch")
  else return spmultm2(car v,smtp (u,nil),nlen);
  >>;
 end;

% This is the actual multiplication function.

symbolic procedure spmultm2 (u,v,len);
 begin scalar tm,rowas,rowbs,rowa,rows,val1,val2,newval,smnewval,jj;
   tm:=mkempspmat(cadr len,len);
   if empty(cadr u,cadr caddr u) = nil or empty(cadr v, cadr caddr v)
     = nil then return tm
   else
   << rowas := cadr u;
      rowbs := cadr v;
      for i:=1:cadr caddr u do
        << rowa :=findrow(rowas,i);
           if rowa then
           <>
                   else <>;
                 >>;
                 newval:=mk!*sq(smnewval);
                 if not (newval=0) then
                 letmtr3(list(tm,i,j),newval,tm,nil);
                >>;
              >>;
            >>;
          >>;
      return tm;
     >>;
 end;

% This is now redundent code.

symbolic procedure spmultm1 (u,v,len);
 begin scalar tm,rowas,rowbs,rowa,rowna,rownb,colas,colbs,cola,colb,
              vala,valb,newval,smnewval,colna,colnb,rows;
   tm:=mkempspmat(cadr len,len);
   if empty(cadr u,cadr caddr u) = nil or empty(cadr v, cadr caddr v)
     = nil then return tm
    else
     << rowas := cadr u;
        rowbs := cadr v;
        for i:=1:cadr caddr u do
        << rowa :=findrow(rowas,i);
        while rowa do
        << for j:=1:cadr caddr v do
           << rows:=findrow(rowbs,j);
              if rows then
            << rowna:= i;
               colas:= cdr rowa;
               rownb:= j;
               colbs:=cdr rows;
               smnewval:=simp 0;
               while not (colas = nil or colbs = nil) do
                << cola:=car colas;
                   colb:=car colbs;
                   colna:=car cola;
                   colnb:=car colb;

                   if colna = colnb then
                    << vala:=simp cdr cola;
                       valb:=simp cdr colb;
                       newval:=multsq(vala,valb);
                       smnewval:=addsq(smnewval,newval);
                       colbs:=cdr colbs;
                       colas:=cdr colas
                    >>
                    else if colna > colnb then << colbs:=cdr colbs>>
                    else <>;
                 >>;
             newval:=mk!*sq(smnewval);
             if not (newval = 0) then
             letmtr3(list(tm,rowna,rownb),newval,tm,nil);
              >>;
             >>;
           rowa:=nil;
          >>;
         >>;
      return tm
       >>;
  end;

% This is a function to enable me to determine whether I am dealing with
% Sparse Matrices or otherwise. This enables my Sparse code to run along
% side the present Matrix package.

% It is an important function as it is the one which enables me to
% extend the current matrix package to include the Sparse code.
% Allows both packages to work side by side.

symbolic procedure checksp(u);
 begin scalar x,sp,m;
  if atom u and not numberp u then
  << x:=get(u, 'avalue); if not (x=nil) then x:=car x>>
   else if pairp u then
   << if car u = 'sparsemat then sp:='sparse
       else if car u = 'mat then m:='matrix
       else
       <>;
                 >>;
               u:=cdr u;
               if not pairp u then u:=nil;
            >>
             else
              <>
                 else if x='matrix then <>
                  else u:=cdr u;
                if not pairp u then u:=nil;
              >>;
         >>;
        >>;
      if sp and not m then x:=sp
       else if m and not sp then x:=m
        else x:=sp . m;
    >>
   else x:=nil;
    return x;
 end;

% The following function is to be used along side the function for the
% evaluation of determinants. This function returns the i,j th minor of
% a matrix.

symbolic procedure sprmcol(num,list);
 begin scalar row,roe,rlist,newlist;
  while list do
   << row := car list;
      roe := cdr row;
     % cnt := car row;
      rlist := car row . rlist;
      while roe do
       << if num = caar roe then roe := cdr roe
           else <>;
       >>;
      list := cdr list;
      newlist := reverse(rlist) . newlist;
      rlist := nil;
   >>;
  return reverse(newlist);
 end;

% This is the determinent function for sparse matrices.

% To replace current code.
% Extended for Sparse Matrices (unlke the Matrix det I only have one
% method of calculation).

symbolic procedure simpdet u;
   % We can't use the Bareiss code when rounded is on, since exact
   % division is required.
  if checksp u = 'sparse then spdet spmatsm car u
   else if !*cramer or !*rounded then detq spmatsm carx(u,'det)
     else bareiss!-det u;


symbolic procedure spdet(u);
 begin scalar len,lena,lenb,llist,ans;
  len:= cdr caddr u;
  lena:=car len;
  lenb:=cadr len;
  llist:=cadr u;
  if not (lena = lenb) then rederr "Non square matrix"
   else ans := nsimpdet(llist,lena);
  return ans;
end;

% A new approach to the ongoing determinent problem.

symbolic procedure mod(a,b);
 if a < b then a
 else mod((a - b), b);

% THE determinant solver (based on the Sarrus' Rule!!)
% The algorithm only works for matrices > 2. As a result a further
% function has been written to deal with this case.

symbolic procedure nsimpdet(list,len);
 begin scalar row,col,xx,rcnt,ccnt,val,zz,res,sign;
  row := 1;
  col := 1;
   zz := simp 0;
  ccnt := 0;
 if len = 2 then return twodet(list);
 if len = 1 then return simp findelem2(list,1,1);
 while res = nil do
  <<
   while not (ccnt = len) do
    << xx := simp 1;
     rcnt := 0;
    while not (rcnt = len) do
     <<  val := simp findelem2(list,row,col);
          if val = (nil ./ 1) then << xx := val; rcnt := len>>
         else
           << xx := multsq(val,xx);
               if sign then row := row - 1
               else row := row + 1;
               col := mod((col + 1),(len + 1));
               if col = 0 then col := 1;
               rcnt := rcnt + 1;
           >>;
     >>;
        if not (xx=(nil ./ 1)) then
         <>;
        ccnt := ccnt + 1;
        col := col + 1;
        if sign then row := len
         else row := 1;
    >>;
      if ccnt = len and sign then res := t;
      ccnt := 0;
      sign := t;
      col := 1;
      row := len;

   >>;
  return zz;
 end;

% The determinent solver for 2 x 2 matrices.

symbolic procedure twodet(list);
 begin scalar val1,val2,res;
  val1:=multsq(simp findelem2(list,1,1), simp findelem2(list,2,2));
  val2:=multsq(simp findelem2(list,2,1), simp findelem2(list,1,2));
   res:=subtrsq(val1,val2);
  return res;
 end;



% This function produces an augmented matrix ready to perform Gaussian
% Elimination in order to calculate the inverse.

symbolic procedure spaugment(list,len);
 begin;
 % he:=car list;
 % tl := caddr list;
  %nlist:=list(he,sumsol(cadr list,0),tl);

  for i:= 1:len do
   <>;
  return list;
 end;

% Gaussian Elimination.


% A function for row swapping.

symbolic procedure swap(row,rest,i);
 begin scalar rowb,len;
 len:=cadr caddr rest;
 if i=len then rerror(matrix,13,"Singular Matrix");
  rowb := findrow(rest,i+1);
 if i = caar cdr rowb then
  << letmtr3(list(rest,i),rowb,rest,nil);
     letmtr3(list(rest,i+1),row,rest,nil);
  >>
  else <>;
  return rest;
 end;

symbolic procedure spgauss(list,len);
 begin scalar rows,nrow,frow,row,cols,piv,plist,ndrow,drow,mval,clist,
               rown,rcnt,ccnt,rowlist;
  rows:=spaugment(list,len);
  rcnt := 0;
  for i:=1:cadr caddr list do
    << frow:=findrow(rows,i);
       if not (frow=nil) then
       <<
       row:=i;
       piv := 0;
    if not (row = rcnt + 1) then rerror(matrix,13,"Singular Matrix");
    while piv = 0 do
    << cols:= cdr frow;
       if caar cols = row then
        << piv := simp cdar cols;
           piv := (cdr piv . car piv)
        >>
       else
        << rowlist:=swap(frow,rows,i);
           frow := findrow(rowlist,i);
        >>;
     >>;

    %plist:=mkempspmat(1,list('spm,1,caddr caddr list));
    %letmtr3(list(clist,1),frow,clist,nil);
   if not (piv = simp 1) then
    << frow:=list(nil). for each xx in cdr frow collect
               (car xx . mk!*sq(multsq(piv,simp cdr xx)));
        %findrow(cadr car spmultsm(piv, clist),1);
    >>;
   %letmtr3(list(clist,1),frow,clist,nil);
   letmtr3(list(rows,i),frow,rows,nil);
   for j:=i+1:cadr caddr list do
   << drow := findrow(rows,j);
     if drow then
     << rown:=j;
      ccnt := caar cdr drow;
      if ccnt = row then
       << mval := simp cdadr drow;
              if mval = (nil ./ 1) then mval := mval
               else mval := ((- car mval) . cdr mval);
       >>
       else mval := simp 0;          %and also for 0 cols.
         clist:=mkempspmat(1,list('spm,1,1));
         plist:=mkempspmat(1,list('spm,1,1));
         letmtr3(list(clist,1),drow,clist,nil);
       if mval = simp 0 then ndrow := clist
         else
         <>;
       >>;
     >>;
    rcnt := rcnt + 1;
   >>
   else <>;
 >>;
  spback_sub(rows,len);
  return rows;
 end;

% This is the procedure for back substitution.

% This function re-writes the matrix list in order to print it out.

symbolic procedure sumsol(list,len);
 begin scalar clist,row;
  for i:=1:len do
  << row:=findrow(list,i);
     if not (row=nil) then
     << clist := for each x in row collect ((car x - len) . cdr x);
        letmtr3(list(list,i),list(nil) . clist,list,nil);
     >>;
  >>;
 end;

% Recursively the rows of the matrix are calculated for each row and
% column values.

symbolic procedure sumsol2(rows,row,listb,len);
 begin scalar rcnt,slist,col,row,val,sum,rlist,lena,elist,llist,list,mval;
  rcnt := row;
  listb := cdr listb;
  elist := cdr listb;
   sum := 0;
   lena := len + 1;
 if row = len then return (elist);
 for i:=lena:2*len + 1 do
 << sum := simp 0;
    for each xx in elist do
     << val := simp cdr xx;
        col:=car xx;
        if col>;
      >>;
   list:=atsoc(lena,elist);
   llist := sol(list,sum,lena);
   if not (llist = nil) then rlist := llist . rlist
    else rlist := rlist;
  rcnt := row;
  lena := lena + 1;
  elist := cdr listb;
  >>;

  return (reverse rlist);
 end;

% This sub-function performs the actual calculation for the matrix.

symbolic procedure sol(list,sum,ccnt);
 begin scalar ccnt,col,val,nval,nlist;
  if list = nil then << col := ccnt; val := simp 0 >>
       else << col := car list; val := simp cdr list >>;
      if ccnt = col then val := val
       else val := simp 0;
      if sum = simp 0 then nval := mk!*sq val
       else nval := mk!*sq(subtrsq(val,sum));
      if not (nval = 0) then nlist := ccnt . nval;
  return nlist;
 end;

% The back-substitution function.

symbolic procedure spback_sub(list,len);
 begin scalar ilist,lrow,rcnt;
  rcnt := 0;
  for i:=len step -1 until 1 do
   << lrow := findrow(cadr list,i);
      if not (lrow=nil) then
       << ilist:= sumsol2(list,i,lrow,len);
          letmtr3(list(list,i),ilist,list,nil);
       >>;
   >>;
   sumsol(list,len);
   return list;
 end;

%The inverse functions, which call the gaussian elemination code.

symbolic procedure spmatinverse(list);
 begin scalar rows,len;
  len:=caddr list;
  rows:=mkempspmat(cadr len, len);
  rows:=copy_vect(list,nil);
  rows:=spgauss(rows,cadr len);
  return list(rows);
 end;

% To replace current function.
% Extended for Sparse Matrices.

symbolic procedure matinverse u;
 if car u = 'sparsemat then spmatinverse(u)
  else lnrsolve(u,generateident length u);

% The following are the functions to calculate the trace of a matrix.

% To replace current function.
% Extended for Sparse Matrices.

symbolic procedure simptrace u;
   begin integer n; scalar z;
   if checksp u = 'sparse then z := sptrace spmatsm car u
    else
     << u := spmatsm carx(u,'trace);
        if length u neq length car u then rederr "Non square matrix";
        n := 1;
        z := nil ./ 1;
        for each x in u do <>;
      >>;
        return z
   end;

% The sparse trace function

symbolic procedure sptrace(list);
 begin scalar val,sum,rlist,len;
  len:= cadar reverse list;
  rlist := cadr list;
  sum := simp 0;
  for i:=1:len do
   << val := simp findelem2(rlist,i,i);
      sum := addsq(sum,val);
   >>;

  return sum;
 end;


% A function for finding the cofactor of a matrix.
% E.g The det of the matrix minor (with the row and col removed).

% To replace current code.
% Extended for Sparse Matrices.

symbolic procedure simpcofactor u;
  if checksp car u = 'sparse then
   spcofactor(spmatsm car u,ieval cadr u,ieval carx(cddr u,'cofactor))
  else
   cofactorq(spmatsm car u,ieval cadr u,ieval carx(cddr u,'cofactor));

% Two functions for removing columns and rows respectively.

symbolic procedure spremcol(num,list);
 begin scalar row,col,len;
 len:=cadr caddr list;
  for i:=1:len do
  << row := findrow(list,i);
     if not (row=nil) then
     <<
     col:=atsoc(num,row);
     if col then
     <>;
     >>;
  >>;
 end;


symbolic procedure spremrow(num,list);
 begin;
 letmtr3(list(list,num),nil,list,nil);
 end;

% The function to hold it all together.

symbolic procedure spcofactor(list,row,col);
 begin scalar len,lena,lenb,rlist,res;
  len := caddr list;
  rlist :=copy_vect(list,len);
  lena := cadr len;
  lenb := caddr len;
  if not (row > 0 and row < lena + 1)
    then rerror(matrix,20,"Row number out of range");
  if not (col > 0 and col < lena + 1)
   then rerror(matrix,21,"Column number out of range");
  if not (lena = lenb)
   then rerror(matrix,22,"non-square matrix");

   spremrow(row,rlist);
   spremcol(col,rlist);

   if rlist = nil then res := simp nil
    else
     << rewrite(rlist,lena - 1,row,col);
        res:= nsimpdet(rlist, lena - 1);
        if remainder(row+col,2)=1 then res := negsq res;
      >>;
  return res;
 end;

% This function rewrites the Minor matrix when the rows and columns have
% been removed.
% This is necessary in order to use the nsimpdet function.

symbolic procedure rewrite(list,len,row,col);
 begin scalar rcnt,ccnt,rows,cols,cola,coln,rlist,cnt,val,rown,
              rrcnt,leng,unt;
  rcnt:=1;
  rrcnt := 1;
  leng:=caddr list;
  if cadr leng = caddr leng then unt:=len+1
   else unt:=len;
  for i:=1:unt do
  << rows := findrow(list,i);
   if not (rows=nil) then
   << cols := cdr rows;
      rown := i;
      if rcnt = row then rcnt := rcnt + 1;
      if rown = rcnt then
      << cnt:=1;
         ccnt:=1;
         rlist := nil;
         while cols and not (cnt = len + 1) do
          << cola:=car cols;
             coln:=car cola;
              val:=cdr cola;
              if cnt = col then ccnt:= ccnt + 1;

              if coln = ccnt then << rlist := (cnt . val) . rlist;
                                     cnt := cnt + 1;
                                     cols := cdr cols;
                                     ccnt := ccnt + 1>>
               else <>;
           >>;
        letmtr3(list(list,rrcnt),list(nil) . reverse rlist,list,nil);
        rrcnt := rrcnt + 1;
         rcnt:= rcnt + 1;
        >>
        else << rcnt := rcnt + 1; rrcnt := rrcnt + 1>>;
     >>
    else rcnt:=rcnt+1;
    >>;
   if len + 1 = cadr caddr list then
    letmtr3(list(list,len+1),nil,list,nil);
   return list;
 end;

endmodule;

end;

%***********************************************************************
%=======================================================================
%
% End of Code.
%
%=======================================================================
%***********************************************************************

%in "spmateigen.red";
%in "splinalg.red";


mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/0000755000175000017500000000000011722677361021327 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/sum/sum2.red0000644000175000017500000006160511526203062022702 0ustar  giovannigiovannimodule sum2; % Auxiliary package for summation in finite terms.

% Authors: K.Yamamoto, K.Kishimoto & K.Onaga  Hiroshima Univ.
% Modified by: F.Kako                         Hiroshima Univ.
%         Fri Sep. 19, 1986
%         Mon Sep. 7, 1987   added PROD operator (by F. Kako)
% e-mail: kako@kako.math.sci.hiroshima-u.ac.jp
%         or D52789%JPNKUDPC.BITNET

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Usage:
%         sum(expression,variable[,lower[,upper]]);
%         lower and upper are optionals.

%         prod(expression,variable[,lower[,upper]]);
%         returns product of expression.

fluid '(!*trsum);               % trace switch;

fluid '(sum_last_attempt_rules!*);

switch trsum;

symbolic procedure simp!-sum0(u,y);
  begin scalar v,upper,lower,lower1,dif;
      if not atom cdr y then <<
          lower := cadr y;
          lower1 := if numberp lower then lower - 1
                     else list('plus,lower,-1);
          upper := if not atom cddr y then caddr y else car y;
          dif := addsq(simp!* upper, negsq simp!* lower);
          if denr dif = 1 then
              if null numr dif
                then return subsq(u,list(!*a2k car y . upper))
                else if fixp numr dif then dif := numr dif
                else dif := nil
           else dif := nil;
          if dif and dif <= 0 then return nil ./ 1;
          if atom cddr y then upper := nil>>;
      v := !*a2k car y;
      return simp!-sum1(u,v,y,upper,lower,lower1,dif)
   end;

symbolic procedure simp!-sum1(u,v,y,upper,lower,lower1,dif);
   begin scalar w,lst,x,z,flg;
      lst := sum!-split!-log(u,v);
      w := car lst;
      lst := cdr lst;
      u := nil ./ 1;
    a:
      if null w then go to b;
      x := multsq(caar w,
                  simp!-prod1(cdar w,v,y,upper,lower,lower1,dif));
      u := addsq(u,simp!* list('log, prepsq x));
      w := cdr w;
      go to a;
    b:
       if null lst then return u;
            flg := nil;
            z := car lst;
            if !*trsum then <<
               prin2!* "Summation ";sqprint z;prin2!*  " w.r.t ";
               xprinf(!*k2f v,nil,nil);terpri!* t >>;
%           z := reorder numr z ./ reorder denr z;
            w := sum!-sq(z,v);
            if w = 'failed then <<
                if !*trsum then <<
                     prin2!* "UMM-SQ failed. Trying SUM-TRIG";
                     terpri!* t>>;
                w := sum!-trig(z,v);
                if w = 'failed then <<
                     if !*trsum then <<
                         prin2!* "SUM-TRIG failed.";
                         terpri!* t>>;
                     w := sum!-unknown(z,v,y,lower,dif);
                     flg := car w;
                     w := cdr w>>>>;
            if !*trsum then <<
                 prin2!* "Result  = "; sqprint w; terpri!* t >>;
            if flg then goto c;
            if upper then
                w := addsq(subsq(w,list(v . upper)),
                           negsq subsq(w,list(v . lower1)))
             else if lower then
                w := addsq(w , negsq subsq(w, list(v . lower1)));
   c:
            u := addsq(u,w);
            lst := cdr lst;
            goto b
   end;


%*********************************************************************
%       Case of trigonometric or other functions
%       Trigonometric functions are expressed in terms of exponetials.
%       Pattern matching to get the summation in closed form.
%********************************************************************;

global '(!*trig!-to!-exp);              % variable to indicate
                                        % that the expression contains
                                        % some trig. functions.

symbolic procedure sum!-trig(u,v);
   begin scalar lst,w;  % z;
      !*trig!-to!-exp := nil;           % trig. to exponential.
      u := trig!-to!-expsq(u,v);
      if not !*trig!-to!-exp then return 'failed;
      lst := sum!-term!-split(u,v);
      u := nil ./ 1;
   a:
      if null lst then return exp!-to!-trigsq u;
%     z := reorder numr car lst ./ reorder denr car lst;
%     w := sum!-sq(z,v);
      w := sum!-sq(car lst,v);
      if w = 'failed then return 'failed;
%      w := exp!-to!-trigsq w;     % exponential to trig. function.
      u := addsq(u,w);
      lst := cdr lst;
      goto a
   end;

   sum_last_attempt_rules!* :=
    algebraic  <<
    { sum(~f + ~g,~n,~anf,~ende) => sum(f,n,anf,ende) +
                                       sum(g,n,anf,ende)
                when or (part(sum(f,n,anf,ende),0) neq sum ,
                         part(sum(g,n,anf,ende),0) neq sum ),
      sum((~f+~g)/~dd,~n,~anf,~ende) => sum(f/dd,n,anf,ende) +
                                        sum(g/dd,n,anf,ende)
                when or (part(sum(f/dd,n,anf,ende),0) neq sum ,
                         part(sum(g/dd,n,anf,ende),0) neq sum ),
      sum(~c*~f,~n,~anf,~ende) => c* sum(f,n,anf,ende)
                         when freeof(c,n) and c neq 1,
      sum(~c/~f,~n,~anf,~ende) => c* sum(1/f,n,anf,ende)
                         when freeof(c,n) and c neq 1,
      sum(~c*~f/~g,~n,~anf,~ende) => c* sum(f/g,n,anf,ende)
                          when freeof(c,n) and c neq 1} >>$


symbolic procedure sum!-unknown(u,v,y,lower,dif);
   begin scalar z,w;
     if null dif then <<
          z := 'sum . (prepsq u . list car y);
          if w := opmtch z then return (nil . simp w)
           else if null cdr y then return (t . mksq(z,1));
          z := 'sum . (prepsq u . y);
          let sum_last_attempt_rules!*;
          w:= opmtch z;
          rule!-list (list sum_last_attempt_rules!*,nil);
          return (t . if w then simp w else mksq(z,1))>>;
%         return (t . if w := opmtch z then simp w else mksq(z,1))>>;
     z := nil ./ 1;
  a:
     if dif < 0 then return (t . z);
     z := addsq(z,subsq(u,list(v . list('plus,lower,dif))));
     dif := dif - 1;
     go to a
   end;

symbolic procedure sum!-subst(u,x,a);
   if u = x then a
    else if atom u then u
    else sum!-subst(car u, x, a) . sum!-subst(cdr u, x, a);

symbolic procedure sum!-df(u,y);
   begin scalar w,z,upper,lower,dif;
      dif := nil;
      if length(y) = 3 then  <<
         lower := cadr y;
         upper := caddr y;
         dif := addsq(simp!* upper, negsq simp!* lower);
         if denr dif = 1 then
            if null numr dif
               then return simp!* sum!-subst(u, car y, upper)
               else if fixp numr dif then dif := numr dif
               else dif := nil
           else dif := nil;
         if dif and dif <= 0 then return nil ./ 1 >>;
     if null dif then <<
          z := 'sum . (u . y);
          let sum_last_attempt_rules!*;
          w:= opmtch z;
          rule!-list (list sum_last_attempt_rules!*,nil);
          return if w then simp w else mksq(z,1)>>;
     z := nil ./ 1;
  a: if dif < 0 then return z;
     z := addsq(z,simp!* sum!-subst(u, car y, list('plus,lower,dif)));
     dif := dif - 1;
     go to a
   end;


%*********************************************************************
%       Summation by Gosper's algorithm.
%********************************************************************;

symbolic procedure sum!-sq(u,v);
   %Argument U : expression of s-q;
   %         V : kernel;
   %value        : expression of sq (result of summation.);
   begin scalar gn,fn,pn,rn,qn,z,k,x;
      if null numr u then return nil ./ 1;
      x := setkorder list v;
      z := reorder numr u;
      u := z ./ reorder denr u;
      if !*trsum then <<
            prin2t " *** Summation by Gosper's algorithm ***";
            prin2!* "    A(n) = "; sqprint u;terpri!* t;
            terpri!* t>>;
      if domainp z or not (mvar z eq v) or red z then
            <>
       else <>;
      z := quotsq(z,nsubsq(z,v, - 1));
      gn := gcdf!*(numr z,denr z);
      if !*trsum then <<
         prin2!* "A(n)/A(n-1) = ";sqprint z;terpri!* t;
         prin2!* "GN = ";xprinf(gn,nil,nil);terpri!* t>>;
      qn := quotf!*(numr z, gn);
      rn := quotf!*(denr z, gn);
      if nonpolyp(qn,v) or nonpolyp(rn,v) then go to fail;
      if !*trsum then <<
         prin2!* "Initial qn, rn and pn are "; terpri!* t;
         prin2!* "QN = ";xprinf(qn,nil,nil);terpri!* t;
         prin2!* "RN = ";xprinf(rn,nil,nil);terpri!* t;
         prin2!* "PN = ";xprinf(pn,nil,nil);terpri!* t>>;
      k := compress explode '!+j;
      z := integer!-root(resultant(qn,nsubsf(rn,v,k),v),k);
      if !*trsum then <<
         prin2 "Root of resultant(q(n),r(n+j)) are "; prin2t z >>;
      while z do <<
            k := car z;
            gn := gcdf!*(qn,nsubsf(rn,v,k));
            qn := quotf!*(qn,gn);
            rn := quotf!*(rn,nsubsf(gn,v, -k));
            while (k := k - 1)>=0 do
               pn := multf(pn,nsubsf(gn,v, -k));
            z := cdr z>>;
      if !*trsum then <<
         prin2!* "Shift free  qn, rn and pn are";terpri!* t;
         prin2!* "QN = ";xprinf(qn,nil,nil);terpri!* t;
         prin2!* "RN = ";xprinf(rn,nil,nil);terpri!* t;
         prin2!* "PN = ";xprinf(pn,nil,nil);terpri!* t>>;
      qn := nsubsf(qn,v,1);
      if (k := degree!-bound(pn,addf(qn,rn),addf(qn,negf rn),v)) < 0
         then go to fail;
      if !*trsum then <<
         prin2 "DEGREE BOUND is "; prin2t k >>;
      if not(fn := solve!-fn(k,pn,qn,rn,v)) then go to fail;
      if !*trsum then <<
         prin2!* "FN = ";sqprint fn;terpri!* t >>;
      u := multsq(multsq(qn ./ 1,fn), multsq(u, 1 ./ pn));
      z := gcdf!*(numr u, denr u);
      u := quotf!*(numr u, z) ./ quotf!*(denr u,z);
      if !*trsum then <<
            prin2t " *** Gosper's algorithm completed ***";
            prin2!* "    S(n) = "; sqprint u;terpri!* t;
            terpri!* t>>;
      setkorder x;
      return (reorder numr u ./ reorder denr u);
  fail:
      if !*trsum then <<
            prin2t " *** Gosper's algorithm failed ***";
            terpri!* t>>;
      setkorder x;
      return 'failed
   end;

%*********************************************************************
%       integer root isolation
%********************************************************************;

symbolic procedure integer!-root(u,v);
% Produce a list of all positive integer root of U;
   begin scalar x,root,n,w;
        x := setkorder list v;
        u := reorder u;
        if domainp u or not(mvar u eq v) then go to a;
        u := numr cancel(u ./ lc u);
        w := u;                                 % get trailing term;
        while not domainp w and mvar w eq v and cdr w do
            w := cdr w;
        if (n := degr(w,v)) > 0 then <<
            w := lc w;
            while n > 0 do <<
               root := 0 . root;
               n := n - 1>>>>;
        n := dfactors lowcoef w;                % factor tail coeff.
        w := (v . 1) . 1;
        while n do <<
            if not testdivide(u,v,car n) then <<
                root := car n . root;
                u := quotf!*(u, (w . - car n))>>
             else n := cdr n>>;
  a:
        setkorder x;
        return root
   end;


symbolic procedure lowcoef u;
   begin scalar lst,m;
        lst := dcoefl u;
        m := 0;
  a:
        if null lst then return m;
        m := gcdn(m,car lst);
        if m = 1 then return 1;
        lst := cdr lst;
        go to a
   end;


symbolic procedure dcoefl u;
   if domainp u then if fixp u then list abs u else nil
    else nconc(dcoefl lc u , dcoefl red u);

symbolic procedure testdivide(u,v,n);
% Evaluate U at integer point (V = N);
   begin scalar x;
 a:
       if domainp u or not(mvar u eq v) then return addf(u,x);
       x := addf(multd(expt(n,ldeg u),lc u),x);
       if (u := red u) then go to a;
       return x
   end;


%*********************************************************************
%********************************************************************;

symbolic procedure degree!-bound(pn,u,v,kern);
% degree bound for fn;
%       u: q(n+1) + r(n);
%       v: q(n+1) - r(n);
   begin scalar lp,l!+, l!-, x,m,k;
      x := setkorder list kern;
      u := reorder u;
      v := reorder v;
      pn := reorder pn;
      l!+ := if u then degr(u,kern) else -1;
      l!- := if v then degr(v,kern) else -1;
      lp := if pn then degr(pn,kern) else -1;
      if l!+ <= l!- then <>;
      k := lp - l!+ + 1;
      if l!+ > 0 then u := lc u;
      if l!- > 0 then v := lc v;
      if l!+ = l!- + 1 and fixp(m := quotf1(multd(-2,v),u)) then
        k := max(m,k)
       else if lp = l!- then k := max(k,0);
   a:
      setkorder x;
      return k
   end;

%*********************************************************************
%       calculate polynomial f(n) such that
%       p(n) - q(n+1)*f(n) + r(n)*f(n-1) = 0;
%********************************************************************;

symbolic procedure solve!-fn(k,pn,qn,rn,v);
   begin scalar i,fn,x,y,z,u,w,c,clst,flst;
      c := makevar('c,0);
      clst := list c;
      fn := !*k2f c;
      i := 0;
      while (i := i + 1) <= k do <<
         c := makevar('c,i);
         clst := c . clst;
         fn := ((v . i) . !*k2f c) . fn>>;
      z :=
       addf(pn,
            addf(negf multf(qn,fn),
                 multf(rn,nsubsf(fn,v, - 1))));
      x := setkorder (v . clst);
      z := reorder z;
      c := clst;
      if !*trsum then <<
         prin2!* "C Equation is";terpri!* t;
         xprinf(z,nil,nil);terpri!* t >>;
  a:
      if domainp z or
         domainp (y := if mvar z eq v then lc z else z) then
           go to fail;
      w := mvar y;
      if not(w memq clst) then go to fail;
      if !*trsum then <<
         prin2!* "C Equation to solve is ";xprinf(y,nil,nil);terpri!* t;
         prin2!* " w.r.t ";xprinf(!*k2f w,nil,nil);terpri!* t >>;
      u := gcdf!*(red y , lc y);
      u := quotf!*(negf red y, u) ./ quotf!*(lc y, u);
      flst := (w . u) . flst;
      z := subst!-cn(z,w,u);
      if !*trsum then <<
         xprinf(!*k2f w,nil,nil);prin2!* " := ";sqprint u;terpri!* t >>;
      clst := deleteq(clst,w);
      if z then go to a;
      setkorder c;
      fn := reorder fn;
      u := 1;
      while not domainp fn and mvar fn memq c do <<
         w := mvar fn;
         z := atsoc(w,flst);
         fn := subst!-cn(fn,w,if z then cdr z);
         if z then u := multf(u,denr cdr z);
         z := gcdf!*(fn,u);
         fn := quotf!*(fn,z);
         u := quotf!*(u,z)>>;
      setkorder x;
      return cancel(reorder fn ./ reorder u);
 fail:
     if !*trsum then <<
        prin2t "Fail to solve C equation.";
        prin2!* "Z := ";xprinf(z,nil,nil);terpri!* t >>;
     setkorder x;
     return nil
   end;


symbolic procedure subst!-cn(u,v,x);
   begin scalar z;
      z := setkorder list v;
      u := reorder u;
      if not domainp u and mvar u eq v then
         if x then u := addf(multf(lc u,reorder numr x),
                             multf(red u,reorder denr x))
          else u := red u;
      setkorder z;
      return reorder u
   end;



symbolic procedure makevar(id,n);
  compress nconc(explode id, explode n);

symbolic procedure deleteq(u,x);
   if null u then nil
    else if car u eq x then cdr u
    else car u . deleteq(cdr u, x);


symbolic procedure nsubsf(u,kern,i);
% ARGUMENT U : expression of sf;
%          KERN : kernel;
%          I : integer or name of integer variable;
% value        : expression of sf;
   begin scalar x,y,z,n;
      if null i or i = 0 then return u;
      x := setkorder list kern;
      u := reorder u;
      y := addf(!*k2f kern,
                if fixp i then i else !*k2f i);
      z := nil;
   a:
      if domainp u or not(mvar u eq kern) then goto b;
      z := addf(z,lc u);
      n := degr(u,kern) - degr(red u,kern);
      u := red u;
   a1:
      if n <= 0 then goto a;
      z := multf(z,y);
      n := n - 1;
      go to a1;
   b:
      z := addf(z,u);
      setkorder x;
      return reorder z
   end;


symbolic procedure nsubsq(u,kern,i);
% ARGUMENT U : expression of sq;
%       KERN : kernel;
%          I : integer or name of integer variable;
% value        : expression of sq;
   subsq(u,list(kern . list('plus, kern, i)));


%*********************************************************************
%       dependency check
%********************************************************************;

symbolic procedure nonpolyp(u,v);
% check U is not a polynomial of V;
   if domainp u then nil
    else (not(mvar u eq v) and depend!-p(mvar u,v))
         or nonpolyp(lc u,v) or nonpolyp(red u,v);


symbolic procedure depend!-sq(u,v);
   depend!-f(numr u,v) or depend!-f(denr u,v);


symbolic procedure depend!-f(u,v);
   if domainp u then nil
    else depend!-p(mvar u,v) or
         depend!-f(lc u,v) or
         depend!-f(red u,v);


symbolic procedure depend!-p(u,v);
   if u eq v then t
    else if atom u then nil
    else if not atom car u then depend!-f(u,v)
    else if car u eq '!*sq then depend!-sq(cadr u, v)
    else depend!-l(cdr u, v);

symbolic procedure depend!-l(u,v);
   if null u then nil
    else if depend!-sq(simp car u, v) then t
    else depend!-l(cdr u,v);


%*********************************************************************
%       term splitting
%********************************************************************;

symbolic procedure sum!-term!-split(u,v);
   begin scalar y,z,klst,lst,x;
      x := setkorder list v;
      z := qremf(reorder numr u, y := reorder denr u);
      klst := kern!-list(car z,v);
      lst := termlst(car z, 1 ./ 1, klst);
      klst := kern!-list(cdr z,v);
      if depend!-f(y,v) then klst := deleteq(klst,v);
      lst := append(lst, termlst(cdr z, 1 ./ y, klst));
      setkorder x;
      return lst
   end;


symbolic procedure kern!-list(u,v);
% Returns list of kernels that depend on V;
   begin scalar x;
      for each j in kernels u do if depend!-p(j,v) then x := j . x;
      return x
   end;

symbolic procedure termlst(u,v,klst);
   begin scalar x,kern,lst;
      if null u then return nil
       else if null klst or domainp u
        % Preserve order for noncom.
        then return list multsq(v,!*f2q u);
      kern := car klst;
      klst := cdr klst;
      x := setkorder list kern;
      u := reorder u;
      v := reorder(numr v) ./ reorder(denr v);
      while not domainp u and mvar u eq kern do <<
         lst := nconc(termlst(lc u, multsq(!*p2q lpow u, v),klst),lst);
         u := red u>>;
      if u then lst := nconc(termlst(u,v,klst),lst);
      setkorder x;
      return lst
   end;


%*********************************************************************
%       Express trigonometric functions (such as sin, cos ..)
%       by exponentials.
%********************************************************************;

symbolic procedure trig!-to!-expsq(u,v);
   multsq(trig!-to!-expf(numr u,v),
          invsq trig!-to!-expf(denr u,v));


symbolic procedure trig!-to!-expf(u,v);
   if domainp u then u ./ 1
    else addsq(multsq(trig!-to!-expp(lpow u,v),
                      trig!-to!-expf(lc u,v)),
               trig!-to!-expf(red u,v));


symbolic procedure trig!-to!-expp(u,v);
   begin scalar !*combineexpt,w,x,z,n,wi;
      % We don't want to combine expt terms here, since the code
      % depends on the terms being separate.
      n := cdr u;          % integer power;
      z := car u;          % main variable;
      if atom z or not atom (x := car z) or not depend!-p(z,v) then
           return !*p2q u;
      if x memq '(sin cos tan sec cosec cot) then <<
          !*trig!-to!-exp := t;
          w := multsq(!*k2q 'i, simp!* cadr z);
          w := simp!* list('expt,'e, mk!*sq w);
%         W := SIMP LIST('EXPT,'E, 'TIMES . ( 'I . CDR Z));
          wi := invsq w;
          if x eq 'sin then
              w := multsq(addsq(w ,negsq wi),
                          1 ./ list(('i .** 1) .* 2))
           else if x eq 'cos then
              w := multsq(addsq(w, wi), 1 ./ 2)
           else if x eq 'tan then
              w := multsq(addsq(w,negsq wi),
                          invsq addsq(w,wi))
           else if x eq 'sec then
              w := multsq(2 ./ 1, invsq addsq(w, wi))
           else if x eq 'cosec then
              w := multsq(list(('i .** 1) .* 2),
                          invsq addsq(w, negsq wi))
           else
              w := multsq(addsq(w, wi),
                          invsq addsq(w, negsq wi))
                     >>
       else if x memq '(sinh cosh tanh sech cosech coth) then <<
          !*trig!-to!-exp := t;
          w := simp!* list('expt,'e,cadr z);
          wi := invsq w;
          if x eq 'sinh then
              w := multsq(addsq(w,negsq wi), 1 ./ 2)
           else if x eq 'cosh then
              w := multsq(addsq(w,wi), 1 ./ 2)
           else if x eq 'tanh then
              w := multsq(addsq(w,negsq wi),
                          invsq addsq(w,wi))
           else if x eq 'sech then
              w := multsq(2 ./ 1, invsq addsq(w, wi))
           else if x eq 'cosech then
              w := multsq(2 ./ 1, invsq addsq(w, negsq wi))
           else
              w := multsq(addsq(w,wi),
                          invsq addsq(w, negsq wi))
                 >>
       else return !*p2q u;
      return exptsq(w,n)
   end;

%*********************************************************************
%       Inverse of trig!-to!-exp.
%       Express exponentials in terms of trigonometric functions
%                (sin, cos, sinh and cosh)
%                               Wed Dec. 17, 1986 by F. Kako;
%********************************************************************;

symbolic procedure exp!-to!-trigsq u;
   multsq(exp!-to!-trigf numr u,
          invsq exp!-to!-trigf denr u);

symbolic procedure exp!-to!-trigf u;
   begin scalar v,v1,x,y,n;
      u := termlst1(u,1,nil ./1);
      v := nil;
   a:
      if null u then go to b;
      x := caar u;
      y := cdar u;
      u := cdr u;
   a1:
      if u and y = cdar u then <<
         x := addf(x,caar u);
         u := cdr u;
         go to a1>>;
      v := (x . y) . v;
      go to a;
   b:
      v1 := reverse v;
      n := length v;
      u := nil ./ 1;
   c:
      if n = 0 then return u
       else if n = 1 then
          return addsq(u,
                       multsq(!*f2q caar v,
                              simp!* list('expt,'e,mk!*sq cdar v)));
      u := addsq(u,exp!-to!-trigl(caar v1,caar v,cdar v1,cdar v));
      v := cdr v;
      v1 := cdr v1;
      n := n - 2;
      go to c
   end;

symbolic procedure exp!-to!-trigl(a,b,c,d);
%       A*E**C + B*E**D
%               -->
%       ((A+B)*COSH((C-D)/2)+(A-B)*SINH((C-D)/2))*E**((C+D)/2);
%       A, B: sf;
%       C, D: sq;
   begin scalar x,y,z;
      x := !*f2q addf(a,b);
      y := !*f2q addf(a, negf b);
      z := multsq(addsq(c,negsq d), 1 ./ 2);
      z := real!-imag!-sincos z;
      return multsq(simp!* list('expt,'e,
                                mk!*sq multsq(addsq(c,d),1 ./ 2)),
                    addsq(multsq(x, cdr z),
                          multsq(y, car z)))
   end;


symbolic procedure termlst1(u,v,w);
%ARGUMENT U : sf;
%         V : sf;
%         W : sq;
%value      : list of (sf . sq);
   begin scalar x,y;
      if null u then return nil
       else if domainp u then return list (multf(u,v) . w);
      x := mvar u;
      y := if atom x or not(car x eq 'expt) or not(cadr x eq 'e) then
              termlst1(lc u,multf(!*p2f lpow u,v),w)
            else termlst1(lc u,v,addsq(w,multsq(simp!* caddr x,
                                                ldeg u ./ 1)));
      return nconc(y,termlst1(red u,v,w))
   end;


% These can be found in Abramowitz-Stegun (27.8.6 Summable Series), and
% were suggested by Winfried Neun.

algebraic;

let {sum(sin(~n*~tt)/n,~n,1,infinity) => (pi - tt)/2,
     sum(sin(~n*~tt)/(~n)^3,~n,1,infinity) =>
             pi^2*tt/6 - pi*tt^2/4 + tt^3/12,
     sum(sin(~n*~tt)/(~n)^5,~n,1,infinity) =>
             pi^4*tt/90 - pi^2*tt^3/36 + pi*tt^4/48-tt^5/240}$

let {sum(cos(~n*~tt)/(~n),~n,1,infinity) =>  -log(2*sin(tt/2)),
     sum(cos(~n*~tt)/(~n)^2,~n,1,infinity) =>
             pi^2/6 - pi*tt/2 + tt^2/4,
     sum(cos(~n*~tt)/(~n)^4,~n,1,infinity) =>
             pi^4/90 - pi^2*tt^2/12 + pi*tt^3/12-tt^4/48}$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/prod.red0000644000175000017500000002434011526203062022753 0ustar  giovannigiovannimodule prod;  % Module for production of finite terms.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%       Author: F.Kako                      Hiroshima Univ.
%                               Mon Sep. 7, 1987.
%
%       usage:
%               prod(expression,variable[,lower[,upper]]);
%               lower and upper are optional.

fluid '(!*trsum prod_last_attempt_rules!*);

symbolic procedure simp!-prod u;
%ARGUMENT  CAR U: expression of prefix form;
%         CADR U: kernel;
%        CADDR U: lower bound;
%       CADDDR U: upper bound;
%value            : expression of sq form;
   begin scalar v,y,upper,lower,lower1,dif;
      y := cdr u;
      u := simp!* car u;
      if null numr u then return (1 ./ 1)
       else if atom y then return u;
      if not atom cdr y then <<
          lower := cadr y;
          lower1 := if numberp lower then lower - 1
                     else list('plus,lower,-1);
          upper := if not atom cddr y then caddr y else car y;
          dif := addsq(simp!* upper, negsq simp!* lower);
          if denr dif = 1 then
              if null numr dif
                then return subsq(u,list(!*a2k car y . upper))
                else if fixp numr dif then dif := numr dif
                else dif := nil
           else dif := nil;
          if dif and dif <= 0 then return 1 ./ 1;
          if atom cddr y then upper := nil>>;
      v := !*a2k car y;
      return simp!-prod1(u,v,y,upper,lower,lower1,dif)
   end;


symbolic procedure simp!-prod1(u,v,y,upper,lower,lower1,dif);
   begin scalar w,lst,x,z,flg;
      lst := prod!-split!-exp(u,v);
      w := car lst;
      lst := cdr lst;
      u := 1 ./ 1;
    a:
      if null w then go to b;
      x := simp!-sum1(cdar w,v,y,upper,lower,lower1,dif);
      u := multsq(u,simpexpt list(caar w, prepsq x));
      w := cdr w;
      go to a;
    b:
       if null lst then return u;
            flg := nil;
            z := car lst;
            if !*trsum then <<
               prin2!* "Product ";sqprint z;prin2!*  " w.r.t ";
               xprinf(!*k2f v,nil,nil);terpri!* t >>;
%           z := reorder numr z ./ reorder denr z;
            w := prod!-sq(z,v);
            if w = 'failed then <<
                if !*trsum then <<
                     prin2!* "PROD-SQ failed.";
                     terpri!* t>>;
                w := prod!-unknown(z,v,y,lower,dif);
                flg := car w;
                w := cdr w>>;
            if !*trsum then <<
                 prin2!* "Result  = "; sqprint w;terpri!* t >>;
            if flg then goto c;
            if upper then
                w := multsq(subsq(w,list(v . upper)),
                           invsq subsq(w,list(v . lower1)))
             else if lower then
                w := multsq(w , invsq subsq(w, list(v . lower1)));
   c:
            u := multsq(u,w);
            lst := cdr lst;
            goto b
   end;


put('prod,'simpfn,'simp!-prod);

%*********************************************************************
%       Case of other functions
%********************************************************************;

symbolic procedure prod!-unknown(u,v,y,lower,dif);
   begin scalar z,w,uu;
     if null dif then <<
          z := 'prod . (prepsq u . list car y);
          if w := opmtch z then return (nil . simp w)
           else if null cdr y then return (t . mksq(z,1));

          load_package 'factor; % try to find factors
          uu := old_factorize prepf numr u;
          if length uu > 2 then <<
                z := 'times . foreach uuu in cdr uu collect
                 ('prod . ( prepsq
                        multsq(if pairp uuu and eq(car uuu,'!*sq)
                                then cadr uuu
                                else simp uuu,1 ./ denr u)) . y);
                return (t . simp z) >>;

          z := 'prod . (prepsq u . y); % try to apply rules
          let prod_last_attempt_rules!*;
          w:= opmtch z;
          rule!-list (list prod_last_attempt_rules!*,nil);
          return (t . if w then simp w else mksq(z,1))>>;
%         return (t . if w := opmtch z then simp w else mksq(z,1))>>;
     z := 1 ./ 1;
  a:
     if dif < 0 then return (t . z);
     z := multsq(z,subsq(u,list(v . list('plus,lower,dif))));
     dif := dif - 1;
     goto a
   end;

   prod_last_attempt_rules!* :=
    algebraic  <<
    { prod(~f * ~g,~n,~anf,~ende) => prod(f,n,anf,ende) *
                                       prod(g,n,anf,ende)
                when g neq 1 and
                         or(numberp prod(f,n,anf,ende),
                         part(prod(f,n,anf,ende),0) neq prod,
                         part(prod(g,n,anf,ende),0) neq prod),
        prod(~f / ~g,~n,~anf,~ende) => prod(f,n,anf,ende) /
                                       prod(g,n,anf,ende)
                when g neq 1 and
                        or(numberp prod(f,n,anf,ende), % 1?
                        part(prod(f,n,anf,ende),0) neq prod,
                        part(prod(g,n,anf,ende),0) neq prod),
        prod(expt(~f,~k),~n,~anf,~ende) =>
                (for ii:=1:k product prod(f,n,anf,ende))
                when neq(part(prod(f,n,anf,ende),0),prod)} >>;

%*********************************************************************
%       Product of rational function
%********************************************************************;

symbolic procedure prod!-sq(u,v);
%ARGUMENT U : expression of s-q;
%         V : kernel;
%value        : expression of sq (result of product.);
   begin scalar gn,p1n,p2n,rn,qn,z,k,x,y;
      if null numr u then return 1 ./ 1;
      x := setkorder list v;
      qn := reorder numr u;
      rn := reorder denr u;
      if !*trsum then <<
            prin2t " *** Product of A(n) = qn/rn with ***";
            prin2!* "QN = ";xprinf(qn,nil,nil);terpri!* t;
            prin2!* "RN = ";xprinf(rn,nil,nil);terpri!* t>>;
      if nonpolyp(qn,v) or nonpolyp(rn,v) then go to fail;
      k := compress explode '!+j;
      z := integer!-root2(resultant(qn,nsubsf(rn,v,k),v),k);
      if !*trsum then <<
         prin2 "Root of resultant(q(n),r(n+j)) are "; prin2t z >>;
      p2n := p1n := 1;
      while z do <<
            k := car z;
            gn := gcdf!*(qn,nsubsf(rn,v,k));
            qn := quotf!*(qn,gn);
            rn := quotf!*(rn,nsubsf(gn,v, -k));
            if k > 0 then
                while (k := k - 1)>=0 do <<
                   p1n := multf(p1n,nsubsf(gn,v, -k));
                   if y := prod!-nsubsf(gn,v,-k)
                     then p2n := multf(p2n,y)>>
             else if k < 0 then
                while k < 0 do <<
                   p2n := multf(p2n,nsubsf(gn,v, -k));
                   if y := prod!-nsubsf(gn,v,-k)
                     then p1n := multf(p1n,y);
                   k := k + 1>>;
            z := cdr z>>;
      if depend!-f(qn,v) or depend!-f(rn,v) then go to fail;
      u := multsq(p1n ./ p2n, simpexpt list(prepsq (qn ./ rn), v));
      if !*trsum then <<
            prin2t " *** Product of rational function calculated ***";
            prin2!* "    P(n) = "; sqprint u;terpri!* t;
            terpri!* t>>;
      setkorder x;
      return (reorder numr u ./ reorder denr u);
      return u;
  fail:
      if !*trsum then <<
            prin2t " *** Product of rational function failed ***";
            terpri!* t>>;
      setkorder x;
      return 'failed
   end;

symbolic procedure prod!-nsubsf(u,kern,i);
% ARGUMENT U : expression of sf;
%          KERN : kernel;
%          I : integer;
% value        : expression of sf;
   begin scalar x,z,n;
      x := setkorder list kern;
      u := reorder u;
      z := nil;
   a:
      if domainp u or not(mvar u eq kern) then goto b;
      z := addf(z,lc u);
      n := degr(u,kern) - degr(red u,kern);
      u := red u;
      if i = 0 then if n = 0 then nil else z := nil
       else z := multf(z,expt(i,n));
      go to a;
   b:
      z := addf(z,u);
      setkorder x;
      return reorder z
   end;

%*********************************************************************
%       integer (positive and negative) root isolation
%********************************************************************;

symbolic procedure integer!-root2(u,v);
% Produce a list of all integer root of U;
   begin scalar x,root,n,w;
        x := setkorder list v;
        u := reorder u;
        if domainp u or not(mvar u eq v) then go to a;
        u := numr cancel(u ./ lc u);
        w := u;                                 % get trailing term;
        while not domainp w and mvar w eq v and cdr w do
            w := cdr w;
        if (n := degr(w,v)) > 0 then <<
            w := lc w;
            while n > 0 do <<
               root := 0 . root;
               n := n - 1>>>>;
        n := dfactors lowcoef w;                % factor tail coeff.;
        w := (v . 1) . 1;
        while n do <<
            if not testdivide(u,v,car n) then <<
                root := car n . root;
                u := quotf!*(u, (w . - car n))>>
             else if not testdivide(u,v,- car n) then <<
                root := (- car n) . root;
                u := quotf!*(u, (w . car n))>>
             else n := cdr n>>;
  a:
        setkorder x;
        return root
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/sum.rlg0000644000175000017500000003341111527635055022640 0ustar  giovannigiovanniFri Feb 18 21:28:31 2011 run on win32
% Tests of the SUM package.

% Author: Fujio Kako (kako@kako.math.sci.hiroshima-u.ac.jp)

% 1) Summations.

sum(n,n);


 n*(n + 1)
-----------
     2


for i:=2:10 do write sum(n**i,n);


       2
 n*(2*n  + 3*n + 1)
--------------------
         6

  2   2
 n *(n  + 2*n + 1)
-------------------
         4

       4       3       2
 n*(6*n  + 15*n  + 10*n  - 1)
------------------------------
              30

  2     4      3      2
 n *(2*n  + 6*n  + 5*n  - 1)
-----------------------------
             12

       6       5       4      2
 n*(6*n  + 21*n  + 21*n  - 7*n  + 1)
-------------------------------------
                 42

  2     6       5       4      2
 n *(3*n  + 12*n  + 14*n  - 7*n  + 2)
--------------------------------------
                  24

        8       7       6       4       2
 n*(10*n  + 45*n  + 60*n  - 42*n  + 20*n  - 3)
-----------------------------------------------
                      90

  2     8       7       6       4       2
 n *(2*n  + 10*n  + 15*n  - 14*n  + 10*n  - 3)
-----------------------------------------------
                      20

       10       9       8       6       4       2
 n*(6*n   + 33*n  + 55*n  - 66*n  + 66*n  - 33*n  + 5)
-------------------------------------------------------
                          66


sum((n+1)**3,n);


     3      2
 n*(n  + 6*n  + 13*n + 12)
---------------------------
             4


sum(x**n,n);


  n
 x *x
-------
 x - 1


sum(n**2*x**n,n);


  n     2  2      2      2
 x *x*(n *x  - 2*n *x + n  - 2*n*x + 2*n + x + 1)
--------------------------------------------------
                3      2
               x  - 3*x  + 3*x - 1


sum(1/n,n);


     1
sum(---,n)
     n


sum(1/n/(n+2),n);


   n*(3*n + 5)
------------------
     2
 4*(n  + 3*n + 2)


sum(log (n/(n+1)),n);


       1
log(-------)
     n + 1


% 2) Expressions including trigonometric functions.

sum(sin(n*x),n);


         2*n*x + x
  - cos(-----------)
             2
---------------------
            x
     2*sin(---)
            2


sum(n*sin(n*x),n,1,k);


 sin(k*x + x)*k - sin(k*x)*k - sin(k*x)
----------------------------------------
             2*(cos(x) - 1)


sum(cos((2*r-1)*pi/n),r);


      2*pi*r
 sin(--------)
        n
---------------
         pi
  2*sin(----)
         n


sum(cos((2*r-1)*pi/n),r,1,n);


0


sum(cos((2*r-1)*pi/(2*n+1)),r);


       2*pi*r
  sin(---------)
       2*n + 1
------------------
          pi
 2*sin(---------)
        2*n + 1


sum(cos((2*r-1)*pi/(2*n+1)),r,1,n);


       2*n*pi
  sin(---------)
       2*n + 1
------------------
          pi
 2*sin(---------)
        2*n + 1


sum(sin((2*r-1)*x),r,1,n);


  - cos(2*n*x) + 1
-------------------
     2*sin(x)


sum(cos((2*r-1)*x),r,1,n);


 sin(2*n*x)
------------
  2*sin(x)


sum(sin(n*x)**2,n);


  - sin(2*n*x + x) + 2*sin(x)*n
--------------------------------
            4*sin(x)


sum(cos(n*x)**2,n);


 sin(2*n*x + x) + 2*sin(x)*n
-----------------------------
          4*sin(x)


sum(sin(n*x)*sin((n+1)*x),n);


  - sin(2*n*x + 2*x) + sin(2*x)*n
----------------------------------
             4*sin(x)


sum(sec(n*x)*sec((n+1)*x),n);


sum(sec(n*x + x)*sec(n*x),n)


sum(1/2**n*tan(x/2**n),n);


          x
     tan(----)
           n
          2
sum(-----------,n)
         n
        2


sum(sin(r*x)*sin((r+1)*x),r,1,n);


  - sin(2*n*x + 2*x) + sin(2*x)*n + sin(2*x)
---------------------------------------------
                  4*sin(x)


sum(sec(r*x)*sec((r+1)*x),r,1,n);


sum(sec(r*x + x)*sec(r*x),r,1,n)


sum(1/2**r*tan(x/2**r),r,1,n);


          x
     tan(----)
           r
          2
sum(-----------,r,1,n)
         r
        2


sum(k*sin(k*x),k,1,n - 1);


  - sin(n*x - x)*n + sin(n*x)*n - sin(n*x)
-------------------------------------------
              2*(cos(x) - 1)


sum(k*cos(k*x),k,1,n - 1);


  - cos(n*x - x)*n + cos(n*x)*n - cos(n*x) + 1
-----------------------------------------------
                2*(cos(x) - 1)


sum(sin((2k - 1)*x),k,1,n);


  - cos(2*n*x) + 1
-------------------
     2*sin(x)


sum(sin(x + k*y),k,0,n);


         2*n*y + 2*x + y          2*x - y
  - cos(-----------------) + cos(---------)
                2                    2
--------------------------------------------
                        y
                 2*sin(---)
                        2


sum(cos(x + k*y),k,0,n);


      2*n*y + 2*x + y          2*x - y
 sin(-----------------) - sin(---------)
             2                    2
-----------------------------------------
                      y
               2*sin(---)
                      2


sum((-1)**(k - 1)*sin((2k - 1)*x),k,1,n + 1);


       n
 ( - 1) *sin(2*n*x + 2*x)
--------------------------
         2*cos(x)


sum((-1)**(k - 1)*cos((2k - 1)*x),k,1,n + 1);


       n
 ( - 1) *cos(2*n*x + 2*x) + 1
------------------------------
           2*cos(x)


sum(r**k*sin(k*x),k,1,n - 1);


     n                   n
  - r *sin(n*x - x)*r + r *sin(n*x) - sin(x)*r
-----------------------------------------------
                            2
              2*cos(x)*r - r  - 1


sum(r**k*cos(k*x),k,0,n - 1);


     n                   n
  - r *cos(n*x - x)*r + r *cos(n*x) + cos(x)*r - 1
---------------------------------------------------
                              2
                2*cos(x)*r - r  - 1


sum(sin(k*x)*sin((k + 1)*x),k,1,n);


  - sin(2*n*x + 2*x) + sin(2*x)*n + sin(2*x)
---------------------------------------------
                  4*sin(x)


sum(sin(k*x)*sin((k + 2)*x),k,1,n);


  - sin(2*n*x + 3*x) + sin(3*x)*n + sin(3*x) - sin(x)*n
--------------------------------------------------------
                        4*sin(x)


sum(sin(k*x)*sin((2k - 1)*x),k,1,n);


         6*n*x + x          2*n*x - 3*x          2*n*x - x          2*n*x + x
( - sin(-----------) + sin(-------------) + sin(-----------) + sin(-----------)
             2                   2                   2                  2

         3*x          x            3*x
  + sin(-----) + sin(---))/(4*sin(-----))
          2           2             2



% The next examples cannot be summed in closed form.

sum(1/(cos(x/2**k)*2**k)**2,k,1,n);


            1
sum(-----------------,k,1,n)
      2*k      x   2
     2   *cos(----)
                k
               2


sum((2**k*sin(x/2**k)**2)**2,k,1,n);


     2*k      x   4
sum(2   *sin(----) ,k,1,n)
               k
              2


sum(tan(x/2**k)/2**k,k,0,n);


          x
     tan(----)
           k
          2
sum(-----------,k,0,n)
         k
        2


sum(cos(k**2*2*pi/n),k,0,n - 1);


            2
         2*k *pi
sum(cos(---------),k,0,n - 1)
            n


sum(sin(k*pi/n),k,1,n - 1);


         2*n*pi - pi          pi
  - cos(-------------) + cos(-----)
             2*n              2*n
------------------------------------
                   pi
            2*sin(-----)
                   2*n


% 3) Expressions including the factorial function.

for all n,m such that fixp m let
	factorial(n+m)=if m > 0 then factorial(n+m-1)*(n+m)
		   else factorial(n+m+1)/(n+m+1);



sum(n*factorial(n),n);


factorial(n)*(n + 1)


sum(n/factorial(n+1),n);


          - 1
----------------------
 factorial(n)*(n + 1)


sum((n**2+n-1)/factorial(n+2),n);


          - 1
----------------------
 factorial(n)*(n + 2)


sum(n*2**n/factorial(n+2),n);


                 n
            - 2*2
-----------------------------
                2
 factorial(n)*(n  + 3*n + 2)


sum(n*x**n/factorial(n+2),n);


                             n
                            x *n
sum(-----------------------------------------------------,n)
                   2
     factorial(n)*n  + 3*factorial(n)*n + 2*factorial(n)


for all n,m such that fixp m and m > 3 let
	factorial((n+m)/2)= factorial((n+m)/2-1)*((n+m)/2),
	factorial((n-m)/2)= factorial((n-m)/2+1)/((n-m)/2+1);



sum(factorial(n-1/2)/factorial(n+1),n);


                    2*n - 1
         factorial(---------)
                       2
sum(-------------------------------,n)
     factorial(n)*n + factorial(n)


for all n,m such that fixp m and m > 3 clear factorial((n+m)/2);



for all n,m such that fixp m and m > 3 clear factorial((n-m)/2);



% 4) Expressions including combination.

operator comb;

          % Combination function.

for all n ,m let comb(n,m)=factorial(n)/factorial(n-m)/factorial(m);



sum((-1)**k*comb(n,k),k,1,m);


          m                        m
( - ( - 1) *factorial(n)*m + ( - 1) *factorial(n)*n

  - factorial( - m + n)*factorial(m)*n)/(factorial( - m + n)*factorial(m)*n)


sum(comb(n + p,q)/comb(n + r,q + 2),n,1,m);


( - factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*m*p*q

  - 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*m*p

  - factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*m*q

  - 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*m

                                                                              2
  + factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*p*q

  - factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*p*q*r

  + 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*p*q

  - 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*p*r

                                                                            2
  + factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*q

  - factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*q*r

  + 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*q

  - 2*factorial( - q + r)*factorial(m + p - q)*factorial(m + r)*factorial(p)*r

                                                                           2
  - factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*m*q

  + factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*m*q*r

  - 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*m*q

  + 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*m*r

                                                                           2
  - factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*p*q

  + factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*p*q*r

  - 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*p*q

  + 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*p*r

                                                                         2
  - factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*q

  + factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*q*r

  - 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*q

  + 2*factorial(m - q + r)*factorial(m + p)*factorial(p - q)*factorial(r)*r)/(

   factorial(m + p - q)*factorial(m + r)*factorial(p - q)*factorial(r)*(m*p*q

                                  2            2                2    2      2
       - m*p*r - m*q*r + m*q + m*r  - m*r - p*q  + 2*p*q*r - p*r  + q *r - q

              2            3    2
       - 2*q*r  + 2*q*r + r  - r ))


sum((-1)**(k + 1)*comb(n,k)/(k + 1),k,1,n);


   n
-------
 n + 1


for all n ,m clear comb(n,m);



for all n,m such that fixp m clear factorial(n+m);



% 3) Examples taken from
%         "Decision procedure for indefinite hypergeometric summation"
%          Proc. Natl. Acad. Sci. USA  vol. 75, no. 1 pp.40-42 (1978)
%          R. William Gosper, Jr.
%

%            n
%           ____     2
%       f =  ||  (b*k +c*k+d)
%           k=1
%
%            n
%           ____     2
%       g =  ||  (b*k +c*k+e)
%           k=1
%
operator f,gg;

  % gg used to avoid possible conflict with high energy
		% physics operator.

for all n,m such that fixp m let
        f(n+m)=if m > 0 then f(n+m-1)*(b*(n+m)**2+c*(n+m)+d)
                   else f(n+m+1)/(b*(n+m+1)**2+c*(n+m+1)+d);



for all n,m such that fixp m let
	gg(n+m)=if m > 0 then gg(n+m-1)*(b*(n+m)**2+c*(n+m)+e)
		   else gg(n+m+1)/(b*(n+m+1)**2+c*(n+m+1)+e);



sum(f(n-1)/gg(n),n);


     f(n)
---------------
 gg(n)*(d - e)


sum(f(n-1)/gg(n+1),n);


          2  2      2        2
(f(n)*(2*b *n  + 4*b *n + 2*b  + 2*b*c*n + 2*b*c + 2*b*d*n + 3*b*d - 2*b*e*n

                             2            2            3    2      3        3
        - b*e + c*d - c*e + d  - 2*d*e + e ))/(gg(n)*(b *d*n  + 2*b *d*n + b *d

          3    2      3        3      2          2        2          2
       - b *e*n  - 2*b *e*n - b *e + b *c*d*n + b *c*d - b *c*e*n - b *c*e

            2  2  2      2  2        2  2    2          2  2  2      2  2
       + 2*b *d *n  + 4*b *d *n + 2*b *d  + b *d*e - 2*b *e *n  - 4*b *e *n

            2  2      2    2        2          2        2    2        2
       - 3*b *e  - b*c *d*n  - 2*b*c *d*n - b*c *d + b*c *e*n  + 2*b*c *e*n

            2            2            2          2            2      3  2
       + b*c *e + 2*b*c*d *n + 2*b*c*d  - 2*b*c*e *n - 2*b*c*e  + b*d *n

              3        3        2    2        2          2            2  2
       + 2*b*d *n + b*d  - 3*b*d *e*n  - 6*b*d *e*n - b*d *e + 3*b*d*e *n

                2            2      3  2        3          3    3        3
       + 6*b*d*e *n + 3*b*d*e  - b*e *n  - 2*b*e *n - 3*b*e  - c *d*n - c *d

          3        3      2        2  2      3        3        2            2
       + c *e*n + c *e - c *d*e + c *e  + c*d *n + c*d  - 3*c*d *e*n - 3*c*d *e

                2            2      3        3    3        2  2        3    4
       + 3*c*d*e *n + 3*c*d*e  - c*e *n - c*e  + d *e - 3*d *e  + 3*d*e  - e ))


for all n,m such that fixp m clear f(n+m);



for all n,m such that fixp m clear gg(n+m);



clear f,gg;



% 4) Products.

prod(n/(n+2),n);


      2
--------------
  2
 n  + 3*n + 2


prod(x**n,n);


   2
 (n  + n)/2
x


prod(e**(sin(n*x)),n);


                1
----------------------------------
  cos((2*n*x + x)/2)/(2*sin(x/2))
 e


end;


Time for test: 62 ms
@@@@@ Resources used: (0 1 20 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/sum.tex0000644000175000017500000000470011526203062022637 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{The REDUCE Sum Package \\ Ver 1.0 9 Oct 1989}
\date{}
\author{Fujio Kako \\ Department of Mathematics \\ Faculty of Science \\
Hiroshima University \\ Hiroshima 730, JAPAN \\
E-mail: kako@ics.nara-wu.ac.jp}
\begin{document}
\maketitle
\index{Gosper's Algorithm} \index{SUM operator} \index{PROD operator}
This package implements the Gosper algorithm for the summation of series.
It defines operators SUM and PROD.  The operator SUM returns the indefinite
or definite summation of a given expression, and the operator PROD returns
the product of the given expression.  These are used with the syntax:

\vspace{.1in}
\noindent {\tt SUM}(EXPR:{\em expression}, K:{\em kernel},
[LOLIM:{\em expression} [, UPLIM:{\em expression}]])
\vspace{.1in}
\noindent {\tt PROD}(EXPR:{\em expression}, K:{\em kernel},
[LOLIM:{\em expression} [, UPLIM:{\em expression}]])

If there is no closed form solution, these operators return the input
unchanged.  UPLIM and LOLIM are optional parameters specifying the lower
limit and upper limit of the summation (or product), respectively.  If UPLIM
is not supplied, the upper limit is taken as K (the summation variable
itself).

For example:

\begin{verbatim}
     sum(n**3,n);

     sum(a+k*r,k,0,n-1);

     sum(1/((p+(k-1)*q)*(p+k*q)),k,1,n+1);

     prod(k/(k-2),k);
\end{verbatim}

Gosper's algorithm succeeds whenever the ratio

\[ \frac{\sum_{k=n_0}^n f(k)}{\sum_{k=n_0}^{n-1} f(k)} \]

\noindent is a rational function of $n$.  The function SUM!-SQ
handles basic functions such as polynomials, rational functions and
exponentials. \ttindex{SUM-SQ}

The trigonometric functions sin, cos, etc. are converted to exponentials
and then Gosper's algorithm is applied.  The result is converted back into
sin, cos, sinh and cosh.

Summations of logarithms or products of exponentials are treated by the
formula:

\vspace{.1in}
\hspace*{2em} \[ \sum_{k=n_0}^{n} \log f(k) = \log \prod_{k=n_0}^n f(k) \]
\vspace{.1in}
\hspace*{2em} \[ \prod_{k=n_0}^n \exp f(k) = \exp \sum_{k=n_0}^n f(k) \]
\vspace{.1in}

Other functions, as shown in the test file for the case of binomials and
formal products, can be summed by providing LET rules which must relate the
functions evaluated at $k$ and $k - 1$ ($k$ being the summation variable).

\index{tracing ! SUM package} \ttindex{TRSUM}
There is a switch TRSUM (default OFF).  If this switch is on, trace
messages are printed out during the course of Gosper's algorithm.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/zeilberg.red0000644000175000017500000016432211526203062023617 0ustar  giovannigiovannimodule zeilberg; % An implementation of the Gosper and Zeilberger
                 % algorithms.

% Authors: Gregor Stoelting & Wolfram Koepf
% version 1.2, April 1995.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% Reduce version 3.6
%
% References:
%
% R. W. Gosper, Jr.:
% Decision procedure for indefinite hypergeometric summation,
% Proc. Nat. Acad. Sci. USA 75 (1978), 40-42.
%
% Koornwinder, T. H.:
% On Zeilberger's algorithm and
% its q-analogue: a rigorous description.
% J. of Comput. and Appl. Math. 48 (1993), 91-111.
%
% Zeilberger, D.:
% A fast algorithm for proving terminating hypergeometric identities,
% Discrete Math. 80 (1990), 207-211.
%
% Koepf, W.:
% Algorithms for the indefinite and definite summation.
% Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-33, 1994.
%
%
create!-package('(zeilberg),'(contrib sum));


fluid '(zb_version);
zb_version:="package zeilberg, version 1.1, Feb. 15, 1995"$
global '(inconsistent!*);

algebraic;
share zb_order$
zb_order:=5 $
gosper_representation:=nil;
zeilberger_representation:=nil;

% operator gamma,binomial;   % Now in entry.red.
operator hypergeom,pochhammer;
operator summ,zb_f,zb_sigma;
operator local_gamma,local_prod;
gamma1!*rules:={
gamma(~k)=> factorial(k-1)
 when fixp(k) and k>0
};
let gamma1!*rules;

pochhammer!*rules:={
pochhammer(~z,~k)  =>  ( for i:=0:(k-1) product(z + i))
   when fixp k and k < 20 and k > 0,
pochhammer(~z,~k)  => factorial(z+k-1)/factorial(z-1)
   when fixp z and z > 0
};

let pochhammer!*rules;

onerules:=
{gamma(~zb_x)=>1,
 binomial(~zb_x,~zb_y)=> 1,
 factorial(~zb_x)=> 1,
 pochhammer(~zb_x,~zb_y)=> 1
};

onerules2:={summ(~zb_x)=>1,hypergeom(~zb_x1,~zb_x2,~zb_x3)=>1};

gammatofactorial:={gamma(~a) => factorial(a-1)};

zb_binomialrules:={binomial(~n,0)=>1,
binomial(~n,~n)=>1,
binomial(~n,~k)=>0 when (fixp k and k<0),
binomial(~n,~k)=>0 when (fixp (n-k) and (n-k)<0),
binomial(~n,~k)=>factorial(n)/(factorial(k)*factorial(n-k)) when
(fixp k and fixp n)
};

let zb_binomialrules;




switch zb_factor, zb_timer,zb_proof, zb_trace,zb_inhomogeneous;
lisp setq(!*zb_factor,t);
% zb_factor:=1;
zb_direction:=down;

symbolic procedure gosper!*(u,v);
% gosper(f,k) searches for a hypergeometric term that is a closed form
% antidifference.
% form solution does not exist.
% gosper(f,k,m,n) determines
%
%  __n___
%  \
%   \   f(k)
%   /
%  /
%  -----
%   k=m
%
% using Gosper's algorithm. This is only successful if
% Gosper's algorithm applies.
   begin scalar x;
      x := if length v=1 then gosper0(u,aeval car v)
            else if length v=2
             then gosperborders(u,aeval car v,0,aeval cadr v)
            else if length v=3
             then gosperborders(u,aeval car v,aeval cadr v,
                                aeval caddr v)
            else rederr("Illegal number of arguments to SUM");
      return simp x
   end;

symbolic procedure gosper!-eval u;
   <>;

put('gosper,number!-of!-args,2);

put ('gosper,'psopfn,'gosper!-eval);

algebraic procedure gosperborders(func,k,k0,k1);
% gosperborders(func,k,k0,k1) = gosper(func,k,k0,k1)
begin
scalar tmp,gosper2,!*factor;
gosper2:=gosper0(func,k);
tmp:=sub(k=k1,gosper2)-sub(k=k0-1,gosper2);
if lisp !*zb_factor then
 <<
  on factor;
  return num(tmp)/den(tmp)
 >>
else
 return tmp;
end;


algebraic procedure gosper0(func,k);
begin
scalar tmp;
tmp:=gosper1(func,k);
if tmp = zb_gancfse then
  rederr("Gosper algorithm: no closed form solution exists")
else
 return (tmp);
end;

algebraic procedure gosper1(func,k);
% gosper1(func,k) = gosper(func,k)
begin
scalar dexp,gexp,d,g,dg,degree, downmax,facj,partj, j,jj, p,r1,r2,
polynomials,sol,!*exp,!*factor,equations,equationlist,f,varlist,s,l;
clear(gosper_representation,
 zeilberger_representation,rational_certificate);
on exp;
%tester:=func;
%tester:=(tester where onerules);
%if not(type_ratpoly(tester,k)) then
%<<
% tester:=tester/sub(k=k-1,tester);
% if not(type_ratpoly(tester,k))  then
%  rederr("tester: algorithm not applicable")
%>>;
if polynomqq(func,k) then
  <<
  if lisp !*zb_trace then write "Gosper algorithm applicable";
  polynomials:={func,1,1}
  >>
else
 <<
 on factor;
 off exp;
  dg:=simplify_combinatorial(func/sub(k=k-1,func));
  %on exp;
  if dg = 0 then return 0;
  d:=num(dg);
  g:=den(dg);
 %Dexp:=D;
 %Gexp:=G;
 if lisp !*zb_trace then
   write "a(",k,")/a(",k,"-1):=",dg;
 %off factor;
  %on exp;
 %if not ratpoly2(D,G,k) then
 %rederr("Gosper algorithm not applicable");
 if not (polynomq4(d,k) and polynomq4(g,k)) then
  rederr("Gosper algorithm not applicable");
 % Gexp:=NIL;
 % Dexp:=NIL;
  if lisp !*zb_trace then write "Gosper algorithm applicable";
 %off exp;
 %on factor;
 % write "D:=",D;
 %write "G:=",G;
  polynomials:=determine!_polynomials2(d,g,k);
  d:=nil; g:=nil;
  %on exp;
 >>;
if lisp !*zb_timer then
 << write "flag: determine polynomials"; showtime>>;
p:=first(polynomials);
r1:=second(polynomials);
r2:=third(polynomials);
if lisp !*zb_trace then
  << write  "p:=",p; write  "q:=",r1; write  "r:=",r2>>;
off factor;
on exp;
% compute the maximum degree for the polynomial f.
% (Lemma 3.6 in Koornwinder)
degree:=maxdegf(r1,r2,p,k);
if lisp !*zb_trace then write  "degreebound:=",degree;
if lisp !*zb_timer then
 << write "flag: maxdegf"; showtime>>;
if (degree< 0) then
 return (zb_gancfse);
f:=(for j:=0 :degree sum (zb_f(j) * k^j));
equations:=(sub(k=k+1,r1) * f - r2 *  sub(k=k-1,f) - p);
on exp;
equationlist:=coeff(equations,k);
varlist:=(for j:=0 : degree collect (zb_f(j)));
l:=arglength(equationlist);
downmax:=max(degree -l +1 ,0);
sol:={};
sol2:={};
for j:=degree step -1 until downmax   do
<<
 off factor;
 partj:=sub(sol,part(equationlist,l -degree  +j));
 on exp;
 jj:=degree;
 while freeof(partj,zb_f(jj)) and jj geq 0 do
  jj:=jj-1;
 facj:=coeff(partj,zb_f(jj));
 off exp;
 on factor;
 if arglength(facj) = 2 then
 <<
  solj:={zb_f(jj)= -part(facj,1)/part(facj,2)};
  off factor;
  sol:=append(solj,sub(solj,sol));
  sol2:=append({zb_f(jj)},sol2)
 >>;
>>;
 if arglength(sol) = degree  then
    <<
     tmp:=t; j:=0;
     while tmp and j leq degree do
      <<
       if freeof (sol2,zb_f(j)) then
         <<
          sol:=append({zb_f(j) = 0},sub(zb_f(j) = 0,sol));
          tmp:=nil
         >>;
      j:=j +1;
     >>
    >>;
if lisp !*zb_timer then
 << write "flag: sol";showtime>>;
if sub(sol,equations) neq 0 then
 <<
  if lisp !*zb_proof then gosper_representation:={p,r1,r2,nil};
  return(zb_gancfse)
 >>;
f:=sub(sol,f);
if lisp !*zb_proof then gosper_representation:={p,r1,r2,f};
if lisp !*zb_proof then
 if zb_direction = down  then
  <<
   rational_certificate:=sub(k=k+1,r1)/p*f;
   s:=rational_certificate*func
  >>
 else
  <<
   rational_certificate:=sub(k=k+1,r2/p)*f;
   s:=rational_certificate*sub(k=k+1,func)
  >>
else
 s:=sub(k=k+1,r1)/p*f*func;
if lisp !*zb_trace then write  "f:=",f;
off factor;
if lisp !*zb_timer then
<< write "flag: simplify comb von sol:=";showtime>>;
if lisp !*zb_factor then
 <<
  on factor;
  s:=num(s)/den(s);
 >>;
if lisp !*zb_timer then
<< write "flag: num(s)/den(s) under factor";showtime>>;
if lisp !*zb_trace then write  "Gosper algorithm successful";
if zb_direction = down  then
 return s
else
 return sub(k=k-1,s);
end; %gosper1


symbolic procedure sumrecursion!-eval u;
% sumrecursion(f,k,n,j) determines a holonomic recurrence equation
% of order less or equal j for
%
%  _____
%  \
%   \   f(n,k)   with respect to n
%   /
%  /
%  -----
%   k
% sumrecursion(f,k,n) = sumrecursion(f,k,n,zb_order), where zb_order
% is a global variable (default = 5)
<<
 if length u = 3 then
  sumrecursion0(aeval car u,aeval cadr u,aeval caddr u,1,zb_order)
 else
  if  length u = 4 then
   sumrecursion0(aeval car u, aeval cadr u, aeval caddr u,
    aeval cadddr u, aeval cadddr u)
  else rederr("illegal number of arguments")
>>;

put ('sumrecursion, 'psopfn,'sumrecursion!-eval);

algebraic procedure sumrecursion0(func,secundus,n,mini, maxi);
begin
scalar !*factor,!*exp;
if lisp !*zb_factor then on factor;
return part(sumrecursion1(func,secundus,n,mini, maxi),1);
end;

algebraic procedure sumrecursion1(func,secundus,n,mini, maxi);
begin
scalar result1,ank,b,c,d,g,bc,dg, j,jj, inhomogeneous,k,aa,bb,
!*factor,!*exp,order1;
clear(gosper_representation,
 zeilberger_representation,rational_certificate);
result1:=-1;
on exp;
inhomogeneous:=nil;
% provisorisch
if (arglength(secundus )= 3) and (part(secundus,0)=list) then
 rederr("not yet implemented.");
if (arglength(secundus )= 3) and (part(secundus,0)=list) then
  <<
   k:=part(secundus,1);
   aa:=part(secundus,2);
   bb:=part(secundus,3);
   inhomogeneous:=t
  >>
 else
  <<
   k:=secundus;
   aa:=0;
   bb:=0
  >>;
ank:=func;
tester:=func;
%Write("tester:=",tester);
tester:=(tester where onerules);
%Write("tester:=",tester);
if tester neq 0  then
<<
 tester2:=tester;
 tester:=tester/sub(k=k-1,tester);
 %Write("tester:=",tester);
 if not(type_ratpoly(tester,k))  then
  rederr("algorithm not applicable");
 %Write("tester2:=",tester);
 tester2:=tester2/sub(n=n-1,tester2);
 %Write("tester2:=",tester);
 if not(type_ratpoly(tester2,n))  then
  rederr("algorithm not applicable");
>>;
bc:=simplify_combinatorial(ank/sub(n=n-1,ank));
b:=num(bc);
c:=den(bc);
if lisp !*zb_trace then
  write "F(",n,",",k,")/F(",n,"-1,",k,"):=",bc;
on exp;
if not type_ratpoly(bc,n) then
 <<
 if lisp !*zb_trace then
   << write "not rational";
      write "Zeilberger algorithm not applicable";
   >>;
 return extended_sumrecursion1(ank,k,n);
 >>;
dg:=simplify_combinatorial(ank/sub(k=k-1,ank));
d:=num(dg);
g:=den(dg);
if lisp !*zb_trace then
  write "F(",n,",",k,")/F(",n,",",k,"-1):=",dg;
on exp ; % achtung
if not type_ratpoly(dg,k) then
 <<
  if lisp !*zb_trace then
   << write "not rational";
      write "Zeilberger algorithm not applicable";
   >>;
return extended_sumrecursion1(ank,k,n);
 >>;
if lisp !*zb_trace then write "Zeilberger algorithm applicable";
on factor;
order1:=0;
for j:=mini : maxi  do
 if result1 = -1 then
   result1:=sumrecursion2(ank,b,c,d,g,k,n,aa,bb,inhomogeneous,j)
 else
   if order1= 0 then order1:=j -1;
   if result1 = -1 then
   rederr("Zeilberger algorithm fails. Enlarge zb_order");
off factor;
if lisp !*zb_factor then
<<
 on factor;
 if lisp minusp (lc numr cadr aeval prepsq cadr result1) then
   result1:=-result1;
>>;
return {result1,order1};
end;
% sumrecursion1

algebraic procedure
   sumrecursion2(ank,b,c,d,g,k,n,aa,bb,inhomogeneous,order1);
% applies Zeilberger algorithm for order order1
begin
scalar j,jj, p,r10,r20,r1,r2,p1,polynomials, gg, recursion,recursion2,
equations,inhomogeneous,f,varlist,r12,summe,s,k,z,!*factor,!*exp;
if lisp !*zb_factor then
on factor;
if lisp !*zb_trace then
  write  "applying Zeilberger algorithm for order:=",order1;
p0:=
 (for j:=0 : (order1-1) product sub(n=n-j,b) )+
 (for j:=1 : order1 sum (zb_sigma(j) *
 (for jj:=0 : (j-1) product sub(n=n-jj,c)) *
 (for jj:=j : (order1-1) product sub(n=n-jj,b)) ));
r12:=
 d * (for j:=0 : (order1-1) product sub({n=n-j,k=k-1},b))/
 (g * (for j:=0 : (order1-1) product sub(n=n-j,b)));
r12:=simplify_combinatorial(r12);
r10:=num(r12);
r20:=den(r12);
off factor;
polynomials:=
  determine!_polynomials(r10,r20,k);
p1:=first(polynomials);
p:=p1 *p0;
r1:=second(polynomials);
r2:=third(polynomials);
if lisp !*zb_trace then
   <0);
if lisp !*zb_trace then write  "f:=",f;
p:=sub(sol,p);
p:=(p where arbcomplex(~x)=>0);
if lisp !*zb_trace then write  "p:=",p;
if lisp !*zb_proof then zeilberger_representation:={p,r1,r2,f};
if zb_direction = down then
  <>
else
  <>;
va:=sub(sol,va);
vb:=sub(sol,vb);
n0:=order1-1;
for j:=1 : degree do
    n0:=max(testnonnegintroots(den(part(va,j)),n),n0);
%write "n0:=",n0;
%write "first va " , testnonnegintroots(den(part(va,1)),n);
%write "last va " , testnonnegintroots(den(part(va,degree)),n);
for j:=1 :order1 do
    n0:=max(testnonnegintroots(den(part(vb,j)),n),n0);
%write "n0:=",n0;
%write "first vb " , testnonnegintroots(den(part(vb,1)),n);
%write "last vb " , testnonnegintroots(den(part(vb,order1)),n);
n0:=max(testnonnegintroots(den(sub(k=n+1,q)),n),n0);
n0:=max(testnonnegintroots(num(sub(k=n+1,p)),n),n0);
%write "n0:=",n0;
if n0>=order1 then write "recursion valid for n>=",n0+1;
%zb_testnonnegintroots:=n0+1;
zb_testnonnegintroots:=n0-order1+1;
recursion:=summ(n) +
(for j:=1 : order1 sum part(vb,j)* summ(n-j));
 recursion:=num(recursion);
recursion:=(recursion where arbcomplex(~local_x) => 1);
if lisp !*zb_proof or inhomogeneous then
 <<
  gg:=
  f*sub(k=k+1,r2*ank/
    (p1*(for j:=0: order1-1 product sub(n=n-j ,b))));
  gg:=sub(sol,gg);
  proof:=gg;
  gg:=sub({k=k-1,n=n+1},gg);
  gg:=simplify_combinatorial(gg);
  if lisp !*zb_trace then write "G:=",gg;
 >>;
if inhomogeneous then
<<
 on factor;
 if lisp !*zb_inhomogeneous then
 <<
  recursion:=
  {recursion ,
  simplify_combinatorial(sub(k=bb+1,gg) - sub(k=aa,gg))};
  tempo:=
   simplify_combinatorial(sub(k=bb,gg) - sub(k=aa-1,gg));
 >>
 else
 <<
  recursion:=
   gg * sub(k=k+1,recursion) -sub(k=k+1,gg)*recursion;
  recursion:=simplify_combinatorial(recursion);
  recursion:=num(recursion)
 >>;
>>;
%if inhomogeneous
if lisp !*zb_trace then write  "Zeilberger algorithm successful";
if zb_direction = down then
 return recursion
else
 return sub(n=n+order1,recursion);
end; %sumrecursion2

algebraic procedure testnonnegintroots(term1,n);
begin
scalar  n0,l,j,n1;
n0:=-1;
term1 := old_factorize(term1);
l:=arglength(term1);
for j:=1:l do
 <<
 f:=part(term1,j);
 if  deg(f,n )= 1 then
  n1:=-part(coeff(f,n),1)/part(coeff(f,n),2);
   if fixp(n1) then n0:=max(n1,n0)
 >>;
%write "returning",n0;
return n0;
end;




symbolic  procedure hypersum!-eval u;
 <<
  if length u = 4 then
   hypersum1(aeval car u, aeval cadr u, aeval
       caddr u,aeval cadddr u,1,zb_order)
  else
   if  length u = 5 then hypersum1(aeval car u, aeval cadr u,
      aeval caddr u, aeval cadddr u,car cddddr u,car cddddr u)
   else rederr("illegal number of arguments")
 >>;

put ('hypersum, 'psopfn,'hypersum!-eval);

algebraic procedure recursion_to_closed_form(recursion,startl,n,m);
begin
scalar aj,recj,list1,p,q,tmp,j,nonhyp,order1,!*factor,!*exp;
on exp;
list1:={};
order1:= arglength(startl);
p:=part(coeff(recursion,summ(n)),2);
q:=part(coeff(recursion,summ(n-order1)),2);
nonhyp:=0;
if not(freeof(summ,p) and freeof(summ,q)) then
  <<
  nonhyp:=1;
  write "no hypergeometric solution found";
  return  recursion;
   >>;
for j:=1:order1 do
  <<
   aj:=part(startl,j);
   if aj=0 then
    list1:=append(list1,{0})
   else
    <<
     recj:=sub(n= n*order1 +j-1,p) * summ(n) +
        sub(n= n*order1 +j-1,q) *summ(n-1);
      tmp:=rectopoch(recj,n,1,m);
      tmp:={aj * sub(n=(n-j+1)/order1,tmp)};
      list1:=append(list1,tmp);
    >>;
   >>;%for
if order1 = 1 then
 return part(list1,1)
else
 return list1;
end;%recursion_to_closed_form



algebraic procedure hypersum1(upper,lower,z,n,mini, maxi);
begin
scalar tmp1,tmp,j,jj,aj,order1,recursion,term1,!*exp,startl;
off exp;
tmp:=hyperrecursion1(upper,lower,z,n,mini,maxi);
recursion:=part(tmp,1);
order1:=part(tmp,2);
%order1:=recorder(f,n);
if lisp !*zb_trace then
 write "recursion for underlying hypergeometric term:=",recursion;
startl:={1};
if order1 > 1 then
<<
 for j:=1: order1-1 do
 <<
  aj:=sub(n=j,(for jj:=0 :j sum hyperterm(upper,lower,z,jj)));
  aj:=simplify_combinatorial(aj);
  %write "aj:=",aj;
   startl:=append(startl,{aj});
 >>;
>>;
% write "startl in hyp1:=",startl;
return recursion_to_closed_form(recursion, startl,n,0);
end;%hypersum1



% sumtohyper(hyperterm({-a,b},{c},z,k),k);
% sumtohyper(hyperterm({-a,b},{c},z,k),k);
algebraic procedure summation(f,k,n);
begin
scalar l,localhypersum ,upper,lower,z,term,i,tmp,
startl, aj,piecewiseterm,piecewiseseq,f1,partj,
recursion,counter,m,tmpterm,upper,lower,z,prefactor,init,ht,
initial,initialnumber,summand,j,gammasummand,!*exp;
on exp;
ht:=sumtohyper(f,k);
prefactor:=(ht where onerules2);
%write "prefactor:=",prefactor;
ht:=ht/prefactor;
upper:=part(ht,1);
lower:=part(ht,2);
z:=part( ht,3);
f1:=simplify_combinatorial(f);
tmp:=sumrecursion1(f1,k,n,1,zb_order);
%write("zb_testnonnegintroots:=",zb_testnonnegintroots);
recursion:=part(tmp,1);
order1:=part(tmp,2);
if (order1 = 1) and (zb_testnonnegintroots= 0)  then
<<
 return recursion_to_closed_form(recursion,{prefactor},n,0);
>>;
% evaluate upper border
l:=arglength(upper);
initialnumber:=0;
%write "UPPER:=",upper;
for j:=1:l do
 <<
 partj:=part(upper,j);
 %write "partj :=",partj;
 tmp:=coeff(partj,n);
 if arglength(tmp)=2 then
  if fixp(part(tmp,2)) and part(tmp,2)<0 and fixp(part(tmp,1)) then
    initialnumber:=-partj;
 >>;
if initialnumber = 0 then
  rederr("no reccurent evaluation possible");
startl:={};
 for j:=zb_testnonnegintroots: order1-1+ zb_testnonnegintroots do
 <<
  write "prefactor:=",prefactor;
  write "sum(hyperterm(UPPER,LOWER,z,k),k,0,initialnumber):=",
   sum(hyperterm(upper,lower,z,k),k,0,initialnumber);
  aj:=sub(n=j,prefactor*
   sum(hyperterm(upper,lower,z,k),k,0,initialnumber));
  aj:=simplify_combinatorial(aj);
   startl:=append(startl,{aj});
 >>;
write "startl:=",startl;
   term:=recursion_to_closed_form(recursion,startl,n,
            zb_testnonnegintroots);
write "term:=",term;
if freeof(term,summ) then
  return(term)
else
 if freeof(prefactor,n) then
  recursion:=term
 else
  recursion:=sumrecursion(f,k,n);
if lisp !*zb_trace then
 %write "recursion:=",recursion;
counter:=0;
l:=arglength(recursion);
for i:=1 : l do
 <<
  term:=
   part(recursion,i)/(part(recursion,i) where onerules2);
  term:=part(term,1);
   m:=part(term,1);
    counter:=max(counter,m-term);
 >>;
%initial values, depend on testnonnegintroots
if lisp !*zb_trace then
 write "calculating initial values";
 initialnumber:=0;
 l:=arglength(upper);
 for i:=1 : l do
  <<
  tmp:=part(coeff(part(i,upper),n),2);
  if fixp(tmp) and (tmp <0) then
     initialnumber:=part(upper,i);
  % still to implement: rational case
 if initialnumber=0 then
   rederr("no initialization found");
 if zb_testnonnegintroots=0 then
  errorset;
>>;
tmp:=sub(n=0,prefactor);
end; %summation


%in "zeilberger.red"$ hypersum({-n,-n},{1},-1,n);
%hypersum({-n,n+3*a,a},{3*a/2,(3*a+1)/2},3/4,n);
%hyperrecursion({-n,-n},{1},-1,n);
%hypersum({-2 *n ,-2 *n},{1},-1,n);
%sub(n=n/2,hypersum({-2 *n ,-2 *n},{1},-1,n));
%sumtohyper((-1)^k*binomial(n,k)^2,k);
% boolsche Variable
% Polynomgeschichten revisited
% w. schickt
% t durch 1 erstezen.



algebraic procedure recorder(f,n);
begin
pa:=patternarguments(f,summ,{});
pa:=sub(n=0,pa);
return (-min(pa));
end;

algebraic procedure rectopoch(f,n,order1,m);
begin
scalar dennum,denden,cases1,k,nume,deno,!*exp,!*gcd;
on exp; on gcd;
%write "order1:=",order1;
%order1:=recorder(f,n);
%write "f:=",f;
deno:=-part(coeff(f, summ(n)),2);
%if freeof(f, summ(n-order1)) then rederr("not yet implemented");
nume:=part(coeff(f, summ(n-order1)),2);
if order1 >1 then
 <<
 for j:=1 : order1 -1 do
  if not freeof(f,summ(n-j)) then rederr("no hypergeometric solution");
 cases1:={};
 for j:=0 :order1-1 do
 cases1:=append({sub(n=(n-j)/order1,
  rectopoch(summ(n) * sub(n=order1*n+j,nume) +
  summ(n-1) * sub(n=order1*n+j,deno),n,1,m))},cases1);
 return cases1
 >>;
%if not freeof(deno,summ) or not freeof(nume,summ) then
% rederr("no hypergeometric solution");
lcr2:=first(reverse(coeff(deno,n)));
lcr1:=first(reverse(coeff(nume,n)));
nume:=nume/lcr1;
dennum:=den(nume);
nume:=num(nume);
deno:=deno/lcr2;
denden:=den(deno);
deno:=num(deno);
deno:= old_factorize(deno);
nume:= old_factorize(nume);
deno:=(part(deno,1):=part(deno,1)/denden);
nume:=(part(nume,1):=part(nume,1)/dennum);
deno:=refactors(deno,n);
nume:=append({1},refactors(nume,n));
tmp:={};l:=arglength(nume);
for j:=1:l do
 tmp:=append(tmp, {part(nume,j)+m});
nume:=tmp;
tmp:={};l:=arglength(deno);
for j:=1:l do
 tmp:=append(tmp, {part(deno,j)+m});
deno:=tmp;
%write "deno:=",deno;
%write "nume:=",nume;
return hyperterm(nume,deno,lcr1/lcr2,n-m)*factorial(n-m)/
pochhammer(m+1,n-m);
end;
%extended_sumrecursion((pochhammer( - n,k)* pochhammer(b,k)*
%pochhammer(c,k))/(factorial(k)*pochhammer((b - n + 1)/2,k)*
%pochhammer(2*c,k)), k, n);
%hypersum({-n,b,c},{1/2*(1-n+b),2*c},1,n);
% hypersum({a,b},{c},1,a);
%hypersum({-n,b},{c},1,n);
%zeilb([-n,b],[c],1,n,1);




algebraic procedure refactors(term1,n);
begin
scalar a, l,i,c,d,g,pol,degree ,!*exp, !*factor,
denpol,numpol;denpol;
on exp;
g:={};
l:=arglength(term1);
%p1:=part(term1,1);
for i:=1:l do
<<
   pol:=part(term1,i);
   on exp;
  if not freeof(pol,n) then
   <<
   numpol:=num(pol);
   denpol:=den(pol);
   degree:=deg(numpol,n);
   if degree=1 then
     <<
      d:=part(coeff(numpol,n),2)/denpol;
      c:=part(coeff(numpol,n),1)/d/denpol+1;
      <>;
       >>
    else
      newrederr{pol," does not factorize."}
   >>
>>;
return g;
end;

symbolic  procedure hyperrecursion!-eval u;
% hyperrecursion({a_1,...,a_p},{b_1,...,b_q},x,n,j) determines
% a holonomic recurrence equation (up to order j)
% with respect to n for the peneralized hypergeometric function
%  F (a_1,...,a_p;b_1,...,b_q;x)
% hyperrecursion(upper,lower,x,n) =
% hyperrecursion(upper,lower,x,n,zb_order)
% where zb_order is a global variable (default = 5)
 <<
  if length u = 4 then
   hyperrecursion0(aeval car u, aeval cadr u, aeval
       caddr u,aeval cadddr u,1,zb_order)
  else
   if  length u = 5 then hyperrecursion0(aeval car u, aeval cadr u,
      aeval caddr u, aeval cadddr u,car cddddr u,car cddddr u)
   else rederr("illegal number of arguments")
 >>;

put ('hyperrecursion, 'psopfn,'hyperrecursion!-eval);


algebraic procedure hyperrecursion0(upper,lower,z,n,mini, maxi);
begin
scalar !*factor,!*exp;
if lisp !*zb_factor then on factor;
return part(hyperrecursion1(upper,lower,z,n,mini, maxi),1)
end;


algebraic procedure hyperrecursion1(upper,lower,z,n,mini, maxi);
begin
scalar tester,result1,b,c,d,g,bc,dg, upl,lol,func,j,goon,x,
liste,!*factor,!*exp,order1;
clear(gosper_representation,
zeilberger_representation,rational_certificate);
result1:=-1;
upl:=arglength(upper);
lol:=arglength(lower);
%% test if some upper index is a nonnegative integer
%goon:=t;
%liste:=upper;
%while goon do
% <<
%  if liste = {} then
%   goon:=NIL
%  else
%  <<
%   x:=first(liste);
%   if fixp(x) and x>-1 then
%     goon:=NIL
%   else
%     liste:=rest(liste)
%  >>
% >>;
%if arglength(liste)>0 then
% rederr ("some upper index is a nonnegative integer");
goon:=t;
liste:=lower;
while goon do
 <<
  if liste = {} then
   goon:=nil
  else
  <<
   x:=first(liste);
   if fixp(x) and x<1 then
     goon:=nil
   else
     liste:=rest(liste)
  >>
 >>;
if arglength(liste)>0 then
  rederr ("some lower index is a nonpositive integer");
func:=hyperterm(upper,lower,z,local_k);
tester:=func;
%Write("tester:=",tester);
tester:=(tester where onerules);
%Write("tester:=",tester);
if tester neq 0  then
<<
 tester:=tester/sub(n=n-1,tester);
 %Write("tester:=",tester);
 if not(type_ratpoly(tester,n))  then
  rederr("algorithm not applicable");
>>;
bc:=simplify_combinatorial(func/sub(n=n-1,func));
on factor;
b:=num(bc);
c:=den(bc);
if lisp !*zb_trace then
  write "F(",n,",local_k)/F(",n,"-1,local_k):=",b/c;
%off factor;
on exp;
if not type_ratpoly(bc,n) then
 <<
 if lisp !*zb_trace then
  <<
   write "not rational";
   write "Zeilberger algorithm not applicable"
  >>;
 return extended_hyperrecursion1(upper,lower,z,n);
 >>;
dg:=(for j:=1 : upl product(local_k - 1 + part(upper,j))) * z/
  ((for j:=1 :lol product(local_k - 1 + part(lower,j)))*(local_k));
d:=num(dg);
g:=den(dg);
if lisp !*zb_trace then
 <<
  write "F(",n,",local_k)/F(",n,",local_k-1):=",d/g;
  write "Zeilberger algorithm applicable"
 >>;
order1:=0;
for j:=mini:maxi  do
 if result1 = -1 then
  result1:=sumrecursion2(func,b,c,d,g,local_k,n,0,0,nil,j)
 else
  if order1= 0 then order1:=j -1;
if result1 = -1 then
 rederr("Zeilberger algorithm fails. Enlarge zb_order");
if lisp !*zb_factor then
<<
 on factor;
 if lisp minusp (lc numr cadr aeval prepsq cadr result1) then
   result1:=-result1;
>>;
return {result1,order1};
end;
% hyperrecursion1

algebraic procedure determine!_polynomials(r10,r20,k);
% determines polynomials p(k),r1(k),r2(k) as in Lemma 3.1 in
% Koornwinder,  or p_k,r_k,q_k as in Gosper,
% respectively.
begin
scalar tmp,r1divr2,p,r1,r2,j,jj, gamma1,!*exp,!*factor;
on exp;
%write "enter maxshift with ",{r10,r20};
%globalns:={r10,r20};
maxshift1:=maxshift(r10,r20,k);
%write "maxshift:=",maxshift1;
p:=1;
r1:=r10;
r2:=r20;
for jj:=0: maxshift1 do
<<
 %write "jj:=",jj;
 gamma1:=gcd(r1,sub(k= k+jj,r2));
 %write "jj:=",jj;
 if gamma1 neq 1 then
  <<
    r1:=r1/gamma1;
    r2:=r2/sub(k= k-jj,gamma1);
    p:=p * (for j:=0 : (jj-1) product sub(k=k-j,gamma1))
  >>; % if
>>;
return {p,r1,r2};
end;

algebraic procedure determine!_polynomials2(r10,r20,k);
% determines polynomials r1(k),r2(k),p(k) as in Lemma 3.1 in
% Koornwinder
begin
scalar
!*exp,!*factor,
f1,f2,order1,order2,ma,leadj,leadjj,jj,j,r1,r2,p;
on factor;off exp;
p:=1;
r1:=r10;
r2:=r20;
f1:= old_factorize(r1);
f2:= old_factorize(r2);
order1:=arglength(f1);
order2:=arglength(f2);
for j:=1 : order1 do
 for jj:=1 : order2 do
  <<
  complist:=comppol(part(f1,j),part(f2,jj),k);
  comp:=part(complist,1);
  leadj:=part(complist,2);
  leadjj:=part(complist,3);
  if comp> -1 then
  <<
   gamma1:=part(f1,j);
   gamma2:=part(f2,jj);
  %if  gamma1 neq  sub(k=k+j,gamma2) then
    r1:=r1/gamma1;
    r2:=r2/sub(k= k-comp,gamma1);
    p:=p * (for jj:=0 : (comp-1) product sub(k=k-jj,gamma1));
    f1:=(part(f1,j):=1);
    f2:=(part(f2,jj):=1);
 % neu
  >> % if
 >>;
on exp;
return {p,r1,r2};
end; % determine!_polynomials2

algebraic procedure maxshift(p1,p2,k);
% computes the maximal j with
% gcd(p1(k),p2(k+j)) neq 1
begin
scalar f1,f2,order1,order2,ma,j,jj;
ma:=-1;
f1:= old_factorize(p1);
f2:= old_factorize(p2);
order1:=arglength(f1);
order2:=arglength(f2);
for j:=1 : order1 do
 for jj:=1 : order2 do
  ma:=max(ma,comppol(part(f1,j),part(f2,jj),k));
return ma;
end;

algebraic procedure maxdegf(r1,r2,p,k);
% evalutes an upper bound for the degree of f
% with respect to variable k
% (Lemma 3.6 in Koornwinder)
begin
scalar l,dp, hold,hold2,!*exp,!*factor;
on exp;
pminus:=sub(k= k+1,r1) - r2;
pplus:=sub(k= k+1,r1) + r2;
lplus:=deg( pplus,k);
lminus:=deg( pminus,k);
if pminus=0 then lminus:=-1;
dp:=deg(p,k);
if (lplus leq lminus) then
 return max(dp - lminus,0)
else
 <<
 el:=
 part(coeff(pplus,k),lplus+1);
>>;
 if arglength(coeff(pminus,k))
   producttopochhammer(term,k,m1,m2));
term1:=(term1 where local_prod(~term,~k,~m1,~m2)=>
   prod(~term,~k,~m1,~m2));
term1:=(term1 where pochhammer(0,~k)=>0);
term1:=(term1 where pochhammer(~n,~k)=> gamma(~n+~k)/gamma(~n));
term1:=(term1 where binomial(~n,~k) =>
        factorial(~n)/(factorial(~n - ~k)*factorial(~k)));
term1:=(term1 where factorial(~k)=> gamma(~k+1));
return term1;
end;

%ratsimplify_gamma(gamma(n) *n);

algebraic procedure ratsimplify_gamma(term1);
begin
scalar !*exp,!*factor,deno,nume, ln,ld,dega,nuga,derest,nurest,
lnurest,lnuga,lderest,ldega,jj,j,sp,term2,tmp;
on factor;
deno:=den(term1);
nume:=num(term1);
nurest:={};nuga:={};
derest:={};dega:={};
% construct two lists
% dega with parts that are gamma terms
% and derest with the others.
if arglength(deno) >0 then
<<
 if not(part(deno,0)= times) then
  if not freeof(deno,gamma) then
   <<
   deno:=strip_power(deno);
   tmp:=part(deno,1);
   if not(part( tmp,0) = gamma) then
    return term1
   else
    dega:=deno
   >>
  else
   derest:=strip_power(deno)
 else
 <<
  ld:=arglength(deno);
  for j:=1: ld do
  <<
   sp:=strip_power(part(deno,j));
   tmp:=part(sp,1);
   if not freeof(tmp,gamma) and part(tmp,0) = gamma then
     dega:=append(dega,sp)
   else
     derest:=append(derest,sp);
  >>; %for
 >>; %else
>> % if
else
 derest:={deno};
%ende
if arglength(nume) >0 then
<<
 if not(part(nume,0)= times) then
  if not freeof(nume,gamma) then
   <<
   nume:=strip_power(nume);
   tmp:=part(nume,1);
   if not(part( tmp,0) = gamma) then
    return term1
   else
    nuga:=nume
   >>
  else
   nurest:=strip_power(nume)
 else
 <<
  ln:=arglength(nume);
  for j:=1: ln do
  <<
   sp:=strip_power(part(nume,j));
   tmp:=part(sp,1);
   if not freeof(tmp,gamma) and part(tmp,0) = gamma then
     nuga:=append(nuga,sp)
   else
     nurest:=append(nurest,sp);
  >>; %for
 >>; %else
>> % if
else
 nurest:={nume};
%ende
% dega with parts that are gamma terms
% and derest with the others.
ldega:=arglength(dega);
lderest:=arglength(derest);
lnuga:=arglength(nuga);
lnurest:=arglength(nurest);
if ldega>0 then
<<
 for j:=1 : ldega  do
 <<
  tmp:=part(dega ,j);
  tmp:=part(tmp,1);
  for jj:=1 : lderest do
   if (part(derest,jj) - tmp) = 0  then
    <<
     derest:=(part(derest,jj):=1);
     tmp:=tmp+1;
     dega:=(part(dega,j):=gamma(tmp));
    >>;
  for jj:=1 : lnurest do
   if (part(nurest,jj) - tmp) = -1  then
    <<
     nurest:=(part(nurest,jj):=1);
     tmp:=tmp-1;
     dega:=(part(dega,j):=gamma(tmp));
    >>;
 >> %for j
>>; %ldega>0
if lnuga>0 then
<<
 for j:=1 : lnuga  do
 <<
  tmp:=part(nuga ,j);
  tmp:=part (tmp,1);
  for jj:=1 : lnurest do
   if (part(nurest,jj) - tmp) = 0  then
    <<
     nurest:=(part(nurest,jj):=1);
     tmp:=tmp+1;
     nuga:=(part(nuga,j):=gamma(tmp));
    >>;
  for jj:=1 : lderest do
   if (part(derest,jj) - tmp) = -1  then
    <<
     derest:=(part(derest,jj):=1);
     tmp:=tmp-1;
     nuga:=(part(nuga,j):=gamma(tmp));
    >>;
 >>% for j;
>>; %lnuga>0
 term2:=1;
%if lnuga>0 then
for j:=1 : lnuga do term2:=term2 *part(nuga,j);
%if lnurest>0 then
for j:=1 : lnurest  do term2:=term2 * part(nurest,j);
%if ldega>0 then
for j:=1 : ldega do term2:=term2 /part(dega,j);
%if lderest>0 then
for j:=1 : lderest  do term2:=term2 / part(derest,j);
if term2 = term1 then
 return term2
else
 return ratsimplify_gamma(term2);
end; %ratsimplify_gamma

algebraic procedure strip_power(term1);
begin
scalar j,!*factor,list1;
on factor;
list1:={};
if (arglength(term1)<2) or
   (part(term1,0) neq expt) or
   not fixp(part(term1,2))  then
  return {term1}
else
  for j:=1: part(term1,2) do
   list1:=append(list1,{part(term1,1)});
return list1;
end;





% ratsimplify_gamma(gamma(n)/n);
% ratsimplify_gamma(gamma(n)/(n-1));
% ratsimplify_gamma(gamma(n)^2/(n-1)^2);
% ratsimplify_gamma(gamma(n)^2*n^2);
% ratsimplify_gamma((n+1) * gamma(n)^2*n^2);


algebraic procedure simplify_gamma(term1);
% converts all subexpressions
% gamma(xi) -> gamma(xi + m)/((xi)*(xi+1)*...* (xi+m-1))
% where m is the largest integer , so that a subexpression
% gamma(xj) of term1 exists with xj = xi + m.
%
begin
scalar !*exp,!*factor,!*gcd,high,highl,highlength,j;
%on gcd;
%on factor;
if freeof(term1,gamma) then return term1;
highl:={};
highl:=highest_gamma_order(term1,highl);
if lisp !*zb_timer then
 << write "flag:highl:=",highl, "at "; showtime>>;
if highl = {} then return term1;
%term1:=gammashift(term1,highl);
term1:=matchgammashift(term1,highl);
%globalterm3:=term1;
%globalterm1:=gammashift(term1,highl);
%highlength:=arglength(highl);
%for j:=1:highlength do
%<<
%high:=part(highl,j);
%term1:=gammashift(term1,high);
%term1:=(term1 where gamma(~local_x)=>shift_gamma(~local_x,high));
%term1:=(term1 where local_gamma(~local_x)=>gamma(~local_x));
%>>;
%globalterm2:=term1;
%on exp;
return term1;
end;

algebraic procedure matchgammashift(term1,highl);
begin
scalar deno,nume,!*factor;
%on factor;
nume:=num(term1);
deno:=den(term1);
nume:=(nume where gamma(~local_x)=>listshift_gamma(~local_x,highl));
nume:=(nume where local_gamma(~local_x)=>gamma(~local_x));
if nume=0 then return 0;
deno:=(deno where gamma(~local_x)=>listshift_gamma(~local_x,highl));
deno:=(deno where local_gamma(~local_x)=>gamma(~local_x));
return nume/deno;
end;


algebraic procedure highest_gamma_order(term1,highl);
% produces a list of maximal xi for which
% exist subexpressions gamma(xi) of term1, and
% xi-xj is no integer iff xi neq xj
begin
scalar jjj,jj,j,max, term1length,localhighl,localhighllength,new;
term1length:=arglength(term1);
if (term1length<1) or freeof(term1,gamma)  then return highl;
new:=1;
highllength:=arglength(highl);
if part(term1,0) = gamma then
 <<
  if term1length neq 1 then
   rederr("gamma has illegal number of arguments");
  for j:=1 : highllength do
   if fixp(part(highl,j) - part(term1,1)) then
     <<
      if (part(highl,j) - part(term1,1)<0) then
        highl:=(part(highl,j):=part(term1,1));
      new:=0;
     >>;
  if new = 1 then highl:=append(highl,{part(term1,1)});
 >>
else
 for j:=1 : term1length do
 <<
  localhighl:=highest_gamma_order(part(term1,j),{});
  localhighllength:=arglength(localhighl);
  for jjj:=1:localhighllength do
   <<
    highllength:=arglength(highl);
    new:=1;
    for jj:=1 :highllength do
      if fixp(part(highl,jj) - part(localhighl,jjj)) then
        <<
        if (part(highl,jj) - part(localhighl,jjj)<0)  then
         highl:=(part(highl,jj):=part(localhighl,jjj));
        new:=0
        >>;
    if new = 1 then highl:=append(highl,{part(localhighl,jjj)})
   >>;
 >>; % for j:=1 : term1length
% if new = 1
return highl;
end;

algebraic procedure gammashift(term1,highl);
begin
scalar lhighl,term2,xx,nminusxx, j,jj,n;
if freeof(term1,gamma) then
  return term1;
if (arglength(term1)>1) then
  return map(gammashift(~zbglobal,highl),term1);
if (part(term1,0) = gamma) then
<<
 lhighl:=arglength(highl);
 term2:=term1;jj:=1;
 while (term1=term2) and (jj leq lhighl) do
 <<
  xx:=part(term1,1);
  n:=part(highl,jj);
  nminusxx:=n-xx;
  if (nminusxx = 0) then term1:=0;
  if fixp(nminusxx) and (nminusxx neq 0) then
   if nminusxx>0 then
    term2:=(gamma(n) / (for j:=1: nminusxx product(n-j)))
   else
    term2:=gamma(n) * (for j:=1: -nminusxx product(xx-j));
  jj:=jj+1;
  >>;
 return term2
>>
else
 return map(gammashift(~zbglobal,highl),term1);
end;




algebraic procedure shift_gamma(xx,n);
% shifts gamma-expression if n - xx is an integer
% warning: returns operator local_gamma instead of gamma
begin
scalar nminusx,j;
nminusx:=n-xx;
if not fixp(nminusx) then return local_gamma(xx);
if nminusx>0 then return local_gamma(n) /
(for j:=1: nminusx product(n-j)) else
return local_gamma(n) * (for j:=1: -nminusx product(xx-j));
end;


algebraic procedure listshift_gamma(xx,highl);
begin
scalar lhighl,nminusx,j,n,ret;
lhighl:=arglength(highl);
ret:=local_gamma(xx);
for j:=1 :lhighl  do
<<
 n:=part(highl,j);
 nminusx:=n-xx;
 if fixp(nminusx) then
 <<
  if nminusx>0 then
   ret:=local_gamma(n) / (for j:=1: nminusx product(n-j))
  else
   ret:=local_gamma(n) * (for j:=1: -nminusx product(xx-j));
  % j:=highl
 >>
>>;
return ret;
end;

algebraic procedure producttopochhammer(term,k,m1,m2);
% converts products into pochhammers
begin
 scalar fehler,ar,co,aa,bb,liste,tlength,j,pa;
 fehler:=nil;
if (den(term) neq 1) then return
  producttopochhammer(num(term),k,m1,m2)/
producttopochhammer(den(term),k,m1,m2);
 liste:= old_factorize(term);
 %gets initialized with factors of term
 %during the procedure I exchange them with pochhammer terms
 tlength:=arglength(liste);
 for j:=1 : tlength do
 <<
  pa:=part(liste,j);
  co:=coeff(pa,k);
  ar:=arglength(co);
  if ar>2 then fehler:=t
  else if ar<2 then
     liste:=(part(liste,j):= pa^(m2-m1+1))
  else
   <<
    aa:=part(co,2);
    bb:=pa/aa -k;
    if bb = 0 then
     liste:=(part(liste,j):=pochhammer(m1+ part(co,1),m2-m1+1))
    else
     liste:=(part(liste,j):=
      aa^(m2-m1)*pochhammer(bb,m2+1)/pochhammer(bb,m1))
   >>
 >>;
 if fehler then return local_prod(term,k,m1,m2);
 return (for j:=1: tlength  product( part(liste,j)));
end;

% extended
% authors: Gregor Stoelting & Wolfram Koepf

symbolic  procedure extended_gosper!-eval u;
(<< abc:=
<<
if length u = 2 then extended_gosper1(aeval car u, aeval cadr u)
else  if length u = 3 then extended_gosper2(aeval car u, aeval cadr u,
  aeval caddr u)
else  if length u = 4
 then extended_gosperborders(aeval car u, aeval cadr u,
  aeval caddr u,aeval cadddr u)
else rederr("illegal number of arguments")>>;
if eqcar (abc,'!*sq) then
      list('!*sq,cadr abc,nil) else abc>>) where abc=nil;
put ('extended_gosper, 'psopfn,'extended_gosper!-eval);

algebraic procedure extended_gosperborders(term1,k,k0,k1);
begin
scalar tmp,gosper2,!*factor;
gosper2:=extended_gosper1(term1,k);
if zb_direction = up then gosper2:=sub(k=k+1,gosper2);
tmp:=sub(k=k1,gosper2)-sub(k=k0-1,gosper2);
if lisp !*zb_factor then
 <<
  on factor;
  return num(tmp)/den(tmp)
 >>
else
 return tmp;
end;% extended_gosperborders


algebraic procedure extended_gosper2(term1,k,m);
begin
scalar !*exp,!*factor,s,tmp;
tmp:=gosper1(sub(k=k*m,term1),k);
if tmp = zb_gancfse then
  newrederr {"extended Gosper algorithm (Koepf): no ",m,
  "-fold hypergeometric solution"};
s:=sub(k=k/m,tmp);
if lisp !*zb_factor then on factor;
return s;
end; %extended_gosper2

algebraic procedure extended_gosper1(term1,k);
begin
scalar sol,!*factor,j,l,partj,s,m,tmp;
if lisp !*zb_trace then
     write "Koepf extension of Gosper algorithm entered...";
list1:=argumentlist(term1,{});
if list1 = {} then return gosper0(term1,k);
list2:=foreach partj in list1 collect linearfactor(partj,k);
m:=lcml(list2);
if lisp !*zb_trace then
  write "linearizing integer with respect to ",k," is ",m;
s:=extended_gosper2(term1,k,m);
if lisp !*zb_trace then write "s(",k,"):=",s;
sol:=(for j:=0:m-1 sum(sub(k=k-j,s)));
%if m>1 then sol:=simplify_combinatorial(sol);
if zb_direction = up then
 sol:=sub(k=k+1,sol);
if lisp !*zb_factor then on factor;
return sol
end; %extended_gosper1


symbolic  procedure extended_sumrecursion!-eval u;
(<< abc:=
<<
if length u = 3 then
  extended_sumrecursion0(aeval car u, aeval cadr u,aeval caddr u)
else  if length u = 5
 then extended_sumrecursion20(aeval car u, aeval cadr u,
  aeval caddr u,aeval cadddr u,car cddddr u)
else rederr("illegal number of arguments")>>;
if eqcar (abc,'!*sq) then
      list('!*sq,cadr abc,nil) else abc>>) where abc=nil;
put ('extended_sumrecursion, 'psopfn,'extended_sumrecursion!-eval);

algebraic procedure extended_sumrecursion0(term1,k,n);
begin
scalar !*factor,!*exp;
if lisp !*zb_factor then on factor;
return part(extended_sumrecursion1(term1,k,n),1);
end;

%extended_hyperrecursion1({ - n,b,c},{(b - n + 1)/2,2*c},1,n);

algebraic procedure extended_sumrecursion1(term1,k,n);
begin
scalar m,j,l,partj,s,!*exp,dg,bc;
on exp;
if lisp !*zb_trace then
     write "Koepf extension of Zeilberger algorithm entered...";
list1:=argumentlist(term1,{});
if list1 = {} then return sumrecursion1(term1,k,n,1,zb_order);
listk:=foreach partj in list1 collect linearfactor(partj,k);
listn:=foreach partj in list1 collect linearfactor(partj,n);
l:=lcml(listk);
m:=lcml(listn);
if lisp !*zb_trace then
   <<
     write "linearizing integer with respect to ",k," is ",l;
     write "linearizing integer with respect to ",n," is ",m;
   >>;
if m=1 and l=1 then
<<
 bc:=simplify_combinatorial(term1/sub(n=n-1,term1));
 globalbc:=bc;
 if not type_ratpoly(bc,n) then
 <<
  if lisp !*zb_trace then
    write "F(",n,",local_k)/F(",n,"-1,local_k):=",bc;
  rederr("Zeilberger algorithm not applicable")
 >>;
 dg:=simplify_combinatorial(term1/sub(k=k-1,term1));
 on exp;
 if not type_ratpoly(dg,k) then
 <<
  if lisp !*zb_trace then
    write "F(",n,",",k,")/F(",n,",",k,"-1):=",dg;
  rederr("Zeilberger algorithm not applicable")
 >>;
 return(sumrecursion1(term1,k,n,1,zb_order))
>>;
return extended_sumrecursion2(term1,k,n,m,l);
end; %extended_sumrecursion1

algebraic procedure extended_sumrecursion20(term1,k,n,m,l);
begin
scalar !*factor,!*exp;
if lisp !*zb_factor then on factor;
return part(extended_sumrecursion2(term1,k,n,m,l),1);
end;

algebraic procedure extended_sumrecursion2(term1,k,n,m,l);
begin
scalar term2,tmpterm,rule,!*factor,!*exp,order1;
term2:=sub({k=k*l,n=n*m},term1);
if lisp !*zb_trace then
  write  "applying Zeilberger algorithm to F(",n,",",k,"):=",term2;
tmpterm:=sumrecursion1(term2,k,n,1,zb_order);
order1:=m* part(tmpterm,2);
tmpterm:=part(tmpterm,1);
tmpterm:=sub({n=n/m},tmpterm);
rule:={summ(~nn/~mm)=>summ(nn) when mm=m};
tmpterm:=num(tmpterm where rule);
off factor;
tmpterm:=tmpterm;
if lisp !*zb_factor then on factor;
return({tmpterm,order1})
end;

symbolic  procedure extended_hyperrecursion!-eval u;
(<< abc:=
<<
if length u = 4 then
  extended_hyperrecursion0(aeval car u, aeval cadr u,aeval caddr u,
   aeval cadddr u)
%else  if length u = 5
%        then extended_hyperrecursion2(aeval car u, aeval cadr u,
%  aeval caddr u,aeval cadddr u,car cddddr u)
else rederr("illegal number of arguments")>>;
if eqcar (abc,'!*sq) then
      list('!*sq,cadr abc,nil) else abc>>) where abc=nil;
put ('extended_hyperrecursion, 'psopfn,'extended_hyperrecursion!-eval);


algebraic procedure extended_hyperrecursion0(upper,lower,x,n);
   part(extended_hyperrecursion1(upper,lower,x,n),1);

algebraic procedure extended_hyperrecursion1(upper,lower,x,n);
  extended_sumrecursion1(hyperterm(upper,lower,x,local_k),local_k,n);


algebraic procedure linearfactor(term1,n);
begin
scalar p,co;
co:=coeff(term1,n);
if arglength(co) = 1 then return 1;
p:=den(part(co,2));
if arglength(co) > 2 or (not fixp(p)) then
   rederr("Extended Gosper algorithm not applicable");
return p;
end;

algebraic procedure lcml(list1);
begin
% finds least common multiple of a list of integers
scalar p1,l;
l:=arglength(list1);
p1:=part(list1,1);
if l = 1 then return p1;
if l = 2 then return lcm( p1, part(list1,2));
return lcm(p1,lcml(rest(list1)));
end;

algebraic procedure argumentlist(term1, list1);
begin
scalar head1,j,l;
l:=arglength(term1);
if l<1 then return list1;
head1:=part(term1,0);
if head1 = gamma or
   %head1 = expt or
   head1 = factorial then
   list1:=append(list1,{part(term1,1)})
else if
   head1 = pochhammer or
   head1 = binomial then
   list1:=append(list1,{part(term1,1),part(term1,2)})
else
 for j:=1:l do
  list1:=argumentlist(part(term1,j),list1);
return list1;
end;

operator hypergeometric;

%let {gamma(~n)=>factorial(n-1) when (fixp(n) and n>0)};


%sumtohyper(hyperterm({a,a,a,a,a,b},{c},x,k),k);


algebraic procedure negintoccurs(list1);
begin
scalar l,tmp,tmp2,j;
 tmp2:=nil;
 l:=arglength(list1);
 if l = 0 then return nil;
 for j:=1 : l do
 <<
  tmp:=part(list1,j)   ;
  if fixp(tmp) and tmp<0 then tmp2:=t
 >>;
 return tmp2 ;
end; % negintoccurs

algebraic procedure sumtohyper(ank,k);
begin
scalar de,rat,numerator,denominator,numfactors,denfactors,lc,l,numlist,
oldnumlist, olddenlist,tmp,tmp2,
numdegree,denfactors,denlist, dendegree,i,j,lcden,
lcnum,!*exp,!*factor,!*gcd, gcdterm;
on exp;on gcd;
ank:=simplify_combinatorial(ank);
de:=simplify_combinatorial(sub(k=k+1,ank)/ank);
 if lisp !*zb_trace then
   write "a(",k,"+1)/a(",k,"):=",de;
numerator:=num(de);
denominator:=den(de);
if not polynomq4(numerator,k) then
 rederr("cannot be converted into hypergeometric form");
if not polynomq4(denominator,k) then
 rederr("cannot be converted into hypergeometric form");
numerator:=numerator;
denominator:=denominator;
numfactors:= old_factorize(numerator);
denfactors:= old_factorize(denominator);
lcnum:=lcof(numerator,k);
lcden:=lcof(denominator,k);
if lcnum = 0 then lcnum:=numerator;
if lcden = 0 then lcden:=denominator;
lc:=lcnum/lcden;
if freeof(first(numfactors),k) then numfactors:=rest(numfactors);
numlist:={};
len:=length(numfactors);
for i:=1:len do
<<
 fir:=first(numfactors);
 if not freeof(fir,k) then
 <<
  new:=-part(first(solve(fir,k)),2);
  numlist:=append(numlist,{new});
 >>;
 numfactors:=rest(numfactors);
>>;
maxint:=maxposint(numlist);
len:=length(denfactors);
denlist:={};
for j:=1:len do
<<
 fir:=first(denfactors);
 if not freeof(fir,k) then
 <<
  if not polynomq4(fir,k) or deg(fir,k)>2  then
    rederr("not yet implemented")
  else
   tmp:=solve( fir,k);
  for jj:=1: arglength(tmp) do
   denlist:=append(denlist,{-part(part(tmp,jj),2)});
 >>;
 denfactors:=rest(denfactors);
>>;
minint:=minnegint(denlist);
if minint leq 0 then
<<
 if lisp !*zb_trace then
    write "shifting by ",1-minint;
 numlist:=sub(k= k+1-minint,numlist);
 if numberofzeros(numlist)>0 then
  rederr("not yet implemented")
>>
else
<<
 if maxint geq 0 then
 <<
 if lisp !*zb_trace then
    write "shifting by ",1-maxint;
 denlist:=sub(k= k+1-maxint,denlist);
 if numberofzeros(denlist)>0 then
  rederr("not yet implemented");
  minint:=maxint;
 >>
>>;
shiftnumber:=1-minint;
if lisp !*zb_trace then
    write "calculating initial value";
olddenlist:=denlist;
denlist:={};
for j:=1: arglength(olddenlist) do
 denlist:=append({part(olddenlist,j ) + 1-minint},denlist);
oldnumlist:=numlist;
numlist:={};
for j:=1: arglength(oldnumlist) do
 numlist:=append({part(oldnumlist,j ) + 1-minint},numlist);
if sub(k=1-minint,den(ank)) = 0 or sub(pochhammer= poch, den(ank)) = 0
  then tmp:=limit(ank,k,1-minint)
else
 tmp:=sub(k=1-minint,ank);
if  member(1,denlist) then
<<
 tmplist:={};
 done:=0;
 for i:=1 : arglength(denlist) do
  if not(part(denlist,i)=1) or done then
   tmplist:=append(tmplist,{ part(denlist,i)})
  else
   done:=1;
 denlist:=tmplist;
>>
else
 numlist:=append(numlist,{1});
tmp:=simplify_combinatorial(tmp)*hypergeom(numlist,denlist,lc);
if lisp !*zb_trace then
  <<
    write "finished conversion in hypergeometric notation";
    write tmp;
  >>;
return tmp;
end$  % sumtohyper


%remove_reduntant_elements({1,3,6},{1,1,1});
%remove_reduntant_elements({1,3,6},{1,1,3});


algebraic procedure remove_reduntant_elements(denlist,numlist);
begin
scalar j,jj,jjj,ln,ld,tmp;
ln:=arglength(numlist);
ld:=arglength(denlist);
if (ln>0) and (ld>0) then
 <<
  for j:=1:arglength(numlist) do
   for jj:=1 : arglength(denlist) do
     if part(numlist,j) =  part(denlist,jj) then
       <<
        tmp:=denlist; denlist:={};
        for jjj:=1 : jj-1 do denlist:=append(denlist,{part(tmp,jjj)});
        for jjj:=jj+1 :arglength(tmp) do
         denlist:=append(denlist,{part(tmp,jjj)});
         tmp:=numlist; numlist:={};
        for jjj:=1 : j-1 do numlist:=append(numlist,{part(tmp,jjj)});
        for jjj:=j+1 :arglength(tmp) do
         numlist:=append(numlist,{part(tmp,jjj)});
       jj:=arglength(denlist)
        >>
 >>;
return {denlist,numlist};
end;



algebraic procedure trim (u);
  if u = {} then {} else
      if member(first u,rest u) then trim rest u
         else first u . trim rest u;



algebraic procedure maxposint(list1);
begin
scalar partj, l,j,tmp;
tmp:=-1;
l:=arglength(list1);
for j:=1 : l do
<<
 partj:=part(list1,j);
 if fixp(partj) and (partj geq 0)  then
   tmp:=max(tmp,partj);
>>;
return tmp;
end;


algebraic procedure minnegint(list1);
begin
scalar partj, l,j,tmp;
tmp:=1;
l:=arglength(list1);
for j:=1 : l do
<<
 partj:=part(list1,j);
 if fixp(partj) and (partj leq 0)  then
   tmp:=min(tmp,partj);
>>;
return tmp;
end;





algebraic procedure binom(n,k);
begin
scalar i;
 if fixp(n) then
  if n>0  then
   return factorial(n)/(factorial(k)*factorial(n-k))
  else
   if n<0  then
    rederr("negative integer argument")
   else return delta(0,k)
 else
  if fixp(k) then
   return (for i:=0:k-1 product(n-i))/factorial(k)
  else
   return binomial(n,k);
end;



algebraic procedure numberofzeros(list1);
begin scalar c,l,j;
c:=0;
l:=arglength(list1);
for j:=1 :l do
 if part(list1,j) = 0 then c:=c+1;
return c;
end;


algebraic procedure patternarguments(term1,pattern,list1);
begin
scalar j,l;
if freeof(term1,pattern) then return list1;
l:=arglength(term1);
if part(term1,0) = pattern then
 return append(list1 ,{part(term1,1)})
else
 for j:=1:l do
  list1:=patternarguments(part(term1,j),pattern,list1);
return list1;
end;

algebraic procedure remove_part(list1,j);
begin
scalar jj,l,list2;
list2:={};
l:=arglength(list1);
for jj:=1 :j-1 do
list2:=append(part(list1,jj),list2);
for jj:=j+1 : l do
 list2:=append(part(list1,jj),list2);
return list2;
end;

algebraic procedure remove_nonlinear_parts(list1,k);
begin
scalar j,list2,!*exp;
on exp;
list2:=list1;
while list1 neq {} do
<<
 if deg(first(list1),k) > 1 then
  rederr("nonlinear argument in gamma")
 else
  if deg(first(list1),k) = 0 then
   list2:=rest(list2);
 list1:=rest(list1)
>>;
return list2;
end;



algebraic procedure closedform_initialization(f,k,n);
begin
scalar co,j,l,ga,mini,maxi,!*exp,ba,b,a,tmpmax,tmpmin;
on exp;
f:=den(simplify_combinatorial(f));
mini:=nil;
maxi:=nil;
ga:=patternarguments(f,gamma,{});
ga:=remove_nonlinear_parts(ga,k);
l:=arglength(ga);
for j:=1 :l do
<<
 co:=coeff(part(ga,j),k);
 a:=part(co,2);
 b:=part(co,1);
 ba:=-b/a;
 if numberp(a) and fixp(ba) then
  if a >0 then
   if maxi = nil then
    maxi:=ba
   else
    maxi:=max(maxi,ba)
  else % a <0
   if mini = nil then
    mini:=ba
   else
    mini:=min(mini,ba)
 else
  if not freeof(ba,n) then
   <<
   if a >0 then
    tmpmax:=ba
   else
    tmpmin:=ba;
   >>;
>>;
if maxi = nil then maxi:=tmpmax;
if mini = nil then mini:=tmpmin;
return {maxi,mini};
end; %closedform_initialization

%f:=(2*pi)^(-1/2)* 2^(2*w2-1/2)*gamma(w2) * gamma(w2+1/2)-gamma(w2*2);
%simplify_gamma2(f);
%simplify_gamman(f,2);


algebraic procedure simplify_gamma2(term1);
begin
scalar p,l,j,jj,jjj,w1,w2,list1,changed;
list1:=patternarguments(term1,gamma,{});
l:=arglength(list1);
changed:={};
for j:=1:l do
<<
 changed:=nil;
 w1:=part(list1,j);
 jj:=0;
 while not changed and jj < l do
  <<
  jj:=jj+1;
  w2:=part(list1,jj);
  p:=w1 - 2* w2;
  if fixp(p) then
   <<
    if p = 0 then
     term1:=sub(gamma(w1)= (2*pi)^(-1/2)* 2^(2*w2-1/2)*
             gamma(w2) * gamma(w2+1/2),term1)
    else
     if p>0 then
      term1:=sub(gamma(w1)= (for jjj:=1 : p product w1-jjj) *
             (2*pi)^(-1/2)* 2^(2*w2-1/2)*
             gamma(w2) * gamma(w2+1/2),term1)
     else
      term1:=sub(gamma(w1)= 1/(for jjj:=0 : (-p-1) product w1 -jjj)*
             (2*pi)^(-1/2)* 2^(2*w2-1/2)*
              gamma(w2) * gamma(w2+1/2),term1);
    changed:=1
   >> % if
  >> %while
>>; % for
return simplify_combinatorial(term1);
end; %simplify_gamma2

%f:=(2*pi)^(-1/2)* 2^(2*w2-1/2)*gamma(w2) * gamma(w2+1/2)-gamma(w2*2);
%simplify_gamma2(f);
%simplify_gamman(f,2);
%simplify_gamman(gamma(3*w2) -subst,3);
%ff:=( - 2*sqrt(3)*gamma(3*w2)*pi + 3**(3*w2)*gamma((3*w2 + 2)/3)*
%    gamma((3*w2 + 1)/3)*gamma(w2))/(2*sqrt(3)*pi)$
%sub(w2=w2+1,ff);
%simplify_gamman(ws,3);
%simplify_gamman(ff,3);



algebraic procedure simplify_gamman(term1,n);
% applies rule 6.1.20 p 77 in Abramowitz
begin
scalar subst,p,l,j,jj,jjj,jjjj,w1,w2,list1,changed;
list1:=patternarguments(term1,gamma,{});
l:=arglength(list1);
changed:={};
for j:=1:l do
<<
 changed:=nil;
 w1:=part(list1,j);
 jj:=0;
 while not changed and jj < l do
  <<
  jj:=jj+1;
  w2:=part(list1,jj);
  p:=w1 - n* w2;
  if fixp(p) then
   <<
    subst:=(2*pi)^(1/2*(1-n))*n^(n*w2-1/2)*(for jjjj:=0:(n-1)
        product (gamma(w2+ jjjj/n)));
    if p = 0 then
     term1:=sub(gamma(w1)=subst ,term1)
    else
     if p>0 then
      term1:=sub(gamma(w1)= (for jjj:=1 : p product w1-jjj) *
             subst,term1)
     else
      term1:=sub(gamma(w1)= 1/(for jjj:=0 : (-p-1) product w1 +jjj)*
             subst,term1);
    changed:=1
   >> % if
  >> %while
>>; % for
return simplify_combinatorial(term1);
end; %simplify_gamman

operator zb_subst;

% simplify_gamma3(f);
algebraic procedure simplify_gamma3(term1);
begin
scalar subst,p,l,j,jj,jjj,w1,w2,list1,changed;
list1:=patternarguments(term1,gamma,{});
l:=arglength(list1);
changed:={};
for j:=1:l do
<<
 changed:=nil;
 w1:=part(list1,j);
 jj:=0;
 while not changed and jj < l do
  <<
  jj:=jj+1;
  w2:=part(list1,jj);
  p:=w1 - 3* w2;
  if fixp(p) then
   <<
   subst:=
  (2*pi)^(-1) * 3^(3*w2-1/2)* gamma(w2) * gamma(w2+1/3)* gamma(w2+2/3);
    if p = 0 then
     term1:=sub(gamma(w1)= zb_subst(j) ,term1)
    else
     if p>0 then
      term1:=sub(gamma(w1)= (for jjj:=1 : p product w1-jjj) *
              zb_subst(j)  ,term1)
     else
      term1:=sub(gamma(w1)= 1/(for jjj:=0 : (-p-1) product w1 +jjj)*
               zb_subst(j)  ,term1);
    term1:=sub(zb_subst(j)=subst,term1);
    changed:=1
   >> % if
  >> %while
>>; % for
return simplify_combinatorial(term1);
end; %simplify_gamma3



% auxiliary functions

symbolic procedure newrederr(u);
   <>;

symbolic procedure newrederr1(u);
     if not atom u and atom car u and cdr u and atom cadr u
        and null cddr u
       then <>
      else maprin u;

flag('(newrederr),'opfn);



% some compatibility functions for Maple sources.
% by Winfried Neun

put('polynomqq,'psopfn,'polynomqqq);

algebraic procedure polynomq4(expr1,k);
begin scalar !*exp;
on exp;
return polynomqq(expr1,k);
end;


% checks if expr is rational in var
algebraic procedure type_ratpoly(expr1,var);
begin
scalar deno, nume;
deno:=den expr1;
nume:=num expr1;
  if (polynomqq (deno,var) and polynomqq (nume,var))
    then return t else return nil;
end;
flag ('(type_ratpoly),'boolean);

symbolic procedure tttype_ratpoly(u,xx);
  ( if fixp xx then t else
        if not eqcar (xx , '!*sq) then  nil
          else and(polynomqqq(list(mk!*sq (numr cadr xx ./ 1),
                                  reval cadr u))
                 ,polynomqqq(list(mk!*sq (denr cadr xx ./ 1),
                                  reval cadr u)))
 ) where xx = aeval(car u);

flag ('(tttype_ratpoly),'boolean);





symbolic flag('(savesolve ),'opfn);

symbolic procedure savesolve (x,y);
<< switch solveinconsistent;
   on solveinconsistent;
   inconsistent!*:=nil;
   if pairp (x:=errorset!*(list ('solveeval,mkquote list(x,y)),nil))
        and not inconsistent!* and not (x = '((list)))
        then << x:=car x;
                if eqcar(cadr x,'equal) then % one element solution
                        list('list,x) else x>>
        else <> >>;


%checks if x is polynomial in var
symbolic procedure polynomq (x,var);

 if not fixp denr simp x then nil else
 begin scalar kerns,kern,aa;

 kerns:=kernels !*q2f simp x;

 aa: if null kerns then return t;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return nil else go aa;
end;

flag('(polynomq),'opfn);

flag ('(polynomq type_ratpoly),'boolean);



symbolic procedure polynomqqq (x);

(
 if not fixp denr (xx:=cadr aeval car x) then nil else
 begin scalar kerns,kern,aa,var;

 var:=reval cadr x;
 kerns:=kernels !*q2f xx;

 aa: if null kerns then return t;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return nil else go aa;
end) where xx = x;


put('polynomqq,'psopfn,'polynomqqq);

symbolic procedure polynomqqq (x);

(if fixp xx then t else
 if not onep denr (xx:=cadr xx) then nil
 else begin scalar kerns,kern,aa,var,fform,mvv,degg;

 fform:=sfp  mvar  numr xx;
 var:=reval cadr x;
 if fform then << xx:=numr xx;
    while (xx neq 1) do
     << mvv:=mvar  xx;
        degg:=ldeg  xx;
        xx:=lc  xx;
        if domainp mvv then <> >> else
        kerns:=append ( append (kernels mvv,kernels degg),kerns) >> >>
   else kerns:=kernels !*q2f xx;

 aa: if null kerns then return t;
     kern:=first kerns;
     kerns:=cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return nil else go aa;
end) where xx = aeval(car x);

put('polynomqq,'psopfn,'polynomqqq);

symbolic procedure ttttype_ratpoly(u);
  ( if fixp xx then t else
        if not eqcar (xx , '!*sq) then nil
          else and(polynomqqq(list(mk!*sq (numr cadr xx ./ 1),
                              reval cadr u)),
                   polynomqqq(list(mk!*sq (denr cadr xx ./ 1),
                              reval cadr u)))
 ) where xx = aeval(car u);

flag ('(type_ratpoly),'boolean);

put('type_ratpoly,'psopfn,'ttttype_ratpoly);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/sum.red0000644000175000017500000000520511526203062022612 0ustar  giovannigiovannimodule sum;  % Driver for various sum capabilities.

% Author: Anthony C. Hearn, derived from code by F. Kako and W. Koepf.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(sum sum2 complx prod),'(contrib sum));
% create!-package('(sum sum2 complx prod zeilberg),'(contrib sum));

fluid '(!*zeilberg);

switch zeilberg;

put('sum,'simpfn,'simp!-sum);

symbolic procedure freeof!-df(u, v);
   % check u contains differential operator with respect to v;
   if atom u then t
    else if car(u) eq 'df
     then freeof!-df(cadr u,v) and not smember(v,cddr u)
    else freeof!-dfl(cdr u,v);

symbolic procedure freeof!-dfl(u, v);
   if null u then t else freeof!-df(car u,v) and freeof!-dfl(cdr u,v);

symbolic procedure simp!-sum u;
   %ARGUMENT  CAR U: expression of prefix form.
   %         CADR U: kernel.
   %        CADDR U: lower bound.
   %       CADDDR U: upper bound.
   %value          : expression of sq form.
   begin scalar y;
      y := cdr u;
      u := car u;
      if not atom y and not freeof!-df(u, car y) then
        if atom y
               then return !*p2f(car fkern(list('sum,u)) .* 1) ./ 1
         else return sum!-df(u, y);
      u := simp!* u;
      return if null numr u then u
              else if atom y
               then !*p2f(car fkern(list('sum,prepsq u)) .* 1) ./ 1
              else if !*zeilberg then gosper!*(mk!*sq u,y)
              else simp!-sum0(u,y)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/complx.red0000644000175000017500000001316711526203062023316 0ustar  giovannigiovannimodule complx;
%                               Wed Dec. 17, 1986 by F. Kako;
%********************************************************************;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%******************************************************************
%*******        SPLIT REAL AND IMAGINARY PART    ******************
%******************************************************************


symbolic procedure real!-imag!-sq u;
%U is a standard quotient,
%Value is the standard quotient real part and imaginary part of U.
   begin scalar x,y;
      x := real!-imag!-f numr u;
      y := real!-imag!-f denr u;
      u := addf(multf(car y, car y),
                multf(cdr y, cdr y));         % Re Y **2 + Im Y **2;
      return (cancel(addf(multf(car x, car y),
                          multf(cdr x, cdr y))
                     ./ u) .
              cancel(addf(multf(car y, cdr x),
                          negf multf(car x, cdr y))
                     ./ u))
   end;

symbolic procedure real!-imag!-f u;
   %U is a standard form.
   %Value is the standard form real and imag part of U.
   begin scalar x;
      if domainp u then return u . nil;
      x := setkorder list 'i;
      u := reorder u;
      u := if mvar u eq 'i and ldeg u = 1 then red u . lc u
            else u . nil;
      setkorder x;
      return (reorder car u . reorder cdr u)
   end;

%*****************************************************************
%       hyperbolic functions
%*****************************************************************;

symbolic procedure real!-imag!-sincos u;
   begin scalar v,w,z;
      v := real!-imag!-sq u;
      if null cadr v then <<
                u := prepsq u;
                return simp!* list('sinh,u)
                        . simp!* list('cosh,u)>>
       else if null caar v then <<
                u := prepsq cdr v;
                return (multsq(!*k2q 'i, simp!* list('sin,u))
                         . simp!* list('cos,u))>>;
      u := prepsq cdr v;
      v := prepsq car v;
      w := simp!* list('cos,u);
      u := simp!* list('sin,u);
      u := multsq(!*k2q 'i,u);
      z := simp!* list('cosh,v);
      v := simp!* list('sinh,v);
      return (addsq (multsq(w, v), multsq(u,z)))
                . (addsq (multsq(w,z),multsq(u,v)))
   end;


% xxxxxxxxxxxxxxxxxxxxxxxx

%*********************************************************************
%       log and exponential term splitting for summation and product
%********************************************************************;


symbolic procedure sum!-split!-log(u,v);
   begin scalar x,y,z,lst,llst,mlst;
      lst := sum!-term!-split(u,v);
   a:
      if null lst then return (llst. mlst);
      u := car lst;
      lst := cdr lst;
      z := numr u;
      if domainp z or red z or not (tdeg (z := lt z) = 1) or
          atom tvar z or not ((car tvar z) eq 'log)
          or depend!-f(tc z,v) or depend!-f(denr u,v)
        then <>;
      y := reorder tc z ./ reorder denr u;
      z := simp!* cadr tvar z;
      if x := assoc(y,llst) then rplacd(x,multsq(cdr x,z))
       else if x := assoc(negsq y,llst)
             then rplacd(x,multsq(cdr x,invsq z))
       else llst := (y . z) . llst;
      go to a
   end;


symbolic procedure prod!-split!-exp(u,v);
   begin scalar x,y,z,w,klst,lst;
%     lst := kernels(numr u,nil);
      lst := kernels numr u;
%     lst := kernels1denr u,lst);
      lst := kernels1(denr u,lst);
   a:
      if null lst then go to b;
      z := car lst;
      if not atom z and car z eq 'expt and
         not depend!-p(cadr z,v) and depend!-p(caddr z,v)
        then klst := z . klst;
      lst := cdr lst;
      go to a;
   b:
      if null klst then return (nil . list u);
      x := setkorder klst;
      z := reorder numr u;
      y := reorder denr u;
   c:
      if domainp z or red z or not memq(w := mvar z,klst)
       then go to d;
      v := multsq(tdeg lt z ./ 1,simp!* caddr w);
      w := cadr w;
      if u := assoc(w,lst) then rplacd(u,addsq(cdr u,v))
       else lst := (w . v) . lst;
      z := tc lt z;
      go to c;
   d:
      if domainp y or red y or not memq(w := mvar y,klst)
       then go to e;
      v := multsq(tdeg lt y ./ 1,negsq simp!* caddr w);
      w := cadr w;
      if u := assoc(w,lst) then rplacd(u,addsq(cdr u,v))
       else lst := (w . v) . lst;
      y := tc lt y;
      go to d;
   e:
      setkorder x;
      u := reorder z ./ reorder y;
      return (lst . list u)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/zeilberg.tst0000644000175000017500000004167211526203062023661 0ustar  giovannigiovanni% Tests of the ZEILBERG package.

% Authors: Gregor Stoelting, Wolfram Koepf (koepf@zib-berlin.de)

load_package sum;
% on time;

% 1) Successful summations by the Gosper algorithm
% R. W. Gosper, Jr.:
% Decision procedure for indefinite hypergeometric summation,
% Proc. Nat. Acad. Sci. USA 75 (1978), 40-42.

gosper(k,k);
gosper(k^2,k);
gosper(k^3,k);
gosper(k^4,k);
gosper(k^5,k);
% gosper(k^20,k);
gosper((6*k+3)/(4*k^4+8*k^3+8*k^2+4*k+3),k);
% gosper(2^k*(k^3-3*k^2-3*k-1)/(k^3*(k+1)^3),k);
gosper(x*k,k);
gosper(k*x^k,k);
gosper(k*factorial(k),k);
gosper(1/(k^2-1),k);
gosper((1+2*k)/((1+k^2)*(k^2+2*k+2)),k);
gosper((k^2+4*k+1)*factorial(k),k);
gosper((4*k-3)*factorial(2*k-2)/factorial(k-1),k);
gosper(gamma(k+n+2)*n/((k+n+1)*gamma(k+2)*gamma(n+1)),k);
gosper((k+n)*factorial(k+n),k);
gosper((3*(1+2*k))/((1+k^2)*(2+2*k+k^2)),k);
% gosper((-25+15*k+18*k^2-2*k^3-k^4)/
% (-23+479*k+613*k^2+137*k^3+53*k^4+5*k^5+k^6),k);
% gosper(3^k*(2*k^4+4*k^3-7*k^2-k-4)/(k*(k+1)*(k^2+1)*((k+1)^2+1)),k);
gosper(3^k*(4*k^2-2*k-3)/((2*k+3)*(2*k+1)*(k+1)*k),k);
% gosper(2^k*(2*k^3+3*k^2-20*k-15)/
% ((2*k+3)*(2*k+1)*(k+5)*(k+4)*(k+1)*k),k);
% gosper(-2^k*((k+11)^2*(k+1)^2-2*(k+10)^2*k^2)/
% ((k+11)^2*(k+10)^2*(k+1)^2*k^2),k);
% gosper(-2^k*((k+6)^2*(k+1)^2-2*(k+5)^2*k^2)/
% ((k+6)^2*(k+5)^2*(k+1)^2*k^2),k);
% gosper(2^k*(k^4-14*k^2-24*k-9)/(k^2*(k+1)^2*(k+2)^2*(k+3)^2),k);
% gosper(((k^2-k-n^2-n-2)*gamma(k+n+2)*gamma(n+1))/
% (2*(-1)^k*2^k*(k+n+1)*gamma(-(k-n-1))*gamma(k+2)),k);
% gosper(1/(k+1)*binomial(2*k,k)/(n-k+1)*binomial(2*n-2*k,n-k),k);
gosper(3^k*(4*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k),k);
gosper(2^k*(k^2-2*k-1)/(k^2*(k+1)^2),k);
gosper((3*k^2+3*k+1)/(k^3*(k+1)^3),k);
gosper((6*k+3)/(4*k^4+8*k^3+8*k^2+4*k+3),k);
gosper(-(k^2+3*k+3)/(k^4+2*k^3-3*k^2-4*k+2),k);
gosper(k^2*4^k/((k+1)*(k+2)),k);
gosper((2*k-1)^3,k);
gosper(3*k^2+3*k+1,k);
gosper((k^2+4*k+2)*2^k,k);
% gosper(2^k*(k^3-3*k^2-3*k-1)/(k^3*(k+1)^3),k);
gosper(k*n^k,k);
% gosper(3^k*(2*k^3+k^2+3*k+6)/((k^2+2)*(k^2+2*k+3)),k);
% gosper(4*(1-k)*(k^2-2*k-1)/(k^2*(k+1)^2*(k-2)^2*(k-3)^2),k);
% gosper(2^k*(k^4-14*k^2-24*k-9)/(k^2*(k+1)^2*(k+2)^2*(k+3)^2),k);
gosper((1+k)/(1-k)+2/k,k);
gosper(1/(k*(k+1)),k);
gosper(1/(k*(k+2)),k);
gosper(1/(k*(k+10)),k);
% gosper(1/(k*(k+30)),k);
gosper(1/(k*(k+1)*(k+2)),k);
gosper(1/(k*(k+1)*(k+2)*(k+3)*(k+4)*(k+5)*(k+6)*(k+7)*(k+8)*(k+9)*
	  (k+10)),k);
gosper(pochhammer(k-n,n),k);
gosper((a+k-1)*pochhammer(a,k),k);
gosper((a-k-1)/pochhammer(a-k,k),k);
gosper(binomial(k,n),k); 
gosper(k*binomial(k,n),k);
% gosper(k^10*binomial(k,n),k);
gosper(1/binomial(k,n),k); 
gosper(k/binomial(k,n),k);
% gosper(k^10/binomial(k,n),k);
gosper(binomial(k-n,k),k);
gosper((-1)^k*binomial(n,k),k);
gosper((-1)^k/binomial(n,k),k);
gosper((-1)^(k+1)*(4*k+1)*factorial(2*k)/
(factorial(k)*4^k*(2*k-1)*factorial(k+1)),k);
% term:=3^k*(3*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k)$
% term:=sub(k=k+3,term)-term$
% gosper(term,k);
% clear(term);

% 2) Examples for the Wilf-Zeilberger method:
% H. S. Wilf and D. Zeilberger:
% Rational functions certify combinatorial identities. 
% J. Amer. Math. Soc. 3, 1990, 147-158.

% Binomial theorem
summand:=binomial(n,k)/2^n$
gosper(sub(n=n+1,summand)-summand,k);

% Vandermonde
summand:=binomial(n,k)^2/binomial(2*n,n)$
gosper(sub(n=n+1,summand)-summand,k);

% Gauss
% summand:=factorial(n+k)*factorial(b+k)*factorial(c-n-1)*factorial(c-b-1)
% /(factorial(n-1)*factorial(c-n-b-1)*factorial(k+1)*factorial(c+k)*
% factorial(b-1))$
% gosper(sub(n=n+1,summand)-summand,k);

% Kummer
% summand:=(-1)^(n+k)*factorial(2*n+c-1)*factorial(n)*factorial(n+c-1)/(
% factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*factorial(k))$
% gosper(sub(n=n+1,summand)-summand,k);

% Saalschuetz
% summand:=factorial(a+k-1)*factorial(b+k-1)*factorial(n)*
% factorial(n+c-a-b-k-1)*factorial(n+c-1)/(factorial(k)*factorial(n-k)*
% factorial(k+c-1)*factorial(n+c-a-1)*factorial(n+c-b-1))$
% gosper(sub(n=n+1,summand)-summand,k);

% Dixon
% summand:=(-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*binomial(b+c,b+k)*
% factorial(n)*factorial(b)*factorial(c)/factorial(n+b+c)$
% gosper(sub(n=n+1,summand)-summand,k);

% 3) Results from Gosper's original work
% R. W. Gosper, Jr.:
% Decision procedure for indefinite hypergeometric summation,
% Proc. Nat. Acad. Sci. USA 75 (1978), 40-42.

% ff(k)=product(a+b*j+c*j^2,j,1,k);
% gg(k)=product(e+b*j+c*j^2,j,1,k);

operator ff,gg;  

let {ff(~k+~m) => ff(k+m-1)*(c*(k+m)^2+b*(k+m)+a)
		     when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+a)
		when (fixp(m) and m<0)};

let {gg(~k+~m) => gg(k+m-1)*(c*(k+m)^2+b*(k+m)+e)
		     when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+e)
		when (fixp(m) and m<0)};

gosper(ff(k-1)/gg(k),k);
% gosper(ff(k-1)/gg(k+1),k);
% gosper(ff(k-1)/gg(k+2),k);

% ff(k)=product(a+b*j+c*j^2+d*j^3,j,1,k);
% gg(k)=product(e+b*j+c*j^2+d*j^3,j,1,k);

let {
ff(~k+~m) => ff(k+m-1)*(d*(k+m)^3+c*(k+m)^2+b*(k+m)+a)
		when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+a) 
when (fixp(m) and m<0)};

let {
gg(~k+~m) => gg(k+m-1)*(d*(k+m)^3+c*(k+m)^2+b*(k+m)+e)
		when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/(d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+e) 
when (fixp(m) and m<0)};

gosper(ff(k-1)/gg(k),k);
gosper(ff(k-1)/gg(k+1),k);
% Decision: no closed form solution exists 

% ff(k)=product(a+b*j+c*j^2+d*j^3+e*j^4,j,1,k);
% gg(k)=product(f+b*j+c*j^2+d*j^3+e*j^4,j,1,k);

let {
ff(~k+~m) => ff(k+m-1)*(e*(k+m)^4+d*(k+m)^3+c*(k+m)^2+b*(k+m)+a) 
when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(e*(k+m+1)^4+d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+a)
when (fixp(m) and m<0)};

let {
gg(~k+~m) => gg(k+m-1)*(e*(k+m)^4+d*(k+m)^3+c*(k+m)^2+b*(k+m)+f) 
when (fixp(m) and m>0),
gg(~k+~m) =>
   gg(k+m+1)/(e*(k+m+1)^4+d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+f)
      when (fixp(m) and m<0)};

gosper(ff(k-1)/gg(k),k);

% ff=product(j^3+b*j^2+c*j+(2*c-4*b+8),j,1,k);
% gg=product(j^3+b*j^2+c*j,j,1,k)

let {
ff(~k+~m) => ff(k+m-1)*((k+m)^3+c*(k+m)^2+b*(k+m)+(2*c-4*b+8)) 
when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/((k+m+1)^2+c*(k+m+1)^2+b*(k+m+1)+(2*c-4*b+8)) 
when (fixp(m) and m<0)};

let {
gg(~k+~m) => gg(k+m-1)*((k+m)^3+c*(k+m)^2+b*(k+m)+1)
		when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/((k+m+1)^2+c*(k+m+1)^2+b*(k+m+1)+1) 
when (fixp(m) and m<0)};

gosper(ff(k-1)/gg(k),k);

clear(ff,gg);

% 4) Examples for which gosper decides that no hypergeometric term
% antidifference exists

gosper(factorial(k),k);
gosper(factorial(2*k)/(factorial(k)*factorial(k+1)),k);
% gosper(1/(factorial(k)*(k^4+k^2+1)),k);
gosper(binomial(A,k),k);
gosper(1/k,k);
gosper((1+k)/(1-k),k);
% gosper(3^k*(3*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k),k);
gosper(factorial(k+n)*factorial(n)/
((-1)^k*factorial(n-k)*factorial(k)*2^k),k);
gosper(1/(k*(k+1/2)),k);
gosper(pochhammer(a,k),k);
gosper(binomial(n,k),k);

% 5) Finding recurrence equations for definite sums
% D. Zeilberger,
% A fast algorithm for proving terminating hypergeometric identities,
% Discrete Math. 80 (1990), 207-211.

sumrecursion(binomial(n,k),k,n);
sumrecursion(k*binomial(n,k),k,n);
% sumrecursion(
% (-1)^k*binomial(2*n,k)*binomial(2*k,k)*binomial(4*n-2*k,2*n-k),k,n);
sumrecursion(binomial(n,k)^2,k,n);
sumrecursion(binomial(n,k)^2/binomial(2*n,n),k,n);
% sumrecursion((-1)^k*binomial(n,k)^2,k,n);
% Gauss
sumrecursion(
factorial(n+k)*factorial(b+k)*factorial(c-n-1)*factorial(c-b-1),k,n);
sumrecursion(
pochhammer(a,k)*pochhammer(b,k)/(factorial(k)*pochhammer(c,k)),k,a);
% Kummer
sumrecursion((-1)^(n+k)*factorial(2*n+c-1)*factorial(n)*factorial(n+c-1)
/(factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*
   factorial(k)),k,n);
sumrecursion((-1)^k/(
factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*
   factorial(k)),k,n);
% Saalschuetz
% sumrecursion(factorial(a+k-1)*factorial(b+k-1)*factorial(n)*
% factorial(n+c-a-b-k-1)*factorial(n+c-1)/
% (factorial(k)*factorial(n-k)*factorial(k+c-1)*
% factorial(n+c-a-1)*factorial(n+c-b-1)),k,n);
sumrecursion(factorial(a+k-1)*factorial(b+k-1)*factorial(n+c-a-b-k-1)/(
factorial(k)*factorial(n-k)*factorial(k+c-1)),k,n);
% Dixon
% sumrecursion((-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*
%    binomial(b+c,b+k)*
% factorial(n)*factorial(b)*factorial(c)/factorial(n+b+c),k,n);
sumrecursion((-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*
   binomial(b+c,b+k),k,n);
sumrecursion((-1)^(k-n)*binomial(2*n,k)^3,k,n);
sumrecursion(
(-1)^(k-n)*binomial(2*n,k)^3/(binomial(3*n,n)*binomial(2*n,n)),k,n);
% Clausen
% summand:=factorial(a+k-1)*factorial(b+k-1)/
% (factorial(k)*factorial(-1/2+a+b+k))*factorial(a+n-k-1)*
%     factorial(b+n-k-1)/(factorial(n-k)*factorial(-1/2+a+b+n-k))$
% sumrecursion(summand,k,n);
% Dougall
% summand:=
% pochhammer(d,k)*pochhammer(1+d/2,k)*pochhammer(d+b-a,k)*
%   pochhammer(d+c-a,k)*
% pochhammer(1+a-b-c,k)*pochhammer(n+a,k)*pochhammer(-n,k)/
%    (factorial(k)*
% pochhammer(d/2,k)*pochhammer(1+a-b,k)*pochhammer(1+a-c,k)*
% pochhammer(b+c+d-a,k)*pochhammer(1+d-a-n,k)*pochhammer(1+d+n,k))$
% sumrecursion(summand,k,n);
% Apery
sumrecursion(binomial(n,k)^2*binomial(n+k,k)^2,k,n);
% sumrecursion(4*(-1)^k*binomial(m-1,k)*binomial(2*m-1,2*k)/
% binomial(4*m-1,4*k)*(4*m^2+16*k^2-16*k*m+16*k-6*m+3)/
% ((4*m-4*k-3)*(4*m-4*k-1)),k,m);
sumrecursion((-1)^k*binomial(n,k)*binomial(k,n),k,n);
sumrecursion((-1)^k*binomial(n,k)*binomial(2*k,n),k,n);
sumrecursion((-1)^k*binomial(n,k)*binomial(k,j)^2,k,n);
sumrecursion(binomial(n,k)*binomial(a,k),k,n);
sumrecursion((3*k-2*n)*binomial(n,k)^2*binomial(2*k,k),k,n);
sumrecursion(binomial(n-k,k),k,n);
sumrecursion(binomial(n,k)*binomial(n+k,k),k,n);
% sumrecursion(binomial(n+k,m+2*k)*binomial(2*k,k)*(-1)^k/(k+1),k,n);
sumrecursion((-1)^k*binomial(n-k,k)*binomial(n-2*k,m-k),k,n);
% sumrecursion((-1)^k*binomial(n-k,k)*binomial(n-2*k,m-k),k,m);
sumrecursion(binomial(n+k,2*k)*2^(n-k),k,n);
sumrecursion(binomial(n,k)*binomial(2*k,k)*(-1/4)^k,k,n);
% sumrecursion(binomial(n,i)*binomial(2*n,n-i),i,n);
sumrecursion((-1)^k*binomial(n,k)*binomial(2*k,k)*4^(n-k),k,n);
sumrecursion((-1)^k*binomial(n,k)/binomial(k+a,k),k,n);
% sumrecursion((-1)^k*binomial(n,k)/binomial(k+a,k),k,a);
sumrecursion((-1)^(n-k)*binomial(2*n,k)^2,k,n);
sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
factorial(k+1)*factorial(n-k)*factorial(k+c)),k,a);
% sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
% factorial(k+1)*factorial(n-k)*factorial(k+c)),k,b);
% sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
% factorial(k+1)*factorial(n-k)*factorial(k+c)),k,c);
sumrecursion(binomial(2*n+1,2*p+2*k+1)*binomial(p+k,k),k,n);
% sumrecursion(binomial(2*n+1,2*p+2*k+1)*binomial(p+k,k),k,p);
sumrecursion(binomial(r,m)*binomial(s,t-m),m,r);
% sumrecursion(binomial(r,m)*binomial(s,t-m),m,s);
% sumrecursion(binomial(r,m)*binomial(s,t-m),m,t);
sumrecursion(binomial(2*n+1,2*k)*binomial(m+k,2*n),k,n);
% sumrecursion(binomial(2*n+1,2*k)*binomial(m+k,2*n),k,m);
sumrecursion(binomial(n,k)*binomial(k,j)*x^j,k,n);
% sumrecursion(binomial(n,k)*binomial(k,j)*x^j,k,j);
% sumrecursion(binomial(n,k)*binomial(k,j)*x^k,k,n);
sumrecursion(x*binomial(n+k,2*k)*((x^2-1)/4)^(n-k),k,n);
sumrecursion(binomial(n+k-1,2*k-1)*(x-1)^(2*k)*x^(n-k)/k,k,n);
sumrecursion(
1/(k+1)*binomial(2*k,k)/(n-k+1)*binomial(2*n-2*k,n-k),k,n);
sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,m);
% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,n);
% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,q);
% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,r);
sumrecursion(pochhammer(-n/2,k)*pochhammer(-n/2+1/2,k)/
(factorial(k)*pochhammer(b+1/2,k)),k,n);
% Watson
% sumrecursion(pochhammer(a,k)*pochhammer(b,k)*pochhammer(c,k)/(
% factorial(k)*pochhammer(1/2*(a+b+1),k)*pochhammer(2*c,k)),k,c);
% sumrecursion(pochhammer(-m,j)*pochhammer(m+2*k+2,j)*pochhammer(k+1/2,j)/
% (factorial(j)*pochhammer(k+3/2,j)*pochhammer(2*k+1,j)),j,k);
sumrecursion((-1)^k*binomial(n,k)^3,k,n);
% sumrecursion(pochhammer(-n,k)*pochhammer(n+2*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(2*a/2,k)*pochhammer((2*a+1)/2,k))*(2/4)^k,k,n);
% sumrecursion(pochhammer(-n,k)*pochhammer(n+4*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(4*a/2,k)*pochhammer((4*a+1)/2,k))*(4/4)^k,k,n);
% sumrecursion(binomial(n+k+1,n-k)*pochhammer(-n+k,j)*pochhammer(k+1/2,j)*
% pochhammer(n+k+2,j)/(factorial(j)*pochhammer(k+3/2,j)*
%    pochhammer(2*k+1,j)),j,n);
% sumrecursion(pochhammer(-m,j)*pochhammer(m+2*k+2,j)*
%    pochhammer(k+1/2,j)/(
% factorial(j)*pochhammer(k+3/2,j)*pochhammer(2*k+1,j)),j,m);
% sumrecursion(binomial(n+k+1,n-k)*pochhammer(-n+k,j)*
%   pochhammer(k+1/2,j)*
% pochhammer(n+k+2,j)/(factorial(j)*pochhammer(k+3/2,j)*
%   pochhammer(2*k+1,j)),
% j,k);
% sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
% (factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
%   pochhammer(b-n/2+1,l)),j,a);
% sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
% (factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
%   pochhammer(b-n/2+1,l)),j,b);
sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
(factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
   pochhammer(b-n/2+1,l)),j,c);
% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%    gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,a);
% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%  gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,b);
% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%  gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,c);
% sumrecursion(pochhammer(-n,k)*pochhammer(n+3*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(3*a/2,k)*
%    pochhammer((3*a+1)/2,k))*(3/4)^k,k,n);
% summand:=k*(-1)^j*pochhammer(2*k+j+1,j)*pochhammer(2*k+2*j+2,n-k-j)/(
% factorial(k+j)*factorial(j)*factorial(n-k-j))*exp(-(j+k)*t)$
% summand:=k*(-1)^j*pochhammer(2*k+j+1,j)*pochhammer(2*k+2*j+2,n-k-j)/(
% (k+j)*factorial(j)*factorial(n-k-j))*exp(-(j+k)*t)$
% sumrecursion(summand,j,n);
clear(summand);

% 6) Finding recurrence equations for hypergeometric functions
% Koornwinder, T. H.:
% On Zeilberger's algorithm and
% its q-analogue: a rigorous description.
% J. of Comput. and Appl. Math. 48, 1993, 91-111.

% Gauss
hyperrecursion({a,b},{c},1,a);
% Dougall
% hyperrecursion({d,1+d/2,d+b-a,d+c-a,1+a-b-c,n+a,-n},
%               {d/2,1+a-b,1+a-c,b+c+d-a,1+d-a-n,1+d+n},1,n);
% Baxter
% hyperrecursion({-n,-n-1,-n-2},{2,3},-1,n);
% Krawtchouk polynomials
% krawtchoukterm :=
%    (-1)^n*p^n*binomial(NN,n)*hyperterm({-n,-x},{-NN},1/p,k)$
% sumrecursion(krawtchoukterm,k,n);
% sumrecursion(krawtchoukterm,k,x);
% sumrecursion(krawtchoukterm,k,NN);
% clear(krawtchoukterm);
% hyperrecursion({-n,b,c+4},{b+1,c},1,n);
hyperrecursion({-n,b,c+1,d+1},{b+1,c,d},1,n);

% 7) Extended versions of Gosper's and Zeilberger's algorithms
% Koepf, W.:
% Algorithms for the indefinite and definite summation.
% Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-33, 1994.

% extended Gosper algorithm
extended_gosper(k*factorial(k/7),k,7);
extended_gosper(k*factorial(k/2),k,2);
extended_gosper(k*factorial(k/2),k);
extended_gosper(binomial(k/2,n),k);
extended_gosper(binomial(n,k/2)-binomial(n,k/2-1),k);

% extended Zeilberger algorithm
% extended_sumrecursion(binomial(n,k)*binomial(k/2,n),k,n,1,2);
sumrecursion(binomial(n,k)*binomial(k/2,n),k,n);
extended_sumrecursion(binomial(n/2,k),k,n,2,1);
sumrecursion(binomial(n/2,k),k,n);
% sumrecursion(hyperterm({a,b,a+1/2-b,1+2*a/3,-n},
% {2*a+1-2*b,2*b,2/3*a,1+a+n/2},4,k)/
% (factorial(n)*2^(-n)/factorial(n/2))/
% hyperterm({a+1,1},{a-b+1,b+1/2},1,n/2),k,n);

% Watson
% sumrecursion(pochhammer(a,k)*pochhammer(b,k)*pochhammer(c,k)/(
% factorial(k)*pochhammer(1/2*(a+b+1),k)*pochhammer(2*c,k))/
% (GAMMA(1/2)*GAMMA(1/2+c)*GAMMA(1/2+a/2+b/2)*GAMMA(1/2-a/2-b/2+c))*
% GAMMA(1/2+a/2)*GAMMA(1/2+b/2)*GAMMA(1/2-a/2+c)*GAMMA(1/2-b/2+c),k,a);
% hyperrecursion({a,b,c},{1/2*(a+b+1),2*c},1,a);
% hyperrecursion({a,b,c},{1/2*(a+b+1),2*c},1,b);

% 8) Closed form representations of hypergeometric sums

% Vandermonde
hypersum({-n,b},{c},1,n);
% Saalschuetz
hypersum({a,b,-n},{c,1+a+b-c-n},1,n);
% Kummer
hypersum({a,-n},{1+a+n},-1,n);
% Dixon
hypersum({a,b,-n},{1+a-b,1+a+n},1,n);
% Dougall
% hypersum({a,1+a/2,b,c,d,1+2*a-b-c-d+n,-n},
% {a/2,1+a-b,1+a-c,1+a-d,1+a-(1+2*a-b-c-d+n),1+a+n},1,n);
% Clausen
% hypersum({a,b,1/2-a-b-n,-n},{1/2+a+b,1-a-n,1-b-n},1,n);

hypersum({a,1+a/2,c,d,-n},{a/2,1+a-c,1+a-d,1+a+n},1,n);
hypersum({a,1+a/2,d,-n},{a/2,1+a-d,1+a+n},-1,n);

% m-fold case:
hypersum({-n,-n,-n},{1,1},1,n);
% hypersum({-n,n+3*a,a},{3*a/2,(3*a+1)/2},3/4,n);

% 9) Hypergeometric representations

sumtohyper(binomial(n,k)^3,k);
sumtohyper(binomial(n,k)/2^n-sub(n=n-1,binomial(n,k)/2^n),k);
sumtohyper(binomial(k+j-1,k-j)*2*(-1)^(j+1)*factorial(2*j-1)/         
factorial(j-1)/factorial(j+1)*x^j,j);
% term:=1/(n-1+k)*(1/2-1/2*x)^k/n*binomial(k-n-1,-n-1)*k*
%         binomial(n-1+k,n-1);
% sumtohyper(sub(n=n+1,term)-term,k);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/zeilberg.rlg0000644000175000017500000006460511527635055023650 0ustar  giovannigiovanniFri Feb 18 21:28:31 2011 run on win32
% Tests of the ZEILBERG package.

% Authors: Gregor Stoelting, Wolfram Koepf (koepf@zib-berlin.de)

load_package sum;


% on time;

% 1) Successful summations by the Gosper algorithm
% R. W. Gosper, Jr.:
% Decision procedure for indefinite hypergeometric summation,
% Proc. Nat. Acad. Sci. USA 75 (1978), 40-42.

gosper(k,k);


 (k + 1)*k
-----------
     2

gosper(k^2,k);


 (2*k + 1)*(k + 1)*k
---------------------
          6

gosper(k^3,k);


        2  2
 (k + 1) *k
-------------
      4

gosper(k^4,k);


     2
 (3*k  + 3*k - 1)*(2*k + 1)*(k + 1)*k
--------------------------------------
                  30

gosper(k^5,k);


     2                   2  2
 (2*k  + 2*k - 1)*(k + 1) *k
------------------------------
              12

% gosper(k^20,k);
gosper((6*k+3)/(4*k^4+8*k^3+8*k^2+4*k+3),k);


   (k + 2)*k
----------------
    2
 2*k  + 4*k + 3

% gosper(2^k*(k^3-3*k^2-3*k-1)/(k^3*(k+1)^3),k);
gosper(x*k,k);


 (k + 1)*k*x
-------------
      2

gosper(k*x^k,k);


  k
 x *((x - 1)*k - 1)*x
----------------------
              2
       (x - 1)

gosper(k*factorial(k),k);


(k + 1)*factorial(k)

gosper(1/(k^2-1),k);


     2
  2*k  - 1
-------------
 2*(k + 1)*k

gosper((1+2*k)/((1+k^2)*(k^2+2*k+2)),k);


    (k + 2)*k
------------------
     2
 2*(k  + 2*k + 2)

gosper((k^2+4*k+1)*factorial(k),k);


(k + 4)*(k + 1)*factorial(k)

gosper((4*k-3)*factorial(2*k-2)/factorial(k-1),k);


 2*(2*k - 1)*factorial(2*(k - 1))
----------------------------------
         factorial(k - 1)

gosper(gamma(k+n+2)*n/((k+n+1)*gamma(k+2)*gamma(n+1)),k);


     gamma(n + 2 + k)
---------------------------
 gamma(k + 2)*gamma(n + 1)

gosper((k+n)*factorial(k+n),k);


(n + 1 + k)*factorial(k + n)

gosper((3*(1+2*k))/((1+k^2)*(2+2*k+k^2)),k);


   3*(k + 2)*k
------------------
     2
 2*(k  + 2*k + 2)

% gosper((-25+15*k+18*k^2-2*k^3-k^4)/
% (-23+479*k+613*k^2+137*k^3+53*k^4+5*k^5+k^6),k);
% gosper(3^k*(2*k^4+4*k^3-7*k^2-k-4)/(k*(k+1)*(k^2+1)*((k+1)^2+1)),k);
gosper(3^k*(4*k^2-2*k-3)/((2*k+3)*(2*k+1)*(k+1)*k),k);


          k
       3*3
-------------------
 (2*k + 3)*(k + 1)

% gosper(2^k*(2*k^3+3*k^2-20*k-15)/
% ((2*k+3)*(2*k+1)*(k+5)*(k+4)*(k+1)*k),k);
% gosper(-2^k*((k+11)^2*(k+1)^2-2*(k+10)^2*k^2)/
% ((k+11)^2*(k+10)^2*(k+1)^2*k^2),k);
% gosper(-2^k*((k+6)^2*(k+1)^2-2*(k+5)^2*k^2)/
% ((k+6)^2*(k+5)^2*(k+1)^2*k^2),k);
% gosper(2^k*(k^4-14*k^2-24*k-9)/(k^2*(k+1)^2*(k+2)^2*(k+3)^2),k);
% gosper(((k^2-k-n^2-n-2)*gamma(k+n+2)*gamma(n+1))/
% (2*(-1)^k*2^k*(k+n+1)*gamma(-(k-n-1))*gamma(k+2)),k);
% gosper(1/(k+1)*binomial(2*k,k)/(n-k+1)*binomial(2*n-2*k,n-k),k);
gosper(3^k*(4*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k),k);


             k
          3*3
-------------------------
 (2*(k + 1) + a)*(k + 1)

gosper(2^k*(k^2-2*k-1)/(k^2*(k+1)^2),k);


      k
   2*2
----------
        2
 (k + 1)

gosper((3*k^2+3*k+1)/(k^3*(k+1)^3),k);


   2
 (k  + 3*k + 3)*k
------------------
            3
     (k + 1)

gosper((6*k+3)/(4*k^4+8*k^3+8*k^2+4*k+3),k);


   (k + 2)*k
----------------
    2
 2*k  + 4*k + 3

gosper(-(k^2+3*k+3)/(k^4+2*k^3-3*k^2-4*k+2),k);


 (2*k + 5)*k
--------------
  2
 k  + 2*k - 1

gosper(k^2*4^k/((k+1)*(k+2)),k);


    k
 4*4 *(k - 1)
--------------
  3*(k + 2)

gosper((2*k-1)^3,k);


    2       2
(2*k  - 1)*k

gosper(3*k^2+3*k+1,k);


  2
(k  + 3*k + 3)*k

gosper((k^2+4*k+2)*2^k,k);


   k        2
2*2 *(k + 1)

% gosper(2^k*(k^3-3*k^2-3*k-1)/(k^3*(k+1)^3),k);
gosper(k*n^k,k);


  k
 n *((n - 1)*k - 1)*n
----------------------
              2
       (n - 1)

% gosper(3^k*(2*k^3+k^2+3*k+6)/((k^2+2)*(k^2+2*k+3)),k);
% gosper(4*(1-k)*(k^2-2*k-1)/(k^2*(k+1)^2*(k-2)^2*(k-3)^2),k);
% gosper(2^k*(k^4-14*k^2-24*k-9)/(k^2*(k+1)^2*(k+2)^2*(k+3)^2),k);
gosper((1+k)/(1-k)+2/k,k);


      2
  - (k  - 2)
-------------
      k

gosper(1/(k*(k+1)),k);


   k
-------
 k + 1

gosper(1/(k*(k+2)),k);


    (3*k + 5)*k
-------------------
 4*(k + 2)*(k + 1)

gosper(1/(k*(k+10)),k);


        9           8            7              6              5               4
((7381*k  + 380755*k  + 8495520*k  + 107353950*k  + 844356513*k  + 4272540195*k

                  3                2
   + 13854467330*k  + 27627865100*k  + 30558324456*k + 14171968800)*k)/(25200

   *(k + 10)*(k + 9)*(k + 8)*(k + 7)*(k + 6)*(k + 5)*(k + 4)*(k + 3)*(k + 2)

   *(k + 1))

% gosper(1/(k*(k+30)),k);
gosper(1/(k*(k+1)*(k+2)),k);


     (k + 3)*k
-------------------
 4*(k + 2)*(k + 1)

gosper(1/(k*(k+1)*(k+2)*(k+3)*(k+4)*(k+5)*(k+6)*(k+7)*(k+8)*(k+9)*
	  (k+10)),k);


   8       7        6         5          4           3           2
((k  + 44*k  + 836*k  + 8954*k  + 59279*k  + 249986*k  + 667084*k  + 1071576*k

   + 966240)*(k + 11)*k)/(36288000*(k + 10)*(k + 9)*(k + 8)*(k + 7)*(k + 6)

   *(k + 5)*(k + 4)*(k + 3)*(k + 2)*(k + 1))

gosper(pochhammer(k-n,n),k);


 pochhammer(k - n,n)*k
-----------------------
         n + 1

gosper((a+k-1)*pochhammer(a,k),k);


(a + k)*pochhammer(a,k)

gosper((a-k-1)/pochhammer(a-k,k),k);


         - 1
---------------------
 pochhammer(a - k,k)

gosper(binomial(k,n),k);


 (k + 1)*binomial(k,n)
-----------------------
         n + 1
 
gosper(k*binomial(k,n),k);


 (k*n + k + n)*(k + 1)*binomial(k,n)
-------------------------------------
           (n + 2)*(n + 1)

% gosper(k^10*binomial(k,n),k);
gosper(1/binomial(k,n),k);


       n - 1 - k
-----------------------
 (n - 1)*binomial(k,n)
 
gosper(k/binomial(k,n),k);


     (n - 1 - k)*k
-----------------------
 (n - 2)*binomial(k,n)

% gosper(k^10/binomial(k,n),k);
gosper(binomial(k-n,k),k);


 (n - 1 - k)*binomial(k - n,k)
-------------------------------
             n - 1

gosper((-1)^k*binomial(n,k),k);


          k
  - ( - 1) *(k - n)*binomial(n,k)
----------------------------------
                n

gosper((-1)^k/binomial(n,k),k);


          k
    ( - 1) *(k + 1)
-----------------------
 (n + 2)*binomial(n,k)

gosper((-1)^(k+1)*(4*k+1)*factorial(2*k)/
(factorial(k)*4^k*(2*k-1)*factorial(k+1)),k);


             k
     - ( - 1) *factorial(2*k)
----------------------------------
  k
 4 *factorial(k + 1)*factorial(k)

% term:=3^k*(3*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k)$
% term:=sub(k=k+3,term)-term$
% gosper(term,k);
% clear(term);

% 2) Examples for the Wilf-Zeilberger method:
% H. S. Wilf and D. Zeilberger:
% Rational functions certify combinatorial identities. 
% J. Amer. Math. Soc. 3, 1990, 147-158.

% Binomial theorem
summand:=binomial(n,k)/2^n$


gosper(sub(n=n+1,summand)-summand,k);


 (n + 1 - k)*(binomial(n + 1,k) - 2*binomial(n,k))
---------------------------------------------------
                   n
                2*2 *(n + 1 - 2*k)


% Vandermonde
summand:=binomial(n,k)^2/binomial(2*n,n)$


gosper(sub(n=n+1,summand)-summand,k);


                   2                                                          2
((binomial(n + 1,k) *binomial(2*n,n) - binomial(2*(n + 1),n + 1)*binomial(n,k) )

                             2
 *(2*k - 3*n - 1)*(k - n - 1) )/(

                                                     2
   (2*(2*(n + 1) - k)*(2*n + 1)*k - (3*n + 1)*(n + 1) )

   *binomial(2*(n + 1),n + 1)*binomial(2*n,n))


% Gauss
% summand:=factorial(n+k)*factorial(b+k)*factorial(c-n-1)*factorial(c-b-1)
% /(factorial(n-1)*factorial(c-n-b-1)*factorial(k+1)*factorial(c+k)*
% factorial(b-1))$
% gosper(sub(n=n+1,summand)-summand,k);

% Kummer
% summand:=(-1)^(n+k)*factorial(2*n+c-1)*factorial(n)*factorial(n+c-1)/(
% factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*factorial(k))$
% gosper(sub(n=n+1,summand)-summand,k);

% Saalschuetz
% summand:=factorial(a+k-1)*factorial(b+k-1)*factorial(n)*
% factorial(n+c-a-b-k-1)*factorial(n+c-1)/(factorial(k)*factorial(n-k)*
% factorial(k+c-1)*factorial(n+c-a-1)*factorial(n+c-b-1))$
% gosper(sub(n=n+1,summand)-summand,k);

% Dixon
% summand:=(-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*binomial(b+c,b+k)*
% factorial(n)*factorial(b)*factorial(c)/factorial(n+b+c)$
% gosper(sub(n=n+1,summand)-summand,k);

% 3) Results from Gosper's original work
% R. W. Gosper, Jr.:
% Decision procedure for indefinite hypergeometric summation,
% Proc. Nat. Acad. Sci. USA 75 (1978), 40-42.

% ff(k)=product(a+b*j+c*j^2,j,1,k);
% gg(k)=product(e+b*j+c*j^2,j,1,k);

operator ff,gg;

  

let {ff(~k+~m) => ff(k+m-1)*(c*(k+m)^2+b*(k+m)+a)
		     when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+a)
		when (fixp(m) and m<0)};



let {gg(~k+~m) => gg(k+m-1)*(c*(k+m)^2+b*(k+m)+e)
		     when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+e)
		when (fixp(m) and m<0)};



gosper(ff(k-1)/gg(k),k);


     ff(k)
---------------
 (a - e)*gg(k)

% gosper(ff(k-1)/gg(k+1),k);
% gosper(ff(k-1)/gg(k+2),k);

% ff(k)=product(a+b*j+c*j^2+d*j^3,j,1,k);
% gg(k)=product(e+b*j+c*j^2+d*j^3,j,1,k);

let {
ff(~k+~m) => ff(k+m-1)*(d*(k+m)^3+c*(k+m)^2+b*(k+m)+a)
		when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+a) 
when (fixp(m) and m<0)};



let {
gg(~k+~m) => gg(k+m-1)*(d*(k+m)^3+c*(k+m)^2+b*(k+m)+e)
		when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/(d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+e) 
when (fixp(m) and m<0)};



gosper(ff(k-1)/gg(k),k);


     ff(k)
---------------
 (a - e)*gg(k)

gosper(ff(k-1)/gg(k+1),k);


***** Gosper algorithm: no closed form solution exists 

% Decision: no closed form solution exists 

% ff(k)=product(a+b*j+c*j^2+d*j^3+e*j^4,j,1,k);
% gg(k)=product(f+b*j+c*j^2+d*j^3+e*j^4,j,1,k);

let {
ff(~k+~m) => ff(k+m-1)*(e*(k+m)^4+d*(k+m)^3+c*(k+m)^2+b*(k+m)+a) 
when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/(e*(k+m+1)^4+d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+a)
when (fixp(m) and m<0)};



let {
gg(~k+~m) => gg(k+m-1)*(e*(k+m)^4+d*(k+m)^3+c*(k+m)^2+b*(k+m)+f) 
when (fixp(m) and m>0),
gg(~k+~m) =>
   gg(k+m+1)/(e*(k+m+1)^4+d*(k+m+1)^3+c*(k+m+1)^2+b*(k+m+1)+f)
      when (fixp(m) and m<0)};



gosper(ff(k-1)/gg(k),k);


     ff(k)
---------------
 (a - f)*gg(k)


% ff=product(j^3+b*j^2+c*j+(2*c-4*b+8),j,1,k);
% gg=product(j^3+b*j^2+c*j,j,1,k)

let {
ff(~k+~m) => ff(k+m-1)*((k+m)^3+c*(k+m)^2+b*(k+m)+(2*c-4*b+8)) 
when (fixp(m) and m>0),
ff(~k+~m) => ff(k+m+1)/((k+m+1)^2+c*(k+m+1)^2+b*(k+m+1)+(2*c-4*b+8)) 
when (fixp(m) and m<0)};



let {
gg(~k+~m) => gg(k+m-1)*((k+m)^3+c*(k+m)^2+b*(k+m)+1)
		when (fixp(m) and m>0),
gg(~k+~m) => gg(k+m+1)/((k+m+1)^2+c*(k+m+1)^2+b*(k+m+1)+1) 
when (fixp(m) and m<0)};



gosper(ff(k-1)/gg(k),k);


         ff(k)
-----------------------
 (2*c + 7 - 4*b)*gg(k)


clear(ff,gg);



% 4) Examples for which gosper decides that no hypergeometric term
% antidifference exists

gosper(factorial(k),k);


***** Gosper algorithm: no closed form solution exists 

gosper(factorial(2*k)/(factorial(k)*factorial(k+1)),k);


***** Gosper algorithm: no closed form solution exists 

% gosper(1/(factorial(k)*(k^4+k^2+1)),k);
gosper(binomial(A,k),k);


***** Gosper algorithm: no closed form solution exists 

gosper(1/k,k);


***** Gosper algorithm: no closed form solution exists 

gosper((1+k)/(1-k),k);


***** Gosper algorithm: no closed form solution exists 

% gosper(3^k*(3*k^2+2*a*k-4*k-2-a)/((2*k+2+a)*(2*k+a)*(k+1)*k),k);
gosper(factorial(k+n)*factorial(n)/
((-1)^k*factorial(n-k)*factorial(k)*2^k),k);


***** Gosper algorithm: no closed form solution exists 

gosper(1/(k*(k+1/2)),k);


***** Gosper algorithm: no closed form solution exists 

gosper(pochhammer(a,k),k);


***** Gosper algorithm: no closed form solution exists 

gosper(binomial(n,k),k);


***** Gosper algorithm: no closed form solution exists 


% 5) Finding recurrence equations for definite sums
% D. Zeilberger,
% A fast algorithm for proving terminating hypergeometric identities,
% Discrete Math. 80 (1990), 207-211.

sumrecursion(binomial(n,k),k,n);


2*summ(n - 1) - summ(n)

sumrecursion(k*binomial(n,k),k,n);


recursion valid for n>=2

(n - 1)*summ(n) - 2*summ(n - 1)*n

% sumrecursion(
% (-1)^k*binomial(2*n,k)*binomial(2*k,k)*binomial(4*n-2*k,2*n-k),k,n);
sumrecursion(binomial(n,k)^2,k,n);


2*(2*n - 1)*summ(n - 1) - summ(n)*n

sumrecursion(binomial(n,k)^2/binomial(2*n,n),k,n);


summ(n - 1) - summ(n)

% sumrecursion((-1)^k*binomial(n,k)^2,k,n);
% Gauss
sumrecursion(
factorial(n+k)*factorial(b+k)*factorial(c-n-1)*factorial(c-b-1),k,n);


 - ((n - 1 - c)*(c - n)*summ(n) + summ(n - 2))

 + (n - 1 - b)*(n - 1 - c)*summ(n - 1)

sumrecursion(
pochhammer(a,k)*pochhammer(b,k)/(factorial(k)*pochhammer(c,k)),k,a);


(b - c + a)*summ(a) - (a - c)*summ(a - 1)

% Kummer
sumrecursion((-1)^(n+k)*factorial(2*n+c-1)*factorial(n)*factorial(n+c-1)
/(factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*
   factorial(k)),k,n);


summ(n - 1) - summ(n)

sumrecursion((-1)^k/(
factorial(2*n+c-1-k)*factorial(2*n-k)*factorial(c+k-1)*
   factorial(k)),k,n);


(2*n - 1 + c)*(2*(n - 1) + c)*(n - 1 + c)*summ(n)*n + summ(n - 1)

% Saalschuetz
% sumrecursion(factorial(a+k-1)*factorial(b+k-1)*factorial(n)*
% factorial(n+c-a-b-k-1)*factorial(n+c-1)/
% (factorial(k)*factorial(n-k)*factorial(k+c-1)*
% factorial(n+c-a-1)*factorial(n+c-b-1)),k,n);
sumrecursion(factorial(a+k-1)*factorial(b+k-1)*factorial(n+c-a-b-k-1)/(
factorial(k)*factorial(n-k)*factorial(k+c-1)),k,n);


 - (n - 1 + c - a)*(n - 1 + c - b)*summ(n - 1) + (n - 1 + c)*summ(n)*n

% Dixon
% sumrecursion((-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*
%    binomial(b+c,b+k)*
% factorial(n)*factorial(b)*factorial(c)/factorial(n+b+c),k,n);
sumrecursion((-1)^k*binomial(n+b,n+k)*binomial(n+c,c+k)*
   binomial(b+c,b+k),k,n);


(c + n + b)*summ(n - 1) - summ(n)*n

sumrecursion((-1)^(k-n)*binomial(2*n,k)^3,k,n);


                                             2
3*(3*n - 1)*(3*n - 2)*summ(n - 1) - summ(n)*n

sumrecursion(
(-1)^(k-n)*binomial(2*n,k)^3/(binomial(3*n,n)*binomial(2*n,n)),k,n);


summ(n - 1) - summ(n)

% Clausen
% summand:=factorial(a+k-1)*factorial(b+k-1)/
% (factorial(k)*factorial(-1/2+a+b+k))*factorial(a+n-k-1)*
%     factorial(b+n-k-1)/(factorial(n-k)*factorial(-1/2+a+b+n-k))$
% sumrecursion(summand,k,n);
% Dougall
% summand:=
% pochhammer(d,k)*pochhammer(1+d/2,k)*pochhammer(d+b-a,k)*
%   pochhammer(d+c-a,k)*
% pochhammer(1+a-b-c,k)*pochhammer(n+a,k)*pochhammer(-n,k)/
%    (factorial(k)*
% pochhammer(d/2,k)*pochhammer(1+a-b,k)*pochhammer(1+a-c,k)*
% pochhammer(b+c+d-a,k)*pochhammer(1+d-a-n,k)*pochhammer(1+d+n,k))$
% sumrecursion(summand,k,n);
% Apery
sumrecursion(binomial(n,k)^2*binomial(n+k,k)^2,k,n);


           3                        3
 - ((n - 1) *summ(n - 2) + summ(n)*n )

        2
 + (17*n  - 17*n + 5)*(2*n - 1)*summ(n - 1)

% sumrecursion(4*(-1)^k*binomial(m-1,k)*binomial(2*m-1,2*k)/
% binomial(4*m-1,4*k)*(4*m^2+16*k^2-16*k*m+16*k-6*m+3)/
% ((4*m-4*k-3)*(4*m-4*k-1)),k,m);
sumrecursion((-1)^k*binomial(n,k)*binomial(k,n),k,n);


summ(n - 1) + summ(n)

sumrecursion((-1)^k*binomial(n,k)*binomial(2*k,n),k,n);


2*summ(n - 1) + summ(n)

sumrecursion((-1)^k*binomial(n,k)*binomial(k,j)^2,k,n);


                                     2
(n - 1 - 2*j)*summ(n - 1)*n - (j - n) *summ(n)

sumrecursion(binomial(n,k)*binomial(a,k),k,n);


(a + n)*summ(n - 1) - summ(n)*n

sumrecursion((3*k-2*n)*binomial(n,k)^2*binomial(2*k,k),k,n);


summ(n - 1) - summ(n)

sumrecursion(binomial(n-k,k),k,n);


summ(n - 1) - summ(n) + summ(n - 2)

sumrecursion(binomial(n,k)*binomial(n+k,k),k,n);


6*summ(n - 1)*n - 3*summ(n - 1) - summ(n)*n - (n - 1)*summ(n - 2)

% sumrecursion(binomial(n+k,m+2*k)*binomial(2*k,k)*(-1)^k/(k+1),k,n);
sumrecursion((-1)^k*binomial(n-k,k)*binomial(n-2*k,m-k),k,n);


summ(n - 1) - summ(n)

% sumrecursion((-1)^k*binomial(n-k,k)*binomial(n-2*k,m-k),k,m);
sumrecursion(binomial(n+k,2*k)*2^(n-k),k,n);


5*summ(n - 1) - summ(n) - 4*summ(n - 2)

sumrecursion(binomial(n,k)*binomial(2*k,k)*(-1/4)^k,k,n);


(2*n - 1)*summ(n - 1) - 2*summ(n)*n

% sumrecursion(binomial(n,i)*binomial(2*n,n-i),i,n);
sumrecursion((-1)^k*binomial(n,k)*binomial(2*k,k)*4^(n-k),k,n);


2*(2*n - 1)*summ(n - 1) - summ(n)*n

sumrecursion((-1)^k*binomial(n,k)/binomial(k+a,k),k,n);


summ(n - 1) + summ(n)

% sumrecursion((-1)^k*binomial(n,k)/binomial(k+a,k),k,a);
sumrecursion((-1)^(n-k)*binomial(2*n,k)^2,k,n);


2*(2*n - 1)*summ(n - 1) - summ(n)*n

sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
factorial(k+1)*factorial(n-k)*factorial(k+c)),k,a);


 - (n + 1 + c - a)*(b - c + a)*summ(a) + (a - c)*(a - 1)*summ(a - 1)

% sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
% factorial(k+1)*factorial(n-k)*factorial(k+c)),k,b);
% sumrecursion(factorial(a+k)*factorial(b+k)*factorial(n+c-a-b-k-1)/(
% factorial(k+1)*factorial(n-k)*factorial(k+c)),k,c);
sumrecursion(binomial(2*n+1,2*p+2*k+1)*binomial(p+k,k),k,n);


(2*p + 1 - 2*n)*(n - p)*summ(n) - 2*(p + 1 - 2*n)*(2*n - p)*summ(n - 1)

% sumrecursion(binomial(2*n+1,2*p+2*k+1)*binomial(p+k,k),k,p);
sumrecursion(binomial(r,m)*binomial(s,t-m),m,r);


(s - t + r)*summ(r) - (r + s)*summ(r - 1)

% sumrecursion(binomial(r,m)*binomial(s,t-m),m,s);
% sumrecursion(binomial(r,m)*binomial(s,t-m),m,t);
sumrecursion(binomial(2*n+1,2*k)*binomial(m+k,2*n),k,n);


(2*n - 3 - 2*m)*(n - 1 - m)*summ(n - 1) - (2*n - 1)*summ(n)*n

% sumrecursion(binomial(2*n+1,2*k)*binomial(m+k,2*n),k,m);
sumrecursion(binomial(n,k)*binomial(k,j)*x^j,k,n);


(j - n)*summ(n) + 2*summ(n - 1)*n

% sumrecursion(binomial(n,k)*binomial(k,j)*x^j,k,j);
% sumrecursion(binomial(n,k)*binomial(k,j)*x^k,k,n);
sumrecursion(x*binomial(n+k,2*k)*((x^2-1)/4)^(n-k),k,n);


           2        2                                 2
 - ((x + 1) *(x - 1) *summ(n - 2) + 16*summ(n)) + 8*(x  + 1)*summ(n - 1)

sumrecursion(binomial(n+k-1,2*k-1)*(x-1)^(2*k)*x^(n-k)/k,k,n);


                         2                          2
 - ((n - 2)*summ(n - 2)*x  + summ(n)*n) + (n - 1)*(x  + 1)*summ(n - 1)

sumrecursion(
1/(k+1)*binomial(2*k,k)/(n-k+1)*binomial(2*n-2*k,n-k),k,n);


summ(n - 1) + summ(n)

sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,m);


(t + 1 + n*t - (t - 1)*q - (t + 1)*m)*summ(m - 1)

 - ((n + 1 - m)*summ(m) - (m - 1)*summ(m - 2)*t)

% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,n);
% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,q);
% sumrecursion(binomial(m,r)*binomial(n-r,n-r-q)*(t-1)^r,r,r);
sumrecursion(pochhammer(-n/2,k)*pochhammer(-n/2+1/2,k)/
(factorial(k)*pochhammer(b+1/2,k)),k,n);


(n - 1 + 2*b)*summ(n) - 2*(n - 1 + b)*summ(n - 1)

% Watson
% sumrecursion(pochhammer(a,k)*pochhammer(b,k)*pochhammer(c,k)/(
% factorial(k)*pochhammer(1/2*(a+b+1),k)*pochhammer(2*c,k)),k,c);
% sumrecursion(pochhammer(-m,j)*pochhammer(m+2*k+2,j)*pochhammer(k+1/2,j)/
% (factorial(j)*pochhammer(k+3/2,j)*pochhammer(2*k+1,j)),j,k);
sumrecursion((-1)^k*binomial(n,k)^3,k,n);


                                             2
3*(3*n - 2)*(3*n - 4)*summ(n - 2) + summ(n)*n

% sumrecursion(pochhammer(-n,k)*pochhammer(n+2*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(2*a/2,k)*pochhammer((2*a+1)/2,k))*(2/4)^k,k,n);
% sumrecursion(pochhammer(-n,k)*pochhammer(n+4*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(4*a/2,k)*pochhammer((4*a+1)/2,k))*(4/4)^k,k,n);
% sumrecursion(binomial(n+k+1,n-k)*pochhammer(-n+k,j)*pochhammer(k+1/2,j)*
% pochhammer(n+k+2,j)/(factorial(j)*pochhammer(k+3/2,j)*
%    pochhammer(2*k+1,j)),j,n);
% sumrecursion(pochhammer(-m,j)*pochhammer(m+2*k+2,j)*
%    pochhammer(k+1/2,j)/(
% factorial(j)*pochhammer(k+3/2,j)*pochhammer(2*k+1,j)),j,m);
% sumrecursion(binomial(n+k+1,n-k)*pochhammer(-n+k,j)*
%   pochhammer(k+1/2,j)*
% pochhammer(n+k+2,j)/(factorial(j)*pochhammer(k+3/2,j)*
%   pochhammer(2*k+1,j)),
% j,k);
% sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
% (factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
%   pochhammer(b-n/2+1,l)),j,a);
% sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
% (factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
%   pochhammer(b-n/2+1,l)),j,b);
sumrecursion(pochhammer(a+b+c-n,j+l)*pochhammer(a+b-n/2,j+l)/
(factorial(j)*factorial(l)*pochhammer(a-n/2+1,j)*
   pochhammer(b-n/2+1,l)),j,c);


 - (n + 1 - l - c - b - a)*(n + 2 - 2*l - 2*c - 2*b)*summ(c - 1)

 + 2*(n + 1 - 2*l - c - 2*b - a)*(n + 1 - c - b - a)*summ(c)

% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%    gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,a);
% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%  gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,b);
% sumrecursion(
% (-1)^(a+b+c)*gamma(a+b+c-d/2)*gamma(d/2-c)*gamma(a+c-d/2)*
%  gamma(b+c-d/2)/
% (gamma(a)*gamma(b)*gamma(d/2)*gamma(a+b+2*c-d)*(m^2)^(a+b+c-d))*
% pochhammer(a+b+c-d,k)*pochhammer(a+c-d/2,k)/
% (pochhammer(a+b+2*c-d,k)*factorial(k)),k,c);
% sumrecursion(pochhammer(-n,k)*pochhammer(n+3*a,k)*pochhammer(a,k)/(
% factorial(k)*pochhammer(3*a/2,k)*
%    pochhammer((3*a+1)/2,k))*(3/4)^k,k,n);
% summand:=k*(-1)^j*pochhammer(2*k+j+1,j)*pochhammer(2*k+2*j+2,n-k-j)/(
% factorial(k+j)*factorial(j)*factorial(n-k-j))*exp(-(j+k)*t)$
% summand:=k*(-1)^j*pochhammer(2*k+j+1,j)*pochhammer(2*k+2*j+2,n-k-j)/(
% (k+j)*factorial(j)*factorial(n-k-j))*exp(-(j+k)*t)$
% sumrecursion(summand,j,n);
clear(summand);



% 6) Finding recurrence equations for hypergeometric functions
% Koornwinder, T. H.:
% On Zeilberger's algorithm and
% its q-analogue: a rigorous description.
% J. of Comput. and Appl. Math. 48, 1993, 91-111.

% Gauss
hyperrecursion({a,b},{c},1,a);


(b - c + a)*summ(a) - (a - c)*summ(a - 1)

% Dougall
% hyperrecursion({d,1+d/2,d+b-a,d+c-a,1+a-b-c,n+a,-n},
%               {d/2,1+a-b,1+a-c,b+c+d-a,1+d-a-n,1+d+n},1,n);
% Baxter
% hyperrecursion({-n,-n-1,-n-2},{2,3},-1,n);
% Krawtchouk polynomials
% krawtchoukterm :=
%    (-1)^n*p^n*binomial(NN,n)*hyperterm({-n,-x},{-NN},1/p,k)$
% sumrecursion(krawtchoukterm,k,n);
% sumrecursion(krawtchoukterm,k,x);
% sumrecursion(krawtchoukterm,k,NN);
% clear(krawtchoukterm);
% hyperrecursion({-n,b,c+4},{b+1,c},1,n);
hyperrecursion({-n,b,c+1,d+1},{b+1,c,d},1,n);


recursion valid for n>=3

(b + n)*summ(n) - summ(n - 1)*n


% 7) Extended versions of Gosper's and Zeilberger's algorithms
% Koepf, W.:
% Algorithms for the indefinite and definite summation.
% Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-33, 1994.

% extended Gosper algorithm
extended_gosper(k*factorial(k/7),k,7);


                   k
(k + 7)*factorial(---)
                   7

extended_gosper(k*factorial(k/2),k,2);


                   k
(k + 2)*factorial(---)
                   2

extended_gosper(k*factorial(k/2),k);


                   k                        k - 1
(k + 2)*factorial(---) + (k + 1)*factorial(-------)
                   2                          2

extended_gosper(binomial(k/2,n),k);


                   k                         k - 1
 (k + 2)*binomial(---,n) + (k + 1)*binomial(-------,n)
                   2                           2
-------------------------------------------------------
                       2*(n + 1)

extended_gosper(binomial(n,k/2)-binomial(n,k/2-1),k);


                                            k - 3                 k - 1
( - ((2*n + 3 - k)*(n + 1 - k)*(binomial(n,-------) - binomial(n,-------))
                                              2                     2

                                                 k - 2                 k
      + (n + 2 - k)*(2*(n + 1) - k)*(binomial(n,-------) - binomial(n,---))))/(2
                                                   2                   2

   *(n + 2 - k)*(n + 1 - k))


% extended Zeilberger algorithm
% extended_sumrecursion(binomial(n,k)*binomial(k/2,n),k,n,1,2);
sumrecursion(binomial(n,k)*binomial(k/2,n),k,n);


recursion valid for n>=3

summ(n - 1) + 2*summ(n)

extended_sumrecursion(binomial(n/2,k),k,n,2,1);


2*summ(n - 2) - summ(n)

sumrecursion(binomial(n/2,k),k,n);


2*summ(n - 2) - summ(n)

% sumrecursion(hyperterm({a,b,a+1/2-b,1+2*a/3,-n},
% {2*a+1-2*b,2*b,2/3*a,1+a+n/2},4,k)/
% (factorial(n)*2^(-n)/factorial(n/2))/
% hyperterm({a+1,1},{a-b+1,b+1/2},1,n/2),k,n);

% Watson
% sumrecursion(pochhammer(a,k)*pochhammer(b,k)*pochhammer(c,k)/(
% factorial(k)*pochhammer(1/2*(a+b+1),k)*pochhammer(2*c,k))/
% (GAMMA(1/2)*GAMMA(1/2+c)*GAMMA(1/2+a/2+b/2)*GAMMA(1/2-a/2-b/2+c))*
% GAMMA(1/2+a/2)*GAMMA(1/2+b/2)*GAMMA(1/2-a/2+c)*GAMMA(1/2-b/2+c),k,a);
% hyperrecursion({a,b,c},{1/2*(a+b+1),2*c},1,a);
% hyperrecursion({a,b,c},{1/2*(a+b+1),2*c},1,b);

% 8) Closed form representations of hypergeometric sums

% Vandermonde
hypersum({-n,b},{c},1,n);


 pochhammer( - b + c,n)
------------------------
    pochhammer(c,n)

% Saalschuetz
hypersum({a,b,-n},{c,1+a+b-c-n},1,n);


 pochhammer( - a + c,n)*pochhammer( - b + c,n)
-----------------------------------------------
  pochhammer( - a - b + c,n)*pochhammer(c,n)

% Kummer
hypersum({a,-n},{1+a+n},-1,n);


  pochhammer(a + 1,n)
-----------------------
             a + 2
 pochhammer(-------,n)
               2

% Dixon
hypersum({a,b,-n},{1+a-b,1+a+n},1,n);


                                 a - 2*b + 2
 pochhammer(a + 1,n)*pochhammer(-------------,n)
                                      2
-------------------------------------------------
                                      a + 2
  pochhammer(a - b + 1,n)*pochhammer(-------,n)
                                        2

% Dougall
% hypersum({a,1+a/2,b,c,d,1+2*a-b-c-d+n,-n},
% {a/2,1+a-b,1+a-c,1+a-d,1+a-(1+2*a-b-c-d+n),1+a+n},1,n);
% Clausen
% hypersum({a,b,1/2-a-b-n,-n},{1/2+a+b,1-a-n,1-b-n},1,n);

hypersum({a,1+a/2,c,d,-n},{a/2,1+a-c,1+a-d,1+a+n},1,n);


 pochhammer(a - c - d + 1,n)*pochhammer(a + 1,n)
-------------------------------------------------
 pochhammer(a - c + 1,n)*pochhammer(a - d + 1,n)

hypersum({a,1+a/2,d,-n},{a/2,1+a-d,1+a+n},-1,n);


   pochhammer(a + 1,n)
-------------------------
 pochhammer(a - d + 1,n)


% m-fold case:
hypersum({-n,-n,-n},{1,1},1,n);


         n/2             2   n               1   n
  ( - 27)   *pochhammer(---,---)*pochhammer(---,---)
                         3   2               3   2
{----------------------------------------------------,
                              n  2
                   factorial(---)
                              2

 0}

% hypersum({-n,n+3*a,a},{3*a/2,(3*a+1)/2},3/4,n);

% 9) Hypergeometric representations

sumtohyper(binomial(n,k)^3,k);


hypergeom({ - n, - n, - n},{1,1},-1)

sumtohyper(binomial(n,k)/2^n-sub(n=n-1,binomial(n,k)/2^n),k);


                 - n + 2           - n
  - hypergeom({----------, - n},{------},-1)
                   2               2
---------------------------------------------
                      n
                     2

sumtohyper(binomial(k+j-1,k-j)*2*(-1)^(j+1)*factorial(2*j-1)/         
factorial(j-1)/factorial(j+1)*x^j,j);


hypergeom({k + 1, - k + 1},{3},x)*k*x

% term:=1/(n-1+k)*(1/2-1/2*x)^k/n*binomial(k-n-1,-n-1)*k*
%         binomial(n-1+k,n-1);
% sumtohyper(sub(n=n+1,term)-term,k);

end;


Time for test: 5275 ms, plus GC time: 389 ms
@@@@@ Resources used: (5 63 105 10)
mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/zeilberg.tex0000644000175000017500000010616111526203062023642 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt ZEILBERG}\\ 
A Package for the Indefinite\\
and Definite Summation}
\date{}
\author{Wolfram Koepf\\
	Gregor St\"olting \\
	ZIB Berlin \\
	email: {\tt  Koepf@ZIB-Berlin.de}
}
\begin{document}
\maketitle
\newcommand{\N} {{\rm {\mbox{\protect\makebox[.15em][l]{I}N}}}}
\newcommand{\funkdef}[3]{\left\{\!\!\!\begin{array}{cc}
                                #1 & \!\!\!\mbox{\rm{if} $#2$ } \\
                                #3 & \!\!\!\mbox{\rm{otherwise}}
                                \end{array}
                         \right.}

\section{Introduction}

This package is a careful implementation of the Gosper%
\footnote{The {\tt sum} package contains also a partial implementation
of the Gosper algorithm.}
and Zeilberger algorithms for indefinite, and definite summation of
hypergeometric terms, respectively. Further, extensions of these algorithms
given by the first author are covered. An expression $a_k$ is called a 
{\sl hypergeometric term} (or {\sl closed form}),
if $a_{k}/a_{k-1}$ is a rational function with respect to $k$.
Typical hypergeometric terms are ratios of products of powers, factorials, 
$\Gamma$ function terms, binomial coefficients, and shifted factorials 
(Pochhammer symbols) that are integer-linear in their arguments.

The extensions of Gosper's and Zeilberger's algorithm mentioned
in particular are valid for ratios of products of powers, factorials,
$\Gamma$ function terms, binomial coefficients, and shifted factorials
that are rational-linear in their arguments.

\section{Gosper Algorithm}

The Gosper algorithm \cite{Gos} is a {\sl decision procedure}, that
decides by algebraic calculations whether or not a given hypergeometric term
$a_k$ has a hypergeometric term antidifference $g_k$, i.\ e.\ 
$g_{k}-g_{k-1}=a_k$ with rational $g_k/g_{k-1}$, 
and returns $g_k$ if the procedure is successful, in which
case we call $a_k$ {\sl Gosper-summable}. Otherwise
{\sl no hypergeometric term antidifference exists}. Therefore
if the Gosper algorithm does not return a closed form solution,
it has {\sl proved} that no such solution exists, an information
that may be quite useful and important. 
The Gosper algorithm is the discrete analogue of the Risch algorithm
for integration in terms of elementary functions.

Any antidifference is uniquely determined up to a constant, and is
denoted by
\[
g_k=\sum\nolimits_k a_k
\;.
\]
Finding $g_k$ given $a_k$ is called {\sl indefinite summation}.
The antidifference operator $\Sigma$ is the inverse of the downward 
difference operator $\nabla a_k=a_{k}-a_{k-1}$. There is an analogous
summation theory corresponding to the upward difference operator 
$\Delta a_k=a_{k+1}-a_k$.

In case, an antidifference $g_k$ of $a_k$ is known, any sum
\[
\sum_{k=m}^{n} a_k=g_{n}-g_{m-1}
\]
can be easily calculated by an evaluation of $g$ at the boundary points
like in the integration case. Note, however, that the sum
\begin{equation}
\sum_{k=0}^n {{n}\choose{k}}
\label{eq:nchoosek}
\end{equation}
e.\ g.\
is not of this type since the summand ${{n}\choose{k}}$ depends on the upper
boundary point $n$ explicitly. This is an example of a definite sum
that we consider in the next section.

Our package supports the input of powers ({\tt a\verb+^+k)},
factorials ({\tt factorial(k)}),
$\Gamma$ function terms ({\tt gamma(a)}), binomial coefficients
({\tt binomial(n,k)}), shifted factorials 
({\tt pochhammer(a,k)$=a(a+1)\cdots(a+k-1)=\Gamma (a+k)/\Gamma (a)$}), and
partially products ({\tt prod(f,k,k1,k2)}).
It takes care of the necessary simplifications, and therefore 
provides you with the solution of the decision problem
as long as the memory or time requirements are not too high for the
computer used.

\section{Zeilberger Algorithm}

The (fast) Zeilberger algorithm \cite{Zei2}--\cite{Zei3}
deals with the {\sl definite summation} of 
hypergeometric terms. Zeilberger's paradigm is to find (and return)
a linear homogeneous recurrence equation with polynomial coefficients
(called {\sl holonomic equation}) for an {\sl infinite sum}
\[
s(n)=\sum_{k=-\infty}^{\infty} f(n,k)
\;,
\]
the summation to be understood over all integers $k$,
if $f(n,k)$ is a hypergeometric term with respect to both $k$ and $n$.
The existence of a holonomic recurrence equation for $s(n)$ is then
generally guaranteed.

If one is lucky, and the resulting recurrence equation is of first order
\[
p(n)\,s(n-1)+q(n)\,s(n)=0
\quad\quad(p,q\;\mbox{polynomials})
\;,
\]
$s(n)$ turns out to be a hypergeometric term, and a closed form solution 
can be easily established using a suitable initial value, and is
represented by a ratio of Pochhammer or $\Gamma$ function terms if the 
polynomials $p$, and $q$ can be factored.

Zeilberger's algorithm does not guarantee to find the holonomic equation
of lowest order, but often it does. 

If the resulting recurrence equation has order larger than one, 
this information can be used for identification purposes:
Any other expression satisfying the same recurrence equation, and the same
initial values, represents the same function.

Note that a {\sl definite sum} $\sum\limits_{k=m_1}^{m_2} f(n,k)$ is an
infinite sum if $f(n,k)=0$ for $km_2$.
This is often the case, an example of which is the sum (\ref{eq:nchoosek})
considered above, for which the hypergeometric recurrence equation
$2 s(n-1) - s(n) = 0$ is generated by Zeilberger's algorithm, leading 
to the closed form solution $s(n)=2^n$.

Definite summation is trivial if the corresponding indefinite sum
is Gosper-summable analogously to the fact that definite integration
is trivial as soon as an elementary antiderivative is known.  If this is 
not the case, the situation is much more difficult, and it is therefore
quite remarkable and non-obvious
that Zeilberger's method is just a clever application of Gosper's algorithm.

Our implementation is mainly based on \cite{Koornwinder} and \cite{Koepf}. 
More examples can be found in \cite{PS}, \cite{Strehl2}, \cite{Wil1},
and \cite{Wilf} many of which are contained in the test file 
{\tt zeilberg.tst}.

\section{\REDUCE{} operator {\tt GOSPER}}

The ZEILBERG package must be loaded by:

{\small
\begin{verbatim}
1: load zeilberg;
\end{verbatim}
}\noindent
The {\tt gosper} operator is an implementation of the Gosper algorithm.
\begin{itemize}
\item
{\tt gosper(a,k)} determines a closed
form antidifference. If it does not return a closed form solution, then
a closed form solution does not exist.
\item
{\tt gosper(a,k,m,n)} determines 
\[
\sum_{k=m}^n a_k
\]
using Gosper's algorithm. This is only successful if Gosper's algorithm applies.
\end{itemize}

Example:

{\small
\begin{verbatim}
2: gosper((-1)^(k+1)*(4*k+1)*factorial(2*k)/
   (factorial(k)*4^k*(2*k-1)*factorial(k+1)),k);

              k
      - ( - 1) *factorial(2*k)
------------------------------------
  2*k
 2   *factorial(k + 1)*factorial(k)
\end{verbatim}
}\noindent
This solves a problem given in SIAM Review (\cite{SR}, Problem 94--2) 
where it was asked to determine the infinite sum
\[
S=\lim_{n\rightarrow\infty} S_n
\;,
\quad\quad\quad
S_n=\sum_{k=1}^n
\frac{(-1)^{k+1}(4k+1)(2k-1)!!}{2^k(2k-1)(k+1)!}
\;,
\]
($(2k-1)!!=1\cdot 3 \cdots (2k-1)=\frac{(2k)!}{2^k\,k!}$).
The above calculation shows that the summand is Gosper-summable,
and the limit $S=1$ is easily established using Stirling's formula.

The implementation solves further deep and difficult problems some examples of
which are:%

{\small
\begin{verbatim}
3:  gosper(sub(n=n+1,binomial(n,k)^2/binomial(2*n,n))-
    binomial(n,k)^2/binomial(2*n,n),k);

                   2
((binomial(n + 1,k) *binomial(2*n,n)

                                            2
   - binomial(2*(n + 1),n + 1)*binomial(n,k) )*(2*k - 3*n - 1)

             2                                       3      2
 *(k - n - 1) )/((2*(2*(n + 1) - k)*(2*n + 1)*k - 3*n  - 7*n  - 5*n

                     - 1)*binomial(2*(n + 1),n + 1)*binomial(2*n,n))

4: gosper(binomial(k,n),k);

 (k + 1)*binomial(k,n)
-----------------------
         n + 1

5: gosper((-25+15*k+18*k^2-2*k^3-k^4)/
   (-23+479*k+613*k^2+137*k^3+53*k^4+5*k^5+k^6),k);

          2
    - (2*k  - 15*k + 8)*k
----------------------------
      3      2
 23*(k  + 4*k  + 27*k + 23)
\end{verbatim}
}\noindent
The Gosper algorithm is not capable to give antidifferences depending
on the harmonic numbers
\[
H_k:=\sum_{j=1}^k\frac{1}{j}
\;,
\]
e.\ g.\ $\sum_k H_k=(k+1)(H_{k+1}-1)$, but, is able to give a proof, instead,
for the fact that $H_k$ does not possess a closed form evaluation:

{\small
\begin{verbatim}
6: gosper(1/k,k);

***** Gosper algorithm: no closed form solution exists
\end{verbatim}
}\noindent
The following code gives the solution to a summation problem proposed in 
Gosper's original paper \cite{Gos}. Let
\[
f_k=\prod_{j=1}^k (a+b\,j+c\,j^2)
\quad\quad\mbox{and}\quad\quad
g_k=\prod_{j=1}^k (e+b\,j+c\,j^2)
\;.
\]
Then a closed form solution for
\[
\sum\nolimits_k\frac{f_{k-1}}{g_{k}}
\]
is found by the definitions

{\small
\begin{verbatim}
7: operator ff,gg$

8: let {ff(~k+~m) => ff(k+m-1)*(c*(k+m)^2+b*(k+m)+a) 
        when (fixp(m) and m>0),
   ff(~k+~m) => ff(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+a) 
        when (fixp(m) and m<0)}$

9: let {gg(~k+~m) => gg(k+m-1)*(c*(k+m)^2+b*(k+m)+e) 
        when (fixp(m) and m>0),
   gg(~k+~m) => gg(k+m+1)/(c*(k+m+1)^2+b*(k+m+1)+e) 
        when (fixp(m) and m<0)}$
\end{verbatim}
}\noindent
and the calculation

{\small
\begin{verbatim}
10: gosper(ff(k-1)/gg(k),k);

     ff(k)
---------------
 (a - e)*gg(k)

11: clear ff,gg$
\end{verbatim}
}\noindent
Similarly closed form solutions of $\sum\nolimits_k\frac{f_{k-m}}{g_{k}}$
for positive integers $m$ can be obtained, as well as of
$\sum_k\frac{f_{k-1}}{g_{k}}$ for
\[
f_k=\prod_{j=1}^k (a+b\,j+c\,j^2+d\,j^3)
\quad\quad\mbox{and}\quad\quad
g_k=\prod_{j=1}^k (e+b\,j+c\,j^2+d\,j^3)
\]
and for analogous expressions of higher degree polynomials.

\section{\REDUCE{} operator {\tt EXTENDED\_GOSPER}}

The {\tt extended\verb+_+gosper} operator is an implementation of an extended
version of Gosper's algorithm given by Koepf \cite{Koepf}.
\begin{itemize}
\item
{\tt extended\verb+_+gosper(a,k)} determines an antidifference $g_k$ of $a_k$
whenever there is a number $m$ such that $h_{k}-h_{k-m}=a_k$, and $h_k$ is an
{\sl $m$-fold hypergeometric term}, i.\ e.
\[
h_{k}/h_{k-m}\quad\mbox{is a rational function with respect to $k$.}
\]
If it does not return a solution, then such a solution does not exist.
\item
{\tt extended\verb+_+gosper(a,k,m)} 
determines an {\sl $m$-fold antidifference} $h_k$ of $a_k$,
i.\ e.\ $h_{k}-h_{k-m}=a_k$, if it is an $m$-fold hypergeometric term.
\end{itemize}
Examples:

{\small
\begin{verbatim}
12: extended_gosper(binomial(k/2,n),k);

                   k                         k - 1
 (k + 2)*binomial(---,n) + (k + 1)*binomial(-------,n)
                   2                           2
-------------------------------------------------------
                       2*(n + 1)

13: extended_gosper(k*factorial(k/7),k,7);

                   k
(k + 7)*factorial(---)
                   7
\end{verbatim}
}\noindent

\section{\REDUCE{} operator {\tt SUMRECURSION}}

The {\tt sumrecursion} operator is an implementation of the (fast)
Zeilberger algorithm.
\begin{itemize}
\item
{\tt sumrecursion(f,k,n)} determines a holonomic recurrence equation
for 
\[
{\tt sum(n)} =\sum\limits_{k=-\infty}^\infty f(n,k)
\]
with respect to $n$, applying
{\tt extended\verb+_+sumrecursion} if necessary, 
see \S~\ref{sec:EXTENDED_SUMRECURSION}.
The resulting expression equals zero.
\item
{\tt sumrecursion(f,k,n,j)} % $(j\in\N)$ 
searches for a holonomic recurrence equation of order $j$. This 
operator does not use {\tt extended\verb+_+sumrecursion} automatically.
Note that if $j$ is too large, the recurrence equation
may not be unique, and only one particular solution is returned.
\end{itemize}
A simple example deals with Equation (\ref{eq:nchoosek})%
\footnote{Note that with \REDUCE{} Version 3.5 we use the global operator 
{\tt summ} instead of {\tt sum} to denote the sum.} 

{\small
\begin{verbatim}
14: sumrecursion(binomial(n,k),k,n);

2*sum(n - 1) - sum(n)
\end{verbatim}
}\noindent
The whole {\sl hypergeometric database} of the {\sl
Vandermonde, Gau{\ss}, Kummer, Saalsch\"utz, Dixon, Clausen} and {\sl Dougall
identities} (see \cite{Wilf}), and many more identities (see e.\ g.\
\cite{Koepf}), can be obtained using {\tt sumrecursion}. 
As examples, we consider the difficult cases of Clausen and Dougall:%

{\small
\begin{verbatim}
15: summand:=factorial(a+k-1)*factorial(b+k-1)/(factorial(k)*
    factorial(-1/2+a+b+k))*factorial(a+n-k-1)*factorial(b+n-k-1)/
    (factorial(n-k)*factorial(-1/2+a+b+n-k))$

16: sumrecursion(summand,k,n);

(2*a + 2*b + 2*n - 1)*(2*a + 2*b + n - 1)*sum(n)*n

 - 2*(2*a + n - 1)*(a + b + n - 1)*(2*b + n - 1)*sum(n - 1)

17: summand:=pochhammer(d,k)*pochhammer(1+d/2,k)*pochhammer(d+b-a,k)*
    pochhammer(d+c-a,k)*pochhammer(1+a-b-c,k)*pochhammer(n+a,k)*
    pochhammer(-n,k)/(factorial(k)*pochhammer(d/2,k)*
    pochhammer(1+a-b,k)*pochhammer(1+a-c,k)*pochhammer(b+c+d-a,k)*
    pochhammer(1+d-a-n,k)*pochhammer(1+d+n,k))$

18: sumrecursion(summand,k,n);

(2*a - b - c - d + n)*(b + n - 1)*(c + n - 1)*(d + n)*sum(n - 1) + 

(a - b - c - d - n + 1)*(a - b + n)*(a - c + n)*(a - d + n - 1)

*sum(n)
\end{verbatim}
}\noindent
corresponding to the statements
\[
_4 F_3\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{c}
a\;, b\;, 1/2-a-b-n\;, -n
\end{array}}\\[1mm]
\multicolumn{1}{c}{\begin{array}{c}
1/2+a+b \;, 1-a-n\;, 1-b-n
            \end{array}}\end{array}
\!\!\!\!
\right| 1\right)
=\frac{(2a)_n\,(a+b)_n\,(2b)_n}
{(2a+2b)_n\,(a)_n\,(b)_n}
\]
and
\[
_7 F_6\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{c} 
d\;, 1+d/2\;, d+b-a\;, d+c-a\;, 1+a-b-c\;, n+a\;, -n 
\end{array}}\\[1mm]
\multicolumn{1}{c}{\begin{array}{c} 
 d/2\;, 1+a-b\;, 1+a-c\;, b+c+d-a \;, 1+d-a-n\;, 1+d+n
            \end{array}}\end{array}
\!\!\!\!
\right| 1\right)
\]
\[
=\frac{(d+1)_n\,(b)_n\,(c)_n\,(1+2\,a-b-c-d)_n}
{(a-d)_n\,(1+a-b)_n\,(1+a-c)_n\,(b+c+d-a)_n}
\]
(compare next section), respectively.

Other applications of the Zeilberger algorithm are connected with
the verification of identities. To prove the identity
\[
\sum_{k=0}^n
{{n}\choose{k}}^3
=
\sum_{k=0}^n
{{n}\choose{k}}^2 {{2k}\choose{n}}
\;,
\]
e.\ g., we may prove that both sums satisfy the same recurrence equation

{\small
\begin{verbatim}
19: sumrecursion(binomial(n,k)^3,k,n);

    2                                  2                      2
(7*n  - 7*n + 2)*sum(n - 1) + 8*(n - 1) *sum(n - 2) - sum(n)*n

20: sumrecursion(binomial(n,k)^2*binomial(2*k,n),k,n);

    2                                  2                      2
(7*n  - 7*n + 2)*sum(n - 1) + 8*(n - 1) *sum(n - 2) - sum(n)*n
\end{verbatim}
}\noindent
and finally check the initial conditions:

{\small
\begin{verbatim}
21: sub(n=0,k=0,binomial(n,k)^3);

1

22: sub(n=0,k=0,binomial(n,k)^2*binomial(2*k,n));

1

23: sub(n=1,k=0,binomial(n,k)^3)+sub(n=1,k=1,binomial(n,k)^3);

2

24: sub(n=1,k=0,binomial(n,k)^2*binomial(2*k,n))+
    sub(n=1,k=1,binomial(n,k)^2*binomial(2*k,n));

2
\end{verbatim}
}\noindent

\section{\REDUCE{} operator {\tt EXTENDED\_SUMRECURSION}}
\label{sec:EXTENDED_SUMRECURSION}

The {\tt extended\verb+_+sumrecursion} operator is an implementation 
of an extension of the (fast) Zeilberger algorithm given by Koepf
\cite{Koepf}.
\begin{itemize}
\item
{\tt extended\verb+_+sumrecursion(f,k,n,m,l)} determines a holonomic recurrence 
equation for ${\tt sum(n)} =\sum\limits_{k=-\infty}^\infty f(n,k)$ 
with respect to $n$ if $f(n,k)$ is an {\sl $(m,l)$-fold hypergeometric term} 
with respect to $(n,k)$, i.\ e.\
\[
\frac{F(n,k)}{F(n-m,k)}
\quad
\mbox{and}
\quad
\frac{F(n,k)}{F(n,k-l)}
\]
are rational functions with respect to both $n$ and $k$.
The resulting expression equals zero.
\item
{\tt sumrecursion(f,k,n)} invokes {\tt extended\verb+_+sumrecursion(f,k,n,m,l)}
with suitable values $m$ and $l$, and covers therefore the extended
algorithm completely.
\end{itemize}
Examples:

{\small
\begin{verbatim}
25: extended_sumrecursion(binomial(n,k)*binomial(k/2,n),k,n,1,2);

sum(n - 1) + 2*sum(n)
\end{verbatim}
}\noindent
which can be obtained automatically by
{\small
\begin{verbatim}
26: sumrecursion(binomial(n,k)*binomial(k/2,n),k,n);

sum(n - 1) + 2*sum(n)
\end{verbatim}
}\noindent
Similarly, we get
{\small
\begin{verbatim}
27: extended_sumrecursion(binomial(n/2,k),k,n,2,1);

2*sum(n - 2) - sum(n)

28: sumrecursion(binomial(n/2,k),k,n);

2*sum(n - 2) - sum(n)

29: sumrecursion(hyperterm({a,b,a+1/2-b,1+2*a/3,-n},
    {2*a+1-2*b,2*b,2/3*a,1+a+n/2},4,k)/(factorial(n)*2^(-n)/
    factorial(n/2))/hyperterm({a+1,1},{a-b+1,b+1/2},1,n/2),k,n);

sum(n - 2) - sum(n)
\end{verbatim}
}\noindent
In the last example, the progam chooses $m=2$, and $l=1$ to derive the
resulting recurrence equation (see \cite{Koepf}, Table 3, (1.3)).


\section{\REDUCE{} operator {\tt HYPERRECURSION}}

Sums to which the Zeilberger algorithm applies, in general are
special cases of the {\sl generalized hypergeometric function}
\[
_{p}F_{q}\left.\left(\begin{array}{cccc}
a_{1},&a_{2},&\cdots,&a_{p}\\
b_{1},&b_{2},&\cdots,&b_{q}\\
            \end{array}\right| x\right)
:=
\sum_{k=0}^\infty \frac
{(a_{1})_{k}\cdot(a_{2})_{k}\cdots(a_{p})_{k}}
{(b_{1})_{k}\cdot(b_{2})_{k}\cdots(b_{q})_{k}\,k!}x^{k}
\label{eq:coefficientformula}
\]
with upper parameters $\{a_{1}, a_{2}, \ldots, a_{p}\}$, and lower
parameters $\{b_{1}, b_{2}, \ldots, b_{q}\}$. If a recursion for a
generalized hypergeometric function is to be established, you can use
the following \REDUCE{} operator:
\begin{itemize}
\item
{\tt hyperrecursion(upper,lower,x,n)} determines a holonomic recurrence 
equation with respect to $n$ for 
$_{p}F_{q}\left.\left(\begin{array}{cccc}
a_{1},&a_{2},&\cdots,&a_{p}\\
b_{1},&b_{2},&\cdots,&b_{q}\\
            \end{array}\right| x\right)
$, where {\tt upper}$=\{a_{1}, a_{2}, \ldots, a_{p}\}$
is the list of upper parameters, and 
{\tt lower}$=\{b_{1}, b_{2}, \ldots, b_{q}\}$
is the list of lower parameters depending on $n$. If Zeilberger's algorithm
does not apply, {\tt extended\verb+_+sumrecursion} 
of \S~\ref{sec:EXTENDED_SUMRECURSION} is used.
\item
{\tt hyperrecursion(upper,lower,x,n,j)} $(j\in\N)$
searches only for a holonomic recurrence equation of order $j$. This
operator does not use {\tt extended\verb+_+sumrecursion} automatically.
\end{itemize}
Therefore

{\small
\begin{verbatim}
30: hyperrecursion({-n,b},{c},1,n);

(b - c - n + 1)*sum(n - 1) + (c + n - 1)*sum(n)
\end{verbatim}
}\noindent
establishes the Vandermonde identity
\[
_2 F_1\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{cc} -n\;, & b \end{array}}\\[1mm]
\multicolumn{1}{c}{ c}
            \end{array}
\!\!\!\!
\right| 1\right)
=\frac{(c-b)_n}{(c)_n}
\;,
\]
whereas

{\small
\begin{verbatim}
31: hyperrecursion({d,1+d/2,d+b-a,d+c-a,1+a-b-c,n+a,-n},
                   {d/2,1+a-b,1+a-c,b+c+d-a,1+d-a-n,1+d+n},1,n);

(2*a - b - c - d + n)*(b + n - 1)*(c + n - 1)*(d + n)*sum(n - 1) + 

(a - b - c - d - n + 1)*(a - b + n)*(a - c + n)*(a - d + n - 1)

*sum(n)
\end{verbatim}
}\noindent
proves Dougall's identity, again.

If a hypergeometric expression is given in hypergeometric notation, then
the use of {\tt hyperrecursion} is more natural than the use of
{\tt sumrecursion}.

Moreover you may use the \REDUCE{} operator
\begin{itemize}
\item
{\tt hyperterm(upper,lower,x,k)} that yields the hypergeometric term
\[
\frac
{(a_{1})_{k}\cdot(a_{2})_{k}\cdots(a_{p})_{k}}
{(b_{1})_{k}\cdot(b_{2})_{k}\cdots(b_{q})_{k}\,k!}x^{k}
\]
with upper parameters {\tt upper}$=\{a_{1}, a_{2}, \ldots, a_{p}\}$,
and lower parameters {\tt lower}$=\{b_{1}, b_{2}, \ldots, b_{q}\}$
\end{itemize}
in connection with hypergeometric terms.

The operator {\tt sumrecursion} can also be used to 
obtain three-term recurrence equations for systems of orthogonal polynomials
with the aid of known hypergeometric representations. By
(\cite{NSU}, (2.7.11a)), the discrete Krawtchouk polynomials $k_n^{(p)}(x,N)$
have the hypergeometric representation
\[
k_n^{(p)}(x,N)=
(-1)^n\,p^n\,{{N}\choose{n}}\;
_2 F_1\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{cc} -n\;, & -x \end{array}}\\[1mm]
\multicolumn{1}{c}{ -N}
            \end{array}
\!\!\!\!
\right| \frac{1}{p}\right)
\;,
\]
and therefore we declare

{\small
\begin{verbatim}
32: krawtchoukterm:=
    (-1)^n*p^n*binomial(NN,n)*hyperterm({-n,-x},{-NN},1/p,k)$
\end{verbatim}
}\noindent
and get the three three-term recurrence equations

{\small
\begin{verbatim}
33: sumrecursion(krawtchoukterm,k,n);

((2*p - 1)*n - nn*p - 2*p + x + 1)*sum(n - 1)

 - (n - nn - 2)*(p - 1)*sum(n - 2)*p - sum(n)*n

34: sumrecursion(krawtchoukterm,k,x);

(2*(x - 1)*p + n - nn*p - x + 1)*sum(x - 1)

 - ((x - 1) - nn)*sum(x)*p - (p - 1)*(x - 1)*sum(x - 2)

35: sumrecursion(krawtchoukterm,k,NN);

((p - 2)*nn + n + x + 1)*sum(nn - 1) + (n - nn)*(p - 1)*sum(nn)

 + (nn - x - 1)*sum(nn - 2)
\end{verbatim}
}\noindent
with respect to the parameters $n$, $x$, and $N$ respectively.

\section{\REDUCE{} operator {\tt HYPERSUM}}

With the operator {\tt hypersum}, hypergeometric sums are directly
evaluated in closed form whenever the extended 
Zeilberger algorithm leads to a recurrence equation containing only
two terms:
\begin{itemize}
\item
{\tt hypersum(upper,lower,x,n)} determines a closed form representation
for
$_{p}F_{q}\left.\left(\begin{array}{cccc}
a_{1},&a_{2},&\cdots,&a_{p}\\
b_{1},&b_{2},&\cdots,&b_{q}\\
            \end{array}\right| x\right)
$, where {\tt upper}$=\{a_{1}, a_{2}, \ldots, a_{p}\}$
is the list of upper parameters, and
{\tt lower}$=\{b_{1}, b_{2}, \ldots, b_{q}\}$
is the list of lower parameters depending on $n$. The result is given as a 
hypergeometric term with respect to $n$.  

If the result is a list of length $m$, we call it $m$-{\sl fold symmetric},
which is to be interpreted as follows:
Its $j^{th}$ part is the solution valid for all $n$ of the form $n=mk+j-1
\;(k\in\N_0)$.
In particular, if the resulting list contains two terms, then
the first part is the solution for even $n$, and the second part is the 
solution for odd $n$.
\end{itemize}
Examples \cite{Koepf}:

{\small
\begin{verbatim}
36: hypersum({a,1+a/2,c,d,-n},{a/2,1+a-c,1+a-d,1+a+n},1,n);

 pochhammer(a - c - d + 1,n)*pochhammer(a + 1,n)
-------------------------------------------------
 pochhammer(a - c + 1,n)*pochhammer(a - d + 1,n)

37: hypersum({a,1+a/2,d,-n},{a/2,1+a-d,1+a+n},-1,n);

  pochhammer(a + 1,n)
-------------------------
 pochhammer(a - d + 1,n)
\end{verbatim}
}\noindent
Note that the operator {\tt togamma} converts expressions given in
factorial-$\Gamma$-binomial-Pochhammer notation
into a pure $\Gamma$ function representation:

{\small
\begin{verbatim}
38: togamma(ws);

 gamma(a - d + 1)*gamma(a + n + 1)
-----------------------------------
 gamma(a - d + n + 1)*gamma(a + 1)
\end{verbatim}
}\noindent
Here are some $m$-fold symmetric results:

{\small
\begin{verbatim}
39: hypersum({-n,-n,-n},{1,1},1,n);

         n/2             2   n               1   n
  ( - 27)   *pochhammer(---,---)*pochhammer(---,---)
                         3   2               3   2
{----------------------------------------------------,
                              n  2
                   factorial(---)
                              2
 0}

40: hypersum({-n,n+3*a,a},{3*a/2,(3*a+1)/2},3/4,n);

                    2   n               1   n
        pochhammer(---,---)*pochhammer(---,---)
                    3   3               3   3
{-----------------------------------------------------,
              3*a + 2   n               3*a + 1   n
  pochhammer(---------,---)*pochhammer(---------,---)
                 3      3                  3      3
 0,

 0}
\end{verbatim}
}\noindent
These results correspond to the formulas (compare \cite{Koepf})
\[
_3 F_2\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{c}
-n\;, -n\;, -n
\end{array}}\\[1mm]
\multicolumn{1}{c}{\begin{array}{c}
1 \;, 1
            \end{array}}\end{array}
\!\!\!\!
\right| 1\right)
=
\funkdef{0}{n\;\mbox{odd}}{\displaystyle
\frac{(1/3)_{n/2}\,(2/3)_{n/2}}{(n/2)!^2}\,(-27)^{n/2}
}
\]
and
\[
_3 F_2\left.
\!\!
\left(
\!\!\!\!
\begin{array}{c}
\multicolumn{1}{c}{\begin{array}{c}
-n\;, n+3a\;, a
\end{array}}\\[1mm]
\multicolumn{1}{c}{\begin{array}{c}
3a/2\;,(3a+1)/2
            \end{array}}\end{array}
\!\!\!\!
\right| \frac{3}{4}\right)
=
\funkdef{0}{n\neq 0 {\mbox{ (mod }} 3)}{\displaystyle
\frac{(1/3)_{n/3}\,(2/3)_{n/3}}
{(a+1/3)_{n/3}\,(a+2/3)_{n/3}}
}
\!\!\!\!\!\!\!\!.
\]

\section{\REDUCE{} operator {\tt SUMTOHYPER}}

With the operator {\tt sumtohyper}, sums given in 
factorial-$\Gamma$-binomial-Poch\-hammer notation
are converted into hypergeometric notation.
\begin{itemize}
\item
{\tt sumtohyper(f,k)} determines the hypergeometric representation
of\linebreak
$\sum\limits_{k=-\infty}^\infty f_k$, i.\ e.\ 
its output is {\tt c*hypergeometric(upper,lower,x)}, corresponding to
the representation
\[
\sum\limits_{k=-\infty}^\infty f_k=c\cdot\;
_{p}F_{q}\left.\left(\begin{array}{cccc}
a_{1},&a_{2},&\cdots,&a_{p}\\
b_{1},&b_{2},&\cdots,&b_{q}\\
            \end{array}\right| x\right)
\;,
\]
where {\tt upper}$=\{a_{1}, a_{2}, \ldots, a_{p}\}$
and {\tt lower}$=\{b_{1}, b_{2}, \ldots, b_{q}\}$
are the lists of upper and lower parameters.
\end{itemize}
Examples:

{\small
\begin{verbatim}
41: sumtohyper(binomial(n,k)^3,k);

hypergeometric({ - n, - n, - n},{1,1},-1)

42: sumtohyper(binomial(n,k)/2^n-sub(n=n-1,binomial(n,k)/2^n),k);

                      - n + 2               - n
  - hypergeometric({----------, - n,1},{1,------},-1)
                        2                   2
------------------------------------------------------
                           n
                          2
\end{verbatim}
}\noindent


\section{Simplification Operators}
For the decision that an expression $a_k$ is a hypergeometric term, it is 
necessary to find out whether or not $a_{k}/a_{k-1}$ is a rational
function with respect to $k$. For the purpose to decide
whether or not an expression involving powers, factorials,
$\Gamma$ function terms, 
binomial coefficients, and Pochhammer symbols is a hypergeometric term,
the following simplification operators can be used:
\begin{itemize}
\item
{\tt simplify\verb+_+gamma(f)} simplifies an expression {\tt f} involving 
only rational, powers and $\Gamma$ function terms according to a recursive 
application of the simplification rule $\Gamma\:(a+1)=a\,\Gamma\:(a)$ 
to the expression tree. Since all $\Gamma$ arguments with integer difference
are transformed, this gives a decision procedure for rationality
for integer-linear $\Gamma$ term product ratios.
\item
{\tt simplify\verb+_+combinatorial(f)} simplifies an expression {\tt f} 
involving powers, factorials, $\Gamma$ function terms,
binomial coefficients, and Pochhammer symbols by converting
factorials, binomial coefficients, and Poch\-hammer symbols into 
$\Gamma$ function terms, and applying {\tt simplify\verb+_+gamma} to its
result. If the output is not rational,
it is given in terms of $\Gamma$ functions. If you prefer factorials
you may use
\item
{\tt gammatofactorial} (rule) converting $\Gamma$ function terms into
factorials using $\Gamma\:(x)\rightarrow (x-1)!$.
\item
{\tt simplify\verb+_+gamma2(f)}
uses the duplication formula of the $\Gamma$ function to simplify $f$.
\item
{\tt simplify\verb+_+gamman(f,n)}
uses the multiplication formula of the $\Gamma$ function to simplify $f$.
\end{itemize}
The use of {\tt simplify\verb+_+combinatorial(f)} is a safe way to
decide the rationality for any ratio of products of powers, factorials,
$\Gamma$ function terms, binomial coefficients, and Pochhammer symbols.

Example:

{\small
\begin{verbatim}
43: simplify_combinatorial(sub(k=k+1,krawtchoukterm)/krawtchoukterm);

  (k - n)*(k - x)
--------------------
 (k - nn)*(k + 1)*p
\end{verbatim}
}\noindent
From this calculation, we see again that the upper parameters of
the hypergeometric representation of the Krawtchouk polynomials are given by
$\{-n,-x\}$, its lower parameter is $\{-N\}$, and the argument of the
hypergeometric function is $1/p$.

Other examples are

{\small
\begin{verbatim}
44: simplify_combinatorial(binomial(n,k)/binomial(2*n,k-1));

  gamma( - (k - 2*n - 2))*gamma(n + 1)
----------------------------------------
 gamma( - (k - n - 1))*gamma(2*n + 1)*k

45: ws where gammatofactorial;

 factorial( - k + 2*n + 1)*factorial(n)
----------------------------------------
  factorial( - k + n)*factorial(2*n)*k

46: simplify_gamma2(gamma(2*n)/gamma(n));

  2*n        2*n + 1
 2   *gamma(---------)
                2
-----------------------
      2*sqrt(pi)

47: simplify_gamman(gamma(3*n)/gamma(n),3);

  3*n        3*n + 2          3*n + 1
 3   *gamma(---------)*gamma(---------)
                3                3
----------------------------------------
              2*sqrt(3)*pi
\end{verbatim}
}\noindent

\section{Tracing}
If you set 

{\small
\begin{verbatim}
48: on zb_trace;
\end{verbatim}
}\noindent
tracing is enabled, and you get intermediate results, see \cite{Koepf}. 

Example for the Gosper algorithm:

{\small
\begin{verbatim}
49: gosper(pochhammer(k-n,n),k);

                 k - 1
a(k)/a(k-1):= -----------
               k - n - 1

Gosper algorithm applicable

p:= 1

q:= k - 1

r:= k - n - 1

degreebound := 0

       1
f:= -------
     n + 1

Gosper algorithm successful

 pochhammer(k - n,n)*k
-----------------------
         n + 1
\end{verbatim}
}\noindent
\vspace*{3mm}\noindent
Example for the Zeilberger algorithm:

\vspace*{3mm}
{\footnotesize
\begin{verbatim}
50: sumrecursion(binomial(n,k)^2,k,n);

                       2
                      n
F(n,k)/F(n-1,k):= ----------
                          2
                   (k - n)

                              2
                   (k - n - 1)
F(n,k)/F(n,k-1):= --------------
                         2
                        k

Zeilberger algorithm applicable

applying Zeilberger algorithm for order:= 1

                 2                                    2    2
p:= zb_sigma(1)*k  - 2*zb_sigma(1)*k*n + zb_sigma(1)*n  + n

     2                  2
q:= k  - 2*k*n - 2*k + n  + 2*n + 1

     2
r:= k

degreebound := 1

     2*k - 3*n + 2
f:= ---------------
           n

           2        2        2              3      2
      - 4*k *n + 2*k  + 8*k*n  - 4*k*n - 3*n  + 2*n
p:= -------------------------------------------------
                            n

Zeilberger algorithm successful

4*sum(n - 1)*n - 2*sum(n - 1) - sum(n)*n

51: off zb_trace;
\end{verbatim}
}\noindent

\section{Global Variables and Switches}
The following global variables and switches can be used in connection with
the {\tt ZEILBERG} package:
\begin{itemize}
\item
{\tt zb\verb+_+trace}, switch; default setting {\tt off}. 
Turns tracing on and off.
\item
{\tt zb\verb+_+direction}, variable; settings: {\tt down}, {\tt up};
default setting {\tt down}. 

In the case of the Gosper algorithm, either a downward or a forward
antidifference is calculated, i.\ e., {\tt gosper} finds $g_k$ with either
\[
a_k=g_k-g_{k-1}
\quad\quad\mbox{or}\quad\quad
a_k=g_{k+1}-g_{k},
\]
respectively.

In the case of the Zeilberger algorithm, either a downward or an upward
recurrence equation is returned. Example:

{\small
\begin{verbatim}
52: zb_direction:=up$

53: sumrecursion(binomial(n,k)^2,k,n);

sum(n + 1)*n + sum(n + 1) - 4*sum(n)*n - 2*sum(n)

54: zb_direction:=down$
\end{verbatim}
}\noindent
\item
{\tt zb\verb+_+order}, variable; settings: any nonnegative integer;
default setting~{\tt 5}. 
Gives the maximal order for the recurrence
equation that {\tt sumrecursion} searches for.
\item
{\tt zb\verb+_+factor}, switch; default setting {\tt on}.
If {\tt off}, the factorization of the output usually producing nicer results
is suppressed.
\item
{\tt zb\verb+_+proof}, switch; default setting {\tt off}. If {\tt on},
then several intermediate results are stored in global variables:
\item
{\tt gosper\verb+_+representation}, variable; default setting {\tt nil}.

If a {\tt gosper} command is issued, and if the Gosper algorithm is applicable,
then the variable {\tt gosper\verb+_+representation} is set to the
list of polynomials (with respect to $k$) {\tt \{p,q,r,f\}}
corresponding to the representation
\[
\frac{a_k}{a_{k-1}}=\frac{p_k}{p_{k-1}}\,\frac{q_k}{r_k}
\;,
\quad\quad\quad
g_k=\frac{q_{k+1}}{p_k}\,f_k\,a_k
\;,
\]
see \cite{Gos}. Examples:

{\small
\begin{verbatim}
55: on zb_proof;

56: gosper(k*factorial(k),k);

(k + 1)*factorial(k)

57: gosper_representation;

{k,k,1,1}

58: gosper(
    1/(k+1)*binomial(2*k,k)/(n-k+1)*binomial(2*n-2*k,n-k),k);

((2*k - n + 1)*(2*k + 1)*binomial( - 2*(k - n), - (k - n))

 *binomial(2*k,k))/((k + 1)*(n + 2)*(n + 1))

59: gosper_representation;

{1,

 (2*k - 1)*(k - n - 2),

 (2*k - 2*n - 1)*(k + 1),

   - (2*k - n + 1)
 ------------------}
  (n + 2)*(n + 1)
\end{verbatim}
}\noindent
\item
{\tt zeilberger\verb+_+representation}, variable; default setting {\tt nil}.

If a {\tt sumrecursion} command is issued, and if the Zeilberger
algorithm is successful, then the variable 
{\tt zeilberger\verb+_+representation} is set to the final Gosper
representation used, see \cite{Koornwinder}.
\end{itemize}

\section{Messages}

The following messages may occur:
\begin{itemize}
\item
{\tt ***** Gosper algorithm:\ no closed form solution exists}

Example input:

{\tt gosper(factorial(k),k)}.
\item
{\tt ***** Gosper algorithm not applicable}

Example input:

{\tt gosper(factorial(k/2),k)}.

The term ratio $a_k/a_{k-1}$ is not rational.
\item
{\tt ***** illegal number of arguments}

Example input:

{\tt gosper(k)}.
\item
{\tt ***** Zeilberger algorithm fails.\ Enlarge zb\verb+_+order}

Example input:

{\tt sumrecursion(binomial(n,k)*binomial(6*k,n),k,n)}

For  this example a setting {\tt zb\verb+_+order:=6} is needed.
\item
{\tt ***** Zeilberger algorithm not applicable}

Example input:

{\tt sumrecursion(binomial(n/2,k),k,n)}

One of the term ratios $f(n,k)/f(n-1,k)$ or $f(n,k)/f(n,k-1)$
is not rational.
\item
{\tt ***** SOLVE given inconsistent equations}

You can ignore this message that occurs with Version 3.5.
\end{itemize}

\begin{thebibliography}{99}

\bibitem{Gos}
Gosper Jr., R.\ W.:
Decision procedure for indefinite hypergeometric
summation. Proc.\ Natl.\ Acad.\ Sci.\ USA {\bf 75}, 1978, 40--42.

\bibitem{Koepf}
Koepf, W.:
Algorithms for the indefinite and definite summation.
Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-33, 1994.

\bibitem{Koornwinder}
Koornwinder, T.\ H.:
On Zeilberger's algorithm and its $q$-analogue: a rigorous description.
J.\ of Comput.\ and Appl.\ Math.\ {\bf 48}, 1993, 91--111.

\bibitem{NSU}
Nikiforov, A.\ F., Suslov, S.\ K,\ and Uvarov, V.\ B.: {\sl Classical
orthogonal polynomials of a discrete variable.} Springer-Verlag,
Berlin--Heidelberg--New York, 1991.

\bibitem{PS}
Paule, P.\ and Schorn, M.: A {\sc Mathematica} version of Zeilberger's
algorithm for proving binomial coefficient identities. J.\ Symbolic
Computation, 1994, to appear.

\bibitem{SR}
Problem 94--2, SIAM Review {\bf 36}, March 1994.

\bibitem{Strehl2}
Strehl, V.:
Binomial sums and identities. Maple Technical Newsletter {\bf 10}, 1993, 37--49.

\bibitem{Wil1}
Wilf, H.\ S.:
{\sl Generatingfunctionology}. Academic Press, Boston, 1990.

\bibitem{Wilf}
Wilf, H.\ S.:
Identities and their computer proofs. ``SPICE'' Lecture Notes,
August 31--September 2, 1993.
Anonymous ftp file {\tt pub/wilf/lecnotes.ps} on
the server {\tt ftp.cis.upenn.edu}.

\bibitem{Zei2}
Zeilberger, D.:
A fast algorithm for proving terminating hypergeometric identities.
Discrete Math.\ {\bf 80}, 1990, 207--211.

\bibitem{Zei3}
Zeilberger, D.:
The method of creative telescoping.
J.\ Symbolic Computation {\bf 11}, 1991, 195--204.

\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/sum/sum.tst0000644000175000017500000000651011526203062022652 0ustar  giovannigiovanni% Tests of the SUM package.

% Author: Fujio Kako (kako@kako.math.sci.hiroshima-u.ac.jp)

% 1) Summations.

sum(n,n);

for i:=2:10 do write sum(n**i,n);

sum((n+1)**3,n);

sum(x**n,n);

sum(n**2*x**n,n);

sum(1/n,n);

sum(1/n/(n+2),n);

sum(log (n/(n+1)),n);

% 2) Expressions including trigonometric functions.

sum(sin(n*x),n);

sum(n*sin(n*x),n,1,k);

sum(cos((2*r-1)*pi/n),r);

sum(cos((2*r-1)*pi/n),r,1,n);

sum(cos((2*r-1)*pi/(2*n+1)),r);

sum(cos((2*r-1)*pi/(2*n+1)),r,1,n);

sum(sin((2*r-1)*x),r,1,n);

sum(cos((2*r-1)*x),r,1,n);

sum(sin(n*x)**2,n);

sum(cos(n*x)**2,n);

sum(sin(n*x)*sin((n+1)*x),n);

sum(sec(n*x)*sec((n+1)*x),n);

sum(1/2**n*tan(x/2**n),n);

sum(sin(r*x)*sin((r+1)*x),r,1,n);

sum(sec(r*x)*sec((r+1)*x),r,1,n);

sum(1/2**r*tan(x/2**r),r,1,n);

sum(k*sin(k*x),k,1,n - 1);

sum(k*cos(k*x),k,1,n - 1);

sum(sin((2k - 1)*x),k,1,n);

sum(sin(x + k*y),k,0,n);

sum(cos(x + k*y),k,0,n);

sum((-1)**(k - 1)*sin((2k - 1)*x),k,1,n + 1);

sum((-1)**(k - 1)*cos((2k - 1)*x),k,1,n + 1);

sum(r**k*sin(k*x),k,1,n - 1);

sum(r**k*cos(k*x),k,0,n - 1);

sum(sin(k*x)*sin((k + 1)*x),k,1,n);

sum(sin(k*x)*sin((k + 2)*x),k,1,n);

sum(sin(k*x)*sin((2k - 1)*x),k,1,n);


% The next examples cannot be summed in closed form.

sum(1/(cos(x/2**k)*2**k)**2,k,1,n);

sum((2**k*sin(x/2**k)**2)**2,k,1,n);

sum(tan(x/2**k)/2**k,k,0,n);

sum(cos(k**2*2*pi/n),k,0,n - 1);

sum(sin(k*pi/n),k,1,n - 1);

% 3) Expressions including the factorial function.

for all n,m such that fixp m let
	factorial(n+m)=if m > 0 then factorial(n+m-1)*(n+m)
		   else factorial(n+m+1)/(n+m+1);

sum(n*factorial(n),n);

sum(n/factorial(n+1),n);

sum((n**2+n-1)/factorial(n+2),n);

sum(n*2**n/factorial(n+2),n);

sum(n*x**n/factorial(n+2),n);

for all n,m such that fixp m and m > 3 let
	factorial((n+m)/2)= factorial((n+m)/2-1)*((n+m)/2),
	factorial((n-m)/2)= factorial((n-m)/2+1)/((n-m)/2+1);

sum(factorial(n-1/2)/factorial(n+1),n);

for all n,m such that fixp m and m > 3 clear factorial((n+m)/2);

for all n,m such that fixp m and m > 3 clear factorial((n-m)/2);

% 4) Expressions including combination.

operator comb;          % Combination function.

for all n ,m let comb(n,m)=factorial(n)/factorial(n-m)/factorial(m);

sum((-1)**k*comb(n,k),k,1,m);

sum(comb(n + p,q)/comb(n + r,q + 2),n,1,m);

sum((-1)**(k + 1)*comb(n,k)/(k + 1),k,1,n);

for all n ,m clear comb(n,m);

for all n,m such that fixp m clear factorial(n+m);

% 3) Examples taken from
%         "Decision procedure for indefinite hypergeometric summation"
%          Proc. Natl. Acad. Sci. USA  vol. 75, no. 1 pp.40-42 (1978)
%          R. William Gosper, Jr.
%

%            n
%           ____     2
%       f =  ||  (b*k +c*k+d)
%           k=1
%
%            n
%           ____     2
%       g =  ||  (b*k +c*k+e)
%           k=1
%
operator f,gg;  % gg used to avoid possible conflict with high energy
		% physics operator.

for all n,m such that fixp m let
        f(n+m)=if m > 0 then f(n+m-1)*(b*(n+m)**2+c*(n+m)+d)
                   else f(n+m+1)/(b*(n+m+1)**2+c*(n+m+1)+d);

for all n,m such that fixp m let
	gg(n+m)=if m > 0 then gg(n+m-1)*(b*(n+m)**2+c*(n+m)+e)
		   else gg(n+m+1)/(b*(n+m+1)**2+c*(n+m+1)+e);

sum(f(n-1)/gg(n),n);

sum(f(n-1)/gg(n+1),n);

for all n,m such that fixp m clear f(n+m);

for all n,m such that fixp m clear gg(n+m);

clear f,gg;

% 4) Products.

prod(n/(n+2),n);

prod(x**n,n);

prod(e**(sin(n*x)),n);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/redfront/0000755000175000017500000000000011722677360022345 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redfront/redfront.red0000644000175000017500000001767111526203062024662 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: redfront.red 730 2010-08-27 06:24:43Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(redfront_rcsid!* redfront_copyright!*);
   redfront_rcsid!* := "$Id: redfront.red 730 2010-08-27 06:24:43Z thomas-sturm $";
   redfront_copyright!* := "(c) 1999-2009 A. Dolzmann and T. Sturm"
>>;


module coloutput;

fluid '(posn!* orig!*);

procedure redfront_oh(m,l);
   begin scalar outputhandler!*;
      if m eq 'maprin then
         if ofl!* or posn!* neq orig!* then
            maprin l
               else <<
            redfront_on();
             assgnpri(l,nil,nil);
            redfront_off()
         >>
      else if m eq 'prin2!* then
         prin2!* l
      else if m eq 'terpri then
         terpri!* l
      else
         rederr {"unknown method ",m," in redfront_oh"}
   end;

procedure redfront_on();
   <<
      terpri!* nil;
      prin2 int2id 3;
      terpri!* nil
   >>;

procedure redfront_off();
   <<
      terpri!* nil;
      prin2 int2id 4
   >>;

procedure redfront_formwrite(u,vars,mode);
   % Workaround to avoid linebreaks with "write 1,2,3". This is based
   % on a patch of the original formwrite(), which TS wanted to avoid.
   begin scalar z;
      z := formwrite(u,vars,mode);
      if null z then return nil;
      return {'cond,
         {{'and,{'eq,'outputhandler!*,'(quote redfront_oh)},'(not ofl!*)},
            {'prog,'(outputhandler!*),'(redfront_on),z,'(redfront_off)}},
         {t,z}}
   end;

put('write,'formfn,'redfront_formwrite);

outputhandler!*:='redfront_oh;

endmodule;  % coloutput;

module redfront;

fluid '(promptstring!* redfront_switches!* redfront_switches!-this!-sl!*
   lispsystem!* breaklevel!* input!-libraries output!-library);

redfront_switches!* := {!*msg,!*output};

off1 'msg;
off1 'output;

procedure redfront_pslp();
   'psl memq lispsystem!*;

if redfront_pslp() then <<
   redfront_switches!-this!-sl!* := {!*usermode};
   off1 'usermode
>>;

procedure redfront_color(c);
   if stringp c then
      compress('!" . int2id 1 .
               reversip('!" . int2id 2 . cdr reversip cdr explode c))
   else
      intern compress(int2id 1 . nconc(explode c,{int2id 2}));

procedure redfront_uncolor(c);
   if stringp c then
      compress('!" . reversip('!" . cddr reversip cddr explode c))
   else
      intern compress('!! . reversip cdr reversip cdr explode c);

procedure redfront_setpchar!-psl(c);
   begin scalar w;
      w := redfront_setpchar!-orig c;
      promptstring!* := redfront_color promptstring!*;
      return redfront_uncolor w
   end;

procedure redfront_setpchar!-csl(c);
   redfront_uncolor redfront_setpchar!-orig redfront_color c;

copyd('redfront_setpchar!-orig,'setpchar);

if redfront_pslp() then
   copyd('setpchar,'redfront_setpchar!-psl)
else
   copyd('setpchar,'redfront_setpchar!-csl);

procedure redfront_yesp!-psl(u);
   begin scalar ifl,ofl,x,y;
      if ifl!* then <<
         ifl := ifl!* := {car ifl!*,cadr ifl!*,curline!*};
         rds nil
      >>;
      if ofl!* then <<
         ofl:= ofl!*;
          wrs nil
      >>;
      if null !*lessspace then
          terpri();
      if atom u then
          prin2 u
      else
          lpri u;
      if null !*lessspace then
          terpri();
      y := setpchar "?";
      x := yesp1();
      setpchar y;
      if ofl then wrs cdr ofl;
      if ifl then rds cadr ifl;
      cursym!* := '!*semicol!*;
      return x
   end;

if redfront_pslp() then <<
   remflag('(yesp),'lose);
   copyd('redfront_yesp!-orig,'yesp);
   copyd('yesp,'redfront_yesp!-psl);
   flag('(yesp),'lose)
>>;

% Color PSL prompts, in case user falls through:

procedure redfront_compute!-prompt!-string(count,level);
   redfront_color redfront_compute!-prompt!-string!-orig(count,level);

if redfront_pslp() then <<
   copyd('redfront_compute!-prompt!-string!-orig,'compute!-prompt!-string);
   copyd('compute!-prompt!-string,'redfront_compute!-prompt!-string)
>>;

procedure redfront_break_prompt();
   <<
      prin2 "break["; prin2 breaklevel!*; prin2 "]";
      promptstring!* := redfront_color promptstring!*
   >>;

if redfront_pslp() then <<
   copyd('break_prompt,'redfront_break_prompt);
   flag('(break_prompt),'lose);
>>;

if redfront_pslp() then
   onoff('usermode,car redfront_switches!-this!-sl!*);

% Support for editline completion

procedure redfront_learncolor(c);
   if stringp c then
      compress('!" . int2id 5 .
               reversip('!" . int2id 6 . cdr reversip cdr explode c))
   else
      intern compress(int2id 5 . nconc(explode c,{int2id 6}));

if redfront_pslp() then <<
   fluid '(l);
   lispeval '(putd 'oblist 'expr
      '(lambda nil (prog (l) (setq l nil)
   	       	     	     (mapobl (function (lambda (x) (setq l (cons x l)))))
	                     (return l))));
   compile '(oblist)
>>;

procedure redfront_swl();
   begin scalar swl;
      swl := for each x in oblist() join if flagp(x,'switch) then {x};
      return sort(swl,'ordp)
   end;

procedure redfront_send!-switches();
   <<
      for each sw in redfront_swl() do
	 prin2t redfront_learncolor sw;
      statcounter := statcounter - 1;
      nil
   >>;

procedure redfront_modl();
   begin scalar libl,l;
      if redfront_pslp() then
      	 return nil;
      libl := input!-libraries;
      if output!-library then
	 libl := output!-library . libl;
      l := for each x in libl join library!-members x;
      return sort(l,'ordp)
   end;

procedure redfront_send!-modules();
   <<
      for each mod in redfront_modl() do
	 prin2t redfront_learncolor mod;
      statcounter := statcounter - 1;
      nil
   >>;

procedure redfront_read_package_map(fn);
   % This is essentially stolen from csl/cslbase/buildreduce.lsp ...
   begin scalar i,w,e,basel,extral;
      % Configuration information is held in a file called something like
      % "package.map".
      i := fn;
      i := open(i, 'input);
      i := rds i;
      e := !*echo;
      !*echo := nil;
      w := read();
      !*echo := e;
      i := rds i;
      close i;
      basel := for each x in w join
	 if member('core, cddr x) then
	    {car x};
      extral := for each x in w join
	 if not member('core, cddr x) then
 	    {car x};
      return basel . extral
   end;

procedure redfront_send!-packages(fn);
   <<
      for each pack in cdr redfront_read_package_map fn do
	 prin2t redfront_learncolor pack;
      statcounter := statcounter - 1;
      nil
   >>;

onoff('msg,car redfront_switches!*);
onoff('output,cadr redfront_switches!*);

crbuf!* := nil;
inputbuflis!* := nil;
lessspace!* := t;
statcounter := 0;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/wu/0000755000175000017500000000000011722677364021161 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/wu/wu.red0000644000175000017500000003677111526203062022304 0ustar  giovannigiovannimodule wu;   % Simple implementation of the Wu algorithm.

% Author: Russell Bradford
%         School of Mathematical Sciences
%         University of Bath
%         Bath
%         Avon BA2 7AY
%         United Kingdom
%         E-mail: rjb@maths.bath.ac.uk

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% First distributed version: 8 July 90
% Bug fixes in wupseudodivide, and misc other changes: 28 Aug 90

% This is a simple implementation of the Wu algorithm, intended to help
% myself understand the method.  As such, there is little optimization,
% and indeed, only implements the basic version from
%
% "A Zero Structure Theorem for Polynomial-Equations-Solving",
%  Wu Wen-tsun, Institute of Systems Science, Academia Sinica, Beijing

% Interface:
% much as the Groebner basis package:
%
% wu({x*y-a, x^y+y^2-b}, {x, y});
%
% uses Wu on the named polynomials with ordering on the variables x > y.
% returns a list of pairs { characteristic set, initial }
%
% { {{a^2 - b*y^2 + y^4}, y} }
%
% The zeros of the input polynomials are the the union of the zeros of
% the characteristic sets, subject to the initials being non-zero.
% Thus the zeros of {x*y-a, x^y+y^2-b} are the zeros of
% {a^2 - b*y^2 + y^4, a - x*y} subject to y neq 0.
%
% The switch
%
% on trwu;
%
% prints some tracing of the algorithm as it works, in particular the
% choice of basic sets, and the computation of characteristic sets.

% This package runs on Reduce 3.3.

% Keywords: polynomial reduction characteristic set sets initial
%           ascending
% chrstrem Wu

% All improvements and bug fixes are welcomed!!

% Possible bug fixes, improvements:
% Should use distributed polys, then class is an integer;
% rather than use union, use an insertion sort;
% return a list of {{polys},{initials}};
% fix pseudo divide for when there is a non-trivial content in the
%   remainder;
% many opportunities for reusing data from a previous iteration, e.g.,
%   when a new polynomial added into a basic set is less than all
%   current members of the basic set, and they are reduced wrt it.
% factor out monomials and numeric contents

create!-package('(wu),'(contrib misc));

fluid '(!*trwu !*trchrstrem wuvarlist!* kord!*);

switch trwu, trchrstrem;

procedure wuconstantp f;
   % A constant is a poly that does not involve any of the interesting
   % variables.
   domainp f or not memq(mvar f, wuvarlist!*);

smacro procedure wuclass f;
  if wuconstantp f then nil else mvar f;

smacro procedure wudeg f;
  if wuconstantp f then 0 else ldeg f;

smacro procedure wuinitial f;
  if wuconstantp f then f else lc f;

procedure wureducedpolysp(f, polylist);
% if f reduced wrt the polys in polylist?
  null polylist or
  (wureducedp(f, car polylist) and wureducedpolysp(f, cdr polylist));

procedure wureducedp(g, f);
% is g reduced wrt f?
  wuconstantp f or
  wuconstantp g or
  deginvar(g, wuclass f) < ldeg f;

procedure deginvar(f, x);
% the degree of x in f
  if wuconstantp f then 0
  else if mvar f = x then ldeg f
  else begin scalar kord!*;
    kord!* := list x;
    f := reorder f;
    return if mvar f = x then ldeg f else 0
  end;

% wukord* = '(x y a) means: all other symbols < x < y < a
fluid '(wukord!*);

procedure symbollessp(x, y);
% an ordering on symbols: Cambs lisp and PSL orderp differ on nils
  if null y then nil
  else if null x then t
  else if wukord!* then wuorderp(x, y)
  else not orderp(x, y);

procedure wuorderp(x, y);
% an order on the symbols has been specified
% return T if x < y
% circumlocutions abound
begin scalar kord, answ;
   if x eq y then return nil;
   kord := wukord!*;
   while kord and not answ do
     if x eq car kord
       then answ := if memq(y, cdr kord) then 'yes else 'no
     else if y eq car kord
       then answ := if memq(x, cdr kord) then 'no else 'yes
     else kord := cdr kord;
   return if answ then answ eq 'yes else not orderp(x, y)
end;

smacro procedure classlessp(c1, c2);
% an order on classes, which are symbols in this implementation
  symbollessp(c1, c2);

procedure wulessp(f, g);
% standard forms f and g
% a partial order
  classlessp(wuclass f, wuclass g) or
  (wuclass f = wuclass g and wudeg f < wudeg g);

procedure wulessp!*(f, g);
% as above, but use some arbitrary means to complete to a total order
  if wulessp(f, g) then t
  else if wulessp(g, f) then nil
  else totallessp(f, g);

smacro procedure nil2zero f;
  f or 0;

procedure totallessp(f, g);
% a total order on polynomials
  totalcompare(f, g) = 'less;

procedure totalcompare(f, g);
% order f and g
% horrid bit of code
  if f = g then 'equal
  else if wulessp(f, g) then 'less
  else if wulessp(g, f) then 'greater
  else if wuconstantp f then                % and so wuconstantp g
    totalcompareconstants(f, g)
  else begin scalar answ;
    answ := totalcompare(lc f, lc g);
    if answ neq 'equal then return answ;
    return totalcompare(red f, red g)
  end;

procedure totalcompareconstants(f, g);
% order the constants f and g
  if f = g then 'equal
  else if domainp f then
    if domainp g then      % Assumption of ints
      if nil2zero f < nil2zero g then 'less else 'greater
    else 'less
  else if domainp g then 'greater
  else begin scalar wukord!*, wuvarlist!*, answ;
    if symbollessp(mvar f, mvar g) then return 'less
    else if symbollessp(mvar g, mvar f) then return 'greater
    else answ := totalcompareconstants(lc f, lc g);
    if answ neq 'equal then return answ;
    return totalcompareconstants(red f, red g)
  end;

procedure wusort polylist;
% sort a list of polys into Wu order
  sort(polylist, 'wulessp!*);

procedure collectvars polylist;
% make a list of the variables appearing in the list of polys
begin scalar varlist;
  varlist := for each poly in polylist conc collectpolyvars poly;
  return sort(union(varlist, nil), 'symbollessp)
end;

procedure collectpolyvars poly;
  collectpolyvarsaux(poly, nil);

procedure collectpolyvarsaux(poly, sofar);
  if domainp poly then sofar
  else union(
         union(sofar, list mvar poly),
         union(collectpolyvarsaux(lc poly, nil),
               collectpolyvarsaux(red poly, nil)));

procedure pickbasicset polylist;
% find a basic set from the ordered list of polys
begin scalar basicset;
  foreach var in wuvarlist!* do <<
    while polylist and symbollessp(mvar car polylist, var) do
      polylist := cdr polylist;
    while polylist and var = mvar car polylist and
          not wureducedpolysp(car polylist, basicset) do
      polylist := cdr polylist;
    if polylist and var = mvar car polylist then <<
      basicset := car polylist . basicset;
      polylist := cdr polylist
    >>
  >>;
  return reversip basicset
end;

procedure wupseudodivide(f, g, x);
% not a true pseudo divide---multiply f by the smallest power
% of lc g necessary to make a fraction-free division
begin scalar origf, oldkord, lcoeff, degf, degg, answ, fudge;
  origf := f;
  oldkord := setkorder list x;
  f := reorder f;
  if wuconstantp f or mvar f neq x then <<
    setkorder oldkord;
    return nil . origf
  >>;
  g := reorder g;
  if wuconstantp g or mvar g neq x then <<
    f := multf(f, quotf(g, gcdf!*(lc f, g)));
    setkorder oldkord;
    return reorder f . nil
  >>;
  degf := ldeg f;
  degg := ldeg g;
  if degf - degg + 1 < 0 then <<
    setkorder oldkord;
    return nil . origf
  >>;
  lcoeff := lc g;
  lcoeff := exptf(lcoeff, degf - degg + 1);
  answ := qremf(multf(lcoeff, f), g);
  fudge := gcdf!*(gcdf!*(lcoeff, cdr answ), car answ);
  answ := quotf(car answ, fudge) . quotf(cdr answ, fudge);
  setkorder oldkord;
  return reorder car answ . reorder cdr answ;
end;

procedure simpwupseudodivide u;
begin scalar f, g, x, answ;
  f := !*a2f car u;
  g := !*a2f cadr u;
  x := if cddr u then !*a2k caddr u else mvar f;
  answ := wupseudodivide(f, g, x);
  return list('list, mk!*sq !*f2q car answ,
                     mk!*sq !*f2q cdr answ)
end;

put('wudiv, 'psopfn, 'simpwupseudodivide);

procedure findremainder(f, polylist);
% form the Wu-remainder of f wrt those polys in polylist
<< foreach poly in polylist do
     f := cdr wupseudodivide(f, poly, mvar poly);
   f
>>;

procedure prin2t!* u;
% a useful procedure
<< prin2!* u;
   terpri!* t
>>;

procedure chrstrem polylist;
% polylist a list of polynomials, to be Wu'd
% horrible circumlocutions here
begin scalar revbasicset, pols, rem, remainders;

  if !*trwu or !*trchrstrem then <<
    terpri!* t;
    prin2t!* "--------------------------------------------------------";
  >>;

  repeat <<
    polylist := wusort polylist;

    if !*trwu or !*trchrstrem then <<
      prin2t!* "The new pol-set in ascending order is";
      foreach poly in polylist do printsf poly;
      terpri!* t;
    >>;

    if wuconstantp car polylist then <<
      if !*trwu then prin2t!* "which is trivially trivial";
      remainders := 'inconsistent;
      revbasicset := list 1;
    >>
    else <<
      remainders := nil;
      % Keep in reverse order.
      revbasicset := reversip pickbasicset polylist;
    >>;

    if !*trwu and null remainders then <<
      prin2t!* "A basic set is";
      foreach poly in reverse revbasicset do printsf poly;
      terpri!* t;
    >>;

    pols := setdiff(polylist, revbasicset);
    foreach poly in pols do
      if remainders neq 'inconsistent then <<

        if !*trwu then <<
          prin2!* "The remainder of ";
          printsf poly;
          prin2!* "wrt the basic set is "
        >>;

        rem := findremainder(poly, revbasicset);

        if !*trwu then <<
          printsf rem;
        >>;

        if rem then
          if wuconstantp rem then <<
            remainders := 'inconsistent;

            if !*trwu then <<
              prin2t "which is a non-zero constant, and so";
              prin2t "the equations are inconsistent."
            >>

          >>
          else remainders := union(list absf rem, remainders);
      >>;
    if remainders and remainders neq 'inconsistent then
      polylist := append(polylist, remainders)
  >> until null remainders or remainders = 'inconsistent;

  if remainders = 'inconsistent then revbasicset := list 1;

  if !*trwu or !*trchrstrem then <<
    terpri!* t;terpri!* t;
    prin2t!* "The final characteristic set is:";
    foreach poly in reverse revbasicset do printsf poly
  >>;

  return reversip foreach poly in revbasicset collect absf poly
end;

procedure simpchrstrem u;
begin scalar answ, polylist, wuvarlist!*;
  polylist := foreach f in u collect !*a2f f;
  wuvarlist!* := colectvars polylist;
  answ := chrstrem polylist;
  return 'list . foreach f in answ collect mk!*sq !*f2q f;
end;

put('chrstrem, 'psopfn, 'simpchrstrem);

procedure wu(polylist, varlist);
% Do the Wu algorithm.
% Vars in varlist arranged in increasing order.
% Return (((poly, poly, ... ) . initial) ... ), a list of characteristic
% sets dotted onto the product of their initials.
% Very parallelizable.
  begin scalar stufftodo, answ, polset, chrset, initialset, initial,
        wuvarlist!*;
  stufftodo := list delete(nil,
                       union(foreach poly in polylist collect absf poly,
                             nil));
  if null car stufftodo then <<
    if !*trwu then prin2t!* "trivial CHS";
    return list(list nil . 1);
  >>;
  if null varlist then <<
    if !*trwu then prin2t!* "trivial CHS";
    return list(list 1 . 1);
  >>;
  wuvarlist!* := varlist;
  while stufftodo do <<
     polset := wusort car stufftodo;
     stufftodo := cdr stufftodo;
     chrset := chrstrem polset;
     if chrset neq '(1) then <<
       initialset := foreach pol in chrset collect wuinitial pol;
       initial := 1;
       foreach pol in initialset do initial := multf(initial, pol);

       if !*trwu then <<
         prin2!* "with initial ";
         printsf initial;
       >>;

       if member(initial, chrset) then <<
         if !*trwu then prin2t!*
           "which we discard, as the initial is a member of the CHS";
       >>
       else answ := union(list(chrset . initial), answ);

       foreach initial in initialset do
         if not wuconstantp initial then <<
           if member(initial, polset) then <<
             prin2t!*
            "*** Something awry: the initial is a member of the polset";
             answ := union(list(polset . 1), answ) % unsure of this one.
           >>
           else stufftodo := union(list wusort(initial . polset),
                                   stufftodo)
         >>
     >>
  >>;
  if null answ then answ := list(list 1 . 1);

  if !*trwu then <<
    terpri!* t;terpri!* t;
    prin2t!* "--------------------------------------------------------";
    prin2t!* "Final result:";
    foreach zset in answ do <<
      prin2t!* "Ascending set";
      foreach f in car zset do printsf f;
      prin2!* "with initial ";
      printsf cdr zset;
      terpri!* t
    >>
  >>;

  return answ;
end;

procedure simpwu u;
% rebind kord* to reflect the wu order of kernels
begin scalar pols, vars, oldkord, answ, nargs;
  nargs := length u;
  if nargs = 0 or nargs > 2 then
    rederr "Wu called with wrong number of arguments";

  pols := aeval car u;
  if nargs = 2 then vars := aeval cadr u;
  if (nargs = 1 and not eqcar(pols, 'list)) or
     (nargs = 2 and not eqcar(vars, 'list)) then
    rederr "Wu: syntax wu({poly, ...}) or wu({poly, ...}, {var, ...})";

  oldkord := kord!*;

  if nargs = 1 then
    begin scalar kord!*, polset, vars;
      kord!* := if wukord!* then reverse wukord!* else oldkord;
      polset := foreach f in cdr pols collect reorder !*a2f f;
      vars := collectvars polset;

      if !*trwu then <<
        terpri!* t;
        prin2!* "Wu variables in decreasing order: ";
        foreach id in reverse vars do <<
          prin2!* id;
          prin2!* " "
        >>;
        terpri!* t
      >>;

      answ := wu(polset, vars)
    end
  else     % nargs = 2
    begin scalar kord!*, polset, wukord!*;
      kord!* := foreach k in cdr vars collect !*a2k k;
      wukord!* := reverse kord!*;
      polset := foreach f in cdr pols collect reorder !*a2f f;
      answ := wu(polset, wukord!*)
    end;

    return 'list . foreach zset in answ collect
             'list . list('list . foreach f in car zset collect
                                  mk!*sq !*f2q absf reorder f,
                          mk!*sq !*f2q absf reorder cdr zset)
end;

put('wu, 'psopfn, 'simpwu);
remprop('wu, 'number!-of!-args);

%procedure wukord u;
%% hack to specify order of kernels in Wu
%% wukord a,y,x => other kernels < a < y < x
%  wukord!* := if u = '(nil) then nil
%              else foreach x in u collect !*a2k x;
%
%rlistat '(wukord);

algebraic;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/wu/wu.tst0000644000175000017500000000167711526203062022341 0ustar  giovannigiovanni% wu.tst

% Russell Bradford, 8 June 90.

% Some tests for the Wu algorithm
% The order directives are not necessary for general use: they just
% help tie things down for testing purposes.

% run after loading Wu code: in "wu.red"$

% test 1

order x,y,a,b;

wu({x^2+y^2-a,x*y-b}, {x,y});

% test 2

order x,y,a,b;

wu({x^2+y^2-a,x*y-b},{x,y,a,b});

% test 3

order x,y,z,r;

wu({x^2+y^2+z^2-r^2, x*y+z^2-1, x*y*z-x^2-y^2-z+1}, {x,y,z});

% test 4

order x,y,z,r;

wu({x^2+y^2+z^2-r^2, x*y+z^2-1, x*y*z-x^2-y^2-z+1}, {x,y,z,r});

% test 5

order x,y,z;

wu({(x-1)*(y-1)*(z-1), (x-2)*(y-2)*(z-2), (x-3)*(y-3)*(z-3)}, {x,y,z});

% test 6

order x,y,z;

wu({(x-1)*(y-1)*(z-1), (x-2)*(y-2)*(z-2), (x-3)*(y-3)*(z-3)});

% test 7

order x1,x2,x3,x4;

p1 := x1+x2+x3+x4;
p2 := x1*x2+x2*x3+x3*x4+x4*x1;
p3 := x1*x2*x3+x2*x3*x4+x3*x4*x1+x4*x1*x2;
p4 := x1*x2*x3*x4 - 1;

wu({p1,p2,p3,p4}, {x1,x2,x3,x4});

% test 8

order x,y,z;

wu({z*z,y*z-1,x*z-1}, {x,y,z});

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/wu/wu.rlg0000644000175000017500000001521311527635055022316 0ustar  giovannigiovanniFri Feb 18 21:28:55 2011 run on win32
% wu.tst

% Russell Bradford, 8 June 90.

% Some tests for the Wu algorithm
% The order directives are not necessary for general use: they just
% help tie things down for testing purposes.

% run after loading Wu code: in "wu.red"$

% test 1

order x,y,a,b;



wu({x^2+y^2-a,x*y-b}, {x,y});


       4    2      2
{{{ - y  + y *a - b , - x*y + b},

  y}}


% test 2

order x,y,a,b;



wu({x^2+y^2-a,x*y-b},{x,y,a,b});


           2
{{{b,y, - x  + a},1},

       4    2      2
 {{ - y  + y *a - b , - x*y + b},

  y}}


% test 3

order x,y,z,r;



wu({x^2+y^2+z^2-r^2, x*y+z^2-1, x*y*z-x^2-y^2-z+1}, {x,y,z});


    3    2    2
{{{z  - z  + r  - 1,

       4    2  2    2  2    2      2        2
    - y  - y *z  + y *r  + z  + z*r  - z + r  - 2,

          2
   x*y + z  - 1},

  y},

    7    6      5    4  2    4    3      2  2    2    2
 {{z  - z  - 2*z  + z *r  + z  + z  - 2*z *r  + z  + r  - 1,

    2   3    2    2
   y *(z  - z  + r  - 1),

          2
   x*y + z  - 1},

      3    2    2
  y*(z  - z  + r  - 1)}}


% test 4

order x,y,z,r;



wu({x^2+y^2+z^2-r^2, x*y+z^2-1, x*y*z-x^2-y^2-z+1}, {x,y,z,r});


    3    2    2
{{{z  - z  + r  - 1,

       4    2  2    2  2    2      2        2
    - y  - y *z  + y *r  + z  + z*r  - z + r  - 2,

          2
   x*y + z  - 1},

  y},

    4      2
 {{r  - 4*r  + 3,

        2
   z + r  - 2,

   y,

       2    2
    - x  + r  - 1},

  1},

    7    6      5    4  2    4    3      2  2    2    2
 {{z  - z  - 2*z  + z *r  + z  + z  - 2*z *r  + z  + r  - 1,

    2   3    2    2
   y *(z  - z  + r  - 1),

          2
   x*y + z  - 1},

      3    2    2
  y*(z  - z  + r  - 1)}}


% test 5

order x,y,z;



wu({(x-1)*(y-1)*(z-1), (x-2)*(y-2)*(z-2), (x-3)*(y-3)*(z-3)}, {x,y,z});


    2
{{{z  - 5*z + 6,

       2        2
   2*(y *z - 3*y  - 4*y*z + 12*y + 3*z - 9),

   x*y*z - 3*x*y - 3*x*z + 9*x - 3*y*z + 9*y + 9*z - 27},

        2                    2
  2*(y*z  - 6*y*z + 9*y - 3*z  + 18*z - 27)},

 {{z - 3,y - 2,2*(x - 1)},2},

             2
 {{z - 3,2*(y  - 3*y + 2),x*y - 2*x - 2*y + 4},

  2*(y - 2)},

 {{2*(z - 3),2*(y - 2),4*(x - 1)},16},

                 2
 {{2*(z - 3),4*(y  - 3*y + 2),2*(x*y - 2*x - 2*y + 4)},

  16*(y - 2)},

    2
 {{z  - 5*z + 6,

   y*z - 3*y - 3*z + 9,

   2*(x*z - 3*x - z + 3)},

      2
  2*(z  - 6*z + 9)},

       3      2
 {{2*(z  - 6*z  + 11*z - 6),

   y*z - 3*y - 3*z + 9,

      2                    2
   x*z  - 5*x*z + 6*x - 2*z  + 10*z - 12},

      3      2
  2*(z  - 8*z  + 21*z - 18)},

       3      2
 {{4*(z  - 6*z  + 11*z - 6),

    2  2      2        2        2                      2
   y *z  - 5*y *z + 6*y  - 5*y*z  + 25*y*z - 30*y + 6*z  - 30*z + 36,

   x*y*z - 3*x*y - 3*x*z + 9*x - 3*y*z + 9*y + 9*z - 27},

        3        2                      3       2
  4*(y*z  - 8*y*z  + 21*y*z - 18*y - 3*z  + 24*z  - 63*z + 54)}}


% test 6

order x,y,z;



wu({(x-1)*(y-1)*(z-1), (x-2)*(y-2)*(z-2), (x-3)*(y-3)*(z-3)});


    2
{{{z  - 5*z + 6,

       2        2
   2*(y *z - 3*y  - 4*y*z + 12*y + 3*z - 9),

   x*y*z - 3*x*y - 3*x*z + 9*x - 3*y*z + 9*y + 9*z - 27},

        2                    2
  2*(y*z  - 6*y*z + 9*y - 3*z  + 18*z - 27)},

 {{z - 3,y - 2,2*(x - 1)},2},

             2
 {{z - 3,2*(y  - 3*y + 2),x*y - 2*x - 2*y + 4},

  2*(y - 2)},

 {{2*(z - 3),2*(y - 2),4*(x - 1)},16},

                 2
 {{2*(z - 3),4*(y  - 3*y + 2),2*(x*y - 2*x - 2*y + 4)},

  16*(y - 2)},

    2
 {{z  - 5*z + 6,

   y*z - 3*y - 3*z + 9,

   2*(x*z - 3*x - z + 3)},

      2
  2*(z  - 6*z + 9)},

       3      2
 {{2*(z  - 6*z  + 11*z - 6),

   y*z - 3*y - 3*z + 9,

      2                    2
   x*z  - 5*x*z + 6*x - 2*z  + 10*z - 12},

      3      2
  2*(z  - 8*z  + 21*z - 18)},

       3      2
 {{4*(z  - 6*z  + 11*z - 6),

    2  2      2        2        2                      2
   y *z  - 5*y *z + 6*y  - 5*y*z  + 25*y*z - 30*y + 6*z  - 30*z + 36,

   x*y*z - 3*x*y - 3*x*z + 9*x - 3*y*z + 9*y + 9*z - 27},

        3        2                      3       2
  4*(y*z  - 8*y*z  + 21*y*z - 18*y - 3*z  + 24*z  - 63*z + 54)}}


% test 7

order x1,x2,x3,x4;



p1 := x1+x2+x3+x4;


p1 := x1 + x2 + x3 + x4

p2 := x1*x2+x2*x3+x3*x4+x4*x1;


p2 := x1*x2 + x1*x4 + x2*x3 + x3*x4

p3 := x1*x2*x3+x2*x3*x4+x3*x4*x1+x4*x1*x2;


p3 := x1*x2*x3 + x1*x2*x4 + x1*x3*x4 + x2*x3*x4

p4 := x1*x2*x3*x4 - 1;


p4 := x1*x2*x3*x4 - 1


wu({p1,p2,p3,p4}, {x1,x2,x3,x4});


         4
{{{x4*(x4  - 1),

     2
   x4 *(x3 - x4),

     2    2               2
   x4 *(x2  + 2*x2*x4 + x4 ),

     2
   x4 *(x1 + x2 + 2*x4)},

    6
  x4 },

     4
 {{x4  - 1,

     2
   x4 *(x3 - x4),

           2               2
   2*x4*(x2  + 2*x2*x4 + x4 ),

     2
   x4 *(x1 + x2 + 2*x4)},

      5
  2*x4 },

     4
 {{x4  - 1,

   x3 - x4,

     2               2
   x2  + 2*x2*x4 + x4 ,

   x1 + x2 + 2*x4},

  1},

     4
 {{x4  - 1,

     2     2
   x3  - x4 ,

           2        3        3
   x2*x3*x4  - x2*x4  + x3*x4  - 1,

                             2
   x1*x3 - x1*x4 - x3*x4 + x4 },

    2    2               2
  x4 *(x3  - 2*x3*x4 + x4 )},

     8       4
 {{x4  - 2*x4  + 1,

     2     2
   x3  - x4 ,

           2        3        3
   x2*x3*x4  - x2*x4  + x3*x4  - 1,

        4             4
   x1*x4  - x1 + x3*x4  - x3},

    2       4          5
  x4 *(x3*x4  - x3 - x4  + x4)},

     2    4
 {{x4 *(x4  - 1),

     3
   x4 *(x3 - x4),

     3    2               2
   x4 *(x2  + 2*x2*x4 + x4 ),

     3
   x4 *(x1 + x2 + 2*x4)},

    9
  x4 },

         4
 {{x4*(x4  - 1),

     3
   x4 *(x3 - x4),

       2    2               2
   2*x4 *(x2  + 2*x2*x4 + x4 ),

     3
   x4 *(x1 + x2 + 2*x4)},

      8
  2*x4 },

     4
 {{x4  - 1,

   x4*(x3 - x4),

         2               2
   x4*(x2  + 2*x2*x4 + x4 ),

   x4*(x1 + x2 + 2*x4)},

    3
  x4 },

         4
 {{x4*(x4  - 1),

     2    2     2
   x4 *(x3  - x4 ),

               2        3        3
   x4*(x2*x3*x4  - x2*x4  + x3*x4  - 1),

                                 2
   x4*(x1*x3 - x1*x4 - x3*x4 + x4 )},

    6    2               2
  x4 *(x3  - 2*x3*x4 + x4 )},

         8       4
 {{x4*(x4  - 2*x4  + 1),

     2    2     2
   x4 *(x3  - x4 ),

               2        3        3
   x4*(x2*x3*x4  - x2*x4  + x3*x4  - 1),

            4             4
   x4*(x1*x4  - x1 + x3*x4  - x3)},

    6       4          5
  x4 *(x3*x4  - x3 - x4  + x4)},

     3   2     2   3
 {{x3 *x4  + x3 *x4  - x3 - x4,

        2        2     2        3
   x2*x3  - x2*x4  + x3 *x4 - x4 ,

        2   2        4     2   3        4
   x1*x3 *x4  - x1*x4  - x3 *x4  - x3*x4  + x3 + x4},

    4    4       2   2     4
  x4 *(x3  - 2*x3 *x4  + x4 )}}


% test 8

order x,y,z;



wu({z*z,y*z-1,x*z-1}, {x,y,z});


{{{1},1}}


end;


Time for test: 32 ms
@@@@@ Resources used: (0 0 8 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/wu/wu.tex0000644000175000017500000000651311526203062022321 0ustar  giovannigiovanni\documentstyle[fullpage]{article}

\pagestyle{empty}
\setlength{\parindent}{0in}
\setlength{\parskip}{0.1in}

\begin{document}
\title{An Implementation of the Wu Algorithm}
\author{Russell Bradford \\
School of Mathematical Sciences,\\
University of Bath,\\
Claverton Down,\\
Bath, BA2 7AY \\
\tt rjb@maths.bath.ac.uk}
\date{}
\maketitle\thispagestyle{empty}

This is a simple implementation of the Wu algorithm implemented in Reduce
3.3, working directly from
``A Zero Structure Theorem for Polynomial-Equations-Solving,''
Wu Wen-tsun, Institute of Systems Science, Academia Sinica, Beijing.

Its purpose was to aid my understanding of the algorithm, so the code is
simple, and has a lot of tracing included. This is a working implementation,
but there is magnificent scope for improvement and optimisation. Things
like using intelligent sorts on polynomial lists, and avoiding the
re-computation of various data spring easily to mind. Also, an attempt
at factorization of the input polynomials at each pass might have beneficial
results. Of course, exploitation of the natural parallel structure is a must!

All bug fixes and improvements are welcomed.

The interface:
\begin{verbatim}
wu( {x^2+y^2+z^2-r^2, x*y+z^2-1, x*y*z-x^2-y^2-z+1}, {x,y,z});
\end{verbatim}
calls {\tt wu} with the named polynomials, and with the variable ordering
${\tt x} > {\tt y} > {\tt z}$. In this example, {\tt r} is a parameter.

The result is
\begin{verbatim}
    2    3    2
{{{r  + z  - z  - 1,

    2  2    2      2    4    2  2    2
   r *y  + r *z + r  - y  - y *z  + z  - z - 2,

          2
   x*y + z  - 1},

  y},

    6  4      6  2    6      4  7      4  6      4  5      4  4
 {{r *z  - 2*r *z  + r  + 3*r *z  - 3*r *z  - 6*r *z  + 3*r *z  + 3*

    4  3      4  2      4      2  10      2  9      2  8      2  7
   r *z  + 3*r *z  - 3*r  + 3*r *z   - 6*r *z  - 3*r *z  + 6*r *z  +

       2  6      2  5      2  4      2  3      2    13      12    11
    3*r *z  + 6*r *z  - 6*r *z  - 6*r *z  + 3*r  + z   - 3*z   + z

         10    9      8      7    6      4      3    2
    + 2*z   + z  + 2*z  - 6*z  - z  + 2*z  + 3*z  - z  - 1,

    2   2    3    2
   y *(r  + z  - z  - 1),

          2
   x*y + z  - 1},

      2    3    2
  y*(r  + z  - z  - 1)}}
\end{verbatim}
namely, a list of pairs of characteristic sets and initials for the
characteristic sets.

Thus, the first pair above has the characteristic set
$$ r^2 + z^3 - z^2 - 1,
r^2 y^2 + r^2 z + r^2 - y^4 - y^2 z^2 + z^2 - z - 2,
x y + z^2 - 1$$
and initial $y$.

According to Wu's theorem, the set of roots of the original polynomials
is the union of the sets of roots of the characteristic sets,
with the additional constraints that the
corresponding initial is non-zero. Thus, for the first pair above, we find the
roots of $\{ r^2 + z^3 - z^2 - 1, \ldots~\}$ under the constraint that
$y \neq 0$. These roots, together with the roots of the other
characteristic set (under the constraint of $y(r^2+z^3-z^2-1) \neq 0$),
comprise all the roots of the original set.

Additional information about the working of the algorithm can be gained by
\begin{verbatim}
on trwu;
\end{verbatim}
This prints out details of the choice of basic sets, and the computation
of characteristic sets.

The second argument (the list of variables) may be omitted, when all the
variables in the input polynomials are implied with some random ordering.
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/0000755000175000017500000000000011722677364021261 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/cgb.tst0000644000175000017500000000676111526203062022540 0ustar  giovannigiovanni% Examples taken from the manual:

% 1 Introduction
oo := torder({x,y},lex)$
cgb {a*x,x+y};
gsys {a*x,x+y};
torder oo;

% 4 CGB: Comprehensive Groebner Basis
oo := torder({x,y},lex)$
cgb {a*x+y,x+b*y};
torder oo;

% 5 GSYS: Groebner System
oo := torder({x,y},lex)$
gsys {a*x+y,x+b*y};
torder oo;

% 6 GSYS2CGB: Groebner System to CGB
oo := torder({x,y},lex)$
gsys {a*x+y,x+b*y};
gsys2cgb ws;
torder oo;

% 7 Switch CGBREAL: Computing over the Real Numbers
oo := torder({x,y},lex)$
off cgbreal;
gsys {a*x+y,x-a*y};
on cgbreal;
gsys({a*x+y,x-a*y});
torder oo;

% Miscellaneous examples:

% Dolzmann's Example
oo := torder({x,y,z},lex);
cgb({a*x+b*y,c*x+d*y,(a*d-b*c)*z});
gsys({a*x+b*y,c*x+d*y,(a*d-b*c)*z});
gsys2cgb ws;
torder oo;

% Forsman's Example (hybrid control system).
oo := torder({x1,x2,y2,y1,y0},lex);
gsys({(u1*u2-u1)*x1+u2*x2+y2,(u2-1)*x1+u2*x2+y1,-x2+y0});
torder oo;

% Weispfenning's Example
oo := torder({x,y},lex);
gsys({v*x*y + x,u*y^2 + x^2});
torder oo;

% The folllowing three examples are taken from
% Weispfenning, Comprehensive Groebner Bases,
% J. Symbolic Computation (1992) 14, 1-29

% Weispfenning's Example 7.1
oo := torder({x},lex);
gsys({a0*x**2 + a1*x + a2,b0*x**2 + b1*x + b2});
torder oo;

% Weispfenning's Example 7.2
oo := torder({x,y},lex);
gsys({v*x*y + u*x**2 + x,u*y**2 + x**2});
torder oo;

% Weispfenning's Example 7.3
oo := torder({x1,x2,x3,x4},lex);
gsys {x4 - (a4-a2),x1 + x2 + x3 + x4 + (a1 + a3 + a4),
   x1*x3 + x1*x4 + x2*x3 + x3*x4 - (a1*a4 + a1*a3 + a3*a4),x1*x3*x4 - a1*a3*a4};
torder oo;

% Pesch's example (Circle through three points)
oo := torder({y,x},revgradlex);
gsys({2*b2*y + 2*a2*x - b2**2 + a2**2,2*b1*y + 2*a1*x - b1**2 + a1**2});
torder oo;

% Effelterre's example (Aspect graphs)
f1 := -4-4*v**2-4*u**2+40*v*v1+24*v-120*v1+8*u-40*v2-68*v1**2-100*v2**2+40*u*v2+
24*v1*v2-4*v1**2*u-4*v2**2*v**2+24*v2**2*v-24*v1*u*v2+8*v*v1*u*v2$
f2 := 8*v*v1*u*v2-4*v1**2*u**2+4*v1**2-4*v2**2*v**2+4*v2**2-16*v**2-16*u**2+16$
f3 := 16*v-48*u+16*v*v1**2-48*u*v2**2-12*v1**2*u+4*v2**2*v-36*v*v1*v2+
12*v1*u*v2+12*v*v2**2*u-
80*u*v1+80*v2*v-20*v1*u*v2**2+20*v2*v*v1**2-20*v1**3*u+20*v2**3*v-12*v1**2*v*u+
12*v2*v**2*v1-12*v1*u**2*v2$
f4 := -160u*v2-1596v2**2+3200*v2-1596-4*u**2+160*u$

% Special case I2, v1=0
oo := torder({v,u},lex);
gsys(sub(v1=0,{f1,f2,f4}));
torder oo;
clear f1,f2,f3,f4;

% Sit's Example 2.2
oo := torder({z2,z2},revgradlex);
gsys({d*z2 + c*z1 - v,b*z2 + a*z1 - u});
torder oo;

% Sit's Example 2.3
oo := torder({z2,z2},revgradlex);
gsys({x**3*z2 + (x**2+1)*z1,x**2*z2 + x*z1 - 1});
torder oo;

% Sit's Example 3.3
oo := torder({z3,z2,z2},revgradlex);
gsys({z3 + b*z2 + a*z1 - 1,a*z3 + z2 + b*z1 - 1,b*z3 + a*z2 + z1 - 1});
torder oo;

% Sit's Example 8.3
oo := torder({z4,z3,z2,z2},revgradlex);
gsys({z4 + c*z3 + b*z2 + a*z1 - w2,2*z4 + z2 - w1,a*z4 - z3 - w4,d*z4 + z3 +
2*z1 - w3,z4 + z1 - w5});
torder oo;

% Two dimensional transportation problem
oo := torder({x33,x32,x31,x23,x22,x21,x13,x12,x11},lex);
gsys({x11+x12+x13-a1,x11+x21+x31-b1,x12+x22+x32-b2,x13+x23+x33-b3,
x21+x22+x23-a2,x31+x32+x33-a3});
torder oo;

% Thomas Weis's Example 1
oo := torder({x,y,z},lex);
gsys({z*y*x-b*y*x-b*z*x+b**2*x-b*z*y+b**2*y+b**2*z-(n3+b**3),
z*y*x-a*y*x-a*z*x+a**2*x-a*z*y+a**2*y+a**2*z-(n3+a**3),
z*y*x-n1});
torder oo;

% Thomas Weis's Example 2
oo := torder({z,y,x,w},lex);
gsys({w*x*y*z-x*y*z-w*y*z+y*z-w*x*z+x*z+w*z-z-w*x*y+x*y+w*y-
y+w*x-x-w-(b-1),
w*x*y*z-2*x*y*z-2*w*y*z+4*y*z-2*w*x*z+4*x*z+4*w*z-8*z-2*w*x*y+4x*y+
4*w*y-8*y+4*w*x-8*x-8*w-(c-16),
w*x*y*z-a,z+y+x+w-v});
torder oo;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/svdp.red0000644000175000017500000001436011526203062022713 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: svdp.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(svdp_rcsid!* svdp_copyright!*);
   svdp_rcsid!* := "$Id: svdp.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   svdp_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module svdp;
% Sound (small) vdp.
% Implementation of vdp's containing only three fields for the dip, the
% vdp number and the sugar.

load!-package 'dp;

fluid '(!*gsugar vdp_pcount!*);

procedure vdp_lbc(u);
   cadar u;

procedure vdp_evlmon(u);
   caar u;

procedure vdp_poly(u);
   car u;

procedure vdp_zero!?(u);
   null car u;

procedure vdp_number(f);
   cadr f;

procedure vdp_sugar(f);
   if car f then cddr f else 0;

procedure vdp_unit!?(p);
   car p and ev_zero!? caar p;

procedure vdp_tdeg(u);
   dip_tdeg car u;

procedure vdp_fdip(u);
   u . ('invalid . 'invalid);

procedure vdp_appendmon(vdp,coef,vev);
   % Add a monomial to the end of a vdp (vev remains unchanged).
   if null car vdp then
      vdp_fmon(coef,vev)
   else if bc_zero!? coef then
      vdp
   else
      vdp_fdip dip_appendmon(vdp_poly vdp,coef,vev);

procedure vdp_nconcmon(vdp,coef,vev);
   if null car vdp then
      vdp_fmon(coef,vev)
   else if bc_zero!? coef then
      vdp
   else
      vdp_fdip dip_nconcmon(vdp_poly vdp,coef,vev);

procedure vdp_bcquot(p,c);
   begin scalar r;
      r := vdp_fdip dip_bcquot(vdp_poly p,c);
      if !*gsugar then
 	 vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_content(p);
   dip_contenti vdp_poly p;

procedure vdp_content1(d,c);
   dip_contenti1(vdp_poly d,c);

procedure vdp_length(f);
   dip_length vdp_poly f;

procedure vdp_bcprod(p,b);
   begin scalar r;
      r := vdp_fdip dip_bcprod(vdp_poly p,b);
      if !*gsugar then
 	 vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_cancelmev(p,vev);
   begin scalar r;
      r := vdp_fdip dip_cancelmev(vdp_poly p,vev);
      if !*gsugar then
 	 vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_sum(d1,d2);
   begin scalar r;
      r := vdp_fdip dip_sum(vdp_poly d1,vdp_poly d2);
      if !*gsugar then
	 % 	 vdp_setsugar(r,max(vdp_sugar d1,vdp_sugar d2));
 	 vdp_setsugar(r,max!#(vdp_sugar d1,vdp_sugar d2));
      return r
   end;

procedure max!#(a,b);
   if a #> b then a else b;

procedure vdp_prod(d1,d2);
   begin scalar r;
      r := vdp_fdip dip_prod(vdp_poly d1,vdp_poly d2);
      if !*gsugar then
 	 vdp_setsugar(r,vdp_sugar d1 #+ vdp_sugar d2);
      return r
   end;

procedure vdp_zero();
   vdp_fdip nil;

procedure vdp_mred(u);
   begin scalar r;
      r := vdp_fdip dip_mred vdp_poly u;
      if !*gsugar then
	 vdp_setsugar(r,vdp_sugar u);
      return r
   end;

procedure vdp_condense(f);
   dip_condense vdp_poly f;

procedure vdp_setsugar(p,s);
   <<
      cddr p := s;
      p
   >>;

procedure vdp_setnumber(p,n);
   <<
      cadr p := n;
      p
   >>;

procedure vdp_fmon(coef,vev);
   begin scalar r;
      r := vdp_fdip dip_fmon(coef,vev);
      if !*gsugar then
 	 vdp_setsugar(r,ev_tdeg vev);
      return r
   end;

procedure vdp_2a(u);
   dip_2a vdp_poly u;

procedure vdp_2f(u);
   dip_2f vdp_poly u;

procedure vdp_init(vars);
   % Initializing vdp-dip polynomial package.
   dip_init vars;

procedure vdp_cleanup();
   dip_cleanup();

procedure vdp_f2vdp(u);
   vdp_fdip dip_f2dip u;

procedure vdp_enumerate(f);
   % f is a temporary result. Prepare it for medium range storage and
   % assign a number.
   if vdp_zero!? f or vdp_number f then
      f
   else
      vdp_setnumber(f,vdp_pcount!* := vdp_pcount!* #+ 1);

procedure vdp_simpcont(p);
   begin scalar q;
      q := vdp_poly p;
      if null q then
 	 return p;
      return vdp_fdip dip_simpcont q
   end;

procedure vdp_lsort(pl);
   % Distributive polynomial list sort. pl is a list of distributive
   % polynomials. vdplsort(pl) returns the sorted distributive
   % polynomial list of pl.
   sort(pl,function vdp_evlcomp);

procedure vdp_evlcomp(p1,p2);
   dip_evlcomp(vdp_poly p1,vdp_poly p2);

procedure vdp_ilcomb1(v1,c1,t1,v2,c2,t2);
   begin scalar r;
      r := vdp_fdip dip_ilcomb1(vdp_poly v1,c1,t1,vdp_poly v2,c2,t2);
      if !*gsugar then
 	 vdp_setsugar(r,max!#(vdp_sugar v1 #+ ev_tdeg t1,vdp_sugar v2 #+ ev_tdeg t2));
      return r
   end;

procedure vdp_ilcomb1r(v1,c1,v2,c2,t2);
   begin scalar r;
      r := vdp_fdip dip_ilcomb1r(vdp_poly v1,c1,vdp_poly v2,c2,t2);
      if !*gsugar then
 	 vdp_setsugar(r,max!#(vdp_sugar v1,vdp_sugar v2 #+ ev_tdeg t2));
      return r
   end;

procedure vdp_make(vbc,vev,form);
   rederr "vdp_make not supported by fast vdp";

procedure vdp_putprop(poly,prop,val);
   rederr "vdp_putrop not supported by fast vdp";

procedure vdp_getprop(poly,prop);
   rederr "vdp_getprop not supported by fast vdp";

endmodule;  % svdp

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/dp.red0000644000175000017500000006523411526203062022350 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: dp.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(dp_rcsid!* dp_copyright!*);
   dp_rcsid!* := "$Id: dp.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   dp_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module dp;

fluid '(kord!*);

fluid '(dip_evlist!* dip_vars!* dip_sortmode!* dip_sortevcomp!*
   dip_sortextension!* vdpsortmode!* vdpsortextension!* global!-dipvars!*);

fluid '(td_vars!* td_sortmode!* td_sortextension!* !*tdusetorder);
td_vars!* := '(list);

td_sortmode!* := 'revgradlex;
   
put('td,'psopfn,'td_torder);

flag('(xrevgradlex revgradlex lex),'dipsortmode);
put('revgradlex,'ev_comp,'ev_revgradlexcomp);
put('lex,'ev_comp,'ev_lexcomp);
put('xrevgradlex,'ev_comp,'ev_xrevgradlexcomp);

switch tdusetorder;

on1 'tdusetorder;

endmodule;  % dp

module bcsq;

procedure bc_zero();
   nil ./ 1;

procedure bc_zero!?(u);
   null numr u;

procedure bc_abs(u);
   absf numr u ./ denr u;

procedure bc_one!?(u);
   numr u = 1 and denr u = 1;

procedure bc_2sq(u);
   u;

procedure bc_a2bc(u);
   % Converts the algebraic (kernel) u into a base coefficient.
   simp!* u;

procedure bc_fd(a);
   % Base coefficient from domain element.
   a ./ 1;

procedure bc_neg(u);
   % Base coefficient negative. u is a base coefficient. bc_neg(u)
   % returns the negative of the base coefficient u, a base
   % coefficient.
   negsq u;

procedure bc_prod(a,b);
   if denr a = 1 and numberp numr a and denr b = 1 and numberp numr b then
      if numr a = 1 then
	 b
      else if numr b = 1 then
	 a
      else if (a := times2(numr a,numr b)) = 0 then
	 nil ./ 1
      else
	 a ./ 1
   else
      multsq(a,b);

%% procedure bc_quot(a,b);
%%    if denr a = 1 and numberp numr a and denr b = 1 and numberp numr b then
%%       if numr b = 1 then
%% 	 a
%%       else if (a := quotientx(numr a,numr b)) = 0 then
%% 	 nil ./ 1
%%       else
%% 	 a ./ 1
%%    else
%%       quotsq(a,b);

procedure bc_quot(a,b);
   quotsq(a,b);

procedure bc_sum(a,b);
   % Base coefficient sum. u and v are base coefficients. bcsum(u,v)
   % calculates u+v and returns a base coefficient.
   if denr a = 1 and numberp numr a and denr b = 1 and numberp numr b then
      if (a := plus2(numr a,numr b)) = 0 then
	 nil ./ 1
      else
	 a ./ 1
   else
      addsq(a,b);

procedure bc_pmon(var,dg);
   % Parameter monomial.
   var .** dg .* 1 .+ nil ./ 1;


procedure bc_minus!?(u);
   % Boolean function. Returns true if u is a negative base coeff.
   if fixp numr u then
      numr u < 0
   else
      minusf numr u;

procedure bc_2a(u);
   % Returns the prefix equivalent of the base coefficient u.
   prepsq u;

procedure bc_gcd(u,v);
   if denr u = 1 and denr v = 1 then
      if fixp numr u and fixp numr v then
 	 gcdn(numr u,numr v) ./ 1
      else
      	 gcdf!*(numr u,numr v) ./ 1
   else
      1 ./ 1;

procedure bc_mkat(op,bc);
   {op,numr bc,nil};

procedure bc_dcont(bc);
   sfto_dcontentf numr bc;

procedure bc_2d(bc);
   numr bc or 0;

procedure bc_vars(bc);
   union(kernels numr bc,kernels denr bc);

endmodule;  % bcsq

module ev;

procedure ev_max!#(a,b);
   if a #> b then a else b;

procedure ev_init();
   ;

procedure ev_member(ev,evl);
   ev member evl;

procedure ev_divides!?(ev1,ev2);
   ev_mtest!?(ev2,ev1);

procedure ev_sdivp(ev1,ev2);
   ev1 neq ev2 and ev_divides!?(ev1,ev2);

procedure ev_xrevgradlexcomp(e1,e2);
   % Exponent vector reverse graduated lex compare. The exponent
   % vectors e1 and e2 are in reverse graduated lex ordering.
   % evRevGradLexcomp(e1,e2) returns the digit 0 if exponent vector e1
   % is equal exponent vector e2, the digit 1 if e1 is greater than
   % e2, else the digit -1.
   begin scalar te1,te2;
      if null e1 then
      	 return 0;
      if car e1 #= car e2 then
      	 return ev_xrevgradlexcomp(cdr e1,cdr e2);
      te1 := ev_tdeg e1;
      te2 := ev_tdeg e2;
      if te1 #= te2 then
	 return if car e1 #< car e2 then 1 else -1;
      return if te1 #> te2 then 1 else -1
   end;

procedure ev_lexcomp(e1,e2);
   % Exponent vector lexicographical compare. The exponent vectors e1
   % and e2 are in lexicographical ordering. evLexComp(e1,e2) returns
   % the digit 0 if exponent vector e1 is equal exponent vector e2,
   % the digit 1 if e1 is greater than e2, else the digit -1. */
   if null e1 then
      0
   else if car e1 #= car e2 then
      ev_lexcomp(cdr e1,cdr e2)
   else if car e1 #> car e2 then
      1
   else
      -1;

procedure ev_revgradlexcomp(e1,e2);
   % Exponent vector reverse graduated lex compare. The exponent
   % vectors e1 and e2 are in reverse graduated lex ordering.
   % evRevGradLexcomp(e1,e2) returns the digit 0 if exponent vector e1
   % is equal exponent vector e2, the digit 1 if e1 is greater than
   % e2, else the digit -1.
   begin scalar te1,te2;
      if null e1 then
      	 return 0;
      if car e1 #= car e2 then
	 return ev_revgradlexcomp(cdr e1, cdr e2);
      te1 := ev_tdeg e1;
      te2 := ev_tdeg e2;
      if te1 #= te2 then
 	 return ev_invlexcomp(e1,e2);
      if te1 #> te2 then
 	 return 1;
      return -1
   end;

procedure ev_invlexcomp(e1,e2);
   % Exponent vector inverse lexicographical compare. No term order!
   begin scalar n;
      if null e1 then
	 return 0;
      if car e1 #= car e2 then
 	 return ev_invlexcomp(cdr e1,cdr e2);  % sic!
      n := ev_invlexcomp(cdr e1,cdr e2);
      if not (n #= 0) then
 	 return n;
      if car e2 #= car e1 then
 	 return 0;
      if car e2 #> car e1 then
 	 return 1;
      return -1
   end;

procedure ev_mtest!?(e1,e2);
   % Exponent vector multiple test. e1 and e2 are compatible exponent
   % vectors. vevmtest?(e1,e2) returns a boolean expression. True if
   % exponent vector e1 is a multiple of exponent vector e2, else
   % false.
   begin scalar r;
      r := t;
      while e1 and r do <<
	 if car e1 #< car e2 then
	    e1 := r := nil
	 else <<
	    e1 := cdr e1;
	    e2 := cdr e2
	 >>
      >>;
      return r
   end;
      
procedure ev_2a(e);
   % Returns list of prefix equivalents of exponent vector e.
   ev_2a1(e,dip_vars!*);

procedure ev_2a1(u,v);
   if null u then
      nil
   else if car u #= 0 then
      ev_2a1(cdr u,cdr v)
   else if car u #= 1 then
      car v . ev_2a1(cdr u,cdr v)
   else
      {'expt,car v,car u} . ev_2a1(cdr u,cdr v);

procedure ev_2f(ev,vars);
   if null ev then
      1
   else if car ev #= 0 then
      ev_2f(cdr ev,cdr vars)
   else
      multf(car vars .** car ev .* 1 .+ nil,ev_2f(cdr ev,cdr vars));

procedure ev_lcm(e1,e2);
   % Exponent vector least common multiple. e1 and e2 are exponent
   % vectors. ev_lcm(e1,e2) computes the least common multiple of the
   % exponent vectors e1 and e2, and returns an exponent vector.
   begin scalar x;
      while e1 do <<
	 x := (if car e1 #> car e2 then car e1 else car e2) . x;
	 e1 := cdr e1;
 	 e2 := cdr e2
      >>;
      return reversip x
   end;

procedure ev_zero();
   for each x in dip_vars!* collect 0;

procedure ev_zero!?(ev);
   null ev or (car ev=0 and ev_zero!? cdr ev);

procedure ev_compless!?(e1,e2);
   ev_comp(e2,e1) #= 1;

procedure ev_comp(e1,e2);
   % Exponent vector compare. e1, e2 are exponent vectors in some
   % order. Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is
   % equal exponent vector e2, the digit 1 if e1 is greater than e2,
   % else the digit -1. This function is assigned a value by the
   % ordering mechanism, so is dummy for now. IDapply would be better
   % here, but is not within standard LISP!
   apply(dip_sortevcomp!*,{e1,e2});

procedure ev_insert(ev,v,dg,vars);
   % f to dip conversion: Insert the "dg" into the ev in the place of
   % variable v.
   if null ev or null vars then
      nil
   else if car vars eq v then
      dg . cdr ev
   else
      car ev . ev_insert(cdr ev,v,dg,cdr vars);

procedure ev_tdeg(u);
   % calculate the total degree of u.
   begin integer x;
      while u do <<
	 x := car u #+ x;
 	 u := cdr u
      >>;
      return x
   end;

procedure ev_dif(e1,e2);
   begin scalar s;
      while e1 do <<
	 s := (car e1 #- car e2) . s;
	 e1 := cdr e1;
	 e2 := cdr e2
      >>;
      return reversip s
   end;

procedure ev_sum(e1,e2);
   begin scalar s;
      while e1 do <<
	 s := (car e1 #+ car e2) . s;
	 e1 := cdr e1;
	 e2 := cdr e2
      >>;
      return reversip s
   end;

procedure ev_disjointp(e1,e2);
   % nonconstructive test of lcm(e1,e2) = e1 + e2 equivalent: no
   % matches of nonzero elements.
   if null e1 then
      t
   else if (car e1 neq 0) and (car e2 neq 0) then
      nil
   else
      ev_disjointp(cdr e1,cdr e2);

procedure ev_identify(oev,nev);
   nev;

endmodule;  % ev

module dip;

procedure dip_fmon(a,e);
   % Distributive polynomial from monomial. a is a base coefficient
   % and e is an exponent vector. dip_fmon(a,e) returns a distributive
   % polynomial with e as exponent vector and a as base coefficient.
   e . a . nil;

procedure dip_moncomp(a,e,p);
   % Distributive polynomial monomial composition. a is a base
   % coefficient, e is an exponent vector and p is a distributive
   % polynomial. dipmoncomp(a,e,p) returns a distributive polynomial
   % with p as monomial reductum, e as exponent vector of the leading
   % monomial and a as leading base coefficient.
   e . a . p;

procedure dip_mred(p);
   % Distributive polynomial reductum. p is a distributive polynomial
   % dipmred(p) returns the reductum of the distributive polynomial p,
   % a distributive polynomial.
   cddr p;

procedure dip_lbc(p);
   % Distributive polynomial leading base coefficient. p is a
   % distributive polynomial. dip_lbc(p) returns the leading base
   % coefficient of p.
   cadr p;

procedure dip_evlmon(p);
   % Distributive polynomial exponent vector leading monomial. p is a
   % distributive polynomial. dipevlmon(p) returns the exponent vector
   % of the leading monomial of p.
   car p;

procedure dip_init(newvars,newsortmode,newsortextension);
   % Initializing dip polynomial package. [newvars] is a list of
   % variables, [newsortmode] is an identifier; [newsortextension] is
   % a list of extra arguments for the term order [newsortmode].
   % Returns a list $(v,o,x,c,l)$, where $v$ is the old list of main
   % variables, $o$ is the old term oredring, $x$ is the old list extra
   % arguments, $c$ is the old comparison procedure, and $l$ is the
   % old list of saved exponent vectors. The returned list is suitable
   % as argument to dip_cleanup.
   begin scalar vars,sortmode,sortextension,sortevcomp,evlist,newsortevcomp,z;
      if not idp newsortmode or not flagp(newsortmode,'dipsortmode) then
 	 return typerr(newsortmode,"term ordering mode");
      % following saves thousands of calls to GET:
      newsortevcomp := get(newsortmode,'ev_comp);
      if not getd newsortevcomp then
	 rederr "dip_init: no comparison routine found";
      if (z := get(newsortmode,'evcompinit)) then
 	 apply(z,nil);
      if (z := get(newsortmode,'evlength)) and z neq length newvars then
 	 rederr "dip_init: wrong variable number for fixed length term order";
      vars := dip_vars!*;
      sortmode := dip_sortmode!*;
      sortextension := dip_sortextension!*;
      sortevcomp := dip_sortevcomp!*;
      evlist := dip_evlist!*;
      dip_vars!* := newvars;
      dip_sortmode!* := newsortmode;
      dip_sortextension!* := newsortextension;
      dip_sortevcomp!* := newsortevcomp;
      dip_evlist!* := {nil};
      ev_init();
      return {vars,sortmode,sortextension,sortevcomp,evlist}
   end;

procedure dip_cleanup(l);
   % Distributive polynomial cleanup. [l] is a list of the form
   % $(v,o,x,c,l)$. Return value is undefined. The elements of the
   % arguments have the following meaning: $v$ is the old list of main
   % variables, $o$ is the old term oredring, $x$ is the old list
   % extra arguments, $c$ is the old comparison procedure, and $l$ is
   % the old list of saved exponent vectors. The returned list is
   % suitable as argument to dip_cleanup.
   <<
      dip_vars!* := car l;
      l := cdr l;
      dip_sortmode!* := car l;
      l := cdr l;
      dip_sortextension!* := car l;
      l := cdr l;
      dip_sortevcomp!* := car l;
      l := cdr l;
      dip_evlist!* := car l
   >>;

procedure dip_monp(u);
   u and not cddr u;

procedure dip_2f(u);
   numr dip_2sq u;

procedure dip_2sq(u);
   % convert a dip into a standard quotient.
   if null u then
      nil ./ 1
   else
      addsq(dip_lmon2sq(dip_lbc u,dip_evlmon u),dip_2sq dip_mred u);

procedure dip_lmon2sq(bc,ev);
   % convert a monomial into a standard quotient.
   multsq(bc_2sq bc,ev_2f(ev,dip_vars!*) ./ 1);

procedure dip_f2dip(u);
   dip_f2dip1(u,ev_zero(),bc_fd 1);

procedure dip_f2dip1(u,ev,bc);
   % f to dip conversion: scan the standard form. ev and bc are the
   % exponent and coefficient parts collected so far from higher parts.
   if null u then
      nil
   else if domainp u then
      dip_fmon(bc_prod(bc,bc_fd u),ev)
   else
      dip_sum(dip_f2dip2(mvar u,ldeg u,lc u,ev,bc),dip_f2dip1(red u,ev,bc));

procedure dip_f2dip2(var,dg,c,ev,bc);
   % f to dip conversion: multiply leading power either into exponent
   % vector or into the base coefficient.
   if memq(var,dip_vars!*) then
      dip_f2dip1(c,ev_insert(ev,var,dg,dip_vars!*),bc)
   else
      dip_f2dip1(c,ev,bc_prod(bc,bc_pmon(var,dg)));

procedure dip_prod(p1,p2);
   % Distributive polynomial product. p1 and p2 are distributive
   % polynomials. dipprod(p1,p2) calculates the product of the two
   % distributive polynomials p1 and p2, a distributive polynomial*/
   if dip_length p1 <= dip_length p2 then
      dip_prodin(p1,p2)
   else
      dip_prodin(p2,p1);

procedure dip_prodin(p1,p2);
   % Distributive polynomial product internal. p1 and p2 are distrib
   % polynomials. dipprod(p1,p2) calculates the product of the two
   % distributive polynomials p1 and p2, a distributive polynomial.
   begin scalar bp1,ep1;
      if null p1 or null p2 then
      	 return nil;
      bp1 := dip_lbc p1;
      ep1 := dip_evlmon p1;
      return dip_moncomp(bc_prod(bp1,dip_lbc p2),ev_sum(ep1,dip_evlmon p2),
      	 dip_sum(dip_prodin(dip_fmon(bp1,ep1),dip_mred p2),
	    dip_prodin(dip_mred p1,p2)))
   end;

procedure dip_sum(p1,p2);
   % Distributive polynomial sum. p1 and p2 are distributive
   % polynomials. dipsum(p1,p2) calculates the sum of the two
   % distributive polynomials p1 and p2. Iterative version, better
   % suited for very long polynomials. Warning: this routine uses
   % "dipmred" == "cdr cdr" for a destructive concatenation.
   begin scalar w,rw,sl,ep1,ep2,nt,al,done;
      while not done do <<
	 if null p1 then <<
	    nt := p2;
 	    done := t
	 >> else if null p2 then <<
	    nt := p1;
 	    done := t
	 >> else <<
	    ep1 := dip_evlmon p1;
	    ep2 := dip_evlmon p2;
	    sl := ev_comp(ep1,ep2);
	    % Compute the next term.
	    if sl #= 1 then <<
	       nt := dip_moncomp(dip_lbc p1,ep1,nil);
	       p1 := dip_mred p1
	    >> else if sl #= -1 then <<
	       nt := dip_moncomp(dip_lbc p2,ep2,nil);
	       p2 := dip_mred p2
	    >> else <<
	       al := bc_sum(dip_lbc p1,dip_lbc p2);
	       nt := if not null al then
 		  dip_moncomp(al,ep1,nil);
	       p1 := dip_mred p1;
 	       p2 := dip_mred p2
	    >>
	 >>;
       	 % Append the term to the sum polynomial.
     	 if nt then
            if null w then
 	       w := rw := nt
            else <<
	       cdr cdr rw := nt;
 	       rw := nt
	    >>
      >>;
      return w
   end;

procedure dip_2a(u);
   % Returns prefix equivalent of distributive polynomial u.
   if null u then 0 else dip_replus dip_2a1 u;

procedure dip_2a1(u);
   begin scalar x,y;
      if null u then
      	 return nil;
      x := dip_lbc u;
      y := ev_2a dip_evlmon u;
      if bc_minus!? x then
 	 return {'minus,dip_retimes(bc_2a bc_neg x . y)} . dip_2a1 dip_mred u;
      return dip_retimes(bc_2a x . y) . dip_2a1 dip_mred u
   end;

procedure dip_replus(u);
   if atom u then u else if null cdr u then car u else 'plus . u;

procedure dip_retimes(u);
   % U is a list of prefix expressions the first of which is a number.
   % Result is prefix representation for their product.
   if car u = 1 then
      if cdr u then dip_retimes cdr u else 1
   else if null cdr u then
      car u
   else
      'times . u;

procedure dip_simpcont(p);
   % Calculate the contents of p and divide all coefficients by it.
   begin scalar c;
      c := dip_contenti p;
      if bc_minus!? dip_lbc p then
 	 c := bc_neg c;
      if bc_one!? c then
 	 return p;
      return dip_reduceconti(p,c)
   end;

procedure dip_contenti(p);
   dip_contenti1(p,bc_zero());

procedure dip_contenti1(p,c);
   <<
      while p do <<
	 c := bc_gcd(dip_lbc p,c);
	 p := dip_mred p
      >>;
      bc_abs c
   >>;

procedure dip_reduceconti(p,c);
   % Divide all coefficients of p by cont.
   if p then
      dip_moncomp(bc_quot(dip_lbc p,c),dip_evlmon p,
	 dip_reduceconti(dip_mred p,c));

%% procedure dip_condense(f);
%%    begin scalar dl,ev,w;
%%       dl := dip_evlist!*;
%%       while f do <<
%% 	 ev := dip_evlmon f;
%%     	 while cdr dl and (w := ev_comp(ev,cadr dl)) #= -1 do
%%  	    dl := cdr dl;
%%     	 if cdr dl and w #= 0 then
%% 	    car f := ev_identify(car f,cadr dl)
%%       	 else
%%  	    cdr dl := ev . cdr dl;
%%     	 f := dip_mred f
%%       >>;
%%    end;

procedure dip_condense(f);
   f;

procedure dip_evlcomp(p1,p2);
   % Distributive polynomial exponent vector leading monomial compare.
   % p1 and p2 are distributive polynomials. dip_evlcomp(p1,p2)
   % returns a boolean expression true if the distributive polynomial
   % p1 is smaller or equal the distributive polynomial p2 else false.
   not ev_compless!?(dip_evlmon p1,dip_evlmon p2);

procedure dip_length(p);
   % Distributive polynomial length. p is a distributive polynomial.
   % dip_length(p) returns the number of terms of the distributive
   % polynomial p, a digit.
   if null p then 0 else 1 + dip_length dip_mred p;

procedure dip_cancelmev(f,ev);
   % cancels all monomials in f which are multiples of ev.
   if null f then
      nil
   else if ev_mtest!?(dip_evlmon f,ev) then
      dip_cancelmev(dip_mred f,ev)
   else
      dip_evlmon f . dip_lbc f . dip_cancelmev(dip_mred f,ev);

procedure dip_bcquot(p,c);
   if bc_one!? c then
      p
   else
      dip_bcquot1(p,c);

procedure dip_bcquot1(p,c);
   if null p then
      nil
   else
      dip_evlmon p . bc_quot(dip_lbc p,c) . dip_bcquot1(dip_mred p,c);

procedure dip_appendmon(dip,bc,ev);
   append(dip,dip_fmon(bc,ev));

procedure dip_nconcmon(dip,bc,ev);
   nconc(dip,dip_fmon(bc,ev));

procedure dip_bcprod(p,c);
   if bc_zero!? c then
      nil
   else if bc_one!? c then
      p
   else
      dip_bcprod1(p,c);

procedure dip_bcprod1(p,c);
   if null p then
      nil
   else
      dip_evlmon p . bc_prod(dip_lbc p,c) . dip_bcprod1(dip_mred p,c);

procedure dip_tdeg(p);
   if null p then
      0
   else
      max(ev_tdeg dip_evlmon p,dip_tdeg dip_mred p);

procedure dip_append(p1,p2);
   append(p1,p2);

procedure dip_cp(p);
   for each x in p collect x;

procedure dip_dcont(dp);
   dip_dcont1(dp,bc_zero());

procedure dip_dcont1(dp,c);
   <<
      c := bc_2d c;
      while dp do <<
	 c := gcdn(c,bc_dcont dip_lbc dp);
	 dp := dip_mred dp
      >>;
     bc_fd c
   >>;

procedure dip_ilcomb(p1,c1,t1,p2,c2,t2);
   if null p1 then
      dip_prod(p2,dip_fmon(c2,t2))
   else if null p2 then
      dip_prod(p1,dip_fmon(c1,t1))
   else
      dip_ilcomb1(p1,c1,t1,p2,c2,t2);

procedure dip_ilcombr(p1,c1,p2,c2,t2);
   if null p1 then
      dip_prod(p2,dip_fmon(c2,t2))
   else if null p2 then
      dip_bcprod(p1,c1)
   else
      dip_ilcomb1r(p1,c1,p2,c2,t2);

procedure dip_ilcomb1(p1,c1,t1,p2,c2,t2);
   % Compute p1*c1^t1+p2*c2^t2.
   begin scalar hc1,ht1,hc2,ht2,cmp,resl,w;
      ht1 := ev_sum(car p1,t1);
      p1 := cdr p1;
      hc1 := bc_prod(car p1,c1);
      p1 := cdr p1;
      ht2 := ev_sum(car p2,t2);
      p2 := cdr p2;
      hc2 := bc_prod(car p2,c2);
      p2 := cdr p2;
      while p1 and p2 do <<
	 cmp := ev_comp(ht1,ht2);  % 1 = ">", -1 = "<", 0 = "="
	 if cmp #= 1 then <<
	    resl := hc1 . ht1 . resl;
	    ht1 := ev_sum(car p1,t1);
	    p1 := cdr p1;
	    hc1 := bc_prod(car p1,c1);
	    p1 := cdr p1
	 >> else if cmp #= -1 then <<
	    resl := hc2 . ht2 . resl;
	    ht2 := ev_sum(car p2,t2);
	    p2 := cdr p2;
	    hc2 := bc_prod(car p2,c2);
	    p2 := cdr p2
	 >> else <<  % cmp = 0, actually add monomials
	    w := bc_sum(hc1,hc2);
	    if not bc_zero!? w then
	       resl := w . ht1 . resl;
	    ht1 := ev_sum(car p1,t1);
	    p1 := cdr p1;
	    hc1 := bc_prod(car p1,c1);
	    p1 := cdr p1;
	    ht2 := ev_sum(car p2,t2);
	    p2 := cdr p2;
	    hc2 := bc_prod(car p2,c2);
	    p2 := cdr p2
	 >>
      >>;
      return if p1 then
	 dip_ilcomb2(resl,hc2,ht2,hc1,ht1,p1,c1,t1)
      else
	 dip_ilcomb2(resl,hc1,ht1,hc2,ht2,p2,c2,t2)
   end;

procedure dip_ilcomb2(resl,hc1,ht1,hc2,ht2,p2,c2,t2);
   begin scalar cmp,w;
      while p2 and (cmp := ev_comp(ht1,ht2)) #= -1 do <<
	 resl := hc2 . ht2 . resl;
	 ht2 := ev_sum(car p2,t2);
	 p2 := cdr p2;
	 hc2 := bc_prod(car p2,c2);
	 p2 := cdr p2
      >>;
      if p2 then <<
	 if cmp #= 1 then
	    resl := hc2 . ht2 . hc1 . ht1 . resl
	 else <<  % cmp = 0
	    w := bc_sum(hc1,hc2);
	    if not bc_zero!? w then
	       resl := w . ht1 . resl
	 >>;
	 while p2 do <<
	    resl := ev_sum(car p2,t2) . resl;
	    p2 := cdr p2;
	    resl := bc_prod(car p2,c2) . resl;
	    p2 := cdr p2
	 >>;
	 return reversip resl
      >>;
      cmp := ev_comp(ht1,ht2);
      if cmp #= -1 then
	 resl := hc1 . ht1 . hc2 . ht2 . resl
      else if cmp #= 1 then
	 resl := hc2 . ht2 . hc1 . ht1 . resl
      else <<  % cmp = 0
	 w := bc_sum(hc1,hc2);
	 if not bc_zero!? w then
	    resl := w . ht1 . resl
      >>;
      return reversip resl
   end;

procedure dip_ilcomb1r(p1,c1,p2,c2,t2);
   % Compute p1*c1+p2*c2^t2.
   begin scalar hc1,ht1,hc2,ht2,cmp,resl,w;
      ht1 := car p1;
      p1 := cdr p1;
      hc1 := bc_prod(car p1,c1);
      p1 := cdr p1;
      ht2 := ev_sum(car p2,t2);
      p2 := cdr p2;
      hc2 := bc_prod(car p2,c2);
      p2 := cdr p2;
      while p1 and p2 do <<
	 cmp := ev_comp(ht1,ht2);  % 1 = ">", -1 = "<", 0 = "="
	 if cmp #= 1 then <<
	    resl := hc1 . ht1 . resl;
	    ht1 := car p1;
	    p1 := cdr p1;
	    hc1 := bc_prod(car p1,c1);
	    p1 := cdr p1
	 >> else if cmp #= -1 then <<
	    resl := hc2 . ht2 . resl;
	    ht2 := ev_sum(car p2,t2);
	    p2 := cdr p2;
	    hc2 := bc_prod(car p2,c2);
	    p2 := cdr p2
	 >> else <<  % cmp = 0, actually add monomials
	    w := bc_sum(hc1,hc2);
	    if not bc_zero!? w then
	       resl := w . ht1 . resl;
	    ht1 := car p1;
	    p1 := cdr p1;
	    hc1 := bc_prod(car p1,c1);
	    p1 := cdr p1;
	    ht2 := ev_sum(car p2,t2);
	    p2 := cdr p2;
	    hc2 := bc_prod(car p2,c2);
	    p2 := cdr p2
	 >>
      >>;
      return if p1 then
	 dip_ilcomb2r(resl,hc2,ht2,hc1,ht1,p1,c1)
      else
	 dip_ilcomb2(resl,hc1,ht1,hc2,ht2,p2,c2,t2)
   end;


procedure dip_ilcomb2r(resl,hc1,ht1,hc2,ht2,p2,c2);
   begin scalar cmp,w;
      while p2 and (cmp := ev_comp(ht1,ht2)) #= -1 do <<
	 resl := hc2 . ht2 . resl;
	 ht2 := car p2;
	 p2 := cdr p2;
	 hc2 := bc_prod(car p2,c2);
	 p2 := cdr p2
      >>;
      if p2 then <<
	 if cmp #= 1 then
	    resl := hc2 . ht2 . hc1 . ht1 . resl
	 else <<  % cmp = 0
	    w := bc_sum(hc1,hc2);
	    if not bc_zero!? w then
	       resl := w . ht1 . resl
	 >>;
	 while p2 do <<
	    resl := car p2 . resl;
	    p2 := cdr p2;
	    resl := bc_prod(car p2,c2) . resl;
	    p2 := cdr p2
	 >>;
	 return reversip resl
      >>;
      cmp := ev_comp(ht1,ht2);
      if cmp #= -1 then
	 resl := hc1 . ht1 . hc2 . ht2 . resl
      else if cmp #= 1 then
	 resl := hc2 . ht2 . hc1 . ht1 . resl
      else <<  % cmp = 0
	 w := bc_sum(hc1,hc2);
	 if not bc_zero!? w then
	    resl := w . ht1 . resl
      >>;
      return reversip resl
   end;

procedure dip_comp(p1,p2);
   % distributive polynomial compare. [p1] and [p2] are DIP's. Returns
   % bool. Returns [T] if [p1] is greater than [p2] wrt. the
   % quasi-order induced by the current term order.
   begin scalar w;
      if null p1 then
      	 return nil;
      if null p2 then
	 return T;
      w := dip_comp1(p1,p2);
      if w #= -1 then
	 return nil;
      if w #= 1 then
	 return T;
      return dip_comp(dip_mred p1,dip_mred p2)
   end;
      
procedure dip_comp1(p1,p2);
   ev_comp(dip_evlmon p1,dip_evlmon p2);

procedure dip_one();
   % Distributive polynomial one. Nor argument. Returns the DIP
   % representation of 1 in the current polynomial ring.
   dip_fmon(bc_a2bc 1,ev_zero());
   
endmodule;  % dip

module td;

procedure td_vars();
   if !*tdusetorder then
      cdr global!-dipvars!*
   else
      cdr td_vars!*;

procedure td_sortmode();
   if !*tdusetorder then
      vdpsortmode!*
   else
      td_sortmode!*;

procedure td_sortextension();
   if !*tdusetorder then
      vdpsortextension!*
   else
      td_sortextension!*;

procedure td_torder(u);
  begin scalar oldmode,oldex,oldvars,w;
     oldmode := td_sortmode!*;
     oldex := td_sortextension!*;
     oldvars := td_vars!*;
     td_vars!* := '(list);
     w := reval car u;
     if null cdr u and eqcar(w,'list) then
	u := cdr w
     else
	u := w . for each a in cdr u collect reval a;
     w := car u;
     u := cdr u;
     if eqcar(w,'list) then <<
	td_vars!* := w;
 	w := car u;
 	u := cdr u
     >>;
     td_sortmode!* := w;
     td_sortextension!* := for each x in u join
     	if eqcar(x,'list) then cdr x else {x};
     if flagp(td_sortmode!*,'dipsortextension) and null td_sortextension!*
     then
 	rederr "td_torder: term order needs additional parameter(s)";
     return 'list . oldvars . oldmode . oldex
  end;

endmodule;  % td

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/gb.red0000644000175000017500000011150211526203062022323 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: gb.red 535 2010-01-28 12:25:54Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(gb_rcsid!* gb_copyright!*);
   gb_rcsid!* := "$Id: gb.red 535 2010-01-28 12:25:54Z thomas-sturm $";
   gb_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module gb;

load!-package 'ezgcd;

switch gbltbasis,groebopt,cgbstat,cgbfullred,cgbverbose,cgbcontred,
   cgbcounthf,cgbcheckg;

fluid '(!*gltbasis !*groebopt !*cgbstat !*cgbfullred !*cgbverbose
   !*cgbcontred !*cgbcounthf !*cgbcheckg !*cgbsloppy !*cgbsugar);

off1 'cgbstat;
on1 'cgbfullred;
off1 'cgbverbose;
off1 'cgbcontred;
off1 'cgbcounthf;
off1 'cgbcheckg;

!*cgbsloppy := T;
!*cgbsugar := nil;  % Indicator for using sugar property of VDP's.
		    % This is on for gb computation and off for using
		    % the code from external procedures. Do not
		    % intermix this with !*gsugar from the groebner
		    % package. if !*cgbsugar is nil then the all
		    % sugars are treated as zero.

switch cgbupdb;
fluid '(cgb_updbcount!* cgb_updbcountp!* cgb_updbcalls!* !*cgbupdb);
off1 'cgbupdb;

fluid '(intvdpvars!*);

fluid '(!*gcd !*ezgcd !*factor !*exp dmode!* depl!* !*backtrace);

fluid '(secondvalue!* thirdvalue!*);

fluid '(dip_vars!* vdp_pcount!*);

fluid '(cgb_hcount!* cgb_hzerocount!* cgb_tr1count!* cgb_tr2count!*
   cgb_tr3count!* cgb_b4count!* cgb_strangecount!* cgb_paircount!*
   cgb_hfaccount!* cgb_gcount!* cgb_gstat!* cgb_gbcount!*);

global '(gvarslast gltb);

gltb := {'list};

fluid '(cgb_contcount!* cgb_mincontred!*);
cgb_mincontred!* := 20;  % originally 10

% Generate the following interfaces for AM:
% - gb: List of Polyomials -> List of Polynomials
% - gbgsys: List of Polyomials -> Groebner System
% - reduce: Polynomial X List of Polynomials -> Polynomial
% - ltb: List of Polynomials -> List of Terms (as Polynomials)
% and the following interfaces for the SM:
% - gbf,gsysf,reducef,ltbf. All polynomials are represented as SF's,
% except the return valute of reducef, which is an SQ. All Procedures
% expect three dditional paramters: List of variable, term order, and
% additional arguments to term order.

macro procedure gb_mkinterface(argl);
   begin
      scalar a2sl1,a2sl2,defl,xvfn,s2a,s2s,s,modes,
	 args,bname,len,sm,prgn,ami,smi,psval,postfix;
      bname := eval nth(argl,2);
      a2sl1 := eval nth(argl,3);
      a2sl2 := eval nth(argl,4);
      defl := eval nth(argl,5);
      xvfn := eval nth(argl,6);
      s2a := eval nth(argl,7);
      s2s := eval nth(argl,8);
      s := eval nth(argl,9);
      postfix := eval nth(argl,10);
      modes := eval nth(argl,11);      
      len := length a2sl1;
      args := for i := 1:len+3 collect mkid('a,i);
      sm := intern compress append('(!g !b !_),explode bname);
      % Define the symbolic mode interface
      if (null modes or modes eq 'sm) then <<
      	 smi := intern compress nconc(explode sm,explode postfix);      
      	 prgn := {'put,mkquote smi,''number!-of!-args,len+3} . prgn;
      	 prgn := {'de,smi,args,{'gb_interface!$,mkquote sm, mkquote a2sl1,
	    mkquote a2sl2,mkquote defl,mkquote xvfn,mkquote s2a,mkquote s2s,
	    mkquote s,T,'list . args}} . prgn
      >>;
      if (null modes or modes eq 'am) then <<
      	 % Define the algebraic mode interface      
      	 ami := bname;
      	 %      ami := intern compress append('(!g !b),explode bname);
      	 psval := intern compress nconc(explode ami,'(!! !$));
      	 prgn := {'put,mkquote ami,''psopfn,mkquote psval} . prgn;
      	 prgn := {'put,mkquote psval,''number!-of!-args,1} . prgn;
      	 prgn := {'put,mkquote psval,''cleanupfn,''gb_cleanup} . prgn;
      	 prgn := {'de,psval,'(argl),{'gb_interface!$,mkquote sm, mkquote a2sl1,
	    mkquote a2sl2,mkquote defl,mkquote xvfn,mkquote s2a, mkquote s2s,
	    mkquote s,nil,'argl}} . prgn
      >>;
      return 'progn . prgn
   end;

gb_mkinterface('gb,'(gb_a2s!-psys),'(gb_a2s2!-psys),
   nil,'gb_xvars!-psys,'gb_s2a!-gbx,'gb_s2s!-gb,T,'f,nil);

%% gb_mkinterface('gbgsys,'(gb_a2s!-psys),'(gb_a2s2!-psys),
%%    nil,'gb_xvars!-psys,'gb_s2a!-gsys,'gb_s2s!-gsys,T,'f,nil);

gb_mkinterface('reduce,'(gb_a2s!-pol gb_a2s!-psys),
   '(gb_a2s2!-pol gb_a2s2!-psys),
   nil,'gb_xvars!-ppsys,'gb_s2a!-pol,'gb_s2s!-pol,T,'f,nil);

gb_mkinterface('ltb,'(gb_a2s!-psys),'(gb_a2s2!-psys),
   nil,'gb_xvars!-psys,'gb_s2a!-gb,'gb_s2s!-gb,T,'f,nil);

procedure gb_a2s!-psys(l);
   % Groebner bases algebraic mode to symbolic mode polynomial system.
   % [l] is an AMPSYS. Returns an FPSYS.
   begin scalar w,resl;
      for each j in getrlist reval l do <<
      	 w := numr simp j;
	 if w and not(w member resl) then
	    resl := w . resl
      >>;
      return sort(resl,'ordp)
   end;

procedure gb_a2s2!-psys(fl);
   for each x in fl collect vdp_f2vdp x;

procedure gb_s2a!-gb(u);
   % Groebner bases symbolic mode to algebraic mode GB. [u] is a list
   % of CGP's. Returns an AMPSYS.
   'list . for each x in u collect vdp_2a x;

procedure gb_s2a!-gbx(l);
   % symbolic to algebraic mode groebner base extended version. [l] is
   % a list of VDP's. Returns an AM object. This procedure sets as a
   % side effet the global variable gltb provided !*gltbasis is on.
   <<
      if !*gltbasis then
      	 gltb := gb_gb2gltb l;      
      gb_s2a!-gb l
   >>;

procedure gb_s2s!-gb(l);
   gb_gb!-sfl l;

procedure gb_s2a!-gsys(l);
   'list . for each x in l collect
      {'list,rl_mk!*fof rl_smkn('and,car x),gb_s2a!-gb cadr x};

procedure gb_s2s!-gsys(l);
   for each x in l collect
      {rl_smkn('and,car x),gb_s2s!-gb cadr x};

procedure gb_a2s!-pol(p);
   numr simp reval p;

procedure gb_a2s2!-pol(p);
   vdp_f2vdp p;

procedure gb_s2a!-pol(p);
   vdp_2a p;

procedure gb_s2s!-pol(p);
   vdp_2sq p;

procedure gb_dummy1(dummy);
   nil;

procedure gb_xvars!-psys(l,vl);
   gb_vars(l,vl);

procedure gb_xvars!-psys2(l,cd,vl);
   gb_vars(l,vl);

procedure gb_xvars!-psys3(l,cd,xvarl,vl);
   gb_vars(l,vl);

procedure gb_xvars!-ppsys(p,l,vl);
   gb_vars(p . l,vl);

procedure gb_cleanup(u,v);
   u;

procedure gb_interface!$(fname,a2sl1,a2sl2,defl,xvfn,s2a,s2s,s,smp,argl);
   % fname is a function, the name of the procedure to be called;
   % [a2sl1] and [as2sl2] are a list of functions, called to be
   % transform algebraic arguments to symbolic arguments; [defl] is a
   % list of algebraic defualt arguments; xvfn is a procedure for
   % extracting the variables from all arguments; [s2a] is procedure
   % for transforming the symbolic return value to an algebraic mode
   % return value; [argl] is the list of arguments; [s] is a flag;
   % [smp] is a flag. Return an S-expr. If [s] is on then second stage
   % of argument processing is done with the results of the first one.
   begin scalar w,vl,nargl,oenv,m,c,x;
      if not smp then <<
	 nargl := gb_am!-pargl(fname,a2sl1,argl,defl);
	 vl := apply(xvfn,append(nargl,{td_vars()}));
	 oenv := vdp_init(car vl,td_sortmode(),td_sortextension());
      	 gvarslast := 'list . car vl;      
      >> else <<
	 w := gb_sm!-pargl(argl);
	 nargl := car w;
	 m := cadr w;
	 c := caddr w;
	 x := cadddr w;
	 vl := apply(xvfn,append(nargl,{m}));
	 oenv := vdp_init(car vl,c,x);	       
      >>;	    
      w := errorset({'gb_interface1!$,
	 mkquote fname,mkquote a2sl2,mkquote s2a,mkquote s2s,mkquote s,
	 mkquote smp,mkquote argl, mkquote nargl,mkquote car vl,
	 mkquote cdr vl},T,!*backtrace);
      vdp_cleanup oenv;
      if errorp w then
      	 rederr {"Error during ",fname};
      return car w
   end;

procedure gb_sm!-pargl(argl);
   begin scalar nargl,m,c,x;
      nargl := reverse argl;
      x := car nargl;
      nargl := cdr nargl;
      c := car nargl;
      nargl := cdr nargl;
      m := car nargl;
      nargl := cdr nargl;
      nargl := reversip nargl;
      return {nargl,m,c,x}
   end;

procedure gb_am!-pargl(fname,a2sl1,argl,defl);
   % process argument list for algebraic mode.
   begin integer l1,l2,l3; scalar w,nargl,scargl,scdefl;
      l1 := length argl;
      l2 := length a2sl1;
      l3 := l2 - length defl;
      if l1 < l3 or l1 > l2 then
	 rederr {fname,"called with",l1,"arguments instead of",l3,"-",l2};
      scargl := argl;
      scdefl := defl;
      nargl := for each x in a2sl1 collect <<
	 if scargl then <<
	    w := car scargl;
	    scargl := cdr scargl
	 >> else <<
	    w := car scdefl;
	    scdefl := cdr scdefl
	 >>;
	 apply(x,{w})
      >>;
      return nargl
   end;

procedure gb_interface1!$(fname,a2sl2,s2a,s2s,s,smp,argl,nargl,m,p);
   begin scalar w,pl;
      pl := if s then nargl else argl;
      argl := for each x in a2sl2 collect <<
	 w := car pl;
	 pl := cdr pl;
	 apply(x,{w})
      >>;
%      w := apply(fname,nconc(argl,{m,p}));
      w := apply(fname,argl);
      w := if smp then
	 apply(s2s,{w})
      else
      	 apply(s2a,{w});
      return w
   end;

smacro procedure gb_tt(s1,s2);
   % lcm of leading terms of s1 and s2
   ev_lcm(vdp_evlmon s1,vdp_evlmon s2);

procedure gb_gb!-sfl(u);
   % Groebner bases GB to SF list. [u] is a list of CGP's. Returns a
   % list of SF's.
   for each p in u collect vdp_2f p;

procedure gb_domainchk();
   % Groebner bases domain check. No argument. Return value not
   % defined. Raises an error if the current domain is not valid for
   % GB computations.
   if not memq(dmode!*,'(nil)) then
      rederr bldmsg("gb does not support domain: %w",get(dmode!*,'dname));
      
procedure gb_vars(l,vl);     %DROPPED: depend,rules,zero divisors.
   % Groebner bases variables. [l] is a list of SF's; [vl] is the list
   % of main variables. Returns a pair $(m . p)$ where $m$ and $p$ are
   % list of variables. $m$ is the list of used main variables and $p$
   % is the list of used parameters. 
   begin scalar w,m,p;
      for each f in l do
	 w := union(w,kernels f);
      if vl then <<
      	 m := gb_intersection(vl,w);
      	 p := setdiff(w,vl)
      >> else
	 m := w;
      return gb_varsopt(l,m) . p
   end;

procedure gb_intersection(a,b);
   % Groebner bases intersection. [a] and [b] are lists. Returns a
   % list. The returned list contains all elements occuring in [a] and
   % in [b]. The order of the elements is the same as in [a].
   for each x in a join
      if x member b then
	 {x};

procedure gb_varsopt(l,vl);
   % Groebner bases variables optimize. [l] is a list of SF's; [vl] is
   % the list of main variables. Returns a possibly reorderd list of
   % main variables.
   if !*groebopt and td_sortmode() memq '(lex gradlex revgradlex) then
      gb_vdpvordopt(l,vl)
   else
      vl;

procedure gb_gb2gltb(base);
   'list . for each j in base collect
      vdp_2a vdp_fmon(bc_a2bc 1,vdp_evlmon j);

procedure gb_ltb(l);
   for each p in l collect
      vdp_fmon(bc_a2bc 1,vdp_evlmon p);

procedure gb_gbggsys0(p,dummy,dummy);
   gb_gbgsys p;

procedure gb_gbgsys0(p,dummy);
   gb_gbgsys p;

procedure gb_gbgsys(p);
   {{nil,gb_gb p,nil}};

procedure gb_gb0(p,dummy);
   gb_gb p;
   
procedure gb_gb(p);
   begin scalar spac,p1,savetime,!*factor,!*exp,intvdpvars!*,!*gcd,!*ezgcd,
	 dip_vars!*,secondvalue!*,thirdvalue!*,cgb_gstat!*,!*cgbsugar;
      integer vdp_pcount!*,cgb_contcount!*,cgb_hcount!*,cgb_hzerocount!*,
	 cgb_tr1count!*,cgb_tr2count!*,cgb_tr3count!*,cgb_b4count!*,
	 cgb_strangecount!*,cgb_paircount!*,cgb_hfaccount!*,cgb_gcount!*,
	 cgb_gbcount!*,cgb_updbcount!*,cgb_updbcountp!*,cgb_updbcalls!*;
      !*exp := !*gcd := !*ezgcd := T;
      !*cgbsugar := T;
      if !*cgbstat then
      	 savetime := time();
      if !*cgbcheckg then	 
      	 cgb_gstat!* := nil;
      cgb_contcount!* := cgb_mincontred!*;
      if !*cgbstat then
      	 spac := gctime();
      p1 := if !*cgbupdb then
 	 gb_traverso!-sturm!-experimental p
      else
 	 gb_traverso p;
      if !*cgbstat then <<
	 ioto_tprin2t "Statistics for GB computation:";
	 ioto_prin2t {"Time: ",time() - savetime," ms plus GC time: ",
	    gctime() - spac," ms"};
	 ioto_prin2t {"H-polynomials total: ",cgb_hcount!*};
	 ioto_prin2t {"H-polynomials zero: ",cgb_hzerocount!*};
	 if !*cgbcounthf then
	    ioto_prin2t {"H-polynomials reducible: ",cgb_hfaccount!*};
	 if !*cgbcheckg then
	    ioto_prin2t {"H-polynomials gaussible: ",cgb_gcount!*,
	       " ",cgb_gstat!*};
	 ioto_prin2t {"Crit Tr1 hits: ",cgb_tr1count!*};
	 ioto_prin2t {"Crit B4 hits: ",cgb_b4count!*," (Buchberger 1)"};
	 ioto_prin2t {"Crit Tr2 hits: ",cgb_tr2count!*};
	 ioto_prin2t {"Crit Tr3 hits: ",cgb_tr3count!*};
	 if !*cgbupdb then
	    ioto_prin2t {"updbase: calls ",cgb_updbcalls!*,", del ",
	       cgb_updbcountp!*,"/",cgb_updbcount!*};
	 ioto_prin2t {"Strange reductions: ",cgb_strangecount!*}
      >>;
      return p1
   end;

procedure gb_traverso!-sturm!-experimental(g0);
   begin scalar gall,g,d,s,h,p;
      g0 := for each fj in g0 join
	 if not vdp_zero!? fj then
	    {vdp_setsugar(vdp_enumerate vdp_simpcont fj,vdp_tdeg fj)};
      for each h in g0 do <<  % create initial critical pairs
	 p := {nil,h,h};
      	 h := gb_enumerate h;
      	 d := gb_traverso!-pairlist(h,g,d);
	 g := nconc(g,{h});
	 gall := nconc(gall,{h});
      >>;
      while d do <<  % critical pairs left
	 if !*cgbverbose then <<
	    ioto_prin2 {"[",cgb_paircount!*,"] "};
	    cgb_paircount!* := cgb_paircount!* #- 1
	 >>;
	 p := car d;
	 d := cdr d;
	 s := gb_spolynomial(p);
	 h := gb_simpcontnormalform gb_normalform(s,gall);
	 cgb_hcount!* := cgb_hcount!* #+ 1;
	 if vdp_zero!? h then <<
	    cgb_hzerocount!* := cgb_hzerocount!* #+ 1;
	 >> else if ev_zero!? vdp_evlmon h then <<  % base 1 found
	    h := gb_enumerate h;
	    d := nil;
	    g := {h}
	 >> else <<
	    if !*cgbcounthf then
	       if cddr fctrf vdp_2f h then
		  cgb_hfaccount!* := cgb_hfaccount!* #+ 1;
      	    h := gb_enumerate h;
      	    d := gb_traverso!-pairlist(h,g,d);
      	    gall := gb_updbase(gall,h);
      	    g := nconc(g,{h})
	 >>
      >>;
      return gb_traverso!-final g
   end;

procedure gb_traverso(g0);
   begin scalar g,d,s,h,p,gstat;
      g0 := for each fj in g0 join
	 if not vdp_zero!? fj then
	    {vdp_setsugar(vdp_enumerate vdp_simpcont fj,vdp_tdeg fj)};
      for each h in g0 do <<  % create initial critical pairs
	 p := {nil,h,h};
      	 h := gb_enumerate h;
      	 d := gb_traverso!-pairlist(h,g,d);
	 g := nconc(g,{h})
      >>;
      if !*cgbverbose then
	 cgb_gbcount!* := length g;
      while d do <<  % critical pairs left
	 if !*cgbverbose then <<
	    ioto_prin2 {"[",cgb_paircount!*,"] "};
	    cgb_paircount!* := cgb_paircount!* #- 1
	 >>;
	 p := car d;
	 d := cdr d;
	 s := gb_spolynomial(p);
	 h := gb_simpcontnormalform gb_normalform(s,g);
	 if !*cgbstat then
	    cgb_hcount!* := cgb_hcount!* #+ 1;
	 if vdp_zero!? h then
	    (if !*cgbstat then
	       cgb_hzerocount!* := cgb_hzerocount!* #+ 1)	    
	 else if vdp_unit!? h then <<
	    h := gb_enumerate h;
	    d := nil;
	    g := {h}
	 >> else <<
	    if !*cgbcounthf then
	       if cddr fctrf vdp_2f h then
		  cgb_hfaccount!* := cgb_hfaccount!* #+ 1;
	    if !*cgbcheckg then <<
	       gstat := gb_chkgauss vdp_poly h;
	       if 1 member gstat then <<
		  cgb_gcount!* := cgb_gcount!* #+ 1;
	       	  cgb_gstat!* := gb_chkgauss!-stat2vl gstat . cgb_gstat!*
	       >>
	    >>;
      	    h := gb_enumerate h;
      	    d := gb_traverso!-pairlist(h,g,d);
      	    g := nconc(g,{h});
	    if !*cgbverbose then
	       cgb_gbcount!* := cgb_gbcount!* #+ 1
	 >>
      >>;
      return gb_traverso!-final g
   end;

procedure gb_updbase(g,h);
   begin scalar hev,oc;
      if !*cgbstat then
      	 oc := cgb_updbcountp!*;
      hev := vdp_evlmon h;
      g := for each p in g join
      	 if not ev_divides!?(hev,vdp_evlmon p) then
 	    {p}
	 else <<
	    if !*cgbverbose then
	       ioto_prin2 "#";
	    if !*cgbstat then
	       cgb_updbcountp!* := cgb_updbcountp!* #+ 1;
	    nil
	 >>;
      if !*cgbstat then <<
      	 if not (oc #= cgb_updbcountp!*) then
	    cgb_updbcount!* := cgb_updbcount!* #+ 1;
	 cgb_updbcalls!* := cgb_updbcalls!* + 1
      >>;
      return nconc(g,{h})
   end;

procedure gb_chkgauss(p);
   % [p] is a dipoly.
   begin scalar stat;
      stat := for each x in dip_vars!* collect 0;  %TODO: Reference to global var
      while p do <<
	 stat := gb_chkgauss1(dip_evlmon p,stat);
   	 p := dip_mred p
      >>;
      return stat
   end;

procedure gb_chkgauss1(ev,stat);
   begin scalar nstat,e,s,td;
      td := ev_tdeg ev;
      if td = 0 then
	 return stat;
      td := if td #= 1 then 1 else -1;
      while ev do <<
	 e := car ev;
	 ev := cdr ev;
	 s := car stat;
	 stat := cdr stat;
	 if e #=0 then
	    nstat := s . nstat
	 else if e #> 1 or s #= -1 then
	    nstat := (-1) . nstat
	 else if e #= 1 and s #= 0 then
	    nstat := td . nstat
	 else if s #=0 and e #=0 then
	    nstat := 0 . nstat
	 else
	    rederr "ich sehe es anders"
      >>;
      return reversip nstat
   end;

procedure gb_chkgauss!-stat2vl(gstat);
   begin scalar scdv,r;
      scdv := dip_vars!*;
      while gstat do <<
	 if eqcar(gstat,1) then
 	    r := car scdv . r;
	 gstat := cdr gstat;
	 scdv := cdr scdv
      >>;
      return reversip r
   end;

procedure gb_enumerate(f);
   % f is a temporary result. Prepare it for medium range storage, and
   % assign a number.
   if vdp_zero!? f then
      f
   else <<
      vdp_condense f;
      if vdp_number f #= 0 then
	 f := vdp_setnumber(f,vdp_pcount!* := vdp_pcount!* #+ 1);
      f
   >>;

procedure gb_traverso!-pairlist(gk,g,d);
   % gk: new polynomial, g: current basis, d: old pair list.
   begin scalar ev,r,n;
      d := gb_traverso!-pairs!-discard1(gk,d);
      % build new pair list:
      ev := vdp_evlmon gk;
      for each p in g do
     	 if not gb_buchcrit4t(ev,vdp_evlmon p) then <<
	    if !*cgbstat then
	       cgb_b4count!* := cgb_b4count!* #+ 1;
 	    r := ev_lcm(ev,vdp_evlmon p) . r
       	 >> else
 	    n := gb_makepair(p,gk) . n;
      n := gb_tr2crit(n,r);
      n := gb_cplistsort(n,!*cgbsloppy);
      n := gb_tr3crit n;
      if !*cgbverbose and n then <<
	 cgb_paircount!* := cgb_paircount!* #+ length n;
	 ioto_cterpri();
	 ioto_prin2 {"(",cgb_gbcount!*,") "}
      >>;
      return gb_cplistmerge(d,reversip n)
   end;

procedure gb_tr2crit(n,r);
   % delete equivalents to coprime lcm
   for each p in n join 
      if ev_member(car p,r) then <<
	 if !*cgbstat then
	    cgb_tr2count!* := cgb_tr2count!* #+ 1;
	 nil
      >> else
	 {p};

procedure gb_tr3crit(n);
   begin scalar newn,scannewn,q;
      for each p in n do <<
	 scannewn := newn;
	 q := nil;
 	 while scannewn do
	    if ev_divides!?(caar scannewn,car p) then <<
	       q := t;
	       scannewn := nil;
	       if !*cgbstat then
	       	  cgb_tr3count!* := cgb_tr3count!* #+ 1
	    >> else
	       scannewn := cdr scannewn;
	 if not q then
	    newn := gb_cplistsortin(p,newn,nil)
      >>;
      return newn
   end;

procedure gb_traverso!-pairs!-discard1(gk,d);
   % crit B. Delete triange relations.
   for each pij in d join
      if gb_traverso!-trianglep(cadr pij,caddr pij,gk,car pij) then <<
	 if !*cgbstat then
	    cgb_tr1count!* := cgb_tr1count!* #+ 1;
	 if !*cgbverbose then
	    cgb_paircount!* := cgb_paircount!* #- 1;
	 nil
      >> else
	 {pij};

procedure gb_traverso!-trianglep(gi,gj,gk,tij);
   ev_sdivp(gb_tt(gi,gk),tij) and ev_sdivp(gb_tt(gj,gk),tij);

procedure gb_traverso!-final(g);
   % Final reduction and sorting.
   for each rg on vdp_lsort g join
      if not gb_searchinlist(vdp_evlmon car rg,cdr rg) then
	 {vdp_remplist gb_simpcontnormalform gb_normalform(car rg,cdr rg)};

procedure gb_buchcrit4t(e1,e2);
   % nonconstructive test of lcm(e1,e2) = e1 + e2 equivalent: no
   % matches of nonzero elements.
   not ev_disjointp(e1,e2);
   
procedure gb_cplistsort(g,sloppy);
   begin scalar gg;
      for each p in g do
 	 gg := gb_cplistsortin(p,gg,sloppy);
      return gg
   end;

procedure gb_cplistsortin(p,pl,sloppy);
   % Distributive polynomial critical pair list sort. pl is a special
   % list for Groebner calculation, p is a pair. Returns the updated
   % list pl (p sorted into).
   if null pl then
      {p}
   else <<
      gb_cplistsortin1(p,pl,sloppy);
      pl
   >>;

procedure gb_cplistsortin1(p,pl,sloppy);
   % Destructive insert of p into nonnull pl.
   if not gb_cpcompless!?(car pl,p,sloppy) then <<
      rplacd(pl,car pl . cdr pl);
      rplaca(pl,p)
   >> else if null cdr pl then
      rplacd(pl,{p})
   else
      gb_cplistsortin1(p,cdr pl,sloppy);

procedure gb_cpcompless!?(p1,p2,sloppy);
   % Compare 2 pairs wrt. their sugar (=cadddr) or their lcm (=car).
   if sloppy then
      ev_compless!?(car p1,car p2)
   else
      gb_cpcompless!?s(p1,p2,cadddr p1 #- cadddr p2,ev_comp(car p1,car p2));

procedure gb_cpcompless!?s(p1,p2,d,q);
   if d neq 0 then
      d #< 0
   else if q neq 0 then
      q < 0
   else
      vdp_number(caddr p1) #< vdp_number(caddr p2);

procedure gb_cplistmerge(pl1,pl2);
   % Distributive polynomial critical pair list merge. pl1 and pl2 are
   % critical pair lists used in the Groebner calculation.
   % groebcplistmerge(pl1,pl2) returns the merged list.
   begin scalar cpl1,cpl2;
      if null pl1 then
 	 return pl2;
      if null pl2 then
 	 return pl1;
      cpl1 := car pl1;
      cpl2 := car pl2;
      return if gb_cpcompless!?(cpl1,cpl2,nil) then
 	 cpl1 . gb_cplistmerge(cdr pl1,pl2)
      else
 	 cpl2 . gb_cplistmerge(pl1,cdr pl2)
   end;

procedure gb_makepair(f,h);
   % Construct a pair from polynomials f and h.
   begin scalar ttt,sf,sh;
      ttt := gb_tt(f,h);
      sf := vdp_sugar(f) #+ ev_tdeg ev_dif(ttt,vdp_evlmon f);
      sh := vdp_sugar(h) #+ ev_tdeg ev_dif(ttt,vdp_evlmon h);
      return {ttt,f,h,ev_max!#(sf,sh)}
   end;

procedure gb_spolynomial(pr);
   begin scalar p1,p2,s;
      p1 := cadr pr;
      p2 := caddr pr;
      s := gb_spolynomial1(p1,p2);   % TODO: Switch for strange reduction
      if vdp_zero!? s or vdp_unit!? s then
 	 return s;
%      return vdp_setsugar(gb_strange!-reduction(s,p1,p2),cadddr pr)
      return gb_strange!-reduction(s,p1,p2)  % TODO: normal suger for
					     % special cases. 
   end;

procedure gb_spolynomial1(p1,p2);
   begin scalar ep1,ep2,ep,rp1,rp2,db1,db2,x;
      ep1 := vdp_evlmon p1;
      ep2 := vdp_evlmon p2;
      ep := ev_lcm(ep1,ep2);
      rp1 := vdp_mred p1;
      rp2 := vdp_mred p2;
      if vdp_zero!? rp1 and vdp_zero!? rp2 then
 	 return rp1;
      if vdp_zero!? rp1 then
	 return vdp_prod(rp2,vdp_fmon(bc_a2bc 1,ev_dif(ep,ep2)));
      if vdp_zero!? rp2 then
	 return vdp_prod(rp1,vdp_fmon(bc_a2bc 1,ev_dif(ep,ep1)));
      db1 := vdp_lbc p1;
      db2 := vdp_lbc p2;
      x := bc_gcd(db1,db2);
      if not bc_one!? x then <<
	 db1 := bc_quot(db1,x);
	 db2 := bc_quot(db2,x)
      >>;
      return vdp_ilcomb(rp2,db1,ev_dif(ep,ep2),rp1,bc_neg db2,ev_dif(ep,ep1))
   end;

procedure gb_strange!-reduction(s,p1,p2);
   % Subtracts multiples of p2 from the s-polynomial such that head
   % terms are eliminated early.
   begin scalar tp1,tp2,ts,c,saves;
      saves := s;
      tp1 := vdp_evlmon p1;
      tp2 := vdp_evlmon p2;
      c := T; while c and not vdp_zero!? s do <<
	 ts := vdp_evlmon s;
	 if gb_buch!-ev_divides!?(tp2,ts) then
	    s := gb_reduceonestepint(s,vdp_zero(),vdp_lbc s,ts,p2)
	 else if gb_buch!-ev_divides!?(tp1,ts) then
	    s := gb_reduceonestepint(s,vdp_zero(),vdp_lbc s,ts,p1)
	 else
	    c := nil
      >>;
      if !*cgbstat and not (s eq saves) then
	 cgb_strangecount!* := cgb_strangecount!* #+ 1;
      return s
   end;

procedure gb_buch!-ev_divides!?(vev1,vev2);
   % Test if vev1 divides vev2 for exponent vectors vev1 and vev2.
   ev_mtest!?(vev2,vev1);

procedure gb_normalform(f,g);
   % General procedure for the reduction of one polynomial modulo a
   % set. f is a polynomial, g is a set of polynomials. Procedure
   % behaves like type='list. f is reduced modulo g. f is possibly
   % multiplied by an factor.
   begin scalar f1,c,vev,divisor,tai,fold; integer n;
      fold := f;
      f1 := vdp_setsugar(vdp_zero(),vdp_sugar f);
      while not vdp_zero!? f do <<
	 vev := vdp_evlmon f;
 	 c := vdp_lbc f;
	 divisor := gb_searchinlist(vev,g);
	 if divisor then <<
	    tai := T;
	    if vdp_monp divisor then
	       f := vdp_cancelmev(f,vdp_evlmon divisor)
	    else <<
	       f := gb_reduceonestepint(f,f1,c,vev,divisor);
	       f1 := secondvalue!*;
	       if !*cgbcontred then <<
	       	  f := gb_adtssimpcont(f,f1,n);
	       	  f1 := secondvalue!*;
	       	  n := thirdvalue!*
	       >>
	    >>
	 >> else if !*cgbfullred then <<
	    f := gb_shift(f,f1);
	    f1 := secondvalue!*
	 >> else <<
	    f1 := vdp_sum(f1,f);
 	    f := vdp_zero()
	 >>
      >>;
      return if tai then f1 else fold
   end;

procedure gb_searchinlist(vev,g);
   % search for a polynomial in the list G, such that the lcm divides
   % vev; G is expected to be sorted in descending sequence.
   if null g then
      nil
   else if gb_buch!-ev_divides!?(vdp_evlmon car g, vev) then
      car g
   else
      gb_searchinlist(vev,cdr g);

procedure gb_adtssimpcont(f,f1,n);
   begin scalar f0;
      if vdp_zero!? f then <<
      	 secondvalue!* := f1;
      	 thirdvalue!* := 0;
      	 return f
      >>;
      n := n + 1;
      if n #> cgb_contcount!* then <<
      	 f0 := f;
      	 f := gb_simpcont2(f,f1);
      	 f1 := secondvalue!*;
      	 gb_contentcontrol(f neq f0);
	 n := 0
      >>;
      secondvalue!* := f1;
      thirdvalue!* := n;
      return f
   end;

procedure gb_simpcont2(f,f1);
   % Simplify two polynomials with the gcd of their contents. [f] is
   % not zero.
   begin scalar c,s1,s2;
      c := vdp_content f;
      if bc_one!? bc_abs c then <<
	 secondvalue!* := f1;
	 return f
      >>;
      s1 := vdp_sugar f;
      s2 := vdp_sugar f1;
      if not vdp_zero!? f1 then <<
 	 c := vdp_content1(f1,c);
	 if bc_one!? bc_abs c then <<
	    secondvalue!* := f1;
	    return f
      	 >>;
	 f1 := vdp_bcquot(f1,c)
      >>;
      f := vdp_bcquot(f,c);
      vdp_setsugar(f,s1);
      vdp_setsugar(f1,s2);
      secondvalue!* := f1;
      return f
    end;

procedure gb_contentcontrol(u);
   % u indicates, that a substantial content reduction was done;
   % update content reduction limit from u.
   <<
      cgb_contcount!* := if u then
      	 ev_max!#(0,cgb_contcount!* #- 1)
      else
      	 gb_min!#(cgb_mincontred!*,cgb_contcount!* #+ 1);
      if !*cgbverbose then
	 ioto_prin2 {"<",cgb_contcount!*,"> "}
   >>;

procedure gb_min!#(a,b);
   if a #< b then a else b;

procedure gb_shift(f,f1);
   begin scalar s,s1;
      s := vdp_sugar f;
      s1 := vdp_sugar f1;
      f1 := vdp_nconcmon(f1,vdp_lbc f,vdp_evlmon f);
      f := vdp_mred f;
      vdp_setsugar(f,s);
      vdp_setsugar(f1,ev_max!#(s1,s));
      secondvalue!* := f1;
      return f
   end;

procedure gb_reduceonestepint(f,f1,c,vev,g1);
   % Reduction step for integer case: calculate f = a*f - b*g a, b
   % such that leading term vanishes (vev of lvbc g divides vev of
   % lvbc f) and calculate f1 = a*f1. Return value=f, secondvalue=f1.
   begin scalar vevcof,a,b,cg,x,rg1;
      rg1 := vdp_mred g1;
      if vdp_zero!? rg1 then <<  % g1 is monomial
	 f := vdp_mred f;
	 secondvalue!* := f1;
	 return f
      >>;
      vevcof := ev_dif(vev,vdp_evlmon g1);  % nix lcm
      cg := vdp_lbc g1;
      x := bc_gcd(c,cg);
      a := bc_quot(cg,x);
      b := bc_quot(c,x);
      % multiply relevant parts of f and f1 by a (vbc)
      if not vdp_zero!? f1 then
 	 f1 := vdp_bcprod(f1,a);
      f := vdp_ilcombr(vdp_mred f,a,rg1,bc_neg b,vevcof);
      secondvalue!*:= f1;
      return f
   end;

procedure gb_simpcontnormalform(h);
   % simpCont version preserving the property SUGAR.
   if vdp_zero!? h then
      h
   else
      vdp_setsugar(vdp_simpcont h,vdp_sugar h);

procedure gb_vdpvordopt(w,vars);
   % w : list of polynomials (standard forms)
   % vars: list of variables
   % return vars
   begin scalar c;
      vars := sort(vars,'ordop);
      c := for each x in vars collect x . 0 . 0;
      for each poly in w do
 	 gb_vdpvordopt1(poly,vars,c);
      c := sort(c,function gb_vdpvordopt2);
      intvdpvars!* := for each v in c collect car v;
      vars := gb_vdpvordopt31 intvdpvars!*;
      return vars
   end;
 
procedure gb_vdpvordopt31(u);
   begin scalar v,y;
      if null u then
 	 return nil;
      v := for each x in u join <<
 	 y := assoc(x,depl!*);
	 if null y or null xnp(cdr y,u) then
 	    {x}
      >>;
      return nconc(gb_vdpvordopt31 setdiff(u,v),v)
   end;

procedure gb_vdpvordopt1(p,vl,c);
   if null p then
      0
   else if domainp p or null vl then
      1
   else if mvar p neq car vl then
      gb_vdpvordopt1(p,cdr vl,c)
   else begin scalar var,pow,slot; integer n;
      n := gb_vdpvordopt1 (lc p,cdr vl,c);
      var := mvar p;
      pow := ldeg p;
      slot := assoc(var,c);
      if pow #> cadr slot then <<
	 rplaca(cdr slot,pow);
 	 rplacd(cdr slot,n)
      >> else
	 rplacd(cdr slot,n #+ cddr slot);
      return n #+ gb_vdpvordopt1 (red p,vl,c)
   end;

procedure gb_vdpvordopt2(sl1,sl2);
   % compare two slots from the power table
   <<
      sl1 := cdr sl1;
      sl2 := cdr sl2;
      car sl1 #< car sl2 or car sl1 = car sl2 and cdr sl1 #< cdr sl2
   >>;

endmodule;  % gb


module vdp;

%DS
% VDP ::= ('vdp,EV,BC,DP,PLIST)

%DS TERM
% A VDP, such that the polynomial contains one monomial with base
% coefficient 1.

%DS MONOMIAL
% A VDP, such that the polynomial contains one monomial.

procedure vdp_lbc(u);
   caddr u;

procedure vdp_evlmon(u);
   cadr u;

procedure vdp_poly(u);
   car cdddr u;

procedure vdp_zero!?(u);
   null vdp_poly u;

procedure vdp_plist(u);
   cadr cdddr u;

procedure vdp_remplist(u);
   % virtual distributive polynomial remove plist. [u] is a VDP.
   % Returns a VDP. Sets the plist of [u] in-plce to [nil].
   <<
      nth(u,5) := nil;
      u
   >>;

procedure vdp_number(f);
   vdp_getprop(f,'number) or 0;

procedure vdp_sugar(f);
   if (vdp_zero!? f or not(!*cgbsugar)) then 0 else vdp_getprop(f,'sugar) or 0;

procedure vdp_unit!?(p);
   not vdp_zero!? p and ev_zero!? vdp_evlmon p;

procedure vdp_make(vbc,vev,form);
   {'vdp,vev,vbc,form,nil};

procedure vdp_monp(u);
   dip_monp vdp_poly u;

procedure vdp_tdeg(u);
   dip_tdeg vdp_poly u;

procedure vdp_fdip(u);
   if null u then
      vdp_zero()
   else
      vdp_make(dip_lbc u,dip_evlmon u,u);

procedure vdp_appendmon(vdp,coef,vev);
   % Add a monomial to the end of a vdp (vev remains unchanged).
   if vdp_zero!? vdp then
      vdp_fmon(coef,vev)
   else if bc_zero!? coef then
      vdp
   else
      vdp_make(vdp_lbc vdp,vdp_evlmon vdp,dip_appendmon(vdp_poly vdp,coef,vev));

procedure vdp_nconcmon(vdp,coef,vev);
   % Add a monomial to the end of a vdp (vev remains unchanged).
   if vdp_zero!? vdp then
      vdp_fmon(coef,vev)
   else if bc_zero!? coef then
      vdp
   else
      vdp_make(vdp_lbc vdp,vdp_evlmon vdp,dip_nconcmon(vdp_poly vdp,coef,vev));

procedure vdp_bcquot(p,c);
   begin scalar r;
      r := vdp_fdip dip_bcquot(vdp_poly p,c);
      vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_content(p);
   dip_contenti vdp_poly p;

procedure vdp_content1(d,c);
   dip_contenti1(vdp_poly d,c);

procedure vdp_length(f);
   dip_length vdp_poly f;

procedure vdp_bcprod(p,b);
   begin scalar r;
      r := vdp_fdip dip_bcprod(vdp_poly p,b);
      vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_cancelmev(p,vev);
   begin scalar r;
      r := vdp_fdip dip_cancelmev(vdp_poly p,vev);
      vdp_setsugar(r,vdp_sugar p);
      return r
   end;

procedure vdp_sum(d1,d2);
   begin scalar r;
      r := vdp_fdip dip_sum(vdp_poly d1,vdp_poly d2);
      vdp_setsugar(r,ev_max!#(vdp_sugar d1,vdp_sugar d2));
      return r
   end;

procedure vdp_prod(d1,d2);
   begin scalar r;
      r := vdp_fdip dip_prod(vdp_poly d1,vdp_poly d2);
      vdp_setsugar(r,vdp_sugar d1 #+ vdp_sugar d2);
      return r
   end;

procedure vdp_zero();
   vdp_make('invalid,'invalid,nil);   

procedure vdp_mred(u);
   begin scalar r;
      r := dip_mred vdp_poly u;
      if null r then
 	 return vdp_zero();
      r := vdp_make(dip_lbc r,dip_evlmon r,r);
      vdp_setsugar(r,vdp_sugar u);
      return r
  end;

procedure vdp_condense(f);
   dip_condense vdp_poly f;

procedure vdp_setsugar(p,s);
   % virtual distributive polynomial set sugar. [p] is a VDP, s is a
   % machine integer. Returns a VDP. The sugar
   % property of [p] is set to [s].
   if not !*cgbsugar then p else vdp_putprop(p,'sugar,s);

procedure vdp_setnumber(p,n);
   vdp_putprop(p,'number,n);

procedure vdp_putprop(poly,prop,val);
   begin scalar c,p;
      c := cdr cdddr poly;
      p := atsoc(prop,car c);
      if p then
 	 rplacd(p,val)
      else
 	 rplaca(c,(prop . val) . car c);
      return poly
   end;

procedure vdp_getprop(poly,prop);
   (if p then cdr p else nil) where p=atsoc(prop,vdp_plist poly);

procedure vdp_fmon(coef,vev);
   % Virtual distributive polynomial from monomial. [coef] is a BC;
   % [vev] is EV. Returns a VDP, representing the monomial
   % $[coef]^[vev]$
   begin scalar r;
      r := vdp_make(coef,vev,dip_fmon(coef,vev));
      vdp_setsugar(r,ev_tdeg vev);
      return r
   end;

procedure vdp_2a(u);
   dip_2a vdp_poly u;

procedure vdp_2f(u);
   dip_2f vdp_poly u;

procedure vdp_2sq(u);
   dip_2sq vdp_poly u;

procedure vdp_init(vars,sm,sx);
   % Initializing vdp-dip polynomial package.
   dip_init(vars,sm,sx);

procedure vdp_cleanup(l);
   dip_cleanup(l);

procedure vdp_f2vdp(u);
   begin scalar dip;
      dip := dip_f2dip u;
      if null dip then
	 return vdp_zero();
      return vdp_make(dip_lbc dip,dip_evlmon dip,dip)
   end;

procedure vdp_enumerate(f);
  % f is a temporary result. Prepare it for medium range storage and
  % assign a number.
  if vdp_zero!? f or vdp_getprop(f,'number) then
     f
  else
     vdp_putprop(f,'number,(vdp_pcount!* := vdp_pcount!* #+ 1));

procedure vdp_simpcont(p);
   begin scalar q;
      q := vdp_poly p;
      if null q then
 	 return p;
      return vdp_fdip dip_simpcont q
   end;

procedure vdp_lsort(pl);
   % Distributive polynomial list sort. pl is a list of distributive
   % polynomials. vdplsort(pl) returns the sorted distributive
   % polynomial list of pl.
   sort(pl,function vdp_evlcomp);

procedure vdp_evlcomp(p1,p2);  % nicht auf das HM?
   dip_evlcomp(vdp_poly p1,vdp_poly p2);

procedure vdp_ilcomb(v1,c1,t1,v2,c2,t2);
   begin scalar r;
      r := vdp_fdip dip_ilcomb(vdp_poly v1,c1,t1,vdp_poly v2,c2,t2);
      vdp_setsugar(r,ev_max!#(
	 vdp_sugar v1 #+ ev_tdeg t1,vdp_sugar v2 #+ ev_tdeg t2));
      return r
   end;

procedure vdp_ilcombr(v1,c1,v2,c2,t2);
   begin scalar r;
      r := vdp_fdip dip_ilcombr(vdp_poly v1,c1,vdp_poly v2,c2,t2);
      vdp_setsugar(r,ev_max!#(vdp_sugar v1,vdp_sugar v2 #+ ev_tdeg t2));
      return r
   end;

% The following procedures are not used for the Groebner basis
% computation but are useful anyway.

procedure gb_reduce(f,g);
   % Groebner basis reduce. [f] is a VDP, [g] is a list of VDP's.
   % Returns a VDP, a normal form of [f] wrt. [g]. Note that the
   % result contains in general denominators.
   begin scalar f1,c,vev,divisor,tai,fold;
      fold := f;
      f1 := vdp_setsugar(vdp_zero(),vdp_sugar f);
      while not vdp_zero!? f do <<
	 vev := vdp_evlmon f;
 	 c := vdp_lbc f;
	 divisor := gb_searchinlist(vev,g);
	 if divisor then <<
	    tai := T;
	    if vdp_monp divisor then
	       f := vdp_cancelmev(f,vdp_evlmon divisor)
	    else
	       f := gb_reduceonesteprat(f,c,vev,divisor);
	 >> else <<
	    f := gb_shift(f,f1);
	    f1 := secondvalue!*
	 >> 
      >>;
      return if tai then f1 else fold
   end;

procedure gb_reduceonesteprat(f,c,vev,g1);
   % Groebner basis reduce one step rational. [f] is VDP; [c] is BC,
   % the head coefficient of [f]; [vev] is a EV, the head term of [f];
   % [g1] is a VDP such that its head monomial divides the head
   % monomial of [f]. Returns a VDP $h$. $h$ is constructed from [f]
   % by reducing the head monomial of [f] by [g1].
   begin scalar b,rg1,vevcof;
      rg1 := vdp_mred g1;
      if vdp_zero!? rg1 then  % g1 is monomial
	 return vdp_mred f; 
      b := bc_quot(c,vdp_lbc g1);
      vevcof := ev_dif(vev,vdp_evlmon g1);
      return vdp_ilcombr(vdp_mred f,bc_a2bc 1,rg1,bc_neg b,vevcof);
   end;

endmodule;  % vdp

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/cgb.bib0000644000175000017500000000262511526203062022455 0ustar  giovannigiovanni@Article{DolzmannSturm:97a,
  author = 	 {Dolzmann, Andreas and Sturm, Thomas},
  title = 	 {Redlog: Computer Algebra Meets Computer Logic},
  journal = 	 {ACM SIGSAM Bulletin},
  year = 	 1997,
  volume =	 31,
  number =	 2,
  month =	 Jun,
  pages =	 {2-9}
}

@TechReport{DolzmannSturm:96a,
  author = 	 {Dolzmann, Andreas and Sturm, Thomas},
  title = 	 {Redlog User Manual},
  institution =  {FMI, Universit\"at Passau},
  year = 	 1996,
  type =	 {Technical Report},
  number =	 {MIP-9616},
  address =	 {D-94030 Passau, Germany},
  month =	 oct,
  note =	 {Edition 1.0 for Version 1.0}
}

@Manual{DolzmannSturm:99,
  title = 	 {Redlog User Manual},
  author =	 {Dolzmann, Andreas and Sturm, Thomas},
  organization = {FMI, Universit\"at Passau},
  address =	 {D-94030 Passau, Germany},
  note =	 {Edition 2.0 for Version 2.0},
  year =	 1999,
  month =	 apr
}

@Article{Weispfenning:92,
  author =       {Weispfenning, Volker},
  title =        {Comprehensive {G}r\"obner Bases},
  journal =      {Journal of Symbolic Computation},
  year =         1992,
  month =        jul,
  volume =       14,
  pages =        {1-29}
}

@Article{DolzmannSturm:97c,
  author = 	 {Dolzmann, Andreas and Sturm, Thomas},
  title = 	 {Simplification of Quantifier-free Formulae over
		  Ordered Fields},
  journal = 	 {Journal of Symbolic Computation},
  year = 	 1997,
  volume =	 24,
  number =	 2,
  month =	 aug,
  pages =	 {209-231}
}
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/cgb.rlg0000644000175000017500000014070611527635055022524 0ustar  giovannigiovanniFri Feb 18 21:28:11 2011 run on win32
% Examples taken from the manual:

% 1 Introduction
oo := torder({x,y},lex)$


cgb {a*x,x+y};


{x + y,a*x,a*y}

gsys {a*x,x+y};


{{a <> 0,{x + y,a*x,a*y}},

 {a = 0,{x + y}}}

torder oo;


{{x,y},lex}


% 4 CGB: Comprehensive Groebner Basis
oo := torder({x,y},lex)$


cgb {a*x+y,x+b*y};


{x + b*y,a*x + y,(a*b - 1)*y}

torder oo;


{{x,y},lex}


% 5 GSYS: Groebner System
oo := torder({x,y},lex)$


gsys {a*x+y,x+b*y};


{{a*b - 1 <> 0 and a <> 0,

  {a*x + y,x + b*y,(a*b - 1)*y}},

 {a <> 0 and a*b - 1 = 0,

  {a*x + y,x + b*y}},

 {a = 0,{x + b*y,y}}}

torder oo;


{{x,y},lex}


% 6 GSYS2CGB: Groebner System to CGB
oo := torder({x,y},lex)$


gsys {a*x+y,x+b*y};


{{a*b - 1 <> 0 and a <> 0,

  {a*x + y,x + b*y,(a*b - 1)*y}},

 {a <> 0 and a*b - 1 = 0,

  {a*x + y,x + b*y}},

 {a = 0,{x + b*y,y}}}

gsys2cgb ws;


{x + b*y,a*x + y,y,(a*b - 1)*y}

torder oo;


{{x,y},lex}


% 7 Switch CGBREAL: Computing over the Real Numbers
oo := torder({x,y},lex)$


off cgbreal;


gsys {a*x+y,x-a*y};


   2
{{a  + 1 <> 0 and a <> 0,

                     2
  {a*x + y,x - a*y,(a  + 1)*y}},

              2
 {a <> 0 and a  + 1 = 0,

  {a*x + y,x - a*y}},

 {a = 0,{x - a*y,y}}}

on cgbreal;


gsys({a*x+y,x-a*y});


{{a <> 0,

                     2
  {a*x + y,x - a*y,(a  + 1)*y}},

 {a = 0,{x - a*y,y}}}

torder oo;


{{x,y},lex}


% Miscellaneous examples:

% Dolzmann's Example
oo := torder({x,y,z},lex);


oo := {{},lex}

cgb({a*x+b*y,c*x+d*y,(a*d-b*c)*z});


{c*x + d*y,

 a*x + b*y,

 (a*d - b*c)*y,

 (a*d - b*c)*z}

gsys({a*x+b*y,c*x+d*y,(a*d-b*c)*z});


{{a*d - b*c <> 0 and a <> 0 and c <> 0,

  {a*x + b*y,

   c*x + d*y,

   (a*d - b*c)*y,

   (a*d - b*c)*z}},

 {a*d - b*c <> 0 and a <> 0 and d <> 0 and c = 0,

  {a*x + b*y,d*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and a <> 0 and c = 0 and d = 0,

  {a*x + b*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and b <> 0 and c <> 0 and a = 0,

  {c*x + d*y,b*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and b <> 0 and d <> 0 and a = 0 and c = 0,

  {b*y,d*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and b <> 0 and a = 0 and c = 0 and d = 0,

  {b*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and c <> 0 and a = 0 and b = 0,

  {c*x + d*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and d <> 0 and a = 0 and b = 0 and c = 0,

  {d*y,(a*d - b*c)*z}},

 {a*d - b*c <> 0 and a = 0 and b = 0 and c = 0 and d = 0,

  {(a*d - b*c)*z}},

 {a <> 0 and c <> 0 and a*d - b*c = 0,

  {a*x + b*y,c*x + d*y}},

 {a <> 0 and d <> 0 and a*d - b*c = 0 and c = 0,

  {a*x + b*y,d*y}},

 {a <> 0 and a*d - b*c = 0 and c = 0 and d = 0,

  {a*x + b*y}},

 {b <> 0 and c <> 0 and a*d - b*c = 0 and a = 0,

  {c*x + d*y,b*y}},

 {b <> 0 and d <> 0 and a*d - b*c = 0 and a = 0 and c = 0,

  {b*y,d*y}},

 {b <> 0 and a*d - b*c = 0 and a = 0 and c = 0 and d = 0,

  {b*y}},

 {c <> 0 and a*d - b*c = 0 and a = 0 and b = 0,

  {c*x + d*y}},

 {d <> 0 and a*d - b*c = 0 and a = 0 and b = 0 and c = 0,

  {d*y}},

 {a*d - b*c = 0 and a = 0 and b = 0 and c = 0 and d = 0,

  {}}}

gsys2cgb ws;


{c*x + d*y,

 a*x + b*y,

 b*y,

 d*y,

 (a*d - b*c)*y,

 (a*d - b*c)*z}

torder oo;


{{x,y,z},lex}


% Forsman's Example (hybrid control system).
oo := torder({x1,x2,y2,y1,y0},lex);


oo := {{},lex}

gsys({(u1*u2-u1)*x1+u2*x2+y2,(u2-1)*x1+u2*x2+y1,-x2+y0});


{{u1*u2 - u1 <> 0,

  {(u1*u2 - u1)*x1 + u2*x2 + y2,

   (u2 - 1)*x1 + u2*x2 + y1,

   x2 - y0,

   y2 - u1*y1 - (u1*u2 - u2)*y0}},

 {u2 - 1 <> 0 and u2 <> 0 and u1*u2 - u1 = 0,

  {(u2 - 1)*x1 + u2*x2 + y1,u2*x2 + y2,x2 - y0,y2 + u2*y0}},

 {u1*u2 - u1 = 0 and u2 - 1 = 0,

  {u2*x2 + y2,u2*x2 + y1,x2 - y0,y2 - y1,y1 + u2*y0}},

 {u1*u2 - u1 = 0 and u2 = 0,

  {(u2 - 1)*x1 + u2*x2 + y1,x2 - y0,y2}}}

torder oo;


{{x1,x2,y2,y1,y0},lex}


% Weispfenning's Example
oo := torder({x,y},lex);


oo := {{},lex}

gsys({v*x*y + x,u*y^2 + x^2});


{{u*v <> 0 and v <> 0,

    2      2
  {x  + u*y ,

   v*x*y + x,

          3      2
   (u*v)*y  + u*y }},

 {u <> 0 and v <> 0 and u*v = 0,

    2      2                  2
  {x  + u*y ,v*x*y + x,u*x,u*y }},

 {u <> 0 and v = 0,

    2      2      2
  {x  + u*y ,x,u*y }},

 {v <> 0 and u*v = 0 and u = 0,

    2      2
  {x  + u*y ,v*x*y + x}},

                    2      2
 {u = 0 and v = 0,{x  + u*y ,x}}}

torder oo;


{{x,y},lex}


% The folllowing three examples are taken from
% Weispfenning, Comprehensive Groebner Bases,
% J. Symbolic Computation (1992) 14, 1-29

% Weispfenning's Example 7.1
oo := torder({x},lex);


oo := {{},lex}

gsys({a0*x**2 + a1*x + a2,b0*x**2 + b1*x + b2});


    3   2     2                2              2      2        2
{{a0 *b2  - a0 *a1*b1*b2 - 2*a0 *a2*b0*b2 + a0 *a2*b1  + a0*a1 *b0*b2

                           2   2
   - a0*a1*a2*b0*b1 + a0*a2 *b0  <> 0 and a0*b1 - a1*b0 <> 0 and a0 <> 0

   and b0 <> 0,

     3   2     2                2              2      2        2
  {a0 *b2  - a0 *a1*b1*b2 - 2*a0 *a2*b0*b2 + a0 *a2*b1  + a0*a1 *b0*b2

                            2   2
    - a0*a1*a2*b0*b1 + a0*a2 *b0 }},

                                                   3   2     2
 {a0*b1 - a1*b0 <> 0 and a0 <> 0 and b0 <> 0 and a0 *b2  - a0 *a1*b1*b2

         2              2      2        2                               2   2
   - 2*a0 *a2*b0*b2 + a0 *a2*b1  + a0*a1 *b0*b2 - a0*a1*a2*b0*b1 + a0*a2 *b0

   = 0,

       2
  {a0*x  + a1*x + a2,

       2
   b0*x  + b1*x + b2,

   (a0*b1 - a1*b0)*x + (a0*b2 - a2*b0)}},

       2                   2
 {a0*b2  - a1*b1*b2 + a2*b1  <> 0 and a0 <> 0 and b1 <> 0 and b0 = 0,

        2                   2
  {a0*b2  - a1*b1*b2 + a2*b1 }},

 {a0*b2 - a2*b0 <> 0 and a0 <> 0 and b0 <> 0 and a0*b1 - a1*b0 = 0,

  {a0*b2 - a2*b0}},

 {a0 <> 0 and b0 <> 0 and a0*b1 - a1*b0 = 0 and a0*b2 - a2*b0 = 0,

       2                 2
  {a0*x  + a1*x + a2,b0*x  + b1*x + b2}},

                               2                   2
 {a0 <> 0 and b1 <> 0 and a0*b2  - a1*b1*b2 + a2*b1  = 0 and b0 = 0,

       2
  {a0*x  + a1*x + a2,b1*x + b2}},

 {a0 <> 0 and b2 <> 0 and b0 = 0 and b1 = 0,{b2}},

 {a0 <> 0 and b0 = 0 and b1 = 0 and b2 = 0,

       2
  {a0*x  + a1*x + a2}},

    2                   2
 {a1 *b2 - a1*a2*b1 + a2 *b0 <> 0 and a1 <> 0 and b0 <> 0 and a0 = 0,

     2                   2
  {a1 *b2 - a1*a2*b1 + a2 *b0}},

 {a1*b2 - a2*b1 <> 0 and a1 <> 0 and b1 <> 0 and a0 = 0 and b0 = 0,

  {a1*b2 - a2*b1}},

                                       2                   2
 {a1 <> 0 and b0 <> 0 and a0 = 0 and a1 *b2 - a1*a2*b1 + a2 *b0 = 0,

       2
  {b0*x  + b1*x + b2,a1*x + a2}},

 {a1 <> 0 and b1 <> 0 and a0 = 0 and a1*b2 - a2*b1 = 0 and b0 = 0,

  {a1*x + a2,b1*x + b2}},

 {a1 <> 0 and b2 <> 0 and a0 = 0 and b0 = 0 and b1 = 0,

  {b2}},

 {a1 <> 0 and a0 = 0 and b0 = 0 and b1 = 0 and b2 = 0,

  {a1*x + a2}},

 {a2 <> 0 and a0 = 0 and a1 = 0,{a2}},

 {b0 <> 0 and a0 = 0 and a1 = 0 and a2 = 0,

       2
  {b0*x  + b1*x + b2}},

 {b1 <> 0 and a0 = 0 and a1 = 0 and a2 = 0 and b0 = 0,

  {b1*x + b2}},

 {b2 <> 0 and a0 = 0 and a1 = 0 and a2 = 0 and b0 = 0 and b1 = 0,

  {b2}},

 {a0 = 0 and a1 = 0 and a2 = 0 and b0 = 0 and b1 = 0 and b2 = 0,

  {}}}

torder oo;


{{x},lex}


% Weispfenning's Example 7.2
oo := torder({x,y},lex);


oo := {{},lex}

gsys({v*x*y + u*x**2 + x,u*y**2 + x**2});


   4        3
{{u *v + u*v  <> 0 and u <> 0 and v <> 0,

      2
  {u*x  + v*x*y + x,

    2      2
   x  + u*y ,

                2  2
   v*x*y + x - u *y ,

    3       5      2  3   3     5    2  2   2
   u *x + (u *v + u *v )*y  - (u  - u *v )*y ,

     7  2    4  4   4       4  3   3     4  2   2
   (u *v  + u *v )*y  + (2*u *v )*y  + (u *v )*y }},

                         4        3
 {u <> 0 and v <> 0 and u *v + u*v  = 0,

      2
  {u*x  + v*x*y + x,

    2      2
   x  + u*y ,

                2  2
   v*x*y + x - u *y ,

    3       5      2  3   3     5    2  2   2
   u *x + (u *v + u *v )*y  - (u  - u *v )*y ,

       4  3   3     4  2   2
   (2*u *v )*y  + (u *v )*y }},

 {u <> 0 and v = 0,

      2
  {u*x  + v*x*y + x,

    2      2
   x  + u*y ,

        2  2
   x - u *y ,

    5  4    2  2
   u *y  + u *y }},

 {v <> 0 and u = 0,

    2      2
  {x  + u*y ,v*x*y + x}},

                    2      2
 {u = 0 and v = 0,{x  + u*y ,x}}}

torder oo;


{{x,y},lex}


% Weispfenning's Example 7.3
oo := torder({x1,x2,x3,x4},lex);


oo := {{},lex}

gsys {x4 - (a4-a2),x1 + x2 + x3 + x4 + (a1 + a3 + a4),
   x1*x3 + x1*x4 + x2*x3 + x3*x4 - (a1*a4 + a1*a3 + a3*a4),x1*x3*x4 - a1*a3*a4};


       2                                  2     3     2          2
{{a1*a2  - a1*a2*a3 - 3*a1*a2*a4 + 2*a1*a4  - a2  + a2 *a3 + 4*a2 *a4

                         2          2       3
   - 3*a2*a3*a4 - 5*a2*a4  + 2*a3*a4  + 2*a4  <> 0 and a2 - a4 = 0,

        2                                  2     3     2          2
  {a1*a2  - a1*a2*a3 - 3*a1*a2*a4 + 2*a1*a4  - a2  + a2 *a3 + 4*a2 *a4

                          2          2       3
    - 3*a2*a3*a4 - 5*a2*a4  + 2*a3*a4  + 2*a4 }},

 {a2 - a4 <> 0,

  {x1*x3*x4 - a1*a3*a4,

   x1*x3 + x1*x4 + x2*x3 + x3*x4 - (a1*a3 + a1*a4 + a3*a4),

   x1 + x2 + x3 + x4 + (a1 + a3 + a4),

                    2
   (a2 - a4)*x2 - x3  - (a1 - a2 + a3 + 2*a4)*x3

                                   2                                   2
    + (a1*a2 - a1*a3 - 2*a1*a4 - a2  + a2*a3 + 3*a2*a4 - 2*a3*a4 - 2*a4 ),

     3                    2
   x3  + (a1 + a3 + a4)*x3  + (a1*a3 + a1*a4 + a3*a4)*x3 - a1*a3*a4,

   x4 + (a2 - a4)}},

       2                                  2     3     2          2
 {a1*a2  - a1*a2*a3 - 3*a1*a2*a4 + 2*a1*a4  - a2  + a2 *a3 + 4*a2 *a4

                         2          2       3
   - 3*a2*a3*a4 - 5*a2*a4  + 2*a3*a4  + 2*a4  = 0 and a2 - a4 = 0,

  {x1*x3*x4 - a1*a3*a4,

   x1*x3 + x1*x4 + x2*x3 + x3*x4 - (a1*a3 + a1*a4 + a3*a4),

   x1 + x2 + x3 + x4 + (a1 + a3 + a4),

        2
    - x3  - (a1 - a2 + a3 + 2*a4)*x3

                                   2                                   2
    + (a1*a2 - a1*a3 - 2*a1*a4 - a2  + a2*a3 + 3*a2*a4 - 2*a3*a4 - 2*a4 ),

   x4 + (a2 - a4)}}}

torder oo;


{{x1,x2,x3,x4},lex}


% Pesch's example (Circle through three points)
oo := torder({y,x},revgradlex);


oo := {{},lex}

gsys({2*b2*y + 2*a2*x - b2**2 + a2**2,2*b1*y + 2*a1*x - b1**2 + a1**2});


    2           2        2        2
{{a1 *a2 - a1*a2  + a1*b2  - a2*b1  <> 0 and a1 <> 0 and a2 <> 0 and b1 = 0

   and b2 = 0,

     2           2        2        2
  {a1 *a2 - a1*a2  + a1*b2  - a2*b1 }},

    2        2        2           2
 {a1 *b2 - a2 *b1 - b1 *b2 + b1*b2  <> 0 and b1 <> 0 and b2 <> 0

   and a1*b2 - a2*b1 = 0,

     2        2        2           2
  {a1 *b2 - a2 *b1 - b1 *b2 + b1*b2 }},

    2     2
 {a1  - b1  <> 0 and a1 = 0 and b1 = 0,

     2     2
  {a1  - b1 }},

 {a1*b2 - a2*b1 <> 0 and b1 <> 0 and b2 <> 0,

                            2     2
  {(2*b1)*y + (2*a1)*x + (a1  - b1 ),

                            2     2
   (2*b2)*y + (2*a2)*x + (a2  - b2 ),

                              2        2        2           2
   (2*a1*b2 - 2*a2*b1)*x + (a1 *b2 - a2 *b1 - b1 *b2 + b1*b2 )}},

                2     2
 {a1 <> 0 and a2  - b2  <> 0 and a2 = 0 and b1 = 0 and b2 = 0,

     2     2
  {a2  - b2 }},

                            2           2        2        2
 {a1 <> 0 and a2 <> 0 and a1 *a2 - a1*a2  + a1*b2  - a2*b1  = 0 and b1 = 0

   and b2 = 0,

                 2     2
  {(2*a1)*x + (a1  - b1 ),

                 2     2
   (2*a2)*x + (a2  - b2 )}},

 {a1 <> 0 and b2 <> 0 and b1 = 0,

                            2     2
  {(2*b2)*y + (2*a2)*x + (a2  - b2 ),

                 2     2
   (2*a1)*x + (a1  - b1 )}},

                2     2
 {a1 <> 0 and a2  - b2  = 0 and a2 = 0 and b1 = 0 and b2 = 0,

                 2     2
  {(2*a1)*x + (a1  - b1 )}},

    2     2
 {a2  - b2  <> 0 and b1 <> 0 and a2 = 0 and b2 = 0,

     2     2
  {a2  - b2 }},

    2     2            2     2
 {a2  - b2  <> 0 and a1  - b1  = 0 and a1 = 0 and a2 = 0 and b1 = 0 and b2 = 0,

     2     2
  {a2  - b2 }},

 {a2 <> 0 and b1 <> 0 and b2 = 0,

                            2     2
  {(2*b1)*y + (2*a1)*x + (a1  - b1 ),

                 2     2
   (2*a2)*x + (a2  - b2 )}},

                2     2
 {a2 <> 0 and a1  - b1  = 0 and a1 = 0 and b1 = 0 and b2 = 0,

                 2     2
  {(2*a2)*x + (a2  - b2 )}},

                            2        2        2           2
 {b1 <> 0 and b2 <> 0 and a1 *b2 - a2 *b1 - b1 *b2 + b1*b2  = 0

   and a1*b2 - a2*b1 = 0,

                            2     2
  {(2*b1)*y + (2*a1)*x + (a1  - b1 ),

                            2     2
   (2*b2)*y + (2*a2)*x + (a2  - b2 )}},

                2     2
 {b1 <> 0 and a2  - b2  = 0 and a2 = 0 and b2 = 0,

                            2     2
  {(2*b1)*y + (2*a1)*x + (a1  - b1 )}},

                2     2
 {b2 <> 0 and a1  - b1  = 0 and a1 = 0 and b1 = 0,

                            2     2
  {(2*b2)*y + (2*a2)*x + (a2  - b2 )}},

    2     2                      2     2
 {a1  - b1  = 0 and a1 = 0 and a2  - b2  = 0 and a2 = 0 and b1 = 0 and b2 = 0,

  {}}}

torder oo;


{{y,x},revgradlex}


% Effelterre's example (Aspect graphs)
f1 := -4-4*v**2-4*u**2+40*v*v1+24*v-120*v1+8*u-40*v2-68*v1**2-100*v2**2+40*u*v2+
24*v1*v2-4*v1**2*u-4*v2**2*v**2+24*v2**2*v-24*v1*u*v2+8*v*v1*u*v2$


f2 := 8*v*v1*u*v2-4*v1**2*u**2+4*v1**2-4*v2**2*v**2+4*v2**2-16*v**2-16*u**2+16$


f3 := 16*v-48*u+16*v*v1**2-48*u*v2**2-12*v1**2*u+4*v2**2*v-36*v*v1*v2+
12*v1*u*v2+12*v*v2**2*u-
80*u*v1+80*v2*v-20*v1*u*v2**2+20*v2*v*v1**2-20*v1**3*u+20*v2**3*v-12*v1**2*v*u+
12*v2*v**2*v1-12*v1*u**2*v2$


f4 := -160u*v2-1596v2**2+3200*v2-1596-4*u**2+160*u$



% Special case I2, v1=0
oo := torder({v,u},lex);


oo := {{},lex}

gsys(sub(v1=0,{f1,f2,f4}));


                  16                   15                    14
{{1000557799569*v2   - 8971728968760*v2   + 32332553961916*v2

                      13                    12                   11
   - 56816638983720*v2   + 43557281160966*v2   - 2232864400680*v2

                     10                    9                    8
   - 2141149653636*v2   - 24710286679320*v2  + 22557177598385*v2

                     7                   6                   5
   - 4364899181280*v2  + 1970637124608*v2  - 2915313822720*v2

                     4                   3                  2
   + 1467702460416*v2  - 1340557025280*v2  + 685570158592*v2  - 140796887040*v2

                                  7            6            5           4
   + 63647907840 <> 0 and 55175*v2  - 184787*v2  + 144885*v2  + 44895*v2

             3           2
   - 13020*v2  - 35580*v2  + 320*v2 - 6368 <> 0,

                   16                   15                    14
  {1000557799569*v2   - 8971728968760*v2   + 32332553961916*v2

                       13                    12                   11
    - 56816638983720*v2   + 43557281160966*v2   - 2232864400680*v2

                      10                    9                    8
    - 2141149653636*v2   - 24710286679320*v2  + 22557177598385*v2

                      7                   6                   5
    - 4364899181280*v2  + 1970637124608*v2  - 2915313822720*v2

                      4                   3                  2
    + 1467702460416*v2  - 1340557025280*v2  + 685570158592*v2  - 140796887040*v2

    + 63647907840}},

            8              7              6             5             4
 {3389663*v2  - 14658420*v2  + 20230730*v2  - 6945060*v2  - 3218385*v2

              3             2                                       7
   - 497040*v2  + 1656704*v2  - 257280*v2 + 255872 <> 0 and 55175*v2

              6            5           4           3           2
   - 184787*v2  + 144885*v2  + 44895*v2  - 13020*v2  - 35580*v2  + 320*v2 - 6368

   = 0,

             8              7              6             5             4
  {3389663*v2  - 14658420*v2  + 20230730*v2  - 6945060*v2  - 3218385*v2

               3             2
    - 497040*v2  + 1656704*v2  - 257280*v2 + 255872}},

          7            6            5           4           3           2
 {55175*v2  - 184787*v2  + 144885*v2  + 44895*v2  - 13020*v2  - 35580*v2

                                            16                   15
   + 320*v2 - 6368 <> 0 and 1000557799569*v2   - 8971728968760*v2

                      14                    13                    12
   + 32332553961916*v2   - 56816638983720*v2   + 43557281160966*v2

                     11                   10                    9
   - 2232864400680*v2   - 2141149653636*v2   - 24710286679320*v2

                      8                   7                   6
   + 22557177598385*v2  - 4364899181280*v2  + 1970637124608*v2

                     5                   4                   3
   - 2915313822720*v2  + 1467702460416*v2  - 1340557025280*v2

                    2
   + 685570158592*v2  - 140796887040*v2 + 63647907840 = 0,

      2       2        2           2                         2
  {(v2  + 1)*v  - (6*v2  + 6)*v + u  - (10*v2 + 2)*u + (25*v2  + 10*v2 + 1),

      2       2      2      2
   (v2  + 4)*v  + 4*u  - (v2  + 4),

        4        2                  3         2
   (6*v2  + 30*v2  + 24)*v - (110*v2  - 122*v2  - 40*v2 - 8)*u

              4          3          2
    - (1223*v2  - 2390*v2  + 1303*v2  + 40*v2 + 8),

    2                           2
   u  + (40*v2 - 40)*u + (399*v2  - 800*v2 + 399),

             7            6            5            4           3            2
   (220700*v2  - 739148*v2  + 579540*v2  + 179580*v2  - 52080*v2  - 142320*v2

                                       8              7              6
     + 1280*v2 - 25472)*u + (3389663*v2  - 14658420*v2  + 20230730*v2

                   5             4            3             2
       - 6945060*v2  - 3218385*v2  - 497040*v2  + 1656704*v2  - 257280*v2

       + 255872)}},

            8              7              6             5             4
 {3389663*v2  - 14658420*v2  + 20230730*v2  - 6945060*v2  - 3218385*v2

              3             2                                      7
   - 497040*v2  + 1656704*v2  - 257280*v2 + 255872 = 0 and 55175*v2

              6            5           4           3           2
   - 184787*v2  + 144885*v2  + 44895*v2  - 13020*v2  - 35580*v2  + 320*v2 - 6368

   = 0,

      2       2        2           2                         2
  {(v2  + 1)*v  - (6*v2  + 6)*v + u  - (10*v2 + 2)*u + (25*v2  + 10*v2 + 1),

      2       2      2      2
   (v2  + 4)*v  + 4*u  - (v2  + 4),

        4        2                  3         2
   (6*v2  + 30*v2  + 24)*v - (110*v2  - 122*v2  - 40*v2 - 8)*u

              4          3          2
    - (1223*v2  - 2390*v2  + 1303*v2  + 40*v2 + 8),

    2                           2
   u  + (40*v2 - 40)*u + (399*v2  - 800*v2 + 399)}}}

torder oo;


{{v,u},lex}

clear f1,f2,f3,f4;



% Sit's Example 2.2
oo := torder({z2,z2},revgradlex);


oo := {{},lex}

gsys({d*z2 + c*z1 - v,b*z2 + a*z1 - u});


{{a*d*z1 - b*c*z1 + b*v - d*u <> 0 and b <> 0 and d <> 0,

  {a*d*z1 - b*c*z1 + b*v - d*u}},

 {a*z1 - u <> 0 and b = 0,{a*z1 - u}},

 {b <> 0 and c*z1 - v <> 0 and d = 0,

  {c*z1 - v}},

 {b <> 0 and d <> 0 and a*d*z1 - b*c*z1 + b*v - d*u = 0,

  {b*z2 + (a*z1 - u),d*z2 + (c*z1 - v)}},

 {b <> 0 and c*z1 - v = 0 and d = 0,

  {b*z2 + (a*z1 - u)}},

 {c*z1 - v <> 0 and a*z1 - u = 0 and b = 0 and d = 0,

  {c*z1 - v}},

 {d <> 0 and a*z1 - u = 0 and b = 0,

  {d*z2 + (c*z1 - v)}},

 {a*z1 - u = 0 and b = 0 and c*z1 - v = 0 and d = 0,

  {}}}

torder oo;


{{z2,z2},revgradlex}


% Sit's Example 2.3
oo := torder({z2,z2},revgradlex);


oo := {{},lex}

gsys({x**3*z2 + (x**2+1)*z1,x**2*z2 + x*z1 - 1});


   2
{{x *z1 + z1 <> 0 and x = 0,

    2
  {x *z1 + z1}},

                     2
 {x*z1 - 1 <> 0 and x *z1 + z1 = 0 and x = 0,

  {x*z1 - 1}},

 {x + z1 <> 0 and x <> 0,{x + z1}},

 {x <> 0 and x + z1 = 0,

    3        2           2
  {x *z2 + (x *z1 + z1),x *z2 + (x*z1 - 1)}},

   2
 {x *z1 + z1 = 0 and x*z1 - 1 = 0 and x = 0,

  {}}}

torder oo;


{{z2,z2},revgradlex}


% Sit's Example 3.3
oo := torder({z3,z2,z2},revgradlex);


oo := {{},lex}

gsys({z3 + b*z2 + a*z1 - 1,a*z3 + z2 + b*z1 - 1,b*z3 + a*z2 + z1 - 1});


   3       2
{{a *z1 - a  - 2*a*b*z1 + a*b + a + z1 - 1 <> 0 and a <> 0 and b = 0,

    3       2
  {a *z1 - a  - 2*a*b*z1 + a*b + a + z1 - 1}},

   3       2                         3       2                            2
 {a *z1 - a  - 3*a*b*z1 + a*b + a + b *z1 - b  + b + z1 - 1 <> 0 and a - b  <> 0

   and a <> 0 and b <> 0,

    3       2                         3       2
  {a *z1 - a  - 3*a*b*z1 + a*b + a + b *z1 - b  + b + z1 - 1}},

   2
 {a *z1 - a - b*z1 + 1 <> 0 and a <> 0 and b <> 0 and a*b*z1 - b - z1 + 1 = 0

                            2
   and a*b - 1 = 0 and a - b  = 0,

    2
  {a *z1 - a - b*z1 + 1}},

                  3       2
 {2*a*b*z1 - a - b *z1 + b  - b - z1 + 1 <> 0 and b <> 0 and a = 0,

                   3       2
  {2*a*b*z1 - a - b *z1 + b  - b - z1 + 1}},

                                                          2
 {a*b*z1 - b - z1 + 1 <> 0 and a <> 0 and b <> 0 and a - b  = 0,

  { - (a*b*z1 - b - z1 + 1)}},

                                                                          2
 {a*b - 1 <> 0 and a <> 0 and b <> 0 and a*b*z1 - b - z1 + 1 = 0 and a - b  = 0,

  {z3 + b*z2 + (a*z1 - 1),

   b*z3 + a*z2 + (z1 - 1),

   a*z3 + z2 + (b*z1 - 1),

                    2
   (a*b - 1)*z2 + (a *z1 - a - b*z1 + 1)}},

       2
 {a - b  <> 0 and a <> 0 and b <> 0

        3       2                         3       2
   and a *z1 - a  - 3*a*b*z1 + a*b + a + b *z1 - b  + b + z1 - 1 = 0,

  {z3 + b*z2 + (a*z1 - 1),

   b*z3 + a*z2 + (z1 - 1),

   a*z3 + z2 + (b*z1 - 1),

         2
   (a - b )*z2 - (a*b*z1 - b - z1 + 1)}},

                         2
 {a <> 0 and b <> 0 and a *z1 - a - b*z1 + 1 = 0 and a*b*z1 - b - z1 + 1 = 0

                            2
   and a*b - 1 = 0 and a - b  = 0,

  {z3 + b*z2 + (a*z1 - 1),

   b*z3 + a*z2 + (z1 - 1),

   a*z3 + z2 + (b*z1 - 1)}},

              3       2
 {a <> 0 and a *z1 - a  - 2*a*b*z1 + a*b + a + z1 - 1 = 0 and b = 0,

  {z3 + b*z2 + (a*z1 - 1),

   a*z3 + z2 + (b*z1 - 1),

   a*z2 + (z1 - 1)}},

                             3       2
 {b <> 0 and 2*a*b*z1 - a - b *z1 + b  - b - z1 + 1 = 0 and a = 0,

  {z3 + b*z2 + (a*z1 - 1),

   b*z3 + a*z2 + (z1 - 1),

   z2 + (b*z1 - 1)}},

 {z1 - 1 <> 0 and a = 0 and b = 0,{z1 - 1}},

 {a = 0 and b = 0 and z1 - 1 = 0,

  {z3 + b*z2 + (a*z1 - 1),z2 + (b*z1 - 1)}}}

torder oo;


{{z3,z2,z2},revgradlex}


% Sit's Example 8.3
oo := torder({z4,z3,z2,z2},revgradlex);


oo := {{},lex}

gsys({z4 + c*z3 + b*z2 + a*z1 - w2,2*z4 + z2 - w1,a*z4 - z3 - w4,d*z4 + z3 +
2*z1 - w3,z4 + z1 - w5});


   3         2           2  2         2  2       2           2         2
{{a *c*z1 + a *b*c*w1 + a *c *w3 - 2*a *c *z1 + a *c*d*z1 - a *c*w2 + a *z1

                                                                     2
   + a*b*c*d*w1 - 2*a*b*c*w3 - 2*a*b*c*w4 + 4*a*b*c*z1 + a*b*w1 - a*c *d*w4

   - a*c*d*w2 + 2*a*c*w3 + a*c*w4 - 4*a*c*z1 + a*d*z1 - a*w2 + b*d*w1 - 2*b*w3

   - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 <> 0 and a*b + b*d <> 0

   and a*c + 1 <> 0 and a <> 0 and d <> 0,

    3         2           2  2         2  2       2           2         2
  {a *c*z1 + a *b*c*w1 + a *c *w3 - 2*a *c *z1 + a *c*d*z1 - a *c*w2 + a *z1

                                                                      2
    + a*b*c*d*w1 - 2*a*b*c*w3 - 2*a*b*c*w4 + 4*a*b*c*z1 + a*b*w1 - a*c *d*w4

    - a*c*d*w2 + 2*a*c*w3 + a*c*w4 - 4*a*c*z1 + a*d*z1 - a*w2 + b*d*w1 - 2*b*w3

    - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1}},

   2  2       2  2       2                                                2
 {a *c *w5 - a *c *z1 + a *c*z1 + a*b*c*w1 - 2*a*b*c*w5 + 2*a*b*c*z1 - a*c *w4

   - a*c*w2 + 2*a*c*w5 - 2*a*c*z1 + a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2

   + w5 - z1 <> 0 and a*c - 2*b + 1 <> 0 and a*c + 1 <> 0 and a <> 0 and d <> 0 

       2
  and a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1

   = 0 and a*b + b*d = 0,

    2  2       2  2       2                                                2
  {a *c *w5 - a *c *z1 + a *c*z1 + a*b*c*w1 - 2*a*b*c*w5 + 2*a*b*c*z1 - a*c *w4

    - a*c*w2 + 2*a*c*w5 - 2*a*c*z1 + a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2

    + w5 - z1}},

   2           2
 {a *c*d*z1 - a *z1 + a*b*c*d*w1 - 2*a*b*c*w3 + 4*a*b*c*z1 - a*b*w1 - a*c*d*w2

   + a*w2 + 2*b*w4 + c*d*w4 - w4 <> 0 and a*b <> 0 and a*c*d - a <> 0 and a <> 0

   and d <> 0 and a*c + 1 = 0,

    2           2
  {a *c*d*z1 - a *z1 + a*b*c*d*w1 - 2*a*b*c*w3 + 4*a*b*c*z1 - a*b*w1 - a*c*d*w2

    + a*w2 + 2*b*w4 + c*d*w4 - w4}},

   2         2
 {a *c*w5 - a *c*z1 + a*c*d*w5 - a*c*d*z1 - a*c*w3 - a*c*w4 + 2*a*c*z1 + a*w5

   - a*z1 + d*w5 - d*z1 - w3 - w4 + 2*z1 <> 0 and a*b + b*d <> 0

                                               3         2           2  2
   and a*c + 1 <> 0 and a <> 0 and d <> 0 and a *c*z1 + a *b*c*w1 + a *c *w3

        2  2       2           2         2
   - 2*a *c *z1 + a *c*d*z1 - a *c*w2 + a *z1 + a*b*c*d*w1 - 2*a*b*c*w3

                                           2
   - 2*a*b*c*w4 + 4*a*b*c*z1 + a*b*w1 - a*c *d*w4 - a*c*d*w2 + 2*a*c*w3 + a*c*w4

   - 4*a*c*z1 + a*d*z1 - a*w2 + b*d*w1 - 2*b*w3 - 2*b*w4 + 4*b*z1 - c*d*w4

   - d*w2 + w3 + w4 - 2*z1 = 0,

    2         2
  {a *c*w5 - a *c*z1 + a*c*d*w5 - a*c*d*z1 - a*c*w3 - a*c*w4 + 2*a*c*z1 + a*w5

    - a*z1 + d*w5 - d*z1 - w3 - w4 + 2*z1}},

   2
 {a *z1 + a*b*w1 - 2*a*b*w5 + 2*a*b*z1 - a*w2 + w4 <> 0 and a*b*c <> 0

   and a*b <> 0 and a <> 0 and d <> 0 and a*c*d - a = 0 and a*c + 1 = 0

   and a*w3 - 2*a*z1 - d*w4 = 0,

    2
  {a *z1 + a*b*w1 - 2*a*b*w5 + 2*a*b*z1 - a*w2 + w4}},

   2
 {a *z1 + a*b*w1 + a*c*w3 - 2*a*c*z1 - a*w2 - 2*b*w3 - 2*b*w4 + 4*b*z1 + w3 + w4

   - 2*z1 <> 0 and a*b <> 0 and a <> 0 and d = 0,

    2
  {a *z1 + a*b*w1 + a*c*w3 - 2*a*c*z1 - a*w2 - 2*b*w3 - 2*b*w4 + 4*b*z1 + w3

    + w4 - 2*z1}},

   2
 {a *z1 + a*b*w1 - a*w2 - 2*b*w4 + w4 <> 0 and a*b <> 0 and a <> 0 and d <> 0

   and a*b*c = 0 and a*c*d - a = 0 and a*c + 1 = 0 and a*w3 - 2*a*z1 - d*w4 = 0,

    2
  {a *z1 + a*b*w1 - a*w2 - 2*b*w4 + w4}},

   2
 {a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1

   <> 0 and a*c + 1 <> 0 and a <> 0 and d <> 0 and a*b + b*d = 0,

    2
  {a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1}},

   2
 {a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1 <> 0 and a <> 0 and a*b = 0

   and d = 0,

    2
  {a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1}},

   2
 {a *z1 - a*w2 + w4 <> 0 and a <> 0 and d <> 0 and a*b = 0 and a*c + 1 = 0,

    2
  {a *z1 - a*w2 + w4}},

 {a*b*c <> 0 and a*b <> 0 and a <> 0 and d <> 0

        2
   and a *z1 + a*b*w1 - 2*a*b*w5 + 2*a*b*z1 - a*w2 + w4 = 0 and a*c*d - a = 0

   and a*c + 1 = 0 and a*w3 - 2*a*z1 - d*w4 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

                    2
   (2*a*b*c)*z3 + (a *z1 + a*b*w1 - a*w2 - 2*b*w4 + w4),

                2
   (a*b)*z2 + (a *z1 - a*w2 + w4)}},

                                                             3         2
 {a*b + b*d <> 0 and a*c + 1 <> 0 and a <> 0 and d <> 0 and a *c*z1 + a *b*c*w1

      2  2         2  2       2           2         2
   + a *c *w3 - 2*a *c *z1 + a *c*d*z1 - a *c*w2 + a *z1 + a*b*c*d*w1

                                                        2
   - 2*a*b*c*w3 - 2*a*b*c*w4 + 4*a*b*c*z1 + a*b*w1 - a*c *d*w4 - a*c*d*w2

   + 2*a*c*w3 + a*c*w4 - 4*a*c*z1 + a*d*z1 - a*w2 + b*d*w1 - 2*b*w3 - 2*b*w4

                                                      2         2
   + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0 and a *c*w5 - a *c*z1

   + a*c*d*w5 - a*c*d*z1 - a*c*w3 - a*c*w4 + 2*a*c*z1 + a*w5 - a*z1 + d*w5

   - d*z1 - w3 - w4 + 2*z1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

                               2
   (a*c + 1)*z3 + (a*b)*z2 + (a *z1 - a*w2 + w4),

                      2
   (a*b + b*d)*z2 + (a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2

       + w3 + w4 - 2*z1)}},

 {a*b <> 0 and a*c*d*w5 - a*c*d*z1 - a*c*w3 + 2*a*c*z1 - a*w5 + a*z1 + w4 <> 0

                                                 2           2
   and a*c*d - a <> 0 and a <> 0 and d <> 0 and a *c*d*z1 - a *z1 + a*b*c*d*w1

   - 2*a*b*c*w3 + 4*a*b*c*z1 - a*b*w1 - a*c*d*w2 + a*w2 + 2*b*w4 + c*d*w4 - w4

   = 0 and a*c + 1 = 0,

  {a*c*d*w5 - a*c*d*z1 - a*c*w3 + 2*a*c*z1 - a*w5 + a*z1 + w4}},

                                                         2           2
 {a*b <> 0 and a*c*d - a <> 0 and a <> 0 and d <> 0 and a *c*d*z1 - a *z1

   + a*b*c*d*w1 - 2*a*b*c*w3 + 4*a*b*c*z1 - a*b*w1 - a*c*d*w2 + a*w2 + 2*b*w4

   + c*d*w4 - w4 = 0

   and a*c*d*w5 - a*c*d*z1 - a*c*w3 + 2*a*c*z1 - a*w5 + a*z1 + w4 = 0

   and a*c + 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (a*c*d - a)*z3 + (a*w3 - 2*a*z1 - d*w4),

                2
   (a*b)*z2 + (a *z1 - a*w2 + w4)}},

 {a*b <> 0 and a*w3 - 2*a*z1 - d*w4 <> 0 and a <> 0 and d <> 0 and a*c*d - a = 0

   and a*c + 1 = 0,

  {a*w3 - 2*a*z1 - d*w4}},

                                                                 2
 {a*b <> 0 and a*w5 - a*z1 - w3 - w4 + 2*z1 <> 0 and a <> 0 and a *z1 + a*b*w1

   + a*c*w3 - 2*a*c*z1 - a*w2 - 2*b*w3 - 2*b*w4 + 4*b*z1 + w3 + w4 - 2*z1 = 0

   and d = 0,

  {a*w5 - a*z1 - w3 - w4 + 2*z1}},

                                      2
 {a*b <> 0 and a <> 0 and d <> 0 and a *z1 + a*b*w1 - a*w2 - 2*b*w4 + w4 = 0

   and a*b*c = 0 and a*c*d - a = 0 and a*c + 1 = 0 and a*w3 - 2*a*z1 - d*w4 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (a*c)*z3 + (a*w5 - a*z1 - w4),

                2
   (a*b)*z2 + (a *z1 - a*w2 + w4)}},

                           2
 {a*b <> 0 and a <> 0 and a *z1 + a*b*w1 + a*c*w3 - 2*a*c*z1 - a*w2 - 2*b*w3

   - 2*b*w4 + 4*b*z1 + w3 + w4 - 2*z1 = 0 and a*w5 - a*z1 - w3 - w4 + 2*z1 = 0

   and d = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   z3 - (w3 - 2*z1),

                2
   (a*b)*z2 + (a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1)}},

 {a*c*d*z1 - a*z1 + b*c*d*w1 - 2*b*c*d*w5 + 2*b*c*d*z1 - b*w1 + 2*b*w5 - 2*b*z1

      2  2       2  2       2           2
   - c *d *w5 + c *d *z1 + c *d*w3 - 2*c *d*z1 - c*d*w2 + 2*c*d*w5 - 2*c*d*z1

   - c*w3 + 2*c*z1 + w2 - w5 + z1 <> 0 and a <> 0 and 2*b + c*d - 1 <> 0

                                    2
   and c*d - 1 <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0,

  {a*c*d*z1 - a*z1 + b*c*d*w1 - 2*b*c*d*w5 + 2*b*c*d*z1 - b*w1 + 2*b*w5 - 2*b*z1

       2  2       2  2       2           2
    - c *d *w5 + c *d *z1 + c *d*w3 - 2*c *d*z1 - c*d*w2 + 2*c*d*w5 - 2*c*d*z1

    - c*w3 + 2*c*z1 + w2 - w5 + z1}},

 {a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2 <> 0 and a*c + 1 <> 0 and a <> 0

   and d <> 0 and 

   2
  a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*b + b*d = 0 and a*c - 2*b + 1 = 0,

  { - (a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2)}},

 {a*c*w5 - a*c*z1 + a*z1 - c*w4 - w2 + w5 - z1 <> 0 and a*c + 1 <> 0 and a <> 0

   and d <> 0 and 

   2
  a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*b + b*d = 0 and a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2 = 0

   and a*c - 2*b + 1 = 0 and b = 0,

  {a*c*w5 - a*c*z1 + a*z1 - c*w4 - w2 + w5 - z1}},

                                                                 2  2
 {a*c - 2*b + 1 <> 0 and a*c + 1 <> 0 and a <> 0 and d <> 0 and a *c *w5

      2  2       2                                                2
   - a *c *z1 + a *c*z1 + a*b*c*w1 - 2*a*b*c*w5 + 2*a*b*c*z1 - a*c *w4 - a*c*w2

   + 2*a*c*w5 - 2*a*c*z1 + a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1

   = 0 and 

   2
  a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*b + b*d = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

                               2
   (a*c + 1)*z3 + (a*b)*z2 + (a *z1 - a*w2 + w4),

   (a*c - 2*b + 1)*z2 - (a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2)}},

 {a*c + 1 <> 0 and a <> 0 and b <> 0 and d <> 0 and 

   2
  a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*b + b*d = 0 and a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2 = 0

   and a*c - 2*b + 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

                               2
   (a*c + 1)*z3 + (a*b)*z2 + (a *z1 - a*w2 + w4),

   b*z2 + (a*c*w5 - a*c*z1 + a*z1 - c*w4 - w2 + w5 - z1)}},

 {a*c + 1 <> 0 and a <> 0 and d <> 0 and 

   2
  a *z1 + a*c*w3 - 2*a*c*z1 + a*d*z1 - a*w2 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*b + b*d = 0 and a*c*w1 + 2*a*z1 - 2*c*w4 + w1 - 2*w2 = 0

   and a*c*w5 - a*c*z1 + a*z1 - c*w4 - w2 + w5 - z1 = 0 and a*c - 2*b + 1 = 0

   and b = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

                               2
   (a*c + 1)*z3 + (a*b)*z2 + (a *z1 - a*w2 + w4)}},

 {a*d*z1 + b*d*w1 - 2*b*d*w5 + 2*b*d*z1 - d*w2 + w3 - 2*z1 <> 0 and a <> 0

                                               2
   and b*c*d <> 0 and b*d <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and c*d - 1 = 0,

  {a*d*z1 + b*d*w1 - 2*b*d*w5 + 2*b*d*z1 - d*w2 + w3 - 2*z1}},

 {a*d*z1 + b*d*w1 - 2*b*w3 - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1

   <> 0 and b*d <> 0 and d <> 0 and a = 0,

  {a*d*z1 + b*d*w1 - 2*b*w3 - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1}}

 ,

 {a*d*z1 + b*d*w1 - 2*b*w3 + 4*b*z1 - d*w2 + w3 - 2*z1 <> 0 and a <> 0

                                2
   and b*d <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0 and a*c + 1 = 0

   and b*c*d = 0 and c*d - 1 = 0,

  {a*d*z1 + b*d*w1 - 2*b*w3 + 4*b*z1 - d*w2 + w3 - 2*z1}},

 {a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 <> 0 and d <> 0 and a = 0 and b*d = 0,

  {a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1}},

                                                            2
 {a*d*z1 - d*w2 + w3 - 2*z1 <> 0 and a <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0

   and a*b = 0 and a*c + 1 = 0 and b*d = 0 and c*d - 1 = 0,

  {a*d*z1 - d*w2 + w3 - 2*z1}},

 {2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 <> 0 and a <> 0 and c*d - 1 <> 0

                   2
   and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0 and a*c + 1 = 0

   and 2*b + c*d - 1 = 0,

  {2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2}},

 {2*a*z1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 <> 0 and a <> 0

        2
   and a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1 = 0 and a*b = 0

   and 2*b - 1 = 0 and d = 0,

  {2*a*z1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2}},

 {2*a*z1 - 2*c*w4 + w1 - 2*w2 <> 0 and d <> 0

   and a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0 and a = 0 and b*d = 0

   and 2*b - 1 = 0,

  {2*a*z1 - 2*c*w4 + w1 - 2*w2}},

 {2*a*z1 - 2*c*w4 + w1 - 2*w2 <> 0 and a = 0 and 2*b - 1 = 0 and d = 0

   and w3 + w4 - 2*z1 = 0,

  {2*a*z1 - 2*c*w4 + w1 - 2*w2}},

                                                     2
 {2*a*z1 + w1 - 2*w2 <> 0 and a <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0

   and a*b = 0 and a*c + 1 = 0 and a*d*z1 - d*w2 + w3 - 2*z1 = 0 and b*d = 0

   and 2*b - 1 = 0 and c*d - 1 = 0 and c = 0,

  {2*a*z1 + w1 - 2*w2}},

 {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1 <> 0 and a <> 0

                         2
   and 2*b - 1 <> 0 and a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1 = 0

   and a*b = 0 and d = 0,

  {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1}},

 {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1 <> 0 and 2*b - 1 <> 0

   and d <> 0 and a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0 and a = 0

   and b*d = 0,

  {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1}},

 {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1 <> 0 and 2*b - 1 <> 0

   and a = 0 and d = 0 and w3 + w4 - 2*z1 = 0,

  {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1}},

 {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - w2 + w5 - z1 <> 0 and a <> 0 and 2*b - 1 <> 0

                   2
   and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0 and a*c + 1 = 0

   and a*d*z1 - d*w2 + w3 - 2*z1 = 0 and b*d = 0 and c*d - 1 = 0 and c = 0,

  {a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - w2 + w5 - z1}},

 {a*z1 - c*d*w5 + c*d*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1 <> 0 and a <> 0

                                    2
   and c*d - 1 <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and 2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 = 0

   and 2*b + c*d - 1 = 0 and b = 0,

  {a*z1 - c*d*w5 + c*d*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1}},

                                                     2
 {a <> 0 and b*c*d <> 0 and b*d <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0

   and a*b = 0 and a*c + 1 = 0

   and a*d*z1 + b*d*w1 - 2*b*d*w5 + 2*b*d*z1 - d*w2 + w3 - 2*z1 = 0

   and c*d - 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (2*b*c*d)*z3 + (a*d*z1 + b*d*w1 - 2*b*w3 + 4*b*z1 - d*w2 + w3 - 2*z1),

   (b*d)*z2 + (a*d*z1 - d*w2 + w3 - 2*z1)}},

                                      2
 {a <> 0 and b*d <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and a*d*z1 + b*d*w1 - 2*b*w3 + 4*b*z1 - d*w2 + w3 - 2*z1 = 0

   and b*c*d = 0 and c*d - 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (c*d)*z3 + (d*w5 - d*z1 - w3 + 2*z1),

   (b*d)*z2 + (a*d*z1 - d*w2 + w3 - 2*z1)}},

 {a <> 0 and 2*b + c*d - 1 <> 0 and c*d - 1 <> 0 and d <> 0

        2
   and a *z1 - a*w2 + w4 = 0 and a*b = 0 and a*c*d*z1 - a*z1 + b*c*d*w1

                                                         2  2       2  2
   - 2*b*c*d*w5 + 2*b*c*d*z1 - b*w1 + 2*b*w5 - 2*b*z1 - c *d *w5 + c *d *z1

      2           2
   + c *d*w3 - 2*c *d*z1 - c*d*w2 + 2*c*d*w5 - 2*c*d*z1 - c*w3 + 2*c*z1 + w2

   - w5 + z1 = 0 and a*c + 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (c*d - 1)*z3 + (b*d)*z2 + (a*d*z1 - d*w2 + w3 - 2*z1),

   (2*b + c*d - 1)*z2 + (2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2)}},

                                          2
 {a <> 0 and 2*b - 1 <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and a*d*z1 - d*w2 + w3 - 2*z1 = 0

   and a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - w2 + w5 - z1 = 0 and b*d = 0

   and c*d - 1 = 0 and c = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (2*b - 1)*z2 + (2*a*z1 + w1 - 2*w2)}},

 {a <> 0 and 2*b - 1 <> 0

        2
   and a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1 = 0 and a*b = 0

   and a*z1 + b*w1 - 2*b*w5 + 2*b*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1 = 0

   and d = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   z3 - (w3 - 2*z1),

   (2*b - 1)*z2 + (2*a*z1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2)}},

                                                     2
 {a <> 0 and b <> 0 and c*d - 1 <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0

   and a*b = 0 and a*c + 1 = 0

   and 2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 = 0 and 2*b + c*d - 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (c*d - 1)*z3 + (b*d)*z2 + (a*d*z1 - d*w2 + w3 - 2*z1),

   b*z2 + (a*z1 - c*d*w5 + c*d*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1)}},

                                          2
 {a <> 0 and c*d - 1 <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and 2*a*z1 - c*d*w1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 = 0

   and a*z1 - c*d*w5 + c*d*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1 = 0

   and 2*b + c*d - 1 = 0 and b = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (c*d - 1)*z3 + (b*d)*z2 + (a*d*z1 - d*w2 + w3 - 2*z1)}},

                                    2
 {a <> 0 and c <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0

   and a*c + 1 = 0 and a*d*z1 - d*w2 + w3 - 2*z1 = 0 and b*d = 0 and c*d - 1 = 0

  ,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   (2*c)*z3 + (2*b - 1)*z2 + (2*a*z1 + w1 - 2*w2),

   z2 - (w1 - 2*w5 + 2*z1)}},

                         2
 {a <> 0 and d <> 0 and a *z1 - a*w2 + w4 = 0 and a*b = 0 and a*c + 1 = 0

   and a*d*z1 - d*w2 + w3 - 2*z1 = 0 and 2*a*z1 + w1 - 2*w2 = 0 and b*d = 0

   and 2*b - 1 = 0 and c*d - 1 = 0 and c = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   b*z2 + (a*z1 - w2 + w5 - z1)}},

              2
 {a <> 0 and a *z1 + a*c*w3 - 2*a*c*z1 - a*w2 + w3 + w4 - 2*z1 = 0 and a*b = 0

   and 2*a*z1 + 2*c*w3 - 4*c*z1 + w1 - 2*w2 = 0 and 2*b - 1 = 0 and d = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   a*z4 - z3 - w4,

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

   z3 - (w3 - 2*z1),

   b*z2 + (a*z1 + c*w3 - 2*c*z1 - w2 + w5 - z1)}},

 {b*d <> 0 and d*w5 - d*z1 - w3 - w4 + 2*z1 <> 0 and d <> 0 and 

  a*d*z1 + b*d*w1 - 2*b*w3 - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1

   = 0 and a = 0,

  {d*w5 - d*z1 - w3 - w4 + 2*z1}},

 {b*d <> 0 and d <> 0 and 

  a*d*z1 + b*d*w1 - 2*b*w3 - 2*b*w4 + 4*b*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1

   = 0 and a = 0 and d*w5 - d*z1 - w3 - w4 + 2*z1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

    - z3 - w4,

   (b*d)*z2 + (a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1)}},

 {2*b - 1 <> 0 and d <> 0 and a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1 = 0 and a = 0

   and b*d = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

    - z3 - w4,

   (2*b - 1)*z2 + (2*a*z1 - 2*c*w4 + w1 - 2*w2)}},

 {2*b - 1 <> 0 and a*z1 + b*w1 - 2*b*w5 + 2*b*z1 - c*w4 - w2 + w5 - z1 = 0

   and a = 0 and d = 0 and w3 + w4 - 2*z1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

    - z3 - w4,

   z3 - (w3 - 2*z1),

   (2*b - 1)*z2 + (2*a*z1 - 2*c*w4 + w1 - 2*w2)}},

 {d <> 0 and a*d*z1 - c*d*w4 - d*w2 + w3 + w4 - 2*z1 = 0

   and 2*a*z1 - 2*c*w4 + w1 - 2*w2 = 0 and a = 0 and b*d = 0 and 2*b - 1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   d*z4 + z3 - (w3 - 2*z1),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

    - z3 - w4,

   b*z2 + (a*z1 - c*w4 - w2 + w5 - z1)}},

 {w3 + w4 - 2*z1 <> 0 and a = 0 and d = 0,

  {w3 + w4 - 2*z1}},

 {2*a*z1 - 2*c*w4 + w1 - 2*w2 = 0 and a = 0 and 2*b - 1 = 0 and d = 0

   and w3 + w4 - 2*z1 = 0,

  {z4 + c*z3 + b*z2 + (a*z1 - w2),

   2*z4 + z2 - w1,

   z4 - (w5 - z1),

    - z3 - w4,

   z3 - (w3 - 2*z1),

   b*z2 + (a*z1 - c*w4 - w2 + w5 - z1)}}}

torder oo;


{{z4,z3,z2,z2},revgradlex}


% Two dimensional transportation problem
oo := torder({x33,x32,x31,x23,x22,x21,x13,x12,x11},lex);


oo := {{},lex}

gsys({x11+x12+x13-a1,x11+x21+x31-b1,x12+x22+x32-b2,x13+x23+x33-b3,
x21+x22+x23-a2,x31+x32+x33-a3});


{{a1 + a2 + a3 - b1 - b2 - b3 <> 0,

  {a1 + a2 + a3 - b1 - b2 - b3}},

 {a1 + a2 + a3 - b1 - b2 - b3 = 0,

  {x33 + x32 + x31 - a3,

   x33 + x23 + x13 - b3,

   x32 + x22 + x12 - b2,

   x31 + x21 + x11 - b1,

   x23 + x22 + x21 - a2,

   x13 + x12 + x11 - a1}}}

torder oo;


{{x33,x32,x31,x23,x22,x21,x13,x12,x11},lex}


% Thomas Weis's Example 1
oo := torder({x,y,z},lex);


oo := {{},lex}

gsys({z*y*x-b*y*x-b*z*x+b**2*x-b*z*y+b**2*y+b**2*z-(n3+b**3),
z*y*x-a*y*x-a*z*x+a**2*x-a*z*y+a**2*y+a**2*z-(n3+a**3),
z*y*x-n1});


   3        3
{{a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3 <> 0 and a - b <> 0

        2        2
   and a *b - a*b  = 0,

        3        3
  { - (a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3)}},

   3
 {a  - n1 + n3 <> 0 and a - b = 0 and a = 0,

    3
  {a  - n1 + n3}},

   2        2
 {a *b - a*b  <> 0 and a - b <> 0,

                            2              2      2       3
  {x*y*z - a*x*y - a*x*z + a *x - a*y*z + a *y + a *z - (a  + n3),

                            2              2      2       3
   x*y*z - b*x*y - b*x*z + b *x - b*y*z + b *y + b *z - (b  + n3),

   x*y*z - n1,

                                 2    2                      2    2
   (a - b)*x*y + (a - b)*x*z - (a  - b )*x + (a - b)*y*z - (a  - b )*y

        2    2        3    3
    - (a  - b )*z + (a  - b ),

     2        2        2        2        2        2
   (a *b - a*b )*x + (a *b - a*b )*y + (a *b - a*b )*z

        3        3
    - (a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3),

     2        2   2     2        2
   (a *b - a*b )*y  + (a *b - a*b )*y*z

        3        3                                    2        2   2
    - (a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3)*y + (a *b - a*b )*z

        3        3
    - (a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3)*z

        3  2    2  3    2       2       2       2
    + (a *b  - a *b  + a *n1 - a *n3 - b *n1 + b *n3),

     2        2   3     3        3                               2
   (a *b - a*b )*z  - (a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3)*z

        3  2    2  3    2       2       2       2           2           2
    + (a *b  - a *b  + a *n1 - a *n3 - b *n1 + b *n3)*z - (a *b*n1 - a*b *n1)}},

                  3        3                                      2        2
 {a - b <> 0 and a *b - a*b  + a*n1 - a*n3 - b*n1 + b*n3 = 0 and a *b - a*b  = 0

  ,

                            2              2      2       3
  {x*y*z - a*x*y - a*x*z + a *x - a*y*z + a *y + a *z - (a  + n3),

                            2              2      2       3
   x*y*z - b*x*y - b*x*z + b *x - b*y*z + b *y + b *z - (b  + n3),

   x*y*z - n1,

                                 2    2                      2    2
   (a - b)*x*y + (a - b)*x*z - (a  - b )*x + (a - b)*y*z - (a  - b )*y

        2    2        3    3
    - (a  - b )*z + (a  - b ),

              2     2    2                   2     2    2          2    2   2
   (a - b)*x*z  - (a  - b )*x*z + (a - b)*y*z  - (a  - b )*y*z - (a  - b )*z

        3    2        2    3        3        3
    + (a  + a *b - a*b  - b )*z - (a *b - a*b  - a*n3 + b*n3),

            2  2     2    2   2       2    2     2     3    2        2    3
   (a - b)*y *z  - (a  - b )*y *z - (a  - b )*y*z  + (a  + a *b - a*b  - b )*y*z

        2  2      3                      3        3
    - (a *b  - a*b  - a*n3 + b*n3)*y - (a *b - a*b  - a*n3 + b*n3)*z

        3  2    2  3    2       2
    + (a *b  - a *b  - a *n3 + b *n3)}},

 {a <> 0 and a - b = 0,

                            2              2      2       3
  {x*y*z - a*x*y - a*x*z + a *x - a*y*z + a *y + a *z - (a  + n3),

                            2              2      2       3
   x*y*z - b*x*y - b*x*z + b *x - b*y*z + b *y + b *z - (b  + n3),

   x*y*z - n1,

                    2              2      2       3
   a*x*y + a*x*z - a *x + a*y*z - a *y - a *z + (a  - n1 + n3),

        2    2            2    2        2  2     3
   a*x*z  - a *x*z + a*y*z  - a *y*z - a *z  + (a  - n1 + n3)*z + a*n1,

      2  2    2  2      2    2     3
   a*y *z  - a *y *z - a *y*z  + (a  - n1 + n3)*y*z + (a*n1)*y + (a*n1)*z

       2
    - a *n1}},

   3
 {a  - n1 + n3 = 0 and a - b = 0 and a = 0,

                            2              2      2       3
  {x*y*z - a*x*y - a*x*z + a *x - a*y*z + a *y + a *z - (a  + n3),

                            2              2      2       3
   x*y*z - b*x*y - b*x*z + b *x - b*y*z + b *y + b *z - (b  + n3),

   x*y*z - n1}}}

torder oo;


{{x,y,z},lex}


% Thomas Weis's Example 2
oo := torder({z,y,x,w},lex);


oo := {{},lex}

gsys({w*x*y*z-x*y*z-w*y*z+y*z-w*x*z+x*z+w*z-z-w*x*y+x*y+w*y-
y+w*x-x-w-(b-1),
w*x*y*z-2*x*y*z-2*w*y*z+4*y*z-2*w*x*z+4*x*z+4*w*z-8*z-2*w*x*y+4x*y+
4*w*y-8*y+4*w*x-8*x-8*w-(c-16),
w*x*y*z-a,z+y+x+w-v});


{{true,

  {z*y*x*w - z*y*x - z*y*w + z*y - z*x*w + z*x + z*w - z - y*x*w + y*x + y*w - y

    + x*w - x - w - (b - 1),

   z*y*x*w - 2*z*y*x - 2*z*y*w + 4*z*y - 2*z*x*w + 4*z*x + 4*z*w - 8*z - 2*y*x*w

    + 4*y*x + 4*y*w - 8*y + 4*x*w - 8*x - 8*w - (c - 16),

   z*y*x*w - a,

   z + y + x + w - v,

    2      2        2      2                              2
   y *x + y *w - 3*y  + y*x  + 2*y*x*w - (v + 3)*y*x + y*w  - (v + 3)*y*w

                 2        2      2                              2
    + (3*v)*y + x *w - 3*x  + x*w  - (v + 3)*x*w + (3*v)*x - 3*w  + (3*v)*w

    + (b - c - 7*v + 15),

      2                                2                        2
   2*y  + 2*y*x + 2*y*w - (2*v)*y + 2*x  + 2*x*w - (2*v)*x + 2*w  - (2*v)*w

    + (a - 2*b + c + 6*v - 14),

      3      2            2        2
   2*x  + 2*x *w - (2*v)*x  + 2*x*w  - (2*v)*x*w + (a - 2*b + c + 6*v - 14)*x

         3          2
    + 2*w  - (2*v)*w  + (a - 2*b + c + 6*v - 14)*w - (3*a - 4*b + c + 4*v - 12),

      4          3                             2
   2*w  - (2*v)*w  + (a - 2*b + c + 6*v - 14)*w  - (3*a - 4*b + c + 4*v - 12)*w

    + 2*a}}}

torder oo;


{{z,y,x,w},lex}


end;


Time for test: 109 ms, plus GC time: 32 ms
@@@@@ Resources used: (0 1 60 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/smartev.red0000644000175000017500000002045411526203062023421 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: smartev.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(smartev_rcsid!* smartev_copyright!*);
   smartev_rcsid!* := "$Id: smartev.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   smartev_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module smartev;
% Implementation of exponent vectors additionally tagged with the total
% degree in a lazy manner.

fluid '(dip_vars!* dip_sortevcomp!* dip_sortmode!* gb_tr2count!* !*trgroebr
   !*groebstat dip_evlist!*);

load!-package 'dp;

smacro procedure sm_lmake(e);
   {e,nil,nil};

smacro procedure sm_make(e,td,bs);
   {e,td,bs};

smacro procedure sm_e(se);
   car se;

smacro procedure sm_td(se);
   cadr se;

smacro procedure sm_std(se);
   cadr se or (cadr se := ev_tdeg1 car se);

smacro procedure sm_settd(se,td);
   cadr se := td;

smacro procedure sm_bs(se);
   caddr se;

procedure ev_init();
   ;

procedure ev_sdivp(ev1,ev2);
   sm_e ev1 neq sm_e ev2 and ev_divides!?(ev1,ev2);

procedure ev_divides!?(ev1,ev2);
   ev_mtest!?(ev2,ev1);

procedure ev_revgradlexcomp(e1,e2);
   % Exponent vector reverse graduated lex compare. The exponent
   % vectors e1 and e2 are in reverse graduated lex ordering.
   % evRevGradLexcomp(e1,e2) returns the digit 0 if exponent vector e1
   % is equal exponent vector e2, the digit 1 if e1 is greater than
   % e2, else the digit -1.
   begin scalar td1,td2;
      td1 := sm_td e1;
      td2 := sm_td e2;
      if td1 and td2 then <<
         if td1 #> td2 then
            return 1;
         if td1 #< td2 then
            return -1
      >>;
      return ev_revgradlexcomp1(sm_e e1,sm_e e2,e1,e2)
   end;

procedure ev_revgradlexcomp1(e1,e2,se1,se2);
   begin scalar te1,te2;
      if null e1 then
               return 0;
      if car e1 #= car e2 then
         return ev_revgradlexcomp1(cdr e1, cdr e2,se1,se2);
      te1 := sm_std se1;
      te2 := sm_std se2;
      if te1 #= te2 then
          return ev_invlexcomp(e1,e2);
      if te1 #> te2 then
          return 1;
      return -1
   end;

procedure ev_invlexcomp(e1,e2);
   % Exponent vector inverse lexicographical compare. No term order!
   begin scalar n;
      if null e1 then
         return 0;
      if car e1 #= car e2 then
          return ev_invlexcomp(cdr e1,cdr e2);  % sic!
      n := ev_invlexcomp(cdr e1,cdr e2);
      if not (n #= 0) then
          return n;
      if car e2 #= car e1 then
          return 0;
      if car e2 #> car e1 then
          return 1;
      return -1
   end;

procedure ev_mtest!?(e1,e2);
   if sm_td e1 and sm_td e2 and sm_td e1 #< sm_td e2 then <<
%      ioto_prin2 "*";
      nil
   >> else <<
%      ioto_prin2 ".";
      ev_mtest!?1(sm_e e1,sm_e e2)
   >>;

procedure ev_mtest!?1(e1,e2);
   % Exponent vector multiple test. e1 and e2 are compatible exponent
   % vectors. vevmtest?(e1,e2) returns a boolean expression. True if
   % exponent vector e1 is a multiple of exponent vector e2, else
   % false.
   begin scalar r;
      r := t;
      while e1 and r do <<
         if car e1 #< car e2 then
            e1 := r := nil
         else <<
            e1 := cdr e1;
            e2 := cdr e2
         >>
      >>;
      return r
   end;

procedure ev_2a(e);
   % Returns list of prefix equivalents of exponent vector e.
   ev_2a1(sm_e e,dip_vars!*);

procedure ev_2a1(u,v);
   if null u then
      nil
   else if car u #= 0 then
      ev_2a1(cdr u,cdr v)
   else if car u #= 1 then
      car v . ev_2a1(cdr u,cdr v)
   else
      {'expt,car v,car u} . ev_2a1(cdr u,cdr v);

procedure ev_2f(ev,vars);
   ev_2f1(sm_e ev,vars);

procedure ev_2f1(ev,vars);
   if null ev then
      1
   else if car ev #= 0 then
      ev_2f1(cdr ev,cdr vars)
   else
      multf(car vars .** car ev .* 1 .+ nil,ev_2f1(cdr ev,cdr vars));

procedure ev_lcm(e1,e2);
   sm_lmake ev_lcm1(sm_e e1,sm_e e2);

procedure ev_lcm1(e1,e2);
   % Exponent vector least common multiple. e1 and e2 are exponent
   % vectors. ev_lcm(e1,e2) computes the least common multiple of the
   % exponent vectors e1 and e2, and returns an exponent vector.
   begin scalar x;
      while e1 do <<
         x := (if car e1 #> car e2 then car e1 else car e2) . x;
         e1 := cdr e1;
          e2 := cdr e2
      >>;
      return reversip x
   end;

procedure ev_zero();
   sm_make(for each x in dip_vars!* collect 0,0,nil);

procedure ev_zero!?(ev);
   sm_td ev #= 0 or ev_zero!?1 sm_e ev;

procedure ev_zero!?1(ev);
   null ev or eqcar(ev,0) and ev_zero!?1 cdr ev;

procedure ev_compless!?(e1,e2);
   ev_comp(e2,e1) #= 1;

procedure ev_comp(e1,e2);
   % Exponent vector compare. e1, e2 are exponent vectors in some
   % order. Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is
   % equal exponent vector e2, the digit 1 if e1 is greater than e2,
   % else the digit -1. This function is assigned a value by the
   % ordering mechanism, so is dummy for now. IDapply would be better
   % here, but is not within standard LISP!
   apply(dip_sortevcomp!*,{e1,e2});

procedure ev_insert(ev,v,dg,vars);
   sm_lmake ev_insert1(sm_e ev,v,dg,vars);

procedure ev_insert1(ev,v,dg,vars);
   % f to dip conversion: Insert the "dg" into the ev in the place of
   % variable v.
   if null ev or null vars then
      nil
   else if car vars eq v then
      dg . cdr ev
   else
      car ev . ev_insert1(cdr ev,v,dg,cdr vars);

procedure ev_tdeg(u);
   sm_std u;

procedure ev_tdeg1(u);
   % calculate the total degree of u.
   begin integer x;
      while u do <<
         x := car u #+ x;
          u := cdr u
      >>;
      return x
   end;

procedure ev_dif(e1,e2);
   if sm_td e1 and sm_td e2 then
      sm_make(ev_dif1(sm_e e1,sm_e e2),sm_td e1 #- sm_td e2,nil)
   else
      sm_lmake ev_dif1(sm_e e1,sm_e e2);

procedure ev_dif1(e1,e2);
   begin scalar s;
      while e1 do <<
         s := (car e1 #- car e2) . s;
         e1 := cdr e1;
         e2 := cdr e2
      >>;
      return reversip s
   end;

procedure ev_sum(e1,e2);
   if sm_td e1 and sm_td e2 then
      sm_make(ev_sum1(sm_e e1,sm_e e2),sm_td e1 #+ sm_td e2,nil)
   else
      sm_lmake ev_sum1(sm_e e1,sm_e e2);

procedure ev_sum1(e1,e2);
   begin scalar s;
      while e1 do <<
         s := (car e1 #+ car e2) . s;
         e1 := cdr e1;
         e2 := cdr e2
      >>;
      return reversip s
   end;

procedure ev_disjointp(e1,e2);
   ev_disjointp1(sm_e e1,sm_e e2);

procedure ev_disjointp1(e1,e2);
   % nonconstructive test of lcm(e1,e2) = e1 + e2 equivalent: no
   % matches of nonzero elements.
   if null e1 then
      t
   else if (car e1 neq 0) and (car e2 neq 0) then
      nil
   else
      ev_disjointp1(cdr e1,cdr e2);

procedure ev_member(a,l);
   assoc(car a,l);

procedure ev_sdivp(ev1,ev2);
   sm_e ev1 neq sm_e ev2 and ev_divides!?(ev1,ev2);

procedure ev_identify(oev,nev);
   <<
      if not sm_td nev and sm_td oev then
               sm_settd(nev,sm_td oev);
      nev
   >>;

endmodule;  % smartev

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/cgb.tex0000644000175000017500000002205611526203062022521 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: cgb.tex 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

\documentstyle{article}
\overfullrule2mm
\newcommand{\C}{{\bf C}}
\newcommand{\R}{{\bf R}}
\newcommand{\Id}{{\rm Id}}
\begin{document}
\title{CGB: Computing Comprehensive Gr\"obner Bases}
\author{Andreas Dolzmann \& Thomas Sturm\\
Department of Mathematics and Computer Science\\ University of Passau\\
D-94030 Passau, Germany\\[1ex]
e-mail: {\tt dolzmann@uni-passau.de}, {\tt sturm@uni-passau.de}\\[1ex]
and\\[1ex]
Winfried Neun\\
Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin\\
Takustra\ss{}e 7\\
D-14195 Berlin-Dahlem, Germany\\[1ex]
e-mail: {\tt neun@zib.de}}
\date{15 April 1999}
\maketitle

\section{Introduction}
Consider the ideal basis $F=\{ax,x+y\}$. Treating $a$ as a parameter,
the calling sequence
\begin{verbatim}
torder({x,y},lex)$
groebner{a*x,x+y};

  {x,y}
\end{verbatim}
yields $\{x,y\}$ as reduced Gr\"obner basis. This is, however, not
correct under the specialization $a=0$. The reduced Gr\"obner basis
would then be $\{x+y\}$. Taking these results together, we obtain
$C=\{x+y,ax,ay\}$, which is correct wrt.~{\em all} specializations for
$a$ including zero specializations. We call this set $C$ a {\em
comprehensive Gr\"obner basis} ({\sc cgb}).

The notion of a {\sc cgb} and a corresponding algorithm has been
introduced bei Weispfenning \cite{Weispfenning:92}. This algorithm
works by performing case distinctions wrt.~parametric coefficient
polynomials in order to find out what the head monomials are under all
possible specializations. It does thus not only determine a {\sc cgb},
but even classifies the contained polynomials wrt.~the specializations
they are relevant for. If we keep the Gr\"obner bases for all cases
separate and associate information on the respective specializations
with them, we obtain a {\em Gr\"obner system}. For our example, the
Gr\"obner system is the following;
$$
\left[
\begin{array}{c|c}
a\neq0 & \{x+y,ax,ay\}\\
a=0 & \{x+y\}
\end{array}
\right].
$$
A {\sc cgb} is obtained as the union of the single Gr\"obner bases in
a Gr\"obner system. It has also been shown that, on the other hand, a
Gr\"obner system can easily be reconstructed from a given {\sc cgb}
\cite{Weispfenning:92}.

The CGB package provides functions for computing both {\sc cgb}'s and
Gr\"obner systems, and for turning Gr\"obner systems into {\sc cgb}'s.
%
\section{Using the REDLOG Package}
For managing the conditions occurring with the {\sc cgb} computations,
the CGB package uses the package REDLOG implementing first-order
formulas, \cite{DolzmannSturm:97a,DolzmannSturm:99}, which is also
part of the \textsc{reduce} distribution.
%
\section{Term Ordering Mode}
The CGB package uses the settings made with the function {\tt torder}
of the GROEBNER package. This includes in particular the choice of the
main variables. All variables not mentioned in the variable list
argument of {\tt torder} are parameters. The only term ordering modes
recognized by \textsc{cgb} are {\tt lex} and {\tt revgradlex}.
%
\section{CGB: Comprehensive Gr\"ob\-ner Basis}
The function {\tt cgb} expects a list $F$ of expressions. It returns a
{\sc cgb} of $F$ wrt.~the current {\tt torder} setting.
%
\subsection*{Example}
\begin{verbatim}
torder({x,y},lex)$
cgb{a*x+y,x+b*y};

{x + b*y,a*x + y,(a*b - 1)*y}

ws;

{b*y + x,

 a*x + y,

 y*(a*b - 1)}
\end{verbatim}
Note that the basis returned by the {\tt cgb} call has not undergone
the standard evaluation process: The returned polynomials are ordered
wrt.~the chosen term order. Reevaluation changes this as can be seen
with the output of {\tt ws}.
%
\section{GSYS: Gr\"obner System}
The function {\tt gsys} follows the same calling conventions as {\tt
cgb}. It returns the complete Gr\"obner system represented as a nested
list
\begin{center}
\begin{tt}
$\bigl\{\bigl\{c_1,\{g_{11},\ldots,g_{1n_1}\}\bigr\},\dots,
\bigl\{c_m,\{g_{m1},\dots,g_{1n_m}\}\bigr\}\bigr\}$.
\end{tt}
\end{center}
The {\tt $c_i$} are conditions in the parameters represented as
quantifier-free REDLOG formulas. Each choice of parameters will obey
at least one of the {\tt $c_i$}. Whenever a choice of parameters obeys
some {\tt $c_i$}, the corresponding {\tt $\{g_{i1},\ldots,g_{in_i}\}$}
is a Gr\"obner basis for this choice.
%
\subsection*{Example}
\begin{verbatim}
torder({x,y},lex)$
gsys {a*x+y,x+b*y};

{{a*b - 1 <> 0 and a <> 0,

  {a*x + y,x + b*y,(a*b - 1)*y}},

 {a <> 0 and a*b - 1 = 0,

  {a*x + y,x + b*y}},

 {a = 0,{a*x + y,x + b*y}}}
\end{verbatim}
As with the function {\tt cgb}, the contained polynomials remain
unevaluated.

Computing a Gr\"obner system is not harder than computing a {\sc cgb}.
In fact, {\tt cgb} also computes a Gr\"obner system and then turns it
into a {\sc cgb}.

\subsection{Switch CGBGEN: Only the Generic Case}
If the switch {\tt cgbgen} is turned on, both {\tt gsys} and {\tt
cgb} will assume all parametric coefficients to be non-zero ignoring
the other cases. For {\tt cgb} this means that the result equals---up
to auto-reduction---that of {\tt groebner}. A call to {\tt gsys} will
return this result as a single case including the assumptions made
during the computation:
%
\subsection*{Example}
\begin{verbatim}
torder({x,y},lex)$
on cgbgen;
gsys{a*x+y,x+b*y};

{{a*b - 1 <> 0 and a <> 0,

  {a*x + y,x + b*y,(a*b - 1)*y}}}

off cgbgen;
\end{verbatim}
%
\section{GSYS2CGB: Gr\"obner System to CGB}
The call {\tt gsys2cgb} turns a given Gr\"obner system into a {\sc
cgb} by constructing the union of the Gr\"obner bases of the single
cases.
%
\subsection*{Example}
\begin{verbatim}
torder({x,y},lex)$
gsys{a*x+y,x+b*y}$
gsys2cgb ws;

{x + b*y,a*x + y,(a*b - 1)*y}
\end{verbatim}
%
\section{Switch CGBREAL: Computing over the Real Numbers}\label{cgbreal}
All computations considered so far have taken place over the complex
numbers, more precisely, over algebraically closed fields. Over the
real numbers, certain branches of the {\sc cgb} computation can become
inconsitent though they are not inconsistent over the complex numbers.
Consider, e.g., a condition $a^2+1=0$.

When turning on the switch {\tt cgbreal}, all simplifications of conditions
are performed over the real numbers. The methods used for this are
described in \cite{DolzmannSturm:97c}.
%
\subsection*{Example}
\begin{verbatim}
torder({x,y},lex)$
off cgbreal;
gsys {a*x+y,x-a*y};

   2
{{a  + 1 <> 0 and a <> 0,

                     2
  {a*x + y,x - a*y,(a  + 1)*y}},

              2
 {a <> 0 and a  + 1 = 0,{a*x + y,x - a*y}},

 {a = 0,{a*x + y,x - a*y}}}

on cgbreal;
gsys({a*x+y,x-a*y});

{{a <> 0,

                     2
  {a*x + y,x - a*y,(a  + 1)*y}},

 {a = 0,{a*x + y,x - a*y}}}
\end{verbatim}

\section{Switches}
\begin{description}
\item[cgbreal] Compute over the real numbers. See
Section~\ref{cgbreal} for details.

\item[cgbgs] Gr\"obner simplification of the condition. The switch
{\tt cgbgs} can be turned on for applying advanced algebraic
simplification techniques to the conditions. This will, in general,
slow down the computation, but lead to a simpler Gr\"obner system.

\item[cgbstat] Statistics of the CGB run. The switch {\tt cgbstat}
toggles the creation and output of statistical information on the CGB
run. The statistical information is printed at the end of the run.

\item[cgbfullred] Full reduction. By default, the CGB functions
perform full reductions in contrast to pure top reductions. By turning
off the switch {\tt cgbfullred}, reduction can be restricted to top
reductions.
\end{description}

\section{Updates}
Information on and updates of the CGB package will be provided on

\centerline{{\tt http://www.fmi.uni-passau.de/\char126 reduce/}.}

\bibliographystyle{alpha}
\bibliography{cgb}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/vecev.red0000644000175000017500000001574311526203062023055 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: vecev.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(vecev_rcsid!* vecev_copyright!*);
   vecev_rcsid!* := "$Id: vecev.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   vecev_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module ev;
% Implementation of exponent vectors based on standard lisp vectors.

fluid '(dip_vars!* dip_sortevcomp!* ev_ub!* kord!* dip_sortmode!*);

procedure ev_init();
   ev_ub!* := length dip_vars!* - 1;

procedure ev_divides!?(ev1,ev2);
   ev_mtest!?(ev2,ev1);

procedure ev_sdivp(ev1,ev2);
   ev1 neq ev2 and ev_divides!?(ev1,ev2);

procedure ev_revgradlexcomp(e1,e2);
   % Exponent vector reverse graduated lex compare. The exponent
   % vectors e1 and e2 are in reverse graduated lex ordering.
   % evRevGradLexcomp(e1,e2) returns the digit 0 if exponent vector e1
   % is equal exponent vector e2, the digit 1 if e1 is greater than
   % e2, else the digit -1.
   begin scalar r; integer i,j,tdeg1,tdeg2;
      r := t;
      i := ev_ub!*;
      while r and not(i #< 0) do
         if not(getv(e1,i) #= getv(e2,i)) then
            r := nil
         else
            i := i #- 1;
      if r then
	 return 0;
      while not(j #> i) do <<
	 tdeg1 := tdeg1 #+ getv(e1,j);
	 tdeg2 := tdeg2 #+ getv(e2,j);
         j := j #+ 1
      >>;
      if tdeg1 #> tdeg2 then
	 return 1;
      if tdeg1 #< tdeg2 then
	 return -1;
      if getv(e1,i) #> getv(e2,i) then
         return -1;
      return 1
   end;

procedure ev_mtest!?(e1,e2);
   % Exponent vector multiple test. e1 and e2 are compatible exponent
   % vectors. vevmtest?(e1,e2) returns a boolean expression. True if
   % exponent vector e1 is a multiple of exponent vector e2, else
   % false.
   begin scalar r; integer i;
      r := t;
      while r and not(i #> ev_ub!*) do
         if getv(e1,i) #< getv(e2,i) then
            r := nil
         else
            i := i #+ 1;
      return r
   end;

procedure ev_2a(e);
   begin scalar r,w,sv; integer i;
      sv := dip_vars!*;
      while not(i #> ev_ub!*) do <<
         w := getv(e,i);
         if w #= 1 then
            r := car sv . r
         else if w #> 1 then
            r := {'expt,car sv,w} . r;
         sv := cdr sv;
         i := i #+ 1
      >>;
      return reversip r
   end;

procedure ev_2f(ev,vars);
   begin scalar r,w,sv; integer i;
      sv := dip_vars!*;
      while not(i #> ev_ub!*) do <<
         w := getv(ev,i);
         if not(w #= 0) then
            multf(r,car sv .** w .* 1 .+ nil);
         sv := cdr sv;
         i := i #+ 1
      >>;
      return r
   end;

procedure ev_lcm(e1,e2);
   % Exponent vector least common multiple. e1 and e2 are exponent
   % vectors. ev_lcm(e1,e2) computes the least common multiple of the
   % exponent vectors e1 and e2, and returns an exponent vector.
   begin scalar s; integer i;
      s := mkvect ev_ub!*;
      while not(i #> ev_ub!*) do <<
         putv(s,i,max!#(getv(e1,i),getv(e2,i)));
         i := i #+ 1
      >>;
      return s
   end;

procedure min!#(a,b);
   if a #< b then a else b;

procedure ev_zero();
   begin scalar v; integer i;
      v := mkvect ev_ub!*;
      while not(i #> ev_ub!*) do <<
         putv(v,i,0);
         i := i #+ 1
      >>;
      return v
   end;

procedure ev_zero!?(ev);
   begin scalar r; integer i;
      r := t;
      while r and not(i #> ev_ub!*) do
         if not(getv(ev,i) #= 0) then
            r := nil
         else
            i := i #+ 1;
      return r
   end;

procedure ev_compless!?(e1,e2);
   ev_comp(e2,e1) #= 1;

procedure ev_comp(e1,e2);
   % Exponent vector compare. e1, e2 are exponent vectors in some
   % order. Evcomp(e1,e2) returns the digit 0 if exponent vector e1 is
   % equal exponent vector e2, the digit 1 if e1 is greater than e2,
   % else the digit -1. This function is assigned a value by the
   % ordering mechanism, so is dummy for now. IDapply would be better
   % here, but is not within standard LISP!
   apply(dip_sortevcomp!*,{e1,e2});

procedure ev_insert(ev,v,dg,vars);
   % f to dip conversion: Insert the "dg" into the ev in the place of
   % variable v.
   begin scalar vv;
      vv := ev_cpv ev;
      putv(vv,ev_ub!* - length memq(v,vars) + 1,dg);
      return vv
   end;

procedure ev_cpv(v);
   begin scalar vv; integer i;
      vv := mkvect ev_ub!*;
      while not(i #> ev_ub!*) do <<
         putv(vv,i,getv(v,i));
         i := i #+ 1
      >>;
      return vv
   end;

procedure ev_tdeg(u);
   % calculate the total degree of u.
   begin integer x,i;
      while not(i #> ev_ub!*) do <<
         x := getv(u,i) #+ x;
         i := i #+ 1
      >>;
      return x
   end;

procedure ev_dif(e1,e2);
   begin scalar s; integer i;
      s := mkvect ev_ub!*;
      while not(i #> ev_ub!*) do <<
         putv(s,i,getv(e1,i) #- getv(e2,i));
         i := i #+ 1
      >>;
      return s
   end;

procedure ev_sum(e1,e2);
   begin scalar s; integer i;
      s := mkvect ev_ub!*;
      while not(i #> ev_ub!*) do <<
         putv(s,i,getv(e1,i) #+ getv(e2,i));
         i := i #+ 1
      >>;
      return s
   end;

procedure ev_disjointp(e1,e2);
   % nonconstructive test of lcm(e1,e2) = e1 + e2 equivalent: no
   % matches of nonzero elements.
   begin scalar r; integer i;
      r := t;
      while r and not(i #> ev_ub!*) do
         if not(getv(e1,i) #=0) and not(getv(e2,i) #=0) then
            r := nil
         else
            i := i #+ 1;
      return r
   end;

procedure ev_member(ev,evl);
   ev member evl;

procedure ev_identify(oev,nev);
   nev;

endmodule;  % vecev

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/cgb.red0000644000175000017500000014352011526203062022473 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: cgb.red 641 2010-05-24 19:00:30Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(cgb_rcsid!* cgb_copyright!*);
   cgb_rcsid!* := "$Id: cgb.red 641 2010-05-24 19:00:30Z thomas-sturm $";
   cgb_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

% TODO:
% - Normalize green groebner systems: Detect branches containing a unit
% - Detect green monomials in RP
% - Final simplification with groebner simplifier
% - Computing reduced or pseudo reduced groeber systems.
% - Computing relatively generic and local groebner systems.

module cgb;
% Comprehensive Groebner Bases.

create!-package('(cgb gb dp gbsc),nil);

!#if (and (memq 'psl lispsystem!*) (not (getd 'modulep)))
fluid '(!*lower loadextentions!*);

procedure modulep(u);
   begin scalar found,ld,le,!*lower;
      !*lower := t;
      ld := loaddirectories!*;
      while ld and not found do <<
	 le := loadextensions!*;
	 while le and not found do <<
	    if filep bldmsg("%w%w%w",first ld,u,car first le) then
	       found := cdr first le;
	       le := rest le
	 >>;
	 ld := rest ld
      >>;
      return not null found
   end;
!#endif

load!-package 'ezgcd;

load!-package 'groebner;  % for torder

%if 'csl memq lispsystem!* or 'psl memq lispsystem!* then
%   if modulep 'redlog then
      load!-package 'redlog;

switch cgbstat,cgbfullred,cgbverbose,cgbcontred,cgbgs,cgbreal,
   cgbsgreen,cgbfaithful;

fluid '(!*cgbstat !*cgbfullred !*cgbverbose !*cgbcontred !*cgbgs !*cgbreal
   !*cgbgen !*cgbsloppy !*cgbcdsimpl !*cgbfaithful);

off1 'cgbstat;
on1 'cgbfullred;
off1 'cgbverbose;
off1 'cgbcontred;
off1 'cgbgs;
off1 'cgbreal;
off1 'cgbsgreen;  % Simulate green: Compute Gsys and color it green.
off1 'cgbfaithful;

!*cgbsloppy := T;
!*cgbcdsimpl := T;

fluid '(!*cgbgreen);  % pseudo switch for computing green Gsys'

fluid '(!*gcd !*ezgcd !*factor !*exp dmode!* !*msg !*backtrace);

fluid '(cgp_pcount!* cgb_hashsize!*);

cgb_hashsize!* := 65521;  % The size of the hash table for BETA (in gbsc).

fluid '(cgb_hcount!* cgb_hzerocount!* cgb_tr1count!* cgb_tr2count!*
   cgb_tr3count!* cgb_b4count!* cgb_strangecount!* cgb_paircount!*
   cgb_gcount!* cgb_gbcount!*);

fluid '(cgb_cd!* cgb_mincontred!* cgb_contcount!*);
cgb_mincontred!* := 20;  % originally 10

fluid '(!*rlgsvb !*rlspgs !*rlsithok !*rlsiexpla);

%DS
%  ::= 
%  ::= ('list,...,,...)
%  ::= ('list,...,,...)
%  ::= ('list,,)
%  ::= (...,,...)
%  ::= (...,,...)
%  ::= (,)
%  ::= (...,,...)

macro procedure cgb_mkinterface(argl);
   begin
      scalar a2sl1,a2sl2,defl,xvfn,s2a,s2s,s,
         args,bname,len,sm,prgn,ami,smi,psval,postfix,modes;
      bname := eval nth(argl,2); % basename of the proc. to be generated
      a2sl1 := eval nth(argl,3); % list of A->SF conv. proc. for all args
      a2sl2 := eval nth(argl,4);
      % list of A->CGP (s=nil)/SF->CGP (s=T) conv. proc. for all args
      defl := eval nth(argl,5);  % list of Lisp pref. default vals for opt. args
      xvfn := eval nth(argl,6);  % func. to extract (m . p) from all args
      s2a := eval nth(argl,7);   % S2A conv. proc for result
      s2s := eval nth(argl,8);   % CGB->Sf conv. proc for result
      s := eval nth(argl,9);     % see a2sl2
      postfix := eval nth(argl,10); % 'f for "(standard) form"
      modes := eval nth(argl,11);   % 'am, 'sm, or nil for both
      len := length a2sl1;
      args := for i := 1:len+3 collect mkid('a,i);
      if (null modes or modes eq 'sm) then <<
               sm := intern compress append('(!c !g !b !_),explode bname);
               % Define the symbolic mode interface
               smi := intern compress nconc(explode sm,explode postfix);
               prgn := {'put,mkquote smi,''number!-of!-args,len+3} . prgn;
               prgn := {'de,smi,args,{'cgb_interface!$,mkquote sm,mkquote a2sl1,
            mkquote a2sl2,mkquote defl,mkquote xvfn,mkquote
               s2a,mkquote s2s,mkquote s,T,'list . args}} . prgn
      >>;
      if (null modes or modes eq 'am) then <<
               % Define the algebraic mode interface
               ami := bname;
               %      ami := intern compress append('(!c !g !b),explode bname);
               psval := intern compress nconc(explode ami,'(!! !$));
               prgn := {'put,mkquote ami,''psopfn,mkquote psval} . prgn;
               prgn := {'put,mkquote psval,''number!-of!-args,1} . prgn;
%%             prgn := {'put,mkquote psval,''cleanupfn,''cgb_cleanup} . prgn;
               prgn := {'de,psval,'(formalargl),{'cgb_interface!$,mkquote sm,
            mkquote a2sl1,mkquote a2sl2,mkquote defl,mkquote
               xvfn,mkquote s2a,mkquote s2s,mkquote s,nil,'formalargl}} . prgn;
      >>;
      return 'progn . prgn
   end;

% cgb(polynomials,[theo])
%
% gsys(polynomials,[theo]) with switch cgbfaithful
%
% ggsys(polynomials,[theo[,xvarl]]) with switch cgbfaithful
%
% gsys2cgb(gsys)

cgb_mkinterface('cgb,'(cgb_a2s!-psys cgb_a2s!-cd),'(cgb_a2s2!-psys
   cgb_a2s2!-cd),{'true},'cgb_xvars!-psys2,'cgb_s2a!-cgb,'cgb_s2s!-cgb,
   T,'f,nil);

cgb_mkinterface('gsys,'(cgb_a2s!-psys cgb_a2s!-cd),'(cgb_a2s2!-psys
   cgb_a2s2!-cd),{'true},'cgb_xvars!-psys2,'cgb_s2a!-gsys,'cgb_s2s!-gsys,
   T,'f,nil);

cgb_mkinterface('ggsys,'(cgb_a2s!-psys cgb_a2s!-cd cgb_a2s!-varl),
   '(cgb_a2s2!-psys cgb_a2s2!-cd cgb_a2s2!-varl),
   {'true,'(list)},'cgb_xvars!-psys3,'cgb_s2a!-gsys,'cgb_s2s!-gsys,T,'f,nil);

cgb_mkinterface('gsys2cgb,'(cgb_a2s!-gsys),'(cgb_a2s2!-gsys),
   nil,'cgb_xvars!-gsys,'cgb_s2a!-cgb,'cgb_s2s!-cgb,T,'f,nil);

put('cgb_cgb,'gb_wrapper,{'gb_gb0,'(gb_a2s!-psys
   gb_dummy1),'(gb_a2s2!-psys gb_dummy1),{'dummy},'gb_xvars!-psys2,
   'gb_s2a!-gbx,'gb_s2s!-gb,T});

put('cgb_gsys,'gb_wrapper,{'gb_gbgsys0,'(gb_a2s!-psys
   gb_dummy1),'(gb_a2s2!-psys gb_dummy1),{'dummy},'gb_xvars!-psys2,
   'gb_s2a!-gsys,'gb_s2s!-gsys,T});

put('cgb_ggsys,'gb_wrapper,{'gb_gbggsys0,'(gb_a2s!-psys
   gb_dummy1 gb_dummy1),'(gb_a2s2!-psys gb_dummy1 gb_dummy1),{'dummy,'dummy},
   'gb_xvars!-psys3,'gb_s2a!-gsys,'gb_s2s!-gsys,T});

procedure cgb_a2s!-psys(l);
   % Comprehensive Groebner bases algebraic mode to symbolic mode
   % polynomial system. [l] is an AMPSYS. Returns an FPSYS.
   begin scalar w,resl;
      for each j in getrlist reval l do <<
               w := numr simp j;
         if w and not(w member resl) then
            resl := w . resl
      >>;
      return sort(resl,'ordp)
   end;

procedure cgb_a2s2!-psys(fl);
   for each x in fl collect cgp_f2cgp x;

procedure cgb_xvars!-psys(l,vl);
   cgb_vars(l,vl);

procedure cgb_xvars!-psys2(l,cd,vl);
   cgb_vars(l,vl);

procedure cgb_xvars!-psys3(l,cd,xvl,vl);
   cgb_vars(l,vl);

procedure cgb_s2a!-cgb(u);
   % Comprehensive Groebner bases symbolic mode to algebraic mode CGB.
   % [u] is a list of CGP's. Returns an AMPSYS.
   'list . for each x in u collect cgp_2a x;

procedure cgb_s2s!-cgb(l);
   cgb_cgb!-sfl l;

procedure cgb_s2a!-gsys(u);
   % Comprehensive Groebner bases symbolic mode to algebraic mode
   % Groebner system. [u] is a GSY. Returns an AMGSYS.
   'list . for each bra in u collect cgb_s2a!-bra bra;

procedure cgb_s2a!-bra(bra);
   % Comprehensive Groebner bases symbolic mode to algebraic mode
   % branch. [u] is a BRA. Returns an AMBRANCH.
   {'list,rl_mk!*fof rl_smkn('and,bra_cd bra),
      'list . for each x in bra_system bra collect cgp_2a x};

procedure cgb_s2s!-gsys(u);
   for each bra in u collect cgb_s2s!-bra bra;

procedure cgb_s2s!-bra(bra);
   {bra_cd bra,cgb_s2s!-cgb bra_system bra};

procedure cgb_a2s!-gsys(u);
   % Comprehensive Groebner bases algebraic mode to symbolic mode
   % Groebner system. [u] is AMGSYS. Returns an FGSYS.
   begin scalar sys,w;
      sys := getrlist reval u;
      return for each bra in sys collect <<
         w := getrlist bra;
         bra_mk(cd_for2cd rl_simp car w,cgb_a2s!-psys cadr w,nil)
      >>
   end;

procedure cgb_a2s2!-gsys(sys);
   for each bra in sys collect
      bra_mk(car bra,cgb_a2s2!-psys cadr bra,nil);

procedure cgb_xvars!-gsys(sys,vl);
   begin scalar w;
      w := for each bra in sys join
         bra_system bra;
      return cgb_vars(w,vl)
   end;

procedure cgb_a2s!-cd(cd);
   begin scalar w,!*rlsiexpla;
      w := rl_simpl(rl_simp reval cd,nil,-1);
      if not cgb_cdp w then
         rederr
             "CGB theory must be truth value or (conjunction of) atomic formulas";
      return cd_for2cd w
   end;

procedure cgb_cdp(cd);
   begin scalar err;
      if rl_tvalp cd or not rl_cxp rl_op cd then
         return T;
      if rl_op cd neq 'and then
         return nil;
      cd := rl_argn cd;
      while not err and cd do
         if (not rl_tvalp car cd and rl_cxp rl_op car cd) then
            err := T
         else
            cd := cdr cd;
      return not err
   end;

procedure cgb_a2s2!-cd(cd);
   cd;

procedure cgb_a2s!-varl(varl);
   cdr varl;

procedure cgb_a2s2!-varl(varl);
   varl;

procedure cgb_cleanup(u,v);  % Do not use reval.
   u;

procedure cgb_interface!$(fname,a2sl1,a2sl2,defl,xvfn,s2a,s2s,s,smp,argl);
   % fname is a function, the name of the procedure to be called;
   % [a2sl1] and [as2sl2] are a list of functions, called to be
   % transform algebraic arguments to symbolic arguments; [defl] is a
   % list of algebraic defualt arguments; xvfn is a procedure for
   % extracting the variables from all arguments; [s2a] is procedure
   % for transforming the symbolic return value to an algebraic mode
   % return value; [argl] is the list of arguments; [s] is a flag;
   % [smp] is a flag. Return an S-expr. If [s] is on then second stage
   % of argument processing is done with the results of the first one.
   begin scalar w,vl,nargl,oenv,ocdenv,m,c,x;
      ocdenv := cd_init();  % early setup for a2s procedures...
      if not smp then <<
         nargl := cgb_am!-pargl(fname,a2sl1,argl,defl);
         vl := apply(xvfn,append(nargl,{td_vars()}));
         if null cdr vl and (w:=get(fname,'gb_wrapper)) then <<
            cd_cleanup ocdenv;
            return apply('gb_interface!$,append(w,{smp,argl}))
         >>;
         oenv := cgp_init(car vl,td_sortmode(),td_sortextension());
      >> else <<
         w := cgb_sm!-pargl argl;
         nargl := car w;
         m := cadr w;
         c := caddr w;
         x := cadddr w;
         vl := apply(xvfn,append(nargl,{m}));
         if null cdr vl and (w:=get(fname,'gb_wrapper)) then <<
            cd_cleanup ocdenv;
            return apply('gb_interface!$,append(w,{smp,argl}))
         >>;
         oenv := cgp_init(car vl,c,x);
      >>;
      w := errorset({'cgb_interface1!$,
         mkquote fname,mkquote a2sl2,mkquote s2a,mkquote s2s,mkquote s,
         mkquote smp,mkquote argl, mkquote nargl,mkquote car vl,
         mkquote cdr vl},T,!*backtrace);
      cd_cleanup ocdenv;
      cgp_cleanup oenv;
      if errorp w then
               rederr {"error during errorset() on",fname};
      return car w
   end;

procedure cgb_sm!-pargl(argl);
   begin scalar nargl,m,c,x;
      nargl := reverse argl;
      x := car nargl;
      nargl := cdr nargl;
      c := car nargl;
      nargl := cdr nargl;
      m := car nargl;
      nargl := cdr nargl;
      nargl := reversip nargl;
      return {nargl,m,c,x}
   end;

procedure cgb_am!-pargl(fname,a2sl1,argl,defl);
   % process argument list for algebraic mode.
   begin integer l1,l2,l3,noa; scalar w,nargl,scargl,scdefl;
      l1 := length argl;  % number of passed args
      l2 := length a2sl1; % number of specified args
      l3 := l2 - length defl;  % lower bound for passed args
      if l1 < l3 or l1 > l2 then
         rederr {fname,"called with",l1,"arguments instead of",l3,"-",l2};
      scargl := argl;
      scdefl := defl;
      noa := 1;
      nargl := for each x in a2sl1 collect <<
         if scargl then <<
            w := car scargl;
            scargl := cdr scargl
         >> else <<
            w := car scdefl;
         >>;
         if noa > l3 then
            scdefl := cdr scdefl;
         noa := noa + 1;
         apply(x,{w})
      >>;
      return nargl
   end;

procedure cgb_interface1!$(fname,a2sl2,s2a,s2s,s,smp,argl,nargl,m,p);
   begin scalar w,pl;
      pl := if s then nargl else argl;
      argl := for each x in a2sl2 collect <<
         w := car pl;
         pl := cdr pl;
         apply(x,{w})
      >>;
%      w := apply(fname,nconc(argl,{m,p}));
      w := apply(fname,argl);
      w := if smp then
         apply(s2s,{w})
      else
               apply(s2a,{w});
      return w
   end;

procedure cgb_greengsysf(u,m,sm,sx,theo,xvarl);
   cgb_ggsysf(u,m,sm,sx,theo,xvarl);

procedure cgb_gsys2green(u,theo);
   % Comprehensive Groebner bases Groebner system to gree Groebner
   % system. [u] is a GSY; [theo] is a CD. Returns a GSY, in which
   % all polynomials are colored green, i.e., the green colore head
   % part is deleted.
   for each bra in u collect
      bra_mk(bra_cd bra,cgb_cgpl2green(bra_system bra,append(theo,bra_cd bra)),
         bra_cprl bra);

procedure cgb_cgpl2green(l,theo);  % TODO: delete green monomials in RP.
   % Comprehensive Groebner bases CGP list 2 green CGP list. [l] is a
   % list of CGP's; [theo] is a CD. Returns a list of CGP's. All CGP's
   % in the returned list are colred green, i.e., the green colored
   % head part is deleted.
   for each cgp in l collect
      cgp_green cgp;

procedure cgb_domainchk();
   % Comprehensive Groebner bases domain check. No argument. Return
   % value not defined. Raises an error if the current domain is not
   % valid for CGB computations.
   if not memq(dmode!*,'(nil)) then
      rederr bldmsg("cgb does not support domain: %w",get(dmode!*,'dname));

procedure cgb_vars(l,vl);
   % Comprehensive Groebner bases variables. [l] is a list of SF's;
   % [vl] is the list of main variables. Returns a pair $(m . p)$
   % where $m$ and $p$ are list of variables. $m$ is the list of used
   % main variables and $p$ is the list of used parameters.
   begin scalar w,m,p;
      for each f in l do
         w := union(w,kernels f);
      if vl then <<
               m := cgb_intersection(vl,w);
               p := setdiff(w,vl)
      >> else
         m := w;
      return m . p
   end;

procedure cgb_varsgsys(gsys,vl);
   % Comprehensive Groebner bases variables in a Groebner system.
   % [gsys] is FGSYS; [vl] is the list of main variables . Returns a
   % pair $(m . p)$ where $m$ and $p$ are list of variables. $m$ is
   % the list of used main variables and $p$ is the list of used
   % parameters.
   begin scalar w,m,p;
      for each bra in gsys do
               for each f in bra_system bra do
            w := union(w,kernels f);
      m := cgb_intersection(vl,w);
      p := setdiff(w,vl);
      return m . p
   end;

procedure cgb_intersection(a,b);
   % Comprehensive Groebner bases intersection. [a] and [b] are lists.
   % Returns a list. The returned list contains all elements occuring
   % in [a] and in [b]. The order of the elements is the same as in
   % [a].
   for each x in a join
      if x member b then
         {x};

procedure cgb_cgb(u,theo);
   % Comprehensive Groebner bases CGB computation. [u] is a list of
   % CGP's; [theo] is a condition. Returns a list of CGP's.
   cgb_gsys2cgb cgb_gsys(u,theo) where !*cgbfaithful=T;

procedure cgb_gsys2cgb(u);
   % Comprehensive Groebner bases CGB to Groebner system conversion.
   % [u] is a GSY. Returns a list of CGP's.
   begin scalar cgbase;
      for each bra in u do
         for each p in bra_system bra do
            if not (p member cgbase) then  % TODO: cgp_member?
               cgbase := p . cgbase;
      return cgp_lsort cgbase
   end;

procedure cgb_cgb!-sfl(u);
   % Comprehensive Groebner bases CGB to SF list. [u] is a list of
   % CGP's. Returns a list of SF's.
   for each p in u collect cgp_2f p;

smacro procedure cgb_tt(s1,s2);
   % Comprehensive Groebner bases tt. [s1] and [s2] are CGP's. Returns
   % an EV, the lcm of the leading terms of [s1] and [s2].
   ev_lcm(cgp_evlmon s1,cgp_evlmon s2);

%% procedure cgb_gsys(u,theo);
%%    % Comprehensive Groebner bases Groebner system computation. [u] is
%%    % a list of CGP's; [theo] is the inital theory. Returns a GSY, the
%%    % Groebner system of [u].
%%    gsy_normalize cgb_gsys1(cgp_lsort u,theo,nil) where
%%       !*cgbgen=nil,!*cgbgreen=not !*cgbfaithful;
%%
%% procedure cgb_ggsys(u,theo,xvarl);
%%    % Comprehensive Groebner bases Groebner system computation. [u] is
%%    % a list of CGP's; [theo] is the inital theory. Returns a GSY, the
%%    % Groebner system of [u].
%%    gsy_normalize cgb_gsys1(cgp_lsort u,theo,xvarl) where
%%       !*cgbgen=T,!*cgbgreen=not !*cgbfaithful;

procedure cgb_gsys(u,theo);
   % Comprehensive Groebner bases Groebner system computation. [u] is
   % a list of CGP's; [theo] is the inital theory. Returns a GSY, the
   % Groebner system of [u].
   if !*cgbfaithful then
      gsy_normalize cgb_gsys1(cgp_lsort u,theo,nil)
          where !*cgbgen=nil,!*cgbgreen=nil
   else
      cgb_nonfaithfulgsys(u,theo,nil) where !*cgbgen=nil;

procedure cgb_ggsys(u,theo,xvarl);
   % Comprehensive Groebner bases Groebner system computation. [u] is
   % a list of CGP's; [theo] is the inital theory. Returns a GSY, the
   % Groebner system of [u].
   if !*cgbfaithful then
      gsy_normalize cgb_gsys1(cgp_lsort u,theo,xvarl)
          where !*cgbgen=T,!*cgbgreen=nil
   else
      cgb_nonfaithfulgsys(u,theo,xvarl) where !*cgbgen=T;

procedure cgb_nonfaithfulgsys(u,theo,xvarl);
   % Comprehensive Groebner bases green Groebner system computation.
   % [u] is a list of CGP's; [theo] is the initial theory. Returns a
   % GSY, the green Groebner system of [u].
   if !*cgbsgreen then
      gsy_normalize cgb_gsys2green(cgb_gsys1(cgp_lsort u,theo,xvarl),theo)
         where !*cgbgreen=nil
   else
      gsy_normalize cgb_gsys1(cgp_lsort u,theo,xvarl) where !*cgbgreen=T;

procedure cgb_gsys1(u,theo,xvarl);
   % Comprehensive Groebner bases Groebner system computation
   % subroutine. [u] is a list of CGP's; [theo] is the initaila
   % theory. Returns a GSY, the Groebner system of [u].
   begin
      scalar spac,stime,p1,!*factor,!*exp,!*gcd,!*ezgcd,cgb_cd!*,!*cgbverbose;
      integer cgp_pcount!*,cgb_contcount!*,cgb_hcount!*,cgb_hzerocount!*,
         cgb_tr1count!*,cgb_tr2count!*,cgb_tr3count!*,cgb_b4count!*,
         cgb_strangecount!*,cgb_paircount!*,cgb_gbcount!*,cgb_contcount!*;
      if theo = '(false) then
         rederr "cgb_gsys1: inconsistent theory";
      !*exp := !*gcd := !*ezgcd := t;
      cgb_contcount!* := cgb_mincontred!*;
      if !*cgbstat then <<
               spac := gctime();
         stime := time()
      >>;
      p1 := cgb_traverso(u,theo,xvarl);
      if !*cgbstat then <<
         ioto_tprin2t "Statistics for GB computation:";
         ioto_prin2t {"Time: ",time() - stime," ms plus GC time: ",
            gctime() - spac," ms"};
         ioto_prin2t {"H-polynomials total: ",cgb_hcount!*};
         ioto_prin2t {"H-polynomials zero: ",cgb_hzerocount!*};
         ioto_prin2t {"Crit Tr1 hits: ",cgb_tr1count!*};
         ioto_prin2t {"Crit B4 hits: ",cgb_b4count!*," (Buchberger 1)"};
         ioto_prin2t {"Crit Tr2 hits: ",cgb_tr2count!*};
         ioto_prin2t {"Crit Tr3 hits: ",cgb_tr3count!*};
%        ioto_prin2t {"Strange reductions: ",cgb_strangecount!*}
      >>;
      return p1
   end;

procedure cgb_traverso(g0,theo,xvars);
   % Comprehensive Groebner bases Traverso. [g0] is a list of CGP's;
   % [theo] is a initial theory. Returns a GSY of [g0].
   begin scalar bra,gsys,resl,bral;
      g0 := for each fj in g0 collect
         cgp_simpdcont fj;
      gsys := gsy_init(g0,theo,xvars);
      while gsys do <<
         bra := car gsys;
         gsys := cdr gsys;
         if bra_cprl bra eq 'final or null bra_cprl bra then
            resl := bra . resl
         else <<
            bral := cgb_traverso1(bra,xvars);
            gsys := nconc(bral,gsys)
         >>
      >>;
      return resl  % TODO: reduction
   end;

procedure cgb_traverso1(bra,xvars);
   % Comprehensive Groebner bases Traverso subroutine. [bra] is a BRA.
   % Returns a GSY. Performs one step in the computation of a GSY.
   begin scalar g,d,s,h,p;
      cgb_cd!* := bra_cd bra;
      g := bra_system bra;
      d := bra_cprl bra;
      if !*cgbverbose then <<
               ioto_prin2 {"[",cgb_paircount!*,"] "};
         cgb_paircount!* := cgb_paircount!* #- 1
      >>;
      p := car d;
      d := cdr d;
      s := cgb_spolynomial p;
      h := cgb_normalform(s,g,xvars);
      h := cgp_simpdcont h;
      if !*cgbstat then
         cgb_hcount!* := cgb_hcount!* #+ 1;
      if cgp_zerop h then
          cgb_hzerocount!* := cgb_hzerocount!* #+ 1;
      return bra_split(bra_mk(cgb_cd!*,g,d),h,xvars)
   end;

procedure cgb_spolynomial(pr);
   % Comprehensive Groebner bases S-polynomial. [pr] is a CPR. Returns
   % a CGP the S-polynomial of [pr] possibly reduced wrt. the
   % polynomials in [pr].
   begin scalar s;
      s := cgb_spolynomial1 pr;  % TODO: updcondition
      return s;  % TODO: Strange reduction
   end;

procedure cgb_spolynomial1(pr);
   % Comprehensive Groebner bases S-polynomial subroutine. [pr] is a
   % CPR. Returns a CGP. the S-polynomial of [pr].
   begin scalar p1,p2,ep,ep1,ep2,rp1,rp2,db1,db2,x,spol;
      p1 := cpr_p1 pr;
      p2 := cpr_p2 pr;
      ep := cpr_lcm pr;
      ep1 := cgp_evlmon p1;
      ep2 := cgp_evlmon p2;
      rp1 := cgp_mred p1;
      rp2 := cgp_mred p2;
      if cgp_greenp rp1 and cgp_greenp rp2 then
          return cgp_zero();
      db1 := cgp_lbc p1;
      db2 := cgp_lbc p2;
      x := bc_gcd(db1,db2);
      db1 := bc_quot(db1,x);
      db2 := bc_quot(db2,x);
      spol := cgp_ilcomb(rp1,db2,ev_dif(ep,ep1),rp2,bc_neg db1,ev_dif(ep,ep2));
      if cgp_greenp spol then
         return cgp_zero();
      return spol
   end;

procedure cgb_normalform(f,g,xvars);
   % Comprehensive Groebner bases normal form computation. [f] is a
   % CGP; [g] is a list of CGP's with red HT's. Returns a CGP $p$.
   % Depends on switch [!*cgbfullred]. $p$ is computed by
   % reducing [f] with polynomials in [g].
   begin scalar fold,c,tai,divisor;
      if null g then
         return f;
      if cgp_greenp f then
         return cgp_zero();
      fold := f;
      f := cgp_hpcp f;
      f := cgp_shift(f,xvars);
      c := T; while c and cgp_rp f do <<
         divisor := cgb_searchinlist(cgp_evlmon f,g);
         if divisor then <<
            tai := T;
            f := cgb_reduce(f,divisor)
         >> else if !*cgbfullred then
            f := cgp_shiftwhite f
         else
            c := nil;
         if c then
            f := cgp_shift(f,xvars)
      >>;
      if not tai then
         return fold;
      return cgp_backshift f  % TODO: updccondition
   end;

procedure cgb_searchinlist(vev,g);
   % Comprehensive Groebner bases search for a polynomial in a list.
   % [vev] is a EV; [g] is a CGP. Returns a CGP $p$, such that the RP
   % of [g] is reducible wrt. $p$.
   if null g then
      nil
   else if cgb_buch!-ev_divides!?(cgp_evlmon car g,vev) then
      car g
   else
      cgb_searchinlist(vev,cdr g);

procedure cgb_buch!-ev_divides!?(vev1,vev2);
   % Comprehensive Groebner bases Buchberger exponent vector divides.
   % [vev1] and [vev2] are EV's. Returns non-[nil] if [vev1] divides
   % [vev2].
   ev_mtest!?(vev2,vev1);

procedure cgb_reduce(f,g1);
   % Comprehensive Groebner bases reduce. [f] is a CGP; [g1] is a CGP,
   % such that the RP of [f] is reducible wrt. [g1]. Returns a CGP
   % $p$. $p$ is computed by reducing [f] with [g1].
   if cgp_monp g1 then
      cgp_cancelmev(cgp_bcprod(f,cgp_lbc g1),cgp_evlmon g1)  % TODO: numberp
   else
      cgb_reduceonestep(f,g1);  % TODO: Content reduction

procedure cgb_reduceonestep(f,g);
   % Comprehensive Groebner bases reduce one step. [f] is a CGP; [g]
   % is a CGP, such that the RP of [f] is top-reducible wrt. [g].
   % Returns a CGP $p$. $p$ is computed by performing one
   % top-reduction.
   begin scalar cot,hcf,hcg,x,a,b;
      cot := ev_dif(cgp_evlmon f,cgp_evlmon g);
      hcf := cgp_lbc f;
      hcg := cgp_lbc g;
      x := bc_gcd(hcf,hcg);
      a := bc_quot(hcg,x);
      b := bc_quot(hcf,x);
      return cgp_setci(cgp_ilcombr(f,a,g,bc_neg b,cot),cgp_ci f)
   end;  % TODO: updccondition

endmodule;   % cgb;


module cd;
% Conditions.

% DS
%  ::=  (false) | () | (...,,...)

procedure cd_init();
   % Condition init. No argument. Return value describes the current
   % context. Depends on switch [!*cgbreal]. Sets up the environment
   % for handling conditions in the choosen context.
   (if !*cgbreal then rl_set '(ofsf) else rl_set '(acfsf)) where !*msg=nil;

procedure cd_cleanup(oc);
   % Condition clean-up. [oc] decsribes the context wich should be
   % selected. Return value unspecified.
   rl_set oc where !*msg=nil;

procedure cd_falsep(cd);
   % Condion false predicate. [cd] is a CD. Returns bool. If [t] is
   % retunred then the condion [cd] is inconsistent.
   eqcar(cd,'false);

procedure cd_siadd(atl,sicd);
   % Condion simplify add. [atl] is a list of atomic formulas; [sicd]
   % is a CD. Returns a CD, the union of [cd] and [atl].
   begin scalar w;
      if not !*cgbcdsimpl then
               return nconc(atl,sicd);
      w := if !*cgbgs then
         cd_gsd(rl_smkn('and,nconc(atl,sicd)),nil)
      else
         rl_siaddatl(atl,rl_smkn('and,sicd));
      return cd_for2cd w
   end;

procedure cd_for2cd(f);
   % Condition formula to condition. [f] is either ['false] , ['true],
   % or a conjunction of atomic formulas. Returns a CD equivalent to
   % [f]. Formula to condition.
   if f eq 'true then
      nil
   else if f eq 'false then
      '(false)
   else if cl_cxfp f then
      rl_argn f
   else
      {f};

procedure cd_surep(f,cd);
   % Condition sure predicate. [f] is an atomic formula; [cd] is a CD.
   % If [T] is returned, then [cd] implies [f].
   begin scalar !*rlgsvb;
      return rl_surep(f,cd) where !*rlspgs=!*cgbgs,!*rlsithok=T;
   end;

procedure cd_gsd(f,cd);
   % Condition Groebner simplifier. [f] is a formula; [cd] is a
   % condition. Simplies [f] wrt. the theory [cd].
   begin scalar !*rlgsvb;
      return rl_gsd(f,cd)
   end;

procedure cd_ordp(cd1,cd2);
   % Condition order predicate. [cd1] and [cd2] are conditions sorted
   % wrt. ['cd_ordatp]. Returns bool.
   if null cd1 then
      T
   else if null cd2 then
      nil
   else if car cd1 neq car cd2 then
      cd_ordatp(car cd1,car cd2)
   else
      cd_ordp(cdr cd1,cdr cd2);

procedure cd_ordatp(a1,a2);
   % Condition order atomic formula predicate. [a1] and [a2] are
   % atomic formulas. Returns bool.
   if car a1 eq 'neq and car a2 eq 'equal then
      T
   else if car a1 eq 'equal and car a2 eq 'neq then
      nil
   else
      ordp(cadr a1,cadr a2);

endmodule;  % cd


module cpr;
% Critical pairs.

%DS
%  ::= (...,,...)
%  ::= (,,,);

procedure cpr_mk(f,h);
   % Critical pair make. [f], and [h] are CGP's. Returns a CPR.
   % Construct a pair from polynomials [f] and [h].
   begin scalar ttt,sf,sh;
      ttt := cgb_tt(f,h);
      sf := cgp_sugar(f) #+ ev_tdeg ev_dif(ttt,cgp_evlmon f);
      sh := cgp_sugar(h) #+ ev_tdeg ev_dif(ttt,cgp_evlmon h);
      return cpr_mk1(ttt,f,h,ev_max!#(sf,sh))
   end;

procedure cpr_mk1(lcm,p1,p2,sugar);
   % Critical pair make subroutine. [lcm] is an EV, the lcm of [evlmon
   % p1] and [evlmon p2]; [p1] and [p2] are CGP's with red HC; [sugar]
   % is a machine integer, the sugar of the S-polynomials of [p1] and
   % [p2]. Returns a CPR.
   {lcm,p1,p2,sugar};

procedure cpr_lcm(cpr);
   % Critical pair lcm. [cpr] is a critical pair. Returns the lcm part
   % of [cpr].
   car cpr;

procedure cpr_p1(cpr);
   % Critical pair p1. [cpr] is a critical pair. Returns the p1 part
   % of [cpr].
   cadr cpr;

procedure cpr_p2(cpr);
   % Critical pair p2. [cpr] is a critical pair. Returns the p2 part
   % of [cpr].
   caddr cpr;

procedure cpr_sugar(cpr);
   % Critical pair suger. [cpr] is a critical pair. Returns the sugar
   % part of [cpr].
   cadddr cpr;

procedure cpr_traverso!-pairlist(gk,g,d);
   % Critical pair Travero pair list. [gk] is a CGP with red HT; [g]
   % is a list of CGP's with red HT's; [d] is a sorted list of CPR's.
   % Returns a sorted list of CPR's the result of updating [w] with
   % critical pairs construction by combining [gk] with polynomials in
   % [g].
   begin scalar ev,r,n;
      d := cpr_traverso!-pairs!-discard1(gk,d);
      % build new pair list:
      ev := cgp_evlmon gk;
      for each p in g do
              if not cpr_buchcrit4t(ev,cgp_evlmon p) then <<
            if !*cgbstat then
               cgb_b4count!* := cgb_b4count!* #+ 1;
             r := ev_lcm(ev,cgp_evlmon p) . r
                >> else
             n := cpr_mk(p,gk) . n;
      n := cpr_tr2crit(n,r);
      n := cpr_listsort(n,!*cgbsloppy);
      n := cpr_tr3crit n;
      if !*cgbverbose and n then <<
         cgb_paircount!* := cgb_paircount!* #+ length n;
         ioto_cterpri();
         ioto_prin2 {"(",cgb_gbcount!*,") "}
      >>;
      return cpr_listmerge(d,reversip n)
   end;

procedure cpr_tr2crit(n,r);
   % Critical pair Travero 2 criterion. [n] is a list of CPR's; [r] is
   % a list of EV's. Returns a list of CPR's. Delete equivalents to
   % coprime lcm
   for each p in n join
      if ev_member(cpr_lcm p,r) then <<
         if !*cgbstat then
            cgb_tr2count!* := cgb_tr2count!* #+ 1;
         nil
      >> else
         {p};

procedure cpr_tr3crit(n);
   % Critical pair Travero 3 criterion. [n] is a sorted list of CPR's;
   % [r] is a list of EV's. Returns a sorted list of CPR's.
   begin scalar newn,scannewn,q;
      for each p in n do <<
         scannewn := newn;
         q := nil;
          while scannewn do
            if ev_divides!?(cpr_lcm car scannewn,cpr_lcm p) then <<
               q := t;
               scannewn := nil;
               if !*cgbstat then
                         cgb_tr3count!* := cgb_tr3count!* #+ 1
            >> else
               scannewn := cdr scannewn;
         if not q then
            newn := cpr_listsortin(p,newn,nil)
      >>;
      return newn
   end;

procedure cpr_traverso!-pairs!-discard1(gk,d);
   % Critical pairs Traverso pairs discard 1. [gk] is a CGP with red
   % HT; [d] is a sorted list of CPR's. Returns a list of [cpr]'s.
   % Criterion B. Delete triange relations.
   for each pij in d join
      if cpr_traverso!-trianglep(cpr_p1 pij,cpr_p2 pij,gk,cpr_lcm pij) then <<
         if !*cgbstat then
            cgb_tr1count!* := cgb_tr1count!* #+ 1;
         if !*cgbverbose then
            cgb_paircount!* := cgb_paircount!* #- 1;
         nil
      >> else
         {pij};

procedure cpr_traverso!-trianglep(gi,gj,gk,tij);
   % Critical pairs Traverso triangle predicate. [gi], [gj], and [gk]
   % are CGP's with red HT; [tij] is an EV.
   ev_sdivp(cgb_tt(gi,gk),tij) and ev_sdivp(cgb_tt(gj,gk),tij);

procedure cpr_buchcrit4t(e1,e2);
   % Critical pair Buchbergers criterion 4. [e1], [e2] are EV's.
   % Returns [T] if [e1] and [e2] are disjoint.
   not ev_disjointp(e1,e2);

procedure cpr_listsort(g,sloppy);
   % Critical pair list sort. [g] is a list of CPR's, [sloppy] is
   % bool. Returns a list of CPR'S. Destructively sorts [g]
   begin scalar gg;
      for each p in g do
          gg := cpr_listsortin(p,gg,sloppy);
      return gg
   end;

procedure cpr_listsortin(p,pl,sloppy);
   % Critical pair list sort into. [p] is a CPR; [pl] is a sorted list
   % of CPR's, [sloppy] is bool. Destructively sorts [p] into [pl].
   if null pl then
      {p}
   else <<
      cpr_listsortin1(p,pl,sloppy);
      pl
   >>;

procedure cpr_listsortin1(p,pl,sloppy);
   % Critical pair list sort into. [p] is a CPR; [pl] is a non-empty,
   % sorted list of CPR's; [sloppy] is bool. Destructively sorts [p]
   % into [pl].
   if not cpr_lessp(car pl,p,sloppy) then <<
      rplacd(pl,car pl . cdr pl);
      rplaca(pl,p)
   >> else if null cdr pl then
      rplacd(pl,{p})
   else
      cpr_listsortin1(p,cdr pl,sloppy);

procedure cpr_lessp(pr1,pr2,sloppy);
   % Critical pair less predicate. [p1] and [p2] are CPR's; [sloppy]
   % is bool. Returns [T] is [p1] is less than [p2]. Compare 2 pairs
   % wrt. their sugar or their lcm.
   if sloppy then
      ev_compless!?(cpr_lcm pr1,cpr_lcm pr2)
   else
      cpr_lessp1(pr1,pr2,cpr_sugar pr1 #- cpr_sugar pr2,
         ev_comp(cpr_lcm pr1,cpr_lcm pr2));

procedure cpr_lessp1(pr1,pr2,d,q);
   % Critical pair less predicate subroutine. [p1] and [p2] are CPR's.
   % Returns [T] is [p1] is less than [p2]. Compare 2 pairs wrt. their
   % sugar or their lcm.
   if not(d #= 0) then
      d #< 0
   else if not(q #= 0) then
      q #< 0
   else
      cgp_number cpr_p2 pr1 #< cgp_number cpr_p2 pr2;

procedure cpr_listmerge(pl1,pl2);  % TODO: Rekursiv, konstruktiv !!!
   % Critical pair list merge. [pl1] and [pl2] are sorted list of
   % CPR's. Returns a sorted list of CPR's the restult of merging the
   % lists [pl1] and [pl2].
   begin scalar cpl1,cpl2;
      if null pl1 then
          return pl2;
      if null pl2 then
          return pl1;
      cpl1 := car pl1;
      cpl2 := car pl2;
      return if cpr_lessp(cpl1,cpl2,nil) then
          cpl1 . cpr_listmerge(cdr pl1,pl2)
      else
          cpl2 . cpr_listmerge(pl1,cdr pl2)
   end;

endmodule;  % cpr


module bra;

%DS
%  ::= (,,)

procedure bra_cd(br);
   % Branch condition. [br] is a BRA. Returns a CD, the condition part
   % of [br].
   car br;

procedure bra_system(br);
   % Branch system. [br] is a BRA. Returns a list of CGP's, the
   % system part of [br].
   cadr br;

procedure bra_cprl(br);
   % Branch critical pair list. [br] is a BRA. Returns a list of
   % CPR's, the pairs part of [br].
   caddr br;

procedure bra_mk(cd,system,cprl);
   % Branch make. [cd] is a CD; [system] is a list of CGP's with red
   % HT's; [cprl] is a list of CPR's. Returns a BRA.
   {cd,system,cprl};

procedure bra_split(bra,p,xvars);
   % Branch split. [bra] is a BRA; [p] is a CGP. Returns a GSY.
   if cgp_greenp p then
      {bra}
   else if bra_cprl bra eq 'final then
      {bra}
   else
      bra_split1(bra,cgp_enumerate cgp_condense p,xvars);

procedure bra_split1(bra,p,xvars);
   % Branch split subroutine. [bra] is a BRA; [p] is a CGP. Returns a GSY.
   for each pr in cgp_2scpl(p,bra_cd bra,xvars) collect
      bra_ext(bra,car pr,cdr pr);

procedure bra_ext(bra,cd,scp);
   % Branch extend. [bra] is a BRA; [cd] is a CD; [scp] is CGP with
   % red HT. Returns a BRA.
   begin scalar sy,d;
      if cgp_unitp scp then
         return bra_mk(cd,{scp},'final);
      sy := for each p in bra_system bra collect cgp_cp p;  % TODO: Copy?
      d := for each pr in bra_cprl bra collect pr;  % TODO: Copy?
      if cgp_greenp scp then
         return bra_mk(cd,sy,d);
      d := cpr_traverso!-pairlist(scp,sy,d);
      return bra_mk(cd,nconc(sy,{scp}),d)
   end;

procedure bra_ordp(b1,b2);
   % Branch order predicate. [b1] and [b2] are branches. Returns bool.
   cd_ordp(bra_cd b1,bra_cd b2);

endmodule;  % bra


module gsy;
% Groebner system.

%DS
%  ::= (...,,...)

procedure gsy_init(l,theo,xvars);
   % Groebner system initialize. [l] is a list of CGP's. Returns a
   % GSY. We construct a case distinction wrt. to the parametric
   % coefficients in the elements of [l].
   begin scalar s;
      s := {bra_mk(theo,nil,nil)};
      for each x in l do
         s := for each y in s join
            bra_split(y,x,xvars);
      return s
   end;

procedure gsy_normalize(l);
   % Groebner system normalize. [l] is a GSY. Returns a GSY.
   sort(gsy_normalize1 l,'bra_ordp);

procedure gsy_normalize1(l);
   % Groebner system normalize subroutine. [l] is a GSY. Returns a GSY.
   for each bra in l collect
      bra_mk(sort(bra_cd bra,'cd_ordatp),
         cgp_lsort for each x in bra_system bra collect cgp_normalize x,
         bra_cprl bra);

endmodule;  % gsy


module cgp;
% Comprehensive Groebner basis polynomial.

%DS
%  ::= ('cgp,,,,,)
%  ::= 
%  ::= 
%  ::=  | nil
%  ::=  | nil
%  ::= 'unknown | 'red | 'green | 'zero | ('mixed . ) | green_colored
%  ::= (...,,...)

procedure cgp_mk(hp,rp,sugar,number,ci);
   % CGP make. [hp] and [rp] are DIP's; [sugar] and [number] are
   % machine numbers; [ci] is an S-expr.
   {'cgp,hp,rp,sugar,number,ci};

procedure cgp_hp(cgp);
   % CGP head polynomial. [cgp] is a CGP. Returns a DIP, the head
   % polynomial part of [cgp].
   cadr cgp;

procedure cgp_rp(cgp);
   % CGP rest polynomial. [cgp] is a CGP. Returns a DIP, the rest
   % polynomial part of [cgp].
   caddr cgp;

procedure cgp_sugar(cgp);
   % CGP sugar. [cgp] is a CGP. Returns a machine number, the sugar
   % part of [cgp].
   cadddr cgp;

procedure cgp_number(cgp);
   % CGP number. [cgp] is a CGP. Returns a machine number, the number
   % part of [cgp].
   nth(cgp,5);

procedure cgp_ci(cgp);
   % CGP number. [cgp] is a CGP. Returns an S-expr, the coloring %
   %  information of [cgp].
   nth(cgp,6);

procedure cgp_init(vars,sm,sx);
   % CGP init. [vars] is a list of variables. Returns an S-expr.
   % Initializing the DIP package.
   dip_init(vars,sm,sx);

procedure cgp_cleanup(l);
   % CGP clean-up. [l] is an S-expr returned by calling [cgp_init].
   dip_cleanup(l);

procedure cgp_lbc(u);
   % CGP leading base coefficient. [u] is a CGP. Returns the HC of the
   % rest part of [u].
   dip_lbc cgp_rp u;

procedure cgp_evlmon(u);
   % CGP exponent vector of leading monomial. [u] is a CGP. Returns
   % the HT of the rest part of [u].
   dip_evlmon cgp_rp u;

procedure cgp_zerop(u);
   % CGP zero predicate. [u] is a CGP. Returns [T] if [u] is the zero
   % polynomial.
   null cgp_hp u and null cgp_rp u;

procedure cgp_greenp(u);
   % CGP green predicate. [u] is a CGP. Returns [T] if [u] is
   % completely green colored.
   null cgp_rp u;

procedure cgp_monp(u);
   % CGP monomial predicate. [u] is a CGP. Returns [T] if [u] is a monomial.
   null cgp_hp u and dip_monp cgp_rp u;

procedure cgp_zero();
   % CGP zero. No argument. Returns the zero polynomial.
   cgp_mk(nil,nil,nil,nil,'zero);

procedure cgp_one();
   % CGP one. No argument. Returns a CGP, the polynomial one in CGP
   % representation.
   cgp_mk(nil,dip_one(),0,nil,'red);

procedure cgp_tdeg(u);
   % CGP total degree. [u] is a CGP. Returns the total degree of the
   % rest polynomial of [u].
   dip_tdeg cgp_rp u;

procedure cgp_mred(cgp);
   % CGP monomial reductum. [cgp] is a CGP. Returns a CGP $p$. $p$ is
   % computed from [cgp] by deleting the HM of the rest part of [cgp].
   cgp_mk(cgp_hp cgp,dip_mred cgp_rp cgp,cgp_sugar cgp,nil,'unknown);

procedure cgp_cp(cgp);
   % CGP copy. [cgp] is a CGP. Returns a CGP, the top-level copy of
   % [cgpl
   cgp_mk(cgp_hp cgp,cgp_rp cgp,cgp_sugar cgp,cgp_number cgp,cgp_ci cgp);

procedure cgp_f2cgp(u);
   % CGP form to cgp. [u] is a SF. Returns a CGP.
   cgp_mk(nil,dip_f2dip u,nil,nil,'unknown);

procedure cgp_2a(u);
   % CGP to algebraic. [u] is a CGP. Returns the AM representation of
   % [u].
   dip_2a dip_append(cgp_hp u,cgp_rp u);

procedure cgp_2f(u);
   % CGP to algebraic. [u] is a CGP. Returns the AM representation of
   % [u].
   dip_2f dip_append(cgp_hp u,cgp_rp u);

procedure cgp_enumerate(p);
   % CGP enumerate. [p] is a CGP. Returns a CGP. Sets the number of
   % [p] destructively to the next free number.
   cgp_setnumber(p,cgp_pcount!* := cgp_pcount!* #+ 1);

procedure cgp_unitp(p);
   % CGP unit predicate. [p] is a CGP with red HT. Returns [T] if [p]
   % is a unit.
   cgp_rp p and ev_zero!? cgp_evlmon p;

procedure cgp_setnumber(p,n);
   % CGP set number. [p] is a CGP; [n] is a machine number. Returns a
   % CGP. Sets the number of [p] destructively to [n].
   <<
      nth(p,5) := n;
      p
   >>;

procedure cgp_setsugar(p,s);
   % CGP set sugar. [p] is a CGP; [s] is a machine number. Returns a
   % CGP. Sets the sugar of [p] destructively to [s].
   <<
      nth(p,4) := s;
      p
   >>;

procedure cgp_setci(p,tg);
   % CGP set coloring information. [p] is a CGP; [tg] is an S-expr.
   % Returns a CGP. Sets the coloring information of [p] destructively
   % to [s].
   <<
      nth(p,6) := tg;
      p
   >>;

procedure cgp_condense(p);
   % CGP condense. [p] is a CGP. Returns a CGP. Condenses both the
   % head and the rest polynomial of [p].
   <<
      dip_condense cgp_hp p;
      dip_condense cgp_rp p;
      p
   >>;

procedure cgp_2scpl(p,cd,xvars);
   % CGP to strong cpl. [p] is a CGP; [cd] is a CD. Returns a list of
   % pairs $(...,(\gamma . p'),...)$, where $\gamma$ is a condition
   % and $p'$ is a CGP with red HC.
   if !*cgbgen and null xvars then
      cgp_2scpl!-gen(p,cd)
   else
      cgp_2scpl1(p,cd,xvars);

procedure cgp_2scpl1(p,cd,xvars);
   % CGP to strong cpl subroutine. [p] is a CGP; [cd] is a CD. Returns
   % a list of pairs $(...,(\gamma . p'),...)$, where $\gamma$ is a
   % condition and $p'$ is a CGP with red HC.
   begin scalar hp,rp,s,n,hc,ht,l,ncdeq,ncdneq;
      hp := cgp_hp p;
      if !*cgbgreen and hp then
         rederr {"cgp_2scpl1: Non empty hp",p};
      rp := cgp_rp p;
      s := cgp_sugar p;
      n := cgp_number p;
      while rp do <<
         hc := dip_lbc rp;
         ht := dip_evlmon rp;
         ncdeq := ncdneq := nil;
         if cd_surep(bc_mkat('neq,hc),cd) or
            eqcar(ncdeq := cd_siadd({bc_mkat('equal,hc)},cd),'false)
         then <<
            l := (cd . cgp_mk(hp,rp,s or dip_tdeg rp,n,'red)) . l;
            hc := 'break;
            rp := nil
         >> else if !*cgbgen and null intersection(xvars,bc_vars hc) then <<
            ncdneq := cd_siadd({bc_mkat('neq,hc)},cd);
            l := (ncdneq . cgp_mk(hp,rp,s or dip_tdeg rp,n,'red)) . l;
            hc := 'break;
            rp := nil
         >> else <<
            if not (cd_surep(bc_mkat('equal,hc),cd) or
               eqcar(ncdneq := cd_siadd({bc_mkat('neq,hc)},cd),'false))
            then <<
               ncdneq := ncdneq or cd_siadd({bc_mkat('neq,hc)},cd);
               ncdeq := ncdeq or cd_siadd({bc_mkat('equal,hc)},cd);
               l := (ncdneq . cgp_mk(hp,rp,s or dip_tdeg rp,n,'red)) . l;
               cd := ncdeq;
            >>;
            rp := dip_mred rp;
            if not(!*cgbgreen) then
               hp := dip_appendmon(hp,hc,ht);
         >>
      >>;
      if hc neq 'break then
          l := (cd . cgp_zero()) . l;
      return reversip l
   end;

procedure cgp_2scpl!-gen(p,cd);
   % CGP to strong cpl generic case. [p] is a CGP; [cd] is a CD. Returns
   % a list of one pair $((\gamma . p'))$, where $\gamma$ is a
   % condition and $p'$ is a CGP with red HC.
   begin scalar hp,rp;
      hp := cgp_hp p;
      rp := cgp_rp p;
      if null rp then
         return {cd . cgp_zero()};
      cd := cd_siadd({bc_mkat('neq,dip_lbc rp)},cd);
      return {cd . cgp_mk(hp,rp,cgp_sugar p or dip_tdeg rp,cgp_number p,'red)}
   end;

procedure cgp_ilcomb(p1,c1,t1,p2,c2,t2);
   % CGP integer linear combination. [p1], [p2] are CGP's; [c1], [c2]
   % are BC's; [t1], [t2] are EV's. Returns a CGP. Computes
   % $p1*c1^t1+p2*c2^t2$.
   begin scalar hp,rp,s;
      hp := dip_ilcomb(cgp_hp p1,c1,t1,cgp_hp p2,c2,t2);
      rp := dip_ilcomb(cgp_rp p1,c1,t1,cgp_rp p2,c2,t2);
      s := ev_max!#(cgp_sugar p1 #+ ev_tdeg t1,cgp_sugar p2 #+ ev_tdeg t2);
      return cgp_mk(hp,rp,s,nil,'unknown)  % TODO: Summe ?????
   end;

procedure cgp_ilcombr(p1,c1,p2,c2,t2);
   % CGP integer linear combination for reduction. [p1], [p2] are
   % CGP's; [c1], [c2] are BC's; [t2] is a EV's. Returns a CGP.
   % Computes $p1*c1+p2*c2^t2$.
   begin scalar hp,rp,s;
      hp := dip_ilcombr(cgp_hp p1,c1,cgp_hp p2,c2,t2);
      rp := dip_ilcombr(cgp_rp p1,c1,cgp_rp p2,c2,t2);
      s := ev_max!#(cgp_sugar p1,cgp_sugar p2 #+ ev_tdeg t2);
      return cgp_mk(hp,rp,s,nil,'unknown)
   end;

procedure cgp_hpcp(cgp);
   % CGP head polynomial copy. [cgp] is a CGP. Returns a CGP, in which
   % the head polynomial is copied.
   cgp_mk(dip_cp cgp_hp cgp,cgp_rp cgp,cgp_sugar cgp,
      cgp_number cgp,cgp_ci cgp);

procedure cgp_shift(p,xvars);
   % CGP shift. [p] is a CGP, which is neither zero nor green. Returns
   % a [CGP]. Shifts all leading green monomials from the rest part
   % into the head part.
   if !*cgbgen and null xvars then
      cgp_shift!-gen p
   else
      cgp_shift1(p,xvars);

procedure cgp_shift1(p,xvars);
   % CGP shift subroutine. [p] is a CGP, which is neither zero nor
   % green. Returns a [CGP]. Shifts all leading green monomials from
   % the rest part into the head part.
   begin scalar hp,rp,ht,hc,c;
      hp := cgp_hp p;
      rp := cgp_rp p;
      c := T;
      while c and rp do <<
         ht := dip_evlmon rp;
         hc := dip_lbc rp;
         if cd_surep(bc_mkat('equal,hc),cgb_cd!*) then <<
            if not(!*cgbgreen) then
               hp := dip_nconcmon(hp,hc,ht);
            rp := dip_mred rp
         >> else
            c := nil
      >>;
      if null rp and idp cgp_ci p then
         return cgp_zero();
      return cgp_mk(hp,rp,cgp_sugar p,cgp_number p,cgp_ci p)
   end;

procedure cgp_shift!-gen(p);
   % CGP shift generic case. [p] is a CGP, which is neither zero nor
   % green. Returns a [CGP]. Shifts all leading green monomials from
   % the rest part into the head part, i.e. we do nothing because
   % there are no green BC's.
   p;

procedure cgp_shiftwhite(p);
   % CGP shift white. [p] is a CGP, which is neither zero nor green.
   % Returns a [CGP]. Shifts the leading white monomials from the rest
   % part into the head part and set the wtl accordingly.
   begin scalar nhp,nci;
      nhp := dip_nconcmon(cgp_hp p,cgp_lbc p,cgp_evlmon p);
      nci := cgp_ci p;
      nci := 'mixed . (cgp_evlmon p . if idp nci then nil else cdr nci);
      return cgp_mk(nhp,dip_mred cgp_rp p,cgp_sugar p,cgp_number p,nci)
   end;

procedure cgp_backshift(p);
   % CGP back shift. [p] is a CGP. Returns a CGP. Shifts all white
   % monomials from the head part into the rest part using the wtl.
   begin scalar ci;
      ci := cgp_ci p;
      if not pairp ci or pairp ci and null cdr ci then
         return p;
      if cgp_rp p then
         rederr "cgp_backshift: Rest polynomial must be zero";
      return cgp_backshift1 p
   end;

procedure cgp_backshift1(p);
   % CGP back shift subroutine. [p] is a CGP. Returns a CGP. Shifts
   % all white monomials from the head part into the rest part using
   % the wtl.
   begin scalar hp,wtl,nhp;
      hp := cgp_hp p;
      wtl := cdr cgp_ci p;
      % TODO: Update condition
      while hp and not ev_member(dip_evlmon hp,wtl) do <<  % TODO: Destructive?
         nhp := dip_nconcmon(nhp,dip_lbc hp,dip_evlmon hp);
         hp := dip_mred hp
      >>;
      if hp then
         return cgp_mk(nhp,hp,cgp_sugar p,cgp_number p,'unknown);
      return cgp_zero()
   end;

procedure cgp_cancelmev(p,ev);
   % CGP cancel monomoial ev's. [p] is a CGP; [ev] is an EV. Returns a
   % CGP. Cancels all monomials in f which are multiples of [ev].
   cgp_mk(cgp_hp p,dip_cancelmev(cgp_rp p,ev),
      cgp_sugar p,cgp_number p,cgp_ci p);

procedure cgp_bcquot(p,c);
   % CGP base coefficient procuct. [p] is a CGP; [c] is a BC. Returns
   % a CGP. Computes $(1/[c])[p]$.
   cgp_mk(dip_bcquot(cgp_hp p,c),dip_bcquot(cgp_rp p,c),
      cgp_sugar p,cgp_number p,cgp_ci p);

procedure cgp_bcprod(p,c);
   % CGP base coefficient procuct. [p] is a CGP; [c] is a BC. Returns
   % a CGP. Computes $[c][p]$.
   cgp_mk(dip_bcprod(cgp_hp p,c),dip_bcprod(cgp_rp p,c),
      cgp_sugar p,cgp_number p,cgp_ci p);

procedure cgp_simpdcont(p);
   % CGP simplify domain content. [p] is a CGP. Returns a CGP $p'$
   % such that $p'$ is primitive as a multivariate polynomial over Z
   % and there is an integer $c$ such that $[p]=cp'$.
   begin scalar c;
      if cgp_zerop p then
          return p;
      c := cgp_dcont p;
      if bc_minus!? cgp_rlbc p then
         c := bc_neg c;
      return cgp_mk(dip_bcquot(cgp_hp p,c),dip_bcquot(cgp_rp p,c),
               cgp_sugar p,cgp_number p,cgp_ci p)
   end;

procedure cgp_rlbc(p);
   % CGP real leading base coefficient. [p] is a CGP. Returns a BC,
   % the coefficient of the largest term in both the head polynomial
   % and the rest polynomial part.
   if cgp_zerop p then
      bc_fd 0
   else if cgp_hp p then
      dip_lbc cgp_hp p
   else
      cgp_lbc p;

procedure cgp_dcont(p);
   % CGP domain content. [p] is a CGP. Returns a BC, the domain
   % content of [p], i.e. the content of [p] considered as an
   % multivariate polynomial over Z.
   begin scalar c;
      c := dip_dcont cgp_hp p;
      if bc_one!? c then
         return c;
      return dip_dcont1(cgp_rp p,c)
   end;

procedure cgp_normalize(u);
   % CGP normalize. [u] is a CGP. Returns a unique representation of
   % [u] as a CGP.
   cgp_mk(nil,dip_append(cgp_hp u,cgp_rp u),nil,nil,'unknown);

procedure cgp_green(u);
   % CGP green. [u] is A CGP. Returns a green CGP, i.e. a CGP in which
   % the green head part is cancelled.
   cgp_mk(nil,cgp_rp u,nil,nil,'green_colored);

procedure cgp_lsort(pl);
   % CGP list sort. pl is a list of CGP's. Returns a list of CGP's.
   sort(pl,function cgp_comp);

procedure cgp_comp(p1,p2);
   dip_comp(cgp_rp p1,cgp_rp p2);

endmodule;  % cgp

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/bcint.red0000644000175000017500000000642311526203062023037 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: bcint.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 1999-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(bcint_rcsid!* bcint_copyright!*);
   bcint_rcsid!* := "$Id: bcint.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   bcint_copyright!* := "Copyright (c) 1999-2009 A. Dolzmann and T. Sturm"
>>;

module bcint;
% Implementation of base coefficients using integers.

procedure bc_zero();
   0;

procedure bc_zero!?(u);
   eqn(u,0);

procedure bc_abs(u);
   abs u;

procedure bc_one!?(u);
   eqn(u,1);

procedure bc_2sq(u);
   simp u;

procedure bc_a2bc(u);
   % Converts the algebraic (kernel) u into a base coefficient.
   u;

procedure bc_fd(a);
   a;

procedure bc_neg(u);
   % Base coefficient negative. u is a base coefficient. bc_neg(u)
   % returns the negative of the base coefficient u, a base
   % coefficient.
   -u;

procedure bc_prod(a,b);
   if eqn(a,1) then
      b
   else if eqn(b,1) then
      a
   else
      times2(a,b);

procedure bc_quot(a,b);
   if eqn(b,1) then
      a
   else
      quotientx(a,b);

procedure bc_sum(a,b);
   % Base coefficient sum. u and v are base coefficients. bcsum(u,v)
   % calculates u+v and returns a base coefficient.
   if eqn(a,0) then
      b
   else if eqn(b,0) then
      a
   else
      plus2(a,b);

procedure bc_pmon(var,dg);
   % Parameter monomial.
   rederr "parametric coefficients not supported over bcint";

procedure bc_minus!?(u);
   % Boolean function. Returns true if u is a negative base coeff.
   u < 0;

procedure bc_2a(u);
   % Returns the prefix equivalent of the base coefficient u.
   u;

procedure bc_gcd(u,v);
   gcdn(u,v);

procedure bc_mkat(op,bc);
   {op,numr simp bc,nil};

procedure bc_dcont(bc);
   bc;

procedure bc_2d(bc);
   bc;

procedure bc_vars(bc);
   nil;

endmodule;  % bcint

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/cgb/gbsc.red0000644000175000017500000002267211526203062022662 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: gbsc.red 84 2009-02-07 07:53:22Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2003-2009 Andreas Dolzmann and Lorenz Gilch
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(gbsc_rcsid!* gbsc_copyright!*);
   gbsc_rcsid!* := "$Id: gbsc.red 84 2009-02-07 07:53:22Z thomas-sturm $";
   gbsc_copyright!* := "Copyright (c) 2003-2009 A. Dolzmann and L. Gilch"
>>;

module gbsc;
% Groebner bases combined structure constants.

fluid '(!*cgbverbose cgb_hashsize!*);

procedure gbsc_strconst(rt,gb,n);
   % Parametric real root counting structure constant. [rt] is a list
   % of TERM's; [gb] is a list of VDP's; [n] is an integer. Returns a
   % BETA, containing the generalized combined structure constants.
   begin scalar w,g,ul,beta; integer l;
      ul := reversip vdp_lsort gbsc_vdpsetprod(rt,n);
      beta := gbsc_betainit();
      if !*cgbverbose then <<
         l := length ul;
         ioto_tprin2t "Combined structure constants:"
      >>;
      for each u in ul do <<
         if !*cgbverbose then <<
            if remainder(l,10) = 0 then
               ioto_prin2 {"[",l,"] "};
            l := l - 1
         >>;
         if u member rt then
            for each v in rt do
               beta := gbsc_betaset(beta,u,v,if u=v then simp 1 else simp 0)
         else if (w := gbsc_hmmember(u,gb)) then <<
            %g := car w;
            g := gb_reduce(u,gb);
            for each v in rt do
               beta := gbsc_betaset(beta,u,v,
                  %negsq quotsq(gbsc_getlincombc(v,g),vdp_lbc g))
		  gbsc_getlincombc(v,g))
         >>
         else <<
            w := gbsc_goodfctr(u,rt);
            for each v in rt do
               beta := gbsc_betaset(beta,u,v,
                  gbsc_sumbeta(beta,car w,cdr w,v,rt))
         >>
      >>;
      if !*cgbverbose then
         ioto_prin2t "done";
      return beta
   end;

procedure gbsc_vdpsetprod(vdpl,n);
   % Parametric real root countig VDP set product. [vdpl] is a list of
   % VDP's. Returns a list of VDP's $v_1 v_2... v_n$ with $v_i$ in
   % $[vdpl]$.
   begin scalar prodl;
      if n = 1 then
         return vdpl;
      for each x in gbsc_vdpsetprod(vdpl,n-1) do
         for each y in vdpl do
            prodl := lto_insert(vdp_prod(x,y),prodl);
      return prodl
   end;

procedure gbsc_hmmember(u,gb);
   % Parametric real root counting head monomial member. [u] is a VDP
   % representing a monomial; [gb] is a list of VDP's. Returns [nil],
   % if there is no $f$ in [gb] with $[u]=HM(f)$ else returns a list
   % of VDP's such that $[u]=HM(g)$ for the first VDP $g$.
   begin scalar htu;
      htu := vdp_evlmon u;
      while gb and vdp_evlmon car gb neq htu do
         gb := cdr gb;
      return gb
   end;

procedure gbsc_getlincombc(b,p);
   % Parametric real root counting get linear combination coefficient.
   % [b] is a TERM an element of a basis of $K[X_1,...,X_n]/I$; [p] is
   % a VDP, an eleemnt of $K[X_1,...,X_n]/I$. Returns an SQ, the
   % coefficient of [b] in [p].
   begin scalar bt;
      b := vdp_poly b;
      p := vdp_poly p;
      bt := dip_evlmon b;
      while not null p and dip_evlmon p neq bt do
         p := dip_mred p;
      if null p then
         return simp 0;
      return bc_2sq dip_lbc p
   end;

procedure gbsc_goodfctr(u,rt);
   % Parametric real root counting good factorization. [u] is a VDP
   % representing a term; [rt] is a list of VDP's representing terms,
   % too. Write $[u]=u'X_i$ such that $u'$ is not in [rt]. Returns a
   % pair $(u' . X_i ) with $u'$ and $X_i$ are VDP's.
   begin scalar htu,fctr,cand,candt,n,i;
      htu := vdp_evlmon u;
      n := length htu;
      i := 1;
      while i <= n do <<
         candt := for each x in htu collect x;  % TODO: Muesste nach EV.
         if nth(candt,i) > 0 then <<
            nth(candt,i) := nth(candt,i) - 1;  % TODO; Muesste nach EV.
            cand := vdp_fmon(simp 1,candt);
            if not (cand member rt) then <<
               fctr := cand . vdp_fmon(simp 1,gbsc_mkvar(i,n));  % TODO Abbruch
               i := n + 1
            >>
         >>;
         i := i + 1
      >>;
      if i neq n + 2 then rederr {"bug in gbsc_goodfctr"};
      return fctr
   end;

procedure gbsc_mkvar(i,n);  % TODO nach EV.
   % Parametric real root counting make variable. [i] and [n] are
   % integers, such that [i] is between 1 and [n]. Returns an EV,
   % representing $X_1$ in the polynomial ring $K[X_1,...,X_n]$.
   begin scalar m;
      for j := 1:i-1 do
         m := 0 . m;
      m := 1 . m;
      for j := i+1:n do
         m := 0 . m;
      return reversip m
   end;

procedure gbsc_sumbeta(beta,up,xi,v,rt);
   % Parametric real root counting sum beta. [beta] is a BETA; [up],
   % [xi], and [a] are VDP's; [rt] is a list of VDP's. Returns a SQ,
   % the sum $sum_{w\in [rt], w<[up]}
   % \beta_{[up]w}}beta_{(w[xi])[v]}$.
   begin scalar res,betaupline;
      res := simp 0;
      betaupline := gbsc_betagetline(beta,up);
      for each w in rt do
         if ev_compless!?(vdp_evlmon w,vdp_evlmon up) then
            res := addsq(res,multsq(gbsc_betalineget(betaupline,w),
               gbsc_betaget(beta,vdp_prod(w,xi),v)));
      return res
   end;


% endmodule;

% module prrcbeta;

% Parametric real root counting beta. Implements an efficient data structue for
% storing generalized combined structure constants.

%DS BETA
% BETA represents a $m\times n% matrix indexed by TERM's. We organize
% BETA as an hashtable for all lines of beta. Each hash table entry is
% an alist mapping the line index to a matrix line. The matrix lines
% are simply organized as ALISTS, mapping the column index to the
% entry. All entries are SQ's. Note that in our case $m$ is
% $|RT(I)|^3$ and $n$ is $|RT(I)|$, and therefore we have in general
% $m>>n$.

procedure gbsc_betainit();
   % Parametric real root counting beta init. [m], [n] are INTEGERS;
   % Returns an empty BETA $\beta$.
   mkvect(cgb_hashsize!* - 1);

procedure gbsc_betaset(beta,u,v,sc);
   % Parametric real root counting beta set. [beta] is a BETA; [u] and
   % [v] are VDP's; [sc] is a SQ. Returns a BETA, the updated and
   % inplace modiefied [beta]. Stores the generalized combined
   % structure constant [sc] of [u] and [v] in [beta]. It is forbidden
   % to overwrite an existing entry in [beta].
   begin scalar w,i,slot;
      i := gbsc_hashfunction u;
      slot := getv(beta,i);
      if null slot then <<
         putv(beta,i,{u . {v . sc}});
         return beta
      >>;
      w := assoc(u,slot);
      if null w then <<
         putv(beta,i,(u . {v . sc}) . slot);
         return beta
      >>;
      if not assoc(v,cdr w) then
	 cdr w := (v . sc) . cdr w
      else
         rederr "bug in gbsc_betaset (gbsc_strconst)";
      return beta
   end;

procedure gbsc_hashfunction(term);
   % Parametric real root counting hash functions. [term] is a TERM.
   % Returns an integer between 0 and [cgb_hashsize!*].
   begin integer w;
      for each x in vdp_evlmon term do
         w := 10*w + x;  % TODO: remainder
      return remainder(w,cgb_hashsize!*)
   end;

procedure gbsc_betagetline(beta,u);
   % Parametric real root counting beta getline. [beta] is a BETA; [u]
   % is a VDP. Returns the line of [beta] which is indexed by [u].
   begin scalar w;
      w := assoc(u,getv(beta,gbsc_hashfunction u));
      if null w then rederr "bug in gbsc_betagetline";
      return cdr w
   end;

procedure gbsc_betalineget(betaline,v);
   % Parametric real root counting beta line get. [betaline] is a line
   % of a BETA; [v] is a VDP. Returns a SQ, the entry of betaline
   % indexed by [v].
   begin scalar w;
      w := atsoc(v,betaline);
      if null w then rederr "bug in gbsc_betalineget";
      return cdr w
   end;

procedure gbsc_betaget(beta,u,v);
   % Parametric real root counting betaget. [beta] is a BETA; [u] and
   % [v] are VDP's. Returns a SQ the entry of [beta] indexed by [u]
   % and [v].
   begin scalar w;
      w := assoc(u,getv(beta,gbsc_hashfunction u));
      if null w then rederr "bug in gbsc_betaget (1)";
      w := atsoc(v,cdr w);
      if null w then rederr "bug in gbsc_betaget (2)";
      return cdr w
   end;

endmodule;  [gbsc]

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/0000755000175000017500000000000011722677360022043 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrans.tst0000644000175000017500000001605511526203062024111 0ustar  giovannigiovanni% test file for ztrans package
% 
operator f;
operator g;
operator h;

% Examples for Z transformation
ztrans(1,n,z);
ztrans(a,n,z);
ztrans((-1)^n,n,z);
ztrans(n,n,z);
ztrans(n^2,n,z);
ztrans(n^k,n,z);
% should be output=input
ztrans((-1)^n*n^2,n,z);
ztrans(binomial(n,m),n,z);
ztrans((-1)^n*binomial(n,m),n,z);
ztrans(binomial(n+k,m),n,z);
ztrans(a^n,n,z);
ztrans(a^(n-1),n,z);
ztrans(a^(n+k),n,z);
ztrans((-1)^n*a^n,n,z);
ztrans(1-a^n,n,z);
ztrans(n*a^n,n,z);
ztrans(n^3*a^n,n,z);
ztrans(binomial(n,m)*a^n,n,z);
ztrans(1/(n+1),n,z);
ztrans(1/(n+2),n,z);
ztrans((-1)^(n)/(n+1),n,z);
ztrans((-1)^(n)/(n+2),n,z);
ztrans(a^(n-1)/(n+1),n,z);
ztrans(a^(n+k)/(n+1),n,z);
ztrans(a^n/factorial(n),n,z);
ztrans((n+1)*a^n/factorial(n),n,z);
ztrans(1/factorial(n-1),n,z);
% ERROR message o.k.
ztrans((-1)^n/factorial(2*n+1),n,z);
ztrans((-1)^n/factorial(2*n),n,z);
ztrans(1/factorial(2*n+1),n,z);
ztrans(1/factorial(2*n-1),n,z);
ztrans(1/factorial(2*n+3),n,z);
ztrans(1/factorial(2*n),n,z);
ztrans(1/factorial(2*n+2),n,z);
ztrans(a^n/factorial(2*n+1),n,z);
ztrans(a^n/factorial(2*n),n,z);
ztrans(e^(a*n),n,z);
ztrans(e^(a*(n+k)),n,z);
ztrans(sinh(a*n),n,z);
ztrans(cosh(a*n),n,z);
ztrans(sinh(a*n+p),n,z);
ztrans(cosh(a*n+p),n,z);
ztrans(a^n*sinh(a*n),n,z);
ztrans(a^n*cosh(a*n),n,z);
ztrans(n*sinh(a*n),n,z);
ztrans(n*cosh(a*n),n,z);
ztrans(n^2*a^n*sinh(b*n),n,z);
ztrans(sin(b*n),n,z);
ztrans(cos(b*n),n,z);
ztrans(sin(b*n+p),n,z);
ztrans(cos(b*n+p),n,z);
ztrans(e^(a*n)*sin(b*n),n,z);
ztrans(e^(a*n)*cos(b*n),n,z);
ztrans((-1)^n*e^(a*n)*sin(b*n),n,z);
ztrans((-1)^n*e^(a*n)*cos(b*n),n,z);
ztrans(n*sin(b*n),n,z);
ztrans(n*cos(b*n),n,z);
ztrans(n^2*a^n*sin(b*n),n,z);
ztrans(cos(b*(n+1))/(n+1),n,z);
ztrans(sin(b*(n+1))/(n+1),n,z);
ztrans(cos(b*(n+2))/(n+2),n,z);
ztrans((-1)^(n)*cos(b*(n+1))/(n+1),n,z);
ztrans((-1)^(n)*sin(b*(n+1))/(n+1),n,z);
ztrans(cos(b*n)/factorial(n),n,z);
ztrans(sin(b*n)/factorial(n),n,z);
ztrans(a*f(n)+b*g(n)+c*h(n),n,z);
ztrans(sum(f(k)*g(n-k),k,0,n),n,z);
ztrans(sum(f(k),k,0,n),n,z);
ztrans(sum(f(k),k,-2,n),n,z);
ztrans(sum(f(k),k,3,n),n,z);
ztrans(sum(f(k),k,0,n+2),n,z);
ztrans(sum(f(k),k,0,n-3),n,z);
ztrans(sum(f(k),k,-2,n+3),n,z);
ztrans(sum(1/factorial(k),k,0,n),n,z);
ztrans(sum(1/factorial(k+2),k,0,n),n,z);
ztrans(n^2*sum(1/factorial(k),k,0,n),n,z);
ztrans(sum(n^2/factorial(k),k,0,n),n,z);
ztrans(sum(1/k,k,0,n),n,z);
% ERROR o.k.
ztrans(sum(1/(k+1),k,0,n),n,z);
ztrans(sum(1/(k+3),k,0,n),n,z);
ztrans(f(n+k),n,z);
% output=input
ztrans(f(n+2),n,z);
ztrans(f(n-k),n,z);
% output=input
ztrans(f(n-3),n,z);
% output=input
ztrans(a^n*f(n),n,z);
ztrans(n*f(n),n,z);
ztrans(1/a^n,n,z);
ztrans(1/a^(n+1),n,z);
ztrans(1/a^(n-1),n,z);
ztrans(2*n+n^2-3/4*n^3,n,x);
ztrans(n^2*cos(n*x),n,z);
ztrans((1+n)^2*f(n),n,z);
ztrans(n^2*f(n),n,z);
ztrans(n/factorial(n),n,z);
ztrans(n^2/factorial(n),n,z);
ztrans(a^n/factorial(n),n,z);
ztrans(1/(a^n*factorial(n)),n,z);
ztrans(sum(f(k)*g(n-k),k,0,n),n,z);
ztrans(sum(f(k),k,0,n-1),n,z);
ztrans(sum(f(k),k,0,n),n,z);
ztrans(sum(1/factorial(k),k,0,n),n,z);
ztrans(sum(k/factorial(k),k,0,n),n,z);
ztrans(sum(a^k*k^2/factorial(k),k,0,n),n,z);
ztrans(a^n*f(n),n,z);
ztrans(binomial(n,k),n,z);
ztrans(1/(n+1),n,z);
ztrans(n/factorial(2*n+1),n,z);
ztrans(a^n*sin(n*x+y),n,z);
ztrans(n^3*sin(n*x+y),n,z);
ztrans((n+1)/factorial(n),n,z);
ztrans(factorial(n)/(factorial(k)*factorial(n-k)),n,z);

% Examples for inverse Z transformation
invztrans(z/(z-1),z,n);
invztrans(z/(z+1),z,n);
invztrans(z/(z-1)^2,z,n);
invztrans(z*(z+1)/(z-1)^3,z,n);
invztrans(z/(z-1)^m,z,n);
% invztrans(z/(z-1)^(m+1),z,n);
% not yet supported
invztrans(z/(z-1)^4,z,n);
invztrans((-1)^m*z/(z+1)^m,z,n);
% not yet supported
invztrans(z/(z+1)^4,z,n);
% invztrans(z^(k+1)/(z-1)^(m+1),z,n);
% not yet supported
invztrans(z^4/(z-1)^m,z,n);
% invztrans(z^4/(z-1)^(m+1),z,n);
% not yet supported
% invztrans(z^4/(z-1)^m,z,n);
% not yet supported
% invztrans(z^(k+1)/(z-1)^5,z,n);
% not yet supported
invztrans(z^3/(z-a)^4,z,n);
invztrans(z/(z-a),z,n);
invztrans(z/(z+a),z,n);
invztrans(z*(1-a)/((z-1)*(z-a)),z,n);
invztrans(z*a/(z-a)^2,z,n);
invztrans(z*3/(z-3)^2,z,n);
% invztrans(a^m*z/(z-a)^(m+1),z,n);
% not yet supported
% invztrans(a^m*z/(z-a)^m,z,n);
% not yet supported
% invztrans(4^m*z/(z-4)^(m+1),z,n);
% not yet supported
invztrans(a^3*z/(z-a)^5,z,n);
invztrans(z*log(z/(z-1)),z,n);
invztrans(z*log(1+1/z),z,n);
invztrans(z*log(z/(z-a)),z,n);
invztrans(e^(a/z),z,n);
invztrans(e^(1/(a*z)),z,n);
invztrans((1+a/z)*e^(a/z),z,n);
invztrans(e^(a/z)*(a+z)/z,z,n);
invztrans(sqrt(z)*sin(1/sqrt(z)),z,n);
invztrans(cos(1/sqrt(z)),z,n);
invztrans(sqrt(z)*sinh(1/sqrt(z)),z,n);
invztrans(cosh(1/sqrt(z)),z,n);
invztrans(sqrt(z/a)*sinh(sqrt(a/z)),z,n);
invztrans(cosh(sqrt(a/z)),z,n);
invztrans(z/(z-e^a),z,n);
invztrans(z*sinh(a)/(z^2-2*z*cosh(a)+1),z,n);
invztrans(z*(z-cosh(a))/(z^2-2*z*cosh(a)+1),z,n);
invztrans(z*(z*sinh(p)+sinh(a-p))/(z^2-2*z*cosh(a)+1),z,n);
% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*(z*cosh(p)-cosh(a-p))/(z^2-2*z*cosh(a)+1),z,n);
% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(a*z*sinh(a)/(z^2-2*a*z*cosh(a)+a^2),z,n);
invztrans(z*(z-a*cosh(a))/(z^2-2*a*z*cosh(a)+a^2),z,n);
invztrans(z*(z^2-1)*sinh(a)/(z^2-2*z*cosh(a)+1)^2,z,n);
% trigsimp(ws);
invztrans(z*((z^2+1)*cosh(a)-2*z)/(z^2-2*z*cosh(a)+1)^2,z,n);
invztrans(z*sin(b)/(z^2-2*z*cos(b)+1),z,n);
invztrans(z*(z-cos(b))/(z^2-2*z*cos(b)+1),z,n);
invztrans(z*(z*sin(p)+sin(b-p))/(z^2-2*z*cos(b)+1),z,n);
% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*(z*cos(p)-cos(b-p))/(z^2-2*z*cos(b)+1),z,n);
% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*e^(a)*sin(b)/(z^2-2*z*e^a*cos(b)+e^(2*a)),z,n);
invztrans(z*(z-e^a*cos(b))/(z^2-2*z*e^a*cos(b)+e^(2*a)),z,n);
invztrans(-z*e^a*sin(b)/(z^2+2*z*e^a*cos(b)+e^(2*a)),z,n);
invztrans(z*(z+e^a*cos(b))/(z^2+2*z*e^a*cos(b)+e^(2*a)),z,n);
invztrans(z*(z^2-1)*sin(b)/(z^2-2*z*cos(b)+1)^2,z,n);
% trigsimp(ws,expon);
% trigsimp(ws,trig);
invztrans(z*((z^2+1)*cos(b)-2*z)/(z^2-2*z*cos(b)+1)^2,z,n);
% trigsimp(ws,expon);
% trigsimp(ws,trig);
invztrans(z*log(z/sqrt(z^2-2*z*cos(b)+1)),z,n);
invztrans(z*atan(sin(b)/(z-cos(b))),z,n);
invztrans(z*log(sqrt(z^2+2*z*cos(b)+1)/z),z,n);
invztrans(z*atan(sin(b)/(z+cos(b))),z,n);
invztrans(cos(sin(b)/z)*e^(cos(b)/z),z,n);
invztrans(sin(sin(b)/z)*e^(cos(b)/z),z,n);
invztrans((f+a*z+b*z^2)/(c+d*z+e*z^2),z,n);

% Example 1 in Bronstein/Semendjajew, p. 651

f(0):=0;
f(1):=0;
f(2):=9;
f(3):=-2;
f(4):=23;
equation:=ztrans(f(n+5)-2*f(n+3)+2*f(n+2)-3*f(n+1)+2*f(n),n,z);
ztransresult:=solve(equation,ztrans(f(n),n,z));
result:=invztrans(part(first(ztransresult),2),z,n);

% Example 2 in Bronstein/Semendjajew, p. 651

clear(f);
operator f;
f(0):=0;
f(1):=1;
equation:=ztrans(f(n+2)-4*f(n+1)+3*f(n)-1,n,z);
ztransresult:=solve(equation,ztrans(f(n),n,z));
result:=invztrans(part(first(ztransresult),2),z,n);

% Other example:

clear(f);
operator f;
f(0):=1;
f(1):=1;
operator tmp;
equation:=ztrans((n+1)*f(n+1)-f(n),n,z);
equation:=sub(ztrans(f(n),n,z)=tmp(z),equation);
load_package odesolve;
oderesult:=odesolve(equation,tmp(z),z);
preresult:=invztrans(part(first(oderesult),2),z,n);
solveresult:=
solve({sub(n=0,preresult)=f(0),sub(n=1,preresult)=f(1)},arbconst(1));
result:=preresult where solveresult;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrans.hlp0000644000175000017500000001051511526203062024055 0ustar  giovannigiovanni\chapter{ZTRANS: $Z$-transform package}
\label{ZTRANS}
\typeout{{ZTRANS: $Z$-transform package}}

{\footnotesize
\begin{center}
Wolfram Koepf and Lisa Temme \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Takustrass 7 \\
D--14195 Berlin--Dahlem, Germany \\[0.05in]
e--mail: Koepf@zib.de
\end{center}
}
\ttindex{ZTRANS}

The $Z$-Transform of a sequence $\{f_n\}$ is the discrete analogue
of the Laplace Transform, and
\[{\cal Z}\{f_n\} = F(z) = \sum^\infty_{n=0} f_nz^{-n}\;.\] \\
This series converges in the region outside the circle 
$|z|=|z_0|= \limsup\limits_{n \rightarrow \infty} \sqrt[n]{|f_n|}\;.$
In the same way that a Laplace Transform can be used to
solve differential equations, so $Z$-Transforms can be used
to solve difference equations.

\begin{tabbing}

{\bf SYNTAX:}\ \ {\tt ztrans($f_n$, n,  z)}\ \ \ \ \ \ \ \
  \=where $f_n$ is an expression, and $n$,$z$ \\
  \> are identifiers.\\
\end{tabbing}
\ttindex{ztrans}

\begin{tabbing}
This pack\=age can compute the \= $Z$-Transforms of the \=following 
list of $f_n$, and \\ certain combinations thereof.\\ \\

\>$1$                             
\>$e^{\alpha n}$                  
\>$\frac{1}{(n+k)}$               \\ \\
\>$\frac{1}{n!}$                  
\>$\frac{1}{(2n)!}$               
\>$\frac{1}{(2n+1)!}$             \\ \\
\>$\frac{\sin(\beta n)}{n!}$      
\>$\sin(\alpha n+\phi)$           
\>$e^{\alpha n} \sin(\beta n)$    \\ \\
\>$\frac{\cos(\beta n)}{n!}$      
\>$\cos(\alpha n+\phi)$           
\>$e^{\alpha n} \cos(\beta n)$    \\ \\
\>$\frac{\sin(\beta (n+1))}{n+1}$ 
\>$\sinh(\alpha n+\phi)$          
\>$\frac{\cos(\beta (n+1))}{n+1}$ \\ \\
\>$\cosh(\alpha n+\phi)$          
\>${n+k \choose m}$\\
\end{tabbing}

\begin{tabbing}
\underline {{\bf Other Combinations}}\= \\ \\

\underline {Linearity}
  \>${\cal Z} \{a f_n+b g_n \} = a{\cal Z} \{f_n\}+b{\cal Z}\{g_n\}$
  \\ \\
\underline {Multiplication by $n$}
  \>${\cal Z} \{n^k \cdot f_n\} = -z \frac{d}{dz} \left({\cal Z}\{n^{k-1} \cdot f_n,n,z\} \right)$
  \\ \\
\underline {Multiplication by $\lambda^n$}
  \>${\cal Z} \{\lambda^n \cdot f_n\}=F \left(\frac{z}{\lambda}\right)$
  \\ \\
\underline {Shift Equation}
  \>${\cal Z} \{f_{n+k}\} = 
           z^k \left(F(z) - \sum\limits^{k-1}_{j=0} f_j z^{-j}\right)$
  \\ \\
\underline {Symbolic Sums}

  \> ${\cal Z} \left\{ \sum\limits_{k=0}^{n} f_k \right\} =
                       \frac{z}{z-1} \cdot {\cal Z} \{f_n\}$ \\ \\

  \>${\cal Z} \left\{ \sum\limits_{k=p}^{n+q} f_k \right\}$
  \ \ \ combination of the above \\ \\
  where $k$,$\lambda \in$ {\bf N}$- \{0\}$; and $a$,$b$ are variables
  or fractions; and $p$,$q \in$ {\bf Z} or \\ 
  are functions of $n$; and $\alpha$, $\beta$ and $\phi$ are angles 
  in radians.
\end{tabbing}


The calculation of the Laurent coefficients of a regular function
results in the following inverse formula for the $Z$-Transform:

If $F(z)$ is a regular function in the region $|z|> \rho$ then
$\exists$ a sequence \{$f_n$\} with ${\cal Z} \{f_n\}=F(z)$
given by \[f_n = \frac{1}{2 \pi i}\oint F(z) z^{n-1} dz\]

\begin{tabbing}

{\bf SYNTAX:}\ \ {\tt invztrans($F(z)$, z,  n)}\ \ \ \ \ \ \ \
  \=where $F(z)$ is an expression, \\
  \> and $z$,$n$ are identifiers.
\end{tabbing}
\ttindex{invztrans}

\begin{tabbing}
  This \= package can compute the Inverse \= Z-Transforms of any 
  rational function, \\ whose denominator can be factored over 
  ${\bf Q}$, in addition to the following list \\ of $F(z)$.\\ \\

\> $\sin \left(\frac{\sin (\beta)}{z} \ \right) 
    e^{\left(\frac{\cos (\beta)}{z} \ \right)}$
\> $\cos \left(\frac{\sin (\beta)}{z} \ \right) 
    e^{\left(\frac{\cos (\beta)}{z} \ \right)}$ \\ \\
\> $\sqrt{\frac{z}{A}} \sin \left( \sqrt{\frac{z}{A}} \ \right)$
\> $\cos \left( \sqrt{\frac{z}{A}} \ \right)$ \\ \\
\> $\sqrt{\frac{z}{A}} \sinh \left( \sqrt{\frac{z}{A}} \ \right)$
\> $\cosh \left( \sqrt{\frac{z}{A}} \ \right)$ \\ \\
\> $z \ \log \left(\frac{z}{\sqrt{z^2-A z+B}} \ \right)$
\> $z \ \log \left(\frac{\sqrt{z^2+A z+B}}{z} \ \right)$ \\ \\
\> $\arctan \left(\frac{\sin (\beta)}{z+\cos (\beta)} \ \right)$
\\
\end{tabbing}

here $k$,$\lambda \in$ {\bf N}$ -  \{0\}$ and $A$,$B$ are fractions
or variables ($B>0$) and $\alpha$,$\beta$, \&  $\phi$ are angles 
in radians.

Examples:
\begin{verbatim}
ztrans(sum(1/factorial(k),k,0,n),n,z);

  1/z
 e   *z
--------
 z - 1

invztrans(z/((z-a)*(z-b)),z,n);

  n    n
 a  - b
---------
  a - b
\end{verbatim}

mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrans.tex0000644000175000017500000002745111526203062024101 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\bf $Z$-Transform Package for {\tt REDUCE}}}
\author{Wolfram Koepf \\ Lisa Temme \\ email: {\tt Koepf@zib.de}}
\date{April 1995 : ZIB Berlin}
\begin{document}
\maketitle
\section{$Z$-Transform}

  The $Z$-Transform of a sequence $\{f_n\}$ is the discrete analogue
  of the Laplace Transform, and
  \[{\cal Z}\{f_n\} = F(z) = \sum^\infty_{n=0} f_nz^{-n}\;.\] \\
  This series converges in the region outside the circle 
  $|z|=|z_0|= \limsup\limits_{n \rightarrow \infty} \sqrt[n]{|f_n|}\;.$


\begin{tabbing}

{\bf SYNTAX:}\ \ {\tt ztrans($f_n$, n,  z)}\ \ \ \ \ \ \ \
  \=where $f_n$ is an expression, and $n$,$z$ \\
  \> are identifiers.\\
\end{tabbing}


\section{Inverse $Z$-Transform}
  The calculation of the Laurent coefficients of a regular function
  results in the following inverse formula for the $Z$-Transform:
  \\
  If $F(z)$ is a regular function in the region $|z|> \rho$ then
  $\exists$ a sequence \{$f_n$\} with ${\cal Z} \{f_n\}=F(z)$
  given by
  \[f_n = \frac{1}{2 \pi i}\oint F(z) z^{n-1} dz\]


\begin{tabbing}

{\bf SYNTAX:}\ \ {\tt invztrans($F(z)$, z,  n)}\ \ \ \ \ \ \ \
  \=where $F(z)$ is an expression, \\
  \> and $z$,$n$ are identifiers.
\end{tabbing}


\section{Input for the $Z$-Transform}
\begin{tabbing}
  This pack\=age can compute the \= $Z$-Transforms of the \=following 
  list of $f_n$, and \\ certain combinations thereof.\\ \\

\>$1$                             
\>$e^{\alpha n}$                  
\>$\frac{1}{(n+k)}$               \\ \\
\>$\frac{1}{n!}$                  
\>$\frac{1}{(2n)!}$               
\>$\frac{1}{(2n+1)!}$             \\ \\
\>$\frac{\sin(\beta n)}{n!}$      
\>$\sin(\alpha n+\phi)$           
\>$e^{\alpha n} \sin(\beta n)$    \\ \\
\>$\frac{\cos(\beta n)}{n!}$      
\>$\cos(\alpha n+\phi)$           
\>$e^{\alpha n} \cos(\beta n)$    \\ \\
\>$\frac{\sin(\beta (n+1))}{n+1}$ 
\>$\sinh(\alpha n+\phi)$          
\>$\frac{\cos(\beta (n+1))}{n+1}$ \\ \\
\>$\cosh(\alpha n+\phi)$          
\>${n+k \choose m}$\\
\end{tabbing}

\begin{tabbing}
\underline {{\bf Other Combinations}}\= \\ \\

\underline {Linearity}
  \>${\cal Z} \{a f_n+b g_n \} = a{\cal Z} \{f_n\}+b{\cal Z}\{g_n\}$
  \\ \\
\underline {Multiplication by $n$}
  \>${\cal Z} \{n^k \cdot f_n\} = -z \frac{d}{dz} \left({\cal Z}\{n^{k-1} \cdot f_n,n,z\} \right)$
  \\ \\
\underline {Multiplication by $\lambda^n$}
  \>${\cal Z} \{\lambda^n \cdot f_n\}=F \left(\frac{z}{\lambda}\right)$
  \\ \\
\underline {Shift Equation}
  \>${\cal Z} \{f_{n+k}\} = 
           z^k \left(F(z) - \sum\limits^{k-1}_{j=0} f_j z^{-j}\right)$
  \\ \\
\underline {Symbolic Sums}

  \> ${\cal Z} \left\{ \sum\limits_{k=0}^{n} f_k \right\} =
                       \frac{z}{z-1} \cdot {\cal Z} \{f_n\}$ \\ \\

  \>${\cal Z} \left\{ \sum\limits_{k=p}^{n+q} f_k \right\}$
  \ \ \ combination of the above \\ \\
  where $k$,$\lambda \in$ {\bf N}$- \{0\}$; and $a$,$b$ are variables
  or fractions; and $p$,$q \in$ {\bf Z} or \\ 
  are functions of $n$; and $\alpha$, $\beta$ \& $\phi$ are angles 
  in radians.
\end{tabbing}

\section{Input for the Inverse $Z$-Transform}
\begin{tabbing}
  This \= package can compute the Inverse \= Z-Transforms of any 
  rational function, \\ whose denominator can be factored over 
  ${\bf Q}$, in addition to the following list \\ of $F(z)$.\\ \\

\> $\sin \left(\frac{\sin (\beta)}{z} \ \right) 
    e^{\left(\frac{\cos (\beta)}{z} \ \right)}$
\> $\cos \left(\frac{\sin (\beta)}{z} \ \right) 
    e^{\left(\frac{\cos (\beta)}{z} \ \right)}$ \\ \\
\> $\sqrt{\frac{z}{A}} \sin \left( \sqrt{\frac{z}{A}} \ \right)$
\> $\cos \left( \sqrt{\frac{z}{A}} \ \right)$ \\ \\
\> $\sqrt{\frac{z}{A}} \sinh \left( \sqrt{\frac{z}{A}} \ \right)$
\> $\cosh \left( \sqrt{\frac{z}{A}} \ \right)$ \\ \\
\> $z \ \log \left(\frac{z}{\sqrt{z^2-A z+B}} \ \right)$
\> $z \ \log \left(\frac{\sqrt{z^2+A z+B}}{z} \ \right)$ \\ \\
\> $\arctan \left(\frac{\sin (\beta)}{z+\cos (\beta)} \ \right)$
\\
\end{tabbing}

  where $k$,$\lambda \in$ {\bf N}$ -  \{0\}$ and $A$,$B$ are fractions
  or variables ($B>0$) and $\alpha$,$\beta$, \&  $\phi$ are angles 
  in radians.

\section{Application of the $Z$-Transform}
\underline {{\bf Solution of difference equations}}\\

  In the same way that a Laplace Transform can be used to
  solve differential equations, so $Z$-Transforms can be used
  to solve difference equations.\\ \\
  Given a linear difference equation of $k$-th order
\begin{equation}
  f_{n+k} + a_1 f_{n+k-1}+ \ldots + a_k f_n = g_n
\label{eq:1}
\end{equation}

  with initial conditions
  $f_0 = h_0$, $f_1 = h_1$, $\ldots$, $f_{k-1} = h_{k-1}$ (where $h_j$
  are given), it is possible to solve it in the following way.
   If the coefficients $a_1, \ldots , a_k$ are constants, then the 
  $Z$-Transform of (\ref{eq:1}) can be calculated using the shift
  equation, and results in a solvable linear equation for 
  ${\cal Z} \{f_n\}$. Application of the Inverse $Z$-Transform
  then results in the solution of \ (\ref{eq:1}).\\
  If the coefficients $a_1, \ldots , a_k$ are polynomials in $n$ then
  the $Z$-Transform of (\ref{eq:1}) constitutes a differential
  equation for ${\cal Z} \{f_n\}$. If this differential equation can
  be solved then the Inverse $Z$-Transform once again yields the
  solution of (\ref{eq:1}).
  Some examples of these methods of solution can be found in
  $\S$\ref{sec:Examples}.

\section{EXAMPLES}
\label{sec:Examples}
\underline {{\bf Here are some examples for the $Z$-Transform}}\\
\begin{verbatim}
1: ztrans((-1)^n*n^2,n,z);

    z*( - z + 1)
---------------------
  3      2
 z  + 3*z  + 3*z + 1

2: ztrans(cos(n*omega*t),n,z);

   z*(cos(omega*t) - z)
---------------------------
                     2
 2*cos(omega*t)*z - z  - 1

3: ztrans(cos(b*(n+2))/(n+2),n,z);

                                 z
z*( - cos(b) + log(------------------------------)*z)
                                          2
                    sqrt( - 2*cos(b)*z + z  + 1)

4: ztrans(n*cos(b*n)/factorial(n),n,z);

  cos(b)/z       sin(b)                 sin(b)
 e        *(cos(--------)*cos(b) - sin(--------)*sin(b))
                   z                      z
---------------------------------------------------------
                            z
5: ztrans(sum(1/factorial(k),k,0,n),n,z);

  1/z
 e   *z
--------
 z - 1

6: operator f$

7: ztrans((1+n)^2*f(n),n,z);

                          2
df(ztrans(f(n),n,z),z,2)*z  - df(ztrans(f(n),n,z),z)*z 
+ ztrans(f(n),n,z)

\end{verbatim}

\underline {{\bf Here are some examples for the Inverse $Z$-Transform}}
\begin{verbatim}

8: invztrans((z^2-2*z)/(z^2-4*z+1),z,n);

              n       n                n
 (sqrt(3) - 2) *( - 1)  + (sqrt(3) + 2)
-----------------------------------------
                    2

9: invztrans(z/((z-a)*(z-b)),z,n);

  n    n
 a  - b
---------
  a - b

10: invztrans(z/((z-a)*(z-b)*(z-c)),z,n);

  n      n      n      n      n      n
 a *b - a *c - b *a + b *c + c *a - c *b
-----------------------------------------
  2      2        2      2    2        2
 a *b - a *c - a*b  + a*c  + b *c - b*c

11: invztrans(z*log(z/(z-a)),z,n);

  n
 a *a
-------
 n + 1

12: invztrans(e^(1/(a*z)),z,n);

        1
-----------------
  n
 a *factorial(n)

13: invztrans(z*(z-cosh(a))/(z^2-2*z*cosh(a)+1),z,n);

cosh(a*n)


\end{verbatim}

\underline {{\bf Examples: Solutions of Difference Equations}}\\ \\
\begin{tabbing}
{\bf I} \ \ \ \ \ \ \= 

  (See \cite{BS}, p.\ 651, Example 1).\\
  \> Consider the \= homogeneous linear difference equation\\ \\
  \>\>  $f_{n+5} - 2 f_{n+3} + 2 f_{n+2} - 3 f_{n+1} + 2 f_{n}=0$\\ \\

  \> with \ initial conditions \ $f_0=0$, $f_1=0$, $f_2=9$, $f_3=-2$,
     $f_4=23$. \  The\\
  \> $Z$-Transform of the left hand side can be written as
     $F(z)=P(z)/Q(z)$ \\
  \> where \ $P(z)=9z^3-2z^2+5z$ \ 
     and \ $Q(z)=z^5-2z^3+2z^2-3z+2$ \ $=$\\ 
  \> $(z-1)^2(z+2)(z^2+1)$, \ which can be inverted to give\\ \\

 \>\>  $f_n = 2n + (-2)^n - \cos \frac{\pi}{2}n\;.$ \\ \\

  \> The following REDUCE session shows how the present package can
\\ \> be used to solve the above problem.

\end{tabbing}
\begin{verbatim}
14: operator f$ f(0):=0$ f(1):=0$ f(2):=9$ f(3):=-2$ f(4):=23$


20: equation:=ztrans(f(n+5)-2*f(n+3)+2*f(n+2)-3*f(n+1)+2*f(n),n,z);

                              5                       3
equation := ztrans(f(n),n,z)*z  - 2*ztrans(f(n),n,z)*z

                                   2
             + 2*ztrans(f(n),n,z)*z  - 3*ztrans(f(n),n,z)*z

                                       3      2
             + 2*ztrans(f(n),n,z) - 9*z  + 2*z  - 5*z


21: ztransresult:=solve(equation,ztrans(f(n),n,z));

                                             2
                                       z*(9*z  - 2*z + 5)
ztransresult := {ztrans(f(n),n,z)=----------------------------}
                                    5      3      2
                                   z  - 2*z  + 2*z  - 3*z + 2

22: result:=invztrans(part(first(ztransresult),2),z,n);

                   n    n       n    n
           2*( - 2)  - i *( - 1)  - i  + 4*n
result := -----------------------------------
                          2

\end{verbatim}

\begin{tabbing}
\\ \\
{\bf II} \ \ \ \ \ \ \= 

  (See \cite{BS}, p.\ 651, Example 2).\\
  \>    Consider the \= inhom\=ogeneous difference equation:\\ \\
  \>\>  $f_{n+2} - 4 f_{n+1} + 3 f_{n} = 1$\\ \\

  \> with initial conditions $f_0=0$, $f_1=1$. Giving  \\ \\
\>\> $F(z)$\>$ = {\cal Z}\{1\} \left( \frac{1}{z^2-4z+3} + \frac{z}{z^2-4z+3} \right)$\\ \\
\>\>\>       $ = \frac{z}{z-1} \left( \frac{1}{z^2-4z+3} + \frac{z}{z^2-4z+3} \right)$.
\\ \\
  \> The Inverse $Z$-Transform results in the solution\\ \\


\>\>
$f_n = \frac{1}{2} \left( \frac{3^{n+1}-1}{2}-(n+1) \right)$.\\ \\

  \> The following REDUCE session shows how the present package can\\
  \> be used to solve the above problem.

\end{tabbing}
\begin{verbatim}

23: clear(f)$ operator f$ f(0):=0$ f(1):=1$


27: equation:=ztrans(f(n+2)-4*f(n+1)+3*f(n)-1,n,z);

                               3                       2
equation := (ztrans(f(n),n,z)*z  - 5*ztrans(f(n),n,z)*z  

                                                           2
    + 7*ztrans(f(n),n,z)*z - 3*ztrans(f(n),n,z) - z )/(z - 1)

28: ztransresult:=solve(equation,ztrans(f(n),n,z));

                                      2
                                     z
result := {ztrans(f(n),n,z)=---------------------}
                              3      2
                             z  - 5*z  + 7*z - 3

29: result:=invztrans(part(first(ztransresult),2),z,n);

              n
           3*3  - 2*n - 3
result := ----------------
                 4
\end{verbatim}

\begin{tabbing}
\\ \\
{\bf III} \ \ \ \ \ \ \= 

    Consider the \=following difference equation, which has a
    differential\\
 \> equation for ${\cal Z}\{f_n\}$.\\ \\

 \>\> $(n+1) \cdot f_{n+1}-f_n=0$\\ \\

 \> with initial conditions $f_0=1$, $f_1=1$. It can be solved in REDUCE\\
 \>  using the present package in the following way.\\

\end{tabbing}
\begin{verbatim}
30: clear(f)$ operator f$ f(0):=1$ f(1):=1$


34: equation:=ztrans((n+1)*f(n+1)-f(n),n,z);

                                        2
equation :=  - (df(ztrans(f(n),n,z),z)*z  + ztrans(f(n),n,z))

35: operator tmp;

36: equation:=sub(ztrans(f(n),n,z)=tmp(z),equation);

                              2
equation :=  - (df(tmp(z),z)*z  + tmp(z))

37: load(odesolve);

38: ztransresult:=odesolve(equation,tmp(z),z);

                         1/z
ztransresult := {tmp(z)=e   *arbconst(1)}

39: preresult:=invztrans(part(first(ztransresult),2),z,n);

              arbconst(1)
preresult := --------------
              factorial(n)

40: solve({sub(n=0,preresult)=f(0),sub(n=1,preresult)=f(1)},
arbconst(1));

{arbconst(1)=1}

41: result:=preresult where ws;

                1
result := --------------
           factorial(n)

\end{verbatim}

\begin{thebibliography}{9}
\bibitem{BS} Bronstein, I.N. and Semedjajew, K.A.,
{\it Taschenbuch der Mathematik},
Verlag Harri Deutsch, Thun und Frankfurt(Main),
 1981.\\ISBN 3 87144 492 8.
\end{thebibliography}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrans.red0000644000175000017500000000530011526203062024040 0ustar  giovannigiovannimodule ztrans; % Calculation of Z transformation and inverse.

% Authors: Wolfram Koepf, Lisa Temme.
% Version 1.0, April 1995.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% ZTRANS: Z transformation, see
% Bronstein, Semendjajew: Taschenbuch der Mathematik, 4.4.4

create!-package('(ztrans ztrrules),'(contrib misc));

flag('(ztrrules),'lap);

fluid '(!*precise);

!*precise := nil;   % Needed for this module at the moment.

% auxiliary functions


symbolic procedure newrederr(u);
   <>;

symbolic procedure newrederr1(u);
     if not atom u and atom car u and cdr u and atom cadr u
        and null cddr u
       then <>
      else maprin u;

flag('(newrederr),'opfn);


%********************************************************************

%Ztrans procedure

algebraic operator ztrans_aux;
algebraic operator !~f,!~g,!~summ,binomial;

algebraic procedure ztrans(f,n,z);
 begin
 scalar tmp,!*factor,!*exp;
   off factor;
   tmp := ztrans_aux(f,n,z);
   if part(tmp,0)=ztrans_aux then
     << on factor;
        tmp := ztrans_aux(f,n,z);
        off factor;
     >>;
   if part(tmp,0)=ztrans_aux then
       return lisp mk!*sq((list((car fkern list('ztrans,f,n,z) . 1)
                                                   . 1)) . 1)
     else return tmp;
 end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrans.rlg0000644000175000017500000006324611527635055024103 0ustar  giovannigiovanniFri Feb 18 21:28:55 2011 run on win32

*** binomial already defined as operator 

*** ~f already defined as operator 
% test file for ztrans package
% 
operator f;


operator g;


operator h;



% Examples for Z transformation
ztrans(1,n,z);


   z
-------
 z - 1

ztrans(a,n,z);


  a*z
-------
 z - 1

ztrans((-1)^n,n,z);


   z
-------
 z + 1

ztrans(n,n,z);


      z
--------------
  2
 z  - 2*z + 1

ztrans(n^2,n,z);


      z*(z + 1)
---------------------
  3      2
 z  - 3*z  + 3*z - 1

ztrans(n^k,n,z);


        k
ztrans(n ,n,z)

% should be output=input
ztrans((-1)^n*n^2,n,z);


    z*( - z + 1)
---------------------
  3      2
 z  + 3*z  + 3*z + 1

ztrans(binomial(n,m),n,z);


        z
------------------
        m
 (z - 1) *(z - 1)

ztrans((-1)^n*binomial(n,m),n,z);


          z
---------------------
           m
 ( - z - 1) *(z + 1)

ztrans(binomial(n+k,m),n,z);


        k
       z *z
------------------
        m
 (z - 1) *(z - 1)

ztrans(a^n,n,z);


  - z
-------
 a - z

ztrans(a^(n-1),n,z);


    - z
-----------
 a*(a - z)

ztrans(a^(n+k),n,z);


     k
  - a *z
---------
  a - z

ztrans((-1)^n*a^n,n,z);


   z
-------
 a + z

ztrans(1-a^n,n,z);


    z*(a - 1)
------------------
            2
 a*z - a - z  + z

ztrans(n*a^n,n,z);


       a*z
-----------------
  2            2
 a  - 2*a*z + z

ztrans(n^3*a^n,n,z);


              2            2
        a*z*(a  + 4*a*z + z )
-------------------------------------
  4      3        2  2        3    4
 a  - 4*a *z + 6*a *z  - 4*a*z  + z

ztrans(binomial(n,m)*a^n,n,z);


         m
      - a *z
------------------
        m
 (z - a) *(a - z)

ztrans(1/(n+1),n,z);


       z
log(-------)*z
     z - 1

ztrans(1/(n+2),n,z);


          z
z*(log(-------)*z - 1)
        z - 1

ztrans((-1)^(n)/(n+1),n,z);


          z
 - log(-------)*z
        z + 1

ztrans((-1)^(n)/(n+2),n,z);


          z
z*(log(-------)*z + 1)
        z + 1

ztrans(a^(n-1)/(n+1),n,z);


       - z
 log(-------)*z
      a - z
----------------
        2
       a

ztrans(a^(n+k)/(n+1),n,z);


  k       - z
 a *log(-------)*z
         a - z
-------------------
         a

ztrans(a^n/factorial(n),n,z);


 a/z
e

ztrans((n+1)*a^n/factorial(n),n,z);


  a/z
 e   *(a + z)
--------------
      z

ztrans(1/factorial(n-1),n,z);


                                           1
***** ERROR: zero divisor in sum(---------------------,n,0,infinity)
                                   n
                                  z *factorial(n - 1)

% ERROR message o.k.
ztrans((-1)^n/factorial(2*n+1),n,z);


                1
sqrt(z)*sin(---------)
             sqrt(z)

ztrans((-1)^n/factorial(2*n),n,z);


        1
cos(---------)
     sqrt(z)

ztrans(1/factorial(2*n+1),n,z);


                 1
sqrt(z)*sinh(---------)
              sqrt(z)

ztrans(1/factorial(2*n-1),n,z);


                1
ztrans(--------------------,n,z)
        factorial(2*n - 1)

ztrans(1/factorial(2*n+3),n,z);


                    1
z*(sqrt(z)*sinh(---------) - 1)
                 sqrt(z)

ztrans(1/factorial(2*n),n,z);


         1
cosh(---------)
      sqrt(z)

ztrans(1/factorial(2*n+2),n,z);


            1
z*(cosh(---------) - 1)
         sqrt(z)

ztrans(a^n/factorial(2*n+1),n,z);


               sqrt(a)
 sqrt(z)*sinh(---------)
               sqrt(z)
-------------------------
         sqrt(a)

ztrans(a^n/factorial(2*n),n,z);


      sqrt(a)
cosh(---------)
      sqrt(z)

ztrans(e^(a*n),n,z);


   - z
--------
  a
 e  - z

ztrans(e^(a*(n+k)),n,z);


     a*k
  - e   *z
-----------
   a
  e  - z

ztrans(sinh(a*n),n,z);


      - sinh(a)*z
----------------------
                2
 2*cosh(a)*z - z  - 1

ztrans(cosh(a*n),n,z);


   z*(cosh(a) - z)
----------------------
                2
 2*cosh(a)*z - z  - 1

ztrans(sinh(a*n+p),n,z);


  - z*(sinh(a - p) + sinh(p)*z)
--------------------------------
                     2
      2*cosh(a)*z - z  - 1

ztrans(cosh(a*n+p),n,z);


 z*(cosh(a - p) - cosh(p)*z)
-----------------------------
                   2
    2*cosh(a)*z - z  - 1

ztrans(a^n*sinh(a*n),n,z);


      - sinh(a)*a*z
-------------------------
                  2    2
 2*cosh(a)*a*z - a  - z

ztrans(a^n*cosh(a*n),n,z);


    z*(cosh(a)*a - z)
-------------------------
                  2    2
 2*cosh(a)*a*z - a  - z

ztrans(n*sinh(a*n),n,z);


                                 2
                     sinh(a)*z*(z  - 1)
------------------------------------------------------------
          2  2              3                  4      2
 4*cosh(a) *z  - 4*cosh(a)*z  - 4*cosh(a)*z + z  + 2*z  + 1

ztrans(n*cosh(a*n),n,z);


                           2
               z*(cosh(a)*z  + cosh(a) - 2*z)
------------------------------------------------------------
          2  2              3                  4      2
 4*cosh(a) *z  - 4*cosh(a)*z  - 4*cosh(a)*z + z  + 2*z  + 1

ztrans(n^2*a^n*sinh(b*n),n,z);


                          2  4  2            2  2  4               3  3    6
(sinh(b)*a*z*( - 4*cosh(b) *a *z  - 4*cosh(b) *a *z  + 16*cosh(b)*a *z  + a

                    4  2      2  4    6              4  4  4             3  5  3
               - 5*a *z  - 5*a *z  + z ))/(16*cosh(b) *a *z  - 32*cosh(b) *a *z

                3  3  5             2  6  2             2  4  4
    - 32*cosh(b) *a *z  + 24*cosh(b) *a *z  + 48*cosh(b) *a *z

                2  2  6              7                 5  3               3  5
    + 24*cosh(b) *a *z  - 8*cosh(b)*a *z - 24*cosh(b)*a *z  - 24*cosh(b)*a *z

                   7    8      6  2      4  4      2  6    8
    - 8*cosh(b)*a*z  + a  + 4*a *z  + 6*a *z  + 4*a *z  + z )

ztrans(sin(b*n),n,z);


      - sin(b)*z
---------------------
               2
 2*cos(b)*z - z  - 1

ztrans(cos(b*n),n,z);


   z*(cos(b) - z)
---------------------
               2
 2*cos(b)*z - z  - 1

ztrans(sin(b*n+p),n,z);


  - z*(sin(b - p) + sin(p)*z)
------------------------------
                   2
     2*cos(b)*z - z  - 1

ztrans(cos(b*n+p),n,z);


 z*(cos(b - p) - cos(p)*z)
---------------------------
                  2
    2*cos(b)*z - z  - 1

ztrans(e^(a*n)*sin(b*n),n,z);


          a
       - e *sin(b)*z
---------------------------
    a             2*a    2
 2*e *cos(b)*z - e    - z

ztrans(e^(a*n)*cos(b*n),n,z);


         a
     z*(e *cos(b) - z)
---------------------------
    a             2*a    2
 2*e *cos(b)*z - e    - z

ztrans((-1)^n*e^(a*n)*sin(b*n),n,z);


          a
       - e *sin(b)*z
---------------------------
    a             2*a    2
 2*e *cos(b)*z + e    + z

ztrans((-1)^n*e^(a*n)*cos(b*n),n,z);


         a
     z*(e *cos(b) + z)
---------------------------
    a             2*a    2
 2*e *cos(b)*z + e    + z

ztrans(n*sin(b*n),n,z);


                               2
                    sin(b)*z*(z  - 1)
---------------------------------------------------------
         2  2             3                 4      2
 4*cos(b) *z  - 4*cos(b)*z  - 4*cos(b)*z + z  + 2*z  + 1

ztrans(n*cos(b*n),n,z);


                         2
              z*(cos(b)*z  + cos(b) - 2*z)
---------------------------------------------------------
         2  2             3                 4      2
 4*cos(b) *z  - 4*cos(b)*z  - 4*cos(b)*z + z  + 2*z  + 1

ztrans(n^2*a^n*sin(b*n),n,z);


                        2  4  2           2  2  4              3  3    6
(sin(b)*a*z*( - 4*cos(b) *a *z  - 4*cos(b) *a *z  + 16*cos(b)*a *z  + a

                   4  2      2  4    6             4  4  4            3  5  3
              - 5*a *z  - 5*a *z  + z ))/(16*cos(b) *a *z  - 32*cos(b) *a *z

               3  3  5            2  6  2            2  4  4            2  2  6
    - 32*cos(b) *a *z  + 24*cos(b) *a *z  + 48*cos(b) *a *z  + 24*cos(b) *a *z

                7                5  3              3  5               7    8
    - 8*cos(b)*a *z - 24*cos(b)*a *z  - 24*cos(b)*a *z  - 8*cos(b)*a*z  + a

         6  2      4  4      2  6    8
    + 4*a *z  + 6*a *z  + 4*a *z  + z )

ztrans(cos(b*(n+1))/(n+1),n,z);


                  z
log(------------------------------)*z
                           2
     sqrt( - 2*cos(b)*z + z  + 1)

ztrans(sin(b*(n+1))/(n+1),n,z);


           sin(b)
 - atan(------------)*z
         cos(b) - z

ztrans(cos(b*(n+2))/(n+2),n,z);


                                 z
z*( - cos(b) + log(------------------------------)*z)
                                          2
                    sqrt( - 2*cos(b)*z + z  + 1)

ztrans((-1)^(n)*cos(b*(n+1))/(n+1),n,z);


                       2    3
        sqrt(2*cos(b)*z  + z  + 1)
 - log(----------------------------)*z
                 sqrt(z)

ztrans((-1)^(n)*sin(b*(n+1))/(n+1),n,z);


        sin(b)
atan(------------)*z
      cos(b) + z

ztrans(cos(b*n)/factorial(n),n,z);


 cos(b)/z      sin(b)
e        *cos(--------)
                 z

ztrans(sin(b*n)/factorial(n),n,z);


 cos(b)/z      sin(b)
e        *sin(--------)
                 z

ztrans(a*f(n)+b*g(n)+c*h(n),n,z);


ztrans(f(n),n,z)*a + ztrans(g(n),n,z)*b + ztrans(h(n),n,z)*c

ztrans(sum(f(k)*g(n-k),k,0,n),n,z);


ztrans(f(n),n,z)*ztrans(g(n),n,z)

ztrans(sum(f(k),k,0,n),n,z);


 ztrans(f(n),n,z)*z
--------------------
       z - 1

ztrans(sum(f(k),k,-2,n),n,z);


                                2
(z*( - f(-1)*z + f(-1) - f(-2)*z  + f(-2) + ztrans(f(n - 2),n,z)

                             2
     + ztrans(f(n - 2),n,z)*z  - ztrans(f(n - 2),n,z)))/(z - 1)

ztrans(sum(f(k),k,3,n),n,z);


                          2                     2
  - f(2) - f(1)*z - f(0)*z  + ztrans(f(n),n,z)*z
--------------------------------------------------
                    z*(z - 1)

ztrans(sum(f(k),k,0,n+2),n,z);


                             2                                               2
(z*( - f(1)*z + f(1) - f(0)*z  + f(0) + ztrans(f(n),n,z) + ztrans(f(n),n,z)*z

     - ztrans(f(n),n,z)))/(z - 1)

ztrans(sum(f(k),k,0,n-3),n,z);


                   2                     2
 ztrans(f(n),n,z)*z  - ztrans(f(n),n,z)*z  + ztrans(f(n),n,z)
--------------------------------------------------------------
                           2
                          z *(z - 1)

ztrans(sum(f(k),k,-2,n+3),n,z);


                             2                3                 4
(z*( - f(2)*z + f(2) - f(1)*z  + f(1) - f(0)*z  + f(0) - f(-1)*z  + f(-1)

              5                                                        5
     - f(-2)*z  + f(-2) + ztrans(f(n - 2),n,z) + ztrans(f(n - 2),n,z)*z

     - ztrans(f(n - 2),n,z)))/(z - 1)

ztrans(sum(1/factorial(k),k,0,n),n,z);


  1/z
 e   *z
--------
 z - 1

ztrans(sum(1/factorial(k+2),k,0,n),n,z);


  2   1/z
 z *(e   *z - z - 1)
---------------------
        z - 1

ztrans(n^2*sum(1/factorial(k),k,0,n),n,z);


  1/z     3      2
 e   *(2*z  + 2*z  - 3*z + 1)
------------------------------
       3      2
   z*(z  - 3*z  + 3*z - 1)

ztrans(sum(n^2/factorial(k),k,0,n),n,z);


  1/z     3      2
 e   *(2*z  + 2*z  - 3*z + 1)
------------------------------
       3      2
   z*(z  - 3*z  + 3*z - 1)

ztrans(sum(1/k,k,0,n),n,z);


                                   1
***** ERROR: zero divisor in sum(------,n,0,infinity)
                                   n
                                  z *n

% ERROR o.k.
ztrans(sum(1/(k+1),k,0,n),n,z);


        z      2
 log(-------)*z
      z - 1
-----------------
      z - 1

ztrans(sum(1/(k+3),k,0,n),n,z);


  2           z      2
 z *(2*log(-------)*z  - 2*z - 1)
            z - 1
----------------------------------
            2*(z - 1)

ztrans(f(n+k),n,z);


ztrans(f(k + n),n,z)

% output=input
ztrans(f(n+2),n,z);


z*( - f(1) - f(0)*z + ztrans(f(n),n,z)*z)

ztrans(f(n-k),n,z);


ztrans(f( - k + n),n,z)

% output=input
ztrans(f(n-3),n,z);


ztrans(f(n - 3),n,z)

% output=input
ztrans(a^n*f(n),n,z);


               z
ztrans(f(n),n,---)
               a

ztrans(n*f(n),n,z);


 - df(ztrans(f(n),n,z),z)*z

ztrans(1/a^n,n,z);


   a*z
---------
 a*z - 1

ztrans(1/a^(n+1),n,z);


    z
---------
 a*z - 1

ztrans(1/a^(n-1),n,z);


   2
  a *z
---------
 a*z - 1

ztrans(2*n+n^2-3/4*n^3,n,x);


            2
      x*(9*x  - 28*x + 1)
--------------------------------
     4      3      2
 4*(x  - 4*x  + 6*x  - 4*x + 1)

ztrans(n^2*cos(n*x),n,z);


               3  4           3  2           6             4             2
(z*( - 4*cos(x) *z  + 4*cos(x) *z  + cos(x)*z  + 9*cos(x)*z  - 9*cos(x)*z

                   5                   4  4            3  5            3  3
     - cos(x) - 4*z  + 4*z))/(16*cos(x) *z  - 32*cos(x) *z  - 32*cos(x) *z

               2  6            2  4            2  2             7              5
    + 24*cos(x) *z  + 48*cos(x) *z  + 24*cos(x) *z  - 8*cos(x)*z  - 24*cos(x)*z

                 3                 8      6      4      2
    - 24*cos(x)*z  - 8*cos(x)*z + z  + 4*z  + 6*z  + 4*z  + 1)

ztrans((1+n)^2*f(n),n,z);


                          2
df(ztrans(f(n),n,z),z,2)*z  - df(ztrans(f(n),n,z),z)*z + ztrans(f(n),n,z)

ztrans(n^2*f(n),n,z);


z*(df(ztrans(f(n),n,z),z,2)*z + df(ztrans(f(n),n,z),z))

ztrans(n/factorial(n),n,z);


  1/z
 e
------
  z

ztrans(n^2/factorial(n),n,z);


  1/z
 e   *(z + 1)
--------------
       2
      z

ztrans(a^n/factorial(n),n,z);


 a/z
e

ztrans(1/(a^n*factorial(n)),n,z);


 1/(a*z)
e

ztrans(sum(f(k)*g(n-k),k,0,n),n,z);


ztrans(f(n),n,z)*ztrans(g(n),n,z)

ztrans(sum(f(k),k,0,n-1),n,z);


 ztrans(f(n),n,z)
------------------
      z - 1

ztrans(sum(f(k),k,0,n),n,z);


 ztrans(f(n),n,z)*z
--------------------
       z - 1

ztrans(sum(1/factorial(k),k,0,n),n,z);


  1/z
 e   *z
--------
 z - 1

ztrans(sum(k/factorial(k),k,0,n),n,z);


  1/z
 e
-------
 z - 1

ztrans(sum(a^k*k^2/factorial(k),k,0,n),n,z);


  a/z
 e   *a*(a + z)
----------------
   z*(z - 1)

ztrans(a^n*f(n),n,z);


               z
ztrans(f(n),n,---)
               a

ztrans(binomial(n,k),n,z);


        z
------------------
        k
 (z - 1) *(z - 1)

ztrans(1/(n+1),n,z);


       z
log(-------)*z
     z - 1

ztrans(n/factorial(2*n+1),n,z);


                  1                 1
 sqrt(z)*cosh(---------) - sinh(---------)*z
               sqrt(z)           sqrt(z)
---------------------------------------------
                  2*sqrt(z)

ztrans(a^n*sin(n*x+y),n,z);


  - z*(sin(x - y)*a + sin(y)*z)
--------------------------------
                     2    2
     2*cos(x)*a*z - a  - z

ztrans(n^3*sin(n*x+y),n,z);


            3         4           2             4           2             2
(z*(8*cos(x) *sin(y)*z  + 4*cos(x) *sin(x - y)*z  - 4*cos(x) *sin(x - y)*z

                2         5            2         3                        5
     + 16*cos(x) *sin(y)*z  - 16*cos(x) *sin(y)*z  + 8*cos(x)*sin(x - y)*z

                                                6                     4
     - 8*cos(x)*sin(x - y)*z + 2*cos(x)*sin(y)*z  - 36*cos(x)*sin(y)*z

                         2               6                  4                  2
     + 10*cos(x)*sin(y)*z  + sin(x - y)*z  - 23*sin(x - y)*z  + 23*sin(x - y)*z

                              5              3                          4  4
     - sin(x - y) - 8*sin(y)*z  + 32*sin(y)*z  - 8*sin(y)*z))/(16*cos(x) *z

               3  5            3  3            2  6            2  4
    - 32*cos(x) *z  - 32*cos(x) *z  + 24*cos(x) *z  + 48*cos(x) *z

               2  2             7              5              3
    + 24*cos(x) *z  - 8*cos(x)*z  - 24*cos(x)*z  - 24*cos(x)*z  - 8*cos(x)*z

       8      6      4      2
    + z  + 4*z  + 6*z  + 4*z  + 1)

ztrans((n+1)/factorial(n),n,z);


  1/z
 e   *(z + 1)
--------------
      z

ztrans(factorial(n)/(factorial(k)*factorial(n-k)),n,z);


        z
------------------
        k
 (z - 1) *(z - 1)


% Examples for inverse Z transformation
invztrans(z/(z-1),z,n);


      2*n
( - 1)

invztrans(z/(z+1),z,n);


      n
( - 1)

invztrans(z/(z-1)^2,z,n);


n

invztrans(z*(z+1)/(z-1)^3,z,n);


 2
n

invztrans(z/(z-1)^m,z,n);


       2*n
 ( - 1)   *binomial(n,m - 1)
-----------------------------
                2*m
          ( - 1)

% invztrans(z/(z-1)^(m+1),z,n);
% not yet supported
invztrans(z/(z-1)^4,z,n);


     2
 n*(n  - 3*n + 2)
------------------
        6

invztrans((-1)^m*z/(z+1)^m,z,n);


                 m
           ( - 1) *z
invztrans(-----------,z,n)
                  m
           (z + 1)

% not yet supported
invztrans(z/(z+1)^4,z,n);


       n        2
 ( - 1) *n*( - n  + 3*n - 2)
-----------------------------
              6

% invztrans(z^(k+1)/(z-1)^(m+1),z,n);
% not yet supported
invztrans(z^4/(z-1)^m,z,n);


       2*n
 ( - 1)   *binomial(n + 3,m - 1)
---------------------------------
                  2*m
            ( - 1)

% invztrans(z^4/(z-1)^(m+1),z,n);
% not yet supported
% invztrans(z^4/(z-1)^m,z,n);
% not yet supported
% invztrans(z^(k+1)/(z-1)^5,z,n);
% not yet supported
invztrans(z^3/(z-a)^4,z,n);


  n     2
 a *n*(n  + 3*n + 2)
---------------------
         6*a

invztrans(z/(z-a),z,n);


 n
a

invztrans(z/(z+a),z,n);


 n       n
a *( - 1)

invztrans(z*(1-a)/((z-1)*(z-a)),z,n);


    n
 - a  + 1

invztrans(z*a/(z-a)^2,z,n);


 n
a *n

invztrans(z*3/(z-3)^2,z,n);


 n
3 *n

% invztrans(a^m*z/(z-a)^(m+1),z,n);
% not yet supported
% invztrans(a^m*z/(z-a)^m,z,n);
% not yet supported
% invztrans(4^m*z/(z-4)^(m+1),z,n);
% not yet supported
invztrans(a^3*z/(z-a)^5,z,n);


  n     3      2
 a *n*(n  - 6*n  + 11*n - 6)
-----------------------------
            24*a

invztrans(z*log(z/(z-1)),z,n);


       2*n
 ( - 1)
-----------
   n + 1

invztrans(z*log(1+1/z),z,n);


       n
 ( - 1)
---------
  n + 1

invztrans(z*log(z/(z-a)),z,n);


  n       2*n
 a *( - 1)   *a
----------------
     n + 1

invztrans(e^(a/z),z,n);


       n
      a
--------------
 factorial(n)

invztrans(e^(1/(a*z)),z,n);


        1
-----------------
  n
 a *factorial(n)

invztrans((1+a/z)*e^(a/z),z,n);


   n
  a *(n + 1)
--------------
 factorial(n)

invztrans(e^(a/z)*(a+z)/z,z,n);


   n
  a *(n + 1)
--------------
 factorial(n)

invztrans(sqrt(z)*sin(1/sqrt(z)),z,n);


            n
      ( - 1)
--------------------
 factorial(2*n + 1)

invztrans(cos(1/sqrt(z)),z,n);


          n
    ( - 1)
----------------
 factorial(2*n)

invztrans(sqrt(z)*sinh(1/sqrt(z)),z,n);


         1
--------------------
 factorial(2*n + 1)

invztrans(cosh(1/sqrt(z)),z,n);


       1
----------------
 factorial(2*n)

invztrans(sqrt(z/a)*sinh(sqrt(a/z)),z,n);


          n
         a
--------------------
 factorial(2*n + 1)

invztrans(cosh(sqrt(a/z)),z,n);


        n
       a
----------------
 factorial(2*n)

invztrans(z/(z-e^a),z,n);


 a*n
e

invztrans(z*sinh(a)/(z^2-2*z*cosh(a)+1),z,n);


sinh(a*n)

invztrans(z*(z-cosh(a))/(z^2-2*z*cosh(a)+1),z,n);


cosh(a*n)

invztrans(z*(z*sinh(p)+sinh(a-p))/(z^2-2*z*cosh(a)+1),z,n);


 cosh(a*n)*sinh(a)*sinh(p) + cosh(a)*sinh(a*n)*sinh(p) + sinh(a - p)*sinh(a*n)
-------------------------------------------------------------------------------
                                    sinh(a)

% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*(z*cosh(p)-cosh(a-p))/(z^2-2*z*cosh(a)+1),z,n);


( - cosh(a - p)*sinh(a*n) + cosh(a*n)*cosh(p)*sinh(a)

  + cosh(a)*cosh(p)*sinh(a*n))/sinh(a)

% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(a*z*sinh(a)/(z^2-2*a*z*cosh(a)+a^2),z,n);


 n
a *sinh(a*n)

invztrans(z*(z-a*cosh(a))/(z^2-2*a*z*cosh(a)+a^2),z,n);


 n
a *cosh(a*n)

invztrans(z*(z^2-1)*sinh(a)/(z^2-2*z*cosh(a)+1)^2,z,n);


                  2
 sinh(a*n)*sinh(a) *n
----------------------
            2
     cosh(a)  - 1

% trigsimp(ws);
invztrans(z*((z^2+1)*cosh(a)-2*z)/(z^2-2*z*cosh(a)+1)^2,z,n);


cosh(a*n)*n

invztrans(z*sin(b)/(z^2-2*z*cos(b)+1),z,n);


sin(b*n)

invztrans(z*(z-cos(b))/(z^2-2*z*cos(b)+1),z,n);


cos(b*n)

invztrans(z*(z*sin(p)+sin(b-p))/(z^2-2*z*cos(b)+1),z,n);


 cos(b*n)*sin(b)*sin(p) + cos(b)*sin(b*n)*sin(p) + sin(b - p)*sin(b*n)
-----------------------------------------------------------------------
                                sin(b)

% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*(z*cos(p)-cos(b-p))/(z^2-2*z*cos(b)+1),z,n);


  - cos(b - p)*sin(b*n) + cos(b*n)*cos(p)*sin(b) + cos(b)*cos(p)*sin(b*n)
--------------------------------------------------------------------------
                                  sin(b)

% trigsimp(ws);
% trigsimp(ws,combine);
invztrans(z*e^(a)*sin(b)/(z^2-2*z*e^a*cos(b)+e^(2*a)),z,n);


 a*n
e   *sin(b*n)

invztrans(z*(z-e^a*cos(b))/(z^2-2*z*e^a*cos(b)+e^(2*a)),z,n);


 a*n
e   *cos(b*n)

invztrans(-z*e^a*sin(b)/(z^2+2*z*e^a*cos(b)+e^(2*a)),z,n);


 a*n       n
e   *( - 1) *sin(b*n)

invztrans(z*(z+e^a*cos(b))/(z^2+2*z*e^a*cos(b)+e^(2*a)),z,n);


 a*n       n
e   *( - 1) *cos(b*n)

invztrans(z*(z^2-1)*sin(b)/(z^2-2*z*cos(b)+1)^2,z,n);


            2
(sqrt(cos(b)  - 1)*sin(b)*n

                           2      n                        2      n
 *( - (cos(b) - sqrt(cos(b)  - 1))  + (cos(b) + sqrt(cos(b)  - 1)) ))/(2

           2
   *(cos(b)  - 1))

% trigsimp(ws,expon);
% trigsimp(ws,trig);
invztrans(z*((z^2+1)*cos(b)-2*z)/(z^2-2*z*cos(b)+1)^2,z,n);


                         2      n                        2      n
 n*((cos(b) - sqrt(cos(b)  - 1))  + (cos(b) + sqrt(cos(b)  - 1)) )
-------------------------------------------------------------------
                                 2

% trigsimp(ws,expon);
% trigsimp(ws,trig);
invztrans(z*log(z/sqrt(z^2-2*z*cos(b)+1)),z,n);


 cos(b*n + b)
--------------
    n + 1

invztrans(z*atan(sin(b)/(z-cos(b))),z,n);


 sin(b*n + b)
--------------
    n + 1

invztrans(z*log(sqrt(z^2+2*z*cos(b)+1)/z),z,n);


       n
 ( - 1) *cos(b*n + b)
----------------------
        n + 1

invztrans(z*atan(sin(b)/(z+cos(b))),z,n);


       n
 ( - 1) *sin(b*n + b)
----------------------
        n + 1

invztrans(cos(sin(b)/z)*e^(cos(b)/z),z,n);


   cos(b*n)
--------------
 factorial(n)

invztrans(sin(sin(b)/z)*e^(cos(b)/z),z,n);


   sin(b*n)
--------------
 factorial(n)

invztrans((f+a*z+b*z^2)/(c+d*z+e*z^2),z,n);


                     2      n                  2        n
(2*(sqrt( - 4*c*e + d ) + d) *sqrt( - 4*c*e + d )*( - 1) *a*c*e

                      2      n                  2        n
  - (sqrt( - 4*c*e + d ) + d) *sqrt( - 4*c*e + d )*( - 1) *b*c*d

                      2      n                  2        n
  - (sqrt( - 4*c*e + d ) + d) *sqrt( - 4*c*e + d )*( - 1) *d*e*f

                        2      n       n    2
  + 4*(sqrt( - 4*c*e + d ) + d) *( - 1) *b*c *e

                      2      n       n      2
  - (sqrt( - 4*c*e + d ) + d) *( - 1) *b*c*d

                        2      n       n    2
  - 4*(sqrt( - 4*c*e + d ) + d) *( - 1) *c*e *f

                      2      n       n  2
  + (sqrt( - 4*c*e + d ) + d) *( - 1) *d *e*f

                        2      n                  2
  - 2*(sqrt( - 4*c*e + d ) - d) *sqrt( - 4*c*e + d )*a*c*e

                      2      n                  2
  + (sqrt( - 4*c*e + d ) - d) *sqrt( - 4*c*e + d )*b*c*d

                      2      n                  2
  + (sqrt( - 4*c*e + d ) - d) *sqrt( - 4*c*e + d )*d*e*f

                        2      n    2                       2      n      2
  + 4*(sqrt( - 4*c*e + d ) - d) *b*c *e - (sqrt( - 4*c*e + d ) - d) *b*c*d

                        2      n    2                       2      n  2
  - 4*(sqrt( - 4*c*e + d ) - d) *c*e *f + (sqrt( - 4*c*e + d ) - d) *d *e*f)/(2

     n  n               2
   *e *2 *c*e*(4*c*e - d ))


% Example 1 in Bronstein/Semendjajew, p. 651

f(0):=0;


f(0) := 0

f(1):=0;


f(1) := 0

f(2):=9;


f(2) := 9

f(3):=-2;


f(3) := -2

f(4):=23;


f(4) := 23

equation:=ztrans(f(n+5)-2*f(n+3)+2*f(n+2)-3*f(n+1)+2*f(n),n,z);


                              5                       3                       2
equation := ztrans(f(n),n,z)*z  - 2*ztrans(f(n),n,z)*z  + 2*ztrans(f(n),n,z)*z

                                                              3      2
             - 3*ztrans(f(n),n,z)*z + 2*ztrans(f(n),n,z) - 9*z  + 2*z  - 5*z

ztransresult:=solve(equation,ztrans(f(n),n,z));


                                             2
                                       z*(9*z  - 2*z + 5)
ztransresult := {ztrans(f(n),n,z)=----------------------------}
                                    5      3      2
                                   z  - 2*z  + 2*z  - 3*z + 2

result:=invztrans(part(first(ztransresult),2),z,n);


               n       n           n  n    n
            - i *( - 1)  + 2*( - 1) *2  - i  + 4*n
result := -----------------------------------------
                              2


% Example 2 in Bronstein/Semendjajew, p. 651

clear(f);


operator f;


f(0):=0;


f(0) := 0

f(1):=1;


f(1) := 1

equation:=ztrans(f(n+2)-4*f(n+1)+3*f(n)-1,n,z);


                               3                       2
equation := (ztrans(f(n),n,z)*z  - 5*ztrans(f(n),n,z)*z  + 7*ztrans(f(n),n,z)*z

                                      2
              - 3*ztrans(f(n),n,z) - z )/(z - 1)

ztransresult:=solve(equation,ztrans(f(n),n,z));


                                            2
                                           z
ztransresult := {ztrans(f(n),n,z)=---------------------}
                                    3      2
                                   z  - 5*z  + 7*z - 3

result:=invztrans(part(first(ztransresult),2),z,n);


              n
           3*3  - 2*n - 3
result := ----------------
                 4


% Other example:

clear(f);


operator f;


f(0):=1;


f(0) := 1

f(1):=1;


f(1) := 1

operator tmp;


equation:=ztrans((n+1)*f(n+1)-f(n),n,z);


                                        2
equation :=  - (df(ztrans(f(n),n,z),z)*z  + ztrans(f(n),n,z))

equation:=sub(ztrans(f(n),n,z)=tmp(z),equation);


                              2
equation :=  - (df(tmp(z),z)*z  + tmp(z))

load_package odesolve;


*** airy_ai already defined as operator 

*** airy_bi already defined as operator 

*** ci already defined as operator 

*** si already defined as operator 

oderesult:=odesolve(equation,tmp(z),z);


                      1/z
oderesult := {tmp(z)=e   *arbconst(1)}

preresult:=invztrans(part(first(oderesult),2),z,n);


              arbconst(1)
preresult := --------------
              factorial(n)

solveresult:=
solve({sub(n=0,preresult)=f(0),sub(n=1,preresult)=f(1)},arbconst(1));


solveresult := {arbconst(1)=1}

result:=preresult where solveresult;


      1
--------------
 factorial(n)


end;


Time for test: 889 ms, plus GC time: 63 ms
@@@@@ Resources used: (1 11 72 2)
mathpiper-0.81f+svn4469+dfsg3/src/packages/ztrans/ztrrules.red0000644000175000017500000006307311526203062024424 0ustar  giovannigiovannimodule ztrrules;  % Ztrans ruleset.

% Author: Lisa Temme.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic <<
ztransrules := {
  ztrans_aux(1,~n,~z) => z/(z-1),

  ztrans_aux(BINOMIAL(~n+~~k,~m),~n,~z) => z^(k+1)/(z-1)^(m+1) when
                                       (freeof(k,n) and freeof(m,n)),

  ztrans_aux(factorial(~n)/(factorial(~n-~k)*factorial(~k)),~n,~z)
                        => ztrans(binomial(n,k),n,z) when freeof(k,n),

  ztrans_aux(1/(~n+~~k),~n,~z) => z^(k-1)*(z*log(z/(z-1))
                              - sum(1/((j+1)*z^j),j,0,k-2))
                              when (freeof(k,n) and fixp(k) and k>0),

  ztrans_aux(~a^(~n+~~k),~n,~z) => a^k*z/(z-a) when (freeof(a,n)
                               and freeof(k,n)),

  ztrans_aux(1/~a^(~n+~~k),~n,~z) => SUB(a=1/a,ztrans(a^(n+k),n,z))
                                 when (freeof(a,n) and freeof(k,n)),

  ztrans_aux(e^(~n*~~a),~n,~z) => -z/(e^a-z) when freeof(a,n),

  ztrans_aux(e^((~n+~~k)*~~a),~n,~z) => e^(a*k)*-z/(e^a-z)
                                   when (freeof(a,n) and freeof(k,n)),

  ztrans_aux(1/FACTORIAL(~n),~n,~z) => e^(1/z),

  ztrans_aux(1/FACTORIAL(2*~n+~~k),~n,~z) =>
                        z^((k-1)/2)*(SQRT(z)*SINH(1/SQRT(z))
                        - sum(1/(factorial(2*j+1)*z^j),j,0,(k-3)/2))
                        when (freeof(k,n) and fixp((k+1)/2) and k>0),

  ztrans_aux(1/FACTORIAL(2*~n+~~k),~n,~z) =>
                        z^(k/2)*(COSH(1/SQRT(z))
                        - sum(1/(factorial(2*j)*z^j),j,0,k/2-1))
                        when (freeof(k,n) and fixp(k/2) and k>=0),

  ztrans_aux((-1)^~n/FACTORIAL(2*~n+~~k),~n,~z) =>
                (-z)^((k-1)/2)*(SQRT(z)*SIN(1/SQRT(z))
                - sum((-1)^j/(factorial(2*j+1)*z^j),j,0,(k-3)/2))
                      when(freeof(k,n) and fixp((k+1)/2) and k>0),

  ztrans_aux((-1)^~n/FACTORIAL(2*~n+~~k),~n,~z) =>
                        (-z)^(k/2)*(COS(1/SQRT(z))
                        - sum((-1)^j/(factorial(2*j)*z^j),j,0,k/2-1))
                        when (freeof(k,n) and fixp(k/2) and k>=0),

  ztrans_aux(SINH(~~al*~n+~~p),~n,~z) => z*(z*SINH(p) + SINH(al-p))
                                   /(z^2 - 2*z*COSH(al) + 1)
                                   when (freeof(al,n) and freeof(p,n)),

  ztrans_aux(COSH(~~al*~n+~~p),~n,~z) => z*(z*COSH(p) - COSH(al-p))
                                   /(z^2 - 2*z*COSH(al) + 1)
                                   when (freeof(al,n) and freeof(p,n)),

  ztrans_aux(SIN(~~b*~n+~~p),~n,~z) =>  z*(z*SIN(p) + SIN(b-p))
                                   /(z^2 - 2*z*COS(b) + 1)
                                    when (freeof(b,n) and freeof(p,n)),

  ztrans_aux(COS(~~b*~n+~~p),~n,~z) =>  z*(z*COS(p) - COS(b-p))
                                   /(z^2 - 2*z*COS(b) + 1)
                                    when (freeof(b,n) and freeof(p,n)),

  ztrans_aux(e^(~~a*~n)*SIN(~~b*~n),~n,~z) =>
                            z*e^a*SIN(b)/(z^2-2*z*e^a*COS(b)+e^(2*a))
                                   when (freeof(a,n) and freeof(b,n)),

  ztrans_aux(e^(~~a*~n)*COS(~~b*~n),~n,~z) =>
                        z*(z-e^a*COS(b))/(z^2-2*z*e^a*COS(b)+e^(2*a))
                                   when (freeof(a,n) and freeof(b,n)),

  ztrans_aux(COS(~~b*(~n+~~k))/(~n+~~k),~n,~z) =>
                        z^(k-1)*(z*log(z/SQRT(z^2-2*z*COS(b)+1))
                        - sum(cos(b*(j+1))/((j+1)*z^j),j,0,k-2))
                        when (freeof(b,n) and freeof(k,n)
                                     and fixp(k) and k>0),

  ztrans_aux(SIN(~~b*(~n+~~k))/(~n+~~k),~n,~z) =>
                        z^(k-1)*(-z*ATAN(SIN(b)/(COS(b)-z))
                        - sum(sin(b*(j+1))/((j+1)*z^j),j,0,k-2))
                        when (freeof(b,n) and freeof(k,n)
                                     and fixp(k) and k>0),

  ztrans_aux((-1)^n*COS(~~b*(~n+~~k))/(~n+~~k),~n,~z) =>
                        -(-z)^(k-1)*(z*log(SQRT(z^2+2*z*COS(b)+1/z))
                        - sum((-1)^j*cos(b*(j+1))/((j+1)*z^j),j,0,k-2))
                        when (freeof(b,n) and freeof(k,n) and fixp(k)),

  ztrans_aux(COS(~~b*~n)/FACTORIAL(~n),~n,~z) =>
                                COS(SIN(b)/z)*e^(COS(b)/z)
                                when freeof(b,n),

  ztrans_aux(COS(~~b*(~n+~~k))/FACTORIAL(~n+~~k),~n,~z) =>
                        z^k*(COS(SIN(b)/z)*e^(COS(b)/z)
                        - sum(cos(b*j)/(factorial(j)*z^j),j,0,k-1))
                                     when (freeof(b,n) and fixp(k)),

  ztrans_aux(SIN(~~b*~n)/FACTORIAL(~n),~n,~z) =>
                                SIN(SIN(b)/z)*e^(COS(b)/z)
                                when freeof(b,n),

  ztrans_aux(SIN(~~b*(~n+~~k))/FACTORIAL(~n+~~k),~n,~z) =>
                        z^k*(SIN(SIN(b)/z)*e^(COS(b)/z)
                        - sum(sin(b*j)/(factorial(j)*z^j),j,0,k-1))
                                     when (freeof(b,n) and fixp(k)),

%LINEARITY
  ztrans_aux(-~f,~n,~z)   => -ztrans(f,n,z),
  ztrans_aux(~a,~n,~z)    => a*ztrans(1,n,z)   when freeof(a,n),
  ztrans_aux(~a*~f,~n,~z) => a*ztrans(f,n,z)   when freeof(a,n),
  ztrans_aux(~f/~b,~n,~z) => ztrans(f,n,z)/b   when freeof(b,n),
  ztrans_aux(~a/~g,~n,~z) => a*ztrans(1/g,n,z) when (freeof(a,n)
                                                    and not(a=1)),

  ztrans_aux(~a*~f/~g,~n,~z) => a*ztrans(f/g,n,z) when freeof(a,n),

  ztrans_aux(~f/(~b*~g),~n,~z) => ztrans(f/g,n,z)/b when freeof(b,n),

  ztrans_aux((~f+~g)/~~h,~n,~z) => ztrans(f/h,n,z) + ztrans(g/h,n,z),

%MULTIPLICATION
  ztrans_aux(~n^~~p*~~f,~n,~z) => -z*DF(ztrans(n^(p-1)*f,n,z),z)
                                  when freeof(p,n) and fixp(p) and p>0,

  ztrans_aux(~n^~~p*~~f/~g,~n,~z) => -z*DF(ztrans(n^(p-1)*f/g,n,z),z)
                                  when freeof(p,n) and fixp(p) and p>0,

%Shift up
  ztrans_aux(~f(~n+~k),~n,~z) =>
                        z^k*(ztrans(f(n),n,z)-SUM(f(n)*z^(-n),n,0,k-1))
                        when freeof(k,n) and fixp(k) and k>0,

  ztrans_aux(~f(~n+~k)/~g(~n+~k),~n,~z) =>
                        z^k*(ztrans(f(n)/g(n),n,z)-
                        SUM(f(n)/g(n)*z^(-n),n,0,k-1))
                        when freeof(k,n) and fixp(k) and k>0,

  ztrans_aux(1/~g(~n+~k),~n,~z) =>
                        z^k*(ztrans(1/g(n),n,z)-
                        SUM(1/g(n)*z^(-n),n,0,k-1))
                        when freeof(k,n) and fixp(k) and k>0,

%Similar Expressions
  ztrans_aux(~a^(~n+~~k)*~f,~n,~z) => a^k*SUB(z=(z/a),ztrans(f,n,z))
                                  when freeof(a,n) and freeof(k,n),

  ztrans_aux(~a^(~n+~~k)*~~f/~g,~n,~z) =>
                                    a^k*SUB(z=(z/a),ztrans(f/g,n,z))
                                    when freeof(a,n) and freeof(k,n),

  ztrans_aux(~a^(~n-~~k)*~~f/~g,~n,~z) =>
                                    a^k*SUB(z=(z/a),ztrans(f/g,n,z))
                                    when freeof(a,n) and freeof(k,n),

  ztrans_aux(1/~a^(~n+~~k)*~f,~n,~z) => 1/a^k*SUB(z=z*a,ztrans(f,n,z))
                                    when freeof(a,n) and freeof(k,n),

  ztrans_aux(1/~a^(~n+~~k)*~~f/~g,~n,~z) =>
                                    1/a^k*SUB(z=z*a,ztrans(f/g,n,z))
                                    when freeof(a,n) and freeof(k,n),

%Summations
  ztrans_aux(sum(~f(~k)*~g(~n-~k),~k,0,~n),~n,~z) =>
                                ztrans(f(n),n,z)*ztrans(g(n),n,z)
                                when freeof(k,n),

  ztrans_aux(~summ(~f,~k,0,~n),~n,~z) => z*ztrans(SUB(k=n,f),n,z)/(z-1)
                                     when freeof(k,n) and summ = sum,

%  ztrans_aux(~summ(~~f/~g,~k,0,~n),~n,~z) =>
%                                     z*ztrans(SUB(k=n,f/g),n,z)/(z-1)
%                                    when (freeof(k,n) and summ = sum),

  ztrans_aux(~summ(~f,~k,0,(~n+~w)),~n,~z) =>
                        z*ztrans(SUB(k=n,f),n,z)/(z-1) +
                        sum(z^x*(ztrans(SUB(k=n,f),n,z) -
                        sum(SUB(k=n,f)/z^n,n,0,x-1)),x,1,w)
                        when (freeof(w,n) and fixp(w) and w>0
                        and summ = sum),

%  ztrans_aux(~summ(~~f/~g,~k,0,(~n+~w)),~n,~z) =>
%                       z*ztrans(SUB(k=n,f/g),n,z)/(z-1) +
%                       sum(z^x*(ztrans(SUB(k=n,f/g),n,z) -
%                       sum(SUB(k=n,f/g)/z^n),n,0,(x-1)),x,1,w)
%                       when (freeof(w,n) and fixp(w) and w>0
%                       and summ = sum),

  ztrans_aux(~summ(~f,~k,~p,~n),~n,~z) =>
                        ztrans(sum(SUB(k=k+p,f),k,0,n-p),n,z)
                        when (freeof(p,n) and fixp(p) and p>0
                        and summ = sum),

  ztrans_aux(~summ(~f,~k,0,(~nn)),~n,~z) =>
                ztrans(SUB(k=n,f),n,z)/(z-1) -
                sum(1/z^y*ztrans(SUB(k=n,f),n,z),y,1,((n-nn)-1))
                when (freeof((nn-n),n) and fixp(nn-n) and
                (nn-n)<0 and summ = sum),

%  ztrans_aux(~summ(~~f/~g,~k,0,(~nn)),~n,~z) =>
%               ztrans(SUB(k=n,f/g),n,z)/(z-1) -
%               sum(1/z^y*ztrans(SUB(k=n,f/g),n,z),y,1,((n-nn)-1))
%               when (freeof((nn-n),n) and fixp (nn-n) and
%               (nn-n)<0 and summ = sum),

  ztrans_aux(~summ(~f,~k,~p,~n),~n,~z) =>
                        ztrans(sum(SUB(k=k+p,f),k,0,n+(-p)),n,z)
                        when (freeof(p,n) and fixp(p) and p<0
                        and summ = sum),

  ztrans_aux(~summ(~f,~k,~p,~q),~n,~z) =>
                        (begin scalar r;
                         r := q-p;
                         return ztrans(sum(SUB(k=k+p,f),k,0,r),n,z);
                         end)  when (not(p=0) and summ = sum),

%Errors
%======
  ztrans_aux(~~f/(~n+~~k),~n,~z) =>
        (begin
        newrederr{"ERROR: zero divisor in ",
                  sum(f/((n+k)*z^n),n,0,infinity)}
        end)
        when (numberp k and k<1),

  ztrans_aux(~~f/factorial(~n+~~k),~n,~z) =>
        (begin
        newrederr{"ERROR: zero divisor in "
                  ,sum(f/(factorial(n+k)*z^n),n,0,infinity)}
        end)
        when (numberp k and k<0)

}$

let ztransrules>>;

% INVZTRANS: inverse Z transformation, see
% Bronstein, Semendjajew: Taschenbuch der Mathematik, 4.4.4

load!-package 'residue;

%######################################################################

% Final simplification,
% by Wolfram Koepf
algebraic<<
ztranstrighypsimplificationrules:={
asin(sin(~xx))=>xx,
acos(cos(~xx))=>xx,
atan(tan(~xx))=>xx,
acot(cot(~xx))=>xx,
asinh(sinh(~xx))=>xx,
acosh(cosh(~xx))=>xx,
atanh(tanh(~xx))=>xx,
acoth(coth(~xx))=>xx,
(1-sin(~xx)^2)^(1/2)=>cos(xx),
(1-cos(~xx)^2)^(1/2)=>sin(xx),
(cosh(~xx)^2-1)^(1/2)=>sinh(xx),
(1+sinh(~xx)^2)^(1/2)=>cosh(xx),
(cosh(~xx)+sinh(~xx))^~nn=>cosh(nn*xx)+sinh(nn*xx),
(cosh(~xx)-sinh(~xx))^~nn=>cosh(nn*xx)-sinh(nn*xx)
} $

operator invztrans,invztrans_aux,invztrans1,invztrans_end;

% let {binomial(~n,~k)=>prod(n-i,i,0,k-1)/factorial(k) when fixp(k)};
let {binomial(~n,~k)=>
        (for i:=0:k-1 product n-i)/factorial(k) when fixp(k)};

>>;
% Procedural embedding,
% by Wolfram Koepf
algebraic procedure do_invztrans(f,z,n);
begin
scalar tmp,numtmp,dentmp;
   tmp := invztrans1(f,z,n);
   numtmp:=num(tmp);
   dentmp:=den(tmp);
   numtmp:=(numtmp where ztranstrighypsimplificationrules);
   dentmp:=(dentmp where ztranstrighypsimplificationrules);
   tmp:=numtmp/dentmp;
   % tmp:=sub(invztrans_end=invztrans,tmp);
   % macht Probleme wegen Rekursivitaet, next if has no part(.0)
   return tmp;
%   if part(tmp,0)=invztrans then
%       return lisp mk!*sq((list((car fkern list('invztrans,f,z,n) . 1)
%                                                 . 1)) . 1)
%   else return tmp;
end$


%********************************************************************

% invztrans ruleset
% by Lisa Temme

put('slash, 'simpfn, 'simpiden);

algebraic <<
invztransrules:=
{
%Linear rules
%============

  invztrans (~P,~z,~n) => !$do_invztrans!$
        when freeof((!$do_invztrans!$ :=
                          do_invztrans(P,z,n)),lisp 'fail),

  invztrans1(~P,~z,~n) => P*invztrans1(1,z,n)
                 when freeof(P,z) and not (p=1),

  invztrans1(~P*~f,~z,~n) => P*invztrans1(f,z,n) when freeof(P,z),

  invztrans1(~f/~Q,~z,~n) => invztrans1(f,z,n)/Q when freeof(Q,z),

  invztrans1(~P/~g,~z,~n) => P*invztrans1(1/g,z,n) when freeof(P,z)
                            and NOT(P=1),

  invztrans1(~P*~f/~g,~z,~n) => P*invztrans1(f/g,z,n) when freeof(P,z),

  invztrans1(~f/(~Q*~g),~z,~n) =>
                                invztrans1(f/g,z,n)/Q when freeof(Q,z),

  invztrans1(-~f,~z,~n) => -invztrans1(f,z,n),

  invztrans1((~f+~g)/~~h,~z,~n) =>
                             invztrans1(f/h,z,n) + invztrans1(g/h,z,n),


%**********************************************************************

%For trigonometric/hyperbolic rational
%input goto ruleset invztrans_aux
%=====================================

  invztrans1(~f/~g,~z,~n) => invztrans_aux(f,g,z,n)

        when ( NOT(freeof(f/g,sin))  OR NOT(freeof(f/g,cos)) OR
               NOT(freeof(f/g,sinh)) OR NOT(freeof(f/g,cosh)) ),


%If not a trig/hyperbolic rational
%input goto ruleset invztrans_end
%(ie. all remaining inputs)
%=================================

  invztrans1(~f,~z,~n) => invztrans_end(f,z,n)
%,


%  invztrans1(~f,~z,~n) =>
%   (begin
%    return lisp mk!*sq((list((car fkern list('invztrans1,reval 'f,
%                                             reval 'z,reval 'n) . 1)
%. 1)) . 1);
%   end)


};let invztransrules;


%######################################################################

invztrans_auxrules :=
{

%Linearity
%=========
  invztrans_aux(~f,-~~X*~z^2+~~W*~z-~Y,~z,~n) =>
                                -invztrans_aux(f,X*z^2-W*z+Y,z,n),

  invztrans_aux(~f+~h,~g,~z,~n) =>
                invztrans_aux(f,g,z,n) + invztrans_aux(h,g,z,n),


%Rules to match trigonometric/hyperbolic
%rational inputs.
%=======================================

  invztrans_aux(~z,(~~X*~z^2-~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            2*srY^n*SIN(ACOS(srX*W/(2*srY*X))*n)
            / ( srX^n*sqrt(4*X*Y-W^2) ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>0 and (W^2)<(4*X*Y))
        OR   (numberp(X) and numberp(W) and NOT(numberp(Y)) and W>0)
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))
              and freeof((W/X),cosh)),


  invztrans_aux(~z,(~~X*~z^2+~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            -2*srY^n*(-1)^n*SIN(ACOS(srX*W/(2*srY*X))*n)
            / ( srX^n*sqrt(4*X*Y-W^2) ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>0 and (W^2)<(4*X*Y))
        OR   (numberp(X) and numberp(W) and NOT(numberp(Y)) and W<0)
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))
              and freeof((W/X),cosh)),

  invztrans_aux(~z,(~~X*~z^2-~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            2*srY^n*SINH(ACOSH(srX*W/(2*srY*X))*n)
            / ( srX^n*sqrt(W^2-4*X*Y) ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and (W^2)>(4*X*Y))
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))),

  invztrans_aux(~z,(~~X*~z^2+~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            -2*(-srY)^n*SINH(ACOSH(srX*W/(2*srY*X))*n)
            / ( srX^n*sqrt(W^2-4*X*Y) ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and (W^2)>(4*X*Y))
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))),

  invztrans_aux(~z^2,(~~X*~z^2-~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            (srY^n*(sqrt(4*X*Y-W^2)*COS(ACOS(srX*W/(2*srY*X))*n)
            + SIN(ACOS(srX*W/(2*srY*X))*n)*W))
            / ( srX^n*sqrt(4*X*Y-W^2)*X ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>0 and (w^2)<(2*X*Y))
        OR   (numberp(X) and numberp(W) and W>0)
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))
              and freeof((W/X),cosh)),


  invztrans_aux(~z^2,(~~X*~z^2+~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            (srY^n*(-1)^n*(sqrt(4*X*Y-W^2)*COS(ACOS(srX*W/(2*srY*X))*n)
            + SIN(ACOS(srX*W/(2*srY*X))*n)*W))
            / ( srX^n*sqrt(4*X*Y-W^2)*X ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>0 and (W^2)>(4*X*Y))
        OR   (numberp(X) and numberp(W) and W<0)
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))
              and freeof((W/X),cosh)),


  invztrans_aux(~z^2,(~~X*~z^2-~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            (srY^n*(sqrt(W^2-4*X*Y)*COSH(ACOSH(srX*W/(2*srY*X))*n)
            + SINH(ACOSH(srX*W/(2*srY*X))*n)*W))
            / ( srX^n*sqrt(W^2-4*X*Y)*X ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>(4*X*Y))
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))),

  invztrans_aux(~z^2,(~~X*~z^2+~~W*~z+~Y),~z,~n) =>

        SUB(srX=sqrt(X), srW=sqrt(W), srY=sqrt(Y),
            ((-srY)^n*(sqrt(W^2-4*X*Y)*COSH(ACOSH(srX*W/(2*srY*X))*n)
            + SINH(ACOSH(srX*W/(2*srY*X))*n)*W))
            / ( srX^n*sqrt(W^2-4*X*Y)*X ) )

        when (numberp(X) and numberp(W) and numberp(Y) and
              Y>0 and W>(4*X*Y))
        OR   (NOT(numberp(X) and numberp(W) and numberp(Y))),

  invztrans_aux(~f,~g,~z,~n) => invztrans_end(f/g,z,n)

};let invztrans_auxrules;

%######################################################################

invztrans_endrules :=
{

%Rules to match other
%trigonometric inputs
%====================

  invztrans_end(~z*atan(SIN(~b)//(COS(~b)-~z)),~z,~n) =>
        -SIN(b*(n+1))/(n+1) when numberp(b)
     OR (freeof(b,z) and NOT(numberp(b))),

  invztrans_end(~z*atan(SIN(~b)//(~z+COS(~b))),~z,~n) =>
        (-1)^n*SIN(b*(n+1))/(n+1) when numberp(a)
     OR (freeof(a,z) and NOT(numberp(a))),

  invztrans_end(~z*log(~z/sqrt(~z^2-~a*~z+1)),~z,~n) =>
        COS(ACOS(a/2)*(n+1))/(n+1) when (numberp(a) and a>0 and a<=-2)
     OR (freeof(a,z) and NOT(numberp(a))),

  invztrans_end(~z*log(~z/sqrt(~z^2+~a*~z+1)),~z,~n) =>
        COS(ACOS(-a/2)*(n+1))/(n+1) when (numberp(a) and a<0 and a>=-2)
     OR (freeof(a,z) and NOT(numberp(a))),

  invztrans_end(~z*log(sqrt(~z^2-~a*~z+1)/~z),~z,~n) =>
       (-1)^n* COS(ACOS(-a/2)*(n+1))/(n+1)
        when (numberp(a) and a<0 and a>=-2)
     OR (freeof(a,z) and NOT(numberp(a))),

  invztrans_end(~z*log(sqrt(~z^2+~a*~z+1)/~z),~z,~n) =>
        (-1)^n*COS(ACOS(a/2)*(n+1))/(n+1)
        when (numberp(a) and a>0 and a<=-2)
     OR (freeof(a,z) and NOT(numberp(a))),

  invztrans_end(COS(~a/~z)*e^(sqrt(1-~a^2)/~z),~z,~n) =>
        COS(ASIN(a)*n)/factorial(n) when (numberp(a) and a<=1 and
       a>=-1)
     OR (freeof(a,z) and NOT(numberp(a))),

%**********************************************************************

%Rule to calculate the Residues and hence
%determine the invztrans of a rational input
%===========================================
% by Wolfram Koepf

  invztrans_end(~f,~z,~n)=>
        (begin scalar denominator, result, solutionset, solution,
          !*fullroots;
          on fullroots;
          denominator:=den(f);
          solution:=solve(denominator,z);
          if not freeof(solution,root_of) then
            rederr("denominator could not be factorized");
          solutionset:=
           for i:=1:length(solution) collect(part(part(solution,i),2));
          result:=
            for each a in solutionset sum(residue(f*z^(n-1),z,a));
          return(result)
        end) when type_ratpoly(f,z),

%**********************************************************************

%Rules to match non-rational inputs
%==================================

%(Binomial)
%----------
  invztrans(~z^~~k/(z+~~a)^~~m,~z,~n) =>
                binomial(n+k-1,m-1)*(-a)^(n+k)/(-a)^m
                when freeof(k,z) and freeof(m,z) and freeof(a,z) and
                     (NOT(numberp k) OR (numberp k and fixp k)) and
                     (NOT(numberp m) OR (numberp m and fixp m)),

%(over n!)
%---------

  invztrans_end(e^(~k/~z),~z,~n) => k^n/factorial(n) when freeof(k,z),

  invztrans_end(e^(~k/~z)/~z,~z,~n) =>
                                 n/k*k^n/factorial(n) when freeof(k,z),

  invztrans_end(1/e^(~k/~z),~z,~n) =>
                                  (-k)^n/factorial(n) when freeof(k,z),

  invztrans_end(1/(e^(~k/~z)*~z),~z,~n) =>
                             -n/k*(-k)^n/factorial(n) when freeof(k,z),

  invztrans_end(e^(~k/(~~j*~z)),~z,~n) =>
                 (k/j)^n/factorial(n) when freeof(k,z) and freeof(j,z),

  invztrans_end(e^(~k/(~~j*~z))/~z,~z,~n) =>
         n/(k/j)*(k/j)^n/factorial(n) when freeof(k,z) and freeof(j,z),

  invztrans_end(1/e^(~k/(~~j*~z)),~z,~n) =>
                (-k/j)^n/factorial(n) when freeof(k,z) and freeof(j,z),

  invztrans_end(1/(e^(~k/(~~j*~z))*~z),~z,~n) =>
       n/(-k/j)*(-k/j)^n/factorial(n) when freeof(k,z) and freeof(j,z),

  invztrans_end(cos(sin(~~b)/~z)*e^(cos(~~b)/~z),~z,~n) =>
                               cos(b*n)/factorial(n) when freeof (b,z),

  invztrans_end(sin(sin(~~b)/~z)*e^(cos(~~b)/~z),~z,~n) =>
                               sin(b*n)/factorial(n) when freeof (b,z),


%(over 2n!)
%----------

  invztrans_end(cosh(~k/sqrt(~z)),~z,~n) =>
                               k^(2*n)/factorial(2*n) when freeof(k,z),

  invztrans_end(cos(~k/sqrt(~z)),~z,~n) =>
                            (-(k^2))^n/factorial(2*n) when freeof(k,z),

  invztrans_end(cosh(~k/(~~j*sqrt(~z))),~z,~n) =>
           (k/j)^(2*n)/factorial(2*n) when freeof(k,z) and freeof(j,z),

  invztrans_end(cos(~k/(~~j*sqrt(~z))),~z,~n) =>
          (-(k/j)^2)^n/factorial(2*n) when freeof(k,z) and freeof(j,z),

%(over (2n+1)!)
%--------------

  invztrans_end(sqrt(~z)*sinh(~k/sqrt(~z)),~z,~n) =>
                          k*k^(2*n)/factorial(2*n+1) when freeof (k,z),

  invztrans_end(sqrt(~z)*sinh(~k/sqrt(-~z)),~z,~n) =>
                       i*k*(-k^2)*n/factorial(2*n+1) when freeof (k,z),

  invztrans_end(sqrt(~z)*sin(~k/sqrt(~z)),~z,~n) =>
                         k*(-k^2)^n/factorial(2*n+1) when freeof (k,z),

  invztrans_end(sqrt(-~z)*sinh(~k/sqrt(~z)),~z,~n) =>
                 sqrt(-k^2)*k^(2*n)/factorial(2*n+1) when freeof (k,z),

  invztrans_end(sqrt(-~z)*sin(~k/sqrt(~z)),~z,~n) =>
                 k*(-k^2)^n/(i*factorial(2*n+1)) when freeof (k,z),

  invztrans_end(sqrt(-~z)*sinh(~k/sqrt(-~z)),~z,~n) =>
                         k*(-k^2)*n/factorial(2*n+1) when freeof (k,z),

  invztrans_end(sqrt(-~z)*sin(~k/sqrt(~z)),~z,~n) =>
                k*(-k^2)*n/(i*factorial(2*n+1)) when freeof (k,z),


  invztrans_end(sqrt(~z)*sinh(~k/(~~j*sqrt(~z))),~z,~n) =>
                                    (k/j)*(k/j)^(2*n)/factorial(2*n+1)
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(-~z)*sinh(~k/(~~j*sqrt(~z))),~z,~n) =>
                                    (k/j)*(k/j)^(2*n)/factorial(2*n+1)
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(-~b*~z)*sinh(~k/(sqrt(~b)*sqrt(~z))),~z,~n) =>
                                 sqrt(-k^2)*(k^2/b)^n/factorial(2*n+1)
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(~z)*sin(~k/(~~j*sqrt(~z))),~z,~n) =>
                  (sqrt(-k^2)/j)*(-k^2)^n/j^(2*n)/(i*factorial(2*n+1))
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(-~z)*sin(~k/(~~j*sqrt(~z))),~z,~n) =>
                                (k/j)*(k/j)^(2*n)/(i*factorial(2*n+1))
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(-~b*~z)*sin(~k/(sqrt(~b)*sqrt(~z))),~z,~n) =>
                                     k*(-k^2/b)^n/(i*factorial(2*n+1))
                                     when freeof (k,z) and freeof(b,z),


  invztrans_end(sqrt(~z)*sinh(~k/(~~j*sqrt(-~z))),~z,~n) =>
                                  i*(k/j)*(k/j)^(2*n)/factorial(2*n+1)
                                     when freeof (k,z) and freeof(j,z),

  invztrans_end(sqrt(~z)*sin(~k/(~~j*sqrt(-~z))),~z,~n) =>
                  (sqrt(-k^2)/j)*(sqrt(-k^2)/j)^(2*n)/factorial(2*n+1)
                                     when freeof (k,z) and freeof(j,z),

%(over n+1)
%----------

  invztrans_end(~z*log(~~b*~z/(~~b*~z+~a)),~z,~n) =>
                   (-a/b)^(n+1)/(n+1) when freeof(a,z) and freeof(b,z),

  invztrans_end(~z*log((~~b*~z+~a)/(~~b*~z)),~z,~n) =>
                                   -invztrans1(z*log(b*z/(b*z+a)),z,n)
                                      when freeof(a,z) and freeof(b,z),


%If input has not matched any rules
%return INVZTRANS(~f,~z,~n)
%==================================

  invztrans_end(~f,~z,~n) =>  lisp 'fail


};let invztrans_endrules;
>>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/0000755000175000017500000000000011722677365022165 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.tex0000644000175000017500000063163611526203062024341 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{GENTRAN User's Manual \\ REDUCE Version}
\date{}
\author{Barbara L. Gates \\ RAND \\
Santa Monica CA 90407-2138 USA \\[0.05in]
{\em Updated for {\REDUCE} 3.4 by} \\[0.05in]
Michael C. Dewar \\
The University of Bath \\
Email: miked@nag.co.uk}
\begin{document}
\maketitle

\index{GENTRAN ! package} \index{GENTRAN package !}

\begin{center} February 1991 \end{center}

GENTRAN is an automatic code GENerator and TRANslator which runs under
REDUCE and VAXIMA\index{VAXIMA}.  It constructs complete numerical
programs based on sets of algorithmic specifications and symbolic
expressions.  Formatted FORTRAN, RATFOR or C code can be generated
through a series of interactive commands or under the control of a
template processing routine.  Large expressions can be automatically
segmented into subexpressions of manageable size, and a special
file-handling mechanism maintains stacks of open I/O channels to allow
output to be sent to any number of files simultaneously and to
facilitate recursive invocation of the whole code generation process.
GENTRAN provides the flexibility necessary to handle most code
generation applications.  This manual describes usage of the GENTRAN
package for REDUCE.

\subsection*{Acknowledgements}

The GENTRAN package was created at Kent State University to generate
numerical code for computations in finite element analysis.  I would
like to thank Prof. Paul Wang for his guidance and many suggestions
used in designing the original package for VAXIMA.

The second version of GENTRAN was implemented at Twente University of
Technology to run under REDUCE.  It was designed to be interfaced with
a code optimization facility created by Dr. J. A. van Hulzen.  I would
like to thank Dr. van Hulzen for all of his help in the implementation
of GENTRAN in RLISP during a stay at his university in The
Netherlands.

Finally, I would like to thank Dr. Anthony Hearn of the RAND
Corporation for his help in better integrating GENTRAN into the REDUCE
environment.

\section{INTRODUCTION}

Solving a problem in science or engineering is often a two-step
process.  First the problem is modeled mathematically and derived
symbolically to provide a set of formulas which describe how to solve
the problem numerically.  Next numerical programs are written based on
this set of formulas to efficiently compute specific values for given
sets of input.  Computer algebra systems such as REDUCE
provide powerful tools for use in the formula-derivation phase but
only provide primitive program-coding tools.  The GENTRAN 
package~\cite{Gates:85,Gates:85a,Gates:85b,Gates:86}
has been constructed to automate the tedious,
time consuming and error-prone task of writing numerical programs
based on a set of symbolic expressions.

\subsection{The GENTRAN Code Generator and Translator}
The GENTRAN code GENeration and TRANslation package, originally
implemented in Franz LISP to run under VAXIMA~\cite{Gates:84}, is now also
implemented in RLISP to run under REDUCE.  Although GENTRAN
was originally created specifically to generate numerical
code for use with an existing FORTRAN-based finite element analysis
package~\cite{Wang:86,Wang:84}, it was designed
to provide the flexibility required to handle most code generation
applications.  GENTRAN contains code generation commands, file-handling
commands, mode switches, and global variables, all of which are
accessible from both the algebraic and symbolic modes of REDUCE to
give the user maximal control over the code generation process.  Formatted
\index{FORTRAN} \index{RATFOR} \index{C}
FORTRAN~\cite{FORTRAN}, RATFOR~\cite{Kernighan:79}, C~\cite{Kernighan:78},
or PASCAL code can be generated from algorithmic specifications,
i.e., descriptions of the behaviour of the target numerical program expressed
in the REDUCE programming language, and from symbolically derived expressions
and formulas.

In addition to arithmetic expressions and assignment statements,
GENTRAN can also generate type declarations and control-flow
structures.  Code generation can be guided by user-supplied
template file(s) to insert generated code into pre-existing program
skeletons, or it can be accomplished interactively through a series
of translation commands without the use of template files.  Special
mode switches enable the user to turn on or off specific features such as
automatic segmentation of large expressions, and global variables
allow the user to modify the code formatting process.  Generated
code can be sent to one or more files and, optionally, to
the user's terminal.  Stacks of open I/O channels facilitate temporary
output redirection and recursive invocation of the code generation process.

\subsection{Code Optimization}
\index{optimization, code}
A code optimizer~\cite{vanHulzen:89}, which runs under REDUCE, has
been constructed to reduce the arithmetic complexity of a set of
symbolic expressions (see the SCOPE package on
page~\pageref{SCOPE:intro}).  It optimizes them by extracting common
subexpressions and assigning them to temporary variables which are
inserted in their places.  The optimization technique is based on
mapping the expressions onto a matrix of coefficients and exponents
which are searched for patterns corresponding to the common
subexpressions.  Due to this process the size of the expressions is
often considerably reduced.

GENTRAN and the Code Optimizer have been interfaced to make it
possible to generate optimized numerical programs directly
\index{GENTRANOPT switch} from REDUCE.  Setting the switch {\tt
GENTRANOPT} {\bf ON} specifies that all sequences of assignment
statements are to be optimized before being converted to numerical
code.

\subsection{Organization of the Manual}
The remainder of this manual is divided into five sections.  Sections
\ref{GENTRAN:inter} and \ref{GENTRAN:template} describe code
generation.  Section \ref{GENTRAN:inter} explains interactive code
generation, the expression segmentation facility, and how temporary
variables can be generated; then section \ref{GENTRAN:template}
explains how code generation can be guided by a user-supplied template
file.  Section \ref{GENTRAN:output} describes methods of output
redirection, and section \ref{GENTRAN:mod} describes user-accessible
global variables and mode switches which alter the code generation
process.  Finally section \ref{GENTRAN:examples} presents three
complete examples.

\subsubsection{Typographic Conventions}
The following conventions are used in the syntactic definitions of
commands in this manual:
\begin{itemize}
\item[{-}]
Command parts which must be typed exactly as shown are given in 
{\bf BOLD PRINT}.
\item[{-}]
User-supplied arguments are {\it emphasized}.
\item[{-}]
[ ... ] indicate optional command parts.
\end{itemize}
The syntax of each GENTRAN command is shown terminated with a {\bf ;}.
However, either {\bf ;} or {\bf \$} can be used to terminate any
command with the usual REDUCE meaning:  {\bf ;} indicates that the
returned value is to be printed, while {\bf \$} indicates that printing
of the returned value is to be suppressed.

Throughout this manual it is stated that file name arguments must be
atoms.  The exact type of atom (e.g., identifier or string) is
system and/or site dependent.  The instructions for the implementation
being used should therefore be consulted.

\section{Interactive Code Generation}\label{GENTRAN:inter}
GENTRAN generates numerical programs based on algorithmic specifications
in the REDUCE programming language and derived symbolic expressions
\index{FORTRAN} \index{RATFOR} \index{PASCAL} \index{C}
produced by REDUCE evaluations.  FORTRAN, RATFOR, PASCAL or C code can
be produced.  Type declarations can be generated, and comments and
other literal strings can be inserted into the generated code.  In
addition, large arithmetic expressions can be automatically segmented
into a sequence of subexpressions of manageable size.

This section explains how to select the target language, generate
code, control expression segmentation, and how to generate temporary
variable names.

\subsection{Target Language Selection}
\label{gentranlang}
Before generating code, the target numerical language must be
selected.  GENTRAN is currently able to generate FORTRAN, RATFOR,
PASCAL and C \ttindex{GENTRANLANG"!*} code.  The global variable {\bf
GENTRANLANG!*} determines which type of code is produced.  {\bf
GENTRANLANG!*} can be set in algebraic or symbolic mode.  It can be
set to any value, but only four atoms have special meaning: {\bf
FORTRAN}, {\bf RATFOR}, {\bf PASCAL} and {\bf C}.  Any other value is
assumed to mean {\bf FORTRAN}.  {\bf GENTRANLANG!*} is always
initialized to {\bf FORTRAN}.


\subsection{Translation}
\label{translation}
\index{GENTRAN ! command}
The {\bf GENTRAN} (GENerate/TRANslate) command is used to generate
numerical code and also to translate code from algorithmic
specifications in the REDUCE programming language to code in the
target numerical language.  Section~\ref{generation} explains code
{\em generation}.  This section explains code {\em translation}.

A substantial subset of all expressions and statements in the REDUCE
programming language can be translated directly into numerical code.
The {\bf GENTRAN} command takes a REDUCE expression, statement, or
procedure definition, and translates it into code in the target
language.

\begin{describe}{Syntax:}
{\bf GENTRAN} {\it stmt} [ {\bf OUT} {\it f1,f2,\dots\  ,fn} ]{\it ;}
\end{describe}

\begin{describe}{Arguments:}
{\it stmt} is any REDUCE expression, statement (simple, compound, or
group), or procedure definition that can be translated by GENTRAN into the
target language\footnote{See~\ref{appa} for a complete listing of REDUCE
expressions and statements that can be translated.}
{\it stmt} may contain any number of calls
to the special functions {\bf EVAL}, {\bf DECLARE}, and {\bf LITERAL}
(see sections~\ref{translation}~--~\ref{comments}).

{\it f1,f2,\dots\  ,fn } is an optional argument list containing one or more
{\it f}'s, where each {\it f} is one of:
\par
\begin{tabular}{lll}
{\it an atom} &= &an output file\\
{\bf T} &= &the terminal\\
{\bf NIL} &= &the current output file(s)\\
\ttindex{ALL"!*} {\bf ALL!*} &= &all files currently open for output \\
& & by GENTRAN (see section~\ref{GENTRAN:output})\\
\end{tabular}
\end{describe}
\index{side effects}
\begin{describe}{Side Effects:}
{\bf GENTRAN} translates {\it stmt} into formatted code in the target language.

If the optional part of the command is not given, generated code is simply
written to the current output file.  However, if it is
given, then the current output file is temporarily overridden.  Generated
code is written to each file represented by 
{\it f1,f2,\dots\  ,fn} for this command only.  Files which were open prior
to the call to {\bf GENTRAN} will remain open after the call, and files
which did not exist prior to the call will be created, opened, written to,
and closed.  The output stack will be exactly the same both before and
after the call.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRAN}  returns the name(s) of the file(s) to which code was written.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)
\end{verbatim}
\begin{verbatim}
***** WRONG TYPE OF ARG
\end{verbatim}
exp
\begin{verbatim}
***** CANNOT BE TRANSLATED
\end{verbatim}
\end{describe}
\begin{describe}{\example\footnote{When the {\bf PERIOD} flag (default
setting: ON) is turned on, all \ttindex{PERIOD}
integers are automatically printed as real numbers except exponents,
subscripts in subscripted variables, and index values in DO-type loops.}}
\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$

2: GENTRAN
2:     FOR I:=1:N DO
2:         V(I) := 0$

      DO 25001 I=1,N
          V(I)=0.0
25001 CONTINUE

3: GENTRANLANG!* := 'RATFOR$ 

4: GENTRAN 
4:      FOR I:=1:N DO 
4:          FOR J:=I+1:N DO 
4:          << 
4:              X(J,I) := X(I,J); 
4:              Y(J,I) := Y(I,J) 
4:          >>$ 

DO I=1,N
    DO J=I+1,N
    {
        X(J,I)=X(I,J)
        Y(J,I)=Y(I,J)
    }

5: GENTRANLANG!* := 'C$ 

6: GENTRAN 
6:      P := FOR I:=1:N PRODUCT I$ 

{
    P=1;
    for (I=1;I<=N;++I)
        P*=I;
}

7: GENTRANLANG!* := 'PASCAL$

8: GENTRAN
8:     S := FOR I := 1:10 SUM V(I)$
BEGIN
    S:=0;
    FOR I:=1 TO 10 DO
        S:=S+V(I)
END;
\end{verbatim}
\end{describe}


\index{numeric code} Translation is a convenient method of producing
numerical code when the exact behaviour of the resultant code is
known.  It gives the REDUCE user who is familiar with the syntax of
statements in the REDUCE programming language the ability to write
code in a numerical programming language without knowing the exact
syntactical requirements of the language.  However the {\em real}
power of the {\bf GENTRAN} command lies in its ability to generate
code: it can produce numerical code from symbolic expressions derived
in REDUCE in addition to translating statements directly.  This aspect
is described in section~\ref{generation}.

\subsection{Precision}
\label{precision}
\index{precision} \index{DOUBLE switch}
By default {\bf GENTRAN} generates constants and type declarations in
single precision form.  If the user requires double precision output
then the switch {\bf DOUBLE} must be set {\bf ON}.  This does the
following:

\begin{itemize}
\item Declarations of appropriate type are converted to their double
precision counterparts.  In FORTRAN and RATFOR this means that objects of type
{\it REAL\/} are converted to objects of type {\it DOUBLE PRECISION\/}
and objects of type {\it COMPLEX\/} are converted to {\it COMPLEX*16\/}
\footnote{This is not part of the ANSI FORTRAN standard.  Some compilers
accept {\it DOUBLE COMPLEX\/} as well as, or instead of, {\it COMPLEX*16\/},
and some accept neither.}. \index{DOUBLE PRECISION} \index{COMPLEX}
\index{COMPLEX*16}
In C the counterpart of {\it float\/} is {\it double\/}, and of {\it int\/}
is {\it long\/}.  There is no complex data type and trying to translate complex
objects causes an error.
\item Similarly subprograms are given their correct type where appropriate.
\item In FORTRAN and RATFOR {\it REAL\/} and {\it COMPLEX\/} numbers are
printed with the correct double precision format.
\item Intrinsic functions are converted to their double precision counterparts
(e.g. in FORTRAN $SIN \rightarrow DSIN$ etc.).
\end{itemize}

\subsubsection{Intrinsic FORTRAN and RATFOR functions.}
An attempt is made to convert the arguments of intrinsic functions to
the correct type.  For example:
\begin{verbatim}
5: GENTRAN f:=sin(1)$
      F=SIN(1.0)

6: GENTRAN f:=sin(x)$
      F=SIN(REAL(X))

7: GENTRAN DECLARE <>$

8: GENTRAN f:=sin(x)$
      F=SIN(X)
\end{verbatim}
Which function is used to coerce the argument may, of course, depend on the
setting of the switch {\bf DOUBLE}.

\subsubsection{Number of printed floating point digits.}
\index{PRECISION command} \index{PRINT"!-PRECISION command}
To ensure the correct number of floating point digits are
generated it may be necessary to use either the {\bf PRECISION} or
{\bf PRINT!-PRECISION} commands.  The former alters the number of
digits REDUCE calculates, the latter only the number of digits REDUCE
prints.  Each takes an integer argument.  It is not possible to set
the printed precision higher than the actual precision.  Calling {\bf
PRINT!-PRECISION} with a negative argument causes the printed
precision to revert to the actual precision.

\begin{verbatim}
1: on rounded$

2: precision 16$

3: 1/3;

0.333 33333 33333 333

4: print!-precision 6$

5: 1/3;

0.333333

6: print!-precision(-1)$

7: 1/3;

0.333 33333 33333 333
\end{verbatim}

\subsection{Code Generation:  Evaluation Prior to Translation}
\label{generation}
Section~\ref{translation} showed how REDUCE statements and expressions
can be translated directly into the target language.  This section
shows how to indicate that parts of those statements and expressions
are to be handed to REDUCE to be evaluated before being translated.
In other words, this section explains how to generate numerical code
from algorithmic specifications (in the REDUCE programming language)
and symbolic expressions.  Each of the following four subsections
describes a special function or operator that can be used to request
partial or full evaluation of expressions prior to translation.  Note
that these functions and operators have the described effects {\it
only} when applied to arguments to the {\bf GENTRAN} function and that
evaluation is done in algebraic or symbolic mode, depending on the
value of the REDUCE variable {\bf !*MODE}.\ttindex{"!*MODE}

\subsubsection{The EVAL Function}
\label{eval}
\begin{describe}{Syntax:} 
{\bf EVAL} {\it exp}
\end{describe} \ttindex{EVAL}
\begin{describe}{Argument:}
{\it exp} is any REDUCE expression or statement which, after evaluation
by REDUCE, results in an expression that can be translated by
GENTRAN into the target language.
\end{describe}
\begin{describe}{Side Effect:}
When {\bf EVAL} is called on an expression which is to be translated, it
tells {\bf GENTRAN} to give the expression to REDUCE
for evaluation first, and then to translate the result of that evaluation.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
The following formula, F, has been derived symbolically:
\begin{verbatim}
   2
2*X  - 5*X + 6
\end{verbatim}
We wish to generate an assignment statement for the quotient
of F and its derivative.
\begin{verbatim}
1: GENTRAN 
1:      Q := EVAL(F)/EVAL(DF(F,X))$ 

      Q=(2.0*X**2-(5.0*X)+6.0)/(4.0*X-5.0)
\end{verbatim}
\end{describe}

\subsubsection{The :=: Operator}
\index{:=:}
\label{rsetq} \index{GENTRAN ! preevaluation} \index{rsetq operator}
In many applications, assignments must be generated in which the
left-hand side is some known variable name, but the
right-hand side is an expression that must be evaluated.  For
this reason, a special operator is provided to indicate that the expression
on the right-hand side is to be evaluated prior to translation.  This
special operator is {\bf :=:} (i.e., the usual REDUCE assignment operator
with an extra ``:'' on the right).
\begin{describe}{\example} \index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRAN 
1:  DERIV :=: DF(X^4-X^3+2*x^2+1,X)$ 

      DERIV=4.0*X**3-(3.0*X**2)+4.0*X
\end{verbatim}
\end{describe}
Each built-in operator in REDUCE has an alternative alphanumeric identifier
associated with it.  Similarly, the GENTRAN {\bf :=:} operator has a
special identifier associated with it: {\bf RSETQ} may be used \ttindex{RSETQ}
interchangeably with {\bf :=:} on input.
\subsubsection{The ::= Operator}
\label{lsetq}
\index{matrices ! in GENTRAN}
When assignments to matrix or array elements must be generated, many
times the indices of the element must be evaluated first.  The special operator
\index{::=} \index{lsetq operator}
{\bf ::=} can be used within a call to {\bf GENTRAN}
to indicate that the indices of the matrix or
array element on the left-hand side of the assignment are to
be evaluated prior to translation.  (This is the usual REDUCE
assignment operator with an extra ``:'' on the left.)
\begin{describe}{\example}\index{GENTRAN package ! example}
We wish to generate assignments which assign zeros to all elements
on the main diagonal of M, an n x n matrix.
\begin{verbatim}
10: FOR j := 1 : 8 DO 
10:      GENTRAN 
10:          M(j,j) ::= 0$

      M(1,1)=0.0
      M(2,2)=0.0
      :
      :
      M(8,8)=0.0
\end{verbatim}
\end{describe}

{\bf LSETQ} may be used interchangeably with {\bf ::=} on input.\ttindex{LSETQ}
\subsubsection{The ::=: Operator}
\label{lrsetq}
\index{::=:}  \index{lrsetq operator}
In applications in which evaluated expressions are to be assigned to
array elements with evaluated subscripts, the {\bf ::=:} operator can be
used.  It is a combination of the {\bf ::=} and {\bf :=:} operators described
in sections~\ref{rsetq} and ~\ref{lsetq}.
\index{matrices ! in GENTRAN}

\newpage
\begin{describe}{\example}\index{GENTRAN package ! example}
The following matrix, M, has been derived symbolically:
\begin{verbatim}
(  A   0  -1   1)
(               )
(  0   B   0   0)
(               )
( -1   0   C  -1)
(               )
(  1   0  -1   D)
\end{verbatim}
We wish to generate assignment statements for those elements
on the main diagonal of the matrix.
\begin{verbatim}
10: FOR j := 1 : 4 DO 
10:      GENTRAN 
10:          M(j,j) ::=: M(j,j)$

      M(1,1)=A
      M(2,2)=B
      M(3,3)=C
      M(4,4)=D
\end{verbatim}
\end{describe}
The alternative alphanumeric identifier associated with {\bf ::=:} is 
{\bf LRSETQ}.\ttindex{LRSETQ}

\subsection{Explicit Type Declarations}
\label{explicit:type}
Type declarations are automatically generated each time a subprogram
heading is generated.  Type declarations are constructed
from information stored in the GENTRAN symbol table.  The user
can place entries into the symbol table explicitly through calls
to the special GENTRAN function {\bf DECLARE}. \index{DECLARE function}
\begin{describe}{Syntax:}
{\bf \ \ DECLARE} {\it v1,v2,\dots\  ,vn} {\bf :} {\it type;}

    or

\begin{tabular}{ll}
{\bf DECLARE}\\
{\bf $<$$<$}\\ 
&{\it v11,v12,\dots\  ,v1n} {\bf :} {\it type1;}\\
&{\it v21,v22,\dots\  ,v2n} {\bf :} {\it type2;}\\
& :\\
& :\\
&{\it vn1,vnn,\dots\  ,vnn} {\bf :} {\it typen;}\\ 
{\bf $>$$>$}{\it ;}
\end{tabular}
\end{describe}
\begin{describe}{Arguments:}
Each {\it v1,v2,\dots\  ,vn} is a list of one or more variables
(optionally subscripted to indicate array dimensions), or
variable ranges (two letters separated by a ``-'').  {\it v}'s are
not evaluated unless given as arguments to {\bf EVAL}.

Each {\it type} is a variable type in the target language.  Each
must be an atom, optionally preceded by the atom {\bf IMPLICIT}.
\index{IMPLICIT option}
{\it type}'s are not evaluated unless given as arguments to {\bf EVAL}.
\end{describe}
\begin{describe}{Side Effect:}
Entries are placed in the symbol table for each variable or
variable range declared in the call to this function.  The function
call itself is removed from the statement group being
translated.  Then after translation, type declarations are
generated from these symbol table entries before the resulting
executable statements are printed.
\end{describe}
\begin{describe}{Diagnostic Message:}
\begin{verbatim}
***** INVALID SYNTAX
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRAN 
1: <<
1:      DECLARE 
1:      << 
1:          A-H, O-Z : IMPLICIT REAL; 
1:          M(4,4)   : INTEGER 
1:      >>; 
1:      FOR I:=1:4 DO 
1:          FOR J:=1:4 DO 
1:              IF I=J 
1:                  THEN M(I,J):=1 
1:                  ELSE M(I,J):=0; 
1:      DECLARE I, J : INTEGER; 
1: >>$ 

      IMPLICIT REAL (A-H,O-Z)
      INTEGER M(4,4),I,J
      DO 25001 I=1,4
          DO 25002 J=1,4
              IF (I.EQ.J) THEN
                  M(I,J)=1.0
              ELSE
                  M(I,J)=0.0
              ENDIF
25002     CONTINUE
25001 CONTINUE
\end{verbatim}
\end{describe}
The {\bf DECLARE} statement can also be used to declare subprogram types (i.e.
{\bf SUBROUTINE} or {\bf FUNCTION}) for \index{SUBROUTINE} \index{FUNCTION}
FORTRAN and RATFOR code, and function types for all four languages.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRANLANG!* := 'RATFOR$ 

2: GENTRAN 
2:      PROCEDURE FAC N; 
2:      BEGIN 
2:      DECLARE 
2:      << 
2:          FAC : FUNCTION; 
2:          FAC, N : INTEGER 
2:      >>; 
2:      F := FOR I:=1:N PRODUCT I; 
2:      DECLARE F, I : INTEGER; 
2:      RETURN F 
2:      END$

INTEGER FUNCTION FAC(N)
INTEGER N,F,I
{
    F=1
    DO I=1,N
        F=F*I
}
RETURN(F)
END

3: GENTRANLANG!* := 'C$
4: GENTRAN 
4:      PROCEDURE FAC N; 
4:      BEGIN 
4:      DECLARE FAC, N, I, F : INTEGER; 
4:      F := FOR I:=1:N PRODUCT I; 
4:      RETURN F 
4:      END$ 

int FAC(N)
int N;
{
    int I,F;
    {
        F=1;
        for (I=1;I<=N;++I)
            F*=I;
    }
    return(F);
}
\end{verbatim}
\end{describe}

When generating code for subscripted variables (i.e., matrix and
array elements), it is important to keep several things in mind.  First
of all, when a REDUCE array is declared with a declaration such as
\index{ARRAY}
\begin{center}
{\bf ARRAY A(}{\it n}{\bf )\$} 
\end{center}
where {\it n} is a positive integer, {\bf A} is actually being declared
to be of size {\bf n}+1.  Each of the elements {\bf A(0), A(1), \dots\  , A(n)}
can be used.  However, a FORTRAN or RATFOR declaration such as
\begin{center}
{\bf DIMENSION A(}{\it n}{\bf )}
\end{center}
declares {\bf A} only to be of size {\bf n}.  Only the elements
{\bf A(1), A(2), \dots\  , A(n)} can be used.  Furthermore, a C declaration
such as
\begin{center}
{\bf float A[}{\it n}{\bf ];}
\end{center}
declares {\bf A} to be of size {\bf n} with elements referred to as
{\bf A[0], A[1], \dots\  , A[}{\it n-1}{\bf ]}.

To resolve these array size and subscripting conflicts, the user should
remember the following:
\index{subscripts ! in GENTRAN}
\begin{itemize}
\item {\it All REDUCE array subscripts are translated literally.}
Therefore it is the user's responsibility to be sure that array elements with
subscript 0 are not translated into FORTRAN or RATFOR.
\item Since C and PASCAL
arrays allow elements with a subscript of 0, when an array is
declared to be of size {\it n} by the user, {\it the actual generated type
declaration will be of size n+1} so that the user can translate
elements with subscripts from 0, and up to and including {\it n}.
\end{itemize}

If the user is generating C code, it is possible to produce declarations 
for arrays with unknown bounds:
\begin{verbatim}
5: gentran declare <>$

6: gendecs nil;
float X[ ][ ];
int Y[ ];
\end{verbatim}


\subsection{Implicit Type Declarations}
\label{implicit:type} \index{GETDECS switch}
Some type  declarations can be made automatically if the switch {\bf GETDECS}
is {\bf ON}.  In this case:
\begin{enumerate}
\item The indices of loops are automatically declared to be integers.
\index{loop indices ! in GENTRAN}
\item There is a global variable {\bf DEFTYPE!*}, which is the default
type given to objects.  Subprograms, their parameters, and local scalar
objects are automatically assigned this type. \ttindex{DEFTYPE"!*}
\index{REAL*8} \index{DOUBLE PRECISION}
Note that types such as REAL*8 or DOUBLE PRECISION should not
be used as, if {\bf DOUBLE} is on, then a default type of REAL
will in fact be DOUBLE PRECISION anyway.
\item  If GENTRAN is used to translate a REDUCE procedure, then it assigns
objects declared {\bf SCALAR} the type given by {\bf DEFTYPE!*}.  Note that
\index{INTEGER declaration} \index{REAL declaration}
it is legal to use the commands {\bf INTEGER} and {\bf REAL} in the place
of {\bf SCALAR}, which allows the user to specify an actual type.  The
procedure may also be given a return type, in which case that is used as
the default.  For example:
\begin{verbatim}

2: on getdecs,gendecs$

3: GENTRAN
3: real procedure f(x);
3: begin integer n;real y;
3:     n := 4;
3:     y := n/(1+x)^2;
3:     return y;
3: end;
      REAL FUNCTION F(X)
      INTEGER N
      REAL X,Y
      N=4
      Y=N/(1.0+X)**2
      F=Y
      RETURN
      END

\end{verbatim}
\end{enumerate}

\subsection{More about Type Declarations}
\label{more:type}
A check is made on output to ensure that all types generated are legal ones.
This is necessary since {\bf DEFTYPE!*} can be set to anything.
Note that {\bf DEFTYPE!*} ought normally to be given a simple 
type as its \ttindex{DEFTYPE"!*}
value, such as REAL, INTEGER, or COMPLEX,
since this will always be translated into the corresponding type in the
target language on output.

An entry is removed from the symbol table once a declaration has been
generated for it.  The {\bf KEEPDECS} switch (by default {\bf OFF})
disables this, allowing a user to check the types of objects
\index{KEEPDECS switch} which GENTRAN has generated (useful if they
are being generated automatically)

\subsection{Comments and Literal Strings}
\label{comments} \index{comments ! in GENTRAN}
Comments and other strings of characters can be inserted directly into
the stream of generated code through a call to the special function
{\bf LITERAL}.
\begin{describe}{Syntax:}
{\bf LITERAL} {\it  arg1,arg2,\dots\  ,argn;}
\end{describe}
\begin{describe}{Arguments:}
{\it arg1,arg2,\dots\  ,argn} is an argument list containing one or more
{\it arg}'s, where each {\it arg} either is, or evaluates to, an atom.  The
\ttindex{TAB"!*} \ttindex{CR"!*} 
atoms {\bf TAB!*} and {\bf CR!*} have special meanings.  {\it arg}'s are
not evaluated unless given as arguments to {\bf EVAL}.
\end{describe}
\begin{describe}{Side Effect:}
This statement is replaced by the character sequence resulting from
concatenation of the given atoms.  Double quotes are stripped from
all string type {\it arg}'s, and the reserved atoms {\bf TAB!*} and
{\bf CR!*} are replaced by a tab to the current level of indentation, and
an end-of-line character, respectively.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Suppose N has value 10.
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$ 

2: GENTRAN 
2: << 
2:      LITERAL 
2:        "C",TAB!*,"--THIS IS A FORTRAN COMMENT--",CR!*, 
2:        "C",CR!*; 
2:      LITERAL 
2:        TAB!*,"DATA N/",EVAL(N),"/",CR!* 
2: >>$ 

C     --THIS IS A FORTRAN COMMENT--
C
      DATA N/10/

3: GENTRANLANG!* := 'RATFOR$ 
4: GENTRAN 
4:     FOR I:=1:N DO 
4:     << 
4:         LITERAL 
4:            TAB!*,"# THIS IS A RATFOR COMMENT",CR!*; 
4:         LITERAL 
4:            TAB!*,"WRITE(6,10) (M(I,J),J=1,N)",CR!*, 
4:            10,TAB!*,"FORMAT(1X,10(I5,3X))",CR!* 
4:     >>$ 

DO I=1,N
    {
        # THIS IS A RATFOR COMMENT
        WRITE(6,10) (M(I,J),J=1,N)
10      FORMAT(1X,10(I5,3X))
    }

5: GENTRANLANG!* := 'C$ 
6: GENTRAN 
6: << 
6:      X:=0; 
6:      LITERAL "/* THIS IS A",CR!*, 
6:              "   C COMMENT */",CR!* 
6: >>$ 

{
    X=0.0;
/* THIS IS A
   C COMMENT */
}

7:  GENTRANLANG!* := 'PASCAL$

8: GENTRAN
8: <<
8:     X := SIN(Y);
8:     LITERAL "{ THIS IS A PASCAL COMMENT }", CR!*
8: >>$
BEGIN
    X:=SIN(Y)
{ THIS IS A PASCAL COMMENT }
END;

\end{verbatim}
\end{describe}
\subsection{Expression Segmentation}
\label{segmentation} \index{segmenting expressions}
Symbolic derivations can easily produce formulas that can be anywhere
from a few lines to several pages in length.  Such formulas
can be translated into numerical assignment statements, but unless they
are broken into smaller pieces they may be too long for a compiler
to handle.  (The maximum number of continuation lines for one statement
allowed by most FORTRAN compilers is only 19.)  Therefore GENTRAN
\index{continuation lines}
contains a segmentation facility which automatically {\it segments},
or breaks down unreasonably large expressions.

The segmentation facility generates a sequence of assignment
statements, each of which assigns a subexpression to an automatically
generated temporary variable.  This sequence is generated in such a
way that temporary variables are re-used as soon as possible, thereby
keeping the number of automatically generated variables to a minimum.
The facility can be turned on or off by setting the mode
\index{GENTRANSEG switch} switch {\bf GENTRANSEG} accordingly (i.e.,
by calling the REDUCE function {\bf ON} or {\bf OFF} on it).  The user
can control the maximum allowable expression size by setting the
\ttindex{MAXEXPPRINTLEN"!*}
variable {\bf MAXEXPPRINTLEN!*} to the maximum number of characters
allowed in an expression printed in the target language (excluding
spaces automatically printed by the formatter).  The {\bf GENTRANSEG}
switch is on initially, and {\bf MAXEXPPRINTLEN!*} is initialized to
800.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: ON EXP$ 

2: JUNK1 := (A+B+C+D)^2$ 

3: MAXEXPPRINTLEN!* := 24$ 

4: GENTRAN VAL :=: JUNK1$ 

      T0=A**2+2.0*A*B
      T0=T0+2.0*A*C+2.0*A*D
      T0=T0+B**2+2.0*B*C
      T0=T0+2.0*B*D+C**2
      VAL=T0+2.0*C*D+D**2

5: JUNK2 := JUNK1/(E+F+G)$ 

6: MAXEXPPRINTLEN!* := 23$ 

7: GENTRANLANG!* := 'C$ 

8: GENTRAN VAL :=: JUNK2$ 

{
    T0=power(A,2)+2.0*A*B;
    T0+=2.0*A*C;
    T0=T0+2.0*A*D+power(B,2);
    T0+=2.0*B*C;
    T0=T0+2.0*B*D+power(C,2);
    T0=T0+2.0*C*D+power(D,2);
    VAL=T0/(exp(1.0)+F+G);
}
\end{verbatim}
\end{describe}
\subsubsection{Implicit Type Declarations}\label{GENTRAN:itd}
When the segmentation routine generates temporary variables, it places
type declarations in the symbol table for those variables if
possible.  It uses the following rules to determine their type:
\index{implicit type declarations} \index{temporary variables ! type}
\begin{itemize}
\item[{(1)}]
If the type of the variable to which the large expression is being
assigned is already known (i.e., has been declared by the user),
then the temporary variables will be declared to be of that same type.
\item[{(2)}] \ttindex{TEMPVARTYPE"!*}
If the global variable {\bf TEMPVARTYPE!*} has a non-NIL value, then the
temporary variables are declared to be of that type.
\item[{(3)}]
Otherwise, the variables are not declared.
\end{itemize}

\newpage
\begin{describe}{\example} \index{GENTRAN package ! example}

\begin{verbatim}
1: MAXEXPPRINTLEN!* := 20$

2: TEMPVARTYPE!* := 'REAL$ 

3: GENTRAN 
3: << 
3:      DECLARE ISUM : INTEGER; 
3:      ISUM := II+JJ+2*KK+LL+10*MM+NN; 
3:      PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2) 
3: >>$ 

      INTEGER ISUM,T0
      REAL T1
      T0=II+JJ+2.0*KK+LL
      ISUM=T0+10.0*MM+NN
      T1=V(X,Y)*SIN(X)*COS(Y**2)
      PROD=T1*(X+Y+Z**2)
\end{verbatim}
\end{describe}
\subsection{Generation of Temporary Variable Names}
\label{tempvars} \index{temporary variables ! names}
As we have just seen, GENTRAN's segmentation module generates
temporary variables and places type declarations in the symbol table
for them whenever possible.  Various other modules also generate
variables and corresponding declarations.  All of these modules call
one special GENTRAN function each time they need a temporary
variable name.  This function is {\bf TEMPVAR}.  There are situations
in which it may be convenient for the user to be able to generate
temporary variable names directly.\footnote{One such example is suppression
of the simplification process to generate numerical code which is more
efficient.  See the example in section~\ref{tempvar:example} on
page~\pageref{tempvar:example}.}
Therefore {\bf TEMPVAR} \ttindex{TEMPVAR}
is a user-accessible function which may be called from both
the algebraic and symbolic modes of REDUCE.
\begin{describe}{Syntax:}
{\bf TEMPVAR} {\it type}
\end{describe}
\begin{describe}{Argument:}
{\it type} is an atom which either indicates the variable type in the
target language (INTEGER, REAL, etc.), or is {\bf NIL} if the variable
type is unknown.
\end{describe}
\begin{describe}{Side Effects:}
{\bf TEMPVAR} creates temporary variable names by repeatedly concatenating
the values of the global variables {\bf TEMPVARNAME!*} (which has a
\ttindex{TEMPVARNUM"!*}
default value of {\bf T}) and {\bf TEMPVARNUM!*} (which is initially set
to 0) and incrementing {\bf TEMPVARNUM!*} until a variable name is created
which satisfies one of the following conditions:
\begin{itemize}
\item[{(1)}]
It was not generated previously, and it has not been declared by the user.
\item[{(2)}]
It was previously generated to hold the same type of value that it
must hold this time (e.g. INTEGER, REAL, etc.), and the value assigned
to it previously is no longer needed.
\end{itemize}
If {\it type} is a non-NIL argument, or if {\it type} is {\bf NIL}
and the global variable {\bf TEMPVARTYPE!*} (initially NIL) has been
\ttindex{TEMPVARTYPE"!*}
set to a non-NIL value, then a type entry for the generated variable name
is placed in the symbol table.
\end{describe}
\begin{describe}{Returned Value:}
{\bf TEMPVAR} returns an atom which can be used as a variable.
\end{describe}
Note:  It is the user's responsibility to set {\bf TEMPVARNAME!*} and 
{\bf TEMPVARNUM!*} to values such that generated variable
names will not clash with variables used elsewhere in the
program unless those variables have been declared.

\subsubsection{Marking Temporary Variables}
In section~\ref{tempvars} we saw that a temporary variable name (of a certain
type) can be regenerated when the value previously assigned to it
is no longer needed.  This section describes a function which {\it marks}
a variable to indicate that it currently holds a
significant value, and the next section describes functions which
{\it unmark} variables to indicate that the values they hold are no
\index{temporary variables ! marking}
\index{marking temporary variables}
longer significant.\ttindex{MARKVAR}
\begin{describe}{Syntax:}
{\bf MARKVAR} {\it  var}
\end{describe}
\begin{describe}{Argument:}
{\it var} is an atom.
\end{describe}
\begin{describe}{Side Effects:}
{\bf MARKVAR} sets a flag on {\it var}'s property list to indicate that
{\it var} currently holds a significant value.
\end{describe}
\begin{describe}{Returned Value:}
{\bf MARKVAR} returns {\it var}.
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
The following matrix, M has been derived symbolically:
\begin{verbatim}
(X*(Y+Z)       0     X*Z)
(                       )
(     -X     X+Y       0)
(                       )
(    X*Z       0    Z**2)
\end{verbatim}
We wish to replace each non-zero element by a generated variable name
to prevent these expressions from being resubstituted into further
calculations.  (We will also record these substitutions in the
numerical program we are constructing by generating assignment
statements.)\footnote{ Note: {\bf MARKVAR} is a symbolic mode
procedure.  Therefore, the name of each variable whose value is to be
passed to it from algebraic mode must appear in a {\bf SHARE}
\index{SHARE command} declaration.  This tells REDUCE to share the
variable's value between algebraic and symbolic modes.}
\begin{verbatim}
9: SHARE var$ 

10: FOR j := 1 : 3 DO 
10:      FOR k := 1 : 3 DO 
10:          IF M(j,k) NEQ 0 THEN 
10:          << 
10:              var := TEMPVAR(NIL); 
10:              MARKVAR var;
10:              GENTRAN
10:                  EVAL(var) :=: M(j,k);
10:              M(j,k) := var
10:          >>$ 

      T0=X*(Y+Z)
      T1=X*Z
      T2=-X
      T3=X+Y
      T4=X*Z
      T5=Z**2
\end{verbatim}
Now matrix M contains the following entries:
\begin{verbatim}
(T0   0  T1)
(          )
(T2  T3   0)
(          )
(T4   0  T5)
\end{verbatim}
\end{describe}

\subsubsection{Unmarking Temporary Variables}
\index{unmarking temporary variables} \index{temporary variables ! unmarking}
After the value assigned to a temporary variable has been used
in the numerical program and is no longer needed, the variable name can be \
\ttindex{UNMARKVAR}
{\it unmarked} with the {\bf UNMARKVAR} function.
\begin{describe}{Syntax:}
{\bf UNMARKVAR} {\it  var;}
\end{describe}
\begin{describe}{Argument:}
{\it var} is an atom (variable name) or an expression containing one or more
variable names.
\end{describe}
\begin{describe}{Side Effect:}
{\bf UNMARKVAR} resets flags on the property lists of all variable names in 
{\it var} to indicate that they do not hold significant values any longer.
\end{describe}

\subsection{Enabling and Disabling Generation of Type Declarations}
\label{control:type}
GENTRAN maintains a symbol table of variable type and dimension
information.  It adds information to the symbol table by processing
user-supplied calls to the {\bf DECLARE} function (see
Section~\ref{explicit:type}) and as a
side effect of generating temporary variable names 
(see Sections~\ref{segmentation} and \ref{tempvars}).
All information is stored in the symbol table until GENTRAN is ready
to print formatted numerical code.  Since programming languages such as
FORTRAN require that type declarations appear before executable statements,
GENTRAN automatically extracts all relevant type information and prints it
in the form of type declarations before printing executable
statements.  This feature is useful when the entire body of a (sub)program is
generated at one time:  in this case, type declarations are printed
before any executable code.  However, if the user chooses to generate code
in pieces, the resulting code may have type declarations interleaved
\index{GENDECS switch}
with executable code.  For this reason, the user may turn the {\bf GENDECS}
mode switch on or off, depending on whether or not s/he chooses to use
this feature.

In the following we re-examine the example of Section~\ref{GENTRAN:itd}.
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: MAXEXPPRINTLEN!* := 20$ 

2: TEMPVARTYPE!* := 'REAL!*8$

3: GENTRAN 
3: << 
3:      DECLARE ISUM : INTEGER; 
3:      ISUM := II+JJ+2*KK+LL+10*MM+NN 
3: >>$ 

      INTEGER ISUM,T0
      T0=II+JJ+2*KK+LL
      ISUM=T0+10*MM+NN

4: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ 

      REAL*8 T2
      T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2))
      PROD=T2*(X+Y+Z**2)

5: OFF GENDECS$ 

6: GENTRAN 
6: <<
6:      DECLARE ISUM : INTEGER; 
6:      ISUM := II+JJ+2*KK+LL+10*MM+NN 
6: >>$ 

      T0=II+JJ+2*KK+LL
      ISUM=T0+10*MM+NN

7: GENTRAN PROD := V(X,Y)*SIN(X)*COS(Y^2)*(X+Y+Z^2)$ 

      T2=V(X,Y)*SIN(REAL(X))*COS(REAL(Y**2))
      PROD=T2*(X+Y+Z**2)
\end{verbatim}
\end{describe}

In Section~\ref{template:type} we will explain how to further control
the generation of type declarations.

\subsection{Complex Numbers}
\label{complex} \index{complex numbers} \index{COMPLEX}
With the switch {\bf COMPLEX} set {\bf ON}, GENTRAN will generate the
correct representation for a complex number in the given precision
provided that:

\begin{enumerate}
\item The current language supports a complex data type (if it doesn't then
an error results);
\item The complex quantity is evaluated by REDUCE
to give an object of the correct
domain; i.e.
\begin{verbatim}
        GENTRAN x:=: 1+i;

        GENTRAN x:= eval 1+i;

        z := 1+i;
        GENTRAN x:=: z;
\end{verbatim}
will all generate the correct result, as will their Symbolic mode equivalents,
while:
\begin{verbatim}
        GENTRAN x := 1+i;
\end{verbatim}
will not.
\end{enumerate}

\subsection{Intrinsic Functions}
\label{intrinsic} \index{intrinsic functions}
A warning is issued if a standard REDUCE function is encountered which
does not have an intrinsic counterpart in the target language (e.g.
 {\it cot\/},
{\it sec\/} etc.).
Output is not halted in case this is a user--supplied function, either via
a REDUCE definition or within a GENTRAN template.

The types of intrinsic FORTRAN functions are coerced to reals (in the correct
precision) as the following examples demonstrate:
\begin{verbatim}
19: GENTRAN x:=sin(0)$
      X=SIN(0.0)

20: GENTRAN x:=cos(A)$
      X=COS(REAL(A))

21: ON DOUBLE$

22: GENTRAN x := log(1)$
      X=DLOG(1.0D0)

23: GENTRAN x := exp(B)$
      X=DEXP(DBLE(B))

24: GENTRAN DECLARE <>$

25: GENTRAN x := exp(B)$
      X=DEXP(B)

\end{verbatim}

\subsection{Miscellaneous}

\subsubsection{MAKECALLS}
A statement like:
\begin{verbatim}
        GENTRAN x^2+1$
\end{verbatim}
will yield the result:
\begin{verbatim}
        X**2+1
\end{verbatim}
but, under normal circumstances, a statement like:
\begin{verbatim}
        GENTRAN sin(x)$
\end{verbatim}
will yield the result:
\begin{verbatim}
              CALL SIN(X)
\end{verbatim}
\index{MAKECALLS switch}
The switch {\bf MAKECALLS} (OFF by default) will make GENTRAN yield
\begin{verbatim}
       SIN(X)
\end{verbatim}
This is useful if you don't know in advance what the form of the expression
which you are translating is going to be.

\subsubsection{E}
\index{e} \index{EXP}
When GENTRAN encounters $e$ it translates it into EXP(1), and when GENTRAN
encounters
$e^x$ it is translated to EXP(X).  This is then translated
into the correct statement in the given language and precision.  Note that
it is still possible to do something like:
\begin{verbatim}
                GENTRAN e:=:e;
\end{verbatim}
and get the correct result.

\subsection{Booleans}
\index{booleans} \index{true} \index{false}
Some languages, like Fortran-77, have a boolean data type.  Others, like
C, do not.  When translating Reduce code into a language with a boolean
data type, GENTRAN will recognise the special identifiers $true$ and
$false$.  For example:
\begin{verbatim}
3: gentran <>;
      LOGICAL T
      T=.TRUE.
\end{verbatim}


\section{Template Processing}\label{GENTRAN:template}

\index{GENTRAN ! templates} \index{templates !} \index{code templates}
In some code generation applications pieces of the target numerical
program are known in advance.  A {\it template} file containing a
program outline is supplied by the user, and formulas are derived in
REDUCE, converted to numerical code, and inserted in the corresponding
places in the program outline to form a complete numerical program.  A
template processor is provided by GENTRAN for use in these
applications.

\subsection{The Template Processing Command}
\label{templates} \index{GENTRANIN command}
\begin{describe}{Syntax:}
{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm} [{\bf OUT} {\it f1,f2,\dots\
 ,fn\/}]{\it ;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fm\/} is an argument list containing one or more
{\it f\/}'s,
where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &a template (input) file\\
{\bf T}& = &the terminal\\
\end{tabular}
\end{center}
{\it f1,f2,\dots\ ,fn\/} is an optional argument list containing one or more
{\it f\/}'s, where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &an output file\\
{\bf T}& = &the terminal\\
{\bf NIL}& = &the current output file(s)\\
{\bf ALL!*}& = &all files currently open for output \\
& &  by GENTRAN (see section~\ref{GENTRAN:output}) \\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANIN} processes each template file {\it f1,f2,\dots\ ,fm}
sequentially.

A template file may contain any number of parts, each of which
is either an active or an inactive part.  All active parts start with
the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}.  The end
of the template file is indicated by an extra {\bf ;END;} character
sequence. \index{;BEGIN; marker}  \index{;END; marker}

Inactive parts of template files are assumed to contain code in the
target language (FORTRAN, RATFOR, PASCAL or C, depending on the value
\ttindex{GENTRANLANG"!*}
of the global variable {\bf GENTRANLANG!*}).  All inactive parts are
copied to the output.  Comments delimited by the appropriate characters,
\index{comments ! in GENTRAN}
\begin{center}
\begin{tabular}{lll}
&{\bf C} \dots\  $<$cr$>$ & FORTRAN (beginning in column 1)\\
&{\bf \#} \dots\  $<$cr$>$ & RATFOR \\
&{\bf /*} \dots\  {\bf */} & C \\
&{\bf \{} \dots\ {\bf \}} or {\bf *(} \dots\  {\bf )*} & PASCAL\\
\end{tabular}
\end{center}
are also copied in their entirety to the output.  Thus the character
sequences {\bf ;BEGIN;} and {\bf ;END;} have no special meanings
within comments.

Active parts may contain any number of REDUCE expressions, statements,
and commands.  They are not copied directly to the output.  Instead,
they are given to REDUCE for evaluation in algebraic mode\footnote{
Active parts are evaluated in algebraic mode unless the mode is
explicitly changed to symbolic from within the active part itself.
This is true no matter which mode the system was in when the template
processor was called.}.  All output generated by each evaluation is
sent to the output file(s).  Returned values are only printed on the
terminal.\index{GENTRAN ! preevaluation}

Active parts will most likely contain calls to {\bf GENTRAN} to
generate code.  This means that the result of processing a
template file will be the original template file with all active
parts replaced by generated code.

If {\bf OUT} {\it f1,f2,\dots\ ,fn} is not given, generated code is simply
written to the current-output file.

However, if {\bf OUT} {\it  f1,f2,\dots\ ,fn}
is given, then the current-output file
is temporarily overridden.  Generated code is written to each file represented
by {\it f1,f2,\dots\ ,fn} for this command only.  Files which were
open prior to the call to {\bf GENTRANIN} will remain open after the
call, and files which did not exist prior to the call will be
created, opened, written to, and closed.  The output-stack will be
exactly the same both before and after the call.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANIN} returns the names of all files written to by this
command.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** NONEXISTENT INPUT FILE

***** TEMPLATE FILE ALREADY OPEN FOR INPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Suppose we wish to generate a FORTRAN subprogram to compute the
determinant of a 3 x 3 matrix.  We can construct a template
file with an outline of the FORTRAN subprogram and REDUCE and
GENTRAN commands to fill it in:
\index{matrices ! in GENTRAN}

Contents of file {\tt det.tem}:
\end{describe}
\begin{framedverbatim}
      REAL FUNCTION DET(M)                         
      REAL M(3,3)                                  
;BEGIN;                                              
      OPERATOR M$                                    
      MATRIX MM(3,3)$                                
      MM := MAT( (M(1,1),M(1,2),M(1,3)),             
                 (M(2,1),M(2,2),M(2,3)),             
                 (M(3,1),M(3,2),M(3,3)) )$           
      GENTRAN DET :=: DET(MM)$                       
;END;                                                
      RETURN                                         
      END                                            
;END;                                                
\end{framedverbatim}

\begin{describe}{}
Now we can generate a FORTRAN subprogram with the following
REDUCE session:
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$ 

2: GENTRANIN 
2:      "det.tem" 
2: OUT "det.f"$ 
\end{verbatim}
Contents of file det.f:
\end{describe}
\begin{framedverbatim}
      REAL FUNCTION DET(M)
      REAL M(3,3)
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1
     . ,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN
      END
\end{framedverbatim}

\subsection{Copying Files into Template Files}
\label{copy:template}

\index{GENTRANIN command} \index{files ! in GENTRAN}
Template files can be copied into other template files with recursive
calls to {\bf GENTRANIN} ; i.e., by calling {\bf GENTRANIN} from the
active part of a template file.

For example, suppose we wish to copy the contents of a file containing
a subprogram into a file containing a main program.  We will call 
{\bf GENTRANIN} to do the copying, so the subprogram file must
have {\bf ;END;} on its last line:

Contents of file {\tt det.tem}:
\begin{framedverbatim}
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1
     . ,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 

Now the template file for the main program can be constructed
with an active part which will include file det.tem:

Contents of file {\tt main.tem}:
\begin{framedverbatim} 
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET                                   
      WRITE(6,*) 'ENTER 3 x 3 MATRIX'                     
      DO 100 I=1,3                                        
          READ(5,*) (M(I,J),J=1,3)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
;BEGIN;                                                   
      GENTRANIN "det.tem"$                                
;END;                                                     
;END;                                                     
\end{framedverbatim} 

The following REDUCE session will create the file {\tt main.f}:
\begin{verbatim}
1: GENTRANIN 
1:      "main.tem" 
1: OUT "main.f"$
\end{verbatim}

Contents of file {\tt main.f}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET                                   
      WRITE(6,*) 'ENTER 3 x 3 MATRIX'                     
      DO 100 I=1,3                                        
          READ(5,*) (M(I,J),J=1,3)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*
     . M(1,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
\end{framedverbatim} 

\subsection{The Template File Stack}
\label{template:stack}

\index{templates ! file stack}
The REDUCE {\bf IN} command takes one or more file names as
arguments.  REDUCE reads each of the given files and executes all
statements and commands, any of which may be another {\bf IN}
command.  A stack of input file names is maintained by
REDUCE to allow recursive invocation of the {\bf IN} command.  Similarly,
a stack of template file names is maintained by GENTRAN to facilitate
recursive invocation of the template processor.  Section~\ref{copy:template}
showed that the {\bf GENTRANIN} command can be
\index{GENTRANIN command}
called recursively to copy files into other files.  This section shows
that template files which are copied into other template files can also
contain active parts, and thus the whole code generation process can
be invoked recursively.

We can generalize the example of section~\ref{copy:template} by
generating code recursively.  We can extend it to generate code which
will compute entries of the inverse matrix, also.  Suppose
we have created the file init.red, which contains REDUCE commands to
create an {\it n}x{\it n} matrix MM and initialize its entries
to M(1,1), M(1,2),~\dots~, M({\it n}, {\it n}), for some user-entered
value of {\it n}:

Contents of file {\tt init.red}:
\begin{framedverbatim}
OPERATOR M$                                               
MATRIX MM(n,n)$                                           
FOR J := 1 : n DO                                         
    FOR K := 1 : n DO                                     
        MM(J,K) := M(J,K)$                                
END$                                                      
\end{framedverbatim} 

We have also created template files {\tt det.tem} and {\tt inv.tem} which
contain outlines of FORTRAN subprograms to compute the
determinant and inverse of an {\it n}x{\it n} matrix, respectively:

Contents of file {\tt det.tem}:
\begin{framedverbatim}
      REAL FUNCTION DET(M)                              
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE M(EVAL(n),EVAL(n)) : REAL;            
          DET :=: DET(MM)                                 
      >>$                                                 
;END;                                                     
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 
Contents of file {\tt inv.tem}:
\begin{framedverbatim}
      SUBROUTINE INV(M,MINV)                              
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE M(EVAL(n),EVAL(n)),                     
          MINV(EVAL(n),EVAL(n)) : REAL;                 
          MINV :=: MM^(-1)                                
      >>$                                                 
;END;                                                     
      RETURN                                              
      END                                                 
;END;                                                     
\end{framedverbatim} 

Now we can construct a template file with a generalized version of the main
program given in section~\ref{copy:template}
and can place {\bf GENTRANIN} commands
in this file to generate code recursively from the template files det.tem
and inv.tem:

Contents of file {\tt main.tem}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
;BEGIN;                                                   
      GENTRAN                                             
      <<                                                  
          DECLARE                                         
          <<                                              
              M(EVAL(n),EVAL(n)),                         
              DET,                                        
              MINV(EVAL(n),EVAL(n)) : REAL;             
              N                     : INTEGER             
          >>;                                             
          LITERAL TAB!*, "DATA N/", EVAL(n), "/", CR!*    
      >>$                                                 
;END;                                                     
      WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX'           
      DO 100 I=1,N                                        
          READ(5,*) (M(I,J),J=1,N)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      WRITE(6,*) ' INVERSE MATRIX:'                       
      CALL INV(M,MINV)                                    
      DO 200 I=1,N                                        
          WRITE(6,*) (MINV(I,J),J=1,N)                    
200   CONTINUE                                            
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
;BEGIN;                                                   
      GENTRANIN "det.tem"$                                
;END;                                                     
C                                                         
C  INVERSE CALCULATION                                    
C                                                         
;BEGIN;                                                   
      GENTRANIN "inv.tem"$                                
;END;                                                     
;END;                                                     
\end{framedverbatim} 

The following REDUCE session will create the file {\tt main.f}:
\begin{verbatim}
1: n := 3$ 

2: IN "init.red"$ 

3: GENTRANLANG!* := 'FORTRAN$ 

4: GENTRANIN 
4:      "main.tem" 
4: OUT "main.f"$ 
\end{verbatim}
Contents of file {\tt main.f}:
\begin{framedverbatim}
C                                                         
C  MAIN PROGRAM                                           
C                                                         
      REAL M(3,3),DET,MINV(3,3)                         
      INTEGER N                                           
      DATA N/3/                                           
      WRITE(6,*) 'ENTER ', N, 'x', N, ' MATRIX'           
      DO 100 I=1,N                                        
          READ(5,*) (M(I,J),J=1,N)                        
100   CONTINUE                                            
      WRITE(6,*) ' DET = ', DET(M)                        
      WRITE(6,*) ' INVERSE MATRIX:'                       
      CALL INV(M,MINV)                                    
      DO 200 I=1,N                                        
          WRITE(6,*) (MINV(I,J),J=1,N)                    
200   CONTINUE                                            
      STOP                                                
      END                                                 
C                                                         
C  DETERMINANT CALCULATION                                
C                                                         
      REAL FUNCTION DET(M)                              
      REAL M(3,3)                                       
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)
     . *M(1,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN                                              
      END                                                 
C                                                         
C  INVERSE CALCULATION                                    
C                                                         
      SUBROUTINE INV(M,MINV)                              
      REAL M(3,3),MINV(3,3)                             
      MINV(1,1)=(M(3,3)*M(2,2)-(M(3,2)*M(2,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(1,2)=(-(M(3,3)*M(1,2))+M(3,2)*M(1,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(1,3)=(M(2,3)*M(1,2)-(M(2,2)*M(1,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(2,1)=(-(M(3,3)*M(2,1))+M(3,1)*M(2,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(2,2)=(M(3,3)*M(1,1)-(M(3,1)*M(1,3)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(2,3)=(-(M(2,3)*M(1,1))+M(2,1)*M(1,3))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(3,1)=(M(3,2)*M(2,1)-(M(3,1)*M(2,2)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      MINV(3,2)=(-(M(3,2)*M(1,1))+M(3,1)*M(1,2))/(M(3,3)*M(2,
     . 2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1)
     . )+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(
     . 2,2)*M(1,3)))
      MINV(3,3)=(M(2,2)*M(1,1)-(M(2,1)*M(1,2)))/(M(3,3)*M(2,2
     . )*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)*M(2,3)*M(1,1))
     . +M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1,2)-(M(3,1)*M(2
     . ,2)*M(1,3)))
      RETURN                                              
      END                                                 
\end{framedverbatim} 

This is an example of a modular approach to code generation; separate
subprogram templates are given in separate files.  Furthermore, the template
files are general; they can be used for matrices of any predetermined
size.  Therefore, we can easily generate different subprograms to
handle matrices of different sizes from the same template files
simply by assigning different values to {\it n}, and reloading the
file init.red.

\subsection{Template Processing and Generation of Type Declarations}
\label{template:type}
\index{GENDECS switch} \index{type declarations}
In Section~\ref{control:type} we described the {\bf GENDECS} flag.  We
explained that type declarations are not generated when this flag is
turned off.  Now that the concept of template processing has been
explained, it is appropriate to continue our discussion of generation
of type declarations.

When the {\bf GENDECS} flag is off, type declaration information is not
simply discarded --- it is still maintained in the symbol table.  Only the
automatic extraction of this information in the form of declarations is
disabled.  When the {\bf GENDECS} flag is turned off, all type
information associated with a specific subprogram can be retrieved in the
form of generated declarations by calling the {\bf GENDECS} function with
the subprogram name as argument.  The template processor recognizes
function and subroutine headings.  It always keeps track of the name of
the subprogram it is processing.  Therefore, the declarations associated with
a particular subprogram {\it subprogname} can be generated with a call to
{\bf GENDECS} as follows:
\begin{center}
{\bf GENDECS} {\it subprogname}\$
\end{center}

By using the {\bf GENDECS} flag and function together with the template
processing facility, it is possible to have type information
inserted into the symbol table during a first pass over a template file, and
then to have it extracted during a second pass.  Consider the following
example in which the original template file is transformed into an
intermediate template during the first pass, and then into the final file
of FORTRAN code during the second pass:

Contents of file {\tt junk.tem}:
\begin{framedverbatim}
;BEGIN;                                       
MAXEXPPRINTLEN!* := 50$                       
OFF GENDECS$                                  
;END;                                         
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
;BEGIN;                                       
GENTRAN LITERAL ";BEGIN;", CR!*,              
                "GENDECS CALC$", CR!*,        
                 ";END;", CR!*$                
;END;                                         
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
;BEGIN;                                       
GENTRAN                                       
<<                                            
    DECLARE X,Y,Z,A,B,RES : REAL;           
    RES :=: (X + Y + Z)^3*(A + B)^2           
>>$                                           
;END;                                         
      RETURN                                  
      END                                     
;BEGIN;                                       
GENTRAN LITERAL ";END;", CR!*$                
;END;                                         
;END;                                         
\end{framedverbatim} 

Invocation of the template processor on this file produces an
intermediate template file:
\begin{verbatim}
1: GENTRANIN 
1:     "junk.tem" 
1: OUT "#junk.tem"$ 
\end{verbatim}
Contents of file {\tt \#junk.tem}:
\begin{framedverbatim}
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
;BEGIN;                                       
GENDECS CALC$                                 
;END;                                         
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
      T0=A**2*X**3+3.0*A**2*X**2*Y            
      T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2   
      T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2    
      T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z         
      T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3         
      T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y       
      T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2     
      T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2     
      T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z       
      T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3       
      T0=T0+B**2*X**3+3.0*B**2*X**2*Y         
      T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2   
      T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2    
      T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z         
      RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3        
      RETURN                                  
      END                                     
;END;                                         
\end{framedverbatim} 
Another pass of the template processor produced the final file of FORTRAN
code:
\begin{verbatim}
2: GENTRANIN 
2:     "#junk.tem" 
2: OUT "junk.f"$ 
\end{verbatim}
Contents of file {\tt junk.f}:
\begin{framedverbatim}
      SUBROUTINE CALC(X,Y,Z,A,B,RES)          
      REAL X,Y,Z,A,B,RES,T0                 
      X=3.75                                  
      Y=-10.2                                 
      Z=16.473                                
      T0=A**2*X**3+3.0*A**2*X**2*Y            
      T0=T0+3.0*A**2*X**2*Z+3.0*A**2*X*Y**2   
      T0=T0+6.0*A**2*X*Y*Z+3.0*A**2*X*Z**2    
      T0=T0+A**2*Y**3+3.0*A**2*Y**2*Z         
      T0=T0+3.0*A**2*Y*Z**2+A**2*Z**3         
      T0=T0+2.0*A*B*X**3+6.0*A*B*X**2*Y       
      T0=T0+6.0*A*B*X**2*Z+6.0*A*B*X*Y**2     
      T0=T0+12.0*A*B*X*Y*Z+6.0*A*B*X*Z**2     
      T0=T0+2.0*A*B*Y**3+6.0*A*B*Y**2*Z       
      T0=T0+6.0*A*B*Y*Z**2+2.0*A*B*Z**3       
      T0=T0+B**2*X**3+3.0*B**2*X**2*Y         
      T0=T0+3.0*B**2*X**2*Z+3.0*B**2*X*Y**2   
      T0=T0+6.0*B**2*X*Y*Z+3.0*B**2*X*Z**2    
      T0=T0+B**2*Y**3+3.0*B**2*Y**2*Z         
      RES=T0+3.0*B**2*Y*Z**2+B**2*Z**3        
      RETURN                                  
      END                                     
\end{framedverbatim} 

\subsection{Referencing Subprogram and Parameter Names}
\index{"!\$n parameters} \index{"!\$0 subprogram name}
In some code generation applications in which template processing is used,
it is useful to be able to reference the names of the parameters
given in the subprogram header.  For this reason, the special
symbols {\bf !\$1}, {\bf !\$2},~\dots, {\bf !\${\it n}}, where {\it n}
is the number
of parameters, can be used in computations and code generation commands in
active parts of template files.  Each of these symbols will be replaced by
the corresponding parameter name when code is generated.  In addition, the
special symbol {\bf !\$0} will be replaced by the subprogram name.  This is
useful when FORTRAN or RATFOR functions are being generated.  Finally, the
\index{"!\$"!\# in GENTRAN}
special global variable {\bf !\$!\#} is bound to the number of parameters in
the subprogram header.

\section{Output Redirection}\label{GENTRAN:output}
\index{GENTRAN ! file output}
Many examples given thus far in this manual have sent all generated code to
the terminal screen.  In actual code generation applications, however,
code must be sent to a file which will be compiled at a later
time.  This section explains methods of redirecting code to a
file as it is generated.  Any number of output files can be open
simultaneously, and generated code can be sent to any combination
of these open files.

\subsection{File Selection Commands}
\label{file:selection}
\index{OUT command} \index{SHUT command}
REDUCE provides the user with two file handling commands for output
redirection: {\bf OUT} and {\bf SHUT}.  The {\bf OUT} command takes a
single file name as argument and directs all REDUCE output to that
file from then on, until another {\bf OUT} changes the output file, or
{\bf SHUT} closes it.  Output can go to only one file at a time,
although many can be open.  If the file has previously been used for
output during the current job and not {\bf SHUT}, then the new output
is appended onto the end of the file.  Any existing file is erased
before its first use for output in a job.  To output on the terminal
without closing the output file, the reserved file name {\bf T} (for
terminal) may be used.

The REDUCE {\bf SHUT} command takes a list of names of files which
have been previously opened via an {\bf OUT} command and closes them.
Most systems require this action by the user before he ends the REDUCE
job; otherwise the output may be lost.  If a file is {\bf SHUT} and a
further {\bf OUT} command is issued for the same file, the file is
erased before the new output is written.  If it is the current output
file that is {\bf SHUT}, output will switch to the terminal.

These commands are suitable for most applications in which REDUCE
output must be saved.  However, they have two deficiencies when
considered for use in code generation applications.  First, they are
inconvenient.  {\bf OUT} tells REDUCE to direct {\it all\/} output to
a specified file.  Thus in addition to output written as side effects
of functions, returned values are also written to the file (unless the
user is careful to terminate all statements and commands with a {\bf
\$}, in which case only output produced by side effects is written).
If code generation is to be accomplished interactively; i.e., if
algebraic computations and code generation commands are interleaved,
then {\bf OUT} {\it filename\/}{\bf \$} must be issued before every
group of code generation requests, and {\bf OUT T\$} must be issued
after every group.  Secondly, the {\bf OUT} command does not allow
output to be sent to two or more files without reissuing the {\bf OUT}
with another file name.  In an effort to remove these deficiencies and
make the code generation commands flexible and easy to use, separate
file handling commands are provided by GENTRAN which redirect
generated code {\it only}.

\index{GENTRANOUT command} \index{GENTRANSHUT command}
The {\bf GENTRANOUT} and {\bf GENTRANSHUT} commands are identical to
the REDUCE {\bf OUT} and {\bf SHUT} commands with the following
exceptions:

\begin{itemize}
\item {\bf GENTRANOUT} and {\bf GENTRANSHUT} redirect {\it only\/} code which
is printed as a side effect of GENTRAN commands.
\item {\bf GENTRANOUT} allows more than one file name to be given
to indicate that generated code is to be sent to two or more
files.  (It is particularly convenient to be able to
have generated code sent to
the terminal screen and one or more file simultaneously.)
\item {\bf GENTRANOUT} does not automatically erase existing files; it prints
a warning message on the terminal and asks the user whether the existing
file should be erased or the whole command be aborted.
\end{itemize}
The next two subsections describe these commands in detail.

\index{GENTRANOUT command}
\subsubsection{GENTRANOUT}
\begin{describe}{Syntax:}
{\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
GENTRAN maintains a list of files currently open for output by
GENTRAN {\it only}.  {\bf GENTRANOUT} inserts each file name represented by
{\it f1,f2,\dots\ ,fn\/} into that list and opens each one for output.  It
also resets the current output file(s) to be all files in {\it f1,f2,\dots\
 ,fn}.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANOUT} returns the list of files represented by
{\it f1,f2,\dots\ ,fn\/};
i.e., the current output file(s) after the command has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(.75,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.7,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
1: GENTRANOUT "f1"; 

"f1"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(2.2,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
2: GENTRANOUT "f2"; 

"f2"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(5,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(3.75,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(3.7,1.5) {\vector(0,-1){.75}}
\end{picture}}


\begin{verbatim}
3: GENTRANOUT T,"f3"; 

{T,"f3"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(5.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(5.25,1.5) {\vector(0,-1){.75}}
\put(5.45,1.5) {\line(-1,0){4.70}}
\put(.75,1.5) {\vector(0,-1){.75}}
\end{picture}}


\begin{verbatim}
4: GENTRANOUT "f1"; 

"f1"
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(2.25,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(2.2,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
5: GENTRANOUT NIL,"f4"; 

{"f1","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(6,0) {\framebox(1.5,.75){"f4"}}
\put(7.5,1.5) {\makebox(0,0)[bl]{\tt current-output}}
\put(6.75,1.5) {\vector(0,-1){.75}}
\put(2.25,1.5) {\vector(0,-1){.75}}
\put(7.45,1.5) {\line(-1,0){5.2}}
\end{picture}}


\ttindex{ALL"!*}
\begin{verbatim}
6: GENTRANOUT ALL!*; 

{"f1","f2","f3","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1.5,.75){T}}
\put(1.5,0) {\framebox(1.5,.75){"f1"}}
\put(3,0) {\framebox(1.5,.75){"f2"}}
\put(4.5,0) {\framebox(1.5,.75){"f3"}}
\put(6,0) {\framebox(1.5,.75){"f4"}}
\put(7.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(6.75,1.5) {\vector(0,-1){.75}}
\put(5.25,1.5) {\vector(0,-1){.75}}
\put(3.75,1.5) {\vector(0,-1){.75}}
\put(2.25,1.5) {\vector(0,-1){.75}}
\put(7.45,1.5) {\line(-1,0){5.2}}
\end{picture}}

\end{describe}

\subsubsection{GENTRANSHUT}
\index{GENTRANSHUT command}
\begin{describe}{Syntax:}
{\bf GENTRANSHUT} {\it  f1,f2,\dots\ ,fn;\/}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANSHUT} creates a list of file names from {\it f1,f2,\dots\ ,fn},
deletes each from the output file list, and closes the
corresponding files.  If (all of) the current output file(s) are
closed, then the current output file is reset to the terminal.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANSHUT} returns the current output file(s) after the command has
been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f1"}}
\put(2,0) {\framebox(1,.75){"f2"}}
\put(3,0) {\framebox(1,.75){"f3"}}
\put(4,0) {\framebox(1,.75){"f4"}}
\put(5,0) {\framebox(1,.75){"f5"}}
\put(6,0) {\framebox(1,.75){"f6"}}
\put(7,0) {\framebox(1,.75){"f7"}}
\put(2,1.5) {\makebox(0,0) [br]{\tt current-output}}
\put(3.5,1.5) {\vector(0,-1){.75}}
\put(4.5,1.5) {\vector(0,-1){.75}}
\put(7.5,1.5) {\vector(0,-1){.75}}
\put(2.05,1.5) {\line(1,0){5.45}}
\end{picture}}

\begin{verbatim}
1: GENTRANSHUT "f1","f2","f7"; 

{"f3","f4"}
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f3"}}
\put(2,0) {\framebox(1,.75){"f4"}}
\put(3,0) {\framebox(1,.75){"f5"}}
\put(4,0) {\framebox(1,.75){"f6"}}
\put(4.5,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(1.5,1.5) {\vector(0,-1){.75}}
\put(2.5,1.5) {\vector(0,-1){.75}}
\put(4.45,1.5) {\line(-1,0){2.95}}
\end{picture}}

\begin{verbatim}
2: GENTRANSHUT NIL; 

T
\end{verbatim}
Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(1,0) {\framebox(1,.75){"f5"}}
\put(2,0) {\framebox(1,.75){"f6"}}
\put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.5,1.5) {\vector(0,-1){.75}}
\end{picture}}

\begin{verbatim}
3: GENTRANSHUT ALL!*; 

T
\end{verbatim}

Output file list:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(1,.75){T}}
\put(.55,1.5) {\makebox(0,0) [bl]{\tt current-output}}
\put(.5,1.5) {\vector(0,-1){.75}}
\end{picture}}

\end{describe}

\subsection{The Output File Stack}
Section~\ref{file:selection}
\index{files ! in GENTRAN} 
explained the {\bf GENTRANOUT} and {\bf GENTRANSHUT}
commands which are very similar to the REDUCE {\bf OUT} and {\bf SHUT}
commands but redirect {\it only code generated as side effects of GENTRAN
commands\/} to files.  This section describes another pair of file
handling commands provided by GENTRAN.

In some code generation applications it may be convenient to be
able to send generated code to one (set of) file(s), then
temporarily send code to another (set of) file(s), and later
resume sending generated code to the first (set of) file(s).  In
other words, it is convenient to think of the output files as
being arranged in a stack which can be pushed whenever new
files are to be written to temporarily, and popped whenever
previously written-to files are to be appended onto.  {\bf GENTRANPUSH}
\index{GENTRANPUSH command} \index{GENTRANPOP command}
and {\bf GENTRANPOP} enable the user to manipulate a stack of open
output files in these ways.

{\bf GENTRANPUSH} simply pushes a (set of) file(s) onto
the stack and opens each one that is not already open for
output.  {\bf GENTRANPOP} deletes the top-most occurrence of
the given file(s) from the stack and closes each one that is no
longer in the stack.  The stack is initialized to one element:  the
terminal.  This element is always on the bottom of the stack, and thus,
is the default output file.  The current output file is always the
file(s) on top of the stack.

\subsubsection{GENTRANPUSH}
\index{GENTRANPUSH command}
\begin{describe}{Syntax:}
{\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANPUSH} creates a list of file name(s) represented by
{\it f1,f2,\dots\ ,fn\/} and pushes that list onto the output stack.  Each file
in the list that is not already open for output is opened at this time.  The
current output file is reset to this new element on the top of the stack.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANPUSH} returns the list of files represented by 
{\it f1,f2,\dots\ ,fn\/};
i.e., the current output file(s) after the command has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS
    OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1)(0,0)
\put(0,0) {\framebox(3,1){}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,.5) {\vector(-1,0){1}}
\put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}


\begin{verbatim}
1: GENTRANPUSH "f1"; 

"f1"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1.5)(0,0)
\put(0,0) {\framebox(3,1.5){}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,1) {\vector(-1,0){1}}
\put(4.1,1) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
2: GENTRANPUSH "f2","f3"; 

{"f2","f3"}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2)(0,0)
\put(0,0) {\framebox(3,2){}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,1.5) {\vector(-1,0){1}}
\put(4.1,1.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
3: GENTRANPUSH NIL,T; 

{"f2","f3",T}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2.5)(0,0)
\put(0,0) {\framebox(3,2.5){}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2) {\vector(-1,0){1}}
\put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
4: GENTRANPUSH "f1"; 

"f1"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3)(0,0)
\put(0,0) {\framebox(3,3){}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2.5) {\vector(-1,0){1}}
\put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
5: GENTRANPUSH ALL!*; 

{"f1","f2","f3"}
\end{verbatim}

Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3.5)(0,0)
\put(0,0) {\framebox(3,3.5){}}
\put(0.25,3) {\makebox(0,0)[cl]{"f1" "f2" "f3"}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,2) {\makebox(0,0)[cl]{"f2" "f3" T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f2" "f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3) {\vector(-1,0){1}}
\put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\end{describe}

\subsubsection{GENTRANPOP}
\index{GENTRANPOP command}
\begin{describe}{Syntax:}
{\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fn\/} is a list of one or more {\it f\/}'s, where each 
{\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom} & = & an output file\\
{\bf T} & = & the terminal\\
{\bf NIL} & = & the current output file(s)\\
{\bf ALL!*} & = & all files currently open for output \\
& & by GENTRAN\\
\end{tabular}
\end{center}
\end{describe}
\begin{describe}{Side Effects:}
{\bf GENTRANPOP} deletes the top-most occurrence of the single element
containing the file name(s) represented by {\it f1,f2,\dots\ ,fn\/}
from the output stack.  Files whose names have been completely removed from
the output stack are closed.  The current output file is reset to the
(new) element on the top of the output stack.
\end{describe}
\begin{describe}{Returned Value:}
{\bf GENTRANPOP} returns the current output file(s) after this command
has been executed.
\end{describe}
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** FILE NOT OPEN FOR OUTPUT

***** WRONG TYPE OF ARG
\end{verbatim}
\end{describe}
\begin{describe}{\example}\index{GENTRAN package ! example}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,4)(0,0)
\put(0,0) {\framebox(3,4){}}
\put(0.25,3.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3.5) {\vector(-1,0){1}}
\put(4.1,3.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
1: GENTRANPOP NIL; 

{"f4","f2",T}
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3.5)(0,0)
\put(0,0) {\framebox(3,3.5){}}
\put(0.25,3) {\makebox(0,0)[cl]{"f4" "f2" T}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,3) {\vector(-1,0){1}}
\put(4.1,3) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
2: GENTRANPOP NIL; 

"f4"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,3)(0,0)
\put(0,0) {\framebox(3,3){}}
\put(0.25,2.5) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,2) {\makebox(0,0)[cl]{T}}
\put(0.25,1.5) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,1) {\makebox(0,0)[cl]{"f2" "f1"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2.5) {\vector(-1,0){1}}
\put(4.1,2.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
3: GENTRANPOP "f2","f1"; 

"f4"
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,2.5)(0,0)
\put(0,0) {\framebox(3,2.5){}}
\put(0.25,2) {\makebox(0,0)[cl]{"f4"}}
\put(0.25,1.5) {\makebox(0,0)[cl]{T}}
\put(0.25,1) {\makebox(0,0)[cl]{"f3"}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,2) {\vector(-1,0){1}}
\put(4.1,2) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\begin{verbatim}
4: GENTRANPOP ALL!*; 

T
\end{verbatim}
Output stack:

{\setlength{\unitlength}{1cm}
\begin{picture}(10,1)(0,0)
\put(0,0) {\framebox(3,1){}}
\put(0.25,.5) {\makebox(0,0)[cl]{T}}
\put(4,.5) {\vector(-1,0){1}}
\put(4.1,.5) {\makebox(0,0)[cl]{\tt current-output}}
\end{picture}}

\end{describe}

\subsection{Temporary Output Redirection}
Sections~\ref{translation} and ~\ref{templates}
explain how to use the code generation and
template processing commands.  The syntax for these two commands
is:
\index{output redirection (temporary)}
\index{GENTRAN command} \index{GENTRANIN command}

\begin{tabular}{lll}
&\multicolumn{2}{l}{{\bf GENTRAN} {\it stmt\/} [{\bf OUT} {\it f1,f2,\dots\
 ,fn\/}]{\it ;}}\\
&&and\\
&\multicolumn{2}{l}{{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT}
 {\it  f1,f2,\dots\ ,fn\/}]{\it ;}}\\
\end{tabular}

The optional parts of these two commands can be used for {\it temporary}
output redirection; they can be used when the current output
file is to be temporarily reset, for this command only.

Thus the following two sequences of commands are equivalent:
\begin{verbatim}
10: GENTRANPUSH "f1",T$ 

11: GENTRAN ... $

12: GENTRANPOP NIL$
\end{verbatim}

and

\begin{verbatim}
10: GENTRAN 
10:    ...
10: OUT "f1",T$
\end{verbatim}

\section{Modification of the Code Generation Process}\label{GENTRAN:mod}

GENTRAN is designed to be flexible enough to be used in a variety of
code generation applications.  For this reason, several mode
switches and variables are provided to enable the user to tailor the
code generation process to meet his or her particular needs.

\subsection{Mode Switches}
\index{GENTRAN package ! switches}
The following GENTRAN mode switches can be turned on and off with the
REDUCE {\bf ON} and {\bf OFF} commands.

\begin{describe}{DOUBLE}
\index{DOUBLE switch} \index{precision}
\begin{itemize}
\item When turned on, causes (where appropriate):
\begin{itemize}
\item floating point numbers to be printed in double precision format;
\item intrinsic functions to be replaced by their double precision
counterparts;
\item generated type declarations to be of double precision form.
\end{itemize}
See also section~\ref{precision} on page~\pageref{precision}.
\item default setting: off
\end{itemize}
\end{describe}

\begin{describe}{GENDECS}
\index{GENDECS switch}
\begin{itemize}
\item when turned on, allows type declarations to be generated automatically;
otherwise, type information is stored in but not automatically retrieved
from the symbol table.  See also sections~\ref{explicit:type} on
page~\pageref{explicit:type}, \ref{more:type} on page~\pageref{more:type},
and \ref{template:type} on page~\pageref{template:type}.
\item default setting:  on
\end{itemize}
\end{describe}

\begin{describe}{GENTRANOPT}
\index{GENTRANOPT switch}
\begin{itemize}
\item when turned on, replaces each block of straightline code by
an optimized sequence of assignments.
The Code Optimizer takes a sequence of assignments and replaces common
subexpressions with temporary variables.  It returns the resulting assignment
statements with common-subexpression-to-temporary-variable assignment
statements preceding them
\item default setting:  off
\end{itemize} 
\end{describe} 

\begin{describe}{GENTRANSEG} 
\index{GENTRANSEG switch}
\begin{itemize}
\item when turned on, checks the print length of expressions and breaks
those expressions that are longer than {\bf MAXEXPPRINTLEN!*} down
\ttindex{MAXEXPPRINTLEN"!*}
into subexpressions which are assigned to temporary variables.
See also section~\ref{segmentation} on page~\pageref{segmentation}.
\item default setting:  on
\end{itemize}
\end{describe}

\begin{describe}{GETDECS}
\index{GETDECS switch}
\begin{itemize}
\item when on, causes:
\begin{itemize}
\item the indices of loops to be declared integer;
\item objects without an explicit type declaration to be declared of the type
given by the variable {\bf DEFTYPE!*}. \ttindex{DEFTYPE"!*}
\end{itemize}
See also section~\ref{implicit:type} on page~\pageref{implicit:type}.
\item default setting:  off
\end{itemize}
\end{describe}

\begin{describe}{KEEPDECS}
\index{KEEPDECS switch}
\begin{itemize}
\item when on, prevents declarations being removed from the symbol table when
type declarations are generated.
\item default: off
\end{itemize}
\end{describe}

\begin{describe}{MAKECALLS}
\index{MAKECALLS switch}
\begin{itemize}
\item when turned on, causes GENTRAN to translate functional expressions as
subprogram calls.
\item default setting: on
\end{itemize}
\end{describe}

\begin{describe}{PERIOD}
\index{PERIOD switch}
\begin{itemize}
\item when turned on, causes all integers to be printed out as floating point
numbers except:
\begin{itemize}
\item exponents;
\item variable subscripts;
\item index values in DO-type loops;
\item those which have been declared to be integers.
\end{itemize}
\item default setting:  on
\end{itemize}
\end{describe}


\subsection{Variables}
\index{GENTRAN package ! variables}
Several global variables are provided in GENTRAN to enable the
user to
\begin{itemize}
\item select the target language
\item control expression segmentation
\item change automatically generated variable names and statement numbers
\item modify the code formatter
\end{itemize}

The following four subsections describe these variables\footnote{
Note that when an atomic value (other than an integer) is assigned to a
variable, that value must be quoted.  For example,
{\bf GENTRANLANG!* := 'FORTRAN\$}
assigns the atom {\bf FORTRAN} to the variable {\bf GENTRANLANG!*}.}.

\subsubsection{Target Language Selection}
\begin{describe}{GENTRANLANG!*}
\ttindex{GENTRANLANG"!*}
\begin{itemize}
\item target language (FORTRAN, RATFOR, PASCAL or C)
See also section~\ref{gentranlang} on page~\pageref{gentranlang}.
\item value type:  atom
\item default value:  FORTRAN
\end{itemize}
\end{describe}

\subsubsection{Expression Segmentation Control}
\begin{describe}{MAXEXPPRINTLEN!*}
\ttindex{MAXEXPPRINTLEN"!*}
\begin{itemize}
\item value used to determine whether or not an expression should be
segmented; maximum number of characters permitted in an expression
in the target language (excluding spaces printed for formatting).
See also section~\ref{segmentation} on page~\pageref{segmentation}.
\item value type:  integer
\item default value:  800
\end{itemize}
\end{describe} 

\subsubsection{Variable Names \& Statement Numbers}
\begin{describe}{TEMPVARNAME!*}
\ttindex{TEMPVARNAME"!*}
\begin{itemize}
\item name used as prefix in generating temporary variable names.
See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  atom
\item default value:  T
\end{itemize}
\end{describe}

\begin{describe}{TEMPVARNUM!*}
\ttindex{TEMPVARNUM"!*}
\begin{itemize}
\item number appended to {\bf TEMPVARNAME!*} to create a temporary variable
name. If the temporary variable name resulting from appending
{\bf TEMPVARNUM!*} onto {\bf TEMPVARNAME!*} has already been generated
and still holds a useful value, then {\bf TEMPVARNUM!*} is incremented
and temporary variable names are compressed until one is found which
was not previously generated or does not still hold a significant value.
See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{TEMPVARTYPE!*}
\ttindex{TEMPVARTYPE"!*}
\begin{itemize}
\item target language variable type (e.g., INTEGER, REAL!*8, FLOAT, etc) used
as a default for automatically generated variables whose type cannot be
determined otherwise.  If {\bf TEMPVARTYPE!*} is NIL, then generated
temporary variables whose type cannot be determined are not automatically
declared.  See also section~\ref{tempvars} on page~\pageref{tempvars}.
\item value type:  atom
\item default value:  NIL
\end{itemize}
\end{describe}

\begin{describe}{GENSTMTNUM!*}
\ttindex{GENSTMTNUM"!*}
\begin{itemize}
\item number used when a statement number must be generated
\item value type:  integer
\item default value:  25000
\end{itemize}
\end{describe}

\begin{describe}{GENSTMTINCR!*}
\ttindex{GENSTMTINCR"!*}
\begin{itemize}
\item number by which {\bf GENSTMTNUM!*} is increased each time a new
statement number is generated.
\item value type:  integer
\item default value:  1
\end{itemize}
\end{describe}

\begin{describe}{DEFTYPE!*}
\ttindex{DEFTYPE"!*}
\begin{itemize}
\item default type for objects when the switch {\bf GETDECS} is on.  See also
section~\ref{implicit:type} on page~\pageref{implicit:type}.
\item value type: atom
\item default value: real
\end{itemize}
\end{describe}

\subsubsection{Code Formatting}
\begin{describe}{FORTCURRIND!*}
\ttindex{FORTCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated FORTRAN code beyond column 6
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{RATCURRIND!*}
\ttindex{RATCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated RATFOR code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{CCURRIND!*}
\ttindex{CCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated C code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{PASCCURRIND!*}
\ttindex{PASCCURRIND"!*}
\begin{itemize}
\item number of blank spaces printed at the beginning of each line of
generated PASCAL code.
\item value type:  integer
\item default value:  0
\end{itemize}
\end{describe}

\begin{describe}{TABLEN!*}
\ttindex{TABLEN"!*}
\begin{itemize}
\item number of blank spaces printed for each new level of indentation.
\item value type:  integer
\item default value:  4
\end{itemize}
\end{describe}

\begin{describe}{FORTLINELEN!*}
\ttindex{FORTLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated FORTRAN
code.
\item value type:  integer
\item default value:  72
\end{itemize}
\end{describe}

\begin{describe}{RATLINELEN!*}
\ttindex{RATLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated RATFOR
code.
\item value type:  integer
\item default value:  80
\end{itemize}
\end{describe}

\begin{describe}{CLINELEN!*}
\ttindex{CLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated C code.
\item value type:  integer
\item default value:  80
\end{itemize} 
\end{describe}

\begin{describe}{PASCLINELEN!*}
\ttindex{PASCLINELEN"!*}
\begin{itemize}
\item maximum number of characters printed on each line of generated PASCAL
code.
\item value type:  integer
\item default value:  70
\end{itemize}
\end{describe}

\begin{describe}{MINFORTLINELEN!*}
\ttindex{MINFORTLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated FORTRAN
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}

\begin{describe}{MINRATLINELEN!*}
\ttindex{MINRATLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated RATFOR
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}
 
\begin{describe}{MINCLINELEN!*}
\ttindex{MINCLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated C
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe}

\begin{describe}{MINPASCLINELEN!*}
\ttindex{MINPASCLINELEN"!*}
\begin{itemize}
\item minimum number of characters printed on each line of generated PASCAL
code after indentation.
\item value type:  integer
\item default value:  40
\end{itemize} 
\end{describe} 

\section{Examples}\label{GENTRAN:examples}
\index{GENTRAN package ! example}

Short examples have been given throughout this manual to illustrate
usage of the GENTRAN commands.  This section gives complete code
generation examples.

\subsection{Interactive Code Generation} \index{GENTRAN package ! example}
\index{interactive code generation}
Suppose we wish to generate a FORTRAN subprogram which can be used for
\index{Graeffe's Root-Squaring Method}
computing the roots of a polynomial by Graeffe's Root-Squaring Method\footnote{
This is for instance convenient for ill-conditioned polynomials.  More
details are given in {\it Introduction to Numerical Analysis\/} by
C. E. Froberg, Addison-Wesley Publishing Company, 1966.}. This
method states that the roots $x_i$ of a polynomial
$$P_n(x) = \sum_{i=0}^{n}{a_i x^{n-i}} $$
can be found by constructing the polynomial
$$P^{*}_n\left({x^2}\right) = \left( a_0x^n + a_2x^{n-2} + \dots\right)^2 -
\left( a_1x^{n-1} + a_3x^{n-3} + \dots\right)^2$$
with roots $x_i^2$
When read into REDUCE, the following file of REDUCE statements
will place the coefficients of $P^{*}_n$
into the list B for some user-entered value of n greater than zero.

Contents of file {\tt graeffe.red}:\footnote{
In accordance with section~\ref{explicit:type},
the subscripts of A are I+1 instead of I.}
\begin{framedverbatim}
OPERATOR A$                                               
Q := FOR I := 0 STEP 2 UNTIL n   SUM (A(I+1)*X^(n-I))$
R := FOR I := 1 STEP 2 UNTIL n-1 SUM (A(I+1)*X^(n-I))$    
P := Q^2 - R^2$                                           
LET X^2 = Y$                                              
B := COEFF(P,Y)$                                             
END$                                                      
\end{framedverbatim}

Now a numerical subprogram can be generated with assignment
statements for the coefficients of $P^{*}_n$ (now stored in list B in
REDUCE).  Since these coefficients are given in terms of the coefficients
of $P_n$ (i.e., operator A in REDUCE), the subprogram will need two
parameters:  A and B, each of which must be arrays of size n+1.

The following REDUCE session will create subroutine GRAEFF for a polynomial
of degree n=10 and write it to file {\tt graeffe.f}:
{\small
\begin{verbatim}
1: n := 10$ 

2: IN "graeffe.red"$

3: GENTRANLANG!* := 'FORTRAN$ 

4: ON DOUBLE$

5: GENTRAN 
5: ( 
5:      PROCEDURE GRAEFF(A,B); 
5:      BEGIN 
5:      DECLARE 
5:      << 
5:          GRAEFF : SUBROUTINE; 
5:          A(11),B(11) : REAL
5:      >>; 
5:      LITERAL 
5:       "C",CR!*, 
5:       "C",TAB!*,"GRAEFFE ROOT-SQUARING METHOD TO FIND",CR!*,
5:       "C",TAB!*,"ROOTS OF A POLYNOMIAL",CR!*, 
5:       "C",CR!*; 
5:      B(1) :=: PART (B,1);
5:      B(2) :=: PART (B,2);
5:      B(3) :=: PART (B,3);
5:      B(4) :=: PART (B,4);
5:      B(5) :=: PART (B,5);
5:      B(6) :=: PART (B,6);
5:      B(7) :=: PART (B,7);
5:      B(8) :=: PART (B,8);
5:      B(9) :=: PART (B,9);
5:      B(10) :=: PART (B,10);
5:      B(11) :=: PART (B,11)
5:      END 
5: ) 
5: OUT "graeffe.f"$ 
\end{verbatim}
}

Contents of file {\tt graeffe.f}:
\begin{framedverbatim}
      SUBROUTINE GRAEFF(A,B)
      DOUBLE PRECISION A(11),B(11)
C
C     GRAEFFE ROOT-SQUARING METHOD TO FIND
C     ROOTS OF A POLYNOMIAL
C
      B(1)=A(11)**2
      B(2)=2.0D0*A(11)*A(9)-A(10)**2
      B(3)=2.0D0*A(11)*A(7)-(2.0D0*A(10)*A(8))+A(9)**2
      B(4)=2.0D0*A(11)*A(5)-(2.0D0*A(10)*A(6))+2.0D0*A(9)*A(7
     . )-A(8)**2
      B(5)=2.0D0*A(11)*A(3)-(2.0D0*A(10)*A(4))+2.0D0*A(9)*A(5
     . )-(2.0D0*A(8)*A(6))+A(7)**2
      B(6)=2.0D0*A(11)*A(1)-(2.0D0*A(10)*A(2))+2.0D0*A(9)*A(3
     . )-(2.0D0*A(8)*A(4))+2.0D0*A(7)*A(5)-A(6)**2
      B(7)=2.0D0*A(9)*A(1)-(2.0D0*A(8)*A(2))+2.0D0*A(7)*A(3)-
     . (2.0D0*A(6)*A(4))+A(5)**2
      B(8)=2.0D0*A(7)*A(1)-(2.0D0*A(6)*A(2))+2.0D0*A(5)*A(3)-
     . A(4)**2
      B(9)=2.0D0*A(5)*A(1)-(2.0D0*A(4)*A(2))+A(3)**2
      B(10)=2.0D0*A(3)*A(1)-A(2)**2
      B(11)=A(1)**2
      RETURN
      END
\end{framedverbatim}

\subsection{Code Generation, Segmentation \& Temporary Variables}
\index{GENTRAN package ! example}
The following 3 x 3 inertia matrix M was derived in the course of
some research \footnote{For details see:
Bos, A. M. and M. J. L. Tiernego.  ``Formula Manipulation in the
Bond Graph Modelling and Simulation of Large Mechanical Systems'',
{\it Journal of the Franklin Institute} , Pergamon Press Ltd.,
Vol. 319, No. 1/2, pp. 51-65, January/February 1985.}:
\begin{eqnarray*}
M(1,1) & = & 18*\cos (q_3)*\cos (q_2)*m_{30}*p^2 - \sin ^2(q_3) *j_{30}y +
 \sin ^2(q_3) \\
  & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2  + j_{10}y + j_{30}y +
 m_{10}*p^2  + \\
 & & 18*m_{30}*p^2\\
M(1,2) & = & 9*\cos (q_3)*\cos (q_2)*m_{30}*p^2  - \sin ^2(q_3) *j_{30}y
 +\sin ^2(q_3) \\
  & & *j_{30}z - 9*\sin ^2(q_3) *m_{30}*p^2 + j_{30}y + 9* m_{30}*p^2\\
M(2,1) & = & M(1,2)\\
M(1,3) & = & - 9*\sin (q_3)*\sin (q_2)*m_{30}*p^2\\
M(3,1) & = & M(1,3)\\
M(2,2) & = & - \sin ^2(q_3) *j_{30}y + \sin ^2(q_3) *j_{30}z -
 9*\sin ^2(q_3)*m_{30}*p^2 \\
& & + j_{30}y + 9*m_{30}*p^2\\
M(2,3) & = & 0\\
M(3,2) & = & M(2,3)\\
M(3,3) & = & 9*m_{30}*p^2 + j_{30}x\\
\end{eqnarray*}
We know M is symmetric.  We wish to generate numerical code
to compute values for M and its inverse matrix.

\subsubsection{Code Generation}
\label{code:example}
Generating code for matrix M and its inverse matrix is
straightforward.  We can simply generate an assignment statement
for each element of M, compute the inverse matrix MIV, and generate
an assignment statement for each element of MIV.  Since we
know M is symmetric, we know that MIV will also be symmetric.  To
avoid duplicate computations, we will not generate assignments
for elements below the main diagonals of these matrices.  Instead,
we will copy elements across the main diagonal by generating
nested loops.  The following REDUCE session will write to the file {\tt m1.f}:

\begin{verbatim}
1: IN "m.red"$ % Initialize M

2: GENTRANOUT "m1.f"$ 

3: GENTRANLANG!* := 'FORTRAN$

4: ON DOUBLE$

5: FOR J := 1 : 3 DO 
5:      FOR K := J : 3 DO 
5:          GENTRAN M(J,K) ::=: M(J,K)$

6: MIV := M^(-1)$ 

7: FOR J := 1 : 3 DO 
7:      FOR K := J : 3 DO 
7:          GENTRAN MIV(J,K) ::=: MIV(J,K)$

8: GENTRAN 
8:      FOR J := 1 : 3 DO 
8:          FOR K := J+1 : 3 DO 
8:          << 
8:              M(K,J) := M(J,K); 
8:              MIV(K,J) := MIV(J,K) 
8:          >>$ 

9: GENTRANSHUT "m1.f"$
\end{verbatim}
The contents of {\tt m1.f} are reproduced in~\ref{appc} on page~\pageref{appc}.

This code was generated with the segmentation facility turned off.  However,
most FORTRAN compilers cannot handle statements more than 20 lines
long.  The next section shows how to generate segmented assignments.

\subsubsection{Segmentation}
\label{seg:example}
\index{segmented assignments}
Large arithmetic expressions can be broken into pieces of manageable
size with the expression segmentation facility.  The following REDUCE
session will write segmented assignment statements to the
file {\tt m2.f}.  Large arithmetic expressions will be broken into
subexpressions of approximately 300 characters in length.

\begin{verbatim}
1: IN "m.red"$ % Initialize M

2: GENTRANOUT "m2.f"$ 

3: ON DOUBLE$

4: ON GENTRANSEG$ 

5: MAXEXPPRINTLEN!* := 300$ 

6: FOR J := 1 : 3 DO 
6:      FOR K := J : 3 DO 
6:          GENTRAN M(J,K) ::=: M(J,K)$ 

7: MIV := M^(-1)$ 

8: FOR J := 1 : 3 DO 
8:      FOR K := J : 3 DO 
8:          GENTRAN MIV(J,K) ::=: MIV(J,K)$ 

9: GENTRAN 
9:      FOR J := 1 : 3 DO 
9:          FOR K := J+1 : 3 DO 
9:          << 
9:              M(K,J) := M(J,K); 
9:              MIV(K,J) := MIV(J,K) 
9:          >>$ 

10: GENTRANSHUT "m2.f"$ 
\end{verbatim}

The contents of file {\tt m2.f} are reproduced in~\ref{appc} on
page~\pageref{appc}.

\subsubsection{Generation of Temporary Variables to Suppress Simplification}
\label{tempvar:example}
We can dramatically improve the efficiency of the code generated
in sections~\ref{code:example} on page~\pageref{code:example} and
\ref{seg:example} on page~\pageref{seg:example}
by replacing expressions by temporary variables before computing the
inverse matrix.  This effectively suppresses simplification; these
expressions will not be substituted into later computations.  We
will replace each non-zero element of the REDUCE matrix M by a
generated variable name, and generate a numerical assignment statement
to reflect that substitution in the numerical program being generated.

The following REDUCE session will write to the file {\tt m3.f}:
\begin{verbatim}
1: in "m.red"$ % Initialize M

2: GENTRANOUT "m3.f"$ 

3: GENTRANLANG!* := 'FORTRAN$ 

4: ON DOUBLE$

5: FOR J := 1 : 3 DO 
5:      FOR K := J : 3 DO 
5:          GENTRAN M(J,K) ::=: M(J,K)$ 

6: SHARE VAR$ 

7: FOR J := 1 : 3 DO 
7:      FOR K := J : 3 DO 
7:          IF M(J,K) NEQ 0 THEN 
7:          << 
7:              VAR := TEMPVAR(NIL)$ 
7:              MARKVAR VAR$ 
7:              M(J,K) := VAR$ 
7:              M(K,J) := VAR$ 
7:              GENTRAN 
7:                  EVAL(VAR) := M(EVAL(J),EVAL(K)) 
7:          >>$ 

8: COMMENT ** Contents of matrix M: **$ 

9: M; 

[T0  T1  T2]
[          ]
[T1  T3  0 ]
[          ]
[T2  0   T4]


10: MIV := M^(-1)$ 

11: FOR J := 1 : 3 DO 
11:      FOR K := J : 3 DO 
11:          GENTRAN MIV(J,K) ::=: MIV(J,K)$ 

12: GENTRAN 
12:      FOR J := 1 : 3 DO 
12:          FOR K := J+1 : 3 DO 
12:          << 
12:              M(K,J) := M(J,K); 
12:              MIV(K,J) := MIV(J,K) 
12:          >>$ 

13: GENTRANSHUT "m3.f"$ 
\end{verbatim}

Contents of file {\tt m3.f}:

\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y
      M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE(
     . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y
      M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      T0=M(1,1)
      T1=M(1,2)
      T2=M(1,3)
      T3=M(2,2)
      T4=M(3,3)
      MIV(1,1)=-(T4*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(1,2)=(T4*T1)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(1,3)=(T2*T3)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(2,2)=(-(T4*T0)+T2**2)/(T4*T1**2-(T4*T3*T0)+T2**2*
     . T3)
      MIV(2,3)=-(T1*T2)/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      MIV(3,3)=(T1**2-(T3*T0))/(T4*T1**2-(T4*T3*T0)+T2**2*T3)
      DO 25009 J=1,3
          DO 25010 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25010     CONTINUE
25009 CONTINUE
\end{framedverbatim}

\subsection{Template Processing} \index{template processing}
\index{GENTRAN package ! example} \index{Automatic Circuitry Code Generator}
Circuit simulation plays a vital role in computer hardware
development.  A recent paper\footnote{Loe, K. F., N. Ohsawa, and E.
Goto.  ``Design of an Automatic Circuitry Code Generator (ACCG)'',
{\it RSYMSAC Proceedings}, Wako-shi, Saitama, Japan.  1984.} describes
the design of an Automatic Circuitry Code Generator (ACCG), which
generates circuit simulation programs based on user-supplied circuit
specifications.  The actual code generator consists of a series of
REDUCE {\bf WRITE} statements, each of which writes one line of
FORTRAN code.

This section presents an alternative implementation for the ACCG
which uses GENTRAN's template processor to generate code.  Template
processing is a much more natural method of code generation than the
REDUCE {\bf WRITE} statement method.

First we will put all REDUCE calculations into two files:  {\tt rk.red} and
{\tt ham.red}.

Contents of file {\tt rk.red}:\footnote{
Line 11 of procedure RUNGEKUTTA was changed from
\begin{center}
{\tt K41 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);}
\end{center}
as given in (Loe84), to
\begin{center}
{\tt K42 := HH*SUB(TT=TT+HH, P=P+K31, Q=Q+K32, P2);}
\end{center}
}
\begin{framedverbatim}
COMMENT  -- RUNGE-KUTTA METHOD --$                        
PROCEDURE RUNGEKUTTA(P1, P2, P, Q, TT);                   
BEGIN                                                     
SCALAR K11,K12,K21,K22,K31,K32,K41,K42;                   
K11 := HH*P1;                                             
K12 := HH*P2;                                             
K21 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P1);      
K22 := HH*SUB(TT=TT+HH/2, P=P+K11/2, Q=Q+K12/2, P2);      
K31 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P1);      
K32 := HH*SUB(TT=TT+HH/2, P=P+K21/2, Q=Q+K22/2, P2);      
K41 := HH*SUB(TT=TT+HH,   P=P+K31,   Q=Q+K32,   P1);      
K42 := HH*SUB(TT=TT+HH,   P=P+K31,   Q=Q+K32,   P2);
PN := P + (K11 + 2*K21 + 2*K31 + K41)/6;                  
QN := Q + (K12 + 2*K22 + 2*K32 + K42)/6                   
END$                                                      
END$                                                      
\end{framedverbatim}

Contents of file {\tt ham.red}:

\begin{framedverbatim}
COMMENT  -- HAMILTONIAN CALCULATION --$                   
DIFQ := DF(H,P)$                                          
DIFP := -DF(H,Q) - SUB(QDOT=P/M, DF(D,QDOT))$             
RUNGEKUTTA(DIFP, DIFQ, P, Q, TT)$                         
END$                                                      
\end{framedverbatim}

Next we will create a template file with an outline of the target
FORTRAN program and GENTRAN commands.

Contents of file {\tt runge.tem}:

\begin{framedverbatim}
      PROGRAM RUNGE                                       
      IMPLICIT DOUBLE PRECISION (K,M)                                 
C                                                         
C  INPUT                                                  
C                                                         
      WRITE(6,*) 'INITIAL VALUE OF P'                     
      READ(5,*) P                                         
      WRITE(6,*) ' P = ', P                               
      WRITE(6,*) 'INITIAL VALUE OF Q'                     
      READ(5,*) Q                                         
      WRITE(6,*) ' Q = ', Q                               
      WRITE(6,*) 'VALUE OF M'                             
      READ(5,*) M                                         
      WRITE(6,*) ' M = ', M                               
      WRITE(6,*) 'VALUE OF K0'                            
      READ(5,*) K0                                        
      WRITE(6,*) ' K0 = ', K0                             
      WRITE(6,*) 'VALUE OF B'                             
      READ(5,*) B                                         
      WRITE(6,*) ' B = ', B                               
      WRITE(6,*) 'STEP SIZE OF T'                         
      READ(5,*) HH                                        
      WRITE(6,*) ' STEP SIZE OF T = ', HH                 
      WRITE(6,*) 'FINAL VALUE OF T'                       
      READ(5,*) TP                                        
      WRITE(6,*) ' FINAL VALUE OF T = ', TP               
C                                                         
C  INITIALIZATION                                         
C                                                         
      TT=0.0D0
;BEGIN;  
      GENTRAN                                             
        LITERAL                                           
          TAB!*, "WRITE(9,*) ' H = ", EVAL(H), "'", CR!*, 
          TAB!*, "WRITE(9,*) ' D = ", EVAL(D), "'", CR!*$ 
;END;                                                     
      WRITE(9,901) C                                      
901   FORMAT(' C= ',D20.10)                               
      WRITE(9,910) TT, Q, P                               
910   FORMAT(' '3D20.10)                                  
C                                                         
C  LOOP                                                   
C                                                         
;BEGIN;                                                   
      GENTRAN                                             
          REPEAT                                          
          <<                                              
              PN :=: PN;                                  
              Q  :=: QN;                                  
              P  := PN;                                   
              TT := TT + HH;                              
              LITERAL                                     
                TAB!*, "WRITE(9,910) TT, QQ, P", CR!*     
          >>                                              
          UNTIL TT >= TF$                                 
;END;                                                     
      STOP                                                
      END                                                 
;END;                                                     
\end{framedverbatim}

Now we can generate a circuit simulation program simply by starting
a REDUCE session and following three steps:
\begin{enumerate}
\item Enter circuit specifications.
\item Perform calculations.
\item Call the GENTRAN template processor.
\end{enumerate}
For example, the following REDUCE session will write a simulation
program to the file {\tt runge.f}:
\begin{verbatim}
1: COMMENT  -- INPUT --$ 

2: K := 1/(2*M)*P^2$    % kinetic energy 

3: U := K0/2*Q^2$       % potential energy 

4: D := B/2*QDOT$       % dissipating function 

5: H := K + U$          % hamiltonian 

6: COMMENT  -- CALCULATIONS --$ 

7: IN "rk.red", "ham.red"$ 

8: COMMENT  -- FORTRAN CODE GENERATION --$ 

9: GENTRANLANG!* := 'FORTRAN$ 

10: ON DOUBLE$

11: GENTRANIN "runge.tem" OUT "runge.f"$ 
\end{verbatim}

Contents of file {\tt runge.f}:
\begin{framedverbatim}
      PROGRAM RUNGE
      IMPLICIT DOUBLE PRECISION (K,M)
C
C  INPUT
C
      WRITE(6,*) 'INITIAL VALUE OF P'
      READ(5,*) P
      WRITE(6,*) ' P = ', P
      WRITE(6,*) 'INITIAL VALUE OF Q'
      READ(5,*) Q
      WRITE(6,*) ' Q = ', Q
      WRITE(6,*) 'VALUE OF M'
      READ(5,*) M
      WRITE(6,*) ' M = ', M
      WRITE(6,*) 'VALUE OF K0'
      READ(5,*) K0
      WRITE(6,*) ' K0 = ', K0
      WRITE(6,*) 'VALUE OF B'
      READ(5,*) B
      WRITE(6,*) ' B = ', B
      WRITE(6,*) 'STEP SIZE OF T'
      READ(5,*) HH
      WRITE(6,*) ' STEP SIZE OF T = ', HH
      WRITE(6,*) 'FINAL VALUE OF T'
      READ(5,*) TP
      WRITE(6,*) ' FINAL VALUE OF T = ', TP
C
C  INITIALIZATION
C
      TT=0.0D0                     
      WRITE(9,*) ' H = (M*Q**2*K0+P**2)/(2.0D0*M)'
      WRITE(9,*) ' D = (B*QDOT)/2.0D0'
      WRITE(9,901) C
901   FORMAT(' C= ',D20.10)
      WRITE(9,910) TT, Q, P
910   FORMAT(' '3D20.10)
C
C  LOOP
C
25001 CONTINUE
          PN=(-(12.0D0*B*M**2*HH)+2.0D0*B*M*K0*HH**3+24.0D0*
     .     M**2*P-(24.0D0*M**2*Q*K0*HH)-(12.0D0*M*P*K0*HH**2)
     .     +4.0D0*M*Q*K0**2*HH**3+P*K0**2*HH**4)/(24.0D0*M**2
     .     )
          Q=(-(12.0D0*B*M*HH**2)+B*K0*HH**4+48.0D0*M**2*Q+
     .     48.0D0*M*P*HH-(24.0D0*M*Q*K0*HH**2)-(8.0D0*P*K0*HH
     .     **3)+2.0D0*Q*K0**2*HH**4)/(48.0D0*M**2)
          P=PN
          TT=TT+HH
          WRITE(9,910) TT, QQ, P
      IF (.NOT.TT.GE.TF) GOTO 25001
      STOP
      END
\end{framedverbatim}

\section{Symbolic Mode Functions}
\index{symbolic mode ! in GENTRAN}

Thus far in this manual, commands have been presented which are meant
to be used primarily in the algebraic mode of REDUCE.  These commands
are designed to be used interactively.  However, many code generation
applications require code to be generated under program control\footnote{
\cite{vandenHeuvel:86ms} contains one such example.}. In these
applications, it is generally more convenient to generate code from
(computed) prefix forms.  Therefore, GENTRAN provides code generation
and file handling functions designed specifically to be used in the
symbolic mode of REDUCE.  This section presents the symbolic functions
which are analogous to the code generation, template processing, and
output file handling commands presented in sections \ref{GENTRAN:inter},
 \ref{GENTRAN:template}, and \ref{GENTRAN:output}.

\subsection{Code Generation and Translation}
Sections~\ref{translation} through \ref{comments}
describe interactive commands and functions which
generate and translate code, declare variables to be of 
specific types, and insert literal strings of characters into the
stream of generated code.  This section describes analogous symbolic
mode code generation functions.

\subsubsection{Translation of Prefix Forms}
In algebraic mode, the {\bf GENTRAN} command translates algorithmic
specifications supplied in the form of REDUCE statements into
numerical code.  Similarly, the symbolic function {\bf SYM!-GENTRAN}
\index{SYM"!-GENTRAN command}
translates algorithmic specifications supplied in the form of REDUCE
prefix forms into numerical code.

\begin{describe}{Syntax:}
{\bf SYM!-GENTRAN} {\it form\/};
\end{describe}
\begin{describe}{Function Type:}
expr
\end{describe} 
\begin{describe}{Argument:}
{\it form\/} is any LISP prefix form that evaluates to a
REDUCE prefix form that can be translated by GENTRAN into the target 
language\footnote{
See~\ref{appa} on page~\pageref{appa} for a complete listing of REDUCE
prefix forms that can be translated.}.
{\it form\/} may contain any number of occurrences of the special forms 
\ttindex{EVAL} \ttindex{LSETQ} \ttindex{RSETQ} \ttindex{LRSETQ}
\ttindex{DECLARE} \ttindex{LITERAL}
{\bf EVAL}, {\bf LSETQ}, {\bf RSETQ}, {\bf LRSETQ}, {\bf DECLARE}, and 
{\bf LITERAL} (see sections~\ref{sym:cg} through \ref{special} on
pages~\pageref{sym:cg}--\pageref{special}).
\end{describe}
\begin{describe}{Side Effects:}
{\bf SYM!-GENTRAN} translates {\it form\/} into formatted code in the target
language and writes it to the file(s) currently selected for output.
\end{describe}
\begin{describe}{Returned Value:}
{\bf SYM!-GENTRAN} returns the name(s) of the file(s) to which code
was written.  If code was written to one file, the returned value is an atom;
otherwise, it is a list.
\end{describe} 
\begin{describe}{Diagnostic Messages:}
\begin{verbatim}
*** OUTPUT FILE ALREADY EXISTS

   OVERWRITE FILE? (Y/N)

***** WRONG TYPE OF ARG
\end{verbatim}
{\it exp}
\begin{verbatim}
***** CANNOT BE TRANSLATED
\end{verbatim}
\end{describe} 
\begin{describe}{\example}\index{GENTRAN package ! example}
\begin{verbatim}
1: SYMBOLIC$ 

2: GENTRANLANG!* := 'FORTRAN$

3:   SYM!-GENTRAN '(FOR I (1 1 n) DO (SETQ (V I) 0))$

     DO 25001 I=1,N
          V(I)=0.0
25001 CONTINUE

4: GENTRANLANG!* := 'RATFOR$

5: SYM!-GENTRAN '(FOR I (1 1 N) DO 
5:                    (FOR J ((PLUS I 1) 1 N) DO 
5:                         (PROGN 
5:                            (SETQ (X J I) (X I J)) 
5:                            (SETQ (Y J I) (Y I J)))))$ 

DO I=1,N
   DO J=I+1,N
        {
            X(J,I)=X(I,J)
            Y(J,I)=Y(I,J)
        }

6: GENTRANLANG!* := 'C$ 

7: SYM!-GENTRAN '(SETQ P (FOR I (1 1 N) PRODUCT I))$

{
    P=1;
    for (I=1;I<=N;++I)
        P*=I;
}

8:  GENTRANLANG!* := 'PASCAL$

9: SYM!-GENTRAN '(SETQ C
9:     (COND ((LESSP A B) A) (T B)))$
IF A$0.0 DO} &\verb!25004 IF(.NOT.F(N).GT.0.0)!\\
               &                          &\verb!     .   GOTO 25005!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!          N=N+1!\\
& &\verb!          GOTO 25004!\\
& &\verb!25005 CONTINUE!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!25006 CONTINUE!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!          X=X/2.0!\\
& &\verb!      IF(.NOT.F(X).LT.0.0)!\\
& &\verb!     .   GOTO 25006!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE Loop structures translatable to FORTRAN}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf FORTRAN CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0} &\verb!  IF (X.GT.0.0) THEN!\\
& {\bf \ \ \ \ \ \ \  THEN Y:=X\$} &\verb!      Y=X!\\
& &\verb!  ENDIF!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!  IF (X.GT.0.0) THEN!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!      Y=X!\\
&     &\verb!  ELSE!\\
&     &\verb!      Y=-X!\\
&     &\verb!  ENDIF!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!  GOTO 25010!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!  CALL CALCV(V,X,Y,Z)!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!  !{\it
 functionname\/}\verb!=X**2!\\
&     &\verb!  RETURN!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;}&\verb!  U=X**2!\\
& {\bf \ \ \ \ \ \ \ \ V:=Y\^{}2$>$$>$\$}    &\verb!  V=Y**2!\\
&     &\\
    group      &{\bf BEGIN}&\verb!  U=X**2!\\
&{\bf\ \ \ \  U:=X\^{}2;}&\verb!  V=Y**2!\\
&{\bf\ \ \ \  V:=Y\^{}2} &\\
&{\bf END\$}&\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE control structures translatable to FORTRAN}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline

Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M(1,1)=U!\\
& &\verb!M(1,2)=V!\\
& &\verb!M(2,1)=W!\\
& &\verb!M(2,2)=X!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!DO I=1,10!\\
& &\verb!    S=S+V(I)!\\
& & \\
    product    &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1!\\
&{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!DO I=2,N,2!\\
&{\ \ \ \ PRODUCT I\$} &\verb!    P=P*I!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A$0.0 DO} &\verb!WHILE(F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N=N+1!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X=X/2.0!\\
& &\verb!UNTIL(F(X)<0.0)!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to RATFOR}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf RATFOR CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF(X>0.0)!\\
&     &\verb!    Y=X!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF(X>0.0)!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y=X!\\
&     &\verb!ELSE!\\
&     &\verb!    Y=-X!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALL CALCV(V,X,Y,Z)!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!RETURN(X**2)!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=X**2!\\
&     &\verb!V=Y**2!\\
&     &\\
    group      &{\bf BEGIN}&\verb!{!\\
&{\bf\ \ \ \  U:=X\^{}2;}& \verb!      U=X**2!\\
&{\bf\ \ \ \  V:=Y\^{}2} & \verb!      V=Y**2!\\
&{\bf END\$}&\verb!}!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to RATFOR}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline
Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=X**2+X;!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),} &\verb!BEGIN!\\
& {\bf \ \ \ \ \ \ \ \ (W,X))\$} &\verb!    M(1,1)=U;!\\
& &\verb!    M(1,2)=V;!\\
& &\verb!    M(2,1)=W;!\\
& &\verb!    M(2,2)=X;!\\
& &\verb!END;!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!BEGIN!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!    S=0.0!\\
& &\verb!    FOR I:=1 TO 10 DO!\\
& &\verb!        S:=S+V(I)!\\
& &\verb!END;!\\
& & \\
    product    &{\bf P:=FOR I:=2:N} &\verb!BEGIN!\\
&{\bf \ \ \ \ PRODUCT I\$} &\verb!    P:=1;!\\
& &\verb!    FOR I:=2 TO N DO!\\
& &\verb!        P:=P*I!\\
& &\verb!END;!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!IF (A$0.0 DO} &\verb!WHILE (F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N:=N+1.0;!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!REPEAT!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X:=X/2.0!\\
& &\verb!UNTIL F(X)<0.0;!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to PASCAL}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf PASCAL CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!IF X>0.0 THEN!\\
& &\verb!    Y:=X;!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!IF X>0.0 THEN!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y:=X;!\\
&     &\verb!ELSE!\\
&     &\verb!    Y:=-X;!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!GOTO 25010;!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &{\it functionname\/}\verb!=X**2;!\\
&     &\verb!GOTO 99999{RETURN}!\\
&     &\verb!99999;!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!BEGIN!\\
&&\verb!    U:=X**2;!\\
&&\verb!    V:=Y**2!\\
&&\verb!END;!\\
&     &\\
    group      &{\bf BEGIN}&\verb!BEGIN!\\
&{\bf\ \ \ \  U:=X\^{}2;}&\verb!    U:=X**2;!\\
&{\bf\ \ \ \  V:=Y\^{}2} &\verb!    V:=Y**2!\\
&{\bf END\$}&\verb!END!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to PASCAL}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE}
 & \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline
Assignments: & &\\
& & \\
    simple     &{\bf V:=X\^{}2+X\$} &\verb!V=power(X,2)+X;!\\
& & \\
    matrix     &{\bf M:=MAT((U,V),(W,X))\$} &\verb!M[1][1]=U;!\\
& &\verb!M[1][2]=V;!\\
& &\verb!M[2][1]=W;!\\
& &\verb!M[2][2]=X;!\\
& & \\
    sum &{\bf S:=FOR I:=1:10} &\verb!S=0.0;!\\
&{\bf\ \ \ \ \ \ SUM V(I)\$} &\verb!for(I=1;I<=10;++I)!\\
& &\verb!    S+=V[I];!\\
& & \\
    product    &{\bf P:=FOR I:=2 STEP 2} &\verb!P=1;!\\
&{\bf\ \ \ \ \ \ \ \ UNTIL N} &\verb!for(I=2;I<=N;++I)!\\
&{\ \ \ \ PRODUCT I\$} &\verb!    P*=I;!\\
& & \\
conditional & {\bf X := IF A$<$B THEN} &\verb!if (A$0.0 DO} &\verb!while(F(N)>0.0)!\\
&{\bf \ \ \ \ N:=N+1\$} &\verb!    N+=1;!\\
& & \\
   repeat     &{\bf REPEAT X:=X/2.0} &\verb!do!\\
&{\bf \ \ \ \ UNTIL F(X)$<$0.0\$} &\verb!    X/=2.0;!\\
& &\verb!while(F(X)>=0.0);!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to C}
\end{table}

\begin{table}
\begin{tabular}{||l|l|l||}\hline\hline
\multicolumn{1}{||c|}{\bf TYPE} & \multicolumn{1}{c|}{\bf EXAMPLE} &
 \multicolumn{1}{c||}{\bf C CODE} \\ \hline\hline
  Conditionals:&     &\\
&     &\\
    if  &{\bf IF X$>$0.0 THEN Y:=X\$} &\verb!if(X>0.0)!\\
&     &\verb!    Y=X;!\\
&     &\\
    if - else  &{\bf IF X$>$0.0 THEN Y:=X} &\verb!if(X>0.0)!\\
&{\bf\ \ \ \  ELSE Y:=-X\$}&\verb!    Y=X;!\\
&     &\verb!else!\\
&     &\verb!    Y=-X;!\\
& & \\\hline
  Unconditional&     &\\
  Transfer of  &     &\\
  Control:     &     &\\
&     &\\
    goto&{\bf GOTO LOOP\$} &\verb!goto LOOP;!\\
&     &\\
    call&{\bf CALCV(V,X,Y,Z)\$} &\verb!CALCV(V,X,Y,Z);!\\
&     &\\
    return     &{\bf RETURN X\^{}2\$} &\verb!return(power(X,2) );!\\
& & \\\hline
Sequences \&    &     &\\
Groups: &     &\\
&     &\\
    sequence   &{\bf $<$$<$ U:=X\^{}2;V:=Y\^{}2$>$$>$\$}&\verb!U=power(X,2);!\\
&     &\verb!V=power(Y,2);!\\
&     &\\
    group      &{\bf BEGIN}&\verb!{!\\
&{\bf\ \ \ \  U:=X\^{}2;}& \verb!      U=power(x,2);!\\
&{\bf\ \ \ \  V:=Y\^{}2} & \verb!      V=power(Y,2);!\\
&{\bf END\$}&\verb!}!\\
& & \\\hline\hline
\end{tabular}
\caption{REDUCE forms translatable to C}
\end{table}

\subsection{Formal Definition}
The remainder of this section contains a formal definition of all
REDUCE expressions, statements, and prefix forms that can be translated by
GENTRAN into FORTRAN, RATFOR, PASCAL and C code.

\begin{describe}{Preliminary Definitions}
An {\it id\/} is an identifier.  Certain {\it id\/}'s are reserved words
and may not be used as array names or subprogram names.  The
complete list appears in the {\it Reserved Words\/} section.

A {\it string\/} consists of any number of characters (excluding double
quotes) which are enclosed in double quotes.
\end{describe}

\begin{describe}{Reserved Words}\index{reserved words}
The following reserved words may not be used as array names or
subprogram names\footnote{Note that names of other built-in REDUCE functions
{\it can\/} be translated, but remember that they will be translated
{\it literally\/} unless {\bf EVAL}'d first.  For example:
{\bf GENTRAN~DERIV~:=~DF(2*X\^{}2-X-1,~X)\$}
generates {\tt DERIV=DF(2*X**2-X-1,X)}
whereas
{\bf GENTRAN~DERIV~:=:~DF(2*X\^{}2-X-1,~X)\$}
generates {\tt DERIV=4*X-1} }:

{\bf AND, BLOCK, COND, DIFFERENCE, EQUAL, EXPT, FOR, GEQ,
GO, GREATERP, LEQ, LESSP, MAT, MINUS, NEQ, NOT, OR,
PLUS, PROCEDURE, PROGN, QUOTIENT, RECIP, REPEAT,
RETURN, SETQ, TIMES, WHILE, WRITE}
\end{describe} 

\subsubsection{Translatable REDUCE Expressions and Statements}
\begin{describe}{Expressions}
\begin{tabular}{lll}
\multicolumn{3}{l}{Arithmetic Expressions:} \\
& & \\
exp & ::= & {\it number} $\mid$  var  $\mid$  funcall  $\mid$  - exp $\mid$
/ exp  $\mid$  exp + exp  $\mid$ \\
	& & exp - exp $\mid$ exp * exp  $\mid$  exp / exp  $\mid$  exp ** exp
 $\mid$ \\
        & & exp \^{} exp  $\mid$ ( exp )\\\\
& & \\
var & ::= & {\it id} $\mid$ {\it id} ( exp$_1$, exp$_2$, \dots\ , exp$_n$ )
 $n > 0$ \\
& & \\
funcall & ::= & {\it id} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$ \\
& & \\
arg & ::=  & exp $\mid$ logexp $\mid$ {\it string} \\
& &\\
\multicolumn{3}{l}{Logical Expressions:}\\
& & \\
logexp & ::= & {\it T} $\mid$ {\it NIL} $\mid$  var  $\mid$  funcall $\mid$
        exp $>$ exp  $\mid$  exp $>$= exp $\mid$\\
        & & exp = exp  $\mid$ exp {\it NEQ} exp $\mid$ exp $<$ exp $\mid$ \\
	& & exp $<$= exp $\mid$ {\it NOT\/} logexp  $\mid$ logexp {\it AND\/}
 logexp $\mid$ \\
        & & logexp {\it OR\/} logexp  $\mid$  ( logexp )\\
\end{tabular}
\end{describe}

\begin{describe}{Operator Precedence}
The following is a list of REDUCE arithmetic and logical
operators in order of decreasing precedence:
\begin{center}
** (or \^{})  /  *  ---  +  $<$  $<$=  $>$  $>$=  NEQ  = NOT  AND  OR
\end{center}

When unparenthesised expressions are translated which contain
operators whose precedence in REDUCE differs from that in the
target language, parentheses are automatically generated.  Thus
the meaning of the original expression is preserved\footnote{
For example in REDUCE, {\bf NOT~A~=~B} and {\bf NOT~(A~=~B)}
are equivalent, whereas in C, {\bf !~A~==~B} and {\bf (!A)~==~B}
are equivalent.  Therefore, {\bf NOT~A~=~B}
is translated into C code which forces the REDUCE precedence rules:
{\bf !(A~==~B)}
}.
\end{describe}
\begin{describe}{Statements}
\begin{tabular}{lll}
stmt & ::= & assign  $\mid$  break  $\mid$  cond  $\mid$  while $\mid$
           repeat  $\mid$  for  $\mid$  goto  $\mid$  label $\mid$ \\
& &   call  $\mid$  return  $\mid$  stop  $\mid$  stmtgp \\
\end{tabular}

Assignment Statements:

\begin{tabular}{llll}
assign & ::= & \multicolumn{2}{l}{var := assign'  $\mid$  matassign $\mid$
 cond}\\
& & & \\
assign' & ::= & \multicolumn{2}{l}{exp  $\mid$  logexp}\\
& & & \\
matassign & ::= & {\it id} := {\it MAT\/}(&(exp$_{11}$, \dots\ , exp$_{1m}$),\\
 & & &(exp$_{21}$, \dots\ , exp$_{2m}$ ),\\
 & & & \ \ \ \ \ \ :\\
 & & & \ \ \ \ \ \ :\\
 & & &( exp$_{n1}$, \dots\ , exp$_{nm}$ ) ) $n,m > 0$ \\
\end{tabular}

Break Statement:

break  ::= {\it BREAK()}

Conditional Statements:

\begin{tabular}{lll}
cond & ::= & {\it IF\/} logexp {\it THEN\/} stmt\\
& & {\it IF\/} logexp {\it THEN\/} stmt {\it ELSE\/} stmt\\
\end{tabular}

Loops:
\index{FOR loop} \index{WHILE loop} \index{REPEAT loop}

\begin{tabular}{lll} 
while & ::= & {\it WHILE\/} logexp {\it DO\/} stmt\\
& &\\
repeat & ::= & {\it REPEAT\/} stmt {\it UNTIL\/} logexp\\
& &\\
for & ::= & {\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp
{\it DO\/} stmt $\mid$\\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it DO\/} stmt $\mid$\\
& &{\it FOR\/} var := exp : exp {\it DO\/} stmt $\mid$\\
& &var := for' $\mid$ \\
& &\\
for' & ::= & var := for' $\mid$\\
& &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp {\it SUM\/} exp
 $\mid$\\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it SUM\/} exp $\mid$\\
& &{\it FOR\/} var := exp : exp {\it SUM\/} exp $\mid$\\
& &{\it FOR\/} var := exp {\it STEP\/} exp {\it UNTIL\/} exp\\
& & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp $\mid$ \\
& &{\it FOR\/} var := exp {\it UNTIL\/} exp {\it PRODUCT\/} exp $\mid$\\
& &{\it FOR\/} var := exp : exp {\it PRODUCT\/} exp\\
\end{tabular}

Goto Statement:

\begin{tabular}{lll}
goto & ::= & {\it GOTO\/} label  $\mid$ {\it GO TO\/} label\\
label & ::= & {\it id\/} :\\
\end{tabular}

Subprogram Calls \& Returns \footnote{ Note that return statements can
only be translated from inside of procedure definitions.
\index{LITERAL command} The LITERAL function must be used to generate
a return statement from anywhere else.}:

\begin{tabular}{lll}
call & ::= & {\it id\/} ( arg$_1$, arg$_2$, \dots\ , arg$_n$ ) $n \geq 0$\\
& &\\
return & ::= & {\it RETURN\/} $\mid$ {\it RETURN\/} arg\\
\end{tabular}

Stop \& Exit Statements \footnote{
In certain cases it may be convenient to generate a FORTRAN
STOP statement or a C EXIT statement.  Since there is no
semantically equivalent REDUCE statement, STOP() can be used
and will be translated appropriately.}:

stop  ::= {\it STOP\/}()

Statement Groups \footnote{
Note that REDUCE BEGIN\dots\ END statement groups are translated
into RATFOR or C \{\dots\ \} statement groups, whereas
REDUCE $<$$<$\dots\ $>$$>$ statement groups are translated into RATFOR or
C statement {\it sequences}.  When the target language is FORTRAN, both
types of REDUCE statement groups are translated into statement
sequences.}:

\begin{tabular}{lll}
stmtgp & ::= & $<$$<$ stmt$_1$ ; stmt$_2$ ; \dots\  ; stmt$_n$ $>$$>$
 $\mid$\\
& &{\it BEGIN\/} stmt$_1$ ; stmt$_2$ ; \dots\  ; stmt$_n$ {\it END\/} $ n >
 0$\\
\end{tabular}
\end{describe}
\begin{describe}{Subprogram Definitions}
\begin{tabular}{lll} 
defn & ::= & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ;
 stmt $\mid$\\
& & {\it PROCEDURE id\/} ({\it id$_1$, id$_2$, \dots\ , id$_n$\/}) ;
 exp\ \ \ \ \ \  $n \geq 0$ \\
\end{tabular}
\end{describe}

\subsubsection{Translatable REDUCE Prefix Forms}
\begin{describe}{Expressions}

Arithmetic Expressions:

\begin{tabular}{lll}
exp & ::= & {\it number\/} $\mid$  funcall  $\mid$  var  $\mid$ 
({\it DIFFERENCE\/} exp exp) $\mid$\\
& &({\it EXPT\/} exp exp)  $\mid$  ({\it MINUS\/} exp)  $\mid$  ({\it PLUS\/}
 exp exp') $\mid$\\
& & ({\it QUOTIENT\/} exp exp)  $\mid$  ({\it RECIP\/} exp) $\mid$\\
& & ({\it TIMES\/} exp exp exp')  $\mid$  ({\it !*SQ\/} sqform)\\
\end{tabular}

where sqform is a standard quotient form equivalent to any acceptable prefix
form.

exp' ::=  exp$_1$ exp$_2$ \dots\  exp$_n$  $n \geq 0$

Logical Expressions:

\begin{tabular}{lll}
logexp & ::= & {\it NIL\/} $\mid$ {\it T\/} $\mid$  funcall  $\mid$  var
$\mid$\\
& &  ({\it AND\/} logexp logexp logexp')  $\mid$  ({\it EQUAL\/} exp exp)
$\mid$\\
& & ({\it GEQ\/} exp exp)  $\mid$  ({\it GREATERP\/} exp exp)  $\mid$ \\
& & ({\it LEQ\/} exp exp) $\mid$ ({\it LESSP\/} exp exp)  $\mid$ \\
& & ({\it NEQ\/} exp exp) $\mid$ ({\it NOT\/} logexp) $\mid$ \\
& & ({\it OR\/} logexp logexp logexp')\\
& &\\
logexp' & ::= & logexp$_1$ logexp$_2$ \dots\  logexp$_n$  $n \geq 0$\\
\end{tabular}
\end{describe}

\begin{describe}{Statements}
\begin{tabular}{lll}
stmt & ::= &  assign  $\mid$  break  $\mid$  call  $\mid$  cond  $\mid$
for  $\mid$  goto $\mid$\\
& & label  $\mid$  read  $\mid$  repeat  $\mid$  return  $\mid$  stmtgp
$\mid$\\
& & stop  $\mid$  while  $\mid$  write \\
& &\\
stmt' &  ::= & stmt$_1$ stmt$_2$ \dots\  stmt$_n$   $n \geq 0$\\
\end{tabular}

Assignment Statements:

assign  ::=  ({\it SETQ\/} var exp)  $\mid$  ({\it SETQ\/} var logexp) $\mid$
             ({\it SETQ\/} id ({\it MAT\/} list list'))

Conditional Statements:

\begin{tabular}{lll}
cond & ::= & ({\it COND\/} (logexp stmt) cond1) \\
& & \\
cond1 & ::= & (logexp stmt$_1$) \dots\  (logexp stmt$_n$) $n \geq 0$\\
\end{tabular}

Loops:

\begin{tabular}{lll}
for & ::= & ({\it FOR\/} var (exp exp exp) {\it DO\/} stmt) $\mid$\\
& &  ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) {\it SUM\/} exp) $\mid$\\
& & ({\it SETQ\/} var ({\it FOR\/} var (exp exp exp) \\
& & \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ {\it PRODUCT\/} exp)\\
& &\\
repeat & ::= & ({\it REPEAT\/} stmt logexp)\\
& &\\
while & ::= & ({\it WHILE\/} logexp stmt)
\end{tabular}

Go To Statements:

\begin{tabular}{lll} 
break & ::= & ({\it BREAK\/})\\
& & \\
goto & ::= & ({\it GO\/} label)\\
& & \\
label & ::= & {\it id}\\
\end{tabular}

Subprogram Calls \& Returns:

\begin{tabular}{lll}
call & ::= & ({\it id\/} arg')\\
& &\\
return & ::= & ({\it RETURN\/})  $\mid$  ({\it RETURN\/} arg)\\
\end{tabular}

Stop \& Exit Statements:

stop ::= ({\it STOP\/})

Statement Groups:

stmtgp  ::=  ({\it PROGN\/} stmt stmt')  $\mid$  ({\it BLOCK\/} (id') stmt')

I/O Statements:

\begin{tabular}{lll}
read & ::= & ({\it SETQ\/} var ({\it READ\/}))\\
& &\\
write & ::= & ({\it WRITE\/} arg arg')\\
\end{tabular}

Subprogram Definitions:

defn  ::=  ({\it PROCEDURE id NIL EXPR\/} (id') stmt)

\end{describe}

\begin{describe}{Miscellaneous}
\begin{tabular}{lll} 
funcall & ::= & ({\it id\/} arg')\\
& &\\
var & ::= & {\it id\/} $\mid$  ({\it id\/} exp exp')\\
& &\\
arg & ::= & {\it string\/} $\mid$  exp  $\mid$  logexp\\
& &\\
arg' & ::= & arg$_1$ arg$_2$ \dots\  arg$_n$  $n \geq 0$ \\
& &\\
list & ::= & (exp exp')\\
& &\\
list' & ::= & list$_1$ list$_2$ \dots\  list$_n$   $n \geq 0$ \\
& &\\
id' &  ::= & {\it id$_1$ id$_2$} \dots\ {\it id$_n$}  $n \geq 0$ \\
\end{tabular}
\end{describe}

\section{List of Commands, Switches, \& Variables}
\label{appb}
\begin{describe}{COMMANDS}
\index{GENTRAN command}
{\bf GENTRAN} {\it stmt\/} [{\bf OUT}{\it  f1,f2,\dots\ ,fn\/}]{\it ;}

\index{GENTRANIN command}
{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm\/} [{\bf OUT}{\it  f1,f2,\dots\
,fn\/}]{\it ;}

\index{GENTRANOUT command}
{\bf GENTRANOUT} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANSHUT command}
{\bf GENTRANSHUT} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANPUSH command}
{\bf GENTRANPUSH} {\it f1,f2,\dots\ ,fn;}

\index{GENTRANPOP command}
{\bf GENTRANPOP} {\it f1,f2,\dots\ ,fn;}
\end{describe}

\begin{describe}{SPECIAL FUNCTIONS \& OPERATORS}

\ttindex{EVAL}
{\bf EVAL} {\it exp}

\index{::=}
{\it var} {\bf ::=} {\it exp;}

\index{:=:}
{\it var} {\bf :=:} {\it exp;}

\index{::=:}
{\it var} {\bf ::=:} {\it exp;}

\ttindex{LSETQ}
{\it var} {\bf LSETQ} {\it exp;}

\ttindex{RSETQ}
{\it var} {\bf RSETQ} {\it exp;}

\ttindex{LRSETQ}
{\it var} {\bf LRSETQ} {\it exp;}

\index{DECLARE function}
{\bf DECLARE} {\it v1,v2,\dots\ ,vn\/}{\bf :} {\it  type;}

\begin{tabular}{ll}
{\bf DECLARE}\\
{\bf $<$$<$}\\
&{\it v11,v12,\dots\ ,v1n} {\bf :} {\it type1\/}{\bf ;}\\
&{\it v12,v22,\dots\ ,v2n} {\bf :} {\it type2\/}{\bf ;}\\
& \ \ \ :\\
& \ \ \ :\\
&{\it vm1,vm2,\dots\ ,vmn} {\bf :} {\it typen\/}{\bf ;}\\
{\bf $>$$>$}{\it ;}
\end{tabular}

\ttindex{LITERAL}
{\bf LITERAL} {\it arg1,arg2,\dots\ ,argn;}
\end{describe}

\begin{describe}{MODE SWITCHES}
{\bf PERIOD} \index{PERIOD switch}

{\bf GENTRANSEG} \index{GENTRANSEG switch}

{\bf GENDECS} \index{GENDECS switch}

{\bf DOUBLE} \index{DOUBLE switch}

{\bf MAKECALLS} \index{MAKECALLS switch}

{\bf KEEPDECS} \index{KEEPDECS switch}

{\bf GETDECS} \index{GETDECS switch}

\end{describe}

\begin{describe}{VARIABLES}
{\bf GENTRANLANG!*}  \ttindex{GENTRANLANG!*}

{\bf MAXEXPPRINTLEN!*}  \ttindex{MAXEXPPRINTLEN!*}

{\bf TEMPVARNAME!*}  \ttindex{TEMPVARNAME!*}

{\bf TEMPVARNUM!*}  \ttindex{TEMPVARNUM!*}

{\bf TEMPVARTYPE!*}  \ttindex{TEMPVARTYPE!*}

{\bf GENSTMTNUM!*}  \ttindex{GENSTMTNUM!*}

{\bf GENSTMTINCR!*}  \ttindex{GENSTMTINCR!*}

{\bf TABLEN!*}  \ttindex{TABLEN!*}

{\bf FORTLINELEN!*}  \ttindex{FORTLINELEN!*}

{\bf RATLINELEN!*}  \ttindex{RATLINELEN!*}

{\bf CLINELEN!*}  \ttindex{CLINELEN!*}

{\bf PASCLINELEN!*}  \ttindex{PASCLINELEN!*}

{\bf MINFORTLINELEN!*}  \ttindex{MINFORTLINELEN!*}

{\bf MINRATLINELEN!*}  \ttindex{MINRATLINELEN!*}

{\bf MINCLINELEN!*}  \ttindex{MINCLINELEN!*}

{\bf MINPASCLINELEN!*}  \ttindex{MINPASCLINELEN!*}

{\bf DEFTYPE!*} \ttindex{DEFTYPE!*}
\end{describe}

\begin{describe}{TEMPORARY VARIABLE GENERATION, MARKING \& UNMARKING}
{\bf TEMPVAR} {\it type;} \ttindex{TEMPVAR}

{\bf MARKVAR} {\it var;} \ttindex{MARKVAR}

{\bf UNMARKVAR} {\it var;} \ttindex{UNMARKVAR}
\end{describe}

\begin{describe}{EXPLICIT GENERATION OF TYPE DECLARATIONS}
{\bf GENDECS} {\it subprogname;} \ttindex{GENDECS switch}
\end{describe}

\begin{describe}{SYMBOLIC MODE FUNCTIONS}
{\bf SYM!-GENTRAN} {\it form;} \index{SYM"!-GENTRAN command}

{\bf SYM!-GENTRANIN} {\it list-of-fnames;} \index{SYM"!-GENTRANIN command}

{\bf SYM!-GENTRANOUT} {\it list-of-fnames;} \index{SYM"!-GENTRANOUT command}

{\bf SYM!-GENTRANSHUT} {\it list-of-fnames;} \index{SYM"!-GENTRANSHUT command}

{\bf SYM!-GENTRANPUSH} {\it list-of-fnames;} \index{SYM"!-GENTRANPUSH command}

{\bf SYM!-GENTRANPOP} {\it list-of-fnames;} \index{SYM"!-GENTRANPOP command}
\end{describe}

\begin{describe}{SYMBOLIC MODE SPECIAL FORMS}
\begin{tabular}{ll}
\ttindex{DECLARE}
{\bf (DECLARE} & {\bf (}{\it type1 v11 v12 \dots\  v1n\/}{\bf )}\\
& {\bf (}{\it type2 v21 v22 \dots\  v2n\/}{\bf )}\\
& \ \ \ :\\
& \ \ \ :\\
& {\bf (}{\it typen vn1 vn2 \dots\  vnn\/}{\bf ))}\\
\end{tabular}

{\bf (LITERAL} {\it arg1 arg2 \dots\  argn\/}{\bf )} \ttindex{LITERAL}

{\bf (EVAL} {\it exp\/}{\bf )} \ttindex{EVAL}

{\bf (LSETQ} {\it var exp\/}{\bf )} \ttindex{LSETQ}

{\bf (RSETQ} {\it var exp\/}{\bf )} \ttindex{RSETQ}

{\bf (LRSETQ} {\it var exp\/}{\bf )} \ttindex{LRSETQ}
\end{describe}

\section{The Programs {\tt M1.F} and {\tt M2.F}.}
\label{appc}

This section contains the two files generated in chapter 6.
Contents of file m1.f:
\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y
      M(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*DCOS(DBLE(
     . Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+J30Y
      M(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      MIV(1,1)=(-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30X)-(DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3))
     . **2*J30Z*J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+
     . 9.0D0*P**2*M30*J30X+J30Y*J30X)/(729.0D0*DSIN(DBLE(Q3))
     . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3
     . ))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN(
     . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(1,2)=(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*
     . J30X+DSIN(DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2*
     . J30Z*J30X)-(81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*
     . M30**2)-(9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*
     . J30X)-(81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y)-(
     . 9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(729.0D0*DSIN(DBLE(
     . Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE
     . (Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*
     . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**
     . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30*
     . J30Y)/(729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**
     . 6*M30**3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P
     . **4*M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2
     . ))**2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*
     . Y*M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*
     . J30Y)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE
     . (Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y
     . *J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3
     . ))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X
     . )+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(
     . Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN(
     . DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-(
     . 729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN(
     . DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))**
     . 2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30
     . **2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y
     . *J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30Z*J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y*
     . J30X)-(DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE
     . (Q3))**2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*
     . J30X*J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3
     . ))**2*J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X
     . -(729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30
     . **3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      MIV(2,2)=(-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*
     . P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*M30*J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2
     . ))*P**4*M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P
     . **2*M30*J30X+162.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+
     . 9.0D0*P**2*M30*J30Y+9.0D0*P**2*M30*J10Y+18.0D0*P**2*
     . M30*J30X+P**2*M10*J30X+J30Y*J30X+J10Y*J30X)/(729.0D0*
     . DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0
     . *DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-
     . (81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**
     . 2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*
     . Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y
     . **2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0
     . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))
     . **4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30
     . )-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*
     . J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2
     . ))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE
     . (Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*
     . P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10
     . )-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3
     . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))*
     . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(729.0D0*DSIN(DBLE(Q3))
     . **4*DSIN(DBLE(Q2))**2*P**6*M30**3+81.0D0*DSIN(DBLE(Q3)
     . )**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y-(81.0D0*DSIN(
     . DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Z)+
     . 81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**2*J30-(81.0D0*
     . DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+9.0D0*DSIN(DBLE(Q3
     . ))**4*P**2*Y*M30*J30Y*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**
     . 2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*
     . J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN
     . (DBLE(Q3))**4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(
     . DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y
     . *J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**
     . 2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2)
     . )**2*P**4*M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6
     . *M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30**2*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*
     . J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN
     . (DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*Y*M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*
     . J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y+9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))**2*P**2*
     . J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10*J30X-(
     . DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE(Q3))**2*
     . J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*J30X)+DSIN(
     . DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(DBLE(Q3))**2
     . *DCOS(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DCOS(DBLE(Q3))
     . **2*DCOS(DBLE(Q2))**2*P**4*M30**2*J30X)+729.0D0*P**6*
     . M30**3+81.0D0*P**6*M30**2*M10+81.0D0*P**4*M30**2*J30Y+
     . 81.0D0*P**4*M30**2*J10Y+81.0D0*P**4*M30**2*J30X+9.0D0*
     . P**4*M30*J30Y*M10+9.0D0*P**4*M30*M10*J30X+9.0D0*P**2*
     . M30*J30Y*J10Y+9.0D0*P**2*M30*J30Y*J30X+9.0D0*P**2*M30*
     . J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      MIV(3,3)=(9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0
     . *DSIN(DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y*
     . J30Y*J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **4*M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J10Y)-(DSIN(DBLE(Q3))**2*P**2*J30Y*
     . M10)+DSIN(DBLE(Q3))**2*P**2*J30Z*M10-(DSIN(DBLE(Q3))**
     . 2*Y*J30Y*J30)+DSIN(DBLE(Q3))**2*J30Y**2-(DSIN(DBLE(Q3)
     . )**2*J30Y*J10Y)+DSIN(DBLE(Q3))**2*J30Z*J10Y-(81.0D0*
     . DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*M30**2)+
     . 81.0D0*P**4*M30**2+9.0D0*P**4*M30*M10+9.0D0*P**2*M30*
     . J30Y+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y*J10Y)/(
     . 729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*M30
     . **2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P
     . **4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*M30**
     . 2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)+
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)+9.0D0*DSIN(DBLE
     . (Q3))**4*P**2*Y*M30*J30X*J30-(9.0D0*DSIN(DBLE(Q3))**4*
     . P**2*M30*J30Y**2)+9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*
     . J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y*J30X)
     . +DSIN(DBLE(Q3))**4*Y*J30Y*J30X*J30-(DSIN(DBLE(Q3))**4*
     . Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3))**4*J30Y**2*J30X)+DSIN
     . (DBLE(Q3))**4*J30Y*J30Z*J30X-(729.0D0*DSIN(DBLE(Q3))**
     . 2*DSIN(DBLE(Q2))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3)
     . )**2*DSIN(DBLE(Q2))**2*P**4*M30**2*J30Y)-(729.0D0*DSIN
     . (DBLE(Q3))**2*P**6*M30**3)-(81.0D0*DSIN(DBLE(Q3))**2*P
     . **6*M30**2*M10)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*Y*M30**
     . 2*J30)+81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J30Z-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*J10Y)-(81.0D0*
     . DSIN(DBLE(Q3))**2*P**4*M30**2*J30X)-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*J30Y*M10)+9.0D0*DSIN(DBLE(Q3))**2*P**
     . 4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*M10*
     . J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30Y*J30)-(
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30X*J30)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2-(9.0D0*DSIN(DBLE(Q3
     . ))**2*P**2*M30*J30Y*J10Y)+9.0D0*DSIN(DBLE(Q3))**2*P**2
     . *M30*J30Z*J10Y+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*
     . J30X-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(
     . DSIN(DBLE(Q3))**2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**
     . 2*P**2*J30Z*M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*
     . J30)+DSIN(DBLE(Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2
     . *J30Y*J10Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(
     . 729.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**
     . 3)-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0
     . *P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2
     . *M30*J30Y*J30X+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      DO 25005 J=1,3
          DO 25006 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25006     CONTINUE
25005 CONTINUE
\end{framedverbatim}

\newpage

Contents of file m2.f:
\begin{framedverbatim}
      M(1,1)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*Y*J30)+DSIN(DBLE(Q3))**2*J30Z+18.0D0*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**2*M30+18.0D0*P**2*M30+P**2*M10
     . +J30Y+J10Y(1,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(
     . DSIN(DBLE(Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*
     . DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30+9.0D0*P**2*M30+
     . J30Y(1,3)=-(9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*
     . M30)
      M(2,2)=-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30)-(DSIN(DBLE(
     . Q3))**2*J30Y)+DSIN(DBLE(Q3))**2*J30Z+9.0D0*P**2*M30+
     . J30Y
      M(2,3)=0.0D0
      M(3,3)=9.0D0*P**2*M30+J30X
      T1=-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0*DSIN(
     . DBLE(Q3))**2*P**2*M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X)-(
     . DSIN(DBLE(Q3))**2*J30Y*J30X)+DSIN(DBLE(Q3))**2*J30Z*
     . J30X+81.0D0*P**4*M30**2+9.0D0*P**2*M30*J30Y+9.0D0*P**2
     . *M30*J30X+J30Y*J30X
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     ; M30*J30Y*J30X
      MIV(1,1)=T1/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*
     . J30X+J30Y*J10Y*J30X)
      T0=81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2+9.0D0*DSIN(DBLE
     . (Q3))**2*P**2*M30*J30Y-(9.0D0*DSIN(DBLE(Q3))**2*P**2*
     . M30*J30Z)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30X+DSIN(
     . DBLE(Q3))**2*J30Y*J30X-(DSIN(DBLE(Q3))**2*J30Z*J30X)-(
     . 81.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(
     . 9.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*J30X)-(
     . 81.0D0*P**4*M30**2)-(9.0D0*P**2*M30*J30Y)
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(1,2)=(T0-(9.0D0*P**2*M30*J30X)-(J30Y*J30X))/(T1+
     . 9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*
     . J30X)
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(1,3)=(-(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**
     . 4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Y)+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2
     . *M30*J30Z+81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*P**2*M30*
     . J30Y)/(T0+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+
     . J30Y*J10Y*J30X)
      T0=-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2)-(9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+9.0D0*DSIN(DBLE(Q3))
     . **2*P**2*M30*J30Z-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*
     . J30X)-(DSIN(DBLE(Q3))**2*Y*J30X*J30)+DSIN(DBLE(Q3))**2
     . *J30Z*J30X+162.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**4*
     . M30**2+18.0D0*DCOS(DBLE(Q3))*DCOS(DBLE(Q2))*P**2*M30*
     . J30X+162.0D0*P**4*M30**2
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(2,2)=(T0+9.0D0*P**4*M30*M10+9.0D0*P**2*M30*J30Y+
     . 9.0D0*P**2*M30*J10Y+18.0D0*P**2*M30*J30X+P**2*M10*J30X
     . +J30Y*J30X+J10Y*J30X)/(T1+9.0D0*P**2*M30*J10Y*J30X+P**
     . 2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      T0=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T0=T0+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T0=T0-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T0=T0+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T0=T0-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(2,3)=(81.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**4*
     . M30**2+9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Y-(9.0D0*DSIN(DBLE(Q3))**3*DSIN(DBLE(Q2))*P**2*M30
     . *J30Z)-(81.0D0*DSIN(DBLE(Q3))*DSIN(DBLE(Q2))*DCOS(DBLE
     . (Q3))*DCOS(DBLE(Q2))*P**4*M30**2)-(81.0D0*DSIN(DBLE(Q3
     . ))*DSIN(DBLE(Q2))*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))*
     . DSIN(DBLE(Q2))*P**2*M30*J30Y))/(T0+9.0D0*P**2*M30*J10Y
     . *J30X+P**2*J30Y*M10*J30X+J30Y*J10Y*J30X)
      T0=9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30-(9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y)+DSIN(DBLE(Q3))**4*Y*J30Y*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30)-(DSIN(DBLE(Q3))**4*
     . J30Y**2)+DSIN(DBLE(Q3))**4*J30Y*J30Z-(81.0D0*DSIN(DBLE
     . (Q3))**2*P**4*M30**2)-(9.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30*M10)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*M30*J30)+
     . 9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z
      T0=T0-(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J10Y)-(DSIN(
     . DBLE(Q3))**2*P**2*J30Y*M10)+DSIN(DBLE(Q3))**2*P**2*
     . J30Z*M10-(DSIN(DBLE(Q3))**2*Y*J30Y*J30)+DSIN(DBLE(Q3))
     . **2*J30Y**2-(DSIN(DBLE(Q3))**2*J30Y*J10Y)+DSIN(DBLE(Q3
     . ))**2*J30Z*J10Y-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2
     . ))**2*P**4*M30**2)+81.0D0*P**4*M30**2+9.0D0*P**4*M30*
     . M10+9.0D0*P**2*M30*J30Y
      T1=729.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**6*M30
     . **3+81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y-(81.0D0*DSIN(DBLE(Q3))**4*DSIN(DBLE(Q2))**
     . 2*P**4*M30**2*J30Z)+81.0D0*DSIN(DBLE(Q3))**4*P**4*Y*
     . M30**2*J30-(81.0D0*DSIN(DBLE(Q3))**4*P**4*M30**2*J30Y)
     . +9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Y*J30-(9.0D0*
     . DSIN(DBLE(Q3))**4*P**2*Y*M30*J30Z*J30)
      T1=T1+9.0D0*DSIN(DBLE(Q3))**4*P**2*Y*M30*J30X*J30-(
     . 9.0D0*DSIN(DBLE(Q3))**4*P**2*M30*J30Y**2)+9.0D0*DSIN(
     . DBLE(Q3))**4*P**2*M30*J30Y*J30Z-(9.0D0*DSIN(DBLE(Q3))
     . **4*P**2*M30*J30Y*J30X)+DSIN(DBLE(Q3))**4*Y*J30Y*J30X*
     . J30-(DSIN(DBLE(Q3))**4*Y*J30Z*J30X*J30)-(DSIN(DBLE(Q3)
     . )**4*J30Y**2*J30X)+DSIN(DBLE(Q3))**4*J30Y*J30Z*J30X-(
     . 729.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**6*M30**
     . 3)
      T1=T1-(81.0D0*DSIN(DBLE(Q3))**2*DSIN(DBLE(Q2))**2*P**4*
     . M30**2*J30Y)-(729.0D0*DSIN(DBLE(Q3))**2*P**6*M30**3)-(
     . 81.0D0*DSIN(DBLE(Q3))**2*P**6*M30**2*M10)-(81.0D0*DSIN
     . (DBLE(Q3))**2*P**4*Y*M30**2*J30)+81.0D0*DSIN(DBLE(Q3))
     . **2*P**4*M30**2*J30Z-(81.0D0*DSIN(DBLE(Q3))**2*P**4*
     . M30**2*J10Y)-(81.0D0*DSIN(DBLE(Q3))**2*P**4*M30**2*
     . J30X)
      T1=T1-(9.0D0*DSIN(DBLE(Q3))**2*P**4*M30*J30Y*M10)+9.0D0
     . *DSIN(DBLE(Q3))**2*P**4*M30*J30Z*M10-(9.0D0*DSIN(DBLE(
     . Q3))**2*P**4*M30*M10*J30X)-(9.0D0*DSIN(DBLE(Q3))**2*P
     . **2*Y*M30*J30Y*J30)-(9.0D0*DSIN(DBLE(Q3))**2*P**2*Y*
     . M30*J30X*J30)+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y**2
     . -(9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Y*J10Y)+9.0D0*
     . DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J10Y
      T1=T1+9.0D0*DSIN(DBLE(Q3))**2*P**2*M30*J30Z*J30X-(9.0D0
     . *DSIN(DBLE(Q3))**2*P**2*M30*J10Y*J30X)-(DSIN(DBLE(Q3))
     . **2*P**2*J30Y*M10*J30X)+DSIN(DBLE(Q3))**2*P**2*J30Z*
     . M10*J30X-(DSIN(DBLE(Q3))**2*Y*J30Y*J30X*J30)+DSIN(DBLE
     . (Q3))**2*J30Y**2*J30X-(DSIN(DBLE(Q3))**2*J30Y*J10Y*
     . J30X)+DSIN(DBLE(Q3))**2*J30Z*J10Y*J30X-(729.0D0*DCOS(
     . DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**6*M30**3)
      T1=T1-(81.0D0*DCOS(DBLE(Q3))**2*DCOS(DBLE(Q2))**2*P**4*
     . M30**2*J30X)+729.0D0*P**6*M30**3+81.0D0*P**6*M30**2*
     . M10+81.0D0*P**4*M30**2*J30Y+81.0D0*P**4*M30**2*J10Y+
     . 81.0D0*P**4*M30**2*J30X+9.0D0*P**4*M30*J30Y*M10+9.0D0*
     . P**4*M30*M10*J30X+9.0D0*P**2*M30*J30Y*J10Y+9.0D0*P**2*
     . M30*J30Y*J30X
      MIV(3,3)=(T0+9.0D0*P**2*M30*J10Y+P**2*J30Y*M10+J30Y*
     . J10Y)/(T1+9.0D0*P**2*M30*J10Y*J30X+P**2*J30Y*M10*J30X+
     . J30Y*J10Y*J30X)
      DO 25007 J=1,3
          DO 25008 K=J+1,3
              M(K,J)=M(J,K)
              MIV(K,J)=MIV(J,K)
25008     CONTINUE
25007 CONTINUE
\end{framedverbatim}
\bibliography{gentran}
\bibliographystyle{plain}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/utils.red0000644000175000017500000003043211526203062024000 0ustar  giovannigiovannimodule utils;   %%  GENTRAN Utility Functions  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  ALL FUNCTIONS


symbolic$


% User-Accessible Primitive Function %
operator genstmtnum$

% User-Accessible Global Variables %
global '(genstmtincr!* genstmtnum!* tablen!*)$
share genstmtincr!*, genstmtnum!*, tablen!*$
genstmtincr!* := 1$
genstmtnum!*  := 25000$
tablen!*      := 4$

% GENTRAN Global Variables %
global '(!*lisparithexpops!* !*lispdefops!* !*lisplogexpops!*
         !*lispstmtgpops!* !*lispstmtops!* !*symboltable!*)$
!*lisparithexpops!* := '(expt minus plus quotient times)$
    %LISP arithmetic expression operators
!*lispdefops!*      := '(defun)$  %LISP function definition operator
!*lisplogexpops!*   := '(and equal geq greaterp leq lessp neq not or)$
    %LISP logical & relational exp operators
!*lispstmtgpops!*   := '(prog progn)$  %LISP statement group operators
!*lispstmtops!*     := '(break cond end for go read repeat
                         return setq stop while write)$
%LISP statement operators
!*symboltable!*     := '(!*main!*)$  %symbol table

global '(!*for!*)$


%%                                      %%
%% Statement Number Generation Function %%
%%                                      %%


procedure genstmtnum;
genstmtnum!* := genstmtnum!* + genstmtincr!*$


%%                                                        %%
%% Symbol Table Insertion, Retrieval & Deletion Functions %%
%%                                                        %%


procedure symtabput(name, type, value);
%                                                                      %
% CALL                                               INSERTS           %
% SymTabPut(subprogname, NIL,         NIL         )  subprogram name   %
% SymTabPut(subprogname, '!*Type!*,   subprogtype )  subprogram type   %
% SymTabPut(subprogname, '!*Params!*, paramlist   )  parameter list    %
% SymTabPut(subprogname, vname,  '(type d1 d2 ...))  type & dimensions %
%                                                    for variable,     %
%                                                    variable range,   %
%   if subprogname=NIL                               parameter, or     %
%      then subprogname <-- Car symboltable          function name     %
%                                                                      %
<<
    name := name or car !*symboltable!*;
    !*symboltable!* := name . delete(name, !*symboltable!*);
    if type memq '(!*type!* !*params!*) then
        put(name, type, value)
    else if type then
        begin
        scalar v, vtype, vdims, dec, decs;
        v := type;
        vtype := car value;
        vdims := cdr value;
        decs := get(name, '!*decs!*);
        dec := assoc(v, decs);
        decs := delete(dec, decs);
        vtype := vtype or (if length dec > 1 then cadr dec);
        vdims := vdims or (if length dec > 2 then cddr dec);
        dec := v . vtype . vdims;
        put(name, '!*decs!*, append(decs, list dec))
        end
>>$

procedure symtabget(name, type);
%                                                                      %
% CALL                                 RETRIEVES                       %
% SymTabGet(NIL,         NIL        )  all subprogram names            %
% SymTabGet(subprogname, '!*Type!*  )  subprogram type                 %
% SymTabGet(subprogname, '!*Params!*)  parameter list                  %
% SymTabGet(subprogname, vname      )  type & dimensions for variable, %
%                                      variable range, parameter, or   %
%                                      function name                   %
% SymTabGet(subprogname, '!*Decs!*  )  all types & dimensions          %
%                                                                      %
%   if subprogname=NIL & 2nd arg is non-NIL                            %
%      then subprogname <-- Car symboltable                            %
%                                                                      %
<<
    if type then name := name or car !*symboltable!*;
    if null name then
        !*symboltable!*
    else if type memq '(!*type!* !*params!* !*decs!*) then
        get(name, type)
    else
        assoc(type, get(name, '!*decs!*))
>>$


symbolic procedure declared!-as!-float u;
begin scalar decs;
    return (decs := symtabget(nil,u)) and
            memq(cadr decs,
                 '(real real!*8 real!*16
                   double! precision double float) )$
end$

procedure symtabrem(name, type);
%                                                                      %
% CALL                                 DELETES                         %
% SymTabRem(subprogname, NIL        )  subprogram name                 %
% SymTabRem(subprogname, '!*Type!*  )  subprogram type                 %
% SymTabRem(subprogname, '!*Params!*)  parameter list                  %
% SymTabRem(subprogname, vname      )  type & dimensions for variable, %
%                                      variable range, parameter, or   %
%                                      function name                   %
% SymTabRem(subprogname, '!*Decs!*  )  all types & dimensions          %
%                                                                      %
%   if subprogname=NIL                                                 %
%      then subprogname <-- Car symboltable                            %
%                                                                      %
<<
    name := name or car !*symboltable!*;
    if null type then
        !*symboltable!* := delete(name, !*symboltable!*) or '(!*main!*)
    else if type memq '(!*type!* !*params!* !*decs!*) then
        remprop(name, type)
    else
        begin
        scalar v, dec, decs;
        v := type;
        decs := get(name, '!*decs!*);
        dec := assoc(v, decs);
        decs := delete(dec, decs);
        put(name, '!*decs!*, decs)
        end
>>$

procedure getvartype var;
begin
scalar type;
if pairp var then
    var := car var;
type := symtabget(nil, var);
if type and length type >= 2 then
    type := cadr type
else
    type := nil;
return type
end$

procedure arrayeltp exp;
length symtabget(nil, car exp) > 2 or equal(car exp,'dummyArrayToken)$


%%                                 %%
%% Functions for Making LISP Forms %%
%%                                 %%


procedure mkassign(var, exp);
list('setq, var, exp)$

procedure mkcond pairs;
'cond . pairs$

procedure mkdef(name, params, body);
append(list('defun, name, params), body)$

procedure mkreturn exp;
list('return, exp)$

procedure mkstmtgp(vars, stmts);
if numberp vars then
    'progn . stmts
else
    'prog . vars . stmts$


%% LISP Form Predicates %%


procedure lispassignp stmt;
eqcar(stmt,'setq)$

procedure lispbreakp form;
eqcar(form, 'break)$

procedure lispcallp form;
pairp form$

procedure lispcondp stmt;
eqcar(stmt, 'cond)$

procedure lispdefp form;
pairp form and car form memq !*lispdefops!*$

procedure lispexpp form;
atom form or
car form memq !*lisparithexpops!* or
car form memq !*lisplogexpops!* or
not (car form memq !*lispstmtops!*) and
not (car form memq !*lispstmtgpops!*) and
not (car form memq !*lispdefops!*)$

procedure lispendp form;
   eqcar( form, 'end)$

procedure lispforp form;
   eqcar( form, !*for!*)$

procedure lispgop form;
   eqcar( form, 'go)$

procedure lisplabelp form;
   atom form$

procedure lispprintp form;
   eqcar( form, 'write)$

procedure lispreadp form;
   eqcar( form, 'read)$

procedure lisprepeatp form;
   eqcar(form, 'repeat)$

procedure lispreturnp stmt;
   eqcar( stmt, 'return)$

procedure lispstmtp form;
atom form or
car form memq !*lispstmtops!* or
( atom car form and
  not (car form memq !*lisparithexpops!* or
       car form memq !*lisplogexpops!* or
       car form memq !*lispstmtgpops!* or
       car form memq !*lispdefops!*) )$

procedure lispstmtgpp form;
pairp form and car form memq !*lispstmtgpops!*$

procedure lispstopp form;
   eqcar(form, 'stop)$

procedure lispwhilep form;
   eqcar(form, 'while)$


%%                                               %%
%% Type Predicates & Type List Forming Functions %%
%%                                               %%


procedure formtypelists varlists;
% ( (var TYPE d1 d2...)       ( (TYPE (var d1 d2...) ...)   %
%   :                     ==>   :                           %
%   (var TYPE d1 d2...) )       (TYPE (var d1 d2...) ...) ) %
begin
scalar type, typelists, tl;
for each vl in varlists do
<<
    type := cadr vl;
    if onep length(vl := delete(type, vl)) then
        vl := car vl;
    if (tl := assoc(type, typelists)) then
        typelists := delete(tl, typelists)
    else
        tl := list type;
    typelists := append(typelists, list append(tl, list vl))
>>;
return typelists
end$


procedure functionformp(stmt, name);
% Does stmt contain an assignment which assigns a value to name? %
% Does it contain a RETURN exp; stmt?                            %
% (i.e., (SETQ name exp) -or- (RETURN exp)                       %
if null stmt or atom stmt then
    nil
else if car stmt eq 'setq and cadr stmt eq name then
    t
else if car stmt eq 'return and cdr stmt then
    t
else
    lispeval('or . for each st in stmt collect functionformp(st, name))$

procedure implicitp type;
begin
scalar xtype, ximp, r;
xtype := explode2 type;
ximp := explode2 'implicit;
r := t;
repeat
    r := r and (car xtype eq car ximp)
until null(xtype := cdr xtype) or null(ximp := cdr ximp);
return r
end$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure insertcommas lst;
begin
scalar result;
if null lst then
    return nil;
result := list car lst;
while lst := cdr lst do
    result := car lst . '!, . result;
return reverse result
end$

procedure insertparens exp;
'!( . append(exp, list '!))$

procedure optype op;
get(op, '!*optype!*)$

put('minus,    '!*optype!*, 'unary )$
put('not,      '!*optype!*, 'unary )$
put('quotient, '!*optype!*, 'binary)$
put('expt,     '!*optype!*, 'binary)$
put('equal,    '!*optype!*, 'binary)$
put('neq,      '!*optype!*, 'binary)$
put('greaterp, '!*optype!*, 'binary)$
put('geq,      '!*optype!*, 'binary)$
put('lessp,    '!*optype!*, 'binary)$
put('leq,      '!*optype!*, 'binary)$
put('plus,     '!*optype!*, 'nary  )$
put('times,    '!*optype!*, 'nary  )$
put('and,      '!*optype!*, 'nary  )$
put('or,       '!*optype!*, 'nary  )$

procedure seqtogp lst;
if null lst or atom lst or lispstmtp lst or lispstmtgpp lst then
    lst
else if onep length lst and pairp car lst then
    seqtogp car lst
else
    mkstmtgp(nil, for each st in lst collect seqtogp st)$

procedure stringtoatom a;
intern compress
    foreach c in append('!" . explode2 a, list '!")
        conc list('!!, c)$

procedure stripquotes a;
if atom a then
    intern compress
        for each c in explode2 a conc list('!!, c)
else if car a eq 'quote then
    stripquotes cadr a
else
    a$

symbolic procedure flushspaces c;
<< while seprp c do
   <<
     if c eq !$eol!$
         then pterpri()
         else pprin2 c;
     c := readch()
   >>;
   c
   >>;

symbolic procedure flushspacescommas c;
<< while seprp c or c eq '!, do
   <<
     if c eq !$eol!$
         then pterpri()
         else pprin2 c;
     c := readch()
   >>;
   c
   >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gparser.red0000644000175000017500000002022611526203062024303 0ustar  giovannigiovannimodule gparser;    %%  GENTRAN Parser Module  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  GentranParse


symbolic$

% GENTRAN Global Variable %
global '(!*reservedops!*)$
!*reservedops!* := '(and rblock cond difference equal expt for geq go
                     greaterp leq lessp mat minus neq not or plus
                     procedure progn quotient read recip repeat return
                     setq times while write)$ %reserved operators


symbolic procedure gentranparse forms;
begin scalar found_error;
  for each f in forms do
    if not(gpstmtp f or gpexpp f or gpdefnp f) then
    <<
        gentranerr('e, f, "CANNOT BE TRANSLATED", nil);
        % If we are processing a template (for example) then this will
        % not result in a hard error, so make Gentran aware that
        % something went wrong:
        found_error := 't;
    >>;
  return not found_error;
end$

procedure gpexpp exp;
%  exp  ::=  id | number | (PLUS exp exp') | (MINUS exp) |             %
%         (DIFFERENCE exp exp) | (TIMES exp exp exp') |                %
%         (RECIP exp) |(QUOTIENT exp exp) | (EXPT exp exp) | (id arg') %
if atom exp then
    idp exp or numberp exp
else if car exp memq '(!:rd!: !:cr!:  !:crn!: !:gi!:) then
    t
else
    if car exp eq 'plus then
        length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp
    else if car exp memq '(minus recip) then
        length exp=2 and gpexpp cadr exp
    else if car exp memq '(difference quotient expt) then
        length exp=3 and gpexpp cadr exp and gpexpp caddr exp
    else if car exp eq 'times then
        length exp >= 3 and gpexpp cadr exp and gpexpp caddr exp and
         gpexp1p cdddr exp
    else if car exp eq '!:rd!: then t
    else if car exp memq '(!:cr!: !:crn!: !:gi!:) then t
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gpexp1p exp;
%  exp'  ::=  exp exp' | eps  %
null exp or (gpexpp car exp and gpexp1p cdr exp)$

procedure gplogexpp exp;
%  logexp  ::=  id | (EQUAL exp exp) | (NEQ exp exp) |                 %
%            (GREATERP exp exp) |(GEQ exp exp) | (LESSP exp exp) |     %
%            (LEQ exp exp) | (NOT logexp) | (AND logexp logexp logexp')%
%            | (OR logexp logexp logexp') | (id arg')                  %
if atom exp then
    idp exp
else
    if car exp memq '(equal neq greaterp geq lessp leq) then
        length exp=3 and gpexpp cadr exp and gpexpp caddr exp
    else if car exp eq 'not then
        length exp=2 and gplogexpp cadr exp
    else if car exp memq '(and or) then
        length exp >= 3 and gplogexpp cadr exp and gplogexpp caddr exp
        and gplogexp1p cdddr exp
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gplogexp1p exp;
%  logexp'  ::=  logexp logexp' | eps  %
null exp or (gplogexpp car exp and gplogexp1p cdr exp)$

procedure gpargp exp;
%  arg  ::=  string | exp | logexp  %
stringp exp or gpexpp exp or gplogexpp exp$

procedure gparg1p exp;
%  arg'  ::=  arg arg' | eps  %
null exp or (gpargp car exp and gparg1p cdr exp)$

procedure gpvarp exp;
%  var  ::=  id | (id exp exp')  %
if atom exp then
    idp exp
else
    if unresidp car exp then
        length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp$

procedure gplistp exp;
%  list  ::=  (exp exp')  %
if pairp exp then
    length exp >= 1 and gpexpp car exp and gpexp1p cdr exp$

procedure gplist1p exp;
%  list'  ::=  list list' | eps  %
null exp or (gplistp car exp and gplist1p cdr exp)$

procedure gpid1p exp;
%  id'  ::=  id id' | eps  %
null exp or (idp car exp and gpid1p cdr exp)$

procedure gpstmtp exp;
%  stmt  ::=  id | (SETQ setq') | (COND cond') | (WHILE logexp stmt) | %
%             (REPEAT stmt logexp) | (FOR var (exp exp exp) DO stmt) | %
%             (GO id) | (RETURN arg) | (WRITE arg arg') |              %
%             (PROGN stmt stmt') | (BLOCK (id') stmt') | (id arg')     %
if atom exp then
    idp exp
else if car exp memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
    nil
else
    if car exp eq 'setq then
        gpsetq1p cdr exp
    else if car exp eq 'cond then
        gpcond1p cdr exp
    else if car exp eq 'while then
        length exp=3 and gplogexpp cadr exp and gpstmtp caddr exp
    else if car exp eq 'repeat then
        length exp=3 and gpstmtp cadr exp and gplogexpp caddr exp
    else if car exp eq 'for then
        length exp=5 and gpvarp cadr exp and pairp caddr exp and
         (length caddr exp=3 and gpexpp car caddr exp and
          gpexpp cadr caddr exp and gpexpp caddr caddr exp) and
           cadddr exp eq 'do and gpstmtp car cddddr exp
    else if car exp eq 'go then
        length exp=2 and idp cadr exp
    else if car exp eq 'return then
        length exp=2 and gpargp cadr exp
    else if car exp eq 'write then
        length exp >= 2 and gpargp cadr exp and gparg1p cddr exp
    else if car exp eq 'progn then
        length exp >= 2 and gpstmtp cadr exp and gpstmt1p cddr exp
    else if car exp eq 'rblock then
        length exp >= 2 and gpid1p cadr exp and gpstmt1p cddr exp
    else if unresidp car exp then
        gparg1p cdr exp$

procedure gpsetq1p exp;
%  setq'  ::=  id setq'' | (id exp exp') setq'''  %
if exp and length exp=2 then
    if atom car exp then
        idp car exp and gpsetq2p cdr exp
    else
        (length car exp >= 2 and idp car car exp
             and unresidp car car exp and gpexpp cadr car exp
             and gpexp1p cddr car exp) and gpsetq3p cdr exp$

procedure gpsetq2p exp;
%  setq''  ::=  (MAT list list') | setq'''  %
if exp then
    if eqcar(car exp, 'mat) then
        onep length exp and (gplistp cadar exp and gplist1p cddar exp)
    else
        gpsetq3p exp$

procedure gpsetq3p exp;
% setq''' ::= (FOR var (exp exp exp) forop exp) | (READ) | exp | logexp
if exp and onep length exp then
    gpexpp car exp or
     gplogexpp car exp or
        (if caar exp eq 'for then
            length car exp=5 and gpvarp cadar exp and
             (pairp caddar exp and length caddar exp=3 and
              gpexpp car caddar exp and gpexpp cadr caddar exp and
               gpexpp caddr caddar exp) and gpforopp car cdddar exp and
                gpexpp cadr cdddar exp
        else if caar exp eq 'read then
            onep length car exp)$

procedure gpforopp exp;
%  forop  ::=  SUM | PRODUCT  %
exp memq '(sum product)$

procedure gpcond1p exp;
%  cond'  ::=  (logexp stmt) cond' | eps  %
null exp or
    (pairp car exp and length car exp=2 and gplogexpp caar exp and
     gpstmtp cadar exp and gpcond1p cdr exp)$

procedure gpstmt1p exp;
%  stmt'  ::=  stmt stmt' | eps  %
   null exp or (gpstmtp car exp and gpstmt1p cdr exp)$

procedure gpdefnp exp;
%  defn  ::=  (PROCEDURE id NIL EXPR (id') stmt)  %
eqcar(exp, 'procedure) and length exp=6 and
 idp cadr exp and null caddr exp and atom cadddr exp and
 gpid1p car cddddr exp and gpstmtp cadr cddddr exp
        and not idp cadr cddddr exp$

%%            %%
%% Predicates %%
%%            %%


procedure unresidp id;
not (id memq !*reservedops!*)$


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/lspc.red0000644000175000017500000005554311526203062023613 0ustar  giovannigiovannimodule lspc;    %%  GENTRAN LISP-to-C Translation Module  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  CCode


symbolic$

fluid '(!*double !*gendecs)$

switch gendecs$

% User-Accessible Global Variables %
global '(clinelen!* minclinelen!* !*ccurrind!* ccurrind!* tablen!*)$
share clinelen!*, minclinelen!*, ccurrind!*, tablen!*$
ccurrind!* := 0$
clinelen!*       := 80$
minclinelen!*    := 40$
!*ccurrind!*    := 0$     %current level of indentation for C code

global '(deftype!* !*c!-functions!*)$
global '(!*posn!* !$!#);

!*c!-functions!* := '(sin cos tan asin acos atan atan2 sinh cosh tanh
                     asinh acosh atanh sincos sinpi cospi tanpi asinpi
                     acospi atanpi exp expm1 exp2 exp10 log log1p log2
                     log10 pow compound annuity abs fabs fmod sqrt
                     cbrt)$

flag( '(abs),'!*int!-args!*)$ % Intrinsic function with integer arg.
%%                                 %%
%% LISP-to-C Translation Functions %%
%%                                 %%


put('c,'formatter,'formatc);
put('c,'codegen,'ccode);
put('c,'proctem,'procctem);
put('c,'gendecs,'cdecs);
put('c,'assigner,'mkfcassign);
put('c,'boolean!-type,'!i!n!t);

%% Control Function %%


symbolic procedure ccode forms;
for each f in forms conc
    if atom f then
        cexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
        cexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(cdecs symtabget('!*main!*, '!*decs!*),
                        cstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            cstmt f
    else if lispdefp f then
        cproc f
    else
        cexp f$


%% Procedure Translation %%


symbolic procedure cproc deff; % Type details amended mcd 3/3/88
begin
scalar type, name, params, paramtypes, vartypes, body, r;
name := cadr deff;
if onep length (body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if (type := symtabget(name, name)) then
<<      type := cadr type;

        % Convert reduce types to c types

        if type equal 'real then
                type := '!f!l!o!a!t
        else if type equal 'integer then
                type := '!i!n!t;

        if !*double then
                if type equal '!f!l!o!a!t then
                        type := '!d!o!u!b!l!e
                else if type equal '!i!n!t then
                        type := '!l!o!n!g;

        symtabrem(name, name)
>>;
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
for each dec in symtabget(name, '!*decs!*) do
    if car dec memq params
       then paramtypes := append(paramtypes, list dec)
       else vartypes := append(vartypes, list dec);
r := append( append( mkfcprocdec(type, name, params),
                     cdecs paramtypes ),
             mkfcbegingp() );
indentclevel(+1);
if !*gendecs then
    r := append(r, cdecs vartypes);
r := append(r, for each s in body
                   conc cstmt s);
indentclevel(-1);
r := append(r, mkfcendgp());
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


symbolic procedure cdecs decs;
for each tl in formtypelists decs
    conc mkfcdec(car tl, cdr tl)$


%% Expression Translation %%


symbolic procedure cexp exp;
cexp1(exp, 0)$

symbolic procedure cexp1(exp, wtin);
if atom exp then
    list cname exp
else
    if onep length exp then
        append(cname exp, insertparens(()))
    else if car exp eq 'expt then
      if caddr exp = 2 then
        cexp1 (list('times, cadr exp, cadr exp), wtin)
      else if caddr exp = 3 then
        cexp1 (list('times, cadr exp, cadr exp, cadr exp), wtin)
      else if caddr exp = 4  then
        cexp1(list('times,cadr exp,cadr exp,cadr exp,cadr exp),wtin)
      else if caddr exp = '(quotient 1 2) then
        cexp1 (list('sqrt, cadr exp), wtin)
      else
        cexp1 ('pow . cdr exp,wtin)
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := cprecedence car exp;
        op := cop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . cexp1(car exp, wt)
        else
        <<
            res := cexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, cexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  cexp1(car exp, wt))
        >>;
        if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        cliteral exp
    else if car exp eq 'range then
        if cadr exp = 0 then cexp caddr exp
           else gentranerr('e,exp,
                   "C does not support non-zero lower bounds",nil)
    else if car exp eq '!:rd!: then
        if smallfloatp cdr exp then
            list cdr exp
        else
        begin scalar mt; % Print bigfloats more naturally.
            integer dotpos,!:lower!-sci!:,!:upper!-sci!:;
                    % This forces most numbers to exponential format.
            mt := rd!:explode exp;
            exp := car mt;
            mt  := cadr mt + caddr mt - 1;

            exp := append(list('literal,car exp, '!.),cdr exp);
            if null (mt = 0) then
                exp := append(exp,
                              list('!e,mt));
            return cliteral exp;
        end
else if car exp memq '(!:cr!: !:crn!: !:gi!:) then
        gentranerr('e,exp,"C doesn't support complex data type",nil)
    else if arrayeltp exp then
        cname car exp . foreach s in cdr exp conc
                                insertbrackets cexp1(s, 0)
    else if memq(car exp,!*c!-functions!*) then
        begin scalar op,res,dblp;
        dblp := not get(car exp,'!*int!-args!*);
        op := cname car exp;
        res := '!( . list op ;
        while exp := cdr exp do
        <<
           op := cexp1(car exp, 0);
           if dblp and not
                (is!-c!-float(op) or is!-c!-float(car exp)) then
             op := if fixp car op then
                 (float car op) . (cdr op)
             else
                 append(list('!(,'!d!o!u!b!l!e,'!),'!(),
                        append(op,list '!)));
           res := if cdr exp then
             append('!, . reversip op,res)
           else
             append(reversip op,res);
        >>;
        return reversip ( '!) . res )
        end
    else if cfunctcallp exp then
        begin
        scalar op, res;
        op := cname car exp;
        exp := cdr exp;
        res := '!( . cexp1(car exp, 0);
        while exp := cdr exp do
            res := append(res, '!, . cexp1(car exp, 0));
        return op . append(res, list('!)) )
        end
    else
        begin
        scalar op, res;
        op := cname car exp;
        exp := cdr exp;
        res := append( '![ . cexp1(car exp, 0),list('!]) );
        % Changed to generate proper C arrays - mcd 25/9/89
        while exp := cdr exp do
            res := append(res, append('![ . cexp1(car exp, 0)
                                      ,list('!]) ) );
        return op . res
        end$

symbolic procedure string2id str;
intern compress reversip cdr reversip cdr explode str$

symbolic procedure is!-c!-float u;
   % Returns T if u is a float or a list whose car is an intrinsic
   % function name with a floating point result.
   floatp(u) or (idp u and declared!-as!-float(u) ) or
   pairp(u) and (car u eq '!:rd!: or
      stringp car u and memq(string2id car u,!*c!-functions!*) and
          not flagp(string2id car u, '!*int!-args!*) or
      declared!-as!-float(car u) )$


symbolic procedure cfunctcallp exp;
symtabget(car exp,'!*type!*)$


symbolic procedure cop op;
get(op, '!*cop!*) or op$

put('or,       '!*cop!*, '!|!|)$
put('and,      '!*cop!*, '!&!&)$
put('not,      '!*cop!*, '!!  )$
put('equal,    '!*cop!*, '!=!=)$
put('neq,      '!*cop!*, '!!!=)$
put('greaterp, '!*cop!*, '>   )$
put('geq,      '!*cop!*, '!>!=)$
put('lessp,    '!*cop!*, '<   )$
put('leq,      '!*cop!*, '!>;
if stmt then
<<
    r := append(r, mkfcelse());
    indentclevel(+1);
    st := seqtogp cdar stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, cstmt st);
    indentclevel(-1)
>>;
return r
end$

symbolic procedure clabel label;
mkfclabel label$

symbolic procedure cliteral stmt;
mkfcliteral cdr stmt$

symbolic procedure crepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfcdo();
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return append(r, mkfcdowhile list('not, logexp))
end$

symbolic procedure creturn stmt;
if cdr stmt then
    mkfcreturn cadr stmt
else
    mkfcreturn nil$

symbolic procedure cstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
    stmtgp := cdr stmtgp
else
    stmtgp :=cddr stmtgp;
r := mkfcbegingp();
indentclevel(+1);
r := append(r, for each stmt in stmtgp conc cstmt stmt);
indentclevel(-1);
return append(r, mkfcendgp())
end$

symbolic procedure cwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfcwhile logexp;
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return r
end$


%%                             %%
%% C Code Formatting Functions %%
%%                             %%


%% Statement Formatting %%


% A macro used to prevent things with *cname*
% properties being evaluated in certain circumstances.  MCD 28.3.94
symbolic smacro procedure cexp_name(u);
   if atom u then list(u)
    else rplaca(cexp ('dummyArrayToken . cdr u), car u)$

symbolic procedure mkfcassign(lhs, rhs);
begin
scalar st;
if length rhs = 3 and lhs member rhs then
    begin
    scalar op, exp1, exp2;
    op := car rhs;
    exp1 := cadr rhs;
    exp2 := caddr rhs;
    if op = 'plus then
        if onep exp1 or onep exp2 then
            st := ('!+!+ . cexp_name lhs)
        else if exp1 member '(-1 (minus 1))
           or exp2 member '(-1 (minus 1)) then
            st := ('!-!- . cexp_name lhs)
        else if eqcar(exp1, 'minus) then
            st := append(cexp_name lhs, '!-!= . cexp cadr exp1)
        else if eqcar(exp2, 'minus) then
            st := append(cexp_name lhs, '!-!= . cexp cadr exp2)
        else if exp1 = lhs then
            st := append(cexp_name lhs, '!+!= . cexp exp2)
        else
            st := append(cexp_name lhs, '!+!= . cexp exp1)
    else if op = 'difference and onep exp2 then
        st := ('!-!- . cexp_name lhs)
    else if op = 'difference and exp1 = lhs then
        st := append(cexp_name lhs, '!-!= . cexp exp2)
    else if op = 'times and exp1 = lhs then
        st := append(cexp_name lhs, '!*!= . cexp exp2)
    else if op = 'times then
        st := append(cexp_name lhs, '!*!= . cexp exp1)
    else if op = 'quotient and exp1 = lhs then
        st := append(cexp_name lhs, '!/!= . cexp exp2)
    else
        st := append(cexp_name lhs, '!= . cexp rhs)
    end
else
    st := append(cexp_name lhs, '!= . cexp rhs);
return append(mkctab() . st, list('!;, mkcterpri()))
end$

symbolic procedure mkfcbegingp;
list(mkctab(), '!{, mkcterpri())$

symbolic procedure mkfcbreak;
list(mkctab(), '!b!r!e!a!k, '!;, mkcterpri())$

symbolic procedure mkfcdec(type, varlist); %Amended mcd 13/11/87,3/3/88
<<
    if type equal 'scalar then
        type := deftype!*;

    % Convert Reduce types to C types.
    if type equal 'real then
        type := '!f!l!o!a!t
    else if type equal 'integer then
        type := '!i!n!t;

    % Deal with precision.
    if !*double then
        if type equal '!f!l!o!a!t then
                type := '!d!o!u!b!l!e
        else if type equal '!i!n!t then
                type := '!l!o!n!g;

    varlist := for each v in varlist collect
           if atom v then
               v
           else
               car v . for each dim in cdr v collect
                       if dim eq 'times then '!  %
                       else if numberp dim then add1 dim
                       else if eqcar (dim, 'range) and cadr dim = 0
                         then add1 caddr dim
                       else gentranerr('e,dim,"Not C dimension",nil);
    append(mkctab() . type . '!  . for each v in insertcommas varlist
                                       conc cexp_name v,
           list('!;, mkcterpri()))
>>$

symbolic procedure mkfcdo;
list(mkctab(), '!d!o, mkcterpri())$

symbolic procedure mkfcdowhile exp;
append(append(list(mkctab(), '!w!h!i!l!e, '! , '!(), cexp exp),
       list('!), '!;, mkcterpri()))$

symbolic procedure mkfcelse;
list(mkctab(), '!e!l!s!e, mkcterpri())$

symbolic procedure mkfcelseif exp;
append(append(list(mkctab(), '!e!l!s!e, '! , '!i!f, '! , '!(),
              cexp exp),
       list('!), mkcterpri()))$

symbolic procedure mkfcendgp;
list(mkctab(), '!}, mkcterpri())$

symbolic procedure mkfcexit;
list(mkctab(), '!e!x!i!t, '!(, 0, '!), '!;, mkcterpri())$

symbolic procedure mkfcfor(var1, lo, cond, var2, nextexp);
<<
    if var1 then
        var1 := append(cexp var1, '!= . cexp lo);
    if cond then
        cond := cexp cond;
    if var2 then
    <<
        var2 := cdr mkfcassign(var2, nextexp);
        var2 := reverse cddr reverse var2
    >>;
    append(append(append(list(mkctab(), '!f!o!r! , '! , '!(), var1),
                         '!; . cond),
           append('!; . var2, list('!), mkcterpri())))
>>$

symbolic procedure mkfcgo label;
list(mkctab(), '!g!o!t!o, '! , label, '!;, mkcterpri())$

symbolic procedure mkfcif exp;
append(append(list(mkctab(), '!i!f, '! , '!(), cexp exp),
       list('!), mkcterpri()))$

symbolic procedure mkfclabel label;
list(label, '!:, mkcterpri())$

symbolic procedure mkfcliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkctab()
    else if a eq 'cr!* then
        list mkcterpri()
    else if pairp a then
        cexp a
    else
        list stripquotes a$

symbolic procedure mkfcprocdec(type, name, params);
<<
    params := append('!( . for each p in insertcommas params
                              conc cexp p,
                     list '!));
    if type then
        append(mkctab() . type . '!  . cexp name,
               append(params,list mkcterpri()))
    else
        append(mkctab() . cexp name, append(params, list mkcterpri()))
>>$

symbolic procedure mkfcreturn exp;
if exp then
    append(append(list(mkctab(), '!r!e!t!u!r!n, '!(), cexp exp),
           list('!), '!;, mkcterpri()))
else
    list(mkctab(), '!r!e!t!u!r!n, '!;, mkcterpri())$

symbolic procedure mkfcwhile exp;
append(append(list(mkctab(), '!w!h!i!l!e, '! , '!(), cexp exp),
       list('!), mkcterpri()))$


%% Indentation Control %%


symbolic procedure mkctab;
list('ctab, ccurrind!*)$


symbolic procedure indentclevel n;
ccurrind!* := ccurrind!* + n * tablen!*$


symbolic procedure mkcterpri;
list 'cterpri$


%%                 %%
%% Misc. Functions %%
%%                 %%


symbolic procedure insertbrackets exp;
'![ . append(exp, list '!])$


%% C Code Formatting & Printing Functions %%


symbolic procedure formatc lst;
begin
scalar linelen;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if pairp elt then lispeval elt
    else
    <<
        if !*posn!* + length explode2 elt > clinelen!* then
            ccontline();
        pprin2 elt
    >>;
linelength linelen
end$

symbolic procedure ccontline;
<<
    cterpri();
    ctab !*ccurrind!*;
    pprin2 " "
>>$

symbolic procedure cterpri;
pterpri()$

symbolic procedure ctab n;
<<
    !*ccurrind!* := min0(n, clinelen!* - minclinelen!*);
    if (n := !*ccurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$

%% C template processing %%


symbolic procedure procctem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
if c eq '!# then c := procc!#line c;
while c neq !$eof!$ do
    if c eq !$eol!$ then
        c := procc!#line c
    else if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else
        c := proccheader(c);
linelength linelen
end$

symbolic procedure procc!#line c;
%  # ...   %
begin
if c eq !$eol!$ then
<<  pterpri();  c := readch()  >>;
if c eq '!# then
    repeat
    <<  pprin2 c;  c := readch()  >>
    until c eq !$eol!$;
return c
end$

symbolic procedure procccomm;
% /* ... */ %
begin
scalar c;
pprin2 '!/;
c := readch();
if c eq '!* then
<<
    pprin2 c;
    c := readch();
    repeat
    <<
        while c neq '!* do
        <<
            if c eq !$eol!$
                then pterpri()
                else pprin2 c;
            c := readch()
        >>;
        pprin2 c;
        c := readch()
    >>
    until c eq '!/;
    pprin2 c;
    c := readch()
>>;
return c
end$

symbolic procedure proccheader c;
begin
scalar name, i;
while seprp c and c neq !$eol!$ do
<<  pprin2 c;  c := readch()  >>;
while not(seprp c or c memq list('!/, '!;, '!()) do
<<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
if c memq list(!$eol!$, '!/, '!;) then return c;
while seprp c and c neq !$eol!$ do
<<  pprin2 c;  c := readch()  >>;
if c neq '!( then return c;
name := intern compress name;
if not !*gendecs then
    symtabput(name, nil, nil);
put('!$0, '!*cname!*, name);
pprin2 c;
i := 1;
c := readch();
while c neq '!) do
<<
    while seprp c or c eq '!, do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>;
    name := list c;
    pprin2 c;
    while not(seprp (c := readch()) or c memq list('!,, '!))) do
    <<  name := aconc(name, c);  pprin2 c  >>;
    put(intern compress append(explode2 '!$, explode2 i),
        '!*cname!*,
        intern compress name);
    i := add1 i;
    c:=flushspaces c
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
          '!*cname!*) do
    remprop(name, '!*cname!*);
return proccfunction c
end$

symbolic procedure proccfunction c;
begin
scalar !{!}count;
while c neq '!{ do
    if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<  pterpri();  c := readch()  >>
    else
    <<  pprin2 c;  c := readch()  >>;
pprin2 c;
!{!}count := 1;
c := readch();
while !{!}count > 0 do
    if c eq '!{ then
    <<  !{!}count := add1 !{!}count;  pprin2 c;  c := readch()  >>
    else if c eq '!} then
    <<  !{!}count := sub1 !{!}count;  pprin2 c;  c := readch()  >>
    else if c eq '!/ then
        c := procccomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<  pterpri();  c := readch()  >>
    else
    <<  pprin2 c;  c := readch()  >>;
return c
end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/lspfor.red0000644000175000017500000006601511526203062024153 0ustar  giovannigiovannimodule lspfor;    %%  GENTRAN LISP-to-FORTRAN Translation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Updates:

% M. Warns 7 Oct 89 Patch in FORTEXP1 for negative constant exponents
%                   and integer arguments of functions like SQRT added.

% M.C. Dewar and J.H. Davenport 8 Jan 88 Double precision etc. added.

% Entry Point:  FortCode

symbolic$


% To allow Fortran-90 Extensions:
fluid '(!*f90)$
switch f90$

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*gendecs)$
switch gendecs$
fluid '(!*getdecs)$

fluid '(!*makecalls)$
switch makecalls$
!*makecalls := t$

% User-Accessible Global Variables %
global '(gentranlang!* fortlinelen!* minfortlinelen!*
         fortcurrind!* !*fortcurrind!* tablen!*)$
share fortcurrind!*, fortlinelen!*, minfortlinelen!*, tablen!*$
fortcurrind!* := 0$
!*fortcurrind!* := 6$     %current level of indentation for FORTRAN code
fortlinelen!*    := 72$
minfortlinelen!* := 40$

% Double Precision Switch (defaults to OFF) - mcd 13/1/88 %
fluid '(!*double);
% !*double := t;
switch double;


% GENTRAN Global Variables %

global '(!*notfortranfuns!* !*endofloopstack!* !*subprogname!*)$
!*notfortranfuns!*:= '(acosh asinh atanh cot dilog ei erf sec)$
                        %mcd 10/11/87
!*endofloopstack!* := nil$
!*subprogname!*    := nil$  %name of subprogram being generated

global '(!*do!* deftype!*)$

% The following ought to be all the legal Fortran types mcd 19/11/87.
global '(!*legalforttypes!*);
!*legalforttypes!* := '(real integer complex real!*8 complex!*16 logical
                        implicit! integer implicit! real
                        implicit! complex implicit! real!*8
                        implicit! complex!*16 implicit! logical)$

global '(!*stdout!*)$
global '(!*posn!* !$!#);
%%                                       %%
%% LISP-to-FORTRAN Translation Functions %%
%%                                       %%

put('fortran,'formatter,'formatfort);
put('fortran,'codegen,'fortcode);
put('fortran,'proctem,'procforttem);
put('fortran,'gendecs,'fortdecs);
put('fortran,'assigner,'mkffortassign);
put('fortran,'boolean!-type,'logical);

%% Control Function %%


symbolic procedure fortcode forms;
for each f in forms conc
    if atom f then
        fortexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
        fortexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(fortdecs symtabget('!*main!*, '!*decs!*),
                        fortstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            fortstmt f
    else if lispdefp f then
        fortsubprog f
    else
        fortexp f$


%% Subprogram Translation %%


symbolic procedure fortsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := !*subprogname!* := cadr deff;
if onep length (body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if lispreturnp (lastst := car reverse body) then
    body := append(body, list '(end))
else if not lispendp lastst then
    body := append(body, list('(return), '(end)));
type :=  symtabget(name, name);
if type then type := cadr type;
stype := symtabget(name, '!*type!*) or
         (    if type or functionformp(body, name)
                 then 'function
                 else 'subroutine    );
symtabrem(name, '!*type!*);
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
if !*getdecs and null type and stype eq 'function
   then type := deftype!*;
if type then
<<  symtabrem(name, name);
    % Generate the correct double precision type name - mcd 28/1/88 %
    if !*double then
        if type memq '(real real!*8) then
                type := 'double! precision
        else if type eq 'complex then
                type := 'complex!*16;
>>;
r := mkffortsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, fortdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc fortstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


symbolic procedure fortdecs decs;
for each tl in formtypelists decs
    conc mkffortdec(car tl, cdr tl)$


%% Expression Translation %%


procedure fortexp exp;
fortexp1(exp, 0)$

symbolic procedure fortexp1(exp, wtin);
if atom exp then
    list fortranname exp
else
    if listp exp and onep length exp then
        fortranname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := fortranprecedence car exp;
        op := fortranop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . fortexp1(car exp, wt)
        else
        <<
            res := fortexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, fortexp1(car exp, wt))
                >>
            else if op eq '!*!*  then
                while exp := cdr exp do
                  begin
                   if numberp car exp and lessp(car exp, 0) then
                    res := append(append(res, list op),
                   insertparens fortexp1(car exp, wt))
                   else
                    res := append(append(res, list op),
                                  fortexp1(car exp, wt))
                  end
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  fortexp1(car exp, wt))
        >>;
        if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        fortliteral exp
    else if car exp eq 'range
        then append(fortexp cadr exp,'!: . fortexp caddr exp)
    else if car exp eq '!:rd!: then
        if smallfloatp cdr exp then
            list cdr exp
        else
        begin scalar mt; % Print bigfloats more naturally. MCD 26/2/90
            integer dotpos,!:lower!-sci!:,!:upper!-sci!:;
                    % This forces most numbers to exponential format.
            mt := rd!:explode exp;
            exp := car mt;
            mt  := cadr mt + caddr mt - 1;
            exp := append(list('literal,car exp, '!.),cdr exp);
            if null (mt = 0) then
                exp := append(exp,
                              list(if !*double then '!D else '!E,mt))
            else if !*double then
                exp := append(exp,'(!D 0));

            return fortliteral exp;
        end
    else if car exp eq '!:crn!: then
        fortexp1(!*crn2cr exp,wtin)
    else if car exp eq '!:gi!: then
        fortexp1(!*gi2cr exp,wtin)
    else if car exp eq '!:cr!: then
        if !*double and !*f90 then
            ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin),
              ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin),
              list( '!, , 'KIND!(!1!.!0!D!0!) , '!) ))
            )
        else
            ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin),
              ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin),
                           list '!)))
               % We must make this list up at run time, since there's
               % a CONC loop that relies on being able to RPLAC into it.
               % Yuck. JHD/MCD 19.6.89
    else
        begin scalar op, res, intrinsic;
        intrinsic := get(car exp, '!*fortranname!*);
        op := fortranname car exp;
        exp := cdr exp;
        % Make the arguments of intrinsic functions real if we aren't
        % sure.  Note that we can't simply evaluate the argument and
        % test that, unless it is a constant.  MCD 7/11/89.
        res := cdr foreach u in exp conc
            '!, . if not intrinsic then
              fortexp1(u,0)
            else if fixp u then
              list float u
            else if isfloat u or memq(op,'(real dble)) then
              fortexp1(u,0)
            else
              (fortranname 'real . insertparens fortexp1(u,0));
        return op . insertparens res
        end;


symbolic procedure isfloat u;
   % Returns T if u is a float or a list whose car is an intrinsic
   % function name.  MCD 7/11/89.
   floatp(u) or (idp u and declared!-as!-float(u) ) or
   pairp(u) and (car u eq '!:rd!: or
                 get(car u,'!*fortranname!*) or
                 declared!-as!-float(car u) );


procedure fortranop op;
get(op, '!*fortranop!*) or op$

put('or,       '!*fortranop!*, '!.or!. )$
put('and,      '!*fortranop!*, '!.and!.)$
put('not,      '!*fortranop!*, '!.not!.)$
put('equal,    '!*fortranop!*, '!.eq!. )$
put('neq,      '!*fortranop!*, '!.ne!. )$
put('greaterp, '!*fortranop!*, '!.gt!. )$
put('geq,      '!*fortranop!*, '!.ge!. )$
put('lessp,    '!*fortranop!*, '!.lt!. )$
put('leq,      '!*fortranop!*, '!.le!. )$
put('plus,     '!*fortranop!*, '!+     )$
put('times,    '!*fortranop!*, '!*     )$
put('quotient, '!*fortranop!*, '/      )$
put('minus,    '!*fortranop!*, '!-     )$
put('expt,     '!*fortranop!*, '!*!*   )$

% This procedure (and FORTRANNAME, RATFORNAME properties, and
% the DOUBLE flag) are shared between FORTRAN and RATFOR
procedure fortranname a; % Amended mcd 10/11/87
if stringp a then
            stringtoatom a    %  convert a to atom containing "'s
else
<<      if a memq !*notfortranfuns!* then
        <<      wrs cdr !*stdout!*;
                prin2 "*** WARNING: ";
                prin1 a;
                prin2t " is not an intrinsic Fortran function";
        >>$

        if !*double then
                get(a, '!*doublename!*) or a
        else
                    get(a, '!*fortranname!*) or a
>>$

put('true,   '!*fortranname!*, '!.true!. )$
put('false, '!*fortranname!*, '!.false!.)$

%% mcd 10/11/87
%% Reduce functions' equivalent Fortran 77 real function names

put('abs,'!*fortranname!*, 'abs)$
put('sqrt,'!*fortranname!*, 'sqrt)$
put('exp,'!*fortranname!*, 'exp)$
put('log,'!*fortranname!*, 'alog)$
put('ln,'!*fortranname!*, 'alog)$
put('sin,'!*fortranname!*, 'sin)$
put('cos,'!*fortranname!*, 'cos)$
put('tan,'!*fortranname!*, 'tan)$
put('acos,'!*fortranname!*, 'acos)$
put('asin,'!*fortranname!*, 'asin)$
put('atan,'!*fortranname!*, 'atan)$
put('sinh,'!*fortranname!*, 'sinh)$
put('cosh,'!*fortranname!*, 'cosh)$
put('tanh,'!*fortranname!*, 'tanh)$
put('real,'!*fortranname!*, 'real)$
put('max,'!*fortranname!*, 'amax1)$
put('min,'!*fortranname!*, 'amin1)$

%% Reduce function's equivalent Fortran 77 double-precision names

put('abs,'!*doublename!*, 'dabs)$
put('sqrt,'!*doublename!*, 'dsqrt)$
put('exp,'!*doublename!*, 'dexp)$
put('log,'!*doublename!*, 'dlog)$
put('ln,'!*doublename!*, 'dlog)$
put('sin,'!*doublename!*, 'dsin)$
put('cos,'!*doublename!*, 'dcos)$
put('tan,'!*doublename!*, 'dtan)$
put('acos,'!*doublename!*, 'dacos)$
put('asin,'!*doublename!*, 'dasin)$
put('atan,'!*doublename!*, 'datan)$
put('sinh,'!*doublename!*, 'dsinh)$
put('cosh,'!*doublename!*, 'dcosh)$
put('tanh,'!*doublename!*, 'dtanh)$
put('true,    '!*doublename!*, '!.true!. )$
put('false,  '!*doublename!*, '!.false!.)$
put('real,'!*doublename!*, 'dble)$
put('max,' !*doublename!*, 'dmax1)$
put('min, '!*doublename!*, 'dmin1)$

%% end of mcd


procedure fortranprecedence op;
get(op, '!*fortranprecedence!*) or 9$

put('or,       '!*fortranprecedence!*, 1)$
put('and,      '!*fortranprecedence!*, 2)$
put('not,      '!*fortranprecedence!*, 3)$
put('equal,    '!*fortranprecedence!*, 4)$
put('neq,      '!*fortranprecedence!*, 4)$
put('greaterp, '!*fortranprecedence!*, 4)$
put('geq,      '!*fortranprecedence!*, 4)$
put('lessp,    '!*fortranprecedence!*, 4)$
put('leq,      '!*fortranprecedence!*, 4)$
put('plus,     '!*fortranprecedence!*, 5)$
put('times,    '!*fortranprecedence!*, 6)$
put('quotient, '!*fortranprecedence!*, 6)$
put('minus,    '!*fortranprecedence!*, 7)$
put('expt,     '!*fortranprecedence!*, 8)$


%% Statement Translation %%


procedure fortstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    fortstmtnum stmt
else if car stmt eq 'literal then
    fortliteral stmt
else if lispreadp stmt then
    fortread stmt
else if lispassignp stmt then
    fortassign stmt
else if lispprintp stmt then
    fortwrite stmt
else if lispcondp stmt then
    fortif stmt
else if lispbreakp stmt then
    fortbreak stmt
else if lispgop stmt then
    fortgoto stmt
else if lispreturnp stmt then
    fortreturn stmt
else if lispstopp stmt then
    fortstop stmt
else if lispendp stmt then
    fortend stmt
else if lispwhilep stmt then
    fortwhile stmt
else if lisprepeatp stmt then
    fortrepeat stmt
else if lispforp stmt then
    fortfor stmt
else if lispstmtgpp stmt then
    fortstmtgp stmt
else if lispdefp stmt then
    fortsubprog stmt
else if lispcallp stmt then
    fortcall stmt$


procedure fortassign stmt;
mkffortassign(cadr stmt, caddr stmt)$

procedure fortbreak stmt;
if null !*endofloopstack!* then
    gentranerr('e, nil, "BREAK NOT INSIDE LOOP - CANNOT BE TRANSLATED",
               nil)
else if atom car !*endofloopstack!* then
    begin
    scalar n1;
    n1 := genstmtnum();
    rplaca(!*endofloopstack!*, list(car !*endofloopstack!*, n1));
    return mkffortgo n1
    end
else
    mkffortgo cadar !*endofloopstack!*$

procedure fortcall stmt;
mkffortcall(car stmt, cdr stmt)$

procedure fortfor stmt;
begin
scalar n1, result, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
!*endofloopstack!* := n1 . !*endofloopstack!*;
result := mkffortdo(n1, var, loexp, hiexp, stepexp);
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortcontinue n1);
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortend stmt;
mkffortend()$

procedure fortgoto stmt;
begin
scalar stmtnum;
if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then
    stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum());
return mkffortgo stmtnum
end$

symbolic procedure fortif stmt;
begin scalar r, st;
    r := mkffortif caadr stmt;
    indentfortlevel(+1);
    st := seqtogp cdadr stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, fortstmt st);
    indentfortlevel(-1);
    stmt := cdr stmt;
    while (stmt := cdr stmt) and caar stmt neq t do
    <<
        r := append(r, mkffortelseif caar stmt);
        indentfortlevel(+1);
        st := seqtogp cdar stmt;
        if eqcar(st, 'cond) and length st=2 then
            st := mkstmtgp(0, list st);
        r := append(r, fortstmt st);
        indentfortlevel(-1)
    >>;
    if stmt then
    <<
        r := append(r, mkffortelse());
        indentfortlevel(+1);
        st := seqtogp cdar stmt;
        if eqcar(st, 'cond) and length st=2 then
            st := mkstmtgp(0, list st);
        r := append(r, fortstmt st);
        indentfortlevel(-1)
    >>;
    return append(r,mkffortendif());
end$


symbolic procedure mkffortif exp;
append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp),
              list('!),'! , 'then , mkfortterpri()))$

symbolic procedure mkffortelseif exp;
append(append(list(mkforttab(), 'else, '! , 'if, '! , '!(),
              fortexp exp),
       list('!), 'then,  mkcterpri()))$

symbolic procedure mkffortelse();
list(mkforttab(), 'else, mkfortterpri())$

symbolic procedure mkffortendif();
list(mkforttab(), 'endif, mkfortterpri())$

procedure fortliteral stmt;
mkffortliteral cdr stmt$

procedure fortread stmt;
mkffortread cadr stmt$

procedure fortrepeat stmt;
begin
scalar n, result, stmtlst, logexp;
stmtlst := reverse cdr stmt;
logexp := car stmtlst;
stmtlst := reverse cdr stmtlst;
n := genstmtnum();
!*endofloopstack!* := 'dummy . !*endofloopstack!*;
result := mkffortcontinue n;
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortifgo(list('not, logexp), n));
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortreturn stmt;
if onep length stmt then
    mkffortreturn()
else if !*subprogname!* then
    append(mkffortassign(!*subprogname!*, cadr stmt), mkffortreturn())
else
    gentranerr('e, nil,
               "RETURN NOT INSIDE FUNCTION - CANNOT BE TRANSLATED",
               nil)$

procedure fortstmtgp stmtgp;
<<
    if car stmtgp eq 'progn then
        stmtgp := cdr stmtgp
    else
        stmtgp := cddr stmtgp;
    for each stmt in stmtgp conc fortstmt stmt
>>$

procedure fortstmtnum label;
begin
scalar stmtnum;
if not ( stmtnum := get(label, '!*stmtnum!*) ) then
    stmtnum := put(label, '!*stmtnum!*, genstmtnum());
return mkffortcontinue stmtnum
end$

procedure fortstop stmt;
mkffortstop()$

procedure fortwhile stmt;
begin
scalar n1, n2, result, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
n2 := genstmtnum();
!*endofloopstack!* := n2 . !*endofloopstack!*;
result := append(list(n1, '! ), mkffortifgo(list('not, logexp), n2));
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
result := append(result, mkffortgo n1);
indentfortlevel(-1);
result := append(result, mkffortcontinue n2);
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$

procedure fortwrite stmt;
mkffortwrite cdr stmt$


%%                                   %%
%% FORTRAN Code Formatting Functions %%
%%                                   %%


%% Statement Formatting %%


% A macro used to prevent things with *fortranname* or *doublename*
% properties being evaluated in certain circumstances.  MCD 28.3.94
symbolic smacro procedure fortexp_name(u);
   if atom u then list(u)
    else rplaca(fortexp ('dummyArrayToken . cdr u), car u)$

symbolic procedure mkffortassign(lhs, rhs);
append(append(mkforttab() . fortexp_name lhs, '!= . fortexp rhs),
       list mkfortterpri())$

symbolic procedure mkffortcall(fname, params);
% Installed the switch makecalls 18/11/88 mcd.
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc fortexp p),
                         list '!));
    % If we want to generate bits of statements, then what might
    % appear a subroutine call may in fact be a function reference.
    if !*makecalls then
            append(append(list(mkforttab(), 'call, '! ), fortexp fname),
           append(params, list mkfortterpri()))
    else
        append(fortexp fname,params)
>>$

procedure mkffortcontinue stmtnum;
list(stmtnum, '! , mkforttab(), 'continue, mkfortterpri())$

symbolic procedure mkffortdec(type, varlist); %Ammended mcd 13/11/87
<<
    if type equal 'scalar then type := deftype!*;
    if type and null (type memq !*legalforttypes!*) then
        gentranerr('e,type,"Illegal Fortran type. ",nil);
    type := type or 'dimension;

    % Generate the correct double precision type name - mcd 14/1/88 %
    if !*double then
        if type memq '(real real!*8) then
                type := 'double! precision
        else if type memq '(implicit! real implicit! real!*8) then
                type := 'implicit! double! precision
        else if type eq 'complex then
                type := 'complex!*16
        else if type eq 'implicit! complex then
                type := 'implicit! complex!*16;

    varlist := for each v in insertcommas varlist
                   conc fortexp_name v;
    if implicitp type then
        append(list(mkforttab(), type, '! , '!(),
               append(varlist, list('!), mkfortterpri())))
    else
        append(list(mkforttab(), type, '! ),
               append(varlist,list mkfortterpri()))
>>$

procedure mkffortdo(stmtnum, var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . fortexp incr;
    append(append(append(list(mkforttab(), !*do!*, '! , stmtnum, '! ),
                         fortexp var),
                  append('!= . fortexp lo, '!, . fortexp hi)),
           append(incr, list mkfortterpri()))
>>$

procedure mkffortend;
list(mkforttab(), 'end, mkfortterpri())$

procedure mkffortgo stmtnum;
list(mkforttab(), 'goto, '! , stmtnum, mkfortterpri())$

procedure mkffortifgo(exp, stmtnum);
append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp),
       list('!), '! , 'goto, '! , stmtnum, mkfortterpri()))$

symbolic procedure mkffortliteral args;
   begin scalar !*lower;
      return for each a in args conc
         if a eq 'tab!* then list mkforttab()
          else if a eq 'cr!* then list mkfortterpri()
          else if pairp a then fortexp a
          else list stripquotes a
   end$

procedure mkffortread var;
append(list(mkforttab(), 'read, '!(!*!,!*!), '! ),
       append(fortexp var, list mkfortterpri()))$

procedure mkffortreturn;
list(mkforttab(), 'return, mkfortterpri())$

procedure mkffortstop;
list(mkforttab(), 'stop, mkfortterpri())$

procedure mkffortsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                   conc fortexp p,
                          list '!));
    if type then
        type := list(mkforttab(), type, '! , stype, '! )
    else
        type := list(mkforttab(), stype, '! );
    append(append(type, fortexp name),
           append(params, list mkfortterpri()))
>>$

procedure mkffortwrite arglist;
append(append(list(mkforttab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc fortexp arg),
       list mkfortterpri())$


%% Indentation Control %%


procedure mkforttab;
list('forttab, fortcurrind!* + 6)$


procedure indentfortlevel n;
fortcurrind!* := fortcurrind!* + n * tablen!*$


procedure mkfortterpri;
list 'fortterpri$

%% FORTRAN Code Formatting & Printing Functions %%

fluid '(maxint);

maxint := 2**31-1;

symbolic procedure formatfort lst;
begin scalar linelen,str,!*lower;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if pairp elt then lispeval elt
    else
    <<
        if fixp elt and (elt>maxint or elt<-maxint) then
           elt := cdr i2rd!* elt;
        str:=explode2 elt;
        if floatp elt then
           if !*double then
              if memq('!e,str)
                 then str:=subst('!D,'!e,str)
                 else if memq('!E,str) % some LISPs use E not e
                      then str:=subst('!D,'!E,str)
                      else str:=append(str,'(D !0))
           else if memq('!e,str) then
                   str:=subst('!E,'!e,str);
           % get the casing conventions correct
        if !*posn!* + length str > fortlinelen!* then
            fortcontline();
        for each u in str do pprin2 u
    >>;
linelength linelen
end$

procedure fortcontline;
<<
    fortterpri();
    pprin2 "     .";
    forttab !*fortcurrind!*;
    pprin2 " "
>>$

procedure fortterpri;
pterpri()$

procedure forttab n;
<<
    !*fortcurrind!* := max(min0(n, fortlinelen!* - minfortlinelen!*),6);
    if (n := !*fortcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$



%% FORTRAN Template routines%%


symbolic procedure procforttem;
   begin scalar c, linelen, !*lower;
      linelen := linelength 150;
      c := procfortcomm();
      while c neq !$eof!$ do
         if c memq '(!F !f !S !s)
           then <>
          else if c eq !$eol!$
           then <>
         else if c eq '!; then c := procactive()
         else <>;
      linelength linelen
   end$

procedure procfortcomm;
% C ...  %
% c ...  %
begin
scalar c;
while (c := readch()) memq '(!C !c) do
<<
    pprin2 c;
    repeat
        if (c := readch()) neq !$eol!$ then
           pprin2 c
    until c eq !$eol!$;
    pterpri()
>>;
return c
end$



%% This function is shared between FORTRAN and RATFOR %%

procedure procsubprogheading c;
% Altered to allow an active statement to be included in a subprogram
% heading.  This is more flexible than forbidding it as in the previous
% version, although it does mean that where such a statement occurs the
% value of !$!# may be incorrect.   MCD 21/11/90
begin
scalar lst, name, i, propname;
lst := if c memq '(!F !f)
          then '((!U !u) (!N !n) (!C !c) (!T !t) (!I !i) (!O !o)
                 (!N !n))
          else '((!U !u) (!B !b) (!R !r) (!O !o) (!U !u)
                 (!T !t) (!I !i) (!N !n) (!E !e));
while lst and (c := readch()) memq car lst do
<<  pprin2 c;  lst := cdr lst  >>;
if lst then return c;
c:=flushspaces readch();
while not(seprp c or c eq '!() do
<<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
name := intern compress name;
if not !*gendecs then
    symtabput(name, nil, nil);
propname := if gentranlang!* eq 'fortran
               then '!*fortranname!*
               else '!*ratforname!*;
put('!$0, propname, name);
c:=flushspaces c;
if c neq '!( then return c;
i := 1;
pprin2 c;
c := readch();
while c neq '!) and c neq '!; do
<<
    while c neq '!; and (seprp c or c eq '!,) do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>;
    if c neq '!; then
    <<
        name := list c;
        pprin2 c;
        while not (seprp (c := readch())
              or c memq list('!,,'!;, '!))) do
        <<  name := aconc(name, c);  pprin2 c  >>;
        put(intern compress append(explode2 '!$, explode2 i),
            propname,
            intern compress name);
        i := add1 i;
        c:=flushspaces c;
    >>;
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
          propname) do
    remprop(name, propname);
return c
end$

endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.bib0000644000175000017500000000577711526203062024276 0ustar  giovannigiovanni@BOOK{FORTRAN,
  KEY = "American National Standards Institute",
  TITLE = "American National Standard Programming Language {FORTRAN}",
  PUBLISHER = "American National Standards Institute",
  SERIES = "{ANS X3.9}",
  ADDRESS = "New York",
  YEAR = 1978}

@INPROCEEDINGS{Gates:84,
  AUTHOR = "Barbara L. Gates and Paul S. Wang",
  TITLE = "A {LISP}-Based {RATFOR} Code Generator",
  BOOKTITLE = "Proceedings of the 1984 {MACSYMA} User's Conference",
  ADDRESS = "Schenectady, New York", MONTH = "July", YEAR = 1984}

@INPROCEEDINGS{Gates:85,
 AUTHOR = "Barbara L. Gates and J. A. van Hulzen",
 TITLE = "Automatic Generation of Optimized Programs",
 BOOKTITLE = "Proc. {EUROCAL} '85", YEAR = 1985,
 MONTH = "April"}

@ARTICLE{Gates:85a,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran:  An Automatic Code Generation Facility
for {REDUCE}",
 JOURNAL = "{SIGSAM} Bulletin",
 YEAR = 1985, VOLUME = 19, NUMBER = 3, PAGES = "24-42", MONTH = "August"}

@TECHREPORT{Gates:85b,
 AUTHOR = "Barbara L. Gates",
 TITLE = "Gentran User's Manual - {REDUCE} Version",
 INSTITUTION = "Twente University of Technology, Department of
Computer Science, The Netherlands", TYPE = "Memorandum",
 YEAR = 1985, NUMBER = "INF-85-11", MONTH = "June"}

@INPROCEEDINGS{Gates:86,
 AUTHOR = "Barbara L. Gates",
 TITLE = "A Numerical Code Generation Facility for {REDUCE}",
 BOOKTITLE = "Proc. {SYMSAC} '86",
 YEAR = 1986, PAGES = "94-99", MONTH = "July"}

@MANUAL{Kernighan:79,
  AUTHOR = "B. W. Kernighan",
  TITLE = "{RATFOR} -- A Preprocessor for a Rational Fortran",
  SERIES = "{UNIX} Programmer's Manual",
  VOLUME = "2B", EDITION = "Seventh",
  PUBLISHER = "Bell Telephone Laboratories, Inc.",
  ADDRESS = "Murray Hill, New Jersey",
  YEAR = 1979}

@BOOK{Kernighan:78,
  AUTHOR = "B. W. Kernighan and Dennis M. Ritchie",
  TITLE = "The {C} Programming Language",
  PUBLISHER = "Prentice-Hall",
  ADDRESS = "Englewood Cliffs, New Jersey",
  YEAR = 1978}

@ARTICLE{Wang:86,
  AUTHOR = "Payl S. Wang",
  TITLE = "{FINGER}:  A Symbolic System for Automatic Generation of
Numerical Programs in Finite Element Analysis",
  JOURNAL = "Journal of Symbolic Computation",
  VOLUME = 2, YEAR = 1986}

@MASTERSTHESIS{vandenHeuvel:86ms,
  AUTHOR = "Pim van den Heuvel",
  TITLE = "Aspects of Program Generation Related to Automatic
Differentiation",
  SCHOOL = "Twente University of Technology",
  ADDRESS = "Department of Computer Science, Enschede, The Netherlands",
  MONTH = "December", YEAR = 1986}

@INPROCEEDINGS{vanHulzen:89,
 AUTHOR = "J. A. van Hulzen and B. J. A. Hulshof and B. L. Gates and
M. C. Van Heerwaarden",
 TITLE = "A Code Optimization Package for {REDUCE}",
 BOOKTITLE = "Proc. of {ISSAC} '89", PUBLISHER = "{ACM} Press, New York",
 YEAR = 1989, PAGES = "163-170",
 COMMENT = {Lecture Notes.}}

@INPROCEEDINGS{Wang:84,
  AUTHOR = "Paul S. Wang and T. Y. P. Chang and J. A. van Hulzen",
  TITLE = "Code Generation and Optimization for Finite Element Analysis",
  BOOKTITLE = "{EUROSAM} '84 Conference Proceedings",
  PUBLISHER = "Springer-Verlag", SERIES = "{LNCS} Series", YEAR = 1984}

mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.rlg0000644000175000017500000000703611527635055024330 0ustar  giovannigiovanniFri Feb 18 21:27:51 2011 run on win32
MATRIX M(3,3)$


M(1,1) := 18*COS(Q3)*COS(Q2)*M30*P**2 - 9*SIN(Q3)**2*P**2*M30
	  - SIN(Q3)**2*J30Y + SIN(Q3)**2*J30Z + P**2*M10
	  + 18*P**2*M30 + J10Y + J30Y;


                                  2          2               2
m(1,1) := 18*cos(q2)*cos(q3)*m30*p  - sin(q3) *j30y + sin(q3) *j30z

                      2      2                      2           2
           - 9*sin(q3) *m30*p  + j10y + j30y + m10*p  + 18*m30*p

M(2,1) :=
M(1,2) := 9*COS(Q3)*COS(Q2)*M30*P**2 - SIN(Q3)**2*J30Y +
	  SIN(Q3)**2*J30Z - 9*SIN(Q3)**2*M30*P**2 + J30Y +
	  9*M30*P**2;


                                           2          2               2
m(2,1) := m(1,2) := 9*cos(q2)*cos(q3)*m30*p  - sin(q3) *j30y + sin(q3) *j30z

            2      2                 2
 - 9*sin(q3) *m30*p  + j30y + 9*m30*p

M(3,1) :=
M(1,3) := -9*SIN(Q3)*SIN(Q2)*M30*P**2;


                                              2
m(3,1) := m(1,3) :=  - 9*sin(q2)*sin(q3)*m30*p

M(2,2) := -SIN(Q3)**2*J30Y + SIN(Q3)**2*J30Z - 9*SIN(Q3)**2
	   *M30*P**2 + J30Y + 9*M30*P**2;


                    2               2                 2      2                 2
m(2,2) :=  - sin(q3) *j30y + sin(q3) *j30z - 9*sin(q3) *m30*p  + j30y + 9*m30*p

M(3,2) :=
M(2,3) := 0;


m(3,2) := m(2,3) := 0

M(3,3) := 9*M30*P**2 + J30X;


                        2
m(3,3) := j30x + 9*m30*p


GENTRANLANG!* := 'FORTRAN$


FORTLINELEN!* := 72$



GENTRAN LITERAL "C", CR!*,
		"C", TAB!*, "*** COMPUTE VALUES FOR MATRIX M ***", CR!*,
		"C", CR!*$

c
c     *** compute values for matrix m ***
c


FOR j:=1:3 DO
    FOR k:=j:3 DO
	 GENTRAN M(j,k) ::=: M(j,k)$

      m(1,1)=18.0*cos(real(q2))*cos(real(q3))*m30*p**2-(sin(real(q3))**2
     . *j30y)+sin(real(q3))**2*j30z-(9.0*sin(real(q3))**2*m30*p**2)+j10y
     . +j30y+m10*p**2+18.0*m30*p**2
      m(1,2)=9.0*cos(real(q2))*cos(real(q3))*m30*p**2-(sin(real(q3))**2*
     . j30y)+sin(real(q3))**2*j30z-(9.0*sin(real(q3))**2*m30*p**2)+j30y+
     . 9.0*m30*p**2
      m(1,3)=-(9.0*sin(real(q2))*sin(real(q3))*m30*p**2)
      m(2,2)=-(sin(real(q3))**2*j30y)+sin(real(q3))**2*j30z-(9.0*sin(
     . real(q3))**2*m30*p**2)+j30y+9.0*m30*p**2
      m(2,3)=0.0
      m(3,3)=j30x+9.0*m30*p**2


GENTRAN LITERAL "C", CR!*,
		"C", TAB!*, "*** COMPUTE VALUES FOR INVERSE MATRIX ***",
		     CR!*,
		"C", CR!*$

c
c     *** compute values for inverse matrix ***
c


SHARE var$


FOR j:=1:3 DO
    FOR k:=j:3 DO
	IF M(j,k) NEQ 0 THEN
	<<
	    var := TEMPVAR NIL;
	    MARKVAR var;
	    M(j,k) := var;
	    M(k,j) := var;
	    GENTRAN
		EVAL(var) := M(EVAL(j),EVAL(k))
        >>$

      t0=m(1,1)
      t1=m(1,2)
      t2=m(1,3)
      t3=m(2,2)
      t4=m(3,3)


COMMENT -- Contents of Matrix M: --$

M := M;


     [t0  t1  t2]
     [          ]
m := [t1  t3  0 ]
     [          ]
     [t2  0   t4]



MATRIX MXINV(3,3)$


MXINV := M**(-1)$



FOR j:=1:3 DO
    FOR k:=j:3 DO
	GENTRAN MXINV(j,k) ::=: MXINV(j,k)$

      mxinv(1,1)=(t3*t4)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))
      mxinv(1,2)=-(t1*t4)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))
      mxinv(1,3)=-(t2*t3)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))
      mxinv(2,2)=(t0*t4-t2**2)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))
      mxinv(2,3)=(t1*t2)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))
      mxinv(3,3)=(t0*t3-t1**2)/(t0*t3*t4-(t1**2*t4)-(t2**2*t3))


GENTRAN
   for j:=1:3 do
       for k:=j+1:3 do
       <<
	   m(k,j) := m(j,k);
	   mxinv(k,j) := mxinv(j,k)
        >>$

      do 25001 j=1,3
          do 25002 k=j+1,3
              m(k,j)=m(j,k)
              mxinv(k,j)=mxinv(j,k)
25002     continue
25001 continue


END$


Time for test: 16 ms
@@@@@ Resources used: (0 0 6 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/templt.red0000644000175000017500000000703611526203062024151 0ustar  giovannigiovanni

module templt;    %%  GENTRAN Template Processing Routines  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  ProcCTem, ProcFortTem, ProcRatTem
% Moved to separate language modules - JHD December 1987

symbolic$

% User-Accessible Global Variables %
global '(gentranlang!* !$!#)$
fluid '(!*gendecs)$
share gentranlang!*, !$!#$
gentranlang!* := 'fortran$
!$!# := 0$
switch gendecs$

global '(!*space!* !*stdout!* !$eof!$ !$eol!$)$
        % GENTRAN Global Variables      %

!*space!* := '! $

fluid '(!*mode)$


%%                          %%
%% Text Processing Routines %%
%%                          %%

%%                                   %%
%% Template File Active Part Handler %%
%%                                   %%

symbolic procedure procactive;
% active parts:  ;BEGIN; ... ;END; %
% eof markers:   ;END;             %
begin scalar c, buf, mode, och, !*int,!*errcont;
% By turning INT off we avoid some excess blank lines, and avoid trouble
% with END being caught by BEGIN1.  We use !*errcont to recover
% gracefully when an error is caught in the template.
!*errcont := 't;
c := readch();
if c eq 'e then
    if (c := readch()) eq 'n then
        if (c := readch()) eq 'd then
            if (c := readch()) eq '!; then
                return !$eof!$
            else buf := '!;end
        else buf := '!;en
    else buf := '!;e
else if c eq 'b then
    if (c := readch()) eq 'e then
        if (c := readch()) eq 'g then
            if (c := readch()) eq 'i then
                if (c := readch()) eq 'n then
                    if (c := readch()) eq '!; then
                    <<
                        mode := !*mode;
                        !*mode := 'algebraic;
                        och := wrs cdr !*stdout!*;
                        begin1();
                        wrs och;
                        !*mode := mode;
                        linelength 150;
                        return if (c := readch()) eq !$eol!$
                                  then readch()
                                  else c
                    >>
                    else buf := '!;begin
                else buf := '!;begi
            else buf := '!;beg
        else buf := '!;be
    else buf := '!;b
else buf := '!;;
pprin2 buf;
return c
end$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/intrfc.red0000644000175000017500000005632711526203062024140 0ustar  giovannigiovannimodule intrfc;    %%  GENTRAN Parsing Routines & Control Functions  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:
% DeclareStat, GENDECS, GenInStat (GentranIn), GenOutStat
% (GentranOutPush), GenPopStat (GentranPop), GenPushStat, GenShutStat
% (GentranShut), GenStat (Gentran), (GENTRANPAIRS),
% LiteralStat, SYM!-GENTRAN, SYM!-GENTRANIN, SYM!-GENTRANOUT,
% SYM!-GENTRANSHUT,
% SYM!-GENTRANPUSH, SYM!-GENTRANPOP

fluid '(!*getdecs);

% GENTRAN Commands %
put('gentran,     'stat, 'genstat    )$
put('gentranin,   'stat, 'geninstat  )$
put('gentranout,  'stat, 'genoutstat )$
put('gentranshut, 'stat, 'genshutstat)$
put('gentranpush, 'stat, 'genpushstat)$
put('gentranpop,  'stat, 'genpopstat )$

% Form Analysis Function %
put('gentran,        'formfn, 'formgentran)$
put('gentranin,      'formfn, 'formgentran)$
put('gentranoutpush, 'formfn, 'formgentran)$
put('gentranshut,    'formfn, 'formgentran)$
put('gentranpop,     'formfn, 'formgentran)$

% GENTRAN Functions %
put('declare, 'stat, 'declarestat)$
put('literal, 'stat, 'literalstat)$

% GENTRAN Operators %
newtok '((!: !: !=)    lsetq )$  infix ::= $
newtok '((!: != !:)    rsetq )$  infix :=: $
newtok '((!: !: != !:) lrsetq)$  infix ::=:$

% User-Accessible Primitive Function %
operator gendecs$

% GENTRAN Mode Switches %
fluid '(!*gendecs)$
!*gendecs := t$
put('gendecs, 'simpfg, '((nil) (t (gendecs nil))))$
switch gendecs$

%See procedure gendecs:
fluid '(!*keepdecs)$
!*keepdecs := nil$
switch keepdecs$

% GENTRAN Flags %

fluid '(!*gentranopt !*gentranseg !*period);

!*gentranseg := t$

switch gentranseg$

% User-Accessible Global Variable %
global '(gentranlang!*)$
share gentranlang!*$
gentranlang!* := 'fortran$

% GENTRAN Global Variable %
global '(!*term!* !*stdin!* !*stdout!* !*instk!* !*currin!* !*outstk!*
         !*currout!* !*outchanl!*)$
!*term!*     := (t . nil)$             %terminal filepair
!*stdin!*    := !*term!*$              %standard input filepair
!*stdout!*   := !*term!*$              %standard output filepair
!*instk!*    := list !*stdin!*$        %template file stack
!*currin!*   := car !*instk!*$         %current input filepair
!*outstk!*   := list !*stdout!*$       %output file stack
!*currout!*  := car !*outstk!*$        %current output filepair
!*outchanl!* := list cdr !*currout!*$  %current output channel list

global '(!*do!* !*for!*)$
off quotenewnam$
!*do!* := 'do$
!*for!* := 'for$
on quotenewnam$

global '(!*lispstmtops!*);

!*lispstmtops!* := !*for!* . !*lispstmtops!*; % added by R. Liska to
                                              % handle long FOR loops.

% REDUCE Variables %
global '(cursym!* !*vars!*)$
fluid '(!*mode)$


%%                    %%
%%  PARSING ROUTINES  %%
%%                    %%


%%  GENTRAN Command Parsers  %%


procedure genstat;
%                     %
% GENTRAN             %
%     stmt            %
% [OUT f1,f2,...,fn]; %
%                     %
begin
scalar stmt;
flag('(out), 'delim);
stmt := xread t;
remflag('(out), 'delim);
if cursym!* eq 'out then
    return list('gentran, stmt, readfargs())
else if endofstmtp() then
    return list('gentran, stmt, nil)
else
    gentranerr('e, nil, "INVALID SYNTAX", nil)
end$


procedure geninstat;
%                     %
% GENTRANIN           %
%     f1,f2,...,fm    %
% [OUT f1,f2,...,fn]; %
%                     %
begin
scalar f1, f2;
flag('(out), 'delim);
f1 := xread nil;
if atom f1 then f1 := list f1 else f1 := cdr f1;
remflag('(out), 'delim);
if cursym!* eq 'out then
    f2 := readfargs();
return list('gentranin, f1, f2)
end$


procedure genoutstat;
%                          %
% GENTRANOUT f1,f2,...,fn; %
%                          %
list('gentranoutpush, readfargs())$


procedure genshutstat;
%                           %
% GENTRANSHUT f1,f2,...,fn; %
%                           %
list('gentranshut, readfargs())$


procedure genpushstat;
%                           %
% GENTRANPUSH f1,f2,...,fn; %
%                           %
list('gentranoutpush, readfargs())$


procedure genpopstat;
%                          %
% GENTRANPOP f1,f2,...,fn; %
%                          %
list('gentranpop, readfargs())$


%%  GENTRAN Function Parsers  %%

newtok '((!: !:) range);
    % Used for declarations with lower and upper bounds;

procedure declarestat;
%                              %
% DECLARE v1,v2,...,vn : type; %
%                              %
% DECLARE                      %
% <<                           %
%     v1,v2,...,vn1 : type1;   %
%     v1,v2,...,vn2 : type2;   %
%     .                        %
%     .                        %
%     v1,v2,...,vnn : typen    %
% >>;                          %
%                              %
begin
scalar res, varlst, type;
scan();
put('range,'infix,4);
put('range,'op,'((4 4)));
if cursym!* eq '!*lsqbkt!* then
<<
    scan();
    while cursym!* neq '!*rsqbkt!* do
    <<
        varlst := list xread1 'for;
        while cursym!* neq '!*colon!* do
            varlst := append(varlst, list xread 'for);
        type := declarestat1();
        res := append(res, list(type . varlst));
        if cursym!* eq '!*semicol!* then scan()
    >>;
    scan()
>>
else
<<
    varlst := list xread1 'for;
    while cursym!* neq '!*colon!* do
        varlst := append(varlst, list xread 'for);
    type := declarestat1();
    res := list (type . varlst);
>>;
if not endofstmtp() then
    gentranerr('e, nil, "INVALID SYNTAX", nil);
remprop('range,'infix);
remprop('range,'op);
return ('declare . res)
end$

procedure declarestat1;
begin
scalar res;
scan();
if endofstmtp() then
    return nil;
if cursym!* eq 'implicit then
<<
    scan();
    res := intern compress append(explode 'implicit! , explode cursym!*)
>>
else
    res := cursym!*;
scan();
if cursym!* eq 'times then
<<
    scan();
    if numberp cursym!* then
    <<
        res := intern compress append(append(explode res, explode '!*),
                                      explode cursym!*);
        scan()
    >>
    else
        gentranerr('e, nil, "INVALID SYNTAX", nil)
>>;
return res
end$


procedure literalstat;
%                             %
% LITERAL arg1,arg2,...,argn; %
%                             %
begin
scalar res;
repeat
    res := append(res, list xread t)
until endofstmtp();
if atom res then
    return list('literal, res)
else if car res eq '!*comma!* then
    return rplaca(res, 'literal)
else
    return('literal . res)
end$


%%                           %%
%%  Symbolic Mode Functions  %%
%%                           %%


procedure sym!-gentran form;
lispeval formgentran(list('gentran, form, nil), !*vars!*, !*mode)$

procedure sym!-gentranin flist;
if flist then
  lispeval formgentran(list('gentranin,
                        (if atom flist then list flist else flist),
                        nil),
                   !*vars!*, !*mode)$

procedure sym!-gentranout flist;
lispeval formgentran(list('gentranoutpush,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranshut flist;
lispeval formgentran(list('gentranshut,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranpush flist;
lispeval formgentran(list('gentranoutpush,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$

procedure sym!-gentranpop flist;
lispeval formgentran(list('gentranpop,
                      if atom flist then list flist else flist),
                 !*vars!*, !*mode)$


%%                           %%
%%  Form Analysis Functions  %%
%%                           %%


procedure formgentran(u, vars, mode);
(car u) . foreach arg in cdr u collect formgentran1(arg, vars, mode)$

symbolic procedure formgentran1(u, vars, mode);
if pairp u and car u eq '!:dn!: then
    mkquote <>
else if pairp u and car u eq '!:rd!: then mkquote u
else if pairp u and not listp u then
  if !*getdecs
     then formgentran1(list ('declare,list(cdr u,car u)),vars,mode)
          % Amended mcd 13/11/87 to allow local definitions.
     else gentranerr('e,u,
                     "Scalar definitions cannot be translated",nil)
else if atom u then
    mkquote u
else if car u eq 'eval then
    if mode eq 'algebraic then
        list('aeval, form1(cadr u, vars, mode))
    else
        form1(cadr u, vars, mode)
else if car u memq '(lsetq rsetq lrsetq) then
    % (LSETQ (var s1 s2 ... sn) exp)                                 %
    %   -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) exp)        %
    % (RSETQ var exp)                                                %
    %   -> (SETQ var (EVAL exp))                                     %
    % (LRSETQ (var s1 s2 ... sn) exp)                                %
    %   -> (SETQ (var (EVAL s1) (EVAL s2) ... (EVAL sn)) (EVAL exp)) %
    begin
    scalar op, lhs, rhs;
    op := car u;
    lhs := cadr u;
    rhs := caddr u;
    if op memq '(lsetq lrsetq) and listp lhs then
        lhs := car lhs . foreach s in cdr lhs collect list('eval, s);
    if op memq '(rsetq lrsetq) then
        rhs := list('eval, rhs);
    return formgentran1(list('setq, lhs, rhs), vars, mode)
    end
else
    'list . foreach elt in u
                collect formgentran1(elt, vars, mode)$


%%                     %%
%%  Control Functions  %%
%%                     %%


%%  Command Control Functions  %%


symbolic procedure gentran(forms, flist);
begin scalar !:print!-prec!: ; % Gentran ignores print_precision
if flist then
    lispeval list('gentranoutpush, list('quote, flist));
forms := preproc list forms;
if gentranparse(forms) then
<<
  forms := lispcode forms;
  if smemq('differentiate,forms) then
    <>;
  if !*gentranopt then forms := opt forms;
  if !*gentranseg then forms := seg forms;
  apply1(get(gentranlang!*,'formatter) or get('fortran,'formatter),
         apply1(get(gentranlang!*,'codegen) or get('fortran,'codegen),
                forms))
>>;
if flist then
<<
    flist := car !*currout!* or ('list . cdr !*currout!*);
    lispeval '(gentranpop '(nil));
    return flist
>>
else
    return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranin(inlist, outlist);
begin
scalar ich;
foreach f in inlist do
    if pairp f then
        gentranerr('e, f, "Wrong Type of Arg", nil)
    else if not !*filep!* f and f neq car !*stdin!* then
        gentranerr('e, f, "Nonexistent Input File", nil);
if outlist then
    lispeval list('gentranoutpush, mkquote outlist);
ich := rds nil;
foreach f in inlist do
<<
    if f = car !*stdin!* then
        pushinputstack !*stdin!*
    else if retrieveinputfilepair f then
        gentranerr('e, f, "Template File Already Open for Input", nil)
    else
        pushinputstack makeinputfilepair f;
    rds cdr !*currin!*;
    lispapply(get(gentranlang!*,'proctem) or get('fortran,'proctem),
              nil);
%    if gentranlang!* eq 'ratfor then
%        procrattem()
%    else if gentranlang!* eq 'c then
%        procctem()
%    else
%        procforttem();
    rds ich;
    popinputstack()
>>;
if outlist then
<<
    outlist := car !*currout!* or ('list . cdr !*currout!*);
    lispeval '(gentranpop '(nil));
    return outlist
>>
else
    return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranoutpush flist;
<<
    if onep length (flist := fargstonames(flist, t)) then
        flist := car flist;
    pushoutputstack (retrieveoutputfilepair flist
                        or makeoutputfilepair flist);
    car !*currout!* or ('list . cdr !*currout!*)
>>$


procedure gentranshut flist;
%  close, delete, [output to T]  %
begin
scalar trm;
flist := fargstonames(flist, nil);
trm := if onep length flist then (car flist = car !*currout!*)
       else if car !*currout!*
        then (if car !*currout!* member flist then t)
       else lispeval('and . foreach f in cdr !*currout!*
                                collect (if f member flist then t));
deletefromoutputstack flist;
if trm and !*currout!* neq !*stdout!* then
    pushoutputstack !*stdout!*;
return car !*currout!* or ('list . cdr !*currout!*)
end$


procedure gentranpop flist;
<<
    if 'all!* member flist then
        while !*outstk!* neq list !*stdout!* do
            lispeval '(gentranpop '(nil))
    else
    <<
        flist := fargstonames(flist,nil);
        if onep length flist then
            flist := car flist;
        popoutputstack flist
    >>;
    car !*currout!* or ('list . cdr !*currout!*)
>>$


%%  Mode Switch Control Function  %%


procedure gendecs name;
% Hacked 15/11/88 to make it actually tidy up symbol table properly.
% KEEPDECS also added.  mcd.
%%%%%%%%%%%%%%%%%%%%%%%%
%                      %
% ON/OFF GENDECS;      %
%                      %
% GENDECS subprogname; %
%                      %
%%%%%%%%%%%%%%%%%%%%%%%%
<<
    if name equal 0 then name := nil;
    apply1(get(gentranlang!*,'formatter) or get('fortran,'formatter),
       apply1(get(gentranlang!*,'gendecs) or get('fortran,'gendecs),
              symtabget(name, '!*decs!*)));
%    if gentranlang!* eq 'ratfor then
%        formatrat ratdecs symtabget(name, '!*decs!*)
%    else if gentranlang!* eq 'c then
%        formatc cdecs symtabget(name, '!*decs!*)
%    else
%        formatfort fortdecs symtabget(name, '!*decs!*);
    % Sometimes it would be handy to know just what we've generated.
    % If the switch KEEPDECS is on (usually off) this is done.
    if null !*keepdecs then
    <<
        symtabrem(name, '!*decs!*);
        symtabrem(name, '!*type!*);
    >>;
    symtabrem(name, nil);
>>$


%%  Misc. Control Functions  %%


procedure gentranpairs prs;
%                              %
% GENTRANPAIRS dottedpairlist; %
%                              %
begin
  scalar formatfn,assignfn;
  formatfn:=get(gentranlang!*,'formatter) or get('fortran,'formatter);
  assignfn:=get(gentranlang!*,'assigner) or get('fortran,'assigner);
  return
    for each pr in prs do
        apply1(formatfn,apply2(assignfn,lispcodeexp(car pr, !*period),
                                        lispcodeexp(cdr pr, !*period)))
  end;

%procedure gentranpairs prs;
%%                              %
%% GENTRANPAIRS dottedpairlist; %
%%                              %
%if gentranlang!* eq 'ratfor then
%    for each pr in prs do
%        formatrat mkfratassign(lispcodeexp(car pr, !*period),
%                               lispcodeexp(cdr pr, !*period))
%else if gentranlang!* eq 'c then
%    for each pr in prs do
%        formatc mkfcassign(lispcodeexp(car pr, !*period),
%                           lispcodeexp(cdr pr, !*period))
%else
%    for each pr in prs do
%        formatfort mkffortassign(lispcodeexp(car pr, !*period),
%                                 lispcodeexp(cdr pr, !*period))$


%%                                                  %%
%% Input & Output File Stack Manipulation Functions %%
%%                                                  %%


%%  Input Stack Manipulation Functions  %%


procedure makeinputfilepair fname;
(fname . open(mkfil fname, 'input))$

procedure retrieveinputfilepair fname;
retrievefilepair(fname, !*instk!*)$

procedure pushinputstack pr;
<<
    !*instk!* := pr . !*instk!*;
    !*currin!* := car !*instk!*;
    !*instk!*
>>$

procedure popinputstack;
begin scalar x;
        x := !*currin!*;
        if cdr !*currin!* then close cdr !*currin!*;
        !*instk!* := cdr !*instk!* or list !*stdin!*;
        !*currin!* := car !*instk!*;
        return x
end$

%%  Output File Stack Manipulation Functions  %%


procedure makeoutputfilepair f;
if atom f then
    (f . open(mkfil f, 'output))
else
    aconc((nil . f) .
          foreach fn in f
                  conc if not retrieveoutputfilepair fn
                          then list makeoutputfilepair fn,
          (nil . nil))$

procedure retrieveoutputfilepair f;
if atom f
   then retrievefilepair(f, !*outstk!*)
   else retrievepfilepair(f, !*outstk!*)$

procedure pushoutputstack pr;
<<
    !*outstk!* := if atom cdr pr
                     then (pr . !*outstk!*)
                     else append(pr, !*outstk!*);
    !*currout!* := car !*outstk!*;
    !*outchanl!* := if car !*currout!*
                       then list cdr !*currout!*
                       else foreach f in cdr !*currout!*
                                   collect cdr retrieveoutputfilepair f;
    !*outstk!*
>>$

procedure popoutputstack f;
%  [close], remove top-most exact occurrence, reset vars  %
begin
scalar pr, s;
if atom f then
<<
    pr := retrieveoutputfilepair f;
    while !*outstk!* and car !*outstk!* neq pr do
        if caar !*outstk!* then
        <>
        else
        <<
            while car !*outstk!* neq (nil . nil) do
            <<  s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!* >>;
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
        >>;
    if !*outstk!* then s := append(s, cdr !*outstk!*);
    !*outstk!* := s;
    if not retrieveoutputfilepair f then close cdr pr
>>
else
<<
    pr := foreach fn in f collect retrieveoutputfilepair fn;
    while !*outstk!* and not filelistequivp(cdar !*outstk!*, f) do
        if caar !*outstk!* then
        <<  s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*  >>
        else
        <<
            while car !*outstk!* neq (nil . nil) do
            <<  s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!* >>;
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
        >>;
    if !*outstk!* then
    <<
        while car !*outstk!* neq (nil . nil) do
           !*outstk!* := cdr !*outstk!*;
        s := append(s, cdr !*outstk!*)
    >>;
    !*outstk!* := s;
    foreach fn in f do pr := delete(retrieveoutputfilepair fn, pr);
    foreach p in pr do close cdr p
>>;
!*outstk!* := !*outstk!* or list !*stdout!*;
!*currout!* := car !*outstk!*;
!*outchanl!* := if car !*currout!*
                   then list cdr !*currout!*
                   else foreach fn in cdr !*currout!*
                                collect cdr retrieveoutputfilepair fn;
return f
end$

procedure deletefromoutputstack f;
begin
scalar s, pr;
    if atom f then
    <<
        pr := retrieveoutputfilepair f;
        while retrieveoutputfilepair f do
            !*outstk!* := delete(pr, !*outstk!*);
        close cdr pr;
        foreach pr in !*outstk!* do
            if listp cdr pr and pairp cdr pr and f member cdr pr then
                rplacd(pr, delete(f, cdr pr)) % Fixed 26-2-88 mcd
    >>
    else
    <<
        foreach fn in f do
            deletefromoutputstack fn;
        foreach fn in f do
            foreach pr in !*outstk!* do
                if pairp cdr pr and fn member cdr pr then
                    rplacd(pr, delete(fn, cdr pr))
    >>;
    while !*outstk!* do
        if caar !*outstk!* and caar !*outstk!* neq 't then
        <<
            s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*
        >>
        else if cdar !*outstk!* and cdar !*outstk!* neq '(t) then
        <<
            while car !*outstk!* neq (nil . nil) do
            <<
                s := aconc(s, car !*outstk!*);
                !*outstk!* := cdr !*outstk!*
            >>;
            s := aconc(s, car !*outstk!*);
            !*outstk!* := cdr !*outstk!*
        >>
        else
            if cdr !*outstk!* then !*outstk!* := cddr !*outstk!*
               else !*outstk!*:=nil;
    !*outstk!* := s or list !*stdout!*;
    !*currout!* := car !*outstk!*;
    !*outchanl!* := if car !*currout!*
                       then list cdr !*currout!*
                       else foreach fn in cdr !*currout!*
                                 collect cdr retrieveoutputfilepair fn;
return f
end$


procedure retrievefilepair(fname, stk);
if null stk then
    nil
else if caar stk and mkfil fname = mkfil caar stk then
    car stk
else
    retrievefilepair(fname, cdr stk)$

procedure retrievepfilepair(f, stk);
if null stk then
    nil
else if null caar stk and filelistequivp(f, cdar stk) then
    list(car stk, (nil . nil))
else
    retrievepfilepair(f, cdr stk)$

procedure filelistequivp(f1, f2);
if pairp f1 and pairp f2 then
<<
    f1 := foreach f in f1 collect mkfil f;
    f2 := foreach f in f2 collect mkfil f;
    while (car f1 member f2) do
    <<
        f2 := delete(car f1, f2);
        f1 := cdr f1
    >>;
    null f1 and null f2
>>$


%%

procedure !*filep!* f;
   not errorp errorset(list('close,
                            list('open,list('mkfil,mkquote f),''input)),
                       nil,nil)$

%%                                     %%
%% Scanning & Arg-Conversion Functions %%
%%                                     %%


procedure endofstmtp;
if cursym!* member '(!*semicol!* !*rsqbkt!* end) then t$

procedure fargstonames(fargs, openp);
begin
scalar names;
fargs :=
    for each a in fargs conc
        if a memq '(nil 0) then
            if car !*currout!* then
                list car !*currout!*
            else
                cdr !*currout!*
        else if a eq 't then
            list car !*stdout!*
        else if a eq 'all!* then
            for each fp in !*outstk!* conc
               (if car fp and not(fp equal !*stdout!*) then list car fp)
        else if atom a then
            if openp then
            <<
                if null getd 'bpsmove and
                   % That essentially disables the test on IBM SLISP
                   % where it causes chaos with the PDS management.
                   !*filep!* a and null assoc(a, !*outstk!*) then
                    gentranerr('w, a, "OUTPUT FILE ALREADY EXISTS",
                               "CONTINUE?");
                list a
            >>
            else
                if retrieveoutputfilepair a then
                    list a
                else
                    gentranerr('w, a, "File not Open for Output", nil)
        else
            gentranerr('e, a, "WRONG TYPE OF ARG", nil);
repeat
    if not (car fargs member names) then
        names := append(names, list car fargs)
until null (fargs := cdr fargs);
return names
end$

procedure readfargs;
begin
scalar f;
while not endofstmtp() do
    f := append(f, list xread t);
return f or list nil
end$


endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/lsppasc.red0000644000175000017500000006567411526203062024325 0ustar  giovannigiovannimodule lsppasc;    %%  GENTRAN LISP-to-PASCAL Translation Module  %%

%%  Author:  John Fitch and James Davenport after Barbara L. Gates  %%
%%  November 1987                               %%

% Entry Point:  PASCCode

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%




symbolic$


fluid '(!*gendecs)$
switch gendecs$

% User-Accessible Global Variables %
global '(pasclinelen!* minpasclinelen!* !*pasccurrind!* pasccurrind!*
         tablen!* pascfuncname!*)$
share pasclinelen!*, minpasclinelen!*,
      pasccurrind!*, tablen!*, pascfuncname!*$
pasccurrind!* := 0$
minpasclinelen!* := 40$
pasclinelen!*    := 70$
!*pasccurrind!* := 0$     %current level of indentation for PASCAL code

global '(!*do!* !*for!*)$
global '(!*posn!* !$!#)$

%%                                      %%
%% LISP-to-PASCAL Translation Functions %%
%%                                      %%

put('pascal,'formatter,'formatpasc);
put('pascal,'codegen,'pasccode);
put('pascal,'proctem,'procpasctem);
put('pascal,'gendecs,'pascdecs);
put('pascal,'assigner,'mkfpascassign);
put('pascal,'boolean!-type,'boolean);

symbolic procedure pasc!-symtabput(name,type,value);
% Like symtabput, but indirects through TYPE declarations.
% has to be recursive
begin
  scalar basetype, origtype, wastypedecl;
  basetype:=car value;
  if basetype = 'TYPE then <<
     wastypedecl:=t;
     value:=cdr value;
    basetype:=car value >>;
  origtype:=symtabget(name,basetype) or symtabget('!*main!*,basetype);
  if pairp origtype then origtype:=cdr origtype; % strip off name;
  if pairp origtype and car origtype = 'TYPE
     then value:= (cadr origtype). append(cdr value,cddr origtype);
  if wastypedecl
     then symtabput(name,type,'TYPE . value)
     else symtabput(name,type,value);
  end;

%% Control Function %%


procedure pasccode forms;
for each f in forms conc
    if atom f then
        pascexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
        pascexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(pascdecs symtabget('!*main!*, '!*decs!*),
                        pascstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            pascstmt f
    else if lispdefp f then
        pascproc f
    else
        pascexp f$


%% Procedure Translation %%


procedure pascproc deff;
begin
  scalar type, name, params, paramtypes, vartypes, body, r;
  name := cadr deff;
  if onep length (body := cdddr deff) and lispstmtgpp car body then
     <<  body := cdar body;
         if null car body then body := cdr body  >>;
  if (type := symtabget(name, name)) then
     <<  type := cadr type;  symtabrem(name, name)  >>;
  params := symtabget(name, '!*params!*) or caddr deff;
  symtabrem(name, '!*params!*);
  for each dec in symtabget(name, '!*decs!*) do
    if car dec memq params
       then paramtypes := append(paramtypes, list dec)
       else if cadr dec neq 'TYPE then
            vartypes := append(vartypes, list dec);
  r := mkfpascprocdec(type, name, params, paramtypes);
  if !*gendecs then
     << r:= append(r,list(mkpasctab(),'label,mkpascterpri()));
        indentpasclevel(+1);
        r:= append(r,list(mkpasctab(),'99999, '!;, mkpascterpri()));
        indentpasclevel(-1);
        r := append(r, pascdecs vartypes) >>;
  r:= append(r, mkfpascbegingp() );
  indentpasclevel(+1);
  r := append(r, for each s in body
                   conc pascstmt s);
  indentpasclevel(-1);
  r:=append(r,list(mkpasctab(), 99999, '!:, mkpascterpri()));
  r := append(r, mkfpascendgp());
  if !*gendecs then
     <<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
  return r
  end$


%% Generation of Declarations %%


procedure pascdecs decs;
begin scalar r;
  decs:=for each r in decs conc
    if cadr r eq 'type then nil else list r;
  if decs then <<
    indentpasclevel(+1);
    decs:=for each tl in formtypelists decs
                      conc mkfpascdec(car tl, cdr tl);
    indentpasclevel(-1);
    r:=append(list(mkpasctab(),'var, mkpascterpri()), decs) >>;
  return r
end$


%% Expression Translation %%


procedure pascexp exp;
pascexp1(exp, 0)$

procedure pascexp1(exp, wtin);
if atom exp then
    list pascname exp
else
    if onep length exp then
        pascname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := pascprecedence car exp;
        op := pascop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . pascexp1(car exp, wt)
        else
        <<
            res := pascexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, pascexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  pascexp1(car exp, wt))
        >>;
        if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        pascliteral exp
    else if car exp eq 'range then
        append(pascexp cadr exp, '!.!. . pascexp caddr exp)
    else if car exp eq '!:rd!: then
    begin scalar mt;
        integer dotpos,!:lower!-sci!:,!:upper!-sci!:; % this forces most
                                         % numbers to exponential format
        mt := rd!:explode exp;
        exp := car mt;
        mt  := cadr mt + caddr mt - 1;
        exp := append(list('literal,car exp, '!.),cdr exp);
        if null (mt = 0) then exp := append(exp, list('!e,mt));

        return pascliteral exp;
    end
    else if car exp memq '(!:cr!: !:crn!: !:gi!:) then
        gentranerr('e,exp,"Pascal doesn't support complex data",nil)
    else if arrayeltp exp then
        if cddr exp and ((caddr exp) equal '!.!.) then
           pascname car exp . pascinsertbrackets cdr exp
          else pascname car exp .
               pascinsertbrackets cdr foreach s in cdr exp conc
                                 '!, . pascexp1(s, 0)
    else
        begin
        scalar op, res;
        op := pascname car exp;
        exp := cdr exp;
        res := pascexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,), pascexp1(car exp, 0));
        return op . insertparens res
        end$


procedure pascop op;
get(op, '!*pascop!*) or op$

put('or,       '!*pascop!*, 'or  )$
put('and,      '!*pascop!*, 'and )$
put('not,      '!*pascop!*, 'not )$
put('equal,    '!*pascop!*, '!=  )$
put('neq,      '!*pascop!*, '!)$
put('greaterp, '!*pascop!*, '!>  )$
put('geq,      '!*pascop!*, '!>!=)$
put('lessp,    '!*pascop!*, '!<  )$
put('leq,      '!*pascop!*, '!>;
  return r
  end$

procedure pasclabel label;
mkfpasclabel label$

procedure pascliteral stmt;
mkfpascliteral cdr stmt$

procedure pascrepeat stmt;
begin
  scalar r, stmtlst, logexp;
  stmt := reverse cdr stmt;
  logexp := car stmt;
  stmtlst := reverse cdr stmt;
  r := mkfpascrepeat();
  indentpasclevel(+1);
  r := append(r, foreach st in stmtlst conc pascstmt st);
  r:=removefinalsemicolon(r);    % Remove final semicolon
  indentpasclevel(-1);
  return append(r, mkfpascuntil logexp)
  end$

procedure pascreturn stmt;
if cdr stmt then
begin scalar r;
    r := mkfpascbegingp();
    indentpasclevel(+1);
    r := append(r, mkfpascassign(pascfuncname!*, cadr stmt));
    r := append(r, mkfpascreturn());
    r := removefinalsemicolon(r);    % Remove final semicolon
    indentpasclevel(-1);
    return append(r, mkfpascendgp())
end
else
    mkfpascreturn()$

procedure pascstmtgp stmtgp;
begin
  scalar r;
  if car stmtgp eq 'progn then
      stmtgp := cdr stmtgp
  else
    stmtgp :=cddr stmtgp;
  r := mkfpascbegingp();
  indentpasclevel(+1);
  r := append(r, for each stmt in stmtgp conc pascstmt stmt);
  r:=removefinalsemicolon(r);    % Remove final semicolon
  indentpasclevel(-1);
  return append(r, mkfpascendgp())
  end$

procedure pascwhile stmt;
begin
  scalar r, logexp, stmtlst;
  logexp := cadr stmt;
  stmtlst := cddr stmt;
  r := mkfpascwhile logexp;
  indentpasclevel(+1);
  r := append(r, foreach st in stmtlst conc pascstmt st);
  indentpasclevel(-1);
  return r
  end$

procedure removefinalsemicolon r;
begin scalar rr;
  r:=reversip r;
  if car r eq '!; then return reversip cdr r;
  if not ('!; memq r) then return reversip r;
  rr:=r;
  while not (cadr rr eq '!;) do << rr := cdr rr >>;
  rplacd(rr, cddr rr);
  return reversip r
end$

%%                                  %%
%% Pascal Code Formatting Functions %%
%%                                  %%


%% Statement Formatting %%


% A macro used to prevent things with *pascname*
% properties being evaluated in certain circumstances.  MCD 28.3.94
symbolic smacro procedure pascexp_name(u);
if atom u then
  list(u)
else
  rplaca(pascexp ('dummyArrayToken . cdr u), car u)$

procedure mkfpascassign(lhs, rhs);
begin
scalar st;
    st := append(pascexp_name lhs, '!:!= . pascexp rhs);
    return append(mkpasctab() . st, list('!;, mkpascterpri()))
end$

procedure mkfpascbegingp;
list(mkpasctab(), 'begin, mkpascterpri())$

symbolic procedure mkfpascdec (type, varlist);
 begin scalar simplet, arrayt;
    varlist := for each v in varlist do
       if atom v then simplet := v . simplet
       else
          arrayt :=
           (car v . cdr for each dim in cdr v conc
                     if eqcar(dim,'range)
                        then list ('!, , cadr dim, '!.!., caddr dim )
                        else list ('!, , 0, '!.!., dim ))
            . arrayt;

    return append(if simplet
                    then append(mkpasctab() .
              for each v in insertcommas simplet conc pascexp v,
                           (list('!:!  , type, '!;, mkpascterpri()))),
           for each v in arrayt conc
             append(mkpasctab() . car pascexp car v. '!:!  .
             'array . insertbrackets cdr v,
                  list('! of!  , type, '!;, mkpascterpri())))
end;


procedure mkfpascdo;
list(mkpasctab(), !*do!*, mkpascterpri())$

procedure mkfpascuntil exp;
append(append(list(mkpasctab(), 'until, '! ),
              pascexp exp),
       list('!;, mkpascterpri() ));

procedure mkfpascelse;
list(mkpasctab(), 'else, mkpascterpri())$

procedure mkfpascendgp;
list(mkpasctab(), 'end, '!;, mkpascterpri())$

procedure mkfpascstop;
list(mkpasctab(), 'svr, '!(, '!0, '!), '!;, mkpascterpri())$

procedure mkfpascfor(var1, lo, hi, stepexp);
<<
    stepexp := if stepexp = 1 then list('! , 'to, '! )  else
           if (stepexp = -1) or (stepexp = '(minus 1)) then
           list('! , 'downto, '! )  else list('error);
    hi:=append(pascexp hi,list('! , !*do!*, mkpascterpri()));
    hi:=append(pascexp lo, nconc(stepexp, hi));
    append(list(mkpasctab(), !*for!*, '! , var1, '!:!=), hi)
>>$

procedure mkfpascgo label;
list(mkpasctab(), 'goto, '! , label, '!;, mkpascterpri())$

procedure mkfpascif exp;
append(append(list(mkpasctab(), 'if, '! ), pascexp exp),
       list('!  , 'then, mkpascterpri()))$

procedure mkfpasclabel label;
list(label, '!:, mkpascterpri())$

procedure mkfpascliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkpasctab()
    else if a eq 'cr!* then
        list mkpascterpri()
    else if pairp a then
        pascexp a
    else
        list stripquotes a$

procedure mkfpascprocdec(type, name, params, paramtypes);
<<  pascfuncname!* := name;
    params := append('!( . cdr for each p in params
                              conc '!, . pascdum(p, paramtypes),
                     list '!));
    if type then
        append(mkpasctab() . 'function . '!  . pascexp name,
               append(params,list( '!:, type,  '!;, mkpascterpri())))
    else
        append(mkpasctab() . 'procedure . '!  . pascexp name,
               append(params, list('!;, mkpascterpri())))
>>$


symbolic procedure pascdum (p,types);
  begin scalar type;
    type := pascgettype(p,types);
    type := if atom type then list type
             else if null cdr type then type
             else append('array .
                          insertbrackets
                           cdr for each dim in cdr type conc
                               if eqcar(dim,'range)
                                 then list('!,,cadr dim,'!.!.,caddr dim)
                                else list ('!, , 0, '!.!., dim ),
                         list ('! of!  , car type));
    return p . '!: . type
end;


symbolic procedure pascgettype(p,types);
  if null types then 'default
  else if p memq car types then cdr car types
  else pascgettype(p,cdr types);


procedure mkfpascrepeat;
list(mkpasctab(), 'repeat, mkpascterpri())$

procedure mkfpascreturn;
   list(mkpasctab(), 'goto, '! , 99999, '!;,
        '!{return!}, mkpascterpri())$

procedure mkfpascwhile exp;
append(append(list(mkpasctab(), 'while, '! , '!(), pascexp exp),
       list('!), mkpascterpri()))$


%% Indentation Control %%


procedure mkpasctab;
list('pasctab, pasccurrind!*)$


procedure indentpasclevel n;
pasccurrind!* := pasccurrind!* + n * tablen!*$


procedure mkpascterpri;
list 'pascterpri$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure pascinsertbrackets exp;
'![ . append(exp, list '!] )$




%% PASCAL Code Formatting & Printing Functions %%


procedure formatpasc lst;
begin
  scalar linelen;
  linelen := linelength 300;
  !*posn!* := 0;
  for each elt in lst do
      if pairp elt then lispeval elt
      else
      <<
          if !*posn!* + length explode2 elt > pasclinelen!* then
              pasccontline();
          pprin2 elt
      >>;
  linelength linelen
  end$

procedure pasccontline;
<<
    pascterpri();
    pasctab !*pasccurrind!*;
    pprin2 " "
>>$

procedure pascterpri;
pterpri()$

procedure pasctab n;
<<
    !*pasccurrind!* := min0(n, pasclinelen!* - minpasclinelen!*);
    if (n := !*pasccurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$



%% PASCAL     %%
%% John Fitch %%

global '(pascfuncname!*)$
share pascfuncname!*$

symbolic procedure procpasctem;
begin
  scalar c;
  c:=flushspaces readch();
  while not (c eq !$eof!$ or c eq '!.)
    do c:=flushspaces procpasctem1(c);
  end;

symbolic procedure procpasctem1 c;
begin
  scalar l,w, linelen;
  linelen := linelength 150;
  pprin2 c;
  while c neq !$eof!$  and w neq 'END do <<
    if c eq !$eol!$ then
    <<  pterpri(); c := readch()  >>
    else if c eq '!{ then << c := procpasccomm(); w:= nil >>
    else if c eq '!; then
        << c := procactive(); pprin2 c; w:=nil >>;
    if null w then <<
      if liter c then l:= list c;
      c := readch();
      while liter c or digit c or c eq '!_ do
         << pprin2 c; l:=c . l; c := readch() >>;
      w:=intern compress reverse l;
      l:=nil >>;
    if w eq 'VAR then c:=procpascvar c
    else if w eq 'CONST then c:=procpascconst c
    else if w eq 'TYPE then c:=procpasctype c
    else if w memq '(FUNCTION PROCEDURE OPERATOR)
         then c:=procfuncoperheading(w,c)
    else if w eq 'BEGIN then c:= NIL . procpasctem1 c
    else if w neq 'END then <<
       while c neq '!; do <<
         if c eq '!{ then c := procpasccomm()
           else << pprin2 c; c := readch() >> >>;
       pprin2 c;
       c:=nil . readch() >>;
    % recursive, since PASCAL is
    if w eq 'END then <<
       c:=flushspaces c;
       if not ( c memq '(!; !.)) then
          gentranerr('e,nil,"END not followed by ; or .",nil);
       pprin2 c; c:=readch() >>
       else <<
         w:=car c;
         c:=flushspaces cdr c; >>
    >>;
  linelength linelen;
  return c;
  end$

symbolic procedure procpasctype c;
% TYPE ...; ...; ... %
begin
  scalar w,l;
next:
  while not liter c do <<
        if c eq !$eol!$ then pterpri() else pprin2 c;
        c:=readch() >>;
  l:=nil;
  while liter c or digit c or c eq '!_ do
    << pprin2 c; l:=c . l; c := readch() >>;
  w:=intern compress reverse l;
  if w memq '(FUNCTION PROCEDURE OPERATOR CONST VAR)
     then return w . c;
  c:=flushspaces c;
  if c neq '!= then
     gentranerr('e,nil,"Malformed TYPE declaration", nil);
  l:=readpascaltype c;
  c:=car l;
  pasc!-symtabput(pascfuncname!*,w,'TYPE . cdr l);
  goto next;
  end;

symbolic procedure procpascvar c;
% VAR ...; ...; ... %
begin
  scalar name,l,namelist;
next:
  while not liter c do <<
        if c eq !$eol!$ then pterpri() else pprin2 c;
        c:=readch() >>;
  l:=nil;
  while liter c or digit c or c eq '!_ do
    << pprin2 c; l:=c . l; c := readch() >>;
  name:=intern compress reverse l;
  if name memq '(FUNCTION PROCEDURE OPERATOR CONST VAR BEGIN)
     then return name . c;
  c:=flushspaces c;
  namelist:=list name;
  while (c = '!, ) do <<
    pprin2 c;
    c:=flushspaces readch();
    l:=nil;
    while liter c or digit c or c eq '!_ do
      << pprin2 c; l:=c . l; c := readch() >>;
    name:=intern compress reverse l;
    namelist:= name . namelist;
    c:=flushspaces c >>;
  if c neq '!: then gentranerr('e,nil,"Malformed VAR declaration", nil);
  l:=readpascaltype c;
  c:=car l;
  for each name in namelist do
    pasc!-symtabput(pascfuncname!*,name, cdr l);
  goto next;
  end;

symbolic procedure procpasccomm;
% { ... } %
begin
scalar c;
pprin2 '!{;
c := readch();
while c neq '!} do
        <<
            if c eq !$eol!$
                then pterpri()
                else pprin2 c;
            c := readch()
        >>;
pprin2 c;
c := readch();
return c
end$

symbolic procedure procfuncoperheading(keyword,c);
% returns the word after the procedure, and the character delimiting it
begin
  scalar lst, name, i, ty, args, myargs;
  c:=flushspaces c;
  while not(seprp c or c eq '!( or c eq '!: ) do
    <<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
  name := intern compress name;
  put('!$0, '!*pascalname!*, name);
  symtabput(name,'!*type!*,keyword);
  pascfuncname!*:=name;
  c:=flushspaces c;
  if c eq '!( then <<
    i := 1;
    pprin2 c;
    c := readch();
    while c neq '!) do
    <<  c:=flushspacescommas c;
        name := list c;
        pprin2 c;
        while not (seprp (c := readch()) or
                   c memq list('!,, '!), '!:)) do
        <<  name := aconc(name, c);  pprin2 c  >>;
        put(intern compress append(explode2 '!$, explode2 i),
            '!*pascalname!*,
            name:=intern compress name);
        myargs := name . myargs;
        i := add1 i;
    if c eq '!: then <<
                ty:=readpascaltype(c);
                c:=car ty; ty:=cdr ty;
        foreach n in myargs do
             pasc!-symtabput(pascfuncname!*,n,ty);
                args:=append(myargs,args);
                myargs:=nil;
                if (c eq '!;) then << pprin2 c; c:=readch() >>
    >>;
        c:=flushspaces c
    >>;
    !$!# := sub1 i;
    >>
    else !$!# :=0;
  if c neq '!: then
     << pprin2 c;
        while not (((c := readch()) eq '!:) or (c eq !$eol!$)) do
              pprin2 c >>;
  if c eq '!: then
  <<
      ty := readpascaltype c;
      pasc!-symtabput(name,name,cdr ty);
          c:=car ty
  >>;
  if numberp i then
     while get(name := intern compress append(explode2 '!$, explode2 i),
            '!*pascalname!*) do
        << remprop(name, '!*pascalname!*); i:=sub1 i >>;
  lst:=nil;
  c:=flushspaces c;
  while liter c or digit c or c eq '!_ do
     << pprin2 c; lst:=c . lst; c := readch() >>;
  if lst then
     lst:=intern compress reverse lst;
  return lst . c
  end$

symbolic procedure readpascaltype(c);
begin
  scalar ty;
  pprin2 c;
  c := flushspaces readch();
  ty := list c;
  pprin2 c;
  while not (seprp (c := readch()) or c memq list('!;, '!), '![ )) do
    <<  ty := aconc(ty, c);  pprin2 c  >>;
  ty := intern compress ty;
  if ty eq 'array then return readpascalarraydeclaration(c)
     else return c . list ty;
  end;

symbolic procedure readpascalarraydeclaration (c);
begin
  scalar lo,hi,ty;
  ty:= nil;
  c:=flushspaces c;
  if not (c eq '![) then
     gentranerr(c,nil,"invalid pascal array declaration",nil);
  pprin2 c;
l:  c:=flushspaces readch();
  lo:= list c;
  pprin2 c;
  while not (seprp (c := readch()) or c eq '!.) do
    << lo:=aconc(lo,c); pprin2 c  >>;
  lo :=  compress lo;
  c:=flushspaces c;
  if not numberp lo then lo:=intern lo;
  pprin2 c;
  c:=readch();
  if not (c eq '!.) then
     gentranerr (c,nil,".. not found in array declaration",nil);
  pprin2 c;
  c:=flushspaces readch();
  hi:= list c;
  pprin2 c;
  while not (seprp (c := readch()) or c memq list('!,, '!])) do
    << hi:=aconc(hi,c); pprin2 c  >>;
  hi := compress hi;
  if not numberp hi then hi:=intern hi;
  ty:= hi . ty;
  pprin2 c;
  c:=flushspaces c;
  if c eq '!] then
    << ty:= reverse ty;
       c:=flushspaces readch();
       if not(c memq '( !o !O)) then gentranerr(c,nil,"not 'of'",nil);
       pprin2 c;
       c:=readch();
       if not(c memq '( !f !F)) then gentranerr(c,nil,"not 'of'",nil);
       pprin2 c;
       c:=readpascaltype(readch());
       return car c . append(cdr c,ty) >>;
  goto l;
  end;

procedure procpascheader c;
begin
  scalar name, i;
  while seprp c and c neq !$eol!$ do
    <<  pprin2 c;  c := readch()  >>;
  while not(seprp c or c memq list('!{, '!;, '!()) do
    <<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
  if c memq list(!$eol!$, '!{, '!;) then return c;
  while seprp c and c neq !$eol!$ do
    <<  pprin2 c;  c := readch()  >>;
  if c neq '!( then return c;
  name := intern compress name;
  if not !*gendecs then
      pasc!-symtabput(name, nil, nil);
  put('!$0, '!*cname!*, name);
  pprin2 c;
  i := 1;
  c := readch();
  while c neq '!) do
  <<  c:=flushspacescommas c;
      name := list c;
      pprin2 c;
      while not(seprp (c := readch()) or c memq list('!,, '!))) do
        <<  name := aconc(name, c);  pprin2 c  >>;
      put(intern compress append(explode2 '!$, explode2 i),
          '!*cname!*,
          intern compress name);
      i := add1 i;
      c:=flushspaces c;
  >>;
  !$!# := sub1 i;
  while get(name := intern compress append(explode2 '!$, explode2 i),
            '!*cname!*) do
      remprop(name, '!*cname!*);
  return procpascfunction c
  end$

procedure procpascfunction c;
begin
  scalar block!-count;
  while c neq '!{ do
      if c eq '!; then
          c := procactive()
      else if c eq !$eol!$ then
      <<  pterpri();  c := readch()  >>
      else
      <<  pprin2 c;  c := readch()  >>;
  pprin2 c;
  block!-count := 1;
  c := readch();
  while block!-count > 0 do
    if c eq 'begin then
        <<  block!-count := add1 block!-count;
            pprin2 c;  c := readch()  >>
    else if c eq 'end then
    <<  block!-count := sub1 block!-count;  pprin2 c;  c := readch()  >>
    else if c eq '!{ then
        c := procpasccomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<  pterpri();  c := readch()  >>
    else
    <<  pprin2 c;  c := readch()  >>;
  return c
  end$

% misc routines - JHD 15.12.87


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/redlsp.red0000644000175000017500000003160311526203062024132 0ustar  giovannigiovannimodule redlsp;    %%  GENTRAN LISP Code Generation Module  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  LispCode


symbolic$

% GENTRAN Global Variables %
global '(!*lisparithexpops!* !*lisplogexpops!* !*redarithexpops!*
        !*redlogexpops!* !*redreswds!* !*redstmtgpops!* !*redstmtops!*)$
!*redarithexpops!*:= '(difference expt minus plus quotient recip times)$
!*redlogexpops!*   := '(and equal geq greaterp leq lessp neq not or)$
!*redreswds!*:= '(and rblock cond de difference end equal expt !~for for
                   geq getel go greaterp leq lessp list minus neq not or
                   plus plus2 prog progn procedure quotient read recip
                   repeat return setel setk setq stop times times2
                   while write)$ %REDUCE reserved words
!*redstmtgpops!*   := '(rblock progn)$
!*redstmtops!*     := '(cond end !~for for go repeat return setq stop
                        while write)$

% REDUCE Non-local Variable %

fluid '(!*period);

global '(deftype!*)$

global '(!*do!* !*for!*)$

% Irena variable referenced here.
global '(irena!-constants)$
irena!-constants := nil$

procedure lispcode forms;
for each f in forms collect
    if redexpp f then
        lispcodeexp(f, !*period)
    else if redstmtp f or redstmtgpp f then
        lispcodestmt f
    else if reddefp f then
        lispcodedef f
    else if pairp f then
        for each e in f collect lispcode e$

symbolic procedure check!-for!-irena!-constants form;
if listp form and memq(car form,!*redarithexpops!*) then
  for each u in cdr form do check!-for!-irena!-constants(u)
else if pairp form and car form memq '( !:cr!: !:crn!: !:gi!: )then
  repeat
  <<
    form := cdr form;
    check!-for!-irena!-constants(if atom form then form else car form);
  >>
  until atom form
else if form and atom form then
  if memq(form,irena!-constants) then set(get(form,'!*found!-flag),t)$

symbolic procedure lispcodeexp(form, fp);
% (RECIP exp) ==> (QUOTIENT 1.0 exp)                   %
% (DIFFERENCE exp1 exp2) ==> (PLUS exp1 (MINUS exp2))  %
% integer ==> floating point  iff  PERIOD flag is ON & %
%                                  not exponent &      %
%                                  not subscript &     %
%                                  not loop index      %
% The above is a little simplistic. We have problems
% With expressions like x**(1/2)
% Now believed fixed. JHD 14.5.88
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% mcd 16-11-88.  Added code to spot certain variables which irena
% needs to generate values for.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
begin
return if numberp form then
    if fp then
        float form
    else
        form
% Substitute (EXP 1) for e - mcd 29/4/88 %
else if form eq 'e then
    lispcodeexp(list('exp,1.0),fp)
else if atom form or car form memq '( !:rd!: !:cr!: !:crn!: !:gi!: )then
<<
    if irena!-constants and form and not stringp form then
        check!-for!-irena!-constants form;
    form
>>
else if car form eq 'expt then
    % Changes (EXPT E X) to (EXP X). mcd 29/4/88 %
    if cadr form eq 'e then
      lispcodeexp(list('exp,caddr form),fp)
    else if caddr form = '(quotient 1 2) then
      lispcodeexp(list('sqrt,cadr form),fp)
    else if eqcar(caddr form,'!:rd!:) then begin scalar r;
         r := realrat caddr form;
         return if r = '(1 . 2)
                  then {'sqrt,lispcodeexp(cadr form, fp)}
                 else {'expt,lispcodeexp(cadr form, fp),
                       lispcodeexp({'quotient,car r,cdr r},nil)}
         end
    else
      list('expt,lispcodeexp(cadr form,fp),lispcodeexp(caddr form,nil))
else if car form eq 'quotient then % re-instate periods if necessary
                                   %e.g. in expressions like **(1/3)
        list('quotient, lispcodeexp(cadr form, t),
                        lispcodeexp(caddr form, t))
else if car form eq 'recip then
    if !*period then % test this not FP, for same reason as above
        list('quotient, 1.0, lispcodeexp(cadr form, fp))
    else
        list('quotient, 1, lispcodeexp(cadr form, fp))
else if car form eq 'difference then
    list('plus, lispcodeexp(cadr form, fp),
                list('minus, lispcodeexp(caddr form, fp)))
else if not(car form memq !*lisparithexpops!*) and
        not(car form memq !*lisplogexpops!*) then
    for each elt in form collect lispcodeexp(elt, nil)
else
    for each elt in form collect lispcodeexp(elt, fp)$
end$


procedure lispcodestmt form;
if atom form then
    form
else if redassignp form then
    lispcodeassign form
else if redreadp form then
    lispcoderead form
else if redprintp form then
    lispcodeprint form
else if redwhilep form then
    lispcodewhile form
else if redrepeatp form then
    lispcoderepeat form
else if redforp form then
    lispcodefor form
else if redcondp form then
    lispcodecond form
else if redreturnp form then
    lispcodereturn form
else if redstmtgpp form then
    lispcodestmtgp form
else if reddefp form then
    lispcodedef form
else if car form eq 'literal then
    for each elt in form collect lispcodeexp(elt, nil)
else
    for each elt in form collect lispcodeexp(elt, !*period)$


symbolic procedure lispcodeassign form;
% Modified mcd 27/11/87 to prevent coercing things already declared as
% integers to reals when the PERIOD flag is on.
%
% (SETQ var (MAT lst lst')) --> (PROGN (SETQ (var 1 1) exp11)          %
%                                      (SETQ (var 1 2) exp12)          %
%                                       .                              %
%                                       .                              %
%                                      (SETQ (var m n) expmn))         %
if eqcar( caddr form, 'mat) then
    begin
    scalar name, r, c, relts, result,ftype;
    name := cadr form;
    form := caddr form;
    r := c := 1;
    ftype := symtabget(nil,name);
    if null ftype then ftype := !*period else
    << ftype := cadr ftype;
       ftype := if ftype equal 'integer or
            (ftype equal 'scalar and deftype!* equal 'integer) then nil
                                                         else !*period;
    >>;
    while form := cdr form do
    <<
        relts := car form;
        repeat
        <<
            result := mkassign(list(name, r, c),
                               lispcodeexp(car relts, ftype))
                                  . result;
            c := add1 c
        >>
        until null(relts := cdr relts);
        r := add1 r;
        c := 1
    >>;
    return mkstmtgp(nil, reverse result)
    end
else begin
        scalar ftype,name;
        name := cadr form;
        if pairp name then name := car name;
        ftype := symtabget(nil,name);
        if null ftype then ftype := !*period else
        << ftype := cadr ftype;
           ftype := if ftype equal 'integer or
             (ftype equal 'scalar and deftype!* equal 'integer) then nil
                                                          else !*period;
        >>;
        if cadr form eq 'e then % To prevent an 'e on the lhs
                                % being changed to exp(1) by lispcodeexp
                                % mcd 29/4/88
                return mkassign('e,lispcodeexp(caddr form, ftype))
        else
             return mkassign(lispcodeexp(cadr form, ftype),
                                    lispcodeexp(caddr form, ftype))
end$

procedure lispcoderead form;
% (SETQ var (READ)) --> (READ var) %
list('read, lispcodeexp(cadr form, nil))$

procedure lispcodeprint form;
'write . for each elt in cdr form collect lispcodeexp(elt, !*period)$

procedure lispcodewhile form;
'while . lispcodeexp(cadr form, !*period) .
         foreach st in cddr form collect lispcodestmt st$

procedure lispcoderepeat form;
begin
scalar body, logexp;
body := reverse cdr form;
logexp := car body;
body := reverse cdr body;
return 'repeat . append(foreach st in body collect lispcodestmt st,
                        list lispcodeexp(logexp, !*period))
end$

procedure lispcodefor form;
% (SETQ var1 (FOR var (exp1 exp2 exp3) SUM exp))
%   --> (PROGN (SETQ var1 0/0.0)
%             (FOR var (exp1 exp2 exp3) DO (SETQ var1 (PLUS var1 exp))))
% (SETQ var1 (FOR var (exp1 exp2 exp3) PRODUCT exp))
%   --> (PROGN (SETQ var1 1/1.0)
%            (FOR var (exp1 exp2 exp3) DO (SETQ var1 (TIMES var1 exp))))
if car form eq 'for then
    begin
    scalar explst, stmtlst;
    explst := list(cadr form, caddr form);
    stmtlst := cddddr form;
    return append(!*for!* .
                    foreach exp in explst collect lispcodeexp(exp, nil),
                  !*do!* .
                    foreach st in stmtlst collect lispcodestmt st)
    end
else
    begin
    scalar var1, var, explst, op, exp;
    var1 := cadr form;
    form := caddr form;
    var := cadr form;
    explst := caddr form;
    if cadddr form eq 'sum then
        op := 'plus
    else
        op := 'times;
    exp := car cddddr form;
    form := list('prog, nil,
                 lispcode list('setq,var1,if op eq 'plus then 0 else 1),
                 lispcode list(!*for!*, var, explst, !*do!*,
                      list('setq, var1, list(op, var1, exp))));
    return lispcodestmt form
    end$

procedure lispcodecond form;
begin
scalar result, pr;
while form := cdr form do
<<
    pr := car form;
    pr := lispcodeexp(car pr, !*period)
            . for each stmt in cdr pr collect lispcodestmt stmt;
    result := pr . result
>>;
return mkcond reverse result
end$

procedure lispcodereturn form;
% (RETURN NIL) --> (RETURN) %
if form member '((return) (return nil)) then
    list 'return
else
    mkreturn lispcodeexp(cadr form, !*period)$

procedure lispcodestmtgp form;
% (RBLOCK () stmt1 stmt2 .. stmtm)      %
%   --> (PROG () stmt1 stmt2 .. stmtm) %
if car form memq '(prog rblock) then
    mkstmtgp(cadr form,
             for each stmt in cddr form collect lispcodestmt stmt)
else
    mkstmtgp(0, for each stmt in cdr form collect lispcodestmt stmt)$

procedure lispcodedef form;
% (PROCEDURE id NIL EXPR (p1 p2 .. pn) stmt') %
%   --> (DEFUN id (p1 p2 .. pn) stmt')        %
if car form eq 'procedure then
    mkdef(cadr form, car cddddr form, for each stmt in cdr cddddr form
                                              collect lispcodestmt stmt)
else
    mkdef(cadr form, caddr form, for each stmt in cdddr form
                                          collect lispcodestmt stmt)$


%% REDUCE Form Predicates %%


procedure redassignp form;
eqcar(form, 'setq) and redassign1p caddr form$

procedure redassign1p form;
if atom form then
    t
else if car form eq 'setq then
    redassign1p caddr form
else if car form memq '(read for) then
    nil
else
    t$

procedure redcondp form;
eqcar(form, 'cond)$

procedure reddefp form;
eqcar(form, 'procedure)$

procedure redexpp form;
atom form or
car form memq !*redarithexpops!* or
car form memq !*redlogexpops!* or
not(car form memq !*redreswds!*)$

procedure redforp form;
if pairp form then
    if car form eq 'for then
        t
    else if car form eq 'setq then
        redfor1p caddr form$

procedure redfor1p form;
if atom form then
    nil
else if car form eq 'setq then
    redfor1p caddr form
else if car form eq 'for then
    t$

procedure redprintp form;
eqcar(form, 'write)$

procedure redreadp form;
eqcar(form, 'setq) and redread1p caddr form$

procedure redread1p form;
if atom form then
    nil
else if car form eq 'setq then
    redread1p caddr form
else if car form eq 'read then
    t$

procedure redrepeatp form;
eqcar(form, 'repeat)$

procedure redreturnp form;
eqcar(form, 'return)$

procedure redstmtp form;
atom form or
car form memq !*redstmtops!* or
atom car form and not(car form memq !*redreswds!*)$

procedure redstmtgpp form;
pairp form and car form memq !*redstmtgpops!*$

procedure redwhilep form;
eqcar(form, 'while)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.red0000644000175000017500000000326111526203062024276 0ustar  giovannigiovannimodule gentran;  % Header module for gentran package.

% Author: Barbara L. Gates.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by:  Michael C. Dewar.

create!-package('(gentran utils intrfc templt pre gparser redlsp segmnt
                  lspfor lsprat lspc lsppasc goutput),
                '(contrib gentran));

symbolic smacro procedure smallfloatp u;
   % Returns true if  is a small rounded.
   atom u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.hlp0000644000175000017500000003711111526203062024310 0ustar  giovannigiovanni\chapter{GENTRAN: A code generation package}
\label{GENTRAN}
\typeout{{GENTRAN: A code generation package}}

{\footnotesize
\begin{center}
Barbara L. Gates \\
RAND \\
Santa Monica CA 90407-2138 \\
U.S.A. \\[0.1in]
Michael C. Dewar \\
School of Mathematical Sciences, The University of Bath \\
Bath BA2 7AY, England \\[0.05in]
e--mail: mcd@maths.bath.ac.uk
\end{center}
}

\ttindex{GENTRAN}

GENTRAN is an automatic code GENerator and TRANslator which runs under
\REDUCE.  It constructs complete numerical programs based on sets of
algorithmic specifications and symbolic expressions.  Formatted
FORTRAN, RATFOR, PASCAL or C code can be generated through a series of
interactive commands or under the control of a template processing
routine.  Large expressions can be automatically segmented into
subexpressions of manageable size, and a special file-handling
mechanism maintains stacks of open I/O channels to allow output to be
sent to any number of files simultaneously and to facilitate recursive
invocation of the whole code generation process.  GENTRAN provides the
flexibility necessary to handle most code generation applications.  It
is designed to work with the SCOPE code optimiser.

GENTRAN is a large system with a great many options.  This section
will only describe the FORTRAN generation facilities, and in broad
outline only.  The full manual is available as part of the \REDUCE\
documentation.

\section{Simple Use}

A substantial subset of all expressions and statements in the \REDUCE{}
programming language can be translated directly into numerical code.
The {\bf GENTRAN} command takes a \REDUCE\ expression, statement, or
procedure definition, and translates it into code in the target
language.

\begin{describe}{Syntax:}
{\bf GENTRAN} {\it stmt} [ {\bf OUT} {\it f1,f2,\dots\  ,fn} ]{\it ;}
\end{describe}

{\it stmt} is any \REDUCE\ expression, statement (simple, compound, or
group), or procedure definition that can be translated by GENTRAN into the
target language.
{\it stmt} may contain any number of calls
to the special functions {\bf EVAL}, {\bf DECLARE}, and {\bf LITERAL}.
{\it f1,f2,\dots\  ,fn } is an optional argument list containing one or more
{\it f}'s, where each {\it f} is one of:
\par
\begin{tabular}{lll}
{\it an atom} &= &an output file\\
{\bf T} &= &the terminal\\
{\bf NIL} &= &the current output file(s)\\
\ttindex{ALL"!*} {\bf ALL!*} &= &all files currently open for output \\
& & by GENTRAN (see section~\ref{GENTRAN:output})\\
\end{tabular}

If the optional part of the command is not given, generated code is simply
written to the current output file.  However, if it is
given, then the current output file is temporarily overridden.  Generated
code is written to each file represented by
{\it f1,f2,\dots\  ,fn} for this command only.  Files which were open prior
to the call to {\bf GENTRAN} will remain open after the call, and files
which did not exist prior to the call will be created, opened, written to,
and closed.  The output stack will be exactly the same both before and
after the call.

{\bf GENTRAN}  returns the name(s) of the file(s) to which code was
written.

\index{GENTRAN package ! example}
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$

2: GENTRAN
2:     FOR I:=1:N DO
2:         V(I) := 0$

      DO 25001 I=1,N
          V(I)=0.0
25001 CONTINUE

\end{verbatim}

\section{Precision}
\label{precision}
\index{precision}\index{DOUBLE switch}
By default {\bf GENTRAN} generates constants and type declarations in
single precision form.  If the user requires double precision output
then the switch {\bf DOUBLE} must be set {\bf ON}.

\index{PRECISION command}\index{PRINT"!-PRECISION command}
To ensure the correct number of floating point digits are
generated it may be necessary to use either the {\bf PRECISION} or
{\bf PRINT!-PRECISION} commands.  The former alters the number of
digits \REDUCE\ calculates, the latter only the number of digits
\REDUCE\ prints.  Each takes an integer argument.  It is not possible to set
the printed precision higher than the actual precision.  Calling {\bf
PRINT!-PRECISION} with a negative argument causes the printed
precision to revert to the actual precision.

\subsection{The EVAL Function}
\label{eval}
\begin{describe}{Syntax:}
{\bf EVAL} {\it exp}
\end{describe}\ttindex{EVAL}
\begin{describe}{Argument:}
{\it exp} is any \REDUCE\ expression or statement which, after evaluation
by \REDUCE, results in an expression that can be translated by
GENTRAN into the target language.
\end{describe}
When {\bf EVAL} is called on an expression which is to be translated, it
tells {\bf GENTRAN} to give the expression to \REDUCE\ for evaluation
first, and then to translate the result of that evaluation. 

\begin{verbatim}
f;

   2
2*X  - 5*X + 6
\end{verbatim}
We wish to generate an assignment statement for the quotient
of F and its derivative.
\begin{verbatim}
1: GENTRAN
1:      Q := EVAL(F)/EVAL(DF(F,X))$

      Q=(2.0*X**2-(5.0*X)+6.0)/(4.0*X-5.0)
\end{verbatim}

\subsection{The :=: Operator}
\index{:=:}
\label{rsetq}\index{GENTRAN ! preevaluation}\index{rsetq operator}
In many applications, assignments must be generated in which the
left-hand side is some known variable name, but the
right-hand side is an expression that must be evaluated.  For
this reason, a special operator is provided to indicate that the expression
on the right-hand side is to be evaluated prior to translation.  This
special operator is {\bf :=:} ({\em i.e.} the usual \REDUCE\ assignment operator
with an extra ``:'' on the right).
\begin{describe}{\example}
\begin{verbatim}
1: GENTRAN
1:  DERIV :=: DF(X^4-X^3+2*x^2+1,X)$

      DERIV=4.0*X**3-(3.0*X**2)+4.0*X
\end{verbatim}
\end{describe}

\subsection{The ::= Operator}
\label{lsetq}
\index{matrices ! in GENTRAN}
When assignments to matrix or array elements must be generated, many
times the indices of the element must be evaluated first.  The special
operator\index{::=}\index{lsetq operator}
{\bf ::=} can be used within a call to {\bf GENTRAN}
to indicate that the indices of the matrix or
array element on the left-hand side of the assignment are to
be evaluated prior to translation.  (This is the usual \REDUCE{}
assignment operator with an extra ``:'' on the left.) 
\begin{describe}{\example}
We wish to generate assignments which assign zeros to all elements
on the main diagonal of M, an n x n matrix.
\begin{verbatim}
10: FOR j := 1 : 8 DO
10:      GENTRAN
10:          M(j,j) ::= 0$

      M(1,1)=0.0
      M(2,2)=0.0
      :
      :
      M(8,8)=0.0
\end{verbatim}
\end{describe}

{\bf LSETQ} may be used interchangeably with {\bf ::=} on input.\ttindex{LSETQ}

\subsection{The ::=: Operator}
\label{lrsetq}
\index{::=:} \index{lrsetq operator}
In applications in which evaluated expressions are to be assigned to
array elements with evaluated subscripts, the {\bf ::=:} operator can be
used.  It is a combination of the {\bf ::=} and {\bf :=:} operators described
in sections~\ref{rsetq} and ~\ref{lsetq}.
\index{matrices ! in GENTRAN}

\begin{describe}{\example}
The following matrix, M, has been derived symbolically:
\newpage
\begin{verbatim}
(  A   0  -1   1)
(               )
(  0   B   0   0)
(               )
( -1   0   C  -1)
(               )
(  1   0  -1   D)
\end{verbatim}
We wish to generate assignment statements for those elements
on the main diagonal of the matrix.
\begin{verbatim}
10: FOR j := 1 : 4 DO
10:      GENTRAN
10:          M(j,j) ::=: M(j,j)$

      M(1,1)=A
      M(2,2)=B
      M(3,3)=C
      M(4,4)=D
\end{verbatim}
\end{describe}
The alternative alphanumeric identifier associated with {\bf ::=:} is
{\bf LRSETQ}.\ttindex{LRSETQ}

\section{Explicit Type Declarations}
\label{explicit:type}
Type declarations are automatically generated each time a subprogram
heading is generated.  Type declarations are constructed
from information stored in the GENTRAN symbol table.  The user
can place entries into the symbol table explicitly through calls
to the special GENTRAN function {\bf DECLARE}.\index{DECLARE function}
\begin{describe}{Syntax:}
{\bf \ \ DECLARE} {\it v1,v2,\dots\  ,vn} {\bf :} {\it type;}

    or

\begin{tabular}{ll}
{\bf DECLARE}\\
{\bf $<$$<$}\\
&{\it v11,v12,\dots\  ,v1n} {\bf :} {\it type1;}\\
&{\it v21,v22,\dots\  ,v2n} {\bf :} {\it type2;}\\
& :\\
& :\\
&{\it vn1,vnn,\dots\  ,vnn} {\bf :} {\it typen;}\\
{\bf $>$$>$}{\it ;}
\end{tabular}
\end{describe}
\begin{describe}{Arguments:}
Each {\it v1,v2,\dots\  ,vn} is a list of one or more variables
(optionally subscripted to indicate array dimensions), or
variable ranges (two letters separated by a ``-'').  {\it v}'s are
not evaluated unless given as arguments to {\bf EVAL}.

Each {\it type} is a variable type in the target language.  Each
must be an atom, optionally preceded by the atom {\bf IMPLICIT}.
\index{IMPLICIT option}
{\it type}'s are not evaluated unless given as arguments to {\bf EVAL}.
\end{describe}

The {\bf DECLARE} statement can also be used to declare subprogram
types ({\em i.e.\ } {\bf SUBROUTINE} or {\bf FUNCTION}) for
\index{SUBROUTINE}\index{FUNCTION} FORTRAN and RATFOR code, and
function types for all four languages.

\section{Expression Segmentation}
\label{segmentation}\index{segmenting expressions}
Symbolic derivations can easily produce formulas that can be anywhere
from a few lines to several pages in length.  Such formulas
can be translated into numerical assignment statements, but unless they
are broken into smaller pieces they may be too long for a compiler
to handle.  (The maximum number of continuation lines for one statement
allowed by most FORTRAN compilers is only 19.)  Therefore GENTRAN
\index{continuation lines}
contains a segmentation facility which automatically {\it segments},
or breaks down unreasonably large expressions.

The segmentation facility generates a sequence of assignment
statements, each of which assigns a subexpression to an automatically
generated temporary variable.  This sequence is generated in such a
way that temporary variables are re-used as soon as possible, thereby
keeping the number of automatically generated variables to a minimum.
The facility can be turned on or off by setting the mode
\index{GENTRANSEG switch} switch {\bf GENTRANSEG} accordingly ({\em
i.e.\ }by calling the \REDUCE\ function {\bf ON} or {\bf OFF} on it).  The user
can control the maximum allowable expression size by setting the
\ttindex{MAXEXPPRINTLEN"!*}
variable {\bf MAXEXPPRINTLEN!*} to the maximum number of characters
allowed in an expression printed in the target language (excluding
spaces automatically printed by the formatter).  The {\bf GENTRANSEG}
switch is on initially, and {\bf MAXEXPPRINTLEN!*} is initialised to
800.

\section{Template Processing}\label{GENTRAN:template}

\index{GENTRAN ! templates}\index{templates}\index{code templates}
In some code generation applications pieces of the target numerical
program are known in advance.  A {\it template} file containing a
program outline is supplied by the user, and formulas are derived in
\REDUCE, converted to numerical code, and inserted in the corresponding
places in the program outline to form a complete numerical program.  A
template processor is provided by GENTRAN for use in these
applications.

\label{templates}\index{GENTRANIN command}
\begin{describe}{Syntax:}
{\bf GENTRANIN} {\it f1,f2,\dots\ ,fm} [{\bf OUT} {\it f1,f2,\dots\
 ,fn\/}]{\it ;}
\end{describe}
\begin{describe}{Arguments:}
{\it f1,f2,\dots\ ,fm\/} is an argument list containing one or more
{\it f\/}'s,
where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &a template (input) file\\
{\bf T}& = &the terminal\\
\end{tabular}
\end{center}
{\it f1,f2,\dots\ ,fn\/} is an optional argument list containing one or more
{\it f\/}'s, where each {\it f\/} is one of:
\begin{center}
\begin{tabular}{lll}
{\it an atom}& = &an output file\\
{\bf T}& = &the terminal\\
{\bf NIL}& = &the current output file(s)\\
{\bf ALL!*}& = &all files currently open for output \\
& &  by GENTRAN (see section~\ref{GENTRAN:output}) \\
\end{tabular}
\end{center}
\end{describe}
{\bf GENTRANIN} processes each template file {\it f1,f2,\dots\ ,fm}
sequentially.

A template file may contain any number of parts, each of which
is either an active or an inactive part.  All active parts start with
the character sequence {\bf ;BEGIN;} and end with {\bf ;END;}.  The end
of the template file is indicated by an extra {\bf ;END;} character
sequence.\index{;BEGIN; marker} \index{;END; marker}

Inactive parts of template files are assumed to contain code in the
target language.  All inactive parts are
copied to the output.

Active parts may contain any number of \REDUCE\ expressions, statements,
and commands.  They are not copied directly to the output.  Instead,
they are given to \REDUCE\ for evaluation in algebraic mode.  All output
generated by each evaluation is sent to the output file(s).  Returned
values are only printed on the terminal.\index{GENTRAN ! preevaluation}

Active parts will most likely contain calls to {\bf GENTRAN} to
generate code.  This means that the result of processing a
template file will be the original template file with all active
parts replaced by generated code.

If {\bf OUT} {\it f1,f2,\dots\ ,fn} is not given, generated code is simply
written to the current-output file.

However, if {\bf OUT} {\it  f1,f2,\dots\ ,fn}
is given, then the current-output file
is temporarily overridden.  Generated code is written to each file
represented by {\it f1,f2,\dots\ ,fn} for this command only.  Files
which were open prior to the call to {\bf GENTRANIN} will remain open
after the call, and files which did not exist prior to the call will
be created, opened, written to, and closed.  The output-stack will be
exactly the same both before and after the call.


{\bf GENTRANIN} returns the names of all files written to by this
command.
\newpage
\begin{describe}{\example}
Suppose we wish to generate a FORTRAN subprogram to compute the
determinant of a 3 x 3 matrix.  We can construct a template
file with an outline of the FORTRAN subprogram and \REDUCE\ and
GENTRAN commands to fill it in:
\index{matrices ! in GENTRAN}

Contents of file {\tt det.tem}:
\end{describe}
\begin{verbatim}
      REAL FUNCTION DET(M)
      REAL M(3,3)
;BEGIN;
      OPERATOR M$
      MATRIX MM(3,3)$
      MM := MAT( (M(1,1),M(1,2),M(1,3)),
                 (M(2,1),M(2,2),M(2,3)),
                 (M(3,1),M(3,2),M(3,3)) )$
      GENTRAN DET :=: DET(MM)$
;END;
      RETURN
      END
;END;
\end{verbatim}

\begin{describe}{}
Now we can generate a FORTRAN subprogram with the following
\REDUCE\ session:
\begin{verbatim}
1: GENTRANLANG!* := 'FORTRAN$

2: GENTRANIN
2:      "det.tem"
2: OUT "det.f"$
\end{verbatim}
Contents of file det.f:
\end{describe}
\begin{verbatim}
      REAL FUNCTION DET(M)
      REAL M(3,3)
      DET=M(3,3)*M(2,2)*M(1,1)-(M(3,3)*M(2,1)*M(1,2))-(M(3,2)
     . *M(2,3)*M(1,1))+M(3,2)*M(2,1)*M(1,3)+M(3,1)*M(2,3)*M(1
     . ,2)-(M(3,1)*M(2,2)*M(1,3))
      RETURN
      END
\end{verbatim}

\section{Output Redirection}\label{GENTRAN:output}
\index{GENTRAN ! file output}

\index{GENTRANOUT command}\index{GENTRANSHUT command}
The {\bf GENTRANOUT} and {\bf GENTRANSHUT} commands are identical to
the \REDUCE\ {\bf OUT} and {\bf SHUT} commands with the following
exceptions:

\begin{itemize}
\item {\bf GENTRANOUT} and {\bf GENTRANSHUT} redirect {\it only\/}
code which is printed as a side effect of GENTRAN commands.
\item {\bf GENTRANOUT} allows more than one file name to be given
to indicate that generated code is to be sent to two or more
files.  (It is particularly convenient to be able to
have generated code sent to
the terminal screen and one or more file simultaneously.)
\item {\bf GENTRANOUT} does not automatically erase existing files; it
prints a warning message on the terminal and asks the user whether the
existing file should be erased or the whole command be aborted.
\end{itemize}

mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/lsprat.red0000644000175000017500000004554611526203062024161 0ustar  giovannigiovannimodule lsprat;    %%  GENTRAN LISP-to-RATFOR Translation Module  %%

%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Updates:

% M.C. Dewar and J.H. Davenport 8 Jan 88 Double precision check added.

% Entry Point:  RatCode


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



symbolic$

fluid '(!*double !*gendecs !*getdecs);

switch gendecs$

fluid '(!*makecalls)$
switch makecalls$
!*makecalls := t$

% User-Accessible Global Variables %
global '(minratlinelen!* ratlinelen!* !*ratcurrind!*
         ratcurrind!* tablen!*)$
share ratcurrind!*, minratlinelen!*, ratlinelen!*, tablen!*$
ratcurrind!* := 0$
minratlinelen!*  := 40$
ratlinelen!*     := 80$
!*ratcurrind!*  := 0$     %current level of indentation for RATFOR code


global '(deftype!* !*do!* !*notfortranfuns!* !*legalforttypes!*)$

global '(!*stdout!*)$
global '(!*posn!* !$!#)$

%%                                      %%
%% LISP-to-RATFOR Translation Functions %%
%%                                      %%

put('ratfor,'formatter,'formatrat);
put('ratfor,'codegen,'ratcode);
put('ratfor,'proctem,'procrattem);
put('ratfor,'gendecs,'ratdecs);
put('ratfor,'assigner,'mkfratassign);
put('ratfor,'boolean!-type,'logical);

%% Control Function %%


procedure ratcode forms;
for each f in forms conc
    if atom f then
        ratexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
        ratexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(ratdecs symtabget('!*main!*, '!*decs!*),
                        ratstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            ratstmt f
    else if lispdefp f then
        ratsubprog f
    else
        ratexp f$


%% Subprogram Translation %%


symbolic procedure ratsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := cadr deff;
if onep length(body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if lispreturnp (lastst := car reverse body) then
    body := append(body, list '(end))
else if not lispendp lastst then
    body := append(body, list('(return), '(end)));
type := cadr symtabget(name, name);
stype := symtabget(name, '!*type!*) or
         (    if type or functionformp(body, name)
                 then 'function
                 else 'subroutine    );
symtabrem(name, '!*type!*);
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
if !*getdecs and null type and stype eq 'function
   then type := deftype!*;
if type then
<<  symtabrem(name, name);
    % Generate the correct double precision type name - mcd 28/1/88 %
    if !*double then
        if type memq '(real real!*8) then
                type := 'double! precision
        else if type eq 'complex then
                type := 'complex!*16;
>>;
r := mkfratsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, ratdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc ratstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$


%% Generation of Declarations %%


procedure ratdecs decs;
for each tl in formtypelists decs
    conc mkfratdec(car tl, cdr tl)$


%% Expression Translation %%


procedure ratexp exp;
ratexp1(exp, 0)$

procedure ratexp1(exp, wtin);
if atom exp then
    list fortranname exp
else
    if onep length exp then
        fortranname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := ratforprecedence car exp;
        op := ratforop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . ratexp1(car exp, wt)
        else
        <<
            res := ratexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
                        res := append(res, list op);
                    res := append(res, ratexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  ratexp1(car exp, wt))
        >>;
        if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        ratliteral exp
    else if car exp eq 'range
        then append(fortexp cadr exp,'!: . fortexp caddr exp)
    else if car exp eq '!:rd!: then
    begin scalar mt;
        integer dotpos,!:lower!-sci!:,!:upper!-sci!:; % this forces most
                                         % numbers to exponential format
        mt := rd!:explode exp;
        exp := car mt;
        mt  := cadr mt + caddr mt - 1;
        exp := append(list('literal,car exp, '!.),cdr exp);
        if null (mt = 0) then
            exp := append(exp, list(if !*double then '!d else '!e,mt))
        else if !*double then
            exp := append(exp,'(!e 0));
        return ratliteral exp;
    end
    else if car exp memq '(!:cr!: !:crn!: !:gi!:) then
    begin scalar re,im;

        re := explode if smallfloatp cadr exp then cadr exp
                                              else caadr exp;
        re := if memq ('!e, re) then
            subst('d,'!e,re)
        else if memq ('!e, re) then
            subst('d,'!e,re)
        else if !*double then
            append(re,'(d 0))
        else
            append(re,'(e 0));

        im := explode if smallfloatp cddr exp then cddr exp
                                              else caddr exp;
        im := if memq ('!e, im) then
            subst('d,'!e,im)
        else if memq ('!e, im) then
            subst('d,'!e,im)
        else if !*double then
            append(im,'(d 0))
        else
            append(im,'(e 0));

        return ('!().append(re,('!,).append(im,'(!))));
    end
    else
        begin
        scalar op, res;
        op := fortranname car exp;
        exp := cdr exp;
        res := ratexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,), ratexp1(car exp, 0));
        return op . insertparens res
        end$


procedure ratforop op;
get(op, '!*ratforop!*) or op$

put('or,       '!*ratforop!*, '|   )$
put('and,      '!*ratforop!*, '&   )$
put('not,      '!*ratforop!*, '!!  )$
put('equal,    '!*ratforop!*, '!=!=)$
put('neq,      '!*ratforop!*, '!!!=)$
put('greaterp, '!*ratforop!*, '>   )$
put('geq,      '!*ratforop!*, '!>!=)$
put('lessp,    '!*ratforop!*, '<   )$
put('leq,      '!*ratforop!*, '!>;
if stmt then
<<
    r := append(r, mkfratelse());
    indentratlevel(+1);
    st := seqtogp cdar stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, ratstmt st);
    indentratlevel(-1)
>>;
return r
end$

procedure ratliteral stmt;
mkfratliteral cdr stmt$

procedure ratread stmt;
mkfratread cadr stmt$

procedure ratrepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfratrepeat();
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return append(r, mkfratuntil logexp)
end$

procedure ratreturn stmt;
if cdr stmt then
    mkfratreturn cadr stmt
else
    mkfratreturn nil$

procedure ratstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
    stmtgp := cdr stmtgp
else
    stmtgp := cddr stmtgp;
r := mkfratbegingp();
indentratlevel(+1);
r := append(r, for each stmt in stmtgp conc ratstmt stmt);
indentratlevel(-1);
return append(r, mkfratendgp())
end$

procedure ratstmtnum label;
begin
scalar stmtnum;
stmtnum := get(label, '!*stmtnum!*) or
          put(label, '!*stmtnum!*, genstmtnum());
return mkfratcontinue stmtnum
end$

procedure ratstop stmt;
mkfratstop()$

procedure ratwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfratwhile logexp;
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return r
end$

procedure ratwrite stmt;
mkfratwrite cdr stmt$


%%                                  %%
%% RATFOR Code Formatting Functions %%
%%                                  %%


%% Statement Formatting %%


% A macro used to prevent things with *fortranname* or *doublename*
% properties being evaluated in certain circumstances.  MCD 28.3.94
symbolic smacro procedure ratexp_name(u);
   if atom u then list(u)
    else rplaca(ratexp ('dummyArrayToken . cdr u), car u)$

procedure mkfratassign(lhs, rhs);
append(append(mkrattab() . ratexp_name lhs, '!= . ratexp rhs),
       list mkratterpri())$

procedure mkfratbegingp;
list(mkrattab(), '!{, mkratterpri())$

procedure mkfratbreak;
list(mkrattab(), 'break, mkratterpri())$

procedure mkfratcall(fname, params);
% Installed the switch makecalls 18/11/88 mcd.
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc ratexp p),
                         list '!));
    % If we want to generate bits of statements, then what might
    % appear a subroutine call may in fact be a function reference.
    if !*makecalls then
            append(append(list(mkrattab(), 'call, '! ), ratexp fname),
           append(params, list mkratterpri()))
    else
        append(ratexp fname,params)
>>$

procedure mkfratcontinue stmtnum;
list(stmtnum, '! , mkrattab(), 'continue, mkratterpri())$


symbolic procedure mkfratdec(type, varlist); %Ammended mcd 3/12/87
<<
    if type equal 'scalar then type := deftype!*;
    if type and null (type memq !*legalforttypes!*) then
        gentranerr('e,type,"Illegal Ratfor type. ",nil);
    type := type or 'dimension;

    % Generate the correct double precision type name - mcd 14/1/88 %
    if !*double then
        if type memq '(real real!*8) then
                type := 'double! precision
        else if type memq '(implicit! real implicit! real!*8) then
                type := 'implicit! double! precision
        else if type eq 'complex then
                type := 'complex!*16
        else if type eq 'implicit! complex then
                type := 'implicit! complex!*16;

    varlist := for each v in insertcommas varlist
                   conc ratexp_name v;
    if implicitp type then
        append(list(mkrattab(), type, '! , '!(),
               append(varlist, list('!), mkratterpri())))
    else
        append(list(mkrattab(), type, '! ),
               append(varlist, list mkratterpri()))
>>$

procedure mkfratdo(var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . ratexp incr;
    append(append(append(list(mkrattab(), !*do!*, '! ), ratexp var),
                  append('!= . ratexp lo, '!, . ratexp hi)),
           append(incr, list mkratterpri()))
>>$

procedure mkfratelse;
list(mkrattab(), 'else, mkratterpri())$

procedure mkfratelseif exp;
append(append(list(mkrattab(), 'else, '! , 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratend;
list(mkrattab(), 'end, mkratterpri())$

procedure mkfratendgp;
list(mkrattab(), '!}, mkratterpri())$

procedure mkfratgo stmtnum;
list(mkrattab(), 'goto, '! , stmtnum, mkratterpri())$

procedure mkfratif exp;
append(append(list(mkrattab(), 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkrattab()
    else if a eq 'cr!* then
        list mkratterpri()
    else if pairp a then
        ratexp a
    else
        list stripquotes a$

procedure mkfratread var;
append(list(mkrattab(), 'read, '!(!*!,!*!), '! ),
       append(ratexp var, list mkratterpri()))$

procedure mkfratrepeat;
list(mkrattab(), 'repeat, mkratterpri())$

procedure mkfratreturn exp;
if exp then
    append(append(list(mkrattab(), 'return, '!(), ratexp exp),
           list('!), mkratterpri()))
else
    list(mkrattab(), 'return, mkratterpri())$

procedure mkfratstop;
list(mkrattab(), 'stop, mkratterpri())$

procedure mkfratsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                  conc ratexp p,
                         list '!));
    if type then
        type := list(mkrattab(), type, '! , stype, '! )
    else
        type := list(mkrattab(), stype, '! );
    append(append(type, ratexp name),
           append(params,list mkratterpri()))
>>$

procedure mkfratuntil logexp;
append(list(mkrattab(), 'until, '! , '!(),
       append(ratexp logexp, list('!), mkratterpri())))$

procedure mkfratwhile exp;
append(append(list(mkrattab(), 'while, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$

procedure mkfratwrite arglist;
append(append(list(mkrattab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc ratexp arg),
       list mkratterpri())$


%% Indentation Control %%


procedure mkrattab;
list('rattab, ratcurrind!*)$


procedure indentratlevel n;
ratcurrind!* := ratcurrind!* + n * tablen!*$


procedure mkratterpri;
list 'ratterpri$

%% RATFOR Code Formatting & Printing Functions %%


procedure formatrat lst;
begin
scalar linelen,str;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if pairp elt then lispeval elt
    else
    <<  str:=explode2 elt;
        if floatp elt then
           if !*double then
              if memq('!e,str)
                 then str:=subst('D,'!e,str)
                 else if memq('E,str)   % Some LISPs use E not e
                      then str:=subst('D,'E,str)
                      else str:=append(str,'(D !0))
           else str:=subst('E,'!e,str);
                % get the casing conventions correct
        if !*posn!* + length str > ratlinelen!* then
            ratcontline();
        for each u in str do pprin2 u
    >>;
linelength linelen
end$

procedure ratcontline;
<<
    ratterpri();
    rattab !*ratcurrind!*;
    pprin2 " "
>>$

procedure ratterpri;
pterpri()$

procedure rattab n;
<<
    !*ratcurrind!* := min0(n, ratlinelen!* - minratlinelen!*);
    if (n := !*ratcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$

%% RATFOR template processing %%


procedure procrattem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
while c neq !$eof!$ do
    if c memq '(!F !f !S !s) then
    <<
        pprin2 c;
        c := procsubprogheading c
    >>
    else if c eq '!# then
        c := procratcomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<
        pterpri();
        c := readch()
    >>
    else
    <<
        pprin2 c;
        c := readch()
    >>;
linelength linelen
end$

procedure procratcomm;
% # ...  %
begin
scalar c;
pprin2 '!#;
while (c := readch()) neq !$eol!$ do
    pprin2 c;
pterpri();
return readch()
end$


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/goutput.red0000644000175000017500000000670511526203062024355 0ustar  giovannigiovanni

module goutput;  % GENTRAN Code Formatting & Printing and Error Handler

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Points:  FormatC, FormatFort, FormatRat, GentranErr, FormatPasc
% All format routines moved to individual language modules
% JHD December 1987

symbolic$

fluid '(!*errcont)$

% GENTRAN Global Variables %
global '(!*errchan!* !*outchanl!* gentranlang!*
         !*posn!* !*stdin!* !*stdout!* !$eol!$)$
!*errchan!*     := nil$   %error channel number
!*posn!*        := 0$     %current position on output line

%%                            %%
%% General Printing Functions %%
%%                            %%

% Pprin2 and pterpri changed by F.Kako.
% Original did not work in SLISP/370, since output must be buffered.

global '(!*pprinbuf!*);

procedure pprin2 arg;
   begin
      !*pprinbuf!* := arg . !*pprinbuf!*;
      !*posn!* := !*posn!* + length explode2 arg;
   end$

procedure pterpri;
   begin
      scalar ch,pbuf;
      ch := wrs nil;
      pbuf := reversip !*pprinbuf!*;
      for each c in !*outchanl!* do
         <>;
      !*posn!* := 0;
      !*pprinbuf!* := nil;
      wrs ch
   end$


%%               %%
%% Error Handler %%
%%               %%


%% Error & Warning Message Printing Routine %%


symbolic procedure gentranerr(msgtype, exp, msg1, msg2);
% Added check for !*errcont to aid graceful recovery from errors
% occurring in templates MCD 11.4.94
begin scalar holdich, holdoch, resp;
holdich := rds !*errchan!*;
holdoch := wrs !*errchan!*;
terpri();
if exp then prettyprint exp;
if (msgtype eq 'e) and not !*errcont then
<<
    rds cdr !*stdin!*;
    wrs cdr !*stdout!*;
    rederr msg1
>>;
prin2 "*** ";
prin2t msg1;
if msg2 then resp := yesp msg2;
wrs holdoch;
rds holdich;
if not(resp or !*errcont)  then error1()
end$


%%                 %%
%% Misc. Functions %%
%%                 %%


procedure min0(n1, n2);
max(min(n1, n2), 0)$

procedure nspaces n;
   % Note n is assumed > 0 here.
   begin scalar s;
      for i := 1:n do s := ('!! . '!  . s);
      return intern compress s
   end$


endmodule;


end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/gentran.tst0000644000175000017500000000243411526203062024337 0ustar  giovannigiovanniMATRIX M(3,3)$
M(1,1) := 18*COS(Q3)*COS(Q2)*M30*P**2 - 9*SIN(Q3)**2*P**2*M30
	  - SIN(Q3)**2*J30Y + SIN(Q3)**2*J30Z + P**2*M10
	  + 18*P**2*M30 + J10Y + J30Y;
M(2,1) :=
M(1,2) := 9*COS(Q3)*COS(Q2)*M30*P**2 - SIN(Q3)**2*J30Y +
	  SIN(Q3)**2*J30Z - 9*SIN(Q3)**2*M30*P**2 + J30Y +
	  9*M30*P**2;
M(3,1) :=
M(1,3) := -9*SIN(Q3)*SIN(Q2)*M30*P**2;
M(2,2) := -SIN(Q3)**2*J30Y + SIN(Q3)**2*J30Z - 9*SIN(Q3)**2
	   *M30*P**2 + J30Y + 9*M30*P**2;
M(3,2) :=
M(2,3) := 0;
M(3,3) := 9*M30*P**2 + J30X;

GENTRANLANG!* := 'FORTRAN$
FORTLINELEN!* := 72$

GENTRAN LITERAL "C", CR!*,
		"C", TAB!*, "*** COMPUTE VALUES FOR MATRIX M ***", CR!*,
		"C", CR!*$

FOR j:=1:3 DO
    FOR k:=j:3 DO
	 GENTRAN M(j,k) ::=: M(j,k)$

GENTRAN LITERAL "C", CR!*,
		"C", TAB!*, "*** COMPUTE VALUES FOR INVERSE MATRIX ***",
		     CR!*,
		"C", CR!*$

SHARE var$
FOR j:=1:3 DO
    FOR k:=j:3 DO
	IF M(j,k) NEQ 0 THEN
	<<
	    var := TEMPVAR NIL;
	    MARKVAR var;
	    M(j,k) := var;
	    M(k,j) := var;
	    GENTRAN
		EVAL(var) := M(EVAL(j),EVAL(k))
        >>$

COMMENT -- Contents of Matrix M: --$
M := M;

MATRIX MXINV(3,3)$
MXINV := M**(-1)$

FOR j:=1:3 DO
    FOR k:=j:3 DO
	GENTRAN MXINV(j,k) ::=: MXINV(j,k)$

GENTRAN
   for j:=1:3 do
       for k:=j+1:3 do
       <<
	   m(k,j) := m(j,k);
	   mxinv(k,j) := mxinv(j,k)
        >>$

END$
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/pre.red0000644000175000017500000001453211526203062023431 0ustar  giovannigiovannimodule pre;    %%  GENTRAN Preprocessing Module  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry Point:  Preproc


symbolic$


procedure preproc exp;
begin
scalar r;
r := preproc1 exp;
if r then
    return car r
else
    return r
end$

% This switch causes gentran to attempt to automatically generate type
% declarations, without use of the 'declare' statement.  mcd 12/11/87.
fluid '(!*getdecs)$
!*getdecs := nil$
switch getdecs$

% This global variable is the default type given when 'getdecs' is on:
global '(deftype!*)$
share deftype!*$
deftype!* := 'real$

% Bfloat defined in arith.red.

% symbolic procedure bfloat x; if floatp x then fl2bf x else
%    normbf(if atom x then read!:num x else x);

symbolic procedure preproc1 exp;
   % Amended mcd 12/11/87,13/11/87,14/10/91.
if atom exp then
    list exp
else if car exp = '!:rd!: then
    list if smallfloatp cdr exp then bfloat cdr exp else exp
else if car exp = '!:dn!: then
    preproc1 decimal2internal(cadr exp,cddr exp)
else if car exp eq '!*sq then
    % (!*SQ dpexp) --> (PREPSQ dpexp) %
    preproc1 prepsq cadr exp
else if car exp eq 'procedure then
<<
    % Store subprogram name & parameters in symbol table %
    symtabput(cadr exp, '!*params!*, car cddddr exp);

    % Store subprogram type and parameters types in symbol table
    % if !*getdecs switch is on.  Use default type unless
    % procedure is declared as either:
    % INTEGER PROCEDURE ...    or    REAL PROCEDURE ...
    if !*getdecs then
            if caddr exp memq '(real integer) then
        <<
                symtabput(cadr exp,cadr exp,list caddr exp);
                for each v in car cddddr exp do
                        symtabput(cadr exp,v,list caddr exp);
                list nconc(list ('procedure,cadr exp,'nil),
                           for each e in cdddr exp conc preproc1 e)
        >>
        else
        <<
                for each v in car cddddr exp do
                        symtabput(cadr exp,v,list deftype!*);
                    list for each e in exp
                             conc preproc1 e
        >>
    else
                 list for each e in exp
                         conc preproc1 e


>>
else if car exp eq 'declare then
<<
    % Store type declarations in symbol table %
    exp := car preproc1 cdr exp;
    exp := preprocdec exp;
    for each dec in exp do
        for each var in cdr dec do
            if car dec memq '(subroutine function) then
                symtabput(var, '!*type!*, car dec)
            else
                symtabput(nil,
                          if atom var then var else car var,
                          if atom var then list car dec
                                      else (car dec . cdr var));
    nil
>>
else if car exp eq 'setq and pairp caddr exp and
  memq(caaddr exp,'(cond progn) ) then
    migrate!-setqs exp
else if memq(car exp, '(plus times difference quotient minus) ) then
begin scalar simp_exp;
  return if pairp numr (simp_exp:=simp!* exp)
            and memq(car numr simp_exp,'(!:cr!: !:crn!: !:gi!:)) then
    if onep denr simp_exp then
      list numr simp_exp
    else
      list list('quotient,numr simp_exp,
                car preproc1 prepsq !*f2q denr simp_exp)
  else
    list for each e in exp conc preproc1 e;
end
else
<<
% The next statement stores the index of a for loop in the symbol
% table, assigning them the type integer,
% if the switch 'getdecs' is on.
        if !*getdecs and (car exp memq '(!~FOR for)) then
                        symtabput(nil,cadr exp, '(integer));
            list for each e in exp
             conc preproc1 e
>>$


symbolic procedure preprocdec arg;
% (TIMES type int) --> type!*int     %
% (IMPLICIT type) --> IMPLICIT! type %
% (DIFFERENCE v1 v2) --> v1!-v2      %
if atom arg then
    arg
else if car arg eq 'times then
  if equal(length arg,3) and fixp(caddr arg) then
    intern
         compress
            append( append( explode cadr arg, explode '!* ),
                    explode caddr arg )
  else
  begin scalar result;
    for i:=1:length(arg) do
        result := append(result,
          if equal(nth(arg,i),'times)
             then '(!*)
             else explode nth(arg,i));
        return intern compress result;
  end
else if car arg eq 'implicit then
    intern
        compress
            append( explode 'implicit! , explode preprocdec cadr arg )
else if car arg eq 'difference then
    intern
        compress
            append( append( explode cadr arg, explode '!- ),
                    explode caddr arg )
else
    for each a in arg collect
        preprocdec a$


symbolic procedure migrate!-setqs exp;
% Move setq's within a progn or cond so that we can translate things
% like gentran x := if ... then ...
list migrate!-setqs1(cadr exp,caddr exp)$

symbolic procedure migrate!-setqs1(var,exp);
if atom exp then
    preproc list('setq,var,exp)
else if eqcar(exp,'cond) then
    ('cond . for each u in cdr exp collect
        list (preproc car u,migrate!-setqs1(var,cadr u)) )
else if eqcar(exp,'progn) then
    reverse rplaca(exp := reverse exp,migrate!-setqs1(var,car exp))
else
    preproc list('setq,var,exp)$


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/gentran/segmnt.red0000644000175000017500000003607711526203062024150 0ustar  giovannigiovannimodule segmnt;    %%  Segmentation Module  %%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%

% Entry points:  Seg, MARKEDVARP, MARKVAR, TEMPVAR, UNMARKVAR


symbolic$

% User-Accessible Global Variables %
global '(gentranlang!* maxexpprintlen!* tempvarname!* tempvarnum!*
         tempvartype!*)$
share gentranlang!*, maxexpprintlen!*, tempvarname!*, tempvarnum!*,
      tempvartype!*$
maxexpprintlen!* := 800$
tempvarname!*    := 't$
tempvarnum!*     := 0$
tempvartype!*    := nil$

% User-Accessible Primitive Functions %
operator markedvarp, markvar, tempvar, unmarkvar$

global '(!*do!* !*for!*)$


%%                       %%
%% Segmentation Routines %%
%%                       %%


procedure seg forms;
% exp --+--> exp                                          %
%       +--> (assign    assign    ... assign      exp   ) %
%                   (1)       (2)           (n-1)    (n)  %
% stmt --+--> stmt                                        %
%        +--> stmtgp                                      %
% stmtgp --> stmtgp                                       %
% def --> def                                             %
for each f in forms collect
    if lispexpp f then
        if toolongexpp f then
            segexp(f, 'unknown)
        else
            f
    else if lispstmtp f then
        segstmt f
    else if lispstmtgpp f then
        if toolongstmtgpp f then
            seggroup f
        else
            f
    else if lispdefp f then
        if toolongdefp f then
            segdef f
        else
            f
    else
        f$


procedure segexp(exp, type);
% exp --> (assign    assign    ... assign      exp   ) %
%                (1)       (2)           (n-1)    (n)  %
reverse segexp1(exp, type)$

procedure segexp1(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar res;
res := segexp2(exp, type);
unmarkvar res;
if car res = cadadr res then
<<
    res := cdr res;
    rplaca(res, caddar res)
>>;
return res
end$

procedure segexp2(exp, type);
% exp --> (exp    assign      assign      ... assign   ) %
%             (n)       (n-1)       (n-2)           (1)  %
begin
scalar expn, assigns, newassigns, unops, op, termlist, var, tmp;
expn := exp;
while length expn=2 do
<<  unops := car expn . unops;  expn := cadr expn  >>;
op := car expn;
for each term in cdr expn do
<<
    if toolongexpp term then
    <<
        tmp := segexp2(term, type);
        term := car tmp;
        newassigns := cdr tmp
    >>
    else
        newassigns := '();
    if toolongexpp (op . term . termlist) and
       termlist and
       (length termlist > 1 or pairp car termlist) then
        <<
            unmarkvar termlist;
            var := var or tempvar type;
            markvar var;
            assigns := mkassign(var, if onep length termlist
                                        then car termlist
                                        else op . termlist) . assigns;
            termlist := list(var, term)
        >>
        else
            termlist := append(termlist, list term);
        assigns := append(newassigns, assigns)
>>;
expn := if onep length termlist
           then car termlist
           else op . termlist;
while unops do
<<  expn := list(car unops, expn);  unops := cdr unops  >>;
if expn = exp then
<<
    unmarkvar expn;
    var := var or tempvar type;
    markvar var;
    assigns := list mkassign(var, expn);
    expn := var
>>;
return expn . assigns
end$


procedure segstmt stmt;
% assign --+--> assign %
%          +--> stmtgp %
% cond --+--> cond     %
%        +--> stmtgp   %
% while --+--> while   %
%         +--> stmtgp  %
% repeat --> repeat    %
% for --+--> for       %
%       +--> stmtgp    %
% return --+--> return %
%          +--> stmtgp %
if lispassignp stmt then
    if toolongassignp stmt then
        segassign stmt
    else
        stmt
else if lispcondp stmt then
    if toolongcondp stmt then
        segcond stmt
    else
        stmt
else if lispwhilep stmt then
    if toolongwhilep stmt then
        segwhile stmt
    else
        stmt
else if lisprepeatp stmt then
    if toolongrepeatp stmt then
        segrepeat stmt
    else
        stmt
else if lispforp stmt then
    if toolongforp stmt then
        segfor stmt
    else
        stmt
else if lispreturnp stmt then
    if toolongreturnp stmt then
        segreturn stmt
    else
        stmt
else
    stmt$


procedure segassign stmt;
% assign --> stmtgp %
begin
scalar var, exp, type;
var := cadr stmt;
type := getvartype var;
exp := caddr stmt;
stmt := segexp1(exp, type);
rplaca(stmt, mkassign(var, car stmt));
return mkstmtgp(nil, reverse stmt)
end$

procedure segcond condd;
% cond --+--> cond   %
%        +--> stmtgp %
begin
scalar tassigns, res, markedvars, type;
%if gentranlang!* eq 'c
%    then type := 'int
%    else type := 'logical;
type:=get(gentranlang!*,'boolean!-type) or get('fortran,'boolean!-type);
while condd := cdr condd do
    begin
    scalar exp, stmt;
    if toolongexpp(exp := caar condd) then
    <<
        exp := segexp1(exp, type);
        tassigns := append(cdr exp, tassigns);
        exp := car exp;
        markvar exp;
        markedvars := exp . markedvars
    >>;
    stmt := for each st in cdar condd conc seg list st;
    res := (exp . stmt) . res
    end;
unmarkvar markedvars;
return
    if tassigns then
        mkstmtgp(nil, reverse(mkcond reverse res . tassigns))
    else
        mkcond reverse res
end$

procedure segwhile stmt;
% while --+--> while  %
%         +--> stmtgp %
begin
scalar logexp, stmtlst, tassigns, type, res;
logexp := cadr stmt;
stmtlst := cddr stmt;
if toolongexpp logexp then
<<
    type:=get(gentranlang!*,'boolean!-type)
          or get('fortran,'boolean!-type);
%    if gentranlang!* eq 'c
%       then type := 'int
%       else type := 'logical;
    tassigns := segexp1(logexp, type);
    logexp := car tassigns;
    tassigns := cdr tassigns
>>;
stmtlst := foreach st in stmtlst
                   conc seg list st;
res := 'while . logexp . stmtlst;
if tassigns then
<<
    res := append(res, reverse tassigns);
    res := 'progn . append(reverse tassigns, list res)
>>;
return res
end$

procedure segrepeat stmt;
% repeat --> repeat %
begin
scalar stmtlst, logexp, type;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
stmtlst := foreach st in stmtlst conc seg list st;
if toolongexpp logexp then
<<
    type:=get(gentranlang!*,'boolean!-type)
          or get('fortran,'boolean!-type);
%    if gentranlang!* eq 'c
%       then type := 'int
%       else type := 'logical;
    logexp := segexp1(logexp, type);
    stmtlst := append(stmtlst, reverse cdr logexp);
    logexp := car logexp
>>;
return 'repeat . append(stmtlst, list logexp)
end$

procedure segfor stmt;
% for --+--> for    %
%       +--> stmtgp %
begin
scalar var, loexp, stepexp, hiexp, stmtlst, tassigns1, tassigns2, type,
       markedvars, res;
var := cadr stmt;
type := getvartype var;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
if toolongexpp loexp then
<<
    loexp := segexp1(loexp, type);
    tassigns1 := reverse cdr loexp;
    loexp := car loexp;
    markvar loexp;
    markedvars := loexp . markedvars
>>;
if toolongexpp stepexp then
<<
    stepexp := segexp1(stepexp, type);
    tassigns2 := reverse cdr stepexp;
    stepexp := car stepexp;
    markvar stepexp;
    markedvars := stepexp . markedvars
>>;
if toolongexpp hiexp then
<<
    hiexp := segexp1(hiexp, type);
    tassigns1 := append(tassigns1, reverse cdr hiexp);
    tassigns2 := append(tassigns2, reverse cdr hiexp);
    hiexp := car hiexp
>>;
unmarkvar markedvars;
stmtlst := foreach st in stmtlst conc seg list st;
stmtlst := append(stmtlst, tassigns2);
res := !*for!* . var . list(loexp, stepexp, hiexp) . !*do!* . stmtlst;
if tassigns1 then
    return mkstmtgp(nil, append(tassigns1, list res))
else
    return res
end$

procedure segreturn ret;
% return --> stmtgp %
<<
    ret := segexp1(cadr ret, 'unknown);
    rplaca(ret, mkreturn car ret);
    mkstmtgp(nil, reverse ret)
>>$

procedure seggroup stmtgp;
% stmtgp --> stmtgp %
begin
scalar locvars, res;
if car stmtgp eq 'prog then
<<
    locvars := cadr stmtgp;
    stmtgp := cdr stmtgp
>>
else
    locvars := 0;
while stmtgp := cdr stmtgp do
    res := append(seg list car stmtgp, res);
return mkstmtgp(locvars, reverse res)
end$

procedure segdef deff;
% def --> def %
mkdef(cadr deff, caddr deff,
      for each stmt in cdddr deff conc seg list stmt)$


%%                                        %%
%% Long Statement & Expression Predicates %%
%%                                        %%


procedure toolongexpp exp;
numprintlen exp > maxexpprintlen!*$

procedure toolongstmtp stmt;
if atom stmt then nil else
if lispstmtp stmt then
    if lispcondp stmt then
        toolongcondp stmt
    else if lispassignp stmt then
        toolongassignp stmt
    else if lispreturnp stmt then
        toolongreturnp stmt
    else if lispwhilep stmt then
        toolongwhilep stmt
    else if lisprepeatp stmt then
        toolongrepeatp stmt
    else if lispforp stmt then
        toolongforp stmt
    else lispeval('or . for each exp in stmt collect toolongexpp exp)
else
    toolongstmtgpp stmt$

procedure toolongassignp assign;
toolongexpp caddr assign$

procedure toolongcondp condd;
begin
scalar toolong;
while condd := cdr condd do
    if toolongexpp caar condd or toolongstmtp cadar condd then
        toolong := t;
return toolong
end$

procedure toolongwhilep stmt;
   toolongexpp cadr stmt or
      lispeval('or . foreach st in cddr stmt collect toolongstmtp st)$

procedure toolongrepeatp stmt;
<<
    stmt := reverse cdr stmt;
    toolongexpp car stmt or
    lispeval('or . foreach st in cdr stmt collect toolongstmtp st)
>>$

procedure toolongforp stmt;
lispeval('or . foreach exp in caddr stmt collect
                   toolongexpp exp          ) or
lispeval('or . foreach st in cddddr stmt collect
                   toolongstmtp st          )$

procedure toolongreturnp ret;
cdr ret and toolongexpp cadr ret$

procedure toolongstmtgpp stmtgp;
lispeval('or . for each stmt in cdr stmtgp collect
               toolongstmtp stmt              )$

procedure toolongdefp deff;
if lispstmtgpp cadddr deff then
    toolongstmtgpp cadddr deff
else
    lispeval('or .
             for each stmt in cdddr deff collect toolongstmtp stmt)$


%%                       %%
%% Print Length Function %%
%%                       %%

symbolic procedure numprintlen exp;
if atom exp then
    length explode exp
else if onep length exp then
    numprintlen car exp
else if car exp = '!:rd!: then
%     2+length explode cadr exp + length explode cddr exp
%else if car exp memq '( !:cr!: !:crn!: !:gi!: ) then
%     8+length explode cadr exp + length explode cddr exp
<<
     exp := rd!:explode exp;
     2+length car exp + length explode cadr exp
>>
else if car exp memq '( !:cr!: !:crn!: !:gi!: ) then
<<
    exp := cons (rd!:explode('!:rd!: . cadr exp),
                 rd!:explode('!:rd!: . cddr exp));
    12 + length caar exp + length explode cdar exp
       + length cadr exp + length explode cddr exp
>>
else
    length exp + lispeval('plus . for each elt in cdr exp collect
                                numprintlen elt              )$


%%                                                              %%
%% Temporary Variable Generation, Marking & Unmarking Functions %%
%%                                                              %%


procedure tempvar type;
%                                                             %
%  IF type Member '(NIL 0) THEN type <- TEMPVARTYPE!*         %
%                                                             %
%  IF type Neq 'NIL And type Neq 'UNKNOWN THEN                %
%    var <- 1st unmarked tvar of VType type or of VType NIL   %
%           which isn't in the symbol table                   %
%    put type on var's VType property list                    %
%    put declaration in symbol table                          %
%  ELSE IF type = NIL THEN                                    %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%  ELSE type = 'UNKNOWN                                       %
%    var <- 1st unmarked tvar of type NIL which isn't in the  %
%           symbol table                                      %
%    put 'UNKNOWN on var's VType property list                %
%    print warning - "undeclared"                             %
%                                                             %
%  RETURN var                                                 %
%                                                             %
begin
scalar tvar, xname, num;
if type memq '(nil 0) then type := tempvartype!*;
xname := explode tempvarname!*;
num := tempvarnum!*;
if type memq '(nil unknown) then
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and not get(tvar, '!*vtype!*) and
          not getvartype tvar
else
    repeat
    <<
        tvar := intern compress append(xname, explode num);
        num := add1 num
    >>
    until not markedvarp tvar and
          (get(tvar, '!*vtype!*) eq type or
           not get(tvar, '!*vtype!*) and not getvartype tvar);
put(tvar, '!*vtype!*, type);
if type eq 'unknown then
    gentranerr('w, tvar, "UNDECLARED VARIABLE", nil)
else if type then
    symtabput(nil, tvar, list type);
return tvar
end$


symbolic procedure isnumber u;
numberp(u) or (pairp(u) and memq(car u,domainlist!*) )$

symbolic procedure markvar var;
if isnumber var then
    var
else if atom var then
<<  flag(list var, '!*marked!*);  var  >>
else
<<  for each v in var do markvar v;  var  >>$

symbolic procedure markedvarp var;
flagp(var, '!*marked!*)$

symbolic procedure unmarkvar var;
if isnumber var then
    var
else if atom var then
    remflag(list var, '!*marked!*)
else
    foreach elt in var do
        unmarkvar elt$


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/0000755000175000017500000000000011722677360022413 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symchrep.red0000644000175000017500000001706111526203062024730 0ustar  giovannigiovannimodule symchrep;
%
% Symmetry Package
%
% Author : Karin Gatermann
%         Konrad-Zuse-Zentrum fuer
%         Informationstechnik Berlin
%         Heilbronner Str. 10
%         W-1000 Berlin 31
%         Germany
%         Email: Gatermann@sc.ZIB-Berlin.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% symchrep.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  functions for representations in iternal structure
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure mk!_internal(representation);
% transfers the user given representation structure to the
% internal structure
begin
scalar group,elems,generators,repgenerators,g,res;
  group:=get!_group!_out(representation);
  elems:=get!*elements(group);
  generators:=get!*generators(group);
  repgenerators:=mk!_rep!_relation(representation,generators);
  if not(hard!_representation!_check!_p(group,repgenerators)) then
      rederr("this is no representation");
  res:=for each g in elems collect
       list(g,
           mk!_rep!_mat(
                 get!*elem!*in!*generators(group,g),
                 repgenerators)
           );
  return append(list(group),res);
end;

symbolic procedure hard!_representation!_check!_p(group,repgenerators);
% repgenerators -- ((g1,matg1),(g2,matg2),...)
begin
scalar checkp;
  checkp:=t;
  for each relation in get!*generator!*relations(group) do
    if not(relation!_check!_p(relation,repgenerators)) then
        checkp:=nil;
  return checkp;
end;

symbolic procedure relation!_check!_p(relation,repgenerators);
begin
scalar mat1,mat2;
  mat1:=mk!_relation!_mat(car relation, repgenerators);
  mat2:=mk!_relation!_mat(cadr relation, repgenerators);
  return equal!+matrices!+p(mat1,mat2);
end;

symbolic procedure mk!_relation!_mat(relationpart,repgenerators);
begin
scalar mat1,g;
   mat1:=mk!+unit!+mat(get!+row!+nr(cadr car repgenerators));
   for each g in relationpart do
     mat1:=mk!+mat!+mult!+mat(mat1,get!_mat(g,repgenerators));
  return mat1;
end;

symbolic procedure get!_mat(elem,repgenerators);
begin
scalar found,res;
  if elem='id then
    return mk!+unit!+mat(get!+row!+nr(cadr car repgenerators));
  found:=nil;
  while ((length(repgenerators)>0) and (null found)) do
    <<
       if elem = caar repgenerators then
         <<
           res:=cadr car repgenerators;
           found := t;
         >>;
       repgenerators:=cdr repgenerators;
    >>;
  if found then return res else
       rederr("error in get_mat");
end;

symbolic procedure mk!_rep!_mat(generatorl,repgenerators);
% returns the representation matrix (internal structure)
% of a group element represented in generatorl
begin
scalar mat1;
   mat1:=mk!+unit!+mat(get!+row!+nr(cadr(car(repgenerators))));
   for each generator in generatorl do
     mat1:=mk!+mat!+mult!+mat(mat1,
                              get!_rep!_of!_generator(
                                generator,repgenerators)
                             );
   return mat1;
end;

symbolic procedure get!_rep!_of!_generator(generator,repgenerators);
% returns the representation matrix (internal structure)
% of the generator
begin
 scalar found,mate,ll;
  if (generator='id) then return mk!+unit!+mat(
                  get!+row!+nr(cadr(car(repgenerators))));
   found:=nil;
   ll:=repgenerators;
   while (not(found) and (length(ll)>0)) do
      <<
        if (caar(ll)=generator) then
           <<
              found:=t;
              mate:=cadr(car(ll));
           >>;
         ll:=cdr ll;
      >>;
  if found then return mate else
    rederr(" error in get rep of generators");
end;

symbolic procedure get!_group!_in(representation);
% returns the group of the internal data structure representation
begin
  return car representation;
end;

symbolic procedure eli!_group!_in(representation);
% returns the internal data structure representation without group
begin
  return cdr representation;
end;

symbolic procedure get!_rep!_matrix!_in(elem,representation);
% returns the matrix of the internal data structure representation
begin
scalar found,mate,replist;
   found:=nil;
   replist:=cdr representation;
   while (null(found) and length(replist)>0) do
     <<
       if ((caar(replist)) = elem) then
             <<
                mate:=cadr(car (replist));
                found:=t;
             >>;
       replist:=cdr replist;
     >>;
  if found then return mate else
       rederr("error in get representation matrix");
end;

symbolic procedure get!_dimension!_in(representation);
% returns the dimension of the representation (internal data structure)
% output is an integer
begin
   return change!+sq!+to!+int(mk!+trace(get!_rep!_matrix!_in('id,
      representation)));
end;

symbolic procedure get!_rep!_matrix!_entry(representation,elem,z,s);
% get a special value of the matrix representation of group
% get the matrix of this representatiuon corresponding
% to the element elem
% returns the matrix element of row z and column s
begin
  return get!+mat!+entry(
           get!_rep!_matrix!_in(elem,representation),
            z,s) ;
end;

symbolic procedure mk!_resimp!_rep(representation);
begin
scalar group,elem,res;
  group:=get!_group!_in(representation);
  res:=for each elem in get!*elements(group) collect
 list(elem,mk!+resimp!+mat(get!_rep!_matrix!_in(elem,representation)));
  return append(list(group),res);
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  functions for characters in iternal structure
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure get!_char!_group(char1);
% returns the group of the internal data structure character
begin
  return car char1;
end;

symbolic procedure get!_char!_dim(char1);
% returns the dimension of the internal data structure character
% output is an integer
begin
   return change!+sq!+to!+int(get!_char!_value(char1,'id));
end;

symbolic procedure get!_char!_value(char1,elem);
% returns the value of an element
% of the internal data structure character
begin
scalar found,value,charlist;
   found:=nil;
   charlist:=cdr char1;
   while (null(found) and length(charlist)>0) do
     <<
       if ((caar(charlist)) = elem) then
             <<
                value:=cadr(car (charlist));
                found:=t;
             >>;
       charlist := cdr charlist;
     >>;
  if found then return value else
       rederr("error in get character element");
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symatvec.red0000644000175000017500000004525611526203062024740 0ustar  giovannigiovannimodule symatvec;

% Symmetry

% Author : Karin Gatermann
%         Konrad-Zuse-Zentrum fuer
%         Informationstechnik Berlin
%         Heilbronner Str. 10
%         W-1000 Berlin 31
%         Germany
%         Email: Gatermann@sc.ZIB-Berlin.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% symatvec.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  functions for matrix vector operations
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure gen!+can!+bas(dimension);
% returns the canonical basis of R^dimension as a vector list
begin
scalar eins,nullsq,i,j,ll;
   eins:=(1 ./ 1);
   nullsq:=(nil ./ 1);
   ll:= for i:=1:dimension collect
           for j:=1:dimension collect
              if i=j then eins else nullsq;
   return ll;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  matrix functions
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure alg!+matrix!+p(mat1);
% returns true if the matrix is a matrix from algebraic level
begin
scalar len,elem;
  if length(mat1)<1 then rederr("should be a matrix");
  if not(car (mat1) = 'mat) then rederr("should be a matrix");
  mat1:=cdr mat1;
  if length(mat1)<1 then rederr("should be a matrix");
  len:=length(car mat1);
  for each elem in cdr mat1 do
    if not(length(elem)=len) then rederr("should be a matrix");
  return t;
end;

symbolic procedure matrix!+p(mat1);
% returns true if the matrix is a matrix in internal structure
begin
scalar dimension,z,res;
  if length(mat1)<1 then return nil;
  dimension:=length(car mat1);
  res:=t;
  for each z in cdr mat1 do
    if not(dimension = length(z)) then res:=nil;
  return res;
end;

symbolic procedure squared!+matrix!+p(mat1);
% returns true if the matrix is a matrix in internal structure
begin
  if (matrix!+p(mat1) and (get!+row!+nr(mat1) = get!+col!+nr(mat1)))
      then return t;
end;

symbolic procedure equal!+matrices!+p(mat1,mat2);
% returns true if the matrices are equal ( internal structure)
begin
scalar s,z,helpp,mathelp,sum,rulesum,rule1,rule2;
   if (same!+dim!+squared!+p(mat1,mat2)) then
       <<
           mathelp:=
             mk!+mat!+plus!+mat(mat1,
                 mk!+scal!+mult!+mat((-1 ./ 1),mat2));
           sum:=(nil ./ 1);
           for each z in mathelp do
                for each s in z do
                  if !*complex then
                     sum:=addsq(sum,multsq(s,mk!+conjugate!+sq s)) else
                     sum:=addsq(sum,multsq(s,s));
      %      print!-sq(sum);
      rulesum:=change!+sq!+to!+algnull(sum);
      if rulesum = 0 then helpp:=t else helpp:=nil;
 %     print!-sq(simp rulesum);
%           if null(numr(simp prepsq(sum))) then helpp:=t
% else helpp:=nil;
       >> else helpp:=nil;
   return helpp;
end;

symbolic procedure get!+row!+nr(mat1);
% returns the number of rows
begin
   return length(mat1);
end;

symbolic procedure get!+col!+nr(mat1);
% returns the number of columns
begin
   return length(car mat1);
end;

symbolic procedure get!+mat!+entry(mat1,z,s);
% returns the matrix element in row z and column s
begin
   return nth(nth(mat1,z),s);
end;

symbolic procedure same!+dim!+squared!+p(mat1,mat2);
% returns true if the matrices are both squared matrices
% of the same dimension
% (internal structur)
begin
  if (squared!+matrix!+p(mat1) and squared!+matrix!+p(mat2) and
       (get!+row!+nr(mat1) = get!+row!+nr(mat1)))
          then return t;
end;

symbolic procedure mk!+transpose!+matrix(mat1);
% returns the transposed matrix (internal structure)
begin
scalar z,s,tpmat1;
  if not(matrix!+p(mat1)) then rederr("no matrix in transpose");
  tpmat1:=for z:=1:get!+col!+nr(mat1) collect
           for s:=1:get!+row!+nr(mat1) collect
                get!+mat!+entry(mat1,s,z);
  return tpmat1
end;

symbolic procedure mk!+conjugate!+matrix(mat1);
% returns the matrix with conjugate elements (internal structure)
begin
scalar z,s,tpmat1;
  if not(matrix!+p(mat1)) then rederr("no matrix in conjugate matrix");
  tpmat1:=for z:=1:get!+row!+nr(mat1) collect
           for s:=1:get!+col!+nr(mat1) collect
              mk!+conjugate!+sq(get!+mat!+entry(mat1,z,s));
  return tpmat1
end;

symbolic procedure mk!+hermitean!+matrix(mat1);
% returns the transposed matrix (internal structure)
begin
   if !*complex then
   return mk!+conjugate!+matrix(mk!+transpose!+matrix(mat1)) else
   return mk!+transpose!+matrix(mat1);
end;

symbolic procedure unitarian!+p(mat1);
% returns true if matrix is orthogonal or unitarian resp.
begin
scalar mathermit,unitmat1;
  mathermit:=mk!+mat!+mult!+mat(mk!+hermitean!+matrix(mat1),mat1);
  unitmat1:=mk!+unit!+mat(get!+row!+nr(mat1));
  if equal!+matrices!+p(mathermit,unitmat1) then return t;
end;

symbolic procedure mk!+mat!+mult!+mat(mat1,mat2);
% returns a matrix= matrix1*matrix2 (internal structure)
begin
scalar dims1,dimz1,dims2,s,z,res,sum,k;
  if not(matrix!+p(mat1)) then rederr("no matrix in mult");
  if not(matrix!+p(mat2)) then rederr("no matrix in mult");
  dims1:=get!+col!+nr(mat1);
  dimz1:=get!+row!+nr(mat1);
  dims2:=get!+col!+nr( mat2);
  if not(dims1 = get!+row!+nr(mat2)) then
     rederr("matrices can not be multiplied");
  res:=for z:=1:dimz1 collect
         for s:=1:dims2 collect
           <<
              sum:=(nil ./ 1);
              for k:=1:dims1 do
               sum:=addsq(sum,
                      multsq(
                       get!+mat!+entry(mat1,z,k),
                       get!+mat!+entry(mat2,k,s)
                             )
                          );
              sum:=subs2 sum where !*sub2=t;
              sum
           >>;
   return res;
end;

symbolic procedure mk!+mat!+plus!+mat(mat1,mat2);
% returns a matrix= matrix1 + matrix2 (internal structure)
begin
scalar dims,dimz,s,z,res,sum;
  if not(matrix!+p(mat1)) then rederr("no matrix in add");
  if not(matrix!+p(mat2)) then rederr("no matrix in add");
  dims:=get!+col!+nr(mat1);
  dimz:=get!+row!+nr(mat1);
  if not(dims = get!+col!+nr(mat2)) then
          rederr("wrong dimensions in add");
  if not(dimz = get!+row!+nr(mat2)) then
          rederr("wrong dimensions in add");
  res:=for z:=1:dimz collect
          for s:=1:dims collect
           <<
            sum:=addsq(
                   get!+mat!+entry(mat1,z,s),
                   get!+mat!+entry(mat2,z,s)
                 );
              sum:=subs2 sum where !*sub2=t;
              sum
           >>;
  return res;
end;

symbolic procedure mk!+mat!*mat!*mat(mat1,mat2,mat3);
% returns a matrix= matrix1*matrix2*matrix3 (internal structure)
begin
scalar res;
  res:= mk!+mat!+mult!+mat(mat1,mat2);
  return mk!+mat!+mult!+mat(res,mat3);
end;

symbolic procedure add!+two!+mats(mat1,mat2);
% returns a matrix=( matrix1, matrix2 )(internal structure)
begin
scalar dimz,z,res;
  if not(matrix!+p(mat1)) then rederr("no matrix in add");
  if not(matrix!+p(mat2)) then rederr("no matrix in add");
  dimz:=get!+row!+nr(mat1);
  if not(dimz = get!+row!+nr(mat2)) then rederr("wrong dim in add");
  res:=for z:=1:dimz collect
      append(nth(mat1,z),nth(mat2,z));
  return res;
end;

symbolic procedure mk!+scal!+mult!+mat(scal1,mat1);
% returns a matrix= scalar*matrix (internal structure)
begin
scalar res,z,s,prod;
  if not(matrix!+p(mat1)) then rederr("no matrix in add");
  res:=for each z in mat1 collect
         for each s in z collect
           <<
              prod:=multsq(scal1,s);
              prod:=subs2 prod where !*sub2=t;
              prod
           >>;
  return res;
end;

symbolic procedure mk!+trace(mat1);
% returns the trace of the matrix (internal structure)
begin
scalar spurx,s;
  if not(squared!+matrix!+p(mat1)) then
          rederr("no square matrix in add");
  spurx :=(nil ./ 1);
  for s:=1:get!+row!+nr(mat1) do
     spurx :=addsq(spurx,get!+mat!+entry(mat1,s,s));
   spurx :=subs2 spurx where !*sub2=t;
  return spurx
end;

symbolic procedure mk!+block!+diagonal!+mat(mats);
% returns a blockdiagonal matrix from
% a list of matrices (internal structure)
begin
  if length(mats)<1 then rederr("no list in mkdiagonalmats");
  if length(mats)=1 then return car mats else
     return fill!+zeros(car mats,mk!+block!+diagonal!+mat(cdr(mats)));
end;

symbolic procedure fill!+zeros(mat1,mat2);
% returns a blockdiagonal matrix from 2 matrices (internal structure)
begin
scalar nullmat1,nullmat2;
  nullmat1:=mk!+null!+mat(get!+row!+nr(mat2),get!+col!+nr(mat1));
  nullmat2:=mk!+null!+mat(get!+row!+nr(mat1),get!+col!+nr(mat2));
  return append(add!+two!+mats(mat1,nullmat2),
                    add!+two!+mats(nullmat1,mat2));
end;

symbolic procedure mk!+outer!+mat(innermat);
% returns a matrix for algebraic level
begin
 scalar res,s,z;
 if not(matrix!+p(innermat)) then rederr("no matrix in mkoutermat");
 res:= for each z in innermat collect
        for each s in z collect
            prepsq s;
 return append(list('mat),res);
end;

symbolic procedure mk!+inner!+mat(outermat);
% returns a matrix in internal structure
begin
   scalar res,s,z;
   res:= for each z in cdr outermat collect
          for each s in z collect
             simp s;
   if matrix!+p(res) then return res else
        rederr("incorrect input in mkinnermat");
end;

symbolic procedure mk!+resimp!+mat(innermat);
% returns a matrix in internal structure
begin
   scalar res,s,z;
   res:= for each z in innermat collect
          for each s in z collect
             resimp s;
   return res;
end;

symbolic procedure mk!+null!+mat(dimz,dims);
% returns a matrix of zeros in internal structure
begin
scalar nullsq,s,z,res;
   nullsq:=(nil ./ 1);
   res:=for z:=1:dimz collect
           for s:=1:dims collect  nullsq;
  return res;
end;

symbolic procedure mk!+unit!+mat(dimension);
% returns a squared unit matrix in internal structure
begin
   return gen!+can!+bas(dimension);
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  vector functions
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure vector!+p(vector1);
% returns the length of a vector
% vector -- list of sqs
begin
  if length(vector1)>0 then return t;
end;

symbolic procedure get!+vec!+dim(vector1);
% returns the length of a vector
% vector -- list of sqs
begin
  return length(vector1);
end;

symbolic procedure get!+vec!+entry(vector1,elem);
% returns the length of a vector
% vector -- list of sqs
begin
  return nth(vector1,elem);
end;

symbolic procedure mk!+mat!+mult!+vec(mat1,vector1);
% returns a vector= matrix*vector (internal structure)
begin
scalar z;
  return for each z in mat1 collect
           mk!+real!+inner!+product(z,vector1);
end;

symbolic procedure mk!+scal!+mult!+vec(scal1,vector1);
% returns a vector= scalar*vector (internal structure)
begin
scalar entry,res,h;
  res:=for each entry in vector1 collect
     <<
        h:=multsq(scal1,entry);
        h:=subs2 h where !*sub2=t;
        h
     >>;
  return res;
end;

symbolic procedure mk!+vec!+add!+vec(vector1,vector2);
% returns a vector= vector1+vector2 (internal structure)
begin
scalar ent,res,h;
  res:=for ent:=1:get!+vec!+dim(vector1) collect
       <<
         h:= addsq(get!+vec!+entry(vector1,ent),
                get!+vec!+entry(vector2,ent));
         h:=subs2 h where !*sub2=t;
         h
       >>;
  return res;
end;

symbolic procedure mk!+squared!+norm(vector1);
% returns a scalar= sum vector_i^2 (internal structure)
begin
   return mk!+inner!+product(vector1,vector1);
end;

symbolic procedure my!+nullsq!+p(scal);
% returns true, if ths sq is zero
begin
   if null(numr( scal)) then return t;
end;

symbolic procedure mk!+null!+vec(dimen);
% returns a vector of zeros
begin
scalar nullsq,i,res;
   nullsq:=(nil ./ 1);
   res:=for i:=1:dimen collect nullsq;
   return res;
end;

symbolic procedure mk!+conjugate!+vec(vector1);
% returns a vector of zeros
begin
scalar z,res;
   res:=for each z in vector1  collect mk!+conjugate!+sq(z);
   return res;
end;

symbolic procedure null!+vec!+p(vector1);
% returns a true, if vector is the zero vector
begin
    if my!+nullsq!+p(mk!+squared!+norm(vector1)) then
       return t;
end;

symbolic procedure mk!+normalize!+vector(vector1);
% returns a normalized vector (internal structure)
begin
scalar scalo,vecres;
  scalo:=simp!* {'sqrt, mk!*sq(mk!+squared!+norm(vector1))};
  if my!+nullsq!+p(scalo) then
     vecres:= mk!+null!+vec(get!+vec!+dim(vector1)) else
      <<
         scalo:=simp prepsq scalo;
         scalo:=quotsq((1 ./ 1),scalo);
         vecres:= mk!+scal!+mult!+vec(scalo,vector1);
      >>;
  return vecres;
end;

symbolic procedure mk!+inner!+product(vector1,vector2);
% returns the inner product of vector1 and vector2 (internal structure)
begin
scalar z,sum,vec2;
  if not(get!+vec!+dim(vector1) = get!+vec!+dim(vector2)) then
        rederr("wrong dimensions in innerproduct");
  sum:=(nil ./ 1);
  if !*complex then vec2:=mk!+conjugate!+vec(vector2) else
    vec2:=vector2;
  for z:=1:get!+vec!+dim(vector1) do
      sum:=addsq(sum,multsq(
            get!+vec!+entry(vector1,z),
            get!+vec!+entry(vec2,z)
                           )
                );
  sum:=subs2 sum where !*sub2=t;
  return sum;
end;

symbolic procedure mk!+real!+inner!+product(vector1,vector2);
% returns the inner product of vector1 and vector2 (internal structure)
begin
scalar z,sum;
  if not(get!+vec!+dim(vector1) = get!+vec!+dim(vector2)) then
        rederr("wrong dimensions in innerproduct");
  sum:=(nil ./ 1);
  for z:=1:get!+vec!+dim(vector1) do
      sum:=addsq(sum,multsq(
            get!+vec!+entry(vector1,z),
            get!+vec!+entry(vector2,z)
                           )
                );
  sum:=subs2 sum where !*sub2=t;
  return sum;
end;

symbolic procedure mk!+Gram!+Schmid(vectorlist,vector1);
% returns a vectorlist of orthonormal vectors
% assumptions: vectorlist is orthonormal basis, internal structure
begin
scalar i,orthovec,scalo,vectors1;
  orthovec:=vector1;
  for i:=1:(length(vectorlist)) do
     <<
       scalo:= negsq(mk!+inner!+product(orthovec,nth(vectorlist,i)));
       orthovec:=mk!+vec!+add!+vec(orthovec,
          mk!+scal!+mult!+vec(scalo,nth(vectorlist,i)));
     >>;
  orthovec:=mk!+normalize!+vector(orthovec);
  if null!+vec!+p(orthovec) then
     vectors1:=vectorlist else
     vectors1:=add!+vector!+to!+list(orthovec,vectorlist);
  return vectors1
end;

symbolic procedure Gram!+Schmid(vectorlist);
% returns a vectorlist of orthonormal vectors
begin
scalar ortholist,i;
  if length(vectorlist)<1 then rederr("error in Gram Schmid");
  if vector!+p(car vectorlist) then
      ortholist:=nil
        else rederr("strange in Gram-Schmid");
  for i:=1:length(vectorlist) do
        ortholist:=mk!+Gram!+Schmid(ortholist,nth(vectorlist,i));
  return ortholist;
end;

symbolic procedure add!+vector!+to!+list(vector1,vectorlist);
% returns a list of vectors consisting of vectorlist
% and the vector1 at the end
% internal structure
begin
    return append(vectorlist,list(vector1));
end;

symbolic procedure mk!+internal!+mat(vectorlist);
% returns a matrix consisting of columns
% equal to the vectors in vectorlist
% internal structure
begin
  return mk!+transpose!+matrix(vectorlist);
end;

symbolic procedure mat!+veclist(mat1);
% returns a vectorlist consisting of the columns of the matrix
% internal structure
begin
  return mk!+transpose!+matrix(mat1);
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% some useful functions
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure change!+sq!+to!+int(scal1);
% scal1 -- sq which is an integer
% result is a nonnegative integer
begin
  scalar nr;
  nr:=simp!* prepsq scal1;
  if (denr(nr) = 1) then return numr(nr) else
    rederr("no integer in change!+sq!+to!+int");
end;

symbolic procedure change!+int!+to!+sq(scal1);
% scal1 --  integer for example 1 oder 2 oder 3
% result is a sq
begin
  return (scal1 ./ 1);
end;

symbolic procedure change!+sq!+to!+algnull(scal1);
begin
scalar rulesum,storecomp;
           if !*complex then
              <<
                 storecomp:=t;
                 off complex;
              >> else
              <<
                 storecomp:=nil;
              >>;
          rulesum:=evalwhereexp ({'(list (list
 (REPLACEBY
   (COS (!~ X))
   (TIMES
      (QUOTIENT 1 2)
 (PLUS (EXPT E (TIMES I (!~ X))) (EXPT E (MINUS (TIMES I (!~ X))))) ))
 (REPLACEBY
   (SIN (!~ X))
   (TIMES
      (QUOTIENT 1 (times 2 i))
 (difference (EXPT E (TIMES I (!~ X)))
      (EXPT E (MINUS (TIMES I (!~ X))))) ))

))
, prepsq(scal1)});
  rulesum:=reval rulesum;
  if storecomp then on complex;
 % print!-sq(simp (rulesum));
  return rulesum;
end;

symbolic procedure mk!+conjugate!+sq(mysq);
begin
    return conjsq(mysq);
 %   return subsq(mysq,'(( i . (minus i))));
end;

symbolic procedure mk!+equation(arg1,arg2);
begin
  return list('equal,arg1,arg2);
end;

symbolic procedure outer!+equation!+p(outerlist);
begin
    if eqcar(outerlist, 'equal) then return t
end;

symbolic procedure mk!+outer!+list(innerlist);
begin
  return append (list('list),innerlist)
end;

symbolic procedure mk!+inner!+list(outerlist);
begin
   if outer!+list!+p(outerlist) then return cdr outerlist;
end;

symbolic procedure outer!+list!+p(outerlist);
begin
  if eqcar(outerlist, 'list) then return t
end;

symbolic procedure equal!+lists!+p(ll1,ll2);
begin
  return (list!+in!+list!+p(ll1,ll2) and list!+in!+list!+p(ll2,ll1));
end;

symbolic procedure list!+in!+list!+p(ll1,ll2);
begin
  if length(ll1)=0 then return t else
       return (memq(car ll1,ll2) and list!+in!+list!+p(cdr ll1,ll2));
end;

symbolic procedure print!-matrix(mat1);
begin
  writepri (mkquote mk!+outer!+mat(mat1),'only);
end;

symbolic procedure print!-sq(mysq);
begin
  writepri (mkquote prepsq(mysq),'only);
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symhandl.red0000644000175000017500000002510111526203062024707 0ustar  giovannigiovannimodule symhandl;
%
% Symmetry Package
%
% Author: Karin Gatermann
%         Konrad-Zuse-Zentrum fuer
%         Informationstechnik Berlin
%         Heilbronner Str. 10
%         W-1000 Berlin 31
%         Germany
%         Email: Gatermann@sc.ZIB-Berlin.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%  symhandl.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% functions to get the stored information of groups
% booleans first
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure available!*p(group);
% returns true, if the information
% concerning irreducible representations
% of the group are in this database
begin
   if not(idp(group)) then rederr("this is no group identifier");
   return flagp(group,'available);
end;

symbolic procedure storing!*p(group);
% returns true, if the information concerning generators
% and group elements
% of the group are in this database
begin
   return flagp(group,'storing);
end;

symbolic procedure g!*element!*p(group,element);
% returns true, if element is an element of the abstract group
begin
   if memq(element,get!*elements(group)) then return t else return nil;
end;

symbolic procedure g!*generater!*p(group,element);
% returns true, if element is a generator of the abstract group
begin
  if memq(element,get!*generators(group)) then return t else return nil;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% operators for abstract group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure get!*available!*groups;
% returns the available groups as a list
begin
  return get('availables,'groups);
end;

symbolic procedure get!*order(group);
% returns the order of group as integer
begin
  return length(get!*elements(group));
end;

symbolic procedure get!*elements(group);
% returns the abstract elements of group
% output list of identifiers
begin
scalar ll;
  return get(group,'elems);
end;

symbolic procedure get!*generators(group);
% returns a list abstract elements of group which generates the group
begin
   return get(group,'generators);
end;

symbolic procedure get!*generator!*relations(group);
% returns a list with relations
% which are satisfied for the generators of the group
begin
   return get(group,'relations);
end;

symbolic procedure get!*product(group,elem1,elem2);
% returns the element elem1*elem2  of  group
begin
scalar table,above,left;
    table:=get(group,'grouptable);
    above:= car table;
    left:=for each row in table collect car row;
    return get!+mat!+entry(table,
                give!*position(elem1,left),
                give!*position(elem2,above));
end;

symbolic procedure get!*inverse(group,elem);
% returns the inverse element of the element elem in group
% invlist = ((g1,g2,..),(inv1,inv2,...))
begin
scalar invlist;
    invlist:=get(group,'inverse);
    return nth(cadr invlist,give!*position(elem,car invlist));
end;

symbolic procedure give!*position(elem,ll);
begin
scalar j,found;
j:=1; found:=nil;
    while (null(found) and (j<=length(ll))) do
       <<
          if (nth(ll,j)=elem) then found:=t else j:=j+1;
       >>;
    if null(found) then rederr("error in give position");
    return j;
end;

symbolic procedure get!*elem!*in!*generators(group,elem);
% returns the element representated by the generators of group
begin
scalar ll,found,res;
    ll:=get(group,'elem!_in!_generators);
    if (elem='id) then return list('id);
    found:=nil;
    while (null(found) and (length(ll)>0)) do
      <<
         if (elem=caaar ll) then
           <<
              res:=cadr car ll;
              found:=t;
           >>;
          ll:=cdr ll;
      >>;
  if found then return res else
       rederr("error in get!*elem!*in!*generators");
end;

symbolic procedure get!*nr!*equi!*classes(group);
% returns the number of equivalence classes of group
begin
    return length(get(group,'equiclasses));
end;

symbolic procedure get!*equi!*class(group,elem);
% returns the equivalence class of the element elem  in  group
begin
scalar ll,equic,found;
    ll:=get(group,'equiclasses);
    found:=nil;
    while (null(found) and (length(ll)>0)) do
      <<
         if memq(elem,car ll) then
           <<
              equic:=car ll;
              found:=t;
           >>;
          ll:=cdr ll;
      >>;
  if found then return equic;
end;

symbolic procedure get!*all!*equi!*classes(group);
% returns the equivalence classes of the element elem  in  group
% list of lists of identifiers
begin
    return get(group,'equiclasses);
end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% functions to get information of real irred. representation of group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure get!*nr!*real!*irred!*reps(group);
% returns number of real irreducible representations of group
begin
  return get(group,'realrepnumber);
end;

symbolic procedure get!*real!*character(group,nr);
% returns the nr-th real character of the group group
begin
   return mk!_character(get!*real!*irreducible!*rep(group,nr));
end;

symbolic procedure get!*real!*comp!*chartype!*p(group,nr);
% returns true if the type of the real irreducible rep.
% of the group is complex
begin
  if eqcar( get(group,mkid('realrep,nr)) ,'complextype) then return t;
end;

symbolic procedure get!*real!*irreducible!*rep(group,nr);
% returns the real nr-th irreducible matrix representation of group
begin
  return mk!_resimp!_rep(append(list(group),
    cdr get(group,mkid('realrep,nr))));
end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% functions to get information of
%  complex irreducible representation of group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure get!*nr!*complex!*irred!*reps(group);
% returns number of complex irreducible representations of group
begin
  return get(group,'complexrepnumber);
end;

symbolic procedure get!*complex!*character(group,nr);
% returns the nr-th complex character of the group group
begin
   return mk!_character(get!*complex!*irreducible!*rep(group,nr));
end;

symbolic procedure get!*complex!*irreducible!*rep(group,nr);
% returns the complex nr-th irreduciblematrix representation of group
begin
  return mk!_resimp!_rep(append(list(group),
      get(group,mkid('complexrep,nr))));
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  set information upon group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure set!*group(group,equiclasses);
%
begin
  put(group,'equiclasses,equiclasses);
end;

symbolic procedure set!*elems!*group(group,elems);
%
begin
  put(group,'elems,elems);
end;

symbolic procedure set!*generators(group,generators);
%
begin
  put(group,'generators,generators);
end;

symbolic procedure set!*relations(group,relations);
%
begin
  put(group,'relations,relations);
end;

symbolic procedure set!*available(group);
begin
scalar grouplist;
  flag(list(group),'available);
  grouplist:=get('availables,'groups);
  grouplist:=append(grouplist,list(group));
  put('availables,'groups,grouplist);
end;

symbolic procedure set!*storing(group);
begin
  flag(list(group),'storing);
end;

symbolic procedure set!*grouptable(group,table);
%
begin
  put(group,'grouptable,table);
end;

symbolic procedure set!*inverse(group,invlist);
% stores the inverse element list in group
begin
  put(group,'inverse,invlist);
end;

symbolic procedure set!*elemasgen(group,glist);
%
begin
  put(group,'elem!_in!_generators,glist);
end;

symbolic procedure set!*representation(group,replist,type);
%
begin
scalar nr;
  nr:=get(group,mkid(type,'repnumber));
  if null(nr) then nr:=0;
  nr:=nr+1;
  put(group,mkid(mkid(type,'rep),nr),replist);
  set!*repnumber(group,type,nr);
end;

symbolic procedure set!*repnumber(group,type,nr);
%
begin
  put(group,mkid(type,'repnumber),nr);
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  functions to build information upon group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure mk!*inverse!*list(table);
% returns ((elem1,elem2,..),(inv1,inv2,..))
begin
scalar elemlist,invlist,elem,row,column;
  elemlist:=cdr(car (mk!+transpose!+matrix(table)));
  invlist:=for each elem in elemlist collect
    <<
      row:=give!*position(elem,elemlist);
      column:=give!*position('id,cdr nth(table,row+1));
      nth(cdr(car table),column)
    >>;
  return list(elemlist,invlist);
end;

symbolic procedure mk!*equiclasses(table);
% returns ((elem1,elem2,..),(inv1,inv2,..))
begin
scalar elemlist,restlist,s,r,tt,ts;
scalar rows,rowt,columnt,columnr,equiclasses,equic,firstrow;
  elemlist:=cdr(car (mk!+transpose!+matrix(table)));
  restlist:=elemlist;
  firstrow:=cdr car table;
  equiclasses:=nil;
  while (length(restlist)>0) do
     <<
        s:=car restlist;
        rows:=give!*position(s,elemlist);
        equic:=list(s);
        restlist:=cdr restlist;
        for each tt in elemlist do
         <<
           columnt:=give!*position(tt,firstrow);
           rowt:=give!*position(tt,elemlist);
           ts:=get!+mat!+entry(table,rows+1,columnt+1);
           columnr:=give!*position(ts,cdr nth(table,rowt+1));
           r:=nth(firstrow,columnr);
           equic:=union(equic,list(r));
           restlist:=delete(r,restlist);
         >>;
     equiclasses:=append(equiclasses,list(equic));
     >>;
  return equiclasses;
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symmetry.tst0000644000175000017500000000262611526203062025030 0ustar  giovannigiovanni% test symmetry package
% implementation of theory of linear representations
% for small groups 

availablegroups();

printgroup(D4);

generators(D4);

charactertable(D4);

characternr(D4,1);
characternr(D4,2);
characternr(D4,3);
characternr(D4,4);
characternr(D4,5);
irreduciblereptable(D4);
irreduciblerepnr(D4,1);
irreduciblerepnr(D4,2);
irreduciblerepnr(D4,3);
irreduciblerepnr(D4,4);
irreduciblerepnr(D4,5);


rr:=mat((1,0,0,0,0),
        (0,0,1,0,0),
        (0,0,0,1,0),
        (0,0,0,0,1),
        (0,1,0,0,0));

sp:=mat((1,0,0,0,0),
        (0,0,1,0,0),
        (0,1,0,0,0),
        (0,0,0,0,1),
        (0,0,0,1,0));

rep:={D4,rD4=rr,sD4=sp};

canonicaldecomposition(rep);

character(rep);

symmetrybasis(rep,1);
symmetrybasis(rep,2);
symmetrybasis(rep,3);
symmetrybasis(rep,4);
symmetrybasis(rep,5);
symmetrybasispart(rep,5);
allsymmetrybases(rep);


% Ritz matrix from Stiefel, Faessler p. 200
m:=mat((eps,a,a,a,a),
       (a  ,d,b,g,b),
       (a  ,b,d,b,g),
       (a  ,g,b,d,b),
       (a  ,b,g,b,d));


diagonalize(m,rep);

% eigenvalues are obvious. Eigenvectors may be obtained with
% the coordinate transformation matrix given by allsymmetrybases.

r1:=mat((0,1,0),
        (0,0,1),
        (1,0,0));

repC3:={C3,rC3=r1};

mC3:=mat((a,b,c),
         (c,a,b),
         (b,c,a));

diagonalize(mC3,repC3); 

% note difference between real and complex case

on complex;
diagonalize(mC3,repC3); 
off complex;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symmetry.tex0000644000175000017500000002015611526203062025014 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{A \REDUCE{} package for Symmetry}
\date{}
\author{Karin Gatermann\\
        Konrad-Zuse-Zentrum f\"ur Informationstechnik Berlin\\
        Takustrasse\ 7\\
        D--14195 Berlin--Dahlem\\
        Federal Republic of Germany\\
	E--mail: gatermann@zib.de}
\begin{document}
\maketitle
\index{SYMMETRY package}

This short note describes a package of \REDUCE{} procedures
that compute symmetry-adapted bases and block diagonal forms
of matrices which have the symmetry of a group.
The SYMMETRY package is the implementation
of the theory of linear representations
for small finite groups such as the dihedral groups.

\section{Introduction}

The exploitation of symmetry is a very important principle in mathematics,
physics and engineering sciences.
The aim of the SYMMETRY package is to give an easy access to the
underlying theory of linear representations for small groups. For
example the
dihedral groups $D_3,D_4,D_5,D_6$ are included.
For an introduction to the theory see {\sc Serre} \cite{Se77} or
{\sc Stiefel} and {\sc F\"assler} \cite{StFae79}.
For a given orthogonal (or unitarian) linear representation
\[
\vartheta : G\longrightarrow GL(K^n), \qquad K=R,C.
\]
the character $\psi\rightarrow K$, the
canonical decomposition or the bases of the isotypic
components are computed. A matrix $A$ having the symmetry of a linear
representation,e.g.
\[
\vartheta_t A = A \vartheta_t \quad \forall \, t\in G,
\]
is transformed to block diagonal form by a coordinate
transformation.
The dependence of the algorithm on the
field of real or complex numbers is controled by the switch {\tt complex}.
An example for this is given in the testfile {\em symmetry.tst}.

As the algorithm needs information concerning the irreducible representations
this information is stored for some groups (see the operators in Section 3).
It is assumed that only orthogonal (unitar) representations are given.

The package is loaded by

{\tt load symmetry;}

\section{Operators for linear representations}

First the data structure for a linear representation has to be explained.
{\em representation} is a list consisting of the group identifier and
equations which assign matrices to the generators of the group.

{\bf Example:}
\begin{verbatim}
   rr:=mat((0,1,0,0),
           (0,0,1,0),
           (0,0,0,1),
           (1,0,0,0));

   sp:=mat((0,1,0,0),
           (1,0,0,0),
           (0,0,0,1),
           (0,0,1,0));

   representation:={D4,rD4=rr,sD4=sp};
\end{verbatim}

For orthogonal (unitarian) representations the following operators
are available.

{\tt canonicaldecomposition(representation);}

returns an equation giving the canonical decomposition of the linear
representation.

{\tt character(representation);}

computes the character of the linear representation. The result is a list
of the group identifier and of lists consisting of a
list of group elements in one equivalence class and a real or complex number.

{\tt symmetrybasis(representation,nr);}

computes the basis of the isotypic component corresponding to the irreducible
representation of type nr. If the nr-th irreducible representation is
multidimensional, the basis is symmetry adapted. The output is a matrix.

{\tt symmetrybasispart(representation,nr);}

is similar as {\tt symmetrybasis}, but for multidimensional
irreducible representations only the first part of the
symmetry adapted basis is computed.

{\tt allsymmetrybases(representation);}

is similar as {\tt symmetrybasis} and {\tt symmetrybasispart},
but the bases of all
isotypic components are computed and thus a
complete coordinate transformation is returned.

{\tt diagonalize(matrix,representation);}

returns the block diagonal form of matrix which has the symmetry
of the given linear representation. Otherwise an error message occurs.

{\tt on complex;}

Of course the property of irreducibility depends on the field $K$ of
real or complex numbers. This is why the algorithm depends on $K$.
The type of computation is set by the switch {\em complex}.

\section{Display Operators}

In this section the operators are described which give access to the
stored information for a group.
First the operators for the abstract groups are given.
Then it is described how to get the irreducible representations
for a group.

{\tt availablegroups();}

returns the list of all groups for which the information such as
irreducible representations is stored. In the following {\tt group}
is always one of these group identifiers.

{\tt printgroup(group);}

returns the list of all group elements;

{\tt generators(group);}

returns a list of group elements which generates the group. For the
definition of a linear representation matrices for these generators
have to be defined.

{\tt charactertable(group);}

returns a list of the characters corresponding to the irreducible
representations of this group.

{\tt charactern(group,nr);}

returns the character corresponding to the nr-th irreducible representation
of this group as a list (see also {\tt character}).

{\tt irreduciblereptable(group);}

returns the list of irreducible representations of the group.

{\tt irreduciblerepnr(group,nr);}

returns an irreducible representation of the group. The output
is a list of the group identifier and equations
assigning the representation matrices to group elements.

\section{Storing a new group}

If the user wants to do computations for a group for which
information is not predefined,
the package SYMMETRY offers the possibility to supply information
for this group.

For this the following data structures are used.

{\bf elemlist} = list of identifiers.

{\bf relationlist}  = list of equations with identifiers and
operators $@$ and $**$.

{\bf grouptable} = matrix with the (1,1)-entry grouptable.

{\bf filename} = "myfilename.new".

\vspace{2cm}
The following operators have to be used in this order.

{\tt setgenerators(group,elemlist,relationlist);}

{\bf Example:}
\begin{verbatim}
   setgenerators(K4,{s1K4,s2K4},
     {s1K4^2=id,s2K4^2=id,s1K4@s2K4=s2K4@s1K4});
\end{verbatim}

{\bf setelements(group,relationlist);}

The group elements except the neutral element
are given as product of the defined
generators. The neutral element is always called {\tt id}.

{\bf Example:}
\begin{verbatim}
   setelements(K4,
        {s1K4=s1K4,s2K4=s2K4,rK4=s1K4@s2K4});
\end{verbatim}

{\bf setgrouptable(group,grouptable);}

installs the group table.

{\bf Example:}
\begin{verbatim}
   tab:=
    mat((grouptable,     id,    s1K4, s2K4, rK4),
        (id        ,     id,    s1K4, s2K4, rK4),
        (s1K4      ,    s1K4,     id,  rK4,s2K4),
        (s2K4      ,    s2K4,    rK4,   id,s1K4),
        (rK4       ,     rK4,   s2K4, s1K4,  id));

   setgrouptable(K4,tab);
\end{verbatim}

{\bf Rsetrepresentation(representation,type);}

is used to define the real irreducible representations of the group.
The variable {\tt type} is either {\em realtype} or {\em complextype}
which indicates the type of the real irreducible representation.

{\bf Example:}
\begin{verbatim}
   eins:=mat((1));
   mineins:=mat((-1));
   rep3:={K4,s1K4=eins,s2K4=mineins};
   Rsetrepresentation(rep3,realtype);
\end{verbatim}

{\bf Csetrepresentation(representation);}

This defines the complex irreducible representations.

{\bf setavailable(group);}

terminates the installation of the group203. It checks some properties of the
irreducible representations and makes the group available for the
operators in Sections 2 and 3.

{\bf storegroup(group,filename);}

writes the information concerning the group to the file with name
{\em filename}.

{\bf loadgroups(filename);}

loads a user defined group from the file {\em filename} into
the system.

\begin{thebibliography}{5}

\bibitem{JaKer81} G.\ James, A.\ Kerber: {\it Representation Theory
of the Symmetric Group.} Addison, Wesley (1981).

\bibitem{LuFal88} W.\ Ludwig, C.\ Falter: {\it Symmetries in Physics.}
Springer, Berlin, Heidelberg, New York (1988).

\bibitem{Se77} J.--P.\ Serre, {\it Linear Representations of Finite
Groups}. Springer, New~York (1977).

\bibitem{StFae79} E.\  Stiefel, A.\  F{\"a}ssler, {\it Gruppentheoretische
Methoden und ihre Anwendung}. Teubner, Stuttgart (1979).
(English translation to appear by Birkh\"auser (1992)).

\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symmetry.rlg0000644000175000017500000002125611527635055025016 0ustar  giovannigiovanniFri Feb 18 21:28:37 2011 run on win32

*** @ already defined as operator 
% test symmetry package
% implementation of theory of linear representations
% for small groups 

availablegroups();


{z2,k4,d3,d4,d5,d6,c3,c4,c5,c6,s4,a4}


printgroup(D4);


{id,rd4,rot2d4,rot3d4,sd4,srd4,sr2d4,sr3d4}


generators(D4);


{rd4,sd4}


charactertable(D4);


{{d4,{{id},1},{{rd4,rot3d4},1},{{rot2d4},1},{{sd4,sr2d4},1},{{sr3d4,srd4},1}},

 {d4,{{id},1},{{rd4,rot3d4},1},{{rot2d4},1},{{sd4,sr2d4},-1},{{sr3d4,srd4},-1}},

 {d4,{{id},1},{{rd4,rot3d4},-1},{{rot2d4},1},{{sd4,sr2d4},1},{{sr3d4,srd4},-1}},

 {d4,{{id},1},{{rd4,rot3d4},-1},{{rot2d4},1},{{sd4,sr2d4},-1},{{sr3d4,srd4},1}},

 {d4,{{id},2},{{rd4,rot3d4},0},{{rot2d4},-2},{{sd4,sr2d4},0},{{sr3d4,srd4},0}}}


characternr(D4,1);


{d4,{{id},1},{{rd4,rot3d4},1},{{rot2d4},1},{{sd4,sr2d4},1},{{sr3d4,srd4},1}}

characternr(D4,2);


{d4,{{id},1},{{rd4,rot3d4},1},{{rot2d4},1},{{sd4,sr2d4},-1},{{sr3d4,srd4},-1}}

characternr(D4,3);


{d4,{{id},1},{{rd4,rot3d4},-1},{{rot2d4},1},{{sd4,sr2d4},1},{{sr3d4,srd4},-1}}

characternr(D4,4);


{d4,{{id},1},{{rd4,rot3d4},-1},{{rot2d4},1},{{sd4,sr2d4},-1},{{sr3d4,srd4},1}}

characternr(D4,5);


{d4,{{id},2},{{rd4,rot3d4},0},{{rot2d4},-2},{{sd4,sr2d4},0},{{sr3d4,srd4},0}}

irreduciblereptable(D4);


{{d4,

  id=

  [1]

  ,

  rd4=

  [1]

  ,

  rot2d4=

  [1]

  ,

  rot3d4=

  [1]

  ,

  sd4=

  [1]

  ,

  srd4=

  [1]

  ,

  sr2d4=

  [1]

  ,

  sr3d4=

  [1]

  },

 {d4,

  id=

  [1]

  ,

  rd4=

  [1]

  ,

  rot2d4=

  [1]

  ,

  rot3d4=

  [1]

  ,

  sd4=

  [ - 1]

  ,

  srd4=

  [ - 1]

  ,

  sr2d4=

  [ - 1]

  ,

  sr3d4=

  [ - 1]

  },

 {d4,

  id=

  [1]

  ,

  rd4=

  [ - 1]

  ,

  rot2d4=

  [1]

  ,

  rot3d4=

  [ - 1]

  ,

  sd4=

  [1]

  ,

  srd4=

  [ - 1]

  ,

  sr2d4=

  [1]

  ,

  sr3d4=

  [ - 1]

  },

 {d4,

  id=

  [1]

  ,

  rd4=

  [ - 1]

  ,

  rot2d4=

  [1]

  ,

  rot3d4=

  [ - 1]

  ,

  sd4=

  [ - 1]

  ,

  srd4=

  [1]

  ,

  sr2d4=

  [ - 1]

  ,

  sr3d4=

  [1]

  },

 {d4,

  id=

  [1  0]
  [    ]
  [0  1]

  ,

  rd4=

  [ 0    1]
  [       ]
  [ - 1  0]

  ,

  rot2d4=

  [ - 1   0  ]
  [          ]
  [ 0     - 1]

  ,

  rot3d4=

  [0   - 1]
  [       ]
  [1   0  ]

  ,

  sd4=

  [1   0  ]
  [       ]
  [0   - 1]

  ,

  srd4=

  [0  1]
  [    ]
  [1  0]

  ,

  sr2d4=

  [ - 1  0]
  [       ]
  [ 0    1]

  ,

  sr3d4=

  [ 0     - 1]
  [          ]
  [ - 1   0  ]

  }}

irreduciblerepnr(D4,1);


{d4,

 id=

 [1]

 ,

 rd4=

 [1]

 ,

 rot2d4=

 [1]

 ,

 rot3d4=

 [1]

 ,

 sd4=

 [1]

 ,

 srd4=

 [1]

 ,

 sr2d4=

 [1]

 ,

 sr3d4=

 [1]

 }

irreduciblerepnr(D4,2);


{d4,

 id=

 [1]

 ,

 rd4=

 [1]

 ,

 rot2d4=

 [1]

 ,

 rot3d4=

 [1]

 ,

 sd4=

 [ - 1]

 ,

 srd4=

 [ - 1]

 ,

 sr2d4=

 [ - 1]

 ,

 sr3d4=

 [ - 1]

 }

irreduciblerepnr(D4,3);


{d4,

 id=

 [1]

 ,

 rd4=

 [ - 1]

 ,

 rot2d4=

 [1]

 ,

 rot3d4=

 [ - 1]

 ,

 sd4=

 [1]

 ,

 srd4=

 [ - 1]

 ,

 sr2d4=

 [1]

 ,

 sr3d4=

 [ - 1]

 }

irreduciblerepnr(D4,4);


{d4,

 id=

 [1]

 ,

 rd4=

 [ - 1]

 ,

 rot2d4=

 [1]

 ,

 rot3d4=

 [ - 1]

 ,

 sd4=

 [ - 1]

 ,

 srd4=

 [1]

 ,

 sr2d4=

 [ - 1]

 ,

 sr3d4=

 [1]

 }

irreduciblerepnr(D4,5);


{d4,

 id=

 [1  0]
 [    ]
 [0  1]

 ,

 rd4=

 [ 0    1]
 [       ]
 [ - 1  0]

 ,

 rot2d4=

 [ - 1   0  ]
 [          ]
 [ 0     - 1]

 ,

 rot3d4=

 [0   - 1]
 [       ]
 [1   0  ]

 ,

 sd4=

 [1   0  ]
 [       ]
 [0   - 1]

 ,

 srd4=

 [0  1]
 [    ]
 [1  0]

 ,

 sr2d4=

 [ - 1  0]
 [       ]
 [ 0    1]

 ,

 sr3d4=

 [ 0     - 1]
 [          ]
 [ - 1   0  ]

 }



rr:=mat((1,0,0,0,0),
        (0,0,1,0,0),
        (0,0,0,1,0),
        (0,0,0,0,1),
        (0,1,0,0,0));


      [1  0  0  0  0]
      [             ]
      [0  0  1  0  0]
      [             ]
rr := [0  0  0  1  0]
      [             ]
      [0  0  0  0  1]
      [             ]
      [0  1  0  0  0]



sp:=mat((1,0,0,0,0),
        (0,0,1,0,0),
        (0,1,0,0,0),
        (0,0,0,0,1),
        (0,0,0,1,0));


      [1  0  0  0  0]
      [             ]
      [0  0  1  0  0]
      [             ]
sp := [0  1  0  0  0]
      [             ]
      [0  0  0  0  1]
      [             ]
      [0  0  0  1  0]



rep:={D4,rD4=rr,sD4=sp};


rep := {d4,

        rd4=

        [1  0  0  0  0]
        [             ]
        [0  0  1  0  0]
        [             ]
        [0  0  0  1  0]
        [             ]
        [0  0  0  0  1]
        [             ]
        [0  1  0  0  0]

        ,

        sd4=

        [1  0  0  0  0]
        [             ]
        [0  0  1  0  0]
        [             ]
        [0  1  0  0  0]
        [             ]
        [0  0  0  0  1]
        [             ]
        [0  0  0  1  0]

        }


canonicaldecomposition(rep);


teta=2*teta1 + teta4 + teta5


character(rep);


{d4,{{id},5},{{rd4,rot3d4},1},{{rot2d4},1},{{sd4,sr2d4},1},{{sr3d4,srd4},3}}


symmetrybasis(rep,1);


[1   0 ]
[      ]
[    1 ]
[0  ---]
[    2 ]
[      ]
[    1 ]
[0  ---]
[    2 ]
[      ]
[    1 ]
[0  ---]
[    2 ]
[      ]
[    1 ]
[0  ---]
[    2 ]


symmetrybasis(rep,2);


symmetrybasis(rep,3);


symmetrybasis(rep,4);


[  0   ]
[      ]
[  1   ]
[ ---  ]
[  2   ]
[      ]
[  - 1 ]
[------]
[  2   ]
[      ]
[  1   ]
[ ---  ]
[  2   ]
[      ]
[  - 1 ]
[------]
[  2   ]


symmetrybasis(rep,5);


[  0       0   ]
[              ]
[  1       - 1 ]
[ ---    ------]
[  2       2   ]
[              ]
[  1       1   ]
[ ---     ---  ]
[  2       2   ]
[              ]
[  - 1     1   ]
[------   ---  ]
[  2       2   ]
[              ]
[  - 1     - 1 ]
[------  ------]
[  2       2   ]


symmetrybasispart(rep,5);


[  0   ]
[      ]
[  1   ]
[ ---  ]
[  2   ]
[      ]
[  1   ]
[ ---  ]
[  2   ]
[      ]
[  - 1 ]
[------]
[  2   ]
[      ]
[  - 1 ]
[------]
[  2   ]


allsymmetrybases(rep);


[1   0     0       0       0   ]
[                              ]
[    1     1       1       - 1 ]
[0  ---   ---     ---    ------]
[    2     2       2       2   ]
[                              ]
[    1     - 1     1       1   ]
[0  ---  ------   ---     ---  ]
[    2     2       2       2   ]
[                              ]
[    1     1       - 1     1   ]
[0  ---   ---    ------   ---  ]
[    2     2       2       2   ]
[                              ]
[    1     - 1     - 1     - 1 ]
[0  ---  ------  ------  ------]
[    2     2       2       2   ]




% Ritz matrix from Stiefel, Faessler p. 200
m:=mat((eps,a,a,a,a),
       (a  ,d,b,g,b),
       (a  ,b,d,b,g),
       (a  ,g,b,d,b),
       (a  ,b,g,b,d));


     [eps  a  a  a  a]
     [               ]
     [ a   d  b  g  b]
     [               ]
m := [ a   b  d  b  g]
     [               ]
     [ a   g  b  d  b]
     [               ]
     [ a   b  g  b  d]




diagonalize(m,rep);


[eps      2*a            0           0      0  ]
[                                              ]
[2*a  2*b + d + g        0           0      0  ]
[                                              ]
[ 0        0        - 2*b + d + g    0      0  ]
[                                              ]
[ 0        0             0         d - g    0  ]
[                                              ]
[ 0        0             0           0    d - g]



% eigenvalues are obvious. Eigenvectors may be obtained with
% the coordinate transformation matrix given by allsymmetrybases.

r1:=mat((0,1,0),
        (0,0,1),
        (1,0,0));


      [0  1  0]
      [       ]
r1 := [0  0  1]
      [       ]
      [1  0  0]



repC3:={C3,rC3=r1};


repc3 := {c3,rc3=

          [0  1  0]
          [       ]
          [0  0  1]
          [       ]
          [1  0  0]

          }


mC3:=mat((a,b,c),
         (c,a,b),
         (b,c,a));


       [a  b  c]
       [       ]
mc3 := [c  a  b]
       [       ]
       [b  c  a]



diagonalize(mC3,repC3);


[a + b + c              0                          0           ]
[                                                              ]
[                  2*a - b - c           sqrt(3)*b - sqrt(3)*c ]
[    0            -------------         -----------------------]
[                       2                          2           ]
[                                                              ]
[             - sqrt(3)*b + sqrt(3)*c         2*a - b - c      ]
[    0      --------------------------       -------------     ]
[                       2                          2           ]

 

% note difference between real and complex case

on complex;


diagonalize(mC3,repC3);


mat((a + b + c,0,0),

        i*sqrt(3)*b - i*sqrt(3)*c + 2*a - b - c
    (0,-----------------------------------------,0),
                           2

           - i*sqrt(3)*b + i*sqrt(3)*c + 2*a - b - c
    (0,0,--------------------------------------------))
                              2

 
off complex;



end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 14 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symaux.red0000644000175000017500000003413611526203062024426 0ustar  giovannigiovannimodule symaux;  %  Data for symmetry package.

% Author: Karin Gatermann .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


CREATE!-PACKAGE('(symaux
                  symatvec
                  symcheck
                  symchrep
                  symhandl
                  sympatch
                  symwork),
                '(contrib symmetry));

load!-package 'matrix;

algebraic(operator @);
algebraic( infix @);
algebraic( precedence @,*);

symbolic procedure give!_groups (u);
% prints the elements of the abstract group
begin
  return mk!+outer!+list(get!*available!*groups());
end;

put('availablegroups,'psopfn,'give!_groups);


symbolic procedure print!_group (groupname);
% prints the elements of the abstract group
begin
scalar g;
  if length(groupname)>1 then rederr("too many arguments");
  if length(groupname)<1 then rederr("group as argument missing");
  g:=reval car groupname;
  if available!*p(g) then
  return alg!:print!:group(g);
end;

put('printgroup,'psopfn,'print!_group);

symbolic procedure print!_generators (groupname);
% prints the generating elements of the abstract group
begin
scalar g;
  if length(groupname)>1 then rederr("too many arguments");
  if length(groupname)<1 then rederr("group as argument missing");
  g:=reval car groupname;
  if  available!*p(g) then
  return alg!:generators(g);
end;

put('generators,'psopfn,'print!_generators);


symbolic procedure character!_table (groupname);
% prints the characters of the group
begin
scalar g;
  if length(groupname)>1 then rederr("too many arguments");
  g:=reval car groupname;
  if available!*p(g) then
  return alg!:characters(g);
end;

put('charactertable,'psopfn,'character!_table);

symbolic procedure character!_nr (groupname);
% prints the characters of the group
begin
scalar group,nr,char1;
  if length(groupname)>2 then rederr("too many arguments");
  if length(groupname)<2 then rederr("group or number missing");
  group:=reval car groupname;
  nr:=reval cadr groupname;
  if not(available!*p(group)) then
     rederr("no information upon group available");
  if not(irr!:nr!:p(nr,group)) then
       rederr("no character with this number");
  if !*complex then
     char1:=get!*complex!*character(group,nr) else
     char1:=get!*real!*character(group,nr);
  return alg!:print!:character(char1);
end;

put('characternr,'psopfn,'character!_nr);

symbolic procedure irreducible!_rep!_table (groupname);
% prints the irreducible representations of the group
begin
scalar g;
  if length(groupname)>1 then rederr("too many arguments");
  if length(groupname)<1 then rederr("group missing");
  g:=reval car groupname;
  if available!*p(g) then
  return alg!:irr!:reps(g);
end;

put('irreduciblereptable,'psopfn,'irreducible!_rep!_table);

symbolic procedure irreducible!_rep!_nr (groupname);
% prints the irreducible representations of the group
begin
scalar g,nr;
  if length(groupname)>2 then rederr("too many arguments");
  if length(groupname)<2 then rederr("group or number missing");
  g:=reval car groupname;
  if not(available!*p(g)) then
     rederr("no information upon group available");
  nr:=reval cadr groupname;
  if not(irr!:nr!:p(nr,g)) then
       rederr("no irreducible representation with this number");
  if !*complex then
       return
    alg!:print!:rep(get!*complex!*irreducible!*rep(g,nr))
       else return
    alg!:print!:rep(get!*real!*irreducible!*rep(g,nr));
end;

put('irreduciblerepnr,'psopfn,'irreducible!_rep!_nr);

symbolic procedure canonical!_decomposition(representation);
% computes the canonical decomposition of the given representation
begin
scalar repr;
   if length(representation)>1 then rederr("too many arguments");
   repr:=reval car representation;
   if representation!:p(repr) then
   return alg!:can!:decomp(mk!_internal(repr));
end;

put('canonicaldecomposition,'psopfn,'canonical!_decomposition);

symbolic procedure sym!_character(representation);
% computes the character of the given representation
begin
scalar repr;
   if length(representation)>1 then rederr("too many arguments");
   if length(representation)<1 then
   rederr("representation list missing");
   repr:=reval car representation;
   if representation!:p(repr) then
   return alg!:print!:character(mk!_character(mk!_internal(repr))) else
     rederr("that's no representation");
end;


put('character,'psopfn,'sym!_character);

symbolic procedure symmetry!_adapted!_basis (arg);
% computes the first part of the symmetry adapted bases of
% the nr-th component
% arg = (representation,nr)
begin
scalar repr,nr,res;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then rederr("group or number missing");
   repr:=reval car arg;
   nr:=reval cadr arg;
   if representation!:p(repr) then
         repr:=mk!_internal(repr) else
         rederr("that's no representation");
   if irr!:nr!:p(nr,get!_group!_in(repr)) then
       <<
          if not(null(mk!_multiplicity(repr,nr))) then
             res:= mk!+outer!+mat(mk!_part!_sym!_all(repr,nr))
             else
             res:=nil;
       >> else
        rederr("wrong number of an irreducible representation");
   return res;
end;

put('symmetrybasis,'psopfn,'symmetry!_adapted!_basis);

symbolic procedure symmetry!_adapted!_basis!_part (arg);
% computes the first part of the symmetry adapted bases
% of the nr-th component
% arg = (representation,nr)
begin
scalar repr,nr,res;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then rederr("group or number missing");
   repr:=reval car arg;
   nr:=reval cadr arg;
   if representation!:p(repr) then
         repr:=mk!_internal(repr) else
         rederr("that's no representation");
   if irr!:nr!:p(nr,get!_group!_in(repr)) then
       <<
          if not(null(mk!_multiplicity(repr,nr))) then
             res:= mk!+outer!+mat(mk!_part!_sym1(repr,nr))
             else
             res:=nil;
       >> else
        rederr("wrong number of an irreducible representation");
   return res;
end;

put('symmetrybasispart,'psopfn,'symmetry!_adapted!_basis!_part);

symbolic procedure symmetry!_bases (representation);
% computes the complete symmetry adapted basis
begin
scalar repr,res;
   if length(representation)>1 then rederr("too many arguments");
   if length(representation)<1 then rederr("representation missing");
   repr:=reval car representation;
   if representation!:p(repr) then
     <<
         res:= mk!+outer!+mat(mk!_sym!_basis(mk!_internal(repr)));
     >> else
       rederr("that's no representation");
    return res;
end;

put('allsymmetrybases,'psopfn,'symmetry!_bases);

symbolic procedure sym!_diagonalize (arg);
% diagonalizes a matrix with respect to a given representation
begin
scalar repr,matrix1;
   if (length(arg)>2) then rederr("too many arguments");
   if (length(arg)<2) then rederr("representation or matrix missing");
   repr:=reval cadr arg;
   matrix1:=reval (car arg);
   if alg!+matrix!+p(matrix1) then
        matrix1:=mk!+inner!+mat(matrix1)
        else
        rederr("first argument must be a matrix");
   if representation!:p(repr) then
       repr:=mk!_internal(repr) else
       rederr("that's no representation");
   if symmetry!:p(matrix1,repr) then
   return mk!+outer!+mat(mk!_diagonal(
          matrix1,repr)) else
   rederr("matrix has not the symmetry of this representation");
end;

put('diagonalize,'psopfn,'sym!_diagonalize);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% function to add new groups to the database by the user
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure set!_generators!_group (arg);
% a group is generated by some elements
begin
scalar group, generators,relations,rel;
   if length(arg)>3 then rederr("too many arguments");
   if length(arg)<2 then
      rederr("group identifier or generator list missing");
   group:=reval car arg;
   generators:=reval cadr arg;
   if length(arg)=3 then
          relations:=reval caddr arg else
          relations:=nil;
   if not(idp(group)) then
        rederr("first argument must be a group identifier");
   generators:=mk!+inner!+list(generators);
   if not(identifier!:list!:p(generators)) then
     rederr("second argument must be a list of generator identifiers")
        else set!*generators(group,generators);
   relations:=mk!_relation!_list(relations);
   for each rel in relations do
       if not(relation!:list!:p(group,rel)) then
          rederr("equations in generators are demanded");
   set!*relations(group,relations);
   writepri("setgenerators finished",'only);
end;

put('setgenerators,'psopfn,'set!_generators!_group);

symbolic procedure set!_elements(arg);
% each element<>id of a group has a representation
% as product of generators
% the identity is called id
begin
scalar elemreps,replist,elems,group;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then
 rederr("missing group or list with group elements with generators ");
   group:=reval car arg;
   if not(idp(group)) then
        rederr("first argument must be a group identifier");
   elemreps:=reval cadr arg;
   elemreps:=mk!_relation!_list(elemreps);
   for each replist in elemreps do
     if not(generator!:list!:p(group,cadr replist)) then
       rederr("group elements should be represented in generators");
   for each replist in elemreps do
     if not((length(car replist)=1) and idp(caar replist)) then
       rederr("first must be one group element");
   elems:= for each replist in elemreps collect caar replist;
   elems:=append(list('id),elems);
   set!*elems!*group(group,elems);
   set!*elemasgen(group,elemreps);
   writepri("setelements finished",'only);
end;

put('setelements,'psopfn,'set!_elements);

symbolic procedure set!_group!_table (arg);
% a group table gives the result of the product of two elements
begin
scalar table,group,z,s;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then
      rederr("missing group or group table as a matrix ");
   group:=reval car arg;
   if not(idp(group)) then
        rederr("first argument must be a group identifier");
   table:=reval cadr arg;
   if alg!+matrix!+p(table) then
       table:=mk!+inner!+mat(table);
   table:=for each z in table collect
        for each s in z collect prepsq(s);
   if group!:table!:p(group,table) then
     <<
        set!*grouptable(group,table);
        set!*inverse(group,mk!*inverse!*list(table));
        set!*group(group,mk!*equiclasses(table));
        set!*storing(group);
     >> else rederr("table is not a group table");
   writepri("setgrouptable finished",'only);
end;

put('setgrouptable,'psopfn,'set!_group!_table);

symbolic procedure set!_real!_rep(arg);
% store the real irreducible representations
begin
scalar replist,type;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then
      rederr("representation or type missing");
   replist:=reval car arg;
   type:=reval cadr arg;
   if (not(type= 'realtype) and not(type = 'complextype)) then
       rederr("only real or complex types possible");
   if get!*order(get!_group!_out(replist))=0 then
         rederr("elements of the groups must be set first");
   if representation!:p(replist) then
         replist:=(mk!_internal(replist));
   set!*representation(get!_group!_in(replist),
          append(list(type),cdr replist),'real);
   writepri("Rsetrepresentation finished",'only);
end;

put('Rsetrepresentation,'psopfn,'set!_real!_rep);

symbolic procedure set!_complex!_rep(arg);
% store the complex irreducible representations
begin
scalar replist;
   if length(arg)>1 then rederr("too many arguments");
   if length(arg)<1 then
      rederr("representation missing");
   replist:=reval car arg;
   if get!*order(get!_group!_out(replist))=0 then
         rederr("elements of the groups must be set first");
   if representation!:p(replist) then
         replist:=(mk!_internal(replist));
   set!*representation(get!_group!_in(replist),cdr replist,'complex);
   writepri("Csetrepresentation finished",'only);
end;

put('Csetrepresentation,'psopfn,'set!_complex!_rep);

symbolic procedure mk!_available(arg);
% group is only then made available, if all information was given
begin
scalar group;
   if length(arg)>1 then rederr("too many arguments");
   if length(arg)<1 then
      rederr("group identifier missing");
   group:=reval car arg;
   if check!:complete!:rep!:p(group) then
       set!*available(group);
   writepri("setavailable finished",'only);
end;

put('setavailable,'psopfn,'mk!_available);

symbolic procedure update!_new!_group (arg);
% stores the user defined new abstract group in a file
begin
scalar group;
   if length(arg)>2 then rederr("too many arguments");
   if length(arg)<2 then
      rederr("group or filename missing");
   group:=reval car arg;
   if available!*p(group) then write!:to!:file(group,reval cadr arg);
   writepri("storegroup finished",'only);
end;

put('storegroup,'psopfn,'update!_new!_group);

procedure loadgroups(fname);
% loads abstract groups from a file which was created from a user
% by newgroup and updategroup
begin
  in fname;
  write"group loaded";
end;
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symwork.red0000644000175000017500000004014511526203062024610 0ustar  giovannigiovannimodule symwork;
%
% Symmetry Package
%
% Author : Karin Gatermann
%         Konrad-Zuse-Zentrum fuer
%         Informationstechnik Berlin
%         Heilbronner Str. 10
%         W-1000 Berlin 31
%         Germany
%         Email: Gatermann@sc.ZIB-Berlin.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% symwork.red
% underground functions

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Boolean functions
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


%symbolic procedure complex!_case!_p();
% returns true, if complex arithmetic is desired
%begin
%  if !*complex then return t else return nil;
%end;

switch outerzeroscheck;

symbolic procedure correct!_diagonal!_p(matrixx,representation,mats);
% returns true, if matrix may be block diagonalized to mats
begin
scalar basis,diag;
   basis:=mk!_sym!_basis (representation);
   diag:= mk!+mat!*mat!*mat(
             mk!+hermitean!+matrix(basis),
             matrixx,basis);
   if equal!+matrices!+p(diag,mats) then return t;
end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% functions on data depending on real or complex case
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure get!_nr!_irred!_reps(group);
% returns number of irreducible representations of group
begin
  if !*complex then
      return get!*nr!*complex!*irred!*reps(group) else
      return get!*nr!*real!*irred!*reps(group);
end;

symbolic procedure get!_dim!_irred!_reps(group,nr);
% returns dimension of nr-th irreducible representations of group
begin
scalar rep;
%   if !*complex then
%        return get!_char!_dim(get!*complex!*character(group,nr)) else
%        return get!_char!_dim(get!*real!*character(group,nr));
   if !*complex then
        rep:= get!*complex!*irreducible!*rep(group,nr) else
        rep:= get!*real!*irreducible!*rep(group,nr);
   return get!_dimension!_in(rep);
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  functions for user given representations
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure get!_group!_out(representation);
% returns the group identifier given in representation
begin
   scalar group,found,eintrag,repl;
   found:=nil;
   repl:=cdr representation;
   while (not(found) and (length(repl)>1)) do
     <<
        eintrag:=car repl;
        repl:=cdr repl;
        if idp(eintrag) then
          <<
             group:=eintrag;
             found:=t;
          >>;
      >>;
  if found then return group else
  rederr("group identifier missing");
end;

symbolic procedure get!_repmatrix!_out(elem,representation);
% returns the representation matrix of elem given in representation
% output in internal structure
begin
scalar repl,found,matelem,eintrag;
   found:=nil;
   repl:= cdr representation;
   while (null(found) and (length(repl)>0)) do
     <<
        eintrag:=car repl;
        repl:=cdr repl;
        if eqcar(eintrag,'equal) then
           <<
              if not(length(eintrag) = 3) then
                       rederr("incomplete equation");
              if (cadr(eintrag) = elem) then
                <<
                   found:=t;
                   matelem:=caddr eintrag;
                >>;
           >>;
     >>;
   if found then return matelem else
        rederr("representation matrix for one generator missing");
end;

symbolic procedure mk!_rep!_relation(representation,generators);
% representation in user given structure
% returns a list of pairs with generator and its representation matrix
% in internal structure
begin
scalar g,matg,res;
  res:=for each g in generators collect
     <<
        matg:= mk!+inner!+mat(get!_repmatrix!_out(g,representation));
        if not(unitarian!+p(matg)) then
             rederr("please give an orthogonal or unitarian matrix");
        list(g,matg)
      >>;
  return res;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% functions which compute, do the real work, get correct arguments
%                    and use get-functions from sym_handle_data.red
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure mk!_character(representation);
% returns the character of the representation (in internal structure)
% result in internal structure
begin
scalar group,elem,char;
   group:=get!_group!_in(representation);
   char:= for each elem in get!*elements(group) collect
             list(elem,
                  mk!+trace(get!_rep!_matrix!_in(
                              elem,representation)
                           )
                  );
   char:=append(list(group),char);
   return char;
end;

symbolic procedure mk!_multiplicity(representation,nr);
% returns the multiplicity of the nr-th rep. in representation
% internal structure
begin
scalar multnr,char1,group;
     group:=get!_group!_in(representation);
  if !*complex then
     char1:=mk!_character(get!*complex!*irreducible!*rep(group,nr))
         else
     char1:=mk!_character(get!*real!*irreducible!*rep(group,nr));
  multnr:=char!_prod(char1,mk!_character(representation));
% complex case factor 1/2 !!
     if (not(!*complex) and
         (get!*real!*comp!*chartype!*p(group,nr))) then
         multnr:=multsq(multnr,(1 ./ 2));
     return change!+sq!+to!+int(multnr);
end;


symbolic procedure char!_prod(char1,char2);
% returns the inner product of the two characters as sq
begin
scalar group,elems,sum,g,product;
  group:=get!_char!_group(char1);
  if not(group = get!_char!_group(char2))
      then rederr("no product for two characters of different groups");
  if not (available!*p(group)) and not(storing!*p(group)) then
       rederr("strange group in character product");
  elems:=get!*elements(group);
  sum:=nil ./ 1;
  for each g in elems do
    <<
      product:=multsq(
        get!_char!_value(char1,g),
        get!_char!_value(char2,get!*inverse(group,g))
                     );
      sum:=addsq(sum,product);
    >>;
  return quotsq(sum,change!+int!+to!+sq(get!*order(group)));
end;

symbolic procedure mk!_proj!_iso(representation,nr);
% returns the projection onto the isotypic component nr
begin
scalar group,elems,g,charnr,dimen,mapping,fact;
  group:=get!_group!_in(representation);
  if not (available!*p(group)) then
       rederr("strange group in projection");
  if not(irr!:nr!:p(nr,group)) then
       rederr("incorrect number of representation");
  elems:=get!*elements(group);
  if !*complex then
      charnr:=
          mk!_character(get!*complex!*irreducible!*rep(group,nr))
  else
      charnr:=mk!_character(get!*real!*irreducible!*rep(group,nr));
  dimen:=get!_dimension!_in(representation);
  mapping:=mk!+null!+mat(dimen,dimen);
  for each g in elems do
    <<
      mapping:=mk!+mat!+plus!+mat(
              mapping,
              mk!+scal!+mult!+mat(
        get!_char!_value(charnr,get!*inverse(group,g)),
        get!_rep!_matrix!_in(g,representation)
                                 )
                                 );
    >>;
  fact:=quotsq(change!+int!+to!+sq(get!_char!_dim(charnr)),
         change!+int!+to!+sq(get!*order(group)));
  mapping:=mk!+scal!+mult!+mat(fact,mapping);
% complex case factor 1/2 !!
  if (not(!*complex) and
    (get!*real!*comp!*chartype!*p(group,nr))) then
       mapping:=mk!+scal!+mult!+mat((1 ./ 2),mapping);
  return mapping;
end;

symbolic procedure mk!_proj!_first(representation,nr);
% returns the projection onto the first vector space of the
% isotypic component nr
begin
scalar group,elems,g,irrrep,dimen,mapping,fact,charnr,irrdim;
  group:=get!_group!_in(representation);
  if not (available!*p(group)) then
       rederr("strange group in projection");
  if not(irr!:nr!:p(nr,group)) then
       rederr("incorrect number of representation");
  elems:=get!*elements(group);
  if !*complex then
      irrrep:=get!*complex!*irreducible!*rep(group,nr) else
      irrrep:=get!*real!*irreducible!*rep(group,nr);
  dimen:=get!_dimension!_in(representation);
  mapping:=mk!+null!+mat(dimen,dimen);
  for each g in elems do
    <<
      mapping:=mk!+mat!+plus!+mat(
              mapping,
              mk!+scal!+mult!+mat(
        get!_rep!_matrix!_entry(irrrep,get!*inverse(group,g),1,1),
        get!_rep!_matrix!_in(g,representation)
                                 )
                                 );
    >>;
  irrdim:=get!_dimension!_in(irrrep);
  fact:=quotsq(change!+int!+to!+sq(irrdim),
         change!+int!+to!+sq(get!*order(group)));
  mapping:=mk!+scal!+mult!+mat(fact,mapping);
% no special rule for real irreducible representations of complex type
  return mapping;
end;

symbolic procedure mk!_mapping(representation,nr,count);
% returns the mapping from V(nr 1) to V(nr count)
% output is internal matrix
begin
scalar group,elems,g,irrrep,dimen,mapping,fact,irrdim;
  group:=get!_group!_in(representation);
  if not (available!*p(group)) then
       rederr("strange group in projection");
  if not(irr!:nr!:p(nr,group)) then
       rederr("incorrect number of representation");
  elems:=get!*elements(group);
  if !*complex then
      irrrep:=get!*complex!*irreducible!*rep(group,nr) else
      irrrep:=get!*real!*irreducible!*rep(group,nr);
  dimen:=get!_dimension!_in(representation);
  mapping:=mk!+null!+mat(dimen,dimen);
  for each g in elems do
    <<
      mapping:=mk!+mat!+plus!+mat(
              mapping,
              mk!+scal!+mult!+mat(
        get!_rep!_matrix!_entry(irrrep,get!*inverse(group,g),1,count),
        get!_rep!_matrix!_in(g,representation)
                                 )
                                 );
    >>;
  irrdim:=get!_dimension!_in(irrrep);
  fact:=quotsq(change!+int!+to!+sq(irrdim),
         change!+int!+to!+sq(get!*order(group)));
  mapping:=mk!+scal!+mult!+mat(fact,mapping);
% no special rule for real irreducible representations of complex type
  return mapping;
end;

symbolic procedure mk!_part!_sym (representation,nr);
% computes the symmetry adapted basis of component nr
% output matrix
begin
scalar unitlist, veclist2, mapping, v;
  unitlist:=gen!+can!+bas(get!_dimension!_in(representation));
  mapping:=mk!_proj!_iso(representation,nr);
  veclist2:= for each v in unitlist collect
             mk!+mat!+mult!+vec(mapping,v);
  return mk!+internal!+mat(Gram!+Schmid(veclist2));
end;

symbolic procedure mk!_part!_sym1 (representation,nr);
% computes the symmetry adapted basis of component V(nr 1)
% internal structure for in and out
% output matrix
begin
scalar unitlist, veclist2, mapping, v,group;
  unitlist:=gen!+can!+bas(get!_dimension!_in(representation));
  group:=get!_group!_in (representation);
  if (not(!*complex) and
       get!*real!*comp!*chartype!*p(group,nr)) then
     <<
        mapping:=mk!_proj!_iso(representation,nr);
     >> else
        mapping:=mk!_proj!_first(representation,nr);
  veclist2:= for each v in unitlist collect
             mk!+mat!+mult!+vec(mapping,v);
  veclist2:=mk!+resimp!+mat(veclist2);
  return mk!+internal!+mat(Gram!+Schmid(veclist2));
end;

symbolic procedure mk!_part!_symnext (representation,nr,count,mat1);
% computes the symmetry adapted basis of component V(nr count)
% internal structure for in and out -- count > 2
% bas1 -- internal matrix
% output matrix
begin
scalar veclist1, veclist2, mapping, v;
  mapping:=mk!_mapping(representation,nr,count);
  veclist1:=mat!+veclist(mat1);
  veclist2:= for each v in veclist1 collect
      mk!+mat!+mult!+vec(mapping,v);
  return mk!+internal!+mat(veclist2);
end;

symbolic procedure mk!_sym!_basis (representation);
% computes the complete symmetry adapted basis
% internal structure for in and out
begin
scalar nr,anz,group,dimen,mats,matels,mat1,mat2;
   group:=get!_group!_in(representation);
   anz:=get!_nr!_irred!_reps(group);
   mats:=for nr := 1:anz join
     if not(null(mk!_multiplicity(representation,nr))) then
     <<
       if get!_dim!_irred!_reps(group,nr)=1 then
           mat1:=mk!_part!_sym (representation,nr)
        else
           mat1:=mk!_part!_sym1 (representation,nr);
       if (not(!*complex) and
              get!*real!*comp!*chartype!*p(group,nr)) then
           <<
              matels:=list(mat1);
           >> else
           <<
              if get!_dim!_irred!_reps(group,nr)=1 then
                <<
                   matels:=list(mat1);
                >> else
                <<
                   matels:=
                  for dimen:=2:get!_dim!_irred!_reps(group,nr) collect
                        mk!_part!_symnext(representation,nr,dimen,mat1);
                   matels:=append(list(mat1),matels);
                >>;
           >>;
       matels
     >>;
  if length(mats)<1 then rederr("no mats in mk!_sym!_basis");
  mat2:=car mats;
  for each mat1 in cdr mats do
      mat2:=add!+two!+mats(mat2,mat1);
  return mat2;
end;

symbolic procedure mk!_part!_sym!_all (representation,nr);
% computes the complete symmetry adapted basis
% internal structure for in and out
begin
scalar group,dimen,matels,mat1,mat2;
   group:=get!_group!_in(representation);
   if get!_dim!_irred!_reps(group,nr)=1 then
      mat1:=mk!_part!_sym (representation,nr)
      else
        <<
           mat1:=mk!_part!_sym1 (representation,nr);
       if (not(!*complex) and
              get!*real!*comp!*chartype!*p(group,nr)) then
           <<
              mat1:=mat1;
           >> else
           <<
              if get!_dim!_irred!_reps(group,nr)>1 then
                << matels:=
                  for dimen:=2:get!_dim!_irred!_reps(group,nr) collect
                     mk!_part!_symnext(representation,nr,dimen,mat1);
                  for each mat2 in matels do
                   mat1:=add!+two!+mats(mat1,mat2);
                >>;
           >>;
        >>;
  return mat1;
end;

symbolic procedure mk!_diagonal (matrix1,representation);
% computes the matrix in diagonal form
% internal structure for in and out
begin
scalar nr,anz,mats,group,mat1,diamats,matdia,dimen;
   group:=get!_group!_in(representation);
   anz:=get!_nr!_irred!_reps(group);
   mats:=for nr := 1:anz join
     if not(null(mk!_multiplicity(representation,nr))) then
     <<
       if get!_dim!_irred!_reps(group,nr)=1 then
           mat1:=mk!_part!_sym (representation,nr)
        else
           mat1:=mk!_part!_sym1 (representation,nr);
%        if (not(!*complex) and
%              get!*real!*comp!*chartype!*p(group,nr)) then
%                mat1:=add!+two!+mats(mat1,
%                          mk!_part!_symnext(representation,nr,2,mat1));
        matdia:= mk!+mat!*mat!*mat(
                  mk!+hermitean!+matrix(mat1),matrix1,mat1
                              );
        if (not(!*complex) and
              get!*real!*comp!*chartype!*p(group,nr)) then
           <<
             diamats:=list(matdia);
           >> else
           <<
             diamats:=
                  for dimen:=1:get!_dim!_irred!_reps(group,nr) collect
                     matdia;
            >>;
        diamats
     >>;
  mats:=mk!+block!+diagonal!+mat(mats);
  if !*outerzeroscheck then
    if not(correct!_diagonal!_p(matrix1,representation,mats)) then
       rederr("wrong diagonalisation");
  return mats;
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symcheck.red0000644000175000017500000003432711526203062024710 0ustar  giovannigiovannimodule symcheck;
%
% Symmetry Package
%
% Author : Karin Gatermann
%         Konrad-Zuse-Zentrum fuer
%         Informationstechnik Berlin
%         Heilbronner Str. 10
%         W-1000 Berlin 31
%         Germany
%         Email: Gatermann@sc.ZIB-Berlin.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% symcheck.red

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  check user input -- used by functions in sym_main.red
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure representation!:p(rep);
% returns true, if rep is a representation
begin
scalar group,elem,mats,mat1,dim1;
  if length(rep)<0 then rederr("list too short");
  if not(outer!+list!+p(rep)) then rederr("argument should be a list");
  if (length(rep)<2) then rederr("empty list is not a representation");
  group:=get!_group!_out(rep);
  if not(available!*p(group) or storing!*p(group)) then
   rederr("one element must be an identifier of an available group");
  mats:=for each elem in get!*generators(group) collect
        get!_repmatrix!_out(elem,rep);
  for each mat1 in mats do
     if not(alg!+matrix!+p(mat1)) then
        rederr("there should be a matrix for each generator");
  mats:=for each mat1 in mats collect mk!+inner!+mat(mat1);
  for each mat1 in mats do
     if not(squared!+matrix!+p(mat1)) then
        rederr("matrices should be squared");
  mat1:=car mats;
  mats:=cdr mats;
  dim1:=get!+row!+nr(mat1);
  while length(mats)>0 do
    <<
      if not(dim1=get!+row!+nr(car mats)) then
         rederr("representation matrices must have the same dimension");
      mat1:=car mats;
      mats:= cdr mats;
    >>;
  return t;
end;

symbolic procedure irr!:nr!:p(nr,group);
% returns true, if group is a group and information is available
% and nr is number of an irreducible representation
begin
  if not(fixp(nr)) then rederr("nr should be an integer");
  if (nr>0 and nr<= get!_nr!_irred!_reps(group)) then
        return t;
end;

symbolic procedure symmetry!:p(matrix1,representation);
% returns true, if the matrix has the symmetry of this representation
% internal structures
begin
scalar group,glist,symmetryp,repmat;
   group:=get!_group!_in(representation);
   glist:=get!*generators(group);
   symmetryp:=t;
   while (symmetryp and (length(glist)>0)) do
      <<
         repmat:=get!_rep!_matrix!_in(car glist,representation);
         if not (equal!+matrices!+p(
                mk!+mat!+mult!+mat(repmat,matrix1),
                mk!+mat!+mult!+mat(matrix1,repmat)) ) then
                  symmetryp:=nil;
         glist:= cdr glist;
      >>;
  return symmetryp;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  check functions used by definition of the group
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure identifier!:list!:p(idlist);
% returns true if idlist is a list of identifiers
begin
  if length(idlist)>0 then
      <<
         if idp(car idlist) then
             return identifier!:list!:p(cdr idlist);
      >> else
      return t;
end;

symbolic procedure generator!:list!:p(group,generatorl);
% returns true if generatorl is an idlist
% consisting of the generators of the group
begin
scalar element,res;
  res:=t;
  if length(generatorl)<1 then
              rederr("there should be a list of generators");
  if length(get!*generators(group))<1 then
              rederr("there are no group generators stored");
  if not(identifier!:list!:p(generatorl)) then return nil;
  for each element in generatorl do
        if not(g!*generater!*p(group,element)) then
            res:=nil;
  return res;
end;

symbolic procedure relation!:list!:p(group,relations);
% relations -- list of two generator lists
begin
  if length(get!*generators(group))<1 then
              rederr("there are no group generators stored");
  return (relation!:part!:p(group,car relations) and
          relation!:part!:p(group,cadr relations))
end;

symbolic procedure relation!:part!:p(group,relationpart);
% relations -- list of two generator lists
begin
scalar generators,res,element;
  res:=t;
  generators:=get!*generators(group);
  if length(generators)<1 then
              rederr("there are no group generators stored");
  if length(relationpart)<1 then
              rederr("wrong relation given");
  if not(identifier!:list!:p(relationpart)) then return nil;
  generators:=append(list('id),generators);
  for each element in relationpart do
       if not(memq(element,generators)) then res:=nil;
  return res;
end;

symbolic procedure group!:table!:p(group,gtable);
% returns true, if gtable is a group table
% gtable - matrix in internal representation
begin
scalar row;
  if not(get!+mat!+entry(gtable,1,1) = 'grouptable) then
  rederr("first diagonal entry in a group table must be grouptable");
  for each row in gtable do
       if not(group!:elemts!:p(group,cdr row)) then
            rederr("this should be a group table");
  for each row in mk!+transpose!+matrix(gtable) do
       if not(group!:elemts!:p(group,cdr row)) then
            rederr("this should be a group table");
  return t;
end;

symbolic procedure group!:elemts!:p(group,elems);
% returns true if each element of group appears exactly once in the list
begin
   return equal!+lists!+p(get!*elements(group),elems);
end;

symbolic procedure check!:complete!:rep!:p(group);
% returns true if sum ni^2 = grouporder and
%                 sum realni = sum complexni
begin
scalar nr,j,sum,dime,order1,sumreal,chars,complexcase;
    nr:=get!*nr!*complex!*irred!*reps(group);
    sum:=(nil ./ 1);
    for j:=1:nr do
       <<
         dime:=change!+int!+to!+sq( get!_dimension!_in(
                get!*complex!*irreducible!*rep(group,j)));
         sum:=addsq(sum,multsq(dime,dime));
       >>;
    order1:=change!+int!+to!+sq(get!*order(group));
    if not(null(numr(addsq(sum,negsq(order1))))) then
        rederr("one complex irreducible representation missing or
                    is not irreducible");
    sum:=(nil ./ 1);
    for j:=1:nr do
       <<
         dime:=change!+int!+to!+sq( get!_dimension!_in(
                get!*complex!*irreducible!*rep(group,j)));
         sum:=addsq(sum,dime);
       >>;
    chars:=for j:=1:nr collect
            get!*complex!*character(group,j);
    if !*complex then
      <<
        complexcase:=t;
      >> else
      <<
        complexcase:=nil;
        on complex;
      >>;
    if not(orthogonal!:characters!:p(chars)) then
          rederr("characters are not orthogonal");
    if null(complexcase) then off complex;
    nr:=get!*nr!*real!*irred!*reps(group);
    sumreal:=(nil ./ 1);
    for j:=1:nr do
       <<
         dime:=change!+int!+to!+sq( get!_dimension!_in(
                get!*real!*irreducible!*rep(group,j)));
         sumreal:=addsq(sumreal,dime);
       >>;
    chars:=for j:=1:nr collect
            get!*real!*character(group,j);
    if not(orthogonal!:characters!:p(chars)) then
          rederr("characters are not orthogonal");
    if not(null(numr(addsq(sum,negsq(sumreal))))) then
  rederr("list real irreducible representation incomplete or wrong");
  return t;
end;

symbolic procedure orthogonal!:characters!:p(chars);
% returns true if all characters in list are pairwise orthogonal
begin
scalar chars1,chars2,char1,char2;
  chars1:=chars;
  while (length(chars1)>0) do
    <<
      char1:=car chars1;
      chars1:=cdr chars1;
      chars2:=chars1;
         while (length(chars2)>0) do
            <<
               char2:=car chars2;
               chars2:=cdr chars2;
               if not(change!+sq!+to!+algnull(
                      char!_prod(char1,char2))=0)
                  then rederr("not orthogonal");
            >>;
    >>;
  return t;
end;

symbolic procedure write!:to!:file(group,filename);
begin
scalar nr,j;
if not(available!*p(group)) then rederr("group is not available");
out filename;
rprint(list
   ('off, 'echo));
rprint('symbolic);
rprint(list
   ('set!*elems!*group ,mkquote group,mkquote get!*elements(group)));
rprint(list
   ('set!*generators, mkquote group,mkquote get!*generators(group)));
rprint(list
   ('set!*relations, mkquote group,
       mkquote get!*generator!*relations(group)));
rprint(list
   ('set!*grouptable, mkquote group,mkquote get(group,'grouptable)));
rprint(list
   ('set!*inverse, mkquote group,mkquote get(group,'inverse)));
rprint(list
   ('set!*elemasgen, mkquote group
          ,mkquote get(group,'elem!_in!_generators)));
rprint(list
   ('set!*group, mkquote group,mkquote get(group,'equiclasses)));

nr:=get!*nr!*complex!*irred!*reps(group);
   for j:=1:nr do
     <<
       rprint(list
   ('set!*representation, mkquote group,
           mkquote cdr get!*complex!*irreducible!*rep(group,j),
            mkquote 'complex));
     >>;
nr:=get!*nr!*real!*irred!*reps(group);
   for j:=1:nr do
     <<
       rprint(list
   ('set!*representation, mkquote group,
           mkquote get(group,mkid('realrep,j)),mkquote 'real));
     >>;
rprint(list(
    'set!*available,mkquote group));
rprint('algebraic);
rprint('end);
shut filename;
end;


symbolic procedure mk!_relation!_list(relations);
% input: outer structure : reval of {r*s*r^2=s,...}
% output: list of pairs of lists
begin
scalar twolist,eqrel;
  if not(outer!+list!+p(relations)) then
       rederr("this should be a list");
  twolist:=for each eqrel in mk!+inner!+list(relations) collect
       change!_eq!_to!_lists(eqrel);
  return twolist;
end;

symbolic procedure change!_eq!_to!_lists(eqrel);
begin
 if not(outer!+equation!+p(eqrel)) then
    rederr("equations should be given");
 return list(mk!_side!_to!_list(reval cadr eqrel),
             mk!_side!_to!_list(reval caddr eqrel));
end;

symbolic procedure mk!_side!_to!_list(identifiers);
begin
scalar i;
  if idp(identifiers) then return list(identifiers);
  if eqcar(identifiers,'Plus) then rederr("no addition in this group");
  if eqcar(identifiers,'EXPT) then
     return for i:=1:(caddr identifiers) collect (cadr identifiers);
  if eqcar(identifiers,'TIMES) then
     rederr("no multiplication with * in this group");
if eqcar(identifiers,'!@) then
     return append(mk!_side!_to!_list(cadr identifiers),
                  mk!_side!_to!_list(caddr identifiers));
end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%  pass to algebraic level
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure alg!:print!:group(group);
% returns the group element list in correct algebraic mode
begin
  return mk!+outer!+list(get!*elements(group));
end;

symbolic procedure alg!:generators(group);
% returns the generator list of a group in correct algebraic mode
begin
  return append(list('list),get!*generators(group));
end;

symbolic procedure alg!:characters(group);
% returns the (real od complex) character table
% in correct algebraic mode
begin
scalar nr,i,charlist,chari;
  nr:=get!_nr!_irred!_reps(group);
  charlist:=for i:=1:nr collect
     if !*complex then
        get!*complex!*character(group,i) else
        get!*real!*character(group,i);
  charlist:= for each chari in charlist collect
        alg!:print!:character(chari);
  return mk!+outer!+list(charlist);
end;

symbolic procedure alg!:irr!:reps(group);
% returns the (real od complex) irr. rep. table
% in correct algebraic mode
begin
scalar repi,reps,nr,i;
  nr:=get!_nr!_irred!_reps(group);
  reps:=for i:=1:nr collect
     if !*complex then
        get!*complex!*irreducible!*rep(group,nr) else
        get!*real!*irreducible!*rep(group,i);
  reps:= for each repi in reps collect
        alg!:print!:rep(repi);
  return mk!+outer!+list(reps);
end;

symbolic procedure alg!:print!:rep(representation);
% returns the representation in correct algebraic mode
begin
scalar pair,repr,group,mat1,g;
  group:=get!_group!_in(representation);
  repr:=eli!_group!_in(representation);
  repr:= for each pair in repr collect
      <<
          mat1:=cadr pair;
          g:=car pair;
          mat1:=mk!+outer!+mat(mat1);
          mk!+equation(g,mat1)
      >>;
  repr:=append(list(group),repr);
  return mk!+outer!+list(repr)
end;

symbolic procedure alg!:can!:decomp(representation);
% returns the canonical decomposition in correct algebraic mode
% representation in internal structure
begin
scalar nr,nrirr,ints,i,sum;
   nrirr:=get!_nr!_irred!_reps(get!_group!_in(representation));
   ints:=for nr:=1:nrirr collect
       mk!_multiplicity(representation,nr);
   sum:=( nil ./ 1);
   ints:= for i:=1:length(ints) do
      sum:=addsq(sum,
             multsq(change!+int!+to!+sq(nth(ints,i)),
                   simp mkid('teta,i)
                  )
                );
   return mk!+equation('teta,prepsq sum);
end;

symbolic procedure alg!:print!:character(character);
% changes the character from internal representation
% to printable representation
begin
scalar group,res,equilists;
  group:=get!_char!_group(character);
  res:=get!*all!*equi!*classes(group);
  res:= for each equilists in res collect
         mk!+outer!+list(equilists);
  res:= for each equilists in res collect
          mk!+outer!+list( list(equilists,
            prepsq get!_char!_value(character,cadr equilists)));
  res:=append(list(group),res);
  return mk!+outer!+list(res);
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symdata1.red0000644000175000017500000023763011526203062024627 0ustar  giovannigiovannimodule symdata1;  %  Data for symmetry package, part 1.

% Author: Karin Gatermann .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


set!*elems!*group('z2,'(id sz2))$
set!*generators('z2,'(sz2))$
set!*relations('z2,'(((sz2 sz2) (id))))$
set!*grouptable('z2,'((grouptable id sz2) (id id sz2) (sz2 sz2 id)))$
set!*inverse('z2,'((id sz2) (id sz2)))$
set!*elemasgen('z2,'(((sz2) (sz2))))$
set!*group('z2,'((id) (sz2)))$
set!*representation('z2,'((id (((1 . 1)))) (sz2 (((1 . 1))))),'complex)$
set!*representation('z2,
  '((id (((1 . 1)))) (sz2 (((-1 . 1))))),'complex)$
set!*representation('z2,
  '(realtype (id (((1 . 1)))) (sz2 (((1 . 1))))),'real)$
set!*representation('z2,
  '(realtype (id (((1 . 1)))) (sz2 (((-1 . 1))))),'real)$
set!*available 'z2$

set!*elems!*group('k4,'(id s1k4 s2k4 rk4))$
set!*generators('k4,'(s1k4 s2k4))$
set!*relations('k4,
               '(((s1k4 s1k4) (id))
                 ((s2k4 s2k4) (id))
                 ((s1k4 s2k4) (s2k4 s1k4))))$
set!*grouptable('k4,
                '((grouptable id s1k4 s2k4 rk4)
                  (id id s1k4 s2k4 rk4)
                  (s1k4 s1k4 id rk4 s2k4)
                  (s2k4 s2k4 rk4 id s1k4)
                  (rk4 rk4 s2k4 s1k4 id)))$
set!*inverse('k4,'((id s1k4 s2k4 rk4) (id s1k4 s2k4 rk4)))$
set!*elemasgen('k4,
  '(((s1k4) (s1k4)) ((s2k4) (s2k4)) ((rk4) (s1k4 s2k4))))$
set!*group('k4,'((id) (s1k4) (s2k4) (rk4)))$
set!*representation('k4,
                    '((id (((1 . 1))))
                      (s1k4 (((1 . 1))))
                      (s2k4 (((1 . 1))))
                      (rk4 (((1 . 1))))),'complex)$
set!*representation('k4,
                    '((id (((1 . 1))))
                      (s1k4 (((-1 . 1))))
                      (s2k4 (((1 . 1))))
                      (rk4 (((-1 . 1))))),'complex)$
set!*representation('k4,
                    '((id (((1 . 1))))
                      (s1k4 (((1 . 1))))
                      (s2k4 (((-1 . 1))))
                      (rk4 (((-1 . 1))))),'complex)$
set!*representation('k4,
                    '((id (((1 . 1))))
                      (s1k4 (((-1 . 1))))
                      (s2k4 (((-1 . 1))))
                      (rk4 (((1 . 1))))),'complex)$
set!*representation('k4,
                    '(realtype
                      (id (((1 . 1))))
                      (s1k4 (((1 . 1))))
                      (s2k4 (((1 . 1))))
                      (rk4 (((1 . 1))))),'real)$
set!*representation('k4,
                    '(realtype
                      (id (((1 . 1))))
                      (s1k4 (((-1 . 1))))
                      (s2k4 (((1 . 1))))
                      (rk4 (((-1 . 1))))),'real)$
set!*representation('k4,
                    '(realtype
                      (id (((1 . 1))))
                      (s1k4 (((1 . 1))))
                      (s2k4 (((-1 . 1))))
                      (rk4 (((-1 . 1))))),'real)$
set!*representation('k4,
                    '(realtype
                      (id (((1 . 1))))
                      (s1k4 (((-1 . 1))))
                      (s2k4 (((-1 . 1))))
                      (rk4 (((1 . 1))))),'real)$
set!*available 'k4$

set!*elems!*group('d3,'(id rd3 rot2d3 sd3 srd3 sr2d3))$
set!*generators('d3,'(rd3 sd3))$
set!*relations('d3,
               '(((sd3 sd3) (id))
                 ((rd3 rd3 rd3) (id))
                 ((sd3 rd3 sd3) (rd3 rd3))))$
set!*grouptable('d3,
                '((grouptable id rd3 rot2d3 sd3 srd3 sr2d3)
                  (id id rd3 rot2d3 sd3 srd3 sr2d3)
                  (rd3 rd3 rot2d3 id sr2d3 sd3 srd3)
                  (rot2d3 rot2d3 id rd3 srd3 sr2d3 sd3)
                  (sd3 sd3 srd3 sr2d3 id rd3 rot2d3)
                  (srd3 srd3 sr2d3 sd3 rot2d3 id rd3)
                  (sr2d3 sr2d3 sd3 srd3 rd3 rot2d3 id)))$
set!*inverse('d3,
   '((id rd3 rot2d3 sd3 srd3 sr2d3) (id rot2d3 rd3 sd3 srd3 sr2d3)))$
set!*elemasgen('d3,
               '(((rd3) (rd3))
                 ((rot2d3) (rd3 rd3))
                 ((sd3) (sd3))
                 ((srd3) (sd3 rd3))
                 ((sr2d3) (sd3 rd3 rd3))))$
set!*group('d3,'((id) (rd3 rot2d3) (sr2d3 sd3 srd3)))$
set!*representation('d3,
                    '((id (((1 . 1))))
                      (rd3 (((1 . 1))))
                      (rot2d3 (((1 . 1))))
                      (sd3 (((1 . 1))))
                      (srd3 (((1 . 1))))
                      (sr2d3 (((1 . 1))))),'complex)$
set!*representation('d3,
                    '((id (((1 . 1))))
                      (rd3 (((1 . 1))))
                      (rot2d3 (((1 . 1))))
                      (sd3 (((-1 . 1))))
                      (srd3 (((-1 . 1))))
                      (sr2d3 (((-1 . 1))))),'complex)$
set!*representation('d3,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd3
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (rot2d3
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (sd3 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd3
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr2d3
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (1 . 2))))),'complex)$
set!*representation('d3,
                    '(realtype
                      (id (((1 . 1))))
                      (rd3 (((1 . 1))))
                      (rot2d3 (((1 . 1))))
                      (sd3 (((1 . 1))))
                      (srd3 (((1 . 1))))
                      (sr2d3 (((1 . 1))))),'real)$
set!*representation('d3,
                    '(realtype
                      (id (((1 . 1))))
                      (rd3 (((1 . 1))))
                      (rot2d3 (((1 . 1))))
                      (sd3 (((-1 . 1))))
                      (srd3 (((-1 . 1))))
                      (sr2d3 (((-1 . 1))))),'real)$
set!*representation('d3,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd3
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (rot2d3
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (sd3 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd3
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr2d3
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (1 . 2))))),'real)$
set!*available 'd3$

set!*elems!*group('d4,'(id rd4 rot2d4 rot3d4 sd4 srd4 sr2d4 sr3d4))$
set!*generators('d4,'(rd4 sd4))$
set!*relations('d4,
               '(((sd4 sd4) (id))
                 ((rd4 rd4 rd4 rd4) (id))
                 ((sd4 rd4 sd4) (rd4 rd4 rd4))))$
set!*grouptable('d4,
                '((grouptable id rd4 rot2d4 rot3d4 sd4 srd4 sr2d4 sr3d4)
                  (id id rd4 rot2d4 rot3d4 sd4 srd4 sr2d4 sr3d4)
                  (rd4 rd4 rot2d4 rot3d4 id sr3d4 sd4 srd4 sr2d4)
                  (rot2d4 rot2d4 rot3d4 id rd4 sr2d4 sr3d4 sd4 srd4)
                  (rot3d4 rot3d4 id rd4 rot2d4 srd4 sr2d4 sr3d4 sd4)
                  (sd4 sd4 srd4 sr2d4 sr3d4 id rd4 rot2d4 rot3d4)
                  (srd4 srd4 sr2d4 sr3d4 sd4 rot3d4 id rd4 rot2d4)
                  (sr2d4 sr2d4 sr3d4 sd4 srd4 rot2d4 rot3d4 id rd4)
                  (sr3d4 sr3d4 sd4 srd4 sr2d4 rd4 rot2d4 rot3d4 id)))$
set!*inverse('d4,
             '((id rd4 rot2d4 rot3d4 sd4 srd4 sr2d4 sr3d4)
               (id rot3d4 rot2d4 rd4 sd4 srd4 sr2d4 sr3d4)))$
set!*elemasgen('d4,
               '(((rd4) (rd4))
                 ((rot2d4) (rd4 rd4))
                 ((rot3d4) (rd4 rd4 rd4))
                 ((sd4) (sd4))
                 ((srd4) (sd4 rd4))
                 ((sr2d4) (sd4 rd4 rd4))
                 ((sr3d4) (sd4 rd4 rd4 rd4))))$
set!*group('d4,'((id) (rd4 rot3d4) (rot2d4) (sd4 sr2d4) (sr3d4 srd4)))$
set!*representation('d4,
                    '((id (((1 . 1))))
                      (rd4 (((1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((1 . 1))))
                      (sd4 (((1 . 1))))
                      (srd4 (((1 . 1))))
                      (sr2d4 (((1 . 1))))
                      (sr3d4 (((1 . 1))))),'complex)$
set!*representation('d4,
                    '((id (((1 . 1))))
                      (rd4 (((1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((1 . 1))))
                      (sd4 (((-1 . 1))))
                      (srd4 (((-1 . 1))))
                      (sr2d4 (((-1 . 1))))
                      (sr3d4 (((-1 . 1))))),'complex)$
set!*representation('d4,
                    '((id (((1 . 1))))
                      (rd4 (((-1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((-1 . 1))))
                      (sd4 (((1 . 1))))
                      (srd4 (((-1 . 1))))
                      (sr2d4 (((1 . 1))))
                      (sr3d4 (((-1 . 1))))),'complex)$
set!*representation('d4,
                    '((id (((1 . 1))))
                      (rd4 (((-1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((-1 . 1))))
                      (sd4 (((-1 . 1))))
                      (srd4 (((1 . 1))))
                      (sr2d4 (((-1 . 1))))
                      (sr3d4 (((1 . 1))))),'complex)$
set!*representation('d4,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd4 (((nil . 1) (1 . 1)) ((-1 . 1) (nil . 1))))
                 (rot2d4 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                 (rot3d4 (((nil . 1) (-1 . 1)) ((1 . 1) (nil . 1))))
                      (sd4 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd4 (((nil . 1) (1 . 1)) ((1 . 1) (nil . 1))))
                      (sr2d4 (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                 (sr3d4 (((nil . 1) (-1 . 1)) ((-1 . 1) (nil . 1))))),
                    'complex)$
set!*representation('d4,
                    '(realtype
                      (id (((1 . 1))))
                      (rd4 (((1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((1 . 1))))
                      (sd4 (((1 . 1))))
                      (srd4 (((1 . 1))))
                      (sr2d4 (((1 . 1))))
                      (sr3d4 (((1 . 1))))),'real)$
set!*representation('d4,
                    '(realtype
                      (id (((1 . 1))))
                      (rd4 (((1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((1 . 1))))
                      (sd4 (((-1 . 1))))
                      (srd4 (((-1 . 1))))
                      (sr2d4 (((-1 . 1))))
                      (sr3d4 (((-1 . 1))))),'real)$
set!*representation('d4,
                    '(realtype
                      (id (((1 . 1))))
                      (rd4 (((-1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((-1 . 1))))
                      (sd4 (((1 . 1))))
                      (srd4 (((-1 . 1))))
                      (sr2d4 (((1 . 1))))
                      (sr3d4 (((-1 . 1))))),'real)$
set!*representation('d4,
                    '(realtype
                      (id (((1 . 1))))
                      (rd4 (((-1 . 1))))
                      (rot2d4 (((1 . 1))))
                      (rot3d4 (((-1 . 1))))
                      (sd4 (((-1 . 1))))
                      (srd4 (((1 . 1))))
                      (sr2d4 (((-1 . 1))))
                      (sr3d4 (((1 . 1))))),'real)$
set!*representation('d4,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd4 (((nil . 1) (1 . 1)) ((-1 . 1) (nil . 1))))
                  (rot2d4 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                  (rot3d4 (((nil . 1) (-1 . 1)) ((1 . 1) (nil . 1))))
                      (sd4 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd4 (((nil . 1) (1 . 1)) ((1 . 1) (nil . 1))))
                  (sr2d4 (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                  (sr3d4 (((nil . 1) (-1 . 1)) ((-1 . 1) (nil . 1))))),
                    'real)$
set!*available 'd4$

set!*elems!*group('d5,
   '(id rd5 r2d5 r3d5 r4d5 sd5 srd5 sr2d5 sr3d5 sr4d5))$
set!*generators('d5,'(rd5 sd5))$
set!*relations('d5,
               '(((sd5 sd5) (id))
                 ((rd5 rd5 rd5 rd5 rd5) (id))
                 ((sd5 rd5 sd5) (rd5 rd5 rd5 rd5))))$
set!*grouptable('d5,
      '((grouptable id rd5 r2d5 r3d5 r4d5 sd5 srd5 sr2d5 sr3d5 sr4d5)
               (id id rd5 r2d5 r3d5 r4d5 sd5 srd5 sr2d5 sr3d5 sr4d5)
               (rd5 rd5 r2d5 r3d5 r4d5 id sr4d5 sd5 srd5 sr2d5 sr3d5)
               (r2d5 r2d5 r3d5 r4d5 id rd5 sr3d5 sr4d5 sd5 srd5 sr2d5)
               (r3d5 r3d5 r4d5 id rd5 r2d5 sr2d5 sr3d5 sr4d5 sd5 srd5)
               (r4d5 r4d5 id rd5 r2d5 r3d5 srd5 sr2d5 sr3d5 sr4d5 sd5)
               (sd5 sd5 srd5 sr2d5 sr3d5 sr4d5 id rd5 r2d5 r3d5 r4d5)
               (srd5 srd5 sr2d5 sr3d5 sr4d5 sd5 r4d5 id rd5 r2d5 r3d5)
               (sr2d5 sr2d5 sr3d5 sr4d5 sd5 srd5 r3d5 r4d5 id rd5 r2d5)
               (sr3d5 sr3d5 sr4d5 sd5 srd5 sr2d5 r2d5 r3d5 r4d5 id rd5)
        (sr4d5 sr4d5 sd5 srd5 sr2d5 sr3d5 rd5 r2d5 r3d5 r4d5 id)))$
set!*inverse('d5,
             '((id rd5 r2d5 r3d5 r4d5 sd5 srd5 sr2d5 sr3d5 sr4d5)
               (id r4d5 r3d5 r2d5 rd5 sd5 srd5 sr2d5 sr3d5 sr4d5)))$
set!*elemasgen('d5,
               '(((rd5) (rd5))
                 ((r2d5) (rd5 rd5))
                 ((r3d5) (rd5 rd5 rd5))
                 ((r4d5) (rd5 rd5 rd5 rd5))
                 ((sd5) (sd5))
                 ((srd5) (sd5 rd5))
                 ((sr2d5) (sd5 rd5 rd5))
                 ((sr3d5) (sd5 rd5 rd5 rd5))
                 ((sr4d5) (sd5 rd5 rd5 rd5 rd5))))$
set!*group('d5,
 '((id) (rd5 r4d5) (r2d5 r3d5) (srd5 sr2d5 sd5 sr4d5 sr3d5)))$
set!*representation('d5,
                    '((id (((1 . 1))))
                      (rd5 (((1 . 1))))
                      (r2d5 (((1 . 1))))
                      (r3d5 (((1 . 1))))
                      (r4d5 (((1 . 1))))
                      (sd5 (((1 . 1))))
                      (srd5 (((1 . 1))))
                      (sr2d5 (((1 . 1))))
                      (sr3d5 (((1 . 1))))
                      (sr4d5 (((1 . 1))))),'complex)$
set!*representation('d5,
                    '((id (((1 . 1))))
                      (rd5 (((1 . 1))))
                      (r2d5 (((1 . 1))))
                      (r3d5 (((1 . 1))))
                      (r4d5 (((1 . 1))))
                      (sd5 (((-1 . 1))))
                      (srd5 (((-1 . 1))))
                      (sr2d5 (((-1 . 1))))
                      (sr3d5 (((-1 . 1))))
                      (sr4d5 (((-1 . 1))))),'complex)$
set!*representation('d5,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd5
                  (((((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                  (((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1))
                  ((((((sin (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                  (((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1))))
                      (r2d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 1)
                    (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 1)
                    (((cos (quotient (times 2 pi) 5)) . 1) . 2)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2)
                      (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                     (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                     (((cos (quotient (times 2 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2)
                        (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                     (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4d5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                        (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3)
                          (((cos (quotient (times 2 pi) 5)) . 1) . -4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1))))
                      (sd5 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd5
                  (((((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                  (((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1))
                  ((((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1)
               (((((cos (quotient (times 2 pi) 5)) . 1) . -1)) . 1))))
                      (sr2d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 1)
                        (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -1))
                          . 1))))
                      (sr3d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . -1))
                          . 1))))
                      (sr4d5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 4) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                            (((cos (quotient (times 2 pi) 5)) . 2) . 6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . -1))
                          . 1))))),'complex)$
set!*representation('d5,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd5
                   (((((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                   (((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1))
                   ((((((sin (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                (((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1))))
                      (r2d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 1) . 2)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4d5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1))))
                      (sd5 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd5
                 (((((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                 (((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1))
                 ((((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1)
                 (((((cos (quotient (times 4 pi) 5)) . 1) . -1)) . 1))))
                      (sr2d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 2) . -1))
                          . 1))))
                      (sr3d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                       . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . -1))
                          . 1))))
                      (sr4d5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 4) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                            (((cos (quotient (times 4 pi) 5)) . 2) . 6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . -1))
                          . 1))))),'complex)$
set!*representation('d5,
                    '(realtype
                      (id (((1 . 1))))
                      (rd5 (((1 . 1))))
                      (r2d5 (((1 . 1))))
                      (r3d5 (((1 . 1))))
                      (r4d5 (((1 . 1))))
                      (sd5 (((1 . 1))))
                      (srd5 (((1 . 1))))
                      (sr2d5 (((1 . 1))))
                      (sr3d5 (((1 . 1))))
                      (sr4d5 (((1 . 1))))),'real)$
set!*representation('d5,
                    '(realtype
                      (id (((1 . 1))))
                      (rd5 (((1 . 1))))
                      (r2d5 (((1 . 1))))
                      (r3d5 (((1 . 1))))
                      (r4d5 (((1 . 1))))
                      (sd5 (((-1 . 1))))
                      (srd5 (((-1 . 1))))
                      (sr2d5 (((-1 . 1))))
                      (sr3d5 (((-1 . 1))))
                      (sr4d5 (((-1 . 1))))),'real)$
set!*representation('d5,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd5
                 (((((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                  (((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1))
                   ((((((sin (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                 (((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1))))
                      (r2d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 1)
                        (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 1) . 2)))
                        . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                         (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4d5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3)
                          (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                          (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3)
                           (((cos (quotient (times 2 pi) 5)) . 1) . -4))
                          (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1))))
                      (sd5 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd5
                 (((((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                 (((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1))
                 ((((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1)
                (((((cos (quotient (times 2 pi) 5)) . 1) . -1)) . 1))))
                      (sr2d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 1)
                        (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 1)
                       (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                        . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2) . 1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . -1))
                          . 1))))
                      (sr3d5
                       (((((((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . -1))
                          . 1))))
                      (sr4d5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 4) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                            (((cos (quotient (times 2 pi) 5)) . 2) . 6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . -1))
                          . 1))))),'real)$
set!*representation('d5,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd5
                  (((((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                   (((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1))
                   ((((((sin (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                  (((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1))))
                   (r2d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                        . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 1) . 2)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2)
                        (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                         (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4d5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                         (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3)
                           (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3)
                           (((cos (quotient (times 4 pi) 5)) . 1) . -4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1))))
                      (sd5 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd5
                  (((((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                   (((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1))
                   ((((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1)
               (((((cos (quotient (times 4 pi) 5)) . 1) . -1)) . 1))))
                      (sr2d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                       . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -1))
                         . 1))))
                      (sr3d5
                       (((((((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . -1))
                          . 1))))
                      (sr4d5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3)
                           (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 4) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                            (((cos (quotient (times 4 pi) 5)) . 2) . 6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . -1))
                          . 1))))),'real)$
set!*available 'd5$

set!*elems!*group('d6,
                  '(id
                    rd6
                    r2d6
                    r3d6
                    r4d6
                    r5d6
                    sd6
                    srd6
                    sr2d6
                    sr3d6
                    sr4d6
                    sr5d6))$
set!*generators('d6,'(rd6 sd6))$
set!*relations('d6,
               '(((sd6 sd6) (id))
                 ((rd6 rd6 rd6 rd6 rd6 rd6) (id))
                 ((sd6 rd6 sd6) (rd6 rd6 rd6 rd6 rd6))))$
set!*grouptable('d6,
                '((grouptable
                   id
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6)
                  (id
                   id
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6)
                  (rd6
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   id
                   sr5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6)
                  (r2d6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   id
                   rd6
                   sr4d6
                   sr5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6)
                  (r3d6
                   r3d6
                   r4d6
                   r5d6
                   id
                   rd6
                   r2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6
                   srd6
                   sr2d6)
                  (r4d6
                   r4d6
                   r5d6
                   id
                   rd6
                   r2d6
                   r3d6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6
                   srd6)
                  (r5d6
                   r5d6
                   id
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6)
                  (sd6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   id
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   r5d6)
                  (srd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6
                   r5d6
                   id
                   rd6
                   r2d6
                   r3d6
                   r4d6)
                  (sr2d6
                   sr2d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6
                   srd6
                   r4d6
                   r5d6
                   id
                   rd6
                   r2d6
                   r3d6)
                  (sr3d6
                   sr3d6
                   sr4d6
                   sr5d6
                   sd6
                   srd6
                   sr2d6
                   r3d6
                   r4d6
                   r5d6
                   id
                   rd6
                   r2d6)
                  (sr4d6
                   sr4d6
                   sr5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   id
                   rd6)
                  (sr5d6
                   sr5d6
                   sd6
                   srd6
                   sr2d6
                   sr3d6
                   sr4d6
                   rd6
                   r2d6
                   r3d6
                   r4d6
                   r5d6
                   id)))$
set!*inverse('d6,
       '((id rd6 r2d6 r3d6 r4d6 r5d6 sd6 srd6 sr2d6 sr3d6 sr4d6 sr5d6)
       (id r5d6 r4d6 r3d6 r2d6 rd6 sd6 srd6 sr2d6 sr3d6 sr4d6 sr5d6)))$
set!*elemasgen('d6,
               '(((rd6) (rd6))
                 ((r2d6) (rd6 rd6))
                 ((r3d6) (rd6 rd6 rd6))
                 ((r4d6) (rd6 rd6 rd6 rd6))
                 ((r5d6) (rd6 rd6 rd6 rd6 rd6))
                 ((sd6) (sd6))
                 ((srd6) (sd6 rd6))
                 ((sr2d6) (sd6 rd6 rd6))
                 ((sr3d6) (sd6 rd6 rd6 rd6))
                 ((sr4d6) (sd6 rd6 rd6 rd6 rd6))
                 ((sr5d6) (sd6 rd6 rd6 rd6 rd6 rd6))))$
set!*group('d6,
           '((id)
             (rd6 r5d6)
             (r2d6 r4d6)
             (r3d6)
             (sr2d6 sd6 sr4d6)
             (srd6 sr5d6 sr3d6)))$
set!*representation('d6,
                    '((id (((1 . 1))))
                      (rd6 (((1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((1 . 1))))
                      (sd6 (((1 . 1))))
                      (srd6 (((1 . 1))))
                      (sr2d6 (((1 . 1))))
                      (sr3d6 (((1 . 1))))
                      (sr4d6 (((1 . 1))))
                      (sr5d6 (((1 . 1))))),'complex)$
set!*representation('d6,
                    '((id (((1 . 1))))
                      (rd6 (((1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((1 . 1))))
                      (sd6 (((-1 . 1))))
                      (srd6 (((-1 . 1))))
                      (sr2d6 (((-1 . 1))))
                      (sr3d6 (((-1 . 1))))
                      (sr4d6 (((-1 . 1))))
                      (sr5d6 (((-1 . 1))))),'complex)$
set!*representation('d6,
                    '((id (((1 . 1))))
                      (rd6 (((-1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((-1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((-1 . 1))))
                      (sd6 (((1 . 1))))
                      (srd6 (((-1 . 1))))
                      (sr2d6 (((1 . 1))))
                      (sr3d6 (((-1 . 1))))
                      (sr4d6 (((1 . 1))))
                      (sr5d6 (((-1 . 1))))),'complex)$
set!*representation('d6,
                    '((id (((1 . 1))))
                      (rd6 (((-1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((-1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((-1 . 1))))
                      (sd6 (((-1 . 1))))
                      (srd6 (((1 . 1))))
                      (sr2d6 (((-1 . 1))))
                      (sr3d6 (((1 . 1))))
                      (sr4d6 (((-1 . 1))))
                      (sr5d6 (((1 . 1))))),'complex)$
set!*representation('d6,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd6
                  (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                      (r2d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                  (r3d6 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (r4d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r5d6
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sd6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd6
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (sr2d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                   (sr3d6 (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (sr4d6
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                      (sr5d6
              (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                   ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))),'complex)$
set!*representation('d6,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r2d6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r3d6 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (r4d6
                 (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                 ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r5d6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (sd6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr2d6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                      (sr3d6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (sr4d6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr5d6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                (1 . 2))))),'complex)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1))))
                      (rd6 (((1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((1 . 1))))
                      (sd6 (((1 . 1))))
                      (srd6 (((1 . 1))))
                      (sr2d6 (((1 . 1))))
                      (sr3d6 (((1 . 1))))
                      (sr4d6 (((1 . 1))))
                      (sr5d6 (((1 . 1))))),'real)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1))))
                      (rd6 (((1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((1 . 1))))
                      (sd6 (((-1 . 1))))
                      (srd6 (((-1 . 1))))
                      (sr2d6 (((-1 . 1))))
                      (sr3d6 (((-1 . 1))))
                      (sr4d6 (((-1 . 1))))
                      (sr5d6 (((-1 . 1))))),'real)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1))))
                      (rd6 (((-1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((-1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((-1 . 1))))
                      (sd6 (((1 . 1))))
                      (srd6 (((-1 . 1))))
                      (sr2d6 (((1 . 1))))
                      (sr3d6 (((-1 . 1))))
                      (sr4d6 (((1 . 1))))
                      (sr5d6 (((-1 . 1))))),'real)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1))))
                      (rd6 (((-1 . 1))))
                      (r2d6 (((1 . 1))))
                      (r3d6 (((-1 . 1))))
                      (r4d6 (((1 . 1))))
                      (r5d6 (((-1 . 1))))
                      (sd6 (((-1 . 1))))
                      (srd6 (((1 . 1))))
                      (sr2d6 (((-1 . 1))))
                      (sr3d6 (((1 . 1))))
                      (sr4d6 (((-1 . 1))))
                      (sr5d6 (((1 . 1))))),'real)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd6
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                      (r2d6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r3d6 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (r4d6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r5d6
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sd6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd6
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (sr2d6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                    (sr3d6 (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (sr4d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                      (sr5d6
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))),'real)$
set!*representation('d6,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rd6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r2d6
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                     (r3d6 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (r4d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r5d6
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
            ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                    (sd6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (srd6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr2d6
             (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
             ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2) (1 . 2))))
                   (sr3d6 (((1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (sr4d6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (sr5d6
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (1 . 2))))),'real)$
set!*available 'd6$

set!*elems!*group('c3,'(id rc3 r2c3))$
set!*generators('c3,'(rc3))$
set!*relations('c3,'(((rc3 rc3 rc3) (id))))$
set!*grouptable('c3,
                '((grouptable id rc3 r2c3)
                  (id id rc3 r2c3)
                  (rc3 rc3 r2c3 id)
                  (r2c3 r2c3 id rc3)))$
set!*inverse('c3,'((id rc3 r2c3) (id r2c3 rc3)))$
set!*elemasgen('c3,'(((rc3) (rc3)) ((r2c3) (rc3 rc3))))$
set!*group('c3,'((id) (rc3) (r2c3)))$
set!*representation('c3,
             '((id (((1 . 1)))) (rc3 (((1 . 1)))) (r2c3 (((1 . 1))))),
                    'complex)$
set!*representation('c3,
                    '((id (((1 . 1))))
                      (rc3
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r2c3
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))),'complex)$
set!*representation('c3,
                    '((id (((1 . 1))))
                      (rc3
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r2c3
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))),'complex)$
set!*representation('c3,
                    '(realtype
                      (id (((1 . 1))))
                      (rc3 (((1 . 1))))
                      (r2c3 (((1 . 1))))),'real)$
set!*representation('c3,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc3
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r2c3
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))),'real)$
set!*available 'c3$

set!*elems!*group('c4,'(id rc4 r2c4 r3c4))$
set!*generators('c4,'(rc4))$
set!*relations('c4,'(((rc4 rc4 rc4 rc4) (id))))$
set!*grouptable('c4,
                '((grouptable id rc4 r2c4 r3c4)
                  (id id rc4 r2c4 r3c4)
                  (rc4 rc4 r2c4 r3c4 id)
                  (r2c4 r2c4 r3c4 id rc4)
                  (r3c4 r3c4 id rc4 r2c4)))$
set!*inverse('c4,'((id rc4 r2c4 r3c4) (id r3c4 r2c4 rc4)))$
set!*elemasgen('c4,
    '(((rc4) (rc4)) ((r2c4) (rc4 rc4)) ((r3c4) (rc4 rc4 rc4))))$
set!*group('c4,'((id) (rc4) (r2c4) (r3c4)))$
set!*representation('c4,
                    '((id (((1 . 1))))
                      (rc4 (((1 . 1))))
                      (r2c4 (((1 . 1))))
                      (r3c4 (((1 . 1))))),'complex)$
set!*representation('c4,
                    '((id (((1 . 1))))
                      (rc4 (((-1 . 1))))
                      (r2c4 (((1 . 1))))
                      (r3c4 (((-1 . 1))))),'complex)$
set!*representation('c4,
                    '((id (((1 . 1))))
                      (rc4 ((((((i . 1) . 1)) . 1))))
                      (r2c4 (((-1 . 1))))
                      (r3c4 ((((((i . 1) . -1)) . 1))))),'complex)$
set!*representation('c4,
                    '((id (((1 . 1))))
                      (rc4 ((((((i . 1) . -1)) . 1))))
                      (r2c4 (((-1 . 1))))
                      (r3c4 ((((((i . 1) . 1)) . 1))))),'complex)$
set!*representation('c4,
                    '(realtype
                      (id (((1 . 1))))
                      (rc4 (((1 . 1))))
                      (r2c4 (((1 . 1))))
                      (r3c4 (((1 . 1))))),'real)$
set!*representation('c4,
                    '(realtype
                      (id (((1 . 1))))
                      (rc4 (((-1 . 1))))
                      (r2c4 (((1 . 1))))
                      (r3c4 (((-1 . 1))))),'real)$
set!*representation('c4,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc4 (((nil . 1) (-1 . 1)) ((1 . 1) (nil . 1))))
                      (r2c4 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
             (r3c4 (((nil . 1) (1 . 1)) ((-1 . 1) (nil . 1))))),'real)$
set!*available 'c4$

set!*elems!*group('c5,'(id rc5 r2c5 r3c5 r4c5))$
set!*generators('c5,'(rc5))$
set!*relations('c5,'(((rc5 rc5 rc5 rc5 rc5) (id))))$
set!*grouptable('c5,
                '((grouptable id rc5 r2c5 r3c5 r4c5)
                  (id id rc5 r2c5 r3c5 r4c5)
                  (rc5 rc5 r2c5 r3c5 r4c5 id)
                  (r2c5 r2c5 r3c5 r4c5 id rc5)
                  (r3c5 r3c5 r4c5 id rc5 r2c5)
                  (r4c5 r4c5 id rc5 r2c5 r3c5)))$
set!*inverse('c5,'((id rc5 r2c5 r3c5 r4c5) (id r4c5 r3c5 r2c5 rc5)))$
set!*elemasgen('c5,
               '(((rc5) (rc5))
                 ((r2c5) (rc5 rc5))
                 ((r3c5) (rc5 rc5 rc5))
                 ((r4c5) (rc5 rc5 rc5 rc5))))$
set!*group('c5,'((id) (rc5) (r2c5) (r3c5) (r4c5)))$
set!*representation('c5,
                    '((id (((1 . 1))))
                      (rc5 (((1 . 1))))
                      (r2c5 (((1 . 1))))
                      (r3c5 (((1 . 1))))
                      (r4c5 (((1 . 1))))),'complex)$
set!*representation('c5,
                    '((id (((1 . 1))))
                      (rc5
              (((((((sin (quotient (times 2 pi) 5)) . 1) ((i . 1) . 1))
                           (((cos (quotient (times 2 pi) 5)) . 1) . 1))
                          . 1))))
                      (r2c5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 1)
                             ((i . 1) . 2)))
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
                       (((((((sin (quotient (times 2 pi) 5)) . 3)
                            ((i . 1) . -1))
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 2)
                             ((i . 1) . 3)))
                         (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1)
                             ((i . 1) . -4)))
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 3)
                             ((i . 1) . 4)))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1))))),'complex)$
set!*representation('c5,
                    '((id (((1 . 1))))
                      (rc5
             (((((((sin (quotient (times 4 pi) 5)) . 1) ((i . 1) . 1))
                           (((cos (quotient (times 4 pi) 5)) . 1) . 1))
                          . 1))))
                      (r2c5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 1)
                             ((i . 1) . 2)))
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
                       (((((((sin (quotient (times 4 pi) 5)) . 3)
                            ((i . 1) . -1))
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 2)
                             ((i . 1) . 3)))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1)
                             ((i . 1) . -4)))
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 3)
                             ((i . 1) . 4)))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1))))),'complex)$
set!*representation('c5,
                    '((id (((1 . 1))))
                      (rc5
                       (((((((sin (quotient (times 4 pi) 5)) . 1)
                            ((i . 1) . -1))
                           (((cos (quotient (times 4 pi) 5)) . 1) . 1))
                          . 1))))
                      (r2c5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 1)
                             ((i . 1) . -2)))
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
               (((((((sin (quotient (times 4 pi) 5)) . 3) ((i . 1) . 1))
                           (((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 2)
                             ((i . 1) . -3)))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1)
                             ((i . 1) . 4)))
                           (((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                            (((cos (quotient (times 4 pi) 5)) . 3)
                             ((i . 1) . -4)))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1))))),'complex)$
set!*representation('c5,
                    '((id (((1 . 1))))
                      (rc5
                       (((((((sin (quotient (times 2 pi) 5)) . 1)
                            ((i . 1) . -1))
                           (((cos (quotient (times 2 pi) 5)) . 1) . 1))
                          . 1))))
                      (r2c5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 1)
                             ((i . 1) . -2)))
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
             (((((((sin (quotient (times 2 pi) 5)) . 3) ((i . 1) . 1))
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 2)
                             ((i . 1) . -3)))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1)
                             ((i . 1) . 4)))
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                            (((cos (quotient (times 2 pi) 5)) . 3)
                             ((i . 1) . -4)))
                        (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1))))),'complex)$
set!*representation('c5,
                    '(realtype
                      (id (((1 . 1))))
                      (rc5 (((1 . 1))))
                      (r2c5 (((1 . 1))))
                      (r3c5 (((1 . 1))))
                      (r4c5 (((1 . 1))))),'real)$
set!*representation('c5,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc5
                 (((((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                 (((((sin (quotient (times 2 pi) 5)) . 1) . -1)) . 1))
                  ((((((sin (quotient (times 2 pi) 5)) . 1) . 1)) . 1)
                (((((cos (quotient (times 2 pi) 5)) . 1) . 1)) . 1))))
                      (r2c5
                       (((((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 1) . 2)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 2 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
                       (((((((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 2 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                          (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 3)
                            (((cos (quotient (times 2 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                          (((cos (quotient (times 2 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 2 pi) 5)) . 3)
                         (((cos (quotient (times 2 pi) 5)) . 1) . -4))
                           (((sin (quotient (times 2 pi) 5)) . 1)
                         (((cos (quotient (times 2 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 2 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 2 pi) 5)) . 2)
                         (((cos (quotient (times 2 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 2 pi) 5)) . 4) . 1))
                          . 1))))),'real)$
set!*representation('c5,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc5
                  (((((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                  (((((sin (quotient (times 4 pi) 5)) . 1) . -1)) . 1))
                   ((((((sin (quotient (times 4 pi) 5)) . 1) . 1)) . 1)
                 (((((cos (quotient (times 4 pi) 5)) . 1) . 1)) . 1))))
                      (r2c5
                       (((((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 1) . -2)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 1) . 2)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2) . -1)
                           (((cos (quotient (times 4 pi) 5)) . 2) . 1))
                          . 1))))
                      (r3c5
                       (((((((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . -3)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3) . -1)
                           (((sin (quotient (times 4 pi) 5)) . 1)
                         (((cos (quotient (times 4 pi) 5)) . 2) . 3)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 2)
                         (((cos (quotient (times 4 pi) 5)) . 1) . -3))
                           (((cos (quotient (times 4 pi) 5)) . 3) . 1))
                          . 1))))
                      (r4c5
                       (((((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 3)
                            (((cos (quotient (times 4 pi) 5)) . 1) . 4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                        (((cos (quotient (times 4 pi) 5)) . 3) . -4)))
                          . 1))
                        ((((((sin (quotient (times 4 pi) 5)) . 3)
                          (((cos (quotient (times 4 pi) 5)) . 1) . -4))
                           (((sin (quotient (times 4 pi) 5)) . 1)
                          (((cos (quotient (times 4 pi) 5)) . 3) . 4)))
                          . 1)
                         (((((sin (quotient (times 4 pi) 5)) . 4) . 1)
                           (((sin (quotient (times 4 pi) 5)) . 2)
                          (((cos (quotient (times 4 pi) 5)) . 2) . -6))
                           (((cos (quotient (times 4 pi) 5)) . 4) . 1))
                          . 1))))),'real)$
set!*available 'c5$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symdata2.red0000644000175000017500000021436611526203062024631 0ustar  giovannigiovannimodule symdata2; %  Symmetry data, part 2.

% Author: Karin Gatermann .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


set!*elems!*group('c6,'(id rc6 r2c6 r3c6 r4c6 r5c6))$
set!*generators('c6,'(rc6))$
set!*relations('c6,'(((rc6 rc6 rc6 rc6 rc6 rc6) (id))))$
set!*grouptable('c6,
                '((grouptable id rc6 r2c6 r3c6 r4c6 r5c6)
                  (id id rc6 r2c6 r3c6 r4c6 r5c6)
                  (rc6 rc6 r2c6 r3c6 r4c6 r5c6 id)
                  (r2c6 r2c6 r3c6 r4c6 r5c6 id rc6)
                  (r3c6 r3c6 r4c6 r5c6 id rc6 r2c6)
                  (r4c6 r4c6 r5c6 id rc6 r2c6 r3c6)
                  (r5c6 r5c6 id rc6 r2c6 r3c6 r4c6)))$
set!*inverse('c6,
  '((id rc6 r2c6 r3c6 r4c6 r5c6) (id r5c6 r4c6 r3c6 r2c6 rc6)))$
set!*elemasgen('c6,
               '(((rc6) (rc6))
                 ((r2c6) (rc6 rc6))
                 ((r3c6) (rc6 rc6 rc6))
                 ((r4c6) (rc6 rc6 rc6 rc6))
                 ((r5c6) (rc6 rc6 rc6 rc6 rc6))))$
set!*group('c6,'((id) (rc6) (r2c6) (r3c6) (r4c6) (r5c6)))$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6 (((1 . 1))))
                      (r2c6 (((1 . 1))))
                      (r3c6 (((1 . 1))))
                      (r4c6 (((1 . 1))))
                      (r5c6 (((1 . 1))))),'complex)$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6 (((-1 . 1))))
                      (r2c6 (((1 . 1))))
                      (r3c6 (((-1 . 1))))
                      (r4c6 (((1 . 1))))
                      (r5c6 (((-1 . 1))))),'complex)$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6
                (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . 1)
                       . 2))))
                      (r2c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r3c6 (((-1 . 1))))
                      (r4c6
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r5c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . 1)
                          . 2))))),'complex)$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r2c6
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r3c6 (((1 . 1))))
                      (r4c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r5c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                       . 2))))),'complex)$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r2c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r3c6 (((1 . 1))))
                      (r4c6
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r5c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                        . 2))))),'complex)$
set!*representation('c6,
                    '((id (((1 . 1))))
                      (rc6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . 1)
                          . 2))))
                      (r2c6
              (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1)) . -1)
                          . 2))))
                      (r3c6 (((-1 . 1))))
                      (r4c6
               (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . -1)
                          . 2))))
                      (r5c6
                (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1)) . 1)
                          . 2))))),'complex)$
set!*representation('c6,
                    '(realtype
                      (id (((1 . 1))))
                      (rc6 (((1 . 1))))
                      (r2c6 (((1 . 1))))
                      (r3c6 (((1 . 1))))
                      (r4c6 (((1 . 1))))
                      (r5c6 (((1 . 1))))),'real)$
set!*representation('c6,
                    '(realtype
                      (id (((1 . 1))))
                      (rc6 (((-1 . 1))))
                      (r2c6 (((1 . 1))))
                      (r3c6 (((-1 . 1))))
                      (r4c6 (((1 . 1))))
                      (r5c6 (((-1 . 1))))),'real)$
set!*representation('c6,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc6
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (1 . 2))))
                      (r2c6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                     (r3c6 (((-1 . 1) (nil . 1)) ((nil . 1) (-1 . 1))))
                      (r4c6
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r5c6
                 (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (1 . 2))))),'real)$
set!*representation('c6,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (rc6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r2c6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (r3c6 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (r4c6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (r5c6
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))),'real)$
set!*available 'c6$

set!*elems!*group('s4,
                  '(id
                    bacd
                    acbd
                    abdc
                    dbca
                    cabd
                    bcad
                    dacb
                    bdca
                    dbac
                    cbda
                    adbc
                    acdb
                    badc
                    cdab
                    dcba
                    cbad
                    adcb
                    bcda
                    bdac
                    cadb
                    dabc
                    cdba
                    dcab))$
set!*generators('s4,'(bacd acbd abdc dbca))$
set!*relations('s4,
               '(((bacd bacd) (id))
                 ((acbd acbd) (id))
                 ((abdc abdc) (id))
                 ((dbca) (bacd acbd abdc acbd bacd))))$
set!*grouptable('s4,
                '((grouptable
                   dcab
                   dcba
                   dbac
                   dbca
                   dabc
                   dacb
                   cdab
                   cdba
                   cbad
                   cbda
                   cabd
                   cadb
                   bdac
                   bdca
                   bcad
                   bcda
                   bacd
                   badc
                   adbc
                   adcb
                   acbd
                   acdb
                   id
                   abdc)
                  (dcab
                   badc
                   abdc
                   cadb
                   acdb
                   cbda
                   bcda
                   bacd
                   id
                   dacb
                   adcb
                   dbca
                   bdca
                   cabd
                   acbd
                   dabc
                   adbc
                   dcba
                   cdba
                   cbad
                   bcad
                   dbac
                   bdac
                   dcab
                   cdab)
                  (dcba
                   bacd
                   id
                   cabd
                   acbd
                   cbad
                   bcad
                   badc
                   abdc
                   dabc
                   adbc
                   dbac
                   bdac
                   cadb
                   acdb
                   dacb
                   adcb
                   dcab
                   cdab
                   cbda
                   bcda
                   dbca
                   bdca
                   dcba
                   cdba)
                  (dbac
                   bcda
                   acdb
                   cbda
                   abdc
                   cadb
                   badc
                   bdca
                   adcb
                   dbca
                   id
                   dacb
                   bacd
                   cdba
                   adbc
                   dcba
                   acbd
                   dabc
                   cabd
                   cdab
                   bdac
                   dcab
                   bcad
                   dbac
                   cbad)
                  (dbca
                   bcad
                   acbd
                   cbad
                   id
                   cabd
                   bacd
                   bdac
                   adbc
                   dbac
                   abdc
                   dabc
                   badc
                   cdab
                   adcb
                   dcab
                   acdb
                   dacb
                   cadb
                   cdba
                   bdca
                   dcba
                   bcda
                   dbca
                   cbda)
                  (dabc
                   bdca
                   adcb
                   cdba
                   adbc
                   cdab
                   bdac
                   bcda
                   acdb
                   dcba
                   acbd
                   dcab
                   bcad
                   cbda
                   abdc
                   dbca
                   id
                   dbac
                   cbad
                   cadb
                   badc
                   dacb
                   bacd
                   dabc
                   cabd)
                  (dacb
                   bdac
                   adbc
                   cdab
                   adcb
                   cdba
                   bdca
                   bcad
                   acbd
                   dcab
                   acdb
                   dcba
                   bcda
                   cbad
                   id
                   dbac
                   abdc
                   dbca
                   cbda
                   cabd
                   bacd
                   dabc
                   badc
                   dacb
                   cadb)
                  (cdab
                   abdc
                   badc
                   acdb
                   cadb
                   bcda
                   cbda
                   id
                   bacd
                   adcb
                   dacb
                   bdca
                   dbca
                   acbd
                   cabd
                   adbc
                   dabc
                   cdba
                   dcba
                   bcad
                   cbad
                   bdac
                   dbac
                   cdab
                   dcab)
                  (cdba
                   id
                   bacd
                   acbd
                   cabd
                   bcad
                   cbad
                   abdc
                   badc
                   adbc
                   dabc
                   bdac
                   dbac
                   acdb
                   cadb
                   adcb
                   dacb
                   cdab
                   dcab
                   bcda
                   cbda
                   bdca
                   dbca
                   cdba
                   dcba)
                  (cbad
                   acdb
                   bcda
                   abdc
                   cbda
                   badc
                   cadb
                   adcb
                   bdca
                   id
                   dbca
                   bacd
                   dacb
                   adbc
                   cdba
                   acbd
                   dcba
                   cabd
                   dabc
                   bdac
                   cdab
                   bcad
                   dcab
                   cbad
                   dbac)
                  (cbda
                   acbd
                   bcad
                   id
                   cbad
                   bacd
                   cabd
                   adbc
                   bdac
                   abdc
                   dbac
                   badc
                   dabc
                   adcb
                   cdab
                   acdb
                   dcab
                   cadb
                   dacb
                   bdca
                   cdba
                   bcda
                   dcba
                   cbda
                   dbca)
                  (cabd
                   adcb
                   bdca
                   adbc
                   cdba
                   bdac
                   cdab
                   acdb
                   bcda
                   acbd
                   dcba
                   bcad
                   dcab
                   abdc
                   cbda
                   id
                   dbca
                   cbad
                   dbac
                   badc
                   cadb
                   bacd
                   dacb
                   cabd
                   dabc)
                  (cadb
                   adbc
                   bdac
                   adcb
                   cdab
                   bdca
                   cdba
                   acbd
                   bcad
                   acdb
                   dcab
                   bcda
                   dcba
                   id
                   cbad
                   abdc
                   dbac
                   cbda
                   dbca
                   bacd
                   cabd
                   badc
                   dabc
                   cadb
                   dacb)
                  (bdac
                   cbda
                   cadb
                   bcda
                   badc
                   acdb
                   abdc
                   dbca
                   dacb
                   bdca
                   bacd
                   adcb
                   id
                   dcba
                   dabc
                   cdba
                   cabd
                   adbc
                   acbd
                   dcab
                   dbac
                   cdab
                   cbad
                   bdac
                   bcad)
                  (bdca
                   cbad
                   cabd
                   bcad
                   bacd
                   acbd
                   id
                   dbac
                   dabc
                   bdac
                   badc
                   adbc
                   abdc
                   dcab
                   dacb
                   cdab
                   cadb
                   adcb
                   acdb
                   dcba
                   dbca
                   cdba
                   cbda
                   bdca
                   bcda)
                  (bcad
                   cadb
                   cbda
                   badc
                   bcda
                   abdc
                   acdb
                   dacb
                   dbca
                   bacd
                   bdca
                   id
                   adcb
                   dabc
                   dcba
                   cabd
                   cdba
                   acbd
                   adbc
                   dbac
                   dcab
                   cbad
                   cdab
                   bcad
                   bdac)
                  (bcda
                   cabd
                   cbad
                   bacd
                   bcad
                   id
                   acbd
                   dabc
                   dbac
                   badc
                   bdac
                   abdc
                   adbc
                   dacb
                   dcab
                   cadb
                   cdab
                   acdb
                   adcb
                   dbca
                   dcba
                   cbda
                   cdba
                   bcda
                   bdca)
                  (bacd
                   cdab
                   cdba
                   bdac
                   bdca
                   adbc
                   adcb
                   dcab
                   dcba
                   bcad
                   bcda
                   acbd
                   acdb
                   dbac
                   dbca
                   cbad
                   cbda
                   id
                   abdc
                   dabc
                   dacb
                   cabd
                   cadb
                   bacd
                   badc)
                  (badc
                   cdba
                   cdab
                   bdca
                   bdac
                   adcb
                   adbc
                   dcba
                   dcab
                   bcda
                   bcad
                   acdb
                   acbd
                   dbca
                   dbac
                   cbda
                   cbad
                   abdc
                   id
                   dacb
                   dabc
                   cadb
                   cabd
                   badc
                   bacd)
                  (adbc
                   dbca
                   dacb
                   dcba
                   dabc
                   dcab
                   dbac
                   cbda
                   cadb
                   cdba
                   cabd
                   cdab
                   cbad
                   bcda
                   badc
                   bdca
                   bacd
                   bdac
                   bcad
                   acdb
                   abdc
                   adcb
                   id
                   adbc
                   acbd)
                  (adcb
                   dbac
                   dabc
                   dcab
                   dacb
                   dcba
                   dbca
                   cbad
                   cabd
                   cdab
                   cadb
                   cdba
                   cbda
                   bcad
                   bacd
                   bdac
                   badc
                   bdca
                   bcda
                   acbd
                   id
                   adbc
                   abdc
                   adcb
                   acdb)
                  (acbd
                   dacb
                   dbca
                   dabc
                   dcba
                   dbac
                   dcab
                   cadb
                   cbda
                   cabd
                   cdba
                   cbad
                   cdab
                   badc
                   bcda
                   bacd
                   bdca
                   bcad
                   bdac
                   abdc
                   acdb
                   id
                   adcb
                   acbd
                   adbc)
                  (acdb
                   dabc
                   dbac
                   dacb
                   dcab
                   dbca
                   dcba
                   cabd
                   cbad
                   cadb
                   cdab
                   cbda
                   cdba
                   bacd
                   bcad
                   badc
                   bdac
                   bcda
                   bdca
                   id
                   acbd
                   abdc
                   adbc
                   acdb
                   adcb)
                  (id
                   dcab
                   dcba
                   dbac
                   dbca
                   dabc
                   dacb
                   cdab
                   cdba
                   cbad
                   cbda
                   cabd
                   cadb
                   bdac
                   bdca
                   bcad
                   bcda
                   bacd
                   badc
                   adbc
                   adcb
                   acbd
                   acdb
                   id
                   abdc)
                  (abdc
                   dcba
                   dcab
                   dbca
                   dbac
                   dacb
                   dabc
                   cdba
                   cdab
                   cbda
                   cbad
                   cadb
                   cabd
                   bdca
                   bdac
                   bcda
                   bcad
                   badc
                   bacd
                   adcb
                   adbc
                   acdb
                   acbd
                   abdc
                   id)))$
set!*inverse('s4,
             '((dcab
                dcba
                dbac
                dbca
                dabc
                dacb
                cdab
                cdba
                cbad
                cbda
                cabd
                cadb
                bdac
                bdca
                bcad
                bcda
                bacd
                badc
                adbc
                adcb
                acbd
                acdb
                id
                abdc)
               (cdba
                dcba
                cbda
                dbca
                bcda
                bdca
                cdab
                dcab
                cbad
                dbac
                bcad
                bdac
                cadb
                dacb
                cabd
                dabc
                bacd
                badc
                acdb
                adcb
                acbd
                adbc
                id
                abdc)))$
set!*elemasgen('s4,
               '(((bacd) (bacd))
                 ((acbd) (acbd))
                 ((abdc) (abdc))
                 ((dbca) (dbca))
                 ((cabd) (bacd acbd))
                 ((bcad) (acbd bacd))
                 ((dacb) (dbca bacd))
                 ((bdca) (bacd dbca))
                 ((dbac) (abdc dbca))
                 ((cbda) (dbca abdc))
                 ((adbc) (acbd abdc))
                 ((acdb) (abdc acbd))
                 ((badc) (bacd abdc))
                 ((cdab) (abdc bacd acbd dbca))
                 ((dcba) (acbd dbca))
                 ((cbad) (bacd acbd bacd))
                 ((adcb) (dbca bacd dbca))
                 ((bcda) (abdc acbd bacd))
                 ((bdac) (acbd bacd abdc))
                 ((cadb) (abdc bacd acbd))
                 ((dabc) (bacd acbd abdc))
                 ((cdba) (bacd acbd dbca))
                 ((dcab) (abdc acbd dbca))))$
set!*group('s4,
           '((dcab dabc cadb bdac bcda cdba)
             (dcba badc cdab)
             (dbac dacb cabd adbc acdb bcad bdca cbda)
             (dbca adcb abdc acbd bacd cbad)
             (id)))$
set!*representation('s4,
                    '((id (((1 . 1))))
                      (bacd (((1 . 1))))
                      (acbd (((1 . 1))))
                      (abdc (((1 . 1))))
                      (dbca (((1 . 1))))
                      (cabd (((1 . 1))))
                      (bcad (((1 . 1))))
                      (dacb (((1 . 1))))
                      (bdca (((1 . 1))))
                      (dbac (((1 . 1))))
                      (cbda (((1 . 1))))
                      (adbc (((1 . 1))))
                      (acdb (((1 . 1))))
                      (badc (((1 . 1))))
                      (cdab (((1 . 1))))
                      (dcba (((1 . 1))))
                      (cbad (((1 . 1))))
                      (adcb (((1 . 1))))
                      (bcda (((1 . 1))))
                      (bdac (((1 . 1))))
                      (cadb (((1 . 1))))
                      (dabc (((1 . 1))))
                      (cdba (((1 . 1))))
                      (dcab (((1 . 1))))),'complex)$
set!*representation('s4,
                    '((id (((1 . 1))))
                      (bacd (((-1 . 1))))
                      (acbd (((-1 . 1))))
                      (abdc (((-1 . 1))))
                      (dbca (((-1 . 1))))
                      (cabd (((1 . 1))))
                      (bcad (((1 . 1))))
                      (dacb (((1 . 1))))
                      (bdca (((1 . 1))))
                      (dbac (((1 . 1))))
                      (cbda (((1 . 1))))
                      (adbc (((1 . 1))))
                      (acdb (((1 . 1))))
                      (badc (((1 . 1))))
                      (cdab (((1 . 1))))
                      (dcba (((1 . 1))))
                      (cbad (((-1 . 1))))
                      (adcb (((-1 . 1))))
                      (bcda (((-1 . 1))))
                      (bdac (((-1 . 1))))
                      (cadb (((-1 . 1))))
                      (dabc (((-1 . 1))))
                      (cdba (((-1 . 1))))
                      (dcab (((-1 . 1))))),'complex)$
set!*representation('s4,
                    '((id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bacd
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (acbd
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (abdc
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dbca
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (cabd
              (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (bcad
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                    ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (dacb
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (bdca
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dbac
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (cbda
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (adbc
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (acdb
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (badc (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cdab (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (dcba (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cbad (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (adcb (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bcda (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bdac
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (cadb
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                      ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (dabc (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cdba
                  (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dcab
                  (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))),'complex)$
set!*representation('s4,
                    '((id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (bacd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (acbd
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (abdc
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (dbca
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cabd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcad
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dacb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (bdca
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (dbac
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cbda
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (adbc
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acdb
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (badc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cdab
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dcba
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cbad
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (adcb
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (bcda
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (bdac
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cadb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dabc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cdba
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (dcab
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))),'complex)$
set!*representation('s4,
                    '((id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (bacd
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acbd
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (abdc
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dbca
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cabd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcad
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dacb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (bdca
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (dbac
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cbda
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (adbc
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acdb
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (badc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cdab
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dcba
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cbad
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (adcb
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcda
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bdac
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cadb
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (dabc
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (cdba
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dcab
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))),'complex)$
set!*representation('s4,
                    '(realtype
                      (id (((1 . 1))))
                      (bacd (((1 . 1))))
                      (acbd (((1 . 1))))
                      (abdc (((1 . 1))))
                      (dbca (((1 . 1))))
                      (cabd (((1 . 1))))
                      (bcad (((1 . 1))))
                      (dacb (((1 . 1))))
                      (bdca (((1 . 1))))
                      (dbac (((1 . 1))))
                      (cbda (((1 . 1))))
                      (adbc (((1 . 1))))
                      (acdb (((1 . 1))))
                      (badc (((1 . 1))))
                      (cdab (((1 . 1))))
                      (dcba (((1 . 1))))
                      (cbad (((1 . 1))))
                      (adcb (((1 . 1))))
                      (bcda (((1 . 1))))
                      (bdac (((1 . 1))))
                      (cadb (((1 . 1))))
                      (dabc (((1 . 1))))
                      (cdba (((1 . 1))))
                      (dcab (((1 . 1))))),'real)$
set!*representation('s4,
                    '(realtype
                      (id (((1 . 1))))
                      (bacd (((-1 . 1))))
                      (acbd (((-1 . 1))))
                      (abdc (((-1 . 1))))
                      (dbca (((-1 . 1))))
                      (cabd (((1 . 1))))
                      (bcad (((1 . 1))))
                      (dacb (((1 . 1))))
                      (bdca (((1 . 1))))
                      (dbac (((1 . 1))))
                      (cbda (((1 . 1))))
                      (adbc (((1 . 1))))
                      (acdb (((1 . 1))))
                      (badc (((1 . 1))))
                      (cdab (((1 . 1))))
                      (dcba (((1 . 1))))
                      (cbad (((-1 . 1))))
                      (adcb (((-1 . 1))))
                      (bcda (((-1 . 1))))
                      (bdac (((-1 . 1))))
                      (cadb (((-1 . 1))))
                      (dabc (((-1 . 1))))
                      (cdba (((-1 . 1))))
                      (dcab (((-1 . 1))))),'real)$
set!*representation('s4,
                    '(realtype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bacd
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (acbd
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (abdc
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
              ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dbca
               (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (cabd
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (bcad
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                      ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (dacb
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (bdca
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dbac
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (cbda
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (adbc
                (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (acdb
               (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
               ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (badc (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cdab (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (dcba (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cbad (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (adcb (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bcda (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (bdac
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (cadb
                (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . -1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (dabc (((-1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (cdba
                 (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2) (-1 . 2))))
                      (dcab
                 (((1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1)) . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))),'real)$
set!*representation('s4,
                    '(realtype
                      (id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (bacd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (acbd
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (abdc
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (dbca
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cabd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcad
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dacb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (bdca
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (dbac
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cbda
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (adbc
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acdb
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (badc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cdab
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dcba
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cbad
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (adcb
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (bcda
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (bdac
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cadb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dabc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cdba
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (dcab
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))),'real)$
set!*representation('s4,
                    '(realtype
                      (id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (bacd
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acbd
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (abdc
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dbca
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cabd
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcad
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dacb
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (bdca
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (dbac
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (cbda
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (adbc
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (acdb
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (badc
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (cdab
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (dcba
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cbad
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (adcb
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bcda
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (bdac
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (cadb
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (dabc
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (cdba
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (dcab
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))),'real)$
set!*available 's4$

set!*elems!*group('a4,
                  '(id ta4 t2a4 xa4 ya4 za4 txa4 tya4 tza4 t2xa4 t2ya4
                       t2za4))$
set!*generators('a4,'(ta4 xa4 ya4 za4))$
set!*relations('a4,
               '(((za4) (ta4 xa4 ta4 ta4))
                 ((ya4) (ta4 za4 ta4 ta4))
                 ((xa4) (ta4 ya4 ta4 ta4))
                 ((ta4 ta4 ta4) (id))
                 ((xa4 xa4) (id))
                 ((ya4 ya4) (id))
                 ((za4 za4) (id))
                 ((xa4 ya4) (za4))))$
set!*grouptable('a4,
                '((grouptable
                   id
                   ta4
                   t2a4
                   xa4
                   ya4
                   za4
                   txa4
                   tya4
                   tza4
                   t2xa4
                   t2ya4
                   t2za4)
                  (id id ta4 t2a4 xa4 ya4 za4 txa4 tya4 tza4 t2xa4
                      t2ya4 t2za4)
                  (ta4 ta4 t2a4 id txa4 tya4 tza4 t2xa4 t2ya4 t2za4 xa4
                       ya4 za4)
                  (t2a4
                   t2a4
                   id
                   ta4
                   t2xa4
                   t2ya4
                   t2za4
                   xa4
                   ya4
                   za4
                   txa4
                   tya4
                   tza4)
                  (xa4 xa4 tya4 t2za4 id za4 ya4 tza4 ta4 txa4 t2ya4
                       t2xa4 t2a4)
                  (ya4 ya4 tza4 t2xa4 za4 id xa4 tya4 txa4 ta4 t2a4
                       t2za4 t2ya4)
                  (za4 za4 txa4 t2ya4 ya4 xa4 id ta4 tza4 tya4 t2za4
                       t2a4 t2xa4)
                  (txa4
                   txa4
                   t2ya4
                   za4
                   ta4
                   tza4
                   tya4
                   t2za4
                   t2a4
                   t2xa4
                   ya4
                   xa4
                   id)
                  (tya4
                   tya4
                   t2za4
                   xa4
                   tza4
                   ta4
                   txa4
                   t2ya4
                   t2xa4
                   t2a4
                   id
                   za4
                   ya4)
                  (tza4
                   tza4
                   t2xa4
                   ya4
                   tya4
                   txa4
                   ta4
                   t2a4
                   t2za4
                   t2ya4
                   za4
                   id
                   xa4)
                  (t2xa4
                   t2xa4
                   ya4
                   tza4
                   t2a4
                   t2za4
                   t2ya4
                   za4
                   id
                   xa4
                   tya4
                   txa4
                   ta4)
                  (t2ya4
                   t2ya4
                   za4
                   txa4
                   t2za4
                   t2a4
                   t2xa4
                   ya4
                   xa4
                   id
                   ta4
                   tza4
                   tya4)
                  (t2za4
                   t2za4
                   xa4
                   tya4
                   t2ya4
                   t2xa4
                   t2a4
                   id
                   za4
                   ya4
                   tza4
                   ta4
                   txa4)))$
set!*inverse('a4,
            '((id ta4 t2a4 xa4 ya4 za4 txa4 tya4 tza4 t2xa4 t2ya4 t2za4)
              (id t2a4 ta4 xa4 ya4 za4 t2za4 t2xa4 t2ya4 tya4 tza4 txa4)
            ))$
set!*elemasgen('a4,
               '(((ta4) (ta4))
                 ((t2a4) (ta4 ta4))
                 ((xa4) (xa4))
                 ((ya4) (ya4))
                 ((za4) (za4))
                 ((txa4) (ta4 xa4))
                 ((tya4) (ta4 ya4))
                 ((tza4) (ta4 za4))
                 ((t2xa4) (ta4 ta4 xa4))
                 ((t2ya4) (ta4 ta4 ya4))
                 ((t2za4) (ta4 ta4 za4))))$
set!*group('a4,
           '((id) (txa4 ta4 tza4 tya4) (t2za4 t2a4 t2ya4 t2xa4)
                  (ya4 xa4 za4)))$
set!*representation('a4,
                    '((id (((1 . 1))))
                      (ta4 (((1 . 1))))
                      (t2a4 (((1 . 1))))
                      (xa4 (((1 . 1))))
                      (ya4 (((1 . 1))))
                      (za4 (((1 . 1))))
                      (txa4 (((1 . 1))))
                      (tya4 (((1 . 1))))
                      (tza4 (((1 . 1))))
                      (t2xa4 (((1 . 1))))
                      (t2ya4 (((1 . 1))))
                      (t2za4 (((1 . 1))))),'complex)$
set!*representation('a4,
                    '((id (((1 . 1))))
                      (ta4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (t2a4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (xa4 (((1 . 1))))
                      (ya4 (((1 . 1))))
                      (za4 (((1 . 1))))
                      (txa4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (tya4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (tza4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (t2xa4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (t2ya4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (t2za4
                      (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . -1))
                               . -1)
                          . 2))))),'complex)$
set!*representation('a4,
                    '((id (((1 . 1))))
                      (ta4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (t2a4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (xa4 (((1 . 1))))
                      (ya4 (((1 . 1))))
                      (za4 (((1 . 1))))
                      (txa4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (tya4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (tza4
                       (((((((expt 3 (quotient 1 2)) . 1)((i . 1) . -1))
                               . -1)
                          . 2))))
                      (t2xa4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (t2ya4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))
                      (t2za4
                       (((((((expt 3 (quotient 1 2)) . 1) ((i . 1) . 1))
                               . -1)
                          . 2))))),'complex)$
set!*representation('a4,
                    '((id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (ta4
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (t2a4
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (xa4
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (ya4
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (za4
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (txa4
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (tya4
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (tza4
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (t2xa4
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (t2ya4
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (t2za4
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))),'complex)$
set!*representation('a4,
                    '(realtype
                      (id (((1 . 1))))
                      (ta4 (((1 . 1))))
                      (t2a4 (((1 . 1))))
                      (xa4 (((1 . 1))))
                      (ya4 (((1 . 1))))
                      (za4 (((1 . 1))))
                      (txa4 (((1 . 1))))
                      (tya4 (((1 . 1))))
                      (tza4 (((1 . 1))))
                      (t2xa4 (((1 . 1))))
                      (t2ya4 (((1 . 1))))
                      (t2za4 (((1 . 1))))),'real)$
set!*representation('a4,
                    '(complextype
                      (id (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (ta4
                       (((-1 . 2)(((((expt 3 (quotient 1 2)) . 1) . 1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (t2a4
                       (((-1 . 2)(((((expt 3 (quotient 1 2)) . 1) . -1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))
                      (xa4 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (ya4 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (za4 (((1 . 1) (nil . 1)) ((nil . 1) (1 . 1))))
                      (txa4
                       (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (tya4
                       (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (tza4
                       (((-1 . 2) (((((expt 3 (quotient 1 2)) . 1) . 1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . -1)) . 2)
                         (-1 . 2))))
                      (t2xa4
                       (((-1 . 2)(((((expt 3 (quotient 1 2)) . 1) . -1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))
                      (t2ya4
                       (((-1 . 2)(((((expt 3 (quotient 1 2)) . 1) . -1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))
                      (t2za4
                       (((-1 . 2)(((((expt 3 (quotient 1 2)) . 1) . -1))
                                     . 2))
                        ((((((expt 3 (quotient 1 2)) . 1) . 1)) . 2)
                         (-1 . 2))))),'real)$
set!*representation('a4,
                    '(realtype
                      (id
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (ta4
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (t2a4
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (xa4
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (ya4
                       (((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))))
                      (za4
                       (((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))))
                      (txa4
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (1 . 1) (nil . 1))))
                      (tya4
                       (((nil . 1) (nil . 1) (1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (tza4
                       (((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))
                        ((nil . 1) (-1 . 1) (nil . 1))))
                      (t2xa4
                       (((nil . 1) (-1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))
                      (t2ya4
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (-1 . 1))
                        ((-1 . 1) (nil . 1) (nil . 1))))
                      (t2za4
                       (((nil . 1) (1 . 1) (nil . 1))
                        ((nil . 1) (nil . 1) (1 . 1))
                        ((1 . 1) (nil . 1) (nil . 1))))),'real)$
set!*available 'a4$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/sympatch.red0000644000175000017500000000512711526203062024726 0ustar  giovannigiovannimodule sympatch;
% from rprint.red
load!_package 'rprint;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*n buffp combuff!* curmark curpos orig pretop pretoprinf rmar);

symbolic procedure rprint u;
   begin integer !*n; scalar buff,buffp,curmark,rmar,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      rmar := linelength nil;
      x := get('!*semicol!*,pretop);
      !*n := 0;
      mprino1(u,list(caar x,cadar x));
    %  prin2ox ";";
      prin2ox "$"; %3.11 91 KG
      omarko curmark;
      prinos buff
   end;

% error in treatment of roots in connection
% with conjugate of complex numbers

symbolic procedure reimexpt u;
   if cadr u eq 'e
     then addsq(reimcos list('cos,reval list('times,'i,caddr u)),
                multsq(simp list('minus,'i),
                    reimsin list('sin,reval list('times,'i,caddr u))))
    else if fixp cadr u and cadr u > 0
              and eqcar(caddr u,'quotient)
              and fixp cadr caddr u
              and fixp caddr caddr u
     then mksq(u,1)
    else addsq(mkrepart u,multsq(simp 'i,mkimpart u));

put('expt,'cmpxsplitfn,'reimexpt);
put('cos,'cmpxsplitfn,'reimcos);
put('sin,'cmpxsplitfn,'reimsin);
endmodule;

% algebraic repart(pi):=pi;   % Present in 3.4.1 and later versions.
% algebraic impart(pi):=0;

% error in treatment of roots in connection
% with conjugate of complex numbers
% end;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symmetry.hlp0000644000175000017500000000520411526203062024774 0ustar  giovannigiovanni\chapter{SYMMETRY: Operations on symmetric matrices}
\label{SYMMETRY}
\typeout{{SYMMETRY: Operations on symmetric matrices}}

{\footnotesize
\begin{center}
Karin Gatermann\\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
e--mail: gatermann@sc.zib-berlin.de
\end{center}
}
\ttindex{SYMMETRY}

The SYMMETRY package provides procedures
that compute symmetry-adapted bases and block diagonal forms
of matrices which have the symmetry of a group.

\section{Operators for linear representations}

The data structure for a linear representation, a {\em
representation}, is a list consisting of the group identifier and
equations which assign matrices to the generators of the group.

{\bf Example:}
\begin{verbatim}
   rr:=mat((0,1,0,0),
           (0,0,1,0),
           (0,0,0,1),
           (1,0,0,0));

   sp:=mat((0,1,0,0),
           (1,0,0,0),
           (0,0,0,1),
           (0,0,1,0));

   representation:={D4,rD4=rr,sD4=sp};
\end{verbatim}

For orthogonal (unitarian) representations the following operators
are available.

{\tt canonicaldecomposition(representation);}\ttindex{canonicaldecomposition}

returns an equation giving the canonical decomposition of the linear
representation.

{\tt character(representation);}\ttindex{character}

computes the character of the linear representation. The result is a list
of the group identifier and of lists consisting of a 
list of group elements in one equivalence class and a real or complex number.

{\tt symmetrybasis(representation,nr);}\ttindex{symmetrybasis}

computes the basis of the isotypic component corresponding to the irreducible
representation of type nr. If the nr-th irreducible representation is
multidimensional, the basis is symmetry adapted. The output is a matrix.
 
{\tt symmetrybasispart(representation,nr);}\ttindex{symmetrybasispart}

is similar as {\tt symmetrybasis}, but for multidimensional 
irreducible representations only the first part of the 
symmetry adapted basis is computed.

{\tt allsymmetrybases(representation);}\ttindex{allsymmetrybases}

is similar as {\tt symmetrybasis} and {\tt symmetrybasispart}, 
but the bases of all
isotypic components are computed and thus a 
complete coordinate transformation is returned.

{\tt diagonalize(matrix,representation);}\ttindex{diagonalize}

returns the block diagonal form of matrix which has the symmetry 
of the given linear representation. Otherwise an error message occurs.


\section{Display Operators}

Access is provided to the information for a group, and for adding
knowledge for other groups.  This is explained in detail in the
Symmetry on-line documentation.

mathpiper-0.81f+svn4469+dfsg3/src/packages/symmetry/symmetry.red0000644000175000017500000000536611526203062024774 0ustar  giovannigiovannimodule symmetry;
%
% ----------------------------------------------------------
%                       Symmetry Package
% ----------------------------------------------------------
%
% Author : Karin Gatermann
%          Konrad-Zuse-Zentrum fuer
%          Informationstechnik Berlin
%          Heilbronner Str. 10
%          W-1000 Berlin 31
%          Germany
%          Email: Gatermann@sc.ZIB-Berlin.de
%
% Version 1.0   9. December 1991
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Abstract:
% ---------
% This program is an implementation of the algorithm
% for computation of symmetry adapted bases from the
% theory of linear representations of finite grous.
% Projections for the computation of block diagonal form
% of matrices are computed having the symmetry of a group.
%
%
% REDUCE 3.4 is required.
%
% References:
% -----------
% J.-P. Serre, Linear Representations of Finite Groups.
% Springer, New York (1977).
% E. Stiefel, A. F{\"a}ssler, Gruppentheoretische
%  Methoden und ihre Anwendung. Teubner, Stuttgart (1979).
%  (English translation to appear by Birkh\"auser (1992)).
%
% Keywords:
% --------
%           linear representations, symmetry adapted bases,
%           matrix with the symmetry of a group,
%           block diagonalization
%
% symmetry.red
% definition of available algebraic operators


% To build a fast loading version of this package, the following
% sequence of commands should be used:

create!-package('(symmetry symdata1 symdata2),'(contrib symmetry));

load!-package 'symaux;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assert/0000755000175000017500000000000011722677364022027 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/assert/assertcheckfn.red0000644000175000017500000001000611526203062025321 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: assertcheckfn.red 724 2010-08-23 17:02:24Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2010 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

module assertcheckfn;

procedure sfpx(u);
   sfpx1(u,nil,nil,0);

procedure sfpx1(u,vl,v,d);
   % Variables from vl must not occur in u and the variable v must occur
   % in u only with a degress less than d. New-found main variables must
   % be smaller than v and smaller than all variables in vl wrt.
   % korder!* and orderp.
   begin scalar c,l,p,r,vv,vl1,w; integer dd;
      if domainp u then
	 return t;
      if not pairp u then
 	 return nil;
      % Decompose u as follows: u = l + r, l = c * p, p = vv ^ dd
      l := lt u;
      r := red u;
      if not pairp l then
 	 return nil;
      c := tc l;
      p := tpow l;
      if not pairp p then
 	 return nil;
      vv := car p;
      if not assert_kernelp vv then
	 return nil;
      dd := pdeg p;
      if vv eq v then
	 % We are considering a reductum and the variable has not changed.
	 return dd < d and sfpx1(c,v . vl,nil,0) and sfpx1(r,vl,v,dd);
      % We are considering the original form or an lc, or a reductum
      % where the variable has changed from v to vv.
      if v then
	 vl := v . vl;
      % vv must be smaller than all variables in vl wrt. the current
      % kernel order. By recursion, vl is sorted so that it is
      % suffiecient to compare with car vl. I construct linear powers in
      % order to use ordpp; I could not find a suitable function for
      % directly comparing (possibly composite) kernels. The relevant
      % code is mostly in alg/order.red and hardly documented.
      if vl and ordpp(vv .** 1,car vl .** 1) then
	 % We have seen a smaller variable before.
	 return nil;
      return sfpx1(c,vv . vl,nil,0) and sfpx1(r,vl,vv,dd)
   end;

procedure assert_kernelp(u);
   begin scalar w;
      if idp u then
 	 return t;
      if not pairp u then
 	 return nil;
      if get(car u,'fkernfn) then
	 return t;
      w := if atom car u then get(car u,'klist) else exlist!*;
      return atsoc(u,w)
   end;

procedure sfpx!*(u);
   % non-zero standard form predicate (extended).
   u and sfpx u;

procedure sqp(q);
   pairp q and sfpx numr q and sfpx denr q;

procedure alistp(l);
   not l or pairp car l and alistp cdr l;

procedure booleanp(u);
   u eq t or u eq nil;

procedure am_listp(u);
   listp u and eqcar(u,'list);

procedure am_polyp(u);
   domainp u or idp u or
      pairp u and (assert_polyopp car u or car u eq '!*sq and denr cadr u eq 1);

procedure assert_polyopp(op);
   op memq '(plus difference minus times expt);

endmodule;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/assert/assert.tst0000644000175000017500000000064111526203062024043 0ustar  giovannigiovannisymbolic;

typedef any;
typedef number checked by numberp;
typedef sf checked by sfpx;
typedef sq checked by sqp;

procedure hugo(x1,x2);
   x2;

assert hugo: (number,any) -> number;

assert_install hugo;

hugo(0,0);
hugo('x,0);
hugo(0,'x);

assert addf: (sf,sf) -> sf;
assert addsq: (sq,sq) -> sq;

assert_install addf,addsq;

addsq(simp 'x,numr simp 'x);

algebraic;

assert_analyze();

assert_uninstall_all;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/assert/assert.tex0000644000175000017500000002326211526203062024035 0ustar  giovannigiovanni\documentclass{article}

\usepackage[latin1]{inputenc}

\begin{document}

\title{ASSERT: Dynamic Verification of Assertions on Function Types}
\author{Thomas Sturm\\
Dpto.~de Matemticas Estadstica y Computacin\\
Universidad de Cantabria\\
39071 Santander, Spain\\
Email: \texttt{sturm@redlog.eu}}
\date{July 18, 2010}
\maketitle

\begin{abstract}
  ASSERT admits to add to symbolic mode RLISP code assertions (partly)
  specifying \emph{types} of the arguments and results of RLISP expr
  procedures. These types can be associated with functions testing the
  validity of the respective arguments during runtime.
\end{abstract}

\section{Loading and Using}
The package is loaded using \texttt{load\_package} or
\texttt{load!-package} in algebraic or symbolic mode, resp. There is a
central switch \texttt{assertcheck}, which is off by default. With
\texttt{assertcheck} off, all type definitions and assertions described
in the sequel are ignored and have the status of comments. For
verification of the assertions it most be turned on (dynamically) before
the first relevant type definition or assertion.

ASSERT aims at the dynamic analysis of RLISP expr procedure in symbolic
mode. All uses of \texttt{typedef} and \texttt{assert} discussed in the
following have to take place in symbolic mode. There is, in contrast, a
final print routine \texttt{assert\_analyze} that is available in both
symbolic and algebraic mode.

\section{Type Definitions}
Here are some examples for definitions of types:
\begin{verbatim}
typedef any;
typedef number checked by numberp;
typedef sf checked by sfpx;
typedef sq checked by sqp;
\end{verbatim}
The first one defines a type \texttt{any}, which is not possibly checked
by any function. This is useful, e.g., for functions which admit any
argument at one position but at others rely on certain types or
guarantee certain result types, e.g.,
\begin{verbatim}
procedure cellcnt(a);
   % a is any, returns a number.
   if not pairp a then 0 else cellcnt car a + cellcnt cdr a + 1;
\end{verbatim}

The other ones define a type \texttt{number}, which can be checked by
the RLISP function \texttt{numberp}, a type \texttt{sf} for standard
forms, which can be checked by the function \texttt{sfpx} provided by
ASSERT, and similarly a type for standard quotients.

All type checking functions take one argument and return extended
Boolean, i.e., non-nil iff their argument is of the corresponding type.

\section{Assertions}
Having defined types, we can formulate assertions on expr procedures in
terms of these types:
\begin{verbatim}
assert cellcnt: (any) -> number;
assert addsq: (sq,sq) -> sq;
\end{verbatim}
Note that on the argument side parenthesis are mandatory also with only
one argument. This notation is inspired by Haskell but avoids the
intuition of currying.\footnote{This notation has benn suggested by C. Zengler}

Assertions can be dynamically checked only for expr procedures. When
making assertions for other types of procedures, a warning is issued and
the assertion has the status of a comment.

It is important that assertions via assert come after the definitions of
the used types via \texttt{typedef} and also after the definition of the
procedures they make assertions on.

A natural order for adding type definitions and assertions to the source
code files would be to have all typedefs at the beginning of a module
and assertions immediately after the respective functions.
Fig.~\ref{FIG:assMod} illustrates this. Note that for dynamic checking
of the assertions the switch \texttt{assertcheck} has to be on during
the translation of the module; i.e., either when reading it with
\texttt{in} or during compilation. For compilation this can be achieved
by commenting in the \texttt{on assertcheck} at the beginning or by
parameterizing the Lisp-specific compilation scripts in a suitable way.

An alternative option is to have type definitions and assertions for
specific packages right after \texttt{load\_package} in batch files as
illustrated in Fig.~\ref{FIG:assBat}.
\begin{figure}
  \begin{small}
\begin{verbatim}
module sizetools;

load!-package 'assert;

% on assertcheck;

typedef any;
typedef number checked by number;

procedure cellcnt(a);
   % a is any, returns a number.
   if not pairp a then 0 else cellcnt car a + cellcnt cdr a + 1;

assert cellcnt: (any) -> number;

% ...

endmodule;

end;  % of file
\end{verbatim}
  \end{small}
  \caption{Assertions in the source code.\label{FIG:assMod}}
\end{figure}

\begin{figure}
  \begin{small}
\begin{verbatim}
load_package sizetools;
load_package assert;

on assertcheck;

lisp <<
   typedef any;
   typedef number checked by numberp;

   assert cellcnt: (any) -> number
>>;

% ... computations ...

assert_analyze();

end;  % of file
\end{verbatim}
  \end{small}
  \caption{Assertions in a batch file.\label{FIG:assBat}}
\end{figure}

\section{Dynamic Checking of Assertions}
Recall that with the switch \texttt{assertcheck} off at translation
time, all type definitions and assertions have the status of comments.
We are now going to discuss how these statements are processed with
\texttt{assertcheck} on.

\texttt{typedef} marks the type identifier as a valid type and possibly
associates the given typechecking function with it. Technically, the
property list of the type identifier is used for both purposes.

\texttt{assert} encapsulates the procedure that it asserts on into
another one, which checks the types of the arguments and of the result
to the extent that there are typechecking functions given. Whenever some
argument does not pass the test by the typechecking function, there is a
warning message issued. Furthermore, the following numbers are counted
for each asserted function:
\begin{enumerate}
\item The number of overall calls,
\item the number of calls with at least one assertion violation,
\item the number of assertion violations.
\end{enumerate}
These numbers can be printed anytime in either symbolic or algebraic
mode using the command \texttt{assert\_analyze()}. This command at the
same time resets all the counters.

Fig.~\ref{FIG:sample} shows an interactive sample session.
%
\begin{figure}
  \begin{small}
\begin{verbatim}
1: symbolic$

2* load_package assert$

3* on assertcheck$

4* typedef sq checked by sqp;
sqp

5* assert negsq: (sq) -> sq;
+++ negsq compiled, 13 + 20 bytes

(negsq)

6* assert addsq: (sq,sq) -> sq;
+++ addsq compiled, 14 + 20 bytes

(addsq)

7* addsq(simp 'x,negsq simp 'y);

((((x . 1) . 1) ((y . 1) . -1)) . 1)

8* addsq(simp 'x,negsq numr simp 'y);

*** assertion negsq: (sq) -> sq violated by arg1 (((y . 1) . 1))

*** assertion negsq: (sq) -> sq violated by result (((y . -1) . -1))

*** assertion addsq: (sq,sq) -> sq violated by arg2 (((y . -1) . -1))

*** assertion addsq: (sq,sq) -> sq violated by result (((y . -1) . -1))

(((y . -1) . -1))

9* assert_analyze()$
------------------------------------------------------------------------
function          #calls              #bad calls   #assertion violations
------------------------------------------------------------------------
addsq                  2                       1                       2
negsq                  2                       1                       2
------------------------------------------------------------------------
sum                    4                       2                       4
------------------------------------------------------------------------
\end{verbatim}
  \end{small}
  \caption{An interactive sample session.\label{FIG:sample}}
\end{figure}

\section{Switches}
As discussed above, the switch \texttt{assertcheck} controls at
translation time whether or not assertions are dynamically checked.

There is a switch \texttt{assertbreak}, which is off by default. When
on, there are not only warnings issued for assertion violations but the
computations is interrupted with a corresponding error.

The statistical counting of procedure calls and assertion violations is
toggled by the switch \texttt{assertstatistics}, which is on by default.

\section{Efficiency}
The encapsulating functions introduced with assertions are automatically
compiled.

% sturm@lennier[~/Desktop] time redpsl < taylor.tst > /dev/null

% real	0m0.798s
% user	0m0.584s
% sys	0m0.166s
% sturm@lennier[~/Desktop] time redcsl < taylor.tst > /dev/null

% real	0m1.975s
% user	0m1.808s
% sys	0m0.143s
% sturm@lennier[~/Desktop] time redpsl < taylor.tst > /dev/null

% real	0m0.442s
% user	0m0.316s
% sys	0m0.122s
% sturm@lennier[~/Desktop] time redcsl < taylor.tst > /dev/null

% real	0m0.610s
% user	0m0.491s
% sys	0m0.115s

We have experimentally checked assertions on the standard quotient
arithmetic \texttt{addsq}, \texttt{multsq}, \texttt{quotsq},
\texttt{invsq}, \texttt{negsq} for the test file \texttt{taylor.tst} of
the TAYLOR package. For CSL we observe a slowdown of factor 3.2, and for
PSL we observe a slowdown of factor 1.8 in this particular example,
where there are 323\,750 function calls checked altogether.

The ASSERT package is considered an analysis and debugging tool.
Production system should as a rule not run with dynamic assertion
checking. For critical applications, however, the slowdown might be
even acceptable.

\section{Possible Extensions}
Our assertions could be used also for a static type analysis of source
code. In that case, the type checking functions become irrelevant. On
the other hand, the introduction of variouse unchecked types becomes
meaningful.

In a model, where the source code is systematically annotated with
assertions, it is technically no problem to generalize the specification
of procedure definitions such that assertions become implicit. For
instance, one could \emph{optionally} admit procedure definitions like
the following:
\begin{verbatim}
procedure cellcnt(a:any):number;
   if not pairp a then 0 else cellcnt car a + cellcnt cdr a + 1;
\end{verbatim}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/assert/assert.red0000644000175000017500000003424311526203062024010 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: assert.red 977 2010-12-02 15:19:26Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2010 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(assert_rcsid!* assert_copyright!*);
   assert_rcsid!* := "$Id: assert.red 977 2010-12-02 15:19:26Z thomas-sturm $";
   assert_copyright!* := "(c) 2010 T. Sturm"
>>;

module assert;

create!-package('(assert assertcheckfn),nil);

global '(assert_functionl!* exlist !*comp);

fluid '(!*assert !*assertstatistics assertstatistics!* lispsystem!*);

switch assert,assertbreak,assertstatistics;

% The switch assert is a hook to make all stats introduced here return
% nil thus turning them into comments. Note that even when it is on,
% typedefs and assertions only modify property lists but do not change
% the behaviour of the system unless assert_install or
% assert_install_all is used. I thus switch it on by default for now.
on1 'assert;

off1 'assertbreak;
on1 'assertstatistics;

%% macro procedure assert_check(l);
%%    begin scalar f,origfn,progn,argl,w,w1,w2,w3,w4,w5,de,msg,code; integer n;
%%       f := cadr l;
%%       n := length cdr caddr l;
%%       if (w := get(f,'number!-of!-args)) and not eqn(w,n) then
%% 	 rederr {"bad number of args in ",l};
%%       origfn := get(f,'assert_origfn);
%%       if not origfn then  <<
%% 	 origfn := intern gensym();
%% 	 progn := {'copyd,mkquote origfn,mkquote f} . progn;
%%       	 progn := {'put,mkquote f,''assert_origfn,mkquote origfn} . progn
%%       >>;
%%       argl := for i := 1:n collect mkid('a,i);
%%       w1 := mkquote f;
%%       w2 := mkquote origfn;
%%       w3 := 'list . argl;
%%       w4 := 'list . for each fn in cdr caddr l collect mkquote fn;
%%       w5 := mkquote cadddr l;
%%       de := {'de,f,argl,{'assert_check1,w1,w2,w3,w4,w5}};
%%       progn := {{'lambda,'(!*comp),de},t} . progn;
%%       progn := 'progn . reversip progn;
%%       msg := {'list,mkquote f,"is not an expr procedure - ignoring assert"};
%%       code := {'cond,
%% 	 {{'not,{'eqcar,{'getd,mkquote f},''expr}},{'lprim,msg}},
%% 	 {t,progn}};
%%       return code
%%    end;

procedure assert_check1(fn,origfn,argl,argtypel,restype);
   % This is the wrapper code executed when an insertion is installed.
   % fn is the name of the original function; origfn is an identifier
   % having the original function as its function value; argl is the
   % list of arguments passed; argtypel is a list of types asserted for
   % the arguments in argl; restype is the type asserted for the result
   % of the function call. Depending on the swith !*assertstatistics,
   % there is statictical information added to the fluid
   % assertstatistics!*, which is output and deleted when calling
   % assert_analyze().
   begin scalar cfn,w,res,scargtypel,bad; integer n;
      if !*assertstatistics then <<
      	 w := atsoc(fn,assertstatistics!*);
      	 if w then
 	    cadr w := cadr w + 1
      	 else
 	    assertstatistics!* := (fn . {1,0,0}) . assertstatistics!*
      >>;
      scargtypel := argtypel;
      for each a in argl do <<
	 n := n + 1;
	 if (cfn := get(car scargtypel,'assert_checkfn))
 	    and not apply(cfn,{a})
 	 then <<
	    bad := t;
	    assert_error(fn,argtypel,restype,n,car scargtypel,a)
	 >>;
	 scargtypel := cdr scargtypel
      >>;
      res := apply(origfn,argl);
      if (cfn := get(restype,'assert_checkfn)) and not apply(cfn,{res}) then <<
	 bad := t;
	 assert_error(fn,argtypel,restype,0,restype,res)
      >>;
      if !*assertstatistics and bad then <<
      	 w := cdr atsoc(fn,assertstatistics!*);
	 cadr w := cadr w + 1
      >>;
      return res
   end;

procedure assert_error(fn,argtypel,restype,typeno,type,arg);
   % Subroutine of assert_check1 called in case of an assertion
   % violation. fn is the name of the original function; argtypel is a
   % list of types asserted for the arguments of the function call;
   % restype is the type asserted for the result of the function call;
   % typeno is an integer denoting which argument has violated an
   % assertion, where 0 stands for the result; type is the asserted type
   % for arg; arg is the argument violating an assertion. Depending on
   % the switch !*assertbreak, either the computation is interrupted
   % with a rederr or computation continues and the error
   % message is printed as a warning. In the latter case lprim is used,
   % which is controlled by the switch !*msg.
   begin scalar w,msg;
      if !*assertstatistics then <<
      	 w := cdr atsoc(fn,assertstatistics!*);
	 caddr w := caddr w + 1
      >>;
      msg := if eqn(typeno,0) then
%	 {"result of",fn,"invalid as",type,":",arg}
	 {"assertion",assert_format(fn,argtypel,restype),
	    "violated by result",arg}
      else
%	 {"argument",typeno,"of",fn,"invalid as",type,":",arg};
	 {"assertion",assert_format(fn,argtypel,restype),
	    "violated by",mkid('arg,typeno),arg};
      if !*assertbreak then
	 rederr msg
      else
	 lprim msg
   end;

procedure assert_format(fn,argtypel,restype);
   % fn is the original function name; argtypel is the list of types
   % asserted for the arguments; restype is the type asserted for the
   % result. Reconstructs the assertion as a identifier for printing in
   % diagnostic messages.
   begin scalar ass;
      ass := explode restype;
      ass := '!! . '!) . '!! . '! . '!! . '!- . '!! . '!> . '!! . '! . ass;
      for each a in reverse argtypel do
	 ass := '!! . '!, . nconc(explode a,ass);
      ass := cddr ass;
      ass := '!! . '!: . '!! . '! . '!! . '!( . ass;
      ass := nconc(explode fn,ass);
      return compress ass
   end;

procedure assert_typedefstat();
   % The parser for typedef. Returns a form that stores the type
   % checking function on the property list of the type.
   begin scalar type,cfn;
      type := scan();
      scan();
      if flagp(cursym!*,'delim) then <<
	 if not !*assert then
	    return nil;
	 if !*msg then lprim {"type",type,"is not checked"};
      	 return nil
      >>;
      if cursym!* neq 'checked then
	 rederr {"expecting 'checked by' in typedef but found",cursym!*};
      if scan() neq 'by then
	 rederr {"expecting 'by' in typedef but found",cursym!*};
      cfn := scan();
      if not flagp(scan(),'delim) then
	 rederr {"expecting end of typedef but found",cursym!*};
      if not !*assert then
	 return nil;
      return {'put,mkquote type,''assert_checkfn,mkquote cfn}
   end;

put('typedef,'stat,'assert_typedefstat);

operator assert_analyze;

procedure assert_analyze();
   % Print and delete the statistical information collected in the fluid
   % assertstatistics!*. This works in both algebraic and symbolic mode.
   begin scalar headline,footline; integer s1,s2,s3;
      assertstatistics!* := sort(assertstatistics!*,
	 function(lambda x,y; ordp(car y,car x)));
      for each pr in assertstatistics!* do <<
	 s1 := s1 + cadr pr;
	 s2 := s2 + caddr pr;
	 s3 := s3 + cadddr pr
      >>;
      headline := '(function . (!#calls  !#bad! calls !#assertion! violations));
      footline := 'SUM . {s1,s2,s3};
      assertstatistics!* := nil . headline . nil .
	 reversip(nil . footline . nil . assertstatistics!*);
      for each pr in assertstatistics!* do <<
	 if pr then <<
	    prin2 car pr;
	    for i := length explode2 car pr + length explode2 cadr pr : 23 do
 	       prin2 " ";
	    prin2 cadr pr;
	    for i := length explode2 caddr pr : 23 do prin2 " ";
	    prin2 caddr pr;
	    for i := length explode2 cadddr pr : 23 do prin2 " ";
	    prin2t cadddr pr
	 >> else <<
	    for i := 1:72 do prin2 "-";
	    terpri()
	 >>
      >>;
      assertstatistics!* := nil
   end;

%% procedure assert_stat();
%%    begin scalar fn,argtypel,restype;
%%       fn := scan();
%%       if scan() neq '!*colon!* then
%% 	 rederr {"expecting ':' in assert but found",cursym!*};
%%       argtypel := assert_stat1();
%%       if scan() neq 'difference or scan() neq 'greaterp then
%% 	 rederr {"expecting '->' in assert but found",cursym!*};
%%       restype := scan();
%%       if not flagp(scan(),'delim) then
%% 	 rederr {"expecting end of assert but found",cursym!*};
%%       if not !*assertcheck then
%% 	 return nil;
%%       return {'assert_check,fn,'list . argtypel,restype}
%%    end;

procedure assert_stat();
   % The parser for assert. Returns forms that define a suitable wrapper
   % function, store relevant information on the property list of the
   % original function, and add the original function to the global list
   % assert_functionl!*.
   begin scalar l,fnx,progn,assertfn,noassertfn,argl,w1,w2,w3,w4,w4,w5;
      integer i;
      l := assert_stat!-parse();
      if not !*assert then
 	    return nil;
      fnx := explode car l;
      assertfn := intern compress nconc(explode 'assert!:,fnx);
      noassertfn := intern compress nconc(explode 'noassert!:,fnx);
      argl := for each x in cadr l collect mkid('a,i := i + 1);
      w1 := mkquote car l;
      w2 := mkquote noassertfn;
      w3 := 'list . argl;
      w4 := 'list . for each fn in cadr l collect mkquote fn;
      w5 := mkquote caddr l;
      progn := {'de,assertfn,argl,{'assert_check1,w1,w2,w3,w4,w5}} . progn;
      progn := {'put,w1,''assert_assertfn,mkquote assertfn} . progn;
      progn := {'put,w1,''assert_noassertfn,w2} . progn;
      progn := {'put,w1,''assert_installed,nil} . progn;
      progn := {'cond,{
	 {'not,{'member,w1,'assert_functionl!*}},
	 {'setq,'assert_functionl!*,{'cons,w1,'assert_functionl!*}}}} . progn;
      return 'progn . reversip progn
   end;

procedure assert_stat!-parse();
   % Subroutine of assert_stat(). This is the actual parsing code.
   begin scalar fn,argtypel,restype;
      fn := scan();
      if scan() neq '!*colon!* then
	 rederr {"expecting ':' in assert but found",cursym!*};
      argtypel := assert_stat1();
      if scan() neq 'difference or scan() neq 'greaterp then
	 rederr {"expecting '->' in assert but found",cursym!*};
      restype := scan();
      if not flagp(scan(),'delim) then
	 rederr {"expecting end of assert but found",cursym!*};
      return {fn,argtypel,restype}
   end;

procedure assert_stat1();
   % Subroutine of assert_stat!-parse. Parses the tuple of argument
   % types left of the arrow.
   begin scalar argtypel;
      if scan() neq '!*lpar!* then
	 rederr {"expecting '(' in assert but found",cursym!*};
      if scan() eq '!*rpar!* then
	 return nil;
      repeat <<
	 argtypel := cursym!* . argtypel;
	 scan();
      	 if cursym!* neq '!*comma!* and cursym!* neq '!*rpar!* then
	    rederr {"expecting ',' or ')' in assert but found",cursym!*};
	 if cursym!* eq '!*comma!* then
	    scan()
      >> until cursym!* eq '!*rpar!*;
      return reversip argtypel
   end;

put('assert,'stat,'assert_stat);

procedure assert_install(fnl);
   % This is parsed as stat rlis, i.e., it takes a comma-separated list
   % fnl of arbirary length of arguments w/o parentesis. fnl is list of
   % identifiers that are functions for which an existing assertion is
   % installed.
   if !*assert then
      for each fn in fnl do assert_install1 fn;

put('assert_install,'stat,'rlis);

procedure assert_install1(fn);
   % fn is an identifier that is a single function for which an existing
   % assertion is installed.
   if get(fn,'assert_installed) then
      lprim {"assert already installed for",fn}
   else if not eqcar(getd fn,'expr) then
      lprim {fn,"is not an expr procedure - ignoring assert"}
   else <<
      copyd(get(fn,'assert_noassertfn),fn);
      copyd(fn,get(fn,'assert_assertfn));
      put(fn,'assert_installed,t)
   >>;

procedure assert_uninstall(fnl);
   % This is parsed as stat rlis, i.e., it takes a comma-separated list
   % fnl of arbirary length of arguments w/o parentesis. fnl is list of
   % identifiers that are functions for which an installed assertion is
   % uninstalled.
   if !*assert then
      for each fn in fnl do assert_uninstall1 fn;

put('assert_uninstall,'stat,'rlis);

procedure assert_uninstall1(fn);
   % fn is an identifier that is a single function for which an
   % installed assertion is uninstalled.
   if not get(fn,'assert_installed) then
      lprim {"assert not installed for",fn}
   else <<
      copyd(fn,get(fn,'assert_noassertfn));
      put(fn,'assert_installed,nil)
   >>;

procedure assert_install_all();
   % This is parsed as stat endstat, i.e., it takes no arguments but
   % also no empty pair of parenthesis. Installs assertions for the
   % functions in the global list assert_functionl!* of all functions
   % for which there are assertions defined.
   if !*assert then
      assert_install assert_functionl!*;

put('assert_install_all,'stat,'endstat);

procedure assert_uninstall_all();
   % This is parsed as stat endstat, i.e., it takes no arguments but
   % also no empty pair of parenthesis. Uninstalls assertions for the
   % functions in the global list assert_functionl!* of all functions
   % for which ther are assertions defined.
   if !*assert then
      assert_uninstall assert_functionl!*;

put('assert_uninstall_all,'stat,'endstat);

endmodule;  % assert

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/assert/assert.rlg0000644000175000017500000000341311527635055024031 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
symbolic;


nil


typedef any;
*** type any is not checked 



nil

typedef number checked by numberp;


numberp

typedef sf checked by sfpx;


sfpx

typedef sq checked by sqp;


sqp


procedure hugo(x1,x2);
   x2;
*** local variable x1 in procedure hugo not used 



hugo


assert hugo: (number,any) -> number;


(hugo)


assert_install hugo;


nil


hugo(0,0);


0

hugo('x,0);


*** assertion hugo: (number,any) -> number violated by arg1 x 

0

hugo(0,'x);


*** assertion hugo: (number,any) -> number violated by result x 

x


assert addf: (sf,sf) -> sf;


(addf hugo)

assert addsq: (sq,sq) -> sq;


(addsq addf hugo)


assert_install addf,addsq;


nil


addsq(simp 'x,numr simp 'x);


*** assertion addsq: (sq,sq) -> sq violated by arg2 (((x . 1) . 1)) 

*** assertion addf: (sf,sf) -> sf violated by arg2 ((x . 1) . 1) 

*** assertion addf: (sf,sf) -> sf violated by result ((x . 1) . 1) 

*** assertion addsq: (sq,sq) -> sq violated by result (((x . 1) . 1)) 

(((x . 1) . 1))


algebraic;



assert_analyze();

------------------------------------------------------------------------
function          #calls              #bad calls   #assertion violations
------------------------------------------------------------------------
addf                   1                       1                       2
addsq                  1                       1                       2
hugo                   3                       2                       2
------------------------------------------------------------------------
sum                    5                       4                       6
------------------------------------------------------------------------


assert_uninstall_all;



end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 3 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/0000755000175000017500000000000011722677361022315 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardian.txt0000644000175000017500000000234611526203062024636 0ustar  giovannigiovanniGUARDIAN:
An experimental REDUCE package for computing with guarded expressions
------------------------------------------------------------------------


This package requires the package REDLOG.

GUARDIAN has originally been described in the following technical report:

Andreas Dolzmann and Thomas Sturm. Guarded expressions in practice.
Technical Report MIP-9702, FMI, Universitaet Passau, D-94030 Passau,
Germany, January 1997.

A revised version of this report has appeared in:

Andreas Dolzmann and Thomas Sturm. Guarded expressions in practice. In
Wolfgang W. Kuechlin, editor, Proceedings of the 1997 International
Symposium on Symbolic and Algebraic Computation (ISSAC 97), pages
376-383, New York, July 1997. ACM, ACM Press.

The file guardian.tex in this directory is essentially the text of MIP-9702.

Switches and Commands:

1. Use the switch "guardian" for turning the GUARDIAN on/off. After
loading the package, it is on. Note that REDLOG procedures cannot be
called with "guardian" on.

2. The "smart mode" is toggled by the switch "gdsmart." It is on by
default.

3. Output mode can be selected using the function "gdomode." Possible
choices:
   a) gdomode matrix;
   b) gdomode gcase;
   c) gdomode gterm;


Thomas Sturm, October 2009
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardian.rlg0000755000175000017500000000202711527635055024616 0ustar  giovannigiovanniFri Feb 18 21:29:01 2011 run on win32
1 / (x^2+2*x+1);


[                  1       ]
[x + 1 <> 0  --------------]
[              2           ]
[             x  + 2*x + 1 ]



(sqrt(x)+sqrt(-x))/x;


[        sqrt( - x) + sqrt(x) ]
[false  ----------------------]
[                 x           ]



1 / (x^2+2*x+1);


[                  1       ]
[x + 1 <> 0  --------------]
[              2           ]
[             x  + 2*x + 1 ]



1 / (x^2+2*x+2);


[            1       ]
[true  --------------]
[        2           ]
[       x  + 2*x + 2 ]



abs(x)-sqrt(x);


[x >= 0   - sqrt(x) + x]



abs(x^2+2*x+1);


[       2          ]
[true  x  + 2*x + 1]



min(x,max(x,y));


[true  x]



min(sign(x),-1);


[true  -1]



abs(x)-x;


[ true   abs(x) - x]
[                  ]
[x >= 0      0     ]
[                  ]
[x < 0      - 2*x  ]



sqrt(1+x^2*y^2+(x^2+y^2-3));


[ 2  2    2    2                 2  2    2    2     ]
[x *y  + x  + y  - 2 >= 0  sqrt(x *y  + x  + y  - 2)]



end;


Time for test: 16 ms
@@@@@ Resources used: (0 0 2 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardianprint.red0000644000175000017500000000614411526203062025646 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: guardianprint.red 475 2009-11-28 14:03:08Z arthurcnorman $
% ----------------------------------------------------------------------
% (c) 1999 Andreas Dolzmann, 1999, 2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

module guardianprint;

fluid '(gd_omode!*);

gd_omode!* := 'matrix;

flag('(gex),'sprifn);
put('gex,'tag,'ge);
put('ge,'setprifn,'gd_setgepri);
put('ge,'prifn,'gd_gepri);
put('ge,'fancy!-setprifn,'gd_fancy!-setgepri);
put('ge,'fancy!-prifn,'gd_fancy!-gepri);

put('gdomode,'psopfn,'gd_omode);

procedure gd_omode(argl);
   begin scalar w;
      w := gd_omode!*;
      gd_omode!* := car argl;
      return w
   end;

procedure gd_setgepri(v,u);
   apply(intern compress append(explode 'gd_setgepri,explode gd_omode!*),{v,u})
      where !*guardian=nil;

procedure gd_gepri(u);
   apply(intern compress append(explode 'gd_gepri,explode gd_omode!*),{u})
      where !*guardian=nil;

procedure gd_setgepridebug(v,u);
   if cdr u then setmatpri(v,u);

procedure gd_gepridebug(u);
   if cdr u then matpri u;

procedure gd_setgeprimatrix(v,u);
   gd_setgepridebug(v,'ge . for each x in cdr u collect cdr x);

procedure gd_geprimatrix(u);
   gd_gepridebug('ge . for each x in cdr u collect cdr x);

procedure gd_setgeprigcase(v,u);
   gd_setgepridebug(v,{'ge,cdar cdr u});

procedure gd_geprigcase(u);
   gd_gepridebug {'ge,cdar cdr u};

procedure gd_setgeprigterm(v,u);
   <<
      if cadr car cdr u = 'false then
	 lprim "contradictive situation";
      assgnpri(mk!*sq simp caddr car cdr u,{v},'only)
   >>;

procedure gd_geprigterm(u);
   <<
      if cadr car cdr u = 'false then
	 lprim "contradictive situation";
      assgnpri(mk!*sq simp caddr car cdr u,nil,'only)
   >>;

endmodule;  % [guardianprint]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardianschemes.red0000644000175000017500000000570511526203062026143 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: guardianschemes.red 475 2009-11-28 14:03:08Z arthurcnorman $
% ----------------------------------------------------------------------
% (c) 1999 Andreas Dolzmann, 1999, 2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

module guardianschemes;

put('gdmkguarded,'psopfn,'gd_mkguarded);

procedure gd_mkguarded(argl);
   % Make guarded expression.
   <<
      put(car argl,'rtypefn,'cquotegex);
      put(car argl,'gd_scheme,cadr argl)
   >>;

algebraic gdmkguarded(abs,ge(ger(true,abs(a1)),gec(a1>=0,a1),gec(a1<0,-a1)));
algebraic gdmkguarded(quotient,ge(geg(a2 neq 0,a1/a2)));
algebraic gdmkguarded(sqrt,ge(geg(a1>=0,sqrt(a1))));
algebraic gdmkguarded(sign,ge(
   ger(true,sign(a1)),gec(a1>0,1),gec(a1=0,0),gec(a1<0,-1)));

put('min,'rtypefn,'cquotegex);
put('min,'gd_schemefn,'gd_scheme!-min);
put('max,'rtypefn,'cquotegex);
put('max,'gd_schemefn,'gd_scheme!-max);

procedure gd_scheme!-min(n);
   'ge . {'ger,'true,'min . for i:=1:n collect mkid('a,i)} .
      for i:=1:n collect
	 {'gec,'and . for j:=1:n join
	    if j neq i then {{'leq,mkid('a,i),mkid('a,j)}},mkid('a,i)};

procedure gd_scheme!-max(n);
   'ge . {'ger,'true,'max . for i:=1:n collect mkid('a,i)} .
      for i:=1:n collect
	 {'gec,'and . for j:=1:n join
	    if j neq i then {{'geq,mkid('a,i),mkid('a,j)}},mkid('a,i)};

procedure gd_getscheme(op,n);
   begin scalar w;
      if (w:=get(op,'gd_scheme)) then
	 return w;
      if (w:=get(op,'gd_schemefn)) then
	 return apply(w,{n});
      return {'ge,{'geg,'true,op . for i:=1:n collect mkid('a,i)}}
   end;

endmodule;  % [guardianschemes]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardian.red0000644000175000017500000002216711526203062024574 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: guardian.red 475 2009-11-28 14:03:08Z arthurcnorman $
% ----------------------------------------------------------------------
% (c) 1999 Andreas Dolzmann, 1999, 2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(gd_rcsid!* gd_copyright!*);
   gd_rcsid!* := "$Id: guardian.red 475 2009-11-28 14:03:08Z arthurcnorman $";
   gd_copyright!* := "(c) 1999 A. Dolzmann, 1999, 2009 T. Sturm"
>>;

module guardian;

create!-package('(guardian guardianschemes guardianprint),nil);

load!-package 'matrix;
load!-package 'redlog;
rl_set '(ofsf);

switch guardian,gdqe,gdsmart;
on1 'guardian;
on1 'gdqe;
on1 'gdsmart;

procedure cquotegex(x);
   % Conditional quote guarded expression.
   if !*guardian then 'gex;

put('gex,'evfn,'gd_reval);
put('gex,'lengthfn,'lengthcdr);

algebraic operator ge,gec,geg,ger;

put('ge,'rtypefn,'cquotegex);

operator mkge;

procedure mkge(x);
   gd_reval(x,nil);

procedure gd_reval(u,v);
   % Reval.
   begin scalar w;
      w := gd_revaleval(u,v);
      w := gd_eta w;
      w := gd_revalsimpl w;
      if !*gdsmart then
	 w := gd_revalsm w;
      return w
   end;

procedure gd_revaleval(u,v);
   % Reval evaluation part.
   if atom u then
      gd_revalatom(u,v)
   else if car u eq 'ge then
      gd_gesimpl gd_flatten('ge . for each x in cdr u collect
 	 {car x,cadr x,gd_revaleval(caddr x,v)})
   else
      gd_gesimpl gd_flatten gd_revalevalop(car u,for each x in cdr u collect
	 gd_revaleval(x,v));

procedure gd_revalatom(u,v);
   % [u] is an atom.
   begin scalar w;
      if null u then typerr("nil","gex");
      if stringp u then typerr({"string",u},"gex");
      if (w := rl_gettype(u)) then <<
	 if w eq 'scalar then
	    return gd_revaleval(reval cadr get(u,'avalue),v)
 	       where !*guardian=nil;
	 if w eq 'gex then
	    return gd_revaleval(cadr get(u,'avalue),v);
	 typerr({w,u},"gex")
      >>;
      % [u] algebraically unbound.
      return {'ge,{'geg,'true,u}}
   end;

procedure gd_flatten(nge);
   % Flatten nested guarded expression.
   begin scalar w;
      return 'ge . for each case in cdr nge join
	 for each subcase in cdr caddr case join <<
	    w := gd_newtype(car case,car subcase);
	    if w then
 	       {{w,{'and,cadr case,cadr subcase},caddr subcase}}
	 >>
   end;

procedure gd_newtype(t1,t2);
   % Compute the type of the new branch. [inner] and [outer] are
   % branch types. [nil] means drop.
   if t1 eq t2 then
      t1
   else if t1 eq 'gec then
      if t2 eq 'geg then
	 'gec
      else  % [t2 eq 'ger]
	 nil
   else if t1 eq 'geg then
      t2
   else  % [t1 eq 'ger]
      if t2 eq 'gec then
	 nil
      else  % [t2 eq 'geg]
	 'ger;

procedure gd_revalevalop(op,gel);
   begin scalar gtag,rgel,gcgammal,gctl;
      gtag := 'geg;
      for each ge in gel do <<
	 if car car cdr ge eq 'ger then <<
	    gtag := 'ger;
	    rgel := ('ge . cdr cdr ge) . rgel
	 >> else  % [car car cdr ge eq 'geg]
	    rgel := ge . rgel;
	 gcgammal := cadr car cdr ge . gcgammal;
	 gctl := caddr car cdr ge . gctl
      >>;
      gcgammal := reversip gcgammal;
      gctl := reversip gctl;
      rgel := reversip rgel;
      return gd_revalevalop1(op,gtag,{gcgammal,gctl},rgel)
   end;

procedure gd_revalevalop1(op,gtag,gcase,gel);
   % [op] is an $n$-ary operator; [gtag] is one of [geg] or [ger];
   % [gcase] is a list $((... \gamma_i ...),(t_1,...,t_n))$; [gel] is
   % a GEL. Returns an NGE.
   begin scalar w,g;
      g := {gtag,'and . car gcase,gd_applyscheme(op,cadr gcase)};
      w := gd_cartprod gel;
      if gtag eq 'geg then
	 w := cdr w;
      return 'ge . g . for each case in w collect
	 {'gec,'and . car case,gd_applyscheme(op,cadr case)}
   end;

procedure gd_applyscheme(op,tl);
   % Returns a GE.
   begin scalar al; integer n;
      for each x in tl do <<
	 n := n + 1;
	 al := (mkid('a,n) . car tl) . al;
	 tl := cdr tl
      >>;
      return sublis(al,gd_getscheme(op,n))
   end;

procedure gd_cartprod(gel);
   % Cartesian product. [gel] is a list of GE's. Returns a list
   % $(...((... \gamma_i ...),(... t_i ...))...)$. The first
   % combination is actually the composition of the first [gel] cases.
   begin scalar w;
      if null cdr gel then
      	 return for each case in cdr car gel collect
 	    {{cadr case},{caddr case}};
      w := gd_cartprod cdr gel;
      return for each case in cdr car gel join
      	 for each x in w collect {cadr case . car x,caddr case . cadr x}
   end;

procedure gd_gesimpl(ge);
   'ge . gd_gcasesimpl cadr ge .
      for each case in cddr ge join gd_casesimpll case;

procedure gd_gcasesimpl(gcase);
   {car gcase,gd_simpl cadr gcase,caddr gcase};

procedure gd_casesimpll(case);
   (if w neq 'false then {{car case,w,caddr case}}) where w=gd_simpl cadr case;

procedure gd_simpl(f);
   rl_prepfof rl_simpl(rl_simp f,nil,-1)
      where !*guardian=nil,!*rlnzden=T,!*rladdcond=nil;

procedure gd_eta(ge);
   % The algebraic evaluator.
   ('ge . for each case in cdr ge collect
      {car case,cadr case,reval caddr case}) where !*guardian=nil;

procedure gd_revalsimpl(ge);
   % Reval sophisticated simplification part.
   gd_revalsimplrmf gd_revalsimplrect gd_revalsimplcc ge;

procedure gd_revalsimplcc(ge);
   % Contract cases.
   begin scalar nw,sc,c;
      for each case in cdr cdr ge do <<
      	 sc := nw;
      	 c := T; while sc and c do <<
	    if caddr car sc = caddr case then <<
	       cadr car sc := gd_simpl {'or,cadr car sc,cadr case};
	       c := nil
	    >>;
	    sc := cdr sc
      	 >>;
      	 if c then
	    nw := case . nw;
      >>;
      return 'ge . car cdr ge . reversip nw
   end;

procedure gd_revalsimplrmf(ge);
   begin scalar ngcase;
      if null !*gdqe then
 	 return ge;
      ngcase := if gd_falsep cadr car cdr ge then
	 {car car cdr ge,'false,caddr car cdr ge}
      else
	 car cdr ge;
      return 'ge . ngcase . for each case in cdr cdr ge join
	 if not gd_falsep cadr case then {case}
   end;

procedure gd_falsep(f);
   % [f] is a quantifier-free formula in Lisp prefix.
   begin scalar !*guardian,!*rlverbose;
      if gd_ckernp f then
	 return nil;
      return rl_prepfof rl_qe(rl_ex(rl_simp f,nil),nil) eq 'false
   end;

procedure gd_revalsimplrect(ge);
   % Recognize true.
   begin scalar sc;
      if gd_truep cadr car cdr ge then
	 ge := 'ge . {car car cdr ge,'true,caddr car cdr ge} . cddr ge;
      sc := cddr ge;
      while sc do <<
	 if gd_truep cadr car sc then <<
	    ge := 'ge . cadr ge . {{car car sc,'true,caddr car sc}};
	    sc := nil
	 >> else
	    sc := cdr sc
      >>;
      return ge
   end;

procedure gd_truep(f);
   % [f] is a quantifier-free formula in Lisp prefix.
   begin scalar !*guardian,!*rlverbose;
      if f eq 'true then
	 return T;
      if null !*gdqe or gd_ckernp f then
	 return nil;
      return rl_prepfof rl_qe(rl_all(rl_simp f,nil),nil) eq 'true
   end;

procedure gd_ckernp(f);
   % Complex kernel predicate. [f] is a quantifier-free formula.
   % [!*guardian] must be zero.
   begin scalar vl,ckern;
      vl := rl_fvarl rl_simp f;
      while vl do
	 if pairp car vl then <<
	    vl := nil;
	    ckern := T
	 >> else
	    vl := cdr vl;
      return ckern
   end;

procedure gd_revalsm(ge);
   % Reval smart. [ge] is a guarded expression. Return a guarded
   % expression.
   begin scalar gcond,scge,thiscase,newgcase;
      gcond := cadr cadr ge;
      scge := cddr ge;
      while scge and not newgcase do <<
	 thiscase := car scge;
	 scge := cdr scge;
	 if cadr thiscase eq 'true or cadr thiscase = gcond then
	    newgcase := 'geg . cdr thiscase
      >>;
      if newgcase then
	 return {'ge,newgcase};
      if not !*gdqe then
	 return ge;
      scge := cddr ge;
      while scge and not newgcase do <<
	 thiscase := car scge;
	 scge := cdr scge;
	 if gd_truep {'impl,gcond,cadr thiscase} then
	    newgcase := 'geg . cdr thiscase
      >>;
      if newgcase then
	 return {'ge,newgcase};
      return ge;
   end;

endmodule;  % [guardian]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardian.tst0000644000175000017500000000031411526203062024622 0ustar  giovannigiovanni1 / (x^2+2*x+1);

(sqrt(x)+sqrt(-x))/x;

1 / (x^2+2*x+1);

1 / (x^2+2*x+2);

abs(x)-sqrt(x);

abs(x^2+2*x+1);

min(x,max(x,y));

min(sign(x),-1);

abs(x)-x;

sqrt(1+x^2*y^2+(x^2+y^2-3));

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/guardian/guardian.tex0000644000175000017500000011452611526203062024623 0ustar  giovannigiovanni\documentstyle[11pt]{article}
\newenvironment{gex}{\left[\begin{array}{c|c}}{\end{array}\right]}
\newcommand{\gc}[1]{\mbox{\boldmath$#1$}}
\newcommand{\true}{{\rm T}}
\newcommand{\false}{{\rm F}}
\newcommand{\E}{{\rm E}}
\newcommand{\GE}{{\rm GE}}
\newcommand{\gscheme}{{\rm gscheme}}
\newcommand{\sign}{{\rm sign}}
\begin{document}
\title{Guarded Expressions in Practice\thanks{This text is essentially
    the Technical Report MIP-9702 of the Universit\"at Passau, Germany,
    a revised version of which has appeared in the Proceedings of the
    ISSAC 97. Some few references to former websites for distributing
    Guardian and Redlog have been removed.}}
\author{Andreas Dolzmann\\
  {\tt andreas@dolzmann.de} \and
  Thomas Sturm\\
  Departamento de Matem\'aticas, Estad\'istica y Computaci\'on\\
  Universidad de Cantabria, Santander, Spain\\
  \texttt{sturmt@unican.es, sturm@redlog.eu}}
\date{}
\maketitle
%
\begin{abstract}
Computer algebra systems typically drop some degenerate cases when
evaluating expressions, e.g., $x/x$ becomes $1$ dropping the case
$x=0$. We claim that it is feasible in practice to compute also the
degenerate cases yielding {\em guarded expressions}. We work over real
closed fields but our ideas about handling guarded expression can be
easily transferred to other situations. Using formulas as guards
provides a powerful tool for heuristically reducing the combinatorial
explosion of cases: equivalent, redundant, tautological, and
contradictive cases can be detected by simplification and quantifier
elimination. Our approach allows to simplify the expressions on the
basis of simplification knowledge on the logical side. The method
described in this paper is implemented in the {\sc reduce} package
{\sc guardian}.
\end{abstract}
%
\section{Introduction}
It is meanwhile a well-known fact that evaluations obtained with the
interactive use of computer algebra systems ({\sc cas}) are not
entirely correct in general. Typically, some degenerate cases are
dropped. Consider for instance the evaluation
$$
\frac{x^2}{x}=x,
$$
which is correct only if $x\neq0$.
The problem here is that {\sc cas} consider variables to be
transcendental elements. The user, in contrast, has in mind variables
in the sense of logic. In other words: The user does not think of
rational functions but of terms.

Next consider the valid expression
$$
\frac{\sqrt{x}+\sqrt{-x}}{x}.
$$
It is meaningless over the reals. {\sc Cas} often offer no choice than
to interprete surds over the complex numbers even if they distinguish
between a {\em real} and a {\em complex} mode.

Corless and Jeffrey~\cite{CorlessJeffrey:92} have examined the
behavior of a number of {\sc cas} with such input data. They come to
the conclusion that simultaneous computation of all cases is exemplary
but not feasible due to the combinatorial explosion of cases to be
considered. Therefore, they suggest to ignore the degenerate cases but
to provide the assumptions to the user on request. We claim, in
contrast, that it is in fact feasible to compute all possible cases.

Our setting is as follows: Expressions are evaluated to {\em guarded
expressions} consisting of possibly several conventional expressions
guarded by quantifier-free formulas. For the above examples, we would
obtain
$$
\begin{gex}
\gc{x\neq0}&\gc{x}
\end{gex},\quad
\begin{gex}
\gc{\false}&\gc{\frac{\sqrt{x}+\sqrt{-x}}{x}}
\end{gex}.
$$
As the second example illustrates, we are working in ordered fields,
more precisely in real closed fields. The handling of guarded
expressions as described in this paper can, however, be easily
transferred to other situations.

Our approach can also deal with redundant guarded expressions, such as
$$
\begin{gex}
\gc{\true} & \gc{|x|-x}\\
x\geq0 & 0\\
x<0 & -2x
\end{gex}
$$
which leads to algebraic simplification techniques based on logical
simplification as proposed by Davenport and
Faure \cite{DavenportFaure:94}.

We use {\em formulas} over the language of ordered rings as guards.
This provides powerful tools for heuristically reducing the
combinatorial explosion of cases: equivalent, redundant, tautological,
and contradictive cases can be detected by {\em
simplification}~\cite{DolzmannSturm:95} and {\em quantifier
elimination}~\cite{Tarski:48,Collins:75,Weispfenning:88,LoosWeispfenning:93,Weispfenning:96,Weispfenning:94}.
In certain situations, we will allow the formulas also to contain
extra functions such as $\sqrt{\cdot}$ or $|\cdot|$. Then we take care
that there is no quantifier elimination applied.

Simultaneous computation of several cases concerning certain
expressions being zero or not has been extensively investigated as
{\em dynamic
evaluation}~\cite{GomezDiaz:93,DuvalReynaud:94,DuvalReynaud:94a,
BroadberryGomezDiazWatt:95}. It has also been extended to real closed
fields~\cite{DuvalGonzalesVega:93}. The idea behind the development of
these methods is of a more theoretical nature than to overcome the
problems with the interactive usage of {\sc cas} sketched above: one
wishes to compute in algebraic (or real) extension fields of the
rationals. Guarded expressions occur naturally when solving problems
parametrically. Consider, e.g., the {\em Gr\"obner systems} used
during the computation of {\em comprehensive Gr\"obner bases}
\cite{Weispfenning:92}.

The algorithms described in this paper are implemented in the {\sc
reduce} package {\sc guardian}. It is based on the {\sc
reduce}~\cite{HearnFitch:95,Melenk:95} package {\sc
redlog}~\cite{DolzmannSturm:96,DolzmannSturm:96a} implementing a
formula data type with corresponding algorithms, in particular
including simplification and quantifier elimination.
% Both {\sc guardian} and {\sc redlog} are available on the {\sc
%   www}.\footnote{{\tt http://www.fmi.uni-passau.de/\~{}redlog/}}

\section{An outline of our method}
\subsection{Guarded expressions}
A {\em guarded expression} is a scheme
$$
\begin{gex}
\gc{\gamma_0} & \gc{t_0}\\
\gamma_1 & t_1\\
\vdots&\vdots\\
\gamma_n& t_n
\end{gex}
$$
where each $\gamma_i$ is a quantifier-free formula, the {\em guard},
and each $t_i$ is an associated {\em conventional expression}. The
idea is that some $t_i$ is a valid interpretation iff $\gamma_i$
holds. Each pair $(\gamma_i,t_i)$ is called a {\em case}.

The first case $(\gamma_0,t_0)$ is the {\em generic} case: $t_0$ is
the expression the system would compute without our package, and
$\gamma_0$ is the corresponding guard.

The guards $\gamma_i$ need neither exclude one another, nor do we
require that they form a complete case distinction. We shall, however,
assume that all cases covered by a guarded expression are already
covered by the generic case; in other words:
\begin{equation}
\bigwedge_{i=1}^n(\gamma_i\longrightarrow\gamma_0).\label{gencoversall}
\end{equation}

Consider the following evaluation of $|x|$ to a guarded expression:
$$
\begin{gex}
\gc{\true} & \gc{|x|}\\
x\geq0 & x\\
x<0 & -x
\end{gex}.
$$
Here the non-generic cases already cover the whole domain. The
generic case is in some way {\em redundant}. It is just present for
keeping track of the system's default behavior. Formally we have
\begin{equation}
\Bigl(\bigvee_{i=1}^n\gamma_i\Bigr)\longleftrightarrow\gamma_0.
\label{formalredund}
\end{equation}
As an example for a non-redundant, i.e., {\em necessary} generic case
we have the evaluation of the reciprocal $\frac{1}{x}$:
$$
\begin{gex}
\gc{x\neq0}& \gc{\frac{1}{x}}
\end{gex}.
$$

In every guarded expression, the generic case is explicitly marked as
either necessary or redundant. The corresponding tag is inherited
during the evaluation process. Unfortunately it can happen that
guarded expressions satisfy~(\ref{formalredund}) without being tagged
redundant, e.g., specialization of
$$
\begin{gex}
\gc{\true}&\gc{\sin x}\\
x=0&0
\end{gex}
$$
to $x=0$ if the system cannot evaluate $\sin(0)$. This does not happen
if one claims for necessary generic cases to have, as the reciprocal
above, no alternative cases at all. Else, in the sequel ``redundant
generic case'' has to be read as ``tagged redundant.''

With guarded expressions, the evaluation splits into two independent
parts: {\em Algebraic evaluation} and a subsequent {\em
simplification} of the guarded expression obtained.
%
\subsection{Guarding schemes}
In the introduction we have seen that certain operators introduce case
distinctions. For this, with each operator $f$ there is a {\em
guarding scheme} associated providing information on how to map
$f(t_1,\ldots,t_m)$ to a guarded expression provided that one does not
have to care for the argument expressions $t_1$, \dots,~$t_m$. In the
easiest case, this is a rewrite rule
$$
f(a_1,\ldots,a_m)\to G(a_1,\ldots,a_m).
$$
The actual terms $t_1$, \dots,~$t_m$ are simply substituted for the
formal symbols $a_1$, \dots,~$a_m$ into the generic guarded expression
$G(a_1,\ldots,a_m)$. We give some examples:
\begin{eqnarray}
\frac{a_1}{a_2} & \to &
\begin{gex}
\gc{a_2\neq 0} & \gc{\frac{a_1}{a_2}}
\end{gex}\nonumber\\
\sqrt{a_1} & \to &
\begin{gex}
\gc{a_1\geq 0} & \gc{\sqrt{a_1}}
\end{gex}\nonumber\\
\sign(a_1) & \to &
\begin{gex}
\gc{\true} & \gc{\sign(a_1)}\\
a_1>0 & 1\\
a_1=0 & 0\\
a_1<0 & -1
\end{gex}\nonumber\\
|a_1| & \to &
\begin{gex}
\gc{\true} & \gc{|a_1|}\\
a_1\geq0 & a_1\\
a_1<0 & -a_1
\end{gex}\label{absrewrite}
\end{eqnarray}

For functions of arbitrary arity, e.g., $\min$ or $\max$, we formally
assume infinitely many operators of the same name. Technically, we
associate a procedure parameterized with the number of arguments $m$
that generates the corresponding rewrite rule. As ${\tt
min\_scheme(2)}$ we obtain, e.g.,
\begin{eqnarray}
\min(a_1,a_2) & \to &
\begin{gex}
\gc{\true} & \gc{\min(a_1,a_2)}\\
a_1\leq a_2 & a_1\\
a_2\leq a_1 & a_2
\end{gex}\label{binminscheme},
\end{eqnarray}
while for higher arities there are more case distinctions necessary.

For later complexity analysis, we state the concept of a guarding
scheme formally: a guarding scheme for an $m$-ary operator $f$ is a
map
$$
\gscheme_f: \E^m \to \GE
$$
where $\E$ is the set of expressions, and $\GE$ is the set of guarded
expressions. This allows to split $f(t_1,\ldots,t_m)$ in dependence
on the form of the parameter expressions $t_1$, \dots,~$t_m$.
%
\subsection{Algebraic evaluation}\label{algeval}
\subsubsection{Evaluating conventional expressions}
The evaluation of conventional expressions into guarded expressions is
performed recursively: Constants $c$ evaluate to
$$
\begin{gex}
\gc{\true} & \gc{c}
\end{gex}.
$$
For the evaluation
of $f(e_1,\ldots,e_m)$ the argument expressions $e_1$, \ldots, $e_m$
are recursively evaluated to guarded expressions
\begin{equation}
e_i'=\begin{gex}
\gc{\gamma_{i0}} & \gc{t_{i0}}\\
\gamma_{i1} & t_{i1}\\
\vdots & \vdots\\
\gamma_{in_i} & t_{in_i}\end{gex}\quad\mbox{for}\quad 1\leq i\leq m.
\label{eprimes}
\end{equation}

Then the operator $f$ is ``moved inside'' the $e_i'$ by combining all
cases, technically a simultaneous Cartesian product computation of
both the sets of guards and the sets of terms:
\begin{equation}
\Gamma=\prod_{i=1}^m\{\gamma_{i0},\ldots,\gamma_{in_i}\},\quad
T=\prod_{i=1}^m\{t_{i0},\ldots,t_{in_i}\}.
\label{cartprod}
\end{equation}
This leads to the intermediate result
\begin{equation}
\begin{gex}
\gc{\gamma_{10}\land\dots\land\gamma_{m0}}&
\gc{f(t_{10},\dots,t_{m0})}\\
\vdots&\vdots\\
\gamma_{1n_1}\land\dots\land\gamma_{m0}&
f(t_{1n_1},\dots,t_{m0})\\
\vdots&\vdots\\
\gamma_{1n_1}\land\dots\land\gamma_{mn_m}&
f(t_{1n_1},\dots,t_{mn_m})
\end{gex}.
\label{intermediate}
\end{equation}
The new generic case is exactly the combination of the generic cases
of the $e_i'$. It is redundant if at least one of these combined cases
is redundant.

Next, all non-generic cases containing at least one {\em redundant}
generic constituent $\gamma_{i0}$ in their guard are deleted. The
reason for this is that generic cases are only used to keep track of
the system default behavior. All other cases get the status of a
non-generic case even if they contain necessary generic constituents
in their guard.

At this point, we apply the guarding scheme of $f$ to all remaining
expressions $f(t_{1i_1},\ldots,t_{mi_m})$ in the
form~(\ref{intermediate}) yielding a nested guarded expression
\begin{equation}
\begin{gex}
\gc{\Gamma_0} &
\begin{gex}
\gc{\delta_{00}} & \gc{u_{00}}\\ \vdots & \vdots \\ \delta_{0k_0} & u_{0k_0}
\end{gex}\\
\vdots & \vdots\\
\Gamma_N &
\begin{gex}
\gc{\delta_{N0}} & \gc{u_{N0}}\\ \vdots & \vdots \\ \delta_{Nk_N} & u_{Nk_N}
\end{gex}
\end{gex},\label{nestedge}
\end{equation}
which can be straightforwardly resolved to a guarded expression
$$
\begin{gex}
\gc{\Gamma_0\land\delta_{00}} & \gc{u_{00}}\\
\vdots & \vdots\\
\Gamma_0\land\delta_{0k_0} & u_{0k_0}\\
\vdots & \vdots\\
\Gamma_N\land\delta_{N0} & u_{N0}\\
\vdots & \vdots\\
\Gamma_N\land\delta_{Nk_N} & u_{Nk_N}
\end{gex}.
$$
This form is treated analogously to the form~(\ref{intermediate}): The
new generic case $(\Gamma_0\land\delta_{00},u_{00})$ is redundant if
at least one of $\bigl(\Gamma_0,f(t_{10},\dots,t_{m0})\bigr)$ and
$(\delta_{00},u_{00})$ is redundant. Among the non-generic cases all
those containing redundant generic constituents in their guard are
deleted, and all those containing necessary generic constituents in
their guard get the status of an ordinary non-generic case.

Finally the standard evaluator of the system---{\tt reval} in the case
of {\sc reduce}---is applied to all contained expressions, which
completes the algebraic part of the evaluation.
%
\subsubsection{Evaluating guarded expressions}
The previous section was concerned with the evaluation of pure
conventional expressions into guarded expressions. Our system
currently combines both conventional and guarded expressions. We are
thus faced with the problem of treating guarded subexpressions during
evaluation.

When there is a {\em guarded} subexpression $e_i$ detected during
evaluation, all contained expressions are recursively evaluated to
guarded expressions yielding a nested guarded expression of the
form~(\ref{nestedge}). This is resolved as described above yielding
the evaluation subresult $e_i'$.

As a special case, this explains how guarded expressions are
(re)evaluated to guarded expressions.
%
\subsection{Example}
We describe the evaluation of the expression $\min(x,|x|)$. The first
argument $e_1=x$ evaluates recursively to
\begin{equation}
e_1'=\begin{gex} \gc{\true} & \gc{x} \end{gex}
\label{evalx}
\end{equation}
with a necessary generic case. The nested $x$ inside $e_2=|x|$ evaluates
to the same form~(\ref{evalx}). For obtaining $e_2'$, we apply the
guarding scheme~(\ref{absrewrite}) of the absolute value to the only
term of~(\ref{evalx}) yielding
$$
\begin{gex} \gc{\true} & \begin{gex}
\gc{\true} & \gc{|x|}\\
x\geq 0 & x\\
x<0 & -x
\end{gex}
\end{gex},
$$
where the inner generic case is redundant. This form is resolved to
$$
e_2'=\begin{gex}
\gc{\true\land\true} & \gc{|x|}\\
\true\land x\geq 0 & x\\
\true\land x<0 & -x
\end{gex}
$$
with a redundant generic case. The next step is the combination of
cases by Cartesian product computation. We obtain
$$
\begin{gex}
\gc{\true\land(\true\land\true)} & \gc{\min(x,|x|)}\\
\true\land(\true\land x\geq0) & \min(x,x)\\
\true\land(\true\land x<0) & \min(x,-x)
\end{gex},
$$
which corresponds to~(\ref{intermediate}) above. For the outer $\min$,
we apply the guarding scheme~(\ref{binminscheme}) to all terms
yielding the nested guarded expression
$$
\begin{gex}
\gc{\true\land(\true\land\true)} & \begin{gex}
\gc{\true} & \gc{\min(x,|x|)}\\
x\leq |x| & x\\
|x|\leq x & |x|
\end{gex}\\
\true\land(\true\land x\geq0) & \begin{gex}
\gc{\true} & \gc{\min(x,x)}\\
x\leq x & x\\
x\leq x & x
\end{gex}\\
\true\land(\true\land x<0) & \begin{gex}
\gc{\true} & \gc{\min(x,-x)}\\
x\leq -x & x\\
-x\leq x & -x
\end{gex}
\end{gex},
$$
which is in turn resolved to
$$
\begin{gex}
\gc{(\true\land(\true\land\true))\land\true} & \gc{\min(x,|x|)}\\
(\true\land(\true\land\true))\land x\leq |x| & x\\
(\true\land(\true\land\true))\land |x|\leq x & |x|\\
(\true\land(\true\land x\geq0))\land\true & \min(x,x)\\
(\true\land(\true\land x\geq0))\land x\leq x & x\\
(\true\land(\true\land x\geq0))\land x\leq x & x\\
(\true\land(\true\land x<0))\land\true & \min(x,-x)\\
(\true\land(\true\land x<0))\land x\leq -x & x\\
(\true\land(\true\land x<0))\land -x\leq x & -x
\end{gex}.
$$
From this, we delete the two non-generic cases obtained by combination
with the redundant generic case of the $\min$. The final result of the
algebraic evaluation step is the following:
\begin{equation}
\begin{gex}
\gc{(\true\land(\true\land\true))\land\true} & \gc{\min(x,|x|)}\\
(\true\land(\true\land\true))\land x\leq |x| & x\\
(\true\land(\true\land\true))\land |x|\leq x & |x|\\
(\true\land(\true\land x\geq0))\land x\leq x & x\\
(\true\land(\true\land x\geq0))\land x\leq x & x\\
(\true\land(\true\land x<0))\land x\leq -x & x\\
(\true\land(\true\land x<0))\land -x\leq x & -x
\end{gex}.\label{example}
\end{equation}
\subsection{Worst-case complexity}
Our measure of complexity $|G|$ for guarded expressions $G$ is the
number of contained cases:
$$
\left|\begin{gex}
\gc{\gamma_0} & \gc{t_0}\\
\gamma_1 & t_1\\
\vdots&\vdots\\
\gamma_n& t_n
\end{gex}\right|=n+1.
$$

As in Section~\ref{algeval}, consider an $m$-ary operator $f$,
guarded expression arguments $e_1'$, \dots,~$e_m'$ as in
equation~(\ref{eprimes}), and the Cartesian product $T$ as in
equation~(\ref{cartprod}). Then
\begin{eqnarray*}
\lefteqn{
|f(e_1',\ldots,e_m')| \leq  \sum_{(t_1,\dots,t_m)\in
T}|\gscheme_f(t_1,\dots,t_m)|}\\
& &{}\leq  \max_{(t_1,\ldots,t_m)\in
T}|\gscheme_f(t_1,\ldots,t_m)|\cdot \#T\\
& & {}=  \max_{(t_1,\ldots,t_m)\in
T}|\gscheme_f(t_1,\ldots,t_m)|\cdot \prod_{j=1}^m|e_j'|\\
& & {}\leq  \max_{(t_1,\ldots,t_m)\in
T}|\gscheme_f(t_1,\ldots,t_m)|\cdot\bigl(\max_{1\leq j\leq m}|e_j'|\bigr)^m.
\end{eqnarray*}

In the important special case that the guarding scheme of $f$ is a
rewrite rule $f(a_1,\ldots,a_m)\to G$, the above complexity
estimation simplifies to
$$
|f(e_1',\ldots,e_m')| \leq  |G|\cdot \prod_{j=1}^m|e_j'| \leq  |G|\cdot
\bigl(\max_{1\leq j\leq m}|e_j'|\bigr)^m.
$$
In other words: $|G|$ plays the role of a factor, which, however,
depends on $f$, and $|f(e_1',\ldots,e_m')|$ is polynomial in the size
of the $e_i$ but exponential in the arity of $f$.

%
\subsection{Simplification}
In view of the increasing size of the guarded expressions coming into
existence with subsequent computations, it is indispensable to apply
simplification strategies. There are two different algorithms involved
in the simplification of guarded expressions:
\begin{enumerate}
\item
A {\em formula simplifier} mapping quantifier-free formulas to
equivalent simpler ones.
\item
Effective {\em quantifier elimination} for real closed fields
over the language of ordered rings.
\end{enumerate}

It is not relevant, which simplifier and which quantifier elimination
procedure is actually used. We use the formula simplifier described
in~\cite{DolzmannSturm:95}. Our quantifier elimination uses test point
methods developed by
Weispfenning~\cite{Weispfenning:88,LoosWeispfenning:93,Weispfenning:96}.
It is restricted to formulas obeying certain degree restrictions
wrt.~the quantified variables. As an alternative, {\sc redlog}
provides an interface to Hong's {\sc qepcad} quantifier elimination
package \cite{Hong:93}. Compared to the simplification, the
quantifier elimination is more time consuming. It can be turned off by
a {\em switch}.

The following simplification steps are applied in the given order:
%
\paragraph{Contraction of cases} This is restricted to the
non-generic cases of the considered guarded expression. We contract
different cases containing the same terms:
$$
\begin{gex}
\gc{\gamma_0}&\gc{t_0}\\
\vdots & \vdots\\
\gamma_i & t_i\\
\vdots & \vdots\\
\gamma_j & t_i\\
\vdots & \vdots
\end{gex}\quad\mbox{becomes}\quad
\begin{gex}
\gc{\gamma_0}&\gc{t_0}\\
\vdots & \vdots\\
\gamma_i\lor\gamma_j & t_i\\
\vdots & \vdots\\
\end{gex}.
$$
\paragraph{Simplification of the guards} The simplifier is applied to
all guards replacing them by simplified equivalents. Since our
simplifier maps $\gamma\lor\gamma$ to $\gamma$, this together with the
contraction of cases takes care for the deletion of duplicate cases.

\paragraph{Keep one tautological case} If the guard of some
non-generic case becomes ``$\true$,'' we delete all other non-generic
cases. Else, if quantifier elimination is turned on, we try to detect
a tautology by eliminating the universal closures
$\underline\forall\gamma$ of the guards $\gamma$. This quantifier
elimination is also applied to the guards of generic cases. These are,
in case of success, simply replaced by ``$\true$'' without deleting
the case.

\paragraph{Remove contradictive cases} A non-generic case is  deleted if
its guard has become ``$\false$.'' If quantifier elimination is turned
on, we try to detect further contradictive cases by eliminating the
existential closure $\underline\exists\gamma$ for each guard $\gamma$.
This quantifier elimination is also applied to generic cases. In case
of success they are not deleted but their guards are replaced by
``$\false$.'' Our assumption (\ref{gencoversall}) allows then to
delete all non-generic cases.

\subsection{Example revisited}
We turn back to the form~(\ref{example}) of our example $\min(x,|x|)$.
Contraction of cases with subsequent simplification automatically
yields
$$
\begin{gex}
\gc{\true} & \gc{\min(x,|x|)}\\
\true & x\\
|x|-x\leq 0 & |x|\\
\false & -x
\end{gex},
$$
of which only the tautological non-generic case survives:
\begin{equation}
\begin{gex}
\gc{\true} & \gc{\min(x,|x|)}\\
\true & x
\end{gex}.\label{minabs}
\end{equation}

\subsection{Output modes}
An {\em output mode} determines which part of the information
contained in the guarded expressions is provided to the user. {\sc
Guardian} knows the following output modes:

\paragraph{Matrix} Output matrices in the style used throughout this
paper. We have already seen that these can become very large in
general.
\paragraph{Generic case} Output only the generic case.
\paragraph{Generic term} Output only the generic term. Thus the output
is exactly the same as without the guardian package. If the condition
of the generic case becomes ``$\false$,'' a {\em warning} ``{\tt
contradictive situation}'' is given. The computation can, however, be
continued.\bigskip

Note that output modes are restrictions concerning only the output;
internally the system still computes with the complete guarded
expressions.
%
\subsection{A smart mode}\label{smartmode}
Consider the evaluation result~(\ref{minabs}) of $\min(x,|x|)$. The
{\em generic term} output mode would output $\min(x,|x|)$, although
more precise information could be given, namely $x$. The problem is
caused by the fact that generic cases are used to keep track of the
system's default behavior. In this section we will describe an
optional {\em smart mode} with a different notion of {\em generic
case}. To begin with, we show why the problem can not be overcome by a
``smart output mode.''

Assume that there is an output mode which outputs $x$
for~(\ref{minabs}). As the next computation involving~(\ref{minabs})
consider division by $y$. This would result in
$$
\begin{gex}
\gc{y\neq0} & \gc{\frac{\min(x,|x|)}{y}}\\
y\neq0 & \frac{x}{y}
\end{gex}.
$$
Again, there are identic conditions for the generic case and some
non-generic case, and, again, the term belonging to the latter is
simpler. Our mode would output $\frac{x}{y}$. Next, we apply the
absolute value once more yielding
$$
\begin{gex}
\gc{y\neq 0} & \gc{\frac{|\min(x,|x|)|}{|y|}}\\
xy\geq0 \land y\neq0 & \frac{x}{y}\\
xy<0 \land y\neq0 & \frac{-x}{y}
\end{gex}.
$$
Here, the condition of the generic case differs from all other
conditions. We thus have to output the generic term. For the user, the
evaluation of $|\frac{x}{y}|$ results in $\frac{|\min(x,|x|)|}{|y|}$.

The smart mode can turn a non-generic case into a necessary generic
one dropping the original generic case and all other non-generic
cases. Consider, e.g.,~(\ref{minabs}), where the conditions are equal,
and the non-generic term is ``simpler.''

In fact, the relevant relationship between the conditions is that the
generic condition {\em implies} the non-generic one. In other words:
Some non-generic condition is not more restrictive than the generic
condition, and thus covers the whole domain of the guarded expression.
Note that from the implication and~(\ref{gencoversall}) we may
conclude that the cases are even equivalent.

Implication is heuristically checked by simplification. If this fails,
quantifier elimination provides a decision procedure. Note that our
test point methods are incomplete in this regard due to the degree
restrictions. Also it cannot be applied straightforwardly to guards
containing operators that do not belong to the language of ordered
rings.

Whenever we happen to detect a relevant implication, we actually turn
the corresponding non-generic case into the generic one. From our
motivation of non-generic cases, we may expect that non-generic
expressions are generally more convenient than generic ones.
%
\section{Examples}\label{examples}
We give the results for the following computations as they are printed
in the output mode {\em matrix} providing the full information on the
computation result. The reader can derive himself what the output in
the mode {\em generic case} or {\em generic term} would be.
\begin{itemize}
\item Smart mode or not:
$$
\frac{1}{x^2+2x+1}=\begin{gex}
\gc{x+1\neq0}& \gc{\frac{1}{x^2+2x+1}}
		   \end{gex}.
$$
The simplifier recognizes that the denominator is a square.
\item Smart mode or not:
$$
\frac{1}{x^2+2x+2}=\begin{gex}
\gc{\true}& \gc{\frac{1}{x^2+2x+2}}
		   \end{gex}.
$$
Quantifier elimination recognizes the positive definiteness of the
denominator.
\item Smart mode:
$$
|x|-\sqrt{x}=\begin{gex}
\gc{x\geq 0} & \gc{-\sqrt{x}+x}
	     \end{gex}.
$$
The square root allows to forget about the negative branch of the
absolute value.
\item Smart mode:
$$
|x^2+2x+1|=\begin{gex}
\gc{\true}&\gc{x^2+2x+1}
	   \end{gex}.
$$
The simplifier recognizes the positive semidefiniteness of
the argument. {\sc Reduce} itself recognizes squares within absolute values
only in very special cases such as $|x^2|$.
\item Smart mode:
$$
\min\bigl(x,\max(x,y)\bigr)=\begin{gex}
\gc{\true}&\gc{x}
		  \end{gex}.
$$
Note that {\sc reduce} does not know any rules about nested minima and
maxima.
\item
Smart mode:
$$
\min\bigl(\sign(x),-1\bigr)=\begin{gex}
\gc{\true}&\gc{-1}
		  \end{gex}.
$$
\item Smart mode or not:
$$
|x|-x=\begin{gex}
\gc{\true}&\gc{|x|-x}\\
x\geq0&0\\
x<0&-2x
      \end{gex}.
$$
This example is taken from~\cite{DavenportFaure:94}.
\item
Smart mode or not:
$$
\sqrt{1+x^2\relax y^2\relax
(x^2+y^2-3)}={}
\begin{gex}\gc{\true}&\gc{\sqrt{x^4\relax y^2 +
x^2\relax y^4 - 3\relax x^2\relax y^2 + 1}}\end{gex}
$$
The {\em Motzkin polynomial} is recognized to be positive semidefinite
by quantifier elimination.
\end{itemize}
The evaluation time for the last example is 119\,ms on a {\sc sun
sparc-4}. This illustrates that efficiency is no problem with such
interactive examples.
\section{Outlook}
This section describes possible extensions of the {\sc guardian}. The
extensions proposed in Section~\ref{simplification} on simplification
of terms and Section~\ref{background} on a background theory are clear
from a theoretical point of view but not yet implemented.
Section~\ref{integration} collects some ideas on the application of
our ideas to the {\sc reduce} integrator. In this field, there is some
more theoretical work necessary.
%
\subsection{Simplification of terms}\label{simplification}
Consider the expression $\sign(x)x-|x|$. It evaluates to the following
guarded expression:
$$
\begin{gex}
\gc{\true} & \gc{-|x|+\sign(x)x}\\
x\neq 0 & 0\\
x=0 & -x
\end{gex}.
$$
This suggests to substitute $-x$ by $0$ in the third case, which would
in turn allow to contract the two non-generic cases yielding
$$
\begin{gex}
\gc{\true} & \gc{-|x|+\sign(x)x}\\
\true & 0\end{gex}.
$$
In smart mode second case would then become the only generic case.

Generally, one would proceed as follows: If the guard is a conjunction
containing as toplevel equations
$$
t_1=0,\quad \dots,\quad t_k=0,
$$
reduce the corresponding expression modulo the set of univariate
linear polynomials among $t_1$, \dots,~$t_k$.

A more general approach would reduce the expression modulo a Gr\"obner
basis of all the $t_1$, \dots,~$t_k$. This leads, however, to larger
expressions in general.

One can also imagine to make use of non-conjunctive guards in the
following way:
\begin{enumerate}
\item Compute a {\sc dnf} of the guard.
\item Split the case into several cases corresponding to the
conjunctions in the {\sc dnf}.
\item Simplify the terms.
\item Apply the standard simplification procedure to the resulting
guarded expression. Note that it includes {\em contraction of cases}.
\end{enumerate}
According to experiences with similar ideas in the ``Gr\"obner
simplifier'' described in~\cite{DolzmannSturm:95}, this should work
well.
%
\subsection{Background theory}\label{background}
In practice one often computes with quantities guaranteed to lie in a
certain range. For instance, when computing an electrical resistance,
one knows in advance that it will not be negative. For such cases one
would like to have some facility to provide external information to
the system. This can then be used to reduce the complexity of the
guarded expressions.

One would provide a function {\tt assert($\varphi$)}, which asserts
the formula {\tt $\varphi$} to hold. Successive applications of {\tt
assert} establish a {\em background theory}, which is a set of
formulas considered conjunctively. The information contained in the
background theory can be used with the guarded expression computation.
The user must, however, not rely on all the background information to
be actually used.

Technically, denote by $\Phi$ the (conjunctive) background theory. For
the {\em simplification of the guards}, we can make use of the fact
that our simplifier is designed to simplify wrt.~a theory,
cf.~\cite{DolzmannSturm:95}. For proving that some guard $\gamma$ is
{\em tautological}, we try to prove
$$\underline{\forall}(\Phi\longrightarrow\gamma)$$ instead of
$\underline{\forall}\gamma$. Similarly, for proving that $\gamma$ is
{\em contradictive}, we try to disprove
$$\underline{\exists}(\Phi\land\gamma).$$ Instead of proving
$\underline{\forall}(\gamma_1\longrightarrow\gamma_2)$ in smart mode, we try to
prove
$$\underline{\forall}\bigl((\Phi\land\gamma_1)\longrightarrow\gamma_2\bigr).$$

Independently, one can imagine to use a background theory for reducing
the {\em output} with the {\em matrix} output mode. For this, one
simplifies each guard wrt.~the theory at the output stage treating
contradictions and tautologies appropriately. Using the theory for
replacing all cases by one at output stage in a smart mode manner
leads once more to the problem of expressions or even guarded
expressions ``mysteriously'' getting more complicated. Applying the
theory only at the output stage makes it possible to implement a
procedure {\tt unassert($\varphi$)} in a reasonable way.
%
\subsection{Integration}\label{integration}
{\sc Cas} integrators make ``mistakes'' similar to those we have
examined. Consider, e.g., the typical result
$$
\int x^a\,dx=\frac{1}{a+1}x^{a+1}.
$$
It does not cover the case $a=-1$, for which one wishes to obtain
$$
\int x^{-1}\,dx=\ln x.
$$
This problem can also be solved by using guarded expressions for
integration results.

Within the framework of this paper, we would have to associate a
guarding scheme to the integrator {\tt int}. It is not hard to see
that this cannot be done in a reasonable way without putting as much
knowledge into the scheme as into the integrator itself. Thus for
treating integration, one has to modify the integrator to provide
guarded expressions.

Next, we have to clarify what the guarded expression for the above
integral would look like. Since we know that the integral is defined
for all interpretations of the variables, our
assumption~(\ref{gencoversall}) implies that the generic condition be
``$\true$.'' We obtain the guarded expression
$$
\begin{gex}
\gc{\true}& \gc{\int x^a\,dx}\\
a\neq-1& \frac{1}{a+1}x^{a+1}\\
a=-1 & \ln x
\end{gex}.
$$
Note that the redundant generic case does not model the system's
current behavior.
%
\subsection{Combining algebra with logic}
Our method, in the described form, uses an already implemented
algebraic evaluator. In the previous section, we have seen that this
point of view is not sufficient for treating integration
appropriately.

Also our approach runs into trouble with built-in knowledge such as
\begin{eqnarray}
\sqrt{x^2}&=&|x|\label{sqrtrule},\\
\sign(|x|)&=&1\label{signrule}.
\end{eqnarray}
Equation~(\ref{sqrtrule}) introduces an absolute value operator within
a non-generic term without making a case distinction.
Equation~(\ref{signrule}) is wrong when not considering $x$
transcendental. In contrast to the situation with reciprocals, our
technique cannot be used to avoid this ``mistake.'' We obtain
$$
\sign(|x|)=\begin{gex}
\gc{\true} & \gc{1}\\
x\neq0 & 1\\
x=0 & 0
	   \end{gex}
$$
yielding two different answers for $x=0$.

We have already seen in the example Section~\ref{examples} that the
implementation of knowledge such as~(\ref{sqrtrule})
and~(\ref{signrule}) is usually quite {\it ad hoc}, and can be mostly
covered by using guarded expressions. This obesrvation gives rise to
the following question: When designing a new {\sc cas} based on guarded
expressions, how should the knowledge be distributed between the
algebraic side and the logic side?
%
\section{Conclusions}
Guarded expressions can be used to overcome well-known problems with
interpreting expressions as terms. We have explained in detail how to
compute with guarded expressions including several simplification
techniques. Moreover we gain algebraic simplification power from the
logical simplifications. Numerous examples illustrate the power of our
simplification methods. The largest part of our ideas is efficiently
implemented, and the software is published. The outlook on background
theories and on the treatment of integration by guarded expressions
points on interesting future extensions.
\nocite{Bradford:92}

\begin{thebibliography}{10}

\bibitem{Bradford:92}
{Bradford, R.}
\newblock Algebraic simplification of multiple valued functions.
\newblock In {\em Design and Implementation of Symbolic Computation Systems\/}
  (1992), J.~Fitch, Ed., vol.~721 of {\em Lecture Notes in Computer Science},
  Springer-Verlag, pp.~13--21.
\newblock Proceedings of the DISCO 92.

\bibitem{BroadberryGomezDiazWatt:95}
{Broadberry, P., G\'omez-D\'{\i}az, T., and Watt, S.}
\newblock On the implementation of dynamic evaluation.
\newblock In {\em Proceedings of the International Symposium on Symbolic and
  Algebraic Manipulation (ISSAC 95)\/} (New York, N.Y., 1995), A.~Levelt, Ed.,
  ACM Press, pp.~77--89.

\bibitem{Collins:75}
{Collins, G.~E.}
\newblock Quantifier elimination for the elementary theory of real closed
  fields by cylindrical algebraic decomposition.
\newblock In {\em Automata Theory and Formal Languages. 2nd GI Conference\/}
  (Berlin, Heidelberg, New York, May 1975), H.~Brakhage, Ed., vol.~33 of {\em
  Lecture Notes in Computer Science}, Gesellschaft f\"ur Informatik,
  Springer-Verlag, pp.~134--183.

\bibitem{CorlessJeffrey:92}
{Corless, R.~M., and Jeffrey, D.~J.}
\newblock Well \dots it isn't quite that simple.
\newblock {\em ACM SIGSAM Bulletin 26}, 3 (Aug. 1992), 2--6.
\newblock Feature.

\bibitem{DavenportFaure:94}
{Davenport, J.~H., and Faure, C.}
\newblock The ``unknown'' in computer algebra.
\newblock {\em Programmirovanie 1}, 1 (1994).

\bibitem{DolzmannSturm:95}
{Dolzmann, A., and Sturm, T.}
\newblock Simplification of quan\-ti\-fier-free formulas over ordered fields.
\newblock Technical Report MIP-9517, FMI, Universit\"at Passau, D-94030 Passau,
  Germany, Oct. 1995.
\newblock To appear in the Journal of Symbolic Computation.

\bibitem{DolzmannSturm:96}
{Dolzmann, A., and Sturm, T.}
\newblock Redlog---computer algebra meets computer logic.
\newblock Technical Report MIP-9603, FMI, Universit\"at Passau, D-94030 Passau,
  Germany, Feb. 1996.

\bibitem{DolzmannSturm:96a}
{Dolzmann, A., and Sturm, T.}
\newblock Redlog user manual.
\newblock Technical Report MIP-9616, FMI, Universit\"at Passau, D-94030 Passau,
  Germany, Oct. 1996.
\newblock Edition 1.0 for Version 1.0.

\bibitem{DuvalGonzalesVega:93}
{Duval, D., and Gonz\'ales-Vega, L.}
\newblock Dynamic evaluation and real closure.
\newblock In {\em Proceedings of the IMACS Symposium on Symbolic Computation\/}
  (1993).

\bibitem{DuvalReynaud:94}
{Duval, D., and Reynaud, J.-C.}
\newblock Sketches and computation {I}: Basic definitions and static
  evaluation.
\newblock {\em Mathematical Structures in Computer Science 4}, 2 (1994),
  185--238.

\bibitem{DuvalReynaud:94a}
{Duval, D., and Reynaud, J.-C.}
\newblock Sketches and computation {II}: Dynamic evaluation and applications.
\newblock {\em Mathematical Structures in Computer Science 4}, 2 (1994),
  239--271.

\bibitem{GomezDiaz:93}
{G\'omez-D\'{\i}az, T.}
\newblock Examples of using dynamic constructible closure.
\newblock In {\em Proceedings of the IMACS Symposium on Symbolic Computation\/}
  (1993).

\bibitem{HearnFitch:95}
{Hearn, A.~C., and Fitch, J.~P.}
\newblock {\em Reduce User's Manual for Version~3.6}.
\newblock RAND, Santa Monica, CA 90407-2138, July 1995.
\newblock RAND Publication CP78.

\bibitem{Hong:93}
{Hong, H., Collins, G.~E., Johnson, J.~R., and Encarnacion, M.~J.}
\newblock {QEPCAD} interactive version 12.
\newblock Kindly communicated to us by Hoon Hong, Sept. 1993.

\bibitem{LoosWeispfenning:93}
{Loos, R., and Weispfenning, V.}
\newblock Applying linear quantifier elimination.
\newblock {\em The Computer Journal 36}, 5 (1993), 450--462.
\newblock Special issue on computational quantifier elimination.

\bibitem{Melenk:95}
{Melenk, H.}
\newblock Reduce symbolic mode primer.
\newblock In {\em REDUCE 3.6 User's Guide for UNIX}. Konrad-Zuse-Institut,
  Berlin, 1995.

\bibitem{Tarski:48}
{Tarski, A.}
\newblock A decision method for elementary algebra and geometry.
\newblock Tech. rep., University of California, 1948.
\newblock Second edn., rev. 1951.

\bibitem{Weispfenning:88}
{Weispfenning, V.}
\newblock The complexity of linear problems in fields.
\newblock {\em Journal of Symbolic Computation 5}, 1 (Feb. 1988), 3--27.

\bibitem{Weispfenning:92}
{Weispfenning, V.}
\newblock Comprehensive {G}r\"obner bases.
\newblock {\em Journal of Symbolic Computation 14\/} (July 1992), 1--29.

\bibitem{Weispfenning:94}
{Weispfenning, V.}
\newblock Quantifier elimination for real algebra---the cubic case.
\newblock In {\em Proceedings of the International Symposium on Symbolic and
  Algebraic Computation in Oxford\/} (New York, July 1994), ACM Press,
  pp.~258--263.

\bibitem{Weispfenning:96}
{Weispfenning, V.}
\newblock Quantifier elimination for real algebra---the quadratic case and
  beyond.
\newblock To appear in AAECC.

\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/0000755000175000017500000000000011722677364021320 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/int/vect.red0000644000175000017500000000702111526203062022733 0ustar  giovannigiovanniMODULE VECT;  % Vector support routines.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modified by: James H. Davenport.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


EXPORTS MKUNIQUEVECT,MKVEC,MKVECF2Q,MKIDENM,COPYVEC,VECSORT,SWAP,
        NON!-NULL!-VEC,MKVECT2;

SYMBOLIC PROCEDURE MKUNIQUEVECT V;
BEGIN SCALAR U,N;
  N:=UPBV V;
  FOR I:=0:N DO BEGIN
    SCALAR UU;
    UU:=GETV(V,I);
    IF NOT (UU MEMBER U)
      THEN U:=UU.U
    END;
  RETURN MKVEC U
  END;

SYMBOLIC PROCEDURE MKVEC(L);
BEGIN SCALAR V,I;
  V:=MKVECT(ISUB1 LENGTH L);
  I:=0;
  WHILE L DO <>;
  RETURN V
  END;

SYMBOLIC PROCEDURE MKVECF2Q(L);
BEGIN
  SCALAR V,I,LL;
  V:=MKVECT(ISUB1 LENGTH L);
  I:=0;
  WHILE L DO <<
    LL:=CAR L;
    IF LL = 0 THEN LL:=NIL;
    PUTV(V,I,!*F2Q LL);
    I:=IADD1 I;
    L:=CDR L >>;
  RETURN V
  END;

SYMBOLIC PROCEDURE MKIDENM N;
BEGIN
  SCALAR ANS,U;
  SCALAR C0,C1;
  C0:=NIL ./ 1;
  C1:= 1 ./ 1;
  % constants.
  ANS:=MKVECT(N);
  FOR I:=0 STEP 1 UNTIL N DO <<
    U:=MKVECT N;
    FOR J:=0 STEP 1 UNTIL N DO
      IF I IEQUAL J
        THEN PUTV(U,J,C1)
        ELSE PUTV(U,J,C0);
    PUTV(ANS,I,U) >>;
  RETURN ANS
  END;

SYMBOLIC PROCEDURE COPYVEC(V,N);
   BEGIN SCALAR NEW;
    NEW:=MKVECT(N);
    FOR I:=0:N DO PUTV(NEW,I,GETV(V,I));
    RETURN NEW
   END;

SYMBOLIC PROCEDURE VECSORT(U,L);
% Sorts vector v of numbers into decreasing order.
% Performs same interchanges of all vectors in the list l.
BEGIN
  SCALAR J,K,N,V,W;
  N:=UPBV U;% elements 0...n exist.
  % algorithm used is a bubble sort.
  FOR I:=1:N DO BEGIN
    V:=GETV(U,I);
    K:=I;
  LOOP:
    J:=K;
    K:=ISUB1 K;
    W:=GETV(U,K);
    IF V<=W
      THEN GOTO ORDERED;
    PUTV(U,K,V);
    PUTV(U,J,W);
    MAPC(L,FUNCTION (LAMBDA U;SWAP(U,J,K)));
    IF K>0
      THEN GOTO LOOP;
  ORDERED:
    END;
  RETURN NIL
  END;

SYMBOLIC PROCEDURE SWAP(U,J,K);
IF NULL U
  THEN NIL
  ELSE BEGIN
    SCALAR V;
    %swaps elements i,j of vector u.
    V:=GETV(U,J);
    PUTV(U,J,GETV(U,K));
    PUTV(U,K,V)
    END;

SYMBOLIC PROCEDURE NON!-NULL!-VEC V;
BEGIN
  SCALAR CNT;
  CNT := 0;
  FOR I:=0:UPBV V DO
    IF GETV(V,I)
      THEN CNT:=IADD1 CNT;
  RETURN CNT
  END;

SYMBOLIC PROCEDURE MKVECT2(N,INITIAL);
BEGIN
  SCALAR U;
  U:=MKVECT N;
  FOR I:=0:N DO
    PUTV(U,I,INITIAL);
  RETURN U
  END;

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/hacksqrt.red0000644000175000017500000001235611526203062023621 0ustar  giovannigiovanniMODULE HACKSQRT;  % Routines for manipulation of sqrt expressions.

% Author: James H. Davenport.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


FLUID '(NESTEDSQRTS THISPLACE);

EXPORTS SQRTSINTREE,SQRTSINSQ,SQRTSINSQL,SQRTSINSF,SQRTSIGN;
EXPORTS DEGREENEST,SORTSQRTS;

IMPORTS MKVECT,INTERR,GETV,DEPENDSP,UNION;

SYMBOLIC PROCEDURE SQRTSINTREE(U,VAR,SLIST);
% Adds to slist all the sqrts in the prefix-type tree u.
IF ATOM U
  THEN SLIST
  ELSE IF CAR U EQ '!*SQ
    THEN UNION(SLIST,SQRTSINSQ(CADR U,VAR))
    ELSE IF CAR U EQ 'SQRT
      THEN IF DEPENDSP(ARGOF U,VAR)
        THEN <<
          SLIST:=SQRTSINTREE(ARGOF U,VAR,SLIST);
          %  nested square roots
          IF MEMBER(U,SLIST)
            THEN SLIST
            ELSE U.SLIST >>
        ELSE SLIST
      ELSE SQRTSINTREE(CAR U,VAR,SQRTSINTREE(CDR U,VAR,SLIST));


SYMBOLIC PROCEDURE SQRTSINSQ(U,VAR);
   % Returns list of all sqrts in sq.
   SQRTSINSF(DENR U,SQRTSINSF(NUMR U,NIL,VAR),VAR);


SYMBOLIC PROCEDURE SQRTSINSQL(U,VAR);
% Returns list of all sqrts in sq list.
IF NULL U
  THEN NIL
  ELSE SQRTSINSF(DENR CAR U,
      SQRTSINSF(NUMR CAR U,SQRTSINSQL(CDR U,VAR),VAR),VAR);


SYMBOLIC PROCEDURE SQRTSINSF(U,SLIST,VAR);
% Adds to slist all the sqrts in sf.
IF DOMAINP U OR NULL U
  THEN SLIST
  ELSE <<
    IF  EQCAR(MVAR U,'SQRT) AND
        DEPENDSP(ARGOF MVAR U,VAR) AND
        NOT MEMBER(MVAR U,SLIST)
      THEN BEGIN
        SCALAR SLIST2;
        SLIST2:=SQRTSINTREE(ARGOF MVAR U,VAR,NIL);
        IF SLIST2
          THEN <<
            NESTEDSQRTS:=T;
            SLIST:=UNION(SLIST2,SLIST) >>;
        SLIST:=(MVAR U).SLIST
        END;
    SQRTSINSF(LC U,SQRTSINSF(RED U,SLIST,VAR),VAR) >>;


SYMBOLIC PROCEDURE EASYSQRTSIGN(SLIST,THINGS);
% This procedure builds a list of all substitutions for all possible
% combinations of square roots in list.
IF NULL SLIST
  THEN THINGS
  ELSE EASYSQRTSIGN(CDR SLIST,
                    NCONC(MAPCONS(THINGS,(CAR SLIST).(CAR SLIST)),
                          MAPCONS(THINGS,
                                  LIST(CAR SLIST,'MINUS,CAR SLIST))));

SYMBOLIC PROCEDURE HARDSQRTSIGN(SLIST,THINGS);
% This procedure fulfils the same role for nested sqrts
% ***assumption: the simpler sqrts come further up the list.
IF NULL SLIST
  THEN THINGS
  ELSE BEGIN
    SCALAR THISPLACE,ANSWERS,POS,NEG;
    THISPLACE:=CAR SLIST;
    ANSWERS:= for each u in THINGS collect SUBLIS(U,THISPLACE) . U;
    POS := for each u in ANSWERS collect (THISPLACE . CAR U) . CDR U;
    % pos is sqrt(f) -> sqrt(innersubst f)
    NEG := for each u in ANSWERS
       collect {THISPLACE,'MINUS,CAR U} . CDR U;
    % neg is sqrt(f) -> -sqrt(innersubst f)
    RETURN HARDSQRTSIGN(CDR SLIST,NCONC(POS,NEG))
    END;


SYMBOLIC PROCEDURE DEGREENEST(PF,VAR);
% Returns the maximum degree of nesting of var
% inside sqrts in the prefix form pf.
IF ATOM PF
  THEN 0
  ELSE IF CAR PF EQ 'SQRT
    THEN IF DEPENDSP(CADR PF,VAR)
      THEN IADD1 DEGREENEST(CADR PF,VAR)
      ELSE 0
    ELSE IF CAR PF EQ 'EXPT
      THEN IF DEPENDSP(CADR PF,VAR)
        THEN IF EQCAR(CADDR PF,'QUOTIENT)
          THEN IADD1 DEGREENEST(CADR PF,VAR)
          ELSE DEGREENEST(CADR PF,VAR)
        ELSE 0
      ELSE DEGREENESTL(CDR PF,VAR);

SYMBOLIC PROCEDURE DEGREENESTL(U,VAR);
%Returns max degreenest from list of pfs u.
IF NULL U
  THEN 0
  ELSE MAX(DEGREENEST(CAR U,VAR),
           DEGREENESTL(CDR U,VAR));


SYMBOLIC PROCEDURE SORTSQRTS(U,VAR);
% Sorts list of sqrts into order required by hardsqrtsign
% (and many other parts of the package).
BEGIN
  SCALAR I,V;
  V:=MKVECT(10); %should be good enough!
  WHILE U DO <<
    I:=DEGREENEST(CAR U,VAR);
    IF I IEQUAL 0
      THEN INTERR "Non-dependent sqrt found";
    IF I > 10
      THEN INTERR
         "Degree of nesting exceeds 10 (recompile with 10 increased)";
    PUTV(V,I,(CAR U).GETV(V,I));
    U:=CDR U >>;
  U:=GETV(V,10);
  FOR I :=9 STEP -1 UNTIL 1 DO
    U:=NCONC(GETV(V,I),U);
  RETURN U
  END;


SYMBOLIC PROCEDURE SQRTSIGN(SQRTS,X);
   IF NESTEDSQRTS THEN HARDSQRTSIGN(SORTSQRTS(SQRTS,X),LIST NIL)
    ELSE EASYSQRTSIGN(SQRTS,LIST NIL);

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/csolve.red0000644000175000017500000001426511526203062023275 0ustar  giovannigiovannimodule csolve;   % routines to do with the C constants.

% Author: John P. Fitch.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trint ccount cmap cmatrix cval loglist neweqn);

exports backsubst4cs,createcmap,findpivot,printvecsq, % printspreadc
   spreadc,subst4eliminateds;

imports nth,interr,!*multf,printsf,printsq,quotf,putv,negf,invsq,
   negsq,addsq,multsq,mksp,addf,domainp,pnth;

symbolic procedure findpivot cvec;
% Finds first non-zero element in CVEC and returns its cell number.
% If no such element exists, result is nil.
   begin         scalar i,x;
      i:=1;
      x:=getv(cvec,i);
      while i>;
      if null x then return nil;
      return i
   end;

symbolic procedure subst4eliminatedcs(neweqn,substorder,ceqns);
% Substitutes into NEWEQN for all the C's that have been eliminated so
% far. These are given by CEQNS. SUBSTORDER gives the order of
% substitution as well as the constant multipliers. Result is the
% transformed NEWEQN.
   if null substorder then neweqn
   else begin    scalar nxt,row,cvar,temp;
      row:=car ceqns;
      nxt:=car substorder;
      if null (cvar:=getv(neweqn,nxt)) then
         return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns);
      nxt:=getv(row,nxt);
      for i:=0 : ccount do
      << temp:=!*multf(nxt,getv(neweqn,i));
         temp:=addf(temp,negf !*multf(cvar,getv(row,i)));
         putv(neweqn,i,temp) >>;
      return subst4eliminatedcs(neweqn,cdr substorder,cdr ceqns)
   end;


symbolic procedure backsubst4cs(cs2subst,cs2solve,cmatrix);
% Solves the C-eqns and sets vector CVAL to the C-constant values
% CMATRIX is a list of matrix rows for C-eqns after Gaussian
% elimination has been performed. CS2SOLVE is a list of the remaining
% C's to evaluate and CS2SUBST are the C's we have evaluated already.
   if null cmatrix then nil
   else begin    scalar eqnn,cvar,already,substlist,temp,temp2;
      eqnn:=car cmatrix;
      cvar:=car cs2solve;
      already:=nil ./ 1; % The S.Q. nil.
      substlist:=cs2subst;
% Now substitute for previously evaluated c's:
      while not null substlist do
      << temp:=car substlist;
         if not null getv(eqnn,temp) then
            already:=addsq(already,multsq(getv(eqnn,temp) ./ 1,
                                 getv(cval,temp)));
         substlist:=cdr substlist >>;
% Now solve for the c given by cvar (any remaining c's assumed zero).
      temp:=negsq addsq(getv(eqnn,0) ./ 1,already);
      if not null (temp2:=quotf(numr temp,getv(eqnn,cvar))) then
                                       temp:=temp2 ./ denr temp
      else temp:=multsq(temp,invsq(getv(eqnn,cvar) ./ 1));
      if not null numr temp then putv(cval,cvar,
                resimp rootextractsq subs2q temp);
      backsubst4cs(reversip(cvar . reversip cs2subst),
            cdr cs2solve,cdr cmatrix)
   end;

%**********************************************************************
% Routines to deal with linear equations for the constants C.
%**********************************************************************

symbolic procedure createcmap;
%Sets LOGLIST to list of things of form (LOG C-constant f), where f is
% function linear in one of the z-variables and C-constant is in S.F.
% When creating these C-constant names, the CMAP is also set up and
% returned as the result.
   begin         scalar i,l,c;
      l:=loglist;
      i:=1;
      while not null l do <<
         c:=(int!-gensym1('c) . i) . c;
         i:=i+1;
         rplacd(car l,((mksp(caar c,1) .* 1) .+ nil) . cdar l);
         l:=cdr l >>;
      if !*trint
        then printc ("Constants Created for log and tan terms:" . c);
      return c
   end;


symbolic procedure spreadc(eqnn,cvec1,w);
% Sets a vector 'cvec1' to coefficients of c in eqnn.
    if domainp eqnn then putv(cvec1,0,addf(getv(cvec1,0),
                                !*multf(eqnn,w)))
    else begin    scalar mv,t1,t2;
        spreadc(red eqnn,cvec1,w);
        mv:=mvar eqnn;
        t1:=assoc(mv,cmap); %tests if it is a c var.
        if not null t1 then return <<
            t1:=cdr t1; %loc in vector for this c.
            if not (tdeg lt eqnn=1) then interr "Not linear in c eqn";
            t2:=addf(getv(cvec1,t1),!*multf(w,lc eqnn));
            putv(cvec1,t1,t2) >>;
        t1:=((lpow eqnn) .* 1) .+ nil; %this main var as sf.
        spreadc(lc eqnn,cvec1,!*multf(w,t1))
    end;

% symbolic procedure printspreadc cvec1;
%     begin
%         for i:=0 : ccount do <<
%            prin2 i;
%            printc ":";
%            printsf(getv(cvec1,i)) >>;
%         printc "End of printspreadc output"
%     end;

% symbolic procedure printvecsq cvec;
% % Print contents of cvec which contains s.q.'s (not s.f.'s).
% % Starts from cell 1 not 0 as above routine (printspreadc).
%    begin
%       for i:=1 : ccount do <<
%         prin2 i;
%         printc ":";
%         if null getv(cvec,i) then printc "0"
%         else printsq(getv(cvec,i)) >>;
%       printc "End of printvecsq output"
%    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/int.tst0000644000175000017500000003566411526203062022642 0ustar  giovannigiovanniCOMMENT

                 THE REDUCE INTEGRATION TEST PACKAGE

                              Edited By

                           Anthony C. Hearn
			 The RAND Corporation


This file is designed to provide a set of representative tests of the
Reduce integration package.  Not all examples go through, even when an
integral exists, since some of the arguments are outside the domain of
applicability of the current package.  However, future improvements to
the package will result in more closed-form evaluations in later
releases.  We would appreciate any additional contributions to this test
file either because they illustrate some feature (good or bad) of the
current package, or suggest domains which future versions should handle.
Any suggestions for improved organization of this test file (e.g., in a
way which corresponds more directly to the organization of a standard
integration table book such as Gradshteyn and Ryznik) are welcome.

Acknowledgments:

The examples in this file have been contributed by the following.
Any omissions to this list should be reported to the Editor.

David M. Dahm
James H. Davenport
John P. Fitch
Steven Harrington
Anthony C. Hearn
K. Siegfried Koelbig
Ernst Krupnikov
Arthur C. Norman
Herbert Stoyan
;

Comment we first set up a suitable testing functions;

fluid '(gcknt!*);

global '(faillist!* gcnumber!* inittime number!-of!-integrals
         unintlist!*);

symbolic operator time;

symbolic procedure initialize!-integral!-test;
   begin
      faillist!* := unintlist!* := nil;
      number!-of!-integrals := 0;
      gcnumber!* := gcknt!*;
      inittime := time()
   end;   

symbolic procedure summarize!-integral!-test;
   begin scalar totaltime;
      totaltime := time()-inittime;
      prin2t 
   "                *****     SUMMARY OF INTEGRAL TESTS     *****";
      terpri();
      prin2 "Number of integrals tested: ";
      prin2t number!-of!-integrals;
      terpri();
      prin2 "Total time taken: ";
      prin2 totaltime;
      prin2t " ms";
      terpri();
      if gcnumber!*
        then <>;
      prin2 "Number of incorrect integrals: ";
            prin2t length faillist!*;
      terpri();
      prin2 "Number of unevaluated integrals: ";
      prin2t length unintlist!*;
      terpri();
      if faillist!* 
        then <>;
      if unintlist!*
        then <>
   end;

procedure testint(a,b);
  begin scalar der,diffce,res,tt;
      tt:=time();
      symbolic (number!-of!-integrals := number!-of!-integrals + 1);
      res:=int(a,b);
%     write "time for integral:  ",time()-tt," ms";
      off precise;
      der := df(res,b);
      diffce := der-a;
      if diffce neq 0
	then  begin for all x let cot x=cos x/sin x,
				  sec x=1/cos x,
				  sin x**2=1-cos x**2,
				  tan(x/2)=sin x/(1+cos x),
				  tan x=sin x/cos x,
		    		  tanh x=
				     (e**(x)-e**(-x))/(e**x+e**(-x)),
				  coth x= 1/tanh x;
	       	    diffce := diffce;
		    for all x clear cot x,sec x,sin x**2,tan x,tan(x/2),
				    tanh x,coth x
	      end;
	%hopefully, difference appeared non-zero due to absence of
	%above transformations;
      if diffce neq 0
	then <>;
      if diffce neq 0
	then begin scalar !*reduced;
		symbolic(!*reduced := t);
		for all x let cos(2x)= 1-2sin x**2, sin x**2=1-cos x**2;
		diffce := diffce;
	       for all x clear cos(2x),sin x**2
	     end;
      if diffce neq 0
	then <>;
               symbolic if smemq('int,res)
                    then unintlist!* := list(a,b,res) . unintlist!*;
      on precise;
      return res
  end;

symbolic initialize!-integral!-test();

% References are to Gradshteyn and Ryznik.

testint(1+x+x**2,x);
testint(x**2*(2*x**2+x)**2,x);
testint(x*(x**2+2*x+1),x);
testint(1/x,x);  % 2.01 #2;
testint((x+1)**3/(x-1)**4,x);
testint(1/(x*(x-1)*(x+1)**2),x);
testint((a*x+b)/((x-p)*(x-q)),x);
testint(1/(a*x**2+b*x+c),x);
testint((a*x+b)/(1+x**2),x);
testint(1/(x**2-2*x+3),x);

% Rational function examples from Hardy, Pure Mathematics, p 253 et seq.

testint(1/((x-1)*(x**2+1))**2,x);
testint(x/((x-a)*(x-b)*(x-c)),x);
testint(x/((x**2+a**2)*(x**2+b**2)),x);
testint(x**2/((x**2+a**2)*(x**2+b**2)),x);
testint(x/((x-1)*(x**2+1)),x);
testint(x/(1+x**3),x);
testint(x**3/((x-1)**2*(x**3+1)),x);
testint(1/(1+x**4),x);
testint(x**2/(1+x**4),x);
testint(1/(1+x**2+x**4),x);

% Examples involving a+b*x.

z := a+b*x;

testint(z**p,x);
testint(x*z**p,x);
testint(x**2*z**p,x);
testint(1/z,x);
testint(1/z**2,x);
testint(x/z,x);
testint(x**2/z,x);
testint(1/(x*z),x);
testint(1/(x**2*z),x);
testint(1/(x*z)**2,x);
testint(1/(c**2+x**2),x);
testint(1/(c**2-x**2),x);

% More complicated rational function examples, mostly contributed
% by David M. Dahm, who also developed the code to integrate them.

testint(1/(2*x**3-1),x);
testint(1/(x**3-2),x);
testint(1/(a*x**3-b),x);
testint(1/(x**4-2),x);
testint(1/(5*x**4-1),x);
testint(1/(3*x**4+7),x);
testint(1/(x**4+3*x**2-1),x);
testint(1/(x**4-3*x**2-1),x);
testint(1/(x**4-3*x**2+1),x);
testint(1/(x**4-4*x**2+1),x);
testint(1/(x**4+4*x**2+1),x);
testint(1/(x**4+x**2+2),x);
testint(1/(x**4-x**2+2),x);
testint(1/(x**6-1),x);
testint(1/(x**6-2),x);
testint(1/(x**6+2),x);
testint(1/(x**8+1),x);
testint(1/(x**8-1),x);
testint(1/(x**8-x**4+1),x);
testint(x**7/(x**12+1),x);

% Examples involving logarithms.

testint(log x,x);
testint(x*log x,x);
testint(x**2*log x,x);
testint(x**p*log x,x);
testint((log x)**2,x);
testint(x**9*log x**11,x);
testint(log x**2/x,x);
testint(1/log x,x);
testint(1/log(x+1),x);
testint(1/(x*log x),x);
testint(1/(x*log x)**2,x);
testint((log x)**p/x,x);
testint(log x *(a*x+b),x);
testint((a*x+b)**2*log x,x);
testint(log x/(a*x+b)**2,x);
testint(x*log (a*x+b),x);
testint(x**2*log(a*x+b),x);
testint(log(x**2+a**2),x);
testint(x*log(x**2+a**2),x);
testint(x**2*log(x**2+a**2),x);
testint(x**4*log(x**2+a**2),x);
testint(log(x**2-a**2),x);
testint(log(log(log(log(x)))),x);

% Examples involving circular functions.

testint(sin x,x); % 2.01 #5;
testint(cos x,x); %     #6;
testint(tan x,x); %     #11;
testint(1/tan(x),x); % 2.01 #12;
testint(1/(1+tan(x))**2,x);
testint(1/cos x,x);
testint(1/sin x,x);
testint(sin x**2,x);
testint(x**3*sin(x**2),x);
testint(sin x**3,x);
testint(sin x**p,x);
testint((sin x**2+1)**2*cos x,x);
testint(cos x**2,x);
testint(cos x**3,x);
testint(sin(a*x+b),x);
testint(1/cos x**2,x);
testint(sin x*sin(2*x),x);
testint(x*sin x,x);
testint(x**2*sin x,x);
testint(x*sin x**2,x);
testint(x**2*sin x**2,x);
testint(x*sin x**3,x);
testint(x*cos x,x);
testint(x**2*cos x,x);
testint(x*cos x**2,x);
testint(x**2*cos x**2,x);
testint(x*cos x**3,x);
testint(sin x/x,x);
testint(cos x/x,x);
testint(sin x/x**2,x);
testint(sin x**2/x,x);
testint(tan x**3,x);
% z := a+b*x;
testint(sin z,x);
testint(cos z,x);
testint(tan z,x);
testint(1/tan z,x);
testint(1/sin z,x);
testint(1/cos z,x);
testint(sin z**2,x);
testint(sin z**3,x);
testint(cos z**2,x);
testint(cos z**3,x);
testint(1/cos z**2,x);
testint(1/(1+cos x),x);
testint(1/(1-cos x),x);
testint(1/(1+sin x),x);
testint(1/(1-sin x),x);
testint(1/(a+b*sin x),x);
testint(1/(a+b*sin x+cos x),x);
testint(x**2*sin z**2,x);
testint(cos x*cos(2*x),x);
testint(x**2*cos z**2,x);
testint(1/tan x**3,x);
testint(x**3*tan(x)**4,x);
testint(x**3*tan(x)**6,x);
testint(x*tan(x)**2,x);
testint(sin(2*x)*cos(3*x),x);
testint(sin x**2*cos x**2,x);
testint(1/(sin x**2*cos x**2),x);
testint(d**x*sin x,x);
testint(d**x*cos x,x);
testint(x*d**x*sin x,x);
testint(x*d**x*cos x,x);
testint(x**2*d**x*sin x,x);
testint(x**2*d**x*cos x,x);
testint(x**3*d**x*sin x,x);
testint(x**3*d**x*cos x,x);
testint(sin x*sin(2*x)*sin(3*x),x);
testint(cos x*cos(2*x)*cos(3*x),x);
testint(sin(x*kx)**3*x**2,x);
testint(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);

% Mixed angles and half angles.

int(cos(x)/(sin(x)*tan(x/2)),x);

% This integral produces a messy result because the code for
% converting half angle tans to sin and cos is not effective enough.

testint(sin(a*x)/(b+c*sin(a*x))**2,x);

% Examples involving logarithms and circular functions.

testint(sin log x,x);
testint(cos log x,x);

% Examples involving exponentials.

testint(e**x,x); % 2.01 #3;
testint(a**x,x); % 2.01 #4;
testint(e**(a*x),x);
testint(e**(a*x)/x,x);
testint(1/(a+b*e**(m*x)),x);
testint(e**(2*x)/(1+e**x),x);
testint(e**(2*x)*e**(a*x),x);
testint(1/(a*e**(m*x)+b*e**(-m*x)),x);
testint(x*e**(a*x),x);
testint(x**20*e**x,x);
testint(a**x/b**x,x);
testint(a**x*b**x,x);
testint(a**x/x**2,x);
testint(x*a**x/(1+b*x)**2,x);
testint(x*e**(a*x)/(1+a*x)**2,x);
testint(x*k**(x**2),x);
testint(e**(x**2),x);
testint(x*e**(x**2),x);
testint((x+1)*e**(1/x)/x**4,x);
testint((2*x**3+x)*(e**(x**2))**2*e**(1-x*e**(x**2))/(1-x*e**(x**2))**2,
	x);
testint(e**(e**(e**(e**x))),x);

% Examples involving exponentials and logarithms.

testint(e**x*log x,x);
testint(x*e**x*log x,x);
testint(e**(2*x)*log(e**x),x);

% Examples involving square roots.

testint(sqrt(2)*x**2 + 2*x,x);
testint(log x/sqrt(a*x+b),x);
u:=sqrt(a+b*x);
v:=sqrt(c+d*x);
testint(u*v,x);
testint(u,x);
testint(x*u,x);
testint(x**2*u,x);
testint(u/x,x);
testint(u/x**2,x);
testint(1/u,x);
testint(x/u,x);
testint(x**2/u,x);
testint(1/(x*u),x);
testint(1/(x**2*u),x);
testint(u**p,x);
testint(x*u**p,x);
testint(atan((-sqrt(2)+2*x)/sqrt(2)),x);
testint(1/sqrt(x**2-1),x);
testint(sqrt(x+1)*sqrt x,x);

testint(sin(sqrt x),x);
testint(x*(1-x^2)^(-9/4),x);
testint(x/sqrt(1-x^4),x);
testint(1/(x*sqrt(1+x^4)),x);
testint(x/sqrt(1+x^2+x^4),x);
testint(1/(x*sqrt(x^2-1-x^4)),x);

% Examples from James Davenport's thesis:

testint(1/sqrt(x**2-1)+10/sqrt(x**2-4),x);      % p. 173
testint(sqrt(x+sqrt(x**2+a**2))/x,x);

% Examples generated by differentiating various functions.

testint(df(sqrt(1+x**2)/(1-x),x),x);
testint(df(log(x+sqrt(1+x**2)),x),x);
testint(df(sqrt(x)+sqrt(x+1)+sqrt(x+2),x),x);
testint(df(sqrt(x**5-2*x+1)-sqrt(x**3+1),x),x);

% Another such example from James Davenport's thesis (p. 146).
% It contains a point of order 3, which is found by use of Mazur's
% bound on the torsion of elliptic curves over the rationals;

testint(df(log(1+sqrt(x**3+1)),x),x);

% Examples quoted by Joel Moses:

testint(1/sqrt(2*h*r**2-alpha**2),r);
testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2)),r);
testint(1/(r*sqrt(2*h*r**2-alpha**2-2*k*r)),r);
testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2-2*k*r)),r);
testint(r/sqrt(2*e*r**2-alpha**2),r);
testint(r/sqrt(2*e*r**2-alpha**2-epsilon**2),r);
testint(r/sqrt(2*e*r**2-alpha**2-2*k*r**4),r);
testint(r/sqrt(2*e*r**2-alpha**2-2*k*r),r);

% These two integrals will evaluate, but they take a very long time
% and the results are messy (compared with the algint results).

% testint(1/(r*sqrt(2*h*r**2-alpha**2-2*k*r**4)),r);
% testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2-2*k*r**4)),r);


Comment many of these integrals used to require Steve Harrington's
	code to evaluate. They originated in Novosibirsk as examples
	of using Analytik. There are still a few examples that could
	be evaluated using better heuristics;

testint(a*sin(3*x+5)**2*cos(3*x+5),x);
testint(log(x**2)/x**3,x);
testint(x*sin(x+a),x);
testint((log(x)*(1-x)-1)/(e**x*log(x)**2),x);
testint(x**3*(a*x**2+b)**(-1),x);
testint(x**(1/2)*(x+1)**(-7/2),x);
testint(x**(-1)*(x+1)**(-1),x);
testint(x**(-1/2)*(2*x-1)**(-1),x);
testint((x**2+1)*x**(1/2),x);
testint(x**(-1)*(x-a)**(1/3),x);
testint(x*sinh(x),x);
testint(x*cosh(x),x);
testint(sinh(2*x)/cosh(2*x),x);
testint((i*eps*sinh x-1)/(eps*i*cosh x+i*a-x),x);
testint(sin(2*x+3)*cos(x)**2,x);
testint(x*atan(x),x);
testint(x*acot(x),x);
testint(x*log(x**2+a),x);
testint(sin(x+a)*cos(x),x);
testint(cos(x+a)*sin(x),x);
testint((1+sin(x))**(1/2),x);
testint((1-sin(x))**(1/2),x);
testint((1+cos(x))**(1/2),x);
testint((1-cos(x))**(1/2),x);
testint(1/(x**(1/2)-(x-1)**(1/2)),x);
testint(1/(1-(x+1)**(1/2)),x);
testint(x/(x**4+36)**(1/2),x);
testint(1/(x**(1/3)+x**(1/2)),x);
testint(log(2+3*x**2),x);
testint(cot(x),x);
testint(cot x**4,x);
testint(tanh(x),x);
testint(coth(x),x);
testint(b**x,x);
testint((x**4+x**(-4)+2)**(1/2),x);
testint((2*x+1)/(3*x+2),x);
testint(x*log(x+(x**2+1)**(1/2)),x);
testint(x*(e**x*sin(x)+1)**2,x);
testint(x*e**x*cos(x),x);

Comment the following set came from Herbert Stoyan;

testint(1/(x-3)**4,x);
testint(x/(x**3-1),x);
testint(x/(x**4-1),x);
testint(log(x)*(x**3+1)/(x**4+2),x);
testint(log(x)+log(x+1)+log(x+2),x);
testint(1/(x**3+5),x);
testint(1/sqrt(1+x**2),x);
testint(sqrt(x**2+3),x);
testint(x/(x+1)**2,x);

COMMENT The following integrals were used among others as a test of
	Moses' SIN program;

testint(asin x,x);
testint(x**2*asin x,x);
testint(sec x**2/(1+sec x**2-3*tan x),x);
testint(1/sec x**2,x);
testint((5*x**2-3*x-2)/(x**2*(x-2)),x);
testint(1/(4*x**2+9)**(1/2),x);
testint((x**2+4)**(-1/2),x);
testint(1/(9*x**2-12*x+10),x);
testint(1/(x**8-2*x**7+2*x**6-2*x**5+x**4),x);
testint((a*x**3+b*x**2+c*x+d)/((x+1)*x*(x-3)),x);
testint(1/(2-log(x**2+1))**5,x);

% The next integral appeared in Risch's 1968 paper.

testint(2*x*e**(x**2)*log(x)+e**(x**2)/x+(log(x)-2)/(log(x)**2+x)**2+
    ((2/x)*log(x)+(1/x)+1)/(log(x)**2+x),x);

% The following integral would not evaluate in REDUCE 3.3.

testint(exp(x*ze+x/2)*sin(pi*ze)**4*x**4,ze);

% This one evaluates:

testint(erf(x),x);

% So why not this one?

testint(erf(x+a),x);

Comment here is an example of using the integrator with pattern
	matching;

for all m,n let int(k1**m*log(k1)**n/(p**2-k1**2),k1)=foo(m,n),
		int(k1*log(k1)**n/(p**2-k1**2),k1)=foo(1,n),
		int(k1**m*log(k1)/(p**2-k1**2),k1)=foo(m,1),
		int(k1*log(k1)/(p**2-k1**2),k1)=foo(1,1),
		int(log(k1)**n/(k1*(p**2-k1**2)),k1)=foo(-1,n);

int(k1**2*log(k1)/(p**2-k1**2),k1);

Comment It is interesting to see how much of this one can be done;

let f1s= (12*log(s/mc**2)*s**2*pi**2*mc**3*(-8*s-12*mc**2+3*mc)
	+ pi**2*(12*s**4*mc+3*s**4+176*s**3*mc**3-24*s**3*mc**2
	-144*s**2*mc**5-48*s*mc**7+24*s*mc**6+4*mc**9-3*mc**8))
	 /(384*e**(s/y)*s**2);

int(f1s,s);

factor ei,log;

ws;

Comment the following is an example of integrals that used to loop
        forever.  They were first revealed by problems with Bessel
	function integration when specfn was loaded,
	e.g., int(x*besseli(2,x),x) or int(besselj(n,x),x);

operator f; let {df(f(~x),x) => x*f(x-1)};

int(f x,x);


Comment the following integrals reveal deficiencies in the current
integrator;

%high degree denominator;
%testint(1/(2-log(x**2+1))**5,x);

%this example should evaluate;
testint(sin(2*x)/cos(x),x);

%this example, which appeared in Tobey's thesis, needs factorization
%over algebraic fields. It currently gives an ugly answer and so has
%been suppressed;

% testint((7*x**13+10*x**8+4*x**7-7*x**6-4*x**3-4*x**2+3*x+3)/
%         (x**14-2*x**8-2*x**7-2*x**4-4*x**3-x**2+2*x+1),x);

symbolic summarize!-integral!-test();

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/contents.red0000644000175000017500000002171711526203062023637 0ustar  giovannigiovannimodule contents;

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(content indexlist sqfr varlist zlist);   % clogflag

exports contents,contentsmv,dfnumr,difflogs,factorlistlist, % multsqfree
        multup,sqfree,sqmerge;

imports int!-fac,fquotf,gcdf,interr,!*multf,partialdiff,quotf,ordop,
        addf,negf,domainp,difff,mksp,negsq,invsq,addsq,!*multsq,diffsq;


comment we assume no power substitution is necessary in this module;

symbolic procedure contents(p,v);
% Find the contents of the polynomial p wrt variable v;
% Note that v may not be the main variable of p;
    if domainp(p) then p
    else if v=mvar p then contentsmv(p,v,nil)
    else if ordop(v,mvar p) then p
    else contentsmv(makemainvar(p,v),v,nil);

symbolic procedure contentsmv(p,v,sofar);
% Find contents of polynomial P;
% V is main variable of P;
% SOFAR is partial result;
    if sofar=1 then 1
    else if domainp p then gcdf(p,sofar)
    else if not(v=mvar p) then gcdf(p,sofar)
    else contentsmv(red p,v,gcdf(lc p,sofar));

symbolic procedure makemainvar(p,v);
% Bring v up to be the main variable in polynomial p.
% Note that the reconstructed p must be used with care since
% it does not conform to the normal REDUCE ordering rules.
    if domainp p then p
    else if v=mvar p then p
    else mergeadd(mulcoeffsby(makemainvar(lc p,v),lpow p,v),
      makemainvar(red p,v),v);

symbolic procedure mulcoeffsby(p,pow,v);
% Multiply each coefficient in p by the standard power pow;
    if null p then nil
    else if domainp p or not(v=mvar p) then ((pow .* p) .+ nil)
    else (lpow p .* ((pow .* lc p) .+ nil)) .+ mulcoeffsby(red p,pow,v);

symbolic procedure mergeadd(a,b,v);
% Add polynomials a and b given that they have same main variable v;
    if domainp a or not(v=mvar a) then
      if domainp b or not(v=mvar b) then addf(a,b)
      else lt b .+ mergeadd(a,red b,v)
    else if domainp b or not(v=mvar b) then
      lt a .+ mergeadd(red a,b,v)
    else (lambda xc;
      if xc=0 then (lpow a .* addf(lc a,lc b)) .+
            mergeadd(red a,red b,v)
      else if xc>0 then lt a .+ mergeadd(red a,b,v)
      else lt b .+ mergeadd(a,red b,v))
        (tdeg lt a-tdeg lt b);

symbolic procedure sqfree(p,vl);
    if (null vl) or (domainp p) then
        <>
    else begin    scalar w,v,dp,gg,pg,dpg,p1,w1;
        w:=contents(p,car vl); % content of p ;
        p:=quotf(p,w); % make p primitive;
        w:=sqfree(w,cdr vl); % process content by recursion;
        if p=1 then return w;
        v:=car vl; % pick out variable from list;
        while not (p=1) do <<
            dp:=partialdiff(p,v);
            gg:=gcdf(p,dp);
            pg:=quotf(p,gg);
            dpg:=negf partialdiff(pg,v);
            p1:=gcdf(pg,addf(quotf(dp,gg),dpg));
            w1:=p1.w1;
            p:=gg>>;
        return sqmerge(reverse w1,w,t)
        end;

symbolic procedure sqmerge(w1,w,simplew1);
% w and w1 are lists of factors of each power. if simplew1 is true
% then w1 contains only single factors for each power. ;
    if null w1 then w
    else if null w then if car w1=1 then nil.sqmerge(cdr w1,w,simplew1)
          else (if simplew1 then list car w1 else car w1).
sqmerge(cdr w1,w,simplew1)
    else if car w1=1 then (car w).sqmerge(cdr w1,cdr w,simplew1) else
        append(if simplew1 then list car w1 else car w1,car w).
        sqmerge(cdr w1,cdr w,simplew1);

symbolic procedure multup l;
% l is a list of s.f.'s. result is s.f. for product of elements of l;
   begin         scalar res;
      res:=1;
      for each j in l do res := multf(res,j);
%     while not null l do <<
%        res:=multf(res,car l);
%        l:=cdr l >>;
      return res
   end;

symbolic procedure diflist(l,cl,x,rl);
% Differentiates l (list of s.f.'s) wrt x to produce the sum of
% terms for the derivative of numr of 1st part of answer.  cl is
% coefficient list (s.f.'s) & rl is list of derivatives we have
% dealt with so far.  Result is s.q.;
   if null l then nil ./ 1
   else begin    scalar temp;
      temp:=!*multf(multup rl,multup cdr l);
      temp:=!*multsq(difff(car l,x),!*f2q temp);
      temp:=!*multsq(temp,(car cl) ./ 1);
      return addsq(temp,diflist(cdr l,cdr cl,x,(car l).rl))
   end;

%symbolic procedure multsqfree w;
%% W is list of sqfree factors. result is product of each list in w
%% to give one polynomial for each sqfree power.
%   if null w then nil
%    else (multup car w) . multsqfree cdr w;

symbolic procedure l2lsf l;
% L is a list of kernels. result is a list of same members as s.f.'s;
   if null l then nil
   else ((mksp(car l,1) .* 1) .+ nil).l2lsf cdr l;

symbolic procedure dfnumr(x,dl);
% Gives the derivative of the numr of the 1st part of answer.
% dl is list of any exponential or 1+tan**2 that occur in integrand
% denr. these are divided out from result before handing it back.
% result is s.q., ready for printing.
   begin         scalar temp1,temp2,coeflist,qlist,count;
      if not null sqfr then <<
      count:=0;
      qlist:=cdr sqfr;
      coeflist:=nil;
      while not null qlist do <<
         count:=count+1;
         coeflist:=count.coeflist;
         qlist:=cdr qlist >>;
      coeflist:=reverse coeflist >>;
      temp1:=!*multsq(diflist(l2lsf zlist,l2lsf indexlist,x,nil),
                      !*f2q multup sqfr);
      if not null sqfr and not null cdr sqfr then <<
          temp2:=!*multsq(diflist(cdr sqfr,coeflist,x,nil),
                          !*f2q multup l2lsf zlist);
      temp2:=!*multsq(temp2,(car sqfr) ./ 1) >>
      else temp2:=nil ./ 1;
      temp1:=addsq(temp1,negsq temp2);
      temp2:=cdr temp1;
      temp1:=car temp1;
      qlist:=nil;
      while not null dl do <<
         if not(car dl member qlist) then qlist:=(car dl).qlist;
         dl:=cdr dl >>;
      while not null qlist do <<
         temp1:=quotf(temp1,car qlist);
         qlist:=cdr qlist >>;
      return temp1 ./ temp2
   end;

symbolic procedure difflogs(ll,denm1,x);
% LL is list of log terms (with coeffts), den is common denominator
% over which they are to be put.  Result is s.q. for derivative of all
% these wrt x.
   if null ll then nil ./ 1
   else begin    scalar temp,qu,cvar,logoratan,arg;
      logoratan:=caar ll;
      cvar:=cadar ll;
      arg:=cddar ll;
      temp:=!*multsq(cvar ./ 1,diffsq(arg,x));
      if logoratan='iden then qu:=1 ./ 1
        else if logoratan='log then qu:=arg
        else if logoratan='atan then qu:=addsq(1 ./ 1,!*multsq(arg,arg))
        else interr "Logoratan=? in difflogs";
%Note call to special division routine;
      qu:=fquotf(!*multf(!*multf(denm1,numr temp),
                denr qu),numr qu);
                        %*MUST* GO EXACTLY;
     temp:=!*multsq(!*invsq (denr temp ./ 1),qu);
                 %result of fquotf is a s.q;
      return !*addsq(temp,difflogs(cdr ll,denm1,x))
   end;

symbolic procedure factorlistlist w;
% W is list of lists of sqfree factors in s.f.  Result is list of log
% terms required for integral answer. the arguments for each log fn
% are in s.q.
    begin scalar res,x,y;
        while not null w do <<
            x:=car w;
            while not null x do <<
                y:=facbypp(car x,varlist);
                while not null y do <<
                    res:=append(int!-fac car y,res);
                    y:=cdr y >>;
                x:=cdr x >>;
            w:=cdr w >>;
        return res
    end;

symbolic procedure facbypp(p,vl);
% Use contents/primitive parts to try to factor p.
    if null vl then list p
    else begin scalar princilap!-part,co;
        co:=contents(p,car vl);
        vl:=cdr vl;
        if co=1 then return facbypp(p,vl); %this var no help.
        princilap!-part:=quotf(p,co); %primitive part.
        if princilap!-part=1 then return facbypp(p,vl); % again no help
        return nconc(facbypp(princilap!-part,vl),facbypp(co,vl))
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/int.red0000644000175000017500000000672111526203062022572 0ustar  giovannigiovannimodule int; % Header for REDUCE integration package.

% Authors: A. C. Norman and P. M. A. Moore.
% Modified by: J. Davenport, J. P. Fitch, A. C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Note that at one point, INT had been flagged SIMP0FN.  However, that
% lead to problems when the arguments of INT contained pattern
% variables.

create!-package('(int contents csolve idepend df2q distrib divide driver
                  symint intfac ibasics makevars jpatches reform
                  simpsqrt hacksqrt sqrtf isolve tidysqrt trcase
                  halfangl trialdiv vect dint),   % simplog
                  % cuberoot d3d4 factr kron lowdeg unifac uniform tdiff
                '(int trans));

fluid '(!*noextend !*pvar frlis!* gaussiani);

global '(gensymcount initl!*);

!*pvar:='!_a;

gaussiani := !*kk2f '(sqrt -1);

gensymcount := 0;

initl!* := append('(!*noextend), initl!*);

flag('(interr),'transfer);   %For the compiler;

flag ('(atan dilog ei erf expt log tan),'transcendental);

comment Kludge to define derivative of an integral and integral of
        a derivative;

frlis!* := union('(!=x !=y),frlis!*);

put('df,'opmtch,'(((int !=y !=x) !=x) (nil . t)
                  (evl!* !=y) nil) . get('df,'opmtch));

put('int,'opmtch,'(((df !=y !=x) !=x) (nil . t)
                  (evl!* !=y) nil) . get('int,'opmtch));

put('evl!*,'opmtch,'(((!=x) (nil . t) !=x nil)));

put('evl!*,'simpfn,'simpiden);


% Various functions used throughout the integrator.

symbolic procedure flatten u;
   if null u then nil
    else if atom u then list u
    else if atom car u then car u . flatten cdr u
    else nconc(flatten car u,flatten cdr u);

symbolic procedure int!-gensym1 u;
   <>;

symbolic procedure mknill n; if n=0 then nil else nil . mknill(n-1);

symbolic procedure printc u; prin2t u;   % This could be an smacro.


% Selector written as an smacro.

smacro procedure argof u;
   % Argument of a unary function.
   cadr u;

put('nthroot,'simpfn,'simpiden);
% The binary n-th root operator nthroot(x,2)=sqrt(x)
% no simplification is used here.
% Hope is that pbuild introduces it, and simplog removes it.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/trialdiv.red0000644000175000017500000000773611526203062023625 0ustar  giovannigiovannimodule trialdiv;  % Trial division routines.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trint intvar loglist tanlist);

exports countz,findsqrts,findtrialdivs,trialdiv,simp,mksp;

imports !*multf,printsf,quotf;

symbolic procedure countz dl;
% DL is a list of S.F.s;
    begin         scalar s,n,rl;
loop2:  if null dl then return arrangelistz rl;
        n:=1;
loop1:  n:=n+1;
        s:=car dl;
        dl:=cdr dl;
        if not null dl and (s eq car dl) then
            go to loop1
        else rl:=(s.n).rl;
        go to loop2
    end;

symbolic procedure arrangelistz d;
    begin         scalar n,s,rl,r;
        n:=1;
        if null d then return rl;
loopd:  if (cdar d)=n then s:=(caar d).s
        else r:=(car d).r;
        d:=cdr d;
        if not null d then go to loopd;
        d:=r;
        rl:=s.rl;
        s:=nil;
        r:=nil;
        n:=n+1;
        if not null d then go to loopd;
        return reversip rl
    end;

symbolic procedure findtrialdivs zl;
   % zl is list of kernels found in integrand. result is a list
   % giving things to be treated specially in the integration
   % namely, exps and tans.
   % Result is list of form ((a . b) ...)
   % with a a kernel and car a=expt or tan
   % and b a standard form for either expt or (1+tan**2).
   begin scalar dlists1,args1;
      for each z in zl do
         if exportan z
           then <>
                   else args1 := !*kk2f z;  % z is not unique here.
                  dlists1 := (z . args1) . dlists1>>;
      return dlists1
   end;

symbolic procedure exportan dl;
    if atom dl then nil
     else begin
    % extract exp or tan fns from the z-list.
        if eq(car dl,'tan) then return t;
   nxt: if not eq(car dl,'expt) then return nil;
        dl:=cadr dl;
%       if atom dl then return t;
%       if atom dl or constant_exprp dl then return t;
        if atom dl or not smember(intvar,dl) then return t;
% Make sure we find nested exponentials?
        go to nxt
    end;

symbolic procedure findsqrts z;
    begin  scalar r;
        while not null z do <<
            if eqcar(car z,'sqrt) then r:=(car z) . r;
            z:=cdr z >>;
        return r
    end;

symbolic procedure trialdiv(x,dl);
    begin         scalar qlist,q;
    while not null dl do
        if not null(q:=quotf(x,cdar dl)) then <<
            if (caaar dl='tan) and not eqcar(qlist,cdar dl) then
                loglist:=('iden . simp cadr caar dl) . loglist;
                         %tan fiddle!
            qlist:=(cdar dl).qlist;
            x:=q >>
        else dl:=cdr dl;
    return qlist.x
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/makevars.red0000644000175000017500000001167411526203062023614 0ustar  giovannigiovannimodule makevars; % Make dummy variables for integration process.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*gensymlist!* !*purerisch);

% exports getvariables,varsinlist,varsinsf,findzvars,  % varsinsq
%         createindices,mergein;

% imports dependsp,union;

% Note that 'i' is already maybe committed for sqrt(-1),
% also 'l' and 'o' are not used as they print badly on certain
% terminals etc and may lead to confusion.

!*gensymlist!* := '(! j ! k ! m ! n ! p ! q ! r ! s ! t ! u ! v ! w ! x
                    ! y ! z);

%mapc(!*gensymlist!*,function remob); %REMOB protection;


symbolic procedure varsinlist(l,vl);
% L is a list of s.q. - find all variables mentioned,
% given thal vl is a list already known about.
    begin       while not null l do <<
            vl:=varsinsf(numr car l,varsinsf(denr car l,vl));
            l:=cdr l >>;
        return vl
    end;

symbolic procedure getvariables sq;
    varsinsf(numr sq,varsinsf(denr sq,nil));

symbolic procedure varsinsf(form,l);
   if domainp form then l
   else begin
     while not domainp form do <<
        l:=varsinsf(lc form,union(l,list mvar form));
        form:=red form >>;
     return l
   end;

symbolic procedure findzvars(vl,zl,var,flg);
    begin scalar v;
   % VL is the crude list of variables found in the original integrand.
   % ZL must have merged into it all EXP, LOG etc terms from this.
   % If FLG is true then ignore DF as a function.
scan: if null vl then return zl;
         v:=car vl; % next variable.
         vl:=cdr vl;
   % At present items get put onto ZL if they are non-atomic
   % and they depend on the main variable. The arguments of
   % functions are decomposed by recursive calls to findzvar.
   % Give up if V has been declared dependent on other things.
        if atom v and v neq var and depends(v,var) then
%          rerror(int,7,
%                 "Can't integrate in the presence of side-relations")
          zl := union(list v, zl)
         else if not atom v and not(v member zl) and dependsp(v,var)
         then if car v='!*sq then zl:=findzvarssq(cadr v,zl,var)
         else if car v memq '(times quotient plus minus difference)
                 or (((car v) eq 'expt) and fixp caddr v)
             then
                 zl:=findzvars(cdr v,zl,var,flg)
         else if flg and car v eq 'df
          then <> % try and stop it
             else zl:=v . findzvars(cdr v,zl,var,flg);
                 % scan arguments of fn.
             %ACH: old code used to look only at CADR if a DF involved.
        go to scan
   end;

symbolic procedure findzvarssq(sq,zl,var);
    findzvarsf(numr sq,findzvarsf(denr sq,zl,var),var);

symbolic procedure findzvarsf(sf,zl,var);
    if domainp sf then zl
    else findzvarsf(lc sf,
                    findzvarsf(red sf,
                               findzvars(list mvar sf,zl,var,nil),
                               var),
                  var);

symbolic procedure createindices zl;
% Produces a list of unique indices, each associated with a ;
% different Z-variable;
     reversip crindex1(zl,!*gensymlist!*);

symbolic procedure crindex1(zl,gl);
 begin if null zl then return nil;
    if null gl then << gl:=list int!-gensym1 'i; %new symbol needed;
        nconc(!*gensymlist!*,gl) >>;
    return (car gl) . crindex1(cdr zl,cdr gl) end;

symbolic procedure cdrmember(a,b);
    if null b then nil
    else if a=cdar b then car b
    else cdrmember(a,cdr b);

symbolic procedure mergein(dl,ll);
    % Adjoin logs of things in dl to existing list ll.
    if null dl then ll
    else if cdrmember(car dl,ll) then mergein(cdr dl,ll)
    else mergein(cdr dl,('log . car dl) . ll);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/ratint.red0000644000175000017500000000454211526203062023300 0ustar  giovannigiovanniMODULE ratint;   % Support for direct rational integration.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


SYMBOLIC PROCEDURE RATIONALINTEGRATE(X,VAR);
    BEGIN     SCALAR N,D;
      N:=NUMR X; D:=DENR X;
      IF NOT(VAR MEMBER VARSINSF(D,NIL)) THEN
            RETURN !*MULTSQ(POLYNOMIALINTEGRATE(N,VAR),1 ./ D);
      REDERR "Rational integration not coded yet"
    END;

SYMBOLIC PROCEDURE POLYNOMIALINTEGRATE(X,V);
% Integrate standard form. result is standard quotient.
    IF NULL X THEN NIL ./ 1
    ELSE IF ATOM X THEN ((MKSP(V,1) .* 1) .+ NIL) ./ 1
    ELSE BEGIN    SCALAR R;
      R:=POLYNOMIALINTEGRATE(RED X,V); % deal with reductum
      IF V=MVAR X THEN BEGIN    SCALAR DEGREE,NEWLT;
         DEGREE:=1+TDEG LT X;
         NEWLT:=((MKSP(V,DEGREE) .* LC X) .+ NIL) ./ 1; % up exponent
         R:=ADDSQ(!*MULTSQ(NEWLT,1 ./ DEGREE),R)
         END
      ELSE BEGIN        SCALAR NEWTERM;
        NEWTERM:=(((LPOW X) .* 1) .+ NIL) ./ 1;
        NEWTERM:=!*MULTSQ(NEWTERM,POLYNOMIALINTEGRATE(LC X,V));
        R:=ADDSQ(R,NEWTERM)
        END;
      RETURN R
    END;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/df2q.red0000644000175000017500000001111511526203062022625 0ustar  giovannigiovannimodule df2q;   % Conversion from distributive to standard forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(indexlist zlist);

exports df2q;

imports addf,gcdf,mksp,!*multf,quotf;

Comment We assume that results already have reduced powers, so
        that no power substitution is necessary;

symbolic procedure df2q p;
   % Converts distributed form P to standard quotient.
   begin scalar n,d,w,x,y,z;
      if null p then return nil ./ 1;
      d:=denr lc p;
      w:=red p;
      while w do
       <<% Get denominator of answer as lcm of denoms in input.
         d := multf(d,quotf(denr lc w,gcdf(d,denr lc w)));
         w := red w>>;
      while p do begin
           w := sqrt2top lc p;
           x := multf(xl2f(lpow p,zlist,indexlist),multf(numr w,d));
           if null x then return (p := red p);  % Shouldn't occur.
           y := denr w;
           z := quotf(x,y);
           if null z
             then <>;
                    z := numr z>>;
           n := addf(n,z);
           p := red p
        end;
      return tidy!-powersq (n ./ d)
   end;

symbolic procedure tidy!-powersq x;
   % This tries to clean up by turning eg (a^(1/3))^3 into a.
   begin scalar expts,!*precise,!*keepsqrts;
      % I rebind *precise to nil so that things like sqrt(a)^2 simplify
      % to a rather than abs(a).
    !*keepsqrts := t;
    x := subs2q x;
    expts := find!-expts(numr x,find!-expts(denr x,nil));
    if null expts then return x; % Nothing to worry about here!
    x := subsq(x,for each v in expts collect
                    (car v . list('expt,cadr v,cddr v)));
    x := subsq(x,for each v in expts collect
                    (cadr v
                        . list('expt,car v,list('quotient,1,cddr v))));
    return x
  end;

symbolic procedure find!-expts(ff,l);
   begin scalar w;
      if domainp ff then return l;
      l := find!-expts(lc ff,find!-expts(red ff, l));
      ff := mvar ff;
      if eqcar(ff,'sqrt)
        then ff := list('expt, cadr ff,'(quotient 1 2))
       else if eqcar(ff,'expt) and eqcar(caddr ff,'quotient)
          and numberp caddr caddr ff
        then <>;
               rplacd(cdr w,lcm(cddr w,caddr caddr ff))>>;
      return l
   end;

symbolic procedure xl2f(l,z,il);
% L is an exponent list from a D.F., Z is the Z-list,
% IL is the list of indices.
% Value is L converted to standard form. ;
    if null z then 1
        else if car l=0 then xl2f(cdr l,cdr z,cdr il)
        else if not atom car l then
            begin       scalar temp;
                if caar l=0 then temp:= car il
                else temp:=list('plus,car il,caar l);
                temp:=mksp(list('expt,car z,temp),1);
                return !*multf(((temp .* 1) .+ nil),
                               xl2f(cdr l,cdr z,cdr il))
            end
%       else if minusp car l then                                     ;
%            multsq(invsq (((mksp(car z,-car l) .* 1) .+ nil)),       ;
%                  xl2f(cdr l,cdr z,cdr il))                          ;
        else !*multf((mksp(car z,car l) .* 1) .+ nil,
                    xl2f(cdr l,cdr z,cdr il));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/distrib.red0000644000175000017500000002237211526203062023440 0ustar  giovannigiovannimodule distrib;  % Routines for manipulating distributed forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(indexlist sqrtlist zlist);

exports dfprintform,multbyarbpowers,negdf,quotdfconst,sub1ind, % var2df,
   vp1,vp2,plusdf,multdf,multdfconst,orddf;

imports interr,addsq,negsq,exptsq,simp,domainp,mk!*sq,addf,
   multsq,invsq,minusp,mksp,sub1;

%***********************************************************************
% NOTE:     The expressions lt,red,lc,lpow have been used on distributed
%           forms as the latter's structure is sufficiently similar to
%           s.f.'s.  However lc df is a s.q. not a s.f. and lpow df is a
%           list of the exponents of the variables.  This also makes
%           lt df different.  Red df is d.f. as expected.
%***********************************************************************

symbolic procedure plusdf(u,v);
% U and V are D.F.'s. Value is D.F. for U+V.
    if null u then v
        else if null v then u
        else if lpow u=lpow v then
            (lambda(x,y); if null numr x then y else (lpow u .* x) .+ y)
            (!*addsq(lc u,lc v),plusdf(red u,red v))
        else if orddf(lpow u,lpow v) then lt u .+ plusdf(red u,v)
        else (lt v) .+ plusdf(u,red v);

symbolic procedure orddf(u,v);
% U and V are the LPOW of a D.F. - i.e. the list of exponents.
% Value is true if LPOW U '>' LPOW V and false otherwise.
    if null u then if null v then interr "Orddf = case"
        else interr "Orddf v longer than u"
        else if null v then interr "Orddf u longer than v"
        else if exptcompare(car u,car v) then t
        else if exptcompare(car v,car u) then nil
        else orddf(cdr u,cdr v);

symbolic procedure exptcompare(x,y);
    if atom x then if atom y then x>y else nil
        else if atom y then t
        else car x > car y;

symbolic procedure negdf u;
    if null u then nil
        else (lpow u .* negsq lc u) .+ negdf red u;

symbolic procedure multdf(u,v);
% U and V are D.F.'s. Value is D.F. for U*V.
% Reduces squares of square-roots as it goes.
    if null u or null v then nil
    else begin scalar y;
        % use (a+b)*(c+d) = (a*c) + a*(c+d) + b*(c+d).
        y:=multerm(lt u,lt v); %leading terms;
        y:=plusdf(y,multdf(red u,v));
        y:=plusdf(y,multdf((lt u) .+ nil,red v));
        return y
    end;

symbolic procedure multerm(u,v);
% Multiply two terms to give a D.F.
    begin scalar coef;
       coef:=!*multsq(cdr u,cdr v); % coefficient part.
       return multdfconst(coef,mulpower(car u,car v))
    end;

symbolic procedure mulpower(u,v);
% U and v are exponent lists. multiply corresponding forms.
    begin scalar r,s;
       r:=addexptsdf(u,v);
       if not null sqrtlist then s:=reduceroots(r,zlist);
       r:=(r .* (1 ./ 1)) .+ nil;
       if not (s=nil) then r:=multdf(r,s);
       return r
    end;

symbolic procedure reduceroots(r,zl);
    begin scalar s;
       while not null r do <<
          if eqcar(car zl,'sqrt) then
              s:=tryreduction(r,car zl,s);
          r:=cdr r; zl:=cdr zl >>;
       return s
    end;

symbolic procedure tryreduction(r,var,s);
   begin scalar x;
      x:=car r; % current exponent.
      if not atom x then << r:=x; x:=car r >>; % numeric part.
      if (x=0) or (x=1) then return s; % no reduction possible.
      x:=divide(x,2);
      rplaca(r,cdr x); % reduce exponent as redorded.
      x:=car x;
      var:=simp cadr var; % sqrt arg as a s q.
      var:=!*exptsq(var,x);
      x:=multdfconst(1 ./ denr var,f2df numr var); % distribute.
      if s=nil then s:=x
      else s:=multdf(s,x);
      return s
   end;



symbolic procedure addexptsdf(x,y);
% X and Y are LPOW's of D.F. Value is list of sum of exponents.
    if null x then if null y then nil else interr "X too long"
        else if null y then interr "Y too long"
        else exptplus(car x,car y).addexptsdf(cdr x,cdr y);

symbolic procedure exptplus(x,y);
    if atom x then if atom y then x+y else list (x+car y)
        else if atom y then list (car x +y)
        else interr "Bad exponent sum";

symbolic procedure multdfconst(x,u);
   % X is S.Q. not involving Z variables of DF U. Value is DF for X*U.
   if null u or null numr x then nil
      % else lpow u .* !*multsq(x,lc u) .+ multdfconst(x,red u);
      % FJW: Does not handle i^2 correctly, so ...
      % (cf. solve!-for!-u in module isolve)
    else lpow u .* subs2q multsq(x,lc u) .+ multdfconst(x,red u);

%symbolic procedure quotdfconst(x,u);
%    multdfconst(!*invsq x,u);

symbolic procedure f2df p;
% P is standard form. Value is P in D.F.
    if domainp p then dfconst(p ./ 1)
        else if mvar p member zlist then
             plusdf(multdf(vp2df(mvar p,tdeg lt p,zlist),f2df lc p),
                    f2df red p)
        else plusdf(multdfconst(((lpow p .* 1) .+ nil) ./ 1,f2df lc p),
                    f2df red p);

% SYMBOLIC PROCEDURE VAR2DF(VAR,N,ZLIST);
%    ((VP1(VAR,N,ZLIST) .* (1 ./ 1)) .+ NIL);

symbolic procedure vp1(var,degg,z);
% Takes VAR and finds it in Z (=list), raises it to power DEGG and puts
% the result in exponent list form for use in a distributed form.
    if null z then interr "Var not in z-list after all"
        else if var=car z then degg.vp2 cdr z
        else 0 . vp1(var,degg,cdr z);

symbolic procedure vp2 z;
% Makes exponent list of zeroes.
    if null z then nil
        else 0 . vp2 cdr z;

symbolic procedure vp2df(var,exprn,z);
% Makes VAR**EXPRN into exponent list and then converts the resulting
% power into a distributed form.  Special care needed with square-roots.
    if eqcar(var,'sqrt) and (exprn>1) then
        mulpower(vp1(var,exprn,z),vp2 z)
    else (vp1(var,exprn,z) .* (1 ./ 1)) .+ nil;

symbolic procedure dfconst q;
% Makes a distributed form from standard quotient constant Q.
    if numr q=nil then nil
        else ((vp2 zlist) .* q) .+ nil;

% Df2q moved to a section of its own.

symbolic procedure df2printform p;
% Convert to a standard form good enough for printing.
    if null p then nil
    else begin
        scalar mv,co;
        mv:=xl2q(lpow p,zlist,indexlist);
        if mv=(1 ./ 1) then <<
            co:=lc p;
            if denr co=1 then return addf(numr co,
                df2printform red p);
            co:=mksp(mk!*sq co,1);
            return (co .* 1) .+ df2printform red p >>;
        co:=lc p;
        if not (denr co=1) then mv:=!*multsq(mv,1 ./ denr co);
        mv:=mksp(mk!*sq mv,1) .* numr co;
        return mv .+ df2printform red p
    end;


symbolic procedure xl2q(l,z,il);
% L is an exponent list from a D.F.,Z is the Z-list, IL is the list of
% indices.  Value is L converted to standard quotient.
    if null z then 1 ./ 1
        else if car l=0 then xl2q(cdr l,cdr z,cdr il)
        else if not atom car l then
            begin    scalar temp;
                if caar l=0 then temp:= car il
                else temp:=list('plus,car il,caar l);
                temp:=mksp(list('expt,car z,temp),1);
                return !*multsq(((temp .* 1) .+ nil) ./ 1,
                               xl2q(cdr l,cdr z,cdr il))
            end
        else if minusp car l then
             !*multsq(!*invsq(((mksp(car z,-car l) .* 1) .+ nil) ./ 1),
                         xl2q(cdr l,cdr z,cdr il))
        else !*multsq(((mksp(car z,car l) .* 1) .+ nil) ./ 1,
                    xl2q(cdr l,cdr z,cdr il));


%symbolic procedure sub1ind power;
%     if atom power then power-1 else list sub1 car power;

symbolic procedure multbyarbpowers u;
% Multiplies the ordinary D.F., U, by arbitrary powers
% of the z-variables,
%       i-1  j-1  k-1
% i.e. x    z    z    ... so result is D.F. with the exponent list
%            1    2
%appropriately altered to contain list elements instead of numeric ones.
   if null u then nil
   else ((addarbexptsdf lpow u) .* lc u) .+ multbyarbpowers red u;

symbolic procedure addarbexptsdf x;
% Adds the arbitrary powers to powers in exponent list, X, to produce
% new exponent list.  e.g. 3 -> (2) to represent x**3 now becoming :
%          3    i-1    i+2
%         x  * x    = x      .
   if null x then nil
    else list exptplus(car x,-1) . addarbexptsdf cdr x;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/symint.red0000644000175000017500000003540611526203062023325 0ustar  giovannigiovannimodule symint;  % Improved simplification of symbolic integrals

% Author: Francis J. Wright

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% An extension of simpint1 in module driver (by Mary Ann Moore, Arthur
% C. Norman and John P. Fitch) to provide better simplification of
% integrals of symbolic derivatives and integrals.  (Originally
% motivated by the needs of the CRACK package.)

% Change Log:

%  7/1/98: Partial integration for integrals of integrals
% 10/1/98: Extended partial integration for integrals of integrals
% 11/1/98: Commutation of integrals
% 21/2/98: df(y,x,2) etc. handling corrected

fluid '(!*failhard !*IntDfFound);

switch CommuteInt;                      % off by default (for now)
deflist('((CommuteInt ((t (rmsubs))))), 'simpfg);

% If the switch CommuteInt is turned on then the top-level integration
% in a symbolic integral is commuted into the integrand to try to
% simplify it, and if that fails and the result is a symbolic multiple
% integral then it is left in canonical nesting order (as is already
% done automatically for multiple derivatives).  However, an
% integrable nested derivative is integrated regardless of this
% switch.

switch PartialInt, PartialIntDf, PartialIntInt; % off by default
deflist('((PartialInt ((t   (on  '(PartialIntDf PartialIntInt)))
                       (nil (off '(PartialIntDf PartialIntInt)))))
          (PartialIntDf ((t (rmsubs))))
          (PartialIntInt ((t (rmsubs))))), 'simpfg);

% If the switch PartialIntDf is turned on then integration by parts is
% performed if the result simplifies in the sense that it integrates a
% symbolic derivative and does not introduce new symbolic derivatives.
% However, because the initial integral contains an unevaluated
% derivative then the result must still contain an unevaluated
% integral.

% If the switch PartialIntInt is turned on then integration by parts
% is performed if the result simplifies in the sense that it removes a
% symbolic integral from the integrand and does not introduce new
% symbolic integrals.  However, because the initial integral contains
% an unevaluated integral then the result must still contain an
% unevaluated integral.

% The switch PartialInt is just a convenience to turn both the above
% switches on or off together.

switch XPartialInt, XPartialIntDf, XPartialIntInt; % off by default
deflist('((XPartialInt ((t   (on  '(XPartialIntDf XPartialIntInt)))
                       (nil (off '(XPartialIntDf XPartialIntInt)))))
          (XPartialIntDf ((t (rmsubs))))
          (XPartialIntInt ((t (rmsubs))))), 'simpfg);

% These switches control extended partial integration of integrals of
% the form int( int(u(x,z),z) * v(x), x ), which is experimental,
% somewhat heuristic and may be slow.

symbolic procedure symint u;
   % u has the form (int y x).
   % At this point linearity has been applied.
   begin scalar v, y, x;
      y := cadr u;  x := caddr u;
      % Check for a directly integrable derivative:
      if (v := NestedIntDf(y,x,nil)) then return mksq(v,1);
      if !*failhard then rerror(int,4,"FAILHARD switch set");
      if (!*PartialIntDf or !*PartialIntInt) and
         % Integrate by parts if the result simplifies:
         % DO WE NEED TO CALL SIMPINT1 RECURSIVELY ON THE RESULT?
         (v := PartialInt(y,x)) then return mksq(v,1);
      if (!*XPartialIntDf or !*XPartialIntInt) and
         % EXPERIMENTAL!  Try extended partial integration:
         (v := XPartialInt(y,x)) then return mksq(v,1);
      return mksq(u,1)
   end;

%% symbolic procedure NestedIntDf(y, x);
%%    %% int( ... df(f,A,x,B) ..., x) -> ... df(f,A,B) ...
%%    %% Find a df(f,A,x,B) among possibly nested int's and df's within
%%    %% the integrand y in int(y,x), and return the whole structure y
%%    %% but with the derivative integrated; otherwise return nil.
%%    %% [A,B are arbitrary sequences of kernels.]
%%    not atom y and
%%    begin scalar car_y, nested;
%%       return
%%          if (car_y := car y) eq 'df and memq(x, cddr y) then
%%             %% int( df(f, A, x, B), x ) -> df(f, A, B)
%%             'df . cadr y . delete(x, cddr y)
%%                %% use delete for portability!
%%                %% deleq is defined in CSL, delq in PSL -- oops!
%%          else if memq(car_y, '(df int)) and
%%             (nested := NestedIntDf(cadr y, x)) then
%%             %% int( df(int(df(f, A, x, B), c), C), x ) ->
%%             %%      df(int(df(f, A, B), c), C)
%%             %% int( int(df(f, A, x, B), c), x ) ->
%%             %%      int(df(f, A, B), c)
%%             car_y . nested . cddr y
%%    end;

symbolic procedure NestedIntDf(y, x, !*recursive);
   %% In order to simplify a symbolic integral int(y,x), commute the
   %% integral through integrals and derivatives in the integrand to
   %% try to find an integrable integrand.  Return the result if
   %% successful; otherwise return nil.  [A,B are arbitrary sequences
   %% of kernels or "kernels followed by integers".]  If the integral
   %% does not simplify, optionally commute multiple integrals into
   %% canonical nesting order, as is done in the standard
   %% differentiator code for multiple derivatives.  !*recursive is
   %% nil in the top-level call, t in recursive calls.  [NB: The
   %% top-level call of this procedure makes redundant the let rule in
   %% the standard integrator code to integrate derivatives.]
   not atom y and
   begin scalar fn, nested;
      return
         if (fn := car y) eq 'df then   % integrating a derivative
            if (nested := IntDf(y, x)) then nested
               %% int( ... df(f, A, x, B) ... , x ) -> df(f, A, B)
            else if (nested := NestedIntDf(cadr y, x, t)) then
               %% recursing into the integrand
               fn . nested . cddr y
            else nil
         else if !*failhard then nil    % give up!
         else if fn eq 'int then        % integrating an integral
            if eq(x, caddr y) then
               %% int( ... int(f, x) ... , x ) -> stop
               nil
            else if (nested := NestedIntDf(cadr y, x, t)) then
               %% recursing into the integrand
               fn . nested . cddr y
            else if !*CommuteInt and ordp(x, caddr y) then
               %% Commute integrals into canonical nesting order:
               %% int( ... int(f, b) ... , a ) ->
               %%    int( ... int(f, a) ... , b )
               %% Successive calls of the integrator by the simplifier
               %% to integrate nested integrals causes this code to
               %% sort the integrands into canonical order.
               {'int, {'int, cadr y, x}, caddr y}
            else nil
         else if !*recursive and !*CommuteInt and
            %% y is not an integral or a derivative -- try to
            %% integrate it unless at top level:
            not eqcar(nested := reval {'int,y,x}, 'int) then nested
   end;

symbolic procedure IntDf(y, x);
   % y = df(f, u, nu, v, nv, ...) where nu, nv, ... optional
   % if x = u, v, ... then return int(y, x)
   begin scalar !*IntDfFound;
      x := IntDfVars(cddr y, x);
      if !*IntDfFound then return
         if x then 'df . cadr y . x else cadr y
   end;

symbolic procedure IntDfVars(y, x);
   if y then
      if car y eq x then
      begin scalar n;
         !*IntDfFound := t;
         return
            if (y := cdr y) and fixp(n := car y) then <<
               y := cdr y;
               if n > 2 then y := (n-1) . y;
               x . y
            >> else y
      end
      else car y . IntDfVars(cdr y, x);


symbolic procedure PartialInt(y, x);
   %% Integrate by parts if the resulting integral simplifies;
   %% otherwise return nil.  Split integrand into a derivative or
   %% integral and a second factor and call the appropriate procedure.
   %% Try all possible allowed partial integrations in turn.
   not atom y and
   begin scalar denlist, faclist, facs, df_or_int, result;
      % Process any quotient:
      if car y eq 'quotient then <<
         denlist := cddr y;
         % y := numerator:
         if atom(y := cadr y) then return % no derivative or integral
      >>;
      % y := list of factors:
      if car y eq 'times then y := cdr y
      else if denlist or !*PartialIntInt then y := y . nil
         % Can do double integral int(int(u(x),x),x) as a special case
      else return;
      faclist := y;
      % Loop through all integrable derivatives or differentiable
      % integrals among the factors:
   continue:
      while faclist and ( atom(df_or_int := car faclist) or
         not (memq(car df_or_int, '(df int)) and
            memq(x, cddr df_or_int)) ) do
               faclist := cdr faclist;
      % Finally, break the loop if there is no integrable derivative
      % or differentiable integral:
      if null faclist then return;
      facs := delete(df_or_int, y);     % list of factors
      facs := if null facs then 1
         else if cdr facs then 'times . facs else car facs;
      if denlist then facs := 'quotient . facs . denlist;
      if car df_or_int eq 'df then
         (if !*PartialIntDf and
            (result := PartialIntDf(facs, df_or_int, x))
         then return result)
      else
         (if !*PartialIntInt and
            (result := PartialIntInt(df_or_int, facs, x))
         then return result);
      % Continue the loop through the factors in faclist:
      faclist := cdr faclist;
      goto continue
   end;

symbolic procedure PartialIntDf(u, df_v, x);
   %% int(u(x)*df(v(x),x), x) -> u(x)*v(x) - int(df(u(x),x)*v(x), x)
   %% Integrate by parts if the resulting integral simplifies [to
   %% avoid infinite loops], which means that df(u(x),x) may not
   %% contain any unevaluated derivatives; otherwise return nil.
   begin scalar v;
      v := IntDf(df_v, x);
      % Check that df(u(x),x) simplifies:
      if smemq('df, df_v := reval {'df,u,x}) then return;
      return reval {'difference,
         {'times,u,v}, {'int, {'times, df_v, v}, x}}
   end;

symbolic procedure PartialIntInt(int_u, v, x);
   %% int(int(u(x),x) * v(x), x) ->
   %%    int(u(x),x) * int(v(x),x) - int( u(x) * int(v(x),x), x )
   %% Integrate by parts if the resulting integral simplifies [to
   %% avoid infinite loops], which means that int(v(x),x) may not
   %% remain an unevaluated integral; otherwise return nil.
   begin scalar u;
      u := cadr int_u;                  % kernel being integrated
      % Check that int(v(x),x) simplifies:
      if eqcar(v := reval {'int,v,x}, 'int) then return;
      return reval {'difference,
         {'times,int_u,v}, {'int, {'times,u,v}, x}}
   end;


symbolic procedure XPartialInt(y, x);
   %% Extended partial integration.  This code is somewhat heuristic
   %% and may be slow.  The problem is to try to simplify
   %%    int( int(u(x,z),z) * v(x), x ).
   %% Integrate by parts if the resulting integral simplifies;
   %% otherwise return nil.  Split integrand into an integral NOT wrt
   %% x and a second factor and call the appropriate procedure.  Try
   %% all possible allowed partial integrations in turn.
   not atom y and
   begin scalar denlist, faclist, facs, int, result;
      % Process any quotient:
      if car y eq 'quotient then <<
         denlist := cddr y;
         % y := numerator:
         if atom(y := cadr y) then return % no derivative or integral
      >>;
      % y := list of factors:
      if car y eq 'times then y := cdr y
      else if denlist then y := y . nil
      else return;
      faclist := y;
      % Loop through all integrals among the factors:
   continue:
      while faclist and ( not eqcar(int := car faclist, 'int) or
         eq(x, caddr int) ) do
            faclist := cdr faclist;
      % Finally, break the loop if there is no appropriate integral:
      if null faclist then return;
      facs := delete(int, y);           % list of factors
      facs := if null facs then 1
         else if cdr facs then 'times . facs else car facs;
      if denlist then facs := 'quotient . facs . denlist;
      if facs = 1 then return;          % ?????
      if (result :=
         (!*XPartialIntDf and XPartialIntDf(int, facs, x)) or
            (!*XPartialIntInt and XPartialIntInt(int, facs, x)))
      then return result;
      % Continue the loop through the factors in faclist:
      faclist := cdr faclist;
      goto continue
   end;

symbolic procedure XPartialIntDf(int_u, v, x);
   %% int(int(u(x,z),z)*v(x), x) ->
   %%    int(int(u(x,z),x),z) * v(x) -
   %%       int( int(int(u(x,z),x),z) * df(v(x),x), x )
   %% provided df(v(x),z) and int(u(x,z),x) simplify.
   begin scalar df_v, z;
      % Check that df(v(x),x) simplifies:
      if smemq('df, df_v := reval {'df, v, x}) then return;
      z := caddr int_u;
      int_u := reval {'int, cadr int_u, x}; % int(u(x,z),x)
      % Check that int(u(x,z),x) simplifies:
      if eqcar(int_u, 'int) then return;
      int_u := reval {'int, int_u, z};  % int(int(u(x,z),x),z)
      return reval {'difference,
         {'times,int_u,v}, {'int, {'times, int_u, df_v}, x}}
   end;

symbolic procedure XPartialIntInt(int_u, v, x);
   %% int(int(u(x,z),z) * v(x), x) ->
   %%    int(u(x,z),z) * int(v(x),x) -
   %%       int( int(df(u(x,z),x),z) * int(v(x),x), x )
   %% provided int(v(x),x) and int(df(u(x,z),x),z) simplify.
   %% If x = z then this reduces to PartialIntInt.
   begin scalar u;
      u := cadr int_u;                  % kernel being integrated
      % Check that int(v(x),x) simplifies:
      if eqcar(v := reval {'int, v, x}, 'int) then return;
      % Check that df(u(x),x) simplifies:
      if smemq('df, u := reval {'df, u, x}) then return;
      % Check that int(df(u(x,z),x),z) simplifies:
      if eqcar(u := reval {'int, u, caddr int_u}, 'int) then return;
      return reval {'difference,
         {'times,int_u,v}, {'int, {'times,u,v}, x}}
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/intfac.red0000644000175000017500000001271511526203062023244 0ustar  giovannigiovannimodule intfac;   % Interface between integrator and factorizer.

% Author:  Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Based on earlier versions by James Davenport, Mary Ann Moore and
% Arthur Norman.

fluid '(!*intfac !*surds kord!* zlist);  % clogflag

exports int!-fac;

symbolic procedure int!-fac x;
   % X is a primitive, square-free polynomial, except for monomial
   % factors.  Result is a list of 'factors' wrt zlist.
   % Throughout most of the integrator we want to add new surds, so we
   % turn surds on.  However, we use *intfac to inhibit use of quadratic
   % factorizer in the poly/primfac module, since things don't work
   % properly if this is used.
   begin scalar !*intfac,!*surds;
      !*intfac := !*surds := t;
      return int!-fac!-inner x;
   end;

symbolic procedure int!-fac!-inner x;
   % X is a primitive, square-free polynomial, except for monomial
   % factors.  Result is a list of  'factors' wrt zlist.
   begin scalar factors;
      factors := fctrf x;
      factors := cdr factors; % Ignore monomial factor.
      % Make sure x really square-free.
      factors := for each u in factors
                    collect if cdr u=1 then car u
                             else interr list(x,"not square free");
      % It seems we need the logs ordered ahead of atans, hence reverse.
      return reversip for each u in factors join fac2int u
   end;

symbolic procedure fac2int u;
   % Returns a list of all the arctangents and logarithms arising from
   % an attempt to take the one irreducible (but not necessarily the
   % absolutely irreducible) factor u.
   begin scalar degrees,x;
      degrees := for each w in zlist collect (degreef(u,w) . w);
      if assoc(1,degrees) then return list ('log . (u ./ 1))
      % An irreducible polynomial of degree 1 is absolutely irreducible.
       else if x := assoc(2,degrees) then return int!-quadterm(u,cdr x)
       else if assoc(0,degrees) then return list('log . (u ./ 1));
      % This suggests a surd occurs. Should that be an error?
      if !*trint
        then <>;
      return list ('log . (u ./ 1))
   end;

symbolic procedure int!-quadterm(pol,var);
   % Add in logs and atans corresponding to splitting the polynomial pol
   % given it is quadratic wrt var.  Does not assume pol is univariate.
   % We need to rootxf!* so that
   % int(1/(x**2*y0+x**2+x*y0**2+3*x*y0+x+y0**2+y0),x) comes out in
   % terms of real functions.
   begin scalar a,b,c,discrim,kord,res,w;
      kord := setkorder(var . kord!*);   % It shouldn't matter if
                                         % var occurs twice.
      c := reorder pol;
      if ldeg c neq 2
        then <>;
      a := lc c;
      c := red c;
      if not domainp c and mvar c = var and ldeg c = 1
        then <>;
      setkorder kord;
      discrim := powsubsf addf(multf(b,b),multd(-4,multf(a,c)));
      if null discrim then interr "discrim is zero in quadterm";
      % A quadratic usually implies an atan term.
%     if not clogflag
%       then <>;
      w := rootxf!*(negf discrim,2);
      if not(w eq 'failed) then go to atancase;
      w := rootxf!*(discrim,2);   % Maybe only rootxf is needed here.
      if w eq 'failed then return list ('log . !*f2q pol);
%     if w eq 'failed then rederr "Integration failure in int-quadterm";
      discrim := w;
      w := multpf(mksp(var,1),a);
      w := addf(multd(2,w),b);   % 2*a*x + b.
      a := addf(w,discrim);
      b := addf(w,negf discrim);
      % Remove monomial multipliers.
      a := quotf(a,cdr comfac a);
      b := quotf(b,cdr comfac b);
      return ('log . !*f2q a) . ('log . !*f2q b) . res;
   atancase:
      res := ('log . !*f2q pol) . res;   % One part of answer.
      a := multpf(mksp(var,1),a);
      a := addf(b,multd(2,a));
      a := fquotf(a,w);
      return ('atan . a) . res
   end;

symbolic procedure rootxf!*(u,n);
   (if x eq 'failed or smemq('i,x) and not smemq('i,u)
      then (rootxf(u,n) where !*surds=nil)
     else x)
    where x=rootxf(u,n);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/halfangl.red0000644000175000017500000002747511526203062023565 0ustar  giovannigiovannimodule halfangl;  % Routines for conversion to half angle tangents.

% Author: Steve Harrington.
% Modifications by: John P. Fitch.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*gcd);

exports halfangle,untan;

symbolic procedure transform(u,x);
   % Transform the SQ U to remove the 'bad' functions sin, cos, cot etc.
   % in favor of half angles.
   % Do this with regard to cases like sin(x)*tan(x/2), so attempt to
   % limit times we use half angles.
   begin scalar zl,tnarg,substlist;
      zl := zlist;
      while car(tnarg := tan!-function!-in zl)
         and halfangle!-confusion(zlist,cadar tnarg)
       do <>;
      return if substlist
               then simp sublis(substlist,prepsq halfangle(u,x))
              % simp prepsq was added so that 1/(e**x*cos(1/e**x)**2)
              % for example returns a closed-form result.
              else simp prepsq halfangle(u,x)
   end;

symbolic procedure tan!-function!-in zz;
   % Look at zlist for tangents or cotangents.
   <>;

symbolic procedure halfangle!-confusion(zz,tnarg);
   % Is there a function in the zlist with twice the tangent argument?
   <>;

symbolic procedure quotqq(u1,v1);
   multsq(u1,invsq(v1));

symbolic procedure !*subtrq(u1,v1);
   addsq(u1, negsq(v1));

symbolic procedure !*int2qm(u1);
   if u1=0 then nil . 1 else u1 . 1;

symbolic procedure halfangle(r,x);
   % Top level procedure for converting;
   % R is a rational expression to be converted,
   % X the integration variable.
   % A rational expression is returned.
   quotqq(hfaglf(numr(r),x), hfaglf(denr(r),x));

symbolic procedure hfaglf(p,x);
   % Converting polynomials,  a rational expression is returned.
   if domainp(p) then !*f2q(p)
    else subs2q addsq(multsq(exptsq(hfaglk(mvar(p),x), ldeg(p)),
                             hfaglf(lc(p),x)),
                      hfaglf(red(p),x));

symbolic procedure hfaglk(k,x);
   % Converting kernels,  a rational expression is returned.
   begin
      scalar kt;
      if atom k or not member(x,flatten(cdr(k))) then return !*k2q k;
      k := car(k) . hfaglargs(cdr(k), x);
      if cadr k eq 'pi then return !*k2q k;  % Don't consider tan(pi/2).
      kt := simp list('tan, list('quotient, cadr(k), 2));
      return if car(k) = 'sin
       then quotqq(multsq(!*int2qm(2),kt), addsq(!*int2qm(1),
                            exptsq(kt,2)))
      else if car(k) = 'cos
       then quotqq(!*subtrq(!*int2qm(1),exptsq(kt,2)),addsq(!*int2qm(1),
         exptsq(kt,2)))
      else if car(k) = 'tan
       then quotqq(multsq(!*int2qm(2),kt), !*subtrq(!*int2qm(1),
                            exptsq(kt,2)))
      else if car(k) = 'cot
       then quotqq(!*subtrq(!*int2qm(1),
                   exptsq(kt,2)),multsq(!*int2qm(2),kt))
      else if car(k) = 'sec
       then quotqq(addsq(!*int2qm(1), exptsq(kt,2)),
                   !*subtrq(!*int2qm(1),exptsq(kt,2)))
      else if car(k) = 'csc
       then quotqq(addsq(!*int2qm(1),exptsq(kt,2)),
%%%                   !*subtrq(!*int2qm(1),exptsq(kt,2)))
                    % FJW - was identical to sec!!!
                   multsq(!*int2qm(2),kt))
      else if car(k) = 'sinh then
        quotqq(!*subtrq(!*p2q mksp('expt.('e. cdr k),2),
        !*int2qm(1)), multsq(!*int2qm(2),
                             !*p2q mksp('expt . ('e . cdr(k)),1)))
      else if car(k) = 'cosh then
        quotqq(addsq(!*p2q mksp('expt.('e. cdr k),2),
        !*int2qm(1)), multsq(!*int2qm(2),
                             !*p2q mksp('expt . ('e . cdr(k)),1)))
      else if car(k) = 'tanh then
        quotqq(!*subtrq(!*p2q mksp('expt.('e. cdr k),2),
        !*int2qm(1)), addsq(!*p2q mksp ('expt.('e.cdr(k)),2),
        !*int2qm(1)))
      else if car(k) = 'coth then
        quotqq(addsq(!*p2q mksp('expt.('e.cdr(k)),2), !*int2qm(1)),
              !*subtrq(!*p2q mksp('expt.('e . cdr k),2),!*int2qm(1)))
      else if car(k) = 'acot then
        !*p2q mksp(list('atan, list('quotient, 1, cadr k)),1)
      else !*k2q(k);  % additional transformation might be added here.
   end;

symbolic procedure hfaglargs(l,x);
   % Conversion of argument list.
   if null l then nil
    else prepsq(hfaglk(car(l),x)) . hfaglargs(cdr(l),x);

symbolic procedure untanf x;
   % This should be done by a table.
   % We turn off gcd to avoid unnecessary gcd calculations, as suggested
   % by Rainer Schoepf.
   begin scalar !*gcd,y,z,w;
      if domainp x then return x . 1;
      y := mvar x;
      if eqcar(y,'int) then error1();  % assume all is hopeless.
      z := ldeg x;
      w := 1 . 1;
      y :=
       if atom y then !*k2q y
        else if car y eq 'tan
         then begin scalar yy;
%%              printc "Recursive tan"; printc cadr y;
                yy := prepsq untan simp cadr y . nil;
%%              princ "==> "; printc yy;
                if evenp z
                then <>
               else if z=1
                then return simp list('quotient,
                                      list('plus,
                                           list('minus,
                                                list('cos,
                                                    'times . (2 . yy))),
                                           1),list('sin,
                                                   'times . (2 . yy)))
               else <>
        end
        else simp y;
      return addsq(multsq(multsq(exptsq(y,z),untanf lc x),w),
                   untanf red x)
   end;

% symbolic procedure untanlist(y);
%    if null y then nil
%      else (prepsq (untan(simp car y)) . untanlist(cdr y));

symbolic procedure untan(x);
   % Expects x to be canonical quotient.
   begin scalar y;
      y:=cossqchk sinsqrdchk multsq(untanf(numr x),
                                    invsq untanf(denr x));
      return if length flatten y>length flatten x then x else y
   end;

symbolic procedure sinsqrdchk(x);
   multsq(sinsqchkf(numr x), invsq sinsqchkf(denr x));

symbolic procedure sinsqchkf(x);
   begin
      scalar y,z,w;
      if domainp x then return x . 1;
      y := mvar x;
      z := ldeg x;
      w := 1 . 1;
      y := if eqcar(y,'sin) then if evenp z
       then <>
      else if z = 1 then !*k2q y
      else  << z := quotient(difference(z,1),2); w := !*k2q y;
             simp list('plus,1,list('minus,
                                    list('expt,('cos . cdr(y)),2)))>>
       else !*k2q y;
      return addsq(multsq(multsq(exptsq(y,z),sinsqchkf(lc x)),w),
                   sinsqchkf(red x));
   end;

symbolic procedure cossqchkf(x);
   begin
      scalar y,z,w,x1,x2;
      if domainp x then return x . 1;
      y := mvar x;
      z := ldeg x;
      w := 1 . 1;
      x1 := cossqchkf(lc x);
      x2 := cossqchkf(red x);
      x := addsq(multsq(!*p2q lpow x,x1),x2);
      y := if eqcar(y,'cos) then if evenp z
       then <>
      else if z = 1 then !*k2q y
      else  << z := quotient(difference(z,1),2); w := !*k2q y;
             simp list('plus,1,list('minus,
                                    list('expt,('sin . cdr(y)),2)))>>
       else !*k2q y;
      y := addsq(multsq(multsq(exptsq(y,z),w),x1),x2);
      return if length(y) > length(x) then x else y;
   end;

symbolic procedure cossqchk(x);
begin scalar !*gcd;
   !*gcd := t;
   return multsq(cossqchkf(numr x), invsq cossqchkf(denr x))
end;

symbolic procedure lrootchk(l,x);
   % Checks each member of list l for a root.
   if null l then nil else krootchk(car l, x) or lrootchk(cdr l, x);

symbolic procedure krootchk(f,x);
   % Checks a kernel to see if it is a root.
   if atom f then nil
    else if car(f) = 'sqrt and member(x, flatten cdr f) then t
   else if car(f) = 'expt
        and not atom caddr(f)
        and caaddr(f) = 'quotient
        and member(x, flatten cadr f)  then t
   else lrootchk(cdr f, x);

symbolic procedure rootchk1p(f,x);
   % Checks polynomial for a root.
   if domainp f then nil
    else krootchk(mvar f,x) or rootchk1p(lc f,x) or rootchk1p(red f,x);

symbolic procedure rootcheckp(f,x);
   % Checks rational (standard quotient) for a root.
   rootchk1p(numr f,x) or rootchk1p(denr f,x);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/dint.red0000644000175000017500000001132711526203062022734 0ustar  giovannigiovannimodule dint;  % Definite integration support.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*precise);

symbolic procedure simpdint u;
   begin scalar low,upp,fn,var,x,y;
      if length u neq 4
        then rerror(int,2,"Improper number of arguments to INT");
      load!-package 'defint;
      fn := car u;
      var := cadr u;
      low := caddr u;
      upp := cadddr u;
      low := reval low;
      upp := reval upp;
      if low = upp then return nil ./ 1
       else if null getd 'new_defint then nil
       else if upp = 'infinity
        then if low = 0
               then if not smemql('(infinity unknown),
                                  x := defint!* {fn,var})
                      then return simp!* x else nil
              else if low = '(minus infinity)
               then return mkinfint(fn,var)
              else if freeof(var,low)
               then if not smemql('(infinity unknown),
                                  x := defint!* {fn,var})
                     and not smemql('(infinity unknown),
                                  y := indefint!* {fn,var,low})
                      then return simp!* {'difference,x,y} else nil
              else nil
       else if upp = '(minus infinity) or low = 'infinity
        then return negsq simpdint {fn,var,upp,low}
       else if low = '(minus infinity)
        then return
           simpdint{prepsq simp{'sub,{'equal,var,{'minus,var}},fn},
                     var,{'minus,upp},'infinity}
       else if low = 0
        then if freeof(var,upp)
                and not smemql('(infinity unknown),
                               x := indefint!* {fn,var,upp})
               then return simp!* x else nil
       else if freeof(var,upp) and freeof(var,low)
                 and not smemq('(infinity unknown),
                               x := indefint!* {fn,var,upp})
                 and not smemql('(infinity unknown),
                               y := indefint!* {fn,var,low})
        then return simp!* {'difference,x,y};
      return mkdint(fn,var,low,upp)
   end;

symbolic procedure defint!* u;
   (if errorp x then 'unknown else car x)
    where x = errorset2 {'new_defint,mkquote u};

symbolic procedure indefint!* u;
   (if errorp x or eqcar(car x,'indefint2) then 'unknown else car x)
    where x = errorset2 {'new_indefint,mkquote u};

symbolic procedure mkdint(fn,var,low,upp);
   % This could be used as an entry point to other dint procedures.
   % Should we handle infinity, - infinity differently?
   begin scalar x,!*precise;
      if getd 'defint0
         and not((x := defint0 {fn,var,low,upp}) eq 'failed)
        then return simp x
       else if not smemq('infinity,low) and not smemq('infinity,upp)
        then <>;
      return mksq({'int,fn,var,low,upp},1)
   end;

symbolic procedure mkinfint(fn,var);
   begin scalar x,y;
      if getd 'defint0
         and not((x := defint0 {fn,var,'(minus infinity),'infinity})
                 eq 'failed) then return simp x;
      x := simpdint {fn,var,0,'infinity};
      y := simpdint {fn,var,'(minus infinity),0};
      if kernp x and eqcar(mvar numr x,'int)
         and kernp y and eqcar(mvar numr y,'int)
        then return mkdint(fn,var,'(minus infinity),'infinity)
       else return addsq(x,y)
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/simpsqrt.red0000644000175000017500000002474211526203062023665 0ustar  giovannigiovannimodule simpsqrt;   % Simplify square roots.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Heavily modified by J.H. Davenport for algebraic functions.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*galois !*pvar !*tra !*trint basic!-listofallsqrts
        gaussiani basic!-listofnewsqrts intvar knowntobeindep
        listofallsqrts listofnewsqrts sqrtflag sqrtlist
        sqrt!-places!-alist varlist zlist);

% This module should be rewritten in terms of the REDUCE function
% SIMPSQRT.

% remd 'simpsqrt;

exports proper!-simpsqrt,simpsqrti,simpsqrtsq,simpsqrt2,sqrtsave,
        newplace,actualsimpsqrt,formsqrt;

symbolic procedure proper!-simpsqrt(exprn);
   simpsqrti carx(exprn,'proper!-simpsqrt);


symbolic procedure simpsqrti sq;
begin
   scalar u;
   if atom sq
     then if numberp sq
       then return (simpsqrt2 sq) ./ 1
       else if (u:=get(sq,'avalue))
         then return simpsqrti cadr u
           % BEWARE!!! This is VERY system dependent.
         else return simpsqrt2((mksp(sq,1) .* 1) .+ nil) ./ 1;
           % If it doesn't have an AVALUE then it is itself.
   if car sq eq 'times
     then return mapply(function multsq,
                        for each j in cdr sq collect simpsqrti j);
   if car sq eq 'quotient
     then return multsq(simpsqrti cadr sq,
                        invsq simpsqrti caddr sq);
   if car sq eq 'expt and numberp caddr sq
     then if evenp caddr sq
       then return simpexpt list(cadr sq,caddr sq / 2)
       else return simpexpt
                     list(mk!*sq simpsqrti cadr sq,caddr sq);
  if car sq = '!*sq
    then return simpsqrtsq cadr sq;
  return simpsqrtsq tidysqrt simp!* sq
  end;


symbolic procedure simpsqrtsq sq;
(simpsqrt2 numr sq) ./ (simpsqrt2 denr sq);


symbolic procedure simpsqrt2 sf;
if minusf sf
  then if sf iequal -1
    then gaussiani
    else begin
      scalar u;
      u:=negf sf;
      if numberp u
        then return multf(gaussiani,simpsqrt3 u);
      % we cannot negate general expressions for the following reason:
%       (%%%thesis remark%%%)
%       sqrt(x*x-1) under x->1/x gives sqrt(1-x*x)/x=i*sqrt(x*x-1)/x
%                 under x->1/x gives x*i*sqrt(-1+1/x*x)=i**2*sqrt(x*x-1)
%       hence an abysmal catastrophe.
      return simpsqrt3 sf
      end
  else simpsqrt3 sf;


symbolic procedure simpsqrt3 sf;
begin
  scalar u;
  u:=assoc(sf,listofallsqrts);
  if u
    then return cdr u;
  % now see if 'knowntobeindep'can help.
  u:=atsoc(listofnewsqrts,knowntobeindep);
  if null u
    then go to no;
  u:=assoc(sf,cdr u);
  if u
    then <<
      listofallsqrts:=u.listofallsqrts;
      return cdr u >>;
no:
  u:=actualsimpsqrt sf;
  listofallsqrts:=(sf.u).listofallsqrts;
  return u
  end;


symbolic procedure sqrtsave(u,v,place);
begin
  scalar a;
  %u is new value of listofallsqrts, v of new.
  a:=assoc(place,sqrt!-places!-alist);
  if null a
    then sqrt!-places!-alist:=(place.(listofnewsqrts.listofallsqrts))
           .sqrt!-places!-alist
    else rplacd(a,listofnewsqrts.listofallsqrts);
      listofnewsqrts:=v;
      % throw away things we are not going to need in future.
      if not !*galois
        then listofallsqrts:=u;
        % we cannot guarantee the validity of our calculations.
      if listofallsqrts eq u
        then return nil;
      v:=listofallsqrts;
      while not (cdr v eq u) do
        v:=cdr v;
      rplacd(v,nil);
      % listofallsqrts is all those added since routine was entered.
      v:=atsoc(listofnewsqrts,knowntobeindep);
      if null v
        then knowntobeindep:=(listofnewsqrts.listofallsqrts)
                              . knowntobeindep
        else rplacd(v,union(cdr v,listofallsqrts));
      listofallsqrts:=u;
      return nil
  end;


symbolic procedure newplace(u);
% Says to restart algebraic bases at a new place u.
begin
  scalar v;
  v:=assoc(u,sqrt!-places!-alist);
  if null v
    then <<
      listofallsqrts:=basic!-listofallsqrts;
      listofnewsqrts:=basic!-listofnewsqrts >>
    else <<
      v:=cdr v;
      listofnewsqrts:=car v;
      listofallsqrts:=cdr v >>;
  return if v then v
              else listofnewsqrts.listofallsqrts
  end;

symbolic procedure mknewsqrt u;
   % U is prefix form.
   begin scalar v,w;
     if not !*galois then go to new;
       % no checking required.
     v:=addf(!*p2f mksp(!*pvar,2),negf !*q2f tidysqrt simp u);
     w:=errorset!*(list('afactor,mkquote v,mkquote !*pvar),t);
     if atom w then go to new
       else w:=car w; % The actual result of afactor.
     if cdr w then go to notnew;
   new:
     w := mksqrt reval u;  % Note that u need not be a canonical
                           % structure here.
     listofnewsqrts:=w . listofnewsqrts;
     return !*kk2f w;
   notnew:
     w:=car w;
     v:=stt(w,!*pvar);
     if car v neq 1 then errach list("Error in mknewsqrt: ",v);
     w:=addf(w,multf(cdr v,(mksp(!*pvar,car v) .* -1) .+nil));
     v:=sqrt2top(w ./ cdr v);
     w:=quotf(numr v,denr v);
     if null w
       % We now test to see if the quotient failure is spurious, e.g.,
       % as in int(-2x/(sqrt(2x^2+1)-2x^2+1),x); It's not clear this is
       % the right place to check though.  More information is
       % available from the earlier int-sqrt step.
       then begin scalar oldprop;
               oldprop := get('sqrt,'simpfn);
               put('sqrt,'simpfn,'simpsqrt);
               v := simp prepsq v;
               put('sqrt,'simpfn,oldprop);
               if denr v = 1 then w := numr v
            end;
     if null w then errach list("Division failure in mknewsqrt",u);
     return w
  end;

symbolic procedure actualsimpsqrt(sf);
if sf iequal -1
  then gaussiani
  else actualsqrtinner(sf,listofnewsqrts);


symbolic procedure actualsqrtinner(sf,l);
   if sf =1 then 1
    else if null l
       or domainp sf or ldeg sf=1
   % Patch by A.C. Norman to prevent recursion errors.
     then actualsimpsqrt2 sf
    else begin scalar z;
       if numberp sf and (z := list('sqrt,sf)) member l
         then return !*kk2f z;
       z := argof car l;
       if z member l then z := !*kk2f car l else z := !*q2f simp z;
       if z = -1 then return actualsqrtinner(sf,cdr l);
       z:=quotf(sf,z);
       if null z then return actualsqrtinner(sf,cdr l)
        else return !*multf(!*kk2f car l,actualsimpsqrt z)
     end;


symbolic procedure actualsimpsqrt2(sf);
 if atom sf
   then if null sf
     then nil
     else if numberp sf
       then if sf < 0
         then multf(gaussiani,actualsimpsqrt2(- sf))
           %Above 2 lines inserted JHD 4 Sept 80;
           % test case: SQRT(B*X**2-C)/SQRT(X);
         else begin
           scalar n;
           n:=int!-sqrt sf;
           % Changed for conformity with DEC20 LISP JHD July 1982;
           if not fixp n
             then return mknewsqrt sf
             else return n
           end
     else mknewsqrt(sf)
   else begin
     scalar form;
     form:=comfac sf;
     if car form
       then return multf((if null cdr sf and (car sf = form)
                            then formsqrt(form .+ nil)
                            else simpsqrt2(form .+ nil)),
                            %The above 2 lines changed by JHD;
                            %(following suggestions of Morrison);
                            %to conform to Standard LISP 4 Sept 80;
                         simpsqrt2 quotf(sf,form .+ nil));
     % we have killed common powers.
     form:=cdr form;
     if form neq 1
       then return multf(simpsqrt2 form,
                          simpsqrt2 quotf(sf,form));
     % remove a common factor from the sf.
     return formsqrt sf
     end;


symbolic procedure int!-sqrt n;
   % Return sqrt of n if same is exact, or something non-numeric
   % otherwise.
    if not numberp n then 'nonnumeric
    else if n<0 then 'negative
    else if floatp n then sqrt n
    else if n<2 then n
    else int!-nr(n,(n+1)/2);


symbolic procedure int!-nr(n,root);
% root is an overestimate here. nr moves downwards to root;
 begin
    scalar w;
    w:=root*root;
    if n=w then return root;
    w:=(root+n/root)/2;
    if w>=root then return !*q2f simpsqrt list n;
    return int!-nr(n,w)
 end;


 symbolic procedure formsqrt(sf);
 if (null red sf)
   then if (lc sf iequal 1) and (ldeg sf iequal 1)
     then mknewsqrt mvar sf
     else multf(if evenp ldeg sf
                  then !*p2f mksp(mvar sf,ldeg sf / 2)
                  else exptf(mknewsqrt mvar sf,ldeg sf),simpsqrt2 lc sf)
   else begin
     scalar varlist,zlist,sqrtlist,sqrtflag;
     scalar v,l,n,w;
     % This returns a list, the i-th member of which is
%      a list of the factors of multiplicity i (as s.f's);
     v:=jsqfree(sf,if intvar and involvesf(sf,intvar) then intvar
                     else findatom mvar sf);
                     % intvar is the best thing to do square-free
                     % decompositions with respect to, but anything
                     % else will do if intvar is not set.
     if null cdr v and null cdar v then return mknewsqrt prepf sf;
       % The JSQFREE did nothing.
     l:=nil;
     n:=0;
     while v do <<
       n:=n+1;
       w:=car v;
       while w do <<
         l:=list('expt,mk!*sq !*f2q car w,n) . l;
         w:=cdr w >>;
       v:=cdr v >>;
     if null cdr l
       then l:=car l
       else l:='times.l;
       % makes L into a valid prefix form;
     return !*q2f simpsqrti l
     end;


symbolic procedure findatom pf;
if atom pf
  then pf
  else findatom argof pf;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/int-table.red0000644000175000017500000000620211526203062023651 0ustar  giovannigiovannimodule int!-table;  % Definition of integrals by means of patterns.

% Authors: John P. Fitch and Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

%Patterns for integration of various logarithmic cases;

for all x,a,b,c,d such that a freeof x and b freeof x and c freeof x
    and d freeof x
   let int(log(a*x+b)/(c*x+d),x)=
           log(c*x+d)*log((b*c-a*d)/c)/c- dilog(c*(a*x+b)/(b*c-a*d))/c;
% A=1;
for all x,b,c,d such that b freeof x and c freeof x and d freeof x
   let int(log(x+b)/(c*x+d),x)=
           log(c*x+d)*log((b*c-d)/c)/c - dilog(c*(x+b)/(b*c-d))/c;
% B=0;
for all x,a,c,d such that a freeof x and c freeof x and d freeof x
   let int(log(a*x)/(c*x+d),x)=
           log(c*x+d)*log(-a*d/c)/c - dilog(-c*x/d)/c;
% C=1;
for all x,a,b,d such that a freeof x and b freeof x and d freeof x
   let int(log(a*x+b)/(x+d),x)=
           log(x+d)*log(b-a*d)-dilog((a*x+b)/(b-a*d));
% D=0;
for all x,a,b,c such that a freeof x and b freeof x and c freeof x
   let int(log(a*x+b)/(c*x),x)= log(c*x)*log(b)/c - dilog((a*x+b)/b)/c;
% A=1, B=0;
for all x,c,d such that c freeof x and d freeof x
   let int(log(x)/(c*x+d),x)= log(c*x+d)*log(-d/c)/c - dilog(-c*x/d)/c;
% A=1, C=1;
for all x,b,d such that b freeof x and d freeof x
   let int(log(x+b)/(x+d),x)= log(x+d)*log(b-d) - dilog((x+b)/(b-d));
% A=1, D=0;
for all x,b,c such that b freeof x and c freeof x
   let int(log(x+b)/(c*x),x)= log(c*x)*log(b)/c - dilog((x+b)/b)/c;
% B=0, C=1;
for all x,a,d such that a freeof x and d freeof x
   let int(log(a*x)/(x+d),x)= log(x+d)*log(-a*d) - dilog(-x/d);
% C=1, D=0;
for all x,a,b such that a freeof x and b freeof x
   let int(log(a*x+b)/x,x)= log(x+d)*log(-d) - dilog(-x/d);
% A=1, C=1, D=0;
for all x,b such that b freeof x
   let int(log(x+b)/x,x)= log(x)*log(b) - dilog((x+b)/b);
% A=1, B=0, C=1;
for all x,d such that d freeof x
   let int(log(x)/(x+d),x)= log(x+d)*log(-d) - dilog(-x/d);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/sqrtf.red0000644000175000017500000001023611526203062023133 0ustar  giovannigiovannimodule sqrtf;   % Square root of standard forms.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*noextend zlist);

exports nrootn,domainp,minusf;  % minusdfp,sqrtdf

imports contentsmv,gcdf,interr,!*multf,partialdiff,printdf,quotf,
   simpsqrt2,vp2;

% symbolic procedure minusdfp a;
%   % Test sign of leading coedd of d.f.
%     if null a then interr "Minusdfp 0 illegal"
%     else minusf numr lc a;

% symbolic procedure sqrtdf l;
%    % Takes square root of distributive form. "Failed" usually means
%    % that the square root is not among already existing objects.
%     if null l then nil
%     else begin scalar c;
%         if lpow l=vp2 zlist then go to ok;
%         c:=sqrtsq df2q l;
%         if numr c eq 'failed
%           then return 'failed;
%         if denr c eq 'failed
%           then return 'failed;
%         return for each u in f2df numr c
%                  collect (car u).!*multsq(cdr u,1 ./ denr c);
%     ok: c:=sqrtsq lc l;
%         if  numr c eq 'failed or
%             denr c eq 'failed
%           then return 'failed
%           else return (lpow l .* c) .+nil
%     end;

% symbolic procedure sqrtsq a;
%     sqrtf numr a ./ sqrtf denr a;

symbolic procedure sqrtf p;
    begin       scalar ip,qp;
        if null p then return nil;
        ip:=sqrtf1 p;
        qp:=cdr ip;
        ip:=car ip; %respectable and nasty parts of the sqrt.
        if qp=1 then return ip; %exact root found.
         if !*noextend then return 'failed;
            % We cannot add new square roots in this case, since it is
            % then impossible to determine if one square root depends
            % on another if new ones are being added all the time.
         if zlistp qp then return 'failed;
            % Liouville's theorem tells you that you never need to add
            % new algebraics depending on the variable of integration.
        qp:=simpsqrt2 qp;
        return !*multf(ip,qp)
    end;

symbolic procedure zlistp qp;
if atom qp then member(qp,zlist)
  else or(member(mvar qp,zlist),zlistp lc qp,zlistp red qp);

symbolic procedure sqrtf1 p;
  % Returns a . b with p=a**2*b.
    if domainp p
     then if fixp p then nrootn(p,2)
           else !*q2f simpsqrt list prepf p . 1
    else begin scalar co,pp,g,pg;
        co:=contentsmv(p,mvar p,nil); %contents of p.
        pp:=quotf(p,co); %primitive part.
        co:=sqrtf1(co); %process contents via recursion.
        g:=gcdf(pp,partialdiff(pp,mvar pp));
        pg:=quotf(pp,g);
        g:=gcdf(g,pg); %a repeated factor of pp.
        if g=1 then pg:=1 . pp
        else <<
            pg:= quotf(pp,!*multf(g,g)); %what is still left.
            pg:=sqrtf1(pg); %split that up.
            rplaca(pg,!*multf(car pg,g))>>;
                 %put in the thing found here.
        rplaca(pg, !*multf(car pg,car co));
        rplacd(pg, !*multf(cdr pg,cdr co));
        return pg
    end;

% NROOTN removed as in REDUCE base.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/reform.red0000644000175000017500000000621711526203062023272 0ustar  giovannigiovannimodule reform; % Reformulate expressions using C-constant substitution.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trint cmap cval loglist ulist);

exports logstosq,substinulist;

imports prepsq,mksp,nth,multsq,addsq,domainp,invsq,plusdf;

symbolic procedure substinulist ulst;
   % Substitutes for the C-constants in the values of the U's given in
   % ULST. Result is a D.F.
   if null ulst then nil
    else begin scalar temp,lcu;
       lcu:=lc ulst;
       temp:=evaluateuconst numr lcu;
       if null numr temp then temp:=nil
        else temp:=((lpow ulst) .*
                   !*multsq(temp,!*invsq(denr lcu ./ 1))) .+ nil;
       return plusdf(temp,substinulist red ulst)
     end;

symbolic procedure evaluateuconst coefft;
% Substitutes for the C-constants into COEFFT (=S.F.). Result is S.Q.;
    if null coefft or domainp coefft then coefft ./ 1
    else begin scalar temp;
      if null(temp:=assoc(mvar coefft,cmap)) then
            temp:=(!*p2f lpow coefft) ./ 1
      else temp:=getv(cval,cdr temp);
      temp:=!*multsq(temp,evaluateuconst(lc coefft));
   % Next line had addsq previously
      return !*addsq(temp,evaluateuconst(red coefft))
    end;

symbolic procedure logstosq;
% Converts LOGLIST to sum of the log terms as a S.Q.;
   begin scalar lglst,logsq,i,temp;
      i:=1;
      lglst:=loglist;
      logsq:=nil ./ 1;
loop: if null lglst then return logsq;
      temp:=cddr car lglst;
%%      if !*trint
%%        then <>;
        a:=dfquotdf1(a,b);
        if (!*trint or !*trdiv) then <<
            printc "Remaining term to be factorised is ";
            printdf a >>;
        if not null resid then begin
            scalar gres,w;
            % Make one more check for a zero residue.
            if null numr df2q resid then return nil;
            if !*trint or !*trdiv then <<
            printc "Failure in factorisation:";
            printdf resid;
            printc "Which should be zero";
            w:=resid;
            gres:=numr lc w; w:=red w;
            while not null w do <<
                gres:=gcdf(gres,numr lc w);
                w:=red w >>;
            printc "I.e. the following vanishes";
            printsf gres>>;
            interr "Non-exact division due to a log term"
            end;
        return a
   end;

symbolic procedure fquotf(a,b);
% Input: a and b standard quotients with (a/b) an exact
% division with respect to the variables in zlist,
% but not necessarily obviously so. the 'non-obvious' problems
% will be because of (e.g.) square-root symbols in b
% output: standard quotient for (a/b)
% (prints message if remainder is not 'clearly' zero.
% A must not be zero.
    begin     scalar t1;
        if null a then interr "a=0 in fquotf";
        t1:=quotf(a,b); %try it the easy way
        if not null t1 then return t1 ./ 1; %ok
        return df2q dfquotdf(f2df a,f2df b)
    end;

symbolic procedure dfquotdf1(a,b);
    begin   scalar q;
        if null b then interr "Attempt to divide by zero";
        q:=sqrtlist; %remove sqrts from denominator, maybe.
        while not null q do begin
            scalar conj;
            conj:=conjsqrt(b,car q); %conjugate wrt given sqrt
            if not (b=conj) then <<
                a:=multdf(a,conj);
                b:=multdf(b,conj) >>;
            q:=cdr q end;
        q:=dfquotdf2(a,b);
        resid:=reversip resid;
        return q
    end;

symbolic procedure dfquotdf2(a,b);
% As above but a and b are distributed forms, as is the result.
    if null a then nil
    else begin scalar xd,lcd;
        xd:=xpdiff(lpow a,lpow b);
        if xd='failed then <<
            xd:=lt a; a:=red a;
            resid:=xd .+ resid;
            return dfquotdf2(a,b) >>;
        lcd:= !*multsq(lc a,!*invsq lc b);
        if null numr lcd then return dfquotdf2(red a,b);
           % Should not be necessary;
        lcd := xd .* lcd;
        xd:=plusdf(a,multdf(negdf (lcd .+ nil),b));
        if xd and (lpow xd = lpow a % Again, should not be necessary;
                   or xpdiff(lpow xd,lpow b) = 'failed)
          then <>;
                 xd := rootextractdf xd;
                 if !*trint or !*trdiv then printdf xd>>;
        return lcd .+ dfquotdf2(xd,b)
    end;

symbolic procedure rootextractdf u;
   if null u then nil
    else begin scalar v;
      v := resimp rootextractsq lc u;
      return if null numr v then rootextractdf red u
              else (lpow u .* v) .+ rootextractdf red u
    end;

symbolic procedure rootextractsq u;
   if null numr u then u
%   else rootextractf numr u ./ rootextractf denr u;
    else (rootextractf numr x ./ rootextractf denr x)
       where x=subs2q u;

symbolic procedure rootextractf v;
   if domainp v then v
    else begin scalar u,r,c,x,p;
      u := mvar v;  p := ldeg v;
      r := rootextractf red v;
      c := rootextractf lc v;
      if null c then return r
       else if atom u then return (lpow v .* c) .+ r
       else if car u eq 'sqrt
        or car u eq 'expt and eqcar(caddr u,'quotient)
           and car cdaddr u = 1 and numberp cadr cdaddr u
        then <
    >
       else <>
               else p := ldeg v>>>>;
      % D. Dahm suggested an additional call of rootextractf on the
      % result here.  This does cause some expressions to simplify
      % sooner, but also leads to infinite loops with expressions
      % like (a*x+b)**p.
      return if p=0 then addf(c,r)
              else if null c then r
              else ((u to p) .* c) .+ r
   end;

% The following hack makes sure that the results of differentiation
% gets passed through ROOTEXTRACT
% a) This should not be done this way, since the effect is global
% b) Should this be done via TIDYSQRT?

put('df,'simpfn,'simpdf!*);

symbolic procedure simpdf!* u;
  begin scalar v,v1;
        v:=simpdf u;
        v1:=rootextractsq v;
        if not(v1=v) then return resimp v1
        else return v
end;

symbolic procedure xpdiff(a,b);
%Result is list a-b, or 'failed' if a member of this would be negative.
    if null a then if null b then nil
        else interr "B too long in xpdiff"
    else if null b then interr "A too long in xpdiff"
    else if car b>car a then 'failed
    else (lambda r;
        if r='failed then 'failed
        else (car a-car b) . r) (xpdiff(cdr a,cdr b));


symbolic procedure conjsqrt(b,var);
% Subst(var=-var,b).
    if null b then nil
    else conjterm(lpow b,lc b,var) .+ conjsqrt(red b,var);

symbolic procedure conjterm(xl,coef,var);
% Ditto but working on a term.
    if involvesp(xl,var,zlist) then xl .* negsq coef
    else xl .* coef;

symbolic procedure involvesp(xl,var,zl);
% Check if exponent list has non-zero power for variable.
    if null xl then interr "Var not found in involvesp"
    else if car zl=var then car xl neq 0
    else involvesp(cdr xl,var,cdr zl);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/isolve.red0000644000175000017500000004421311526203062023277 0ustar  giovannigiovannimodule isolve;   % Routines for solving the final reduction equation.

% Author: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*trint
        badpart
        ccount
        cmap
        cmatrix
        cval
        indexlist
        lhs!*
        lorder
        orderofelim
        power!-list!*
        pt
        rhs!*
        sillieslist
        tanlist
        ulist
        zlist);

global '(!*number!* !*statistics);

exports solve!-for!-u;

imports nth,findpivot,gcdf,int!-gensym1,mkvect,interr,multdfconst,
   !*multf!*,negdf,orddf,plusdf,printdf,printsf,printspreadc,printsq,
   quotf,putv,spreadc,subst4eliminatedcs,mknill,pnth,domainp,addf,
   invsq,multsq;

symbolic procedure uterm(powu,rhs!*);
% Finds the contribution from RHS!* of reduction equation, of the
% U-coefficient given by POWU. Result is in D.F.
   if null rhs!* then nil
   else begin    scalar coef,power;
      power:=addinds(powu,lpow rhs!*);
      coef:=evaluatecoeffts(numr lc rhs!*,powu);
      if null coef then return uterm(powu,red rhs!*);
      coef:=coef ./ denr lc rhs!*;
      return plusdf((power .* coef) .+ nil,uterm(powu,red rhs!*))
   end;

symbolic procedure solve!-for!-u(rhs!*,lhs!*,ulist);
   % Solves the reduction eqn LHS!*=RHS!*.  Returns list of U-coeffs
   % and their values (ULIST are those we have so far), and a list of
   % C-equations to be solved (CLIST are the eqns we have so far).
   begin
   top:
      if null lhs!* then return ulist
       else begin scalar u,lpowlhs;
         lpowlhs := lpow lhs!*;
         begin scalar ll,m1,chge;
           ll:=maxorder(power!-list!*,zlist,0);
           m1:=lorder;
           while m1 do << if car ll < car m1 then
                   << chge:=t; rplaca(m1,car ll) >>;
               ll:=cdr ll; m1:=cdr m1 >>;
           if !*trint and chge then <<
              princ
           "Maximum order for undetermined coefficients is reduced to ";
              printc lorder >>
         end;
         u:=pickupu(rhs!*,lpow lhs!*,t);
         if null u then
         << if !*trint then <<
                printc "***** Equation for a constant to be solved:";
                printsf numr lc lhs!*;
                printc "    = 0";
                printc " ">>;
             % Remove a zero constant from the lhs, rather than use
             % Gauss Elim;
           if gausselimn(numr lc lhs!*,lt lhs!*) then <<
                    lhs!*:=squashconstants(red lhs!*); u := t >>
           else lhs!*:=red lhs!* >>
         else
         << ulist:=(car u .
              subs2q multsq(coefdf(lhs!*,lpowlhs),invsq cdr u)).ulist;
                   % used to be !*multsq.  However, i^2 was not handled
                   % correctly.
           if !*statistics then !*number!*:=!*number!*+1;
            if !*trint then <<
                printc "A coefficient of numerator has been determined";
                   prin2 "***** U"; prin2 car u; prin2t " =";
                   printsq multsq(coefdf(lhs!*,lpowlhs),invsq cdr u);
                   printc " ">>;
            lhs!*:=plusdf(lhs!*,
                   negdf multdfconst(cdar ulist,uterm(car u,rhs!*)))>>;
         if !*trint and u
           then <>
      end;
      go to top
   end;

symbolic procedure squashconstants(express);
begin scalar constlst,ii,xp,cl,subby,cmt,xx;
        constlst:=reverse cmap;
        cmt:=cmatrix;
xxx:    xx:=car cmt;            % Look at next row of Cmatrix
        cl:=constlst;           % and list of the names.
        ii:=1;                   % will become index of removed constant.
        while not getv(xx,ii) do
                << ii:=ii+1; cl:=cdr cl >>;
        subby:=caar cl;         %II is now index, and SUBBY the name.
        if member(subby,sillieslist) then
                <>; %This loop must terminate.
                        % This is because at least one constant remains.
        xp:=prepsq !*f2q getv(xx,0);    % start to build up the answer.
        cl:=cdr cl;
        if not (ccount=ii) then for jj:=ii+1:ccount do <<
                if getv(xx,jj) then
                        xp:=list('plus,xp,
                                list('times,caar cl,
                                        prepsq !*f2q getv(xx,jj)));
                cl:=cdr cl >>;
        xp:=list('quotient,list('minus,xp),
                        prepsq !*f2q getv(xx,ii));
        if !*trint then <<
                prin2 "Replace constant "; prin2 subby;
                prin2 " by "; printsq simp xp >>;
        sillieslist:=subby . sillieslist;
        return subdf(express,xp,subby)
end;

symbolic procedure checku(ulst,u);
   % Checks that U is not already in ULST - ie. that this u-coeff
   % has not already been given a value.
   ulst and (car u = caar ulst or checku(cdr ulst,u));

symbolic procedure checku1(powu,rhs!*);
% Checks that use of a particular U-term will not cause trouble
% by introducing negative exponents into lhs when it is used.
    begin
    top:
        if null rhs!* then return nil;
        if negind(powu,lpow rhs!*) then
          if not null evaluatecoeffts(numr lc rhs!*,powu) then return t;
        rhs!*:=red rhs!*;
        go to top
    end;

symbolic procedure negind(pu,pr);
% Check if substituting index values in power gives rise to -ve
% exponents.
    pu and ((car pu+caar pr)<0 or negind(cdr pu,cdr pr));

symbolic procedure evaluatecoeffts(coefft,indlist);
% Substitutes the values of the i,j,k,...'s that appear in the S.F.
% COEFFT (=coefficient of r.h.s. of reduction equation). Result is S.F.
   if null coefft or domainp coefft then
      if coefft=0 then nil else coefft
   else begin    scalar temp;
      if mvar coefft member indexlist then
         temp:=valuecoefft(mvar coefft,indlist,indexlist)
      else temp:=!*p2f lpow coefft;
      temp:=!*multf(temp,evaluatecoeffts(lc coefft,indlist));
      return addf(temp,evaluatecoeffts(red coefft,indlist))
   end;

symbolic procedure valuecoefft(var,indvalues,indlist);
% Finds the value of VAR, which should be in INDLIST, given INDVALUES,
% the corresponding values of INDLIST variables.
   if null indlist then interr "Valuecoefft - no value"
   else if var eq car indlist then
      if car indvalues=0 then nil
      else car indvalues
   else valuecoefft(var,cdr indvalues,cdr indlist);

symbolic procedure addinds(powu,powrhs);
% Adds indices in POWU to those in POWRHS. Result is LPOW of D.F.
   if null powu then if null powrhs then nil
      else interr "Powrhs too long"
   else if null powrhs then interr "Powu too long"
   else (car powu + caar powrhs).addinds(cdr powu,cdr powrhs);


symbolic procedure pickupu(rhs!*,powlhs,flg);
% Picks up the 'lowest' U coefficient from RHS!* if it exists and
% returns it in the form of LT of D.F..
% Returns NIL if no legal term in RHS!* can be found.
% POWLHS is the power we want to match (LPOW of D.F).
% and COEFFU is the list of previous coefficients that must be zero.
 begin scalar coeffu,u;
    pt:=rhs!*;
top:
    if null pt then return nil; %no term found - failed.
    u:=nextu(lt pt,powlhs); %check this term...
    if null u then go to notthisone;
    if not testord(car u,lorder) then go to neverthisone;
    if not checkcoeffts(coeffu,car u) then go to notthisone;
    %that inhibited clobbering things already passed over.
    if checku(ulist,u) then go to notthisone;
    %that avoided redefining a u value.
    if checku1(car u,rhs!*) then go to neverthisone;
    %avoid introduction of negative exponents.
    if flg then
        u:=patchuptan(list u,powlhs,red pt,rhs!*);
    return u;
neverthisone:
    coeffu:=(lc pt) . coeffu;
notthisone:
    pt:=red pt;
    go to top
 end;

symbolic procedure patchuptan(u,powlhs,rpt,rhs!*);
        begin
            scalar uu,cc,dd,tanlist,redu,redu1,mesgiven,needsquash;
            pt:=rpt;
            while pt do <<
                if (uu:=pickupu(pt,powlhs,nil))
                        and testord(car uu,lorder) then <<
                                % Nasty found, patch it up.
                    cc:=(int!-gensym1 'c . caar u) . cc;
                                % CC is an alist of constants.
                    if !*trint then <<
                        if not mesgiven then << %% Changed by JPff
                          prin2t
                         "*** Introduce new constants for coefficients";
                          mesgiven := t >>;
                        prin2 "***** U";
                        prin2 caar u;
                        prin2t " =";
                        print caar cc >>;
                    redu:=plusdf(redu,
                        multdfconst(!*k2q caar cc,uterm(caar u,rhs!*)));
                    u:=uu.u
                >>;
                if pt then pt:=red pt >>;
            redu1:=redu;
            while redu1 do begin scalar xx; xx:=car redu1;
                if !*trint
                  then << prin2 "Introduced terms: ";
                          prin2 car xx; princ "*(";
                          printsq cdr xx; printc ")">>;
                if (not testord(car xx,lorder)) then <<
                    if !*trint then printc "  =  0";
                    if dd:=killsingles(cadr xx,cc) then <<
                        redu:=subdf(redu,0,car dd);
                        redu1:=subdf(redu1,0,car dd);
                        ulist:=((cdr dd).(nil ./ 1)).ulist;
                        u:=rmve(u,cdr dd);
                        cc:=purgeconst(cc,dd) >>
                    else <<
                        needsquash := t;
                        redu1 :=cdr redu1
                    >>
                >>
                else redu1:=cdr redu1  end;
            for each xx in redu do <<
                if (not testord(car xx,lorder)) then <<
                    while cc do <<
                                addctomap(caar cc);
                                ulist:=((cdar cc).(!*k2q caar cc))
                                          . ulist;
                                if !*statistics
                                  then !*number!*:=!*number!*+1;
                                cc:=cdr cc >>;
                        gausselimn(numr lc redu,lt redu)>> >>;
            if redu then << while cc do << addctomap(caar cc);
                        ulist:=((cdar cc).(!*k2q caar cc)).ulist;
                        if !*statistics then !*number!*:=!*number!*+1;
                        cc:=cdr cc >>;
                lhs!*:=plusdf(lhs!*,negdf redu);
                if needsquash then lhs!*:=squashconstants(lhs!*) >>;
        return car u
end;

symbolic procedure killsingles(xx,cc);
  if atom xx then nil
  else if not (cdr xx eq nil) then nil
  else begin scalar dd;
    dd:=assoc(caaar xx,cc);
    if dd then return dd;
    return killsingles(cdar xx,cc)
end;

symbolic procedure rmve(l,x);
   if caar l=x then cdr l else cons(car l,rmve(cdr l,x));

symbolic procedure subdf(a,b,c);
% Substitute b for c into the df a. Used to get rid of silly constants
% introduced.
if a=nil then nil else
  begin scalar x;
    x:=subs2q subf(numr lc a,list (c . b)) ;
    if x=(nil . 1) then return subdf(red a,b,c)
        else return plusdf(
                list ((lpow a).((car x).!*multf(cdr x,denr lc a))),
                subdf(red a,b,c))
end;

symbolic procedure testord(a,b);
% Test order of two DF's in recursive fashion.
  if null a then t
    else if car a leq car b then testord(cdr a,cdr b)
    else nil;

symbolic procedure tansfrom(rhs,z,indexlist,n);
% We notice that in all bad cases we have (j-num)tan**j...;
% Extract the num to get list of all maxima;
if null z then nil else
begin scalar zz,r, rr, ans;
    r:=rhs;
    zz := car z;
    ans := 0;
    if not(atom zz) and car zz = 'tan then
      while  r do <<
        rr:=caar r;  % The list of powers;
        for i:=1:n do rr:=cdr rr;
        if fixp caar rr then
                ans := max(ans,tanextract(car indexlist,prepsq cdar r));
        r:=cdr r;
      >>;
    return cons(ans,tansfrom(rhs, cdr z,cdr indexlist,n+1))
end;

symbolic procedure tanextract(var, exp);
% Find the value of the variable which makes the expression vanish.
% The coefficients must be linear.
begin scalar ans, c0, c1;
  ans := cdr coeff1(exp,var,nil);
  if length ans = 2 and
     not(car ans = 0) then <<
        c0 := car ans; c1 := cadr ans;
        if eqcar(c0,'!*sq) then c0 := cadr c0 else c0 := c0 ./ 1;
        if eqcar(c1,'!*sq) then c1 := cadr c1 else c1 := c1 ./ 1;
        ans := multsq(c0, invsq c1);
        if atom ans then return 0;
        if (cdr ans = 1) and fixp (car ans) then return -(car ans);
        return 0 >>;
  return 0;
end;

symbolic procedure coefdf(y,u);
  if y=nil then nil
  else if lpow y=u then lc y
  else coefdf(red y,u);


symbolic procedure purgeconst(a,b);
% Remove a constant from and expression. May be the same as DELETE?
  if null a then nil
  else if car a=b then purgeconst(cdr a,b)
  else cons(car a,purgeconst(cdr a,b));

symbolic procedure maxorder(minpowers,z,n);
% Find a limit on the order of terms, this is ad hoc;
  if null z then nil
    else if eqcar(car z,'sqrt) then
        cons(1,maxorder(cdr minpowers,cdr z,n+1))
    else if (atom car z) or (caar z neq 'tan) then
        cons(maxfrom(lhs!*,n)+1,maxorder(cdr minpowers,cdr z,n+1))
    else cons(max(car minpowers, maxfrom(lhs!*,n)),
              maxorder(cdr minpowers,cdr z,n+1));

symbolic procedure maxfrom(l,n); maxfrom1(l,n+1,0);

symbolic procedure maxfrom1(l,n,v);
   % Largest order in the nth variable.
   if null l then v
    else <>;

symbolic procedure addctomap cc;
begin
    scalar ncval;
    ccount:=ccount+1;
    ncval:=mkvect(ccount);
    for i:=0:(ccount-1) do putv(ncval,i,getv(cval,i));
    putv(ncval,ccount,nil ./ 1);
    cval:=ncval;
    cmap:=(cc . ccount).cmap;
    if !*trint then << prin2 "Constant map changed to "; print cmap >>;
    cmatrix := for each j in cmatrix collect addtovector j
end;

symbolic procedure addtovector v;
    begin scalar vv;
        vv:=mkvect(ccount);
        for i:=0:(ccount-1) do putv(vv,i,getv(v,i));
        putv(vv,ccount,nil);
        return vv
    end;

symbolic procedure checkcoeffts(cl,indv);
% checks to see that the coefficients in CL (coefficient list - S.Q.s)
% are zero when the i,j,k,... are given values in INDV (LPOW of
% D.F.). if so the result is true else NIL=false.
    if null cl then t
    else begin    scalar res;
        res:=evaluatecoeffts(numr car cl,indv);
        if not(null res or res=0) then return nil
        else return checkcoeffts(cdr cl,indv)
    end;

symbolic procedure nextu(ltrhs,powlhs);
% picks out the appropriate U coefficients for term: LTRHS to match the
% powers of the z-variables given in POWLHS (= exponent list of D.F.).
% return this coefficient in form LT of D.F. If U coefficient does
% not exist then result is NIL. If it is multiplied by a zero then
% result is NIL.
   if null ltrhs then nil
   else begin    scalar indlist,ucoefft;
      indlist:=subtractinds(powlhs,car ltrhs,nil);
      if null indlist then return nil;
      ucoefft:=evaluatecoeffts(numr cdr ltrhs,indlist);
      if null ucoefft or ucoefft=0 then return nil;
      return indlist .* (ucoefft ./ denr cdr ltrhs)
   end;

symbolic procedure subtractinds(powlhs,l,sofar);
% subtract the indices in list L from those in POWLHS to find
% appropriate values for i,j,k,... when equating coefficients of terms
% on lhs of reduction eqn. SOFAR is the resulting value list we have
% constructed so far. if any i,j,k,... value is -ve then result is NIL.
    if null l then reversip sofar
    else if ((car powlhs)-(caar l))<0 then nil
    else subtractinds(cdr powlhs,cdr l,
        ((car powlhs)-(caar l)) . sofar);

symbolic procedure gausselimn(equation,tokill);
% Performs Gaussian elimination on the matrix for the c-equations
% as each c-equation is found. EQUATION is the next one to deal with.
   begin         scalar newrow,pivot;
      if ccount=0 then go to noway; % failure.
      newrow:=mkvect(ccount);
      spreadc(equation,newrow,1);
      subst4eliminatedcs(newrow,reverse orderofelim,reverse cmatrix);
      pivot:=findpivot newrow;
      if null pivot then go to nopivotfound;
      orderofelim:=pivot . orderofelim;
      newrow:=makeprim newrow; % remove hcf from new equation.
      cmatrix:=newrow . cmatrix;
%      if !*trint then printspreadc newrow;
      return t;
 nopivotfound:
      if null getv(newrow,0) then <<
        if !*trint then printc "This equation adds no new information";
        return nil>>; % equation was 0=0.
 noway:
      badpart:=tokill . badpart; % non-integrable term.
      if !*trint then
        <>;
      return nil
   end;

symbolic procedure makeprim row;
    begin scalar g;
        g:=getv(row,0);
        for i:=1:ccount do g:=gcdf(g,getv(row,i));
        if g neq 1 then
           for i:=0:ccount do putv(row,i,quotf(getv(row,i),g));
        for i := 0:ccount do
          <>;
        return row
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/jpatches.red0000644000175000017500000002731311526203062023601 0ustar  giovannigiovannimodule jpatches;   % Routines for manipulating sf's with power folding.

% Author: James H. Davenport.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*noncomp sqrtflag);

exports !*addsq,!*multsq,!*invsq,!*multf,!*exptsq,!*exptf; %squashsqrtsq

% !*MULTF(A,B) multiplies the polynomials (standard forms) U and V
% in much the same way as MULTF(U,V) would, EXCEPT...
%     (1) !*MULTF inhibits the action of OFF EXP and of non-commutative
%         multiplications
%     (2) Within !*MULTF powers of square roots, and powers of
%         exponential kernels are reduced as if substitution rules
%         such as FOR ALL X LET SQRT(X)**2=X were being applied;

% Note that !*MULTF comes between MULTF and !*Q2F SUBS2F MULTF in its
% behaviour, and that it is the responsibility of the user to call it
% in sensible places where its services are needed.

% Similarly for the other functions defined here.


%symbolic procedure !*addsq(u,v);
   %U and V are standard quotients.
%  %Value is canonical sum of U and V;
%   if null numr u then v
%    else if null numr v then u
%    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
%    else begin scalar nu,du,nv,dv,x;
%        x := gcdf(du:=denr u,dv:=denr v);
%        du:=quotf(du,x); dv:=quotf(dv,x);
%        nu:=numr u; nv:=numr v;
%        u:=addf(!*multf(nu,dv),!*multf(nv,du));
%        if u=nil then return nil ./ 1;
%        v:=!*multf(du,denr v);
%        return !*ff2sq(u,v)
%    end;

%symbolic procedure !*multsq(a,b);
%  begin
%    scalar n,d;
%    n:=!*multf(numr a,numr b);
%    d:=!*multf(denr a,denr b);
%    return !*ff2sq(n,d)
%  end;

%symbolic procedure !*ff2sq(a,b);
%  begin
%    scalar gg;
%    if null a then return nil ./ 1;
%    gg:=gcdf(a,b);
%    if not (gg=1) then <<
%        a:=quotf(a,gg);
%        b:=quotf(b,gg) >>;
%    if minusf b then <<
%        a:=negf a;
%        b:=negf b >>;
%    return a ./ b
%  end;

symbolic procedure !*addsq(u,v);
   %U and V are standard quotients.
   %Value is canonical sum of U and V;
   if null numr u then v
    else if null numr v then u
    else if denr u=1 and denr v=1 then addf(numr u,numr v) ./ 1
    else begin scalar du,dv,x,y,z;
        x := gcdf(du:=denr u,dv:=denr v);
        du:=quotf(du,x); dv:=quotf(dv,x);
        y:=addf(!*multf(dv,numr u),!*multf(du,numr v));
        if null y then return nil ./ 1;
        z:=!*multf(denr u,dv);
        if minusf z then <>;
        % In this case (as opposed to ADDSQ), Y and Z may have
        % developed common factors from SQRT expansion, so a
        % gcd of Y and Z is needed.
        x := gcdf(y,z);
        return if x=1 then y ./ z else quotf(y,x) ./ quotf(z,x)
    end;

symbolic procedure !*multsq(u,v);
   %U and V are standard quotients. Result is the canonical product of
   %U and V with surd powers suitably reduced.
   if null numr u or null numr v then nil ./ 1
    else if denr u=1 and denr v=1 then !*multf(numr u,numr v) ./ 1
    else begin scalar w,x,y;
     x := gcdf(numr u,denr v);
     y := gcdf(numr v,denr u);
     w := !*multf(quotf(numr u,x),quotf(numr v,y));
     x := !*multf(quotf(denr u,y),quotf(denr v,x));
     if minusf x then <>;
     y := gcdf(w,x);  % another factor may have been generated.
     return if y=1 then w ./ x else quotf(w,y) ./ quotf(x,y)
    end;

symbolic procedure !*invsq a;
   % Note that several examples (e.g., int(1/(x**8+1),x)) give a more
   % compact result when SQRTFLAG is true if SQRT2TOP is not called.
   if sqrtflag then sqrt2top invsq a else invsq a;

symbolic procedure !*multf(u,v);
  % U and V are standard forms
  % Value is SF for U*V;
  begin scalar x,y;
      if null u or null v then return nil
      else if u=1 then return squashsqrt v
        else if v=1 then return squashsqrt u
        else if domainp u then return multd(u,squashsqrt v)
        else if domainp v then return multd(v,squashsqrt u)
        else if !*noncomp then return multf(u,v);
      x:=mvar u;
      y:=mvar v;
      if x eq y then go to c else if ordop(x,y) then go to b;
      x:=!*multf(u,lc v);
      y:=!*multf(u,red v);
      return if null x then y
              else if not domainp lc v
                and mvar u eq mvar lc v
                and not atom mvar u
                and car mvar u memq '(expt sqrt)
               then addf(!*multf(x,!*p2f lpow v),y)
              else makeupsf(lpow v,x,y);
  b:  x:=!*multf(lc u,v);
      y:=!*multf(red u,v);
      return if null x then y
              else if not domainp lc u
                and mvar lc u eq mvar v
                and not atom mvar v
                and car mvar v memq '(expt sqrt)
               then addf(!*multf(!*p2f lpow u,x),y)
              else makeupsf(lpow u,x,y);
  c:  y:=addf(!*multf(list lt u,red v),!*multf(red u,v));
      if eqcar(x,'sqrt)
        then return addf(squashsqrt y,!*multfsqrt(x,
                        !*multf(lc u,lc v),ldeg u + ldeg v))
        else if eqcar(x,'expt) and prefix!-rational!-numberp caddr x
          then return addf(squashsqrt y,!*multfexpt(x,
                        !*multf(lc u,lc v),ldeg u + ldeg v));
      x:=mkspm(x,ldeg u + ldeg v);
      return if null x or null (u:=!*multf(lc u,lc v))
               then y
               else addf(multpf(x,u),y)
    end;

symbolic procedure makeupsf(u,x,y);
% Makes u .* x .+ y  except when u is not a valid lpow (because of
% sqrts).
   if atom car u or cdr u = 1 then addf(multpf(u,x),y)
     else if caar u eq 'sqrt then addf(!*multfsqrt(car u,x,cdr u),y)
       else if <>
         then addf(!*multfexpt(car u,x,cdr u),y)
         else addf(multpf(u,x),y);


symbolic procedure !*multfsqrt(x,u,w);
   % This code (Due to Norman a& Davenport) squashes SQRT(...)**2.
   begin scalar v;
     w:=divide(w,2);
     v:=!*q2f simp cadr x;
     u:=!*multf(u,exptf(v,car w));
     if cdr w neq 0 then u:=!*multf(u,!*p2f mksp(x,1));
     return u
   end;


symbolic procedure !*multfexpt(x,u,w);
  begin scalar expon,v;
    expon:=caddr x;
    x:=cadr x;
    w:=w * cadr expon;
    expon:=caddr expon;
    v:=gcdn(w,expon);
    w:=w/v;
    v:=expon/v;
    if not (w > 0) then rerror(int,8,"Invalid exponent")
     else if v = 1
      then return !*multf(u,exptf(if numberp x then x
                                    else if atom x then !*k2f x
                                    else !*q2f if car x eq '!*sq
                                                 then argof x
                                                else simp x,
                          w));
    expon:=0;
    while not (w < v) do <>;
    if expon>0 then u:=!*multf(u,exptf(!*q2f simp x,expon));
    if w = 0 then return u;
    x:=list('expt,x,list('quotient,1,v));
    return multf(squashsqrt u,!*p2f mksp(x,w))   % Cannot be *MULTF.
  end;

symbolic procedure prefix!-rational!-numberp u;
  % Tests for m/n in prefix representation.
    eqcar(u,'quotient) and numberp cadr u and numberp caddr u;

% symbolic procedure squashsqrtsq sq;
%    !*multsq(squashsqrt numr sq ./ 1,1 ./ squashsqrt denr sq);

symbolic procedure squashsqrt sf;
if (not sqrtflag) or atom sf or atom mvar sf
  then sf
  else if car mvar sf eq 'sqrt and ldeg sf > 1
    then addf(squashsqrt red sf,!*multfsqrt(mvar sf,lc sf,ldeg sf))
    else if car mvar sf eq 'expt
       and prefix!-rational!-numberp caddr mvar sf
       and ldeg sf >= caddr caddr mvar sf
      then addf(squashsqrt red sf,!*multfexpt(mvar sf,lc sf,ldeg sf))
      else (if null x then squashsqrt red sf
            else lpow sf .* x .+ squashsqrt red sf)
           where x = squashsqrt lc sf;

%remd 'simpx1;

% The following definition requires frlis!* declared global.

%symbolic procedure simpx1(u,m,n);
%   %u,m and n are prefix expressions;
%   %value is the standard quotient expression for u**(m/n);
%   begin scalar flg,z;
%        if null frlis!* or null intersection(frlis!*,flatten (m . n))
%          then go to a;
%        exptp!* := t;
%        return !*k2q list('expt,u,if n=1 then m
%                                   else list('quotient,m,n));
%    a:  if numberp m and fixp m then go to e
%         else if atom m then go to b
%         else if car m eq 'minus then go to mns
%         else if car m eq 'plus then go to pls
%         else if car m eq 'times and numberp cadr m and fixp cadr m
%                and numberp n
%          then go to tms;
%    b:  z := 1;
%    c:  if atom u and not numberp u then flag(list u,'used!*);
%        u := list('expt,u,if n=1 then m else list('quotient,m,n));
%        if not(u member exptl!*) then exptl!* := u . exptl!*;
%    d:  return mksq(u,if flg then -z else z); %u is already in lowest
%%       %terms;
%    e:  if numberp n and fixp n then go to int;
%        z := m;
%        m := 1;
%        go to c;
%    mns: m := cadr m;
%        if !*mcd then return invsq simpx1(u,m,n);
%        flg := not flg;
%        go to a;
%    pls: z := 1 ./ 1;
%    pl1: m := cdr m;
%        if null m then return z;
%        z := multsq(simpexpt list(u,
%                        list('quotient,if flg then list('minus,car m)
%                                        else car m,n)),
%                    z);
%        go to pl1;
%    tms: z := gcdn(n,cadr m);
%        n := n/z;
%        z := cadr m/z;
%        m := retimes cddr m;
%        go to c;
%    int:z := divide(m,n);
%        if cdr z<0 then z:= (car z - 1) . (cdr z+n);
%        if 0 = cdr z
%          then return simpexpt list(u,car z);
%        if n = 2
%          then return multsq(simpexpt list(u,car z),
%                             simpsqrti u);
%        return multsq(simpexpt list(u,car z),
%                        mksq(list('expt,u,list('quotient,1,n)),cdr z))
%   end;

symbolic procedure !*exptsq(a,n);
% Raises A to the power N using !*MULTSQ.
    if n=0 then 1 ./ 1
    else if n=1 then a
    else if n<0 then !*exptsq(invsq a,-n)
    else begin
      scalar q,r;
      q:=divide(n,2);
      r:=cdr q; q:=car q;
      q:=!*exptsq(!*multsq(a,a),q);
      if r=0 then return q
      else return !*multsq(a,q)
    end;


symbolic procedure !*exptf(a,n);
% Raises A to the power N using !*MULTF.
    if n=0 then 1
    else if n=1 then a
    else begin
      scalar q,r;
      q:=divide(n,2);
      r:=cdr q; q:=car q;
      q:=!*exptf(!*multf(a,a),q);
      if r=0 then return q
      else return !*multf(a,q)
    end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/trcase.red0000644000175000017500000003246711526203062023267 0ustar  giovannigiovannimodule trcase;  % Driving routine for integration of transcendental fns.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*backtrace
        !*failhard
        !*nowarnings
        !*purerisch
        !*reverse
        !*trint
        badpart
        ccount
        cmap
        cmatrix
        content
        cval
        denbad
        denominator!*
        indexlist
        lhs!*
        loglist
        lorder
        orderofelim
        power!-list!*
        rhs!*
        sillieslist
        sqfr
        sqrtflag
        sqrtlist
        tanlist
        svar
        varlist
        xlogs
        zlist);

% !*reverse:       flag to re-order zlist.
% !*nowarnings:    flag to lose messages.

global '(!*number!*
         !*ratintspecial
         !*seplogs
         !*spsize!*
         !*statistics
         gensymcount);

switch failhard;

exports transcendentalcase;

imports backsubst4cs,countz,createcmap,createindices,df2q,dfnumr,
  difflogs,fsdf,factorlistlist,findsqrts,findtrialdivs,gcdf,mkvect,
  interr,logstosq,mergin,multbyarbpowers,!*multf, % multsqfree,
  printdf,printsq,quotf,rationalintegrate,putv,
  simpint1,solve!-for!-u,sqfree,sqmerge,sqrt2top,substinulist,trialdiv,
  mergein,negsq,addsq,f2df,mknill,pnth,invsq,multsq,domainp,mk!*sq,
  mksp,prettyprint;

% Note that SEPLOGS keeps logarithmic part of result together as a
% kernel form, but this can lead to quite messy results.

symbolic
   procedure transcendentalcase(integrand,svar,xlogs,zlist,varlist);
   begin scalar divlist,jhd!-content,content,prim,sqfr,dfu,indexlist,
%      JHD!-CONTENT is local, while CONTENT is free (set in SQFREE).
      sillieslist,originalorder,wrongway,power!-list!*,
      sqrtlist,tanlist,loglist,dflogs,eprim,dfun,unintegrand,
      sqrtflag,badpart,rhs!*,lhs!*,gcdq,cmap,cval,orderofelim,cmatrix;
      scalar ccount,denominator!*,result,denbad,temp;
        gensymcount:=0;
      integrand:=sqrt2top integrand; % Move the sqrts to the numerator.
      if !*trint then << printc "Extension variables z are";
          print zlist>>;
%     if !*ratintspecial and null cdr zlist then
%           return rationalintegrate(integrand,svar);
     % *** now unnormalize integrand, maybe ***.
     begin scalar w,gg;
        gg:=1;
        foreach z in zlist do
           <>;
        gg := quotf(gg,gcdf(gg,denr integrand));
        unintegrand := (!*multf(gg,numr integrand)
                        ./ !*multf(gg,denr integrand));  % multf?
        if !*trint then <<
                printc "After unnormalization the integrand is ";
                printsq unintegrand >>
      end;
      divlist := findtrialdivs zlist;
         % Also puts some things on loglist sometimes.
      sqrtlist := findsqrts zlist;
      divlist := trialdiv(denr unintegrand,divlist);
      % N.B. the next line also sets 'content' as a free variable.
      % Since SQFREE may be used later, we copy it into JHD!-CONTENT.
      prim := sqfree(cdr divlist,zlist);
      jhd!-content := content;
      printfactors(prim,nil);
      eprim := sqmerge(countz car divlist,prim,nil);
      printfactors(eprim,t);
%     if !*trint then <>;
      sqfr := for each u in eprim collect multup u;
%      sqfr := multsqfree eprim;
%     if !*trint then <>;
      if !*reverse then zlist := reverse zlist; % Alter order function.
      indexlist := createindices zlist;
%     if !*trint then << printc "...indices are:";
%         prettyprint indexlist>>;
      dfu:=dfnumr(svar,car divlist);
%     if !*trint then << terpri();
%         printc "************ Derivative of u is:";
%         printsq dfu>>;
      loglist := append(loglist,factorlistlist prim); %%% nconc?
      loglist := mergein(xlogs,loglist);
      loglist := mergein(tanlist,loglist);
      cmap := createcmap();
      ccount := length cmap;
      if !*trint then <>;
      dflogs := difflogs(loglist,denr unintegrand,svar);
      if !*trint
        then <>;
      dflogs := addsq((numr unintegrand) ./ 1,negsq dflogs);
      % Put everything in reduction eqn over common denominator.
      gcdq := gcdf(denr dflogs,denr dfu);
      dfun := !*multf(numr dfu,denbad:=quotf(denr dflogs,gcdq));
      denbad := !*multf(denr dfu,denbad);
      denbad := !*multf(denr unintegrand,denbad);
      dflogs := !*multf(numr dflogs,quotf(denr dfu,gcdq));
      dfu := dfun;
      % Now DFU and DFLOGS are S.F.s.
      rhs!* := multbyarbpowers f2df dfu;
      if checkdffail(rhs!*,svar)
        then <>;
      if !*trint then <<
          printc "Distributed Form of Numerator is:";
          printdf rhs!*>>;
      lhs!* := f2df dflogs;
%     if checkdffail(lhs!*,svar) then interr "Simplification failure";
      if !*trint then << printc "Distributed Form of integrand is:";
          printdf lhs!*;
          terpri()>>;
      cval := mkvect(ccount);
      for i := 0:ccount do putv(cval,i,nil ./ 1);
      power!-list!* := tansfrom(rhs!*,zlist,indexlist,0);
      lorder:=maxorder(power!-list!*,zlist,0);
      originalorder := for each x in lorder collect x;
           % Must copy as it is overwritten.
        if !*trint then <<
                printc "Maximum order for variables determined as ";
                print lorder >>;
        if !*statistics then << !*number!*:=0;
                !*spsize!*:=1;
                foreach xx in lorder do
                   !*spsize!*:=!*spsize!* * (xx+1) >>;
                % That calculates the largest U that can appear.
      dfun:=solve!-for!-u(rhs!*,lhs!*,nil);
      backsubst4cs(nil,orderofelim,cmatrix);
%      if !*trint then if ccount neq 0 then printvecsq cval;
        if !*statistics then << prin2 !*number!*; prin2 " used out of ";
                printc !*spsize!* >>;
      badpart:=substinulist badpart;
                 %substitute for c still in badpart.
      dfun:=df2q substinulist dfun;
      result:= !*multsq(dfun,!*invsq(denominator!* ./ 1));
      result:= !*multsq(result,!*invsq(jhd!-content ./ 1));
      dflogs:=logstosq();
      if not null numr dflogs then <<
          if !*seplogs and (not domainp numr result) then <<
              result:=mk!*sq result;
              result:=(mksp(result,1) .* 1) .+ nil;
              result:=result ./ 1 >>;
          result:=addsq(result,dflogs)>>;
      if !*trint
        then  << %% prettyprint result;
          terpri();
          printc
          "*****************************************************";
          printc
           "************ THE INTEGRAL IS : **********************";
          printc
           "*****************************************************";
          terpri();
          printsq result;
          terpri()>>;
      if badpart then begin scalar n,oorder;
          if !*trint
            then printc "plus a part which has not been integrated";
          lhs!*:=badpart;
          lorder:=maxorder(power!-list!*,zlist,0);
          oorder:=originalorder;
          n:=length lorder;
          while lorder do <<
                if car lorder > car originalorder then
                        wrongway:=t;
                if car lorder=car originalorder then n:= n-1;
                lorder:=cdr lorder;
                originalorder:=cdr originalorder >>;
%%          if n=0 then wrongway:=t;      % Nothing changed
          if !*trint and wrongway then printc "Went wrong way";
          dfun:=df2q badpart;
%%          if !*trint
%%            then <>;
          if rootcheckp(unintegrand,svar) then
                return simpint1(integrand . svar.nil) . (nil ./ 1)
          else if !*purerisch or allowedfns zlist then
              << badpart := dfun;
                 dfun := nil ./ 1 >>    % JPff
           else << !*purerisch:=t;
                if !*trint
                  then <>;
              % We do not want any rules for tan at this point. In fact,
              % this may not be enough.
              temp := get('tan,'opmtch);
              remprop('tan,'opmtch);
              denbad:=transform(dfun,svar);
              if denbad=dfun
                then <>
             else < car oorder then
                                        wrongway:=t;
                                if car lorder=car oorder then n:= n-1;
                                lorder:=cdr lorder;
                                oorder:=cdr oorder >>;
                          if wrongway or (n=0) then <<
                               if !*trint then printc "Still backwards";
                               dfun := nil ./ 1;
                               badpart := integrand>>>>>>
                     else <>>>>>;
          if !*failhard then rerror(int,9,"FAILHARD switch set");
          if !*seplogs and not domainp result then <<
                result:=mk!*sq result;
                if not numberp result
                  then result:=(mksp(result,1) .* 1) .+ nil;
                result:=result ./ 1>>;
          result:=addsq(result,dfun) end
         else badpart:=nil ./ 1;
      return (sqrt2top result . badpart)                % JPff
   end;

symbolic procedure checkdffail(u,v);
   % Sometimes simplification fails and this gives the integrator the
   % idea that something is a constant when it is not.  Check for this.
   if null u then nil
    else if depends(lc u,v) then lc u
    else checkdffail(red u,v);

symbolic procedure printfactors(w,prdenom);
    % W is a list of factors to each power. If PRDENOM is true
    % this prints denominator of answer, else prints square-free
    % decomposition.
    begin         scalar i,wx;
        i:=1;
        if prdenom then <<
            denominator!* := 1;
            if !*trint
              then printc "Denominator of 1st part of answer is:";
            if not null w then w:=cdr w >>;
loopx:  if w=nil then return;
        if !*trint then <>;
        wx:=car w;
        while not null wx do <<
            if !*trint then printsf car wx;
            for j:=1 : i do
                denominator!*:= !*multf(car wx,denominator!*);
            wx:=cdr wx >>;
        i:=i+1;
        w:=cdr w;
        go to loopx
    end;

% unfluid '(dfun svar xlogs);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/tidysqrt.red0000644000175000017500000001532311526203062023661 0ustar  giovannigiovannimodule tidysqrt;  % General tidying up of square roots.

% Authors: Mary Ann Moore and Arthur C. Norman.
% Modifications by J.H. Davenport.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


exports sqrt2top,tidysqrt;

%symbolic procedure tidysqrtdf a;
%    if null a then nil
%    else begin    scalar tt,r;
%        tt:=tidysqrt lc a;
%        r:=tidysqrtdf red a;
%        if null numr tt then return r;
%        return ((lpow a) .* tt) .+ r
%    end;
%
symbolic procedure tidysqrt q;
    begin    scalar n1,dd;
        n1:=tidysqrtf numr q;
        if null n1 then return nil ./ 1; %answer is zero.
        dd:=tidysqrtf denr q;
        return multsq(n1,invsq dd)
    end;

symbolic procedure tidysqrtf p;
%Input - standard form.
%Output - standard quotient.
%Simplifies sqrt(a)**n with n>1.
    if domainp p then p ./ 1
    else begin    scalar v,w;
        v:=lpow p;
        if car v='i then v:=mksp('(sqrt -1),cdr v); %I->sqrt(-1);
        if eqcar(car v,'sqrt) and not onep cdr v
          then begin    scalar x;
             %here we have a reduction to apply.
            x:=divide(cdr v,2); %halve exponent.
            w:=exptsq(simp cadar v,car x); %rational part of answer.
            if cdr x neq 0
              then w := multsq(w,((mksp(car v,1) .* 1) .+ nil) ./ 1);
            %the next line allows for the horrors of nested sqrts.
            w:=tidysqrt w
            end
        else w:=((v .* 1) .+ nil) ./ 1;
        v:=multsq(w,tidysqrtf lc p);
        return addsq(v,tidysqrtf red p)
    end;


symbolic procedure multoutdenr q;
  % Move sqrts in a sq to the numerator.
    begin  scalar n,d,root,conj;
        n:=numr q;
        d:=denr q;
        while (root:=findsquareroot d) do <<
          conj:=conjugatewrt(d,root);
          n:=!*multf(n,conj);
          d:=!*multf(d,conj) >>;
        while (root:=findnthroot d) do <<
          conj:=conjugateexpt(d,root,kord!*);
          n:=!*multf(n,conj);
          d:=!*multf(d,conj) >>;
        return (n . d);
        end;

symbolic procedure conjugateexpt(d,root,kord!*);
  begin scalar ord,ans,repl,xi;
  ord:=caddr caddr root; % the denominator of the exponent;
  ans:=1;
  kord!*:= (xi:=gensym()) . kord!*;
  % XI is an ORD'th root of unity;
  for i:=1:ord-1 do <<
    ans:=!*multf(ans,numr subf(d,
                   list(root . list('times,root,list('explt,xi,i)))));
    while (mvar ans eq xi) and ldeg ans > ord do
      ans:=addf(red ans,(xi) to (ldeg ans - ord) .* lc ans .+ nil);
    if (mvar ans eq xi) and ldeg ans = ord then
      ans:=addf(red ans,lc ans) >>;
  if (mvar ans eq xi) and ldeg ans = ord-1 then <<
    repl:=-1;
    for i:=1:ord-2 do
      repl:=(xi) to i .* -1 .+ repl;
    ans:=addf(red ans,!*multf(lc ans,repl)) >>;
  if not domainp ans and mvar ans eq xi
    then interr "Conjugation failure";
  return ans;
  end;

symbolic procedure sqrt2top q;
begin
  scalar n,d;
  n:=multoutdenr q;
  d:=denr n;
  n:=numr n;
  if d eq denr q
    then return q;%no change.
  if d iequal 1
    then return (n ./ 1);
  q:=gcdcoeffsofsqrts n;
  if q iequal 1
    then if minusf d
      then return (negf n ./ negf d)
      else return (n ./ d);
  q:=gcdf(q,d);
  n:=quotf(n,q);
  d:=quotf(d,q);
  if minusf d
    then return (negf n ./ negf d)
    else return (n ./ d)
    end;

%symbolic procedure denrsqrt2top q;
%begin
%  scalar n,d;
%  n:=multoutdenr q;
%  d:=denr n;
%  n:=numr n;
%  if d eq denr q
%    then return d; % no changes;
%  if d iequal 1
%    then return 1;
%  q:=gcdcoeffsofsqrts n;
%  if q iequal 1
%    then return d;
%  q:=gcdf(q,d);
%  if q iequal 1
%    then return d
%    else return quotf(d,q)
%  end;

symbolic procedure findsquareroot p;
  % Locate a sqrt symbol in poly p.
    if domainp p then nil
    else begin scalar w;
        w:=mvar p; %check main var first.
        if atom w
          then return nil; %we have passed all sqrts.
        if eqcar(w,'sqrt) then return w;
        w:=findsquareroot lc p;
        if null w then w:=findsquareroot red p;
        return w
    end;

symbolic procedure findnthroot p;
   nil;   % Until corrected.

% symbolic procedure x!-findnthroot p;
%     % Locate an n-th root symbol in poly p.
%     if domainp p then nil
%     else begin scalar w;
%         w:=mvar p; %check main var first.
%         if atom w
%           then return nil; %we have passed all sqrts.
%         if eqcar(w,'expt) and eqcar(caddr w,'quotient) then return w;
%         w:=findnthroot lc p;
%         if null w then w:=findnthroot red p;
%         return w
%     end;

symbolic procedure conjugatewrt(p,var);
  % Var -> -var in form p.
    if domainp p then p
    else if mvar p=var then begin
        scalar x,c,r;
        x:=tdeg lt p; %degree
        c:=lc p; %coefficient
        r:=red p; %reductum
        x:=remainder(x,2); %now just 0 or 1.
        if x=1 then c:=negf c; %-coefficient.
        return (lpow p .* c) .+ conjugatewrt(r,var) end
    else if ordop(var,mvar p) then p
    else (lpow p .* conjugatewrt(lc p,var)) .+
        conjugatewrt(red p,var);

symbolic procedure gcdcoeffsofsqrts u;
if atom u
  then if numberp u and minusp u
    then -u
    else u
  else if eqcar(mvar u,'sqrt)
    then begin
      scalar v;
      v:=gcdcoeffsofsqrts lc u;
      if v iequal 1
        then return v
        else return gcdf(v,gcdcoeffsofsqrts red u)
      end
    else begin
      scalar root;
      root:=findsquareroot u;
      if null root
        then return u;
      u:=makemainvar(u,root);
      root:=gcdcoeffsofsqrts lc u;
      if root iequal 1
        then return 1
        else return gcdf(root,gcdcoeffsofsqrts red u)
      end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/idepend.red0000644000175000017500000000562111526203062023406 0ustar  giovannigiovanniMODULE IDEPEND;  % Routines for considering dependency among variables.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


FLUID '(TAYLORVARIABLE);

EXPORTS DEPENDSPL,DEPENDSP,INVOLVESQ,INVOLVSF;

IMPORTS DOMAINP;

SYMBOLIC PROCEDURE DEPENDSP(X,V);
   IF NULL V THEN T
    ELSE IF DEPENDS(X,V) THEN X
    ELSE IF ATOM X THEN IF X EQ V THEN X ELSE NIL
    ELSE IF CAR X = '!*SQ THEN INVOLVESQ(CADR X,V)
    ELSE IF TAYLORP X
     THEN IF V EQ TAYLORVARIABLE THEN TAYLORVARIABLE ELSE NIL
    ELSE BEGIN SCALAR W;
       IF X=V THEN RETURN V;
       % Check if a prefix form expression depends on the variable v.
       % Note this assumes the form x is in normal prefix notation;
       W := X; % preserve the dependency;
       X := CDR X; % ready to recursively check arguments;
 SCAN: IF NULL X THEN RETURN NIL; % no dependency found;
       IF DEPENDSP(CAR X,V) THEN RETURN W;
       X:=CDR X;
       GO TO SCAN
    END;

SYMBOLIC PROCEDURE INVOLVESQ(SQ,TERM);
   INVOLVESF(NUMR SQ,TERM) OR INVOLVESF(DENR SQ,TERM);

SYMBOLIC PROCEDURE INVOLVESF(SF,TERM);
   IF DOMAINP SF OR NULL SF THEN NIL
    ELSE DEPENDSP(MVAR SF,TERM)
       OR INVOLVESF(LC SF,TERM)
       OR INVOLVESF(RED SF,TERM);

SYMBOLIC PROCEDURE DEPENDSPL(DEP!-LIST,VAR);
   % True if any member of deplist (a list of prefix forms) depends on
   % var.
   DEP!-LIST
      AND (DEPENDSP(CAR DEP!-LIST,VAR) OR DEPENDSPL(CDR DEP!-LIST,VAR));

SYMBOLIC SMACRO PROCEDURE TAYLORFUNCTION U; CAAR U;

SYMBOLIC PROCEDURE TAYLORP EXXPR;
   % Sees if a random entity is a taylor expression.
   NOT ATOM EXXPR
       AND NOT ATOM CAR EXXPR
       AND FLAGP(TAYLORFUNCTION EXXPR,'TAYLOR);

ENDMODULE;

END;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/ibasics.red0000644000175000017500000001064011526203062023410 0ustar  giovannigiovannimodule ibasics;   % Some basic support routines for integrator.

% Authors: Mary Ann Moore and Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*backtrace !*gcd !*sqfree !*trint indexlist sqrtflag sqrtlist
        varlist zlist);

exports partialdiff,printdf,interr;

imports df2printform,printsf,varsinsf,addsq,multsq,multd,mksp;

symbolic procedure printdf u;
% Print distributed form via cheap conversion to reduce structure.
    begin scalar !*gcd;
       printsf df2printform u;
    end;

% symbolic procedure indx(n);
%    if n<2 then (list 1) else(n . indx(isub1 n));

symbolic procedure interr mess;
   <>;
     error1()>>;

symbolic procedure partialdiff(p,v);
% Partial differentiation of p wrt v - p is s.f. as is result.
    if domainp p then nil
    else
        if v=mvar p then
            (lambda x; if x=1 then lc p
             else ((mksp(v,x-1) .* multd(x,lc p))
                         .+ partialdiff(red p,v)))
            (tdeg lt p)
        else
            (lambda x; if null x then partialdiff(red p,v)
             else ((lpow p .* x) .+ partialdiff(red p,v)))
            (partialdiff(lc p,v));

put('pdiff,'simpfn,'simppdiff);

symbolic procedure mkilist(old,term);
   if null old then nil
    else term.mkilist(cdr old,term);

% symbolic procedure addin(lista,first,listb);
% if null lista
%  then nil
%  else ((first.car listb).car lista).addin(cdr lista,first,cdr listb);

symbolic procedure removeduplicates(u);
  % Purges duplicates from the list passed to it.
if null u then nil
  else if (atom u) then u.nil
    else if member(car u,cdr u)
      then removeduplicates cdr u
      else (car u).removeduplicates cdr u;

symbolic procedure jsqfree(sf,var);
begin
  varlist:=getvariables(sf ./ 1);
  zlist:=findzvars(varlist,list var,var,nil);
  sqrtlist:=findsqrts varlist; % before the purge
  sqrtflag:=not null sqrtlist;
  varlist := setdiff(varlist,zlist);
  return if sf eq !*sqfree then list list sf else sqfree(sf,zlist)
  end;

symbolic procedure stt(u,x);
  if domainp u
    then if u eq nil
      then ((-1) . nil)
      else (0 . u)
    else if mvar u eq x
      then ldeg  u . lc u
      else if ordop(x,mvar u)
        then (0 . u)
        else begin
          scalar ltlc,ltrest;
          ltlc:=stt(lc u,x);
          ltrest:= stt(red u,x);
          if car ltlc = car ltrest then go to merge;
          if car ltlc > car ltrest
            then return car ltlc .
                             !*multf(cdr ltlc,(lpow u .* 1) .+ nil)
            else return ltrest;
        merge:
          return car ltlc.addf(cdr ltrest,
                               !*multf(cdr ltlc,(lpow u .* 1) .+ nil))
          end;

symbolic procedure mapply(funct,l);
   if null l then rerror(int,6,"Empty list to mapply")
    else if null cdr l then car l
    else apply2(funct,car l,mapply(funct,cdr l));

% symbolic procedure intersect(x,y);
%    if null x then nil else if member(car x,y) then
%     car(x) . intersect(cdr x,y) else
%          intersect(cdr x,y);

symbolic procedure mapvec(v,f);
   begin
      scalar n;
      n:=upbv v;
      for i:=0:n do apply1(f,getv(v,i))
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/driver.red0000644000175000017500000010110111526203062023257 0ustar  giovannigiovannimodule driver;  % Driving routines for integration program.

% Author: Mary Ann Moore and Arthur C. Norman.
% Modifications by: John P. Fitch, David Hartley, Francis J. Wright.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*algint
        !*backtrace
        !*exp
        % !*failhard
        !*gcd
        !*intflag!*
        !*keepsqrts
        !*limitedfactors
        !*mcd
        !*noncomp
        !*nolnr
        !*partialintdf
        !*precise
        !*purerisch
        !*rationalize
        !*structure
        !*trdint
        !*trint
        !*uncached
        basic!-listofnewsqrts
        basic!-listofallsqrts
        gaussiani
        intvar
        kord!*
        listofnewsqrts
        listofallsqrts
        loglist
        powlis!*
        sqrt!-intvar
        sqrt!-places!-alist
        subfg!*
        varlist
        varstack!*
        xlogs
        zlist);

global '(erfg!*);

exports integratesq,simpint,simpint1;

imports algebraiccase,algfnpl,findzvars,getvariables,interr,printsq,
  transcendentalcase,varsinlist,kernp,simpcar,prepsq,mksq,simp,
   opmtch,formlnr;

switch algint,nolnr,trdint,trint;
switch hyperbolic;

% Form is   int(expr,var,x1,x2,...);
% meaning is integrate expr wrt var, given that the result may
% contain logs of x1,x2,...
% x1, etc are intended for use when the system has to be helped
% in the case that expr is algebraic.
% Extended arguments x1, x2, etc., are not currently supported.

symbolic procedure simpint u;
   % Simplifies an integral.  First two components of U are the integrand
   % and integration variable respectively.  Optional succeeding
   % components are log forms for the final integral.
   if atom u or null cdr u or cddr u and (null cdddr u or cddddr u)
     then rerror(int,1,"Improper number of arguments to INT")
    else if cddr u then simpdint u
%    then if getd 'simpdint then simpdint u
%          else rerror(int,2,"Improper number of arguments to INT")
    else begin scalar ans,dmod,expression,variable,loglist,oldvarstack,
                 !*intflag!*,!*purerisch,cflag,intvar,listofnewsqrts,
                 listofallsqrts,sqrtfn,sqrt!-intvar,sqrt!-places!-alist,
                 basic!-listofallsqrts,basic!-listofnewsqrts,coefft,
                 varchange,w,!*precise;
    !*intflag!* := t;     % Shows we are in integrator.
    variable := !*a2k cadr u;
    if not(idp variable or pairp variable and numlistp cdr variable)
%     then typerr(variable,"integration variable");
      then <>;
    intvar := variable;   % Used in SIMPSQRT and algebraic integrator.
    w := cddr u;
    if w then rerror(int,3,"Too many arguments to INT");
    listofnewsqrts:= list mvar gaussiani; % Initialize for SIMPSQRT.
    listofallsqrts:= list (argof mvar gaussiani . gaussiani);
    sqrtfn := get('sqrt,'simpfn);
    put('sqrt,'simpfn,'proper!-simpsqrt);
    % We need explicit settings of several switches during integral
    % evaluation.  In addition, the current code cannot handle domains
    % like floating point, so we suppress it while the integral is
    % calculated.  UNCACHED is turned on since integrator does its own
    % caching.
    % Any changes made to these settings must also be made in wstrass.
    if dmode!* then
       << % added by Alan Barnes
          if (cflag:=get(dmode!*, 'cmpxfn)) then onoff('complex, nil);
          if (dmod := get(dmode!*,'dname)) then
             onoff(dmod,nil)>> where !*msg := nil;
    begin scalar dmode!*,!*exp,!*gcd,!*keepsqrts,!*limitedfactors,!*mcd,
                 !*rationalize,!*structure,!*uncached,kord!*,
                 ans1,badbit,denexp,erfg,nexp,oneterm;
       !*keepsqrts := !*limitedfactors := t;     % !*sqrt := t;
       !*exp := !*gcd := !*mcd := !*structure := !*uncached := t;
       dmode!* := nil;
       if !*algint
         then <<
            % The algint code now needs precise off.
%           !*precise := t;
            % Start a clean slate (in terms of SQRTSAVE) for this
            % integral.
            sqrt!-intvar:=!*q2f simpsqrti variable;
            if (red sqrt!-intvar) or (lc sqrt!-intvar neq 1)
                or (ldeg sqrt!-intvar neq 1)
              then interr "Sqrt(x) not properly formed"
              else sqrt!-intvar:=mvar sqrt!-intvar;
            basic!-listofallsqrts:=listofallsqrts;
            basic!-listofnewsqrts:=listofnewsqrts;
            sqrtsave(basic!-listofallsqrts,basic!-listofnewsqrts,
                         list(variable . variable))>>;
       coefft := (1 ./ 1);           % Collect simple coefficients.
       expression := int!-simp car u;
       if varchange
         then <>;
       denexp := 1 ./ denr expression;          % Get into two bits
       nexp := numr expression;
       while not atom nexp and null cdr nexp and
          not depends(mvar nexp,variable) do
              <>;
       ans1 := nil;
       while nexp do begin              % Collect by zvariables
           scalar x,zv,tmp;
           if atom nexp then <>
            else <>;
           x := multsq(x,denexp);
           zv := zvars(getvariables x,zv,variable,t);
           tmp := ans1;
           while tmp do
              <>
                 else tmp := cdr tmp>>;
           if zv then ans1 := (zv . x) . ans1
       end;
       if length ans1 = 1 then oneterm := t; % Efficiency
       nexp := ans1;
       ans := nil ./ 1;
       badbit:=nil ./ 1;                        % SQ zero
       while nexp do                            % Run down the terms
        <>;
          erfg := erfg!*;
          ans1 := errorset!*(list('integratesq,mkquote u,
                             mkquote variable,mkquote loglist,
                             mkquote caar nexp),
                             !*backtrace);
          erfg!* := erfg; % It can be turned on by errors in integratesq.
          nexp := cdr nexp;
          if errorp ans1 then badbit := addsq(badbit,u)
           else <>>>;
       if !*trdint
         then <>;
          if oneterm and ans = '(nil . 1) then ans1 := nil
            else ans1 := errorset!*(list('integratesq,mkquote badbit,
                                  mkquote variable,mkquote loglist,nil),
                                  !*backtrace);
          if null ans1 or errorp ans1
            then ans := addsq(ans,simpint1(badbit . variable . w))
           else <>>>;
    end;
    ans := multsq(coefft,ans); %Put back coefficient, preserving order.
%    if errorp ans
%      then return <>
%     else ans := car ans;
%   expression := sqrtchk numr ans ./ sqrtchk denr ans;
    if !*trdint then << printc "Resimp and all that"; printsq ans >>;
    % We now need to check that all simplifications have been done
    % but we have to make sure INT is not resimplified, and that SIMP
    % does not complain at getting the same argument again.
    put('int,'simpfn,'simpiden);
    put('sqrt,'simpfn,sqrtfn);
    << if dmod then onoff(dmod,t);
       % added by Alan Barnes
       if cflag then onoff('complex,t)>> where !*msg := nil;
    oldvarstack := varstack!*;
    varstack!* := nil;
%   ans := errorset!*(list('resimp,mkquote ans),t);
    ans := errorset!*(list('int!-resub,mkquote ans,mkquote
                           varchange),t);
    put('int,'simpfn,'simpint);
    varstack!* := oldvarstack;
    return if errorp ans then error1() else car ans
   end;

symbolic procedure int!-resub(x,v);
   % {sq,alist} -> sq
   % Undo any variable change and resimplify.
   if v then <>
    else resimp x;

symbolic procedure int!-subsq(x,v);
   % {sq,alist} -> sq
   % A version of subsq with the int and df operators unprotected.
   % Intended for straightforward change of variable names only.
   begin scalar subfuncs,subfg!*;
      subfuncs := {remprop('df,'subfunc),remprop('int,'subfunc)};
      x := subsq(x,v);
      put('df,'subfunc,car subfuncs);
      put('int,'subfunc,cadr subfuncs);
      return x
   end;

symbolic procedure numlistp u;
   % True if u is a list of numbers.
   null u or numberp car u and numlistp cdr u;

% symbolic procedure sqrtchk u;
%    % U is a standard form. Result is another standard form with square
%    % roots replaced by half powers.
%    if domainp u then u
%     else if not eqcar(mvar u,'sqrt)
%      then addf(multpf(lpow u,sqrtchk lc u),sqrtchk red u)
% %   else if mvar u = '(sqrt -1)
% %    then addf(multpf(mksp('i,ldeg u),sqrtchk lc u),sqrtchk red u)
%     else addf(multpf(mksp(list('expt,cadr mvar u,'(quotient 1 2)),
%                           ldeg u),
%                      sqrtchk lc u),
%               sqrtchk red u);

symbolic procedure int!-simp u;
   % Converts U to canonical form, including the resimplification of
   % *sq forms.
   subs2 resimp simp!* u;

put('int,'simpfn,'simpint);

symbolic procedure integratesq(integrand,var,xlogs,zv);
 begin scalar varlist,x,zlist,!*noncomp;
    if !*trint then <<
        printc "Start of Integration; integrand is ";
        printsq integrand >>;
    !*noncomp := noncomfp numr integrand
                    or noncomfp denr integrand;
    varlist:=getvariables integrand;
    varlist:=varsinlist(xlogs,varlist); %in case more exist in xlogs
    if zv then zlist := zv else zlist := zvars(varlist,zlist,var,nil);
    if !*trint  then <<
      printc "Determination of the differential field descriptor";
      printc "gives the functions:";
      print zlist >>;
%% Look for rational powers in the descriptor
%% If there is make a suitable transformation and do the sub integral
%% and return the revised integral
    x := look_for_substitute(integrand, var, zlist);
    if x then return x;
%% End of rational patch
    if !*purerisch and not allowedfns zlist
      then return (nil ./ 1) . integrand;
      % If it is not suitable for Risch.
    varlist := setdiff(varlist,zlist);
%   varlist := purge(zlist,varlist);
    % Now zlist is list of things that depend on x, and varlist is list
    % of constant kernels in integrand.
    if !*algint and cdr zlist and algfnpl(zlist,var)
      then return algebraiccase(integrand,zlist,varlist)
     else return transcendentalcase(integrand,var,xlogs,zlist,varlist)
 end;

symbolic procedure zvars(x,zv,variable,bool);
   % This code attempts to find all possible terms in the target
   % integral.
   % There used to be problems with nested exponentials or logs,
   % but that no longer seems true (10 May 00).
   begin scalar oldzlist; integer n;
      zv := findzvars(x,list variable,variable,nil);
   % The following loop is constrained to five passes to avoid problems
   % with differentiation rules such as let {df(f(~x),x) => x*f(x-1)}.
   % All integration tests run with just one pass through this loop, so
   % five passes is probably overkill.
      while oldzlist neq zv and n<5 do <<
           oldzlist := zv;
           foreach zz in oldzlist do
%          zv := findzvars(distexp(pseudodiff(zz,variable)),
%                          zv,variable,t);
           zv := findzvars(pseudodiff(zz,variable),zv,variable,t);
           n := n+1>>;
      % The following line is based on experiments with the test files.
      % At the moment, it's not clear why it's needed, but it is!!
      if bool then zv := sort(zv,function ordp);
      return zv
   end;

% symbolic procedure distexp(l);
%    if null l then nil
%    else if atom car l then car l . distexp cdr l
%    else if (caar l = 'expt) and (cadar l = 'e) then
%        begin scalar ll;
%            ll:=caddr car l;
%            if eqcar(ll,'plus) then <<
%                ll:=foreach x in cdr ll collect list('expt,'e,x);
%                return ('times . ll) . distexp cdr l >>
%            else return car l . distexp cdr l
%        end
%    else distexp car l . distexp cdr l;

symbolic procedure pseudodiff(a,var);
    if atom a then      % **** Treat diffs correctly??
        if depends(a,var) then list prepsq simpdf(list(a,var)) else nil
    else if car a
               memq '(atan equal log plus quotient sqrt times minus)
        then begin scalar aa,bb;
            foreach zz in cdr a do <<
                bb:=pseudodiff(zz,var);
                aa:= union(bb,aa) >>;
            return aa
        end
      else if car a eq 'expt
        then if depends(cadr a,var) then
            if depends(caddr a,var) then
                prepsq simp list('log,cadr a) . %% a(x)^b(x)
                cadr a .
                caddr a .
                union(pseudodiff(cadr a,var),pseudodiff(caddr a,var))
            else cadr a . pseudodiff(cadr a,var)        %% a(x)^b
        else caddr a . pseudodiff(caddr a,var)          %% a^b(x)
    else list prepsq simpdf(list(a,var));

symbolic procedure look_for_substitute(integrand, var, zz);
% Search for rational power transformations
begin
  scalar res;
  if atom zz then return nil
  else if (res := look_for_rational(integrand, var, zz)) then return res
  else if (res := look_for_quad(integrand, var, zz)) then return res
  else if (res := look_for_substitute(integrand, var, car zz))
   then return res
  else return look_for_substitute(integrand, var, cdr zz)
end;

symbolic procedure look_for_rational(integrand, var, zz);
% Look for a form x^(n/m) in the field descriptor, and transform
% the integral if it is found.  Note that the sqrt form may be used
% as well as exponentials.  Return nil if no transformation
  if (car zz = 'sqrt and cadr zz = var) then
        look_for_rational1(integrand, var, 2)
  else if (car zz = 'expt) and (cadr zz = var) and
     (listp caddr zz) and (caaddr zz = 'quotient) and
     (numberp cadr caddr zz) and (numberp caddr caddr zz) then
                look_for_rational1(integrand, var, caddr caddr zz)
  else nil;

symbolic procedure look_for_rational1(integrand, var, m);
% Actually do the transformation and integral
begin
        scalar newvar, res, ss, mn2m!-1;
        newvar := gensym();
        mn2m!-1 := !*f2q(((newvar .** (m-1)) .* m) .+ nil);
%%      print ("Integrand was " . integrand);
% x => y^m, and dx => m y^(m-1)
        integrand := multsq(subsq(integrand,
                                  list(var . list('expt,newvar,m))),
                            mn2m!-1);
        if !*trint then <<
            prin2 "Integrand is transformed to ";
            printsq integrand
        >>;
        begin scalar intvar;
            intvar := newvar;   % To circumvent an algint bug.
        res := integratesq(integrand, newvar, nil, nil);
        end;
        ss := list(newvar . list('expt,var, list('quotient, 1, m)));
        res := subsq(car res, ss) .
               subsq(quotsq(cdr res, mn2m!-1), ss);
        if !*trint then <<
            printc "Transforming back...";
            printsq car res;
            prin2 " plus a bad part of ";
            printsq cdr res
        >>;
        return res
 end;

symbolic procedure look_for_quad(integrand, var, zz);
% Look for a form sqrt(a+bx+cx^2) in the field descriptor
% and transform to the appropriate asin, acosh or asinh.
% Return nil if no transformation found
 % if !*algint then nil % Algint doesn't do better ...
 % else begin
 begin
  if (car zz = 'sqrt and listp cadr zz and caadr zz = 'plus) or
     (car zz = 'expt and listp cadr zz and caadr zz = 'plus and
      listp caddr zz and car caddr zz = 'quotient
         and fixp caddr caddr zz)
   then <<
    zz := simp cadr zz;
    if (cdr zz = 1) then <<
        zz := cdr coeff1(prepsq zz, var, nil);
        if length zz = 2 then return begin      % Linear
          scalar a, b;
          scalar nvar, res, ss;
          a := car zz; b := cadr zz;
          if (depends(a,var) or depends(b,var)) then return nil;
          nvar := gensym();
          if !*trint then <<
                prin2 "Linear shift suggested ";
                prin2 a; prin2 " "; prin2 b; terpri();
          >>;
          integrand := subsq(integrand,         % Make the substitution
                             list(var . list('quotient,
                                             list('difference,
                                                  list('expt,nvar,2),a),
                                                  b)));
          integrand := multsq(integrand,        % and the dx component
                              simp list('quotient,list('times,nvar,2),
                                        b));
%         integrand := subsq(integrand,
%                             list(var . list('difference, nvar, a)));
%         integrand := multsq(integrand, simp b);
          if !*trint then <<
                prin2 "Integrand is transformed by substitution to ";
                printsq integrand;
                prin2 "using substitution "; prin2 var; prin2 " -> ";
                printsq simp list('quotient,
                                 list('difference,list('expt,nvar,2),a),
                                 b);
           >>;
           res := integratesq(integrand, nvar, nil, nil);
           ss := list(nvar . list('sqrt,list('plus,list('times,var,b),
                                  a)));
           res := subsq(car res, ss) .
                  subsq(multsq(cdr res, simp list('quotient,b,
                                                  list('times,nvar,2))), ss);
        %% Should one reject if there is a bad bit??
           return res;
        end
        else if length zz = 3 then return begin % A quadratic
          scalar a, b, c;
          a := car zz; b := cadr zz; c:= caddr zz;
          if (depends(a,var) or depends(b,var) or depends(c,var)) then
                return nil;
          % Used to be simp, but powers can occur.
          a := simp!* list('difference, a,        % Re-centre
                         list('times,b,b,
                         list('quotient,1,list('times,4,c))));
          if null numr a then return nil;   % Power occurred.
          b := simp list('quotient, b, list('times, 2, c));
          c := simp c;
          return
           if minusf numr c then <<
           if minusf numr a then  begin
                            scalar !*hyperbolic;
                            !*hyperbolic := t;
                            return
                                look_for_invhyp(integrand,nil,var,a,b,c)
                        end
            else                look_for_asin(integrand,var,a,b,c)>>
          else <<
            if minusf numr a then look_for_invhyp(integrand,t,var,a,b,c)
          else                  look_for_invhyp(integrand,nil,var,a,b,c)
          >>
        end
        else if length zz = 5 then return begin % A quartic
          scalar a, b, c, d, e, nn, dd, mm;
          a := car zz; b := cadr zz; c:= caddr zz;
          d := cadddr zz; e := car cddddr zz;
          if not(b = 0) or not(d = 0) then return nil;
          if (depends(a,var) or depends(c,var)) or depends(e,var) then
                return nil;
          nn := numr integrand;  dd := denr integrand;
          if denr(mm :=quotsq(nn ./ 1, !*kk2q var)) = 1 and
             even_power(numr mm, var) and even_power(dd, var) then <<
        % substitute x -> sqrt(y)
              return sqrt_substitute(numr mm, dd, var);
          >>;
          if denr(mm :=quotsq(dd ./ 1, !*kk2q var)) = 1 and
             even_power(nn, var) and even_power(numr mm, var) then <<
        % substitute x -> sqrt(y)
              return sqrt_substitute(nn, multf(dd,!*kk2f var), var);
          >>;
          return nil;
        end;
  >>>>;
  return nil;
end;

symbolic procedure look_for_asin(integrand, var, a, b, c);
% Actually do the transformation and integral
begin
    scalar newvar, res, ss, sqmn, onemth, m, n;
    m := prepsq a;
    n := prepsq c;
    b := prepsq b;
    newvar := gensym();
    sqmn := prepsq apply1(get('sqrt, 'simpfn),
                          list list('quotient, list('minus,n), m));
    onemth := list('cos, newvar);
    ss := list('sin, newvar);
    powlis!* := list(ss, 2, '(nil . t),
                     list('difference,1,list('expt,onemth,2)),
                     nil) .
                powlis!*;
    integrand := subs2q
        multsq(subsq(integrand,
                     list(var . list('difference,
                                     list('quotient,ss,sqmn), b))),
               quotsq(onemth := simp onemth, simp sqmn));
    if !*trint then <<
        prin2 "Integrand is transformed by substitution to ";
        printsq integrand;
        prin2 "using substitution "; prin2 var; prin2 " -> ";
        printsq simp list('difference, list('quotient, ss, sqmn), b);
    >>;
    res := integratesq(integrand, newvar, nil, nil);
    powlis!* := cdr powlis!*;
    ss:= list(newvar . list('asin,list('times,list('plus,var,b),sqmn)));
    res := subsq(car res, ss) . subsq(quotsq(cdr res, onemth), ss);
    if !*trint then <<
        printc "Transforming back...";
        printsq car res;
        prin2 " plus a bad part of ";
        printsq cdr res
    >>;
    if (car res = '(nil . 1)) then return nil;
    return res;
 end;

symbolic procedure look_for_invhyp(integrand, do_acosh, var, a, b, c);
% Actually do the transformation and integral; uses acosh/asinh form
% depending on second argument
begin
    scalar newvar, res, ss, sqmn, onemth, m, n, realdom;
    m := prepsq a;
    n := prepsq c;
    b := prepsq b;
    newvar := gensym();
    if do_acosh then <<
      sqmn := prepsq apply1(get('sqrt, 'simpfn),
                            list list('quotient, n, list('minus, m)));
      onemth := list('sinh, newvar);
      ss := list('cosh, newvar)
    >>
    else <<
      sqmn:= prepsq apply1(get('sqrt,'simpfn),list list('quotient,n,m));
      onemth := list('cosh, newvar);
      ss := list('sinh, newvar)
    >>;
    powlis!* := list(ss, 2, '(nil . t),
                     list((if do_acosh then 'plus else 'difference),
                          list('expt, onemth, 2),1),
                     nil) .
                powlis!*;
%   print ("sqmn" . sqmn); print("onemth" . onemth); print ("ss" . ss);
%   print cdddar powlis!*;
    integrand := subs2q
        multsq(subsq(integrand,
               list(var . list('difference,list('quotient,ss,sqmn),b))),
               quotsq(onemth := simp onemth, simp sqmn));
    if !*trint then <<
        prin2 "Integrand is transformed by substitution to ";
        printsq integrand;
        prin2 "using substitution "; prin2 var; prin2 " -> ";
        printsq simp list('difference, list('quotient, ss, sqmn), b);
    >>;
    realdom := not smember('(sqrt -1),integrand);
%   print integrand; print realdom;
    res := integratesq(integrand, newvar, nil, nil);
    powlis!* := cdr powlis!*;
    if !*hyperbolic then <<
      ss := list(if do_acosh then 'acosh else 'asinh,
                 list('times,list('plus,var,b), sqmn));
    >>
    else <<
      ss := list('times,list('plus,var,b), sqmn);
      ss := if do_acosh then
        subst(ss,'ss,
              '(log (plus ss (sqrt (difference (times ss ss) 1)))))
      else
        subst(ss,'ss,'(log (plus ss (sqrt (plus (times ss ss) 1)))))
    >>;
    ss := list(newvar . ss);
    res := sqrt2top subsq(car res, ss) .
           sqrt2top subsq(quotsq(cdr res, onemth), ss);
    if !*trint then <<
        printc "Transforming back...";
        printsq car res;
        prin2 " plus a bad part of ";
        printsq cdr res
    >>;
    if (car res = '(nil . 1)) then return nil;
    if realdom and smember('(sqrt -1),res) then <<
        if !*trint then print "Wrong sheet"; return nil;  % Wrong sheet?
    >>;
    return res
end;

symbolic procedure simpint1 u;
   % Varstack* rebound, since FORMLNR use can create recursive
   % evaluations.  (E.g., with int(cos(x)/x**2,x)).
   begin scalar !*keepsqrts,v,varstack!*;
      u := 'int . prepsq car u . cdr u;
      if (v := formlnr u) neq u
        then if !*nolnr
               then <>
              else <>;
      return if (v := opmtch u) then simp v
      else symint u                     % FJW: symbolic integral
   end;

mkop 'int!*;

put('int!*,'simpfn,'simpint!*);

symbolic procedure simpint!* u;
   begin scalar x;
      return if (x := opmtch('int . u)) then simp x
              else simpiden('int!* . u)
   end;

symbolic procedure remakesf u;
   %remakes standard form U, substituting operator INT for INT!*;
   if domainp u then u
    else addf(multpf(if eqcar(mvar u,'int!*)
                       then mksp('int . cdr mvar u,ldeg u)
                      else lpow u,remakesf lc u),
               remakesf red u);

symbolic procedure allowedfns u;
   if null u then t
     else if atom car u then (car u=intvar) or not depends(car u,intvar)
     else if (caar u = 'expt and not (cadar u = 'e)
        and not depends(cadar u, intvar)
        and depends(caddar u, intvar)) then nil
     else if flagp(caar u,'transcendental) then allowedfns cdr u
    else nil;

symbolic procedure look_for_power(integrand, var);
begin
    scalar nn, dd, mm;
    nn := numr integrand;  dd := denr integrand;
    if denr(mm :=quotsq(nn ./ 1, !*kk2q var)) = 1 and
       even_power(numr mm, var) and even_power(dd, var) then <<
        % substitute x -> sqrt(y)
        return sqrt_substitute(numr mm, dd, var);
    >>;
    if denr(mm :=quotsq(dd ./ 1, !*kk2q var)) = 1 and
       even_power(nn, var) and even_power(numr mm, var) then <<
        % substitute x -> sqrt(y)
        return sqrt_substitute(nn, numr mm, var);
    >>;
    return nil;
end;

symbolic procedure even_power(xpr, var);
  if atom xpr then t
  else if mvar xpr = var then <<
    if evenp pdeg lpow xpr then even_power(lc xpr, var) and
                                even_power(red xpr, var)
    else nil >>
  else if eqcar(mvar xpr, 'expt) and
          cadr mvar xpr = var and
          evenp caddr mvar xpr then t
  else if atom mvar xpr then
          even_power(lc xpr, var) and even_power(red xpr, var)
  else if even_power(red xpr, var) and even_power(lc xpr, var) then
        even_prep(mvar xpr, var);

symbolic procedure even_prep(xpr,var);
if xpr = var then nil
else if atom xpr then t
else if eqcar(xpr, 'expt) and cadr xpr = var and evenp caddr xpr then t
else if even_prep(car xpr, var) then even_prep(cdr xpr, var);


symbolic procedure sqrt_substitute(nn, dd, var);
begin
    scalar newvar, integrand, res, ss, !*keepsqrts;
    newvar := gensym();
    integrand := subst(list('sqrt,newvar), var,
                       list('quotient, prepsq (nn ./ dd), 2));
    integrand := prepsq simp integrand;
    integrand := simp integrand;
    begin scalar intvar;
        intvar := newvar;   % To circumvent an algint bug/oddity
        res := integratesq(integrand, newvar, nil, nil);
    end;
    ss := list(newvar . list('expt, var, 2));
    res := subsq(car res, ss) . multsq((((var .^ 1) .* 2) .+ nil) ./ 1,
                                       subsq(cdr res, ss));
    if !*trint then <<
        printc "Transforming back...";
        printsq car res;
        prin2 " plus a bad part of ";
        printsq cdr res
    >>;
    return res
end;

% The following rules probably belong in other places.

%-----------------------------------------------------------------------
algebraic;

operator ci,si;  % ei.
% FJW: ci,si also defined in specfn(sfint.red), so ...
symbolic((algebraic operator ci,si) where !*msg=nil);

intrules :=
  {e^(~n*acosh(~x)) => (sqrt(x^2-1)+x)^n when numberp n,
   e^(~n*asinh(~x)) => (sqrt(x^2+1)+x)^n when numberp n,
   e^(acosh(~x)) => (sqrt(x^2-1)+x),
   e^(asinh(~x)) => (sqrt(x^2+1)+x),
   cosh(log(~x)) => (x^2+1)/(2*x),
   sinh(log(~x)) => (x^2-1)/(2*x),
   % These next two are rather uncertain.
   int(log(~x)/(~b-x),x) => dilog(x/b),
   int(log(~x)/(~b*x-x^2),x) => dilog(x/b)/b + log(x)^2/(2b),

%% FJW: Next 2 rules replaced by ~~ rules below
%% int(e^(~x^2),x) => erf(i*x)*sqrt(pi)/(2i),
%% int(1/e^(~x^2),x) => erf(x) * sqrt(pi)/2,
%% FJW: Missing sqrt(b):
%% int(e^(~b*~x^2),x) => erf(i*x)*sqrt(pi)/(2i*sqrt(b)),
   int(e^(~~b*~x^2),x) => erf(i*sqrt(b)*x)*sqrt(pi)/(2i*sqrt(b)),
%% FJW: Rule missing:
   int(e^(~x^2/~b),x) => erf(i*x/sqrt(b))*sqrt(pi)*sqrt(b)/(2i),
%% FJW: Missing sqrt(b):
%% int(1/e^(~b*~x^2),x) => erf(x)*sqrt(pi)/(2sqrt(b)),
   int(1/e^(~~b*~x^2),x) => erf(sqrt(b)*x)*sqrt(pi)/(2sqrt(b)),
%% FJW: Rule missing:
   int(1/e^(~x^2/~b),x) => erf(x/sqrt(b))*sqrt(pi)*sqrt(b)/2,

   df(ei(~x),x) => exp(x)/x,
   int(e^(~~b*~x)/x,x) => ei(b*x),      % FJW
   int(e^(~x/~b)/x,x) => ei(x/b),
   int(1/(exp(~x*~~b)*x),x) => ei(-x*b), % FJW
   int(1/(exp(~x/~b)*x),x) => ei(-x/b),
%% FJW: Next 2 rules replaced by ~~ rules above
%% int(e^~x/x,x) => ei(x),
%% int(1/(e^~x*x),x) => ei(-x),
   int(~a^~x/x,x) => ei(x*log(a)),
   int(1/((~a^~x)*x),x) => ei(-x*log(a)),
   df(si(~x),x) => sin(x)/x,
   int(sin(~~b*~x)/x,x) => si(b*x),     % FJW
   int(sin(~x/~b)/x,x) => si(x/b),      % FJW
%% int(sin(~x)/x,x) => si(x),           % FJW
   int(sin(~x)/x^2,x) => -sin(x)/x +ci(x),
   int(sin(~x)^2/x,x) =>(log(x)-ci(2x))/2,
   df(ci(~x),x) => cos(x)/x,
   int(cos(~~b*~x)/x,x) => ci(b*x),     % FJW
   int(cos(~x/~b)/x,x) => ci(x/b),      % FJW
%% int(cos(~x)/x,x) => ci(x),           % FJW
   int(cos(~x)/x^2,x) => -cos(x)/x -si(x),
   int(cos(~x)^2/x,x) =>(log(x)+ci(2x)/2),
   int(1/log(~~b*~x),x) => ei(log(b*x))/b, % FJW
   int(1/log(~x/~b),x) => ei(log(x/b))*b, % FJW
%% int(1/log(~x),x) => ei(log(x)),      % FJW
%% int(1/log(~x+~b),x) => ei(log(x+b)), % FJW
   int(1/log(~~a*~x+~b),x) => ei(log(a*x+b))/b, % FJW
   int(1/log(~x/~a+~b),x) => ei(log(x/a+b))/b, % FJW
   int(~x/log(~x),x) => ei(2*log(x)),
   int(~x^~n/log(x),x) => ei((n+1)*log(x)) when fixp n,
   int(1/(~x^~n*log(x)),x) => ei((-n+1)*log(x)) when fixp n};

let intrules;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/int/int.rlg0000644000175000017500000021666311527635055022630 0ustar  giovannigiovanniFri Feb 18 21:27:13 2011 run on win32
COMMENT

                 THE REDUCE INTEGRATION TEST PACKAGE

                              Edited By

                           Anthony C. Hearn
			 The RAND Corporation


This file is designed to provide a set of representative tests of the
Reduce integration package.  Not all examples go through, even when an
integral exists, since some of the arguments are outside the domain of
applicability of the current package.  However, future improvements to
the package will result in more closed-form evaluations in later
releases.  We would appreciate any additional contributions to this test
file either because they illustrate some feature (good or bad) of the
current package, or suggest domains which future versions should handle.
Any suggestions for improved organization of this test file (e.g., in a
way which corresponds more directly to the organization of a standard
integration table book such as Gradshteyn and Ryznik) are welcome.

Acknowledgments:

The examples in this file have been contributed by the following.
Any omissions to this list should be reported to the Editor.

David M. Dahm
James H. Davenport
John P. Fitch
Steven Harrington
Anthony C. Hearn
K. Siegfried Koelbig
Ernst Krupnikov
Arthur C. Norman
Herbert Stoyan
;


Comment we first set up a suitable testing functions;


fluid '(gcknt!*);



global '(faillist!* gcnumber!* inittime number!-of!-integrals
         unintlist!*);



symbolic operator time;



symbolic procedure initialize!-integral!-test;
   begin
      faillist!* := unintlist!* := nil;
      number!-of!-integrals := 0;
      gcnumber!* := gcknt!*;
      inittime := time()
   end;


initialize!-integral!-test
   

symbolic procedure summarize!-integral!-test;
   begin scalar totaltime;
      totaltime := time()-inittime;
      prin2t 
   "                *****     SUMMARY OF INTEGRAL TESTS     *****";
      terpri();
      prin2 "Number of integrals tested: ";
      prin2t number!-of!-integrals;
      terpri();
      prin2 "Total time taken: ";
      prin2 totaltime;
      prin2t " ms";
      terpri();
      if gcnumber!*
        then <>;
      prin2 "Number of incorrect integrals: ";
            prin2t length faillist!*;
      terpri();
      prin2 "Number of unevaluated integrals: ";
      prin2t length unintlist!*;
      terpri();
      if faillist!* 
        then <>;
      if unintlist!*
        then <>
   end;


summarize!-integral!-test


procedure testint(a,b);
  begin scalar der,diffce,res,tt;
      tt:=time();
      symbolic (number!-of!-integrals := number!-of!-integrals + 1);
      res:=int(a,b);
%     write "time for integral:  ",time()-tt," ms";
      off precise;
      der := df(res,b);
      diffce := der-a;
      if diffce neq 0
	then  begin for all x let cot x=cos x/sin x,
				  sec x=1/cos x,
				  sin x**2=1-cos x**2,
				  tan(x/2)=sin x/(1+cos x),
				  tan x=sin x/cos x,
		    		  tanh x=
				     (e**(x)-e**(-x))/(e**x+e**(-x)),
				  coth x= 1/tanh x;
	       	    diffce := diffce;
		    for all x clear cot x,sec x,sin x**2,tan x,tan(x/2),
				    tanh x,coth x
	      end;
	%hopefully, difference appeared non-zero due to absence of
	%above transformations;
      if diffce neq 0
	then <>;
      if diffce neq 0
	then begin scalar !*reduced;
		symbolic(!*reduced := t);
		for all x let cos(2x)= 1-2sin x**2, sin x**2=1-cos x**2;
		diffce := diffce;
	       for all x clear cos(2x),sin x**2
	     end;
      if diffce neq 0
	then <>;
               symbolic if smemq('int,res)
                    then unintlist!* := list(a,b,res) . unintlist!*;
      on precise;
      return res
  end;


testint


symbolic initialize!-integral!-test();



% References are to Gradshteyn and Ryznik.

testint(1+x+x**2,x);


       2
 x*(2*x  + 3*x + 6)
--------------------
         6

testint(x**2*(2*x**2+x)**2,x);


  5      2
 x *(60*x  + 70*x + 21)
------------------------
          105

testint(x*(x**2+2*x+1),x);


  2     2
 x *(3*x  + 8*x + 6)
---------------------
         12

testint(1/x,x);


log(x)
  % 2.01 #2;
testint((x+1)**3/(x-1)**4,x);


               3                 2                                      3
 3*log(x - 1)*x  - 9*log(x - 1)*x  + 9*log(x - 1)*x - 3*log(x - 1) - 6*x  - 2
------------------------------------------------------------------------------
                               3      2
                           3*(x  - 3*x  + 3*x - 1)

testint(1/(x*(x-1)*(x+1)**2),x);


(log(x - 1)*x + log(x - 1) + 3*log(x + 1)*x + 3*log(x + 1) - 4*log(x)*x

  - 4*log(x) + 2*x)/(4*(x + 1))

testint((a*x+b)/((x-p)*(x-q)),x);


 log(p - x)*a*p + log(p - x)*b - log(q - x)*a*q - log(q - x)*b
---------------------------------------------------------------
                             p - q

testint(1/(a*x**2+b*x+c),x);


                 2           2*a*x + b
 2*sqrt(4*a*c - b )*atan(------------------)
                                        2
                          sqrt(4*a*c - b )
---------------------------------------------
                          2
                 4*a*c - b

testint((a*x+b)/(1+x**2),x);


                    2
 2*atan(x)*b + log(x  + 1)*a
-----------------------------
              2

testint(1/(x**2-2*x+3),x);


                x - 1
 sqrt(2)*atan(---------)
               sqrt(2)
-------------------------
            2


% Rational function examples from Hardy, Pure Mathematics, p 253 et seq.

testint(1/((x-1)*(x**2+1))**2,x);


          3            2                              2       3        2       2
(atan(x)*x  - atan(x)*x  + atan(x)*x - atan(x) + log(x  + 1)*x  - log(x  + 1)*x

         2               2                      3                 2
  + log(x  + 1)*x - log(x  + 1) - 2*log(x - 1)*x  + 2*log(x - 1)*x

                                     3                 3    2
  - 2*log(x - 1)*x + 2*log(x - 1) - x  - 2*x + 1)/(4*(x  - x  + x - 1))

testint(x/((x-a)*(x-b)*(x-c)),x);


(log(a - x)*a*b - log(a - x)*a*c - log(b - x)*a*b + log(b - x)*b*c

                                       2      2        2      2    2        2
  + log(c - x)*a*c - log(c - x)*b*c)/(a *b - a *c - a*b  + a*c  + b *c - b*c )

testint(x/((x**2+a**2)*(x**2+b**2)),x);


         2    2         2    2
  - log(a  + x ) + log(b  + x )
--------------------------------
              2    2
          2*(a  - b )

testint(x**2/((x**2+a**2)*(x**2+b**2)),x);


       x             x
 atan(---)*a - atan(---)*b
       a             b
---------------------------
           2    2
          a  - b

testint(x/((x-1)*(x**2+1)),x);


                  2
 2*atan(x) - log(x  + 1) + 2*log(x - 1)
----------------------------------------
                   4

testint(x/(1+x**3),x);


                 2*x - 1          2
 2*sqrt(3)*atan(---------) + log(x  - x + 1) - 2*log(x + 1)
                 sqrt(3)
------------------------------------------------------------
                             6

testint(x**3/((x-1)**2*(x**3+1)),x);


           2                     2
( - 4*log(x  - x + 1)*x + 4*log(x  - x + 1) + 9*log(x - 1)*x - 9*log(x - 1)

  - log(x + 1)*x + log(x + 1) - 6*x)/(12*(x - 1))

testint(1/(1+x**4),x);


                     sqrt(2) - 2*x             sqrt(2) + 2*x
(sqrt(2)*( - 2*atan(---------------) + 2*atan(---------------)
                        sqrt(2)                   sqrt(2)

                                 2                         2
           - log( - sqrt(2)*x + x  + 1) + log(sqrt(2)*x + x  + 1)))/8

testint(x**2/(1+x**4),x);


                     sqrt(2) - 2*x             sqrt(2) + 2*x
(sqrt(2)*( - 2*atan(---------------) + 2*atan(---------------)
                        sqrt(2)                   sqrt(2)

                                 2                         2
           + log( - sqrt(2)*x + x  + 1) - log(sqrt(2)*x + x  + 1)))/8

testint(1/(1+x**2+x**4),x);


                 2*x - 1                     2*x + 1            2
(2*sqrt(3)*atan(---------) + 2*sqrt(3)*atan(---------) - 3*log(x  - x + 1)
                 sqrt(3)                     sqrt(3)

           2
  + 3*log(x  + x + 1))/12


% Examples involving a+b*x.

z := a+b*x;


z := a + b*x


testint(z**p,x);


          p
 (a + b*x) *(a + b*x)
----------------------
      b*(p + 1)

testint(x*z**p,x);


          p      2              2    2    2  2
 (a + b*x) *( - a  + a*b*p*x + b *p*x  + b *x )
------------------------------------------------
                2   2
               b *(p  + 3*p + 2)

testint(x**2*z**p,x);


          p
((a + b*x)

      3      2            2  2  2      2    2    3  2  3      3    3      3  3
 *(2*a  - 2*a *b*p*x + a*b *p *x  + a*b *p*x  + b *p *x  + 3*b *p*x  + 2*b *x ))

   3   3      2
/(b *(p  + 6*p  + 11*p + 6))

testint(1/z,x);


 log(a + b*x)
--------------
      b

testint(1/z**2,x);


      x
-------------
 a*(a + b*x)

testint(x/z,x);


  - log(a + b*x)*a + b*x
-------------------------
            2
           b

testint(x**2/z,x);


                 2              2  2
 2*log(a + b*x)*a  - 2*a*b*x + b *x
-------------------------------------
                   3
                2*b

testint(1/(x*z),x);


  - log(a + b*x) + log(x)
--------------------------
            a

testint(1/(x**2*z),x);


 log(a + b*x)*b*x - log(x)*b*x - a
-----------------------------------
                2
               a *x

testint(1/(x*z)**2,x);


                                        2  2                              2  2
(2*log(a + b*x)*a*b*x + 2*log(a + b*x)*b *x  - 2*log(x)*a*b*x - 2*log(x)*b *x

     2      2  2    3
  - a  + 2*b *x )/(a *x*(a + b*x))

testint(1/(c**2+x**2),x);


       x
 atan(---)
       c
-----------
     c

testint(1/(c**2-x**2),x);


 log( - c - x) - log(c - x)
----------------------------
            2*c


% More complicated rational function examples, mostly contributed
% by David M. Dahm, who also developed the code to integrate them.

testint(1/(2*x**3-1),x);


                             1/3
  2/3                     2*2   *x + 1          2/3  2    1/3
(2   *( - 2*sqrt(3)*atan(--------------) - log(2   *x  + 2   *x + 1)
                            sqrt(3)

                 1/3
        + 2*log(2   *x - 1)))/12

testint(1/(x**3-2),x);


                            1/3
  1/3                      2    + 2*x           2/3    1/3      2
(2   *( - 2*sqrt(3)*atan(--------------) - log(2    + 2   *x + x )
                           1/3
                          2   *sqrt(3)

                    1/3
        + 2*log( - 2    + x)))/12

testint(1/(a*x**3-b),x);


                             1/3      1/3
  1/3                     2*a   *x + b             2/3  2    1/3  1/3      2/3
(b   *( - 2*sqrt(3)*atan(-----------------) - log(a   *x  + b   *a   *x + b   )
                            1/3
                           b   *sqrt(3)

                 1/3      1/3        1/3
        + 2*log(a   *x - b   )))/(6*a   *b)

testint(1/(x**4-2),x);


  1/4              x            1/4                1/4
 2   *( - 2*atan(------) - log(2    + x) + log( - 2    + x))
                   1/4
                  2
-------------------------------------------------------------
                              8

testint(1/(5*x**4-1),x);


          1/4             sqrt(5)*x          1/4               1/4
 sqrt(5)*5   *( - 2*atan(-----------) + log(5   *x - 1) - log(5   *x + 1))
                             1/4
                            5
---------------------------------------------------------------------------
                                    20

testint(1/(3*x**4+7),x);


                                     1/4
           1/4             sqrt(2)*21    - 2*sqrt(3)*x
(sqrt(6)*21   *( - 2*atan(-----------------------------)
                                            1/4
                                  sqrt(2)*21

                                     1/4
                           sqrt(2)*21    + 2*sqrt(3)*x
                 + 2*atan(-----------------------------)
                                            1/4
                                  sqrt(2)*21

                                    1/4                        2
                 - log( - sqrt(2)*21   *x + sqrt(7) + sqrt(3)*x )

                                 1/4                        2
                 + log(sqrt(2)*21   *x + sqrt(7) + sqrt(3)*x )))/168

testint(1/(x**4+3*x**2-1),x);


                                                         2*x
(sqrt(2)*(6*sqrt(sqrt(13) + 3)*sqrt(13)*atan(----------------------------)
                                              sqrt(sqrt(13) + 3)*sqrt(2)

                                                    2*x
           - 26*sqrt(sqrt(13) + 3)*atan(----------------------------) + 3
                                         sqrt(sqrt(13) + 3)*sqrt(2)

          *sqrt(sqrt(13) - 3)*sqrt(13)*log( - sqrt(sqrt(13) - 3) + sqrt(2)*x)

           - 3*sqrt(sqrt(13) - 3)*sqrt(13)*log(sqrt(sqrt(13) - 3) + sqrt(2)*x)

           + 13*sqrt(sqrt(13) - 3)*log( - sqrt(sqrt(13) - 3) + sqrt(2)*x)

           - 13*sqrt(sqrt(13) - 3)*log(sqrt(sqrt(13) - 3) + sqrt(2)*x)))/104

testint(1/(x**4-3*x**2-1),x);


                                                            2*x
(sqrt(2)*( - 6*sqrt(sqrt(13) - 3)*sqrt(13)*atan(----------------------------)
                                                 sqrt(sqrt(13) - 3)*sqrt(2)

                                                    2*x
           - 26*sqrt(sqrt(13) - 3)*atan(----------------------------) - 3
                                         sqrt(sqrt(13) - 3)*sqrt(2)

          *sqrt(sqrt(13) + 3)*sqrt(13)*log( - sqrt(sqrt(13) + 3) + sqrt(2)*x)

           + 3*sqrt(sqrt(13) + 3)*sqrt(13)*log(sqrt(sqrt(13) + 3) + sqrt(2)*x)

           + 13*sqrt(sqrt(13) + 3)*log( - sqrt(sqrt(13) + 3) + sqrt(2)*x)

           - 13*sqrt(sqrt(13) + 3)*log(sqrt(sqrt(13) + 3) + sqrt(2)*x)))/104

testint(1/(x**4-3*x**2+1),x);


( - sqrt(5)*log( - sqrt(5) + 2*x - 1) - sqrt(5)*log( - sqrt(5) + 2*x + 1)

  + sqrt(5)*log(sqrt(5) + 2*x - 1) + sqrt(5)*log(sqrt(5) + 2*x + 1)

  + 5*log( - sqrt(5) + 2*x - 1) - 5*log( - sqrt(5) + 2*x + 1)

  + 5*log(sqrt(5) + 2*x - 1) - 5*log(sqrt(5) + 2*x + 1))/20

testint(1/(x**4-4*x**2+1),x);


                                  2*x                            2*x
(sqrt(2)*(2*sqrt(3)*atanh(-------------------) + 6*atanh(-------------------)
                           sqrt(6) - sqrt(2)              sqrt(6) - sqrt(2)

                           - sqrt(6) - sqrt(2) + 2*x
           - sqrt(3)*log(----------------------------)
                                      2

                          sqrt(6) + sqrt(2) + 2*x
           + sqrt(3)*log(-------------------------)
                                     2

                     - sqrt(6) - sqrt(2) + 2*x
           + 3*log(----------------------------)
                                2

                    sqrt(6) + sqrt(2) + 2*x
           - 3*log(-------------------------)))/24
                               2

testint(1/(x**4+4*x**2+1),x);


                                 2*x                           2*x
(sqrt(2)*(2*sqrt(3)*atan(-------------------) - 6*atan(-------------------)
                          sqrt(6) + sqrt(2)             sqrt(6) + sqrt(2)

                           - sqrt(6)*i + sqrt(2)*i + 2*x
           - sqrt(3)*log(--------------------------------)*i
                                        2

                          sqrt(6)*i - sqrt(2)*i + 2*x
           + sqrt(3)*log(-----------------------------)*i
                                       2

                     - sqrt(6)*i + sqrt(2)*i + 2*x
           - 3*log(--------------------------------)*i
                                  2

                    sqrt(6)*i - sqrt(2)*i + 2*x
           + 3*log(-----------------------------)*i))/24
                                 2

testint(1/(x**4+x**2+2),x);


                                     sqrt(2*sqrt(2) - 1) - 2*x
(2*sqrt(2*sqrt(2) + 1)*sqrt(2)*atan(---------------------------)
                                        sqrt(2*sqrt(2) + 1)

                                sqrt(2*sqrt(2) - 1) - 2*x
  - 8*sqrt(2*sqrt(2) + 1)*atan(---------------------------)
                                   sqrt(2*sqrt(2) + 1)

                                        sqrt(2*sqrt(2) - 1) + 2*x
  - 2*sqrt(2*sqrt(2) + 1)*sqrt(2)*atan(---------------------------)
                                           sqrt(2*sqrt(2) + 1)

                                sqrt(2*sqrt(2) - 1) + 2*x
  + 8*sqrt(2*sqrt(2) + 1)*atan(---------------------------)
                                   sqrt(2*sqrt(2) + 1)

                                                                          2
  - sqrt(2*sqrt(2) - 1)*sqrt(2)*log( - sqrt(2*sqrt(2) - 1)*x + sqrt(2) + x )

                                                                       2
  + sqrt(2*sqrt(2) - 1)*sqrt(2)*log(sqrt(2*sqrt(2) - 1)*x + sqrt(2) + x )

                                                                    2
  - 4*sqrt(2*sqrt(2) - 1)*log( - sqrt(2*sqrt(2) - 1)*x + sqrt(2) + x )

                                                                 2
  + 4*sqrt(2*sqrt(2) - 1)*log(sqrt(2*sqrt(2) - 1)*x + sqrt(2) + x ))/56

testint(1/(x**4-x**2+2),x);


                                        sqrt(2*sqrt(2) + 1) - 2*x
( - 2*sqrt(2*sqrt(2) - 1)*sqrt(2)*atan(---------------------------)
                                           sqrt(2*sqrt(2) - 1)

                                sqrt(2*sqrt(2) + 1) - 2*x
  - 8*sqrt(2*sqrt(2) - 1)*atan(---------------------------)
                                   sqrt(2*sqrt(2) - 1)

                                        sqrt(2*sqrt(2) + 1) + 2*x
  + 2*sqrt(2*sqrt(2) - 1)*sqrt(2)*atan(---------------------------)
                                           sqrt(2*sqrt(2) - 1)

                                sqrt(2*sqrt(2) + 1) + 2*x
  + 8*sqrt(2*sqrt(2) - 1)*atan(---------------------------)
                                   sqrt(2*sqrt(2) - 1)

                                                                          2
  + sqrt(2*sqrt(2) + 1)*sqrt(2)*log( - sqrt(2*sqrt(2) + 1)*x + sqrt(2) + x )

                                                                       2
  - sqrt(2*sqrt(2) + 1)*sqrt(2)*log(sqrt(2*sqrt(2) + 1)*x + sqrt(2) + x )

                                                                    2
  - 4*sqrt(2*sqrt(2) + 1)*log( - sqrt(2*sqrt(2) + 1)*x + sqrt(2) + x )

                                                                 2
  + 4*sqrt(2*sqrt(2) + 1)*log(sqrt(2*sqrt(2) + 1)*x + sqrt(2) + x ))/56

testint(1/(x**6-1),x);


                    2*x - 1                     2*x + 1          2
( - 2*sqrt(3)*atan(---------) - 2*sqrt(3)*atan(---------) + log(x  - x + 1)
                    sqrt(3)                     sqrt(3)

         2
  - log(x  + x + 1) + 2*log(x - 1) - 2*log(x + 1))/12

testint(1/(x**6-2),x);


                         1/6                              1/6
  1/6                   2    - 2*x                       2    + 2*x
(2   *(2*sqrt(3)*atan(--------------) - 2*sqrt(3)*atan(--------------)
                        1/6                              1/6
                       2   *sqrt(3)                     2   *sqrt(3)

                 1/6                  1/6                1/6      1/3    2
        - 2*log(2    + x) + 2*log( - 2    + x) + log( - 2   *x + 2    + x )

               1/6      1/3    2
        - log(2   *x + 2    + x )))/24

testint(1/(x**6+2),x);


                   1/6                            1/6
  1/6             2   *sqrt(3) - 2*x             2   *sqrt(3) + 2*x
(2   *( - 2*atan(--------------------) + 2*atan(--------------------)
                          1/6                            1/6
                         2                              2

                   x                       1/6              1/3    2
        + 4*atan(------) - sqrt(3)*log( - 2   *sqrt(3)*x + 2    + x )
                   1/6
                  2

                       1/6              1/3    2
        + sqrt(3)*log(2   *sqrt(3)*x + 2    + x )))/24

testint(1/(x**8+1),x);


                              sqrt( - sqrt(2) + 2) - 2*x
( - 2*sqrt(sqrt(2) + 2)*atan(----------------------------)
                                  sqrt(sqrt(2) + 2)

                              sqrt( - sqrt(2) + 2) + 2*x
  + 2*sqrt(sqrt(2) + 2)*atan(----------------------------)
                                  sqrt(sqrt(2) + 2)

                                 sqrt(sqrt(2) + 2) - 2*x
  - 2*sqrt( - sqrt(2) + 2)*atan(-------------------------)
                                  sqrt( - sqrt(2) + 2)

                                 sqrt(sqrt(2) + 2) + 2*x
  + 2*sqrt( - sqrt(2) + 2)*atan(-------------------------)
                                  sqrt( - sqrt(2) + 2)

                                                          2
  - sqrt( - sqrt(2) + 2)*log( - sqrt( - sqrt(2) + 2)*x + x  + 1)

                                                       2
  + sqrt( - sqrt(2) + 2)*log(sqrt( - sqrt(2) + 2)*x + x  + 1)

                                                    2
  - sqrt(sqrt(2) + 2)*log( - sqrt(sqrt(2) + 2)*x + x  + 1)

                                                 2
  + sqrt(sqrt(2) + 2)*log(sqrt(sqrt(2) + 2)*x + x  + 1))/16

testint(1/(x**8-1),x);


                 sqrt(2) - 2*x                     sqrt(2) + 2*x
(2*sqrt(2)*atan(---------------) - 2*sqrt(2)*atan(---------------) - 4*atan(x)
                    sqrt(2)                           sqrt(2)

                                2                                 2
  + sqrt(2)*log( - sqrt(2)*x + x  + 1) - sqrt(2)*log(sqrt(2)*x + x  + 1)

  + 2*log(x - 1) - 2*log(x + 1))/16

testint(1/(x**8-x**4+1),x);


                                         sqrt(6) + sqrt(2) - 4*x
( - 2*sqrt( - sqrt(3) + 2)*sqrt(3)*atan(-------------------------)
                                         2*sqrt( - sqrt(3) + 2)

                                 sqrt(6) + sqrt(2) - 4*x
  - 6*sqrt( - sqrt(3) + 2)*atan(-------------------------)
                                 2*sqrt( - sqrt(3) + 2)

                                         sqrt(6) + sqrt(2) + 4*x
  + 2*sqrt( - sqrt(3) + 2)*sqrt(3)*atan(-------------------------)
                                         2*sqrt( - sqrt(3) + 2)

                                 sqrt(6) + sqrt(2) + 4*x
  + 6*sqrt( - sqrt(3) + 2)*atan(-------------------------)
                                 2*sqrt( - sqrt(3) + 2)

                    2*sqrt( - sqrt(3) + 2) - 4*x
  - 2*sqrt(6)*atan(------------------------------)
                         sqrt(6) + sqrt(2)

                    2*sqrt( - sqrt(3) + 2) + 4*x
  + 2*sqrt(6)*atan(------------------------------)
                         sqrt(6) + sqrt(2)

                                                                  2
  - sqrt( - sqrt(3) + 2)*sqrt(3)*log( - sqrt( - sqrt(3) + 2)*x + x  + 1)

                                                               2
  + sqrt( - sqrt(3) + 2)*sqrt(3)*log(sqrt( - sqrt(3) + 2)*x + x  + 1)

                                                            2
  - 3*sqrt( - sqrt(3) + 2)*log( - sqrt( - sqrt(3) + 2)*x + x  + 1)

                                                         2
  + 3*sqrt( - sqrt(3) + 2)*log(sqrt( - sqrt(3) + 2)*x + x  + 1)

                                               2
                  - sqrt(6)*x - sqrt(2)*x + 2*x  + 2
  - sqrt(6)*log(-------------------------------------)
                                  2

                                            2
                 sqrt(6)*x + sqrt(2)*x + 2*x  + 2
  + sqrt(6)*log(----------------------------------))/24
                                2

testint(x**7/(x**12+1),x);


                                       sqrt(6) + sqrt(2) - 4*x
( - sqrt( - sqrt(3) + 2)*sqrt(6)*atan(-------------------------)
                                       2*sqrt( - sqrt(3) + 2)

                                         sqrt(6) + sqrt(2) - 4*x
  - 3*sqrt( - sqrt(3) + 2)*sqrt(2)*atan(-------------------------)
                                         2*sqrt( - sqrt(3) + 2)

                                       sqrt(6) + sqrt(2) + 4*x
  - sqrt( - sqrt(3) + 2)*sqrt(6)*atan(-------------------------)
                                       2*sqrt( - sqrt(3) + 2)

                                         sqrt(6) + sqrt(2) + 4*x
  - 3*sqrt( - sqrt(3) + 2)*sqrt(2)*atan(-------------------------)
                                         2*sqrt( - sqrt(3) + 2)

                                       2*sqrt( - sqrt(3) + 2) - 4*x
  + sqrt( - sqrt(3) + 2)*sqrt(6)*atan(------------------------------)
                                            sqrt(6) + sqrt(2)

                                         2*sqrt( - sqrt(3) + 2) - 4*x
  + 3*sqrt( - sqrt(3) + 2)*sqrt(2)*atan(------------------------------)
                                              sqrt(6) + sqrt(2)

                                       2*sqrt( - sqrt(3) + 2) + 4*x
  + sqrt( - sqrt(3) + 2)*sqrt(6)*atan(------------------------------)
                                            sqrt(6) + sqrt(2)

                                         2*sqrt( - sqrt(3) + 2) + 4*x
  + 3*sqrt( - sqrt(3) + 2)*sqrt(2)*atan(------------------------------)
                                              sqrt(6) + sqrt(2)

                                     2                              2
  + log( - sqrt( - sqrt(3) + 2)*x + x  + 1) - 2*log( - sqrt(2)*x + x  + 1)

                                  2                           2
  + log(sqrt( - sqrt(3) + 2)*x + x  + 1) - 2*log(sqrt(2)*x + x  + 1)

                                       2
          - sqrt(6)*x - sqrt(2)*x + 2*x  + 2
  + log(-------------------------------------)
                          2

                                    2
         sqrt(6)*x + sqrt(2)*x + 2*x  + 2
  + log(----------------------------------))/24
                        2


% Examples involving logarithms.

testint(log x,x);


x*(log(x) - 1)

testint(x*log x,x);


  2
 x *(2*log(x) - 1)
-------------------
         4

testint(x**2*log x,x);


  3
 x *(3*log(x) - 1)
-------------------
         9

testint(x**p*log x,x);


  p
 x *x*(log(x)*p + log(x) - 1)
------------------------------
          2
         p  + 2*p + 1

testint((log x)**2,x);


         2
x*(log(x)  - 2*log(x) + 2)

testint(x**9*log x**11,x);


  10                 11                  10                  9
(x  *(15625000*log(x)   - 17187500*log(x)   + 17187500*log(x)

                        8                  7                 6                 5
       - 15468750*log(x)  + 12375000*log(x)  - 8662500*log(x)  + 5197500*log(x)

                       4                 3                2
       - 2598750*log(x)  + 1039500*log(x)  - 311850*log(x)  + 62370*log(x)

       - 6237))/156250000

testint(log x**2/x,x);


       3
 log(x)
---------
    3

testint(1/log x,x);


ei(log(x))

testint(1/log(x+1),x);


ei(log(x + 1))

testint(1/(x*log x),x);


log(log(x))

testint(1/(x*log x)**2,x);


  - (ei( - log(x))*log(x)*x + 1)
---------------------------------
            log(x)*x

testint((log x)**p/x,x);


       p
 log(x) *log(x)
----------------
     p + 1

testint(log x *(a*x+b),x);


 x*(2*log(x)*a*x + 4*log(x)*b - a*x - 4*b)
-------------------------------------------
                     4

testint((a*x+b)**2*log x,x);


              2  2                                2      2  2                 2
(x*(6*log(x)*a *x  + 18*log(x)*a*b*x + 18*log(x)*b  - 2*a *x  - 9*a*b*x - 18*b )

 )/18

testint(log x/(a*x+b)**2,x);


  - log(a*x + b)*a*x - log(a*x + b)*b + log(x)*a*x
---------------------------------------------------
                   a*b*(a*x + b)

testint(x*log (a*x+b),x);


                 2  2                   2    2  2
 2*log(a*x + b)*a *x  - 2*log(a*x + b)*b  - a *x  + 2*a*b*x
------------------------------------------------------------
                               2
                            4*a

testint(x**2*log(a*x+b),x);


                 3  3                   3      3  3      2    2        2
 6*log(a*x + b)*a *x  + 6*log(a*x + b)*b  - 2*a *x  + 3*a *b*x  - 6*a*b *x
---------------------------------------------------------------------------
                                       3
                                   18*a

testint(log(x**2+a**2),x);


        x            2    2
2*atan(---)*a + log(a  + x )*x - 2*x
        a

testint(x*log(x**2+a**2),x);


      2    2   2        2    2   2    2
 log(a  + x )*a  + log(a  + x )*x  - x
----------------------------------------
                   2

testint(x**2*log(x**2+a**2),x);


            x    3          2    2   3      2        3
  - 6*atan(---)*a  + 3*log(a  + x )*x  + 6*a *x - 2*x
            a
-------------------------------------------------------
                           9

testint(x**4*log(x**2+a**2),x);


          x    5           2    2   5       4         2  3      5
 30*atan(---)*a  + 15*log(a  + x )*x  - 30*a *x + 10*a *x  - 6*x
          a
------------------------------------------------------------------
                                75

testint(log(x**2-a**2),x);


           2    2              2    2
 - log( - a  + x )*a + log( - a  + x )*x + 2*log( - a - x)*a - 2*x

testint(log(log(log(log(x)))),x);


                         1
 - int(-------------------------------------,x) + log(log(log(log(x))))*x
        log(log(log(x)))*log(log(x))*log(x)


% Examples involving circular functions.

testint(sin x,x);


 - cos(x)
 % 2.01 #5;
testint(cos x,x);


sin(x)
 %     #6;
testint(tan x,x);


           2
 log(tan(x)  + 1)
------------------
        2
 %     #11;
testint(1/tan(x),x);


              2
  - log(tan(x)  + 1) + 2*log(tan(x))
-------------------------------------
                  2
 % 2.01 #12;
testint(1/(1+tan(x))**2,x);


              2                         2
( - log(tan(x)  + 1)*tan(x) - log(tan(x)  + 1) + 2*log(tan(x) + 1)*tan(x)

  + 2*log(tan(x) + 1) + 2*tan(x))/(4*(tan(x) + 1))

testint(1/cos x,x);


            x                   x
 - log(tan(---) - 1) + log(tan(---) + 1)
            2                   2

testint(1/sin x,x);


         x
log(tan(---))
         2

testint(sin x**2,x);


  - cos(x)*sin(x) + x
----------------------
          2

testint(x**3*sin(x**2),x);


         2   2        2
  - cos(x )*x  + sin(x )
-------------------------
            2

testint(sin x**3,x);


                 2
  - cos(x)*sin(x)  - 2*cos(x) + 2
----------------------------------
                3

testint(sin x**p,x);


          p
int(sin(x) ,x)

testint((sin x**2+1)**2*cos x,x);


                 4            2
 sin(x)*(3*sin(x)  + 10*sin(x)  + 15)
--------------------------------------
                  15

testint(cos x**2,x);


 cos(x)*sin(x) + x
-------------------
         2

testint(cos x**3,x);


                  2
 sin(x)*( - sin(x)  + 3)
-------------------------
            3

testint(sin(a*x+b),x);


  - cos(a*x + b)
-----------------
        a

testint(1/cos x**2,x);


 sin(x)
--------
 cos(x)

testint(sin x*sin(2*x),x);


  - 2*cos(2*x)*sin(x) + cos(x)*sin(2*x)
----------------------------------------
                   3

testint(x*sin x,x);


 - cos(x)*x + sin(x)

testint(x**2*sin x,x);


           2
 - cos(x)*x  + 2*cos(x) + 2*sin(x)*x

testint(x*sin x**2,x);


                              2    2
  - 2*cos(x)*sin(x)*x + sin(x)  + x  - 2
-----------------------------------------
                    4

testint(x**2*sin x**2,x);


                     2                             2        3
  - 6*cos(x)*sin(x)*x  + 3*cos(x)*sin(x) + 6*sin(x) *x + 2*x  - 3*x
--------------------------------------------------------------------
                                 12

testint(x*sin x**3,x);


                   2                        3
  - 3*cos(x)*sin(x) *x - 6*cos(x)*x + sin(x)  + 6*sin(x)
---------------------------------------------------------
                            9

testint(x*cos x,x);


cos(x) + sin(x)*x

testint(x**2*cos x,x);


                     2
2*cos(x)*x + sin(x)*x  - 2*sin(x)

testint(x*cos x**2,x);


                           2    2
 2*cos(x)*sin(x)*x - sin(x)  + x  + 2
--------------------------------------
                  4

testint(x**2*cos x**2,x);


                  2                             2        3
 6*cos(x)*sin(x)*x  - 3*cos(x)*sin(x) - 6*sin(x) *x + 2*x  + 3*x
-----------------------------------------------------------------
                               12

testint(x*cos x**3,x);


                 2                      3
  - cos(x)*sin(x)  + 7*cos(x) - 3*sin(x) *x + 9*sin(x)*x + 1
-------------------------------------------------------------
                              9

testint(sin x/x,x);


si(x)

testint(cos x/x,x);


ci(x)

testint(sin x/x**2,x);


 ci(x)*x - sin(x)
------------------
        x

testint(sin x**2/x,x);


  - ci(2*x) + log(x)
---------------------
          2

testint(tan x**3,x);


              2              2
  - log(tan(x)  + 1) + tan(x)
-------------------------------
               2

% z := a+b*x;
testint(sin z,x);


  - cos(a + b*x)
-----------------
        b

testint(cos z,x);


 sin(a + b*x)
--------------
      b

testint(tan z,x);


                 2
 log(tan(a + b*x)  + 1)
------------------------
          2*b

testint(1/tan z,x);


                    2
  - log(tan(a + b*x)  + 1) + 2*log(tan(a + b*x))
-------------------------------------------------
                       2*b

testint(1/sin z,x);


          a + b*x
 log(tan(---------))
             2
---------------------
          b

testint(1/cos z,x);


             a + b*x                   a + b*x
  - log(tan(---------) - 1) + log(tan(---------) + 1)
                2                         2
------------------------------------------------------
                          b

testint(sin z**2,x);


  - cos(a + b*x)*sin(a + b*x) + b*x
------------------------------------
                2*b

testint(sin z**3,x);


                             2
  - cos(a + b*x)*sin(a + b*x)  - 2*cos(a + b*x) + 2
----------------------------------------------------
                        3*b

testint(cos z**2,x);


 cos(a + b*x)*sin(a + b*x) + b*x
---------------------------------
               2*b

testint(cos z**3,x);


                              2
 sin(a + b*x)*( - sin(a + b*x)  + 3)
-------------------------------------
                 3*b

testint(1/cos z**2,x);


  sin(a + b*x)
----------------
 cos(a + b*x)*b

testint(1/(1+cos x),x);


     x
tan(---)
     2

testint(1/(1-cos x),x);


    - 1
----------
      x
 tan(---)
      2

testint(1/(1+sin x),x);


         x
  2*tan(---)
         2
--------------
      x
 tan(---) + 1
      2

testint(1/(1-sin x),x);


           x
  - 2*tan(---)
           2
---------------
      x
 tan(---) - 1
      2

testint(1/(a+b*sin x),x);


                            x
                       tan(---)*a + b
         2    2             2
 2*sqrt(a  - b )*atan(----------------)
                             2    2
                       sqrt(a  - b )
----------------------------------------
                 2    2
                a  - b

testint(1/(a+b*sin x+cos x),x);


                                x            x
                           tan(---)*a - tan(---) + b
         2    2                 2            2
 2*sqrt(a  - b  - 1)*atan(---------------------------)
                                     2    2
                               sqrt(a  - b  - 1)
-------------------------------------------------------
                       2    2
                      a  - b  - 1

testint(x**2*sin z**2,x);


                                 2  2
( - 6*cos(a + b*x)*sin(a + b*x)*b *x  + 3*cos(a + b*x)*sin(a + b*x)

                  2                3  3               3
  + 6*sin(a + b*x) *b*x + 9*a + 2*b *x  - 3*b*x)/(12*b )

testint(cos x*cos(2*x),x);


  - cos(2*x)*sin(x) + 2*cos(x)*sin(2*x)
----------------------------------------
                   3

testint(x**2*cos z**2,x);


                              2  2
(6*cos(a + b*x)*sin(a + b*x)*b *x  - 3*cos(a + b*x)*sin(a + b*x)

                  2          3  3               3
  - 6*sin(a + b*x) *b*x + 2*b *x  + 3*b*x)/(12*b )

testint(1/tan x**3,x);


           2            2                       2
 log(tan(x)  + 1)*tan(x)  - 2*log(tan(x))*tan(x)  - 1
------------------------------------------------------
                              2
                      2*tan(x)

testint(x**3*tan(x)**4,x);


                2                  2                3  3           2  2
(48*int(tan(x)*x ,x) - 6*log(tan(x)  + 1) + 4*tan(x) *x  - 6*tan(x) *x

               3                    4      2
  - 12*tan(x)*x  + 12*tan(x)*x + 3*x  - 6*x )/12

testint(x**3*tan(x)**6,x);


                    2                   2                 5  3           4  2
( - 276*int(tan(x)*x ,x) + 60*log(tan(x)  + 1) + 12*tan(x) *x  - 9*tan(x) *x

             3  3           3              2  2           2              3
  - 20*tan(x) *x  + 6*tan(x) *x + 48*tan(x) *x  - 3*tan(x)  + 60*tan(x)*x

                       4       2
  - 114*tan(x)*x - 15*x  + 57*x )/60

testint(x*tan(x)**2,x);


              2                      2
  - log(tan(x)  + 1) + 2*tan(x)*x - x
---------------------------------------
                   2

testint(sin(2*x)*cos(3*x),x);


 2*cos(3*x)*cos(2*x) + 3*sin(3*x)*sin(2*x)
-------------------------------------------
                     5

testint(sin x**2*cos x**2,x);


                3
 2*cos(x)*sin(x)  - cos(x)*sin(x) + x
--------------------------------------
                  8

testint(1/(sin x**2*cos x**2),x);


         2
 2*sin(x)  - 1
---------------
 cos(x)*sin(x)

testint(d**x*sin x,x);


  x
 d *( - cos(x) + log(d)*sin(x))
--------------------------------
                2
          log(d)  + 1

testint(d**x*cos x,x);


  x
 d *(cos(x)*log(d) + sin(x))
-----------------------------
               2
         log(d)  + 1

testint(x*d**x*sin x,x);


  x                  2                                        3
(d *( - cos(x)*log(d) *x + 2*cos(x)*log(d) - cos(x)*x + log(d) *sin(x)*x

              2                                            4           2
      - log(d) *sin(x) + log(d)*sin(x)*x + sin(x)))/(log(d)  + 2*log(d)  + 1)

testint(x*d**x*cos x,x);


  x               3                  2
(d *(cos(x)*log(d) *x - cos(x)*log(d)  + cos(x)*log(d)*x + cos(x)

              2                                                4           2
      + log(d) *sin(x)*x - 2*log(d)*sin(x) + sin(x)*x))/(log(d)  + 2*log(d)  + 1

   )

testint(x**2*d**x*sin x,x);


  x                  4  2                  3                    2  2
(d *( - cos(x)*log(d) *x  + 4*cos(x)*log(d) *x - 2*cos(x)*log(d) *x

                       2                               2
      - 6*cos(x)*log(d)  + 4*cos(x)*log(d)*x - cos(x)*x  + 2*cos(x)

              5         2           4                    3         2
      + log(d) *sin(x)*x  - 2*log(d) *sin(x)*x + 2*log(d) *sin(x)*x

                3                         2
      + 2*log(d) *sin(x) + log(d)*sin(x)*x  - 6*log(d)*sin(x) + 2*sin(x)*x))/(

         6           4           2
   log(d)  + 3*log(d)  + 3*log(d)  + 1)

testint(x**2*d**x*cos x,x);


  x               5  2                  4                    3  2
(d *(cos(x)*log(d) *x  - 2*cos(x)*log(d) *x + 2*cos(x)*log(d) *x

                       3                  2
      + 2*cos(x)*log(d)  + cos(x)*log(d)*x  - 6*cos(x)*log(d) + 2*cos(x)*x

              4         2           3                    2         2
      + log(d) *sin(x)*x  - 4*log(d) *sin(x)*x + 2*log(d) *sin(x)*x

                2                                      2                     6
      + 6*log(d) *sin(x) - 4*log(d)*sin(x)*x + sin(x)*x  - 2*sin(x)))/(log(d)

              4           2
    + 3*log(d)  + 3*log(d)  + 1)

testint(x**3*d**x*sin x,x);


  x                  6  3                  5  2                  4  3
(d *( - cos(x)*log(d) *x  + 6*cos(x)*log(d) *x  - 3*cos(x)*log(d) *x

                        4                     3  2                   3
      - 18*cos(x)*log(d) *x + 12*cos(x)*log(d) *x  + 24*cos(x)*log(d)

                       2  3                   2                      2
      - 3*cos(x)*log(d) *x  - 12*cos(x)*log(d) *x + 6*cos(x)*log(d)*x

                                   3                      7         3
      - 24*cos(x)*log(d) - cos(x)*x  + 6*cos(x)*x + log(d) *sin(x)*x

                6         2           5         3           5
      - 3*log(d) *sin(x)*x  + 3*log(d) *sin(x)*x  + 6*log(d) *sin(x)*x

                4         2           4                  3         3
      - 3*log(d) *sin(x)*x  - 6*log(d) *sin(x) + 3*log(d) *sin(x)*x

                 3                    2         2            2
      - 12*log(d) *sin(x)*x + 3*log(d) *sin(x)*x  + 36*log(d) *sin(x)

                       3                                  2
      + log(d)*sin(x)*x  - 18*log(d)*sin(x)*x + 3*sin(x)*x  - 6*sin(x)))/(

         8           6           4           2
   log(d)  + 4*log(d)  + 6*log(d)  + 4*log(d)  + 1)

testint(x**3*d**x*cos x,x);


  x               7  3                  6  2                  5  3
(d *(cos(x)*log(d) *x  - 3*cos(x)*log(d) *x  + 3*cos(x)*log(d) *x

                       5                    4  2                  4
      + 6*cos(x)*log(d) *x - 3*cos(x)*log(d) *x  - 6*cos(x)*log(d)

                       3  3                   3                    2  2
      + 3*cos(x)*log(d) *x  - 12*cos(x)*log(d) *x + 3*cos(x)*log(d) *x

                        2                  3                                  2
      + 36*cos(x)*log(d)  + cos(x)*log(d)*x  - 18*cos(x)*log(d)*x + 3*cos(x)*x

                         6         3           5         2           4         3
      - 6*cos(x) + log(d) *sin(x)*x  - 6*log(d) *sin(x)*x  + 3*log(d) *sin(x)*x

                 4                     3         2            3
      + 18*log(d) *sin(x)*x - 12*log(d) *sin(x)*x  - 24*log(d) *sin(x)

                2         3            2                             2
      + 3*log(d) *sin(x)*x  + 12*log(d) *sin(x)*x - 6*log(d)*sin(x)*x

                                   3                       8           6
      + 24*log(d)*sin(x) + sin(x)*x  - 6*sin(x)*x))/(log(d)  + 4*log(d)

              4           2
    + 6*log(d)  + 4*log(d)  + 1)

testint(sin x*sin(2*x)*sin(3*x),x);


( - cos(3*x)*cos(2*x)*cos(x) + 6*cos(3*x)*cos(2*x)*sin(x)*x

  + 6*cos(3*x)*cos(x)*sin(2*x)*x - 8*cos(3*x)*sin(2*x)*sin(x)

  - 6*cos(2*x)*cos(x)*sin(3*x)*x + 3*cos(2*x)*sin(3*x)*sin(x)

  + 6*sin(3*x)*sin(2*x)*sin(x)*x)/24

testint(cos x*cos(2*x)*cos(3*x),x);


(6*cos(3*x)*cos(2*x)*cos(x)*x + 8*cos(3*x)*cos(2*x)*sin(x)

  + 5*cos(3*x)*cos(x)*sin(2*x) - 6*cos(3*x)*sin(2*x)*sin(x)*x

  + 6*cos(2*x)*sin(3*x)*sin(x)*x + 6*cos(x)*sin(3*x)*sin(2*x)*x

  + 9*sin(3*x)*sin(2*x)*sin(x))/24

testint(sin(x*kx)**3*x**2,x);


                         2   2  2                        2                  2  2
( - 9*cos(kx*x)*sin(kx*x) *kx *x  + 2*cos(kx*x)*sin(kx*x)  - 18*cos(kx*x)*kx *x

                              3                                      3
  + 40*cos(kx*x) + 6*sin(kx*x) *kx*x + 36*sin(kx*x)*kx*x + 16)/(27*kx )

testint(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);


            xi
     cos(--------)*cos(x)*x
          sin(x)
int(------------------------,x)
                  2
            sin(x)


% Mixed angles and half angles.

int(cos(x)/(sin(x)*tan(x/2)),x);


          x
  - (tan(---)*x + 1)
          2
---------------------
           x
      tan(---)
           2


% This integral produces a messy result because the code for
% converting half angle tans to sin and cos is not effective enough.

testint(sin(a*x)/(b+c*sin(a*x))**2,x);


                               a*x
                          tan(-----)*b + c
            2    2              2                      2
( - 2*sqrt(b  - c )*atan(------------------)*sin(a*x)*c
                                 2    2
                           sqrt(b  - c )

                               a*x
                          tan(-----)*b + c
            2    2              2                            3               2
  - 2*sqrt(b  - c )*atan(------------------)*b*c - cos(a*x)*b  + cos(a*x)*b*c )/
                                 2    2
                           sqrt(b  - c )

              4                 2  3             5    5      3  2      4
(a*(sin(a*x)*b *c - 2*sin(a*x)*b *c  + sin(a*x)*c  + b  - 2*b *c  + b*c ))


% Examples involving logarithms and circular functions.

testint(sin log x,x);


 x*( - cos(log(x)) + sin(log(x)))
----------------------------------
                2

testint(cos log x,x);


 x*(cos(log(x)) + sin(log(x)))
-------------------------------
               2


% Examples involving exponentials.

testint(e**x,x);


 x
e
 % 2.01 #3;
testint(a**x,x);


    x
   a
--------
 log(a)
 % 2.01 #4;
testint(e**(a*x),x);


  a*x
 e
------
  a

testint(e**(a*x)/x,x);


ei(a*x)

testint(1/(a+b*e**(m*x)),x);


         m*x
  - log(e   *b + a) + m*x
--------------------------
           a*m

testint(e**(2*x)/(1+e**x),x);


 x        x
e  - log(e  + 1)

testint(e**(2*x)*e**(a*x),x);


  a*x + 2*x
 e
------------
   a + 2

testint(1/(a*e**(m*x)+b*e**(-m*x)),x);


                            m*x
                           e   *a
 sqrt(b)*sqrt(a)*atan(-----------------)
                       sqrt(b)*sqrt(a)
-----------------------------------------
                  a*b*m

testint(x*e**(a*x),x);


  a*x
 e   *(a*x - 1)
----------------
        2
       a

testint(x**20*e**x,x);


 x   20       19        18         17           16            15             14
e *(x   - 20*x   + 380*x   - 6840*x   + 116280*x   - 1860480*x   + 27907200*x

                  13               12                11                 10
     - 390700800*x   + 5079110400*x   - 60949324800*x   + 670442572800*x

                      9                   8                    7
     - 6704425728000*x  + 60339831552000*x  - 482718652416000*x

                         6                      5                       4
     + 3379030566912000*x  - 20274183401472000*x  + 101370917007360000*x

                           3                        2
     - 405483668029440000*x  + 1216451004088320000*x  - 2432902008176640000*x

     + 2432902008176640000)

testint(a**x/b**x,x);


           x
          a
----------------------
  x
 b *(log(a) - log(b))

testint(a**x*b**x,x);


       x  x
      b *a
-----------------
 log(a) + log(b)

testint(a**x/x**2,x);


                          x
 ei(log(a)*x)*log(a)*x - a
----------------------------
             x

testint(x*a**x/(1+b*x)**2,x);


                                x
                               a *x
int(-----------------------------------------------------------,x)*(log(a) - b)
             2  2                            3  2      2
     log(a)*b *x  + 2*log(a)*b*x + log(a) - b *x  - 2*b *x - b

testint(x*e**(a*x)/(1+a*x)**2,x);


      a*x
     e
--------------
  2
 a *(a*x + 1)

testint(x*k**(x**2),x);


     2
    x
   k
----------
 2*log(k)

testint(e**(x**2),x);


  - sqrt(pi)*erf(i*x)*i
------------------------
           2

testint(x*e**(x**2),x);


   2
  x
 e
-----
  2

testint((x+1)*e**(1/x)/x**4,x);


  1/x      2
 e   *( - x  + x - 1)
----------------------
           2
          x

testint((2*x**3+x)*(e**(x**2))**2*e**(1-x*e**(x**2))/(1-x*e**(x**2))**2,
	x);


         - e
--------------------
    2
   x       2
  e  *x   x
 e     *(e  *x - 1)

testint(e**(e**(e**(e**x))),x);


        x
       e
      e
     e
int(e    ,x)


% Examples involving exponentials and logarithms.

testint(e**x*log x,x);


            x
 - ei(x) + e *log(x)

testint(x*e**x*log x,x);


         x             x           x
ei(x) + e *log(x)*x - e *log(x) - e

testint(e**(2*x)*log(e**x),x);


  2*x
 e   *(2*x - 1)
----------------
       4


% Examples involving square roots.

testint(sqrt(2)*x**2 + 2*x,x);


  2
 x *(sqrt(2)*x + 3)
--------------------
         3

testint(log x/sqrt(a*x+b),x);


(2*(sqrt(a*x + b)*log(x) - 2*sqrt(a*x + b)

     + 2*sqrt(b)*log( - sqrt(a*x + b) - sqrt(b)) - sqrt(b)*log(x)))/a

u:=sqrt(a+b*x);


u := sqrt(a + b*x)

v:=sqrt(c+d*x);


v := sqrt(c + d*x)

testint(u*v,x);


                                  2                                2
(sqrt(c + d*x)*sqrt(a + b*x)*a*b*d  + sqrt(c + d*x)*sqrt(a + b*x)*b *c*d

                                   2  2
  + 2*sqrt(c + d*x)*sqrt(a + b*x)*b *d *x

                         sqrt(d)*sqrt(a + b*x) + sqrt(b)*sqrt(c + d*x)    2  2
  - sqrt(d)*sqrt(b)*log(-----------------------------------------------)*a *d  +
                                        sqrt(a*d - b*c)

                         sqrt(d)*sqrt(a + b*x) + sqrt(b)*sqrt(c + d*x)
  2*sqrt(d)*sqrt(b)*log(-----------------------------------------------)*a*b*c*d
                                        sqrt(a*d - b*c)

                         sqrt(d)*sqrt(a + b*x) + sqrt(b)*sqrt(c + d*x)    2  2
  - sqrt(d)*sqrt(b)*log(-----------------------------------------------)*b *c )/
                                        sqrt(a*d - b*c)

    2  2
(4*b *d )

testint(u,x);


 2*sqrt(a + b*x)*(a + b*x)
---------------------------
            3*b

testint(x*u,x);


                        2              2  2
 2*sqrt(a + b*x)*( - 2*a  + a*b*x + 3*b *x )
---------------------------------------------
                        2
                    15*b

testint(x**2*u,x);


                     3      2            2  2       3  3
 2*sqrt(a + b*x)*(8*a  - 4*a *b*x + 3*a*b *x  + 15*b *x )
----------------------------------------------------------
                               3
                          105*b

testint(u/x,x);


2*sqrt(a + b*x) - sqrt(a)*log( - sqrt(a + b*x) - sqrt(a))

 + sqrt(a)*log( - sqrt(a + b*x) + sqrt(a))

testint(u/x**2,x);


( - 2*sqrt(a + b*x)*a - sqrt(a)*log( - sqrt(a + b*x) - sqrt(a))*b*x

  + sqrt(a)*log( - sqrt(a + b*x) + sqrt(a))*b*x)/(2*a*x)

testint(1/u,x);


 2*sqrt(a + b*x)
-----------------
        b

testint(x/u,x);


 2*sqrt(a + b*x)*( - 2*a + b*x)
--------------------------------
                 2
              3*b

testint(x**2/u,x);


                     2                2  2
 2*sqrt(a + b*x)*(8*a  - 4*a*b*x + 3*b *x )
--------------------------------------------
                       3
                   15*b

testint(1/(x*u),x);


 sqrt(a)*( - log( - sqrt(a + b*x) - sqrt(a)) + log( - sqrt(a + b*x) + sqrt(a)))
--------------------------------------------------------------------------------
                                       a

testint(1/(x**2*u),x);


( - 2*sqrt(a + b*x)*a + sqrt(a)*log( - sqrt(a + b*x) - sqrt(a))*b*x

                                                     2
  - sqrt(a)*log( - sqrt(a + b*x) + sqrt(a))*b*x)/(2*a *x)

testint(u**p,x);


            p/2
 2*(a + b*x)   *(a + b*x)
--------------------------
        b*(p + 2)

testint(x*u**p,x);


            p/2        2              2    2      2  2
 2*(a + b*x)   *( - 2*a  + a*b*p*x + b *p*x  + 2*b *x )
--------------------------------------------------------
                    2   2
                   b *(p  + 6*p + 8)

testint(atan((-sqrt(2)+2*x)/sqrt(2)),x);


                 sqrt(2) - 2*x             sqrt(2) - 2*x
(2*sqrt(2)*atan(---------------) - 4*atan(---------------)*x
                    sqrt(2)                   sqrt(2)

                             2
  - sqrt(2)*log(sqrt(2)*x - x  - 1))/4

testint(1/sqrt(x**2-1),x);


          2
log(sqrt(x  - 1) + x)

testint(sqrt(x+1)*sqrt x,x);


 2*sqrt(x)*sqrt(x + 1)*x + sqrt(x)*sqrt(x + 1) - log(sqrt(x + 1) + sqrt(x))
----------------------------------------------------------------------------
                                     4


testint(sin(sqrt x),x);


2*( - sqrt(x)*cos(sqrt(x)) + sin(sqrt(x)))

testint(x*(1-x^2)^(-9/4),x);


              2     1/4
     - 2*( - x  + 1)
----------------------------
            2        2
 5*sqrt( - x  + 1)*(x  - 1)

testint(x/sqrt(1-x^4),x);


       2
 asin(x )
----------
    2

testint(1/(x*sqrt(1+x^4)),x);


           4         2                  4         2
 log(sqrt(x  + 1) + x  - 1) - log(sqrt(x  + 1) + x  + 1)
---------------------------------------------------------
                            2

testint(x/sqrt(1+x^2+x^4),x);


              4    2           2
      2*sqrt(x  + x  + 1) + 2*x  + 1
 log(--------------------------------)
                 sqrt(3)
---------------------------------------
                   2

testint(1/(x*sqrt(x^2-1-x^4)),x);


                 4    2
        sqrt( - x  + x  - 1)
 - int(----------------------,x)
             5    3
            x  - x  + x


% Examples from James Davenport's thesis:

testint(1/sqrt(x**2-1)+10/sqrt(x**2-4),x);


                                      2
          2                     sqrt(x  - 4) + x
log(sqrt(x  - 1) + x) + 10*log(------------------)
                                       2
      % p. 173
testint(sqrt(x+sqrt(x**2+a**2))/x,x);


                2    2
     sqrt(sqrt(a  + x ) + x)
int(-------------------------,x)
                x


% Examples generated by differentiating various functions.

testint(df(sqrt(1+x**2)/(1-x),x),x);


          2
  - sqrt(x  + 1)
-----------------
      x - 1

testint(df(log(x+sqrt(1+x**2)),x),x);


          2
log(sqrt(x  + 1) + x)

testint(df(sqrt(x)+sqrt(x+1)+sqrt(x+2),x),x);


sqrt(x + 2) + sqrt(x + 1) + sqrt(x)

testint(df(sqrt(x**5-2*x+1)-sqrt(x**3+1),x),x);


      5                    3
sqrt(x  - 2*x + 1) - sqrt(x  + 1)


% Another such example from James Davenport's thesis (p. 146).
% It contains a point of order 3, which is found by use of Mazur's
% bound on the torsion of elliptic curves over the rationals;

testint(df(log(1+sqrt(x**3+1)),x),x);


                  3
            sqrt(x  + 1)
 3*( - int(--------------,x) + log(x))
                4
               x  + x
---------------------------------------
                   2


% Examples quoted by Joel Moses:

testint(1/sqrt(2*h*r**2-alpha**2),r);


                                   2        2
                      sqrt( - alpha  + 2*h*r ) + sqrt(h)*sqrt(2)*r
 sqrt(h)*sqrt(2)*log(----------------------------------------------)
                                         alpha
---------------------------------------------------------------------
                                 2*h

testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2)),r);


             2          2
(2*sqrt(alpha  + epsilon )

                     2          2        2
        sqrt( - alpha  - epsilon  + 2*h*r ) + sqrt(h)*sqrt(2)*r          2
 *atan(---------------------------------------------------------))/(alpha
                                  2          2
                        sqrt(alpha  + epsilon )

             2
    + epsilon )

testint(1/(r*sqrt(2*h*r**2-alpha**2-2*k*r)),r);


                              2        2
         sqrt(h)*sqrt( - alpha  + 2*h*r  - 2*k*r)*sqrt(2) + 2*h*r
 2*atan(----------------------------------------------------------)
                          sqrt(h)*sqrt(2)*alpha
--------------------------------------------------------------------
                               alpha

testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2-2*k*r)),r);


             2          2
(2*sqrt(alpha  + epsilon )

                             2          2        2
        sqrt(h)*sqrt( - alpha  - epsilon  + 2*h*r  - 2*k*r)*sqrt(2) + 2*h*r
 *atan(---------------------------------------------------------------------))/(
                                        2          2
                      sqrt(h)*sqrt(alpha  + epsilon )*sqrt(2)

        2          2
   alpha  + epsilon )

testint(r/sqrt(2*e*r**2-alpha**2),r);


              2        2
 sqrt( - alpha  + 2*e*r )
--------------------------
           2*e

testint(r/sqrt(2*e*r**2-alpha**2-epsilon**2),r);


              2        2          2
 sqrt( - alpha  + 2*e*r  - epsilon )
-------------------------------------
                 2*e

testint(r/sqrt(2*e*r**2-alpha**2-2*k*r**4),r);


                                          2
                             e*i - 2*i*k*r
 sqrt(k)*sqrt(2)*asinh(--------------------------)*i
                                       2      2
                        sqrt( - 2*alpha *k + e )
-----------------------------------------------------
                         4*k

testint(r/sqrt(2*e*r**2-alpha**2-2*k*r),r);


                2        2
(2*sqrt( - alpha  + 2*e*r  - 2*k*r)*e + sqrt(e)*sqrt(2)

                            2        2
       sqrt(e)*sqrt( - alpha  + 2*e*r  - 2*k*r)*sqrt(2) + 2*e*r - k          2
 *log(--------------------------------------------------------------)*k)/(4*e )
                                      2      2
                          sqrt(2*alpha *e + k )


% These two integrals will evaluate, but they take a very long time
% and the results are messy (compared with the algint results).

% testint(1/(r*sqrt(2*h*r**2-alpha**2-2*k*r**4)),r);
% testint(1/(r*sqrt(2*h*r**2-alpha**2-epsilon**2-2*k*r**4)),r);


Comment many of these integrals used to require Steve Harrington's
	code to evaluate. They originated in Novosibirsk as examples
	of using Analytik. There are still a few examples that could
	be evaluated using better heuristics;


testint(a*sin(3*x+5)**2*cos(3*x+5),x);


             3
 sin(3*x + 5) *a
-----------------
        9

testint(log(x**2)/x**3,x);


          2
  - (log(x ) + 1)
------------------
          2
       2*x

testint(x*sin(x+a),x);


 - cos(a + x)*x + sin(a + x)

testint((log(x)*(1-x)-1)/(e**x*log(x)**2),x);


     x
-----------
  x
 e *log(x)

testint(x**3*(a*x**2+b)**(-1),x);


           2             2
  - log(a*x  + b)*b + a*x
---------------------------
              2
           2*a

testint(x**(1/2)*(x+1)**(-7/2),x);


                      2                                                2
(2*( - 2*sqrt(x + 1)*x  - 4*sqrt(x + 1)*x - 2*sqrt(x + 1) + 2*sqrt(x)*x

                                       2
     + 5*sqrt(x)*x))/(15*sqrt(x + 1)*(x  + 2*x + 1))

testint(x**(-1)*(x+1)**(-1),x);


 - log(x + 1) + log(x)

testint(x**(-1/2)*(2*x-1)**(-1),x);


 sqrt(2)*(log(2*sqrt(x) - sqrt(2)) - log(2*sqrt(x) + sqrt(2)))
---------------------------------------------------------------
                               2

testint((x**2+1)*x**(1/2),x);


                 2
 2*sqrt(x)*x*(3*x  + 7)
------------------------
           21

testint(x**(-1)*(x-a)**(1/3),x);


                                1/6    1/6
                    2*( - a + x)    - a   *sqrt(3)
( - 2*sqrt(3)*atan(--------------------------------)*a
                                  1/6
                                 a

                                1/6    1/6
                    2*( - a + x)    + a   *sqrt(3)          2/3           1/3
  + 2*sqrt(3)*atan(--------------------------------)*a + 6*a   *( - a + x)
                                  1/6
                                 a

                    1/3    1/3
  - 2*log(( - a + x)    + a   )*a

            1/6           1/6                     1/3    1/3
  + log( - a   *( - a + x)   *sqrt(3) + ( - a + x)    + a   )*a

         1/6           1/6                     1/3    1/3         2/3
  + log(a   *( - a + x)   *sqrt(3) + ( - a + x)    + a   )*a)/(2*a   )

testint(x*sinh(x),x);


cosh(x)*x - sinh(x)

testint(x*cosh(x),x);


 - cosh(x) + sinh(x)*x

testint(sinh(2*x)/cosh(2*x),x);


 log(cosh(2*x))
----------------
       2

testint((i*eps*sinh x-1)/(eps*i*cosh x+i*a-x),x);


log(cosh(x)*eps*i + a*i - x)

testint(sin(2*x+3)*cos(x)**2,x);


                                                          2
( - 4*cos(2*x + 3)*cos(x)*sin(x)*x + 2*cos(2*x + 3)*sin(x)  - 3*cos(2*x + 3)

                         2
  - 4*sin(2*x + 3)*sin(x) *x + 2*sin(2*x + 3)*x + 3)/8

testint(x*atan(x),x);


          2
 atan(x)*x  + atan(x) - x
--------------------------
            2

testint(x*acot(x),x);


          2
 acot(x)*x  + acot(x) + x
--------------------------
            2

testint(x*log(x**2+a),x);


          2               2   2    2
 log(a + x )*a + log(a + x )*x  - x
-------------------------------------
                  2

testint(sin(x+a)*cos(x),x);


  - cos(a + x)*cos(x) - cos(a + x)*sin(x)*x + cos(x)*sin(a + x)*x
------------------------------------------------------------------
                                2

testint(cos(x+a)*sin(x),x);


  - cos(a + x)*cos(x) + cos(a + x)*sin(x)*x - cos(x)*sin(a + x)*x
------------------------------------------------------------------
                                2

testint((1+sin(x))**(1/2),x);


int(sqrt(sin(x) + 1),x)

testint((1-sin(x))**(1/2),x);


int(sqrt( - sin(x) + 1),x)

testint((1+cos(x))**(1/2),x);


int(sqrt(cos(x) + 1),x)

testint((1-cos(x))**(1/2),x);


int(sqrt( - cos(x) + 1),x)

testint(1/(x**(1/2)-(x-1)**(1/2)),x);


 2*(sqrt(x - 1)*x - sqrt(x - 1) + sqrt(x)*x)
---------------------------------------------
                      3

testint(1/(1-(x+1)**(1/2)),x);


 - 2*(sqrt(x + 1) + log(sqrt(x + 1) - 1))

testint(x/(x**4+36)**(1/2),x);


            4          2
      sqrt(x  + 36) + x
 log(--------------------)
              6
---------------------------
             2

testint(1/(x**(1/3)+x**(1/2)),x);


   1/6      1/3                      1/6
6*x    - 3*x    + 2*sqrt(x) - 6*log(x    + 1)

testint(log(2+3*x**2),x);


                   3*x                2
 2*sqrt(6)*atan(---------) + 3*log(3*x  + 2)*x - 6*x
                 sqrt(6)
-----------------------------------------------------
                          3

testint(cot(x),x);


            x  2                 x
 - log(tan(---)  + 1) + log(tan(---))
            2                    2

testint(cot x**4,x);


          3
  - cot(x)  + 3*cot(x) + 3*x
-----------------------------
              3

testint(tanh(x),x);


     2*x
log(e    + 1) - x

testint(coth(x),x);


     x             x
log(e  - 1) + log(e  + 1) - x

testint(b**x,x);


    x
   b
--------
 log(b)

testint((x**4+x**(-4)+2)**(1/2),x);


  4
 x  - 3
--------
  3*x

testint((2*x+1)/(3*x+2),x);


  - log(3*x + 2) + 6*x
-----------------------
           9

testint(x*log(x+(x**2+1)**(1/2)),x);


          2                      2            2             2
  - sqrt(x  + 1)*x + 2*log(sqrt(x  + 1) + x)*x  + log(sqrt(x  + 1) + x)
------------------------------------------------------------------------
                                   4

testint(x*(e**x*sin(x)+1)**2,x);


       2*x                    2*x                    x               x
( - 2*e   *cos(x)*sin(x)*x + e   *cos(x)*sin(x) - 8*e *cos(x)*x + 8*e *cos(x)

       2*x       2      2*x      2*x      x               2
  + 2*e   *sin(x) *x + e   *x - e    + 8*e *sin(x)*x + 4*x )/8

testint(x*e**x*cos(x),x);


  x
 e *(cos(x)*x + sin(x)*x - sin(x))
-----------------------------------
                 2


Comment the following set came from Herbert Stoyan;


testint(1/(x-3)**4,x);


            - 1
---------------------------
     3      2
 3*(x  - 9*x  + 27*x - 27)

testint(x/(x**3-1),x);


                 2*x + 1          2
 2*sqrt(3)*atan(---------) - log(x  + x + 1) + 2*log(x - 1)
                 sqrt(3)
------------------------------------------------------------
                             6

testint(x/(x**4-1),x);


         2
  - log(x  + 1) + log(x - 1) + log(x + 1)
------------------------------------------
                    4

testint(log(x)*(x**3+1)/(x**4+2),x);


            log(x)               log(x)             2
  - 4*int(----------,x) + 2*int(--------,x) + log(x)
            5                     4
           x  + 2*x              x  + 2
------------------------------------------------------
                          2

testint(log(x)+log(x+1)+log(x+2),x);


log(x + 2)*x + 2*log(x + 2) + log(x + 1)*x + log(x + 1) + log(x)*x - 3*x

testint(1/(x**3+5),x);


                            1/3
  1/3                      5    - 2*x           2/3    1/3      2
(5   *( - 2*sqrt(3)*atan(--------------) - log(5    - 5   *x + x )
                                   1/3
                          sqrt(3)*5

                 1/3
        + 2*log(5    + x)))/30

testint(1/sqrt(1+x**2),x);


          2
log(sqrt(x  + 1) + x)

testint(sqrt(x**2+3),x);


                               2
       2                 sqrt(x  + 3) + x
 sqrt(x  + 3)*x + 3*log(------------------)
                             sqrt(3)
--------------------------------------------
                     2

testint(x/(x+1)**2,x);


 log(x + 1)*x + log(x + 1) - x
-------------------------------
             x + 1


COMMENT The following integrals were used among others as a test of
	Moses' SIN program;


testint(asin x,x);


                     2
asin(x)*x + sqrt( - x  + 1)

testint(x**2*asin x,x);


             2
int(asin(x)*x ,x)

testint(sec x**2/(1+sec x**2-3*tan x),x);


                        x                                x
log( - sqrt(5) + 2*tan(---) + 1) - log( - sqrt(2) + tan(---) + 1)
                        2                                2

                        x                             x
 + log(sqrt(5) + 2*tan(---) + 1) - log(sqrt(2) + tan(---) + 1)
                        2                             2

testint(1/sec x**2,x);


 cos(x)*sin(x) + x
-------------------
         2

testint((5*x**2-3*x-2)/(x**2*(x-2)),x);


 3*log(x - 2)*x + 2*log(x)*x - 1
---------------------------------
                x

testint(1/(4*x**2+9)**(1/2),x);


              2
      sqrt(4*x  + 9) + 2*x
 log(----------------------)
               3
-----------------------------
              2

testint((x**2+4)**(-1/2),x);


           2
     sqrt(x  + 4) + x
log(------------------)
            2

testint(1/(9*x**2-12*x+10),x);


               3*x - 2
 sqrt(6)*atan(---------)
               sqrt(6)
-------------------------
           18

testint(1/(x**8-2*x**7+2*x**6-2*x**5+x**4),x);


        2       4          2       3                  4                  3
(3*log(x  + 1)*x  - 3*log(x  + 1)*x  - 30*log(x - 1)*x  + 30*log(x - 1)*x

               4              3       4       2                 3
  + 24*log(x)*x  - 24*log(x)*x  - 30*x  + 12*x  + 8*x + 4)/(12*x *(x - 1))

testint((a*x**3+b*x**2+c*x+d)/((x+1)*x*(x-3)),x);


(27*log(x - 3)*a + 9*log(x - 3)*b + 3*log(x - 3)*c + log(x - 3)*d

  - 3*log(x + 1)*a + 3*log(x + 1)*b - 3*log(x + 1)*c + 3*log(x + 1)*d

  - 4*log(x)*d + 12*a*x)/12

testint(1/(2-log(x**2+1))**5,x);


               2     5           2     4           2     3           2     2
 - int(1/(log(x  + 1)  - 10*log(x  + 1)  + 40*log(x  + 1)  - 80*log(x  + 1)

                     2
           + 80*log(x  + 1) - 32),x)


% The next integral appeared in Risch's 1968 paper.

testint(2*x*e**(x**2)*log(x)+e**(x**2)/x+(log(x)-2)/(log(x)**2+x)**2+
    ((2/x)*log(x)+(1/x)+1)/(log(x)**2+x),x);


   2             2
  x        3    x                       2            2             2
(e  *log(x)  + e  *log(x)*x + log(log(x)  + x)*log(x)  + log(log(x)  + x)*x

                   2
  - log(x))/(log(x)  + x)


% The following integral would not evaluate in REDUCE 3.3.

testint(exp(x*ze+x/2)*sin(pi*ze)**4*x**4,ze);


  (2*x*ze + x)/2  3                             3   3
(e              *x *( - 16*cos(pi*ze)*sin(pi*ze) *pi *x

                              3     3                              3
     - 4*cos(pi*ze)*sin(pi*ze) *pi*x  - 24*cos(pi*ze)*sin(pi*ze)*pi *x

                   4   2  2             4  4                2   2  2        4
     + 4*sin(pi*ze) *pi *x  + sin(pi*ze) *x  + 12*sin(pi*ze) *pi *x  + 24*pi ))/

      4        2  2    4
(64*pi  + 20*pi *x  + x )


% This one evaluates:

testint(erf(x),x);


   2
  x
 e  *erf(x)*pi*x + sqrt(pi)
----------------------------
             2
            x
           e  *pi


% So why not this one?

testint(erf(x+a),x);


int(erf(a + x),x)


Comment here is an example of using the integrator with pattern
	matching;


for all m,n let int(k1**m*log(k1)**n/(p**2-k1**2),k1)=foo(m,n),
		int(k1*log(k1)**n/(p**2-k1**2),k1)=foo(1,n),
		int(k1**m*log(k1)/(p**2-k1**2),k1)=foo(m,1),
		int(k1*log(k1)/(p**2-k1**2),k1)=foo(1,1),
		int(log(k1)**n/(k1*(p**2-k1**2)),k1)=foo(-1,n);



int(k1**2*log(k1)/(p**2-k1**2),k1);


*** foo declared operator 

foo(2,1)


Comment It is interesting to see how much of this one can be done;


let f1s= (12*log(s/mc**2)*s**2*pi**2*mc**3*(-8*s-12*mc**2+3*mc)
	+ pi**2*(12*s**4*mc+3*s**4+176*s**3*mc**3-24*s**3*mc**2
	-144*s**2*mc**5-48*s*mc**7+24*s*mc**6+4*mc**9-3*mc**8))
	 /(384*e**(s/y)*s**2);



int(f1s,s);


   2        s/y      - s     9        s/y      - s     8
(pi *( - 4*e   *ei(------)*mc *s + 3*e   *ei(------)*mc *s
                     y                         y

             s/y      - s     7           s/y      - s     6
       - 48*e   *ei(------)*mc *s*y + 24*e   *ei(------)*mc *s*y
                      y                            y

              s/y      - s     5    2       s/y      - s     4    2
       - 144*e   *ei(------)*mc *s*y  + 36*e   *ei(------)*mc *s*y
                       y                             y

             s/y      - s     3    3             s      5    2
       - 96*e   *ei(------)*mc *s*y  + 144*log(-----)*mc *s*y
                      y                           2
                                                mc

                  s      4    2            s      3  2  2
       - 36*log(-----)*mc *s*y  + 96*log(-----)*mc *s *y
                   2                        2
                 mc                       mc

                  s      3    3       9         8           5    2
       + 96*log(-----)*mc *s*y  - 4*mc *y + 3*mc *y + 144*mc *s*y
                   2
                 mc

               3  2  2        3    3        2  2  2        2    3          3  2
       - 176*mc *s *y  - 80*mc *s*y  + 24*mc *s *y  + 24*mc *s*y  - 12*mc*s *y

                2  3            4      3  2      2  3        4         s/y
       - 24*mc*s *y  - 24*mc*s*y  - 3*s *y  - 6*s *y  - 6*s*y ))/(384*e   *s*y)


factor ei,log;



ws;


  s/y      - s     3   2
(e   *ei(------)*mc *pi *s
           y

          6       5        4          3           2  2          2       3
 *( - 4*mc  + 3*mc  - 48*mc *y + 24*mc *y - 144*mc *y  + 36*mc*y  - 96*y )

             s      3   2    2       2                         2           9
  + 12*log(-----)*mc *pi *s*y *(12*mc  - 3*mc + 8*s + 8*y) + pi *y*( - 4*mc
              2
            mc

           8         5             3  2          3    2        2  2
     + 3*mc  + 144*mc *s*y - 176*mc *s *y - 80*mc *s*y  + 24*mc *s *y

            2    2          3            2  2            3      3        2  2
     + 24*mc *s*y  - 12*mc*s *y - 24*mc*s *y  - 24*mc*s*y  - 3*s *y - 6*s *y

            3         s/y
     - 6*s*y ))/(384*e   *s*y)


Comment the following is an example of integrals that used to loop
        forever.  They were first revealed by problems with Bessel
	function integration when specfn was loaded,
	e.g., int(x*besseli(2,x),x) or int(besselj(n,x),x);


operator f;

 let {df(f(~x),x) => x*f(x-1)};



int(f x,x);


int(f(x),x)



Comment the following integrals reveal deficiencies in the current
integrator;


%high degree denominator;
%testint(1/(2-log(x**2+1))**5,x);

%this example should evaluate;
testint(sin(2*x)/cos(x),x);


     sin(2*x)
int(----------,x)
      cos(x)


%this example, which appeared in Tobey's thesis, needs factorization
%over algebraic fields. It currently gives an ugly answer and so has
%been suppressed;

% testint((7*x**13+10*x**8+4*x**7-7*x**6-4*x**3-4*x**2+3*x+3)/
%         (x**14-2*x**8-2*x**7-2*x**4-4*x**3-x**2+2*x+1),x);

symbolic summarize!-integral!-test();

                *****     SUMMARY OF INTEGRAL TESTS     *****

Number of integrals tested: 276

Total time taken: 638 ms

Number of incorrect integrals: 0

Number of unevaluated integrals: 19

Integrands of unevaluated integrals are:


log(log(log(log(x))))


      p
sin(x)


      4  3
tan(x) *x


      6  3
tan(x) *x


        xi
 cos(--------)*cos(x)*x
      sin(x)
------------------------
              2
        sin(x)


        x
       a *x
-------------------
  2  2
 b *x  + 2*b*x + 1


    x
   e
  e
 e
e


           1
------------------------
          4    2
 sqrt( - x  + x  - 1)*x


            2    2
 sqrt(sqrt(a  + x ) + x)
-------------------------
            x


              2
           3*x
---------------------------
         3           3
 2*sqrt(x  + 1) + 2*x  + 2


sqrt(sin(x) + 1)


sqrt( - sin(x) + 1)


sqrt(cos(x) + 1)


sqrt( - cos(x) + 1)


         3
 log(x)*x  + log(x)
--------------------
        4
       x  + 2


         2
asin(x)*x


             2     5           2     4           2     3           2     2
( - 1)/(log(x  + 1)  - 10*log(x  + 1)  + 40*log(x  + 1)  - 80*log(x  + 1)

                   2
         + 80*log(x  + 1) - 32)


erf(a + x)


 sin(2*x)
----------
  cos(x)



end;


Time for test: 653 ms, plus GC time: 16 ms
@@@@@ Resources used: (1 8 103 2)
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/0000755000175000017500000000000011722677360021776 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/mri/0000755000175000017500000000000011722677357022573 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/mri/mri_ofsf.red0000644000175000017500000000431611526203062025053 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: mri_ofsf.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2008-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(mri_ofsf_rcsid!* mri_ofsf_copyright!*);
   mri_ofsf_rcsid!* :=
      "$Id: mri_ofsf.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   mri_ofsf_copyright!* := "Copyright (c) 2008-2009 T. Sturm"
>>;

module mri_ofsf;

load!-package 'redlog;
load!-package 'ofsf;

rl_copyc('mri_ofsf,'ofsf);

rl_bbiadd('mri_ofsf,'rl_simplat1!*,'mri_simplat1);
rl_bbiadd('mri_ofsf,'rl_negateat!*,'mri_negateat);
rl_bbiadd('mri_ofsf,'rl_simplb!*,'mri_simplb);  % for now
rl_bbiadd('mri_ofsf,'rl_bsatp!*,'mri_bsatp);    % for now

rl_cswadd('mri_ofsf,'rlsism,nil);
rl_cswadd('mri_ofsf,'rlsusi,nil);

endmodule;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/mri/mri.red0000644000175000017500000002255511526203062024043 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: mri.red 391 2009-07-28 07:02:23Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2008-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(mri_rcsid!* mri_copyright!*);
   mri_rcsid!* := "$Id: mri.red 391 2009-07-28 07:02:23Z thomas-sturm $";
   mri_copyright!* := "Copyright (c) 2008-2009 T. Sturm"
>>;

module mri;
% Mixed real-integer quantifier elimination.

create!-package('(mri mriqe),nil);

load!-package 'cl;
load!-package 'pasf;
load!-package 'ofsf;
load!-package 'rltools;

fluid '(!*msg !*rlverbose);

switch rlmrivb,rlmrivbio,rlsimplfloor,rlmrivb2;;

on1 'rlmrivb;
off1 'rlmrivb2;
on1 'rlsimplfloor;

flag('(mri),'rl_package);
flag('(mri_chsimpat),'full);
flag('(mri_simpat),'full);
flag('(equal neq leq geq lessp greaterp),'spaced);

put('mri,'rl_cswitches,'(
   (rlsism . nil)));

% Parameters
put('mri,'rl_params,'(
   (rl_simplat1!* . mri_simplat1)
   (rl_op!* . mri_op)
   (rl_negateat!* . mri_negateat)
   (rl_tordp!* . ordp)
   (rl_simplb!* . mri_simplb)
   (rl_bsatp!* . mri_bsatp)
   (rl_ordatp!* . mri_ordatp)
   (rl_subat!* . mri_subat)
   (rl_subalchk!* . null)
   (rl_eqnrhskernels!* . mri_eqnrhskernels)
   (rl_bnfsimpl!* . cl_bnfsimpl)
   (rl_smsimpl!-impl!* . cl_smsimpl!-impl)
   (rl_smsimpl!-equiv1!* . cl_smsimpl!-equiv1)
   (rl_susibin!* . mri_susibin)
   (rl_susipost!* . mri_susipost)
   (rl_susitf!* . mri_susitf)));

% Services
put('mri,'rl_services,'(
   (rl_simpl!* . cl_simpl)
   (rl_nnf!* . cl_nnf)
   (rl_atnum!* . cl_atnum)
   (rl_varlat!* . mri_varlat)
   (rl_atl!* . cl_atl)
   (rl_subfof!* . cl_subfof)	 
   (rl_expand!* . mri_expand)
   (rl_qe!* . mri_qe)));

put('mri,'simpfnname,'mri_simpfn);
put('mri,'rl_prepat,'mri_prepat);
put('mri,'rl_resimpat,'mri_resimpat);
put('mri,'rl_lengthat,'mri_lengthat);
put('mri,'rl_prepterm,'prepf);
put('mri,'rl_simpterm,'mri_simpterm);

put('equal,'mri_simpfn,'mri_chsimpat);

put('neq,'mri_simpfn,'mri_chsimpat);

put('leq,'mri_simpfn,'mri_chsimpat);

put('geq,'mri_simpfn,'mri_chsimpat);

put('lessp,'mri_simpfn,'mri_chsimpat);

put('greaterp,'mri_simpfn,'mri_chsimpat);

put('cong,'mri_simpfn,'mri_simpat);

put('ncong,'mri_simpfn,'mri_simpat);

put('floor,'prifn,'mri_prifloor);

put('mrireal,'stat,'rlis);

put('mriclear,'stat,'rlis);

procedure mri_prifloor(u);
   if null !*nat then
      'failed
   else <<
      prin2!* "[";
      maprin cadr u;
      prin2!* "]"
   >>;

procedure mrireal(varl);
   <<
      for each v in varl do put(v,'mri_type,'real);
      rmsubs()
   >>;

procedure mri_putreal(v);
   <<
      put(v,'mri_type,'real);
      rmsubs()
   >>;

procedure mri_realvarp(id);
   idp id and get(id,'mri_type) eq 'real;

procedure mriclear(varl);
   <<
      for each v in varl do remprop(v,'mri_type);
      rmsubs()
   >>;

procedure mri_simpat(u);
   begin scalar w;
      w := pasf_simpat u;
      return mri_pasf2mriat(w,nil)
   end;

procedure mri_chsimpat(u);
   begin scalar w;
      w := pasf_chsimpat u;
      return mri_pasf2mri(w,nil)
   end;

procedure mri_resimpat(u);
   mri_pasf2mriat(pasf_resimpat mri_2pasfat u,nil);

procedure mri_pasf2mri(f,type);
   cl_apply2ats1(f,function mri_pasf2mriat,{type});

procedure mri_2pasf(f);
   cl_apply2ats(f,function mri_2pasfat);

procedure mri_pasf2mriat(at,type);
   mri_0mk2(pasf_op at,pasf_arg2l at,type);

procedure mri_ofsf2mri(f,type);
   cl_apply2ats1(f,function mri_ofsf2mriat,{type});

procedure mri_ofsf2mriat(at,type);
   mri_0mk2(ofsf_op at,ofsf_arg2l at,type);

procedure mri_prepat(u);
   pasf_prepat mri_2pasfat u;

procedure mri_2pasfat(at);
   pasf_0mk2(mri_op at,mri_arg2l at);

procedure mri_2ofsfat(at);
   ofsf_0mk2(mri_op at,mri_arg2l at);

procedure mri_op(atf);
   % Mixed-real-integer operator. [atf] is an atomic formula
   % $r(t_1,t_2)$ or $r(t_1,t_2,m)$. Returns $r$ or in case of a
   % congruence the pair $(r . m)$.
   car atf;

procedure mri_opn(atf);
   (if atom w then w else car w) where w=mri_op atf;

procedure mri_m(atf);
   % Mixed-real-integer modulus operator. [atf] is an atomic formula
   % $t_1 \equiv_m t_2$. Returns $m$.
   cdadr atf;

procedure mri_type(atf);
   % Mixed-real-integer type. [atf] is an atomic formula. Returns the
   % type of atf, which is ['real], ['int], or [nil].
   cdddr atf and cadddr atf;

procedure mri_arg2l(atf);
   % Mixed-real-integer left hand side argument. [atf] is an atomic
   % formula $r(t_1,t_2)$. Returns $t_1$.
   cadr atf;

procedure mri_mkop(op,m);
   % Mixed-real-integer make operator. [op] is an operator; [m] is an
   % optional modulus. Returns $op$ if the operator is not 'cong or
   % 'ncong and $([op] . [m])$ otherwise.
   op . m;

procedure mri_0mk2(op,lhs,type);
   % Mixed-real-integer make zero right hand atomic formula. [op] is
   % an operator; [lhs] is a term; [type] is one of ['real], ['int],
   % ['nil]. Returns the atomic formula $[op]([lhs],0)$.
   {op,lhs,nil,type};

procedure mri_atfp(f);
   % Mixed-real-integer atomic formula predicate. [f] is a formula.
   % Returns non-[nil] iff [f] has a legal relation name.
   mri_opn f memq '(equal neq leq geq lessp greaterp cong ncong);

procedure mri_congp(atf);
   % Mixed-real-integer congruence predicate. [atf] is an atomic
   % formula. Returns non-[nil] iff the operator is 'cong or 'ncong.
   mri_opn atf memq '(cong ncong);

procedure mri_simplat1(at,sop);
   begin scalar type,w;
      if !*rlsimplfloor then
	 at := mri_0mk2(mri_op at,mri_simplfloor mri_arg2l at,mri_type at);
      type := mri_type at or mri_dettype at;
      if type eq 'int then
	 return mri_pasf2mri(pasf_simplat1(mri_2pasfat at,sop),'int);
      if not mri_congp at then
	 return mri_ofsf2mri(ofsf_simplat1(mri_2ofsfat at,sop),'real);
      return mri_0mk2(mri_op at,mri_arg2l at,type)
   end;

procedure mri_simplfloor(lhs);
   if not mri_floorkernelp lhs then
      lhs
   else
      mri_simplfloor1 lhs;

procedure mri_simplfloor1(lhs);
   begin scalar l,r,w;
      if domainp lhs then
	 return lhs;
      l := mri_simplfloor lc lhs;
      r := mri_simplfloor red lhs;
      w := mri_irsplit mvar lhs;
      return addf(multf(l,exptf(addf(car w,cdr w),ldeg lhs)),r)
   end;

procedure mri_irsplit(k);
   begin scalar w;
      if not eqcar(k,'floor) then
      	 return !*k2f k . nil;
      w := mri_irsplit1 mri_simplfloor numr simp cadr k;
      return car w . if cdr w then !*k2f !*a2k {'floor,prepf cdr w} 
   end;

procedure mri_irsplit1(k);
   begin scalar l,r,v; integer d;
      if domainp k then
      	 return k . nil;
      r := mri_irsplit1 red k;
      d := ldeg k;
      v := exptf(!*k2f mvar k,d);
      if mri_realvarp mvar v then
	 return car r . addf(multf(lc k,v),cdr r);
      l := mri_irsplit1 lc k;
      return addf(multf(car l,v),car r) . addf(multf(cdr l,v),cdr r)
   end;

procedure mri_floorkernelp(f);
   mri_floorp kernels f;

procedure mri_floorp(l);
   l and (eqcar(car l,'floor) or mri_floorp cdr l);

procedure mri_dettype(at);
   begin scalar varl,v,c,foundreal,foundint;
      varl := kernels mri_arg2l at;
      if null varl then
	 return 'int;
      c := t; while c and varl do <<
	 v := car varl;
	 varl := cdr varl;
	 if mri_realvarp v then
	    if foundint then
 	       c := foundint := foundreal := nil
	    else
	       foundreal := 'real
	 else
	    if foundreal then
 	       c := foundint := foundreal := nil
	    else
	       foundint := 'int
      >>;
      return foundint or foundreal
   end;

procedure mri_negateat(at);
   mri_pasf2mriat(pasf_negateat mri_2pasfat at,mri_type at);

procedure mri_varlat(at);
   pasf_varlat mri_2pasfat at;

procedure mri_ordatp(at1,at2);
   pasf_ordatp(mri_2pasfat at1,mri_2pasfat at2);

procedure mri_simplb(f,v);
   pasf_simplb(f,v);

procedure mri_bsatp(f,var);
   f eq 'true;

procedure mri_subat(al,at);
   mri_0mk2(mri_op at,numr subf(mri_arg2l at,al),nil);

procedure mri_eqnrhskernels(x);
   nconc(kernels numr w,kernels denr w) where w=simp cdr x;

procedure mri_expand(f);
   begin scalar !*rlverbose;
      return if mri_bqp f then mri_pasf2mri(pasf_expand mri_2pasf f,nil) else f
   end;

procedure mri_bqp(f);
   smemq('bex,f) or smemq('ball,f);
   
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/mri/mri_pasf.red0000644000175000017500000000432011526203062025042 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: mri_pasf.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2008-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(mri_pasf_rcsid!* mri_pasf_copyright!*);
   mri_pasf_rcsid!* :=
      "$Id: mri_pasf.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   mri_pasf_copyright!* := "Copyright (c) 2008-2009 T. Sturm"
>>;

module mri_pasf;

load!-package 'redlog;
load!-package 'pasf;

rl_copyc('mri_pasf,'pasf);

rl_bbiadd('mri_pasf,'rl_simplat1!*,'mri_simplat1);
rl_bbiadd('mri_pasf,'rl_negateat!*,'mri_negateat);
%rl_bbiadd('mri_pasf,'rl_simplb!*,'mri_simplb);  % for now
%rl_bbiadd('mri_pasf,'rl_bsatp!*,'mri_bsatp);    % for now

rl_cswadd('mri_pasf,'rlsism,nil);
rl_cswadd('mri_pasf,'rlsusi,nil);

endmodule;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/mri/mriqe.red0000644000175000017500000003074711526203062024373 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: mriqe.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2008-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(mri_qe_rcsid!* mri_qe_copyright!*);
   mri_qe_rcsid!* :=
      "$Id: mriqe.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   mri_qe_copyright!* := "Copyright (c) 2008-2009 T. Sturm"
>>;

module mriqe;

procedure mri_qe(f,theo);
   begin scalar w,q,ql,varl,varll;
      if !*rlverbose then
	 ioto_tprin2t {"++++++ MRI entering mri_qe"};
%      if !*rlqepnf then f := rl_pnf f;
      if theo then lprim {"mri_mriqe: ignoring theory"};
      f := cl_simpl(f,nil,-1);
      if not rl_quap rl_op f then
	 return f;
      w := mri_splitqf f; ql := car w; varll := cadr w; f := caddr w;
      while ql do <<
      	 q := car ql;
      	 ql := cdr ql;
      	 varl := car varll;
      	 varll := cdr varll;
      	 if !*rlverbose then
      	    ioto_tprin2 {"+++++ MRI current block is ", q . reverse varl};
 	 f := mri_qeblock(f,q,varl);
      >>;
      return f
   end;

procedure mri_splitqf(f);
   % Split [f] into a quantifier list, a list of variable lists, and
   % its matrix.
   begin scalar q,op,ql,varl,varll;
      q := op := rl_op f;
      repeat <<
   	 if op neq q then <<
      	    ql := q . ql;
      	    varll := varl . varll;
      	    q := op;
      	    varl := nil
   	 >>;
   	 varl := rl_var f . varl;
   	 f := rl_mat f
      >> until not rl_quap(op := rl_op f);
      ql := q . ql;
      varll := varl . varll;
      return {ql,varll,f}
   end;

procedure mri_qeblock(f,q,varl);
   if q eq 'ex then
      mri_qeblock1(f,varl)
   else
      cl_nnfnot mri_qeblock1(cl_nnfnot f,varl);

procedure mri_qeblock1(f,varl);
   begin scalar v,w;
      while varl do <<
	 v := mri_varsel varl;
	 varl := delq(v,varl);
	 if mri_realvarp v then <<
	    mri_vbin("+++ MRI expanding bounded quantifiers for real qe",f);
	    w := mri_expand f;
	    mri_vbout(f,w);
	    w := mri_qereal(w,v);
	    f := car w;
	    varl := cdr w . varl
	 >> else
 	    f := mri_qeint(f,v)
      >>;
      return f
   end;

procedure mri_varsel(varl);
   begin scalar w;
      if !*rlverbose and !*rlmrivb then
      	 ioto_tprin2 {"++++ MRI picking next variable from ",reverse varl,
	    " ... "};
      w := mri_varselreal varl;
      ioto_prin2 if w then {w," (real)"} else {car varl," (integer)"};
      return w or car varl
   end;

procedure mri_varselreal(varl);
   if varl then
      if mri_realvarp car varl then
 	 car varl
      else
 	 mri_varselreal cdr varl;

procedure mri_qereal(f,v);
   begin scalar w,vint,vtrunc;
      w := mri_truncate(f,v);
      f := car w;
      vtrunc := cadr w;
      vint := caddr w;
      if !*rlverbose then
	 ioto_tprin2 {"++++ MRI introduced new quantified variables ",vtrunc,
	    " and ",vint," for ",v};
      w := rl_mkq('ex,vtrunc,mri_case2(mri_lemma33(f,vtrunc),vtrunc));
      if !*rlverbose then
	 ioto_tprin2 {"+++ MRI entering real qe for ",vtrunc," ... "};
      w := mri_qereal1 w;
      if !*rlverbose then <<
	 ioto_prin2 "finished";
	 mathprint rl_mk!*fof w
      >>;
      return w . vint
   end;

procedure mri_qereal1(f);
   begin scalar w,!*rlverbose,!*msg;
      !*rlverbose := !*rlmrivb2;
      rl_set '(mri_ofsf);
      w := rl_qe(f,nil);
      rl_set '(mri);
      return w
   end;

procedure mri_truncate(f,u);
   begin scalar utrunc,uint,w;
      mri_vbin({"+++ MRI truncating ",u},f);
      utrunc := intern lto_idconcat2(u,'!_trunc);
      mri_putreal utrunc;
      uint := intern lto_idconcat2(u,'!_int);
      w := mri_smartand {mri_0mk2('geq,!*k2f utrunc,'real),
	 mri_0mk2('lessp,addf(!*k2f utrunc,negf 1),'real),
	 rl_subfof({u . {'plus,uint,utrunc}},f)};
      mri_vbout(f,w);
      return {w,utrunc,uint}
   end;

procedure mri_smartand(l);
   rl_smkn('and,for each f in l join
      if rl_op f eq 'and then append(rl_argn f,nil) else {f});

procedure mri_vbin(msg,f);
   if !*rlverbose then
      if !*rlmrivb then <<
	 ioto_tprin2 msg;
	 if !*rlmrivbio then <<
	    ioto_tprin2 "+++ in:";
      	    mathprint rl_mk!*fof f
	 >>
      >>;
   
procedure mri_vbout(f,w);
   if !*rlverbose then
      if !*rlmrivb then <<
      	 if !*rlmrivbio then <<
	    ioto_prin2 "+++ out:";
	    mathprint rl_mk!*fof w
      	 >> else if w neq f then
	    mathprint rl_mk!*fof w
      	 else
	    ioto_prin2 " - no changes"
      >>;

procedure mri_lemma33(f,u);
   begin scalar w;
      mri_vbin({"+++ MRI applying Lemma 3.3 (remove ",u," from floors)"},f);
      w := cl_apply2ats1(f,function mri_lemma33at,{u});
      mri_vbout(f,w);
      return w
   end;

procedure mri_lemma33at(at,u);
   begin scalar lhs,cd,phi,s,n;
      lhs := mri_arg2l at;
      if not mri_floorkernelp lhs then
	 return at;
      cd := mri_lemma33f(lhs,u);
      return rl_smkn('or,for each c in cd collect <<
	 phi := car c;
	 s := cadr c;
	 n := caddr c;
	 rl_mkn('and,{phi,mri_0mk2(mri_op at,addf(multf(n,!*k2f u),s),'real)})
      >>)
   end;

procedure mri_lemma33f(f,u);
   begin scalar cdlc,cdkern,cdred;
      if domainp f then
	 return {{'true,f,nil}};
      cdlc := mri_lemma33f(lc f,u);
      cdkern := mri_lemma33k(mvar f,u);
      cdred := mri_lemma33f(red f,u);
      return mri_add33(mri_mult33(cdlc,mri_expt33(cdkern,ldeg f)),cdred)
   end;

procedure mri_lemma33k(ker,u);
   begin scalar cd,phi,s,n,phij,fs,fsj,fsj1,ss;
      if ker eq u then
	 return {{'true,nil,1}};
      if idp ker then
	 return {{'true,!*k2f ker,nil}};
      if not eqcar(ker,'floor) then
	 rederr {"invalid kernel",ker};
      cd := mri_lemma33f(numr simp cadr ker,u);
      phi := car cd;
      s := cadr cd;
      n := caddr cd;
      if not domainp n then  % mri_mult33 should have complained before
	 rederr "mri_lemma33k: real variable with parametric coefficient";
      return for j:=0:n collect <<
	 fs := !*k2f !*a2k {'floor,prepf s};
	 fsj := addf(fs,j);
	 fsj1 := addf(fsj,1);
	 ss := addf(multf(n,!*k2f u),fs);
	 phij := rl_mkn('and,{phi,
	    mri_0mk2('leq,addf(fsj,negf ss),'real),
	    mri_0mk2('lessp,addf(ss,negf fsj1),'real)});
	 {phij,fsj,nil}
      >>
   end;

procedure mri_add33(cd1,cd2);
   begin scalar phi1,phi2,s1,s2,n1,n2;
      return for each t1 in cd1 join <<
	 phi1 := car t1;
	 s1 := cadr t1;
	 n1 := caddr t1;
      	 for each t2 in cd2 collect <<
	    phi2 := car t2;
	    s2 := cadr t2;
	    n2 := caddr t2;
	    {rl_mkn('and,{phi1,phi2}),addf(s1,s2),addf(n1,n2)}
	 >>
      >>
   end;

procedure mri_mult33(cd1,cd2);
   begin scalar phi1,phi2,s1,s2,n1,n2;
      return for each t1 in cd1 join <<
	 phi1 := car t1;
	 s1 := cadr t1;
	 n1 := caddr t1;
      	 for each t2 in cd2 collect <<
	    phi2 := car t2;
	    s2 := cadr t2;
	    n2 := caddr t2;
	    if n1 and n2 then
	       rederr "mri_mult33: real variable with degree > 1";
	    if (n1 or n2) and (not domainp s1 or not domainp s2) then
	       rederr "mri_mult33: real variable with parametric coefficient";
	    {rl_mkn('and,{phi1,phi2}),
	       multf(s1,s2),addf(multf(n1,s2),multf(n2,s1))}
      	 >>
      >>
   end;

procedure mri_expt33(cd,k);
   begin scalar phi,s,n;
      return for each c in cd collect <<
      	 phi := car c;
      	 s := cadr c;
      	 n := caddr c;
      	 if n and k>1 then
	    rederr "mri_expt33: real variable with degree > 1";
	 {phi,exptf(s,k),n}
      >>
   end;
      
procedure mri_qeint(f,v);
   begin scalar w;
      w := rl_mkq('ex,v,mri_case1(mri_lemma32(f,v),v));
      if !*rlverbose then
	 ioto_tprin2 {"+++ MRI entering integer qe for ",v," ... "};
      w := mri_qeint1(w);
      if !*rlverbose then <<
	 ioto_prin2 "finished";
	 mathprint rl_mk!*fof w
      >>;
      return w
   end;

procedure mri_qeint1(f);
   begin scalar w,!*msg,!*rlverbose;
      !*rlverbose := !*rlmrivb2;
      rl_set '(mri_pasf);
      w := pasf_wqe(f,nil);
      rl_set '(mri);
      return w
   end;

procedure mri_lemma32(f,xi);
   begin scalar w;
      mri_vbin({"+++ MRI applying Lemma 3.2 (remove ",xi," from floors)"},f);
      w := cl_apply2ats1(f,function mri_lemma32at,{xi});
      mri_vbout(f,w);
      return w
   end;
	 
procedure mri_lemma32at(f,xi);
   mri_0mk2(mri_op f,mri_lemma32f(mri_arg2l f,xi),mri_type f);

procedure mri_lemma32f(u,xi);
   begin scalar w,c,v,r,xpnd;
      if domainp u then
 	 return u;
      c := mri_lemma32f(lc u,xi);
      r := mri_lemma32f(red u,xi);
      v := mvar u;
      if idp v then
 	 return addf(exptf(multf(c,!*k2f v),ldeg u),r);
      w := sfto_reorder(numr simp cadr v,xi);
      if domainp w or not (mvar w eq xi) then
 	 return addf(exptf(multf(c,!*k2f v),ldeg u),r);
      xpnd := addf(multf(lc w,!*k2f xi),numr simp {'floor,prepf red w});
      return addf(exptf(multf(c,xpnd),ldeg u),r)
   end;

procedure mri_case1(f,xi);
   begin scalar w;
      mri_vbin({"+++ MRI applying Theorem 3.1 Case 1 (restrict ",xi,
	 " to integer atfs)"},f);
      w := cl_simpl(cl_apply2ats1(f,function mri_case1at,{xi}),nil,-1);
      mri_vbout(f,w);
      return w
   end;      

procedure mri_case1at(f,xi);
   begin scalar lhs,nxi,s,fs,op;
      lhs := sfto_reorder(mri_arg2l f,xi);
      if domainp lhs or not (mvar lhs eq xi) then
 	 return f;
      nxi := multf(lc lhs,!*k2f mvar lhs);
      s := negf red lhs;
      fs := numr simp {'floor,prepf s};
      op := mri_op f;
      return mri_case1at1(op,nxi,s,fs)
   end;

procedure mri_case1at1(op,nxi,s,fs);
   if op eq 'neq then
      cl_nnfnot mri_case1at2('equal,nxi,s,fs)
   else if op eq 'geq then
      cl_nnfnot mri_case1at2('lessp,nxi,s,fs)
   else if eqcar(op,'ncong) then
      cl_nnfnot mri_case1at2(mri_mkop('cong,cdr op),nxi,s,fs)
%   else if op eq 'leq then
%      rl_mkn('or,{mri_case1at2('lessp,nxi,s,fs),mri_case1at2('equal,nxi,s,fs)})
   else if op eq 'greaterp then
%      cl_nnfnot rl_mkn('or,
%	 {mri_case1at2('lessp,nxi,s,fs),mri_case1at2('equal,nxi,s,fs)})
      cl_nnfnot mri_case1at2('leq,nxi,s,fs)
   else mri_case1at2(op,nxi,s,fs);

procedure mri_case1at2(op,nxi,s,fs);
   begin scalar w,ww,www;
      w := mri_0mk2(op,addf(nxi,negf fs),'int);
      if op eq 'equal or eqcar(op,'cong) then
      	 return rl_mkn('and,{w,mri_0mk2('equal,addf(s,negf fs),nil)});
      if op eq 'leq then
	 return w;
      % op eq 'lessp
      ww := mri_0mk2('equal,addf(nxi,negf fs),'int);
      www := mri_0mk2('lessp,addf(fs,negf s),nil);
      return rl_mkn('or,{w,rl_mkn('and,{ww,www})})
   end;
      
procedure mri_case2(f,u);
   begin scalar w;
      mri_vbin({"+++ MRI applying Theorem 3.1 Case 2 (remove ",u,
	 " from congruences)"},f);
      w := cl_simpl(cl_apply2ats1(f,function mri_case2at,{u}),nil,-1);
      mri_vbout(f,w);
      return w
   end;      

procedure mri_case2at(at,u);
   begin scalar w,n,s,fs,fsi,nums;
      if not mri_congp at or not (u memq kernels mri_arg2l at) then
	 return at;
      w := sfto_reorder(mri_arg2l at,u);
      if ldeg w neq 1 then
	 rederr "mri_case2at: real variable with degree > 1";
      n := lc w;
      if not domainp n then
	 rederr "mri_case2at: real variable with parametric coefficient";
      s := negf red w;
      fs := !*k2f !*a2k {'floor,prepf s};
      nums := addf(multf(n,!*k2f u),negf s);
      return rl_smkn('or,for i:=0:n collect <<
	 fsi := addf(fs,negf i);
      	 w := addf(nums,fsi);
	 rl_mkn('and,{mri_0mk2('equal,w,nil),mri_0mk2(mri_op at,fsi,'int)})
      >>)
   end;
      
endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/0000755000175000017500000000000011722677360022727 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfqe.red0000644000175000017500000013346111526203062024674 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfqe.red 607 2010-05-14 06:14:30Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(pasf_qe_rcsid!* pasf_qe_copyright!*);
   pasf_qe_rcsid!* :=
      "$Id: pasfqe.red 607 2010-05-14 06:14:30Z thomas-sturm $";
   pasf_qe_copyright!* :=
      "(c) 2002-2009 A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm"
>>;

module pasfqe;
% Presburger arithmetic standard form quantifier elimination. Submodule of
% PASF.

% ---- Quantifier elimination control ----------------------------------------

procedure pasf_qe(phi,theo);
   % Presburger arithmetic standard form quantifier elimination. [phi]
   % is a formula; [theo] is an explicit theory. Returns a strictly
   % quantifier-free formula equivalent to [phi].
   if null pasf_uprap phi then
      pasf_expand pasf_gqe(phi,theo,nil,simp 1)
   else
      rederr{"Only weak quantifier elimination possible"};

procedure pasf_wqe(phi,theo);
   % Presburger arithmetic standard form weak quantifier elimination.
   % [phi] is a formula; [theo] is an explicit theory. Returns a weakly
   % quantifier-free formula equivalent to [phi].
   pasf_gqe(phi,theo,nil,simp 1);

procedure pasf_qea(phi,theo);
   % Presburger arithmetic standard form quantifier elimination with
   % answers. [phi] is a formula; [theo] is an explicit theory. Returns
   % an answer to the quantifier elimination.
   if null pasf_uprap phi then
      pasf_expanda(pasf_wqea(phi,theo),phi)
   else
      rederr{"Only weak quantifier elimination possible"};

procedure pasf_wqea(phi,theo);
   % Presburger arithmetic standard form weak quantifier elimination
   % with answers. [phi] is a formula; [theo] is an explicit theory.
   % Returns an answer to the quantifier elimination.
   begin scalar res,ret;
      res := pasf_gqe(phi,theo,t,simp 1);
      for each r in res do
	 ret := {answ_f r,for each b in answ_bl r collect b,
      	    for each eqn in answ_tl r collect
	       pasf_mk2('equal,prepf pasf_arg2l eqn,prepsq pasf_arg2r eqn)} . ret;
      return ret
   end;

procedure pasf_pqe(phi,p,theo);
   % Presburger arithmetic standard form probabilistic weak quantifier
   % elimination. [phi] is a formula; [theo] is an explicit theory; [p]
   % is a probability for PQE. Returns a $p$-equivalent quantifier-free
   % formula.
   if null pasf_uprap phi then
      pasf_gqe(phi,theo,nil,p)
   else
      rederr{"Probabilistic quantifier elimination impossible"};

procedure pasf_pqea(phi,p,theo);
   % Presburger arithmetic standard form probabilistic weak quantifier
   % eliminationwith answers. [phi] is a formula; [theo] is an explicit
   % theory; [p] is a probability for PQE. Returns a $p$-equivalent
   % quantifier-free formula.
   if null pasf_uprap phi then
      pasf_expanda(pasf_pqea1(phi,theo,p),phi)
   else
      rederr{"Probabilistic quantifier elimination impossible"};

procedure pasf_pqea1(phi,theo,p);
   % Presburger arithmetic standard form probabilistic quantifier
   % elimination with answers subprocedure. [phi] is a formula; [theo]
   % is an explicit theory; [p] is a probability for PQE. Returns an
   % answer to the probabilistic quantifier elimination.
   begin scalar res,ret;
      res := pasf_gqe(phi,theo,t,p);
      for each r in res do
	 ret := {answ_f r,for each b in answ_bl r collect b,
      	    for each eqn in answ_tl r collect
	       pasf_mk2('equal,prepf pasf_arg2l eqn,prepsq pasf_arg2r eqn)} . ret;
      return ret
   end;

procedure pasf_gqe(phi,theo,answ,p);
   % Presburger arithmetic standard form generic compute a
   % quantifier-free formula equivalent. [phi] is a formula; [theo] is
   % the explicit theory; [answ] should be set to nil iff no answers are
   % required; [p] is the probability for PQE. Returns a quantifier-free
   % formula $\psi$ equivalent to $\phi$ if [answ] is nil and a pair
   % $(\psi . a)$ where $a$ is an answer for the last quantifier block
   % otherwise.
   begin scalar rslt,pt,retn,tmp,bl,tl;
      if !*rlverbose then ioto_tprin2 "++++ Entering pasf_qe";
      % Tests for correct UPrA form.
      % pasf_uprap(phi);
      % The formula is always simplified via input theory
      phi := cl_simpl(phi,theo,-1);
      % Performing DNF on the matrix if wanted
      rslt := if !*rlpasfdnffirst then
	 % Note: a pseudo DNF computation is performed. In the second case the
	 % pseudo-DNF is also in PNF, so a PNF is computed in any case.
    	 pasf_dnf phi
      else
      	 pasf_pnf phi;
      % Determining the problem type for answers
      if rl_op rslt eq 'ex or phi then pt := 'existential
      else if rl_op rslt eq 'all or phi then pt := 'universal
      % For now user has to specify the formula with a non-bounded quantifier
      % in front to get answers
      else if answ then rederr{"QE with answers impossible"};
      rslt := pasf_inplaceqe(rslt,theo,answ,p);
      % Tuning rslt to fit QE with answers result type
      if answ and rl_tvalp rslt then
	 rslt := {answ_new(rslt,nil,nil)};
      % The last step is always simplified via input theory
      if answ then <<
	 for each an in rslt do <<
	    tmp :=  cl_simpl(answ_f an,theo,-1);
	    bl := answ_bl an;
	    tl := answ_tl an;
	    % Results with false guard for existential and with true guard for
	    % universal problems will be ignored
	    if pt eq 'existential and tmp neq 'false or
	       pt eq 'universal and tmp neq 'true then
	    	  retn := lto_insert(answ_new(tmp,bl,tl),retn)
	 >>;
	 if null retn then retn := {answ_new('false,nil,nil)};
 	 return retn
      >> else
	 return cl_simpl(rslt,theo,-1)
   end;

procedure pasf_inplaceqe(phi,theo,answ,p);
   % Presburger arithmetic standard form inplace quantifier elimination.
   % [phi] is a formula; [theo] is a theory; [answ] is the answer flag,
   % [p] is the probability for PQE. Returns a quantifier-free
   % equivalent or an answer according to answ flag.
   begin scalar res;
      res := pasf_inplaceqe1(phi,theo,p);
      if cdr res then
      	 % The outermost block is eliminated explicitly
      	 return pasf_qeblock(cadr res,cddr res,car res,theo,
	    if answ then answ_new('true,nil,nil) else nil,p);
      return car res
   end;

procedure pasf_inplaceqe1(phi,theo,p);
   % Presburger arithmetic standard form inplace quantifier elimination
   % subprocedure. [phi] is a formula; [theo] is a theory; [p] is the
   % probability for PQE. Returns a quantifier-free equivalent.
   begin scalar tmp,f;
      % Note: We can ignore the answer because all the blocks qe called inside
      % this procedure with are not the outter-most
      if rl_bquap rl_op phi then <<
	 tmp := pasf_inplaceqe1(rl_mat phi,theo,p);
	 if cdr tmp then
	    % A normal quantifier block has ended by outter bounded quantifier
	    f := pasf_qeblock(cadr tmp,cddr tmp,car tmp,theo,nil,p)
	 else
	    f := car tmp;
	 return (rl_mkbq(rl_op phi,rl_var phi,rl_b phi,f) . nil)
      >>;
      if rl_quap rl_op phi then <<
	 tmp := pasf_inplaceqe1(rl_mat phi,theo,p);
	 return if cdr tmp then
 	    (if cadr tmp neq rl_op phi then
	       (pasf_qeblock(cadr tmp,cddr tmp,car tmp,theo,nil,p) .
	       	  (rl_op phi . {rl_var phi}))
	    else
	       (car tmp . (cadr tmp . (rl_var phi . cddr tmp))))
	 else
	    (car tmp . (rl_op phi . {rl_var phi}))
      >>;
      % Now, assuming that the formula is in PNF, the formula is strong
      % quantifier-free
      return (phi . nil)
   end;

procedure pasf_qeblock(theta,varl,psi,theo,answ,p);
   % Presburger arithmetic standrd form eliminate a block of
   % quantifiers. [theta] if the quantifier type; [varl] is a list of
   % bounded variables by the quantifier; [psi] is the matrix of the
   % formula; [theo] is the current theory; [answ] should be set to nil
   % if no answers are required; [p] is the probability for PQE. Returns
   % an equivalent quantifier-free formula or a pair $(\psi . a)$ where
   % $a$ is an answer.
   begin scalar res;integer dpth,vlv;
      if !*rlverbose then <<
	 ioto_tprin2 {"---- ",theta . reverse varl};
	 dpth := length varl;
      	 if !*rlqedfs then <<  % should not happen by now
	    vlv :=  dpth / 4;
	    ioto_prin2t {" [DFS: depth ",dpth,", watching ",dpth - vlv,"]"}
      	 >> else
	    ioto_prin2t {" [BFS: depth ",dpth,"]"}
      >>;
      if theta eq 'ex then
      	 res := pasf_qeexblock(varl,psi,dpth,vlv,theo,answ,p)
      else <<
	 % Handling of the all operator
      	 res := pasf_qeexblock(varl,cl_nnfnot psi,dpth,vlv,theo,answ,p);
      	 res := if answ then
	    for each an in res collect
	       answ_new(cl_nnfnot answ_f an,answ_bl an,answ_tl an)
      	 else
	    cl_nnfnot res
      >>;
      return res
   end;

procedure pasf_qeexblock(varl,psi,dpth,vlv,theo,answ,p);
   % Presburger arithmetic standrd form eliminate a block of existential
   % quantifiers. [varl] are the bounded variables; [psi] is the matrix
   % of the formula; [dpth] ist the recursion depth; [vlv] is a list of
   % variables; [theo] is a theory; [answ] is nil if no answers are
   % required; [p] is the probability for PQE. Returns an equivalent
   % quantifier-free formula or a pair $(\psi . a)$ where $a$ is an
   % answer.
   begin scalar co,cvl,w,coe,f,newj,v,ans; integer c,delc,oldcol,count;
      cvl := varl;
      if rl_op psi eq 'or then
	 for each x in rl_argn psi do
	    co := cl_save(co,{cl_mkcoel(cvl,x,answ,nil)})
      else
      	 co := cl_save(co,{cl_mkcoel(cvl,psi,answ,nil)});
      while co do <<
	 w := cl_get co;
	 co := cdr w;
	 coe := car w;
    	 cvl := cl_covl coe;
	 f := cl_cof coe;
	 count := count + 1;
	 if !*rlverbose then
	    if !*rlqedfs then <<
	       if vlv = length cvl then
	       	  ioto_tprin2t {"-- crossing: ",dpth - vlv};
	       ioto_prin2 {"[",dpth - length cvl}
	    >> else <<
	       if c=0 then <<
	       	  ioto_tprin2t {"-- left: ",length cvl};
		  c := cl_colength co + 1
	       >>;
	       ioto_nterpri(length explode c + 4);
	       ioto_prin2 {"[",c};
	       c := c - 1
	    >>;
	 % Variable selection
	 v := car cvl;
	 cvl := cdr cvl;
	 % Eliminating the selected variable
	 ans := pasf_qeex(f,v,theo,cl_coan coe,cvl,p);
	 if cvl then <<
	    if !*rlverbose then oldcol := cl_colength(co);
	    co := cl_save(co,ans);
	    if !*rlverbose then
	       delc := delc + oldcol + length ans - cl_colength(co)
	 >> else <<
	    if answ then
	       for each an in ans do
		  newj := lto_insert(cl_coan an,newj)
	    else
	       for each an in ans do newj := lto_insert(cl_cof an,newj)
	 >>;
	 if !*rlverbose then <<
	    ioto_prin2 "] ";
	    if !*rlqedfs and null cvl then ioto_prin2 ". "
      	 >>
      >>;
      if !*rlverbose then ioto_prin2{"[DEL:",delc,"/",count,"]"};
      return if answ then newj else rl_smkn('or,newj)
   end;

procedure pasf_qeex(psi,x,theo,answ,cvlm,p);
   % Presburger arithmetic standard form eliminate an existential
   % quantifier in front of a quantifier free formula. [psi] is a
   % formula; [x] is the quantified variable; [theo] is the current
   % theory; [answ] is an ANSW structure; [cvlm] is the variable list;
   % [p] is the probability for PQE. Returns a pair $(a . p) . theo'$
   % where $a=t$ and $p$ is a list of container elements and $theo'$ a
   % theory.
   begin scalar eset,dec,f,res,pcc,tmp;
      % PNF must be applied because of guards added during the substitution
      psi := pasf_pnf psi;
      if not (x memq cl_fvarl1 psi) then <<
      	 % The formula does not contain the quantified variable
	 if !*rlverbose then ioto_prin2 "*";
	 return {cl_mkcoel(cvlm,psi,answ_new(psi,nil,
	    if answ then
	       pasf_mk2('equal,numr simp x,simp 0) . answ_tl answ else nil),nil)}
      >>;
      if !*rlverbose then ioto_prin2 "e";
      % Computing a gauss decomposition of the input formula
      dec := if !*rlpasfgauss then
	 pasf_gaussdec(psi,x,theo)
      else
	 (nil . psi);
      if !*rlverbose and car dec then ioto_prin2 "g";
      % f is the formula resulting from psi by replacing all gauss subformulas
      % by false
      f := cl_simpl(cdr dec,theo,-1);
      if not (x memq cl_fvarl1 f) then <<
 	 % The non-gauss part of the formula does not contain the quantified
 	 % variable or is even possibly trivial
	 if !*rlverbose then ioto_prin2 "#"
      >> else
      	 % Computing the elimination set of the input without gauss-formulas
      	 eset := pasf_elimset(f,x,theo,p);
      % Computing the quantifier-free equivalent. Each item of the following
      % list contains an answer to the corresponding substitution point.
      pcc := 0;
      res := append(
	 % Substitution of points from non gauss formulas
	 if null eset and f neq 'false then {answ_new(f,nil,
	    if answ then
	       pasf_mk2('equal,numr simp x,simp 0) . answ_tl answ else nil)} else
	    for each elimpt in eset collect
	       pasf_vs(if !*rlpasfsc then <<
		  tmp := pasf_condense(f,elimpt_pos elimpt);
		  pcc := pcc + cdr tmp;
		  car tmp
	       >> else f,x,elimpt),
	 % Substitution of points from gauss formulas
	 for each elimpt in car dec collect
	    pasf_vs(if !*rlpasfgc then <<
	       tmp := pasf_condense(psi,elimpt_pos elimpt);
	       pcc := pcc + cdr tmp;
	       car tmp
	    >> else psi,x,elimpt));
      if !*rlverbose and pcc > 0 then <<
	 ioto_prin2 "c";
	 ioto_prin2 pcc
      >>;
      % Simplifying the results
      res := for each rs in res collect
	 answ_new(if !*rlpasfsimplify then
	    cl_simpl(answ_f rs,theo,-1) else answ_f rs,answ_bl rs,answ_tl rs);
      % Answers represent directly the output disjunction
      return for each an in res collect
	 cl_mkcoel(cvlm,answ_f an,answ_backsubst(an,answ),nil)
   end;

% ---- Virtual substitution --------------------------------------------------

procedure pasf_vs(f,x,elimpt);
   % Presburger arithmetic standard form virtual substitution. [f] is a
   % positive quantifier-free formula; [x] is a variable; [elimptl] is
   % an ELIMPT. Returns a list of ANSW structures.
   begin scalar res,tf,bvl,sf;
      % Creating the formula to substitute
      sf := cl_apply2ats1(f,'pasf_vsubstatf,
	 {x,elimpt_den elimpt,elimpt_nom elimpt,elimpt_unif elimpt});
      tf := rl_smkn('and, {sf,elimpt_guard elimpt});
      % Checking if the substitution is trivial eg. gauss substitution.
      if elimpt_bvl elimpt then <<
	 % There are bounded quantifiers to create
	 bvl := elimpt_bvl elimpt;
	 for each bv in bvl do
	    tf := rl_mkbq('bex,cdr bv,car bv,tf)
      >>;
      res := answ_new(tf,for each bv in bvl collect car bv,
     	 {pasf_mk2('equal,numr simp x,
	    (elimpt_nom elimpt . elimpt_den elimpt))});
      % mathprint rl_mk!*fof answ_f res;
      return res
   end;

procedure pasf_vsubstatf(atf,x,n_j,a_j,unif);
   % Presburger arithmetic standard form virtual stubstitution in atomic
   % formula. [atf] is an atomic formula; [x] is the eliminated
   % variable; [n_j] is a substitution parameter; [a_j] is a
   % substitution parameter; [unif] is a flag that is t iff the formula
   % represents cauchy bounds. Returns the substituted atomic formula.
   begin scalar n_i,a_i,dc,d,degr;
      % Decomposing the atomic formula
      dc := repr_atfnew(atf,x,nil);
      % Highest degree of the polynomial
      degr := repr_ldeg dc;
      % Constrained substitution if univariate formula
      if degr > 1 and not unif then
	 return pasf_vsubstcatf(atf,x,n_j,a_j);
      if degr <= 1 then <<
      	 n_i := repr_n dc;
      	 a_i := repr_a dc;
      	 % Returning unchanged formula if no quantified variable in the formula
      	 if null n_i then return atf;
      	 d := pasf_pdp n_j;
      	 return if pasf_congp atf then
	    % Multiplying the modulus
      	    pasf_0mk2(pasf_mkop(pasf_opn atf,multf(pasf_m atf,n_j)),
	       addf(multf(n_i,a_j),negf multf(n_j,a_i)))
      	 else if pasf_op atf memq '(leq lessp geq greaterp) then
	    (if d memq '(pdef psdef) then
	       pasf_0mk2(repr_op dc,addf(multf(n_i,a_j), negf multf(n_j,a_i)))
      	    else if d memq '(ndef nsdef) then
	       pasf_0mk2(anegrel repr_op dc,addf(multf(n_i,a_j),
	       	  negf multf(negf n_j,a_i)))
	    else if d eq 'indef then
	       % For inequalities with indefinite denominator the denominator
	       % must be made positive
      	       pasf_0mk2(repr_op dc,addf(multf(multf(n_i,n_j),a_j),
	       	  negf multf(multf(n_j,n_j),a_i))))
      	 else
	    pasf_0mk2(repr_op dc,addf(multf(n_i,a_j), negf multf(n_j,a_i)))
      >> else <<
	 % Trivial substitution
	 return pasf_subat({(x . prepf a_j)},atf);
      >>;
   end;

procedure pasf_vsubstcatf(atf,x,n_j,a_j);
   % Presburger arithmetic standard form constrained virtual
   % stubstitution in a univariate nonlinear atomic formula. [atf] is an
   % atomic formula; [x] is the eliminated variable; [n_j] is the test
   % point nominator; [a_j] is the test point denominator. Returns a
   % formula.
   begin scalar cl,cb,cbadd,lcoeff;
      %if pasf_congp atf then
      %rederr{"For now no congruences with univariate polynomials allowed"};
      cl := pasf_coeflst(pasf_arg2l atf,x);
      cb := pasf_cauchybndcl(cl);
      cbadd := multf(multf(n_j,n_j),cb);
      lcoeff := car cl;
      if domainp car lcoeff and remainder(cdr lcoeff,2) = 0 then
	 return rl_smkn('or,
	    {rl_smkn('and,{pasf_0mk2('leq,addf(a_j,cbadd)),
	       pasf_0mk2(pasf_op atf,car lcoeff)}),
	       rl_smkn('and,{pasf_0mk2('geq,addf(a_j,negf cbadd)),
		  pasf_0mk2(pasf_op atf,car lcoeff)})});
      if !*rlqesubi then
	 return rl_smkn('or,
	    {rl_smkn('and,{pasf_0mk2('leq,addf(a_j,cbadd)),
	    pasf_qesubiat(atf,x,'minf)}),
	       rl_smkn('and,{pasf_0mk2('geq,addf(a_j,negf cbadd)),
	    pasf_qesubiat(atf,x,'pinf)})})
      else
	 return rl_smkn('or,
	    {rl_smkn('and,{pasf_0mk2('leq,addf(a_j,cbadd)),
	    pasf_subat({(x . prepf negf cb)},atf)}),
	       rl_smkn('and,{pasf_0mk2('geq,addf(a_j,negf cbadd)),
	    pasf_subat({(x . prepf cb)},atf)})})
   end;

procedure pasf_qesubi(f,v,inf);
   % Presburger arithmetic standard form quantifier elimination
   % substitute infinite element. [bvl] is a list of variables, [theo]
   % is the current theory; [f] is a quantifier-free formula; [v] is a
   % variable; [inf] is one of ['minf], ['pinf] which stand for
   % $-\infty$ and $\infty$ resp. Returns a pair $(\Theta' . \phi)$
   % where $\Theta'$ is a theory and $\phi$ is a quantifier-free
   % formula. $\phi$ is equivalent to $[f]([v]/[inf])$ under the theory
   % $[th] \cup \Theta'$. $\Theta' is currently always [nil].
   cl_apply2ats1(f,'pasf_qesubiat,{v,inf});

procedure pasf_qesubiat(atf,v,inf);
   % Presburger arithmetic standard form quantifier elimination
   % substitute infinite element into atomic formula. [atf] is an atomic
   % formula; [v] is a variable; [inf] is one of ['minf], ['pinf] which
   % stand for $-\infty$ and $\infty$ resp. Returns a quantifier-free
   % formula equivalent to $[atf]([v]/[inf])$.
   begin scalar op,lhs;
      if not (v memq pasf_varlat atf) then return atf;
      op := pasf_op atf;
      lhs := pasf_arg2l atf;
      if op eq 'equal or op eq 'neq then
	 return pasf_qesubtranseq(op,lhs,v);
      % [op] is an ordering relation.
      return pasf_qesubiord(op,lhs,v,inf)
   end;

procedure pasf_qesubtranseq(op,lhs,v);
   % Presburger arithmetic standard form quantifier elimination
   % substitute transcendental element with equality relation. [op] is
   % one of ['equal], ['neq]; [lhs] is an SF; [v] is a variable. Returns
   % a quantifier-free formula equivalent to $[r]([lhs],0)([v]/\alpha)$
   % for any transcendental $\alpha$.
   if op eq 'equal then
      pasf_qesubtransequal(lhs,v)
   else  % [op eq 'neq]
      cl_nnfnot pasf_qesubtransequal(lhs,v);

procedure pasf_qesubtransequal(lhs,v);
   % Presburger arithmetic standard form quantifier elimination
   % substitute transcendental element into equation. [lhs] is an SF;
   % [v] is a variable. Returns a quantifier-free formula equivalent to
   % $[lhs]([v]/\alpha)=0$ for any transcendental $\alpha$.
   pasf_qesubtransequal1(sfto_reorder(lhs,v),v);

procedure pasf_qesubtransequal1(lhs,v);
   % Presburger arithmetic standard form quantifier elimination
   % substitute transcendental element into equation. [lhs] is an SF
   % reordered wrt. [v]; [v] is a variable. Returns a quantifier-free
   % formula equivalent to $[lhs]([v]/\alpha)=0$ for any transcendental
   % $\alpha$.
   begin scalar cl;
      while not domainp lhs and mvar lhs eq v do <<
	 cl := pasf_0mk2('equal,reorder lc lhs) . cl;
	 lhs := red lhs
      >>;
      cl := pasf_0mk2('equal,reorder lhs) . cl;
      return rl_smkn('and,cl)
   end;

procedure pasf_qesubiord(op,f,v,inf);
   % Presburger arithmetic standard form quantifier elimination
   % substitute infinite element with ordering relation. [op] is an
   % ordering relation. [f] is an SF; [v] is a variable; [inf] is one of
   % ['minf], ['pinf] which stand for $-\infty$ and $\infty$ resp.
   % Returns a quantifier-free formula equivalent to
   % $[op]([lhs]([v]/[inf]),0)$.
   pasf_qesubiord1(op,sfto_reorder(f,v),v,inf);

procedure pasf_qesubiord1(op,f,v,inf);
   % Presburger arithmetic standard form quantifier elimination
   % substitute infinite element with ordering relation subroutine. [op]
   % is an ordering relation. [f] is an SF, which is reordered wrt. [v];
   % [v] is a variable; [inf] is one of ['minf], ['pinf] which stand for
   % $-\infty$ and $\infty$ resp. Returns a quantifier-free formula
   % equivalent to $[op]([lhs]([v]/[inf]),0)$.
   begin scalar an;
      if domainp f or mvar f neq v then
      	 return pasf_0mk2(op,reorder f);
      an := if inf eq 'minf and not evenp ldeg f then
 	 negf reorder lc f
      else
 	 reorder lc f;
      % The use of [an] is correct in the equal case.   % Generic QE!
      return rl_mkn('or,{pasf_0mk2(pasf_mkstrict op,an),rl_mkn(
	 'and,{pasf_0mk2('equal,an),pasf_qesubiord1(op,red f,v,inf)})})
   end;

% ---- Condensing operator --------------------------------------------------

procedure pasf_condense(f,pl);
   % Presburger arithmetic standard form condensing operator. [f] is a
   % positive quantifier-free formula; [pl] is a list of tree positions
   % of formulas to condense. Returns a pair $(f' . c)$ where $f'$
   % results from [f] by replacing each subformula, that is not
   % conjunctively associated to [pl], with false and $c$ is the total
   % amount of condensed subtrees.
   begin scalar r,c,tmp,cm;
      % We have found the formula producing the resulting test point
      if null pl then return (f . 0);
      % In disjunctions we remove all points that are not conjunctively
      % associated to the formula producing the test point
      if rl_op f eq 'or then <<
	 c := 0;
	 for each sf in rl_argn f do <<
	    if c = car pl then
	       r := pasf_condense(sf,cdr pl);
	    c := c + 1
	 >>;
	 if c = 0 then
	    rederr{"Bug in pasf_condense, reference leads to nothing"};
	 return (car r . (cdr r + c - 1))
      >>;
      % In conjunctions we proceed with condensing on the way to the
      % formula, that produced the testpoint, without replacing anything
      % on the current level
      if rl_op f eq 'and then <<
	 c := 0;
	 cm := 0;
	 for each sf in rl_argn f do <<
	    if c = car pl then <<
	       tmp := pasf_condense(sf,cdr pl);
	       r := (car tmp) . r;
	       cm := cdr tmp
	    >> else
	       r := sf . r;
	    c := c + 1
	 >>;
	 return (rl_smkn('and,r) . cm)
      >>;
      % Note: Universal bounded quantifiers stay as they are even if one
      % tries to condense something inside such a quantifier. It could
      % make sence to raise an error, if one tries to do so, but this
      % implementation avoids condensing of universal bounded
      % quantifiers with other tools
      if rl_op f eq 'bex then <<
	 tmp := pasf_condense(rl_mat f,cdr pl);
	 return (rl_mkbq(rl_op f,rl_var f,rl_b f,car tmp) . cdr tmp)
      >>;
      return (f . 0)
   end;

% ---- Elimination set computation -------------------------------------------

procedure pasf_elimset(f,x,theo,p);
   % Presburger arithmetic standard form elimination set computation.
   % [f] is a forumla; [x] is a variable; [theo] is a theory; [p] is the
   % probability for PQE. Returns an ELIMPT list.
   begin scalar reprl,reprls,m,tempm,pdp,rl,res,vl,tz,toc;
      % Probabilistic mode is on
      if !*rlverbose and p neq simp 1 then ioto_prin2 "p";
      reprls := pasf_rep(f,x);
      % Create all new variables. This prevents running out of variables:
      vl := for i := 1 : length fdec_bvl car reprls + 1 collect
	 pasf_newvar(nil);
      if !*rlverbose and length cdr reprls > 1 then <<
	 ioto_prin2 "s";
	 ioto_prin2 length cdr reprls
      >>;
      for each reprl in cdr reprls do <<
      	 % Compute the approximation for the moduli period:
      	 m := 1;
	 rl := nil;
	 toc := t;
      	 for each repr in reprl do
	    % Only representants containing the quantified variable
	    % concerned:
      	    if repr_n repr then <<
               if pairp repr_op repr and
 	       	  car repr_op repr memq '(cong ncong) then <<
		     % Getting the modulus
		     tempm := cdr repr_op repr;
		     pdp := pasf_pdp tempm;
		     m := if pdp eq 'pdef then
		     	% For definite moduli no approximation needed
			lcm(m,tempm)
		     else if pdp eq 'ndef then
			lcm(m,negf tempm)
		     else if pdp eq 'psdef then
			% For semidefinite moduli just adding 1
 			lcm(m,addf(tempm,1))
		     else if pdp eq 'nsdef then
			% Approximate the modulus by it's square plus 1
 			lcm(m,addf(negf tempm,1))
		     else
 			lcm(m,addf(multf(tempm,tempm),1));
		     % Add the congruence to the representant list if it
		     % can become zero:
		     if not (pdp memq '(pdef ndef)) then <<
			toc := t;
			rl := repr . rl
		     >>
	     	  >> else
		     rl := repr . rl
      	    >>;
	 res := append(pasf_testpt(fdec_bvl car reprls,rl,m,vl,toc,p),res)
      >>;
      tz := length res;
      res := if !*rlpasfconf then pasf_conflate res else res;
      if !*rlverbose and !*rlpasfconf and tz-length res > 0 then <<
	 ioto_prin2 "t";
	 ioto_prin2 (tz-length res)
      >>;
      if null res then rederr{"error in elimination set creation"};
      % Add the zero case only in case of uniform input and
      % non-univariate formula:
      return if pasf_uprap f and not pasf_univnlfp(f,x) then
	 elimpt_new(nil,'true,nil,1,nil,nil) . res
      else res
   end;

procedure pasf_testpt(b,l,m,vl,toc,p);
   % Presburger arithmetic standard form elimination test points. [b] is
   % a list of bound/bound variable pairs; [l] is the list of
   % representants that will be used for test point generation; [m] is a
   % congruence period approximation, which can be not positive definite
   % only in case of generic elimination; [vl] is a list of new
   % varibles; [toc] is a flag that signals if the congruence case has
   % to be added; [p] is the probability for PQE. Returns an ELIMSET.
   begin scalar v,res,cp,nsv,rnd,rng,n;
      v := car vl;
      nsv := numr simp v;
      % The congruences case
      res := if null l or null toc then
	 if p neq simp 1 then
	    pasf_testptpqe(nil,0,1,0,m,p,nil)
         else
	    {elimpt_new(nil,'true,numr simp v,1,
	       {(rl_smkn('or,{pasf_mkrng(numr simp v,nil,m),
	    	  pasf_mkrng(nsv,nil,negf m)}) . v)},nil)};
      for each repr in l do <<
         % DEBUG Test for correct representants
	 if repr_ldeg repr = 0 then
	    rederr{"pasf_testpt: representant with leading degree 0"};
	 % Probabilistic test point
	 if p neq simp 1 and repr_ldeg repr = 1 then
	    res := pasf_testptpqe(repr_pos repr,repr_r repr,repr_n repr,
	       -m*repr_n repr,m*repr_n repr,p,t)
      	 else if repr_ldeg repr = 1 then
	    % Simple test point
	    res := elimpt_new(
	       % Position of the subformula
	       	  repr_pos repr,
       	    	  % Guards for each representant
	    	  rl_smkn('and,{pasf_0mk2('neq,repr_n repr),
	       	     pasf_0mk2(('cong . repr_n repr),
		  	addf(repr_r repr, nsv))}),
	    	  % Substitution point
	    	  addf(repr_r repr,nsv),repr_n repr,
	    	  % Bounds
	    	  pasf_substb(b,repr_t repr,v,m,repr_n repr,cdr vl),nil) . res
      	 else <<
	    % Univariate test point. Note: assuming m to be positive
	    cp := addf(pasf_cauchybndcl repr_cl repr,m);
	    res := elimpt_new(
	       % Position of the subformula
	       repr_pos repr,
	       % Guards for the substitution
	       'true,
	       % Substitution point
	       nsv,1,
	       % Bounds are the Cauchy-bounds
	       {(pasf_mkrng(nsv,negf cp,cp) . v)},t) . res;
	 >>
      >>;
      return res
   end;

procedure pasf_testptpqe(pos,nom,den,a,b,p,g);
   % Presburger arithmetic standard form elimination test points for
   % pqe. [pos] is the position of the formula; [nom] is the numerator
   % term; [den] is the denominator; [a] is the lower interval boundary;
   % [b] is the upper interval boundary; [p] is the probability for PQE;
   % [g] is nil iff there are no guards to create. Returns a
   % probabilistic elimination set.
   if !*rlpqeold then
	pasf_testptpqeold(pos,nom,den,a,b,p,g)
   else
	pasf_testptpqenew(pos,nom,den,a,b,p,g);

procedure pasf_testptpqenew(pos,nom,den,a,b,p,g);
   % Presburger arithmetic standard form elimination test points for
   % pqe. [pos] is the position of the formula; [nom] is the numerator
   % term; [den] is the denominator; [a] is the lower interval boundary;
   % [b] is the upper interval boundary; [p] is the probability for PQE;
   % [g] is nil iff there are no guards to create. Returns an ELIMSET
   % which comes from the substitution of a random test term.
   begin scalar n,r,res;
	 r := pasf_mkrndf(b,pasf_newvar('false));
	 res := {elimpt_new(pos,
	    if g then
	       rl_smkn('and,{pasf_0mk2('neq,den),
	    	  pasf_0mk2(('cong . den),addf(nom,r))})
	    else
	       'true,addf(nom,r),den,nil,nil),
	 elimpt_new(pos,
	    if g then
	       rl_smkn('and,{pasf_0mk2('neq,den),
	    	  pasf_0mk2(('cong . den),addf(nom,negf r))})
	    else
	       'true,addf(nom,negf r),den,nil,nil)};
      return res;
   end;

procedure pasf_testptpqeold(pos,nom,den,a,b,p,g);
   % Presburger arithmetic standard form elimination test points for
   % pqe. [pos] is the position of the formula; [nom] is the numerator
   % term; [den] is the denominator; [a] is the lower interval boundary;
   % [b] is the upper interval boundary; [p] is the probability for PQE;
   % [g] is nil iff there are no guards to create. Returns an ELIMSET
   % which contains random points from the range $[t+a,t+b]$ such that
   % each term is hit with probability [p].
   begin scalar n,rnd,res;
      n := max2(ceiling(ln(1.0-numr p*1.0/denr p)/ln(1.0-1.0/(b-a+1))-1),1);
      for i := 1 : n do <<
	 rnd := numr simp (random(b-a+1)+a);
	 res := elimpt_new(pos,
	    if g then
	       rl_smkn('and,{pasf_0mk2('neq,den),
	    	  pasf_0mk2(('cong . den),addf(nom,rnd))})
	    else
	       'true,addf(nom,rnd),den,nil,nil) . res
      >>;
      return res
   end;

procedure pasf_substb(b,term,v,m,n_j,vl);
   % Presburger arithmetic standard form bound substitution. [b] is a
   % list of bound/bound variable pairs; [term] is the term of linear
   % combinations of bounded variables in b; [m] is an approximation of
   % all moduli; [n_j] is the coefficient of the representant; [vl] is a
   % list of new variables. Returns a list of bounds where $v$ runs in
   % some range about all values of [term] in [b].
   begin scalar nb,nv,nt1,nt2,res,sb,nbb,tmp,pdp;
      % Collecting all variables for substitution
      for each bnd in b do <<
	 sb := (cdr bnd . car vl) . sb;
	 vl := cdr vl
      >>;
      % Duplicating the term
      term := numr subf(term,sb);
      % Duplicating the bounds
      for each bnd in b do <<
	 nbb := car bnd;
	 nv := nil;
	 for each s in sb do <<
	    if car s eq cdr bnd then nv := cdr s;
	    % Note: Bounds are strong quantifier-free
	    nbb := pasf_subfof(car s,cdr s,nbb)
	 >>;
	 if null nv then rederr {"bug in bound substitution"};
	 nb := (nbb . nv) . nb
      >>;
      if !*rlpasfbapprox then <<
	 % Bound approximation
	 tmp := pasf_bapprox(nb,term,v,m,n_j);
	 if tmp then return tmp
      >>;
      % Note: nt1 assumes m and n_j to be both positive
      nt1 := multf(n_j,m);
      % Note: nt2 assumes analog n_j to be negative
      nt2 := multf(negf n_j,m);
      % Bound substitution
      pdp := pasf_pdp n_j;
      res := rl_smkn('or,
      	 if pdp eq 'pdef then
	    {pasf_mkrng(addf(numr simp v,negf term),negf nt1,nt1)}
	 else if pdp eq 'ndef then
	    {pasf_mkrng(addf(numr simp v,negf term),negf nt2,nt2)}
	 else
	    {pasf_mkrng(addf(numr simp v,negf term),negf nt1,nt1),
      	       pasf_mkrng(addf(numr simp v,negf term),negf nt2,nt2)});
      return ((res . v) . reverse nb)
   end;

procedure pasf_bapprox(b,term,v,l,n_j);
   % Presburger arithmetic standard form bound approximation. [b] is a
   % list of bound/bound variable pairs; [term] is the term of linear
   % combinations of bounded variables in [b]; [l] is the lcm of all
   % nonzero coefficients; [n_j] is the coefficient of the representant.
   % Returns a new bound in [v] where [v] runs in some range about all
   % values of [term] in [b].
   begin scalar tmin,tmax,tmp,flag,tpool,tnpool,res,fvl;
      % For now only the real non uniform case
      if null domainp l then return nil;
      if null domainp n_j then return nil;
      if pasf_termp(term,nil) then return nil;
      tpool := {term};
      % Collecting all ranges of the bounds
      for each bnd in b do <<
	 fvl := cl_fvarl car bnd;
	 if length fvl > 1 then flag := t;
	 if length fvl = 1 and car fvl neq cdr bnd then
	    rederror{"bug in bound approximation"};
	 if null flag then <<
	    tmp := pasf_brng(car bnd,cdr bnd);
	    tnpool := nil;
	    for each tm in tpool do <<
	       tnpool := numr subf(tm,{(cdr bnd . car tmp)}) . tnpool;
	       tnpool := numr subf(tm,{(cdr bnd . cdr tmp)}) . tnpool
	    >>
	 >>;
	 tpool := tnpool
      >>;
      % If parametric bounds appear substitution fails
      if flag then return nil;
      % Looking for minimum and maximum in the term list
      tmax := 'minf;
      tmin := 'pinf;
      for each tm in tpool do <<
	 if pasf_leqp(tm,tmin) then tmin := tm;
	 if pasf_leqp(tmax,tm) then tmax := tm
      >>;
      if n_j < 0 then n_j := -n_j;
      if l < 0 then l := -l;
      res := pasf_mkrng(numr simp v,
	 addf(tmin,negf multf(n_j,l)),
	 addf(tmax,multf(n_j,l)));
      return {(res . v)}
   end;

procedure pasf_conflate(elsl);
   % Presburger arithmetic standard form conflation of elimination sets.
   % [elsl] is a list of test points. Returns a conflated elimination
   % set.
   begin scalar tmp,res;
      while elsl do <<
	 tmp := pasf_conflate1(cdr elsl,car elsl);
	 res := car tmp . res;
	 elsl := cdr tmp
      >>;
      return res
   end;

procedure pasf_conflate1(elsl,els1);
   % Presburger arithmetic standard form conflation of elimination sets
   % subprocedure. [elsl] is a list of test points; [els1] is a point to
   % conflate with. Returns a conflated elimination set.
   begin scalar r,rev1,rev2;
      for each els2 in elsl do <<
	 if (elimpt_nom els1 = elimpt_nom els2) and
	 (elimpt_den els1 = elimpt_den els2) and
	 (elimpt_guard els1 = elimpt_guard els2) and
	 (elimpt_unif els1 = elimpt_unif els2) then <<
	    rev1 := elimpt_bvl els1;
	    rev2 := elimpt_bvl els2;
	    els1 := elimpt_new(elimpt_cpos(els1,els2),
	       elimpt_guard els1,elimpt_nom els1,elimpt_den els1,
	       % Note: This part uses the special form of the
	       % elimination set of the QE-method (refer to Lasaruk's
	       % diploma thesis)
	       if rev1 and rev2 then
		  ((pasf_ssmk2('or,caar rev1,caar rev2) .
		     cdar rev1) . cdr rev1)
	       else if rev1 then rev1
	       else rev2,elimpt_unif els1)
	 >> else r := els2 . r
      >>;
      return (els1 . r)
   end;

procedure pasf_ssmk2(op,a1,a2);
    if a1 = a2 then
       a1
    else
      if rl_op a1 eq op and rl_op a2 eq op then
      rl_mkn(op,append(rl_argn a1,rl_argn a2))
   else if rl_op a1 eq op then
      rl_mkn(op,a2 . rl_argn a1)
   else if rl_op a2 eq op then
      rl_mkn(op,a1 . rl_argn a2)
   else
      rl_mkn(op,{a1,a2});

% ---- Representant computation ---------------------------------------------

procedure pasf_rep(f,x);
   % Presburger arithmetic standard form search for representants. [f]
   % is a weak quantifier-free formula in PNF; [x] is the eliminated
   % variable. Returns a pair of a FDEC structure and a list of REPR
   % structures.
   begin scalar fdec,ball;
      % Compute the matrix and the list of bounded variables:
      fdec := fdec_new(f,x);
      for each b in fdec_bopl fdec do if b eq 'ball then ball := t;
      % Perform structural elimination only in existential problems.
      % This specially avoids condensing of formulas with universal
      % bounded quantifiers:
      return if !*rlpasfses and null ball then
	 (fdec . pasf_ses(fdec_mat fdec,x,fdec_pos fdec,fdec_bvl fdec))
      else
      	 (fdec . {pasf_rep1(fdec_mat fdec,x,fdec_pos fdec,fdec_bvl fdec)})
   end;

procedure pasf_rep1(f,x,pos,bvl);
   % Presburger arithmetic standard form search for representants
   % subprocedure. [f] a strong quantifier-free formula; [x] is the
   % eliminatied variable; [pos] is the current position inside the
   % formula; [bvar] is the list of bounded variables. Returns the
   % elimindation data.
   begin scalar n,res;
      % Note: pos is reserved for future implementation of positional
      % condensing.
      n := 0;
      if rl_bquap rl_op f or rl_bquap rl_op f then
      	 % Input formula should be strong quantifier-free
      	 rederr{"pasf_canrep : quantifier illegal inside a formula's matrix"};
      if rl_boolp rl_op f then <<
      	 for each arg in rl_argn f do <<
	    % For now condensing only in structural elimination sets
	    res := append(pasf_rep1(arg,x,nil,bvl),res);
	    n := n+1
	 >>;
	 return res
      >>;
      % Atomic formula reached
      if pasf_congp f and x memq kernels pasf_m f then
	 rederr{"Quantified variable ",x," is not allowed in modulus"};
      return {repr_atfbnew(f,x,nil,bvl)}
   end;

procedure pasf_ses(f,x,pos,bvl);
   % Presburger arithmetic standard form search for representants with
   % structural elimination sets. [f] a strong quantifier-free formula;
   % [x] is the eliminatied variable; [pos] is the current position
   % inside the formula; [bvar] is the list of bounded variables.
   % Returns the elimindation data.
   begin scalar n,res,tmp,lmax,smax;
      n := 0;
      if rl_quap rl_op f or rl_bquap rl_op f then
      	 % Input formula should be strong quantifier-free
      	 rederr{"bug in pasf_canrep"};
      if rl_op f eq 'and then <<
	 lmax := 0;
      	 for each arg in rl_argn f do <<
	    tmp := pasf_ses(arg,x,append(pos,{n}),bvl);
	    if length tmp > lmax then <<
	       for each sm in smax do res := append(sm,res);
	       lmax := length tmp;
	       smax := tmp
	    >> else
	       for each sm in tmp do res := append(sm,res);
	    n := n+1
	 >>;
	 return for each esl in smax collect
	    append(esl,for each r in res collect
	       repr_setpos(r,repr_pos car esl))
      >>;
      if rl_op f eq 'or then <<
     	 for each arg in rl_argn f do <<
	    res := append(pasf_ses(arg,x,append(pos,{n}),bvl),res);
	    n := n+1
	 >>;
	 return res
      >>;
      % Atomic formula reached
      if pasf_congp f and x memq kernels pasf_m f then
	 rederr{"Quantified variable",x,"is not allowed in modulus"};
      return {{repr_atfbnew(f,x,pos,bvl)}}
   end;

% ---- Gauss decomposition ---------------------------------------------------

procedure pasf_gaussdec(f,x,theo);
   % Presburger arithmetic standard form gauss decomposition. [f] is a
   % positive weakly quantifier-free formula; [x] is a variable; [theo]
   % is a theory. Returns a pair $(l . \psi)$ where $l$ is a list of $(p
   % . es)$ where $p$ is the position of a gauss formula in $f$ and $es$
   % is it's elimination set and $\psi$ is the formula resulting from
   % $f$ by replacing every gauss formula by false.
   begin scalar r,fdec,f,opl,stp,vl;
      % Note : Using the fact the formula is in PNF
      fdec := fdec_new(f,x);
      % Gauss elimination does not work for now with univariate formulas
      if pasf_univnlfp(fdec_mat fdec,x) then return (nil . f);
      opl := fdec_bopl fdec;
      % Cancelling gauss elimination for universal bounded quantifiers
      for each op in opl do
	 if op eq 'ball then stp := t;
      if stp then return (nil . f);
      % Creating new variables
      vl := for i := 1 : length fdec_bvl fdec + 1 collect pasf_newvar(nil);
      r := pasf_gaussdec1(fdec_mat fdec,x,theo,fdec_pos fdec,fdec_bvl fdec,vl);
      f := caddr r;
      for each bv in fdec_bvl fdec do <<
	 f := rl_mkbq(car opl,cdr bv,car bv,f);
	 opl := cdr opl
      >>;
      return (cadr r . f)
   end;

procedure pasf_gaussdec1(f,x,theo,pos,bvar,vl);
   % Presburger arithmetic standard form gauss decomposition
   % subprocedure. [f] is a formula; [x] is a variable; [theo] is a
   % theory; [pos] is a position; [bvar] is a list of bounded variable
   % and bound pairs; [vl] is the new variable list. Returns list $\{flg
   % , l , \psi\}$ where $flg$ is t iff the formula is a gauss formula,
   % $l$ is a list of $(p . es)$ where $p$ is the position of a gauss
   % formula in [f] and $es$ is it's elimination set and $\psi$ is the
   % formula resulting from [f] by replacing every gauss formula by
   % 'false.
   begin scalar c,tmp,r;
      if f eq 'false then
	 return{t,nil,f};
      if f eq 'true then
	 return{nil,nil,f};
      if rl_op f eq 'and then <<
 	 % It is sufficient to find one gauss argument
	 c := 0;
	 % Internal datastructure {a,b,c}. First element is t iff a
	 % gauss-formula was found. The second is a list of ELIMPT of
	 % nested gauss formulas till now. The third is the formula
	 % without gauss formulas inside
	 tmp := {nil,nil,nil};
	 for each sf in rl_argn f do <<
	    % Among gauss subformulas we choose the elimination set with a
	    % corresponding heuristic
	    r := pasf_gaussdec1(sf,x,theo,append(pos,{c}),bvar,vl);
	    if car r then
	       % Found a new gauss subformula
	       tmp := {t,pasf_gaussesord(cadr tmp,cadr r),'false}
	    else if null car tmp then
 	       % There for now no gauss subformulas found and the current one
 	       % is a non-gauss-formula
	       tmp := {nil,append(cadr tmp,cadr r),caddr r . caddr tmp};
	    % Note: Non-gauss subformulas are ignored if one is already found
	    c := c + 1
	 >>;
	 if car tmp then
	    % This formula is a gauss formula
	    return tmp
	 else
	    return {nil,cadr tmp,rl_smkn('and,caddr tmp)}
      >>;
      if rl_op f eq 'or then <<
	 % All arguments have to be gauss formulas
	 c := 0;
	 tmp := {t,nil,nil};
	 for each sf in rl_argn f do <<
	    r := pasf_gaussdec1(sf,x,theo,append(pos,{c}),bvar,vl);
	    if car r then
	       % Found a new gauss subformula
	       tmp := {car tmp,append(cadr tmp,cadr r),caddr r . caddr tmp}
	    else
	       tmp := {nil,append(cadr tmp,cadr r),caddr r . caddr tmp};
	    c := c + 1
 	 >>;
	 if car tmp then
	    % The formula is a gauss formula
	    return {t,cadr tmp,'false}
	 else
	    return {nil,cadr tmp,rl_smkn('or,caddr tmp)}
      >>;
      % There are no bounded quantifiers inside the pnf matrix
      if rl_bquap rl_op f then rederr{"Bug in gauss decomposition"};
      % Gauss atomic formulas are only equations
      if pasf_atfp f then
 	 if pasf_opn f eq 'equal then
	    return pasf_gaussdec2(f,x,bvar,pos,vl)
	 else
 	    return {nil,nil,f};
      % This code should not be reached at runtime, because that would mean
      % there is a negation, extended boolean operator or a quantifier in the
      % formula.
      rederr{"Bug in gauss decomposition. Code assumed dead reached"}
   end;

procedure pasf_gaussdec2(atf,x,bvar,pos,vl);
   % Presburger arithmetic standard form gauss decomposition
   % subprocedure for the treatment of gauss-equations. [bvar] is a list
   % of bounded variables; [x] is the eliminated variable; [atf] is an
   % atomic gauss equation; [pos] is the position of this gauss formula;
   % [vl] is the new variable list. Returns the gauss decomposition of
   % the atomic formula.
   begin scalar repr,a_i,b;
      repr := repr_atfbnew(atf,x,pos,bvar);
      a_i := repr_r repr;
      % Bound for gauss formula
      b := pasf_substb(bvar,repr_t repr,car vl,nil,nil,cdr vl);
      if bvar then a_i := addf(a_i,numr simp car vl);
      if repr_n repr and domainp repr_n repr then
	 return {t,{elimpt_new(
	    % Position of the gauss formula
	    pos,
	    % Guard for gauss formulas
	    rl_mkn('and,{pasf_0mk2(('cong . repr_n repr),a_i),
	       pasf_0mk2('neq,repr_n repr)}),
	       % Test point for gauss formulas
	       a_i, repr_n repr,
	    if bvar then b else nil,nil)},'false};
      % Nothing can be done
      return {nil,nil,atf}
   end;

procedure pasf_gaussesord(a,b);
   % Presburger arithmetic standard form gauss elimination set ordering.
   % [a] and [b] are lists of ELIMPT. Returns one of [a] or [b]
   % according to the length of the elimination sets term form.
   begin
      if null a and b then return b
      else if null a and null b then return nil
      else if a and null b then return a
      else if length cdar b < length cdar a then return b
      else if length cdar b > length cdar a then return a;
      % Now the only case is the equality of lengths
      return b
   end;

endmodule; % pasfqe.red

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasf.rlg0000644000175000017500000001030411527635055024362 0ustar  giovannigiovanniFri Feb 18 21:28:25 2011 run on win32
load_package redlog;


rlset pasf;


*** turned on switch rlsusi 

{}

off rlverbose;



% Information Flow Control
sec := (a < b and cong(a+b,0,2) and 2*n = a+b and
      (a < b and b-a = n or a >= b and a-b = n)) or
   (a < b and ncong(a+b,0,2) and 2*n = a+b+1 and
      (a < b and b-a = n or a >= b and a-b = n))$



rlqe rlex sec;


true


rlqea rlex sec;


{{true,{n = 1,b = 1,a = 0}},

 {true,{n = 2,b = 3,a = 1}}}


rlqe ex(n,sec);


(3*a - b + 1 = 0 and a + b #2# 0 and a - b < 0)

 or (3*a - b = 0 and a + b ~2~ 0 and a - b < 0)


% Information Flow Control, Nonlinear Variant
phi := ex(n,
   (a < b and cong(a+b,0,2) and 2*n = a+b and
      ((a= b and a-b = n^2))) or
   (a < b and ncong(a+b,0,2) and 2*n = a+b+1 and
      ((a < b and b-a = n^2) or (a >= b and a-b = n^2))))$



rlwqe phi;


             2            2                2            2
bex g19 [ - a  + 2*a*b - b  - 2 <= g19 <= a  - 2*a*b + b  + 2] (a - b < 0

                2
 and a - b + g19  = 0 and a + b #2# 0 and a + b - 2*g19 + 1 = 0) or bex g18 [

    2            2                2            2
 - a  + 2*a*b - b  - 2 <= g18 <= a  - 2*a*b + b  + 2] (a - b < 0

                2
 and a - b + g18  = 0 and a + b ~2~ 0 and a + b - 2*g18 = 0)


% Integer Roots
phi := ex(x,x^5-3x^2+1 = 0 and 3x >= 1 and x <= 3)$



rlwqe phi;


false


% Integer Roots of Generic Polynomial
phi := ex(x,a*x^2+b*x+c=0)$



rlwqe phi;


             2    2                2    2            2
bex g20 [ - b  - c  - 2 <= g20 <= b  + c  + 2] (a*g20  + b*g20 + c = 0)


% Feasibility of Parametric Integer Constraints
las := ex(x,a*x>=b and c*x<=d)$



rlwqe las;


bex g22 [ - abs(a) <= g22 <= abs(a)] (

((a*d - b*c - c*g22 >= 0 and a > 0) or (a*d - b*c - c*g22 <= 0 and a < 0))

 and ((a > 0 and g22 >= 0) or (a < 0 and g22 <= 0)) and b + g22 ~a~ 0 and a <> 0

) or bex g22 [ - abs(c) <= g22 <= abs(c)] (

((c > 0 and g22 <= 0) or (c < 0 and g22 >= 0))

 and ((a*d + a*g22 - b*c >= 0 and c > 0) or (a*d + a*g22 - b*c <= 0 and c < 0))

 and d + g22 ~c~ 0 and c <> 0) or (b <= 0 and d >= 0)


procedure t1(m);
   rlsimpl ex(for i:=1:m collect mkid(x,i),
      (for i:=1:m sum mkid(x,i))=a and
      for i:=1:m mkand mkid(x,i)>=0);


t1


procedure t2(m);
   rlsimpl ex(for i:=1:m join for j:=1:m collect mkid(mkid(x,i),j),
      for i:=1:m mkand (for j:=1:m sum mkid(mkid(x,i),j))=mkid(a,i) and
      for j:=1:m mkand (for i:=1:m sum mkid(mkid(x,i),j))=mkid(b,j) and
      for i:=1:m mkand for j:=1:m mkand mkid(mkid(x,i),j)>=0);


t2


% We compute $T_{1,8}$. In the literature we have treated instances
% with in the range t1(5), ..., t1(11):

f:=t1(5)$

 s:=rlwqe f$

 rlatnum s;


192
 rlexpand s$

 ws;


a >= 0


% We compute $T_{2,2}$. In the literature we have treated instances with
% in the range t1(1), ..., t1(3):

f:=t2(2)$

 s:=rlwqe f$

 rlatnum s;


24
 rlexpand s$

 ws;


(a1 + a2 - b1 - b2 = 0 and a2 - b2 <= 0 and a2 >= 0 and b1 >= 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b2 - 1 <= 0 and a2 > 0 and b1 > 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 - b2 <= 0 and a2 - b2 >= 0 and b2 >= 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 - b2 < 0 and a2 - b2 + 1 >= 0 and b2 > 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 - b2 < 0 and a2 - b1 + 1 >= 0 and b1 > 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 - b2 <= 0 and a2 - b1 >= 0 and b1 >= 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 - 1 <= 0 and a2 > 0 and b2 > 0)

 or (a1 + a2 - b1 - b2 = 0 and a2 - b1 <= 0 and a2 >= 0 and b2 >= 0)


% Dependency Analysis for Automatic Parallelization
dep := ex({ii,j,ip,jp},0<=ii<=m and 0<=j<=m and 0<=ip<=m and 0<=jp<=m and
(ii<>ip or j<>jp) and ii+j<>ip+jp and n*ii+j=n*ip+jp)$



depsol := rlwqe dep$


rlatnum depsol;


11031


rlexpand rlsimpl sub(m=4,n=4,depsol);


true


rlqe sub(m=4,n=4,dep);


true


rlqe sub(m=4,n=5,dep);


false


% Parametric Linear Optimization Problem with Univariately Nonlinear
% Constraints
f := ex({x,y},x+y <= z and x >= 0 and y >= 0 and x+y >= 0 and x^2-a >= 0);


f := ex x ex y (x + y - z <= 0 and x >= 0 and y >= 0 and x + y >= 0

             2
 and  - a + x  >= 0)


sol := rlwqe f$


rlatnum sol;


103

rlexpand sub(a=10,sol);


z - 3 > 0


end;


Time for test: 5195 ms, plus GC time: 626 ms
@@@@@ Resources used: (6 107 7 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfsism.red0000644000175000017500000005510211526203062025235 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfsism.red 313 2009-05-19 07:26:52Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2003-2009 A. Dolzmann, A. Seidl, and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(pasf_sism_rcsid!* pasf_sism_copyright!*);
   pasf_sism_rcsid!* :=
      "$Id: pasfsism.red 313 2009-05-19 07:26:52Z thomas-sturm $";
   pasf_sism_copyright!* :=
      "Copyright (c) 2003-2009 A. Dolzmann. A. Seidl and T. Sturm"
>>;

module pasfsism;
% Presburger arithmetic standard form smart simplification. Submodule of PASF.

procedure pasf_smwupdknowl(op,atl,knowl,n);
   % Presburger arithmetic standard form update knowledge. [op] is an
   % operator; [atl] is the list of atomic formulas to add to the knowledge;
   % [knowl] is a knowledge; [n] is the level. Returns modified knowledge.
   if !*rlsusi then
      cl_susiupdknowl(op,atl,knowl,n)
   else
      cl_smupdknowl(op,atl,knowl,n);

procedure pasf_smwrmknowl(knowl,v);
   % Presburger arithmetic standard form remove variable from the
   % knowledge. [knowl] is a knowledge; [v] is the variable to remove. Returns
   % modified knowledge.
   if !*rlsusi then
      pasf_susirmknowl(knowl,v)
   else
      cl_smrmknowl(knowl,v);

procedure pasf_smwcpknowl(knowl);
   % Presburger arithmetic standard form copy knowledge. [knowl] is a
   % knowledge. Returns a copy of the knowledge.
   if !*rlsusi then
      cl_susicpknowl(knowl)
   else
      cl_smcpknowl(knowl);

procedure pasf_smwmkatl(op,knowl,newknowl,n);
   % Presburger arithmetic standard form make atomic formula list. [op] is an
   % operator; [knowl] is a knowledge; [newknowl] is a knowledge; [n] is the
   % current level. Returns an atomic formula list. For detailed documentation
   % refer to clsimpl.red.
   if !*rlsusi then
      cl_susimkatl(op,knowl,newknowl,n)
   else
      cl_smmkatl(op,knowl,newknowl,n);

procedure pasf_susirmknowl(knowl,v);
   % Presburger arithmetic standard form remove knowledge. [knowl] is a
   % knowledge; [v] is a variable. Returns a knowledge. Removes all
   % information about [v] from [knowl].
   for each p in knowl join
      if v memq pasf_varlat car p then nil else {p};

procedure pasf_susibin(old,new);
   % Presburger arithmetic standard form susi binary smart
   % simplification. [old] is a LAT; [new] is a LAT. Returns 'false or a
   % SUSIPROG.
   pasf_susibinad(old,new);
   
procedure pasf_susibinad(old,new);
   % Presburger standard form additive smart simplification. [old] is the old
   % atomic formula in the theory; [new] is the new atomic formula
   % found. Returns a SUSIPROG that simplifies the formula.
   begin scalar od,nd,level,olevel,kn,ko;
      level := cl_susiminlevel(cdr old,cdr new);
      olevel := cdr old;
      old := car old;
      new := car new;
      % Check for truth value of the level formula
      if new eq 'false then
	 return 'false;
      if new eq 'true then
	 return {'(delete . T)};
      % Equal left handsides simplification
      if pasf_arg2l old = pasf_arg2l new then
	 return pasf_susibineq(pasf_arg2l old,pasf_op old,pasf_op new,level);
      % Decomposing both atomic formulas for additive simplification
      od := pasf_dec pasf_arg2l old;
      nd := pasf_dec pasf_arg2l new;
      if car od = car nd then 
	 % Equal parametric parts
	 return pasf_susibinord(
	    pasf_op old,car od,if cdr od then cdr od else 0,
	    pasf_op new,car nd,if cdr nd then cdr nd else 0,level);
      ko := kernels car od;
      kn := kernels car nd;
      % Integer substitution
      if pasf_op old eq 'equal and null cdr ko and car ko memq kn then
	 return pasf_susibinad1(pasf_subfof1(new,car ko,negf cdr od),level,t);
      if pasf_op new eq 'equal and null cdr kn and car kn memq ko then	
	 return pasf_susibinad1(pasf_subfof1(old,car kn,negf cdr nd),level,nil);
      return nil
   end;

procedure pasf_susibinad1(sb,level,flag);
   begin scalar ssb;
      ssb := pasf_simplat1(sb,nil);
      if rl_op ssb eq 'and then
	 return {'delete . flag,
	    for each at in rl_argn ssb collect ('add . (at . level))};
      if rl_cxp rl_op ssb then
	 ssb := pasf_simplat1(sb,nil) where !*rlsifac=nil;   
      return {'delete . flag,'add . (ssb . level)}
   end;

procedure pasf_susibineq(u,oop,nop,level);
   % Presburger arithmetic standard form smart simplification with equal left
   % handside terms. [u] is the (common) left handside term; [oop] is the old
   % operator in the theory; [nop] is the new operator in the found atomic
   % formula; [level] is the recursion level of the new found atomic
   % formula. Returns a SUSIPROG that simplifies the formula.
   begin scalar w;
      % Congruences with different moduli
      if pairp oop and pairp nop and cdr oop neq cdr nop then
	 return pasf_susibineqcong(u,oop,nop,level);
      % ASSUMPTION: A congruence is never in the output of pasf_smeqtable
      w := pasf_smeqtable(
	 if pairp oop then car oop else oop,
	 if pairp nop then car nop else nop);
      if car w eq nil then
     	 % Nothing can be done
	 return nil	    
      else if car w eq 'false then
      	 % Contradiction found
	 return 'false
      else if eqn(car w,1) then
	 % Remove new atomic formula from the level
 	 return {'(delete . T)}
      else if eqn(car w,2) then
 	 % Remove old atomic formula from the theory, add new atomic
 	 % formula to the knowledge
	 return {'(delete . nil)}
      else if eqn(car w,3) then
	 % Remove old atomic formula from the theory, remove new
	 % atomic formula from the level, add modified atomic formula to
	 % the level
	 return {'(delete . nil), '(delete . T),
	    ('add . (pasf_0mk2(cdr w, u) . level))}
      else if eqn(car w,4) then
	 % Remove new atomic formula from the level, add modified
	 % atomic formula to the level
	 return {'(delete . T),
	    ('add . (pasf_0mk2(cdr w, u) . level))}
      else
	 % Remove old atomic formula from the theory, add modified
	 % atomic formula to the level
	 return {'(delete . nil),
	    ('add . (pasf_0mk2(cdr w, u) . level))}
   end;

procedure pasf_susibineqcong(u,oop,nop,level);
   % Presburger arithmetic standard form smart equal simplification with equal
   % left handside terms in congruences with different moduli. [u] is the
   % (common) left handside term; [oop] is the old operator in the theory;
   % [nop] is the new operator in the found atomic formula; [level] is the
   % recursion level of the new found atomic formula. Returns a SUSIPROG that
   % simplifies the formula.
   begin scalar n,m,mo,atf;
      n := cdr oop;
      m := cdr nop;
      % For parametric moduli nothing yet
      if null domainp n or null domainp m then return nil;
      % Both formulas are congruences
      if car oop eq 'cong and car nop eq 'cong then
	 return{'(delete . nil),'(delete . T),
	    ('add . (pasf_0mk2(pasf_mkop('cong,lcm(m,n)),u) . level))};
      % Old formula is a congruence and new is a incongruence
      if car oop eq 'cong and car nop eq 'ncong then <<
	 if m = 2*n then
	    return{'(delete . T),('delete . nil),('add .
	       (pasf_0mk2(pasf_mkop('ncong,m),addf(u,negf n)) . level))}
	 else <<
	    % Making sure changes are really applied
	    mo := pasf_susibineqcong1(m,n);
	    if mo neq m then <<
	       atf := pasf_simplat1(pasf_0mk2(pasf_mkop('ncong,mo),u),nil)
		  where !*rlsifac=nil;
	       if atf eq 'false then
		  return atf
	       else if atf eq 'true then
		  return nil
	       else
	       	  return{'(delete . T),('add . (atf . level))}
	    >> else
	       return nil
	 >>
      >>;	    
      % Old formula is an incongruence and new is a congurence
      if car oop eq 'ncong and car nop eq 'cong then <<
	 if n = 2*m then
	    return{'(delete . nil),'(delete . T),('add .
	       (pasf_0mk2(pasf_mkop('ncong,n),addf(u,negf m)) . level))}
	 else <<
	    % Making sure changes are really applied
	    mo := pasf_susibineqcong1(n,m);
	    if mo neq m then <<
	       atf := pasf_simplat1(pasf_0mk2(pasf_mkop('ncong,mo),u),nil)
	       	  where !*rlsifac=nil;
	       if atf eq 'false then
		  return atf
	       else if atf eq 'true then
		  return nil
	       else	       		       
	       	  return{'(delete . nil), ('add . (atf . level))}
	    >> else
	       return nil	    
	 >>
      >>;
      % Both formulas are incongruences
      if remainder(m,n) = 0 then
	 return {'(delete . T)}
      else if remainder(n,m) = 0 then
	 return {'(delete . nil)}
      else
	 return nil
   end;

procedure pasf_susibineqcong1(m,n);
   % Presburger arithmetic standard form smart equal simplification with equal
   % left handside terms in congruences with different moduli subprocedure.
   % [m] is the modulus of the incongruence; [n] is the modulus of the
   % congruence. Returns the reduced modulus (see the diplom thesis of lasaruk
   % for details).
   begin scalar p;
      % For parametric moduli nothing yet
      if null domainp n or null domainp m then return nil;
      % ASSERTION: m,n are greater than 1 (due to atomic formula normal form)
      if (m <= 1 or n <= 1) then
	 rederr{"pasf_susibineqcong1: wrong modulus in input"};
      p := zfactor(n);
      for each f in p do
	 % Factor is present in m with minor power
	 if remainder(m,car f) = 0 and
	 remainder(m,(car f)^(cdr f)) neq 0 then
	    while (remainder(m,car f) = 0) do
	       m := m / car f;	 
      return m
   end;
   
procedure pasf_susibinord(oop,ot,oabs,nop,nt,nabs,level);
   % Presburger arithmetic standard form additive simplification. [oop] is the
   % old relation operator; [nop] is the new relation operator; [ot] is the
   % left handside of the old formula; [nt] is the left handside of the new
   % formula; [oabs] is the constant part of the old formula; [nabs] is the
   % constant parts of the new formula; [level] is the recursion
   % level. Returns a SUSIPROG that simplifies the two atomic formulas.
   begin scalar w,oabsv,nabsv;
      % Congruences are treated differently
      if pairp oop and pairp nop then
	 if cdr oop = cdr nop then
	    return pasf_susibinordcongeq(oop,nop)
	 else
	    return pasf_susibinordcong(oop,ot,oabs,nop,nt,nabs,level);
      % Nothing to do for congruences times order relations
      if pairp oop or pairp nop then
	 return nil;
      % Special cases
      oabsv := if null oabs then 0 else oabs;
      nabsv := if null nabs then 0 else nabs;
      % Special case: strict inequalities with an emptyset gap
      if (oop eq 'lessp and nop eq 'greaterp and oabsv + 1 = nabsv) or	
       	 (nop eq 'lessp and oop eq 'greaterp and nabsv + 1 = oabsv) then
	    return 'false;
      % Special case: inequalities with single point satisfaction set
      if oop eq 'geq and nop eq 'lessp and nabsv + 1 = oabsv then
	 return {'(delete . T), '(delete . nil),
	    ('add . (pasf_0mk2('equal, addf(ot,numr simp oabs)) . level))};
      if nop eq 'geq and oop eq 'lessp and oabsv + 1 = nabsv then
	 return {'(delete . T), '(delete . nil),
	    ('add . (pasf_0mk2('equal, addf(ot,numr simp nabs)) . level))};
      if oop eq 'leq and nop eq 'greaterp and oabsv + 1 = nabsv then
	 return {'(delete . T), '(delete . nil),
	    ('add . (pasf_0mk2('equal, addf(ot,numr simp oabs)) . level))};
      if nop eq 'leq and oop eq 'greaterp and nabsv + 1 = oabsv then
	 return {'(delete . T), '(delete . nil),
	    ('add . (pasf_0mk2('equal, addf(ot,numr simp nabs)) . level))};
      w := pasf_smordtable(oop,nop,oabs,nabs);
      if car w eq nil then
     	 % Nothing can be done
	 return nil	    
      else if car w eq 'false then
      	 % Contradiction found
	 return 'false
      else if eqn(car w,1) then
	 % Remove new atomic formula from the level
 	 return {'(delete . T)}
      else if eqn(car w,2) then
 	 % Remove old atomic formula from the theory, add new atomic formula
 	 % to the knowledge
       	 return {'(delete . nil)};
      reutrn nil
   end;

procedure pasf_susibinordcongeq(oop,nop);
   % Presburger arithmetic standard form smart additive simplification with
   % equal left handside terms in congruences with equai moduli. [oop] is the
   % old relation operator; [nop] is the new relation operator. Returns a
   % SUSIPROG that simplifies the formula.
   begin scalar n,m;
      n := cdr oop;
      m := cdr nop;
      % For parametric moduli nothing yet
      if null domainp n or null domainp m then return nil;
      % Both formulas are congruences
      if car oop eq 'cong and car nop eq 'cong then
	 return 'false;
      % Old formula is a congruence and new is an incongruence
      if car oop eq 'cong and car nop eq 'ncong then
	 return {'(delete . T)};
      % Old formula is an incongruence and new is a congurence
      if car oop eq 'ncong and car nop eq 'cong then
	 return {'(delete . nil)};
      % Both formulas are incongruences
      return nil
   end;

procedure pasf_susibinordcong(oop,ot,oabs,nop,nt,nabs,level);
   % Presburger arithmetic standard form additive simplification. [oop] is the
   % old relation operator; [nop] is the new relation operator; [ot] is the
   % left handside of the old formula; [nt] is the left handside of the new
   % formula; [oabs] is the constant part of the old formula; [nabs] is the
   % constant part of the new formula; [level] is the recursion
   % level. Returns a SUSIPROG that simplifies the two atomic formulas.
   begin scalar n,m,eucd,lhs,op,at;
      n := cdr oop;
      m := cdr nop;
      % For parametric moduli nothing yet
      if null domainp n or null domainp m then return nil;
      if car oop eq 'cong and car nop eq 'cong and gcdf(n,m) = 1 then <<
	 op := pasf_mkop('cong,numr simp (n*m));
	 eucd := sfto_exteucd(n,m);
	 lhs := addf(ot,numr simp(n*cadr eucd*nabs + m*caddr
	    eucd*oabs));
	 at := pasf_simplat1(pasf_0mk2(op,lhs),nil) where !*rlsifac=nil;
	 return {'(delete . T),'(delete . nil), 'add . (at . level)}
      >>;
      return nil
   end;

procedure pasf_susipost(atl,knowl);
   % Presburger arithmetic standad form susi post simplification. [atl] is a
   % list of atomic formulas; [knowl] is a knowledge. Returns a list $\lambda$
   % of atomic formulas, such that $\bigwedge [knowl] \land \bigwedge \lambda$
   % is equivalent to $\bigwedge [knowl] \land \bigwedge [atl]$.
   atl;

procedure pasf_susitf(at,knowl);
   % Presburger arithmetic standard form susi transform. [at] is an atomic
   % formula; [knowl] is a knowledge. Returns an atomic formula $\alpha$ such
   % that $\alpha \land \bigwedge [knowl]$ is equivalent to $[at] \land
   % \bigwedge [knowl]$ ($\alpha$ has possibly a more convenient relation than
   % [at]).
   at;

procedure pasf_smeqtable(r_1,r_2);
   % Presburger arithmetic standard form smart simplify equal absolute
   % summands table. [r_1] is a relation; [r_2] is a relation. Returns 'false
   % or a relation $r$ such that $r(t,0)$ is equivalent to $[r_1](t,0) \land
   % [r_2](t,0)$.
   begin scalar al;
      al := '(
	 (equal .
	    ((equal . (1 . nil))
	     (neq . (false . nil))
	     (geq . (1 . nil))
             (leq . (1 . nil))
	     (greaterp . (false . nil))
	     (lessp . (false . nil))
	     (cong . (1 . nil))
	     (ncong . (false . nil))))
         (neq .
	    ((equal . (false . nil))
	     (neq . (1 . nil))
	     (geq . (3 . greaterp))
             (leq . (3 . lessp))
	     (greaterp . (2 . nil))
	     (lessp . (2 . nil))
	     (cong . (nil . nil))
	     (ncong . (2 . nil))))		  
         (geq .
	    ((equal . (2 . nil))
	     (neq . (3 . greaterp))
	     (geq . (1 . nil))
             (leq . (3 . equal))
	     (greaterp . (2 . nil))
	     (lessp . (false . nil))
	     (cong . (nil . nil))
	     (ncong . (5 . greaterp))))		      
         (leq .
	    ((equal . (2 . nil))
	     (neq . (3 . lessp))
	     (geq . (3 . equal))
             (leq . (1 . nil))
	     (greaterp . (false . nil))
	     (lessp . (2 . nil))
	     (cong . (nil . nil))
	     (ncong . (5 . lessp))))	   
         (greaterp .
 	    ((equal . (false . nil))
	     (neq . (1 . nil))
	     (geq . (1 . nil))
             (leq . (false . nil))
	     (greaterp . (1 . nil))
	     (lessp . (false . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))	   
         (lessp .
	     ((equal . (false . nil))
	     (neq . (1 . nil))
	     (geq . (false . nil))
             (leq . (1 . nil))
	     (greaterp . (false . nil))
	     (lessp . (1 . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))	   
	 (cong .
	    ((equal . (2 . nil))
	     (neq . (nil . nil))
	     (geq . (nil . nil))
             (leq . (nil . nil))
	     (greaterp . (nil . nil))
	     (lessp . (nil . nil))
	     (cong . (1 . nil))
	     (ncong . (false . nil))))
	 (ncong .
	    ((equal . (false . nil))
	     (neq . (1 . nil))
	     (geq . (4 . greaterp))
             (leq . (4 . lessp))
	     (greaterp . (nil . nil))
	     (lessp . (nil . nil))
	     (cong . (false . nil))
	     (ncong . (1 . nil)))));
      return cdr (atsoc(r_2,atsoc(r_1,al)))
   end;

procedure pasf_smordtable(r1,r2,s,tt);
   % Presburger arithmetic standard form smart simplify ordered absolute
   % summands. [r1] is a relation; [r2] is a relation; [s] is the constant
   % part of [r1]; [t] is the constant part of [r2]. Returns '(nil . nil) if
   % no simplification is possible; '(false . nil) if contradiction was found;
   % '(1 . nil) if the new formula does not bring any knowledge and can be so
   % removed from the actual level; '(2 . nil) if the old formula should be
   % removed and the new added.
   if s < tt then
      pasf_smordtable2(r1,r2)
   else if s > tt then
      pasf_smordtable1(r1,r2)
   else
      rederr {"abused smordtable"};
   
procedure pasf_smordtable1(r1,r2);
   % Presburger arithmetic standard form smart simplify ordered absolute
   % summands table if absoulte summand of $r1$ is less as the one of $r2$.
   % [r1] is a relaton; [r2] is a relation. Returns '(nil . nil) if no
   % simplification is possible; '(false . nil) if contradiction was found;
   % '(1 . nil) if the new formula does not bring any knowledge and can be so
   % removed from the actual level; '(2 . nil) if the old formula should be
   % removed and the new added.
   begin scalar al;
      al := '(
	 (lessp .
	    ((lessp . (1 . nil))
             (leq . (1 . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (false . nil))
	     (greaterp . (false . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (leq .
	    ((lessp . (1 . nil))
             (leq . (1 . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (false . nil))
	     (greaterp . (false . nil))
             (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (equal .
	    ((lessp . (1 . nil))
             (leq . (1 . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (false . nil))
	     (greaterp . (false . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (neq .
	    ((lessp . (nil . nil))
             (leq . (nil . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (2 . nil))
	     (greaterp . (2 . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (geq .
	    ((lessp . (nil . nil))
             (leq . (nil . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (2 . nil))
	     (greaterp . (2 . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (greaterp .
	    ((lessp . (nil . nil))
             (leq . (nil . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (2 . nil))
	     (greaterp . (2 . nil))
	     (cong . (nil . nil))
    	     (ncong . (nil . nil)))));
      return cdr (atsoc(r2,atsoc(r1,al)))
   end;

procedure pasf_smordtable2(r1,r2);
   % Presburger arithmetic standard form smart simplify ordered absolute
   % summands table if absoulte summand of $r1$ is less as the one of $r2$.
   % [r1] is a relaton; [r2] is a relation. Returns '(nil . nil) if no
   % simplification is possible; '(false . nil) if contradiction was found;
   % '(1 . nil) if the new formula does not bring any knowledge and can be so
   % removed from the actual level; '(2 . nil) if the old formula should be
   % removed and the new added.
   begin scalar al;
      al := '(
	 (lessp .
	    ((lessp . (2 . nil))
             (leq . (2 . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (nil . nil))
	     (greaterp . (nil . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (leq .
	    ((lessp . (2 . nil))
             (leq . (2 . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (nil . nil))
	     (greaterp . (nil . nil))
             (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (equal .
	    ((lessp . (false . nil))
             (leq . (false . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (1 . nil))
	     (greaterp . (1 . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (neq .
	    ((lessp . (2 . nil))
             (leq . (2 . nil))
	     (equal . (2 . nil))
   	     (neq . (nil . nil))
	     (geq . (nil . nil))
	     (greaterp . (nil . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (geq .
	    ((lessp . (false . nil))
             (leq . (false . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (1 . nil))
	     (greaterp . (1 . nil))
	     (cong . (nil . nil))
	     (ncong . (nil . nil))))
	 (greaterp .
	    ((lessp . (false . nil))
             (leq . (false . nil))
	     (equal . (false . nil))
   	     (neq . (1 . nil))
	     (geq . (1 . nil))
	     (greaterp . (1 . nil))
	     (cong . (nil . nil))
    	     (ncong . (nil . nil)))));
      return cdr (atsoc(r2,atsoc(r1,al)))
   end;

endmodule; % [pasfsism]

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasf.tst0000644000175000017500000000414411526203062024401 0ustar  giovannigiovanniload_package redlog;
rlset pasf;
off rlverbose;

% Information Flow Control
sec := (a < b and cong(a+b,0,2) and 2*n = a+b and
      (a < b and b-a = n or a >= b and a-b = n)) or
   (a < b and ncong(a+b,0,2) and 2*n = a+b+1 and
      (a < b and b-a = n or a >= b and a-b = n))$

rlqe rlex sec;

rlqea rlex sec;

rlqe ex(n,sec);

% Information Flow Control, Nonlinear Variant
phi := ex(n,
   (a < b and cong(a+b,0,2) and 2*n = a+b and
      ((a= b and a-b = n^2))) or
   (a < b and ncong(a+b,0,2) and 2*n = a+b+1 and
      ((a < b and b-a = n^2) or (a >= b and a-b = n^2))))$

rlwqe phi;

% Integer Roots
phi := ex(x,x^5-3x^2+1 = 0 and 3x >= 1 and x <= 3)$

rlwqe phi;

% Integer Roots of Generic Polynomial
phi := ex(x,a*x^2+b*x+c=0)$

rlwqe phi;

% Feasibility of Parametric Integer Constraints
las := ex(x,a*x>=b and c*x<=d)$

rlwqe las;

procedure t1(m);
   rlsimpl ex(for i:=1:m collect mkid(x,i),
      (for i:=1:m sum mkid(x,i))=a and
      for i:=1:m mkand mkid(x,i)>=0);

procedure t2(m);
   rlsimpl ex(for i:=1:m join for j:=1:m collect mkid(mkid(x,i),j),
      for i:=1:m mkand (for j:=1:m sum mkid(mkid(x,i),j))=mkid(a,i) and
      for j:=1:m mkand (for i:=1:m sum mkid(mkid(x,i),j))=mkid(b,j) and
      for i:=1:m mkand for j:=1:m mkand mkid(mkid(x,i),j)>=0);

% We compute $T_{1,8}$. In the literature we have treated instances
% with in the range t1(5), ..., t1(11):

f:=t1(5)$ s:=rlwqe f$ rlatnum s; rlexpand s$ ws;

% We compute $T_{2,2}$. In the literature we have treated instances with
% in the range t1(1), ..., t1(3):

f:=t2(2)$ s:=rlwqe f$ rlatnum s; rlexpand s$ ws;

% Dependency Analysis for Automatic Parallelization
dep := ex({ii,j,ip,jp},0<=ii<=m and 0<=j<=m and 0<=ip<=m and 0<=jp<=m and
(ii<>ip or j<>jp) and ii+j<>ip+jp and n*ii+j=n*ip+jp)$

depsol := rlwqe dep$
rlatnum depsol;

rlexpand rlsimpl sub(m=4,n=4,depsol);

rlqe sub(m=4,n=4,dep);

rlqe sub(m=4,n=5,dep);

% Parametric Linear Optimization Problem with Univariately Nonlinear
% Constraints
f := ex({x,y},x+y <= z and x >= 0 and y >= 0 and x+y >= 0 and x^2-a >= 0);

sol := rlwqe f$
rlatnum sol;
rlexpand sub(a=10,sol);

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfmisc.red0000644000175000017500000014552011526203062025221 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfmisc.red 606 2010-05-14 06:06:15Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(pasf_misc_rcsid!* pasf_misc_copyright!*);
   pasf_misc_rcsid!* :=
      "$Id: pasfmisc.red 606 2010-05-14 06:06:15Z thomas-sturm $";
   pasf_misc_copyright!* :=
      "(c) 1995-2009 by A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm"
>>;

module pasfmisc;
% This module provides a collection of algorithms shared by all other modules
% in Presburger arithmetic standard form (PASF) context.

procedure pasf_atf2iv(atf);
   % Presburger arithmetic standard form atomic formula to interval. [atf] is
   % an atomic formula. Returns an interval as a dotted pair of lower bound
   % and upper bound or a congruence class (see also iv_newcong).
   begin scalar dc,nom,den,floor,ceil,eucd;
      dc := repr_atfnew(atf,car cl_fvarl atf,nil);
      nom := repr_a dc;
      den := repr_n dc;
      floor := pasf_floor(nom,den);
      ceil := pasf_ceil(nom,den);
      if repr_op dc eq 'equal then
	 % Check if the equality solution is an integer
	 if eqn(den,1) then
	    % Floor and ceil are the same
	    return iv_new(floor,floor)
	 else
	    return {};
      if repr_op dc eq 'leq then
	 return iv_new('minf,floor);
      if repr_op dc eq 'lessp then
	 return iv_new('minf,addf(ceil,negf 1));
      if repr_op dc eq 'geq then
	 return iv_new(ceil,'pinf);
      if repr_op dc eq 'greaterp then
	 return iv_new(addf(floor,1),'pinf);
      if repr_op dc eq 'neq then
	 return iv_merge(iv_new('minf,addf(ceil,negf 1)),
	    iv_new(addf(floor,1),'pinf));
      if pasf_congp atf then
	 % Check if the equality solution is an integer
	 if gcdf(den,pasf_m atf) eq 1 then <<
	    eucd := sfto_exteucd(den,pasf_m atf);
	    return iv_newcong(repr_op dc,multf(cadr eucd,nom))
	 >> else
	    return {};
     rederr{"pasf_atf2iv: illegal operator ",pasf_op atf}
   end;

procedure pasf_qff2ivl(f);
   % Presburger arithmetic standard form positive quantifier free formula to
   % interval. [f] is a quantifier free formula in one variable. Returns the
   % satisfability set of [f] as a list of ascending intervals.
   if pasf_uprap f then
      rederr{"pasf_qff2ivl : uniform Presburger arithmetic formula in input"}
   else
      pasf_qff2ivl1 pasf_dnf f;

procedure pasf_qff2ivl1(f);
   % Presburger arithmetic standard form positive quantifier free formula to
   % interval subprocedure. [f] is a quantifier free formula in one variable.
   % Returns the satisfability set of [f] as a list of ascending intervals IV.
   begin scalar fs,cng;
      if rl_tvalp f then
	 % 'true or 'false
	 if f eq 'true then
	    rederr{"pasf_qff2ivl1 : true as a bound is invalid"}
	 else
	    return nil;
      if rl_op f eq 'and then <<
      	 % Using the fact the formula is in DNF. Than an "and" is the end node
      	 % of the formula's evaluation tree
      	 for each pf in rl_argn f do
	    % Only atomic formulas
	    if pasf_congp pf then
	       cng := (car pasf_atf2iv pf) . cng
	    else
	       fs := (pasf_atf2iv pf) . fs;
         % print cng;
	 return iv_cutcongs(iv_cutn fs,cng)
      >> else
      	 if rl_op f eq 'or then
      	    return iv_mergen for each pf in rl_argn f collect
	       pasf_qff2ivl1 pf;
      % This case can only occur if one of the DNF's conjunctions contains
      % only one atomic formula (e.g. x = 0 or x = 10). This leads to a
      % correct expansion only if this atomic formula is an equality (truth
      % values are already concerned) and represent so a finite set. In other
      % cases the original input formula represents an infinite set and is
      % illegal for expansion. Note: Atomic formulas are assumed to be
      % simplified.
      if pasf_opn f eq 'equal then return pasf_atf2iv f;
      % Something is wrong (mainly an error in DNF computation or a formula
      % with infinite satisfiability set in input)
      rederr{"pasf_qff2ivl1 : abused procedure call with",f}
   end;

procedure pasf_ivl2qff(ivl,var);
   % Presburger arithmetic standard form interval list to quantifier free
   % formula. [ivl] is an interval list; [var] is a free variable. Returns a
   % quantifier free formula with [var] as single free valiable with [ivl] as
   % satisfiability interval.
   if not iv_empty ivl then
      rl_smkn('or,for each iv in ivl collect
      	 pasf_mkrng(numr simp var,numr simp car iv,numr simp cdr iv))
   else
      'false;

procedure pasf_bsatp(f,var);
   % Presburger arithmetic standard form bound satisfiability. [f] is
   % a bound. Returns [t] if the bound is satifiable and nil if it is
   % too expensive to compute or if the bound is equivalent to 'false.
   begin scalar flg,r,argn,argna,a;
      if cl_fvarl f neq {var} then return nil;
      f := pasf_dnf f;
      if f eq 'false then return nil;
      if f eq 'true then rederr {"pasf_bsatp: infinite bound"};
      % Looking for one argument in the DNF without a congruence
      argn := if rl_op f eq 'or then rl_argn f else {f};
      while argn and null r do <<
	 argna := if rl_op car argn eq 'and then
	    rl_argn car argn else {car argn};
	 flg := nil;
 	 while argna and not flg do <<
	    flg := pasf_congp car argna;
	    argna := cdr argna
	 >>;
	 % Found a constituent without congruences
	 if null flg and not iv_empty pasf_qff2ivl car argn then
	    r := t;
	 argn := cdr argn
      >>;
      return r
   end;

procedure pasf_b2atl(b,k);
   % Presburger arithmetic standard form bound to list of atoms. [b] is a
   % formula in at most one variable with finite satisfability set in DNF; [k]
   % is the variable of [b]. Returns a list of atomic formulas
   % $(\varphi_i)_{i}$, so that the equivalence $$\bigvee_i \varphi_i
   % \longleftrightarrow b$$ holds and nil if it is too expensive to derive
   % atomic formulas from the bound.
   if rl_tvalp b then
      (if b eq 'false then {} else rederr "pasf_b2atl: infinite bound")
   else if cl_atfp b then
      {b}
   else if rl_op b eq 'and then
      % Using the fact the application of b2atl is performed after a DNF
      rl_argn b;

procedure pasf_simplb(f,var);
   % Presburger arithmetic standard form simplify formulas' bound. [f] is a
   % bound of some bounded formula; [var] is the bounded variable. Returns an
   % [f]-equivalent simplified formula (flat simplified DNF of [f]).
   begin scalar sb,nsb,flg,argn,argna;
      f := pasf_dnf cl_simpl(f,nil,-1);
      if rl_tvalp f then return f;
      % If the bound is parametric or contains univariate formulas only normal
      % simplification is done
      if length cl_fvarl f > 1 or pasf_univnlfp(f,var) then
	 return f;
      % Looking for one argument in the DNF without a congruence
      argn := if rl_op f eq 'or then rl_argn f else {f};
      % Note: Congruences in the bound are critical to heap space and time
      for each arg in argn do <<
	 flg := nil;
	 argna := if rl_op arg eq 'and then rl_argn arg else {arg};
	 for each a in argna do if pasf_congp a then flg := t;
	 if null flg then
	    sb := arg . sb
	 else
	    nsb := arg . nsb
      >>;
      sb := pasf_ivl2qff(pasf_qff2ivl rl_smkn('or,sb),var);
      return cl_simpl(rl_smkn('or,sb . nsb),nil,-1)
   end;

procedure pasf_b2terml(b,var);
   % Presburger arithmetic standard form bound to termlist. [b] is a bound of
   % some bounded formula; [var] is the bounded variable. Returns the
   % satisfiability set as a list of satisfying terms (for example
   % $\{1,2,3,10\}$).
   begin scalar ivl;
      % Term list for uniform bounds not possible
      if length cl_fvarl b > 1 then
	 rederr{"pasf_b2terml called with a parametric bound"};
      % Note: imprudent use of this code is extremely space- and time-critical
      ivl := pasf_qff2ivl b;
      return for each iv in ivl join
	 if (numberp car iv) and (numberp cdr iv) then
	    for i := car iv : cdr iv collect
	       i
     	 else
	    rederr{"pasf_b2terml : trying to expand infinite bound"}
   end;

procedure pasf_rmax(rng1,rng2);
   % Presburger arithmetic standard range maximum. [rng1] and [rng2] are pairs
   % of integers representing intervals. Returns an pair of integers
   % representing inteval that contains both [rng1] and [rng2].
   (pasf_min(car rng1,car rng2) . pasf_max(cdr rng1,cdr rng2));

procedure pasf_brng(b,var);
   % Presburger arithmetic standard form bound range. [b] is a bound; [var] is
   % the bound variable. Returns a pair of minimal and maximal bound values.
   begin scalar tmp,bmax;
      % Range approximation for uniform bounds is not possible
      if length cl_fvarl b > 1 then
	 rederr{"pasf_brng called with parametric bound"};
      tmp := cl_simpl(pasf_dnf b,nil,-1);
      if tmp eq 'false then
	 rederr{"Not satisfiable bound in pasf_brng"};
      if tmp eq 'true then
	 rederr{"Tautological bound in pasf_brng"};
      bmax := ('pinf . 'minf);
      % Note: The initial value for bmax is always rewritten by the first
      % application of pasf_rmax since each result of pasf_brng1 describes a
      % finite set.
      if rl_op tmp eq 'or then
	 for each sf in rl_argn tmp do
	    bmax := pasf_rmax(pasf_brng1(sf,var),bmax)
      else
	 bmax := pasf_brng1(tmp,var);
      return bmax;
   end;

procedure pasf_brng1(b,var);
   % Presburger arithmetic standard form bound range. [b] is a bound that is a
   % conjunction; [var] is the bound variable. Returns a pair of minimal and
   % maximal bound values.
   begin scalar tmp;
      % We can simply remove all congruences, since they only strengthten the
      % solution set.
      tmp := pasf_qff2ivl rl_smkn('and,
	 for each atf in cl_atl b collect
	    if null (pasf_op atf memq '(cong ncong)) then
	       atf);
      if null tmp then
	 rederr{"pasf_brng1 : Something is wrong, empty bound solution set"};
      return (caar tmp . cdar reverse tmp);
   end;

procedure pasf_ordatp(a1,a2);
   % Presburger arithmetic standard form atomic formula predicate. [a1] is an
   % atomic formula; [a2] is an atomic formula. Returns t iff [a1] is less
   % than [a2].
   begin scalar lhs1,lhs2;
      lhs1 := pasf_arg2l a1;
      lhs2 := pasf_arg2l a2;
      if lhs1 neq lhs2 then return ordp(lhs1,lhs2);
      return pasf_ordrelp(pasf_opn a1,pasf_opn a2)
   end;

procedure pasf_ordrelp(r1,r2);
   % Presburger arithmetic standard form relation order predicate. [r1] is a
   % relation; [r2] is a relation. Returns t iff $[r1] < [r2]$.
   not not (r2 memq (r1 memq '(equal neq
      leq lessp geq greaterp cong ncong)));

procedure pasf_dec(u);
   % Presburger arithmetic standard form decompose a standard form. [u] is a
   % SF. Returns a pair $(p . a)$, where $p$ and $a$ are SF's. $p$ is the
   % parametric part of [u] and $a$ is the absolut part of [u].
   begin scalar absv;
      absv := u;
      while not domainp absv do
	 absv := red absv;
      return (addf(u,negf absv) . absv)
   end;

procedure pasf_deci(u);
   % Presburger arithmetic standard form decompose a standard form with
   % integer constant part. [u] is a SF. Returns a pair $(p . a)$, where $p$
   % is a SF and $a$ is an integer; $p$ is the parametric part of [u] and $a$
   % is the absolut part of [u].
   begin scalar r;
      r := pasf_dec u;
      return (car r . if null cdr r then 0 else cdr r)
   end;

procedure pasf_varlat(atf);
   % Presburger arithmetic standard form atomic formula list of variables.
   % [atf] is an atomic formula. Returns the variables contained in $atf$ as a
   % list.
   append(kernels pasf_arg2l atf,
      if pasf_congp atf then kernels pasf_m atf else nil);

procedure pasf_varsubstat(atf,new,old);
   % Presburger arithmetic standard form substitute variable for variable in
   % atomic formula. [atf] is an atomic formula; [new] is a variable; [old] is
   % a variable. Returns an atomic formula equivalent to [atf] where [old] is
   % substituted with [new].
   if rl_tvalp atf then
      % If so no substitution is done.
      atf
   else
      pasf_0mk2(if pasf_congp atf then
	 % Substituting in modulus also
      	 (pasf_opn atf . numr subf(pasf_m atf,{old . new}))
      else
	 pasf_op atf,
	 numr subf(pasf_arg2l atf,{old . new}));

procedure pasf_negateat(atf);
   % Presburger arithmetic standard form negate atomic formula. [atf] is an
   % atomic formula. Returns an atomic formula equivalent to $\lnot([atf])$.
   if rl_tvalp atf then
      (if atf eq 'false then 'true else 'false)
   else if (pasf_opn atf) memq '(cong ncong) then
      pasf_mk2(pasf_mkop(pasf_lnegrel pasf_opn atf,pasf_m atf),
	 pasf_arg2l atf, pasf_arg2r atf)
   else
      pasf_mk2(pasf_lnegrel pasf_opn atf,pasf_arg2l atf,pasf_arg2r atf);

procedure pasf_lnegrel(r);
   % Presburger arithmetic standard form logically negate relation. [r] is a
   % relation. Returns a relation $\rho$ such that for terms $t_1$, $t_2$ we
   % have $\rho(t_1,t_2)$ equivalent to $\lnot [r](t_1,t_2)$.
   if r eq 'equal then 'neq
   else if r eq 'neq then 'equal
   else if r eq 'leq then 'greaterp
   else if r eq 'lessp then 'geq
   else if r eq 'geq then 'lessp
   else if r eq 'greaterp then 'leq
   else if r eq 'cong then 'ncong
   else if r eq 'ncong then 'cong
   else rederr {"pasf_lnegrel: unknown operator",r};

procedure pasf_anegateat(atf);
   % Presburger arithmetic standard form negate atomic formula
   % algebraically. [atf] is an atomic formula. Returns an atomic formula
   % equivalent to $-([atf])$.
   if (pasf_opn atf) memq '(cong ncong) then
      pasf_mk2(pasf_mkop(pasf_anegrel pasf_opn atf,pasf_m atf),
	 negf pasf_arg2l atf,negf pasf_arg2r atf)
   else
      pasf_mk2(pasf_anegrel pasf_opn atf,
	 negf pasf_arg2l atf,negf pasf_arg2r atf);

procedure pasf_anegrel(r);
   % Presburger arithmetic standard form algebraically negate relation. [r] is
   % a relation. Returns a relation $\rho$ such that $\rho(-t,0)$ is
   % equivalent to $[r](t,0)$ for a term $t$.
   cdr atsoc(r,'((equal . equal) (neq . neq) (leq . geq) (geq . leq)
      (lessp . greaterp) (greaterp . lessp) (cong . cong) (ncong . ncong)))
	 or rederr {"pasf_anegrel: unknown operator ",r};

procedure pasf_subat(al,f);
   % Presburger arithmetic standard form substitute into an atomic
   % formula. [al] is a substitution list; [f] is the formula. Returns an
   % atomic formula after substitution.
   begin scalar nlhs,nlhs1;
      for each a in al do
	 if null eqn(denr simp cdr a,1) then
	    rederr "pasf_subat: only presburger terms can be substituted";
      if pasf_congp f then <<
      	 nlhs := subf(pasf_arg2l f,al);
	 nlhs1 := subf(pasf_m f,al);
      	 if not domainp denr nlhs or not domainp denr nlhs1 then
	    rederr "pasf_subat: parametric denominator after substitution";
	 return pasf_0mk2((pasf_opn f . numr nlhs1), numr nlhs)
      >>;
      nlhs := subf(pasf_arg2l f,al);
      if not domainp denr nlhs then
	 rederr "pasf_subat: parametric denominator after substitution";
      return pasf_0mk2(pasf_op f,numr nlhs)
   end;

procedure pasf_mkstrict(r);
   % Presburger arithmetic standard form make strict. [r] is an ordering
   % relation. Returns the strict part of [r].
   if r eq 'leq then 'lessp else if r eq 'geq then 'greaterp else r;

procedure pasf_subalchk(al);
   % Presburger arithmetic standard form check for parametric
   % denominators. [al] is a list. Returns nil or raises an error.
   for each x in al do
      if not domainp denr simp cdr x then
	 rederr "pasf_subalchk: parametric denominator in substituted term";

procedure pasf_eqnrhskernels(x);
   % Presburger arithmetic standard form equation right handside kernels. [x]
   % is an expression. Returns a list of kernels.
   nconc(kernels numr w,kernels denr w) where w=simp cdr x;

procedure pasf_floor(nom,den);
   % Presburer arithmetic standard form floor of two domain valued standard
   % forms. [nom] is the nominator SF; [den] is the denominator SF. Returns
   % $\lfloor \frac{[nom]}{[den]} \rfloor$.
   if domainp  nom and domainp den then
      if null nom then
	 nil
      else
      	 numr simp
	    if remainder(nom,den) = 0 then
      	       nom / den
	    % The value is not negative
	    else if nom*den > 0 then
	       nom / den
	    else
	       nom / den - 1
   else
      rederr{"pasf_floor: not a domain valued sf in input",nom,den};

procedure pasf_ceil(nom,den);
   % Presburer arithmetic standard form ceil of two domain valued standard
   % forms. [nom] is the nominator SF; [den] is the denominator SF. Returns
   % $\lceil \frac{[nom]}{[den]} \rceil$.
   if domainp nom and domainp den then
      if null nom then
	 nil
      else
	 numr simp
	    if remainder(nom,den) = 0 then
	       nom / den
	    % The value is not negative
   	    else if nom*den > 0 then
	       nom / den + 1
	    else
	       nom / den
   else
      rederr{"pasf_ceil: not a domain valued sf in input",nom,den};

procedure pasf_const(ex);
   % Presburger arithmetic standard form constant part of an expresion
   % computation. [expr] is an expression. Returns the constant part of [ex].
   if domainp ex then
      ex
   else
      pasf_const red ex;

procedure pasf_fctrat(atf);
   % Presburger arithmetic standard form factorize atomic formula. [atf] is an
   % atomic formula $l \mathrel{\varrho} 0$. Returns a list $(...,(f_i
   % . d_i),...)$, where $f$ is an irreducible SF and $d$ is a
   % positive integer. We have $l=c \prod_i g_i^{d_i}$ for an integer
   % $c$.
   if pasf_congp atf then
      nconc(cdr fctrf pasf_arg2l atf,cdr fctrf pasf_m atf)
   else
      cdr fctrf pasf_arg2l atf;

procedure pasf_termmlat(atf);
   % Presburger arithmetic standard form term multiplicity list of an atomic
   % formula. [atf] is an atomic formula. Returns the multiplicity list of all
   % non-zero terms in [atf].
   if pasf_arg2l atf then {(pasf_arg2l atf . 1)};

procedure pasf_max(a,b);
   % Presburger arithmetic standard form maximum of two constant expressions
   % in $\mathbb{Z} \cup \{ \infty, -\infty \}$. [a] is a constant expression;
   % [b] is a constant epxression. Returns the maximum of [a] and [b].
   if pasf_leqp(a,b) then b else a;

procedure pasf_min(a,b);
   % Presburger arithmetic standard form minimum of two constant expressions
   % in $\mathbb{Z} \cup \{ \infty, -\infty \}$. [a] is a constant expression;
   % [b] is a constant epxression. Returns the minimum of [a] and [b].
   if pasf_leqp(a,b) then a else b;

procedure pasf_leqp(c1,c2);
   % Presburger arithmetic standard form less or equal predicate on extended
   % integer expressions in $\mathbb{Z} \cup \{ \infty, -\infty \}$. [c1] is a
   % constant expression; [c2] is a constant expression. Returns t iff [c1]
   % is less or equal than [c2].
   begin
      if null c1 then c1 := 0;
      if null c2 then c2 := 0;
      return if (c1 eq 'minf) or (c2 eq 'pinf) or
      	 (c1 neq 'pinf and c2 neq 'minf and c1 <= c2) then
	    t
   end;

procedure pasf_leq(c1,c2);
   % Presburger arithmetic standard form less or equal predicate on extended
   % integer expressions in $\mathbb{Z} \cup \{ \infty, -\infty \}$. [c1] is a
   % constant expression; [c2] is a constant expression. Returns t iff [c1]
   % is less or equal than [c2].
   begin
      if null c1 then c1 := 0;
      if null c2 then c2 := 0;
      return if (c1 eq 'minf) or (c2 eq 'pinf) or
      	 (c1 neq 'pinf and c2 neq 'pinf and c2 neq 'minf and c1 < c2) then
	    t
   end;

procedure pasf_expand(f);
   % Presburger arithmetic standard form expand a formula with non
   % parametric bounded quantifiers. [f] is a formula with bounded
   % quantifiers. Returns an equivalent formula without bounded
   % quantifiers. If the bounds of [f] are all non-parametric, then it
   % is possible to expand smartly. Note: [rl_pnf] renames variables
   % so that the bounded variables, and free variables are distinct.
   begin scalar fdec,flag,tmp;
      if !*rlverbose then ioto_tprin2 {"++++ Entering pasf_expand"};
      % TS: Blindly use pasf_exprng1 for now
      if !*rlverbose then ioto_prin2t " (exprng1)";
      return cl_simpl(pasf_exprng1 f,nil,-1);
      %
      fdec := fdec_new(pasf_pnf f,nil);
      for each b in fdec_bvl fdec do <<
	 tmp := cl_fvarl car b;
	 if length tmp > 1 or (length tmp = 1 and cdr b neq car tmp) then
	    flag := t
      >>;
      return if flag then <<
      	 if !*rlverbose then ioto_prin2t " (regular)";
      	 cl_simpl(pasf_exprng1 f,nil,-1)
      >> else <<
      	 if !*rlverbose then ioto_prin2t " (smart)";
	 cl_simpl(pasf_exprng2 f,nil,-1)
      >>
   end;

procedure pasf_exprng1(f);
   % Presburger arithmetic standard form expand bounded quantifier. [f] is a
   % formula. Returns an equivalent formula, where each bounded quantifier is
   % expanded.
   begin scalar op;
      if rl_tvalp f then
 	 return f;
      op := rl_op f;
      if rl_boolp op then
	 return rl_smkn(op,for each arg in rl_argn f collect pasf_exprng1 arg);
      if rl_quap op then
      	 return rl_mkq(op,rl_var f,pasf_exprng1 rl_mat f);
      if op eq 'ball then
	 return pasf_exprng1!-gand(
	    op,rl_var f,rl_b f,rl_mat f,'and,'true,'false);
      if op eq 'bex then
	 return pasf_exprng1!-gand(
	    op,rl_var f,rl_b f,rl_mat f,'or,'false,'true);
      return f
   end;

procedure pasf_exprng1!-gand(op,v,b,m,gand,gtrue,gfalse);
   begin scalar w,matj,terml,j,c,resl;
      w := cl_fvarl b;
      if not eqcar(w,v) or cdr w then
	 rederr {"Expanding a parametric bounded formula is impossible"};
      terml := pasf_b2terml(b,v);
      if !*rlverbose then ioto_prin2 {"[",op,",",v,",",length terml};
      c := t; while c and terml do <<
	 j := car terml;
	 terml := cdr terml;
	 % if !*rlverbose then ioto_prin2 {"(",j,")"};
	 matj := cl_simpl(pasf_exprng1 pasf_subfof(v,j,m),nil,-1);
	 if matj eq gfalse then <<
	    if !*rlverbose then ioto_prin2 {"!"};
	    secondvalue!* := (v . j) . secondvalue!*;
	    c := nil
	 >> else if matj neq gtrue then
	    resl :=  matj . resl
      >>;
      if !*rlverbose then ioto_prin2 {"]"};
      return if c then cl_simpl(rl_smkn(gand,resl),nil,-1) else gfalse
   end;

procedure pasf_exprng2(f);
   % Presburger arithmetic standard form expand bounded quantifier smart. [f]
   % is a formula. Returns an equivalent formula, where each bounded
   % quantifier is expanded.
   begin scalar terml,evaltype,matr,tmp,res;
      if rl_tvalp f then return f;
      if rl_boolp rl_op f then
	 return rl_smkn(rl_op f,for each sf in rl_argn f collect
	    cl_simpl(pasf_exprng2 sf,nil,-1));
      if rl_bquap rl_op f then <<
      	 % Long or or long and check
      	 if rl_op f eq 'bex then
	    evaltype := 'or
      	 else if rl_op f eq 'ball then
	    evaltype := 'and
      	    else
	       % Unknown operator
	       rederr{"pasf_expand : unknown or illegal quantifier",rl_op f};
	 tmp := cl_fvarl rl_b f;
	 if length tmp > 1 or (length tmp = 1 and rl_var f neq car tmp) then
	    rederr {"Expanding a parametric bounded formula is impossible"};
	 terml := pasf_b2terml(rl_b f,rl_var f);
	 matr := pasf_exprng2 rl_mat f;
	 if !*rlverbose then
	    ioto_tprin2t {"---- (",rl_op f," ",rl_var f,")"};
	 res := {};
	 for each j in terml collect <<
	    if !*rlverbose then ioto_prin2 {"[",j,"]"};
	    res := cl_simpl(pasf_subfof(rl_var f,j,matr),nil,-1) . res
	 >>;
	 ioto_prin2t {""};
	 return rl_smkn(evaltype,res)
      >>;
      if rl_quap rl_op f then
      	 rl_mkq(rl_op f, rl_var f, pasf_exprng2 rl_mat f);
      return f
   end;

switch hack;

procedure pasf_expanda(answ,phi);
   % Presburger arithmetic standard form expand an answer. [answ] is
   % an answer structure. Returns an answer with expanded first
   % components. The argument [phi] is not yet used. This is planned
   % to be the original quantified formula so that its matrix can be
   % possibly used for finding suitable values.
   begin scalar guard,w,badl,goodl,gdis,sample;
      for each a in answ do <<
	 secondvalue!* := nil;
      	 guard := pasf_expand car a;
	 w := secondvalue!*;
	 sample := pasf_findsample(cadr a,caddr a,w);
	 if car sample then
	    badl := lto_insert({guard,nconc(cdr sample,'!! . car sample)},badl)
	 else
	    goodl := lto_insert({guard,cdr sample},goodl)
      >>;
      gdis := cl_simpl(rl_smkn('or,for each gp in goodl collect car gp),nil,-1);
      if !*rlqeasri then
      	 badl := for each gp in badl join
	    if pasf_srip(car gp,gdis) then <<
	       if !*rlverbose then ioto_prin2 "(SRI) ";
	       nil
	    >> else
	       {gp};
      return nconc(reversip goodl,reversip badl)
   end;

procedure pasf_srip(prem,concl);
   % Presburger arithmetic standard form simplifier-recognized
   % implication.
   cl_simpl(rl_mk2('impl,prem,concl),nil,-1) eq 'true;

procedure pasf_findsample(rangel,points,hitl);
   begin scalar w,answ,nrangel;
      answ := for each point in points collect
	 {car point,cadr point,prepsq subsq(simp caddr point,hitl)};
      nrangel := for each range in rangel join <<
	 w := cl_simpl(cl_subfof(hitl,range),nil,-1);
	 % FRAGE: Kann false rauskommen? Was dann?
	 if not rl_tvalp w then {rl_prepfof w}
      >>;
      return nrangel . answ
   end;

procedure pasf_zsimpl(f);
   begin scalar w,z,fl,fb,best,gleq,glessp,gone;
      w := cl_fvarl f;
      if cdr w then rederr {"pasf_zsimpl: more than one variable: ",w};
      z := car w;
      f := cl_dnf f;
      fl := if rl_op f eq 'or then rl_argn f else {f};
      fb := pasf_zsimpl!-firstbound fl;
      if fb eq 'lessp or fb eq 'leq then <<
	 gleq := 'leq;
	 glessp := 'lessp;
	 gone := 1
      >> else if fb eq 'greaterp or fb eq 'geq then <<
	 gleq := 'geq;
	 glessp := 'greaterp;
	 gone := -1
      >> else
	 rederr "pasf_zsimpl: cannot determine direction";
      for each arg in fl do
	 best := pasf_improve(z,best,arg,gleq,glessp,gone);
      return pasf_0mk2(gleq,z .** 1 .* 1 .+ -best)
   end;

procedure pasf_zsimpl!-firstbound(fl);
   begin scalar f,op,fb,atl;
      while not fb and fl do <<
	 f := car fl;
	 fl := cdr fl;
	 atl := if rl_op f eq 'and then rl_argn f else {f};
	 while not fb and atl do <<
	    op := rl_op car atl;
	    atl := cdr atl;
	    if op memq '(lessp leq greaterp geq) then
	       fb := op
	 >>
      >>;
      return fb
   end;

procedure pasf_improve(z,best,arg,gleq,glessp,gone);
   begin scalar op,argl,type,cand,congl,cong;
      argl := if rl_op arg eq 'and then rl_argn arg else {arg};
      for each at in argl do <<
	 if pasf_congp at then
	    congl := at . congl
	 else <<
	    op := rl_op at;
	    if op eq gleq then <<
	       if type then rederr {"pasf_improve: too many bounds in",arg};
	       cand := pasf_improve!-getval(z,rl_arg2l at)
	    >> else if op eq glessp then <<
	       if type then rederr {"pasf_improve: too many bounds in",arg};
	       cand := pasf_improve!-getval(z,rl_arg2l at) - gone
	    >> else if op eq 'equal then <<
	       if type then rederr {"pasf_improve: too many bounds in",arg};
	       cand := pasf_improve!-getval(z,rl_arg2l at)
	    >> else rederr {"pasf_improve: unexpected operator",op};
	    type := op
	 >>
      >>;
      if best and eval {gleq,cand,best} then return best;
      cong := rl_smkn('and,congl);
      if type eq 'equal then
	 return if pasf_improve!-congp(z,cand,cong) then cand else best;
      while (null best or eval {glessp,best,cand}) and
	 not pasf_improve!-congp(z,cand,cong)
      do
	 cand := cand - gone;
      return if (null best or eval {glessp,best,cand}) then cand else best
   end;

procedure pasf_improve!-getval(z,u);
   <<
      if mvar u neq z or ldeg u neq 1 or lc u neq 1 then
      	 rederr {"pasf_improve: unexpected term ",u};
      - red u
   >>;

procedure pasf_improve!-congp(z,cand,cong);
   cl_simpl(cl_subfof({z . cand},cong),nil,-1) eq 'true;

procedure pasf_pdp(term);
   % Presburger arithmetic standard form definitness test. [term] is a
   % standard form. Returns one of the 'pdef, 'ndef or 'indef. Note: 'indef
   % has as semantic, that the test for positive and negative definitness has
   % failed. Not that the term is indefinite.
   begin scalar c,r;
      if domainp term then
	 return (if null term then 'indef
      	 else if term < 0 then 'ndef
      	 else if term > 0 then 'pdef
      	 else 'indef);
      if evenp ldeg term then <<
	 c := pasf_pdp lc term;
	 r := pasf_pdp red term;
	 if null r and (c eq 'psdef or c eq 'pdef) then return 'psdef;
	 if null r and (c eq 'nsdef or c eq 'ndef) then return 'nsdef;
	 if r eq 'pdef and (c eq 'psdef or c eq 'pdef) then return 'pdef;
	 if r eq 'ndef and (c eq 'nsdef or c eq 'ndef) then return 'ndef
      >>;
      return 'indef
   end;

procedure pasf_subfof(var,ex,f);
   % Presburger arithmetic standard form substitute into a strong quantifier
   % free formula. [var] is the variable to substitute; [ex] is the expression
   % to substitute; [f] is a formula. Returns the formula where every
   % occurence of [var] is substituted by [ex].
   cl_apply2ats1(f,'pasf_subfof1,{var,ex});

procedure pasf_subfof1(atf,var,ex);
   % Presburger arithmetic standard form substitute into a formula
   % subroutinue. [atf] is an atomic formula; [var] is the variable to
   % substitute; [ex] is the expression to substitute. Returns an atomic
   % formula where every occurence of [var] is substituted by [ex].
   pasf_mk2(if pasf_congp atf then
      (pasf_opn atf . numr subf(pasf_m atf,{(var . ex)}))
   else pasf_opn atf,
      numr subf(pasf_arg2l atf,{(var . ex)}),
      numr subf(pasf_arg2r atf,{(var . ex)}));
   % LASARUK: Evidence for an error!

procedure pasf_newvar(f);
   % Presburger arithmetic standard form new variable generation. [f] is a
   % formula. Returns a new variable which is not present in [f].
   intern gensym();

procedure pasf_newvar1(f);
   % Presburger arithmetic standard form new variable generation. [f] is a
   % formula. Returns a new variable which is not present in [f].
   begin scalar varl,varv,expld,l;
      varl := cl_varl f;
      varv := 0;
      % Checking only the whole varlist
      for each var in append(car varl,cdr varl) do <<
	 expld := explode var;
	 % Looking for k variables
	 if car expld eq 'k then <<
	    l := implode cdr expld;
	    if l >= varv then
	       varv := l+1
	 >>
      >>;
      return implode('k . explode(varv))
   end;

procedure pasf_cauchybnd(p,x);
   % Presburgr arithmetic standard form polynomial sign change bounds. [p] is
   % an expression; [x] is a variable. Returns an expression $b$, such that
   % $\abs{z} \leq b$ for each interval boundary $z$ of [p] in [x].
   begin scalar cl,res;
      cl := pasf_coeflst(p,x);
      for each p in cdr cl do
	 res := addf(res,exptf(car p,2));
      return addf(res,1)
   end;

procedure pasf_cauchybndcl(cl);
   % Presburgr arithmetic standard form polynomial sign change bounds from
   % coefficient list. [cl] is a coefficient list. Returns an expression $b$,
   % such that $\abs{z} \leq b$ for each characteristic point $z$ of the
   % solution set of the polynomial with coefficients [cl]. We assume [cl]
   % here to be sorted such that the highest degree is the first entry.
   begin scalar res;
      for each p in cdr cl do
	 res := addf(res,exptf(car p,2));
      return addf(res,1);
   end;

procedure pasf_coeflst(p,x);
   % Presburgr arithmetic standard form coefficient list. [p] is a polynomial
   % expression; [x] is a variable. Returns a list of pairs of coefficients;
   % the car is a standard form; the cdr is a positive number. The cars are
   % the coefficients of [p] as a polynomial in [x] and the cdrs are the
   % corresponding degrees. We guarantee the list is sorted by degrees
   % starting with the highest one.
   begin scalar oldkord,nexpr,res;
      oldkord := setkorder({x});
      nexpr := reorder p;
      while not domainp nexpr and mvar nexpr eq x do <<
	 res := (lc nexpr . ldeg nexpr) . res;
	 nexpr := red nexpr
      >>;
      setkorder oldkord;
      return reversip ((negf nexpr . 0) . res)
   end;

% ---- Structure definitions and accessor methods ----------------------------

% REPR is a datastructure that represents the decomposition of an atomic
% formula into representant term, bounded term, coefficient list w.r.t. the
% quantified variable and the atomic formula's position in the input
% formula. After the list of [repr] is computed the structure of the
% corresponding formula is not allowed to be changed.

procedure repr_new(pos,op,cl,tn);
   % Presburger arithmetic standard form REPR constructor. [pos] ist the
   % position of the atomic formula in the input; [op] is the operator; [r] is
   % the representant term; [cl] is the list of pairs of coefficients and
   % their power; [tn] is a linear combination of bounded variables. Returns a
   % new REPR structure.
   {pos,op,cl,tn,if null cl then
      rederr{"repr_new : invalid coefficient list"}
   else
      cdar cl};

procedure repr_eq(repr1,repr2);
   % Presburger arithmetic standard form REPR comparator. [repr1] is a REPR
   % structure; [repr2] is a REPR structure. Returns t only if positions of
   % [repr1] and [repr2] are different.
   cdr repr1 eq cdr repr2;

procedure repr_pos(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the position.
   car repr;

procedure repr_setpos(repr,pos);
   % Presburger arithmetic standard form REPR modifier. [repr] is a REPR
   % structure; [pos] is a position. Returns a new REPR structure with new
   % position.
   pos . cdr repr;

procedure repr_op(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the operator.
   cadr repr;

procedure repr_ldeg(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the leading degree of the corresponding formula.
   car cddddr repr;

procedure repr_n(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the leading coefficient.
   if null caddr repr then
      rederr{"repr_n : invalid REPR structure"}
   else if car cddddr repr = 0 then
      nil
   %else if car cddddr repr >= 2 then
   %   % First element of the second element of the coefficient list
   %   car cadr caddr reverse repr
   %   %rederr{"repr_n : nonlinear formula where a linear was expected"}
   else
      caar caddr repr;

procedure repr_r(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the representant term.
   caar reverse caddr repr;

procedure repr_cl(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the coefficients list.
   caddr repr;

procedure repr_t(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the linear combination of bounded variables.
   cadddr repr;

procedure repr_a(repr);
   % Presburger arithmetic standard form REPR accessor. [repr] is a REPR
   % structure. Returns the summ of r and t.
   addf(caar reverse caddr repr,cadddr repr);

procedure repr_atfnew(atf,x,pos);
   % Presburger arithmetic standard form REPR basic atomic formula
   % decompose. [atf] is an atomic formula; [x] is a variable; [pos] is the
   % position of the atomic formula. Returns the according REPR structure.
   begin scalar op,cl;
      op := pasf_op atf;
      cl := pasf_coeflst(pasf_arg2l atf,x);
      if minusf caar cl then <<
	 % Note : multiplication of the modulus by -1 does not change the
	 % semantics
	 op := if pasf_congp atf then
	    (pasf_anegrel car op . cdr op)
	 else
	    pasf_anegrel op;
	 cl := for each c in cl collect
	    (multf(car c,-1) . cdr c);
      >>;
      % This decomposition assumes no bounded variables
      return repr_new(pos,op,cl,nil)
   end;

procedure repr_atfbnew(atf,x,pos,bvl);
   % Presburger arithmetic standard form atomic formula bounded
   % decomposition. [atf] is an atomic formula; [x] is the eliminated
   % variable; [pos] is the position inside the formula; [bvl] is the list of
   % bound/bounded variable pairs. Returns a REPR structure.
   begin scalar rp,r,tm,tmp;
      if rl_tvalp atf then return repr_new(pos,atf,nil,nil);
      % Decomposing the atomic formula
      rp := repr_atfnew(atf,x,pos);
      r := repr_a rp;
      % Building the linear combination of all bound variables and the
      % representant right hand side term
      for each v in bvl do <<
	 tmp := pasf_coeflst(r,cdr v);
	 % Adding the next bounded variable to the linear combination Note:
	 % assuming bounded variables occur linearly in the formula
 	 if length tmp > 1 then
	    tm := addf(tm,multf(numr simp cdr v,caar tmp));
      	 % Substituting 0 for bounded variables to get the representants
	 r := numr subf(r,{(cdr v . nil)})
      >>;
      return repr_new(pos,repr_op rp,
	 reversip ((r . 0) . cdr reverse repr_cl rp),tm)
   end;

% FDEC represents a decomposition of a formula in PNF into the bound list,
% matrix and the position of the matrix in the formula.

procedure fdec_new(f,x);
   % Presburger arithmetic standard form FDEC constructor. [f] is a weak
   % quantifier free formula in PNF; [x] is an exception variable, that should
   % not apper in the bounds of [f], actually the quantified variable. Returns
   % an FDEC structure.
   begin scalar bvl,pos,btl;
      % Note: Using the fact the input formula is in PNF
      while rl_bquap rl_op f do <<
	 % Test of exception in bounds
	 if x memq rl_fvarl rl_b f then
	    rederr{"Quantified variable",x,
	       "is not allowed inside formula's bound"};
	 bvl := (rl_b f . rl_var f) . bvl;
	 pos := append(pos,{0});
	 btl := rl_op f . btl;
	 f := rl_mat f
      >>;
      return {f,pos,bvl,btl}
   end;

procedure fdec_mat(fdec);
   % Presburger arithmetic standard form bound accessor. [fdec] is a FDEC
   % structure of a weak quantifier free formula in PNF. Returns the matrix.
   car fdec;

procedure fdec_pos(fdec);
   % Presburger arithmetic standard form bound accessor. [fdec] is a FDEC
   % structure of a weak quantifier free formula in PNF. Returns the position
   % of the matrix.
   cadr fdec;

procedure fdec_bvl(fdec);
   % Presburger arithmetic standard form bound accessor. [fdec] is a FDEC
   % structure of a weak quantifier free formula in PNF. Returns the list of
   % pairs (bound . bounded variable).
   caddr fdec;

procedure fdec_bopl(fdec);
   % Presburger arithmetic standard form bound accessor. [fdec] is a FDEC
   % structure of a weak quantifier free formula in PNF. Returns the list of
   % quantifier types according to the bounded quantifiers.
   cadddr fdec;

% ELIMPT represents an elimination set part corresponding to a
% representant. The application of an ELIMPT results in a row of bounded
% quantifiers.

procedure elimpt_new(pos,guard,nom,den,bvl,unif);
   % Presburger arithmetic standard form ELIMPT constructor. [pos] is the
   % position of the representant in the formula; [guard] is the guard for the
   % testpoint; [nom] represents the nominator of the testpoint [nom]/[den];
   % [den] represents the denominator of the testpoint [nom]/[den]; [bvl] is a
   % list of bounds that will be attached by the application of the ELIMPT;
   % [unif] is a flag that is t iff the test point represents an element of
   % the cauchy bounds. Returns a new ELIMPT structure.
   {pos,guard,nom,den,bvl,unif};

procedure elimpt_pos(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the position.
   car elimpt;

procedure elimpt_cpos(elimpt1,elimpt2);
   % Presburger arithmetic standard form ELIMPT common position. [elimpt1] and
   % [elimpt2] are ELIMPT structures. Returns the common position of two
   % eliminatin points.
   begin scalar pos,p1,p2;
      p1 := car elimpt1;
      p2 := car elimpt2;
      while (p1 and p2 and car p1 eq car p2) do <<
	 pos := car p1 . pos;
	 p1 := cdr p1;
	 p2 := cdr p2
      >>;
      return reverse pos
   end;

procedure elimpt_guard(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the guard.
   cadr elimpt;

procedure elimpt_nom(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the nominator.
   caddr elimpt;

procedure elimpt_den(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the denominator.
   cadddr elimpt;

procedure elimpt_bvl(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the list of bounds.
   car cddddr elimpt;

procedure elimpt_unif(elimpt);
   % Presburger arithmetic standard form ELIMPT accessor. [elimpt] is an
   % ELIMPT structure. Returns the unif flag of bounds.
   cadr cddddr elimpt;

% ANSW represents a quantifier elimination answer. An answer contains a
% formula and a list of substitution values possibly bounded by some ranges
% given by bounds.

procedure answ_new(f,bl,tl);
   % Presburger arithmetic standard form ANSW constructor. [f] is a formula;
   % [bl] is a list of bounds; [tl] is a list of terms. Returns a new ANSW
   % structure.
   {f,bl,tl};

procedure answ_f(answ);
   % Presburger arithmetic standard form ANSW accessor. [answ] is an ANSW
   % structure. Returns the formula.
   car answ;

procedure answ_bl(answ);
   % Presburger arithmetic standard form ANSW accessor. [answ] is an ANSW
   % structure. Returns the list of bounds.
   cadr answ;

procedure answ_tl(answ);
   % Presburger arithmetic standard form ANSW accessor. [answ] is an ANSW
   % structure. Returns the list of terms.
   caddr answ;

procedure answ_backsubst(answ1,answ2);
   % Presburger arithmetic standard form ANSW backsubstitution. [answ1] is a
   % new answer; [answ2] is an old answ. Returns a list of terms, where
   % equations in [answ1] are substituted into [answ2] and the formula of the
   % old answer is replaced by the new one.
   begin scalar res,sub,var;
      if null answ2 and answ1 then
	 return answ1
      else if null answ1 then rederr{"incorrect ANSW structure"};
      sub := {(prepf pasf_arg2l caaddr answ1 .
	 prepsq pasf_arg2r caaddr answ1)};
      res := for each eqn in caddr answ2 collect
	 pasf_mk2('equal,pasf_arg2l eqn,subsq(pasf_arg2r eqn,sub));
      return {car answ1,append(cadr answ1,cadr answ2),
	 (caaddr answ1) . res}
   end;

% IV structure defines a simple representation of finite interval joints and
% provides some operations on that structure such as merge and cut. A
% procedure to map quantifier free formulas in one variable to IV's is also
% privided in this module above.

procedure iv_new(lb,rb);
   % Presburger arithmetic standard form interval datastructure
   % constructor. [lb] is the lower bound; [rb] is the upper bound. Returns a
   % new interval $[[lb],[rb]]$ (including the bounds).
   {((if lb then lb else 0) . (if rb then rb else 0))};

procedure iv_newcong(op,class);
   % Presburger arithmetic standard form interval datastructure congruence
   % constructor. [op] is the congruence operator; [class] is a representant
   % of the congruence class. Returns the (possibly non canonical)
   % datastructure representation for $[class] + modulo \mathbb{Z}$.
   {(op . if class then class else 0)};

procedure iv_congp(ivl);
   % Presburger arithmetic standard form interval datastructure new interval
   % congruence predicate. [ivl] is an interval list. Returns t iff [ivl]
   % contains a congruence.
   if ivl then pairp caar ivl or iv_congp cdr ivl;

procedure iv_empty(ivl);
   % Presburger arithmetic standard form interval datastructure empty
   % attribute. [ivl] is a an interval list. Returns t if the list is empty.
   not ivl;

procedure iv_congsplitl(ivl);
   % Presburger arithmetic standard form interval datastructure congruence
   % split of an interval list. [ivl] is an interval list.  Returns a pair
   % $(iv_1 . iv_2)$ where $iv_1$ is a list of intervals without congruences
   % and $iv_2$ are all the congruences.
   begin scalar split,rest;
      if ivl then return (nil . nil);
      % Splitting the first list
      split := iv_congsplit car ivl;
      rest := iv_congsplitl cdr ivl;
      return ((car split . car rest) . (cdr split . cdr rest))
   end;

procedure iv_congsplit(iv);
   % Presburger arithmetic standard form interval datastructure congruence
   % split. [iv] is an interval. Returns a pair $(iv_1 . iv_2)$ where $iv_1$
   % all intervals without congruences and $iv_2$ are all the congruences.
   if iv then
      if iv_congp({car iv}) then
	 (car iv_congsplit cdr iv . (car iv . cdr iv_congsplit cdr iv))
      else
	 ((car iv . car iv_congsplit cdr iv) . cdr iv_congsplit cdr iv)
   else
      (nil . nil);

procedure iv_cutn(ivl);
   % Presburger arithmetic standard form interval datastructure multiple
   % interval cut. [ivl] is a list of intervals. Returns interval $\bigcap_{iv
   % \in [ivl]} iv$.
   if cdr ivl then
      iv_cut(car ivl,iv_cutn cdr ivl)
   else
      car ivl;

procedure iv_cut(iv1,iv2);
   % Presburger arithmetic standard form interval datastructure cut. [iv1] is
   % a congruence-free interval; [iv2] is a congruence-free interval. Returns
   % interval $[iv1] \cap [iv2]$.
   begin scalar curr,lower,res;
      % If one of the intervals is empty returning nil
      if iv_empty iv1 or iv_empty iv2 then
	 return nil;
      % Until all lists are empty
      while not(iv_empty iv1 and iv_empty iv2) do <<
	 % Choosing the interval with the smallest lower bound. If one of
	 % those is empty then we take the lower bound from the lover one
	 if iv_empty iv2 or
	    (not iv_empty iv1 and pasf_leqp(caar iv1,caar iv2)) then <<
	       lower := car iv1;
	       iv1 := cdr iv1
	    >> else <<
	       lower := car iv2;
	       iv2 := cdr iv2
	    >>;
	 % Initialization of a new result interval
	 if null curr then
	    curr := lower
	 else
	    if pasf_leq(cdr curr,car lower) then
	       % The limit of the next smallest interval is bigger than the
	       % end of the current
	       curr := lower
	    else
	       if pasf_leqp(cdr curr,cdr lower) then <<
		  res := (car lower . cdr curr) . res;
		  curr := lower
	       >> else
		  res := lower . res
      >>;
      return reverse res
   end;

procedure iv_cutcongs(ivl,congs);
   % Presburger arithmetic standard form interval datastructure congruence
   % processing. [ivl] is a congruence free interval list; [congs] is a list
   % of congruences. Returns an interval list that represents $[congs] \cup
   % [ivl]$.
   begin scalar curr,res;
      if not congs then return ivl;
      while not iv_empty ivl do <<
	 for i := caar ivl : cdar ivl do <<
	    iv_cutcongs1(i,congs);
	    if iv_cutcongs1(i,congs) then
	       if curr then
		  curr := (car curr . i)
	       else
		  curr := (i . i)
	    else
	       if curr then <<
		  res := curr . res;
		  curr := nil
	       >>
	 >>;
	 % Joining the last interval limit
	 if null cdr ivl and curr then
	    res := (car curr . cdar ivl) . res;
	 ivl := cdr ivl
      >>;
      return reverse res
   end;

procedure iv_cutcongs1(val,congs);
   % Presburger arithmetic standard form interval datastructure congruence
   % processing. [val] is a value; [congs] is a list of congruences. Returns
   % t iff [val] satisfies all congruences.
   if congs then
      iv_cutcongs2(val,car congs) and iv_cutcongs1(val,cdr congs)
   else
      t;

procedure iv_cutcongs2(val,cong);
   % Presburger arithmetic standard form interval datastructure congruence
   % processing. [val] is a value; [cong] is a congruence. Returns t iff
   % [val] satisfies [cong].
   if caar cong eq 'cong then
      remainder(cdr cong - val,cdar cong) = 0
   else
      not (remainder(cdr cong - val,cdar cong) = 0);

procedure iv_mergen(ivl);
   % Presburger arithmetic standard form interval datastructure multiple
   % intervals merge. [ivl] is an interval list. Returns interval $\bigcup_{iv
   % \in [ivl]} iv$.
   if cdr ivl then
      iv_merge(car ivl,iv_mergen cdr ivl)
   else
      car ivl;

procedure iv_merge(iv1,iv2);
   % Presburger arithmetic standard form interval datastructure merge. [iv1]
   % is an interval; [iv2] is an interval. Returns interval $[iv1] \cup
   % [iv2]$.
   begin scalar curr,lower,res;
      % Test for congruences in the intervals
      if iv_congp iv1 or iv_congp iv2 then
	 rederr{"iv_merge : merging a congruence not possible }"};
      % Test for empty input lists
      if iv_empty iv1 and iv_empty iv2 then
	 return nil;
      % Until all lists are empty
      while not(iv_empty iv1 and iv_empty iv2) do <<
	 % Choosing the interval with the smallest lower bound.  If one of
	 % those is empty then we take the lower bound from the lover one
      	 if iv_empty iv2 or
	    (not iv_empty iv1 and pasf_leqp(caar iv1,caar iv2)) then <<
	    lower := car iv1;
	    iv1 := cdr iv1
	 >> else <<
	    lower := car iv2;
	    iv2 := cdr iv2
	 >>;
	 % Initialization of a new result interval
	 if not curr then
	    curr := lower
	 else
	    if pasf_leq(cdr curr,car lower) then <<
	       % The limit of the next smallest interval is bigger than the
	       % end of the current
	       res := curr . res;
	       curr := lower
	    >> else
	       if pasf_leqp(cdr curr,cdr lower) then
		  % A new limit must be set for the current interval
		  curr := (car curr . cdr lower)
      >>;
      return reverse (curr . res)
   end;

procedure pasf_rxffn(op);
   if op eq 'max then
      'cl_rxffn!-max
   else if op eq 'min then
      'cl_rxffn!-max
   else if op eq 'abs then
      'cl_rxffn!-abs
   else if op eq 'sign then
      'cl_rxffn!-sign
   else if op eq 'sqrt then
      'cl_rxffn!-sqrt
   else
      nil;

procedure pasf_stex(f);
   cl_apply2ats1(f,function pasf_stexat,{nil . nil});

procedure pasf_stexat(at,rndalpair);
   begin scalar al,lhs,w;
      al := car rndalpair;
      lhs := pasf_arg2l at;
      w := pasf_stexf(lhs,al);
      car rndalpair := cdr w;
      return pasf_0mk2(pasf_op at,car w)
   end;

procedure pasf_stexf(u,al);
   begin scalar w,c,r;
      if domainp u then
      	 return u . al;
      w := pasf_stexf(lc u,al);
      al := cdr w;
      c := car w;
      w := pasf_stexf(red u,al);
      al := cdr w;
      r := car w;
      w := pasf_stexk(mvar u,al);
      return addf(multf(c,exptf(car w,ldeg u)),r) . cdr w
   end;

procedure pasf_stexk(k,al);
   begin scalar w;
      if idp k then
	 return !*k2f k . al;
      % We now know that k is an rnd() kernel.
      w := atsoc(caddr k,al);
      if w then
	 return cdr w . al;
      if not domainp cadr k then
	 rederr {"pasf_stexk:",cadr k,"is not a number"};
      w := random(cadr k + 1);
      return w . ((caddr k . w) . al)
   end;

endmodule; % pasfmisc

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfsiat.red0000644000175000017500000003347511526203062025233 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfsiat.red 601 2010-05-11 07:30:44Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(pasf_siat_rcsid!* pasf_siat_copyright!*);
   pasf_siat_rcsid!* :=
      "$Id: pasfsiat.red 601 2010-05-11 07:30:44Z thomas-sturm $";
   pasf_siat_copyright!* :=
      "Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, and T. Sturm"
>>;

module pasfsiat;
% Presburger arithmetic standard form atomic formula simplification. Submodule
% of PASF.

procedure pasf_simplat1(atf,sop);
   % Presburger arithmetic standard form simplify atomic formula. [atf] is an
   % atomic formula; [sop] is the boolean operator [atf] occurs with or
   % nil. Returns a quantifier-free formula that is a simplified equivalent of
   % [atf].
   begin
      % Conversion to normal form (NF) and evaluation of variable free atomic
      % formulas
      atf := pasf_vf pasf_dt pasf_mkpos pasf_zcong atf;
      if rl_tvalp atf then return atf;
      % Congruences are treated differently as non-congruences
      if pasf_congp atf then
	 % Total modulo reduction possible; content elimination for
	 % congruences (CEcong)
	 atf := pasf_cecong pasf_vf pasf_mr atf
      else (if pasf_opn atf memq '(equal neq) then
	 atf := pasf_ceeq atf
      else
	 atf := pasf_cein atf);
      % Checking if done yet
      if rl_tvalp atf then return atf;
      % Advanced simplification
      atf := if pasf_opn atf memq '(cong ncong) then	       
	 % Solvability of congruences (SECong)
	 pasf_sc atf
      else if pasf_opn atf memq '(equal neq) then
	 % Solvability of diophantine (in-)equations (SE-Rule)	 
	 pasf_se atf
      else
	 % Order relation reduction
	 pasf_or atf;
      if not !*rlsifac then
	 return atf;
      % Factorization check
      return pasf_fact atf;
   end;

procedure pasf_zcong(atf);
   % Presburger arithmetic standard form zero congruences. [atf] is an atomic
   % formula. Returns an equality if modulus of the congruence is zero.
   if pasf_congp atf then (
      if null pasf_m atf then
      	 pasf_0mk2(if pasf_opn atf eq 'cong then 'equal else 'neq,
	    pasf_arg2l atf)
      else if null pasf_arg2l atf and pasf_opn atf eq 'cong then 'true
      else if null pasf_arg2l atf and pasf_opn atf eq 'ncong then 'false
      else atf) 
   else 
      atf;

procedure pasf_mkpos(atf);
   % Presburger arithmetic standard form make atomic formula positive. [atf]
   % is an atomic formula. Returns an equivalent atomic formula with a
   % positive leading coefficient.
   begin scalar res;
      % Left handside 
      res := if not(rl_tvalp atf) and minusf pasf_arg2l atf then
      	 pasf_anegateat atf
      else
	 atf;
      % Congruences with negative modulus
      if pasf_congp res and minusf pasf_m res then
	 res := pasf_0mk2(((pasf_opn res) . (negf pasf_m res)),pasf_arg2l res);
      return res
   end;

procedure pasf_vf(atf);
   % Presburger arithmetic standard form evaluation of variable free atomic
   % formulas. [atf] is an atomic formula. Returns [atf] if it is not
   % variable-free or a truth value.
   begin
      if (not(rl_tvalp atf) and domainp pasf_arg2l atf) then <<
	 % Parametric modulus
	 if pasf_congp atf and null domainp pasf_m atf then
	    if null pasf_arg2l atf then 
	       return 'false
	    else
	       return atf;
      	 return if pasf_evalatp(pasf_op atf,pasf_arg2l atf) then
   	    'true
      	 else
   	    'false
      >>;
      return atf
   end;	 

procedure pasf_dt(atf);
   % Presburger arithmetic standard form evaluation of definite terms. [atf]
   % is an atomic formula. Returns [atf] if no simplification is possible or a
   % truth value.
   begin scalar pdp,opn;
      if rl_tvalp atf then return atf;
      pdp := pasf_pdp pasf_arg2l atf;
      opn := pasf_opn atf;
      % Positive and negative definite terms
      if pdp eq 'pdef and opn memq '(equal lessp leq) then return 'false;
      if pdp eq 'ndef and opn memq '(equal greaterp geq) then return 'false;
      if pdp eq 'pdef and opn memq '(neq greaterp geq) then return 'true;
      if pdp eq 'ndef and opn memq '(neq lessp leq) then return 'true;
      % Positive and negative semidefinite terms
      if pdp eq 'psdef and opn eq 'lessp then return 'false;
      if pdp eq 'nsdef and opn eq 'greaterp then return 'false;
      if pdp eq 'psdef and opn eq 'geq then return 'true;
      if pdp eq 'nsdef and opn eq 'leq then return 'true;
      if pdp eq 'psdef and opn eq 'neq then return 
	 pasf_0mk2('greaterp,pasf_arg2l atf);
      if pdp eq 'nsdef and opn eq 'neq then return 
	 pasf_0mk2('lessp,pasf_arg2l atf);
      return atf
   end;

procedure pasf_mr(atf);
   % Presburger arithmetic standard form modulo reduction. [atf] is an atomic
   % formula. Returns a modulo free formula equivalent to [atf]. For
   % non-congruences nothing can be done.
   if not rl_tvalp atf and pasf_congp atf and domainp pasf_m atf then
      pasf_0mk2(pasf_op atf,pasf_premf(pasf_arg2l atf,pasf_m atf))
   else
      % For non-congruences nothing can be done
      atf;

procedure pasf_premf(f,m);
   % Positive remainder.
   pasf_premf1(remf(f,m),m);

procedure pasf_premf1(r,m);
   begin scalar c,v,d,rr;
      if domainp r then
	 return if minusf r then addf(r,m) else r;
      c := pasf_premf1(lc r,m);
      v := !*k2f mvar r;
      d := ldeg r;
      rr := pasf_premf1(red r,m);
      return addf(multf(c,exptf(v,d)),rr)
   end;

procedure pasf_ceeq(atf);
   % Presburger arithmetic standard form content elimination (CE) for
   % equalities. [atf] is an atomic formula. Returns an equivalent atomic
   % formula.
   begin scalar g;
      % Nothing to do for non-equalities
      if rl_tvalp atf or not(pasf_opn atf memq '(equal neq)) then
	 return atf;
      % Computing the domain valued content of the coefficients
      g := sfto_dcontentf pasf_arg2l atf;
      return pasf_0mk2(pasf_op atf,quotfx(pasf_arg2l atf, numr simp g))
   end;

procedure pasf_cein(atf);
   % Presburger arithmetic standard form content elimination (CE) for
   % non-equalities. [atf] is an atomic formula. Returns an equivalent atomic
   % formula.
   begin scalar g,decp;
      if rl_tvalp atf or not(pasf_opn atf memq '(leq greaterp geq lessp)) then
	 return atf;
      % Computing the content of the parametric part
      decp := pasf_deci pasf_arg2l atf;
      g := sfto_dcontentf car decp;
      return pasf_0mk2(pasf_op atf,
	 addf(quotfx(car decp,numr simp g),
	    if pasf_opn atf memq '(leq greaterp) then
	       negf pasf_floor(-(cdr decp),g)
	    else if pasf_opn atf memq '(geq lessp) then
	       negf pasf_ceil(-(cdr decp),g)))
   end;

procedure pasf_cecong(atf);
   % Presburger arithmetic standard form content elimination (CE) for
   % congruences. [atf] is an atomic formula. Returns equivalent atomic
   % formula.
   begin scalar inv,m,g;
      % For non-congruences nothing to do
      if rl_tvalp atf or not pasf_congp atf then
	    return atf;
      m := pasf_m atf;
      g := gcdf(m,sfto_dcontentf pasf_arg2l atf);
      atf := pasf_0mk2(pasf_mkop(pasf_opn atf,quotfx(m,numr simp g)),	      
	 quotfx(pasf_arg2l atf,numr simp g));
      m := pasf_m atf;
      g := sfto_dcontentf pasf_arg2l atf;
      inv := domainp m and gcdf(m,g) = 1;
      % Check if the content has an inverse
      return if inv then
	 % Division is always possible
      	 pasf_0mk2(pasf_op atf,quotfx(pasf_arg2l atf,numr simp g))
      else
	 atf
   end;

procedure pasf_se(atf);
   % Presburger arithmetic standard form (un-)solvability check for
   % (in-)equalities. [atf] is an atomic formula. Returns a truth value or
   % [atf].
   begin scalar decp,g;
      % For non-equalities nothing to do
      if rl_tvalp atf or not(pasf_opn atf memq '(neq equal)) then
	 return atf;
      % Computing the content
      decp := pasf_deci pasf_arg2l atf;
      g := sfto_dcontentf car decp;
      if remainder(cdr decp,g) neq 0 and pasf_opn atf eq 'neq then
	 return 'true;
      if remainder(cdr decp,g) neq 0 and pasf_opn atf eq 'equal then
	 return 'false;
      return atf
   end;

procedure pasf_or(atf);
   % Presburger arithmetic standard form order relation reduction. [atf] is an
   % atomic formula. Returns equivalent atomic formula.
   begin scalar decp;
      % For non orderings nothing to do
      if rl_tvalp atf or not(pasf_opn atf memq '(lessp greaterp leq geq)) then
	 return atf;
      % Decomposing the atomic formula
      decp := pasf_deci pasf_arg2l atf;
      if pasf_opn atf eq 'lessp and cdr decp < 0 then
	 return pasf_0mk2('leq, addf(pasf_arg2l atf, numr simp 1));
      if pasf_opn atf eq 'leq and cdr decp > 0 then
	 return pasf_0mk2('lessp, addf(pasf_arg2l atf, negf numr simp 1));
      if pasf_opn atf eq 'greaterp and cdr decp > 0 then
	 return pasf_0mk2('geq, addf(pasf_arg2l atf, negf numr simp 1));
      if pasf_opn atf eq 'geq and cdr decp < 0 then
	 return pasf_0mk2('greaterp, addf(pasf_arg2l atf, numr simp 1));
      return atf
   end;

procedure pasf_sc(atf);
   % Presburger arithmetic standard form (un-)solvability check for
   % (in-)congruences. [atf] is an atomic formula. Returns a truth value or
   % [atf].
   begin scalar g,res,m,decp;
      % For noncongruences nothing to do
      if rl_tvalp atf or not(pasf_opn atf memq '(cong ncong)) or
      	 % For congruences with non-domainvalued modulus nothing is done yet
	 null domainp pasf_m atf then
	    return atf;
      % Decomposing the formula
      decp := pasf_deci pasf_arg2l atf;
      % Computing the content 
      g := sfto_dcontentf car decp;
      m := pasf_m atf;
      % Verbose check for simplification
      res := t;
      for j := 0 : m do
	 res := res and (remainder(cdr decp + j*g,m) neq 0);
      if res and pasf_opn atf eq 'cong then
	 return 'false;
      if res and pasf_opn atf eq 'ncong then
	 return 'true;
      return atf
   end;

procedure pasf_evalatp(rel,lhs);
   % Presburger arithmetic standard form evaluate atomic formula. [rel] is a
   % relation; [lhs] is a domain element. Returns a truth value equivalent to
   % $[rel]([lhs],0)$.
   if pairp rel and car rel memq '(cong ncong) then
      % Only congruences with nonparametric modulus are allowed
      (if domainp cdr rel then pasf_evalatpm(car rel,lhs,cdr rel)
      else rederr{"pasf_evalatp : parametric modulus in input"})
   else
      pasf_evalatpm(rel,lhs,nil);

procedure pasf_evalatpm(rel,lhs,m);
   % Presburger arithmetic standard form evaluate atomic formula
   % subroutine. [rel] is a relation; [lhs] is a domain element; [m] is an
   % optional modulus. Returns a truth value equivalent to $[rel]([lhs],0)$.
   if rel eq 'equal then null lhs or lhs = 0
   else if rel eq 'neq then not (null lhs or lhs = 0)
   else if rel eq 'leq then minusf lhs or (null lhs or lhs = 0)
   else if rel eq 'geq then not minusf lhs
   else if rel eq 'lessp then minusf lhs
   else if rel eq 'greaterp then not (minusf lhs or null lhs or lhs = 0)
   else if rel eq 'cong then 
      (null lhs or lhs = 0) or 0 = remainder(lhs,m)
   else if rel eq 'ncong then 
      not ((null lhs or lhs = 0) or 0 = remainder(lhs,m))
   else rederr {"pasf_evalatp: unknown operator",rel};


procedure pasf_fact(atf);
   % Presburger arithmetic standard form factorization of atomic formulas.
   % [atf] is an atomic formula. Returns atf if no factorization can be done
   % and an equivalent quantifier-free formula else.
   begin scalar fac,op,m;
      if rl_tvalp atf then
	 return atf;
      op := pasf_op atf;
      fac := fctrf pasf_arg2l atf;
      if length fac < 3 then
	 return atf;
      if op memq '(equal neq) then
	 return rl_mkn(if op eq 'equal then 'or else 'and,
	    for each fct in cdr fac collect
	       pasf_0mk2(op,car fct));
      if op memq '(leq lessp geq greaterp) then
	 return pasf_fact1(cdr fac,	    
	    if minusf car fac then pasf_anegrel op else op);
      return atf;
   end;

procedure pasf_fact1(fac,op);
   % Presburger arithmetic standard form factorization of atomic formulas
   % subprocedure. [fac] is a factorization of an atomic formula; [op] is the
   % operator. Returns an equivalent formula to $\prod_i fac(i) op 0$.
   if null cdr fac then
      pasf_0mk2(op,caar fac)
   else if remainder(cdar fac,2) neq 0 then 
      rl_mkn('or,{
	 rl_mkn('and,{pasf_0mk2(op,caar fac),
	    if op memq '(geq greaterp) then 
	       pasf_fact1(cdr fac,op) 
	    else
	       pasf_fact1(cdr fac,pasf_anegrel op)}),
	 rl_mkn('and,{pasf_0mk2(pasf_anegrel op,caar fac),
	    if op memq '(geq greaterp) then 
	       pasf_fact1(cdr fac,pasf_anegrel op) 
	    else
	       pasf_fact1(cdr fac,op)})})
   else
      pasf_fact1(cdr fac,op);

endmodule; % [pasfsiat]

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfbnf.red0000644000175000017500000000645511526203062025036 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfbnf.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(pasf_bnf_rcsid!* pasf_bnf_copyright!*);
   pasf_bnf_rcsid!* :=
      "$Id: pasfbnf.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   pasf_bnf_copyright!* :=
      "Copyright (c) 1995-2009 A. Dolzmann, A. Seidl, T. Sturm"
>>;

module pasfbnf;
% Methods for DNF and CNF computation. For now pseudo- DNF and CNF are
% computed. A pseudo DNF (CNF) is a formula in PNF with matrix in DNF (CNF).

procedure pasf_sacat(a1,a2,gor);
   % Presburger arithmetic standard form subsume and cut atomic formula. [a1]
   % is an atomic formula; [a2] is an atomic formula; [gor] is one of 'or,
   % 'and. Returns for the first trivially nil.
   nil;

procedure pasf_dnf(phi);
   % Presburger arithmetic standard form disjunctive normal form. [phi] is a
   % quantifier free frmula. Returns a pseudo DNF of [phi].
   pasf_pbnf(pasf_pnf phi,'dnf);

procedure pasf_cnf(phi);
   % Presburger arithmetic standard form conjunctive normal form. [phi] is a
   % quantifier free formula. Returns a pseudo DNF of [phi].
   pasf_pbnf(pasf_pnf phi,'cnf);

procedure pasf_pbnf(phi,flag);
   % Presburger arithmetic standard form pseudo boolean normal form
   % computation. [phi] is a formula in PNF; [flag] is one of 'dnf or
   % 'cnf. Returns a pseudo boolean normal form of [phi] according to flag.
   begin
      if rl_bquap rl_op phi then
	 return rl_mkbq(rl_op phi,rl_var phi,rl_b phi,
	    pasf_pbnf(rl_mat phi,flag));
      if rl_quap rl_op phi then
	 return  rl_mkq(rl_op phi,rl_var phi,
	    pasf_pbnf(rl_mat phi,flag));
      % Now assuming that the formula is in PNF the formula is strong
      % quantifier free
      return if flag eq 'dnf then cl_dnf phi else cl_cnf phi
   end;

endmodule; % pasfbnf

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfopt.red0000644000175000017500000000457111526203062025070 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfopt.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 A. Dolzmann and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(pasf_opt_rcsid!* pasf_opt_copyright!*);
   pasf_misc_rcsid!* :=
      "$Id: pasfopt.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   pasf_misc_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann, T. Sturm"
>>;

module pasfopf;
% Presburger arithmetic standard form optimization. This module was introduced
% by lasaruk to experiment with linear optimization.

procedure pasf_opt(cl,targ,parml,nproc);
   % Presburger arithmetic standard form linear optimization. [cl] is a list
   % of constraints; [targ] is the cost function; [paraml] is the list of
   % parameters; [nproc] is NOT COMMENTED. Returns optimal solutions of the
   % problem if any exist.
   rederr {"Linear optimization not yet implemented in context PASF"};

endmodule; % pasfopt

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasfnf.red0000644000175000017500000001734011526203062024667 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasfnf.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2001-2009 A. Dolzmann, A. Lasaruk, A. Seidl, T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(pasf_nf_rcsid!* pasf_nf_copyright!*);
   pasf_nf_rcsid!* :=
      "$Id: pasfnf.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   pasf_nf_copyright!* :=
      "Copyright (c) 1995-2009 A. Dolzmann, A. Lasaruk, A. Seidl, and T. Sturm"
>>;

module pasfnf;
% PASF normal forms. Submodule of PASF. This module provides for now only the
% prenex normal form algorithmus. Possibly should be merged with pasfbnf
% module in the future.

procedure pasf_pnf(phi);
   % Presburger arithmetic standard form prenex normal form. [phi] is a
   % formula. Returns a prenex formula equivalent to [phi].
   pasf_pnf1 rl_nnf phi;

procedure pasf_pnf1(phi);
   % Presburger arithmetic standard form prenex normal form subroutine. [phi]
   % is a positive formula that does not contain any extended boolean
   % operator. Returns a prenex formula equivalent to [phi].
   <<
      if null cdr erg or pasf_qb car erg < pasf_qb cadr erg then
 	 car erg
      else
 	 cadr erg
   >> where erg=pasf_pnf2(cl_rename!-vars phi);

procedure pasf_pnf2(phi);
   % Presburger arithmetic standard form prenex normal form subroutine. [phi]
   % is a positive formula that does not contain any extended boolean
   % operator. Returns a list or prenex formulas equivalent to [phi].
   begin scalar op;
      op := rl_op phi;
      if rl_quap op or rl_bquap op then
 	 return pasf_pnf2!-quantifier(phi);
      if rl_junctp op then
 	 return pasf_pnf2!-junctor(phi);
      if rl_tvalp op then
 	 return {phi};
      if rl_cxp op then
 	 rederr{"pasf_pnf2():",op,"invalid as operator"};
      return {phi}
   end;

procedure pasf_pnf2!-quantifier(phi);
   % Presburger arithmetic standard form prenex normal form subroutine. [phi]
   % is a positive formula that does not contain any extended boolean
   % operator. Returns a list or prenex formulas equivalent to [phi].
   begin scalar pnfmat,tp;
      pnfmat := pasf_pnf2 rl_mat phi;
      % Bounded quantifiers are treated as normal quantifiers
      return if (null cdr pnfmat) or 
	 ((rl_op phi memq '(all ball) and rl_op car pnfmat memq '(all ball)) or
	    (rl_op phi memq '(ex bex) and rl_op car pnfmat memq '(ex bex))) 
      then
	 (if rl_bquap rl_op phi then
	    {rl_mkbq(rl_op phi,rl_var phi,rl_pnf rl_b phi,car pnfmat)}
	 else
       	    {rl_mkq(rl_op phi,rl_var phi,car pnfmat)}) 
      else
	 (if rl_bquap rl_op phi then
       	    {rl_mkbq(rl_op phi,rl_var phi,rl_pnf rl_b phi,cadr pnfmat)}
	 else
	    {rl_mkq(rl_op phi,rl_var phi,cadr pnfmat)});
   end;

procedure pasf_pnf2!-junctor(phi);
   % Presburger arithmetic standard form prenex normal form subroutine. [phi]
   % is a positive formula that does not contain any extended boolean
   % operator. Returns a list or prenex formulas equivalent to [phi].
   begin scalar args,junctor,e,l1,l2,onlyex,onlyall,phi1,phi2;
      integer m,qb;
      junctor := rl_op phi;
      args := rl_argn phi;
      % Preparing the PNF of arguments
      e := for each f in args collect pasf_pnf2(f);
      onlyex := T; onlyall := T;
      for each ej in e do <<
    	 qb := pasf_qb car ej;
    	 if qb > m then <<
 	    m := qb; onlyex := T; onlyall := T
 	 >>;
    	 if cdr ej then <<
 	    l1 := (car ej) . l1;
 	    l2 := (cadr ej) . l2
 	 >> else <<
 	    l1 := (car ej) . l1;
 	    l2 := (car ej) . l2
 	 >>;
	 % Bounded quantifiers are treated as normal quantifiers
    	 if eqn(m,qb) then <<
      	    if rl_op car l1 eq 'all  or rl_op car l1 eq 'ball then
	       onlyex := nil;
      	    if rl_op car l2 eq 'ex or rl_op car l1 eq 'bex then 
	       onlyall := nil
    	 >>
      >>;
      l1 := reversip l1;
      l2 := reversip l2;
      if eqn(m,0) then return {phi};
      if onlyex neq onlyall then
    	 if onlyex then
 	    return {pasf_interchange(l1,junctor,'ex)}
    	 else  % [onlyall]
 	    return {pasf_interchange(l2,junctor,'all)};
      phi1 := pasf_interchange(l1,junctor,'ex);
      phi2 := pasf_interchange(l2,junctor,'all);
      if car phi1 eq car phi2 then
 	 return {phi1}
      else
 	 return {phi1,phi2}
   end;

procedure pasf_qb(phi);
   % Presburger arithmetic standard form quantifier block count. [phi] is a
   % positive formula that does not contain any extended boolean
   % operator. Returns the amount of quantifier blocks in phi. Note that the
   % procedure returns the amount of universal or existential blocks without
   % performing a distinction between normal and bounded quantifiers.
   begin scalar q,tp; integer qb;
      while (rl_quap rl_op phi or rl_bquap rl_op phi) do <<
	 tp := if rl_op phi memq '(ball all) then 'all else 'ex;	       
    	 if tp neq q then <<
      	    qb := qb + 1;
      	    q := if rl_op phi memq '(ball all) then 'all else 'ex
    	 >>;
    	 phi := rl_mat phi
      >>;
      return qb
   end;

procedure pasf_interchange(l,junctor,a);
   % Presburger arithmetic standard form interchange. [l] list of argument
   % formulas; [junctor] is the junction type; [a] is the quantifier. Returns
   % a formula, where the quantifiers are interchanged with the junctor.
   begin scalar ql,b,result;
      while pasf_contains!-quantifier(l) do <<
    	 l := for each f in l collect <<
      	    while (a eq 'all and rl_op f memq '(ball all) or
 	       a eq 'ex and rl_op f memq '(bex ex)) do <<
	       % The list contains operator, variable and bound if there is
	       % one and nil in other case
               b := {rl_op f,rl_var f,if rl_bquap rl_op f then 
		  rl_b f else nil} . b;
               f := rl_mat f
      	    >>;
      	    f
    	 >>;
    	 ql := b . ql;
    	 b := nil;
    	 a := cl_flip a
      >>;
      result := rl_mkn(junctor,l);
      for each b in ql do <<
    	 for each v in b do 
	    if null caddr v then 
	       result := rl_mkq(car v,cadr v,result)
	    else
	       result := rl_mkbq(car v,cadr v,caddr v,result)
      >>;
      return result
   end;

procedure pasf_contains!-quantifier(l);
   % Presburger arithmetic standard form containing quantifier test. [l] is a
   % list of positive formulas that do not contain any extended boolean
   % operator. Returns t iff [l] contains any quantifiers.
   l and (rl_quap rl_op car l or rl_bquap rl_op car l or 
      pasf_contains!-quantifier cdr l);

endmodule; % pasfnf

end; % of the file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/pasf/pasf.red0000644000175000017500000004730711526203062024351 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: pasf.red 637 2010-05-24 18:54:41Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2002-2009 A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(pasf_rcsid!* pasf_copyright!*);
   pasf_rcsid!* := "$Id: pasf.red 637 2010-05-24 18:54:41Z thomas-sturm $";
   pasf_copyright!* :=
      "(c) 2002-2009 A. Dolzmann, A. Seidl, T. Sturm, 2010 T. Sturm"
>>;

module pasf;
% Presburger arithmetic standard form main module. Algorithms on first-order
% formulas over the language of rings together with congruences. Binary
% relations (operators) are [equal], [neq], [leq], [geq], [lessp],
% [greaterp]. Ternary relations are [cong] and [ncong].

create!-package('(pasf pasfbnf pasfmisc pasfnf pasfsiat
   pasfqe pasfsism pasfopt),nil);

fluid '(!*rlnzden !*rlposden !*rladdcond !*rlqeasri !*rlsusi !*rlsifac !*utf8);

load!-package 'redlog;
load!-package 'cl;
load!-package 'rltools;
imports rltools,cl;

fluid '(!*rlverbose secondvalue!*);
flag('(pasf),'rl_package);
flag('(pasf_chsimpat),'full);
flag('(pasf_simpat),'full);
flag('(equal neq leq geq lessp greaterp),'spaced);

% QE-Switches

% QE call to DNF on the input formula's matrix
switch rlpasfdnffirst;
off1 'rlpasfdnffirst;
% Expand bounded quantifiers inside QE, if possible; Not used in the current
% implementation
switch rlpasfexpand;
off1 'rlpasfexpand;
% Simplify intermediate results
switch rlpasfsimplify;
on1 'rlpasfsimplify;
% Approximate bounds by maximal and minimal values
switch rlpasfbapprox;
on1 'rlpasfbapprox;
% Gauss elimination
switch rlpasfgauss;
on1 'rlpasfgauss;
% Full gauss condensing
switch rlpasfgc;
on1 'rlpasfgc;
% Structural condensing
switch rlpasfsc;
on1 'rlpasfsc;
% Structural elimination sets
switch rlpasfses;
on1 'rlpasfses;
% Conflation of structural elimination sets
switch rlpasfconf;
on1 'rlpasfconf;
% If on constrained virtual substitution uses infinity symbols instead of
% cauchy bounds
switch rlqesubi;
on1 'rlqesubi;
% Trun on the old probabilistic mode
switch rlpqeold;
off1 'rlpqeold;

% Force cl_qe to make the formula prenex
switch rlqepnf;  % hack for now - TS
on1 'rlqepnf;

% Verboseswitches

% General verbose switch
switch rlpasfvb;
off1 'rlpasfvb;

% Smart simplification verbose
switch rlsiverbose;
off1 'rlsiverbose;

% Switches automaticly handled on context change
put('pasf,'rl_cswitches,'(
   (rlsism . t)
   (rlsusi . t)));

% Parameters
put('pasf,'rl_params,'(
   (rl_subat!* . pasf_subat)
   (rl_subalchk!* . pasf_subalchk)
   (rl_eqnrhskernels!* . pasf_eqnrhskernels)
   (rl_simplat1!* . pasf_simplat1)
   (rl_fctrat!* . pasf_fctrat)
   (rl_ordatp!* . pasf_ordatp)
   (rl_op!* . pasf_op)
   (rl_simplb!* . pasf_simplb)
   (rl_varsubstat!* . pasf_varsubstat)
   (rl_negateat!* . pasf_negateat)
   (rl_bnfsimpl!* . cl_bnfsimpl)
   (rl_tordp!* . ordp)
   (rl_termmlat!* . pasf_termmlat)
   (rl_sacat!* . pasf_sacat)
   (rl_sacatlp!* . cl_sacatlp)
   (rl_varlat!* . pasf_varlat)
   (rl_smupdknowl!* . pasf_smwupdknowl)
   (rl_smrmknowl!* . pasf_smwrmknowl)
   (rl_smcpknowl!* . pasf_smwcpknowl)
   (rl_smmkatl!* . pasf_smwmkatl)
   (rl_smsimpl!-impl!* . cl_smsimpl!-impl)
   (rl_smsimpl!-equiv1!* . cl_smsimpl!-equiv1)
   (rl_susibin!* . pasf_susibin)
   (rl_susipost!* . pasf_susipost)
   (rl_susitf!* . pasf_susitf)
   (rl_b2terml!* . pasf_b2terml)
   (rl_b2atl!* . pasf_b2atl)
   (rl_bsatp!* . pasf_bsatp)
   (rl_rxffn!* . pasf_rxffn)));

% Services
put('pasf,'rl_services,'(
   (rl_subfof!* . cl_subfof)
   (rl_apnf!* . cl_apnf)
   (rl_atml!* . cl_atml)
   (rl_terml!* . cl_terml)
   (rl_termml!* . cl_termml)
   (rl_ifacl!* . cl_ifacl)
   (rl_ifacml!* . cl_ifacml)
   (rl_tnf!* . cl_tnf)
   (rl_varl!* . cl_varl)
   (rl_fvarl!* . cl_fvarl)
   (rl_bvarl!* . cl_bvarl)
   (rl_all!* . cl_all)
   (rl_ex!* . cl_ex)
   (rl_simpl!* . cl_simpl)
   (rl_atnum!* . cl_atnum)
   (rl_qnum!* . cl_qnum)
   (rl_matrix!* . cl_matrix)
   (rl_qe!* . pasf_qe)
   (rl_wqe!* . pasf_wqe)
   (rl_expand!* . pasf_expand)
   (rl_atl!* . cl_atl)
   (rl_pnf!* . pasf_pnf)
   (rl_dnf!* . pasf_dnf)
   (rl_cnf!* . pasf_cnf)
   (rl_nnf!* . cl_nnf)
   (rl_opt!* . pasf_opt)
   (rl_qea!* . pasf_qea)
   (rl_pqea!* . pasf_pqea)
   (rl_wqea!* . pasf_wqea)
   (rl_pqe!* . pasf_pqe)
   (rl_stex!* . pasf_stex)
   (rl_expanda!* . pasf_expanda)
   (rl_zsimpl!* . pasf_zsimpl)
   (rl_resolve!* . cl_resolve)
   (rl_depth!* . cl_depth)));

% Administration definitions
put('pasf,'simpfnname,'pasf_simpfn);
put('pasf,'rl_prepat,'pasf_prepat);
put('pasf,'rl_resimpat,'pasf_resimpat);
put('pasf,'rl_lengthat,'pasf_lengthat);
put('pasf,'rl_prepterm,'prepf);
put('pasf,'rl_simpterm,'pasf_simpterm);

algebraic infix equal;
put('equal,'pasf_simpfn,'pasf_chsimpat);
put('equal,'number!-of!-args,2);

algebraic infix neq;
put('neq,'pasf_simpfn,'pasf_chsimpat);
put('neq,'number!-of!-args,2);
put('neq,'rtypefn,'quotelog);
newtok '((!< !>) neq);

algebraic infix leq;
put('leq,'pasf_simpfn,'pasf_chsimpat);
put('leq,'number!-of!-args,2);
put('leq,'rtypefn,'quotelog);

algebraic infix geq;
put('geq,'pasf_simpfn,'pasf_chsimpat);
put('geq,'number!-of!-args,2);
put('geq,'rtypefn,'quotelog);

algebraic infix lessp;
put('lessp,'pasf_simpfn,'pasf_chsimpat);
put('lessp,'number!-of!-args,2);
put('lessp,'rtypefn,'quotelog);

algebraic infix greaterp;
put('greaterp,'pasf_simpfn,'pasf_chsimpat);
put('greaterp,'number!-of!-args,2);
put('greaterp,'rtypefn,'quotelog);

algebraic operator cong;
put('cong,'prifn,'pasf_pricong);
put('cong,'pasf_simpfn,'pasf_simpat);
put('cong,'number!-of!-args,3);
put('cong,'rtypefn,'quotelog);
put('cong,'fancy!-prifn,'pasf_fancy!-pricong);

algebraic operator ncong;
put('ncong,'prifn,'pasf_princong);
put('ncong,'pasf_simpfn,'pasf_simpat);
put('ncong,'number!-of!-args,3);
put('ncong,'rtypefn,'quotelog);
put('ncong,'fancy!-prifn,'pasf_fancy!-pricong);

algebraic operator rnd;
put('rnd,'simpfn,'pasf_simprnd);
put('rnd,'number!-of!-args,2);

smacro procedure pasf_op(atf);
   % Presburger arithmetic standard form operator. [atf] is an atomic formula
   % $r(t_1,t_2)$ or $r(t_1,t_2,m)$. Returns $r$ or in case of a congruence
   % the pair $(r . m)$.
   car atf;

smacro procedure pasf_opp(op);
   % Presburger arithmetic standard form operator predicate. [op] is an
   % expression. Returns t iff the name of [op] is a legal operator or
   % relation name. Hardly ever used.
   op memq '(equal neq lessp leq greaterp geq) or
      (pairp op and car op memq '(cong ncong));

smacro procedure pasf_m(atf);
   % Presburger arithmetic standard form modulus operator. [atf] is an atomic
   % formula $t_1 \equiv_m t_2$. Returns $m$.
   cdar atf;

smacro procedure pasf_arg2l(atf);
   % Presburger arithmetic standard form left hand side argument. [atf] is an
   % atomic formula $r(t_1,t_2)$. Returns $t_1$.
   cadr atf;

smacro procedure pasf_arg2r(atf);
   % Presburger arithmetic standard form right hand side argument. [atf] is an
   % atomic formula $r(t_1,t_2)$. Returns $t_2$.
   caddr atf;

smacro procedure pasf_mk2(op,lhs,rhs);
   % Presburger arithmetic standard form make atomic formula. [op] is an
   % operator; [lhs] is the left handside term; [rhs] is the right handside
   % term. Returns the atomic formula $[op]([lhs],[rhs])$.
   {op,lhs,rhs};

smacro procedure pasf_0mk2(op,lhs);
   % Presburger arithmetic standard form make zero right hand atomic
   % formula. [op] is an operator; [lhs] is a term. Returns the atomic formula
   % $[op]([lhs],0)$.
   {op,lhs,nil};

smacro procedure pasf_opn(atf);
   % Presburger arithmetic standard form operator name. [atf] is an
   % atomic formula $r(t_1,t_2)$ or $r(t_1,t_2,m)$. Returns $r$. Used
   % heavily.
   if rl_tvalp atf then
      atf
   else if pairp car atf then
      caar atf
   else
      car atf;

smacro procedure pasf_atfp(f);
   % Presburger arithmetic standard form atomic formula predicate. [f] is a
   % formula. Returns t iff [f] has a legal relation name.
   (pasf_opn f) memq '(equal neq leq geq lessp greaterp
      cong ncong);

smacro procedure pasf_congopp(op);
   op memq '(cong ncong);

smacro procedure pasf_equopp(op);
   op memq '(equal neq);

smacro procedure pasf_congp(atf);
   % Presburger arithmetic standard form congruence atomic formula
   % predicate. [atf] is an atomic formula. Returns t iff the operator
   % is 'cong or 'ncong.
   pairp atf and pairp car atf and pasf_congopp caar atf;

procedure pasf_mkop(op,m);
   % Presburger arithmetic standard form make operator. [op] is an operator;
   % [m] is an optional modulus. Returns $op$ if the operator is not 'cong or
   % 'ncong and $([op] . [m])$ otherwise.
   if op memq '(cong ncong) then
      (op . if null m then
	 % User should use equations instead of congruences modulo 0
      	 rederr{"Modulo 0 congruence created"}
      else
	 m)
   else
      op;

procedure pasf_mkrng(v,lb,ub);
   % Presburger arithmetic standard form make interval range formula. [v] is a
   % variable; [lb] is a lower bound; [ub] is an upper bound. Returns the
   % formula $[lb] \leq [v] \leq [ub]$.
   if lb eq ub then
      pasf_0mk2('equal,addf(v,negf lb))
   else rl_mkn('and,{
      pasf_0mk2('geq,addf(v,negf lb)),
      pasf_0mk2('leq,addf(v,negf ub))});

procedure pasf_simprnd(u);
   % [u] is Lisp Prefix. Returns an SQ.
   <<
      if null u or null cdr u or cddr u then
      	 rederr {"rnd called with",length u,"arguments instead of 2"};
      if not idp cadr u then
	 rederr {"second argument of rnd must be an identifier"};
      mksq({'rnd,reval car u,cadr u},1)
   >>;

procedure pasf_mkrndf(u,key);
   % [u] is an SF; [key] is an interned identifier. Returns an SF.
   numr simp {'rnd,prepf u,key};

procedure pasf_pricong(l);
   % Presburger arithmetic standard form print a congruence. [l] is a lisp
   % prefix. Returns 'failed iff printing failed.
   if null !*nat then
      'failed
   else if !*utf8 then
      pasf_gpricong l
   else <<
      maprin cadr l;
      prin2!* " ~";
      maprin cadddr l;
      prin2!* "~ ";
      maprin caddr l
   >>;

procedure pasf_gpricong(l);
   if numberp cadddr l then <<
      maprin cadr l;
      prin2!* " ";
      prin2!* intern compress nconc(explode car l,explode cadddr l);
      prin2!* " ";
      maprin caddr l
   >> else <<
      maprin cadr l;
      prin2!* " ";
      prin2!* car l;
      prin2!* " ";
      maprin caddr l;
      prin2!* " mod ";
      maprin cadddr l
   >>;

procedure pasf_princong(l);
   % Presburger arithmetic standard form print an incongruence. [l] is a lisp
   % prefix. Returns 'failed iff printing failed.
   if null !*nat then
      'failed
   else if !*utf8 then
      pasf_gpricong l
   else <<
      maprin cadr l;
      prin2!* " #";
      maprin cadddr l;
      prin2!* "# ";
      maprin caddr l
   >>;

procedure pasf_fancy!-pricong(l);
   % Presburger arithmetic standard form texmacs print a congruence. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if rl_texmacsp() then
      pasf_fancy!-pricong!-texmacs l
   else
      pasf_fancy!-pricong!-fm l;

procedure pasf_fancy!-pricong!-texmacs(l);
   % Presburger arithmetic standard form texmacs print a congruence. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if null !*nat then
      'failed
   else <<
      maprin cadr l; % lhs
      if car l eq 'cong then
	 fancy!-prin2 "\equiv"
      else
	 fancy!-prin2 "\not\equiv";
      fancy!-prin2!-underscore();
      fancy!-prin2 "{";
      maprin cadddr l; % modulus
      fancy!-prin2 "}";
      maprin caddr l; % rhs
   >>;

procedure pasf_fancy!-pricong!-fm(l);
   % Presburger arithmetic standard form texmacs print a congruence. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if null !*nat then
      'failed
   else <<
      maprin cadr l;
      if car l eq 'cong then
      	 fancy!-special!-symbol(186,2)
      else <<
	 fancy!-prin2 "/";
	 fancy!-special!-symbol(186,2)
      >>;
      maprin caddr l;
      fancy!-prin2 " (";
      maprin cadddr l;
      fancy!-prin2 ")"
   >>;

procedure pasf_verbosep();
   % Presburger arithmetic standard form verbose switch. Returns t iff the
   % main switch rlverbose is on and the switch rlpasfvb is on.
   !*rlverbose and !*rlpasfvb;

procedure pasf_simpterm(l);
   % Presburger arithmetic standard form simp term. [l] is lisp
   % prefix. Returns [l] as a PASF term.
   numr simp l;

procedure pasf_prepat(atf);
   % Presburger arithmetic standard form prep atomic formula. [atf] is a PASF
   % atomic formula. Returns [atf] in Lisp prefix form.
   if pasf_congp atf then
       {pasf_opn atf,prepf pasf_arg2l atf,prepf pasf_arg2r atf,
	  prepf pasf_m atf}
   else
      pasf_opn atf . for each arg in rl_argn atf collect prepf arg;

procedure pasf_resimpat(atf);
   % Presburger arithmetic standard form resimp atomic formula. [atf] is a
   % PASF atomic formula. Returns the atomic formula [atf] with resimplified
   % terms.
   pasf_mk2(if pasf_congp atf then
      (pasf_opn atf . numr resimp !*f2q pasf_m atf)
   else
      pasf_op atf,
      numr resimp !*f2q pasf_arg2l atf, numr resimp !*f2q pasf_arg2r atf);

procedure pasf_lengthat(atf);
   % Presburger arithmetic standard form length of an atomic formula. [atf] is
   % an atomic formula. Returns a number, the length of [atf].
   length rl_argn atf;
   % Note: This procedure is added only for code compatibility and is not used
   % inside PASF yet.

procedure pasf_chsimpat(l);
   % Presburger arithmetic standard form chain simp. [l] is a lisp prefix.
   % Returns [l] as a conjunction of atomic formulas.
   rl_smkn('and,for each x in pasf_chsimpat1 l collect pasf_simpat x);

procedure pasf_chsimpat1(l);
   % Presburger arithmetic standard form chain simp subprocedure. [l] is a
   % lisp prefix. Returns [l] without chains.
   begin scalar leftl,rightl,lhs,rhs;
      lhs := cadr l;
      if pairp lhs and pasf_opp car lhs then <<
	 leftl := pasf_chsimpat1 lhs;
	 lhs := caddr lastcar leftl
      >>;
      rhs := caddr l;
      if pairp rhs and pasf_opp car rhs then <<
	 rightl := pasf_chsimpat1 rhs;
	 rhs := cadr car rightl
      >>;
      return nconc(leftl,{car l,lhs,rhs} . rightl)
   end;

procedure pasf_simpat(u);
   % Simp atomic formula. [u] is Lisp prefix. Returns an atomic
   % formula.
   begin scalar op,lhs,rhs,nlhs,f,m;
      op := car u;
      if op memq '(cong ncong) then <<
	 if length u neq 4 then
 	    rederr("invalid length in congruence");
	 lhs := subtrsq(simp cadr u,simp caddr u);
	 m := simp cadddr u;
	 if denr lhs neq 1 or denr m neq 1 then
 	    rederr("denominators in congruence");
	 return pasf_0mk2(op . numr m,numr lhs)
      >>;
      lhs := simp cadr u;
      if not (!*rlnzden or !*rlposden or (domainp denr lhs)) then
 	 typerr(u,"atomic formula");
      rhs := simp caddr u;
      if not (!*rlnzden or !*rlposden or (domainp denr rhs)) then
 	 typerr(u,"atomic formula");
      lhs := subtrsq(lhs,rhs);
      nlhs := numr lhs;
      if !*rlposden and not domainp denr lhs then <<
	 f := pasf_0mk2(op,nlhs);
	 if !*rladdcond then
	    f := if op memq '(lessp leq greaterp geq) then
	       rl_mkn('and,{pasf_0mk2('greaterp,denr lhs),f})
	    else
	       rl_mkn('and,{pasf_0mk2('neq,denr lhs),f});
	 return f
      >>;
      if !*rlnzden and not domainp denr lhs then <<
	 if op memq '(lessp leq greaterp geq) then
	    nlhs := multf(nlhs,denr lhs);
	 f := pasf_0mk2(op,nlhs);
	 if !*rladdcond then
	    f := rl_mkn('and,{pasf_0mk2('neq,denr lhs),f});
	 return f
      >>;
      return pasf_0mk2(op,nlhs)
   end;

procedure pasf_termp(exps,exclst);
   % Presburger arithmetic standard form test for a correct presburger
   % term. [exps] is an expression supposed to be a PASF term; [exclst] is an
   % exception list of variables, that are not allowed to be
   % non-linear. Returns t iff the term is a correct UPrA term.
   begin scalar p,errc,oldord;
      oldord:= setkorder({});
      for each var in kernels exps do <<
	 setkorder({var});
	 p := reorder(exps);
	 if var memq exclst then <<
	    % Testing for degree of the variable
	    %if ldeg p > 1 then
	    %   rederr{"Illegal UPrA formula :",
	    %   	  "Quantified variable",var,"with degreee",ldeg p};
	    % Testing for other quantified variables in exception list
	    for each v in exclst do
	       if v neq var and v memq kernels lc p then
 	       	  rederr{"Illegal UPrA formula :",
		  "Quantified variables",var,"and",v,"multiplied"}
	 >>;
	 % Testing for parametric coefficients
	 if not domainp lc p then
	    errc := t
      >>;
      % Term is correct
      setkorder(oldord);
      return errc
   end;

procedure pasf_uprap(f);
   % Presburger arithmetic standard form test for uniform presburger
   % arithmetic formula. [f] is a formula. Returns t only if the formula is
   % in UPrA and not in PrA and raises an error if the formula is neither in
   % PrA nor in UPrA.
   pasf_uprap1(f,nil);

procedure pasf_uprap1(f,bvarl);
   % Presburger arithmetic standard form test for uniform presburger
   % arithmetic formula subprocedure. [f] is a formula; [bvarl] is a list of
   % bounded variables. Returns t only if the formula is in UPrA and not in
   % PrA and raises an error if the formula is neither in PrA nor in UPrA.
   begin scalar s;
      if rl_tvalp f then
      	 return nil;
      if rl_boolp rl_op f then <<
	 % If one of the arguments is in UPrA then the whole formula too
	 for each arg in rl_argn f do
	    s := s or pasf_uprap1(arg,bvarl);
	 return s
      >>;
      if rl_quap rl_op f then
	 return pasf_uprap1(rl_mat f,rl_var f . bvarl);
      if rl_bquap rl_op f then
	 return (pasf_uprap1(rl_mat f,rl_var f . bvarl) or
	    pasf_uprap1(rl_b f,bvarl));
      % Atomic formulas
      return if pasf_congp f then
	 pasf_termp(pasf_arg2l f,bvarl) or not domainp pasf_m f
      else
	 pasf_termp(pasf_arg2l f,bvarl)
   end;

procedure pasf_univnlfp(f,x);
   % Presburger arithmetic standard form univariate nonlinear formula
   % predicate. [f] is a formula; [x] is a variable. Returns t iff [f] is a
   % univariate formula and contains a term, that is not linear in [x].
   begin scalar res;
      for each atf in rl_atl f do
      	 res := res or pasf_univnlp(atf,x);
      return res;
   end;

procedure pasf_univnlp(atf,x);
   % Presburger arithmetic standard form univariate nonlinear atomic formula
   % predicate. [atf] is an atomic formula; [x] is a variable. Returns t iff
   % [atf] is a univariate formula and contains a term, that is not linear in
   % [x].
   begin scalar oldord,res;
      oldord := setkorder({x});
      % quick fix to avoid car on nil (TS)
      if not domainp pasf_arg2l atf and ldeg reorder pasf_arg2l atf > 1 then
	 res := t;
      setkorder oldord;
      return res;
   end;

endmodule; % [pasf]

end; % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/tplp/0000755000175000017500000000000011722677357022763 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/tplp/tplp.tst0000644000175000017500000000367311526203062024463 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: tplp.tst 469 2009-11-28 13:58:18Z arthurcnorman $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

load redlog;

rlset(tplp,{{o,0},{s,3}},{{r,4},{p,0}});

o := 3;

hu := r(o,o,o);

wa := p();

prop 'hu;

prop 'wa;

f := ex(x,r(s(x,x,x),o,s(o,x,y)) and p() and (not r(o,o,x) or hu or wa));

y := s(a,b,c);

f;

rlkapur f;

% Sokrates

rlset(tplp,{{sokrates,0}},{{m,1},{s,1}});

sok := (all(x,m(x) impl s(x)) and m(sokrates)) impl s(sokrates);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/tplp/tplp.red0000644000175000017500000003441111526203062024415 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: tplp.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(tplp_rcsid!* tplp_copyright!*);
   tplp_rcsid!* := "$Id: tplp.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   tplp_copyright!* := "Copyright (c) 2007-2009 T. Sturm"
>>;

module tplp;
% Theorem proving lisp prefix. Main module. Algorithms on first-order
% formulas over a finite language. The terms are represented in lisp
% prefix.

create!-package('(tplp tplpkapur),nil);

load!-package 'redlog;  % for rl_texmacsp()
load!-package 'cl;
load!-package 'rltools;

imports rltools,cl;

global '(tplp_fsyml!* tplp_rsyml!*);

flag('(tplp),'rl_package);

% Parameters
put('tplp,'rl_params,'(
   (rl_op!* . tplp_op)));

% Services
put('tplp,'rl_services,'(
   (rl_kapur!* . tplp_kapur)
   (rl_miniscope!* . tplp_miniscope)
   (rl_skolemize!* . tplp_skolemize)
   (rl_subfof!* . cl_subfof)
   (rl_ex!* . cl_ex)
   (rl_all!* . cl_all)
   (rl_atnum!* . tplp_atnum)
   (rl_qnum!* . cl_qnum)
   (rl_atl!* . cl_atl)
   (rl_atml!* . cl_atml)
   (rl_terml!* . cl_terml)
   (rl_termml!* . cl_termml)
   (rl_cnf!* . tplp_cnf)
   (rl_dnf!* . tplp_dnf)
   (rl_pnf!* . cl_pnf)
   (rl_apnf!* . cl_apnf)
   (rl_nnf!* . cl_nnf)
   (rl_nnfnot!* . cl_nnfnot)
   (rl_bnfsimpl!* . cl_bnfsimpl)
   (rl_sacat!* . cl_sacat)
   (rl_sacatlp!* . cl_sacatlp)
   (rl_negateat!* . tplp_negateat)
   (rl_simpl!* . cl_simpl)
   (rl_smupdknowl!* . cl_smupdknowl)
   (rl_smrmknowl!* . cl_smrmknowl)
   (rl_smcpknowl!* . cl_smcpknowl)
   (rl_smmkatl!* . cl_smmkatl)
   (rl_smsimpl!-impl!* . cl_smsimpl!-impl)
   (rl_smsimpl!-equiv1!* . cl_smsimpl!-equiv1)
   (rl_simplat1!* . tplp_simplat1)
   (rl_ordatp!* . ordop)
   (rl_varl!* . cl_varl)
   (rl_fvarl!* . cl_fvarl)
   (rl_bvarl!* . cl_bvarl)
   (rl_subat!* . tplp_subat)
   (rl_eqnrhskernels!* . tplp_eqnrhskernels)
   (rl_subalchk!* . tplp_subalchk)
   (rl_varlat!* . tplp_varlat)
   (rl_matrix!* . cl_matrix)));

% Admin
put('tplp,'rl_enter,'tplp_enter);
put('tplp,'rl_exit,'tplp_exit);
put('tplp,'simpfnname,'tplp_simpfn);
put('tplp,'rl_prepat,'tplp_prepat);
put('tplp,'rl_resimpat,'tplp_resimpat);
put('tplp,'rl_lengthat,'tplp_lengthat);
put('tplp,'rl_prepterm,'tplp_prepterm);
put('tplp,'rl_simpterm,'tplp_simpterm);

algebraic infix equal;
put('equal,'number!-of!-args,2);
put('equal,'tplp_simpfn,'tplp_simpat);

algebraic infix neq;
put('neq,'number!-of!-args,2);
put('neq,'tplp_simpfn,'tplp_simpat);
put('neq,'rtypefn,'quotelog);
newtok '((!< !>) neq);

flag('(equal neq),'spaced);
flag('(tplp_simpat),'full);

procedure tplp_enter(argl);
   % Theorem proving lisp prefix enter context. [argl] is a list
   % containing lists representing language elements. Returns a pair
   % $(f . l)$. If $f$ is nil then $l$ contains an error message, else
   % $l$ is the new value of [rl_argl!*].
   begin scalar op;
      if not eqn(length argl,2) then
 	 return nil . "wrong number of arguments";
      tplp_fsyml!* := for each x in cdar argl collect <<
	 op := cadr x;
	 if not idp op then
	    typerr(op,"function symbol");
	 if eqn(caddr x,0) then <<
	    lprim {op,"is being reserved"};
	    flag ({op},'reserved)
	 >> else
 	    tplp_mkalop cdr x;
	 cadr x . caddr x
      >>;
      tplp_rsyml!* := for each x in cdadr argl collect <<
	 tplp_mkalop cdr x;
	 tplp_mkpredicate cdr x;
      	 cadr x . caddr x
      >>;
      return T . argl
   end;

procedure tplp_exit();
   % Theorem proving lisp prefix exit context.
   <<
      for each x in tplp_fsyml!* do
	 if eqn(cdr x,0) then
	    remflag({car x},'reserved)
	 else
	    tplp_unmkalop car x;
      for each x in tplp_rsyml!* do <<
	 tplp_unmkalop car x;
	 tplp_unmkpredicate car x
      >>;
      tplp_rsyml!* := nil;
      tplp_fsyml!* := nil;
      nil
   >>;

procedure tplp_mkalop(f);
   % Theorem proving lisp prefix make algebraic operator. [f] is a
   % dotted pair of the form $(op . arity)$.
   (algebraic operator op) where op=car f;

procedure tplp_unmkalop(f);
   % Theorem proving lisp prefix unmake algebraic operator. [f] is an
   % identifier.
   algebraic clear f;

procedure tplp_mkpredicate(r);
   % Theorem proving lisp prefix make predicate. [r] is a
   % dotted pair of the form $(op . arity)$.
   put(car r,'tplp_simpfn,'tplp_simpat);

procedure tplp_unmkpredicate(r);
   % Theorem proving lisp prefix unmake predicate. [r] is an
   % identifier.
   remprop(r,'tplp_simpfn);

procedure tplp_fsyml();
   % Theorem proving Lisp prefix get language.
   tplp_fsyml!*;

procedure tplp_rsyml();
   % Theorem proving Lisp prefix get language.
   tplp_rsyml!*;

procedure tplp_prepat(atf);
   % Theorem proving Lisp prefix prep atomic formula. [atf] is an atomic
   % formula.  Returns [atf] in Lisp prefix form.
   atf;

procedure tplp_lengthat(atf);
   % Theorem proving Lisp prefix length of atomic formula. [atf] is an
   % atomic formula. Returns length of [atf].
   length cdr atf;

procedure tplp_simpterm(term);
   % Theorem proving Lisp prefix simplify term. [term] is a Lisp
   % prefix term. Returns context-specific representation of [term],
   % which is Lisp prefix here. Apart from syntax-checking, reval
   % would work here. We have to take care of rebound atoms.
   begin scalar w; integer arity;
      if atom term then
         return reval term;
      w := atsoc(car term,tplp_fsyml());
      if null w then
	 rederr {car term,"not declared as function symbol"};
      arity := cdr w;
      if not eqn(length cdr term,arity) then
	 rederr {car term, "requires", arity,"arguments"};
      return car term . for each arg in cdr term collect
 	 tplp_simpterm arg
   end;

procedure tplp_resimpterm(term);
   % Theorem proving Lisp prefix resimplify term. [term] is a term.
   % Returns resimplified [term]. We try to be somewhat more efficient
   % than reval.
   if atom term then
      reval term
   else
      car term . for each x in cdr term collect tplp_resimpterm x;

procedure tplp_prepterm(term);
   % Theorem proving Lisp prefix prep term. [term] is a term. Returns
   % the Lisp prefix representaion of term.
   term;

procedure tplp_simpat(atf);
   % Theorem proving Lisp prefix simplify atomic formula. [atf] is
   % Lisp prefix. Returns an atomic formula.
   begin scalar op;
      op := car atf;
      if not (op and atom op) then
 	 typerr (op,"predicate symbol");
      return op . for each x in cdr atf collect tplp_simpterm x
   end;

procedure tplp_resimpat(atf);
   % Theorem proving Lisp prefix simplify atomic formula. [atf] is an
   % atomic formula. Returns atomic formula with resimplified terms.
   car atf . for each x in cdr atf collect tplp_resimpterm x;

procedure tplp_opp(op);
   % Theorem proving Lisp prefix operator predicate. [op] is an atom.
   % Returns non-[nil] if op is a relation.
   atsoc(op,tplp_rsyml());

procedure tplp_op(at);
   % Theorem proving Lisp prefix operator. [at] is an atomic formula.
   % Returns the relation symbol of [at].
   car at;

procedure tplp_arg2l(at);
   % Theorem proving Lisp prefix argument binary operator left hand
   % side. [at] is an atomic formula $R(lhs,rhs)$. Returns $lhs$.
   cadr at;

procedure tplp_arg2r(at);
   % Theorem proving Lisp prefix argument binary operator right hand
   % side. [at] is an atomic formula $R(lhs,rhs)$. Returns $rhs$.
   caddr at;

procedure tplp_argl(f);
   % Theorem proving Lisp prefix argument list. [f] is a formula.
   % Returns the list of arguments of [f].
   cdr f;

procedure tplp_mk2(op,lhs,rhs);
   % Theorem proving Lisp prefix make atomic formula for binary
   % operator. [op] is ['equal] or ['neq], [lhs] and [rhs] are
   % terms. Returns the atomic formula $[op]([lhs],[rhs])$.
   {op,lhs,rhs};

procedure tplp_mkn(op,argl);
   % Theorem proving Lisp prefix make atomic formula for n-ary operator.
   % [op] is ['equal], ['neq] or a predicate symbol, [argl] is a list of
   % terms.  Returns the atomic formula $[op]([argl])$.
   op . argl;

procedure tplp_fop(term);
   % Theorem proving Lisp prefix function operator. [term] is a term $(F
   % args)$. Returns $F$.
   car term;

procedure tplp_fmkn(op,argl);
   % Theorem proving Lisp prefix function make for n-ary operator.
   % [op] is an identifier, [argl] is a list of terms.
   op . argl;

procedure tplp_fargl(term);
   % Theorem proving Lisp prefix function's argument list. [term] is a
   % term. Return the list of argument terms.
   cdr term;

procedure tplp_varlat(atf);
   % Variable list atomic formula. [atf] is an atomic formula. Returns a
   % list of identifiers. The set of variables ocurring in [atf].
   begin scalar l;
      for each x in tplp_argl atf do
         if idp x and null tplp_funcp x then
            l := lto_insertq(x,l)
         else if pairp x and tplp_funcp tplp_fop x then
            l := union(l,tplp_varlterm x);
      return l
   end;

procedure tplp_funcp(op);
   % Theorem proving Lisp prefix function predicate. [op] is an identifier.
   % Returns non-[nil] if op is a function.
   atsoc(op,tplp_fsyml());

procedure tplp_varlterm(term);
   % Variable list term. [term] is a term. Returns a
   % list of identifiers. The set of variables ocurring in [term].
   begin scalar l;
      if idp term then
         return if null tplp_funcp term then {term};
      for each x in tplp_fargl term do
         if idp x and null tplp_funcp x then
            l := lto_insertq(x,l)
         else if pairp x then
            l := union(l,tplp_varlterm x);
      return l
   end;

procedure tplp_subat(al,atf);
   % Substitute in atomic formula. [al] is an
   % alist, [atf] is an atomic formula. Returns an atomic formula.
   tplp_mkn(tplp_op atf,for each x in tplp_argl atf collect tplp_subt(al,x));

procedure tplp_subt(al,u);
   % Substitute in term. [al] is an alist, [u] is a term. Returns a term.
   begin scalar w;
      if idp u and (w := atsoc(u,al)) then
      	 return tplp_clonestruct cdr w;
      if atom u then
      	 return u;
      return tplp_fmkn(tplp_fop u,for each arg in tplp_fargl u collect
         tplp_subt(al,arg))
   end;

procedure tplp_clonestruct(s);
   % Clone structure. [s] is any. Returns any, which is a clone of [s] in a
   % constructive way.
   if atom s then s else (tplp_clonestruct car s) . (tplp_clonestruct cdr s);

procedure tplp_eqnrhskernels(x);
   % Equation right hand side
   % kernels. [x] is an equation. Returns a list of all kernels
   % contained in the right hand side of [x].
   tplp_varlterm cdr x;

procedure tplp_subalchk(al);
   % Substitution alist check.
   ;

procedure tplp_atnum(f);
   % Atomic formula number. [f] is a
   % formula. Returns the number of atomic formulas in [f].
   begin scalar op;
      op := rl_op f;
      if rl_boolp op then
 	 return for each subf in rl_argn f sum tplp_atnum subf;
      if rl_quap op then
    	 return tplp_atnum rl_mat f;
      if rl_tvalp op then return 0;
      % [f] is an atomic formula.
      return 1
   end;

procedure tplp_negateat(atf);
   % Negate atomic formula. [atf] is an atomic formula. Returns the negation
   % of [atf].
   if tplp_op atf eq 'negp then tplp_argl atf else tplp_mkn('negp,atf);

procedure tplp_cnf(f);
   % Conjunctive normalform. [f] is a formula. Returns a formula.
   tplp_removenegp cl_cnf f;

procedure tplp_dnf(f);
   % Disjunctive normalform. [f] is a formula. Returns a formula.
   tplp_removenegp cl_dnf f;

procedure tplp_removenegp(f);
  % Remove help-predicate negp. [f] is a formula. Returns a formula where each
  % negated predicate is replaced by 'not . p.
  if rl_tvalp rl_op f then
     f
  else if rl_boolp rl_op f then
     rl_mkn(rl_op f,for each x in rl_argn f collect tplp_removenegp x)
  else if rl_quap rl_op f then
     rl_mkq(rl_op f,rl_var f,tplp_removenegp rl_mat f)
  else if tplp_op f eq 'negp then
     rl_mk1('not,tplp_argl f)
  else
     f;

procedure tplp_simplat1(at,sop);
   % Simplify atomic formula. (no simplification)
   at;

procedure tplp_constp(term);
   % Constant predicate. [term] is a term. Returns non-nil if [term]
   % is a constant term.
   (idp term and tplp_funcp term) or (pairp term and null tplp_fargl term);

procedure tplp_cons2func(f);
   % Constant to function. [f] is a formula. Returns a formula where
   % every constant is represented as a 0-ary function.
   if rl_tvalp f then
      f
   else if rl_boolp rl_op f then
     rl_mkn(rl_op f,for each x in rl_argn f collect tplp_cons2func x)
   else if rl_quap rl_op f then
      rl_mkq(rl_op f,rl_var f,tplp_cons2func rl_mat f)
   else if tplp_op f eq 'negp then
      rl_mk1('not,tplp_mkn(tplp_op tplp_argl f,for each x in tplp_argl
         tplp_argl f collect tplp_fcons2func x))
   else
      tplp_mkn(tplp_op f,for each x in tplp_argl f collect tplp_fcons2func x);

procedure tplp_fcons2func(term);
   % Term Constant to function. [term] is a term. Returns a term where
   % every constant is represented as a 0-ary function.
   if idp term and tplp_funcp term then
      tplp_fmkn(term,nil)
   else if idp term then
      term
   else
      tplp_fmkn(tplp_fop term,for each x in tplp_fargl term collect
         tplp_fcons2func x);

endmodule;  % [tplp]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/tplp/tplpkapur.red0000644000175000017500000021221411526203062025457 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: tplpkapur.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(tplp_kapur_rcsid!* tplp_kapur_copyright!*);
   tplp_kapur_rcsid!* :=
      "$Id: tplpkapur.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   tplp_kapur_copyright!* := "Copyright (c) 2007-2009 T. Sturm"
>>;

module tplpkapur;
% Author Stefan Kaeser

% global vars
fluid '(tplp_kapuroptions!* tplp_kapuratf0!* tplp_kapuratf1!*);

% own switches
fluid '(!*rlkapurmultimon !*rlkapursplitequiv);
switch rlkapurmultimon,rlkapursplitequiv;
on1 'rlkapursplitequiv;
on1 'rlkapurmultimon;

% import needed switches and global settings
fluid '(!*rlverbose !*modular);

procedure tplp_setkapuroption(opt,val);
   % Set Kapur option. [opt] is an identifier. [val] is any. Returns
   % any (old setting or nil).
   begin scalar oldopt,oldval;
     if oldopt := atsoc(opt,tplp_kapuroptions!*) then <<
     	oldval := cdr oldopt;
     	cdr oldopt := val
     >>
     else
     	tplp_kapuroptions!* := (opt . val) . tplp_kapuroptions!*;
     return oldval
   end;

procedure tplp_getkapuroption(opt);
   % Get Kapur option. [opt] is an identifier. Returns any.
   lto_catsoc(opt,tplp_kapuroptions!*);

procedure tplp_setkapurumode(umode);
   % Set Kapur umode. [umode] is an identifier or nil. Returns any.
   if umode memq '(kapur direct knf kapurknf) then
      tplp_setkapuroption('polygenmode,umode)
   else
      tplp_setkapuroption('polygenmode,'kapur);

procedure tplp_initkapuroptions();
   % Initialise Kapur options. Returns any.
   <<
      tplp_kapuratf0!* := nil;
      tplp_kapuratf1!* := nil;
      tplp_kapuroptions!* := {
         ('polygenmode . 'kapur)
      }
   >>;

procedure tplp_kapur(f,umode);
   % AM interface for rlkapur. [f] is a formula, [umode] is an identifier.
   % Returns ['true] or ['false].
   begin scalar oldmod,oldswitch,newf,polyset;
      oldmod := setmod 2;
      oldswitch := !*modular;
      on1 'modular;
      tplp_initkapuroptions();
      tplp_setkapurumode(umode);
      if !*rlverbose then <<
         ioto_tprin2t "++++ Starting Kapur theorem proving algorithm.";
         ioto_prin2t {"Polynomial generation method: ",
            tplp_getkapuroption 'polygenmode};
         ioto_tprin2t "-------------------------"
      >>;
      newf := tplp_cons2func rl_simpl(f,nil,-1);
      newf := if rl_qnum newf > 0 then tplp_miniscope newf else newf;
      if !*rlkapursplitequiv then
         newf := for each x in tplp_splitequiv newf collect
            tplp_skolemize(x,nil)
      else
         newf := {tplp_skolemize(newf,nil)};
      if !*rlverbose then
         ioto_tprin2t {"-- Splitting and Skolemisation: ",length newf,
            " Formula(e)"};
      polyset := for each x in newf join tplp_polyset(x,0);
      if !*rlverbose then <<
         ioto_tprin2t {"-- Generated polynomials: ",length polyset};
         ioto_tprin2t "-- Compute Groebner Basis..."
      >>;
      polyset := tplp_gb polyset;
      newf := if 1 member polyset then 'true else 'false;
      setmod oldmod;
      if null oldswitch then off1 'modular;
      return newf
   end;

procedure tplp_splitlist(l);
   % Split list. [l] is a list. Returns a pair of lists. Devides a
   % list into two lists with equal length containing all elements of
   % [l]. New lists are created constructive.
   if null l or null cdr l then
      (l . nil)
   else
      (((car l . car w) . (cadr l . cdr w)) where w=tplp_splitlist cddr l);

procedure tplp_binarize(f);
   % Binarize a formula. [f] is a formula. Returns a formula with just
   % binary operators using associative laws.
   if rl_tvalp rl_op f then
      f
   else if rl_quap rl_op f then
      rl_mkq(rl_op f,rl_var f,tplp_binarize rl_mat f)
   else if rl_op f eq 'not then
      rl_mk1('not,tplp_binarize rl_arg1 f)
   else if rl_junctp rl_op f and lto_lengthp(rl_argn f,3,'geq) then
      (rl_mk2(rl_op f,tplp_binarize rl_smkn(rl_op f,car splitl),
         tplp_binarize rl_smkn(rl_op f,cdr splitl))
            where splitl=tplp_splitlist rl_argn f)
   else if rl_boolp rl_op f then
      rl_mk2(rl_op f,tplp_binarize rl_arg2l f,tplp_binarize rl_arg2r f)
   else
      f;

procedure tplp_miniscope(f);
   % Miniscope. [f] is a formula. Returns a formula
   % where each quantifier is as far inside as possible.
   if rl_quap rl_op f then
      tplp_miniscopeq f
   else if rl_boolp rl_op f then
      rl_mkn(rl_op f,for each x in rl_argn f collect tplp_miniscope x)
   else
      f;

procedure tplp_miniscopeq(f);
   % Miniscope qantifier. [f] is a formula of the form $Q x (\alpha)$.
   % Returns a formula where each quantifier is miniscoped.
   begin scalar var,q,mat;
      q := rl_op f;
      var := rl_var f;
      mat := rl_mat f;
      if not(var memq rl_fvarl mat) then
         return tplp_miniscope mat;
      if rl_op mat eq 'not then
         return rl_mk1('not,tplp_miniscope rl_mkq(cl_flip q,var,rl_arg1 mat));
      if rl_quap rl_op mat then
         return tplp_miniscopeqq f;
      if rl_op mat eq 'equiv then
         return tplp_miniscopeqequiv f;
      if not rl_cxp rl_op mat then
         return f;
      if q eq 'ex then
         return tplp_miniscopeex f;
      return tplp_miniscopeall f
   end;

procedure tplp_miniscopeex(f);
   % Miniscope Exquantor. [f] is a formula of the form $'ex x (\alpha)$.
   % Returns a formula where each quantifier is miniscoped.
   begin scalar g,var,b,free,bound;
      g := rl_mat f;
      var := rl_var f;
      if rl_op g eq 'or then
         return rl_mkn('or,for each x in rl_argn g collect
            tplp_miniscope rl_mkq('ex,var,x));
      if rl_op g eq 'impl then
         return rl_mk2('or,rl_mk1('not,tplp_miniscope
            rl_mkq('all,var,rl_arg2l g)),tplp_miniscope
               rl_mkq('ex,var,rl_arg2r g));
      if rl_op g eq 'repl then
         return rl_mk2('or,tplp_miniscope rl_mkq('ex,var,rl_arg2l g),
            rl_mk1('not,tplp_miniscope rl_mkq('all,var,rl_arg2r g)));
      if rl_op g eq 'and then <<
         for each x in rl_argn g do <<
            b := tplp_miniscope x;
            if var memq rl_fvarl b then
               bound := b . bound
            else
               free := b . free
         >>;
         free := rl_mkq('ex,var,rl_smkn('and,reversip bound)) . free;
         return rl_smkn('and,reversip free)
      >>;
      if rl_boolp rl_op g then
         return rl_mkq('ex,var,rl_mkn(rl_op g,for each x in rl_argn g collect
            tplp_miniscope x));
      return f
   end;

procedure tplp_miniscopeall(f);
   % Miniscope Allquantor. [f] is a formula of the form $'all x (\alpha)$.
   % Returns a formula where each quantifier is miniscoped.
   begin scalar g,var,b,free,bound;
      g := rl_mat f;
      var := rl_var f;
      if rl_op g eq 'and then
         return rl_mkn('and,for each x in rl_argn g collect
            tplp_miniscope rl_mkq('all,var,x));
      if rl_op g eq 'or then <<
         for each x in rl_argn g do <<
            b := tplp_miniscope x;
            if var memq rl_fvarl b then
               bound := b . bound
            else
               free := b . free
         >>;
         free := rl_mkq('all,var,rl_smkn('or,reversip bound)) . free;
         return rl_smkn('or,reversip free)
      >>;
      if not(var memq rl_fvarl rl_arg2l g) then
         return tplp_miniscopeqr f;
      if not(var memq rl_fvarl rl_arg2r g) then
         return tplp_miniscopeql f;
      if rl_boolp rl_op g then
         return rl_mkq('all,var,rl_mkn(rl_op g,for each x in rl_argn g collect
            tplp_miniscope x));
      return f
   end;

procedure tplp_miniscopeqequiv(f);
   % Miniscope quantor over equivalence. [f] is a formula of the form
   % $Q(\alpha 'equiv \beta)$. Returns a formula.
   begin scalar a,b,mat,var,q,arg1,arg2;
      mat := rl_mat f;
      var := rl_var f;
      q := rl_op f;
      a := tplp_miniscope rl_arg2l mat;
      b := tplp_miniscope rl_arg2r mat;
      if var memq rl_fvarl a and var memq rl_fvarl b then
         return rl_mkq(q,var,rl_mk2('equiv,a,b));
      if q eq 'ex then <<
         arg1 := tplp_miniscope rl_mkq('ex,var,rl_mk2('and,
            tplp_clonestruct a,tplp_clonestruct b));
         arg2 := rl_mk1('not,
            tplp_miniscope rl_mkq('all,var,rl_mk2('or,a,b)));
         return rl_mk2('or,arg1,arg2)
      >>;
      arg1 := tplp_miniscope rl_mkq('all,var,rl_mk2('impl,
         tplp_clonestruct a,tplp_clonestruct b));
      arg2 := tplp_miniscope rl_mkq('all,var,rl_mk2('repl,a,b));
      return rl_mk2('and,arg1,arg2)
   end;

procedure tplp_miniscopeqr(f);
   % Miniscope quantor right. [f] is a formula of the form $Qx(\alpha
   % \circ \beta)$ where $x$ does not appear free in $\alpha$. Returns
   % a formula.
   begin scalar newq,op,mat;
      op := rl_op rl_mat f;
      mat := rl_mat f;
      newq := if op eq 'repl then cl_flip rl_op f else rl_op f;
      return tplp_miniscope rl_mk2(op,rl_arg2l mat,
         rl_mkq(newq,rl_var f,rl_arg2r mat))
   end;

procedure tplp_miniscopeql(f);
   % Miniscope quantor left. [f] is a formula of the form $Qx(\alpha
   % \circ \beta)$ where $x$ does not appear free in $\beta$. Returns
   % a formula.
   begin scalar newq,op,mat;
      op := rl_op rl_mat f;
      mat := rl_mat f;
      newq := if op eq 'impl then cl_flip rl_op f else rl_op f;
      return tplp_miniscope rl_mk2(op,rl_mkq(newq,rl_var f,rl_arg2l mat),
         rl_arg2r mat)
   end;

procedure tplp_miniscopeqq(f);
   % Miniscope two quantifiers in row. [f] is a formula with two or
   % more quantifiers as toplevel operators. Returns a formula.
   begin scalar g,var,q1;
      q1 := rl_op f;
      var := rl_var f;
      g := tplp_miniscope rl_mat f;
      if rl_quap rl_op g then
         if rl_op g eq q1 then
            g := rl_mkq(q1,rl_var g,tplp_miniscope rl_mkq(q1,var,rl_mat g))
         else
            g := rl_mkq(q1,var,g)
      else
         g := tplp_miniscope rl_mkq(q1,var,g);
      return g
   end;

procedure tplp_skolemize(f,mark);
   % Skolemize. [f] is a formula, [mark] is boolean. Returns a formula
   % without quantifiers.
   if eqn(rl_qnum f,0) or rl_tvalp rl_op f then
      f
   else if rl_op f eq 'not then
      rl_mk1('not,tplp_skolemize(rl_arg1 f,null mark))
   else if rl_boolp rl_op f then
      if rl_junctp rl_op f then
         rl_mkn(rl_op f,for each x in rl_argn f collect tplp_skolemize(x,mark))
      else if rl_op f eq 'impl then
         rl_mk2('impl,tplp_skolemize(rl_arg2l f,null mark),tplp_skolemize(
            rl_arg2r f,mark))
      else if rl_op f eq 'repl then
         rl_mk2('repl,tplp_skolemize(rl_arg2l f,mark),tplp_skolemize(
            rl_arg2r f,null mark))
      else if rl_op f eq 'equiv then
         tplp_skolemize(rl_mk2('and,rl_mk2('impl,rl_arg2l f,rl_arg2r f),rl_mk2(
            'repl,tplp_clonestruct rl_arg2l f,tplp_clonestruct rl_arg2r f)),
               mark)
      else
         f
   else if rl_quap rl_op f then
      tplp_skolemizeq(f,if rl_op f eq 'ex then null mark else mark,mark)
   else
      f;

procedure tplp_skolemizeq(f,markq,markmat);
   % Skolemize quantifier. Subprocedure of tplp_skolemize. [f] is a
   % formula with a quantifier as toplevel operator. [markq] and
   % [markmat] are boolean. Returns a quantifier-free formula.
   if markq then
      cl_subfof({(rl_var f . tplp_skolemizenewvar())},
         tplp_skolemize(rl_mat f,markmat))
   else
      cl_subfof({(rl_var f . tplp_skolemizenewfkt rl_fvarl f)},
         tplp_skolemize(rl_mat f,markmat));

procedure tplp_genauxpred(varl);
   % Generate auxiliary predicate. [varl] is a list of variables.
   % Returns an atomic formula.
   tplp_mkn(compress ('p . cdr explode gensym()),varl);

procedure tplp_skolemizenewvar();
   % Skolemize generate new variable. Returns an identifier.
   compress ('v . cdr explode gensym());

procedure tplp_skolemizenewfkt(varl);
   % Skolemize generate new skolemfkt. [varl] is a list of variables.
   % Returns a term.
   tplp_fmkn(compress ('s . ('k . cdr explode gensym())),varl);

procedure tplp_remnested(pl,op);
   % Remove nested. [pl] is a list, [op] is an identifier. Returns a
   % list where no sublist is starting with [op] anymore by merging
   % into [pl] (applying the associative law).
   for each j in pl join
      if eqcar(j,op) then
         tplp_remnested(cdr j,op)
      else
         {j};

% change formula into set of polynomials
procedure tplp_polyform(f);
   % Polynomial form. [f] is a quantifier-free formula. Returns a
   % polynomial.
   begin scalar a,b;
      if rl_tvalp rl_op f then
         return if rl_op f eq 'true then 1 else 0;
      if rl_op f eq 'not then
         return kpoly_plus {1,tplp_polyform rl_arg1 f};
      if rl_junctp rl_op f then <<
         if rl_op f eq 'and then
            return kpoly_times tplp_polyformlist rl_argn f;
         return kpoly_plus {1,kpoly_times for each j in
            tplp_polyformlist rl_argn f collect kpoly_plus {1,j}}
      >>;
      if rl_boolp rl_op f then <<
         a := tplp_polyform rl_arg2l f;
         b := tplp_polyform rl_arg2r f;
         if rl_op f eq 'impl then
            return kpoly_plus {1,kpoly_times {a,b},tplp_clonestruct a};
         if rl_op f eq 'repl then
            return kpoly_plus {1,kpoly_times {a,b},tplp_clonestruct b};
         if rl_op f eq 'equiv then
            return kpoly_plus {1,a,b};
         if rl_op f eq 'xor then
            return kpoly_plus {a,b}
      >>;
      % f is an atomic formula
      return tplp_polyformatf f
   end;

procedure tplp_polyformatf(atf);
   % Polynomialform of an atomic formula. [atf] is a atomic formula.
   % Returns a polynomial.
   begin scalar negp,patf;
      if tplp_op atf eq 'negp then <<
         negp := 1;
         patf := tplp_argl atf
      >> else <<
         negp := 0;
         patf := atf
      >>;
      if patf member tplp_kapuratf0!* then return kpoly_plus {0,negp};
      if patf member tplp_kapuratf1!* then return kpoly_plus {1,negp};
      return kpoly_atf2poly atf
   end;

procedure tplp_polyformlist(l);
   % Polynomialform list. [l] is a list of formulae. Returns a list of
   % polynomials.
   for each x in l collect tplp_polyform x;

procedure tplp_genpolyform(f,trthval);
   % Generate polynomial form. [f] is a quantifier free formula.
   % [trthval] is 0 or 1. Returns a polynomial without exponents.
   if eqn(trthval,1) then
      kpoly_plus {1,tplp_polyform f}
   else
      tplp_polyform f;

procedure tplp_splitequiv(f);
   % Split formula on equiv. [f] is a formula. Returns a list of formulae.
   % The first entry is the original formula, where all arguments to equiv
   % are replaced by new predicates. Cdr of the list are additional formulae
   % to ensure the conditions of [f]
   begin scalar argn,newargn,newvar,newarg,fl;
      if rl_tvalp rl_op f then
         return {f};
      if rl_quap rl_op f then
         return {f};
      if rl_op f eq 'equiv then <<
         argn := rl_argn f;
         newargn := for each x in argn collect
            if rl_op x eq 'equiv then
               tplp_splitequiv x
            else if not rl_cxp rl_op x and null tplp_argl x then
               {x}
            else <<
               newvar := tplp_genauxpred rl_fvarl x;
               newarg := tplp_splitequiv x;
               newvar . (rl_mk2('equiv,newvar,car newarg) . cdr newarg)
            >>;
         fl := for each x in newargn join cdr x;
         return (rl_mkn(rl_op f,for each x in newargn collect car x) . fl)
      >>;
      if rl_boolp rl_op f then <<
         argn := rl_argn f;
         newargn := for each x in argn collect tplp_splitequiv x;
         fl := for each x in newargn join cdr x;
         return (rl_mkn(rl_op f,for each x in newargn collect car x) . fl)
      >>;
      return {f}
   end;

procedure tplp_polyset(f,trthval);
   % Generate set of polynomials. [f] is a formula. [trthval] is 0 or
   % 1. Returns a list of polynomials equivalent to [f].
   if tplp_getkapuroption 'polygenmode eq 'knf then
      tplp_pset3knf(f,trthval)
   else if tplp_getkapuroption 'polygenmode eq 'direct then
      tplp_psetdirect(f,trthval)
   else if tplp_getkapuroption 'polygenmode memq '(kapur kapurknf) then
      tplp_psetkapur(f,trthval)
   else
      tplp_psetkapur(f,trthval);

procedure tplp_psetsplitnf(f,trthval);
   % Set of polynomials split normalform. [f] is a formula. [trthval]
   % is 0 or 1. Returns a list of formulae, by transforming [f] into a
   % boolean normalform and splitting on basic junctor.
   begin scalar nfop;
      nfop := if eqn(trthval,0) then 'or else 'and;
      f := if eqn(trthval,0) then tplp_dnf f else tplp_cnf f;
      if rl_op f eq nfop then
         return rl_argn f;
      return {f};
   end;

% umode 3KNF

procedure tplp_pset3knf(f,trthval);
   % Generate set of polynomials 3KNF. [f] is a formula, [trthval] is
   % 0 or 1. Returns a list of polynomials by transforming [f] into a
   % conjunctive clausal form, containing max 3 variables per clause.
   begin scalar newf;
      newf := if eqn(trthval,1) then f else rl_mk1('not,f);
      newf := tplp_pset3knfnf newf;
      newf := tplp_pset3knf2(newf,nil);
      if rl_op newf eq 'and then
         newf :=
            rl_mkn('and,for each j in rl_argn newf join tplp_pset3knf3(j,nil))
      else
         newf := rl_smkn('and,tplp_pset3knf3(newf,nil));
      if null !*rlkapurmultimon then
         if rl_op newf eq 'and then
            newf := rl_mkn('and,for each x in rl_argn newf join
               tplp_psetsplitnf(x,1))
         else
            return for each x in tplp_psetsplitnf(newf,1) collect
               tplp_genpolyform(x,1);
      if rl_op newf eq 'and then
         return
            for each j in rl_argn newf collect tplp_genpolyform(j,1);
      return {tplp_genpolyform(newf,1)}
   end;

procedure tplp_pset3knfnf(f);
   % Generate set of polynomials 3KNF negated form. [f] is a formula.
   % Returns a formula in negated form
   if rl_tvalp rl_op f or null rl_boolp rl_op f then
      f
   else if rl_op f eq 'not then
      if null rl_boolp rl_op rl_arg1 f then
         f
      else
         tplp_pset3knfnf1 rl_arg1 f
   else if rl_junctp rl_op f then
      rl_mkn(rl_op f, for each j in rl_argn f collect tplp_pset3knfnf j)
   else if rl_op f eq 'impl then
      rl_mk2('or,tplp_pset3knfnf rl_mk1('not,rl_arg2l f),
         tplp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'repl then
      rl_mk2('or,tplp_pset3knfnf rl_mk1('not,rl_arg2r f),
         tplp_pset3knfnf rl_arg2l f)
   else
      rl_mk2(rl_op f,tplp_pset3knfnf rl_arg2l f,tplp_pset3knfnf rl_arg2r f);

procedure tplp_pset3knfnf1(f);
   % Generate set of polynomials 3KNF negated form subprocedure 1. [f]
   % is a formula, but not an atomic formula. Returns a formula in
   % negated form assuming the operator before [f] was a 'not.
   if rl_tvalp rl_op f then
      cl_flip rl_op f
   else if rl_op f eq 'not then
      tplp_pset3knfnf rl_arg1 f
   else if rl_junctp rl_op f then
      rl_mkn(cl_flip rl_op f,
         for each j in rl_argn f collect tplp_pset3knfnf rl_mk1('not,j))
   else if rl_op f eq 'impl then
      rl_mk2('and,tplp_pset3knfnf rl_arg2l f,tplp_pset3knfnf
         rl_mk1('not,rl_arg2r f))
   else if rl_op f eq 'repl then
      rl_mk2('and,tplp_pset3knfnf rl_mk1('not,rl_arg2l f),
         tplp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'equiv then
      rl_mk2('equiv,tplp_pset3knfnf rl_mk1('not,rl_arg2l f),
         tplp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'xor then
      rl_mk2('equiv,tplp_pset3knfnf rl_arg2l f,tplp_pset3knfnf rl_arg2r f);

procedure tplp_pset3knf2(f,intree);
   % Generate set of polynomials 3KNF subprocedure 2. [f] is a formula
   % in negated form, [intree] is boolean. Returns a formula where
   % only the top-level operator 'and is n-ary.
   if null intree and rl_op f eq 'and then
      rl_smkn('and,for each j in rl_argn f join
         ((if rl_op g eq 'and then rl_argn g else {g}) where
            g=tplp_pset3knf2(j,nil)))
   else
      tplp_binarize f;

procedure tplp_pset3knf3(f,clausevar);
   % Generate set of polynomials 3KNF subprocedure 3. [f] is a formula
   % in binary tree negated form. [clausevar] is an identifier or nil.
   % Returns a list of formulae with max three vars per clause.
   begin scalar nvarl,nvarr,returnlist;
      if rl_tvalp rl_op f then
         return {f};
      if rl_op f eq 'not or null rl_boolp rl_op f then
         return {f};
      if null clausevar then <<
         clausevar := tplp_genauxpred rl_fvarl f;
         returnlist := clausevar . returnlist
      >>;
      if rl_op rl_arg2l f eq 'not or null rl_boolp rl_op rl_arg2l f then
         nvarl := rl_arg2l f
      else <<
         nvarl := tplp_genauxpred rl_fvarl rl_arg2l f;
         returnlist := nconc(returnlist,tplp_pset3knf3(rl_arg2l f,nvarl))
      >>;
      if rl_op rl_arg2r f eq 'not or null rl_boolp rl_op rl_arg2r f then
         nvarr := rl_arg2r f
      else <<
         nvarr := tplp_genauxpred rl_fvarl rl_arg2r f;
         returnlist := nconc(returnlist,tplp_pset3knf3(rl_arg2r f,nvarr))
      >>;
      return rl_mk2('equiv,clausevar,rl_mk2(rl_op f,nvarl,nvarr)) . returnlist;
   end;

% umode Kapur

procedure tplp_psetkapur(f,trthval);
   % Generate set of polynomials Kapur. [f] is a formula. [trthval] is
   % 0 or 1. Returns a list of polynomials by transforming [f] using
   % Kapur and Narendrans optimized Method. [trthval] is the trthvalue
   % which should be achieved.
   if tplp_kapuratf0!* = {1} then
      nil
   else if rl_op f eq 'not then
      tplp_psetkapur(rl_arg1 f,if eqn(trthval,0) then 1 else 0)
   else if eqn(trthval,1) then
      tplp_psetkapurcont f
   else
      tplp_psetkapurtaut f;

procedure tplp_psetkapurtaut(f);
   % Generate set of polynomials Kapur tautology. [f] is a formula.
   % Returns a list of polynomials.
   if rl_op f eq 'impl then
      nconc(tplp_psetkapur(rl_arg2l f,1),tplp_psetkapur(rl_arg2r f,0))
   else if rl_op f eq 'repl then
      nconc(tplp_psetkapur(rl_arg2l f,0),tplp_psetkapur(rl_arg2r f,1))
   else if rl_op f eq 'or then
      for each j in rl_argn f join tplp_psetkapur(j,0)
   else if rl_op f eq 'and then
      tplp_psetkapurnary(f,0)
   else
      tplp_psetkapurnoopt(f,0);

procedure tplp_psetkapurcont(f);
   % Generate set of polynomials Kapur contradiction. [f] is a
   % formula. Returns a list of polynomials.
   if rl_op f eq 'and then
      for each j in rl_argn f join tplp_psetkapur(j,1)
   else if rl_op f eq 'impl and rl_op rl_arg2r f eq 'and then
      tplp_psetkapurdistleft(f,1)
   else if rl_op f eq 'repl and rl_op rl_arg2l f eq 'and then
      tplp_psetkapurdistright(f,1)
   else if rl_op f eq 'or then
      tplp_psetkapurnary(f,1)
   else
      tplp_psetkapurnoopt(f,1);

procedure tplp_psetkapurnary(f,trthval);
   % Generate set of polynomials Kapur n-ary subprocedure 1. [f] is a
   % formula with an n-ary toplevel operator. [trthval] is 0 or 1.
   % Returns a list of polynomials by splitting a n-ary boolean
   % formulae into two equivalent polynomials adding auxiliary vars.
   begin scalar distop,argn,newf;
      argn := tplp_remnested(rl_argn f,rl_op f);
      newf := rl_mkn(rl_op f,argn);
      distop := cl_flip rl_op f;
      if lto_lengthp(argn,4,'geq) then
         return tplp_psetkapurnary1(newf,trthval);
      if lto_lengthp(argn,2,'eqn) then
         return
            if rl_op rl_arg2r f eq distop then
              tplp_psetkapurdistleft(newf,trthval)
            else if rl_op rl_arg2l f eq distop then
               tplp_psetkapurdistright(newf,trthval)
            else
               tplp_psetkapurnoopt(newf,trthval);
      return tplp_psetkapurnoopt(newf,trthval)
   end;

procedure tplp_psetkapurnary1(f,trthval);
   % Generate set of polynomials Kapur n-ary subprocedure 1. [f] is a
   % formula with an n-ary toplevel operator. [trthval] is 0 or 1.
   % Returns a list of polynomials by spliting a n-ary boolean
   % formulae into two equivalent polynomials adding auxiliary vars.
   begin scalar partlists,newvar,l1,l2;
      partlists := tplp_splitlist rl_argn f;
      l1 := car partlists;
      l2 := cdr partlists;
      newvar := tplp_genauxpred nil;
      l1 := rl_mkn(rl_op f,newvar . l1);
      l2 := rl_mkn(rl_op f,rl_mk1('not,newvar) . l2);
      return nconc(tplp_psetkapur(l1,trthval),tplp_psetkapur(l2,trthval))
   end;

procedure tplp_psetkapurnoopt(f,trthval);
   % Generate set of polynomials Kapur without possible optimizations.
   % [f] is a formula. [trthval] is 0 or 1. Returns a list of
   % polynomials.
   begin scalar p,fl,expop;
      if rl_boolp rl_op f then <<
         if tplp_getkapuroption 'polygenmode eq 'kapurknf then
            return tplp_pset3knf(f,trthval);
         if null !*rlkapurmultimon then <<
            expop := if eqn(trthval,1) then 'or else 'and;
            fl := tplp_psetsplitnf(f,trthval);
            return for each x in fl join
               if rl_op x eq expop and lto_lengthp(rl_argn x,4,'geq) then
                  tplp_psetkapur(x,trthval)
               else
                  {tplp_genpolyform(x,trthval)}
         >>
      >>;
      p := tplp_genpolyform(f,trthval);
      if not(eqn(p,0)) then return tplp_psetkapurnoopt1(p)
   end;

procedure tplp_psetkapurnoopt1(p);
   % Generate set of polynomials Kapur without possible optimizations 1.
   % [p] is a non-zero polynomial. Returns a list of polynomials.
   if eqn(p,1) then <<
      tplp_kapuratf0!* := {1};
      {1}
   >> else if kpoly_monomialp p and null cdr kpoly_atfl p then <<
      tplp_kapuratf0!* := (car kpoly_atfl p) . tplp_kapuratf0!*;
      {p}
   >> else if cdr kpoly_monlist p and not cddr kpoly_monlist p then
      if eqn(cadr kpoly_monlist p,1) then <<
            tplp_kapuratf1!* := append(tplp_kapuratf1!*,kpoly_atfl
               car kpoly_monlist p) ;
            {p}
      >> else
         {p}
   else
      {p};

procedure tplp_psetkapurdistleft(f,trthval);
   % Generate set of polynomials Kapur left distributivity. [f] is a
   % formula. [trthval] is 0 or 1. Returns a list of polynomials by
   % applying the distributivity rule first.
   for each j in rl_argn rl_arg2r f join
      tplp_psetkapur(rl_mk2(rl_op f,rl_arg2l f,j),trthval);

procedure tplp_psetkapurdistright(f,trthval);
   % Generate set of polynomials Kapur right distributivity. [f] is a
   % formula. [trthval] is 0 or 1. Returns a list of polynomials by
   % applying the distributivity rule first.
   for each j in rl_argn rl_arg2l f join
      tplp_psetkapur(rl_mk2(rl_op f,rl_arg2r f,j),trthval);

procedure tplp_psetdirect(f,trthval);
   % Generate set of polynomials directly. [f] is a formula. [trthval]
   % is 0 or 1. Returns a list of polynomials.
   if null !*rlkapurmultimon then
      for each x in tplp_psetsplitnf(f,trthval) collect
         tplp_genpolyform(x,trthval)
   else
      {tplp_genpolyform(f,trthval)};

% groebner basis procedures
procedure tplp_gb(pl);
   % Groebner Basis. [pl] is a list of first-order polynomials.
   % Returns a list of polynomials which is a Groebner Basis of [pl].
   begin scalar rules,currules,spolyl,lastrule,redpoly,rls1;
      if null pl then return '(0);
      rls1 := {krule_poly2rule 1};
      rules := tplp_gbinitrules pl;
      currules := rules;
      lastrule := lastpair currules;
      while currules and rules neq rls1 do <<
         spolyl := tplp_gbgenspolyl(car currules,rules);
         while spolyl do <<
            redpoly := tplp_gbreducepoly(car spolyl,rules);
            if eqn(redpoly,1) then <<
               rules := rls1;
               cdr spolyl := nil;
               cdr currules := nil
            >> else <<
               cdr lastrule := tplp_gbgenrules redpoly;
               lastrule := lastpair lastrule
            >>;
            spolyl := cdr spolyl
         >>;
         rules := tplp_gbsimplifyonce(rules,car currules);
         currules := cdr currules
      >>;
      return for each j in rules collect krule_rule2poly j
   end;

procedure tplp_gbgenrules(p);
   % Groebner Basis generate rules. [p] is a polynomial not equal to 1.
   % Returns a list of rules which can be generated by [p].
   begin scalar rule;
      if eqn(p,0) then return nil;
      rule := krule_poly2rule p;
      if rule eq 'failed then return nil;
      if eqn(krule_tail rule,1) and kpoly_monomialp krule_head rule then
         return for each x in kpoly_atfl krule_head rule collect
            krule_mkrule(kpoly_atf2poly x,1);
      return {rule}
   end;

procedure tplp_gbreducepoly(p,rules);
   % Groebner Basis reduce polynomial. [p] is a polynomial. [rules] is
   % a list of rules. Returns a polynomial which is in normalform
   % according to the [rules].
   tplp_gbreducepoly1(p,rules,nil);

procedure tplp_gbreducepoly1(p,rules,currule);
   % Groebner Basis reduce polynomial 1. [p] is a polynomial, [rules] is
   % a list of rules, [currule] is a rule or nil. Returns a polynomial.
   begin scalar chnge,p1,p2;
      chnge := t;
      p1 := p;
      p2 := tplp_clonestruct p;
      while chnge do <<
         for each j in rules do
            if null currule or not(j eq currule) then p1 := krule_apply(p1,j);
         chnge := p1 neq p2 and not(eqn(p1,0));
         if chnge then p2 := tplp_clonestruct p1
      >>;
      return p1
   end;

procedure tplp_gbgenspolyl(rule,rules);
   % Groebner Basis generate s-poly list. [rule] is a rule, [rules] is
   % a list of rules which must contain [rule]. Returns a list of
   % polynomials, which can be generated by [rule] and overlaps.
   begin scalar rpoly,spolyl,olaprules,lastpoly,newrule;
      rpoly := tplp_gbreducepoly1(krule_rule2poly rule,rules,rule);
      if numberp rpoly then return {rpoly};
      newrule := krule_poly2rule rpoly;
      newrule := if newrule eq 'failed then rule else newrule;
      spolyl := {0};
      lastpoly := spolyl;
      cdr lastpoly := tplp_gbspolylidemp newrule;
      lastpoly := lastpair lastpoly;
      cdr lastpoly := tplp_gbspolylself newrule;
      lastpoly := lastpair lastpoly;
      olaprules := rules;
      while not(car olaprules eq rule) do <<
         cdr lastpoly := tplp_gbspolyl(newrule,car olaprules);
         lastpoly := lastpair lastpoly;
         olaprules := cdr olaprules
      >>;
      return list2set spolyl
   end;

procedure tplp_gbspolylidemp(rule);
   % Groebner Basis generate s-poly list idempotentials. [rule] is a rule.
   % Returns a list of polynomials, beeing the s-polynomials overlapping
   % [rule] with idempotential rules.
   list2set for each y in kpoly_monlist krule_head rule join
      for each x in kpoly_atfl y join tplp_gbspolyl(rule,krule_idemprule x);

procedure tplp_gbspolylself(rule);
   % Groebner Basis generate s-poly list self-overlap. [rule] is a rule.
   % Returns a list of polynomials, beeing the s-polynomials overlapping
   % [rule] with itself.
   begin scalar plist,ovp;
      plist := krule_headplist rule;
      while cdr plist do <<
         if eqcar(plist,cadr plist) then ovp := t;
         plist := cdr plist
      >>;
      if null ovp then return nil;
      return list2set tplp_gbspolyl(rule,rule)
   end;

procedure tplp_gbspolyl(rule1,rule2);
   % Groebner Basis generate s-poly list. [rule1] and [rule2] are rules.
   % Returns a list of polynomials, which can be generated by overlapping
   % [rule1] and [rule2].
   if null !*rlkapurmultimon or (kpoly_monomialp krule_head rule1
      and kpoly_monomialp krule_head rule2) then
      tplp_gbspolylmm(rule1,rule2)
   else
      tplp_gbspolylmult(rule1,rule2);

procedure tplp_gbspolylmult(rule1,rule2);
   % Groebner Basis generate s-poly list multi monomials. [rule1] and [rule2]
   % are rules with at least one rule has more than one head monomial.
   % Returns a list of polynomials, which can be generated by overlapping
   % [rule1] and [rule2].
   begin scalar unify1p,ml1,ml2,unifl,spolyl,m1,m2,g,spoly;
      ml1 := kpoly_monlist krule_head rule1;
      ml2 := kpoly_monlist krule_head rule2;
      unify1p := cdr ml1 and cdr ml2;
      for each mon1 in ml1 do for each mon2 in ml2 do <<
         unifl := tplp_gbgetunifierlist(mon1,mon2);
         if unify1p then unifl := nil . unifl;
         for each unif in unifl do <<
            m2 := kpoly_subst(unif,mon1);
            m1 := kpoly_subst(unif,mon2);
            g := intersection(kpoly_atfl m1,kpoly_atfl m2);
            m1 := kpoly_atfl2mon setdiff(kpoly_atfl m1,g);
            m2 := kpoly_atfl2mon setdiff(kpoly_atfl m2,g);
            spoly := kpoly_plus {
               kpoly_times {m1,kpoly_subst(unif,krule_tail rule1)},
               kpoly_times {m2,kpoly_subst(unif,krule_tail rule2)},
               kpoly_times {m1,kpoly_plus for each x in ml1 collect
                  if x eq mon1 then 0 else kpoly_subst(unif,x)},
               kpoly_times {m2,kpoly_plus for each x in ml2 collect
                  if x eq mon2 then 0 else kpoly_subst(unif,x)}
            };
            if not eqn(spoly,0) then spolyl := spoly . spolyl
         >>
      >>;
      return list2set spolyl
   end;

procedure tplp_gbgetunifierlist(mon1,mon2);
   % Groebner Basis get list of unifiers. [mon1] and [mon2] are monomials not
   % equal to 0 or 1. Returns a list of unifiers, to unify [mon1] and [mon2]
   % in all possible ways.
   begin scalar unif,unifl;
      for each atf1 in kpoly_atfl mon1 do
         for each atf2 in kpoly_atfl mon2 do <<
            if tplp_op atf1 eq tplp_op atf2 then <<
               unif := tplp_gbgetunifieratf(atf1,atf2);
               if not(unif eq 'failed) then unifl := unif . unifl
            >>
         >>;
      return unifl
   end;

procedure tplp_gbspolylmm(rule1,rule2);
   % Groebner Basis generate s-poly list two monomials. [rule1] and [rule2]
   % are rules with just one head monomial. Returns a list of polynomials,
   % which can be generated by overlapping [rule1] and [rule2].
   begin scalar spolyl,plist1,plist2,sublist;
      plist1 := krule_headplist rule1;
      plist2 := krule_headplist rule2;
      if null intersection(plist1,plist2) then return nil;
      sublist := tplp_gbgetunifierlist(krule_head rule1,krule_head rule2);
      spolyl := for each mgu in sublist collect
         tplp_gbspolyl1(krule_subst(mgu,rule1),krule_subst(mgu,rule2));
      return list2set spolyl
   end;

procedure tplp_gbspolyl1(rule1,rule2);
   % Groebner Basis generate s-poly list subprocedure. [rule1] and [rule2]
   % are overlapping rules. Returns a polynomial, by overlapping [rule1]
   % and [rule2].
   begin scalar headatfl1,tail1,headatfl2,tail2,g,m1,m2;
      tail1 := krule_tail rule1;
      tail2 := krule_tail rule2;
      if krule_head rule1 = krule_head rule2 then
         return kpoly_plus {tail1,tail2};
      headatfl1 := kpoly_atfl krule_head rule1;
      headatfl2 := kpoly_atfl krule_head rule2;
      g := intersection(headatfl1,headatfl2);
      m1 := kpoly_atfl2mon setdiff(headatfl2,g);
      m2 := kpoly_atfl2mon setdiff(headatfl1,g);
      return kpoly_plus {kpoly_times {m1,tail1},kpoly_times {m2,tail2}}
   end;

procedure tplp_mgu(t1,t2);
   % Most general unifier. [t1] and [t2] are terms. Returns an
   % alist or 'failed.
   if idp t1 then
      tplp_mgu1(t1,t2)
   else if idp t2 then
      tplp_mgu1(t2,t1)
   else if tplp_fop t1 eq tplp_fop t2 then
      tplp_mgulist(tplp_fargl t1,tplp_fargl t2)
   else
      'failed;

procedure tplp_mgulist(l1,l2);
   % Most general unifier. [l1] and [l2] are equal length list of terms.
   % Returns an alist or 'failed.
   begin scalar unif,unif2;
      while l1 and not (unif eq 'failed) do <<
         unif2 := tplp_mgu(tplp_subt(unif,car l1),tplp_subt(unif,car l2));
         if unif2 eq 'failed then
            unif := 'failed
         else
            unif := nconc(unif,unif2);
         l1 := cdr l1;
         l2 := cdr l2
      >>;
      return unif
   end;

procedure tplp_mgu1(v,term);
   % Most general unifier 1. [v] is an identifier, [term] is a term.
   % Returns an alist or 'failed.
   if v eq term then
      nil
   else if v memq tplp_varlterm term then
      'failed
   else
      {(v . term)};

procedure tplp_gbgetunifieratf(atf1,atf2);
   % Groebner Basis get atomic formula unifier. [atf1] and [atf2] are
   % atomic formulae. Returns an alist to unifiy [atf1] and [atf2] or
   % 'failed if no unification is possible.
   if tplp_op atf1 eq tplp_op atf2 then
      tplp_mgulist(tplp_argl atf1,tplp_argl atf2)
   else
      'failed;

procedure tplp_gbinitrules(pl);
   % Groebner Basis init ruleslist. [pl] is a non-empty list of polynomials.
   % Returns a list of rules, generated by the polynomials in [pl].
   begin scalar rules,newrule,newp;
      rules := {krule_poly2rule car pl};
      while pl := cdr pl do <<
         newp := tplp_gbreducepoly(tplp_clonestruct car pl,rules);
         if eqn(newp,1) then <<
            if !*rlverbose then ioto_tprin2t "-- 1 in Ideal Initialisation";
            rules := {krule_poly2rule 1};
            pl := nil . nil
         >>
         else if not eqn(newp,0) then <<
            newrule := krule_poly2rule newp;
            if newrule eq 'failed then newrule := krule_poly2rule car pl;
            rules := newrule . rules
         >>
      >>;
      return rules
   end;

procedure tplp_gbsimplifyonce(rules,currule);
   % Groebner Basis simplify rules. [rules] is a list of rules, [currule]
   % is a rule in [rules]. Returns a list of rules, containing [currule]
   % and all other rules are reduced.
   begin scalar w,poly,nrule,head,tail,rule,stopp; integer remr;
      while stopp := null stopp do <<
         w := rules;
         while w and cdr w and cddr w do <<
            if car w eq currule then w := cdr w;
            rule := car w;
            if null !*rlkapurmultimon then <<
               head := tplp_gbreducepoly1(krule_head rule,rules,rule);
               tail := tplp_gbreducepoly1(krule_tail rule,rules,rule);
               poly := kpoly_plus {head,tail}
            >> else
               poly := tplp_gbreducepoly1(krule_rule2poly rule,rules,rule);
            if eqn(poly,0) then <<
               remr := add1 remr;
               car w := cadr w;
               cdr w := cddr w;
               stopp := nil
            >> else if eqn(poly,1) then <<
               remr := -1;
               car w := krule_poly2rule 1;
               rules := {car w};
               w := nil
            >> else <<
               nrule := krule_poly2rule poly;
               if null !*rlkapurmultimon and nrule eq 'failed then
                  nrule := krule_mkrule(krule_head rule,tail);
               car w := nrule;
               w := cdr w
            >>
         >>
      >>;
      if !*rlverbose then
         ioto_prin2 {" [s",if eqn(remr,-1) then "all" else remr,"]"};
      return rules
   end;

procedure tplp_tordertotalp(m1,m2);
   % Totally termorder predicate. [m1] and [m2] are monomials. Returns
   % t if [m1] > [m2], nil if [m1] < [m2] and ordop([m1],[m2]) if [m1]
   % and [m2] are equal or not comparable regarding the current
   % torder.
   (if ord eq 'eq then ordop(m1,m2) else ord) where ord=tplp_torderp(m1,m2);

procedure tplp_tordertotalatfp(m1,m2);
   % Totally Order atomic formula predicate. [m1] and [m2] are atomic
   % formulae. Returns t if [m1] > [m2], nil if [m1] < [m2] and
   % ordop([m1],[m2]) if [m1] and [m2] are equal or not comparable
   % regarding the current torder.
   if tplp_op m1 eq tplp_op m2 then ordop(m1,m2) else tplp_torderatfp(m1,m2);

procedure tplp_torderp(m1,m2);
   % Termorder predicate. [m1] and [m2] are monomials. Returns t if
   % [m1] > [m2], nil if [m1] < [m2] and 'eq if [m1] and [m2] are
   % equal or not comparable regarding the current torder.
   begin scalar curord,atfl1,atfl2; integer l1,l2;
      curord := tplp_torderp1(m1,m2);
      if not(curord eq 'eq) then return curord;
      if m2 = m1 then return 'eq;
      atfl1 := kpoly_atfl m1;
      atfl2 := kpoly_atfl m2;
      l1 := length atfl1;
      l2 := length atfl2;
      if not eqn(l1,l2) then return l1 > l2;
      l1 := for each x in atfl1 sum length tplp_argl x;
      l2 := for each x in atfl2 sum length tplp_argl x;
      if not eqn(l1,l2) then return l1 > l2;
      if kpoly_plist m1 = kpoly_plist m2 then
         return tplp_ordermsetp(atfl1,atfl2,'tplp_torderatfp);
      return tplp_orderlex(kpoly_plist m1,kpoly_plist m2,'tplp_torderordop)
   end;

procedure tplp_torderp1(m1,m2);
   % Termorder predicate 1. [m1] and [m2] are monomials. Returns t if
   % [m1] > [m2], nil if [m1] < [m2] and 'eq if [m1] and [m2] are
   % equal or not comparable in a fast way regarding the current
   % torder.
   if eqn(m2,0) then t
   else if eqn(m1,0) then nil
   else if eqn(m2,1) then t
   else if eqn(m1,1) then nil
   else 'eq;

procedure tplp_torderordop(id1,id2);
   % Termorder ordop. [id1] and [id2] are identifiers. Returns 'eq
   % if [id1] eq [id2], else [ordop(id1,id2)].
   if id1 eq id2 then 'eq else ordop(id1,id2);

procedure tplp_torderatfp(atf1,atf2);
   % Termorder atomic formula predicate. [atf1] and [atf2] are atomic
   % formulae. Returns t if [atf1] > [atf2], nil if [atf1] < [atf2]
   % and 'eq if [atf1] and [atf2] are equal or not comparable
   % regarding the current torder.
   begin scalar t1,t2; integer l1,l2;
      if tplp_op atf1 eq tplp_op atf2 then <<
         t1 := tplp_fmkn('id,tplp_argl atf1);
         t2 := tplp_fmkn('id,tplp_argl atf2);
         return tplp_tordertpb(t1,t2)
      >>;
      l1 := length tplp_argl atf1;
      l2 := length tplp_argl atf2;
      if not eqn(l1,l2) then return l1 > l2;
      return ordop(tplp_op atf1,tplp_op atf2)
   end;

procedure tplp_tordertp(t1,t2);
   % Termorder term predicate. [t1] and [t2] are terms. Returns t if
   % [t1] > [t2], nil if [t1] < [t2] and 'eq if [t1] and [t2] are
   % equal or not comparable regarding the current torder.
   begin scalar preord; integer l1,l2;
      if t1 = t2 then return 'eq;
      if idp t1 or idp t2 then return tplp_tordervtp(t1,t2);
      if tplp_fop t1 eq tplp_fop t2 then return tplp_tordertpb(t1,t2);
      l1 := length tplp_fargl t1;
      l2 := length tplp_fargl t2;
      if l1 > l2 or (eqn(l1,l2) and ordop(tplp_fop t1,tplp_fop t2)) then
         preord := tplp_tordertpa(t1,t2)
      else
         preord := tplp_torderflip tplp_tordertpa(t2,t1);
      if preord eq 'eq then
         return tplp_tordertpc(t1,t2)
      else
         return preord
   end;

procedure tplp_torderflip(ord);
   % Termorder flip. [ord] is boolean or 'eq. Return boolean or 'eq.
   if ord eq 'eq then 'eq else null ord;

procedure tplp_tordervtp(t1,t2);
   % Termorder variable term predicate. [t1] and [t2] are terms where
   % at least one has to be a variable. Returns t if [t1] > [t2], nil
   % if [t1] < [t2] and 'eq if [t1] and [t2] are equal or not
   % comparable regarding the current torder.
   if idp t1 and idp t2 then
      'eq
   else if idp t1 then
      if t1 memq tplp_varlterm t2 then
         nil
      else
         'eq
   else
      if t2 memq tplp_varlterm t1 then
         t
      else
         'eq;

procedure tplp_tordertpa(t1,t2);
   % Termorder term predicate case a. [t1] and [t2] are terms. Returns
   % t if [t1] > [t2], nil if [t1] < [t2] and 'eq if [t1] and [t2] are
   % equal or not comparable regarding the current torder. Case a of
   % recursive path ordering means the function symbol of [t1] is
   % greater than [t2].
   begin scalar m2,trth;
      trth := t;
      m2 := tplp_fargl t2;
      while m2 do <<
         trth := tplp_tordertp(t1,car m2);
         if null trth or trth eq 'eq then
            m2 := nil
         else
            m2 := cdr m2
      >>;
      return trth
  end;

procedure tplp_tordertpb(t1,t2);
   % Termorder term predicate case b. [t1] and [t2] are terms. Returns
   % t if [t1] > [t2], nil if [t1] < [t2] and 'eq if [t1] and [t2] are
   % equal or not comparable regarding the current torder. Case b of
   % recursive path ordering means the function symbols of [t1] and
   % [t2] are equivalent.
   tplp_ordermsetp(tplp_fargl t1,tplp_fargl t2,'tplp_tordertp);

procedure tplp_tordertpc(t1,t2);
   % Termorder term predicate case c. [t1] and [t2] are terms. Returns
   % t if [t1] > [t2], nil if [t1] < [t2] and 'eq if [t1] and [t2] are
   % equal or not comparable regarding the current torder. Case c of
   % recursive path ordering.
   begin scalar m1,trth,curord;
      m1 := tplp_fargl t1;
      trth := 'eq;
      while m1 do <<
         curord := tplp_tordertp(car m1,t2);
         if null curord or curord eq 'eq then
            m1 := cdr m1
         else <<
            trth := t;
            m1 := nil
         >>
      >>;
      return trth
   end;

procedure tplp_orderlex(l1,l2,orderproc);
   % Lexicographic ordering. [l1] and [l2] are list, [orderproc] is a
   % function that implements an ordering. Returns t if [l1] > [l2],
   % nil if [l1] < [l2] and 'eq if [l1] and [l2] are equal or not
   % comparable regarding [orderproc].
   begin scalar trth;
      trth := 'eq;
      while l1 and l2 and trth eq 'eq do <<
         trth := apply(orderproc,{car l1,car l2});
         l1 := cdr l1;
         l2 := cdr l2
      >>;
      if trth eq 'eq and null l1 and l2 then return nil;
      if trth eq 'eq and l1 and null l2 then return t;
      return trth
   end;

procedure tplp_ordermsetp(ms1,ms2,orderproc);
   % Multiset ordering predicate. [ms1] and [ms2] are multisets,
   % [orderproc] is a function that implements an ordering. Returns
   % t if [l1] > [l2], nil if [l1] < [l2] and 'eq if [l1] and [l2]
   % are equal or not comparable regarding [orderproc].
   begin scalar isect,chkl;
      isect := intersection(ms1,ms2);
      ms1 := setdiff(ms1,isect);
      ms2 := setdiff(ms2,isect);
      if null ms1 and null ms2 then return 'eq;
      if null ms1 then return nil;
      if null ms2 then return t;
      chkl := ms2;
      for each x in ms1 do chkl := for each y in chkl join
         if apply(orderproc,{y,x}) then {y};
      if null chkl then return t;
      chkl := ms1;
      for each x in ms2 do chkl := for each y in chkl join
         if apply(orderproc,{y,x}) then {y};
      if null chkl then return nil;
      return 'eq
   end;

procedure tplp_permlist(l);
   % List of permutations. [l] is a list. Returns a list containing
   % all Permutations of [l]
   if null l then
      l
   else if null cdr l then
      {l}
   else
      for each x in l join
         for each j in tplp_permlist delete(x,l) collect (x . j);

procedure tplp_permlistn(l,n);
   % List of permutations n. [l] is a list, [n] is a non-negative integer.
   % Returns a list, which is a sublist of all permutations of [l].
   % Just the first [n] positions of [l] will go through all permutations,
   % positions [n]+1 won't change. Example: l = '(1 2 3), n = 1. This
   % will return '((1 2 3) (2 1 3) (3 1 2))).
   if null l then
      l
   else if eqn(n,0) or null cdr l then
      {l}
   else
      for each x in l join
         for each j in tplp_permlistn(delete(x,l),n-1) collect (x . j);


endmodule;  % [tplpkapur]

module krule;
% Kapur Rewriterules

% DS
%  ::= ( . ) if null !*rlkapurmultimon
%  ::= ( . ) if !*rlkapurmultimon

procedure krule_mkrule(head,tail);
   % Make rule. [head] and [tail] are polynomials. Returns a rule.
   (head . tail);

procedure krule_head(r);
   % Headpolynomial. [r] is a rule. Returns the head of the rule.
   car r;

procedure krule_tail(r);
   % Tailpolynomial. [r] is a rule. Returns the tail of the rule.
   cdr r;

procedure krule_rule2poly(r);
   % Convert rule into a polynomial. [r] is a rule. Returns a
   % polynomial.
   kpoly_plus {krule_head r,krule_tail r};

procedure krule_idemprule(atf);
   % Idempotential rule. [atf] is an atomic formula. Returns the
   % idempotential rule atf^2 -> atf.
   krule_mkrule({'times,kpoly_atf2poly atf,kpoly_atf2poly atf},
      kpoly_atf2poly atf);

procedure krule_poly2rule(p);
   % Convert a polynomial into a rule. [p] is a polynomial. Returns a
   % rule or 'failed if no unique head monomial can be choosen and
   % !*rlkapurmultimon is nil.
   begin scalar monlist,maxmonlist;
      if kpoly_monomialp p then return (p . 0);
      monlist := kpoly_monlist p;
      maxmonlist := kpoly_maxmonlist p;
      if null !*rlkapurmultimon and cdr maxmonlist then
         return 'failed;
      return krule_mkrule(kpoly_plus maxmonlist,
         kpoly_plus setdiff(monlist,maxmonlist))
   end;

procedure krule_subst(al,r);
   % Substitute. [al] is an alist, [r] is an rule. Returns [r] where
   % all substitutions of [al] are used on head and tail.
   krule_mkrule(kpoly_subst(al,krule_head r),kpoly_subst(al,krule_tail r));

procedure krule_apply(p,rule);
   % Apply rule. [p] is a polynomial, [rule] is a rule. Returns a
   % polynomial.
   if rule = '(1 . 0) then
      0
   else if null !*rlkapurmultimon or kpoly_monomialp krule_head rule then
      krule_applymonhead(p,rule)
   else if kpoly_monomialp p then
      p
   else
      krule_applymulthead(p,rule);

procedure krule_applymulthead(p,rule);
   % Apply rule with more than one head monomial. [p] is a polynomial,
   % [rule] is a rule with at least two headmonomials. Returns
   % a polynomial.
   begin scalar restmon,posmonal,headplist,monplist,headlgth,redpolyl;
      if numberp p or kpoly_monomialp p then return p;
      headlgth := length kpoly_monlist krule_head rule;
      if length kpoly_monlist p < headlgth then return p;
      headplist := krule_headplist rule;
      for each mon in kpoly_monlist p do <<
         monplist := kpoly_plist mon;
         if not lto_sublistp(monplist,headplist) then
            restmon := mon . restmon
         else
            posmonal := lto_alinsert(monplist,mon,posmonal)
      >>;
      if null posmonal then return p;
      for each x in posmonal do
         if length cdr x < headlgth then
            restmon := nconc(restmon,cdr x)
         else
            redpolyl := krule_applymulthead1(cdr x,rule) . redpolyl;
      if null redpolyl then return p;
      return kpoly_plus nconc(restmon,redpolyl)
   end;

procedure krule_applymulthead1(mlist,rule);
   % Apply rule with more than one head monomial subprocedure. [mlist] is
   % a list of monomials which shares the same predicate symbols and list
   % length is greater or equal to headlength of [rule].
   % Returns a polynomial.
   begin scalar plist,multp;
      plist := kpoly_plist car mlist;
      while null multp and cdr plist do <<
         multp := car plist eq cadr plist;
         plist := cdr plist
      >>;
      if null multp then return krule_applymulthead1simp(mlist,rule);
      return krule_applymulthead1full(mlist,rule)
   end;

procedure krule_applymulthead1simp(mlist,rule);
   % Apply rule with more than one head monomial subprocedure simple.
   % [mlist] is a list of monomials which shares the same predicate
   % symbols and list length is greater or equal to headlength of [rule].
   % No predicate symbol can appear more than once in a monomial.
   % Returns a polynomial.
   begin scalar perml,monfac,curmon,headml,subal;
      headml := kpoly_monlist krule_head rule;
      perml := tplp_permlistn(mlist,length headml);
      subal := 'failed;
      while perml and subal eq 'failed do <<
         monfac := nil;
         curmon := krule_apply(caar perml,krule_mkrule(car headml,1));
         if curmon neq caar perml then <<
            monfac := curmon;
            subal := krule_applymulthead1simp1(car perml,headml,monfac);
         >>;
         perml := cdr perml
      >>;
      if subal eq 'failed or null monfac then return kpoly_plus mlist;
      curmon := kpoly_times {monfac,krule_rule2poly krule_subst(subal,rule)};
      return kpoly_plus (curmon . mlist)
   end;

procedure krule_applymulthead1simp1(mlist,headml,monfac);
   % Apply multi head monomial1simpl1. [mlist] and [headml] are lists
   % of monomials, [monfac] is a monomial not equal to 0. Returns an
   % alist beeing a substitution, so [monfac]*[headml] will match [mlist]
   % or 'failed if such a substitution is not possible.
   begin scalar al,curmon;
     while headml and not(al eq 'failed) do
         if null kpoly_mondivp(car mlist,monfac) then
            al := 'failed
         else <<
            curmon := kpoly_divmon(car mlist,monfac);
            al :=
               krule_appgetsubaldir(kpoly_atfl curmon,kpoly_atfl car headml,al);
            mlist := cdr mlist;
            headml := cdr headml
         >>;
      return al
   end;

procedure krule_applymulthead1full(mlist,rule);
   % Apply rule with more than one head monomial subprocedure. [mlist]
   % is a list of monomials which shares the same predicate symbols and
   % list length is greater or equal to headlength of [rule].
   % Returns a polynomial.
   begin scalar perml,monfac,headml,subal,curmon;
      headml := kpoly_monlist krule_head rule;
      perml := tplp_permlistn(mlist,length headml);
      subal := 'failed;
      while perml and subal eq 'failed do <<
         subal := krule_applymulthead1full1(car perml,headml);
         if not(subal eq 'failed) then
            monfac := kpoly_divmon(caar perml,kpoly_subst(subal,car headml));
         perml := cdr perml
      >>;
      if subal eq 'failed or null monfac then return kpoly_plus mlist;
      curmon := kpoly_times {monfac,krule_rule2poly krule_subst(subal,rule)};
      return kpoly_plus (curmon . mlist)
   end;

procedure krule_applymulthead1full1(mlist,headml);
   % Apply multi head monomial1full1. [mlist] and [headml] are lists
   % of monomials. Returns an alist beeing a substitution, so
   % [monfac]*[headml] will match [mlist] or 'failed if such a
   % substitution is not possible.
   begin scalar facal,monfac;
      facal := krule_applymongetfacal(
         kpoly_atfl car mlist,kpoly_atfl car headml,kpoly_plist car mlist);
      monfac := lto_catsoc('cofactor,facal);
      monfac := if null monfac then 1 else kpoly_times monfac;
      return krule_applymulthead1full2(mlist,headml,monfac,nil);
   end;

procedure krule_applymulthead1full2(mlist,headml,monfac,subal);
   % Apply multi head monomial1full2. [mlist] and [headml] are lists
   % of monomials. [monfac] is a non-zero monomial and [subal] is an
   % substitution alist. Returns an alist or 'failed.
   begin scalar curmon,curheadmon,suball,nsubal,cursub,curmonfac;
      if null headml or subal eq 'failed then return subal;
      if null kpoly_mondivp(car mlist,monfac) then return 'failed;
      curheadmon := car headml;
      curmon := kpoly_divmon(car mlist,monfac);
      nsubal := 'failed;
      suball := list2set(krule_appgetsuball(curmon,curheadmon,subal));
      while suball and nsubal eq 'failed do <<
         cursub := car suball;
         curmonfac := kpoly_times {monfac,kpoly_divmon(curmon,
            kpoly_subst(cursub,curheadmon))};
         nsubal :=
            krule_applymulthead1full2(cdr mlist,cdr headml,curmonfac,cursub);
         suball := cdr suball
      >>;
      return nsubal;
   end;

procedure krule_appgetsuball(curmon,curheadmon,subal);
   % Apply rule get all substitution alists. [curmon] and [curheadmon]
   % are monomials. [subal] is an alist. Returns a list of alists,
   % containing all possible substitutions for [curheadmon] dividing
   % [curmon].
   begin scalar nsub,suball;
      if subal eq 'failed then return nil;
      if eqn(curheadmon,1) then return {subal};
      for each headx in kpoly_atfl curheadmon do
         for each monx in kpoly_atfl curmon do <<
            nsub := krule_appgetsubal(monx,headx,subal);
            if not(nsub eq 'failed) then
               suball := nconc(suball,krule_appgetsuball(
                  kpoly_divmon(curmon,kpoly_atf2poly monx),
                  kpoly_divmon(curheadmon,kpoly_atf2poly headx),nsub))
            >>;
      return suball
   end;

procedure krule_applymonhead(p,rule);
   % Apply rule with one headmonomial. [p] is a polynomial. [rule] is
   % a rule having a monomial as head. Returns a polynomial.
   if numberp p then
      p
   else if kpoly_monomialp p then
      krule_applymon(p,rule)
   else
      kpoly_plus for each x in kpoly_monlist p collect krule_applymon(x,rule);

procedure krule_applymon(m,rule);
   % Apply rule on monomial. [m] is a monomial, [rule] is a rule not
   % equal to (1 -> 0). Returns a polynomial which is created by
   % applying [rule] once on [m].
   begin scalar plistrule,subal,facal,w,v;
      if numberp m then
         return m;
      plistrule := krule_headplist rule;
      if null lto_sublistp(kpoly_plist m,plistrule) then
         return m;
      if kpoly_mondivp(m,krule_head rule) then return krule_applymon1(m,rule);
      facal := krule_applymongetfacal(kpoly_atfl m,kpoly_atfl krule_head rule,
         plistrule);
      if w := lto_catsoc('singlm,facal) then
         subal := krule_appgetsubaldir(w,lto_catsoc('singlh,facal),nil);
      if subal eq 'failed then
         return m;
      if w := lto_catsoc('multm,facal) then
         subal := krule_appgetsubalmult(w,lto_catsoc('multh,facal),subal);
      if subal eq 'failed then
         return m;
      rule := krule_subst(subal,rule);
      v := kpoly_atfl2mon
         setdiff(lto_catsoc('multm,facal),kpoly_atfl krule_head rule);
      w := kpoly_atfl2mon lto_catsoc('cofactor,facal);
      return kpoly_times {v,w,krule_tail rule};
   end;

procedure krule_appgetsubaldir(atfm,atfr,subal);
   % Apply rule, get substitution alist direct. [atfm] and [atfr] are
   % lists of atomic formulae, having the same predicate symbols,
   % within the same order, [subal] is an alist with already fixed
   % substitutions. Returns an alist which substitutes all
   % vars in [atfr] in a way that [atfr] will be equal to [atfm] after
   % substitution. If such a substitution is not possible, 'failed
   % will be returned.
   if subal eq 'failed or null atfm or null atfr then
      subal
   else
      krule_appgetsubaldir(cdr atfm,cdr atfr,
         krule_appgetsubal(car atfm,car atfr,subal));

procedure krule_appgetsubalmult(atfm,atfr,subal);
   % Apply rule, get substitution alist multi. [atfm] and [atfr] are
   % lists of atomic formulae, having the same predicate symbols.
   % [subal] is an alist of already fixed substitutions. Returns an
   % alist which substitutes all vars in [atfr] in a way that a
   % sublist of [atfm] will be equal to [atfm] after substitution. If
   % such a substitution is not possible, 'failed will be returned.
   begin scalar alatfm,alatfr;
      for each x in atfm do alatfm := lto_alinsert(tplp_op x,x,alatfm);
      for each x in atfr do alatfr := lto_alinsert(tplp_op x,x,alatfr);
      return krule_appgetsubalmult1(alatfm,alatfr,subal);
   end;

procedure krule_appgetsubalmult1(alatfm,alatfr,subal);
   % Apply rule, get substitution alist multi subprocedure. [alatfm]
   % and [alatfr] are alists, car is the predicate symbol, cdr a list
   % of atomic formulae. [subal] is an alist of already fixed
   % substitutions. Returns an alist.
   begin scalar subal1,permlist,atfm,atfr;
      if null alatfm then return subal;
      atfm := cdar alatfm;
      atfr := cdar alatfr;
      permlist := tplp_permlistn(atfm,length atfr);
      subal1 := 'failed;
      while permlist and subal1 eq 'failed do <<
         subal1 := krule_appgetsubaldir(car permlist,atfr,subal);
         if not(subal1 eq 'failed) then
            subal1 := krule_appgetsubalmult1(cdr alatfm,cdr alatfr,subal1);
         permlist := cdr permlist
      >>;
      return subal1
   end;

procedure krule_applymongetfacal(m,head,plistrule);
   % Apply rule on monomial get factors alist. [m] and [head] are
   % lists of atfs,
   % [plistrule] is a list of predicatesymbols in [head]. Returns an
   % alist containing five entries:
   % 'cofactor -> sublist of [m], containing all atfs not appearing in head;
   % 'singlm -> sublist of [m], atfs which appear in [m] once;
   % 'multm -> rest of [m];
   % 'singlh -> sublist of [head] appearing once in head;
   % 'multh -> rest of h.
   begin scalar multl,w,al;
      al := {('cofactor . nil),('singlm . nil),('multm . nil),('singlh . nil),
         ('multh . nil)};
      for each w on m do
         if not(tplp_op car w memq plistrule) then
            al := lto_alinsert('cofactor,car w,al)
         else if cdr w and tplp_op car w eq tplp_op cadr w then <<
            multl := lto_insertq(tplp_op car w,multl);
            al := lto_alinsert('multm,car w,al)
         >> else if tplp_op car w memq multl then
            al := lto_alinsert('multm,car w,al)
         else
            al := lto_alinsert('singlm,car w,al);
      for each x in head do
         if tplp_op x memq multl then
            al := lto_alinsert('multh,x,al)
         else
            al := lto_alinsert('singlh,x,al);
      return for each x in al collect (car x . reversip cdr x)
   end;

procedure krule_appgetsubal(atfm,atfr,al);
   % Apply rule, get substitution alist. [atfm] and [atfr] are atomic
   % formulae. [al] is an alist which might have substitutions already.
   % Returns an alist which substitutes all vars in [atfr] in a way that
   % [atfr] will be equal to [atfm] after substitution. If such a
   % substitution is not possible, 'failed will be returned.
   if tplp_op atfm eq tplp_op atfr then
      krule_appgetsubal2(tplp_argl atfm,tplp_argl atfr,al)
   else
      'failed;

procedure krule_appgetsubal1(termm,termr,al);
   % Apply rule, get substitution alist 1. [termm] and [termr] are
   % terms, [al] is an alist. Returns an alist or 'failed.
   begin scalar olds;
      if atom termr then <<
         olds := atsoc(termr,al);
         if olds and termm neq cdr olds then return 'failed;
         if not olds then return (termr . termm) . al;
         return al
      >>;
      if atom termm then return 'failed;
      if tplp_fop termm neq tplp_fop termr then return 'failed;
      return krule_appgetsubal2(tplp_fargl termm,tplp_fargl termr,al);
   end;

procedure krule_appgetsubal2(termlm,termlr,al);
   % Apply rule, get substitution alist 2. [termlm] and [termlr] are
   % lists of terms with equal length, [al] is an alist.
   % Returns an alist or 'failed.
   if al eq 'failed or null termlm then
      al
   else
      krule_appgetsubal2(cdr termlm,cdr termlr,
         krule_appgetsubal1(car termlm,car termlr,al));

procedure krule_applymon1(m,rule);
   % Apply rule on monomial 1. [m] is a monomial and [rule] is a rule
   % with a single head monomial which divides [m]. Returns a polynomial.
   if rule = '(1 . 0) then
      0
   else if rule = '(1 . 1) then
      m
   else if numberp m then
      m
   else if m = krule_head rule then
      tplp_clonestruct krule_tail rule
   else <<
      for each j in kpoly_atfl krule_head rule do m := delete(j,m);
      kpoly_times {m,tplp_clonestruct krule_tail rule}
   >>;

procedure krule_headplist(rule);
   % Headmonomial predicate list. [rule] is a rule. Returns the list
   % of predicate symbols in the headmonomial(s).
   if kpoly_monomialp krule_head rule then
      kpoly_plist krule_head rule
   else
      kpoly_plist car kpoly_monlist krule_head rule;

endmodule; %[krule]

module kpoly;
% Kapur Polynomials

% DS
%  ::=  | ('plus,...,,...)
%  ::= 0 | 1 |  | ('times,...,,...)

procedure kpoly_atf2poly(f);
   % Polynomial form of an atomic formula. [f] is an atomic formula.
   % Returns a monomial.
   if tplp_op f eq 'negp then
      kpoly_plus {1,tplp_clonestruct tplp_argl f}
   else
      tplp_clonestruct f;

procedure kpoly_atfl2mon(atfl);
   % List of atomic formulae to monomial. [atfl] is a list of atomic
   % formulae. Returns a monomial.
   if null atfl then
      1
   else if null cdr atfl then
      car atfl
   else
      kpoly_times atfl;

procedure kpoly_atfl(m);
   % Get list of atomic formulae. [m] is a monomial. Returns a list of
   % atomic formulae appearing in [m].
   if eqcar(m,'times) then cdr m else if not numberp m then {m};

procedure kpoly_monlist(p);
   % Get list of monomials. [p] is a polynomial. Returns a list of
   % monomials in [p].
   if kpoly_monomialp p then
      {p}
   else
      cdr p;

procedure kpoly_times(l);
   % Polynomial times. [l] is a non-empty list of polynomials. Returns
   % the product of the polynomials in [l].
   begin scalar setlvar,setlsum,curpoly;
      l := tplp_remnested(l,'times);
      if 0 member l then return 0;
      for each j in l do
         if null kpoly_monomialp j then
            setlsum := lto_insert(j,setlsum)
         else if not eqn(j,1) then
            setlvar := lto_insert(j,setlvar);
      setlvar := sort(setlvar,'tplp_tordertotalatfp);
      if null setlsum then
         return kpoly_norm ('times . setlvar);
      if null setlvar and null cdr setlsum then
         return car setlsum;
      if setlvar then
         curpoly := kpoly_norm ('times . setlvar)
      else <<
         curpoly := car setlsum;
         setlsum := cdr setlsum
      >>;
      while setlsum do <<
         curpoly := kpoly_times2(curpoly,car setlsum);
         setlsum := if not eqn(curpoly,0) then cdr setlsum
      >>;
      return curpoly
   end;

procedure kpoly_times2(p1,p2);
   % Polynomial times2. [p1] and [p2] are polynomials. Returns a
   % polynomial beeing the product of [p1] and [p2].
   if kpoly_monomialp p1 and kpoly_monomialp p2 then
      kpoly_times2monoms(p1,p2)
   else if kpoly_monomialp p1 then
      kpoly_times2monomsum(p1,p2)
   else if kpoly_monomialp p2 then
      kpoly_times2monomsum(p2,p1)
   else
      kpoly_times2sums(p1,p2);

procedure kpoly_times2sums(s1,s2);
   % Polynomial times 2 sums. [s1] and [s2] are polynomials.
   % Returns a polynomial being the multiplication of [s1] and [s2].
   kpoly_plus for each j in kpoly_monlist s1 collect kpoly_times2monomsum(j,s2);

procedure kpoly_times2monomsum(m,s);
   % Polynomial times2 monomial and sum. [m] is a monomial, [s] is a
   % polynomial. Returns a polynomial beeing the product of [m] and [s].
   if kpoly_monomialp s then
      kpoly_times2monoms(m,s)
   else
      kpoly_plus for each j in kpoly_monlist s collect kpoly_times2monoms(m,j);

procedure kpoly_times2monoms(m1,m2);
   % Polynomial times2 monomials. [m1] and [m2] are monomials.
   % Returns a monomial containing all ATFs of [m1] and [m2]. The
   % result list is sorted.
   if eqn(m1,0) or eqn(m2,0) then
      0
   else if eqn(m1,1) then
      m2
   else if eqn(m2,1) then
      m1
   else
      kpoly_norm ('times .
         sort(union(kpoly_atfl m1,kpoly_atfl m2),'tplp_tordertotalatfp));

procedure kpoly_plus(l);
   % Polynomial plus. [l] is a non-empty list of polynomials. Returns
   % a polynomial equated the addition of the polynomials in [l]. The
   % result is sorted using ordop().
   begin scalar tmpl,w;
      tmpl := 0 . sort(0 . tplp_remnested(l,'plus),'ordop);
      w := tmpl;
      while cdr w do
         if eqn(cadr w,0) then
            cdr w := nil
         else if cadr w = caddr w then
            cdr w := cdddr w
         else
            w := cdr w;
      return kpoly_norm ('plus . cdr tmpl)
    end;

procedure kpoly_divmon(m1,m2);
   % Divide monomial. [m1] and [m2] are monomials where [m2] divides [m1].
   % Returns the monomial [m1/m2].
   if eqn(m2,1) or eqn(m1,0) then
      m1
   else
      kpoly_norm ('times . for each x in kpoly_atfl m1 join
         if not(x member kpoly_atfl m2) then {x});

procedure kpoly_monomialp(p);
   % Monomial predicate. [p] is a polynomial. Returns non-nil if [p]
   % is not starting with 'plus.
   not eqcar(p,'plus);

procedure kpoly_subst(al,p);
   % Substitution. [al] is an alist, [p] is a polynomial. Returns a
   % polynomial.
   if numberp p then
      p
   else if kpoly_monomialp p then
      kpoly_times for each j in kpoly_atfl p collect tplp_subat(al,j)
   else
      kpoly_plus for each j in kpoly_monlist p collect kpoly_subst(al,j);

procedure kpoly_norm(p);
   % Normalise. [p] is a polynomial. Returns a polynomial which is in
   % a normalized form.
   if eqcar(p,'times) then
      if null cdr p then
         1
      else if null cddr p then
         cadr p
      else
         p
   else if eqcar(p,'plus) then
      if null cdr p then
         0
      else if null cddr p then
         cadr p
      else
         p
   else
      p;

procedure kpoly_mondivp(m1,m2);
   % Monomial divide predicate. [m1] and [m2] are monomials.
   % Returns non-nil if [m2] divides [m1].
   eqn(m1,0) or eqn(m2,1) or m1 = m2 or
      (not eqn(m2,0) and not eqn(m1,1) and
      lto_sublistp(kpoly_atfl m1,kpoly_atfl m2));

procedure kpoly_plist(m);
   % Predicate list. [m] is a monomial. Returns the list of
   % predicate symbols in [m].
   if not numberp m then for each j in kpoly_atfl m collect tplp_op j;

procedure kpoly_maxmonlist(p);
   % List of maximal monomials. [p] is a polynomial. Returns the list
   % of maximal monomials in [p].
   begin scalar ml,maxml,curord,insertp;
      if kpoly_monomialp p then return {p};
      ml := kpoly_monlist p;
      maxml := {car ml};
      for each x in cdr ml do <<
         insertp := t;
         for each y in maxml do <<
            curord := tplp_torderp(x,y);
            if curord and not(curord eq 'eq) then
               maxml := delete(y,maxml)
            else if null curord then
               insertp := nil
         >>;
         if insertp then maxml := x . maxml
      >>;
      return maxml
   end;

endmodule; %kpoly

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/tplp/tplpkapur.tst0000644000175000017500000000570011526203062025517 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: tplpkapur.tst 469 2009-11-28 13:58:18Z arthurcnorman $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

load redlog$

% sokrates (true)
rlset(tplp,{{sokrates,0}},{{human,1},{mortal,1}})$
sok := (all(x,human(x) impl mortal(x)) and human(sokrates)) impl mortal(sokrates)$
rlkapur sok;

% 3.1 (true)
rlset(tplp,{{fi,1}},{{m,3},{p,1}})$
ex31 := (ex(y,all(x,(m(y,x,x) and m(x,y,x) and m(x,fi(x),y) and m(fi(x),x,y))))
   and (all({x,y,z}, ((p(x) and p(y) and m(x,fi(y),z)) impl p(z))))) impl
   all(z,p(z) impl p(fi(z)))$
rlkapur ex31;

% 4.2 (true)
rlset(tplp,{},{{a,1},{b,1}})$
ex42 := all(x,a(x) equiv b(x)) impl (all(x,a(x)) equiv all(x,b(x)))$
rlkapur ex42;

% 4.3 (satisfiable)
rlset(tplp,{},{{p,0},{q,1}})$
ex43 := ex(x,p() impl q(x)) impl (p() impl all(x,q(x)))$
rlkapur ex43;

% 4.4 (true)
rlset(tplp,{},{{p,0},{q,1}})$
ex44 := ex(x,p() impl q(x)) impl (p() impl ex(x,q(x)))$
rlkapur ex44;

% 4.5 -> infinit example
rlset(tplp,{},{{p,2}})$
ex45 := not(all(x,not(p(x,x))) and all({x,y,z},(p(x,y) and p(y,z)) impl p(x,z))
   and all(x,ex(y,p(x,y))))$
%rlkapur ex45;

% 4.6 -> satisfiable (finit GB not containing 1)
rlset(tplp,{{f,1}},{{p,1}})$
ex46 := (p(f(x)) or p(x)) and (not(p(f(y))) or not(p(y)))$
rlkapur not(ex46);

% 4.7 (true) -> takes very long without optimization
rlset(tplp,{},{{p,1},{q,1}})$
ex47 :=
(ex(x,all(y,p(x) equiv p(y))) equiv ex(x,q(x)) equiv all(y,p(y)))
 equiv
(ex(x,all(y,q(x) equiv q(y))) equiv ex(x,p(x)) equiv all(y,q(y)))$
rlkapur ex47;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/0000755000175000017500000000000011722677357023073 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalp.rlg0000644000175000017500000105043711527635055024672 0ustar  giovannigiovanniFri Feb 18 21:28:22 2011 run on win32
load_package redlog;


rlset ibalp;


*** turned off switch lower 

{}


% Formula ii8c1.cnf of the Dimacs II benchmark set
% http://www.cs.ubc.ca/~hoos/SATLIB/benchm.html
ii8c1 :=
(var1 = 1 or var2 = 1) and (var3 = 1 or var4 = 1) and (var5 = 1 or var6 = 1) and
 (var7 = 1 or var8 = 1) and (var9 = 1 or var10 = 1) and (var11 = 1 or var12 = 1)
 and (var13 = 1 or var14 = 1) and (var15 = 1 or var16 = 1) and (var17 = 1 or
var18 = 1) and (var19 = 1 or var20 = 1) and (var21 = 1 or var22 = 1) and (var23
= 1 or var24 = 1) and (var25 = 1 or var26 = 1) and (var27 = 1 or var28 = 1) and
(var29 = 1 or var30 = 1) and (var31 = 1 or var32 = 1) and (var33 = 1 or var34 =
1) and (var35 = 1 or var36 = 1) and (var37 = 1 or var38 = 1) and (var39 = 1 or
var40 = 1) and (var41 = 1 or var42 = 1) and (var43 = 1 or var44 = 1) and (var45
= 1 or var46 = 1) and (var47 = 1 or var48 = 1) and (var49 = 1 or var50 = 1) and
(var51 = 1 or var52 = 1) and (var53 = 1 or var54 = 1) and (var55 = 1 or var56 =
1) and (var57 = 1 or var58 = 1) and (var59 = 1 or var60 = 1) and (var61 = 1 or
var62 = 1) and (var63 = 1 or var64 = 1) and (var65 = 1 or var66 = 1) and (var67
= 1 or var68 = 1) and (var69 = 1 or var70 = 1) and (var71 = 1 or var72 = 1) and
(var73 = 1 or var74 = 1) and (var75 = 1 or var76 = 1) and (var77 = 1 or var78 =
1) and (var79 = 1 or var80 = 1) and (var81 = 1 or var82 = 1) and (var83 = 1 or
var84 = 1) and (var85 = 1 or var86 = 1) and (var87 = 1 or var88 = 1) and (var89
= 1 or var90 = 1) and (var91 = 1 or var92 = 1) and (var93 = 1 or var94 = 1) and
(var95 = 1 or var96 = 1) and (var97 = 1 or var98 = 1) and (var99 = 1 or var100 =
 1) and (var101 = 1 or var102 = 1) and (var103 = 1 or var104 = 1) and (var105 =
1 or var106 = 1) and (var107 = 1 or var108 = 1) and (var109 = 1 or var110 = 1)
and (var111 = 1 or var112 = 1) and (var113 = 1 or var114 = 1) and (var115 = 1 or
 var116 = 1) and (var117 = 1 or var118 = 1) and (var119 = 1 or var120 = 1) and (
var121 = 1 or var122 = 1) and (var123 = 1 or var124 = 1) and (var125 = 1 or
var126 = 1) and (var127 = 1 or var128 = 1) and (var129 = 1 or var130 = 1) and (
var131 = 1 or var132 = 1) and (var133 = 1 or var134 = 1) and (var135 = 1 or
var136 = 1) and (var137 = 1 or var138 = 1) and (var139 = 1 or var140 = 1) and (
var141 = 1 or var142 = 1) and (var143 = 1 or var144 = 1) and (var145 = 1 or
var146 = 1) and (var147 = 1 or var148 = 1) and (var149 = 1 or var150 = 1) and (
var151 = 1 or var152 = 1) and (var153 = 1 or var154 = 1) and (var155 = 1 or
var156 = 1) and (var157 = 1 or var158 = 1) and (var159 = 1 or var160 = 1) and (
not(var1 = 1) or not(var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1
) or not(var12 = 1) or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or
not(var20 = 1) or not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(
var28 = 1) or not(var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36
 = 1) or not(var37 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or
 not(var45 = 1) or not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(
var53 = 1) or not(var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 =
1) or not(var64 = 1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or
 not(var72 = 1) or not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(
var80 = 1)) and (not(var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88
 = 1) or not(var89 = 1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1))
and (not(var97 = 1) or not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or
not(var105 = 1) or not(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (
not(var113 = 1) or not(var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(
var121 = 1) or not(var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(
var129 = 1) or not(var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(
var137 = 1) or not(var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(
var145 = 1) or not(var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(
var153 = 1) or not(var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(
var2 = 1) or not(var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or
 not(var12 = 1) or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(
var19 = 1) or not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 =
1) or not(var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or
 not(var38 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(
var45 = 1) or not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54
 = 1) or not(var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or
 not(var64 = 1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(
var71 = 1) or not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 =
1)) and (not(var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or
 not(var89 = 1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(
var98 = 1) or not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105
 = 1) or not(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114
= 1) or not(var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1)
 or not(var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1)
or not(var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or
not(var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or
not(var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var103 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (var1 = 1 or not(var161 =
 1)) and (var4 = 1 or not(var161 = 1)) and (var6 = 1 or not(var161 = 1)) and (
var8 = 1 or not(var161 = 1)) and (var10 = 1 or not(var161 = 1)) and (var12 = 1
or not(var161 = 1)) and (var13 = 1 or not(var161 = 1)) and (var16 = 1 or not(
var161 = 1)) and (var17 = 1 or not(var162 = 1)) and (var20 = 1 or not(var162 = 1
)) and (var22 = 1 or not(var162 = 1)) and (var24 = 1 or not(var162 = 1)) and (
var26 = 1 or not(var162 = 1)) and (var28 = 1 or not(var162 = 1)) and (var29 = 1
or not(var162 = 1)) and (var32 = 1 or not(var162 = 1)) and (var33 = 1 or not(
var163 = 1)) and (var36 = 1 or not(var163 = 1)) and (var38 = 1 or not(var163 = 1
)) and (var40 = 1 or not(var163 = 1)) and (var42 = 1 or not(var163 = 1)) and (
var44 = 1 or not(var163 = 1)) and (var45 = 1 or not(var163 = 1)) and (var48 = 1
or not(var163 = 1)) and (var49 = 1 or not(var164 = 1)) and (var52 = 1 or not(
var164 = 1)) and (var54 = 1 or not(var164 = 1)) and (var56 = 1 or not(var164 = 1
)) and (var58 = 1 or not(var164 = 1)) and (var60 = 1 or not(var164 = 1)) and (
var61 = 1 or not(var164 = 1)) and (var64 = 1 or not(var164 = 1)) and (var65 = 1
or not(var165 = 1)) and (var68 = 1 or not(var165 = 1)) and (var70 = 1 or not(
var165 = 1)) and (var72 = 1 or not(var165 = 1)) and (var74 = 1 or not(var165 = 1
)) and (var76 = 1 or not(var165 = 1)) and (var77 = 1 or not(var165 = 1)) and (
var80 = 1 or not(var165 = 1)) and (var81 = 1 or not(var166 = 1)) and (var84 = 1
or not(var166 = 1)) and (var86 = 1 or not(var166 = 1)) and (var88 = 1 or not(
var166 = 1)) and (var90 = 1 or not(var166 = 1)) and (var92 = 1 or not(var166 = 1
)) and (var93 = 1 or not(var166 = 1)) and (var96 = 1 or not(var166 = 1)) and (
var97 = 1 or not(var167 = 1)) and (var100 = 1 or not(var167 = 1)) and (var102 =
1 or not(var167 = 1)) and (var104 = 1 or not(var167 = 1)) and (var106 = 1 or not
(var167 = 1)) and (var108 = 1 or not(var167 = 1)) and (var109 = 1 or not(var167
= 1)) and (var112 = 1 or not(var167 = 1)) and (var113 = 1 or not(var168 = 1))
and (var116 = 1 or not(var168 = 1)) and (var118 = 1 or not(var168 = 1)) and (
var120 = 1 or not(var168 = 1)) and (var122 = 1 or not(var168 = 1)) and (var124 =
 1 or not(var168 = 1)) and (var125 = 1 or not(var168 = 1)) and (var128 = 1 or
not(var168 = 1)) and (var129 = 1 or not(var169 = 1)) and (var132 = 1 or not(
var169 = 1)) and (var134 = 1 or not(var169 = 1)) and (var136 = 1 or not(var169 =
 1)) and (var138 = 1 or not(var169 = 1)) and (var140 = 1 or not(var169 = 1)) and
 (var141 = 1 or not(var169 = 1)) and (var144 = 1 or not(var169 = 1)) and (var145
 = 1 or not(var170 = 1)) and (var148 = 1 or not(var170 = 1)) and (var150 = 1 or
not(var170 = 1)) and (var152 = 1 or not(var170 = 1)) and (var154 = 1 or not(
var170 = 1)) and (var156 = 1 or not(var170 = 1)) and (var157 = 1 or not(var170 =
 1)) and (var160 = 1 or not(var170 = 1)) and (var1 = 1 or not(var171 = 1)) and (
var4 = 1 or not(var171 = 1)) and (var6 = 1 or not(var171 = 1)) and (var8 = 1 or
not(var171 = 1)) and (var9 = 1 or not(var171 = 1)) and (var12 = 1 or not(var171
= 1)) and (var14 = 1 or not(var171 = 1)) and (var16 = 1 or not(var171 = 1)) and
(var17 = 1 or not(var172 = 1)) and (var20 = 1 or not(var172 = 1)) and (var22 = 1
 or not(var172 = 1)) and (var24 = 1 or not(var172 = 1)) and (var25 = 1 or not(
var172 = 1)) and (var28 = 1 or not(var172 = 1)) and (var30 = 1 or not(var172 = 1
)) and (var32 = 1 or not(var172 = 1)) and (var33 = 1 or not(var173 = 1)) and (
var36 = 1 or not(var173 = 1)) and (var38 = 1 or not(var173 = 1)) and (var40 = 1
or not(var173 = 1)) and (var41 = 1 or not(var173 = 1)) and (var44 = 1 or not(
var173 = 1)) and (var46 = 1 or not(var173 = 1)) and (var48 = 1 or not(var173 = 1
)) and (var49 = 1 or not(var174 = 1)) and (var52 = 1 or not(var174 = 1)) and (
var54 = 1 or not(var174 = 1)) and (var56 = 1 or not(var174 = 1)) and (var57 = 1
or not(var174 = 1)) and (var60 = 1 or not(var174 = 1)) and (var62 = 1 or not(
var174 = 1)) and (var64 = 1 or not(var174 = 1)) and (var65 = 1 or not(var175 = 1
)) and (var68 = 1 or not(var175 = 1)) and (var70 = 1 or not(var175 = 1)) and (
var72 = 1 or not(var175 = 1)) and (var73 = 1 or not(var175 = 1)) and (var76 = 1
or not(var175 = 1)) and (var78 = 1 or not(var175 = 1)) and (var80 = 1 or not(
var175 = 1)) and (var81 = 1 or not(var176 = 1)) and (var84 = 1 or not(var176 = 1
)) and (var86 = 1 or not(var176 = 1)) and (var88 = 1 or not(var176 = 1)) and (
var89 = 1 or not(var176 = 1)) and (var92 = 1 or not(var176 = 1)) and (var94 = 1
or not(var176 = 1)) and (var96 = 1 or not(var176 = 1)) and (var97 = 1 or not(
var177 = 1)) and (var100 = 1 or not(var177 = 1)) and (var102 = 1 or not(var177 =
 1)) and (var104 = 1 or not(var177 = 1)) and (var105 = 1 or not(var177 = 1)) and
 (var108 = 1 or not(var177 = 1)) and (var110 = 1 or not(var177 = 1)) and (var112
 = 1 or not(var177 = 1)) and (var113 = 1 or not(var178 = 1)) and (var116 = 1 or
not(var178 = 1)) and (var118 = 1 or not(var178 = 1)) and (var120 = 1 or not(
var178 = 1)) and (var121 = 1 or not(var178 = 1)) and (var124 = 1 or not(var178 =
 1)) and (var126 = 1 or not(var178 = 1)) and (var128 = 1 or not(var178 = 1)) and
 (var129 = 1 or not(var179 = 1)) and (var132 = 1 or not(var179 = 1)) and (var134
 = 1 or not(var179 = 1)) and (var136 = 1 or not(var179 = 1)) and (var137 = 1 or
not(var179 = 1)) and (var140 = 1 or not(var179 = 1)) and (var142 = 1 or not(
var179 = 1)) and (var144 = 1 or not(var179 = 1)) and (var145 = 1 or not(var180 =
 1)) and (var148 = 1 or not(var180 = 1)) and (var150 = 1 or not(var180 = 1)) and
 (var152 = 1 or not(var180 = 1)) and (var153 = 1 or not(var180 = 1)) and (var156
 = 1 or not(var180 = 1)) and (var158 = 1 or not(var180 = 1)) and (var160 = 1 or
not(var180 = 1)) and (var1 = 1 or not(var181 = 1)) and (var4 = 1 or not(var181 =
 1)) and (var5 = 1 or not(var181 = 1)) and (var7 = 1 or not(var181 = 1)) and (
var10 = 1 or not(var181 = 1)) and (var11 = 1 or not(var181 = 1)) and (var13 = 1
or not(var181 = 1)) and (var16 = 1 or not(var181 = 1)) and (var17 = 1 or not(
var182 = 1)) and (var20 = 1 or not(var182 = 1)) and (var21 = 1 or not(var182 = 1
)) and (var23 = 1 or not(var182 = 1)) and (var26 = 1 or not(var182 = 1)) and (
var27 = 1 or not(var182 = 1)) and (var29 = 1 or not(var182 = 1)) and (var32 = 1
or not(var182 = 1)) and (var33 = 1 or not(var183 = 1)) and (var36 = 1 or not(
var183 = 1)) and (var37 = 1 or not(var183 = 1)) and (var39 = 1 or not(var183 = 1
)) and (var42 = 1 or not(var183 = 1)) and (var43 = 1 or not(var183 = 1)) and (
var45 = 1 or not(var183 = 1)) and (var48 = 1 or not(var183 = 1)) and (var49 = 1
or not(var184 = 1)) and (var52 = 1 or not(var184 = 1)) and (var53 = 1 or not(
var184 = 1)) and (var55 = 1 or not(var184 = 1)) and (var58 = 1 or not(var184 = 1
)) and (var59 = 1 or not(var184 = 1)) and (var61 = 1 or not(var184 = 1)) and (
var64 = 1 or not(var184 = 1)) and (var65 = 1 or not(var185 = 1)) and (var68 = 1
or not(var185 = 1)) and (var69 = 1 or not(var185 = 1)) and (var71 = 1 or not(
var185 = 1)) and (var74 = 1 or not(var185 = 1)) and (var75 = 1 or not(var185 = 1
)) and (var77 = 1 or not(var185 = 1)) and (var80 = 1 or not(var185 = 1)) and (
var81 = 1 or not(var186 = 1)) and (var84 = 1 or not(var186 = 1)) and (var85 = 1
or not(var186 = 1)) and (var87 = 1 or not(var186 = 1)) and (var90 = 1 or not(
var186 = 1)) and (var91 = 1 or not(var186 = 1)) and (var93 = 1 or not(var186 = 1
)) and (var96 = 1 or not(var186 = 1)) and (var97 = 1 or not(var187 = 1)) and (
var100 = 1 or not(var187 = 1)) and (var101 = 1 or not(var187 = 1)) and (var103 =
 1 or not(var187 = 1)) and (var106 = 1 or not(var187 = 1)) and (var107 = 1 or
not(var187 = 1)) and (var109 = 1 or not(var187 = 1)) and (var112 = 1 or not(
var187 = 1)) and (var113 = 1 or not(var188 = 1)) and (var116 = 1 or not(var188 =
 1)) and (var117 = 1 or not(var188 = 1)) and (var119 = 1 or not(var188 = 1)) and
 (var122 = 1 or not(var188 = 1)) and (var123 = 1 or not(var188 = 1)) and (var125
 = 1 or not(var188 = 1)) and (var128 = 1 or not(var188 = 1)) and (var129 = 1 or
not(var189 = 1)) and (var132 = 1 or not(var189 = 1)) and (var133 = 1 or not(
var189 = 1)) and (var135 = 1 or not(var189 = 1)) and (var138 = 1 or not(var189 =
 1)) and (var139 = 1 or not(var189 = 1)) and (var141 = 1 or not(var189 = 1)) and
 (var144 = 1 or not(var189 = 1)) and (var145 = 1 or not(var190 = 1)) and (var148
 = 1 or not(var190 = 1)) and (var149 = 1 or not(var190 = 1)) and (var151 = 1 or
not(var190 = 1)) and (var154 = 1 or not(var190 = 1)) and (var155 = 1 or not(
var190 = 1)) and (var157 = 1 or not(var190 = 1)) and (var160 = 1 or not(var190 =
 1)) and (var2 = 1 or not(var191 = 1)) and (var3 = 1 or not(var191 = 1)) and (
var6 = 1 or not(var191 = 1)) and (var7 = 1 or not(var191 = 1)) and (var10 = 1 or
 not(var191 = 1)) and (var12 = 1 or not(var191 = 1)) and (var14 = 1 or not(
var191 = 1)) and (var15 = 1 or not(var191 = 1)) and (var18 = 1 or not(var192 = 1
)) and (var19 = 1 or not(var192 = 1)) and (var22 = 1 or not(var192 = 1)) and (
var23 = 1 or not(var192 = 1)) and (var26 = 1 or not(var192 = 1)) and (var28 = 1
or not(var192 = 1)) and (var30 = 1 or not(var192 = 1)) and (var31 = 1 or not(
var192 = 1)) and (var34 = 1 or not(var193 = 1)) and (var35 = 1 or not(var193 = 1
)) and (var38 = 1 or not(var193 = 1)) and (var39 = 1 or not(var193 = 1)) and (
var42 = 1 or not(var193 = 1)) and (var44 = 1 or not(var193 = 1)) and (var46 = 1
or not(var193 = 1)) and (var47 = 1 or not(var193 = 1)) and (var50 = 1 or not(
var194 = 1)) and (var51 = 1 or not(var194 = 1)) and (var54 = 1 or not(var194 = 1
)) and (var55 = 1 or not(var194 = 1)) and (var58 = 1 or not(var194 = 1)) and (
var60 = 1 or not(var194 = 1)) and (var62 = 1 or not(var194 = 1)) and (var63 = 1
or not(var194 = 1)) and (var66 = 1 or not(var195 = 1)) and (var67 = 1 or not(
var195 = 1)) and (var70 = 1 or not(var195 = 1)) and (var71 = 1 or not(var195 = 1
)) and (var74 = 1 or not(var195 = 1)) and (var76 = 1 or not(var195 = 1)) and (
var78 = 1 or not(var195 = 1)) and (var79 = 1 or not(var195 = 1)) and (var82 = 1
or not(var196 = 1)) and (var83 = 1 or not(var196 = 1)) and (var86 = 1 or not(
var196 = 1)) and (var87 = 1 or not(var196 = 1)) and (var90 = 1 or not(var196 = 1
)) and (var92 = 1 or not(var196 = 1)) and (var94 = 1 or not(var196 = 1)) and (
var95 = 1 or not(var196 = 1)) and (var98 = 1 or not(var197 = 1)) and (var99 = 1
or not(var197 = 1)) and (var102 = 1 or not(var197 = 1)) and (var103 = 1 or not(
var197 = 1)) and (var106 = 1 or not(var197 = 1)) and (var108 = 1 or not(var197 =
 1)) and (var110 = 1 or not(var197 = 1)) and (var111 = 1 or not(var197 = 1)) and
 (var114 = 1 or not(var198 = 1)) and (var115 = 1 or not(var198 = 1)) and (var118
 = 1 or not(var198 = 1)) and (var119 = 1 or not(var198 = 1)) and (var122 = 1 or
not(var198 = 1)) and (var124 = 1 or not(var198 = 1)) and (var126 = 1 or not(
var198 = 1)) and (var127 = 1 or not(var198 = 1)) and (var130 = 1 or not(var199 =
 1)) and (var131 = 1 or not(var199 = 1)) and (var134 = 1 or not(var199 = 1)) and
 (var135 = 1 or not(var199 = 1)) and (var138 = 1 or not(var199 = 1)) and (var140
 = 1 or not(var199 = 1)) and (var142 = 1 or not(var199 = 1)) and (var143 = 1 or
not(var199 = 1)) and (var146 = 1 or not(var200 = 1)) and (var147 = 1 or not(
var200 = 1)) and (var150 = 1 or not(var200 = 1)) and (var151 = 1 or not(var200 =
 1)) and (var154 = 1 or not(var200 = 1)) and (var156 = 1 or not(var200 = 1)) and
 (var158 = 1 or not(var200 = 1)) and (var159 = 1 or not(var200 = 1)) and (var1 =
 1 or not(var201 = 1)) and (var3 = 1 or not(var201 = 1)) and (var5 = 1 or not(
var201 = 1)) and (var8 = 1 or not(var201 = 1)) and (var9 = 1 or not(var201 = 1))
 and (var12 = 1 or not(var201 = 1)) and (var14 = 1 or not(var201 = 1)) and (
var15 = 1 or not(var201 = 1)) and (var17 = 1 or not(var202 = 1)) and (var19 = 1
or not(var202 = 1)) and (var21 = 1 or not(var202 = 1)) and (var24 = 1 or not(
var202 = 1)) and (var25 = 1 or not(var202 = 1)) and (var28 = 1 or not(var202 = 1
)) and (var30 = 1 or not(var202 = 1)) and (var31 = 1 or not(var202 = 1)) and (
var33 = 1 or not(var203 = 1)) and (var35 = 1 or not(var203 = 1)) and (var37 = 1
or not(var203 = 1)) and (var40 = 1 or not(var203 = 1)) and (var41 = 1 or not(
var203 = 1)) and (var44 = 1 or not(var203 = 1)) and (var46 = 1 or not(var203 = 1
)) and (var47 = 1 or not(var203 = 1)) and (var49 = 1 or not(var204 = 1)) and (
var51 = 1 or not(var204 = 1)) and (var53 = 1 or not(var204 = 1)) and (var56 = 1
or not(var204 = 1)) and (var57 = 1 or not(var204 = 1)) and (var60 = 1 or not(
var204 = 1)) and (var62 = 1 or not(var204 = 1)) and (var63 = 1 or not(var204 = 1
)) and (var65 = 1 or not(var205 = 1)) and (var67 = 1 or not(var205 = 1)) and (
var69 = 1 or not(var205 = 1)) and (var72 = 1 or not(var205 = 1)) and (var73 = 1
or not(var205 = 1)) and (var76 = 1 or not(var205 = 1)) and (var78 = 1 or not(
var205 = 1)) and (var79 = 1 or not(var205 = 1)) and (var81 = 1 or not(var206 = 1
)) and (var83 = 1 or not(var206 = 1)) and (var85 = 1 or not(var206 = 1)) and (
var88 = 1 or not(var206 = 1)) and (var89 = 1 or not(var206 = 1)) and (var92 = 1
or not(var206 = 1)) and (var94 = 1 or not(var206 = 1)) and (var95 = 1 or not(
var206 = 1)) and (var97 = 1 or not(var207 = 1)) and (var99 = 1 or not(var207 = 1
)) and (var101 = 1 or not(var207 = 1)) and (var104 = 1 or not(var207 = 1)) and (
var105 = 1 or not(var207 = 1)) and (var108 = 1 or not(var207 = 1)) and (var110 =
 1 or not(var207 = 1)) and (var111 = 1 or not(var207 = 1)) and (var113 = 1 or
not(var208 = 1)) and (var115 = 1 or not(var208 = 1)) and (var117 = 1 or not(
var208 = 1)) and (var120 = 1 or not(var208 = 1)) and (var121 = 1 or not(var208 =
 1)) and (var124 = 1 or not(var208 = 1)) and (var126 = 1 or not(var208 = 1)) and
 (var127 = 1 or not(var208 = 1)) and (var129 = 1 or not(var209 = 1)) and (var131
 = 1 or not(var209 = 1)) and (var133 = 1 or not(var209 = 1)) and (var136 = 1 or
not(var209 = 1)) and (var137 = 1 or not(var209 = 1)) and (var140 = 1 or not(
var209 = 1)) and (var142 = 1 or not(var209 = 1)) and (var143 = 1 or not(var209 =
 1)) and (var145 = 1 or not(var210 = 1)) and (var147 = 1 or not(var210 = 1)) and
 (var149 = 1 or not(var210 = 1)) and (var152 = 1 or not(var210 = 1)) and (var153
 = 1 or not(var210 = 1)) and (var156 = 1 or not(var210 = 1)) and (var158 = 1 or
not(var210 = 1)) and (var159 = 1 or not(var210 = 1)) and (var1 = 1 or not(var211
 = 1)) and (var3 = 1 or not(var211 = 1)) and (var5 = 1 or not(var211 = 1)) and (
var8 = 1 or not(var211 = 1)) and (var10 = 1 or not(var211 = 1)) and (var11 = 1
or not(var211 = 1)) and (var13 = 1 or not(var211 = 1)) and (var15 = 1 or not(
var211 = 1)) and (var17 = 1 or not(var212 = 1)) and (var19 = 1 or not(var212 = 1
)) and (var21 = 1 or not(var212 = 1)) and (var24 = 1 or not(var212 = 1)) and (
var26 = 1 or not(var212 = 1)) and (var27 = 1 or not(var212 = 1)) and (var29 = 1
or not(var212 = 1)) and (var31 = 1 or not(var212 = 1)) and (var33 = 1 or not(
var213 = 1)) and (var35 = 1 or not(var213 = 1)) and (var37 = 1 or not(var213 = 1
)) and (var40 = 1 or not(var213 = 1)) and (var42 = 1 or not(var213 = 1)) and (
var43 = 1 or not(var213 = 1)) and (var45 = 1 or not(var213 = 1)) and (var47 = 1
or not(var213 = 1)) and (var49 = 1 or not(var214 = 1)) and (var51 = 1 or not(
var214 = 1)) and (var53 = 1 or not(var214 = 1)) and (var56 = 1 or not(var214 = 1
)) and (var58 = 1 or not(var214 = 1)) and (var59 = 1 or not(var214 = 1)) and (
var61 = 1 or not(var214 = 1)) and (var63 = 1 or not(var214 = 1)) and (var65 = 1
or not(var215 = 1)) and (var67 = 1 or not(var215 = 1)) and (var69 = 1 or not(
var215 = 1)) and (var72 = 1 or not(var215 = 1)) and (var74 = 1 or not(var215 = 1
)) and (var75 = 1 or not(var215 = 1)) and (var77 = 1 or not(var215 = 1)) and (
var79 = 1 or not(var215 = 1)) and (var81 = 1 or not(var216 = 1)) and (var83 = 1
or not(var216 = 1)) and (var85 = 1 or not(var216 = 1)) and (var88 = 1 or not(
var216 = 1)) and (var90 = 1 or not(var216 = 1)) and (var91 = 1 or not(var216 = 1
)) and (var93 = 1 or not(var216 = 1)) and (var95 = 1 or not(var216 = 1)) and (
var97 = 1 or not(var217 = 1)) and (var99 = 1 or not(var217 = 1)) and (var101 = 1
 or not(var217 = 1)) and (var104 = 1 or not(var217 = 1)) and (var106 = 1 or not(
var217 = 1)) and (var107 = 1 or not(var217 = 1)) and (var109 = 1 or not(var217 =
 1)) and (var111 = 1 or not(var217 = 1)) and (var113 = 1 or not(var218 = 1)) and
 (var115 = 1 or not(var218 = 1)) and (var117 = 1 or not(var218 = 1)) and (var120
 = 1 or not(var218 = 1)) and (var122 = 1 or not(var218 = 1)) and (var123 = 1 or
not(var218 = 1)) and (var125 = 1 or not(var218 = 1)) and (var127 = 1 or not(
var218 = 1)) and (var129 = 1 or not(var219 = 1)) and (var131 = 1 or not(var219 =
 1)) and (var133 = 1 or not(var219 = 1)) and (var136 = 1 or not(var219 = 1)) and
 (var138 = 1 or not(var219 = 1)) and (var139 = 1 or not(var219 = 1)) and (var141
 = 1 or not(var219 = 1)) and (var143 = 1 or not(var219 = 1)) and (var145 = 1 or
not(var220 = 1)) and (var147 = 1 or not(var220 = 1)) and (var149 = 1 or not(
var220 = 1)) and (var152 = 1 or not(var220 = 1)) and (var154 = 1 or not(var220 =
 1)) and (var155 = 1 or not(var220 = 1)) and (var157 = 1 or not(var220 = 1)) and
 (var159 = 1 or not(var220 = 1)) and (var1 = 1 or not(var221 = 1)) and (var4 = 1
 or not(var221 = 1)) and (var5 = 1 or not(var221 = 1)) and (var7 = 1 or not(
var221 = 1)) and (var10 = 1 or not(var221 = 1)) and (var12 = 1 or not(var221 = 1
)) and (var14 = 1 or not(var221 = 1)) and (var16 = 1 or not(var221 = 1)) and (
var17 = 1 or not(var222 = 1)) and (var20 = 1 or not(var222 = 1)) and (var21 = 1
or not(var222 = 1)) and (var23 = 1 or not(var222 = 1)) and (var26 = 1 or not(
var222 = 1)) and (var28 = 1 or not(var222 = 1)) and (var30 = 1 or not(var222 = 1
)) and (var32 = 1 or not(var222 = 1)) and (var33 = 1 or not(var223 = 1)) and (
var36 = 1 or not(var223 = 1)) and (var37 = 1 or not(var223 = 1)) and (var39 = 1
or not(var223 = 1)) and (var42 = 1 or not(var223 = 1)) and (var44 = 1 or not(
var223 = 1)) and (var46 = 1 or not(var223 = 1)) and (var48 = 1 or not(var223 = 1
)) and (var49 = 1 or not(var224 = 1)) and (var52 = 1 or not(var224 = 1)) and (
var53 = 1 or not(var224 = 1)) and (var55 = 1 or not(var224 = 1)) and (var58 = 1
or not(var224 = 1)) and (var60 = 1 or not(var224 = 1)) and (var62 = 1 or not(
var224 = 1)) and (var64 = 1 or not(var224 = 1)) and (var65 = 1 or not(var225 = 1
)) and (var68 = 1 or not(var225 = 1)) and (var69 = 1 or not(var225 = 1)) and (
var71 = 1 or not(var225 = 1)) and (var74 = 1 or not(var225 = 1)) and (var76 = 1
or not(var225 = 1)) and (var78 = 1 or not(var225 = 1)) and (var80 = 1 or not(
var225 = 1)) and (var81 = 1 or not(var226 = 1)) and (var84 = 1 or not(var226 = 1
)) and (var85 = 1 or not(var226 = 1)) and (var87 = 1 or not(var226 = 1)) and (
var90 = 1 or not(var226 = 1)) and (var92 = 1 or not(var226 = 1)) and (var94 = 1
or not(var226 = 1)) and (var96 = 1 or not(var226 = 1)) and (var97 = 1 or not(
var227 = 1)) and (var100 = 1 or not(var227 = 1)) and (var101 = 1 or not(var227 =
 1)) and (var103 = 1 or not(var227 = 1)) and (var106 = 1 or not(var227 = 1)) and
 (var108 = 1 or not(var227 = 1)) and (var110 = 1 or not(var227 = 1)) and (var112
 = 1 or not(var227 = 1)) and (var113 = 1 or not(var228 = 1)) and (var116 = 1 or
not(var228 = 1)) and (var117 = 1 or not(var228 = 1)) and (var119 = 1 or not(
var228 = 1)) and (var122 = 1 or not(var228 = 1)) and (var124 = 1 or not(var228 =
 1)) and (var126 = 1 or not(var228 = 1)) and (var128 = 1 or not(var228 = 1)) and
 (var129 = 1 or not(var229 = 1)) and (var132 = 1 or not(var229 = 1)) and (var133
 = 1 or not(var229 = 1)) and (var135 = 1 or not(var229 = 1)) and (var138 = 1 or
not(var229 = 1)) and (var140 = 1 or not(var229 = 1)) and (var142 = 1 or not(
var229 = 1)) and (var144 = 1 or not(var229 = 1)) and (var145 = 1 or not(var230 =
 1)) and (var148 = 1 or not(var230 = 1)) and (var149 = 1 or not(var230 = 1)) and
 (var151 = 1 or not(var230 = 1)) and (var154 = 1 or not(var230 = 1)) and (var156
 = 1 or not(var230 = 1)) and (var158 = 1 or not(var230 = 1)) and (var160 = 1 or
not(var230 = 1)) and (var2 = 1 or not(var231 = 1)) and (var4 = 1 or not(var231 =
 1)) and (var6 = 1 or not(var231 = 1)) and (var7 = 1 or not(var231 = 1)) and (
var10 = 1 or not(var231 = 1)) and (var11 = 1 or not(var231 = 1)) and (var13 = 1
or not(var231 = 1)) and (var16 = 1 or not(var231 = 1)) and (var18 = 1 or not(
var232 = 1)) and (var20 = 1 or not(var232 = 1)) and (var22 = 1 or not(var232 = 1
)) and (var23 = 1 or not(var232 = 1)) and (var26 = 1 or not(var232 = 1)) and (
var27 = 1 or not(var232 = 1)) and (var29 = 1 or not(var232 = 1)) and (var32 = 1
or not(var232 = 1)) and (var34 = 1 or not(var233 = 1)) and (var36 = 1 or not(
var233 = 1)) and (var38 = 1 or not(var233 = 1)) and (var39 = 1 or not(var233 = 1
)) and (var42 = 1 or not(var233 = 1)) and (var43 = 1 or not(var233 = 1)) and (
var45 = 1 or not(var233 = 1)) and (var48 = 1 or not(var233 = 1)) and (var50 = 1
or not(var234 = 1)) and (var52 = 1 or not(var234 = 1)) and (var54 = 1 or not(
var234 = 1)) and (var55 = 1 or not(var234 = 1)) and (var58 = 1 or not(var234 = 1
)) and (var59 = 1 or not(var234 = 1)) and (var61 = 1 or not(var234 = 1)) and (
var64 = 1 or not(var234 = 1)) and (var66 = 1 or not(var235 = 1)) and (var68 = 1
or not(var235 = 1)) and (var70 = 1 or not(var235 = 1)) and (var71 = 1 or not(
var235 = 1)) and (var74 = 1 or not(var235 = 1)) and (var75 = 1 or not(var235 = 1
)) and (var77 = 1 or not(var235 = 1)) and (var80 = 1 or not(var235 = 1)) and (
var82 = 1 or not(var236 = 1)) and (var84 = 1 or not(var236 = 1)) and (var86 = 1
or not(var236 = 1)) and (var87 = 1 or not(var236 = 1)) and (var90 = 1 or not(
var236 = 1)) and (var91 = 1 or not(var236 = 1)) and (var93 = 1 or not(var236 = 1
)) and (var96 = 1 or not(var236 = 1)) and (var98 = 1 or not(var237 = 1)) and (
var100 = 1 or not(var237 = 1)) and (var102 = 1 or not(var237 = 1)) and (var103 =
 1 or not(var237 = 1)) and (var106 = 1 or not(var237 = 1)) and (var107 = 1 or
not(var237 = 1)) and (var109 = 1 or not(var237 = 1)) and (var112 = 1 or not(
var237 = 1)) and (var114 = 1 or not(var238 = 1)) and (var116 = 1 or not(var238 =
 1)) and (var118 = 1 or not(var238 = 1)) and (var119 = 1 or not(var238 = 1)) and
 (var122 = 1 or not(var238 = 1)) and (var123 = 1 or not(var238 = 1)) and (var125
 = 1 or not(var238 = 1)) and (var128 = 1 or not(var238 = 1)) and (var130 = 1 or
not(var239 = 1)) and (var132 = 1 or not(var239 = 1)) and (var134 = 1 or not(
var239 = 1)) and (var135 = 1 or not(var239 = 1)) and (var138 = 1 or not(var239 =
 1)) and (var139 = 1 or not(var239 = 1)) and (var141 = 1 or not(var239 = 1)) and
 (var144 = 1 or not(var239 = 1)) and (var146 = 1 or not(var240 = 1)) and (var148
 = 1 or not(var240 = 1)) and (var150 = 1 or not(var240 = 1)) and (var151 = 1 or
not(var240 = 1)) and (var154 = 1 or not(var240 = 1)) and (var155 = 1 or not(
var240 = 1)) and (var157 = 1 or not(var240 = 1)) and (var160 = 1 or not(var240 =
 1)) and (var1 = 1 or not(var241 = 1)) and (var4 = 1 or not(var241 = 1)) and (
var5 = 1 or not(var241 = 1)) and (var8 = 1 or not(var241 = 1)) and (var10 = 1 or
 not(var241 = 1)) and (var12 = 1 or not(var241 = 1)) and (var13 = 1 or not(
var241 = 1)) and (var15 = 1 or not(var241 = 1)) and (var17 = 1 or not(var242 = 1
)) and (var20 = 1 or not(var242 = 1)) and (var21 = 1 or not(var242 = 1)) and (
var24 = 1 or not(var242 = 1)) and (var26 = 1 or not(var242 = 1)) and (var28 = 1
or not(var242 = 1)) and (var29 = 1 or not(var242 = 1)) and (var31 = 1 or not(
var242 = 1)) and (var33 = 1 or not(var243 = 1)) and (var36 = 1 or not(var243 = 1
)) and (var37 = 1 or not(var243 = 1)) and (var40 = 1 or not(var243 = 1)) and (
var42 = 1 or not(var243 = 1)) and (var44 = 1 or not(var243 = 1)) and (var45 = 1
or not(var243 = 1)) and (var47 = 1 or not(var243 = 1)) and (var49 = 1 or not(
var244 = 1)) and (var52 = 1 or not(var244 = 1)) and (var53 = 1 or not(var244 = 1
)) and (var56 = 1 or not(var244 = 1)) and (var58 = 1 or not(var244 = 1)) and (
var60 = 1 or not(var244 = 1)) and (var61 = 1 or not(var244 = 1)) and (var63 = 1
or not(var244 = 1)) and (var65 = 1 or not(var245 = 1)) and (var68 = 1 or not(
var245 = 1)) and (var69 = 1 or not(var245 = 1)) and (var72 = 1 or not(var245 = 1
)) and (var74 = 1 or not(var245 = 1)) and (var76 = 1 or not(var245 = 1)) and (
var77 = 1 or not(var245 = 1)) and (var79 = 1 or not(var245 = 1)) and (var81 = 1
or not(var246 = 1)) and (var84 = 1 or not(var246 = 1)) and (var85 = 1 or not(
var246 = 1)) and (var88 = 1 or not(var246 = 1)) and (var90 = 1 or not(var246 = 1
)) and (var92 = 1 or not(var246 = 1)) and (var93 = 1 or not(var246 = 1)) and (
var95 = 1 or not(var246 = 1)) and (var97 = 1 or not(var247 = 1)) and (var100 = 1
 or not(var247 = 1)) and (var101 = 1 or not(var247 = 1)) and (var104 = 1 or not(
var247 = 1)) and (var106 = 1 or not(var247 = 1)) and (var108 = 1 or not(var247 =
 1)) and (var109 = 1 or not(var247 = 1)) and (var111 = 1 or not(var247 = 1)) and
 (var113 = 1 or not(var248 = 1)) and (var116 = 1 or not(var248 = 1)) and (var117
 = 1 or not(var248 = 1)) and (var120 = 1 or not(var248 = 1)) and (var122 = 1 or
not(var248 = 1)) and (var124 = 1 or not(var248 = 1)) and (var125 = 1 or not(
var248 = 1)) and (var127 = 1 or not(var248 = 1)) and (var129 = 1 or not(var249 =
 1)) and (var132 = 1 or not(var249 = 1)) and (var133 = 1 or not(var249 = 1)) and
 (var136 = 1 or not(var249 = 1)) and (var138 = 1 or not(var249 = 1)) and (var140
 = 1 or not(var249 = 1)) and (var141 = 1 or not(var249 = 1)) and (var143 = 1 or
not(var249 = 1)) and (var145 = 1 or not(var250 = 1)) and (var148 = 1 or not(
var250 = 1)) and (var149 = 1 or not(var250 = 1)) and (var152 = 1 or not(var250 =
 1)) and (var154 = 1 or not(var250 = 1)) and (var156 = 1 or not(var250 = 1)) and
 (var157 = 1 or not(var250 = 1)) and (var159 = 1 or not(var250 = 1)) and (var1 =
 1 or not(var251 = 1)) and (var3 = 1 or not(var251 = 1)) and (var6 = 1 or not(
var251 = 1)) and (var7 = 1 or not(var251 = 1)) and (var10 = 1 or not(var251 = 1)
) and (var11 = 1 or not(var251 = 1)) and (var14 = 1 or not(var251 = 1)) and (
var16 = 1 or not(var251 = 1)) and (var17 = 1 or not(var252 = 1)) and (var19 = 1
or not(var252 = 1)) and (var22 = 1 or not(var252 = 1)) and (var23 = 1 or not(
var252 = 1)) and (var26 = 1 or not(var252 = 1)) and (var27 = 1 or not(var252 = 1
)) and (var30 = 1 or not(var252 = 1)) and (var32 = 1 or not(var252 = 1)) and (
var33 = 1 or not(var253 = 1)) and (var35 = 1 or not(var253 = 1)) and (var38 = 1
or not(var253 = 1)) and (var39 = 1 or not(var253 = 1)) and (var42 = 1 or not(
var253 = 1)) and (var43 = 1 or not(var253 = 1)) and (var46 = 1 or not(var253 = 1
)) and (var48 = 1 or not(var253 = 1)) and (var49 = 1 or not(var254 = 1)) and (
var51 = 1 or not(var254 = 1)) and (var54 = 1 or not(var254 = 1)) and (var55 = 1
or not(var254 = 1)) and (var58 = 1 or not(var254 = 1)) and (var59 = 1 or not(
var254 = 1)) and (var62 = 1 or not(var254 = 1)) and (var64 = 1 or not(var254 = 1
)) and (var65 = 1 or not(var255 = 1)) and (var67 = 1 or not(var255 = 1)) and (
var70 = 1 or not(var255 = 1)) and (var71 = 1 or not(var255 = 1)) and (var74 = 1
or not(var255 = 1)) and (var75 = 1 or not(var255 = 1)) and (var78 = 1 or not(
var255 = 1)) and (var80 = 1 or not(var255 = 1)) and (var81 = 1 or not(var256 = 1
)) and (var83 = 1 or not(var256 = 1)) and (var86 = 1 or not(var256 = 1)) and (
var87 = 1 or not(var256 = 1)) and (var90 = 1 or not(var256 = 1)) and (var91 = 1
or not(var256 = 1)) and (var94 = 1 or not(var256 = 1)) and (var96 = 1 or not(
var256 = 1)) and (var97 = 1 or not(var257 = 1)) and (var99 = 1 or not(var257 = 1
)) and (var102 = 1 or not(var257 = 1)) and (var103 = 1 or not(var257 = 1)) and (
var106 = 1 or not(var257 = 1)) and (var107 = 1 or not(var257 = 1)) and (var110 =
 1 or not(var257 = 1)) and (var112 = 1 or not(var257 = 1)) and (var113 = 1 or
not(var258 = 1)) and (var115 = 1 or not(var258 = 1)) and (var118 = 1 or not(
var258 = 1)) and (var119 = 1 or not(var258 = 1)) and (var122 = 1 or not(var258 =
 1)) and (var123 = 1 or not(var258 = 1)) and (var126 = 1 or not(var258 = 1)) and
 (var128 = 1 or not(var258 = 1)) and (var129 = 1 or not(var259 = 1)) and (var131
 = 1 or not(var259 = 1)) and (var134 = 1 or not(var259 = 1)) and (var135 = 1 or
not(var259 = 1)) and (var138 = 1 or not(var259 = 1)) and (var139 = 1 or not(
var259 = 1)) and (var142 = 1 or not(var259 = 1)) and (var144 = 1 or not(var259 =
 1)) and (var145 = 1 or not(var260 = 1)) and (var147 = 1 or not(var260 = 1)) and
 (var150 = 1 or not(var260 = 1)) and (var151 = 1 or not(var260 = 1)) and (var154
 = 1 or not(var260 = 1)) and (var155 = 1 or not(var260 = 1)) and (var158 = 1 or
not(var260 = 1)) and (var160 = 1 or not(var260 = 1)) and (var2 = 1 or not(var261
 = 1)) and (var3 = 1 or not(var261 = 1)) and (var5 = 1 or not(var261 = 1)) and (
var8 = 1 or not(var261 = 1)) and (var10 = 1 or not(var261 = 1)) and (var11 = 1
or not(var261 = 1)) and (var13 = 1 or not(var261 = 1)) and (var15 = 1 or not(
var261 = 1)) and (var18 = 1 or not(var262 = 1)) and (var19 = 1 or not(var262 = 1
)) and (var21 = 1 or not(var262 = 1)) and (var24 = 1 or not(var262 = 1)) and (
var26 = 1 or not(var262 = 1)) and (var27 = 1 or not(var262 = 1)) and (var29 = 1
or not(var262 = 1)) and (var31 = 1 or not(var262 = 1)) and (var34 = 1 or not(
var263 = 1)) and (var35 = 1 or not(var263 = 1)) and (var37 = 1 or not(var263 = 1
)) and (var40 = 1 or not(var263 = 1)) and (var42 = 1 or not(var263 = 1)) and (
var43 = 1 or not(var263 = 1)) and (var45 = 1 or not(var263 = 1)) and (var47 = 1
or not(var263 = 1)) and (var50 = 1 or not(var264 = 1)) and (var51 = 1 or not(
var264 = 1)) and (var53 = 1 or not(var264 = 1)) and (var56 = 1 or not(var264 = 1
)) and (var58 = 1 or not(var264 = 1)) and (var59 = 1 or not(var264 = 1)) and (
var61 = 1 or not(var264 = 1)) and (var63 = 1 or not(var264 = 1)) and (var66 = 1
or not(var265 = 1)) and (var67 = 1 or not(var265 = 1)) and (var69 = 1 or not(
var265 = 1)) and (var72 = 1 or not(var265 = 1)) and (var74 = 1 or not(var265 = 1
)) and (var75 = 1 or not(var265 = 1)) and (var77 = 1 or not(var265 = 1)) and (
var79 = 1 or not(var265 = 1)) and (var82 = 1 or not(var266 = 1)) and (var83 = 1
or not(var266 = 1)) and (var85 = 1 or not(var266 = 1)) and (var88 = 1 or not(
var266 = 1)) and (var90 = 1 or not(var266 = 1)) and (var91 = 1 or not(var266 = 1
)) and (var93 = 1 or not(var266 = 1)) and (var95 = 1 or not(var266 = 1)) and (
var98 = 1 or not(var267 = 1)) and (var99 = 1 or not(var267 = 1)) and (var101 = 1
 or not(var267 = 1)) and (var104 = 1 or not(var267 = 1)) and (var106 = 1 or not(
var267 = 1)) and (var107 = 1 or not(var267 = 1)) and (var109 = 1 or not(var267 =
 1)) and (var111 = 1 or not(var267 = 1)) and (var114 = 1 or not(var268 = 1)) and
 (var115 = 1 or not(var268 = 1)) and (var117 = 1 or not(var268 = 1)) and (var120
 = 1 or not(var268 = 1)) and (var122 = 1 or not(var268 = 1)) and (var123 = 1 or
not(var268 = 1)) and (var125 = 1 or not(var268 = 1)) and (var127 = 1 or not(
var268 = 1)) and (var130 = 1 or not(var269 = 1)) and (var131 = 1 or not(var269 =
 1)) and (var133 = 1 or not(var269 = 1)) and (var136 = 1 or not(var269 = 1)) and
 (var138 = 1 or not(var269 = 1)) and (var139 = 1 or not(var269 = 1)) and (var141
 = 1 or not(var269 = 1)) and (var143 = 1 or not(var269 = 1)) and (var146 = 1 or
not(var270 = 1)) and (var147 = 1 or not(var270 = 1)) and (var149 = 1 or not(
var270 = 1)) and (var152 = 1 or not(var270 = 1)) and (var154 = 1 or not(var270 =
 1)) and (var155 = 1 or not(var270 = 1)) and (var157 = 1 or not(var270 = 1)) and
 (var159 = 1 or not(var270 = 1)) and (var1 = 1 or not(var271 = 1)) and (var3 = 1
 or not(var271 = 1)) and (var6 = 1 or not(var271 = 1)) and (var7 = 1 or not(
var271 = 1)) and (var9 = 1 or not(var271 = 1)) and (var12 = 1 or not(var271 = 1)
) and (var14 = 1 or not(var271 = 1)) and (var15 = 1 or not(var271 = 1)) and (
var17 = 1 or not(var272 = 1)) and (var19 = 1 or not(var272 = 1)) and (var22 = 1
or not(var272 = 1)) and (var23 = 1 or not(var272 = 1)) and (var25 = 1 or not(
var272 = 1)) and (var28 = 1 or not(var272 = 1)) and (var30 = 1 or not(var272 = 1
)) and (var31 = 1 or not(var272 = 1)) and (var33 = 1 or not(var273 = 1)) and (
var35 = 1 or not(var273 = 1)) and (var38 = 1 or not(var273 = 1)) and (var39 = 1
or not(var273 = 1)) and (var41 = 1 or not(var273 = 1)) and (var44 = 1 or not(
var273 = 1)) and (var46 = 1 or not(var273 = 1)) and (var47 = 1 or not(var273 = 1
)) and (var49 = 1 or not(var274 = 1)) and (var51 = 1 or not(var274 = 1)) and (
var54 = 1 or not(var274 = 1)) and (var55 = 1 or not(var274 = 1)) and (var57 = 1
or not(var274 = 1)) and (var60 = 1 or not(var274 = 1)) and (var62 = 1 or not(
var274 = 1)) and (var63 = 1 or not(var274 = 1)) and (var65 = 1 or not(var275 = 1
)) and (var67 = 1 or not(var275 = 1)) and (var70 = 1 or not(var275 = 1)) and (
var71 = 1 or not(var275 = 1)) and (var73 = 1 or not(var275 = 1)) and (var76 = 1
or not(var275 = 1)) and (var78 = 1 or not(var275 = 1)) and (var79 = 1 or not(
var275 = 1)) and (var81 = 1 or not(var276 = 1)) and (var83 = 1 or not(var276 = 1
)) and (var86 = 1 or not(var276 = 1)) and (var87 = 1 or not(var276 = 1)) and (
var89 = 1 or not(var276 = 1)) and (var92 = 1 or not(var276 = 1)) and (var94 = 1
or not(var276 = 1)) and (var95 = 1 or not(var276 = 1)) and (var97 = 1 or not(
var277 = 1)) and (var99 = 1 or not(var277 = 1)) and (var102 = 1 or not(var277 =
1)) and (var103 = 1 or not(var277 = 1)) and (var105 = 1 or not(var277 = 1)) and
(var108 = 1 or not(var277 = 1)) and (var110 = 1 or not(var277 = 1)) and (var111
= 1 or not(var277 = 1)) and (var113 = 1 or not(var278 = 1)) and (var115 = 1 or
not(var278 = 1)) and (var118 = 1 or not(var278 = 1)) and (var119 = 1 or not(
var278 = 1)) and (var121 = 1 or not(var278 = 1)) and (var124 = 1 or not(var278 =
 1)) and (var126 = 1 or not(var278 = 1)) and (var127 = 1 or not(var278 = 1)) and
 (var129 = 1 or not(var279 = 1)) and (var131 = 1 or not(var279 = 1)) and (var134
 = 1 or not(var279 = 1)) and (var135 = 1 or not(var279 = 1)) and (var137 = 1 or
not(var279 = 1)) and (var140 = 1 or not(var279 = 1)) and (var142 = 1 or not(
var279 = 1)) and (var143 = 1 or not(var279 = 1)) and (var145 = 1 or not(var280 =
 1)) and (var147 = 1 or not(var280 = 1)) and (var150 = 1 or not(var280 = 1)) and
 (var151 = 1 or not(var280 = 1)) and (var153 = 1 or not(var280 = 1)) and (var156
 = 1 or not(var280 = 1)) and (var158 = 1 or not(var280 = 1)) and (var159 = 1 or
not(var280 = 1)) and (var1 = 1 or not(var281 = 1)) and (var4 = 1 or not(var281 =
 1)) and (var6 = 1 or not(var281 = 1)) and (var7 = 1 or not(var281 = 1)) and (
var10 = 1 or not(var281 = 1)) and (var11 = 1 or not(var281 = 1)) and (var13 = 1
or not(var281 = 1)) and (var16 = 1 or not(var281 = 1)) and (var17 = 1 or not(
var282 = 1)) and (var20 = 1 or not(var282 = 1)) and (var22 = 1 or not(var282 = 1
)) and (var23 = 1 or not(var282 = 1)) and (var26 = 1 or not(var282 = 1)) and (
var27 = 1 or not(var282 = 1)) and (var29 = 1 or not(var282 = 1)) and (var32 = 1
or not(var282 = 1)) and (var33 = 1 or not(var283 = 1)) and (var36 = 1 or not(
var283 = 1)) and (var38 = 1 or not(var283 = 1)) and (var39 = 1 or not(var283 = 1
)) and (var42 = 1 or not(var283 = 1)) and (var43 = 1 or not(var283 = 1)) and (
var45 = 1 or not(var283 = 1)) and (var48 = 1 or not(var283 = 1)) and (var49 = 1
or not(var284 = 1)) and (var52 = 1 or not(var284 = 1)) and (var54 = 1 or not(
var284 = 1)) and (var55 = 1 or not(var284 = 1)) and (var58 = 1 or not(var284 = 1
)) and (var59 = 1 or not(var284 = 1)) and (var61 = 1 or not(var284 = 1)) and (
var64 = 1 or not(var284 = 1)) and (var65 = 1 or not(var285 = 1)) and (var68 = 1
or not(var285 = 1)) and (var70 = 1 or not(var285 = 1)) and (var71 = 1 or not(
var285 = 1)) and (var74 = 1 or not(var285 = 1)) and (var75 = 1 or not(var285 = 1
)) and (var77 = 1 or not(var285 = 1)) and (var80 = 1 or not(var285 = 1)) and (
var81 = 1 or not(var286 = 1)) and (var84 = 1 or not(var286 = 1)) and (var86 = 1
or not(var286 = 1)) and (var87 = 1 or not(var286 = 1)) and (var90 = 1 or not(
var286 = 1)) and (var91 = 1 or not(var286 = 1)) and (var93 = 1 or not(var286 = 1
)) and (var96 = 1 or not(var286 = 1)) and (var97 = 1 or not(var287 = 1)) and (
var100 = 1 or not(var287 = 1)) and (var102 = 1 or not(var287 = 1)) and (var103 =
 1 or not(var287 = 1)) and (var106 = 1 or not(var287 = 1)) and (var107 = 1 or
not(var287 = 1)) and (var109 = 1 or not(var287 = 1)) and (var112 = 1 or not(
var287 = 1)) and (var113 = 1 or not(var288 = 1)) and (var116 = 1 or not(var288 =
 1)) and (var118 = 1 or not(var288 = 1)) and (var119 = 1 or not(var288 = 1)) and
 (var122 = 1 or not(var288 = 1)) and (var123 = 1 or not(var288 = 1)) and (var125
 = 1 or not(var288 = 1)) and (var128 = 1 or not(var288 = 1)) and (var129 = 1 or
not(var289 = 1)) and (var132 = 1 or not(var289 = 1)) and (var134 = 1 or not(
var289 = 1)) and (var135 = 1 or not(var289 = 1)) and (var138 = 1 or not(var289 =
 1)) and (var139 = 1 or not(var289 = 1)) and (var141 = 1 or not(var289 = 1)) and
 (var144 = 1 or not(var289 = 1)) and (var145 = 1 or not(var290 = 1)) and (var148
 = 1 or not(var290 = 1)) and (var150 = 1 or not(var290 = 1)) and (var151 = 1 or
not(var290 = 1)) and (var154 = 1 or not(var290 = 1)) and (var155 = 1 or not(
var290 = 1)) and (var157 = 1 or not(var290 = 1)) and (var160 = 1 or not(var290 =
 1)) and (var1 = 1 or not(var291 = 1)) and (var4 = 1 or not(var291 = 1)) and (
var6 = 1 or not(var291 = 1)) and (var8 = 1 or not(var291 = 1)) and (var10 = 1 or
 not(var291 = 1)) and (var12 = 1 or not(var291 = 1)) and (var13 = 1 or not(
var291 = 1)) and (var16 = 1 or not(var291 = 1)) and (var17 = 1 or not(var292 = 1
)) and (var20 = 1 or not(var292 = 1)) and (var22 = 1 or not(var292 = 1)) and (
var24 = 1 or not(var292 = 1)) and (var26 = 1 or not(var292 = 1)) and (var28 = 1
or not(var292 = 1)) and (var29 = 1 or not(var292 = 1)) and (var32 = 1 or not(
var292 = 1)) and (var33 = 1 or not(var293 = 1)) and (var36 = 1 or not(var293 = 1
)) and (var38 = 1 or not(var293 = 1)) and (var40 = 1 or not(var293 = 1)) and (
var42 = 1 or not(var293 = 1)) and (var44 = 1 or not(var293 = 1)) and (var45 = 1
or not(var293 = 1)) and (var48 = 1 or not(var293 = 1)) and (var49 = 1 or not(
var294 = 1)) and (var52 = 1 or not(var294 = 1)) and (var54 = 1 or not(var294 = 1
)) and (var56 = 1 or not(var294 = 1)) and (var58 = 1 or not(var294 = 1)) and (
var60 = 1 or not(var294 = 1)) and (var61 = 1 or not(var294 = 1)) and (var64 = 1
or not(var294 = 1)) and (var65 = 1 or not(var295 = 1)) and (var68 = 1 or not(
var295 = 1)) and (var70 = 1 or not(var295 = 1)) and (var72 = 1 or not(var295 = 1
)) and (var74 = 1 or not(var295 = 1)) and (var76 = 1 or not(var295 = 1)) and (
var77 = 1 or not(var295 = 1)) and (var80 = 1 or not(var295 = 1)) and (var81 = 1
or not(var296 = 1)) and (var84 = 1 or not(var296 = 1)) and (var86 = 1 or not(
var296 = 1)) and (var88 = 1 or not(var296 = 1)) and (var90 = 1 or not(var296 = 1
)) and (var92 = 1 or not(var296 = 1)) and (var93 = 1 or not(var296 = 1)) and (
var96 = 1 or not(var296 = 1)) and (var97 = 1 or not(var297 = 1)) and (var100 = 1
 or not(var297 = 1)) and (var102 = 1 or not(var297 = 1)) and (var104 = 1 or not(
var297 = 1)) and (var106 = 1 or not(var297 = 1)) and (var108 = 1 or not(var297 =
 1)) and (var109 = 1 or not(var297 = 1)) and (var112 = 1 or not(var297 = 1)) and
 (var113 = 1 or not(var298 = 1)) and (var116 = 1 or not(var298 = 1)) and (var118
 = 1 or not(var298 = 1)) and (var120 = 1 or not(var298 = 1)) and (var122 = 1 or
not(var298 = 1)) and (var124 = 1 or not(var298 = 1)) and (var125 = 1 or not(
var298 = 1)) and (var128 = 1 or not(var298 = 1)) and (var129 = 1 or not(var299 =
 1)) and (var132 = 1 or not(var299 = 1)) and (var134 = 1 or not(var299 = 1)) and
 (var136 = 1 or not(var299 = 1)) and (var138 = 1 or not(var299 = 1)) and (var140
 = 1 or not(var299 = 1)) and (var141 = 1 or not(var299 = 1)) and (var144 = 1 or
not(var299 = 1)) and (var145 = 1 or not(var300 = 1)) and (var148 = 1 or not(
var300 = 1)) and (var150 = 1 or not(var300 = 1)) and (var152 = 1 or not(var300 =
 1)) and (var154 = 1 or not(var300 = 1)) and (var156 = 1 or not(var300 = 1)) and
 (var157 = 1 or not(var300 = 1)) and (var160 = 1 or not(var300 = 1)) and (var1 =
 1 or not(var301 = 1)) and (var3 = 1 or not(var301 = 1)) and (var5 = 1 or not(
var301 = 1)) and (var8 = 1 or not(var301 = 1)) and (var9 = 1 or not(var301 = 1))
 and (var11 = 1 or not(var301 = 1)) and (var14 = 1 or not(var301 = 1)) and (
var16 = 1 or not(var301 = 1)) and (var17 = 1 or not(var302 = 1)) and (var19 = 1
or not(var302 = 1)) and (var21 = 1 or not(var302 = 1)) and (var24 = 1 or not(
var302 = 1)) and (var25 = 1 or not(var302 = 1)) and (var27 = 1 or not(var302 = 1
)) and (var30 = 1 or not(var302 = 1)) and (var32 = 1 or not(var302 = 1)) and (
var33 = 1 or not(var303 = 1)) and (var35 = 1 or not(var303 = 1)) and (var37 = 1
or not(var303 = 1)) and (var40 = 1 or not(var303 = 1)) and (var41 = 1 or not(
var303 = 1)) and (var43 = 1 or not(var303 = 1)) and (var46 = 1 or not(var303 = 1
)) and (var48 = 1 or not(var303 = 1)) and (var49 = 1 or not(var304 = 1)) and (
var51 = 1 or not(var304 = 1)) and (var53 = 1 or not(var304 = 1)) and (var56 = 1
or not(var304 = 1)) and (var57 = 1 or not(var304 = 1)) and (var59 = 1 or not(
var304 = 1)) and (var62 = 1 or not(var304 = 1)) and (var64 = 1 or not(var304 = 1
)) and (var65 = 1 or not(var305 = 1)) and (var67 = 1 or not(var305 = 1)) and (
var69 = 1 or not(var305 = 1)) and (var72 = 1 or not(var305 = 1)) and (var73 = 1
or not(var305 = 1)) and (var75 = 1 or not(var305 = 1)) and (var78 = 1 or not(
var305 = 1)) and (var80 = 1 or not(var305 = 1)) and (var81 = 1 or not(var306 = 1
)) and (var83 = 1 or not(var306 = 1)) and (var85 = 1 or not(var306 = 1)) and (
var88 = 1 or not(var306 = 1)) and (var89 = 1 or not(var306 = 1)) and (var91 = 1
or not(var306 = 1)) and (var94 = 1 or not(var306 = 1)) and (var96 = 1 or not(
var306 = 1)) and (var97 = 1 or not(var307 = 1)) and (var99 = 1 or not(var307 = 1
)) and (var101 = 1 or not(var307 = 1)) and (var104 = 1 or not(var307 = 1)) and (
var105 = 1 or not(var307 = 1)) and (var107 = 1 or not(var307 = 1)) and (var110 =
 1 or not(var307 = 1)) and (var112 = 1 or not(var307 = 1)) and (var113 = 1 or
not(var308 = 1)) and (var115 = 1 or not(var308 = 1)) and (var117 = 1 or not(
var308 = 1)) and (var120 = 1 or not(var308 = 1)) and (var121 = 1 or not(var308 =
 1)) and (var123 = 1 or not(var308 = 1)) and (var126 = 1 or not(var308 = 1)) and
 (var128 = 1 or not(var308 = 1)) and (var129 = 1 or not(var309 = 1)) and (var131
 = 1 or not(var309 = 1)) and (var133 = 1 or not(var309 = 1)) and (var136 = 1 or
not(var309 = 1)) and (var137 = 1 or not(var309 = 1)) and (var139 = 1 or not(
var309 = 1)) and (var142 = 1 or not(var309 = 1)) and (var144 = 1 or not(var309 =
 1)) and (var145 = 1 or not(var310 = 1)) and (var147 = 1 or not(var310 = 1)) and
 (var149 = 1 or not(var310 = 1)) and (var152 = 1 or not(var310 = 1)) and (var153
 = 1 or not(var310 = 1)) and (var155 = 1 or not(var310 = 1)) and (var158 = 1 or
not(var310 = 1)) and (var160 = 1 or not(var310 = 1)) and (var2 = 1 or not(var311
 = 1)) and (var4 = 1 or not(var311 = 1)) and (var5 = 1 or not(var311 = 1)) and (
var8 = 1 or not(var311 = 1)) and (var9 = 1 or not(var311 = 1)) and (var11 = 1 or
 not(var311 = 1)) and (var14 = 1 or not(var311 = 1)) and (var16 = 1 or not(
var311 = 1)) and (var18 = 1 or not(var312 = 1)) and (var20 = 1 or not(var312 = 1
)) and (var21 = 1 or not(var312 = 1)) and (var24 = 1 or not(var312 = 1)) and (
var25 = 1 or not(var312 = 1)) and (var27 = 1 or not(var312 = 1)) and (var30 = 1
or not(var312 = 1)) and (var32 = 1 or not(var312 = 1)) and (var34 = 1 or not(
var313 = 1)) and (var36 = 1 or not(var313 = 1)) and (var37 = 1 or not(var313 = 1
)) and (var40 = 1 or not(var313 = 1)) and (var41 = 1 or not(var313 = 1)) and (
var43 = 1 or not(var313 = 1)) and (var46 = 1 or not(var313 = 1)) and (var48 = 1
or not(var313 = 1)) and (var50 = 1 or not(var314 = 1)) and (var52 = 1 or not(
var314 = 1)) and (var53 = 1 or not(var314 = 1)) and (var56 = 1 or not(var314 = 1
)) and (var57 = 1 or not(var314 = 1)) and (var59 = 1 or not(var314 = 1)) and (
var62 = 1 or not(var314 = 1)) and (var64 = 1 or not(var314 = 1)) and (var66 = 1
or not(var315 = 1)) and (var68 = 1 or not(var315 = 1)) and (var69 = 1 or not(
var315 = 1)) and (var72 = 1 or not(var315 = 1)) and (var73 = 1 or not(var315 = 1
)) and (var75 = 1 or not(var315 = 1)) and (var78 = 1 or not(var315 = 1)) and (
var80 = 1 or not(var315 = 1)) and (var82 = 1 or not(var316 = 1)) and (var84 = 1
or not(var316 = 1)) and (var85 = 1 or not(var316 = 1)) and (var88 = 1 or not(
var316 = 1)) and (var89 = 1 or not(var316 = 1)) and (var91 = 1 or not(var316 = 1
)) and (var94 = 1 or not(var316 = 1)) and (var96 = 1 or not(var316 = 1)) and (
var98 = 1 or not(var317 = 1)) and (var100 = 1 or not(var317 = 1)) and (var101 =
1 or not(var317 = 1)) and (var104 = 1 or not(var317 = 1)) and (var105 = 1 or not
(var317 = 1)) and (var107 = 1 or not(var317 = 1)) and (var110 = 1 or not(var317
= 1)) and (var112 = 1 or not(var317 = 1)) and (var114 = 1 or not(var318 = 1))
and (var116 = 1 or not(var318 = 1)) and (var117 = 1 or not(var318 = 1)) and (
var120 = 1 or not(var318 = 1)) and (var121 = 1 or not(var318 = 1)) and (var123 =
 1 or not(var318 = 1)) and (var126 = 1 or not(var318 = 1)) and (var128 = 1 or
not(var318 = 1)) and (var130 = 1 or not(var319 = 1)) and (var132 = 1 or not(
var319 = 1)) and (var133 = 1 or not(var319 = 1)) and (var136 = 1 or not(var319 =
 1)) and (var137 = 1 or not(var319 = 1)) and (var139 = 1 or not(var319 = 1)) and
 (var142 = 1 or not(var319 = 1)) and (var144 = 1 or not(var319 = 1)) and (var146
 = 1 or not(var320 = 1)) and (var148 = 1 or not(var320 = 1)) and (var149 = 1 or
not(var320 = 1)) and (var152 = 1 or not(var320 = 1)) and (var153 = 1 or not(
var320 = 1)) and (var155 = 1 or not(var320 = 1)) and (var158 = 1 or not(var320 =
 1)) and (var160 = 1 or not(var320 = 1)) and (var1 = 1 or not(var321 = 1)) and (
var4 = 1 or not(var321 = 1)) and (var5 = 1 or not(var321 = 1)) and (var7 = 1 or
not(var321 = 1)) and (var10 = 1 or not(var321 = 1)) and (var11 = 1 or not(var321
 = 1)) and (var14 = 1 or not(var321 = 1)) and (var16 = 1 or not(var321 = 1)) and
 (var17 = 1 or not(var322 = 1)) and (var20 = 1 or not(var322 = 1)) and (var21 =
1 or not(var322 = 1)) and (var23 = 1 or not(var322 = 1)) and (var26 = 1 or not(
var322 = 1)) and (var27 = 1 or not(var322 = 1)) and (var30 = 1 or not(var322 = 1
)) and (var32 = 1 or not(var322 = 1)) and (var33 = 1 or not(var323 = 1)) and (
var36 = 1 or not(var323 = 1)) and (var37 = 1 or not(var323 = 1)) and (var39 = 1
or not(var323 = 1)) and (var42 = 1 or not(var323 = 1)) and (var43 = 1 or not(
var323 = 1)) and (var46 = 1 or not(var323 = 1)) and (var48 = 1 or not(var323 = 1
)) and (var49 = 1 or not(var324 = 1)) and (var52 = 1 or not(var324 = 1)) and (
var53 = 1 or not(var324 = 1)) and (var55 = 1 or not(var324 = 1)) and (var58 = 1
or not(var324 = 1)) and (var59 = 1 or not(var324 = 1)) and (var62 = 1 or not(
var324 = 1)) and (var64 = 1 or not(var324 = 1)) and (var65 = 1 or not(var325 = 1
)) and (var68 = 1 or not(var325 = 1)) and (var69 = 1 or not(var325 = 1)) and (
var71 = 1 or not(var325 = 1)) and (var74 = 1 or not(var325 = 1)) and (var75 = 1
or not(var325 = 1)) and (var78 = 1 or not(var325 = 1)) and (var80 = 1 or not(
var325 = 1)) and (var81 = 1 or not(var326 = 1)) and (var84 = 1 or not(var326 = 1
)) and (var85 = 1 or not(var326 = 1)) and (var87 = 1 or not(var326 = 1)) and (
var90 = 1 or not(var326 = 1)) and (var91 = 1 or not(var326 = 1)) and (var94 = 1
or not(var326 = 1)) and (var96 = 1 or not(var326 = 1)) and (var97 = 1 or not(
var327 = 1)) and (var100 = 1 or not(var327 = 1)) and (var101 = 1 or not(var327 =
 1)) and (var103 = 1 or not(var327 = 1)) and (var106 = 1 or not(var327 = 1)) and
 (var107 = 1 or not(var327 = 1)) and (var110 = 1 or not(var327 = 1)) and (var112
 = 1 or not(var327 = 1)) and (var113 = 1 or not(var328 = 1)) and (var116 = 1 or
not(var328 = 1)) and (var117 = 1 or not(var328 = 1)) and (var119 = 1 or not(
var328 = 1)) and (var122 = 1 or not(var328 = 1)) and (var123 = 1 or not(var328 =
 1)) and (var126 = 1 or not(var328 = 1)) and (var128 = 1 or not(var328 = 1)) and
 (var129 = 1 or not(var329 = 1)) and (var132 = 1 or not(var329 = 1)) and (var133
 = 1 or not(var329 = 1)) and (var135 = 1 or not(var329 = 1)) and (var138 = 1 or
not(var329 = 1)) and (var139 = 1 or not(var329 = 1)) and (var142 = 1 or not(
var329 = 1)) and (var144 = 1 or not(var329 = 1)) and (var145 = 1 or not(var330 =
 1)) and (var148 = 1 or not(var330 = 1)) and (var149 = 1 or not(var330 = 1)) and
 (var151 = 1 or not(var330 = 1)) and (var154 = 1 or not(var330 = 1)) and (var155
 = 1 or not(var330 = 1)) and (var158 = 1 or not(var330 = 1)) and (var160 = 1 or
not(var330 = 1)) and (var2 = 1 or not(var331 = 1)) and (var4 = 1 or not(var331 =
 1)) and (var6 = 1 or not(var331 = 1)) and (var7 = 1 or not(var331 = 1)) and (
var9 = 1 or not(var331 = 1)) and (var11 = 1 or not(var331 = 1)) and (var14 = 1
or not(var331 = 1)) and (var16 = 1 or not(var331 = 1)) and (var18 = 1 or not(
var332 = 1)) and (var20 = 1 or not(var332 = 1)) and (var22 = 1 or not(var332 = 1
)) and (var23 = 1 or not(var332 = 1)) and (var25 = 1 or not(var332 = 1)) and (
var27 = 1 or not(var332 = 1)) and (var30 = 1 or not(var332 = 1)) and (var32 = 1
or not(var332 = 1)) and (var34 = 1 or not(var333 = 1)) and (var36 = 1 or not(
var333 = 1)) and (var38 = 1 or not(var333 = 1)) and (var39 = 1 or not(var333 = 1
)) and (var41 = 1 or not(var333 = 1)) and (var43 = 1 or not(var333 = 1)) and (
var46 = 1 or not(var333 = 1)) and (var48 = 1 or not(var333 = 1)) and (var50 = 1
or not(var334 = 1)) and (var52 = 1 or not(var334 = 1)) and (var54 = 1 or not(
var334 = 1)) and (var55 = 1 or not(var334 = 1)) and (var57 = 1 or not(var334 = 1
)) and (var59 = 1 or not(var334 = 1)) and (var62 = 1 or not(var334 = 1)) and (
var64 = 1 or not(var334 = 1)) and (var66 = 1 or not(var335 = 1)) and (var68 = 1
or not(var335 = 1)) and (var70 = 1 or not(var335 = 1)) and (var71 = 1 or not(
var335 = 1)) and (var73 = 1 or not(var335 = 1)) and (var75 = 1 or not(var335 = 1
)) and (var78 = 1 or not(var335 = 1)) and (var80 = 1 or not(var335 = 1)) and (
var82 = 1 or not(var336 = 1)) and (var84 = 1 or not(var336 = 1)) and (var86 = 1
or not(var336 = 1)) and (var87 = 1 or not(var336 = 1)) and (var89 = 1 or not(
var336 = 1)) and (var91 = 1 or not(var336 = 1)) and (var94 = 1 or not(var336 = 1
)) and (var96 = 1 or not(var336 = 1)) and (var98 = 1 or not(var337 = 1)) and (
var100 = 1 or not(var337 = 1)) and (var102 = 1 or not(var337 = 1)) and (var103 =
 1 or not(var337 = 1)) and (var105 = 1 or not(var337 = 1)) and (var107 = 1 or
not(var337 = 1)) and (var110 = 1 or not(var337 = 1)) and (var112 = 1 or not(
var337 = 1)) and (var114 = 1 or not(var338 = 1)) and (var116 = 1 or not(var338 =
 1)) and (var118 = 1 or not(var338 = 1)) and (var119 = 1 or not(var338 = 1)) and
 (var121 = 1 or not(var338 = 1)) and (var123 = 1 or not(var338 = 1)) and (var126
 = 1 or not(var338 = 1)) and (var128 = 1 or not(var338 = 1)) and (var130 = 1 or
not(var339 = 1)) and (var132 = 1 or not(var339 = 1)) and (var134 = 1 or not(
var339 = 1)) and (var135 = 1 or not(var339 = 1)) and (var137 = 1 or not(var339 =
 1)) and (var139 = 1 or not(var339 = 1)) and (var142 = 1 or not(var339 = 1)) and
 (var144 = 1 or not(var339 = 1)) and (var146 = 1 or not(var340 = 1)) and (var148
 = 1 or not(var340 = 1)) and (var150 = 1 or not(var340 = 1)) and (var151 = 1 or
not(var340 = 1)) and (var153 = 1 or not(var340 = 1)) and (var155 = 1 or not(
var340 = 1)) and (var158 = 1 or not(var340 = 1)) and (var160 = 1 or not(var340 =
 1)) and (var1 = 1 or not(var341 = 1)) and (var3 = 1 or not(var341 = 1)) and (
var5 = 1 or not(var341 = 1)) and (var7 = 1 or not(var341 = 1)) and (var9 = 1 or
not(var341 = 1)) and (var12 = 1 or not(var341 = 1)) and (var14 = 1 or not(var341
 = 1)) and (var16 = 1 or not(var341 = 1)) and (var17 = 1 or not(var342 = 1)) and
 (var19 = 1 or not(var342 = 1)) and (var21 = 1 or not(var342 = 1)) and (var23 =
1 or not(var342 = 1)) and (var25 = 1 or not(var342 = 1)) and (var28 = 1 or not(
var342 = 1)) and (var30 = 1 or not(var342 = 1)) and (var32 = 1 or not(var342 = 1
)) and (var33 = 1 or not(var343 = 1)) and (var35 = 1 or not(var343 = 1)) and (
var37 = 1 or not(var343 = 1)) and (var39 = 1 or not(var343 = 1)) and (var41 = 1
or not(var343 = 1)) and (var44 = 1 or not(var343 = 1)) and (var46 = 1 or not(
var343 = 1)) and (var48 = 1 or not(var343 = 1)) and (var49 = 1 or not(var344 = 1
)) and (var51 = 1 or not(var344 = 1)) and (var53 = 1 or not(var344 = 1)) and (
var55 = 1 or not(var344 = 1)) and (var57 = 1 or not(var344 = 1)) and (var60 = 1
or not(var344 = 1)) and (var62 = 1 or not(var344 = 1)) and (var64 = 1 or not(
var344 = 1)) and (var65 = 1 or not(var345 = 1)) and (var67 = 1 or not(var345 = 1
)) and (var69 = 1 or not(var345 = 1)) and (var71 = 1 or not(var345 = 1)) and (
var73 = 1 or not(var345 = 1)) and (var76 = 1 or not(var345 = 1)) and (var78 = 1
or not(var345 = 1)) and (var80 = 1 or not(var345 = 1)) and (var81 = 1 or not(
var346 = 1)) and (var83 = 1 or not(var346 = 1)) and (var85 = 1 or not(var346 = 1
)) and (var87 = 1 or not(var346 = 1)) and (var89 = 1 or not(var346 = 1)) and (
var92 = 1 or not(var346 = 1)) and (var94 = 1 or not(var346 = 1)) and (var96 = 1
or not(var346 = 1)) and (var97 = 1 or not(var347 = 1)) and (var99 = 1 or not(
var347 = 1)) and (var101 = 1 or not(var347 = 1)) and (var103 = 1 or not(var347 =
 1)) and (var105 = 1 or not(var347 = 1)) and (var108 = 1 or not(var347 = 1)) and
 (var110 = 1 or not(var347 = 1)) and (var112 = 1 or not(var347 = 1)) and (var113
 = 1 or not(var348 = 1)) and (var115 = 1 or not(var348 = 1)) and (var117 = 1 or
not(var348 = 1)) and (var119 = 1 or not(var348 = 1)) and (var121 = 1 or not(
var348 = 1)) and (var124 = 1 or not(var348 = 1)) and (var126 = 1 or not(var348 =
 1)) and (var128 = 1 or not(var348 = 1)) and (var129 = 1 or not(var349 = 1)) and
 (var131 = 1 or not(var349 = 1)) and (var133 = 1 or not(var349 = 1)) and (var135
 = 1 or not(var349 = 1)) and (var137 = 1 or not(var349 = 1)) and (var140 = 1 or
not(var349 = 1)) and (var142 = 1 or not(var349 = 1)) and (var144 = 1 or not(
var349 = 1)) and (var145 = 1 or not(var350 = 1)) and (var147 = 1 or not(var350 =
 1)) and (var149 = 1 or not(var350 = 1)) and (var151 = 1 or not(var350 = 1)) and
 (var153 = 1 or not(var350 = 1)) and (var156 = 1 or not(var350 = 1)) and (var158
 = 1 or not(var350 = 1)) and (var160 = 1 or not(var350 = 1)) and (var2 = 1 or
not(var351 = 1)) and (var3 = 1 or not(var351 = 1)) and (var5 = 1 or not(var351 =
 1)) and (var8 = 1 or not(var351 = 1)) and (var9 = 1 or not(var351 = 1)) and (
var12 = 1 or not(var351 = 1)) and (var14 = 1 or not(var351 = 1)) and (var16 = 1
or not(var351 = 1)) and (var18 = 1 or not(var352 = 1)) and (var19 = 1 or not(
var352 = 1)) and (var21 = 1 or not(var352 = 1)) and (var24 = 1 or not(var352 = 1
)) and (var25 = 1 or not(var352 = 1)) and (var28 = 1 or not(var352 = 1)) and (
var30 = 1 or not(var352 = 1)) and (var32 = 1 or not(var352 = 1)) and (var34 = 1
or not(var353 = 1)) and (var35 = 1 or not(var353 = 1)) and (var37 = 1 or not(
var353 = 1)) and (var40 = 1 or not(var353 = 1)) and (var41 = 1 or not(var353 = 1
)) and (var44 = 1 or not(var353 = 1)) and (var46 = 1 or not(var353 = 1)) and (
var48 = 1 or not(var353 = 1)) and (var50 = 1 or not(var354 = 1)) and (var51 = 1
or not(var354 = 1)) and (var53 = 1 or not(var354 = 1)) and (var56 = 1 or not(
var354 = 1)) and (var57 = 1 or not(var354 = 1)) and (var60 = 1 or not(var354 = 1
)) and (var62 = 1 or not(var354 = 1)) and (var64 = 1 or not(var354 = 1)) and (
var66 = 1 or not(var355 = 1)) and (var67 = 1 or not(var355 = 1)) and (var69 = 1
or not(var355 = 1)) and (var72 = 1 or not(var355 = 1)) and (var73 = 1 or not(
var355 = 1)) and (var76 = 1 or not(var355 = 1)) and (var78 = 1 or not(var355 = 1
)) and (var80 = 1 or not(var355 = 1)) and (var82 = 1 or not(var356 = 1)) and (
var83 = 1 or not(var356 = 1)) and (var85 = 1 or not(var356 = 1)) and (var88 = 1
or not(var356 = 1)) and (var89 = 1 or not(var356 = 1)) and (var92 = 1 or not(
var356 = 1)) and (var94 = 1 or not(var356 = 1)) and (var96 = 1 or not(var356 = 1
)) and (var98 = 1 or not(var357 = 1)) and (var99 = 1 or not(var357 = 1)) and (
var101 = 1 or not(var357 = 1)) and (var104 = 1 or not(var357 = 1)) and (var105 =
 1 or not(var357 = 1)) and (var108 = 1 or not(var357 = 1)) and (var110 = 1 or
not(var357 = 1)) and (var112 = 1 or not(var357 = 1)) and (var114 = 1 or not(
var358 = 1)) and (var115 = 1 or not(var358 = 1)) and (var117 = 1 or not(var358 =
 1)) and (var120 = 1 or not(var358 = 1)) and (var121 = 1 or not(var358 = 1)) and
 (var124 = 1 or not(var358 = 1)) and (var126 = 1 or not(var358 = 1)) and (var128
 = 1 or not(var358 = 1)) and (var130 = 1 or not(var359 = 1)) and (var131 = 1 or
not(var359 = 1)) and (var133 = 1 or not(var359 = 1)) and (var136 = 1 or not(
var359 = 1)) and (var137 = 1 or not(var359 = 1)) and (var140 = 1 or not(var359 =
 1)) and (var142 = 1 or not(var359 = 1)) and (var144 = 1 or not(var359 = 1)) and
 (var146 = 1 or not(var360 = 1)) and (var147 = 1 or not(var360 = 1)) and (var149
 = 1 or not(var360 = 1)) and (var152 = 1 or not(var360 = 1)) and (var153 = 1 or
not(var360 = 1)) and (var156 = 1 or not(var360 = 1)) and (var158 = 1 or not(
var360 = 1)) and (var160 = 1 or not(var360 = 1)) and (var2 = 1 or not(var361 = 1
)) and (var3 = 1 or not(var361 = 1)) and (var6 = 1 or not(var361 = 1)) and (var8
 = 1 or not(var361 = 1)) and (var10 = 1 or not(var361 = 1)) and (var12 = 1 or
not(var361 = 1)) and (var13 = 1 or not(var361 = 1)) and (var16 = 1 or not(var361
 = 1)) and (var18 = 1 or not(var362 = 1)) and (var19 = 1 or not(var362 = 1)) and
 (var22 = 1 or not(var362 = 1)) and (var24 = 1 or not(var362 = 1)) and (var26 =
1 or not(var362 = 1)) and (var28 = 1 or not(var362 = 1)) and (var29 = 1 or not(
var362 = 1)) and (var32 = 1 or not(var362 = 1)) and (var34 = 1 or not(var363 = 1
)) and (var35 = 1 or not(var363 = 1)) and (var38 = 1 or not(var363 = 1)) and (
var40 = 1 or not(var363 = 1)) and (var42 = 1 or not(var363 = 1)) and (var44 = 1
or not(var363 = 1)) and (var45 = 1 or not(var363 = 1)) and (var48 = 1 or not(
var363 = 1)) and (var50 = 1 or not(var364 = 1)) and (var51 = 1 or not(var364 = 1
)) and (var54 = 1 or not(var364 = 1)) and (var56 = 1 or not(var364 = 1)) and (
var58 = 1 or not(var364 = 1)) and (var60 = 1 or not(var364 = 1)) and (var61 = 1
or not(var364 = 1)) and (var64 = 1 or not(var364 = 1)) and (var66 = 1 or not(
var365 = 1)) and (var67 = 1 or not(var365 = 1)) and (var70 = 1 or not(var365 = 1
)) and (var72 = 1 or not(var365 = 1)) and (var74 = 1 or not(var365 = 1)) and (
var76 = 1 or not(var365 = 1)) and (var77 = 1 or not(var365 = 1)) and (var80 = 1
or not(var365 = 1)) and (var82 = 1 or not(var366 = 1)) and (var83 = 1 or not(
var366 = 1)) and (var86 = 1 or not(var366 = 1)) and (var88 = 1 or not(var366 = 1
)) and (var90 = 1 or not(var366 = 1)) and (var92 = 1 or not(var366 = 1)) and (
var93 = 1 or not(var366 = 1)) and (var96 = 1 or not(var366 = 1)) and (var98 = 1
or not(var367 = 1)) and (var99 = 1 or not(var367 = 1)) and (var102 = 1 or not(
var367 = 1)) and (var104 = 1 or not(var367 = 1)) and (var106 = 1 or not(var367 =
 1)) and (var108 = 1 or not(var367 = 1)) and (var109 = 1 or not(var367 = 1)) and
 (var112 = 1 or not(var367 = 1)) and (var114 = 1 or not(var368 = 1)) and (var115
 = 1 or not(var368 = 1)) and (var118 = 1 or not(var368 = 1)) and (var120 = 1 or
not(var368 = 1)) and (var122 = 1 or not(var368 = 1)) and (var124 = 1 or not(
var368 = 1)) and (var125 = 1 or not(var368 = 1)) and (var128 = 1 or not(var368 =
 1)) and (var130 = 1 or not(var369 = 1)) and (var131 = 1 or not(var369 = 1)) and
 (var134 = 1 or not(var369 = 1)) and (var136 = 1 or not(var369 = 1)) and (var138
 = 1 or not(var369 = 1)) and (var140 = 1 or not(var369 = 1)) and (var141 = 1 or
not(var369 = 1)) and (var144 = 1 or not(var369 = 1)) and (var146 = 1 or not(
var370 = 1)) and (var147 = 1 or not(var370 = 1)) and (var150 = 1 or not(var370 =
 1)) and (var152 = 1 or not(var370 = 1)) and (var154 = 1 or not(var370 = 1)) and
 (var156 = 1 or not(var370 = 1)) and (var157 = 1 or not(var370 = 1)) and (var160
 = 1 or not(var370 = 1)) and (var2 = 1 or not(var371 = 1)) and (var3 = 1 or not(
var371 = 1)) and (var6 = 1 or not(var371 = 1)) and (var7 = 1 or not(var371 = 1))
 and (var9 = 1 or not(var371 = 1)) and (var12 = 1 or not(var371 = 1)) and (var14
 = 1 or not(var371 = 1)) and (var16 = 1 or not(var371 = 1)) and (var18 = 1 or
not(var372 = 1)) and (var19 = 1 or not(var372 = 1)) and (var22 = 1 or not(var372
 = 1)) and (var23 = 1 or not(var372 = 1)) and (var25 = 1 or not(var372 = 1)) and
 (var28 = 1 or not(var372 = 1)) and (var30 = 1 or not(var372 = 1)) and (var32 =
1 or not(var372 = 1)) and (var34 = 1 or not(var373 = 1)) and (var35 = 1 or not(
var373 = 1)) and (var38 = 1 or not(var373 = 1)) and (var39 = 1 or not(var373 = 1
)) and (var41 = 1 or not(var373 = 1)) and (var44 = 1 or not(var373 = 1)) and (
var46 = 1 or not(var373 = 1)) and (var48 = 1 or not(var373 = 1)) and (var50 = 1
or not(var374 = 1)) and (var51 = 1 or not(var374 = 1)) and (var54 = 1 or not(
var374 = 1)) and (var55 = 1 or not(var374 = 1)) and (var57 = 1 or not(var374 = 1
)) and (var60 = 1 or not(var374 = 1)) and (var62 = 1 or not(var374 = 1)) and (
var64 = 1 or not(var374 = 1)) and (var66 = 1 or not(var375 = 1)) and (var67 = 1
or not(var375 = 1)) and (var70 = 1 or not(var375 = 1)) and (var71 = 1 or not(
var375 = 1)) and (var73 = 1 or not(var375 = 1)) and (var76 = 1 or not(var375 = 1
)) and (var78 = 1 or not(var375 = 1)) and (var80 = 1 or not(var375 = 1)) and (
var82 = 1 or not(var376 = 1)) and (var83 = 1 or not(var376 = 1)) and (var86 = 1
or not(var376 = 1)) and (var87 = 1 or not(var376 = 1)) and (var89 = 1 or not(
var376 = 1)) and (var92 = 1 or not(var376 = 1)) and (var94 = 1 or not(var376 = 1
)) and (var96 = 1 or not(var376 = 1)) and (var98 = 1 or not(var377 = 1)) and (
var99 = 1 or not(var377 = 1)) and (var102 = 1 or not(var377 = 1)) and (var103 =
1 or not(var377 = 1)) and (var105 = 1 or not(var377 = 1)) and (var108 = 1 or not
(var377 = 1)) and (var110 = 1 or not(var377 = 1)) and (var112 = 1 or not(var377
= 1)) and (var114 = 1 or not(var378 = 1)) and (var115 = 1 or not(var378 = 1))
and (var118 = 1 or not(var378 = 1)) and (var119 = 1 or not(var378 = 1)) and (
var121 = 1 or not(var378 = 1)) and (var124 = 1 or not(var378 = 1)) and (var126 =
 1 or not(var378 = 1)) and (var128 = 1 or not(var378 = 1)) and (var130 = 1 or
not(var379 = 1)) and (var131 = 1 or not(var379 = 1)) and (var134 = 1 or not(
var379 = 1)) and (var135 = 1 or not(var379 = 1)) and (var137 = 1 or not(var379 =
 1)) and (var140 = 1 or not(var379 = 1)) and (var142 = 1 or not(var379 = 1)) and
 (var144 = 1 or not(var379 = 1)) and (var146 = 1 or not(var380 = 1)) and (var147
 = 1 or not(var380 = 1)) and (var150 = 1 or not(var380 = 1)) and (var151 = 1 or
not(var380 = 1)) and (var153 = 1 or not(var380 = 1)) and (var156 = 1 or not(
var380 = 1)) and (var158 = 1 or not(var380 = 1)) and (var160 = 1 or not(var380 =
 1)) and (var1 = 1 or not(var381 = 1)) and (var4 = 1 or not(var381 = 1)) and (
var5 = 1 or not(var381 = 1)) and (var8 = 1 or not(var381 = 1)) and (var10 = 1 or
 not(var381 = 1)) and (var12 = 1 or not(var381 = 1)) and (var13 = 1 or not(
var381 = 1)) and (var15 = 1 or not(var381 = 1)) and (var17 = 1 or not(var382 = 1
)) and (var20 = 1 or not(var382 = 1)) and (var21 = 1 or not(var382 = 1)) and (
var24 = 1 or not(var382 = 1)) and (var26 = 1 or not(var382 = 1)) and (var28 = 1
or not(var382 = 1)) and (var29 = 1 or not(var382 = 1)) and (var31 = 1 or not(
var382 = 1)) and (var33 = 1 or not(var383 = 1)) and (var36 = 1 or not(var383 = 1
)) and (var37 = 1 or not(var383 = 1)) and (var40 = 1 or not(var383 = 1)) and (
var42 = 1 or not(var383 = 1)) and (var44 = 1 or not(var383 = 1)) and (var45 = 1
or not(var383 = 1)) and (var47 = 1 or not(var383 = 1)) and (var49 = 1 or not(
var384 = 1)) and (var52 = 1 or not(var384 = 1)) and (var53 = 1 or not(var384 = 1
)) and (var56 = 1 or not(var384 = 1)) and (var58 = 1 or not(var384 = 1)) and (
var60 = 1 or not(var384 = 1)) and (var61 = 1 or not(var384 = 1)) and (var63 = 1
or not(var384 = 1)) and (var65 = 1 or not(var385 = 1)) and (var68 = 1 or not(
var385 = 1)) and (var69 = 1 or not(var385 = 1)) and (var72 = 1 or not(var385 = 1
)) and (var74 = 1 or not(var385 = 1)) and (var76 = 1 or not(var385 = 1)) and (
var77 = 1 or not(var385 = 1)) and (var79 = 1 or not(var385 = 1)) and (var81 = 1
or not(var386 = 1)) and (var84 = 1 or not(var386 = 1)) and (var85 = 1 or not(
var386 = 1)) and (var88 = 1 or not(var386 = 1)) and (var90 = 1 or not(var386 = 1
)) and (var92 = 1 or not(var386 = 1)) and (var93 = 1 or not(var386 = 1)) and (
var95 = 1 or not(var386 = 1)) and (var97 = 1 or not(var387 = 1)) and (var100 = 1
 or not(var387 = 1)) and (var101 = 1 or not(var387 = 1)) and (var104 = 1 or not(
var387 = 1)) and (var106 = 1 or not(var387 = 1)) and (var108 = 1 or not(var387 =
 1)) and (var109 = 1 or not(var387 = 1)) and (var111 = 1 or not(var387 = 1)) and
 (var113 = 1 or not(var388 = 1)) and (var116 = 1 or not(var388 = 1)) and (var117
 = 1 or not(var388 = 1)) and (var120 = 1 or not(var388 = 1)) and (var122 = 1 or
not(var388 = 1)) and (var124 = 1 or not(var388 = 1)) and (var125 = 1 or not(
var388 = 1)) and (var127 = 1 or not(var388 = 1)) and (var129 = 1 or not(var389 =
 1)) and (var132 = 1 or not(var389 = 1)) and (var133 = 1 or not(var389 = 1)) and
 (var136 = 1 or not(var389 = 1)) and (var138 = 1 or not(var389 = 1)) and (var140
 = 1 or not(var389 = 1)) and (var141 = 1 or not(var389 = 1)) and (var143 = 1 or
not(var389 = 1)) and (var145 = 1 or not(var390 = 1)) and (var148 = 1 or not(
var390 = 1)) and (var149 = 1 or not(var390 = 1)) and (var152 = 1 or not(var390 =
 1)) and (var154 = 1 or not(var390 = 1)) and (var156 = 1 or not(var390 = 1)) and
 (var157 = 1 or not(var390 = 1)) and (var159 = 1 or not(var390 = 1)) and (var2 =
 1 or not(var391 = 1)) and (var3 = 1 or not(var391 = 1)) and (var6 = 1 or not(
var391 = 1)) and (var7 = 1 or not(var391 = 1)) and (var10 = 1 or not(var391 = 1)
) and (var11 = 1 or not(var391 = 1)) and (var14 = 1 or not(var391 = 1)) and (
var15 = 1 or not(var391 = 1)) and (var18 = 1 or not(var392 = 1)) and (var19 = 1
or not(var392 = 1)) and (var22 = 1 or not(var392 = 1)) and (var23 = 1 or not(
var392 = 1)) and (var26 = 1 or not(var392 = 1)) and (var27 = 1 or not(var392 = 1
)) and (var30 = 1 or not(var392 = 1)) and (var31 = 1 or not(var392 = 1)) and (
var34 = 1 or not(var393 = 1)) and (var35 = 1 or not(var393 = 1)) and (var38 = 1
or not(var393 = 1)) and (var39 = 1 or not(var393 = 1)) and (var42 = 1 or not(
var393 = 1)) and (var43 = 1 or not(var393 = 1)) and (var46 = 1 or not(var393 = 1
)) and (var47 = 1 or not(var393 = 1)) and (var50 = 1 or not(var394 = 1)) and (
var51 = 1 or not(var394 = 1)) and (var54 = 1 or not(var394 = 1)) and (var55 = 1
or not(var394 = 1)) and (var58 = 1 or not(var394 = 1)) and (var59 = 1 or not(
var394 = 1)) and (var62 = 1 or not(var394 = 1)) and (var63 = 1 or not(var394 = 1
)) and (var66 = 1 or not(var395 = 1)) and (var67 = 1 or not(var395 = 1)) and (
var70 = 1 or not(var395 = 1)) and (var71 = 1 or not(var395 = 1)) and (var74 = 1
or not(var395 = 1)) and (var75 = 1 or not(var395 = 1)) and (var78 = 1 or not(
var395 = 1)) and (var79 = 1 or not(var395 = 1)) and (var82 = 1 or not(var396 = 1
)) and (var83 = 1 or not(var396 = 1)) and (var86 = 1 or not(var396 = 1)) and (
var87 = 1 or not(var396 = 1)) and (var90 = 1 or not(var396 = 1)) and (var91 = 1
or not(var396 = 1)) and (var94 = 1 or not(var396 = 1)) and (var95 = 1 or not(
var396 = 1)) and (var98 = 1 or not(var397 = 1)) and (var99 = 1 or not(var397 = 1
)) and (var102 = 1 or not(var397 = 1)) and (var103 = 1 or not(var397 = 1)) and (
var106 = 1 or not(var397 = 1)) and (var107 = 1 or not(var397 = 1)) and (var110 =
 1 or not(var397 = 1)) and (var111 = 1 or not(var397 = 1)) and (var114 = 1 or
not(var398 = 1)) and (var115 = 1 or not(var398 = 1)) and (var118 = 1 or not(
var398 = 1)) and (var119 = 1 or not(var398 = 1)) and (var122 = 1 or not(var398 =
 1)) and (var123 = 1 or not(var398 = 1)) and (var126 = 1 or not(var398 = 1)) and
 (var127 = 1 or not(var398 = 1)) and (var130 = 1 or not(var399 = 1)) and (var131
 = 1 or not(var399 = 1)) and (var134 = 1 or not(var399 = 1)) and (var135 = 1 or
not(var399 = 1)) and (var138 = 1 or not(var399 = 1)) and (var139 = 1 or not(
var399 = 1)) and (var142 = 1 or not(var399 = 1)) and (var143 = 1 or not(var399 =
 1)) and (var146 = 1 or not(var400 = 1)) and (var147 = 1 or not(var400 = 1)) and
 (var150 = 1 or not(var400 = 1)) and (var151 = 1 or not(var400 = 1)) and (var154
 = 1 or not(var400 = 1)) and (var155 = 1 or not(var400 = 1)) and (var158 = 1 or
not(var400 = 1)) and (var159 = 1 or not(var400 = 1)) and (var2 = 1 or not(var401
 = 1)) and (var3 = 1 or not(var401 = 1)) and (var5 = 1 or not(var401 = 1)) and (
var8 = 1 or not(var401 = 1)) and (var10 = 1 or not(var401 = 1)) and (var11 = 1
or not(var401 = 1)) and (var13 = 1 or not(var401 = 1)) and (var15 = 1 or not(
var401 = 1)) and (var18 = 1 or not(var402 = 1)) and (var19 = 1 or not(var402 = 1
)) and (var21 = 1 or not(var402 = 1)) and (var24 = 1 or not(var402 = 1)) and (
var26 = 1 or not(var402 = 1)) and (var27 = 1 or not(var402 = 1)) and (var29 = 1
or not(var402 = 1)) and (var31 = 1 or not(var402 = 1)) and (var34 = 1 or not(
var403 = 1)) and (var35 = 1 or not(var403 = 1)) and (var37 = 1 or not(var403 = 1
)) and (var40 = 1 or not(var403 = 1)) and (var42 = 1 or not(var403 = 1)) and (
var43 = 1 or not(var403 = 1)) and (var45 = 1 or not(var403 = 1)) and (var47 = 1
or not(var403 = 1)) and (var50 = 1 or not(var404 = 1)) and (var51 = 1 or not(
var404 = 1)) and (var53 = 1 or not(var404 = 1)) and (var56 = 1 or not(var404 = 1
)) and (var58 = 1 or not(var404 = 1)) and (var59 = 1 or not(var404 = 1)) and (
var61 = 1 or not(var404 = 1)) and (var63 = 1 or not(var404 = 1)) and (var66 = 1
or not(var405 = 1)) and (var67 = 1 or not(var405 = 1)) and (var69 = 1 or not(
var405 = 1)) and (var72 = 1 or not(var405 = 1)) and (var74 = 1 or not(var405 = 1
)) and (var75 = 1 or not(var405 = 1)) and (var77 = 1 or not(var405 = 1)) and (
var79 = 1 or not(var405 = 1)) and (var82 = 1 or not(var406 = 1)) and (var83 = 1
or not(var406 = 1)) and (var85 = 1 or not(var406 = 1)) and (var88 = 1 or not(
var406 = 1)) and (var90 = 1 or not(var406 = 1)) and (var91 = 1 or not(var406 = 1
)) and (var93 = 1 or not(var406 = 1)) and (var95 = 1 or not(var406 = 1)) and (
var98 = 1 or not(var407 = 1)) and (var99 = 1 or not(var407 = 1)) and (var101 = 1
 or not(var407 = 1)) and (var104 = 1 or not(var407 = 1)) and (var106 = 1 or not(
var407 = 1)) and (var107 = 1 or not(var407 = 1)) and (var109 = 1 or not(var407 =
 1)) and (var111 = 1 or not(var407 = 1)) and (var114 = 1 or not(var408 = 1)) and
 (var115 = 1 or not(var408 = 1)) and (var117 = 1 or not(var408 = 1)) and (var120
 = 1 or not(var408 = 1)) and (var122 = 1 or not(var408 = 1)) and (var123 = 1 or
not(var408 = 1)) and (var125 = 1 or not(var408 = 1)) and (var127 = 1 or not(
var408 = 1)) and (var130 = 1 or not(var409 = 1)) and (var131 = 1 or not(var409 =
 1)) and (var133 = 1 or not(var409 = 1)) and (var136 = 1 or not(var409 = 1)) and
 (var138 = 1 or not(var409 = 1)) and (var139 = 1 or not(var409 = 1)) and (var141
 = 1 or not(var409 = 1)) and (var143 = 1 or not(var409 = 1)) and (var146 = 1 or
not(var410 = 1)) and (var147 = 1 or not(var410 = 1)) and (var149 = 1 or not(
var410 = 1)) and (var152 = 1 or not(var410 = 1)) and (var154 = 1 or not(var410 =
 1)) and (var155 = 1 or not(var410 = 1)) and (var157 = 1 or not(var410 = 1)) and
 (var159 = 1 or not(var410 = 1)) and (var2 = 1 or not(var411 = 1)) and (var4 = 1
 or not(var411 = 1)) and (var5 = 1 or not(var411 = 1)) and (var7 = 1 or not(
var411 = 1)) and (var10 = 1 or not(var411 = 1)) and (var11 = 1 or not(var411 = 1
)) and (var14 = 1 or not(var411 = 1)) and (var16 = 1 or not(var411 = 1)) and (
var18 = 1 or not(var412 = 1)) and (var20 = 1 or not(var412 = 1)) and (var21 = 1
or not(var412 = 1)) and (var23 = 1 or not(var412 = 1)) and (var26 = 1 or not(
var412 = 1)) and (var27 = 1 or not(var412 = 1)) and (var30 = 1 or not(var412 = 1
)) and (var32 = 1 or not(var412 = 1)) and (var34 = 1 or not(var413 = 1)) and (
var36 = 1 or not(var413 = 1)) and (var37 = 1 or not(var413 = 1)) and (var39 = 1
or not(var413 = 1)) and (var42 = 1 or not(var413 = 1)) and (var43 = 1 or not(
var413 = 1)) and (var46 = 1 or not(var413 = 1)) and (var48 = 1 or not(var413 = 1
)) and (var50 = 1 or not(var414 = 1)) and (var52 = 1 or not(var414 = 1)) and (
var53 = 1 or not(var414 = 1)) and (var55 = 1 or not(var414 = 1)) and (var58 = 1
or not(var414 = 1)) and (var59 = 1 or not(var414 = 1)) and (var62 = 1 or not(
var414 = 1)) and (var64 = 1 or not(var414 = 1)) and (var66 = 1 or not(var415 = 1
)) and (var68 = 1 or not(var415 = 1)) and (var69 = 1 or not(var415 = 1)) and (
var71 = 1 or not(var415 = 1)) and (var74 = 1 or not(var415 = 1)) and (var75 = 1
or not(var415 = 1)) and (var78 = 1 or not(var415 = 1)) and (var80 = 1 or not(
var415 = 1)) and (var82 = 1 or not(var416 = 1)) and (var84 = 1 or not(var416 = 1
)) and (var85 = 1 or not(var416 = 1)) and (var87 = 1 or not(var416 = 1)) and (
var90 = 1 or not(var416 = 1)) and (var91 = 1 or not(var416 = 1)) and (var94 = 1
or not(var416 = 1)) and (var96 = 1 or not(var416 = 1)) and (var98 = 1 or not(
var417 = 1)) and (var100 = 1 or not(var417 = 1)) and (var101 = 1 or not(var417 =
 1)) and (var103 = 1 or not(var417 = 1)) and (var106 = 1 or not(var417 = 1)) and
 (var107 = 1 or not(var417 = 1)) and (var110 = 1 or not(var417 = 1)) and (var112
 = 1 or not(var417 = 1)) and (var114 = 1 or not(var418 = 1)) and (var116 = 1 or
not(var418 = 1)) and (var117 = 1 or not(var418 = 1)) and (var119 = 1 or not(
var418 = 1)) and (var122 = 1 or not(var418 = 1)) and (var123 = 1 or not(var418 =
 1)) and (var126 = 1 or not(var418 = 1)) and (var128 = 1 or not(var418 = 1)) and
 (var130 = 1 or not(var419 = 1)) and (var132 = 1 or not(var419 = 1)) and (var133
 = 1 or not(var419 = 1)) and (var135 = 1 or not(var419 = 1)) and (var138 = 1 or
not(var419 = 1)) and (var139 = 1 or not(var419 = 1)) and (var142 = 1 or not(
var419 = 1)) and (var144 = 1 or not(var419 = 1)) and (var146 = 1 or not(var420 =
 1)) and (var148 = 1 or not(var420 = 1)) and (var149 = 1 or not(var420 = 1)) and
 (var151 = 1 or not(var420 = 1)) and (var154 = 1 or not(var420 = 1)) and (var155
 = 1 or not(var420 = 1)) and (var158 = 1 or not(var420 = 1)) and (var160 = 1 or
not(var420 = 1)) and (var2 = 1 or not(var421 = 1)) and (var4 = 1 or not(var421 =
 1)) and (var6 = 1 or not(var421 = 1)) and (var7 = 1 or not(var421 = 1)) and (
var10 = 1 or not(var421 = 1)) and (var11 = 1 or not(var421 = 1)) and (var13 = 1
or not(var421 = 1)) and (var16 = 1 or not(var421 = 1)) and (var18 = 1 or not(
var422 = 1)) and (var20 = 1 or not(var422 = 1)) and (var22 = 1 or not(var422 = 1
)) and (var23 = 1 or not(var422 = 1)) and (var26 = 1 or not(var422 = 1)) and (
var27 = 1 or not(var422 = 1)) and (var29 = 1 or not(var422 = 1)) and (var32 = 1
or not(var422 = 1)) and (var34 = 1 or not(var423 = 1)) and (var36 = 1 or not(
var423 = 1)) and (var38 = 1 or not(var423 = 1)) and (var39 = 1 or not(var423 = 1
)) and (var42 = 1 or not(var423 = 1)) and (var43 = 1 or not(var423 = 1)) and (
var45 = 1 or not(var423 = 1)) and (var48 = 1 or not(var423 = 1)) and (var50 = 1
or not(var424 = 1)) and (var52 = 1 or not(var424 = 1)) and (var54 = 1 or not(
var424 = 1)) and (var55 = 1 or not(var424 = 1)) and (var58 = 1 or not(var424 = 1
)) and (var59 = 1 or not(var424 = 1)) and (var61 = 1 or not(var424 = 1)) and (
var64 = 1 or not(var424 = 1)) and (var66 = 1 or not(var425 = 1)) and (var68 = 1
or not(var425 = 1)) and (var70 = 1 or not(var425 = 1)) and (var71 = 1 or not(
var425 = 1)) and (var74 = 1 or not(var425 = 1)) and (var75 = 1 or not(var425 = 1
)) and (var77 = 1 or not(var425 = 1)) and (var80 = 1 or not(var425 = 1)) and (
var82 = 1 or not(var426 = 1)) and (var84 = 1 or not(var426 = 1)) and (var86 = 1
or not(var426 = 1)) and (var87 = 1 or not(var426 = 1)) and (var90 = 1 or not(
var426 = 1)) and (var91 = 1 or not(var426 = 1)) and (var93 = 1 or not(var426 = 1
)) and (var96 = 1 or not(var426 = 1)) and (var98 = 1 or not(var427 = 1)) and (
var100 = 1 or not(var427 = 1)) and (var102 = 1 or not(var427 = 1)) and (var103 =
 1 or not(var427 = 1)) and (var106 = 1 or not(var427 = 1)) and (var107 = 1 or
not(var427 = 1)) and (var109 = 1 or not(var427 = 1)) and (var112 = 1 or not(
var427 = 1)) and (var114 = 1 or not(var428 = 1)) and (var116 = 1 or not(var428 =
 1)) and (var118 = 1 or not(var428 = 1)) and (var119 = 1 or not(var428 = 1)) and
 (var122 = 1 or not(var428 = 1)) and (var123 = 1 or not(var428 = 1)) and (var125
 = 1 or not(var428 = 1)) and (var128 = 1 or not(var428 = 1)) and (var130 = 1 or
not(var429 = 1)) and (var132 = 1 or not(var429 = 1)) and (var134 = 1 or not(
var429 = 1)) and (var135 = 1 or not(var429 = 1)) and (var138 = 1 or not(var429 =
 1)) and (var139 = 1 or not(var429 = 1)) and (var141 = 1 or not(var429 = 1)) and
 (var144 = 1 or not(var429 = 1)) and (var146 = 1 or not(var430 = 1)) and (var148
 = 1 or not(var430 = 1)) and (var150 = 1 or not(var430 = 1)) and (var151 = 1 or
not(var430 = 1)) and (var154 = 1 or not(var430 = 1)) and (var155 = 1 or not(
var430 = 1)) and (var157 = 1 or not(var430 = 1)) and (var160 = 1 or not(var430 =
 1)) and (var1 = 1 or not(var431 = 1)) and (var3 = 1 or not(var431 = 1)) and (
var5 = 1 or not(var431 = 1)) and (var7 = 1 or not(var431 = 1)) and (var10 = 1 or
 not(var431 = 1)) and (var11 = 1 or not(var431 = 1)) and (var13 = 1 or not(
var431 = 1)) and (var16 = 1 or not(var431 = 1)) and (var17 = 1 or not(var432 = 1
)) and (var19 = 1 or not(var432 = 1)) and (var21 = 1 or not(var432 = 1)) and (
var23 = 1 or not(var432 = 1)) and (var26 = 1 or not(var432 = 1)) and (var27 = 1
or not(var432 = 1)) and (var29 = 1 or not(var432 = 1)) and (var32 = 1 or not(
var432 = 1)) and (var33 = 1 or not(var433 = 1)) and (var35 = 1 or not(var433 = 1
)) and (var37 = 1 or not(var433 = 1)) and (var39 = 1 or not(var433 = 1)) and (
var42 = 1 or not(var433 = 1)) and (var43 = 1 or not(var433 = 1)) and (var45 = 1
or not(var433 = 1)) and (var48 = 1 or not(var433 = 1)) and (var49 = 1 or not(
var434 = 1)) and (var51 = 1 or not(var434 = 1)) and (var53 = 1 or not(var434 = 1
)) and (var55 = 1 or not(var434 = 1)) and (var58 = 1 or not(var434 = 1)) and (
var59 = 1 or not(var434 = 1)) and (var61 = 1 or not(var434 = 1)) and (var64 = 1
or not(var434 = 1)) and (var65 = 1 or not(var435 = 1)) and (var67 = 1 or not(
var435 = 1)) and (var69 = 1 or not(var435 = 1)) and (var71 = 1 or not(var435 = 1
)) and (var74 = 1 or not(var435 = 1)) and (var75 = 1 or not(var435 = 1)) and (
var77 = 1 or not(var435 = 1)) and (var80 = 1 or not(var435 = 1)) and (var81 = 1
or not(var436 = 1)) and (var83 = 1 or not(var436 = 1)) and (var85 = 1 or not(
var436 = 1)) and (var87 = 1 or not(var436 = 1)) and (var90 = 1 or not(var436 = 1
)) and (var91 = 1 or not(var436 = 1)) and (var93 = 1 or not(var436 = 1)) and (
var96 = 1 or not(var436 = 1)) and (var97 = 1 or not(var437 = 1)) and (var99 = 1
or not(var437 = 1)) and (var101 = 1 or not(var437 = 1)) and (var103 = 1 or not(
var437 = 1)) and (var106 = 1 or not(var437 = 1)) and (var107 = 1 or not(var437 =
 1)) and (var109 = 1 or not(var437 = 1)) and (var112 = 1 or not(var437 = 1)) and
 (var113 = 1 or not(var438 = 1)) and (var115 = 1 or not(var438 = 1)) and (var117
 = 1 or not(var438 = 1)) and (var119 = 1 or not(var438 = 1)) and (var122 = 1 or
not(var438 = 1)) and (var123 = 1 or not(var438 = 1)) and (var125 = 1 or not(
var438 = 1)) and (var128 = 1 or not(var438 = 1)) and (var129 = 1 or not(var439 =
 1)) and (var131 = 1 or not(var439 = 1)) and (var133 = 1 or not(var439 = 1)) and
 (var135 = 1 or not(var439 = 1)) and (var138 = 1 or not(var439 = 1)) and (var139
 = 1 or not(var439 = 1)) and (var141 = 1 or not(var439 = 1)) and (var144 = 1 or
not(var439 = 1)) and (var145 = 1 or not(var440 = 1)) and (var147 = 1 or not(
var440 = 1)) and (var149 = 1 or not(var440 = 1)) and (var151 = 1 or not(var440 =
 1)) and (var154 = 1 or not(var440 = 1)) and (var155 = 1 or not(var440 = 1)) and
 (var157 = 1 or not(var440 = 1)) and (var160 = 1 or not(var440 = 1)) and (var2 =
 1 or not(var441 = 1)) and (var3 = 1 or not(var441 = 1)) and (var5 = 1 or not(
var441 = 1)) and (var8 = 1 or not(var441 = 1)) and (var10 = 1 or not(var441 = 1)
) and (var12 = 1 or not(var441 = 1)) and (var13 = 1 or not(var441 = 1)) and (
var15 = 1 or not(var441 = 1)) and (var18 = 1 or not(var442 = 1)) and (var19 = 1
or not(var442 = 1)) and (var21 = 1 or not(var442 = 1)) and (var24 = 1 or not(
var442 = 1)) and (var26 = 1 or not(var442 = 1)) and (var28 = 1 or not(var442 = 1
)) and (var29 = 1 or not(var442 = 1)) and (var31 = 1 or not(var442 = 1)) and (
var34 = 1 or not(var443 = 1)) and (var35 = 1 or not(var443 = 1)) and (var37 = 1
or not(var443 = 1)) and (var40 = 1 or not(var443 = 1)) and (var42 = 1 or not(
var443 = 1)) and (var44 = 1 or not(var443 = 1)) and (var45 = 1 or not(var443 = 1
)) and (var47 = 1 or not(var443 = 1)) and (var50 = 1 or not(var444 = 1)) and (
var51 = 1 or not(var444 = 1)) and (var53 = 1 or not(var444 = 1)) and (var56 = 1
or not(var444 = 1)) and (var58 = 1 or not(var444 = 1)) and (var60 = 1 or not(
var444 = 1)) and (var61 = 1 or not(var444 = 1)) and (var63 = 1 or not(var444 = 1
)) and (var66 = 1 or not(var445 = 1)) and (var67 = 1 or not(var445 = 1)) and (
var69 = 1 or not(var445 = 1)) and (var72 = 1 or not(var445 = 1)) and (var74 = 1
or not(var445 = 1)) and (var76 = 1 or not(var445 = 1)) and (var77 = 1 or not(
var445 = 1)) and (var79 = 1 or not(var445 = 1)) and (var82 = 1 or not(var446 = 1
)) and (var83 = 1 or not(var446 = 1)) and (var85 = 1 or not(var446 = 1)) and (
var88 = 1 or not(var446 = 1)) and (var90 = 1 or not(var446 = 1)) and (var92 = 1
or not(var446 = 1)) and (var93 = 1 or not(var446 = 1)) and (var95 = 1 or not(
var446 = 1)) and (var98 = 1 or not(var447 = 1)) and (var99 = 1 or not(var447 = 1
)) and (var101 = 1 or not(var447 = 1)) and (var104 = 1 or not(var447 = 1)) and (
var106 = 1 or not(var447 = 1)) and (var108 = 1 or not(var447 = 1)) and (var109 =
 1 or not(var447 = 1)) and (var111 = 1 or not(var447 = 1)) and (var114 = 1 or
not(var448 = 1)) and (var115 = 1 or not(var448 = 1)) and (var117 = 1 or not(
var448 = 1)) and (var120 = 1 or not(var448 = 1)) and (var122 = 1 or not(var448 =
 1)) and (var124 = 1 or not(var448 = 1)) and (var125 = 1 or not(var448 = 1)) and
 (var127 = 1 or not(var448 = 1)) and (var130 = 1 or not(var449 = 1)) and (var131
 = 1 or not(var449 = 1)) and (var133 = 1 or not(var449 = 1)) and (var136 = 1 or
not(var449 = 1)) and (var138 = 1 or not(var449 = 1)) and (var140 = 1 or not(
var449 = 1)) and (var141 = 1 or not(var449 = 1)) and (var143 = 1 or not(var449 =
 1)) and (var146 = 1 or not(var450 = 1)) and (var147 = 1 or not(var450 = 1)) and
 (var149 = 1 or not(var450 = 1)) and (var152 = 1 or not(var450 = 1)) and (var154
 = 1 or not(var450 = 1)) and (var156 = 1 or not(var450 = 1)) and (var157 = 1 or
not(var450 = 1)) and (var159 = 1 or not(var450 = 1)) and (var1 = 1 or not(var451
 = 1)) and (var3 = 1 or not(var451 = 1)) and (var6 = 1 or not(var451 = 1)) and (
var8 = 1 or not(var451 = 1)) and (var9 = 1 or not(var451 = 1)) and (var12 = 1 or
 not(var451 = 1)) and (var14 = 1 or not(var451 = 1)) and (var16 = 1 or not(
var451 = 1)) and (var17 = 1 or not(var452 = 1)) and (var19 = 1 or not(var452 = 1
)) and (var22 = 1 or not(var452 = 1)) and (var24 = 1 or not(var452 = 1)) and (
var25 = 1 or not(var452 = 1)) and (var28 = 1 or not(var452 = 1)) and (var30 = 1
or not(var452 = 1)) and (var32 = 1 or not(var452 = 1)) and (var33 = 1 or not(
var453 = 1)) and (var35 = 1 or not(var453 = 1)) and (var38 = 1 or not(var453 = 1
)) and (var40 = 1 or not(var453 = 1)) and (var41 = 1 or not(var453 = 1)) and (
var44 = 1 or not(var453 = 1)) and (var46 = 1 or not(var453 = 1)) and (var48 = 1
or not(var453 = 1)) and (var49 = 1 or not(var454 = 1)) and (var51 = 1 or not(
var454 = 1)) and (var54 = 1 or not(var454 = 1)) and (var56 = 1 or not(var454 = 1
)) and (var57 = 1 or not(var454 = 1)) and (var60 = 1 or not(var454 = 1)) and (
var62 = 1 or not(var454 = 1)) and (var64 = 1 or not(var454 = 1)) and (var65 = 1
or not(var455 = 1)) and (var67 = 1 or not(var455 = 1)) and (var70 = 1 or not(
var455 = 1)) and (var72 = 1 or not(var455 = 1)) and (var73 = 1 or not(var455 = 1
)) and (var76 = 1 or not(var455 = 1)) and (var78 = 1 or not(var455 = 1)) and (
var80 = 1 or not(var455 = 1)) and (var81 = 1 or not(var456 = 1)) and (var83 = 1
or not(var456 = 1)) and (var86 = 1 or not(var456 = 1)) and (var88 = 1 or not(
var456 = 1)) and (var89 = 1 or not(var456 = 1)) and (var92 = 1 or not(var456 = 1
)) and (var94 = 1 or not(var456 = 1)) and (var96 = 1 or not(var456 = 1)) and (
var97 = 1 or not(var457 = 1)) and (var99 = 1 or not(var457 = 1)) and (var102 = 1
 or not(var457 = 1)) and (var104 = 1 or not(var457 = 1)) and (var105 = 1 or not(
var457 = 1)) and (var108 = 1 or not(var457 = 1)) and (var110 = 1 or not(var457 =
 1)) and (var112 = 1 or not(var457 = 1)) and (var113 = 1 or not(var458 = 1)) and
 (var115 = 1 or not(var458 = 1)) and (var118 = 1 or not(var458 = 1)) and (var120
 = 1 or not(var458 = 1)) and (var121 = 1 or not(var458 = 1)) and (var124 = 1 or
not(var458 = 1)) and (var126 = 1 or not(var458 = 1)) and (var128 = 1 or not(
var458 = 1)) and (var129 = 1 or not(var459 = 1)) and (var131 = 1 or not(var459 =
 1)) and (var134 = 1 or not(var459 = 1)) and (var136 = 1 or not(var459 = 1)) and
 (var137 = 1 or not(var459 = 1)) and (var140 = 1 or not(var459 = 1)) and (var142
 = 1 or not(var459 = 1)) and (var144 = 1 or not(var459 = 1)) and (var145 = 1 or
not(var460 = 1)) and (var147 = 1 or not(var460 = 1)) and (var150 = 1 or not(
var460 = 1)) and (var152 = 1 or not(var460 = 1)) and (var153 = 1 or not(var460 =
 1)) and (var156 = 1 or not(var460 = 1)) and (var158 = 1 or not(var460 = 1)) and
 (var160 = 1 or not(var460 = 1)) and (var1 = 1 or not(var461 = 1)) and (var4 = 1
 or not(var461 = 1)) and (var6 = 1 or not(var461 = 1)) and (var8 = 1 or not(
var461 = 1)) and (var10 = 1 or not(var461 = 1)) and (var12 = 1 or not(var461 = 1
)) and (var13 = 1 or not(var461 = 1)) and (var16 = 1 or not(var461 = 1)) and (
var17 = 1 or not(var462 = 1)) and (var20 = 1 or not(var462 = 1)) and (var22 = 1
or not(var462 = 1)) and (var24 = 1 or not(var462 = 1)) and (var26 = 1 or not(
var462 = 1)) and (var28 = 1 or not(var462 = 1)) and (var29 = 1 or not(var462 = 1
)) and (var32 = 1 or not(var462 = 1)) and (var33 = 1 or not(var463 = 1)) and (
var36 = 1 or not(var463 = 1)) and (var38 = 1 or not(var463 = 1)) and (var40 = 1
or not(var463 = 1)) and (var42 = 1 or not(var463 = 1)) and (var44 = 1 or not(
var463 = 1)) and (var45 = 1 or not(var463 = 1)) and (var48 = 1 or not(var463 = 1
)) and (var49 = 1 or not(var464 = 1)) and (var52 = 1 or not(var464 = 1)) and (
var54 = 1 or not(var464 = 1)) and (var56 = 1 or not(var464 = 1)) and (var58 = 1
or not(var464 = 1)) and (var60 = 1 or not(var464 = 1)) and (var61 = 1 or not(
var464 = 1)) and (var64 = 1 or not(var464 = 1)) and (var65 = 1 or not(var465 = 1
)) and (var68 = 1 or not(var465 = 1)) and (var70 = 1 or not(var465 = 1)) and (
var72 = 1 or not(var465 = 1)) and (var74 = 1 or not(var465 = 1)) and (var76 = 1
or not(var465 = 1)) and (var77 = 1 or not(var465 = 1)) and (var80 = 1 or not(
var465 = 1)) and (var81 = 1 or not(var466 = 1)) and (var84 = 1 or not(var466 = 1
)) and (var86 = 1 or not(var466 = 1)) and (var88 = 1 or not(var466 = 1)) and (
var90 = 1 or not(var466 = 1)) and (var92 = 1 or not(var466 = 1)) and (var93 = 1
or not(var466 = 1)) and (var96 = 1 or not(var466 = 1)) and (var97 = 1 or not(
var467 = 1)) and (var100 = 1 or not(var467 = 1)) and (var102 = 1 or not(var467 =
 1)) and (var104 = 1 or not(var467 = 1)) and (var106 = 1 or not(var467 = 1)) and
 (var108 = 1 or not(var467 = 1)) and (var109 = 1 or not(var467 = 1)) and (var112
 = 1 or not(var467 = 1)) and (var113 = 1 or not(var468 = 1)) and (var116 = 1 or
not(var468 = 1)) and (var118 = 1 or not(var468 = 1)) and (var120 = 1 or not(
var468 = 1)) and (var122 = 1 or not(var468 = 1)) and (var124 = 1 or not(var468 =
 1)) and (var125 = 1 or not(var468 = 1)) and (var128 = 1 or not(var468 = 1)) and
 (var129 = 1 or not(var469 = 1)) and (var132 = 1 or not(var469 = 1)) and (var134
 = 1 or not(var469 = 1)) and (var136 = 1 or not(var469 = 1)) and (var138 = 1 or
not(var469 = 1)) and (var140 = 1 or not(var469 = 1)) and (var141 = 1 or not(
var469 = 1)) and (var144 = 1 or not(var469 = 1)) and (var145 = 1 or not(var470 =
 1)) and (var148 = 1 or not(var470 = 1)) and (var150 = 1 or not(var470 = 1)) and
 (var152 = 1 or not(var470 = 1)) and (var154 = 1 or not(var470 = 1)) and (var156
 = 1 or not(var470 = 1)) and (var157 = 1 or not(var470 = 1)) and (var160 = 1 or
not(var470 = 1)) and (var2 = 1 or not(var471 = 1)) and (var4 = 1 or not(var471 =
 1)) and (var5 = 1 or not(var471 = 1)) and (var7 = 1 or not(var471 = 1)) and (
var10 = 1 or not(var471 = 1)) and (var12 = 1 or not(var471 = 1)) and (var13 = 1
or not(var471 = 1)) and (var15 = 1 or not(var471 = 1)) and (var18 = 1 or not(
var472 = 1)) and (var20 = 1 or not(var472 = 1)) and (var21 = 1 or not(var472 = 1
)) and (var23 = 1 or not(var472 = 1)) and (var26 = 1 or not(var472 = 1)) and (
var28 = 1 or not(var472 = 1)) and (var29 = 1 or not(var472 = 1)) and (var31 = 1
or not(var472 = 1)) and (var34 = 1 or not(var473 = 1)) and (var36 = 1 or not(
var473 = 1)) and (var37 = 1 or not(var473 = 1)) and (var39 = 1 or not(var473 = 1
)) and (var42 = 1 or not(var473 = 1)) and (var44 = 1 or not(var473 = 1)) and (
var45 = 1 or not(var473 = 1)) and (var47 = 1 or not(var473 = 1)) and (var50 = 1
or not(var474 = 1)) and (var52 = 1 or not(var474 = 1)) and (var53 = 1 or not(
var474 = 1)) and (var55 = 1 or not(var474 = 1)) and (var58 = 1 or not(var474 = 1
)) and (var60 = 1 or not(var474 = 1)) and (var61 = 1 or not(var474 = 1)) and (
var63 = 1 or not(var474 = 1)) and (var66 = 1 or not(var475 = 1)) and (var68 = 1
or not(var475 = 1)) and (var69 = 1 or not(var475 = 1)) and (var71 = 1 or not(
var475 = 1)) and (var74 = 1 or not(var475 = 1)) and (var76 = 1 or not(var475 = 1
)) and (var77 = 1 or not(var475 = 1)) and (var79 = 1 or not(var475 = 1)) and (
var82 = 1 or not(var476 = 1)) and (var84 = 1 or not(var476 = 1)) and (var85 = 1
or not(var476 = 1)) and (var87 = 1 or not(var476 = 1)) and (var90 = 1 or not(
var476 = 1)) and (var92 = 1 or not(var476 = 1)) and (var93 = 1 or not(var476 = 1
)) and (var95 = 1 or not(var476 = 1)) and (var98 = 1 or not(var477 = 1)) and (
var100 = 1 or not(var477 = 1)) and (var101 = 1 or not(var477 = 1)) and (var103 =
 1 or not(var477 = 1)) and (var106 = 1 or not(var477 = 1)) and (var108 = 1 or
not(var477 = 1)) and (var109 = 1 or not(var477 = 1)) and (var111 = 1 or not(
var477 = 1)) and (var114 = 1 or not(var478 = 1)) and (var116 = 1 or not(var478 =
 1)) and (var117 = 1 or not(var478 = 1)) and (var119 = 1 or not(var478 = 1)) and
 (var122 = 1 or not(var478 = 1)) and (var124 = 1 or not(var478 = 1)) and (var125
 = 1 or not(var478 = 1)) and (var127 = 1 or not(var478 = 1)) and (var130 = 1 or
not(var479 = 1)) and (var132 = 1 or not(var479 = 1)) and (var133 = 1 or not(
var479 = 1)) and (var135 = 1 or not(var479 = 1)) and (var138 = 1 or not(var479 =
 1)) and (var140 = 1 or not(var479 = 1)) and (var141 = 1 or not(var479 = 1)) and
 (var143 = 1 or not(var479 = 1)) and (var146 = 1 or not(var480 = 1)) and (var148
 = 1 or not(var480 = 1)) and (var149 = 1 or not(var480 = 1)) and (var151 = 1 or
not(var480 = 1)) and (var154 = 1 or not(var480 = 1)) and (var156 = 1 or not(
var480 = 1)) and (var157 = 1 or not(var480 = 1)) and (var159 = 1 or not(var480 =
 1)) and (var2 = 1 or not(var481 = 1)) and (var4 = 1 or not(var481 = 1)) and (
var5 = 1 or not(var481 = 1)) and (var7 = 1 or not(var481 = 1)) and (var10 = 1 or
 not(var481 = 1)) and (var12 = 1 or not(var481 = 1)) and (var14 = 1 or not(
var481 = 1)) and (var16 = 1 or not(var481 = 1)) and (var18 = 1 or not(var482 = 1
)) and (var20 = 1 or not(var482 = 1)) and (var21 = 1 or not(var482 = 1)) and (
var23 = 1 or not(var482 = 1)) and (var26 = 1 or not(var482 = 1)) and (var28 = 1
or not(var482 = 1)) and (var30 = 1 or not(var482 = 1)) and (var32 = 1 or not(
var482 = 1)) and (var34 = 1 or not(var483 = 1)) and (var36 = 1 or not(var483 = 1
)) and (var37 = 1 or not(var483 = 1)) and (var39 = 1 or not(var483 = 1)) and (
var42 = 1 or not(var483 = 1)) and (var44 = 1 or not(var483 = 1)) and (var46 = 1
or not(var483 = 1)) and (var48 = 1 or not(var483 = 1)) and (var50 = 1 or not(
var484 = 1)) and (var52 = 1 or not(var484 = 1)) and (var53 = 1 or not(var484 = 1
)) and (var55 = 1 or not(var484 = 1)) and (var58 = 1 or not(var484 = 1)) and (
var60 = 1 or not(var484 = 1)) and (var62 = 1 or not(var484 = 1)) and (var64 = 1
or not(var484 = 1)) and (var66 = 1 or not(var485 = 1)) and (var68 = 1 or not(
var485 = 1)) and (var69 = 1 or not(var485 = 1)) and (var71 = 1 or not(var485 = 1
)) and (var74 = 1 or not(var485 = 1)) and (var76 = 1 or not(var485 = 1)) and (
var78 = 1 or not(var485 = 1)) and (var80 = 1 or not(var485 = 1)) and (var82 = 1
or not(var486 = 1)) and (var84 = 1 or not(var486 = 1)) and (var85 = 1 or not(
var486 = 1)) and (var87 = 1 or not(var486 = 1)) and (var90 = 1 or not(var486 = 1
)) and (var92 = 1 or not(var486 = 1)) and (var94 = 1 or not(var486 = 1)) and (
var96 = 1 or not(var486 = 1)) and (var98 = 1 or not(var487 = 1)) and (var100 = 1
 or not(var487 = 1)) and (var101 = 1 or not(var487 = 1)) and (var103 = 1 or not(
var487 = 1)) and (var106 = 1 or not(var487 = 1)) and (var108 = 1 or not(var487 =
 1)) and (var110 = 1 or not(var487 = 1)) and (var112 = 1 or not(var487 = 1)) and
 (var114 = 1 or not(var488 = 1)) and (var116 = 1 or not(var488 = 1)) and (var117
 = 1 or not(var488 = 1)) and (var119 = 1 or not(var488 = 1)) and (var122 = 1 or
not(var488 = 1)) and (var124 = 1 or not(var488 = 1)) and (var126 = 1 or not(
var488 = 1)) and (var128 = 1 or not(var488 = 1)) and (var130 = 1 or not(var489 =
 1)) and (var132 = 1 or not(var489 = 1)) and (var133 = 1 or not(var489 = 1)) and
 (var135 = 1 or not(var489 = 1)) and (var138 = 1 or not(var489 = 1)) and (var140
 = 1 or not(var489 = 1)) and (var142 = 1 or not(var489 = 1)) and (var144 = 1 or
not(var489 = 1)) and (var146 = 1 or not(var490 = 1)) and (var148 = 1 or not(
var490 = 1)) and (var149 = 1 or not(var490 = 1)) and (var151 = 1 or not(var490 =
 1)) and (var154 = 1 or not(var490 = 1)) and (var156 = 1 or not(var490 = 1)) and
 (var158 = 1 or not(var490 = 1)) and (var160 = 1 or not(var490 = 1)) and (var1 =
 1 or not(var491 = 1)) and (var4 = 1 or not(var491 = 1)) and (var5 = 1 or not(
var491 = 1)) and (var8 = 1 or not(var491 = 1)) and (var10 = 1 or not(var491 = 1)
) and (var11 = 1 or not(var491 = 1)) and (var13 = 1 or not(var491 = 1)) and (
var15 = 1 or not(var491 = 1)) and (var17 = 1 or not(var492 = 1)) and (var20 = 1
or not(var492 = 1)) and (var21 = 1 or not(var492 = 1)) and (var24 = 1 or not(
var492 = 1)) and (var26 = 1 or not(var492 = 1)) and (var27 = 1 or not(var492 = 1
)) and (var29 = 1 or not(var492 = 1)) and (var31 = 1 or not(var492 = 1)) and (
var33 = 1 or not(var493 = 1)) and (var36 = 1 or not(var493 = 1)) and (var37 = 1
or not(var493 = 1)) and (var40 = 1 or not(var493 = 1)) and (var42 = 1 or not(
var493 = 1)) and (var43 = 1 or not(var493 = 1)) and (var45 = 1 or not(var493 = 1
)) and (var47 = 1 or not(var493 = 1)) and (var49 = 1 or not(var494 = 1)) and (
var52 = 1 or not(var494 = 1)) and (var53 = 1 or not(var494 = 1)) and (var56 = 1
or not(var494 = 1)) and (var58 = 1 or not(var494 = 1)) and (var59 = 1 or not(
var494 = 1)) and (var61 = 1 or not(var494 = 1)) and (var63 = 1 or not(var494 = 1
)) and (var65 = 1 or not(var495 = 1)) and (var68 = 1 or not(var495 = 1)) and (
var69 = 1 or not(var495 = 1)) and (var72 = 1 or not(var495 = 1)) and (var74 = 1
or not(var495 = 1)) and (var75 = 1 or not(var495 = 1)) and (var77 = 1 or not(
var495 = 1)) and (var79 = 1 or not(var495 = 1)) and (var81 = 1 or not(var496 = 1
)) and (var84 = 1 or not(var496 = 1)) and (var85 = 1 or not(var496 = 1)) and (
var88 = 1 or not(var496 = 1)) and (var90 = 1 or not(var496 = 1)) and (var91 = 1
or not(var496 = 1)) and (var93 = 1 or not(var496 = 1)) and (var95 = 1 or not(
var496 = 1)) and (var97 = 1 or not(var497 = 1)) and (var100 = 1 or not(var497 =
1)) and (var101 = 1 or not(var497 = 1)) and (var104 = 1 or not(var497 = 1)) and
(var106 = 1 or not(var497 = 1)) and (var107 = 1 or not(var497 = 1)) and (var109
= 1 or not(var497 = 1)) and (var111 = 1 or not(var497 = 1)) and (var113 = 1 or
not(var498 = 1)) and (var116 = 1 or not(var498 = 1)) and (var117 = 1 or not(
var498 = 1)) and (var120 = 1 or not(var498 = 1)) and (var122 = 1 or not(var498 =
 1)) and (var123 = 1 or not(var498 = 1)) and (var125 = 1 or not(var498 = 1)) and
 (var127 = 1 or not(var498 = 1)) and (var129 = 1 or not(var499 = 1)) and (var132
 = 1 or not(var499 = 1)) and (var133 = 1 or not(var499 = 1)) and (var136 = 1 or
not(var499 = 1)) and (var138 = 1 or not(var499 = 1)) and (var139 = 1 or not(
var499 = 1)) and (var141 = 1 or not(var499 = 1)) and (var143 = 1 or not(var499 =
 1)) and (var145 = 1 or not(var500 = 1)) and (var148 = 1 or not(var500 = 1)) and
 (var149 = 1 or not(var500 = 1)) and (var152 = 1 or not(var500 = 1)) and (var154
 = 1 or not(var500 = 1)) and (var155 = 1 or not(var500 = 1)) and (var157 = 1 or
not(var500 = 1)) and (var159 = 1 or not(var500 = 1)) and (var1 = 1 or not(var501
 = 1)) and (var3 = 1 or not(var501 = 1)) and (var5 = 1 or not(var501 = 1)) and (
var8 = 1 or not(var501 = 1)) and (var10 = 1 or not(var501 = 1)) and (var12 = 1
or not(var501 = 1)) and (var14 = 1 or not(var501 = 1)) and (var16 = 1 or not(
var501 = 1)) and (var17 = 1 or not(var502 = 1)) and (var19 = 1 or not(var502 = 1
)) and (var21 = 1 or not(var502 = 1)) and (var24 = 1 or not(var502 = 1)) and (
var26 = 1 or not(var502 = 1)) and (var28 = 1 or not(var502 = 1)) and (var30 = 1
or not(var502 = 1)) and (var32 = 1 or not(var502 = 1)) and (var33 = 1 or not(
var503 = 1)) and (var35 = 1 or not(var503 = 1)) and (var37 = 1 or not(var503 = 1
)) and (var40 = 1 or not(var503 = 1)) and (var42 = 1 or not(var503 = 1)) and (
var44 = 1 or not(var503 = 1)) and (var46 = 1 or not(var503 = 1)) and (var48 = 1
or not(var503 = 1)) and (var49 = 1 or not(var504 = 1)) and (var51 = 1 or not(
var504 = 1)) and (var53 = 1 or not(var504 = 1)) and (var56 = 1 or not(var504 = 1
)) and (var58 = 1 or not(var504 = 1)) and (var60 = 1 or not(var504 = 1)) and (
var62 = 1 or not(var504 = 1)) and (var64 = 1 or not(var504 = 1)) and (var65 = 1
or not(var505 = 1)) and (var67 = 1 or not(var505 = 1)) and (var69 = 1 or not(
var505 = 1)) and (var72 = 1 or not(var505 = 1)) and (var74 = 1 or not(var505 = 1
)) and (var76 = 1 or not(var505 = 1)) and (var78 = 1 or not(var505 = 1)) and (
var80 = 1 or not(var505 = 1)) and (var81 = 1 or not(var506 = 1)) and (var83 = 1
or not(var506 = 1)) and (var85 = 1 or not(var506 = 1)) and (var88 = 1 or not(
var506 = 1)) and (var90 = 1 or not(var506 = 1)) and (var92 = 1 or not(var506 = 1
)) and (var94 = 1 or not(var506 = 1)) and (var96 = 1 or not(var506 = 1)) and (
var97 = 1 or not(var507 = 1)) and (var99 = 1 or not(var507 = 1)) and (var101 = 1
 or not(var507 = 1)) and (var104 = 1 or not(var507 = 1)) and (var106 = 1 or not(
var507 = 1)) and (var108 = 1 or not(var507 = 1)) and (var110 = 1 or not(var507 =
 1)) and (var112 = 1 or not(var507 = 1)) and (var113 = 1 or not(var508 = 1)) and
 (var115 = 1 or not(var508 = 1)) and (var117 = 1 or not(var508 = 1)) and (var120
 = 1 or not(var508 = 1)) and (var122 = 1 or not(var508 = 1)) and (var124 = 1 or
not(var508 = 1)) and (var126 = 1 or not(var508 = 1)) and (var128 = 1 or not(
var508 = 1)) and (var129 = 1 or not(var509 = 1)) and (var131 = 1 or not(var509 =
 1)) and (var133 = 1 or not(var509 = 1)) and (var136 = 1 or not(var509 = 1)) and
 (var138 = 1 or not(var509 = 1)) and (var140 = 1 or not(var509 = 1)) and (var142
 = 1 or not(var509 = 1)) and (var144 = 1 or not(var509 = 1)) and (var145 = 1 or
not(var510 = 1)) and (var147 = 1 or not(var510 = 1)) and (var149 = 1 or not(
var510 = 1)) and (var152 = 1 or not(var510 = 1)) and (var154 = 1 or not(var510 =
 1)) and (var156 = 1 or not(var510 = 1)) and (var158 = 1 or not(var510 = 1)) and
 (var160 = 1 or not(var510 = 1)) and (var1 = 1 or not(var511 = 1)) and (var4 = 1
 or not(var511 = 1)) and (var6 = 1 or not(var511 = 1)) and (var8 = 1 or not(
var511 = 1)) and (var10 = 1 or not(var511 = 1)) and (var11 = 1 or not(var511 = 1
)) and (var14 = 1 or not(var511 = 1)) and (var15 = 1 or not(var511 = 1)) and (
var17 = 1 or not(var512 = 1)) and (var20 = 1 or not(var512 = 1)) and (var22 = 1
or not(var512 = 1)) and (var24 = 1 or not(var512 = 1)) and (var26 = 1 or not(
var512 = 1)) and (var27 = 1 or not(var512 = 1)) and (var30 = 1 or not(var512 = 1
)) and (var31 = 1 or not(var512 = 1)) and (var33 = 1 or not(var513 = 1)) and (
var36 = 1 or not(var513 = 1)) and (var38 = 1 or not(var513 = 1)) and (var40 = 1
or not(var513 = 1)) and (var42 = 1 or not(var513 = 1)) and (var43 = 1 or not(
var513 = 1)) and (var46 = 1 or not(var513 = 1)) and (var47 = 1 or not(var513 = 1
)) and (var49 = 1 or not(var514 = 1)) and (var52 = 1 or not(var514 = 1)) and (
var54 = 1 or not(var514 = 1)) and (var56 = 1 or not(var514 = 1)) and (var58 = 1
or not(var514 = 1)) and (var59 = 1 or not(var514 = 1)) and (var62 = 1 or not(
var514 = 1)) and (var63 = 1 or not(var514 = 1)) and (var65 = 1 or not(var515 = 1
)) and (var68 = 1 or not(var515 = 1)) and (var70 = 1 or not(var515 = 1)) and (
var72 = 1 or not(var515 = 1)) and (var74 = 1 or not(var515 = 1)) and (var75 = 1
or not(var515 = 1)) and (var78 = 1 or not(var515 = 1)) and (var79 = 1 or not(
var515 = 1)) and (var81 = 1 or not(var516 = 1)) and (var84 = 1 or not(var516 = 1
)) and (var86 = 1 or not(var516 = 1)) and (var88 = 1 or not(var516 = 1)) and (
var90 = 1 or not(var516 = 1)) and (var91 = 1 or not(var516 = 1)) and (var94 = 1
or not(var516 = 1)) and (var95 = 1 or not(var516 = 1)) and (var97 = 1 or not(
var517 = 1)) and (var100 = 1 or not(var517 = 1)) and (var102 = 1 or not(var517 =
 1)) and (var104 = 1 or not(var517 = 1)) and (var106 = 1 or not(var517 = 1)) and
 (var107 = 1 or not(var517 = 1)) and (var110 = 1 or not(var517 = 1)) and (var111
 = 1 or not(var517 = 1)) and (var113 = 1 or not(var518 = 1)) and (var116 = 1 or
not(var518 = 1)) and (var118 = 1 or not(var518 = 1)) and (var120 = 1 or not(
var518 = 1)) and (var122 = 1 or not(var518 = 1)) and (var123 = 1 or not(var518 =
 1)) and (var126 = 1 or not(var518 = 1)) and (var127 = 1 or not(var518 = 1)) and
 (var129 = 1 or not(var519 = 1)) and (var132 = 1 or not(var519 = 1)) and (var134
 = 1 or not(var519 = 1)) and (var136 = 1 or not(var519 = 1)) and (var138 = 1 or
not(var519 = 1)) and (var139 = 1 or not(var519 = 1)) and (var142 = 1 or not(
var519 = 1)) and (var143 = 1 or not(var519 = 1)) and (var145 = 1 or not(var520 =
 1)) and (var148 = 1 or not(var520 = 1)) and (var150 = 1 or not(var520 = 1)) and
 (var152 = 1 or not(var520 = 1)) and (var154 = 1 or not(var520 = 1)) and (var155
 = 1 or not(var520 = 1)) and (var158 = 1 or not(var520 = 1)) and (var159 = 1 or
not(var520 = 1)) and (var2 = 1 or not(var521 = 1)) and (var3 = 1 or not(var521 =
 1)) and (var5 = 1 or not(var521 = 1)) and (var8 = 1 or not(var521 = 1)) and (
var10 = 1 or not(var521 = 1)) and (var12 = 1 or not(var521 = 1)) and (var13 = 1
or not(var521 = 1)) and (var15 = 1 or not(var521 = 1)) and (var18 = 1 or not(
var522 = 1)) and (var19 = 1 or not(var522 = 1)) and (var21 = 1 or not(var522 = 1
)) and (var24 = 1 or not(var522 = 1)) and (var26 = 1 or not(var522 = 1)) and (
var28 = 1 or not(var522 = 1)) and (var29 = 1 or not(var522 = 1)) and (var31 = 1
or not(var522 = 1)) and (var34 = 1 or not(var523 = 1)) and (var35 = 1 or not(
var523 = 1)) and (var37 = 1 or not(var523 = 1)) and (var40 = 1 or not(var523 = 1
)) and (var42 = 1 or not(var523 = 1)) and (var44 = 1 or not(var523 = 1)) and (
var45 = 1 or not(var523 = 1)) and (var47 = 1 or not(var523 = 1)) and (var50 = 1
or not(var524 = 1)) and (var51 = 1 or not(var524 = 1)) and (var53 = 1 or not(
var524 = 1)) and (var56 = 1 or not(var524 = 1)) and (var58 = 1 or not(var524 = 1
)) and (var60 = 1 or not(var524 = 1)) and (var61 = 1 or not(var524 = 1)) and (
var63 = 1 or not(var524 = 1)) and (var66 = 1 or not(var525 = 1)) and (var67 = 1
or not(var525 = 1)) and (var69 = 1 or not(var525 = 1)) and (var72 = 1 or not(
var525 = 1)) and (var74 = 1 or not(var525 = 1)) and (var76 = 1 or not(var525 = 1
)) and (var77 = 1 or not(var525 = 1)) and (var79 = 1 or not(var525 = 1)) and (
var82 = 1 or not(var526 = 1)) and (var83 = 1 or not(var526 = 1)) and (var85 = 1
or not(var526 = 1)) and (var88 = 1 or not(var526 = 1)) and (var90 = 1 or not(
var526 = 1)) and (var92 = 1 or not(var526 = 1)) and (var93 = 1 or not(var526 = 1
)) and (var95 = 1 or not(var526 = 1)) and (var98 = 1 or not(var527 = 1)) and (
var99 = 1 or not(var527 = 1)) and (var101 = 1 or not(var527 = 1)) and (var104 =
1 or not(var527 = 1)) and (var106 = 1 or not(var527 = 1)) and (var108 = 1 or not
(var527 = 1)) and (var109 = 1 or not(var527 = 1)) and (var111 = 1 or not(var527
= 1)) and (var114 = 1 or not(var528 = 1)) and (var115 = 1 or not(var528 = 1))
and (var117 = 1 or not(var528 = 1)) and (var120 = 1 or not(var528 = 1)) and (
var122 = 1 or not(var528 = 1)) and (var124 = 1 or not(var528 = 1)) and (var125 =
 1 or not(var528 = 1)) and (var127 = 1 or not(var528 = 1)) and (var130 = 1 or
not(var529 = 1)) and (var131 = 1 or not(var529 = 1)) and (var133 = 1 or not(
var529 = 1)) and (var136 = 1 or not(var529 = 1)) and (var138 = 1 or not(var529 =
 1)) and (var140 = 1 or not(var529 = 1)) and (var141 = 1 or not(var529 = 1)) and
 (var143 = 1 or not(var529 = 1)) and (var146 = 1 or not(var530 = 1)) and (var147
 = 1 or not(var530 = 1)) and (var149 = 1 or not(var530 = 1)) and (var152 = 1 or
not(var530 = 1)) and (var154 = 1 or not(var530 = 1)) and (var156 = 1 or not(
var530 = 1)) and (var157 = 1 or not(var530 = 1)) and (var159 = 1 or not(var530 =
 1)) and (var1 = 1 or not(var531 = 1)) and (var3 = 1 or not(var531 = 1)) and (
var6 = 1 or not(var531 = 1)) and (var8 = 1 or not(var531 = 1)) and (var10 = 1 or
 not(var531 = 1)) and (var11 = 1 or not(var531 = 1)) and (var14 = 1 or not(
var531 = 1)) and (var15 = 1 or not(var531 = 1)) and (var17 = 1 or not(var532 = 1
)) and (var19 = 1 or not(var532 = 1)) and (var22 = 1 or not(var532 = 1)) and (
var24 = 1 or not(var532 = 1)) and (var26 = 1 or not(var532 = 1)) and (var27 = 1
or not(var532 = 1)) and (var30 = 1 or not(var532 = 1)) and (var31 = 1 or not(
var532 = 1)) and (var33 = 1 or not(var533 = 1)) and (var35 = 1 or not(var533 = 1
)) and (var38 = 1 or not(var533 = 1)) and (var40 = 1 or not(var533 = 1)) and (
var42 = 1 or not(var533 = 1)) and (var43 = 1 or not(var533 = 1)) and (var46 = 1
or not(var533 = 1)) and (var47 = 1 or not(var533 = 1)) and (var49 = 1 or not(
var534 = 1)) and (var51 = 1 or not(var534 = 1)) and (var54 = 1 or not(var534 = 1
)) and (var56 = 1 or not(var534 = 1)) and (var58 = 1 or not(var534 = 1)) and (
var59 = 1 or not(var534 = 1)) and (var62 = 1 or not(var534 = 1)) and (var63 = 1
or not(var534 = 1)) and (var65 = 1 or not(var535 = 1)) and (var67 = 1 or not(
var535 = 1)) and (var70 = 1 or not(var535 = 1)) and (var72 = 1 or not(var535 = 1
)) and (var74 = 1 or not(var535 = 1)) and (var75 = 1 or not(var535 = 1)) and (
var78 = 1 or not(var535 = 1)) and (var79 = 1 or not(var535 = 1)) and (var81 = 1
or not(var536 = 1)) and (var83 = 1 or not(var536 = 1)) and (var86 = 1 or not(
var536 = 1)) and (var88 = 1 or not(var536 = 1)) and (var90 = 1 or not(var536 = 1
)) and (var91 = 1 or not(var536 = 1)) and (var94 = 1 or not(var536 = 1)) and (
var95 = 1 or not(var536 = 1)) and (var97 = 1 or not(var537 = 1)) and (var99 = 1
or not(var537 = 1)) and (var102 = 1 or not(var537 = 1)) and (var104 = 1 or not(
var537 = 1)) and (var106 = 1 or not(var537 = 1)) and (var107 = 1 or not(var537 =
 1)) and (var110 = 1 or not(var537 = 1)) and (var111 = 1 or not(var537 = 1)) and
 (var113 = 1 or not(var538 = 1)) and (var115 = 1 or not(var538 = 1)) and (var118
 = 1 or not(var538 = 1)) and (var120 = 1 or not(var538 = 1)) and (var122 = 1 or
not(var538 = 1)) and (var123 = 1 or not(var538 = 1)) and (var126 = 1 or not(
var538 = 1)) and (var127 = 1 or not(var538 = 1)) and (var129 = 1 or not(var539 =
 1)) and (var131 = 1 or not(var539 = 1)) and (var134 = 1 or not(var539 = 1)) and
 (var136 = 1 or not(var539 = 1)) and (var138 = 1 or not(var539 = 1)) and (var139
 = 1 or not(var539 = 1)) and (var142 = 1 or not(var539 = 1)) and (var143 = 1 or
not(var539 = 1)) and (var145 = 1 or not(var540 = 1)) and (var147 = 1 or not(
var540 = 1)) and (var150 = 1 or not(var540 = 1)) and (var152 = 1 or not(var540 =
 1)) and (var154 = 1 or not(var540 = 1)) and (var155 = 1 or not(var540 = 1)) and
 (var158 = 1 or not(var540 = 1)) and (var159 = 1 or not(var540 = 1)) and (var1 =
 1 or not(var541 = 1)) and (var3 = 1 or not(var541 = 1)) and (var6 = 1 or not(
var541 = 1)) and (var8 = 1 or not(var541 = 1)) and (var10 = 1 or not(var541 = 1)
) and (var11 = 1 or not(var541 = 1)) and (var14 = 1 or not(var541 = 1)) and (
var15 = 1 or not(var541 = 1)) and (var17 = 1 or not(var542 = 1)) and (var19 = 1
or not(var542 = 1)) and (var22 = 1 or not(var542 = 1)) and (var24 = 1 or not(
var542 = 1)) and (var26 = 1 or not(var542 = 1)) and (var27 = 1 or not(var542 = 1
)) and (var30 = 1 or not(var542 = 1)) and (var31 = 1 or not(var542 = 1)) and (
var33 = 1 or not(var543 = 1)) and (var35 = 1 or not(var543 = 1)) and (var38 = 1
or not(var543 = 1)) and (var40 = 1 or not(var543 = 1)) and (var42 = 1 or not(
var543 = 1)) and (var43 = 1 or not(var543 = 1)) and (var46 = 1 or not(var543 = 1
)) and (var47 = 1 or not(var543 = 1)) and (var49 = 1 or not(var544 = 1)) and (
var51 = 1 or not(var544 = 1)) and (var54 = 1 or not(var544 = 1)) and (var56 = 1
or not(var544 = 1)) and (var58 = 1 or not(var544 = 1)) and (var59 = 1 or not(
var544 = 1)) and (var62 = 1 or not(var544 = 1)) and (var63 = 1 or not(var544 = 1
)) and (var65 = 1 or not(var545 = 1)) and (var67 = 1 or not(var545 = 1)) and (
var70 = 1 or not(var545 = 1)) and (var72 = 1 or not(var545 = 1)) and (var74 = 1
or not(var545 = 1)) and (var75 = 1 or not(var545 = 1)) and (var78 = 1 or not(
var545 = 1)) and (var79 = 1 or not(var545 = 1)) and (var81 = 1 or not(var546 = 1
)) and (var83 = 1 or not(var546 = 1)) and (var86 = 1 or not(var546 = 1)) and (
var88 = 1 or not(var546 = 1)) and (var90 = 1 or not(var546 = 1)) and (var91 = 1
or not(var546 = 1)) and (var94 = 1 or not(var546 = 1)) and (var95 = 1 or not(
var546 = 1)) and (var97 = 1 or not(var547 = 1)) and (var99 = 1 or not(var547 = 1
)) and (var102 = 1 or not(var547 = 1)) and (var104 = 1 or not(var547 = 1)) and (
var106 = 1 or not(var547 = 1)) and (var107 = 1 or not(var547 = 1)) and (var110 =
 1 or not(var547 = 1)) and (var111 = 1 or not(var547 = 1)) and (var113 = 1 or
not(var548 = 1)) and (var115 = 1 or not(var548 = 1)) and (var118 = 1 or not(
var548 = 1)) and (var120 = 1 or not(var548 = 1)) and (var122 = 1 or not(var548 =
 1)) and (var123 = 1 or not(var548 = 1)) and (var126 = 1 or not(var548 = 1)) and
 (var127 = 1 or not(var548 = 1)) and (var129 = 1 or not(var549 = 1)) and (var131
 = 1 or not(var549 = 1)) and (var134 = 1 or not(var549 = 1)) and (var136 = 1 or
not(var549 = 1)) and (var138 = 1 or not(var549 = 1)) and (var139 = 1 or not(
var549 = 1)) and (var142 = 1 or not(var549 = 1)) and (var143 = 1 or not(var549 =
 1)) and (var145 = 1 or not(var550 = 1)) and (var147 = 1 or not(var550 = 1)) and
 (var150 = 1 or not(var550 = 1)) and (var152 = 1 or not(var550 = 1)) and (var154
 = 1 or not(var550 = 1)) and (var155 = 1 or not(var550 = 1)) and (var158 = 1 or
not(var550 = 1)) and (var159 = 1 or not(var550 = 1)) and (var1 = 1 or not(var551
 = 1)) and (var4 = 1 or not(var551 = 1)) and (var6 = 1 or not(var551 = 1)) and (
var7 = 1 or not(var551 = 1)) and (var9 = 1 or not(var551 = 1)) and (var12 = 1 or
 not(var551 = 1)) and (var14 = 1 or not(var551 = 1)) and (var16 = 1 or not(
var551 = 1)) and (var17 = 1 or not(var552 = 1)) and (var20 = 1 or not(var552 = 1
)) and (var22 = 1 or not(var552 = 1)) and (var23 = 1 or not(var552 = 1)) and (
var25 = 1 or not(var552 = 1)) and (var28 = 1 or not(var552 = 1)) and (var30 = 1
or not(var552 = 1)) and (var32 = 1 or not(var552 = 1)) and (var33 = 1 or not(
var553 = 1)) and (var36 = 1 or not(var553 = 1)) and (var38 = 1 or not(var553 = 1
)) and (var39 = 1 or not(var553 = 1)) and (var41 = 1 or not(var553 = 1)) and (
var44 = 1 or not(var553 = 1)) and (var46 = 1 or not(var553 = 1)) and (var48 = 1
or not(var553 = 1)) and (var49 = 1 or not(var554 = 1)) and (var52 = 1 or not(
var554 = 1)) and (var54 = 1 or not(var554 = 1)) and (var55 = 1 or not(var554 = 1
)) and (var57 = 1 or not(var554 = 1)) and (var60 = 1 or not(var554 = 1)) and (
var62 = 1 or not(var554 = 1)) and (var64 = 1 or not(var554 = 1)) and (var65 = 1
or not(var555 = 1)) and (var68 = 1 or not(var555 = 1)) and (var70 = 1 or not(
var555 = 1)) and (var71 = 1 or not(var555 = 1)) and (var73 = 1 or not(var555 = 1
)) and (var76 = 1 or not(var555 = 1)) and (var78 = 1 or not(var555 = 1)) and (
var80 = 1 or not(var555 = 1)) and (var81 = 1 or not(var556 = 1)) and (var84 = 1
or not(var556 = 1)) and (var86 = 1 or not(var556 = 1)) and (var87 = 1 or not(
var556 = 1)) and (var89 = 1 or not(var556 = 1)) and (var92 = 1 or not(var556 = 1
)) and (var94 = 1 or not(var556 = 1)) and (var96 = 1 or not(var556 = 1)) and (
var97 = 1 or not(var557 = 1)) and (var100 = 1 or not(var557 = 1)) and (var102 =
1 or not(var557 = 1)) and (var103 = 1 or not(var557 = 1)) and (var105 = 1 or not
(var557 = 1)) and (var108 = 1 or not(var557 = 1)) and (var110 = 1 or not(var557
= 1)) and (var112 = 1 or not(var557 = 1)) and (var113 = 1 or not(var558 = 1))
and (var116 = 1 or not(var558 = 1)) and (var118 = 1 or not(var558 = 1)) and (
var119 = 1 or not(var558 = 1)) and (var121 = 1 or not(var558 = 1)) and (var124 =
 1 or not(var558 = 1)) and (var126 = 1 or not(var558 = 1)) and (var128 = 1 or
not(var558 = 1)) and (var129 = 1 or not(var559 = 1)) and (var132 = 1 or not(
var559 = 1)) and (var134 = 1 or not(var559 = 1)) and (var135 = 1 or not(var559 =
 1)) and (var137 = 1 or not(var559 = 1)) and (var140 = 1 or not(var559 = 1)) and
 (var142 = 1 or not(var559 = 1)) and (var144 = 1 or not(var559 = 1)) and (var145
 = 1 or not(var560 = 1)) and (var148 = 1 or not(var560 = 1)) and (var150 = 1 or
not(var560 = 1)) and (var151 = 1 or not(var560 = 1)) and (var153 = 1 or not(
var560 = 1)) and (var156 = 1 or not(var560 = 1)) and (var158 = 1 or not(var560 =
 1)) and (var160 = 1 or not(var560 = 1)) and (var1 = 1 or not(var561 = 1)) and (
var3 = 1 or not(var561 = 1)) and (var5 = 1 or not(var561 = 1)) and (var8 = 1 or
not(var561 = 1)) and (var10 = 1 or not(var561 = 1)) and (var11 = 1 or not(var561
 = 1)) and (var14 = 1 or not(var561 = 1)) and (var16 = 1 or not(var561 = 1)) and
 (var17 = 1 or not(var562 = 1)) and (var19 = 1 or not(var562 = 1)) and (var21 =
1 or not(var562 = 1)) and (var24 = 1 or not(var562 = 1)) and (var26 = 1 or not(
var562 = 1)) and (var27 = 1 or not(var562 = 1)) and (var30 = 1 or not(var562 = 1
)) and (var32 = 1 or not(var562 = 1)) and (var33 = 1 or not(var563 = 1)) and (
var35 = 1 or not(var563 = 1)) and (var37 = 1 or not(var563 = 1)) and (var40 = 1
or not(var563 = 1)) and (var42 = 1 or not(var563 = 1)) and (var43 = 1 or not(
var563 = 1)) and (var46 = 1 or not(var563 = 1)) and (var48 = 1 or not(var563 = 1
)) and (var49 = 1 or not(var564 = 1)) and (var51 = 1 or not(var564 = 1)) and (
var53 = 1 or not(var564 = 1)) and (var56 = 1 or not(var564 = 1)) and (var58 = 1
or not(var564 = 1)) and (var59 = 1 or not(var564 = 1)) and (var62 = 1 or not(
var564 = 1)) and (var64 = 1 or not(var564 = 1)) and (var65 = 1 or not(var565 = 1
)) and (var67 = 1 or not(var565 = 1)) and (var69 = 1 or not(var565 = 1)) and (
var72 = 1 or not(var565 = 1)) and (var74 = 1 or not(var565 = 1)) and (var75 = 1
or not(var565 = 1)) and (var78 = 1 or not(var565 = 1)) and (var80 = 1 or not(
var565 = 1)) and (var81 = 1 or not(var566 = 1)) and (var83 = 1 or not(var566 = 1
)) and (var85 = 1 or not(var566 = 1)) and (var88 = 1 or not(var566 = 1)) and (
var90 = 1 or not(var566 = 1)) and (var91 = 1 or not(var566 = 1)) and (var94 = 1
or not(var566 = 1)) and (var96 = 1 or not(var566 = 1)) and (var97 = 1 or not(
var567 = 1)) and (var99 = 1 or not(var567 = 1)) and (var101 = 1 or not(var567 =
1)) and (var104 = 1 or not(var567 = 1)) and (var106 = 1 or not(var567 = 1)) and
(var107 = 1 or not(var567 = 1)) and (var110 = 1 or not(var567 = 1)) and (var112
= 1 or not(var567 = 1)) and (var113 = 1 or not(var568 = 1)) and (var115 = 1 or
not(var568 = 1)) and (var117 = 1 or not(var568 = 1)) and (var120 = 1 or not(
var568 = 1)) and (var122 = 1 or not(var568 = 1)) and (var123 = 1 or not(var568 =
 1)) and (var126 = 1 or not(var568 = 1)) and (var128 = 1 or not(var568 = 1)) and
 (var129 = 1 or not(var569 = 1)) and (var131 = 1 or not(var569 = 1)) and (var133
 = 1 or not(var569 = 1)) and (var136 = 1 or not(var569 = 1)) and (var138 = 1 or
not(var569 = 1)) and (var139 = 1 or not(var569 = 1)) and (var142 = 1 or not(
var569 = 1)) and (var144 = 1 or not(var569 = 1)) and (var145 = 1 or not(var570 =
 1)) and (var147 = 1 or not(var570 = 1)) and (var149 = 1 or not(var570 = 1)) and
 (var152 = 1 or not(var570 = 1)) and (var154 = 1 or not(var570 = 1)) and (var155
 = 1 or not(var570 = 1)) and (var158 = 1 or not(var570 = 1)) and (var160 = 1 or
not(var570 = 1)) and (var1 = 1 or not(var571 = 1)) and (var4 = 1 or not(var571 =
 1)) and (var6 = 1 or not(var571 = 1)) and (var8 = 1 or not(var571 = 1)) and (
var9 = 1 or not(var571 = 1)) and (var12 = 1 or not(var571 = 1)) and (var14 = 1
or not(var571 = 1)) and (var15 = 1 or not(var571 = 1)) and (var17 = 1 or not(
var572 = 1)) and (var20 = 1 or not(var572 = 1)) and (var22 = 1 or not(var572 = 1
)) and (var24 = 1 or not(var572 = 1)) and (var25 = 1 or not(var572 = 1)) and (
var28 = 1 or not(var572 = 1)) and (var30 = 1 or not(var572 = 1)) and (var31 = 1
or not(var572 = 1)) and (var33 = 1 or not(var573 = 1)) and (var36 = 1 or not(
var573 = 1)) and (var38 = 1 or not(var573 = 1)) and (var40 = 1 or not(var573 = 1
)) and (var41 = 1 or not(var573 = 1)) and (var44 = 1 or not(var573 = 1)) and (
var46 = 1 or not(var573 = 1)) and (var47 = 1 or not(var573 = 1)) and (var49 = 1
or not(var574 = 1)) and (var52 = 1 or not(var574 = 1)) and (var54 = 1 or not(
var574 = 1)) and (var56 = 1 or not(var574 = 1)) and (var57 = 1 or not(var574 = 1
)) and (var60 = 1 or not(var574 = 1)) and (var62 = 1 or not(var574 = 1)) and (
var63 = 1 or not(var574 = 1)) and (var65 = 1 or not(var575 = 1)) and (var68 = 1
or not(var575 = 1)) and (var70 = 1 or not(var575 = 1)) and (var72 = 1 or not(
var575 = 1)) and (var73 = 1 or not(var575 = 1)) and (var76 = 1 or not(var575 = 1
)) and (var78 = 1 or not(var575 = 1)) and (var79 = 1 or not(var575 = 1)) and (
var81 = 1 or not(var576 = 1)) and (var84 = 1 or not(var576 = 1)) and (var86 = 1
or not(var576 = 1)) and (var88 = 1 or not(var576 = 1)) and (var89 = 1 or not(
var576 = 1)) and (var92 = 1 or not(var576 = 1)) and (var94 = 1 or not(var576 = 1
)) and (var95 = 1 or not(var576 = 1)) and (var97 = 1 or not(var577 = 1)) and (
var100 = 1 or not(var577 = 1)) and (var102 = 1 or not(var577 = 1)) and (var104 =
 1 or not(var577 = 1)) and (var105 = 1 or not(var577 = 1)) and (var108 = 1 or
not(var577 = 1)) and (var110 = 1 or not(var577 = 1)) and (var111 = 1 or not(
var577 = 1)) and (var113 = 1 or not(var578 = 1)) and (var116 = 1 or not(var578 =
 1)) and (var118 = 1 or not(var578 = 1)) and (var120 = 1 or not(var578 = 1)) and
 (var121 = 1 or not(var578 = 1)) and (var124 = 1 or not(var578 = 1)) and (var126
 = 1 or not(var578 = 1)) and (var127 = 1 or not(var578 = 1)) and (var129 = 1 or
not(var579 = 1)) and (var132 = 1 or not(var579 = 1)) and (var134 = 1 or not(
var579 = 1)) and (var136 = 1 or not(var579 = 1)) and (var137 = 1 or not(var579 =
 1)) and (var140 = 1 or not(var579 = 1)) and (var142 = 1 or not(var579 = 1)) and
 (var143 = 1 or not(var579 = 1)) and (var145 = 1 or not(var580 = 1)) and (var148
 = 1 or not(var580 = 1)) and (var150 = 1 or not(var580 = 1)) and (var152 = 1 or
not(var580 = 1)) and (var153 = 1 or not(var580 = 1)) and (var156 = 1 or not(
var580 = 1)) and (var158 = 1 or not(var580 = 1)) and (var159 = 1 or not(var580 =
 1)) and (var1 = 1 or not(var581 = 1)) and (var3 = 1 or not(var581 = 1)) and (
var6 = 1 or not(var581 = 1)) and (var8 = 1 or not(var581 = 1)) and (var10 = 1 or
 not(var581 = 1)) and (var11 = 1 or not(var581 = 1)) and (var13 = 1 or not(
var581 = 1)) and (var16 = 1 or not(var581 = 1)) and (var17 = 1 or not(var582 = 1
)) and (var19 = 1 or not(var582 = 1)) and (var22 = 1 or not(var582 = 1)) and (
var24 = 1 or not(var582 = 1)) and (var26 = 1 or not(var582 = 1)) and (var27 = 1
or not(var582 = 1)) and (var29 = 1 or not(var582 = 1)) and (var32 = 1 or not(
var582 = 1)) and (var33 = 1 or not(var583 = 1)) and (var35 = 1 or not(var583 = 1
)) and (var38 = 1 or not(var583 = 1)) and (var40 = 1 or not(var583 = 1)) and (
var42 = 1 or not(var583 = 1)) and (var43 = 1 or not(var583 = 1)) and (var45 = 1
or not(var583 = 1)) and (var48 = 1 or not(var583 = 1)) and (var49 = 1 or not(
var584 = 1)) and (var51 = 1 or not(var584 = 1)) and (var54 = 1 or not(var584 = 1
)) and (var56 = 1 or not(var584 = 1)) and (var58 = 1 or not(var584 = 1)) and (
var59 = 1 or not(var584 = 1)) and (var61 = 1 or not(var584 = 1)) and (var64 = 1
or not(var584 = 1)) and (var65 = 1 or not(var585 = 1)) and (var67 = 1 or not(
var585 = 1)) and (var70 = 1 or not(var585 = 1)) and (var72 = 1 or not(var585 = 1
)) and (var74 = 1 or not(var585 = 1)) and (var75 = 1 or not(var585 = 1)) and (
var77 = 1 or not(var585 = 1)) and (var80 = 1 or not(var585 = 1)) and (var81 = 1
or not(var586 = 1)) and (var83 = 1 or not(var586 = 1)) and (var86 = 1 or not(
var586 = 1)) and (var88 = 1 or not(var586 = 1)) and (var90 = 1 or not(var586 = 1
)) and (var91 = 1 or not(var586 = 1)) and (var93 = 1 or not(var586 = 1)) and (
var96 = 1 or not(var586 = 1)) and (var97 = 1 or not(var587 = 1)) and (var99 = 1
or not(var587 = 1)) and (var102 = 1 or not(var587 = 1)) and (var104 = 1 or not(
var587 = 1)) and (var106 = 1 or not(var587 = 1)) and (var107 = 1 or not(var587 =
 1)) and (var109 = 1 or not(var587 = 1)) and (var112 = 1 or not(var587 = 1)) and
 (var113 = 1 or not(var588 = 1)) and (var115 = 1 or not(var588 = 1)) and (var118
 = 1 or not(var588 = 1)) and (var120 = 1 or not(var588 = 1)) and (var122 = 1 or
not(var588 = 1)) and (var123 = 1 or not(var588 = 1)) and (var125 = 1 or not(
var588 = 1)) and (var128 = 1 or not(var588 = 1)) and (var129 = 1 or not(var589 =
 1)) and (var131 = 1 or not(var589 = 1)) and (var134 = 1 or not(var589 = 1)) and
 (var136 = 1 or not(var589 = 1)) and (var138 = 1 or not(var589 = 1)) and (var139
 = 1 or not(var589 = 1)) and (var141 = 1 or not(var589 = 1)) and (var144 = 1 or
not(var589 = 1)) and (var145 = 1 or not(var590 = 1)) and (var147 = 1 or not(
var590 = 1)) and (var150 = 1 or not(var590 = 1)) and (var152 = 1 or not(var590 =
 1)) and (var154 = 1 or not(var590 = 1)) and (var155 = 1 or not(var590 = 1)) and
 (var157 = 1 or not(var590 = 1)) and (var160 = 1 or not(var590 = 1)) and (var2 =
 1 or not(var591 = 1)) and (var3 = 1 or not(var591 = 1)) and (var5 = 1 or not(
var591 = 1)) and (var7 = 1 or not(var591 = 1)) and (var10 = 1 or not(var591 = 1)
) and (var12 = 1 or not(var591 = 1)) and (var13 = 1 or not(var591 = 1)) and (
var15 = 1 or not(var591 = 1)) and (var18 = 1 or not(var592 = 1)) and (var19 = 1
or not(var592 = 1)) and (var21 = 1 or not(var592 = 1)) and (var23 = 1 or not(
var592 = 1)) and (var26 = 1 or not(var592 = 1)) and (var28 = 1 or not(var592 = 1
)) and (var29 = 1 or not(var592 = 1)) and (var31 = 1 or not(var592 = 1)) and (
var34 = 1 or not(var593 = 1)) and (var35 = 1 or not(var593 = 1)) and (var37 = 1
or not(var593 = 1)) and (var39 = 1 or not(var593 = 1)) and (var42 = 1 or not(
var593 = 1)) and (var44 = 1 or not(var593 = 1)) and (var45 = 1 or not(var593 = 1
)) and (var47 = 1 or not(var593 = 1)) and (var50 = 1 or not(var594 = 1)) and (
var51 = 1 or not(var594 = 1)) and (var53 = 1 or not(var594 = 1)) and (var55 = 1
or not(var594 = 1)) and (var58 = 1 or not(var594 = 1)) and (var60 = 1 or not(
var594 = 1)) and (var61 = 1 or not(var594 = 1)) and (var63 = 1 or not(var594 = 1
)) and (var66 = 1 or not(var595 = 1)) and (var67 = 1 or not(var595 = 1)) and (
var69 = 1 or not(var595 = 1)) and (var71 = 1 or not(var595 = 1)) and (var74 = 1
or not(var595 = 1)) and (var76 = 1 or not(var595 = 1)) and (var77 = 1 or not(
var595 = 1)) and (var79 = 1 or not(var595 = 1)) and (var82 = 1 or not(var596 = 1
)) and (var83 = 1 or not(var596 = 1)) and (var85 = 1 or not(var596 = 1)) and (
var87 = 1 or not(var596 = 1)) and (var90 = 1 or not(var596 = 1)) and (var92 = 1
or not(var596 = 1)) and (var93 = 1 or not(var596 = 1)) and (var95 = 1 or not(
var596 = 1)) and (var98 = 1 or not(var597 = 1)) and (var99 = 1 or not(var597 = 1
)) and (var101 = 1 or not(var597 = 1)) and (var103 = 1 or not(var597 = 1)) and (
var106 = 1 or not(var597 = 1)) and (var108 = 1 or not(var597 = 1)) and (var109 =
 1 or not(var597 = 1)) and (var111 = 1 or not(var597 = 1)) and (var114 = 1 or
not(var598 = 1)) and (var115 = 1 or not(var598 = 1)) and (var117 = 1 or not(
var598 = 1)) and (var119 = 1 or not(var598 = 1)) and (var122 = 1 or not(var598 =
 1)) and (var124 = 1 or not(var598 = 1)) and (var125 = 1 or not(var598 = 1)) and
 (var127 = 1 or not(var598 = 1)) and (var130 = 1 or not(var599 = 1)) and (var131
 = 1 or not(var599 = 1)) and (var133 = 1 or not(var599 = 1)) and (var135 = 1 or
not(var599 = 1)) and (var138 = 1 or not(var599 = 1)) and (var140 = 1 or not(
var599 = 1)) and (var141 = 1 or not(var599 = 1)) and (var143 = 1 or not(var599 =
 1)) and (var146 = 1 or not(var600 = 1)) and (var147 = 1 or not(var600 = 1)) and
 (var149 = 1 or not(var600 = 1)) and (var151 = 1 or not(var600 = 1)) and (var154
 = 1 or not(var600 = 1)) and (var156 = 1 or not(var600 = 1)) and (var157 = 1 or
not(var600 = 1)) and (var159 = 1 or not(var600 = 1)) and (var1 = 1 or not(var601
 = 1)) and (var4 = 1 or not(var601 = 1)) and (var5 = 1 or not(var601 = 1)) and (
var8 = 1 or not(var601 = 1)) and (var10 = 1 or not(var601 = 1)) and (var12 = 1
or not(var601 = 1)) and (var14 = 1 or not(var601 = 1)) and (var15 = 1 or not(
var601 = 1)) and (var17 = 1 or not(var602 = 1)) and (var20 = 1 or not(var602 = 1
)) and (var21 = 1 or not(var602 = 1)) and (var24 = 1 or not(var602 = 1)) and (
var26 = 1 or not(var602 = 1)) and (var28 = 1 or not(var602 = 1)) and (var30 = 1
or not(var602 = 1)) and (var31 = 1 or not(var602 = 1)) and (var33 = 1 or not(
var603 = 1)) and (var36 = 1 or not(var603 = 1)) and (var37 = 1 or not(var603 = 1
)) and (var40 = 1 or not(var603 = 1)) and (var42 = 1 or not(var603 = 1)) and (
var44 = 1 or not(var603 = 1)) and (var46 = 1 or not(var603 = 1)) and (var47 = 1
or not(var603 = 1)) and (var49 = 1 or not(var604 = 1)) and (var52 = 1 or not(
var604 = 1)) and (var53 = 1 or not(var604 = 1)) and (var56 = 1 or not(var604 = 1
)) and (var58 = 1 or not(var604 = 1)) and (var60 = 1 or not(var604 = 1)) and (
var62 = 1 or not(var604 = 1)) and (var63 = 1 or not(var604 = 1)) and (var65 = 1
or not(var605 = 1)) and (var68 = 1 or not(var605 = 1)) and (var69 = 1 or not(
var605 = 1)) and (var72 = 1 or not(var605 = 1)) and (var74 = 1 or not(var605 = 1
)) and (var76 = 1 or not(var605 = 1)) and (var78 = 1 or not(var605 = 1)) and (
var79 = 1 or not(var605 = 1)) and (var81 = 1 or not(var606 = 1)) and (var84 = 1
or not(var606 = 1)) and (var85 = 1 or not(var606 = 1)) and (var88 = 1 or not(
var606 = 1)) and (var90 = 1 or not(var606 = 1)) and (var92 = 1 or not(var606 = 1
)) and (var94 = 1 or not(var606 = 1)) and (var95 = 1 or not(var606 = 1)) and (
var97 = 1 or not(var607 = 1)) and (var100 = 1 or not(var607 = 1)) and (var101 =
1 or not(var607 = 1)) and (var104 = 1 or not(var607 = 1)) and (var106 = 1 or not
(var607 = 1)) and (var108 = 1 or not(var607 = 1)) and (var110 = 1 or not(var607
= 1)) and (var111 = 1 or not(var607 = 1)) and (var113 = 1 or not(var608 = 1))
and (var116 = 1 or not(var608 = 1)) and (var117 = 1 or not(var608 = 1)) and (
var120 = 1 or not(var608 = 1)) and (var122 = 1 or not(var608 = 1)) and (var124 =
 1 or not(var608 = 1)) and (var126 = 1 or not(var608 = 1)) and (var127 = 1 or
not(var608 = 1)) and (var129 = 1 or not(var609 = 1)) and (var132 = 1 or not(
var609 = 1)) and (var133 = 1 or not(var609 = 1)) and (var136 = 1 or not(var609 =
 1)) and (var138 = 1 or not(var609 = 1)) and (var140 = 1 or not(var609 = 1)) and
 (var142 = 1 or not(var609 = 1)) and (var143 = 1 or not(var609 = 1)) and (var145
 = 1 or not(var610 = 1)) and (var148 = 1 or not(var610 = 1)) and (var149 = 1 or
not(var610 = 1)) and (var152 = 1 or not(var610 = 1)) and (var154 = 1 or not(
var610 = 1)) and (var156 = 1 or not(var610 = 1)) and (var158 = 1 or not(var610 =
 1)) and (var159 = 1 or not(var610 = 1)) and (var1 = 1 or not(var611 = 1)) and (
var4 = 1 or not(var611 = 1)) and (var5 = 1 or not(var611 = 1)) and (var7 = 1 or
not(var611 = 1)) and (var10 = 1 or not(var611 = 1)) and (var11 = 1 or not(var611
 = 1)) and (var14 = 1 or not(var611 = 1)) and (var15 = 1 or not(var611 = 1)) and
 (var17 = 1 or not(var612 = 1)) and (var20 = 1 or not(var612 = 1)) and (var21 =
1 or not(var612 = 1)) and (var23 = 1 or not(var612 = 1)) and (var26 = 1 or not(
var612 = 1)) and (var27 = 1 or not(var612 = 1)) and (var30 = 1 or not(var612 = 1
)) and (var31 = 1 or not(var612 = 1)) and (var33 = 1 or not(var613 = 1)) and (
var36 = 1 or not(var613 = 1)) and (var37 = 1 or not(var613 = 1)) and (var39 = 1
or not(var613 = 1)) and (var42 = 1 or not(var613 = 1)) and (var43 = 1 or not(
var613 = 1)) and (var46 = 1 or not(var613 = 1)) and (var47 = 1 or not(var613 = 1
)) and (var49 = 1 or not(var614 = 1)) and (var52 = 1 or not(var614 = 1)) and (
var53 = 1 or not(var614 = 1)) and (var55 = 1 or not(var614 = 1)) and (var58 = 1
or not(var614 = 1)) and (var59 = 1 or not(var614 = 1)) and (var62 = 1 or not(
var614 = 1)) and (var63 = 1 or not(var614 = 1)) and (var65 = 1 or not(var615 = 1
)) and (var68 = 1 or not(var615 = 1)) and (var69 = 1 or not(var615 = 1)) and (
var71 = 1 or not(var615 = 1)) and (var74 = 1 or not(var615 = 1)) and (var75 = 1
or not(var615 = 1)) and (var78 = 1 or not(var615 = 1)) and (var79 = 1 or not(
var615 = 1)) and (var81 = 1 or not(var616 = 1)) and (var84 = 1 or not(var616 = 1
)) and (var85 = 1 or not(var616 = 1)) and (var87 = 1 or not(var616 = 1)) and (
var90 = 1 or not(var616 = 1)) and (var91 = 1 or not(var616 = 1)) and (var94 = 1
or not(var616 = 1)) and (var95 = 1 or not(var616 = 1)) and (var97 = 1 or not(
var617 = 1)) and (var100 = 1 or not(var617 = 1)) and (var101 = 1 or not(var617 =
 1)) and (var103 = 1 or not(var617 = 1)) and (var106 = 1 or not(var617 = 1)) and
 (var107 = 1 or not(var617 = 1)) and (var110 = 1 or not(var617 = 1)) and (var111
 = 1 or not(var617 = 1)) and (var113 = 1 or not(var618 = 1)) and (var116 = 1 or
not(var618 = 1)) and (var117 = 1 or not(var618 = 1)) and (var119 = 1 or not(
var618 = 1)) and (var122 = 1 or not(var618 = 1)) and (var123 = 1 or not(var618 =
 1)) and (var126 = 1 or not(var618 = 1)) and (var127 = 1 or not(var618 = 1)) and
 (var129 = 1 or not(var619 = 1)) and (var132 = 1 or not(var619 = 1)) and (var133
 = 1 or not(var619 = 1)) and (var135 = 1 or not(var619 = 1)) and (var138 = 1 or
not(var619 = 1)) and (var139 = 1 or not(var619 = 1)) and (var142 = 1 or not(
var619 = 1)) and (var143 = 1 or not(var619 = 1)) and (var145 = 1 or not(var620 =
 1)) and (var148 = 1 or not(var620 = 1)) and (var149 = 1 or not(var620 = 1)) and
 (var151 = 1 or not(var620 = 1)) and (var154 = 1 or not(var620 = 1)) and (var155
 = 1 or not(var620 = 1)) and (var158 = 1 or not(var620 = 1)) and (var159 = 1 or
not(var620 = 1)) and (var1 = 1 or not(var621 = 1)) and (var3 = 1 or not(var621 =
 1)) and (var5 = 1 or not(var621 = 1)) and (var7 = 1 or not(var621 = 1)) and (
var9 = 1 or not(var621 = 1)) and (var12 = 1 or not(var621 = 1)) and (var14 = 1
or not(var621 = 1)) and (var16 = 1 or not(var621 = 1)) and (var17 = 1 or not(
var622 = 1)) and (var19 = 1 or not(var622 = 1)) and (var21 = 1 or not(var622 = 1
)) and (var23 = 1 or not(var622 = 1)) and (var25 = 1 or not(var622 = 1)) and (
var28 = 1 or not(var622 = 1)) and (var30 = 1 or not(var622 = 1)) and (var32 = 1
or not(var622 = 1)) and (var33 = 1 or not(var623 = 1)) and (var35 = 1 or not(
var623 = 1)) and (var37 = 1 or not(var623 = 1)) and (var39 = 1 or not(var623 = 1
)) and (var41 = 1 or not(var623 = 1)) and (var44 = 1 or not(var623 = 1)) and (
var46 = 1 or not(var623 = 1)) and (var48 = 1 or not(var623 = 1)) and (var49 = 1
or not(var624 = 1)) and (var51 = 1 or not(var624 = 1)) and (var53 = 1 or not(
var624 = 1)) and (var55 = 1 or not(var624 = 1)) and (var57 = 1 or not(var624 = 1
)) and (var60 = 1 or not(var624 = 1)) and (var62 = 1 or not(var624 = 1)) and (
var64 = 1 or not(var624 = 1)) and (var65 = 1 or not(var625 = 1)) and (var67 = 1
or not(var625 = 1)) and (var69 = 1 or not(var625 = 1)) and (var71 = 1 or not(
var625 = 1)) and (var73 = 1 or not(var625 = 1)) and (var76 = 1 or not(var625 = 1
)) and (var78 = 1 or not(var625 = 1)) and (var80 = 1 or not(var625 = 1)) and (
var81 = 1 or not(var626 = 1)) and (var83 = 1 or not(var626 = 1)) and (var85 = 1
or not(var626 = 1)) and (var87 = 1 or not(var626 = 1)) and (var89 = 1 or not(
var626 = 1)) and (var92 = 1 or not(var626 = 1)) and (var94 = 1 or not(var626 = 1
)) and (var96 = 1 or not(var626 = 1)) and (var97 = 1 or not(var627 = 1)) and (
var99 = 1 or not(var627 = 1)) and (var101 = 1 or not(var627 = 1)) and (var103 =
1 or not(var627 = 1)) and (var105 = 1 or not(var627 = 1)) and (var108 = 1 or not
(var627 = 1)) and (var110 = 1 or not(var627 = 1)) and (var112 = 1 or not(var627
= 1)) and (var113 = 1 or not(var628 = 1)) and (var115 = 1 or not(var628 = 1))
and (var117 = 1 or not(var628 = 1)) and (var119 = 1 or not(var628 = 1)) and (
var121 = 1 or not(var628 = 1)) and (var124 = 1 or not(var628 = 1)) and (var126 =
 1 or not(var628 = 1)) and (var128 = 1 or not(var628 = 1)) and (var129 = 1 or
not(var629 = 1)) and (var131 = 1 or not(var629 = 1)) and (var133 = 1 or not(
var629 = 1)) and (var135 = 1 or not(var629 = 1)) and (var137 = 1 or not(var629 =
 1)) and (var140 = 1 or not(var629 = 1)) and (var142 = 1 or not(var629 = 1)) and
 (var144 = 1 or not(var629 = 1)) and (var145 = 1 or not(var630 = 1)) and (var147
 = 1 or not(var630 = 1)) and (var149 = 1 or not(var630 = 1)) and (var151 = 1 or
not(var630 = 1)) and (var153 = 1 or not(var630 = 1)) and (var156 = 1 or not(
var630 = 1)) and (var158 = 1 or not(var630 = 1)) and (var160 = 1 or not(var630 =
 1)) and (var1 = 1 or not(var631 = 1)) and (var4 = 1 or not(var631 = 1)) and (
var5 = 1 or not(var631 = 1)) and (var7 = 1 or not(var631 = 1)) and (var10 = 1 or
 not(var631 = 1)) and (var12 = 1 or not(var631 = 1)) and (var14 = 1 or not(
var631 = 1)) and (var15 = 1 or not(var631 = 1)) and (var17 = 1 or not(var632 = 1
)) and (var20 = 1 or not(var632 = 1)) and (var21 = 1 or not(var632 = 1)) and (
var23 = 1 or not(var632 = 1)) and (var26 = 1 or not(var632 = 1)) and (var28 = 1
or not(var632 = 1)) and (var30 = 1 or not(var632 = 1)) and (var31 = 1 or not(
var632 = 1)) and (var33 = 1 or not(var633 = 1)) and (var36 = 1 or not(var633 = 1
)) and (var37 = 1 or not(var633 = 1)) and (var39 = 1 or not(var633 = 1)) and (
var42 = 1 or not(var633 = 1)) and (var44 = 1 or not(var633 = 1)) and (var46 = 1
or not(var633 = 1)) and (var47 = 1 or not(var633 = 1)) and (var49 = 1 or not(
var634 = 1)) and (var52 = 1 or not(var634 = 1)) and (var53 = 1 or not(var634 = 1
)) and (var55 = 1 or not(var634 = 1)) and (var58 = 1 or not(var634 = 1)) and (
var60 = 1 or not(var634 = 1)) and (var62 = 1 or not(var634 = 1)) and (var63 = 1
or not(var634 = 1)) and (var65 = 1 or not(var635 = 1)) and (var68 = 1 or not(
var635 = 1)) and (var69 = 1 or not(var635 = 1)) and (var71 = 1 or not(var635 = 1
)) and (var74 = 1 or not(var635 = 1)) and (var76 = 1 or not(var635 = 1)) and (
var78 = 1 or not(var635 = 1)) and (var79 = 1 or not(var635 = 1)) and (var81 = 1
or not(var636 = 1)) and (var84 = 1 or not(var636 = 1)) and (var85 = 1 or not(
var636 = 1)) and (var87 = 1 or not(var636 = 1)) and (var90 = 1 or not(var636 = 1
)) and (var92 = 1 or not(var636 = 1)) and (var94 = 1 or not(var636 = 1)) and (
var95 = 1 or not(var636 = 1)) and (var97 = 1 or not(var637 = 1)) and (var100 = 1
 or not(var637 = 1)) and (var101 = 1 or not(var637 = 1)) and (var103 = 1 or not(
var637 = 1)) and (var106 = 1 or not(var637 = 1)) and (var108 = 1 or not(var637 =
 1)) and (var110 = 1 or not(var637 = 1)) and (var111 = 1 or not(var637 = 1)) and
 (var113 = 1 or not(var638 = 1)) and (var116 = 1 or not(var638 = 1)) and (var117
 = 1 or not(var638 = 1)) and (var119 = 1 or not(var638 = 1)) and (var122 = 1 or
not(var638 = 1)) and (var124 = 1 or not(var638 = 1)) and (var126 = 1 or not(
var638 = 1)) and (var127 = 1 or not(var638 = 1)) and (var129 = 1 or not(var639 =
 1)) and (var132 = 1 or not(var639 = 1)) and (var133 = 1 or not(var639 = 1)) and
 (var135 = 1 or not(var639 = 1)) and (var138 = 1 or not(var639 = 1)) and (var140
 = 1 or not(var639 = 1)) and (var142 = 1 or not(var639 = 1)) and (var143 = 1 or
not(var639 = 1)) and (var145 = 1 or not(var640 = 1)) and (var148 = 1 or not(
var640 = 1)) and (var149 = 1 or not(var640 = 1)) and (var151 = 1 or not(var640 =
 1)) and (var154 = 1 or not(var640 = 1)) and (var156 = 1 or not(var640 = 1)) and
 (var158 = 1 or not(var640 = 1)) and (var159 = 1 or not(var640 = 1)) and (var1 =
 1 or not(var641 = 1)) and (var3 = 1 or not(var641 = 1)) and (var6 = 1 or not(
var641 = 1)) and (var8 = 1 or not(var641 = 1)) and (var9 = 1 or not(var641 = 1))
 and (var12 = 1 or not(var641 = 1)) and (var14 = 1 or not(var641 = 1)) and (
var15 = 1 or not(var641 = 1)) and (var17 = 1 or not(var642 = 1)) and (var19 = 1
or not(var642 = 1)) and (var22 = 1 or not(var642 = 1)) and (var24 = 1 or not(
var642 = 1)) and (var25 = 1 or not(var642 = 1)) and (var28 = 1 or not(var642 = 1
)) and (var30 = 1 or not(var642 = 1)) and (var31 = 1 or not(var642 = 1)) and (
var33 = 1 or not(var643 = 1)) and (var35 = 1 or not(var643 = 1)) and (var38 = 1
or not(var643 = 1)) and (var40 = 1 or not(var643 = 1)) and (var41 = 1 or not(
var643 = 1)) and (var44 = 1 or not(var643 = 1)) and (var46 = 1 or not(var643 = 1
)) and (var47 = 1 or not(var643 = 1)) and (var49 = 1 or not(var644 = 1)) and (
var51 = 1 or not(var644 = 1)) and (var54 = 1 or not(var644 = 1)) and (var56 = 1
or not(var644 = 1)) and (var57 = 1 or not(var644 = 1)) and (var60 = 1 or not(
var644 = 1)) and (var62 = 1 or not(var644 = 1)) and (var63 = 1 or not(var644 = 1
)) and (var65 = 1 or not(var645 = 1)) and (var67 = 1 or not(var645 = 1)) and (
var70 = 1 or not(var645 = 1)) and (var72 = 1 or not(var645 = 1)) and (var73 = 1
or not(var645 = 1)) and (var76 = 1 or not(var645 = 1)) and (var78 = 1 or not(
var645 = 1)) and (var79 = 1 or not(var645 = 1)) and (var81 = 1 or not(var646 = 1
)) and (var83 = 1 or not(var646 = 1)) and (var86 = 1 or not(var646 = 1)) and (
var88 = 1 or not(var646 = 1)) and (var89 = 1 or not(var646 = 1)) and (var92 = 1
or not(var646 = 1)) and (var94 = 1 or not(var646 = 1)) and (var95 = 1 or not(
var646 = 1)) and (var97 = 1 or not(var647 = 1)) and (var99 = 1 or not(var647 = 1
)) and (var102 = 1 or not(var647 = 1)) and (var104 = 1 or not(var647 = 1)) and (
var105 = 1 or not(var647 = 1)) and (var108 = 1 or not(var647 = 1)) and (var110 =
 1 or not(var647 = 1)) and (var111 = 1 or not(var647 = 1)) and (var113 = 1 or
not(var648 = 1)) and (var115 = 1 or not(var648 = 1)) and (var118 = 1 or not(
var648 = 1)) and (var120 = 1 or not(var648 = 1)) and (var121 = 1 or not(var648 =
 1)) and (var124 = 1 or not(var648 = 1)) and (var126 = 1 or not(var648 = 1)) and
 (var127 = 1 or not(var648 = 1)) and (var129 = 1 or not(var649 = 1)) and (var131
 = 1 or not(var649 = 1)) and (var134 = 1 or not(var649 = 1)) and (var136 = 1 or
not(var649 = 1)) and (var137 = 1 or not(var649 = 1)) and (var140 = 1 or not(
var649 = 1)) and (var142 = 1 or not(var649 = 1)) and (var143 = 1 or not(var649 =
 1)) and (var145 = 1 or not(var650 = 1)) and (var147 = 1 or not(var650 = 1)) and
 (var150 = 1 or not(var650 = 1)) and (var152 = 1 or not(var650 = 1)) and (var153
 = 1 or not(var650 = 1)) and (var156 = 1 or not(var650 = 1)) and (var158 = 1 or
not(var650 = 1)) and (var159 = 1 or not(var650 = 1)) and (var2 = 1 or not(var651
 = 1)) and (var4 = 1 or not(var651 = 1)) and (var6 = 1 or not(var651 = 1)) and (
var8 = 1 or not(var651 = 1)) and (var10 = 1 or not(var651 = 1)) and (var11 = 1
or not(var651 = 1)) and (var13 = 1 or not(var651 = 1)) and (var16 = 1 or not(
var651 = 1)) and (var18 = 1 or not(var652 = 1)) and (var20 = 1 or not(var652 = 1
)) and (var22 = 1 or not(var652 = 1)) and (var24 = 1 or not(var652 = 1)) and (
var26 = 1 or not(var652 = 1)) and (var27 = 1 or not(var652 = 1)) and (var29 = 1
or not(var652 = 1)) and (var32 = 1 or not(var652 = 1)) and (var34 = 1 or not(
var653 = 1)) and (var36 = 1 or not(var653 = 1)) and (var38 = 1 or not(var653 = 1
)) and (var40 = 1 or not(var653 = 1)) and (var42 = 1 or not(var653 = 1)) and (
var43 = 1 or not(var653 = 1)) and (var45 = 1 or not(var653 = 1)) and (var48 = 1
or not(var653 = 1)) and (var50 = 1 or not(var654 = 1)) and (var52 = 1 or not(
var654 = 1)) and (var54 = 1 or not(var654 = 1)) and (var56 = 1 or not(var654 = 1
)) and (var58 = 1 or not(var654 = 1)) and (var59 = 1 or not(var654 = 1)) and (
var61 = 1 or not(var654 = 1)) and (var64 = 1 or not(var654 = 1)) and (var66 = 1
or not(var655 = 1)) and (var68 = 1 or not(var655 = 1)) and (var70 = 1 or not(
var655 = 1)) and (var72 = 1 or not(var655 = 1)) and (var74 = 1 or not(var655 = 1
)) and (var75 = 1 or not(var655 = 1)) and (var77 = 1 or not(var655 = 1)) and (
var80 = 1 or not(var655 = 1)) and (var82 = 1 or not(var656 = 1)) and (var84 = 1
or not(var656 = 1)) and (var86 = 1 or not(var656 = 1)) and (var88 = 1 or not(
var656 = 1)) and (var90 = 1 or not(var656 = 1)) and (var91 = 1 or not(var656 = 1
)) and (var93 = 1 or not(var656 = 1)) and (var96 = 1 or not(var656 = 1)) and (
var98 = 1 or not(var657 = 1)) and (var100 = 1 or not(var657 = 1)) and (var102 =
1 or not(var657 = 1)) and (var104 = 1 or not(var657 = 1)) and (var106 = 1 or not
(var657 = 1)) and (var107 = 1 or not(var657 = 1)) and (var109 = 1 or not(var657
= 1)) and (var112 = 1 or not(var657 = 1)) and (var114 = 1 or not(var658 = 1))
and (var116 = 1 or not(var658 = 1)) and (var118 = 1 or not(var658 = 1)) and (
var120 = 1 or not(var658 = 1)) and (var122 = 1 or not(var658 = 1)) and (var123 =
 1 or not(var658 = 1)) and (var125 = 1 or not(var658 = 1)) and (var128 = 1 or
not(var658 = 1)) and (var130 = 1 or not(var659 = 1)) and (var132 = 1 or not(
var659 = 1)) and (var134 = 1 or not(var659 = 1)) and (var136 = 1 or not(var659 =
 1)) and (var138 = 1 or not(var659 = 1)) and (var139 = 1 or not(var659 = 1)) and
 (var141 = 1 or not(var659 = 1)) and (var144 = 1 or not(var659 = 1)) and (var146
 = 1 or not(var660 = 1)) and (var148 = 1 or not(var660 = 1)) and (var150 = 1 or
not(var660 = 1)) and (var152 = 1 or not(var660 = 1)) and (var154 = 1 or not(
var660 = 1)) and (var155 = 1 or not(var660 = 1)) and (var157 = 1 or not(var660 =
 1)) and (var160 = 1 or not(var660 = 1)) and (var2 = 1 or not(var661 = 1)) and (
var3 = 1 or not(var661 = 1)) and (var6 = 1 or not(var661 = 1)) and (var7 = 1 or
not(var661 = 1)) and (var9 = 1 or not(var661 = 1)) and (var12 = 1 or not(var661
= 1)) and (var14 = 1 or not(var661 = 1)) and (var16 = 1 or not(var661 = 1)) and
(var18 = 1 or not(var662 = 1)) and (var19 = 1 or not(var662 = 1)) and (var22 = 1
 or not(var662 = 1)) and (var23 = 1 or not(var662 = 1)) and (var25 = 1 or not(
var662 = 1)) and (var28 = 1 or not(var662 = 1)) and (var30 = 1 or not(var662 = 1
)) and (var32 = 1 or not(var662 = 1)) and (var34 = 1 or not(var663 = 1)) and (
var35 = 1 or not(var663 = 1)) and (var38 = 1 or not(var663 = 1)) and (var39 = 1
or not(var663 = 1)) and (var41 = 1 or not(var663 = 1)) and (var44 = 1 or not(
var663 = 1)) and (var46 = 1 or not(var663 = 1)) and (var48 = 1 or not(var663 = 1
)) and (var50 = 1 or not(var664 = 1)) and (var51 = 1 or not(var664 = 1)) and (
var54 = 1 or not(var664 = 1)) and (var55 = 1 or not(var664 = 1)) and (var57 = 1
or not(var664 = 1)) and (var60 = 1 or not(var664 = 1)) and (var62 = 1 or not(
var664 = 1)) and (var64 = 1 or not(var664 = 1)) and (var66 = 1 or not(var665 = 1
)) and (var67 = 1 or not(var665 = 1)) and (var70 = 1 or not(var665 = 1)) and (
var71 = 1 or not(var665 = 1)) and (var73 = 1 or not(var665 = 1)) and (var76 = 1
or not(var665 = 1)) and (var78 = 1 or not(var665 = 1)) and (var80 = 1 or not(
var665 = 1)) and (var82 = 1 or not(var666 = 1)) and (var83 = 1 or not(var666 = 1
)) and (var86 = 1 or not(var666 = 1)) and (var87 = 1 or not(var666 = 1)) and (
var89 = 1 or not(var666 = 1)) and (var92 = 1 or not(var666 = 1)) and (var94 = 1
or not(var666 = 1)) and (var96 = 1 or not(var666 = 1)) and (var98 = 1 or not(
var667 = 1)) and (var99 = 1 or not(var667 = 1)) and (var102 = 1 or not(var667 =
1)) and (var103 = 1 or not(var667 = 1)) and (var105 = 1 or not(var667 = 1)) and
(var108 = 1 or not(var667 = 1)) and (var110 = 1 or not(var667 = 1)) and (var112
= 1 or not(var667 = 1)) and (var114 = 1 or not(var668 = 1)) and (var115 = 1 or
not(var668 = 1)) and (var118 = 1 or not(var668 = 1)) and (var119 = 1 or not(
var668 = 1)) and (var121 = 1 or not(var668 = 1)) and (var124 = 1 or not(var668 =
 1)) and (var126 = 1 or not(var668 = 1)) and (var128 = 1 or not(var668 = 1)) and
 (var130 = 1 or not(var669 = 1)) and (var131 = 1 or not(var669 = 1)) and (var134
 = 1 or not(var669 = 1)) and (var135 = 1 or not(var669 = 1)) and (var137 = 1 or
not(var669 = 1)) and (var140 = 1 or not(var669 = 1)) and (var142 = 1 or not(
var669 = 1)) and (var144 = 1 or not(var669 = 1)) and (var146 = 1 or not(var670 =
 1)) and (var147 = 1 or not(var670 = 1)) and (var150 = 1 or not(var670 = 1)) and
 (var151 = 1 or not(var670 = 1)) and (var153 = 1 or not(var670 = 1)) and (var156
 = 1 or not(var670 = 1)) and (var158 = 1 or not(var670 = 1)) and (var160 = 1 or
not(var670 = 1)) and (var1 = 1 or not(var671 = 1)) and (var3 = 1 or not(var671 =
 1)) and (var6 = 1 or not(var671 = 1)) and (var8 = 1 or not(var671 = 1)) and (
var10 = 1 or not(var671 = 1)) and (var12 = 1 or not(var671 = 1)) and (var13 = 1
or not(var671 = 1)) and (var16 = 1 or not(var671 = 1)) and (var17 = 1 or not(
var672 = 1)) and (var19 = 1 or not(var672 = 1)) and (var22 = 1 or not(var672 = 1
)) and (var24 = 1 or not(var672 = 1)) and (var26 = 1 or not(var672 = 1)) and (
var28 = 1 or not(var672 = 1)) and (var29 = 1 or not(var672 = 1)) and (var32 = 1
or not(var672 = 1)) and (var33 = 1 or not(var673 = 1)) and (var35 = 1 or not(
var673 = 1)) and (var38 = 1 or not(var673 = 1)) and (var40 = 1 or not(var673 = 1
)) and (var42 = 1 or not(var673 = 1)) and (var44 = 1 or not(var673 = 1)) and (
var45 = 1 or not(var673 = 1)) and (var48 = 1 or not(var673 = 1)) and (var49 = 1
or not(var674 = 1)) and (var51 = 1 or not(var674 = 1)) and (var54 = 1 or not(
var674 = 1)) and (var56 = 1 or not(var674 = 1)) and (var58 = 1 or not(var674 = 1
)) and (var60 = 1 or not(var674 = 1)) and (var61 = 1 or not(var674 = 1)) and (
var64 = 1 or not(var674 = 1)) and (var65 = 1 or not(var675 = 1)) and (var67 = 1
or not(var675 = 1)) and (var70 = 1 or not(var675 = 1)) and (var72 = 1 or not(
var675 = 1)) and (var74 = 1 or not(var675 = 1)) and (var76 = 1 or not(var675 = 1
)) and (var77 = 1 or not(var675 = 1)) and (var80 = 1 or not(var675 = 1)) and (
var81 = 1 or not(var676 = 1)) and (var83 = 1 or not(var676 = 1)) and (var86 = 1
or not(var676 = 1)) and (var88 = 1 or not(var676 = 1)) and (var90 = 1 or not(
var676 = 1)) and (var92 = 1 or not(var676 = 1)) and (var93 = 1 or not(var676 = 1
)) and (var96 = 1 or not(var676 = 1)) and (var97 = 1 or not(var677 = 1)) and (
var99 = 1 or not(var677 = 1)) and (var102 = 1 or not(var677 = 1)) and (var104 =
1 or not(var677 = 1)) and (var106 = 1 or not(var677 = 1)) and (var108 = 1 or not
(var677 = 1)) and (var109 = 1 or not(var677 = 1)) and (var112 = 1 or not(var677
= 1)) and (var113 = 1 or not(var678 = 1)) and (var115 = 1 or not(var678 = 1))
and (var118 = 1 or not(var678 = 1)) and (var120 = 1 or not(var678 = 1)) and (
var122 = 1 or not(var678 = 1)) and (var124 = 1 or not(var678 = 1)) and (var125 =
 1 or not(var678 = 1)) and (var128 = 1 or not(var678 = 1)) and (var129 = 1 or
not(var679 = 1)) and (var131 = 1 or not(var679 = 1)) and (var134 = 1 or not(
var679 = 1)) and (var136 = 1 or not(var679 = 1)) and (var138 = 1 or not(var679 =
 1)) and (var140 = 1 or not(var679 = 1)) and (var141 = 1 or not(var679 = 1)) and
 (var144 = 1 or not(var679 = 1)) and (var145 = 1 or not(var680 = 1)) and (var147
 = 1 or not(var680 = 1)) and (var150 = 1 or not(var680 = 1)) and (var152 = 1 or
not(var680 = 1)) and (var154 = 1 or not(var680 = 1)) and (var156 = 1 or not(
var680 = 1)) and (var157 = 1 or not(var680 = 1)) and (var160 = 1 or not(var680 =
 1)) and (var1 = 1 or not(var681 = 1)) and (var4 = 1 or not(var681 = 1)) and (
var5 = 1 or not(var681 = 1)) and (var8 = 1 or not(var681 = 1)) and (var10 = 1 or
 not(var681 = 1)) and (var12 = 1 or not(var681 = 1)) and (var13 = 1 or not(
var681 = 1)) and (var15 = 1 or not(var681 = 1)) and (var17 = 1 or not(var682 = 1
)) and (var20 = 1 or not(var682 = 1)) and (var21 = 1 or not(var682 = 1)) and (
var24 = 1 or not(var682 = 1)) and (var26 = 1 or not(var682 = 1)) and (var28 = 1
or not(var682 = 1)) and (var29 = 1 or not(var682 = 1)) and (var31 = 1 or not(
var682 = 1)) and (var33 = 1 or not(var683 = 1)) and (var36 = 1 or not(var683 = 1
)) and (var37 = 1 or not(var683 = 1)) and (var40 = 1 or not(var683 = 1)) and (
var42 = 1 or not(var683 = 1)) and (var44 = 1 or not(var683 = 1)) and (var45 = 1
or not(var683 = 1)) and (var47 = 1 or not(var683 = 1)) and (var49 = 1 or not(
var684 = 1)) and (var52 = 1 or not(var684 = 1)) and (var53 = 1 or not(var684 = 1
)) and (var56 = 1 or not(var684 = 1)) and (var58 = 1 or not(var684 = 1)) and (
var60 = 1 or not(var684 = 1)) and (var61 = 1 or not(var684 = 1)) and (var63 = 1
or not(var684 = 1)) and (var65 = 1 or not(var685 = 1)) and (var68 = 1 or not(
var685 = 1)) and (var69 = 1 or not(var685 = 1)) and (var72 = 1 or not(var685 = 1
)) and (var74 = 1 or not(var685 = 1)) and (var76 = 1 or not(var685 = 1)) and (
var77 = 1 or not(var685 = 1)) and (var79 = 1 or not(var685 = 1)) and (var81 = 1
or not(var686 = 1)) and (var84 = 1 or not(var686 = 1)) and (var85 = 1 or not(
var686 = 1)) and (var88 = 1 or not(var686 = 1)) and (var90 = 1 or not(var686 = 1
)) and (var92 = 1 or not(var686 = 1)) and (var93 = 1 or not(var686 = 1)) and (
var95 = 1 or not(var686 = 1)) and (var97 = 1 or not(var687 = 1)) and (var100 = 1
 or not(var687 = 1)) and (var101 = 1 or not(var687 = 1)) and (var104 = 1 or not(
var687 = 1)) and (var106 = 1 or not(var687 = 1)) and (var108 = 1 or not(var687 =
 1)) and (var109 = 1 or not(var687 = 1)) and (var111 = 1 or not(var687 = 1)) and
 (var113 = 1 or not(var688 = 1)) and (var116 = 1 or not(var688 = 1)) and (var117
 = 1 or not(var688 = 1)) and (var120 = 1 or not(var688 = 1)) and (var122 = 1 or
not(var688 = 1)) and (var124 = 1 or not(var688 = 1)) and (var125 = 1 or not(
var688 = 1)) and (var127 = 1 or not(var688 = 1)) and (var129 = 1 or not(var689 =
 1)) and (var132 = 1 or not(var689 = 1)) and (var133 = 1 or not(var689 = 1)) and
 (var136 = 1 or not(var689 = 1)) and (var138 = 1 or not(var689 = 1)) and (var140
 = 1 or not(var689 = 1)) and (var141 = 1 or not(var689 = 1)) and (var143 = 1 or
not(var689 = 1)) and (var145 = 1 or not(var690 = 1)) and (var148 = 1 or not(
var690 = 1)) and (var149 = 1 or not(var690 = 1)) and (var152 = 1 or not(var690 =
 1)) and (var154 = 1 or not(var690 = 1)) and (var156 = 1 or not(var690 = 1)) and
 (var157 = 1 or not(var690 = 1)) and (var159 = 1 or not(var690 = 1)) and (var2 =
 1 or not(var691 = 1)) and (var3 = 1 or not(var691 = 1)) and (var5 = 1 or not(
var691 = 1)) and (var8 = 1 or not(var691 = 1)) and (var10 = 1 or not(var691 = 1)
) and (var12 = 1 or not(var691 = 1)) and (var14 = 1 or not(var691 = 1)) and (
var15 = 1 or not(var691 = 1)) and (var18 = 1 or not(var692 = 1)) and (var19 = 1
or not(var692 = 1)) and (var21 = 1 or not(var692 = 1)) and (var24 = 1 or not(
var692 = 1)) and (var26 = 1 or not(var692 = 1)) and (var28 = 1 or not(var692 = 1
)) and (var30 = 1 or not(var692 = 1)) and (var31 = 1 or not(var692 = 1)) and (
var34 = 1 or not(var693 = 1)) and (var35 = 1 or not(var693 = 1)) and (var37 = 1
or not(var693 = 1)) and (var40 = 1 or not(var693 = 1)) and (var42 = 1 or not(
var693 = 1)) and (var44 = 1 or not(var693 = 1)) and (var46 = 1 or not(var693 = 1
)) and (var47 = 1 or not(var693 = 1)) and (var50 = 1 or not(var694 = 1)) and (
var51 = 1 or not(var694 = 1)) and (var53 = 1 or not(var694 = 1)) and (var56 = 1
or not(var694 = 1)) and (var58 = 1 or not(var694 = 1)) and (var60 = 1 or not(
var694 = 1)) and (var62 = 1 or not(var694 = 1)) and (var63 = 1 or not(var694 = 1
)) and (var66 = 1 or not(var695 = 1)) and (var67 = 1 or not(var695 = 1)) and (
var69 = 1 or not(var695 = 1)) and (var72 = 1 or not(var695 = 1)) and (var74 = 1
or not(var695 = 1)) and (var76 = 1 or not(var695 = 1)) and (var78 = 1 or not(
var695 = 1)) and (var79 = 1 or not(var695 = 1)) and (var82 = 1 or not(var696 = 1
)) and (var83 = 1 or not(var696 = 1)) and (var85 = 1 or not(var696 = 1)) and (
var88 = 1 or not(var696 = 1)) and (var90 = 1 or not(var696 = 1)) and (var92 = 1
or not(var696 = 1)) and (var94 = 1 or not(var696 = 1)) and (var95 = 1 or not(
var696 = 1)) and (var98 = 1 or not(var697 = 1)) and (var99 = 1 or not(var697 = 1
)) and (var101 = 1 or not(var697 = 1)) and (var104 = 1 or not(var697 = 1)) and (
var106 = 1 or not(var697 = 1)) and (var108 = 1 or not(var697 = 1)) and (var110 =
 1 or not(var697 = 1)) and (var111 = 1 or not(var697 = 1)) and (var114 = 1 or
not(var698 = 1)) and (var115 = 1 or not(var698 = 1)) and (var117 = 1 or not(
var698 = 1)) and (var120 = 1 or not(var698 = 1)) and (var122 = 1 or not(var698 =
 1)) and (var124 = 1 or not(var698 = 1)) and (var126 = 1 or not(var698 = 1)) and
 (var127 = 1 or not(var698 = 1)) and (var130 = 1 or not(var699 = 1)) and (var131
 = 1 or not(var699 = 1)) and (var133 = 1 or not(var699 = 1)) and (var136 = 1 or
not(var699 = 1)) and (var138 = 1 or not(var699 = 1)) and (var140 = 1 or not(
var699 = 1)) and (var142 = 1 or not(var699 = 1)) and (var143 = 1 or not(var699 =
 1)) and (var146 = 1 or not(var700 = 1)) and (var147 = 1 or not(var700 = 1)) and
 (var149 = 1 or not(var700 = 1)) and (var152 = 1 or not(var700 = 1)) and (var154
 = 1 or not(var700 = 1)) and (var156 = 1 or not(var700 = 1)) and (var158 = 1 or
not(var700 = 1)) and (var159 = 1 or not(var700 = 1)) and (var2 = 1 or not(var701
 = 1)) and (var4 = 1 or not(var701 = 1)) and (var5 = 1 or not(var701 = 1)) and (
var8 = 1 or not(var701 = 1)) and (var10 = 1 or not(var701 = 1)) and (var12 = 1
or not(var701 = 1)) and (var14 = 1 or not(var701 = 1)) and (var15 = 1 or not(
var701 = 1)) and (var18 = 1 or not(var702 = 1)) and (var20 = 1 or not(var702 = 1
)) and (var21 = 1 or not(var702 = 1)) and (var24 = 1 or not(var702 = 1)) and (
var26 = 1 or not(var702 = 1)) and (var28 = 1 or not(var702 = 1)) and (var30 = 1
or not(var702 = 1)) and (var31 = 1 or not(var702 = 1)) and (var34 = 1 or not(
var703 = 1)) and (var36 = 1 or not(var703 = 1)) and (var37 = 1 or not(var703 = 1
)) and (var40 = 1 or not(var703 = 1)) and (var42 = 1 or not(var703 = 1)) and (
var44 = 1 or not(var703 = 1)) and (var46 = 1 or not(var703 = 1)) and (var47 = 1
or not(var703 = 1)) and (var50 = 1 or not(var704 = 1)) and (var52 = 1 or not(
var704 = 1)) and (var53 = 1 or not(var704 = 1)) and (var56 = 1 or not(var704 = 1
)) and (var58 = 1 or not(var704 = 1)) and (var60 = 1 or not(var704 = 1)) and (
var62 = 1 or not(var704 = 1)) and (var63 = 1 or not(var704 = 1)) and (var66 = 1
or not(var705 = 1)) and (var68 = 1 or not(var705 = 1)) and (var69 = 1 or not(
var705 = 1)) and (var72 = 1 or not(var705 = 1)) and (var74 = 1 or not(var705 = 1
)) and (var76 = 1 or not(var705 = 1)) and (var78 = 1 or not(var705 = 1)) and (
var79 = 1 or not(var705 = 1)) and (var82 = 1 or not(var706 = 1)) and (var84 = 1
or not(var706 = 1)) and (var85 = 1 or not(var706 = 1)) and (var88 = 1 or not(
var706 = 1)) and (var90 = 1 or not(var706 = 1)) and (var92 = 1 or not(var706 = 1
)) and (var94 = 1 or not(var706 = 1)) and (var95 = 1 or not(var706 = 1)) and (
var98 = 1 or not(var707 = 1)) and (var100 = 1 or not(var707 = 1)) and (var101 =
1 or not(var707 = 1)) and (var104 = 1 or not(var707 = 1)) and (var106 = 1 or not
(var707 = 1)) and (var108 = 1 or not(var707 = 1)) and (var110 = 1 or not(var707
= 1)) and (var111 = 1 or not(var707 = 1)) and (var114 = 1 or not(var708 = 1))
and (var116 = 1 or not(var708 = 1)) and (var117 = 1 or not(var708 = 1)) and (
var120 = 1 or not(var708 = 1)) and (var122 = 1 or not(var708 = 1)) and (var124 =
 1 or not(var708 = 1)) and (var126 = 1 or not(var708 = 1)) and (var127 = 1 or
not(var708 = 1)) and (var130 = 1 or not(var709 = 1)) and (var132 = 1 or not(
var709 = 1)) and (var133 = 1 or not(var709 = 1)) and (var136 = 1 or not(var709 =
 1)) and (var138 = 1 or not(var709 = 1)) and (var140 = 1 or not(var709 = 1)) and
 (var142 = 1 or not(var709 = 1)) and (var143 = 1 or not(var709 = 1)) and (var146
 = 1 or not(var710 = 1)) and (var148 = 1 or not(var710 = 1)) and (var149 = 1 or
not(var710 = 1)) and (var152 = 1 or not(var710 = 1)) and (var154 = 1 or not(
var710 = 1)) and (var156 = 1 or not(var710 = 1)) and (var158 = 1 or not(var710 =
 1)) and (var159 = 1 or not(var710 = 1)) and (var1 = 1 or not(var711 = 1)) and (
var3 = 1 or not(var711 = 1)) and (var5 = 1 or not(var711 = 1)) and (var8 = 1 or
not(var711 = 1)) and (var10 = 1 or not(var711 = 1)) and (var11 = 1 or not(var711
 = 1)) and (var13 = 1 or not(var711 = 1)) and (var16 = 1 or not(var711 = 1)) and
 (var17 = 1 or not(var712 = 1)) and (var19 = 1 or not(var712 = 1)) and (var21 =
1 or not(var712 = 1)) and (var24 = 1 or not(var712 = 1)) and (var26 = 1 or not(
var712 = 1)) and (var27 = 1 or not(var712 = 1)) and (var29 = 1 or not(var712 = 1
)) and (var32 = 1 or not(var712 = 1)) and (var33 = 1 or not(var713 = 1)) and (
var35 = 1 or not(var713 = 1)) and (var37 = 1 or not(var713 = 1)) and (var40 = 1
or not(var713 = 1)) and (var42 = 1 or not(var713 = 1)) and (var43 = 1 or not(
var713 = 1)) and (var45 = 1 or not(var713 = 1)) and (var48 = 1 or not(var713 = 1
)) and (var49 = 1 or not(var714 = 1)) and (var51 = 1 or not(var714 = 1)) and (
var53 = 1 or not(var714 = 1)) and (var56 = 1 or not(var714 = 1)) and (var58 = 1
or not(var714 = 1)) and (var59 = 1 or not(var714 = 1)) and (var61 = 1 or not(
var714 = 1)) and (var64 = 1 or not(var714 = 1)) and (var65 = 1 or not(var715 = 1
)) and (var67 = 1 or not(var715 = 1)) and (var69 = 1 or not(var715 = 1)) and (
var72 = 1 or not(var715 = 1)) and (var74 = 1 or not(var715 = 1)) and (var75 = 1
or not(var715 = 1)) and (var77 = 1 or not(var715 = 1)) and (var80 = 1 or not(
var715 = 1)) and (var81 = 1 or not(var716 = 1)) and (var83 = 1 or not(var716 = 1
)) and (var85 = 1 or not(var716 = 1)) and (var88 = 1 or not(var716 = 1)) and (
var90 = 1 or not(var716 = 1)) and (var91 = 1 or not(var716 = 1)) and (var93 = 1
or not(var716 = 1)) and (var96 = 1 or not(var716 = 1)) and (var97 = 1 or not(
var717 = 1)) and (var99 = 1 or not(var717 = 1)) and (var101 = 1 or not(var717 =
1)) and (var104 = 1 or not(var717 = 1)) and (var106 = 1 or not(var717 = 1)) and
(var107 = 1 or not(var717 = 1)) and (var109 = 1 or not(var717 = 1)) and (var112
= 1 or not(var717 = 1)) and (var113 = 1 or not(var718 = 1)) and (var115 = 1 or
not(var718 = 1)) and (var117 = 1 or not(var718 = 1)) and (var120 = 1 or not(
var718 = 1)) and (var122 = 1 or not(var718 = 1)) and (var123 = 1 or not(var718 =
 1)) and (var125 = 1 or not(var718 = 1)) and (var128 = 1 or not(var718 = 1)) and
 (var129 = 1 or not(var719 = 1)) and (var131 = 1 or not(var719 = 1)) and (var133
 = 1 or not(var719 = 1)) and (var136 = 1 or not(var719 = 1)) and (var138 = 1 or
not(var719 = 1)) and (var139 = 1 or not(var719 = 1)) and (var141 = 1 or not(
var719 = 1)) and (var144 = 1 or not(var719 = 1)) and (var145 = 1 or not(var720 =
 1)) and (var147 = 1 or not(var720 = 1)) and (var149 = 1 or not(var720 = 1)) and
 (var152 = 1 or not(var720 = 1)) and (var154 = 1 or not(var720 = 1)) and (var155
 = 1 or not(var720 = 1)) and (var157 = 1 or not(var720 = 1)) and (var160 = 1 or
not(var720 = 1)) and (var1 = 1 or not(var721 = 1)) and (var4 = 1 or not(var721 =
 1)) and (var6 = 1 or not(var721 = 1)) and (var8 = 1 or not(var721 = 1)) and (
var10 = 1 or not(var721 = 1)) and (var11 = 1 or not(var721 = 1)) and (var13 = 1
or not(var721 = 1)) and (var16 = 1 or not(var721 = 1)) and (var17 = 1 or not(
var722 = 1)) and (var20 = 1 or not(var722 = 1)) and (var22 = 1 or not(var722 = 1
)) and (var24 = 1 or not(var722 = 1)) and (var26 = 1 or not(var722 = 1)) and (
var27 = 1 or not(var722 = 1)) and (var29 = 1 or not(var722 = 1)) and (var32 = 1
or not(var722 = 1)) and (var33 = 1 or not(var723 = 1)) and (var36 = 1 or not(
var723 = 1)) and (var38 = 1 or not(var723 = 1)) and (var40 = 1 or not(var723 = 1
)) and (var42 = 1 or not(var723 = 1)) and (var43 = 1 or not(var723 = 1)) and (
var45 = 1 or not(var723 = 1)) and (var48 = 1 or not(var723 = 1)) and (var49 = 1
or not(var724 = 1)) and (var52 = 1 or not(var724 = 1)) and (var54 = 1 or not(
var724 = 1)) and (var56 = 1 or not(var724 = 1)) and (var58 = 1 or not(var724 = 1
)) and (var59 = 1 or not(var724 = 1)) and (var61 = 1 or not(var724 = 1)) and (
var64 = 1 or not(var724 = 1)) and (var65 = 1 or not(var725 = 1)) and (var68 = 1
or not(var725 = 1)) and (var70 = 1 or not(var725 = 1)) and (var72 = 1 or not(
var725 = 1)) and (var74 = 1 or not(var725 = 1)) and (var75 = 1 or not(var725 = 1
)) and (var77 = 1 or not(var725 = 1)) and (var80 = 1 or not(var725 = 1)) and (
var81 = 1 or not(var726 = 1)) and (var84 = 1 or not(var726 = 1)) and (var86 = 1
or not(var726 = 1)) and (var88 = 1 or not(var726 = 1)) and (var90 = 1 or not(
var726 = 1)) and (var91 = 1 or not(var726 = 1)) and (var93 = 1 or not(var726 = 1
)) and (var96 = 1 or not(var726 = 1)) and (var97 = 1 or not(var727 = 1)) and (
var100 = 1 or not(var727 = 1)) and (var102 = 1 or not(var727 = 1)) and (var104 =
 1 or not(var727 = 1)) and (var106 = 1 or not(var727 = 1)) and (var107 = 1 or
not(var727 = 1)) and (var109 = 1 or not(var727 = 1)) and (var112 = 1 or not(
var727 = 1)) and (var113 = 1 or not(var728 = 1)) and (var116 = 1 or not(var728 =
 1)) and (var118 = 1 or not(var728 = 1)) and (var120 = 1 or not(var728 = 1)) and
 (var122 = 1 or not(var728 = 1)) and (var123 = 1 or not(var728 = 1)) and (var125
 = 1 or not(var728 = 1)) and (var128 = 1 or not(var728 = 1)) and (var129 = 1 or
not(var729 = 1)) and (var132 = 1 or not(var729 = 1)) and (var134 = 1 or not(
var729 = 1)) and (var136 = 1 or not(var729 = 1)) and (var138 = 1 or not(var729 =
 1)) and (var139 = 1 or not(var729 = 1)) and (var141 = 1 or not(var729 = 1)) and
 (var144 = 1 or not(var729 = 1)) and (var145 = 1 or not(var730 = 1)) and (var148
 = 1 or not(var730 = 1)) and (var150 = 1 or not(var730 = 1)) and (var152 = 1 or
not(var730 = 1)) and (var154 = 1 or not(var730 = 1)) and (var155 = 1 or not(
var730 = 1)) and (var157 = 1 or not(var730 = 1)) and (var160 = 1 or not(var730 =
 1)) and (var2 = 1 or not(var731 = 1)) and (var3 = 1 or not(var731 = 1)) and (
var6 = 1 or not(var731 = 1)) and (var8 = 1 or not(var731 = 1)) and (var10 = 1 or
 not(var731 = 1)) and (var12 = 1 or not(var731 = 1)) and (var13 = 1 or not(
var731 = 1)) and (var15 = 1 or not(var731 = 1)) and (var18 = 1 or not(var732 = 1
)) and (var19 = 1 or not(var732 = 1)) and (var22 = 1 or not(var732 = 1)) and (
var24 = 1 or not(var732 = 1)) and (var26 = 1 or not(var732 = 1)) and (var28 = 1
or not(var732 = 1)) and (var29 = 1 or not(var732 = 1)) and (var31 = 1 or not(
var732 = 1)) and (var34 = 1 or not(var733 = 1)) and (var35 = 1 or not(var733 = 1
)) and (var38 = 1 or not(var733 = 1)) and (var40 = 1 or not(var733 = 1)) and (
var42 = 1 or not(var733 = 1)) and (var44 = 1 or not(var733 = 1)) and (var45 = 1
or not(var733 = 1)) and (var47 = 1 or not(var733 = 1)) and (var50 = 1 or not(
var734 = 1)) and (var51 = 1 or not(var734 = 1)) and (var54 = 1 or not(var734 = 1
)) and (var56 = 1 or not(var734 = 1)) and (var58 = 1 or not(var734 = 1)) and (
var60 = 1 or not(var734 = 1)) and (var61 = 1 or not(var734 = 1)) and (var63 = 1
or not(var734 = 1)) and (var66 = 1 or not(var735 = 1)) and (var67 = 1 or not(
var735 = 1)) and (var70 = 1 or not(var735 = 1)) and (var72 = 1 or not(var735 = 1
)) and (var74 = 1 or not(var735 = 1)) and (var76 = 1 or not(var735 = 1)) and (
var77 = 1 or not(var735 = 1)) and (var79 = 1 or not(var735 = 1)) and (var82 = 1
or not(var736 = 1)) and (var83 = 1 or not(var736 = 1)) and (var86 = 1 or not(
var736 = 1)) and (var88 = 1 or not(var736 = 1)) and (var90 = 1 or not(var736 = 1
)) and (var92 = 1 or not(var736 = 1)) and (var93 = 1 or not(var736 = 1)) and (
var95 = 1 or not(var736 = 1)) and (var98 = 1 or not(var737 = 1)) and (var99 = 1
or not(var737 = 1)) and (var102 = 1 or not(var737 = 1)) and (var104 = 1 or not(
var737 = 1)) and (var106 = 1 or not(var737 = 1)) and (var108 = 1 or not(var737 =
 1)) and (var109 = 1 or not(var737 = 1)) and (var111 = 1 or not(var737 = 1)) and
 (var114 = 1 or not(var738 = 1)) and (var115 = 1 or not(var738 = 1)) and (var118
 = 1 or not(var738 = 1)) and (var120 = 1 or not(var738 = 1)) and (var122 = 1 or
not(var738 = 1)) and (var124 = 1 or not(var738 = 1)) and (var125 = 1 or not(
var738 = 1)) and (var127 = 1 or not(var738 = 1)) and (var130 = 1 or not(var739 =
 1)) and (var131 = 1 or not(var739 = 1)) and (var134 = 1 or not(var739 = 1)) and
 (var136 = 1 or not(var739 = 1)) and (var138 = 1 or not(var739 = 1)) and (var140
 = 1 or not(var739 = 1)) and (var141 = 1 or not(var739 = 1)) and (var143 = 1 or
not(var739 = 1)) and (var146 = 1 or not(var740 = 1)) and (var147 = 1 or not(
var740 = 1)) and (var150 = 1 or not(var740 = 1)) and (var152 = 1 or not(var740 =
 1)) and (var154 = 1 or not(var740 = 1)) and (var156 = 1 or not(var740 = 1)) and
 (var157 = 1 or not(var740 = 1)) and (var159 = 1 or not(var740 = 1)) and (var2 =
 1 or not(var741 = 1)) and (var4 = 1 or not(var741 = 1)) and (var5 = 1 or not(
var741 = 1)) and (var7 = 1 or not(var741 = 1)) and (var9 = 1 or not(var741 = 1))
 and (var11 = 1 or not(var741 = 1)) and (var14 = 1 or not(var741 = 1)) and (
var16 = 1 or not(var741 = 1)) and (var18 = 1 or not(var742 = 1)) and (var20 = 1
or not(var742 = 1)) and (var21 = 1 or not(var742 = 1)) and (var23 = 1 or not(
var742 = 1)) and (var25 = 1 or not(var742 = 1)) and (var27 = 1 or not(var742 = 1
)) and (var30 = 1 or not(var742 = 1)) and (var32 = 1 or not(var742 = 1)) and (
var34 = 1 or not(var743 = 1)) and (var36 = 1 or not(var743 = 1)) and (var37 = 1
or not(var743 = 1)) and (var39 = 1 or not(var743 = 1)) and (var41 = 1 or not(
var743 = 1)) and (var43 = 1 or not(var743 = 1)) and (var46 = 1 or not(var743 = 1
)) and (var48 = 1 or not(var743 = 1)) and (var50 = 1 or not(var744 = 1)) and (
var52 = 1 or not(var744 = 1)) and (var53 = 1 or not(var744 = 1)) and (var55 = 1
or not(var744 = 1)) and (var57 = 1 or not(var744 = 1)) and (var59 = 1 or not(
var744 = 1)) and (var62 = 1 or not(var744 = 1)) and (var64 = 1 or not(var744 = 1
)) and (var66 = 1 or not(var745 = 1)) and (var68 = 1 or not(var745 = 1)) and (
var69 = 1 or not(var745 = 1)) and (var71 = 1 or not(var745 = 1)) and (var73 = 1
or not(var745 = 1)) and (var75 = 1 or not(var745 = 1)) and (var78 = 1 or not(
var745 = 1)) and (var80 = 1 or not(var745 = 1)) and (var82 = 1 or not(var746 = 1
)) and (var84 = 1 or not(var746 = 1)) and (var85 = 1 or not(var746 = 1)) and (
var87 = 1 or not(var746 = 1)) and (var89 = 1 or not(var746 = 1)) and (var91 = 1
or not(var746 = 1)) and (var94 = 1 or not(var746 = 1)) and (var96 = 1 or not(
var746 = 1)) and (var98 = 1 or not(var747 = 1)) and (var100 = 1 or not(var747 =
1)) and (var101 = 1 or not(var747 = 1)) and (var103 = 1 or not(var747 = 1)) and
(var105 = 1 or not(var747 = 1)) and (var107 = 1 or not(var747 = 1)) and (var110
= 1 or not(var747 = 1)) and (var112 = 1 or not(var747 = 1)) and (var114 = 1 or
not(var748 = 1)) and (var116 = 1 or not(var748 = 1)) and (var117 = 1 or not(
var748 = 1)) and (var119 = 1 or not(var748 = 1)) and (var121 = 1 or not(var748 =
 1)) and (var123 = 1 or not(var748 = 1)) and (var126 = 1 or not(var748 = 1)) and
 (var128 = 1 or not(var748 = 1)) and (var130 = 1 or not(var749 = 1)) and (var132
 = 1 or not(var749 = 1)) and (var133 = 1 or not(var749 = 1)) and (var135 = 1 or
not(var749 = 1)) and (var137 = 1 or not(var749 = 1)) and (var139 = 1 or not(
var749 = 1)) and (var142 = 1 or not(var749 = 1)) and (var144 = 1 or not(var749 =
 1)) and (var146 = 1 or not(var750 = 1)) and (var148 = 1 or not(var750 = 1)) and
 (var149 = 1 or not(var750 = 1)) and (var151 = 1 or not(var750 = 1)) and (var153
 = 1 or not(var750 = 1)) and (var155 = 1 or not(var750 = 1)) and (var158 = 1 or
not(var750 = 1)) and (var160 = 1 or not(var750 = 1)) and (var2 = 1 or not(var751
 = 1)) and (var4 = 1 or not(var751 = 1)) and (var5 = 1 or not(var751 = 1)) and (
var8 = 1 or not(var751 = 1)) and (var9 = 1 or not(var751 = 1)) and (var11 = 1 or
 not(var751 = 1)) and (var14 = 1 or not(var751 = 1)) and (var15 = 1 or not(
var751 = 1)) and (var18 = 1 or not(var752 = 1)) and (var20 = 1 or not(var752 = 1
)) and (var21 = 1 or not(var752 = 1)) and (var24 = 1 or not(var752 = 1)) and (
var25 = 1 or not(var752 = 1)) and (var27 = 1 or not(var752 = 1)) and (var30 = 1
or not(var752 = 1)) and (var31 = 1 or not(var752 = 1)) and (var34 = 1 or not(
var753 = 1)) and (var36 = 1 or not(var753 = 1)) and (var37 = 1 or not(var753 = 1
)) and (var40 = 1 or not(var753 = 1)) and (var41 = 1 or not(var753 = 1)) and (
var43 = 1 or not(var753 = 1)) and (var46 = 1 or not(var753 = 1)) and (var47 = 1
or not(var753 = 1)) and (var50 = 1 or not(var754 = 1)) and (var52 = 1 or not(
var754 = 1)) and (var53 = 1 or not(var754 = 1)) and (var56 = 1 or not(var754 = 1
)) and (var57 = 1 or not(var754 = 1)) and (var59 = 1 or not(var754 = 1)) and (
var62 = 1 or not(var754 = 1)) and (var63 = 1 or not(var754 = 1)) and (var66 = 1
or not(var755 = 1)) and (var68 = 1 or not(var755 = 1)) and (var69 = 1 or not(
var755 = 1)) and (var72 = 1 or not(var755 = 1)) and (var73 = 1 or not(var755 = 1
)) and (var75 = 1 or not(var755 = 1)) and (var78 = 1 or not(var755 = 1)) and (
var79 = 1 or not(var755 = 1)) and (var82 = 1 or not(var756 = 1)) and (var84 = 1
or not(var756 = 1)) and (var85 = 1 or not(var756 = 1)) and (var88 = 1 or not(
var756 = 1)) and (var89 = 1 or not(var756 = 1)) and (var91 = 1 or not(var756 = 1
)) and (var94 = 1 or not(var756 = 1)) and (var95 = 1 or not(var756 = 1)) and (
var98 = 1 or not(var757 = 1)) and (var100 = 1 or not(var757 = 1)) and (var101 =
1 or not(var757 = 1)) and (var104 = 1 or not(var757 = 1)) and (var105 = 1 or not
(var757 = 1)) and (var107 = 1 or not(var757 = 1)) and (var110 = 1 or not(var757
= 1)) and (var111 = 1 or not(var757 = 1)) and (var114 = 1 or not(var758 = 1))
and (var116 = 1 or not(var758 = 1)) and (var117 = 1 or not(var758 = 1)) and (
var120 = 1 or not(var758 = 1)) and (var121 = 1 or not(var758 = 1)) and (var123 =
 1 or not(var758 = 1)) and (var126 = 1 or not(var758 = 1)) and (var127 = 1 or
not(var758 = 1)) and (var130 = 1 or not(var759 = 1)) and (var132 = 1 or not(
var759 = 1)) and (var133 = 1 or not(var759 = 1)) and (var136 = 1 or not(var759 =
 1)) and (var137 = 1 or not(var759 = 1)) and (var139 = 1 or not(var759 = 1)) and
 (var142 = 1 or not(var759 = 1)) and (var143 = 1 or not(var759 = 1)) and (var146
 = 1 or not(var760 = 1)) and (var148 = 1 or not(var760 = 1)) and (var149 = 1 or
not(var760 = 1)) and (var152 = 1 or not(var760 = 1)) and (var153 = 1 or not(
var760 = 1)) and (var155 = 1 or not(var760 = 1)) and (var158 = 1 or not(var760 =
 1)) and (var159 = 1 or not(var760 = 1)) and (var1 = 1 or not(var761 = 1)) and (
var3 = 1 or not(var761 = 1)) and (var6 = 1 or not(var761 = 1)) and (var8 = 1 or
not(var761 = 1)) and (var10 = 1 or not(var761 = 1)) and (var11 = 1 or not(var761
 = 1)) and (var13 = 1 or not(var761 = 1)) and (var16 = 1 or not(var761 = 1)) and
 (var17 = 1 or not(var762 = 1)) and (var19 = 1 or not(var762 = 1)) and (var22 =
1 or not(var762 = 1)) and (var24 = 1 or not(var762 = 1)) and (var26 = 1 or not(
var762 = 1)) and (var27 = 1 or not(var762 = 1)) and (var29 = 1 or not(var762 = 1
)) and (var32 = 1 or not(var762 = 1)) and (var33 = 1 or not(var763 = 1)) and (
var35 = 1 or not(var763 = 1)) and (var38 = 1 or not(var763 = 1)) and (var40 = 1
or not(var763 = 1)) and (var42 = 1 or not(var763 = 1)) and (var43 = 1 or not(
var763 = 1)) and (var45 = 1 or not(var763 = 1)) and (var48 = 1 or not(var763 = 1
)) and (var49 = 1 or not(var764 = 1)) and (var51 = 1 or not(var764 = 1)) and (
var54 = 1 or not(var764 = 1)) and (var56 = 1 or not(var764 = 1)) and (var58 = 1
or not(var764 = 1)) and (var59 = 1 or not(var764 = 1)) and (var61 = 1 or not(
var764 = 1)) and (var64 = 1 or not(var764 = 1)) and (var65 = 1 or not(var765 = 1
)) and (var67 = 1 or not(var765 = 1)) and (var70 = 1 or not(var765 = 1)) and (
var72 = 1 or not(var765 = 1)) and (var74 = 1 or not(var765 = 1)) and (var75 = 1
or not(var765 = 1)) and (var77 = 1 or not(var765 = 1)) and (var80 = 1 or not(
var765 = 1)) and (var81 = 1 or not(var766 = 1)) and (var83 = 1 or not(var766 = 1
)) and (var86 = 1 or not(var766 = 1)) and (var88 = 1 or not(var766 = 1)) and (
var90 = 1 or not(var766 = 1)) and (var91 = 1 or not(var766 = 1)) and (var93 = 1
or not(var766 = 1)) and (var96 = 1 or not(var766 = 1)) and (var97 = 1 or not(
var767 = 1)) and (var99 = 1 or not(var767 = 1)) and (var102 = 1 or not(var767 =
1)) and (var104 = 1 or not(var767 = 1)) and (var106 = 1 or not(var767 = 1)) and
(var107 = 1 or not(var767 = 1)) and (var109 = 1 or not(var767 = 1)) and (var112
= 1 or not(var767 = 1)) and (var113 = 1 or not(var768 = 1)) and (var115 = 1 or
not(var768 = 1)) and (var118 = 1 or not(var768 = 1)) and (var120 = 1 or not(
var768 = 1)) and (var122 = 1 or not(var768 = 1)) and (var123 = 1 or not(var768 =
 1)) and (var125 = 1 or not(var768 = 1)) and (var128 = 1 or not(var768 = 1)) and
 (var129 = 1 or not(var769 = 1)) and (var131 = 1 or not(var769 = 1)) and (var134
 = 1 or not(var769 = 1)) and (var136 = 1 or not(var769 = 1)) and (var138 = 1 or
not(var769 = 1)) and (var139 = 1 or not(var769 = 1)) and (var141 = 1 or not(
var769 = 1)) and (var144 = 1 or not(var769 = 1)) and (var145 = 1 or not(var770 =
 1)) and (var147 = 1 or not(var770 = 1)) and (var150 = 1 or not(var770 = 1)) and
 (var152 = 1 or not(var770 = 1)) and (var154 = 1 or not(var770 = 1)) and (var155
 = 1 or not(var770 = 1)) and (var157 = 1 or not(var770 = 1)) and (var160 = 1 or
not(var770 = 1)) and (var2 = 1 or not(var771 = 1)) and (var3 = 1 or not(var771 =
 1)) and (var6 = 1 or not(var771 = 1)) and (var8 = 1 or not(var771 = 1)) and (
var10 = 1 or not(var771 = 1)) and (var11 = 1 or not(var771 = 1)) and (var14 = 1
or not(var771 = 1)) and (var15 = 1 or not(var771 = 1)) and (var18 = 1 or not(
var772 = 1)) and (var19 = 1 or not(var772 = 1)) and (var22 = 1 or not(var772 = 1
)) and (var24 = 1 or not(var772 = 1)) and (var26 = 1 or not(var772 = 1)) and (
var27 = 1 or not(var772 = 1)) and (var30 = 1 or not(var772 = 1)) and (var31 = 1
or not(var772 = 1)) and (var34 = 1 or not(var773 = 1)) and (var35 = 1 or not(
var773 = 1)) and (var38 = 1 or not(var773 = 1)) and (var40 = 1 or not(var773 = 1
)) and (var42 = 1 or not(var773 = 1)) and (var43 = 1 or not(var773 = 1)) and (
var46 = 1 or not(var773 = 1)) and (var47 = 1 or not(var773 = 1)) and (var50 = 1
or not(var774 = 1)) and (var51 = 1 or not(var774 = 1)) and (var54 = 1 or not(
var774 = 1)) and (var56 = 1 or not(var774 = 1)) and (var58 = 1 or not(var774 = 1
)) and (var59 = 1 or not(var774 = 1)) and (var62 = 1 or not(var774 = 1)) and (
var63 = 1 or not(var774 = 1)) and (var66 = 1 or not(var775 = 1)) and (var67 = 1
or not(var775 = 1)) and (var70 = 1 or not(var775 = 1)) and (var72 = 1 or not(
var775 = 1)) and (var74 = 1 or not(var775 = 1)) and (var75 = 1 or not(var775 = 1
)) and (var78 = 1 or not(var775 = 1)) and (var79 = 1 or not(var775 = 1)) and (
var82 = 1 or not(var776 = 1)) and (var83 = 1 or not(var776 = 1)) and (var86 = 1
or not(var776 = 1)) and (var88 = 1 or not(var776 = 1)) and (var90 = 1 or not(
var776 = 1)) and (var91 = 1 or not(var776 = 1)) and (var94 = 1 or not(var776 = 1
)) and (var95 = 1 or not(var776 = 1)) and (var98 = 1 or not(var777 = 1)) and (
var99 = 1 or not(var777 = 1)) and (var102 = 1 or not(var777 = 1)) and (var104 =
1 or not(var777 = 1)) and (var106 = 1 or not(var777 = 1)) and (var107 = 1 or not
(var777 = 1)) and (var110 = 1 or not(var777 = 1)) and (var111 = 1 or not(var777
= 1)) and (var114 = 1 or not(var778 = 1)) and (var115 = 1 or not(var778 = 1))
and (var118 = 1 or not(var778 = 1)) and (var120 = 1 or not(var778 = 1)) and (
var122 = 1 or not(var778 = 1)) and (var123 = 1 or not(var778 = 1)) and (var126 =
 1 or not(var778 = 1)) and (var127 = 1 or not(var778 = 1)) and (var130 = 1 or
not(var779 = 1)) and (var131 = 1 or not(var779 = 1)) and (var134 = 1 or not(
var779 = 1)) and (var136 = 1 or not(var779 = 1)) and (var138 = 1 or not(var779 =
 1)) and (var139 = 1 or not(var779 = 1)) and (var142 = 1 or not(var779 = 1)) and
 (var143 = 1 or not(var779 = 1)) and (var146 = 1 or not(var780 = 1)) and (var147
 = 1 or not(var780 = 1)) and (var150 = 1 or not(var780 = 1)) and (var152 = 1 or
not(var780 = 1)) and (var154 = 1 or not(var780 = 1)) and (var155 = 1 or not(
var780 = 1)) and (var158 = 1 or not(var780 = 1)) and (var159 = 1 or not(var780 =
 1)) and (var2 = 1 or not(var781 = 1)) and (var3 = 1 or not(var781 = 1)) and (
var6 = 1 or not(var781 = 1)) and (var7 = 1 or not(var781 = 1)) and (var9 = 1 or
not(var781 = 1)) and (var12 = 1 or not(var781 = 1)) and (var14 = 1 or not(var781
 = 1)) and (var16 = 1 or not(var781 = 1)) and (var18 = 1 or not(var782 = 1)) and
 (var19 = 1 or not(var782 = 1)) and (var22 = 1 or not(var782 = 1)) and (var23 =
1 or not(var782 = 1)) and (var25 = 1 or not(var782 = 1)) and (var28 = 1 or not(
var782 = 1)) and (var30 = 1 or not(var782 = 1)) and (var32 = 1 or not(var782 = 1
)) and (var34 = 1 or not(var783 = 1)) and (var35 = 1 or not(var783 = 1)) and (
var38 = 1 or not(var783 = 1)) and (var39 = 1 or not(var783 = 1)) and (var41 = 1
or not(var783 = 1)) and (var44 = 1 or not(var783 = 1)) and (var46 = 1 or not(
var783 = 1)) and (var48 = 1 or not(var783 = 1)) and (var50 = 1 or not(var784 = 1
)) and (var51 = 1 or not(var784 = 1)) and (var54 = 1 or not(var784 = 1)) and (
var55 = 1 or not(var784 = 1)) and (var57 = 1 or not(var784 = 1)) and (var60 = 1
or not(var784 = 1)) and (var62 = 1 or not(var784 = 1)) and (var64 = 1 or not(
var784 = 1)) and (var66 = 1 or not(var785 = 1)) and (var67 = 1 or not(var785 = 1
)) and (var70 = 1 or not(var785 = 1)) and (var71 = 1 or not(var785 = 1)) and (
var73 = 1 or not(var785 = 1)) and (var76 = 1 or not(var785 = 1)) and (var78 = 1
or not(var785 = 1)) and (var80 = 1 or not(var785 = 1)) and (var82 = 1 or not(
var786 = 1)) and (var83 = 1 or not(var786 = 1)) and (var86 = 1 or not(var786 = 1
)) and (var87 = 1 or not(var786 = 1)) and (var89 = 1 or not(var786 = 1)) and (
var92 = 1 or not(var786 = 1)) and (var94 = 1 or not(var786 = 1)) and (var96 = 1
or not(var786 = 1)) and (var98 = 1 or not(var787 = 1)) and (var99 = 1 or not(
var787 = 1)) and (var102 = 1 or not(var787 = 1)) and (var103 = 1 or not(var787 =
 1)) and (var105 = 1 or not(var787 = 1)) and (var108 = 1 or not(var787 = 1)) and
 (var110 = 1 or not(var787 = 1)) and (var112 = 1 or not(var787 = 1)) and (var114
 = 1 or not(var788 = 1)) and (var115 = 1 or not(var788 = 1)) and (var118 = 1 or
not(var788 = 1)) and (var119 = 1 or not(var788 = 1)) and (var121 = 1 or not(
var788 = 1)) and (var124 = 1 or not(var788 = 1)) and (var126 = 1 or not(var788 =
 1)) and (var128 = 1 or not(var788 = 1)) and (var130 = 1 or not(var789 = 1)) and
 (var131 = 1 or not(var789 = 1)) and (var134 = 1 or not(var789 = 1)) and (var135
 = 1 or not(var789 = 1)) and (var137 = 1 or not(var789 = 1)) and (var140 = 1 or
not(var789 = 1)) and (var142 = 1 or not(var789 = 1)) and (var144 = 1 or not(
var789 = 1)) and (var146 = 1 or not(var790 = 1)) and (var147 = 1 or not(var790 =
 1)) and (var150 = 1 or not(var790 = 1)) and (var151 = 1 or not(var790 = 1)) and
 (var153 = 1 or not(var790 = 1)) and (var156 = 1 or not(var790 = 1)) and (var158
 = 1 or not(var790 = 1)) and (var160 = 1 or not(var790 = 1)) and (var1 = 1 or
not(var791 = 1)) and (var3 = 1 or not(var791 = 1)) and (var5 = 1 or not(var791 =
 1)) and (var7 = 1 or not(var791 = 1)) and (var10 = 1 or not(var791 = 1)) and (
var12 = 1 or not(var791 = 1)) and (var13 = 1 or not(var791 = 1)) and (var15 = 1
or not(var791 = 1)) and (var17 = 1 or not(var792 = 1)) and (var19 = 1 or not(
var792 = 1)) and (var21 = 1 or not(var792 = 1)) and (var23 = 1 or not(var792 = 1
)) and (var26 = 1 or not(var792 = 1)) and (var28 = 1 or not(var792 = 1)) and (
var29 = 1 or not(var792 = 1)) and (var31 = 1 or not(var792 = 1)) and (var33 = 1
or not(var793 = 1)) and (var35 = 1 or not(var793 = 1)) and (var37 = 1 or not(
var793 = 1)) and (var39 = 1 or not(var793 = 1)) and (var42 = 1 or not(var793 = 1
)) and (var44 = 1 or not(var793 = 1)) and (var45 = 1 or not(var793 = 1)) and (
var47 = 1 or not(var793 = 1)) and (var49 = 1 or not(var794 = 1)) and (var51 = 1
or not(var794 = 1)) and (var53 = 1 or not(var794 = 1)) and (var55 = 1 or not(
var794 = 1)) and (var58 = 1 or not(var794 = 1)) and (var60 = 1 or not(var794 = 1
)) and (var61 = 1 or not(var794 = 1)) and (var63 = 1 or not(var794 = 1)) and (
var65 = 1 or not(var795 = 1)) and (var67 = 1 or not(var795 = 1)) and (var69 = 1
or not(var795 = 1)) and (var71 = 1 or not(var795 = 1)) and (var74 = 1 or not(
var795 = 1)) and (var76 = 1 or not(var795 = 1)) and (var77 = 1 or not(var795 = 1
)) and (var79 = 1 or not(var795 = 1)) and (var81 = 1 or not(var796 = 1)) and (
var83 = 1 or not(var796 = 1)) and (var85 = 1 or not(var796 = 1)) and (var87 = 1
or not(var796 = 1)) and (var90 = 1 or not(var796 = 1)) and (var92 = 1 or not(
var796 = 1)) and (var93 = 1 or not(var796 = 1)) and (var95 = 1 or not(var796 = 1
)) and (var97 = 1 or not(var797 = 1)) and (var99 = 1 or not(var797 = 1)) and (
var101 = 1 or not(var797 = 1)) and (var103 = 1 or not(var797 = 1)) and (var106 =
 1 or not(var797 = 1)) and (var108 = 1 or not(var797 = 1)) and (var109 = 1 or
not(var797 = 1)) and (var111 = 1 or not(var797 = 1)) and (var113 = 1 or not(
var798 = 1)) and (var115 = 1 or not(var798 = 1)) and (var117 = 1 or not(var798 =
 1)) and (var119 = 1 or not(var798 = 1)) and (var122 = 1 or not(var798 = 1)) and
 (var124 = 1 or not(var798 = 1)) and (var125 = 1 or not(var798 = 1)) and (var127
 = 1 or not(var798 = 1)) and (var129 = 1 or not(var799 = 1)) and (var131 = 1 or
not(var799 = 1)) and (var133 = 1 or not(var799 = 1)) and (var135 = 1 or not(
var799 = 1)) and (var138 = 1 or not(var799 = 1)) and (var140 = 1 or not(var799 =
 1)) and (var141 = 1 or not(var799 = 1)) and (var143 = 1 or not(var799 = 1)) and
 (var145 = 1 or not(var800 = 1)) and (var147 = 1 or not(var800 = 1)) and (var149
 = 1 or not(var800 = 1)) and (var151 = 1 or not(var800 = 1)) and (var154 = 1 or
not(var800 = 1)) and (var156 = 1 or not(var800 = 1)) and (var157 = 1 or not(
var800 = 1)) and (var159 = 1 or not(var800 = 1)) and (var2 = 1 or not(var801 = 1
)) and (var3 = 1 or not(var801 = 1)) and (var6 = 1 or not(var801 = 1)) and (var7
 = 1 or not(var801 = 1)) and (var10 = 1 or not(var801 = 1)) and (var11 = 1 or
not(var801 = 1)) and (var13 = 1 or not(var801 = 1)) and (var16 = 1 or not(var801
 = 1)) and (var18 = 1 or not(var802 = 1)) and (var19 = 1 or not(var802 = 1)) and
 (var22 = 1 or not(var802 = 1)) and (var23 = 1 or not(var802 = 1)) and (var26 =
1 or not(var802 = 1)) and (var27 = 1 or not(var802 = 1)) and (var29 = 1 or not(
var802 = 1)) and (var32 = 1 or not(var802 = 1)) and (var34 = 1 or not(var803 = 1
)) and (var35 = 1 or not(var803 = 1)) and (var38 = 1 or not(var803 = 1)) and (
var39 = 1 or not(var803 = 1)) and (var42 = 1 or not(var803 = 1)) and (var43 = 1
or not(var803 = 1)) and (var45 = 1 or not(var803 = 1)) and (var48 = 1 or not(
var803 = 1)) and (var50 = 1 or not(var804 = 1)) and (var51 = 1 or not(var804 = 1
)) and (var54 = 1 or not(var804 = 1)) and (var55 = 1 or not(var804 = 1)) and (
var58 = 1 or not(var804 = 1)) and (var59 = 1 or not(var804 = 1)) and (var61 = 1
or not(var804 = 1)) and (var64 = 1 or not(var804 = 1)) and (var66 = 1 or not(
var805 = 1)) and (var67 = 1 or not(var805 = 1)) and (var70 = 1 or not(var805 = 1
)) and (var71 = 1 or not(var805 = 1)) and (var74 = 1 or not(var805 = 1)) and (
var75 = 1 or not(var805 = 1)) and (var77 = 1 or not(var805 = 1)) and (var80 = 1
or not(var805 = 1)) and (var82 = 1 or not(var806 = 1)) and (var83 = 1 or not(
var806 = 1)) and (var86 = 1 or not(var806 = 1)) and (var87 = 1 or not(var806 = 1
)) and (var90 = 1 or not(var806 = 1)) and (var91 = 1 or not(var806 = 1)) and (
var93 = 1 or not(var806 = 1)) and (var96 = 1 or not(var806 = 1)) and (var98 = 1
or not(var807 = 1)) and (var99 = 1 or not(var807 = 1)) and (var102 = 1 or not(
var807 = 1)) and (var103 = 1 or not(var807 = 1)) and (var106 = 1 or not(var807 =
 1)) and (var107 = 1 or not(var807 = 1)) and (var109 = 1 or not(var807 = 1)) and
 (var112 = 1 or not(var807 = 1)) and (var114 = 1 or not(var808 = 1)) and (var115
 = 1 or not(var808 = 1)) and (var118 = 1 or not(var808 = 1)) and (var119 = 1 or
not(var808 = 1)) and (var122 = 1 or not(var808 = 1)) and (var123 = 1 or not(
var808 = 1)) and (var125 = 1 or not(var808 = 1)) and (var128 = 1 or not(var808 =
 1)) and (var130 = 1 or not(var809 = 1)) and (var131 = 1 or not(var809 = 1)) and
 (var134 = 1 or not(var809 = 1)) and (var135 = 1 or not(var809 = 1)) and (var138
 = 1 or not(var809 = 1)) and (var139 = 1 or not(var809 = 1)) and (var141 = 1 or
not(var809 = 1)) and (var144 = 1 or not(var809 = 1)) and (var146 = 1 or not(
var810 = 1)) and (var147 = 1 or not(var810 = 1)) and (var150 = 1 or not(var810 =
 1)) and (var151 = 1 or not(var810 = 1)) and (var154 = 1 or not(var810 = 1)) and
 (var155 = 1 or not(var810 = 1)) and (var157 = 1 or not(var810 = 1)) and (var160
 = 1 or not(var810 = 1)) and (var1 = 1 or not(var811 = 1)) and (var3 = 1 or not(
var811 = 1)) and (var6 = 1 or not(var811 = 1)) and (var8 = 1 or not(var811 = 1))
 and (var9 = 1 or not(var811 = 1)) and (var11 = 1 or not(var811 = 1)) and (var14
 = 1 or not(var811 = 1)) and (var16 = 1 or not(var811 = 1)) and (var17 = 1 or
not(var812 = 1)) and (var19 = 1 or not(var812 = 1)) and (var22 = 1 or not(var812
 = 1)) and (var24 = 1 or not(var812 = 1)) and (var25 = 1 or not(var812 = 1)) and
 (var27 = 1 or not(var812 = 1)) and (var30 = 1 or not(var812 = 1)) and (var32 =
1 or not(var812 = 1)) and (var33 = 1 or not(var813 = 1)) and (var35 = 1 or not(
var813 = 1)) and (var38 = 1 or not(var813 = 1)) and (var40 = 1 or not(var813 = 1
)) and (var41 = 1 or not(var813 = 1)) and (var43 = 1 or not(var813 = 1)) and (
var46 = 1 or not(var813 = 1)) and (var48 = 1 or not(var813 = 1)) and (var49 = 1
or not(var814 = 1)) and (var51 = 1 or not(var814 = 1)) and (var54 = 1 or not(
var814 = 1)) and (var56 = 1 or not(var814 = 1)) and (var57 = 1 or not(var814 = 1
)) and (var59 = 1 or not(var814 = 1)) and (var62 = 1 or not(var814 = 1)) and (
var64 = 1 or not(var814 = 1)) and (var65 = 1 or not(var815 = 1)) and (var67 = 1
or not(var815 = 1)) and (var70 = 1 or not(var815 = 1)) and (var72 = 1 or not(
var815 = 1)) and (var73 = 1 or not(var815 = 1)) and (var75 = 1 or not(var815 = 1
)) and (var78 = 1 or not(var815 = 1)) and (var80 = 1 or not(var815 = 1)) and (
var81 = 1 or not(var816 = 1)) and (var83 = 1 or not(var816 = 1)) and (var86 = 1
or not(var816 = 1)) and (var88 = 1 or not(var816 = 1)) and (var89 = 1 or not(
var816 = 1)) and (var91 = 1 or not(var816 = 1)) and (var94 = 1 or not(var816 = 1
)) and (var96 = 1 or not(var816 = 1)) and (var97 = 1 or not(var817 = 1)) and (
var99 = 1 or not(var817 = 1)) and (var102 = 1 or not(var817 = 1)) and (var104 =
1 or not(var817 = 1)) and (var105 = 1 or not(var817 = 1)) and (var107 = 1 or not
(var817 = 1)) and (var110 = 1 or not(var817 = 1)) and (var112 = 1 or not(var817
= 1)) and (var113 = 1 or not(var818 = 1)) and (var115 = 1 or not(var818 = 1))
and (var118 = 1 or not(var818 = 1)) and (var120 = 1 or not(var818 = 1)) and (
var121 = 1 or not(var818 = 1)) and (var123 = 1 or not(var818 = 1)) and (var126 =
 1 or not(var818 = 1)) and (var128 = 1 or not(var818 = 1)) and (var129 = 1 or
not(var819 = 1)) and (var131 = 1 or not(var819 = 1)) and (var134 = 1 or not(
var819 = 1)) and (var136 = 1 or not(var819 = 1)) and (var137 = 1 or not(var819 =
 1)) and (var139 = 1 or not(var819 = 1)) and (var142 = 1 or not(var819 = 1)) and
 (var144 = 1 or not(var819 = 1)) and (var145 = 1 or not(var820 = 1)) and (var147
 = 1 or not(var820 = 1)) and (var150 = 1 or not(var820 = 1)) and (var152 = 1 or
not(var820 = 1)) and (var153 = 1 or not(var820 = 1)) and (var155 = 1 or not(
var820 = 1)) and (var158 = 1 or not(var820 = 1)) and (var160 = 1 or not(var820 =
 1)) and (var1 = 1 or not(var821 = 1)) and (var4 = 1 or not(var821 = 1)) and (
var5 = 1 or not(var821 = 1)) and (var8 = 1 or not(var821 = 1)) and (var9 = 1 or
not(var821 = 1)) and (var12 = 1 or not(var821 = 1)) and (var14 = 1 or not(var821
 = 1)) and (var16 = 1 or not(var821 = 1)) and (var17 = 1 or not(var822 = 1)) and
 (var20 = 1 or not(var822 = 1)) and (var21 = 1 or not(var822 = 1)) and (var24 =
1 or not(var822 = 1)) and (var25 = 1 or not(var822 = 1)) and (var28 = 1 or not(
var822 = 1)) and (var30 = 1 or not(var822 = 1)) and (var32 = 1 or not(var822 = 1
)) and (var33 = 1 or not(var823 = 1)) and (var36 = 1 or not(var823 = 1)) and (
var37 = 1 or not(var823 = 1)) and (var40 = 1 or not(var823 = 1)) and (var41 = 1
or not(var823 = 1)) and (var44 = 1 or not(var823 = 1)) and (var46 = 1 or not(
var823 = 1)) and (var48 = 1 or not(var823 = 1)) and (var49 = 1 or not(var824 = 1
)) and (var52 = 1 or not(var824 = 1)) and (var53 = 1 or not(var824 = 1)) and (
var56 = 1 or not(var824 = 1)) and (var57 = 1 or not(var824 = 1)) and (var60 = 1
or not(var824 = 1)) and (var62 = 1 or not(var824 = 1)) and (var64 = 1 or not(
var824 = 1)) and (var65 = 1 or not(var825 = 1)) and (var68 = 1 or not(var825 = 1
)) and (var69 = 1 or not(var825 = 1)) and (var72 = 1 or not(var825 = 1)) and (
var73 = 1 or not(var825 = 1)) and (var76 = 1 or not(var825 = 1)) and (var78 = 1
or not(var825 = 1)) and (var80 = 1 or not(var825 = 1)) and (var81 = 1 or not(
var826 = 1)) and (var84 = 1 or not(var826 = 1)) and (var85 = 1 or not(var826 = 1
)) and (var88 = 1 or not(var826 = 1)) and (var89 = 1 or not(var826 = 1)) and (
var92 = 1 or not(var826 = 1)) and (var94 = 1 or not(var826 = 1)) and (var96 = 1
or not(var826 = 1)) and (var97 = 1 or not(var827 = 1)) and (var100 = 1 or not(
var827 = 1)) and (var101 = 1 or not(var827 = 1)) and (var104 = 1 or not(var827 =
 1)) and (var105 = 1 or not(var827 = 1)) and (var108 = 1 or not(var827 = 1)) and
 (var110 = 1 or not(var827 = 1)) and (var112 = 1 or not(var827 = 1)) and (var113
 = 1 or not(var828 = 1)) and (var116 = 1 or not(var828 = 1)) and (var117 = 1 or
not(var828 = 1)) and (var120 = 1 or not(var828 = 1)) and (var121 = 1 or not(
var828 = 1)) and (var124 = 1 or not(var828 = 1)) and (var126 = 1 or not(var828 =
 1)) and (var128 = 1 or not(var828 = 1)) and (var129 = 1 or not(var829 = 1)) and
 (var132 = 1 or not(var829 = 1)) and (var133 = 1 or not(var829 = 1)) and (var136
 = 1 or not(var829 = 1)) and (var137 = 1 or not(var829 = 1)) and (var140 = 1 or
not(var829 = 1)) and (var142 = 1 or not(var829 = 1)) and (var144 = 1 or not(
var829 = 1)) and (var145 = 1 or not(var830 = 1)) and (var148 = 1 or not(var830 =
 1)) and (var149 = 1 or not(var830 = 1)) and (var152 = 1 or not(var830 = 1)) and
 (var153 = 1 or not(var830 = 1)) and (var156 = 1 or not(var830 = 1)) and (var158
 = 1 or not(var830 = 1)) and (var160 = 1 or not(var830 = 1)) and (var1 = 1 or
not(var831 = 1)) and (var3 = 1 or not(var831 = 1)) and (var5 = 1 or not(var831 =
 1)) and (var8 = 1 or not(var831 = 1)) and (var9 = 1 or not(var831 = 1)) and (
var12 = 1 or not(var831 = 1)) and (var14 = 1 or not(var831 = 1)) and (var16 = 1
or not(var831 = 1)) and (var17 = 1 or not(var832 = 1)) and (var19 = 1 or not(
var832 = 1)) and (var21 = 1 or not(var832 = 1)) and (var24 = 1 or not(var832 = 1
)) and (var25 = 1 or not(var832 = 1)) and (var28 = 1 or not(var832 = 1)) and (
var30 = 1 or not(var832 = 1)) and (var32 = 1 or not(var832 = 1)) and (var33 = 1
or not(var833 = 1)) and (var35 = 1 or not(var833 = 1)) and (var37 = 1 or not(
var833 = 1)) and (var40 = 1 or not(var833 = 1)) and (var41 = 1 or not(var833 = 1
)) and (var44 = 1 or not(var833 = 1)) and (var46 = 1 or not(var833 = 1)) and (
var48 = 1 or not(var833 = 1)) and (var49 = 1 or not(var834 = 1)) and (var51 = 1
or not(var834 = 1)) and (var53 = 1 or not(var834 = 1)) and (var56 = 1 or not(
var834 = 1)) and (var57 = 1 or not(var834 = 1)) and (var60 = 1 or not(var834 = 1
)) and (var62 = 1 or not(var834 = 1)) and (var64 = 1 or not(var834 = 1)) and (
var65 = 1 or not(var835 = 1)) and (var67 = 1 or not(var835 = 1)) and (var69 = 1
or not(var835 = 1)) and (var72 = 1 or not(var835 = 1)) and (var73 = 1 or not(
var835 = 1)) and (var76 = 1 or not(var835 = 1)) and (var78 = 1 or not(var835 = 1
)) and (var80 = 1 or not(var835 = 1)) and (var81 = 1 or not(var836 = 1)) and (
var83 = 1 or not(var836 = 1)) and (var85 = 1 or not(var836 = 1)) and (var88 = 1
or not(var836 = 1)) and (var89 = 1 or not(var836 = 1)) and (var92 = 1 or not(
var836 = 1)) and (var94 = 1 or not(var836 = 1)) and (var96 = 1 or not(var836 = 1
)) and (var97 = 1 or not(var837 = 1)) and (var99 = 1 or not(var837 = 1)) and (
var101 = 1 or not(var837 = 1)) and (var104 = 1 or not(var837 = 1)) and (var105 =
 1 or not(var837 = 1)) and (var108 = 1 or not(var837 = 1)) and (var110 = 1 or
not(var837 = 1)) and (var112 = 1 or not(var837 = 1)) and (var113 = 1 or not(
var838 = 1)) and (var115 = 1 or not(var838 = 1)) and (var117 = 1 or not(var838 =
 1)) and (var120 = 1 or not(var838 = 1)) and (var121 = 1 or not(var838 = 1)) and
 (var124 = 1 or not(var838 = 1)) and (var126 = 1 or not(var838 = 1)) and (var128
 = 1 or not(var838 = 1)) and (var129 = 1 or not(var839 = 1)) and (var131 = 1 or
not(var839 = 1)) and (var133 = 1 or not(var839 = 1)) and (var136 = 1 or not(
var839 = 1)) and (var137 = 1 or not(var839 = 1)) and (var140 = 1 or not(var839 =
 1)) and (var142 = 1 or not(var839 = 1)) and (var144 = 1 or not(var839 = 1)) and
 (var145 = 1 or not(var840 = 1)) and (var147 = 1 or not(var840 = 1)) and (var149
 = 1 or not(var840 = 1)) and (var152 = 1 or not(var840 = 1)) and (var153 = 1 or
not(var840 = 1)) and (var156 = 1 or not(var840 = 1)) and (var158 = 1 or not(
var840 = 1)) and (var160 = 1 or not(var840 = 1)) and (var2 = 1 or not(var841 = 1
)) and (var3 = 1 or not(var841 = 1)) and (var5 = 1 or not(var841 = 1)) and (var7
 = 1 or not(var841 = 1)) and (var9 = 1 or not(var841 = 1)) and (var12 = 1 or not
(var841 = 1)) and (var13 = 1 or not(var841 = 1)) and (var15 = 1 or not(var841 =
1)) and (var18 = 1 or not(var842 = 1)) and (var19 = 1 or not(var842 = 1)) and (
var21 = 1 or not(var842 = 1)) and (var23 = 1 or not(var842 = 1)) and (var25 = 1
or not(var842 = 1)) and (var28 = 1 or not(var842 = 1)) and (var29 = 1 or not(
var842 = 1)) and (var31 = 1 or not(var842 = 1)) and (var34 = 1 or not(var843 = 1
)) and (var35 = 1 or not(var843 = 1)) and (var37 = 1 or not(var843 = 1)) and (
var39 = 1 or not(var843 = 1)) and (var41 = 1 or not(var843 = 1)) and (var44 = 1
or not(var843 = 1)) and (var45 = 1 or not(var843 = 1)) and (var47 = 1 or not(
var843 = 1)) and (var50 = 1 or not(var844 = 1)) and (var51 = 1 or not(var844 = 1
)) and (var53 = 1 or not(var844 = 1)) and (var55 = 1 or not(var844 = 1)) and (
var57 = 1 or not(var844 = 1)) and (var60 = 1 or not(var844 = 1)) and (var61 = 1
or not(var844 = 1)) and (var63 = 1 or not(var844 = 1)) and (var66 = 1 or not(
var845 = 1)) and (var67 = 1 or not(var845 = 1)) and (var69 = 1 or not(var845 = 1
)) and (var71 = 1 or not(var845 = 1)) and (var73 = 1 or not(var845 = 1)) and (
var76 = 1 or not(var845 = 1)) and (var77 = 1 or not(var845 = 1)) and (var79 = 1
or not(var845 = 1)) and (var82 = 1 or not(var846 = 1)) and (var83 = 1 or not(
var846 = 1)) and (var85 = 1 or not(var846 = 1)) and (var87 = 1 or not(var846 = 1
)) and (var89 = 1 or not(var846 = 1)) and (var92 = 1 or not(var846 = 1)) and (
var93 = 1 or not(var846 = 1)) and (var95 = 1 or not(var846 = 1)) and (var98 = 1
or not(var847 = 1)) and (var99 = 1 or not(var847 = 1)) and (var101 = 1 or not(
var847 = 1)) and (var103 = 1 or not(var847 = 1)) and (var105 = 1 or not(var847 =
 1)) and (var108 = 1 or not(var847 = 1)) and (var109 = 1 or not(var847 = 1)) and
 (var111 = 1 or not(var847 = 1)) and (var114 = 1 or not(var848 = 1)) and (var115
 = 1 or not(var848 = 1)) and (var117 = 1 or not(var848 = 1)) and (var119 = 1 or
not(var848 = 1)) and (var121 = 1 or not(var848 = 1)) and (var124 = 1 or not(
var848 = 1)) and (var125 = 1 or not(var848 = 1)) and (var127 = 1 or not(var848 =
 1)) and (var130 = 1 or not(var849 = 1)) and (var131 = 1 or not(var849 = 1)) and
 (var133 = 1 or not(var849 = 1)) and (var135 = 1 or not(var849 = 1)) and (var137
 = 1 or not(var849 = 1)) and (var140 = 1 or not(var849 = 1)) and (var141 = 1 or
not(var849 = 1)) and (var143 = 1 or not(var849 = 1)) and (var146 = 1 or not(
var850 = 1)) and (var147 = 1 or not(var850 = 1)) and (var149 = 1 or not(var850 =
 1)) and (var151 = 1 or not(var850 = 1)) and (var153 = 1 or not(var850 = 1)) and
 (var156 = 1 or not(var850 = 1)) and (var157 = 1 or not(var850 = 1)) and (var159
 = 1 or not(var850 = 1)) and (var2 = 1 or not(var851 = 1)) and (var4 = 1 or not(
var851 = 1)) and (var5 = 1 or not(var851 = 1)) and (var8 = 1 or not(var851 = 1))
 and (var9 = 1 or not(var851 = 1)) and (var11 = 1 or not(var851 = 1)) and (var14
 = 1 or not(var851 = 1)) and (var16 = 1 or not(var851 = 1)) and (var18 = 1 or
not(var852 = 1)) and (var20 = 1 or not(var852 = 1)) and (var21 = 1 or not(var852
 = 1)) and (var24 = 1 or not(var852 = 1)) and (var25 = 1 or not(var852 = 1)) and
 (var27 = 1 or not(var852 = 1)) and (var30 = 1 or not(var852 = 1)) and (var32 =
1 or not(var852 = 1)) and (var34 = 1 or not(var853 = 1)) and (var36 = 1 or not(
var853 = 1)) and (var37 = 1 or not(var853 = 1)) and (var40 = 1 or not(var853 = 1
)) and (var41 = 1 or not(var853 = 1)) and (var43 = 1 or not(var853 = 1)) and (
var46 = 1 or not(var853 = 1)) and (var48 = 1 or not(var853 = 1)) and (var50 = 1
or not(var854 = 1)) and (var52 = 1 or not(var854 = 1)) and (var53 = 1 or not(
var854 = 1)) and (var56 = 1 or not(var854 = 1)) and (var57 = 1 or not(var854 = 1
)) and (var59 = 1 or not(var854 = 1)) and (var62 = 1 or not(var854 = 1)) and (
var64 = 1 or not(var854 = 1)) and (var66 = 1 or not(var855 = 1)) and (var68 = 1
or not(var855 = 1)) and (var69 = 1 or not(var855 = 1)) and (var72 = 1 or not(
var855 = 1)) and (var73 = 1 or not(var855 = 1)) and (var75 = 1 or not(var855 = 1
)) and (var78 = 1 or not(var855 = 1)) and (var80 = 1 or not(var855 = 1)) and (
var82 = 1 or not(var856 = 1)) and (var84 = 1 or not(var856 = 1)) and (var85 = 1
or not(var856 = 1)) and (var88 = 1 or not(var856 = 1)) and (var89 = 1 or not(
var856 = 1)) and (var91 = 1 or not(var856 = 1)) and (var94 = 1 or not(var856 = 1
)) and (var96 = 1 or not(var856 = 1)) and (var98 = 1 or not(var857 = 1)) and (
var100 = 1 or not(var857 = 1)) and (var101 = 1 or not(var857 = 1)) and (var104 =
 1 or not(var857 = 1)) and (var105 = 1 or not(var857 = 1)) and (var107 = 1 or
not(var857 = 1)) and (var110 = 1 or not(var857 = 1)) and (var112 = 1 or not(
var857 = 1)) and (var114 = 1 or not(var858 = 1)) and (var116 = 1 or not(var858 =
 1)) and (var117 = 1 or not(var858 = 1)) and (var120 = 1 or not(var858 = 1)) and
 (var121 = 1 or not(var858 = 1)) and (var123 = 1 or not(var858 = 1)) and (var126
 = 1 or not(var858 = 1)) and (var128 = 1 or not(var858 = 1)) and (var130 = 1 or
not(var859 = 1)) and (var132 = 1 or not(var859 = 1)) and (var133 = 1 or not(
var859 = 1)) and (var136 = 1 or not(var859 = 1)) and (var137 = 1 or not(var859 =
 1)) and (var139 = 1 or not(var859 = 1)) and (var142 = 1 or not(var859 = 1)) and
 (var144 = 1 or not(var859 = 1)) and (var146 = 1 or not(var860 = 1)) and (var148
 = 1 or not(var860 = 1)) and (var149 = 1 or not(var860 = 1)) and (var152 = 1 or
not(var860 = 1)) and (var153 = 1 or not(var860 = 1)) and (var155 = 1 or not(
var860 = 1)) and (var158 = 1 or not(var860 = 1)) and (var160 = 1 or not(var860 =
 1)) and (var1 = 1 or not(var861 = 1)) and (var3 = 1 or not(var861 = 1)) and (
var5 = 1 or not(var861 = 1)) and (var7 = 1 or not(var861 = 1)) and (var10 = 1 or
 not(var861 = 1)) and (var12 = 1 or not(var861 = 1)) and (var13 = 1 or not(
var861 = 1)) and (var16 = 1 or not(var861 = 1)) and (var17 = 1 or not(var862 = 1
)) and (var19 = 1 or not(var862 = 1)) and (var21 = 1 or not(var862 = 1)) and (
var23 = 1 or not(var862 = 1)) and (var26 = 1 or not(var862 = 1)) and (var28 = 1
or not(var862 = 1)) and (var29 = 1 or not(var862 = 1)) and (var32 = 1 or not(
var862 = 1)) and (var33 = 1 or not(var863 = 1)) and (var35 = 1 or not(var863 = 1
)) and (var37 = 1 or not(var863 = 1)) and (var39 = 1 or not(var863 = 1)) and (
var42 = 1 or not(var863 = 1)) and (var44 = 1 or not(var863 = 1)) and (var45 = 1
or not(var863 = 1)) and (var48 = 1 or not(var863 = 1)) and (var49 = 1 or not(
var864 = 1)) and (var51 = 1 or not(var864 = 1)) and (var53 = 1 or not(var864 = 1
)) and (var55 = 1 or not(var864 = 1)) and (var58 = 1 or not(var864 = 1)) and (
var60 = 1 or not(var864 = 1)) and (var61 = 1 or not(var864 = 1)) and (var64 = 1
or not(var864 = 1)) and (var65 = 1 or not(var865 = 1)) and (var67 = 1 or not(
var865 = 1)) and (var69 = 1 or not(var865 = 1)) and (var71 = 1 or not(var865 = 1
)) and (var74 = 1 or not(var865 = 1)) and (var76 = 1 or not(var865 = 1)) and (
var77 = 1 or not(var865 = 1)) and (var80 = 1 or not(var865 = 1)) and (var81 = 1
or not(var866 = 1)) and (var83 = 1 or not(var866 = 1)) and (var85 = 1 or not(
var866 = 1)) and (var87 = 1 or not(var866 = 1)) and (var90 = 1 or not(var866 = 1
)) and (var92 = 1 or not(var866 = 1)) and (var93 = 1 or not(var866 = 1)) and (
var96 = 1 or not(var866 = 1)) and (var97 = 1 or not(var867 = 1)) and (var99 = 1
or not(var867 = 1)) and (var101 = 1 or not(var867 = 1)) and (var103 = 1 or not(
var867 = 1)) and (var106 = 1 or not(var867 = 1)) and (var108 = 1 or not(var867 =
 1)) and (var109 = 1 or not(var867 = 1)) and (var112 = 1 or not(var867 = 1)) and
 (var113 = 1 or not(var868 = 1)) and (var115 = 1 or not(var868 = 1)) and (var117
 = 1 or not(var868 = 1)) and (var119 = 1 or not(var868 = 1)) and (var122 = 1 or
not(var868 = 1)) and (var124 = 1 or not(var868 = 1)) and (var125 = 1 or not(
var868 = 1)) and (var128 = 1 or not(var868 = 1)) and (var129 = 1 or not(var869 =
 1)) and (var131 = 1 or not(var869 = 1)) and (var133 = 1 or not(var869 = 1)) and
 (var135 = 1 or not(var869 = 1)) and (var138 = 1 or not(var869 = 1)) and (var140
 = 1 or not(var869 = 1)) and (var141 = 1 or not(var869 = 1)) and (var144 = 1 or
not(var869 = 1)) and (var145 = 1 or not(var870 = 1)) and (var147 = 1 or not(
var870 = 1)) and (var149 = 1 or not(var870 = 1)) and (var151 = 1 or not(var870 =
 1)) and (var154 = 1 or not(var870 = 1)) and (var156 = 1 or not(var870 = 1)) and
 (var157 = 1 or not(var870 = 1)) and (var160 = 1 or not(var870 = 1)) and (var2 =
 1 or not(var871 = 1)) and (var4 = 1 or not(var871 = 1)) and (var5 = 1 or not(
var871 = 1)) and (var8 = 1 or not(var871 = 1)) and (var9 = 1 or not(var871 = 1))
 and (var12 = 1 or not(var871 = 1)) and (var14 = 1 or not(var871 = 1)) and (
var16 = 1 or not(var871 = 1)) and (var18 = 1 or not(var872 = 1)) and (var20 = 1
or not(var872 = 1)) and (var21 = 1 or not(var872 = 1)) and (var24 = 1 or not(
var872 = 1)) and (var25 = 1 or not(var872 = 1)) and (var28 = 1 or not(var872 = 1
)) and (var30 = 1 or not(var872 = 1)) and (var32 = 1 or not(var872 = 1)) and (
var34 = 1 or not(var873 = 1)) and (var36 = 1 or not(var873 = 1)) and (var37 = 1
or not(var873 = 1)) and (var40 = 1 or not(var873 = 1)) and (var41 = 1 or not(
var873 = 1)) and (var44 = 1 or not(var873 = 1)) and (var46 = 1 or not(var873 = 1
)) and (var48 = 1 or not(var873 = 1)) and (var50 = 1 or not(var874 = 1)) and (
var52 = 1 or not(var874 = 1)) and (var53 = 1 or not(var874 = 1)) and (var56 = 1
or not(var874 = 1)) and (var57 = 1 or not(var874 = 1)) and (var60 = 1 or not(
var874 = 1)) and (var62 = 1 or not(var874 = 1)) and (var64 = 1 or not(var874 = 1
)) and (var66 = 1 or not(var875 = 1)) and (var68 = 1 or not(var875 = 1)) and (
var69 = 1 or not(var875 = 1)) and (var72 = 1 or not(var875 = 1)) and (var73 = 1
or not(var875 = 1)) and (var76 = 1 or not(var875 = 1)) and (var78 = 1 or not(
var875 = 1)) and (var80 = 1 or not(var875 = 1)) and (var82 = 1 or not(var876 = 1
)) and (var84 = 1 or not(var876 = 1)) and (var85 = 1 or not(var876 = 1)) and (
var88 = 1 or not(var876 = 1)) and (var89 = 1 or not(var876 = 1)) and (var92 = 1
or not(var876 = 1)) and (var94 = 1 or not(var876 = 1)) and (var96 = 1 or not(
var876 = 1)) and (var98 = 1 or not(var877 = 1)) and (var100 = 1 or not(var877 =
1)) and (var101 = 1 or not(var877 = 1)) and (var104 = 1 or not(var877 = 1)) and
(var105 = 1 or not(var877 = 1)) and (var108 = 1 or not(var877 = 1)) and (var110
= 1 or not(var877 = 1)) and (var112 = 1 or not(var877 = 1)) and (var114 = 1 or
not(var878 = 1)) and (var116 = 1 or not(var878 = 1)) and (var117 = 1 or not(
var878 = 1)) and (var120 = 1 or not(var878 = 1)) and (var121 = 1 or not(var878 =
 1)) and (var124 = 1 or not(var878 = 1)) and (var126 = 1 or not(var878 = 1)) and
 (var128 = 1 or not(var878 = 1)) and (var130 = 1 or not(var879 = 1)) and (var132
 = 1 or not(var879 = 1)) and (var133 = 1 or not(var879 = 1)) and (var136 = 1 or
not(var879 = 1)) and (var137 = 1 or not(var879 = 1)) and (var140 = 1 or not(
var879 = 1)) and (var142 = 1 or not(var879 = 1)) and (var144 = 1 or not(var879 =
 1)) and (var146 = 1 or not(var880 = 1)) and (var148 = 1 or not(var880 = 1)) and
 (var149 = 1 or not(var880 = 1)) and (var152 = 1 or not(var880 = 1)) and (var153
 = 1 or not(var880 = 1)) and (var156 = 1 or not(var880 = 1)) and (var158 = 1 or
not(var880 = 1)) and (var160 = 1 or not(var880 = 1)) and (var1 = 1 or not(var881
 = 1)) and (var3 = 1 or not(var881 = 1)) and (var6 = 1 or not(var881 = 1)) and (
var7 = 1 or not(var881 = 1)) and (var10 = 1 or not(var881 = 1)) and (var12 = 1
or not(var881 = 1)) and (var14 = 1 or not(var881 = 1)) and (var15 = 1 or not(
var881 = 1)) and (var17 = 1 or not(var882 = 1)) and (var19 = 1 or not(var882 = 1
)) and (var22 = 1 or not(var882 = 1)) and (var23 = 1 or not(var882 = 1)) and (
var26 = 1 or not(var882 = 1)) and (var28 = 1 or not(var882 = 1)) and (var30 = 1
or not(var882 = 1)) and (var31 = 1 or not(var882 = 1)) and (var33 = 1 or not(
var883 = 1)) and (var35 = 1 or not(var883 = 1)) and (var38 = 1 or not(var883 = 1
)) and (var39 = 1 or not(var883 = 1)) and (var42 = 1 or not(var883 = 1)) and (
var44 = 1 or not(var883 = 1)) and (var46 = 1 or not(var883 = 1)) and (var47 = 1
or not(var883 = 1)) and (var49 = 1 or not(var884 = 1)) and (var51 = 1 or not(
var884 = 1)) and (var54 = 1 or not(var884 = 1)) and (var55 = 1 or not(var884 = 1
)) and (var58 = 1 or not(var884 = 1)) and (var60 = 1 or not(var884 = 1)) and (
var62 = 1 or not(var884 = 1)) and (var63 = 1 or not(var884 = 1)) and (var65 = 1
or not(var885 = 1)) and (var67 = 1 or not(var885 = 1)) and (var70 = 1 or not(
var885 = 1)) and (var71 = 1 or not(var885 = 1)) and (var74 = 1 or not(var885 = 1
)) and (var76 = 1 or not(var885 = 1)) and (var78 = 1 or not(var885 = 1)) and (
var79 = 1 or not(var885 = 1)) and (var81 = 1 or not(var886 = 1)) and (var83 = 1
or not(var886 = 1)) and (var86 = 1 or not(var886 = 1)) and (var87 = 1 or not(
var886 = 1)) and (var90 = 1 or not(var886 = 1)) and (var92 = 1 or not(var886 = 1
)) and (var94 = 1 or not(var886 = 1)) and (var95 = 1 or not(var886 = 1)) and (
var97 = 1 or not(var887 = 1)) and (var99 = 1 or not(var887 = 1)) and (var102 = 1
 or not(var887 = 1)) and (var103 = 1 or not(var887 = 1)) and (var106 = 1 or not(
var887 = 1)) and (var108 = 1 or not(var887 = 1)) and (var110 = 1 or not(var887 =
 1)) and (var111 = 1 or not(var887 = 1)) and (var113 = 1 or not(var888 = 1)) and
 (var115 = 1 or not(var888 = 1)) and (var118 = 1 or not(var888 = 1)) and (var119
 = 1 or not(var888 = 1)) and (var122 = 1 or not(var888 = 1)) and (var124 = 1 or
not(var888 = 1)) and (var126 = 1 or not(var888 = 1)) and (var127 = 1 or not(
var888 = 1)) and (var129 = 1 or not(var889 = 1)) and (var131 = 1 or not(var889 =
 1)) and (var134 = 1 or not(var889 = 1)) and (var135 = 1 or not(var889 = 1)) and
 (var138 = 1 or not(var889 = 1)) and (var140 = 1 or not(var889 = 1)) and (var142
 = 1 or not(var889 = 1)) and (var143 = 1 or not(var889 = 1)) and (var145 = 1 or
not(var890 = 1)) and (var147 = 1 or not(var890 = 1)) and (var150 = 1 or not(
var890 = 1)) and (var151 = 1 or not(var890 = 1)) and (var154 = 1 or not(var890 =
 1)) and (var156 = 1 or not(var890 = 1)) and (var158 = 1 or not(var890 = 1)) and
 (var159 = 1 or not(var890 = 1)) and (var1 = 1 or not(var891 = 1)) and (var4 = 1
 or not(var891 = 1)) and (var5 = 1 or not(var891 = 1)) and (var7 = 1 or not(
var891 = 1)) and (var10 = 1 or not(var891 = 1)) and (var12 = 1 or not(var891 = 1
)) and (var13 = 1 or not(var891 = 1)) and (var16 = 1 or not(var891 = 1)) and (
var17 = 1 or not(var892 = 1)) and (var20 = 1 or not(var892 = 1)) and (var21 = 1
or not(var892 = 1)) and (var23 = 1 or not(var892 = 1)) and (var26 = 1 or not(
var892 = 1)) and (var28 = 1 or not(var892 = 1)) and (var29 = 1 or not(var892 = 1
)) and (var32 = 1 or not(var892 = 1)) and (var33 = 1 or not(var893 = 1)) and (
var36 = 1 or not(var893 = 1)) and (var37 = 1 or not(var893 = 1)) and (var39 = 1
or not(var893 = 1)) and (var42 = 1 or not(var893 = 1)) and (var44 = 1 or not(
var893 = 1)) and (var45 = 1 or not(var893 = 1)) and (var48 = 1 or not(var893 = 1
)) and (var49 = 1 or not(var894 = 1)) and (var52 = 1 or not(var894 = 1)) and (
var53 = 1 or not(var894 = 1)) and (var55 = 1 or not(var894 = 1)) and (var58 = 1
or not(var894 = 1)) and (var60 = 1 or not(var894 = 1)) and (var61 = 1 or not(
var894 = 1)) and (var64 = 1 or not(var894 = 1)) and (var65 = 1 or not(var895 = 1
)) and (var68 = 1 or not(var895 = 1)) and (var69 = 1 or not(var895 = 1)) and (
var71 = 1 or not(var895 = 1)) and (var74 = 1 or not(var895 = 1)) and (var76 = 1
or not(var895 = 1)) and (var77 = 1 or not(var895 = 1)) and (var80 = 1 or not(
var895 = 1)) and (var81 = 1 or not(var896 = 1)) and (var84 = 1 or not(var896 = 1
)) and (var85 = 1 or not(var896 = 1)) and (var87 = 1 or not(var896 = 1)) and (
var90 = 1 or not(var896 = 1)) and (var92 = 1 or not(var896 = 1)) and (var93 = 1
or not(var896 = 1)) and (var96 = 1 or not(var896 = 1)) and (var97 = 1 or not(
var897 = 1)) and (var100 = 1 or not(var897 = 1)) and (var101 = 1 or not(var897 =
 1)) and (var103 = 1 or not(var897 = 1)) and (var106 = 1 or not(var897 = 1)) and
 (var108 = 1 or not(var897 = 1)) and (var109 = 1 or not(var897 = 1)) and (var112
 = 1 or not(var897 = 1)) and (var113 = 1 or not(var898 = 1)) and (var116 = 1 or
not(var898 = 1)) and (var117 = 1 or not(var898 = 1)) and (var119 = 1 or not(
var898 = 1)) and (var122 = 1 or not(var898 = 1)) and (var124 = 1 or not(var898 =
 1)) and (var125 = 1 or not(var898 = 1)) and (var128 = 1 or not(var898 = 1)) and
 (var129 = 1 or not(var899 = 1)) and (var132 = 1 or not(var899 = 1)) and (var133
 = 1 or not(var899 = 1)) and (var135 = 1 or not(var899 = 1)) and (var138 = 1 or
not(var899 = 1)) and (var140 = 1 or not(var899 = 1)) and (var141 = 1 or not(
var899 = 1)) and (var144 = 1 or not(var899 = 1)) and (var145 = 1 or not(var900 =
 1)) and (var148 = 1 or not(var900 = 1)) and (var149 = 1 or not(var900 = 1)) and
 (var151 = 1 or not(var900 = 1)) and (var154 = 1 or not(var900 = 1)) and (var156
 = 1 or not(var900 = 1)) and (var157 = 1 or not(var900 = 1)) and (var160 = 1 or
not(var900 = 1)) and (var1 = 1 or not(var901 = 1)) and (var3 = 1 or not(var901 =
 1)) and (var6 = 1 or not(var901 = 1)) and (var7 = 1 or not(var901 = 1)) and (
var10 = 1 or not(var901 = 1)) and (var12 = 1 or not(var901 = 1)) and (var14 = 1
or not(var901 = 1)) and (var15 = 1 or not(var901 = 1)) and (var17 = 1 or not(
var902 = 1)) and (var19 = 1 or not(var902 = 1)) and (var22 = 1 or not(var902 = 1
)) and (var23 = 1 or not(var902 = 1)) and (var26 = 1 or not(var902 = 1)) and (
var28 = 1 or not(var902 = 1)) and (var30 = 1 or not(var902 = 1)) and (var31 = 1
or not(var902 = 1)) and (var33 = 1 or not(var903 = 1)) and (var35 = 1 or not(
var903 = 1)) and (var38 = 1 or not(var903 = 1)) and (var39 = 1 or not(var903 = 1
)) and (var42 = 1 or not(var903 = 1)) and (var44 = 1 or not(var903 = 1)) and (
var46 = 1 or not(var903 = 1)) and (var47 = 1 or not(var903 = 1)) and (var49 = 1
or not(var904 = 1)) and (var51 = 1 or not(var904 = 1)) and (var54 = 1 or not(
var904 = 1)) and (var55 = 1 or not(var904 = 1)) and (var58 = 1 or not(var904 = 1
)) and (var60 = 1 or not(var904 = 1)) and (var62 = 1 or not(var904 = 1)) and (
var63 = 1 or not(var904 = 1)) and (var65 = 1 or not(var905 = 1)) and (var67 = 1
or not(var905 = 1)) and (var70 = 1 or not(var905 = 1)) and (var71 = 1 or not(
var905 = 1)) and (var74 = 1 or not(var905 = 1)) and (var76 = 1 or not(var905 = 1
)) and (var78 = 1 or not(var905 = 1)) and (var79 = 1 or not(var905 = 1)) and (
var81 = 1 or not(var906 = 1)) and (var83 = 1 or not(var906 = 1)) and (var86 = 1
or not(var906 = 1)) and (var87 = 1 or not(var906 = 1)) and (var90 = 1 or not(
var906 = 1)) and (var92 = 1 or not(var906 = 1)) and (var94 = 1 or not(var906 = 1
)) and (var95 = 1 or not(var906 = 1)) and (var97 = 1 or not(var907 = 1)) and (
var99 = 1 or not(var907 = 1)) and (var102 = 1 or not(var907 = 1)) and (var103 =
1 or not(var907 = 1)) and (var106 = 1 or not(var907 = 1)) and (var108 = 1 or not
(var907 = 1)) and (var110 = 1 or not(var907 = 1)) and (var111 = 1 or not(var907
= 1)) and (var113 = 1 or not(var908 = 1)) and (var115 = 1 or not(var908 = 1))
and (var118 = 1 or not(var908 = 1)) and (var119 = 1 or not(var908 = 1)) and (
var122 = 1 or not(var908 = 1)) and (var124 = 1 or not(var908 = 1)) and (var126 =
 1 or not(var908 = 1)) and (var127 = 1 or not(var908 = 1)) and (var129 = 1 or
not(var909 = 1)) and (var131 = 1 or not(var909 = 1)) and (var134 = 1 or not(
var909 = 1)) and (var135 = 1 or not(var909 = 1)) and (var138 = 1 or not(var909 =
 1)) and (var140 = 1 or not(var909 = 1)) and (var142 = 1 or not(var909 = 1)) and
 (var143 = 1 or not(var909 = 1)) and (var145 = 1 or not(var910 = 1)) and (var147
 = 1 or not(var910 = 1)) and (var150 = 1 or not(var910 = 1)) and (var151 = 1 or
not(var910 = 1)) and (var154 = 1 or not(var910 = 1)) and (var156 = 1 or not(
var910 = 1)) and (var158 = 1 or not(var910 = 1)) and (var159 = 1 or not(var910 =
 1)) and (var2 = 1 or not(var911 = 1)) and (var4 = 1 or not(var911 = 1)) and (
var5 = 1 or not(var911 = 1)) and (var7 = 1 or not(var911 = 1)) and (var10 = 1 or
 not(var911 = 1)) and (var12 = 1 or not(var911 = 1)) and (var13 = 1 or not(
var911 = 1)) and (var16 = 1 or not(var911 = 1)) and (var18 = 1 or not(var912 = 1
)) and (var20 = 1 or not(var912 = 1)) and (var21 = 1 or not(var912 = 1)) and (
var23 = 1 or not(var912 = 1)) and (var26 = 1 or not(var912 = 1)) and (var28 = 1
or not(var912 = 1)) and (var29 = 1 or not(var912 = 1)) and (var32 = 1 or not(
var912 = 1)) and (var34 = 1 or not(var913 = 1)) and (var36 = 1 or not(var913 = 1
)) and (var37 = 1 or not(var913 = 1)) and (var39 = 1 or not(var913 = 1)) and (
var42 = 1 or not(var913 = 1)) and (var44 = 1 or not(var913 = 1)) and (var45 = 1
or not(var913 = 1)) and (var48 = 1 or not(var913 = 1)) and (var50 = 1 or not(
var914 = 1)) and (var52 = 1 or not(var914 = 1)) and (var53 = 1 or not(var914 = 1
)) and (var55 = 1 or not(var914 = 1)) and (var58 = 1 or not(var914 = 1)) and (
var60 = 1 or not(var914 = 1)) and (var61 = 1 or not(var914 = 1)) and (var64 = 1
or not(var914 = 1)) and (var66 = 1 or not(var915 = 1)) and (var68 = 1 or not(
var915 = 1)) and (var69 = 1 or not(var915 = 1)) and (var71 = 1 or not(var915 = 1
)) and (var74 = 1 or not(var915 = 1)) and (var76 = 1 or not(var915 = 1)) and (
var77 = 1 or not(var915 = 1)) and (var80 = 1 or not(var915 = 1)) and (var82 = 1
or not(var916 = 1)) and (var84 = 1 or not(var916 = 1)) and (var85 = 1 or not(
var916 = 1)) and (var87 = 1 or not(var916 = 1)) and (var90 = 1 or not(var916 = 1
)) and (var92 = 1 or not(var916 = 1)) and (var93 = 1 or not(var916 = 1)) and (
var96 = 1 or not(var916 = 1)) and (var98 = 1 or not(var917 = 1)) and (var100 = 1
 or not(var917 = 1)) and (var101 = 1 or not(var917 = 1)) and (var103 = 1 or not(
var917 = 1)) and (var106 = 1 or not(var917 = 1)) and (var108 = 1 or not(var917 =
 1)) and (var109 = 1 or not(var917 = 1)) and (var112 = 1 or not(var917 = 1)) and
 (var114 = 1 or not(var918 = 1)) and (var116 = 1 or not(var918 = 1)) and (var117
 = 1 or not(var918 = 1)) and (var119 = 1 or not(var918 = 1)) and (var122 = 1 or
not(var918 = 1)) and (var124 = 1 or not(var918 = 1)) and (var125 = 1 or not(
var918 = 1)) and (var128 = 1 or not(var918 = 1)) and (var130 = 1 or not(var919 =
 1)) and (var132 = 1 or not(var919 = 1)) and (var133 = 1 or not(var919 = 1)) and
 (var135 = 1 or not(var919 = 1)) and (var138 = 1 or not(var919 = 1)) and (var140
 = 1 or not(var919 = 1)) and (var141 = 1 or not(var919 = 1)) and (var144 = 1 or
not(var919 = 1)) and (var146 = 1 or not(var920 = 1)) and (var148 = 1 or not(
var920 = 1)) and (var149 = 1 or not(var920 = 1)) and (var151 = 1 or not(var920 =
 1)) and (var154 = 1 or not(var920 = 1)) and (var156 = 1 or not(var920 = 1)) and
 (var157 = 1 or not(var920 = 1)) and (var160 = 1 or not(var920 = 1)) and (var2 =
 1 or not(var921 = 1)) and (var4 = 1 or not(var921 = 1)) and (var6 = 1 or not(
var921 = 1)) and (var7 = 1 or not(var921 = 1)) and (var10 = 1 or not(var921 = 1)
) and (var12 = 1 or not(var921 = 1)) and (var13 = 1 or not(var921 = 1)) and (
var16 = 1 or not(var921 = 1)) and (var18 = 1 or not(var922 = 1)) and (var20 = 1
or not(var922 = 1)) and (var22 = 1 or not(var922 = 1)) and (var23 = 1 or not(
var922 = 1)) and (var26 = 1 or not(var922 = 1)) and (var28 = 1 or not(var922 = 1
)) and (var29 = 1 or not(var922 = 1)) and (var32 = 1 or not(var922 = 1)) and (
var34 = 1 or not(var923 = 1)) and (var36 = 1 or not(var923 = 1)) and (var38 = 1
or not(var923 = 1)) and (var39 = 1 or not(var923 = 1)) and (var42 = 1 or not(
var923 = 1)) and (var44 = 1 or not(var923 = 1)) and (var45 = 1 or not(var923 = 1
)) and (var48 = 1 or not(var923 = 1)) and (var50 = 1 or not(var924 = 1)) and (
var52 = 1 or not(var924 = 1)) and (var54 = 1 or not(var924 = 1)) and (var55 = 1
or not(var924 = 1)) and (var58 = 1 or not(var924 = 1)) and (var60 = 1 or not(
var924 = 1)) and (var61 = 1 or not(var924 = 1)) and (var64 = 1 or not(var924 = 1
)) and (var66 = 1 or not(var925 = 1)) and (var68 = 1 or not(var925 = 1)) and (
var70 = 1 or not(var925 = 1)) and (var71 = 1 or not(var925 = 1)) and (var74 = 1
or not(var925 = 1)) and (var76 = 1 or not(var925 = 1)) and (var77 = 1 or not(
var925 = 1)) and (var80 = 1 or not(var925 = 1)) and (var82 = 1 or not(var926 = 1
)) and (var84 = 1 or not(var926 = 1)) and (var86 = 1 or not(var926 = 1)) and (
var87 = 1 or not(var926 = 1)) and (var90 = 1 or not(var926 = 1)) and (var92 = 1
or not(var926 = 1)) and (var93 = 1 or not(var926 = 1)) and (var96 = 1 or not(
var926 = 1)) and (var98 = 1 or not(var927 = 1)) and (var100 = 1 or not(var927 =
1)) and (var102 = 1 or not(var927 = 1)) and (var103 = 1 or not(var927 = 1)) and
(var106 = 1 or not(var927 = 1)) and (var108 = 1 or not(var927 = 1)) and (var109
= 1 or not(var927 = 1)) and (var112 = 1 or not(var927 = 1)) and (var114 = 1 or
not(var928 = 1)) and (var116 = 1 or not(var928 = 1)) and (var118 = 1 or not(
var928 = 1)) and (var119 = 1 or not(var928 = 1)) and (var122 = 1 or not(var928 =
 1)) and (var124 = 1 or not(var928 = 1)) and (var125 = 1 or not(var928 = 1)) and
 (var128 = 1 or not(var928 = 1)) and (var130 = 1 or not(var929 = 1)) and (var132
 = 1 or not(var929 = 1)) and (var134 = 1 or not(var929 = 1)) and (var135 = 1 or
not(var929 = 1)) and (var138 = 1 or not(var929 = 1)) and (var140 = 1 or not(
var929 = 1)) and (var141 = 1 or not(var929 = 1)) and (var144 = 1 or not(var929 =
 1)) and (var146 = 1 or not(var930 = 1)) and (var148 = 1 or not(var930 = 1)) and
 (var150 = 1 or not(var930 = 1)) and (var151 = 1 or not(var930 = 1)) and (var154
 = 1 or not(var930 = 1)) and (var156 = 1 or not(var930 = 1)) and (var157 = 1 or
not(var930 = 1)) and (var160 = 1 or not(var930 = 1)) and (var1 = 1 or not(var931
 = 1)) and (var3 = 1 or not(var931 = 1)) and (var6 = 1 or not(var931 = 1)) and (
var8 = 1 or not(var931 = 1)) and (var10 = 1 or not(var931 = 1)) and (var11 = 1
or not(var931 = 1)) and (var13 = 1 or not(var931 = 1)) and (var15 = 1 or not(
var931 = 1)) and (var17 = 1 or not(var932 = 1)) and (var19 = 1 or not(var932 = 1
)) and (var22 = 1 or not(var932 = 1)) and (var24 = 1 or not(var932 = 1)) and (
var26 = 1 or not(var932 = 1)) and (var27 = 1 or not(var932 = 1)) and (var29 = 1
or not(var932 = 1)) and (var31 = 1 or not(var932 = 1)) and (var33 = 1 or not(
var933 = 1)) and (var35 = 1 or not(var933 = 1)) and (var38 = 1 or not(var933 = 1
)) and (var40 = 1 or not(var933 = 1)) and (var42 = 1 or not(var933 = 1)) and (
var43 = 1 or not(var933 = 1)) and (var45 = 1 or not(var933 = 1)) and (var47 = 1
or not(var933 = 1)) and (var49 = 1 or not(var934 = 1)) and (var51 = 1 or not(
var934 = 1)) and (var54 = 1 or not(var934 = 1)) and (var56 = 1 or not(var934 = 1
)) and (var58 = 1 or not(var934 = 1)) and (var59 = 1 or not(var934 = 1)) and (
var61 = 1 or not(var934 = 1)) and (var63 = 1 or not(var934 = 1)) and (var65 = 1
or not(var935 = 1)) and (var67 = 1 or not(var935 = 1)) and (var70 = 1 or not(
var935 = 1)) and (var72 = 1 or not(var935 = 1)) and (var74 = 1 or not(var935 = 1
)) and (var75 = 1 or not(var935 = 1)) and (var77 = 1 or not(var935 = 1)) and (
var79 = 1 or not(var935 = 1)) and (var81 = 1 or not(var936 = 1)) and (var83 = 1
or not(var936 = 1)) and (var86 = 1 or not(var936 = 1)) and (var88 = 1 or not(
var936 = 1)) and (var90 = 1 or not(var936 = 1)) and (var91 = 1 or not(var936 = 1
)) and (var93 = 1 or not(var936 = 1)) and (var95 = 1 or not(var936 = 1)) and (
var97 = 1 or not(var937 = 1)) and (var99 = 1 or not(var937 = 1)) and (var102 = 1
 or not(var937 = 1)) and (var104 = 1 or not(var937 = 1)) and (var106 = 1 or not(
var937 = 1)) and (var107 = 1 or not(var937 = 1)) and (var109 = 1 or not(var937 =
 1)) and (var111 = 1 or not(var937 = 1)) and (var113 = 1 or not(var938 = 1)) and
 (var115 = 1 or not(var938 = 1)) and (var118 = 1 or not(var938 = 1)) and (var120
 = 1 or not(var938 = 1)) and (var122 = 1 or not(var938 = 1)) and (var123 = 1 or
not(var938 = 1)) and (var125 = 1 or not(var938 = 1)) and (var127 = 1 or not(
var938 = 1)) and (var129 = 1 or not(var939 = 1)) and (var131 = 1 or not(var939 =
 1)) and (var134 = 1 or not(var939 = 1)) and (var136 = 1 or not(var939 = 1)) and
 (var138 = 1 or not(var939 = 1)) and (var139 = 1 or not(var939 = 1)) and (var141
 = 1 or not(var939 = 1)) and (var143 = 1 or not(var939 = 1)) and (var145 = 1 or
not(var940 = 1)) and (var147 = 1 or not(var940 = 1)) and (var150 = 1 or not(
var940 = 1)) and (var152 = 1 or not(var940 = 1)) and (var154 = 1 or not(var940 =
 1)) and (var155 = 1 or not(var940 = 1)) and (var157 = 1 or not(var940 = 1)) and
 (var159 = 1 or not(var940 = 1)) and (var2 = 1 or not(var941 = 1)) and (var3 = 1
 or not(var941 = 1)) and (var6 = 1 or not(var941 = 1)) and (var8 = 1 or not(
var941 = 1)) and (var10 = 1 or not(var941 = 1)) and (var11 = 1 or not(var941 = 1
)) and (var13 = 1 or not(var941 = 1)) and (var15 = 1 or not(var941 = 1)) and (
var18 = 1 or not(var942 = 1)) and (var19 = 1 or not(var942 = 1)) and (var22 = 1
or not(var942 = 1)) and (var24 = 1 or not(var942 = 1)) and (var26 = 1 or not(
var942 = 1)) and (var27 = 1 or not(var942 = 1)) and (var29 = 1 or not(var942 = 1
)) and (var31 = 1 or not(var942 = 1)) and (var34 = 1 or not(var943 = 1)) and (
var35 = 1 or not(var943 = 1)) and (var38 = 1 or not(var943 = 1)) and (var40 = 1
or not(var943 = 1)) and (var42 = 1 or not(var943 = 1)) and (var43 = 1 or not(
var943 = 1)) and (var45 = 1 or not(var943 = 1)) and (var47 = 1 or not(var943 = 1
)) and (var50 = 1 or not(var944 = 1)) and (var51 = 1 or not(var944 = 1)) and (
var54 = 1 or not(var944 = 1)) and (var56 = 1 or not(var944 = 1)) and (var58 = 1
or not(var944 = 1)) and (var59 = 1 or not(var944 = 1)) and (var61 = 1 or not(
var944 = 1)) and (var63 = 1 or not(var944 = 1)) and (var66 = 1 or not(var945 = 1
)) and (var67 = 1 or not(var945 = 1)) and (var70 = 1 or not(var945 = 1)) and (
var72 = 1 or not(var945 = 1)) and (var74 = 1 or not(var945 = 1)) and (var75 = 1
or not(var945 = 1)) and (var77 = 1 or not(var945 = 1)) and (var79 = 1 or not(
var945 = 1)) and (var82 = 1 or not(var946 = 1)) and (var83 = 1 or not(var946 = 1
)) and (var86 = 1 or not(var946 = 1)) and (var88 = 1 or not(var946 = 1)) and (
var90 = 1 or not(var946 = 1)) and (var91 = 1 or not(var946 = 1)) and (var93 = 1
or not(var946 = 1)) and (var95 = 1 or not(var946 = 1)) and (var98 = 1 or not(
var947 = 1)) and (var99 = 1 or not(var947 = 1)) and (var102 = 1 or not(var947 =
1)) and (var104 = 1 or not(var947 = 1)) and (var106 = 1 or not(var947 = 1)) and
(var107 = 1 or not(var947 = 1)) and (var109 = 1 or not(var947 = 1)) and (var111
= 1 or not(var947 = 1)) and (var114 = 1 or not(var948 = 1)) and (var115 = 1 or
not(var948 = 1)) and (var118 = 1 or not(var948 = 1)) and (var120 = 1 or not(
var948 = 1)) and (var122 = 1 or not(var948 = 1)) and (var123 = 1 or not(var948 =
 1)) and (var125 = 1 or not(var948 = 1)) and (var127 = 1 or not(var948 = 1)) and
 (var130 = 1 or not(var949 = 1)) and (var131 = 1 or not(var949 = 1)) and (var134
 = 1 or not(var949 = 1)) and (var136 = 1 or not(var949 = 1)) and (var138 = 1 or
not(var949 = 1)) and (var139 = 1 or not(var949 = 1)) and (var141 = 1 or not(
var949 = 1)) and (var143 = 1 or not(var949 = 1)) and (var146 = 1 or not(var950 =
 1)) and (var147 = 1 or not(var950 = 1)) and (var150 = 1 or not(var950 = 1)) and
 (var152 = 1 or not(var950 = 1)) and (var154 = 1 or not(var950 = 1)) and (var155
 = 1 or not(var950 = 1)) and (var157 = 1 or not(var950 = 1)) and (var159 = 1 or
not(var950 = 1)) and (var161 = 1 or var162 = 1 or var163 = 1 or var164 = 1 or
var165 = 1 or var166 = 1 or var167 = 1 or var168 = 1 or var169 = 1 or var170 = 1
) and (var171 = 1 or var172 = 1 or var173 = 1 or var174 = 1 or var175 = 1 or
var176 = 1 or var177 = 1 or var178 = 1 or var179 = 1 or var180 = 1) and (var181
= 1 or var182 = 1 or var183 = 1 or var184 = 1 or var185 = 1 or var186 = 1 or
var187 = 1 or var188 = 1 or var189 = 1 or var190 = 1) and (var191 = 1 or var192
= 1 or var193 = 1 or var194 = 1 or var195 = 1 or var196 = 1 or var197 = 1 or
var198 = 1 or var199 = 1 or var200 = 1) and (var201 = 1 or var202 = 1 or var203
= 1 or var204 = 1 or var205 = 1 or var206 = 1 or var207 = 1 or var208 = 1 or
var209 = 1 or var210 = 1) and (var211 = 1 or var212 = 1 or var213 = 1 or var214
= 1 or var215 = 1 or var216 = 1 or var217 = 1 or var218 = 1 or var219 = 1 or
var220 = 1) and (var221 = 1 or var222 = 1 or var223 = 1 or var224 = 1 or var225
= 1 or var226 = 1 or var227 = 1 or var228 = 1 or var229 = 1 or var230 = 1) and (
var231 = 1 or var232 = 1 or var233 = 1 or var234 = 1 or var235 = 1 or var236 = 1
 or var237 = 1 or var238 = 1 or var239 = 1 or var240 = 1) and (var241 = 1 or
var242 = 1 or var243 = 1 or var244 = 1 or var245 = 1 or var246 = 1 or var247 = 1
 or var248 = 1 or var249 = 1 or var250 = 1) and (var251 = 1 or var252 = 1 or
var253 = 1 or var254 = 1 or var255 = 1 or var256 = 1 or var257 = 1 or var258 = 1
 or var259 = 1 or var260 = 1) and (var261 = 1 or var262 = 1 or var263 = 1 or
var264 = 1 or var265 = 1 or var266 = 1 or var267 = 1 or var268 = 1 or var269 = 1
 or var270 = 1) and (var271 = 1 or var272 = 1 or var273 = 1 or var274 = 1 or
var275 = 1 or var276 = 1 or var277 = 1 or var278 = 1 or var279 = 1 or var280 = 1
) and (var281 = 1 or var282 = 1 or var283 = 1 or var284 = 1 or var285 = 1 or
var286 = 1 or var287 = 1 or var288 = 1 or var289 = 1 or var290 = 1) and (var291
= 1 or var292 = 1 or var293 = 1 or var294 = 1 or var295 = 1 or var296 = 1 or
var297 = 1 or var298 = 1 or var299 = 1 or var300 = 1) and (var301 = 1 or var302
= 1 or var303 = 1 or var304 = 1 or var305 = 1 or var306 = 1 or var307 = 1 or
var308 = 1 or var309 = 1 or var310 = 1) and (var311 = 1 or var312 = 1 or var313
= 1 or var314 = 1 or var315 = 1 or var316 = 1 or var317 = 1 or var318 = 1 or
var319 = 1 or var320 = 1) and (var321 = 1 or var322 = 1 or var323 = 1 or var324
= 1 or var325 = 1 or var326 = 1 or var327 = 1 or var328 = 1 or var329 = 1 or
var330 = 1) and (var331 = 1 or var332 = 1 or var333 = 1 or var334 = 1 or var335
= 1 or var336 = 1 or var337 = 1 or var338 = 1 or var339 = 1 or var340 = 1) and (
var341 = 1 or var342 = 1 or var343 = 1 or var344 = 1 or var345 = 1 or var346 = 1
 or var347 = 1 or var348 = 1 or var349 = 1 or var350 = 1) and (var351 = 1 or
var352 = 1 or var353 = 1 or var354 = 1 or var355 = 1 or var356 = 1 or var357 = 1
 or var358 = 1 or var359 = 1 or var360 = 1) and (var361 = 1 or var362 = 1 or
var363 = 1 or var364 = 1 or var365 = 1 or var366 = 1 or var367 = 1 or var368 = 1
 or var369 = 1 or var370 = 1) and (var371 = 1 or var372 = 1 or var373 = 1 or
var374 = 1 or var375 = 1 or var376 = 1 or var377 = 1 or var378 = 1 or var379 = 1
 or var380 = 1) and (var381 = 1 or var382 = 1 or var383 = 1 or var384 = 1 or
var385 = 1 or var386 = 1 or var387 = 1 or var388 = 1 or var389 = 1 or var390 = 1
) and (var391 = 1 or var392 = 1 or var393 = 1 or var394 = 1 or var395 = 1 or
var396 = 1 or var397 = 1 or var398 = 1 or var399 = 1 or var400 = 1) and (var401
= 1 or var402 = 1 or var403 = 1 or var404 = 1 or var405 = 1 or var406 = 1 or
var407 = 1 or var408 = 1 or var409 = 1 or var410 = 1) and (var411 = 1 or var412
= 1 or var413 = 1 or var414 = 1 or var415 = 1 or var416 = 1 or var417 = 1 or
var418 = 1 or var419 = 1 or var420 = 1) and (var421 = 1 or var422 = 1 or var423
= 1 or var424 = 1 or var425 = 1 or var426 = 1 or var427 = 1 or var428 = 1 or
var429 = 1 or var430 = 1) and (var431 = 1 or var432 = 1 or var433 = 1 or var434
= 1 or var435 = 1 or var436 = 1 or var437 = 1 or var438 = 1 or var439 = 1 or
var440 = 1) and (var441 = 1 or var442 = 1 or var443 = 1 or var444 = 1 or var445
= 1 or var446 = 1 or var447 = 1 or var448 = 1 or var449 = 1 or var450 = 1) and (
var451 = 1 or var452 = 1 or var453 = 1 or var454 = 1 or var455 = 1 or var456 = 1
 or var457 = 1 or var458 = 1 or var459 = 1 or var460 = 1) and (var461 = 1 or
var462 = 1 or var463 = 1 or var464 = 1 or var465 = 1 or var466 = 1 or var467 = 1
 or var468 = 1 or var469 = 1 or var470 = 1) and (var471 = 1 or var472 = 1 or
var473 = 1 or var474 = 1 or var475 = 1 or var476 = 1 or var477 = 1 or var478 = 1
 or var479 = 1 or var480 = 1) and (var481 = 1 or var482 = 1 or var483 = 1 or
var484 = 1 or var485 = 1 or var486 = 1 or var487 = 1 or var488 = 1 or var489 = 1
 or var490 = 1) and (var491 = 1 or var492 = 1 or var493 = 1 or var494 = 1 or
var495 = 1 or var496 = 1 or var497 = 1 or var498 = 1 or var499 = 1 or var500 = 1
) and (var501 = 1 or var502 = 1 or var503 = 1 or var504 = 1 or var505 = 1 or
var506 = 1 or var507 = 1 or var508 = 1 or var509 = 1 or var510 = 1) and (var511
= 1 or var512 = 1 or var513 = 1 or var514 = 1 or var515 = 1 or var516 = 1 or
var517 = 1 or var518 = 1 or var519 = 1 or var520 = 1) and (var521 = 1 or var522
= 1 or var523 = 1 or var524 = 1 or var525 = 1 or var526 = 1 or var527 = 1 or
var528 = 1 or var529 = 1 or var530 = 1) and (var531 = 1 or var532 = 1 or var533
= 1 or var534 = 1 or var535 = 1 or var536 = 1 or var537 = 1 or var538 = 1 or
var539 = 1 or var540 = 1) and (var541 = 1 or var542 = 1 or var543 = 1 or var544
= 1 or var545 = 1 or var546 = 1 or var547 = 1 or var548 = 1 or var549 = 1 or
var550 = 1) and (var551 = 1 or var552 = 1 or var553 = 1 or var554 = 1 or var555
= 1 or var556 = 1 or var557 = 1 or var558 = 1 or var559 = 1 or var560 = 1) and (
var561 = 1 or var562 = 1 or var563 = 1 or var564 = 1 or var565 = 1 or var566 = 1
 or var567 = 1 or var568 = 1 or var569 = 1 or var570 = 1) and (var571 = 1 or
var572 = 1 or var573 = 1 or var574 = 1 or var575 = 1 or var576 = 1 or var577 = 1
 or var578 = 1 or var579 = 1 or var580 = 1) and (var581 = 1 or var582 = 1 or
var583 = 1 or var584 = 1 or var585 = 1 or var586 = 1 or var587 = 1 or var588 = 1
 or var589 = 1 or var590 = 1) and (var591 = 1 or var592 = 1 or var593 = 1 or
var594 = 1 or var595 = 1 or var596 = 1 or var597 = 1 or var598 = 1 or var599 = 1
 or var600 = 1) and (var601 = 1 or var602 = 1 or var603 = 1 or var604 = 1 or
var605 = 1 or var606 = 1 or var607 = 1 or var608 = 1 or var609 = 1 or var610 = 1
) and (var611 = 1 or var612 = 1 or var613 = 1 or var614 = 1 or var615 = 1 or
var616 = 1 or var617 = 1 or var618 = 1 or var619 = 1 or var620 = 1) and (var621
= 1 or var622 = 1 or var623 = 1 or var624 = 1 or var625 = 1 or var626 = 1 or
var627 = 1 or var628 = 1 or var629 = 1 or var630 = 1) and (var631 = 1 or var632
= 1 or var633 = 1 or var634 = 1 or var635 = 1 or var636 = 1 or var637 = 1 or
var638 = 1 or var639 = 1 or var640 = 1) and (var641 = 1 or var642 = 1 or var643
= 1 or var644 = 1 or var645 = 1 or var646 = 1 or var647 = 1 or var648 = 1 or
var649 = 1 or var650 = 1) and (var651 = 1 or var652 = 1 or var653 = 1 or var654
= 1 or var655 = 1 or var656 = 1 or var657 = 1 or var658 = 1 or var659 = 1 or
var660 = 1) and (var661 = 1 or var662 = 1 or var663 = 1 or var664 = 1 or var665
= 1 or var666 = 1 or var667 = 1 or var668 = 1 or var669 = 1 or var670 = 1) and (
var671 = 1 or var672 = 1 or var673 = 1 or var674 = 1 or var675 = 1 or var676 = 1
 or var677 = 1 or var678 = 1 or var679 = 1 or var680 = 1) and (var681 = 1 or
var682 = 1 or var683 = 1 or var684 = 1 or var685 = 1 or var686 = 1 or var687 = 1
 or var688 = 1 or var689 = 1 or var690 = 1) and (var691 = 1 or var692 = 1 or
var693 = 1 or var694 = 1 or var695 = 1 or var696 = 1 or var697 = 1 or var698 = 1
 or var699 = 1 or var700 = 1) and (var701 = 1 or var702 = 1 or var703 = 1 or
var704 = 1 or var705 = 1 or var706 = 1 or var707 = 1 or var708 = 1 or var709 = 1
 or var710 = 1) and (var711 = 1 or var712 = 1 or var713 = 1 or var714 = 1 or
var715 = 1 or var716 = 1 or var717 = 1 or var718 = 1 or var719 = 1 or var720 = 1
) and (var721 = 1 or var722 = 1 or var723 = 1 or var724 = 1 or var725 = 1 or
var726 = 1 or var727 = 1 or var728 = 1 or var729 = 1 or var730 = 1) and (var731
= 1 or var732 = 1 or var733 = 1 or var734 = 1 or var735 = 1 or var736 = 1 or
var737 = 1 or var738 = 1 or var739 = 1 or var740 = 1) and (var741 = 1 or var742
= 1 or var743 = 1 or var744 = 1 or var745 = 1 or var746 = 1 or var747 = 1 or
var748 = 1 or var749 = 1 or var750 = 1) and (var751 = 1 or var752 = 1 or var753
= 1 or var754 = 1 or var755 = 1 or var756 = 1 or var757 = 1 or var758 = 1 or
var759 = 1 or var760 = 1) and (var761 = 1 or var762 = 1 or var763 = 1 or var764
= 1 or var765 = 1 or var766 = 1 or var767 = 1 or var768 = 1 or var769 = 1 or
var770 = 1) and (var771 = 1 or var772 = 1 or var773 = 1 or var774 = 1 or var775
= 1 or var776 = 1 or var777 = 1 or var778 = 1 or var779 = 1 or var780 = 1) and (
var781 = 1 or var782 = 1 or var783 = 1 or var784 = 1 or var785 = 1 or var786 = 1
 or var787 = 1 or var788 = 1 or var789 = 1 or var790 = 1) and (var791 = 1 or
var792 = 1 or var793 = 1 or var794 = 1 or var795 = 1 or var796 = 1 or var797 = 1
 or var798 = 1 or var799 = 1 or var800 = 1) and (var801 = 1 or var802 = 1 or
var803 = 1 or var804 = 1 or var805 = 1 or var806 = 1 or var807 = 1 or var808 = 1
 or var809 = 1 or var810 = 1) and (var811 = 1 or var812 = 1 or var813 = 1 or
var814 = 1 or var815 = 1 or var816 = 1 or var817 = 1 or var818 = 1 or var819 = 1
 or var820 = 1) and (var821 = 1 or var822 = 1 or var823 = 1 or var824 = 1 or
var825 = 1 or var826 = 1 or var827 = 1 or var828 = 1 or var829 = 1 or var830 = 1
) and (var831 = 1 or var832 = 1 or var833 = 1 or var834 = 1 or var835 = 1 or
var836 = 1 or var837 = 1 or var838 = 1 or var839 = 1 or var840 = 1) and (var841
= 1 or var842 = 1 or var843 = 1 or var844 = 1 or var845 = 1 or var846 = 1 or
var847 = 1 or var848 = 1 or var849 = 1 or var850 = 1) and (var851 = 1 or var852
= 1 or var853 = 1 or var854 = 1 or var855 = 1 or var856 = 1 or var857 = 1 or
var858 = 1 or var859 = 1 or var860 = 1) and (var861 = 1 or var862 = 1 or var863
= 1 or var864 = 1 or var865 = 1 or var866 = 1 or var867 = 1 or var868 = 1 or
var869 = 1 or var870 = 1) and (var871 = 1 or var872 = 1 or var873 = 1 or var874
= 1 or var875 = 1 or var876 = 1 or var877 = 1 or var878 = 1 or var879 = 1 or
var880 = 1) and (var881 = 1 or var882 = 1 or var883 = 1 or var884 = 1 or var885
= 1 or var886 = 1 or var887 = 1 or var888 = 1 or var889 = 1 or var890 = 1) and (
var891 = 1 or var892 = 1 or var893 = 1 or var894 = 1 or var895 = 1 or var896 = 1
 or var897 = 1 or var898 = 1 or var899 = 1 or var900 = 1) and (var901 = 1 or
var902 = 1 or var903 = 1 or var904 = 1 or var905 = 1 or var906 = 1 or var907 = 1
 or var908 = 1 or var909 = 1 or var910 = 1) and (var911 = 1 or var912 = 1 or
var913 = 1 or var914 = 1 or var915 = 1 or var916 = 1 or var917 = 1 or var918 = 1
 or var919 = 1 or var920 = 1) and (var921 = 1 or var922 = 1 or var923 = 1 or
var924 = 1 or var925 = 1 or var926 = 1 or var927 = 1 or var928 = 1 or var929 = 1
 or var930 = 1) and (var931 = 1 or var932 = 1 or var933 = 1 or var934 = 1 or
var935 = 1 or var936 = 1 or var937 = 1 or var938 = 1 or var939 = 1 or var940 = 1
) and (var941 = 1 or var942 = 1 or var943 = 1 or var944 = 1 or var945 = 1 or
var946 = 1 or var947 = 1 or var948 = 1 or var949 = 1 or var950 = 1)$



rlqsat ii8c1;


true


% The formula toilet_a_04_01.4.qdimacs of Castellini's encoding of the
% bomb in the toilet problem http://www.qbflib.org
toilet_a_04_01_4 :=
ex(var43,all(var50,all(var49,all(var48,all(var51,ex(var1,ex(var2,ex(var3,ex(var4
,ex(var5,ex(var6,ex(var7,ex(var8,ex(var9,ex(var10,ex(var11,ex(var12,ex(var52,ex(
var55,ex(var56,ex(var57,ex(var58,ex(var59,ex(var60,(not(var49 = 1) or not(var50
= 1) or not(var51 = 1) or var48 = 1 or var52 = 1) and (not(var49 = 1) or not(
var50 = 1) or not(var51 = 1) or var48 = 1 or var53 = 1) and (not(var49 = 1) or
not(var50 = 1) or not(var51 = 1) or var48 = 1 or var54 = 1) and (not(var49 = 1)
or not(var50 = 1) or not(var51 = 1) or not(var55 = 1) or var48 = 1) and (not(
var49 = 1) or not(var50 = 1) or not(var52 = 1) or var48 = 1 or var51 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var53 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var54 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var55 = 1) and (
not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or not(var52 = 1) or var49 =
1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or var49 = 1 or var53
 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or var49 = 1 or
var54 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or not(var55
= 1) or var49 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or var51 =
 1 or var52 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var53 = 1) or
var49 = 1 or var51 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or
var51 = 1 or var54 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or
var51 = 1 or var55 = 1) and (not(var50 = 1) or not(var51 = 1) or var48 = 1 or
var49 = 1 or var52 = 1) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1)
or var48 = 1 or var49 = 1) and (not(var50 = 1) or not(var51 = 1) or var48 = 1 or
 var49 = 1 or var54 = 1) and (not(var50 = 1) or not(var51 = 1) or not(var55 = 1)
 or var48 = 1 or var49 = 1) and (not(var50 = 1) or not(var52 = 1) or var48 = 1
or var49 = 1 or var51 = 1) and (not(var50 = 1) or not(var53 = 1) or var48 = 1 or
 var49 = 1 or var51 = 1) and (not(var50 = 1) or var48 = 1 or var49 = 1 or var51
= 1 or var54 = 1) and (not(var50 = 1) or var48 = 1 or var49 = 1 or var51 = 1 or
var55 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51 = 1) or not(var52
= 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51 = 1) or
not(var53 = 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51
= 1) or var50 = 1 or var54 = 1) and (not(var48 = 1) or not(var49 = 1) or not(
var51 = 1) or not(var55 = 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1)
 or var50 = 1 or var51 = 1 or var52 = 1) and (not(var48 = 1) or not(var49 = 1)
or var50 = 1 or var51 = 1 or var53 = 1) and (not(var48 = 1) or not(var49 = 1) or
 not(var54 = 1) or var50 = 1 or var51 = 1) and (not(var48 = 1) or not(var49 = 1)
 or var50 = 1 or var51 = 1 or var55 = 1) and (not(var49 = 1) or not(var51 = 1)
or var48 = 1 or var50 = 1 or var52 = 1) and (not(var49 = 1) or not(var51 = 1) or
 var48 = 1 or var50 = 1 or var53 = 1) and (not(var49 = 1) or not(var51 = 1) or
not(var54 = 1) or var48 = 1 or var50 = 1) and (not(var49 = 1) or not(var51 = 1)
or not(var55 = 1) or var48 = 1 or var50 = 1) and (not(var49 = 1) or not(var52 =
1) or var48 = 1 or var50 = 1 or var51 = 1) and (not(var49 = 1) or var48 = 1 or
var50 = 1 or var51 = 1 or var53 = 1) and (not(var49 = 1) or not(var54 = 1) or
var48 = 1 or var50 = 1 or var51 = 1) and (not(var49 = 1) or var48 = 1 or var50 =
 1 or var51 = 1 or var55 = 1) and (not(var48 = 1) or not(var51 = 1) or not(var52
 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or not(var51 = 1) or var49
= 1 or var50 = 1 or var53 = 1) and (not(var48 = 1) or not(var51 = 1) or not(
var54 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or not(var51 = 1) or
not(var55 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or var49 = 1 or
var50 = 1 or var51 = 1 or var52 = 1) and (not(var48 = 1) or not(var53 = 1) or
var49 = 1 or var50 = 1 or var51 = 1) and (not(var48 = 1) or not(var54 = 1) or
var49 = 1 or var50 = 1 or var51 = 1) and (not(var48 = 1) or var49 = 1 or var50 =
 1 or var51 = 1 or var55 = 1) and (not(var51 = 1) or var48 = 1 or var49 = 1 or
var50 = 1 or var52 = 1) and (not(var51 = 1) or not(var53 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var51 = 1) or not(var54 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var51 = 1) or not(var55 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var52 = 1) or var48 = 1 or var49 = 1 or var50 =
 1 or var51 = 1) and (not(var53 = 1) or var48 = 1 or var49 = 1 or var50 = 1 or
var51 = 1) and (not(var54 = 1) or var48 = 1 or var49 = 1 or var50 = 1 or var51 =
 1) and (var48 = 1 or var49 = 1 or var50 = 1 or var51 = 1 or var55 = 1) and (not
(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var52 = 1) and (
not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var53 = 1)
and (not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var54 =
1) and (not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var55
 = 1) and not(var56 = 1) and not(var57 = 1) and not(var58 = 1) and not(var59 = 1
) and not(var60 = 1) and (not(var24 = 1) or not(var60 = 1)) and (not(var24 = 1)
or not(var56 = 1)) and (not(var4 = 1) or not(var25 = 1)) and (not(var1 = 1) or
not(var25 = 1)) and (not(var5 = 1) or not(var26 = 1)) and (not(var2 = 1) or not(
var26 = 1)) and (not(var28 = 1) or not(var57 = 1)) and (not(var28 = 1) or not(
var60 = 1)) and (not(var9 = 1) or not(var29 = 1)) and (not(var4 = 1) or not(
var29 = 1)) and (not(var10 = 1) or not(var30 = 1)) and (not(var5 = 1) or not(
var30 = 1)) and (not(var32 = 1) or not(var58 = 1)) and (not(var32 = 1) or not(
var60 = 1)) and (not(var14 = 1) or not(var33 = 1)) and (not(var4 = 1) or not(
var33 = 1)) and (not(var15 = 1) or not(var34 = 1)) and (not(var5 = 1) or not(
var34 = 1)) and (not(var36 = 1) or not(var59 = 1)) and (not(var36 = 1) or not(
var60 = 1)) and (not(var19 = 1) or not(var38 = 1)) and (not(var4 = 1) or not(
var38 = 1)) and (not(var20 = 1) or not(var40 = 1)) and (not(var5 = 1) or not(
var40 = 1)) and (not(var37 = 1) or var60 = 1) and (not(var39 = 1) or var4 = 1)
and (not(var41 = 1) or var5 = 1) and (not(var24 = 1) or var4 = 1) and (not(var7
= 1) or not(var24 = 1)) and (not(var24 = 1) or var1 = 1) and (not(var25 = 1) or
var5 = 1) and (not(var8 = 1) or not(var25 = 1)) and (not(var25 = 1) or var2 = 1)
 and (not(var26 = 1) or var6 = 1) and (not(var26 = 1) or not(var44 = 1)) and (
not(var26 = 1) or var3 = 1) and (not(var28 = 1) or var9 = 1) and (not(var12 = 1)
 or not(var28 = 1)) and (not(var28 = 1) or var4 = 1) and (not(var29 = 1) or
var10 = 1) and (not(var13 = 1) or not(var29 = 1)) and (not(var29 = 1) or var5 =
1) and (not(var30 = 1) or var11 = 1) and (not(var30 = 1) or not(var45 = 1)) and
(not(var30 = 1) or var6 = 1) and (not(var32 = 1) or var14 = 1) and (not(var17 =
1) or not(var32 = 1)) and (not(var32 = 1) or var4 = 1) and (not(var33 = 1) or
var15 = 1) and (not(var18 = 1) or not(var33 = 1)) and (not(var33 = 1) or var5 =
1) and (not(var34 = 1) or var16 = 1) and (not(var34 = 1) or not(var46 = 1)) and
(not(var34 = 1) or var6 = 1) and (not(var36 = 1) or var19 = 1) and (not(var22 =
1) or not(var36 = 1)) and (not(var36 = 1) or var4 = 1) and (not(var38 = 1) or
var20 = 1) and (not(var23 = 1) or not(var38 = 1)) and (not(var38 = 1) or var5 =
1) and (not(var40 = 1) or var21 = 1) and (not(var40 = 1) or not(var47 = 1)) and
(not(var40 = 1) or var6 = 1) and (not(var4 = 1) or not(var37 = 1)) and (not(var5
 = 1) or not(var39 = 1)) and (not(var6 = 1) or not(var41 = 1)) and (not(var1 = 1
) or var24 = 1 or var56 = 1) and (not(var2 = 1) or var1 = 1 or var25 = 1) and (
not(var3 = 1) or var2 = 1 or var26 = 1) and (not(var56 = 1) or var1 = 1) and (
not(var1 = 1) or var2 = 1) and (not(var2 = 1) or var3 = 1) and (not(var4 = 1) or
 var24 = 1 or var28 = 1 or var32 = 1 or var36 = 1 or var60 = 1) and (not(var5 =
1) or var4 = 1 or var25 = 1 or var29 = 1 or var33 = 1 or var38 = 1) and (not(
var6 = 1) or var5 = 1 or var26 = 1 or var30 = 1 or var34 = 1 or var40 = 1) and (
not(var60 = 1) or var4 = 1 or var37 = 1) and (not(var4 = 1) or var5 = 1 or var39
 = 1) and (not(var5 = 1) or var6 = 1 or var41 = 1) and (not(var7 = 1) or var55 =
 1) and (not(var8 = 1) or var7 = 1) and (not(var44 = 1) or var8 = 1) and (not(
var55 = 1) or var7 = 1 or var24 = 1) and (not(var7 = 1) or var8 = 1 or var25 = 1
) and (not(var8 = 1) or var26 = 1 or var44 = 1) and (not(var9 = 1) or var28 = 1
or var57 = 1) and (not(var10 = 1) or var9 = 1 or var29 = 1) and (not(var11 = 1)
or var10 = 1 or var30 = 1) and (not(var57 = 1) or var9 = 1) and (not(var9 = 1)
or var10 = 1) and (not(var10 = 1) or var11 = 1) and (not(var12 = 1) or var52 = 1
) and (not(var13 = 1) or var12 = 1) and (not(var45 = 1) or var13 = 1) and (not(
var52 = 1) or var12 = 1 or var28 = 1) and (not(var12 = 1) or var13 = 1 or var29
= 1) and (not(var13 = 1) or var30 = 1 or var45 = 1) and (not(var14 = 1) or var32
 = 1 or var58 = 1) and (not(var15 = 1) or var14 = 1 or var33 = 1) and (not(var16
 = 1) or var15 = 1 or var34 = 1) and (not(var58 = 1) or var14 = 1) and (not(
var14 = 1) or var15 = 1) and (not(var15 = 1) or var16 = 1) and (not(var17 = 1)
or var53 = 1) and (not(var18 = 1) or var17 = 1) and (not(var46 = 1) or var18 = 1
) and (not(var53 = 1) or var17 = 1 or var32 = 1) and (not(var17 = 1) or var18 =
1 or var33 = 1) and (not(var18 = 1) or var34 = 1 or var46 = 1) and (not(var19 =
1) or var36 = 1 or var59 = 1) and (not(var20 = 1) or var19 = 1 or var38 = 1) and
 (not(var21 = 1) or var20 = 1 or var40 = 1) and (not(var59 = 1) or var19 = 1)
and (not(var19 = 1) or var20 = 1) and (not(var20 = 1) or var21 = 1) and (not(
var22 = 1) or var54 = 1) and (not(var23 = 1) or var22 = 1) and (not(var47 = 1)
or var23 = 1) and (not(var54 = 1) or var22 = 1 or var36 = 1) and (not(var22 = 1)
 or var23 = 1 or var38 = 1) and (not(var23 = 1) or var40 = 1 or var47 = 1) and (
not(var24 = 1) or not(var28 = 1)) and (not(var25 = 1) or not(var29 = 1)) and (
not(var26 = 1) or not(var30 = 1)) and (not(var27 = 1) or not(var31 = 1)) and (
not(var24 = 1) or not(var32 = 1)) and (not(var25 = 1) or not(var33 = 1)) and (
not(var26 = 1) or not(var34 = 1)) and (not(var27 = 1) or not(var35 = 1)) and (
not(var24 = 1) or not(var36 = 1)) and (not(var25 = 1) or not(var38 = 1)) and (
not(var26 = 1) or not(var40 = 1)) and (not(var27 = 1) or not(var42 = 1)) and (
not(var24 = 1) or not(var37 = 1)) and (not(var25 = 1) or not(var39 = 1)) and (
not(var26 = 1) or not(var41 = 1)) and (not(var27 = 1) or not(var43 = 1)) and (
not(var28 = 1) or not(var32 = 1)) and (not(var29 = 1) or not(var33 = 1)) and (
not(var30 = 1) or not(var34 = 1)) and (not(var31 = 1) or not(var35 = 1)) and (
not(var28 = 1) or not(var36 = 1)) and (not(var29 = 1) or not(var38 = 1)) and (
not(var30 = 1) or not(var40 = 1)) and (not(var31 = 1) or not(var42 = 1)) and (
not(var28 = 1) or not(var37 = 1)) and (not(var29 = 1) or not(var39 = 1)) and (
not(var30 = 1) or not(var41 = 1)) and (not(var31 = 1) or not(var43 = 1)) and (
not(var32 = 1) or not(var36 = 1)) and (not(var33 = 1) or not(var38 = 1)) and (
not(var34 = 1) or not(var40 = 1)) and (not(var35 = 1) or not(var42 = 1)) and (
not(var32 = 1) or not(var37 = 1)) and (not(var33 = 1) or not(var39 = 1)) and (
not(var34 = 1) or not(var41 = 1)) and (not(var35 = 1) or not(var43 = 1)) and (
not(var36 = 1) or not(var37 = 1)) and (not(var38 = 1) or not(var39 = 1)) and (
not(var40 = 1) or not(var41 = 1)) and (not(var42 = 1) or not(var43 = 1)) and not
(var44 = 1) and not(var45 = 1) and not(var46 = 1) and not(var47 = 1)))))))))))))
))))))))))))$


rlqsat toilet_a_04_01_4;


false


end;


Time for test: 3102 ms, plus GC time: 221 ms
@@@@@ Resources used: (3 48 820 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalpqsat.red0000644000175000017500000032052711526203062025534 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: ibalpqsat.red 529 2010-01-19 23:40:14Z czengler $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Andreas Dolzmann and Thomas Sturm
% ---------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(ibalp_qsat_rcsid!* ibalp_qsat_copyright!*);
   ibalp_qsat_rcsid!* :=
      "$Id: ibalpqsat.red 529 2010-01-19 23:40:14Z czengler $";
   ibalp_qsat_copyright!* := "Copyright (c) 2007-2009 A. Dolzmann and T. Sturm"
>>;

module ibalpqsat;

fluid '(ibalp_qsatoptions!* !*rlverbose);

fluid '(donel!*, numcdcl!*, numlocs!*);

procedure my_mkvect(n);
   <<
      ioto_tprin2t {"entering mkvect n=",n};
      for i := 0:n collect (i . nil)
   >>;

procedure my_putv(v,n,a);
   begin scalar w;
      ioto_tprin2t {"entering putv n=",n," size=",length v};
      w := assoc(n,v);
      cdr w := a;
      return v
   end;

procedure my_getv(v,n);
   <<
      ioto_tprin2t {"entering getv n=",n," size=",length v};
      cdr assoc(n,v)
   >>;

procedure my_mkvect(n);
   <<
      ioto_tprin2t {"entering mkvect n=",n};
      mkvect n
   >>;

procedure my_putv(v,n,a);
   begin scalar w;
      ioto_tprin2t {"entering putv n=",n," size=",upbv v};
      putv(v,n,a);
      ioto_tprin2t {"leaving putv n=",n," size=",upbv v};
   end;

procedure my_getv(v,n);
   <<
      ioto_tprin2t {"entering getv n=",n," size=",upbv v};
      getv(v,n)
   >>;

procedure ibalp_qsat!-initoptions();
   % Initialise the options. Sets default values for all options.
   ibalp_qsat!-setoptionl({'zmom,5,1,1.2,200});

procedure ibalp_qsat!-getoptionl();
   % Get the option list. Returns the list with the options of the SAT
   % solver.
   begin scalar tlist;
      tlist := lto_catsoc('clause_del,ibalp_qsatoptions!*) . nil;
      tlist := lto_catsoc('res_inc,ibalp_qsatoptions!*) . tlist;
      tlist := lto_catsoc('first_val,ibalp_qsatoptions!*) . tlist;
      tlist := lto_catsoc('res_start,ibalp_qsatoptions!*) . tlist;
      tlist := lto_catsoc('heuristic,ibalp_qsatoptions!*) . tlist;
      return tlist
   end;

procedure ibalp_qsat!-setoptionl(optionl);
   % Set options. [optionl] is a list of options. It must be [nil] or
   % have five elements, indicating the branching heuristc, the
   % restart value, the first value to be set, the increase factor for
   % restarts, the bound for clause deletion. Returns the new list of
   % options.
   begin scalar temp;
      if null optionl then
	 return ibalp_qsat!-getoptionl();
      temp := car optionl;
      ibalp_qsatoptions!* := ('heuristic . temp) . nil;
      temp := cadr optionl;
      ibalp_qsatoptions!* := ('res_start . temp) . ibalp_qsatoptions!*;
      temp := caddr optionl;
      ibalp_qsatoptions!* := ('first_val . temp) . ibalp_qsatoptions!*;
      temp := cadddr optionl;
      ibalp_qsatoptions!* := ('res_inc . temp) . ibalp_qsatoptions!*;
      temp := car cddddr optionl;
      ibalp_qsatoptions!* := ('clause_del . temp) . ibalp_qsatoptions!*;
      return ibalp_qsat!-getoptionl();
   end;

procedure ibalp_qsat!-getoption(opt);
   % Get option. [opt] is one of the options heuristic, res_start,
   % first_val, res_inc or clause_del. Returns the corresponding
   % option.
   lto_catsoc(opt,ibalp_qsatoptions!*);

!#if t

smacro procedure ibalp_var!-new(id);
   % Create a new variable. [id] is the identifier of the
   % variable. Returns a list with the following components: l[0] is
   % the identifier; l[1] is the value of the variable; l[2] is the
   % list of positive occurences of the variable; l[3] is the list of
   % negative occurences; l[4] is the number of currently false
   % clauses where the variable has a positive occurence; l[5] is the
   % number of currently false clauses where the variable has a
   % negative occurence; l[6] is the level at which the variable was
   % set; l[7] is the reason for the variable; l[8] is the number of
   % positive occurences in new added conflict-clauses; l[9] is the
   % number of positive occurences in new added conflict-clauses;
   % l[10] is the list of watched clauses; l[11] is the f-Calc;
   % l[12] is the quantifier of this variable; l[13] is the
   % quantification level of the variable; l[14] is the flipped-flag.
   {id,nil,nil,nil,0,0,-1,nil,0,0,nil,0,nil,0,nil};
 
smacro procedure ibalp_var!-setval(var,val);
   % Set the value of a variable. [var] is a variable; [val] is the
   % value [0], [1] or [nil];
   cadr var := val;

smacro procedure ibalp_var!-setposocc(var,posocc);
   % Add a clause to the list of clauses where the variable has a
   % positive occurence. [var] is a variable; [negocc] the clause.
   caddr var := posocc . caddr var;

smacro procedure ibalp_var!-setnegocc(var,negocc);
   % Add a clause to the list of clauses where the variable has a
   % negative occurence. [var] is a variable; [negocc] the clause.
   cadddr var := negocc . cadddr var;

smacro procedure ibalp_var!-setposoccabs(var,posocc);
   % Add a clause to the list of clauses where the variable has a
   % positive occurence. [var] is a variable; [negocc] the clause.
   caddr var := posocc;

smacro procedure ibalp_var!-setnegoccabs(var,negocc);
   % Add a clause to the list of clauses where the variable has a
   % negative occurence. [var] is a variable; [negocc] the clause.
   cadddr var := negocc;

smacro procedure ibalp_var!-setnumpos(var,numpos);
   % Get the number of currently false clauses where the variable has
   % a positive occurence and is not set. [var] is a variable;
   % [numpos] the number of occurences.
   car cddddr var := numpos;

smacro procedure ibalp_var!-setnumneg(var,numneg);
   % Set the number of currently false clauses where the variable has
   % a negative occurence and is not set. [var] is a variable;
   % [numneg] the number of occurences.
   cadr cddddr var := numneg;

smacro procedure ibalp_var!-setlev(var,lev);
   % Set the level at which the variable was set. [var] is a variable;
   % [lev] is the number of the level;
   caddr cddddr var := lev;

smacro procedure ibalp_var!-setreas(var,reas);
   % Set the reason why the variable was set. [var] is a variable;
   % [reas] is the clause which became unit and forced the set or nil
   % if it was a decision.
   cadddr cddddr var := reas;

smacro procedure ibalp_var!-setposcc(var,num);
   % Set the number of positive occurences in added
   % conflict-clauses. [var] is a variable; [num] is the number of
   % occurences.
   car cddddr cddddr var := num;

smacro procedure ibalp_var!-setnegcc(var,num);
   % Set the number of negative occurences in added
   % conflict-clauses. [var] is a variable; [num] is the number of
   % occurences.
   cadr cddddr cddddr var := num;

smacro procedure ibalp_var!-setwc(var,wc);
   % Set the watched-clauses of a variable . [var] is a variable; [wc]
   % is a watched clause.
   caddr cddddr cddddr var := wc . caddr cddddr cddddr var;

smacro procedure ibalp_var!-setmom(var,mom);
   % Set the MOM-value for this variable. [var] is a variable; [mom]
   % is the MOM-value.
   cadddr cddddr cddddr var := mom;

smacro procedure ibalp_var!-setquant(var,quant);
   % Set the quantifier for this variable. [var] is a variable;
   % [quant] is [nil] if it is an unquantified variable, [ex] for an
   % existential quantified variable and [all] for an universal
   % quantified variable.
   car cddddr cddddr cddddr var := quant;

smacro procedure ibalp_var!-setqlevel(var,qlevel);
   % Set the quantifier-level for this variable. [var] is a variable;
   % [qlevel] the quantifier level.
   cadr cddddr cddddr cddddr var := qlevel;

smacro procedure ibalp_var!-setflip(var,flip);
   % Set the flip-level for this variable. [var] is a variable;
   % [flip] is the flipstatus.
   caddr cddddr cddddr cddddr var := flip;

smacro procedure ibalp_var!-getid(var);
   % Get the identifier of a variable. [var] is variable. Returns the
   % identifier.
   car var;

smacro procedure ibalp_var!-getval(var);
   % Get the current value of a variable. [var] is a variable. Returns
   % [1] if the variable is set to true, [0] if set to false and [nil]
   % if the variable is not set.
   cadr var;

smacro procedure ibalp_var!-getposocc(var);
   % Get the list of all clauses where the variable has a positive
   % occurence. [var] is a variable. Returns the list of clauses.
   caddr var;

smacro procedure ibalp_var!-getnegocc(var);
   % Get the list of all clauses where the variable has a negative
   % occurence. [var] is a variable. Returns the list of clauses.
   cadddr var;

smacro procedure ibalp_var!-getnumpos(var);
   % Get the number of currently false clauses where the variable has
   % a positive occurence and is not set. [var] is a variable. Returns
   % the number of clauses.
   car cddddr var;

smacro procedure ibalp_var!-getnumneg(var);
   % Get the number of currently false clauses where the variable has
   % a negative occurence and is not set. [var] is a variable. Returns
   % the number of clauses.
   cadr cddddr var;

smacro procedure ibalp_var!-getlev(var);
   % Get the level at which the variable was set. [var] is a
   % variable. Returns the level.
   caddr cddddr var;

smacro procedure ibalp_var!-getreas(var);
   % Get the reason why the variable was set. [var] is a variable.
   % Returns the clause which became unit and forced the set or [nil]
   % if a decision was the reason.
   cadddr cddddr var;

smacro procedure ibalp_var!-getposcc(var);
   % Get the number of positive occurences in added
   % conflict-clauses. [var] is a variable.  Returns the number of
   % positive occurences in conflict-clauses.
   car cddddr cddddr var;

smacro procedure ibalp_var!-getnegcc(var);
   % Get the number of negative occurences in added
   % conflict-clauses. [var] is a variable.  Returns the number of
   % negative occurences in conflict-clauses.
   cadr cddddr cddddr var;

smacro procedure ibalp_var!-getwc(var);
   % Get the watched-clauses of a variable . [var] is a variable.
   caddr cddddr cddddr var;

smacro procedure ibalp_var!-delwc(var,wc);
   % Delete a single watched-clauses of this variable . [var] is a
   % variable; [wc] is a clause.
   caddr cddddr cddddr var := delq(wc,caddr cddddr cddddr var);

smacro procedure ibalp_var!-delallwc(var);
   % Delete all watched-clauses of this variable . [var] is a
   % variable.
   caddr cddddr cddddr var := nil;

smacro procedure ibalp_var!-getmom(var);
   % Get the MOM-value for this variable. [var] is a variable.
   cadddr cddddr cddddr var;

smacro procedure ibalp_var!-getquant(var);
   % Get the quantifier for this variable. [var] is a variable;
   % Return [nil] if it is an unquantified variable, [ex] for an
   % existential quantified variable and [all] for an universal
   % quantified variable.
   car cddddr cddddr cddddr var;

smacro procedure ibalp_var!-isex(var);
   % Returns if a variable is existential quantified. [var] is a
   % variable. Returns [t] iff the var is existential quantified.
   car cddddr cddddr cddddr var eq 'ex;

smacro procedure ibalp_var!-isuni(var);
   % Returns if a variable is universal quantified. [var] is a
   % variable. Returns [t] iff the var is universal quantified.
   car cddddr cddddr cddddr var eq 'all;

smacro procedure ibalp_var!-getqlevel(var);
   % Get the quantifier-level for this variable. [var] is a variable;
   % Returns the quantifier level.
   cadr cddddr cddddr cddddr var;

smacro procedure ibalp_var!-getflip(var);
   % Get the flipstatus for this variable. [var] is a variable;
   % Returns [nil] if the variable is no decision variable, 0 if the
   % variable i unflipped and 1 if flipped.
   caddr cddddr cddddr cddddr var;

smacro procedure ibalp_clause!-new();
   % Create a new clause. Returns a list with the following
   % components: l[0] is a list of the positive literals of the
   % clause; l[1] is a list of the negative literals of the clause;
   % l[2] is the number of currently unset positive variables in the
   % clause; l[3] is the number of currently unset negative variables
   % in the clause; l[4] is the variable turning this clause to true
   % or [nil] if the clause is false; l[5] is a counter for new-added
   % clauses.
   {nil,nil,0,0,nil,nil,nil};

smacro procedure ibalp_clause!-setsat(clause,sat);
   % Set the variable turning a clause to true. [clause] is a clause;
   % [sat] is the variable turning to true
   car cddddr clause := sat . car cddddr clause;

smacro procedure ibalp_clause!-delallsat(clause);
   % Set the variable turning a clause to true. [clause] is a clause;
   % [sat] is the variable turning to true
   car cddddr clause := nil;

smacro procedure ibalp_clause!-setposlit(clause,var);
   % Add a variable to the list of positive literals of a
   % clause. [clause] is a clause; [var] is a variable.
   car clause := var . car clause;

smacro procedure ibalp_clause!-setneglit(clause,var);
   % Add a variable to the list of negative literals of a
   % clause. [clause] is a clause; [var] is a variable.
   cadr clause := var . cadr clause;

smacro procedure ibalp_clause!-setposlitabs(clause,var);
   % Add a variable to the list of positive literals of a
   % clause. [clause] is a clause; [var] is a variable.
   car clause := var;

smacro procedure ibalp_clause!-setneglitabs(clause,var);
   % Add a variable to the list of negative literals of a
   % clause. [clause] is a clause; [var] is a variable.
   cadr clause := var;

smacro procedure ibalp_clause!-setactpos(clause,actpos);
   % Set the number of positive literals that are currently
   % unset. [clause] is a clause; [actpos] is the number of currently
   % unset literals.
   caddr clause := actpos;

smacro procedure ibalp_clause!-setactneg(clause,actneg);
   % Set the number of negative literals that are currently
   % unset. [clause] is a clause; [actneg] is the number of currently
   % unset literals.
   cadddr clause := actneg;

smacro procedure ibalp_clause!-setcount(clause,count);
   % Set the current count for new-added clauses. [clause] is a
   % clause; [count] is the count.
   cadr cddddr clause := count;

smacro procedure ibalp_clause!-setwl(clause,wl);
   % Add a watched literal for this clause. [clause] is a
   % clause; [wl] is a variable.
   caddr cddddr clause := wl . caddr cddddr clause;
      
smacro procedure ibalp_clause!-delallwl(clause);
   % Delete the watched literals for this clause. [clause] is a
   % clause.
   caddr cddddr clause := nil;

smacro procedure ibalp_clause!-delwl(clause,wl);
   % Delete a single watched literal from this clause. [clause] is a
   % clause; [wl] is a variable.
   caddr cddddr clause := delq(wl,caddr cddddr clause);
   
smacro procedure ibalp_clause!-getposlit(clause);
   % Get a list of all positive literals of a clause. [clause] is a
   % clause. Returns the list of variables. [nil] if the clause has no
   % positive literals.
   car clause;

smacro procedure ibalp_clause!-getneglit(clause);
   % Get a list of all negative literals of a clause. [clause] is a
   % clause. Returns the list of variables. [nil] if the clause has no
   % negative literals.
   cadr clause;

smacro procedure ibalp_clause!-getactpos(clause);
   % Get the number of positive literals that are currently unset in a
   % clause. [clause] is a clause. Returns the number of literals
   caddr clause;

smacro procedure ibalp_clause!-getactneg(clause);
   % Get the number of negative literals that are currently unset in a
   % clause. [clause] is a clause. Returns the number of literals.
   cadddr clause;

smacro procedure ibalp_clause!-getsat(clause);
   % Get the variable turning a clause to true. [clause] is a
   % clause. Returns the variable or [nil] if the clause is false.
   car cddddr clause;

smacro procedure ibalp_clause!-delsat(clause,sat);
   % Delete a variable turning a clause to true. [clause] is a clause;
   % [sat] is a variable.
   car cddddr clause := delq(sat,car cddddr clause);

smacro procedure ibalp_clause!-getcount(clause);
   % Get the current count for new-added clauses. [clause] is a
   % clause. Return the count.
   cadr cddddr clause;

smacro procedure ibalp_clause!-getwl(clause);
   % Get the watched literals for this clause. [clause] is a
   % clause. Return the watched literal.
   caddr cddddr clause;

!#else

smacro procedure ibalp_var!-new(id);
   % Create a new variable. [id] is the identifier of the
   % variable. Returns a list with the following components: l[0] is
   % the identifier; l[1] is the value of the variable; l[2] is the
   % list of positive occurences of the variable; l[3] is the list of
   % negative occurences; l[4] is the number of currently false
   % clauses where the variable has a positive occurence; l[5] is the
   % number of currently false clauses where the variable has a
   % negative occurence; l[6] is the level at which the variable was
   % set; l[7] is the reason for the variable; l[8] is the number of
   % positive occurences in new added conflict-clauses; l[9] is the
   % number of positive occurences in new added conflict-clauses;
   % l[10] is the list of watched clauses; l[11] is the MOM-Calc;
   % l[12] is the quantifier of this variable; l[13] is the
   % quantification level of the variable; l[14] is the flipped-flag.
   begin scalar v;
      v := mkvect(14);
      putv(v,0,id);
      putv(v,4,0);
      putv(v,5,0);
      putv(v,6,-1);
      putv(v,8,0);
      putv(v,9,0);
      putv(v,11,0);
      putv(v,13,0);
      return v
   end;
   
smacro procedure ibalp_var!-setval(var,val);
   % Set the value of a variable. [var] is a variable; [val] is the
   % value [0], [1] or [nil];
   putv(var,1,val);

smacro procedure ibalp_var!-setposocc(var,posocc);
   % Add a clause to the list of clauses where the variable has a
   % positive occurence. [var] is a variable; [negocc] the clause.
   putv(var,2,posocc . getv(var,2));

smacro procedure ibalp_var!-setnegocc(var,negocc);
   % Add a clause to the list of clauses where the variable has a
   % negative occurence. [var] is a variable; [negocc] the clause.
   putv(var,3,negocc . getv(var,3));

smacro procedure ibalp_var!-setposoccabs(var,posocc);
   % Add a clause to the list of clauses where the variable has a
   % positive occurence. [var] is a variable; [negocc] the clause.
   putv(var,2,posocc);

smacro procedure ibalp_var!-setnegoccabs(var,negocc);
   % Add a clause to the list of clauses where the variable has a
   % negative occurence. [var] is a variable; [negocc] the clause.
   putv(var,3,negocc);

smacro procedure ibalp_var!-setnumpos(var,numpos);
   % Get the number of currently false clauses where the variable has
   % a positive occurence and is not set. [var] is a variable;
   % [numpos] the number of occurences.
   putv(var,4,numpos);

smacro procedure ibalp_var!-setnumneg(var,numneg);
   % Set the number of currently false clauses where the variable has
   % a negative occurence and is not set. [var] is a variable;
   % [numneg] the number of occurences.
   putv(var,5,numneg);

smacro procedure ibalp_var!-setlev(var,lev);
   % Set the level at which the variable was set. [var] is a variable;
   % [lev] is the number of the level;
   putv(var,6,lev);

smacro procedure ibalp_var!-setreas(var,reas);
   % Set the reason why the variable was set. [var] is a variable;
   % [reas] is the clause which became unit and forced the set or nil
   % if it was a decision.
   putv(var,7,reas);

smacro procedure ibalp_var!-setposcc(var,num);
   % Set the number of positive occurences in added
   % conflict-clauses. [var] is a variable; [num] is the number of
   % occurences.
   putv(var,8,num);

smacro procedure ibalp_var!-setnegcc(var,num);
   % Set the number of negative occurences in added
   % conflict-clauses. [var] is a variable; [num] is the number of
   % occurences.
   putv(var,9,num);

smacro procedure ibalp_var!-setwc(var,wc);
   % Set the watched-clauses of a variable . [var] is a variable; [wc]
   % is a watched clause.
   putv(var,10,wc . getv(var,10));

smacro procedure ibalp_var!-setmom(var,mom);
   % Set the MOM-value for this variable. [var] is a variable; [mom]
   % is the MOM-value.
   putv(var,11,mom);

smacro procedure ibalp_var!-setquant(var,quant);
   % Set the quantifier for this variable. [var] is a variable;
   % [quant] is [nil] if it is an unquantified variable, [ex] for an
   % existential quantified variable and [all] for an universal
   % quantified variable.
   putv(var,12,quant);

smacro procedure ibalp_var!-setqlevel(var,qlevel);
   % Set the quantifier-level for this variable. [var] is a variable;
   % [qlevel] the quantifier level.
   putv(var,13,qlevel);

smacro procedure ibalp_var!-setflip(var,flip);
   % Set the flip-level for this variable. [var] is a variable;
   % [flip] is the flipstatus.
   putv(var,14,flip);

smacro procedure ibalp_var!-getid(var);
   % Get the identifier of a variable. [var] is variable. Returns the
   % identifier.
   getv(var,0);

smacro procedure ibalp_var!-getval(var);
   % Get the current value of a variable. [var] is a variable. Returns
   % [1] if the variable is set to true, [0] if set to false and [nil]
   % if the variable is not set.
   getv(var,1);

smacro procedure ibalp_var!-getposocc(var);
   % Get the list of all clauses where the variable has a positive
   % occurence. [var] is a variable. Returns the list of clauses.
   getv(var,2);

smacro procedure ibalp_var!-getnegocc(var);
   % Get the list of all clauses where the variable has a negative
   % occurence. [var] is a variable. Returns the list of clauses.
   getv(var,3);

smacro procedure ibalp_var!-getnumpos(var);
   % Get the number of currently false clauses where the variable has
   % a positive occurence and is not set. [var] is a variable. Returns
   % the number of clauses.
   getv(var,4);

smacro procedure ibalp_var!-getnumneg(var);
   % Get the number of currently false clauses where the variable has
   % a negative occurence and is not set. [var] is a variable. Returns
   % the number of clauses.
   getv(var,5);

smacro procedure ibalp_var!-getlev(var);
   % Get the level at which the variable was set. [var] is a
   % variable. Returns the level.
   getv(var,6);

smacro procedure ibalp_var!-getreas(var);
   % Get the reason why the variable was set. [var] is a variable.
   % Returns the clause which became unit and forced the set or [nil]
   % if a decision was the reason.
   getv(var,7);

smacro procedure ibalp_var!-getposcc(var);
   % Get the number of positive occurences in added
   % conflict-clauses. [var] is a variable.  Returns the number of
   % positive occurences in conflict-clauses.
   getv(var,8);

smacro procedure ibalp_var!-getnegcc(var);
   % Get the number of negative occurences in added
   % conflict-clauses. [var] is a variable.  Returns the number of
   % negative occurences in conflict-clauses.
   getv(var,9);

smacro procedure ibalp_var!-getwc(var);
   % Get the watched-clauses of a variable . [var] is a variable.
   getv(var,10);

smacro procedure ibalp_var!-delwc(var,wc);
   % Delete a single watched-clauses of this variable . [var] is a
   % variable; [wc] is a clause.
   putv(var,10,delq(wc,getv(var,10)));

smacro procedure ibalp_var!-delallwc(var);
   % Delete all watched-clauses of this variable . [var] is a
   % variable.
   putv(var,10,nil);

smacro procedure ibalp_var!-getmom(var);
   % Get the MOM-value for this variable. [var] is a variable.
   getv(var,11);

smacro procedure ibalp_var!-getquant(var);
   % Get the quantifier for this variable. [var] is a variable;
   % Return [nil] if it is an unquantified variable, [ex] for an
   % existential quantified variable and [all] for an universal
   % quantified variable.
   getv(var,12);

smacro procedure ibalp_var!-isex(var);
   % Returns if a variable is existential quantified. [var] is a
   % variable. Returns [t] iff the var is existential quantified.
   getv(var,12) eq 'ex;

smacro procedure ibalp_var!-isuni(var);
   % Returns if a variable is universal quantified. [var] is a
   % variable. Returns [t] iff the var is universal quantified.
   getv(var,12) eq 'all;

smacro procedure ibalp_var!-getqlevel(var);
   % Get the quantifier-level for this variable. [var] is a variable;
   % Returns the quantifier level.
   getv(var,13);

smacro procedure ibalp_var!-getflip(var);
   % Get the flipstatus for this variable. [var] is a variable;
   % Returns [nil] if the variable is no decision variable, 0 if the
   % variable i unflipped and 1 if flipped.
   getv(var,14);

smacro procedure ibalp_clause!-new();
   % Create a new clause. Returns a list with the following
   % components: l[0] is a list of the positive literals of the
   % clause; l[1] is a list of the negative literals of the clause;
   % l[2] is the number of currently unset positive variables in the
   % clause; l[3] is the number of currently unset negative variables
   % in the clause; l[4] is the variable turning this clause to true
   % or [nil] if the clause is false; l[5] is a counter for new-added
   % clauses.
   begin scalar v;
      v := mkvect(6);
      putv(v,2,0);
      putv(v,3,0);
      return v
   end;

smacro procedure ibalp_clause!-setsat(clause,sat);
   % Set the variable turning a clause to true. [clause] is a clause;
   % [sat] is the variable turning to true
   putv(clause,4,sat . getv(clause,4));

smacro procedure ibalp_clause!-delallsat(clause);
   % Set the variable turning a clause to true. [clause] is a clause;
   % [sat] is the variable turning to true
   putv(clause,4,nil);

smacro procedure ibalp_clause!-setposlit(clause,var);
   % Add a variable to the list of positive literals of a
   % clause. [clause] is a clause; [var] is a variable.
   putv(clause,0,var . getv(clause,0));

smacro procedure ibalp_clause!-setneglit(clause,var);
   % Add a variable to the list of negative literals of a
   % clause. [clause] is a clause; [var] is a variable.
   putv(clause,1,var . getv(clause,1));

smacro procedure ibalp_clause!-setposlitabs(clause,var);
   % Add a variable to the list of positive literals of a
   % clause. [clause] is a clause; [var] is a variable.
   putv(clause,0,var);

smacro procedure ibalp_clause!-setneglitabs(clause,var);
   % Add a variable to the list of negative literals of a
   % clause. [clause] is a clause; [var] is a variable.
   putv(clause,1,var);

smacro procedure ibalp_clause!-setactpos(clause,actpos);
   % Set the number of positive literals that are currently
   % unset. [clause] is a clause; [actpos] is the number of currently
   % unset literals.
   putv(clause,2,actpos);

smacro procedure ibalp_clause!-setactneg(clause,actneg);
   % Set the number of negative literals that are currently
   % unset. [clause] is a clause; [actneg] is the number of currently
   % unset literals.
   putv(clause,3,actneg);

smacro procedure ibalp_clause!-setcount(clause,count);
   % Set the current count for new-added clauses. [clause] is a
   % clause; [count] is the count.
   putv(clause,5,count);

smacro procedure ibalp_clause!-setwl(clause,wl);
   % Add a watched literal for this clause. [clause] is a
   % clause; [wl] is a variable.
   putv(clause,6,wl . getv(clause,6));
      
smacro procedure ibalp_clause!-delallwl(clause);
   % Delete the watched literals for this clause. [clause] is a
   % clause.
   putv(clause,6,nil);

smacro procedure ibalp_clause!-delwl(clause,wl);
   % Delete a single watched literal from this clause. [clause] is a
   % clause; [wl] is a variable.
   putv(clause,6,delq(wl,getv(clause,6)));
   
smacro procedure ibalp_clause!-getposlit(clause);
   % Get a list of all positive literals of a clause. [clause] is a
   % clause. Returns the list of variables. [nil] if the clause has no
   % positive literals.
   getv(clause,0);

smacro procedure ibalp_clause!-getneglit(clause);
   % Get a list of all negative literals of a clause. [clause] is a
   % clause. Returns the list of variables. [nil] if the clause has no
   % negative literals.
   getv(clause,1);

smacro procedure ibalp_clause!-getactpos(clause);
   % Get the number of positive literals that are currently unset in a
   % clause. [clause] is a clause. Returns the number of literals
   getv(clause,2);

smacro procedure ibalp_clause!-getactneg(clause);
   % Get the number of negative literals that are currently unset in a
   % clause. [clause] is a clause. Returns the number of literals.
   getv(clause,3);

smacro procedure ibalp_clause!-getsat(clause);
   % Get the variable turning a clause to true. [clause] is a
   % clause. Returns the variable or [nil] if the clause is false.
   getv(clause,4);

smacro procedure ibalp_clause!-delsat(clause,sat);
   % Delete a variable turning a clause to true. [clause] is a clause;
   % [sat] is a variable.
   putv(clause,4,delq(sat,getv(clause,4)));

smacro procedure ibalp_clause!-getcount(clause);
   % Get the current count for new-added clauses. [clause] is a
   % clause. Return the count.
   getv(clause,5);

smacro procedure ibalp_clause!-getwl(clause);
   % Get the watched literals for this clause. [clause] is a
   % clause. Return the watched literal.
   getv(clause,6);

!#endif

procedure ibalp_printclause(clause);
   % Helper function to print a clause.
   begin scalar poslit,neglit,sat;
      for each v in ibalp_clause!-getposlit clause do
	 poslit := ibalp_var!-getid v . poslit;
      for each v in ibalp_clause!-getneglit clause do 
      	 neglit := ibalp_var!-getid v . neglit;
      for each v in ibalp_clause!-getsat clause do
      	 sat := v . sat;
      ioto_tprin2t {"Clause ",poslit," ",neglit," ","SAT: ",sat}
   end;

procedure ibalp_printclauses(clausel);
   % Helper function to print all clauses.
   for each c in clausel do
      ibalp_printclause c;

procedure ibalp_printvaral(varal);
   % Helper function to print the list of variables.
   for each v in varal do
      ioto_tprin2t {ibalp_var!-getid cdr v, " ", ibalp_var!-getval cdr v, " ", ibalp_var!-getquant cdr v};

procedure ibalp_qsat!-dimacs(input);
   % The main entry point for solving a given .cnf or .qdimacs
   % file. [input] is the filename. Returns [true] or [false].
   begin scalar pair,clausel,varal;
      if null ibalp_qsatoptions!* then ibalp_qsat!-initoptions();
      pair := ibalp_qsat!-readdimacs2(input);
      clausel := cadr pair;
      varal := cddr pair;
      return if car pair then
	 car ibalp_qsat!-cdcl(clausel,varal,nil,t)
      else 
      	 ibalp_start!-sat(clausel,varal)
   end;

procedure ibalp_qsat!-readdimacs(input);
   % Read a .cnf or .qdimacs file and conert it to Lisp
   % Prefix. [input] is the filename. Returns the corresponding
   % formula in Lisp Prefix.
   begin scalar pair,clausel,varal;
      pair := ibalp_qsat!-readdimacs2(input);
      clausel := cadr pair;
      varal := cddr pair;
      return ibalp_convcnf(clausel,varal,car pair)
   end;

procedure ibalp_qsat(f);
   % The main entry point for the QSAT function. [f] is a formula in
   % lisp prefix. Returns true or false in SAT and Q-SAT or a formula
   % in DNF in PQ-SAT.
   begin scalar pair,clausel,varal,readform,qsat,pqsat;
      if null ibalp_qsatoptions!* then ibalp_qsat!-initoptions();
      qsat := cl_bvarl f;
      pqsat := cl_fvarl f;
      readform := if qsat then cl_matrix (cl_pnf f) else f;
      if not (ibalp_iscnf readform) then <<
	 %readform := ibalp_get3cnf(readform);
      	 if !*rlverbose then 
      	    ioto_tprin2t "Formula was not in CNF. Using QE";
	 return cl_qe(f,nil)
      >>;
      pair := ibalp_readform readform;
      clausel := car pair;
      varal := cdr pair;
      if null clausel then
	 return 'true;
      if ibalp_emptyclausep car clausel then
	 return 'false;
      if qsat and null pqsat then
       	 return ibalp_start!-qsat(clausel,varal,f)
      else if qsat and pqsat then
      	 return ibalp_start!-pqsat(clausel,varal,f,pqsat)
      else
      	 return ibalp_start!-sat(clausel,varal)
   end;

procedure ibalp_start!-sat(clausel,varal);
   % Start SAT solving. [clausel] is the list of clauses; [varal] is
   % the A-List of variables. Returns [true] if there is a satisfying
   % assignment, [nil] else.
   begin scalar resstart,firstval,inc,heur;
      if !*rlverbose then
      	 ioto_tprin2t {"Starting SAT Algorithm"};
      for each v in varal do
	 ibalp_var!-setmom(cdr v,ibalp_calcmom cdr v);
      resstart := ibalp_qsat!-getoption('res_start);
      firstval := ibalp_qsat!-getoption('first_val);
      inc := ibalp_qsat!-getoption('res_inc);
      heur := ibalp_qsat!-getoption('heuristic);
      return ibalp_cdcl(clausel,varal,resstart,firstval,1,inc,heur)
   end;

procedure ibalp_start!-qsat(clausel,varal,f);
      % Start Q-SAT solving. [clausel] is the list of clauses, [varal]
      % is the A-List of variables; [f] is the original
      % formula. Returns [true] if the formula is true, [nil] else.
      begin scalar varal,pair;
	 if !*rlverbose then
	    ioto_tprin2t {"Starting QSAT Algorithm"};
   	 pair := ibalp_readquantal(cl_pnf f,varal);
	 varal := cdr pair;
	 if eqn(car pair,1) and ibalp_var!-isex cdar varal then
	    return ibalp_start!-sat(clausel,varal)
	 else
   	    return car ibalp_qsat!-cdcl(clausel,varal,nil,t)
      end;
   
procedure ibalp_start!-pqsat(clausel,varal,f,pqsat);
      % Start parametric Q-SAT solving. [clausel] is the list of
      % clauses; [varal] is the A-List of variables; [f] is the
      % original formula; [pqsat] is the list of free
      % variables. Returns a condition to the free variables in DNF or
      % true or false.
   begin scalar pair,psat;
      if !*rlverbose then
	 ioto_tprin2t {"Starting PQSAT Algorithm with ", length pqsat, " free variables..."};
      pair := ibalp_readquantal(cl_pnf f,varal);
      varal := cdr pair;
      pair := ibalp_splitvars(pqsat,varal);
      varal := car pair;
      pqsat := cdr pair;
      psat := ibalp_psatp varal;
      if !*rlverbose and psat then
	 ioto_tprin2t {"**PSAT Problem"};
      donel!* := nil;
      numcdcl!* := 0;
      numlocs!* := 0;
      %if length pqsat / length varal > 2/3 then
      if nil then 
	 return cl_qe(f,nil)
      else <<
      	 varal := cdr ibalp_readquantal(cl_pnf f,varal);
      	 pair := ibalp_qsat!-par(pqsat,clausel,varal,nil,psat);
	 if !*rlverbose then <<
	    ioto_tprin2t {"Runs of CDCL: ", numcdcl!*};
	    ioto_tprin2t {"Local Search Successes: ", numlocs!*};
	 >>;
      	 return ibalp_exres2(car pair,pqsat)
      >>
   end;
   
procedure ibalp_cdcl(clausel,varal,c,setval,rescount,inc,heur);
   % Conflict Driven Clause Learning Procedure. [clausel] is the list
   % of clauses; [varal] is the A-List of variables; [c] is the number
   % of conflict clauses for a restart; [setval] is the value a chosen
   % variable should be set to; [rescount] is a counter for restarts;
   % [inc] is the increase factor for restarts; [heur] is the used
   % heuristic. Returns [true] if there is a satisfying assignment,
   % [false] else.
   begin scalar res,fin,pair,ec,lv,upl; integer level,count;
      pair := ibalp_preprocess(clausel,varal);
      clausel := car pair;
      varal := cdr pair;
      if null clausel then return {'true};
      upl := ibalp_initwl clausel;
      while null fin do <<
	 ec := ibalp_cec clausel;
	 if null ec then <<
	    upl := ibalp_getupl clausel;
	    pair := ibalp_unitprop(upl,clausel,level);
	    ec := car pair;
	    lv := cdr pair;
	 >>;
	 if ec then <<
	    if eqn(level,0) then <<
	       fin := t;
	       res := {'false}
	    >> else <<
	       ibalp_recalcv varal;
	       count := count + 1;
	       ibalp_dimcount clausel;
	       pair := ibalp_analconf(ec,level,lv,clausel,varal);
	       level := car pair;
	       clausel := cdr pair;
	       pair := ibalp_dosimpl(clausel,varal);
	       clausel := car pair;
	       varal := cdr pair
	    >>
	 >> else <<
	    if ibalp_istotal varal or ibalp_csat clausel then <<
	       fin := t;
	       res := {'true}
	    >> else <<
	       pair := ibalp_getvar(varal,clausel,heur);
	       level := level + 1;
	       if heur = 'activity then setval := cdr pair;
	       ibalp_var!-set(car pair,setval,level,nil);
	       if count > c then <<
	     	  res := ibalp_restart(clausel,varal,c,
		     rescount,setval,inc,heur);
	       	  fin := t
	       >>
	    >>
	 >>
      >>;
      return res
   end;

procedure ibalp_preprocess(clausel,varal);
   % Pre-processing of the formula. [clausel] is the list of clauses;
   % [varal] is the A-List of variables. Retruns a pair of the new
   % clauses and the new variables.
   begin scalar pair; integer count;
      for each v in varal do <<
	 if eqn(ibalp_var!-getnumpos cdr v,0) then <<
	    count := count + 1;
	    pair := ibalp_simplify(cdr v,0,nil,clausel,varal);
	    clausel := car pair;
	    varal := cdr pair
	 >> else if eqn(ibalp_var!-getnumneg cdr v,0) then <<
	    count := count + 1;
	    pair := ibalp_simplify(cdr v,1,nil,clausel,varal);
	    clausel := car pair;
	    varal := cdr pair
      	 >>
      >>;
      if !*rlverbose then 
      	 ioto_tprin2t {"deleted variables in pre-processing ",count};
      return (clausel . varal)
   end;

procedure ibalp_getvar(varal,clausel,heur);
   % Get a variable corresponding to a branching heuristic. [clausel]
   % is the list of clauses; [varal] is the A-List of variables;
   % [heur] is the branching heuristic. Returns a pair of variable and
   % value it should be assigned to.
   if heur = 'zmom then 
      ibalp_getvar!-zmom(varal,clausel)
   else if heur = 'activity then
      ibalp_getmacvext varal
   else ibalp_getvar!-dlcs varal;

procedure ibalp_restart(clausel,varal,c,rescount,setval,inc,heur);
   % Restart the CDCL algorithm. [clausel] is the list of clauses;
   % [varal] is the A-List of variables; [c] is the number of conflict
   % clauses for a restart; [setval] is the value a chosen variable
   % should be set to; [rescount] is a counter for restarts; [inc] is
   % the increase factor for restarts; [heur] is the used
   % heuristic. Returns [true] if there is a satisfying assignment for
   % the formula, [nil] else.
   <<
      if !*rlverbose then
	 ioto_tprin2t {"restart ",rescount};
      ibalp_dav(varal,clausel);
      if c > ibalp_qsat!-getoption('clause_del) then
	 clausel := ibalp_killcount clausel;
      ibalp_cdcl(clausel,varal,c*inc,1-setval,rescount+1,inc,heur)
   >>;
      
procedure ibalp_analconf(ec,level,lv,clausel,varal);
   % Analyse conflict. [ec] is the empty clause; [level] is the
   % current level; [lv] is the last assigned variable; [clausel] is
   % the list of clauses; [varal] is the A-List of variables. Returns
   % a pair of the new level and the new list of clauses.
   begin scalar pair,newlev,cc,p,val;
      cc := ibalp_calccc!-fuip(ec,level,lv);
      pair := ibalp_calccvar(cc,level);
      p := car pair;
      newlev := cdr pair;
      val := ibalp_var!-getval p;
      clausel := cc . clausel;
      ibalp_tvb(varal,newlev);
      ibalp_renewwl clausel;
      ibalp_var!-set(p,1-val,newlev,nil);
      return (newlev . clausel)
   end;

procedure ibalp_dosimpl(clausel,varal);
   % Perform Simplifications. [clausel] is the list of clauses;
   % [varal] is the A-List of variables. Return a pair of the new
   % clauses and the new variables.
   begin scalar h,pair;
      while h := ibalp_hassimple clausel do <<
	 pair := ibalp_simplify(nil,nil,h,clausel,varal);
	 clausel := car pair;
	 varal := cdr pair
      >>;
      return (clausel . varal)
   end;

procedure ibalp_simplify(dvar,dval,clause,clausel,varal);
   % Simplification. Delete needles literals. [dvar] is a variable;
   % [dval] its value; [clause] is a clause; [clausel] is the list of
   % clauses; [varal] is the A-List of variables. Returns a pair of
   % the new clauses and the new variables.
   begin scalar var,val;
      if null dvar then <<
      	 if ibalp_lenisone ibalp_clause!-getposlit clause then <<
	    var := car ibalp_clause!-getposlit clause;
	    val := 1
      	 >>
      	 else <<
	    var := car ibalp_clause!-getneglit clause;
	    val := 0
      	 >>;
      	 if ibalp_var!-getval var then
	    ibalp_var!-unset(var,ibalp_var!-getval var);
	 ibalp_var!-set(var,val,0,nil);
      >> else <<
	 var := dvar;
	 val := dval
      >>;
      if eqn(val,1) then <<
	 for each clause in ibalp_var!-getposocc var do
	    clausel := ibalp_delclause(clause,clausel);
	 for each clause in ibalp_var!-getnegocc var do
	    ibalp_dellit(var,clause,nil);
      >> else <<
	 for each clause in ibalp_var!-getnegocc var do
	    clausel := ibalp_delclause(clause,clausel);
	 for each clause in ibalp_var!-getposocc var do
	    ibalp_dellit(var,clause,t);
      >>;
      varal := delq(atsoc(ibalp_var!-getid var,varal),varal);
      return (clausel . varal)
   end;

procedure ibalp_lenisone(l);
   l and null cdr l;

procedure ibalp_commonlenisone(l1,l2);
   % l1 and l2 are lists, which are not both empty.
   null l1 and ibalp_lenisone l2 or null l2 and ibalp_lenisone l1;

procedure ibalp_hassimple(clausel);
   % Check if a clause list has some literals to simplify. [clausel]
   % is the list of clauses. Returns a clause to simplfy or [nil].
   begin scalar ret,tl;
      tl := clausel;
      while tl and null ret do << 
	 if ibalp_commonlenisone(
	    ibalp_clause!-getposlit car tl,ibalp_clause!-getneglit car tl)
	 then
	    ret := car tl;
	 tl := cdr tl
      >>;
      return ret
   end;

procedure ibalp_getupl(clausel);
   % Get initial set for Unit Propagation. [clausel] is the list of
   % clauses. Returns a list of unit clauses.
   begin scalar upl;
      for each c in clausel do
	 if null ibalp_clause!-getsat c and
	 eqn(ibalp_clause!-getactpos c + ibalp_clause!-getactneg c,1) then
	    upl := c . upl;
      return upl
   end;

procedure ibalp_unitprop(clist,clausel,level);
   % Unitpropagation. [clist] is a list of clauses with unit
   % variables; [clausel] ist the list of clauses; [level] is the
   % level the reduction is made; [setvar] is the last variable
   % set. Returns a Pair. The first entry is an empty clause if one is
   % derived the second the variable set at last.
   begin scalar tl,clause,actpos,actneg,var,ec,upl,w;
      w := tl := clist;
      while tl and null ec do <<
	 clause := car tl;
	 if null ibalp_clause!-getsat clause then <<
	    actpos := ibalp_clause!-getactpos clause;
	    actneg := ibalp_clause!-getactneg clause;
	    % Since clause is unit, we know that actpos is 1 and
	    % actneg is 0 or vice versa.
	    if actpos #= 1 then <<
	       var := car ibalp_clause!-getwl clause;
	       if null ibalp_var!-getval var then <<
	       	  upl := ibalp_var!-set(var,1,level,clause);
		  nconc(w,upl);
		  w := upl or w
	       >>
	    >> else <<
	       var := car ibalp_clause!-getwl clause;
	       if null ibalp_var!-getval var then <<
	       	  upl := ibalp_var!-set(var,0,level,clause);
		  nconc(w,upl);
		  w := upl or w
	       >>
	    >>
	 >>;
	 tl := cdr tl;
	 ec := ibalp_cec clausel
      >>;
      return (ec . var)
   end;

procedure ibalp_initwl(clausel);
   % Initialize the watched literals. [clausel] is the list of
   % clauses. Returns a list of unit clauses.
   begin scalar count,upl,tl;
      for each c in clausel do <<
	 count := 0;
	 tl := ibalp_clause!-getposlit c;
	 while not eqn(count,2) and tl do <<
	    ibalp_clause!-setwl(c,car tl);
	    ibalp_var!-setwc(car tl,c);
	    count := count + 1;
	    tl := cdr tl
	 >>;
	 tl := ibalp_clause!-getneglit c;
	 while not eqn(count,2) and tl do <<
	    ibalp_clause!-setwl(c,car tl);
	    ibalp_var!-setwc(car tl,c);
	    count := count + 1;
	    tl := cdr tl
	 >>;
	 if count < 2 then upl := c . upl
      >>;
      return upl
   end;

procedure ibalp_renewwl(clausel);
   % Renew watched literals. [clausel] is the list of clauses;
   begin scalar wl;
      for each c in clausel do <<
	 if null ibalp_clause!-getsat c then <<
      	    if eqn(length ibalp_clause!-getwl c,1) and
	       length ibalp_clause!-getposlit c +
	       length ibalp_clause!-getneglit c > 1 then <<
	    	  wl := ibalp_getnewwl c;
	    	  if wl then <<
	       	     ibalp_clause!-setwl(c,wl);
	       	     ibalp_var!-setwc(wl,c)
	    	  >>;
	       >> else 
	 	  if null ibalp_clause!-getwl c  and
	       length ibalp_clause!-getposlit c +
	       length ibalp_clause!-getneglit c > 1 then <<
		  wl := ibalp_getnewwl c;
	       	  if wl then <<
	       	     ibalp_clause!-setwl(c,wl);
	       	     ibalp_var!-setwc(wl,c)
	       	  >>;
	       	  wl := ibalp_getnewwl c;
	       	  if wl then <<
	       	     ibalp_clause!-setwl(c,wl);
	       	     ibalp_var!-setwc(wl,c)
	       	  >>
	       >>
	 >>
      >>
   end;
   
procedure ibalp_resolve(newclause,clause1,clause2,cv);
   % Resolve two clauses to one. [newclause] is the new clause;
   % [clause1] is the first clause to resolve; [clause2] is the second
   % clause to resolve; [cv] is the conflict variable within the two
   % clauses.
   <<
      for each v in ibalp_clause!-getposlit clause1 do
      	 if null (v eq cv) and
	 null memq(v,ibalp_clause!-getposlit newclause) then <<
	    ibalp_clause!-setposlit(newclause,v);
	    ibalp_var!-setposocc(v,newclause);
	    ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v + 1)
	 >>;
      for each v in ibalp_clause!-getposlit clause2 do
      	 if null (v eq cv) and
	 null memq(v,ibalp_clause!-getposlit newclause) then <<
	    ibalp_clause!-setposlit(newclause,v);
	    ibalp_var!-setposocc(v,newclause);
	    ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v + 1)
	 >>;
      for each v in ibalp_clause!-getneglit clause1 do
	 if null (v eq cv) and
	 null memq(v,ibalp_clause!-getneglit newclause) then <<
	    ibalp_clause!-setneglit(newclause,v);
	    ibalp_var!-setnegocc(v,newclause);
	    ibalp_var!-setnumneg(v,ibalp_var!-getnumneg v + 1)
	 >>;
      for each v in ibalp_clause!-getneglit clause2 do
	 if null (v eq cv) and
	 null memq(v,ibalp_clause!-getneglit newclause) then <<
	    ibalp_clause!-setneglit(newclause,v);
	    ibalp_var!-setnegocc(v,newclause);
	    ibalp_var!-setnumneg(v,ibalp_var!-getnumneg v + 1)
	 >>;
   >>;

procedure ibalp_dav(varal,clausel);
   % Delete all assignments to variables. [varal] is the A-List of
   % variables; [clausel] is the list of clauses.
   begin scalar ;
      for each v in varal do <<
	 if ibalp_var!-getval cdr v then <<
	    ibalp_var!-unset(cdr v,ibalp_var!-getval cdr v);
	    ibalp_var!-setflip(cdr v,nil)
	 >>
      >>;
      for each v in varal do <<
	 ibalp_var!-delallwc cdr v
      >>;
      for each c in clausel do
	 ibalp_clause!-delallwl c
   end;
	    
procedure ibalp_calccc!-fuip(ec,level,lv);
   % Calculate conflict clause after Strategy: First UIP. [ec] is the
   % empty clause to start the calculation with; [level] is the
   % conflict level; [lv] is the last variable set. Returns the new
   % learnt clause.
   begin scalar newclause,tv,reas;
      newclause := ibalp_clause!-new();
      ibalp_resolve(newclause,ec,ibalp_var!-getreas lv,lv);
      while tv := ibalp_countgetlev(newclause,level) do <<
	 if eqn(ibalp_var!-getval tv,0) then
	    ibalp_dellit(tv,newclause,t)
	 else
	    ibalp_dellit(tv,newclause,nil);
	 reas := ibalp_var!-getreas tv;
	 if ibalp_clause!-getcount reas then
	    ibalp_clause!-setcount(reas,ibalp_clause!-getcount reas + 1);
	 ibalp_resolve(newclause,newclause,reas,tv);
      >>;
      for each v in ibalp_clause!-getposlit newclause do
	 ibalp_var!-setposcc(v,ibalp_var!-getposcc v + 1);
      for each v in ibalp_clause!-getneglit newclause do
	 ibalp_var!-setnegcc(v,ibalp_var!-getnegcc v + 1);
      ibalp_clause!-setcount(newclause,1);
      return newclause
   end;

procedure ibalp_countgetlev(clause,level);
   % Count variables at a certain level and return a variable at this
   % level if there are more than one. [clause] is a clause; [level]
   % is the level. Returns a
   % variable or [nil]
   begin scalar temp,tv,ret;
      tv := ibalp_clause!-getposlit clause;
      while tv and null ret do <<
	 temp := car tv;
	 if ibalp_var!-getlev temp = level and
	    ibalp_var!-getreas temp then
	       ret := temp;
	 tv := cdr tv;
      >>;
      tv := ibalp_clause!-getneglit clause;
      while tv and null ret do <<
	 temp := car tv;
	 if ibalp_var!-getlev temp = level and
 	    ibalp_var!-getreas temp then
	       ret := temp;
	 tv := cdr tv;
      >>;
      return ret
   end;

procedure ibalp_dellit(lit,clause,posneg);
   % Delete a literal from a clause. [lit] is the literal to delete;
   % [clause] is the clause; [posneg] is [t] if it is a true literal,
   % [nil] else;
   if posneg then <<
      ibalp_var!-setposoccabs(lit,delq(clause,ibalp_var!-getposocc lit));
      ibalp_clause!-setposlitabs(
	 clause,delq(lit,ibalp_clause!-getposlit clause))
   >> else <<
      ibalp_var!-setnegoccabs(lit,delq(clause,ibalp_var!-getnegocc lit));
      ibalp_clause!-setneglitabs(
	 clause,delq(lit,ibalp_clause!-getneglit clause))
   >>;

procedure ibalp_dimcount(clausel);
   % Decrease the counter of newly added clauses. [clausel] is the
   % list of clauses.
   begin scalar doit,tc,c;
      doit := t;
      tc := clausel;
      while doit do <<
	 c := car tc;
	 if null ibalp_clause!-getcount c then
	    doit := nil
	 else
	    ibalp_clause!-setcount(c,ibalp_clause!-getcount c - 0.05);
	 tc := cdr tc
      >>
   end;

procedure ibalp_killcount(clausel);
   % Delete clauses with a count < 1. [clausel] is the list of
   % clauses. Return the new list of clauses.
   begin scalar doit,tc,c;
      doit := t;
      tc := clausel;
      while doit do <<
	 c := car tc;
	 if null ibalp_clause!-getcount c then doit := nil else <<
	    tc := cdr tc;
	    if ibalp_clause!-getcount c < 1 then
	       clausel := ibalp_delclause(c,clausel);
	 >>
      >>;
      return clausel
   end;

procedure ibalp_delclause(c,clausel);
   % Delete a clause. [c] is the clause to delete; [clausel] is the
   % list of clauses.
   <<
      for each v in ibalp_clause!-getposlit c do <<
	 ibalp_var!-setposoccabs(v,delq(c,ibalp_var!-getposocc v));
	 if ibalp_clause!-getcount c then
	    ibalp_var!-setposcc(v,ibalp_var!-getposcc v - 1);
	 if null ibalp_clause!-getsat c then
	    ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v - 1);
	 ibalp_var!-setmom(v,ibalp_calcmom v)
      >>;
      for each v in ibalp_clause!-getneglit c do <<
	 ibalp_var!-setnegoccabs(v,delq(c,ibalp_var!-getnegocc v));
	 if ibalp_clause!-getcount c then 
	    ibalp_var!-setnegcc(v,ibalp_var!-getnegcc v - 1);
	 if null ibalp_clause!-getsat c then
	    ibalp_var!-setnumneg(v,ibalp_var!-getnumneg v - 1);
	 ibalp_var!-setmom(v,ibalp_calcmom v)
      >>;
      for each v in ibalp_clause!-getwl c do <<
	 ibalp_var!-delwc(v,c);
      >>;
      clausel := delq(c,clausel);
      clausel
   >>;

procedure ibalp_getmacvext(varal);
   % Get most active variable. [varal] is the list of
   % variables. Returns a pair of the most active variable and its
   % value.
   begin scalar tv,tm,val;
      tv := ibalp_cv varal;
      if ibalp_var!-getposcc tv > ibalp_var!-getnegcc tv then <<
	 tm := ibalp_var!-getposcc tv;
 	 val := 1
      >> else <<
	 tm := ibalp_var!-getnegcc tv;
	 val := 0
      >>;
      for each v in varal do
	 if null ibalp_var!-getval cdr v then <<
	    if ibalp_var!-getposcc cdr v > tm then <<
	       tv := cdr v;
	       val := 1;
	       tm := ibalp_var!-getposcc tv
	    >>;
	    if ibalp_var!-getnegcc cdr v > tm then <<
	       tv := cdr v;
	       val := 0;
	       tm := ibalp_var!-getnegcc tv
	    >>
      	 >>;
      return (tv . val)
   end;

procedure ibalp_recalcv(varal);
   % Recalc variables activity value. [varal] is the A-List of
   % variables.
   for each v in varal do <<
      ibalp_var!-setposcc(cdr v,ibalp_var!-getposcc cdr v - 0.05);
      ibalp_var!-setnegcc(cdr v,ibalp_var!-getnegcc cdr v - 0.05)
   >>;

procedure ibalp_calccvar(cc,level);
   % Calclate the only conflict variable set at the conflict
   % level. [cc] is the conflict clause; [varal] is the A-List of
   % variables; [level] is the conflict level. Returns a Pair. The
   % first entry is the conflict variable and the second is the
   % highest level of all other variables.
   begin scalar v,rv; integer lev;
      for each v in ibalp_clause!-getposlit cc do <<
	 if eqn(ibalp_var!-getlev v,level) then
	    rv := v
	 else 
	    if ibalp_var!-getlev v > lev then lev := ibalp_var!-getLev v
      >>;
      for each v in ibalp_clause!-getneglit cc do <<
	 if eqn(ibalp_var!-getlev v,level) then
	    rv := v
	 else 
	    if ibalp_var!-getlev v > lev then lev := ibalp_var!-getLev v
      >>;
      return (rv . lev)
   end;

procedure ibalp_tvb(varal,level);
   % Take back all variable assignments down to a certain
   % level. [varal] is the A-List of variables; [level] is the level.
   for each v in varal do
      if ibalp_var!-getlev cdr v >= level then
	 ibalp_var!-unset(cdr v,ibalp_var!-getval cdr v);
	 
procedure ibalp_istotal(varal);
   % Checks if an assignment is total. [varal] is a A-List of
   % variables. Returns [t] if the assigenment is total [nil] else.
   null varal or (ibalp_var!-getval cdar varal and
      ibalp_istotal cdr varal);

procedure ibalp_getvar!-zmom(varal,clausel);
   % Get a variable following the ZMOM (maximum occurrences in minimal
   % clauses ) strategy. [varal] is a A-List of variables. Returns a
   % Pair. The first entry is the chosen variable, the second entry
   % is the value the variable should be set to.
   begin scalar minc,tv,tmax,h,val;
      minc := ibalp_minclnr clausel;
      tmax := -1;
      for each v in varal do <<
	 if null ibalp_var!-getval cdr v and
	    (h := ibalp_var!-getmom cdr v) > tmax then
	       if ibalp_isinminclause(cdr v,minc) then <<
	       	  tv := cdr v;
	       	  tmax := h
	       >>
      >>;
      val := if ibalp_var!-getposcc tv > ibalp_var!-getnegcc tv then 1 else 0;
      return (tv . val)
   end;

procedure ibalp_isinminclause(var,minc);
   % Check if a variable is in a clause of minmal size. [var] is a
   % variable; [minc] is the size of a minimal clause. Returns [t] if
   % the variable is in a clause of minimal size, [nil] else.
   begin scalar tv,ret;
      tv := ibalp_var!-getposocc var;
      while tv and null ret do <<
	 if null ibalp_clause!-getsat car tv and
	    eqn(ibalp_clause!-getactneg car tv +
	    ibalp_clause!-getactpos car tv,minc) then
	       ret := t;
	 tv := cdr tv;
      >>;
      tv := ibalp_var!-getnegocc var;
      while tv and null ret do <<
	 if null ibalp_clause!-getsat car tv and
	    eqn(ibalp_clause!-getactneg car tv +
	    ibalp_clause!-getactpos car tv,minc) then
	       ret := t;
	 tv := cdr tv;
      >>;
      return ret
   end;

procedure ibalp_getvar!-dlcs(varal);
   % Get a variable following the DLCS (dynamic largest combined sum)
   % strategy. [varal] is a A-List of variables. Returns a Pair. The
   % first entry is the chosen variable, the second entry is the value
   % the variable should be set to.
   begin scalar tv,max,val;
      tv := ibalp_cv varal;
      max := ibalp_var!-getnumneg tv + ibalp_var!-getnumpos tv;
      for each var in varal do
	 if null ibalp_var!-getval cdr var then
	    if ibalp_var!-getnumneg cdr var +
	 ibalp_var!-getnumpos cdr var > max then <<
	    tv := cdr var;
	    max := ibalp_var!-getnumneg cdr var +
	       ibalp_var!-getnumpos cdr var
	 >>;
      val := if ibalp_var!-getnumpos tv > ibalp_var!-getnumneg tv then
	 1
      else
 	 0;
      return (tv . val)
   end;

procedure ibalp_minclnr(clausel);
   % Get the size of a minimal clause. [clausel] is the list of
   % clauses. Returns the size of a minimum clause.
   begin scalar min;
      %hack
      min := 100000;
      for each c in clausel do
	 if null ibalp_clause!-getsat c then
	    if ibalp_clause!-getactpos c +
	 ibalp_clause!-getactneg c < min then
	    min := ibalp_clause!-getactpos c +
	 ibalp_clause!-getactneg c;
      return min
   end;

procedure ibalp_calcmom(var);
   % Calculate the zmom value of a variable. [var] is a
   % variable. Returns the mom value.
   (ibalp_var!-getnumpos var + ibalp_var!-getnumneg var)*32 +
      (ibalp_var!-getnumpos var * ibalp_var!-getnumneg var);

procedure ibalp_cec(clausel);
   % Check empty clauses. [clausel] is the list of clauses. Returns
   % the first empty clause if there is one (a clause which is false
   % but has also no unset variables), else [nil].
   if null clausel then
      nil
   else if ibalp_emptyclausep car clausel then
      car clausel
   else
      ibalp_cec cdr clausel;

procedure ibalp_emptyclausep(clause);
   null ibalp_clause!-getsat clause and
      eqn(ibalp_clause!-getactpos clause,0) and
      eqn(ibalp_clause!-getactneg clause,0);

procedure ibalp_csat(clausel);
   % Check SAT. [clausel] is the list of clauses. Returns [t] if all
   % the clauses are true, else [nil].
   null clausel or (ibalp_clause!-getsat car clausel
      and ibalp_csat cdr clausel);
   
procedure ibalp_cv(varal);
   % Choose a variable. [varal] is the A-List of variables. Returns a
   % unset variable.
   if null ibalp_var!-getval cdar varal then
      cdar varal
   else
      ibalp_cv cdr varal;

procedure ibalp_var!-set(var,val,level,reas);
   % Set a variable. [var] is the variable; [val] is value to be set;
   % [level] is the level the variable is set; [reas] is the reason
   % why the variable is set. Sets the given variable from [nil] to
   % [val] and updates all needed data structures. Returns a pair of
   % new unit clauses.
   begin scalar id,sc,upl;
      ibalp_var!-setval(var,val);
      ibalp_var!-setlev(var,level);
      ibalp_var!-setreas(var,reas);
      id := ibalp_var!-getid var;
      sc := if eqn(val,0) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      ibalp_var!-satlist(sc,id);
      sc := if eqn(val,1) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      ibalp_var!-unsatlist(sc,val);
      upl := ibalp_var!-wclist var;
      ibalp_var!-setmom(var,ibalp_calcmom var);
      return upl
   end;

procedure ibalp_var!-satlist(sc,id);
   % Perform changes on the list of satisfied clauses. [sc] is the
   % list of satisfied clauses; [id] is the identifier of the
   % variable.
   for each clause in sc do <<
      if null ibalp_clause!-getsat clause then <<
	 for each v in ibalp_clause!-getposlit clause do <<
	    ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v - 1);
	    ibalp_var!-setmom(v,ibalp_calcmom v)
	 >>;
	 for each v in ibalp_clause!-getneglit clause do <<
	    ibalp_var!-setnumneg(v, ibalp_var!-getnumneg v - 1);
	    ibalp_var!-setmom(v,ibalp_calcmom v)
	 >>;
	 for each v in ibalp_clause!-getwl clause do <<
	    ibalp_var!-delwc(v,clause)
	 >>;
	 ibalp_clause!-delallwl clause;
      >>;
      ibalp_clause!-setsat(clause,id)
   >>;

procedure ibalp_var!-unsatlist(sc,val);
   % Perform changes on the list of unsatisfied clauses. [sc] is the
   % list of unsatisfied clauses; [val] is the value of the
   % variable.
   for each clause in sc do
      if eqn(val,1) then
	 ibalp_clause!-setactneg(clause,
	    ibalp_clause!-getactneg clause - 1)
      else 
	 ibalp_clause!-setactpos(clause,
	    ibalp_clause!-getactpos clause - 1);

procedure ibalp_var!-wclist(var);
   % Perform changes on the list of watched clauses. [var] is the
   % variable. Returns the list of unit clauses.
   begin scalar newwl,upl;
      for each c in ibalp_var!-getwc var do
      	 if null ibalp_clause!-getsat c then <<
	    ibalp_clause!-delwl(c,var);
	    ibalp_var!-delwc(var,c);
	    newwl := ibalp_getnewwl c;
	    if null newwl then
	       upl := c . upl
	    else <<
	       ibalp_clause!-setwl(c,newwl);
	       ibalp_var!-setwc(newwl,c)
	    >>
      	 >>;
      return upl
   end;

procedure ibalp_var!-setq(var,val,level,reas);
   % Set a variable (QSAT). [var] is the variable; [val] is value to
   % be set; [varal] is the list of variables; [level] is the level
   % the variable is set; [reas] is the reason why the variable is
   % set. Sets the given variable from [nil] to [val] and updates all
   % needed data structures. Returns a pair of new unit clauses and
   % new conflict clauses.
   begin scalar clause,id,sc,upl,h,ec;
      ibalp_var!-setval(var,val);
      ibalp_var!-setlev(var,level);
      ibalp_var!-setreas(var,reas);
      id := ibalp_var!-getid var;
      sc := if eqn(val,0) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      ibalp_var!-satlistq(sc,id);
      sc := if eqn(val,1) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      for each clause in sc do <<
	 if eqn(val,1) then
	    ibalp_clause!-setactneg(clause,
	       ibalp_clause!-getactneg clause - 1)
	 else 
	    ibalp_clause!-setactpos(clause,
	       ibalp_clause!-getactpos clause - 1);
	 if h := ibalp_qsat!-isunit clause then upl := (h . clause) . upl;
	 if ibalp_qsat!-isec clause then ec := clause
      >>;
      ibalp_var!-setmom(var,ibalp_calcmom var);
      return (upl . ec)
   end;

procedure ibalp_var!-satlistq(sc,id);
   % Perform changes on the list of satisfied clauses. [sc] is the
   % list of satisfied clauses; [id] is the identifier of the
   % variable.
   for each clause in sc do <<
      if null ibalp_clause!-getsat clause then <<
	 for each v in ibalp_clause!-getposlit clause do <<
	    ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v - 1);
	    ibalp_var!-setmom(v,ibalp_calcmom v)
	 >>;
	 for each v in ibalp_clause!-getneglit clause do <<
	    ibalp_var!-setnumneg(v, ibalp_var!-getnumneg v - 1);
	    ibalp_var!-setmom(v,ibalp_calcmom v)
	 >>;
      >>;
      ibalp_clause!-setsat(clause,id)
   >>;

procedure ibalp_var!-unset(var,val);
   % Unset a variable. [var] is the variable; [val] is value to be
   % unset. Sets the given variable from [val] to [nil] and updates
   % all needed data structures.
   begin scalar clause,id,sc;
      ibalp_var!-setval(var,nil);
      ibalp_var!-setlev(var,-1);
      ibalp_var!-setreas(var,nil);
      id := ibalp_var!-getid var;
      sc := if eqn(val,1) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      for each clause in sc do <<
	 if eqn(val,1) then
	    ibalp_clause!-setactneg(clause,
	       ibalp_clause!-getactneg clause +1)
	 else
	    ibalp_clause!-setactpos(clause,
	       ibalp_clause!-getactpos clause +1)
      >>;
      sc := if eqn(val,0) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var;
      ibalp_unvar!-unsatlist(sc,id);
      ibalp_var!-setmom(var,ibalp_calcmom var)
   end;

procedure ibalp_unvar!-unsatlist(sc,id);
   % Perform changes on the list of unsatisfied clauses. [sc] is the
   % list of unsatisfied clauses; [id] is the identifier of the
   % variable.
   begin scalar newwl;
      for each clause in sc do <<
	 ibalp_clause!-delsat(clause,id);
	 if null ibalp_clause!-getsat clause then <<
      	    for each v in ibalp_clause!-getposlit clause do <<
	       ibalp_var!-setnumpos(v, ibalp_var!-getnumpos v + 1);
	       ibalp_var!-setmom(v,ibalp_calcmom v)
	    >>;
	    for each v in ibalp_clause!-getneglit clause do <<
	       ibalp_var!-setnumneg(v, ibalp_var!-getnumneg v + 1);
	       ibalp_var!-setmom(v,ibalp_calcmom v)
	    >>;
	    for each v in ibalp_clause!-getwl clause do <<
	       ibalp_var!-delwc(v,clause)
	    >>;
	    ibalp_clause!-delallwl clause;
	    newwl := ibalp_getnewwl clause;
	    ibalp_clause!-setwl(clause,newwl);
	    ibalp_var!-setwc(newwl,clause);
	    newwl := ibalp_getnewwl clause;
	    if newwl then <<
	       ibalp_clause!-setwl(clause,newwl);
	       ibalp_var!-setwc(newwl,clause)
	    >>
	 >>
      >>;
   end;

procedure ibalp_var!-unsetq(var,val);
   % Unset a variable (QSAT). [var] is the variable; [val] is value to
   % be unset; Sets the given variable from [val] to [nil] and updates
   % all needed data structures.
   begin scalar clause,v,id,sc;
      ibalp_var!-setval(var,nil);
      ibalp_var!-setlev(var,-1);
      ibalp_var!-setreas(var,nil);
      id := ibalp_var!-getid var;
      sc := if eqn(val,1) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var; 
      ibalp_unvar!-unsatlistq(sc,val);
      sc := if eqn(val,0) then
	 ibalp_var!-getnegocc var
      else
	 ibalp_var!-getposocc var;
      for each clause in sc do <<
	 ibalp_clause!-delsat(clause,id);
	 if null ibalp_clause!-getsat clause then <<
      	    for each v in ibalp_clause!-getposlit clause do <<
	       ibalp_var!-setnumpos(v, ibalp_var!-getnumpos v + 1);
	       ibalp_var!-setmom(v,ibalp_calcmom v)
	    >>;
	    for each v in ibalp_clause!-getneglit(clause) do <<
	       ibalp_var!-setnumneg(v, ibalp_var!-getnumneg v + 1);
	       ibalp_var!-setmom(v,ibalp_calcmom v)
	    >>;
	 >>
      >>;
      ibalp_var!-setmom(var,ibalp_calcmom var)
   end;

procedure ibalp_unvar!-unsatlistq(sc,val);
   % Perform changes on the list of unsatisfied clauses. [sc] is the
   % list of unsatisfied clauses; [val] is the value of the
   % variable.
   for each clause in sc do <<
      if eqn(val,1) then
	 ibalp_clause!-setactneg(clause,
	    ibalp_clause!-getactneg clause +1)
      else
	 ibalp_clause!-setactpos(clause,
	    ibalp_clause!-getactpos clause +1)
   >>;

procedure ibalp_getnewwl(clause);
   % Get a new watched literal for a clause. [clause] is a clause;
   % Returns a new watched literal or [nil].
   begin scalar tl,wl;
      tl := ibalp_clause!-getposlit clause;
      while tl and null wl do <<
	 if null ibalp_var!-getval car tl and
	    null memq(car tl,ibalp_clause!-getwl clause)
	 then
	    wl := car tl;
	 tl := cdr tl
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl and null wl do <<
	 if null ibalp_var!-getval car tl and
	    null memq(car tl,ibalp_clause!-getwl clause)
	 then
	    wl := car tl;
	 tl := cdr tl
      >>;
      return wl
   end;

procedure ibalp_iscnf(f);
   ibalp_clausep f or (rl_op f eq 'and and ibalp_clauselp rl_argn f);

procedure ibalp_clauselp(l);
   null l or (ibalp_clausep car l and ibalp_clauselp cdr l);

procedure ibalp_clausep(s);
   ibalp_litp s or (rl_op s eq 'or and ibalp_litlp rl_argn s);

procedure ibalp_litlp(l);
   null l or (ibalp_litp car l and ibalp_litlp cdr l);

procedure ibalp_litp(s);
   ibalp_atomp s or (rl_op s eq 'not and ibalp_atomp rl_arg1 s);

procedure ibalp_atomp(s);
   % We consider true and false to be atomic formulas at this point.
   rl_tvalp s or (rl_op s eq 'equal and idp ibalp_arg2l s and numberp ibalp_arg2r s);

procedure ibalp_readform(f);
   % Read a formula in cnf. [f] is a formula in cnf in lisp
   % prefix. Returns a pair: [clausel] is the list of clauses; [varal]
   % is the A-List of variables.
   begin scalar pair,clausel,varal,clause,argn,x,c; integer count;
      f := cl_mkstrict(f,'and);
      argn := rl_argn f;
      c := t; while c and argn do <<
	 x := car argn;
	 argn := cdr argn;
	 pair := ibalp_readclause(x,varal);
	 clause := car pair;
	 varal := cdr pair;
	 if clause neq 'true then <<
	    if ibalp_emptyclausep clause then
	       c := nil
	    else
	       (if ibalp_clmember(clause,clausel) or ibalp_redclause clause then <<
	       	  ibalp_undoclause clause;
	       	  count := count + 1
	       >> else
	       	  clausel := car pair . clausel)
	 >>
      >>;
      if null c then <<
      if !*rlverbose then
      	 ioto_tprin2t {"Detected empty clause"};
	 return {clause} . nil
      >>;
      if null clausel then <<
      	 if !*rlverbose then
      	    ioto_tprin2t {"Tautology detected"};
	 return nil . nil
      >>;
      if !*rlverbose then
      	 ioto_tprin2t {"Deleted redundant clauses: ",count};
      return (clausel . varal)
   end;

procedure ibalp_clmember(x,l);
   l and (ibalp_cequal(x,car l) or ibalp_clmember(x,cdr l));

procedure ibalp_cequal(c1,c2);
   begin scalar poslitl1,neglitl1,poslitl2,neglitl2;
      poslitl1 := for each v in ibalp_clause!-getposlit c1 collect
	 ibalp_var!-getid v;
      poslitl2 := for each v in ibalp_clause!-getposlit c2 collect
	 ibalp_var!-getid v;
      if not lto_setequalq(poslitl1,poslitl2) then
	 return nil;
      neglitl1 := for each v in ibalp_clause!-getneglit c1 collect
	 ibalp_var!-getid v;
      neglitl2 := for each v in ibalp_clause!-getneglit c2 collect
	 ibalp_var!-getid v;
      return lto_setequalq(neglitl1,neglitl2)
   end;      

procedure ibalp_undoclause(clause);
   % Undo a clause if it redundant. [clause] is a clause.
   <<
      for each v in ibalp_clause!-getposlit clause do <<
	 ibalp_var!-setposoccabs(v,delq(clause,ibalp_var!-getposocc v));
	 ibalp_var!-setnumpos(v,ibalp_var!-getnumpos v - 1);
	 ibalp_var!-setposcc(v,ibalp_var!-getposcc v - 1)
      >>;
      for each v in ibalp_clause!-getneglit clause do <<
	 ibalp_var!-setnegoccabs(v,delq(clause,ibalp_var!-getnegocc v));
	 ibalp_var!-setnumneg(v,ibalp_var!-getnumneg v - 1);
	 ibalp_var!-setnegcc(v,ibalp_var!-getnegcc v - 1)
      >>
   >>;

procedure ibalp_redclause(clause);
   % Checks if a new clause is redundant. [clause] is a
   % clause. Returns [t] if the clause is redundant, [nil] else.
   begin scalar tv,ret;
      tv := ibalp_clause!-getposlit clause;
     while tv and null ret do <<
	 if ibalp_vmember(car tv,ibalp_clause!-getneglit clause) then
	    ret := t;
	 tv := cdr tv
      >>;
      return ret
   end;

procedure ibalp_vmember(v,vl);
   vl and (ibalp_vequal(v,car vl) or ibalp_vmember(v,cdr vl));

procedure ibalp_vequal(v1,v2);
   ibalp_var!-getid v1 eq ibalp_var!-getid v2;

procedure ibalp_readclause(c,varal);
   % Read a clause. [c] is a clause in lisp prefix; [varal] is the
   % A-List of variables. Returns a pair: [clause] is the created
   % datastructure for this clause; [varal] is the updated list of
   % variables.
   begin scalar x,id,val,clause,nc,posids,negids,cnt;
      nc := rl_argn c;
      clause := ibalp_clause!-new();
      cnt := t; while cnt and nc do <<
	 x := car nc;
	 if x eq 'true then
	    cnt := nil
	 else <<
	    nc := cdr nc;
	    if x neq 'false then <<
	       if rl_op x eq 'not then <<
	       	  id := ibalp_arg2l rl_arg1 x;
	       	  val := 1 #- ibalp_arg2r rl_arg1 x
	       >> else <<
	       	  id := ibalp_arg2l x;
	       	  val := ibalp_arg2r x
	       >>;
	       if val #= 1 then <<
	       	  if not memq(id,posids) then <<  
	       	     ibalp_clause!-setactpos(clause,
		     	ibalp_clause!-getactpos clause + 1);
	       	     posids := id . posids;
	       	     varal := ibalp_process!-var(clause,varal,id,1)
	       	  >>
	       >> else <<
	       	  if not memq(id,negids) then <<
	       	     ibalp_clause!-setactneg(clause,
		     	ibalp_clause!-getactneg clause + 1);
	       	     negids := id . negids;
	       	     varal := ibalp_process!-var(clause,varal,id,0)
	       	  >>
	       >>
	    >>
      	 >>
      >>;
      if not cnt then
	 return 'true . varal;
      return (clause . varal)
   end;

procedure ibalp_qsat!-readdimacs2(file);
   % Read a .cnf or .qdimacs file. [file] is the filename. Returns a
   % pair of the clauses and variables of this file.
   begin scalar ch,tok,doit,numvars,numclauses,varal,clausel,pair,qsat;
      ch := open(file, 'input);
      rds ch;
      tok := read();
      if not (tok eq 'p or tok eq 'c) then <<
	 rederr "Invalid input format";
	 rds nil;
      	 close(ch);
	 return {'false}
      >>;
      if tok eq 'c then doit := t;
      while doit do <<
      	 tok := read();
	 if tok eq 'p then doit := nil
      >>;
      tok := read();
      if not (tok eq 'cnf) then rederr "Invalid input format";
      numvars := read();
      numclauses := read();
      if !*rlverbose then
      	 ioto_tprin2t {"Reading ",numvars," variables and ",
	    numclauses," clauses"};
      tok := read();
      if tok eq 'e or tok eq 'a then <<
	 qsat := t;
	 if !*rlverbose then
      	    ioto_tprin2t "Q-SAT: Reading quantifiers";
	 pair := ibalp_readquant!-cnf(tok);
	 tok := car pair;
	 varal := cdr pair
      >>;
      pair := ibalp_readclause!-cnf(numclauses,varal,tok);
      clausel := car pair;
      varal := cdr pair;
      rds nil;
      close(ch);
      return (qsat . (clausel . varal))
   end;

procedure ibalp_readquant!-cnf(tok);
   % Read quantifier list from a .qdimacs file. [tok] is the last read
   % token. Returns a pair of the last read token and the new
   % variables.
   begin scalar varal,quant,level,doit,qswitch,var;
      if tok eq 'e then quant := 'ex else quant := 'all;
      level := 1;
      doit := t;
      while doit or qswitch do <<
	 tok := read();
	 if eqn(tok,0) then <<
	    doit := nil;
	    tok := read();
	    if tok eq 'a or tok eq 'e then <<
	       qswitch := t;
	       quant := if tok eq 'a then 'all else 'ex;
	       level := level + 1
	    >> else
	       qswitch := nil;
	 >> else <<
	    var := ibalp_var!-new(tok);
	    ibalp_var!-setqlevel(var,level);
	    ibalp_var!-setquant(var,quant);
	    varal := (tok . var) . varal;
	 >>
      >>;
      varal := reverse varal;
      return (tok . varal)
   end;

procedure ibalp_readclause!-cnf(numclauses,varal,lt);
   % Reads the clauses of a .cnf or .qdimacs file. [numclauses] is the
   % number of clauses; [varal] is the A-List of variables; [lt] is
   % the last read token. Returns a pair of clauses / variables.
   begin scalar doit,poslit,neglit,clause,tok,clausel,first; integer count;
      first := t;
      for i := 1 : numclauses do <<
      	 doit := t;
	 poslit := nil;
	 neglit := nil;
	 clause := ibalp_clause!-new();
      	 while doit do <<
	    if first then <<
	       tok := lt;
	       first := nil
	    >>
	    else
      	       tok := read();
      	    if tok = 0 then
	       doit := nil
	    else
	       if tok < 0 and null memq(-tok,neglit) then <<
		  ibalp_clause!-setactneg(clause,
		     ibalp_clause!-getactneg clause + 1);
		  varal := ibalp_process!-var(clause,varal,-tok,0)
	       >> else if tok > 0 and null memq(tok,poslit) then <<
		  ibalp_clause!-setactpos(clause,
		     ibalp_clause!-getactpos clause + 1);
		  varal := ibalp_process!-var(clause,varal,tok,1)
	       >>
      	 >>;
	 if ibalp_clmember(clause,clausel) or ibalp_redclause clause then <<
	    ibalp_undoclause clause;
	    count := count + 1
	 >> else
	    clausel := clause . clausel;
      >>;
      if !*rlverbose then
      	 ioto_tprin2t {"Deleted Redundant Clauses: ",count};
      return (clausel . varal)
   end;

procedure ibalp_process!-var(clause,varal,id,val);
   % Process a variable of the input. [clause] is a clause; [varal] is
   % the A-List of variables; [id] is a number; [val] is the value of
   % the variable. Returns the new A-List of variables.
   begin scalar h,var;
      id := intern compress('!! . explode id);
      if h := atsoc(id,varal) then
	 var := cdr h
      else <<
	 var := ibalp_var!-new(id);
	 varal := (id . var) . varal
      >>;
      if eqn(val,1) then <<
	 ibalp_var!-setposocc(var,clause);
	 ibalp_var!-setnumpos(var,ibalp_var!-getnumpos var + 1);
	 ibalp_var!-setposcc(var,ibalp_var!-getposcc var + 1);
	 ibalp_clause!-setposlit(clause,var)
      >>
      else <<
	 ibalp_var!-setnegocc(var,clause);
	 ibalp_var!-setnumneg(var,ibalp_var!-getnumneg var + 1);
	 ibalp_var!-setnegcc(var,ibalp_var!-getnegcc var + 1);
	 ibalp_clause!-setneglit(clause,var)
      >>;
      return varal
   end;

procedure ibalp_get3cnf(f);
   % Generate set of polynomials 3CNF. [f] is a formula. [trthval] is
   % 0 or 1. Returns a list of polynomials by transforming [f] into a
   % into a conjunctive clausal form, containing max 3 variables per
   % clause.
   begin scalar newf,newform;
      newf := f;
      newf := ibalp_pset3knfnf newf;
      newf := ibalp_pset3knf2(newf,nil);
      newf := if rl_op newf eq 'and then
            rl_mkn('and,for each j in rl_argn newf join
               ibalp_pset3knf3(j,nil))
         else
            rl_smkn('and,ibalp_pset3knf3(newf,nil));
      newform := for each c in rl_argn newf join
	 if rl_op c = 'equal or rl_op c = 'not then
	    {c}
	 else
	    rl_argn ibalp_cnf c;
      newform := 'and . newform;
      return newform
   end;

procedure ibalp_convcnf(clausel,varal,qsat);
   % Converts a list of clauses and variables into Lisp
   % Prefix. [clausel] is the list of variables; [varal] is the A-List
   % of variables; [qsat] indicates if it is a Q-SAT problem or
   % not. Returns the corresponding formula in lisp-prefix.
   begin scalar formula,tempcl,id,newvaral,rvaral;
      for each v in varal do <<
	 id := ibalp_var!-mkid ibalp_var!-getid cdr v;
	 newvaral := (ibalp_var!-getid cdr v . id) . newvaral
      >>;
      for each clause in clausel do <<
	 tempcl := nil;
	 for each v in ibalp_clause!-getposlit clause do <<
	    id := cdr atsoc(ibalp_var!-getid v,newvaral);
	    tempcl := {'equal,id,1} . tempcl;
	 >>;
	 for each v in ibalp_clause!-getneglit clause do <<
	    id := cdr atsoc(ibalp_var!-getid v,newvaral);
	    tempcl := {'equal,id,0} . tempcl
	 >>;
	 if length tempcl > 1 then
	    tempcl := 'or . tempcl
	 else 
	    tempcl := {'equal, cadar tempcl,caddar tempcl};
	 formula := tempcl . formula;
      >>;
      if length formula > 1 then 
      	 formula := 'and . formula;
      if qsat then <<
	 rvaral := reverse varal;
	 for each v in rvaral do <<
	    id := cdr atsoc(ibalp_var!-getid v,newvaral);
	    if ibalp_var!-isex cdr v then
	       formula := {'ex, id, formula}
	    else
	       formula := {'all, id, formula}
	 >>
      >>;
      return formula
   end;

procedure ibalp_var!-mkid(tok);
   % Turn a number into a identifier. [tok] is a number. Returns an
   % identifier.
   intern compress ('v . 'a . 'r . explode tok);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% QSAT %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

procedure ibalp_qsat!-cdcl(clausel,varal,origupl,qsat);
   % Main procedure for the conflictdriven clausel-learning QSAT
   % algorithm. [clausel] is the list of clauses; [varal] is the
   % A-List of variables; [origupl] is a set of initial unit clauses;
   % [qsat] indicates if it is a Q-SAT problem or a parametric
   % one. Return [true] if the formula is true, [false] else.
   begin scalar fin,break,res,level,pair,ec,lv,upl;
      pair := ibalp_qsat!-preprocess(clausel,varal,origupl,qsat);
      if car pair then return car pair;
      clausel := cadr pair;
      varal := cddr pair;
      level := 1;
      while null fin do <<
	 break := nil;
	 pair := ibalp_qsat!-cv(clausel,varal,level);
	 if cdr pair and eqn(level,1) then <<
	    res := {'false};
	    break := t;
	    fin := t
	 >> else
	    upl := car pair;
	 while null break do <<
	    pair := ibalp_qsat!-cdclup(upl,level);
	    ec := car pair;
	    lv := cdr pair;
	    if ec then <<
	       pair := ibalp_qsat!-analconf(ec,lv,level,clausel,varal);
	       if cddr pair < 0 then <<
		  res := {'false};
		  break := t;
		  fin := t
	       >> else <<
		  clausel := car pair;
		  level := cddr pair;
		  upl := car ibalp_qsat!-btcase(level,
		     cadr pair,varal,car clausel,t);
		  ec := nil
	       >>
	    >> else if ibalp_qsat!-csat clausel then <<
	       pair := ibalp_qsat!-analsatNAIV varal;
	       if cdr pair <= 0 then <<
		  res := {'true};
		  break := t;
		  fin := t
	       >> else <<
		  level := cdr pair;
		  upl := car ibalp_qsat!-btcase(level,car pair,varal,nil,nil);
	       >>
	    >> else <<
	       break := t;
	       level := level + 1
	    >>
	 >>
      >>;
      return (res . (clausel . varal))
   end;

procedure ibalp_qsat!-preprocess(clausel,varal,origupl,qsat);
   % Perform pre-processing on the formula. [clausel] is the list of
   % clauses; [varal] is the A-List of variables; [origupl] is the set
   % of initial unit clauses; [qsat] indicates if it is a Q-SAT or a
   % parametric problem. Return a pair of clauses/variables and a
   % possible return value (Sudden death).
   begin scalar pair,res;
      pair := ibalp_qsat!-cdclup(origupl,-1);
      if car pair then res := ({'false} . (clausel . varal));
      if qsat then <<
      	 pair := ibalp_qsat!-doSimpl(clausel,varal);
      	 clausel := car pair;
      	 varal := cdr pair
      >>;
      if ibalp_qsat!-csat clausel then res := ({'true} . (clausel . varal));
      if null clausel then res := ({'true} . (clausel . varal));
      if ibalp_qsat!-abort clausel then res := ({'false} . (clausel . varal));
      return (res . (clausel . varal))
   end;

procedure ibalp_qsat!-doSimpl(clausel,varal);
   % Do simplifications on the formula. [clausel] is the list of
   % clauses; [varal] is the A-List of variables. Return a pair of
   % clauses and variables.
   begin scalar h,pair; integer count;
      while h := ibalp_hassimple clausel do <<
      	 pair := ibalp_simplify(nil,nil,h,clausel,varal);
      	 clausel := car pair;
      	 varal := cdr pair
      >>;
      for each v in varal do <<
	 if ibalp_var!-isex cdr v and
	    eqn(ibalp_var!-getnumpos cdr v,0) then <<
	       count := count + 1;
	       ibalp_var!-setq(cdr v,0,0,nil);
	       pair := ibalp_simplify(cdr v,0,nil,clausel,varal);
	       clausel := car pair;
	       varal := cdr pair;
	    >> else if ibalp_var!-isex cdr v and
	    eqn(ibalp_var!-getnumneg cdr v,0) then <<
	       count := count + 1;
	       ibalp_var!-setq(cdr v,1,0,nil);
	       pair := ibalp_simplify(cdr v,1,nil,clausel,varal);
	       clausel := car pair;
	       varal := cdr pair;
      	    >>
      >>;
      if !*rlverbose then 
      	 ioto_tprin2t {"Deleted variables in pre-processing: ",count};
      return (clausel . varal)
   end;

procedure ibalp_qsat!-cv(clausel,varal,level);
   % Choose and set a variable. [clausel] is the list of clauses;
   % [varal] is the A-List of variables; [level] is the current
   % level. Returns the new list of unit clauses.
   begin scalar cv,temp;
      cv := ibalp_qsat!-mom(varal,clausel);
      temp := ibalp_var!-setq(cv,1,level,nil);
      if cdr temp then <<
	 ibalp_var!-unsetq(cv,1);
	 temp := ibalp_var!-setq(cv,0,level,nil)
      >>;
      ibalp_var!-setflip(cv,0);
      return temp
   end;

procedure ibalp_qsat!-btcase(blevel,bvar,varal,cc,val);
   % Subprocedure for the backtrack case. [blevel] is the backtracking
   % level; [bvar] is the backtrack variable; [varal] is the A-List of
   % variables; [cc] is the new learnt clause; [val] indicates if it
   % is a conflict-driven or a SAT-driven backtracking. Returns the
   % list of new unit clauses.
   begin scalar tval,temp;
      tval := ibalp_var!-getval bvar;
      ibalp_qsat!-backtrack(blevel,varal,val);
      temp := ibalp_var!-setq(bvar,1-tval,blevel,cc);
      ibalp_var!-setflip(bvar,1);
      return temp
   end;


procedure ibalp_qsat!-analconf(ec,lv,level,clausel,varal);
   % Clausel Learning backtracking. [ec] is the conflict clause; [lv]
   % is the variable last set; [level] is the current level; [clausel]
   % is the list of clauses; [varal] is the A-List of
   % variables. Returns a pair. The first entry is the new list of
   % clauses. The second entry is a pair of conflict variable and the
   % conflict-level.
   begin scalar cl,cc,cv;
      if eqn(level,0) then return (clausel . (nil . -1));
      cc := ibalp_qsat!-calccc(varal,ec,lv);
      if null cc then
	 return (clausel . (nil . -1))
      else <<
	 cv := ibalp_qsat!-calccvar cc;
	 cl := ibalp_qsat!-getbtlevel(cc,level);
	 clausel := cc . clausel;
      	 return (clausel . (cv . cl))
      >>
   end;

procedure ibalp_qsat!-mom(varal,clausel);
   % Get a variable following the original MOM-strategy. [varal] is
   % the A-List of variables; [clausel] is the list of
   % clauses. Returns a variable.
   begin scalar min,tv,h,qlevel,tmom;
      min := ibalp_minclnr clausel;
      qlevel := ibalp_qsat!-qlevel varal;
      tmom := -1;
      for each v in varal do
	 if eqn(ibalp_var!-getqlevel cdr v,qlevel)
	    and null ibalp_var!-getval cdr v
	       and ibalp_var!-getquant cdr v then 
	    	  if (h := ibalp_qsat!-calcmom(cdr v,min)) > tmom then <<
	       	     tmom := h;
	       	     tv := cdr v
	    	  >>;
      return tv
   end;

procedure ibalp_qsat!-calcmom(var,min);
   % Calculate the mom value of a variable. [var] is a variable; [min]
   % is the size of minimal clause. Returns the mom value.
   begin integer minpos,minneg;
      for each clause in ibalp_var!-getposocc var do
	 if null clause and eqn(ibalp_clause!-getactpos clause +
	    ibalp_clause!-getactneg clause,min) then
	       minpos := minpos + 1;
      for each clause in ibalp_var!-getnegocc var do
	 if null clause and eqn(ibalp_clause!-getactpos clause +
	    ibalp_clause!-getactneg clause,min) then
	       minneg := minneg + 1;
      return (minpos + minneg)*64 + (minpos * minneg)
   end;

procedure ibalp_qsat!-qlevel(varal);
   % Return the current quantification level. [varal] is the A-List of
   % variables. Returns the current quantification level.
   if null ibalp_var!-getval cdar varal then
      ibalp_var!-getqlevel cdar varal
   else
      ibalp_qsat!-qlevel cdr varal;

procedure ibalp_qsat!-hassimple(clausel);
   % Check if a clause list has some literals to simplify. [clausel]
   % is the list of clauses. Returns a clause to simplfy or [nil].
   begin scalar ret,tl,tv;
      tl := clausel;
      while tl and null ret do <<
      	 if eqn(length ibalp_clause!-getposlit car tl +
      	    length ibalp_clause!-getneglit car tl,1) then <<
	       tv := if null ibalp_clause!-getposlit car tl then
		  car ibalp_clause!-getneglit car tl
	       else
	 	  car ibalp_clause!-getposlit car tl;
	       if ibalp_var!-isex tv and ibalp_var!-getreas tv then 
		  ret := car tl
	       if ibalp_var!-isex tv and ibalp_var!-getreas tv then
		  ret := car tl;
	    >>;
	 tl := cdr tl;
      >>;
      return ret
   end;

procedure ibalp_qsat!-abort(clausel);
   % Checks for contradictions after simplification. [clausel] is the
   % list of clauses. Return [t] if there is a contradiction, [nil]
   % else.
   if null clausel then nil else
      if null ibalp_clause!-getposlit car clausel
	 and null ibalp_clause!-getneglit car clausel then t
      else
	 ibalp_qsat!-abort cdr clausel;

procedure ibalp_qsat!-calccvar(clause);
   % Calculate the conflict variable of a new learnt clause. [clause]
   % is the new learnt clause. Returns the conflict variable.
   begin scalar tl,tv,cv,level;
      level := -1;
      tl := ibalp_clause!-getposlit clause;
      while tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and ibalp_var!-getlev tv > level then <<
	    level := ibalp_var!-getlev tv;
	    cv := tv
	 >>;
	 tl := cdr tl
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and ibalp_var!-getlev tv > level then <<
	    level := ibalp_var!-getlev tv;
	    cv := tv
	 >>;
	 tl := cdr tl
      >>;
      return cv
   end;

procedure ibalp_qsat!-getbtlevel(clause,oldlev);
   % Calculate the backtrack level after a conflict case. [clause] is
   % the new learnt clause; [oldlev] is the old level; Returns the
   % backtrack level.
   begin scalar tl,tv,level,tlevel;
      level := -1;
      tl := ibalp_clause!-getposlit clause;
      tlevel := ibalp_var!-getlev ibalp_qsat!-calccvar clause;
      while tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and
	    ibalp_var!-getlev tv > level and ibalp_var!-getlev tv < tlevel then
	    level := ibalp_var!-getlev tv;
	 tl := cdr tl
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and
	    ibalp_var!-getlev tv > level and ibalp_var!-getlev tv < tlevel then
	    level := ibalp_var!-getlev tv;
	 tl := cdr tl
      >>;
      return if eqn(level,-1) then oldlev - 1 else level
   end;

procedure ibalp_qsat!-calccc(varal,ec,lv);
   % Calculate conflict clause after Strategy: First UIP. [varal] is a
   % A-List of variables; [ec] is the empty clause to start the
   % calculation with [lv] is the last variable set. Returns the new
   % generated clause or nil if there is a sudden death.
   begin scalar newclause,tv,reas,doit,res;
      newclause := ibalp_clause!-new();
      res := t;
      ibalp_resolve(newclause,ec,ibalp_var!-getreas lv,lv);
      doit := ibalp_qsat!-doresolve(newclause,varal);
      if cdr doit then return nil; 
      while car doit and res do <<
	 tv := ibalp_qsat!-getresvar newclause;
	 if eqn(ibalp_var!-getval tv,0) then
	    ibalp_dellit(tv,newclause,t)
	 else
	    ibalp_dellit(tv,newclause,nil);
	 reas := ibalp_var!-getreas tv;
	 if ibalp_clausetest(reas,newclause) then res := nil;
	 if not (null ibalp_clause!-getcount reas) then
	    ibalp_clause!-setcount(reas,ibalp_clause!-getcount reas + 1);
	 ibalp_resolve(newclause,newclause,reas,tv);
	 doit := ibalp_qsat!-doresolve(newclause,varal);
	 if cdr doit then res := nil
      >>;
      ibalp_clause!-setcount(newclause,1);
      return if res then newclause else nil;
   end;

procedure ibalp_clausetest(clause1,clause2);
   % Tests if two clauses have the same literal. [clause1] is a
   % clause; [clause2] is a clause. Returns [t] or [nil].
   ibalp_clause!-getposlit clause1 equal ibalp_clause!-getposlit clause2
      and ibalp_clause!-getneglit clause1 equal
	 ibalp_clause!-getneglit clause2;

procedure ibalp_qsat!-doresolve(newclause,varal);
   % Test the stopping criterion for resolving. [newclause] is a
   % clause; [varal] is the A-List of variables. Returns a pair. The
   % first entry is the result of the test, the second is a flag for a
   % sudden death.
   begin scalar hl,cl,hv,decv,ac1,ac2;
      hl := -2;
      for each v in ibalp_clause!-getposlit newclause do <<
	 if ibalp_var!-isex v then <<
	    ac1 := t;
	    if ibalp_var!-getlev v > hl then <<
	       hl := ibalp_var!-getlev v;
	       hv := v;
	       cl := 1
	    >> else if eqn(ibalp_var!-getlev v,hl) then
 	       cl := cl + 1;
 	    if ibalp_var!-getlev v > 0 then ac2 := t
	 >>
      >>;
      for each v in ibalp_clause!-getneglit newclause do <<
	 if ibalp_var!-isex v then <<
	    ac1 := t;
	    if ibalp_var!-getlev v > hl then <<
	       hl := ibalp_var!-getlev v;
	       hv := v;
	       cl := 1
	    >> else if eqn(ibalp_var!-getlev v,hl) then
 	       cl := cl + 1;
 	    if ibalp_var!-getlev v > 0 then ac2 := t
	 >>
      >>;
      if null ac1 or null ac2 then return (nil . t);
      if cl > 1 then return (t . nil);
      decv := ibalp_qsat!-searchdec(hl,varal);
      if not (ibalp_var!-isex decv) then return (t . nil);
      return ibalp_qsat!-unicheck(newclause,hv)
   end;

procedure ibalp_qsat!-searchdec(level,varal);
   % Search a decision variable at a certain level. [level] is the
   % level; [varal] is the A-List of variables.
   if null varal then nil else
      if eqn(ibalp_var!-getlev cdar varal,level) and
      null ibalp_var!-getreas cdar varal then
	 cdar varal
      else
	 ibalp_qsat!-searchdec(level,cdr varal);

procedure ibalp_qsat!-unicheck(clause,var);
   % Checks the third condition of the stopping criterion. [clause] is
   % a clause; [var] is a single variable. Returns a pair. The first
   % entry indicates the result of the check.
   begin scalar tl,res,tv,ql,dl;
      ql := ibalp_var!-getqlevel var;
      dl := ibalp_var!-getlev var;
      tl := ibalp_clause!-getposlit clause;
      while tl and null res do <<
	 tv := car tl;
	 if ibalp_var!-isuni tv and
	    ibalp_var!-getqlevel tv < ql then
	       if not (eqn(ibalp_var!-getval tv,0) and
		  ibalp_var!-getlev tv < dl) then
		     res := t;
	 tl := cdr tl;
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl and null res do <<
	 tv := car tl;
	 if ibalp_var!-isuni tv and
	    ibalp_var!-getqlevel tv < ql then
	       if not (eqn(ibalp_var!-getval tv,0) and
		  ibalp_var!-getlev tv < dl) then
		     res := t;
	 tl := cdr tl;
      >>;
      return (res . nil);
   end;

procedure ibalp_qsat!-getresvar(clause);
   % Get the variable for the next resolve. [clause] is a
   % clause. Returns a variable.
   begin scalar tl,tv,res,lev;
      tl := ibalp_clause!-getposlit clause;
      lev := -2;
      while tl do <<
      	 tv := car tl;
	 if ibalp_var!-getreas tv and ibalp_var!-getlev tv > lev then <<
	    res := tv;
	    lev := ibalp_var!-getlev tv
	 >>;
	 tl := cdr tl;
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl do <<
      	 tv := car tl;
	 if ibalp_var!-getreas tv and ibalp_var!-getlev tv > lev then <<
	    res := tv;
	    lev := ibalp_var!-getlev tv
	 >>;
	 tl := cdr tl;
      >>;
      return res
   end;

procedure ibalp_qsat!-analsatNAIV(varal);
   % Naive SAT-driven backtracking. [varal] is the A-List of
   % variables. Returns a pair of branching variable and the
   % branch-level.
   begin scalar cv,cl;
      cl := -1;
      for each v in varal do <<
	 if ibalp_var!-isuni cdr v and eqn(ibalp_var!-getflip cdr v,0) then
	    if ibalp_var!-getlev cdr v > cl then <<
	       cl := ibalp_var!-getlev cdr v;
	       cv := cdr v
	    >>
      >>;
      return (cv . cl)
   end;

procedure ibalp_qsat!-backtrack(level,varal,val);
   % Backtrack to a certain level. [level] is the backtrack level;
   % [varal] is the A-List of variables; [val] indicates if it is a
   % Conflict-driven or a SAT-driven backtracking.
   if val then <<
      for each v in varal do
      	 if ibalp_var!-getlev cdr v > level then <<
	    ibalp_var!-unsetq(cdr v,ibalp_var!-getval cdr v);
	    ibalp_var!-setflip(cdr v,nil)
      	 >>
   >> else <<
      for each v in varal do
	 if ibalp_var!-getlev cdr v >= level then <<
	    ibalp_var!-unsetq(cdr v,ibalp_var!-getval cdr v);
	    ibalp_var!-setflip(cdr v,nil)
      	 >>
   >>;

procedure ibalp_qsat!-cdclup(clist,level);
   % Unitpropagation. [clist] is a list of clauses with unit
   % variables; [level] is the level the reduction is made; Returns a
   % Pair. The first entry is an empty clause if one is derived the
   % second the variable set at last.
   begin scalar tl,tv,lv,ec,upl,temp;
      tl := clist;
      while tl and null ec do <<
	 tv := car tl;
	 if null ibalp_clause!-getsat cdr tv then <<
	    temp := ibalp_var!-setq(caar tv,cdar tv,level,cdr tv);
	    upl := car temp;
	    nconc(tl,upl)
	 >>;
	 tl := cdr tl;
	 lv := caar tv;
	 ec := cdr temp;
      >>;
      return (ec. lv)
   end;

procedure ibalp_qsat!-isunit(clause);
   % Check if a clause is a unit clause. [clause] is a clause. Returns
   % the unit variable and its assignment of a unit clause or [nil] if
   % the clause is not unit.
   begin scalar tl,tv,min,te; integer ce;
      if ibalp_clause!-getsat clause then return nil;
      %dirty hack
      min := 10000;
      tl := ibalp_clause!-getposlit clause;
      while tl and ce < 2 do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and null ibalp_var!-getval tv then <<
	    ce := ce + 1;
	    te := (tv . 1)
	 >>;
	 if ibalp_var!-isuni tv and null ibalp_var!-getval tv and
 	    ibalp_var!-getqlevel tv < min then min := ibalp_var!-getqlevel tv;
	 tl := cdr tl
      >>;
      tl := ibalp_clause!-getneglit clause;
      while tl and ce < 2 do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and null ibalp_var!-getval tv then <<
	    ce := ce + 1;
	    te := (tv . 0)
	 >>;
	 if ibalp_var!-isuni tv and null ibalp_var!-getval tv and
 	    ibalp_var!-getqlevel tv < min then min := ibalp_var!-getqlevel tv;
	 tl := cdr tl
      >>;
      return if eqn(ce,1) and ibalp_var!-getqlevel car te < min then
	 te
      else
	 nil
   end;

procedure ibalp_qsat!-isec(clause);
   % Check if a clause is an empty clause. [clausel] is the list of
   % clauses. Returns [t] if the clause is a empty clause, [nil] else.
   begin scalar ec,tl,tv;
      if ibalp_clause!-getsat clause then return nil;
      ec := t;
      tl := ibalp_clause!-getposlit clause;
      while ec and tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and
 	    not eqn(ibalp_var!-getval tv,0) then ec := nil;
	 if ibalp_var!-isuni tv and
	    eqn(ibalp_var!-getval tv,1) then ec := nil;
	 if null ibalp_var!-getquant tv and null ibalp_var!-getval tv then
	    ec := nil;
	 tl := cdr tl
      >>;
      tl := ibalp_clause!-getneglit clause;
      while ec and tl do <<
	 tv := car tl;
	 if ibalp_var!-isex tv and
 	    not eqn(ibalp_var!-getval tv,1) then ec := nil;
	 if ibalp_var!-isuni tv and
	    eqn(ibalp_var!-getval tv,0) then ec := nil;
	 if null ibalp_var!-getquant tv and null ibalp_var!-getval tv then
	    ec := nil;
	 tl := cdr tl
      >>;
      return ec
   end;

procedure ibalp_qsat!-csat(clausel);
   % Check if the formula is satisfied. [clausel] is the List of
   % clauses. Returns [t] if all clauses are satisfied, [nil] else.
   ibalp_csat clausel;
   
procedure ibalp_readquantal(formula,varal);
   % Read prenex quantifiers of a formula. [formula] is a formula in
   % LISP-Prefix, [varal] is the A-List of variables. Reads the
   % quantifiers and annotates each quantified variable with its
   % quantifier and its quantification level. Returns a pair of the
   % highest quantification level and the A-List of the new sorted
   % variables.
   begin scalar hl,tl;
      tl := ibalp_readquantal2(formula,varal,rl_op formula,1,nil);
      hl := ibalp_var!-getqlevel cdar tl;
      for each v in varal do
	 if null ibalp_var!-getquant cdr v then
	    tl := v . tl;
      tl := reverse tl;
      return (hl . tl)
   end;

procedure ibalp_readquantal2(formula,varal,quant,level,newvaral);
   % Helper function for reading prenex quantifiers of a
   % formula. [formula] is a formula in LISP-Prefix, [varal] is the
   % A-List of variables, [quant] is the current quantifier, [level]
   % is the current quantification level, [varal] is the new A-list of
   % variables. Returns a A-List of the new sorted variables.
   if rl_quap rl_op formula then <<
      if not (rl_op formula eq quant) then level := level + 1;
      if atsoc(rl_var formula,varal) then <<
      	 ibalp_var!-setquant(cdr atsoc(rl_var formula,varal),rl_op formula);
      	 ibalp_var!-setqlevel(cdr atsoc(rl_var formula,varal),level);
      	 newvaral := (ibalp_var!-getid cdr atsoc(rl_var formula,varal) .
	    cdr atsoc(rl_var formula,varal)) . newvaral
      >>;
      ibalp_readquantal2(rl_mat formula,varal,rl_op formula,level,newvaral)
   >> else
      newvaral;

%%%%%%%%%%%%%%%%%%%%%%%%%% Parametric QSAT %%%%%%%%%%%%%%%%%%%%%%%%%%

procedure ibalp_qsat!-par(fvl,clausel,varal,result,psat);
   % The main procedure for parametric Q-SAT. [fvl] is the list of
   % currently free variables; [clausel] is the list of clauses; [varal] is the
   % A-List of variables; [result] is the current list of
   % results; [pqsat] ist the list of free variables. Returns a pair of the 
   % result and the clauses/variables.
   begin scalar tv,res,pair,ec,upl,pair2,ec2;
      tv := ibalp_getfree!-dlcs fvl;
      if null tv then <<
	 if (not member(ibalp_qsat!-calcbin fvl,donel!*)) then <<
	    upl := ibalp_qsat!-getupl clausel;
	    res := ibalp_qsat!-cdcl(clausel,varal,upl,nil);
	    numcdcl!* := numcdcl!* + 1;
	    donel!* := ibalp_qsat!-calcbin fvl . donel!*; 
	    if car res = {'true} then <<
	       result := (ibalp_exres fvl) . result;
	       if psat then
	       	  result := ibalp_qsat!-localsearch(clausel,varal,length fvl,
		     fvl,result);
	    >>;
	    return (result . (cadr res . cddr res));
	 >> else 
	    return (result . (clausel . varal));
      >> else <<
	 ec := ibalp_var!-setq(tv,1,-42,nil);
	 if null cdr ec then <<
	    pair := ibalp_qsat!-par(fvl,clausel,varal,result,psat);
    	    result := car pair;
    	    clausel := cadr pair;
    	    varal := cddr pair;
    	    ibalp_qsat!-dav varal;	
	 >>;
	 ibalp_var!-unsetq(tv,1);
	 ec := ibalp_var!-setq(tv,0,-42,nil);
	 if null cdr ec then <<
	    pair := ibalp_qsat!-par(fvl,clausel,varal,result,psat);
	    result := car pair;
	    clausel := cadr pair;
	    varal := cddr pair;
	    ibalp_qsat!-dav varal;
	 >>;
	 ibalp_var!-unsetq(tv,0);
	 return (result . (clausel . varal))
      >>
   end;

procedure ibalp_qsat!-localsearch(clausel,varal,radius,fvl,result);
   % Performs a local search with a given radius. [clausel] is the list of
   % clauses; [varal] is the A-List of variables; [radius] is the radius for
   % the local search; [fvl] is the list of free variables; [result] ist the 
   % current result. Returns the new result.
   begin scalar v,oldl,varl;
      varl := ibalp_qsat!-getlocvars!-last(fvl,radius);
      for each v in varl do <<
	 oldl := ibalp_var!-getval v . oldl;
	 ibalp_var!-unsetq(v,ibalp_var!-getval v);
      >>;
      result := ibalp_qsat!-localsearchrec(clausel,varal,varl,fvl,result);
      for i := 1:length varl do <<
	 v := nth(varl,i);
	 if eqn(nth(oldl,(length oldl) - i + 1),0) then
	    ibalp_var!-setq(v,0,-42,nil)
	 else
	    ibalp_var!-setq(v,1,-42,nil)
      >>;
      return result
   end;
	
procedure ibalp_qsat!-getlocvars!-last(fvl,number);
   % Get the [number] last free variables for local search.
   begin scalar l,varl;
      l := length fvl;
      for i := l-number+1:l do 
	    varl := nth(fvl,i) . varl;
      return varl
   end;
	
procedure ibalp_qsat!-getlocvars!-rand(fvl,number);
   % Get [number] random free variables for local search.
   begin scalar v,r,varl;
      while not eqn(length varl,number) do <<
	 r := random length fvl;
	 v := nth(fvl,r+1);
	 if (not memq(v,varl)) then
	    varl := v . varl
      >>;
      return varl
   end;

procedure ibalp_qsat!-localsearchrec(clausel,varal,selvars,fvl,result);
   % Recursive helper function of the local search.
   begin scalar tv,res,pair,ec,upl,pair2;
      tv := ibalp_getfree selvars;
      if null tv then <<
	 if ibalp_csat clausel and 
	    not member(ibalp_qsat!-calcbin fvl,donel!*) then <<
	    donel!* := ibalp_qsat!-calcbin fvl . donel!*; 
	    numlocs!* := numlocs!* + 1;
	    result := (ibalp_exres fvl) . result;
	 >>
      >> else <<
	 ec := ibalp_var!-setq(tv,1,-42,nil);
	 if null cdr ec then
	    result := ibalp_qsat!-localsearchrec(clausel,varal,selvars,
	       fvl,result);
	 ibalp_var!-unsetq(tv,1);
	 ec := ibalp_var!-setq(tv,0,-42,nil);
	 if null cdr ec then
	    result := ibalp_qsat!-localsearchrec(clausel,varal,selvars,
	       fvl,result);
	 ibalp_var!-unsetq(tv,0)
      >>;
      return result
   end;

procedure ibalp_qsat!-calcbin(fvl);
   % Calculate a binary representation of the current assignment to the free
   % variables in [fvl].
   if null fvl then 0 else 
      ibalp_var!-getval car fvl * 2^(length fvl -1) + 
      ibalp_qsat!-calcbin(cdr fvl);

procedure ibalp_printvars(fvl);
   % Helper function to print the list of variables.
   for each v in fvl do
      ioto_tprin2t {ibalp_var!-getid v, " ", ibalp_var!-getval v};

procedure ibalp_qsat!-getupl(clausel);
   % Get a initial set of unit clauses. [clausel] is the list of
   % clauses. Return a list of unit clauses.
   begin scalar upl,h;
      for each clause in clausel do
	 if (h := ibalp_qsat!-isunit clause) then
	    upl := (h . clause) . upl;
      return upl
   end;

procedure ibalp_exres2(resultl,fvl);
   % Expand the result. [resultl] is the list of results; [fvl] is the
   % list of free variables. Returns the complete result in lisp
   % prefix.
   begin scalar l,tl;
      l := length fvl;
      if eqn(length resultl,0) then return {'false};
      if eqn(length resultl,1) then return car resultl;
      if eqn(length resultl,2^l) then return {'true};
      for each res in resultl do <<
	 tl := res . tl
      >>;
      tl := 'or . tl;
      return tl
   end;

procedure ibalp_exres(vl);
   % Expand result. Expand a single result into Lisp Prefix. [vl] is a
   % list of variables. Return the expanded result.
   begin scalar tl,var,res;
      for each v in vl do <<
	 var := {'equal,ibalp_var!-getid v,ibalp_var!-getval v};
	 tl := var . tl;
      >>;
      if length tl > 1 then <<
	 for each v in tl do
	    res := v . res;
	 res := 'and . res
      >> else
	 res := car tl;
      return res
   end;

procedure ibalp_getfree(list);
   % Get an unassigned variable. [list] is the list of free
   % varibles. Returns a varialbe or [nil] if there is no unassigned.
   if null list then nil else
      if null ibalp_var!-getval car list then
	 car list
      else
	 ibalp_getfree cdr list;
	
procedure ibalp_getfree!-dlcs(list);
   % Get an unassigned variable. [list] is the list of free
   % varibles (following the DLCS strategy). Returns a varialbe 
   % or [nil] if there is no unassigned.
   begin scalar tv,max;
      tv := ibalp_getfree list;
      if null tv then return nil;
      max := ibalp_var!-getnumneg tv + ibalp_var!-getnumpos tv;
      for each var in list do
	 if null ibalp_var!-getval var then
	    if ibalp_var!-getnumneg var +
	 ibalp_var!-getnumpos var > max then <<
	    tv := var;
	    max := ibalp_var!-getnumneg var + ibalp_var!-getnumpos var
	 >>;
      return tv;
   end;

procedure ibalp_psatp(varal);
   % Returns whether a problem is PSAT.
   %if null varal then 
   %   t 
   %else 
   %   ibalp_var!-isex cdar varal and ibalp_psatp cdr varal;
   begin scalar ret;
      ret := t;
      for each v in varal do <<
	 if ibalp_var!-isuni cdr v then
	     ret := nil;
      >>;
      return ret;
   end;

procedure ibalp_splitvars(pqsat,varal);
   % Split variables. [pqsat] is the list of free variables; [varal]
   % is the A-List of variables. Deletes all the free variables from
   % the variable list and returns the two lists of bound and free
   % variables.
   begin scalar fvl,tv;
      for each v in pqsat do <<
	 tv := cdr atsoc(v,varal);
	 fvl := tv . fvl;
	 varal := delete((v . tv),varal)
      >>;
      return (varal . fvl)
   end;

procedure ibalp_qsat!-dav(varal);
   % Delete all assignments to variables. [varal] is the A-List of
   % variables; [clausel] is the list of clauses.
   for each v in varal do <<
      if ibalp_var!-getval cdr v then
	 ibalp_var!-unsetq(cdr v,ibalp_var!-getval cdr v);
      ibalp_var!-setflip(cdr v,nil)
   >>;

endmodule;  % ibalpqsat

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalp.red0000644000175000017500000007044011526203062024637 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: ibalp.red 295 2009-05-01 11:28:44Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2003-2009 A. Dolzmann, A. Seidl, and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(ibalp_rcsid!* ibalp_copyright!*);
   ibalp_rcsid!* := "$Id: ibalp.red 295 2009-05-01 11:28:44Z thomas-sturm $";
   ibalp_copyright!* :=
      "Copyright (c) 2003-2009 A. Dolzmann, A. Seidl, and T. Sturm"
>>;

module ibalp;
% Initial Boolean Algebra Lisp Prefix Form. Provides for
% Propositional Logic as well.

create!-package('(ibalp ibalpkapur ibalpqsat),nil);

load!-package 'redlog;  % for rl_texmacsp()
load!-package 'cl;
load!-package 'rltools;

imports rltools,cl;

fluid '(rl_cid!* !*rlverbose !*rlbnfsac !*rlpcprint !*rlsiso !*msg);

flag('(ibalp),'rl_package);

% Switches
switch rlpcprint;
switch rlpcprintall;

on1 'rlpcprintall;

% Parameters
put('ibalp,'rl_params,'(
   (rl_tordp!* . ibalp_ordp)
   (rl_a2cdl!* . ibalp_a2cdl)
   (rl_subsumption!* . ibalp_subsumption)
   (rl_bnfsimpl!* . cl_bnfsimpl)
   (rl_sacatlp!* . cl_sacatlp)
   (rl_sacat!* . ibalp_sacat)
   (rl_subat!* . ibalp_subat)
   (rl_subalchk!* . ibalp_subalchk)
   (rl_eqnrhskernels!* . ibalp_eqnrhskernels)
   (rl_smupdknowl!* . cl_smupdknowl)
   (rl_smrmknowl!* . cl_smrmknowl)
   (rl_smcpknowl!* . cl_smcpknowl)
   (rl_smmkatl!* . cl_smmkatl)
   (rl_smsimpl!-impl!* . cl_smsimpl!-impl)
   (rl_smsimpl!-equiv1!* . cl_smsimpl!-equiv1)
   (rl_elimset!* . ibalp_elimset)
   (rl_translat!* . ibalp_translat)
   (rl_varsel!* . ibalp_varsel)
   (rl_betterp!* . cl_betterp)
   (rl_transform!* . ibalp_transform)
   (rl_trygauss!* . ibalp_trygauss)
   (rl_specelim!* . ibalp_specelim)
   (rl_simplat1!* . ibalp_simplat1)
   (rl_ordatp!* . ibalp_ordatp)
   (rl_termmlat!* . ibalp_termmlat)
   (rl_op!* . ibalp_op) 
   (rl_varsubstat!* . ibalp_substat) 
   (rl_negateat!* . ibalp_negateat) 
   (rl_qemkans!* . ibalp_qemkans)
   (rl_varlat!* . ibalp_varlat)
   (rl_qstrycons!* . cl_qstrycons)
   (rl_qscsaat!* . ibalp_qscsaat)
   (rl_qssubat!* . ibalp_qssubat)
   (rl_qsconsens!* . cl_qs1consens)
   (rl_qsimpltestccl!* . cl_qsimpltestccl)
   (rl_qssubsumep!* . cl_qssusubymem)
   (rl_qstautp!* . cl_qstautp)
   (rl_qssimpl!* . cl_qssibysimpl)
));

% Services
put('ibalp,'rl_services,'(
   (rl_tab!* . cl_tab)
   (rl_atab!* . ibalp_atab)
   (rl_itab!* . ibalp_itab)
   (rl_cnf!* . ibalp_cnf)
   (rl_dnf!* . ibalp_dnf)
   (rl_subfof!* . cl_subfof)
   (rl_identifyonoff!* . cl_identifyonoff)
   (rl_ex!* . cl_ex)
   (rl_all!* . cl_all)
   (rl_simpl!* . cl_simpl)
   (rl_atnum!* . cl_atnum)
   (rl_qnum!* . cl_qnum)
   (rl_matrix!* . cl_matrix)
   (rl_atl!* . cl_atl)
   (rl_atml!* . cl_atml)
   (rl_pnf!* . cl_pnf)
   (rl_nnf!* . cl_nnf)
   (rl_nnfnot!* . cl_nnfnot) % not available in algebraic mode
   (rl_termml!* . cl_termml)
   (rl_terml!* . cl_terml)
   (rl_varl!* . cl_varl)
   (rl_fvarl!* . cl_fvarl)
   (rl_bvarl!* . cl_bvarl)
   (rl_quine!* . cl_quine) 
   (rl_qe!* . cl_qe)
   (rl_qea!* . cl_qea)
   (rl_qsat!* . ibalp_qsat)
   (rl_qsatoptions!* . ibalp_qsat!-setoptionl)
   (rl_qsatdimacs!* . ibalp_qsat!-dimacs)
   (rl_readdimacs!* . ibalp_qsat!-readdimacs)
   (rl_kapur!* . ibalp_kapur)));

% Switches
put('ibalp,'rl_cswitches,'(
   (rlsism . t)
   (lower . nil)
   (raise . nil)));

% Admin
put('ibalp,'simpfnname,'ibalp_simpfn);
put('ibalp,'simpdefault,'ibalp_simprel);

put('ibalp,'rl_prepat,'ibalp_prepat);
put('ibalp,'rl_resimpat,'ibalp_resimpat);
put('ibalp,'rl_lengthat,'ibalp_lengthat);

put('ibalp,'rl_prepterm,'ibalp_prepterm);
put('ibalp,'rl_simpterm,'ibalp_simpterm);

algebraic infix equal;
put('equal,'prifn,'ibalp_priequal);
put('equal,'fancy!-prifn,'ibalp_fancy!-priequal);
put('equal,'ibalp_simpfn,'ibalp_simpat);
put('equal,'fancy!-prifn,'ibalp_fancy!-priequal);
put('equal,'number!-of!-args,2);

procedure ibalp_priequal(f);
   % Print equal. [f] is of the form $([equal] s t)$. Returns in
   % identifier. Provided that switches [nat] and [rlpcprint] are on:
   % If $s$ is an identifier and the corresponding uppercase
   % identifier is $S$ is a PC variable, then print $S$. Else returns
   % ['failed] and leave printing to [maprin].
   begin scalar w,rhs;
      if not eqcar(rl_cid!*,'ibalp) or not !*nat or not !*rlpcprint then
      	 return 'failed;
      f := reval f;
      rhs := caddr f;
      if not eqn(rhs,1) and not eqn(rhs,0) then
	 return 'failed;
      w := cadr f;
      if not idp w then
	 return 'failed;
      w := ibalp_upcase w;
      if not ibalp_pcvarp w and not !*rlpcprintall then
	 return 'failed;
      if eqn(rhs,0) then
	 if !*utf8 then <<
	    maprin 'not;
	    maprin w
	 >> else
	    maprin {'not,w}
      else
	 maprin w
   end;

procedure ibalp_fancy!-priequal(c);
   begin scalar w;
      if not !*nat then
      	 return 'failed;
      w := ibalp_fancy!-priequal!-pc c;
      if w eq 'failed then <<
      	 maprin cadr c;
      	 fancy!-prin2 "=";
      	 maprin caddr c
      >>
   end;

procedure ibalp_fancy!-priequal!-pc(c);
   begin scalar w,rhs;
      if not !*rlpcprint then
	 return 'failed;
      if not member(caddr c,'(0 1))then
	 return 'failed;
      w := cadr c;
      if not idp w then
	 return 'failed;
      w := ibalp_upcase w;
      if not ibalp_pcvarp w then
	 return 'failed;
      if rl_texmacsp() then <<
      	 if caddr c eq 0 then fancy!-prin2 "\overline{";
      	 fancy!-prin2 w;
      	 if caddr c eq 0 then fancy!-prin2 "}"
      >> else <<
      	 if caddr c eq 0 then fancy!-special!-symbol(96,1);
      	 fancy!-prin2 w
      >>
   end;

algebraic infix neq;
put('neq,'ibalp_simpfn,'ibalp_simpat);
put('neq,'number!-of!-args,2);
put('neq,'rtypefn,'quotelog);
newtok '((!< !>) neq) where !*msg=nil;

algebraic operator bnot;
put('bnot,'number!-of!-args,1);
put('bnot,'prifn,'ibalp_pribnot);
put('bnot,'fancy!-prifn,'ibalp_fancy!-pribnot);
newtok '((!~) bnot) where !*msg=nil;;

procedure ibalp_pribnot(u);
   <<
      prin2!* " ";
      prin2!* get(car u,'prtch);
      prin2!* " ";
      if pairp cadr u and get(caadr u,'infix) then <<
	 prin2!* "(";
	 maprin cadr u;
	 prin2!* ")"
      >> else
      	 maprin cadr u
   >>;

procedure ibalp_fancy!-pribnot(u);
   if rl_texmacsp() then
      ibalp_fancy!-pribnot!-tm(u)
   else
      ibalp_fancy!-pribnot!-fm(u);
	 
procedure ibalp_fancy!-pribnot!-tm(u);
   <<
      fancy!-prin2 "(";
      fancy!-prin2 "\~{}"; % \char126
      maprin cadr u;
      fancy!-prin2 ")";
   >>;

procedure ibalp_fancy!-pribnot!-fm(u);
   <<
      fancy!-prin2 "~";
      if pairp cadr u and get(caadr u,'infix) then <<
	 fancy!-prin2 "(";
	 maprin cadr u;
	 fancy!-prin2 ")"
      >> else
      	 maprin cadr u
   >>;

algebraic infix bequiv;
put('bequiv,'number!-of!-args,2);
put('bequiv,'fancy!-prifn,'ibalp_fancy!-pribequiv);
newtok '((!< !- !>) bequiv) where !*msg=nil;
put('bequiv,'fancy!-infix!-symbol,"\leftrightarrow ");
precedence bequiv,neq;

symbolic procedure ibalp_fancy!-pribequiv(u);
   <<
      fancy!-prin2 "(";
      maprin cadr u;
      fancy!-prin2 "\leftrightarrow{}";
      maprin caddr u;
      fancy!-prin2 ")";
   >>;

algebraic infix bimpl;
put('bimpl,'number!-of!-args,2);
put('bimpl,'fancy!-prifn,'ibalp_fancy!-pribimpl);
newtok '((!- !>) bimpl) where !*msg=nil;
put('bimpl,'fancy!-infix!-symbol,"\rightarrow ");
precedence bimpl,bequiv;

symbolic procedure ibalp_fancy!-pribimpl(u);
   <<
      fancy!-prin2 "(";
      maprin cadr u;
      fancy!-prin2 "\rightarrow{}";
      maprin caddr u;
      fancy!-prin2 ")";
   >>;

algebraic infix brepl;
put('brepl,'number!-of!-args,2);
put('brepl,'fancy!-prifn,'ibalp_fancy!-pribrepl);
newtok '((!< !-) brepl) where !*msg=nil;
put('brepl,'fancy!-infix!-symbol,"\leftarrow");
precedence brepl,bimpl;

symbolic procedure ibalp_fancy!-pribrepl(u);
   <<
      fancy!-prin2 "(";
      maprin cadr u;
      fancy!-prin2 "\leftarrow{}";
      maprin caddr u;
      fancy!-prin2 ")";
   >>;

algebraic infix bor;
flag('(bor),'nary);
put('bor,'fancy!-prifn,'ibalp_fancy!-pribor);
newtok '((!|) bor) where !*msg=nil;
put('bor,'fancy!-infix!-symbol,"\|");
precedence bor,bimpl;

symbolic procedure ibalp_fancy!-pribor(u);
   begin scalar w;
      fancy!-prin2 "(";
      w := cdr u; % the arguments
      maprin car w;
      w := cdr w;
      while w do <<
	 fancy!-prin2 "|";
	 maprin car w;
	 w := cdr w;
      >>;
      fancy!-prin2 ")";
   end;

algebraic infix band;
flag('(band),'nary);
newtok '((!&) band) where !*msg=nil;
if rl_texmacsp() then
   put('band,'fancy!-infix!-symbol,"\&")
else
   put('band,'fancy!-infix!-symbol,38);
precedence band,bor;

flag('(band bor bimpl brepl bequiv equal neq),'spaced);

flag('(ibalp_simpat),'full);

flag('(ibalp_pcstat),'endstatfn);

procedure ibalp_pcstat();
   begin scalar x;
      x := cursym!*;
      scan();
      return {x}
   end;

procedure ibalp_pcform(form,an!-empty!-al,mode);
   if mode eq 'symbolic then
      mkquote intern car form  % we mean the identifier then
   else  % we know [mode eq 'algebraic]
      mkquote {'equal,ibalp_downcase car form,1};

put('rlpcvar,'stat,'rlis);
put('rlpcvar,'formfn,'ibalp_pcvarform);

procedure ibalp_pcvarform(vl,an!-empty!-al,mode);
   <<
      ibalp_pcvar for each v in cdr vl join <<
      	 if pairp v and ibalp_pcvarp car v then <<
	    lprim {"ignoring",car v,"- already declared pcvar"};
	    nil
      	 >> else if not ibalp_uppercasep v then <<
	    lprim{"ignoring",v,"- not an uppercase identifier"};
	    nil
      	 >> else
	    {v}
      >>;
      mkquote nil
   >>;

procedure ibalp_pcvar(vl);
   for each v in vl do <<
      put(v,'stat,'ibalp_pcstat);
      put(v,'formfn,'ibalp_pcform)
   >>;

procedure ibalp_uppercasep(id);
   id = ibalp_upcase id;

procedure ibalp_pcvarp(id);
   get(id,'stat) eq 'ibalp_pcstat;

procedure ibalp_upcase(id);
   intern compress for each c in explode id collect red!-char!-upcase c;

procedure ibalp_downcase(id);
   intern compress for each c in explode id collect red!-char!-downcase c;

ibalp_pcvar '(!A !B !C !D !E !F !G !H !I !J !K !L !M !N !O !P !Q !R !S !T
   !U !V !W !X !Y !Z);

procedure ibalp_subat(al,at);
   ibalp_mk2(ibalp_op at,
      ibalp_subt(al,ibalp_arg2l at),ibalp_subt(al,ibalp_arg2r at));

procedure ibalp_subt(al,u);
   begin scalar w;
      if idp u and (w := atsoc(u,al)) then
      	 return cdr w;
      if atom u then
      	 return u;
      return car u . for each arg in cdr u collect ibalp_subt(al,arg)
   end;

procedure ibalp_subalchk(al);
   ;

procedure ibalp_eqnrhskernels(x);
   ibalp_varlt cdr x;

procedure ibalp_simpterm(u);
   % Simplify term. [u] is Lisp Prefix. Returns the [u] as a IBALP
   % term.
   begin scalar op;
      if atom u then
      	 return ibalp_simpatom u;
      op := car u;
      if ibalp_boolfp op then
 	 return op . for each arg in cdr u collect ibalp_simpterm arg;
      u := reval u;
      if eqcar(u,op) then
	 typerr(op,"Boolean function");
      return ibalp_simpterm u  % terminates because reval is idempotent
   end;

procedure ibalp_simpatom(u);
   begin scalar w;
      if u = 0 or u = 1 then
	 return u;
      if idp u then <<
      	 if (w := rl_gettype u) then
	    return ibalp_simpterm reval u;
	 flag({u},'used!*);
	 return u
      >>;
      if null u then
	 typerr("nil","Boolean term");
      if numberp u then
 	 typerr({"number",u},"Boolean term");
      if stringp u then
 	 typerr({"string",u},"Boolean term")
   end;

procedure ibalp_prepterm(u);
   u;

procedure ibalp_boolfp(op);
   op memq '(bnot band bor bimpl brepl bequiv);

procedure ibalp_resimpterm(u);
   ibalp_simpterm u;

procedure ibalp_prepat(f);
   % Prep atomic formula. [f] is a IBALP atomic formula. Returns [f]
   % in Lisp prefix form.
   f;
   
procedure ibalp_resimpat(f);
   % Resimp atomic formula. [f] is an IBALP atomic formula. Returns the
   % atomic formula [f] with resimplified terms.
   ibalp_mk2(ibalp_op f,ibalp_resimpterm ibalp_arg2l f,
      ibalp_resimpterm ibalp_arg2r f);

procedure ibalp_lengthat(f);
   % Length of atomic formula. [f] is an
   % atomic formula. Returns a number, the length of [f].
   length ibalp_argn f;

procedure ibalp_simpat(u);
   % Simp atomic formula. [u] is Lisp prefix. Returns [u] as an atomic
   % formula.
   ibalp_mk2(car u,ibalp_simpterm cadr u,ibalp_simpterm caddr u);

procedure ibalp_op(atf);
   % Get operator. [atf] is an atomic formula $(R,t_1,t_2)$. Returns
   % $R$ which is $=$.
   car atf;

procedure ibalp_atfp(f);
   % Atomic formula predicate. [f] is a
   % formula. Returns t is and only if [f] is an atomic formula.
   ibalp_op f memq '(equal neq); 

procedure ibalp_arg1(atf);
   % Unary operator argument. [atf] is an atomic formula $R(t)$.
   % Returns $t$.
   cadr atf;

procedure ibalp_arg2l(atf);
   % Binary operator left hand side argument. [atf] is an atomic
   % formula $R(t_1,t_2)$. Returns $t_1$.
   cadr atf;

procedure ibalp_arg2r(atf);
   % Binary operator right hand side argument. [atf] is an atomic
   % formula $R(t_1,t_2)$. Returns $t_2$.
   caddr atf;

procedure ibalp_argn(atf);
   % n-ary operator argument list. [atf] is an atomic formula
   % $(R,t_1,...,t_n)$. Returns the list $(t_1,...,t_n)$.
   cdr atf;

procedure ibalp_mk2(op,lhs,rhs);
   % Make atomic formula for binary operator. [op] is one of the
   % operators [equal], [neq]; [lhs] and [rhs] are terms. Returns the
   % atomic formula $[op]([lhs],[rhs])$.
   {op,lhs,rhs};

procedure ibalp_1mk2(op,lhs);
   % Make zero right hand atomic formula for binary operator. [op] is
   % the operator [equal]. Returns the atomic formula $[op]([lhs],0)$.
   {op,lhs,1};

procedure ibalp_mkn(op,argl);
   % Make atomic formula for n-ary operator. [op] is one of the
   % operators [equal], [neq]; [argl] is a list $(t_1,t_2)$ of terms.
   % Returns the atomic formula $(op,t_1,t_2)$.
   op . argl;

%%% --- this part might become ibalpbnf.red --- %%%

procedure ibalp_dnf(f);
   % Disjunctive normal form. [f] is a formula. Returns a DNF of [f].
   if !*rlbnfsac then
      (cl_dnf f) where !*rlsiso=t
   else
      cl_dnf f;

procedure ibalp_cnf(f);
   % Conjunctive normal form. % [f] is a formula. Returns a CNF of
   % [f].
   if !*rlbnfsac then
      (cl_cnf f) where !*rlsiso=t
   else
      cl_cnf f;

procedure ibalp_subsumption(l1,l2,gor);
   % Discretely valued field standard form subsume. [l1] and [l2] are
   % lists of atomic formulas. Returns one of [keep1], [keep2], [nil].
   if gor eq 'or then (
      if ibalp_subsumep!-and(l1,l2) then
 	 'keep2
      else if ibalp_subsumep!-and(l2,l1) then
	 'keep1
   ) else  % [gor eq 'and]
      if ibalp_subsumep!-or(l1,l2) then
	 'keep1
      else if ibalp_subsumep!-or(l2,l1) then
	 'keep2
      else
	 nil;

procedure ibalp_subsumep!-and(l1,l2);
   % Subsume [and] case. [l1] and [l2] are lists of atomic formulas.
   begin scalar a;
      while l2 do <<
	 a := car l2;
	 l2 := cdr l2;
	 if cl_simpl(a,l1,-1) neq 'true then a := l2 := nil
      >>;
      return a
   end;

procedure ibalp_subsumep!-or(l1,l2);
   % Subsume [or] case. [l1] and [l2] are lists of atomic formulas.
   begin scalar a;
      while l1 do <<
	 a := car l1;
	 l1 := cdr l1;
	 if cl_simpl(rl_smkn('or,l2),{a},-1) neq 'true then a := l1 := nil
      >>;
      return a
   end;

procedure ibalp_sacat(a1,a2,gor);
   % Subsume and cut atomic formula. [a1] and [a2] are atomic
   % formulas; [gor] is one of [or], [and]. Returns [nil], ['keep],
   % ['keep2], ['keep1], ['drop], or an atomic formula. If [nil] is
   % returned then neither a cut nor a subsumption can be applied, if
   % [keep] is returned then the atomic formulas are identical, in the
   % case of [keep1] or [keep2] the respective atomic formula must be
   % kept but the other can be dropped. If an atomic formula $a$ is
   % returned then it is the result of the cut beween [a1] and [a2],
   % if ['drop] is returned, a cut with result ['true] or ['false] can
   % be performed.
   begin scalar rhs1,rhs2;
      if ibalp_arg2l a1 neq ibalp_arg2l a2 then
	 return nil;
      rhs1 := ibalp_arg2r a1;
      rhs2 := ibalp_arg2r a2;
      if rhs1 = rhs2 then
	 return 'keep;
      if rhs1 = 0 and rhs2 = 1 or rhs1 = 1 and rhs2 = 0 then
	 return 'drop;
      return nil
   end;

%%% --- this part might become ibalpmisc.red --- %%%

procedure ibalp_atab(f);
   cl_atab cl_simpl(f,nil,-1);

procedure ibalp_itab(f);
   cl_itab cl_simpl(f,nil,-1);

procedure ibalp_a2cdl(atml);
   % Atomic to case distinction list. [atml] is a list of atomic
   % formulas with multiplicity, the right hand side of which is
   % always zero. Returns a list, each containing a list of case
   % distinction w.r.t. the term $t$, i.e. ${t<0,t=0,t>0}$ resp.
   % ${t=0,t neq 0}$.
   for each pr in atml collect
      {ibalp_mk2('equal,w,0),ibalp_mk2('equal,w,1)} where w=ibalp_arg2l car pr;

procedure ibalp_substat(atf,new,old);
   % Substitute into atomic formula. [atf] is an atomic formula; [old]
   % is a variable; [new] is a term.
   ibalp_mk2(ibalp_op atf,ibalp_qesubt(ibalp_arg2l atf,old,new),
      ibalp_qesubt(ibalp_arg2r atf,old,new));

procedure ibalp_ordatp(a1,a2);
   % Ordered atomic formula predicate. [a1] and [a2] are atomic
   % formulas. Returns [t] iff [a1] is less than [a2].
   begin scalar u1,u2;
      u1 := ibalp_arg2l a1;
      u2 := ibalp_arg2l a2;
      if u1 neq u2 then return ibalp_ordp(u1,u2);
      u1 := ibalp_arg2r a1;
      u2 := ibalp_arg2r a2;
      if u1 neq u2 then return ibalp_ordp(u1,u2);
      return ibalp_ordrelp(ibalp_op a1,ibalp_op a2)
   end;

procedure ibalp_ordp(u1,u2);
   ordp(!*k2f u1,!*k2f u2);

procedure ibalp_ordrelp(r1,r2);
   not not (r2 memq (r1 memq '(equal neq)));

procedure ibalp_negateat(atf);
   % Negate atomic formula. [atf] is an atomic formula.
   % Returns an atomic formula equivalent to $\lnot [atf]$.
   ibalp_mk2(ibalp_op atf,ibalp_arg2l atf,ibalp_negatet ibalp_arg2r atf);

procedure ibalp_negatet(u);
   if u = 0 then 1 else if u = 1 then 0 else {'bnot,u};

procedure seidl_negateat(atf);
   % Negate atomic formula. [atf] is an atomic formula.
   % Returns an atomic formula equivalent to $\lnot [atf]$. The
   % relation is left unchanged, and ibalb_cveq relies on this.
   begin scalar lhs,rhs,rel,op;
      rhs := ibalp_arg2r atf;
      lhs := ibalp_arg2l atf;
      rel := ibalp_op atf;
      % flip 0 and 1, if possible
      if rhs member {0,1} then
	 return ibalp_mk2(rel,lhs,ibalp_flip01 rhs);
      if lhs member {0,1} then
      	 return ibalp_mk2(rel,ibalp_flip01 lhs,rhs);
      % drop a bnot, if possible
      op := ibalp_op rhs;
      if op equal 'bnot then
	 return ibalp_mk2(rel,lhs,ibalp_arg1 rhs);
      op := ibalp_op lhs;
      if op equal 'bnot then
	 return ibalp_mk2(rel,ibalp_arg1 lhs,rhs);
      % otherwise: negate left side
      return ibalp_mk2(rel,ibalp_mk1('bnot,rhs),rhs);
   end;

procedure ibalp_flip01(n);
   if n = 1 then 0 else if n = 0 then 1 else
      rederr{"ibalb_flip01: cannot flip",n};

procedure ibalp_cveq(a);
   % Convert to equation. [a] is an atom. Returns an atom.
   if ibalp_op a eq 'equal then
      a
   else
      ibalp_mk2('equal,ibalp_arg2l w,ibalp_arg2r w)
	 where w=ibalp_negateat(a);

procedure ibalp_termmlat(at);
   % Term multiplicity list of atomic formula. [at] is an atomic
   % formula. Returns the multiplicity list off all non-zero terms in
   % [at].
   begin scalar lhs,rhs;
      lhs := ibalp_arg2l at;
      rhs := ibalp_arg2r at;
      if lhs = 0 and rhs = 0 then return nil;
      if lhs = 0 then return {rhs . 1};
      if rhs = 0 then return {lhs . 1};
      if lhs = rhs then return {lhs . 2};
      return {lhs . 1,rhs . 1}
   end;
      
%(rl_varlat!* . ibalp_varlat))); %%% needs to be written in ibalpmisc.red

%%% --- this part might become ibalpsiat.red --- %%%

procedure ibalp_simplat1(f,sop);
   % Simplify atomic formula. [f] is an atomic formula; [sop] is the
   % boolean operator [f] occurs with or [nil]. Maybe later: accesses
   % switches [rlsiatadv], [rlsipd], [rlsiexpl], and [rlsiexpla].
   % Returns a quantifier-free formula that is a simplified equivalent
   % of [f].
   begin scalar lhs,rhs;
      if not (ibalp_op f memq '(equal neq)) then return nil; % why not error?
      % left-hand side domain element: switch sides for pcprint
      lhs := ibalp_arg2l f;
      rhs := ibalp_arg2r f;
      if numberp lhs then f := ibalp_mk2(ibalp_op f,rhs,lhs);
      f := ibalp_cveq f;
      % from now on, we have an equation
      lhs := ibalp_arg2l f;
      rhs := ibalp_arg2r f;
      % two numbers
      if numberp lhs and numberp rhs then
	 return if lhs eq rhs then 'true else 'false;
      % if we have a "propositional variable", we're done:
      if idp lhs and numberp rhs then return f;
      % from now on we have a complex term (longer than a "propositional
      % variable") to expand, and to simplify.
      lhs := ibalp_term2fo lhs;
      rhs := ibalp_term2fo rhs;
      return cl_simpl(cl_nnf rl_mk2('equiv,lhs,rhs),nil,-1)
   end;

procedure ibalp_term2fo(term);
   % Convert term to Formula. [term] is a lisp-prefix expression over
   % the language of initial boolean algebras. Returns a formula, with
   % atoms being only of the form [a=1].
   begin scalar rel;
      if numberp term then return if term = 0 then 'false else 'true;
      if idp term then return ibalp_mk2('equal,term,1);
      rel := ibalp_op(term);
      if rel eq 'bnot then return rl_mk1('not,ibalp_term2fo ibalp_arg1 term);
      if rel eq 'band then return
	 rl_mkn('and,for each a in ibalp_argn term collect
	    ibalp_term2fo a);      
      if rel eq 'bor then return
	 rl_mkn('or,for each a in ibalp_argn term collect
	    ibalp_term2fo a);      
      if rel eq 'bimpl then return rl_mk2('impl,ibalp_term2fo ibalp_arg2l term,
	 ibalp_term2fo ibalp_arg2r term);
      if rel eq 'brepl then return rl_mk2('repl,ibalp_term2fo ibalp_arg2l term,
	 ibalp_term2fo ibalp_arg2r term);
      if rel eq 'bequiv then return rl_mk2('equiv,
	 ibalp_term2fo ibalp_arg2l term, ibalp_term2fo ibalp_arg2r term);
      rederr {"ibalp_term2fo: unknown symbol:",rel}
   end;

procedure ibalp_varlat(a);
   % Variable list atomic formlua. [a] is an atomic formula. Returns a
   % list of identifiers. The set of variables ocurring in [a].
   union(ibalp_varlt ibalp_arg2l a,ibalp_varlt ibalp_arg2r a);

procedure ibalp_varlt(u);
   % Variable list term. [u] is an IBALP term. Returns a list of
   % identifiers. The set of variables ocurring in [u].
   ibalp_varlt1(u,nil);

procedure ibalp_varlt1(u,vl);
   % Variable list term. [u] is an IBALP term; [vl] is a list of
   % identifiers. Returns a list of identifiers. The set of variables
   % ocurring in [u] added to [vl].
   begin
      if u = 0 or u = 1 then
	 return nil;
      if idp u then
      	 return lto_insertq(u,vl);
      for each arg in ibalp_argn u do
      	 vl := ibalp_varlt1(arg,vl);
      return vl
   end;

procedure ibalp_transform(f,v);
   % Transform formula. [f] is a quantifier-free formula; [v] is a
   % variable. Returns $([f] . nil)$. This behavior informs [cl_qe]
   % that there no transformation possible.
   f . nil;

procedure ibalp_trygauss(f,v,theo,ans,bvl);
   % Try Gauss. [f] is a quantifier-free formula; [v] is a variable.
   % Returns [failed]. This behavior informs [cl_qe] that there no
   % Gauss elimination possible.
   'failed;

procedure ibalp_specelim(f,vl,theo,ans,bvl);
   % Special elimination. [f] is a quantifier-free formula; [vl] is a
   % list of variables; [theo] is a theory; [ans] is Bool; [bvl] is
   % the list of bound variables. Returns [failed]. This behavior
   % informs [cl_qe] that there no special elimination possible.
   'failed;

switch ibalpbadvarsel;

procedure ibalp_varsel(f,vl,theo);
   % Variable selection. [vl] is a list of variables; [f] is a
   % quantifier-free formula; [theo] is the current theory. Returns a
   % variable.
   begin scalar v; integer n;
      if !*ibalpbadvarsel then
	 return ibalp_badvarsel(f,vl);
      for each pr in cl_termml f do
	 if car pr memq vl and cdr pr > n then <<
	    v := car pr;
	    n := cdr pr
	 >>;
      return if v then {v} else {car sort(vl,'ibalp_ordp)}
   end;

procedure ibalp_badvarsel(f,vl);
   begin scalar v; integer n;
      for each pr in cl_termml f do
	 if car pr memq vl and cdr pr < n then <<
	    v := car pr;
	    n := cdr pr
	 >>;
      return if v then {v} else {car sort(vl,'ibalp_ordp)}
   end;
      
%
% procedure ibalp_varsel(f,vl,theo);
%    % Variable selection. [vl] is a list of variables; [f] is a
%    % quantifier-free formula; [theo] is the current theory. Returns a
%    % variable.
%    begin scalar v,found,gvp;
%       if not !*rlqevarsel then
% 	 return car vl;
%       while reverse vl and not found do <<
% 	 v := car vl;
% 	 vl := cdr vl;
% 	 gvp := not ibalp_goodvarp(f,v,{0,1});  % good var is bad var once more
% 	 if !*ibalpbadvarsel then
% 	    gvp := not gvp;
% 	 if gvp then  
% 	    found := t
%       >>;
%       return v
%    end;

% procedure ibalp_goodvarp(f,v,l);
%    begin scalar argl;
%       if rl_cxp rl_op f then <<
% 	 argl := rl_argn f;
% 	 while argl and l do <<
% 	    l := ibalp_goodvarp(car argl,v,l);
% 	    argl := cdr argl
% 	 >>;
% 	 return l
%       >>;
%       if ibalp_arg2l f eq v then
% 	 return deletip(ibalp_arg2r f,l);
%       return l
%    end;
	 
procedure ibalp_translat(atf,v,theo,pos,ans);
   % Translate atomic formula. [atf] is an atomic formula $\rho(t,0)$;
   % [v] is a variable; [theo] is the current theory; [pos], [ans] are
   % Bool. Returns an ALP.
   if ibalp_arg2l atf neq v then
      nil . nil
   else if pos then
      ibalp_mkalp('equal,{ibalp_arg2r atf})
   else if ibalp_arg2r atf = 1 then
      ibalp_mkalp('equal,{0})
   else
      ibalp_mkalp('equal,{1});

procedure ibalp_mkalp(tag,l);
   % Make alist pair. [tag] is a key; [l] is an entry. Returns an ALP.
   {tag . l} . {tag . 1};

%DS elimination_set
% A list $(...,(p . (l_1,...,l_n)),...)$ where the $p$ are procedures
% and the $l_i$ are parameter lists $(l_{i1},...,l_{im})$ such that
% there is $p(bvl,theo,f,v,l_{i1},...,l_{im})$ called for
% substitution, where $f$ is the considered formula, and $v$ the
% considered variable.

procedure ibalp_elimset(v,alp);
   % Elimination set. [v] is a variable; [alp] is a pair of alists.
   % Returns an elimination set.
   <<
      if !*rlverbose and not cdr cdaar alp then
      	 ioto_prin2 "S";
      {'ibalp_qesub . for each bconst in cdaar alp collect {bconst}}
   >>;

procedure ibalp_qesub(bvl,theo,f,v,bconst);
   theo . cl_apply2ats1(f,'ibalp_qesubat,{v,bconst});

procedure ibalp_qesubat(atf,v,bconst);
   ibalp_mk2(ibalp_op atf,
      ibalp_qesubt(ibalp_arg2l atf,v,bconst),ibalp_arg2r atf);

procedure ibalp_qesubt(u,v,bconst);
   if u eq v then
      bconst
   else if atom u then
      u
   else
      car u . for each arg in cdr u collect ibalp_qesubt(arg,v,bconst);

procedure ibalp_qemkans(an,atr);
   sort(for each x in an collect {'equal,car x,car caddr x},
      function(lambda(x,y); ordp(!*k2f cadr x,!*k2f cadr y)));

procedure ibalp_qscsaat(at);
   if not(idp ibalp_arg2l at and ibalp_arg2r at memq '(1 0)) then
      rederr {"ibalp_qscsaat: cannot process",at}
   else
      (ibalp_arg2l at . ibalp_arg2r at );

procedure ibalp_qssubat(pl,at);
   begin scalar w;
      if not(idp ibalp_arg2l at and ibalp_arg2r at memq '(1 0)) then
      	 rederr {"ibalp_qssubat: cannot process",at};
      w := assoc(ibalp_arg2l at,pl);
      if w then
	 return ibalp_mk2(ibalp_op at,cdr w,ibalp_arg2r at);
      return at
   end;

on raise;  % static case sensitivity was for compilation only

endmodule;  % [ibalp]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalpkapur.red0000644000175000017500000010623011526203062025677 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: ibalpkapur.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(ibalp_kapur_rcsid!* ibalp_kapur_copyright!*);
   ibalp_kapur_rcsid!* :=
      "$Id: ibalpkapur.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   ibalp_kapur_copyright!* := "Copyright (c) 2007-2009 A. Dolzmann and T. Sturm"
>>;

module ibalpkapur;
% Author Stefan Kaeser

% own switches and global vars
fluid '(ibalp_kapuroptions!* !*ibalp_kapurgb !*rlkapurchktaut !*rlkapurchkcont);
switch ibalp_kapurgb,rlkapurchktaut,rlkapurchkcont;

% debug switches
fluid '(!*ibalp_kapurgbdegd !*ibalp_kapurdisablegb);
switch ibalp_kapurgbdegd,ibalp_kapurdisablegb;

% import needed switches and global settings
fluid '(!*rlverbose !*modular vdpsortmode!*);

procedure ibalp_setkapuroption(opt,val);
   % Set Kapur option. [opt] is an identifier. [val] is any. Returns
   % any (old setting or nil).
   begin scalar oldopt,oldval;
     if oldopt := atsoc(opt,ibalp_kapuroptions!*) then <<
     	oldval := cdr oldopt;
     	cdr oldopt := val
     >>
     else
     	ibalp_kapuroptions!* := (opt . val) . ibalp_kapuroptions!*;
     return oldval
   end;

procedure ibalp_getkapuroption(opt);
   % Get Kapur option. [opt] is an identifier. Returns any.
   lto_catsoc(opt,ibalp_kapuroptions!*);

procedure ibalp_initkapuroptions();
   % Initialise Kapur options. Returns a list.
   <<
      ibalp_kapuroptions!* := {
         ('torder . vdpsortmode!*),
         ('polygenmode . 'kapur)}; % other are 'direct, 'knf, 'kapurknf
      if !*rlkapurchktaut and !*rlkapurchkcont then
         ibalp_setkapuroption('checkmode,'full)
      else if !*rlkapurchktaut then
         ibalp_setkapuroption('checkmode,'taut)
      else if !*rlkapurchkcont then
         ibalp_setkapuroption('checkmode,'cont)
      else
         ibalp_setkapuroption('checkmode,'sat)
   >>;

procedure ibalp_kapur(f,umode);
   % Kapur algebraic interface. [f] is a formula. [checkmode] is an
   % identifier. [umode] is an identifier. Returns a formula.
   begin scalar oldmod,oldswitch,newf;
      oldmod := setmod 2;
      oldswitch := !*modular;
      on1 'modular;
      ibalp_initkapuroptions();
      ibalp_setkapuroption('polygenmode,umode);
      if !*rlverbose then <<
         ioto_tprin2t "++++ Starting ibalp_kapur";
         ioto_prin2t {"Polynomial generation method: ",
            ibalp_getkapuroption 'polygenmode};
         ioto_tprin2t "-------------------------"
      >>;
      f := cl_simpl(f,nil,-1); % fast simplify once
      if ibalp_getkapuroption 'checkmode memq '(taut full) then <<
         if !*rlverbose then ioto_prin2t "---- Check for tautology";
         newf := ibalp_regformula(ibalp_kapur1(f,0),0,f)
      >>;
      if ibalp_getkapuroption 'checkmode memq '(cont full sat) and
            not rl_tvalp rl_op newf then <<
         if !*rlverbose then ioto_prin2t "---- Check for contradiction";
         newf := ibalp_regformula(ibalp_kapur1(f,1),1,f)
      >>;
      setmod oldmod;
      if null oldswitch then off1 'modular;
      return newf
   end;

procedure ibalp_regformula(pl,trthval,origf);
   % Regenerate formula. [pl] is a list of polynomials. [trthval] is 0
   % or 1. [origf] is a formula. Returns a formula.
   if eqn(trthval,0) then
      if 1 member pl then
         'true
      else
         origf
   else
      if 1 member pl then
         'false
      else if ibalp_getkapuroption 'checkmode eq 'sat then
         'true
      else
         origf;

procedure ibalp_kapur1(f,trthval);
   % Kapur subprocedure 1. [f] is a formula. [trthval] is 0 if check
   % for tautology or 1 if check for contradiction. Returns a Groebner
   % Basis of an equivalent set of polynomials.
   begin scalar polylist;
      if rl_qnum f > 0 then f := cl_qe(f,nil);
      if !*rlverbose then ioto_prin2t "--- Generate polynomials...";
      polylist := ibalp_polyset(f,trthval);
      polylist := nconc(polylist,ibalp_genidemppolylist polylist);
      if !*rlverbose then <<
         ioto_prin2t {"-- Generated ",length polylist," polynomials"};
         ioto_prin2t {"--- Compute Groebner Basis (",vdpsortmode!*,")..."}
      >>;
      polylist := ibalp_groebnereval polylist;
      if !*rlverbose then <<
         ioto_prin2t {"-- Generated ",length polylist," polynomials"}
      >>;
      return polylist
   end;

procedure ibalp_polyset(f,trthval);
   % Generate set of polynomials. [f] is a formula. [trthval] is 0 or
   % 1. Returns a list of polynomials equivalent to [f].
   if ibalp_getkapuroption 'polygenmode eq 'knf then
      ibalp_pset3knf(f,trthval)
   else if ibalp_getkapuroption 'polygenmode eq 'direct then
      ibalp_psetdirekt(f,trthval)
   else if ibalp_getkapuroption 'polygenmode memq '(kapur kapurknf) then
      ibalp_psetkapur(f,trthval)
   else
      ibalp_psetkapur(f,trthval);

procedure ibalp_formulaform(p);
   % Formula Form. [p] is a polynomial without exponents. Returns a
   % formula.
   if eqn(p,1) then
      'true
   else if eqn(p,0) then
      'false
   else if idp p then
      ibalp_1mk2('equal,p)
   else if eqcar(p,'times) then
      rl_smkn('and,for each x in cdr p collect ibalp_formulaform x)
   else if eqcar(p,'plus) then
      rl_mk1('not,rl_mk2('equiv,ibalp_formulaform cadr p,
         ibalp_formulaform kpoly_norm ('plus . cddr p)));

procedure ibalp_polyform(f);
   % Polynomial form. [f] is a quantifier-free formula. Returns a
   % polynomial.
   begin scalar a,b;
   if rl_tvalp rl_op f then
      return if rl_op f eq 'true then 1 else 0;
   if ibalp_atfp f then
      return ibalp_polyformatf f;
   if rl_op f eq 'not then
      return kpoly_plus {1,ibalp_polyform rl_arg1 f};
   if rl_junctp rl_op f then <<
      if rl_op f eq 'and then
         return kpoly_times ibalp_polyformlist rl_argn f;
      return kpoly_plus {1,kpoly_times for each j in
         ibalp_polyformlist rl_argn f collect kpoly_plus {1,j}}
   >>;
   a := ibalp_polyform rl_arg2l f;
   b := ibalp_polyform rl_arg2r f;
   if rl_op f eq 'impl then
      return kpoly_plus {1,kpoly_times {a,b},ibalp_clonestruct a};
   if rl_op f eq 'repl then
      return kpoly_plus {1,kpoly_times {a,b},ibalp_clonestruct b};
   if rl_op f eq 'equiv then
      return kpoly_plus {1,a,b};
   if rl_op f eq 'xor then
      return kpoly_plus {a,b}
   end;

procedure ibalp_polyformatf(f);
   % Polynomial form of an atomic formula. [f] is an atomic formula.
   % Returns a polynomial.
   if ibalp_op f eq 'equal then
      if eqn(ibalp_arg2r f,1) then
         ibalp_arg2l f
      else
         kpoly_plus {1,ibalp_arg2l f}
   else % ibalp_op eq 'neq
      if eqn(ibalp_arg2r f,0) then
         ibalp_arg2l f
      else
         kpoly_plus {1,ibalp_arg2l f};

procedure ibalp_remnested(pl,op);
   % Remove nested. [l] is a list. [op] is an identifier. Returns a
   % list where no sublist ist starting with [op] anymore by merging
   % into [pl] (applying the associative law).
   for each j in pl join
      if eqcar(j,op) then
         ibalp_remnested(cdr j,op)
      else
         {j};

procedure ibalp_polyformlist(l);
   % Polynomialform list. [l] is a list of formulae. Returns a list of
   % polynomials.
   for each x in l collect ibalp_polyform x;

procedure ibalp_groebnereval(pl);
   % Groebner Basis evaluation. [pl] is a list of polynomials. Returns
   % a list of polynomials which is a Groebner Basis of [pl].
   if null pl then
      {0}
   else if !*ibalp_kapurdisablegb then
      pl
   else if !*ibalp_kapurgbdegd then
      ibalp_gbdegd(pl,20)
   else if !*ibalp_kapurgb then
      ibalp_gb pl
   else
      cdr groebnereval {'list . pl};

procedure ibalp_torderp(a,b);
   % Termorder predicate. [a] and [b] are monomials. Returns boolean.
   if eqn(b,0) then
      t
   else if eqn(a,0) then
      nil
   else if eqn(b,1) then
      t
   else if eqn(a,1) then
      nil
   else if a = b then
      t
   else if ibalp_getkapuroption 'torder eq 'lex then
      ibalp_torderlexp(a,b)
   else if ibalp_getkapuroption 'torder eq 'gradlex then
      ibalp_tordergradlexp(a,b)
   else %use gradlex per default
      ibalp_tordergradlexp(a,b);

procedure ibalp_torderlexp(a,b);
   % Termorder Lexicographic. [a] and [b] are monomials different from
   % 0 or 1. Returns boolean.
   if atom a and atom b then
      ordop(a,b)
   else if atom a and pairp b then
      if a eq cadr b then nil else ordop(a,cadr b)
   else if pairp a and atom b then
      ordop(cadr a,b)
   else if pairp a and pairp b and cdr a and cdr b then
      if cadr a eq cadr b then
         if cddr a and cddr b then
            ibalp_torderp('times . cddr a,'times . cddr b)
         else if cddr a then
            t
         else if cddr b then
            nil
         else
            t
      else
         ordop(cadr a,cadr b)
   else
      if cdr a then t else nil;

procedure ibalp_tordergradlexp(a,b);
   % Termorder Gradlex. [a] and [b] are monomials different from 0 or
   % 1. Returns boolean.
   if atom a and atom b then
      ordop(a,b)
   else if atom a and pairp b then
      nil
   else if atom b and pairp a then
      t
   else if length a > length b then
      t
   else if length a < length b then
      nil
   else if pairp a and pairp b and cdr a and cdr b then
      if cadr a eq cadr b then
         if cddr a and cddr b then
            ibalp_tordergradlexp('times . cddr a,'times . cddr b)
         else if cddr a then
            t
         else if cddr b then
            nil
         else
            t
      else
         ordop(cadr a,cadr b);

procedure ibalp_gbdegd(pl,maxdeg);
   % Degree-d Groebner Basis. [pl] is a non-empty list of polynomials.
   % [maxdeg] is a positive integer. Returns a list of polynomials
   % which is a Degree-[maxdeg] Groebner Basis of [pl].
   begin scalar glist,glistend,slist,pol,newrule,srule;
      glist := {krule_poly2rule car pl};
      glistend := glist;
      slist := cdr pl;
      while slist do <<
         pol := car slist;
         slist := cdr slist;
         pol := ibalp_gbreducepoly(pol,glist);
         if not eqn(pol,0) then <<
            newrule := krule_poly2rule pol;
            % add new rule at the end of gb
            cdr glistend := (newrule . nil);
            glistend := cdr glistend;
            % check if new overlap should be added
            for each j in glist do <<
               srule := ibalp_gboverlaprules(j,newrule,nil);
               if (atom car srule and not(eqn(car srule,0) or eqn(car srule,1)))
                  or (listp car srule and length cdar srule < maxdeg + 1) then
                  slist := (krule_rule2poly srule) . slist
            >>
         >>
      >>;
      return for each j in glist collect krule_rule2poly j
   end;

procedure ibalp_gb(pl);
   % Groebner Basis. [pl] is a list of polynomials. Returns a list of
   % polynomials which is a Groebner Basis of [pl].
   begin scalar allrules,newrules,newrule,newrules2;
      if null pl then return '(0);
      if null cdr pl then return pl;
      allrules := ibalp_gbinitrules pl;
      newrules := cdr allrules;
      while newrules do <<
         if !*rlverbose then ioto_tprin2t {"- ",length newrules," new rules"};
         newrules2 := newrules;
         newrules := nil;
         for each j in newrules2 do for each k in allrules do <<
            newrule := ibalp_gboverlaprules(j,k,append(allrules,newrules));
            if newrule = '(1 . 0) then <<
               if !*rlverbose then ioto_tprin2t "-- 1 in GB generation";
               allrules := '((1 . 0));
               newrules := nil
            >> else if eqn(cdr newrule,1) and eqcar(car newrule,'times) then
               newrules := nconc(for each k in cdar newrule collect (k . 1),
                  newrules)
            else if newrule neq '(0 . 0) then <<
               if !*rlverbose then
                  ioto_tprin2t {car newrule," -> ",cdr newrule};
               newrules := newrule . newrules
            >>
         >>;
         if newrules then <<
            newrules := ibalp_gbsimplifyall newrules;
            allrules := ibalp_gbsimplifyall append(allrules,newrules)
         >>
      >>;
      return for each j in allrules collect krule_rule2poly j
   end;

procedure ibalp_gbsimplifyall(rules);
   % Groebner Basis simplify all rules. [rules] is a non-empty list of
   % rules. Returns a list of rules, where every rule is in normalform
   % in regard to all other rules in the list.
   begin scalar currule,beforr,afterr,newp; integer curlength,cntr;
      if !*rlverbose then ioto_tprin2t {"-- Simplifing ",length rules," Rules"};
      if null cdr rules then return rules;
      curlength := 1;
      cntr := 0;
      currule := rules;
      beforr := rules;
      afterr := cdr rules;
      while cdr beforr do <<
         curlength := add1 curlength;
         beforr := cdr beforr
      >>;
      while cntr < curlength do <<
         newp := ibalp_gbreducepoly(krule_rule2poly car currule,afterr);
        if eqn(newp,1) then <<
            currule := {krule_poly2rule 1};
            cntr := curlength + 25
         >> else if eqn(newp,0) then <<
            curlength := sub1 curlength;
            currule := afterr;
            afterr := cdr afterr
         >> else <<
            cdr beforr := (krule_poly2rule newp) . nil;
            cntr := if cadr beforr = car currule then add1 cntr else 0;
            beforr := cdr beforr;
            currule := afterr;
            afterr := cdr afterr
         >>
      >>;
      return currule
   end;

procedure ibalp_gboverlaprules(r1,r2,rlist);
   % Groebner Basis overlap rules. [r1] and [r2] are rules. [rlist] is
   % a list of rules. Returns a rule which is the result of [r1] and
   % [r2] beeing overlapped and the S-Polynomial is reduced using
   % [rlist].
   begin scalar spoly,head1,tail1,head2,tail2;
      if ibalp_gboverlapruleszcritp(r1,r2) then return krule_poly2rule 0;
      head1 := krule_head r1;
      head2 := krule_head r2;
      tail1 := krule_tail r1;
      tail2 := krule_tail r2;
      spoly :=
         if head1 = head2 then
            kpoly_plus {tail1,tail2}
         else if atom head1 and pairp head2 and head1 memq cdr head2 then
            kpoly_plus {tail2,kpoly_times {tail1,delete(head1,head2)}}
         else if atom head2 and pairp head1 and head2 memq cdr head1 then
            kpoly_plus {tail1,kpoly_times {tail2,delete(head2,head1)}}
         else <<
            spoly := kpoly_times union(cdr head1,cdr head2); % lcm
            kpoly_plus {ibalp_gbapplyrule(spoly,r1),ibalp_gbapplyrule(spoly,r2)}
         >>;
      return krule_poly2rule ibalp_gbreducepoly(spoly,rlist)
   end;

procedure ibalp_gboverlapruleszcritp(r1,r2);
   % Groebner Basis overlap rules zero criteria Predicate. [r1] and
   % [r2] are rules. Returns non-nil if the S-Polynomial of [r1] and
   % [r2] can be reduced to 0 easily.
   (r1 = r2) or
      (atom car r1 and atom car r2 and not(eqcar(r1,car r2))) or
      (eqn(cdr r1,0) and eqn(cdr r2,0)) or
      (atom car r1 and pairp car r2 and not(car r1 memq cdar r2)) or
      (atom car r2 and pairp car r1 and not(car r2 memq cdar r1)) or
      (pairp car r1 and pairp car r2 and null intersection(cdar r1,cdar r2));

procedure ibalp_gbreducepoly(p,rules);
   % Groebner Basis reduce polynomial. [p] is a polynomial. [rules] is
   % a list of rules. Returns a polynomial which is in normalform
   % according to the [rules].
   begin scalar chnge,p1,p2;
      chnge := t;
      p1 := p;
      p2 := p;
      while chnge do <<
         chnge := nil;
         for each j in rules do p1 := ibalp_gbapplyrule(p1,j);
         if p1 neq p2 then <<
            chnge := t;
            p2 := p1
         >>
      >>;
      return p1
   end;

procedure ibalp_gbapplyrule(p,rule);
   % Groebner Basis apply rule. [p] is a polynomial. [rule] is a rule.
   % Returns a polynomial.
   begin scalar w;
      if rule = krule_poly2rule 1 then return 0;
      if kpoly_monomialp p then return ibalp_gbapplyrulem(p,rule);
      w := cdr p;
      while w do
         if ibalp_torderp(car w,krule_head rule) then <<
            car w := ibalp_gbapplyrulem(car w,rule);
            w := cdr w
         >>
         else
            w := nil;
      return kpoly_plus cdr p
   end;

procedure ibalp_gbapplyrulem(m,rule);
   % Groebner Basis apply rule monomial. [m] is a monomial. [rule] is
   % a rule. Returns a polynomial.
   if rule = krule_poly2rule 1 then
      0
   else if atom m then
      if eqcar(rule,m) then krule_tail rule else m
   else if atom krule_head rule then
      if krule_head rule memq m then
         kpoly_times {delq(krule_head rule,m),krule_tail rule}
      else
         m
   else if kpoly_mondivp(m,krule_head rule) then <<
      for each j in cdr krule_head rule do m := delq(j,m);
      kpoly_times {m,krule_tail rule}
   >> else
      m;

procedure ibalp_gbinitrules(pl);
   % Groebner Basis init ruleslist. [pl] is a non-empty list of
   % polynomials. Returns a list of rules, generated by the
   % polynomials in [pl].
   begin scalar rules,newp;
      rules := {krule_poly2rule car pl};
      pl := cdr pl;
      while pl do <<
         newp := ibalp_gbreducepoly(car pl,rules);
         pl := cdr pl;
         if eqn(newp,1) then <<
            if !*rlverbose then ioto_tprin2t "-- 1 in Ideal Initialisation";
            rules := {krule_poly2rule 1};
            pl := nil
         >>
         else if not eqn(newp,0) then
            rules := (krule_poly2rule newp) . rules
      >>;
      rules := ibalp_gbsimplifyall rules;
      return rules
   end;

procedure ibalp_genpolyform(f,trthval);
   % Generate polynomial form. [f] is a quantifier free formula.
   % [trthval] is 0 or 1. Returns a polynomial without exponents.
   if eqn(trthval,1) then
      kpoly_plus {1,ibalp_polyform f}
   else
      ibalp_polyform f;

procedure ibalp_genidemppolylist(l);
   % Generate idempotential polynomial list. [l] is a list of
   % polynomials. Returns a list of polynomials containing the
   % idempotential polynomials for each variable in [l].
   begin scalar vl;
      for each j in l do
         if idp j then
            vl := lto_insert(j,vl)
         else if eqcar(j,'times) then
            for each k in cdr j do vl := lto_insert(k,vl)
         else if eqcar(j,'plus) then
            for each k in cdr j do
               if idp k then
                  vl := lto_insert(k,vl)
               else if eqcar(k,'times) then
                  for each m in cdr k do
                     vl := lto_insert(m,vl);
      return for each j in vl collect kpoly_idemppoly j;
   end;

% umode 3KNF

procedure ibalp_pset3knf(f,trthval);
   % Generate set of polynomials 3KNF. [f] is a formula. [trthval] is
   % 0 or 1. Returns a list of polynomials by transforming [f] into a
   % into a conjunctive clausal form, containing max 3 variables per
   % clause.
   begin scalar newf;
      newf := if eqn(trthval,1) then f else rl_mk1('not,f);
      newf := ibalp_pset3knfnf newf;
      newf := ibalp_pset3knf2(newf,nil);
      newf := if rl_op newf eq 'and then
            rl_mkn('and,for each j in rl_argn newf join
               ibalp_pset3knf3(j,nil))
         else
            rl_smkn('and,ibalp_pset3knf3(newf,nil));
      return
         if rl_op newf eq 'and then
            for each j in rl_argn newf collect ibalp_genpolyform(j,1)
	 else
	    {ibalp_genpolyform(newf,1)}
   end;

procedure ibalp_pset3knfnf(f);
   % Generate set of polynomials 3KNF negated form. [f] is a formula.
   % Returns a formula in negated form
   if rl_tvalp rl_op f or ibalp_atfp f then
      f
   else if rl_op f eq 'not then
      if ibalp_atfp rl_arg1 f then
         f
      else
         ibalp_pset3knfnf1 rl_arg1 f
   else if rl_junctp rl_op f then
      rl_mkn(rl_op f, for each j in rl_argn f collect
         ibalp_pset3knfnf j)
   else if rl_op f eq 'impl then
      rl_mk2('or,ibalp_pset3knf1 rl_mk1('not,rl_arg2l f),
         ibalp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'repl then
      rl_mk2('or,ibalp_pset3knfnf rl_mk1('not,rl_arg2r f),
         ibalp_pset3knfnf rl_arg2l f)
   else
      rl_mk2(rl_op f, ibalp_pset3knfnf rl_arg2l f,
         ibalp_pset3knfnf rl_arg2r f);

procedure ibalp_pset3knfnf1(f);
   % Generate set of polynomials 3KNF negated form subprocedure 1. [f]
   % is a formula, but not an atomic formula. Returns a formula in
   % negated form assuming the operator before [f] was a 'not.
   if rl_tvalp rl_op f then
      cl_flip rl_op f
   else if rl_op f eq 'not then
      ibalp_pset3knfnf rl_arg1 f
   else if rl_junctp rl_op f then
      rl_mkn(cl_flip rl_op f,
         for each j in rl_argn f collect ibalp_pset3knfnf rl_mk1('not,j))
   else if rl_op f eq 'impl then
      rl_mk2('and,ibalp_pset3knfnf rl_arg2l f,ibalp_pset3knfnf
         rl_mk1('not,rl_arg2r f))
   else if rl_op f eq 'repl then
      rl_mk2('and,ibalp_pset3knfnf rl_mk1('not,rl_arg2l f),
         ibalp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'equiv then
      rl_mk2('equiv,ibalp_pset3knfnf rl_mk1('not,rl_arg2l f),
         ibalp_pset3knfnf rl_arg2r f)
   else if rl_op f eq 'xor then
      rl_mk2('equiv,ibalp_pset3knfnf rl_arg2l f,ibalp_pset3knfnf rl_arg2r f);

procedure ibalp_pset3knf2(f,intree);
   % Generate set of polynomials 3KNF subprocedure 2. [f] is a formula
   % in negated form. [intree] is boolean. Returns a formula where
   % only the top-level operator 'and is n-ary.
   begin scalar partlists,g;
   if rl_tvalp rl_op f or rl_op f eq 'not or ibalp_atfp f then
      return f;
   if null intree and rl_op f eq 'and then
      return rl_smkn('and, for each j in rl_argn f join <<
         g := ibalp_pset3knf2(j,nil);
         if rl_op g eq 'and then rl_argn g else {g}
      >>);
   if rl_junctp rl_op f and lto_lengthp(rl_argn f,3,'geq) then <<
      if lto_lengthp(rl_argn f,4,'geq) then <<
         partlists := ibalp_splitlist rl_argn f;
         return rl_mk2(rl_op f,
            ibalp_pset3knf2(rl_mkn(rl_op f,car partlists),t),
               ibalp_pset3knf2(rl_mkn(rl_op f,cdr partlists),t))
      >>;
      return rl_mk2(rl_op f,ibalp_pset3knf2(car rl_argn f,t),
         rl_mk2(rl_op f,ibalp_pset3knf2(cadr rl_argn f,t),
            ibalp_pset3knf2(caddr rl_argn f, t)))
   >>;
   return rl_mk2(rl_op f,ibalp_pset3knf2(rl_arg2l f,t),
         ibalp_pset3knf2(rl_arg2r f,t));
   end;

procedure ibalp_pset3knf3(f,clausevar);
   % Generate set of polynomials 3KNF subprocedure 3. [f] is a formula
   % in binary tree negated form. [clausevar] is an identifier or nil.
   % Returns a list of formulae with max three vars in each clause.
   begin scalar nvarl,nvarr,returnlist;
      if rl_tvalp rl_op f then
         return {f};
      if rl_op f eq 'not or ibalp_atfp f then
         return {f};
      if null clausevar then <<
         clausevar := ibalp_1mk2('equal,gensym());
         returnlist := clausevar . returnlist
      >>;
      if rl_op rl_arg2l f eq 'not or ibalp_atfp rl_arg2l f then
         nvarl := rl_arg2l f
      else <<
         nvarl := ibalp_1mk2('equal,gensym());
         returnlist := nconc(returnlist,ibalp_pset3knf3(rl_arg2l f,nvarl))
      >>;
      if rl_op rl_arg2r f eq 'not or ibalp_atfp rl_arg2r f then
         nvarr := rl_arg2r f
      else <<
         nvarr := ibalp_1mk2('equal,gensym());
         returnlist := nconc(returnlist,ibalp_pset3knf3(rl_arg2r f,nvarr))
      >>;
      return rl_mk2('equiv,clausevar,rl_mk2(rl_op f,nvarl,nvarr)) . returnlist;
   end;

% umode Kapur

procedure ibalp_psetkapur(f,trthval);
   % Generate set of polynomials Kapur. [f] is a formula. [trthval] is
   % 0 or 1. Returns a list of polynomials by transforming [f] using
   % Kapur and Narendrans optimized Method. [trthval] is the trthvalue
   % which should be achieved.
   if rl_op f eq 'not then
      ibalp_psetkapur(rl_arg1 f,ibalp_flip01 trthval)
   else if eqn(trthval,1) then
      ibalp_psetkapurcont f
   else
      ibalp_psetkapurtaut f;

procedure ibalp_psetkapurtaut(f);
   % Generate set of polynomials Kapur tautology. [f] is a formula.
   % Returns a list of polynomials.
   if rl_op f eq 'impl then
      nconc(ibalp_psetkapur(rl_arg2l f,1),ibalp_psetkapur(rl_arg2r f,0))
   else if rl_op f eq 'repl then
      nconc(ibalp_psetkapur(rl_arg2l f,0),ibalp_psetkapur(rl_arg2r f,1))
   else if rl_op f eq 'or then
      for each j in rl_argn f join ibalp_psetkapur(j,0)
   else if rl_op f eq 'and then
      ibalp_psetkapurnary(f,0)
   else
      ibalp_psetkapurnoopt(f,0);

procedure ibalp_psetkapurcont(f);
   % Generate set of polynomials Kapur contradiction. [f] is a formula.
   % Returns a list of polynomials.
   if rl_op f eq 'and then
      for each j in rl_argn f join ibalp_psetkapur(j,1)
   else if rl_op f eq 'impl and rl_op rl_arg2r f eq 'and then
      ibalp_psetkapurdistleft(f,1)
   else if rl_op f eq 'repl and rl_op rl_arg2l f eq 'and then
      ibalp_psetkapurdistright(f,1)
   else if rl_op f eq 'or then
      ibalp_psetkapurnary(f,1)
   else
      ibalp_psetkapurnoopt(f,1);

procedure ibalp_psetkapurnary(f,trthval);
   % Generate set of polynomials Kapur n-Ary subprocedure 1. [f] is a
   % formula with an n-ary toplevel operator. [trthval] is 0 or 1.
   % Returns a list of polynomials by spliting a n-ary boolean
   % formulae into two equivalent polynomials adding auxiliary vars.
   begin scalar distop;
      distop := cl_flip rl_op f;
      if lto_lengthp(rl_argn f,4,'geq) then
         return ibalp_psetkapurnary1(f,trthval);
      if lto_lengthp(rl_argn f,2,'eqn) then
         return
            if rl_op rl_arg2r f eq distop then
              ibalp_psetkapurdistleft(f,trthval)
            else if rl_op rl_arg2l f eq distop then
               ibalp_psetkapurdistright(f,trthval)
            else
               ibalp_psetkapurnoopt(f,trthval);
      return ibalp_psetkapurnoopt(f,trthval)
   end;

procedure ibalp_psetkapurnary1(f,trthval);
   % Generate set of polynomials Kapur n-Ary subprocedure 1. [f] is a
   % formula with an n-ary toplevel operator. [trthval] is 0 or 1.
   % Returns a list of polynomials by spliting a n-ary boolean
   % formulae into two equivalent polynomials adding auxiliary vars.
   begin scalar partlists,newvar,l1,l2;
      partlists := ibalp_splitlist rl_argn f;
      l1 := car partlists;
      l2 := cdr partlists;
      newvar := gensym();
      l1 := rl_mkn(rl_op f,ibalp_1mk2('equal,newvar) . l1);
      l2 := rl_mkn(rl_op f,rl_mk1('not,ibalp_1mk2('equal,newvar)) . l2);
      return nconc(ibalp_psetkapur(l1,trthval),ibalp_psetkapur(l2,trthval))
   end;

procedure ibalp_psetkapurnoopt(f,trthval);
   % Generate set of polynomials Kapur without possible optimizations.
   % [f] is a formula. [trthval] is 0 or 1. Returns a list of
   % polynomials.
   begin scalar p;
      if ibalp_getkapuroption 'polygenmode eq 'kapurknf then
         return ibalp_pset3knf(f,trthval);
      p := ibalp_genpolyform(f,trthval);
      return if not eqn(p,0) then {p}
   end;

procedure ibalp_psetkapurdistleft(f,trthval);
   % Generate set of polynomials Kapur left distributivity. [f] is a
   % formula. [trthval] is 0 or 1. Returns a list of polynomials by
   % applying the distributivity rule first.
   for each j in rl_argn rl_arg2r f join
      ibalp_psetkapur(rl_mk2(rl_op f,rl_arg2l f,j),trthval);

procedure ibalp_psetkapurdistright(f,trthval);
   % Generate set of polynomials Kapur right distributivity. [f] is a
   % formula. [trthval] is 0 or 1. Returns a list of polynomials by
   % applying the distributivity rule first.
   for each j in rl_argn rl_arg2l f join
      ibalp_psetkapur(rl_mk2(rl_op f,rl_arg2r f,j),trthval);

procedure ibalp_psetdirekt(f, trthval);
   % Generate set of polynomials directly. [f] is a formula. [trthval]
   % is 0 or 1. Returns a list of polynomials.
   {ibalp_genpolyform(f,trthval)};

procedure ibalp_splitlist(l);
   % Split list. [l] is a list. Returns a pair of lists. Devides a
   % list into two lists of equal length containing all elements of
   % [l].
   begin scalar elm,l2; integer lgt,cnt;
      if null l then
         return (nil . nil);
      if null cdr l then
         return (l . nil);
      lgt := length l;
      cnt := 1;
      elm := l;
      while cnt < lgt / 2 do <<
         cnt := add1 cnt;
         elm := cdr elm
      >>;
      l2 := cdr elm;
      cdr elm := nil;
      return (l . l2);
   end;

procedure ibalp_clonestruct(s);
   % Clone structure. [s] is any. Returns any, which is a clone of [s]
   % in a constructive way.
   if atom s then s else (ibalp_clonestruct car s) . (ibalp_clonestruct cdr s);

endmodule; %ibalpkapur

module krule;
% Kapur Rewriterules

% DS
%  ::= ( . )

procedure krule_head(r);
   % Headmonomial. [r] is a rule. Returns the head of the rule.
   car r;

procedure krule_tail(r);
   % Tailpolynomial. [r] is a rule. Returns the tail of the rule.
   cdr r;

procedure krule_genrule(h,tt);
   % Generate rule. [h] is a monomial, [t] is a polynomial. Returns a
   % rule with [h] as head and [t] as tail.
   (h . tt);

procedure krule_rule2poly(r);
   % Convert rule into a polynomial. [r] is a rule. Returns a
   % polynomial.
   kpoly_plus {krule_head r,krule_tail r};

procedure krule_poly2rule(p);
   % Convert a polynomial into a rule. [p] is a polynomial. Returns a
   % rule or 'failed if no unique head monomial can be choosen.
   begin scalar monlist;
      if kpoly_monomialp p then return (p . 0);
      monlist := sort(cdr p,'ibalp_torderp);
      return krule_genrule(car monlist,kpoly_plus cdr monlist)
   end;

endmodule; %[krule]


module kpoly;
% Kapur Polynomials

% DS
%  ::=  | ('plus,...,,...)
%  ::= 0 | 1 |  | ('times,...,,...)

procedure kpoly_times(l);
   % Polynomial times. [l] is a non-empty list of polynomials. Returns
   % the product of the polynomials in [l].
   begin scalar setlvar,setlsum,curpoly;
      l := ibalp_remnested(l,'times);
      if 0 member l then return 0;
      for each j in l do
         if atom j and not eqn(j,1) then
            setlvar := lto_insert(j,setlvar)
         else if eqcar(j,'plus) then
            setlsum := lto_insert(j,setlsum);
      setlvar := sort(setlvar,'ordop);
      if null setlsum then
         return kpoly_norm ('times . setlvar);
      if null setlvar and null cdr setlsum then
         return car setlsum;
      if setlvar then
         curpoly := kpoly_norm ('times . setlvar)
      else <<
         curpoly := car setlsum;
         setlsum := cdr setlsum
      >>;
      while setlsum do <<
         curpoly := kpoly_times2(curpoly,car setlsum);
         setlsum := if not eqn(curpoly,0) then cdr setlsum
      >>;
      return curpoly
   end;

procedure kpoly_times2(p1,p2);
   % Polynomial times 2. [p1] and [p2] are polynomials. Returns a
   % polynomial which is the product of [p1] and [p2].
   if kpoly_monomialp p1 and kpoly_monomialp p2 then
      kpoly_times2monoms(p1,p2)
   else if kpoly_monomialp p1 then
      kpoly_times2monomsum(p1,p2)
   else if kpoly_monomialp p2 then
      kpoly_times2monomsum(p2,p1)
   else
      kpoly_times2sums(p1,p2);

procedure kpoly_times2sums(s1,s2);
   % Polynomial times 2 sums. [s1] and [s2] are lists starting with
   % 'plus. Returns a polynomial being the multiplication of [s1] and
   % [s2].
   kpoly_plus for each j in cdr s1 collect
      kpoly_times2monomsum(j,s2);

procedure kpoly_times2monomsum(m,s);
   % Polynomial times2 monomial and sum. [m] is a monomial. [s] is a
   % list starting with 'plus. Returns a polynomial which is the
   % product of [m] and [s].
   if kpoly_monomialp s then
      kpoly_times2monoms(m,s)
   else
      kpoly_plus for each j in cdr s collect
         kpoly_times2monoms(m,j);

procedure kpoly_times2monoms(m1,m2);
   % Polynomial times 2 monomials. [m1] and [m2] are monomials.
   % Returns a monomial containing all identifiers of [s1] and [s2].
   % The result list is sorted lexicographically.
   begin scalar setl;
      if atom m1 then
         if eqn(m1,1) then
            return m2
         else
            setl := lto_insert(m1,setl)
      else
      	 for each j in cdr m1 do setl := lto_insert(j,setl);
      if atom m2 then
         if eqn(m2,1) then
            return m1
         else
            setl := lto_insert(m2,setl)
      else
      	 for each j in cdr m2 do setl := lto_insert(j,setl);
      return kpoly_norm ('times . sort(setl,'ordop))
   end;

procedure kpoly_plus(l);
   % Polynomial plus. [l] is a non-empty list of polynomials. Returns
   % a polynomial equated the addition of the polynomials in [l]. The
   % result is sorted using current torder.
   begin scalar tmpl,w;
      tmpl := sort(ibalp_remnested(l,'plus),'ibalp_torderp);
      w := tmpl;
      % remove multiple occurences
      while w and cdr w do
         if eqn(car w,0) then <<
            car w := cadr w;
            cdr w := cddr w
         >> else if car w = cadr w then
           if cddr w then <<
               car w := caddr w;
               cdr w := cdddr w
            >> else <<
               car w := 0;
               cdr w := nil
            >>
         else
            w := cdr w;
      tmpl := delete(0,tmpl);
      return kpoly_norm ('plus . tmpl)
    end;

procedure kpoly_monomialp(p);
   % Monomial predicate. [p] is a polynomial. Returns non-nil if [p]
   % is an atom or a list starting with 'times.
   atom p or eqcar(p,'times);

procedure kpoly_idemppoly(var);
   % Idempotential polynomial. [var] is an identifier. Returns the
   % polynomial var^2 + var.
   {'plus,{'times,var,var},var};

procedure kpoly_norm(p);
   % Normalise. [p] is a polynomial. Returns a polynomial which
   % is in a normalized form (no list if atom).
   if atom p then
      p
   else if null cdr p then
      if eqcar(p,'times) then 1 else 0
   else if null cddr p then
      cadr p
   else
      p;

procedure kpoly_mondivp(m1,m2);
   % Monomial divide predicate. Returns non-nil if [m2] divides [m1].
   begin scalar e1,e2,rsl;
      if eqn(m1,0) or eqn(m2,1) or m1 = m2 then return t;
      if eqn(m2,0) then return nil;
      if atom m1 and atom m2 then return m1 = m2;
      if atom m1 then return nil;
      if atom m2 then return m2 member m1;
      e1 := cdr m1;
      e2 := cdr m2;
      rsl := t;
      while e1 and e2 and rsl do
         if car e1 = car e2 then <<
            e1 := cdr e1;
            e2 := cdr e2
         >>
         else if ordop(car e1,car e2) then
            e1 := cdr e1
         else
            rsl := nil;
      return null e2 and rsl
   end;

endmodule; %kpoly

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalp.tst0000644000175000017500000105016711526203062024704 0ustar  giovannigiovanniload_package redlog;
rlset ibalp;

% Formula ii8c1.cnf of the Dimacs II benchmark set
% http://www.cs.ubc.ca/~hoos/SATLIB/benchm.html
ii8c1 :=
(var1 = 1 or var2 = 1) and (var3 = 1 or var4 = 1) and (var5 = 1 or var6 = 1) and
 (var7 = 1 or var8 = 1) and (var9 = 1 or var10 = 1) and (var11 = 1 or var12 = 1)
 and (var13 = 1 or var14 = 1) and (var15 = 1 or var16 = 1) and (var17 = 1 or
var18 = 1) and (var19 = 1 or var20 = 1) and (var21 = 1 or var22 = 1) and (var23
= 1 or var24 = 1) and (var25 = 1 or var26 = 1) and (var27 = 1 or var28 = 1) and
(var29 = 1 or var30 = 1) and (var31 = 1 or var32 = 1) and (var33 = 1 or var34 =
1) and (var35 = 1 or var36 = 1) and (var37 = 1 or var38 = 1) and (var39 = 1 or
var40 = 1) and (var41 = 1 or var42 = 1) and (var43 = 1 or var44 = 1) and (var45
= 1 or var46 = 1) and (var47 = 1 or var48 = 1) and (var49 = 1 or var50 = 1) and
(var51 = 1 or var52 = 1) and (var53 = 1 or var54 = 1) and (var55 = 1 or var56 =
1) and (var57 = 1 or var58 = 1) and (var59 = 1 or var60 = 1) and (var61 = 1 or
var62 = 1) and (var63 = 1 or var64 = 1) and (var65 = 1 or var66 = 1) and (var67
= 1 or var68 = 1) and (var69 = 1 or var70 = 1) and (var71 = 1 or var72 = 1) and
(var73 = 1 or var74 = 1) and (var75 = 1 or var76 = 1) and (var77 = 1 or var78 =
1) and (var79 = 1 or var80 = 1) and (var81 = 1 or var82 = 1) and (var83 = 1 or
var84 = 1) and (var85 = 1 or var86 = 1) and (var87 = 1 or var88 = 1) and (var89
= 1 or var90 = 1) and (var91 = 1 or var92 = 1) and (var93 = 1 or var94 = 1) and
(var95 = 1 or var96 = 1) and (var97 = 1 or var98 = 1) and (var99 = 1 or var100 =
 1) and (var101 = 1 or var102 = 1) and (var103 = 1 or var104 = 1) and (var105 =
1 or var106 = 1) and (var107 = 1 or var108 = 1) and (var109 = 1 or var110 = 1)
and (var111 = 1 or var112 = 1) and (var113 = 1 or var114 = 1) and (var115 = 1 or
 var116 = 1) and (var117 = 1 or var118 = 1) and (var119 = 1 or var120 = 1) and (
var121 = 1 or var122 = 1) and (var123 = 1 or var124 = 1) and (var125 = 1 or
var126 = 1) and (var127 = 1 or var128 = 1) and (var129 = 1 or var130 = 1) and (
var131 = 1 or var132 = 1) and (var133 = 1 or var134 = 1) and (var135 = 1 or
var136 = 1) and (var137 = 1 or var138 = 1) and (var139 = 1 or var140 = 1) and (
var141 = 1 or var142 = 1) and (var143 = 1 or var144 = 1) and (var145 = 1 or
var146 = 1) and (var147 = 1 or var148 = 1) and (var149 = 1 or var150 = 1) and (
var151 = 1 or var152 = 1) and (var153 = 1 or var154 = 1) and (var155 = 1 or
var156 = 1) and (var157 = 1 or var158 = 1) and (var159 = 1 or var160 = 1) and (
not(var1 = 1) or not(var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1
) or not(var12 = 1) or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or
not(var20 = 1) or not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(
var28 = 1) or not(var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36
 = 1) or not(var37 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or
 not(var45 = 1) or not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(
var53 = 1) or not(var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 =
1) or not(var64 = 1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or
 not(var72 = 1) or not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(
var80 = 1)) and (not(var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88
 = 1) or not(var89 = 1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1))
and (not(var97 = 1) or not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or
not(var105 = 1) or not(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (
not(var113 = 1) or not(var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(
var121 = 1) or not(var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(
var129 = 1) or not(var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(
var137 = 1) or not(var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(
var145 = 1) or not(var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(
var153 = 1) or not(var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(
var2 = 1) or not(var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or
 not(var12 = 1) or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(
var19 = 1) or not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 =
1) or not(var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or
 not(var38 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(
var45 = 1) or not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54
 = 1) or not(var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or
 not(var64 = 1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(
var71 = 1) or not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 =
1)) and (not(var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or
 not(var89 = 1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(
var98 = 1) or not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105
 = 1) or not(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114
= 1) or not(var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1)
 or not(var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1)
or not(var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or
not(var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or
not(var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var103 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var70 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var86 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var67 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var83 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var5 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var21 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var37
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var69 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var85 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var101 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var117 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var133 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var149 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var15 = 1)) and (not(var18 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var31 = 1)) and (not(var34 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var47 = 1)) and (not(var50 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var63 =
1)) and (not(var66 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var79 = 1)) and (not(
var82 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var95 = 1)) and (not(var98 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var111 = 1)) and (not(var114 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var127 = 1)) and (not(var130 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var143 = 1)) and (not(var146 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var159 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var1 = 1) or not(
var4 = 1) or not(var5 = 1) or not(var8 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var17 = 1) or not(var20 = 1) or
not(var21 = 1) or not(var24 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var33 = 1) or not(var36 = 1) or not(var37
 = 1) or not(var40 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var49 = 1) or not(var52 = 1) or not(var53 = 1) or not(
var56 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var65 = 1) or not(var68 = 1) or not(var69 = 1) or not(var72 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var81 = 1) or not(var84 = 1) or not(var85 = 1) or not(var88 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var97 = 1) or
 not(var100 = 1) or not(var101 = 1) or not(var104 = 1) or not(var105 = 1) or not
(var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var113 = 1) or not(
var116 = 1) or not(var117 = 1) or not(var120 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var129 = 1) or not(
var132 = 1) or not(var133 = 1) or not(var136 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var145 = 1) or not(
var148 = 1) or not(var149 = 1) or not(var152 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var12 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var28 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var44 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var60 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var76 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var92 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var108 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var124 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var140 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var156 = 1) or not(var157 = 1) or not(var160 = 1)) and (not(var2 = 1) or not(
var3 = 1) or not(var6 = 1) or not(var7 = 1) or not(var9 = 1) or not(var11 = 1)
or not(var13 = 1) or not(var16 = 1)) and (not(var18 = 1) or not(var19 = 1) or
not(var22 = 1) or not(var23 = 1) or not(var25 = 1) or not(var27 = 1) or not(
var29 = 1) or not(var32 = 1)) and (not(var34 = 1) or not(var35 = 1) or not(var38
 = 1) or not(var39 = 1) or not(var41 = 1) or not(var43 = 1) or not(var45 = 1) or
 not(var48 = 1)) and (not(var50 = 1) or not(var51 = 1) or not(var54 = 1) or not(
var55 = 1) or not(var57 = 1) or not(var59 = 1) or not(var61 = 1) or not(var64 =
1)) and (not(var66 = 1) or not(var67 = 1) or not(var70 = 1) or not(var71 = 1) or
 not(var73 = 1) or not(var75 = 1) or not(var77 = 1) or not(var80 = 1)) and (not(
var82 = 1) or not(var83 = 1) or not(var86 = 1) or not(var87 = 1) or not(var89 =
1) or not(var91 = 1) or not(var93 = 1) or not(var96 = 1)) and (not(var98 = 1) or
 not(var99 = 1) or not(var102 = 1) or not(var103 = 1) or not(var105 = 1) or not(
var107 = 1) or not(var109 = 1) or not(var112 = 1)) and (not(var114 = 1) or not(
var115 = 1) or not(var118 = 1) or not(var119 = 1) or not(var121 = 1) or not(
var123 = 1) or not(var125 = 1) or not(var128 = 1)) and (not(var130 = 1) or not(
var131 = 1) or not(var134 = 1) or not(var135 = 1) or not(var137 = 1) or not(
var139 = 1) or not(var141 = 1) or not(var144 = 1)) and (not(var146 = 1) or not(
var147 = 1) or not(var150 = 1) or not(var151 = 1) or not(var153 = 1) or not(
var155 = 1) or not(var157 = 1) or not(var160 = 1)) and (var1 = 1 or not(var161 =
 1)) and (var4 = 1 or not(var161 = 1)) and (var6 = 1 or not(var161 = 1)) and (
var8 = 1 or not(var161 = 1)) and (var10 = 1 or not(var161 = 1)) and (var12 = 1
or not(var161 = 1)) and (var13 = 1 or not(var161 = 1)) and (var16 = 1 or not(
var161 = 1)) and (var17 = 1 or not(var162 = 1)) and (var20 = 1 or not(var162 = 1
)) and (var22 = 1 or not(var162 = 1)) and (var24 = 1 or not(var162 = 1)) and (
var26 = 1 or not(var162 = 1)) and (var28 = 1 or not(var162 = 1)) and (var29 = 1
or not(var162 = 1)) and (var32 = 1 or not(var162 = 1)) and (var33 = 1 or not(
var163 = 1)) and (var36 = 1 or not(var163 = 1)) and (var38 = 1 or not(var163 = 1
)) and (var40 = 1 or not(var163 = 1)) and (var42 = 1 or not(var163 = 1)) and (
var44 = 1 or not(var163 = 1)) and (var45 = 1 or not(var163 = 1)) and (var48 = 1
or not(var163 = 1)) and (var49 = 1 or not(var164 = 1)) and (var52 = 1 or not(
var164 = 1)) and (var54 = 1 or not(var164 = 1)) and (var56 = 1 or not(var164 = 1
)) and (var58 = 1 or not(var164 = 1)) and (var60 = 1 or not(var164 = 1)) and (
var61 = 1 or not(var164 = 1)) and (var64 = 1 or not(var164 = 1)) and (var65 = 1
or not(var165 = 1)) and (var68 = 1 or not(var165 = 1)) and (var70 = 1 or not(
var165 = 1)) and (var72 = 1 or not(var165 = 1)) and (var74 = 1 or not(var165 = 1
)) and (var76 = 1 or not(var165 = 1)) and (var77 = 1 or not(var165 = 1)) and (
var80 = 1 or not(var165 = 1)) and (var81 = 1 or not(var166 = 1)) and (var84 = 1
or not(var166 = 1)) and (var86 = 1 or not(var166 = 1)) and (var88 = 1 or not(
var166 = 1)) and (var90 = 1 or not(var166 = 1)) and (var92 = 1 or not(var166 = 1
)) and (var93 = 1 or not(var166 = 1)) and (var96 = 1 or not(var166 = 1)) and (
var97 = 1 or not(var167 = 1)) and (var100 = 1 or not(var167 = 1)) and (var102 =
1 or not(var167 = 1)) and (var104 = 1 or not(var167 = 1)) and (var106 = 1 or not
(var167 = 1)) and (var108 = 1 or not(var167 = 1)) and (var109 = 1 or not(var167
= 1)) and (var112 = 1 or not(var167 = 1)) and (var113 = 1 or not(var168 = 1))
and (var116 = 1 or not(var168 = 1)) and (var118 = 1 or not(var168 = 1)) and (
var120 = 1 or not(var168 = 1)) and (var122 = 1 or not(var168 = 1)) and (var124 =
 1 or not(var168 = 1)) and (var125 = 1 or not(var168 = 1)) and (var128 = 1 or
not(var168 = 1)) and (var129 = 1 or not(var169 = 1)) and (var132 = 1 or not(
var169 = 1)) and (var134 = 1 or not(var169 = 1)) and (var136 = 1 or not(var169 =
 1)) and (var138 = 1 or not(var169 = 1)) and (var140 = 1 or not(var169 = 1)) and
 (var141 = 1 or not(var169 = 1)) and (var144 = 1 or not(var169 = 1)) and (var145
 = 1 or not(var170 = 1)) and (var148 = 1 or not(var170 = 1)) and (var150 = 1 or
not(var170 = 1)) and (var152 = 1 or not(var170 = 1)) and (var154 = 1 or not(
var170 = 1)) and (var156 = 1 or not(var170 = 1)) and (var157 = 1 or not(var170 =
 1)) and (var160 = 1 or not(var170 = 1)) and (var1 = 1 or not(var171 = 1)) and (
var4 = 1 or not(var171 = 1)) and (var6 = 1 or not(var171 = 1)) and (var8 = 1 or
not(var171 = 1)) and (var9 = 1 or not(var171 = 1)) and (var12 = 1 or not(var171
= 1)) and (var14 = 1 or not(var171 = 1)) and (var16 = 1 or not(var171 = 1)) and
(var17 = 1 or not(var172 = 1)) and (var20 = 1 or not(var172 = 1)) and (var22 = 1
 or not(var172 = 1)) and (var24 = 1 or not(var172 = 1)) and (var25 = 1 or not(
var172 = 1)) and (var28 = 1 or not(var172 = 1)) and (var30 = 1 or not(var172 = 1
)) and (var32 = 1 or not(var172 = 1)) and (var33 = 1 or not(var173 = 1)) and (
var36 = 1 or not(var173 = 1)) and (var38 = 1 or not(var173 = 1)) and (var40 = 1
or not(var173 = 1)) and (var41 = 1 or not(var173 = 1)) and (var44 = 1 or not(
var173 = 1)) and (var46 = 1 or not(var173 = 1)) and (var48 = 1 or not(var173 = 1
)) and (var49 = 1 or not(var174 = 1)) and (var52 = 1 or not(var174 = 1)) and (
var54 = 1 or not(var174 = 1)) and (var56 = 1 or not(var174 = 1)) and (var57 = 1
or not(var174 = 1)) and (var60 = 1 or not(var174 = 1)) and (var62 = 1 or not(
var174 = 1)) and (var64 = 1 or not(var174 = 1)) and (var65 = 1 or not(var175 = 1
)) and (var68 = 1 or not(var175 = 1)) and (var70 = 1 or not(var175 = 1)) and (
var72 = 1 or not(var175 = 1)) and (var73 = 1 or not(var175 = 1)) and (var76 = 1
or not(var175 = 1)) and (var78 = 1 or not(var175 = 1)) and (var80 = 1 or not(
var175 = 1)) and (var81 = 1 or not(var176 = 1)) and (var84 = 1 or not(var176 = 1
)) and (var86 = 1 or not(var176 = 1)) and (var88 = 1 or not(var176 = 1)) and (
var89 = 1 or not(var176 = 1)) and (var92 = 1 or not(var176 = 1)) and (var94 = 1
or not(var176 = 1)) and (var96 = 1 or not(var176 = 1)) and (var97 = 1 or not(
var177 = 1)) and (var100 = 1 or not(var177 = 1)) and (var102 = 1 or not(var177 =
 1)) and (var104 = 1 or not(var177 = 1)) and (var105 = 1 or not(var177 = 1)) and
 (var108 = 1 or not(var177 = 1)) and (var110 = 1 or not(var177 = 1)) and (var112
 = 1 or not(var177 = 1)) and (var113 = 1 or not(var178 = 1)) and (var116 = 1 or
not(var178 = 1)) and (var118 = 1 or not(var178 = 1)) and (var120 = 1 or not(
var178 = 1)) and (var121 = 1 or not(var178 = 1)) and (var124 = 1 or not(var178 =
 1)) and (var126 = 1 or not(var178 = 1)) and (var128 = 1 or not(var178 = 1)) and
 (var129 = 1 or not(var179 = 1)) and (var132 = 1 or not(var179 = 1)) and (var134
 = 1 or not(var179 = 1)) and (var136 = 1 or not(var179 = 1)) and (var137 = 1 or
not(var179 = 1)) and (var140 = 1 or not(var179 = 1)) and (var142 = 1 or not(
var179 = 1)) and (var144 = 1 or not(var179 = 1)) and (var145 = 1 or not(var180 =
 1)) and (var148 = 1 or not(var180 = 1)) and (var150 = 1 or not(var180 = 1)) and
 (var152 = 1 or not(var180 = 1)) and (var153 = 1 or not(var180 = 1)) and (var156
 = 1 or not(var180 = 1)) and (var158 = 1 or not(var180 = 1)) and (var160 = 1 or
not(var180 = 1)) and (var1 = 1 or not(var181 = 1)) and (var4 = 1 or not(var181 =
 1)) and (var5 = 1 or not(var181 = 1)) and (var7 = 1 or not(var181 = 1)) and (
var10 = 1 or not(var181 = 1)) and (var11 = 1 or not(var181 = 1)) and (var13 = 1
or not(var181 = 1)) and (var16 = 1 or not(var181 = 1)) and (var17 = 1 or not(
var182 = 1)) and (var20 = 1 or not(var182 = 1)) and (var21 = 1 or not(var182 = 1
)) and (var23 = 1 or not(var182 = 1)) and (var26 = 1 or not(var182 = 1)) and (
var27 = 1 or not(var182 = 1)) and (var29 = 1 or not(var182 = 1)) and (var32 = 1
or not(var182 = 1)) and (var33 = 1 or not(var183 = 1)) and (var36 = 1 or not(
var183 = 1)) and (var37 = 1 or not(var183 = 1)) and (var39 = 1 or not(var183 = 1
)) and (var42 = 1 or not(var183 = 1)) and (var43 = 1 or not(var183 = 1)) and (
var45 = 1 or not(var183 = 1)) and (var48 = 1 or not(var183 = 1)) and (var49 = 1
or not(var184 = 1)) and (var52 = 1 or not(var184 = 1)) and (var53 = 1 or not(
var184 = 1)) and (var55 = 1 or not(var184 = 1)) and (var58 = 1 or not(var184 = 1
)) and (var59 = 1 or not(var184 = 1)) and (var61 = 1 or not(var184 = 1)) and (
var64 = 1 or not(var184 = 1)) and (var65 = 1 or not(var185 = 1)) and (var68 = 1
or not(var185 = 1)) and (var69 = 1 or not(var185 = 1)) and (var71 = 1 or not(
var185 = 1)) and (var74 = 1 or not(var185 = 1)) and (var75 = 1 or not(var185 = 1
)) and (var77 = 1 or not(var185 = 1)) and (var80 = 1 or not(var185 = 1)) and (
var81 = 1 or not(var186 = 1)) and (var84 = 1 or not(var186 = 1)) and (var85 = 1
or not(var186 = 1)) and (var87 = 1 or not(var186 = 1)) and (var90 = 1 or not(
var186 = 1)) and (var91 = 1 or not(var186 = 1)) and (var93 = 1 or not(var186 = 1
)) and (var96 = 1 or not(var186 = 1)) and (var97 = 1 or not(var187 = 1)) and (
var100 = 1 or not(var187 = 1)) and (var101 = 1 or not(var187 = 1)) and (var103 =
 1 or not(var187 = 1)) and (var106 = 1 or not(var187 = 1)) and (var107 = 1 or
not(var187 = 1)) and (var109 = 1 or not(var187 = 1)) and (var112 = 1 or not(
var187 = 1)) and (var113 = 1 or not(var188 = 1)) and (var116 = 1 or not(var188 =
 1)) and (var117 = 1 or not(var188 = 1)) and (var119 = 1 or not(var188 = 1)) and
 (var122 = 1 or not(var188 = 1)) and (var123 = 1 or not(var188 = 1)) and (var125
 = 1 or not(var188 = 1)) and (var128 = 1 or not(var188 = 1)) and (var129 = 1 or
not(var189 = 1)) and (var132 = 1 or not(var189 = 1)) and (var133 = 1 or not(
var189 = 1)) and (var135 = 1 or not(var189 = 1)) and (var138 = 1 or not(var189 =
 1)) and (var139 = 1 or not(var189 = 1)) and (var141 = 1 or not(var189 = 1)) and
 (var144 = 1 or not(var189 = 1)) and (var145 = 1 or not(var190 = 1)) and (var148
 = 1 or not(var190 = 1)) and (var149 = 1 or not(var190 = 1)) and (var151 = 1 or
not(var190 = 1)) and (var154 = 1 or not(var190 = 1)) and (var155 = 1 or not(
var190 = 1)) and (var157 = 1 or not(var190 = 1)) and (var160 = 1 or not(var190 =
 1)) and (var2 = 1 or not(var191 = 1)) and (var3 = 1 or not(var191 = 1)) and (
var6 = 1 or not(var191 = 1)) and (var7 = 1 or not(var191 = 1)) and (var10 = 1 or
 not(var191 = 1)) and (var12 = 1 or not(var191 = 1)) and (var14 = 1 or not(
var191 = 1)) and (var15 = 1 or not(var191 = 1)) and (var18 = 1 or not(var192 = 1
)) and (var19 = 1 or not(var192 = 1)) and (var22 = 1 or not(var192 = 1)) and (
var23 = 1 or not(var192 = 1)) and (var26 = 1 or not(var192 = 1)) and (var28 = 1
or not(var192 = 1)) and (var30 = 1 or not(var192 = 1)) and (var31 = 1 or not(
var192 = 1)) and (var34 = 1 or not(var193 = 1)) and (var35 = 1 or not(var193 = 1
)) and (var38 = 1 or not(var193 = 1)) and (var39 = 1 or not(var193 = 1)) and (
var42 = 1 or not(var193 = 1)) and (var44 = 1 or not(var193 = 1)) and (var46 = 1
or not(var193 = 1)) and (var47 = 1 or not(var193 = 1)) and (var50 = 1 or not(
var194 = 1)) and (var51 = 1 or not(var194 = 1)) and (var54 = 1 or not(var194 = 1
)) and (var55 = 1 or not(var194 = 1)) and (var58 = 1 or not(var194 = 1)) and (
var60 = 1 or not(var194 = 1)) and (var62 = 1 or not(var194 = 1)) and (var63 = 1
or not(var194 = 1)) and (var66 = 1 or not(var195 = 1)) and (var67 = 1 or not(
var195 = 1)) and (var70 = 1 or not(var195 = 1)) and (var71 = 1 or not(var195 = 1
)) and (var74 = 1 or not(var195 = 1)) and (var76 = 1 or not(var195 = 1)) and (
var78 = 1 or not(var195 = 1)) and (var79 = 1 or not(var195 = 1)) and (var82 = 1
or not(var196 = 1)) and (var83 = 1 or not(var196 = 1)) and (var86 = 1 or not(
var196 = 1)) and (var87 = 1 or not(var196 = 1)) and (var90 = 1 or not(var196 = 1
)) and (var92 = 1 or not(var196 = 1)) and (var94 = 1 or not(var196 = 1)) and (
var95 = 1 or not(var196 = 1)) and (var98 = 1 or not(var197 = 1)) and (var99 = 1
or not(var197 = 1)) and (var102 = 1 or not(var197 = 1)) and (var103 = 1 or not(
var197 = 1)) and (var106 = 1 or not(var197 = 1)) and (var108 = 1 or not(var197 =
 1)) and (var110 = 1 or not(var197 = 1)) and (var111 = 1 or not(var197 = 1)) and
 (var114 = 1 or not(var198 = 1)) and (var115 = 1 or not(var198 = 1)) and (var118
 = 1 or not(var198 = 1)) and (var119 = 1 or not(var198 = 1)) and (var122 = 1 or
not(var198 = 1)) and (var124 = 1 or not(var198 = 1)) and (var126 = 1 or not(
var198 = 1)) and (var127 = 1 or not(var198 = 1)) and (var130 = 1 or not(var199 =
 1)) and (var131 = 1 or not(var199 = 1)) and (var134 = 1 or not(var199 = 1)) and
 (var135 = 1 or not(var199 = 1)) and (var138 = 1 or not(var199 = 1)) and (var140
 = 1 or not(var199 = 1)) and (var142 = 1 or not(var199 = 1)) and (var143 = 1 or
not(var199 = 1)) and (var146 = 1 or not(var200 = 1)) and (var147 = 1 or not(
var200 = 1)) and (var150 = 1 or not(var200 = 1)) and (var151 = 1 or not(var200 =
 1)) and (var154 = 1 or not(var200 = 1)) and (var156 = 1 or not(var200 = 1)) and
 (var158 = 1 or not(var200 = 1)) and (var159 = 1 or not(var200 = 1)) and (var1 =
 1 or not(var201 = 1)) and (var3 = 1 or not(var201 = 1)) and (var5 = 1 or not(
var201 = 1)) and (var8 = 1 or not(var201 = 1)) and (var9 = 1 or not(var201 = 1))
 and (var12 = 1 or not(var201 = 1)) and (var14 = 1 or not(var201 = 1)) and (
var15 = 1 or not(var201 = 1)) and (var17 = 1 or not(var202 = 1)) and (var19 = 1
or not(var202 = 1)) and (var21 = 1 or not(var202 = 1)) and (var24 = 1 or not(
var202 = 1)) and (var25 = 1 or not(var202 = 1)) and (var28 = 1 or not(var202 = 1
)) and (var30 = 1 or not(var202 = 1)) and (var31 = 1 or not(var202 = 1)) and (
var33 = 1 or not(var203 = 1)) and (var35 = 1 or not(var203 = 1)) and (var37 = 1
or not(var203 = 1)) and (var40 = 1 or not(var203 = 1)) and (var41 = 1 or not(
var203 = 1)) and (var44 = 1 or not(var203 = 1)) and (var46 = 1 or not(var203 = 1
)) and (var47 = 1 or not(var203 = 1)) and (var49 = 1 or not(var204 = 1)) and (
var51 = 1 or not(var204 = 1)) and (var53 = 1 or not(var204 = 1)) and (var56 = 1
or not(var204 = 1)) and (var57 = 1 or not(var204 = 1)) and (var60 = 1 or not(
var204 = 1)) and (var62 = 1 or not(var204 = 1)) and (var63 = 1 or not(var204 = 1
)) and (var65 = 1 or not(var205 = 1)) and (var67 = 1 or not(var205 = 1)) and (
var69 = 1 or not(var205 = 1)) and (var72 = 1 or not(var205 = 1)) and (var73 = 1
or not(var205 = 1)) and (var76 = 1 or not(var205 = 1)) and (var78 = 1 or not(
var205 = 1)) and (var79 = 1 or not(var205 = 1)) and (var81 = 1 or not(var206 = 1
)) and (var83 = 1 or not(var206 = 1)) and (var85 = 1 or not(var206 = 1)) and (
var88 = 1 or not(var206 = 1)) and (var89 = 1 or not(var206 = 1)) and (var92 = 1
or not(var206 = 1)) and (var94 = 1 or not(var206 = 1)) and (var95 = 1 or not(
var206 = 1)) and (var97 = 1 or not(var207 = 1)) and (var99 = 1 or not(var207 = 1
)) and (var101 = 1 or not(var207 = 1)) and (var104 = 1 or not(var207 = 1)) and (
var105 = 1 or not(var207 = 1)) and (var108 = 1 or not(var207 = 1)) and (var110 =
 1 or not(var207 = 1)) and (var111 = 1 or not(var207 = 1)) and (var113 = 1 or
not(var208 = 1)) and (var115 = 1 or not(var208 = 1)) and (var117 = 1 or not(
var208 = 1)) and (var120 = 1 or not(var208 = 1)) and (var121 = 1 or not(var208 =
 1)) and (var124 = 1 or not(var208 = 1)) and (var126 = 1 or not(var208 = 1)) and
 (var127 = 1 or not(var208 = 1)) and (var129 = 1 or not(var209 = 1)) and (var131
 = 1 or not(var209 = 1)) and (var133 = 1 or not(var209 = 1)) and (var136 = 1 or
not(var209 = 1)) and (var137 = 1 or not(var209 = 1)) and (var140 = 1 or not(
var209 = 1)) and (var142 = 1 or not(var209 = 1)) and (var143 = 1 or not(var209 =
 1)) and (var145 = 1 or not(var210 = 1)) and (var147 = 1 or not(var210 = 1)) and
 (var149 = 1 or not(var210 = 1)) and (var152 = 1 or not(var210 = 1)) and (var153
 = 1 or not(var210 = 1)) and (var156 = 1 or not(var210 = 1)) and (var158 = 1 or
not(var210 = 1)) and (var159 = 1 or not(var210 = 1)) and (var1 = 1 or not(var211
 = 1)) and (var3 = 1 or not(var211 = 1)) and (var5 = 1 or not(var211 = 1)) and (
var8 = 1 or not(var211 = 1)) and (var10 = 1 or not(var211 = 1)) and (var11 = 1
or not(var211 = 1)) and (var13 = 1 or not(var211 = 1)) and (var15 = 1 or not(
var211 = 1)) and (var17 = 1 or not(var212 = 1)) and (var19 = 1 or not(var212 = 1
)) and (var21 = 1 or not(var212 = 1)) and (var24 = 1 or not(var212 = 1)) and (
var26 = 1 or not(var212 = 1)) and (var27 = 1 or not(var212 = 1)) and (var29 = 1
or not(var212 = 1)) and (var31 = 1 or not(var212 = 1)) and (var33 = 1 or not(
var213 = 1)) and (var35 = 1 or not(var213 = 1)) and (var37 = 1 or not(var213 = 1
)) and (var40 = 1 or not(var213 = 1)) and (var42 = 1 or not(var213 = 1)) and (
var43 = 1 or not(var213 = 1)) and (var45 = 1 or not(var213 = 1)) and (var47 = 1
or not(var213 = 1)) and (var49 = 1 or not(var214 = 1)) and (var51 = 1 or not(
var214 = 1)) and (var53 = 1 or not(var214 = 1)) and (var56 = 1 or not(var214 = 1
)) and (var58 = 1 or not(var214 = 1)) and (var59 = 1 or not(var214 = 1)) and (
var61 = 1 or not(var214 = 1)) and (var63 = 1 or not(var214 = 1)) and (var65 = 1
or not(var215 = 1)) and (var67 = 1 or not(var215 = 1)) and (var69 = 1 or not(
var215 = 1)) and (var72 = 1 or not(var215 = 1)) and (var74 = 1 or not(var215 = 1
)) and (var75 = 1 or not(var215 = 1)) and (var77 = 1 or not(var215 = 1)) and (
var79 = 1 or not(var215 = 1)) and (var81 = 1 or not(var216 = 1)) and (var83 = 1
or not(var216 = 1)) and (var85 = 1 or not(var216 = 1)) and (var88 = 1 or not(
var216 = 1)) and (var90 = 1 or not(var216 = 1)) and (var91 = 1 or not(var216 = 1
)) and (var93 = 1 or not(var216 = 1)) and (var95 = 1 or not(var216 = 1)) and (
var97 = 1 or not(var217 = 1)) and (var99 = 1 or not(var217 = 1)) and (var101 = 1
 or not(var217 = 1)) and (var104 = 1 or not(var217 = 1)) and (var106 = 1 or not(
var217 = 1)) and (var107 = 1 or not(var217 = 1)) and (var109 = 1 or not(var217 =
 1)) and (var111 = 1 or not(var217 = 1)) and (var113 = 1 or not(var218 = 1)) and
 (var115 = 1 or not(var218 = 1)) and (var117 = 1 or not(var218 = 1)) and (var120
 = 1 or not(var218 = 1)) and (var122 = 1 or not(var218 = 1)) and (var123 = 1 or
not(var218 = 1)) and (var125 = 1 or not(var218 = 1)) and (var127 = 1 or not(
var218 = 1)) and (var129 = 1 or not(var219 = 1)) and (var131 = 1 or not(var219 =
 1)) and (var133 = 1 or not(var219 = 1)) and (var136 = 1 or not(var219 = 1)) and
 (var138 = 1 or not(var219 = 1)) and (var139 = 1 or not(var219 = 1)) and (var141
 = 1 or not(var219 = 1)) and (var143 = 1 or not(var219 = 1)) and (var145 = 1 or
not(var220 = 1)) and (var147 = 1 or not(var220 = 1)) and (var149 = 1 or not(
var220 = 1)) and (var152 = 1 or not(var220 = 1)) and (var154 = 1 or not(var220 =
 1)) and (var155 = 1 or not(var220 = 1)) and (var157 = 1 or not(var220 = 1)) and
 (var159 = 1 or not(var220 = 1)) and (var1 = 1 or not(var221 = 1)) and (var4 = 1
 or not(var221 = 1)) and (var5 = 1 or not(var221 = 1)) and (var7 = 1 or not(
var221 = 1)) and (var10 = 1 or not(var221 = 1)) and (var12 = 1 or not(var221 = 1
)) and (var14 = 1 or not(var221 = 1)) and (var16 = 1 or not(var221 = 1)) and (
var17 = 1 or not(var222 = 1)) and (var20 = 1 or not(var222 = 1)) and (var21 = 1
or not(var222 = 1)) and (var23 = 1 or not(var222 = 1)) and (var26 = 1 or not(
var222 = 1)) and (var28 = 1 or not(var222 = 1)) and (var30 = 1 or not(var222 = 1
)) and (var32 = 1 or not(var222 = 1)) and (var33 = 1 or not(var223 = 1)) and (
var36 = 1 or not(var223 = 1)) and (var37 = 1 or not(var223 = 1)) and (var39 = 1
or not(var223 = 1)) and (var42 = 1 or not(var223 = 1)) and (var44 = 1 or not(
var223 = 1)) and (var46 = 1 or not(var223 = 1)) and (var48 = 1 or not(var223 = 1
)) and (var49 = 1 or not(var224 = 1)) and (var52 = 1 or not(var224 = 1)) and (
var53 = 1 or not(var224 = 1)) and (var55 = 1 or not(var224 = 1)) and (var58 = 1
or not(var224 = 1)) and (var60 = 1 or not(var224 = 1)) and (var62 = 1 or not(
var224 = 1)) and (var64 = 1 or not(var224 = 1)) and (var65 = 1 or not(var225 = 1
)) and (var68 = 1 or not(var225 = 1)) and (var69 = 1 or not(var225 = 1)) and (
var71 = 1 or not(var225 = 1)) and (var74 = 1 or not(var225 = 1)) and (var76 = 1
or not(var225 = 1)) and (var78 = 1 or not(var225 = 1)) and (var80 = 1 or not(
var225 = 1)) and (var81 = 1 or not(var226 = 1)) and (var84 = 1 or not(var226 = 1
)) and (var85 = 1 or not(var226 = 1)) and (var87 = 1 or not(var226 = 1)) and (
var90 = 1 or not(var226 = 1)) and (var92 = 1 or not(var226 = 1)) and (var94 = 1
or not(var226 = 1)) and (var96 = 1 or not(var226 = 1)) and (var97 = 1 or not(
var227 = 1)) and (var100 = 1 or not(var227 = 1)) and (var101 = 1 or not(var227 =
 1)) and (var103 = 1 or not(var227 = 1)) and (var106 = 1 or not(var227 = 1)) and
 (var108 = 1 or not(var227 = 1)) and (var110 = 1 or not(var227 = 1)) and (var112
 = 1 or not(var227 = 1)) and (var113 = 1 or not(var228 = 1)) and (var116 = 1 or
not(var228 = 1)) and (var117 = 1 or not(var228 = 1)) and (var119 = 1 or not(
var228 = 1)) and (var122 = 1 or not(var228 = 1)) and (var124 = 1 or not(var228 =
 1)) and (var126 = 1 or not(var228 = 1)) and (var128 = 1 or not(var228 = 1)) and
 (var129 = 1 or not(var229 = 1)) and (var132 = 1 or not(var229 = 1)) and (var133
 = 1 or not(var229 = 1)) and (var135 = 1 or not(var229 = 1)) and (var138 = 1 or
not(var229 = 1)) and (var140 = 1 or not(var229 = 1)) and (var142 = 1 or not(
var229 = 1)) and (var144 = 1 or not(var229 = 1)) and (var145 = 1 or not(var230 =
 1)) and (var148 = 1 or not(var230 = 1)) and (var149 = 1 or not(var230 = 1)) and
 (var151 = 1 or not(var230 = 1)) and (var154 = 1 or not(var230 = 1)) and (var156
 = 1 or not(var230 = 1)) and (var158 = 1 or not(var230 = 1)) and (var160 = 1 or
not(var230 = 1)) and (var2 = 1 or not(var231 = 1)) and (var4 = 1 or not(var231 =
 1)) and (var6 = 1 or not(var231 = 1)) and (var7 = 1 or not(var231 = 1)) and (
var10 = 1 or not(var231 = 1)) and (var11 = 1 or not(var231 = 1)) and (var13 = 1
or not(var231 = 1)) and (var16 = 1 or not(var231 = 1)) and (var18 = 1 or not(
var232 = 1)) and (var20 = 1 or not(var232 = 1)) and (var22 = 1 or not(var232 = 1
)) and (var23 = 1 or not(var232 = 1)) and (var26 = 1 or not(var232 = 1)) and (
var27 = 1 or not(var232 = 1)) and (var29 = 1 or not(var232 = 1)) and (var32 = 1
or not(var232 = 1)) and (var34 = 1 or not(var233 = 1)) and (var36 = 1 or not(
var233 = 1)) and (var38 = 1 or not(var233 = 1)) and (var39 = 1 or not(var233 = 1
)) and (var42 = 1 or not(var233 = 1)) and (var43 = 1 or not(var233 = 1)) and (
var45 = 1 or not(var233 = 1)) and (var48 = 1 or not(var233 = 1)) and (var50 = 1
or not(var234 = 1)) and (var52 = 1 or not(var234 = 1)) and (var54 = 1 or not(
var234 = 1)) and (var55 = 1 or not(var234 = 1)) and (var58 = 1 or not(var234 = 1
)) and (var59 = 1 or not(var234 = 1)) and (var61 = 1 or not(var234 = 1)) and (
var64 = 1 or not(var234 = 1)) and (var66 = 1 or not(var235 = 1)) and (var68 = 1
or not(var235 = 1)) and (var70 = 1 or not(var235 = 1)) and (var71 = 1 or not(
var235 = 1)) and (var74 = 1 or not(var235 = 1)) and (var75 = 1 or not(var235 = 1
)) and (var77 = 1 or not(var235 = 1)) and (var80 = 1 or not(var235 = 1)) and (
var82 = 1 or not(var236 = 1)) and (var84 = 1 or not(var236 = 1)) and (var86 = 1
or not(var236 = 1)) and (var87 = 1 or not(var236 = 1)) and (var90 = 1 or not(
var236 = 1)) and (var91 = 1 or not(var236 = 1)) and (var93 = 1 or not(var236 = 1
)) and (var96 = 1 or not(var236 = 1)) and (var98 = 1 or not(var237 = 1)) and (
var100 = 1 or not(var237 = 1)) and (var102 = 1 or not(var237 = 1)) and (var103 =
 1 or not(var237 = 1)) and (var106 = 1 or not(var237 = 1)) and (var107 = 1 or
not(var237 = 1)) and (var109 = 1 or not(var237 = 1)) and (var112 = 1 or not(
var237 = 1)) and (var114 = 1 or not(var238 = 1)) and (var116 = 1 or not(var238 =
 1)) and (var118 = 1 or not(var238 = 1)) and (var119 = 1 or not(var238 = 1)) and
 (var122 = 1 or not(var238 = 1)) and (var123 = 1 or not(var238 = 1)) and (var125
 = 1 or not(var238 = 1)) and (var128 = 1 or not(var238 = 1)) and (var130 = 1 or
not(var239 = 1)) and (var132 = 1 or not(var239 = 1)) and (var134 = 1 or not(
var239 = 1)) and (var135 = 1 or not(var239 = 1)) and (var138 = 1 or not(var239 =
 1)) and (var139 = 1 or not(var239 = 1)) and (var141 = 1 or not(var239 = 1)) and
 (var144 = 1 or not(var239 = 1)) and (var146 = 1 or not(var240 = 1)) and (var148
 = 1 or not(var240 = 1)) and (var150 = 1 or not(var240 = 1)) and (var151 = 1 or
not(var240 = 1)) and (var154 = 1 or not(var240 = 1)) and (var155 = 1 or not(
var240 = 1)) and (var157 = 1 or not(var240 = 1)) and (var160 = 1 or not(var240 =
 1)) and (var1 = 1 or not(var241 = 1)) and (var4 = 1 or not(var241 = 1)) and (
var5 = 1 or not(var241 = 1)) and (var8 = 1 or not(var241 = 1)) and (var10 = 1 or
 not(var241 = 1)) and (var12 = 1 or not(var241 = 1)) and (var13 = 1 or not(
var241 = 1)) and (var15 = 1 or not(var241 = 1)) and (var17 = 1 or not(var242 = 1
)) and (var20 = 1 or not(var242 = 1)) and (var21 = 1 or not(var242 = 1)) and (
var24 = 1 or not(var242 = 1)) and (var26 = 1 or not(var242 = 1)) and (var28 = 1
or not(var242 = 1)) and (var29 = 1 or not(var242 = 1)) and (var31 = 1 or not(
var242 = 1)) and (var33 = 1 or not(var243 = 1)) and (var36 = 1 or not(var243 = 1
)) and (var37 = 1 or not(var243 = 1)) and (var40 = 1 or not(var243 = 1)) and (
var42 = 1 or not(var243 = 1)) and (var44 = 1 or not(var243 = 1)) and (var45 = 1
or not(var243 = 1)) and (var47 = 1 or not(var243 = 1)) and (var49 = 1 or not(
var244 = 1)) and (var52 = 1 or not(var244 = 1)) and (var53 = 1 or not(var244 = 1
)) and (var56 = 1 or not(var244 = 1)) and (var58 = 1 or not(var244 = 1)) and (
var60 = 1 or not(var244 = 1)) and (var61 = 1 or not(var244 = 1)) and (var63 = 1
or not(var244 = 1)) and (var65 = 1 or not(var245 = 1)) and (var68 = 1 or not(
var245 = 1)) and (var69 = 1 or not(var245 = 1)) and (var72 = 1 or not(var245 = 1
)) and (var74 = 1 or not(var245 = 1)) and (var76 = 1 or not(var245 = 1)) and (
var77 = 1 or not(var245 = 1)) and (var79 = 1 or not(var245 = 1)) and (var81 = 1
or not(var246 = 1)) and (var84 = 1 or not(var246 = 1)) and (var85 = 1 or not(
var246 = 1)) and (var88 = 1 or not(var246 = 1)) and (var90 = 1 or not(var246 = 1
)) and (var92 = 1 or not(var246 = 1)) and (var93 = 1 or not(var246 = 1)) and (
var95 = 1 or not(var246 = 1)) and (var97 = 1 or not(var247 = 1)) and (var100 = 1
 or not(var247 = 1)) and (var101 = 1 or not(var247 = 1)) and (var104 = 1 or not(
var247 = 1)) and (var106 = 1 or not(var247 = 1)) and (var108 = 1 or not(var247 =
 1)) and (var109 = 1 or not(var247 = 1)) and (var111 = 1 or not(var247 = 1)) and
 (var113 = 1 or not(var248 = 1)) and (var116 = 1 or not(var248 = 1)) and (var117
 = 1 or not(var248 = 1)) and (var120 = 1 or not(var248 = 1)) and (var122 = 1 or
not(var248 = 1)) and (var124 = 1 or not(var248 = 1)) and (var125 = 1 or not(
var248 = 1)) and (var127 = 1 or not(var248 = 1)) and (var129 = 1 or not(var249 =
 1)) and (var132 = 1 or not(var249 = 1)) and (var133 = 1 or not(var249 = 1)) and
 (var136 = 1 or not(var249 = 1)) and (var138 = 1 or not(var249 = 1)) and (var140
 = 1 or not(var249 = 1)) and (var141 = 1 or not(var249 = 1)) and (var143 = 1 or
not(var249 = 1)) and (var145 = 1 or not(var250 = 1)) and (var148 = 1 or not(
var250 = 1)) and (var149 = 1 or not(var250 = 1)) and (var152 = 1 or not(var250 =
 1)) and (var154 = 1 or not(var250 = 1)) and (var156 = 1 or not(var250 = 1)) and
 (var157 = 1 or not(var250 = 1)) and (var159 = 1 or not(var250 = 1)) and (var1 =
 1 or not(var251 = 1)) and (var3 = 1 or not(var251 = 1)) and (var6 = 1 or not(
var251 = 1)) and (var7 = 1 or not(var251 = 1)) and (var10 = 1 or not(var251 = 1)
) and (var11 = 1 or not(var251 = 1)) and (var14 = 1 or not(var251 = 1)) and (
var16 = 1 or not(var251 = 1)) and (var17 = 1 or not(var252 = 1)) and (var19 = 1
or not(var252 = 1)) and (var22 = 1 or not(var252 = 1)) and (var23 = 1 or not(
var252 = 1)) and (var26 = 1 or not(var252 = 1)) and (var27 = 1 or not(var252 = 1
)) and (var30 = 1 or not(var252 = 1)) and (var32 = 1 or not(var252 = 1)) and (
var33 = 1 or not(var253 = 1)) and (var35 = 1 or not(var253 = 1)) and (var38 = 1
or not(var253 = 1)) and (var39 = 1 or not(var253 = 1)) and (var42 = 1 or not(
var253 = 1)) and (var43 = 1 or not(var253 = 1)) and (var46 = 1 or not(var253 = 1
)) and (var48 = 1 or not(var253 = 1)) and (var49 = 1 or not(var254 = 1)) and (
var51 = 1 or not(var254 = 1)) and (var54 = 1 or not(var254 = 1)) and (var55 = 1
or not(var254 = 1)) and (var58 = 1 or not(var254 = 1)) and (var59 = 1 or not(
var254 = 1)) and (var62 = 1 or not(var254 = 1)) and (var64 = 1 or not(var254 = 1
)) and (var65 = 1 or not(var255 = 1)) and (var67 = 1 or not(var255 = 1)) and (
var70 = 1 or not(var255 = 1)) and (var71 = 1 or not(var255 = 1)) and (var74 = 1
or not(var255 = 1)) and (var75 = 1 or not(var255 = 1)) and (var78 = 1 or not(
var255 = 1)) and (var80 = 1 or not(var255 = 1)) and (var81 = 1 or not(var256 = 1
)) and (var83 = 1 or not(var256 = 1)) and (var86 = 1 or not(var256 = 1)) and (
var87 = 1 or not(var256 = 1)) and (var90 = 1 or not(var256 = 1)) and (var91 = 1
or not(var256 = 1)) and (var94 = 1 or not(var256 = 1)) and (var96 = 1 or not(
var256 = 1)) and (var97 = 1 or not(var257 = 1)) and (var99 = 1 or not(var257 = 1
)) and (var102 = 1 or not(var257 = 1)) and (var103 = 1 or not(var257 = 1)) and (
var106 = 1 or not(var257 = 1)) and (var107 = 1 or not(var257 = 1)) and (var110 =
 1 or not(var257 = 1)) and (var112 = 1 or not(var257 = 1)) and (var113 = 1 or
not(var258 = 1)) and (var115 = 1 or not(var258 = 1)) and (var118 = 1 or not(
var258 = 1)) and (var119 = 1 or not(var258 = 1)) and (var122 = 1 or not(var258 =
 1)) and (var123 = 1 or not(var258 = 1)) and (var126 = 1 or not(var258 = 1)) and
 (var128 = 1 or not(var258 = 1)) and (var129 = 1 or not(var259 = 1)) and (var131
 = 1 or not(var259 = 1)) and (var134 = 1 or not(var259 = 1)) and (var135 = 1 or
not(var259 = 1)) and (var138 = 1 or not(var259 = 1)) and (var139 = 1 or not(
var259 = 1)) and (var142 = 1 or not(var259 = 1)) and (var144 = 1 or not(var259 =
 1)) and (var145 = 1 or not(var260 = 1)) and (var147 = 1 or not(var260 = 1)) and
 (var150 = 1 or not(var260 = 1)) and (var151 = 1 or not(var260 = 1)) and (var154
 = 1 or not(var260 = 1)) and (var155 = 1 or not(var260 = 1)) and (var158 = 1 or
not(var260 = 1)) and (var160 = 1 or not(var260 = 1)) and (var2 = 1 or not(var261
 = 1)) and (var3 = 1 or not(var261 = 1)) and (var5 = 1 or not(var261 = 1)) and (
var8 = 1 or not(var261 = 1)) and (var10 = 1 or not(var261 = 1)) and (var11 = 1
or not(var261 = 1)) and (var13 = 1 or not(var261 = 1)) and (var15 = 1 or not(
var261 = 1)) and (var18 = 1 or not(var262 = 1)) and (var19 = 1 or not(var262 = 1
)) and (var21 = 1 or not(var262 = 1)) and (var24 = 1 or not(var262 = 1)) and (
var26 = 1 or not(var262 = 1)) and (var27 = 1 or not(var262 = 1)) and (var29 = 1
or not(var262 = 1)) and (var31 = 1 or not(var262 = 1)) and (var34 = 1 or not(
var263 = 1)) and (var35 = 1 or not(var263 = 1)) and (var37 = 1 or not(var263 = 1
)) and (var40 = 1 or not(var263 = 1)) and (var42 = 1 or not(var263 = 1)) and (
var43 = 1 or not(var263 = 1)) and (var45 = 1 or not(var263 = 1)) and (var47 = 1
or not(var263 = 1)) and (var50 = 1 or not(var264 = 1)) and (var51 = 1 or not(
var264 = 1)) and (var53 = 1 or not(var264 = 1)) and (var56 = 1 or not(var264 = 1
)) and (var58 = 1 or not(var264 = 1)) and (var59 = 1 or not(var264 = 1)) and (
var61 = 1 or not(var264 = 1)) and (var63 = 1 or not(var264 = 1)) and (var66 = 1
or not(var265 = 1)) and (var67 = 1 or not(var265 = 1)) and (var69 = 1 or not(
var265 = 1)) and (var72 = 1 or not(var265 = 1)) and (var74 = 1 or not(var265 = 1
)) and (var75 = 1 or not(var265 = 1)) and (var77 = 1 or not(var265 = 1)) and (
var79 = 1 or not(var265 = 1)) and (var82 = 1 or not(var266 = 1)) and (var83 = 1
or not(var266 = 1)) and (var85 = 1 or not(var266 = 1)) and (var88 = 1 or not(
var266 = 1)) and (var90 = 1 or not(var266 = 1)) and (var91 = 1 or not(var266 = 1
)) and (var93 = 1 or not(var266 = 1)) and (var95 = 1 or not(var266 = 1)) and (
var98 = 1 or not(var267 = 1)) and (var99 = 1 or not(var267 = 1)) and (var101 = 1
 or not(var267 = 1)) and (var104 = 1 or not(var267 = 1)) and (var106 = 1 or not(
var267 = 1)) and (var107 = 1 or not(var267 = 1)) and (var109 = 1 or not(var267 =
 1)) and (var111 = 1 or not(var267 = 1)) and (var114 = 1 or not(var268 = 1)) and
 (var115 = 1 or not(var268 = 1)) and (var117 = 1 or not(var268 = 1)) and (var120
 = 1 or not(var268 = 1)) and (var122 = 1 or not(var268 = 1)) and (var123 = 1 or
not(var268 = 1)) and (var125 = 1 or not(var268 = 1)) and (var127 = 1 or not(
var268 = 1)) and (var130 = 1 or not(var269 = 1)) and (var131 = 1 or not(var269 =
 1)) and (var133 = 1 or not(var269 = 1)) and (var136 = 1 or not(var269 = 1)) and
 (var138 = 1 or not(var269 = 1)) and (var139 = 1 or not(var269 = 1)) and (var141
 = 1 or not(var269 = 1)) and (var143 = 1 or not(var269 = 1)) and (var146 = 1 or
not(var270 = 1)) and (var147 = 1 or not(var270 = 1)) and (var149 = 1 or not(
var270 = 1)) and (var152 = 1 or not(var270 = 1)) and (var154 = 1 or not(var270 =
 1)) and (var155 = 1 or not(var270 = 1)) and (var157 = 1 or not(var270 = 1)) and
 (var159 = 1 or not(var270 = 1)) and (var1 = 1 or not(var271 = 1)) and (var3 = 1
 or not(var271 = 1)) and (var6 = 1 or not(var271 = 1)) and (var7 = 1 or not(
var271 = 1)) and (var9 = 1 or not(var271 = 1)) and (var12 = 1 or not(var271 = 1)
) and (var14 = 1 or not(var271 = 1)) and (var15 = 1 or not(var271 = 1)) and (
var17 = 1 or not(var272 = 1)) and (var19 = 1 or not(var272 = 1)) and (var22 = 1
or not(var272 = 1)) and (var23 = 1 or not(var272 = 1)) and (var25 = 1 or not(
var272 = 1)) and (var28 = 1 or not(var272 = 1)) and (var30 = 1 or not(var272 = 1
)) and (var31 = 1 or not(var272 = 1)) and (var33 = 1 or not(var273 = 1)) and (
var35 = 1 or not(var273 = 1)) and (var38 = 1 or not(var273 = 1)) and (var39 = 1
or not(var273 = 1)) and (var41 = 1 or not(var273 = 1)) and (var44 = 1 or not(
var273 = 1)) and (var46 = 1 or not(var273 = 1)) and (var47 = 1 or not(var273 = 1
)) and (var49 = 1 or not(var274 = 1)) and (var51 = 1 or not(var274 = 1)) and (
var54 = 1 or not(var274 = 1)) and (var55 = 1 or not(var274 = 1)) and (var57 = 1
or not(var274 = 1)) and (var60 = 1 or not(var274 = 1)) and (var62 = 1 or not(
var274 = 1)) and (var63 = 1 or not(var274 = 1)) and (var65 = 1 or not(var275 = 1
)) and (var67 = 1 or not(var275 = 1)) and (var70 = 1 or not(var275 = 1)) and (
var71 = 1 or not(var275 = 1)) and (var73 = 1 or not(var275 = 1)) and (var76 = 1
or not(var275 = 1)) and (var78 = 1 or not(var275 = 1)) and (var79 = 1 or not(
var275 = 1)) and (var81 = 1 or not(var276 = 1)) and (var83 = 1 or not(var276 = 1
)) and (var86 = 1 or not(var276 = 1)) and (var87 = 1 or not(var276 = 1)) and (
var89 = 1 or not(var276 = 1)) and (var92 = 1 or not(var276 = 1)) and (var94 = 1
or not(var276 = 1)) and (var95 = 1 or not(var276 = 1)) and (var97 = 1 or not(
var277 = 1)) and (var99 = 1 or not(var277 = 1)) and (var102 = 1 or not(var277 =
1)) and (var103 = 1 or not(var277 = 1)) and (var105 = 1 or not(var277 = 1)) and
(var108 = 1 or not(var277 = 1)) and (var110 = 1 or not(var277 = 1)) and (var111
= 1 or not(var277 = 1)) and (var113 = 1 or not(var278 = 1)) and (var115 = 1 or
not(var278 = 1)) and (var118 = 1 or not(var278 = 1)) and (var119 = 1 or not(
var278 = 1)) and (var121 = 1 or not(var278 = 1)) and (var124 = 1 or not(var278 =
 1)) and (var126 = 1 or not(var278 = 1)) and (var127 = 1 or not(var278 = 1)) and
 (var129 = 1 or not(var279 = 1)) and (var131 = 1 or not(var279 = 1)) and (var134
 = 1 or not(var279 = 1)) and (var135 = 1 or not(var279 = 1)) and (var137 = 1 or
not(var279 = 1)) and (var140 = 1 or not(var279 = 1)) and (var142 = 1 or not(
var279 = 1)) and (var143 = 1 or not(var279 = 1)) and (var145 = 1 or not(var280 =
 1)) and (var147 = 1 or not(var280 = 1)) and (var150 = 1 or not(var280 = 1)) and
 (var151 = 1 or not(var280 = 1)) and (var153 = 1 or not(var280 = 1)) and (var156
 = 1 or not(var280 = 1)) and (var158 = 1 or not(var280 = 1)) and (var159 = 1 or
not(var280 = 1)) and (var1 = 1 or not(var281 = 1)) and (var4 = 1 or not(var281 =
 1)) and (var6 = 1 or not(var281 = 1)) and (var7 = 1 or not(var281 = 1)) and (
var10 = 1 or not(var281 = 1)) and (var11 = 1 or not(var281 = 1)) and (var13 = 1
or not(var281 = 1)) and (var16 = 1 or not(var281 = 1)) and (var17 = 1 or not(
var282 = 1)) and (var20 = 1 or not(var282 = 1)) and (var22 = 1 or not(var282 = 1
)) and (var23 = 1 or not(var282 = 1)) and (var26 = 1 or not(var282 = 1)) and (
var27 = 1 or not(var282 = 1)) and (var29 = 1 or not(var282 = 1)) and (var32 = 1
or not(var282 = 1)) and (var33 = 1 or not(var283 = 1)) and (var36 = 1 or not(
var283 = 1)) and (var38 = 1 or not(var283 = 1)) and (var39 = 1 or not(var283 = 1
)) and (var42 = 1 or not(var283 = 1)) and (var43 = 1 or not(var283 = 1)) and (
var45 = 1 or not(var283 = 1)) and (var48 = 1 or not(var283 = 1)) and (var49 = 1
or not(var284 = 1)) and (var52 = 1 or not(var284 = 1)) and (var54 = 1 or not(
var284 = 1)) and (var55 = 1 or not(var284 = 1)) and (var58 = 1 or not(var284 = 1
)) and (var59 = 1 or not(var284 = 1)) and (var61 = 1 or not(var284 = 1)) and (
var64 = 1 or not(var284 = 1)) and (var65 = 1 or not(var285 = 1)) and (var68 = 1
or not(var285 = 1)) and (var70 = 1 or not(var285 = 1)) and (var71 = 1 or not(
var285 = 1)) and (var74 = 1 or not(var285 = 1)) and (var75 = 1 or not(var285 = 1
)) and (var77 = 1 or not(var285 = 1)) and (var80 = 1 or not(var285 = 1)) and (
var81 = 1 or not(var286 = 1)) and (var84 = 1 or not(var286 = 1)) and (var86 = 1
or not(var286 = 1)) and (var87 = 1 or not(var286 = 1)) and (var90 = 1 or not(
var286 = 1)) and (var91 = 1 or not(var286 = 1)) and (var93 = 1 or not(var286 = 1
)) and (var96 = 1 or not(var286 = 1)) and (var97 = 1 or not(var287 = 1)) and (
var100 = 1 or not(var287 = 1)) and (var102 = 1 or not(var287 = 1)) and (var103 =
 1 or not(var287 = 1)) and (var106 = 1 or not(var287 = 1)) and (var107 = 1 or
not(var287 = 1)) and (var109 = 1 or not(var287 = 1)) and (var112 = 1 or not(
var287 = 1)) and (var113 = 1 or not(var288 = 1)) and (var116 = 1 or not(var288 =
 1)) and (var118 = 1 or not(var288 = 1)) and (var119 = 1 or not(var288 = 1)) and
 (var122 = 1 or not(var288 = 1)) and (var123 = 1 or not(var288 = 1)) and (var125
 = 1 or not(var288 = 1)) and (var128 = 1 or not(var288 = 1)) and (var129 = 1 or
not(var289 = 1)) and (var132 = 1 or not(var289 = 1)) and (var134 = 1 or not(
var289 = 1)) and (var135 = 1 or not(var289 = 1)) and (var138 = 1 or not(var289 =
 1)) and (var139 = 1 or not(var289 = 1)) and (var141 = 1 or not(var289 = 1)) and
 (var144 = 1 or not(var289 = 1)) and (var145 = 1 or not(var290 = 1)) and (var148
 = 1 or not(var290 = 1)) and (var150 = 1 or not(var290 = 1)) and (var151 = 1 or
not(var290 = 1)) and (var154 = 1 or not(var290 = 1)) and (var155 = 1 or not(
var290 = 1)) and (var157 = 1 or not(var290 = 1)) and (var160 = 1 or not(var290 =
 1)) and (var1 = 1 or not(var291 = 1)) and (var4 = 1 or not(var291 = 1)) and (
var6 = 1 or not(var291 = 1)) and (var8 = 1 or not(var291 = 1)) and (var10 = 1 or
 not(var291 = 1)) and (var12 = 1 or not(var291 = 1)) and (var13 = 1 or not(
var291 = 1)) and (var16 = 1 or not(var291 = 1)) and (var17 = 1 or not(var292 = 1
)) and (var20 = 1 or not(var292 = 1)) and (var22 = 1 or not(var292 = 1)) and (
var24 = 1 or not(var292 = 1)) and (var26 = 1 or not(var292 = 1)) and (var28 = 1
or not(var292 = 1)) and (var29 = 1 or not(var292 = 1)) and (var32 = 1 or not(
var292 = 1)) and (var33 = 1 or not(var293 = 1)) and (var36 = 1 or not(var293 = 1
)) and (var38 = 1 or not(var293 = 1)) and (var40 = 1 or not(var293 = 1)) and (
var42 = 1 or not(var293 = 1)) and (var44 = 1 or not(var293 = 1)) and (var45 = 1
or not(var293 = 1)) and (var48 = 1 or not(var293 = 1)) and (var49 = 1 or not(
var294 = 1)) and (var52 = 1 or not(var294 = 1)) and (var54 = 1 or not(var294 = 1
)) and (var56 = 1 or not(var294 = 1)) and (var58 = 1 or not(var294 = 1)) and (
var60 = 1 or not(var294 = 1)) and (var61 = 1 or not(var294 = 1)) and (var64 = 1
or not(var294 = 1)) and (var65 = 1 or not(var295 = 1)) and (var68 = 1 or not(
var295 = 1)) and (var70 = 1 or not(var295 = 1)) and (var72 = 1 or not(var295 = 1
)) and (var74 = 1 or not(var295 = 1)) and (var76 = 1 or not(var295 = 1)) and (
var77 = 1 or not(var295 = 1)) and (var80 = 1 or not(var295 = 1)) and (var81 = 1
or not(var296 = 1)) and (var84 = 1 or not(var296 = 1)) and (var86 = 1 or not(
var296 = 1)) and (var88 = 1 or not(var296 = 1)) and (var90 = 1 or not(var296 = 1
)) and (var92 = 1 or not(var296 = 1)) and (var93 = 1 or not(var296 = 1)) and (
var96 = 1 or not(var296 = 1)) and (var97 = 1 or not(var297 = 1)) and (var100 = 1
 or not(var297 = 1)) and (var102 = 1 or not(var297 = 1)) and (var104 = 1 or not(
var297 = 1)) and (var106 = 1 or not(var297 = 1)) and (var108 = 1 or not(var297 =
 1)) and (var109 = 1 or not(var297 = 1)) and (var112 = 1 or not(var297 = 1)) and
 (var113 = 1 or not(var298 = 1)) and (var116 = 1 or not(var298 = 1)) and (var118
 = 1 or not(var298 = 1)) and (var120 = 1 or not(var298 = 1)) and (var122 = 1 or
not(var298 = 1)) and (var124 = 1 or not(var298 = 1)) and (var125 = 1 or not(
var298 = 1)) and (var128 = 1 or not(var298 = 1)) and (var129 = 1 or not(var299 =
 1)) and (var132 = 1 or not(var299 = 1)) and (var134 = 1 or not(var299 = 1)) and
 (var136 = 1 or not(var299 = 1)) and (var138 = 1 or not(var299 = 1)) and (var140
 = 1 or not(var299 = 1)) and (var141 = 1 or not(var299 = 1)) and (var144 = 1 or
not(var299 = 1)) and (var145 = 1 or not(var300 = 1)) and (var148 = 1 or not(
var300 = 1)) and (var150 = 1 or not(var300 = 1)) and (var152 = 1 or not(var300 =
 1)) and (var154 = 1 or not(var300 = 1)) and (var156 = 1 or not(var300 = 1)) and
 (var157 = 1 or not(var300 = 1)) and (var160 = 1 or not(var300 = 1)) and (var1 =
 1 or not(var301 = 1)) and (var3 = 1 or not(var301 = 1)) and (var5 = 1 or not(
var301 = 1)) and (var8 = 1 or not(var301 = 1)) and (var9 = 1 or not(var301 = 1))
 and (var11 = 1 or not(var301 = 1)) and (var14 = 1 or not(var301 = 1)) and (
var16 = 1 or not(var301 = 1)) and (var17 = 1 or not(var302 = 1)) and (var19 = 1
or not(var302 = 1)) and (var21 = 1 or not(var302 = 1)) and (var24 = 1 or not(
var302 = 1)) and (var25 = 1 or not(var302 = 1)) and (var27 = 1 or not(var302 = 1
)) and (var30 = 1 or not(var302 = 1)) and (var32 = 1 or not(var302 = 1)) and (
var33 = 1 or not(var303 = 1)) and (var35 = 1 or not(var303 = 1)) and (var37 = 1
or not(var303 = 1)) and (var40 = 1 or not(var303 = 1)) and (var41 = 1 or not(
var303 = 1)) and (var43 = 1 or not(var303 = 1)) and (var46 = 1 or not(var303 = 1
)) and (var48 = 1 or not(var303 = 1)) and (var49 = 1 or not(var304 = 1)) and (
var51 = 1 or not(var304 = 1)) and (var53 = 1 or not(var304 = 1)) and (var56 = 1
or not(var304 = 1)) and (var57 = 1 or not(var304 = 1)) and (var59 = 1 or not(
var304 = 1)) and (var62 = 1 or not(var304 = 1)) and (var64 = 1 or not(var304 = 1
)) and (var65 = 1 or not(var305 = 1)) and (var67 = 1 or not(var305 = 1)) and (
var69 = 1 or not(var305 = 1)) and (var72 = 1 or not(var305 = 1)) and (var73 = 1
or not(var305 = 1)) and (var75 = 1 or not(var305 = 1)) and (var78 = 1 or not(
var305 = 1)) and (var80 = 1 or not(var305 = 1)) and (var81 = 1 or not(var306 = 1
)) and (var83 = 1 or not(var306 = 1)) and (var85 = 1 or not(var306 = 1)) and (
var88 = 1 or not(var306 = 1)) and (var89 = 1 or not(var306 = 1)) and (var91 = 1
or not(var306 = 1)) and (var94 = 1 or not(var306 = 1)) and (var96 = 1 or not(
var306 = 1)) and (var97 = 1 or not(var307 = 1)) and (var99 = 1 or not(var307 = 1
)) and (var101 = 1 or not(var307 = 1)) and (var104 = 1 or not(var307 = 1)) and (
var105 = 1 or not(var307 = 1)) and (var107 = 1 or not(var307 = 1)) and (var110 =
 1 or not(var307 = 1)) and (var112 = 1 or not(var307 = 1)) and (var113 = 1 or
not(var308 = 1)) and (var115 = 1 or not(var308 = 1)) and (var117 = 1 or not(
var308 = 1)) and (var120 = 1 or not(var308 = 1)) and (var121 = 1 or not(var308 =
 1)) and (var123 = 1 or not(var308 = 1)) and (var126 = 1 or not(var308 = 1)) and
 (var128 = 1 or not(var308 = 1)) and (var129 = 1 or not(var309 = 1)) and (var131
 = 1 or not(var309 = 1)) and (var133 = 1 or not(var309 = 1)) and (var136 = 1 or
not(var309 = 1)) and (var137 = 1 or not(var309 = 1)) and (var139 = 1 or not(
var309 = 1)) and (var142 = 1 or not(var309 = 1)) and (var144 = 1 or not(var309 =
 1)) and (var145 = 1 or not(var310 = 1)) and (var147 = 1 or not(var310 = 1)) and
 (var149 = 1 or not(var310 = 1)) and (var152 = 1 or not(var310 = 1)) and (var153
 = 1 or not(var310 = 1)) and (var155 = 1 or not(var310 = 1)) and (var158 = 1 or
not(var310 = 1)) and (var160 = 1 or not(var310 = 1)) and (var2 = 1 or not(var311
 = 1)) and (var4 = 1 or not(var311 = 1)) and (var5 = 1 or not(var311 = 1)) and (
var8 = 1 or not(var311 = 1)) and (var9 = 1 or not(var311 = 1)) and (var11 = 1 or
 not(var311 = 1)) and (var14 = 1 or not(var311 = 1)) and (var16 = 1 or not(
var311 = 1)) and (var18 = 1 or not(var312 = 1)) and (var20 = 1 or not(var312 = 1
)) and (var21 = 1 or not(var312 = 1)) and (var24 = 1 or not(var312 = 1)) and (
var25 = 1 or not(var312 = 1)) and (var27 = 1 or not(var312 = 1)) and (var30 = 1
or not(var312 = 1)) and (var32 = 1 or not(var312 = 1)) and (var34 = 1 or not(
var313 = 1)) and (var36 = 1 or not(var313 = 1)) and (var37 = 1 or not(var313 = 1
)) and (var40 = 1 or not(var313 = 1)) and (var41 = 1 or not(var313 = 1)) and (
var43 = 1 or not(var313 = 1)) and (var46 = 1 or not(var313 = 1)) and (var48 = 1
or not(var313 = 1)) and (var50 = 1 or not(var314 = 1)) and (var52 = 1 or not(
var314 = 1)) and (var53 = 1 or not(var314 = 1)) and (var56 = 1 or not(var314 = 1
)) and (var57 = 1 or not(var314 = 1)) and (var59 = 1 or not(var314 = 1)) and (
var62 = 1 or not(var314 = 1)) and (var64 = 1 or not(var314 = 1)) and (var66 = 1
or not(var315 = 1)) and (var68 = 1 or not(var315 = 1)) and (var69 = 1 or not(
var315 = 1)) and (var72 = 1 or not(var315 = 1)) and (var73 = 1 or not(var315 = 1
)) and (var75 = 1 or not(var315 = 1)) and (var78 = 1 or not(var315 = 1)) and (
var80 = 1 or not(var315 = 1)) and (var82 = 1 or not(var316 = 1)) and (var84 = 1
or not(var316 = 1)) and (var85 = 1 or not(var316 = 1)) and (var88 = 1 or not(
var316 = 1)) and (var89 = 1 or not(var316 = 1)) and (var91 = 1 or not(var316 = 1
)) and (var94 = 1 or not(var316 = 1)) and (var96 = 1 or not(var316 = 1)) and (
var98 = 1 or not(var317 = 1)) and (var100 = 1 or not(var317 = 1)) and (var101 =
1 or not(var317 = 1)) and (var104 = 1 or not(var317 = 1)) and (var105 = 1 or not
(var317 = 1)) and (var107 = 1 or not(var317 = 1)) and (var110 = 1 or not(var317
= 1)) and (var112 = 1 or not(var317 = 1)) and (var114 = 1 or not(var318 = 1))
and (var116 = 1 or not(var318 = 1)) and (var117 = 1 or not(var318 = 1)) and (
var120 = 1 or not(var318 = 1)) and (var121 = 1 or not(var318 = 1)) and (var123 =
 1 or not(var318 = 1)) and (var126 = 1 or not(var318 = 1)) and (var128 = 1 or
not(var318 = 1)) and (var130 = 1 or not(var319 = 1)) and (var132 = 1 or not(
var319 = 1)) and (var133 = 1 or not(var319 = 1)) and (var136 = 1 or not(var319 =
 1)) and (var137 = 1 or not(var319 = 1)) and (var139 = 1 or not(var319 = 1)) and
 (var142 = 1 or not(var319 = 1)) and (var144 = 1 or not(var319 = 1)) and (var146
 = 1 or not(var320 = 1)) and (var148 = 1 or not(var320 = 1)) and (var149 = 1 or
not(var320 = 1)) and (var152 = 1 or not(var320 = 1)) and (var153 = 1 or not(
var320 = 1)) and (var155 = 1 or not(var320 = 1)) and (var158 = 1 or not(var320 =
 1)) and (var160 = 1 or not(var320 = 1)) and (var1 = 1 or not(var321 = 1)) and (
var4 = 1 or not(var321 = 1)) and (var5 = 1 or not(var321 = 1)) and (var7 = 1 or
not(var321 = 1)) and (var10 = 1 or not(var321 = 1)) and (var11 = 1 or not(var321
 = 1)) and (var14 = 1 or not(var321 = 1)) and (var16 = 1 or not(var321 = 1)) and
 (var17 = 1 or not(var322 = 1)) and (var20 = 1 or not(var322 = 1)) and (var21 =
1 or not(var322 = 1)) and (var23 = 1 or not(var322 = 1)) and (var26 = 1 or not(
var322 = 1)) and (var27 = 1 or not(var322 = 1)) and (var30 = 1 or not(var322 = 1
)) and (var32 = 1 or not(var322 = 1)) and (var33 = 1 or not(var323 = 1)) and (
var36 = 1 or not(var323 = 1)) and (var37 = 1 or not(var323 = 1)) and (var39 = 1
or not(var323 = 1)) and (var42 = 1 or not(var323 = 1)) and (var43 = 1 or not(
var323 = 1)) and (var46 = 1 or not(var323 = 1)) and (var48 = 1 or not(var323 = 1
)) and (var49 = 1 or not(var324 = 1)) and (var52 = 1 or not(var324 = 1)) and (
var53 = 1 or not(var324 = 1)) and (var55 = 1 or not(var324 = 1)) and (var58 = 1
or not(var324 = 1)) and (var59 = 1 or not(var324 = 1)) and (var62 = 1 or not(
var324 = 1)) and (var64 = 1 or not(var324 = 1)) and (var65 = 1 or not(var325 = 1
)) and (var68 = 1 or not(var325 = 1)) and (var69 = 1 or not(var325 = 1)) and (
var71 = 1 or not(var325 = 1)) and (var74 = 1 or not(var325 = 1)) and (var75 = 1
or not(var325 = 1)) and (var78 = 1 or not(var325 = 1)) and (var80 = 1 or not(
var325 = 1)) and (var81 = 1 or not(var326 = 1)) and (var84 = 1 or not(var326 = 1
)) and (var85 = 1 or not(var326 = 1)) and (var87 = 1 or not(var326 = 1)) and (
var90 = 1 or not(var326 = 1)) and (var91 = 1 or not(var326 = 1)) and (var94 = 1
or not(var326 = 1)) and (var96 = 1 or not(var326 = 1)) and (var97 = 1 or not(
var327 = 1)) and (var100 = 1 or not(var327 = 1)) and (var101 = 1 or not(var327 =
 1)) and (var103 = 1 or not(var327 = 1)) and (var106 = 1 or not(var327 = 1)) and
 (var107 = 1 or not(var327 = 1)) and (var110 = 1 or not(var327 = 1)) and (var112
 = 1 or not(var327 = 1)) and (var113 = 1 or not(var328 = 1)) and (var116 = 1 or
not(var328 = 1)) and (var117 = 1 or not(var328 = 1)) and (var119 = 1 or not(
var328 = 1)) and (var122 = 1 or not(var328 = 1)) and (var123 = 1 or not(var328 =
 1)) and (var126 = 1 or not(var328 = 1)) and (var128 = 1 or not(var328 = 1)) and
 (var129 = 1 or not(var329 = 1)) and (var132 = 1 or not(var329 = 1)) and (var133
 = 1 or not(var329 = 1)) and (var135 = 1 or not(var329 = 1)) and (var138 = 1 or
not(var329 = 1)) and (var139 = 1 or not(var329 = 1)) and (var142 = 1 or not(
var329 = 1)) and (var144 = 1 or not(var329 = 1)) and (var145 = 1 or not(var330 =
 1)) and (var148 = 1 or not(var330 = 1)) and (var149 = 1 or not(var330 = 1)) and
 (var151 = 1 or not(var330 = 1)) and (var154 = 1 or not(var330 = 1)) and (var155
 = 1 or not(var330 = 1)) and (var158 = 1 or not(var330 = 1)) and (var160 = 1 or
not(var330 = 1)) and (var2 = 1 or not(var331 = 1)) and (var4 = 1 or not(var331 =
 1)) and (var6 = 1 or not(var331 = 1)) and (var7 = 1 or not(var331 = 1)) and (
var9 = 1 or not(var331 = 1)) and (var11 = 1 or not(var331 = 1)) and (var14 = 1
or not(var331 = 1)) and (var16 = 1 or not(var331 = 1)) and (var18 = 1 or not(
var332 = 1)) and (var20 = 1 or not(var332 = 1)) and (var22 = 1 or not(var332 = 1
)) and (var23 = 1 or not(var332 = 1)) and (var25 = 1 or not(var332 = 1)) and (
var27 = 1 or not(var332 = 1)) and (var30 = 1 or not(var332 = 1)) and (var32 = 1
or not(var332 = 1)) and (var34 = 1 or not(var333 = 1)) and (var36 = 1 or not(
var333 = 1)) and (var38 = 1 or not(var333 = 1)) and (var39 = 1 or not(var333 = 1
)) and (var41 = 1 or not(var333 = 1)) and (var43 = 1 or not(var333 = 1)) and (
var46 = 1 or not(var333 = 1)) and (var48 = 1 or not(var333 = 1)) and (var50 = 1
or not(var334 = 1)) and (var52 = 1 or not(var334 = 1)) and (var54 = 1 or not(
var334 = 1)) and (var55 = 1 or not(var334 = 1)) and (var57 = 1 or not(var334 = 1
)) and (var59 = 1 or not(var334 = 1)) and (var62 = 1 or not(var334 = 1)) and (
var64 = 1 or not(var334 = 1)) and (var66 = 1 or not(var335 = 1)) and (var68 = 1
or not(var335 = 1)) and (var70 = 1 or not(var335 = 1)) and (var71 = 1 or not(
var335 = 1)) and (var73 = 1 or not(var335 = 1)) and (var75 = 1 or not(var335 = 1
)) and (var78 = 1 or not(var335 = 1)) and (var80 = 1 or not(var335 = 1)) and (
var82 = 1 or not(var336 = 1)) and (var84 = 1 or not(var336 = 1)) and (var86 = 1
or not(var336 = 1)) and (var87 = 1 or not(var336 = 1)) and (var89 = 1 or not(
var336 = 1)) and (var91 = 1 or not(var336 = 1)) and (var94 = 1 or not(var336 = 1
)) and (var96 = 1 or not(var336 = 1)) and (var98 = 1 or not(var337 = 1)) and (
var100 = 1 or not(var337 = 1)) and (var102 = 1 or not(var337 = 1)) and (var103 =
 1 or not(var337 = 1)) and (var105 = 1 or not(var337 = 1)) and (var107 = 1 or
not(var337 = 1)) and (var110 = 1 or not(var337 = 1)) and (var112 = 1 or not(
var337 = 1)) and (var114 = 1 or not(var338 = 1)) and (var116 = 1 or not(var338 =
 1)) and (var118 = 1 or not(var338 = 1)) and (var119 = 1 or not(var338 = 1)) and
 (var121 = 1 or not(var338 = 1)) and (var123 = 1 or not(var338 = 1)) and (var126
 = 1 or not(var338 = 1)) and (var128 = 1 or not(var338 = 1)) and (var130 = 1 or
not(var339 = 1)) and (var132 = 1 or not(var339 = 1)) and (var134 = 1 or not(
var339 = 1)) and (var135 = 1 or not(var339 = 1)) and (var137 = 1 or not(var339 =
 1)) and (var139 = 1 or not(var339 = 1)) and (var142 = 1 or not(var339 = 1)) and
 (var144 = 1 or not(var339 = 1)) and (var146 = 1 or not(var340 = 1)) and (var148
 = 1 or not(var340 = 1)) and (var150 = 1 or not(var340 = 1)) and (var151 = 1 or
not(var340 = 1)) and (var153 = 1 or not(var340 = 1)) and (var155 = 1 or not(
var340 = 1)) and (var158 = 1 or not(var340 = 1)) and (var160 = 1 or not(var340 =
 1)) and (var1 = 1 or not(var341 = 1)) and (var3 = 1 or not(var341 = 1)) and (
var5 = 1 or not(var341 = 1)) and (var7 = 1 or not(var341 = 1)) and (var9 = 1 or
not(var341 = 1)) and (var12 = 1 or not(var341 = 1)) and (var14 = 1 or not(var341
 = 1)) and (var16 = 1 or not(var341 = 1)) and (var17 = 1 or not(var342 = 1)) and
 (var19 = 1 or not(var342 = 1)) and (var21 = 1 or not(var342 = 1)) and (var23 =
1 or not(var342 = 1)) and (var25 = 1 or not(var342 = 1)) and (var28 = 1 or not(
var342 = 1)) and (var30 = 1 or not(var342 = 1)) and (var32 = 1 or not(var342 = 1
)) and (var33 = 1 or not(var343 = 1)) and (var35 = 1 or not(var343 = 1)) and (
var37 = 1 or not(var343 = 1)) and (var39 = 1 or not(var343 = 1)) and (var41 = 1
or not(var343 = 1)) and (var44 = 1 or not(var343 = 1)) and (var46 = 1 or not(
var343 = 1)) and (var48 = 1 or not(var343 = 1)) and (var49 = 1 or not(var344 = 1
)) and (var51 = 1 or not(var344 = 1)) and (var53 = 1 or not(var344 = 1)) and (
var55 = 1 or not(var344 = 1)) and (var57 = 1 or not(var344 = 1)) and (var60 = 1
or not(var344 = 1)) and (var62 = 1 or not(var344 = 1)) and (var64 = 1 or not(
var344 = 1)) and (var65 = 1 or not(var345 = 1)) and (var67 = 1 or not(var345 = 1
)) and (var69 = 1 or not(var345 = 1)) and (var71 = 1 or not(var345 = 1)) and (
var73 = 1 or not(var345 = 1)) and (var76 = 1 or not(var345 = 1)) and (var78 = 1
or not(var345 = 1)) and (var80 = 1 or not(var345 = 1)) and (var81 = 1 or not(
var346 = 1)) and (var83 = 1 or not(var346 = 1)) and (var85 = 1 or not(var346 = 1
)) and (var87 = 1 or not(var346 = 1)) and (var89 = 1 or not(var346 = 1)) and (
var92 = 1 or not(var346 = 1)) and (var94 = 1 or not(var346 = 1)) and (var96 = 1
or not(var346 = 1)) and (var97 = 1 or not(var347 = 1)) and (var99 = 1 or not(
var347 = 1)) and (var101 = 1 or not(var347 = 1)) and (var103 = 1 or not(var347 =
 1)) and (var105 = 1 or not(var347 = 1)) and (var108 = 1 or not(var347 = 1)) and
 (var110 = 1 or not(var347 = 1)) and (var112 = 1 or not(var347 = 1)) and (var113
 = 1 or not(var348 = 1)) and (var115 = 1 or not(var348 = 1)) and (var117 = 1 or
not(var348 = 1)) and (var119 = 1 or not(var348 = 1)) and (var121 = 1 or not(
var348 = 1)) and (var124 = 1 or not(var348 = 1)) and (var126 = 1 or not(var348 =
 1)) and (var128 = 1 or not(var348 = 1)) and (var129 = 1 or not(var349 = 1)) and
 (var131 = 1 or not(var349 = 1)) and (var133 = 1 or not(var349 = 1)) and (var135
 = 1 or not(var349 = 1)) and (var137 = 1 or not(var349 = 1)) and (var140 = 1 or
not(var349 = 1)) and (var142 = 1 or not(var349 = 1)) and (var144 = 1 or not(
var349 = 1)) and (var145 = 1 or not(var350 = 1)) and (var147 = 1 or not(var350 =
 1)) and (var149 = 1 or not(var350 = 1)) and (var151 = 1 or not(var350 = 1)) and
 (var153 = 1 or not(var350 = 1)) and (var156 = 1 or not(var350 = 1)) and (var158
 = 1 or not(var350 = 1)) and (var160 = 1 or not(var350 = 1)) and (var2 = 1 or
not(var351 = 1)) and (var3 = 1 or not(var351 = 1)) and (var5 = 1 or not(var351 =
 1)) and (var8 = 1 or not(var351 = 1)) and (var9 = 1 or not(var351 = 1)) and (
var12 = 1 or not(var351 = 1)) and (var14 = 1 or not(var351 = 1)) and (var16 = 1
or not(var351 = 1)) and (var18 = 1 or not(var352 = 1)) and (var19 = 1 or not(
var352 = 1)) and (var21 = 1 or not(var352 = 1)) and (var24 = 1 or not(var352 = 1
)) and (var25 = 1 or not(var352 = 1)) and (var28 = 1 or not(var352 = 1)) and (
var30 = 1 or not(var352 = 1)) and (var32 = 1 or not(var352 = 1)) and (var34 = 1
or not(var353 = 1)) and (var35 = 1 or not(var353 = 1)) and (var37 = 1 or not(
var353 = 1)) and (var40 = 1 or not(var353 = 1)) and (var41 = 1 or not(var353 = 1
)) and (var44 = 1 or not(var353 = 1)) and (var46 = 1 or not(var353 = 1)) and (
var48 = 1 or not(var353 = 1)) and (var50 = 1 or not(var354 = 1)) and (var51 = 1
or not(var354 = 1)) and (var53 = 1 or not(var354 = 1)) and (var56 = 1 or not(
var354 = 1)) and (var57 = 1 or not(var354 = 1)) and (var60 = 1 or not(var354 = 1
)) and (var62 = 1 or not(var354 = 1)) and (var64 = 1 or not(var354 = 1)) and (
var66 = 1 or not(var355 = 1)) and (var67 = 1 or not(var355 = 1)) and (var69 = 1
or not(var355 = 1)) and (var72 = 1 or not(var355 = 1)) and (var73 = 1 or not(
var355 = 1)) and (var76 = 1 or not(var355 = 1)) and (var78 = 1 or not(var355 = 1
)) and (var80 = 1 or not(var355 = 1)) and (var82 = 1 or not(var356 = 1)) and (
var83 = 1 or not(var356 = 1)) and (var85 = 1 or not(var356 = 1)) and (var88 = 1
or not(var356 = 1)) and (var89 = 1 or not(var356 = 1)) and (var92 = 1 or not(
var356 = 1)) and (var94 = 1 or not(var356 = 1)) and (var96 = 1 or not(var356 = 1
)) and (var98 = 1 or not(var357 = 1)) and (var99 = 1 or not(var357 = 1)) and (
var101 = 1 or not(var357 = 1)) and (var104 = 1 or not(var357 = 1)) and (var105 =
 1 or not(var357 = 1)) and (var108 = 1 or not(var357 = 1)) and (var110 = 1 or
not(var357 = 1)) and (var112 = 1 or not(var357 = 1)) and (var114 = 1 or not(
var358 = 1)) and (var115 = 1 or not(var358 = 1)) and (var117 = 1 or not(var358 =
 1)) and (var120 = 1 or not(var358 = 1)) and (var121 = 1 or not(var358 = 1)) and
 (var124 = 1 or not(var358 = 1)) and (var126 = 1 or not(var358 = 1)) and (var128
 = 1 or not(var358 = 1)) and (var130 = 1 or not(var359 = 1)) and (var131 = 1 or
not(var359 = 1)) and (var133 = 1 or not(var359 = 1)) and (var136 = 1 or not(
var359 = 1)) and (var137 = 1 or not(var359 = 1)) and (var140 = 1 or not(var359 =
 1)) and (var142 = 1 or not(var359 = 1)) and (var144 = 1 or not(var359 = 1)) and
 (var146 = 1 or not(var360 = 1)) and (var147 = 1 or not(var360 = 1)) and (var149
 = 1 or not(var360 = 1)) and (var152 = 1 or not(var360 = 1)) and (var153 = 1 or
not(var360 = 1)) and (var156 = 1 or not(var360 = 1)) and (var158 = 1 or not(
var360 = 1)) and (var160 = 1 or not(var360 = 1)) and (var2 = 1 or not(var361 = 1
)) and (var3 = 1 or not(var361 = 1)) and (var6 = 1 or not(var361 = 1)) and (var8
 = 1 or not(var361 = 1)) and (var10 = 1 or not(var361 = 1)) and (var12 = 1 or
not(var361 = 1)) and (var13 = 1 or not(var361 = 1)) and (var16 = 1 or not(var361
 = 1)) and (var18 = 1 or not(var362 = 1)) and (var19 = 1 or not(var362 = 1)) and
 (var22 = 1 or not(var362 = 1)) and (var24 = 1 or not(var362 = 1)) and (var26 =
1 or not(var362 = 1)) and (var28 = 1 or not(var362 = 1)) and (var29 = 1 or not(
var362 = 1)) and (var32 = 1 or not(var362 = 1)) and (var34 = 1 or not(var363 = 1
)) and (var35 = 1 or not(var363 = 1)) and (var38 = 1 or not(var363 = 1)) and (
var40 = 1 or not(var363 = 1)) and (var42 = 1 or not(var363 = 1)) and (var44 = 1
or not(var363 = 1)) and (var45 = 1 or not(var363 = 1)) and (var48 = 1 or not(
var363 = 1)) and (var50 = 1 or not(var364 = 1)) and (var51 = 1 or not(var364 = 1
)) and (var54 = 1 or not(var364 = 1)) and (var56 = 1 or not(var364 = 1)) and (
var58 = 1 or not(var364 = 1)) and (var60 = 1 or not(var364 = 1)) and (var61 = 1
or not(var364 = 1)) and (var64 = 1 or not(var364 = 1)) and (var66 = 1 or not(
var365 = 1)) and (var67 = 1 or not(var365 = 1)) and (var70 = 1 or not(var365 = 1
)) and (var72 = 1 or not(var365 = 1)) and (var74 = 1 or not(var365 = 1)) and (
var76 = 1 or not(var365 = 1)) and (var77 = 1 or not(var365 = 1)) and (var80 = 1
or not(var365 = 1)) and (var82 = 1 or not(var366 = 1)) and (var83 = 1 or not(
var366 = 1)) and (var86 = 1 or not(var366 = 1)) and (var88 = 1 or not(var366 = 1
)) and (var90 = 1 or not(var366 = 1)) and (var92 = 1 or not(var366 = 1)) and (
var93 = 1 or not(var366 = 1)) and (var96 = 1 or not(var366 = 1)) and (var98 = 1
or not(var367 = 1)) and (var99 = 1 or not(var367 = 1)) and (var102 = 1 or not(
var367 = 1)) and (var104 = 1 or not(var367 = 1)) and (var106 = 1 or not(var367 =
 1)) and (var108 = 1 or not(var367 = 1)) and (var109 = 1 or not(var367 = 1)) and
 (var112 = 1 or not(var367 = 1)) and (var114 = 1 or not(var368 = 1)) and (var115
 = 1 or not(var368 = 1)) and (var118 = 1 or not(var368 = 1)) and (var120 = 1 or
not(var368 = 1)) and (var122 = 1 or not(var368 = 1)) and (var124 = 1 or not(
var368 = 1)) and (var125 = 1 or not(var368 = 1)) and (var128 = 1 or not(var368 =
 1)) and (var130 = 1 or not(var369 = 1)) and (var131 = 1 or not(var369 = 1)) and
 (var134 = 1 or not(var369 = 1)) and (var136 = 1 or not(var369 = 1)) and (var138
 = 1 or not(var369 = 1)) and (var140 = 1 or not(var369 = 1)) and (var141 = 1 or
not(var369 = 1)) and (var144 = 1 or not(var369 = 1)) and (var146 = 1 or not(
var370 = 1)) and (var147 = 1 or not(var370 = 1)) and (var150 = 1 or not(var370 =
 1)) and (var152 = 1 or not(var370 = 1)) and (var154 = 1 or not(var370 = 1)) and
 (var156 = 1 or not(var370 = 1)) and (var157 = 1 or not(var370 = 1)) and (var160
 = 1 or not(var370 = 1)) and (var2 = 1 or not(var371 = 1)) and (var3 = 1 or not(
var371 = 1)) and (var6 = 1 or not(var371 = 1)) and (var7 = 1 or not(var371 = 1))
 and (var9 = 1 or not(var371 = 1)) and (var12 = 1 or not(var371 = 1)) and (var14
 = 1 or not(var371 = 1)) and (var16 = 1 or not(var371 = 1)) and (var18 = 1 or
not(var372 = 1)) and (var19 = 1 or not(var372 = 1)) and (var22 = 1 or not(var372
 = 1)) and (var23 = 1 or not(var372 = 1)) and (var25 = 1 or not(var372 = 1)) and
 (var28 = 1 or not(var372 = 1)) and (var30 = 1 or not(var372 = 1)) and (var32 =
1 or not(var372 = 1)) and (var34 = 1 or not(var373 = 1)) and (var35 = 1 or not(
var373 = 1)) and (var38 = 1 or not(var373 = 1)) and (var39 = 1 or not(var373 = 1
)) and (var41 = 1 or not(var373 = 1)) and (var44 = 1 or not(var373 = 1)) and (
var46 = 1 or not(var373 = 1)) and (var48 = 1 or not(var373 = 1)) and (var50 = 1
or not(var374 = 1)) and (var51 = 1 or not(var374 = 1)) and (var54 = 1 or not(
var374 = 1)) and (var55 = 1 or not(var374 = 1)) and (var57 = 1 or not(var374 = 1
)) and (var60 = 1 or not(var374 = 1)) and (var62 = 1 or not(var374 = 1)) and (
var64 = 1 or not(var374 = 1)) and (var66 = 1 or not(var375 = 1)) and (var67 = 1
or not(var375 = 1)) and (var70 = 1 or not(var375 = 1)) and (var71 = 1 or not(
var375 = 1)) and (var73 = 1 or not(var375 = 1)) and (var76 = 1 or not(var375 = 1
)) and (var78 = 1 or not(var375 = 1)) and (var80 = 1 or not(var375 = 1)) and (
var82 = 1 or not(var376 = 1)) and (var83 = 1 or not(var376 = 1)) and (var86 = 1
or not(var376 = 1)) and (var87 = 1 or not(var376 = 1)) and (var89 = 1 or not(
var376 = 1)) and (var92 = 1 or not(var376 = 1)) and (var94 = 1 or not(var376 = 1
)) and (var96 = 1 or not(var376 = 1)) and (var98 = 1 or not(var377 = 1)) and (
var99 = 1 or not(var377 = 1)) and (var102 = 1 or not(var377 = 1)) and (var103 =
1 or not(var377 = 1)) and (var105 = 1 or not(var377 = 1)) and (var108 = 1 or not
(var377 = 1)) and (var110 = 1 or not(var377 = 1)) and (var112 = 1 or not(var377
= 1)) and (var114 = 1 or not(var378 = 1)) and (var115 = 1 or not(var378 = 1))
and (var118 = 1 or not(var378 = 1)) and (var119 = 1 or not(var378 = 1)) and (
var121 = 1 or not(var378 = 1)) and (var124 = 1 or not(var378 = 1)) and (var126 =
 1 or not(var378 = 1)) and (var128 = 1 or not(var378 = 1)) and (var130 = 1 or
not(var379 = 1)) and (var131 = 1 or not(var379 = 1)) and (var134 = 1 or not(
var379 = 1)) and (var135 = 1 or not(var379 = 1)) and (var137 = 1 or not(var379 =
 1)) and (var140 = 1 or not(var379 = 1)) and (var142 = 1 or not(var379 = 1)) and
 (var144 = 1 or not(var379 = 1)) and (var146 = 1 or not(var380 = 1)) and (var147
 = 1 or not(var380 = 1)) and (var150 = 1 or not(var380 = 1)) and (var151 = 1 or
not(var380 = 1)) and (var153 = 1 or not(var380 = 1)) and (var156 = 1 or not(
var380 = 1)) and (var158 = 1 or not(var380 = 1)) and (var160 = 1 or not(var380 =
 1)) and (var1 = 1 or not(var381 = 1)) and (var4 = 1 or not(var381 = 1)) and (
var5 = 1 or not(var381 = 1)) and (var8 = 1 or not(var381 = 1)) and (var10 = 1 or
 not(var381 = 1)) and (var12 = 1 or not(var381 = 1)) and (var13 = 1 or not(
var381 = 1)) and (var15 = 1 or not(var381 = 1)) and (var17 = 1 or not(var382 = 1
)) and (var20 = 1 or not(var382 = 1)) and (var21 = 1 or not(var382 = 1)) and (
var24 = 1 or not(var382 = 1)) and (var26 = 1 or not(var382 = 1)) and (var28 = 1
or not(var382 = 1)) and (var29 = 1 or not(var382 = 1)) and (var31 = 1 or not(
var382 = 1)) and (var33 = 1 or not(var383 = 1)) and (var36 = 1 or not(var383 = 1
)) and (var37 = 1 or not(var383 = 1)) and (var40 = 1 or not(var383 = 1)) and (
var42 = 1 or not(var383 = 1)) and (var44 = 1 or not(var383 = 1)) and (var45 = 1
or not(var383 = 1)) and (var47 = 1 or not(var383 = 1)) and (var49 = 1 or not(
var384 = 1)) and (var52 = 1 or not(var384 = 1)) and (var53 = 1 or not(var384 = 1
)) and (var56 = 1 or not(var384 = 1)) and (var58 = 1 or not(var384 = 1)) and (
var60 = 1 or not(var384 = 1)) and (var61 = 1 or not(var384 = 1)) and (var63 = 1
or not(var384 = 1)) and (var65 = 1 or not(var385 = 1)) and (var68 = 1 or not(
var385 = 1)) and (var69 = 1 or not(var385 = 1)) and (var72 = 1 or not(var385 = 1
)) and (var74 = 1 or not(var385 = 1)) and (var76 = 1 or not(var385 = 1)) and (
var77 = 1 or not(var385 = 1)) and (var79 = 1 or not(var385 = 1)) and (var81 = 1
or not(var386 = 1)) and (var84 = 1 or not(var386 = 1)) and (var85 = 1 or not(
var386 = 1)) and (var88 = 1 or not(var386 = 1)) and (var90 = 1 or not(var386 = 1
)) and (var92 = 1 or not(var386 = 1)) and (var93 = 1 or not(var386 = 1)) and (
var95 = 1 or not(var386 = 1)) and (var97 = 1 or not(var387 = 1)) and (var100 = 1
 or not(var387 = 1)) and (var101 = 1 or not(var387 = 1)) and (var104 = 1 or not(
var387 = 1)) and (var106 = 1 or not(var387 = 1)) and (var108 = 1 or not(var387 =
 1)) and (var109 = 1 or not(var387 = 1)) and (var111 = 1 or not(var387 = 1)) and
 (var113 = 1 or not(var388 = 1)) and (var116 = 1 or not(var388 = 1)) and (var117
 = 1 or not(var388 = 1)) and (var120 = 1 or not(var388 = 1)) and (var122 = 1 or
not(var388 = 1)) and (var124 = 1 or not(var388 = 1)) and (var125 = 1 or not(
var388 = 1)) and (var127 = 1 or not(var388 = 1)) and (var129 = 1 or not(var389 =
 1)) and (var132 = 1 or not(var389 = 1)) and (var133 = 1 or not(var389 = 1)) and
 (var136 = 1 or not(var389 = 1)) and (var138 = 1 or not(var389 = 1)) and (var140
 = 1 or not(var389 = 1)) and (var141 = 1 or not(var389 = 1)) and (var143 = 1 or
not(var389 = 1)) and (var145 = 1 or not(var390 = 1)) and (var148 = 1 or not(
var390 = 1)) and (var149 = 1 or not(var390 = 1)) and (var152 = 1 or not(var390 =
 1)) and (var154 = 1 or not(var390 = 1)) and (var156 = 1 or not(var390 = 1)) and
 (var157 = 1 or not(var390 = 1)) and (var159 = 1 or not(var390 = 1)) and (var2 =
 1 or not(var391 = 1)) and (var3 = 1 or not(var391 = 1)) and (var6 = 1 or not(
var391 = 1)) and (var7 = 1 or not(var391 = 1)) and (var10 = 1 or not(var391 = 1)
) and (var11 = 1 or not(var391 = 1)) and (var14 = 1 or not(var391 = 1)) and (
var15 = 1 or not(var391 = 1)) and (var18 = 1 or not(var392 = 1)) and (var19 = 1
or not(var392 = 1)) and (var22 = 1 or not(var392 = 1)) and (var23 = 1 or not(
var392 = 1)) and (var26 = 1 or not(var392 = 1)) and (var27 = 1 or not(var392 = 1
)) and (var30 = 1 or not(var392 = 1)) and (var31 = 1 or not(var392 = 1)) and (
var34 = 1 or not(var393 = 1)) and (var35 = 1 or not(var393 = 1)) and (var38 = 1
or not(var393 = 1)) and (var39 = 1 or not(var393 = 1)) and (var42 = 1 or not(
var393 = 1)) and (var43 = 1 or not(var393 = 1)) and (var46 = 1 or not(var393 = 1
)) and (var47 = 1 or not(var393 = 1)) and (var50 = 1 or not(var394 = 1)) and (
var51 = 1 or not(var394 = 1)) and (var54 = 1 or not(var394 = 1)) and (var55 = 1
or not(var394 = 1)) and (var58 = 1 or not(var394 = 1)) and (var59 = 1 or not(
var394 = 1)) and (var62 = 1 or not(var394 = 1)) and (var63 = 1 or not(var394 = 1
)) and (var66 = 1 or not(var395 = 1)) and (var67 = 1 or not(var395 = 1)) and (
var70 = 1 or not(var395 = 1)) and (var71 = 1 or not(var395 = 1)) and (var74 = 1
or not(var395 = 1)) and (var75 = 1 or not(var395 = 1)) and (var78 = 1 or not(
var395 = 1)) and (var79 = 1 or not(var395 = 1)) and (var82 = 1 or not(var396 = 1
)) and (var83 = 1 or not(var396 = 1)) and (var86 = 1 or not(var396 = 1)) and (
var87 = 1 or not(var396 = 1)) and (var90 = 1 or not(var396 = 1)) and (var91 = 1
or not(var396 = 1)) and (var94 = 1 or not(var396 = 1)) and (var95 = 1 or not(
var396 = 1)) and (var98 = 1 or not(var397 = 1)) and (var99 = 1 or not(var397 = 1
)) and (var102 = 1 or not(var397 = 1)) and (var103 = 1 or not(var397 = 1)) and (
var106 = 1 or not(var397 = 1)) and (var107 = 1 or not(var397 = 1)) and (var110 =
 1 or not(var397 = 1)) and (var111 = 1 or not(var397 = 1)) and (var114 = 1 or
not(var398 = 1)) and (var115 = 1 or not(var398 = 1)) and (var118 = 1 or not(
var398 = 1)) and (var119 = 1 or not(var398 = 1)) and (var122 = 1 or not(var398 =
 1)) and (var123 = 1 or not(var398 = 1)) and (var126 = 1 or not(var398 = 1)) and
 (var127 = 1 or not(var398 = 1)) and (var130 = 1 or not(var399 = 1)) and (var131
 = 1 or not(var399 = 1)) and (var134 = 1 or not(var399 = 1)) and (var135 = 1 or
not(var399 = 1)) and (var138 = 1 or not(var399 = 1)) and (var139 = 1 or not(
var399 = 1)) and (var142 = 1 or not(var399 = 1)) and (var143 = 1 or not(var399 =
 1)) and (var146 = 1 or not(var400 = 1)) and (var147 = 1 or not(var400 = 1)) and
 (var150 = 1 or not(var400 = 1)) and (var151 = 1 or not(var400 = 1)) and (var154
 = 1 or not(var400 = 1)) and (var155 = 1 or not(var400 = 1)) and (var158 = 1 or
not(var400 = 1)) and (var159 = 1 or not(var400 = 1)) and (var2 = 1 or not(var401
 = 1)) and (var3 = 1 or not(var401 = 1)) and (var5 = 1 or not(var401 = 1)) and (
var8 = 1 or not(var401 = 1)) and (var10 = 1 or not(var401 = 1)) and (var11 = 1
or not(var401 = 1)) and (var13 = 1 or not(var401 = 1)) and (var15 = 1 or not(
var401 = 1)) and (var18 = 1 or not(var402 = 1)) and (var19 = 1 or not(var402 = 1
)) and (var21 = 1 or not(var402 = 1)) and (var24 = 1 or not(var402 = 1)) and (
var26 = 1 or not(var402 = 1)) and (var27 = 1 or not(var402 = 1)) and (var29 = 1
or not(var402 = 1)) and (var31 = 1 or not(var402 = 1)) and (var34 = 1 or not(
var403 = 1)) and (var35 = 1 or not(var403 = 1)) and (var37 = 1 or not(var403 = 1
)) and (var40 = 1 or not(var403 = 1)) and (var42 = 1 or not(var403 = 1)) and (
var43 = 1 or not(var403 = 1)) and (var45 = 1 or not(var403 = 1)) and (var47 = 1
or not(var403 = 1)) and (var50 = 1 or not(var404 = 1)) and (var51 = 1 or not(
var404 = 1)) and (var53 = 1 or not(var404 = 1)) and (var56 = 1 or not(var404 = 1
)) and (var58 = 1 or not(var404 = 1)) and (var59 = 1 or not(var404 = 1)) and (
var61 = 1 or not(var404 = 1)) and (var63 = 1 or not(var404 = 1)) and (var66 = 1
or not(var405 = 1)) and (var67 = 1 or not(var405 = 1)) and (var69 = 1 or not(
var405 = 1)) and (var72 = 1 or not(var405 = 1)) and (var74 = 1 or not(var405 = 1
)) and (var75 = 1 or not(var405 = 1)) and (var77 = 1 or not(var405 = 1)) and (
var79 = 1 or not(var405 = 1)) and (var82 = 1 or not(var406 = 1)) and (var83 = 1
or not(var406 = 1)) and (var85 = 1 or not(var406 = 1)) and (var88 = 1 or not(
var406 = 1)) and (var90 = 1 or not(var406 = 1)) and (var91 = 1 or not(var406 = 1
)) and (var93 = 1 or not(var406 = 1)) and (var95 = 1 or not(var406 = 1)) and (
var98 = 1 or not(var407 = 1)) and (var99 = 1 or not(var407 = 1)) and (var101 = 1
 or not(var407 = 1)) and (var104 = 1 or not(var407 = 1)) and (var106 = 1 or not(
var407 = 1)) and (var107 = 1 or not(var407 = 1)) and (var109 = 1 or not(var407 =
 1)) and (var111 = 1 or not(var407 = 1)) and (var114 = 1 or not(var408 = 1)) and
 (var115 = 1 or not(var408 = 1)) and (var117 = 1 or not(var408 = 1)) and (var120
 = 1 or not(var408 = 1)) and (var122 = 1 or not(var408 = 1)) and (var123 = 1 or
not(var408 = 1)) and (var125 = 1 or not(var408 = 1)) and (var127 = 1 or not(
var408 = 1)) and (var130 = 1 or not(var409 = 1)) and (var131 = 1 or not(var409 =
 1)) and (var133 = 1 or not(var409 = 1)) and (var136 = 1 or not(var409 = 1)) and
 (var138 = 1 or not(var409 = 1)) and (var139 = 1 or not(var409 = 1)) and (var141
 = 1 or not(var409 = 1)) and (var143 = 1 or not(var409 = 1)) and (var146 = 1 or
not(var410 = 1)) and (var147 = 1 or not(var410 = 1)) and (var149 = 1 or not(
var410 = 1)) and (var152 = 1 or not(var410 = 1)) and (var154 = 1 or not(var410 =
 1)) and (var155 = 1 or not(var410 = 1)) and (var157 = 1 or not(var410 = 1)) and
 (var159 = 1 or not(var410 = 1)) and (var2 = 1 or not(var411 = 1)) and (var4 = 1
 or not(var411 = 1)) and (var5 = 1 or not(var411 = 1)) and (var7 = 1 or not(
var411 = 1)) and (var10 = 1 or not(var411 = 1)) and (var11 = 1 or not(var411 = 1
)) and (var14 = 1 or not(var411 = 1)) and (var16 = 1 or not(var411 = 1)) and (
var18 = 1 or not(var412 = 1)) and (var20 = 1 or not(var412 = 1)) and (var21 = 1
or not(var412 = 1)) and (var23 = 1 or not(var412 = 1)) and (var26 = 1 or not(
var412 = 1)) and (var27 = 1 or not(var412 = 1)) and (var30 = 1 or not(var412 = 1
)) and (var32 = 1 or not(var412 = 1)) and (var34 = 1 or not(var413 = 1)) and (
var36 = 1 or not(var413 = 1)) and (var37 = 1 or not(var413 = 1)) and (var39 = 1
or not(var413 = 1)) and (var42 = 1 or not(var413 = 1)) and (var43 = 1 or not(
var413 = 1)) and (var46 = 1 or not(var413 = 1)) and (var48 = 1 or not(var413 = 1
)) and (var50 = 1 or not(var414 = 1)) and (var52 = 1 or not(var414 = 1)) and (
var53 = 1 or not(var414 = 1)) and (var55 = 1 or not(var414 = 1)) and (var58 = 1
or not(var414 = 1)) and (var59 = 1 or not(var414 = 1)) and (var62 = 1 or not(
var414 = 1)) and (var64 = 1 or not(var414 = 1)) and (var66 = 1 or not(var415 = 1
)) and (var68 = 1 or not(var415 = 1)) and (var69 = 1 or not(var415 = 1)) and (
var71 = 1 or not(var415 = 1)) and (var74 = 1 or not(var415 = 1)) and (var75 = 1
or not(var415 = 1)) and (var78 = 1 or not(var415 = 1)) and (var80 = 1 or not(
var415 = 1)) and (var82 = 1 or not(var416 = 1)) and (var84 = 1 or not(var416 = 1
)) and (var85 = 1 or not(var416 = 1)) and (var87 = 1 or not(var416 = 1)) and (
var90 = 1 or not(var416 = 1)) and (var91 = 1 or not(var416 = 1)) and (var94 = 1
or not(var416 = 1)) and (var96 = 1 or not(var416 = 1)) and (var98 = 1 or not(
var417 = 1)) and (var100 = 1 or not(var417 = 1)) and (var101 = 1 or not(var417 =
 1)) and (var103 = 1 or not(var417 = 1)) and (var106 = 1 or not(var417 = 1)) and
 (var107 = 1 or not(var417 = 1)) and (var110 = 1 or not(var417 = 1)) and (var112
 = 1 or not(var417 = 1)) and (var114 = 1 or not(var418 = 1)) and (var116 = 1 or
not(var418 = 1)) and (var117 = 1 or not(var418 = 1)) and (var119 = 1 or not(
var418 = 1)) and (var122 = 1 or not(var418 = 1)) and (var123 = 1 or not(var418 =
 1)) and (var126 = 1 or not(var418 = 1)) and (var128 = 1 or not(var418 = 1)) and
 (var130 = 1 or not(var419 = 1)) and (var132 = 1 or not(var419 = 1)) and (var133
 = 1 or not(var419 = 1)) and (var135 = 1 or not(var419 = 1)) and (var138 = 1 or
not(var419 = 1)) and (var139 = 1 or not(var419 = 1)) and (var142 = 1 or not(
var419 = 1)) and (var144 = 1 or not(var419 = 1)) and (var146 = 1 or not(var420 =
 1)) and (var148 = 1 or not(var420 = 1)) and (var149 = 1 or not(var420 = 1)) and
 (var151 = 1 or not(var420 = 1)) and (var154 = 1 or not(var420 = 1)) and (var155
 = 1 or not(var420 = 1)) and (var158 = 1 or not(var420 = 1)) and (var160 = 1 or
not(var420 = 1)) and (var2 = 1 or not(var421 = 1)) and (var4 = 1 or not(var421 =
 1)) and (var6 = 1 or not(var421 = 1)) and (var7 = 1 or not(var421 = 1)) and (
var10 = 1 or not(var421 = 1)) and (var11 = 1 or not(var421 = 1)) and (var13 = 1
or not(var421 = 1)) and (var16 = 1 or not(var421 = 1)) and (var18 = 1 or not(
var422 = 1)) and (var20 = 1 or not(var422 = 1)) and (var22 = 1 or not(var422 = 1
)) and (var23 = 1 or not(var422 = 1)) and (var26 = 1 or not(var422 = 1)) and (
var27 = 1 or not(var422 = 1)) and (var29 = 1 or not(var422 = 1)) and (var32 = 1
or not(var422 = 1)) and (var34 = 1 or not(var423 = 1)) and (var36 = 1 or not(
var423 = 1)) and (var38 = 1 or not(var423 = 1)) and (var39 = 1 or not(var423 = 1
)) and (var42 = 1 or not(var423 = 1)) and (var43 = 1 or not(var423 = 1)) and (
var45 = 1 or not(var423 = 1)) and (var48 = 1 or not(var423 = 1)) and (var50 = 1
or not(var424 = 1)) and (var52 = 1 or not(var424 = 1)) and (var54 = 1 or not(
var424 = 1)) and (var55 = 1 or not(var424 = 1)) and (var58 = 1 or not(var424 = 1
)) and (var59 = 1 or not(var424 = 1)) and (var61 = 1 or not(var424 = 1)) and (
var64 = 1 or not(var424 = 1)) and (var66 = 1 or not(var425 = 1)) and (var68 = 1
or not(var425 = 1)) and (var70 = 1 or not(var425 = 1)) and (var71 = 1 or not(
var425 = 1)) and (var74 = 1 or not(var425 = 1)) and (var75 = 1 or not(var425 = 1
)) and (var77 = 1 or not(var425 = 1)) and (var80 = 1 or not(var425 = 1)) and (
var82 = 1 or not(var426 = 1)) and (var84 = 1 or not(var426 = 1)) and (var86 = 1
or not(var426 = 1)) and (var87 = 1 or not(var426 = 1)) and (var90 = 1 or not(
var426 = 1)) and (var91 = 1 or not(var426 = 1)) and (var93 = 1 or not(var426 = 1
)) and (var96 = 1 or not(var426 = 1)) and (var98 = 1 or not(var427 = 1)) and (
var100 = 1 or not(var427 = 1)) and (var102 = 1 or not(var427 = 1)) and (var103 =
 1 or not(var427 = 1)) and (var106 = 1 or not(var427 = 1)) and (var107 = 1 or
not(var427 = 1)) and (var109 = 1 or not(var427 = 1)) and (var112 = 1 or not(
var427 = 1)) and (var114 = 1 or not(var428 = 1)) and (var116 = 1 or not(var428 =
 1)) and (var118 = 1 or not(var428 = 1)) and (var119 = 1 or not(var428 = 1)) and
 (var122 = 1 or not(var428 = 1)) and (var123 = 1 or not(var428 = 1)) and (var125
 = 1 or not(var428 = 1)) and (var128 = 1 or not(var428 = 1)) and (var130 = 1 or
not(var429 = 1)) and (var132 = 1 or not(var429 = 1)) and (var134 = 1 or not(
var429 = 1)) and (var135 = 1 or not(var429 = 1)) and (var138 = 1 or not(var429 =
 1)) and (var139 = 1 or not(var429 = 1)) and (var141 = 1 or not(var429 = 1)) and
 (var144 = 1 or not(var429 = 1)) and (var146 = 1 or not(var430 = 1)) and (var148
 = 1 or not(var430 = 1)) and (var150 = 1 or not(var430 = 1)) and (var151 = 1 or
not(var430 = 1)) and (var154 = 1 or not(var430 = 1)) and (var155 = 1 or not(
var430 = 1)) and (var157 = 1 or not(var430 = 1)) and (var160 = 1 or not(var430 =
 1)) and (var1 = 1 or not(var431 = 1)) and (var3 = 1 or not(var431 = 1)) and (
var5 = 1 or not(var431 = 1)) and (var7 = 1 or not(var431 = 1)) and (var10 = 1 or
 not(var431 = 1)) and (var11 = 1 or not(var431 = 1)) and (var13 = 1 or not(
var431 = 1)) and (var16 = 1 or not(var431 = 1)) and (var17 = 1 or not(var432 = 1
)) and (var19 = 1 or not(var432 = 1)) and (var21 = 1 or not(var432 = 1)) and (
var23 = 1 or not(var432 = 1)) and (var26 = 1 or not(var432 = 1)) and (var27 = 1
or not(var432 = 1)) and (var29 = 1 or not(var432 = 1)) and (var32 = 1 or not(
var432 = 1)) and (var33 = 1 or not(var433 = 1)) and (var35 = 1 or not(var433 = 1
)) and (var37 = 1 or not(var433 = 1)) and (var39 = 1 or not(var433 = 1)) and (
var42 = 1 or not(var433 = 1)) and (var43 = 1 or not(var433 = 1)) and (var45 = 1
or not(var433 = 1)) and (var48 = 1 or not(var433 = 1)) and (var49 = 1 or not(
var434 = 1)) and (var51 = 1 or not(var434 = 1)) and (var53 = 1 or not(var434 = 1
)) and (var55 = 1 or not(var434 = 1)) and (var58 = 1 or not(var434 = 1)) and (
var59 = 1 or not(var434 = 1)) and (var61 = 1 or not(var434 = 1)) and (var64 = 1
or not(var434 = 1)) and (var65 = 1 or not(var435 = 1)) and (var67 = 1 or not(
var435 = 1)) and (var69 = 1 or not(var435 = 1)) and (var71 = 1 or not(var435 = 1
)) and (var74 = 1 or not(var435 = 1)) and (var75 = 1 or not(var435 = 1)) and (
var77 = 1 or not(var435 = 1)) and (var80 = 1 or not(var435 = 1)) and (var81 = 1
or not(var436 = 1)) and (var83 = 1 or not(var436 = 1)) and (var85 = 1 or not(
var436 = 1)) and (var87 = 1 or not(var436 = 1)) and (var90 = 1 or not(var436 = 1
)) and (var91 = 1 or not(var436 = 1)) and (var93 = 1 or not(var436 = 1)) and (
var96 = 1 or not(var436 = 1)) and (var97 = 1 or not(var437 = 1)) and (var99 = 1
or not(var437 = 1)) and (var101 = 1 or not(var437 = 1)) and (var103 = 1 or not(
var437 = 1)) and (var106 = 1 or not(var437 = 1)) and (var107 = 1 or not(var437 =
 1)) and (var109 = 1 or not(var437 = 1)) and (var112 = 1 or not(var437 = 1)) and
 (var113 = 1 or not(var438 = 1)) and (var115 = 1 or not(var438 = 1)) and (var117
 = 1 or not(var438 = 1)) and (var119 = 1 or not(var438 = 1)) and (var122 = 1 or
not(var438 = 1)) and (var123 = 1 or not(var438 = 1)) and (var125 = 1 or not(
var438 = 1)) and (var128 = 1 or not(var438 = 1)) and (var129 = 1 or not(var439 =
 1)) and (var131 = 1 or not(var439 = 1)) and (var133 = 1 or not(var439 = 1)) and
 (var135 = 1 or not(var439 = 1)) and (var138 = 1 or not(var439 = 1)) and (var139
 = 1 or not(var439 = 1)) and (var141 = 1 or not(var439 = 1)) and (var144 = 1 or
not(var439 = 1)) and (var145 = 1 or not(var440 = 1)) and (var147 = 1 or not(
var440 = 1)) and (var149 = 1 or not(var440 = 1)) and (var151 = 1 or not(var440 =
 1)) and (var154 = 1 or not(var440 = 1)) and (var155 = 1 or not(var440 = 1)) and
 (var157 = 1 or not(var440 = 1)) and (var160 = 1 or not(var440 = 1)) and (var2 =
 1 or not(var441 = 1)) and (var3 = 1 or not(var441 = 1)) and (var5 = 1 or not(
var441 = 1)) and (var8 = 1 or not(var441 = 1)) and (var10 = 1 or not(var441 = 1)
) and (var12 = 1 or not(var441 = 1)) and (var13 = 1 or not(var441 = 1)) and (
var15 = 1 or not(var441 = 1)) and (var18 = 1 or not(var442 = 1)) and (var19 = 1
or not(var442 = 1)) and (var21 = 1 or not(var442 = 1)) and (var24 = 1 or not(
var442 = 1)) and (var26 = 1 or not(var442 = 1)) and (var28 = 1 or not(var442 = 1
)) and (var29 = 1 or not(var442 = 1)) and (var31 = 1 or not(var442 = 1)) and (
var34 = 1 or not(var443 = 1)) and (var35 = 1 or not(var443 = 1)) and (var37 = 1
or not(var443 = 1)) and (var40 = 1 or not(var443 = 1)) and (var42 = 1 or not(
var443 = 1)) and (var44 = 1 or not(var443 = 1)) and (var45 = 1 or not(var443 = 1
)) and (var47 = 1 or not(var443 = 1)) and (var50 = 1 or not(var444 = 1)) and (
var51 = 1 or not(var444 = 1)) and (var53 = 1 or not(var444 = 1)) and (var56 = 1
or not(var444 = 1)) and (var58 = 1 or not(var444 = 1)) and (var60 = 1 or not(
var444 = 1)) and (var61 = 1 or not(var444 = 1)) and (var63 = 1 or not(var444 = 1
)) and (var66 = 1 or not(var445 = 1)) and (var67 = 1 or not(var445 = 1)) and (
var69 = 1 or not(var445 = 1)) and (var72 = 1 or not(var445 = 1)) and (var74 = 1
or not(var445 = 1)) and (var76 = 1 or not(var445 = 1)) and (var77 = 1 or not(
var445 = 1)) and (var79 = 1 or not(var445 = 1)) and (var82 = 1 or not(var446 = 1
)) and (var83 = 1 or not(var446 = 1)) and (var85 = 1 or not(var446 = 1)) and (
var88 = 1 or not(var446 = 1)) and (var90 = 1 or not(var446 = 1)) and (var92 = 1
or not(var446 = 1)) and (var93 = 1 or not(var446 = 1)) and (var95 = 1 or not(
var446 = 1)) and (var98 = 1 or not(var447 = 1)) and (var99 = 1 or not(var447 = 1
)) and (var101 = 1 or not(var447 = 1)) and (var104 = 1 or not(var447 = 1)) and (
var106 = 1 or not(var447 = 1)) and (var108 = 1 or not(var447 = 1)) and (var109 =
 1 or not(var447 = 1)) and (var111 = 1 or not(var447 = 1)) and (var114 = 1 or
not(var448 = 1)) and (var115 = 1 or not(var448 = 1)) and (var117 = 1 or not(
var448 = 1)) and (var120 = 1 or not(var448 = 1)) and (var122 = 1 or not(var448 =
 1)) and (var124 = 1 or not(var448 = 1)) and (var125 = 1 or not(var448 = 1)) and
 (var127 = 1 or not(var448 = 1)) and (var130 = 1 or not(var449 = 1)) and (var131
 = 1 or not(var449 = 1)) and (var133 = 1 or not(var449 = 1)) and (var136 = 1 or
not(var449 = 1)) and (var138 = 1 or not(var449 = 1)) and (var140 = 1 or not(
var449 = 1)) and (var141 = 1 or not(var449 = 1)) and (var143 = 1 or not(var449 =
 1)) and (var146 = 1 or not(var450 = 1)) and (var147 = 1 or not(var450 = 1)) and
 (var149 = 1 or not(var450 = 1)) and (var152 = 1 or not(var450 = 1)) and (var154
 = 1 or not(var450 = 1)) and (var156 = 1 or not(var450 = 1)) and (var157 = 1 or
not(var450 = 1)) and (var159 = 1 or not(var450 = 1)) and (var1 = 1 or not(var451
 = 1)) and (var3 = 1 or not(var451 = 1)) and (var6 = 1 or not(var451 = 1)) and (
var8 = 1 or not(var451 = 1)) and (var9 = 1 or not(var451 = 1)) and (var12 = 1 or
 not(var451 = 1)) and (var14 = 1 or not(var451 = 1)) and (var16 = 1 or not(
var451 = 1)) and (var17 = 1 or not(var452 = 1)) and (var19 = 1 or not(var452 = 1
)) and (var22 = 1 or not(var452 = 1)) and (var24 = 1 or not(var452 = 1)) and (
var25 = 1 or not(var452 = 1)) and (var28 = 1 or not(var452 = 1)) and (var30 = 1
or not(var452 = 1)) and (var32 = 1 or not(var452 = 1)) and (var33 = 1 or not(
var453 = 1)) and (var35 = 1 or not(var453 = 1)) and (var38 = 1 or not(var453 = 1
)) and (var40 = 1 or not(var453 = 1)) and (var41 = 1 or not(var453 = 1)) and (
var44 = 1 or not(var453 = 1)) and (var46 = 1 or not(var453 = 1)) and (var48 = 1
or not(var453 = 1)) and (var49 = 1 or not(var454 = 1)) and (var51 = 1 or not(
var454 = 1)) and (var54 = 1 or not(var454 = 1)) and (var56 = 1 or not(var454 = 1
)) and (var57 = 1 or not(var454 = 1)) and (var60 = 1 or not(var454 = 1)) and (
var62 = 1 or not(var454 = 1)) and (var64 = 1 or not(var454 = 1)) and (var65 = 1
or not(var455 = 1)) and (var67 = 1 or not(var455 = 1)) and (var70 = 1 or not(
var455 = 1)) and (var72 = 1 or not(var455 = 1)) and (var73 = 1 or not(var455 = 1
)) and (var76 = 1 or not(var455 = 1)) and (var78 = 1 or not(var455 = 1)) and (
var80 = 1 or not(var455 = 1)) and (var81 = 1 or not(var456 = 1)) and (var83 = 1
or not(var456 = 1)) and (var86 = 1 or not(var456 = 1)) and (var88 = 1 or not(
var456 = 1)) and (var89 = 1 or not(var456 = 1)) and (var92 = 1 or not(var456 = 1
)) and (var94 = 1 or not(var456 = 1)) and (var96 = 1 or not(var456 = 1)) and (
var97 = 1 or not(var457 = 1)) and (var99 = 1 or not(var457 = 1)) and (var102 = 1
 or not(var457 = 1)) and (var104 = 1 or not(var457 = 1)) and (var105 = 1 or not(
var457 = 1)) and (var108 = 1 or not(var457 = 1)) and (var110 = 1 or not(var457 =
 1)) and (var112 = 1 or not(var457 = 1)) and (var113 = 1 or not(var458 = 1)) and
 (var115 = 1 or not(var458 = 1)) and (var118 = 1 or not(var458 = 1)) and (var120
 = 1 or not(var458 = 1)) and (var121 = 1 or not(var458 = 1)) and (var124 = 1 or
not(var458 = 1)) and (var126 = 1 or not(var458 = 1)) and (var128 = 1 or not(
var458 = 1)) and (var129 = 1 or not(var459 = 1)) and (var131 = 1 or not(var459 =
 1)) and (var134 = 1 or not(var459 = 1)) and (var136 = 1 or not(var459 = 1)) and
 (var137 = 1 or not(var459 = 1)) and (var140 = 1 or not(var459 = 1)) and (var142
 = 1 or not(var459 = 1)) and (var144 = 1 or not(var459 = 1)) and (var145 = 1 or
not(var460 = 1)) and (var147 = 1 or not(var460 = 1)) and (var150 = 1 or not(
var460 = 1)) and (var152 = 1 or not(var460 = 1)) and (var153 = 1 or not(var460 =
 1)) and (var156 = 1 or not(var460 = 1)) and (var158 = 1 or not(var460 = 1)) and
 (var160 = 1 or not(var460 = 1)) and (var1 = 1 or not(var461 = 1)) and (var4 = 1
 or not(var461 = 1)) and (var6 = 1 or not(var461 = 1)) and (var8 = 1 or not(
var461 = 1)) and (var10 = 1 or not(var461 = 1)) and (var12 = 1 or not(var461 = 1
)) and (var13 = 1 or not(var461 = 1)) and (var16 = 1 or not(var461 = 1)) and (
var17 = 1 or not(var462 = 1)) and (var20 = 1 or not(var462 = 1)) and (var22 = 1
or not(var462 = 1)) and (var24 = 1 or not(var462 = 1)) and (var26 = 1 or not(
var462 = 1)) and (var28 = 1 or not(var462 = 1)) and (var29 = 1 or not(var462 = 1
)) and (var32 = 1 or not(var462 = 1)) and (var33 = 1 or not(var463 = 1)) and (
var36 = 1 or not(var463 = 1)) and (var38 = 1 or not(var463 = 1)) and (var40 = 1
or not(var463 = 1)) and (var42 = 1 or not(var463 = 1)) and (var44 = 1 or not(
var463 = 1)) and (var45 = 1 or not(var463 = 1)) and (var48 = 1 or not(var463 = 1
)) and (var49 = 1 or not(var464 = 1)) and (var52 = 1 or not(var464 = 1)) and (
var54 = 1 or not(var464 = 1)) and (var56 = 1 or not(var464 = 1)) and (var58 = 1
or not(var464 = 1)) and (var60 = 1 or not(var464 = 1)) and (var61 = 1 or not(
var464 = 1)) and (var64 = 1 or not(var464 = 1)) and (var65 = 1 or not(var465 = 1
)) and (var68 = 1 or not(var465 = 1)) and (var70 = 1 or not(var465 = 1)) and (
var72 = 1 or not(var465 = 1)) and (var74 = 1 or not(var465 = 1)) and (var76 = 1
or not(var465 = 1)) and (var77 = 1 or not(var465 = 1)) and (var80 = 1 or not(
var465 = 1)) and (var81 = 1 or not(var466 = 1)) and (var84 = 1 or not(var466 = 1
)) and (var86 = 1 or not(var466 = 1)) and (var88 = 1 or not(var466 = 1)) and (
var90 = 1 or not(var466 = 1)) and (var92 = 1 or not(var466 = 1)) and (var93 = 1
or not(var466 = 1)) and (var96 = 1 or not(var466 = 1)) and (var97 = 1 or not(
var467 = 1)) and (var100 = 1 or not(var467 = 1)) and (var102 = 1 or not(var467 =
 1)) and (var104 = 1 or not(var467 = 1)) and (var106 = 1 or not(var467 = 1)) and
 (var108 = 1 or not(var467 = 1)) and (var109 = 1 or not(var467 = 1)) and (var112
 = 1 or not(var467 = 1)) and (var113 = 1 or not(var468 = 1)) and (var116 = 1 or
not(var468 = 1)) and (var118 = 1 or not(var468 = 1)) and (var120 = 1 or not(
var468 = 1)) and (var122 = 1 or not(var468 = 1)) and (var124 = 1 or not(var468 =
 1)) and (var125 = 1 or not(var468 = 1)) and (var128 = 1 or not(var468 = 1)) and
 (var129 = 1 or not(var469 = 1)) and (var132 = 1 or not(var469 = 1)) and (var134
 = 1 or not(var469 = 1)) and (var136 = 1 or not(var469 = 1)) and (var138 = 1 or
not(var469 = 1)) and (var140 = 1 or not(var469 = 1)) and (var141 = 1 or not(
var469 = 1)) and (var144 = 1 or not(var469 = 1)) and (var145 = 1 or not(var470 =
 1)) and (var148 = 1 or not(var470 = 1)) and (var150 = 1 or not(var470 = 1)) and
 (var152 = 1 or not(var470 = 1)) and (var154 = 1 or not(var470 = 1)) and (var156
 = 1 or not(var470 = 1)) and (var157 = 1 or not(var470 = 1)) and (var160 = 1 or
not(var470 = 1)) and (var2 = 1 or not(var471 = 1)) and (var4 = 1 or not(var471 =
 1)) and (var5 = 1 or not(var471 = 1)) and (var7 = 1 or not(var471 = 1)) and (
var10 = 1 or not(var471 = 1)) and (var12 = 1 or not(var471 = 1)) and (var13 = 1
or not(var471 = 1)) and (var15 = 1 or not(var471 = 1)) and (var18 = 1 or not(
var472 = 1)) and (var20 = 1 or not(var472 = 1)) and (var21 = 1 or not(var472 = 1
)) and (var23 = 1 or not(var472 = 1)) and (var26 = 1 or not(var472 = 1)) and (
var28 = 1 or not(var472 = 1)) and (var29 = 1 or not(var472 = 1)) and (var31 = 1
or not(var472 = 1)) and (var34 = 1 or not(var473 = 1)) and (var36 = 1 or not(
var473 = 1)) and (var37 = 1 or not(var473 = 1)) and (var39 = 1 or not(var473 = 1
)) and (var42 = 1 or not(var473 = 1)) and (var44 = 1 or not(var473 = 1)) and (
var45 = 1 or not(var473 = 1)) and (var47 = 1 or not(var473 = 1)) and (var50 = 1
or not(var474 = 1)) and (var52 = 1 or not(var474 = 1)) and (var53 = 1 or not(
var474 = 1)) and (var55 = 1 or not(var474 = 1)) and (var58 = 1 or not(var474 = 1
)) and (var60 = 1 or not(var474 = 1)) and (var61 = 1 or not(var474 = 1)) and (
var63 = 1 or not(var474 = 1)) and (var66 = 1 or not(var475 = 1)) and (var68 = 1
or not(var475 = 1)) and (var69 = 1 or not(var475 = 1)) and (var71 = 1 or not(
var475 = 1)) and (var74 = 1 or not(var475 = 1)) and (var76 = 1 or not(var475 = 1
)) and (var77 = 1 or not(var475 = 1)) and (var79 = 1 or not(var475 = 1)) and (
var82 = 1 or not(var476 = 1)) and (var84 = 1 or not(var476 = 1)) and (var85 = 1
or not(var476 = 1)) and (var87 = 1 or not(var476 = 1)) and (var90 = 1 or not(
var476 = 1)) and (var92 = 1 or not(var476 = 1)) and (var93 = 1 or not(var476 = 1
)) and (var95 = 1 or not(var476 = 1)) and (var98 = 1 or not(var477 = 1)) and (
var100 = 1 or not(var477 = 1)) and (var101 = 1 or not(var477 = 1)) and (var103 =
 1 or not(var477 = 1)) and (var106 = 1 or not(var477 = 1)) and (var108 = 1 or
not(var477 = 1)) and (var109 = 1 or not(var477 = 1)) and (var111 = 1 or not(
var477 = 1)) and (var114 = 1 or not(var478 = 1)) and (var116 = 1 or not(var478 =
 1)) and (var117 = 1 or not(var478 = 1)) and (var119 = 1 or not(var478 = 1)) and
 (var122 = 1 or not(var478 = 1)) and (var124 = 1 or not(var478 = 1)) and (var125
 = 1 or not(var478 = 1)) and (var127 = 1 or not(var478 = 1)) and (var130 = 1 or
not(var479 = 1)) and (var132 = 1 or not(var479 = 1)) and (var133 = 1 or not(
var479 = 1)) and (var135 = 1 or not(var479 = 1)) and (var138 = 1 or not(var479 =
 1)) and (var140 = 1 or not(var479 = 1)) and (var141 = 1 or not(var479 = 1)) and
 (var143 = 1 or not(var479 = 1)) and (var146 = 1 or not(var480 = 1)) and (var148
 = 1 or not(var480 = 1)) and (var149 = 1 or not(var480 = 1)) and (var151 = 1 or
not(var480 = 1)) and (var154 = 1 or not(var480 = 1)) and (var156 = 1 or not(
var480 = 1)) and (var157 = 1 or not(var480 = 1)) and (var159 = 1 or not(var480 =
 1)) and (var2 = 1 or not(var481 = 1)) and (var4 = 1 or not(var481 = 1)) and (
var5 = 1 or not(var481 = 1)) and (var7 = 1 or not(var481 = 1)) and (var10 = 1 or
 not(var481 = 1)) and (var12 = 1 or not(var481 = 1)) and (var14 = 1 or not(
var481 = 1)) and (var16 = 1 or not(var481 = 1)) and (var18 = 1 or not(var482 = 1
)) and (var20 = 1 or not(var482 = 1)) and (var21 = 1 or not(var482 = 1)) and (
var23 = 1 or not(var482 = 1)) and (var26 = 1 or not(var482 = 1)) and (var28 = 1
or not(var482 = 1)) and (var30 = 1 or not(var482 = 1)) and (var32 = 1 or not(
var482 = 1)) and (var34 = 1 or not(var483 = 1)) and (var36 = 1 or not(var483 = 1
)) and (var37 = 1 or not(var483 = 1)) and (var39 = 1 or not(var483 = 1)) and (
var42 = 1 or not(var483 = 1)) and (var44 = 1 or not(var483 = 1)) and (var46 = 1
or not(var483 = 1)) and (var48 = 1 or not(var483 = 1)) and (var50 = 1 or not(
var484 = 1)) and (var52 = 1 or not(var484 = 1)) and (var53 = 1 or not(var484 = 1
)) and (var55 = 1 or not(var484 = 1)) and (var58 = 1 or not(var484 = 1)) and (
var60 = 1 or not(var484 = 1)) and (var62 = 1 or not(var484 = 1)) and (var64 = 1
or not(var484 = 1)) and (var66 = 1 or not(var485 = 1)) and (var68 = 1 or not(
var485 = 1)) and (var69 = 1 or not(var485 = 1)) and (var71 = 1 or not(var485 = 1
)) and (var74 = 1 or not(var485 = 1)) and (var76 = 1 or not(var485 = 1)) and (
var78 = 1 or not(var485 = 1)) and (var80 = 1 or not(var485 = 1)) and (var82 = 1
or not(var486 = 1)) and (var84 = 1 or not(var486 = 1)) and (var85 = 1 or not(
var486 = 1)) and (var87 = 1 or not(var486 = 1)) and (var90 = 1 or not(var486 = 1
)) and (var92 = 1 or not(var486 = 1)) and (var94 = 1 or not(var486 = 1)) and (
var96 = 1 or not(var486 = 1)) and (var98 = 1 or not(var487 = 1)) and (var100 = 1
 or not(var487 = 1)) and (var101 = 1 or not(var487 = 1)) and (var103 = 1 or not(
var487 = 1)) and (var106 = 1 or not(var487 = 1)) and (var108 = 1 or not(var487 =
 1)) and (var110 = 1 or not(var487 = 1)) and (var112 = 1 or not(var487 = 1)) and
 (var114 = 1 or not(var488 = 1)) and (var116 = 1 or not(var488 = 1)) and (var117
 = 1 or not(var488 = 1)) and (var119 = 1 or not(var488 = 1)) and (var122 = 1 or
not(var488 = 1)) and (var124 = 1 or not(var488 = 1)) and (var126 = 1 or not(
var488 = 1)) and (var128 = 1 or not(var488 = 1)) and (var130 = 1 or not(var489 =
 1)) and (var132 = 1 or not(var489 = 1)) and (var133 = 1 or not(var489 = 1)) and
 (var135 = 1 or not(var489 = 1)) and (var138 = 1 or not(var489 = 1)) and (var140
 = 1 or not(var489 = 1)) and (var142 = 1 or not(var489 = 1)) and (var144 = 1 or
not(var489 = 1)) and (var146 = 1 or not(var490 = 1)) and (var148 = 1 or not(
var490 = 1)) and (var149 = 1 or not(var490 = 1)) and (var151 = 1 or not(var490 =
 1)) and (var154 = 1 or not(var490 = 1)) and (var156 = 1 or not(var490 = 1)) and
 (var158 = 1 or not(var490 = 1)) and (var160 = 1 or not(var490 = 1)) and (var1 =
 1 or not(var491 = 1)) and (var4 = 1 or not(var491 = 1)) and (var5 = 1 or not(
var491 = 1)) and (var8 = 1 or not(var491 = 1)) and (var10 = 1 or not(var491 = 1)
) and (var11 = 1 or not(var491 = 1)) and (var13 = 1 or not(var491 = 1)) and (
var15 = 1 or not(var491 = 1)) and (var17 = 1 or not(var492 = 1)) and (var20 = 1
or not(var492 = 1)) and (var21 = 1 or not(var492 = 1)) and (var24 = 1 or not(
var492 = 1)) and (var26 = 1 or not(var492 = 1)) and (var27 = 1 or not(var492 = 1
)) and (var29 = 1 or not(var492 = 1)) and (var31 = 1 or not(var492 = 1)) and (
var33 = 1 or not(var493 = 1)) and (var36 = 1 or not(var493 = 1)) and (var37 = 1
or not(var493 = 1)) and (var40 = 1 or not(var493 = 1)) and (var42 = 1 or not(
var493 = 1)) and (var43 = 1 or not(var493 = 1)) and (var45 = 1 or not(var493 = 1
)) and (var47 = 1 or not(var493 = 1)) and (var49 = 1 or not(var494 = 1)) and (
var52 = 1 or not(var494 = 1)) and (var53 = 1 or not(var494 = 1)) and (var56 = 1
or not(var494 = 1)) and (var58 = 1 or not(var494 = 1)) and (var59 = 1 or not(
var494 = 1)) and (var61 = 1 or not(var494 = 1)) and (var63 = 1 or not(var494 = 1
)) and (var65 = 1 or not(var495 = 1)) and (var68 = 1 or not(var495 = 1)) and (
var69 = 1 or not(var495 = 1)) and (var72 = 1 or not(var495 = 1)) and (var74 = 1
or not(var495 = 1)) and (var75 = 1 or not(var495 = 1)) and (var77 = 1 or not(
var495 = 1)) and (var79 = 1 or not(var495 = 1)) and (var81 = 1 or not(var496 = 1
)) and (var84 = 1 or not(var496 = 1)) and (var85 = 1 or not(var496 = 1)) and (
var88 = 1 or not(var496 = 1)) and (var90 = 1 or not(var496 = 1)) and (var91 = 1
or not(var496 = 1)) and (var93 = 1 or not(var496 = 1)) and (var95 = 1 or not(
var496 = 1)) and (var97 = 1 or not(var497 = 1)) and (var100 = 1 or not(var497 =
1)) and (var101 = 1 or not(var497 = 1)) and (var104 = 1 or not(var497 = 1)) and
(var106 = 1 or not(var497 = 1)) and (var107 = 1 or not(var497 = 1)) and (var109
= 1 or not(var497 = 1)) and (var111 = 1 or not(var497 = 1)) and (var113 = 1 or
not(var498 = 1)) and (var116 = 1 or not(var498 = 1)) and (var117 = 1 or not(
var498 = 1)) and (var120 = 1 or not(var498 = 1)) and (var122 = 1 or not(var498 =
 1)) and (var123 = 1 or not(var498 = 1)) and (var125 = 1 or not(var498 = 1)) and
 (var127 = 1 or not(var498 = 1)) and (var129 = 1 or not(var499 = 1)) and (var132
 = 1 or not(var499 = 1)) and (var133 = 1 or not(var499 = 1)) and (var136 = 1 or
not(var499 = 1)) and (var138 = 1 or not(var499 = 1)) and (var139 = 1 or not(
var499 = 1)) and (var141 = 1 or not(var499 = 1)) and (var143 = 1 or not(var499 =
 1)) and (var145 = 1 or not(var500 = 1)) and (var148 = 1 or not(var500 = 1)) and
 (var149 = 1 or not(var500 = 1)) and (var152 = 1 or not(var500 = 1)) and (var154
 = 1 or not(var500 = 1)) and (var155 = 1 or not(var500 = 1)) and (var157 = 1 or
not(var500 = 1)) and (var159 = 1 or not(var500 = 1)) and (var1 = 1 or not(var501
 = 1)) and (var3 = 1 or not(var501 = 1)) and (var5 = 1 or not(var501 = 1)) and (
var8 = 1 or not(var501 = 1)) and (var10 = 1 or not(var501 = 1)) and (var12 = 1
or not(var501 = 1)) and (var14 = 1 or not(var501 = 1)) and (var16 = 1 or not(
var501 = 1)) and (var17 = 1 or not(var502 = 1)) and (var19 = 1 or not(var502 = 1
)) and (var21 = 1 or not(var502 = 1)) and (var24 = 1 or not(var502 = 1)) and (
var26 = 1 or not(var502 = 1)) and (var28 = 1 or not(var502 = 1)) and (var30 = 1
or not(var502 = 1)) and (var32 = 1 or not(var502 = 1)) and (var33 = 1 or not(
var503 = 1)) and (var35 = 1 or not(var503 = 1)) and (var37 = 1 or not(var503 = 1
)) and (var40 = 1 or not(var503 = 1)) and (var42 = 1 or not(var503 = 1)) and (
var44 = 1 or not(var503 = 1)) and (var46 = 1 or not(var503 = 1)) and (var48 = 1
or not(var503 = 1)) and (var49 = 1 or not(var504 = 1)) and (var51 = 1 or not(
var504 = 1)) and (var53 = 1 or not(var504 = 1)) and (var56 = 1 or not(var504 = 1
)) and (var58 = 1 or not(var504 = 1)) and (var60 = 1 or not(var504 = 1)) and (
var62 = 1 or not(var504 = 1)) and (var64 = 1 or not(var504 = 1)) and (var65 = 1
or not(var505 = 1)) and (var67 = 1 or not(var505 = 1)) and (var69 = 1 or not(
var505 = 1)) and (var72 = 1 or not(var505 = 1)) and (var74 = 1 or not(var505 = 1
)) and (var76 = 1 or not(var505 = 1)) and (var78 = 1 or not(var505 = 1)) and (
var80 = 1 or not(var505 = 1)) and (var81 = 1 or not(var506 = 1)) and (var83 = 1
or not(var506 = 1)) and (var85 = 1 or not(var506 = 1)) and (var88 = 1 or not(
var506 = 1)) and (var90 = 1 or not(var506 = 1)) and (var92 = 1 or not(var506 = 1
)) and (var94 = 1 or not(var506 = 1)) and (var96 = 1 or not(var506 = 1)) and (
var97 = 1 or not(var507 = 1)) and (var99 = 1 or not(var507 = 1)) and (var101 = 1
 or not(var507 = 1)) and (var104 = 1 or not(var507 = 1)) and (var106 = 1 or not(
var507 = 1)) and (var108 = 1 or not(var507 = 1)) and (var110 = 1 or not(var507 =
 1)) and (var112 = 1 or not(var507 = 1)) and (var113 = 1 or not(var508 = 1)) and
 (var115 = 1 or not(var508 = 1)) and (var117 = 1 or not(var508 = 1)) and (var120
 = 1 or not(var508 = 1)) and (var122 = 1 or not(var508 = 1)) and (var124 = 1 or
not(var508 = 1)) and (var126 = 1 or not(var508 = 1)) and (var128 = 1 or not(
var508 = 1)) and (var129 = 1 or not(var509 = 1)) and (var131 = 1 or not(var509 =
 1)) and (var133 = 1 or not(var509 = 1)) and (var136 = 1 or not(var509 = 1)) and
 (var138 = 1 or not(var509 = 1)) and (var140 = 1 or not(var509 = 1)) and (var142
 = 1 or not(var509 = 1)) and (var144 = 1 or not(var509 = 1)) and (var145 = 1 or
not(var510 = 1)) and (var147 = 1 or not(var510 = 1)) and (var149 = 1 or not(
var510 = 1)) and (var152 = 1 or not(var510 = 1)) and (var154 = 1 or not(var510 =
 1)) and (var156 = 1 or not(var510 = 1)) and (var158 = 1 or not(var510 = 1)) and
 (var160 = 1 or not(var510 = 1)) and (var1 = 1 or not(var511 = 1)) and (var4 = 1
 or not(var511 = 1)) and (var6 = 1 or not(var511 = 1)) and (var8 = 1 or not(
var511 = 1)) and (var10 = 1 or not(var511 = 1)) and (var11 = 1 or not(var511 = 1
)) and (var14 = 1 or not(var511 = 1)) and (var15 = 1 or not(var511 = 1)) and (
var17 = 1 or not(var512 = 1)) and (var20 = 1 or not(var512 = 1)) and (var22 = 1
or not(var512 = 1)) and (var24 = 1 or not(var512 = 1)) and (var26 = 1 or not(
var512 = 1)) and (var27 = 1 or not(var512 = 1)) and (var30 = 1 or not(var512 = 1
)) and (var31 = 1 or not(var512 = 1)) and (var33 = 1 or not(var513 = 1)) and (
var36 = 1 or not(var513 = 1)) and (var38 = 1 or not(var513 = 1)) and (var40 = 1
or not(var513 = 1)) and (var42 = 1 or not(var513 = 1)) and (var43 = 1 or not(
var513 = 1)) and (var46 = 1 or not(var513 = 1)) and (var47 = 1 or not(var513 = 1
)) and (var49 = 1 or not(var514 = 1)) and (var52 = 1 or not(var514 = 1)) and (
var54 = 1 or not(var514 = 1)) and (var56 = 1 or not(var514 = 1)) and (var58 = 1
or not(var514 = 1)) and (var59 = 1 or not(var514 = 1)) and (var62 = 1 or not(
var514 = 1)) and (var63 = 1 or not(var514 = 1)) and (var65 = 1 or not(var515 = 1
)) and (var68 = 1 or not(var515 = 1)) and (var70 = 1 or not(var515 = 1)) and (
var72 = 1 or not(var515 = 1)) and (var74 = 1 or not(var515 = 1)) and (var75 = 1
or not(var515 = 1)) and (var78 = 1 or not(var515 = 1)) and (var79 = 1 or not(
var515 = 1)) and (var81 = 1 or not(var516 = 1)) and (var84 = 1 or not(var516 = 1
)) and (var86 = 1 or not(var516 = 1)) and (var88 = 1 or not(var516 = 1)) and (
var90 = 1 or not(var516 = 1)) and (var91 = 1 or not(var516 = 1)) and (var94 = 1
or not(var516 = 1)) and (var95 = 1 or not(var516 = 1)) and (var97 = 1 or not(
var517 = 1)) and (var100 = 1 or not(var517 = 1)) and (var102 = 1 or not(var517 =
 1)) and (var104 = 1 or not(var517 = 1)) and (var106 = 1 or not(var517 = 1)) and
 (var107 = 1 or not(var517 = 1)) and (var110 = 1 or not(var517 = 1)) and (var111
 = 1 or not(var517 = 1)) and (var113 = 1 or not(var518 = 1)) and (var116 = 1 or
not(var518 = 1)) and (var118 = 1 or not(var518 = 1)) and (var120 = 1 or not(
var518 = 1)) and (var122 = 1 or not(var518 = 1)) and (var123 = 1 or not(var518 =
 1)) and (var126 = 1 or not(var518 = 1)) and (var127 = 1 or not(var518 = 1)) and
 (var129 = 1 or not(var519 = 1)) and (var132 = 1 or not(var519 = 1)) and (var134
 = 1 or not(var519 = 1)) and (var136 = 1 or not(var519 = 1)) and (var138 = 1 or
not(var519 = 1)) and (var139 = 1 or not(var519 = 1)) and (var142 = 1 or not(
var519 = 1)) and (var143 = 1 or not(var519 = 1)) and (var145 = 1 or not(var520 =
 1)) and (var148 = 1 or not(var520 = 1)) and (var150 = 1 or not(var520 = 1)) and
 (var152 = 1 or not(var520 = 1)) and (var154 = 1 or not(var520 = 1)) and (var155
 = 1 or not(var520 = 1)) and (var158 = 1 or not(var520 = 1)) and (var159 = 1 or
not(var520 = 1)) and (var2 = 1 or not(var521 = 1)) and (var3 = 1 or not(var521 =
 1)) and (var5 = 1 or not(var521 = 1)) and (var8 = 1 or not(var521 = 1)) and (
var10 = 1 or not(var521 = 1)) and (var12 = 1 or not(var521 = 1)) and (var13 = 1
or not(var521 = 1)) and (var15 = 1 or not(var521 = 1)) and (var18 = 1 or not(
var522 = 1)) and (var19 = 1 or not(var522 = 1)) and (var21 = 1 or not(var522 = 1
)) and (var24 = 1 or not(var522 = 1)) and (var26 = 1 or not(var522 = 1)) and (
var28 = 1 or not(var522 = 1)) and (var29 = 1 or not(var522 = 1)) and (var31 = 1
or not(var522 = 1)) and (var34 = 1 or not(var523 = 1)) and (var35 = 1 or not(
var523 = 1)) and (var37 = 1 or not(var523 = 1)) and (var40 = 1 or not(var523 = 1
)) and (var42 = 1 or not(var523 = 1)) and (var44 = 1 or not(var523 = 1)) and (
var45 = 1 or not(var523 = 1)) and (var47 = 1 or not(var523 = 1)) and (var50 = 1
or not(var524 = 1)) and (var51 = 1 or not(var524 = 1)) and (var53 = 1 or not(
var524 = 1)) and (var56 = 1 or not(var524 = 1)) and (var58 = 1 or not(var524 = 1
)) and (var60 = 1 or not(var524 = 1)) and (var61 = 1 or not(var524 = 1)) and (
var63 = 1 or not(var524 = 1)) and (var66 = 1 or not(var525 = 1)) and (var67 = 1
or not(var525 = 1)) and (var69 = 1 or not(var525 = 1)) and (var72 = 1 or not(
var525 = 1)) and (var74 = 1 or not(var525 = 1)) and (var76 = 1 or not(var525 = 1
)) and (var77 = 1 or not(var525 = 1)) and (var79 = 1 or not(var525 = 1)) and (
var82 = 1 or not(var526 = 1)) and (var83 = 1 or not(var526 = 1)) and (var85 = 1
or not(var526 = 1)) and (var88 = 1 or not(var526 = 1)) and (var90 = 1 or not(
var526 = 1)) and (var92 = 1 or not(var526 = 1)) and (var93 = 1 or not(var526 = 1
)) and (var95 = 1 or not(var526 = 1)) and (var98 = 1 or not(var527 = 1)) and (
var99 = 1 or not(var527 = 1)) and (var101 = 1 or not(var527 = 1)) and (var104 =
1 or not(var527 = 1)) and (var106 = 1 or not(var527 = 1)) and (var108 = 1 or not
(var527 = 1)) and (var109 = 1 or not(var527 = 1)) and (var111 = 1 or not(var527
= 1)) and (var114 = 1 or not(var528 = 1)) and (var115 = 1 or not(var528 = 1))
and (var117 = 1 or not(var528 = 1)) and (var120 = 1 or not(var528 = 1)) and (
var122 = 1 or not(var528 = 1)) and (var124 = 1 or not(var528 = 1)) and (var125 =
 1 or not(var528 = 1)) and (var127 = 1 or not(var528 = 1)) and (var130 = 1 or
not(var529 = 1)) and (var131 = 1 or not(var529 = 1)) and (var133 = 1 or not(
var529 = 1)) and (var136 = 1 or not(var529 = 1)) and (var138 = 1 or not(var529 =
 1)) and (var140 = 1 or not(var529 = 1)) and (var141 = 1 or not(var529 = 1)) and
 (var143 = 1 or not(var529 = 1)) and (var146 = 1 or not(var530 = 1)) and (var147
 = 1 or not(var530 = 1)) and (var149 = 1 or not(var530 = 1)) and (var152 = 1 or
not(var530 = 1)) and (var154 = 1 or not(var530 = 1)) and (var156 = 1 or not(
var530 = 1)) and (var157 = 1 or not(var530 = 1)) and (var159 = 1 or not(var530 =
 1)) and (var1 = 1 or not(var531 = 1)) and (var3 = 1 or not(var531 = 1)) and (
var6 = 1 or not(var531 = 1)) and (var8 = 1 or not(var531 = 1)) and (var10 = 1 or
 not(var531 = 1)) and (var11 = 1 or not(var531 = 1)) and (var14 = 1 or not(
var531 = 1)) and (var15 = 1 or not(var531 = 1)) and (var17 = 1 or not(var532 = 1
)) and (var19 = 1 or not(var532 = 1)) and (var22 = 1 or not(var532 = 1)) and (
var24 = 1 or not(var532 = 1)) and (var26 = 1 or not(var532 = 1)) and (var27 = 1
or not(var532 = 1)) and (var30 = 1 or not(var532 = 1)) and (var31 = 1 or not(
var532 = 1)) and (var33 = 1 or not(var533 = 1)) and (var35 = 1 or not(var533 = 1
)) and (var38 = 1 or not(var533 = 1)) and (var40 = 1 or not(var533 = 1)) and (
var42 = 1 or not(var533 = 1)) and (var43 = 1 or not(var533 = 1)) and (var46 = 1
or not(var533 = 1)) and (var47 = 1 or not(var533 = 1)) and (var49 = 1 or not(
var534 = 1)) and (var51 = 1 or not(var534 = 1)) and (var54 = 1 or not(var534 = 1
)) and (var56 = 1 or not(var534 = 1)) and (var58 = 1 or not(var534 = 1)) and (
var59 = 1 or not(var534 = 1)) and (var62 = 1 or not(var534 = 1)) and (var63 = 1
or not(var534 = 1)) and (var65 = 1 or not(var535 = 1)) and (var67 = 1 or not(
var535 = 1)) and (var70 = 1 or not(var535 = 1)) and (var72 = 1 or not(var535 = 1
)) and (var74 = 1 or not(var535 = 1)) and (var75 = 1 or not(var535 = 1)) and (
var78 = 1 or not(var535 = 1)) and (var79 = 1 or not(var535 = 1)) and (var81 = 1
or not(var536 = 1)) and (var83 = 1 or not(var536 = 1)) and (var86 = 1 or not(
var536 = 1)) and (var88 = 1 or not(var536 = 1)) and (var90 = 1 or not(var536 = 1
)) and (var91 = 1 or not(var536 = 1)) and (var94 = 1 or not(var536 = 1)) and (
var95 = 1 or not(var536 = 1)) and (var97 = 1 or not(var537 = 1)) and (var99 = 1
or not(var537 = 1)) and (var102 = 1 or not(var537 = 1)) and (var104 = 1 or not(
var537 = 1)) and (var106 = 1 or not(var537 = 1)) and (var107 = 1 or not(var537 =
 1)) and (var110 = 1 or not(var537 = 1)) and (var111 = 1 or not(var537 = 1)) and
 (var113 = 1 or not(var538 = 1)) and (var115 = 1 or not(var538 = 1)) and (var118
 = 1 or not(var538 = 1)) and (var120 = 1 or not(var538 = 1)) and (var122 = 1 or
not(var538 = 1)) and (var123 = 1 or not(var538 = 1)) and (var126 = 1 or not(
var538 = 1)) and (var127 = 1 or not(var538 = 1)) and (var129 = 1 or not(var539 =
 1)) and (var131 = 1 or not(var539 = 1)) and (var134 = 1 or not(var539 = 1)) and
 (var136 = 1 or not(var539 = 1)) and (var138 = 1 or not(var539 = 1)) and (var139
 = 1 or not(var539 = 1)) and (var142 = 1 or not(var539 = 1)) and (var143 = 1 or
not(var539 = 1)) and (var145 = 1 or not(var540 = 1)) and (var147 = 1 or not(
var540 = 1)) and (var150 = 1 or not(var540 = 1)) and (var152 = 1 or not(var540 =
 1)) and (var154 = 1 or not(var540 = 1)) and (var155 = 1 or not(var540 = 1)) and
 (var158 = 1 or not(var540 = 1)) and (var159 = 1 or not(var540 = 1)) and (var1 =
 1 or not(var541 = 1)) and (var3 = 1 or not(var541 = 1)) and (var6 = 1 or not(
var541 = 1)) and (var8 = 1 or not(var541 = 1)) and (var10 = 1 or not(var541 = 1)
) and (var11 = 1 or not(var541 = 1)) and (var14 = 1 or not(var541 = 1)) and (
var15 = 1 or not(var541 = 1)) and (var17 = 1 or not(var542 = 1)) and (var19 = 1
or not(var542 = 1)) and (var22 = 1 or not(var542 = 1)) and (var24 = 1 or not(
var542 = 1)) and (var26 = 1 or not(var542 = 1)) and (var27 = 1 or not(var542 = 1
)) and (var30 = 1 or not(var542 = 1)) and (var31 = 1 or not(var542 = 1)) and (
var33 = 1 or not(var543 = 1)) and (var35 = 1 or not(var543 = 1)) and (var38 = 1
or not(var543 = 1)) and (var40 = 1 or not(var543 = 1)) and (var42 = 1 or not(
var543 = 1)) and (var43 = 1 or not(var543 = 1)) and (var46 = 1 or not(var543 = 1
)) and (var47 = 1 or not(var543 = 1)) and (var49 = 1 or not(var544 = 1)) and (
var51 = 1 or not(var544 = 1)) and (var54 = 1 or not(var544 = 1)) and (var56 = 1
or not(var544 = 1)) and (var58 = 1 or not(var544 = 1)) and (var59 = 1 or not(
var544 = 1)) and (var62 = 1 or not(var544 = 1)) and (var63 = 1 or not(var544 = 1
)) and (var65 = 1 or not(var545 = 1)) and (var67 = 1 or not(var545 = 1)) and (
var70 = 1 or not(var545 = 1)) and (var72 = 1 or not(var545 = 1)) and (var74 = 1
or not(var545 = 1)) and (var75 = 1 or not(var545 = 1)) and (var78 = 1 or not(
var545 = 1)) and (var79 = 1 or not(var545 = 1)) and (var81 = 1 or not(var546 = 1
)) and (var83 = 1 or not(var546 = 1)) and (var86 = 1 or not(var546 = 1)) and (
var88 = 1 or not(var546 = 1)) and (var90 = 1 or not(var546 = 1)) and (var91 = 1
or not(var546 = 1)) and (var94 = 1 or not(var546 = 1)) and (var95 = 1 or not(
var546 = 1)) and (var97 = 1 or not(var547 = 1)) and (var99 = 1 or not(var547 = 1
)) and (var102 = 1 or not(var547 = 1)) and (var104 = 1 or not(var547 = 1)) and (
var106 = 1 or not(var547 = 1)) and (var107 = 1 or not(var547 = 1)) and (var110 =
 1 or not(var547 = 1)) and (var111 = 1 or not(var547 = 1)) and (var113 = 1 or
not(var548 = 1)) and (var115 = 1 or not(var548 = 1)) and (var118 = 1 or not(
var548 = 1)) and (var120 = 1 or not(var548 = 1)) and (var122 = 1 or not(var548 =
 1)) and (var123 = 1 or not(var548 = 1)) and (var126 = 1 or not(var548 = 1)) and
 (var127 = 1 or not(var548 = 1)) and (var129 = 1 or not(var549 = 1)) and (var131
 = 1 or not(var549 = 1)) and (var134 = 1 or not(var549 = 1)) and (var136 = 1 or
not(var549 = 1)) and (var138 = 1 or not(var549 = 1)) and (var139 = 1 or not(
var549 = 1)) and (var142 = 1 or not(var549 = 1)) and (var143 = 1 or not(var549 =
 1)) and (var145 = 1 or not(var550 = 1)) and (var147 = 1 or not(var550 = 1)) and
 (var150 = 1 or not(var550 = 1)) and (var152 = 1 or not(var550 = 1)) and (var154
 = 1 or not(var550 = 1)) and (var155 = 1 or not(var550 = 1)) and (var158 = 1 or
not(var550 = 1)) and (var159 = 1 or not(var550 = 1)) and (var1 = 1 or not(var551
 = 1)) and (var4 = 1 or not(var551 = 1)) and (var6 = 1 or not(var551 = 1)) and (
var7 = 1 or not(var551 = 1)) and (var9 = 1 or not(var551 = 1)) and (var12 = 1 or
 not(var551 = 1)) and (var14 = 1 or not(var551 = 1)) and (var16 = 1 or not(
var551 = 1)) and (var17 = 1 or not(var552 = 1)) and (var20 = 1 or not(var552 = 1
)) and (var22 = 1 or not(var552 = 1)) and (var23 = 1 or not(var552 = 1)) and (
var25 = 1 or not(var552 = 1)) and (var28 = 1 or not(var552 = 1)) and (var30 = 1
or not(var552 = 1)) and (var32 = 1 or not(var552 = 1)) and (var33 = 1 or not(
var553 = 1)) and (var36 = 1 or not(var553 = 1)) and (var38 = 1 or not(var553 = 1
)) and (var39 = 1 or not(var553 = 1)) and (var41 = 1 or not(var553 = 1)) and (
var44 = 1 or not(var553 = 1)) and (var46 = 1 or not(var553 = 1)) and (var48 = 1
or not(var553 = 1)) and (var49 = 1 or not(var554 = 1)) and (var52 = 1 or not(
var554 = 1)) and (var54 = 1 or not(var554 = 1)) and (var55 = 1 or not(var554 = 1
)) and (var57 = 1 or not(var554 = 1)) and (var60 = 1 or not(var554 = 1)) and (
var62 = 1 or not(var554 = 1)) and (var64 = 1 or not(var554 = 1)) and (var65 = 1
or not(var555 = 1)) and (var68 = 1 or not(var555 = 1)) and (var70 = 1 or not(
var555 = 1)) and (var71 = 1 or not(var555 = 1)) and (var73 = 1 or not(var555 = 1
)) and (var76 = 1 or not(var555 = 1)) and (var78 = 1 or not(var555 = 1)) and (
var80 = 1 or not(var555 = 1)) and (var81 = 1 or not(var556 = 1)) and (var84 = 1
or not(var556 = 1)) and (var86 = 1 or not(var556 = 1)) and (var87 = 1 or not(
var556 = 1)) and (var89 = 1 or not(var556 = 1)) and (var92 = 1 or not(var556 = 1
)) and (var94 = 1 or not(var556 = 1)) and (var96 = 1 or not(var556 = 1)) and (
var97 = 1 or not(var557 = 1)) and (var100 = 1 or not(var557 = 1)) and (var102 =
1 or not(var557 = 1)) and (var103 = 1 or not(var557 = 1)) and (var105 = 1 or not
(var557 = 1)) and (var108 = 1 or not(var557 = 1)) and (var110 = 1 or not(var557
= 1)) and (var112 = 1 or not(var557 = 1)) and (var113 = 1 or not(var558 = 1))
and (var116 = 1 or not(var558 = 1)) and (var118 = 1 or not(var558 = 1)) and (
var119 = 1 or not(var558 = 1)) and (var121 = 1 or not(var558 = 1)) and (var124 =
 1 or not(var558 = 1)) and (var126 = 1 or not(var558 = 1)) and (var128 = 1 or
not(var558 = 1)) and (var129 = 1 or not(var559 = 1)) and (var132 = 1 or not(
var559 = 1)) and (var134 = 1 or not(var559 = 1)) and (var135 = 1 or not(var559 =
 1)) and (var137 = 1 or not(var559 = 1)) and (var140 = 1 or not(var559 = 1)) and
 (var142 = 1 or not(var559 = 1)) and (var144 = 1 or not(var559 = 1)) and (var145
 = 1 or not(var560 = 1)) and (var148 = 1 or not(var560 = 1)) and (var150 = 1 or
not(var560 = 1)) and (var151 = 1 or not(var560 = 1)) and (var153 = 1 or not(
var560 = 1)) and (var156 = 1 or not(var560 = 1)) and (var158 = 1 or not(var560 =
 1)) and (var160 = 1 or not(var560 = 1)) and (var1 = 1 or not(var561 = 1)) and (
var3 = 1 or not(var561 = 1)) and (var5 = 1 or not(var561 = 1)) and (var8 = 1 or
not(var561 = 1)) and (var10 = 1 or not(var561 = 1)) and (var11 = 1 or not(var561
 = 1)) and (var14 = 1 or not(var561 = 1)) and (var16 = 1 or not(var561 = 1)) and
 (var17 = 1 or not(var562 = 1)) and (var19 = 1 or not(var562 = 1)) and (var21 =
1 or not(var562 = 1)) and (var24 = 1 or not(var562 = 1)) and (var26 = 1 or not(
var562 = 1)) and (var27 = 1 or not(var562 = 1)) and (var30 = 1 or not(var562 = 1
)) and (var32 = 1 or not(var562 = 1)) and (var33 = 1 or not(var563 = 1)) and (
var35 = 1 or not(var563 = 1)) and (var37 = 1 or not(var563 = 1)) and (var40 = 1
or not(var563 = 1)) and (var42 = 1 or not(var563 = 1)) and (var43 = 1 or not(
var563 = 1)) and (var46 = 1 or not(var563 = 1)) and (var48 = 1 or not(var563 = 1
)) and (var49 = 1 or not(var564 = 1)) and (var51 = 1 or not(var564 = 1)) and (
var53 = 1 or not(var564 = 1)) and (var56 = 1 or not(var564 = 1)) and (var58 = 1
or not(var564 = 1)) and (var59 = 1 or not(var564 = 1)) and (var62 = 1 or not(
var564 = 1)) and (var64 = 1 or not(var564 = 1)) and (var65 = 1 or not(var565 = 1
)) and (var67 = 1 or not(var565 = 1)) and (var69 = 1 or not(var565 = 1)) and (
var72 = 1 or not(var565 = 1)) and (var74 = 1 or not(var565 = 1)) and (var75 = 1
or not(var565 = 1)) and (var78 = 1 or not(var565 = 1)) and (var80 = 1 or not(
var565 = 1)) and (var81 = 1 or not(var566 = 1)) and (var83 = 1 or not(var566 = 1
)) and (var85 = 1 or not(var566 = 1)) and (var88 = 1 or not(var566 = 1)) and (
var90 = 1 or not(var566 = 1)) and (var91 = 1 or not(var566 = 1)) and (var94 = 1
or not(var566 = 1)) and (var96 = 1 or not(var566 = 1)) and (var97 = 1 or not(
var567 = 1)) and (var99 = 1 or not(var567 = 1)) and (var101 = 1 or not(var567 =
1)) and (var104 = 1 or not(var567 = 1)) and (var106 = 1 or not(var567 = 1)) and
(var107 = 1 or not(var567 = 1)) and (var110 = 1 or not(var567 = 1)) and (var112
= 1 or not(var567 = 1)) and (var113 = 1 or not(var568 = 1)) and (var115 = 1 or
not(var568 = 1)) and (var117 = 1 or not(var568 = 1)) and (var120 = 1 or not(
var568 = 1)) and (var122 = 1 or not(var568 = 1)) and (var123 = 1 or not(var568 =
 1)) and (var126 = 1 or not(var568 = 1)) and (var128 = 1 or not(var568 = 1)) and
 (var129 = 1 or not(var569 = 1)) and (var131 = 1 or not(var569 = 1)) and (var133
 = 1 or not(var569 = 1)) and (var136 = 1 or not(var569 = 1)) and (var138 = 1 or
not(var569 = 1)) and (var139 = 1 or not(var569 = 1)) and (var142 = 1 or not(
var569 = 1)) and (var144 = 1 or not(var569 = 1)) and (var145 = 1 or not(var570 =
 1)) and (var147 = 1 or not(var570 = 1)) and (var149 = 1 or not(var570 = 1)) and
 (var152 = 1 or not(var570 = 1)) and (var154 = 1 or not(var570 = 1)) and (var155
 = 1 or not(var570 = 1)) and (var158 = 1 or not(var570 = 1)) and (var160 = 1 or
not(var570 = 1)) and (var1 = 1 or not(var571 = 1)) and (var4 = 1 or not(var571 =
 1)) and (var6 = 1 or not(var571 = 1)) and (var8 = 1 or not(var571 = 1)) and (
var9 = 1 or not(var571 = 1)) and (var12 = 1 or not(var571 = 1)) and (var14 = 1
or not(var571 = 1)) and (var15 = 1 or not(var571 = 1)) and (var17 = 1 or not(
var572 = 1)) and (var20 = 1 or not(var572 = 1)) and (var22 = 1 or not(var572 = 1
)) and (var24 = 1 or not(var572 = 1)) and (var25 = 1 or not(var572 = 1)) and (
var28 = 1 or not(var572 = 1)) and (var30 = 1 or not(var572 = 1)) and (var31 = 1
or not(var572 = 1)) and (var33 = 1 or not(var573 = 1)) and (var36 = 1 or not(
var573 = 1)) and (var38 = 1 or not(var573 = 1)) and (var40 = 1 or not(var573 = 1
)) and (var41 = 1 or not(var573 = 1)) and (var44 = 1 or not(var573 = 1)) and (
var46 = 1 or not(var573 = 1)) and (var47 = 1 or not(var573 = 1)) and (var49 = 1
or not(var574 = 1)) and (var52 = 1 or not(var574 = 1)) and (var54 = 1 or not(
var574 = 1)) and (var56 = 1 or not(var574 = 1)) and (var57 = 1 or not(var574 = 1
)) and (var60 = 1 or not(var574 = 1)) and (var62 = 1 or not(var574 = 1)) and (
var63 = 1 or not(var574 = 1)) and (var65 = 1 or not(var575 = 1)) and (var68 = 1
or not(var575 = 1)) and (var70 = 1 or not(var575 = 1)) and (var72 = 1 or not(
var575 = 1)) and (var73 = 1 or not(var575 = 1)) and (var76 = 1 or not(var575 = 1
)) and (var78 = 1 or not(var575 = 1)) and (var79 = 1 or not(var575 = 1)) and (
var81 = 1 or not(var576 = 1)) and (var84 = 1 or not(var576 = 1)) and (var86 = 1
or not(var576 = 1)) and (var88 = 1 or not(var576 = 1)) and (var89 = 1 or not(
var576 = 1)) and (var92 = 1 or not(var576 = 1)) and (var94 = 1 or not(var576 = 1
)) and (var95 = 1 or not(var576 = 1)) and (var97 = 1 or not(var577 = 1)) and (
var100 = 1 or not(var577 = 1)) and (var102 = 1 or not(var577 = 1)) and (var104 =
 1 or not(var577 = 1)) and (var105 = 1 or not(var577 = 1)) and (var108 = 1 or
not(var577 = 1)) and (var110 = 1 or not(var577 = 1)) and (var111 = 1 or not(
var577 = 1)) and (var113 = 1 or not(var578 = 1)) and (var116 = 1 or not(var578 =
 1)) and (var118 = 1 or not(var578 = 1)) and (var120 = 1 or not(var578 = 1)) and
 (var121 = 1 or not(var578 = 1)) and (var124 = 1 or not(var578 = 1)) and (var126
 = 1 or not(var578 = 1)) and (var127 = 1 or not(var578 = 1)) and (var129 = 1 or
not(var579 = 1)) and (var132 = 1 or not(var579 = 1)) and (var134 = 1 or not(
var579 = 1)) and (var136 = 1 or not(var579 = 1)) and (var137 = 1 or not(var579 =
 1)) and (var140 = 1 or not(var579 = 1)) and (var142 = 1 or not(var579 = 1)) and
 (var143 = 1 or not(var579 = 1)) and (var145 = 1 or not(var580 = 1)) and (var148
 = 1 or not(var580 = 1)) and (var150 = 1 or not(var580 = 1)) and (var152 = 1 or
not(var580 = 1)) and (var153 = 1 or not(var580 = 1)) and (var156 = 1 or not(
var580 = 1)) and (var158 = 1 or not(var580 = 1)) and (var159 = 1 or not(var580 =
 1)) and (var1 = 1 or not(var581 = 1)) and (var3 = 1 or not(var581 = 1)) and (
var6 = 1 or not(var581 = 1)) and (var8 = 1 or not(var581 = 1)) and (var10 = 1 or
 not(var581 = 1)) and (var11 = 1 or not(var581 = 1)) and (var13 = 1 or not(
var581 = 1)) and (var16 = 1 or not(var581 = 1)) and (var17 = 1 or not(var582 = 1
)) and (var19 = 1 or not(var582 = 1)) and (var22 = 1 or not(var582 = 1)) and (
var24 = 1 or not(var582 = 1)) and (var26 = 1 or not(var582 = 1)) and (var27 = 1
or not(var582 = 1)) and (var29 = 1 or not(var582 = 1)) and (var32 = 1 or not(
var582 = 1)) and (var33 = 1 or not(var583 = 1)) and (var35 = 1 or not(var583 = 1
)) and (var38 = 1 or not(var583 = 1)) and (var40 = 1 or not(var583 = 1)) and (
var42 = 1 or not(var583 = 1)) and (var43 = 1 or not(var583 = 1)) and (var45 = 1
or not(var583 = 1)) and (var48 = 1 or not(var583 = 1)) and (var49 = 1 or not(
var584 = 1)) and (var51 = 1 or not(var584 = 1)) and (var54 = 1 or not(var584 = 1
)) and (var56 = 1 or not(var584 = 1)) and (var58 = 1 or not(var584 = 1)) and (
var59 = 1 or not(var584 = 1)) and (var61 = 1 or not(var584 = 1)) and (var64 = 1
or not(var584 = 1)) and (var65 = 1 or not(var585 = 1)) and (var67 = 1 or not(
var585 = 1)) and (var70 = 1 or not(var585 = 1)) and (var72 = 1 or not(var585 = 1
)) and (var74 = 1 or not(var585 = 1)) and (var75 = 1 or not(var585 = 1)) and (
var77 = 1 or not(var585 = 1)) and (var80 = 1 or not(var585 = 1)) and (var81 = 1
or not(var586 = 1)) and (var83 = 1 or not(var586 = 1)) and (var86 = 1 or not(
var586 = 1)) and (var88 = 1 or not(var586 = 1)) and (var90 = 1 or not(var586 = 1
)) and (var91 = 1 or not(var586 = 1)) and (var93 = 1 or not(var586 = 1)) and (
var96 = 1 or not(var586 = 1)) and (var97 = 1 or not(var587 = 1)) and (var99 = 1
or not(var587 = 1)) and (var102 = 1 or not(var587 = 1)) and (var104 = 1 or not(
var587 = 1)) and (var106 = 1 or not(var587 = 1)) and (var107 = 1 or not(var587 =
 1)) and (var109 = 1 or not(var587 = 1)) and (var112 = 1 or not(var587 = 1)) and
 (var113 = 1 or not(var588 = 1)) and (var115 = 1 or not(var588 = 1)) and (var118
 = 1 or not(var588 = 1)) and (var120 = 1 or not(var588 = 1)) and (var122 = 1 or
not(var588 = 1)) and (var123 = 1 or not(var588 = 1)) and (var125 = 1 or not(
var588 = 1)) and (var128 = 1 or not(var588 = 1)) and (var129 = 1 or not(var589 =
 1)) and (var131 = 1 or not(var589 = 1)) and (var134 = 1 or not(var589 = 1)) and
 (var136 = 1 or not(var589 = 1)) and (var138 = 1 or not(var589 = 1)) and (var139
 = 1 or not(var589 = 1)) and (var141 = 1 or not(var589 = 1)) and (var144 = 1 or
not(var589 = 1)) and (var145 = 1 or not(var590 = 1)) and (var147 = 1 or not(
var590 = 1)) and (var150 = 1 or not(var590 = 1)) and (var152 = 1 or not(var590 =
 1)) and (var154 = 1 or not(var590 = 1)) and (var155 = 1 or not(var590 = 1)) and
 (var157 = 1 or not(var590 = 1)) and (var160 = 1 or not(var590 = 1)) and (var2 =
 1 or not(var591 = 1)) and (var3 = 1 or not(var591 = 1)) and (var5 = 1 or not(
var591 = 1)) and (var7 = 1 or not(var591 = 1)) and (var10 = 1 or not(var591 = 1)
) and (var12 = 1 or not(var591 = 1)) and (var13 = 1 or not(var591 = 1)) and (
var15 = 1 or not(var591 = 1)) and (var18 = 1 or not(var592 = 1)) and (var19 = 1
or not(var592 = 1)) and (var21 = 1 or not(var592 = 1)) and (var23 = 1 or not(
var592 = 1)) and (var26 = 1 or not(var592 = 1)) and (var28 = 1 or not(var592 = 1
)) and (var29 = 1 or not(var592 = 1)) and (var31 = 1 or not(var592 = 1)) and (
var34 = 1 or not(var593 = 1)) and (var35 = 1 or not(var593 = 1)) and (var37 = 1
or not(var593 = 1)) and (var39 = 1 or not(var593 = 1)) and (var42 = 1 or not(
var593 = 1)) and (var44 = 1 or not(var593 = 1)) and (var45 = 1 or not(var593 = 1
)) and (var47 = 1 or not(var593 = 1)) and (var50 = 1 or not(var594 = 1)) and (
var51 = 1 or not(var594 = 1)) and (var53 = 1 or not(var594 = 1)) and (var55 = 1
or not(var594 = 1)) and (var58 = 1 or not(var594 = 1)) and (var60 = 1 or not(
var594 = 1)) and (var61 = 1 or not(var594 = 1)) and (var63 = 1 or not(var594 = 1
)) and (var66 = 1 or not(var595 = 1)) and (var67 = 1 or not(var595 = 1)) and (
var69 = 1 or not(var595 = 1)) and (var71 = 1 or not(var595 = 1)) and (var74 = 1
or not(var595 = 1)) and (var76 = 1 or not(var595 = 1)) and (var77 = 1 or not(
var595 = 1)) and (var79 = 1 or not(var595 = 1)) and (var82 = 1 or not(var596 = 1
)) and (var83 = 1 or not(var596 = 1)) and (var85 = 1 or not(var596 = 1)) and (
var87 = 1 or not(var596 = 1)) and (var90 = 1 or not(var596 = 1)) and (var92 = 1
or not(var596 = 1)) and (var93 = 1 or not(var596 = 1)) and (var95 = 1 or not(
var596 = 1)) and (var98 = 1 or not(var597 = 1)) and (var99 = 1 or not(var597 = 1
)) and (var101 = 1 or not(var597 = 1)) and (var103 = 1 or not(var597 = 1)) and (
var106 = 1 or not(var597 = 1)) and (var108 = 1 or not(var597 = 1)) and (var109 =
 1 or not(var597 = 1)) and (var111 = 1 or not(var597 = 1)) and (var114 = 1 or
not(var598 = 1)) and (var115 = 1 or not(var598 = 1)) and (var117 = 1 or not(
var598 = 1)) and (var119 = 1 or not(var598 = 1)) and (var122 = 1 or not(var598 =
 1)) and (var124 = 1 or not(var598 = 1)) and (var125 = 1 or not(var598 = 1)) and
 (var127 = 1 or not(var598 = 1)) and (var130 = 1 or not(var599 = 1)) and (var131
 = 1 or not(var599 = 1)) and (var133 = 1 or not(var599 = 1)) and (var135 = 1 or
not(var599 = 1)) and (var138 = 1 or not(var599 = 1)) and (var140 = 1 or not(
var599 = 1)) and (var141 = 1 or not(var599 = 1)) and (var143 = 1 or not(var599 =
 1)) and (var146 = 1 or not(var600 = 1)) and (var147 = 1 or not(var600 = 1)) and
 (var149 = 1 or not(var600 = 1)) and (var151 = 1 or not(var600 = 1)) and (var154
 = 1 or not(var600 = 1)) and (var156 = 1 or not(var600 = 1)) and (var157 = 1 or
not(var600 = 1)) and (var159 = 1 or not(var600 = 1)) and (var1 = 1 or not(var601
 = 1)) and (var4 = 1 or not(var601 = 1)) and (var5 = 1 or not(var601 = 1)) and (
var8 = 1 or not(var601 = 1)) and (var10 = 1 or not(var601 = 1)) and (var12 = 1
or not(var601 = 1)) and (var14 = 1 or not(var601 = 1)) and (var15 = 1 or not(
var601 = 1)) and (var17 = 1 or not(var602 = 1)) and (var20 = 1 or not(var602 = 1
)) and (var21 = 1 or not(var602 = 1)) and (var24 = 1 or not(var602 = 1)) and (
var26 = 1 or not(var602 = 1)) and (var28 = 1 or not(var602 = 1)) and (var30 = 1
or not(var602 = 1)) and (var31 = 1 or not(var602 = 1)) and (var33 = 1 or not(
var603 = 1)) and (var36 = 1 or not(var603 = 1)) and (var37 = 1 or not(var603 = 1
)) and (var40 = 1 or not(var603 = 1)) and (var42 = 1 or not(var603 = 1)) and (
var44 = 1 or not(var603 = 1)) and (var46 = 1 or not(var603 = 1)) and (var47 = 1
or not(var603 = 1)) and (var49 = 1 or not(var604 = 1)) and (var52 = 1 or not(
var604 = 1)) and (var53 = 1 or not(var604 = 1)) and (var56 = 1 or not(var604 = 1
)) and (var58 = 1 or not(var604 = 1)) and (var60 = 1 or not(var604 = 1)) and (
var62 = 1 or not(var604 = 1)) and (var63 = 1 or not(var604 = 1)) and (var65 = 1
or not(var605 = 1)) and (var68 = 1 or not(var605 = 1)) and (var69 = 1 or not(
var605 = 1)) and (var72 = 1 or not(var605 = 1)) and (var74 = 1 or not(var605 = 1
)) and (var76 = 1 or not(var605 = 1)) and (var78 = 1 or not(var605 = 1)) and (
var79 = 1 or not(var605 = 1)) and (var81 = 1 or not(var606 = 1)) and (var84 = 1
or not(var606 = 1)) and (var85 = 1 or not(var606 = 1)) and (var88 = 1 or not(
var606 = 1)) and (var90 = 1 or not(var606 = 1)) and (var92 = 1 or not(var606 = 1
)) and (var94 = 1 or not(var606 = 1)) and (var95 = 1 or not(var606 = 1)) and (
var97 = 1 or not(var607 = 1)) and (var100 = 1 or not(var607 = 1)) and (var101 =
1 or not(var607 = 1)) and (var104 = 1 or not(var607 = 1)) and (var106 = 1 or not
(var607 = 1)) and (var108 = 1 or not(var607 = 1)) and (var110 = 1 or not(var607
= 1)) and (var111 = 1 or not(var607 = 1)) and (var113 = 1 or not(var608 = 1))
and (var116 = 1 or not(var608 = 1)) and (var117 = 1 or not(var608 = 1)) and (
var120 = 1 or not(var608 = 1)) and (var122 = 1 or not(var608 = 1)) and (var124 =
 1 or not(var608 = 1)) and (var126 = 1 or not(var608 = 1)) and (var127 = 1 or
not(var608 = 1)) and (var129 = 1 or not(var609 = 1)) and (var132 = 1 or not(
var609 = 1)) and (var133 = 1 or not(var609 = 1)) and (var136 = 1 or not(var609 =
 1)) and (var138 = 1 or not(var609 = 1)) and (var140 = 1 or not(var609 = 1)) and
 (var142 = 1 or not(var609 = 1)) and (var143 = 1 or not(var609 = 1)) and (var145
 = 1 or not(var610 = 1)) and (var148 = 1 or not(var610 = 1)) and (var149 = 1 or
not(var610 = 1)) and (var152 = 1 or not(var610 = 1)) and (var154 = 1 or not(
var610 = 1)) and (var156 = 1 or not(var610 = 1)) and (var158 = 1 or not(var610 =
 1)) and (var159 = 1 or not(var610 = 1)) and (var1 = 1 or not(var611 = 1)) and (
var4 = 1 or not(var611 = 1)) and (var5 = 1 or not(var611 = 1)) and (var7 = 1 or
not(var611 = 1)) and (var10 = 1 or not(var611 = 1)) and (var11 = 1 or not(var611
 = 1)) and (var14 = 1 or not(var611 = 1)) and (var15 = 1 or not(var611 = 1)) and
 (var17 = 1 or not(var612 = 1)) and (var20 = 1 or not(var612 = 1)) and (var21 =
1 or not(var612 = 1)) and (var23 = 1 or not(var612 = 1)) and (var26 = 1 or not(
var612 = 1)) and (var27 = 1 or not(var612 = 1)) and (var30 = 1 or not(var612 = 1
)) and (var31 = 1 or not(var612 = 1)) and (var33 = 1 or not(var613 = 1)) and (
var36 = 1 or not(var613 = 1)) and (var37 = 1 or not(var613 = 1)) and (var39 = 1
or not(var613 = 1)) and (var42 = 1 or not(var613 = 1)) and (var43 = 1 or not(
var613 = 1)) and (var46 = 1 or not(var613 = 1)) and (var47 = 1 or not(var613 = 1
)) and (var49 = 1 or not(var614 = 1)) and (var52 = 1 or not(var614 = 1)) and (
var53 = 1 or not(var614 = 1)) and (var55 = 1 or not(var614 = 1)) and (var58 = 1
or not(var614 = 1)) and (var59 = 1 or not(var614 = 1)) and (var62 = 1 or not(
var614 = 1)) and (var63 = 1 or not(var614 = 1)) and (var65 = 1 or not(var615 = 1
)) and (var68 = 1 or not(var615 = 1)) and (var69 = 1 or not(var615 = 1)) and (
var71 = 1 or not(var615 = 1)) and (var74 = 1 or not(var615 = 1)) and (var75 = 1
or not(var615 = 1)) and (var78 = 1 or not(var615 = 1)) and (var79 = 1 or not(
var615 = 1)) and (var81 = 1 or not(var616 = 1)) and (var84 = 1 or not(var616 = 1
)) and (var85 = 1 or not(var616 = 1)) and (var87 = 1 or not(var616 = 1)) and (
var90 = 1 or not(var616 = 1)) and (var91 = 1 or not(var616 = 1)) and (var94 = 1
or not(var616 = 1)) and (var95 = 1 or not(var616 = 1)) and (var97 = 1 or not(
var617 = 1)) and (var100 = 1 or not(var617 = 1)) and (var101 = 1 or not(var617 =
 1)) and (var103 = 1 or not(var617 = 1)) and (var106 = 1 or not(var617 = 1)) and
 (var107 = 1 or not(var617 = 1)) and (var110 = 1 or not(var617 = 1)) and (var111
 = 1 or not(var617 = 1)) and (var113 = 1 or not(var618 = 1)) and (var116 = 1 or
not(var618 = 1)) and (var117 = 1 or not(var618 = 1)) and (var119 = 1 or not(
var618 = 1)) and (var122 = 1 or not(var618 = 1)) and (var123 = 1 or not(var618 =
 1)) and (var126 = 1 or not(var618 = 1)) and (var127 = 1 or not(var618 = 1)) and
 (var129 = 1 or not(var619 = 1)) and (var132 = 1 or not(var619 = 1)) and (var133
 = 1 or not(var619 = 1)) and (var135 = 1 or not(var619 = 1)) and (var138 = 1 or
not(var619 = 1)) and (var139 = 1 or not(var619 = 1)) and (var142 = 1 or not(
var619 = 1)) and (var143 = 1 or not(var619 = 1)) and (var145 = 1 or not(var620 =
 1)) and (var148 = 1 or not(var620 = 1)) and (var149 = 1 or not(var620 = 1)) and
 (var151 = 1 or not(var620 = 1)) and (var154 = 1 or not(var620 = 1)) and (var155
 = 1 or not(var620 = 1)) and (var158 = 1 or not(var620 = 1)) and (var159 = 1 or
not(var620 = 1)) and (var1 = 1 or not(var621 = 1)) and (var3 = 1 or not(var621 =
 1)) and (var5 = 1 or not(var621 = 1)) and (var7 = 1 or not(var621 = 1)) and (
var9 = 1 or not(var621 = 1)) and (var12 = 1 or not(var621 = 1)) and (var14 = 1
or not(var621 = 1)) and (var16 = 1 or not(var621 = 1)) and (var17 = 1 or not(
var622 = 1)) and (var19 = 1 or not(var622 = 1)) and (var21 = 1 or not(var622 = 1
)) and (var23 = 1 or not(var622 = 1)) and (var25 = 1 or not(var622 = 1)) and (
var28 = 1 or not(var622 = 1)) and (var30 = 1 or not(var622 = 1)) and (var32 = 1
or not(var622 = 1)) and (var33 = 1 or not(var623 = 1)) and (var35 = 1 or not(
var623 = 1)) and (var37 = 1 or not(var623 = 1)) and (var39 = 1 or not(var623 = 1
)) and (var41 = 1 or not(var623 = 1)) and (var44 = 1 or not(var623 = 1)) and (
var46 = 1 or not(var623 = 1)) and (var48 = 1 or not(var623 = 1)) and (var49 = 1
or not(var624 = 1)) and (var51 = 1 or not(var624 = 1)) and (var53 = 1 or not(
var624 = 1)) and (var55 = 1 or not(var624 = 1)) and (var57 = 1 or not(var624 = 1
)) and (var60 = 1 or not(var624 = 1)) and (var62 = 1 or not(var624 = 1)) and (
var64 = 1 or not(var624 = 1)) and (var65 = 1 or not(var625 = 1)) and (var67 = 1
or not(var625 = 1)) and (var69 = 1 or not(var625 = 1)) and (var71 = 1 or not(
var625 = 1)) and (var73 = 1 or not(var625 = 1)) and (var76 = 1 or not(var625 = 1
)) and (var78 = 1 or not(var625 = 1)) and (var80 = 1 or not(var625 = 1)) and (
var81 = 1 or not(var626 = 1)) and (var83 = 1 or not(var626 = 1)) and (var85 = 1
or not(var626 = 1)) and (var87 = 1 or not(var626 = 1)) and (var89 = 1 or not(
var626 = 1)) and (var92 = 1 or not(var626 = 1)) and (var94 = 1 or not(var626 = 1
)) and (var96 = 1 or not(var626 = 1)) and (var97 = 1 or not(var627 = 1)) and (
var99 = 1 or not(var627 = 1)) and (var101 = 1 or not(var627 = 1)) and (var103 =
1 or not(var627 = 1)) and (var105 = 1 or not(var627 = 1)) and (var108 = 1 or not
(var627 = 1)) and (var110 = 1 or not(var627 = 1)) and (var112 = 1 or not(var627
= 1)) and (var113 = 1 or not(var628 = 1)) and (var115 = 1 or not(var628 = 1))
and (var117 = 1 or not(var628 = 1)) and (var119 = 1 or not(var628 = 1)) and (
var121 = 1 or not(var628 = 1)) and (var124 = 1 or not(var628 = 1)) and (var126 =
 1 or not(var628 = 1)) and (var128 = 1 or not(var628 = 1)) and (var129 = 1 or
not(var629 = 1)) and (var131 = 1 or not(var629 = 1)) and (var133 = 1 or not(
var629 = 1)) and (var135 = 1 or not(var629 = 1)) and (var137 = 1 or not(var629 =
 1)) and (var140 = 1 or not(var629 = 1)) and (var142 = 1 or not(var629 = 1)) and
 (var144 = 1 or not(var629 = 1)) and (var145 = 1 or not(var630 = 1)) and (var147
 = 1 or not(var630 = 1)) and (var149 = 1 or not(var630 = 1)) and (var151 = 1 or
not(var630 = 1)) and (var153 = 1 or not(var630 = 1)) and (var156 = 1 or not(
var630 = 1)) and (var158 = 1 or not(var630 = 1)) and (var160 = 1 or not(var630 =
 1)) and (var1 = 1 or not(var631 = 1)) and (var4 = 1 or not(var631 = 1)) and (
var5 = 1 or not(var631 = 1)) and (var7 = 1 or not(var631 = 1)) and (var10 = 1 or
 not(var631 = 1)) and (var12 = 1 or not(var631 = 1)) and (var14 = 1 or not(
var631 = 1)) and (var15 = 1 or not(var631 = 1)) and (var17 = 1 or not(var632 = 1
)) and (var20 = 1 or not(var632 = 1)) and (var21 = 1 or not(var632 = 1)) and (
var23 = 1 or not(var632 = 1)) and (var26 = 1 or not(var632 = 1)) and (var28 = 1
or not(var632 = 1)) and (var30 = 1 or not(var632 = 1)) and (var31 = 1 or not(
var632 = 1)) and (var33 = 1 or not(var633 = 1)) and (var36 = 1 or not(var633 = 1
)) and (var37 = 1 or not(var633 = 1)) and (var39 = 1 or not(var633 = 1)) and (
var42 = 1 or not(var633 = 1)) and (var44 = 1 or not(var633 = 1)) and (var46 = 1
or not(var633 = 1)) and (var47 = 1 or not(var633 = 1)) and (var49 = 1 or not(
var634 = 1)) and (var52 = 1 or not(var634 = 1)) and (var53 = 1 or not(var634 = 1
)) and (var55 = 1 or not(var634 = 1)) and (var58 = 1 or not(var634 = 1)) and (
var60 = 1 or not(var634 = 1)) and (var62 = 1 or not(var634 = 1)) and (var63 = 1
or not(var634 = 1)) and (var65 = 1 or not(var635 = 1)) and (var68 = 1 or not(
var635 = 1)) and (var69 = 1 or not(var635 = 1)) and (var71 = 1 or not(var635 = 1
)) and (var74 = 1 or not(var635 = 1)) and (var76 = 1 or not(var635 = 1)) and (
var78 = 1 or not(var635 = 1)) and (var79 = 1 or not(var635 = 1)) and (var81 = 1
or not(var636 = 1)) and (var84 = 1 or not(var636 = 1)) and (var85 = 1 or not(
var636 = 1)) and (var87 = 1 or not(var636 = 1)) and (var90 = 1 or not(var636 = 1
)) and (var92 = 1 or not(var636 = 1)) and (var94 = 1 or not(var636 = 1)) and (
var95 = 1 or not(var636 = 1)) and (var97 = 1 or not(var637 = 1)) and (var100 = 1
 or not(var637 = 1)) and (var101 = 1 or not(var637 = 1)) and (var103 = 1 or not(
var637 = 1)) and (var106 = 1 or not(var637 = 1)) and (var108 = 1 or not(var637 =
 1)) and (var110 = 1 or not(var637 = 1)) and (var111 = 1 or not(var637 = 1)) and
 (var113 = 1 or not(var638 = 1)) and (var116 = 1 or not(var638 = 1)) and (var117
 = 1 or not(var638 = 1)) and (var119 = 1 or not(var638 = 1)) and (var122 = 1 or
not(var638 = 1)) and (var124 = 1 or not(var638 = 1)) and (var126 = 1 or not(
var638 = 1)) and (var127 = 1 or not(var638 = 1)) and (var129 = 1 or not(var639 =
 1)) and (var132 = 1 or not(var639 = 1)) and (var133 = 1 or not(var639 = 1)) and
 (var135 = 1 or not(var639 = 1)) and (var138 = 1 or not(var639 = 1)) and (var140
 = 1 or not(var639 = 1)) and (var142 = 1 or not(var639 = 1)) and (var143 = 1 or
not(var639 = 1)) and (var145 = 1 or not(var640 = 1)) and (var148 = 1 or not(
var640 = 1)) and (var149 = 1 or not(var640 = 1)) and (var151 = 1 or not(var640 =
 1)) and (var154 = 1 or not(var640 = 1)) and (var156 = 1 or not(var640 = 1)) and
 (var158 = 1 or not(var640 = 1)) and (var159 = 1 or not(var640 = 1)) and (var1 =
 1 or not(var641 = 1)) and (var3 = 1 or not(var641 = 1)) and (var6 = 1 or not(
var641 = 1)) and (var8 = 1 or not(var641 = 1)) and (var9 = 1 or not(var641 = 1))
 and (var12 = 1 or not(var641 = 1)) and (var14 = 1 or not(var641 = 1)) and (
var15 = 1 or not(var641 = 1)) and (var17 = 1 or not(var642 = 1)) and (var19 = 1
or not(var642 = 1)) and (var22 = 1 or not(var642 = 1)) and (var24 = 1 or not(
var642 = 1)) and (var25 = 1 or not(var642 = 1)) and (var28 = 1 or not(var642 = 1
)) and (var30 = 1 or not(var642 = 1)) and (var31 = 1 or not(var642 = 1)) and (
var33 = 1 or not(var643 = 1)) and (var35 = 1 or not(var643 = 1)) and (var38 = 1
or not(var643 = 1)) and (var40 = 1 or not(var643 = 1)) and (var41 = 1 or not(
var643 = 1)) and (var44 = 1 or not(var643 = 1)) and (var46 = 1 or not(var643 = 1
)) and (var47 = 1 or not(var643 = 1)) and (var49 = 1 or not(var644 = 1)) and (
var51 = 1 or not(var644 = 1)) and (var54 = 1 or not(var644 = 1)) and (var56 = 1
or not(var644 = 1)) and (var57 = 1 or not(var644 = 1)) and (var60 = 1 or not(
var644 = 1)) and (var62 = 1 or not(var644 = 1)) and (var63 = 1 or not(var644 = 1
)) and (var65 = 1 or not(var645 = 1)) and (var67 = 1 or not(var645 = 1)) and (
var70 = 1 or not(var645 = 1)) and (var72 = 1 or not(var645 = 1)) and (var73 = 1
or not(var645 = 1)) and (var76 = 1 or not(var645 = 1)) and (var78 = 1 or not(
var645 = 1)) and (var79 = 1 or not(var645 = 1)) and (var81 = 1 or not(var646 = 1
)) and (var83 = 1 or not(var646 = 1)) and (var86 = 1 or not(var646 = 1)) and (
var88 = 1 or not(var646 = 1)) and (var89 = 1 or not(var646 = 1)) and (var92 = 1
or not(var646 = 1)) and (var94 = 1 or not(var646 = 1)) and (var95 = 1 or not(
var646 = 1)) and (var97 = 1 or not(var647 = 1)) and (var99 = 1 or not(var647 = 1
)) and (var102 = 1 or not(var647 = 1)) and (var104 = 1 or not(var647 = 1)) and (
var105 = 1 or not(var647 = 1)) and (var108 = 1 or not(var647 = 1)) and (var110 =
 1 or not(var647 = 1)) and (var111 = 1 or not(var647 = 1)) and (var113 = 1 or
not(var648 = 1)) and (var115 = 1 or not(var648 = 1)) and (var118 = 1 or not(
var648 = 1)) and (var120 = 1 or not(var648 = 1)) and (var121 = 1 or not(var648 =
 1)) and (var124 = 1 or not(var648 = 1)) and (var126 = 1 or not(var648 = 1)) and
 (var127 = 1 or not(var648 = 1)) and (var129 = 1 or not(var649 = 1)) and (var131
 = 1 or not(var649 = 1)) and (var134 = 1 or not(var649 = 1)) and (var136 = 1 or
not(var649 = 1)) and (var137 = 1 or not(var649 = 1)) and (var140 = 1 or not(
var649 = 1)) and (var142 = 1 or not(var649 = 1)) and (var143 = 1 or not(var649 =
 1)) and (var145 = 1 or not(var650 = 1)) and (var147 = 1 or not(var650 = 1)) and
 (var150 = 1 or not(var650 = 1)) and (var152 = 1 or not(var650 = 1)) and (var153
 = 1 or not(var650 = 1)) and (var156 = 1 or not(var650 = 1)) and (var158 = 1 or
not(var650 = 1)) and (var159 = 1 or not(var650 = 1)) and (var2 = 1 or not(var651
 = 1)) and (var4 = 1 or not(var651 = 1)) and (var6 = 1 or not(var651 = 1)) and (
var8 = 1 or not(var651 = 1)) and (var10 = 1 or not(var651 = 1)) and (var11 = 1
or not(var651 = 1)) and (var13 = 1 or not(var651 = 1)) and (var16 = 1 or not(
var651 = 1)) and (var18 = 1 or not(var652 = 1)) and (var20 = 1 or not(var652 = 1
)) and (var22 = 1 or not(var652 = 1)) and (var24 = 1 or not(var652 = 1)) and (
var26 = 1 or not(var652 = 1)) and (var27 = 1 or not(var652 = 1)) and (var29 = 1
or not(var652 = 1)) and (var32 = 1 or not(var652 = 1)) and (var34 = 1 or not(
var653 = 1)) and (var36 = 1 or not(var653 = 1)) and (var38 = 1 or not(var653 = 1
)) and (var40 = 1 or not(var653 = 1)) and (var42 = 1 or not(var653 = 1)) and (
var43 = 1 or not(var653 = 1)) and (var45 = 1 or not(var653 = 1)) and (var48 = 1
or not(var653 = 1)) and (var50 = 1 or not(var654 = 1)) and (var52 = 1 or not(
var654 = 1)) and (var54 = 1 or not(var654 = 1)) and (var56 = 1 or not(var654 = 1
)) and (var58 = 1 or not(var654 = 1)) and (var59 = 1 or not(var654 = 1)) and (
var61 = 1 or not(var654 = 1)) and (var64 = 1 or not(var654 = 1)) and (var66 = 1
or not(var655 = 1)) and (var68 = 1 or not(var655 = 1)) and (var70 = 1 or not(
var655 = 1)) and (var72 = 1 or not(var655 = 1)) and (var74 = 1 or not(var655 = 1
)) and (var75 = 1 or not(var655 = 1)) and (var77 = 1 or not(var655 = 1)) and (
var80 = 1 or not(var655 = 1)) and (var82 = 1 or not(var656 = 1)) and (var84 = 1
or not(var656 = 1)) and (var86 = 1 or not(var656 = 1)) and (var88 = 1 or not(
var656 = 1)) and (var90 = 1 or not(var656 = 1)) and (var91 = 1 or not(var656 = 1
)) and (var93 = 1 or not(var656 = 1)) and (var96 = 1 or not(var656 = 1)) and (
var98 = 1 or not(var657 = 1)) and (var100 = 1 or not(var657 = 1)) and (var102 =
1 or not(var657 = 1)) and (var104 = 1 or not(var657 = 1)) and (var106 = 1 or not
(var657 = 1)) and (var107 = 1 or not(var657 = 1)) and (var109 = 1 or not(var657
= 1)) and (var112 = 1 or not(var657 = 1)) and (var114 = 1 or not(var658 = 1))
and (var116 = 1 or not(var658 = 1)) and (var118 = 1 or not(var658 = 1)) and (
var120 = 1 or not(var658 = 1)) and (var122 = 1 or not(var658 = 1)) and (var123 =
 1 or not(var658 = 1)) and (var125 = 1 or not(var658 = 1)) and (var128 = 1 or
not(var658 = 1)) and (var130 = 1 or not(var659 = 1)) and (var132 = 1 or not(
var659 = 1)) and (var134 = 1 or not(var659 = 1)) and (var136 = 1 or not(var659 =
 1)) and (var138 = 1 or not(var659 = 1)) and (var139 = 1 or not(var659 = 1)) and
 (var141 = 1 or not(var659 = 1)) and (var144 = 1 or not(var659 = 1)) and (var146
 = 1 or not(var660 = 1)) and (var148 = 1 or not(var660 = 1)) and (var150 = 1 or
not(var660 = 1)) and (var152 = 1 or not(var660 = 1)) and (var154 = 1 or not(
var660 = 1)) and (var155 = 1 or not(var660 = 1)) and (var157 = 1 or not(var660 =
 1)) and (var160 = 1 or not(var660 = 1)) and (var2 = 1 or not(var661 = 1)) and (
var3 = 1 or not(var661 = 1)) and (var6 = 1 or not(var661 = 1)) and (var7 = 1 or
not(var661 = 1)) and (var9 = 1 or not(var661 = 1)) and (var12 = 1 or not(var661
= 1)) and (var14 = 1 or not(var661 = 1)) and (var16 = 1 or not(var661 = 1)) and
(var18 = 1 or not(var662 = 1)) and (var19 = 1 or not(var662 = 1)) and (var22 = 1
 or not(var662 = 1)) and (var23 = 1 or not(var662 = 1)) and (var25 = 1 or not(
var662 = 1)) and (var28 = 1 or not(var662 = 1)) and (var30 = 1 or not(var662 = 1
)) and (var32 = 1 or not(var662 = 1)) and (var34 = 1 or not(var663 = 1)) and (
var35 = 1 or not(var663 = 1)) and (var38 = 1 or not(var663 = 1)) and (var39 = 1
or not(var663 = 1)) and (var41 = 1 or not(var663 = 1)) and (var44 = 1 or not(
var663 = 1)) and (var46 = 1 or not(var663 = 1)) and (var48 = 1 or not(var663 = 1
)) and (var50 = 1 or not(var664 = 1)) and (var51 = 1 or not(var664 = 1)) and (
var54 = 1 or not(var664 = 1)) and (var55 = 1 or not(var664 = 1)) and (var57 = 1
or not(var664 = 1)) and (var60 = 1 or not(var664 = 1)) and (var62 = 1 or not(
var664 = 1)) and (var64 = 1 or not(var664 = 1)) and (var66 = 1 or not(var665 = 1
)) and (var67 = 1 or not(var665 = 1)) and (var70 = 1 or not(var665 = 1)) and (
var71 = 1 or not(var665 = 1)) and (var73 = 1 or not(var665 = 1)) and (var76 = 1
or not(var665 = 1)) and (var78 = 1 or not(var665 = 1)) and (var80 = 1 or not(
var665 = 1)) and (var82 = 1 or not(var666 = 1)) and (var83 = 1 or not(var666 = 1
)) and (var86 = 1 or not(var666 = 1)) and (var87 = 1 or not(var666 = 1)) and (
var89 = 1 or not(var666 = 1)) and (var92 = 1 or not(var666 = 1)) and (var94 = 1
or not(var666 = 1)) and (var96 = 1 or not(var666 = 1)) and (var98 = 1 or not(
var667 = 1)) and (var99 = 1 or not(var667 = 1)) and (var102 = 1 or not(var667 =
1)) and (var103 = 1 or not(var667 = 1)) and (var105 = 1 or not(var667 = 1)) and
(var108 = 1 or not(var667 = 1)) and (var110 = 1 or not(var667 = 1)) and (var112
= 1 or not(var667 = 1)) and (var114 = 1 or not(var668 = 1)) and (var115 = 1 or
not(var668 = 1)) and (var118 = 1 or not(var668 = 1)) and (var119 = 1 or not(
var668 = 1)) and (var121 = 1 or not(var668 = 1)) and (var124 = 1 or not(var668 =
 1)) and (var126 = 1 or not(var668 = 1)) and (var128 = 1 or not(var668 = 1)) and
 (var130 = 1 or not(var669 = 1)) and (var131 = 1 or not(var669 = 1)) and (var134
 = 1 or not(var669 = 1)) and (var135 = 1 or not(var669 = 1)) and (var137 = 1 or
not(var669 = 1)) and (var140 = 1 or not(var669 = 1)) and (var142 = 1 or not(
var669 = 1)) and (var144 = 1 or not(var669 = 1)) and (var146 = 1 or not(var670 =
 1)) and (var147 = 1 or not(var670 = 1)) and (var150 = 1 or not(var670 = 1)) and
 (var151 = 1 or not(var670 = 1)) and (var153 = 1 or not(var670 = 1)) and (var156
 = 1 or not(var670 = 1)) and (var158 = 1 or not(var670 = 1)) and (var160 = 1 or
not(var670 = 1)) and (var1 = 1 or not(var671 = 1)) and (var3 = 1 or not(var671 =
 1)) and (var6 = 1 or not(var671 = 1)) and (var8 = 1 or not(var671 = 1)) and (
var10 = 1 or not(var671 = 1)) and (var12 = 1 or not(var671 = 1)) and (var13 = 1
or not(var671 = 1)) and (var16 = 1 or not(var671 = 1)) and (var17 = 1 or not(
var672 = 1)) and (var19 = 1 or not(var672 = 1)) and (var22 = 1 or not(var672 = 1
)) and (var24 = 1 or not(var672 = 1)) and (var26 = 1 or not(var672 = 1)) and (
var28 = 1 or not(var672 = 1)) and (var29 = 1 or not(var672 = 1)) and (var32 = 1
or not(var672 = 1)) and (var33 = 1 or not(var673 = 1)) and (var35 = 1 or not(
var673 = 1)) and (var38 = 1 or not(var673 = 1)) and (var40 = 1 or not(var673 = 1
)) and (var42 = 1 or not(var673 = 1)) and (var44 = 1 or not(var673 = 1)) and (
var45 = 1 or not(var673 = 1)) and (var48 = 1 or not(var673 = 1)) and (var49 = 1
or not(var674 = 1)) and (var51 = 1 or not(var674 = 1)) and (var54 = 1 or not(
var674 = 1)) and (var56 = 1 or not(var674 = 1)) and (var58 = 1 or not(var674 = 1
)) and (var60 = 1 or not(var674 = 1)) and (var61 = 1 or not(var674 = 1)) and (
var64 = 1 or not(var674 = 1)) and (var65 = 1 or not(var675 = 1)) and (var67 = 1
or not(var675 = 1)) and (var70 = 1 or not(var675 = 1)) and (var72 = 1 or not(
var675 = 1)) and (var74 = 1 or not(var675 = 1)) and (var76 = 1 or not(var675 = 1
)) and (var77 = 1 or not(var675 = 1)) and (var80 = 1 or not(var675 = 1)) and (
var81 = 1 or not(var676 = 1)) and (var83 = 1 or not(var676 = 1)) and (var86 = 1
or not(var676 = 1)) and (var88 = 1 or not(var676 = 1)) and (var90 = 1 or not(
var676 = 1)) and (var92 = 1 or not(var676 = 1)) and (var93 = 1 or not(var676 = 1
)) and (var96 = 1 or not(var676 = 1)) and (var97 = 1 or not(var677 = 1)) and (
var99 = 1 or not(var677 = 1)) and (var102 = 1 or not(var677 = 1)) and (var104 =
1 or not(var677 = 1)) and (var106 = 1 or not(var677 = 1)) and (var108 = 1 or not
(var677 = 1)) and (var109 = 1 or not(var677 = 1)) and (var112 = 1 or not(var677
= 1)) and (var113 = 1 or not(var678 = 1)) and (var115 = 1 or not(var678 = 1))
and (var118 = 1 or not(var678 = 1)) and (var120 = 1 or not(var678 = 1)) and (
var122 = 1 or not(var678 = 1)) and (var124 = 1 or not(var678 = 1)) and (var125 =
 1 or not(var678 = 1)) and (var128 = 1 or not(var678 = 1)) and (var129 = 1 or
not(var679 = 1)) and (var131 = 1 or not(var679 = 1)) and (var134 = 1 or not(
var679 = 1)) and (var136 = 1 or not(var679 = 1)) and (var138 = 1 or not(var679 =
 1)) and (var140 = 1 or not(var679 = 1)) and (var141 = 1 or not(var679 = 1)) and
 (var144 = 1 or not(var679 = 1)) and (var145 = 1 or not(var680 = 1)) and (var147
 = 1 or not(var680 = 1)) and (var150 = 1 or not(var680 = 1)) and (var152 = 1 or
not(var680 = 1)) and (var154 = 1 or not(var680 = 1)) and (var156 = 1 or not(
var680 = 1)) and (var157 = 1 or not(var680 = 1)) and (var160 = 1 or not(var680 =
 1)) and (var1 = 1 or not(var681 = 1)) and (var4 = 1 or not(var681 = 1)) and (
var5 = 1 or not(var681 = 1)) and (var8 = 1 or not(var681 = 1)) and (var10 = 1 or
 not(var681 = 1)) and (var12 = 1 or not(var681 = 1)) and (var13 = 1 or not(
var681 = 1)) and (var15 = 1 or not(var681 = 1)) and (var17 = 1 or not(var682 = 1
)) and (var20 = 1 or not(var682 = 1)) and (var21 = 1 or not(var682 = 1)) and (
var24 = 1 or not(var682 = 1)) and (var26 = 1 or not(var682 = 1)) and (var28 = 1
or not(var682 = 1)) and (var29 = 1 or not(var682 = 1)) and (var31 = 1 or not(
var682 = 1)) and (var33 = 1 or not(var683 = 1)) and (var36 = 1 or not(var683 = 1
)) and (var37 = 1 or not(var683 = 1)) and (var40 = 1 or not(var683 = 1)) and (
var42 = 1 or not(var683 = 1)) and (var44 = 1 or not(var683 = 1)) and (var45 = 1
or not(var683 = 1)) and (var47 = 1 or not(var683 = 1)) and (var49 = 1 or not(
var684 = 1)) and (var52 = 1 or not(var684 = 1)) and (var53 = 1 or not(var684 = 1
)) and (var56 = 1 or not(var684 = 1)) and (var58 = 1 or not(var684 = 1)) and (
var60 = 1 or not(var684 = 1)) and (var61 = 1 or not(var684 = 1)) and (var63 = 1
or not(var684 = 1)) and (var65 = 1 or not(var685 = 1)) and (var68 = 1 or not(
var685 = 1)) and (var69 = 1 or not(var685 = 1)) and (var72 = 1 or not(var685 = 1
)) and (var74 = 1 or not(var685 = 1)) and (var76 = 1 or not(var685 = 1)) and (
var77 = 1 or not(var685 = 1)) and (var79 = 1 or not(var685 = 1)) and (var81 = 1
or not(var686 = 1)) and (var84 = 1 or not(var686 = 1)) and (var85 = 1 or not(
var686 = 1)) and (var88 = 1 or not(var686 = 1)) and (var90 = 1 or not(var686 = 1
)) and (var92 = 1 or not(var686 = 1)) and (var93 = 1 or not(var686 = 1)) and (
var95 = 1 or not(var686 = 1)) and (var97 = 1 or not(var687 = 1)) and (var100 = 1
 or not(var687 = 1)) and (var101 = 1 or not(var687 = 1)) and (var104 = 1 or not(
var687 = 1)) and (var106 = 1 or not(var687 = 1)) and (var108 = 1 or not(var687 =
 1)) and (var109 = 1 or not(var687 = 1)) and (var111 = 1 or not(var687 = 1)) and
 (var113 = 1 or not(var688 = 1)) and (var116 = 1 or not(var688 = 1)) and (var117
 = 1 or not(var688 = 1)) and (var120 = 1 or not(var688 = 1)) and (var122 = 1 or
not(var688 = 1)) and (var124 = 1 or not(var688 = 1)) and (var125 = 1 or not(
var688 = 1)) and (var127 = 1 or not(var688 = 1)) and (var129 = 1 or not(var689 =
 1)) and (var132 = 1 or not(var689 = 1)) and (var133 = 1 or not(var689 = 1)) and
 (var136 = 1 or not(var689 = 1)) and (var138 = 1 or not(var689 = 1)) and (var140
 = 1 or not(var689 = 1)) and (var141 = 1 or not(var689 = 1)) and (var143 = 1 or
not(var689 = 1)) and (var145 = 1 or not(var690 = 1)) and (var148 = 1 or not(
var690 = 1)) and (var149 = 1 or not(var690 = 1)) and (var152 = 1 or not(var690 =
 1)) and (var154 = 1 or not(var690 = 1)) and (var156 = 1 or not(var690 = 1)) and
 (var157 = 1 or not(var690 = 1)) and (var159 = 1 or not(var690 = 1)) and (var2 =
 1 or not(var691 = 1)) and (var3 = 1 or not(var691 = 1)) and (var5 = 1 or not(
var691 = 1)) and (var8 = 1 or not(var691 = 1)) and (var10 = 1 or not(var691 = 1)
) and (var12 = 1 or not(var691 = 1)) and (var14 = 1 or not(var691 = 1)) and (
var15 = 1 or not(var691 = 1)) and (var18 = 1 or not(var692 = 1)) and (var19 = 1
or not(var692 = 1)) and (var21 = 1 or not(var692 = 1)) and (var24 = 1 or not(
var692 = 1)) and (var26 = 1 or not(var692 = 1)) and (var28 = 1 or not(var692 = 1
)) and (var30 = 1 or not(var692 = 1)) and (var31 = 1 or not(var692 = 1)) and (
var34 = 1 or not(var693 = 1)) and (var35 = 1 or not(var693 = 1)) and (var37 = 1
or not(var693 = 1)) and (var40 = 1 or not(var693 = 1)) and (var42 = 1 or not(
var693 = 1)) and (var44 = 1 or not(var693 = 1)) and (var46 = 1 or not(var693 = 1
)) and (var47 = 1 or not(var693 = 1)) and (var50 = 1 or not(var694 = 1)) and (
var51 = 1 or not(var694 = 1)) and (var53 = 1 or not(var694 = 1)) and (var56 = 1
or not(var694 = 1)) and (var58 = 1 or not(var694 = 1)) and (var60 = 1 or not(
var694 = 1)) and (var62 = 1 or not(var694 = 1)) and (var63 = 1 or not(var694 = 1
)) and (var66 = 1 or not(var695 = 1)) and (var67 = 1 or not(var695 = 1)) and (
var69 = 1 or not(var695 = 1)) and (var72 = 1 or not(var695 = 1)) and (var74 = 1
or not(var695 = 1)) and (var76 = 1 or not(var695 = 1)) and (var78 = 1 or not(
var695 = 1)) and (var79 = 1 or not(var695 = 1)) and (var82 = 1 or not(var696 = 1
)) and (var83 = 1 or not(var696 = 1)) and (var85 = 1 or not(var696 = 1)) and (
var88 = 1 or not(var696 = 1)) and (var90 = 1 or not(var696 = 1)) and (var92 = 1
or not(var696 = 1)) and (var94 = 1 or not(var696 = 1)) and (var95 = 1 or not(
var696 = 1)) and (var98 = 1 or not(var697 = 1)) and (var99 = 1 or not(var697 = 1
)) and (var101 = 1 or not(var697 = 1)) and (var104 = 1 or not(var697 = 1)) and (
var106 = 1 or not(var697 = 1)) and (var108 = 1 or not(var697 = 1)) and (var110 =
 1 or not(var697 = 1)) and (var111 = 1 or not(var697 = 1)) and (var114 = 1 or
not(var698 = 1)) and (var115 = 1 or not(var698 = 1)) and (var117 = 1 or not(
var698 = 1)) and (var120 = 1 or not(var698 = 1)) and (var122 = 1 or not(var698 =
 1)) and (var124 = 1 or not(var698 = 1)) and (var126 = 1 or not(var698 = 1)) and
 (var127 = 1 or not(var698 = 1)) and (var130 = 1 or not(var699 = 1)) and (var131
 = 1 or not(var699 = 1)) and (var133 = 1 or not(var699 = 1)) and (var136 = 1 or
not(var699 = 1)) and (var138 = 1 or not(var699 = 1)) and (var140 = 1 or not(
var699 = 1)) and (var142 = 1 or not(var699 = 1)) and (var143 = 1 or not(var699 =
 1)) and (var146 = 1 or not(var700 = 1)) and (var147 = 1 or not(var700 = 1)) and
 (var149 = 1 or not(var700 = 1)) and (var152 = 1 or not(var700 = 1)) and (var154
 = 1 or not(var700 = 1)) and (var156 = 1 or not(var700 = 1)) and (var158 = 1 or
not(var700 = 1)) and (var159 = 1 or not(var700 = 1)) and (var2 = 1 or not(var701
 = 1)) and (var4 = 1 or not(var701 = 1)) and (var5 = 1 or not(var701 = 1)) and (
var8 = 1 or not(var701 = 1)) and (var10 = 1 or not(var701 = 1)) and (var12 = 1
or not(var701 = 1)) and (var14 = 1 or not(var701 = 1)) and (var15 = 1 or not(
var701 = 1)) and (var18 = 1 or not(var702 = 1)) and (var20 = 1 or not(var702 = 1
)) and (var21 = 1 or not(var702 = 1)) and (var24 = 1 or not(var702 = 1)) and (
var26 = 1 or not(var702 = 1)) and (var28 = 1 or not(var702 = 1)) and (var30 = 1
or not(var702 = 1)) and (var31 = 1 or not(var702 = 1)) and (var34 = 1 or not(
var703 = 1)) and (var36 = 1 or not(var703 = 1)) and (var37 = 1 or not(var703 = 1
)) and (var40 = 1 or not(var703 = 1)) and (var42 = 1 or not(var703 = 1)) and (
var44 = 1 or not(var703 = 1)) and (var46 = 1 or not(var703 = 1)) and (var47 = 1
or not(var703 = 1)) and (var50 = 1 or not(var704 = 1)) and (var52 = 1 or not(
var704 = 1)) and (var53 = 1 or not(var704 = 1)) and (var56 = 1 or not(var704 = 1
)) and (var58 = 1 or not(var704 = 1)) and (var60 = 1 or not(var704 = 1)) and (
var62 = 1 or not(var704 = 1)) and (var63 = 1 or not(var704 = 1)) and (var66 = 1
or not(var705 = 1)) and (var68 = 1 or not(var705 = 1)) and (var69 = 1 or not(
var705 = 1)) and (var72 = 1 or not(var705 = 1)) and (var74 = 1 or not(var705 = 1
)) and (var76 = 1 or not(var705 = 1)) and (var78 = 1 or not(var705 = 1)) and (
var79 = 1 or not(var705 = 1)) and (var82 = 1 or not(var706 = 1)) and (var84 = 1
or not(var706 = 1)) and (var85 = 1 or not(var706 = 1)) and (var88 = 1 or not(
var706 = 1)) and (var90 = 1 or not(var706 = 1)) and (var92 = 1 or not(var706 = 1
)) and (var94 = 1 or not(var706 = 1)) and (var95 = 1 or not(var706 = 1)) and (
var98 = 1 or not(var707 = 1)) and (var100 = 1 or not(var707 = 1)) and (var101 =
1 or not(var707 = 1)) and (var104 = 1 or not(var707 = 1)) and (var106 = 1 or not
(var707 = 1)) and (var108 = 1 or not(var707 = 1)) and (var110 = 1 or not(var707
= 1)) and (var111 = 1 or not(var707 = 1)) and (var114 = 1 or not(var708 = 1))
and (var116 = 1 or not(var708 = 1)) and (var117 = 1 or not(var708 = 1)) and (
var120 = 1 or not(var708 = 1)) and (var122 = 1 or not(var708 = 1)) and (var124 =
 1 or not(var708 = 1)) and (var126 = 1 or not(var708 = 1)) and (var127 = 1 or
not(var708 = 1)) and (var130 = 1 or not(var709 = 1)) and (var132 = 1 or not(
var709 = 1)) and (var133 = 1 or not(var709 = 1)) and (var136 = 1 or not(var709 =
 1)) and (var138 = 1 or not(var709 = 1)) and (var140 = 1 or not(var709 = 1)) and
 (var142 = 1 or not(var709 = 1)) and (var143 = 1 or not(var709 = 1)) and (var146
 = 1 or not(var710 = 1)) and (var148 = 1 or not(var710 = 1)) and (var149 = 1 or
not(var710 = 1)) and (var152 = 1 or not(var710 = 1)) and (var154 = 1 or not(
var710 = 1)) and (var156 = 1 or not(var710 = 1)) and (var158 = 1 or not(var710 =
 1)) and (var159 = 1 or not(var710 = 1)) and (var1 = 1 or not(var711 = 1)) and (
var3 = 1 or not(var711 = 1)) and (var5 = 1 or not(var711 = 1)) and (var8 = 1 or
not(var711 = 1)) and (var10 = 1 or not(var711 = 1)) and (var11 = 1 or not(var711
 = 1)) and (var13 = 1 or not(var711 = 1)) and (var16 = 1 or not(var711 = 1)) and
 (var17 = 1 or not(var712 = 1)) and (var19 = 1 or not(var712 = 1)) and (var21 =
1 or not(var712 = 1)) and (var24 = 1 or not(var712 = 1)) and (var26 = 1 or not(
var712 = 1)) and (var27 = 1 or not(var712 = 1)) and (var29 = 1 or not(var712 = 1
)) and (var32 = 1 or not(var712 = 1)) and (var33 = 1 or not(var713 = 1)) and (
var35 = 1 or not(var713 = 1)) and (var37 = 1 or not(var713 = 1)) and (var40 = 1
or not(var713 = 1)) and (var42 = 1 or not(var713 = 1)) and (var43 = 1 or not(
var713 = 1)) and (var45 = 1 or not(var713 = 1)) and (var48 = 1 or not(var713 = 1
)) and (var49 = 1 or not(var714 = 1)) and (var51 = 1 or not(var714 = 1)) and (
var53 = 1 or not(var714 = 1)) and (var56 = 1 or not(var714 = 1)) and (var58 = 1
or not(var714 = 1)) and (var59 = 1 or not(var714 = 1)) and (var61 = 1 or not(
var714 = 1)) and (var64 = 1 or not(var714 = 1)) and (var65 = 1 or not(var715 = 1
)) and (var67 = 1 or not(var715 = 1)) and (var69 = 1 or not(var715 = 1)) and (
var72 = 1 or not(var715 = 1)) and (var74 = 1 or not(var715 = 1)) and (var75 = 1
or not(var715 = 1)) and (var77 = 1 or not(var715 = 1)) and (var80 = 1 or not(
var715 = 1)) and (var81 = 1 or not(var716 = 1)) and (var83 = 1 or not(var716 = 1
)) and (var85 = 1 or not(var716 = 1)) and (var88 = 1 or not(var716 = 1)) and (
var90 = 1 or not(var716 = 1)) and (var91 = 1 or not(var716 = 1)) and (var93 = 1
or not(var716 = 1)) and (var96 = 1 or not(var716 = 1)) and (var97 = 1 or not(
var717 = 1)) and (var99 = 1 or not(var717 = 1)) and (var101 = 1 or not(var717 =
1)) and (var104 = 1 or not(var717 = 1)) and (var106 = 1 or not(var717 = 1)) and
(var107 = 1 or not(var717 = 1)) and (var109 = 1 or not(var717 = 1)) and (var112
= 1 or not(var717 = 1)) and (var113 = 1 or not(var718 = 1)) and (var115 = 1 or
not(var718 = 1)) and (var117 = 1 or not(var718 = 1)) and (var120 = 1 or not(
var718 = 1)) and (var122 = 1 or not(var718 = 1)) and (var123 = 1 or not(var718 =
 1)) and (var125 = 1 or not(var718 = 1)) and (var128 = 1 or not(var718 = 1)) and
 (var129 = 1 or not(var719 = 1)) and (var131 = 1 or not(var719 = 1)) and (var133
 = 1 or not(var719 = 1)) and (var136 = 1 or not(var719 = 1)) and (var138 = 1 or
not(var719 = 1)) and (var139 = 1 or not(var719 = 1)) and (var141 = 1 or not(
var719 = 1)) and (var144 = 1 or not(var719 = 1)) and (var145 = 1 or not(var720 =
 1)) and (var147 = 1 or not(var720 = 1)) and (var149 = 1 or not(var720 = 1)) and
 (var152 = 1 or not(var720 = 1)) and (var154 = 1 or not(var720 = 1)) and (var155
 = 1 or not(var720 = 1)) and (var157 = 1 or not(var720 = 1)) and (var160 = 1 or
not(var720 = 1)) and (var1 = 1 or not(var721 = 1)) and (var4 = 1 or not(var721 =
 1)) and (var6 = 1 or not(var721 = 1)) and (var8 = 1 or not(var721 = 1)) and (
var10 = 1 or not(var721 = 1)) and (var11 = 1 or not(var721 = 1)) and (var13 = 1
or not(var721 = 1)) and (var16 = 1 or not(var721 = 1)) and (var17 = 1 or not(
var722 = 1)) and (var20 = 1 or not(var722 = 1)) and (var22 = 1 or not(var722 = 1
)) and (var24 = 1 or not(var722 = 1)) and (var26 = 1 or not(var722 = 1)) and (
var27 = 1 or not(var722 = 1)) and (var29 = 1 or not(var722 = 1)) and (var32 = 1
or not(var722 = 1)) and (var33 = 1 or not(var723 = 1)) and (var36 = 1 or not(
var723 = 1)) and (var38 = 1 or not(var723 = 1)) and (var40 = 1 or not(var723 = 1
)) and (var42 = 1 or not(var723 = 1)) and (var43 = 1 or not(var723 = 1)) and (
var45 = 1 or not(var723 = 1)) and (var48 = 1 or not(var723 = 1)) and (var49 = 1
or not(var724 = 1)) and (var52 = 1 or not(var724 = 1)) and (var54 = 1 or not(
var724 = 1)) and (var56 = 1 or not(var724 = 1)) and (var58 = 1 or not(var724 = 1
)) and (var59 = 1 or not(var724 = 1)) and (var61 = 1 or not(var724 = 1)) and (
var64 = 1 or not(var724 = 1)) and (var65 = 1 or not(var725 = 1)) and (var68 = 1
or not(var725 = 1)) and (var70 = 1 or not(var725 = 1)) and (var72 = 1 or not(
var725 = 1)) and (var74 = 1 or not(var725 = 1)) and (var75 = 1 or not(var725 = 1
)) and (var77 = 1 or not(var725 = 1)) and (var80 = 1 or not(var725 = 1)) and (
var81 = 1 or not(var726 = 1)) and (var84 = 1 or not(var726 = 1)) and (var86 = 1
or not(var726 = 1)) and (var88 = 1 or not(var726 = 1)) and (var90 = 1 or not(
var726 = 1)) and (var91 = 1 or not(var726 = 1)) and (var93 = 1 or not(var726 = 1
)) and (var96 = 1 or not(var726 = 1)) and (var97 = 1 or not(var727 = 1)) and (
var100 = 1 or not(var727 = 1)) and (var102 = 1 or not(var727 = 1)) and (var104 =
 1 or not(var727 = 1)) and (var106 = 1 or not(var727 = 1)) and (var107 = 1 or
not(var727 = 1)) and (var109 = 1 or not(var727 = 1)) and (var112 = 1 or not(
var727 = 1)) and (var113 = 1 or not(var728 = 1)) and (var116 = 1 or not(var728 =
 1)) and (var118 = 1 or not(var728 = 1)) and (var120 = 1 or not(var728 = 1)) and
 (var122 = 1 or not(var728 = 1)) and (var123 = 1 or not(var728 = 1)) and (var125
 = 1 or not(var728 = 1)) and (var128 = 1 or not(var728 = 1)) and (var129 = 1 or
not(var729 = 1)) and (var132 = 1 or not(var729 = 1)) and (var134 = 1 or not(
var729 = 1)) and (var136 = 1 or not(var729 = 1)) and (var138 = 1 or not(var729 =
 1)) and (var139 = 1 or not(var729 = 1)) and (var141 = 1 or not(var729 = 1)) and
 (var144 = 1 or not(var729 = 1)) and (var145 = 1 or not(var730 = 1)) and (var148
 = 1 or not(var730 = 1)) and (var150 = 1 or not(var730 = 1)) and (var152 = 1 or
not(var730 = 1)) and (var154 = 1 or not(var730 = 1)) and (var155 = 1 or not(
var730 = 1)) and (var157 = 1 or not(var730 = 1)) and (var160 = 1 or not(var730 =
 1)) and (var2 = 1 or not(var731 = 1)) and (var3 = 1 or not(var731 = 1)) and (
var6 = 1 or not(var731 = 1)) and (var8 = 1 or not(var731 = 1)) and (var10 = 1 or
 not(var731 = 1)) and (var12 = 1 or not(var731 = 1)) and (var13 = 1 or not(
var731 = 1)) and (var15 = 1 or not(var731 = 1)) and (var18 = 1 or not(var732 = 1
)) and (var19 = 1 or not(var732 = 1)) and (var22 = 1 or not(var732 = 1)) and (
var24 = 1 or not(var732 = 1)) and (var26 = 1 or not(var732 = 1)) and (var28 = 1
or not(var732 = 1)) and (var29 = 1 or not(var732 = 1)) and (var31 = 1 or not(
var732 = 1)) and (var34 = 1 or not(var733 = 1)) and (var35 = 1 or not(var733 = 1
)) and (var38 = 1 or not(var733 = 1)) and (var40 = 1 or not(var733 = 1)) and (
var42 = 1 or not(var733 = 1)) and (var44 = 1 or not(var733 = 1)) and (var45 = 1
or not(var733 = 1)) and (var47 = 1 or not(var733 = 1)) and (var50 = 1 or not(
var734 = 1)) and (var51 = 1 or not(var734 = 1)) and (var54 = 1 or not(var734 = 1
)) and (var56 = 1 or not(var734 = 1)) and (var58 = 1 or not(var734 = 1)) and (
var60 = 1 or not(var734 = 1)) and (var61 = 1 or not(var734 = 1)) and (var63 = 1
or not(var734 = 1)) and (var66 = 1 or not(var735 = 1)) and (var67 = 1 or not(
var735 = 1)) and (var70 = 1 or not(var735 = 1)) and (var72 = 1 or not(var735 = 1
)) and (var74 = 1 or not(var735 = 1)) and (var76 = 1 or not(var735 = 1)) and (
var77 = 1 or not(var735 = 1)) and (var79 = 1 or not(var735 = 1)) and (var82 = 1
or not(var736 = 1)) and (var83 = 1 or not(var736 = 1)) and (var86 = 1 or not(
var736 = 1)) and (var88 = 1 or not(var736 = 1)) and (var90 = 1 or not(var736 = 1
)) and (var92 = 1 or not(var736 = 1)) and (var93 = 1 or not(var736 = 1)) and (
var95 = 1 or not(var736 = 1)) and (var98 = 1 or not(var737 = 1)) and (var99 = 1
or not(var737 = 1)) and (var102 = 1 or not(var737 = 1)) and (var104 = 1 or not(
var737 = 1)) and (var106 = 1 or not(var737 = 1)) and (var108 = 1 or not(var737 =
 1)) and (var109 = 1 or not(var737 = 1)) and (var111 = 1 or not(var737 = 1)) and
 (var114 = 1 or not(var738 = 1)) and (var115 = 1 or not(var738 = 1)) and (var118
 = 1 or not(var738 = 1)) and (var120 = 1 or not(var738 = 1)) and (var122 = 1 or
not(var738 = 1)) and (var124 = 1 or not(var738 = 1)) and (var125 = 1 or not(
var738 = 1)) and (var127 = 1 or not(var738 = 1)) and (var130 = 1 or not(var739 =
 1)) and (var131 = 1 or not(var739 = 1)) and (var134 = 1 or not(var739 = 1)) and
 (var136 = 1 or not(var739 = 1)) and (var138 = 1 or not(var739 = 1)) and (var140
 = 1 or not(var739 = 1)) and (var141 = 1 or not(var739 = 1)) and (var143 = 1 or
not(var739 = 1)) and (var146 = 1 or not(var740 = 1)) and (var147 = 1 or not(
var740 = 1)) and (var150 = 1 or not(var740 = 1)) and (var152 = 1 or not(var740 =
 1)) and (var154 = 1 or not(var740 = 1)) and (var156 = 1 or not(var740 = 1)) and
 (var157 = 1 or not(var740 = 1)) and (var159 = 1 or not(var740 = 1)) and (var2 =
 1 or not(var741 = 1)) and (var4 = 1 or not(var741 = 1)) and (var5 = 1 or not(
var741 = 1)) and (var7 = 1 or not(var741 = 1)) and (var9 = 1 or not(var741 = 1))
 and (var11 = 1 or not(var741 = 1)) and (var14 = 1 or not(var741 = 1)) and (
var16 = 1 or not(var741 = 1)) and (var18 = 1 or not(var742 = 1)) and (var20 = 1
or not(var742 = 1)) and (var21 = 1 or not(var742 = 1)) and (var23 = 1 or not(
var742 = 1)) and (var25 = 1 or not(var742 = 1)) and (var27 = 1 or not(var742 = 1
)) and (var30 = 1 or not(var742 = 1)) and (var32 = 1 or not(var742 = 1)) and (
var34 = 1 or not(var743 = 1)) and (var36 = 1 or not(var743 = 1)) and (var37 = 1
or not(var743 = 1)) and (var39 = 1 or not(var743 = 1)) and (var41 = 1 or not(
var743 = 1)) and (var43 = 1 or not(var743 = 1)) and (var46 = 1 or not(var743 = 1
)) and (var48 = 1 or not(var743 = 1)) and (var50 = 1 or not(var744 = 1)) and (
var52 = 1 or not(var744 = 1)) and (var53 = 1 or not(var744 = 1)) and (var55 = 1
or not(var744 = 1)) and (var57 = 1 or not(var744 = 1)) and (var59 = 1 or not(
var744 = 1)) and (var62 = 1 or not(var744 = 1)) and (var64 = 1 or not(var744 = 1
)) and (var66 = 1 or not(var745 = 1)) and (var68 = 1 or not(var745 = 1)) and (
var69 = 1 or not(var745 = 1)) and (var71 = 1 or not(var745 = 1)) and (var73 = 1
or not(var745 = 1)) and (var75 = 1 or not(var745 = 1)) and (var78 = 1 or not(
var745 = 1)) and (var80 = 1 or not(var745 = 1)) and (var82 = 1 or not(var746 = 1
)) and (var84 = 1 or not(var746 = 1)) and (var85 = 1 or not(var746 = 1)) and (
var87 = 1 or not(var746 = 1)) and (var89 = 1 or not(var746 = 1)) and (var91 = 1
or not(var746 = 1)) and (var94 = 1 or not(var746 = 1)) and (var96 = 1 or not(
var746 = 1)) and (var98 = 1 or not(var747 = 1)) and (var100 = 1 or not(var747 =
1)) and (var101 = 1 or not(var747 = 1)) and (var103 = 1 or not(var747 = 1)) and
(var105 = 1 or not(var747 = 1)) and (var107 = 1 or not(var747 = 1)) and (var110
= 1 or not(var747 = 1)) and (var112 = 1 or not(var747 = 1)) and (var114 = 1 or
not(var748 = 1)) and (var116 = 1 or not(var748 = 1)) and (var117 = 1 or not(
var748 = 1)) and (var119 = 1 or not(var748 = 1)) and (var121 = 1 or not(var748 =
 1)) and (var123 = 1 or not(var748 = 1)) and (var126 = 1 or not(var748 = 1)) and
 (var128 = 1 or not(var748 = 1)) and (var130 = 1 or not(var749 = 1)) and (var132
 = 1 or not(var749 = 1)) and (var133 = 1 or not(var749 = 1)) and (var135 = 1 or
not(var749 = 1)) and (var137 = 1 or not(var749 = 1)) and (var139 = 1 or not(
var749 = 1)) and (var142 = 1 or not(var749 = 1)) and (var144 = 1 or not(var749 =
 1)) and (var146 = 1 or not(var750 = 1)) and (var148 = 1 or not(var750 = 1)) and
 (var149 = 1 or not(var750 = 1)) and (var151 = 1 or not(var750 = 1)) and (var153
 = 1 or not(var750 = 1)) and (var155 = 1 or not(var750 = 1)) and (var158 = 1 or
not(var750 = 1)) and (var160 = 1 or not(var750 = 1)) and (var2 = 1 or not(var751
 = 1)) and (var4 = 1 or not(var751 = 1)) and (var5 = 1 or not(var751 = 1)) and (
var8 = 1 or not(var751 = 1)) and (var9 = 1 or not(var751 = 1)) and (var11 = 1 or
 not(var751 = 1)) and (var14 = 1 or not(var751 = 1)) and (var15 = 1 or not(
var751 = 1)) and (var18 = 1 or not(var752 = 1)) and (var20 = 1 or not(var752 = 1
)) and (var21 = 1 or not(var752 = 1)) and (var24 = 1 or not(var752 = 1)) and (
var25 = 1 or not(var752 = 1)) and (var27 = 1 or not(var752 = 1)) and (var30 = 1
or not(var752 = 1)) and (var31 = 1 or not(var752 = 1)) and (var34 = 1 or not(
var753 = 1)) and (var36 = 1 or not(var753 = 1)) and (var37 = 1 or not(var753 = 1
)) and (var40 = 1 or not(var753 = 1)) and (var41 = 1 or not(var753 = 1)) and (
var43 = 1 or not(var753 = 1)) and (var46 = 1 or not(var753 = 1)) and (var47 = 1
or not(var753 = 1)) and (var50 = 1 or not(var754 = 1)) and (var52 = 1 or not(
var754 = 1)) and (var53 = 1 or not(var754 = 1)) and (var56 = 1 or not(var754 = 1
)) and (var57 = 1 or not(var754 = 1)) and (var59 = 1 or not(var754 = 1)) and (
var62 = 1 or not(var754 = 1)) and (var63 = 1 or not(var754 = 1)) and (var66 = 1
or not(var755 = 1)) and (var68 = 1 or not(var755 = 1)) and (var69 = 1 or not(
var755 = 1)) and (var72 = 1 or not(var755 = 1)) and (var73 = 1 or not(var755 = 1
)) and (var75 = 1 or not(var755 = 1)) and (var78 = 1 or not(var755 = 1)) and (
var79 = 1 or not(var755 = 1)) and (var82 = 1 or not(var756 = 1)) and (var84 = 1
or not(var756 = 1)) and (var85 = 1 or not(var756 = 1)) and (var88 = 1 or not(
var756 = 1)) and (var89 = 1 or not(var756 = 1)) and (var91 = 1 or not(var756 = 1
)) and (var94 = 1 or not(var756 = 1)) and (var95 = 1 or not(var756 = 1)) and (
var98 = 1 or not(var757 = 1)) and (var100 = 1 or not(var757 = 1)) and (var101 =
1 or not(var757 = 1)) and (var104 = 1 or not(var757 = 1)) and (var105 = 1 or not
(var757 = 1)) and (var107 = 1 or not(var757 = 1)) and (var110 = 1 or not(var757
= 1)) and (var111 = 1 or not(var757 = 1)) and (var114 = 1 or not(var758 = 1))
and (var116 = 1 or not(var758 = 1)) and (var117 = 1 or not(var758 = 1)) and (
var120 = 1 or not(var758 = 1)) and (var121 = 1 or not(var758 = 1)) and (var123 =
 1 or not(var758 = 1)) and (var126 = 1 or not(var758 = 1)) and (var127 = 1 or
not(var758 = 1)) and (var130 = 1 or not(var759 = 1)) and (var132 = 1 or not(
var759 = 1)) and (var133 = 1 or not(var759 = 1)) and (var136 = 1 or not(var759 =
 1)) and (var137 = 1 or not(var759 = 1)) and (var139 = 1 or not(var759 = 1)) and
 (var142 = 1 or not(var759 = 1)) and (var143 = 1 or not(var759 = 1)) and (var146
 = 1 or not(var760 = 1)) and (var148 = 1 or not(var760 = 1)) and (var149 = 1 or
not(var760 = 1)) and (var152 = 1 or not(var760 = 1)) and (var153 = 1 or not(
var760 = 1)) and (var155 = 1 or not(var760 = 1)) and (var158 = 1 or not(var760 =
 1)) and (var159 = 1 or not(var760 = 1)) and (var1 = 1 or not(var761 = 1)) and (
var3 = 1 or not(var761 = 1)) and (var6 = 1 or not(var761 = 1)) and (var8 = 1 or
not(var761 = 1)) and (var10 = 1 or not(var761 = 1)) and (var11 = 1 or not(var761
 = 1)) and (var13 = 1 or not(var761 = 1)) and (var16 = 1 or not(var761 = 1)) and
 (var17 = 1 or not(var762 = 1)) and (var19 = 1 or not(var762 = 1)) and (var22 =
1 or not(var762 = 1)) and (var24 = 1 or not(var762 = 1)) and (var26 = 1 or not(
var762 = 1)) and (var27 = 1 or not(var762 = 1)) and (var29 = 1 or not(var762 = 1
)) and (var32 = 1 or not(var762 = 1)) and (var33 = 1 or not(var763 = 1)) and (
var35 = 1 or not(var763 = 1)) and (var38 = 1 or not(var763 = 1)) and (var40 = 1
or not(var763 = 1)) and (var42 = 1 or not(var763 = 1)) and (var43 = 1 or not(
var763 = 1)) and (var45 = 1 or not(var763 = 1)) and (var48 = 1 or not(var763 = 1
)) and (var49 = 1 or not(var764 = 1)) and (var51 = 1 or not(var764 = 1)) and (
var54 = 1 or not(var764 = 1)) and (var56 = 1 or not(var764 = 1)) and (var58 = 1
or not(var764 = 1)) and (var59 = 1 or not(var764 = 1)) and (var61 = 1 or not(
var764 = 1)) and (var64 = 1 or not(var764 = 1)) and (var65 = 1 or not(var765 = 1
)) and (var67 = 1 or not(var765 = 1)) and (var70 = 1 or not(var765 = 1)) and (
var72 = 1 or not(var765 = 1)) and (var74 = 1 or not(var765 = 1)) and (var75 = 1
or not(var765 = 1)) and (var77 = 1 or not(var765 = 1)) and (var80 = 1 or not(
var765 = 1)) and (var81 = 1 or not(var766 = 1)) and (var83 = 1 or not(var766 = 1
)) and (var86 = 1 or not(var766 = 1)) and (var88 = 1 or not(var766 = 1)) and (
var90 = 1 or not(var766 = 1)) and (var91 = 1 or not(var766 = 1)) and (var93 = 1
or not(var766 = 1)) and (var96 = 1 or not(var766 = 1)) and (var97 = 1 or not(
var767 = 1)) and (var99 = 1 or not(var767 = 1)) and (var102 = 1 or not(var767 =
1)) and (var104 = 1 or not(var767 = 1)) and (var106 = 1 or not(var767 = 1)) and
(var107 = 1 or not(var767 = 1)) and (var109 = 1 or not(var767 = 1)) and (var112
= 1 or not(var767 = 1)) and (var113 = 1 or not(var768 = 1)) and (var115 = 1 or
not(var768 = 1)) and (var118 = 1 or not(var768 = 1)) and (var120 = 1 or not(
var768 = 1)) and (var122 = 1 or not(var768 = 1)) and (var123 = 1 or not(var768 =
 1)) and (var125 = 1 or not(var768 = 1)) and (var128 = 1 or not(var768 = 1)) and
 (var129 = 1 or not(var769 = 1)) and (var131 = 1 or not(var769 = 1)) and (var134
 = 1 or not(var769 = 1)) and (var136 = 1 or not(var769 = 1)) and (var138 = 1 or
not(var769 = 1)) and (var139 = 1 or not(var769 = 1)) and (var141 = 1 or not(
var769 = 1)) and (var144 = 1 or not(var769 = 1)) and (var145 = 1 or not(var770 =
 1)) and (var147 = 1 or not(var770 = 1)) and (var150 = 1 or not(var770 = 1)) and
 (var152 = 1 or not(var770 = 1)) and (var154 = 1 or not(var770 = 1)) and (var155
 = 1 or not(var770 = 1)) and (var157 = 1 or not(var770 = 1)) and (var160 = 1 or
not(var770 = 1)) and (var2 = 1 or not(var771 = 1)) and (var3 = 1 or not(var771 =
 1)) and (var6 = 1 or not(var771 = 1)) and (var8 = 1 or not(var771 = 1)) and (
var10 = 1 or not(var771 = 1)) and (var11 = 1 or not(var771 = 1)) and (var14 = 1
or not(var771 = 1)) and (var15 = 1 or not(var771 = 1)) and (var18 = 1 or not(
var772 = 1)) and (var19 = 1 or not(var772 = 1)) and (var22 = 1 or not(var772 = 1
)) and (var24 = 1 or not(var772 = 1)) and (var26 = 1 or not(var772 = 1)) and (
var27 = 1 or not(var772 = 1)) and (var30 = 1 or not(var772 = 1)) and (var31 = 1
or not(var772 = 1)) and (var34 = 1 or not(var773 = 1)) and (var35 = 1 or not(
var773 = 1)) and (var38 = 1 or not(var773 = 1)) and (var40 = 1 or not(var773 = 1
)) and (var42 = 1 or not(var773 = 1)) and (var43 = 1 or not(var773 = 1)) and (
var46 = 1 or not(var773 = 1)) and (var47 = 1 or not(var773 = 1)) and (var50 = 1
or not(var774 = 1)) and (var51 = 1 or not(var774 = 1)) and (var54 = 1 or not(
var774 = 1)) and (var56 = 1 or not(var774 = 1)) and (var58 = 1 or not(var774 = 1
)) and (var59 = 1 or not(var774 = 1)) and (var62 = 1 or not(var774 = 1)) and (
var63 = 1 or not(var774 = 1)) and (var66 = 1 or not(var775 = 1)) and (var67 = 1
or not(var775 = 1)) and (var70 = 1 or not(var775 = 1)) and (var72 = 1 or not(
var775 = 1)) and (var74 = 1 or not(var775 = 1)) and (var75 = 1 or not(var775 = 1
)) and (var78 = 1 or not(var775 = 1)) and (var79 = 1 or not(var775 = 1)) and (
var82 = 1 or not(var776 = 1)) and (var83 = 1 or not(var776 = 1)) and (var86 = 1
or not(var776 = 1)) and (var88 = 1 or not(var776 = 1)) and (var90 = 1 or not(
var776 = 1)) and (var91 = 1 or not(var776 = 1)) and (var94 = 1 or not(var776 = 1
)) and (var95 = 1 or not(var776 = 1)) and (var98 = 1 or not(var777 = 1)) and (
var99 = 1 or not(var777 = 1)) and (var102 = 1 or not(var777 = 1)) and (var104 =
1 or not(var777 = 1)) and (var106 = 1 or not(var777 = 1)) and (var107 = 1 or not
(var777 = 1)) and (var110 = 1 or not(var777 = 1)) and (var111 = 1 or not(var777
= 1)) and (var114 = 1 or not(var778 = 1)) and (var115 = 1 or not(var778 = 1))
and (var118 = 1 or not(var778 = 1)) and (var120 = 1 or not(var778 = 1)) and (
var122 = 1 or not(var778 = 1)) and (var123 = 1 or not(var778 = 1)) and (var126 =
 1 or not(var778 = 1)) and (var127 = 1 or not(var778 = 1)) and (var130 = 1 or
not(var779 = 1)) and (var131 = 1 or not(var779 = 1)) and (var134 = 1 or not(
var779 = 1)) and (var136 = 1 or not(var779 = 1)) and (var138 = 1 or not(var779 =
 1)) and (var139 = 1 or not(var779 = 1)) and (var142 = 1 or not(var779 = 1)) and
 (var143 = 1 or not(var779 = 1)) and (var146 = 1 or not(var780 = 1)) and (var147
 = 1 or not(var780 = 1)) and (var150 = 1 or not(var780 = 1)) and (var152 = 1 or
not(var780 = 1)) and (var154 = 1 or not(var780 = 1)) and (var155 = 1 or not(
var780 = 1)) and (var158 = 1 or not(var780 = 1)) and (var159 = 1 or not(var780 =
 1)) and (var2 = 1 or not(var781 = 1)) and (var3 = 1 or not(var781 = 1)) and (
var6 = 1 or not(var781 = 1)) and (var7 = 1 or not(var781 = 1)) and (var9 = 1 or
not(var781 = 1)) and (var12 = 1 or not(var781 = 1)) and (var14 = 1 or not(var781
 = 1)) and (var16 = 1 or not(var781 = 1)) and (var18 = 1 or not(var782 = 1)) and
 (var19 = 1 or not(var782 = 1)) and (var22 = 1 or not(var782 = 1)) and (var23 =
1 or not(var782 = 1)) and (var25 = 1 or not(var782 = 1)) and (var28 = 1 or not(
var782 = 1)) and (var30 = 1 or not(var782 = 1)) and (var32 = 1 or not(var782 = 1
)) and (var34 = 1 or not(var783 = 1)) and (var35 = 1 or not(var783 = 1)) and (
var38 = 1 or not(var783 = 1)) and (var39 = 1 or not(var783 = 1)) and (var41 = 1
or not(var783 = 1)) and (var44 = 1 or not(var783 = 1)) and (var46 = 1 or not(
var783 = 1)) and (var48 = 1 or not(var783 = 1)) and (var50 = 1 or not(var784 = 1
)) and (var51 = 1 or not(var784 = 1)) and (var54 = 1 or not(var784 = 1)) and (
var55 = 1 or not(var784 = 1)) and (var57 = 1 or not(var784 = 1)) and (var60 = 1
or not(var784 = 1)) and (var62 = 1 or not(var784 = 1)) and (var64 = 1 or not(
var784 = 1)) and (var66 = 1 or not(var785 = 1)) and (var67 = 1 or not(var785 = 1
)) and (var70 = 1 or not(var785 = 1)) and (var71 = 1 or not(var785 = 1)) and (
var73 = 1 or not(var785 = 1)) and (var76 = 1 or not(var785 = 1)) and (var78 = 1
or not(var785 = 1)) and (var80 = 1 or not(var785 = 1)) and (var82 = 1 or not(
var786 = 1)) and (var83 = 1 or not(var786 = 1)) and (var86 = 1 or not(var786 = 1
)) and (var87 = 1 or not(var786 = 1)) and (var89 = 1 or not(var786 = 1)) and (
var92 = 1 or not(var786 = 1)) and (var94 = 1 or not(var786 = 1)) and (var96 = 1
or not(var786 = 1)) and (var98 = 1 or not(var787 = 1)) and (var99 = 1 or not(
var787 = 1)) and (var102 = 1 or not(var787 = 1)) and (var103 = 1 or not(var787 =
 1)) and (var105 = 1 or not(var787 = 1)) and (var108 = 1 or not(var787 = 1)) and
 (var110 = 1 or not(var787 = 1)) and (var112 = 1 or not(var787 = 1)) and (var114
 = 1 or not(var788 = 1)) and (var115 = 1 or not(var788 = 1)) and (var118 = 1 or
not(var788 = 1)) and (var119 = 1 or not(var788 = 1)) and (var121 = 1 or not(
var788 = 1)) and (var124 = 1 or not(var788 = 1)) and (var126 = 1 or not(var788 =
 1)) and (var128 = 1 or not(var788 = 1)) and (var130 = 1 or not(var789 = 1)) and
 (var131 = 1 or not(var789 = 1)) and (var134 = 1 or not(var789 = 1)) and (var135
 = 1 or not(var789 = 1)) and (var137 = 1 or not(var789 = 1)) and (var140 = 1 or
not(var789 = 1)) and (var142 = 1 or not(var789 = 1)) and (var144 = 1 or not(
var789 = 1)) and (var146 = 1 or not(var790 = 1)) and (var147 = 1 or not(var790 =
 1)) and (var150 = 1 or not(var790 = 1)) and (var151 = 1 or not(var790 = 1)) and
 (var153 = 1 or not(var790 = 1)) and (var156 = 1 or not(var790 = 1)) and (var158
 = 1 or not(var790 = 1)) and (var160 = 1 or not(var790 = 1)) and (var1 = 1 or
not(var791 = 1)) and (var3 = 1 or not(var791 = 1)) and (var5 = 1 or not(var791 =
 1)) and (var7 = 1 or not(var791 = 1)) and (var10 = 1 or not(var791 = 1)) and (
var12 = 1 or not(var791 = 1)) and (var13 = 1 or not(var791 = 1)) and (var15 = 1
or not(var791 = 1)) and (var17 = 1 or not(var792 = 1)) and (var19 = 1 or not(
var792 = 1)) and (var21 = 1 or not(var792 = 1)) and (var23 = 1 or not(var792 = 1
)) and (var26 = 1 or not(var792 = 1)) and (var28 = 1 or not(var792 = 1)) and (
var29 = 1 or not(var792 = 1)) and (var31 = 1 or not(var792 = 1)) and (var33 = 1
or not(var793 = 1)) and (var35 = 1 or not(var793 = 1)) and (var37 = 1 or not(
var793 = 1)) and (var39 = 1 or not(var793 = 1)) and (var42 = 1 or not(var793 = 1
)) and (var44 = 1 or not(var793 = 1)) and (var45 = 1 or not(var793 = 1)) and (
var47 = 1 or not(var793 = 1)) and (var49 = 1 or not(var794 = 1)) and (var51 = 1
or not(var794 = 1)) and (var53 = 1 or not(var794 = 1)) and (var55 = 1 or not(
var794 = 1)) and (var58 = 1 or not(var794 = 1)) and (var60 = 1 or not(var794 = 1
)) and (var61 = 1 or not(var794 = 1)) and (var63 = 1 or not(var794 = 1)) and (
var65 = 1 or not(var795 = 1)) and (var67 = 1 or not(var795 = 1)) and (var69 = 1
or not(var795 = 1)) and (var71 = 1 or not(var795 = 1)) and (var74 = 1 or not(
var795 = 1)) and (var76 = 1 or not(var795 = 1)) and (var77 = 1 or not(var795 = 1
)) and (var79 = 1 or not(var795 = 1)) and (var81 = 1 or not(var796 = 1)) and (
var83 = 1 or not(var796 = 1)) and (var85 = 1 or not(var796 = 1)) and (var87 = 1
or not(var796 = 1)) and (var90 = 1 or not(var796 = 1)) and (var92 = 1 or not(
var796 = 1)) and (var93 = 1 or not(var796 = 1)) and (var95 = 1 or not(var796 = 1
)) and (var97 = 1 or not(var797 = 1)) and (var99 = 1 or not(var797 = 1)) and (
var101 = 1 or not(var797 = 1)) and (var103 = 1 or not(var797 = 1)) and (var106 =
 1 or not(var797 = 1)) and (var108 = 1 or not(var797 = 1)) and (var109 = 1 or
not(var797 = 1)) and (var111 = 1 or not(var797 = 1)) and (var113 = 1 or not(
var798 = 1)) and (var115 = 1 or not(var798 = 1)) and (var117 = 1 or not(var798 =
 1)) and (var119 = 1 or not(var798 = 1)) and (var122 = 1 or not(var798 = 1)) and
 (var124 = 1 or not(var798 = 1)) and (var125 = 1 or not(var798 = 1)) and (var127
 = 1 or not(var798 = 1)) and (var129 = 1 or not(var799 = 1)) and (var131 = 1 or
not(var799 = 1)) and (var133 = 1 or not(var799 = 1)) and (var135 = 1 or not(
var799 = 1)) and (var138 = 1 or not(var799 = 1)) and (var140 = 1 or not(var799 =
 1)) and (var141 = 1 or not(var799 = 1)) and (var143 = 1 or not(var799 = 1)) and
 (var145 = 1 or not(var800 = 1)) and (var147 = 1 or not(var800 = 1)) and (var149
 = 1 or not(var800 = 1)) and (var151 = 1 or not(var800 = 1)) and (var154 = 1 or
not(var800 = 1)) and (var156 = 1 or not(var800 = 1)) and (var157 = 1 or not(
var800 = 1)) and (var159 = 1 or not(var800 = 1)) and (var2 = 1 or not(var801 = 1
)) and (var3 = 1 or not(var801 = 1)) and (var6 = 1 or not(var801 = 1)) and (var7
 = 1 or not(var801 = 1)) and (var10 = 1 or not(var801 = 1)) and (var11 = 1 or
not(var801 = 1)) and (var13 = 1 or not(var801 = 1)) and (var16 = 1 or not(var801
 = 1)) and (var18 = 1 or not(var802 = 1)) and (var19 = 1 or not(var802 = 1)) and
 (var22 = 1 or not(var802 = 1)) and (var23 = 1 or not(var802 = 1)) and (var26 =
1 or not(var802 = 1)) and (var27 = 1 or not(var802 = 1)) and (var29 = 1 or not(
var802 = 1)) and (var32 = 1 or not(var802 = 1)) and (var34 = 1 or not(var803 = 1
)) and (var35 = 1 or not(var803 = 1)) and (var38 = 1 or not(var803 = 1)) and (
var39 = 1 or not(var803 = 1)) and (var42 = 1 or not(var803 = 1)) and (var43 = 1
or not(var803 = 1)) and (var45 = 1 or not(var803 = 1)) and (var48 = 1 or not(
var803 = 1)) and (var50 = 1 or not(var804 = 1)) and (var51 = 1 or not(var804 = 1
)) and (var54 = 1 or not(var804 = 1)) and (var55 = 1 or not(var804 = 1)) and (
var58 = 1 or not(var804 = 1)) and (var59 = 1 or not(var804 = 1)) and (var61 = 1
or not(var804 = 1)) and (var64 = 1 or not(var804 = 1)) and (var66 = 1 or not(
var805 = 1)) and (var67 = 1 or not(var805 = 1)) and (var70 = 1 or not(var805 = 1
)) and (var71 = 1 or not(var805 = 1)) and (var74 = 1 or not(var805 = 1)) and (
var75 = 1 or not(var805 = 1)) and (var77 = 1 or not(var805 = 1)) and (var80 = 1
or not(var805 = 1)) and (var82 = 1 or not(var806 = 1)) and (var83 = 1 or not(
var806 = 1)) and (var86 = 1 or not(var806 = 1)) and (var87 = 1 or not(var806 = 1
)) and (var90 = 1 or not(var806 = 1)) and (var91 = 1 or not(var806 = 1)) and (
var93 = 1 or not(var806 = 1)) and (var96 = 1 or not(var806 = 1)) and (var98 = 1
or not(var807 = 1)) and (var99 = 1 or not(var807 = 1)) and (var102 = 1 or not(
var807 = 1)) and (var103 = 1 or not(var807 = 1)) and (var106 = 1 or not(var807 =
 1)) and (var107 = 1 or not(var807 = 1)) and (var109 = 1 or not(var807 = 1)) and
 (var112 = 1 or not(var807 = 1)) and (var114 = 1 or not(var808 = 1)) and (var115
 = 1 or not(var808 = 1)) and (var118 = 1 or not(var808 = 1)) and (var119 = 1 or
not(var808 = 1)) and (var122 = 1 or not(var808 = 1)) and (var123 = 1 or not(
var808 = 1)) and (var125 = 1 or not(var808 = 1)) and (var128 = 1 or not(var808 =
 1)) and (var130 = 1 or not(var809 = 1)) and (var131 = 1 or not(var809 = 1)) and
 (var134 = 1 or not(var809 = 1)) and (var135 = 1 or not(var809 = 1)) and (var138
 = 1 or not(var809 = 1)) and (var139 = 1 or not(var809 = 1)) and (var141 = 1 or
not(var809 = 1)) and (var144 = 1 or not(var809 = 1)) and (var146 = 1 or not(
var810 = 1)) and (var147 = 1 or not(var810 = 1)) and (var150 = 1 or not(var810 =
 1)) and (var151 = 1 or not(var810 = 1)) and (var154 = 1 or not(var810 = 1)) and
 (var155 = 1 or not(var810 = 1)) and (var157 = 1 or not(var810 = 1)) and (var160
 = 1 or not(var810 = 1)) and (var1 = 1 or not(var811 = 1)) and (var3 = 1 or not(
var811 = 1)) and (var6 = 1 or not(var811 = 1)) and (var8 = 1 or not(var811 = 1))
 and (var9 = 1 or not(var811 = 1)) and (var11 = 1 or not(var811 = 1)) and (var14
 = 1 or not(var811 = 1)) and (var16 = 1 or not(var811 = 1)) and (var17 = 1 or
not(var812 = 1)) and (var19 = 1 or not(var812 = 1)) and (var22 = 1 or not(var812
 = 1)) and (var24 = 1 or not(var812 = 1)) and (var25 = 1 or not(var812 = 1)) and
 (var27 = 1 or not(var812 = 1)) and (var30 = 1 or not(var812 = 1)) and (var32 =
1 or not(var812 = 1)) and (var33 = 1 or not(var813 = 1)) and (var35 = 1 or not(
var813 = 1)) and (var38 = 1 or not(var813 = 1)) and (var40 = 1 or not(var813 = 1
)) and (var41 = 1 or not(var813 = 1)) and (var43 = 1 or not(var813 = 1)) and (
var46 = 1 or not(var813 = 1)) and (var48 = 1 or not(var813 = 1)) and (var49 = 1
or not(var814 = 1)) and (var51 = 1 or not(var814 = 1)) and (var54 = 1 or not(
var814 = 1)) and (var56 = 1 or not(var814 = 1)) and (var57 = 1 or not(var814 = 1
)) and (var59 = 1 or not(var814 = 1)) and (var62 = 1 or not(var814 = 1)) and (
var64 = 1 or not(var814 = 1)) and (var65 = 1 or not(var815 = 1)) and (var67 = 1
or not(var815 = 1)) and (var70 = 1 or not(var815 = 1)) and (var72 = 1 or not(
var815 = 1)) and (var73 = 1 or not(var815 = 1)) and (var75 = 1 or not(var815 = 1
)) and (var78 = 1 or not(var815 = 1)) and (var80 = 1 or not(var815 = 1)) and (
var81 = 1 or not(var816 = 1)) and (var83 = 1 or not(var816 = 1)) and (var86 = 1
or not(var816 = 1)) and (var88 = 1 or not(var816 = 1)) and (var89 = 1 or not(
var816 = 1)) and (var91 = 1 or not(var816 = 1)) and (var94 = 1 or not(var816 = 1
)) and (var96 = 1 or not(var816 = 1)) and (var97 = 1 or not(var817 = 1)) and (
var99 = 1 or not(var817 = 1)) and (var102 = 1 or not(var817 = 1)) and (var104 =
1 or not(var817 = 1)) and (var105 = 1 or not(var817 = 1)) and (var107 = 1 or not
(var817 = 1)) and (var110 = 1 or not(var817 = 1)) and (var112 = 1 or not(var817
= 1)) and (var113 = 1 or not(var818 = 1)) and (var115 = 1 or not(var818 = 1))
and (var118 = 1 or not(var818 = 1)) and (var120 = 1 or not(var818 = 1)) and (
var121 = 1 or not(var818 = 1)) and (var123 = 1 or not(var818 = 1)) and (var126 =
 1 or not(var818 = 1)) and (var128 = 1 or not(var818 = 1)) and (var129 = 1 or
not(var819 = 1)) and (var131 = 1 or not(var819 = 1)) and (var134 = 1 or not(
var819 = 1)) and (var136 = 1 or not(var819 = 1)) and (var137 = 1 or not(var819 =
 1)) and (var139 = 1 or not(var819 = 1)) and (var142 = 1 or not(var819 = 1)) and
 (var144 = 1 or not(var819 = 1)) and (var145 = 1 or not(var820 = 1)) and (var147
 = 1 or not(var820 = 1)) and (var150 = 1 or not(var820 = 1)) and (var152 = 1 or
not(var820 = 1)) and (var153 = 1 or not(var820 = 1)) and (var155 = 1 or not(
var820 = 1)) and (var158 = 1 or not(var820 = 1)) and (var160 = 1 or not(var820 =
 1)) and (var1 = 1 or not(var821 = 1)) and (var4 = 1 or not(var821 = 1)) and (
var5 = 1 or not(var821 = 1)) and (var8 = 1 or not(var821 = 1)) and (var9 = 1 or
not(var821 = 1)) and (var12 = 1 or not(var821 = 1)) and (var14 = 1 or not(var821
 = 1)) and (var16 = 1 or not(var821 = 1)) and (var17 = 1 or not(var822 = 1)) and
 (var20 = 1 or not(var822 = 1)) and (var21 = 1 or not(var822 = 1)) and (var24 =
1 or not(var822 = 1)) and (var25 = 1 or not(var822 = 1)) and (var28 = 1 or not(
var822 = 1)) and (var30 = 1 or not(var822 = 1)) and (var32 = 1 or not(var822 = 1
)) and (var33 = 1 or not(var823 = 1)) and (var36 = 1 or not(var823 = 1)) and (
var37 = 1 or not(var823 = 1)) and (var40 = 1 or not(var823 = 1)) and (var41 = 1
or not(var823 = 1)) and (var44 = 1 or not(var823 = 1)) and (var46 = 1 or not(
var823 = 1)) and (var48 = 1 or not(var823 = 1)) and (var49 = 1 or not(var824 = 1
)) and (var52 = 1 or not(var824 = 1)) and (var53 = 1 or not(var824 = 1)) and (
var56 = 1 or not(var824 = 1)) and (var57 = 1 or not(var824 = 1)) and (var60 = 1
or not(var824 = 1)) and (var62 = 1 or not(var824 = 1)) and (var64 = 1 or not(
var824 = 1)) and (var65 = 1 or not(var825 = 1)) and (var68 = 1 or not(var825 = 1
)) and (var69 = 1 or not(var825 = 1)) and (var72 = 1 or not(var825 = 1)) and (
var73 = 1 or not(var825 = 1)) and (var76 = 1 or not(var825 = 1)) and (var78 = 1
or not(var825 = 1)) and (var80 = 1 or not(var825 = 1)) and (var81 = 1 or not(
var826 = 1)) and (var84 = 1 or not(var826 = 1)) and (var85 = 1 or not(var826 = 1
)) and (var88 = 1 or not(var826 = 1)) and (var89 = 1 or not(var826 = 1)) and (
var92 = 1 or not(var826 = 1)) and (var94 = 1 or not(var826 = 1)) and (var96 = 1
or not(var826 = 1)) and (var97 = 1 or not(var827 = 1)) and (var100 = 1 or not(
var827 = 1)) and (var101 = 1 or not(var827 = 1)) and (var104 = 1 or not(var827 =
 1)) and (var105 = 1 or not(var827 = 1)) and (var108 = 1 or not(var827 = 1)) and
 (var110 = 1 or not(var827 = 1)) and (var112 = 1 or not(var827 = 1)) and (var113
 = 1 or not(var828 = 1)) and (var116 = 1 or not(var828 = 1)) and (var117 = 1 or
not(var828 = 1)) and (var120 = 1 or not(var828 = 1)) and (var121 = 1 or not(
var828 = 1)) and (var124 = 1 or not(var828 = 1)) and (var126 = 1 or not(var828 =
 1)) and (var128 = 1 or not(var828 = 1)) and (var129 = 1 or not(var829 = 1)) and
 (var132 = 1 or not(var829 = 1)) and (var133 = 1 or not(var829 = 1)) and (var136
 = 1 or not(var829 = 1)) and (var137 = 1 or not(var829 = 1)) and (var140 = 1 or
not(var829 = 1)) and (var142 = 1 or not(var829 = 1)) and (var144 = 1 or not(
var829 = 1)) and (var145 = 1 or not(var830 = 1)) and (var148 = 1 or not(var830 =
 1)) and (var149 = 1 or not(var830 = 1)) and (var152 = 1 or not(var830 = 1)) and
 (var153 = 1 or not(var830 = 1)) and (var156 = 1 or not(var830 = 1)) and (var158
 = 1 or not(var830 = 1)) and (var160 = 1 or not(var830 = 1)) and (var1 = 1 or
not(var831 = 1)) and (var3 = 1 or not(var831 = 1)) and (var5 = 1 or not(var831 =
 1)) and (var8 = 1 or not(var831 = 1)) and (var9 = 1 or not(var831 = 1)) and (
var12 = 1 or not(var831 = 1)) and (var14 = 1 or not(var831 = 1)) and (var16 = 1
or not(var831 = 1)) and (var17 = 1 or not(var832 = 1)) and (var19 = 1 or not(
var832 = 1)) and (var21 = 1 or not(var832 = 1)) and (var24 = 1 or not(var832 = 1
)) and (var25 = 1 or not(var832 = 1)) and (var28 = 1 or not(var832 = 1)) and (
var30 = 1 or not(var832 = 1)) and (var32 = 1 or not(var832 = 1)) and (var33 = 1
or not(var833 = 1)) and (var35 = 1 or not(var833 = 1)) and (var37 = 1 or not(
var833 = 1)) and (var40 = 1 or not(var833 = 1)) and (var41 = 1 or not(var833 = 1
)) and (var44 = 1 or not(var833 = 1)) and (var46 = 1 or not(var833 = 1)) and (
var48 = 1 or not(var833 = 1)) and (var49 = 1 or not(var834 = 1)) and (var51 = 1
or not(var834 = 1)) and (var53 = 1 or not(var834 = 1)) and (var56 = 1 or not(
var834 = 1)) and (var57 = 1 or not(var834 = 1)) and (var60 = 1 or not(var834 = 1
)) and (var62 = 1 or not(var834 = 1)) and (var64 = 1 or not(var834 = 1)) and (
var65 = 1 or not(var835 = 1)) and (var67 = 1 or not(var835 = 1)) and (var69 = 1
or not(var835 = 1)) and (var72 = 1 or not(var835 = 1)) and (var73 = 1 or not(
var835 = 1)) and (var76 = 1 or not(var835 = 1)) and (var78 = 1 or not(var835 = 1
)) and (var80 = 1 or not(var835 = 1)) and (var81 = 1 or not(var836 = 1)) and (
var83 = 1 or not(var836 = 1)) and (var85 = 1 or not(var836 = 1)) and (var88 = 1
or not(var836 = 1)) and (var89 = 1 or not(var836 = 1)) and (var92 = 1 or not(
var836 = 1)) and (var94 = 1 or not(var836 = 1)) and (var96 = 1 or not(var836 = 1
)) and (var97 = 1 or not(var837 = 1)) and (var99 = 1 or not(var837 = 1)) and (
var101 = 1 or not(var837 = 1)) and (var104 = 1 or not(var837 = 1)) and (var105 =
 1 or not(var837 = 1)) and (var108 = 1 or not(var837 = 1)) and (var110 = 1 or
not(var837 = 1)) and (var112 = 1 or not(var837 = 1)) and (var113 = 1 or not(
var838 = 1)) and (var115 = 1 or not(var838 = 1)) and (var117 = 1 or not(var838 =
 1)) and (var120 = 1 or not(var838 = 1)) and (var121 = 1 or not(var838 = 1)) and
 (var124 = 1 or not(var838 = 1)) and (var126 = 1 or not(var838 = 1)) and (var128
 = 1 or not(var838 = 1)) and (var129 = 1 or not(var839 = 1)) and (var131 = 1 or
not(var839 = 1)) and (var133 = 1 or not(var839 = 1)) and (var136 = 1 or not(
var839 = 1)) and (var137 = 1 or not(var839 = 1)) and (var140 = 1 or not(var839 =
 1)) and (var142 = 1 or not(var839 = 1)) and (var144 = 1 or not(var839 = 1)) and
 (var145 = 1 or not(var840 = 1)) and (var147 = 1 or not(var840 = 1)) and (var149
 = 1 or not(var840 = 1)) and (var152 = 1 or not(var840 = 1)) and (var153 = 1 or
not(var840 = 1)) and (var156 = 1 or not(var840 = 1)) and (var158 = 1 or not(
var840 = 1)) and (var160 = 1 or not(var840 = 1)) and (var2 = 1 or not(var841 = 1
)) and (var3 = 1 or not(var841 = 1)) and (var5 = 1 or not(var841 = 1)) and (var7
 = 1 or not(var841 = 1)) and (var9 = 1 or not(var841 = 1)) and (var12 = 1 or not
(var841 = 1)) and (var13 = 1 or not(var841 = 1)) and (var15 = 1 or not(var841 =
1)) and (var18 = 1 or not(var842 = 1)) and (var19 = 1 or not(var842 = 1)) and (
var21 = 1 or not(var842 = 1)) and (var23 = 1 or not(var842 = 1)) and (var25 = 1
or not(var842 = 1)) and (var28 = 1 or not(var842 = 1)) and (var29 = 1 or not(
var842 = 1)) and (var31 = 1 or not(var842 = 1)) and (var34 = 1 or not(var843 = 1
)) and (var35 = 1 or not(var843 = 1)) and (var37 = 1 or not(var843 = 1)) and (
var39 = 1 or not(var843 = 1)) and (var41 = 1 or not(var843 = 1)) and (var44 = 1
or not(var843 = 1)) and (var45 = 1 or not(var843 = 1)) and (var47 = 1 or not(
var843 = 1)) and (var50 = 1 or not(var844 = 1)) and (var51 = 1 or not(var844 = 1
)) and (var53 = 1 or not(var844 = 1)) and (var55 = 1 or not(var844 = 1)) and (
var57 = 1 or not(var844 = 1)) and (var60 = 1 or not(var844 = 1)) and (var61 = 1
or not(var844 = 1)) and (var63 = 1 or not(var844 = 1)) and (var66 = 1 or not(
var845 = 1)) and (var67 = 1 or not(var845 = 1)) and (var69 = 1 or not(var845 = 1
)) and (var71 = 1 or not(var845 = 1)) and (var73 = 1 or not(var845 = 1)) and (
var76 = 1 or not(var845 = 1)) and (var77 = 1 or not(var845 = 1)) and (var79 = 1
or not(var845 = 1)) and (var82 = 1 or not(var846 = 1)) and (var83 = 1 or not(
var846 = 1)) and (var85 = 1 or not(var846 = 1)) and (var87 = 1 or not(var846 = 1
)) and (var89 = 1 or not(var846 = 1)) and (var92 = 1 or not(var846 = 1)) and (
var93 = 1 or not(var846 = 1)) and (var95 = 1 or not(var846 = 1)) and (var98 = 1
or not(var847 = 1)) and (var99 = 1 or not(var847 = 1)) and (var101 = 1 or not(
var847 = 1)) and (var103 = 1 or not(var847 = 1)) and (var105 = 1 or not(var847 =
 1)) and (var108 = 1 or not(var847 = 1)) and (var109 = 1 or not(var847 = 1)) and
 (var111 = 1 or not(var847 = 1)) and (var114 = 1 or not(var848 = 1)) and (var115
 = 1 or not(var848 = 1)) and (var117 = 1 or not(var848 = 1)) and (var119 = 1 or
not(var848 = 1)) and (var121 = 1 or not(var848 = 1)) and (var124 = 1 or not(
var848 = 1)) and (var125 = 1 or not(var848 = 1)) and (var127 = 1 or not(var848 =
 1)) and (var130 = 1 or not(var849 = 1)) and (var131 = 1 or not(var849 = 1)) and
 (var133 = 1 or not(var849 = 1)) and (var135 = 1 or not(var849 = 1)) and (var137
 = 1 or not(var849 = 1)) and (var140 = 1 or not(var849 = 1)) and (var141 = 1 or
not(var849 = 1)) and (var143 = 1 or not(var849 = 1)) and (var146 = 1 or not(
var850 = 1)) and (var147 = 1 or not(var850 = 1)) and (var149 = 1 or not(var850 =
 1)) and (var151 = 1 or not(var850 = 1)) and (var153 = 1 or not(var850 = 1)) and
 (var156 = 1 or not(var850 = 1)) and (var157 = 1 or not(var850 = 1)) and (var159
 = 1 or not(var850 = 1)) and (var2 = 1 or not(var851 = 1)) and (var4 = 1 or not(
var851 = 1)) and (var5 = 1 or not(var851 = 1)) and (var8 = 1 or not(var851 = 1))
 and (var9 = 1 or not(var851 = 1)) and (var11 = 1 or not(var851 = 1)) and (var14
 = 1 or not(var851 = 1)) and (var16 = 1 or not(var851 = 1)) and (var18 = 1 or
not(var852 = 1)) and (var20 = 1 or not(var852 = 1)) and (var21 = 1 or not(var852
 = 1)) and (var24 = 1 or not(var852 = 1)) and (var25 = 1 or not(var852 = 1)) and
 (var27 = 1 or not(var852 = 1)) and (var30 = 1 or not(var852 = 1)) and (var32 =
1 or not(var852 = 1)) and (var34 = 1 or not(var853 = 1)) and (var36 = 1 or not(
var853 = 1)) and (var37 = 1 or not(var853 = 1)) and (var40 = 1 or not(var853 = 1
)) and (var41 = 1 or not(var853 = 1)) and (var43 = 1 or not(var853 = 1)) and (
var46 = 1 or not(var853 = 1)) and (var48 = 1 or not(var853 = 1)) and (var50 = 1
or not(var854 = 1)) and (var52 = 1 or not(var854 = 1)) and (var53 = 1 or not(
var854 = 1)) and (var56 = 1 or not(var854 = 1)) and (var57 = 1 or not(var854 = 1
)) and (var59 = 1 or not(var854 = 1)) and (var62 = 1 or not(var854 = 1)) and (
var64 = 1 or not(var854 = 1)) and (var66 = 1 or not(var855 = 1)) and (var68 = 1
or not(var855 = 1)) and (var69 = 1 or not(var855 = 1)) and (var72 = 1 or not(
var855 = 1)) and (var73 = 1 or not(var855 = 1)) and (var75 = 1 or not(var855 = 1
)) and (var78 = 1 or not(var855 = 1)) and (var80 = 1 or not(var855 = 1)) and (
var82 = 1 or not(var856 = 1)) and (var84 = 1 or not(var856 = 1)) and (var85 = 1
or not(var856 = 1)) and (var88 = 1 or not(var856 = 1)) and (var89 = 1 or not(
var856 = 1)) and (var91 = 1 or not(var856 = 1)) and (var94 = 1 or not(var856 = 1
)) and (var96 = 1 or not(var856 = 1)) and (var98 = 1 or not(var857 = 1)) and (
var100 = 1 or not(var857 = 1)) and (var101 = 1 or not(var857 = 1)) and (var104 =
 1 or not(var857 = 1)) and (var105 = 1 or not(var857 = 1)) and (var107 = 1 or
not(var857 = 1)) and (var110 = 1 or not(var857 = 1)) and (var112 = 1 or not(
var857 = 1)) and (var114 = 1 or not(var858 = 1)) and (var116 = 1 or not(var858 =
 1)) and (var117 = 1 or not(var858 = 1)) and (var120 = 1 or not(var858 = 1)) and
 (var121 = 1 or not(var858 = 1)) and (var123 = 1 or not(var858 = 1)) and (var126
 = 1 or not(var858 = 1)) and (var128 = 1 or not(var858 = 1)) and (var130 = 1 or
not(var859 = 1)) and (var132 = 1 or not(var859 = 1)) and (var133 = 1 or not(
var859 = 1)) and (var136 = 1 or not(var859 = 1)) and (var137 = 1 or not(var859 =
 1)) and (var139 = 1 or not(var859 = 1)) and (var142 = 1 or not(var859 = 1)) and
 (var144 = 1 or not(var859 = 1)) and (var146 = 1 or not(var860 = 1)) and (var148
 = 1 or not(var860 = 1)) and (var149 = 1 or not(var860 = 1)) and (var152 = 1 or
not(var860 = 1)) and (var153 = 1 or not(var860 = 1)) and (var155 = 1 or not(
var860 = 1)) and (var158 = 1 or not(var860 = 1)) and (var160 = 1 or not(var860 =
 1)) and (var1 = 1 or not(var861 = 1)) and (var3 = 1 or not(var861 = 1)) and (
var5 = 1 or not(var861 = 1)) and (var7 = 1 or not(var861 = 1)) and (var10 = 1 or
 not(var861 = 1)) and (var12 = 1 or not(var861 = 1)) and (var13 = 1 or not(
var861 = 1)) and (var16 = 1 or not(var861 = 1)) and (var17 = 1 or not(var862 = 1
)) and (var19 = 1 or not(var862 = 1)) and (var21 = 1 or not(var862 = 1)) and (
var23 = 1 or not(var862 = 1)) and (var26 = 1 or not(var862 = 1)) and (var28 = 1
or not(var862 = 1)) and (var29 = 1 or not(var862 = 1)) and (var32 = 1 or not(
var862 = 1)) and (var33 = 1 or not(var863 = 1)) and (var35 = 1 or not(var863 = 1
)) and (var37 = 1 or not(var863 = 1)) and (var39 = 1 or not(var863 = 1)) and (
var42 = 1 or not(var863 = 1)) and (var44 = 1 or not(var863 = 1)) and (var45 = 1
or not(var863 = 1)) and (var48 = 1 or not(var863 = 1)) and (var49 = 1 or not(
var864 = 1)) and (var51 = 1 or not(var864 = 1)) and (var53 = 1 or not(var864 = 1
)) and (var55 = 1 or not(var864 = 1)) and (var58 = 1 or not(var864 = 1)) and (
var60 = 1 or not(var864 = 1)) and (var61 = 1 or not(var864 = 1)) and (var64 = 1
or not(var864 = 1)) and (var65 = 1 or not(var865 = 1)) and (var67 = 1 or not(
var865 = 1)) and (var69 = 1 or not(var865 = 1)) and (var71 = 1 or not(var865 = 1
)) and (var74 = 1 or not(var865 = 1)) and (var76 = 1 or not(var865 = 1)) and (
var77 = 1 or not(var865 = 1)) and (var80 = 1 or not(var865 = 1)) and (var81 = 1
or not(var866 = 1)) and (var83 = 1 or not(var866 = 1)) and (var85 = 1 or not(
var866 = 1)) and (var87 = 1 or not(var866 = 1)) and (var90 = 1 or not(var866 = 1
)) and (var92 = 1 or not(var866 = 1)) and (var93 = 1 or not(var866 = 1)) and (
var96 = 1 or not(var866 = 1)) and (var97 = 1 or not(var867 = 1)) and (var99 = 1
or not(var867 = 1)) and (var101 = 1 or not(var867 = 1)) and (var103 = 1 or not(
var867 = 1)) and (var106 = 1 or not(var867 = 1)) and (var108 = 1 or not(var867 =
 1)) and (var109 = 1 or not(var867 = 1)) and (var112 = 1 or not(var867 = 1)) and
 (var113 = 1 or not(var868 = 1)) and (var115 = 1 or not(var868 = 1)) and (var117
 = 1 or not(var868 = 1)) and (var119 = 1 or not(var868 = 1)) and (var122 = 1 or
not(var868 = 1)) and (var124 = 1 or not(var868 = 1)) and (var125 = 1 or not(
var868 = 1)) and (var128 = 1 or not(var868 = 1)) and (var129 = 1 or not(var869 =
 1)) and (var131 = 1 or not(var869 = 1)) and (var133 = 1 or not(var869 = 1)) and
 (var135 = 1 or not(var869 = 1)) and (var138 = 1 or not(var869 = 1)) and (var140
 = 1 or not(var869 = 1)) and (var141 = 1 or not(var869 = 1)) and (var144 = 1 or
not(var869 = 1)) and (var145 = 1 or not(var870 = 1)) and (var147 = 1 or not(
var870 = 1)) and (var149 = 1 or not(var870 = 1)) and (var151 = 1 or not(var870 =
 1)) and (var154 = 1 or not(var870 = 1)) and (var156 = 1 or not(var870 = 1)) and
 (var157 = 1 or not(var870 = 1)) and (var160 = 1 or not(var870 = 1)) and (var2 =
 1 or not(var871 = 1)) and (var4 = 1 or not(var871 = 1)) and (var5 = 1 or not(
var871 = 1)) and (var8 = 1 or not(var871 = 1)) and (var9 = 1 or not(var871 = 1))
 and (var12 = 1 or not(var871 = 1)) and (var14 = 1 or not(var871 = 1)) and (
var16 = 1 or not(var871 = 1)) and (var18 = 1 or not(var872 = 1)) and (var20 = 1
or not(var872 = 1)) and (var21 = 1 or not(var872 = 1)) and (var24 = 1 or not(
var872 = 1)) and (var25 = 1 or not(var872 = 1)) and (var28 = 1 or not(var872 = 1
)) and (var30 = 1 or not(var872 = 1)) and (var32 = 1 or not(var872 = 1)) and (
var34 = 1 or not(var873 = 1)) and (var36 = 1 or not(var873 = 1)) and (var37 = 1
or not(var873 = 1)) and (var40 = 1 or not(var873 = 1)) and (var41 = 1 or not(
var873 = 1)) and (var44 = 1 or not(var873 = 1)) and (var46 = 1 or not(var873 = 1
)) and (var48 = 1 or not(var873 = 1)) and (var50 = 1 or not(var874 = 1)) and (
var52 = 1 or not(var874 = 1)) and (var53 = 1 or not(var874 = 1)) and (var56 = 1
or not(var874 = 1)) and (var57 = 1 or not(var874 = 1)) and (var60 = 1 or not(
var874 = 1)) and (var62 = 1 or not(var874 = 1)) and (var64 = 1 or not(var874 = 1
)) and (var66 = 1 or not(var875 = 1)) and (var68 = 1 or not(var875 = 1)) and (
var69 = 1 or not(var875 = 1)) and (var72 = 1 or not(var875 = 1)) and (var73 = 1
or not(var875 = 1)) and (var76 = 1 or not(var875 = 1)) and (var78 = 1 or not(
var875 = 1)) and (var80 = 1 or not(var875 = 1)) and (var82 = 1 or not(var876 = 1
)) and (var84 = 1 or not(var876 = 1)) and (var85 = 1 or not(var876 = 1)) and (
var88 = 1 or not(var876 = 1)) and (var89 = 1 or not(var876 = 1)) and (var92 = 1
or not(var876 = 1)) and (var94 = 1 or not(var876 = 1)) and (var96 = 1 or not(
var876 = 1)) and (var98 = 1 or not(var877 = 1)) and (var100 = 1 or not(var877 =
1)) and (var101 = 1 or not(var877 = 1)) and (var104 = 1 or not(var877 = 1)) and
(var105 = 1 or not(var877 = 1)) and (var108 = 1 or not(var877 = 1)) and (var110
= 1 or not(var877 = 1)) and (var112 = 1 or not(var877 = 1)) and (var114 = 1 or
not(var878 = 1)) and (var116 = 1 or not(var878 = 1)) and (var117 = 1 or not(
var878 = 1)) and (var120 = 1 or not(var878 = 1)) and (var121 = 1 or not(var878 =
 1)) and (var124 = 1 or not(var878 = 1)) and (var126 = 1 or not(var878 = 1)) and
 (var128 = 1 or not(var878 = 1)) and (var130 = 1 or not(var879 = 1)) and (var132
 = 1 or not(var879 = 1)) and (var133 = 1 or not(var879 = 1)) and (var136 = 1 or
not(var879 = 1)) and (var137 = 1 or not(var879 = 1)) and (var140 = 1 or not(
var879 = 1)) and (var142 = 1 or not(var879 = 1)) and (var144 = 1 or not(var879 =
 1)) and (var146 = 1 or not(var880 = 1)) and (var148 = 1 or not(var880 = 1)) and
 (var149 = 1 or not(var880 = 1)) and (var152 = 1 or not(var880 = 1)) and (var153
 = 1 or not(var880 = 1)) and (var156 = 1 or not(var880 = 1)) and (var158 = 1 or
not(var880 = 1)) and (var160 = 1 or not(var880 = 1)) and (var1 = 1 or not(var881
 = 1)) and (var3 = 1 or not(var881 = 1)) and (var6 = 1 or not(var881 = 1)) and (
var7 = 1 or not(var881 = 1)) and (var10 = 1 or not(var881 = 1)) and (var12 = 1
or not(var881 = 1)) and (var14 = 1 or not(var881 = 1)) and (var15 = 1 or not(
var881 = 1)) and (var17 = 1 or not(var882 = 1)) and (var19 = 1 or not(var882 = 1
)) and (var22 = 1 or not(var882 = 1)) and (var23 = 1 or not(var882 = 1)) and (
var26 = 1 or not(var882 = 1)) and (var28 = 1 or not(var882 = 1)) and (var30 = 1
or not(var882 = 1)) and (var31 = 1 or not(var882 = 1)) and (var33 = 1 or not(
var883 = 1)) and (var35 = 1 or not(var883 = 1)) and (var38 = 1 or not(var883 = 1
)) and (var39 = 1 or not(var883 = 1)) and (var42 = 1 or not(var883 = 1)) and (
var44 = 1 or not(var883 = 1)) and (var46 = 1 or not(var883 = 1)) and (var47 = 1
or not(var883 = 1)) and (var49 = 1 or not(var884 = 1)) and (var51 = 1 or not(
var884 = 1)) and (var54 = 1 or not(var884 = 1)) and (var55 = 1 or not(var884 = 1
)) and (var58 = 1 or not(var884 = 1)) and (var60 = 1 or not(var884 = 1)) and (
var62 = 1 or not(var884 = 1)) and (var63 = 1 or not(var884 = 1)) and (var65 = 1
or not(var885 = 1)) and (var67 = 1 or not(var885 = 1)) and (var70 = 1 or not(
var885 = 1)) and (var71 = 1 or not(var885 = 1)) and (var74 = 1 or not(var885 = 1
)) and (var76 = 1 or not(var885 = 1)) and (var78 = 1 or not(var885 = 1)) and (
var79 = 1 or not(var885 = 1)) and (var81 = 1 or not(var886 = 1)) and (var83 = 1
or not(var886 = 1)) and (var86 = 1 or not(var886 = 1)) and (var87 = 1 or not(
var886 = 1)) and (var90 = 1 or not(var886 = 1)) and (var92 = 1 or not(var886 = 1
)) and (var94 = 1 or not(var886 = 1)) and (var95 = 1 or not(var886 = 1)) and (
var97 = 1 or not(var887 = 1)) and (var99 = 1 or not(var887 = 1)) and (var102 = 1
 or not(var887 = 1)) and (var103 = 1 or not(var887 = 1)) and (var106 = 1 or not(
var887 = 1)) and (var108 = 1 or not(var887 = 1)) and (var110 = 1 or not(var887 =
 1)) and (var111 = 1 or not(var887 = 1)) and (var113 = 1 or not(var888 = 1)) and
 (var115 = 1 or not(var888 = 1)) and (var118 = 1 or not(var888 = 1)) and (var119
 = 1 or not(var888 = 1)) and (var122 = 1 or not(var888 = 1)) and (var124 = 1 or
not(var888 = 1)) and (var126 = 1 or not(var888 = 1)) and (var127 = 1 or not(
var888 = 1)) and (var129 = 1 or not(var889 = 1)) and (var131 = 1 or not(var889 =
 1)) and (var134 = 1 or not(var889 = 1)) and (var135 = 1 or not(var889 = 1)) and
 (var138 = 1 or not(var889 = 1)) and (var140 = 1 or not(var889 = 1)) and (var142
 = 1 or not(var889 = 1)) and (var143 = 1 or not(var889 = 1)) and (var145 = 1 or
not(var890 = 1)) and (var147 = 1 or not(var890 = 1)) and (var150 = 1 or not(
var890 = 1)) and (var151 = 1 or not(var890 = 1)) and (var154 = 1 or not(var890 =
 1)) and (var156 = 1 or not(var890 = 1)) and (var158 = 1 or not(var890 = 1)) and
 (var159 = 1 or not(var890 = 1)) and (var1 = 1 or not(var891 = 1)) and (var4 = 1
 or not(var891 = 1)) and (var5 = 1 or not(var891 = 1)) and (var7 = 1 or not(
var891 = 1)) and (var10 = 1 or not(var891 = 1)) and (var12 = 1 or not(var891 = 1
)) and (var13 = 1 or not(var891 = 1)) and (var16 = 1 or not(var891 = 1)) and (
var17 = 1 or not(var892 = 1)) and (var20 = 1 or not(var892 = 1)) and (var21 = 1
or not(var892 = 1)) and (var23 = 1 or not(var892 = 1)) and (var26 = 1 or not(
var892 = 1)) and (var28 = 1 or not(var892 = 1)) and (var29 = 1 or not(var892 = 1
)) and (var32 = 1 or not(var892 = 1)) and (var33 = 1 or not(var893 = 1)) and (
var36 = 1 or not(var893 = 1)) and (var37 = 1 or not(var893 = 1)) and (var39 = 1
or not(var893 = 1)) and (var42 = 1 or not(var893 = 1)) and (var44 = 1 or not(
var893 = 1)) and (var45 = 1 or not(var893 = 1)) and (var48 = 1 or not(var893 = 1
)) and (var49 = 1 or not(var894 = 1)) and (var52 = 1 or not(var894 = 1)) and (
var53 = 1 or not(var894 = 1)) and (var55 = 1 or not(var894 = 1)) and (var58 = 1
or not(var894 = 1)) and (var60 = 1 or not(var894 = 1)) and (var61 = 1 or not(
var894 = 1)) and (var64 = 1 or not(var894 = 1)) and (var65 = 1 or not(var895 = 1
)) and (var68 = 1 or not(var895 = 1)) and (var69 = 1 or not(var895 = 1)) and (
var71 = 1 or not(var895 = 1)) and (var74 = 1 or not(var895 = 1)) and (var76 = 1
or not(var895 = 1)) and (var77 = 1 or not(var895 = 1)) and (var80 = 1 or not(
var895 = 1)) and (var81 = 1 or not(var896 = 1)) and (var84 = 1 or not(var896 = 1
)) and (var85 = 1 or not(var896 = 1)) and (var87 = 1 or not(var896 = 1)) and (
var90 = 1 or not(var896 = 1)) and (var92 = 1 or not(var896 = 1)) and (var93 = 1
or not(var896 = 1)) and (var96 = 1 or not(var896 = 1)) and (var97 = 1 or not(
var897 = 1)) and (var100 = 1 or not(var897 = 1)) and (var101 = 1 or not(var897 =
 1)) and (var103 = 1 or not(var897 = 1)) and (var106 = 1 or not(var897 = 1)) and
 (var108 = 1 or not(var897 = 1)) and (var109 = 1 or not(var897 = 1)) and (var112
 = 1 or not(var897 = 1)) and (var113 = 1 or not(var898 = 1)) and (var116 = 1 or
not(var898 = 1)) and (var117 = 1 or not(var898 = 1)) and (var119 = 1 or not(
var898 = 1)) and (var122 = 1 or not(var898 = 1)) and (var124 = 1 or not(var898 =
 1)) and (var125 = 1 or not(var898 = 1)) and (var128 = 1 or not(var898 = 1)) and
 (var129 = 1 or not(var899 = 1)) and (var132 = 1 or not(var899 = 1)) and (var133
 = 1 or not(var899 = 1)) and (var135 = 1 or not(var899 = 1)) and (var138 = 1 or
not(var899 = 1)) and (var140 = 1 or not(var899 = 1)) and (var141 = 1 or not(
var899 = 1)) and (var144 = 1 or not(var899 = 1)) and (var145 = 1 or not(var900 =
 1)) and (var148 = 1 or not(var900 = 1)) and (var149 = 1 or not(var900 = 1)) and
 (var151 = 1 or not(var900 = 1)) and (var154 = 1 or not(var900 = 1)) and (var156
 = 1 or not(var900 = 1)) and (var157 = 1 or not(var900 = 1)) and (var160 = 1 or
not(var900 = 1)) and (var1 = 1 or not(var901 = 1)) and (var3 = 1 or not(var901 =
 1)) and (var6 = 1 or not(var901 = 1)) and (var7 = 1 or not(var901 = 1)) and (
var10 = 1 or not(var901 = 1)) and (var12 = 1 or not(var901 = 1)) and (var14 = 1
or not(var901 = 1)) and (var15 = 1 or not(var901 = 1)) and (var17 = 1 or not(
var902 = 1)) and (var19 = 1 or not(var902 = 1)) and (var22 = 1 or not(var902 = 1
)) and (var23 = 1 or not(var902 = 1)) and (var26 = 1 or not(var902 = 1)) and (
var28 = 1 or not(var902 = 1)) and (var30 = 1 or not(var902 = 1)) and (var31 = 1
or not(var902 = 1)) and (var33 = 1 or not(var903 = 1)) and (var35 = 1 or not(
var903 = 1)) and (var38 = 1 or not(var903 = 1)) and (var39 = 1 or not(var903 = 1
)) and (var42 = 1 or not(var903 = 1)) and (var44 = 1 or not(var903 = 1)) and (
var46 = 1 or not(var903 = 1)) and (var47 = 1 or not(var903 = 1)) and (var49 = 1
or not(var904 = 1)) and (var51 = 1 or not(var904 = 1)) and (var54 = 1 or not(
var904 = 1)) and (var55 = 1 or not(var904 = 1)) and (var58 = 1 or not(var904 = 1
)) and (var60 = 1 or not(var904 = 1)) and (var62 = 1 or not(var904 = 1)) and (
var63 = 1 or not(var904 = 1)) and (var65 = 1 or not(var905 = 1)) and (var67 = 1
or not(var905 = 1)) and (var70 = 1 or not(var905 = 1)) and (var71 = 1 or not(
var905 = 1)) and (var74 = 1 or not(var905 = 1)) and (var76 = 1 or not(var905 = 1
)) and (var78 = 1 or not(var905 = 1)) and (var79 = 1 or not(var905 = 1)) and (
var81 = 1 or not(var906 = 1)) and (var83 = 1 or not(var906 = 1)) and (var86 = 1
or not(var906 = 1)) and (var87 = 1 or not(var906 = 1)) and (var90 = 1 or not(
var906 = 1)) and (var92 = 1 or not(var906 = 1)) and (var94 = 1 or not(var906 = 1
)) and (var95 = 1 or not(var906 = 1)) and (var97 = 1 or not(var907 = 1)) and (
var99 = 1 or not(var907 = 1)) and (var102 = 1 or not(var907 = 1)) and (var103 =
1 or not(var907 = 1)) and (var106 = 1 or not(var907 = 1)) and (var108 = 1 or not
(var907 = 1)) and (var110 = 1 or not(var907 = 1)) and (var111 = 1 or not(var907
= 1)) and (var113 = 1 or not(var908 = 1)) and (var115 = 1 or not(var908 = 1))
and (var118 = 1 or not(var908 = 1)) and (var119 = 1 or not(var908 = 1)) and (
var122 = 1 or not(var908 = 1)) and (var124 = 1 or not(var908 = 1)) and (var126 =
 1 or not(var908 = 1)) and (var127 = 1 or not(var908 = 1)) and (var129 = 1 or
not(var909 = 1)) and (var131 = 1 or not(var909 = 1)) and (var134 = 1 or not(
var909 = 1)) and (var135 = 1 or not(var909 = 1)) and (var138 = 1 or not(var909 =
 1)) and (var140 = 1 or not(var909 = 1)) and (var142 = 1 or not(var909 = 1)) and
 (var143 = 1 or not(var909 = 1)) and (var145 = 1 or not(var910 = 1)) and (var147
 = 1 or not(var910 = 1)) and (var150 = 1 or not(var910 = 1)) and (var151 = 1 or
not(var910 = 1)) and (var154 = 1 or not(var910 = 1)) and (var156 = 1 or not(
var910 = 1)) and (var158 = 1 or not(var910 = 1)) and (var159 = 1 or not(var910 =
 1)) and (var2 = 1 or not(var911 = 1)) and (var4 = 1 or not(var911 = 1)) and (
var5 = 1 or not(var911 = 1)) and (var7 = 1 or not(var911 = 1)) and (var10 = 1 or
 not(var911 = 1)) and (var12 = 1 or not(var911 = 1)) and (var13 = 1 or not(
var911 = 1)) and (var16 = 1 or not(var911 = 1)) and (var18 = 1 or not(var912 = 1
)) and (var20 = 1 or not(var912 = 1)) and (var21 = 1 or not(var912 = 1)) and (
var23 = 1 or not(var912 = 1)) and (var26 = 1 or not(var912 = 1)) and (var28 = 1
or not(var912 = 1)) and (var29 = 1 or not(var912 = 1)) and (var32 = 1 or not(
var912 = 1)) and (var34 = 1 or not(var913 = 1)) and (var36 = 1 or not(var913 = 1
)) and (var37 = 1 or not(var913 = 1)) and (var39 = 1 or not(var913 = 1)) and (
var42 = 1 or not(var913 = 1)) and (var44 = 1 or not(var913 = 1)) and (var45 = 1
or not(var913 = 1)) and (var48 = 1 or not(var913 = 1)) and (var50 = 1 or not(
var914 = 1)) and (var52 = 1 or not(var914 = 1)) and (var53 = 1 or not(var914 = 1
)) and (var55 = 1 or not(var914 = 1)) and (var58 = 1 or not(var914 = 1)) and (
var60 = 1 or not(var914 = 1)) and (var61 = 1 or not(var914 = 1)) and (var64 = 1
or not(var914 = 1)) and (var66 = 1 or not(var915 = 1)) and (var68 = 1 or not(
var915 = 1)) and (var69 = 1 or not(var915 = 1)) and (var71 = 1 or not(var915 = 1
)) and (var74 = 1 or not(var915 = 1)) and (var76 = 1 or not(var915 = 1)) and (
var77 = 1 or not(var915 = 1)) and (var80 = 1 or not(var915 = 1)) and (var82 = 1
or not(var916 = 1)) and (var84 = 1 or not(var916 = 1)) and (var85 = 1 or not(
var916 = 1)) and (var87 = 1 or not(var916 = 1)) and (var90 = 1 or not(var916 = 1
)) and (var92 = 1 or not(var916 = 1)) and (var93 = 1 or not(var916 = 1)) and (
var96 = 1 or not(var916 = 1)) and (var98 = 1 or not(var917 = 1)) and (var100 = 1
 or not(var917 = 1)) and (var101 = 1 or not(var917 = 1)) and (var103 = 1 or not(
var917 = 1)) and (var106 = 1 or not(var917 = 1)) and (var108 = 1 or not(var917 =
 1)) and (var109 = 1 or not(var917 = 1)) and (var112 = 1 or not(var917 = 1)) and
 (var114 = 1 or not(var918 = 1)) and (var116 = 1 or not(var918 = 1)) and (var117
 = 1 or not(var918 = 1)) and (var119 = 1 or not(var918 = 1)) and (var122 = 1 or
not(var918 = 1)) and (var124 = 1 or not(var918 = 1)) and (var125 = 1 or not(
var918 = 1)) and (var128 = 1 or not(var918 = 1)) and (var130 = 1 or not(var919 =
 1)) and (var132 = 1 or not(var919 = 1)) and (var133 = 1 or not(var919 = 1)) and
 (var135 = 1 or not(var919 = 1)) and (var138 = 1 or not(var919 = 1)) and (var140
 = 1 or not(var919 = 1)) and (var141 = 1 or not(var919 = 1)) and (var144 = 1 or
not(var919 = 1)) and (var146 = 1 or not(var920 = 1)) and (var148 = 1 or not(
var920 = 1)) and (var149 = 1 or not(var920 = 1)) and (var151 = 1 or not(var920 =
 1)) and (var154 = 1 or not(var920 = 1)) and (var156 = 1 or not(var920 = 1)) and
 (var157 = 1 or not(var920 = 1)) and (var160 = 1 or not(var920 = 1)) and (var2 =
 1 or not(var921 = 1)) and (var4 = 1 or not(var921 = 1)) and (var6 = 1 or not(
var921 = 1)) and (var7 = 1 or not(var921 = 1)) and (var10 = 1 or not(var921 = 1)
) and (var12 = 1 or not(var921 = 1)) and (var13 = 1 or not(var921 = 1)) and (
var16 = 1 or not(var921 = 1)) and (var18 = 1 or not(var922 = 1)) and (var20 = 1
or not(var922 = 1)) and (var22 = 1 or not(var922 = 1)) and (var23 = 1 or not(
var922 = 1)) and (var26 = 1 or not(var922 = 1)) and (var28 = 1 or not(var922 = 1
)) and (var29 = 1 or not(var922 = 1)) and (var32 = 1 or not(var922 = 1)) and (
var34 = 1 or not(var923 = 1)) and (var36 = 1 or not(var923 = 1)) and (var38 = 1
or not(var923 = 1)) and (var39 = 1 or not(var923 = 1)) and (var42 = 1 or not(
var923 = 1)) and (var44 = 1 or not(var923 = 1)) and (var45 = 1 or not(var923 = 1
)) and (var48 = 1 or not(var923 = 1)) and (var50 = 1 or not(var924 = 1)) and (
var52 = 1 or not(var924 = 1)) and (var54 = 1 or not(var924 = 1)) and (var55 = 1
or not(var924 = 1)) and (var58 = 1 or not(var924 = 1)) and (var60 = 1 or not(
var924 = 1)) and (var61 = 1 or not(var924 = 1)) and (var64 = 1 or not(var924 = 1
)) and (var66 = 1 or not(var925 = 1)) and (var68 = 1 or not(var925 = 1)) and (
var70 = 1 or not(var925 = 1)) and (var71 = 1 or not(var925 = 1)) and (var74 = 1
or not(var925 = 1)) and (var76 = 1 or not(var925 = 1)) and (var77 = 1 or not(
var925 = 1)) and (var80 = 1 or not(var925 = 1)) and (var82 = 1 or not(var926 = 1
)) and (var84 = 1 or not(var926 = 1)) and (var86 = 1 or not(var926 = 1)) and (
var87 = 1 or not(var926 = 1)) and (var90 = 1 or not(var926 = 1)) and (var92 = 1
or not(var926 = 1)) and (var93 = 1 or not(var926 = 1)) and (var96 = 1 or not(
var926 = 1)) and (var98 = 1 or not(var927 = 1)) and (var100 = 1 or not(var927 =
1)) and (var102 = 1 or not(var927 = 1)) and (var103 = 1 or not(var927 = 1)) and
(var106 = 1 or not(var927 = 1)) and (var108 = 1 or not(var927 = 1)) and (var109
= 1 or not(var927 = 1)) and (var112 = 1 or not(var927 = 1)) and (var114 = 1 or
not(var928 = 1)) and (var116 = 1 or not(var928 = 1)) and (var118 = 1 or not(
var928 = 1)) and (var119 = 1 or not(var928 = 1)) and (var122 = 1 or not(var928 =
 1)) and (var124 = 1 or not(var928 = 1)) and (var125 = 1 or not(var928 = 1)) and
 (var128 = 1 or not(var928 = 1)) and (var130 = 1 or not(var929 = 1)) and (var132
 = 1 or not(var929 = 1)) and (var134 = 1 or not(var929 = 1)) and (var135 = 1 or
not(var929 = 1)) and (var138 = 1 or not(var929 = 1)) and (var140 = 1 or not(
var929 = 1)) and (var141 = 1 or not(var929 = 1)) and (var144 = 1 or not(var929 =
 1)) and (var146 = 1 or not(var930 = 1)) and (var148 = 1 or not(var930 = 1)) and
 (var150 = 1 or not(var930 = 1)) and (var151 = 1 or not(var930 = 1)) and (var154
 = 1 or not(var930 = 1)) and (var156 = 1 or not(var930 = 1)) and (var157 = 1 or
not(var930 = 1)) and (var160 = 1 or not(var930 = 1)) and (var1 = 1 or not(var931
 = 1)) and (var3 = 1 or not(var931 = 1)) and (var6 = 1 or not(var931 = 1)) and (
var8 = 1 or not(var931 = 1)) and (var10 = 1 or not(var931 = 1)) and (var11 = 1
or not(var931 = 1)) and (var13 = 1 or not(var931 = 1)) and (var15 = 1 or not(
var931 = 1)) and (var17 = 1 or not(var932 = 1)) and (var19 = 1 or not(var932 = 1
)) and (var22 = 1 or not(var932 = 1)) and (var24 = 1 or not(var932 = 1)) and (
var26 = 1 or not(var932 = 1)) and (var27 = 1 or not(var932 = 1)) and (var29 = 1
or not(var932 = 1)) and (var31 = 1 or not(var932 = 1)) and (var33 = 1 or not(
var933 = 1)) and (var35 = 1 or not(var933 = 1)) and (var38 = 1 or not(var933 = 1
)) and (var40 = 1 or not(var933 = 1)) and (var42 = 1 or not(var933 = 1)) and (
var43 = 1 or not(var933 = 1)) and (var45 = 1 or not(var933 = 1)) and (var47 = 1
or not(var933 = 1)) and (var49 = 1 or not(var934 = 1)) and (var51 = 1 or not(
var934 = 1)) and (var54 = 1 or not(var934 = 1)) and (var56 = 1 or not(var934 = 1
)) and (var58 = 1 or not(var934 = 1)) and (var59 = 1 or not(var934 = 1)) and (
var61 = 1 or not(var934 = 1)) and (var63 = 1 or not(var934 = 1)) and (var65 = 1
or not(var935 = 1)) and (var67 = 1 or not(var935 = 1)) and (var70 = 1 or not(
var935 = 1)) and (var72 = 1 or not(var935 = 1)) and (var74 = 1 or not(var935 = 1
)) and (var75 = 1 or not(var935 = 1)) and (var77 = 1 or not(var935 = 1)) and (
var79 = 1 or not(var935 = 1)) and (var81 = 1 or not(var936 = 1)) and (var83 = 1
or not(var936 = 1)) and (var86 = 1 or not(var936 = 1)) and (var88 = 1 or not(
var936 = 1)) and (var90 = 1 or not(var936 = 1)) and (var91 = 1 or not(var936 = 1
)) and (var93 = 1 or not(var936 = 1)) and (var95 = 1 or not(var936 = 1)) and (
var97 = 1 or not(var937 = 1)) and (var99 = 1 or not(var937 = 1)) and (var102 = 1
 or not(var937 = 1)) and (var104 = 1 or not(var937 = 1)) and (var106 = 1 or not(
var937 = 1)) and (var107 = 1 or not(var937 = 1)) and (var109 = 1 or not(var937 =
 1)) and (var111 = 1 or not(var937 = 1)) and (var113 = 1 or not(var938 = 1)) and
 (var115 = 1 or not(var938 = 1)) and (var118 = 1 or not(var938 = 1)) and (var120
 = 1 or not(var938 = 1)) and (var122 = 1 or not(var938 = 1)) and (var123 = 1 or
not(var938 = 1)) and (var125 = 1 or not(var938 = 1)) and (var127 = 1 or not(
var938 = 1)) and (var129 = 1 or not(var939 = 1)) and (var131 = 1 or not(var939 =
 1)) and (var134 = 1 or not(var939 = 1)) and (var136 = 1 or not(var939 = 1)) and
 (var138 = 1 or not(var939 = 1)) and (var139 = 1 or not(var939 = 1)) and (var141
 = 1 or not(var939 = 1)) and (var143 = 1 or not(var939 = 1)) and (var145 = 1 or
not(var940 = 1)) and (var147 = 1 or not(var940 = 1)) and (var150 = 1 or not(
var940 = 1)) and (var152 = 1 or not(var940 = 1)) and (var154 = 1 or not(var940 =
 1)) and (var155 = 1 or not(var940 = 1)) and (var157 = 1 or not(var940 = 1)) and
 (var159 = 1 or not(var940 = 1)) and (var2 = 1 or not(var941 = 1)) and (var3 = 1
 or not(var941 = 1)) and (var6 = 1 or not(var941 = 1)) and (var8 = 1 or not(
var941 = 1)) and (var10 = 1 or not(var941 = 1)) and (var11 = 1 or not(var941 = 1
)) and (var13 = 1 or not(var941 = 1)) and (var15 = 1 or not(var941 = 1)) and (
var18 = 1 or not(var942 = 1)) and (var19 = 1 or not(var942 = 1)) and (var22 = 1
or not(var942 = 1)) and (var24 = 1 or not(var942 = 1)) and (var26 = 1 or not(
var942 = 1)) and (var27 = 1 or not(var942 = 1)) and (var29 = 1 or not(var942 = 1
)) and (var31 = 1 or not(var942 = 1)) and (var34 = 1 or not(var943 = 1)) and (
var35 = 1 or not(var943 = 1)) and (var38 = 1 or not(var943 = 1)) and (var40 = 1
or not(var943 = 1)) and (var42 = 1 or not(var943 = 1)) and (var43 = 1 or not(
var943 = 1)) and (var45 = 1 or not(var943 = 1)) and (var47 = 1 or not(var943 = 1
)) and (var50 = 1 or not(var944 = 1)) and (var51 = 1 or not(var944 = 1)) and (
var54 = 1 or not(var944 = 1)) and (var56 = 1 or not(var944 = 1)) and (var58 = 1
or not(var944 = 1)) and (var59 = 1 or not(var944 = 1)) and (var61 = 1 or not(
var944 = 1)) and (var63 = 1 or not(var944 = 1)) and (var66 = 1 or not(var945 = 1
)) and (var67 = 1 or not(var945 = 1)) and (var70 = 1 or not(var945 = 1)) and (
var72 = 1 or not(var945 = 1)) and (var74 = 1 or not(var945 = 1)) and (var75 = 1
or not(var945 = 1)) and (var77 = 1 or not(var945 = 1)) and (var79 = 1 or not(
var945 = 1)) and (var82 = 1 or not(var946 = 1)) and (var83 = 1 or not(var946 = 1
)) and (var86 = 1 or not(var946 = 1)) and (var88 = 1 or not(var946 = 1)) and (
var90 = 1 or not(var946 = 1)) and (var91 = 1 or not(var946 = 1)) and (var93 = 1
or not(var946 = 1)) and (var95 = 1 or not(var946 = 1)) and (var98 = 1 or not(
var947 = 1)) and (var99 = 1 or not(var947 = 1)) and (var102 = 1 or not(var947 =
1)) and (var104 = 1 or not(var947 = 1)) and (var106 = 1 or not(var947 = 1)) and
(var107 = 1 or not(var947 = 1)) and (var109 = 1 or not(var947 = 1)) and (var111
= 1 or not(var947 = 1)) and (var114 = 1 or not(var948 = 1)) and (var115 = 1 or
not(var948 = 1)) and (var118 = 1 or not(var948 = 1)) and (var120 = 1 or not(
var948 = 1)) and (var122 = 1 or not(var948 = 1)) and (var123 = 1 or not(var948 =
 1)) and (var125 = 1 or not(var948 = 1)) and (var127 = 1 or not(var948 = 1)) and
 (var130 = 1 or not(var949 = 1)) and (var131 = 1 or not(var949 = 1)) and (var134
 = 1 or not(var949 = 1)) and (var136 = 1 or not(var949 = 1)) and (var138 = 1 or
not(var949 = 1)) and (var139 = 1 or not(var949 = 1)) and (var141 = 1 or not(
var949 = 1)) and (var143 = 1 or not(var949 = 1)) and (var146 = 1 or not(var950 =
 1)) and (var147 = 1 or not(var950 = 1)) and (var150 = 1 or not(var950 = 1)) and
 (var152 = 1 or not(var950 = 1)) and (var154 = 1 or not(var950 = 1)) and (var155
 = 1 or not(var950 = 1)) and (var157 = 1 or not(var950 = 1)) and (var159 = 1 or
not(var950 = 1)) and (var161 = 1 or var162 = 1 or var163 = 1 or var164 = 1 or
var165 = 1 or var166 = 1 or var167 = 1 or var168 = 1 or var169 = 1 or var170 = 1
) and (var171 = 1 or var172 = 1 or var173 = 1 or var174 = 1 or var175 = 1 or
var176 = 1 or var177 = 1 or var178 = 1 or var179 = 1 or var180 = 1) and (var181
= 1 or var182 = 1 or var183 = 1 or var184 = 1 or var185 = 1 or var186 = 1 or
var187 = 1 or var188 = 1 or var189 = 1 or var190 = 1) and (var191 = 1 or var192
= 1 or var193 = 1 or var194 = 1 or var195 = 1 or var196 = 1 or var197 = 1 or
var198 = 1 or var199 = 1 or var200 = 1) and (var201 = 1 or var202 = 1 or var203
= 1 or var204 = 1 or var205 = 1 or var206 = 1 or var207 = 1 or var208 = 1 or
var209 = 1 or var210 = 1) and (var211 = 1 or var212 = 1 or var213 = 1 or var214
= 1 or var215 = 1 or var216 = 1 or var217 = 1 or var218 = 1 or var219 = 1 or
var220 = 1) and (var221 = 1 or var222 = 1 or var223 = 1 or var224 = 1 or var225
= 1 or var226 = 1 or var227 = 1 or var228 = 1 or var229 = 1 or var230 = 1) and (
var231 = 1 or var232 = 1 or var233 = 1 or var234 = 1 or var235 = 1 or var236 = 1
 or var237 = 1 or var238 = 1 or var239 = 1 or var240 = 1) and (var241 = 1 or
var242 = 1 or var243 = 1 or var244 = 1 or var245 = 1 or var246 = 1 or var247 = 1
 or var248 = 1 or var249 = 1 or var250 = 1) and (var251 = 1 or var252 = 1 or
var253 = 1 or var254 = 1 or var255 = 1 or var256 = 1 or var257 = 1 or var258 = 1
 or var259 = 1 or var260 = 1) and (var261 = 1 or var262 = 1 or var263 = 1 or
var264 = 1 or var265 = 1 or var266 = 1 or var267 = 1 or var268 = 1 or var269 = 1
 or var270 = 1) and (var271 = 1 or var272 = 1 or var273 = 1 or var274 = 1 or
var275 = 1 or var276 = 1 or var277 = 1 or var278 = 1 or var279 = 1 or var280 = 1
) and (var281 = 1 or var282 = 1 or var283 = 1 or var284 = 1 or var285 = 1 or
var286 = 1 or var287 = 1 or var288 = 1 or var289 = 1 or var290 = 1) and (var291
= 1 or var292 = 1 or var293 = 1 or var294 = 1 or var295 = 1 or var296 = 1 or
var297 = 1 or var298 = 1 or var299 = 1 or var300 = 1) and (var301 = 1 or var302
= 1 or var303 = 1 or var304 = 1 or var305 = 1 or var306 = 1 or var307 = 1 or
var308 = 1 or var309 = 1 or var310 = 1) and (var311 = 1 or var312 = 1 or var313
= 1 or var314 = 1 or var315 = 1 or var316 = 1 or var317 = 1 or var318 = 1 or
var319 = 1 or var320 = 1) and (var321 = 1 or var322 = 1 or var323 = 1 or var324
= 1 or var325 = 1 or var326 = 1 or var327 = 1 or var328 = 1 or var329 = 1 or
var330 = 1) and (var331 = 1 or var332 = 1 or var333 = 1 or var334 = 1 or var335
= 1 or var336 = 1 or var337 = 1 or var338 = 1 or var339 = 1 or var340 = 1) and (
var341 = 1 or var342 = 1 or var343 = 1 or var344 = 1 or var345 = 1 or var346 = 1
 or var347 = 1 or var348 = 1 or var349 = 1 or var350 = 1) and (var351 = 1 or
var352 = 1 or var353 = 1 or var354 = 1 or var355 = 1 or var356 = 1 or var357 = 1
 or var358 = 1 or var359 = 1 or var360 = 1) and (var361 = 1 or var362 = 1 or
var363 = 1 or var364 = 1 or var365 = 1 or var366 = 1 or var367 = 1 or var368 = 1
 or var369 = 1 or var370 = 1) and (var371 = 1 or var372 = 1 or var373 = 1 or
var374 = 1 or var375 = 1 or var376 = 1 or var377 = 1 or var378 = 1 or var379 = 1
 or var380 = 1) and (var381 = 1 or var382 = 1 or var383 = 1 or var384 = 1 or
var385 = 1 or var386 = 1 or var387 = 1 or var388 = 1 or var389 = 1 or var390 = 1
) and (var391 = 1 or var392 = 1 or var393 = 1 or var394 = 1 or var395 = 1 or
var396 = 1 or var397 = 1 or var398 = 1 or var399 = 1 or var400 = 1) and (var401
= 1 or var402 = 1 or var403 = 1 or var404 = 1 or var405 = 1 or var406 = 1 or
var407 = 1 or var408 = 1 or var409 = 1 or var410 = 1) and (var411 = 1 or var412
= 1 or var413 = 1 or var414 = 1 or var415 = 1 or var416 = 1 or var417 = 1 or
var418 = 1 or var419 = 1 or var420 = 1) and (var421 = 1 or var422 = 1 or var423
= 1 or var424 = 1 or var425 = 1 or var426 = 1 or var427 = 1 or var428 = 1 or
var429 = 1 or var430 = 1) and (var431 = 1 or var432 = 1 or var433 = 1 or var434
= 1 or var435 = 1 or var436 = 1 or var437 = 1 or var438 = 1 or var439 = 1 or
var440 = 1) and (var441 = 1 or var442 = 1 or var443 = 1 or var444 = 1 or var445
= 1 or var446 = 1 or var447 = 1 or var448 = 1 or var449 = 1 or var450 = 1) and (
var451 = 1 or var452 = 1 or var453 = 1 or var454 = 1 or var455 = 1 or var456 = 1
 or var457 = 1 or var458 = 1 or var459 = 1 or var460 = 1) and (var461 = 1 or
var462 = 1 or var463 = 1 or var464 = 1 or var465 = 1 or var466 = 1 or var467 = 1
 or var468 = 1 or var469 = 1 or var470 = 1) and (var471 = 1 or var472 = 1 or
var473 = 1 or var474 = 1 or var475 = 1 or var476 = 1 or var477 = 1 or var478 = 1
 or var479 = 1 or var480 = 1) and (var481 = 1 or var482 = 1 or var483 = 1 or
var484 = 1 or var485 = 1 or var486 = 1 or var487 = 1 or var488 = 1 or var489 = 1
 or var490 = 1) and (var491 = 1 or var492 = 1 or var493 = 1 or var494 = 1 or
var495 = 1 or var496 = 1 or var497 = 1 or var498 = 1 or var499 = 1 or var500 = 1
) and (var501 = 1 or var502 = 1 or var503 = 1 or var504 = 1 or var505 = 1 or
var506 = 1 or var507 = 1 or var508 = 1 or var509 = 1 or var510 = 1) and (var511
= 1 or var512 = 1 or var513 = 1 or var514 = 1 or var515 = 1 or var516 = 1 or
var517 = 1 or var518 = 1 or var519 = 1 or var520 = 1) and (var521 = 1 or var522
= 1 or var523 = 1 or var524 = 1 or var525 = 1 or var526 = 1 or var527 = 1 or
var528 = 1 or var529 = 1 or var530 = 1) and (var531 = 1 or var532 = 1 or var533
= 1 or var534 = 1 or var535 = 1 or var536 = 1 or var537 = 1 or var538 = 1 or
var539 = 1 or var540 = 1) and (var541 = 1 or var542 = 1 or var543 = 1 or var544
= 1 or var545 = 1 or var546 = 1 or var547 = 1 or var548 = 1 or var549 = 1 or
var550 = 1) and (var551 = 1 or var552 = 1 or var553 = 1 or var554 = 1 or var555
= 1 or var556 = 1 or var557 = 1 or var558 = 1 or var559 = 1 or var560 = 1) and (
var561 = 1 or var562 = 1 or var563 = 1 or var564 = 1 or var565 = 1 or var566 = 1
 or var567 = 1 or var568 = 1 or var569 = 1 or var570 = 1) and (var571 = 1 or
var572 = 1 or var573 = 1 or var574 = 1 or var575 = 1 or var576 = 1 or var577 = 1
 or var578 = 1 or var579 = 1 or var580 = 1) and (var581 = 1 or var582 = 1 or
var583 = 1 or var584 = 1 or var585 = 1 or var586 = 1 or var587 = 1 or var588 = 1
 or var589 = 1 or var590 = 1) and (var591 = 1 or var592 = 1 or var593 = 1 or
var594 = 1 or var595 = 1 or var596 = 1 or var597 = 1 or var598 = 1 or var599 = 1
 or var600 = 1) and (var601 = 1 or var602 = 1 or var603 = 1 or var604 = 1 or
var605 = 1 or var606 = 1 or var607 = 1 or var608 = 1 or var609 = 1 or var610 = 1
) and (var611 = 1 or var612 = 1 or var613 = 1 or var614 = 1 or var615 = 1 or
var616 = 1 or var617 = 1 or var618 = 1 or var619 = 1 or var620 = 1) and (var621
= 1 or var622 = 1 or var623 = 1 or var624 = 1 or var625 = 1 or var626 = 1 or
var627 = 1 or var628 = 1 or var629 = 1 or var630 = 1) and (var631 = 1 or var632
= 1 or var633 = 1 or var634 = 1 or var635 = 1 or var636 = 1 or var637 = 1 or
var638 = 1 or var639 = 1 or var640 = 1) and (var641 = 1 or var642 = 1 or var643
= 1 or var644 = 1 or var645 = 1 or var646 = 1 or var647 = 1 or var648 = 1 or
var649 = 1 or var650 = 1) and (var651 = 1 or var652 = 1 or var653 = 1 or var654
= 1 or var655 = 1 or var656 = 1 or var657 = 1 or var658 = 1 or var659 = 1 or
var660 = 1) and (var661 = 1 or var662 = 1 or var663 = 1 or var664 = 1 or var665
= 1 or var666 = 1 or var667 = 1 or var668 = 1 or var669 = 1 or var670 = 1) and (
var671 = 1 or var672 = 1 or var673 = 1 or var674 = 1 or var675 = 1 or var676 = 1
 or var677 = 1 or var678 = 1 or var679 = 1 or var680 = 1) and (var681 = 1 or
var682 = 1 or var683 = 1 or var684 = 1 or var685 = 1 or var686 = 1 or var687 = 1
 or var688 = 1 or var689 = 1 or var690 = 1) and (var691 = 1 or var692 = 1 or
var693 = 1 or var694 = 1 or var695 = 1 or var696 = 1 or var697 = 1 or var698 = 1
 or var699 = 1 or var700 = 1) and (var701 = 1 or var702 = 1 or var703 = 1 or
var704 = 1 or var705 = 1 or var706 = 1 or var707 = 1 or var708 = 1 or var709 = 1
 or var710 = 1) and (var711 = 1 or var712 = 1 or var713 = 1 or var714 = 1 or
var715 = 1 or var716 = 1 or var717 = 1 or var718 = 1 or var719 = 1 or var720 = 1
) and (var721 = 1 or var722 = 1 or var723 = 1 or var724 = 1 or var725 = 1 or
var726 = 1 or var727 = 1 or var728 = 1 or var729 = 1 or var730 = 1) and (var731
= 1 or var732 = 1 or var733 = 1 or var734 = 1 or var735 = 1 or var736 = 1 or
var737 = 1 or var738 = 1 or var739 = 1 or var740 = 1) and (var741 = 1 or var742
= 1 or var743 = 1 or var744 = 1 or var745 = 1 or var746 = 1 or var747 = 1 or
var748 = 1 or var749 = 1 or var750 = 1) and (var751 = 1 or var752 = 1 or var753
= 1 or var754 = 1 or var755 = 1 or var756 = 1 or var757 = 1 or var758 = 1 or
var759 = 1 or var760 = 1) and (var761 = 1 or var762 = 1 or var763 = 1 or var764
= 1 or var765 = 1 or var766 = 1 or var767 = 1 or var768 = 1 or var769 = 1 or
var770 = 1) and (var771 = 1 or var772 = 1 or var773 = 1 or var774 = 1 or var775
= 1 or var776 = 1 or var777 = 1 or var778 = 1 or var779 = 1 or var780 = 1) and (
var781 = 1 or var782 = 1 or var783 = 1 or var784 = 1 or var785 = 1 or var786 = 1
 or var787 = 1 or var788 = 1 or var789 = 1 or var790 = 1) and (var791 = 1 or
var792 = 1 or var793 = 1 or var794 = 1 or var795 = 1 or var796 = 1 or var797 = 1
 or var798 = 1 or var799 = 1 or var800 = 1) and (var801 = 1 or var802 = 1 or
var803 = 1 or var804 = 1 or var805 = 1 or var806 = 1 or var807 = 1 or var808 = 1
 or var809 = 1 or var810 = 1) and (var811 = 1 or var812 = 1 or var813 = 1 or
var814 = 1 or var815 = 1 or var816 = 1 or var817 = 1 or var818 = 1 or var819 = 1
 or var820 = 1) and (var821 = 1 or var822 = 1 or var823 = 1 or var824 = 1 or
var825 = 1 or var826 = 1 or var827 = 1 or var828 = 1 or var829 = 1 or var830 = 1
) and (var831 = 1 or var832 = 1 or var833 = 1 or var834 = 1 or var835 = 1 or
var836 = 1 or var837 = 1 or var838 = 1 or var839 = 1 or var840 = 1) and (var841
= 1 or var842 = 1 or var843 = 1 or var844 = 1 or var845 = 1 or var846 = 1 or
var847 = 1 or var848 = 1 or var849 = 1 or var850 = 1) and (var851 = 1 or var852
= 1 or var853 = 1 or var854 = 1 or var855 = 1 or var856 = 1 or var857 = 1 or
var858 = 1 or var859 = 1 or var860 = 1) and (var861 = 1 or var862 = 1 or var863
= 1 or var864 = 1 or var865 = 1 or var866 = 1 or var867 = 1 or var868 = 1 or
var869 = 1 or var870 = 1) and (var871 = 1 or var872 = 1 or var873 = 1 or var874
= 1 or var875 = 1 or var876 = 1 or var877 = 1 or var878 = 1 or var879 = 1 or
var880 = 1) and (var881 = 1 or var882 = 1 or var883 = 1 or var884 = 1 or var885
= 1 or var886 = 1 or var887 = 1 or var888 = 1 or var889 = 1 or var890 = 1) and (
var891 = 1 or var892 = 1 or var893 = 1 or var894 = 1 or var895 = 1 or var896 = 1
 or var897 = 1 or var898 = 1 or var899 = 1 or var900 = 1) and (var901 = 1 or
var902 = 1 or var903 = 1 or var904 = 1 or var905 = 1 or var906 = 1 or var907 = 1
 or var908 = 1 or var909 = 1 or var910 = 1) and (var911 = 1 or var912 = 1 or
var913 = 1 or var914 = 1 or var915 = 1 or var916 = 1 or var917 = 1 or var918 = 1
 or var919 = 1 or var920 = 1) and (var921 = 1 or var922 = 1 or var923 = 1 or
var924 = 1 or var925 = 1 or var926 = 1 or var927 = 1 or var928 = 1 or var929 = 1
 or var930 = 1) and (var931 = 1 or var932 = 1 or var933 = 1 or var934 = 1 or
var935 = 1 or var936 = 1 or var937 = 1 or var938 = 1 or var939 = 1 or var940 = 1
) and (var941 = 1 or var942 = 1 or var943 = 1 or var944 = 1 or var945 = 1 or
var946 = 1 or var947 = 1 or var948 = 1 or var949 = 1 or var950 = 1)$

rlqsat ii8c1;

% The formula toilet_a_04_01.4.qdimacs of Castellini's encoding of the
% bomb in the toilet problem http://www.qbflib.org
toilet_a_04_01_4 :=
ex(var43,all(var50,all(var49,all(var48,all(var51,ex(var1,ex(var2,ex(var3,ex(var4
,ex(var5,ex(var6,ex(var7,ex(var8,ex(var9,ex(var10,ex(var11,ex(var12,ex(var52,ex(
var55,ex(var56,ex(var57,ex(var58,ex(var59,ex(var60,(not(var49 = 1) or not(var50
= 1) or not(var51 = 1) or var48 = 1 or var52 = 1) and (not(var49 = 1) or not(
var50 = 1) or not(var51 = 1) or var48 = 1 or var53 = 1) and (not(var49 = 1) or
not(var50 = 1) or not(var51 = 1) or var48 = 1 or var54 = 1) and (not(var49 = 1)
or not(var50 = 1) or not(var51 = 1) or not(var55 = 1) or var48 = 1) and (not(
var49 = 1) or not(var50 = 1) or not(var52 = 1) or var48 = 1 or var51 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var53 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var54 = 1) and (
not(var49 = 1) or not(var50 = 1) or var48 = 1 or var51 = 1 or var55 = 1) and (
not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or not(var52 = 1) or var49 =
1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or var49 = 1 or var53
 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or var49 = 1 or
var54 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var51 = 1) or not(var55
= 1) or var49 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or var51 =
 1 or var52 = 1) and (not(var48 = 1) or not(var50 = 1) or not(var53 = 1) or
var49 = 1 or var51 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or
var51 = 1 or var54 = 1) and (not(var48 = 1) or not(var50 = 1) or var49 = 1 or
var51 = 1 or var55 = 1) and (not(var50 = 1) or not(var51 = 1) or var48 = 1 or
var49 = 1 or var52 = 1) and (not(var50 = 1) or not(var51 = 1) or not(var53 = 1)
or var48 = 1 or var49 = 1) and (not(var50 = 1) or not(var51 = 1) or var48 = 1 or
 var49 = 1 or var54 = 1) and (not(var50 = 1) or not(var51 = 1) or not(var55 = 1)
 or var48 = 1 or var49 = 1) and (not(var50 = 1) or not(var52 = 1) or var48 = 1
or var49 = 1 or var51 = 1) and (not(var50 = 1) or not(var53 = 1) or var48 = 1 or
 var49 = 1 or var51 = 1) and (not(var50 = 1) or var48 = 1 or var49 = 1 or var51
= 1 or var54 = 1) and (not(var50 = 1) or var48 = 1 or var49 = 1 or var51 = 1 or
var55 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51 = 1) or not(var52
= 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51 = 1) or
not(var53 = 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1) or not(var51
= 1) or var50 = 1 or var54 = 1) and (not(var48 = 1) or not(var49 = 1) or not(
var51 = 1) or not(var55 = 1) or var50 = 1) and (not(var48 = 1) or not(var49 = 1)
 or var50 = 1 or var51 = 1 or var52 = 1) and (not(var48 = 1) or not(var49 = 1)
or var50 = 1 or var51 = 1 or var53 = 1) and (not(var48 = 1) or not(var49 = 1) or
 not(var54 = 1) or var50 = 1 or var51 = 1) and (not(var48 = 1) or not(var49 = 1)
 or var50 = 1 or var51 = 1 or var55 = 1) and (not(var49 = 1) or not(var51 = 1)
or var48 = 1 or var50 = 1 or var52 = 1) and (not(var49 = 1) or not(var51 = 1) or
 var48 = 1 or var50 = 1 or var53 = 1) and (not(var49 = 1) or not(var51 = 1) or
not(var54 = 1) or var48 = 1 or var50 = 1) and (not(var49 = 1) or not(var51 = 1)
or not(var55 = 1) or var48 = 1 or var50 = 1) and (not(var49 = 1) or not(var52 =
1) or var48 = 1 or var50 = 1 or var51 = 1) and (not(var49 = 1) or var48 = 1 or
var50 = 1 or var51 = 1 or var53 = 1) and (not(var49 = 1) or not(var54 = 1) or
var48 = 1 or var50 = 1 or var51 = 1) and (not(var49 = 1) or var48 = 1 or var50 =
 1 or var51 = 1 or var55 = 1) and (not(var48 = 1) or not(var51 = 1) or not(var52
 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or not(var51 = 1) or var49
= 1 or var50 = 1 or var53 = 1) and (not(var48 = 1) or not(var51 = 1) or not(
var54 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or not(var51 = 1) or
not(var55 = 1) or var49 = 1 or var50 = 1) and (not(var48 = 1) or var49 = 1 or
var50 = 1 or var51 = 1 or var52 = 1) and (not(var48 = 1) or not(var53 = 1) or
var49 = 1 or var50 = 1 or var51 = 1) and (not(var48 = 1) or not(var54 = 1) or
var49 = 1 or var50 = 1 or var51 = 1) and (not(var48 = 1) or var49 = 1 or var50 =
 1 or var51 = 1 or var55 = 1) and (not(var51 = 1) or var48 = 1 or var49 = 1 or
var50 = 1 or var52 = 1) and (not(var51 = 1) or not(var53 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var51 = 1) or not(var54 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var51 = 1) or not(var55 = 1) or var48 = 1 or
var49 = 1 or var50 = 1) and (not(var52 = 1) or var48 = 1 or var49 = 1 or var50 =
 1 or var51 = 1) and (not(var53 = 1) or var48 = 1 or var49 = 1 or var50 = 1 or
var51 = 1) and (not(var54 = 1) or var48 = 1 or var49 = 1 or var50 = 1 or var51 =
 1) and (var48 = 1 or var49 = 1 or var50 = 1 or var51 = 1 or var55 = 1) and (not
(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var52 = 1) and (
not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var53 = 1)
and (not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var54 =
1) and (not(var48 = 1) or not(var49 = 1) or not(var50 = 1) or var51 = 1 or var55
 = 1) and not(var56 = 1) and not(var57 = 1) and not(var58 = 1) and not(var59 = 1
) and not(var60 = 1) and (not(var24 = 1) or not(var60 = 1)) and (not(var24 = 1)
or not(var56 = 1)) and (not(var4 = 1) or not(var25 = 1)) and (not(var1 = 1) or
not(var25 = 1)) and (not(var5 = 1) or not(var26 = 1)) and (not(var2 = 1) or not(
var26 = 1)) and (not(var28 = 1) or not(var57 = 1)) and (not(var28 = 1) or not(
var60 = 1)) and (not(var9 = 1) or not(var29 = 1)) and (not(var4 = 1) or not(
var29 = 1)) and (not(var10 = 1) or not(var30 = 1)) and (not(var5 = 1) or not(
var30 = 1)) and (not(var32 = 1) or not(var58 = 1)) and (not(var32 = 1) or not(
var60 = 1)) and (not(var14 = 1) or not(var33 = 1)) and (not(var4 = 1) or not(
var33 = 1)) and (not(var15 = 1) or not(var34 = 1)) and (not(var5 = 1) or not(
var34 = 1)) and (not(var36 = 1) or not(var59 = 1)) and (not(var36 = 1) or not(
var60 = 1)) and (not(var19 = 1) or not(var38 = 1)) and (not(var4 = 1) or not(
var38 = 1)) and (not(var20 = 1) or not(var40 = 1)) and (not(var5 = 1) or not(
var40 = 1)) and (not(var37 = 1) or var60 = 1) and (not(var39 = 1) or var4 = 1)
and (not(var41 = 1) or var5 = 1) and (not(var24 = 1) or var4 = 1) and (not(var7
= 1) or not(var24 = 1)) and (not(var24 = 1) or var1 = 1) and (not(var25 = 1) or
var5 = 1) and (not(var8 = 1) or not(var25 = 1)) and (not(var25 = 1) or var2 = 1)
 and (not(var26 = 1) or var6 = 1) and (not(var26 = 1) or not(var44 = 1)) and (
not(var26 = 1) or var3 = 1) and (not(var28 = 1) or var9 = 1) and (not(var12 = 1)
 or not(var28 = 1)) and (not(var28 = 1) or var4 = 1) and (not(var29 = 1) or
var10 = 1) and (not(var13 = 1) or not(var29 = 1)) and (not(var29 = 1) or var5 =
1) and (not(var30 = 1) or var11 = 1) and (not(var30 = 1) or not(var45 = 1)) and
(not(var30 = 1) or var6 = 1) and (not(var32 = 1) or var14 = 1) and (not(var17 =
1) or not(var32 = 1)) and (not(var32 = 1) or var4 = 1) and (not(var33 = 1) or
var15 = 1) and (not(var18 = 1) or not(var33 = 1)) and (not(var33 = 1) or var5 =
1) and (not(var34 = 1) or var16 = 1) and (not(var34 = 1) or not(var46 = 1)) and
(not(var34 = 1) or var6 = 1) and (not(var36 = 1) or var19 = 1) and (not(var22 =
1) or not(var36 = 1)) and (not(var36 = 1) or var4 = 1) and (not(var38 = 1) or
var20 = 1) and (not(var23 = 1) or not(var38 = 1)) and (not(var38 = 1) or var5 =
1) and (not(var40 = 1) or var21 = 1) and (not(var40 = 1) or not(var47 = 1)) and
(not(var40 = 1) or var6 = 1) and (not(var4 = 1) or not(var37 = 1)) and (not(var5
 = 1) or not(var39 = 1)) and (not(var6 = 1) or not(var41 = 1)) and (not(var1 = 1
) or var24 = 1 or var56 = 1) and (not(var2 = 1) or var1 = 1 or var25 = 1) and (
not(var3 = 1) or var2 = 1 or var26 = 1) and (not(var56 = 1) or var1 = 1) and (
not(var1 = 1) or var2 = 1) and (not(var2 = 1) or var3 = 1) and (not(var4 = 1) or
 var24 = 1 or var28 = 1 or var32 = 1 or var36 = 1 or var60 = 1) and (not(var5 =
1) or var4 = 1 or var25 = 1 or var29 = 1 or var33 = 1 or var38 = 1) and (not(
var6 = 1) or var5 = 1 or var26 = 1 or var30 = 1 or var34 = 1 or var40 = 1) and (
not(var60 = 1) or var4 = 1 or var37 = 1) and (not(var4 = 1) or var5 = 1 or var39
 = 1) and (not(var5 = 1) or var6 = 1 or var41 = 1) and (not(var7 = 1) or var55 =
 1) and (not(var8 = 1) or var7 = 1) and (not(var44 = 1) or var8 = 1) and (not(
var55 = 1) or var7 = 1 or var24 = 1) and (not(var7 = 1) or var8 = 1 or var25 = 1
) and (not(var8 = 1) or var26 = 1 or var44 = 1) and (not(var9 = 1) or var28 = 1
or var57 = 1) and (not(var10 = 1) or var9 = 1 or var29 = 1) and (not(var11 = 1)
or var10 = 1 or var30 = 1) and (not(var57 = 1) or var9 = 1) and (not(var9 = 1)
or var10 = 1) and (not(var10 = 1) or var11 = 1) and (not(var12 = 1) or var52 = 1
) and (not(var13 = 1) or var12 = 1) and (not(var45 = 1) or var13 = 1) and (not(
var52 = 1) or var12 = 1 or var28 = 1) and (not(var12 = 1) or var13 = 1 or var29
= 1) and (not(var13 = 1) or var30 = 1 or var45 = 1) and (not(var14 = 1) or var32
 = 1 or var58 = 1) and (not(var15 = 1) or var14 = 1 or var33 = 1) and (not(var16
 = 1) or var15 = 1 or var34 = 1) and (not(var58 = 1) or var14 = 1) and (not(
var14 = 1) or var15 = 1) and (not(var15 = 1) or var16 = 1) and (not(var17 = 1)
or var53 = 1) and (not(var18 = 1) or var17 = 1) and (not(var46 = 1) or var18 = 1
) and (not(var53 = 1) or var17 = 1 or var32 = 1) and (not(var17 = 1) or var18 =
1 or var33 = 1) and (not(var18 = 1) or var34 = 1 or var46 = 1) and (not(var19 =
1) or var36 = 1 or var59 = 1) and (not(var20 = 1) or var19 = 1 or var38 = 1) and
 (not(var21 = 1) or var20 = 1 or var40 = 1) and (not(var59 = 1) or var19 = 1)
and (not(var19 = 1) or var20 = 1) and (not(var20 = 1) or var21 = 1) and (not(
var22 = 1) or var54 = 1) and (not(var23 = 1) or var22 = 1) and (not(var47 = 1)
or var23 = 1) and (not(var54 = 1) or var22 = 1 or var36 = 1) and (not(var22 = 1)
 or var23 = 1 or var38 = 1) and (not(var23 = 1) or var40 = 1 or var47 = 1) and (
not(var24 = 1) or not(var28 = 1)) and (not(var25 = 1) or not(var29 = 1)) and (
not(var26 = 1) or not(var30 = 1)) and (not(var27 = 1) or not(var31 = 1)) and (
not(var24 = 1) or not(var32 = 1)) and (not(var25 = 1) or not(var33 = 1)) and (
not(var26 = 1) or not(var34 = 1)) and (not(var27 = 1) or not(var35 = 1)) and (
not(var24 = 1) or not(var36 = 1)) and (not(var25 = 1) or not(var38 = 1)) and (
not(var26 = 1) or not(var40 = 1)) and (not(var27 = 1) or not(var42 = 1)) and (
not(var24 = 1) or not(var37 = 1)) and (not(var25 = 1) or not(var39 = 1)) and (
not(var26 = 1) or not(var41 = 1)) and (not(var27 = 1) or not(var43 = 1)) and (
not(var28 = 1) or not(var32 = 1)) and (not(var29 = 1) or not(var33 = 1)) and (
not(var30 = 1) or not(var34 = 1)) and (not(var31 = 1) or not(var35 = 1)) and (
not(var28 = 1) or not(var36 = 1)) and (not(var29 = 1) or not(var38 = 1)) and (
not(var30 = 1) or not(var40 = 1)) and (not(var31 = 1) or not(var42 = 1)) and (
not(var28 = 1) or not(var37 = 1)) and (not(var29 = 1) or not(var39 = 1)) and (
not(var30 = 1) or not(var41 = 1)) and (not(var31 = 1) or not(var43 = 1)) and (
not(var32 = 1) or not(var36 = 1)) and (not(var33 = 1) or not(var38 = 1)) and (
not(var34 = 1) or not(var40 = 1)) and (not(var35 = 1) or not(var42 = 1)) and (
not(var32 = 1) or not(var37 = 1)) and (not(var33 = 1) or not(var39 = 1)) and (
not(var34 = 1) or not(var41 = 1)) and (not(var35 = 1) or not(var43 = 1)) and (
not(var36 = 1) or not(var37 = 1)) and (not(var38 = 1) or not(var39 = 1)) and (
not(var40 = 1) or not(var41 = 1)) and (not(var42 = 1) or not(var43 = 1)) and not
(var44 = 1) and not(var45 = 1) and not(var46 = 1) and not(var47 = 1)))))))))))))
))))))))))))$
rlqsat toilet_a_04_01_4;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/ibalp/ibalpkapur.tst0000644000175000017500000001404511526203062025741 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: ibalpkapur.tst 469 2009-11-28 13:58:18Z arthurcnorman $
% ----------------------------------------------------------------------
% Copyright (c) 2007-2009 A. Dolzmann and T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

load redlog$
rlset boolean$
on rlpcprint$
off time$
off gc$
off rlverbose$

lisp;

procedure gen3knf(n,m);
   % generates a formula in 3knf form with [n] variables and [m] clauses.
   begin scalar varl,clausl,a,b,c;
      for i:=1:n do varl := gensym() . varl;
      for i:=1:m do <<
         a := rl_mk2('equal,nth(varl,random n + 1),random 2);
         b := rl_mk2('equal,nth(varl,random n + 1),random 2);
         c := rl_mk2('equal,nth(varl,random n + 1),random 2);
         clausl := rl_mkn('or,{a,b,c}) . clausl
      >>;
      return rl_mkn('and,clausl)
   end;

operator gen3knf;

procedure gensat(n,m);
   % generates a random formula with [n] variables and [m] operators
   begin scalar varl;
      for i:=1:n do varl := gensym() . varl;
      return gensat1(m,varl)
   end;

operator gensat;

procedure gensat1(m,varlist);
   % generates a random formula with [m] operators containing all vars in
   % [varlist]
   if m = 0 then
      rl_mk2('equal,nth(varlist,random length varlist + 1),1)
   else
      begin scalar leftm,rightm,oper,leftcl,rightcl;
         leftm := random m;
         rightm := (m - 1) - leftm;
         oper := random 6;
         if oper = 0 then
            return rl_mk1('not,gensat1(m - 1,varlist))
         else if oper = 1 then
            oper := 'and
         else if oper = 2 then
            oper := 'or
         else if oper = 3 then
            oper := 'impl
         else if oper = 4 then
            oper := 'repl
         else if oper = 5 then
            oper := 'equiv;
         leftcl := gensat1(leftm,varlist);
         rightcl := gensat1(rightm,varlist);
         return rl_mk2(oper,leftcl,rightcl)
      end;

procedure testumode(n,m);
   % Test Polynomgeneration modes. [n] is a positive integer meaning the ammount
   % of variables in the test cases. [m] is a positive integer meaning the 
   % number of operators per formula.
   % returns nil.
   begin scalar checkcases,starttime,endtime,ammo;
      ammo := 100;
      checkcases := for i:=1:ammo collect gensat(n,m);

      off ibalp_kapurgb;
      ioto_prin2t "Vergleich der Umwandlungsvarianten";
      ioto_prin2t {"Anzahl der Variablen: ",n};
      ioto_prin2t {"Anzahl der Operatoren: ",m};
      ioto_prin2t "----------------------------------";
      
      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'knf);
      endtime := time();
      ioto_prin2t {"3KNF: ",(endtime-starttime)/ammo,"ms"};

      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'kapurknf);
      endtime := time();
      ioto_prin2t {"Kombiniert: ",(endtime-starttime)/ammo,"ms"};

      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'kapur);
      endtime := time();
      ioto_prin2t {"Kapur: ",(endtime-starttime)/ammo,"ms"};

      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'direct);
      endtime := time();
      ioto_prin2t {"Direkt: ",(endtime-starttime)/ammo,"ms"};
      return nil
   end;

operator testumode;

procedure testinternal(n,m);
   % Test Internal settings. [n] is a positive integer meaning the ammount
   % of variables in the test cases. [m] is a positive integer meaning the 
   % number of clauses in 3KNF per formula.
   % returns nil.
   begin scalar checkcases,starttime,endtime,ammo;
      ammo := 100;
      
      checkcases := for i:=1:ammo collect gen3knf(n,m);
      ioto_prin2t "Vergleich der internen Einstellungen";
      ioto_prin2t {"Anzahl der Variablen: ",n};
      ioto_prin2t {"Anzahl der Klauseln: ",m};
      ioto_prin2t "------------------------------------";
      
      off ibalp_kapurgb;
      vdpsortmode!* := 'lex;
      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'kapur);
      endtime := time();
      ioto_prin2t {"Buchb (lex): ",(endtime-starttime)/ammo,"ms"};

      vdpsortmode!* := 'gradlex;
      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'kapur);
      endtime := time();
      ioto_prin2t {"Buchb (gradlex): ",(endtime-starttime)/ammo,"ms"};

      on ibalp_kapurgb;
      starttime := time();
      for each j in checkcases do ibalp_kapur(j,'sat,'kapur);
      endtime := time();
      ioto_prin2t {"KapurGB (gradlex): ",(endtime-starttime)/ammo,"ms"};
      
      starttime := time();
      for each j in checkcases do rl_qe(rl_ex(j,nil),nil);
      endtime := time();
      ioto_prin2t {"QE rlex: ",(endtime-starttime)/ammo,"ms"};

      return nil
   end;

operator testinternal;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/0000755000175000017500000000000011722677357022572 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqesism.red0000644000175000017500000000356011526203062024730 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqesism.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_sism_rcsid!* qqe_sism_copyright!*);
   qqe_sism_rcsid!* :=
      "$Id: qqesism.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_sism_copyright!* :=
      "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqemisc.red0000644000175000017500000017017711526203062024721 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqemisc.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_misc_rcsid!* qqe_misc_copyright!*);
   qqe_misc_rcsid!* :=
      "$Id: qqemisc.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_misc_copyright!* :=
      "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

module qqemisc;
% qqe miscellaneous. Submodule of [qqe].

procedure qqe_prefix!-length(pref);
   % Queue quantifier elimination prefix length. [pref] is a term 
   % in lisp prefix. The length of the prefix of tails and heads is
   % returned. For example: lhead ltail rtail ltail q -> 4.
   begin scalar x,j;
      j := 0;

      if null pref then x:=nil
      else <>;

      while x and not atom x do
      <<
         
         if car x memq '(rtail ltail rhead lhead) 
         then j := j+1;
         x := cadr x;
      >>;

      return j;

   end;
      
procedure qqe_prefix!-lefts(pref);
   % Queue quantifier elimination prefix length lefts. [pref] is a term 
   % in lisp prefix. The length of the prefix of rtails is
   % returned. For example: lhead ltail rtail ltail q -> 1.
   begin scalar lefts;
      lefts := 0;
      if atom pref then return 0
      else if qqe_op pref memq '(lhead, rhead, ltail, rtail)
      then return qqe_prefix!-lefts1 pref
      else for each x in cdr pref do
         lefts := max(lefts,qqe_prefix!-lefts x);
      return lefts;
   end;

procedure qqe_prefix!-lefts1(pref);
   % Queue quantifier elimination prefix length lefts. [pref] is a term 
   % in lisp prefix. The length of the prefix of rtails is
   % returned. For example: lhead ltail rtail ltail q -> 1.
   begin scalar x, j,op;
      x := pref;
      op := qqe_op pref;
      if op eq 'lhead or op eq 'rtail then j:=1 else j:=0; 
      x := qqe_arg2l x;
      while x and not atom x do
      <<
         
         if qqe_op x eq 'rtail 
         then j := j+1;
         x := qqe_arg2l x;
      >>;
      return j;
   end;

procedure qqe_prefix!-rights(pref);
   % Queue quantifier elimination prefix length rights. [pref] is a term 
   % in lisp prefix. The length of the prefix of ltails and rheads is
   % returned. For example: lhead ltail rtail ltail q -> 2.
   begin scalar rights;
      rights := 0;
      if atom pref then return 0
      else if qqe_op pref memq '(lhead, rhead, ltail, rtail)
      then return rights :=  qqe_prefix!-rights1 pref
      else for each x in cdr pref do
         rights := max(rights,qqe_prefix!-rights x);
      return rights;
   end;

procedure qqe_prefix!-rights1(pref);
   % Queue quantifier elimination prefix length rights. [pref] is a term 
   % in lisp prefix. The length of the prefix of ltails and rheads is
   % returned. For example: lhead ltail rtail ltail q -> 2.
   begin scalar x, j, op;
      x := pref;
      op := qqe_op pref;
      if op eq 'rhead or op eq 'ltail then j := 1 else j := 0;
      x := qqe_arg2l x;
      while x and not atom x  do
      <<
         if qqe_op x eq 'ltail 
         then j := j+1;
         x := qqe_arg2l x;
      >>;
      return j;
   end;

procedure qqe_dfs(u,x);
   % qqe depth first search. searches in lisp prefix [u] for 
   % subformula [x], which is also in lisp prefix. Search method
   % uses 'eq, so it doesn't check for identity in the sense of
   % using the same memory address.
   begin scalar y, not_yet;
      not_yet := t;
      if atom u then
      <<
         if u eq x then return t
         else return nil;
      >>;
      y := u; 
      while y and not_yet do
      <<
         if car y eq x then not_yet := nil;
         if qqe_dfs(car y,x) then not_yet := nil;
         y := cdr y;
      >>;
      if not_yet then return nil
      else return t;
   end;

procedure qqe_lcm(a,b);
   % Queue quantifier elimination lowest common multiplier. [a],[b] are 
   % integers.
   begin scalar x,y;
      x := a;
      y := b;
      while x neq y do
         if x < y then x := x+a
         else y := y+b;
      return x;
   end;

procedure qqe_lcm!-list(list);
   % Queue quantifier elimination lowest common multiplier. [list] is a
   % list of integers.
   begin scalar x,p;
      if null cdr list then return car list;
      x := cdr list;
      p := qqe_lcm(car x, car list);
      x := cdr x;
      while x do 
      <<
         p := qqe_lcm(car x, p);
         x := cdr x;
      >>;
      return p;
   end;

procedure qqe_plcm(a1,a2,b1,b2);
   % Queue quantifier elimination pseudo lowest common multiplier.
   % at the moment not used
   begin
        if not numberp a1 then typerr(a1,"number");
        if not numberp a2 then typerr(a1,"number");
        if not numberp b1 then typerr(a1,"number");
        if not numberp b2 then typerr(a1,"number");

        % if a1 eq b1 then return 0;
        
        if not(remainder(abs(a1-b1), !:gcd(a2,b2)) = 0)
                then return -1;
        
        while a1 neq b1 do
        <<
           if a1 < b1 then a1 := (a1+a2)
           else b1 := (b1+b2);
        >>;

        return a1;
   end;

procedure qqe_plcm!-list(u);
   % Queue quantifier elimination pseudo lowest common multiplier for list.
   % At the moment not used.
   begin scalar x, tmp;
      
      % carefull with special case with one-element lists
      x := cdr u;
      tmp := car u;

      while x do
      <<
         tmp := 
            {qqe_plcm(car tmp, cadr tmp, car car x, cadr car x), 
            qqe_lcm(cadr tmp, cadr car x)}$
         
         if car tmp eq -1 then x := nil
         else x := cdr x;
      >>;
      return car tmp;
         
   end;

procedure qqe_plcm!-2list(u,v);
   % Queue quantifier elimination pseudo lowest common multiplier 
   % with input of two lists. At the moment not used.
   begin scalar x1, x2, tmp1, tmp2;
      
      % !!! special case: one element list!
      x1 := cdr u;
      x2 := cdr v;
      tmp1 := car u;
      tmp2 := car v;

      while x1 and x2 do
      <<
         tmp1 := qqe_plcm(tmp1, tmp2,car x1, car x2); 
         tmp2 := qqe_lcm(tmp2,car x2)}$
         
         if tmp1 eq -1 then x1 := nil
         else
         <<
            x1 := cdr x1;
            x2 := cdr x2;
         >>;
      >>;
      return tmp1;
         
   end;

procedure qqe_quicksort(list);
   % Queue quantifier elimination quicksort. Quicksort of a list [list]
   % of integers in reverse order. For example (2 4 3 5) -> (5 4 3 2).
   begin scalar pivot;
      if list then
      <<
         pivot := car list;
         list := qqe_partition(cdr list,pivot);
         list := append(qqe_quicksort(car list),
            append({pivot}, qqe_quicksort(cadr list)));
      >>;
      return list;
  end;

procedure qqe_partition(list, pivot);
   % Queue quantifier elimination partition. Belongs to quicksort algorithm.
   begin scalar l,r, x;

      for each x in list do
      <<
         if x > pivot then l := append(l,{x})
         else if x < pivot then << r := append(r,{x});>>;
      >>;
      return {l,r};
   end;

% --------------------- length graph --------------------------------%

procedure qqe_length!-graph!-update!-lengths(nodes);
   % QQE length graph update lengths. [nodes] is a structured list of
   % nodes of a length graph (compare return value of
   % [qqe_clause!-length!-graph]). Returns (non-structured) list of
   % all nodes of the length graph. Function calculates min- and
   % maxlengths of all nodes (wherever possible) of length graph.
   begin scalar bad_circles, start_min, start_max, rest;
      start_min := car nodes;
      start_max := cadr nodes;
      rest := caddr nodes;
      bad_circles := qqe_length!-graph!-detect!-bad!-circles(
         append(start_min, append(start_max,rest)));
      %prin2t{"bad circles are ",bad_circles};
      qqe_length!-graph!-maxlength!-bad!-circles bad_circles;
      
      if null qqe_length!-graph!-correct(append(start_min, 
         append(start_max,rest))) then <<
            qqe_length!-graph!-delete append(start_min, 
               append(start_max,rest));
            return 'false; >>;
      qqe_length!-graph!-update!-maxlengths start_max;
      if null qqe_length!-graph!-correct(append(start_min, 
         append(start_max,rest))) then <<
            qqe_length!-graph!-delete append(start_min, 
               append(start_max,rest));
            return 'false; >>;
      %%       qqe_length!-graph!-print(append(start_min, 
      %%          append(start_max,rest)));
      qqe_length!-graph!-update!-minlengths start_min;
      %%       qqe_length!-graph!-print(append(start_min, 
      %%          append(start_max,rest)));
      return append(start_min, append(start_max,rest));
   end;
      
procedure qqe_clause!-update!-lengths(u, headmin);
   % QQE clause update lengths. [u] is a conjunction of atomic
   % formulas, [headmin] is boole. Porcedure initiates a min- and
   % maxlength calculation for the nodes of the length graph of
   % formula [u]. If [headmin] is [t], also headmin values are
   % calculated. It returns a list of all nodes of the length graph of
   % formula [u].
   qqe_length!-graph!-update!-lengths qqe_length!-graph!-clause(u, headmin);


procedure qqe_length!-graph!-clause(u, headmin);
   % QQE length graph clause. [u] is a conjunction of atomic
   % formulas. [headmin] is boole.  Procedure creates length graph for
   % formula [u] and calculates initial min- and maxlength values. If
   % [headmin] is true also headmin values are calculated.
   begin scalar start_min, start_max, op, var_list, var_l, var_r, 
         var_listtemp;

      if not(car u eq 'and) then u := {u} else u := cdr u;

      %% generate graph
      for each at in u do <<
         if qqe_debug!* then prin2t{"lengthgraph-clause at at=",at};
         op := qqe_op at;
         if op eq 'qequal then <<
            var_l := qqe_qprefix!-var qqe_arg2l at;
            var_r := qqe_qprefix!-var qqe_arg2r at;
            if var_l eq 'qepsilon and var_r neq 'qepsilon 
            then <<
               qqe_update!-maxlength(var_r, 
                  qqe_prefix!-length qqe_arg2r at);
               start_max := lto_insertq(var_r,start_max);
            >>
            else if var_r eq 'qepsilon and var_l neq 'qepsilon 
            then <<
               qqe_update!-maxlength(var_l,
                  qqe_prefix!-length qqe_arg2l at);
               start_max := lto_insertq(var_l,start_max);
            >>
            else <<
               qqe_length!-graph!-update!-edges(var_l, var_r, at);
               var_list := lto_insertq(var_l,var_list);
               if var_l neq var_r then 
                  var_list := lto_insertq(var_r,var_list);
               if qqe_debug!* then prin2t var_list;
            >>;
         >>
         else if op eq 'qneq then <<
            var_l := qqe_qprefix!-var qqe_arg2l at;
            var_r := qqe_qprefix!-var qqe_arg2r at;
            if var_l eq 'qepsilon and var_r neq 'qepsilon 
            then <<
               qqe_update!-minlength(var_r,
                  qqe_prefix!-length qqe_arg2r at + 1);
               start_min := lto_insertq(var_r, start_min);
            >>
            else if var_r eq 'qepsilon and var_l neq 'qepsilon 
            then <<
               qqe_update!-minlength(var_l,
                  qqe_prefix!-length qqe_arg2l at + 1);
               start_min := lto_insertq(var_l, start_min);
            >>;
         >>
         else if headmin then var_list := qqe_update!-headmin(rl_prepat at, 
            var_list);
      >>;

      % elements not appearing in start_min and start_max
      if qqe_debug!* then prin2t{"var_list before collect = ",var_list};
      var_list := for each x in var_list do
         if not(x memq start_min) and not(x memq start_max) then 
            var_listtemp :=  x . var_listtemp;
      if qqe_debug!* then qqe_length!-graph!-print(append(start_min,
         append(start_max,var_listtemp)));
      return {start_min, start_max, var_listtemp};
   end;  

procedure qqe_length!-graph!-update!-edges(var_l, var_r, at);
   % QQE length graph update edges. [var_l] and [var_r] are
   % variables. [at] is an atomic formula. Edges of the length graph
   % of [at] for variables [var_l] and [var_r] are created.
   begin scalar el, er, diff,edge, neighbor;
      el := qqe_prefix!-length qqe_arg2l at;
      er := qqe_prefix!-length qqe_arg2r at;
      diff := er-el;
      edge := qqe_length!-graph!-edge(el,er,diff);
      neighbor := qqe_length!-graph!-neighbor!-not!-redundant!-edge(
         var_l,var_r,edge);
      if neighbor and not(neighbor eq t) then
         qqe_length!-graph!-delete!-neighbor(var_l,neighbor);
      if neighbor then <<
         qqe_length!-graph!-insert!-neighbor(var_l,
            qqe_length!-graph!-neighbor(var_r,t,edge));
         if (var_l neq var_r) then 
            qqe_length!-graph!-insert!-neighbor(var_r, 
               qqe_length!-graph!-neighbor(var_l,nil,edge));
      >>
      else if qqe_debug!* then <<
         prin2t {"redundant edge=", edge, "with var_1,var_2=",var_l,
            var_r,"in list = ", qqe_length!-graph!-neighbors var_l};
      >>;
         
   end;

procedure qqe_length!-graph!-neighbor!-not!-redundant!-edge(var_1,
      var_2,edge);
   % QQE length graph neighbor not redundant edge. [var_1] and [var_2]
   % are variables, [edge] is an edge. Returns the neighbor
   % corresponding with [var_2] if [var_1] and [var_2] are connected
   % already with a stronger edge with same diff value, that is an
   % edge with smaller left and right values, else it returns nil if
   % [var_1] and [var_2] are connected already with an edge with the
   % same diff value which is not stronger in the above mentioned
   % sense, else it returns true (this case occurs if there is no
   % neighbor matching [var_2], or if there are, then only over a
   % edges with different diff value compared to [edge]).
   begin scalar edge2, neighbor, neighbors, flag, x;
      flag := t;
      neighbors := qqe_length!-graph!-neighbors var_1;
      while flag and neighbors do
      % for all x in qqe_length!-graph!-neighbors var_1 do
      <<
         x := car neighbors;
         if qqe_length!-graph!-neighbor!-node x eq var_2 then
         <<
            if (qqe_length!-graph!-neighbor!-diff x eq 
               qqe_length!-graph!-edge!-diff edge)
            then <<
               edge2 := qqe_length!-graph!-neighbor!-edge x;
               if qqe_length!-graph!-neighbor!-left!-on!-edge x 
               then <<
                  if qqe_length!-graph!-edge!-el edge < 
                     qqe_length!-graph!-edge!-er edge2 
                  then << neighbor := x, flag := nil;>>
                  else << flag := nil; neighbor := nil; >>;
               >>
               else <<
                  if qqe_length!-graph!-edge!-el edge <
                     qqe_length!-graph!-edge!-el edge2
                  then << neighbor := x, flag := nil;>>
                  else << flag := nil; neighbor := nil;>>
               >>;
            >>;
         >>;
         neighbors := cdr neighbors;
      >>;
      if flag then return t 
      else return neighbor;
   end;

procedure qqe_length!-graph!-neighbor(var,left,edge);
   % QQE length graph neighbor. Constructur for a neigbor. [var] is a
   % variable, [left] is boole, [edge] is an edge.
   {var,left,edge};

procedure qqe_length!-graph!-insert!-neighbor(var,neighbor);
   put(var,'neighbors, neighbor . get(var,'neighbors));

procedure qqe_length!-graph!-is!-neighbor(var_1,var_2);
   % QQE length graph is neighbor. [var_1] and [var_2] are
   % variables. Function return [t] if [var_2] is a node in the
   % neighborhood of [var_1], else [nil].
   begin scalar flag, neighbors, neighbor;
      flag := nil;
      neighbors := qqe_length!-graph!-neighbors(var_1);
      while null flag and neighbors do <<
         neighbor := car  neighbors;
         if qqe_length!-graph!-neighbor!-node neighbor eq var_2 
         then
            flag := t;
         neighbors := cdr neighbors;
      >>;
      return if flag then neighbor else nil;
   end;

procedure qqe_length!-graph!-delete!-neighbor(var, neighbor);
   % QQE length graph delete neighbor. [var] is a variable, [neighbor]
   % is a neighbor element. [neighbor] is deleted from the
   % neighborhood of [var].
   begin scalar neighbors, neighbors2, flag;
      neighbors := qqe_length!-graph!-neighbors var;
      while null flag and neighbors do <<
         if neighbor eq car neighbors then <<
            flag := t;
            put(var, 'neighbors,append(neighbors2,cdr neighbors));
         >>;
         neighbors2 := append(neighbors2, {car neighbors});
         neighbors := cdr neighbors;
      >>;
   end;

procedure qqe_length!-graph!-edge(el,er,diff);
   % QQE length graph edge. Constructor for an edge. [el], [er] and
   % [diff] are integers.
   {el,er,diff};

procedure qqe_length!-graph!-neighbor!-left!-on!-edge(neighbor);
   % QQE length graph neighbor left on edge. [neighbor] is a neighbor
   % element. Return a boole.
   cadr neighbor;

procedure qqe_length!-graph!-neighbor!-edge1(neighbor);
   % QQE length graph neighbor edge1. [neighbor] is a neighbor. Returns
   % the left edge value of neighbor [neighbor]. !!! Misnamer
   if qqe_length!-graph!-neighbor!-left!-on!-edge neighbor then
      qqe_length!-graph!-neighbor!-edge!-left neighbor
   else qqe_length!-graph!-neighbor!-edge!-right neighbor;
   %car cadr cadr neighbor;

procedure qqe_length!-graph!-neighbor!-edge2(neighbor);
   % QQE length graph neighbor edge2. [neighbor] is a neighbor. Returns
   % the right edge value of neighbor [neighbor]. !!! Misnamer
   if qqe_length!-graph!-neighbor!-left!-on!-edge neighbor then
      qqe_length!-graph!-neighbor!-edge!-right neighbor
   else qqe_length!-graph!-neighbor!-edge!-left neighbor;
   % cadr cadr cadr neighbor;

procedure qqe_length!-graph!-neighbor!-edge(neighbor);
   % QQE length graph neighbor edge. [neighbor] is a neighbor
   % element. Returns the edge belonging to [neighbor].
   car cddr neighbor;

procedure qqe_length!-graph!-neighbor!-edge!-left(neighbor);
   % QQE length graph neighbor edge left. [neighbor] is a neighbor
   % element. Returns the left edge value of the edge belonging to
   % [neighbor].
   qqe_length!-graph!-edge!-el qqe_length!-graph!-neighbor!-edge neighbor;

procedure qqe_length!-graph!-neighbor!-edge!-right(neighbor);
   % QQE length graph neighbor edge right. [neighbor] is a neighbor
   % element. Returns the right edge value of the edge belonging to
   % [neighbor].
   qqe_length!-graph!-edge!-er qqe_length!-graph!-neighbor!-edge neighbor;

procedure qqe_length!-graph!-neighbor!-edge!-diff(neighbor);
   % QQE length graph neighbor diff. [neighbor] is a neighbor. Return
   % the diff value of the edge belonging to [neighbor].
   caddr qqe_length!-graph!-neighbor!-edge neighbor;

procedure qqe_length!-graph!-edge!-mark(edge);
   % QQE length graph edge mark. [edge] is an edge element. Marks
   % [edge].
   cdr edge := append(cdr edge, {t});

procedure qqe_length!-graph!-edge!-marked(edge);
   % QQE length graph edge marked. [edge] is an edge element. Returns
   % [t], if [edge] is marked, else [nil].
   cdddr edge;

procedure qqe_length!-graph!-edge!-unmark(edge);
   % QQE length graph edge unmark. [edge] is an edge element. Unmarks
   % [edge].
   if qqe_length!-graph!-edge!-marked edge then
      cddr edge := {caddr edge};

procedure qqe_length!-graph!-edge!-el(edge);
   % QQE length graph edge edge value left. [edge] is an edge
   % element. Returns left edge value of [edge].
   car edge;

procedure qqe_length!-graph!-edge!-er(edge);
      % QQE length graph edge edge value right. [edge] is an edge
   % element. Returns right edge value of [edge].
   cadr edge;

procedure qqe_length!-graph!-edge!-diff(edge);
   % QQE length graph edge diff. [edge] is an edge element. Returns
   % the diff value of [edge].
   caddr edge;

procedure qqe_length!-graph!-neighbor!-diff(neighbor);
   % QQE length graph neighbor diff. [neighbor] is a neighbor
   % element. Returns the diff value of the edge belonging to
   % [neighbor].
   if qqe_length!-graph!-neighbor!-left!-on!-edge neighbor then
      qqe_length!-graph!-edge!-diff 
         qqe_length!-graph!-neighbor!-edge neighbor
   else - qqe_length!-graph!-edge!-diff
      qqe_length!-graph!-neighbor!-edge neighbor;
   % car cadr neighbor;

procedure qqe_length!-graph!-neighbor!-node(neighbor);
   % QQE length graph neighbor node. [neighbor] is a neighbor
   % element. Return node belonging to [neighbor].
   car neighbor;

procedure qqe_length!-graph!-neighbors(node);
   % QQE length graph neighbors. [node] is an node element. Returns
   % all neighbors of node in the length graph.
   get(node,'neighbors);

procedure qqe_update!-minlength(var, length);
   % QQE update minlength. [var] is a node, [length] an
   % integer. Updates the minlength of [var] to [length]. Returns
   % value if update is successfull.
   << if null minlength or minlength < length 
   then put(var,'minlength, length) >>
      where minlength=get(var,'minlength);

procedure qqe_update!-maxlength(var, length);
   % QQE update maxlength. [var] is a node, [length] an
   % integer. Updates the maxlength of [var] to [length]. Returns
   % value if update is successfull.
   << if null maxlength or maxlength > length 
   then put(var,'maxlength, length) >>
      where maxlength=get(var,'maxlength);

procedure qqe_update!-headmin(at, var_list);
   % QQE update headmin. [at] is an atomic formula. [var_list] is a
   % list of nodes. Updates the headmin values of all variables of
   % atomic formula [at]. Returns [var_list] extended with the nodes,
   % for which the headmin values has been updated.
   begin 
      var_list := qqe_length!-graph!-bterm(qqe_arg2l at, var_list);
      var_list := qqe_length!-graph!-bterm(qqe_arg2r at, var_list);
      return var_list;
   end;

% that has to be done for every connection component


procedure qqe_length!-graph!-detect!-bad!-circles(nodes);
   % QQE length graph detect bad circles. [nodes] is a list of nodes
   % of a length graph. Function returns a list of all bad circles
   % which appear in the graph represented by [nodes].
   begin scalar bad_circles, new_nodes, new_edges, new_bad!-circles;
      for each x in nodes do
         if not qqe_length!-graph!-marked x then <<
            % components := x . components;
            << new_bad!-circles := car y;
               new_nodes := append(new_nodes,cadr y);
               new_edges := append(new_edges,caddr y);
               if qqe_debug!* then 
                  prin2t{"bad circles component returned" ,y};
            >> where y=qqe_length!-graph!-detect!-bad!-circles!-component(
               x,0,nil,0);
               if new_bad!-circles then 
                  bad_circles := append(new_bad!-circles,bad_circles);
         >>;
      qqe_length!-graph!-detect!-bad!-circles!-clean!-up(new_nodes,
         new_edges);
      return bad_circles;
   end;

procedure qqe_length!-graph!-detect!-bad!-circles!-clean!-up(nodes,edges);
   % QQE length graph detect bad circles clean up. [nodes] is a list
   % of nodes. [edges] is a list of edges. Function removes all marks
   % which were generated by the bad circles detection algorithm from
   % [nodes] and [edges].
   <<
      qqe_length!-graph!-detect!-bad!-circles!-rem!-marks!-nodes(nodes);
      qqe_length!-graph!-detect!-bad!-circles!-rem!-marks!-edges(edges);
   >>;

procedure qqe_length!-graph!-remove!-edge!-marks(edges);
   % QQE length graph remove edge marks. [edges] is a list of
   % edges. Removes all marks from [edges].
   for each x in edges do
      qqe_length!-graph!-remove!-edge!-marks!-neighbors(
         qqe_length!-graph!-neighbors x);

procedure qqe_length!-graph!-remove!-edge!-marks!-neighbors(neighbors);
   % QQE length graph remove edge marks neighbor. [neighbors] is a
   % list of neighbors. Function removes all marks from nodes in
   % [neighbors].
   for each x in neighbors do
      qqe_length!-graph!-edge!-unmark qqe_length!-graph!-neighbor!-edge x;

procedure qqe_graph!-get!-dfsnum(node);
   % QQE graph get dfsnum. [node] is a node element. Return the dfsnum
   % of [node].
   get(node,'dfsnum);

procedure qqe_graph!-put!-dfsnum(node,num);
   % QQE graph put dfsnum. [node] is a node element. [num] is a
   % positive integer or zero. Updates [node] dfsnum by [num].
   put(node,'dfsnum,num);

procedure qqe_graph!-rem!-dfsnum(node);
   % QQE graph remove dfsnum. [node] is a node element. Remove dfsnum
   % from [node].
   remprop(node,'dfsnum);

procedure qqe_length!-graph!-detect!-bad!-circles!-component(node,sigma,path,
      dfsnum);
   % QQE length graph detect bad circles component. [node] is a node
   % element, [sigma] is a integer, [path] is a path, [dfsnum] is a
   % positive integer. Function returns {bad_circles, nodes, edges},
   % where [bad_circles] is a list of all bad graphs in the component
   % represented by [node], [nodes] ([edges]) are all nodes
   % (resp. edges) touched by the algorithm (this is only needed for
   % later clean-up). 
   begin scalar bad_circles, nodex, sigmax, edgex, leftx, new_nodes, 
         new_edges, bad_circles!-branch;
      if qqe_debug!* then 
         prin2t{"qqe_graph!-detect!-bad!-circles with node = ",node,
         "sigma = ", sigma, "path = ", path};
      qqe_length!-graph!-mark node;
      qqe_graph!-put!-dfsnum(node,dfsnum);
      new_nodes := {node};
      dfsnum := dfsnum + 1;
      put(node,'blocksum,sigma);
      path := qqe_length!-graph!-path!-insert!-node!-right(path,node);

      for each x in qqe_length!-graph!-neighbors node do <<
         sigmax := sigma + qqe_length!-graph!-neighbor!-diff x;
         nodex := qqe_length!-graph!-neighbor!-node x;
         edgex := qqe_length!-graph!-neighbor!-edge x;
         leftx := qqe_length!-graph!-neighbor!-left!-on!-edge x;
         % prin2t edgex;
         if not qqe_length!-graph!-neighbor!-marked x 
            and not qqe_length!-graph!-edge!-marked edgex
         then <<
            if qqe_debug!* then  prin2t{"no circle with ",nodex};
            qqe_length!-graph!-edge!-mark edgex;
            new_edges := edgex . new_edges;
            <<
               bad_circles!-branch := car x;
               new_nodes := append(new_nodes,cadr x);
               new_edges := append(new_edges,caddr x);
            >> where x=qqe_length!-graph!-detect!-bad!-circles!-component(
               nodex,sigmax,qqe_length!-graph!-path!-insert!-edge!-right(path,
                  edgex,leftx), dfsnum);
            if bad_circles and bad_circles!-branch then 
               bad_circles := bad_circles!-branch . bad_circles
            else if bad_circles!-branch then
               bad_circles := {bad_circles!-branch};
            >>
         else if not qqe_length!-graph!-edge!-marked edgex then <<
            if qqe_debug!* then 
               prin2t{"circle with sum=",sigmax, node, nodex};
            qqe_length!-graph!-edge!-mark edgex;
            new_edges := edgex . new_edges;
            if not(sigmax = get(nodex,'blocksum)) then << %bad cycle
               if qqe_debug!* then prin2t "detect blocks : !!! bad_cycle";
               bad_circles :=  if bad_circles then 
                  {qqe_length!-graph!-get!-circle(
                  qqe_length!-graph!-path!-insert!-edge!-right(path,edgex,
                     leftx), nodex)} . bad_circles
               else {{qqe_length!-graph!-get!-circle(
                  qqe_length!-graph!-path!-insert!-edge!-right(path,edgex,
                     leftx), nodex)}};
               put(node,'bad_cycle,t); >>;
         >>;
      >>;
      if qqe_debug!* then 
         prin2t{"return from node = ",node,"with bad_circles = ",bad_circles};
      bad_circles := 
         qqe_length!-graph!-shuffle!-circle!-psets(bad_circles,node);
      return {bad_circles,new_nodes,new_edges};
   end;

procedure qqe_length!-graph!-detect!-bad!-circles!-rem!-marks!-nodes(nodes);
   % QQE length graph detect bad circles remove marks nodes. [nodes]
   % is a list of nodes. 
   for each node in nodes do <<
      qqe_length!-graph!-unmark node;
      remprop(node,'blocksum);
      qqe_graph!-rem!-dfsnum(node);
   >>;

procedure qqe_length!-graph!-detect!-bad!-circles!-rem!-marks!-edges(edges);
   % QQE length graph detect bad circles remove marks edges. [edges]
   % is a list of edges.
   for each x in edges do
      qqe_length!-graph!-edge!-unmark x;

procedure qqe_length!-graph!-get!-circle(path,node);
   % QQE length graph get circle. [path] is a path, [node] is a node
   % element. Returs the circle (in path format) in path [path].
   begin
      while car path neq node do
         path := cdr path;
      return path;
   end;

procedure qqe_print!-prop!-path(list,prop);
   % Debugging function.
   while list do <<
      % prin2t{car list, get(car list,prop)};
      list := qqe_length!-graph!-path!-step list;
   >>;

procedure qqe_length!-graph!-maxlength!-bad!-circles(circles);
   % QQE length graph maxlength bad circles. [circles] is a list of
   % (bad) circles. Function calculates maxlength for all nodes
   % appearing in circles of [circles].
   for each circle in circles do
      qqe_length!-graph!-maxlength!-bad!-circle circle;

procedure qqe_length!-graph!-maxlength!-bad!-circle(circle);
   % QQE length graph maxlength bad circle. [circle] is a bad
   % circle. Function updates maxlength value of all nodes appearing
   % in [circle].  use new constructors
   begin scalar rev_circle, top, circle_ext, top_circle;
      top_circle := car circle;
      rev_circle := qqe_length!-graph!-reverse!-path circle;
      rev_circle := append(rev_circle,rev_circle);
      circle_ext := append(circle,circle);
      qqe_update!-maxlength(car circle,
            qqe_length!-graph!-maxlength!-bad!-circle1 circle_ext);
      circle_ext := qqe_length!-graph!-path!-step circle_ext;
      top := car circle_ext; %!!!
      while top neq top_circle do <<
         qqe_update!-maxlength(top,
            qqe_length!-graph!-maxlength!-bad!-circle1 circle_ext);
         circle_ext := qqe_length!-graph!-path!-step circle_ext;
         top := car circle_ext;
      >>;
      qqe_update!-maxlength(car rev_circle,
         qqe_length!-graph!-maxlength!-bad!-circle1 rev_circle);
      rev_circle := qqe_length!-graph!-path!-step rev_circle;
      top := car rev_circle;
      while top neq top_circle do <<
         qqe_update!-maxlength(top,
            qqe_length!-graph!-maxlength!-bad!-circle1 rev_circle);
         rev_circle := qqe_length!-graph!-path!-step rev_circle;
         top := car rev_circle;
      >>;
      circle_ext := circle;
      while circle_ext do <<
         top := car circle_ext;
         qqe_length!-graph!-update!-maxlength!-context(top,
            get(top,'maxlength));
         circle_ext := qqe_length!-graph!-path!-step circle_ext;
      >>;
      if qqe_debug!* then qqe_print!-prop!-path(circle,'maxlength);
   end;

procedure qqe_length!-graph!-path!-next!-node(path);
   % QQE length graph path next node. [path] is a path. Returns next
   % node appearing on path.
   if cdr path then if cddr path then caddr path;

procedure qqe_length!-graph!-path!-step(path);
   % QQE length graph path step. [path] is a path. Proceeds one step
   % forward in path [path].
   if cdr path then cddr path else nil;

procedure qqe_length!-graph!-path!-next!-edge(path);
   % QQE length graph path next edge. [path] is a path. Returns the
   % next edge in [path].  i'm standing on a node
   if cdr path then cadr cadr path;

procedure qqe_length!-graph!-path!-next!-edge!-left(path);
   % QQE length graph path next edge left. [path] is a path. Returns
   % the left value of the next edge appearing in [path].
   if cdr path then car cadr path;

procedure qqe_length!-graph!-path!-next!-edge!-value(path);
   % QQE length graph path next edge value. Return the value of the
   % side according to the value [left!-on!-edge] for the next edge on
   % [path].
   if qqe_length!-graph!-path!-next!-edge!-left path then
      qqe_length!-graph!-edge!-el 
         qqe_length!-graph!-path!-next!-edge path
   else qqe_length!-graph!-edge!-er 
      qqe_length!-graph!-path!-next!-edge path;

procedure qqe_length!-graph!-path!-next!-edge!-diff(path);
   % QQE length graph path next edge diff. [path] is a path. Returns
   % the diff value of the next edge appearing on [path].  i'm
   if qqe_length!-graph!-path!-next!-edge!-left path then
      qqe_length!-graph!-edge!-diff 
         qqe_length!-graph!-path!-next!-edge path
   else - qqe_length!-graph!-edge!-diff 
      qqe_length!-graph!-path!-next!-edge path;

procedure qqe_length!-graph!-maxlength!-bad!-circle1(circle);
   begin scalar maxlength, sigma, e, node, top;
      maxlength := qqe_length!-graph!-path!-next!-edge!-value circle 
         + 1;
      sigma := maxlength + 
         qqe_length!-graph!-path!-next!-edge!-diff circle;
      top := car circle;
      while node neq top do <<
         circle := qqe_length!-graph!-path!-step circle;
         node := car circle;
         e :=  max(0,qqe_length!-graph!-path!-next!-edge!-value circle
            - sigma + 1);
         maxlength := maxlength + e;
         sigma := sigma + e;
      >>;
      return maxlength - 1;   
   end;

procedure qqe_length!-graph!-reverse!-path(path);
   % QQE length graph reverse path. [path] is a path. Returns reversed
   % path [path].
   begin scalar flag, rev_path;
      flag := t;
      for each x in cdr path do <<
         if flag then 
            rev_path := qqe_length!-graph!-path!-insert!-edge!-left(
               rev_path, cadr x, not car x)
         else rev_path := x . rev_path;
         flag := not flag;
      >>;
      return car path . rev_path;
   end;
         

procedure qqe_length!-graph!-path!-insert!-edge!-right(path,edge,left);
   % QQE length graph insert edge right. Inserts a new edge to the
   % right of the ath [path]. [edge] is a edge. [left] is a boole.
   append(path,{{left,edge}});

procedure qqe_length!-graph!-path!-insert!-edge!-left(path,edge,left);
   % QQE length graph path insert edge left. Inserts a new edge to the
   % left of the ath [path]. [edge] is a edge. [left] is a boole.
   {left,edge} . path;

procedure qqe_length!-graph!-path!-insert!-node!-right(path,node);
   % QQE length graph path insert node right. [path] is a path, [node]
   % is a node. Inserts node from the right in [path].
   append(path,{node});


procedure qqe_length!-graph!-path!-insert!-node!-left(path,node);
   % QQE length graph path insert node left. [path] is a path, [node]
   % is a node. Inserts node from the left in [path].
   node . path;
      

procedure qqe_length!-graph!-shuffle!-circle!-psets(circle_sets,node);
   %% QQE length graph shuffle circle powersets. [circle_sets] is a
   %% list of sets of circles. [node] is a node element. Function
   %% returns a list of circles.
   begin scalar set1, circles;
      if null circle_sets then return nil
      else if null cdr circle_sets then return car circle_sets;
      for each cs1 on circle_sets do <<
         set1 := car cs1;
         for each set2 in cdr cs1 do
            circles := append(qqe_length!-graph!-shuffle!-circle!-sets(set1,
               set2,node),circles);
      >>;
      return circles;
   end;

procedure qqe_length!-graph!-shuffle!-circle!-sets(set1, set2,node);
   % QQE length graph shuffle circle sets. [set1], [set2] are sets of
   % circles. [node] is a node element. Function shuffles circles in
   % [set1] with circles in [set2] and returns a list of circles.
   begin scalar circles;
      for each circle1 in set1 do 
         for each circle2 in set2 do 
            if qqe_length!-graph!-shufflable(circle1,circle2,node) then
               circles := qqe_length!-graph!-shuffle!-circles(circle1, 
                  circle2,node) . circles;
      return append(circles,append(set1,set2));
   end;

procedure qqe_length!-graph!-shufflable(circle1,circle2,node);
   % QQE length graph shufflable. [circle1], [circle2] are
   % circles. [node] is a node element. Returns [t] if circles are
   % shufflable, else [nil].
   <<
      if circle1_topdfs and circle2_topdfs and circle1_topdfs >= nodedfs 
         and 
         circle2_topdfs >= nodedfs and not(circle1_topdfs = circle2_topdfs)
      then t else nil >>
         where circle1_topdfs=qqe_graph!-get!-dfsnum car circle1,
      circle2_topdfs=qqe_graph!-get!-dfsnum car circle2, 
      nodedfs=qqe_graph!-get!-dfsnum node;

procedure qqe_length!-graph!-shuffle!-circles(c1,c2, node);
   % QQE length graph shuffle circles. [c1], [c2] are circles. [node]
   % is a node element. Function shuffles [c1] with [c2].
   begin scalar firstc, secondc, shufflec, temp;
      if qqe_length!-graph!-shuffle!-circles!-order(c1,c2,node) then <<
         firstc := c1;
         secondc := c2;
      >>
      else <<
         firstc := c2;
         secondc := c1;
      >>;
      % temp_c := firstc;
      temp := car firstc;
      while temp neq car secondc do <<
         shufflec := append(shufflec,{temp});
         firstc := cdr firstc;
         temp := car firstc;
      >>;
      shufflec := append(shufflec,{temp});
      secondc := reverse secondc;
      temp := car secondc;
      while temp neq node do <<
         shufflec := append(shufflec,{temp});
         secondc := cdr secondc;
         temp := car secondc;
      >>;
      while car firstc neq node do 
         firstc := cdr firstc;
      shufflec := append(shufflec,firstc);
      
      return shufflec;
   end;

   
procedure qqe_length!-graph!-shuffle!-circles!-order(c1,c2,node);
   % QQE length graph shuffle circles order. [c1], [c2] are
   % circles. [node] is a node element. Returns [t] if [c1] is of
   % higher order then [c2], [nil] else.
   begin scalar top1, top2, top1_temp, top2_temp;
     top1_temp := car c1;
     top2_temp := car c2;
     top1 := top1_temp;
     top2 := top2_temp;
     while top1_temp neq top2 and top2_temp neq top1 and
        top1_temp neq node and top2_temp neq node do <<
           c1 := cdr c1;
           c2 := cdr c2;
           top1_temp := car c1;
           top2_temp := car c2;
        >>;
     if top2_temp eq top1 or top1_temp eq node then
        return nil
     else return t;
   end;  



procedure qqe_length!-graph!-neighbor!-mark(neighbor);
   % QQE length graph neighbor mark. [neighbor] is a neighbor
   % element. Function marks the node belonging to [neighbor]. 
   qqe_length!-graph!-mark qqe_length!-graph!-neighbor!-node neighbor;

procedure qqe_length!-graph!-neighbor!-marked(neighbor);
   % QQE length graph neighbor marked. [neighbor] is a neighbor
   % element. Returns [t] if the node belonging to [neighbor] is
   % marked, [nil] else.
   qqe_length!-graph!-marked qqe_length!-graph!-neighbor!-node neighbor;
       
procedure qqe_length!-graph!-update!-maxlength(node,length);
   % QQE length graph update maxlength. [node] is a node element,
   % [length] is a positive integer. Recursively updates maxlengths of
   % all nodes within the reach of [node] (t.i. the transitive closure
   % of the neighborhood). [node] is updated.
   if qqe_update!-maxlength(node,length) then 
      for each x in qqe_length!-graph!-neighbors node do 
         qqe_length!-graph!-update!-maxlength(
            qqe_length!-graph!-neighbor!-node x, 
            if qqe_length!-graph!-neighbor!-edge1 x >= length then 
               qqe_length!-graph!-neighbor!-edge2 x 
            else length + qqe_length!-graph!-neighbor!-diff x);

procedure qqe_length!-graph!-update!-maxlength!-context(node,length);
   % QQE length graph update maxlength context. [node] is a node
   % element, [length] is a positive integer. Recursively update the
   % maxlengths of all nodes within the reach of [node] (t.i. the
   % transitive closure of the neighborhood). [node] is not updated.
   for each x in qqe_length!-graph!-neighbors node do <<
      % prin2t x;
      qqe_length!-graph!-update!-maxlength(
         qqe_length!-graph!-neighbor!-node x, 
         if qqe_length!-graph!-neighbor!-edge1 x >= length then 
            qqe_length!-graph!-neighbor!-edge2 x 
         else length + qqe_length!-graph!-neighbor!-diff x); 
   >>;

procedure qqe_length!-graph!-update!-maxlengths(nodes);
   % QQE length graph update maxlengths. [nodes] is a list of
   % nodes. Recursively update the maxlength in the contexts of each
   % element in [nodes].
   for each x in nodes do 
      qqe_length!-graph!-update!-maxlength!-context(x,get(x,'maxlength));

procedure qqe_length!-graph!-update!-minlengths(nodes);
   % QQE length graph update minlength. [nodes] is a list of
   % nodes. Recursively update the minlength in the contexts of each
   % element in [nodes].
   for each x in nodes do 
      qqe_length!-graph!-update!-minlength!-context(x,get(x,'minlength));

procedure qqe_length!-graph!-update!-minlength!-context(node,length);
   % QQE length graph update minlength context. [node] is a node
   % element, [length] is a positive integer. Recursively update the
   % minlengths of all nodes within the reach of [node] (t.i. the
   % transitive closure of the neighborhood). [node] is not updated.
   for each x in qqe_length!-graph!-neighbors node do
      if qqe_length!-graph!-neighbor!-edge1 x < length then
         qqe_length!-graph!-update!-minlength(
            qqe_length!-graph!-neighbor!-node x, 
            length + qqe_length!-graph!-neighbor!-diff x);

procedure qqe_length!-graph!-update!-minlength(node, length);
   % QQE length graph update minlength. [node] is a node element,
   % [length] is a positive integer. Recursively updates minlengths of
   % all nodes within the reach of [node] (t.i. the transitive closure
   % of the neighborhood). [node] is updated.
   if qqe_update!-minlength(node,length) then
      for each x in qqe_length!-graph!-neighbors node do
         if qqe_length!-graph!-neighbor!-edge1 x < length then
            qqe_length!-graph!-update!-minlength(
               qqe_length!-graph!-neighbor!-node x, 
               length + qqe_length!-graph!-neighbor!-diff x);

procedure qqe_length!-graph!-marked(var);
   % QQE length graph marked. [var] is a node. Return [t] if [var] is
   % marked, [nil] else.
    get(var,'blockmark);

procedure qqe_length!-graph!-mark(var);
   % QQE length graph mark. [var] is a node. Functions marks [var].
   put(var,'blockmark,t);

procedure qqe_length!-graph!-unmark(var);
   % QQE length graph unmark. [var] is a node. Function unmarks [var].
   remprop(var,'blockmark);

procedure qqe_length!-graph!-bterm(term, var_list);
   % QQE length graph basic type term. Subroutine of
   % [qqe_length!-graph!-clause]. [term] is a term of basic
   % type. [var_list] is a list of identifiers. Returns a list of
   % identifiers. Newly in the graph as nodes inserted identifiers are
   % add to [var_list].
   begin
      if null term or atom term then return var_list;
      if qqe_op term memq '(lhead rhead) then 
         var_list := qqe_length!-graph!-bterm!-update!-headmin(term, var_list)
      else for each x in cdr term do 
         var_list := qqe_length!-graph!-bterm(x,var_list);
      return var_list;
   end;

procedure qqe_length!-graph!-bterm!-update!-headmin(term, var_list);
   % QQE ength graph basic term update headmin. Subroutine of
   % [qqe_length!-graph!-bterm]. [term] is a basic term with leading
   % lhead or rhead. [var_list] is a list of identifiers. Returns a
   % list of identifiers. Newly in the graph as nodes inserted
   % identifiers are added to [var_list].
   begin scalar var, prefix_length, headmin;
      var := qqe_qprefix!-var term;
      if var eq 'qepsilon then return;
      prefix_length := qqe_prefix!-length term;
      headmin := get(var,'headmin);
      if null headmin then <<
         put(var,'headmin,prefix_length);
         var_list := lto_insertq(var,var_list);
      >>
      else if prefix_length > headmin then 
         put(var,'headmin,prefix_length); 
      return var_list;
   end; 

procedure qqe_length!-graph!-at!-notq(at, var_list);
   % TODO obsolete
   begin
      var_list := qqe_length!-graph!-term!-notq(qqe_arg2l at, 
         var_list);
      var_list := qqe_length!-graph!-term!-notq(qqe_arg2r at, 
         var_list);
      return var_list;
   end;

procedure qqe_length!-graph!-term!-notq(term, var_list);
   % TODO obsolete
   begin scalar var;
      if atom term then return var_list
      else if qqe_op term memq '(lhead rhead) then << 
         var := qqe_qprefix!-var term;
         qqe_update!-minlength(var, qqe_prefix!-length term);
         return lto_insertq(var,var_list);
      >>
      else <<
         for each x in cdr term do
            var_list := qqe_length!-graph!-term!-notq(x, var_list);
         return var_list;
      >>;
   end;

procedure qqe_length!-graph!-at!-qneq(lhs, var_list);
   % QQE length graph atomic formula with qneq. Subroutine of
   % [qqe_length!-graph!-clause]. [lhs] is one / the left hand side of
   % a atomic formula M q <<>> qepsilon. [var_list] is a list of
   % identifiers. Returns a list of identifiers. Newly in the graph as
   % nodes inserted identifiers are add to [var_list].
   begin scalar var_lhs;
      var_lhs := qqe_qprefix!-var lhs;
      qqe_update!-minlength(var_lhs, qqe_prefix!-length lhs + 1);
      return lto_insertq(var_lhs,var_list);
   end;

procedure qqe_length!-graph!-at!-qequal(at, var_list);
   % QQE length graph atomic formula with qequal. Subroutine of
   % [qqe_length!-graph!-clause]. [at] is one / the left hand side of
   % a atomic formula M q <<>> qepsilon. [var_list] is a list of
   % identifiers. Returns a list of identifiers. Newly in the graph as
   % nodes inserted identifiers are add to [var_list].
   begin scalar varlhs, varrhs, lhs, rhs;
      lhs := qqe_arg2l at;
      rhs := qqe_arg2r at;
      varlhs := qqe_qprefix!-var(lhs);
      varrhs := qqe_qprefix!-var(rhs);
      
      if varrhs eq 'qepsilon then <<
         qqe_update!-maxlength(varlhs,qqe_prefix!-length lhs);
         var_list := lto_insertq(varlhs,var_list);
      >>
      else if varlhs eq 'qepsilon then <<
         qqe_update!-maxlength(varrhs,qqe_prefix!-length rhs);
         var_list := lto_insertq(varrhs,var_list);
      >>
      else << 
         qqe_update!-graph!-adlist(varlhs,varrhs,qqe_prefix!-length lhs,
            qqe_prefix!-length rhs);
         var_list := lto_insertq(varlhs,var_list);
         var_list := lto_insertq(varrhs,var_list);
      >>;
      
      return var_list;
   end;

procedure qqe_length!-graph!-correct(var_list);
   % QQE length graph correct. [var_list] is a list of identifiers
   % representing nodes of the graph. Return [t] if graph is correct,
   % [nil] otherwise. Subroutine is [qqe_length!-graph!-correct!-adlist].
   begin scalar minlength, maxlength, list, v, correct;
      list := var_list;
      if null var_list then return t;
      correct := t;
      while list and correct do <<
         v := car list;
         % if null get(v,'lengthmark) then <<
         %   put(v,'lengthmark,t);
         minlength := get(v,'minlength);
         maxlength := get(v,'maxlength);
         %% todo: work here with the length comparison functions
         if minlength and maxlength and maxlength < minlength then 
            correct := nil;
         if correct and minlength then 
            correct := qqe_length!-graph!-correct!-adlist(v, minlength);
         % >>;
         list := cdr list;
      >>;
      % qqe_length!-graph!-remove!-mark(var_list);
      return if null correct then correct else var_list;   
   end;

procedure qqe_length!-graph!-correct!-adlist(v, minlength);
   % QQE length graph correct adlist. [v] is a identifier representing
   % a node in the graph. [minlength] is an integer: the minlength of
   % [v]. Routine checks the adlist of [v] for correctness according
   % to [minlength] of [v]. Returns [t] if adlist is correct, [nil]
   % otherwise.
   begin scalar correct, temp, el, x, list, maxlength, var;
      % minlength := get(v,'minlength);
      correct := t;
      list := get(v,'adlist);
      while list and correct do <<
         var := car car list;
         maxlength := get(var,'maxlength);
      
         el := cdr car list;
         while correct and el do <<
            %% x := (diffi,(li,ri));
            x := car el;
            if minlength > car cadr x then <<
               if maxlength and maxlength < cadr cadr x then 
                  correct := nil;
               if null temp then temp := car x
               else if car x neq temp then correct := nil;
            >>;
            el := cdr el;
         >>;
         temp := nil;
         list := cdr list;
      >>;
      return correct;
   end;

procedure qqe_length!-graph!-remove!-mark(var_list,mark);
   % QQE length graph remove mark. [var_list] is a list of identifiers
   % representing nodes in a length graph. [mark] is a
   % property. Removes all properties [mark] for each element in list
   % [var_list].
   for each v in var_list do <<
      % prin2t{"removing mark",mark," from ",v};
      remprop(v,mark);
   >>;

procedure qqe_length!-graph!-delete(list);
   % QQE length graph delete. [list] is a list of identifiers
   % representing a length graph. Routine deletes the length graph,
   % that is: all properties of the length graph are removed from the
   % variables.
   begin
      if null list then return;
      qqe_length!-graph!-remove!-mark(list,'maxlength);
      qqe_length!-graph!-remove!-mark(list,'minlength);
      qqe_length!-graph!-remove!-mark(list,'adlist);
      qqe_length!-graph!-remove!-mark(list,'headmin);
      qqe_length!-graph!-remove!-mark(list,'neighbors);
   end;

procedure qqe_length!-graph!-print(list);
   % QQE length graph print. [list] is a list of identifiers
   % representing a length graph. Textual print routine for length
   % graphs. Needed for debugging purposes only.
   for each x in list do <<
      prin2t{"var=",x,"with minlength=",get(x,'minlength),
         " and maxlength=", get(x,'maxlength), " and headmin=", 
         get(x,'headmin), " with adlist", get(x,'neighbors)};
   >>;

procedure qqe_print!-prop!-list(list,prop);
   for each x in list do
      prin2t{x,get(x,prop)};

procedure qqe_minlength!-var(var);
   % QQE minlength var. Returns the minlength of variable [var].
   <<
      if minlength then minlength
      else 0
   >> where minlength=get(var,'minlength);

procedure qqe_maxlength!-var(var);
   % QQE minlength var. Returns the maxlength of variable [var].
   <<
      if maxlength then maxlength
      else 'infty
   >> where maxlength=get(var,'maxlength);

procedure qqe_less!-length(l1,l2);
   % QQE less length. [l1] and [l2] are lengths, that is integers or
   % 'infty. Returns [t], if [l1] < [l2], otherwise [nil].
   if l1 eq l2 then nil
   else if l1 eq 'infty then nil
   else if l2 eq 'infty then t
   else if l1 < l2 then t
   else nil;

procedure qqe_lesseq!-length(l1,l2);
   if l1 eq l2 then t
   else if l1 eq 'infty then nil
   else if l2 eq 'infty then t
   else if l1 < l2 then t
   else nil;

procedure qqe_greatereq!-length(l1,l2);
   % QQE greater length. [l1] and [l2] are lengths, that is integers or
   % 'infty. Returns [t], if [l1] >= [l2], otherwise [nil].
   not qqe_less!-length(l1,l2);

procedure qqe_min!-length(l1,l2);
   % QQE min length. [l1] and [l2] are lengths, that is integers or
   % 'infty. Returns the min of [l1] and [l2].
   if l1 eq l2 then l1
   else if l1 eq 'infty then l2
   else if l2 eq 'infty then l1
   else if l1 < l2 then l1
   else l2;

procedure qqe_max!-length(l1,l2);
   % QQE max length. [l1] and [l2] are lengths, that is integers or
   % 'infty. Returns the max of [l1] and [l2].
   if l1 eq l2 then l1
   else if l1 eq 'infty then l1
   else if l2 eq 'infty then l2
   else if l1 < l2 then l2
   else l1;
   
procedure qqe_qprefix!-var(u);
   % QQE queue prefix of variable. [u] is a queue term without
   % appearences of ladd, radd. Returns the variable of sort queue
   % which is argument of the term, or qepsilon if V_queue(u) =
   % emptyset.
   begin
      while u and not atom u do
      <<
         if qqe_op u memq '(ltail rtail lhead rhead) then
            u := qqe_arg2l u
         else u :=  qqe_arg2r u;
      >>;
      return u;
   end;


%--------------harmless test-----------------------------

procedure qqe_harmless!-formula!-test(f);
   % QQE harmless formula test. [f] is a formula. Returns [t] if [f]
   % is harmless, [nil] otherwise.
   begin scalar dnf, flag;
      if atom f then return t;
      dnf := rl_dnf f;
      flag := t;
      if qqe_op dnf eq 'and then dnf := {dnf}
      else dnf := cdr dnf;
      while flag and dnf do <<
         flag := qqe_harmless!-formula!-test!-clause(car dnf);
         dnf := cdr dnf;
      >>;
      return flag;
   end;

procedure qqe_harmless!-formula!-test!-clause(clause);
   % QQE harmless formula test. [f] is a conjunction of atomic
   % formulas. Returns [t] if [f] is harmless, [nil] otherwise.
   begin scalar var_list, flag, flag2;
      var_list := qqe_length!-graph!-clause(clause,nil);
      flag := qqe_harmless!-formula!-test!-clause1(clause,var_list);
      flag2 := qqe_harmless!-formula!-test!-clause2(var_list);
      if flag neq flag2 then rederr "harmless-test failure";
      % qqe_length!-graph!-print var_list;
      qqe_length!-graph!-delete var_list;
      return flag;
   end;

procedure qqe_harmless!-formula!-test!-clause2(var_list);
   % subroutine of [qqe_harmless!-formula!-test!-clause].
   begin scalar harmless, minlength, headmin, v;
      harmless := t;

      while var_list and harmless do <<
         v := car var_list;
         minlength := get(v, 'minlength);
         headmin := get(v, 'headmin);
         
         if headmin and ((null minlength) or (headmin > minlength)) 
         then harmless := nil;

         var_list := cdr var_list;
      >>;
      return harmless;
   end;

%% following parts of harmless formula test is only needed if we want
%% to put the headmin calculation out of length graph ... but as
%% length graph calculation is at the moment only needed in
%% combination with harmless formula test we can save time this way

procedure qqe_harmless!-formula!-test!-clause1(clause, var_list);
   % TODO
   begin scalar flag, at, var_list;
      flag := t;
      if atom clause then return t;
      % if null qqe_length!-graph!-correct(var_list) then return nil;
      if null var_list then
         return t;  %% was nil -- why?!
      % qqe_length!-graph!-print var_list;
      
      if car clause neq 'and then clause := {clause}
      else clause := cdr clause;
      while flag and clause do <<
         at := car clause;
         if pairp at and not(qqe_op at memq '(qequal qneq)) 
         then flag := qqe_harmless!-formula!-test!-at(rl_prepat at);
         clause := cdr clause;
      >>;
      return flag;
   end;

procedure qqe_harmless!-formula!-test!-at(at);
   % QQE harmless formula test atomic formula. [at] is an atomic
   % formula. This is a subfunction of
   % [qqe_harmless!-formula!-test!-clause1].
   begin scalar flag;
      flag := qqe_harmless!-formula!-test!-term(qqe_arg2l at);
      if flag then
         flag := qqe_harmless!-formula!-test!-term(qqe_arg2r at);
      return flag;
   end;

procedure qqe_harmless!-formula!-test!-term(term);
   % QQE harmless formula test term. [term] is a
   % term. Function is a subfunction of
   % [qqe_harmless!-formula!-test!-at.
   begin scalar flag;
      if atom term then return t;
      flag := t;
      if qqe_op term memq '(lhead rhead) then 
         return qqe_harmless!-formula!-test!-qterm term;
      term := cdr term;
      while term and flag do <<
         flag := qqe_harmless!-formula!-test!-term car term;
         term := cdr term;
      >>;
      return flag;
   end;

procedure qqe_harmless!-formula!-test!-qterm(term);
   % QQE harmless formula test queue term. [term] is a
   % term of type queue. Function is a subfunction of
   % [qqe_harmless!-formula!-test!-term.
   begin scalar var, minlength;
      var := qqe_qprefix!-var term;
      if var eq 'qepsilon then return t;
      minlength := get(var,'minlength);
      if null minlength then return nil;
      if minlength < qqe_prefix!-length term then return nil
      else return t;
   end;

procedure qqe_make!-harmless(f);
   % QQE make harmless. rl_dnf doesnt preserve the harmless property
   % for harmless formulas in the conjunctions. This procedure takes
   % care of this. [f] is a dnf.
   begin scalar f2;
      if atom f then return f
      else if car f eq 'or then <<
         for each x in cdr f do 
            f2 := append(f2,{qqe_make!-harmless!-clause x});
         return append({'or}, f2);
      >>
      else return qqe_make!-harmless!-clause f;
   end;

procedure qqe_make!-harmless!-clause(f);
   % QQE make harmless clause. subfunction of
   % [qqe_make!-harmless]. [f] is a conjunction of atomic
   % formulas. returns an equivalent formula which is harmless.
   begin scalar add_on;
      if not (rl_cxp car f) then <<
         add_on := qqe_make!-harmless!-at rl_prepat f;
         return if add_on then append(append({'and},{f}),add_on)
         else f;
      >>
      else for each x in cdr f do 
         add_on := append(add_on,qqe_make!-harmless!-at rl_prepat x);
      return if add_on then append(append({'and},cdr f),add_on)
      else f;
   end;

procedure qqe_make!-harmless!-at f;
   % QQE make harmless atomic formula. subroutine of
   % [qqe_make!-harmless!-clause]. [f] is an atomic formula.
   begin scalar add_on;
      add_on := nil;
      if atom f or qqe_op f memq '(qneq qequal) then return nil;
      for each x in cdr f do <<
         if not atom x and qqe_op x memq '(lhead rhead) then 
            add_on := append(add_on,{{'qneq, qqe_arg2l x, 'qepsilon}})
         else add_on := append(add_on, qqe_make!-harmless!-at x);
      >>;
      % prin2t{"will return", add_on};
      return add_on;
   end;



%% end of the at the moment not needed code

% ---------------- satlengths qneq--------------------------------------------

procedure qqe_quicksort!-dbl!-crit(list);
   % Queue quantifier elimination quicksort. Quicksort of a list of integers
   % in reverse order. For example (2 4 3 5) -> (5 4 3 2).
   begin scalar pivot;
      if list then
      <<
         pivot := car list;
         list := qqe_partition!-dbl!-crit(cdr list,pivot);
         list := append(qqe_quicksort!-dbl!-crit(car list),
            append({pivot}, qqe_quicksort!-dbl!-crit(cadr list)));
      >>;
      return list;
  end;

procedure qqe_partition!-dbl!-crit(list, pivot);
   % Queue quantifier elimination partition. Belongs to quicksort algorithm.
   begin scalar l,r, x, lp;

      for each x in list do
      <<
         lp := qqe_lessp!-dbl!-crit(x,pivot);
         if null lp then r := append(r,{x})
         else if lp eq t then l := append(l,{x});
      >>;
      return {l,r};
   end;

procedure qqe_lessp!-dbl!-crit(x1,x2);
   % TODO at the moment not needed
   begin scalar minlength1, minlength2, maxlength1, maxlength2;
      minlength1 := get(x1,'minlength);
      minlength2 := get(x2,'minlength);
      maxlength1 := get(x1,'maxlength);
      maxlength2 := get(x2,'maxlength);
      
      if null minlength1 and null minlength2 then <<
         if null maxlength1 and null maxlength2 then return 'eq
         else if null maxlength2 then return nil
         else if null maxlength1 then return t
         else if maxlength1 < maxlength2 then return nil
         else if maxlength1 = maxlength2 then return 'eq 
         else return t;
      >>
      else if null minlength1 then return t
      else if null minlength2 then return nil
      else if minlength1 < minlength2 then return t
      else if minlength1 = minlength2 then <<
         if null maxlength1 and maxlength2 then return nil
         else if maxlength1 eq maxlength2 then return 'eq
         else return t;
      >>
      else return nil;
   end;

endmodule;  % [qqemisc]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqesiat.red0000644000175000017500000002500111526203062024707 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqesiat.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_siat_rcsid!* qqe_siat_copyright!*);
   qqe_siat_rcsid!* :=
      "$Id: qqesiat.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_siat_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

module qqesiat;
% QQE simplify atomic formula. Submodule of [qqe].

procedure qqe_simplat1(f, sop);
   % QQE simplify atomic formula. [f] is an
   % atomic formula; [sop] is the boolean operator [f] occurs with or
   % [nil]. Returns a quantifier-free formula that is a
   % simplified equivalent of [f].
   <<
      if not (rel memq '(qequal qneq)) then qqe_simplbtat(f,sop)
      else if rel eq 'qequal then qqe_simplqequal(f,sop)
      else qqe_simplqneq(f,sop)
   >> where rel=qqe_op f;
   
procedure qqe_simplbtat(f, sop);
   % QQE simplify basic type atomic formula. [f] is a atomic formula
   % of basic type.
   begin scalar prepf, eta_lhs, eta_rhs, op;
      
      prepf := rl_prepat f;
      % prepf := f;
      op := qqe_op f;

      eta_lhs := qqe_eta!-in!-term qqe_arg2l prepf;
      eta_rhs := qqe_eta!-in!-term qqe_arg2r prepf;

      if eta_lhs and null eta_rhs then <<
         if op neq 'neq then return 'false
         else return 'true;
      >>
      else if eta_rhs and null eta_lhs then <<
         if op neq 'neq then return 'false
         else return 'true;
      >>
      else if eta_lhs and eta_rhs then << 
         if qqe_op f eq 'equal then return 'true
         else return 'false;
      >>
      else return rl_simpat prepf; 
   end;

procedure qqe_eta!-in!-term(term);
   % QQE eta in term. [term] is a term of basic type. Return [t] if
   % the simplified term contains a term (tail qepsilon), where tail
   % is ltail or rtail.
   begin scalar eta_in, x;
      eta_in := nil;
      if atom term then return nil
      else if qqe_op term memq '(lhead rhead) then 
         return qqe_eta!-in!-term1 term %!!!
      else <<
         x := cdr term;
         while x and null eta_in do
         <<
            % prin2t car x;
            if not atom car x then <<
               if qqe_op car x memq '(lhead rhead) then
                  eta_in := qqe_eta!-in!-term1(car x) 
               %else if qqe_op car x eq 'plus then
               %   car x := qqe_simplterm!-plus car x;
               else eta_in := qqe_eta!-in!-term car x;
            >>;
            
            x := cdr x;
         >>;
         return eta_in;
      >>;
               
   end;

procedure qqe_eta!-in!-term1(term);
   begin scalar arg;
      arg := qqe_simplterm cadr term;
      term := qqe_op term . arg;
      if arg eq 'qepsilon then return t
      else return nil;
   end;

procedure qqe_simplqequal(f, sop);
   % QQE simplify atomic formula with qequal. [f] is a atomic formula
   % with qequal. Returns simplified formula.
   begin scalar lhs,rhs, varlhs, varrhs, noal, noar, notl, notr, rhsnew,
      lhsnew;
      rhs := qqe_arg2r f;
      lhs := qqe_arg2l f;

      if rhs = lhs then return 'true;

      varlhs := qqe_qprefix!-var(lhs);
      varrhs := qqe_qprefix!-var(rhs);

      if (varlhs eq varrhs) or (varlhs eq 'qepsilon) or 
         (varrhs eq 'qepsilon)
      then <<
         noar := qqe_number!-of!-adds!-in!-qterm rhs;
         noal := qqe_number!-of!-adds!-in!-qterm lhs;
         notr := qqe_number!-of!-tails!-in!-qterm rhs;
         notl := qqe_number!-of!-tails!-in!-qterm lhs;

         if (varlhs eq varrhs) and ((noar>=notr) or (noal>=notl)) 
            and not((noar-notr) = (noal-notl)) then <<
               return 'false; >>
                          
         else if (rhs eq 'qepsilon) and (noal > notl) 
         then return 'false
            
         else if (lhs eq 'qepsilon) and (noar > notr) 
         then return 'false
         else if (rhs eq 'qepsilon) and (noar = 0 and noal = 0) then 
         <<
            
            if varlhs eq 'qepsilon then return 'true
            else lhsnew := qqe_simplterm lhs;
            return qqe_mk2('qequal,lhsnew,rhs);
         >>
         else if (lhs eq 'qepsilon) and (noar = 0 and noal = 0) then
         <<
            
            if varrhs eq 'qepsilon then return 'true
            else rhsnew := qqe_simplterm rhs;
            return qqe_mk2('qequal,lhs,rhsnew);
         >>
      >>;
      
      rhsnew := qqe_simplterm rhs;
      lhsnew := qqe_simplterm lhs;
      if (rhs = rhsnew) and (lhs = lhsnew) then 
         return qqe_mk2('qequal, lhsnew, rhsnew)
      else 
         return qqe_simplqequal(qqe_mk2('qequal, lhsnew, rhsnew),nil);

   end;

procedure qqe_simplterm(term);
   % QQE simplify term. [term] is a term of queue type. Returns
   % simplified term.
   begin scalar op;
      if atom term then return term;
      op := qqe_op term;

      if op memq '(ltail rtail) then return qqe_simplterm!-tail term
      else if op memq '(lhead rhead) 
      then return qqe_simplterm!-head term
      else if op memq '(ladd radd) 
      then return qqe_simplterm!-add term
      else return term;
   end;

procedure qqe_simplterm!-add(term);
   % QQE simplify term with leading operation ladd or radd. [term] is
   % a term with leading operation ladd or radd. Returns simplified term.
   begin scalar arg;
      arg := qqe_arg2r term;
      if atom arg then return term
      else
      <<
         if arg=argnew then return term  
            % !!!qqe_mk2(op,qqe_arg2l term, argnew)
         else return qqe_simplterm qqe_mk2(op,qqe_arg2l term, argnew)
      >> where argnew=qqe_simplterm arg, op=qqe_op term;
   end;

procedure qqe_simplterm!-tail(term);
   % QQE simplify term with leading operation ltail or rtail. [term]
   % is term with leading operation ltail or rtail. Returns simplified
   % term.
   begin scalar arg, op, oparg;
      arg := qqe_arg2l term;
      if arg eq 'qepsilon then return 'qepsilon
      else if atom arg then return term;
      op := qqe_op term;
      oparg := qqe_op arg;
      if oparg memq '(ladd radd) then
      <<
         if (arg2rarg eq 'qepsilon) then return 'qepsilon
         else if op eq 'ltail and oparg eq 'radd then 
            return arg2rarg
         else if op eq 'rtail and oparg eq 'ladd then
            return arg2rarg      
      >> where arg2rarg=qqe_arg2r arg;
      <<
         if argnew = arg then return term % !!!{op,argnew}
         else return qqe_simplterm {op,argnew}
      >> where argnew=qqe_simplterm arg;
   end;

procedure qqe_simplterm!-head(term);
   % QQE simplify term with leading operation lhead or rhead. [term]
   % is a term with leading lhead or rhead. Return simplified term.
   begin scalar arg;
      arg := qqe_arg2l term;
      if atom arg then return term
      else if (qqe_op arg memq '(ladd radd))
         and (qqe_arg2r arg eq 'qepsilon)
      then return qqe_arg2l arg
      else
      <<
         if argnew = arg then return term 
         else return qqe_simplterm {op,argnew}
      >> where argnew=qqe_simplterm arg, op=qqe_op term;
   end;

procedure qqe_number!-of!-adds!-in!-qterm(term);
   % QQE number of adds in qterm. Counts the number of ladds and
   % radds in a term [term] of type queue.
   if atom term then 0
   else if qqe_op term memq '(ladd radd) 
   then 1 + qqe_number!-of!-adds!-in!-qterm qqe_arg2r term
   else qqe_number!-of!-adds!-in!-qterm qqe_arg2l term;

procedure qqe_number!-of!-tails!-in!-qterm(term);
   % QQE number of adds in qterm. Counts the number of ltails and
   % rtails in a term [term] of type queue.
   if atom term then 0
   else if qqe_op term memq '(ladd radd) then
      qqe_number!-of!-tails!-in!-qterm qqe_arg2r term
   else 1 + qqe_number!-of!-tails!-in!-qterm qqe_arg2l term;

procedure qqe_simplqneq(f, sop);
   % QQE simplify atomic formula with qneq. [f] is a atomic formula
   % with qneq. Returns simplified formula.
   begin scalar op, lhs, rhs, negu;
      op := car f;
      lhs := cadr f;
      rhs := caddr f;
      negu := qqe_simplqequal(qqe_mk2('qequal, lhs, rhs),nil);
      if negu eq 'true then f := 'false
      else if negu eq 'false then f := 'true
      else f := qqe_mk2('qneq, qqe_arg2l negu, qqe_arg2r negu);
      
      return f;
   end;

procedure qqe_simpl_standardizeqterm(term);
   %TODO soon going to be obsolete
   begin scalar x;
      x := term;
      while not atom x do
      <<
         car x := 'ltail;
         x := car cdr x;
      >>;
      return term;
   end;

endmodule;  % [qqesiat]

end;  % of file


%% ::: TODO : Other simplifications

%% lhead^l_1(q) == 'qepsilon or/and lhead^l_2(q) == 'qepsilon <->
%% lhead^l_1(q) == 'qespilon with l_1 >/< l_2

%% equal and eta ... neq and eta

%% (qneq (ltail (rtail (rtail (rtail q)))) (ltail
%% (ltail (ladd x140 (ladd x130 (ladd x120 (ladd x110
%% (ladd x100 (ladd x90 (ladd x80 (ladd x70 (ladd x60
%% (ladd x50 (ladd x40 (ladd x30 (ladd x20 (ladd x17 qepsilon)))))))))))))))))
%%    a2:  or
%% qqe_simplat1 = (qneq (ltail (rtail (rtail (rtail q))))
%% (ltail (ltail (ladd x140 (ladd x130 (ladd x120 (ladd x110
%% (ladd x100 (ladd x90 (ladd x80 (ladd x70 (ladd x60
%% (ladd x50 (ladd x40 (ladd x30 (ladd x20 (ladd x17 qepsilon))))))))))))))))) 
%%    AND length q > 16 !!! (maybe as pre-simplification !) 
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqeqemisc.red0000644000175000017500000014643011526203062025242 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqeqemisc.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_qemisc_rcsid!* qqe_qemisc_copyright!*);
   qqe_qemisc_rcsid!* :=
      "$Id: qqeqemisc.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_qemisc_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;
 
module qqeqemisc;
% Quantifier elimination for queues miscellaneous helping functions.

% do i have to list them a second time here!?! as these are fluids of
% module qqeqe.red and qqeqemisc is only submodule of that. !!!
fluid '(qqe_resf!*  % list of atomic formulas not containing the 
                       % bounded variable -qvar-, which actually has
                       % to be eliminated
   qqe_qvarf!*      % list of atomic formulas containing qvar
   qqe_atf!-qequal!-ext!-c!* % list of atomic formulas of form: q == p
   qqe_atf!-qequal!-ext!-p!* % list of atomic formulas of form: Lq == p
   qqe_atf!-equal!-ext!* % list of at. formulas of form: t( ..,Lq,..) = ..
   qqe_atf!-equal!-int!* % list of atomic formulas of form: 
                         % t(...,Lq,...)=t(...,Mq,...)
   qqe_atf!-misc!-basic!* % list of atf of basic type not = or neq
   qqe_atf!-qequal!-int!*   % list of atomic formulas of form: Lq == Mq
   qqe_la!*         % left area
   qqe_ra!*         % right area
   qqe_pat!-lengths!* % list of pattern lengths
   qqe_sf!*         % formula to be quantifiereliminated
   qqe_atf!-qneq!-int!* % list of atomic formulas of form: Lq<<>>Mq
   qqe_atf!-qneq!-ext!* % list of atomic formulas of form: Lq<<>>p
   qqe_atf!-qneq!-ext!-qepsilon!* % list of atform. of form Lq <<>> qeps.
   qqe_atf!-neq!*    % list of atomic formulas of form: t(..,Lq,..) neq ..
   % qqe_atf!-neq!-int!-s!* % list of atomic formulas of form: 
                          % head(..(p)) neq head(..(p))
   qqe_var!*         % quantifier which binds qqe_var!* has to be 
                        % eliminated
   qqe_qqu!-list!*    % list of quantifiers of type queue which have to
                        % to be eliminated
   qqe_bqu!-list!*    % list of quantifiers of basic type
   % qqe_id_counter!*   % counts the number of new id's already used
   );


% sorting procedures --------------------------------------------- %

procedure qqe_insert!-resf(u);
   qqe_resf!* := u . qqe_resf!*;

procedure qqe_insert!-qvarf(u);
   qqe_qvarf!* := u . qqe_qvarf!*;
   
procedure qqe_sort!-resf!-qvarf(u, qvar);
   % queue quantifier elimination rest formula qvar formula.  [u] is a
   % formula, which is considered to be a conjunction of atomic
   % formulas, or an atomic formula. [qvar] is an atom - a variable.
   % The function sorts atomic formulas containing qvar in the list
   % [qqe_qvarf!*] and such not containing qvar in the list
   % [qqe_resf!*].
   begin scalar x;
      if qqe_op u neq 'and then x := {u}
      else x := cdr u; 
      
      while x neq nil do
      <<
         if qqe_dfs(qqe_arg2l rl_prepat car x, qvar) then
            qqe_insert!-qvarf car x
         else if qqe_dfs(qqe_arg2r rl_prepat car x, qvar) then
         <<
            qqe_insert!-qvarf {caar x,qqe_arg2r car x, 
               qqe_arg2l car x};
         >>
         else 
         <<
            qqe_insert!-resf car x;
         >>;
         x := cdr x;
      >>;
   end;

procedure qqe_atf!-qequal!-ext!-c(x,qvar);
   % Queue quantifier elimination atomic formula with qequal to an
   % external queue -that means: not a part queue of qvar- complete,
   % in the sense that for qvar we have no leading prefix.
   (qqe_op x eq 'qequal) and (atom qqe_arg2l x) 
      and not (qqe_dfs(qqe_arg2r x, qvar));

procedure qqe_atf!-qequal!-ext!-p(x, qvar);
  % Queue quantifier elimination atomic formula with qequal to an
  % external element - that means: not a part queue of qvar- ,
  % partial, in the sense that for qvar we have a leading prefix. 
  (qqe_op x eq 'qequal) and not (atom qqe_arg2l x) 
     and (qqe_qoptailp car qqe_arg2l x)
        and not (qqe_dfs(qqe_arg2r x, qvar));
  
procedure qqe_atf!-equal!-ext(x, qvar);
   % Queue quantifier elimination atomic formula with equal. 
   (qqe_op x eq 'equal) and not qqe_dfs(qqe_arg2r x,qvar);

procedure qqe_atf!-equal!-int(x);
   % qqe_atf!-equal!-ext supposed to run first
   (qqe_op x eq 'equal); % and qqe_dfs(qqe_arg2r x, qvar);
 
procedure qqe_atf!-qequal!-int(x,qvar);
   % Queue quantifier elimination atomic formula with qequal to an
   % internal element - that means a part queue of qvar.
   (qqe_op x eq 'qequal) and not (atom qqe_arg2l x)
         and (qqe_qoptailp car qqe_arg2l x) 
            and (qqe_dfs(qqe_arg2l x, qvar))
               and (not atom qqe_arg2r x)
                  and (qqe_qoptailp car qqe_arg2r x)
                     and (qqe_dfs(qqe_arg2r x, qvar));
  
procedure qqe_atf!-qneq!-ext(x,qvar);
   % Queue quantifier elimination atomic formula with qneq to an external
   % element - that means: not a part queue of qvar.
   (qqe_op x eq 'qneq) and not(qqe_dfs(qqe_arg2r x,qvar)) and 
      qqe_arg2r x neq 'qepsilon;
      
procedure qqe_atf!-qneq!-ext!-qepsilon(x);
   (qqe_op x eq 'qneq) and qqe_arg2r x eq 'qepsilon;

procedure qqe_atf!-neq(x);
   % Queue quantifier elimination conjuncts with neq.
   (qqe_op x eq 'neq);
   
procedure qqe_atf!-qneq!-int(x,qvar);
   % Queue quantifier elimination atomic formula with qneq to an internal
   % element - that means a part queue of qvar. 
   (qqe_op x eq 'qneq) and (qqe_dfs(qqe_arg2r x, qvar));

procedure qqe_atf!-misc!-basic(x);
   % Queue quantifier elimination atomic formula with miscellaneous basic
   % type relation.
   not (qqe_op x memq '(equal neq qequal qneq)); 

procedure qqe_sort!-atf(u, qvar);
   % Queue quantifier elimination sort conjuncts. [u] is a formula, more
   % precisely a conjunction of atomic formulas. [qvar] is an atom, a
   % variable.  The function sorts the atomic formulas in the lists
   % [qqe_qvarf!*] and [qqe_resf!*].
   begin 
      qqe_sort!-resf!-qvarf(u,qvar);
     
      for each x in qqe_qvarf!* do
      <<
         if qqe_atf!-qequal!-ext!-c(x, qvar) 
         then qqe_atf!-qequal!-ext!-c!* := x . qqe_atf!-qequal!-ext!-c!* 
         else if qqe_atf!-qequal!-ext!-p(x, qvar)
         then qqe_atf!-qequal!-ext!-p!* := x . qqe_atf!-qequal!-ext!-p!*
         else if qqe_atf!-equal!-ext(x, qvar)
         then qqe_atf!-equal!-ext!* := x .qqe_atf!-equal!-ext!*
         else if qqe_atf!-equal!-int(x)
         then qqe_atf!-equal!-int!* := x . qqe_atf!-equal!-int!*
         else if qqe_atf!-qequal!-int(x, qvar)
         then qqe_atf!-qequal!-int!* := x . qqe_atf!-qequal!-int!*
         else if qqe_atf!-qneq!-ext!-qepsilon(x)
         then qqe_atf!-qneq!-ext!-qepsilon!* := 
            x . qqe_atf!-qneq!-ext!-qepsilon!*
         else if qqe_atf!-qneq!-ext(x, qvar)
         then qqe_atf!-qneq!-ext!* := x . qqe_atf!-qneq!-ext!*
         else if qqe_atf!-neq(x)
         then qqe_atf!-neq!* := x . qqe_atf!-neq!*
         else if qqe_atf!-qneq!-int(x, qvar)
         then qqe_atf!-qneq!-int!* := x . qqe_atf!-qneq!-int!*
         else if qqe_atf!-misc!-basic(x)
         then qqe_atf!-misc!-basic!* := x . qqe_atf!-misc!-basic!*;
         % else prin2t"sort not sorted";
      >>;
   end;

% calculation of values for different key concepts ----------------- %


% left and right area ---------------------------------------------- %
procedure qqe_la();
   % Queue quantifier elimination left area. Returns the length of the 
   % left area for the formula [qqe_sf!*]. The variable [qqe_la!*]
   % is updated.
   begin scalar la;
      la := 0;
      la := max(la,qqe_max!-lefts!-lhs(qqe_atf!-qequal!-ext!-p!*));
      la := max(la,qqe_max!-lefts!-lhs(qqe_atf!-qequal!-ext!-c!*));
      la := max(la,qqe_max!-lefts!-ls!-recursive(qqe_atf!-equal!-ext!*));
      la := max(la,qqe_max!-lefts!-ls!-recursive(qqe_atf!-equal!-int!*));
      la := max(la,qqe_max!-lefts!-bs(qqe_atf!-qequal!-int!*));
      la := max(la,qqe_max!-lefts!-bs!-recursive(qqe_atf!-neq!*));
      la := max(la,qqe_max!-lefts!-lhs(qqe_atf!-qneq!-ext!*));
      la := max(la,qqe_max!-lefts!-bs(qqe_atf!-qneq!-int!*));
      la := 
         max(la,qqe_max!-lefts!-bs!-recursive(qqe_atf!-misc!-basic!*));
      qqe_la!* := la;
      return la;
   end;

procedure qqe_ra();
   % Queue quantifier elimination right area. Returns the length of the 
   % right area for the formula [qqe_sf!*]. The variable [qqe_ra!*]
   % is updated.
   begin scalar ra;
      ra := 0;
      ra := max(ra,qqe_max!-rights!-lhs(qqe_atf!-qequal!-ext!-p!*));
      ra := max(ra,qqe_max!-rights!-lhs(qqe_atf!-qequal!-ext!-c!*));
      ra := max(ra,qqe_max!-rights!-ls!-recursive(qqe_atf!-equal!-ext!*));
      ra := max(ra,qqe_max!-rights!-bs!-recursive(qqe_atf!-equal!-int!*));
      ra := max(ra,qqe_max!-rights!-bs(qqe_atf!-qequal!-int!*));
      ra := max(ra,qqe_max!-rights!-bs!-recursive(qqe_atf!-neq!*));
      ra := max(ra,qqe_max!-rights!-lhs(qqe_atf!-qneq!-ext!*));
      ra := max(ra,qqe_max!-rights!-bs(qqe_atf!-qneq!-int!*));
      ra := 
         max(ra,qqe_max!-rights!-bs!-recursive(qqe_atf!-misc!-basic!*));
      qqe_ra!* := ra;
      return ra;
   end;

% max lefts for different types of atomic formulas ----------------- %

procedure qqe_max!-lefts!-bs!-recursive(atflist);
   % Queue quantifier elimination max lefts both sides
   % recursive. Returns maximal lefts for all terms appearing in list
   % of atomic romulas [atflist].
   begin scalar max;
      max := 0;
      if null atflist then return 0;
      for each x in atflist do
      <<
         max := max(max, max(
            qqe_max!-lefts!-term!-recursive(qqe_arg2l rl_prepat x, 0),
            qqe_max!-lefts!-term!-recursive(qqe_arg2r rl_prepat x, 0)));
      >>;
      return max;
   end;

procedure qqe_max!-lefts!-ls!-recursive(atflist);
   % Queue quantifier elimination max lefts left side
   % recursive. Returns maximal lefts for all terms appearing in list
   % of atomic formulas [atflist].
   begin scalar max;
      max := 0;
      if null atflist then return 0;
      for each x in atflist do
         max := max(max,qqe_max!-lefts!-term!-recursive 
            (qqe_arg2l rl_prepat x, 0));
      return max;
   end;

procedure qqe_max!-lefts!-term!-recursive(term, lefts);
   % Queue quantifier elimination max lefts term recursive. Make dfs
   % through [term] and return max of all lefts.
   begin scalar x;
      x := term;
      if atom x then return lefts;
      if qqe_op x memq '(lhead rhead) 
      then return max(lefts, qqe_prefix!-lefts(x));
      
      x := cdr x;
      
      while x do
      <<
         if (not atom car x) and (qqe_op car x memq '(lhead rhead)) 
            and (qqe_dfs(qqe_arg2l car x, qqe_var!*))
         then lefts := max(lefts, qqe_prefix!-lefts(car x))
         else lefts := qqe_max!-lefts!-term!-recursive(car x, lefts);
         
         x := cdr x;
      >>;
      return lefts;
   end;
         

procedure qqe_max!-lefts!-lhs(u);
   % Queue quantifier elimination max length of left prefix in lhs. 
   % [u] is a formula in lisp prefix.
   begin scalar l,x;
      if null u then x := nil
      else x := u;

      l := 0;

      while x neq nil do
      <<
         l := max(l,qqe_prefix!-lefts(qqe_arg2l rl_prepat car x));
         x := cdr x;
      >>;
      
      return l;
   end;

procedure qqe_max!-lefts!-bs(u);
   % Queue quantifier elimination max length of left prefix considering 
   % both sides of the formula. 
   % [u] is a formula in lisp prefix.
   begin scalar l,x;
      if null u then x := nil
      else x := u;
 
      l := 0;
 
      while x neq nil do
      <<
         l := max(l,max(qqe_prefix!-lefts(
            qqe_arg2l rl_prepat car x), 
            qqe_prefix!-lefts(qqe_arg2r rl_prepat car x)));
         x := cdr x;
      >>;
      
      return l;
   end;

procedure qqe_max!-rights!-lhs(u);
   % Queue quantifier elimination max length of rights prefix in lhs. 
   % [u] is a formula in lisp prefix.
   begin scalar l,x;
      if null u then x := nil
      else x := u;
 
      l := 0;
 
      while x neq nil do
      <<
         l := max(l,qqe_prefix!-rights(qqe_arg2l rl_prepat car x));
         x := cdr x;
      >>;
      
      return l;
   end;

procedure qqe_max!-rights!-bs(u);
   % Queue quantifier elimination max length of rights in prefix
   % considering both sides of the formula.  [u] is a formula in lisp
   % prefix.
   begin scalar l,x;
      if null u then x := nil
      else x := u;
 
      l := 0;
 
      while x neq nil do
      <<
         l := max(l,max(qqe_prefix!-rights(
            qqe_arg2l rl_prepat car x), 
            qqe_prefix!-rights(qqe_arg2r rl_prepat car x)));
         x := cdr x;
      >>;
      
      return l;
   end;

procedure qqe_max!-rights!-bs!-recursive(atflist);
   % Queue quantifier elimination max length of rights in prefix
   % considering both sides of the formula recursively. Returns
   % maximal rights for all terms appearing in list of atomic formulas
   % [atflist].
   begin scalar max;
      if null atflist then return 0;
      max := 0;
      for each x in atflist do
      <<
         max(max,max(qqe_max!-rights!-term!-recursive(
            qqe_arg2l rl_prepat x, 0),
            qqe_max!-rights!-term!-recursive(qqe_arg2r rl_prepat x, 0)));
      >>;
      return max;
   end;

procedure qqe_max!-rights!-ls!-recursive(atflist);
   % Queue quantifier elimination max length of rights in prefix
   % considering left side of the formula recursively. Returns maximal
   % rights for all terms appearing in list of atomic formulas
   % [atflist].
   begin scalar max;
      if null atflist then return 0;
      max := 0;
      for each x in atflist do
      <<
         max := max(max,qqe_max!-rights!-term!-recursive(
            qqe_arg2l rl_prepat x, 0));
      >>;
      return max;
   end;

procedure qqe_max!-rights!-term!-recursive(term, rights);
   % Queue quantifier elimination max length of rights in prefix
   % appearing in term recursively.  [term] is a term in lisp prefix.
   begin scalar x;
      x := term;
      if atom x then return rights;
      if qqe_op x memq '(lhead rhead) 
      then return max(rights, qqe_prefix!-rights(x));
      
      x := cdr x;
      
      while x do
      <<
         if (not atom car x) and 
            (qqe_op car x memq '(lhead rhead)) and
            (qqe_dfs(qqe_arg2l car x, qqe_var!*))
         then rights := max(rights, qqe_prefix!-rights(car x))
         else rights := qqe_max!-rights!-term!-recursive(car x, rights);
         
         x := cdr x;
      >>;
      return rights;
   end;
         
procedure qqe_max!-prefix!-length!-term!-recursive(term, l);
   % Queue quantifier elimination max prefix length in term recursively.
   %  [term] is a term in lisp prefix. -- obsolete !?
    begin % scalar x;
      % x := term;
      if atom term then return l;
      if qqe_op term memq '(lhead rhead)
      then return max(l, qqe_prefix!-length term);

      for each x in cdr term do
      <<
         if (not atom x) and (qqe_op x memq '(lhead rhead))
            and (qqe_dfs(qqe_arg2l x, qqe_var!*))
         then l := max(l, qqe_prefix!-length x)
         else qqe_max!-prefix!-length!-term!-recursive(x, l);
      >>;
      return l;
   end;

procedure qqe_patpos(at, patlength, pos);
   % QQE pattern position. [at] is a atomic formula. [patlength] is a
   % natural number denoting the length of the pattern represented
   % with [at]. [pos] is a positive integer.
   begin scalar l, rem;
      l := min(qqe_prefix!-lefts(qqe_arg2l at), 
         qqe_prefix!-lefts(qqe_arg2r at));
      rem := remainder(pos-l, patlength);
      if pos < l then return -1
      else if rem eq 0 then return patlength
      else return rem;
   end;
   

procedure qqe_pat!-lengths(l);
   % Queue quantifier elimination pattern lengths.[l] is an integer.
   % Returns list of integers, representing the pattern lengths 
   % according to [l] and the list of patterns [qqe_atf!-qequal!-int!*].
   begin scalar list, x;
      x := qqe_atf!-qequal!-int!*;
      if null x then x := qqe_atf!-qneq!-int!*;
      if null x then return nil;

      list := {qqe_pat!-length(car x,l)};
      x := cdr x;
      while x do
      <<
         list := append(list, {qqe_pat!-length(car x,l)});
         x := cdr x;
      >>;    
      x := qqe_atf!-qneq!-int!*;
      if null x then return list;
      while x do
      <<
         list := append(list, {qqe_pat!-length(car x,l)});
         x := cdr x;
      >>;
      return list;
   end;
         

procedure qqe_pat!-length(pat,l);
   % Queue quantifier elimination pattern length. [pat] is a pattern in 
   % the form of an atomic formula in lisp prefix. [l] is an integer.
   % Returns the length of pattern [pat] according to queue length [l].
   begin scalar a, prepat;
      prepat := rl_prepat pat;
      a := qqe_prefix!-length(qqe_arg2l prepat);
      if a < l then
      <<
         if (max(qqe_prefix!-lefts(qqe_arg2l prepat), 
            qqe_prefix!-lefts(qqe_arg2r prepat))) <=
               (l - max(qqe_prefix!-rights(qqe_arg2l prepat), 
                  qqe_prefix!-rights(qqe_arg2r prepat)))
         then return
            abs(qqe_prefix!-lefts(qqe_arg2l prepat) -
               qqe_prefix!-lefts(qqe_arg2r prepat))
         else return l - a;
      >>  

      else return 0;
      
   end;
  
procedure qqe_get!-quantifier!-sequenz(u);
   % returns list of quantifiers and the quantifierfree part of formula
   % [u].  works for pnf.  returns list (y,x) with y is list of
   % quantifiers and x is a quantifier free formula.
   begin scalar x,y;
      
      if atom u then return {nil,nil};
      
      x := u;
      
      while car x memq '(ex all) do
      << %!!!
         y := append(y, {{car x, cadr x}});
         if get(cadr x,'idtype) eq 'qt then 
            qqe_qqu!-list!* := 
               lto_insertq({car x, cadr x},qqe_qqu!-list!*)
         else  
         qqe_bqu!-list!* := lto_insertq({car x, cadr x} ,qqe_bqu!-list!*);
         x := caddr x;
      >>;
   
      return {y,x};
   end;

procedure qqe_atf!-qequal!-ext!-min!-prefix();
   % QQE atomic formula qequal external minimal prefix. Returns [(m
   % term)], where [term] is the term with minimal prefix appearing on
   % lhs of atomic formulas in [qqe_atf!-qequal!-ext!*] and [m] is a
   % natural number denoting the prefix length of [term].
   begin scalar m, mm, term, list;
      
      m := qqe_prefix!-length qqe_arg2l car qqe_atf!-qequal!-ext!-p!*;
      term := car qqe_atf!-qequal!-ext!-p!*;
      list := cdr qqe_atf!-qequal!-ext!-p!*;
      if list then
      <<
         for each x in list do
         <<
            mm := qqe_prefix!-length qqe_arg2l x;
            if mm < m
            then <<
               m := mm;
               term := x;
            >>;
         >>;
      >>;
      return {m, term};
   end;

procedure qqe_atf!-qequal!-ext!-p!-min!-lefts(minlength, minpref);
   % Queue quantifier elimination conjuncts qequal external partial 
   % minimum of left prefixes.
   begin scalar m,mm, term, list, l;
      l := qqe_prefix!-lefts qqe_arg2l minpref;
      m := qqe_prefix!-lefts qqe_arg2l minpref;
      term := minpref;
      % m := qqe_prefix!-lefts qqe_arg2l car qqe_atf!-qequal!-ext!-p!*;
      % term := car qqe_atf!-qequal!-ext!-p!*;
      list := qqe_atf!-qequal!-ext!-p!*;
      if list then
      <<
         for each x in list do
         <<
            mm := qqe_prefix!-lefts qqe_arg2l x;
            if (mm < m) and (minlength >= l + 
               qqe_prefix!-rights qqe_arg2l x)
            then <<
               m := mm;
               term := x;
            >>;
         >>;
      >>;
      return {m,term};
   end;

procedure qqe_atf!-qequal!-ext!-p!-min!-rights(minlength, minpref);
   % Queue quantifier elimination conjuncts qequal external partial 
   % minimum of right prefixes.
   begin scalar m,mm,term, list, r;
      r := qqe_prefix!-rights qqe_arg2l minpref;
      m := qqe_prefix!-rights qqe_arg2l minpref;
      term := minpref;
      % qqe_prefix!-rights qqe_arg2l car qqe_atf!-qequal!-ext!-p!*;
      % temp := car qqe_atf!-qequal!-ext!-p!*;
      list := qqe_atf!-qequal!-ext!-p!*;
      for each x in list do
      <<
         mm := qqe_prefix!-rights qqe_arg2l x;
         if (mm < m) and (minlength >= r + 
            qqe_prefix!-lefts qqe_arg2l x)
         then
         <<
            m := mm;
            term := x;
         >>;
      >>;
      return {m,term};
   end;



procedure qqe_new!-ids!-x(num, u);
   % Queue quantifier elimination make new identifiers. [num] is
   % an integer. Function returns a list of [num] man identifiers,
   % which are not yet in formula [qqe_sf!*]. The list
   % has the form ( x1 x2 x3 x4...).
   begin scalar j,jj, x, idlist;
      j := 1;
      jj := 1;
      while j <= num do
      <<
         if (null smemq(x := qqe_make!-id!-x(jj), u)) then
         <<
            j := j+1;
            jj := jj+1;
            if idlist then idlist := append(idlist, {x})
            else idlist := {x};
         >>
         else 
         <<
            jj := jj+1;
         >>;
      >>;
      return idlist;
   end;

procedure qqe_make!-id!-x(num);
   % Queue quantifier elimination make new identifier x[num].
   % [num] is an integer. Function returns the identifier
   % x[num].
   intern compress append({cadr a},cdddr a) 
      where a=explode{'x,num};

procedure qqe_list!-take!-n(list,length,n);
   % QQE list take list of length of list minus n elements of list
   % beginning from left. [list] is a list. [length] is the length of
   % the list. [n] is a natural number.
   begin
      for i:=1:length-n do
         list := cdr list;
      return list;
   end;

% QQE substitution procedures -------------------------------------- %

procedure qqe_subst(num,new_ids);
   % QQE substitute. [num] is a natural number. [new_ids] is a list of
   % identifiers. Return [qqe_sf!*] substituted by |x1 ... xn|, where
   % list is (x1 ... xn). Returns equivalent formula to the
   % substitution result, for which variable xi only appear in basic
   % type atomic formulas.
   begin scalar f;
      if num eq 0 then return subst('qepsilon,qqe_var!*, qqe_sf!*)
      else <<
         if qqe_atf!-qequal!-ext!-p!* then 
            f := qqe_subst!-qequal!-ext!-p(num,new_ids) . f;
         if qqe_atf!-equal!-ext!* then 
            f := qqe_subst!-batf(num,new_ids,qqe_atf!-equal!-ext!*) . f;
         if qqe_atf!-equal!-int!* then 
            f := qqe_subst!-batf(num,new_ids,qqe_atf!-equal!-int!*) . f;
         if qqe_atf!-qequal!-int!* then  
            f := qqe_subst!-qequal!-int(num,new_ids) . f;
         if qqe_atf!-qneq!-ext!* then  
            f := qqe_subst!-qneq!-ext(num,new_ids) . f;
         if qqe_atf!-qneq!-ext!-qepsilon!* then
            f := 'true . f;
         if qqe_atf!-neq!* then 
            f := qqe_subst!-batf(num,new_ids,qqe_atf!-neq!*) . f;
         if qqe_atf!-qneq!-int!* then  % !!! <- here we get or! 
            f := qqe_subst!-qneq!-int(num, new_ids) . f;
         if qqe_atf!-misc!-basic!* then 
            f := qqe_subst!-batf(num,new_ids,qqe_atf!-misc!-basic!*) . f;
      >>;
      
      if cdr qqe_qvarf!* then f := 'and . f else f := car f;
      
      return f;
   end;

procedure qqe_subst!-batf(num,new_ids,atlist);
  % QQE substitution basic type atomic formula. [num] is a natural
  % number. [new_ids] is a list of identifiers. [atlist] is a list of
  % atomic formulas. Substitute [qqe_var!*] with |x_1
  % ... x_num|. Transform the result in a equivalent form, where x_i
  % only occur in basic type atomic formulas.
  begin scalar list;
     for each f in atlist do <<
        f := rl_prepat f;
        list := rl_simpat {qqe_op f, 
           qqe_subst!-bterm(num,new_ids, qqe_arg2l f),
        qqe_subst!-bterm(num,new_ids, qqe_arg2r f)} . list;
     >>;
     return if cdr atlist then 'and . list else car list;
  end;

procedure qqe_subst!-bterm(num,new_ids,term);
   % QQE substitution basic type term. [num] is a natural
   % number. [new_ids] is a list of identifiers. Substitute
   % [qqe_var!*] with |x_1 ... x_num|.
   begin scalar term3;
      if null term or atom term then return term
      else if qqe_op term memq '(lhead rhead) and 
         qqe_qprefix!-var term eq qqe_var!* then <<
         return qqe_subst!-simplterm(term,num,new_ids);
      >>
      else for each term2 in cdr term do 
         term3 := append(term3,{qqe_subst!-bterm(num,new_ids,term2)});
      return car term . term3;
   end;
                     
procedure qqe_subst!-qequal!-ext!-p(num,new_ids);
   % QQE substitution basic type atomic formula for atomic formulas in
   % [qqe_atf!-qequal!-ext!-p]. [num] is a natural number. [new_ids]
   % is a list of identifiers. Substitute [qqe_var!*] with |x_1
   % ... x_num|. Transform the result in a equivalent form, where x_i
   % only occur in basic type atomic formulas.
   begin scalar list, g;
      for each f in qqe_atf!-qequal!-ext!-p!* do <<
         list := qqe_subst!-simplterm(qqe_arg2l f,num,new_ids);
         if null list then g := {'qequal,qqe_arg2r f,'qepsilon} . g
         else g := qqe_makef!-termlength!-l(qqe_arg2r f, num) . 
            qqe_makef!-termlength!-g(qqe_arg2r f, num-1) . 
               qqe_makef!-qequal2equal(qqe_arg2r f, list) . g;
      >>;
      % return g;
      %return if cdr g then g else car g;
      return if cdr qqe_atf!-qequal!-ext!-p!* then 'and . g else car g;
   end;

procedure qqe_subst!-qneq!-ext(num,new_ids);
   % QQE substitution basic type atomic formula for atomic formulas in
   % [qqe_atf!-qneq!-ext!]. [num] is a natural number. [new_ids]
   % is a list of identifiers. Substitute [qqe_var!*] with |x_1
   % ... x_num|. Transform the result in a equivalent form, where x_i
   % only occur in basic type atomic formulas.
    begin scalar list, g;
       for each f in qqe_atf!-qneq!-ext!* do <<
          list := qqe_subst!-simplterm(qqe_arg2l f,num,new_ids);
          
          if null list then g := {'qneq,qqe_arg2r f,'qepsilon} . g
          else g := {'or, qqe_makef!-termlength!-g(qqe_arg2r f, num+1),
             qqe_makef!-termlength!-l(qqe_arg2r f, num-1), 
             {'and, qqe_makef!-qneq2equal(qqe_arg2r f, list), 
                qqe_makef!-termlength!-l(qqe_arg2r f, num),
                qqe_makef!-termlength!-g(qqe_arg2r f, num-1)}} . g;
       >>;
       return if cdr qqe_atf!-qneq!-ext!* then 'and . g else car g;
       % return if cdr g then g else car g;
    end;

procedure qqe_makef!-qneq2equal(term, list);
   % QQE make formula: transform atomic formula with qneq into atomic
   % formula with neq. [term] is a queue type term. [list] is a list
   % of variables. term <<>> |x1 ... xn| is transformed in
   % bigvee_{i=1}^n xi <> lhead ltail^{i-1} term.
   begin scalar f, tail, list2;
      list2 := list;
      tail := term;
      while list2 do <<
         f := rl_simpat({'neq,'lhead . {tail}, car list2}) . f;
         tail := 'ltail . {tail};
         list2 := cdr list2;
      >>;
      if null cdr list then return car f
      else return 'or . f;
   end;

procedure qqe_subst!-qneq!-int(num, new_ids);
   % QQE substitution basic type atomic formula for atomic formulas in
   % [qqe_atf!-qneq!-int!]. [num] is a natural number. [new_ids]
   % is a list of identifiers. Substitute [qqe_var!*] with |x_1
   % ... x_num|. Transform the result in a equivalent form, where x_i
   % only occur in basic type atomic formulas.
   begin scalar list1, list2, g;
      for each f in qqe_atf!-qneq!-int!* do <<
         list1 := qqe_subst!-simplterm(qqe_arg2l f,num, new_ids);
         list2 := qqe_subst!-simplterm(qqe_arg2r f,num, new_ids);
         if length(list1) neq length(list2) then g := 'true . g
         else if null list1 then g := 'false . g
         else g := qqe_makef!-list2qneq(list1,list2) .  g;
      >>;
      return if cdr qqe_atf!-qneq!-int!* then 'and . g else car g;
   end;

procedure qqe_subst!-qequal!-int(num,new_ids);
   % QQE substitution basic type atomic formula for atomic formulas in
   % [qqe_atf!-qequal!-int!]. [num] is a natural number. [new_ids]
   % is a list of identifiers. Substitute [qqe_var!*] with |x_1
   % ... x_num|. Transform the result in a equivalent form, where x_i
   % only occur in basic type atomic formulas.
   begin scalar list1, list2, g, list, f;
      list := qqe_atf!-qequal!-int!*;
      while list and g neq 'false do <<
         % for each f in qqe_atf!-qequal!-int!* do <<
         f := car list;
         list1 := qqe_subst!-simplterm(qqe_arg2l f,num,new_ids);
         list2 := qqe_subst!-simplterm(qqe_arg2r f,num,new_ids);
         if null list1 and null list2 then g := 'true . g
         else if null list1 or null list2 then g := 'false %%shortcut!!!
         else if qqe_prefix!-length(qqe_arg2l f) neq 
            qqe_prefix!-length(qqe_arg2r f) then g := 'false
         else g := qqe_makef!-list2equal(list1,list2) . g;
         list := cdr list;
      >>;

      return if cdr qqe_atf!-qequal!-int!* then 'and . g else car g;
   end;

procedure qqe_makef!-list2qneq(list1,list2);
   % QQE make formula: transform atomic formula with qneq into
   % disjunction of atomic formulas with neq. [list1], [list2] are
   % lists of variables. |y1 ... yn| <<>> |x1 ... xn| is transformed
   % in bigvee_{i=1}^n xi <> yi.
   begin scalar f, list;
      list := list1;
      while list1 do <<
         f := rl_simpat({'neq, car list1, car list2}) . f;
         list1 := cdr list1;
         list2 := cdr list2;
      >>;
      if null cdr list then return car f
      else return 'or . f;
   end;

procedure qqe_makef!-list2equal(list1, list2);
   % QQE make formula: transform atomic formula with qneq into atomic
   % formula with equal. [list1], [list2] are lists
   % of variables. |y1 ... yn| <<>> |x1 ... xn| is transformed in
   % bigvee_{i=1}^n xi <> yi.
   begin scalar f, list;
      list := list1;
      while list1 do <<
         f := rl_simpat({'equal,car list1, car list2}) . f;
         list1 := cdr list1;
         list2 := cdr list2;
      >>;

      if null cdr list then return car f
      else return 'and . f;
   end;

procedure qqe_makef!-qequal2equal(term,list);
   % QQE make formula: transform atomic formula with qequal into
   % atomic formula with equal. [term] is a queue type term. [list1],
   % [list2] are lists of variables. |y1 .. y2| <<>> |x1 ... xn| is
   % transformed in bigvee_{i=1}^n xi = yi.
   begin scalar f, tail, list2;
      tail := term;
      list2 := list;
      while list2 do <<
         f := rl_simpat({'equal,'lhead . {tail},car list2}) . f;
         tail := 'ltail . {tail};
         list2 := cdr list2;
      >>;

      if null cdr list then return car f
      else return 'and . f;
   end;

procedure qqe_makef!-termlength!-l(term,num);
   % length(term) ltail^num(term) == qepsilon
   {'qequal, qqe_iterate!-ltail(num,term), 'qepsilon};

procedure qqe_makef!-termlength!-g(term,num);
   % length(term) > num ---> ltail^num(term) <<>> qepsilon
   {'qneq, qqe_iterate!-ltail(num,term), 'qepsilon};

procedure qqe_subst!-simplterm(old_term,num,new_ids);
   % QQE substitute and simplify term. [old_term] is a term, [num] is
   % a natural number, [new_ids] is a list of identifiers.  For a term
   % M p we return the result of the evaluation of M |x1 .. xn|.  
   % For example with new_ids=(x1 .. x5) : lhead ltail rtail p --> x2
   begin scalar l,r;
      if atom old_term then return new_ids;
      l := qqe_prefix!-lefts old_term;
      r := qqe_prefix!-rights old_term;
      
      % because we only look at harmless formulas: this case shouldn't
      % be considered. !!! (still not?!)
      % But as we don't have a perfect test for harmless formulas
      if l + r > num then if car old_term memq '(lhead rhead)then
         return {'eta}
      else return nil;

      if car old_term eq 'lhead then 
         return qqe_subst!-simplterm!-lhead(l-1,new_ids);
      if car old_term eq 'rhead then
         return qqe_subst!-simplterm!-rhead(r-1,new_ids);

      % num > l + r
      if l > 0 then
         for i:=1:l do
            new_ids := cdr new_ids;
      
      if r > 0 then <<
         new_ids := reverse new_ids;
         for i:=1:r do
            new_ids := cdr new_ids;
         new_ids := reverse new_ids;
      >>;

      return new_ids;
   end;

procedure qqe_subst!-simplterm!-lhead(lefts, new_ids);
   % QQE substitute and simplify term with leading operation being
   % lhead. [lefts] is a natural number, [new_ids]
   % is a list of identifiers.  For a term M p we return the result of
   % the evaluation of M |x1 .. xn|.  For example with new_ids=(x1
   % .. x5) : lhead ltail rtail p --> x2
   begin 
      if lefts > 0 then
         for i:=1:lefts do
            new_ids := cdr new_ids;
      return car new_ids;
   end;

procedure qqe_subst!-simplterm!-rhead(rights, new_ids);
   % QQE substitute and simplify term with leading operation being
   % rhead. [rights] is a natural number, [new_ids]
   % is a list of identifiers.  For a term M p we return the result of
   % the evaluation of M |x1 .. xn|.  For example with new_ids=(x1
   % .. x5) : rhead ltail rtail p --> x4
   begin 
      new_ids := reverse new_ids;
      if rights > 0 then
         for i:=1:rights do
            new_ids := cdr new_ids;
      return car new_ids;
   end;



procedure qqe_iterate!-quantifier!-ex(l,list, arg);
   % Queue quantifier elimination iterate quantifier existence.
   % [l] is an integer, [list] is a list of identifiers,
   % [arg] is a lisp prefix.
   % Returns ex l(1) (ex l(2) .... (ex(l(|l|)) arg))).
   begin scalar q,x;
      q := arg;
      x := list;

      for j:=1:l do
      <<
         q := {'ex, car x, q};
         x := cdr x;
      >>;
      return q;
   end;

procedure qqe_iterate!-quantifier(qlist,f);
   % QQE iterate quantifier. [qlist] is a list of pairs (q, v), where
   % q is a quantifier (ex, all) and v is a variable. [f] is a
   % formula. Returns formula with leading sequence of quantifier with
   % scopus being f. For example: qlist: ((all q) (ex p)), f: q = p
   % ---> (all q (ex p (equal q p))).
   begin
      for each x in qlist do
         f := {car x, cadr x, f};
      return f;
   end;


procedure qqe_simpl!-dnf(u);
   % QQE simplify disjunctive normalform. [u] is a dnf.  Simplify [u]
   % with help of length graph. The function is mainly needed at the
   % end of the QE procedure. 
   begin scalar list, clauses, length_list;
      
      if car u eq 'or then <<
         list := cdr u;
         
         for each clause in list do <<
            length_list := qqe_clause!-update!-lengths(clause,nil);
            if length_list eq 'false then <<
               clauses := append(clauses,{'false});
            >>
            else << 
               clauses := append(clauses,{qqe_simpl!-clause clause});
               qqe_length!-graph!-delete length_list;
            >>;
         >>;
         list := append({'or}, clauses);
      >>
      else list := qqe_simpl!-clause u;
      
      return rl_simpl(list,nil,-1);
   end;
         

procedure qqe_simpl!-clause(u);
   % QQE simplify clause. [u] is a conjunction of atomic formulas.
   % Simplify [u] with help of length graph. The function is mainly
   % needed in the QE procedure. The length graph is considered to be
   % correct.
   begin scalar list, flag, at, atlist_rest,varlist, x;
      flag := t;
      list := if qqe_op u eq 'and then cdr u else {u};
      while flag and list do <<
         at := car list;
        
         if pairp at and qqe_op at memq '(qequal qneq) then <<
            at := {qqe_op at, 
               qqe_simpl!-clause!-term qqe_simplterm qqe_arg2l at,
               qqe_simpl!-clause!-term qqe_simplterm qqe_arg2r at};
            if qqe_qprefix!-var qqe_arg2l at eq 'qepsilon or
               qqe_qprefix!-var qqe_arg2r at eq 'qepsilon then <<
                  if qqe_op at eq 'qequal then
                     x := qqe_simpl!-clause!-qequal(at)
                  else 
                     x := qqe_simpl!-clause!-qneq(at);
                  if null x then flag := nil
                  else if x neq 'true then <<
                     atlist_rest := at  . atlist_rest; 
                     if x neq t then
                        varlist := x . varlist;
                  >>;
               >>
            else atlist_rest := at . atlist_rest;
         >>
         else atlist_rest := at . atlist_rest;
         list := cdr list;
      >>;
      
      qqe_simpl!-clause!-remprop varlist;

      if flag then <<
         if null atlist_rest then return 'true
         else if null cdr atlist_rest then return car atlist_rest
         else return 'and . atlist_rest;
      >>
      else return 'false;
   end;

procedure qqe_simpl!-clause!-remprop(varlist);
   % QQE simplify clause remove properties from list of variables 
   % [varlist].
   for each x in varlist do <<
      remprop(x,'qqeqemisceq);
      remprop(x,'qqeqemiscneq);
   >>;

procedure qqe_simpl!-clause!-qequal(at);
   % QQE simplify clause qequal. [at] is an atomic formula.  this is a
   % subroutine of [qqe_simpl!-clause] for atomic formulas with
   % [qequal].
   begin scalar var;
      if (qqe_arg2l at eq 'qepsilon) and 
         (qqe_arg2r at eq 'qepsilon) 
      then  return 'true
      
      else if (qqe_arg2l at eq 'qepsilon) and
         (qqe_qprefix!-var qqe_arg2r at eq 'qepsilon) and
         (qqe_number!-of!-adds!-in!-qterm qqe_arg2r at <= 
            qqe_number!-of!-tails!-in!-qterm qqe_arg2r at) 
      then return 'true

      else if (qqe_arg2r at eq 'qepsilon) and
               (qqe_qprefix!-var qqe_arg2l at eq 'qepsilon) and 
               (qqe_number!-of!-adds!-in!-qterm qqe_arg2l at <=
                  qqe_number!-of!-tails!-in!-qterm qqe_arg2l at) 
      then return 'true
      
      else if (qqe_arg2l at eq 'qepsilon) and 
         (qqe_number!-of!-adds!-in!-qterm qqe_arg2r at = 0) then <<
         var := qqe_qprefix!-var qqe_arg2r at;
         if null get(var,'qqeqemisceq) and 
            qqe_lesseq!-length(qqe_prefix!-length qqe_arg2r at,
               qqe_maxlength!-var var) then <<
                  put(var, 'qqeqemisceq, t);
                  return var;
               >>
         else return 'true;
      >>
        
      else if (qqe_arg2r at eq 'qepsilon) and
         (qqe_number!-of!-adds!-in!-qterm qqe_arg2l at = 0) then <<
            var := qqe_qprefix!-var qqe_arg2l at;
            if null get(var,'qqeqemisceq) and 
               qqe_lesseq!-length(qqe_prefix!-length qqe_arg2l at,
                  qqe_maxlength!-var var) then <<
                     put(var,'qqeqemisceq,t);
                     return var;
                  >>
            else return 'true;
         >>
      else return t;
   end;

procedure qqe_simpl!-clause!-qneq(at);
    % QQE simplify clause qneq. [at] is an atomic formula.  this is a
   % subroutine of [qqe_simpl!-clause] for atomic formulas with
   % [qneq].
   begin scalar var;
      if (qqe_arg2l at eq 'qepsilon) and 
         (qqe_arg2r at eq 'qepsilon) 
      then return nil
      
      else if (qqe_arg2l at eq 'qepsilon) and
         (qqe_qprefix!-var qqe_arg2r at eq 'qepsilon) and
         (qqe_number!-of!-adds!-in!-qterm qqe_arg2r at <= 
            qqe_number!-of!-tails!-in!-qterm qqe_arg2r at) 
      then return nil

      else if (qqe_arg2r at eq 'qepsilon) and
               (qqe_qprefix!-var qqe_arg2l at eq 'qepsilon) and 
               (qqe_number!-of!-adds!-in!-qterm qqe_arg2l at <=
                  qqe_number!-of!-tails!-in!-qterm qqe_arg2l at) 
      then return nil
      
      else if (qqe_arg2l at eq 'qepsilon) and 
      (qqe_number!-of!-adds!-in!-qterm qqe_arg2r at = 0) then <<
         var := qqe_qprefix!-var qqe_arg2r at;
         if null get(var,'qqeqemiscneq) and 
            qqe_greatereq!-length(qqe_prefix!-length qqe_arg2r at+1,
               qqe_minlength!-var var) then <<
                  put(var, 'qqeqemiscneq, t);
                  return var;
               >>
         else return 'true;
      >>
        
      else if (qqe_arg2r at eq 'qepsilon) and 
      (qqe_number!-of!-adds!-in!-qterm qqe_arg2l at = 0) then <<
         var := qqe_qprefix!-var qqe_arg2l at;
         if null get(var,'qqeqemiscneq) and 
            qqe_greatereq!-length(qqe_prefix!-length qqe_arg2l at+1,
               qqe_minlength!-var var) then <<
                  put(var,'qqeqemiscneq,t);
                  return var;
               >>
         else return 'true;
      >>
      else return t;
   end;

procedure qqe_simpl!-clause!-term(term);
   % QQE simplify clause: simplify a term.  With the help of the
   % information from the length graph a term [term] of type queue is
   % simplified.
   begin scalar var, maxlength;
      if atom term then return term;
      var := qqe_qprefix!-var term;
      maxlength := get(var,'maxlength);
      if null maxlength then return term;
      if (qqe_number!-of!-tails!-in!-qterm(term) - 
         qqe_number!-of!-adds!-in!-qterm(term)) > maxlength then
            return 'qepsilon
      else return term;
   end;

% -------------------- critical point graph ---------------------------------%%%%% Rest of module : : UNDER CONSTRUCTION %%%%%%

%% procedure qqe_make!-cpg(list);
%%    % outer loop  cpg -- critical point graph
%%    begin scalar graph;
%%       list := qqe_quicksort!-dbl!-crit list;
%%       graph := qqe_cpg!-make!-root();
%%       for each x in list do 
%%          qqe_cpg!-insert(qqe_cpg!-make!-node x, graph);
%%       return graph;
%%    end;
%% 
%% procedure qqe_cpg!-make!-root();
%%    qqe_cpg!-make!-supernode();
%% 
%% procedure qqe_cpg!-make!-node(var);
%%    % incl-pointer, excl-pointer, var
%%    {nil,nil,var};
%% 
%% procedure qqe_cpg!-make!-supernode();
%%    % last-pointer, listofnodes
%%    {nil,nil, {nil}};
%% 
%% procedure qqe_cpg!-supernode!-last(snode);
%%    % TODO
%%    cadr snode;
%% 
%% procedure qqe_cpg!-supernode!-first(snode);
%%    car snode;
%% 
%% procedure qqe_cpg!-incl(node);
%%    car node;
%% 
%% procedure qqe_cpg!-excl(node);
%%    cadr node;
%% 
%% procedure qqe_cpg!-make!-incl(node);
%%    car node := qqe_cpg!-make!-supernode();
%% 
%% procedure qqe_cpg!-insert(node,graph);
%%    qqe_cpg!-insert!-incl(node,graph, 'infty);
%% 
%% procedure qqe_cpg!-make!-excl(node_in, node);
%%    cadr node := node_in;
%% 
%% procedure qqe_cpg!-empty!-graph(graph);
%%    if car graph then nil
%%    else t;
%% 
%% procedure qqe_cpg!-insert!-supernode(node_in,snode);
%%    <<
%%       if car snode then caddr snode := caddr snode . {car snode};
%%       cadr snode := node_in;
%%       if null qqe_cpg!-supernode!-first snode then 
%%          car snode := cadr snode;
%%       %%       cadr snode := append(cadr snode,{node_in});
%%       %%       car snode := node_in;
%%       prin2t{"::insert!-supernode: snode=",snode};
%%    >>;
%% 
%% procedure qqe_cpg!-minlength!-node(node);
%%    qqe_minlength!-var qqe_cpg!-var node;
%% 
%% procedure qqe_cpg!-maxlength!-node(node);
%%    qqe_maxlength!-var qqe_cpg!-var node;
%% 
%% procedure qqe_cpg!-var(node);
%%    caddr node;
%% 
%% procedure qqe_cpg!-insert!-incl(node, graph, max_border);
%%    % TODO 
%%    begin scalar minlength, maxlength, maxlength_last, last_node;
%%       prin2t "_";
%%       prin2t {":::qqe_cpg!-insert!-incl with var_node=",qqe_cpg!-var node,
%%          " and graph= ",if qqe_cpg!-supernode!-last graph then qqe_cpg!-var 
%%             qqe_cpg!-supernode!-last graph else nil,
%%          "and max_border=", max_border};
%%       minlength := qqe_cpg!-minlength!-node node;  
%%       maxlength := qqe_cpg!-maxlength!-node node;  
%%       if qqe_cpg!-empty!-graph graph then <<
%%          prin2t " branch :: emty_graph";
%%          qqe_cpg!-insert!-supernode(node,graph)
%%       >>
%% %%       else if minlength eq 0 then <<
%% %%          prin2t "branch :: minlength=0";
%% %%          qqe_cpg!-make!-incl qqe_cpg!-supernode!-first graph;
%% %%          qqe_cpg!-insert!-incl(node,qqe_cpg!-incl 
%% %%             qqe_cpg!-supernode!-first graph, max_border)
%% %%       >>
%%       else <<
%%          prin2t "branch :: elsewise";
%%          last_node := qqe_cpg!-supernode!-last graph;
%%          maxlength_last := qqe_cpg!-maxlength!-node last_node;
%%          if qqe_less!-length(maxlength_last,minlength) then <<
%%             prin2t "branch :: elsewise with no intersection in incs";
%%             qqe_cpg!-supernode!-insert(graph,node);
%%          >>
%%          else <<
%%             prin2t "branch :: elsewise intersection exists";
%%             if null qqe_cpg!-incl last_node then 
%%                qqe_cpg!-make!-incl last_node;
%%             qqe_cpg!-insert!-incl(node,qqe_cpg!-incl last_node, 
%%                qqe_min!-length(maxlength_last, max_border));
%%             if qqe_less!-length(maxlength_last, maxlength) and 
%%                qqe_less!-length(maxlength_last,max_border) then <<
%%                prin2t {"branch :: elsewise also excl part with last=", 
%%                   qqe_cpg!-var last_node};
%%                if null qqe_cpg!-excl last_node then 
%%                   qqe_cpg!-make!-excl(qqe_cpg!-make!-node qqe_cpg!-var node, 
%%                      last_node)
%%                else qqe_cpg!-insert!-excl(qqe_cpg!-make!-node 
%%                   qqe_cpg!-var node, qqe_cpg!-excl last_node, 
%%                   max_border);
%%             >>;
%% 
%%          >>;
%%       >>;
%%             
%% %%          if qqe_less_length(qqe_maxlength!-var qqe_cpg!-var 
%% %%             qqe_cpg!-most!-exclusive last_node,minlength) then
%%    end;
%% 
%% procedure qqe_cpg!-insert!-excl(node_in,node,max_border);
%%    % TODO
%%    begin scalar minlength_in, maxlength_in, minlength, maxlength;
%%       prin2t {"entering qqe_cpg!-insert!-excl with node_in =", 
%%          qqe_cpg!-var node_in, "and 
%%          node=", qqe_cpg!-var node};
%%       pause;
%%       minlength_in := qqe_cpg!-minlength!-node node_in;
%%       minlength := qqe_cpg!-minlength!-node node;
%%       maxlength_in := qqe_cpg!-maxlength!-node node_in;
%%       maxlength := qqe_cpg!-maxlength!-node node;
%%       
%%       % if qqe_less!-length(maxlength_in, maxlength) then <<
%%       if null qqe_cpg!-incl node then qqe_cpg!-make!-incl node;
%%       qqe_cpg!-insert!-incl(node_in,qqe_cpg!-incl node, max_border);
%%       % >>;
%%       if qqe_less!-length(maxlength, maxlength_in) then  <<
%%          if null qqe_cpg!-excl node then qqe_cpg!-make!-excl node;
%%          qqe_cpg!-insert!-excl(node_in, qqe_cpg!-excl node,max_border);
%%       >>;
%%    end;
%% 
%% procedure qqe_cpg!-min!-solution(start, lcm);
%%    % TODO
%%    ;
%% 
%% procedure qqe_cpg!-check!-chain(start,lcm,length_of_chain, graph);
%%    % TODO first
%%    begin scalar next, solution;
%%       if length_of_chain eq 1 then 
%%          return qqe_cpg!-check!-chain1(start,lcm,graph);
%%       while right neighbor on supernode and not solution do <<
%%          proiers mit dem;
%%          if not solution do <<
%%             while excl-child and not solution do this <<
%%                % next := qqe_cpg!-get!-next graph;
%%                % while next and not solution do
%%                solution := qqe_cpg!-check!-chain(start,lcm, 
%%             length_of_chain-1,next);
%%             >>;
%%          >>;
%%       >>;
%%       return solution;
%%    end;
%% 
%% procedure qqe_cpg!-supernode!-get!-next(snode,node);
%%    % TODO
%%    begin scalar temp;
%%       temp := qqe_cpg!-superode!-list snode;
%%       while temp and car temp neq node do 
%%          temp := cdr temp;
%%       if temp and car temp eq node then return if cdr temp then car temp 
%%          else nil
%%       else return nil;
%%    end;
%% 
%% procedure qqe_cpg!-check!-chain1(start,lcm,graph);
%%    % TODO
%%    ;
%% 
%% procedure qqe_cpg!-get!-next(list,node);
%%    % TODO
%%    begin
%%       if qqe_cpg!-incl node then 
%%          return qqe_cpg!-incl qqe_cpg!-supernode!-first node
%%       else if qqe_cpg!-supernode!-get!-next(qqe_cpg!-list!-get!-prev node, % dafuer muesste ein incl Knoten als Liste uebergeben werden
%%          then return {'e,qqe_cpg!-minlength!-node car cdr node}
%%       else qqe_cpg!-get!-next!-reiterate(list,node);
%%    end;
%% 
%% procedure qqe_cpg!-get!-next!-reiterate(list,node);
%%    begin scalar next;
%%       list := reverse list;
%%       % where do i get the father from - it must be the predecessor in the list
%%       % not always !
%%       while cdr list and null next do << 
%%          % null next sollte car next memq (nil v)
%%          % next := qqe_cpg!-get!-next!-reiterate!-check!-node(list,car list);
%%          list := cdr list;
%%          if qqe_cpg!-excl car list then 
%%             next := qqe_cpg!-get!-next!-down(list);
%%       >>;
%%       if null next then qqe_cpg!-get!-next!-max car list;
%%    end;
%% 
%% procedure qqe_cpg!-get!-down(list);
%%    % TODO
%%    begin scalar max, temp;
%%       max := qqe_get!-maxlength car list;
%%       temp := qqe_cpg!-incl car list;
%%       list := cdr list;
%%       
%%       list := for each x in list collect 
%%          if qqe_get!-maxlength car list > max  then caar list;
%% 
%%       
%%       while qqe_cpg!-incl temp and null next do
%%          if qqe_cpg!-var car temp neq car list then 
%%             next := {'e, qqe_get!-min car list}
%%          else <<
%%             temp := qqe_cpg!-incl temp;
%%             list := cdr list;
%%          >>;
%%       
%%       return next;
%% 
%%    end;
%% 
%% procedure qqe_cpg!-get!-next!-reiterate!-check!-node(list, node);
%%    % i need the whole list down!
%%    begin 
%%       while null qqe_cpg!-excl car list do 
%%          list := cdr list;
%%       %either last or excl exists
%%       if qqe_cpg!-excl car then qqe_cpg!-get!-next!-down(list, car list)
%%       else return qqe_cpg!-get!-next!-max(list);
%%    end;
%% 
%% %% procedure qqe_cpg!-get!-alternative();
%% %%    % TODO
%% %%    begin
%% %%       while right neighbor on supernode try that
%% %%          while excl-child do this;
%% %%       
%% %%    end;
%% 
%% procedure qqe_cpg!-get!-solution!-for!-intervall(a,o,start,lcm, steps);
%%    % TODO
%%    begin temp, counter, lengths, s;
%%       if start > o then return nil;
%%       
%%       temp := start;
%%       while temp < a do
%%          temp := temp + lcm;
%% 
%%       if temp > o then return nil
%%       counter := 1; 
%%       lengths := {temp};
%% 
%%       while temp < o and counter < steps do <<
%%          temp := temp + lcm;
%%          if temp < o then << 
%%             counter := counter + 1;
%%             lengths := lengths . {temp};
%%          >>;
%%       >>;
%%       if counter eq steps then <<
%%          s := 0;
%%          for each l in lenghts do s := l + s;
%%          return {s ,lengths};
%%       >>
%%       else return nil;
%%    end;

endmodule;  % [qqeqemisc]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqe.red0000644000175000017500000004770411526203062024044 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqe.red 641 2010-05-24 19:00:30Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(qqe_rcsid!* qqe_copyright!*);
   qqe_rcsid!* := "$Id: qqe.red 641 2010-05-24 19:00:30Z thomas-sturm $";
   qqe_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

module qqe;
% Quantorelimination for queues. Main module. Algorithms on formulas
% in the two-sorted logic consisting of basic and queue sort.
% The language contains additional binary functions ['ladd], ['radd],
% as well as unary functions ['lhead], ['rhead], ['ltail], ['rtail].
% Additional binary logic operators are ['qequal] and ['qneq].

create!-package('(qqe qqetrans qqemisc qqesism qqeqe qqesiat qqeqemisc),nil);

load!-package 'rltools;
load!-package 'redlog;
% load!-package 'qqe_ofsf;

exports qqe_chsimpat;

imports cl,rltools;

fluid '(qqe_marked!-ids!-rollback!* qqe_qadd!-location!*
   qqe_elimb!* qqe_debug!* !*rlsism);

flag('(qqe),'rl_package);

put('qqe,'rl_enter,'qqe_enter);

put ('qqe,'simpfnname, 'rl_simpfn);

%% put('qqe,'rl_prepat,'qqe_prepat);
%% put('qqe,'rl_resimpat,'qqe_resimpat);
put('qqe,'rl_lengthat,'qqe_lengthat);

put('qqe,'rl_prepterm,'qqe_prepterm);
put('qqe,'rl_simpterm,'qqe_simpterm);

algebraic infix qequal;
put('qequal,'rl_prepfn,'qqe_prepat);
put('qequal,'rl_simpfn,'qqe_chsimpat);
put('qequal,'number!-of!-args,2);
put('qequal,'rtypefn,'quotelog);
put('qequal,'fancy!-prifn,'qqe_fancy!-priqequal);
newtok '((!= !=) qequal);
flag('(qequal),'spaced);

algebraic infix qneq;
put('qneq,'rl_prepfn,'qqe_prepat);
put('qneq,'rl_simpfn,'qqe_chsimpat);
put('qneq,'number!-of!-args,2);
put('qneq,'rtypefn,'quotelog);
put('qneq,'fancy!-prifn,'qqe_fancy!-priqneq);
newtok '((!< !< !> !>) qneq);
flag('(qneq),'spaced);

algebraic operator qepsilon;  % -> qqe_enter TODO
put('qepsilon,'number!-of!-args,0);
put('qepsilon,'idtype,'qt);

algebraic operator ladd;
put('ladd,'qqe_number!-of!-args,2);

algebraic operator radd;
put('ladd,'qqe_number!-of!-args,2);

algebraic operator lhead;
put('ladd,'qqe_number!-of!-args,1);

algebraic operator rhead;
put('ladd,'qqe_number!-of!-args,1);

algebraic operator rtail;
put('ladd,'qqe_number!-of!-args,1);

algebraic operator ltail;
put('ladd,'qqe_number!-of!-args,1);

flag('(qqe_chsimpat),'full);
!*rlsism := nil;
%else failure in simplifier cl_simpl  -> context switch

procedure qqe_enter(argl);
   begin scalar w,qqecid2;
      if null argl then
	 return nil . "base type context missing";

      qqe_elimb!* := nil;

      qqecid2 := intern compress nconc(explode 'qqe_,explode car argl);
      w := qqe_load!-basetype(qqecid2,cdr argl);
      if w then return nil . w;
      qqe_patch!-ctag(qqecid2,'qqe_params,'rl_params);
      qqe_patch!-ctag(qqecid2,'qqe_services,'rl_services);
      qqe_patch!-ctag(qqecid2,'qqe_cswitches,'rl_cswitches);

      % Begin CS
      put('qqe,'rl_resimpat,intern compress nconc(explode qqecid2,
         explode '!_resimpat));
      put('qqe,'rl_prepat,intern compress nconc(explode qqecid2,
         explode '!_prepat));
      % End CS

      % temporarily
      put('qneq,'infix,32);
      put('qequal,'infix,31);

      return t . argl  % means no error
   end;

procedure qqe_load!-basetype(qqecid2,argl);
   % Setup base type context. [cid2] is an identifier. This code
   % resembles rl_enter() in submodule rlcont.
   begin scalar w,enter;
      w := errorset({'load!-package,mkquote(qqecid2)},nil,!*backtrace)
	 where !*msg=nil;
      if errorp w then
	 return {"switching to base type wrapper",qqecid2,"failed"};
      if not flagp(qqecid2,'rl_package) then
	 return {qqecid2,"is not an rl package"};
      enter := get(qqecid2,'rl_enter);
      if null enter and argl then
	 lprim {"extra",ioto_cplu("argument",cdr argl),"ignored"};
      if enter then <<
      	 w := apply(enter,{argl});
      	 if not car w then
	    return cdr w
      	 else
	    argl := cdr w
      >>;
      return nil  % means no error
   end;

procedure qqe_patch!-ctag(qqecid2,qqeal,rlal);
   begin scalar w;
      w := get('qqe,qqeal);
      for each x in get(qqecid2,rlal) do
	 if not atsoc(car x,w) then
	    w := x . w;
      put('qqe,rlal,w)
   end;

procedure qqe_exit();
   ;

procedure qqe_lengthat(f);
   2;

procedure qqe_prepat(f);
   f;

procedure qqe_simpat(f);
   f;

procedure qqe_prepterm(f);
   f;

procedure qqe_chsimpat(f);
   begin
      cadr f := qqe_chsimpterm(qqe_arg2l f);
      caddr f := qqe_chsimpterm(qqe_arg2r f);
      qqe_arg!-check f;
      return f;
   end;

procedure qqe_chsimpterm(term);
   begin
      if atom term then term
      else if qqe_op term eq 'expt then term := qqe_chsimpterm1(term)
      else if qqe_op term memq '(ltail rtail) then
         cadr term := qqe_chsimpterm(cadr term)
      else if qqe_op term memq '(ladd radd) then
         caddr term := qqe_chsimpterm(caddr term)
      else if qqe_op term memq '(lhead rhead) then
         cadr term := qqe_chsimpterm(cadr term);
      return term;
   end;

procedure qqe_chsimpterm1(term);
   begin scalar op, arg;
      op := qqe_op qqe_arg2l term;
      arg := qqe_chsimpterm qqe_arg2l term;
      for j:=1:(qqe_arg2r term)-1 do <<
         arg := op . {arg};
      >>;
      return arg;
   end;

procedure qqe_op(atf);
   % QQE operator. [atf] is an atomic formula
   % $R(t_1,t_2)$. Returns $R$.
   car atf;

procedure qqe_lhs(atf);
   cadr atf;

procedure qqe_rhs(atf);
   caddr atf;

procedure qqe_arg2l(atf);
   % qqe binary operator left hand side argument. [atf] is
   % an atomic formula $R(t_1,t_2)$. Returns $t_1$.
   cadr atf;

procedure qqe_arg2r(atf);
   % qqe binary operator right hand side argument. [atf] is
   % an atomic formula $R(t_1,t_2)$. Returns $t_2$.
   caddr atf;

procedure qqe_argn(atf);
   % qqe binary operator right hand side argument. [atf] is
   % an atomic formula $R(t_1,t_2)$. Returns the list $(t_1,t_2)$.
   {cadr atf,caddr atf};

procedure qqe_mk2(op,lhs,rhs);
   % qqe constructor for binary operator. [op] is a relation
   % [lhs] and [rhs] are terms. Returns the atomic formula
   % $[op]([lhs],[rhs])$.
   {op,lhs,rhs};

procedure qqe_0mk2(op,lhs);
   % qqe zero constructor for binary operator. [op] is a
   % relation [lhs] is a term. Returns the atomic formula
   % $[op]([lhs],0)$.
   {op,lhs,nil};

procedure qqe_mkn(op,argl);
   % qqe constructor for binary operator. [op] is a relation
   % [argl] is a list $(t_1,t_2)$ of terms. Returns the atomic formula
   % $[op](t_1,t_2)$.
   {op,car argl,cadr argl};

procedure qqe_rqopp(op);
   % qqe relation queue type operator predicate. [op] is an
   % S-expression. Returns [nil] if op is not a relation with queue
   % type arguments.
   op memq '(qequal qneq);

% should be replaced later in favour of dynamic application to
% different basic theories, for example:
% if rlset = ofsf then qqe_rbopp -> ofsf_opp
procedure qqe_rbopp(op);
   % qqe relation basic type operator predicate. [op] is an
   % S-expression. Returns [nil] if op is not a relation with
   % basic type arguments.
   op memq '(equal neq lessp leq geq greaterp);

% obsolete
%% procedure qqe_luopp(op);
%%    % qqe logic unary operator
%%    op = 'neg;

procedure qqe_ropp(op);
   % qqe relation operator predicate. [op] is an
   % S-expression. Returns [nil] if op is not a relation.
   qqe_rqopp op or qqe_rbopp op;

procedure qqe_qopp(op);
   % qqe queue operator predicate. [op] is an
   % S-expression. Returns [nil] if op is not a function of queue type.
   op memq '(radd ladd lhead rhead ltail rtail);

procedure qqe_qopheadp(op);
   % qqe queue operator lhead or rhead predicate. [op] is an
   % S-expression. Returns [nil] if op is not lhead or rhead.
   op memq '(lhead rhead);

procedure qqe_arg!-check(u);
    % qqe argument check. [u] is an S-expression.
    % Checks for lhs and rhs of an atomic formula
    % recursivly if arguments are of correct type else error msg.
    <<
       if qqe_rqopp op then qqe_arg!-check!-lq!-rq u

       else if qqe_rbopp op then qqe_arg!-check!-lb!-rb u

       else if qqe_qopheadp op or qqe_qoptailp op
       then << if not qqe_arg!-check!-q cadr u then <<
          qqe_arg!-check!-marked!-ids!-rollback();
          typerr(u,"some arguments are not of queue type");
       >>;
       >>

       else if qqe_qopaddp op then qqe_arg!-check!-lb!-rq u

       else % plus, minus, etc.
       % <<
          for each x in cdr u do
             if not qqe_arg!-check!-b x then <<
                qqe_arg!-check!-marked!-ids!-rollback();
                typerr(u,"some arguments are not of basic type");
             >>;

%%           if not qqe_arg!-check!-b lhs then
%%           <<
%%              qqe_arg!-check!-marked!-ids!-rollback();
%%              typerr(u,"binary op with basic type args");
%%           >>;
%%           if rhs and not qqe_arg!-check!-b rhs then
%%           <<
%%              qqe_arg!-check!-marked!-ids!-rollback();
%%              typerr(u,"binary op with basic type args");
%%           >>;
%%
%%        >> where lhs=cadr u, rhs=if cddr u then caddr u else nil;

    >> where op=car u;


procedure qqe_arg!-check!-lb!-rq(u);
   % qqe argument check lhs basic rhs queue type.
   % [u] is an S-expression.
   % Checks for lhs and rhs of a function
   % recursivly if arguments are of correct type else error msg.
   begin scalar lhs, rhs;
      lhs := cadr u; rhs := caddr u;
      % rhs
      if not qqe_arg!-check!-q rhs then
      <<
         qqe_arg!-check!-marked!-ids!-rollback();
         typerr(u,"type conflict: arguments don't fit
            binary op with lhs basic type and rhs queue type");
      >>;

      % lhs
      if not qqe_arg!-check!-b lhs then
      <<
         qqe_arg!-check!-marked!-ids!-rollback();
         typerr(u,"type conflict: arguments don't fit
            binary op with lhs basic type and rhs queue type");
      >>;

   end;

procedure qqe_arg!-check!-lq!-rq(u);
   % qqe argument check lhs queue rhs queue type.
   % [u] is an S-expression.
   % Checks for lhs and rhs of a function
   % recursivly if arguments are of correct type else error msg.
   begin scalar lhs, rhs;
       lhs := cadr u; rhs := caddr u;
       % lhs
       if not qqe_arg!-check!-q lhs then
       <<
          qqe_arg!-check!-marked!-ids!-rollback();
          typerr(u,"type conflict: arguments don't fit
             binary op with queue type args");
       >>;

       % rhs
       if not qqe_arg!-check!-q rhs then
       <<
          qqe_arg!-check!-marked!-ids!-rollback();
          typerr(u,"type conflict: arguments don't fit
             binary op with queue type args");
       >>;
   end;

procedure qqe_arg!-check!-q(u);
   % qqe argument check queue type.
   % [u] is an S-expression.
   % Checks for argument of a function
   % recursivly if arguments are of correct type else error msg.
   begin
      if not qqe_id!-nyt!-branchq u then return nil
      else if atom u and not numberp u then
      <<
         if qqe_btidp u then return nil
         else if qqe_nytidp u then
         <<
            qqe_qtid u;
            qqe_add2rollbackids u;
            return t;
         >>
         else return t;
      >>
      else if not numberp u then
      <<
         qqe_arg!-check u;
         return t;
      >>
   end;

procedure qqe_arg!-check!-b(u);
   % qqe argument check basic type.
   % [u] is an S-expression.
   % Checks for argument of a function
   % recursivly if arguments are of correct type else error msg.
   begin
      if not qqe_id!-nyt!-branchb u then return nil
      else if atom u and not numberp u then
      <<
         if qqe_qtidp u then return nil
         else if qqe_nytidp u then
         <<
            qqe_btid u;
            qqe_add2rollbackids u;
            return t;
         >>
         else return t;
      >>
      else if not atom u then
      <<
         qqe_arg!-check u;
         return t;
      >>
      else return t; % numbers
   end;

procedure qqe_arg!-check!-lb!-rb(u);
   % qqe argument check lhs basic rhs basic type.
   % [u] is an S-expression.
   % Checks for lhs and rhs of a function
   % recursivly if arguments are of correct type else error msg.
   begin scalar lhs, rhs;
       lhs := cadr u; rhs := caddr u;
       % lhs
       if not qqe_arg!-check!-b lhs then
       <<
          qqe_arg!-check!-marked!-ids!-rollback();
          typerr(u,"type conflict: arguments don't fit
             binary op with basic type args");
       >>;

       % rhs
       if not qqe_arg!-check!-b rhs then
       <<
          qqe_arg!-check!-marked!-ids!-rollback();
          typerr(u,"type conflict: arguments don't fit
             binary op with basic type args");
       >>;
   end;

procedure qqe_qoptailp(op);
    % qqe queue operator rtail or ltail. [op] is a
    % S-expression. Returns [nil] if op is not rtail or ltail.
    if op memq '(rtail ltail) then t;

procedure qqe_qopaddp(op);
   % qqe queue operator ladd or radd. [op] is a
    % S-expression. Returns [nil] if op is not ladd or radd.
    if op memq '(ladd radd) then t;

procedure qqe_id!-nyt!-branchq(u);
    % qqe identifier not yet typed branch queue type. checks if the
    % argument u is of type queue or not yet typed.
    % Returns [nil] if argument is of type basic.
    if atom u then (qqe_qtidp u or qqe_nytidp u)
    else (qqe_qopaddp car u or qqe_qoptailp car u);

procedure qqe_id!-nyt!-branchb(u);
   % qqe identifier not yet typed branch basic type. checks if the
   % argument u is of type basic or not yet typed.
   % Returns [nil] if argument is of type queue.
   if atom u then (qqe_btidp u or qqe_nytidp u)
   else not(qqe_qopaddp car u or qqe_qoptailp car u);

procedure qqe_btid(u);
    % qqe basic type identifier. [u] is atom.
    % Set idtype on basic type. Error msg if idtype of u
    % is queue.
    % if qqe_qtidp u then typerr(u, "is queue type.")
    %    else
    put(u,'idtype,'bt);

procedure qqe_qtid(u);
    % qqe queue type identifier. [u] is atom.
    % Set idtype on queue type. Error msg if idtype of u
    % is basic.
    % if qqe_btidp u then typerr(u, "is basic type")
    %    else
    put(u,'idtype,'qt);

procedure qqe_niltid(u);
   % qqe nil type identifier. [u] is atom.
   % Set idtype on nil. Needed for rollback of typed identifiers
   % while processing incorrect formula.
   put(u,'idtype,nil);

procedure qqe_btidp(u);
    % qqe basic type identifier predicate. [u] is atom.
    % Returns [idtype] of u. Return [nil] if idtype is not yet set.
    get(u,'idtype) = 'bt;

procedure qqe_qtidp(u);
    % qqe queue type identifier predicate. [u] is atom.
    % Returns [idtype] of u. Return [nil] if idtype is not yet set.
    get(u,'idtype) = 'qt;

procedure qqe_nytidp(u);
   % qqe queue not yet set type identifier predicate. [u] is atom.
   % Returns [true] if idtype is not set, [nil] if idtype is set.
   get(u, 'idtype) = nil;

procedure qqe_fancy!-priqequal(l);
   % qqe standard form texmacs print a queue equality. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if rl_texmacsp() then
      qqe_fancy!-priqequal!-texmacs l;

procedure qqe_fancy!-priqequal!-texmacs(l);
   % qqe standard form texmacs print a queue equality. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if null !*nat then 'failed
   else <<
      maprin cadr l; %lhs
      % other options:
      % fancy!-prin2 "\mathop = \limits_{q}";
      % fancy!-prin2 "\circeq"; etc.
      fancy!-prin2 "\leftrightharpoons";
      % fancy!-prin2!-underscore();
      fancy!-prin2 " ";
      maprin caddr l; %rhs
   >>;

procedure qqe_fancy!-priqneq(l);
   % qqe standard form texmacs print a queue not equality. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if rl_texmacsp() then
      qqe_fancy!-priqneq!-texmacs l;

procedure qqe_fancy!-priqneq!-texmacs(l);
   % qqe standard form texmacs print a queue not equality. [l] is a
   % lisp prefix. Returns 'failed iff printing failed.
   if null !*nat then 'failed
   else <<
      maprin cadr l; %lhs
      fancy!-prin2 "\ll\gg";
      fancy!-prin2!-underscore();
      fancy!-prin2 " ";
      maprin caddr l; %rhs
   >>;

procedure qqe_arg!-check!-marked!-ids!-rollback();
   % qqe argument check marked identifiers rollback. While processing
   % a given formula with qqe_arg!-check identifiers get typed
   % according to which relation or functions they belong.
   % If processing an incorrect formula it can happen, that variables
   % get typed. This identifiers get stored in the list
   % qqe_marked!-ids!-rollback!*. Undo the typing of identifiers in
   % qqe_marked!-ids!-rollback!*.
   while qqe_marked!-ids!-rollback!* neq nil do
   <<
      qqe_niltid car qqe_marked!-ids!-rollback!*;
      qqe_marked!-ids!-rollback!* := cdr qqe_marked!-ids!-rollback!*;
   >>;

procedure qqe_add2rollbackids(u);
   % qqe add to rollback identifiers list. [u] is an atom.
   % Add variables being typed while processing a given formula with
   % qqe_check_args to the list qqe_marked!-ids!-rollback!*.
   qqe_marked!-ids!-rollback!* := u . qqe_marked!-ids!-rollback!*;

procedure qqe_iterate!-ltail(j, arg);
   % Queue quantor elimination iterate ltail. [j] is an integer.
   % [arg] is a lisp prefix.
   % Function returns ltail**j(arg).
   begin scalar term;
      term := arg;
      for jj:=1:j do
      <<
         term := {'ltail, term};
      >>;
      return term;
   end;

procedure qqe_iterate!-rtail(j, arg);
   % Queue quantor elimination iterate rtail. [j] is an integer.
   % [arg] is a lisp prefix.
   % Function returns rtail**j(arg).
   begin scalar term;
      term := arg;
      for jj:=1:j do
      <<
         term := {'rtail, term};
      >>;
      return term;
   end;

procedure qqe_iterate!-radd(j,arg, list);
   % Queue quantor elimination iterate radd. [j] is an integer.
   % [arg] is a lisp prefix. [list] is a list of lisp prefixes.
   % Function returns radd(l(j),radd(l(j-1) ....,arg)))).
   begin scalar term,l;

      term := arg;
      l := list;

      for jj:=1:j do
      <<
         term := {'radd, car l, term};
         l := cdr l;
      >>;
      return term;

   end;

procedure qqe_iterate!-ladd(j,arg,list);
   % Queue quantor elimination iterate Ladd. [j] is an integer.
   % [arg] is a lisp prefix. [list] is a list of lisp prefixes.
   % Function returns ladd(l(j),ladd(l(j-1) ....,arg)))).
   begin scalar term,l;

      term := arg;
      l := list;

      for jj:=1:j do
      <<
         term := {'ladd, car l, term};
         l := cdr l;
      >>;
      return term;

   end;

procedure qqe_varsubstat(atf,new,old);
   % Ordered field standard form substitute variable for variable in
   % atomic formula. [atf] is an atomic formula; [new] and [old] are
   % variables. Returns an atomic formula equivalent to [atf] where
   % [old] is substituted with [new].
   qqe_mk2(qqe_op atf,subst(new, old, qqe_arg2l atf),
      subst(new,old,qqe_arg2r atf));

endmodule;  % [qqe]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqeqe.red0000644000175000017500000004016011526203062024357 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqeqe.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_qe_rcsid!* qqe_qe_copyright!*);
   qqe_qe_rcsid!* :=
      "$Id: qqeqe.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_qe_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

module qqeqe;
% Quantifierelimination for queues. Module with algorithms
% for elimination process.



fluid '(qqe_resf!*  % list of atomic formulas not containing the 
                       % bounded variable -qvar-, which actually has
                       % to be eliminated
   qqe_qvarf!*      % list of atomic formulas containing qvar
   qqe_atf!-qequal!-ext!-c!* % list of atomic formulas of form: q == p
   qqe_atf!-qequal!-ext!-p!* % list of atomic formulas of form: Lq == p
   qqe_atf!-equal!-ext!* % list of at. formulas of form: t( ..,Lq,..) = ..
   qqe_atf!-equal!-int!* % list of atomic formulas of form: 
                         % t(...,Lq,...)=t(...,Mq,...)
   qqe_atf!-misc!-basic!* % list of atf of basic type not = or neq
   qqe_atf!-qequal!-int!*   % list of atomic formulas of form: Lq == Mq
   qqe_la!*         % left area
   qqe_ra!*         % right area
   qqe_pat!-lengths!* % list of pattern lengths
   qqe_sf!*         % formula to be quantifiereliminated
   qqe_atf!-qneq!-int!* % list of atomic formulas of form: Lq<<>>Mq
   qqe_atf!-qneq!-ext!* % list of atomic formulas of form: Lq<<>>p
   qqe_atf!-qneq!-ext!-qepsilon!* % list of atform. of form Lq <<>> qeps.
   qqe_atf!-neq!*    % list of atomic formulas of form: t(..,Lq,..) neq ..
   % qqe_atf!-neq!-int!-s!* % list of atomic formulas of form: 
                          % head(..(p)) neq head(..(p))
   qqe_var!*         % quantifier which binds qqe_var!* has to be 
                        % eliminated
   qqe_qqu!-list!*    % list of quantifiers of type queue which have to
                        % to be eliminated
   qqe_bqu!-list!*    % list of quantifiers of basic type
   % qqe_id_counter!*   % counts the number of new id's already used
   );

imports qqeqemisc.red;


procedure qqe_satlengths(minlength, maxlength, lcm, lara);
   % Queue quantifier elimination saturation lengths. Returns a list of
   % integers representing lengths which have to be considered for the
   % equivalent quantifierfree formula. [[minlength]], [[maxlength]], are
   % positive integer, [[lcm]] is nil in case there are no pattern in
   % the formula, else a positive integer, [[lara]] is a positive
   % integer denoting left area + right area.
   begin scalar list, sll;
      % if there are pattern in formula then add the corresponding
      % satlengths (lowest common multiplier of pat lengths!)
      if lcm then
         for j:=0:(lcm-1) do
            sll := append(sll, {j})
      else sll := {0};

      for j:=minlength:(max(lara,minlength)) do 
      <<
         for each x in sll do
            if null maxlength or maxlength >= j+x then
               list := lto_insertq(j + x,list);
      >>;
      
      if null lcm and qqe_atf!-qneq!-int!* then
         list := lto_insertq(lara +1,list);
      
      return qqe_quicksort list;
                        
   end;

% ------------------ Quantifierelimination ------------------------------

procedure qqe_qe(u);
   % Queue quantifier elimination entry function. [u] is a formula 
   % for which a existential quantifier binding [qvar] has to be
   % eliminated. The function initiates a scan of [u] to decide,
   % what further steps have to be done.
   begin scalar f;
   
      f := rl_pnf(u);
      f := cadr qqe_get!-quantifier!-sequenz(f);
      
      f := qqe_la2lth f;
      qqe_elimb!* := t;
      if null qqe_qqu!-list!* then <<
         if qqe_elimb!* then <<
            % return qqe_qe!-basic u
            f := qqe_simpl!-dnf rl_dnf qqe_qe!-basic 
               qqe_iterate!-quantifier(qqe_bqu!-list!*,f);
            qqe_qeexit();
            return f;
         >>
         else << qqe_qeexit(); return u;>>;
      >>;
      
      for each q in qqe_qqu!-list!* do
      <<
         if not atom f then <<
            if car q eq 'ex then f := cadr qqe_get!-quantifier!-sequenz f 
            else <<
               f := rl_dnf cadr qqe_get!-quantifier!-sequenz {'not, f};
               f := qqe_make!-harmless f;
               %pause;
            >>;
            
            f := qqe_la2lth f;
            
            f := rl_dnf f;
            
            if car q eq 'ex then f := rl_pnf qqe_qe!-dnf(f,cadr q) 
            else f := rl_pnf {'not,qqe_qe!-dnf(f,cadr q)};
      
         >>;
      >>;
      
      f := rl_pnf rl_simpl(f,nil,-1);
      if not atom f then <<
         << if x then f := cadr x >>
            where x=qqe_get!-quantifier!-sequenz f;
         f := qqe_simpl!-dnf rl_dnf f;
         f := qqe_iterate!-quantifier(qqe_bqu!-list!*,f);
      >>;
      qqe_qeexit();
      return if qqe_elimb!* then qqe_qe!-basic f else f;
            
   end;

procedure qqe_qeexit();
   % QQE exit. Exit function. Free memory.
   begin
      qqe_resf!* := nil;
      qqe_qvarf!* := nil;    
      qqe_atf!-qequal!-ext!-c!* := nil;
      qqe_atf!-qequal!-ext!-p!* := nil;
      qqe_atf!-equal!-ext!* := nil;
      qqe_atf!-equal!-int!* := nil;
      qqe_atf!-misc!-basic!* := nil;
      qqe_atf!-qequal!-int!* := nil;  
      qqe_la!* := nil;    
      qqe_ra!* := nil;
      qqe_pat!-lengths!* := nil;
      qqe_sf!* := nil;       
      qqe_atf!-qneq!-int!* := nil;
      qqe_atf!-qneq!-ext!* := nil;
      qqe_atf!-qneq!-ext!-qepsilon!* := nil;
      qqe_atf!-neq!* := nil;  
      qqe_var!* := nil;   
      qqe_qqu!-list!* := nil;
      qqe_bqu!-list!* := nil;
   end;

procedure qqe_qe!-clause!-init(u);
   % initialize fluids
   begin
      qqe_resf!* := nil; 
      qqe_qvarf!* := nil;
      qqe_atf!-qequal!-ext!-c!* := nil;
      qqe_atf!-qequal!-ext!-p!* := nil;
      qqe_atf!-equal!-ext!* := nil;
      qqe_atf!-equal!-int!* := nil; 
      qqe_atf!-misc!-basic!* := nil; 
      qqe_atf!-qequal!-int!* := nil; 
      qqe_la!* := nil;
      qqe_ra!* := nil;
      qqe_pat!-lengths!* := nil; 
      qqe_sf!* := nil;
      qqe_atf!-qneq!-int!* := nil;
      qqe_atf!-qneq!-ext!* := nil;
      qqe_atf!-qneq!-ext!-qepsilon!* := nil;
      qqe_atf!-neq!* := nil;
      %% qqe_atf!-neq!-int!-s!* := nil;
      qqe_var!* := nil;
      % qqe_qqu!-list!* := nil;
      % qqe_bqu!-list!* := nil;

      % return  qqe_length!-graph!-clause u;
      return qqe_clause!-update!-lengths(u,t);
   end;

procedure qqe_qe!-dnf(u,q);
   % Queue quantifier elimination for disjunctive normal form.
   % [u] is dnf. Quantifier of variable [q] is has to be eliminated. 
   begin scalar f, temp;
      if u memq '(true false) then return u
      else if car u eq 'or then
      <<
         f := {'or};
         if cddr u then 
         <<
            for each x in cdr u do 
            <<
               temp := qqe_qe!-clause(x,q);
               f := append(f, {temp});  
            >>;
         >>
         else 
            f := qqe_qe!-clause(cadr u,q);
      >>
      else f := qqe_qe!-clause(u,q);
      
      return f;
   end;

procedure qqe_qe!-clause(u,q);
   % Queue quantifier elimination for clause of dnf.  [u] is a
   % conjunctive clause. Quantifier of variable [q] is has to be
   % eliminated.
   begin scalar f, list; 
      list := qqe_qe!-clause!-init(u);
      if list eq 'false then u := 'false
      else if list then <<
         if null qqe_harmless!-formula!-test!-clause1(u, list) then <<
            qqe_length!-graph!-delete list;
            qqe_qeexit();
            rederr("input formula is not harmless");
         >>;
      >>;

      if not atom u then u := qqe_simpl!-clause(u);

      if idp u then <<
         if list neq 'false then qqe_length!-graph!-delete(list);
         return u;
      >>;

      f := u;

      % initialization of fluids
      qqe_var!* := q;
      qqe_sf!* := f;

      qqe_sort!-atf(qqe_sf!*, qqe_var!*);
      
      if null qqe_qvarf!* then <<
         qqe_length!-graph!-delete(list);
         return f;
      >>;

      % calculation of left and right area
      qqe_la!* := qqe_la();
      qqe_ra!* := qqe_ra();
  
      % decision how to proceed according to structure of input formula
      if qqe_atf!-qequal!-ext!-c!* or qqe_atf!-qequal!-ext!-p!* 
      then <<
	 f := qqe_qe!-dna();
	 if qqe_resf!* then
            f := append({'and,f},qqe_resf!*);
      >>
      else <<
         if qqe_atf!-qneq!-ext!* then f:= qqe_ndna!-qneq!-ext()
         else f := qqe_ndna(nil,nil ,nil, qqe_la!* + qqe_ra!*); 
         if qqe_resf!* then
            f := append({'and,f},qqe_resf!*);
      >>;
  
      f := rl_simpl(f,nil,-1);
     
      qqe_length!-graph!-delete(list);
      
      return f;      
   end;

procedure qqe_qe!-dna();
   % Queue quantifier elimination determined neutral area. Initiates
   % quantifier elimination for the case that the neutral area is
   % fully determined.
   if qqe_atf!-qequal!-ext!-c!* then qqe_qe!-dna!-fd()
   else qqe_qe!-dna!-nfd();
   
procedure qqe_qe!-dna!-fd();
   % Queue quantifier elimination determined neutral area with [qqe_sf!*]
   % is fully determined, e.g. a atomic formula of the form: q==p exists.
   qqe_simpl!-clause subst(qqe_arg2r car qqe_atf!-qequal!-ext!-c!*,
      qqe_var!*, qqe_sf!*);
  
procedure qqe_qe!-dna!-nfd();
   % Queue quantifier elimination determined neutral area with [qqe_sf!*]
   % is not fully determined with a formula of the form q == p.
   begin scalar l,r,j, phi, rho, phi_e, k, idlist, minlength, maxlength;
      % init of variables   
      minlength := get(qqe_var!*,'minlength);
      if null minlength then minlength := 0;
      maxlength := get(qqe_var!*,'maxlength);
      if qqe_debug!* then 
	 prin2t{"minlength=",minlength," maxlength=", maxlength};
      j := qqe_atf!-qequal!-ext!-min!-prefix();
      l := qqe_atf!-qequal!-ext!-p!-min!-lefts(minlength, cadr j);
      r := qqe_atf!-qequal!-ext!-p!-min!-rights(minlength,cadr j);
      k := car l + car r;
      if maxlength then k := min(maxlength, k);
      idlist := qqe_new!-ids!-x(k, qqe_sf!*);

      % subformula generation
      % - rho
      if minlength + 1 < k then
         rho := qqe_atf!-dna!-nfd!-rho(idlist, minlength, k)
       else rho := 'false; 
      % - phi
      phi := qqe_simpl!-clause subst(
         qqe_atf!-dna!-nfd!-psi!-subst(l,r,j, idlist), qqe_var!*, qqe_sf!*);
      % - phi_e
      if minlength = 0 then
         phi_e := qqe_simpl!-clause subst('qepsilon, qqe_var!*, qqe_sf!*)
      else phi_e := 'false; 
      if qqe_debug!* then <>;

      return qqe_qe!-basic qqe_iterate!-quantifier!-ex(k, idlist, 
        qqe_la2lth {'or, rho, phi, phi_e});
   end;


procedure qqe_atf!-dna!-nfd!-rho(idlist, minlength, kup);
   begin scalar f, ff, idlistx;
      for j:=max(minlength,1):kup do 
      <<
         idlistx := qqe_list!-take!-n(idlist,kup,j);
         f := qqe_subst(j,idlistx);         
         ff := f . ff;
      >>;
      
      if null cdr ff then return car ff
      else return 'or . ff;
   end;

procedure qqe_atf!-dna!-nfd!-rho!-subst(list,k);
   % obsolete - but eventually needed later
   begin scalar x, f;
      x := list;
      f := 'qepsilon;

      for j:=1:k do
      <<
         f := {'radd, car x, f};
         x := cdr x;
      >>;
      return f;
   end;

procedure qqe_atf!-dna!-nfd!-psi!-subst(l,r,j, idlist);
   % QQE atomic formula determined neutral area not fully determined
   % psi substitution. [l], [r], [j] are natural
   % numbers. [idlist] is a list of identifiers.
   begin scalar x, f;
      
      x := idlist;
      f := qqe_arg2r cadr j;

      if cadr l neq cadr j then
      <<
         for jj:=0:
            (qqe_prefix!-lefts qqe_arg2l cadr j - 
               qqe_prefix!-lefts qqe_arg2l cadr l - 1)
               do f := {'ladd, {'lhead, 
                  qqe_iterate!-rtail(jj, qqe_arg2r cadr l)}, f};
      >>;

      if car l neq 0 then
      <<
         for j:=1:car l do
         <<
            f := {'ladd, car x, f};
            x := cdr x;
         >>;
      >>;
      
      if cadr r neq cadr j then
      <<
         for jj:=0:
            (qqe_prefix!-rights qqe_arg2l cadr j - 
               qqe_prefix!-rights qqe_arg2l cadr r - 1)
                  do f:= {'radd,{'rhead, 
                     qqe_iterate!-ltail(jj, qqe_arg2r cadr r)}, f};
      >>;
      
      if car r neq 0 then
      <<
         for jj:=1:car r do
         <<
            f := {'radd, car x, f};
            x := cdr x;
         >>;
      >>;
      return f;
   end;

procedure qqe_ndna(minlength, maxlength,lcm, lara);
   % Queue quantifier elimination not determined neutral area.
   % [minlength], [maxlength], [lcm] are natural numbers, or nil.
   begin scalar satlengths,f, new_ids, new_idsx;
      
      if null minlength then minlength := get(qqe_var!*,'minlength);
      if null maxlength then maxlength := get(qqe_var!*,'maxlength);
      if null minlength then minlength := 0;

      if null qqe_pat!-lengths!* and qqe_atf!-qequal!-int!* then
      <<
         qqe_pat!-lengths!* := qqe_pat!-lengths(lara);
         if null lcm then
            lcm := qqe_lcm!-list qqe_pat!-lengths!*;
      >>;

      satlengths := qqe_satlengths(minlength, maxlength, lcm, lara);

      if qqe_debug!* then 
         prin2t{"satlengths=",satlengths, "for ", qqe_var!*};

      new_ids := qqe_new!-ids!-x(car satlengths, qqe_sf!*);
      
      f := nil;
      for each x in satlengths do
      << %!!!
         new_idsx := qqe_list!-take!-n(new_ids,car satlengths,x);
         f := qqe_qe!-basic(qqe_iterate!-quantifier!-ex(x,new_idsx,
            qqe_subst(x, new_idsx))) . f;
      >>;
      if cdr satlengths then f := 'or . f else f := car f;
      return f;
   end;

procedure qqe_ndna!-qneq!-ext!-phi2!-true();
   if qqe_atf!-qequal!-ext!-c!* or qqe_atf!-qequal!-ext!-p!* or
      qqe_atf!-equal!-ext!* or qqe_atf!-equal!-int!* or
      qqe_atf!-misc!-basic!* or qqe_atf!-qequal!-int!* or
      qqe_atf!-qneq!-int!* or qqe_atf!-neq!* 
   then nil
   else 'true;
  
procedure qqe_ndna!-qneq!-ext();
   % QQE not determined neutral area for the case that
   % [qqe_atf!-qneq!-ext!*] is not nil.
   begin scalar phi1, phi2, lcm, lara;
      
      lara := qqe_la!* + qqe_ra!*;
      if qqe_atf!-qequal!-int!* then
      <<
         qqe_pat!-lengths!* := qqe_pat!-lengths(lara);
         lcm := qqe_lcm!-list qqe_pat!-lengths!*;
      >>
      else lcm := 1;
      
      phi1 := rl_simpl(qqe_ndna(nil,nil, lcm, lara),nil,-1);
      if qqe_debug!* then pause;
      phi2 := qqe_ndna!-qneq!-ext!-phi2!-true(); 
   
      qqe_atf!-qneq!-ext!* := nil;
      qqe_atf!-qneq!-ext!-qepsilon!* := nil;
      if null phi2 then phi2 := rl_simpl(qqe_ndna(lara + lcm, 
         lara + 2 * lcm - 1, lcm, lara + lcm),nil,-1);
      if qqe_debug!* then pause;
      return {'or, phi1, phi2};
   end;
      
endmodule;  % [qqeqe]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/qqe/qqetrans.red0000644000175000017500000005226211526203062025107 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: qqetrans.red 81 2009-02-06 18:22:31Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2005-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(qqe_trans_rcsid!* qqe_trans_copyright!*);
   qqe_trans_rcsid!* :=
      "$Id: qqetrans.red 81 2009-02-06 18:22:31Z thomas-sturm $";
   qqe_trans_copyright!* := "Copyright (c) 2005-2009 A. Dolzmann and T. Sturm"
>>;

module qqetrans;
% Queue quantor elimination translation module. Submodule of [qqe].

exports qqe_la2lth;

procedure qqe_la2lth(u);
   % qqe language with ladds and radds to language with only heads and
   % tails. [u] is a S-expression, it is supposed to be a formula.
   % Function recursively transforms a formula into an equivalent one 
   % with only heads and tails. Function calls for subroutines for
   % atomic formula or for non atomic formula are performed.
   begin scalar f;
      % non atomic formula
      if qqe_debug!* then prin2t":::entering qqe_la2lth";
      if atom u then return u;
      f := rl_simpl(u,nil,-1);
      if atom f then return f;
      if qqe_debug!* then prin2t{"simplificated formula is", f};
      if rl_cxp car f then return qqe_la2lth1 f
      % atomic formula
      else return qqe_la2lth!-at f;
   end;

procedure qqe_la2lth1(u);
   % qqe language with ladds and radds to language with only heads and
   % tails. [u] is a S-expression, it is supposed to be a formula.
   % Function recursively transforms a formula into an equivalent one 
   % with only heads and tails. Function calls for subroutines for
   % atomic formula or for non atomic formula are performed.
   car u . for each x in cdr u collect 
      if qqe_qadd!-insidef x  then qqe_la2lth x
      else x;

procedure qqe_la2lth!-at(u);
   % qqe language with ladds and radds to language with only heads and
   % tails for atomic formulas. [u] is a S-expression, it is supposed to 
   % be an atomic formula. The most outer ladd or radd is transformed 
   % into equivalent form without ladd, radd. 
   begin scalar lhs, rhs, op, x, prepu;
      
      prepu := rl_prepat u;
      lhs := qqe_arg2l prepu;
      rhs := qqe_arg2r prepu;
      op := qqe_op prepu;
      x := nil;

      if qqe_qadd!-inside lhs then 
      <<
         u := qqe_la2lth!-at1 prepu;
         x := t;
      >>
      else if qqe_qadd!-inside rhs then 
      <<
         u := qqe_la2lth!-at1 qqe_mk2(op,rhs,lhs); 
         x := t;
      >>;

      if x then u := qqe_la2lth u;
      
      return u;
   end;

procedure qqe_la2lth!-at1(u);
   % qqe language with ladds and radds to language with only heads and
   % tails for atomic formulas. [u] is a S-expression, it is supposed to 
   % be an atomic formula in lisp prefix.
   if (qqe_qopaddp caadr u) then qqe_la2lth!-addout u
   else qqe_la2lth!-addin u;
      
procedure qqe_la2lth!-addout(u);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is most outer function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula in lisp prefix.
   begin scalar op, lhs, rhs, rhsadd, lhsadd, opadd;
      op := qqe_op u;
      lhs := qqe_arg2l u;
      rhs := qqe_arg2r u; 
      lhsadd := qqe_arg2l lhs;
      rhsadd := qqe_arg2r lhs;
      opadd := qqe_op lhs;

      if opadd = 'ladd then
      <<
         if op eq 'qequal then
            return {'and, qqe_mk2('qneq,rhs,'qepsilon),
               rl_simpat(qqe_mk2('equal,{'lhead,copy rhs},lhsadd)),
               qqe_mk2('qequal,{'rtail,rhs},rhsadd)}
         else return {'or, qqe_mk2('qequal,rhs,'qepsilon),
            {'and, rl_simpat(qqe_mk2('neq,{'lhead, copy rhs},lhsadd)),
               qqe_mk2('qneq,copy rhs,'qepsilon)},
            qqe_mk2('qneq,{'rtail,copy rhs},rhsadd)};
      >>
      else if opadd = 'radd then
      <<
         if op eq 'qequal then
            return {'and, qqe_mk2('qneq, rhs, 'qepsilon),
               rl_simpat(qqe_mk2('equal,{'rhead,rhs},lhsadd)),
               qqe_mk2('qequal,{'ltail,copy rhs},rhsadd)}
         else return {'or, qqe_mk2('qequal,rhs,'qepsilon),
            {'and, rl_simpat(qqe_mk2('neq,{'rhead,copy rhs},lhsadd)),
               qqe_mk2('qneq,rhs,'qepsilon)},
            qqe_mk2('qneq,{'ltail,copy rhs},rhsadd)};
      >>
            
   end;


procedure qqe_la2lth!-addin(u);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula in lisp prefix.
   begin scalar lhs, preadd, preaddop, opadd, at_type;
      at_type := qqe_op u;
      lhs := qqe_arg2l u;

      qqe_reset!-qadd!-location();
      qqe_qadd!-inside lhs;  %% should become obsolete
                            %% at the moment still needed

      % first if lhs has more then one argument, we should locate the
      % "right" subterm of lhs!!! compare example: %% (greaterp
      % ((((lhead q) . 1) . 1) (( %% (rhead (radd x10 (radd x9 (radd
      % x8 (radd x7 (ladd x6 %% (ladd x5 (ladd x4 (ladd x3 (ladd x2
      % (ladd x1 (ltail %% (ltail (ltail q)))))))))))))) . 1) . 1)
      % (((rhead m) . 1) . -1) %% ((x . 1) . 1)) nil)

      preadd := qqe_qadd!-inside!-relocate lhs;
      preaddop := qqe_op preadd;

      if qqe_debug!* then 
         prin2t{"preadd=",preadd,"preaddop=",preaddop, 
            "at_type = ", at_type};
      % pause;

      opadd := qqe_op qqe_arg2l preadd;
      
      if opadd = 'ladd then
      <<
         if preaddop = 'lhead then
            u := qqe_la2lth!-addin!-laddlhead u
         else if preaddop = 'ltail then
            u := qqe_la2lth!-addin!-laddltail(u,at_type)
         else if preaddop = 'rhead then
            u := qqe_la2lth!-addin!-laddrhead(u,at_type)
         else if preaddop = 'rtail then
            u := qqe_la2lth!-addin!-laddrtail(u,at_type);
         % else rederr("qqe_la2lth expected something else");
      >>
      else if opadd = 'radd then
      <<
         if preaddop = 'lhead then
            u := qqe_la2lth!-addin!-raddlhead(u,at_type)
         else if preaddop = 'ltail then
            u := qqe_la2lth!-addin!-raddltail(u,at_type)
         else if preaddop = 'rhead then
            u := qqe_la2lth!-addin!-raddrhead u
         else if preaddop = 'rtail then
            u := qqe_la2lth!-addin!-raddrtail(u,at_type);
         % else rederr("qqe_la2lth expected something else");
      >>;
      % else rederr("qqe_la2lth expected something else");
      % prin2t{"end with u=", u}; pause;
      return u;
   end;
      

procedure qqe_la2lth!-addin!-laddlhead(u);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is lhead. 
   begin scalar lhs, lhsadd, prepreadd;
      lhs := qqe_arg2l u;
       
      lhsadd := cadr cadr qqe_qadd!-inside!-relocate lhs;;

      prepreadd := qqe_qadd!-inside!-relocate!-2up lhs;
       
      cadr prepreadd := lhsadd;

      return rl_simpat u;
   end;

procedure qqe_la2lth!-addin!-laddrhead(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is rhead. 
   begin scalar list, cu, prepreadd, preadd, preadd_cu,
         lhsadd, rhsadd;
      preadd := qqe_qadd!-inside!-relocate cadr u;
      cu := copy u;
      lhsadd := cadr cadr preadd;
      if atom cddr cadr preadd then rhsadd := cddr cadr preadd 
      else rhsadd := caddr cadr preadd;
          
      if cadr u neq preadd then
      <<
         prepreadd := qqe_qadd!-inside!-relocate!-2up cadr u;
         preadd_cu := qqe_qadd!-inside!-relocate cadr cu;
         cadr preadd_cu := copy rhsadd;
         cadr prepreadd := lhsadd;
      >>
      else
      <<
         cadr u := lhsadd;
         cadr cu := {'rhead, copy rhsadd};
      >>;
      
      if op neq 'neq then
         u := {'or, {'and,rl_simpat cu, 
            qqe_mk2('qneq,copy rhsadd,'qepsilon)},
            {'and,rl_simpat u,qqe_mk2('qequal,copy rhsadd,'qepsilon)}}
      else % op eq 'neq 
         u := {'and, {'or,rl_simpat cu, 
            qqe_mk2('qequal,copy rhsadd,'qepsilon)},
            {'or,rl_simpat u,qqe_mk2('qneq,copy rhsadd,'qepsilon)}};
      
      return u;
   end;

procedure qqe_la2lth!-addin!-laddltail(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is ltail. 
   begin scalar cu, lhsadd, rhsadd, prepreadd, preadd, preadd_cu;

      preadd := qqe_qadd!-inside!-relocate cadr u;
      
      lhsadd := cadr cadr preadd;
      if atom cddr cadr preadd then rhsadd := cddr cadr preadd 
      else rhsadd := caddr cadr preadd;
      cu := copy u;
      % prin2t{"cu=",cu, preadd, rhsadd,lhsadd};
      if cadr u neq preadd then
      <<
         % prin2t "here";
         preadd_cu := qqe_qadd!-inside!-relocate cadr cu;
         prepreadd := qqe_qadd!-inside!-relocate!-2up cadr u;
         car preadd_cu := 'ladd;         
         cdr preadd_cu := copy lhsadd . {{'ltail, copy rhsadd}};
         cadr prepreadd := 'qepsilon;
      >>
      else
      <<
         % prin2t "here2";
         cadr u := 'qepsilon;
         cadr cu := qqe_mk2('ladd, copy lhsadd,{'ltail, copy rhsadd});
      >>;
      
      if op eq 'qequal then
      u := {'or, {'and,rl_simpat cu, 
         qqe_mk2('qneq,copy rhsadd,'qepsilon)},
         {'and,rl_simpat u, qqe_mk2('qequal, copy rhsadd, 'qepsilon)}}
      else % op eq 'qneq
         u := {'and, {'or,rl_simpat cu, 
            qqe_mk2('qequal,copy rhsadd,'qepsilon)},
         {'or,rl_simpat u, qqe_mk2('qneq,copy rhsadd, 'qepsilon)}};
      return u;
      
   end;

procedure qqe_la2lth!-addin!-laddrtail(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is rtail. 
   begin scalar list, cu, preadd, prepreadd, preadd_cu, prepreadd_cu, 
         lhsadd, rhsadd;
      preadd := qqe_qadd!-inside!-relocate cadr u;
      lhsadd := cadr cadr preadd;
      if atom cddr cadr preadd then rhsadd := cddr cadr preadd 
      else rhsadd := caddr cadr preadd;
      cu := copy u;
      
      if cadr u neq preadd then
      <<
         preadd_cu := qqe_qadd!-inside!-relocate cadr cu;
         prepreadd := qqe_qadd!-inside!-relocate!-2up cadr u;
         prepreadd_cu := qqe_qadd!-inside!-relocate!-2up cadr cu;
         cadr prepreadd_cu := copy rhsadd;
         cadr prepreadd := 'qepsilon;
      >>
      else
      <<
         cadr u := 'qepsilon;
         cadr cu := copy rhsadd;
      >>;
      
      if op eq 'qequal then
         u := {'or, {'and,rl_simpat cu, 
            qqe_mk2('qneq,copy rhsadd,'qepsilon)},
            {'and,rl_simpat u, qqe_mk2('qequal, copy rhsadd, 
               'qepsilon)}}
      else % op eq 'qneq
         u := {'and, {'or,rl_simpat cu, 
            qqe_mk2('qequal,copy rhsadd,'qepsilon)},
            {'or,rl_simpat u, qqe_mk2('qneq, copy rhsadd, 'qepsilon)}};
      return u;
      
   end;

procedure qqe_la2lth!-addin!-raddlhead(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is lhead. 
   begin scalar list, cu, preadd, prepreadd,  preadd_cu, 
         lhsadd, rhsadd;
      preadd := qqe_qadd!-inside!-relocate cadr u;
      lhsadd := cadr cadr preadd;
      if atom cddr cadr preadd then rhsadd := cddr cadr preadd 
      else rhsadd := caddr cadr preadd;
      cu := copy u;
            
      if cadr u neq preadd then
      <<
         preadd_cu := qqe_qadd!-inside!-relocate cadr cu;
         prepreadd := qqe_qadd!-inside!-relocate!-2up cadr u;
         cadr preadd_cu := copy rhsadd;
         cadr prepreadd := lhsadd;
      >>
      else
      <<
         cadr u := lhsadd;
         cadr cu := {'lhead, copy rhsadd};
      >>;
      
      if op neq 'neq then
         u := {'or, {'and,rl_simpat cu, 
            qqe_mk2('qneq,copy rhsadd,'qepsilon)},
            {'and,rl_simpat u, qqe_mk2('qequal,copy rhsadd, 
               'qepsilon)}}
      else % op eq 'neq
         u := {'and, {'or,rl_simpat cu, 
            qqe_mk2('qequal,copy rhsadd,'qepsilon)},
            {'or,rl_simpat u, qqe_mk2('qneq,copy rhsadd, 'qepsilon)}};
      return u;
   end;

procedure qqe_la2lth!-addin!-raddrhead(u);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is rhead. 
   qqe_la2lth!-addin!-laddlhead u;

procedure qqe_la2lth!-addin!-raddltail(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is rtail. 
   qqe_la2lth!-addin!-laddrtail(u,op);

procedure qqe_la2lth!-addin!-raddrtail(u,op);
   % qqe language with ladds and radds to language with only heads and
   % tails with add is an inside function of the lhs term of an atomic 
   % formula. [u] is a S-expression, it is supposed to be a atomic 
   % formula. This is a subroutine for the case the the predecessor
   % function to radd or ladd is rtail. 
   begin scalar list, cu, preadd_cu, preadd, prepreadd, lhsadd, rhsadd;
      preadd := qqe_qadd!-inside!-relocate cadr u;
      lhsadd := cadr cadr preadd;
      if atom cddr cadr preadd then rhsadd := cddr cadr preadd 
      else rhsadd := caddr cadr preadd;
      cu := copy u;
            
      if cadr u neq preadd then
      <<
         preadd_cu := qqe_qadd!-inside!-relocate cadr cu;
         prepreadd := qqe_qadd!-inside!-relocate!-2up cadr u;
         car preadd_cu := 'radd;
         cdr preadd_cu := copy lhsadd . {{'rtail, copy rhsadd}};
         cadr prepreadd := 'qepsilon;
      >>
      else
      <<
         cadr u := 'qepsilon;
         cadr cu := qqe_mk2('radd, copy lhsadd, {'rtail, copy rhsadd});
      >>;
      
      if op eq 'qequal then
         u := {'or, {'and,rl_simpat cu,
            qqe_mk2('qneq,copy rhsadd,'qepsilon)},
            {'and,rl_simpat u, qqe_mk2('qequal, copy rhsadd, 
               'qepsilon)}}
      else
         u := {'and, {'or,rl_simpat cu,
            qqe_mk2('qequal,copy rhsadd,'qepsilon)},
            {'or,rl_simpat u, qqe_mk2('qneq, copy rhsadd, 
               'qepsilon)}};
      
      return u;
      
   end;

% --------------------------------------------------------------------
%                qadd location

procedure qqe_reset!-qadd!-location();
   qqe_qadd!-location!* := nil;

procedure qqe_qadd!-inside!-at(u);
   % qqe queue add inside atomic formula. [u] is a S-expression,
   % it is supposed to be a atomic formula. Function 
   % checks if a ladd or radd is within the lhs or rhs of u and returns 
   % [t], if so, and [nil] if not.
   begin scalar lhs, rhs,prepu;
      
      prepu := rl_prepat u;
      lhs := qqe_arg2l prepu;

      rhs := qqe_arg2r prepu;

      if qqe_qadd!-inside lhs or qqe_qadd!-inside rhs then return t
      else return nil;
   end;

procedure qqe_qadd!-insidef(f);
   % QQE queue add inside of f. [f] is a term. procedure checks
   % recursivly if there is an appearance of [radd] or [ladd] in
   % [f]. If so, then it returns [t], else [nil].
   begin scalar p,x;
      
      if rl_cxp qqe_op f then 
      <<
         
         x := cdr f;
         while x and null p do
         <<
            p := qqe_qadd!-insidef car x or p;
            x := cdr x;
         >>;
         return p;
      >>
      else return qqe_qadd!-inside!-at f;
   end;

procedure qqe_qadd!-inside(u);
   % qqe queue add inside atomic. [u] is a S-expression,
   % it is supposed to be a term in lisp prefix. Function checks if
   % a ladd or radd is within u and returns [t],
   % if so, and [nil] if not.
   begin scalar op, notyet, x, preop, qadd_location_before;

      if null u or atom u then return nil;
      op := qqe_op u;
      qqe_qadd!-location!* := 'a . qqe_qadd!-location!*;

      if pairp u and not qqe_qopaddp op then 
         <<
            notyet := t;
            preop := op;
            x := cdr u;
            qadd_location_before := qqe_qadd!-location!*;

            while x and notyet do
               <<
                  qqe_qadd!-location!* := 'd . qadd_location_before;
                  qadd_location_before := qqe_qadd!-location!*;
                  if not atom x and pairp car x and 
                     qqe_qadd!-inside car x 
                  then notyet := nil;
                  preop := x;
                  x := cdr x;
               >>;
            % prin2t
            
            if not notyet then return preop
            else return nil;
         >>
      % else if atom op then return nil
      else if pairp u and qqe_qopaddp op then return t
      else return nil;
   end;

procedure qqe_qadd!-inside!-relocate(u);
   % qqe queue add inside relocate the first appearance of a ladd or
   % radd. [u] is a S-expression, it is supposed to be a term. 
   % qqe_qadd!-inside supposed to be executed before.
   % Function returns a term beginning with the first function in u,
   % whose argument the most outside ladd, radd of u is.
   % For example: u := lhead(ltail(radd(lhead(q),p))), then
   % ltail(radd(lhead(q),p)) is being returned. 
   % Function returns [nil] if there is no ladd, radd in u.
   begin scalar pos, rq, list;
      
      list := reverse qqe_qadd!-location!*;
      % pos := cdr qqe_qadd!-location!*;
      pos := cdr list;
      rq := u;

      while cddr pos do
      <<
         if car pos = 'a then rq := car rq
         else rq := cdr rq; % car pos = 'd
         pos := cdr pos;
      >>;
      
      return if atom car rq then rq else car rq;
     
   end;

procedure qqe_qadd!-inside!-relocate!-2up(u);
   % qqe queue add inside relocate the first appearance of a ladd or
   % radd. [u] is a S-expression, it is supposed to be a term.
   % qqe_qadd!-inside supposed to be executed before.  Function
   % returns a S-expression beginning with the first function f in u,
   % whose argument q := qqe_qadd!-inside!-relocate u is, if f is
   % unary or q is the first argument, otherwise it returns the last
   % argument of f left to q.  For example: u := (plus
   % (lhead(ltail(radd(lhead(q),p)))) y), then
   % lhead(ltail(radd(lhead(q),p))) is being returned.  Another
   % example: u := (plus y (lhead(ltail(radd(lhead(q),p))))), then (y
   % (lhead(ltail(radd(lhead(q),p))))) is returned. Function returns
   % [nil] if there is no ladd, radd in u.
   begin scalar pos_loc, pos_u;
      if length qqe_qadd!-location!* < 5 then return u;
      % prin2t qqe_qadd!-location!*;
      pos_loc := cdr reverse cddddr qqe_qadd!-location!*;
      % prin2t pos_loc;
      pos_u := u;
      for each x in pos_loc do
      <<
         if x eq 'a then pos_u := car pos_u
         else pos_u := cdr pos_u;
      >>;
      % return if atom car pos_u then pos_u else car pos_u;
      return pos_u;
   end;

endmodule;  % [qqetrans]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/dcfsf/0000755000175000017500000000000011722677357023071 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/dcfsf/dcfsfqe.red0000644000175000017500000011466711526203062025173 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: dcfsfqe.red 981 2010-12-02 21:40:09Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2004-2009 A. Dolzmann, 2004-2010 T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(dcfsf_qe_rcsid!* dcfsf_qe_copyright!*);
   dcfsf_qe_rcsid!* :=
      "$Id: dcfsfqe.red 981 2010-12-02 21:40:09Z thomas-sturm $";
   dcfsf_qe_copyright!* := "(c) 2004-2009 A. Dolzmann, 2004-2010 T. Sturm"
>>;

module dcfsfqe;
% Diferentially closed field standard form quantifier elimination.

procedure dcfsf_orddegf(f,v);
   % Diferentially closed field standard form order and degree. [f] is
   % a standard form; [v] is a variable. Returns a pair of numbers.
   % The [car] is the order and the [cdr] is the degree wrt. [v].
   dcfsf_orddegf1(f,v,(-1) . (-1));

procedure dcfsf_orddegf1(f,v,od);
   % Diferentially closed field standard form order and degree
   % subroutine. [f] is a standard form; [v] is a variable; [od] is a
   % pair of numbers. Returns a pair of numbers. The [car] is the
   % order and the [cdr] is the degree wrt. [v].
   begin scalar mv,r; integer lord;
      if domainp f then
 	 return od;
      mv := mvar f;
      lord := if mv eq v then
	 0
      else if pairp mv and cadr mv eq v then
	 caddr mv
      else
	 -2;
      if lord > car od then
	 od := lord . ldeg f
      else if lord = car od then
	 od := lord . max(cdr od,ldeg f);
      r := f;
      while not domainp r and mvar r eq mv do
	 r := red r;
      return dcfsf_orddegf1(lc f,v,dcfsf_orddegf1(r,v,od))
   end;

procedure dcfsf_ordf(f,v);
   % Diferentially closed field standard form order. [f] is a standard
   % form with kernel order [{...,(d v 2),(d v 1),v}]; [v] is a
   % variable. Returns a number, the order of [f] wrt. [v].
   if domainp f then
      -1
   else if mvar f eq v then
      0
   else if pairp mvar f and cadr mvar f eq v then
      caddr mvar f
   else
      -1;

procedure dcfsf_degf(f,v);
   % Diferentially closed field standard form order. [f] is a standard
   % form with kernel order [{...,(d v 2),(d v 1),v}]; [v] is a
   % variable. Returns a number, the degree of [f] wrt. [v].
   if domainp f then
      0
   else if mvar f eq v or pairp mvar f and cadr mvar f eq v then
      ldeg f
   else
      0;

procedure dcfsf_df(f,x);
   % Diferentially closed field standard form derivative. [f] is a
   % standard form; [x] is a possibly composite kernel. Returns a
   % standard form. Computes the formal partial derivative of [f] wrt.
   % [x].
   begin scalar oldorder,w;
      oldorder := setkorder {x};
      w := dcfsf_df1(reorder f,x);
      setkorder oldorder;
      return reorder w
   end;

procedure dcfsf_df1(f,x);
   % Diferentially closed field standard form derivative subroutine. [f]
   % is a standard form; [x] is a possibly composite kernel that is
   % largest wrt. the current kernel order. Returns a standard form.
   % Computes the formal partial derivative of [f] wrt. [x].
   if domainp f or mvar f neq x then
      nil
   else if eqn(ldeg f,1) then
      lc f
   else
      x .** (ldeg f - 1) .* multf(ldeg f,lc f) .+ dcfsf_df1(red f,x);

procedure dcfsf_derivationf(f,n,theo);
   % Diferentially closed field standard form n-th derivation. [f] is a
   % standard form; [theo] is a theory. Returns a standard form.
   % Computes the n-th derivative of [f].
   begin scalar r;
      r := f;
      for i := 1 : n do
	 r := dcfsf_derivation1f(r,theo);
      return r
   end;

procedure dcfsf_derivation1f(f,theo);
   % Diferentially closed field standard form derivation. [f] is a
   % standard form; [theo] is a theory. Returns a standard form.
   % Computes the derivative of [f].
   begin scalar res;
      for each v in kernels f do
	 res := addf(res,multf(dcfsf_df(f,v),dcfsf_derivationk(v,theo)));
      return res
   end;

procedure dcfsf_derivationk(k,theo);
   % Diferentially closed field kernel derivation. [k] is a kernel;
   % [theo] is a theory. Returns a standard form. Computes the
   % derivative of [k], which is possibly specified in [theo].
   begin scalar oldorder,kpf,kp,a,cnt;
      kp := dcfsf_derivationk1 k;
      kpf := kp .** 1 .* 1 .+ nil;
      oldorder := setkorder {kp};
      cnt := t;
      while cnt and theo do <<
	 a := pop theo;
	 if dcfsf_op a eq 'equal then <<
	    a := reorder dcfsf_arg2l a;
	    if mvar a eq kp and lc a = 1 then <<
	       cnt := nil;
	       kpf := negf red a
	    >>
	 >>
      >>;
      setkorder oldorder;
      return reorder kpf
   end;

procedure dcfsf_derivationk1(k);
   % Diferentially closed field kernel derivation subroutine. [k] is a
   % kernel. Returns a kernel. Computes the derivative of [k].
   if atom k then
      !*a2k {'d,k,1}
   else
      !*a2k {'d,cadr k,caddr k + 1};


switch kacem;    % DO NOT SWITCH ON
switch dcfsfold; % DO NOT SWITCH ON

procedure dcfsf_qe(f,theo);
   % Quantifier elimination. [f] is a formula, [theo] is a theory.
   % Returns a quantifier-free formula. The result is equivalent to [f]
   % wrt. [theo].
   if !*kacem then
      dcfsf_qe!-kacem(f,theo)
   else
      dcfsf_qe0(f,theo);

procedure dcfsf_qe!-kacem(f,theo);
   % DO NOT USE.
   begin scalar w;
      f := rl_prepfof f;
      f := cl_pnf f;
      w := dqe_start1 f;
      if w eq t then
	 w := 'true
      else if null w then
	 w := 'false;
      w := rl_simp w;
      return w
   end;

procedure dcfsf_qe0(f,theo);
   % Quantifier elimination entry point. [f] is a formula, [theo] is a
   % theory. Returns a quantifier-free formula. The result is equivalent
   % to [f] wrt. [theo].
   begin scalar w,bl;
      f := cl_simpl(cl_pnf cl_nnf f,theo,-1);
      w := cl_splt f;
      bl := car w;
      f := cadr w;
      for each blk in bl do
	 f := cl_simpl(dcfsf_qeblk(f,blk,theo),theo,-1);
      return f
   end;

procedure dcfsf_qeblk(f,blk,theo);
   % Quantifier elimination for one block. [f] is a quantifier-free
   % formula; [blk] is a QBLK (see clmisc); [theo] is a theory. Returns
   % a quantifier-free formula equivalent to $[blk] [f]$ wrt. [theo].
   if car blk eq 'all then
      rl_nnfnot dcfsf_qeblk1(rl_nnfnot f,blk,theo)
   else
      dcfsf_qeblk1(f,blk,theo);

procedure dcfsf_qeblk1(f,blk,theo);
   % Quantifier elimination for one block subroutine. [f] is a
   % quantifier-free formula; [blk] is a QBLK (see clmisc); [theo] is a
   % theory. Returns a quantifier-free formula equivalent to $[blk] [f]$
   % wrt. [theo].
   <<
      if !*rlverbose then
	 ioto_tprin2t {"Eliminating ",blk};
      for each v in cdr blk do
	 f := if !*dcfsfold then
      	    dcfsf_qevarold(f,v,theo)
	 else
	    dcfsf_qevar(f,v,theo);
      f
   >>;

procedure dcfsf_qevar(phi,v,theo);
   % Quantifier elimination for one variable. [f] is a quantifier-free
   % formula; [v] is a variable considered existentially quantified;
   % [theo] is a theory. Returns a quantifier-free formula. The result
   % is equivalent to $\exists [v] [f]$ wrt. [theo].
   begin scalar kl,oo,pll,!*rlsifacne;
      if !*rlverbose then
	 ioto_tprin2t {"Eliminating ",v};
      phi := cl_dnf cl_simpl(phi,theo,-1);
      if rl_tvalp phi then
	 return phi;
      kl := dcfsf_mkkl(v,dcfsf_maxorder(cl_terml phi,v));
      oo := setkorder kl;
      phi := cl_apply2ats(phi,function(dcfsf_reorderat));
      pll := dcfsf_dnf2pll(phi,v,theo);
      if !*rlverbose then
	 ioto_tprin2t "Computing ENF";
      pll := dcfsf_enf1(pll,v,theo);
      if !*rlverbose then
	 ioto_tprin2t "Eliminating base cases";
      phi := dcfsf_elim(pll,v,theo);
      if !*rlverbose then
	 ioto_tprin2t "Final simplification";
      setkorder oo;
      phi := cl_apply2ats(phi,function(dcfsf_reorderat));
      phi := rl_simpl(phi,theo,-1);
      return phi
   end;

procedure dcfsf_elim(pll,v,theo);
   begin integer enf1len;
      if !*rlverbose then
	 enf1len := pll_length pll + 1;
      return rl_smkn('or,for each pl in pll_2l pll collect <<
	 enf1len := enf1len - 1;
   	 dcfsf_elim1(pl,v,theo,enf1len)>>)
   end;

procedure dcfsf_elim1(pl,v,theo,left);
   begin scalar veql,vnel,oeql,onel,argl,f,i,g,rmd,of,og,df,dg,r;
      {veql,vnel,oeql,onel} := pl_2l pl;
      % The following three conditions cannot occur provided that the
      % code is correct:
      if veql and cdr veql then
	 rederr {"dcfsf_elim1: more than one equation in ",v};
      if vnel and cdr vnel then
	 rederr {"dcfsf_elim1: more than one inequality in ",v};
      if null vnel then
	 rederr {"dcfsf_elim1: no inequality in ",v};
      argl := dcfsf_oatl(oeql,onel);
      if not veql then <<
	 % no equation, only (one) inequality
	 if !*rlverbose then ioto_prin2 {"[",left,":C1] "};
	 return rl_smkn('and,dcfsf_bc1(car vnel,v,theo) . argl)
      >>;
      if domainp car vnel and not null car vnel then <<
	 % no inequality, only (one) equation
	 if !*rlverbose then ioto_prin2 {"[",left,":C2] "};
	 %%	 return rl_smkn('and,dcfsf_bc2(car veql,v,theo) . argl)
      	 % The following condition cannot occur provided that the code is
      	 % correct:
	 i := lc car veql;
	 if not (domainp i and not null i or member(sfto_sqfpartf i,onel)) then
	    rederr {"dcfsf_elim1: no initial inequality for equation"};
	 return rl_smkn('and,argl)
      >>;
      % We now know that there is one equation and one inequality.
      f := car veql;
      i := lc f;
      g . rmd := qremf(car vnel,i);
      % The following condition cannot occur provided that the code is
      % correct:
      if rmd then
	 rederr {"dcfsf_elim1: lhs of inequality is not divisible by I_f"};
      of . df := dcfsf_orddegf(f,v);
      og . dg := dcfsf_orddegf(g,v);
      if og < of then <<
	 if !*rlverbose then ioto_prin2 {"[",left,":C3] "};
	 return rl_smkn('and,dcfsf_bc3(i,g,v,theo) . argl)
      >>;
      if og = of and dg < df then <<
	 if !*rlverbose then ioto_prin2 {"[",left,":C4] "};
	 r := car dcfsf_reduce({exptf(g,df)},f,v);
	 return rl_smkn('and,dcfsf_bc3(i,r,v,theo) . argl)
      >>;
      rederr {"dcfsf_elim1: ord(g) = ord(f) and deg(g) >= deg(f)"}
   end;

procedure dcfsf_oatl(oeql,onel);
   begin scalar atl;
      for each one in onel do
 	 atl := dcfsf_0mk2('neq,one) . atl;
      for each oeq in oeql do
 	 atl := dcfsf_0mk2('equal,oeq) . atl;
      return atl
   end;

procedure dcfsf_bc1(g,v,theo);
   % Base Case 1
   rl_smkn('or,for each gt in dcfsf_cl(g,v) collect dcfsf_0mk2('neq,gt));

procedure dcfsf_bc2(f,v,theo);
   % Base Case 2
   begin scalar ftl,f1;
      ftl . f1 := dcfsf_cl1(f,v);
      return rl_smkn('or,dcfsf_0mk2('equal,f1) .
	 for each gt in ftl collect dcfsf_0mk2('neq,gt))
   end;

procedure dcfsf_bc3(i,g,v,theo);
   % Base Case 3
   begin scalar iff,w1,w2;
      w1 := for each gt in dcfsf_cl(g,v) collect
	 dcfsf_0mk2('neq,gt);
      w2 := for each ct in dcfsf_cl(i,v) collect
	 dcfsf_0mk2('neq,ct);
      return rl_mkn('and,{rl_smkn('or,w1),rl_smkn('or,w2)})
   end;

procedure dcfsf_qevarold(f,v,theo);
   % Quantifier elimination for one variable. [f] is a quantifier-free
   % formula; [v] is a variable considered existentially quantified;
   % [theo] is a theory. Returns a quantifier-free formula. The result
   % is equivalent to $\exists [v] [f]$ wrt. [theo].
   begin scalar rl;
      if !*rlverbose then
	 ioto_tprin2t {"Eliminating ",v};
      f := cl_dnf f;
      rl := if rl_op f eq 'or then
      	 for each ff in rl_argn f collect
	    dcfsf_qevar1(ff,v,theo)
      else
	 {dcfsf_qevar1(f,v,theo)};
      return rl_smkn('or,rl)
   end;

procedure dcfsf_qevar1(f,v,theo);
   % Quantifier elimination for one variable subroutine. [f] is a
   % conjunction of atomic formulas or an atomic formula or a truth
   % value; [v] is a variable considered existentially quantified;
   % [theo] is a theory. Returns a quantifier-free formula. The result
   % is equivalent to $\exists [v] [f]$ wrt. [theo].
   begin scalar r,w;
      if rl_tvalp f then
	 return f;
      w := dcfsf_nf(f,v);
      r := dcfsf_qevar2(car w,cadr w,v,theo);
      r := rl_mkn('and,{rl_smkn('and,caddr w),r});
      return r
   end;

procedure dcfsf_nf(f,v);
   % Normal form. [f] is a conjunction of atomic formulas or an atomic
   % formula; [v] is a variable. Returns a triplet $([e],[n],[s|)$,
   % where [e] is a list of standard forms, [n] is a standard form, and
   % [s] is a list of atomic formulas. [e] is the list of all left hand
   % sides of equations containing [v] in [f], [n] is the product of all
   % left hand side of inequalities containing [v] in [f], and [s] is
   % the list of all atomic formulas not containing [v] in [f].
      if rl_op f eq 'and then
	 dcfsf_nf1(rl_argn f,v)
      else
	 dcfsf_nf1({f},v);

procedure dcfsf_nf1(f,v);
   % Normal form subroutine. [f] is a list of atomic formulas; [v] is a
   % variable. Returns a triplet $([e],[n],[s|)$, where [e] is a list of
   % standard forms, [n] is a standard form, and [s] is a list of atomic
   % formulas. [e] is the list of all left hand sides of equations
   % containing [v] in [f], [n] is the product of all left hand side of
   % inequalities containing [v] in [f], and [s] is the list of all
   % atomic formulas not containing [v] in [f].
   begin scalar e,n,s;
      n := numr simp 1;
      for each at in f do
	 if not(v memq dcfsf_varlat at) then
	    s := at . s
	 else if dcfsf_op at eq 'equal then
	    e := dcfsf_arg2l(at) . e
	 else
	    n := multf(dcfsf_arg2l at,n);
      return {e,n,s}
   end;


procedure dcfsf_qevar2(fl,g,v,theo);
   % Quantifier elimination for one variable subroutine. [f] is a list
   % of standard forms, [g] is a standard form, [v] is a variable,
   % [theo] is a theory. Returns a quantifier-free formula. The result
   % is equivalent to $\exists [v] (\bigwedge_{f \in [fl]} f=0 \land g
   % \neq 0)$ wrt. [v]. Old comment: "Special case on page 5."
   begin scalar oo,kl,r;
      kl := dcfsf_mkkl(v,dcfsf_maxorder(g . fl,v));
      oo := setkorder kl;
      fl := for each f in fl collect reorder f;
      g := reorder g;
      r := dcfsf_qesc5(fl,g,v,theo,t);
      setkorder oo;
      return cl_apply2ats(r,'dcfsf_reorderat)
   end;

procedure dcfsf_reorderat(a);
   % Reorder atomic formula. [a] is an atomic formula. Returns an atomic
   % formula reorders the left hand side of a wrt. the current kernel
   % order.
   if rl_tvalp a then
      a
   else
      dcfsf_0mk2(dcfsf_op a,reorder dcfsf_arg2l a);

procedure dcfsf_maxorder(fl,v);
   % Maximal order. [fl] is a list of standard forms; [v] is variable.
   % Returns a number. The result is the maximum of the orders wrt. [v]
   % of the differential polynomials in [fl].
   begin scalar w; integer m;
      for each f in fl do <<
	 w := dcfsf_orddegf(f,v);
	 if car w > m then
	    m := car w
      >>;
      return m
   end;

procedure dcfsf_mkkl(v,m);
   % Make kernel list. [v] is a variable; [m] is a non-negative integer.
   % Returns a list of (composite) kernels. The result is
   % $([v],[v]',[v]'',...,[v]^{(m)})$.
   reversip(v . for i := 1 : m collect !*a2k {'d,v,i});

procedure dcfsf_qesc5(fl,g,v,theo,elim);
   if elim then
      dcfsf_qesc5!-elim(fl,g,v,theo)
   else
      dcfsf_qesc5!-noelim(fl,g,v,theo);

procedure dcfsf_qesc5!-elim(fl,g,v,theo);
   % Special case on page 5.
   <<
      fl := sort(fl,'dcfsf_qeordp!-desc);
      if !*rlverbose then
	 ioto_prin2 {"[",length fl,dcfsf_orddegf(lastcar fl,v),"] "};
      if null fl then
	 % CASC Base Case 2
	 dcfsf_qesc1(g,v,theo)
      else if null cdr fl then
	 % m=1: CASC Recursion Subcases 2.1 and 2.2
	 dcfsf_qebasis(car fl,g,v,theo)
      else
	 % m>1: CASC Recursion Subcase 2.3
      	 dcfsf_qesc5r(fl,g,v,theo,t)
   >>;

procedure dcfsf_qesc5!-noelim(fl,g,v,theo);
   % Special case on page 5.
   <<
      fl := sort(fl,'dcfsf_qeordp!-desc);
      if !*rlverbose then
	 ioto_prin2 {"[",length fl,dcfsf_orddegf(lastcar fl,v),"] "};
      if null fl then
	 dcfsf_0mk2('neq,g)
      else if null cdr fl then
	 rl_mkn('and,{dcfsf_0mk2('equal,car fl),dcfsf_0mk2('neq,g)})
      else
      	 dcfsf_qesc5r(fl,g,v,theo,nil)
   >>;

procedure dcfsf_qesc50(fl,g,v,theo,elim);
   % Essentially CASC Recursion Case 1
   begin scalar nfl,r,f,pl;
      if null g then
	 return 'false;
      if domainp g then
	 g := 1;
      while fl do <<
	 f := pop fl;
	 if domainp f then <<
	    if f then <<
	       r := 'false;
	       fl := nil
	    >>
	 >> else if not(v memq dcfsf_varlat1 kernels f) then
	    pl := dcfsf_0mk2('equal,f) . pl
	 else
	    nfl := f . nfl;
      >>;
      if r eq 'false then
	 return 'false;
      r := dcfsf_qesc5(nfl,g,v,theo,elim);
      r := rl_mkn('and,{rl_smkn('and,pl),r});
      return r
   end;

procedure dcfsf_qeordp!-desc(f1,f2);
   % Order predicate. [f1] and [f2] are SFs. Returns Bool. The result is
   % non-[nil] iff [f1] > [f2] wrt. to lexicographically considering
   % (order, degree). That is, the order is the principle criterion.
   begin scalar p1,p2,v;
      v := dcfsf_mvar f1;
      p1 := dcfsf_orddegf(f1,v);
      p2 := dcfsf_orddegf(f2,v);
      return car p1 > car p2 or car p1 = car p2 and cdr p1 > cdr p2
   end;

procedure dcfsf_qebasis(f1,g,v,theo);
   if null g then
      % CASC Base Case 1
      'false
   else if domainp g then
      % CASC Base Case 3
      dcfsf_qesc2(f1,v,theo)
   else if dcfsf_ordf(g,v) leq dcfsf_ordf(f1,v) then
      % CASC Recursion Subcase 2.1
      dcfsf_qebasis1(f1,g,v,theo)
   else
      % CASC Recursion Subcase 2.2
      dcfsf_qebasis2(f1,g,v,theo);

switch dzopt;

procedure dcfsf_qebasis1(f1,g,v,theo);
   % CASC Recursion Subcase 2.1
   begin scalar phi1p,phi2p;
      if !*dzopt and null cdr qremf(g,lc f1) then <<
	 phi1p := 'false;
	 phi2p := dcfsf_qesc(f1,lc f1,g,v,theo);
      >> else <<
      	 phi1p := dcfsf_qesc50({red f1,lc f1},g,v,theo,t);
	 phi1p := cl_simpl(phi1p,theo,-1);
      	 if phi1p eq 'true then
	    return 'true;
      	 phi2p := dcfsf_qesc(f1,lc f1,g,v,theo);
      >>;
      return cl_simpl(rl_mkn('or,{phi1p,phi2p}),theo,-1);
   end;

procedure dcfsf_qebasis2(f1,g,v,theo);
   % CASC Recursion Subcase 2.2
   begin scalar psi,sp,s1,sf1,if1,qr,r,dp,phi1p,phi3p,r;
      if1 := lc f1;
      sp := dcfsf_ordf(g,v);
      s1 := dcfsf_ordf(f1,v);
      sf1 := dcfsf_separant f1;
      dp := dcfsf_degf(g,v);
      qr := qremf(multf(exptf(sf1,dp),g),dcfsf_dn(f1,sp-s1,v,theo));
      r := cdr qr;
      if !*dzopt and null cdr qremf(g,lc f1) then <<
	 if1 := 1;
	 phi1p := 'false;
      >> else
      	 phi1p := dcfsf_qesc50({red f1,lc f1},g,v,theo,t);
      phi1p := cl_simpl(phi1p,theo,-1);
      if phi1p eq 'true then
	 return 'true;
      if dcfsf_degf(f1,v) > 1 then <<
      	 psi := dcfsf_qebasis(f1,multf(multf(sf1,if1),r),v,theo);
      	 phi3p := dcfsf_qesc50({f1,sf1},g,v,theo,t);
	 r := rl_mkn('or,{phi1p,psi,phi3p});
      >> else <<
      	 psi := dcfsf_qebasis(f1,multf(if1,r),v,theo);
	 r := rl_mkn('or,{phi1p,psi})
      >>;
      return r
   end;

procedure dcfsf_mvar(f);
   % Main variable. [f] is an SF. Returns an identifier. The result is
   % the leading variable, in contrast to leading kernel, of [f] or
   % [nil] if [f] is a domain element.
   if domainp f then
      nil
   else if eqcar(mvar f,'d) then
      cadr mvar f
   else
      mvar f;

procedure dcfsf_separant(f);
   % Separant. [f] is an SF. Returns an SF. The result is the separant
   % of [f].
   dcfsf_df(f,mvar f);

procedure dcfsf_qesc5r(fl,g,v,theo,elim);
   % CASC Recursion Case 2, phi1
   begin scalar phi1p,phi2p,fm,ffl;
      ffl := reverse fl;
      fm := car ffl;
      if !*dzopt and null cdr qremf(g,lc fm) then
	 phi1p := 'false
      else
      	 phi1p := dcfsf_qesc50(red fm . lc fm . cdr ffl,g,v,theo,elim);
      phi2p := dcfsf_qesc5r2(fl,g,v,theo,elim);
      ioto_tprin2t "fl:";
      mathprint('list . for each f in fl collect prepf f);
      ioto_tprin2t "phi1':";
      mathprint rl_prepfof cl_simpl(phi1p,nil,-1);
      ioto_tprin2t "phi2':";
      mathprint rl_prepfof cl_simpl(phi2p,nil,-1);
      ioto_tprin2t "----------------------------------------";
      return rl_mkn('or,{phi1p,phi2p})
   end;

procedure dcfsf_qesc5r2(fl,g,v,theo,elim);
   % CASC Recursion Case 2, phi2
   begin scalar ffl,fm,fm1;
      ffl := reverse fl;
      fm := pop ffl;
      fm1 := pop ffl;
      if dcfsf_ordf(fm,v) = dcfsf_ordf(fm1,v) then
	 return dcfsf_qesc5r2u1(fm,fm1,ffl,g,v,theo,elim);
      return dcfsf_qesc5r2u2(fm,fm1,ffl,g,v,theo,elim)
   end;

procedure dcfsf_qesc5r2u1(fm,fm1,ffl,g,v,theo,elim);
   begin scalar dm1,ifm,qr,r,psip;
      dm1 := dcfsf_degf(fm1,v);
      ifm := lc fm;
      qr := qremf(multf(exptf(ifm,dm1),fm1),fm);
      r := cdr qr;
      if !*dzopt and null cdr qremf(g,lc fm) then
	 psip := dcfsf_qesc50(fm . r . ffl,g,v,theo,elim)
      else
      	 psip := dcfsf_qesc50(fm . r . ffl,multf(ifm,g),v,theo,elim);
      return psip
   end;

procedure dcfsf_qesc5r2u2(fm,fm1,ffl,g,v,theo,elim);
   begin scalar sfm,dm1,qr,r,sm,sm1,psip,ifm;
      sfm := dcfsf_separant fm;
      dm1 := dcfsf_degf(fm1,v);
      sm := dcfsf_ordf(fm,v);
      sm1 := dcfsf_ordf(fm1,v);
      ifm := lc fm;
      qr := qremf(multf(exptf(sfm,dm1),fm1),
	 dcfsf_dn(fm,sm1-sm,v,theo));
      r := cdr qr;
      if !*dzopt and null cdr qremf(g,lc fm) then
      	 psip := dcfsf_qesc50(fm . r . ffl,g,v,theo,elim)
      else
%      	 psip := dcfsf_qesc50(fm . r . ffl,multf(ifm,g),v,theo,elim);
      	 psip := dcfsf_qesc50(fm . r . ffl,multf(sfm,g),v,theo,elim);
      return psip
   end;

procedure dcfsf_dn(f,n,v,theo);
   % Derivate n times. [f] is an SF, [n] is a number, [v] is an
   % identifier, [theo] is a theory. Returns an SF. Dynamically extends
   % the current kernel order in such a way that all existing SFs remain
   % valid.
   begin scalar r,s,m;
      m := if kord!* and pairp car kord!* and car car kord!* eq 'd then
	 caddr car kord!* else 0;
      s := car dcfsf_orddegf(f,v);
      m := max(m,s+n);
      setkorder dcfsf_mkkl(v,m);
      r := reorder f;
      r := dcfsf_derivationf(r,n,theo);
      % I think the following reorder is not really necessary:
      return reorder r
   end;

procedure dcfsf_qesc1(g,v,theo);
   % CASC Base Case 2
   rl_smkn('or,for each gt in dcfsf_cl(g,v) collect dcfsf_0mk2('neq,gt));

procedure dcfsf_cl(f,v);
   % Coefficient list. [f] is an SF; [v] is an identifier. Returns a
   % list of SFs. The result is the list of coefficients of [f] as a
   % differential polynomial in [v].
   if domainp f or not(v memq dcfsf_varlat1 kernels f) then
      {f}
   else
      nconc(dcfsf_cl(lc f,v),dcfsf_cl(red f,v));

procedure dcfsf_cl1(f,v);
   % Coefficient list variant. [f] is an SF; [v] is an identifier.
   % Returns a pair $a . d$, where $a$ is a list of SFs and $d$ is an
   % SF. In the result $d$ is absolute summand of [f] as a differential
   % polynomial in [v], and $a$ is the list of all other coefficients.
   dcfsf_cl2(f,v,T);

procedure dcfsf_cl2(f,v,flg);
   begin scalar w;
      if domainp f or not(v memq dcfsf_varlat1 kernels f) then
      	 return if flg then
	    nil . f
      	 else
      	    {f} . nil
      else <<
	 w := dcfsf_cl2(red f,v,T);
      	 return nconc(car dcfsf_cl2(lc f,v,nil),car w) . cdr w
      >>
   end;

procedure dcfsf_qesc(f1,if1,g,v,theo);
   begin
      if null g or null if1 then
      	 return 'false;
      if domainp if1 then
      	 if1 := 1;
      if g = 1 and not(v memq dcfsf_varlat1 kernels if1) then
      	 return rl_mkn('and,{dcfsf_0mk2('neq,if1),dcfsf_qesc2(f1,v,theo)});
      if dcfsf_ordf(g,v) < dcfsf_ordf(f1,v) then
      	 return dcfsf_qesc3(f1,g,if1,v,theo);
      return dcfsf_qesc4(f1,g,if1,v,theo)
   end;

procedure dcfsf_qesc2(f,v,theo);
   % CASC Base Case 3
   begin scalar ftl,f1;
      ftl . f1 := dcfsf_cl1(f,v);
      return rl_smkn('or,dcfsf_0mk2('equal,f1) .
	 for each gt in ftl collect dcfsf_0mk2('neq,gt))
   end;

procedure dcfsf_qesc3(f,g,iff,v,theo);
   begin scalar iff,w1,w2;
      w1 := for each gt in dcfsf_cl(g,v) collect
	 dcfsf_0mk2('neq,gt);
      w2 := for each ct in dcfsf_cl(lc f,v) collect
	 dcfsf_0mk2('neq,ct);
      return rl_mkn('and,{rl_smkn('or,w1),rl_smkn('or,w2)})
   end;

procedure dcfsf_qesc4(f,g,iff,v,theo);
   begin scalar qr,dd,dp,w1,w2,r,s;
      dd := dcfsf_degf(f,v);
      dp := dcfsf_degf(g,v);
      s := dcfsf_ordf(f,v);
      qr := qremf(multf(exptf(lc f,dd*dp),exptf(g,dd)),f);
      r := cdr qr;
      w1 := for each ct in dcfsf_cl(lc f,v) collect
	 dcfsf_0mk2('neq,ct);
      w2 := for each rt in dcfsf_cl(r,v) collect
	 dcfsf_0mk2('neq,rt);
      return rl_mkn('and,{rl_smkn('or,w1),rl_smkn('or,w2)})
   end;

procedure dcfsf_1equation(f,v,theo);
   begin scalar fl,gl,g,oo,kl,r,!*rlsiexpla;
      f := cl_simpl(f,theo,-1);
      if rl_op f neq 'and then
	 rederr {"dcfsf_1equation:",f,"is not a conjunction"};
      g := 1;
      for each at in rl_argn f do
	 if rl_op at eq 'equal then
	    fl := dcfsf_arg2l at . fl
	 else if rl_op at eq 'neq then
	    g := multf(g,dcfsf_arg2l at)
	 else
	    rederr {"dcfsf_1equation:",at,"is not an atomic formula"};
      kl := dcfsf_mkkl(v,dcfsf_maxorder(g . fl,v));
      oo := setkorder kl;
      fl := for each f in fl collect reorder f;
      g := reorder g;
      r := dcfsf_qesc5(fl,g,v,nil,nil);
      setkorder oo;
      r := cl_apply2ats(r,'dcfsf_reorderat);
      r := cl_simpl(cl_dnf r,theo,-1);
      return r
   end;

%DS
%  ::= {, ...};  considered as a disjunction
%  ::= {, , , };  considered as a conjunction
%  ::= {, ...};  left hand sides of equations containing v
%  ::= {};  product of left hand sides of inequalities containing v
%  ::= {, ...};  left hand sides of equations not containing v
%  ::= {, ...};  left hand sides of inequalities not containing v

put('!*rl_pl,'prifn,'pl_prifn);

put('!*rl_pll,'prifn,'pll_prifn);

procedure pll_new();
   {'!*rl_pll};

procedure pll_emptyp(pll);
   not cdr pll;

procedure pll_length(pll);
   length pll_2l pll;

macro procedure pll_pop(l);
   % A limited pop in the sense of ANSI Common Lisp. Admits only a
   % single identifier as its argument. A more sophisticated version
   % would evaluate the properties setqfn or assignop.
   begin scalar ll;
      if null cdr l or cddr l then
         rederr {"pop called with",length cdr l, "arguments instead of 1"};
      ll := cadr l;
      if not idp ll then
         typerr(ll,"identifier");
      return {'prog,{'a},
         {'setq,'a,{'cadr,ll}},
         {'rplacd,ll,{'cddr,ll}},
         {'return,'a}}
   end;

procedure pll_cons(pl,pll);
   rplacd(pll,lto_insert(pl,cdr pll));

procedure pll_fl(l);
   begin scalar pll;
      pll := pll_new();
      for each pl in l do
	 pll := pll_cons(pl,pll);
      return pll
   end;

procedure pll_prifn(pll);
   <<
      ioto_prin2 "";
      for each pl in pl_2l pll do
	 pl_prifn pl;
      ioto_prin2 "";
   >>;

procedure pll_2l(pll);
   cdr pll;

procedure pl_factorize(pl);
   % [pl] is a PL. Returns a PLL containing PLs to be inserted.
   begin scalar veql,vnel,oeql,onel,fveql,apll;
      pl := pl_sqfpart pl;
      pl := pl_simpl pl;
      if pl_falsep pl then
	 return pll_new();
      if not !*rlenffac then
      	 return pll_fl {pl};
      {veql,vnel,oeql,onel} := pl_2l pl;
      fveql := for each veq in veql collect
	 for each pr in cdr fctrf veq collect
	    car pr;
      apll := pll_new();
      for each pveql in lto_cartprod fveql do
	 apll := pll_cons(pl_new(list2set pveql,vnel,oeql,onel),apll);
      return apll
   end;

procedure pll_ins(apll,pll);
   <<
      for each pl in pll_2l apll do
	 pll := pll_cons(pl,pll);
      pll
   >>;

procedure pl_sqfpart(pl);
   begin scalar l,w;
      l := for each ll in pl_2l pl collect
	 for each f in ll collect
	    if domainp f then
	       f
	    else <<
	       w := sfto_sqfpartf f;
	       if minusf w then w := negf w;
	       w
	    >>;
      return pl_fl l
   end;

procedure pl_new(veql,vnel,oeql,onel);
   pl_fl {veql,vnel,oeql,onel};

procedure pl_2l(pl);
   cdr pl;

procedure pl_fl(l);
   '!*rl_pl . l;

procedure pl_prifn(pl);
   <<
      pop pl;
      ioto_prin2 "";
      pl_mapril pop pl;
      for i := 1:3 do <<
      	 ioto_prin2 ",";
      	 pl_mapril pop pl
      >>;
      ioto_prin2 ""
   >>;

procedure pl_mapril(l);
   <<
      ioto_prin2 "{";
      if l then <<
	 maprin prepf pop l;
      	 for each f in l do <<
	    ioto_prin2 ",";
	    maprin prepf f
      	 >>
      >>;
      ioto_prin2 "}"
   >>;

switch rlenfsimpl;
switch rlenf1twice;

procedure dcfsf_enf(phi,v,theo);
   % Elimination normal form. [phi] is a formula; [v] is an identifier;
   % [theo] is a theory. Returns a formula in DNF. The result is
   % equivalent to [phi].
   begin scalar kl,oo,pll,!*rlsiexpla,!*rlsifac,pll2,!*nat;
      if !*rlverbose then
	 ioto_tprin2t "Computing ENF";
      phi := cl_dnf cl_simpl(phi,theo,-1);
      if rl_tvalp phi or cl_atfp phi then
	 return phi;
      kl := dcfsf_mkkl(v,dcfsf_maxorder(cl_terml phi,v));
      oo := setkorder kl;
      phi := cl_apply2ats(phi,function(dcfsf_reorderat));
      pll := dcfsf_dnf2pll(phi,v,theo);
      if !*rlenf1twice then <<
      	 pll := dcfsf_enf1(pll,v,theo);
      	 pll2 := 'rl_pll!* . reverse cdr pll;
      	 pll2 := dcfsf_enf1(pll2,v,theo);
	 if pll2 neq pll then <<
	    lprim {"enf1 not idempotent here"};
	    terpri!* t;
	    mathprint pll;
	    mathprint pll2;
	    pll := pll2
	 >>
      >> else
      	 pll := dcfsf_enf1(pll,v,theo);
      phi := pll_2dnf pll;
      setkorder oo;
      phi := cl_apply2ats(phi,function(dcfsf_reorderat));
      if !*rlenfsimpl then
      	 phi := rl_simpl(phi,theo,-1);
      if !*rlverbose then
	 ioto_tprin2t "";
      return phi
   end;

procedure dcfsf_dnf2pll(phi,v,theo);
   % Disjunctive normal form to . [phi] is a formula in DNF; [v] is
   % an identifier; [theo] is a theory. Returns a .
   begin scalar pll,apll;
      phi := cl_mkstrict(phi,'or);
      pll := pll_new();
      for each conj in rl_argn phi do <<
	 apll := pl_factorize dcfsf_atl2pl(rl_argn conj,v);
	    pll := pll_ins(apll,pll)
      >>;
      return pll
   end;

procedure dcfsf_atl2pl(atl,v);
   % Atomic formula list to . [atl] is a list of atomic formulas;
   % [v] is an identifier. Returns a .
   begin scalar op,lhs,veql,vne,oeql,onel;
      vne := 1;
      for each at in atl do <<
	 op := rl_op at;
	 lhs := rl_arg2l at;
	 if op eq 'equal then
	    if dcfsf_mvar lhs eq v then
	       veql := lhs . veql
	    else
	       oeql := lhs . oeql
	 else if rl_op at eq 'neq then
	    if dcfsf_mvar lhs eq v then
	       vne := sfto_sqfpartf multf(lhs,vne)
	    else
	       onel := lhs . onel
	 else
	    rederr {"dcfsf_atl2pll: unexpected operator ",op}
      >>;
      return pl_new(veql,{vne},oeql,onel)
   end;

procedure pll_2dnf(pll);
   %  to DNF. [pll] is a . Returns a formula in DNF.
   rl_smkn('or,reversip for each pl in pll_2l pll collect
      rl_smkn('and,pl_2atl pl));

procedure pl_2atl(pl);
   %  to list of atomic formulas. [pl] is a . Returns a possibly
   % degenerate conjunction of atomic formulas.
   begin scalar veql,vnel,oeql,onel;
      pop pl;
      veql := pop pl;
      veql := for each f in veql collect dcfsf_0mk2('equal,f);
      vnel := pop pl;
      vnel := if !*rlenffacne then
	 for each f in cdr fctrf car vnel collect dcfsf_0mk2('neq,car f)
      else
	 {dcfsf_0mk2('neq,car vnel)};
      oeql := pop pl;
      oeql := for each f in oeql collect dcfsf_0mk2('equal,f);
      onel := pop pl;
      onel := for each f in onel collect dcfsf_0mk2('neq,f);
      return lto_nconcn {veql,vnel,oeql,onel}
   end;

procedure pl_simpl(pl);
   begin scalar veql,vnel,oeql,onel,a,brk,nveql,nvnel,noeql,nonel,w;
      if not !*rlplsimpl then
	 return pl;
      {veql,vnel,oeql,onel} := pl_2l pl;
      nveql := veql;
      nvnel := vnel;
      brk := nil; while oeql and not brk do <<
	 a := pop oeql;
	 if domainp a then
	    (if not null a then brk := t)
	 else
	    noeql := lto_insert(a,noeql)
      >>;
      if brk then
 	 return pl_false();
      noeql := reversip noeql;
      brk := nil; while onel and not brk do <<
	 a := pop onel;
	 if domainp a then
	    (if null a then brk := t)
	 else
	    nonel := lto_insert(a,nonel)
      >>;
      if brk then
 	 return pl_false();
      nonel := reversip nonel;
      pl := pl_new(nveql,nvnel,noeql,nonel);
      if cl_simpl(rl_smkn('and,pl_2atl pl),nil,-1) eq 'false then
	 return pl_false();
      return pl
   end;

procedure pl_false();
   '(!*rl_pl nil (1) (1) nil);

procedure pl_falsep(pl);
   pl = pl_false();

procedure dcfsf_enf1(pll,v,theo);
   % Elimination normal form subroutine. [pll] is a ; [v] is an
   % identifier; [theo] is a theory. Returns a . When interpreted
   % as a formula, the result is equivalent to [pll].
   begin scalar pl,veql,vnel,oeql,onel,npll,veq1,veql1_,i,r,s,o,d,apll,w;
      npll := pll_new();
      while not pll_emptyp pll do <<
	 if !*rlverbose then ioto_prin2 {"[",pll_length pll};
	 pl := pll_pop pll;
	 {veql,vnel,oeql,onel} := pl_2l pl;
	 veql := sort(veql,function dcfsf_qeordp);
	 if not veql then <<  % base case
	    if !*rlverbose then ioto_prin2 "] ";
	    npll := pll_ins({pl},npll)
	 >> else <<  % at least on equation in [v]
	    veq1 := car veql;
	    veql1_ := cdr veql;
	    if !*rlverbose then <<
	       o . d := dcfsf_orddegf(veq1,v);
	       ioto_prin2 {":(",o,",",d,")] "}
	    >>;
	    i := lc veq1;
	    r := red veq1;
	    s := dcfsf_separant veq1;
	    % Case 1: initial = 0
	    apll := pl_factorize dcfsf_enf1c1(i,r,veql1_,vnel,oeql,onel,v);
	    pll := pll_ins(apll,pll);
	    % Case 2: inital <> 0 and separant = 0
	    if ldeg veq1 neq 1 then <<
	       % otherwise there is nothing to do because initial = separant
	       apll := pl_factorize dcfsf_enf1c2(i,r,s,veql,vnel,oeql,onel,v);
	       pll := pll_ins(apll,pll)
	    >>;
	    % Case 3: initial <> 0 and separant <> 0
	    if veql1_ then <<
	       apll := pl_factorize
 		  dcfsf_enf1c3(i,s,veq1,veql1_,vnel,oeql,onel,v);
	       pll := pll_ins(apll,pll)
	    >> else << % "base case"
	       apll := pl_factorize
		     dcfsf_enf1c3b(i,s,veq1,veql,vnel,oeql,onel,v);
	       if (w := pll_2l apll) and cdr w then
		  pll := pll_ins(apll,pll)
	       else
	       	  npll := pll_ins(apll,npll)
	    >>
	 >>
      >>;
      return npll
   end;

procedure dcfsf_qeordp(f1,f2);
   % Order predicate. [f1] and [f2] are SFs. Returns Bool. The result is
   % non-[nil] iff [f1] < [f2] wrt. to lexicographically considering
   % (order, degree). That is, the order is the principle criterion.
   begin scalar p1,p2,v;
      v := dcfsf_mvar f1;
      p1 := dcfsf_orddegf(f1,v);
      p2 := dcfsf_orddegf(f2,v);
      return car p1 < car p2 or car p1 = car p2 and cdr p1 < cdr p2
   end;

procedure dcfsf_enf1c1(i,r,veql1_,vnel,oeql,onel,v);
   % Elimination normal form subroutine, Case 1: initial = 0. [i], [r]
   % are SFs; [veql1_], [vnel], [oeql], [onel] are s; [v] is an
   % identifier. Returns a .
   begin scalar veql1,oeql1;
      veql1 . oeql1 := dcfsf_inserteq(veql1_,oeql,r,v);
      veql1 . oeql1 := dcfsf_inserteq(veql1,oeql1,i,v);
      return pl_new(veql1,vnel,oeql1,onel)
   end;

procedure dcfsf_enf1c2(i,r,s,veql,vnel,oeql,onel,v);
   % Elimination normal form subroutine, Case 2: inital <> 0 and
   % separant = 0. [i], [r], [s] are SFs; [veql], [vnel], [oeql], [onel]
   % are ; [v] is an identifier. Returns a .
   begin scalar veql1,vnel1,oeql1,onel1;
      vnel1 . onel1 := dcfsf_insertne(vnel,onel,i,v);
      veql1 . oeql1 := dcfsf_reduceeq(veql,oeql,s,v);
      veql1 := lto_insert(s,veql1);
      vnel1 . onel1 := dcfsf_reducene(vnel1,onel1,s,v);
      return pl_new(veql1,vnel1,oeql1,onel1)
   end;

procedure dcfsf_enf1c3(i,s,veq1,veql1_,vnel,oeql,onel,v);
   % Elimination normal form subroutine, Case 3: inital <> 0 and
   % separant <> 0. [i], [s] are SFs; [veql], [vnel], [oeql], [onel] are
   % ; [v] is an identifier. Returns a .
   begin scalar veql1,vnel1,oeql1,onel1;
      vnel1 . onel1 := dcfsf_insertne(vnel,onel,i,v);
      vnel1 . onel1 := dcfsf_insertne(vnel1,onel1,s,v);
      vnel1 . onel1 := dcfsf_reducene(vnel1,onel1,veq1,v);
      veql1 . oeql1 := dcfsf_reduceeq(veql1_,oeql,veq1,v);
      veql1 := lto_insert(veq1,veql1);
      return pl_new(veql1,vnel1,oeql1,onel1)
   end;

procedure dcfsf_enf1c3b(i,s,veq1,veql,vnel,oeql,onel,v);
   % Elimination normal form subroutine, Case 3 base: inital <> 0 and
   % separant <> 0 and no more equations in [v]. [i], [s] are SFs;
   % [veql], [vnel], [oeql], [onel] are ; [v] is an identifier.
   % Returns a .
   begin scalar vnel1,onel1;
      vnel1 . onel1 := dcfsf_insertne(vnel,onel,i,v);
      vnel1 . onel1 := dcfsf_insertne(vnel1,onel1,s,v);
      vnel1 . onel1 := dcfsf_reducene(vnel1,onel1,veq1,v);
      return pl_new(veql,vnel1,oeql,onel1)
   end;

procedure dcfsf_reduceeq(fl,ofl,g,v);
   begin scalar w,vfl;
      w := dcfsf_reduce(fl,g,v);
      for each f in w do
	 vfl . ofl := dcfsf_inserteq(vfl,ofl,f,v);
      return vfl . ofl
   end;

procedure dcfsf_reducene(fl,ofl,g,v);
   begin scalar w,vfl;
      w := dcfsf_reduce(fl,g,v);
      vfl := {1};
      for each f in w do
	 vfl . ofl := dcfsf_insertne(vfl,ofl,f,v);
      return vfl . ofl
   end;

procedure dcfsf_reduce(fl,g,v);
   begin scalar of,df,og,dg,g1,w,vfl,ofl;
      og . dg := dcfsf_orddegf(g,v);
      w := for each f in fl collect <<
      	 of . df := dcfsf_orddegf(f,v);
      	 if of < og or (of = og and df < dg) then
	    f
	 else if eqn(of,og) then  % we know df >= dg
	    cdr qremf(multf(f,exptf(lc g,df-dg+1)),g)
	 else <<  % we know of > og
	    g1 := dcfsf_derivationf(g,of-og,nil);
	    cdr qremf(multf(f,exptf(lc g1,df)),g1)
	 >>
      >>;
      return w
   end;

procedure dcfsf_inserteq(vl,ol,f,v);
   if dcfsf_mvar f eq v then
      lto_insert(f,vl) . ol
   else
      vl . lto_insert(f,ol);

procedure dcfsf_insertne(vl,ol,f,v);
   if dcfsf_mvar f eq v then
      {sfto_sqfpartf multf(f,car vl)} . ol
   else
      vl . lto_insert(f,ol);

endmodule;  % [dcfsfqe]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/dcfsf/dcfsfmisc.red0000644000175000017500000001444611526203062025513 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: dcfsfmisc.red 67 2009-02-05 18:55:15Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2004-2009 Andreas Dolzmann and Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
% 

lisp <<
   fluid '(dcfsf_misc_rcsid!* dcfsf_misc_copyright!*);
   dcfsf_misc_rcsid!* :=
      "$Id: dcfsfmisc.red 67 2009-02-05 18:55:15Z thomas-sturm $";
   dcfsf_misc_copyright!* := "Copyright (c) 2004-2009 A. Dolzmann and T. Sturm"
>>;

module dcfsfmisc;
% Differentially closed field standard form miscellaneous. Submodule
% of [dcfsf].

procedure dcfsf_termprint(u);
   % Differentialally closed field term print. [u] is a
   % term. The return value is not specified. Prints [u] AM-like.
   <<
      sqprint !*f2q u where !*nat=nil;
      ioto_prin2 nil
   >>;

procedure dcfsf_clnegrel(r,flg);
   % Differentialally closed field conditionally logically negate
   % relation. [r] is a relation. Returns for [flg] equal to [nil] a
   % relation $R$ such that for terms $t_1$, $t_2$ we have
   % $R(t_1,t_2)$ equivalent to $\lnot [r](t_1,t_2)$. Returns [r] for
   % non-[nil] [flg].
   if flg then r else dcfsf_lnegrel r;

procedure dcfsf_lnegrel(r);
   % Differentialally closed field logically negate relation. [r] is a
   % relation. Returns a relation $R$ such that for terms $t_1$, $t_2$
   % we have $R(t_1,t_2)$ equivalent to $\lnot [r](t_1,t_2)$.
   if r eq 'equal then 'neq
   else if r eq 'neq then 'equal
   else rederr {"dcfsf_lnegrel: unknown operator ",r};

procedure dcfsf_fctrat(atf);
   % Differentialally closed field factorize atomic formula. [atf] is an
   % atomic formula. Returns the factorized left hand side of [atf] as
   % a list $(...,(f_i . n_i),...)$, where the $f_i$ are the factors
   % as SF's and the $n_i$ are the corresponding multiplicities. The
   % integer content is dropped.
   cdr fctrf dcfsf_arg2l atf;

procedure dcfsf_negateat(f);
   % Differentialally closed field negate atomic formula. [f] is an
   % atomic formula. Returns an atomic formula equivalent to $\lnot
   % [f]$.
   dcfsf_mkn(dcfsf_lnegrel dcfsf_op f,dcfsf_argn f);

procedure dcfsf_varlat(atform);
   % Differentialally closed field variable list of atomic formula.
   % [atform] is an atomic formula. Returns the set of variables
   % contained in [atform] as a list.
   dcfsf_varlat1 kernels dcfsf_arg2l(atform);

procedure dcfsf_varlat1(kl);
   foreach k in kl join
      if pairp k and car k eq 'd then
	  {cadr k}
      else
	 {k};

procedure dcfsf_varsubstat(atf,new,old);
   % Differentialally closed substitute variable for variable in atomic
   % formula. [atf] is an atomic formula; [new] and [old] are
   % variables. Returns [atf] with [new] substituted for [old].
   dcfsf_0mk2(dcfsf_op atf,numr subf(dcfsf_arg2l atf,{old . new}));

procedure dcfsf_ordatp(a1,a2);
   % Differentialally closed field order predicate for atomic formulas.
   % [a1] and [a2] are atomic formulas. Returns [T] iff [a1] is
   % strictly less than [a2] wrt. some syntactical ordering; returns
   % [nil] else. The specification that [nil] is returned if
   % $[a1]=[a2]$ is used in [dcfsf_subsumeandcut].
   begin scalar lhs1,lhs2;
      lhs1 := dcfsf_arg2l a1;
      lhs2 := dcfsf_arg2l a2;
      if lhs1 neq lhs2 then return ordp(lhs1,lhs2);
      return dcfsf_ordrelp(dcfsf_op a1,dcfsf_op a2)
   end;

procedure dcfsf_ordrelp(r1,r2);
   % Differentialally closed field standard form relation order
   % predicate. [r1] and [r2] are dcfsf-relations. Returns a [T] iff
   % $[r1] <= [r2]$.
   r1 eq r2 or r1 eq 'equal;

procedure dcfsf_subalchk(al);
   % Differentialally closed field substitution ALIST check. [al] is
   % an ALIST $(..., (v_i . t_i), ...)$, where the $v_i$ are kernels,
   % and the $t_i$ are Lisp prefix terms. The return value is
   % unspecified. Raises an error if some $t_i$ contains a parametric
   % denominator.
   for each x in al do
      if not domainp denr simp cdr x then
	 rederr "parametric denominator in substituted term"
      else if not idp car x then
	 typerr({"expression ",car x},"variable") where !*nat=nil;

procedure dcfsf_eqnrhskernels(x);
   % Differentialally closed field equation right hand side kernels.
   % [x] is an equation. Returns the set of kernels contained in the
   % right hand side of [x] as a list.
   nconc(kernels numr w,kernels denr w) where w=simp cdr x;

procedure dcfsf_subat(al,f);
   % Differentialally closed field substitute into atomic formula.
   % [al] is an ALIST $(..., (v_i . t_i), ...)$, where the $v_i$ are
   % kernels, and the $t_i$ are Lisp prefix terms; [f] is an atomic
   % formula. Returns [f] with $t_i$ substituted for each occurrence
   % of $v_i$. The $t_i$ must be such that the substitution does not
   % yield parametric denominators.
   begin scalar nlhs;
      nlhs := subf(dcfsf_arg2l f,al);
      if not domainp denr nlhs then
	 rederr "parametric denominator after substitution";
      return dcfsf_0mk2(acfsf_op f,numr nlhs)
   end;

endmodule;  % [dcfsfmisc]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/dcfsf/dcfsf.red0000644000175000017500000002463411526203062024637 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: dcfsf.red 981 2010-12-02 21:40:09Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2004-2009 A. Dolzmann, 2004-2010 T. Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(dcfsf_rcsid!* dcfsf_copyright!*);
   dcfsf_rcsid!* := "$Id: dcfsf.red 981 2010-12-02 21:40:09Z thomas-sturm $";
   dcfsf_copyright!* := "(c) 2004-2009 A. Dolzmann, 2004-2010 T. Sturm"
>>;

module dcfsf;
% Diferentially closed field standard form. Main module. Algorithms on
% first-order formulas over diferentially closed fields. The language
% contains binary relations ['equal], ['neq], ring operations and a
% binary derivative operator ['d].

create!-package('(dcfsf dcfsfmisc dcfsfqe dcfsfsism dcfsfkacem),nil);

load!-package 'rltools;
load!-package 'cl;
remflag('(load!-package),'eval);  % for bootstrapping
load!-package 'cgb;
flag('(load!-package),'eval);
load!-package 'acfsf;

exports dcfsf_simpterm,dcfsf_prepat,dcfsf_resimpat,dcfsf_lengthat,
   dcfsf_chsimpat,dcfsf_simpat,dcfsf_op,dcfsf_arg2l,dcfsf_arg2r,dcfsf_argn,
   dcfsf_mk2,dcfsf_0mk2,dcfsf_mkn,dcfsf_opp;

imports rltools,cl,cgb;

fluid '(!*rlsiatadv !*rlsiexpl !*rlsiexpla !*rlgssub !*rlsiso !*rlgsrad
   !*rlgsred !*rlgsprod !*rlgserf !*rlverbose !*rlsifac !*rlbnfsac !*rlgsvb
   !*rlgsbnf !*rlgsutord !*rlnzden !*rladdcond !*rlqegen !*cgbgen !*cgbreal
   !*gbverbose dcfsf_gstv!* !*cgbverbose !*groebopt !*nat !*rlsid
   !*rlsiplugtheo !*rlenffac !*rlenffacne !*rlplsimpl);

flag('(dcfsf),'rl_package);

% Parameters
put('dcfsf,'rl_params,'(
   (rl_subat!* . dcfsf_subat)
   (rl_subalchk!* . dcfsf_subalchk)
   (rl_eqnrhskernels!* . dcfsf_eqnrhskernels)
   (rl_ordatp!* . dcfsf_ordatp)
   (rl_simplat1!* . acfsf_simplat1)
   (rl_smupdknowl!* . dcfsf_smupdknowl)
   (rl_smrmknowl!* . dcfsf_smrmknowl)
   (rl_smcpknowl!* . dcfsf_smcpknowl)
   (rl_smmkatl!* . dcfsf_smmkatl)
   (rl_smsimpl!-impl!* . cl_smsimpl!-impl)
   (rl_smsimpl!-equiv1!* . cl_smsimpl!-equiv1)
   (rl_negateat!* . dcfsf_negateat)
   (rl_varlat!* . dcfsf_varlat)
   (rl_varsubstat!* . dcfsf_varsubstat)
   (rl_subsumption!* . acfsf_subsumption)
   (rl_bnfsimpl!* . cl_bnfsimpl)
   (rl_sacat!* .acfsf_sacat)
   (rl_sacatlp!* . acfsf_sacatlp)
   (rl_fctrat!* . acfsf_fctrat)
   (rl_tordp!* . ordp)
   (rl_a2cdl!* . acfsf_a2cdl)
   (rl_t2cdl!* . acfsf_t2cdl)
   (rl_getineq!* . acfsf_getineq)
   (rl_structat!* . acfsf_structat)
   (rl_ifstructat!* . acfsf_ifstructat)
   (rl_termmlat!* . acfsf_termmlat)
   (rl_multsurep!* . acfsf_multsurep)
   (rl_fbqe!* . cl_fbqe)));

% Switches
put('dcfsf,'rl_cswitches,'(
   (rlsusi . nil)
));

% Services
put('dcfsf,'rl_services,'(
   (rl_subfof!* . cl_subfof)
   (rl_identifyonoff!* . cl_identifyonoff)
   (rl_simpl!* . cl_simpl)
   (rl_thsimpl!* . acfsf_thsimpl)
   (rl_nnf!* . cl_nnf)
   (rl_nnfnot!* . cl_nnfnot)
   (rl_pnf!* . cl_pnf)
   (rl_cnf!* . acfsf_cnf)
   (rl_dnf!* . acfsf_dnf)
   (rl_all!* . cl_all)
   (rl_ex!* . cl_ex)
   (rl_atnum!* . cl_atnum)
   (rl_qnum!* . cl_qnum)
   (rl_tab!* . cl_tab)
   (rl_atab!* . cl_atab)
   (rl_itab!* . cl_itab)
   (rl_gsc!* . acfsf_gsc)
   (rl_gsd!* . acfsf_gsd)
   (rl_gsn!* . acfsf_gsn)
   (rl_ifacl!* . cl_ifacl)
   (rl_ifacml!* . cl_ifacml)
   (rl_matrix!* . cl_matrix)
   (rl_apnf!* . cl_apnf)
   (rl_atml!* . cl_atml)
   (rl_tnf!* . cl_tnf)
   (rl_atl!* . cl_atl)
   (rl_struct!* . cl_struct)
   (rl_ifstruct!* . cl_ifstruct)
   (rl_termml!* . cl_termml)
   (rl_terml!* . cl_terml)
   (rl_varl!* . cl_varl)
   (rl_fvarl!* . cl_fvarl)
   (rl_bvarl!* . cl_bvarl)
   (rl_gentheo!* . cl_gentheo)
   (rl_decdeg!* . acfsf_decdeg)
   (rl_decdeg1!* . acfsf_decdeg1)
   (rl_surep!* . cl_surep)
   (rl_qe!* . dcfsf_qe)
   (rl_1equation!* . dcfsf_1equation)
   (rl_enf!* . dcfsf_enf)
   (rl_qeipo!* . cl_qeipo)
   (rl_siaddatl!* . cl_siaddatl)));

% Admin
put('dcfsf,'simpfnname,'dcfsf_simpfn);
put('dcfsf,'simpdefault,'dcfsf_simprel);

put('dcfsf,'rl_prepat,'dcfsf_prepat);
put('dcfsf,'rl_resimpat,'dcfsf_resimpat);
put('dcfsf,'rl_lengthat,'dcfsf_lengthat);

put('dcfsf,'rl_prepterm,'prepf);
put('dcfsf,'rl_simpterm,'dcfsf_simpterm);

algebraic infix equal;
put('equal,'dcfsf_simpfn,'dcfsf_chsimpat);
put('equal,'number!-of!-args,2);

algebraic infix neq;
put('neq,'dcfsf_simpfn,'dcfsf_chsimpat);
put('neq,'number!-of!-args,2);
put('neq,'rtypefn,'quotelog);
newtok '((!< !>) neq);

algebraic operator d;
put('d,'number!-of!-args,2);
put('d,'simpfn,'dcfsf_simpd);
%precedence d,**;

put('d,'prifn,'dcfsf_prid);

flag('(equal neq d),'spaced);
flag('(dcfsf_chsimpat),'full);

procedure dcfsf_prid(u);
   if not !*nat then
      'failed
   else <<
      maprin cadr u;
      for i:=1:caddr u do prin2!* "'"
   >>;

procedure dcfsf_simpterm(u);
   % Differentially closed field simp term. [u] is Lisp Prefix. Returns
   % the [u] as an DCFSF term.
   numr simp u;

procedure dcfsf_prepat(f);
   % Differentially closed field prep atomic formula. [f] is an DCFSF
   % atomic formula. Returns [f] in Lisp prefix form.
   {dcfsf_op f,prepf dcfsf_arg2l f,prepf dcfsf_arg2r f};

procedure dcfsf_resimpat(f);
   % Differentially closed field resimp atomic formula. [f] is an DCFSF
   % atomic formula. Returns the atomic formula [f] with resimplified
   % terms.
   dcfsf_mk2(dcfsf_op f,
      numr resimp !*f2q dcfsf_arg2l f,numr resimp !*f2q dcfsf_arg2r f);

procedure dcfsf_simpd(u);
   begin scalar vf,n,w;
      if length u neq 2 then
	 rederr "dcfsf_simpd: d is infix with 2 arguments";
      vf := simp car u;
      if not domainp denr vf then
	 rederr "parametric denominator";
      vf := numr vf;
      n := cadr u;
      if not (numberp n and n >=0) then
	 rederr {"dcfsf_simpd:",n,"is not a natural number"};
      if (w:=sfto_idvarf vf) then
	 return mksq({'d,w,n},1);
      vf := dcfsf_derivationnf(vf,n,nil);
      return !*f2q vf
   end;

procedure dcfsf_lengthat(f);
   % Differentially closed field length of atomic formula. [f] is an
   % atomic formula. Returns a number, the length of [f].
   2;

procedure dcfsf_chsimpat(u);
   % Differentially closed field chain simp atomic formula. [u] is the
   % Lisp prefix representation of a chain of atomic formulas, i.e.,
   % the operators are nested right associatively. Returns a formula,
   % which is the corresponding conjunction.
   rl_smkn('and,for each x in dcfsf_chsimpat1 u collect dcfsf_simpat x);

procedure dcfsf_chsimpat1(u);
   % Differentially closed field chain simp atomic formula. [u] is the
   % Lisp prefix representation of a chain of atomic formulas, i.e.,
   % the operators are nested right associatively.
   begin scalar leftl,rightl,lhs,rhs;
      lhs := cadr u;
      if pairp lhs and dcfsf_opp car lhs then <<
	 leftl := dcfsf_chsimpat1 lhs;
	 lhs := caddr lastcar leftl
      >>;
      rhs := caddr u;
      if pairp rhs and dcfsf_opp car rhs then <<
	 rightl := dcfsf_chsimpat1 rhs;
	 rhs := cadr car rightl
      >>;
      return nconc(leftl,{car u,lhs,rhs} . rightl)
   end;

procedure dcfsf_simpat(u);
   % Differentially closed field simp atomic formula. [u] is Lisp
   % prefix. Returns [u] as an atomic formula.
   begin scalar op,lhs,rhs,nlhs,f;
      op := car u;
      lhs := simp cadr u;
      if not (!*rlnzden or (domainp denr lhs)) then
 	 typerr(u,"atomic formula");
      rhs := simp caddr u;
      if not (!*rlnzden or (domainp denr rhs)) then
 	 typerr(u,"atomic formula");
      lhs := subtrsq(lhs,rhs);
      nlhs := numr lhs;
      if !*rlnzden and not domainp denr lhs then <<
	 f := dcfsf_0mk2(op,nlhs);
	 if !*rladdcond then
	    f := rl_mkn('and,{dcfsf_0mk2('neq,denr lhs),f});
	 return f
      >>;
      return dcfsf_0mk2(op,nlhs)
   end;

procedure dcfsf_op(atf);
   % Differentially closed field operator. [atf] is an atomic formula
   % $R(t_1,t_2)$. Returns $R$.
   car atf;

procedure dcfsf_arg2l(atf);
   % Differentially closed field binary operator left hand side
   % argument. [atf] is an atomic formula $R(t_1,t_2)$. Returns $t_1$.
   cadr atf;

procedure dcfsf_arg2r(atf);
   % Differentially closed field binary operator right hand side
   % argument. [atf] is an atomic formula $R(t_1,t_2)$. Returns $t_2$.
   caddr atf;

procedure dcfsf_argn(atf);
   % Differentially closed field n-ary operator argument list. [atf] is
   % an atomic formula $R(t_1,t_2)$. Returns the list $(t_1,t_2)$.
   {cadr atf,caddr atf};

procedure dcfsf_mk2(op,lhs,rhs);
   % Differentially closed field make atomic formula for binary
   % operator. [op] is a relation; [lhs] and [rhs] are terms. Returns
   % the atomic formula $[op]([lhs],[rhs])$.
   {op,lhs,rhs};

procedure dcfsf_0mk2(op,lhs);
   % Differentially closed field make zero right hand side atomic
   % formula for binary operator. [op] is a relation [lhs] is a term.
   % Returns the atomic formula $[op]([lhs],0)$.
   {op,lhs,nil};

procedure dcfsf_mkn(op,argl);
   % Differentially closed field make atomic formula for n-ary
   % operator. [op] is a relation; [argl] is a list $(t_1,t_2)$ of
   % terms. Returns the atomic formula $[op](t_1,t_2)$.
   {op,car argl,cadr argl};

procedure dcfsf_opp(op);
   % Differentially closed field operator predicate. [op] is an
   % S-expression. Returns non-[nil] iff op is a relation.
   op memq '(equal neq);

endmodule;  % [dcfsf]

end;  % of file
mathpiper-0.81f+svn4469+dfsg3/src/packages/redlog/dcfsf/dcfsfsism.red0000644000175000017500000003415411526203062025531 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: dcfsfsism.red 595 2010-05-09 05:01:45Z thomas-sturm $
% ----------------------------------------------------------------------
% Copyright (c) 2010 Thomas Sturm
% ----------------------------------------------------------------------
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions
% are met:
%
%    * Redistributions of source code must retain the relevant
%      copyright notice, this list of conditions and the following
%      disclaimer.
%    * Redistributions in binary form must reproduce the above
%      copyright notice, this list of conditions and the following
%      disclaimer in the documentation and/or other materials provided
%      with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%

lisp <<
   fluid '(dcfsf_sism_rcsid!* dcfsf_sism_copyright!*);
   dcfsf_sism_rcsid!* :=
      "$Id: dcfsfsism.red 595 2010-05-09 05:01:45Z thomas-sturm $";
   dcfsf_sism_copyright!* := "Copyright (c) 2010 T. Sturm"
>>;

module dcfsfsism;
% Differentially closed field standard form smart simplification.
% Submodule of [dcfsf].

%DS
%  ::= (,...)
%  ::=  . 
%  ::= (,...)
%  ::= 
    Example of MathML
    

    
The following is MathML directly encoded within this homepage:


    


   
      
         x
      
      
         x
         
            x
            2
         
      
   




    
On some browsers such as WebEQ, the MathML is rendered correctly.


\end{verbatim} 

But most people on the web use either Netscape or Microsoft Internet
Explorer, which do not at the moment support complete MathML rendering. 

What must be done in cases where Netscape or Microsoft Internet Explorer
are used, is to make available the IBM Tech Explorer Plug-in, and include
the MathML inside the web page surrounded by $<$embed$>$$<$/embed$>$ tags.
This is easily done with the REDUCE-MathML interface by having the {\bf
web} switch on. Here is an example of how to do this:

\paragraph{Example}

\begin{verbatim} 



MathML example

    Example of MathML
    

    
The following is MathML directly encoded within this homepage:


    





    
On all browsers with the Tech Explorer Plug-in, this is rendered
correctly.


\end{verbatim} 

Another way to embed MathML in a web page document is by having a
separate file contain MathML (usually a file with {\bf .mml} extension)
and to embed it inside a page with the following code:

\begin{verbatim} 



\end{verbatim} 


\section{Examples}

We would like to present a series of examples which will illustrate the
possibilities of the interface.

\paragraph{Example 1} Type in the following and observe the resulting
expression:

\begin{verbatim}
23: on mathml;

24: solve({z=x*a+1},{z,x});
\end{verbatim}
\paragraph{Example 2}Have a file {\tt ex2.mml} containing the following
MathML source code:\\
\\
{\tt                 $<$mathml$>$\\
\hspace*{1mm}      $<$apply$>$$<$sum/$>$\\
\hspace*{5mm}       $<$bvar$>$\\
\hspace*{9mm}         $<$ci$>$x$<$/ci$>$\\
\hspace*{5mm}       $<$/bvar$>$\\
\hspace*{5mm}       $<$apply$>$$<$fn$>$$<$ci$>$F$<$/ci$>$$<$fn$>$\\
\hspace*{9mm}         $<$ci$>$x$<$/ci$>$\\
\hspace*{5mm}       $<$/apply$>$\\
\hspace*{1mm}      $<$/apply$>$\\
                  $<$/mathml$>$\\}
\\
and type:\\
\\
{\tt mml "ex2.mml"}

\paragraph{Example 3} This example illustrates how practical the switch
{\bf both} can be for interpreting verbose MathML.
Introduce the following MathML source into a file, say {\tt ex3.mml}\\
\\
{\tt $<$mathml$>$\\
\hspace*{1mm}  $<$apply$>$$<$int/$>$\\
\hspace*{5mm}    $<$bvar$>$\\
\hspace*{9mm}      $<$ci$>$x$<$/ci$>$\\
\hspace*{5mm}    $<$/bvar$>$\\
\hspace*{5mm}    $<$apply$>$$<$sin/$>$\\
\hspace*{9mm}      $<$apply$>$$<$log/$>$\\
\hspace*{13mm}       $<$ci$>$x$<$/ci$>$\\
\hspace*{9mm}      $<$/apply$>$\\
\hspace*{5mm}    $<$/apply$>$\\
\hspace*{1mm}  $<$/apply$>$\\
$<$/mathml$>$ \\}
\\
then do the following:

\begin{verbatim}

2: on both;

3: mml "ml";

\end{verbatim}

\section{An overview of how the Interface Works}

The interface is primarily built in two parts. A first one which parses
and evaluates MathML, and a second one which parses REDUCE's algebraic
expressions and prints them out in MathML format. Both parts work by
recursive parsing, using Top-Down Recursive Descent parsing with one token
look ahead.

The BNF description of the MathML grammar is to be defined informally in
APPENDIX E of the current MathML specification. It is with this document that
we have developed the MathML parser. The MathML parser evaluates all
that is possible and returns a valid REDUCE algebraic expression. When {\bf
mathml} or {\bf both} are on, this algebraic expression is fed into the
second part of the program which parses these expressions and transforms them
back into MathML. 

The MathML generator parses through the algebraic expression produced by
either REDUCE itself or the MathML parser. It works in a very
similar way as the MathML parser. It is simpler, since no evaluation is
involved. All the generated code is MathML compliant. It is important to note
that the MathML code generator sometimes introduces Presentation Markup tags,
and other tags which are not understood by the MathML parser of the
interface\footnote{The set of tags not understood by the MathML parser are
detailed in section {\bf Limitations}.}.

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathmlom.red0000644000175000017500000000325111526203062024301 0ustar  giovannigiovannimodule mathmlom;

% Author Luis Alvarez (Bath University)

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


FLUID '(!*f!* safe_atts char ch atts omfuncs!*
        interval!* mmltypes!* constantsom!*
        count temp space temp2 mmlatts constants!*
        functions!* relations!* constructors!* ir2mml!*
        valid_om!* special_cases!* special_cases2!* mmleq!*);

create!-package('(mathmlom mtables tools ir2om om2ir mml_ir),nil);

endmodule;
end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/bib.tex0000644000175000017500000000373611526203062023255 0ustar  giovannigiovanni\begin{thebibliography}{99}

\bibitem{w3c} World Wibe Web Consortium
\\
{\tt http://www.w3.org}.

\bibitem{openmath} OpenMath Society
\\
{\tt http://www.openmath.org}.

\bibitem{mathml}{\it MathML Standard Specification}, W3C Working Draft 28 March 2000\\
{\tt http://www.w3.org/Math}

\bibitem{openmathspec} O. Caproti, D. P. Carlisle, A. M. Cohen, {\it The OpenMath Standard}, August 1999
\\
{\tt http://www.nag.co.uk/projects/openmath/omsoc/}

\bibitem{htmlp} HTML+ Specification,
\\
{\tt http://www.w3.org/MarkUp/HTMLPlus/htmlplus\_1.html}

\bibitem{html3} HTML 3.0 Draft
\\
{\tt http://www.w3.org/MarkUp/html3/CoverPage.html}

\bibitem{html3.2} D. Raggett {\it HTML 3.2 Specification}, W3C 14 June 1997.
\\
{\tt http://www.w3.org/TR/REC-html32.html}

\bibitem{sgml} SGML Specification,
\\
{\tt
http://www.w3.org/TR/1999/REC-html401-19991224/ \\
 \hspace{1cm} conform.html\#h-4.2}.

\bibitem{latex2html} \LaTeX2HTML Manual
\\
{\tt http://www-dsed.llnl.gov/files/programs/UNIX/ \\ latex2html/manual/Snodel.html}

\bibitem{xml} Bray, Tim, Jean Paoli and C.M. Sperberg-Mcqueen, {\it Extensible Markup Language 1.0}, 10 February 1998 \\ 
{\tt http://www.w3.org/TR/1998/REC-xml-19980210.  }

\bibitem{compilers} A. V. Aho, J. D. Ullman. {\it Principles of Compiler Design}. Addison-Wesley Publications, 1979.

\bibitem{compilers2} J. P. Bennet. {\it Introduction to Compiling Techniques}. McGraw-Hill Publications, 1996.
\\
\\
\\
{\Large Important Web Ressources}

\bibitem{tex4ht} TeX4ht Web Site
\\
{\tt http://www.cis.ohio\-state.edu/~gurari/TeX4ht/mn.html }

\bibitem{TtM} TtM Seb Site
\\
{\tt http://hutchinson.belmont.ma.us/tth/mml/ }

\bibitem{webeq} WebEQ Seb Site
\\
{\tt http://www.webeq.com/webeq/}

\bibitem{ice} ICEBrowser Seb Site
\\
{\tt http://www.icesoft.no/ICEBrowser/index.html }

\bibitem{ibm} IBM TechExplorer web site
\\
{\tt http://www\-4.ibm.com/software/network/techexplorer/ }









\end{thebibliography}
\addcontentsline{toc}{chapter}{Bibliography}

                                 

mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathmlom.pdf0000644000175000017500000107475511526203062024322 0ustar  giovannigiovanni%PDF-1.2
3 0 obj <<
/Length 4 0 R
/Filter /FlateDecode
>>
stream
x-M1+rl&r~$F*z;Ur	ϓ7*Z:cNaw.FOzIh!4
5[b.7.Ȳxf."u=M|f`T^ %\ێF]MVRLA7΃0N:o5OOn
^\m|Α4Ԉ9yƩJN(P@1endstream
endobj
4 0 obj
205
endobj
2 0 obj <<
/Type /Page
/Contents 3 0 R
/Resources 1 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
1 0 obj <<
/Font << /F16 5 0 R /F17 6 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
10 0 obj <<
/Length 11 0 R
/Filter /FlateDecode
>>
stream
xڭVKo6G
>D=S^"Ef,6zd}*BE`F7g~|8Y,\Ƌ9\}ɂs+X?zwrweYf,R)vv֚~KcxK-,|:KErۻbP4vnhvp,	e	vc6Ũϣe•$>R	)~z&\X mf謳cR/g*]F"%O|F^>@2&!%ҜH'=[:
_cl'd=4fLעEY1t_;7DNFԴdVo\s^!̭i_ߍI]~ZaE$;HИsH
"_롴fjt̜*Wq 'PvWrx(}s(fݢL@
@xUe19p{3b
H
5
*v#~qO0=k\@#nuS$BJ\)Fve,Ӆkhrs[B#sP'2GQ9'Jե¾ט\*k_}A[{B
RQ9?bJN	![N3.Yc~vv8A۳ʪ(ZM=}H+AUSdeRܖR(*T&9Z@3}+m`ZoNw,=ǬFLbKoMgOV)5vWW&'hbcrG,"{"gdE@2R@)1>Gd][w
]IGzpط@v6١v#	¦*B= 2йV/	$8vaev}mB'9Mb͗Nvqϫ+30c*&t2~k1G.`ʽYG	k!Ⱦx㲁Ieq9!a~>Y@T_8x	TzWSݯ;ܽ5˙1Mx	hvbX@v>On'B=A		^vAASBhh%ӭMbӭ֍
W&q6Q ;p
RkYiDendstream
endobj
11 0 obj
1219
endobj
9 0 obj <<
/Type /Page
/Contents 10 0 R
/Resources 8 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
8 0 obj <<
/Font << /F26 12 0 R /F27 13 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F32 17 0 R /F28 18 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
21 0 obj <<
/Length 22 0 R
/Filter /FlateDecode
>>
stream
xX[F}	?R0WC6nDj/U00Xo.PCfؑaf|w;@fȌ+freۛHbm.V۪X
}w
D8753H&T706kr)KŬ3[6ot6mab1׏HNwOLYHaPR.m6z6y!cC,&/BBE$'7:",s2܀7ڍiKݸMZ|	\&M%v9o6;$6
-!cW+VS`99"z&3]:PJ*="by[hD1
wr=̎x/{fm]k.ΐaDӣ:7a5JXx‹|[_#]3#O; s2hb>*H$r_NR	!BNY/6l${oBt:DyWI$e:b2:PKL&:)ieigU*jΟV@XJrIdg}f:PlbN߉i߱ws]@UuW4)9:FB~zY?h:O\;})zj?`Ssj.t{=1@`-\1#D2gi_y,K2[2Pn;Һb#"/%L^F	)0"simD#D,UUa(w?ϸ{+yaJTds5ˈJ~	&:&8?mip#+Zq"x~Q$Mxxqur8d\tʞ[Ӏ|AQ3P~,cE-njE_|kkѳ&8?>5˼s~~lL<|_gSzx߂'E'Nh'NoUo?އ_[@ܳ8a
+.qxssendstream
endobj
22 0 obj
1095
endobj
20 0 obj <<
/Type /Page
/Contents 21 0 R
/Resources 19 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
19 0 obj <<
/Font << /F34 13 0 R /F30 15 0 R /F15 14 0 R /F31 16 0 R /F28 18 0 R /F32 17 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
25 0 obj <<
/Length 26 0 R
/Filter /FlateDecode
>>
stream
xX]O0}ȣ~hI֥ҴSЖ!A
M|9#$G"<9My烓蜈Ta
pl8H`)Q*Jx31!LLɨt@LLޱER/nb3jkn*]Tq1_zaY!\
DsLKW~#Rt}o6c8Lͪ(WM^zo	$#*R6)]-h*Wke aq
'KF,4l8>`W빞q-km@7j୐
0S0v,u(j:`Q]T]Kرax'| .nWũm{G~ݯg 5  	S.b쌦lm֌ʀIk峾]+"
Ca*m~&]I
_KʐM;"&W"E_"۴u$&Ƈ'|V8?,B?fւCCM𫢙\Mqh8Cϑ)MRս#<)ߛD\7P:
)v1;hI%E{ImNN]tvzw7_6ђ<=NMufl7ʸY~9x4BT	WM&O\w\"{R_/F5,n󲝙tCM$[+endstream
endobj
26 0 obj
882
endobj
24 0 obj <<
/Type /Page
/Contents 25 0 R
/Resources 23 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
23 0 obj <<
/Font << /F15 14 0 R /F30 15 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
29 0 obj <<
/Length 30 0 R
/Filter /FlateDecode
>>
stream
x}WK6@2vE}lH@"h2%v_-X㛡ZSuEuE}x~_bufG>h*)H-6`(\պT	ꖉF5S=U*[x]ŕʒuRUk|guǥ.t@NG3˕.Pte~w%eY&Q"DPU99ѵ-^UV:KYe\I5zjG$`7xb7ˌ]C.4qPiȀ: #LLVdUZq˭wE\"
-8 0յ
HXQJxoMX
EyMq'gnXˮơ>z_R)} 8*Z~7"y	xr05ߖjoYtg
-QZݮ(3ahqd·;6vs	5G'J'Q2bLWEa`|'wS{buCy`aȨLEYIOlo;;*>ot}_A5=]WnIq`p~r6tiK#ӶloP9RRҡ	̛TA B[FPf,ݶvM"*_WI~!3+]eWDN݋켢d),ԡr2G5e+8_k3khFA͗Б^E.'̡adg>zW4n-U9^s<`<*(@LcO*&2|X-!Uw0l\+I7bCEК3Z|@j\KN)m[
M(t`V+y`gv:W]gA 
+يP-sUc|#ՂEGR4Qq?4 6XARmXMu\
<sgx24QXZ?~}8Yhqtxp4VP/j{٬aIazfsUGmm	ؓad
T	2u.)rx?8`pmJx%x!ַ\;:1:ҔD#a{L)M0sΥ܎}u7D-pιjt)~	p-[gXdD1QvP`x|cJ|$PRYk'[O13X`-'$u9`Pdm#Wx˂Dݜ霉)p	,	6Rt&1pO"_gUPXiJziyq?endstream
endobj
30 0 obj
1827
endobj
28 0 obj <<
/Type /Page
/Contents 29 0 R
/Resources 27 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
27 0 obj <<
/Font << /F37 13 0 R /F34 13 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
33 0 obj <<
/Length 34 0 R
/Filter /FlateDecode
>>
stream
xڅN0E
/q&{YJ+@%b6.5JM[.@ /<39s)
CaCY8Cw{	$^xt;+?LdE#7|\/`BCr~ƹ &q
;#igH4@EF#SNh?xh
*]<4UGvc[XնM+].C}_fOļԢ()j^EU)Cyv"q61~SvedgeMOM$Z%yI)HҿmV'?IqŇe|Pk-NRtz̡
,R<ʭb#.jendstream
endobj
34 0 obj
377
endobj
32 0 obj <<
/Type /Page
/Contents 33 0 R
/Resources 31 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 7 0 R
>> endobj
31 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
38 0 obj <<
/Length 39 0 R
/Filter /FlateDecode
>>
stream
xuWKo7ߠ#DhRME"zWI΃+K&97&%$),Wi͏UmݞTĻVOF~t%mQIm(RhAY\Q/њ/KUV*.VU-kA?Mvbv`ĸgiCk=
j38,EXfq8vԘZ4,giZod!vz
f%jlRpTx\mrm&v1nguǻ<_R兰dvsx1XpbVFV[p56Sl(K]623Bss>3]gb*cs)bx7[w8M5MxJ%P+>Q8NygX&b$*Fa=Mo;ߏN>qWgBqK v]{?إН ֌z[CD02gt<$I{#Oa눖ceUGB!`rCc 3!M~ig^E3Ɔeh aaCd'ʞ
<;@[5|;]GaK[1ިs1kW-+ͷ؟{ψcr9v0aboKg$.]g0B,%de2/Yp'edĺC3v\kcdsōLk@	*+ዒXg1hmqvi|p#Ok.̕ƫ+
1B1Yw6
t5l
 Bȍ4́;ˌM~(!LcF~מh3)nGtS$#@gj-U@im?8]+@]q׮e1:Qyv,l,r 堠X .-0qiI]An-җ%.L'*8/-l%t (Qu|=8fXǞ(cZlHْ
rrZsDDB=2zaڙ;K8.v~A6d{x$幓b}jr
B}86sMTCκvLs#R̢$}t8N2#\A4|CjHG~FZL, !^)$&*}%J@ZAAc#܎i+;1PmQxT=kP{LS=Ms-/ѢB
ur˟n'ձDDA&|[Y%tx37w7wJendstream
endobj
39 0 obj
1735
endobj
37 0 obj <<
/Type /Page
/Contents 38 0 R
/Resources 36 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 40 0 R
>> endobj
36 0 obj <<
/Font << /F37 13 0 R /F34 13 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
43 0 obj <<
/Length 44 0 R
/Filter /FlateDecode
>>
stream
xڕYYܶ~C~üSPJ^KJZG%1;xyh!gi\FDOlH,6Cn٫g/HQGvO^AnwiootTpӇkpO_oKZ"ϝ<ϮoE
U"a>6Q(lpB)FPdcNXxԠV炙U{ȏAI+zݩL ?Ԗ kqՙ韪Һm&{bqض趻8JT+CQ)!CrRiPLm1LqS֔8@t{S,2i(OV-ѶfJ?LI:vqmL¢%eh,Sк;HSmz0Rox1)|0x3i#%ґiK.0yXdβo2:'ZYy& ,!'GS&[18N&)!(
jf:%+՘S$Bu/Jew8`~
 X!SlϕB+۶`
Wz1_BZ9HL;6J;dcpڙRF
ku(\6jE։:kPn_ܹښk\A[q0_CE_q	rPrr5(Q\LCձD's+[rX;fzoH}UIGܳ8xѴ<*_+v0M,@`p4ӱs	{4q0"cꄢV1ҧCE"p!ya ̀3u0;J;t7DdڪK3
b(0iQ'(T=|Jo opLy}FCKȽ{o6QsuһȻb	4sYFwlf^&!~*@'LkŸz]~v#7|7y?\TSFn"U0¶9zJU#eVLpcPѵkL[=
ynQX,04DƷ1VCOBf`^T@ZoDu,R=R=،cm="A-=VLg@yxb+3p,*
30@Sݜ抮(0reQw
U22!|itLXkgO^tQrq`Z#_ʓGWН395t}Bh;yٓhe,ؼ;~WX( OPai(de@z\R+{:&z>\AFNt37B6wAE,̓Y4+oVRIdY5`R0XEr"~dRH-Iu87 %f_|"~wDRR_CN*
U\۩ruLoǵcwۯˑoVZ/woU3Srendstream
endobj
44 0 obj
2662
endobj
42 0 obj <<
/Type /Page
/Contents 43 0 R
/Resources 41 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 40 0 R
>> endobj
41 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F39 13 0 R /F18 45 0 R /F27 13 0 R /F19 46 0 R /F40 47 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
50 0 obj <<
/Length 51 0 R
/Filter /FlateDecode
>>
stream
xڝYYoH~}Y
1dwzLLIfѮp@-0
8_uDY&X0P/\a*]$F&Yl뫷t?zG7\_^֞$Ia25_y_,x.#Y&Hqu
+X|ǑYEgPZG9ؗ=7󆿿w&mͦlWLR6xRyJ'& WYǫ88^(?Rbbu"Z#"8am2>/N[/?6.U}\i,V#wV6x#eaoWUܔN
S6}
XR%mPxa۞A6g.k,le}7UIeFGy8MA.Dc+\廁}	q_nq=Ucs7`N#bi[U(8&&p
/`^}ōzv[~	B%Kcr3M;ȍ5dI	|D'wZ˦˻n;˓۶mӗ_ILЏ1u4{$kaGj&V;~	a18#[V)ਧQ赏ۍN`ex7-l2R0ys/v_9Zۡ}2vӶG:(8j%5ށ:-#B<lo{ۿeيnxC[	hMey]q9o
)AxvufVpW
[9䧇Lǁˊl1|X+*{`:7Z:R{{a6]O#+ni; 'sl{&Ղ20x3Q;8YW
5=,!L0qP<!NM{0$"p
PROmP]@A3Vwx +%Q(@Z0]B'CQ+'o1qP#%ʓJȠ﮼/׹Ћ-Θ&@o`yQ\:I)~C0b"MS_DPHݿ8? cׅ[EIО<0^>΂L<2AwZ@8AsV/{PP%FYh+qIc`U9IǑABF.F-յȉ	@Uy/í;O!8h)ލΞZjl
aݽml&mv.L`Sy!Ajѱ
%cw$,
&BnyP"{'`,al2x<%Ρ>dY7	tX	b#W0e	M;-8YB04#S/TĈȥxb1L)%rJAg3l@ʜ+|crI g
dS3Y[e޾-whMeKExXs\Odsuzy
A1E!A5ISTʜRD*¢K@&mAYmu>8m!'@@1`1Q=QXgo	Kx>2% %@߉xCKHs(32>E1{S1x-G+y\T~&Ri8*Wmv
·lh"W] mb0t/bW@*|d'F?ұ8Y"|BS|8VTOBXC]yk9:ѾNYُ4/ɧsƑ: ;u=^15s}AԬcWN?+;;6ɹЛ $$諳{?
ٙuKeLz9BHV?39fTу	>أ'$)#܆掗=$,1{0CW
6bՓC[gv> endobj
48 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F18 45 0 R /F32 17 0 R /F27 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
54 0 obj <<
/Length 55 0 R
/Filter /FlateDecode
>>
stream
xڅYr8}ޖ1g7SIM*lU&YP${~te;*h4vWū8.2)WEi^yVqVQ1M-xןo\RA^>~ 2
nZƾ\׫7zWR
rxq}"Z0a(TUf{;AGRIƤ *2&au'*}-IU+֠jݒ(̪}ثuUR?Bwǣ#1	hi@cB̖7Ig}d1PИ4*Ҋn*D(t^\ME^x|0i]akP[N冉X{7qp3I2Q
~~'UiAD03P6`Hy覆<
mc>)UYpV4~oNMnA@ŕOj(p{LiD	(b*#$۶Stˢ{Au]0mɜ$mF*.8:"oCivܱZ	qV,yˇOf'wIO*ēDS3-,Ē4[(jmk]/zaLY&/0
ouOgiЉ
	MTPT`uQyT	,9qD4OqčUQIDo{a19h[GwEɼtN3]=TN'/t
ͦi}h^nF[bf{CeURRP)?|G\Z`OAMHOXl>|d$XC,e^mLsꗫB
S|E8.	nMB$M!8Jght"`ghYyifYoX;:o3Z
k:4vBMgZKD*
,[I+ԥܯp!"/<[ln[EH,Nt;PxT5~̈ |X0"l,$V,vOLCs5[=s%ΥC҃5Z[E!Mπ,N
+H,G2;g>ȸQx%H`X')<9[	gPJ(ߋcD-Эi\B+!)@S1x.
ŏ!Ew%.܏9{l~6&{TCb&Nf89@Di-gO~NhK">*X,r eg
v/z#%(6jNY {i|>=u6Ʊew*4ІS20ZJt.АaXp)JN[!^J_LGLe;cK.;u}k	wzZo`kEaлwݎ~qVA^K#kf۲HPnhN"Psz6^pPKv~Τ;#	%#€=cd,2w!Lw0/^mch lLy++!:n94$}/
N!%E56*8ҁ/Wl~-ĖGYlT>*Ǒ!GJPjc:zu(
ÿ䠈/ Q8XP3!>sr\~dIΒAO f8I/YjAtaѻ,˚2AQ LSlLHҿ#!tɬp;PlDz,[ӟ}◿+,:XK|/O%t5$ܨxd
<$
͠ɸ<5D^
xjXGnO,sL//"~6f1N ^)EuH?:	ڦ1HbЄq;A_COCXYuf_2+<"Ny?ढ"ƶ%'ȵmxr/ST.
g;32VT0%$'adi&a:Va]Z xʰʹr$@e$z'T
cv^tІVކ7Fn/Ӆ)B_3TV
TrU=})kWiV"+8+[Rnj35)_WU]u,)2m-M}G[o{#mt682W ]Ff'PR9IlmK8׭ Ckh~cd'ߠ
=Enendstream
endobj
55 0 obj
2647
endobj
53 0 obj <<
/Type /Page
/Contents 54 0 R
/Resources 52 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 40 0 R
>> endobj
52 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F27 13 0 R /F39 13 0 R /F18 45 0 R /F19 46 0 R /F40 47 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
58 0 obj <<
/Length 59 0 R
/Filter /FlateDecode
>>
stream
xڍYYs~'b*/WbZjmy.T Ju kvFhwȶgl"1yX&qhMѓI1QXFg_/ޞm$	lE682_xwf)IД+hƣ珢ֆ6K0^Yj7QŦwGFŜ$;hd8yc'_ki^tpfbz7LvU&Xa:}v$NH$Lm>ÌkQ^H!	nAջ
%ξdt~DIPDE6]O݊9bfiwi 6Yp}[Cȸ,d	t[X󐠹
,5I2L\;b8JYpsُwnW-ُZ0]+ڄcPekv<%bp#E]jǷ=Ͱb뺣_H*6‚	}!)IrFF:4\CFςc<\X	N(p[ah	<3]E7r8alM,]4۝:.5_]ˊA"jdmp1ҵz4
>k{8^Rm԰?4w:eh*Ǯ@\/f|7l{4[
#	+"Y8[$%	9LDw\=a_I\~zdNçc*Ne`
#14L9NҔ ;tfȐN׸Ma-+u:${t(;;4PKWth|]Q`7a7ܟ޿nƿh8̗f.lBWqT
5mzbhxWTqΙEh)es׬|Cq*(6d2?.lv'Q翬21#c`Lps3n
Qd}N:웅~JKųic9mʈccHH5uk|YQ'Wg>:.|tmu̻-Z{2uQG
NHfEC]h^pLRZՂ~B`ё;⠣{?
2E7RrO,Ϸ!\jC4xj	w=7Bb?$J戝i/'fJղd'+D25ԠԘ
{ѳO3*'$9U4>TÉ`7xU-pEJ
j*}]l|ґsUЄK	$c^/;	;bHhC@oh8jbh~"tj
W2$|_YD.nn@aI,h/ŋzT[bHŽY;J3/pHe2С\VH*#B@tPl6Yhbe*{%+z,q-15Z.
"AȜNIABy4͐4NH}G?2EVZÑK+)XY WURҩwJ2fcV>v~3"8gIRQ<΀{])_*]"y>,>EƿX$ #P%}
'Xv 
INÌ#d?Mm}ޜoe
m(̾ác/.Uw:T?+Ft3Ԓȵ(?
55HT ,pw#94ߛ#fb!b1`wv!ԕi\}r"qKsWy2{aW}3JU%2UtmNqaԈ> endobj
56 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F32 17 0 R /F39 13 0 R /F18 45 0 R /F19 46 0 R /F40 47 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
62 0 obj <<
/Length 63 0 R
/Filter /FlateDecode
>>
stream
xڍX[o~wV/v".sDiyX+iv_F€;;;;of㵏w~u۟Ia~y9r\m:r$Mha:]"($$^}P:c7q~G	vWd0iKՉ;聓1	x.Aߞ;-<t*P"xL6xl@X
D9g7ā@.@:(Jxx:c̄eR&I䙯H^^J (qmr1LkyҊ^BS"ΟQSqERe&rԠdJN751+:ԃfܥ)$Z>ö9I|gŗp|w覨{^FO%mS$nGpBZ(Iv+} D:46jhǎB
E<=AJ<}Bh=/Z}Bu#fAwVXbXmR2hs0E
1u~
PХ1Rs> endobj
60 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F18 45 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
66 0 obj <<
/Length 67 0 R
/Filter /FlateDecode
>>
stream
xڅX[o8~c_VUbh:ֳ-0Zmn$CJd~%+E<$|t/^q\bUwom޼d8
Zmvs_$I>f]Ϸw_x)IHS/p˛͛hui6IUZ^Rؓa'!UI/acSdnFXD,I0~dAx*N8*3e @$៮YȖe𲫵=Ӛ)tY]y)|0K+ 8v@ňS(hxG+MVEXU*^0JysI0/PyӆD
ȉ9lW'7//nH"{vƲOVHJeE[EDlGJ,\*JpTLմHHgCK!|3עX7fuAUKo|U3,@7wf	AE<-4pFFY	>,JgieӢ"ҢxPõKd&8:qկAcp=Gmi0{6#vtydXyDsXm[CC/CCrvV2|>9(C
;L")XԍG1̱CNE/"&[:$t 
Ÿ<r$	 OGL+^Րbb-I@&81b,顛\6uAhzσ!WMSL51{Ewx'5Z+hqpkk0.[iwVvW\~VN{R+_@kXr\.ԍ>8l;t6/8H[*:eS^D,l;jFzC+Y5R:4v֭"dޛN{d2;{aP+}_";p+ىO[.w;	b(?`̎և#e#j	kcm)ā7'<j,cMW\FϪiHWheqLq&'?0݊d%
#! >-W[3Hʝס |A2FvxykDX/0s48WeߦR^FWǭ#\GxAz|HO"3'+m:1CZ\"Ne+Z
1C	7Xrx)($ Qpـ'aPV4 Jg 	)}{T
yBs9ȑś'{xꚪ!n~Isڟ> s~MNh^`ç/PGϟ4xgU\a//>.UB`9-UN?e*7:<„mp0/ʠ5Fj-'
wx0mCp8,8_ڀ焋LXYϿ7Ɨ~8joZ_\ǾUZ!֮4$wXendstream
endobj
67 0 obj
2255
endobj
65 0 obj <<
/Type /Page
/Contents 66 0 R
/Resources 64 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 69 0 R
>> endobj
64 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F39 13 0 R /F32 17 0 R /F43 68 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
72 0 obj <<
/Length 73 0 R
/Filter /FlateDecode
>>
stream
x}n6oUX+ç)h.zX]`Fblz-;Jgy3]%ҴKUrMjVU{Q+yVg"__0pօ@hVEY0l2D(u?D&$ʲ$FGvCcGw,6Viot7AkMdR(yT5/c\<n'L176p(9@c3:U*N$QgEԂ2~|5 lA#0,5vdϷ`۬:
LDwk6bMD<s"jMs;;9H/xEGߗ&B4`ȱTc9%pnRےhwI_!Ok1}4^ ڱp]8E5og[)dj-P̯F軯||lLiot~3*_h1P)Y>=jj^}5XiQKJ0f2zAUzn<Г{uE|J^Oo_N-4g)c=Gp%(&\@yaB0Za5Q4"ыG "~*/4_6<BxQiu8\dʄJ~84DPRCB0
ʼng5r2O<
.Lj
(E;\'s@4/RBK
*q@7$'N0|c4~q~!uYL@*Mc__S`8@uxa5^R{VK.\	߸ntIH䪷-Kͣ, QWIҼx4d_lyI~să}5|wvD嚄H*٨keE]
&;A.pT(Fs͍L49JM̲)a^0IBzZԓ2SG,zXn0;i,U3AOHYf@e1Rrz?.4(.7=:ճ2JSo1j-;Uu,5@9p
Os4G鬸YEKBq]z!@sf4 J=xWRqNc0Y=*xUiáݱ͖;g6lW'@Wxǝ<DwM7|5qy5VI:.!Ai[wnqendstream
endobj
73 0 obj
1709
endobj
71 0 obj <<
/Type /Page
/Contents 72 0 R
/Resources 70 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 69 0 R
>> endobj
70 0 obj <<
/Font << /F37 13 0 R /F34 13 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
76 0 obj <<
/Length 77 0 R
/Filter /FlateDecode
>>
stream
xڽZoܸ2CCÝK{u\I;R6h h8of-2'΄(R+YeūoT~&ʳ;Zy[۫o^p~JTz~Q6W6On^@=.W~|w?ϗoĜEZh $.yEvvSmԙmjrXҞuTBT3.d/t%5MBId@;^Mf놪m/;ynwv%*uIfqSf&͡"q&ٵ0 #h}{Vbv
tWM.f;.xIl!eSwkPXdFHb%Ib%E҂ P,"OZDŽvA{Dt
R`m3mPho2cr	}"h|˵v@)0:\X۪>|Bqd8Sz8/kzEƠ~|IaTfql<ݦ`=_1XIL4fݓzer2K׬63kJԄ;VJ
`57$k 91 qa&8jܧ$D~e0`Iig?pvݾ?:'Dw9;(&ܓvq
?aXa3խeш?zY#1m߳|Hq	ygîy4?+ĭ
=8K&&(ٟ~
+\1'%!P&]aPs!+hHta_lmhrQ4Q
rpL>Nv:N
&jB6MSRydm7{Q
زa/TFšV$@7ƆnpzBp3AnS<-)eZ)o0%@HSK<נlJ|k)Uq
XM:+:2K9
*Zӄ	0Vu##nGv.OhO>RpKD&!m
'D
> /qF{<.ؠ|@j֤Q4$IAϙ*QjϞi
.ёA0*$}U`jBH|u0|42TOO$0ʙrQS@S$숭DZ IsUطm(C_uBqcXl\
)Ǒ\1R!e]3Mapm(U]QLZ)cģᗏ·a16j.O~F ͝#z,b\3"+tZUp-$kqlnp`|,<$:K-
)j8/V'kJ?i:> endobj
74 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F32 17 0 R /F28 18 0 R /F31 16 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
80 0 obj <<
/Length 81 0 R
/Filter /FlateDecode
>>
stream
xZmo8(1+H$w-Y~ĺ%$';ádIV_Ţ@ESpp^g!353̴LY}w2Ζnro?e|!$/6/o?}|37Q564>~Aӗ~L+Wz|XddX&ULj9[㙔LȿHY?ݾe2ⳅLć݇Dfݪi"VkZr%P2@e	RyXjcp10$O
.US,XͿ9J{g2)^`h?g$ɪd3{Mȉq"":k΂^!:SM^O)!
Dtl/c`qϐKp55"ءOhM2tނϲ,mEx5$~ dZ%!{V٦x5PA6`/hSaنaz|=/Չ	jd5dHI]i46Vog&7?_~/?N3pZ<"~Oɘt^>&eCQvʪE_蹠ߟշFM=|=Qo㞭tTT!xCMX
HvSUrnd\m?JsI,jwe7&Ȳ,#q/L@l\YוtF&;j@?HWv5/{c^St-=%\o։o%
5l>EQVw촯'3JLL˔IF	Jq71ฏر8'09GA٬
Q\
m^d~PBLvUc
m]c9ooR^cvBnƋJÏu@#uf	8,ze!jsnRu=JuI)|ee;Y߃.E; M;Duy5F)9%_-Bd?PcIP@7@]}?Mӟd5r*=SpmMɶ`&w@<rmق_*<ʋǪG[KlTs/R8.'E{Vhس-ZWŊf#=Aa=ybSpU.Ncp2M>B:Au{uoBDh1ڶ_n8mMIQ߂;

[d	F<cFM_TLTۋC.+LwN"Rё@*KVC 1h.{'x0(I9sGDd1ljo4lA#w8GM6K\7	y28)x?\4x(4P[aJqSb-/L$Imb3ϬX	~6Bc,UVQ]3+=	`q@!ā
;̉,;ICPq=]
y%bfuvQshx^Sf1Q<(Uq*Ԙ(6ݝ]jƇKu)uoPt3{LNbZ2J.0}n>]Dv)L;rщGxx@>R<
G|	0(1 mA6ޑ`/1j/8ܙ"DsIv
;\_e\{.sH nr4oζ!ޡIz̼PIF<i_6FR	E.
#76iB1!Z),j4i2tB2G
LxGA@\e/yΪ!b1G /ā[M
BOx=%W%ø:}.$Dy}}| {mÒn[^u͠HVJtvA	:AЇ;!m	;_-4zpcAsLVZM'6LFrUAvAI.w2&3Rӹi&x&ʣ->AІ$MvSVgK ۜS(MJy]
pybw|}o73n[OOjeRVZ#v ^^v
lW4oX%@p%bQH"<@ %6SVf,Tuiq`RE9GgbtE> endobj
78 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F28 18 0 R /F31 16 0 R /F32 17 0 R /F39 13 0 R /F18 45 0 R /F19 46 0 R /F40 47 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
84 0 obj <<
/Length 85 0 R
/Filter /FlateDecode
>>
stream
xڍYYo~w
zxhv7
lx_X؇$-Noޫ&,W_E78Sscѵt#=|WVT\
w?BmMv"ǽ֞qm2KxR̞WvWuuCٺPJH2p"Q
f(%T{7Nv:vn)(l=ˆ	mXuLΎOHj
er#;]aM_ADȃǮ%Ŕn?vߐTyOC@zZXL#
Ĩ8Gjb#XoB,Am8J4CK!	'&vi<ڮp'[3]Ӥ%?eEʞYxBe2m ;!g! u:E'F6
*X题8[9uꌧ=1tK)pdfK\̘1$^9ͩ
PzEL	Dͅr/HFK`MRB3!^lv\9?#C<01WPk/nx$ۯ(@+3$
!
(9M rِCHb,"5g!"l
{aEL)H$e">.(~X;efdبWT	5^֔*	/ zkF%+W+b@2;70!ʧt=3u̜}b,Bg)pkk@Psw&^5^R0Sgy24`+;aw[٩g_K”}2S_V.d3Z@Ɗ
P+Cǘ*۝Rڰ#ȿT|@!AGaRp F'eWYRI:iG'	aCHp_zͭ_ݩ#U1ɏ<_@Md&FqiX?o5策I"d8-	PB(6F
KD }mLd f+c
wj˧=T\Qy]$)erNv治#b汳E|'160aꙿh`//
cX`^:\^蝯!ǡ
d?bg ?a=A'ie8o$$Js)^Flpkb:dҩɪMSRHQq%:wӫ
cr_TPm6a\_޷ny" =#~OXW1^3<ü~`0̖TSy&d/zeB/"3#-	kePJ]uxE|b/w:@3HBWI$E) FoN%SY÷0W>HP]ܺelWKGa.1+NWxQאָktDJ;h:);:Ntؽ@0	z%ͅ蝍IL2nlv~j<2տY9iT7r1sqlBe;؎CK^ßl"#&yѕ;$\jЦ
)A5X~8べZ(NR15
__旓I@"ͽ\.(A.Mql-qexXc/G}JIPjj]#aȾڹ> endobj
82 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F32 17 0 R /F27 13 0 R /F28 18 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
88 0 obj <<
/Length 89 0 R
/Filter /FlateDecode
>>
stream
xڕXێ6}(cZ$:3AyL^QK>u!m-g4"*aթbrŸIB(aYjAۙLE5Iޯ2_h-(~IVl7' s5CCwr,x4K~CCME@e$xe
% r>dz*"cWLR~ڦzh϶nO
{'Vw`_w[.Da.J
0yԔ!>^nDZ	|<.o,~D9BID
h5c'y4J!y0}?aL@O
=|4Ʀ,|a+"T*cS!dh+~GXCVA'1RaKΚOh5*T	r'ړjbcY@_mɨi@Qlŋ|%L4a>	Nf.tb]pJ+\)5mjE.!ZQjˠNQ6f5SC	b!gBꙻbx94C=> endobj
86 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F39 13 0 R /F32 17 0 R /F27 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
92 0 obj <<
/Length 93 0 R
/Filter /FlateDecode
>>
stream
xڥY[o~Oqd fċ.
d]{98mR*ɛ)KmQ|s*?*WQ;d*ljWwykܽuZ'Z7EQ&_~y̒7800`tNN֦12GwWjcJg3`ږίdxt)GU:ި"'7@,u#C $/TG&H,?f

ew5[e
eZdƒhG7tՖd5;dɷ5ۡHTTw3>ϳ6O]$vg\*,êjڇ}~TRm$ST1*|	SKeHBCBd&[
{aŅ̘3~u;Hۺ&Ra,qc,*f'z:T[d<%ǒ	ϰ,",q3ԙ.R"c`8cמ{4ފ\7:v30h8ra?BY_& FP9о`[}ȫiC(ZonXT&`pTd6F9GW5cF^XW
DZ}]Mꁐ]Euf_ÊI*rS>}U\aHyxx5xr%eT?9T0\jO
]ǴImu:N7h#Q%	_8wb\PG$25{:gPuͰ
frmP;'ZiiL(%p`<

^^yhKe8`*X)T1xQJ2qr\fʰ2Ь#tshb!J=^s!
x`lP;oWoXWuCB"FMti
DMj[Q̈́,~j4AQ?sR_Q[Hf
9BBB(zreƬq@9Pm㓪'6rEq
Eǁk~	Eù9h¡m5T/[ЙO޽esL
*ݧ.
+M5|:~rPĚ}w9dq}]1?/!Q¥k	a9l6rzs:.z-Żg7jTHSGR+*x|pdzP0sl	U> endobj
90 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F32 17 0 R /F31 16 0 R /F27 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
97 0 obj <<
/Length 98 0 R
/Filter /FlateDecode
>>
stream
xڕXYoF~,j7ǀ$7}hVQTyV}gv鸅sRbŌgk[n0g7gˏ7܊x4{h_<~:_8k=|pw==.,>#^L??-?l
u ه3>[;3-ˉYf3al(fǷBnM? NVB2\(Gv`qЇw7+tm.v\`@`±<7jh2rCz,eX~w.ډs:^;s^NՓ,HkU\%KIVI}ͩVnrk^咎=i&z3p{6+dĽpgً
u7lև[de?Jܯֲ 0Sc߯ DeOPp|*|Ѻ#::Ϫ0[LXj)D dXUȬLed[:6'-HSZq$JAiU^QcIETII$UYH*'ae}8a Է"E!OIg[yF{#V1Hij=YѵKr(6T<S;t3(9JckS{i!4CUQrawN‹nDҕl,&퐃e\$ZuEb8lAL	adzՐ(<&@`Q+'`0rA!:}g+35	a'q.D8hdiӁ(^\		@C;Lh*-I"Aֈ֋6m fm
g\ul'qOFANM& DW
PJi9ksP@IIWAḰQhkUZ^i(\e(T\FR&CjMxvء:V1ޖBUE˰5g
'I7
$t8Vk8{PdD0ErrӮD7լ77uE-~/qsZSla,
`oSAM]BVωzuޤ&pwbYӼ

}=@8C]НoF#-:6#U;,3Xl
m>
Ae5+:u;1yr35a]J&&4_a:cuZ+CIeqI kKRgB/T+S9c16°b08%ʎ jՌ7jЀT*N60I
Z.7Ih|-BypqE
>I@i7't*;":wOw4PiRD~:m1.of=3-^7J4LxJz=mh<o˓>
q<']*ˉW+Lca~9\ѯ'R"
b꧛u3S7oR8ГS#حUjLVY÷endstream
endobj
98 0 obj
1711
endobj
96 0 obj <<
/Type /Page
/Contents 97 0 R
/Resources 95 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 94 0 R
>> endobj
95 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F32 17 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
101 0 obj <<
/Length 102 0 R
/Filter /FlateDecode
>>
stream
xڥX[o~W\x+J )l+C9%%$׊{n+nϜ9ͨUjT':YV6^凫W7?p?
8?x/13zljwoImw_n?||ğ>5؏T,WoWjc}	?
7ijJcߘh[-]A\kw4Y۹:zWU\ݜv{
36{yӶʻל&uzY[fxDCY
ql]ׁE\\ET̂!<+w@%bGuw`eL6;Ю~20z2Gyy&g&lqDi]jq۽O`(=	XdHs7Q٦u>tE!=8I2z6ON]y
~Ȫn!pu)9Q5b6뛶cH")!W1BXasWr8ʩz8e!0*2A!B{u9`~bow:,Jk?aciP?H$ޢN+w]C&kY{vؐq6ZY?™ 9IsePs{[~ϟ}5	2J7<w:e(_-ۺb*8c?g%&(]֔Ǫ̳ػgfiYcdgv#~Ųy9}kl?x<%XN+_9J]Q.ƏT}(}G)~b[P.I`U.m3Pvg03Y)4ũl
xEk%'lcs)3EPw|yBAR X٤A6A(bng5+6pvV':I<}>hp!S"R|>s
3
wL䳲]AUXTw5q0>}y3hs:`@rZ0F:>>!1i."`}k?K%4I=f.H
Řc(͐kx=;ruQ#L:uB$@#Uh!݆HRN	#0A@&? }r9F	ӂq	&}"ѨLX	b-sus\Ez%_J1TY߷%(u-JϠeu #cCvd:jM<;(9sNr"/,XͲ(;l;B	{bFI%*ڒ+-eA8ȷgD[pҠ`|5d}{atfj\rc|}#ŷ#bfZ
L7ooBMv2vrt6؇6Wz6
)9 %`
6mxrѬ}ns=/n,',\j0qt:
lC\7>–pMtr%gT 9mb`!cʜkB6~xG[CWOEjw
['Ou@I2Ѕ9 ,=̬o˾{H%X5Dd1gg19Ɍexz9:L+/֑ad4xⶒ'4Vcsߺ%Z
fRޜm͑CAS:Tgendstream
endobj
102 0 obj
2190
endobj
100 0 obj <<
/Type /Page
/Contents 101 0 R
/Resources 99 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 94 0 R
>> endobj
99 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F27 13 0 R /F32 17 0 R /F31 16 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
105 0 obj <<
/Length 106 0 R
/Filter /FlateDecode
>>
stream
xZo8Ͻ۽ykFE@nE{hŮnl3YIr_3JM"~͐	'f%2oROx4/=|7_:I)ɦ3clWϧV'7gPxoh퇋8{yKeQ*s$9y5?I'3T&'R[i `2M.OK4(3OEř:Lpɴ|8e̤a"۝<}_3Yʭ]=<ayYs9͎mS˸̠}tsϽoŶwLnJjqST?aO)6xVڳ[Oah'jwZۑ΄ʘ΄,I4p`&30#xQֽko0rŶ꿂bL٤I2b$\ZRydT ,Ujmzl\{nu#3~I?0tfyf\Ӷ6i$e/T6#){nS?Gonܛjgϊ6-bV]&E5,b. idi+wxNi]r7SK3Z[w ?#׫v]T((Aoa/Bu
`u}2
E|
bQgH&~xP:ymy3&)*WOMzwa&lTM^ޫO=Uiӻ7
p/.i|zw$̄#Hh:LZ@qtƹcbTl/j|LLsy[i#ux2zrUa~AZ,@W?+եeSU
‚H143„#|xv+ԚeBX7aY1n(o>e]w>J3g}Vz,EŘHph#<`<("Hµ=EqB*QaxȒVW4p[eȠ-kX/c
C]X
pŤ`-b'߰$rkϦ%Kt٭^%d5tlA@:ىEWmZ @8YbB`&4өHDpPM,nc@-l,8J;G#|O*
<8!3M4^e۬I*O] <8aU	mI~+鐤BI
Zdoh18'JVłފ1=3;O^<t_=T\庸*EA<[H vvQW	g;ʎQ(z+|I26\w7@P;jQy0י3%fv,ͰAp[%a#);^j|4t#nDb1KzPb֏1j
FePjsC`$Č/~?G9LHu{].Q3APyx@ΪS䰨fr2H7+/2ﶄ`29,ZwS
#ǁ9/RZ_9tendstream
endobj
106 0 obj
2154
endobj
104 0 obj <<
/Type /Page
/Contents 105 0 R
/Resources 103 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 94 0 R
>> endobj
103 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F32 17 0 R /F27 13 0 R /F28 18 0 R /F21 107 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
110 0 obj <<
/Length 111 0 R
/Filter /FlateDecode
>>
stream
xڝWmo6	#e/uҡA[$Mۇmɒ'M_{lqm0`1EGqlT#D(_MQEh 7f?'R@1ipqٛ)NLn	f/]3wӫx([*D,ggghBȑih`e7Z=$d240SDe=YzSq.ṟk|,`+[xݒuڶ=K翅7?JI6Vazri2At
Mhyj[ɼ-U8M1Ϣn)AHպtO^Y=KlpיٶpmGx΢-fafUmvr零x֨v̺i`C
xp#-G4Æm"ad8צ4I`K3Ts>RjΟ3`jKD}ŒI)^AG(!&"tw$8C1ۗM}y7h|yY9+r?{gc]9^@"~ywl۞mr
tz2TIvwСo&Sq(ڮeW\;Ňlyqpxx9E	<>++fk${[u>m;AUoNހA|?K]Q6&L2&5vCWG)N754)@5ss,rFUuJ8͌]buSߗngIa҂{*0N[HlfKJX^<+,Ya 85tDd}f>s&[ҁ:zc	=T&V*GGTş;g][eCp	9 !3j(`I_`ϥ0ʴkt-bqBa{VϥSdIϲsഠ/Ҕu7kJu
Csnyˢ_s¯2cC5ȱxF9 *Boɉ&hi6('=@쵼/i\;z㙱6'5O/;UZ--͘MA^hDn	#(dklm8Vo^,Lana8{㛃F'nܓ`ے.|#$2@8rly1;HI
]SoHe%w"Kw,Y'շkB&Jh)mo/.xf2A^ed~{qJ4
U%eOikQd-&S81eip9A٧]X鱀mƔܠ.ynIzmloo<.bwWCsw*tfT*LICneȠ=F5t^`0v蝤{
ፂZm
]DXpUXX8oXtu39#u֠(~Wx㔷H?{"-,aFjBH<(,8xw:KZ/=wI,ɉp4뮾oܧ•/CcNƘxA$Fendstream
endobj
111 0 obj
1614
endobj
109 0 obj <<
/Type /Page
/Contents 110 0 R
/Resources 108 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 94 0 R
>> endobj
108 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F31 16 0 R /F27 13 0 R /F44 112 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
115 0 obj <<
/Length 116 0 R
/Filter /FlateDecode
>>
stream
xڕY[5<&
]C[\i$1
Iū}iv=|͓IOHYR7Q7㳿={Zg7267w[yW㛗?ݽvN]E|Շ/o,{;:&çw5?]AF~DX,׼=*lR7Жiz.{J{ˁx8A<Ԝ|n_ϡk4Z5U$&s
ЙΔՑzYһcd׼vtUS7;TƟ8uԠo[;Tɡ>1#(@eD@D(-in@4@Lxpu{|8kP2Cz|QDTyy3-T"`6xЂzPʖ3s]sۆP(nxm˭kjZ).~&6]+fB~ny)YgJauKÛjhN}
2oSߦ0xєG@[{0Oa6l#v0qԬ'\T`˖.C8ʓ}'Zg/^CžZ(}{\(1MN(I!lx8p?(Bx;DuG.0(@Y	ƁА(sRaF(@8䈸x;ϡO#@)^331	ԷG?"HͰHb+cèfª"&=~-*]"`eK P(!8SQ>B7#fhƀ*/bTYWXE˺Vc"P1jBWE
>i;_0{%Gk
BIAѣSE%IBf9jمC;^\+֗pbے4l(J%ok=}t.> endobj
113 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F28 18 0 R /F29 117 0 R /F39 13 0 R /F31 16 0 R /F32 17 0 R /F27 13 0 R /F20 118 0 R /F44 112 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
121 0 obj <<
/Length 122 0 R
/Filter /FlateDecode
>>
stream
xڵXo6	UfZH}lElhB=mHU\INlQۭ}.f!E(JE&YP^X,
Eխ\?_]]=7_qbH,xWL%^\^D&|%߼e"ˎU*RXr|uJ$:٬ۋmcg"G?ݚ~BErz5]mӚZ)͝i?/p-uK b̮{yijp/Ŝs}53z}Iʿp@xcz~:wRNȲQCᦞ[[;4aPJvڣ%1G1Y.8ʖNJ:*~ rG),ESaw='*,r[ORr~؟}ND*
:t2
Qoݚs?An/:wSY9NH$+orvy0S_I4u$tho,”WPqȔe=,A$ց׎v_9I=ɓA'}U%u!Cn(r3n@ a
wu@샂Ff!,-Pyظ!H3uy/]kcZofKvqmO
\|NoSƖ[*EpYPhh!)1H>m`OG\D^ڢ2C/oOBP[K|UNQi_`Rt$..:pq "m,kZv60xn;YAgEu,#I=c
5V[h:)nۖL7i3>"_[XTguyүO=؊vW5]0x ePse
|ы|#W0IXJk*z"Wv	u1BRl0Hxà*똵n5KNLz+ǽmSPl!kzLCn?>Jf/ 9wcD`liYrUfL@˰ɺk-_aKС?-S;iqiMSBƸqŅ,^> endobj
119 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F31 16 0 R /F28 18 0 R /F32 17 0 R /F27 13 0 R /F20 118 0 R /F44 112 0 R /F45 123 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
127 0 obj <<
/Length 128 0 R
/Filter /FlateDecode
>>
stream
xڕY[7C( r.E ^ IkTH﹑"W\7
sxxf\sfVU+0*:?&^(̣|usK7۟.q1&\o4zrͫX}L07L|}n?.WӵMZAdyvu,Zmlh2q&10&V_>S";,4&9
Mb0^o6+?UٯA`Q
KĚ^~cn/Q:ftAs_~1h0۲֭x0o|[^,}Y(lNvEòx-΃l+S51y7y8`{jʻvXjDƘÇȓ`D(~9[v(Rh_,q;]@޺-ie:s&+UqyЀz2aAS۶ٟ	w?Pe'H09˚"zKT$P=
N慀߻l˄8
db۲D<Š|5FMFg:Y*UU֮_-W@XCjcTfy2S[q
"il5iG[3kӠedTBŔ1=bds3QC+T5HqI\w+qLܖE_6kKAƐx7;J9=Qv(u dDʻz
G3
_pQjJlj$P
!8ieٲ
@HiuuYxlX&=Iwxs-*#سz`iRC%%'9fm0݇5O)д[co;vcGJ*
恊4l}e'FGj,~b}z!}9bNC_ ~#DF҇h`fdy
 9]љ 1
ii/LkUkm,e,:]|-	a!Kz=SZ7%U9$z0ƚZo݋/**D0ΞIsǽxqc,!)uMrЂ<$e(=WZ3D9W]b2y=,?TIƠ]-XSXi0C`!`pp-Rr4R&qQ,'``P`Nt(N-FM؊8}=0[Ls@Z4<±1LvueM~Pe*1eKd߹ـFB~ZCs$[	by$8*3E0+d#?(t-1{8?\3۾4;Qj-	(CX10~55KmN8Q}o}jJxlbna)Pŧ\ͣnL`Fy0#T;&ͻ8}g-zP/_N,LQyڝ%`ͯ<ʼn:TblyʶOd2azYqIJ-ؕ>alDv濠_5}6S훁%tx*	%r./l`Vt҂u!WjDaޱ^l\"\NN9uFL)6OkDPM)#ʽ@Ga3تȅ1e
%Sz_rhI뷗K5:ĵߜnIN5qk:<f̻!j6&3,̡I	QVzXZxBx S)Hઈ9
a!
LBqkg͝&g"d;QtJ>0I6m6$N.WHDV!R؇N[m)qpC<Ԅj=~Hعn~_i%qu!A|iЁ#k
"2
q%Nț̀3_i_8@ϋ&QIpUeFGr#\CJ8OJ2;R#WCc!uۍUh"/ulW*-8W0ee*fq<%i=mܝ
nL~뉱ݶ`PkB8~.5ܢNqqn|Ț?Hki#h(~
vY$篮^Gx	/p֮/.{6O}ΗLC+rEB"\i/
O0p}}bA``=\_FVfN?	`tZ͇*}#_k
^Q"Z}|endstream
endobj
128 0 obj
2715
endobj
126 0 obj <<
/Type /Page
/Contents 127 0 R
/Resources 125 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 124 0 R
>> endobj
125 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F39 13 0 R /F31 16 0 R /F18 45 0 R /F32 17 0 R /F19 46 0 R /F40 47 0 R /F46 129 0 R /F42 130 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
133 0 obj <<
/Length 134 0 R
/Filter /FlateDecode
>>
stream
xڍXo6/c[]k{6T[IsLr|!I")G:(_<<%QΓr}f~6QET'9~<e,x,hj"~yE{'nw8dqO)"lke++!MAh{k5h!cfq\k466?bb^K/#miԃ?#|"nͽq`7{YųY$+
U[.m]MHQъ"A@3-0k6&JJyޭS#pLJ=VN=;*jY1io-	l1VV޾2ɨA8)-bC-I	$g%pՌG[@PHt$hRV7Nd7\}
VXv>ƶ=FcE`D-Dbݤ_M`X ٯtWp^nGɤ$Xp?LvyL⡿{>mj#y0QZ 7rMx$B3_?`endstream
endobj
134 0 obj
1837
endobj
132 0 obj <<
/Type /Page
/Contents 133 0 R
/Resources 131 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 124 0 R
>> endobj
131 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F31 16 0 R /F32 17 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
137 0 obj <<
/Length 138 0 R
/Filter /FlateDecode
>>
stream
xڅYY~wV4	fm/<_X؇F"q
Z)ߒ|vk?,Mc&jSF{;wK]LxIڿxհ{.{`oRY\xV*ȩJ)m*O/VͶv&pr,M$R MnPRw<腆S>va`O%K
s(l
wWM<#T4tCE=!1O>‡+|cLIj8>wnǝ`=>܆^ڠH_\Ǽ+`@\[&ڴ̳΃[:zcC)MXІ)kv\3z*[؏x؂N6+MW(hBU'=(AW5`B/6OQaS(}b-oIwsUqZg|iV;,ҸTb4ğ\Dp8,IB_zKYqj!Ch×9ƆKsyg	RA mx.TLCZ*b"0}I-(kt==M$Mfl:	U7U&u
;F#LVnaB|^oۓ
yrhۼ`]?o!9Q×m 4fjn͞"seq	ZNZQ٪0@$7r%evCHFmPkT^vHL`x>ޚ8Q9AGK@c@hsh#
,̳◒
XӵIϨJ.h=,6Npw=1\,*.^ͻBxc&I\fSZF@ݩ@
0tȓQ/
> endobj
135 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F31 16 0 R /F39 13 0 R /F32 17 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
141 0 obj <<
/Length 142 0 R
/Filter /FlateDecode
>>
stream
xڅTMo0gGےТh}vPm%ؙlw~HQ	, hz||RD8yA..>,>UխH8eTEVWn\ݼ,C!|yo7encA`_yV}YB<ҟdQJ.3Y
\E`u];Ĉ]``	cLWyy`?V;).(a5F;գn|9Vۘq3ؚZP[C̱,~Kdny"af VV!f`W1͙-t&SK24#gj{9dHNժ#G2/E*x.qmp8uGUc	ti,3y.Ze:
υL#QѨ|D
2Xq''b@cfQcO>àVT%Y=]G6r@O3d9d,˅ҲBHlF!2@0q㞶9!Q$:M*8j>gxPP"k}q2	nl
j!xe9:t`HӴ-&O,o'NS	\whg]eV|e4{	Od--qڿYnt(q=V76endstream
endobj
142 0 obj
729
endobj
140 0 obj <<
/Type /Page
/Contents 141 0 R
/Resources 139 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 124 0 R
>> endobj
139 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
145 0 obj <<
/Length 146 0 R
/Filter /FlateDecode
>>
stream
xڝWK6o֊(RޚТAvh{JMDT=yPu"X`I73rßHGERlԛy~w7IeYۓ]xq4dNZw?$:ʋw
HӢz.^<3a|QEA?}c[I)&3γndq,*ReIGvWhQۓRnϣ	=ߛqG

/ڛ*\Ԣd'^Sǂmmϫ+1N\7IT*yR؏ohnJ,CHhbZJG۝$ Fެ\T3A	ck+im:EhVgPGO
ς%
h40ɇG0
.\|>z6_ۑX|_V#.]F.0'$Յah;%(B7Cmo3+l5@30K	DoǑ,V_ِYTmKCT`uBqe:.j{l8NP0ARchD@hwc\S.l_j8N؅k^:&f8؉70:=uӕ?)㴊@A:23ɃWb!)B'W_^+>Q).FdAahD&ЅR1wQ"u&wEW/yY#Uif9)ϘQzN4d+f:R:5nMkT/vaK(Wzw񣄛rR_!/:~nO>/t{"H|%~c$ǍWw7xendstream
endobj
146 0 obj
1468
endobj
144 0 obj <<
/Type /Page
/Contents 145 0 R
/Resources 143 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 124 0 R
>> endobj
143 0 obj <<
/Font << /F37 13 0 R /F34 13 0 R /F15 14 0 R /F39 13 0 R /F29 117 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
150 0 obj <<
/Length 151 0 R
/Filter /FlateDecode
>>
stream
xڽXYF~_Rf7WX`
<3I8bKE$x.a
6Uu|U-< ә^n^bOAvOG?o?noV(|iV:?W7?l޼ǵ߿…7޼߮ؿ^en>_k54H:CUM`ȋ,Hb`}ۈAp5L;P[{jmgwM-58*Bdr]I5Tjʙ7f߀Ξ&Ȑ干g_S܍xv6{Wy$^69K3ߓۃL8ץmK|W"6[USې֝Hf;}[]E22:7=<M*NBbp\
FF{t}?~s0x*#+˰JVD~GʹbRsO)bbh\八ѿ;k31͹*G^ڂ׿׮h/:b(VkGs˼,N\)	+aAg
آ{\-YjAu1CID
xQjcf+"h`$q

	o;A%-A"&e0Hp 
}G-N1 ߌT@_̚4e-eVt~ 
f;K1͑"dW
G"|%O16>RIb7o.]Y3h.:lUչMt8/fS
ͦV6lP-AJA-^
BC!g?]K݂_P5gi7CxJR&u(U*caB;inj6#|zљq
%zof`?J4nG0F\{n`V`AuJ\L?hتQ`u$ υ8[X!87wcF	P06SX2SbS$Ӑ3Q&
~sB:fHHCfAC(|JV<lmԇ`^ $v)*ID"zGH"Lx2#4_h4%Ci{[b=f0
F0'25sZbNE߷W	JDq^
wι`܀=2uN3Ssh5MSbvLP2S
i`J=Ks:6wz=ʤIěAɏW]moTsV	'-1%!Yendstream
endobj
151 0 obj
2001
endobj
149 0 obj <<
/Type /Page
/Contents 150 0 R
/Resources 148 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 152 0 R
>> endobj
147 0 obj <<
/Type /XObject
/Subtype /Form
/BBox [-1 -1 380.799 109.9]
/FormType 1
/Matrix [1 0 0 1 0 0]
/Resources 153 0 R
/Length 154 0 R
/Filter /FlateDecode
>>
stream
x+263T0BC=+9K3P%+endstream
endobj
154 0 obj
39
endobj
155 0 obj <<
/Type /XObject
/Subtype /Image
/Name /Im1
/Width 422
/Height 121
/BitsPerComponent 8
/Length 9106
/ColorSpace /DeviceRGB
/Filter /DCTDecode
>>
stream
JFIFPPC		

 $.' ",#(7),01444'9=82<.342C			

2!!22222222222222222222222222222222222222222222222222y"	
}!1AQa"q2#BR$3br	
%&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz	
w!1AQaq"2B	#3Rbr
$4%&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz?(
+]Rdo7dm".#b݄ *V-a>Tj!G#n%H?‹9DU_Nla+OXJ``vJjxXkC2iD1It&!P6*|fl@Ey%:wH6ڦR![x%Ï~89((znHK$# A!p	$xOWCϓ4_>gv]tW??wC4GaAUtW??wC4GaAUtW??wC4GaAUtW??wC4Qke8BcI4Y,.I=qhnQˇSuH̻e;28!X2J((((xmm常8`$Q@$W6>!]/kE)kg2F0W'HR}M7%PAEsct?MT}M7%PAEsct?MT}M7%PAEsct?MT}M7%PAEsct?MUbPM֌\k#1sI@RE:Q@x]U
ޝgaqY[K"9YݥG$0
Mcz]#[ǡZ:݈K.l$p#9@=}z>G-4n_pq81
"Um'M7P.]cv)г+
Ar}
"+^Y|rqbTmb}0}=I%ә{ג܁% C9((ZM.[7LR'Yk,w/2]QEQEQEpj_
!_sC#)fK.vn$s3goMwJbuY%W2HH%
"rFI5P5>"-1@ﰤq/Ye?fpR]|>ҮZkl_/tUe
u`HՏx+M)ԗPlUw#IY۾Mc]JmCS1ihrHn.ݎ|xUW7u+xcBdD21Cn끁Zn=OuZ(ĪN$@I#dn5%ݿk{eSQJ-,"Bjx\O?ɵfD\R~^Nq$V6WCBRIZm&RBF0FԾݝ߄2Oe`ւHB.H'8O
շ/[^ؽzOlMx	.<."[C54
M.~1JNO_n]={cDAimYd#ͪ9,8S]RJ7vN7	"=B>cv~Ö/4xWaOl?儸@Lq@  Egzy_ڭ/w	c8FqV<X5MDtV98]Bq'/xi"yO!O&GsTk6rֻO>(&5xTF\#P	P0pN</>>xIO&?:DqWs.0ր="L򭼑9B#ycTHl[=։mkjVu(e}2yDcIw.,1]}?OvF[L˨V)kk.rjWʟlEv2NL*:C*]wc+֦-t[#st93%ld8/cBF]N_)o
I,VbU2CeV*9QxRԬi5j݆hQR0䌐+ὕ0zɱ䈥hX
1e	utƒŚBng)Rh.au=TnSrMrz޿2+ykRhXuTJ̥Y7or6%~c'P[0[2Aom`j?_R'硅Ua+&v#.?hhgkV-VPde'޻ `q@Es~5?Ie8
hy*į2)9T:J]69l2p2H51ס*
(]ORjwٺKe,띧<$/+[JX4'mnSRz1xZGldq䬅G@>rx#;dOx[ÞCi:
n<.<9=8@vs$ڴo)"JǿlaӌV'Oqzy7Ï,m+HAɭJ(
<GogjlkifS0q&cHPU[	JwjȰ9xB1}фbH
EtP\'Oqzy7Ï,m+HAɭJ((((((((
znE$n$"HАFpH %X$?+Cǝ4>g^_3nMǭtP?CGQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQEQY	>}ܿg$YfڡQ؜8S
U$nYm5=/fchGOe=ߛ/G?s?͗#C~l:
+{T\6_G#ڧzz(S=s=G?5mm9B#y-U* ϨѵүSf~yHb[[k2v((((}oi7yv<>vXrp@(m,mS]Rl-x4Ia%rqd%@n9<ԟj9GOe=ߛ/G?s?͗#C~l:
+{T\6_G#ڧzz(S=s=Imsw_iԗ9K;F#;E"UvWU*0@
(
(
(
(
(
(
(
(9L?E{hK]sWfM]T\ޛ]PZ=,Fsr+R9L?E{hK]sWf
&êC˨Z&2oѦQ+#gtGrCFN$Rxpt;gQrv{+X2$8|ndoCn(eis8#t`mvyC~P77Ae3N	쬅3S)b3&[ѓW=HuqӰJI#-¨i `#5ڕ>YݛYX@IgBỲ`6˨ дglfYtbUxnꖺ-=αϸ!rFRa`dPb4=5<{I_by{fF#ev!dP?|yI07l;sgUiv.o$il"G*$t<r8fH}+<*o,'%|m{<㡨C/J4I6R:sΪN#HFkCO#kæX$	F.
viV:ՃXjVZ;2rQîGqGq@?6x/7Z%ݝmulۤf )7(rGCk*5[z};XV%-2B3}\Yľx5g@)6^kuW7}z\.խHZdpe
עj-yaut%3[d+V$|:18!o–7 CP
T
]#LWyK	qg>R6޽qօ^hjm2/u}*TF	 |l_|Z%ݝŕż6VͺFhR
nP	8䎇8׬jU`wVpnQ9W?'MѾxK,`m2;XV%-
WY4)6WZay~*k^v[&]fd?*[ji͢͡|M,e2+yf͹bwI''5Nhwi&5xn%Y.#68b1#nj^.zC7@m]-ź4ϴ7?Rh߈qi|@Io3Bq|rs⺉-\Mu=4p^y\r**T
a*9#܉wvK~}:H'1[QP87+g[_&mN⍞E
s>,BC8M3E7i۔S2"ʁp8$T^ZXX^OuemNXuI߯u|\crt\2,	v~2Fp\aQ?>
/ProcSet [ /PDF /ImageC ]
>> endobj
148 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F29 117 0 R /F18 45 0 R /F27 13 0 R /F32 17 0 R /F30 15 0 R /F31 16 0 R >>
/XObject << /Fm1 147 0 R >>
/ProcSet [ /PDF /Text /ImageC ]
>> endobj
158 0 obj <<
/Length 159 0 R
/Filter /FlateDecode
>>
stream
xڍY[s
~z+=1$wyt:NNdkieHK&V}q#EJt@,|p_ϢlbzIŋ0 _$﫻R2M3u{>?<0篸/ww_WY\g[z
{)ֲc*X,Pq'1*]lB9ȨW*9#9Ʒyz0ښ)B?WzEteBcFxEO,J͢(롱uE3Ն9mc*DTI,cۺ+q;U
xt@rMaZ6Qӂ	p:̼w+7gZ+X$ۡT$sXeҾkSG1Fi%Csb]F\g'ر%	whj5\Rىu
ޏF)D\˿)ۭѿ;Kdg କ]^=icogퟤ)gڳJSZ!؝D*ﭩ+VTϢ08k$z2β(TCcP7=fPJ'1Bڡzp+>C݈
ɘjOFvtǬN;x^eS̈́@eѵ4C?r4	oxg͕վWݫsKKB5k$٧;c5\Cgi3M1oq%#Y	
I'2jaAXF_;J,xq/؅Tù&0ULMZLz\pmWbc
u:78ӏ\RI5'H3rg}veHDň޿!{\A;q³(^@yb[Psq	Hd#l>,lFrP𥊟7yiB	0อRo\M8N5f52	LPLoi#SW&iK.:22߃PZ6jo&e{wx'ǍYω96ZsHjfo̼fg:|bO64ȣЩ D+X2^׭1']L؟<+.Ys"fؗ,є,)%)sD,m֞z4}R`+|i,/SL̕!1\_s!txN5=9?\Ҁo`B -VY;KI*؉*(Nmc	d<|U3o#g+ j'N-%uKC˴mS> endobj
156 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
162 0 obj <<
/Length 163 0 R
/Filter /FlateDecode
>>
stream
x}YIs8g7HUY
p;:w$hj=}I"5iGm )N@,[+~*mfT[wUos?_D+~zEMfޗ0>'>|CGl(ͧ:uO?wzk0?+R6UJN|$yw{6jh6`٪3%QD6KxUiy\o$3ͽLy8ucG
8PqЏ2]!סU:p{]'"4͠{^=af0cNܣJaơq*#:V,x47{C,ka:كsMOzO'9&[a'	!$_sdn(#CIbO[֕=xwa5̣S/>hR[jUNwq1?*+yԍd
h0PZف&z0'ntfL$0,* ܃7ٸI
ܼ/Hx=LK"BZ]N-R
A_a۞'-t7\2l)@EGJXՋt&Na:HUZdE
nxU%g^8B/Y^_dF0Cp9V", ˍgtKrs_3lFw<%ªB7Ҩ!V3/c1kp
ں}<󨶒96]5hM/PV:,Svэ3_șjGq]uywE@5p~u%3頭]9{$;Iэo	xwrMՆ3@2iL	waWf3lx^sZO5䪭(3_jDPT4=dSH5CIGdD0I#w/Z_8,&pUh:FBIBK؈'ıqK
C6GIYWv;e	!V*FXC#2f.Mlu鞓T
dڣ}pLY)$>-CUD.ĤC"+; 'ȹND/D	|y8E%M"!$$@jZ Gۥ`ZwZb
-# :(ø]]&.[APLz؛TDqvp1Fb6.+L5'N,GP*2S1!eUt*B\%]P/Iک30π 
Gt!޸[#ʆ)!HB)'grer5[!2(ImEW0SwQJX0U Su.> endobj
160 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F32 17 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
166 0 obj <<
/Length 167 0 R
/Filter /FlateDecode
>>
stream
xڕYKsW0)syT)Yy%CDL$@_~ 	YNAϫ_w,?92NYn0l;mg2EZ̖rW\\|/։E㧹*|㉟o~*&~9w6;,o?wr|6ȍ	7jKnWlaL['2.ܬ+d5	(m'>ph)?J&+{^+x!lqI_5}~w,;Py(
( Vl&YnVpKx[sRa>u*%4Sp 
qr;\yWa){vx~`
0ů9 &I<<6-6ę=y׫f_cwdNP
3Hb׹xf:)@:)cv	vM~	~(EV5#ZBlA*q'F#'BvdJH=`vvU	::AQyeGPX<#M#G]Q!'|WjڢřO,㹲>x#ř/T9^l;jJT.CJȑb^;s8RCQSAn
8_)*^LB"LRPP%Ub2ƥO@!~8y-g'\!$%h_
uJE%S%ѳߗX*,$
 tx,iC> endobj
164 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F18 45 0 R /F30 15 0 R /F31 16 0 R /F19 46 0 R /F40 47 0 R /F46 129 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
170 0 obj <<
/Length 171 0 R
/Filter /FlateDecode
>>
stream
xڝXmo87ɇ*
8n,6h{X-HIe[NQ3gc3,<ڽy|Hg,ˤ-Ns=Bx"b5*BCR誣&FO2IKS>?	h7K+bNGoʵQFSb>Bc+mG]@s_s/\^~V~qnm7k_s5LS)2#W\g54H8r2LE
iAC$o6\$SQYD1T1~4,z坦TQMmw4DAޛmڪ'xE+%BNeJ}޵݊"}S9C0`;W+";BoBI~HIFkDɳzE)CEH|$oUثG2C3rk&Ӈa⨍
xCD}`$)
?Fc	q`JS7e"nt.y%].䕡Sm42*?U6o$?Pa(^b$+Z7Y@hҳ#Fs8H>>84B{|Xŝr1e1A^#tGe7;s
zAѝ/AhP6vpfǖ
\@C3瀄Zh>\v9e(Q_+]K/|y%J/7vc9$mȿ>}]!"Rgl,lrqq> endobj
168 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F31 16 0 R /F30 15 0 R /F39 13 0 R /F27 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
174 0 obj <<
/Length 175 0 R
/Filter /FlateDecode
>>
stream
xڍXYF~
z[
ءn6x۰$@lH<3[I vW_u~UjOD'hī|7]OtmUWqx>u|w56wsvsy]'ֻ^'޼{7j~Vhb?6FNCb}opď,L4Yn{D&~FjIc]7Z'^6K;8dmZmOZlpz@X>u9pj뛶Bh߷cOQ
wmeɎdfmOFFE6٫@+DɊJ
:V~*AmGi
7ɘ{:Te^3Y,dA\wEgnQ.C=if]1JZw\PB̹gG&Urx/>/Smh_5}u
	:+$9Fx=֠.H
tIYqP/9Soz=4J6`C-7-;eO(^f;ϺA`Ӻ#(L/uٽqL
1zHq4g4A].I	BHO)+W,[*b'䑗8py)u{W`J<G]А_&Ln}d鱖>4C*Mkԍu9-S0 f9!Әd.0HJ#9	}X>c' *&$3[Htuf=L^
)5Y]tq*@
f--!S@jjrha~jyUü|=%E!Ҋ	`FY7R(L=(To_$])&",䇱oWJi}X4]W~'B.y]AZ\$@SSBWF]h>a_`$NeWqv{X@D3
2P!xNvD񴇬w)2P9C,
h
$Q2"ans7#~~3XW}@
=C?E\Eɴ5ۀ8OX=h?8^
&˵\o=\1kp֏4bh#ʘ
JBI!SR'KDX#{
'a]/yG3<
f9aA!kʡF]
ɛqd)'(n/_,ď隋g]/q&m"BJwD@35ZP/ZXv{w+KI}RU?{MOF \ύM
Pn d,-X	VF+KY;I0ΩސR@,+pU(1yLV;)5Ç}VvX%Gn͗9"C'YjR{,E
u>5[t	˗N/+endstream
endobj
175 0 obj
2433
endobj
173 0 obj <<
/Type /Page
/Contents 174 0 R
/Resources 172 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 152 0 R
>> endobj
172 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F18 45 0 R /F32 17 0 R /F39 13 0 R /F30 15 0 R /F19 46 0 R /F40 47 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
178 0 obj <<
/Length 179 0 R
/Filter /FlateDecode
>>
stream
x}Qn0+|6+vi	DszH)H!ANjJe=;ڝ vl9O4/0AZb[<߻PD	1lQB\j3Xk@S)0ׄ"CXuݺpH{[6]]@e۽fs_Xf
5	0q~~kL9"ڛ3WAl|"#Lհ5%͍QFdH3?:ͤ>!Қoɗݚ%±X]yolUUendstream
endobj
179 0 obj
359
endobj
177 0 obj <<
/Type /Page
/Contents 178 0 R
/Resources 176 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
176 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
183 0 obj <<
/Length 184 0 R
/Filter /FlateDecode
>>
stream
x}XK6!GU-z֤	A/zh{JXY2Hj mEx8
fjUUi׫2oRU雨V&-|ݑ;ҫv *\2d֙ vތO,l6&"MCC^ovx~,iM&>{#Y+Դ-3:[wC@WMƎw+H>CE^&]ò7e7]%Hy^yTv#`'h218&3~VLKRf_Zc_0,/泈l/"H)tz0vl\]kM-
5\18R]-(v:2ْ$BňR/~?>F-+DeЪ.jƔʴ噅lXS%ԉ'gdm\abg^&9EYVnh^q>0c_U'j+Ȩ!0̬=Yҙ;3ho`1#$G:٦;\KoD,!(
@q`COlX&@=>*jaⅲkc/`BCWdI$AlYAv”Eرĕ{0bQ{&ȝ2/PREXE^= (c!@ޗ_:'(;dn=6_U&ShΣx 3{Z)NRm;[H3fϣ)O.⃛k<,TJU</4T#^upD/3&B|xf-P;C^Wu>*TzƩ?`-oa
U(92{&!ɐMjrvrn
v얙uc@jWf@ofŒbaƩw?½Ҿ(Z:/Q,~*fB6arA4`TАAM8Ȃ6ckWEorakVL!w\&`Q夳HCAۆiPԋnNt0
B':&:Q|8|obART/ć2;U`˂ZpఋANsl<"(Y0CgՆc[1@\D] ^"+{IuRuEzjF4,.hg
.;;LNvê2I_\X4(1`1UldAҤ2:_*xT)oqhh[9{㞇nmRC1;ʡ
N-kCbTO!|~bqDlDKpQ"{̀G4ب*|&[t?[蛻 
x[3.,_t(G11Ê*h	1Aj%%Q;P]'dv/twght!-!ptx?۸|N2޴O1VTA7v .	U/Bd*-I"4I|sMCJE}8(6"5>gYoPu|@5In!߆΀1љO-hJ50Me%-Ow_w_Bendstream
endobj
184 0 obj
1721
endobj
182 0 obj <<
/Type /Page
/Contents 183 0 R
/Resources 181 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
181 0 obj <<
/Font << /F37 13 0 R /F34 13 0 R /F15 14 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
187 0 obj <<
/Length 188 0 R
/Filter /FlateDecode
>>
stream
xڭXrF?&`Cn/nD9}(&X(5[upZ^\jOB]sw&]$.r=ѻni1Diym?׿o;5flfᒛۛdʤE 6epD-XcؘlH-ijϬѡlh];n)~yۏnte)]Z:+Uud>*APnntK3ɕiiImc	3*vWk]cnV
f
׹Ku|W_"y{Y8=sPx^pM"FBkWp.''2Z@Jl(biVJj:y;ڣzxaNXa[ϡ3J6b_$p#uO/{Ґ;[\.Νk\:Z&9/P[0k@RР/dT,Ʌd?"l*[éiF*Oxq}Ѭ{閭H$hΟ0 O"-B!ݠqE trY1'MtB@[3
@!;Ipi`lEۣئ`Xot]_WLM?Y20*QypIhsZ9$
f!̱'\:TWF
[E),	~
-p%yZ%)o}-GwIE<<pKSJn]*d>rˋTPtj%A[?`u BNXT#"VVAF4>p2.u*|H0P̃?{nF)bl>XD<,;·0&	^é„RPU6R3
f$^1?Pj灔|.ލs.	#y݅;7tr.\Y,	[ xEe"ӊibIwB=ij&E\5`Ka9A¾sRew{Nu	&3Pdq*YTz˿*k4!qa4P
?f{V]y5Ħ~30-S/6̔D
:URx|XdU~zPAݱޔ8pŋ*VXCAendstream
endobj
188 0 obj
1970
endobj
186 0 obj <<
/Type /Page
/Contents 187 0 R
/Resources 185 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
185 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F27 13 0 R /F30 15 0 R /F31 16 0 R /F32 17 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
191 0 obj <<
/Length 192 0 R
/Filter /FlateDecode
>>
stream
xڭXo6?@͊"av֡ن=2%x-)*
C<~1˓|ɄlQ^^jcVb}wDm}~BD-WYG뷿k7|xLȌeR"-W7xLb!TR(Ջ+؂="gB"Ls\%*nuk$~;c*}HDDeEG,n-˺S?сmHW^OHzFÏidd^q,<eY9vȄLK
9>}I/({]"`
%PٲquIÉva4#Nrg۽g4qx}[@U]i~H7HKeŁ<~e8]鈺ˁ;?=X`ڒ
lȡQG|(9N7e<Ŗ	0_YhX(VW}c>
eƧi1ncp4eM^ɕ3<|CD$p">) >(&q6b9,Ek`R~>+;
BNy]p0hpXad ~}"mtznʸ2]"u_:n٤ۂ%\xL,W
H300-E|IEL7<ۅvoMSm҆%j&LS:
o,r=Vɡ3)6GR˙3)7vP<%Q$R5COŽvwLwnO7DIOM{]
w ۇP89&vKCYI)Q&w() ):Hh
ԨI̪ʏHSgg|Xm۴
Ie*`_zT9=ypwԿdtҿ)7i&W
$+oByV< ejW2(@ti;
 
|?#J|]yJwHwzVBIp~+]4U@숊A<t(NaƐY8~Ә5$론ڇ%*d|"L4e94mꎀuPyxA&k
zJB"K_5xS8SYߓyEu2s>,CKR~Il=~	~lW3%);mН-Nj?c.)98)Rn`ݑRY0HX\qfTYܘfi}g*tXRXQ!B3(&=@Lt"4ʌW=%M|q+(7uHĄ<1fq
@%$ε} Yw$so0&ݮ+p0L4".C

&~pĝZ6m~i'qs-pīm6\Y7FITgE	'd)kCҺc{ݠaj]TkfO\ȡKzZk+ؗfu'
FrU aC/_8#jk=	Mendstream
endobj
192 0 obj
1889
endobj
190 0 obj <<
/Type /Page
/Contents 191 0 R
/Resources 189 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
189 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F27 13 0 R /F29 117 0 R /F31 16 0 R /F32 17 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
195 0 obj <<
/Length 196 0 R
/Filter /FlateDecode
>>
stream
xڭX[6~VI$o"iHE8c54df}M((
,rxx.߹&tel2)urs8yJ4mb7{W~w۝R*,M~_?mWe\j-Adӱ.F&.r 5774JDY	6ϗq]f*uȅn@RG=_>=u,J.eI֧ۜT#F.mkT䚺Yuke.3oqBX0i~Y2n	>t'&#R?7iT_CV\-epuHD0	Lxp*r p}Dl| gdD<&j߷G`?ww<BC=ĩM/wtx
vښcM\ 0aWca:Hڀm;دv*6UfTě~M&jrEn8|5y;X)TXЁG&ǜp:D%@
ZkE{MY"dR&Ђᆱux4Vphû7̤ۏ̂[q@kl/.t`1terJ|9$jNԙV1[vy8?NhNӥYyEjN%MZ*",FNTPR`Xu+d%1]@X):*Bf;ɏ!EөFVwcוkE qiE0饔|@3	7
2%#i?>25:r`,KLF++mZEEXqх9ݮ4[NrQ0lޭjJZc1wTS>`i=]6K-Zx7*X/;*
ac,
=M%c#+TJX[_gd8񥀵`xNiRર#b#^˻B79'/O3wW`Np#RO"9%>PIG6hv"
!Z|iE
ZIkV2*^HW;TE2)2KH]L+,~9z\r4eKi&QYY^3!att-:g_$s
|<ZբlZٰMyOXRx29s*趪jPyk軯U|yH]xDc#B%.UFc]c"RSϫϭseSř-XfJ{&]3uO䛖|<-f@j,Hm@˔܏4ݡ-n@Itv
KYLN	x\8ѵu{hFznrPsC6PT8:zS<qwAC9ckg<[NJ(s>N.k]R찬Rxzˏk5PyH80fnmS~ww}\,i
;I?M?endstream
endobj
196 0 obj
1989
endobj
194 0 obj <<
/Type /Page
/Contents 195 0 R
/Resources 193 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
193 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F27 13 0 R /F30 15 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
199 0 obj <<
/Length 200 0 R
/Filter /FlateDecode
>>
stream
xڍYmܶ~H(
$®H˅rp晙gt&&MP"VŦn~y^f4gx"l|`\Dߓx!:n@ywD+
k\EwO-Fʓ9dRĹJ}xV"5/$	:	gEy[׵+2.D3BᏏq$D3Ea?b5Yd~_7_0@ݏ,z3c9ꑃkܨ"9ފ
"!D*]ijt>d!K!*(q́^9qr#MxDZ+	Ѽq:Eݱ)gSS?x*MtMa{WT_!rbYbMS~+1۽">6#9­!A?vHYl{DCItL1p[7vn9yОAd*'m3L[͋fȭDTk*Y-GGVV4<kt
T啘;T2pa;];joMV9!@:jF6¼g/_/to4lX"m
	.:NQbd{|Qe\*{|20gx 2w>W
HYJyc>㴁yJxcGCZYn+G%Uʗ%P|4'8t-s
Lk,#3HwpNF֍?X|Ujਝ}5)z6
Hz@E\恍əN@4S'p'J@_ *фN|gTB(]w*WVy68B0ҍq?eeqFW/r
p pd4.ja޷Ӿ{ɡ9ԷE2;~ifv*/{k`N~Hy2P8ϭm$ŢE|dPOr:oJPU/fXkBK[M+Nx{7sSfN#n9?@Aeʽ)AWBS5!|R(M.a*8y]%
)V~A|񕇻y=_4k`.xlAICn<54+Pa73oz&O]v$_Ue҄mL~TLEQXKR}wxHP:*b9w
:n|
n!|@"HGRN[i㛵	/
w?ìNADqj.`Hxq2kbT))f>^K8Za6e9uq-iJ"Ai1(Qf.7X	sWHs%.3=s~')@k8=?a柛9Qjj8}V}x"Βtz=Ui˩њ_Bp@lSendstream
endobj
200 0 obj
2489
endobj
198 0 obj <<
/Type /Page
/Contents 199 0 R
/Resources 197 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 180 0 R
>> endobj
197 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
203 0 obj <<
/Length 204 0 R
/Filter /FlateDecode
>>
stream
xڅTMo0,eI}LtЮ۶b+1,9[GJN)~=>aQ?1h)*r2b	-"*w޳/kIR9)7ꆝqb	,6"G\4@yGv6SγWDE";G$\}MH [
2A5Kfz
ھ8]Pl%|ҟ(p猝c\3QnCɶ!,cJQxxuvЈ}nyyAm$ك:,XUfsUΫ^
!=ֺ5*Aj\p.ȰD"kVCKR"DFL'kQ=hH2q}Cc~k:Sa~0URA8!Gy{;Ff<
E,\s?P}6(OA
KE$lO]USȅoa5چ݆F/
ykZsF",ȿw2c)	{YJvonjK??<[<޾Fn{~fʜap@Sendstream
endobj
204 0 obj
595
endobj
202 0 obj <<
/Type /Page
/Contents 203 0 R
/Resources 201 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 205 0 R
>> endobj
201 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F39 13 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
208 0 obj <<
/Length 209 0 R
/Filter /FlateDecode
>>
stream
x3T0BC#KC=s afl¥fh`hgi`VabgBiendstream
endobj
209 0 obj
62
endobj
207 0 obj <<
/Type /Page
/Contents 208 0 R
/Resources 206 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 205 0 R
>> endobj
206 0 obj <<
/Font << /F15 14 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
212 0 obj <<
/Length 213 0 R
/Filter /FlateDecode
>>
stream
xڍVMo8W(+F$AHbEDZbܦCImTE>μ73${ac$cļl7[n(p(̿_,^!ĿEA9v/s;ׯw^;'~Z;"솘"'Ǘ⟇cD-@-3kJS283܋ P$QH8'gJހ(U?a$b`rGb$a 	>BVy}|_2^)[+~[Y{l:TO":	C^8Y+i=0 zR!#1:|H.C)ujt_Ik,/E&WTV2c7&{
n_;6Uj]Έ !fC
,!VKlz	EuPfڊ,-"|=ZU=nף)IM]^^Whk-*O:(8=e;VkzW,cjot]!|D2h?- CV%P8ERY>t!BHA'(F~A}=H$_(8"OP>$bH&8ŮJہ1ڙP)qyw;Tv(9g˿VMYN=eQMzVwim@wd7qjW[Cp(pLx.>G$b$OJzOMۺ0hjշwzeԡPe,=> endobj
210 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F37 13 0 R /F34 13 0 R /F30 15 0 R /F31 16 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
216 0 obj <<
/Length 217 0 R
/Filter /FlateDecode
>>
stream
xڥV]o0}W17HU;]jڃKf	p] &$p@(4Ng׫-ȉUWOs|Zl9yx'9Z|y}rB_*ύO[Bh-7
n$׎klաB@l`/'G!`,B auF,#|Z
!St]境Fp$!*ӊTˈT);ax:wc{`/Iݿ
g샎"/O>W'b[z<()N(7l=dqaBxS3fi-,^JƒN=F"N3e0u
tXI5eJL6U)KB؅UݯBPgPr$QOhd\[%-5y#%HX}g{ @}":M{;-κ]d&%#YAt/P4#P䜨T͹!iJb}󓍴n2V QZTnWp]Kț,BIzJxN6[iVAz2$s]$lI
#笠VWYaoIQ`t6XOdueE*
Ki)cב4Oik״	0pB$)Ӆ[8:wkÎݍ-7:tdYvTO|
f}U=>PhgZtB݄~endstream
endobj
217 0 obj
855
endobj
215 0 obj <<
/Type /Page
/Contents 216 0 R
/Resources 214 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 205 0 R
>> endobj
214 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
220 0 obj <<
/Length 221 0 R
/Filter /FlateDecode
>>
stream
xڥKo0A*SǴMծ6V{`";&KRUvƞaq!
9'^LK&3?3F)x=x;}|=y܈]b#r_ͼ_oxO!ĝz4tkKbø1Jd2OBsA
C'7˄4&Ym0@[QVdc#hM8^'/h&o<@cqogWa,9XGIoSYre&:$iG۶zh>V(m5vQ,
**&`vH6b>U`Rt["qxj\-HrJG[:DKPJaa "Nr[Ad(/MDYHP'د͔x~pse60;ۣ^~> endobj
218 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F30 15 0 R /F31 16 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
224 0 obj <<
/Length 225 0 R
/Filter /FlateDecode
>>
stream
xڭVRF}+TFs70
̲U=d
f]6IQFQ}zH@HRrfA|x$Mn?}U<>#" e83[`O>Q$0oG)uSGc4-GMBe^޼pV7]ٯ\F^ eIle׭GȐnXYl#D"-\vI-k
4G鵪WmDJxHfc#WP4z7#A¹͋2f埘Y]!X#7]n/LtPօ#[v73C}B1E@Lml53&I%E<#8_7+[/M]nw4UVn!5pY/U}8=.	L
}	615(/\ɲ^o;'
Yi?@_jֵ2cj,^*trrU1dyYeշ[UkXw*LШ0`IJ4hT8 Q f/;Mn0G;A&T$1W,8nNox2/^hx`
(T
o 2|QH~a{)oB
f!jz_#K}?|S.q^e1@
ZLݬ~ZF3[ȻW4
,gpK$T&Ʃ%@&X%O̸3n}$Mj0J0ѼUsTUu
%^jM˂c7~4cwU^CsU5E]784N˕_+8;6*ͫǻìliP5vPMMfj}Hi|ԩ_S3κa8%K$)cM7NPP!jxZUF	)ٌNGRZr7UF%49eSֳr
e"$^XPsy-v3ȕjҡVבOR*v9R+jnZl'7qPVύ\$endstream
endobj
225 0 obj
1147
endobj
223 0 obj <<
/Type /Page
/Contents 224 0 R
/Resources 222 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 205 0 R
>> endobj
222 0 obj <<
/Font << /F34 13 0 R /F15 14 0 R /F31 16 0 R /F32 17 0 R /F18 45 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
228 0 obj <<
/Length 229 0 R
/Filter /FlateDecode
>>
stream
xڥ[O0)hK_${@"m!M]b-KO?q>Crqw.>$EB4H8E<	f6gPeA[{0_ί'7?C~ȱ	J8\8"EA,`qDl
ҠvF<Ѫ<
H30ݶ 8K0lo3kUC Y&q1"ioEsZ>R7x]Viy]|%?lwAƓƪȗU19 }m2 K׀eWn"&`tk?9RfG>v,+QYa&
)"fW'X}-J3p=sٮ
ہE) 
endstream
endobj
229 0 obj
639
endobj
227 0 obj <<
/Type /Page
/Contents 228 0 R
/Resources 226 0 R
/MediaBox [0 0 595.273 841.887]
/Parent 230 0 R
>> endobj
226 0 obj <<
/Font << /F35 35 0 R /F15 14 0 R /F32 17 0 R /F38 6 0 R /F31 16 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
130 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 231 0 R
/BaseFont 237 0 R
/FontDescriptor 238 0 R
>> endobj
231 0 obj
[ 799 286 799 514 799 514 799 799 799 799 799 799 799 1028 514 514 799 799 799 799 799 799 799 799 799 799 799 799 1028 1028 799 799 1028 1028 514 514 1028 1028 1028 799 1028 1028 628 628 1028 1028 1028 799 279 1028 685 685 914 914 0 0 571 571 685 514 742 742 799 799 628 821 674 543 794 542 736 611 871 563 697 782 708 1229 842 816 717 839 874 622 563 642 632 1018 732 685 742 685 685 685 685 685 628 628 457 457 457 457 514 514 400 400 286 514 514 628 514 286 857 771 857 428 685 685 799 799 457 457 457 628 799 799 799 799 ]
endobj
232 0 obj <<
/Length 233 0 R
/Length1 234 0 R
/Length2 235 0 R
/Length3 236 0 R
>>
stream
%!PS-AdobeFont-1.1: CMSY9 1.0
%%CreationDate: 1991 Aug 15 07:22:27
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMSY9) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.035 def
/isFixedPitch false def
end readonly def
/FontName /AAAAAA+CMSY9 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 0 /minus put
readonly def
/FontBBox{-30 -958 1146 777}readonly def
/UniqueID 5000819 def
currentdict end
currentfile eexec
oc;j~EЪ/	ȭX~id}S5Q!gtⵎkJc;rN^X5.Sy
+'IqV:r㚉#,#dBZ*R*"7٨y=cLIPsF'f>ba
]fv}3N/+	I:=Zc>>:} 2lgC5'F]5'V	88Р"z^wxh-fp
CIځqɳ7^qB&Cgv=H\hM$C<{Fq*}S8bD#5nVOkg4	]0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
233 0 obj
1896
endobj
234 0 obj
767
endobj
235 0 obj
597
endobj
236 0 obj
532
endobj
237 0 obj
/AAAAAA+CMSY9
endobj
238 0 obj <<
/Ascent 750
/CapHeight 683
/Descent 0
/FontName 237 0 R
/ItalicAngle -14
/StemV 87
/XHeight 431
/FontBBox [ -30 -958 1146 777 ]
/Flags 4
/CharSet (/minus)
/FontFile 232 0 R
>> endobj
129 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 239 0 R
/BaseFont 245 0 R
/FontDescriptor 246 0 R
>> endobj
239 0 obj
[ 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 ]
endobj
240 0 obj <<
/Length 241 0 R
/Length1 242 0 R
/Length2 243 0 R
/Length3 244 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTT9 1.0
%%CreationDate: 1991 Aug 20 16:46:24
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTT9) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch true def
end readonly def
/FontName /PKHGSC+CMTT9 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 35 /numbersign put
dup 46 /period put
dup 47 /slash put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 53 /five put
dup 57 /nine put
dup 58 /colon put
dup 68 /D put
dup 76 /L put
dup 77 /M put
dup 87 /W put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 119 /w put
dup 120 /x put
readonly def
/FontBBox{-6 -233 542 698}readonly def
/UniqueID 5000831 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_c2Bطj=-)1_]X` Y{nn9׫/uye);9*fHHK-\rБkg\5&(G<`J7dhn)Zl득52Z$نa#q13@H;+G"1L(seER;ԱJo"BFKkv/ ֈpZCޯ*@;db
s*Mm~4]꽺\Qߍ):۞3#˂3u?O+|mMۉfH21C2/AHw;u&~#V=@Ņ*Ft@*(s9)UdƁF!;ŭ$r)_e_LRXJ*'*|o+_|flWU6yM`MFPzXktw_K1Bov7}E(>[)Abц>Uu
s,H6Wa7]_ΑAXφNp콕Tĩ>2oשW,1e~O6Y̮X~Ր)L]80O{(h%:eZKЧۅ8+fڀD}Dod&
7~ᗸ7j}zӡ%mdwmN|ڂY\Ԝ_/
YD()/lO;j܊B,olCo4/ځ_u.ިq>FEnJy1DȾM 6nS̕6ZQQIσ+lnaWό($f4*#Enq=95Gl׬"mx6F
#]
weLk$l--MTF/߇i³N~7}_!VŒ5ڔ+5yhne-!u^eil]~/+LO#>F7$9*A_Q·.)a%lMc _+
3FhY[HH+[j1~Q#wAJԗ?<~ N:~dڇ41BD`֗iJF@ϨDG7i=~x/"
' ܑy	a$B~-x	gݵ\mJP%FH0~^G2ҡ*gUt`x)S10+3P=j_X
w#se+PvK\U+˱=B
d@hgdKʉ
/]%s*:$izhm
.$^9ֻ%:V$SL!>ù67!P2ˉ_`qcT;C6TKVͅq(BSѝ]HUj|x
v7Ӧbۗg	jlҾ%[8;m1GuBRrlB[)
E`GfݽpcVaGΛPWҥ%'DRos-2RdpkTsiX,Gf'Uw##}aD;u*'
8ʞޭmqQARG&_盾y-n]+H\\PCE!
 "Coxr4T(260\=C\t7Y.
R4tW}_ub!012> OIK,|kxVq`2PnI0IYzgKEB%#2?vI#o	/Iqe
9@x#IAe*}dEaIE%I!Hj}].3S<}JFu*aQ;OOd`f7r){XIp(چ|gOyM;yMQșMxJGɹj˰G"][FyjmwtX 'pq%)ۨ@1A؉	ws/۷KhQJ${Nchr]0]^)kn2NFZI}̅
 1^8O,
*³BWmھ3'tMYpOyd=AW 
<͆楔t$6?-s_OSnn4xf'>ŦXbh]]R#6M#SPS/WDKm=U'Nҗshb~%B޷RoO[)#'otB[\R
=E$S#_8LzjAxs#@uz?&)mw-p
+͒B齊G`DZL6o*P;3zq!I0;*u҈bغWS^BMz)Vg?i	8~oع+c%qؚ*kXվd^&4V9CQay*zʹ]L>:u>@!l7}F.C&KNbA3p$k*}3424gDotp}/
j?0}WPLRN8e_mwo%CE5c$50>1}
4ַU/;'@in}~Ry-u@LҺ/0y8~\E:"UOv
/闠kdSe.hU5~װMKXȿLAU^!,wi
!4b㣵߄SBCn
vP~-K_m;YK{AE9&!Ud`:#=sxhŐa5\vciRYQrk&|H	]G&zujȁY4M#hj0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
241 0 obj
7273
endobj
242 0 obj
1226
endobj
243 0 obj
5515
endobj
244 0 obj
532
endobj
245 0 obj
/PKHGSC+CMTT9
endobj
246 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName 245 0 R
/ItalicAngle 0
/StemV 74
/XHeight 431
/FontBBox [ -6 -233 542 698 ]
/Flags 4
/CharSet (/numbersign/period/slash/one/two/three/five/nine/colon/D/L/M/W/a/b/c/d/e/g/h/i/l/m/n/o/p/r/s/t/w/x)
/FontFile 240 0 R
>> endobj
123 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 247 0 R
/BaseFont 253 0 R
/FontDescriptor 254 0 R
>> endobj
247 0 obj
[ 613 800 750 677 650 727 700 750 700 750 700 600 550 575 863 875 300 325 500 500 500 500 500 815 450 525 700 700 500 863 963 750 250 300 500 800 755 800 750 300 400 400 500 750 300 350 300 500 500 500 500 500 500 500 500 500 500 500 300 300 300 750 500 500 750 727 688 700 738 663 638 757 727 377 513 752 613 877 727 750 663 750 713 550 700 727 727 977 727 727 600 300 500 300 500 300 300 500 450 450 500 450 300 450 500 300 300 450 250 800 550 500 500 450 413 400 325 525 450 650 450 475 400 500 1000 500 500 500 ]
endobj
248 0 obj <<
/Length 249 0 R
/Length1 250 0 R
/Length2 251 0 R
/Length3 252 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTI12 1.0
%%CreationDate: 1991 Aug 18 21:06:53
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTI12) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /LQSMBA+CMTI12 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 44 /comma put
dup 97 /a put
dup 99 /c put
dup 105 /i put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 114 /r put
dup 116 /t put
dup 117 /u put
dup 119 /w put
dup 120 /x put
readonly def
/FontBBox{-36 -251 1103 750}readonly def
/UniqueID 5000829 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9M֨[G(aܘ|RP>f}|Zx'5+jۊz3p3`/gtJ8)&ho%̸{sCVah~I"Y0'Ӷg;
怦#Ӝոgl;O6jyg
H@n΅
l2qŽwޗMe]}Aq}_oyѣg+JIua;5m˺ڳŞppX!cs|:J#]Ts*?~XH VH ‡9E ;ۉ?jK&\$x!/_lPK1Mgl"oË	9ёIهnXBf9)/J}ʝw@⌥iDf
_kvI\um	D~v z+Q84S{dY)ı*}tqբkyf}	KI*wj#}szDƓmS\Z12PiVaAg؛"ċ"Mːl_FF|	sOnO:bC_bA>0aG$b
v.Ye(xp4ɩ	]:Am}L|'&Py=9e=;mRAi6lO*|CMb̀<	$'DQRAʁo<(Ko/.ux/l>I|7tgnɽ.\p)_+&eC1VP4r=?gy,R$,sX 1+Ht=uzYQp~U2F
>8MhfPxWeXequOt~6Aՙ}5La[>%2\L@<oI\)b}yH(v4wgZ0lEH1F6G)+6{*[n[Z=Hv/A#$%
x2lӦX([LӦFTTebڈFbĽAvK0.&vL*vh5ځ(πTm0.Kf4jjeiωZ͓	{$a6$lů=+MBDHSEM3Z0[uzMXQw9?q3-ku<7a6Xg f$$˗HZan;vunx%f!RJ+bnߝ_F-@KGN>>
lѧΣ(s(KUy'peJةxZ	&pa_{Ƚ='2ev3#Vr5_U{ѱ:1zWɂ,r*ߥ)5᩾jpAK]|bC+LLS~3tCFqIE/TS_rXpwE-5ڋ\?d1s_ely
jobO+&VWUt:p&["'dɽߎfJ;LY^GS3Rb%t5!v )^UFw;	2E\
5=>]mr3i΁ut,=KAw&wFXVY2CrBr}GsEٙǴa@0:^}I/6Pd~ץϗi	hΌowl5o^U?1^5{Yͽ;|$C2IP^M4lRh=q-C_L{*/-zqEpQhS0Fع[08a	r)|Z[ȑDv
Loڍ!BۻCʞtCLXD2XZyY)evz}0%N,vPi5זէ3&VEzCu	Yz@5YOQ]$WodD?VƲ?j
Iڕ4y}Pz_S]L`
JivC̷j;brSceDR	u8vE	exM*2NR:dӷ:S<>{ԉҢ.&wǧG5ojOn|d	%}+i:ѷ{eؠ;C߼_/4}%WxFÅs$&6{LHk^h#+TxGndjq1/yUk29U1(0m$<WȐu`3I$QcX>R>r#p0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
249 0 obj
4781
endobj
250 0 obj
948
endobj
251 0 obj
3301
endobj
252 0 obj
532
endobj
253 0 obj
/LQSMBA+CMTI12
endobj
254 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 253 0 R
/ItalicAngle -14
/StemV 63
/XHeight 431
/FontBBox [ -36 -251 1103 750 ]
/Flags 4
/CharSet (/comma/a/c/i/l/m/n/o/r/t/u/w/x)
/FontFile 248 0 R
>> endobj
118 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 255 0 R
/BaseFont 261 0 R
/FontDescriptor 262 0 R
>> endobj
255 0 obj
[ 607 816 748 680 729 811 766 571 653 598 758 623 553 508 434 395 428 483 456 346 564 571 589 484 428 555 505 557 425 528 580 613 637 610 458 577 809 505 354 641 979 979 979 979 272 272 490 490 490 490 490 490 490 490 490 490 490 490 272 272 762 490 762 490 517 734 744 701 813 725 634 772 811 432 541 833 666 947 784 748 631 776 745 602 574 665 571 924 813 568 670 381 381 381 979 979 411 514 416 421 509 454 483 469 564 334 405 509 292 856 584 471 491 434 441 461 354 557 473 700 556 477 455 312 378 623 490 272 ]
endobj
256 0 obj <<
/Length 257 0 R
/Length1 258 0 R
/Length2 259 0 R
/Length3 260 0 R
>>
stream
%!PS-AdobeFont-1.1: CMMI12 1.100
%%CreationDate: 1996 Jul 27 08:57:55
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.100) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMMI12) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /HHAAAA+CMMI12 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 60 /less put
dup 62 /greater put
readonly def
/FontBBox{-30 -250 1026 750}readonly def
/UniqueID 5087386 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9M֨[G(aܘ|RP6n=:b9s2m4{~CD%xyDOg<<Alw|Uv̬i@o*|'iSq?s"{}3w*`,\Ź
g=X|Y20VO
T{̀]mDU:Ms/V-|UҔ4Beg}%1%V7E]|o?41	ZYmm	
w*
IGK2Yd0=bsS;e`hz9h˴ %^{x
'i{]&
9c<U6cޏ(>O1sb>HAҞ#A͇i;yZYIG 	2og#!\SR8?STGA'
;%a	%98ٮ(5E= W"2b'+}»*?)bUE5Jh
	E.ͥqXZUgT^.и`}o>,e,yh[g
 2Zzn[or_!](l︟ŭ=}:8@|\mlʛo<ϒM
fY~CNYZtHvMLi,9!<Ȋ.	:PaUHQ*xa@=Qwh\}\^nϛ$Eij\i4#UdupdqoTi而Mne2.^P-VvI¬h)&܀X-OiUpm&cBK?BmCW'N̪	,h;-6~85Yst4O[Ī?æʿ=L04W[nR(ԏ&jnD'~!j
v nzҍ6cdI(u}IYmqAPVzfEk:aq-]:GJ# YP)˖p05ɿ@JVbB
؉1fG:TGy
-.5	qFxl?	")_i4G^Νwo+T(>-&MS*eX*$YCȻEZX#_1ڇGVzzW6Ĩ@CS0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
257 0 obj
3539
endobj
258 0 obj
793
endobj
259 0 obj
2214
endobj
260 0 obj
532
endobj
261 0 obj
/HHAAAA+CMMI12
endobj
262 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 261 0 R
/ItalicAngle -14
/StemV 65
/XHeight 431
/FontBBox [ -30 -250 1026 750 ]
/Flags 4
/CharSet (/less/greater)
/FontFile 256 0 R
>> endobj
117 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 263 0 R
/BaseFont 269 0 R
/FontDescriptor 270 0 R
>> endobj
263 0 obj
[ 778 278 778 500 778 500 778 778 778 778 778 778 778 1000 500 500 778 778 778 778 778 778 778 778 778 778 778 778 1000 1000 778 778 1000 1000 500 500 1000 1000 1000 778 1000 1000 611 611 1000 1000 1000 778 275 1000 667 667 889 889 0 0 556 556 667 500 722 722 778 778 611 798 657 527 771 528 719 595 845 545 678 762 690 1201 820 796 696 817 848 606 545 626 613 988 713 668 725 667 667 667 667 667 611 611 444 444 444 444 500 500 389 389 278 500 500 611 500 278 833 750 833 417 667 667 778 778 444 444 444 611 778 778 778 778 ]
endobj
264 0 obj <<
/Length 265 0 R
/Length1 266 0 R
/Length2 267 0 R
/Length3 268 0 R
>>
stream
%!PS-AdobeFont-1.1: CMSY10 1.0
%%CreationDate: 1991 Aug 15 07:20:57
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMSY10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.035 def
/isFixedPitch false def
end readonly def
/FontName /IGCAAA+CMSY10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 15 /bullet put
dup 56 /universal put
dup 102 /braceleft put
dup 103 /braceright put
dup 106 /bar put
readonly def
/FontBBox{-29 -960 1116 775}readonly def
/UniqueID 5000820 def
currentdict end
currentfile eexec
oc;j~EЪ/	ȭX~id}S5Q!gtⵎkJc;rN^X5.Sy
+'IqV:r㚉#,#dBZ*R*"7٨y=cLIPsF'f>ba
]fv+QAwdO[x"%Sx~{p҈덡|O	
BÄ/GL3h+Ng03jU1~akDzq=U}.KY碌ֻ1?C	N2Muh/4Gm&v.d)%\о .u	߸d`]m'Z9Kͅut>2{m-=B3P=	,N-6}IB;c"nEU)g~.in| PQ4T
(#6؋t)T
|B8мU.	Jqu|BC5p*`SL
*\窪褽J%<م-ɪu%hҕCj±꜠JhO^z3iB|ZI:ѾʁxsF6vm6:9oouB(8Yf:q`mEzN0e< QZ9
-	L=PhZtTkģlfǎ08jDֽdќ
IB45/gtn\d\Ε|sɱ)ӱ&$vBã寒
1>TG)sn@Y]YE+xrXP9ϵkwNPW7tAq|_Bnʙ粟.U5Z0D!1[:bäӬm;d8IecGNYV"ؘ%  5?LR(Ѵ]RG%$E&T78EQo{43udNm<΁8.(>SoxI+Z*2xH%cRI>dw1PwQxo԰p+o?}XC
~ٻ"*q~m1һ<	0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
265 0 obj
2575
endobj
266 0 obj
858
endobj
267 0 obj
1185
endobj
268 0 obj
532
endobj
269 0 obj
/IGCAAA+CMSY10
endobj
270 0 obj <<
/Ascent 750
/CapHeight 683
/Descent 0
/FontName 269 0 R
/ItalicAngle -14
/StemV 85
/XHeight 431
/FontBBox [ -29 -960 1116 775 ]
/Flags 4
/CharSet (/bullet/universal/braceleft/braceright/bar)
/FontFile 264 0 R
>> endobj
112 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 271 0 R
/BaseFont 277 0 R
/FontDescriptor 278 0 R
>> endobj
271 0 obj
[ 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 515 ]
endobj
272 0 obj <<
/Length 273 0 R
/Length1 274 0 R
/Length2 275 0 R
/Length3 276 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTT12 1.0
%%CreationDate: 1991 Aug 20 16:45:46
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTT12) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch true def
end readonly def
/FontName /KAVABA+CMTT12 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 97 /a put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 105 /i put
dup 108 /l put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 114 /r put
dup 116 /t put
readonly def
/FontBBox{-1 -234 524 695}readonly def
/UniqueID 5000833 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_dV` H[fIs
?Sy_aOg+k%;Y`AXGSp֓Y%&n@C[KBcCE(7@$2`5ձSX/
z)ύ	թFrsWa-3"ay}]*z]¶2k,2ƲXg׳1V71y	\š)~V+h7|v1j>3~/%'5
{kzM˿G%+g@|x̅/ER~AX^o*ӳF7/q\X<~Zֿ]ŋ	*8)E_oG	aUXGv:.~2ڜlT3eU&:0V{]GhsH޹o?SV=9͒SaM8pHs,omΠK>CРk%th1eh@D/!0eΨ4t`]	P(hk4>r\>+rY]Q:N"F5HFx&پub9Tc_RHbRˬ	z4&)oHf
]CcuF,P=p9Qgt }$$D0C̕>m͚ҘɥrjBW7RXX&*)nFSA'dҫf1~tfuDA
Ɛ'(AH%-N\'5/I	)Y'*ŦRE[s!4C[~psJ}aD,zf*%s6Ph"7,N}TTЬ~పZ'5o%|anikr51_1R0,.[ߥa 
mbBz˨rGȕ%Xdu.|騍|c|v$6bؓ1}!"
l|#Ga9=G>q^3\LCqP
e;`ۆ1rdםVxkLr3!Yk}-KhtHoa.+Ɩ|Czr i݋;x@/hAٝxD&p_7τ	nLhRzI(__RwWaRv^E*ykc"kJkI9QGx4͜Pd89OKӥާ4N<bc
E$Ql{8c@ln]ktA/5pi2M=ta;TMWҮStO0!?Gnl^;7/$]nbYx7,]y+
Q5g$WjgbAuuxŶc5aB0(Qn}O|C,9	Ϲ݉!}>`~Y<2Cn}vH~FsO  D%>eܼ#\1ɋŀ>V'1qyddOl iuJlܨȈd3p692/:rE2͈֭5hxE;T8IȊ7h :3[<g!jceR&tV 

vOZ%ze[/#j`gBLa#㍕jn|gǩ%T}09\'5GoK}vr^]<=ЬC
!Ϛ}x̬~
rU OS+iQmlQHo7;{[7K4m`kqa$6;=R^]HO}pXܥ\pzh&=C	+O!c(ke
D
|+VU7${#>pEꈼ󒟫p2ږDy_w~RI"ykTƈ25v6߯1~>	̓F-3Ix`z/J8Jj
,ѱXC/P8b=x#KWt
2=D`DW7RQ
cږ qPrt_.#r!^N$)~Ol0:WaB#,y}{JS@J윜8W;w0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
273 0 obj
4099
endobj
274 0 obj
922
endobj
275 0 obj
2645
endobj
276 0 obj
532
endobj
277 0 obj
/KAVABA+CMTT12
endobj
278 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName 277 0 R
/ItalicAngle 0
/StemV 65
/XHeight 431
/FontBBox [ -1 -234 524 695 ]
/Flags 4
/CharSet (/a/c/d/e/f/i/l/n/o/p/r/t)
/FontFile 272 0 R
>> endobj
107 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 279 0 R
/BaseFont 285 0 R
/FontDescriptor 286 0 R
>> endobj
279 0 obj
[ 643 885 806 737 783 873 823 620 708 655 817 682 596 547 470 430 467 533 496 376 612 620 639 522 467 610 544 607 472 576 632 660 694 661 491 632 882 544 389 692 1063 1063 1063 1063 295 295 531 531 531 531 531 531 531 531 531 531 531 531 295 295 826 531 826 531 560 796 801 757 872 779 672 828 873 461 580 896 723 1020 843 806 674 836 800 646 619 719 619 1002 874 616 720 413 413 413 1063 1063 434 564 455 460 547 493 510 506 612 362 430 553 317 940 645 514 535 474 479 491 384 615 517 762 598 525 494 350 400 673 531 295 ]
endobj
280 0 obj <<
/Length 281 0 R
/Length1 282 0 R
/Length2 283 0 R
/Length3 284 0 R
>>
stream
%!PS-AdobeFont-1.1: CMMI8 1.100
%%CreationDate: 1996 Jul 23 07:53:54
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.100) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMMI8) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /QFAAAA+CMMI8 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 18 /theta put
dup 105 /i put
readonly def
/FontBBox{-24 -250 1110 750}readonly def
/UniqueID 5087383 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9M֨[G(aܘ|RP6n=:b9s2m4{~CD%xSd,&jA x"ПmѬ,+;ŝboB|ծTboI*VDZBJϟ2a{Y0Q(/e@AGƀ挄п]w}ga8.ݲ	cS,t^Ujq.or!N]@j
Gē75uʑm$KWNWVF2P,KP˻62abw;SBֳ{ u&DChNe^L2Ib^ǞY62"CSl5X!okR6DUjT|S{G3:6A| ٺJ
33kLKEnMpٽqlHZoxV	Յ(\FNҸnd:lڄiugND!~ă{3e}ʸXEOnn8gfP>ژ
)X%J܀
NzHzS)Ğ
-11y]EfB̘e[Y;%>P7qqB!`WwKn[*QY1?S;jEBi-㝋z
11bbomj6cBJ[]!KY9~)Bn{:Cr۞K=cxkYwT26CBa^e	'=6OeEa%8,“j%lSIةn8yLt*qLzZq2SėjL4pۄKnڄ`It ID̂\u,|;xBSghpl@$0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
281 0 obj
2637
endobj
282 0 obj
786
endobj
283 0 obj
1319
endobj
284 0 obj
532
endobj
285 0 obj
/QFAAAA+CMMI8
endobj
286 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 285 0 R
/ItalicAngle -14
/StemV 78
/XHeight 431
/FontBBox [ -24 -250 1110 750 ]
/Flags 4
/CharSet (/theta/i)
/FontFile 280 0 R
>> endobj
68 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 287 0 R
/BaseFont 293 0 R
/FontDescriptor 294 0 R
>> endobj
287 0 obj
[ 673 878 823 742 713 797 768 823 768 823 768 658 603 631 946 960 329 357 549 549 549 549 549 885 494 576 768 768 549 947 1057 823 274 329 550 878 816 878 823 329 439 439 549 823 329 384 329 549 549 549 549 549 549 549 549 549 549 549 329 329 329 823 549 549 823 797 755 768 810 727 700 830 797 413 563 824 673 961 797 823 727 823 782 603 768 797 797 1071 797 797 658 329 550 329 549 329 329 549 494 494 549 494 329 494 549 329 329 494 274 878 603 549 549 494 453 439 357 576 494 713 495 521 439 549 1097 549 549 549 ]
endobj
288 0 obj <<
/Length 289 0 R
/Length1 290 0 R
/Length2 291 0 R
/Length3 292 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTI8 1.0
%%CreationDate: 1991 Aug 18 21:07:42
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTI8) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /PCAAAA+CMTI8 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 65 /A put
readonly def
/FontBBox{-35 -250 1190 750}readonly def
/UniqueID 5000826 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9M֨[G(aܘ|RPד>~}F.om[@ lnho:%@VM![}]V`$6ssI	(VW[b%B[P{>0^8YO[z"h|\ѳP_c
8`[6]**}ݹcHc'X{>cS[B:tnlKѨ֬UH㗷M$>QкMpF.9x4Y)8i
D\Q]*@Rg4	lE|pUl3D7FY
B'Y)-&LZ,co-OpKCEja	,'Dg>ӎ$qO
u̴Z/! ,}R9WxJUM((nB
Z
} Hk/ f$AHMEr8TT# O-(嚗qq.Xĕ{=~FgT
vLJ5@+GV^:ܠJg9Z?GB
`8Eb,/j|_(䍳qN%R.-X?[304fap7CY\">Nhd߸[{ƼX,=QZFV;}*ѫić00000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
289 0 obj
2449
endobj
290 0 obj
763
endobj
291 0 obj
1154
endobj
292 0 obj
532
endobj
293 0 obj
/PCAAAA+CMTI8
endobj
294 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 293 0 R
/ItalicAngle -14
/StemV 73
/XHeight 431
/FontBBox [ -35 -250 1190 750 ]
/Flags 4
/CharSet (/A)
/FontFile 288 0 R
>> endobj
47 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 295 0 R
/BaseFont 301 0 R
/FontDescriptor 302 0 R
>> endobj
295 0 obj
[ 642 857 799 714 685 771 742 799 742 799 742 600 571 571 857 857 286 314 514 514 514 514 514 771 457 514 742 799 514 928 1042 799 286 286 514 857 514 857 799 286 400 400 514 799 286 343 286 514 514 514 514 514 514 514 514 514 514 514 286 286 286 799 485 485 799 771 728 742 785 699 671 807 771 371 528 799 642 942 771 799 699 799 757 571 742 771 771 1056 771 771 628 286 514 286 514 286 286 514 571 457 571 457 314 514 571 286 314 542 286 857 571 514 571 542 402 405 400 571 542 742 542 542 457 514 1028 514 514 514 ]
endobj
296 0 obj <<
/Length 297 0 R
/Length1 298 0 R
/Length2 299 0 R
/Length3 300 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR9 1.0
%%CreationDate: 1991 Aug 20 16:39:59
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR9) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /WGHEJE+CMR9 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 12 /fi put
dup 14 /ffi put
dup 33 /exclam put
dup 46 /period put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 70 /F put
dup 72 /H put
dup 73 /I put
dup 75 /K put
dup 76 /L put
dup 77 /M put
dup 80 /P put
dup 84 /T put
dup 87 /W put
dup 88 /X put
dup 91 /bracketleft put
dup 93 /bracketright put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 107 /k put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 121 /y put
readonly def
/FontBBox{-39 -250 1036 750}readonly def
/UniqueID 5000792 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou\c3R*R?쨤ȯ@ gSr RIzE_EMv,X!%6]ަ_3+_hJإ0oyX`U) %N5<6[mR"-%Qg!2og,Ydhhu_1A͐
	.Um;3YZ`7z*%͟AJ2UhcCp2,숛§#@J
s8,
ed?Ms."A#
p9Ɂv*\X	K	 QF7q
{N{G0o?8I*!D]!ض8iȂa>VGkV4;Wy;3Oo8KߝpY,!7T˒jHC9[I?;J_1,>W7'pRlfa{x[:3;9ԫV4z^EЩ!6A_xcL8i[Ulzt
Z76M,-KbB-$9]fًJ3bŅs|
AMR$m,|qc
4l̬[ÕnaO;㗐+Kxݐ4J*x@Ӏq7Y)I)V<#qv9nB?_q:ZުA_ɚԝl2:&rC,OҊC+ę6ei&ʟHI);Cs@csliя1W58)րX?0OQBJ\ț	a#*DUs8)^;bf~pț.PyI"yKwVN,{x-wU@BPZ$Zػ;Dp-^ݧ8܍W贋A9GBz)Z7
i>)ikG.UeTGu+l #T~W5q+"Œ!svcW]z[̥1&#vţ`aciU*h=d'MKښ(7B<&XA=1#{ʜU_I'y.ےdMQ&lenBe7teĖBmlJB@(.1*i$ֺJ,)r"))ãRYti"C`63FOi7p_*OdlP̶3+wLVlAB5/i9cf}e(^
Y%=i NɄ5ol|l1܊Zk}7
-ټ`ij@y(>yTR{u"W-B68o-l䈔Cq̷Ra;Օ{NSQ]#t9Z.Ģ-w:}f3{Ha[Nqǟv1d3	Vˆp:9uw~OJ匓P(4Wa%6fū*ZW-v@`ȣCgКz$<.cl*3Fs/F_
68I;~gKed|T$^Rɳ3W
dw[y4+?A0$u{zٺ(
cex+ꃊ/Yik,%%$PoY
ɜӏH*|,~`gx|p-/nG4< t"^R#DOIyЖ~mSe
$԰?0`ޖŹ6ou}3dDIrE)HC;rpQl&O2K
]P`.[CӁX=[vylXTro~.mdo4n]~UBҡxu	;([0ʞxGe
<0[+Wqw?msDz柒'rBAHΪS/!YA1ӒnbIfDh*bBAho_beX.aքo!\D.5be1[gweX8KlB,pݯ&PX,YF->h#Hˠ>xRDaa솃唏ՏU]϶ԾM#^ѓr%J4$2|b\2l/X߽aۆ椸|==QAXDOVd?!T뭚\C+5
`*:FW	jvyJ7ˮ\Jsie,Ӵ>ti[
2O:EA':@1kAySU
7fBX/*AM]Jl)USIÄA_A40:.շ0DtBPE
S^1Ƃw\avPE6g/߻҄Y9vaM(VoSy4iIqN?gtH3@7ʣZ$0g}V0]huh=#{I`&x[
U
M BKi4}P681o7zGX+JrВ'gthG߆ö[KAE'9I4y&}2
q<U>z0:?%-Y"ؓnUPFqF͔}Qo,;.vz
hk9,;it~̷DbýTJl:1+=9MW~P^H'hн>UI4!’Dwz	0)j
59(1"}Jȃ/ynȱ[0pXDk/?\bQn@YK2%{PQʬY@'P!cs_+rAe/E=i77{9Bx|l0y}QߖdH\9XwԶ+6cHsɏ3toУ}zi$2Pݜ^'(_cy~'2\d2
]fi	. ;ҏeB,}il2PɯЬ$\rO0J2 rr?"egr?]\W
b}wy#R/f!XiA*Ε磍h1*߰#֙{_~dpu2vO*őX~66se.>w朮:W>!qE!|
#u؃%
~sx#%;<3g߂:B;Ш"$bϸNgOv;G!#XÎI_}E$VaԌA`HACGJ9l!
+	(vЃ_y޳Nh֪mZҥFqeXޕ޺9g,zK_sº65'u;
hoS_[/iRZstt;SaYd6ަNĈ`FSBe]njXK9WGD5K{ o%ebD]1<+KE~a5W6p3¾M%35pú
=&:jcF%߰h3JCI06muͅha+JǮiL##FK۫K[
*>d
kft"*#$!@%[*OZFo1
S:$/eP~T]B-FToާvM%ծ;b3Rsњ1={
j	4ŖjlJ)ť tXBDonoyXiۿ"\d!.dn2EY5-
в\vwwiy]A:
ow<=f͆ߎrnnM$Ya/Y7E<~P2.|=]?n7YJNa*q8mKKueΉ'G܇pxe@mP^텩:)/sKjOP=l/|$mԑ獮-WT
y6[DG=N)
Ø5
yg@U~'2L+7`:l^7	&ȣWFȥ=10$,9~}5G!#+W,I>H53z;s0PqYfYujzEmmA$@Na)E٦=e8c[{PnҺ:zޱstٖӊE" ;Kod
p"\SeZT:
֫A\)w${`*%
^1J(?ԽVgSef}~խ'--JphjM[nm&ͱ$y7ĵQe`'dcXe(Kp]ڝ]/@5@_hD[3'LɩlKGK*؇>4JSpoMʄLPsz1yAGtZ6J
ڝZCUha._DlZkc%rf1qe-"P=q)RD%,#MBW%d&462`+E C/QU0uI|LPٌF,y@v[&sU,6
lFLZ!
鋸R"sS*pXMִ;6ủtɍ51aN'̒OT mZk(Rnh _M
2uGy)FL\ ex>v61$߂HX>!o6H۽bS?ZH	z?^rD|pb:QP,:('zChnF`wkt]2]Y"#I^(.+88b7&
njVyqq%O;-;|͒3coSlz"fOS*`=-NY6{7tude<@dͽ6$b3Bυs>x
=
̿Peh\&bJ
71sLMP$kD.PzI)ۢn}fW-QDO>Mj^?|e\P)E#ڞF0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
297 0 obj
10147
endobj
298 0 obj
1435
endobj
299 0 obj
8180
endobj
300 0 obj
532
endobj
301 0 obj
/WGHEJE+CMR9
endobj
302 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 301 0 R
/ItalicAngle 0
/StemV 74
/XHeight 431
/FontBBox [ -39 -250 1036 750 ]
/Flags 4
/CharSet (/fi/ffi/exclam/period/one/two/three/four/C/D/E/F/H/I/K/L/M/P/T/W/X/bracketleft/bracketright/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/r/s/t/u/v/w/y)
/FontFile 296 0 R
>> endobj
46 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 303 0 R
/BaseFont 309 0 R
/FontDescriptor 310 0 R
>> endobj
303 0 obj
[ 754 1000 935 831 805 896 870 935 870 935 870 736 704 704 1055 1055 352 384 611 611 611 611 611 896 546 611 870 935 611 1078 1207 935 352 352 611 1000 611 1000 935 352 481 481 611 935 352 417 352 611 611 611 611 611 611 611 611 611 611 611 352 352 352 935 579 579 935 896 851 870 916 818 786 942 896 443 624 929 754 1091 896 935 818 935 883 676 870 896 896 1220 896 896 741 352 611 352 611 352 352 611 676 546 676 546 384 611 676 352 384 643 352 1000 676 611 676 643 481 488 481 676 643 870 643 643 546 611 1222 611 611 611 ]
endobj
304 0 obj <<
/Length 305 0 R
/Length1 306 0 R
/Length2 307 0 R
/Length3 308 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR6 1.0
%%CreationDate: 1991 Aug 20 16:39:02
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR6) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /WNAAAA+CMR6 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 49 /one put
dup 50 /two put
dup 51 /three put
readonly def
/FontBBox{-20 -250 1193 750}readonly def
/UniqueID 5000789 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou\@[6]nhmlhaH+4/?3&n=a6E#|~.ԅˡ}_B$~\|"4Pxҍ>P%
~ߏ4q.C3s蛼q翈by?Z72z6LpHC1D"28sB
~OPQ
O\O}l4x
^;CTQ됧[I/=G6n0X9q(Ck	oM'G{z
	wx1~4=jOl&$
QvO\3qZ9i1Zp0EVLyF3J,fD6YQ
kT:~
:͉ xJt]1kpWcI*”$*utHYCQNN&y-M6{}h /4}M"QfӾX	)Lş1RuD
xSޙkK"vQJ_R	&yrݮU !ndn> endobj
45 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 311 0 R
/BaseFont 317 0 R
/FontDescriptor 318 0 R
>> endobj
311 0 obj
[ 664 885 826 737 708 796 767 826 767 826 767 620 590 590 885 885 295 325 531 531 531 531 531 796 472 531 767 826 531 959 1077 826 295 295 531 885 531 885 826 295 413 413 531 826 295 354 295 531 531 531 531 531 531 531 531 531 531 531 295 295 295 826 502 502 826 796 752 767 811 723 693 834 796 383 545 825 664 973 796 826 723 826 782 590 767 796 796 1091 796 796 649 295 531 295 531 295 295 531 590 472 590 472 325 531 590 295 325 561 295 885 590 531 590 561 414 419 413 590 561 767 561 561 472 531 1063 531 531 531 ]
endobj
312 0 obj <<
/Length 313 0 R
/Length1 314 0 R
/Length2 315 0 R
/Length3 316 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR8 1.0
%%CreationDate: 1991 Aug 20 16:39:40
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR8) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /JFBAAA+CMR8 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 65 /A put
readonly def
/FontBBox{-36 -250 1070 750}readonly def
/UniqueID 5000791 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou\@[6]nhmlhaH+4/?3&n=a6E#|~.ԅˡw,"rg[eHi>u
Wת>~ӖѿJmdvA
[4|ܾ.Vz_1.Ff	|X9^Rw]
ۊ31S\DKZW`P^3 eێ
8`2?l;Ȋ!eXxh
Df@=$*IBXԏ!Wx-b1C;
p}hQi=HXbgbmǣR,>_Q!
Z؞Ar]< Qjt8?B,mN3v լǵ+K6 t{AJcQ%r?v60RmXsŤ+pǸi:Us)kPW\~;
7T.N	}.&:D~4LDV5bgANӪ&׏+“Ļɂ?\Sek鬁dVPzjmSȬߤj;-0@3q!,ay,`y۪ik9kmosrA~}wڇ$Ĥtt&px:J,Me'EA"NL?dFG۩SC;XnUHqXIO!rbߒpM!V >~|xLm8؊ƻcYwORHg!8% 
RDH9FݍeGl~4t ۇ3"7ᩨHf
-x\3);p,Or90oc#t*YyiljȌj֓~mU{}du~n|Gb/ce7TzpN?܇$_8[peحDs
SY7Pm\vmcl?Jb+?{`0n^Aa}סt{\lbw$5@:ɞC[P%AlKTw_l\HLw:X%q"K\!3(g1)Mvޯ:eϾ1
-6\ݙtRPR%hL٧njZTecG>]*U;w|o4".M8tC#/uve;qbqf^oKB%)˜?ɍ	覯94>HIV,V4@K>.Z| NK\c]t&ux4ts!HV·
BO#ك	ع9Z"WQ
ŹR9${ҢF*ѵ)&tgI0W[bx)%VKY,2ĿKWZ*ȰQe0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
313 0 obj
2978
endobj
314 0 obj
805
endobj
315 0 obj
1641
endobj
316 0 obj
532
endobj
317 0 obj
/JFBAAA+CMR8
endobj
318 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 317 0 R
/ItalicAngle 0
/StemV 76
/XHeight 431
/FontBBox [ -36 -250 1070 750 ]
/Flags 4
/CharSet (/one/two/three/A)
/FontFile 312 0 R
>> endobj
35 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 319 0 R
/BaseFont 325 0 R
/FontDescriptor 326 0 R
>> endobj
319 0 obj
[ 625 833 778 694 667 750 722 778 722 778 722 583 556 556 833 833 278 306 500 500 500 500 500 809 444 500 722 778 500 903 1014 778 278 278 500 833 500 833 778 278 389 389 500 778 278 333 278 500 500 500 500 500 500 500 500 500 500 500 278 278 278 778 472 472 778 750 708 722 764 681 653 785 750 361 514 778 625 917 750 778 681 778 736 556 722 750 750 1028 750 750 611 278 500 278 500 278 278 500 556 444 556 444 306 500 556 278 306 528 278 833 556 500 556 528 392 394 389 556 528 722 528 528 444 500 1000 500 500 500 ]
endobj
320 0 obj <<
/Length 321 0 R
/Length1 322 0 R
/Length2 323 0 R
/Length3 324 0 R
>>
stream
%!PS-AdobeFont-1.1: CMSL10 1.0
%%CreationDate: 1991 Aug 20 16:40:20
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMSL10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -9.46 def
/isFixedPitch false def
end readonly def
/FontName /PVXPML+CMSL10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 46 /period put
dup 47 /slash put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 53 /five put
dup 65 /A put
dup 66 /B put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 70 /F put
dup 71 /G put
dup 72 /H put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 78 /N put
dup 79 /O put
dup 80 /P put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 85 /U put
dup 86 /V put
dup 87 /W put
dup 88 /X put
dup 89 /Y put
readonly def
/FontBBox{-62 -250 1123 750}readonly def
/UniqueID 5000798 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9Mՙ=	0)xf
1kX)	$%Dlgg5hZBNj/!by(Nv44|0x5>*TχXwj"vǠ\Ar@zgt;B?O}C;J
ߋb>N:u񳻶o	=;xT+gW+"0qXٲ"lCpXǹSٵ˪\Y圃ۭȺ7NR>DrɍW*-EGÿ#9ѳ[BRkO|~OgrVKq|媞ڵ1|@5$ccD2'}}]^C]a\;^v|[Skz
2WM}
o/Pp)t7P^
q
L	[.DRܠK;v=|GύGy10oYN0?yY4xl
#ÈcQX\;;3U(9%–fUAƦzTFU%Gu{7	%Qt̋k
0su0.ŻݺVK2|)(џä%@xx{MYtj h8eh5	dVGg趛WASϞ
hr1;_*4CCTV0s3s!e6y}->1s}g3S:9Ps؊H'2	H~}j4w
&q0PQgϵ*mIKʨFB~Yxbxu+,J~gDL?J5У
hgc%?l߻QͭRqґƹcʲɲRhv}kTcz	ކX$F&ҳ*_kHΙH";ޛ#%\a%ҁKy-u&Hy3OǯJod7FA	a]Jk;Hc([>T_v9lK]1gF1naRб sdxQuwJmB<.QoE#3@7	fk
s2v,\R*Xo'M-
哃b%:b2H?a.V҈%;3woOԹq[JՙMG6٬0[>oÌ[k_gX$w[MV^"0$;7C(Z7b깞]CAHuGWq@bdF|i]JVOY|PMuƘ|K\'2=_(Ny,J0	ܭ[۾ڿey[Jn	
/4qLR[/(2GqUM_:4=%2*^F{`jG=bf}Z9LsE
%9Co%
31Z{gq&*V\'r;
n2xrhkә!	W	,99^NW6K>F/nBtPCD3M:hS:r{4k^]^u-xoq]EZ*KϾ#D'%#W2UQiwʞ-@<#x0Nί8ƞuH;@\3-dDJa2d5%,60ӱB*tjanB_?0o? ';cYMoI]Ҏle&3lSa*ԡdP$ftCqF*"?ۆ!+],cᒜ=):֠?DfCSSBdݧ0K=f}[Aqkn(La1[
Z[xu; 24h^0V9ݷ܅I'=ȴ|2MGTdgU:#䔬Vd9Exв?+n(<.W!o.&^@Sp3mPc)q@֙(s)xrMw}xϫe+ut~!O1~x[&`reEXMG?Ȣ#>vă_زDF}[J\UJh-X%x7)%b_|v4 $B$Ŗ2-8c%誠M~}Z\߷]Ơbפ׃y4x$*ǰ9>ǘF"#wNݶ>C1r3(B{J;>~#<@Eϲ4lr+MK@y?I7[;rNɨ
@_!bi
SA7K|;r0tٶj/|Y"S"K5nxbr| e=[)g:vRlu*~m~#+y1H8JF_*Y0ҟhu)[cL(Qxl_έخ6\I<)&5)6Ǭ)9P۱2wgG??ѳ4Z.y˴&@R_m5
1\bt횹\%K,w1vtA\*%FSo}~)[#"ȡ=ۓ[~>6e&}brƸDEW8sh50u]{UiE\?L^L1jf,ig1(ܝΎX҄_K&#
Bh?03;
|b\'C,Pk'bF-\}Y=2cVݻĶ:le+3h0o~C>߉6B
i%BYFJK5U&Etu_kDӜSDzB[v2v?lOm+A:ɧڤwH#l;洲qǒz
eޫkwzD	8#IM3)@4Z['YOȀ0AN(Qх,'E!cB|?Q5?|x]|E+`&=PuyC}-ޙ.TBRZ.󍳤bJz_Y2ϒD8Xp	f:J1#i:-˓FF&0@Q{u|
nNYwĪe	e#䣓nR~]Sva?ܵ<;.:kMbJCWmNy=WdM `coةȣ]}Qy@ٟ”KP2u[\wQ&gj~#r:&;{\ir{ۉ%S1R:{UZ!N$	pz)
{8'nPBѪB	"Co"uYYZrDZdSߙ3C
_%CU)gY:XLI"=
I*++W*m)wn;è?xZ2/
g.):z
{T	"jjiUoqB"acu$r\PȌ5^/p$Vy-F_uLY/죾b4yf
зi9ChۿDB.0iN
&}T7SyZޕv,K?:^I#"TC/Hv:/ڈ:Ȁ'R\fAI
"ua;ŔzV7a.owP2yhZJyB2Αb)j'V85d18)2ao/](P2THm|WʨI}Q~Q0¦
	gt{4~?X  `!ox+O%@G7ݦMǗDNJr/bV4+-K\Ý#pw7[e*dﴺqJDYQ֥WUCc{lwϵ=˂M>ʾV.AƬ_q5{㥋z+E=
/?pClӯm
6yhoQ3^I">HUA
߅{pVyKwӏ+)u8
fG*t
}f+;'!'^hwg6]Lt'xz]`O%^mqEMqZH&PHXθ
*!o&wq

&>ĉX¾p+Xy_ҧQlVy)nZǒ/Q^.'C8>O%:E?ҩg@#b0$ι2d_]ݹ.\.8jZ𵷳'bži߹)
yXNiBuKj:)?.Xh\l2ǘcC*>'6'ňjO
jȿH2yPT>vD$nA#[\="Yœ@)gPט
1J> endobj
18 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 327 0 R
/BaseFont 333 0 R
/FontDescriptor 334 0 R
>> endobj
327 0 obj
[ 615 833 763 694 742 831 780 583 667 612 772 640 566 518 444 406 438 497 469 354 576 583 603 494 438 570 517 571 437 540 596 626 651 622 466 591 828 517 363 654 1000 1000 1000 1000 278 278 500 500 500 500 500 500 500 500 500 500 500 500 278 278 778 500 778 500 531 750 759 715 828 738 643 786 831 440 555 849 681 970 803 763 642 791 759 613 584 683 583 944 828 581 683 389 389 389 1000 1000 417 529 429 433 520 466 490 477 576 345 412 521 298 878 600 485 503 446 451 469 361 572 485 716 572 490 465 322 384 636 500 278 ]
endobj
328 0 obj <<
/Length 329 0 R
/Length1 330 0 R
/Length2 331 0 R
/Length3 332 0 R
>>
stream
%!PS-AdobeFont-1.1: CMMI10 1.100
%%CreationDate: 1996 Jul 23 07:53:57
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.100) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMMI10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /TYCHAA+CMMI10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 11 /alpha put
dup 25 /pi put
dup 58 /period put
dup 59 /comma put
dup 60 /less put
dup 62 /greater put
dup 101 /e put
dup 105 /i put
dup 114 /r put
dup 120 /x put
dup 121 /y put
dup 122 /z put
readonly def
/FontBBox{-32 -250 1048 750}readonly def
/UniqueID 5087385 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9Mՙ=	0)xf
1kX9JS:6V =!X>KM)9!I}HWIUcl=GeZm>nQk2=1p%R`%$]c{!W+8?v(+)0ӈ!YahtA?H@m?|M X9Հ֨#2
:m,MZ+ǒ\Ex9Yn<Ŀ2^FC[`T+ȬD]ǸFF$oB!>;A\T hxh|5:6;ϖUǷ6~k.T*{8K`y8'dT|-QkKmy9	91|Afr (K*)%_ʬtP`.rY?nrn{v2O_5;\g>R{4_
:9pEz~GuE[n窙i9ヽu#=X&>~J~ПUt0t1Cqs-b5	4AG˧OE1"?@~
R
Oԁ>XO8' IVTnP	#ԫ3L3zٛoH9@uD	Jsf*+5x/Jl dc!=2~S،%Ws{D,Exy`_4垱2O兴g(%V<q)əW~#&f*t+3+<E	Bӑ|i+#c+ƺ'VRK)/ơ'S{[U46h{
j+9|.Pyˇ 
{kŠH:ƭ_p,Z:s q}Kњ.k&nP)VV.8b]ؙMD*pkf-b:TTk\e"
0x吹ɺO:6tp-&ר
pWg%h$ƕ]XT}FZwq2(?_hJ^M-\vof")dګ̷R5O]&hp0_]4
@Z(Z&kUpo>~KuHb_)c¶s]8WyǭGWDt8Bʭ&C,-ԸZhuy+ΊQteN4SsȹK/ǽ;X61Ct"p5fY=B|=Ľ2j⿧F郞2\
' v(py=-G~-9@v2gjHˀx:K6m0:r羓-ɜE|CLu{ښQ!+hZDGOna4pG&	]Z:ʈ껼(9#VQDdSLuşl5=l*Extr˚d	 ۪4T.WP3Ec=0"rv_|wh9
7
P]3\/eU>x*;D;QtD&
x]lݱK]~gK%ԑRԬZb>GT?aMU(q{B8d!]ح$JSJ+y?WJ*P
x
7wTjhо@AyS%[dZrㆁBf0c9gطvø&-$\
i)b0$AzΥj'RF8'joK|wo:OMnC4?a`N%zJW^),T"#Y Fs,|
jg1Zy6&
:gz*b=tzu=V7՟q^ZB+%S\I F0g-EE(I~슜n+izXRMr7~i{XfY{J4Fhىdu=>gHx,Kc?ÕkҚu,T?`D9Q-i&Ġ` !,dtvl7<36<"q.q]<6W;.XM+I!}5Ğ:'TXh<(L8H5i&vfhIZP.pa
(4T#wE6{WU
zPwJlձmUp :{߯aAku-~R=˘uD=m.ao~VlJycYwJB}
~åǼ-nuZ]_$v'(-s*(Д˷p;4kܺ*{[bYq;-|<6EV򢪞
iŒTů 9}X(#}yh4d}d> endobj
17 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 335 0 R
/BaseFont 341 0 R
/FontDescriptor 342 0 R
>> endobj
335 0 obj
[ 627 818 767 692 664 743 716 767 716 767 716 613 562 588 882 894 307 332 511 511 511 511 511 831 460 537 716 716 511 883 985 767 256 307 514 818 769 818 767 307 409 409 511 767 307 358 307 511 511 511 511 511 511 511 511 511 511 511 307 307 307 767 511 511 767 743 704 716 755 678 653 774 743 386 525 769 627 897 743 767 678 767 729 562 716 743 743 999 743 743 613 307 514 307 511 307 307 511 460 460 511 460 307 460 511 307 307 460 256 818 562 511 511 460 422 409 332 537 460 664 464 486 409 511 1022 511 511 511 ]
endobj
336 0 obj <<
/Length 337 0 R
/Length1 338 0 R
/Length2 339 0 R
/Length3 340 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTI10 1.00B
%%CreationDate: 1992 Feb 19 19:56:16
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.00B) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTI10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle -14.04 def
/isFixedPitch false def
end readonly def
/FontName /CJEYTV+CMTI10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 11 /ff put
dup 12 /fi put
dup 34 /quotedblright put
dup 39 /quoteright put
dup 40 /parenleft put
dup 41 /parenright put
dup 44 /comma put
dup 45 /hyphen put
dup 46 /period put
dup 48 /zero put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 72 /H put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 79 /O put
dup 80 /P put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 87 /W put
dup 88 /X put
dup 92 /quotedblleft put
dup 96 /quoteleft put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 106 /j put
dup 107 /k put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 113 /q put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 120 /x put
dup 121 /y put
readonly def
/FontBBox{-163 -250 1146 969}readonly def
/UniqueID 5000828 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9Mՙ=	0)xf
1kX9H!.vPN
7qjj7!6CɫTw.]ʂԬ/J1]0':fqdU24tԡ?@^g+0[
KTB/UٝFMz7.U{7K.=UٯIC^$O7Û-tGrzJ:"ia~
T"*^MMчff0EM
z8uwi*?rw5(*5nZ٫
4*RX&RTdRM3mѫ& .Pd8;]F	|H!%T[-͘ޞ
E|pV$MU]n11RP}
d
.{IQ7^N-+C#̲]\M؅1
pk2
\t,o)2TTڮw}Ҏvq`;lSgs3c-h}W9;ڤ9Ö`2	${};;m򉅘^l1'C.]~/ِ?a!ic7A<.ʤpIDm1t}J]j_ΆiUǵe4q8}Œl~$Z0ү#+2a}o]!3ZaI|qxiܕ#N95.+lR[qĹr[İU߬{(WoϔѢ#>i0
1.EWNTQ0T4c][+ }}=mã-a~:@u5WšT,R,ΤױP[*NY5L5|hds%Ap
,lISB+
\1 xFM8-b ^qR|/if^t\z<-[.9\C_$F|iC[vy'D +!a?2
SjnCW"{!Z$a@YʉgϸÜA+xXw
qܸW]Q{t*RG	4˺'<8PJ>bmCj{-09{WEBr?@?CڶuAvyzޣ턴as%ɡZе׮1])O%35ƍBI0vn<$kK8I4"4@0X氉ʲ*4~_"uuɿQt0s ~\v,'CyC jZ+H]enwP.{<.k,:21|{
^_/#د)V^0- ǩ(V9y}#V?JITgw0k\0ƒ
^b,fK_="niQ"$Yf90AIsjϕg7O5rDLTP$Z/@׎-HX	1R(nbP?ERɤrgU:Lu3xu꧁QP
4$ˍ1C_wW4$"z}3ԹfbXUCi}(y^k
kTF,6it6`	$_aW;WRF	aWv<J"Y).03|8kw)	ušABELu1v!vY8Eͯ"ҋKh(EѲ'-*[+ÂNj[@/r=GU&^0QQ
$x'Ue)!W6ޏi(YC~Lo*-M;QN@nz;F~
Ni9U68h7曷b?i@hq*xg=+FL'R"qyGb#ʠЉۀ\GgǤD5'r(oo/~"|a5+gzZBdkCuT`RN7vtpwޫ%݊L
q=-
0[&<zv΅L7:}$}M]߾ǏxgV}
N|Huz@md?O-em47 	EOUƃŤ[&&r3|	T:5GFPK5;o{[D)iv:+io%T(UsQ?;҈jj\RQA/0՘8!W4r3ݓMGpVvL'J,E0U:,JSGrLf}ms,*J8Ǎv|BW.v F0e.]4!q­y:t}2}pPqtT*߮^]^ˌxD:5k񤵪<'U-1nn"B7(Psjlz^_%#sC0Ņ#\>ly9+	2dƑ?9)sMv>,sg:u
;+s=F1R2rs̖?fQ
AJ}RQu`;|BWt^<͞PT2ҁuz=3pjv/!-g}:73S2f/"^^Uhkx(;oA#MKkҌZ	Xfq4cĬ.VVK	qJb\K9J*kȯ]fH{m7BOD8|ն|e*\$ܯۆx$|וKRUzt`~&aAzqķP<;az'w}
gC˾a:;*#d>E6jbE"?V3~)O#n&_/Ŕ[@#^rܻ.+e}-璾bz2#{<4GҒٷnF az+-B5TjhG?~֖?'."*CVlXKa\hm {lSA".s`jN/<+eM]Ǩ옓V͓e=}P`nDRRzJ/9Uǐ526ٙ47SQ q;]?)`">xkAä	^64EP<`p>Ah?.sF867FZKڋ4t._USXWkƹz~!(MmUzt,t4lmU/GbhnEYc٬[_V9bziG9	$8|um /3)$e(6$j~}ǟD-[Af4j
Hd~v1XFΥLm3Wr7'JU[)(=!}ME5}
4GG-8T!&UkP ,\K9")!p[qeQ0PΫf)%(C	S"BwNe)B]\[zrU0"!^'3Tp$$tfj|&e7g>\=i@☶eÉ:v$.~M8Cդɪ0*
H
8!X3GF)خ4?yFer98n)r!#0ׁ#dpQ_wx!+SS732#MtG46wVIVLzK-R؜BIwJjYb7W;~@$wU7~GnllmJ̽n 76MhZm?$N&\qME
Bω=-搪ϕzgu7&nz)^(R;GF_vCf.sz,d,(-F%Ew8N}sc<ZGr'3B#zńSx,ڝ@|B\PQM^ڜ;ub޵	}nƹq:IV}?#K5ztG_ZB6PXvPiHu+c6xۢ4ŒAN&l/J,`XPnqv	Tw
">8,HaJ	e+&_J ]H|C?ٱV;{ёkPIm
zb'*LUblO((:GR"xCS-	wA".?o~@e-6T=o/z-᪁YNOim%
-8pD߫]P0:z;S-!7o8'K'Ĭ|3gR41/]Ig$|yc;c#ݍ(UCHC˝C'G0:qNL3
e*=ԡ;܍w3D໒d;6V;>{Ywj>PSp3^21FO~'
akY\0ʂ?4MN7x@Ҧ^qftVor6-Nxs'HטqV	KB4.4Sr%vLN|Sem
Zk-Y蔧ua>ux'APoZ9]ȯeu…KG{;lߢfdY<+>@眴
6"tqUp(`~fP3NQRd?Tg_O3AzGW卆QP(oPBnB]3v_-c$	/Nt_rG.:>pmt.-2cO0>q̡4V}nu GozLM_mzKԳ
"C8.KPIJ-]2j?F^?- D[h&SWT[+qҀ;HdBW6uw  -fUi[,*((`&h. =ΨK桭>(Bxl=ހ.6d~z_	uEf*%JRhi
aq1wVJR%o&4hf/zߺL(kd\wtM5R.XImJ$o`qj/z}`.m6!bra-%  spǛLXC

S<2_0Rfɪ96_~>;+}%;9&\Nzt$G/"BVmܸ4ni\eO).
q}
၊NFv4gP韜~D)3t뼒74FF4}Ja&Jk>\6=k4Ӯ]duf=&$bFEYڛDr!Ar"7ζEM,RClIkeog2g^ҏ2+*.9m0Oj6Pe]ň5#Gkm,&0/
*N*u>Fy*Tb@1+ϒx5xޫ4vs,"=
BtWfikH"[ܕ=BJ3L]*<"]Ʒ)u%,&_yG*so	p+tb^ |h|"|ŖI*3rq&NR0:mq
+X5";
ۢ%bY]Tٝϴ: 9_Pt3\
z.ۏX`2>ợ0z5	2"p[Lw`;L&ꋒŸ!qVl
rnxB/G8=Y@eЊ>jFۂ1@Mo
$H>gM7x¶]j2W&곛~#)׎-ys
}Wʵov+	"3h*fc4Zvp_6
p'{leLbR)-r\"ώ'63*p}ThJy`Pi~u&r٪%	pm>$Ե"joM#FI$m_s6X_KCK+
_3guY뻶]0ٚH'X$$nNtZuSXKcI~t	j'p
6esl\{ks%ɥNj́	ƒ
xXH2tqĨĤɳ0Y݇/̳]އ^g,;&+4%4Dž
Iɯʯn:)?dF-cpD<5Ҹ(	Ljւ“'"Q"SujՐXq,%!W{Ie?#RtOBBZ)%kw&(A$hcZ aM
JAQC0}!*7'į@=LJrbKΏeܭ,OOpkq@B*څYg*g5@֞-F1XxawҸ4,uG8v8K'a~aj>[HjjƭDN,34"~0_u#z'^/ڥ3a:һ;*q1=gto
K{fEq}`t
5Ŵp4DG~M$ǿ)mCh9$$#=q.I\b%ikYNSYUC#TR*2 넆I1ه3N8*b%ǵJB=Z;a/:zÇT{xeuM p:1OE`렞Evb[$ekF?r !.LqM_QS9HI&<#M%9pg~etgRzժdyP
"rUZll tP,rT[ґf4r3X~W᫃싗kA;؎?m[X'1WyIE?D7ހb`8,3CuBi׮eUx/osΫLcu'P!p=r4JVvITc3.neǥ_@kyƻIr,kB`axoFqdWU <}u9VÕ4"-J`)ܨAf}J.~cRQ8{(GLM3`3#?lw_"[6NǜGLkȾ"V?	+0AmHtW}:o6pa\g8~$T:qWI?ʸCe}^>;u&3Zb&\8@3y;mZjh }N\*Qw	A>+L1
: ÷	{FnP1:0B4/`(c+9# 
۝5'C	/]ȣHVQN)FjJllg*%b_/J
T*^OSM}"nW,w'$l&2b@(y?Nn
{voWlC0ϐT
V}|V!r);M}gQhS -

>A>Ȗ}B
>{ 9d5ێ7F5
>7zʒ8>OBa3c8~!Dx[wsJ>r
	[G\%o0Ld&Zpɥ+Et05W򺫓xĺf &WQ_atG؉L:}Q}S"t53[pXG,4J+GP[)$UG&NU<
(77;R
'>fLBfԈ(W7ˤ57="{Vښ|,屸a|B-+_YK7?oH2oM5h#Θ7U-d*HQ\R.p2a>,c#"29
!T\qunlni`[gB;mp.8"S[ab{IpA2"7Fy>hhhqz[/
'eehR&> endobj
16 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 343 0 R
/BaseFont 349 0 R
/FontDescriptor 350 0 R
>> endobj
343 0 obj
[ 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 ]
endobj
344 0 obj <<
/Length 345 0 R
/Length1 346 0 R
/Length2 347 0 R
/Length3 348 0 R
>>
stream
%!PS-AdobeFont-1.1: CMTT10 1.00B
%%CreationDate: 1992 Apr 26 10:42:42
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.00B) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMTT10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch true def
end readonly def
/FontName /OWKOUQ+CMTT10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 33 /exclam put
dup 34 /quotedbl put
dup 35 /numbersign put
dup 38 /ampersand put
dup 40 /parenleft put
dup 41 /parenright put
dup 42 /asterisk put
dup 44 /comma put
dup 45 /hyphen put
dup 46 /period put
dup 47 /slash put
dup 48 /zero put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 53 /five put
dup 54 /six put
dup 56 /eight put
dup 57 /nine put
dup 58 /colon put
dup 59 /semicolon put
dup 60 /less put
dup 61 /equal put
dup 62 /greater put
dup 65 /A put
dup 66 /B put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 70 /F put
dup 72 /H put
dup 73 /I put
dup 74 /J put
dup 76 /L put
dup 77 /M put
dup 78 /N put
dup 79 /O put
dup 80 /P put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 85 /U put
dup 86 /V put
dup 88 /X put
dup 95 /underscore put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 106 /j put
dup 107 /k put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 113 /q put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 120 /x put
dup 121 /y put
dup 122 /z put
readonly def
/FontBBox{-4 -235 731 800}readonly def
/UniqueID 5000832 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_c2Bطj=-8\Dg݌] /%bԺnٻڿSy	b*L(9sWF
R:EMksH02E?Oe+Z'zK΃оif <,EDNZ|J#BW3ϗMp(%5%~(5Bk}Ajc'S-8*!iy$G.w	g	
J0nr
;଍ Kr^ox7p4=CyO#y[49'n*xx/J}o֯p6Oޏe}hà1W6Ϋ%(i]Ii
텴""b3=5sJzbJ>[WеH 2"ێ0Oy9.t:=$EǪ
]to`%
'EKKfrRK^y`vO^v~ZwR iNMW3HSp+T,q!s0(ع;U+3"J8q3dJ`77+kXֻvuGga懨O|?Ja\Lp|j	5	լhER5}
d߀?eu6sjDh*/"qJrWx
#1].kKy;"%o(UYO![x;o_*A*O˵cTtEQ	&+KԌ PJ>薻Cy_5XK"	0,pr0 BZo3ij>r̐:ԫv0I7vqt@'*STg8E.ZQp׊P%x^a&(-X%OfCmTsCJzZפ4k^H	J=o9vMLg'!Tx}ᒥMF	{'tV2ANX8	F]E 	{b&bfo_%pT1}*ڢUO4W^t6U:05:a"0~rn:%g@Aɠe`Oڀj|Y}#xHR~@paAY<	Z.#0ȼ. 	DkQ6MgDțHhrtml)!|=~tWPA߾Xxɮ'[Y"f6S2P)Q1Dl;;Sz$̢!)Q\d	D}N\ip,:22N^x"6?_Oki֧@2|[(_c6wL*^,&l!+U+.>AZĜXYVχ%CN+7an;H#e2{f3zUI9xa]X7W^^.؍=ŅSϡ	pݬ@Aεr$4q^҂fތ]Z^X}hrÔl%Hb%kגw2<-Jׇ]GguRڠ35qZ_aXO84)*j+1"IoN9ԞɆMLNٱC#lXcc_JB#L5Qؾ=B?K[\XSB|Bvei'bc@DNA&7?](+
p8PYp:ؾ5E"Dr;&y~}_2&ubm&?2]#:dBvjMM0%yګ<#R5|Mq2^_(*@<nFX8'W;X	X?b#ڦ	+}-I;*-qKfBs&1rwzF}x\)f	{`sA<_pNHVUkrj[z	F~0e#EAS6!UOTu"iz~gX	<$AZXbdsP7s	.04_5dm7u>&zgis^mAXiՆAZ2Hv,B3W'{2Z=6v\/!{n:͐.$bf>1Cz"N՝/(f];,`jJ0kO
]Yak97}“HB;1qD~2,௲"t.-L:d@@ܯoV'wMgi]Du o,>WV'>2F88n7;p\YVA|U47TMi9q*< 9;L=Tyͳ5b+S0ǛKQGVgBc>s;^IegCԜl$}?9'~[A~!I(4/ 8ڝ!"rQvƄ=6ji<*ctFL߉'SU@Q)cI[)1w"&Uި.׷,y%c@]Jtmr(X9,>LۿX?K9 *0gXJޖEhlYFEW](
rI&kxGv׺<˅ 6z\,/?"
dj'12f~hݸ )L~
Fķ5oXI93ǪEp{ d3ļm< 	8*6i2CAb晔0{ﵴp/id[h7:Z"1
g#y	pw2%(LڬC4;w}F`z̬!}m/vsxM`rM,af6ׇW\D:OenBWҼUf9kݷ0QH(Q^O
-Y"n@aQDQUU#<R#[lB+eF30;ew=ЀT|wEr iTV$Z,V—[(Z\klٛ!pϬdthIO GϹdXR^aR.5JxlU'gz%7ཌྷE90v$-lAtEeR8`.HwP.gg{+͆Xl"`~&%dόmSIˏklOWmu8A{M)dmLÑ8ױl#_&M(pt5n퐵Țs$j[ͩ|AEA<JE"V`YGU+IM+!uȼ*7͛\sT[[dHxT~Wue#BcGk\%=OVuKP}zBᲶ"e7p+>[h{%=[QeJ"	U9x bצATqEe)cc7׷tIaӧgu`f;+tk6ĚҶBMZ/rn_(LU::>Rנ+p^-Or/{W@no
!B}i(/ʋIk*_!m2@-n1ȸ
3dݩ܊nBE1 +M#>6	% Q.[͒D<-h`m+?ZMe	092[ZثsTnjqwd	
~v.qULPwl]#R)\;ZkK zjl5%eW),A;:%0S2o9wޑŀ2g:&ta*G;xD20w	&*:qDY"5h53Lt(/Nך񈿪Bgg3)KHTU!SnʻuKQ/#$Aax`btpk2Eoc-&6[A+i:P;X-=WԛuIIFM)U%1(I#be;T\iQ'r+UӌyRE6(`5fvbu6|t#&7BS>#!kZdznMlHxWB=!ND{|LV]DMa/s^Ɇm b`]XUy#b3E'YRRiOS_ސY٥~̤*L]Yq01'n5UfHևAX(1vU%4 G>HL$Zer@'|.L)C8>N*b!E'r-&Gus}Xߏz`FGLaYiiGicSlGe:bikI2?	yH)tv[mErؑO)=@e0-.$"R9 q~^`/3*s*F{w^S
kHHwЮ⌓9
656X1_(}6K;ʌ̑TXUky+ITzT%
O"!݌^JiGpo2V
;Qӎ=[{D]uy~a{R%o39kržئscoM燈<@rFUB}mZ8'帻cQaCA]^<=$W2DjO/O'S_gXH|R˄j1R3*<].\}8/&d>ý'<
8㹅ؙ-+Bx=^*l	XƑFkq2d̉`cVGĆ᱄9˫/MWOɊЃU2A:r8+rpJj:ƴioA}a6ZSV}l4?tsc^ь@)H1lrB:lL!B{xV	ON궢6}Z7|Źm &weV Ihx!uI*VJ쀝jA.QTĸ_8Ul\c]r۾&:p8=t-%Kk˿7&n>-ZG>U5Z^2i_@{6s'v@QFŁ| cmH9wrTZ.zQTR$.r=K%Yܽq<\!h"u:K?ŸjƪnNA:bH&@ DUushMLEm_ž~J	qZ>MA9A/`pqLzlmݞ[8??ʠEWJ`M~i/DYBʃ:Ϫ]&xe3
,JEH_  8ؠ)/o~G3]aI3@z*4	t!pwW}\asecԜz7=9ߛk*BKn3I3격:I-0ƼYEq	wlnpFAnzlV(j;|(zZJS5d
0ѭŜe\^rN>ݗKNu&UGI'JU+*DX6CUs=0]6"(Q
l(P;uKa=@?<4uޗz]kGLw5-H`vLji7VsnӢ"[!/$SMX~ԎB'iy}54uuCKƶk򧻽F">BZnI$^o{Yl'|4;{gWa#s5}\Yx3~OVt=*)	!,Å(
~0PHxa0~7]t"UAg}j;.	?䱼'i-4iδT+QwCmꨧL;Pr8=21 ZMx(僾:"y_@wƺJ:%vuMh}D/5!_Rqj,n)K".]lLD^3LP>?7%k)vhHGB\}kE\g3X)sw0
t?J̭0!֓.]ڪdd/VՕ[|sdw 8KDϫs'rLc^Y7]W]SԒ<J(_
F,ƥt!GHp"C5}7Zl|3~m[XN0]t-ks{Z7E	ԤJ&6}^#WX6Y	!`0~ejK£<0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
345 0 obj
14584
endobj
346 0 obj
1910
endobj
347 0 obj
12142
endobj
348 0 obj
532
endobj
349 0 obj
/OWKOUQ+CMTT10
endobj
350 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName 349 0 R
/ItalicAngle 0
/StemV 69
/XHeight 431
/FontBBox [ -4 -235 731 800 ]
/Flags 4
/CharSet (/exclam/quotedbl/numbersign/ampersand/parenleft/parenright/asterisk/comma/hyphen/period/slash/zero/one/two/three/four/five/six/eight/nine/colon/semicolon/less/equal/greater/A/B/C/D/E/F/H/I/J/L/M/N/O/P/R/S/T/U/V/X/underscore/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z)
/FontFile 344 0 R
>> endobj
15 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 351 0 R
/BaseFont 357 0 R
/FontDescriptor 358 0 R
>> endobj
351 0 obj
[ 692 958 894 806 767 900 831 894 831 894 831 671 639 639 958 958 319 351 575 575 575 575 575 869 511 597 831 894 575 1042 1169 894 319 350 603 958 575 958 894 319 447 447 575 894 319 383 319 575 575 575 575 575 575 575 575 575 575 575 319 319 350 894 543 543 894 869 818 831 882 756 724 904 900 436 594 901 692 1092 900 864 786 864 862 639 800 885 869 1189 869 869 703 319 603 319 575 319 319 559 639 511 639 527 351 575 639 319 351 607 319 958 639 575 639 607 474 454 447 639 607 831 607 607 511 575 1150 575 575 575 ]
endobj
352 0 obj <<
/Length 353 0 R
/Length1 354 0 R
/Length2 355 0 R
/Length3 356 0 R
>>
stream
%!PS-AdobeFont-1.1: CMBX10 1.00B
%%CreationDate: 1992 Feb 19 19:54:06
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.00B) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMBX10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Bold) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /BWOMIG+CMBX10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 47 /slash put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 53 /five put
dup 54 /six put
dup 55 /seven put
dup 58 /colon put
dup 65 /A put
dup 66 /B put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 79 /O put
dup 80 /P put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 85 /U put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 107 /k put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 113 /q put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 120 /x put
dup 121 /y put
readonly def
/FontBBox{-301 -250 1164 946}readonly def
/UniqueID 5000768 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_cst
?}ߴ7-95†笟M/Z+FCxw\#㺴DɫN^?0^~o&fZ9-(*ϟVV9
|J7@s.$DFYMi+M즒DSW['1qy4qZ;]6y@F<
V&N3n]Db	a[sK
kԃ9$[F=e,&Ȩ)uv1DVIjaIç#
5k~QaMjFJL3.0lVem;
YnⱪyRyh$&'gYxQi-o	7kacg92X3]*#5kհQa?aYtVSQj)ngk(F3㊮FH~QGZx8=9IBr{_YEMn*ܧ}KyW3K)UNީ>[GR"a1b;:j3g߲gҀ7s҅RhUSh7~dUQ[#OM/܂U%Lqb
GG>hmC19YLcwI+F	)s#2TP
"L#$Wb8y$;
7*XL,q]8
"QSIJb
yԶ! k8PDݵ%C;8_nPz|%b7K#l2GAj:c"Q9acI{k~]T@sd~kIEuAy)[:6t]?X3T
)*٥d8e,'$eT7OTl+'#3Y4_45ߤQ6)AXLM3*1AxOIEb&e9|
Cs灧@J;s.mPQDb-6x~[`VV`**JIS"%{.sLF[[hQ8knbT*p
KGQlӋw
&[Ĝ$kwj߁݋TXT11(uܡu\y[^_#WHurF(!p%޳9%{us?D~Hi$sJ2U[^\ԝg])~-HBh5>هPy@SBa{2gW)X1Ac0
?A&,9GZG(zԑ1{ *&oOFk?*onJ?T3{tnq)Tbbzn	ʷ6*`8}4_ޅ48mHF-+J'b]@J!ങLsyps: E!f#(#wNiԺBW193(gAc
pjqc&ˍt(U˂&I0ǽGU{/?hx>M`(/ |#}S혩`Up͐(E0,e
e|X`fYԢ|;=c`f.ԅFϥO8'3U
傥4䃮wV2ˀ2N>9,&c7|r8Mq}ƟȄ
g68<
M lu=hx7GGjZ^}mD*|fbK2AKށfY~?DvN3ҕ)&f^i4wYoZY*^չfeZ
/&;%m,r	칋W5O	+,Y˜,QylCRldNu0'h~a	RF0|(ƚ@d>Sʇ%wu)yV
N,SKJTnHbTĝE0}LWmjlsQeXwZreŕ:)[GU.JrLpV"pݗ%VOW1#I@D\;?bzCTzAPy0t@m5{%:ZBpgUG%XjCfbZT
-B	}g
ePr֔!O6Ѓd-~@SY,eyaC1"%y=kPk:MEX>tԑe)	[[[/YFnCdJ+$>F	
=l
˅WmnnukcNx̰B㱦"\Yy:#B,G,xeit:H'o6Zݺ٭	Ad%GBBrUWLS:+ҰXT;WM3XSJ])yJqblܥ7SWJ0UxHрd;_]fþ}efu<DY# ArdOIz7f*aWq0YX&X&뛕䥒	/89f
VL`BI>66R*	Q|2re.aLJb8*iH=$K(;9jѤA˳b顬q.:Y˦Jk?O`AMH?qxoEQ4͏\4M>}Ӧ%Em?eD[f|&%k970`*B,m'ה3v&X*$PqUZ^h6ngsQ݃&O*pLVj&7(vx?q=R$RM&%$P]e+'>yB6iu+_4ɰQw_0g2/RkPz"

"68\	٭|3ybsqT2.6mN?dYeP3cȀw5+xh!-p51#QXڪRVZgw/|l/s1PF瀙#G{~{)]6߆d͑pR5:@f|_USR*_*.ga<}NW=abdsnȟRNm$!_;}'r1"`oC(Rײ^wKY#|+|%vGLr#K^S%pU'j޺GnE_B5}˞EKg<8=|FǏsX?1;{7#o(ݸo_U!bX_=:
vJ8!RFJڛ8tE3jfIMP`1HV"6^=b~/+=HD;Ր =C?߸J'QeMG{I=%ĊOͷ,R8F|10HMŵ6pK߳9<ײYɤ]eQ
A
?v>D",n^Q'>5ukJ^`hDŽpRoET3[r#}/:B!0)mC6iRX#o l-H(E*Pf}	"0`x*Wj2nNtZa\f7kcY	N:#`͢ȐOx0&ڠ!s}?ޮ&Hʖ73ݢϲ@*sZW
"oia|ڿtnoFl/%0v[k.a;g!h Bl}Md<~A$H4h_
ZGR`AO(:9PNg4jSpLMM6EoάhZ:<ɲscUXUVUv$z@ffFnx9J-%|Rnhq|K	Bm@~'wᴓ9W?_@BWՓBbOȦ¯쟲F#C_*%vz>{«I1Q&Cauqr"MA j	9FYwGNA1ܻͪ5L&2r,5-k-df-mGK&z lSVފKba/t^%SA@`#%IdơAє5k/
CIpFr_N/@mڶ`nJa#&q378	S<o HnԱdL)!&]JbYAIq2q"\7[Nį<2=W
lC$t7Ef[07AdaƤN_3߳YPV{/K-@׭vҔmNN~|Yϩ9|~T̫M]K-i\Œ:Bq|$sW:e
fo?WQlPvQ*KDkjx0Y*F`M֑=s(xt^z$4'M>ݰ9
!`b$4(9Y_TN]aT?h½4m\܈ƴO;ӞdL͛+1ެnsIyXkȮ0sӒUZf,+
lץnli="Rqs_K^֧Dly
\x/f=k#*eu.\Zˇ/WpQ&f'4-3
A<<
D4C |çğB2#} (9ȔNnȂV@rE ~q^яT$!wRae[B´IBqs|ͭcWƶThpO0cfo,Yheי5n!
nFN͟q	J@W1I78"Id
9.:T'z59Μ~]PN wYޘ;ѵMu4Vilz~
"na&_lf|e71ۿnr0f9dG\cݛuX\$=Pz)9{oT;gTltF8nH%|5S)Pbk˿ufc@Pc൳m1RK:6B<.64T{O[Y>/NK5woJhZ4)LؽAct%i]EVqx8>ʓ˞y[elJP彆d.*e%ڲR
/˷͆Qw'2-WY=%/L_Ӝ2[+ݤ9^jh]aR=LF
;+Hp@ؒ5$<}'"[F?dͬm^Eywg.ￎ}P75dfoz95Ɠƹ	Y1^eτFt5>[gI^m`ŃFR81}k2ߓ#(oЋ?iZ7	"qʸh΅\c]T^o:l&q)%иNe%c
tM.<
[UŜIjWVŕ"	%:xr2:3w$@cc,-DKzA<@{(g{YfVW91!4e'#Y8 BDA42%ȕM̕ɞB׌
,RyrHo2OdS׋]uVY/e!sD1abNt^&*M75W@>5Y,{Qa̠w&U.A'xG͖.N,0hD
	Tݍ :b`Bg[!ReԜƦ "uJ: }8'S5'V֕`Cǚfqg#VtYr&	2Jpp錬B
ҌvhX5aӟe+5<8{(X?EaYd1а8`\.;GtlRA'xcVX&.a,&I
_A8W!B6>o`bxXI(+5!{&"=Hx$ބ[TLwsYTc~4kQ{G]قdp8Q8_~
q&pɗ-$ sŹS_:I>VFA4'!+gX_DҬu4,7`Ђ]~G0@n.]޼v?Q4h)`9h܅ȭ9^7SݝX nvoINC.GQ'Pt{p{2hMpEw_Q+&R80<1}dIԡn"){ooRl:D MRFkcz|4ܜQaԭ{B_nU)*_DKkw)	Su%CzZv/Ch(_"+9E5"`vWx.9>рA℣Dgtf|s/di?muPp}/O5ɥJipY
װޚ
7oԮ'kL{ߔI@(R0\8_h#9 =q{$hՃȿހ2락@vz@4{`\5l?>͚Y{:fiW#<|t?'G-IJ*e?4۸53:vB,䩍z$=bӲBQ{ &!I8

*,qM7Ϣsvd2xXCncRnjV9EGA͑7̷cye%7
bBźpwN#lI=SJcbErmt[`#9M|-h!Pygt?cu!>HKeHŸ,Uvꢯ|=gb"N
w{}iNp;@@ݶn\Ӛ[OSڪa39Tȯf/-μ0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
353 0 obj
11608
endobj
354 0 obj
1457
endobj
355 0 obj
9619
endobj
356 0 obj
532
endobj
357 0 obj
/BWOMIG+CMBX10
endobj
358 0 obj <<
/Ascent 694
/CapHeight 686
/Descent -194
/FontName 357 0 R
/ItalicAngle 0
/StemV 114
/XHeight 444
/FontBBox [ -301 -250 1164 946 ]
/Flags 4
/CharSet (/slash/one/two/three/four/five/six/seven/colon/A/B/C/D/E/I/L/M/O/P/R/S/T/U/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y)
/FontFile 352 0 R
>> endobj
14 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 359 0 R
/BaseFont 365 0 R
/FontDescriptor 366 0 R
>> endobj
359 0 obj
[ 625 833 778 694 667 750 722 778 722 778 722 583 556 556 833 833 278 306 500 500 500 500 500 750 444 500 722 778 500 903 1014 778 278 278 500 833 500 833 778 278 389 389 500 778 278 333 278 500 500 500 500 500 500 500 500 500 500 500 278 278 278 778 472 472 778 750 708 722 764 681 653 785 750 361 514 778 625 917 750 778 681 778 736 556 722 750 750 1028 750 750 611 278 500 278 500 278 278 500 556 444 556 444 306 500 556 278 306 528 278 833 556 500 556 528 392 394 389 556 528 722 528 528 444 500 1000 500 500 500 ]
endobj
360 0 obj <<
/Length 361 0 R
/Length1 362 0 R
/Length2 363 0 R
/Length3 364 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR10 1.00B
%%CreationDate: 1992 Feb 19 19:54:52
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.00B) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /MEFEXO+CMR10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 11 /ff put
dup 12 /fi put
dup 13 /fl put
dup 14 /ffi put
dup 39 /quoteright put
dup 40 /parenleft put
dup 41 /parenright put
dup 43 /plus put
dup 44 /comma put
dup 45 /hyphen put
dup 46 /period put
dup 47 /slash put
dup 48 /zero put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 53 /five put
dup 54 /six put
dup 55 /seven put
dup 56 /eight put
dup 57 /nine put
dup 58 /colon put
dup 59 /semicolon put
dup 63 /question put
dup 65 /A put
dup 66 /B put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 70 /F put
dup 71 /G put
dup 72 /H put
dup 73 /I put
dup 74 /J put
dup 75 /K put
dup 76 /L put
dup 77 /M put
dup 78 /N put
dup 79 /O put
dup 80 /P put
dup 81 /Q put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 85 /U put
dup 86 /V put
dup 87 /W put
dup 88 /X put
dup 91 /bracketleft put
dup 93 /bracketright put
dup 96 /quoteleft put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 106 /j put
dup 107 /k put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 113 /q put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 120 /x put
dup 121 /y put
dup 122 /z put
readonly def
/FontBBox{-251 -250 1009 969}readonly def
/UniqueID 5000793 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou\c3R*R?쨤ȯ@ gSr RIzE_EMv,X!%6]ަ_3+_hJإ0o'z 9K$|tV\)Z!
j#ZŚz1UA~
"p?{u@]A}s
ijB)~Ob{z;O9mT[Ğ^dUl$Wh:?Ƃ(r6;Bt6cFCr$/;!,KqLeWuG h7IQ[u20uZ8*#qP|̖I̓pe}#YۇW{
Hs(}CEc;[e/SmV&
i2ǡmc\0kC'sp)X0@$2jOGG9%fLJD@m2b5\cdy!iz+lxa+2S@uIY5F>qgROEowK*;/sDGǡx=>J ujLDfdžk4ؐ.
vî|1wm%QiwXDN}}x|E.gK{T >k&mxo.<n&lQ>I,
7
LU/GGSL@PEdԑϟ5::""l5ȸM-/5p7Z՘B8]4t/ī+Ic/xe\%	SqP=]IC!#ԽE~!|kZ`f<槷$TtPxCknKAAYsrƨF0,tu|bk"]fL`*ðydN)Ql1$?XN
E>cfV=[miGU>LfqcD	t.2'-;p[MR+S"#bp`1i0zCD]	~+KX>`o9N(V%U0H?Ӫ~'XPl+Mkгp(I-hq.=fKr涍.y<,=l20FndہQ6_@sPNц&-&Dr!ۀOp]!&|h]DD_GJIK'.zH*$Q]"A	et`[vv3&g}`5dz+u
YcvpojL`|U}|c=%6~6XSLLg.
(Tv&nv~Nv}(íVOlnJ'^=Or9nffǍŠuyAܼsu.[;b<4B_yn7QhŏU)*eY,G0==֚/	~gq9N
BZ954)I3Ob|M7X(x#@l`g4v:7M`‚kyN)qơFj5CM	λ۾*VY+hL^6Nϋ΃׈v*
[PU_R( ^u&@Ψ-K*4AHVu-}8Wgm1vki܌TSQO6Tdny$J	SrSFVJXDضwJ}j'bv'Ӭ,u/Ь銓dʝG$_TW@+
{l
me0VE(xҙL}}4E#DGkch"Iu%hfpO#CmT`7пǸEvM
3_tp|
Eϯ
2ǮwK24țܠDOY^O͵Wn\E!UNDDRS'za/~oi0BGqr}8{Idg'ʿNrY3L>WZ[c[[M7c<2}Zry,5?zStD~MJ͎v
~:qOXmɢ0:+ݍo1[aׁLѵE!*k>τcUσ@z:ơRIa
Eaa;B1XMͤ#㈀Oa)?x܆\gV)IH	+9Saث&30~Ou\iHo'|_H;XĬ')~ֲ'*Jbjt47fx
	_˛ ;f0mW#q&htgSc!$S(4ܞ 0jxW9)_ns~~bMpr+ݻ.01	&L_1x";pxd7's0Ėت%93a؂
3n4f}Vp.Іdv@MdUj.#*.ܿ>',q>YACM5X>ѹbd~AP_dA jyNaIkJd@dyGXCG~x&tpkh?BۡyQ41j.[2;+tOlw!!B0!M4o[<Wk>IG;lFZT9tWQDU7YG>m!#1Lpݩ_Lt6g҄`+{h1!/pE*8!$~E
^"'Wb5]niyXk"Epr.e=ֲQb9<|F8jғ8F?}
;`v3{wc,UC+H^4橖
DswܰʓH4~lwTCކOg{Zj'z	GSh˜A=yR3h]"A#bk0+[Xsb5`UmU1w$OQg`# m2pZ, L{~abGP~[T22ˆjGaMU|
0C#N&{gqMOkߜ}]vڟp>`O\""Wh'#qD`0:v%b|:Rh2,RĸCjCycuE[5ƣˊp1 %yu@]P"{	ǘdI-g;'/VuX3&8xzoQD{~6*Rn͍t3Jg|قܱV(˲ҧ+8cOkEP#tR$d:ؿBC=ga/Mj&׳:,sBȎ=[T_ŒK?uĬ\A<-dų?,m_`=d5G߲y4؞i1vvض"yր}|{RJ&|-'a.	Jή!5K!`T3{	tMjD&aWbґz
m '_vfjx׏{
ڛO\F S]9ܟ/SDnj}mKêg@ݡG
v&>]-AorN7RR:z#8max%iң27R!+2e
tbZ:lW}
:!\
$%g9(-05U>9*yAڅtm$!b: 9瑏=Zp-SPU*EmvoxӸJ	uG
WGMyD>nT-glO*ꄐjq
b5)7qG"hO`>kRe
nΟB@fc
>ٴz~	^q.L)gg}&*qb7+D#5޵IYZؖHf&6109kE-r<<Y}U$w%{D=h21q3ip?u9LX!R%ԗk#<%%[K:N9%EGg淴7pY~㇄Q9B!TKtJ6h!	E3Ї)Pi!hD0BjVi]
/:Tn$iAE	G~?h["[_T"YǶȄK:)^Kzs_C_W]ym^s˱(B7ؖ_.1A9&
]=G@Iȿ97^yKSjRQE(/MزfD&[8gG:ǎv%'$]PHC}O&AWtߕ4%z:+?e4)1ʧ:6dNz]
`Fmz#9L^^%NH!j阕F@TO҄uUDY;^	)>R?pL$>rT,t1w$H[^`
/cxM{P}Z"OO
u}dzal,zّzp
9KYęh'yPFԕDv	^1_y6iY؉^J9bJ$ts͏!KBĵNqy[2(މ(dt8%)[̦ݺm0j;T壢Sۼ22"IK0V=`uө:ʳ.=Ih@줾Pzi1XLIC	rSaI?Xzh.}-s|6!rêW"L3펌d5[ѽ3o;g.d̷`Ƕ ^r"Y!~S7
ؗeh(
jq%⩱}FoL?w!4d/r?M֡=Ms_e=B0߬4^nQsTҊ#=siƆ,A7DHLӲ)DƸUMs2{Z]XM+dV/s]i+ʭ 9s/MDs,7\Pdi3+3+G8j
^`ti*WݗF5_W:KH*yl2#
5
Imm8baTt?ϗ̢KkEVs.19G'Bս=Glk\$H/vbFK2oذ&1A	,hʻLnXbm|K3MQPTz,5<=~_U{-ŋk`k	ढ़ݜͼ0C1=,yeH#IZlև'{paAYK_E4Ir[ܢC\%%<7|i 6Tl3>n&WpI-r++)@c!Mi+d&xJ=[>L(;̺HbYL.8y>dgLfmSEEZSNN9ʏw>
)۾*85@I]U|oiǯ4F:i#!O;l|oOy߄cqlY	tάԶ

W\h%aZd/eתLK۳?
BqLZ^Cx/u8cCMSJǰE˴IM?lrM5[gOS:?9sM|9邴Ԡsׄ,EX@x7242liԚ59hΎZʴ,c؆kbNU-s.ͮ~tUR֕fMV¨k_7Ew,h?.+ٸO9Z=,m3z	}7ȍ-kJmK[a9KQ	F	~8) pJN԰@ޫ
:虜lԠ#sA:|W,RquԳ,5R[[l JD7_vehi,wgvX#(d{6:#3SUV=4]@C75ybor\BxE	e`. ́dn8eүcU$1t.EED˕ʂ/hĖ_˘ToN‘i0뼛0/Qkjz&(*2c- &-e/uWKl^0|Yg
"^'ث`4׊
p(tŁf7D|i"mR|0=REhQ4%+sHQ	gƾ
uVz'>iO,z8mBDՂ>O4?Thk3ޞsҪ:I5MqCנ5E%ҝ`_@FZF}_e,o؎g`alf|C=Ԯ~WD8!ĮʤG)M(]ܸD2Ad}[p8ZrJt;o?L
@2p_Hͼ}v\_="WL$|bxijx̹Z339i_#bt'!!Y{EqGOBE

2C-DDL{p_hL
Y!+5211FeGV3q1cD4ڢM3f4б=b0IK݆
X{̓D%KlfqB*EK_b<'z1$	<ջ4?}
` f
 z1R3o{(1r]ojۚ>7G[yXˇݮ(7ѥDbQM[V~}}d<<9MN*G4+.#MeqTD
WɃ(fmp5%auTJZDwyPyO
P]	&1+HD9Ы{IC.<֔ck${#sS>7+	6ΩJ{Mb+{Yant~IpW
뀡] SN?wT"k>H,/RQ3%XEKr{{!ƱPoƈtO52F3ᏣNksB>\BUO9Z;=[_5L9p])<cUV6.#-I8_QP-2oBB^wBrV
uu˽f<6gcP8hb[KRKoD,)+<;=	X?i9ܞ1IZuLWn(5Al_ؗOϿXtvjЙ=hn*HęgIn}toF4BhPcvMI{ZZFRAȚ($dNW[5t|~xLݠW"P
:Ֆp/Sv@U^k3׳PPaC$1IڋMC4r!1dPsFaϛ
`[cX	oĐ̧XXM/򽳚AiMs!hW2(L:tSJ_.)[]JWCf#DG=++.wx`JE%i[[=eDtK0^熄oo㭺0kkeTL&*Mn:IBA^P^D}RYpB}PDz3,c/7(Icc;PZ6R~0b@fK;))/[ʊ}rۍq"*WHbmh/tbi"a[T얨Ԥzt@ 3
Sp4
)e9Ͻ%b8Mw[+UY|YgpCx5Yʐe0PNto`Ab?&	s{™xZO*G~]DR(w$erᕐU6!xlg~~B8?v$?Ħbh|ٙ{@ #;mTMIZ1/v.OG*+&1i@>۾tQ#1uO"W&.,G+%I9ݧeg[E.
u쟚Ij)NV$T6c2<Udbl%:%?)/(ɭۣ<$}bRkge9amFgH|>:zPzq4}y5:(Z$ڂZo݊=ͪ(JZ+I)ް*Z!m	{`mlh33S|5֫rJB=Kz%;W_^9UcQM.i%I].py
fS;<'qEw"b!.A'v$J4~1boq0맇8!;zE~1Q-HEb޽MŪ=="{`@b:q3
?JY"Q70#1Tj(=(ȜaR	,dA2з=Y% L7׼ꐱ.>:,V=1k={PFcD<?:Dy]|g9hC'%ꀫw;8j=V
2CLkY.BnU@R<	2S6WXN?!ח>@Wu,mXCݣƽa,ʞq>82s j@qS|/l2,f|/Zc'"Q`¸^iŞQyf
bVMkfb^ҾIaBxS.J
$Ւfy)#Dѿ&rSHW0ZnJL\(%dWU2!1!7||٫#g%y;o#sVyHP՝LT!%$p]?D!?D1yy	T
)
z3Oyw,) OF6&x>#ޙ!--tNpe~ӊi	i*!KnI;FN߄0W#j7u^l9yjvlf=J=DŽ
cY/y͡wNPC}pzI
r[ljw]ēe?QXRVAMV#z
YxP$'Ix(UQ[$wZնP0yu8:ۚ|3'I+ZzJdƣ#ޝ|t%&eh)g>-ӆMZJhV5`2UH٬9&M?aYm/H	*ON1ÎЭld0iS"cVj8
lJ&H;jCD:Z!	q:)8v89-k/˴JEniǞ^wW55_"Z;B_cW:nZ~We{y[VPxQ
ME
[V~	/3;}Zdn֗^E
[ob3't$*yUOess܏ĀoH,IT!IyLN8*5n.x{{xŧImDma`Թj,^c֦
ڶARjΛv:HtE_2m(\z1,bV߆,C/vҼ~Kr$]<=ɴ΀k7'*C=*Z]74}< .V53gluol."W$Pcxc	L{PZ!#{(~*/@GM6#Nޘix-}WxWMS^][5)hu58m2V,?{^A0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
361 0 obj
17340
endobj
362 0 obj
1994
endobj
363 0 obj
14814
endobj
364 0 obj
532
endobj
365 0 obj
/MEFEXO+CMR10
endobj
366 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 365 0 R
/ItalicAngle 0
/StemV 69
/XHeight 431
/FontBBox [ -251 -250 1009 969 ]
/Flags 4
/CharSet (/ff/fi/fl/ffi/quoteright/parenleft/parenright/plus/comma/hyphen/period/slash/zero/one/two/three/four/five/six/seven/eight/nine/colon/semicolon/question/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/bracketleft/bracketright/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z)
/FontFile 360 0 R
>> endobj
13 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 367 0 R
/BaseFont 373 0 R
/FontDescriptor 374 0 R
>> endobj
367 0 obj
[ 676 938 875 787 750 880 813 875 813 875 813 656 625 625 938 938 313 344 563 563 563 563 563 850 500 574 813 875 563 1019 1144 875 313 343 581 938 563 938 875 313 438 438 563 875 313 375 313 563 563 563 563 563 563 563 563 563 563 563 313 313 343 875 531 531 875 850 800 813 862 738 707 884 880 419 581 881 676 1067 880 845 769 845 839 625 782 865 850 1162 850 850 688 313 581 313 563 313 313 547 625 500 625 513 344 563 625 313 344 594 313 938 625 563 625 594 459 444 438 625 594 813 594 594 500 563 1125 563 563 563 ]
endobj
368 0 obj <<
/Length 369 0 R
/Length1 370 0 R
/Length2 371 0 R
/Length3 372 0 R
>>
stream
%!PS-AdobeFont-1.1: CMBX12 1.0
%%CreationDate: 1991 Aug 20 16:34:54
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMBX12) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Bold) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /UJXHDC+CMBX12 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 11 /ff put
dup 46 /period put
dup 47 /slash put
dup 49 /one put
dup 50 /two put
dup 51 /three put
dup 52 /four put
dup 53 /five put
dup 54 /six put
dup 55 /seven put
dup 65 /A put
dup 66 /B put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 70 /F put
dup 71 /G put
dup 72 /H put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 79 /O put
dup 80 /P put
dup 82 /R put
dup 83 /S put
dup 84 /T put
dup 85 /U put
dup 86 /V put
dup 88 /X put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 100 /d put
dup 101 /e put
dup 102 /f put
dup 103 /g put
dup 104 /h put
dup 105 /i put
dup 106 /j put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 113 /q put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 119 /w put
dup 120 /x put
dup 121 /y put
readonly def
/FontBBox{-53 -251 1139 750}readonly def
/UniqueID 5000769 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_dV`Ky
Z]uMYb[1[l',t\pڮԞZO4GJ7
i!U&Ϸݢh`ZṆhKGz; #1&()$J3KُօEsjFf"P$-I޵˕B
6=hqDV<`	EkENrraƌJG	~L{6IE6U'y
0gK>&)o>2\U]$XW-1f@'B1mW=L%5t.O-]NCT4>&wvNXŅCf
עr1fׁVCȖ~q0Xf^^$ӷ%G7dȱ\lFc0]g<銷_&W{>}N|ӷ
054H4ܞlG>T_cќ6Y1 nUr-u$yfOσ4nAyغINz+:΃΃Џ}=|z`v+D{.;FWLEc6o, e&ۺH%&e+ o='a9ܮ;-sg}l3K?SEhAr;}5٠땷7_KߔZn+Kw$ZdvԬ|d-ruv7RZ.߳mP#5%cH.ӓ˘~I$U
&P_g)"уj
"n3@:p5?s4clc2-%C!C8@&p_zuPHV8v=O荿>n
u$out
`:X-mDb,-rI*F"C@Q	4;wC7{mLCvfb.G$-.U9Uzky/uJyHP#7P.?tQqM=_x\u,{KSjg<~+bfWA/g:
A[4`{~]LzSvfZgD/K{AW+߶ꊆ3[]])a9eTRxƝЃ|=PtQ@L5*$=gI/iʺ!kqL3Sp{1IA1ҧG%3"o'jLXN(Y_&/Yɚ+	JQL	6mvmAYc]ay`zRfVfAR#L@Ĺ)6{ܳ𤯾)JD6mR;/Z|ۣQ=",]fqEd0=%'lǫɕx	ZddLfF@;D}f17Gm"A5]^e92W/~cQ`Hb
:‰K4i%6
.k.NkWv,7ɯ\φoX#QGԗjbFg!
*8?ô/?$I[bE|sW49QI){
uaM-çlɹ|TAA@K^=xs
^g̿ⶠ3I;~E/K#,/cN_GȮ(S
fיDA.u8]y\
yifsQuZ,s\+#/ra1W^kOu`@Bc=IwY@W/Wr'>#|/)o ͒
vspKj8.Nm&ʢf;&a,".[uXc=}#x,;w:2MѦTGQ3|W
;A0G`{qT-ɨon
7s@7ׄ\	"2"hinhO&n˂OdHXS^\>y.=vc=L&P&Whe!6^}eA_7r}<)S
58`-TF`r~	~C
\g5dُ`)J>Ճ-[y
Ϲ>h SmQBilL:.<.LA5YaK~3ǎ6^P?rCHbG.SζЖfI_zsgS$P	OZZGH@GxP*sf?xMa)	~N}粯_Ȓ._MAF.d/+M?أrzZ`JgE0lZxroFo<`
?5_q6dJ%I$+ښewQJ4Syie[Ư8
w
%r]xǰOOJc`-LQ8quj-ߡ^"8*
u5R2	,׆u}fx5%(k4Z)kCٜ9-'oSrw~@6(֣!I2'x/Xp[ZF	@-|tDq	d=gBb9Of
0Jl*NVfk.̑>ph#NXF2QteSQ=׌5eRս@s]1; ԽLIO}^Nͮ2&騇˯w`ڊ9IM'4Ysm@Jwly̚9?W=_Э}M0xyA
uׂ2(
U:}2K9If;GErͩnd0L?AK=!k301I^&%].Ew+7%WI݉wƄ^d7@c&%>:au|{z+TH2?m(y&^PgqCG&&AE>S-Pv1)
6TS'Wj5_\) )ZJ舷gt6@g|&m[[/s^=zXwzp4*Nj㐭*ݔ햓nǴ"8]"lǰx3e<;+TvЃ~0.f|.
.
]xZ*q_ٽWG/li"PБjhͰ G_gjڳ6afѝL2UiW#2lnzcɽAg&XQD’܅B~Td3\k[\|6Blu
M5P3c^_awgb0֣m(?L96ִзeDwxX^x(kZǖ{E&tbMS\DƬ|yW"	uS$8R!lS!7}3syOhuOWp)j5}x~Ffh NQ4 =Bd)j}&fN3JM>%N°MKx݅49z$x?SpsBB"D-H^m2}׏1o9?%.\TX@(-}A^E&..۶MbV6Grga:dOQ"Df!ϕQ1cv7J7Pۙř
LݎM';e'-:j(/OU4b)@!Dr#$PÁdf6J/d+o̍Ij5Dn.?mc- umL+03DGos#ļGJteiy쉇J`;9cq~V[>"->3:7m뷙u*3_
ctT\GcUCڮ)v=##MMEO}G'fntQrMӕ-͔U{د{Avl.X
Q4@R:r3F[eqwPkfӶ[D ^+]/QUTLv8i! va*dL0迶H[z.	HPg%9
3zJ`:"9B(޵"QfEГi6
X<DؕR{Kd3QĆmGhf- T|-!8_]>$('#*4;t:1J#&OP9Z)	fk݌xzDK@jvDZlҴ#ʴ%}~I(hFІ^lf/èzU8rZAESXoa-sfY8UW3l#\zFܴL.8p\|[w9[p;yk
fÑeqՉ$9+u"ӧoa=>=H]iO8]
Ls*6T~m헖|~CWu(G_*d6S<*_vU!q'/׍L=+"Xm&g-y6I$!=
>)!`_&N=JUZ\Ua
8`Vdg[TX^[r\/PoD$E"(~ߕ2ȫ+_4޾龨LtJ\+wak?k.IE3ccƾ&xkF<Ɏdq'^zNQGߌV#/g
5Dzz=	r/;m0:.097+<ʮ5](nmί|D|;v-VL[)-s(b*w'mnGzcF	4*@mIzCn\Rip֙KDwYDt;QD
pLol"ȭwNy>}̶F"9tߙGD+1gf1(\gm꽰z>sQB"ooDW*J2څVv('}R*;nHhlDyXC"t
],%͇9~J,RiO}^:CH/J<EBn(ʥ6MIllEpwPScN)
X^)XGl9IHf;pJo;pny=ސ+ؗ$>tOT@EɝXW{;3Z6g^goe#S0s4?H-iyd(Du4iuiQCjw
 ~)>B
萐}w)gGCpcϯ`rۆKqUXw:} Q+'V=w\@4dxIj*ZTVNp	
0!0O[RCP&2%9Ψ檤G1E
mՈMُDX[`϶᢫P?H7r5O{Td\KSwm5"A9th̵āk0e+U˔{Y,TtpM,Lmz2	`u,qZ *2)Uѿ@B6:Ts}{<$=9ͮ2iCFSͥpJZ^?pY48eW`6}Y!SFbB6[".ͯ3_XMwͪGRnێtd_y|OJnd+5J|ިbώC(b\D&3:Lv> FlK*gMq$s;*7P&Q0TCt6ų /xdB7Ծ6Ɖƪ:.0a*Ԫ`jM3ɣp^ibkWm9:zMIk.(	d=Ux/p62sྻPh{W(UB;#>2Upk,RIJ*ŞEzNk[
ب躣@YURؙI5{Y@Fw4"raT+EI~/_d	o	C7rGa^zYFiC@F&62%{!c&-VHd4|6w31'GMj2+6#!9(]B\xpD\Bb&1\SI
|G A@
Kd󅩲
~jQ_8ě\agVGF5}z#OtfSO˂rhIM5Ty[?n^S!@h8 /
"^TX;˯0:!Vۣ2s}
=&HZ!.}ŕ#}gx4#4vQq>5kˬ [,f%xRي~Q*~Wr{7zBAE
G:DJQv˽4 v:⺻٠o'TYPدN`!H>jcr9ukg9?/YOm3
TK׳'8U! qJ,;fGQ>h,ʌҫ=\)Hr UbuZņYF
/+Mm^0*6|^P JUSKUzjmw%./}E*)”uf#<'#.0)6$S
b>?EeLs^HO)P0k|YsaoCy*Q
ep)2]))0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
369 0 obj
11053
endobj
370 0 obj
1538
endobj
371 0 obj
8983
endobj
372 0 obj
532
endobj
373 0 obj
/UJXHDC+CMBX12
endobj
374 0 obj <<
/Ascent 694
/CapHeight 686
/Descent -194
/FontName 373 0 R
/ItalicAngle 0
/StemV 109
/XHeight 444
/FontBBox [ -53 -251 1139 750 ]
/Flags 4
/CharSet (/ff/period/slash/one/two/three/four/five/six/seven/A/B/C/D/E/F/G/H/I/L/M/O/P/R/S/T/U/V/X/a/b/c/d/e/f/g/h/i/j/l/m/n/o/p/q/r/s/t/u/v/w/x/y)
/FontFile 368 0 R
>> endobj
12 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 375 0 R
/BaseFont 381 0 R
/FontDescriptor 382 0 R
>> endobj
375 0 obj
[ 683 903 844 756 728 814 786 844 786 844 786 553 553 319 319 524 302 424 553 553 553 553 553 814 494 916 736 824 636 975 1092 844 319 319 553 903 553 903 844 319 436 436 553 844 319 378 319 553 553 553 553 553 553 553 553 553 553 553 319 319 844 844 844 524 844 814 771 786 829 742 713 851 814 406 567 843 683 989 814 844 742 844 800 611 786 814 814 1106 814 814 669 319 553 319 553 319 319 613 580 591 624 558 536 641 613 302 424 636 513 747 613 636 558 636 602 458 591 613 613 836 613 613 502 553 1106 553 553 553 ]
endobj
376 0 obj <<
/Length 377 0 R
/Length1 378 0 R
/Length2 379 0 R
/Length3 380 0 R
>>
stream
%!PS-AdobeFont-1.1: CMCSC10 1.0
%%CreationDate: 1991 Aug 18 17:46:49
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMCSC10) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /MAVNEL+CMCSC10 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 48 /zero put
dup 50 /two put
dup 56 /eight put
dup 65 /A put
dup 68 /D put
dup 72 /H put
dup 77 /M put
dup 80 /P put
dup 84 /T put
dup 85 /U put
dup 98 /b put
dup 99 /c put
dup 101 /e put
dup 105 /i put
dup 106 /j put
dup 108 /l put
dup 110 /n put
dup 111 /o put
dup 114 /r put
dup 116 /t put
dup 117 /u put
readonly def
/FontBBox{14 -250 1077 750}readonly def
/UniqueID 5000772 def
currentdict end
currentfile eexec
oc;j~EЪ)s̾;.;rTejiK/df5A|{S/
)Sc\^ȟmp+#vL17~kd#
]LeVߐGoo٥\k
9Mՙ=	0)xf
0v7ϱ9àE(O&k{ǛHFſꇼw
R^q&AԛhF8N&{oi(^[olW%'5,.V!0&u%ˎKxZ4pX:;[4+	@c
ߌ
}s$)PͶ'/CզxBCxSƫE\	'MXpͰԁ Cq6 
2T1e|jԲH*}
t.-"k5,h:J.X 4Z@0v)FEʫ@"jKNJrYDdcm!G~,f\HAӮhcc>SK}pkkRX>LfU8dWNb䊌b ?g~8o|R<)C쩔`J(UeIKvreNdβli;|x"F:2:;In<K$bl,
f$riƃW/Y[x:)-uE]-B@UpUڦ^@pceOI$rV#t=~c>)ewK&Hhoԏپ[R0m'ΥSH+J})L%a4`fO'nEEWqǗQjILƱ~,I]i1ې @+y;VeEBb]b4D\纎XK+*rNȹFDomfI9:Ix9O/$x40њ"ΰ[[,vѭ:jc8^;g(PMɸD0n8'xD62e`;ZvAQ1T|{s -K"M+ 맲u}	Up>Znݟ[;^WDUBh6<Ìy(P)c~WO5U lNhX8Fb}4W6@MoMCms(6	:{i@Лk6-$..&68#iElΙ.oyϫ>Pot6ΚMPi)_Ҏa^Df*G!{ oU@ČOxa9ĔQ\VC"#]:,seeTT`O*1f=,~@LN4~,583P}*GPռX4uQGQ#'2#`Xj^0`џ~h=̾4H>e0{ѴK{B6d9,ꪓ1/͌[g!5M}4Lt*)rβAAZ 5,ZK5l9OBǫah41Կs5?Xy
kW0}.`i#0߉pk^JJ(.W*ĘJ;	RʯA#	:ZGD~2g?>	ilMB~<-EP%YR^r3߈ds=aHfyG(w;@&Nv>b;Q;?*3.#Pa,2Oc~.q>nFYHv}g(t#
xc٬/XKe_?9E%MJIvPfYqmQFc\/l|Ӏ
R.1x׫lHY!/[*Z<

X{ï$T68grvuH:Hzs5cbY3.;=Sip-5ª=hyxŪ݉kϺ/u#AR%@Mĕa32
8l;Y0̫un9$nnL #uoD*3{!zSy>Amn?6|?Ӽ~yW6.(IWvsd.Ma<$	
I1IC
E(1s^"6MO5סD(P`}B"/'O$MA01O$ 8Y-e	7xNblK
Mǟ$ֈAXz*%kbUd
2jmpǝƢrp͛V2U>QRb
_l5B%5pUԊ"xoB?݈bz@./@
AT/Bmԑq
ψei08|	f>%Z-wnj=^Sp0
$;S Qpxe/W'P
+袕yar4)O*MYF\y&~UDW&a1:_CA`
ktGrBg~	<x̓&T=,^PQKM,`
/C}8nY^Ot6TGt0Ép?ޮYX_.䧪N9maԶhe7;]
@Y:=+EĈ_ME
gR"B֩CȲ[zJi'`o}/ l9v#/H
c>+L`r첮~.t=`Y@d	Hg ^΄5꠰Tl۠H\h
F/s`66ܣ^5E{CCy~g/rn8sŦ
n6\\,Kd0O=:\U1ξX_r 1_++
05GU%Qdee)i,6>=ݓrŠK}#c*Roh)?S
:
`T-wǮK31FF.J"
 ը|k$kMMC$cxs!bgV~89\|DZT	NjlC9+0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
377 0 obj
5787
endobj
378 0 obj
1061
endobj
379 0 obj
4194
endobj
380 0 obj
532
endobj
381 0 obj
/MAVNEL+CMCSC10
endobj
382 0 obj <<
/Ascent 514
/CapHeight 683
/Descent -144
/FontName 381 0 R
/ItalicAngle 0
/StemV 72
/XHeight 431
/FontBBox [ 14 -250 1077 750 ]
/Flags 4
/CharSet (/zero/two/eight/A/D/H/M/P/T/U/b/c/e/i/j/l/n/o/r/t/u)
/FontFile 376 0 R
>> endobj
6 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 383 0 R
/BaseFont 389 0 R
/FontDescriptor 390 0 R
>> endobj
383 0 obj
[ 612 816 762 680 653 734 707 762 707 762 707 571 544 544 816 816 272 299 490 490 490 490 490 734 435 490 707 762 490 884 993 762 272 272 490 816 490 816 762 272 381 381 490 762 272 326 272 490 490 490 490 490 490 490 490 490 490 490 272 272 272 762 462 462 762 734 693 707 748 666 639 768 734 353 503 761 612 897 734 762 666 762 721 544 707 734 734 1006 734 734 598 272 490 272 490 272 272 490 544 435 544 435 299 490 544 272 299 517 272 816 544 490 544 517 381 386 381 544 517 707 517 517 435 490 979 490 490 490 ]
endobj
384 0 obj <<
/Length 385 0 R
/Length1 386 0 R
/Length2 387 0 R
/Length3 388 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR12 1.0
%%CreationDate: 1991 Aug 20 16:38:05
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR12) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /VEPBNF+CMR12 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 44 /comma put
dup 48 /zero put
dup 50 /two put
dup 65 /A put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 82 /R put
dup 83 /S put
dup 87 /W put
dup 97 /a put
dup 98 /b put
dup 99 /c put
dup 101 /e put
dup 105 /i put
dup 108 /l put
dup 109 /m put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
dup 118 /v put
dup 121 /y put
dup 122 /z put
readonly def
/FontBBox{-34 -251 988 750}readonly def
/UniqueID 5000794 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou\@[6]nhmlhaH+4/?3&n=a6E#|~.ԅˠLw2.槝sNY ڻ.,VnNX3|裠k(QIOs	m;fߖC1}_aIo#0wݙ\P,f	*bG3Z2کP8L3r[vnc_Eh~g9|M)	}YaѕH|1m![AzXpPNCU7Uֲ7ΖTgx_hyW^]W}s_Zfs@dYr ȟsy&vJx)ݱ~Kq
45hL#q:4pP?g|GJSn^i26M	Ęz0.
 v31껰xCj	7}0a`~iEfÎBwS:;9l[	vqo
(>DlqY?kڑo^8KLG7qZC`DYׯ!FT=º`EB|(.?Pǣ]pQhyE3
AVF)?ZrmCVWF{\q2i;]+F)bckk
@sm$L|8‚S'mլMw=7zA֩l1Eo
w
A |ބG4"	(jڭh%5ϫzŠMPn-r?S<Am tu!:%O`L<ĉM$tKDcG|ܭVL)5w5wLݣ*wT?ϖ&~3T^$vW2sЕOAM 
Λ,Jݳz(0IKRR/]&d?U]?@IT/5cb$DC148Ԏ3q<ʁ8&Zi#]{]CZ0^95Nq)5Qm>qJz/Ŏ8?"R\jQHR,\?+U)r;Ho;K
÷6?{ 9XAٶjUX4tFi߭t:go8i^h8fnH%dNc_3pN,DPP@a/_@(औV'/tirZRȆ"FroCƤRP`q6n6ҁ>,ngb\|$uԛY-T?[tZYgH0{Чѱ4/<ʏ1Qr]3ͧXAٶ=Zf)kYXl1t:5eM,LE="93Yƒ7oZۃQ!LXEbU`mc;L Rw.rdu`y3eC7t:*^0@K^p	'H&\/tTS5cGlYÊu.0`5T{2R)In8AԙVf-Ġi8R}*ɬls2M1/tyGNPz1_+!ӫK`|{@jaI
3N:D;q!U8
-RgaoIѺ5-ڑPa6Öpqc
܍@m%Oh1(cd>&JG]9́YZV0o^t-I-b&:TGFe]^>aR_-l0%"

{\M<><}SgDF<do1MEy/p>`ߍ4f8=!NA
n4N|qbDl_>n~O"QLA	/n̡In+𺆾Z
o='qHF4.Wsԋ9l.O泐[o/.Ya/]՚)vkke=1}`"ڻƶ^.g]2IlȚ`vu:$Tt!7&A8(ٕC
'̇gU9Iwx_d,P$s_CB{0Gmɵn.Xz9`(֮G7+#
3^#Vmh`q\K_{-idlB,XiCnȒd<슑<ܣ+'DQ|>_kn4PX=uk6r6MiܕtJ	Aq	z\T[ld<}Ay9Pخ&kDp_pWCgО.yFĭo!dG^@Jk!Ag)uygO:aǪuR.yB]	|;pUzOl~0dqŭ~I>ީഒWp[e'MСB}Gwa^H)䙦~c%9((}p'k5T^K}2{>%SS^Ώ.fHƛ>WDL:QgC.[7JEh9B*FQ=qQ_H)U,+d~Lv )|lNn}+ѮSC~*JV -hs]A@D 
%/MDg{}ZK⒲gBrPe?M9GVգayʀٰ7
@^d3m
~7o._a_>]WU6+wmofMfmko1oc6@W($u㗙s~"
,+sbl2lk;9p'HemKWͦjNw*eDNrP151S&],lG8NICjPH.pY\X$WYƈ0#vAR$WfTݺ90m"e[sr*M@6"c`ڕf08Pj%X"UIr~*v@ʇbeD`KFϮ]$s̈́qD^[}z{X裘nxeQǿ({Wިco5amec$(}@doʂF0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
385 0 obj
6945
endobj
386 0 obj
1144
endobj
387 0 obj
5269
endobj
388 0 obj
532
endobj
389 0 obj
/VEPBNF+CMR12
endobj
390 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 389 0 R
/ItalicAngle 0
/StemV 65
/XHeight 431
/FontBBox [ -34 -251 988 750 ]
/Flags 4
/CharSet (/comma/zero/two/A/I/L/M/R/S/W/a/b/c/e/i/l/m/n/o/p/r/s/t/u/v/y/z)
/FontFile 384 0 R
>> endobj
5 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 391 0 R
/BaseFont 397 0 R
/FontDescriptor 398 0 R
>> endobj
391 0 obj
[ 576 772 720 641 615 693 668 720 668 720 668 525 499 499 749 749 250 276 459 459 459 459 459 693 406 459 668 720 459 837 942 720 250 250 459 772 459 772 720 250 354 354 459 720 250 302 250 459 459 459 459 459 459 459 459 459 459 459 250 250 250 720 433 433 720 693 654 668 707 628 602 726 693 328 471 719 576 850 693 720 628 720 680 511 668 693 693 955 693 693 563 250 459 250 459 250 250 459 511 406 511 406 276 459 511 250 276 485 250 772 511 459 511 485 354 359 354 511 485 668 485 485 406 459 917 459 459 459 ]
endobj
392 0 obj <<
/Length 393 0 R
/Length1 394 0 R
/Length2 395 0 R
/Length3 396 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR17 1.0
%%CreationDate: 1991 Aug 20 16:38:24
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR17) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /MWMKCG+CMR17 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 45 /hyphen put
dup 67 /C put
dup 68 /D put
dup 69 /E put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 79 /O put
dup 82 /R put
dup 85 /U put
dup 97 /a put
dup 99 /c put
dup 101 /e put
dup 102 /f put
dup 104 /h put
dup 110 /n put
dup 111 /o put
dup 112 /p put
dup 114 /r put
dup 116 /t put
readonly def
/FontBBox{-33 -250 945 749}readonly def
/UniqueID 5000795 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_^
2nΗ%)[yi2:(o Gu^~kτ>(O/߄ۤXNߵ(ӸaXœIli-i{.%Õ`
vEa!n]8rCzi.;a.|&Lу׊@a,
|/"UZ%F	7?@^7>at%Tcq{K9a%-dSKKV$m3+8&t}2oM#
*w6`*s:82hbwC$o&I$}&3Ͻ3i	
b3?
K{\7j}8fnd
Zt4~d. (w;ZdLBarεR['`a_Btl27[rLPYm
力HI~xܧsbU=h2AL;ܢhoNfj7j8$P3=AOu#dW3哐^y853 ʗMqW;ç.PA.ƒͫ-L}[HGR\^<&JCPϚ֯x	:{Ϛ!dK+px65$WKud\8l\,oX: 2іB%#1.D4A!Į|vId/e1Gߏ)7
{u4*6yj7·߾Ǒ{=@77
Cur9W'.)CˁNTۀvn$I:Z:#|C+	o '2rZ"B|dCc^_IX>W?i"!?cՈ @V[	'2Y9jIMJzmpOE^]zSyԵuKm`JrP%C?bBtRoi3OP#'4m5wCNۛR*Z0}{򒐰6Bg-31-c'DzCj!Iuн3E_`y<㯬JⰟĂJz'q[W{.AӮZuAZs^ Iw臸P~A;;z̓TZV.`pE>]qSlvk7C)kn*g$i$pOlT^NSy[U¥n/׌Br%olhƻɐ_{eP"[q퉴ȵ=
[3 w%ܢ!Ɏ1>P!FEԜvF$Y50^1]afr/nՎu߈}{ FJxBs9m>?sx9sز//\B)]pyϷ"IKهjs
Nqk 
RFB&4{.TTG~WpW3
M9e/s9@:b
0xn+tX4m+9ڈ{A/U ף	
Pռ~^TmŠWMN-kt_zb<^)K:Z:8>=CYoZL 
;Kq tŝgr?g`H4_}["PgH7X}Э@wyrh[>lTdkZ6<Ֆþ1^4}TJ:l#=Bt"Dd(X6@ֿ[ݼMkh4YON:+Ddu&d.R{kO*/mzLˆjj]|jqEmgȇٻoL)+}ԙV(5bzİ^<,LD^֠tUL5$^̻m~"PNz!"Oxq==yA0,qv)
PAQյl'nT\;"1; VdvHsU-cwU\	PEc6qؑ=AP )>YTdt	e<^bܩbKr3ew|^cx}%O?7]RBA{Þn a(CJlHT`^dg׼ij5v]&VU
,
V)rXkpZg8F̗qp~ 
cQ_de<'Ca^v3QPTݵ^ R0sr+95q^=1H*8]A/'XmAkQO'*&6r}(U&ټpLSyR~q%MDWK%E2Q$Ad $ӣef#uqHQ@ك>Eύ{aV.g]
Ey|k|	,'Lڔ:G&#βFƿ(eIp@.FW/W($!UTP{zc%I9encdmpLi~_-*3
bo
5);_d;<|&
`dߐGLƁl{N)5ܷb̕C{Cn	\R_lsBsyˣ\Ů1ApYI
N`/g,3fU95Wd7K#lb	)
tِmP2m|3@
(n~%`q[@6s:9'I/<\G|eh0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
393 0 obj
5438
endobj
394 0 obj
1036
endobj
395 0 obj
3870
endobj
396 0 obj
532
endobj
397 0 obj
/MWMKCG+CMR17
endobj
398 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -195
/FontName 397 0 R
/ItalicAngle 0
/StemV 53
/XHeight 431
/FontBBox [ -33 -250 945 749 ]
/Flags 4
/CharSet (/hyphen/C/D/E/I/L/M/O/R/U/a/c/e/f/h/n/o/p/r/t)
/FontFile 392 0 R
>> endobj
7 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [2 0 R 9 0 R 20 0 R 24 0 R 28 0 R 32 0 R]
>> endobj
40 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [37 0 R 42 0 R 49 0 R 53 0 R 57 0 R 61 0 R]
>> endobj
69 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [65 0 R 71 0 R 75 0 R 79 0 R 83 0 R 87 0 R]
>> endobj
94 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [91 0 R 96 0 R 100 0 R 104 0 R 109 0 R 114 0 R]
>> endobj
124 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [120 0 R 126 0 R 132 0 R 136 0 R 140 0 R 144 0 R]
>> endobj
152 0 obj <<
/Type /Pages
/Count 6
/Parent 399 0 R
/Kids [149 0 R 157 0 R 161 0 R 165 0 R 169 0 R 173 0 R]
>> endobj
180 0 obj <<
/Type /Pages
/Count 6
/Parent 400 0 R
/Kids [177 0 R 182 0 R 186 0 R 190 0 R 194 0 R 198 0 R]
>> endobj
205 0 obj <<
/Type /Pages
/Count 6
/Parent 400 0 R
/Kids [202 0 R 207 0 R 211 0 R 215 0 R 219 0 R 223 0 R]
>> endobj
230 0 obj <<
/Type /Pages
/Count 1
/Parent 400 0 R
/Kids [227 0 R]
>> endobj
399 0 obj <<
/Type /Pages
/Count 36
/Parent 401 0 R
/Kids [7 0 R 40 0 R 69 0 R 94 0 R 124 0 R 152 0 R]
>> endobj
400 0 obj <<
/Type /Pages
/Count 13
/Parent 401 0 R
/Kids [180 0 R 205 0 R 230 0 R]
>> endobj
401 0 obj <<
/Type /Pages
/Count 49
/Kids [399 0 R 400 0 R]
>> endobj
402 0 obj <<
/Type /Catalog
/Pages 401 0 R
>> endobj
403 0 obj <<
/Creator (TeX)
/Producer (pdfTeX-0.13d)
/CreationDate (D:20000502022000)
>> endobj
xref
0 404
0000000000 65535 f 
0000000418 00000 n 
0000000306 00000 n 
0000000009 00000 n 
0000000287 00000 n 
0000277214 00000 n 
0000269123 00000 n 
0000283779 00000 n 
0000001925 00000 n 
0000001812 00000 n 
0000000497 00000 n 
0000001791 00000 n 
0000262197 00000 n 
0000249916 00000 n 
0000231200 00000 n 
0000218377 00000 n 
0000202433 00000 n 
0000186891 00000 n 
0000181273 00000 n 
0000003372 00000 n 
0000003257 00000 n 
0000002066 00000 n 
0000003236 00000 n 
0000004594 00000 n 
0000004479 00000 n 
0000003502 00000 n 
0000004459 00000 n 
0000006714 00000 n 
0000006599 00000 n 
0000004676 00000 n 
0000006578 00000 n 
0000007395 00000 n 
0000007280 00000 n 
0000006808 00000 n 
0000007260 00000 n 
0000172059 00000 n 
0000009424 00000 n 
0000009308 00000 n 
0000007477 00000 n 
0000009287 00000 n 
0000283886 00000 n 
0000012392 00000 n 
0000012276 00000 n 
0000009518 00000 n 
0000012255 00000 n 
0000167980 00000 n 
0000164064 00000 n 
0000152695 00000 n 
0000015497 00000 n 
0000015381 00000 n 
0000012534 00000 n 
0000015360 00000 n 
0000018474 00000 n 
0000018358 00000 n 
0000015615 00000 n 
0000018337 00000 n 
0000021525 00000 n 
0000021409 00000 n 
0000018616 00000 n 
0000021388 00000 n 
0000024314 00000 n 
0000024198 00000 n 
0000021667 00000 n 
0000024177 00000 n 
0000026875 00000 n 
0000026759 00000 n 
0000024408 00000 n 
0000026738 00000 n 
0000149156 00000 n 
0000283996 00000 n 
0000028914 00000 n 
0000028798 00000 n 
0000026993 00000 n 
0000028777 00000 n 
0000032185 00000 n 
0000032069 00000 n 
0000029008 00000 n 
0000032048 00000 n 
0000035044 00000 n 
0000034928 00000 n 
0000032315 00000 n 
0000034907 00000 n 
0000038066 00000 n 
0000037950 00000 n 
0000035222 00000 n 
0000037929 00000 n 
0000040363 00000 n 
0000040247 00000 n 
0000038208 00000 n 
0000040226 00000 n 
0000043403 00000 n 
0000043287 00000 n 
0000040505 00000 n 
0000043266 00000 n 
0000284106 00000 n 
0000045444 00000 n 
0000045328 00000 n 
0000043521 00000 n 
0000045307 00000 n 
0000047969 00000 n 
0000047851 00000 n 
0000045562 00000 n 
0000047829 00000 n 
0000050459 00000 n 
0000050340 00000 n 
0000048087 00000 n 
0000050318 00000 n 
0000145417 00000 n 
0000052447 00000 n 
0000052328 00000 n 
0000050615 00000 n 
0000052306 00000 n 
0000140211 00000 n 
0000055579 00000 n 
0000055460 00000 n 
0000052567 00000 n 
0000055438 00000 n 
0000136499 00000 n 
0000131860 00000 n 
0000057695 00000 n 
0000057575 00000 n 
0000055761 00000 n 
0000057553 00000 n 
0000125961 00000 n 
0000284220 00000 n 
0000060799 00000 n 
0000060679 00000 n 
0000057865 00000 n 
0000060657 00000 n 
0000117507 00000 n 
0000114511 00000 n 
0000063036 00000 n 
0000062916 00000 n 
0000060980 00000 n 
0000062894 00000 n 
0000065988 00000 n 
0000065868 00000 n 
0000063143 00000 n 
0000065846 00000 n 
0000067054 00000 n 
0000066934 00000 n 
0000066107 00000 n 
0000066913 00000 n 
0000068824 00000 n 
0000068704 00000 n 
0000067137 00000 n 
0000068682 00000 n 
0000071164 00000 n 
0000080774 00000 n 
0000071044 00000 n 
0000068944 00000 n 
0000071022 00000 n 
0000284337 00000 n 
0000080697 00000 n 
0000071391 00000 n 
0000071411 00000 n 
0000083552 00000 n 
0000083432 00000 n 
0000080966 00000 n 
0000083410 00000 n 
0000086508 00000 n 
0000086388 00000 n 
0000083671 00000 n 
0000086366 00000 n 
0000089208 00000 n 
0000089088 00000 n 
0000086627 00000 n 
0000089066 00000 n 
0000091874 00000 n 
0000091754 00000 n 
0000089364 00000 n 
0000091732 00000 n 
0000094657 00000 n 
0000094537 00000 n 
0000092005 00000 n 
0000094515 00000 n 
0000095389 00000 n 
0000095269 00000 n 
0000094812 00000 n 
0000095248 00000 n 
0000284454 00000 n 
0000097412 00000 n 
0000097292 00000 n 
0000095472 00000 n 
0000097270 00000 n 
0000099708 00000 n 
0000099588 00000 n 
0000097519 00000 n 
0000099566 00000 n 
0000101947 00000 n 
0000101827 00000 n 
0000099839 00000 n 
0000101805 00000 n 
0000104311 00000 n 
0000104191 00000 n 
0000102103 00000 n 
0000104169 00000 n 
0000107126 00000 n 
0000107006 00000 n 
0000104418 00000 n 
0000106984 00000 n 
0000108058 00000 n 
0000107938 00000 n 
0000107245 00000 n 
0000107917 00000 n 
0000284571 00000 n 
0000108432 00000 n 
0000108312 00000 n 
0000108153 00000 n 
0000108292 00000 n 
0000109607 00000 n 
0000109487 00000 n 
0000108503 00000 n 
0000109466 00000 n 
0000110811 00000 n 
0000110691 00000 n 
0000109738 00000 n 
0000110670 00000 n 
0000111944 00000 n 
0000111824 00000 n 
0000110918 00000 n 
0000111803 00000 n 
0000113417 00000 n 
0000113297 00000 n 
0000112051 00000 n 
0000113275 00000 n 
0000114393 00000 n 
0000114273 00000 n 
0000113536 00000 n 
0000114252 00000 n 
0000284688 00000 n 
0000114647 00000 n 
0000115192 00000 n 
0000117195 00000 n 
0000117217 00000 n 
0000117238 00000 n 
0000117259 00000 n 
0000117280 00000 n 
0000117311 00000 n 
0000117643 00000 n 
0000118176 00000 n 
0000125556 00000 n 
0000125578 00000 n 
0000125600 00000 n 
0000125622 00000 n 
0000125643 00000 n 
0000125674 00000 n 
0000126097 00000 n 
0000126631 00000 n 
0000131519 00000 n 
0000131541 00000 n 
0000131562 00000 n 
0000131584 00000 n 
0000131605 00000 n 
0000131637 00000 n 
0000131996 00000 n 
0000132529 00000 n 
0000136175 00000 n 
0000136197 00000 n 
0000136218 00000 n 
0000136240 00000 n 
0000136261 00000 n 
0000136293 00000 n 
0000136635 00000 n 
0000137179 00000 n 
0000139861 00000 n 
0000139883 00000 n 
0000139904 00000 n 
0000139926 00000 n 
0000139947 00000 n 
0000139979 00000 n 
0000140347 00000 n 
0000140880 00000 n 
0000145086 00000 n 
0000145108 00000 n 
0000145129 00000 n 
0000145151 00000 n 
0000145172 00000 n 
0000145204 00000 n 
0000145553 00000 n 
0000146094 00000 n 
0000148838 00000 n 
0000148860 00000 n 
0000148881 00000 n 
0000148903 00000 n 
0000148924 00000 n 
0000148955 00000 n 
0000149291 00000 n 
0000149827 00000 n 
0000152383 00000 n 
0000152405 00000 n 
0000152426 00000 n 
0000152448 00000 n 
0000152469 00000 n 
0000152500 00000 n 
0000152830 00000 n 
0000153366 00000 n 
0000163620 00000 n 
0000163643 00000 n 
0000163665 00000 n 
0000163687 00000 n 
0000163708 00000 n 
0000163738 00000 n 
0000164199 00000 n 
0000164743 00000 n 
0000167659 00000 n 
0000167681 00000 n 
0000167702 00000 n 
0000167724 00000 n 
0000167745 00000 n 
0000167775 00000 n 
0000168115 00000 n 
0000168651 00000 n 
0000171736 00000 n 
0000171758 00000 n 
0000171779 00000 n 
0000171801 00000 n 
0000171822 00000 n 
0000171852 00000 n 
0000172194 00000 n 
0000172730 00000 n 
0000180881 00000 n 
0000180903 00000 n 
0000180925 00000 n 
0000180947 00000 n 
0000180968 00000 n 
0000181000 00000 n 
0000181408 00000 n 
0000181947 00000 n 
0000186533 00000 n 
0000186555 00000 n 
0000186576 00000 n 
0000186598 00000 n 
0000186619 00000 n 
0000186651 00000 n 
0000187026 00000 n 
0000187560 00000 n 
0000201926 00000 n 
0000201949 00000 n 
0000201971 00000 n 
0000201994 00000 n 
0000202015 00000 n 
0000202047 00000 n 
0000202568 00000 n 
0000203101 00000 n 
0000217792 00000 n 
0000217815 00000 n 
0000217837 00000 n 
0000217860 00000 n 
0000217881 00000 n 
0000217913 00000 n 
0000218512 00000 n 
0000219050 00000 n 
0000230765 00000 n 
0000230788 00000 n 
0000230810 00000 n 
0000230832 00000 n 
0000230853 00000 n 
0000230885 00000 n 
0000231335 00000 n 
0000231871 00000 n 
0000249318 00000 n 
0000249341 00000 n 
0000249363 00000 n 
0000249386 00000 n 
0000249407 00000 n 
0000249438 00000 n 
0000250051 00000 n 
0000250589 00000 n 
0000261749 00000 n 
0000261772 00000 n 
0000261794 00000 n 
0000261816 00000 n 
0000261837 00000 n 
0000261869 00000 n 
0000262332 00000 n 
0000262868 00000 n 
0000268762 00000 n 
0000268784 00000 n 
0000268806 00000 n 
0000268828 00000 n 
0000268849 00000 n 
0000268882 00000 n 
0000269257 00000 n 
0000269791 00000 n 
0000276843 00000 n 
0000276865 00000 n 
0000276887 00000 n 
0000276909 00000 n 
0000276930 00000 n 
0000276961 00000 n 
0000277348 00000 n 
0000277881 00000 n 
0000283426 00000 n 
0000283448 00000 n 
0000283470 00000 n 
0000283492 00000 n 
0000283513 00000 n 
0000283544 00000 n 
0000284765 00000 n 
0000284878 00000 n 
0000284972 00000 n 
0000285042 00000 n 
0000285095 00000 n 
trailer
<<
/Size 404
/Root 402 0 R
/Info 403 0 R
>>
startxref
285191
%%EOF
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mml_ir.red0000644000175000017500000010131611526203062023743 0ustar  giovannigiovanni%  Description: This module contains both functions for passing MathML to the Intermediate
%               representation and from the intermediate representation to MathML.
%               Both main functions are: mml2ir() and ir2mml().
%
%  Date: 2 May 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  Here start the functions in charge of parsing MathML and printing                   %
%  it out in REDUCE intermediate representation.       MathML->REDUCE IR        %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% WN global '(f);
% WN changed name of parameter of mml f -> fi

fluid '(constructors!* !*f!*);

% This is the function for reading from a file. It is given the name of a file which contains
% the mathml input. It launches the program by calling mml2ir().

symbolic procedure mml(fi);
begin;
 FILE!*:=t;
 !*f!*:= open(fi, 'input);
 !*f!*:= rds(!*f!*);
 mml2ir();
 close rds !*f!*;
 FILE!*:=nil;
end;

% This function starts the parsing mechanism, which is a recursive descent
% parsing. Begins at the  token.


symbolic procedure mml2ir();
begin scalar res;
 res:=nil;
 mmlatts:=nil;
 space:=int2id(32);
 count:=0;
 ch:=readch();
 temp2:=nil;
 lex();
 if char='(m a t h) then
     res:=mathML()
   else errorML("",2);
 lex();
 if char='(!/ m a t h) then
   terpri()
   else errorML("",19);

 return res;
end;

% The two next functions differ in that one of them parses from the next
% token onwards, and the other one from the actual token onwards.
% It is necessary to have both since some functions end their task one
% token ahead (eg getargs()).

symbolic procedure mathML();
begin scalar a;
 a:=nil;
 lex();
 return sub_math();
end;

symbolic procedure mathML2();
begin scalar a;
 a:=nil;
 return sub_math();
end;

% Parses all tokens which legally follow a  token.
% These tokens have to be constructors.

symbolic procedure sub_math();
begin scalar a, aa;
 a:=nil;

 if char='(i d e n t !/) then return list 'ident;

 % The reason why we perform an individual test to see if we are dealing with a vector tag
 % is because REDUCE changes vector in the list to ~vector when compressing (v e c t o r)
 % and then it doesnt work anymore...

  if char='(v e c t o r) then
   <",2);
     return a>>;

 if (aa:=assoc(compress!* char, constructors!*)) then <<
    a:=apply(cadr aa, nil );
    if PAIRP a then if car a = 'csymbol then a:=cddr a;
    if PAIRP a then if car a = 'fn then a:=cddr a;
    if compress!* char neq third aa then
      errorML(third cdr aa, 2);
    return a>>;

  return nil;
end;


% The next two functions parse the  and  tokens and extract its
% content to be used by the function calling it. It will have different
% behaviours according to the attributes contained.

symbolic procedure cnRD();
begin scalar type, sep, tt, base;
% Must check that what is being returned is an int.
 type:=nil;
 sep:=nil;
 type:=intern find(atts, 'type);
 base:=find(atts, 'base);
 lex();
 tt := char;

 lex();

 if type='constant then return compress!* tt;

 if type=nil then return compress!* tt;

 if member(type, '(real integer)) neq nil then <<
   if base eq nil then return compress!* tt
   else return 'based_integer . nil . base . list ('string . list compress!* tt)
 >>;

 if member(intern type, '(rational complex!-cartesian complex!-polar)) neq nil then
   << sep:=sepRD();
      if type='rational then <<
        lex();
        return rational(compress!* tt, sep)
      >>
      else
       if type='complex!-cartesian then
         << lex();return 'complex_cartesian . nil . compress!* tt . list sep >>
       else
        if type='complex!-polar then
         << lex();return 'complex_polar . nil . compress!* tt . list sep >>
   >>;
end;


symbolic procedure ciRD();
begin scalar test, type,aa, tt, ats;
 aa:=nil; type:=nil; test:=nil;
 ats:=retattributes(atts, '(type));
 lex();
 tt := char;
 lex();
  << test:=compress tt;
     if NUMBERP test then errorML(test, 4);
     test := compress!* tt;
     if ats = nil then return test;
     return list('ci, ats, test)>>
end;

% returns the value of the constant values.
% !!!!!!!!!! USELESS
%symbolic procedure consts(c);
%begin;
% if c='(quote i) then return 'i;
% if c='(quote d) then return 'd;
% if c='(quote e) then return 'e;
% if c='(quote p) then return 'pi;
% if c='(quote infinity) then return 'infinity;
% if c='(quote gamma) then return 'gamma;
%end;

% Constructs a rational number in intermediate representation

symbolic procedure rational(a,b);
begin;
 return 'rational . nil . a . list b;
end;

% Reads through values seperated by  tags and
% returns them in a list

symbolic procedure sepRD();
begin scalar p1, p2;
 p1:=nil; p2:=nil;
 if char neq '(s e p !/) then errorML("",2);
 lex();
 p2:=compress!* char;
 return p2;
end;

% Creates a vector by using function matrix_row.

symbolic procedure vectorRD();
begin scalar a, ats;
 ats:=retattributes(atts, '(type other));
 a:=nil;
 a:=matrixrowRD();
 a:=cons('vectorml,cons(ats, a));
 return a;
end;

% The following functions constructs the matrix from the mathml information.

symbolic procedure matrixRD();
begin scalar b1, stop, ats, b2;
 ats:=retattributes(atts, '(type));
 stop:=0;
 b1:='();
 b2:=nil;
 while stop=0 do
 <<
   lex();
   if char='(m a t r i x r o w) then
    <",2)>>
   else stop:=1
  >>;
 return cons('matrix, cons(ats,cons('matrixrow, list b1)));
end;

symbolic procedure matrixrowRD();
begin scalar a;
 a:=nil;
 a:=mathML();
 return if a=nil then nil
        else cons(a, matrixrowRD());
end;

% returns a lambda function constructed from the information supplied.

symbolic procedure lambdaRD();
begin scalar b1, b2, ats;
 ats:=retattributes(atts, '(type definitionURL encoding));
 lex();
 b1:=getargsRD();
 b2:=mathML2();
 lex();
 return cons('lambda, cons(ats, append (b1, list b2)));
end;

% returns a set constructed from the information supplied.

symbolic procedure setRD();
begin scalar setvars, ats;
 ats:=retattributes(atts, '(type));
 setvars:= cons('set, cons(ats, stats_getargs()));
 return setvars;
end;

% returns a list constructed from the information supplied.

symbolic procedure listRD();
begin scalar ats;
 ats:=retattributes(atts, '(order));
 return cons('list, cons(ats , stats_getargs()));
end;



symbolic procedure fnRD();
begin scalar b1;
 lex();
 if char neq '(c i) then errorML(compress char,20)
 else b1:= mathML2();
 lex();
 return b1;
end;

% Reads the declare construct and sets the value of the given variable to
% the given value.

symbolic procedure declareRD();
begin scalar b1, b2, ats;
 ats:=retattributes(atts, '(type nargs occurence scope definitionURL));
 lex();
 if char='(c i) then
  << b1:=ciRD()>>
 else errorML("", 8);
 lex();
 if char neq '(!/ d e c l a r e) then <>;

 return cons('declare, list(ats, b1, b2));
end;

% This function will determine if the next token is a valid token following
% an apply token. It then calls the appropriate function if succesful.

symbolic procedure applyRD();
begin scalar aa, fun;
 lex();
 % This following _if_ statement relates the mathml tag to its entry in functions!*
 % It then returns a list starting with the name of the function followed by its
 % arguments: eg: (plus 1 2 3).
 % It uses the table in functions!* to find the function name (the third entry) and
 % the arguments to send the RD function.

 mmlatts:=retattributes(atts, '(type definitionURL encoding));

 if (aa:=assoc(compress!* char, functions!*)) then <<
   fun:=apply(cadr aa, nil);
   fun:=mmlatts . fun;
   mmlatts:=nil;
   return cons(cadr rest aa, fun);
 >>;
 errorML(compress char, 17);
end;


%  Reads through a select construct and acts accordingly.

symbolic procedure selectRD();
begin scalar a1, b2, b3;
 a1:=mathml();

 if car a1 = 'matrix then <<
   b2:=mathml();
   lex();
   if char neq '(!/ a p p l y) then <>;
   return cons(a1, list(b2, b3))
 >>;

 if car a1 = 'list OR car a1 = 'vectorml then <<
   b2:=mathml();
   lex();
   return cons(a1, list b2)
 >>;

end;

% Returns the transpose of the element contained in the transpose tags.

symbolic procedure transposeRD();
begin scalar a;
 a:=mathML();
 lex();
 return list a;
end;

% Returns the determinant of the given element.

symbolic procedure determinantRD();
begin scalar a;
 a:=mathML();
 lex();
 return list a;
end;

% Takes the given function name, makes it an operator, and then
% applies it to the arguments specified in the mathml input.

symbolic procedure applyfnRD();
begin scalar b1, b2, c1;
 b1:=nil; b2:=nil; c1:=nil;
 b1:=fnRD();
 b2:=stats_getargs();
 return b1 . nil . b2;
end;

% Introduces the new csymbol element of MathML 2.0

symbolic procedure csymbolRD();
begin scalar b1, b2, c1;
 b1:=nil; b2:=nil; c1:=nil;
 b1:=fnRD();
 b2:=stats_getargs();
 return b1 . nil . b2;
end;

% Reads the condition tag.

symbolic procedure conditionRD();
begin scalar a;
 a:=mathml();
 lex();
 if char neq '(!/ c o n d i t i o n) then errorML("", 2);
 return cons('condition, list a);
end;

% This function will read all legal tags following the  tag.

fluid '(relations!*);

symbolic procedure relnRD();
begin scalar aa, ats;
 lex();
 ats:=retattributes(atts, '(type definitionURL));
 if (aa:=assoc(compress!* char, relations!*)) then return cons(cadr rest aa, cons(ats, apply(cadr aa, nil)));
end;

symbolic procedure relationRD( type );
begin scalar args;
 args:=stats_getargs();
 return cons(cadr type, args);
end;

%!!!!!!!! PROBABLY USELESS FUNCTION!!!!!
symbolic procedure binaryrelationRD( type );
begin scalar arg1, arg2;
 arg1 := MathML();
 arg2 := MathML();
 lex();
 return cons(type, list (arg1, arg2));
end;

% The following functions do all the necessay actions in order to evaluate
% what should be by the tags.


symbolic procedure subsetRD();
begin scalar abc1;
abc1:=nil;
abc1:=mathML();
return if abc1 = nil then '()
        else cons(abc1, subsetRD());
end;

symbolic procedure prsubsetRD();
begin scalar abc1;
abc1:=nil;
abc1:=mathML();
return if abc1 = nil then '()
        else cons(abc1, prsubsetRD());
end;

% These functions parse through most MathML elements,
% since many fall in the unary, binary and nary categories.

symbolic procedure unaryRD();
begin scalar a;
  a:= mathML();
  lex();
  return list a;
end;

symbolic procedure binaryRD();
begin scalar a1, a2;
  a1:=mathML();
  a2:=mathML();
  lex();
  return cons(a1, list a2);
end;

symbolic procedure naryRD();
begin scalar a;
a:=mathML();
return if a = nil then '()
        else cons(a, naryRD());
end;

symbolic procedure setFuncsNaryRD();
begin scalar a;
a:=mathML();
if PAIRP a then <>;
return if a = nil then '()
        else cons(a, setFuncsnaryRD());
end;

symbolic procedure setFuncsBinRD();
begin scalar flag,a1,a2;
  flag:=nil;
  a1:=mathML();
  if PAIRP a1 then <>;
  lex();
  if flag=t then mmlatts:='multiset;
  return cons(a1, list a2);
end;


% Encodes information given in a  tag.

symbolic procedure limitRD();
begin scalar var, condi, low, exp, ats;
 ats:=retattributes(atts, '(definitionurl));
 low:=nil;
 lex();
 if char='(b v a r) then
  << var:=bvarRD();
     if (caddr var neq 1) then errorML("",8);
     lex()>>
 else var:=nil;

 if char='(l o w l i m i t) then
  << low:=lowlimitRD();
     >>
 else if char='(c o n d i t i o n) then
     <<      condi:=conditionRD()
        >>
      else condi:=nil;

 exp:=mathML();
 lex();

 if condi=nil then
   return list(var, low, exp);

 if low=nil then
        return list(var, condi, exp);
end;

% Returns the partial derivative.

symbolic procedure partialdiffRD();
begin scalar res, bvar, express;
 lex();
 bvar:=getargsRD();
 express:=mathML2();
 lex();
% res:=cons(express, bvar);
 res:=append(bvar, list express);
 return res;
end;

% Returns the derivative.

symbolic procedure diffRD();
begin scalar bvar, express;
 lex();
 if char='(b v a r) then
  <>
 else bvar:=nil;
 express:=mathML2();
 lex();
 return diff2 list(bvar, express);
end;

% This function restructures the IR when we are differentiating
% more than degree 1 so the translation is possible to OM

symbolic procedure diff2(elem);
begin scalar fun, res, deg, var;
  deg:=caddr car elem;
  var:=cadr car elem;
  if deg=1 then return elem;
  fun:=car reverse elem;
  res:='diff . nil . ('bvar . var .list  1) . list fun;
  deg:=deg-1;
  while deg > 0 do <<
  res:='diff . nil . ('bvar . var .list  1) . list res;
  deg:=deg-1;
  >>;
  return cddr res;
end;


% This function reads through the a series of  tags and extracts the
% variables.

symbolic procedure getargsRD();
begin scalar a;

% Dont forget. This function leaves the file pointer on
% the next token after the last bvar. So you need to use mathML2 after.

if char='(b v a r) then
<>;
end;

% Parses through MathML quantifiers

symbolic procedure quantifierRD();
begin scalar bvars, condi, exp;
  lex();
  bvars:=getargsRD();
  if char='(c o n d i t i o n) then
     condi:=conditionRD()
  else condi:=nil;

  if condi neq nil then exp:=MathML()
  else exp:=MathML2();
  lex();
  return append(bvars, list(condi, exp));
end;

% This function will parse through the sum, product and int tags. Takes in the expression, then
% the bound variable, and finally the limits, conditions or intervals if they exist.

symbolic procedure symbolsRD();
begin scalar bvar, low, upper, int, exp, result, cond;
 low:=nil;
 upper:=nil;
 int:=nil;
 exp:=nil;
 result:=nil;
 cond:=nil;
 lex();
 if char='(b v a r) then
      <>
   else errorML("",14);


 if char='(l o w l i m i t) then <>
   else low:=nil;

 if char='(i n t e r v a l) then
   <>
   else int:=nil;

 if char='(c o n d i t i o n) then
   <>
   else cond:=nil;

 exp:=mathML2();
 lex();
 if (low neq nil) then return list(bvar, low, exp);
 if (int neq nil) then return list(bvar, int, exp);
 if (cond neq nil) then return list(bvar, cond, exp);
 return list(bvar, nil, exp);
end;

% Here we parse bound variables. The function reads the variable as well as
% the degree if there is one.

symbolic procedure bvarRD();
begin scalar var, deg;
 lex();
 if char='(d e g r e e) then
     errorML("",15);
 var:=mathML2();
 lex();
 if char='(d e g r e e) then
   << deg:=mathML();
      lex();
      if char neq '(!/ d e g r e e) then
        error("",2);
      lex()>>
 else deg:=1;

 if char='(!/ b v a r) then return cons('bvar , list(var, deg))
   else errorML("", 2);
end;

% Functions used to parse the limits of an integral, sum, or product.

symbolic procedure lowupperlimitRD();
begin scalar lowlimit,  upperlimit;
 lowlimit:=mathML();
 lex();
 if char='(!/ l o w l i m i t) then upperlimit:=upperlimitRD()
   else errorML("", 2);
 return cons('lowupperlimit, list (lowlimit, upperlimit))
end;

symbolic procedure lowlimitRD();
begin scalar lowlimit;
 lowlimit:=mathML();
 lex();
 if char neq '(!/ l o w l i m i t) then errorML("", 2);
 return cons('lowlimit, list lowlimit);
end;

symbolic procedure upperlimitRD();
begin scalar upperlimit;
 lex();
 if char neq '(u p l i m i t) then errorML("", 10);
 upperlimit:=mathML();
 lex();
 if char='(!/ u p l i m i t) then return upperlimit
   else errorML("", 2);
end;

symbolic procedure intervalRD();
begin scalar l,u, ats;
 ats:=retattributes(atts, '(closure));
 l:=mathML();
 u:=mathML();
 lex();
 if char='(!/ i n t e r v a l) then return cons('interval, list(ats, l,u))
   else errorML("", 2);
end;

% Following functions just evaluate calculus functions.

symbolic procedure logRD();
begin scalar a1, base;
 base:=nil;
 lex();
 if char='(l o g b a s e) then
    <>;
  a1:=mathML2();
  lex();
   return cons(base, list a1);
end;

symbolic procedure logbaseRD();
begin scalar a;
 a:=mathML();
 lex();
 if char='(!/ l o g b a s e) then return a
   else errorML("",2);
end;


% % Work on here. Make sure you can have either one or two arguments...
symbolic procedure minusRD();
begin scalar c,b;
  c:=mathML();
  b:=mathML();
  if b=nil then c:= cons(c,'())
   else <<
        c:=cons(c, cons(b, '()));
        lex()>>;
  return c;
end;


symbolic procedure rootRD();
begin scalar b,deg;
  lex();
  if char='(d e g r e e) then
  << deg:=mathML();
     lex();
     if char neq '(!/ d e g r e e) then
       error("","Syntax ERROR: Missing end tag");
     lex()>>
  else deg:=2;

  b:=mathML2();
  lex();
  return list(cons('degree, list deg), b);
end;



symbolic procedure minmaxRD();
begin scalar a, bvar, cond, flag;
 lex();
 flag:=0;
 if char = '(b v a r) then <> else bvar:=nil;
 if char = '(c o n d i t i o n) then <>
 else <<
   a:=mathml2();
   a:=cons(a, stats_getargs());
   cond:=nil
 >>;

 if flag=1 then << a:=MathML2(); lex()>>;
 if bvar neq nil then return cons(bvar, append(list cond, list a));
 if cond neq nil then return list(cond);
 return a;
end;


% Following function are in charge of parsing statistics related mathml.

symbolic procedure momentRD( );
begin scalar  deg, child;
 lex();
 if char='(d e g r e e) then
   << deg:=mathML();
      lex();
      if char neq '(!/ d e g r e e) then
        error("",2);
      lex()>>
 else deg:=nil;

 child:=mathml2();
 lex();

 return list(cons('degree, list deg), child);
end;

% The following function gets all arguments from the mathml input.

symbolic procedure stats_getargs();
begin scalar ww;
  ww:=nil;
  ww:=mathML();
  if ww neq nil then <<
  return cons (ww,stats_getargs())>>;
end;


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%   Here start the functions in charge of parsing reduce's output and printing %
%   it out in MathML.                 REDUCE->MathML                          %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% The following function takes an IR expression and produces a MathML equivalent

symbolic procedure ir2mml( u );
begin;
     FLUID '(indent);
     ind:=3;
     indent:=0$
     printout("");
     indent!* t;
     expression u;
     indent!* nil;
     printout( "" );
end;

% Prints out vectors.

symbolic procedure vectorML( elem );
begin;
   printout("");
end;

% Following functions print out matrices.

symbolic procedure matrixML( elem );
begin;
   printout(">
  else
    if ((car elem)= '!*sq)  then expression (PREPSQ (cadr elem))
    else operator_fn(elem);>>;
end;

symbolic procedure tendstoML( elem );
begin;
   printout("");
end;


% Prints out derivatives.

symbolic procedure dfml( elem );
begin scalar test;
 test:=cdr elem;
 if length test=1 OR (length test=2 AND NUMBERP
cadr test) then
    printout("")
 else
    printout("");
 indent!* t;
 dfargs(cdr elem);
 expression(car elem);
 indent!* nil;
 printout("");
end;

symbolic procedure dfargs( elem );
begin;
 if elem neq nil then
   << if length elem>1 then
      <<  if NUMBERP cadr elem then
          <");
            indent!* t;
            expression car elem;
            degreeML(cadr elem);
            indent!* nil;
            printout("");
            dfargs(cddr elem)>>
          else
          <");
            indent!* t;
           expression car elem;
            indent!* nil;
            printout("");
            dfargs(cdr elem)>>; >>
      else
        << printout("");
           indent!* t;
           expression car elem;
           indent!* nil;
           printout("");
           dfargs(cdr elem)>> >>;
end;


% Prints out degree statements.

symbolic procedure degreeML( elem );
begin;
 if car elem neq nil then <<
   printout("");
   indent!* t;
   expression( car elem );
   indent!* nil;
   printout("") >>;
end;


symbolic procedure rationalML(elem);
begin scalar a, b;
 a:=cadr elem;
 b:=caddr elem;
 printout("");
 princ a; princ ""; princ b; princ "";
end;


% Prints out relns.

symbolic procedure reln(elem, tty);
begin;
 printout("");
 princ "<"; princ tty;
 attributesML(car elem, "/");
 indent!* t;
 multi_elem( cdr elem );
 indent!* nil;
 printout("");
end;

% Prints out a set.

symbolic procedure containerML( elem, tty );
begin;
  if tty = 'integer_interval then tty:='interval;
  printout("<"); princ tty;
  attributesML(car elem, "");
  indent!* t;
  multi_elem( cdr elem );
  indent!* nil;
  printout("";
end;

% Prints out set theory related functions.

symbolic procedure sets(elem, tty);
begin;
 printout("");
 princ "<"; princ tty;
 attributesML(car elem, "/");
 indent!* t;
 multi_elem( cdr elem );
 indent!* nil;
 printout("");
end;

symbolic procedure listML( elem );
begin;
  printout( "" );
end;

symbolic procedure multilists( elem );
begin;
 if elem neq nil then
  if ((LENGTH elem)=1) then expression (car elem)
    else <>
end;

% Prints out unknown functions as a function. It prints out all variables
% declared as operators.

symbolic procedure csymbol_fn( elem );
begin;
  printout("");
  indent!* t;
  printout("";
  indent!* t;
  printout("");
  princ cadr elem;
  princ "";
  indent!* nil;
  printout("");
  multi_args(cddr elem);
  indent!* nil;
  printout("");
end;

symbolic procedure operator_fn( elem );
begin;
  printout("");
  indent!* t;
  printout("");
  indent!* t;
  printout("");
  princ car elem;
  princ "";
  indent!* nil;
  printout("");
  multi_args(cdr elem);
  indent!* nil;
  printout("");
end;

% Reads through a list and prints out each component.

symbolic procedure multi_args( elem );
begin;
  if  (elem neq ()) then <>
end;


% Prints out logs with a base.

symbolic procedure log_baseML(elem, type);
begin;
  printout("");
    indent!* t;
    expression(cadr elem);
    indent!* nil;
    printout("")>>;
    expression(caddr elem);
    indent!* nil;
    printout("");
end;


% Prints out equal relns.

symbolic procedure equalML( elem );
begin;
  printout( "" );
  indent!* t;
  expression(car elem);
  expression(cadr elem);
  indent!* nil;
  printout( "" );
end;

% Prints out square roots and moments.

symbolic procedure degreetoksML( elem, tty );
begin;
  printout( "<" ); princ tty;
  attributesML(car elem, "/");
  indent!* t;
  degreeML(cdadr elem);
  expression( caddr elem );
  indent!* nil;
  printout( "" );
end;

symbolic procedure bvarML(elem);
begin;
  printout("");
  indent!* t;
  expression(car elem);
  if cadr elem neq 1 then <<
    degreeML(list cadr elem);
  >>;
  indent!* nil;
  printout("")
end;

% This function prints a series of bvar statements

symbolic procedure xbvarML(elem);
begin;
  if elem neq nil then <>;
end;

symbolic procedure conditionML( elem );
begin;
  printout("");
  indent!* t;
  expression(car elem);
  indent!* nil;
  printout("")
end;

symbolic procedure lambdaML( elem );
begin;
  printout("")
end;

symbolic procedure attributesML( a, s );
begin;
  if a eq nil then <">>
  else <<
     princ " ";
     princ caar a;
     princ "=""";
     if caar a neq 'definitionurl then <<
        if cadar a = 'vectorml then princ "vector"
        else princ cadar a;
     >>
     else list2string(cadar a);
     princ"""";
     attributesML(cdr a, s);
  >>;
end;

symbolic procedure list2string(a);
begin;
  if a neq nil then <>;
end;

symbolic procedure declareML( elem );
begin;
  printout("")
end;

symbolic procedure lowupperlimitML( elem );
begin;
  printout("");
  indent!* t;
  expression(cadr elem);
  indent!* nil;
  printout("");
  printout("");
  indent!* t;
  expression(caddr elem);
  indent!* nil;
  printout("");
end;

symbolic procedure lowlimitML( elem );
begin;
  printout("");
  indent!* t;
  expression(car elem);
  indent!* nil;
  printout("");
end;


% Prints out quotients.

symbolic procedure quotientML( elem , tty);
begin;
  if (NUMBERP car elem) AND (NUMBERP cadr elem) then <<
     if !*web=nil then printout(" ")
     else printout(" ");
     princ car elem;
     princ "  ";
     princ cadr elem;
     princ " ">>
  else <<
     printout( "" );
     princ "<"; princ tty; princ "/>";
     indent!* t;
     expression( cadr elem );
     expression( caddr elem );
     indent!* nil;
     printout( "" )>>;
end;

% Prints out all nary functions.

symbolic procedure nary( elem, type );
begin;
  if car elem = 'e AND type = 'power then unary(cdr elem, 'exp)
  else <<
    printout( "" );
    princ "<";
    princ type;
    attributesml(car elem, "/");
    indent!* t;
    multi_elem( cdr elem );
    indent!* nil;
    printout( "" )>>
end;

symbolic procedure multi_elem( elem );
begin;
   if ((length elem)=1) then expression( car elem )
       else <>
end;


symbolic procedure minusML( elem );
begin;
  printout( "" );
  indent!* t;
  multiminus( cdr elem );
  indent!* nil;
  printout( "" );
end;

symbolic procedure multiminus( elem );
begin;
  expression(car elem);
  if ((length elem)=2) then expression cadr elem;
end;

symbolic procedure ciML(elem);
begin;
  printout("");
end;

symbolic procedure cnML(elem);
begin;
  printout("");
end;

symbolic procedure semanticML(elem);
begin;
  if length elem > 1 then <<
    printout("");
    indent!* t;
    printout("");
    indent!* t;
  >>;
  printout("");
  indent!* t;
  printout(""); princ caar elem; princ "";
  printout("");
  indent!* t;
  printout"<"; list2string cadar elem; princ ">";
  indent!* nil;
  printout("");
  indent!* nil;
  printout("");
  if length elem > 1 then <<
     indent!* nil;
     printout("");
     multi_elem(cdr elem);
     indent!* nil;
     printout("");
  >>;
end;

symbolic procedure numML(elem, type);
begin;
   if type='based_integer then <<
     printout " "; princ cadr caddr elem; princ " ";
   >>;
   if type='complex_cartesian then <<
     printout " "; princ cadr elem; princ "  "; princ caddr elem; princ " ";
   >>;
   if type='complex_polar then <<
     printout " "; princ cadr elem; princ "  "; princ caddr elem; princ " ";
   >>;


end;

% Prints out all pieces of data: i.e terminal symbols.
% They can be numbers, identifiers, or constants.

symbolic procedure constsML(exp);
begin;
      if (NUMBERP exp) then
                      << printout " "
                            else
                              if (FIXP exp) then princ " type=""integer""> "
                                else princ "> ";
                         princ exp;
                         princ " ">>;
         if (IDP exp) then
                     <<
                        if member(intern exp, constants!*) neq nil then
%                            < "; princ exp; princ " "; return nil>>
                            < "; princ exp; princ " ">>
                        else << printout " "
                           else
                              if (vectorp exp) then princ " type=""vector""> "
                                else princ "> ";
                         princ exp;
                         princ " ">>; >>;
end;

% Functions used to print out variables with a subscript.

% Prints out expressions in math form. Plagiarised from reduce code of
% mathprint

symbolic procedure ma_print l;
begin scalar temp;
   temp:=outputhandler!*;
   outputhandler!*:=nil;
   terpri!* nil;
   if !*web=nil then maprin ""
   else maprin "";
   maprin l;
   maprin "";
   terpri!* nil;
   outputhandler!*:=temp;
end;

% Function in charge of doing all printing in order to make sure the
% indentation is always correct.

symbolic procedure printout( str );
begin;
   if !*web = nil then terpri();
   if !*web = nil then for i := 1:indent
      do << princ " " >>;
   if PAIRP str then
    <>
   else princ str;
end;

lisp operator mml;
lisp operator mml2ir;
algebraic operator g_eq;
algebraic operator l_eq;
algebraic operator gt;
algebraic operator lt;
lisp operator plusRD;

symbolic procedure test();
begin scalar a;
  a:=mml2ir();
  terpri!* t;
  princ "Intermediate representation: ";
  terpri!* t;
  print a;
  ir2mml a;
end;


end;
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/introduction.tex����������������������������������0000644�0001750�0001750�00000053030�11526203062�025232� 0����������������������������������������������������������������������������������������������������ustar  �giovanni������������������������giovanni���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������\chapter{Introduction}

Nearly eight years after the appearance of the World Wide Web, it is still a difficult medium to use for the transmission
of mathematics and scientific material in spite of its success in other areas. Sending mathematics via e-mail or reading
mathematics into a software package from a web page is not a simple task, depriving the scientific community from a
powerful communications tool which is the Internet. Likewise, displaying mathematics on the Internet in a way that allows
editing and reuse has until now been impossible.

As the Internet continues to grow it is becoming ever more important to facilitate the exchange of mathematics amongst
users and computer algebra software packages, offering automatic processing of expressions, searching, editing and reuse.

To overcome these difficulties, various companies and societies have joined together to produce standards for representing mathematics whilst
preserving mathematical meaning. The World Wide Web Consortium\index{World Wide Web Consortium}~\cite{w3c} and the OpenMath\index{OpenMath
Society} society~\cite{openmath} have developed the two leading standards currently receiving most attention. These are MathML\index{MathML}
\cite{mathml} and OpenMath\index{OpenMath} \cite{openmathspec} respectively.

The chief purpose of OpenMath\index{OpenMath} is to facilitate consistent communication of mathematics between
mathematical applications. MathML\index{MathML} however, concentrates on displaying mathematics on the web whilst
maintaining its meaning. Both standards are complementary and used together can provide the opportunity to expand our
ability to represent, encode and successfully communicate mathematical ideas with one another across the Internet.

The primary aim of this project is to understand the differences and similarities between OpenMath\index{OpenMath} and
MathML\index{MathML}, to assess their exchangeability and develop a way of mapping one standard to the other. The main
objective will be to ultimately design and implement an interface running on REDUCE\index{REDUCE} which will translate
OpenMath\index{OpenMath} into MathML\index{MathML} and vice versa. This interface will provide REDUCE\index{REDUCE} with
the capability of exchanging mathematics with other applications as well as displaying output on the World Wide Web and
reading from it, allowing REDUCE to join the MathML/OpenMath trend.

\chapter{Literature Review}

The notation of mathematics has constantly evolved with the appearance of new concepts and ideas. Modern mathematical
notation is the result of centuries of refinement. As a result of this, the sophisticated symbols with which we write
mathematics pose certain problems when bringing them onto printed paper. Publishing mathematics is a difficult task simply
because mathematics do not lend themselves easily to publication.

Recently, the advances in Internet publishing, following the Internet expansion, have added a new dimension to
mathematical publishing. New problems as well as new requirements must be dealt with. We want the Internet not only to be
a medium for displaying mathematics around the world, but also a communications tool for transmitting them.

How can we ensure that mathematics published on a web page are reusable? Editable? The outputs of one application should
be displayed on the Internet in a way humans can understand and other applications can reuse. But because there is a
distinction between presenting mathematical objects, and transmitting their content, merging both into one notation to
achieve this duality is a non-trivial task.

In order to fully understand the motivations of this project, as well as appreciating its outcome, it is important to
carefully illustrate any related issues. We will look into the development of mathematical publishing and how it has
evolved with the growth of the Internet. This will permit us to better understand the need for mathematical representation
standards such as MathML\index{MathML} and OpenMath\index{OpenMath} which we shall introduce. Finally we will talk about
the relation between these standards, the existing software supporting them, and their future.

With such an overview of the current situation, the necessity of a MathML\index{MathML} to OpenMath\index{OpenMath}
interface for REDUCE\index{REDUCE} will become clear.

\section{Mathematical Publishing}

Before the foundation of the World Wide Web, encoding of mathematical documents was already a widespread practice. Back in
the days when computers were starting to become popular, the ASCII\index{ASCII} character set (and encodings based on it)
was the only widely available encoding scheme. The restrictions of such a limited symbol set were soon apparent.

In the mid seventies, Donald Knuth developed \TeX\index{\TeX}, from which variants such as \LaTeX\index{\LaTeX} stemmed. Layout and
typesetting of mathematics is extremely demanding and until now, Donald Knuth's \TeX\index{\TeX} had been able to address
these difficulties in a successful way, appealing to the scientific community who has now made it a standard in scientific
publishing. \TeX\index{\TeX} has become the tool of choice for producing scientific and mathematical documents.

Despite its widespread use and ease with which it is authored, \TeX\index{\TeX} does not preserve mathematical semantic
value, making it unpractical for use in web documents and useless for transmission between applications. \TeX\index{\TeX}
is only concerned with describing the presentation of mathematics, not the content. Because people are interested in
transmitting their ideas and research via e-mail or web pages it is fundamental that semantic value is kept.

While \TeX\index{\TeX} is mainly a UNIX based application, PC applications dealing with mathematical encoding have also emerged. Generally these
are equipped with a graphical user interface making them easier to use: Design Science\index{Design Science}'s MS Word Equation Editor,
FrameMaker\index{FrameMaker}, WordPerfect\index{WordPerfect} or ScientificWord\index{ScientificWord} are a few to name examples. All these
applications\footnote{It is worth noting that PC applications have not had the same success as \TeX\index{\TeX}.} just deal with displaying
mathematics and ignore semantic value. They are usually vendor specific making them unpractical for use in mathematical web publishing.

\section{Mathematics and the Internet Challenge}

\subsection{Html and Mathematics}

In the early 1990's, The World Wide Web Consortium\index{World Wide Web Consortium}'s Html \index{Html} became the
standard markup language for publishing on the World Wide Web. It has since evolved and has become an extensible and very
powerful means of representing interactive Internet documents. In terms of representing mathematics however, Html has
little support.

In the first versions of Html\index{Html} , no support for mathematics was included. It was not until 1993 that the first
intent of embedding mathematics within Internet documents was attempted in the Html+\index{Html!Html+} draft \cite{htmlp}
presented by the World Wide Web Consortium\index{World Wide Web Consortium}. Equations were represented directly as
Html+\index{Html!Html+} using an SGML\index{SGML} \cite{sgml} based notation, inspired by \LaTeX's\index{\LaTeX} approach.

In 1994, the World Wide Web Consortium\index{World Wide Web Consortium} went further in mathematics Internet publishing by
presenting the Html 3.0\index{Html!Html 3.0} draft \cite{html3} (which later was officially published as the Html
3.2\index{Html!Html 3.2} \cite{html3.2} specification with a few modifications) which offered a more comprehensive support.
They claimed {\it ``Html math is powerful enough to describe the range of math expressions you can create in common word
processing packages, as well as being suitable for rendering to speech.''}

Nonetheless, both drafts failed because of lack of interest from popular browser vendors. But even though the mathematical
ideas in the Html 3.2\index{Html!Html 3.2} specification were never fully deployed, people started thinking more carefully
about mathematics, and how they could be represented on the WWW.

In the meantime, while the World Wide Web Consortium\index{World Wide Web Consortium} and other societies continued
working on developing mathematical support for Internet documents, other solutions to transmitting mathematics on the web
arose. The lack of a standard approach to uniformly represent mathematics on the Internet pushed mathematicians and
scientists to use a variety of different techniques to achieve this purpose. Let us give a brief overview of the main
ones.
	
\subsection{Embedded Graphics}

One way of displaying mathematics on the web is by the use of embedded graphics inside Html documents. Mathematical
equations are represented by graphical images (e.g. gifs) which all browsers display without difficulties. Formulae can be
viewed in their original rendering, without the browser requiring additional fonts or external viewing programs.

Nevertheless, these images display low resolutions and printing them results in poor quality documents. There are also
problems with alignment and sizing. Because graphical images are generally slow to download, documents might take more
time than desired to be rendered. Since we are only dealing with images, the equations are not editable. No modifications
can be done on them. For the same reasons, they are not reusable, because semantic value is completely lost.

This method is widespread but not very appreciated. In the Html 3.0\index{Html!Html 3.0} draft, the World Wide Web
Consortium\index{World Wide Web Consortium} specifically states its intention of helping users avoid the use of inline
images to display equations.

This is the approach used by programs such as \LaTeX\index{\LaTeX}2Html \cite{latex2html} or \TeX\index{\TeX}4ht
\cite{tex4ht} which can convert \LaTeX\index{\LaTeX} and \TeX\index{\TeX} documents to Html\index{Html} format for direct insertion into the
Internet. \LaTeX\index{\LaTeX} markup is translated into Html while mathematical equations are converted into graphical
images. It is worth noting however, that there exist programs such as TtM\index{TtM} \cite{TtM} which translate the
mathematical sections directly into MathML\index{MathML} presentation markup \index{MathML!presentation markup}.

\subsection{Graphical Page Display}

Another way of approaching the problem is by using graphical page displays. The page is rendered into a page-description
language such as postscript\index{postscript} or PDF\index{PDF}. Internet browsers, aided by an external viewer or plug-in
can then display the page in its integrity, including any mathematical formulae within it. When using this method,
documents are displayed with exactly the same layout as the original documents, which could be \TeX\index{\TeX} documents
for instance. The printing resolution is also maintained at a high quality level.

But using an external viewer or plug-in involves everyone possessing a copy. A viewer also requires a verbose and large
file format including all the non-standard fonts used. Just in the same way as the embedded graphics display, any
mathematics contained within these documents looses its semantic value, as well as the possibility to edit it or modify
it.



\section{OpenMath\index{OpenMath} and MathML\index{MathML}}

These interim solutions have only contributed to the problem by putting in evidence the need of a consistent standardized methodology for the
transmission of mathematics via the World Wide Web. In view of the failure of existing methods MathML and OpenMath's\footnote{Describing these
standards in detail is not in the scope of this report. We do encourage the reader to have a careful read through both standard specifications
\cite{openmath}\cite{mathml} in order to better understand this report and its implications.} significance and importance increased. Both standards
are complementary yet serving different purposes.

The primary aim of OpenMath\index{OpenMath} is to facilitate reliable communication of mathematical objects between mathematical applications. It
ensures semantic content is preserved within the notation. The semantic scope of OpenMath\index{OpenMath} is defined within its content
dictionaries\index{content dictionaries} (CD) where all symbols used are described defining their semantic value. Related symbols and functions are
grouped into CD groups. It is expected that applications using OpenMath\index{OpenMath} declare which CD groups they understand.

MathML\index{MathML} however is World Wide Web oriented in that it seeks to display mathematics on web pages.
MathML\index{MathML} has two combinable versions, one encoding mathematical objects (presentation
markup\index{MathML!presentation markup}) and the other encoding mathematical meaning (content markup\index{content
markup}). Both versions allow authors to encode both the notation which represents a mathematical object and the
mathematical structure of the object itself. Moreover, authors can mix both kinds of encoding in order to specify both the
presentation and content of a mathematical idea.

In fact there are strong links between both recommendations. The communities developing both standards are closely
related, with some members belonging to both groups. This has resulted in both standards superceding each other in some
areas.

The {\it core} OpenMath\index{OpenMath} CD group is the principal CD group. The {\it core} CD group was designed based on
MathML\index{MathML!MathML 1.0} 1.0, extending the set of symbols covered by MathML\index{MathML!MathML 1.0} 1.0. Its
intention is not to be very specific, only covering everyday and K-12 (kindergarden to high school level) mathematics just
as MathML\index{MathML} does.

For completeness, a MathML\index{MathML} CD group was introduced in the OpenMath\index{OpenMath} standard. It is a subset
of the {\it core} CD group and has the same semantic scope as do the content elements of MathML\index{MathML}. It is
expected that most applications will understand the {\it core} CD group, automatically understanding the
MathML\index{MathML} CD group.

The recently published MathML\index{MathML!MathML 2.0} 2.0 version has incorporated elements of the {\it core}
OpenMath\index{OpenMath} CD group which weren't before in MathML\index{MathML!MathML 1.0} 1.0. But in order to keep the
scope of content markup\index{content markup} down to a reasonable size, the designers of MathML\index{MathML} have
restricted the mathematics that it attempts to cover to high school level mathematics limiting MathML\index{MathML}'s
ability to convey mathematical meaning. Because OpenMath\index{OpenMath} is more powerful in this respect, the designers
of MathML\index{MathML} have introduced means allowing for extensibility. It is possible to encode semantic information
inside MathML by embeding OpenMath\index{OpenMath} objects within MathML\index{MathML} code.

This demonstrates the close ties existing between both the World Wide Web Consortium\index{World Wide Web Consortium} and
the OpenMath\index{OpenMath Society} society. In the MathML\index{MathML!MathML 2.0} 2.0 specification one can read: {\it
``The MathML\index{MathML} content elements are heavily indebted to the OpenMath\index{OpenMath} project \ldots''}

\section{Current Support}
   
Both standards have received considerable attention, and have mobilized many developers. Support for MathML\footnote{For a comprehensive list of software supporting MathML look at the W3C web site~\cite{w3c}}
\index{MathML}
and OpenMath\index{OpenMath} is being introduced in many areas now that a future seems to profile itself. 

The dominance of Java\index{Java} on the Internet today has made it a good candidate for offering a solution to the
problem of publishing mathematics. The flexibility and power of Java\index{Java} applets can be used in conjunction with
MathML or OpenMath to display mathematical formulae.

This approach is currently best represented by WebEQ\index{WebEQ} \cite{webeq}. WebEQ\index{WebEQ} is a collection of programs and Java\index{Java}
programming libraries dealing with all aspects of putting math on the Web.  Because WebEQ\index{WebEQ} is based on MathML\index{MathML},
WebEQ\index{WebEQ} tools can easily be combined with each other and with other MathML\index{MathML} software to accomplish a wide range of tasks.
The applet takes a representation of an equation as input, and displays it. The representation has to be some markup language which the applet
supports (MathML\index{MathML} or Web\TeX\index{WebTeX}). Another Java\index{Java} application is ICEBrowser \cite{ice}. A browser component
written in Java\index{Java} which renders MathML\index{MathML}.

By using a Java\index{Java} applet we encounter the same difficulties as when using embedded graphics. In addition to
this, Java\index{Java} applets have a larger initial download overhead, which can be disturbing to some users.
Java\index{Java} applets usually offer good equation displays, but different vendors supply different solutions and markup
languages.

Another set of applications currently offering MathML support are plug-ins. The main distinction in principle between
using plug-ins or Java\index{Java} applets is that plug-ins need to be pre-installed on the Internet browser for any
rendering to take place. IBM\index{IBM} Techexplorer\index{TechExplorer} \cite{ibm} is a representative example under
development. It currently supports MathML\index{MathML} encodings. IBM\index{IBM}'s approach to the problem is definetely
bordering the solution the scientific community is hoping to see. Techexplorer can display MathML\index{MathML} and the
quality of display is acceptable. Hopefully, IBM\index{IBM}'s techexplorer initiative will push other browser vendors and
companies to adopt MathML\index{MathML} as the leading standard.

But as with the other temporary solutions, plug-ins also have their limitations. 
Plug-ins have trouble getting the current HTML document font size, changing the size of the window to fit the display, or getting the current HTML document background color. Plug-ins such as IBM\index{IBM}'s are not
yet widespread, and most people are not familiar with plug-in download and installation.

In the area of computer algebra, soon many computer algebra packages should have interfaces to both standards. An example
of this is the MathML\index{MathML} to REDUCE\index{REDUCE} interface available in REDUCE\index{REDUCE} 3.7, or the MathML
interface built in Mathematica Version 4.

Various programs convert \LaTeX~documents into MathML. This is important because of the large amount of documents written
in LaTeX\index{\LaTeX} until now. An example of a program accomplishing this task is TtM\index{TtM} \cite{TtM} for
instance.

Various equation editors such as MathType or Design Science\index{Design Science}'s MS equation editor also support
MathML\index{MathML}. They manipulate expressions and offer easy to use graphical user interfaces. It is possible to
export equations to MathML format.

Until now however, both Explorer\index{Explorer} and Netscape\index{Netscape} have not yet incorporated support for
MathML\index{MathML}, although they have committed themselves in doing so in the near future. Because these are the most
popular browsers, it is important that they soon provide MathML\index{MathML} facilities in order to boost the use of
MathML\index{MathML}.

\newpage

\section{The future}

\begin{quotation}

\emph{``While many in the mathematical and scientific community have already adopted \LaTeX~as the standard for writing
papers, it appears that MathML\index{MathML} is the future of scientific and mathematical notation on the Web.''} Bob
Henshaw, UNC.

\end{quotation}

Regardless of how efficient MathML \index{MathML}and OpenMath are in transmitting and displaying mathematics, it is clear
that they will only be of any use if all communities adopt it. It is expected however that most popular software companies
working on the Internet or on computer algebra packages will soon support MathML and OpenMath. It seems as if MathML and
OpenMath will recieve the necessary support due to the commitment that various big companies have already shown
(IBM\index{IBM}, Netscape\index{Netscape}, Microsoft\index{Microsoft}, Wolfram\index{Wolfram}, Design Science\index{Design
Science}, and many others).

At the moment some browsers have already implemented MathML\index{MathML} rendering facilities (Amaya\index{Amaya} for
instance), and soon other bigger browser vendors will join the trend. Mozilla has recently released its latest browser
which does render MathML. Netscape should follow soon with Navigator5\index{Netscape!Navigator 5}. MathType from Design
Science\index{Design Science} has released a new version incorporating various tools for dealing with MathML and OpenMath.
For those not familiar with Design Science\index{Design Science}, they also make MS Word's equation editor. Other
companies (mainly Stilo) are developing equation editors with MathML and OpenMath facilities which will soon hit the
market.

While substantial progress has been made, there are still areas in which more work is required before MathML can be
incorporated easily into the Internet. Further improvement in coordination between browsers and embedded elements will be
necessary. Furthermore, higher printing resolution must be achieved.

MathML and OpenMath are the first XML\index{XML} based markup language to appear on the Internet. They will show the power and limitations of XML.
An example has been set for other specialist areas which also want to benefit from the Internet.; areas such as Chemical Engineering or Music are
using XML to develop representation standards. Both standards have been recieved enthousiastically and it will surely not take long before they are
used widely by the scientific community.


��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/design.tex����������������������������������������0000644�0001750�0001750�00000040172�11526203062�023765� 0����������������������������������������������������������������������������������������������������ustar  �giovanni������������������������giovanni���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������\chapter{Program Design and Implementation}

The design of an OpenMath/MathML interface must aim to keep the structure simple, extensible if needed and easy to maintain. This document will
attempt to describe the structure of the overall system and the individual modules which compose it. A common interface coordinating the separate
components will be analysed and defined.

Furthermore we will explain why the system will be table based and what advantages this offers for our application. Because both OpenMath and
MathML are XML languages, we must specify the requirements the translator's lexer and parser must follow. Finally we will see what new
functionalities can be added to the interface in possible future extensions.

\section{System architecture}

The task of translating one language to another, as is the case of our OpenMath/MathML interface, can be compared to the task performed by a
compiler when passing from a programming language to a computer executable representation.

We will need to lex and parse an expression, represent it in some intermediate language which allows a certain degree of freedom for manipulation,
and then from there an expression can be generated in the target language.

Following this approach, the architecture of the REDUCE OpenMath to MathML interface is going to be composed of four independent modules. One for
each of the following tasks:

\begin{itemize}

\item Passing MathML to the intermediate representation

\item Passing OpenMath to the intermediate representation

\item Passing from the intermediate representation to MathML

\item Passing from the intermediate representation to OpenMath

\end{itemize}

Dividing the interface into these separate modules gives us the possibility to better understand the overall process of translation. It has the
advantage of permitting efficient modifications to the system.

If MathML syntax were to change, for instance, it would only be necessary to modify two of the four modules. This separation also makes it easy to
add extensions. By implementing a module going from the intermediate representation to \LaTeX, it is possible to extend the interface's
capabilities to offer OpenMath to \LaTeX~or MathML to \LaTeX~translations. Figure \ref{archi} illustrates the system architecture.

\begin{figure}

\begin{center}

{\includegraphics{architecture.eps}}
%{\includegraphics{architecture.jpg}}

\caption{OpenMath/MathML Interface System Architecture}
\label{archi}

\end{center}

\end{figure}

\subsection{Module Requirements}

Each of these modules has several requirements to respect. These requirements ensure the system is efficient and behaves satisfactorily. {\it (Here
IR stands for intermediate representation)}

\begin{description}

\item[MathML to IR:] This module parses through MathML and generates an equivalent expression in the intermediate representation. It should ensure
that the input given is not lexically or syntactically incorrect. In which case the translation process is aborted. Incorrect or unimportant
attribute values should be ignored unless they compromise the translation process. Both MathML 1.0 and MathML 2.0 expressions must be accepted as
valid and parsed. It should be designed so any modification in MathML can be easily adapted to.

\item[IR to MathML:] This module generates valid MathML from the intermediate representation of an expression. The user should have the option to
generate either MathML 2.0 or MathML 1.0, since most applications today are only MathML 1.0 compliant . In order to embed MathML into a web page
for rendering by a plug-in, there should also be an option outputting the MathML inside HTML \verb|| tags.

\item[OpenMath to IR:] This module reads in OpenMath expressions and transforms them into the intermediate representation. It should ensure that
the input given is not lexically or syntactically incorrect. In which case the translation process is aborted. Symbols must be checked to see if
they have a MathML equivalent. This means checking each symbol against the CD it belongs to and then looking up in a table to see whether a mapping
is possible. If there is no equivalent, this module must encode the OpenMath symbol into the intermediate representation as an unknown symbol for
inclusion in MathML \verb|| tags.

\item[IR to OpenMath:] This module generates valid OpenMath from the intermediate representation. It is important that all symbols generated appear
next to the correct CD to which they belong. This is done by consulting a table containing this information.

\end{description}

Because it is important to specify which OpenMath CDs an application handles, Appendix A gives a comprehensive list of all the OpenMath CDs and
elements which are supported by the translator.

\section{The Intermediate Representation}

If the breakdown of the system into separate modules is to be effective, we need a clean interface between all parts. An intermediate
representation representing expressions in a generic way accomplishes this task. For an intermediate representation to be useful, it is important
that it conveys and preserves all the information MathML and OpenMath objects are capable of representing. Let us look at the requirements such an
intermediate representation must satisfy for use in our OpenMath/MathML interface.

Both OpenMath and MathML build expressions by using prefix operators. REDUCE's symbolic representation of expressions also uses prefix operators to
construct expressions. This connection motivates us to use prefix operators in our intermediate representation, thus allowing an uncomplicated
mapping between the intermediate representation, OpenMath, MathML and REDUCE's representation of expressions. Subsequently the intermediate
representation is closely related to the parse trees of each language.

Given that MathML elements may take attributes changing their semantic meaning, it is necessary that attribute values are represented by the
intermediate representation. Thus permitting MathML elements mapping to different OpenMath symbols (depending on their attribute values) to be
correctly translated from one standard to the other. The attributes conveyed by the intermediate representation are then interpreted differently by
the various modules according to the context they appear in.

Considering that OpenMath extensibility is a key issue, our intermediate representation must be able to encode objects without MathML equivalent.
The unsupported OpenMath symbol and its CD will be passed on from the {\bf OpenMath to IR} module to the {\bf IR to MathML} module so that the
MathML extension mechanism is employed.

Moreover, the intermediate representation will need to be simple to manipulate. Since RLISP is the programming language in which this interface is
written, we must keep in mind the possibilities and limitations this language offers. Therefore the intermediate representation expressions will be
structured as lists. Lists are the basic data structures in RLISP and there exist many commands permitting very easy and efficient manipulation of
them.

Because our intermediate representation is designed in terms of the syntactic structure of both OpenMath and MathML, and certain subroutines are
attached to the MathML and OpenMath production rules to produce proper intermediate encoding, we can classify our methodology as {\it
syntax-directed translation}~\cite{compilers}. Basically, the actions of the syntax analysis phase guide the translation. Thus the intermediate
code is generated as syntax analysis takes place.

\section{Use of Tables in the Translation Process}

The complexity and diversity of MathML and OpenMath elements require that a translator has some way of keeping information concerning all elements.
The parsing and generation of OpenMath requires a translator to have some way of knowing which content dictionaries symbols belong to. Similarly,
the correct procedures must be employed upon each element encountered. This information must be stored in a readily accessible way. It is important
to design these tables and that we understand how each module will use them to appropriately accomplish their tasks.

The information guiding the translator can be either hand coded into the program or gathered into tables. Hand coding is complex and useful only in
situations where an element needs to be handled in a very precise way. Tables however can contain organized information related to each element
useful when parsing and generating expressions.

We believe using a table-based system is more efficient for our application and can produce better and more compact code, thus improving code
readability, extensibility and maintenance. Because a translator must deal with a variety of elements, most of similar structure, a table-based
system permits the translator to relate an element to a set of functions and/or information. This way, any modifications of the MathML standard can
be easily adapted to by modifying a table or adding a new entry to it.

The idea is to gather in a few tables all the necessary information for properly handling all MathML and OpenMath recognized elements. Let us
describe the main tables\footnote{These tables are defined in the file {\tt tables.red}} which are used by the interface. To better understand the
system we will describe how they should be used by each module to accomplish the task.

\subsubsection{MathML to IR Module}

All MathML elements are stored in the tables {\tt constructors!*}, {\tt relations!*} and {\tt functions!*}. These tables determine what functions
must be called for each MathML element encountered and what the equivalent intermediate representation operator is.

When a MathML object is encountered, the first element will inform us of how the expression is constructed. We look this element up in the {\tt
constructors!*} table to call the proper function which deals with objects constructed in this manner.

If the expression constructor is the \verb|| element then the {\tt relations!*} table is used. This table will determine which function to
call as well as containing the equivalent intermediate representation operator. The {\tt functions!*} table is the same as the {\tt relations!*}
table only that it contains all operators appearing within \verb||\ldots\verb|| instead.

These tables together will inform the translator of how to deal with all MathML elements

New MathML elements can be added to these tables to modify the translator's scope. An existing procedure can be related to the new element, or a
new procedure can be implemented and added to the table next to the element's entry. An equivalent intermediate operator must also be defined here.

\subsubsection{IR to MathML Module}

When an intermediate representation expression must be translated to MathML the table {\tt ir2om\_mml!*} specifies which function to call for the
translation of each intermediate representation operator. As an intermediate expression is parsed, this table will ensure that proper production of
MathML is achieved. This table also contains the function to call when producing OpenMath.

New operators are added to this table. The procedure name specifying how the new IR operator is translated to MathML is also added to the table.

\subsubsection{OpenMath to IR Module}

OpenMath objects must be thoroughly checked for various reasons. Firstly, not all OpenMath symbols have MathML equivalents. Table {\tt mmleq!*}
contains all OpenMath symbols which easily translate to MathML. If a symbol is not contained within this table then it is searched inside tables
{\tt special\_cases!*} and {\tt special\_cases2!*}.

Table {\tt special\_cases!*} contains all OpenMath symbols which have a MathML equivalent but under a different name. It also deals with OpenMath
symbols mapping to one MathML element but with different attribute values. This table will also specify where necessary the correct attribute types
and values the MathML equivalent element must take.

Table {\tt special\_cases2!*} contains all OpenMath symbols which require careful translation. For each element, a specific function is associated.
These functions are specially designed to deal with these elements efficiently.

If a symbol is not contained within any of these tables, then the elements is considered unknown and the MathML extension mechanism is used to
produce a reasonable translation.

\subsubsection{IR to OpenMath Module}

Producing OpenMath from the intermediate representation follows a similar procedure as that described for generation of MathML. The table {\tt
ir2om\_mml!*} contains the function to call for each intermediate representation operator to produce OpenMath.

\section{XML Lexing and Parsing}

Because there are no XML lexers or parsers for REDUCE, it is necessary to design and implement them. In order to do so it is important to establish
what the requirements of such procedures are.

\subsection{The Lexer}

Both MathML and OpenMath are based on the structures defined by XML. The lexer must validate XML markup languages and extract the necessary tokens
from the successive characters in the input source.

Hence it is important that our lexer tokenizes XML elements as well as determining the different attribute types and values an element may possess.
These requirements must be met in order to retrieve the different attributes contained in MathML elements or to find out what symbol and content
dictionary is expressed by an OpenMath \verb|| tag.

An XML lexer must also be flexible with spaces, ignoring any amount of spaces or return carriages contained in the input source.

\subsection{The Parser}

The lexical analysis and the following phase, the syntax analysis, will be grouped together into the same pass. Under that pass the lexer operates
under the control of the parser. The parser will ask the lexical analyzer for the next token whenever it needs one. The lexer will return this
information as well as storing the attribute types and values of the current token parsed. The parser will not generate a parse tree explicitly but
rather go to intermediate code directly as syntax analysis takes place.

The parser will stop its task when a syntactical error or a misspelled or unrecognized token is encountered. It should not attempt to correct it.
In some cases a constructive error message\footnote{The efficiency of this facility will depend on the time left to correctly implement it} will be
printed to the user.

The parser we will implement will follow the widely used LL(1) parsing method also known as {\it predictive recursive descent} parsing. The parser
will use top-down parsing following the grammars defined in both the MathML and OpenMath standards and will only need to look at the next token in
the token stream ~\cite{compilers}.


\section{Possible Future Extensions}

The desire to extend the OpenMath/MathML interface to include new functions or adapt to changes was paramount in the design process. Here we would
like to mention some possible extensions which could be added in the future.

\begin{description}

\item[Evaluation of expressions:] It should be possible to extend the interface to allow evaluation of OpenMath and MathML expressions using
REDUCE's computational power. This extension is possible because the intermediate representation was designed imitating REDUCE's internal
representation of expressions. Without difficulty a procedure could be implemented which would evaluate an intermediate representation expression
by mapping it to REDUCE's internal representation. The appropriate modules would then print out the evaluated intermediate representation as MathML
or OpenMath.

\item[Separate Interfaces to REDUCE:] For the same reasons as expressed above, it is possible to modify the interface so it offers a MathML to
REDUCE interface and/or an OpenMath to REDUCE interface. This would allow a REDUCE user to import and export MathML or OpenMath expressions
separately for use in calculations or for transmission on the Internet to other applications.

\item[Interfaces to other Representations:] Because the system architecture is designed around the intermediate representation, it is possible to
implement modules which transform the intermediate representation into other representations such as \LaTeX, \TeX, HTML, or WEB\TeX, thus allowing
translation from MathML or OpenMath to any of the mentioned representations.

\end{description}


mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/analysis.tex0000644000175000017500000011156011526203062024337 0ustar  giovannigiovanni\chapter{OpenMath/MathML Translation} \label{analysis}

MathML and OpenMath are closely related, serving a similar purpose of
conveying mathematics across different applications. The aim of this
analysis is to relate MathML and OpenMath to illustrate their
similarities and differences. We intend it to be application
independent, highlighting the problems arising when developing programs
translating MathML to OpenMath and vice versa.

As is stated in the OpenMath standard \cite{openmathspec}, OpenMath
objects have the expressive power to cover all areas of computational
mathematics. This is certainly not the case with MathML. However,
MathML was designed to be displayed on any MathML compliant renderer.  
The possibility to translate between them would allow OpenMath objects
to be displayed, and MathML objects to have a wider semantic scope. But is
a translation possible?

OpenMath and MathML have many common aspects. Some features of the
standards help facilitate the translation, mainly that the structure of
both standards is very similar.  They both use prefix operators and are
XML \cite{xml}\index{XML} based. They both construct their objects by
applying certain rules recursively. Such similarities facilitate
mapping across both standards.

Because both standards are XML based, their syntax is governed by the
rules of XML syntax. In other words, the details of using tags,
attributes, entity references and so on are defined in the XML language
specification. By complying with the XML standard it is possible to use
generic XML generators and validators. These can be programmed for the
application being developed, or existing ones can be used.

Finally, OpenMath has specific content dictionaries\index{content
dictionaries} mirroring MathML's semantic scope, which permit a
straightforward mapping between both recommendations. Since both
standards are simply different ways of representing mathematics,
designed with translation in mind, mapping one to the other is
certainly possible.

We shall look at all the areas of both recommendations where
differences occur and how they pose difficulties to designing a
translator. It is important to understand how objects are constructed
and what they represent. We will then discuss how functions and
operators are applied on their arguments. There are various specific
structural differences between both standards which need to be properly
understood; we will attempt to explain these differences and offer a
method of translation for each one. We will also discuss how MathML
supports extensibility and to what extent it is possible to implement
such extensibility to accept new OpenMath symbols. To finish we will
give an explanation of how to handle the translation problem.

Before we start our analysis, it is important that we define a few
terms related to our analysis. We also encourage the reader to have a
look at the standards in order to better appreciate this analysis.  
MathML and OpenMath {\it
objects}\index{MathML!objects|textbf}\index{OpenMath!objects|textbf}
convey the meaning of a mathematical expression and are represented as
labelled trees. An object can also be called an {\it expression}. A
{\it symbol}\index{OpenMath!symbol|textbf} in OpenMath is used to
represent a mathematical concept. For instance {\it plus} or {\it max}
are considered symbols. We call {\it elements} the words enclosed
within \texttt{$<$$>$} such as \texttt{$<$apply$>$} or
\texttt{$<$OMA$>$}. Elements enclose other XML data called their
`content' between a `start tag' (sometimes called a `begin tag') and an
`end tag', much like in HTML\index{Html}. There are also `empty
elements' such as \texttt{$<$plus/$>$}, whose start tag ends with /$>$
to indicate that the element has no content or end tag.

\section{Constructing Objects} \label{constructors}

Constructing objects in MathML and OpenMath is done in similar ways.
MathML uses elements termed {\it containers} and OpenMath uses elements
called {\it constructs}.  They are both closely related, and most of
them are easily interchangeable. The nature of the
constructors\index{constructors} in both standards is rather different,
but their usage is the same.

OpenMath objects can be created by applying a symbol onto a series of
arguments.  These are the objects created by {\it application} and are
surrounded by \texttt{$<$OMA$>$\ldots$<$/OMA$>$} elements. In MathML
the approach is different. MathML possesses more constructors and they
are more specific.  It is important to note that OpenMath objects
constructed with the \texttt{$<$OMA$>$} element may translate to
various constructors in MathML.

In OpenMath for instance, defining a list or a matrix would be done by
applying the application constructor on the {\it list} or {\it matrix}
symbol followed by the contents of the list or matrix. In MathML
however, a list would require the \texttt{$<$list$>$$\ldots<$/list$>$}
constructor, and a matrix would need the
\texttt{$<$matrix$>$\ldots$<$/matrix$>$} constructor.

Most OpenMath symbols constructed by application are constructed in
MathML using the {\tt $<$apply$>$} constructor. But there are
exceptions which do not map to {\tt $<$apply$>$} tags. It is important
that all exceptions such as \verb|matrix|, \verb|list|, \verb|set| and
others are determined and that the appropriate MathML constructor is
used when translating. Table \ref{const} shows what possible MathML
constructors {\tt $<$OMA$>$} can map to.

OpenMath objects can also be constructed using the
\texttt{$<$OMBIND$>$} element.  This consists in binding a symbol to a
function with zero or more bound variables.  MathML does not have an
equivalent, and so symbols which use the {\it binding} construct in
OpenMath, like {\tt lambda} or {\tt forall}, may have different ways of
being constructed in MathML. {\tt lambda} uses a specific constructor
in MathML, whereas {\tt forall} uses the {\tt $<$apply$>$} construct.
It is very important in order to ensure proper translation, to
determine which OpenMath symbols use the binding constructor and what
their MathML equivalent is.

There are objects constructed by attributing a value to an object.
These are objects constructed by {\it attribution} and employ the {\tt
$<$OMATTR$>$} elements. MathML also allows objects to possess
attributed values called attributes. The translation is
straightforward.

There are other constructors which we do not mention in more detail
because there exists a direct mapping between both standards. This is
the case of \texttt{$<$OMI$>$, $<$OMF$>$}, \texttt{$<$OMV$>$}
\texttt{$<$cn$>$} and \texttt{$<$ci$>$}. Table \ref{const} shows the
relation between them.

\begin{table} 

\begin{center}

\begin{tabular}{|l|l|} 
\hline 
\label{const}

{\bf OpenMath} 			&	{\bf MathML} \\ \hline

\texttt{$<$OMA$>$}		&	\texttt{$<$interval$>$, $<$set$>$, $<$list$>$, $<$matrix$>$,}\\
				&	\texttt{$<$vector$>$, $<$apply$>$, $<$lambda$>$, $<$reln$>$}. \\
\texttt{$<$OMATTR$>$}		&	{\it attributes associated to a tag} \\
\texttt{$<$OMI$>$, $<$OMF$>$}	&	\texttt{$<$cn$>$} \\
\texttt{$<$OMV$>$}		&	\texttt{$<$ci$>$} \\
\texttt{$<$OMSTR$>$}		&	{\it not supported} \\
\texttt{$<$OMBIND$>$}		&	{\it not supported} \\
{\it not supported}		&	\texttt{$<$declare$>$} \\

\hline

\end{tabular}

\end{center}     
\caption{Relation between constructors} 

\end{table}     

\section{Elements and Functions}
\label{funcs}

MathML has a classification\footnote{MathML standard section 4.2.3}
which categorises elements according to the number of arguments they
accept and the types of these arguments.  This classification can be
summarised for our purpose into the following:

\begin{description}

\item[unary elements] accepting 1 argument

\item [binary elements] accepting 2 arguments

\item [nary elements] accepting 3 or more arguments

\item [operators:] elements whose arguments are given following a
specific syntax. This includes symbols such as {\tt int, sum, diff,
limit, forall} and a few others.

\end{description}

This classification is not explicitly stated in the OpenMath standard
but can also be used since OpenMath symbols fit well into these
categories. By gathering OpenMath and MathML symbols into these defined
groups according to their syntax, it is possible to define specific
translating procedures which deal with all symbols in one group in the
same way.

For instance one procedure could parse through any unary function by
reading in the symbol and then the one argument. Printing out unary
functions would be done by one procedure which would output the symbol
in MathML or OpenMath followed by that one argument.

The advantages of this classification are that it greatly simplifies
the translation.  Parsing and generation of all symbols would then be
the task of a few generic procedures. However, symbols contained in the
{\it operators} group require more attention, since they have different
ways of reading in arguments. Specific procedures need to be
implemented for such cases.  We will discuss these in more detail
later.

\subsection{The Scope of Symbols} \label{scope}

When dealing with a function or an operator in mathematics, it is
important that its scope is well defined. MathML and OpenMath both
specify the scope\index{scope} of an operator by enclosing it with its
arguments inside opening and closing tags. In MathML, the opening and
closing tags \texttt{$<$apply$>$} are employed, and in OpenMath one
uses the opening and closing tags \texttt{$<$OMA$>$}.

However, OpenMath's grammar as it is defined in the OpenMath standard
in section 4.1.2 can produce OpenMath objects where the scope of an
operator is ambiguous, in which case a parser would have great
difficulties validating the syntax for translation. Let us illustrate
this problem with the two OpenMath expressions in figure \ref{omscope} which are grammatically
correct.


\begin{figure}[h]

\begin{tabular}{ l l }

{\bf Example 1}					& {\bf Example 2}\\
						& \\
\verb||					&\verb||\\  
\verb| |					&\verb| |\\
\verb|   |		&\verb|   | \\
\verb|   |		&\verb|   | \\
\verb|   |				&\verb|     | \\
\verb|   |				&\verb|     | \\
\verb|   |				&\verb|     | \\
\verb|   6|				&\verb|   | \\
\verb| |					&\verb|   | \\
\verb||					&\verb|   6| \\
						&\verb| | \\
						&\verb|| \\

\end{tabular}  

\caption{The importance of defining scopes}
\label{omscope}
\end{figure}  

Example 2 demonstrates how the use of \verb|| tags help define
clearly the scope of each operator. A parser can then without
difficulty interpret the expression and translate it correctly. Example
1, on the other side, shows how insufficient use of \verb|| tags
can lead to ambiguous expressions both for automatic parsers and
humans.

MathML is stricter when defining the scopes of operators. Every
operator must be enclosed with its own \verb|| tags. This
difference between both standards is source of problems. The expression
in Example 1 does not allow the scopes of the operators to be
determined with accuracy, and so an equivalent MathML expression cannot
be produced.

When developing an OpenMath/MathML translator, it is important to
specify that operator scopes in OpenMath must be accurately defined, or
else translation to MathML is not possible. The use of \verb||
tags must be imposed.

\section{Differences in Structure}

There are MathML and OpenMath elements which require special attention.
Mainly because there are elements constructed differently in MathML as
they are in OpenMath and because some elements have no equivalent in
both standards. Such cases must be well understood before starting to
implement any translator. We shall look at these cases and propose a
reliable method for overcoming the differences and implementing an
efficient solution. We will mention bound variables, element attributes
and constants representation.

There exist elements in both standards which represent the same
mathematical concept, but where the syntactical structure is different.
The following list shows these elements: {\it matrices, limits,
integrals, definite integrals, differentiation, partial
differentiation, sums, products, intervals, selection from a vector}
and {\it
selection from a matrix}.

\subsection{Selector functions and Matrices}

Let us first look at: {\it matrices, selection from a matrix} and {\it
selection from a vector}.  These elements exist in both
recommendations, but differ syntactically.

Selection from a matrix and from a vector is done by the
\verb|| element in MathML and by the symbols {\it
vector\_selector} and {\it matrix\_selector} in OpenMath. Because
MathML uses the same element to deal both with matrices and vectors, it
is necessary for the parser to determine what the arguments of the
expression are before finding the correct equivalent OpenMath. If the
expression has a matrix as argument, then {\it matrix\_selector} is the
correct corresponding symbol. If the argument is a vector then the
corresponding symbol is {\it vector\_selector}.

It is important to note as well the order of arguments. The MathML
\verb|| tag first takes the vector or matrix object, and
then the indices of selection. In OpenMath it is the other way around.
First the indices of selection are given and then the object.

Another element where differences in structure are important is the
matrix element.  OpenMath has two ways of representing matrices. One
representation defined in the \verb|"linalg1"| CD and the other defined
in the \verb|"linalg2"| CD. A matrix is defined as a series of
matrixrows in \verb|"linalg1"|, exactly as in MathML. For such
matrices, translation is straightforward.

However, \verb|"linalg2"| defines a matrix as a series of matrix
columns. This representation has no equivalent in MathML. It is
important that a translator is capable of understanding both
representations in order to offer correct translation.

When dealing with a \verb|"linalg2"| matrix, a procedure can be
implemented which given the matrix columns of a matrix, returns a
series of matrix rows representing the same matrix. From these matrix
rows, a MathML expression can be generated.

\subsection{Bound Variables} \label{boundvars}

The remaining elements {\it limit, integrals, definite integrals,
differentiation, partial differentiation, sums, and products} have a
similar structure and can be treated in a similar way when translating.  
Following the classification in section \ref{funcs} these elements go
in the {\it operators} group.

What characterises these elements is that in MathML they all specify
their bound variables explicitly using the \verb|| construct.
However, in OpenMath, the bound variables are not explicitly stated.
OpenMath expressions are the result of applying the symbol on a lambda
expression. In order to determine the bound variable the parser must
retrieve it from the lambda expression. Let us illustrate this problem
by contrasting two equivalent expressions on figure \ref{bound}


\begin{figure}[h]
\begin{tabular}{ l l }    

{\bf OpenMath} 						& {\bf MathML}\\
							& \\
\verb|| 						&\verb|| \\
\verb| | 						&\verb| | \\
\verb|  |    		&\verb|   | \\
\verb|  |						&\verb|     i| \\
\verb|   | 	&\verb|   | \\
\verb|    1 |				&\verb|   | \\
\verb|    10 |				&\verb|     0| \\
\verb|  |						&\verb|   | \\
\verb|  |					&\verb|   | \\
\verb|   |		&\verb|     100| \\
\verb|   |					&\verb|   | \\
\verb|     |				&\verb|   | \\
\verb|   |					&\verb|       x| \\
\verb|   |						&\verb|       i| \\	
\verb|    |		&\verb|   | \\
\verb|     1 |				&\verb| |  \\
\verb|    |				&\verb||   \\
\verb|   |					& \\
\verb|  |					& \\
\verb| |						& \\
\verb||						& \\

\end{tabular}  

\caption{Use of bound variables}
\label{bound}

\end{figure}

In MathML, the index variable is explicitly stated within the
\verb|| tags. It is part of the \verb|| syntax and is
obligatory.  In OpenMath, the {\it sum} symbol takes as arguments an
interval giving the range of summation and a function. Specifying the
bound variable is not part of the syntax. It is contained inside the
lambda expression. This same difference in structure exists with the
other operators mentioned above.

When translating any of these elements, it is necessary to support
automatic generation and decoding of lambda expressions. Thus when
going from OpenMath to MathML, the bound variable and the function
described by the lambda expression need to be extracted to generate
valid MathML.

When passing from MathML to OpenMath, the variable contained inside the
\verb|| tags and the function given as argument would have to be
encoded as a lambda expression. This is possible for all MathML
expressions of this type, and correct OpenMath is simple to produce.

Thus by retrieving bound variable information from OpenMath lambda
expressions, it is possible to translate to MathML. But OpenMath
grammar does not impose the use of lambda expressions to define bound
variables. Because of this flexibility, it is possible to construct
OpenMath expressions which cannot be translated to MathML by an
automatic translator. If one looks at the \verb|"calculus1"| CD, the
OpenMath examples of {\it int} and {\it defint} do not specify their
variable of integration. A parser would not determine the variables of
integration and an equivalent MathML expression would not be possible.

This is a problem for an OpenMath/MathML translator with no easy
solution. A parser intelligent enough to extract the correct bound
variables of an expression is very difficult to implement. We recommend
that OpenMath expressions which do not specify all the necessary
information for translation are ignored. The use of lambda expressions
should be required.

\subsection{Intervals}

Some operators require an interval to be given specifying the range
within which a variable ranges. The {\it sum} or {\it product} operator
are some good examples. They both take as argument the interval giving
the range of summation or multiplication. Other operators accepting 
intervals in some cases are {\it int} and {\it condition}.

Both in MathML and OpenMath these operators define ranges with
intervals, but differently. OpenMath defines intervals using specific
interval defining symbols found in the {\tt interval1} CD. MathML can
use either the interval element or the tags \verb|| and
\verb||. These two tags do not have an OpenMath equivalent
and so when encountered must be transformed into an interval. This is
not difficult since one must simply merge the lower and upper limits
into the edges of an interval.

\subsection{MathML attributes}

There are OpenMath symbols which map to the same MathML element, and
are only distinguished by the attributes characterising the MathML
element. A MathML element which illustrates this is \verb||.
The interval element in MathML has a \verb|closure| attribute which
specifies the type of interval being represented. This attribute takes
the following values:  \verb|open|, \verb|closed|, \verb|open_closed|,
\verb|closed_open|.  Depending on the attribute value, a different
OpenMath symbol will be used in the translation. The following example
illustrates how one element with different attribute values maps to
different OpenMath symbols.

\begin{center}

\begin{verbatim}
      

      
\end{verbatim}

\end{center}

\noindent are equivalent and so are

\begin{center}

\begin{verbatim}
      

      
\end{verbatim}

\end{center}

When a translator encounters such elements, it is necessary that the
MathML elements generated posses these attributes, or else semantic
value is lost. Table \ref{allatts} shows the relation between all
MathML elements whose attributes are of importance and their equivalent
OpenMath symbols.

\begin{table}[h]
\begin{center}

\begin{tabular}{|l|l|l|} \hline   
\label{allatts}

{\bf MathML element}  		&{\bf Attribute values}			& {\bf 
OpenMath symbol} \\ \hline
\verb||		&{\it default}				& {\it interval} \\
				&\verb|closure="open_closed"|		& {\it interval\_oc}	\\	
				&\verb|closure="closed_open"|		& {\it interval\_co}	\\	
				&\verb|closure="closed"|		& {\it interval\_cc}	\\	
				&\verb|closure="open"|			& {\it interval\_oo}	\\ \hline
\verb||		&{\it default}				& {\it above} 	\\
\verb||				&\verb|type="above"|			& {\it above}	\\
\verb||				&\verb|type="below"|			& {\it below}	\\
\verb||				&\verb|type="both_sides"|		& {\it null}	\\ \hline
\verb||			&{\it default}				& {\it set}	\\
				&\verb|type="normal"|			& {\it set}	\\
				&\verb|type="multiset"|			& {\it multiset}	\\
\hline

\end{tabular}

\end{center}     
\caption{Equivalent OpenMath symbols to the different attribute values of MathML 
elements }

\end{table}     

\subsection{MathML constants}

In MathML, constants are defined as being any of the following:  
\verb|e|, \verb|i|, \verb|pi|, \verb|gamma|, \verb|infinity|,
\verb|true|, \verb|false| or \verb|not a number (NaN)|. They appear
within \verb|| tags when the attribute \verb|type| is set to
\verb|constant|. For instance $\pi$ would be represented in MathML as:

\begin{verbatim}
        pi
\end{verbatim}

In OpenMath, these constants all appear as different symbols and from
different CDs.  Hence, we face a similar problem as we did with MathML
attributes. The \verb|| tag with the attribute set to
\verb|constant| can map to different OpenMath symbols.

It is important that the translator detects the use of the
\verb|constant| attribute value and maps the constant expressed to the
correct OpenMath symbol.

MathML also allows to define Cartesian complex numbers and polar
complex numbers.  A complex number is of the form two real point
numbers separated by the \verb|| tag. For instance $3+4i$ is
represented as:

\begin{verbatim}
         3  4 
\end{verbatim}

OpenMath is more flexible in its definition of complex numbers. The
real and imaginary parts, or the magnitude and argument of a complex
number do not have to be only real numbers. They may be variables. This
allows OpenMath to represent numbers such as $x+iy$ or $re^{i\theta}$
which cannot be done in MathML.

So how should one map such an OpenMath expression to MathML? Because
there is no specific construct for such complex numbers, the easiest
way is to generate a MathML representation using simple operators. The
two expressions in figure \ref{compls} are equivalent and illustrate how a
translator should perform:

\begin{figure}[h]

\begin{verbatim}
      
        
          
          
          
        
       
\end{verbatim}

\begin{verbatim}
       
          
              x 
             
                
                    y 
                    &imaginaryi; 
                
             
          
        
\end{verbatim}

\caption{How to translate complex numbers}
\label{compls}
\end{figure}

The problem is the same when representing rationals, since OpenMath
allows variables to be used as elements of a rational number, whereas
MathML only allows real numbers.

\subsection{{\tt partialdiff} and {\tt diff}}

In both standards it is possible to represent normal and partial
differentiations. But the structures are different. Let us first look
at {\tt diff}. In MathML, it is possible to specify the order of the
derivative. In OpenMath, differentiation is always of first order.  
The trouble here is translating MathML expressions where the order of
derivation is higher than one. There is no equivalent representation in
OpenMath.

What can be done to overcome this discrepancy is to construct an
OpenMath expression differentiated as many times as is specified by the
MathML derivation order. For instance, when dealing with a MathML
second order derivative, the equivalent OpenMath expression could be a
first order derivative of a first order derivative.  This will surely
generate very verbose OpenMath in cases where the order of derivation
is high, but at least will convey the same semantic meaning and
surmounts OpenMath's limitation.

The case of partial differentiation is complicated. The representations
in both standards are very different. In MathML one specifies all the
variables of integration and the order of derivation of each variable.
In OpenMath one specifies a list of integers which index the variables
of the function. Suppose a function has bound variables $x$, $y$ and
$z$. If we give as argument the integer list $\{1,3\}$ then we are
differentiating with respect to $x$ and $z$. The differentiation is of
first order for each variable.

Translating partial differentials from OpenMath to MathML is simple,
because the information conveyed by the OpenMath expression can be
represented without difficulty by MathML syntax. However the other way
around is difficult. Given OpenMath's limitation of only allowing first
order differentiation for each variable, many MathML expressions which
differentiate with respect to various variables and each at a different
degree cannot be translated. We recommend that such MathML expressions
are discarded by the translator.

\section{Elements not Supported by both Standards}

There are some elements which have no equivalent in both standards.
These are mainly the MathML elements \verb|| and
\verb||and the OpenMath {\it matrixrow} and {\it matrixcolumn}
symbols.


\subsection{{\tt $<$condition$>$}}

The \verb|| element is used often throughout MathML and is
necessary to convey certain mathematical concepts. There is no direct
equivalent in OpenMath, making translation impossible for certain
expressions.

The \verb|| element is used to define the `such that'
construct in mathematical expressions.  Condition elements are used in
a number of contexts in MathML. They are used to construct objects like
sets and lists by rule instead of by enumeration. They can be used with
the {\tt forall} and {\tt exists} operators to form logical
expressions. And finally, they can be used in various ways in
conjunction with certain operators. For example, they can be used with
an int element to specify domains of integration, or to specify
argument lists for operators like min and max.

The example in figure \ref{forall} represents $\{\forall x | x<9:
x<10\}$ and shows how the \verb|| tags can be used in a
MathML expression. This MathML expression has no OpenMath equivalent
because OpenMath does not allow to specify any conditions on bound
variables.


\begin{figure}[h]

\begin{verbatim}
         
        
          
             x 
          
          
            
               x 
               9       
            
          
          
             x 
             10       
          
        
         
\end{verbatim}

\caption{Use of {\tt $<$condition$>$}}
\label{forall}

\end{figure}


The \verb|| tags are used in the following MathML elements:
{\it set, forall, exists, int, sum, product, limit, min} and {\it max}.
In all of these elements except {\it limit}, the use of
\verb|| tags makes translation impossible.

The case of {\it limit} is different because OpenMath does allow
constraints to be placed on the bound variable; mainly to define the
limit point and the direction from which the limit point is approached.

\subsection{{\tt $<$declare$>$}}

The \verb|| construct is used to associate specific properties
or meanings with an object. It was designed with computer algebra
packages in mind. OpenMath's philosophy is to leave the application
deal with the object once it has received it. It is not intended to be
a query or programming language. This is why such a construct was not
defined. A translator should deny such MathML expressions.

\subsection{{\it matrixrow, matrixcolumn}}

In the MathML specification it is stated that {\it `The matrixrow
elements must always be contained inside of a matrix'}. This is not the
case in OpenMath where the {\it matrixrow} symbol can appear on its
own.  A matrix row encountered on its own has no MathML equivalent.
However, when it is encountered within a matrix object, then
translation is possible.

As we mentioned earlier, it is possible to translate a matrix defined
with matrixcolumns to MathML. However, if a matrixcolumn is found on
its own it does not have a MathML equivalent.


\section{Extensibility}

OpenMath already possesses a set of CDs covering all of MathML's
semantic scope. These CDs belong to the MathML CD Group.  It is clear
that these CDs must be understood by an OpenMath/MathML interface.  
There are as well a few other symbols from other CDs which are not in
the MathML CD Group but can be mapped such as matrices defined in {\tt
"linalg2"}.

But OpenMath has the capability of extending its semantic scope by
defining new symbols within new content dictionaries\index{content
dictionaries}. This facility affects the design of any OpenMath
compliant application. When it comes to translating to MathML, it is
necessary that newly defined symbols are properly dealt with. A
translator should have the ability to recognise any symbol with no
mapping to MathML.

But how do we deal with most symbols outside the MathML CD Group? Or
with new symbols which will continue to appear as OpenMath evolves? How
do we map them to MathML?

MathML, as any system of content markup\index{content markup}, requires
an extension mechanism which combines notation with semantics.
Extensibility in MathML is not as efficient as in OpenMath, but it is
possible to define and use functions which are not part of the MathML
specification. MathML content markup specifies several ways of
attaching an external semantic definition to content objects.

Because OpenMath contains many elements which have no equivalent in
MathML, and because OpenMath can have new CDs amended to it, we will
need to use these mechanisms of extension. The \verb||
element is used in MathML to bind a semantic definition with a symbol.
An example taken from the MathML specification~\cite{mathml} section
5.2.1\footnote{CHECK!!!!{\tt
http://www.w3.org/WD$-$MathML2$-$19991222/chapter5.html\#mixing:parallel}}
shows how the OpenMath `rank' operator (non existent in MathML) can be
encoded using MathML. The MathML encoding of rank is shown in figure
\ref{rank}:

\begin{figure}[h]
\begin{verbatim}
      	
        
          
              
                rank
                
                  
                
              
            
            
              
                u
              
              v
            
          
          1
        
      
\end{verbatim}
\caption{Encoding of OpenMath symbol `rank' in MathML}
\label{rank}
\end{figure}

It shows that an OpenMath operator without MathML equivalent is easily
contained within \verb|| tags and can be applied on any
number of arguments.

This method works well when dealing with operators constructed by {\it
application} (between \verb|| tags), because MathML also
constructs expressions by application (between \verb|| tags). It
is assumed they take any number of arguments. However, OpenMath can
also construct expressions by binding symbols to their arguments. As we
described earlier (section \ref{constructors}), this method has no
equivalent in MathML.

So what happens when a new symbol is encountered which is constructed
by binding in OpenMath? Enveloping the new symbol inside
\verb|| tags will produce an incorrect translation.

It is first necessary to determine if the new symbol encountered is
constructed by binding or not. In order to do so, a file describing the
new symbol specifying these details could be read in by the translator.
This file could be the CD where the symbol is defined. But
unfortunately CDs are written in a human readable way, and there is no
way a program could determine the construction method of a particular
symbol or the number and type of arguments it takes.

One would need to read in the STS file of a symbol. But the best way
would be by checking the tag preceding the new symbol given by the
OpenMath input. If it was \verb|| then we are sure this symbol
is constructed by binding. Nonetheless, accurate mapping would be
impossible. As we have seen before, MathML only offers extensibility
constructing operators by application. It is not possible to define new
containers, new types, or new operators constructed differently such as
those constructed by binding.

While it is possible to define certain new symbols in MathML, the
advantages of OpenMath extensibility would create problems for a
translator to MathML. This is why it is stated in the OpenMath standard
in section 2.5 that {\it `it is envisioned that a software application
dealing with a specific area of mathematics declares which content
dictionaries\index{content dictionaries} it understands'}. A MathML
translator deals with the area of mathematics defined by MathML and
should understand all CDs within the MathML CD Group. Any other symbols
will be properly translated if they are enclosed inside \verb||
tags.

Extensibility is limited by the extension mechanisms offered by MathML.

\section{How to Handle the Translation problem}

Although there are surely many ways to tackle the translation problem,
there are a few requirements which must be respected by any
OpenMath/MathML translator. Mainly that content dictionaries and
symbols are dealt with correctly during translation in both directions.

In OpenMath, symbols always appear next to the content
dictionary\index{content dictionary} they belong to. The \verb||
element always takes two attributes: the symbol's name and the
symbol's corresponding CD. Two symbols with the same name coming from
different CDs are considered to be different.

When parsing OpenMath, a translator must ensure that the symbols read
belong to the correct CDs, if not it should conclude the symbol has a
meaning it does not understand and deal with it accordingly. Because
an OpenMath/MathML translator will understand all MathML related CDs,
symbols encountered are considered valid if they come from this CD
group. Symbols with the same name, but from unknown CDs should be
enclosed within \verb|| tags when possible.

We face the same requirement when generating OpenMath. All OpenMath
symbols output from the translator must appear next to their correct
CDs. If we are translating the MathML element \verb||, the
corresponding OpenMath symbol {\it plus} must appear next to the
\verb|arith1| CD.

This requires a translator to keep a database relating each understood
symbol with its CD. This database must allow the translator to detect
unknown symbols, or to accept some symbols from different CDs with the
same name which have MathML equivalents. This is the case of {\it
matrix} which belongs to various CDs (\verb|linalg1|, \verb|linalg2|) as do
the symbols {\it in}, {\it inverse}, {\it setdiff}, {\it vector}, {\it
arcsinh} to name a few.

These symbols belonging to various CDs pose a problem when
translating from MathML to OpenMath. Which CD do we choose? {\it
inverse} for instance belongs to {\it fns1} and {\it arith2}.
Priority should be given to the CD belonging to the MathML CD group.
If both CDs belong to the MathML then common sense should guide which
CD to place. It is up to the designer.

An OpenMath/MathML interface must be very rigorous when dealing with
content dictionaries. Any mistake may produce invalid OpenMath or
reject valid OpenMath expressions.

\section{Conclusion}

It is clear now that a translation is possible. Putting apart the
difficulties described in this analysis, their are many similarities
between both standards. As we have seen, expressions are constructed
similarly and the application of functions is practically identical.

However, the various differences of structure can limit the power of a
translator in some situations. Mainly when translating partial
differentiations or applying conditions to bound variables.

The design of any translator requires a good understanding of both
standards and how they represent mathematical concepts. The
information described in this document will guide the design of an
OpenMath/MathML translator.

mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathml_1.red0000644000175000017500000021570611526203062024177 0ustar  giovannigiovannimodule mathml;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version 5 August 1999

% Modified by FJW, 22 May 2000
% Modified by Winfried Neun , 1 August 2000

fluid '(atts ch cha char count file!* pvar rdci!* rdelems!* rdlist!*
        rdreln!* space safe_atts temp2 unary!* !*mathprint
        consts_compl consts_int flagg found_compl found_int consts_mat_int
        consts_mat_compl found_mat_compl found_mat_int indent);

%Declaration of some switches.

%_mathml_ allows all output to be printed in mathml.
%_both_ allows all output to be printed in mathml and in normal reduce
%output.

load assist;
load matrix;


global '(f);

global '(!*mathml);
switch mathml;
global '(!*both);
switch both;
global '(!*web);
switch web;

LISP (FILE!*:=nil);
!*mathml:=nil;
!*both:=nil;
!*web:=nil;

off both;
off mathml;
off web;

%Declaration of a series of lists which contain the function to be executed
%when the token (cadr) is found.

%Tokens to be found between  tags.

RDci!*:='
((!&imaginaryi!; . (consts 'i))
(!&ii!; . (consts 'i))
(!&exponential!; . (consts 'e))
(!&ee!; . (consts 'e))
(!&pi!; . (consts 'p))
(!&differentiald!; . (const 'd))
(!&dd!; . (consts 'd)));

%Tokens to be found between  tags.

RDreln!*:=
'((tendsto . (tendstoRD ))
(eq!/ . (relationRD 'eq))
(neq!/ . (relationRD 'neq))
(lt!/ . (relationRD 'lt))
(gt!/ . (relationRD 'gt))
(geq!/ . (relationRD 'geq))
(leq!/ . (relationRD 'leq))
(in!/ . (inRD ))
(notin!/ . (notinRD ))
(subset!/ . (relationRD 'subset))
(prsubset!/ . (relationRD 'prsubset))
(notprsubset!/ . (notprsubsetRD ))
(notsubset!/ . (notsubsetRD )));

%Tokens to be found between  tags.

RDlist!*:=
'((divide!/ . (divideRD))
(setdiff!/ . ( setdiffRD))
(select!/ . (selectRD))
(transpose!/ . ( transposeRD))
(determinant!/ . ( determinantRD))
(fn . ( applyfnRD))
(union!/ . (unionRD))
(intersect!/ . (intersectionRD))
(implies!/ . ( impliesRD))
(not!/ . ( notRD))
(xor!/ . (xorRD))
(or!/ . (orRD))
(and!/ . (andRD))
(mean!/ . ( meanRD))
(var!/ . ( varRD))
(sdev!/ . ( sdevRD))
(moment!/ . ( momentRD))
(median!/ . ( medianRD))
(sin!/ . ( sinRD))
(sec!/ . ( secRD))
(sinh!/ . ( sinhRD))
(sech!/ . ( sechRD))
(arcsin!/ . ( arcsinRD))
(cos!/ . ( cosRD))
(csc!/ . ( cscRD))
(cosh!/ . ( coshRD))
(csch!/ . ( cschRD))
(arccos!/ . ( arccosRD))
(tan!/ . ( tanRD))
(cot!/ . ( cotRD))
(tanh!/ . ( tanhRD))
(coth!/ . ( cothRD))
(arctan!/ . ( arctanRD))
(abs!/ . ( absRD))
(ln!/ . ( lnRD))
(plus!/ . ( plusRD))
(times!/ . ( timesRD))
(power!/ . ( powerRD))
(exp!/ . ( expRD))
(factorial!/ . ( factorialRD))
(quotient!/ . ( quotientRD))
(max!/ . ( maxRD))
(min!/ . ( minRD))
(minus!/ . ( minusRD))
(rem!/ . (remRD))
(conjugate!/ . ( conjugateRD))
(root!/ . ( rootRD))
(gcd!/ . ( gcdRD))
(log!/ . (logRD))
(int!/ . (intRD))
(sum!/ . ( sumRD))
(limit!/ . (limitRD))
(condition . (conditionRD))
(product!/ . (productRD))
(diff!/ . (diffRD))
(partialdiff!/ . (partialdiffRD)));

RDelems!* :=
'((reln . (relnRD !/reln ""))
(set . ( setRD !/set ""))
(fn . ( fnRD !/fn ""))
(declare . ( declareRD !/declare ""))
(list . ( listRD !/list ""))
(matrix . ( matrixRD !/matrix ""))
(cn . ( cnML !/cn ""))
(ci . ( ciML !/ci ""))
(lambda . ( lambdaRD !/lambda "")));

unary!* :=
'((determinant . (unary determinant))
(transpose . (unary transpose))
(sum . (sum_prodML sum))
(prod . (sum_prodML product))
(df . (dfML nil))      % FJW: (df.(dfML df))
(impart . (complpart impart))
(repart . (complpart repart))
(abs . (unary abs))
(gcd . (n_nary gcd))
(set . (setML set))
(factorial . (unary factorial))
(max . (n_nary max))
(min . (n_nary min))
(cos . (unary cos))
(sin . (unary sin))
(sec . (unary sec))
(cosh . (unary cosh))
(cot . (unary cot))
(coth . (unary coth))
(csch . (unary csch))
(acos . (trigML acos))
(asin . (trigML asin))
(atan . (trigML atan))
(sech . (unary sech))
(sinh . (unary sinh))
(tan . (unary tan))
(tanh . (unary tanh))
(csc . (unary csc))
(quotient . (quotientML nil))
(plus . (n_nary plus))
(times . (n_nary times))
(expt . (n_nary power))
(sqrt . (sqrtML sqrt))
(log . (unary log))
(logb . (log_baseML logb))
(log10 . (log_baseML log10))
(ln . (unary ln))
(eq . (reln eq))
(neq . (reln neq))
(gt . (reln gt))
(lt . (reln lt))
(geq . (reln geq))
(leq . (reln leq))
(union . (sets union))
(intersection . (sets intersection))
(in . (reln in))
(notin . (reln notin))
(subset . (reln subset))
(prsubset . (reln prsubset))
(notsubset . (reln notsubset))
(notprsubset . (reln notprsubset))
(setdf . (sets setdf))
(arbcomplex . (printsub2cadr arbcomplex))
(arbint . (printsub2cadr arbint))
(mat . (matrixML nil))
(minus . (minusML nil))
(int . (integralML nil))
(equal . (equalML nil))
(list . (listML nil)));






%The next three functions are the lexer. When called they returns the next
%mathml token in the input stream.

symbolic procedure lex();
begin scalar token;
 token:=nil;
 if atts neq nil then safe_atts:=atts;
 atts:=nil;
 if ch neq !$EOF!$ then <<
  if ch=space then while (ch:=readch())=space do
  else
   if ch='!< then char:=get_token()
   else char:=get_content();
   if char neq nil then
   <<  count:=count+1;
       token:=reverse char;
       char:=butes(token);
%By decomenting the following line, the tokens read in are one by one
%printed onto the output stream.
%       print char;
       attributes(char,token)>>
    else lex(); >>
end;


symbolic procedure get_token();
begin scalar d;
 d:=();
 while (ch:=readch()) neq '!> do d:=cons(ch,d);
 return cons('!$,d);
end;


symbolic procedure get_content();
begin scalar d;
 d:=();
 while (ch:=readch()) neq '!< AND ch neq !$EOF!$
do
    if ch neq space AND id2int(ch)>10 then
d:=cons(ch,d);
 if d neq nil then d:=cons('!$,d);
 return d;
end;


%This function will search the list of attributes _att_ for the attribute
%named _key_

symbolic procedure search_att( att, key);
begin scalar l, stop,d;
 l:=nil;
 d:=();
 stop:=0;
 att:= find(att, key);
 if att neq '(stop) then
 <<
 while (car att='! ) do att:=cdr att;
 if (car att = '!=) then
   <<
     att:=cdr att;
     while (car att='! ) do att:=cdr att;
     if (car att='!") then
      << att:=cdr att;
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
      >>
      else
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
   >>
 else
 errorML(compress key,1);
 if car d='!" then d:=cdr d;
 return reverse d
 >>
end;

symbolic procedure find(fatt, fkey);
begin;
return if fkey= '() then if fatt neq nil then cdr fatt else '(stop)
          else
          find(member(car fkey, fatt), cdr fkey);
end;

symbolic procedure attributes(a,b);
begin scalar l;
 l:=length a;
 for a:=1:l do b:=cdr b;
 while (car b='! ) do b:=cdr b;
 if b neq '(!$) then  atts:=b;
end;


symbolic procedure butes( str );
%Removes all attributes to a token.
begin cha;
cha:=car str;
return if (cha='!  OR cha='!$) then <<'(); >>
        else  cons(car str, butes cdr str);
end;


%This is the MAIN function. It is given the name of a file which contains
%the mathml input. It launches the program by calling parseML().

symbolic procedure mml(ff);
begin;
 FILE!*:=t;
 ff:= open(ff, 'input);
 ff:= rds(ff);
 parseML();
 close rds ff;
 FILE!*:=nil;
end;

%This function starts the parsing mechanism, which is a recursive descent
%parsing.


symbolic procedure parseML();
begin scalar res, vswitch;
 res:=nil;
 vswitch:=nil;
%  FLUID '(safe_atts char ch atts count temp space temp2);
 space:=int2id(32);
 count:=0;
 ch:=readch();
 temp2:=nil;
 lex();
 if char='(m a t h) then
     res:=mathML()
   else errorML("",2);
 lex();
 if char='(!/ m a t h) then
   terpri()
   else errorML("",19);

 return algebraic res;
end;

%The two next functions differ in that one of them parses from the next
%token onwards, and the other one from the actual token onwards.


symbolic procedure mathML();
begin scalar a;
 a:=nil;
 lex();
 return sub_math();
end;

symbolic procedure mathML2();
begin scalar a;
 a:=nil;
 return sub_math();
end;

%Parses all tokens which legally follow a mathml token.

symbolic procedure sub_math();
   begin scalar a,aa;
      if char='(a p p l y)
        then <    ",3)>>
       else if char='(v e c t o r)
        then <",2)>>
       else if (aa := assoc(compress!* char, RDelems!*))
        then <>;
      return a
   end;

symbolic procedure compress!* u;
   begin scalar x;
      if digit car u then return compress u;
      for each j in u do
         if j eq '!/ or j eq '!- or j eq '!; or j eq '!.
            then x := j . '!! . x
          else x := j . x;
      return intern compress reversip x
   end;


%The next two functions parse the  and  tokens and extracts its
%content to be used by the function calling it. It will have different
%behaviours according to the type of the  data.

symbolic procedure cnML();
begin scalar type, sep, tt,aa;
%Must check that what is being returned is an int.
 type:=nil; sep:=nil;
 type:=search_att(atts, '(t y p e));
 lex();
 tt := char;
 lex();


 if type='(c o n s t a n t) then
 <<
   if (aa:=assoc(intern compress tt, RDci!*)) then
     return apply(first cdr aa, rest cdr aa) >>;

 if IDP compress tt then errorML(compress tt, 16);

 if type=nil then return compress tt;
 if member(type, '((r e a l) (i n t e g e r))) neq nil then
    return compress tt;
 if member(type, '((r a t i o n a l) (c o m p l e x !- c a r t e s i a n)
                   (c o m p l e x !- p o l a r))) neq nil then
   << sep:=sepRD();
      if type='(r a t i o n a l) then <>
      else
      if type='(c o m p l e x !- c a r t e s i a n) then
        << lex();return comp2(compress tt, sep) >>else
      if type='(c o m p l e x !- p o l a r) then
        <> >>
   >>;
end;


symbolic procedure ciML();
begin scalar test, type,aa, tt;
 aa:=nil; type:=nil; test:=nil;
 type:=search_att(atts, '(t y p e));
 lex();
 tt := char;
 lex();
  << test:=compress tt;
     if NUMBERP test then errorML(test, 4);
     test:=intern test;
     return test>>
end;

%returns the algebraic value of the constant values.

algebraic procedure consts(c);
begin;
 if c=i then return i;
 if c=d then return d;
 if c=e then return e;
 if c=p then return pi;
end;

%Constructs a complex number.

algebraic procedure comp2(a,b);
begin;
 return a+b*i;
end;

%Returns the two values separated by a  tag.

symbolic procedure sepRD();
begin scalar p1, p2;
 p1:=nil; p2:=nil;
 if char neq '(s e p !/) then errorML("",2);
 lex();
 p2:=compress char;
 return p2;
end;

%Creates a vector by using function matrix_row.

symbolic procedure vectorRD();
begin scalar a;
 a:=nil;
 a:=matrixrowRD();
 a:=lisp aeval list('mat, a);
 return a;
end;

%The following functions construct the matrix from the mathml information.

symbolic procedure matrixRD();
begin scalar b1, b2, stop;
 stop:=0;
 b1:='();
 b2:=nil;
 while stop=0 do
 <<
   lex();
   if char='(m a t r i x r o w) then
    <",2)>>
   else stop:=1
  >>;
 return aeval cons ('mat ,b1);
end;

symbolic procedure matrixrowRD();
begin scalar a;
 a:=nil;
 a:=mathML();
 return if a=nil then nil
        else cons(a, matrixrowRD());
end;

%returns a lambda function constructed from the information supplied.

symbolic procedure lambdaRD();
begin scalar b1, b2;
 lex();
 b1:=bvarRD();
 b1:=car b1;
 b2:=mathML();
 lex();
 return algebraic( (lambda  b1; b2) b1 );
end;

%returns a set constructed from the information supplied.

symbolic procedure setRD();
begin scalar setvars;
 atts:='(t y p e != s e t !$);
 setvars:= cons('list,stats_getargs());
 setvars:=cons(car setvars, norepeat(cdr setvars));
 return setvars;
end;

%This function will keep one copy only of any repeating elements

symbolic procedure norepeat(args);
begin;
return if args=nil then nil else
 if length args=1 then list car args
 else append(list car args, norepeat(delall(car args, cdr args)));
end;

%This function will delete all occurences of element x in list l

symbolic procedure delall(x,l);
if l=nil then nil
else if x=car l then delall(x, cdr l)
     else append(list car l ,delall(x, cdr l));

%returns a list constructed from the information supplied.

symbolic procedure listRD();
begin scalar setvars, lorder, tmp;
 lorder:=search_att(atts, '(o r d e r));
 atts:='(t y p e != l i s t !$);
 setvars:= cons('list,stats_getargs());
 tmp := setvars;
 if lorder='(l e x i c o g r a p h i c) then
   setvars:=algebraic sortlist (setvars, lexog);
 if lorder='(n u m e r i c) then
  setvars:=algebraic sortlist (setvars, numer)
 else
   setvars:=algebraic sortlist (setvars, pred);
 if setvars = nil then setvars:= tmp;
 return setvars;
end;

%Defines the predicate function used by function _sortlist_. Sortlist comes
%from package assist, and its documentation can be found in assist's
%documentation

%This one will sort all elements in numerical and alphanumerical order

symbolic procedure pred(u,v);
begin;
return if NUMBERP u and NUMBERP v then <> else
 if IDP u and IDP v then <>
 else if NUMBERP u and IDP v then <> else
if IDP u and NUMBERP v then <>;
end;

%This one sorts in alphanumerical order

symbolic procedure lexog(u,v);
begin;
 return if IDP u and IDP v then <>
 else t;
end;

%This one sorts in numerical order

symbolic procedure numer(u,v);
begin;
 return if NUMBERP u and NUMBERP v then <>
 else t;
end;

%Makes the next token in the inputstream an operator.

symbolic procedure fnRD();
begin scalar b1;
 lex();
 if char neq '(c i) then errorML(compress char,20)
 else b1:= mathML2();
 if ATOM b1 then algebraic operator b1;
 lex();
 return b1;
end;

%Reads the declare construct and sets the value of the given variable to
%the given value.

symbolic procedure declareRD();
begin scalar b1, b2, flagg, at;
 at:=atts;
 flagg := nil;
 b1:=mathML();
 clear b1;
 clear reval b1;
 lex();
 if at neq nil then
   put(b1, 'type, search_att(at,'(t y p e)));

 if search_att(at, '(t y p e)) = '(v e c t o r) then
   flagg:=t;

 if char='(!/ d e c l a r e) then return nil;
 b2 :=mathML2();
 if get(b1, 'type)='(f n) then
  << algebraic operator b1>>;
 if flagg = t then setk(b1, b2)
 else algebraic set(b1, b2);
 lex();
 return nil;
end;

%This function will determine if the next token is a valid token following
%an apply token. It then calls the appropriate function if succesful.

symbolic procedure applyML();
   begin scalar aa;
      lex();
      if (aa := assoc(compress!* char, RDlist!*))
        then return apply(first cdr aa, rest cdr aa)
       else if char='(i d e n t !/) or char='(c o m p o s e !/)
        then return nil
       else if char='(i n v e r s e !/) then return t
       else errorML(compress!* char, 17)
   end;

%Reads the next two elements and returns their setdifference.

symbolic procedure setdiffRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 and b2=reval b2 then return list('setdiff,b1, b2)
else
 if b1=reval b1 then return list('setdiff, b1, reval b2) else
 if b2=reval b2 then return list('setdiff, reval b1, b2) else
 return append(list('set), setdiff(reval b1, reval b2));
end;

%Reads through a select construct and acts accordingly.

symbolic procedure selectRD();
begin scalar a1, res;
 a1:=stats_getargs();
 if caar a1='mat then res:=mat_select(a1);
 if caar a1='list then res:=list_select(a1);
 if ATOM res then return res;
 return cons('list, res);
end;

symbolic procedure mat_select(a1);
begin
 if length car a1=2 then return nth(cadar a1, cadr a1)
 else
 if length a1=2 then return nth(cdar a1, cadr a1);
 if length a1=3 then return nth(nth(cdar a1, caddr a1), cadr a1);
end;

symbolic procedure list_select(a1);
begin scalar b1;
 b1:=cdar a1;
 return nth(b1, cadr a1);
end;


%Returns the transpose of the element contained in the transpose tags.

symbolic procedure transposeRD();
begin scalar a, res;
 a:=mathML();
 res:=algebraic(tp a);
 lex();
 return res;
end;

%Returns the determinant of the given element.

symbolic procedure determinantRD();
begin scalar a, res;
 a:=mathML();
   res:=alg_det a;
 lex();
 return res;
end;

algebraic procedure alg_det(a);
begin;
return det a;
end;

%Takes the given function name, makes it an operator, and then
%applies it to the arguments specified in the mathml input.

symbolic procedure applyfnRD();
begin scalar b1, b2, c1;
 b1:=nil; b2:=nil; c1:=nil;
 b1:=fnRD();
 b2:=stats_getargs();
 b2:=cons(b1, b2);
 c1:=algebraic b2;
 return  c1;
end;

%Returns the union of the elements specified.

symbolic procedure unionRD();
begin scalar b1, a1, a2,type,res;
 b1:=stats_getargs();
 a1:=car b1;
 a2:=cadr b1;
 if PAIRP a1 AND PAIRP a2 then <<
   type := car a1;
   a1:=cons('list, eval_list cdr a1);
   a2:=cons('list, eval_list cdr a2);
   res:=algebraic union(a1,a2);
 >>
 else <<
  type := 'list;
  res := cons('list,cons(a1,list a2));
 >>;
 return cons(type, cdr res);
end;

%Returns the intersection of the elements specified.

symbolic procedure intersectionRD();
begin scalar b1, a1, a2,type,res;
 b1:=stats_getargs();
 a1:=car b1;
 a2:=cadr b1;
 if PAIRP a1 AND PAIRP a2 then <<
   type := car a1;
   a1:=cons('list, eval_list cdr a1);
   a2:=cons('list, eval_list cdr a2);
   res:=algebraic intersect(a1,a2);
 >>
 else <<
  type := 'list;
  res := cons('list,cons(a1,list a2));
 >>;
 return cons(type, cdr res);
end;


%Takes all the arguments in a list, and forces an evaluation on them if they can be
%evaluated.

symbolic procedure eval_list(args);
begin;
 return if args=nil then nil
 else cons(reval car args, eval_list(cdr args));
end;

%Takes all the arguments in a list of sets, and evaluates them if they can
%be evaluated.

symbolic procedure eval_list_sets(args);
begin scalar ab;
 return if args=nil then nil
 else <>
        else ab:=reval car args;
        cons(ab, eval_list_sets(cdr args))>>;
end;

%Sets global variable temp2 to 'stop if an evaluatable element is found in
%list args.

symbolic procedure constants(args);
begin scalar b1;
if args neq nil then b1:=car args;
 return if args=nil then nil
   else <> else
 if type='(quote lt) then <> else
 if type='(quote gt) then <> else
 if type='(quote subset) then <> else
 if type='(quote prsubset) then <> else
 if type='(quote geq) then <> else
 if type='(quote leq) then <>;

 return if a=t then t
        else if a=nil then 'false else a;
end;

%The following functions do all the necessay actions in order to evaluate
%what should be by the tags.

symbolic procedure notsubsetRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 AND b2=reval b2 then
    return list('notsubset, b1, b2);
 if b1= reval b1 then
    return list('notsubset, b1,cons ('set, cdr reval b2));
 if b2= reval b2 then
    return list('notsubset, cons('set,cdr reval b1), b2);
 if intersection(cdr reval b1,cdr reval b2)=nil then
    return t
 else
    return nil;
end;

symbolic procedure notprsubsetRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 AND b2=reval b2 then
    return list('notprsubset, b1, b2);
 if b1= reval b1 then
    return list('notprsubset, b1,cons('set, cdr reval b2));
 if b2= reval b2 then
    return list('notprsubset, cons('set,cdr reval b1), b2);
 if reval b1 = reval b2 then return t;
 if intersection(cdr reval b1,cdr reval b2)=nil then return t else
return nil;
end;


symbolic procedure subsetRD(sets);
begin scalar args,val;
 args:=sets;
 val:=t;
 while (length args > 1) do
  << if NUMBERP reval car args then
       errorML(reval car args,5);
     if car args = reval car args OR cadr args = reval cadr args then
     << args:='();
        val:=cons('subset, eval_list_sets(sets))>>
     else
     << val:=AND(val, alg_subset(reval car args, reval cadr args));
        args:=cdr args >>
  >>;
 return val;
end;



symbolic procedure alg_subset(a,b);
begin;
  if a=b then return t
  else
  if setdiff(a,b)=nil then return t else return nil;
end;


symbolic procedure prsubsetRD(sets);
begin scalar args, val;
 val:=t;
 while (length args > 1) do
  << if car args = reval car args OR cadr args = reval cadr args then
     << args:='();
        val:=cons('prsubset, eval_list_sets(sets))>>
     else
     << val:=AND(val, alg_prsubset(reval car args, reval cadr args));
        args:=cdr args >> >>;
 return val;
end;

symbolic procedure alg_prsubset(a,b);
begin;
  if setdiff(a,b)=nil then return t else return nil;
end;

symbolic procedure inRD();
begin scalar b1,b2;
 b1:= mathML();
 b2:= mathML();
 lex();
 if b2 = reval b2 AND ATOM b2 then
 <<
    if b2='n then <>;
    if b2='r then <>;
    return list('in, reval b1, b2)
 >>;
 if MEMBER(reval b1,reval  b2) neq nil then return t
   else return nil;
end;

symbolic procedure notinRD();
begin scalar b1,b2;
 b1:= mathML();
 b2:= mathML();
 lex();
 if b2 = reval b2 AND ATOM b2 then
 <<
    if b2='N then if FIXP b1 then return nil else return nil;
    if b2='R then if NUMBERP b1 then return nil else return nil;
    return list('notin, reval b1, b2)>>;
 if MEMBER(reval b1,reval  b2) neq nil then return nil
   else return t;
end;

symbolic procedure alg_eq(args);
begin;
 constants(args);
 return alg_eq2 eval_list args;

end;

symbolic procedure alg_eq2(args);
begin;
 return if length args=1 then t
        else if (reval car args eq reval cadr args) then
                alg_eq2(cdr args);
end;

symbolic procedure alg_neq(args);
begin;
 constants(args);
 return alg_neq2(eval_list(args));
end;

symbolic procedure alg_neq2(args);
begin;
 return if length args=1 then t
        else if (reval car args neq reval cadr args) then
                alg_neq2(cdr args);
end;

symbolic procedure alg_lt(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_lt2(eval_list(args));
end;

symbolic procedure alg_lt2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <>
 else errorML("",6);
end;



symbolic procedure alg_gt(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_gt2(eval_list(args));
end;

symbolic procedure alg_gt2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   < reval cadr args) then
       alg_gt2(cdr args)
     else nil>>
 else errorML("",6);
end;

symbolic procedure alg_geq(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_geq2(eval_list(args));
end;

symbolic procedure alg_geq2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <= reval cadr args) then
       alg_geq2(cdr args)
     else nil>>
 else errorML("",6);
end;

symbolic procedure alg_leq(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_leq2(eval_list(args));
end;

symbolic procedure alg_leq2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <>
 else errorML("",6);
end;

%Interprets the  tag when used in the  tag.

symbolic procedure tendstoRD();
begin scalar attr, arg1 ,arg2;
 if intersection(atts, '(t y p e)) neq nil then
    attr:=search_att(atts, '(t y p e))
 else attr:=nil;
 arg1:=mathML();
 arg2:=mathML();
 lex();
 return list (attr,arg2);
end;

%Returns the limit of the information given. Uses the Reduce package
%LIMITS.

symbolic procedure limitRD();
begin scalar var, condi, low, exp;
 lex();
 if char='(b v a r) then
  << var:=bvarRD();
     if eqn(cadr var,1) then var:=car var
      else
         errorML("",8);
     lex()>>
 else var:=nil;

 if char='(l o w l i m i t) then
  << low:=lowlimitRD();
     lex()>>
 else if char='(c o n d i t i o n) then
     <<      condi:=conditionRD();
        if char neq '(!/ c o n d i t i o n) then
        errorML("",2);
        lex()>>
      else condi:=nil;

 exp:=mathML2();
 lex();

 if condi=nil then
   return alg_limit(exp, var, low, 'norm);

 if low=nil then
   if car condi='(a b o v e) then
        return alg_limit(exp, var, cadr condi, 'plus)
   else return alg_limit(exp, var, cadr condi, 'min);

end;

algebraic procedure alg_limit(exp, var, tendto, type);
begin;
 if type='norm then return limit(exp, var, tendto);
 if type='plus then return limit!+(exp,var,tendto);
 if type='min then return limit!-(exp,var,tendto);
end;

%Returns the sum.

symbolic procedure sumRD();
begin scalar svar, low, upper, express, res;
 svar:=nil; low:=nil; upper:=nil; express:=nil; res:=nil;
 lex();
 if char='(b v a r) then
      <",7);
        lex()>>
 else errorML("",9);

 if char='(l o w l i m i t) then
     << low:=lowlimitRD();
        lex();
          if char='(u p l i m i t) then
             <<      upper:=upperlimitRD();
                lex()>>
        else errorML("",10) >>
 else if char='(i n t e r v a l) then
     <<      res:=intervalRD();
        lex();
        low:=car res;
        upper:=cadr res >>
      else errorML(" or ",11);

 express:=mathML2();
 lex();

 return algebraic sum(express, svar, low, upper);

end;

algebraic procedure alg_sum( low, upper, formu);
begin scalar temp,var2;
 algebraic;
 temp:=0;
 var2:=symbolic svar;
 for tt:=low:upper do
  << set(var2,tt);
     temp:=temp+formu;
     clear symbolic svar;
     var2:=symbolic svar>>;
 symbolic;
 return temp;
end;


%Returns the product.

symbolic procedure productRD();
begin scalar pvar, low, upper, pexpress, res;
 lex();
 if char='(b v a r) then
      <",12);
        lex()>>
 else errorML("",9);
 if char='(l o w l i m i t) then
     << low:=lowlimitRD();
        lex();
          if char='(u p l i m i t) then
             <<      upper:=upperlimitRD();
                lex()>>
        else errorML("",10)>>
 else if char='(i n t e r v a l) then
     <<      res:=intervalRD();
        lex();
        low:=car res;
        upper:=cadr res >>
      else errorML(" or ",11);

 pexpress:=mathML2();
 lex();

 return algebraic prod(pexpress, pvar, low, upper);


end;



algebraic procedure alg_prod( low, upper, formu);
begin scalar temp,var2;
 algebraic;
 temp:=1;
 var2:=symbolic pvar;
 for tt:=low:upper do
  << set(var2,tt);
     temp:=temp*formu;
     clear symbolic pvar;
     var2:=symbolic pvar>>;
 symbolic;
 return temp;
end;

%Returns the partial derivative.

symbolic procedure partialdiffRD();
begin scalar res, bvar, express;
 lex();
 bvar:=getargsRD();
 express:=mathML2();
 lex();
 res:=differentiate(express, bvar);
 return res;
end;

symbolic procedure differentiate(express, bvar);
begin scalar temp,diffed;
return
  if eqn(length bvar,0) then express
   else
    <>;
end;


%This function reads through the a series of  tags and extracts the
%variables.

symbolic procedure getargsRD();
begin scalar a;

%Dont forget. This function leaves the file pointer on
%the next token after the last bvar. So you need to use mathML2 after.

if char='(b v a r) then
<>;
end;

%Returns the derivative.

symbolic procedure diffRD();
begin scalar bvar, degree, express, res;
 lex();
 if char='(b v a r) then
  <>
 else <>;
 express:=mathML2();
 lex();
 res:=alg_df(express, bvar, degree);
 return res;
end;

algebraic procedure alg_df(a,b,c);
begin;
 return df(a,b,c);
end;

%This function will calculate the integral. Takes in the expression, then
%the bound variable, and finally the limits if they exist.

symbolic procedure intRD();
begin scalar bvar, low, upper, int, exp;
 lex();
 if char='(b v a r) then
      <>
   else errorML("",14);


 if char='(l o w l i m i t) then <>
   else low:=nil;

 if char='(u p l i m i t) then <>
   else upper:=nil;

 if char='(i n t e r v a l) then
   <>
   else int:=nil;


 exp:=mathML2();
 lex();
 return alg_int(exp, bvar, low, upper);
end;

algebraic procedure alg_int(exp, bvar, low, upper);
begin scalar res;
 if (low='nil) AND (upper=nil) then res:= int(exp, bvar)
  else res:= int(exp,bvar,low,upper);
return res;
end;

%Here we parse bound variables. The function reads the variable as well as
%the degree if there is one.

symbolic procedure bvarRD();
begin scalar var, deg;
 lex();
 if char='(d e g r e e) then
     errorML("",15);
 var:=mathML2();
 lex();
 if char='(d e g r e e) then
   << deg:=mathML();
      lex();
      if char neq '(!/ d e g r e e) then
        error("",2);
      lex()>>
 else deg:=1;
 if char='(!/ b v a r) then return list(var, deg)
   else errorML("", 2);
end;

%Functions used to parse the limits of an integral, sum, or product.

symbolic procedure lowlimitRD();
begin scalar lowlimit;
 lowlimit:=mathML();
 lex();
 if char='(!/ l o w l i m i t) then return lowlimit
   else errorML("", 2);
end;

symbolic procedure upperlimitRD();
begin scalar upperlimit;
 upperlimit:=mathML();
 lex();
 if char='(!/ u p l i m i t) then return upperlimit
   else errorML("", 2);
end;


symbolic procedure intervalRD();
begin scalar l,u;
 l:=mathML();
 u:=mathML();
 lex();
 if char='(!/ i n t e r v a l) then return list(l,u)
   else errorML("", 2);
end;

%Following functions just evaluate calculus functions.

symbolic procedure lnRD();
begin scalar a;
 a:=alg_ln(mathML());
 lex();
 return a;
end;

algebraic procedure alg_ln(a);
begin;
  return ln(a);
end;

symbolic procedure logRD();
begin scalar a, a1, base;
 base:=nil;
 lex();
 if char='(l o g b a s e) then
    <>;
  a1:=mathML2();
  lex();
  a:=alg_log(a1, base);
  return a;
end;

algebraic procedure alg_log(a, base);
begin;
 if base=nil then return log(a)
 else
  return logb(a, base);
end;

symbolic procedure logbaseRD();
begin scalar a;
 a:=mathML();
 lex();
 if char='(!/ l o g b a s e) then return a
   else errorML("",2);
end;


symbolic procedure conjugateRD();
begin scalar a;
  a:= alg_conj(mathML());
  lex();
  return a;
end;

algebraic procedure alg_conj(a);
begin;
 return conj(a);
end;


symbolic procedure minusRD();
begin scalar c,b;
  c:=mathML();
  b:=mathML();
  if b=nil then c:=alg_minus(c)
   else <<
        c:=alg_difference(c,b);
        lex()>>;
  return c;
end;

algebraic procedure alg_minus(a);
begin;
 return -a;
end;

algebraic procedure alg_difference(a,b);
begin;
 return difference(a,b);
end;


symbolic procedure absRD();
begin scalar a;
  a:=alg_abs(mathML());
  lex();
  return a;
end;

algebraic procedure alg_abs(a);
begin;
 return abs(a);
end;

symbolic procedure rootRD();
begin scalar b,deg;
  lex();
  if char='(d e g r e e) then
  << deg:=mathML();
     lex();
     if char neq '(!/ d e g r e e) then
       error("","Syntax ERROR: Missing end tag");
     lex()>>
  else deg:=2;

  b:=mathML2();
  lex();
  return alg_root(b,deg);
end;

algebraic procedure alg_root(b,a);
begin;
return b**(1/a);
end;


symbolic procedure remRD();
begin scalar a, a1, a2;
  a1:=mathml();
  a2:=mathml();
  a:=alg_remainder(a1, a2);
  lex();
  return a;
end;

algebraic procedure alg_remainder(a,b);
begin;
  return remainder(a,b);
end;

symbolic procedure factorialRD();
begin scalar a;
  a:=alg_factorial(mathML());
  lex();
  return a;
end;

algebraic procedure alg_factorial(a);
begin;
  return factorial(a);
end;

symbolic procedure expRD();
begin scalar a;
  a:= alg_exp(mathML());
  lex();
  return a;
end;

algebraic procedure alg_exp(a);
begin;
  return exp(a);
end;

symbolic procedure quotientRD();
begin scalar a, a1, a2;
  a1:=mathML();
  a2:=mathML();
  if IDP reval a1 OR IDP reval a2 then a:=alg_quotient(a1,a2)
  else
  a:= (reval a1)/(reval a2);
  lex();
  return a;
end;

algebraic procedure alg_quotient(a,b);
begin;
  return a/b;
end;

symbolic procedure divideRD();
begin scalar a, a1, a2;
  a1:=mathML();
  a2:=mathML();
  if a2 = 0 then errorML("", 21);
  a:=alg_divide(a1,a2);
  lex();
  return a;
end;

algebraic procedure alg_divide(a,b);
begin;
  return quotient(a,b);
end;

symbolic procedure gcdRD();
begin scalar c1;
 c1:=stats_getargs();
 constants(c1);
 if temp2='stop then
   << temp2:=nil;
      return cons('gcd, eval_list(c1))>>
 else return gcdRD2(c1);
end;

symbolic procedure gcdRD2(args);
begin scalar a;
a:=reval car args;
return if length args=1 then  car args
        else alg_gcd2(a, gcdRD2(cdr args));
end;

algebraic procedure alg_gcd2(a , b);
begin;
return gcd(a,b);
end;

symbolic procedure minRD();
begin scalar a;
a:=mathML();
return if a=nil then nil
         else alg_min(a,minRD());
end;

algebraic procedure alg_min(a,b);
begin;
 return min(b,a);
end;

symbolic procedure maxRD();
begin scalar a;
a:=mathML();
return if a=nil then nil
         else alg_max(a,maxRD());
end;

algebraic procedure alg_max(a,b);
begin;
  return max(a,b)
end;

lisp operator plusRD;

symbolic procedure plusRD();
begin scalar abc1;
abc1:=nil;
abc1:=mathML();
return if abc1 = nil then 0
        else alg_plus(abc1, plusRD());
end;

algebraic procedure alg_plus(acb1,b);
begin;
return acb1+b;
end;


symbolic procedure timesRD();
begin scalar a;
a:=nil;
a:=mathML();
return if a=nil then 1
  else alg_times(a, timesRD());
end;

algebraic procedure alg_times(a,b);
begin;

if b=i then return a*i;
return a*b;
end;



symbolic procedure powerRD();
begin scalar var,power;
 var:=mathML();
 power:=mathML();
 lex();
 return alg_expt(var,power);
end;

algebraic procedure alg_expt(a,b);
begin;
return expt(a,b);
end;

%The following function is in charge of providing the correct error message
%as well as closing the input/output stream, and exiting the program
%correctly.

symbolic procedure errorML( str, msg );
begin;
 terpri();
 princ "***** Error in token number ";
 princ count;
 princ " (<";
 princ compress char;
 princ ">)";
 terpri();
 if msg=1 then
  << princ "Needed attribute";
     princ str;
     princ " and none was found.">> else
 if msg=2 then
  << princ "Missing tag: ";
     princ str >> else
 if msg=3 then
  << princ "Undefined error!";
     princ " Token number "; princ sub1 count;
     princ " probably mispelled or an";
     princ "ambiguous or erroneous use of .">> else
 if msg=4 then
  << princ "Numerical constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=5 then
  << princ "All arguments must be sets";
     terpri();
     princ str;
     princ " does not represent a set.">> else
 if msg=6 then
  << princ "Non-numeric argument in arithmetic.">> else
 if msg=7 then
  << princ "The degree quantifier is of no use in the sumation";
     princ "operator.">> else
 if msg=8 then
  << princ "The degree quantifier is of no use in the limit";
     princ " operator.">> else
 if msg=9 then
  << princ "The index of sumation has not been specified.";
     terpri();
     princ "Please use  tags to specify an index.">>
 else
 if msg=10 then
  << princ "Upperlimit not specified.">> else
 if msg=11 then
  << princ "Upper and lower limits have not been specified.">> else
 if msg=12 then
  << princ "The degree quantifier is of no use in the product";
     princ " operator.">> else
 if msg=13 then
  << princ "The degree quantifier is not allowed in the integral";
     princ " operator.">> else
 if msg=14 then
  << princ "Variable of integration not specified.";
     princ "Please use  tags to specify variable.">>
 else
 if msg=15 then
  << princ "Incorrect use of  tags.";
     princ " Correct use:";
     terpri();
     princ
" bound_var  [ degree ] ">> else
 if msg=16 then
  << princ "Symbolic constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax:  ";
     princ str;
     princ " ";
     terpri();
     princ "or  ";
     princ "if using constants ⅈ, ⅈ, ⅇ, ⅇ or π."
  >> else
 if msg=17 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Token not allowed within  tags.";
     terpri();
     princ "Might be: <"; princ str; princ "/>.">> else
 if msg=18 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Not allowed within  tags.">> else
 if msg=19 then
  << princ "Undefined error!";
     princ " Token "; princ sub1 count;
     princ " is probably mispelled";
     terpri();
     princ "or unknown, ";
     princ "or the  tag is missing">> else
 if msg=20 then
  << princ "Function ";
     princ str;
     princ "()";
     princ " was not enclosed in  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=21 then
  << princ "Error, division by 0">>;


 terpri();
 if FILE!*=t then close rds f;
 FILE!*:=nil;
 rederr("");
 rederr("");
 terpri();
end;

%Following function are in charge of parsing statistics related mathml.

symbolic procedure meanRD();
begin scalar b, size, args;
 args:=stats_getargs();
 b:=0;
 size:=length( args );
    while (args neq ()) do
        << b:=alg_plus(b, car args);
           args:= cdr args >>;
 return alg_quotient(b,size);
end;

symbolic procedure sdevRD(  );
begin scalar args,mean,b,size;
 args:=stats_getargs();
 mean:=alg_mean( args );
 size:=length(args);
 while(args neq ()) do
   << b:=alg_plus(b, alg_expt(alg_difference(car args, mean),2));
      args:=cdr args; >>;
 return b;
end;

symbolic procedure varRD( );
begin scalar args;
 args:=stats_getargs();
 return alg_expt(sdev( args ), 2);
end;

symbolic procedure medianRD( );
begin scalar args, siz, si;
 args:=stats_getargs();
 args:=cons('list, args);
 args:=sortl(args);
 args:=cdr args;
 si:=length args;
 siz:=si/2;
 if remainder(si,2)=0 then
return alg_quotient(alg_plus(nth(args,siz),nth(args,(siz+1))),2)
 else return nth(args, siz);
end;

algebraic procedure sortl(args);
begin scalar rr;
 rr:=sortlist(args, pred);
 if rr=nil then return sortnumlist(args)
 else return rr;
end;

symbolic procedure momentRD( );
begin scalar args,size,d,i;
 args:=stats_getargs();
if char='(d e g r e e) then
 <>) where outputhandler!* := nil;
if mode neq 'terpri then
  << % FLUID '(indent, flagg,found_int, found_compl, consts_compl, consts_int);
     % FLUID '(found_mat_int, found_mat_compl, consts_mat_int, consts_mat_compl);
     found_mat_int=0$;
     found_mat_compl=0$;
     indent:=0$
     consts_compl:=()$
     consts_mat_compl:=()$
     consts_int:=()$
     consts_mat_int:=()$
     found_int:=0$
     found_compl:=0$
     flagg:=0$
     if (PAIRP u) then <<
        if !*web=t then printout("");
         indent:=3;

        if ((car u)='setq) then
          <>
        else
           if ((car u)='list) then
             << arbitrary_c( !*a2k u );
                  listML(cdr u)>>
           else
                  if ((car u)='mat) then
                << arbitrary_c( u );
                     matrixML(cdr u)>>
              else
                     if ((car u)='!*sq) then
                      << arbitrary_c(PREPSQ (cadr u));
                       expression(PREPSQ (cadr u))>>
                 else expression(u);

             indent:=indent-3;
             close_forall();
             indent:=0;
             printout( "" );
             if !*web=t then princ(""" HEIGHT=300 WIDTH=500>");
             terpri()
        >>
     else
        if (ATOM u) then <<
           if !*web=t then printout("" );
           indent:=3;
           expression( u );
           indent:=0;
           printout( "" );
           if !*web=t then princ(" "" HEIGHT=300 WIDTH=500>");
           terpri() >>
  else ; >> >>;


%Prints out vectors.

symbolic procedure vectorML( elem );
begin;
   printout("");
   indent:=indent+3;
   multi_elem(car elem);
   indent:=indent-3;
   printout("")
end;

%Following functions print out matrices.

symbolic procedure matrixML( elem );
begin;
  if length elem=1 then vectorML( elem )
  else
  << printout("");
     indent:=indent+3;
     matrix_rows(elem);
     indent:=indent-3;
     printout("")
  >>;
end;

symbolic procedure matrix_rows( elem );
begin;
  if (elem neq()) then
     <<      printout("");
        indent:=indent+3;
        row(car elem);
          indent:=indent-3;
        printout("");
        matrix_rows( cdr elem ); >>
end;

symbolic procedure row( elem );
begin;
  if (elem neq()) then
         << expression(car elem); row(cdr elem);>>
end;

%This function searches for arbitrary integers, or complex in the reduce
%output. If so, it declares these variables in a forall statement.

symbolic procedure arbitrary_c( elem );
begin;
found_int:=nil;
found_mat_int:=nil;
found_compl:=nil;
found_mat_compl:=nil;

if (PAIRP elem) then <<
   if (car elem='mat) then
     << isarb_mat_compl(cdr elem);
        isarb_mat_int(cdr elem)>>
   else
     <<      isarb_compl(elem);
          isarb_int(elem)>>;



  if ((found_compl=1) OR (found_int=1)) then
   << flagg:=1;
      printout( "" );
      indent:=indent+3;
      print_arb_compl(elem);
      print_arb_int(elem);
      printout( "");
      indent:=indent+3;
      if ((found_compl=1) AND (found_int=1)) then
        << printout( "" );
           indent:=indent+3>>
      else
        if ((length consts_compl) > 1) then
          <<  printout( "" );
              indent:=indent+3>>
        else
           if ((length consts_int) > 1) then
             << printout( "" );
                indent:=indent+3>>;


      if (found_compl=1) then
        in_complexML( consts_compl );
      if (found_int=1) then
        in_integerML( consts_int );


      if ((found_compl=1) AND (found_int=1)) then
         << indent:=indent-3;
            printout( "" )>>
      else
          if ((length consts_compl) > 1) then
            << indent:=indent-3;
               printout( "" )>>
          else
              if ((length consts_int) > 1) then
                << indent:=indent-3;
                   printout( "" )>>;

      indent:=indent-3;
      printout( "" )>>;


  if ((found_mat_compl=1) OR (found_mat_int=1)) then
    << flagg:=1;
       printout( "" );
       indent:=indent+3;
       printarb_mat_compl(cdr elem);
       printarb_mat_int(cdr elem);
       printout( "");
       indent:=indent+3;

       if ((found_mat_compl=1) AND (found_mat_int=1)) then
         << printout( "" );
           indent:=indent+3>>
       else
          if ((length consts_mat_compl) > 1) then
            << printout( "" );
               indent:=indent+3>>
          else
             if ((length consts_mat_int) > 1) then
               << printout( "" );
                  indent:=indent+3>>;


       if (found_mat_compl=1) then
          in_complexML( consts_mat_compl );
       if (found_mat_int=1) then
          in_integerML( consts_mat_int );

       if ((found_mat_compl=1) AND (found_mat_int=1)) then
         << indent:=indent-3;
            printout( "" )>>
       else
               if ((length consts_mat_compl) > 1) then
            << indent:=indent-3;
               printout( "" )>>
          else
                 if ((length consts_mat_int) > 1) then
              << indent:=indent-3;
                 printout( "" )>>;

     indent:=indent-3;
     printout( "" )>>;
  >>
end;

symbolic procedure in_complexML( elem );
begin;
  if (elem neq ()) then <<
    printout("");
    indent:=indent+3;
    printsub2( car elem, 'compl );
    printout(" C ");
    indent:=indent-3;
    printout("");
    in_complexML( cdr elem )>>;
end;


symbolic procedure in_integerML( elem );
begin;
  if (elem neq ()) then <<
    printout("");
    indent:=indent+3;
    printsub2( car elem, 'int );
    printout(" N ");
    indent:=indent-3;
    printout("");
    in_integerML( cdr elem )>>;
end;

symbolic procedure close_forall();
begin;
  if (flagg=1) then printout("");
end;

%Prints out setq statements as  statements.

symbolic procedure setqML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  expression(cadr elem);
  expression( caddr elem);
  indent:=indent-3;
  printout( "" );
end;

%Prints out lists.

symbolic procedure listML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  multilists( elem );
  indent:=indent-3;
  printout( "" );
end;

symbolic procedure multilists( elem );
begin;
 if elem neq nil then
  if ((LENGTH elem)=1) then expression (car elem)
    else <>
end;

%This function takes in a reduce expression, and parses it. It also takes
%expressions created by the above program.



symbolic procedure expression( elem );
begin scalar aa;
if (ATOM elem) then f4( elem ) else
if car elem='!:RD!: then <> else
 <<



  if (aa:=assoc(car elem, unary!*)) then <<
    if caddr aa = nil then
      apply(cadr aa, list cdr elem)
    else
      apply(cadr aa, list(cdr elem, caddr aa)) >> else
  if ((car elem)= '!*sq)  then expression (PREPSQ (cadr elem)) else
  operator_fn(elem);>>;
end;

%Prints out sum, or products.

symbolic procedure sum_prodML( elem, tty );
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 printout("");
 indent:=indent+3;
 expression( cadr elem );
 indent:=indent-3;
 printout("");
 printout("");
 indent:=indent+3;
 expression( caddr elem );
 indent:=indent-3;
 printout("");
 printout("");
 indent:=indent+3;
 expression( cadddr elem );
 indent:=indent-3;
 printout("");
 expression car elem;
 indent:=indent-3;
 printout("");
end;

%Prints out derivatives.

symbolic procedure dfml( elem );
begin scalar test;
 test:=cdr elem;
 if length test=1 OR (length test=2 AND NUMBERP cadr test) then
    printout("")
 else
    printout("");
 indent:=indent+3;
 dfargs(cdr elem);                % FJW: two statements swapped
 expression(car elem);
 indent:=indent-3;
 printout("");
end;

symbolic procedure dfargs( elem );
begin;
 if elem neq nil then
   << if length elem>1 then
      <<  if NUMBERP cadr elem then
          <");
            indent:=indent+3;
            expression car elem;
            degreeML(cadr elem);
            indent:=indent-3;
            printout("");
            dfargs(cddr elem)>>
          else
          <");
            indent:=indent+3;
            expression car elem;
            indent:=indent-3;
            printout("");
            dfargs(cdr elem)>>; >>
      else
        << printout("");
            indent:=indent+3;
           expression car elem;
            indent:=indent-3;
           printout("");
           dfargs(cdr elem)>> >>;
end;

%Prints out degree statements.

symbolic procedure degreeML( elem );
begin;
 printout("");
 indent:=indent+3;
 expression( elem );
 indent:=indent-3;
 printout("");
end;



symbolic procedure complpart( elem, tty);
begin;
 printout("<");
 princ tty;
 princ ">";
 indent:=indent+3;
 expression(car elem);
 indent:=indent-3;
 printout("");
end;

%Prints out set theory related functions.

symbolic procedure sets(elem, tty);
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 multi_elem( elem );
 indent:=indent-3;
 printout("");
end;

%Prints out relns.

symbolic procedure reln(elem, tty);
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 multi_elem( elem );
 indent:=indent-3;
 printout("");
end;

%Prints out a set.

symbolic procedure setML( elem );
begin;
  printout("");
  indent:=indent+3;
  multi_elem( elem );
  indent:=indent-3;
  printout("");
end;

%Prints out unknown functions as a function. It prints out all variables
%declared a soperators.

symbolic procedure operator_fn( elem );
begin;
  printout("");
  princ car elem;
  princ "";
  indent:=indent+3;
  multi_args(cdr elem);
  indent:=indent-3;
  printout("");
end;

%Reads through a list and prints out each component.

symbolic procedure multi_args( elem );
begin;
  if  (elem neq ()) then <>
end;

%Prints out all trigonometric functions which have not the same tag name,
%as reduce function.

symbolic procedure trigML(elem, type);
begin;
  printout("");
  if ((type='acos) OR (type='asin) OR (type='atan)) then
    << if (type='acos) then princ "";
       if (type='asin) then princ "";
       if (type='atan) then princ "">>;
  indent:=indent+3;
  expression(car elem);
  indent:=indent-3;
  printout("");
end;

%Prints out all unary functions such as log, or many trig functions.

symbolic procedure unary( elem, type );
begin;
  printout("");
  princ "<";
  princ type;
  princ "/>";
  indent:=indent+3;
  expression(car elem );
  indent:=indent-3;
  printout("");
end;

%Prints out logs with a base.

symbolic procedure log_baseML(elem, type);
begin;
  printout("");
  indent:=indent+3;
  printout("");
  indent:=indent+3;
  if (type='logb) then expression(cadr elem);
  if (type='log10) then f4(10);
  indent:=indent-3;
  printout("");
  expression(car elem);
  indent:=indent-3;
  printout("");
end;

%Prints out equal relns.

symbolic procedure equalML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  expression(car elem);
  expression(cadr elem);
  indent:=indent-3;
  printout( "" );
end;

%Prints out square roots.

symbolic procedure sqrtML( elem , type);
begin;
  printout( "" );
  indent:=indent+3;
  printout( " 2 " );
  expression( car elem );
  indent:=indent-3;
  printout( "" );
end;

%Prints out integrals.

symbolic procedure integralML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  expression (cadr elem);
  indent:=indent-3;
  printout( "" );
  if (length cdr elem >1) then
     << printout("");
        indent:=indent+3;
             expression( caddr elem );
           indent:=indent-3;
             printout("");
             printout("");
             indent:=indent+3;
             expression( cadddr elem );
             indent:=indent-3;
             printout("")>>;
  expression( car elem );
  indent:=indent-3;
  printout( "" );
end;

%Prints out quotients.

symbolic procedure quotientML( elem );
begin;
  if (NUMBERP car elem) AND (NUMBERP cadr elem) then <<
     if !*web=nil then printout(" ")
     else printout(" ");
     princ car elem;
     princ "  ";
     princ cadr elem;
     princ " ">>
  else <<
     printout( "" );
     indent:=indent+3;
     expression( car elem );
     expression( cadr elem );
     indent:=indent-3;
     printout( "" )>>;
end;

%Prints out all n_nary functions.

symbolic procedure n_nary( elem, type );
begin;
  if car elem = 'e AND type = 'power then unary(cdr elem, 'exp)
  else <<
    printout( "" );
    princ "<";
    princ type;
    princ "/>";
    indent:=indent+3;
    multi_elem( elem );
    indent:=indent-3;
    printout( "" )>>
end;

symbolic procedure multi_elem( elem );
begin;
   if ((length elem)=1) then expression( car elem )
       else <>
end;


symbolic procedure minusML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  multiminus( elem );
  indent:=indent-3;
  printout( "" );
end;

symbolic procedure multiminus( elem );
begin;
  expression(car elem);
  if ((length elem)=2) then expression (cadr elem);
end;

%Prints out all pieces of data: i.e terminal symbols.
%They can be numbers, identifiers, or constants.

symbolic procedure f4(exp);
begin;
if (exp='infinity) then
  << if !*web=nil then printout("")
     else printout("");
     princ "∞";
     princ "">>
else <<
  if (exp='e) then
   << if !*web=nil then printout("")
      else printout("");
      princ "ⅇ";
      princ "">>
else <<
   if (exp='i) then
    << if !*web=nil then printout("")
       else printout("");
       princ "ⅈ";
       princ "">>
   else <<
      if (NUMBERP exp) then
                      << printout ""
                                                else princ " type="real">" >>
                            else
                              if (FIXP exp) then <"
                                                  else princ " type="integer">" >>
                                else princ ">";
                         princ exp;
                         princ "">>;
         if (IDP exp) then
                     <<  printout ""
                                              else princ " type="list">">>
                           else
                              if (vectorp exp) then  <"
                                                      else princ " type="vector">">>
                                else princ ">";
                         princ exp;
                         princ "">>;
         >>
      >>
   >>
end;

%Functions used to print out variables with a subscript.

symbolic procedure printsub( subscript, type );
begin;
  printout("");
  indent:=indent+3;
  printout("");
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  if (type='compl) then printout( "c" );
  if (type='int) then printout( "d" );
  printout( "" );
  princ subscript;
  princ "";
  indent:=indent-3;
  printout( "" );
  indent:=indent-3;
  printout("");
  indent:=indent-3;
  printout("");
end;


symbolic procedure printsub2( subscript, type );
begin;
  printout("");
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  if (type='compl) then  printout( "c" );
  if (type='int) then  printout( "d" );
  printout( "" );
  princ subscript;
  princ "";
  indent:=indent-3;
  printout( "" );
  indent:=indent-3;
  printout("");
end;

%Prints out expressions in math form. Plagiarised from reduce code of
%mathprint

symbolic procedure ma_print l;
begin scalar temp;
   temp:=outputhandler!*;
   outputhandler!*:=nil;
   terpri!* nil;
   if !*web=nil then maprin ""
   else maprin "";
   maprin l;
   maprin "";
   terpri!* nil;
   outputhandler!*:=temp;
end;

%Function in charge of doing all printing in order to make sure the
%indentation is always correct.

symbolic procedure printout( str );
begin;
   if !*web = nil then terpri();
   if !*web = nil then for i := 1:indent
      do << princ " " >>;
   if PAIRP str then
    <>
   else princ str;
end;

%Following functions are quite obscure. They find arbitrary constants in
%expressions and matrices. Then record them, and everytime they appear, are
%replaced with a fancy subscripts C, or D.

symbolic procedure issq( elem );
begin scalar value;
 value:=0;
        if (ATOM elem) then value:=0
           else <>
end;

symbolic procedure multi_isarb_compl( elem );
begin;
if (PAIRP elem) then <<
   if (elem=()) then
      else <> >>
end;


symbolic procedure isarb_int( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbint) then found_int:=1
     else  multi_isarb_int(cdr elem);>>
end;

symbolic procedure multi_isarb_int( elem );
begin;
if (PAIRP elem) then <<
   if (elem=()) then
      else <> >>
end;

symbolic procedure print_arb_compl( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbcomplex) then
     << if (xnp(list (cadr elem),consts_compl) eq nil) then
          << printsub(cadr elem, 'compl);
             consts_compl:=cons(cadr elem, consts_compl)>> >>
  else  multi_compl(cdr elem);>>
end;

symbolic procedure multi_compl( elem );
begin;
   if (elem=()) then
      else <>
end;


symbolic procedure print_arb_int( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbint) then
     << if (xnp(list (cadr elem),consts_int) eq nil) then
          << printsub(cadr elem, 'int);
             consts_int:=cons(cadr elem, consts_int)>> >>
  else  multi_int(cdr elem);>>
end;

symbolic procedure multi_int( elem );
begin;
   if (elem=()) then
      else <>
end;

symbolic procedure isarb_mat_int( elem );
begin;
  if (elem neq()) then
    << isarb_row_int(car elem);
       isarb_mat_int( cdr elem ); >>
end;

symbolic procedure isarb_row_int( elem );
begin;
  if (elem neq()) then
         << if (issq(car elem)=1) then
                if (PAIRP (PREPSQ cadr (car elem))) then
                   if (car (PREPSQ cadr (car elem))='arbint) then
                         found_mat_int:=1;
           isarb_row_int(cdr elem);>>
end;


symbolic procedure isarb_mat_compl( elem );
begin;
  if (elem neq()) then
        <<
        isarb_row_compl(car elem);
        isarb_mat_compl( cdr elem ); >>
end;

symbolic procedure isarb_row_compl( elem );
begin;
  if (elem neq()) then
         << if (issq(car elem)=1) then
                if (PAIRP (PREPSQ cadr (car elem))) then
                   if (car (PREPSQ cadr (car elem))='arbcomplex) then
                         found_mat_compl:=1;
           isarb_row_compl(cdr elem);>>
end;

symbolic procedure printarb_mat_compl( elem );
begin;
  if (elem neq()) then
    << printarb_row_compl(car elem);
       printarb_mat_compl( cdr elem ); >>
end;

symbolic procedure printarb_row_compl( elem );
begin scalar value;
  if (elem neq()) then
         << if (issq(car elem)=1) then
              if (PAIRP (PREPSQ cadr (car elem))) then
                << value:=cadr PREPSQ cadr car elem;
                          if (car (PREPSQ cadr (car elem)))='arbcomplex then
                       if (xnp(list (value), consts_mat_compl) eq nil) then
                        << printsub(value, 'compl);
                            consts_mat_compl:=cons(value, consts_mat_compl)>> >>;
           printarb_row_compl(cdr elem);>>
end;


symbolic procedure printarb_mat_int( elem );
begin;
  if (elem neq()) then
        <<
        printarb_row_int(car elem);
        printarb_mat_int( cdr elem ); >>
end;

symbolic procedure printarb_row_int( elem );
begin scalar value;
  if (elem neq()) then
         << if (issq(car elem)=1) then
              if (PAIRP (PREPSQ cadr (car elem))) then
                 << value:=cadr PREPSQ cadr car elem;
                          if (car (PREPSQ cadr (car elem)))='arbint then
                       if (xnp(list (value), consts_mat_int) eq nil) then
                        << printsub(value, 'int);
                            consts_mat_int:=cons(value, consts_mat_int)>> >>;
           printarb_row_int(cdr elem);>>
end;






%Following function is the same as math_ml_printer, just that it prints out
%input given from mml, which reads from files, and not form the reduce
%normal output stream.


symbolic procedure math_ml (u);
  << % FLUID '(indent flagg found_int found_compl consts_compl
     %        consts_int !*mathprint);
     % FLUID '(found_mat_int found_mat_compl consts_mat_int
     %        consts_mat_compl);
     !*mathprint:=0;
     found_mat_int=0$;
     found_mat_compl=0$;
     indent:=0$
     consts_compl:=()$
     consts_mat_compl:=()$
     consts_int:=()$
     consts_mat_int:=()$
     found_int:=0$
     found_compl:=0$
     flagg:=0$
     if (PAIRP u) then <<
        printout("");
         indent:=3;

        if ((car u)='setq) then
          <>
        else
           if ((car u)='list) then
             << arbitrary_c( !*a2k u );
                  listML(cdr u)>>
           else
                  if ((car u)='mat) then
                << arbitrary_c( u );
                     matrixML(cdr u)>>
              else
                     if ((car u)='!*sq) then
                      << arbitrary_c(PREPSQ (cadr u));
                       expression(PREPSQ (cadr u))>>
                 else expression(u);

             indent:=indent-3;
             close_forall();
             indent:=0;
             printout( "" )
        >>
     else
        if (ATOM u) then <<
           printout( "" );
           indent:=3;
           expression( u );
           indent:=0;
           printout( "" )>>
  else ; >>;


%This function executes certain commands when switches state are changed.
%It will change the outputhandler!* when mathml is set to on or both is set
%to on. And then modify it accroding to the switches states.

symbolic procedure onoff(u,bool);
   begin scalar x,y;
      if not idp u then typerr(u,"switch")
       else if not flagp(u,'switch)
               then rerror(rlisp,25,list(u,"not defined as switch"));
      x := intern compress append(explode '!*,explode u);
      if !*switchcheck and lispeval x eq bool then return nil
       else if y := atsoc(bool,get(u,'simpfg))
        then lispeval('progn . append(cdr y,list nil));
      if bool and x eq '!*!r!a!i!s!e then x := '!*raise; % Special case.
   if x='!*web AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*web AND bool=nil then
      if !*mathml neq t then outputhandler!*:=nil;
   if x='!*mathml AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*mathml AND bool=nil then
      if !*both=nil then
        outputhandler!*:=nil;
   if x='!*both AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*both AND bool=nil then
      if !*mathml=nil then
        outputhandler!*:=nil
      else outputhandler!*:='math_ml_printer;

       set(x,bool);
   end;

lisp operator mml;
lisp operator parseml;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/0000755000175000017500000000000011722677364021657 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/rintro-txt.red0000644000175000017500000001000011526203062024452 0ustar  giovannigiovanniMODULE RINTRO!-TXT;  % Description of non-local variables used in RLISP.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These must be initialized at the top level of the program.

%CRBUFLIS!* := NIL;     %terminal input buffer;
%CMSG!* := NIL;         %shows that continuation msg has been printed;
%DFPRINT!* := NIL;      %used to define special output process;
%ERFG!* := NIL;         %indicates that an input error has occurred;
%INPUTBUFLIS!* := NIL;  %association list for storing input commands;
%LETL!* := NIL;         %used in algebraic mode for special delimiters;
%LREADFN!* := NIL;      %used to define special reading function;
%OUTL!* := NIL;         %storage for output of input line;
%RESULTBUFLIS!* := NIL;  %association list for storing command outputs;
%TECHO!* := NIL;        %terminal echo status;
%TSLIN!* := NIL;        %stack of input reading functions;
%!*BACKTRACE := NIL;    %if ON, prints a LISP backtrace;
%!*BLANKNOTOK!* := NIL; %if ON, disables blank as CEDIT character;
%!*COMPOSITES := NIL;   %used to indicate the use of composite numbers;
%!*FORCE := NIL;        %causes all macros to expand;
%!*MSG:=NIL;            %flag to indicate whether messages should be
                        %printed;
%!*NAT := NIL;          %used in algebraic mode to denote 'natural'
                        %output. Must be on in symbolic mode to
                        %ensure input echoing;
%NAT!*!* := NIL;        %temporary variable used in algebraic mode;
%!*NOSAVE!*             %used to denote a command not to be saved in
                        %input history;
%!*SLIN := NIL;         %indicates that LISP code should be read;

% These are initialized within some function, although they may not
% appear in that function's variable list.

% CRCHAR!*               next character in input line
% CURSYM!*               current symbol (i. e. identifier, parenthesis,
%                       delimiter, e.t.c,) in input line
% FNAME!*                name of a procedure being read
% FTYPES!*               list of regular procedure types
% IFL!*           input file/channel pair - set in BEGIN to NIL
% IPL!*           input file list- set in BEGIN to NIL
% NXTSYM!*               next symbol read in TOKEN
% OFL!*           output file/channel pair - set in BEGIN to NIL
% OPL!*           output file list- set in BEGIN to NIL
% PROGRAM!*              current input program
% PROGRAML!*             stores input program when error occurs for a
%                       later restart
% SEMIC!*                current delimiter character (used to decide
%                       whether to print result of calculation)
% TTYPE!*               current token type
% !*BLOCKP!*            keeps track of which block is active
% !*MODE         current mode of calculation
;

endmodulel;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/io.red0000644000175000017500000001307011526203062022741 0ustar  giovannigiovannimodule io; % Functions for handling input and output of files.

% Author: Anthony C. Hearn.

% Copyright (c) 1995 RAND. All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*echo !*int !*reduce4 semic!*);

global '(contl!* curline!* ifl!* ipl!* linelist!* ofl!* opl!* techo!*);

symbolic procedure file!-transform(u,v);
   % Performs a transformation on the file u.  V is name of function
   % used for the transformation.
   begin scalar echo,ichan,oldichan,val;
      echo := !*echo;
      !*echo := nil;
      ichan := open(u,'input);
      oldichan := rds ichan;
      val := errorset!*(list v,t);
      !*echo := echo;
      close ichan;
      rds oldichan;
      if not errorp val then return car val
   end;

symbolic procedure infile u;
   % Loads the single file u into REDUCE without echoing.
   begin scalar !*int;
   return file!-transform(u,function begin1)
   end;

symbolic procedure in u; in_non_empty_list u;  % REDUCE 3 hook.

symbolic procedure in_non_empty_list u;
   begin scalar echop;
      echop := null(semic!* eq '!$); % Record echo character from input.
      if null ifl!* then techo!* := !*echo;   % Terminal echo status.
      if !*reduce4 then u := value u;
      for each fl in u do in_list1(fl,echop);
      if ipl!* then ifl!* := car ipl!* else ifl!* := nil;
      if ifl!* then curline!* := caddr ifl!*;
      if !*reduce4 then return mkobject(nil,'noval)
   end;

symbolic procedure mkfil!* u;
   % Converts file descriptor U into valid system filename.
   % Allows for u to have an algebraic scalar value.
   begin scalar x;
      return if stringp u then u
              else if not idp u then typerr(u,"file name")
              else if flagp(u,'share) and stringp (x := eval u)
               then x
              else string!-downcase u
   end;

symbolic procedure in_list1(fl,echop);
   begin scalar chan,echo,ochan;
      echo := !*echo;   % Save current echo status.
      if !*reduce4 then if type fl neq 'string then typerr(fl,'string)
                         else fl := value fl;
      chan := open(fl := mkfil!* fl,'input);
      ochan := rds chan;
      if assoc(fl,linelist!*) then nil;
      curline!* := 1;
      ifl!* := list(fl,chan,1);
      ipl!* := ifl!* . ipl!*;  % Add to input file stack.
      !*echo := echop;
      begin1();
      rds ochan;
      close chan;
      !*echo := echo;   % Restore echo status.
      if null ipl!* and contl!* then return nil
       else if null ipl!* or null(fl eq caar ipl!*)
        then rederr list("FILE STACK CONFUSION",fl,ipl!*)
       else ipl!* := cdr ipl!*
   end;

symbolic procedure out u; out_non_empty_list u;  % REDUCE 3 hook.

symbolic procedure out_non_empty_list u;
   % U is a list of one file.
   begin integer n; scalar chan,fl,x;
      n := linelength nil;
      if !*reduce4 then u := value u;
      if null u then return nil;
      u := car u;
      if !*reduce4 then if type u neq 'string then typerr(u,'string)
                         else u := value u;
      if u eq 't then return <>;
      fl := mkfil u;
      if not (x := assoc(fl,opl!*))
        then <>>>
       else ofl!* := x;
      wrs cdr ofl!*;
      linelength n;
      if !*reduce4 then return mkobject(nil,'noval)
   end;

symbolic procedure shut u; shut_non_empty_list u;  % REDUCE 3 hook.

symbolic procedure shut_non_empty_list u;
   % U is a list of names of files to be shut.
   begin scalar fl1;
      if !*reduce4 then u := value u;
      for each fl in u do
       <>;
                  close cdr fl1>>
         else if not (fl1 := assoc(fl,ipl!*))
          then rerror(rlisp,26,list(fl,"not open"))
         else if fl1 neq ifl!*
          then <>
         else rerror(rlisp,27,
                     list("Cannot shut current input file",car fl1))>>;
      if !*reduce4 then return mkobject(nil,'noval)
   end;

deflist ('((in rlis) (out rlis) (shut rlis)),'stat);  % REDUCE 3 only.

flag ('(in out shut),'eval);

flag ('(in out shut),'ignore);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/block.red0000644000175000017500000001510711526203062023427 0ustar  giovannigiovannimodule block;   % Block statement and related operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1993 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*blockp !*novarmsg !*rlisp88);

global '(!*vars!* cursym!* nxtsym!*);

flag('(novarmsg),'switch);

% ***** GO statement *****

symbolic procedure gostat;
   begin scalar var;
        var := if eq(scan(),'to) then scan() else cursym!*;
        scan();
        return list('go,var)
   end;

put('go,'stat,'gostat);

put('goto,'newnam,'go);


% ***** Declaration Statement *****

symbolic procedure decl u;
   begin scalar varlis,w;
   a: if cursym!* eq '!*semicol!* then go to c
       else if cursym!* eq 'local and !*reduce4 then nil
       else if not flagp(cursym!*,'type) then return varlis
       else if !*reduce4 then typerr(cursym!*,"local declaration");
      w := cursym!*;
      scan();
      if null !*reduce4
        then if cursym!* eq 'procedure then return procstat1 w
              else varlis
                  := append(varlis,pairvars(remcomma xread1 nil,nil,w))
       else varlis := append(varlis,read_param_list nil);
      if not(cursym!* eq '!*semicol!*) or null u then symerr(nil,t);
   c: scan();
      go to a
   end;

put('integer,'initvalue!*,0);

symbolic procedure decstat;
  % Called if a declaration occurs at the top level or not first
  % in a block.
  begin scalar x,y,z;
     if !*blockp then symerr('block,t);
     x := cursym!*;
     y := nxtsym!*;
     z := decl nil;
     if y neq 'procedure
       then rerror('rlisp,7,list(x,"invalid outside block"));
     return z
  end;

flag('(integer real scalar),'type);

symbolic procedure blocktyperr u;
   % Type declaration found at wrong position.
   rerror('rlisp,8,list(u,"invalid except at head of block"));


% ***** Block Statement *****

symbolic procedure mapovercar u;
   begin scalar x;
 a: if u then progn(x := caar u . x, u := cdr u, go to a);
   return reversip!* x
   end;

symbolic procedure blockstat;
   begin scalar hold,varlis,x,!*blockp;
        !*blockp := t;
        scan();
        if cursym!* memq '(nil !*rpar!*)
          then rerror('rlisp,9,"BEGIN invalid");
        varlis := decl t;
    a:  if cursym!* eq 'end and not(nxtsym!* eq '!:) then go to b;
        x := xread1 nil;
        if eqcar(x,'end) then go to c;
        not(cursym!* eq 'end) and scan();
        if x
          then progn((if eqcar(x,'equal)
                 then lprim list("top level",cadr x,"= ... in block")),
                      hold := aconc!*(hold,x));
        go to a;
    b:  comm1 'end;
    c:  return mkblock(varlis,hold)
   end;

symbolic procedure mkblock(u,v); 'rblock . (u . v);

putd('rblock,'macro,
 '(lambda (u) (cons 'prog (cons (mapovercar (cadr u)) (cddr u)))));

symbolic procedure symbvarlst(vars,body,mode);
   begin scalar x,y;
      if null(mode eq 'symbolic) then return nil;
      y := vars;
   a: if null y then return nil;
      x := if pairp car y then caar y else car y;
      if not fluidp x and not globalp x and not smemq(x,body)
         and not !*novarmsg
        then lprim list("local variable",x,"in procedure",
                        fname!*,"not used");
      y := cdr y;
      go to a
   end;

symbolic procedure make_prog_declares(v, b);
   begin
!#if (memq 'csl lispsystem!*)
% This detects any bound variables that are fluid (or global) at the
% time I process this code and adds in a DECLARE to remind us about
% that fact.
     scalar w, r;
     w := v;
  l: if null w then go to x;
     if fluidp car w or globalp car w then r := car w . r;
     w := cdr w;
     go to l;
  x: if r then b := list('declare, 'special . r) . b;
!#endif
     return ('prog . v . b)
   end;

symbolic procedure formblock(u,vars,mode);
   begin scalar w;
     symbvarlst(cadr u,cddr u,mode); % Merely report on any unused vars
     w := initprogvars cadr u;
     return make_prog_declares(car w,
                      append(cdr w,
                             formprog1(cddr u,append(cadr u,vars),mode)));
   end;

symbolic procedure initprogvars u;
   begin scalar x,y,z;
    a: if null u then return(reversip!* x . reversip!* y)
       else if (z := get(caar u,'initvalue!*))
          or (z := get(cdar u,'initvalue!*))
        then y := mksetq(caar u,z) . y;
      x := caar u . x;
      u := cdr u;
      go to a
   end;

symbolic procedure formprog(u,vars,mode);
   make_prog_declares(cadr u, formprog1(cddr u,pairvars(cadr u,vars,mode),mode));


symbolic procedure formprog1(u,vars,mode);
   if null u then nil
    else if null car u then formprog1(cdr u,vars,mode)
        % remove spurious NILs, probably generated by FOR statements.
    else if atom car u then car u . formprog1(cdr u,vars,mode)
    else if idp caar u and flagp(caar u,'modefn)
           then if !*rlisp88 and null(caar u eq 'symbolic)
                  then typerr("algebraic expression","Rlisp88 form")
          else formc(cadar u,vars,caar u) . formprog1(cdr u,vars,mode)
    else formc(car u,vars,mode) . formprog1(cdr u,vars,mode);

put('rblock,'formfn,'formblock);

put('prog,'formfn,'formprog);

put('begin,'stat,'blockstat);

flag('(declare), 'noform);

% ***** Return Statement *****

symbolic procedure retstat;
   if not !*blockp then symerr(nil,t)
    else begin scalar !*blockp;  % To prevent RETURN within a RETURN.
            return list('return,
                if flagp(scan(),'delim) then nil else xread1 t)
      end;

put('return,'stat,'retstat);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/statmisc.red0000644000175000017500000000603511526203062024164 0ustar  giovannigiovannimodule write;  % Miscellaneous statement definitions.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% ***** DEFINE STATEMENT *****

remprop('define,'stat);

symbolic procedure define u;
   for each x in u do
      if not eqcar(x,'equal) or not idp cadr x
        then typerr(x,"DEFINE declaration")
       else put(cadr x,'newnam,caddr x);

deflist('((define rlis)),'stat);

flag('(define),'eval);

% ***** WRITE STATEMENT *****

symbolic procedure formwrite(u,vars,mode);
   begin scalar bool1,bool2,x,y,z;
      u := cdr u;
      bool1 := mode eq 'symbolic;
      while u do
        <>;
        if bool1 then z := nil . z;  % Since PRIN2 returns its value.
        return if null z then nil
                else if null cdr z then car z
                else 'progn . reversip!* z
   end;

put('write,'stat,'rlis);

put('write,'formfn,'formwrite);


% ECHOPR is similar to WRITE but, if switch TESTECHO is on, it echos an
% offline print onto the screen, in either algebraic or symbolic mode.

% Switch is not yet defined.

flag('(testecho),'switch);

put('echopr,'stat,'rlis);

put('echopr,'formfn,'formechopr);

symbolic procedure formechopr(u,vars,mode);
   (lambda x; list ('progn,x,
      list ('cond,list ('(and !*testecho ofl!*),
         list (list ('lambda,'(n),
            list ('progn,x,'(wrs n),nil)),'(wrs nil) ))) ))
       formwrite(u,vars,mode);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/newtok.red0000644000175000017500000001144711526203062023647 0ustar  giovannigiovannimodule newtok;  % Functions for introducing infix tokens to the system.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*msg !*redeflg!*);

global '(preclis!* fixedpreclis!*);

% Several operators in REDUCE are used in an infix form (e.g., +,- ).
% The internal alphanumeric names associated with these operators are
% introduced by the function NEWTOK defined below.  This association,
% and the precedence of each infix operator, is initialized in this
% section.  We also associate printing characters with each internal
% alphanumeric name as well.

fixedpreclis!* := '(where !*comma!* setq);

preclis!*:= '(or and member memq equal neq eq geq greaterp leq   % not
              lessp freeof plus difference times quotient expt cons);

deflist ('(
%  (not not)
   (plus plus)
   (difference minus)
   (minus minus)
   (times times)
   (quotient recip)
   (recip recip)
 ), 'unary);

flag ('(and or !*comma!* plus times),'nary);

flag ('(cons setq plus times),'right);

deflist ('((minus plus) (recip times)),'alt);

symbolic procedure mkprec;
   begin scalar x,y,z;
        x := append(fixedpreclis!*,preclis!*);
        y := 1;
    a:  if null x then return nil;
        put(car x,'infix,y);
        put(car x,'op,list list(y,y));   % for RPRINT.
        if z := get(car x,'unary) then put(z,'infix,y);
        if and(z,null flagp(z,'nary)) then put(z,'op,list(nil,y));
        x := cdr x;
        y := add1 y;
        go to a
   end;

mkprec();

symbolic procedure newtok u;
   begin scalar !*redeflg!*,x,y;
      if atom u or atom car u or null idp caar u
        then typerr(u,"NEWTOK argument");
      % set up SWITCH* property.
      put(caar u,'switch!*,
          cdr newtok1(car u,cadr u,get(caar u,'switch!*)));
      % set up PRTCH property.
      y := intern compress consescc car u;
      if !*redeflg!* then lprim list(y,"redefined");
      put(cadr u,'prtch,y);
      if x := get(cadr u,'unary) then put(x,'prtch,y)
   end;

symbolic procedure newtok1(charlist,name,propy);
      if null propy then lstchr(charlist,name)
       else if null cdr charlist
        then begin
                if cdr propy and !*msg then !*redeflg!* := t;
                return list(car charlist,car propy,name)
             end
       else car charlist . newtok2(cdr charlist,name,car propy)
                         . cdr propy;

symbolic procedure newtok2(charlist,name,assoclist);
   if null assoclist then list lstchr(charlist,name)
    else if car charlist eq caar assoclist
     then newtok1(charlist,name,cdar assoclist) . cdr assoclist
    else car assoclist . newtok2(charlist,name,cdr assoclist);

symbolic procedure consescc u;
   if null u then nil else '!! . car u . consescc cdr u;

symbolic procedure lstchr(u,v);
   if null cdr u then list(car u,nil,v)
    else list(car u,list lstchr(cdr u,v));

newtok '((!$) !*semicol!*);
newtok '((!;) !*semicol!*);
newtok '((!+) plus);
newtok '((!-) difference);
newtok '((!*) times);
newtok '((!^) expt);
newtok '((!* !*) expt);
newtok '((!/) quotient);
newtok '((!=) equal);
newtok '((!,) !*comma!*);
newtok '((!() !*lpar!*);
newtok '((!)) !*rpar!*);
newtok '((!:) !*colon!*);
newtok '((!: !=) setq);
newtok '((!.) cons);
newtok '((!<) lessp);
newtok '((!< !=) leq);
newtok '((![) !*lsqbkt!*);
newtok '((!< !<) !*lsqbkt!*);
newtok '((!>) greaterp);
newtok '((!> !=) geq);
newtok '((!]) !*rsqbkt!*);
newtok '((!> !>) !*rsqbkt!*);

put('expt,'prtch,'!*!*);   % To ensure that FORTRAN output is correct.

flag('(difference minus plus setq),'spaced);

flag('(newtok),'eval);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/switch.red0000644000175000017500000000651111526203062023635 0ustar  giovannigiovannimodule switch;  % Support for switches and ON and OFF statements.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*switchcheck switchlist!*);

% No references to RPLAC-based functions in this module.

symbolic procedure on u; for each j in u do on1 j;

symbolic procedure off u; for each j in u do off1 j;

symbolic procedure off1 u; onoff(u,nil);

symbolic procedure on1 u; onoff(u,t);

symbolic procedure onoff(u,bool);
   begin scalar x,y;
      if not idp u then typerr(u,"switch")
       else if not flagp(u,'switch)
%       then if !*switchcheck
               then rerror(rlisp,25,list(u,"not defined as switch"));
%             else lpriw("*****",list(u,"not defined as switch"));
      x := intern compress append(explode '!*,explode u);
      if !*switchcheck and lispeval x eq bool then return nil
       else if y := atsoc(bool,get(u,'simpfg))
        then lispeval('progn . append(cdr y,list nil));
      if bool and x eq '!*!r!a!i!s!e then x := '!*raise; % Special case.
       set(x,bool)
   end;

symbolic procedure switch u;
   % Declare list u as switches.
   for each x in u do
      begin scalar y;
         if not idp x then typerr(x,"switch");
         if not(x memq switchlist!*)
           then switchlist!* := x . switchlist!*;
         flag(list x,'switch);
         y := intern compress append(explode '!*,explode x);
         if not fluidp y and not globalp y then fluid list y
      end;

deflist('((switch rlis)),'stat);   % we use deflist since it's flagged
                                   % eval
flag('(switch),'eval);

put('off,'stat,'rlis);

put('on,'stat,'rlis);

flag ('(off on),'ignore);

% Symbolic mode switches:

switch backtrace,comp,defn,demo,echo,errcont,fastfor,   % eoldelimp
       int,lessspace,msg,output,pret,quotenewnam,raise,time;

put('eoldelimp,'simpfg,'((t (flag (list !$eol!$) 'delchar))
                         (nil (remflag (list !$eol!$) 'delchar))));

% Support for REDUCE 4.

switch reduce4;

put('reduce4,'simpfg,'((t (load!-package 'reduce4) (!%reduce4))));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/loops.red0000644000175000017500000000642111526203062023470 0ustar  giovannigiovannimodule loops;  % Looping forms other than the FOR statement.

% Author: Anthony C. Hearn

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*blockp);

global '(cursym!*);


% ***** REPEAT STATEMENT *****

symbolic procedure repeatstat;
  begin scalar !*blockp,body,bool;
        if flagp('until,'delim) then bool := t
         else flag('(until),'delim);
        body:= xread t;
        if not bool then remflag('(until),'delim);
        if not(cursym!* eq 'until) then symerr('repeat,t);
        return list('repeat,body,xread t);
   end;

symbolic macro procedure repeat u;
   begin scalar body,bool,lab;
        body := cadr u; bool := caddr u;
        lab := gensym();
        return mkprog(nil,list(lab,body,
                list('cond,list(list('not,bool),list('go,lab)))))
   end;

put('repeat,'stat,'repeatstat);

flag('(repeat),'nochange);

symbolic procedure formrepeat(u,vars,mode);
   begin scalar !*!*a2sfn;
      !*!*a2sfn := 'aeval!*;
      return list('repeat,formc(cadr u,vars,mode),
                  formbool(caddr u,vars,mode))
   end;

put('repeat,'formfn,'formrepeat);


% ***** WHILE STATEMENT *****

symbolic procedure whilstat;
   begin scalar !*blockp,bool,bool2;
        if flagp('do,'delim) then bool2 := t else flag('(do),'delim);
        bool := xread t;
        if not bool2 then remflag('(do),'delim);
        if not(cursym!* eq 'do) then symerr('while,t);
        return list('while,bool,xread t)
   end;

symbolic macro procedure while u;
   begin scalar body,bool,lab;
        bool := cadr u; body := caddr u;
        lab := gensym();
        return mkprog(nil,list(lab,list('cond,list(list('not,bool),
                list('return,nil))),body,list('go,lab)))
   end;

put('while,'stat,'whilstat);

flag('(while),'nochange);

symbolic procedure formwhile(u,vars,mode);
   begin scalar !*!*a2sfn;
      !*!*a2sfn := 'aeval!*;
      return list('while,formbool(cadr u,vars,mode),
                  formc(caddr u,vars,mode))
   end;

put('while,'formfn,'formwhile);

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/slfns.red0000644000175000017500000001016311526203062023457 0ustar  giovannigiovannimodule slfns;  % Complete list of Standard LISP functions.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(!*argnochk slfns!*);

slfns!* := '(
        (abs 1)
        (add1 1)
        (append 2)
        (apply 2)
        (assoc 2)
        (atom 1)
        (car 1)
        (cdr 1)
        (caar 1)
        (cadr 1)
        (cdar 1)
        (cddr 1)
        (caaar 1)
        (caadr 1)
        (cadar 1)
        (caddr 1)
        (cdaar 1)
        (cdadr 1)
        (cddar 1)
        (cdddr 1)
        (caaaar 1)
        (caaadr 1)
        (caadar 1)
        (caaddr 1)
        (cadaar 1)
        (cadadr 1)
        (caddar 1)
        (cadddr 1)
        (cdaaar 1)
        (cdaadr 1)
        (cdadar 1)
        (cdaddr 1)
        (cddaar 1)
        (cddadr 1)
        (cdddar 1)
        (cddddr 1)
        (close 1)
        (codep 1)
        (compress 1)
        (cons 2)
        (constantp 1)
        (de 3)
        (deflist 2)
        (delete 2)
%       (df 3)                     conflicts with algebraic operator DF
        (difference 2)
        (digit 1)
        (divide 2)
        (dm 3)
%       (dn 3)
%       (ds 3)
        (eject 0)
        (eq 2)
        (eqn 2)
        (equal 2)
        (error 2)
        (errorset 3)
        (eval 1)
        (evlis 1)
        (expand 2)
        (explode 1)
        (expt 2)
        (fix 1)
        (fixp 1)
        (flag 2)
        (flagp 2)
        (float 1)
        (floatp 1)
        (fluid 1)
        (fluidp 1)
        (function 1)
        (gensym 0)
        (get 2)
        (getd 1)
        (getv 2)
        (global 1)
        (globalp 1)
        (go 1)
        (greaterp 2)
        (idp 1)
        (intern 1)
        (length 1)
        (lessp 2)
        (linelength 1)
        (liter 1)
        (lposn 0)
        (map 2)
        (mapc 2)
        (mapcan 2)
        (mapcar 2)
        (mapcon 2)
        (maplist 2)
        (max2 2)
        (member 2)
        (memq 2)
        (minus 1)
        (minusp 1)
        (min2 2)
        (mkvect 1)
        (nconc 2)
        (not 1)
        (null 1)
        (numberp 1)
        (onep 1)
        (open 2)
        (pagelength 1)
        (pair 2)
        (pairp 1)
        (plus2 2)
        (posn 0)
        (print 1)
        (prin1 1)
        (prin2 1)
        (prog2 2)
        (put 3)
        (putd 3)
        (putv 3)
        (quote 1)
        (quotient 2)
        (rds 1)
        (read 0)
        (readch 0)
        (remainder 2)
        (remd 1)
        (remflag 2)
        (remob 1)
        (remprop 2)
        (return 1)
        (reverse 1)
        (rplaca 2)
        (rplacd 2)
        (sassoc 3)
        (set 2)
        (setq 2)
        (stringp 1)
        (sublis 2)
        (subst 3)
        (sub1 1)
        (terpri 0)
        (times2 2)
        (unfluid 1)
        (upbv 1)
        (vectorp 1)
        (wrs 1)
        (zerop 1)
        );

if !*argnochk then deflist(slfns!*,'number!-of!-args);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/xmodule.red0000644000175000017500000001001711526203062024005 0ustar  giovannigiovannimodule xmodule; % Support for "exemplary" module use.

% Author: Anthony C. Hearn.

% Copyright (c) 1995 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


remprop('xmodule,'newnam);

load_package rcref;

fluid '(!*nocrefpri intfns!* modulename!*);

fluid '(!*backtrace !*mode !*nocrefpri);

global '(exportslist!* importslist!* loaded!-packages!* mode!-list!*);

global '(entpts!* gseen!* seen!* tseen!* xseen!* nolist!* undefg!*);

symbolic procedure xmodule u;
   % Sets up an "exemplary" module definition.
   begin scalar x,y;
      modulename!* := u;
      mode!-list!* := !*mode . mode!-list!*;
      !*mode := 'symbolic;
      while (y := command()) neq '(symbolic (endmodule)) do
         progn(if eqcar(cadr y,'progn)
                 then x := append(reversip for each j in cdadr y
                                     collect list(car y,j),x)
                else x := y . x,
               if null atom cadr y and caadr y memq '(exports imports)
                 then eval cadr y);
      x := reversip x;
      begin scalar !*defn, dfprint!*,!*nocrefpri;
         !*nocrefpri := t;
         crefon();
         for each j in x do refprint cdr j;
         crefoff1()
      end;
      lprim list("Encountered non-SL functions:",idsort seen!*);
      lprim list("Encountered extended SL functions:",idsort xseen!*);
      lprim list("Globals seen:",idsort gseen!*);
      % Find internal functions.
      intfns!* := idsort setdiff(setdiff(setdiff(seen!*,undefns!*),
                                importslist!*),exportslist!*);
      lprim list("Internal functions:",intfns!*);
      if (y := setdiff(entpts!*,exportslist!*))
        then lprim list("Defined but not used:",idsort y);
      if tseen!* then lprim list("Encountered types not fn:",tseen!*);
      if undefg!*
        then lprim list("Undeclared globals:",idsort undefg!*);
      if (y := setdiff(undefns!*,importslist!*))
        then lprim list("Functions not defined:",idsort y);
      if pretitl!* then lprim list("Errors, etc.:",pretitl!*);
      return x
end;

deflist('((xmodule rlis)),'stat);

symbolic procedure xmodloop u;
   begin scalar x;
      flag(intfns!*,'internalfunction);
   a: if null u then go to b;
      x := cadar u;
      if null atom x
          and ((car x eq 'put
               and caddr x = mkquote 'number!-of!-args
               and memq(cadadr x,intfns!*))
           or car x memq '(exports imports))
        then nil
       else if errorp(x := errorset!*(list('begin11,mkquote car u),t))
        then progn(u := 'err2,go to b)
       else if car x then progn(u := car x,go to b);
      u := cdr u;
      go to a;
   b: remflag(intfns!*,'internalfunction);
      return u
   end;

% Augment list of functions not needing "imports" references.

nolist!* := append('(atsoc exports imports neq),nolist!*)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/forstat.red0000644000175000017500000003050411526203062024015 0ustar  giovannigiovannimodule forstat;   % Definition of REDUCE FOR loops.

% Author: Anthony C. Hearn.

% Copyright (c) 1993 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*blockp !*fastfor !*modular);

global '(cursym!* foractions!*);

Comment the syntax of the FOR statement is as follows:

                 {step i3 until}
        {i := i1 {             } i2 }
        {        {      :      }    }
   for  {                           }  
        {        { in }             }
        { each i {    }       }
                 { on }

In all cases, the  is evaluated algebraically within the scope of
the current value of i.  If  is DO, then nothing else happens.
In other cases,  is a binary operator that causes a result to be
built up and returned by FOR.  In each case, the loop is initialized to
a default value.  The test for the end condition is made before any
action is taken.

The effect of the definition here is to replace all for loops by
semantically equivalent blocks.  As a result, none of the mapping
functions are needed in REDUCE.

To declare a set of actions, one says;

foractions!* := '(do collect conc product sum);

remflag(foractions!*,'delim);    % For bootstrapping purposes.

% To associate a binary function with an action, one says:

deflist('((product times) (sum plus)),'bin);

% And to give these an initial value in a loop:

deflist('((product 1) (sum 0)),'initval);

% NB:  We need to reset for and let delims if an error occurs.  It's
% probably best to do this in the begin1 loop.

% flag('(for),'nochange);

symbolic procedure forstat;
   begin scalar !*blockp;
      return if scan() eq 'all then forallstat()
              else if cursym!* eq 'each then foreachstat()
              else forloop()
   end;

put('for,'stat,'forstat);

symbolic procedure forloop;
   begin scalar action,bool,incr,var,x;
      if flagp('step,'delim) then bool := t else flag('(step),'delim);
      x := errorset!*('(xread1 'for),t);
      if null bool then remflag('(step),'delim) else bool := nil;
      if errorp x then error1() else x := car x;
      if not eqcar(x,'setq) or not idp(var := cadr x)
        then symerr('for,t);
      x := caddr x;
      if cursym!* eq 'step
        then <>
       else if cursym!* eq '!*colon!* then incr := 1
       else symerr('for,t);
      if flagp(car foractions!*,'delim) then bool := t % nested loop
       else flag(foractions!*,'delim);
      incr := list(x,incr,xread t);
      if null bool then remflag(foractions!*,'delim);
      if not((action := cursym!*) memq foractions!*)
        then symerr('for,t);
      return list('for,var,incr,action,xread t)
   end;

symbolic procedure formfor(u,vars,mode);
   begin scalar action,algp,body,endval,incr,initval,var,x;
         scalar !*!*a2sfn;
        % ALGP is used to determine if the loop calculation must be
        % done algebraically or not.
      !*!*a2sfn := 'aeval!*;
      var := cadr u;
      incr := caddr u;
      incr := list(formc(car incr,vars,mode),
                   formc(cadr incr,vars,mode),
                   formc(caddr incr,vars,mode));
      if not atsoc(var,vars)
        then if intexprnp(car incr,vars) and intexprnp(cadr incr,vars)
               then vars := (var . 'integer) . vars
              else vars := (var . mode) . vars;
      action := cadddr u;
      body := formc(car cddddr u,vars,mode);
      initval := car incr;
      endval := caddr incr;
      incr := cadr incr;
      algp := algmodep initval or algmodep incr or algmodep endval;
      if algp then <>;
      x := if algp then list('list,''difference,endval,var)
            else list(if !*fastfor then 'idifference else 'difference,
                      endval,var);
      if incr neq 1
        then x := if algp then list('list,''times,incr,x)
                   else list('times,incr,x);
      % We could consider simplifying X here (via reval).
      x := if algp then list('aminusp!:,x)
            else list(if !*fastfor then 'iminusp else 'minusp,x);
      return forformat(action,body,initval,x,
                       if algp
                          then list('aeval!*,list('list,''plus,incr))
                        else list(if !*fastfor then 'iplus2 else 'plus2,
                                  incr),
                       var,vars,mode)
   end;

put('for,'formfn,'formfor);

symbolic procedure algmodep u;
   not atom u and car u memq '(aeval aeval!*);

symbolic procedure aminusp!: u;
   % This is only used in loop tests. We must make sure we are not in a
   % modular domain (where the difference will always be positive!).
   begin scalar oldmode,v;
      if !*modular then oldmode := setdmode('modular,nil);
      v := errorset2 list('aminusp!:1,mkquote u);
      if oldmode then setdmode('modular,t);
      if errorp v then typerr(u,"arithmetic expression")
       else return car v
   end;

symbolic procedure aminusp!:1 u;
   begin scalar x;
      u := aeval!* u;
      x := u;
      if fixp x then return minusp x
       else if not eqcar(x,'!*sq)
        then msgpri(nil,reval u,"invalid in FOR statement",nil,t);
      x := cadr x;
      if fixp car x and fixp cdr x then return minusp car x
       else if not(cdr x = 1)
             or not (atom(x := car x) or atom car x)
         % Should be DOMAINP, but SMACROs not yet defined.
        then msgpri(nil,reval u,"invalid in FOR statement",nil,t)
       else return apply1('!:minusp,x)
   end;

symbolic procedure foreachstat;
   begin scalar w,x,y,z;
        if not idp(x := scan()) or not((y := scan()) memq '(in on))
          then symerr("FOR EACH",t)
         else if flagp(car foractions!*,'delim) then w := t
         else flag(foractions!*,'delim);
        z := xread t;
        if null w then remflag(foractions!*,'delim);
        w := cursym!*;
        if not(w memq foractions!*) then symerr("FOR EACH",t);
        return list('foreach,x,y,z,w,xread t)
   end;

put('foreach,'stat,'foreachstat);

symbolic procedure formforeach(u,vars,mode);
   begin scalar action,body,lst,mod1,var;
        var := cadr u; u := cddr u;
        mod1 := car u; u := cdr u;
        lst := formc(car u,vars,mode); u := cdr u;
        if not(mode eq 'symbolic) then lst := list('getrlist,lst);
        action := car u; u := cdr u;
        body := formc(car u,(var . mode) . vars,mode); % was FORMC
        if mod1 eq 'in
          then body := list(list('lambda,list var,body),list('car,var))
         else if not(mode eq 'symbolic) then typerr(mod1,'action);
        return forformat(action,body,lst,
                         list('null,var),list 'cdr,var,vars,mode)
   end;

put('foreach,'formfn,'formforeach);

symbolic procedure forformat(action,body,initval,
                             testexp,updform,var,vars,mode);
   begin scalar result;
       % Next test is to correct structure generated by formfor.
% The expansion here can introduce new local variables named
% forall!-result and forall!-endprt. Until recently the first of
% these had been created as a gensym to avoid any prospect of name
% clashing. However that results in code parsing onto different stuff
% each time it is read, and that causes some confusion in the CSL world
% where I want to match source code to compiled code. The messy use
% of a "sort of obscure" name should in practise be OK. Especially since
% I observe that "endptr" had been polluting the name-space for some years.
      if algmodep updform and length cadr updform > 2
         then <>;
      result := 'forall!-result; % gensym();
      return
         sublis(list('body2 .
                if mode eq 'symbolic or intexprnp(body,vars)
                  then list(get(action,'bin),body,result)
                 else list('aeval!*,list('list,mkquote get(action,'bin),
                            unreval body,result)),
               'body3 .
                   if mode eq 'symbolic then body
                      else list('getrlist,body),
               'body . body,
               'initval . initval,
               'nillist .
                   if mode eq 'symbolic then nil else '(makelist nil),
               'result . result,
               'initresult . get(action,'initval),
               'resultlist . if mode eq 'symbolic then result
                              else list('cons,''list,result),
               'testexp . testexp,
               'updfn . car updform,
               'updval . cdr updform,
               'var . var),
          if action eq 'do
            then '(prog (var)
                  (setq var initval)
              lab (cond (testexp (return nil)))
                  body
                  (setq var (updfn var . updval))
                  (go lab))
           else if action eq 'collect
            then '(prog (var result forall!-endptr)
                  (setq var initval)
                  (cond (testexp (return nillist)))
                  (setq result (setq forall!-endptr (cons body nil)))
                looplabel
                  (setq var (updfn var . updval))
                  (cond (testexp (return resultlist)))
                  (rplacd forall!-endptr (cons body nil))
                  (setq forall!-endptr (cdr forall!-endptr))
                  (go looplabel))
           else if action eq 'conc
            then '(prog (var result forall!-endptr)
                  (setq var initval)
               startover
                  (cond (testexp (return nillist)))
                  (setq result body)
                  (setq forall!-endptr (lastpair resultlist))
                  (setq var (updfn var . updval))
                  (cond ((atom forall!-endptr) (go startover)))
                looplabel
                  (cond (testexp (return result)))
                  (rplacd forall!-endptr body3)
                  (setq forall!-endptr (lastpair forall!-endptr))
                  (setq var (updfn var . updval))
                  (go looplabel))
           else '(prog (var result)
                 (setq var initval)
                 (setq result initresult)
              lab1
                 (cond (testexp (return result)))
                 (setq result body2)
                 (setq var (updfn var . updval))
                 (go lab1)))
   end;

symbolic procedure lastpair u;
   % Return the last pair of the list u.
   if atom u or atom cdr u then u else lastpair cdr u;

symbolic procedure unreval u;
   % Remove spurious aeval or reval in inner expression.
   if atom u or null(car u memq '(aeval reval)) then u else cadr u;

remprop('conc,'newnam);

put('join,'newnam,'conc);   % alternative for CONC

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/parser.red0000644000175000017500000001040411526203062023624 0ustar  giovannigiovannimodule parser;  % Functions for parsing RLISP expressions.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*backtrace);

global '(cursym!* letl!* nxtsym!*);

%With the exception of assignment statements, which are handled by
%XREAD, statements in REDUCE are introduced by a key-word, which
%initiates a reading process peculiar to that statement.  The key-word
%is recognized (in XREAD1) by the indicator STAT on its property list.
%The corresponding property is the name of the function (of no
%arguments) which carries out the reading sequence.

% ***** COMMENTS *****

symbolic procedure comm1 u;
   begin scalar bool;
        if u eq 'end then go to b;
  a:    if cursym!* eq '!*semicol!*
           or u eq 'end
                and cursym!* memq
                   '(end else then until !*rpar!* !*rsqbkt!*)
          then return nil
         else if u eq 'end and null bool
          then progn(lprim list("END-COMMENT NO LONGER SUPPORTED"),
                     bool := t);
  b:    scan();
        go to a
   end;


% ***** CONDITIONAL STATEMENT *****

symbolic procedure ifstat;
   begin scalar condx,condit;
    a:  condx := xread t;
        if not(cursym!* eq 'then) then symerr('if,t);
        condit := aconc!*(condit,list(condx,xread t));
        if not(cursym!* eq 'else) then nil
         else if scan() eq 'if then go to a
         else condit := aconc!*(condit,list(t,xread1 t));
        return ('cond . condit)
   end;

put('if,'stat,'ifstat);

flag ('(then else),'delim);


% ***** FUNCTION STATEMENT *****

symbolic procedure functionstat;
   begin scalar x;
      x := scan();
      return list('function,
                  if x eq '!*lpar!* then xread1 t
                   else if idp x and null(x eq 'lambda)
                    then progn(scan(),x)
                   else symerr("Function",t))
   end;

put('function,'stat,'functionstat);


% ***** LAMBDA STATEMENT *****

symbolic procedure lamstat;
   begin scalar x,y;
        x:= xread 'lambda;
%       x := flagtype(if null x then nil else remcomma x,'scalar);
        if x then x := remcomma x;
        y := list('lambda,x,xread t);
%       remtype x;
        return y
   end;

put ('lambda,'stat,'lamstat);


% ***** GROUP STATEMENT *****

symbolic procedure readprogn;
   %Expects a list of statements terminated by a >>;
   begin scalar lst;
    a:  lst := aconc!*(lst,xread 'group);
        if null(cursym!* eq '!*rsqbkt!*) then go to a;
        scan();
        return ('progn . lst)
   end;

put('!*lsqbkt!*,'stat,'readprogn);

flag ('(!*lsqbkt!*),'go);

flag('(!*rsqbkt!*),'delim);

flag('(!*rsqbkt!*),'nodel);


% ***** END STATEMENT *****

symbolic procedure endstat;
  %This procedure can also be used for any key-words  which  take  no
  %arguments;
   begin scalar x; x := cursym!*; comm1 'end; return list x end;

put('end,'stat,'endstat);

put('endmodule,'stat,'endstat);

put('bye,'stat,'endstat);

put('quit,'stat,'endstat);

flag('(bye quit),'eval);

put('showtime,'stat,'endstat);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/rlisp.red0000644000175000017500000000403111526203062023460 0ustar  giovannigiovanni% module rlisp;  % Header module for rlisp package.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


global '(date!* patch!-date!* version!*);

create!-package('(rlisp module newtok rsupport slfns superv tok xread
                  lpri parser block form proc forstat loops statmisc
                  smacro io infix switch where list array inter),
                 nil);

flag('(rlisp),'core!_package);

% if patch!-date!* then
%     date!* := compress('!" . append(explode2 "15-Sep-2008, patched to ",
%                                 nconc(explode2 patch!-date!*,list '!")))
%  else 

date!* := date();

if null version!* then version!* := "REDUCE";

% Hook to Rlisp88.

put('rlisp88,'simpfg,'((t (load!-package 'rlisp88) (rlisp88!_on))));

flag('(rlisp88),'switch);

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/mkset.red0000644000175000017500000000726611526203062023467 0ustar  giovannigiovannimodule mkset;  % Define a set as a list of expressions enclosed by
               % curly brackets.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(orig!* posn!*);

global '(cursym!*);

% Add to system table.

put('set,'tag,'set);

put('set,'rtypefn,'quoteset);

symbolic procedure quoteset u; 'set;

% Parsing interface.

symbolic procedure mkset;
   % expects a list of expressions enclosed by {, }.
   % also allows expressions separated by ; --- treats these as progn.
   begin scalar cursym,delim,lst;
        if scan() eq '!*rcbkt!* then <>;
    a:      lst := aconc(lst,xread1 'group);
        cursym := cursym!*;
        scan();
        if cursym eq '!*rcbkt!*
          then return if delim eq '!*semicol!* then 'progn . lst
                       else 'set . trim lst
         else if null delim then delim := cursym
         else if not(delim eq cursym)
          then symerr("syntax error: mixed , and ; in set",nil);
        go to a
   end;

put('!*lcbkt!*,'stat,'mkset);

newtok '((!{) !*lcbkt!*);

newtok '((!}) !*rcbkt!*);

flag('(!*rcbkt!*),'delim);

flag('(!*rcbkt!*),'nodel);

% Evaluation interface.

put('set,'evfn,'seteval);

symbolic procedure seteval(u,v);
   if atom u then seteval get(u,'set)
    else car u . trim for each x in cdr u collect reval1(x,v);

symbolic procedure trim u;
   % Remove repeated elements from u.
   if null u then nil
    else if car u member cdr u then trim cdr u
    else car u . trim cdr u;

% Length interface.

put('set,'lengthfn,'length);


% Printing interface.

put('set,'prifn,'setpri);

symbolic procedure setpri l;
   % This definition is basically that of INPRINT, except that it
   % decides when to split at the comma by looking at the size of
   % the argument.
   begin scalar orig,split;
      l := cdr l;
      prin2!* "{";
      orig := orig!*;
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split := treesizep(l,40);   % 40 is arbitrary choice.
   a: maprint(negnumberchk car l,0);
      l := cdr l;
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b: prin2!* "}";
      terpri!* nil;
      orig!* := orig
   end;

symbolic procedure treesizep(u,n);
   % true if u has recursively more pairs than n.
   treesizep1(u,n)=0;

symbolic procedure treesizep1(u,n);
   if atom u then n-1
    else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n)
    else 0;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/superv.red0000644000175000017500000004275211526203062023667 0ustar  giovannigiovannimodule superv; % REDUCE supervisory functions.

% Author: Anthony C. Hearn.

% Modified by: Jed B. Marti, Francis J. Wright.

% Copyright (c) 1998 Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*debug
        !*defn
        !*demo
        !*echo
        !*errcont
        !*int
        !*lisp!_hook
        !*mode
        !*output
        !*pret
        !*reduce4
        !*slin
        !*time
        !*rlisp88
        dfprint!*
        errmsg!*
        lispsystem!*
        loopdelimslist!*
        lreadfn!*
        newrule!*
        semic!*
        tslin!*);

global '(!$eof!$
         !*byeflag!*
         !*extraecho
         !*lessspace
         !*micro!-version
         !*nosave!*
         !*strind
         !*struct
         cloc!*
         cmsg!*
         crbuf!*
         crbuflis!*
         crbuf1!*
         curline!*
         cursym!*
         eof!*
         erfg!*
         forkeywords!*
         ifl!*
         ipl!*
         initl!*
         inputbuflis!*
         key!*
         ofl!*
         opl!*
         ogctime!*
         otime!*
         program!*
         programl!*
         promptexp!*
         repeatkeywords!*
         resultbuflis!*
         st!*
         statcounter
         symchar!*
         tok!*
         ttype!*
         whilekeywords!*
         ws);

!*output := t;
eof!* := 0;
initl!* := '(fname!* outl!*);
statcounter := 0;

% The true REDUCE supervisory function is BEGIN, again defined in the
% system dependent part of this program.  However, most of the work is
% done by BEGIN1, which is called by BEGIN for every file encountered
% on input;

symbolic procedure errorp u;
   %returns true if U is an ERRORSET error format;
   atom u or cdr u;

symbolic procedure printprompt u;
   %Prints the prompt expression for input;
   progn(ofl!* and wrs nil, prin2 u, ofl!* and wrs cdr ofl!*);

symbolic procedure setcloc!*;
   % Used to set for file input a global variable CLOC!* to dotted pair
   % of file name and dotted pair of line and page being read.
   % Currently a place holder for system specific function, since not
   % supported in Standard LISP.  CLOC!* is used in the INTER and RCREF
   % modules.
   cloc!* := if null ifl!* then nil else car ifl!* . (1 . curline!*);

symbolic procedure commdemo;
   begin scalar echo,x,y,z,!*demo;
      echo := !*echo;
      !*echo := nil;
      x := ifl!*;
      terpri();
      rds nil;
      y:=readch();
      if null seprp y then
             % Read command line from terminal.
          begin scalar crbuf,crbuf1,crchar,ifl;
                crbuf := crbuf!*;
                crbuf!* := nil;
                crbuf1 := crbuf1!*;
                crbuf1!* := list y;
                crchar := crchar!*;
                crchar!* := '! ;
                ifl := ifl!*;
                ifl!* := nil;
                z := errorset!*('(command),t);
                z := if errorp z then '(algebraic(aeval 0))
                     else car z;
                     % eat rest of line quietly.
             q: y  := readch();
                if y neq !$eol!$ then go to q;
                rds cadr x;
                crbuf!* := crbuf;
                crbuf1!* := crbuf1;
                crchar!* := crchar;
                ifl!* := ifl;
                !*echo := echo;
          end
       else
             % Read command from current input.
          progn(rds cadr x, !*echo := echo, z := command());
       return z
   end;

symbolic procedure command1;
   % Innermost part of COMMAND. Can be used as hook to editor if needed.
   begin
      scan();
      setcloc!*();
      key!* := cursym!*;
      return xread1 nil
   end;

symbolic procedure command;
   begin scalar errmsg!*,loopdelimslist!*,mode,x,y;
      if !*demo and ifl!* then return commdemo()
       else if null !*slin or !*reduce4 then go to a;
      % Note key!* not set in this case.
      setcloc!*();
      y := if lreadfn!* then lispapply(lreadfn!*,nil) else read();
      go to b;
   a: crchar!* := readch1();  % Initialize crchar!*.
      if crchar!* = !$eol!$ then go to a;
      % Parse input.
      y := command1();
   b: if !*reduce4 then go to c
       else if !*struct then y := structchk y;
      if !*pret and (atom y or null (car y memq '(in out shut)))
        then if null y and cursym!* eq 'end then rprint 'end
              else progn(rprint y,terpri());
      if !*slin then return list('symbolic,y);
      x := form y;
      % Determine target mode.
      if flagp(key!*,'modefn) then mode := key!*
       else if null atom x % and null !*micro!-version
         and null(car x eq 'quote)
         and (null(idp car x
                 and (flagp(car x,'nochange)
                       or flagp(car x,'intfn)
                       or car x eq 'list))
           or car x memq '(setq setel setf)
                   and eqcar(caddr x,'quote))
        then mode := 'symbolic
       else mode := !*mode;
      return list(mode,convertmode1(x,nil,'symbolic,mode));
   c: if !*debug then progn(prin2 "Parse: ",prettyprint y);
    % Mode analyze input.
      if key!* eq '!*semicol!* then go to a;  % Should be a comment.
      if null !*reduce4 then y := form y else y := n!_form y;
%     y := n!_form y;
      if !*debug then progn(terpri(),prin2 "Form: ",prettyprint y);
      return y
   end;

symbolic procedure update!_prompt;
   begin
      statcounter := statcounter + 1;
      promptexp!* :=
         compress('!! . append(explode statcounter,
                     explode if null symchar!* or !*mode eq 'algebraic
                               then '!:!  else '!*! ));
      setpchar promptexp!*
   end;

symbolic procedure begin1;
   begin scalar parserr,result,x;
      otime!* := time();
      % The next line is that way for bootstrapping purposes.
      if getd 'gctime then ogctime!* := gctime() else ogctime!* := 0;
      cursym!* := '!*semicol!*;
  a:  if terminalp()
        then progn((if !*nosave!* or statcounter=0 then nil
                     else add2buflis()),
                   update!_prompt());
      !*nosave!* := nil;
      !*strind := 0;     % Used by some versions of input editor.
      parserr := nil;
      if !*time then lispeval '(showtime);   % Since a STAT.
      if !*output and null ofl!* and terminalp() and null !*defn
         and null !*lessspace
        then terpri();
      if tslin!*
        then progn(!*slin := car tslin!*,
                   lreadfn!* := cdr tslin!*,
                   tslin!* := nil);
      x := initl!*;
 b:   if x then progn(sinitl car x, x := cdr x, go to b);
      remflag(forkeywords!*,'delim);
      remflag(repeatkeywords!*,'delim);
      remflag( whilekeywords!*,'delim);
      if !*int then erfg!* := nil;   % To make editing work properly.
      if cursym!* eq 'end then progn(comm1 'end, return nil)
       % Note that key* was set from *previous* command in following.
       else if terminalp() and null(key!* eq 'ed)
        then printprompt promptexp!*;
      x := errorset!*('(command),t);
      condterpri();
      if errorp x then go to err1;
      x := car x;
      if car x eq 'symbolic and eqcar(cadr x,'xmodule)
        then result := xmodloop eval cadr x
       else result := begin11 x;
      if null result then go to a
       else if result eq 'end then return nil
       else if result eq 'err2 then go to err2
       else if result eq 'err3 then go to err3;
  c:  if crbuf1!* then
        progn(lprim "Closing object improperly removed. Redo edit.",
                crbuf1!* := nil, return nil)
        else if eof!*>4
         then progn(lprim "End-of-file read", return lispeval '(bye))
       else if terminalp()
        then progn(crbuf!* := nil,!*nosave!* := t,go to a)
       else return nil;
  err1:
      if eofcheck() or eof!*>0 then go to c
       else if x="BEGIN invalid" then go to a;
      parserr := t;
  err2:
      resetparser();  % In case parser needs to be modified.
  err3:
      erfg!* := t;
      if null !*int and null !*errcont
        then progn(!*defn := t,
                   !*echo := t,
                   (if null cmsg!*
                      then lprie "Continuing with parsing only ..."),
                   cmsg!* := t)
       else if null !*errcont
        then progn(result := pause1 parserr,
                   (if result then return null lispeval result),
                   erfg!* := nil)
       else erfg!* := nil;
      go to a
   end;

% Newrule!* is initialized in the following function, since it is not
% always reinitialized by the rule code.

symbolic procedure begin11 x;
   begin scalar errmsg!*,mode,result,newrule!*;
      if cursym!* eq 'end
         then if terminalp() and null !*lisp!_hook
                then progn(cursym!* := '!*semicol!*, !*nosave!* := t,
                           return nil)
               else progn(comm1 'end, return 'end)
       else if eqcar((if !*reduce4 then x else cadr x),'retry)
        then if programl!* then x := programl!*
              else progn(lprim "No previous expression",return nil);
      if null !*reduce4 then progn(mode := car x,x := cadr x);
      program!* := x;    % Keep it around for debugging purposes.
      if eofcheck() then return 'c else eof!* := 0;
      add2inputbuf(x,if !*reduce4 then nil else mode);
      if null atom x
          and car x memq '(bye quit)
        then if getd 'bye
               then progn(lispeval x, !*nosave!* := t, return nil)
              else progn(!*byeflag!* := t, return nil)
       else if null !*reduce4 and eqcar(x,'ed)
        then progn((if getd 'cedit and terminalp()
                      then cedit cdr x
                     else lprim "ED not supported"),
                   !*nosave!* := t, return nil)
       else if !*defn
        then if erfg!* then return nil
              else if null flagp(key!*,'ignore)
                and null eqcar(x,'quote)
               then progn((if x then dfprint x else nil),
                          if null flagp(key!*,'eval) then return nil);
      if !*output and ifl!* and !*echo and null !*lessspace
        then terpri();
      result := errorset!*(x,t);
      if errorp result or erfg!*
        then progn(programl!* := list(mode,x),return 'err2)
       else if !*defn then return nil;
      if null !*reduce4
        then if null(mode eq 'symbolic) then x := getsetvars x else nil
       else progn(result := car result,
                  (if null result then result := mkobject(nil,'noval)),
                  mode := type result,
                  result := value result);
      add2resultbuf((if null !*reduce4 then car result else result),
                    mode);
      if null !*output then return nil
       else if null(semic!* eq '!$)
        then if !*reduce4 then (begin
                   terpri();
                   if mode eq 'noval then return nil
                    else if !*debug then prin2t "Value:";
                   rapply1('print,list list(mode,result))
                 end)
       else if mode eq 'symbolic
              then if null car result and null(!*mode eq 'symbolic)
                     then nil
              else begin
                  terpri();
                  result:=
                       errorset!*(list('print,mkquote car result),t)
                    end
       else if car result
        then result := errorset!*(list('assgnpri,mkquote car result,
                                       (if x then 'list . x else nil),
                                       mkquote 'only),
                                  t);
      if null !*reduce4
        then return if errorp result then 'err3 else nil
       else if null(!*mode eq 'noval) % and !*debug
        then progn(terpri(), prin2 "of type: ", print mode);
      return nil
   end;

symbolic procedure getsetvarlis u;
   if null u then nil
    else if atom u then errach list("getsetvarlis",u)
    else if atom car u then car u . getsetvarlis cdr u
    else if caar u memq '(setel setk)   % setk0.
     then getsetvarlis cadar u . getsetvarlis cdr u
    else if caar u eq 'setq then mkquote cadar u . getsetvarlis cdr u
    else car u . getsetvarlis cdr u;

symbolic procedure getsetvars u;
   if atom u then nil
    else if car u memq '(setel setk)   % setk0.
     then getsetvarlis cadr u . getsetvars caddr u
    else if car u eq 'setq then mkquote cadr u . getsetvars caddr u
    else nil;

flag ('(deflist flag fluid global remflag remprop unfluid),'eval);

symbolic procedure close!-input!-files;
   % Close all input files currently open;
   begin
      if ifl!* then progn(rds nil,ifl!* := nil);
  aa: if null ipl!* then return nil;
      close cadar ipl!*;
      ipl!* := cdr ipl!*;
      go to aa
   end;

symbolic procedure close!-output!-files;
   % Close all output files currently open;
   begin
      if ofl!* then progn(wrs nil,ofl!* := nil);
  aa: if null opl!* then return nil;
      close cdar opl!*;
      opl!* := cdr opl!*;
      go to aa
   end;

symbolic procedure add2buflis;
   begin
      if null crbuf!* then return nil;
      crbuf!* := reversip crbuf!*;   %put in right order;
   a: if crbuf!* and seprp car crbuf!*
        then progn(crbuf!* := cdr crbuf!*, go to a);
      crbuflis!* := (statcounter . crbuf!*) . crbuflis!*;
      crbuf!* := nil
   end;

symbolic procedure add2inputbuf(u,mode);
   begin
      if null terminalp() or !*nosave!* then return nil;
      inputbuflis!* := list(statcounter,mode,u) . inputbuflis!*
   end;

symbolic procedure add2resultbuf(u,mode);
   begin
      if mode eq 'symbolic
       or (null u and (null !*reduce4 or null(mode eq 'empty!_list)))
       or !*nosave!* then return nil;
      if !*reduce4 then putobject('ws,u,mode) else ws := u;
      if terminalp()
        then resultbuflis!* := (statcounter . u) . resultbuflis!*
   end;

symbolic procedure condterpri;
   !*output and !*echo and !*extraecho and (null !*int or ifl!*)
        and null !*defn and null !*demo and terpri();

symbolic procedure eofcheck;
   % true if an end-of-file has been read in current input sequence;
   program!* eq !$eof!$ and ttype!*=3 and (eof!* := eof!*+1);

symbolic procedure resetparser;
   %resets the parser after an error;
   if null !*slin then comm1 t;

symbolic procedure terminalp;
   %true if input is coming from an interactive terminal;
   !*int and null ifl!*;

symbolic procedure dfprint u;
   % Looks for special action on a form, otherwise prettyprints it.
   if dfprint!* then lispapply(dfprint!*,list u)
    else if cmsg!* then nil
    else if null eqcar(u,'progn) then prettyprint u
    else begin
            a:  u := cdr u;
                if null u then return nil;
                dfprint car u;
                go to a
         end;

remprop('showtime,'lose);  % Temporary.

symbolic procedure showtime;
   begin scalar x,y;
      x := otime!*;
      otime!* := time();
      x := otime!* - x;
      y := ogctime!*;
      ogctime!* := gctime();
      y := ogctime!* - y;
      if 'psl memq lispsystem!* then x := x - y;
      terpri();
      prin2 "Time: "; prin2 x; prin2 " ms";
      if null(y=0)
        then progn(prin2 "  plus GC time: ", prin2 y, prin2 " ms");
      terpri();
      return if !*reduce4 then mknovalobj() else nil
   end;

symbolic procedure sinitl u;
   set(u,eval get(u,'initl));

symbolic procedure read!-init!-file name;
  % Read a resource file in REDUCE syntax. Quiet input.
  % Algebraic mode is used unless rlisp88 is on.
  % Look for file in home directory. If no home directory
  % is defined, use the current directory.
  begin scalar !*errcont,!*int,base,fname,oldmode,x,y;
   base := getenv "home" or getenv "HOME" or
           ((x := getenv "HOMEDRIVE") and (y := getenv "HOMEPATH")
              and concat2(x,y)) or ".";
   if not(car reversip explode2 base eq '!/)
     then base := concat2(base,"/"); % FJW
   fname := if filep(x := concat2(base,concat2(".", % FJW
                                                concat2(name,"rc"))))
               then x
             else if filep(x := concat2(base,concat2(name,".rc"))) % FJW
              then x
             else if filep
                     (x := concat2(getenv "HOME",concat2(name,".INI")))
               then x; % for (Open) VMS
   if null fname then return nil
    else if !*mode neq 'algebraic and null !*rlisp88
     then progn(oldmode := !*mode, !*mode := 'algebraic);
   x := errorset(list('in!_list1,fname,nil),nil,nil);
   if errorp x or erfg!* then
     progn(terpri(),
           prin2 "***** Error processing resource file ",
           prin2t fname);
   close!-input!-files();
   erfg!*:= cmsg!* := !*defn := nil;
   if oldmode then !*mode := oldmode;
   terpri();
   statcounter := 0
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/module-dist.red0000644000175000017500000001221611526203062024561 0ustar  giovannigiovanni% module module; % Support for module and package use.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% fluid '(!*backtrace !*mode !*redefmsg !*usermode);
fluid '(!*backtrace !*mode);

global '(exportslist!* importslist!* loaded!-packages!* mode!-list!*);

!*mode := 'symbolic;   % initial value.

% Note: !*redefmsg and !*usermode are only currently used by PSL.

symbolic procedure exports u;
   begin exportslist!* := union(u,exportslist!*) end;

symbolic procedure imports u;
   begin importslist!* := union(u,importslist!*) end;

symbolic procedure module u;
   % Sets up a module definition.
   begin
      mode!-list!* := !*mode . mode!-list!*;
      !*mode := 'symbolic
   end;

symbolic procedure endmodule;
   begin
      if null mode!-list!*
        then rederr  "ENDMODULE called outside module";
      exportslist!* := nil;
      importslist!* := nil;
      !*mode := car mode!-list!*;
      mode!-list!* := cdr mode!-list!*
   end;

deflist('((exports rlis) (imports rlis) (module rlis)),'stat);

put('endmodule,'stat,'endstat);

flag('(endmodule),'go);

flag('(module endmodule),'eval);

% Support for package creation and loading.

symbolic procedure create!-package(u,v);
   % Make module list u into a package with path v.  Dummy for now.
   car u;

create!-package('(module),'(rlisp));

put('load,'stat,'rlis);

put('load,'formfn,'formload);

symbolic procedure formload(u,vars,mode);
   list((if eq(mode,'symbolic) then 'evload else 'load!_package),
	mkquote cdr u);

symbolic procedure load!-package u;
   begin scalar x;
      if null idp u then rederr list(u,"is not a package name")
       else if memq(u,loaded!-packages!*)
%       then progn(lprim list("Package",u,"already loaded"), return u)
        then return u
       else if or(atom(x:= errorset(list('evload,list('quote,list u)),
                               nil,!*backtrace)),
                  cdr x)
        then rederr
           list("error in loading package",u,"or package not found");
      if (x := get(u,'patchfn))
        then begin scalar !*usermode,!*redefmsg; eval list x end;
      loaded!-packages!* := u . loaded!-packages!*
   end;

% Now a more friendly user version.

remprop('load!_package,'stat);

symbolic procedure load!_package u;
   begin scalar x;
      x := u;
   a: if null x then return nil;
      load!-package car x;
      x := cdr x;
      go to a
   end;

symbolic procedure packages!_to!_load u;
   %% FJW: Load other packages at package load time only, i.e. do not
   %% load during building (hence not to be flagged eval).
   load!_package u;

put('load!_package,'stat,'rlis);

put('packages!_to!_load,'stat,'rlis);

flag('(load!-package load!_package),'eval);


% Support for patching REDUCE 3.5 sources.

symbolic procedure patchstat;
   % Read a patch for a given package.
   begin scalar !*mode,u,v,x,y,z,z2;
      x := scan();   % Package name.
      scan();        % Remove semicolon.
 a:   !*mode := 'symbolic;
      y := xread nil;
      if eqcar(y,'symbolic) then y := cadr y
       else if flagpcar(y,'modefn)
        then progn(!*mode := car y, y := cadr y);
      if eq(y,'endpatch)
       then progn(u := dated!-gensym x,
                  z2 :=  list('de,u,nil,'progn . reversip z) . z2,
                  z2 := list('put,mkquote x,mkquote 'patchfn,mkquote u)
                           . z2,
                  return ('patch . reversip z2))
       else if eqcar(y,'procedure)
        then progn(u := dated!-gensym v,
               v := cadr y,
               z := list('copyd,mkquote v,mkquote u) . z,
               z2  := convertmode(('procedure . u . cddr y),nil,
                                  'symbolic,!*mode)
                     . z2)
       else z := convertmode(y,nil,'symbolic,!*mode) . z;
      go to a;
   end;

put('patch,'stat,'patchstat);

symbolic procedure formpatch(u,vars,mode);
   'progn . cdr u;

put('patch,'formfn,'formpatch);

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/tok.red0000644000175000017500000004237011526203062023134 0ustar  giovannigiovannimodule tok; % Identifier and reserved character reading.

% Author: Anthony C. Hearn.
% Modifications by: Arthur Norman.

% Copyright (c) 2001 Anthony C. Hearn.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*adjprec !*comment !*defn !*eoldelimp !*lower !*minusliter
        !*quotenewnam semic!*);

% Note *raise is global in the SL Report, but treated as fluid here.

global '(!$eof!$
         !$eol!$
         !*micro!-version
         !*raise
         !*savecomments!*
         comment!*
         crbuf!*
         crbuf1!*
         crchar!*
         curline!*
         cursym!*
         eof!*
         ifl!*
         nxtsym!*
         outl!*
         ttype!*);

flag('(adjprec),'switch);

!*quotenewnam := t;

crchar!* := '! ;

curline!* := 1;

% The function TOKEN defined below is used for reading identifiers
% and reserved characters (such as parentheses and infix operators).
% It is called by the function SCAN, which translates reserved
% characters into their internal name, and sets up the output of the
% input line.  The following definitions of TOKEN and SCAN are quite
% general, but also inefficient.  The reading process can often be
% speeded up considerably if these functions (especially token) are
% written in terms of the explicit LISP used.

symbolic procedure prin2x u;
  outl!* := u . outl!*;

symbolic procedure mkstrng u;
   %converts the uninterned id U into a string;
   %if strings are not constants, this should be replaced by
   %list('string,u);
   u;

symbolic procedure readch1;
   begin scalar x;
      if null terminalp()
        then progn(x := readch(),
                   x eq !$eol!$ and (curline!* := curline!*+1),
                   return x)
       else if crbuf1!*
        then begin x := car crbuf1!*; crbuf1!* := cdr crbuf1!* end
       else x := readch();
      crbuf!* := x . crbuf!*;
      return x
   end;

symbolic procedure tokquote;
   begin
      crchar!* := readch1();
      nxtsym!* := mkquote rread();
      ttype!* := 4;
      return nxtsym!*
   end;

put('!','tokprop,'tokquote);

symbolic procedure token!-number x;
   % Read and return a valid number from input.
   % Adjusted by A.C. Norman to be less sensitive to input case and to
   % support hex numbers.
   begin scalar dotp,power,sign,y,z;
      power := 0;
      ttype!* := 2;
    num1:
      if y or null(x eq '!)) then y := x . y;
      if dotp then power := power - 1;
    num2:
      if (x := readch1()) eq '!.
         then if dotp
                then rerror('rlisp,3,"Syntax error: improper number")
               else progn(dotp := t, go to num2)
       else if digit x then go to num1
       else if y = '(!0) and (x eq '!x or x eq '!X) then go to hexnum
       else if x eq '!\ then progn(readch(), go to num2)
       else if null(x eq '!e or x eq '!E) then go to ret;
      % Case of number with embedded or trailing E.
      dotp := t;
      if (x := readch1()) eq '!- then sign := t
       else if x eq '!+ then nil
       else if null digit x then go to ret
       else z := list x;
   nume1:
      if null digit(x := readch1()) then go to nume2;
      z := x . z;
      go to nume1;
   hexnum:
      y := 0;
   hexnum1:
      if not (z := get(x := readch1(), 'hexdigit)) then go to ret1;
      y := 16*y + z;
      go to hexnum1;
   nume2:
      if null z then rerror('rlisp,4,"Syntax error: improper number");
      z := compress reversip!* z;
      if sign then power := power - z else power := power + z;
   ret:
      y := compress reversip!* y;
   ret1:
      nxtsym!* := if dotp then '!:dn!: . (y . power)
                   else if !*adjprec then '!:int!: . (y . nil)
                   else y;
      crchar!* := x;
      return nxtsym!*
   end;

deflist(
 '((!0 0)  (!1 1)  (!2 2)  (!3 3)  (!4 4)
   (!5 5)  (!6 6)  (!7 7)  (!8 8)  (!9 9)
   (!a 10) (!b 11) (!c 12) (!d 13) (!e 14) (!f 15)
   (!A 10) (!B 11) (!C 12) (!D 13) (!E 14) (!F 15)), 'hexdigit);

symbolic procedure token1;
   begin scalar x,y;
        x := crchar!*;
    a:  if seprp x and null(x eq !$eol!$ and !*eoldelimp)
          then progn(x := readch1(), go to a)
         else if digit x then return token!-number x
         else if liter x then go to letter
         else if (y := get(x,'tokprop)) then return lispapply(y,nil)
         else if x eq '!% and null !*savecomments!* then go to coment
         else if x eq '!! and null(!*micro!-version and null !*defn)
          then go to escape
         else if x eq '!" then go to string;
        ttype!* := 3;
        if x eq !$eof!$ then prog2(crchar!* := '! ,filenderr());
        nxtsym!* := x;
        if delcp x then crchar!*:= '!  else crchar!*:= readch1();
        if null(x eq '!- and digit crchar!* and !*minusliter)
          then go to c;
        x := token!-number crchar!*;
        if numberp x then return apply1('minus,x);  % For bootstrapping.
        rplaca(cdr x,apply1('minus,cadr x));        % Also for booting.
        return x;
    escape:
        begin scalar raise,!*lower;
           raise := !*raise;
           !*raise := nil;
           y := x . y;
           x := readch1();
           !*raise := raise
        end;
    letter:
        ttype!* := 0;
    let1:
        y := x . y;
        if digit (x := readch1()) or liter x then go to let1
         else if x eq '!! then go to escape
         else if x eq '!- and !*minusliter
          then progn(y := '!! . y, go to let1)
         else if x eq '!_ then go to let1;    % Allow _ as letter.
        nxtsym!* := intern compress reversip!* y;
        crchar!* := x;
    c:  return nxtsym!*;
%   minusl:
%       if digit (x := readch1())
%         then progn(crchar!* := x, return(nxtsym!* := 'minus))
%        else progn(y := '!- . '!! . y, go to letter);
    string:
        begin scalar raise,!*lower;
           raise := !*raise;
           !*raise := nil;
       strinx:
           y := x . y;
           if (x := readch1()) eq !$eof!$
             then progn(!*raise := raise,
                        crchar!* := '! ,
                        lpriw("***** End-of-file in string",nil),
                        filenderr())
            else if null(x eq '!") then go to strinx;
           y := x . y;
           % Now check for embedded string character.
           x := readch1();
           if x eq '!" then go to strinx;
           nxtsym!* := mkstrng compress reversip!* y;
           !*raise := raise
         end;
        ttype!* := 1;
        crchar!* := x;
        go to c;
    coment:
        begin scalar !*lower,raise;
        raise := !*raise;
        !*raise := nil;
    comm1: if null(readch1() eq !$eol!$) then go to comm1;
        !*raise := raise
        end;
        x := readch1();
        go to a
   end;

symbolic procedure tokbquote;
   begin
     crchar!* := readch1();
      nxtsym!* := list('backquote,rread());
      ttype!* := 3;
      return nxtsym!*
   end;

put('!`,'tokprop,'tokbquote);

symbolic procedure token;
   %This provides a hook for a faster TOKEN;
   token1();

symbolic procedure filenderr;
   begin
      eof!* := eof!*+1;
      if terminalp() then error1()
       else error(99,if ifl!*
                       then list("End-of-file read in file",car ifl!*)
                      else "End-of-file read")
   end;

symbolic procedure ptoken;
   begin scalar x;
        x := token();
        if x eq '!) and eqcar(outl!*,'! ) then outl!*:= cdr outl!*;
           %an explicit reference to OUTL!* used here;
        prin2x x;
        if null ((x eq '!() or (x eq '!))) then prin2x '! ;
        return x
   end;

symbolic procedure rread1;
   % Modified to use QUOTENEWNAM's for ids.
   % Note that handling of reals uses symbolic mode, regardless of
   % actual mode.
   begin scalar x,y;
        x := ptoken();
        if null (ttype!*=3)
          then return if idp x
                        then if !*quotenewnam
                                and (y := get(x,'quotenewnam))
                               then y
                              else x
                       else if eqcar(x,'!:dn!:)
                        then dnform(x,nil,'symbolic)
                       else x
         else if x eq '!( then return rrdls()
         else if null (x eq '!+ or x eq '!-) then return x;
        y := ptoken();
        if eqcar(y,'!:dn!:) then y := dnform(y,nil,'symbolic);
        if null numberp y
          then progn(nxtsym!* := " ",
                     symerr("Syntax error: improper number",nil))
         else if x eq '!- then y := apply1('minus,y);
           % We need this construct for bootstrapping purposes.
        return y
   end;

symbolic procedure rrdls;
   begin scalar x,y,z;
    a:  x := rread1();
        if null (ttype!*=3) then go to b
         else if x eq '!) then return z
         else if null (x eq '!.) then go to b;
        x := rread1();
        y := ptoken();
        if null (ttype!*=3) or null (y eq '!))
          then progn(nxtsym!* := " ",symerr("Invalid S-expression",nil))
         else return nconc(z,x);
    b: z := nconc(z,list x);
       go to a
   end;

symbolic procedure rread;
   progn(prin2x " '",rread1());

symbolic procedure delcp u;
   % Returns true if U is a semicolon, dollar sign, or other delimiter.
   % This definition replaces the one in the BOOT file.
   flagp(u,'delchar);

flag('(!; !$),'delchar);

symbolic procedure toknump x;
   numberp x or eqcar(x,'!:dn!:) or eqcar(x,'!:int!:);

% The following version of SCAN provides RLISP with a facility for
% conditional compilation.  The protocol is that text is included or
% excluded at the level of tokens.  Control by use of new reserved
% tokens !#if, !#else and !#endif.  These are used in the form:
%    !#if (some Lisp expression for use as a condition)
%    ... RLISP input ...
%    !#else
%    ... alternative RLISP input ...
%    !#endif
%
% The form
%    !#if C1 ... !#elif C2 ... !#elif C3 ... !#else ... !#endif
% is also supported.
%
% Conditional compilation can be nested.  If the Lisp expression used
% to guard a condition causes an error it is taken to be a FALSE
% condition. It is not necessary to have an !#else before !#endif if no
% alternative text is needed.  Although the examples here put !#if etc
% at the start of lines this is not necessary (though it may count as
% good style?).  Since the condition will be read using RLISPs own
% list-reader there could be conditional compilation guarding parts of
% it - the exploitation of that possibility is to be discouraged!

% Making the condition a raw Lisp expression makes sure that parsing it
% is easy. It makes it possible to express arbitrary conditions, but it
% is hoped that most conditions will not be very elaborate - things like
%    !#if (member 'psl lispsystem!*)
%         magic();
%    !#else
%         error();
%    !#endif
% or
%    !#if debugging!-mode  % NB if variable is unset that counts as nil
%    print "message";      % so care should be taken to select the most
%    !#endif               % useful default sense for such tests
% should be about as complicated as reasonable people need.
%
% Two further facilities are provided:
%    !#eval (any lisp expression)
% causes that expression to be evaluated at parse time.  Apart from any
% side-effects in the evaluation the text involved is all ignored. It is
% expected that this will only be needed in rather curious cases, for
% instance to set system-specific options for a compiler.

%    !#define symbol value
% where the value should be another symbol, a string or a number,
% causes the first symbol to be mapped onto the second value wherever
% it occurs in subsequent input.  This uses exactly the same mechanism
% as the existing REDUCE "define" statement and so has the same
% limitations.  The use of a hook in SCAN to support this ensures that
% the !#define can be written anywhere in REDUCE source code (eg within
% a procedure definition) and will still apply while the program
% involved is parsed.  No special facility for undoing the effect of a
% !#define is provided, but the general-purpose !#eval could be used to
% remove the 'newnam property that is involved.

symbolic procedure addcomment u;
 %  if commentlist!*
 %    then cursym!* := 'comment . aconc(reversip commentlist!*,u)
 %   else
   cursym!* := u;

symbolic procedure scan;
   begin scalar bool,x,y;
        if null (cursym!* eq '!*semicol!*) then go to b;
    a:  nxtsym!* := token();
    b:  if null atom nxtsym!* and null toknump nxtsym!*
          then go to q1
         else if nxtsym!* eq 'else or cursym!* eq '!*semicol!*
         then outl!* := nil;
        prin2x nxtsym!*;
    c:  if null idp nxtsym!* then go to l
         else if (x:=get(nxtsym!*,'newnam)) and
                        (null (x=nxtsym!*)) then go to new
         else if nxtsym!* eq 'comment
          then progn(x := read!-comment1 'comment,
                     if !*comment then return x else go to a)
         else if nxtsym!* eq '!% and ttype!*=3
          then progn(x := read!-comment1 'percent!_comment,
                     if !*comment then return x else go to a)
         else if nxtsym!* eq '!#if then go to conditional
         else if nxtsym!* eq '!#else or
                 nxtsym!* eq '!#elif then progn(nxtsym!* := x := nil,
                                                go to skipping)
         else if nxtsym!* eq '!#endif then go to a
         else if nxtsym!* eq '!#eval then progn(
                     errorset(rread(), !*backtrace, nil),
                     go to a)
         else if nxtsym!* eq '!#define then progn(
                     x := errorset(rread(), !*backtrace, nil),
                     progn(if errorp x then go to a),
                     y := errorset(rread(), !*backtrace, nil),
                     progn(if errorp y then go to a),
                     put(x, 'newnam, y),
                     go to a)
         else if null(ttype!* = 3) then go to l
         else if nxtsym!* eq !$eof!$ then return filenderr()
         else if nxtsym!* eq '!' then rederr "Invalid QUOTE"
         else if !*eoldelimp and nxtsym!* eq !$eol!$ then go to delim
         else if null (x:= get(nxtsym!*,'switch!*)) then go to l
         else if eqcar(cdr x,'!*semicol!*) then go to delim;
        bool := seprp crchar!*;
   sw1: nxtsym!* := token();
        if null(ttype!* = 3) then go to sw2
         else if nxtsym!* eq !$eof!$ then return filenderr()
         else if car x then go to sw3;
   sw2: cursym!*:=cadr x;
        bool := nil;
        if cursym!* eq '!*rpar!* then go to l2
         else return addcomment cursym!*;
   sw3: if bool or null (y:= atsoc(nxtsym!*,car x)) then go to sw2;
        prin2x nxtsym!*;
        x := cdr y;
        if null car x and cadr x eq '!*Comment!*
          then progn(comment!* := read!-comment(),go to a);
        go to sw1;
  conditional:
% The conditional expression used here must be written in Lisp form
        x := errorset(rread(), !*backtrace, nil);
% errors in evaluation count as NIL
        if null errorp x and car x then go to a;
        x := nil;
  skipping:
% I support nesting of conditional inclusion.
        if nxtsym!* eq '!#endif then
           if null x then go to a else x := cdr x
        else if nxtsym!* eq '!#if then x := nil . x
        else if (nxtsym!* eq '!#else) and null x then go to a
        else if (nxtsym!* eq '!#elif) and null x then go to conditional;
        nxtsym!* := token();
        if (ttype!*=3) and (nxtsym!* eq !$eof!$)
          then return filenderr()
         else go to skipping;
  delim:
        semic!*:=nxtsym!*;
        return addcomment '!*semicol!*;
  new:  nxtsym!* := x;
        if stringp x then go to l
        else if atom x then go to c
        else go to l;
  q1:   if null (car nxtsym!* eq 'string) then go to l;
        prin2x " ";
        prin2x cadr(nxtsym!* := mkquote cadr nxtsym!*);
  l:    cursym!*:=nxtsym!*;
        nxtsym!* := token();
        if nxtsym!* eq !$eof!$ and ttype!* = 3 then return filenderr();
  l2:   if numberp nxtsym!*
           or (atom nxtsym!* and null get(nxtsym!*,'switch!*))
          then prin2x " ";
        return addcomment cursym!*
   end;

symbolic procedure read!-comment1 u;
   begin scalar !*lower,raise;
      raise := !*raise;
      !*raise := nil;
 comm1: if null(delcp crchar!* and null(crchar!* eq !$eol!$))
          then progn(crchar!* := readch1(), go to comm1);
      crchar!* := '! ;
      !*raise := raise;
      condterpri()
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/form.red0000644000175000017500000006144611526203062023307 0ustar  giovannigiovannimodule form;  % Performs a mode analysis of parsed forms.

% Author: Anthony C. Hearn.

% Modifications by: Jed Marti, Arthur C. Norman.

% Copyright (c) 1993 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*!*a2sfn !*cref !*defn !*mode !*reduce4 !*rlisp88
        current!-modulus fname!* ftype!*);

global '(!*argnochk !*comp !*composites !*force !*micro!-version
         !*vars!* cursym!*);

!*!*a2sfn := 'aeval;

flag('(algebraic symbolic),'modefn);

symbolic procedure formcond(u,vars,mode);
   'cond . formcond1(cdr u,vars,mode);

symbolic procedure formcond1(u,vars,mode);
   if null u then nil
    else list(formbool(caar u,vars,mode),formc(cadar u,vars,mode))
       % FORM1 here leaves out top level REVAL.
              . formcond1(cdr u,vars,mode);

put('cond,'formfn,'formcond);




% See formprog for commentary.
% NOTE that this can create a LAMBDA with a PROGN, as
% in (lambda (q) (progn 
%                  (declare (special q))
%                  original_body)
% which hides the DECLARE within a PROGN. This is so that there
% remains just one item in the body.

symbolic procedure formlamb(u,vars,mode);
   begin scalar v, b, fl;
      v := cadr u;
      b := list form1(caddr u, pairvars(v,vars,mode),mode);
!#if (memq 'csl lispsystem!*)
l:    if null v then go to x;
      if fluidp car v or globalp car v then fl := car v . fl;
      v := cdr v;
      go to l;
x:    if fl then b := list('declare, 'special . fl) . b;
      v := cadr u;
!#endif
      return 'lambda . v . b;
   end;

put('lambda,'formfn,'formlamb);

symbolic procedure formprogn(u,vars,mode);
   'progn . formclis(cdr u,vars,mode);

put('progn,'formfn,'formprogn);

symbolic procedure expdrmacro u;
   % Returns the macro form for U if expansion is permitted.
   begin scalar x;
      if null(x := getrmacro u) or flagp(u,'noexpand) then return nil
%      else if null(null !*cref and (null !*defn or car x eq 'smacro)
%         or flagp(u,'expand) or !*force)
       else if !*cref and null flagp(u,'expand) and null !*force
        then return nil
       else return x
   end;

symbolic procedure getrmacro u;
   %returns a Reduce macro definition for U, if one exists,
   %in GETD format;
   begin scalar x;
      return if not idp u then nil
       else if (x := getd u) and car x eq 'macro then x
       else if (x := get(u,'smacro)) then 'smacro . x
       else nil
   end;

symbolic procedure applmacro(u,v,w); apply1(u,w . v);

put('macro,'macrofn,'applmacro);

flag('(ed go quote),'noform);

symbolic procedure set!-global!-mode u;
   begin
      !*mode := u;
      return list('null,list('setq,'!*mode,mkquote u))
   end;

symbolic procedure form1(u,vars,mode);
   begin scalar x,y;
      if atom u
        then return if not idp u then u
                     else if u eq 'ed then list u
                     else if flagp(u,'modefn) then set!-global!-mode u
                     else if x:= get(mode,'idfn)
                      then apply2(x,u,vars)
                     else u
       else if not atom car u then return form2(u,vars,mode)
       else if not idp car u then typerr(car u,"operator")
       else if car u eq 'comment
        then return form1(car lastpair u,vars,mode)
       else if flagp(car u,'noform) then return u
       else if arrayp car u
%         and (mode eq 'symbolic or intexprlisp(cdr u,vars))
          and mode eq 'symbolic
        then return list('getel,intargfn(u,vars,mode))
       else if cdr u and (get(car u,'rtype) eq 'vector
             or vectorp cadr u or flagpcar(cadr u,'vecfn))
        then return getvect(u,vars,mode)
       else if flagp(car u,'modefn)
        then return convertmode(cadr u,vars,mode,car u)
       else if (x := get(car u,'formfn))
        then return macrochk(apply3(x,u,vars,mode),mode)
       else if get(car u,'stat) eq 'rlis
        then return macrochk(formrlis(u,vars,mode),mode)
%      else if (x := getd car u) and eqcar(x, 'macro) and
%              not(mode eq 'algebraic) then
%            return <>
%      else if flagp(car u,'type) then blocktyperr car u
       else if car u eq '!*comma!*
        then if not atom cadr u and atom caddr u
                 and flagp(caadr u,'type)
%                and(get(caddr u,'stat) eq 'decstat)
               then blocktyperr caadr u
              else rerror('rlisp,10,
                          list("Syntax error: , invalid after",cadr u));
      % Exclude algebraic operator with same name as symbolic function.
      if mode eq 'symbolic or flagp(car u,'opfn)
        then argnochk u;
      x := formlis(cdr u,vars,mode);
      y := if x=cdr u then u else car u . x;
      return if mode eq 'symbolic
              or get(car u,'stat)
              or cdr u and eqcar(cadr u,'quote)
                       and null(!*micro!-version and null !*defn)
              or intexprnp(y,vars) and null !*composites
                 and current!-modulus=1
               then macrochk(y,mode)
              else if not(mode eq 'algebraic)
               then convertmode(y,vars,mode,'algebraic)
              else ('list . algid(car u,vars) . x)
   end;

symbolic procedure form2(u,vars,mode);
   begin scalar x;
      if x := get(caar u,'form2fn) then return apply3(x,u,vars,mode)
        else typerr(car u,"operator")
   end;

put('lambda,'form2fn,'formlis);

symbolic procedure argnochk u;
   begin scalar x;
      if null !*argnochk then return u
       else if (x := argsofopr car u) and x neq length cdr u
          %% and null get(car u,'simpfn)
          and null (get(car u,'simpfn) or get(car u,'psopfn)) % FJW ?????
        then rerror('rlisp,11,list(car u,"called with",
                                   length cdr u,
                                   if length cdr u=1 then "argument"
                                    else "arguments",
                                   "instead of",x))
      else return u
   end;

symbolic procedure argsofopr u;
   % This function may be optimizable in various implementations.
   get(u,'number!-of!-args);

symbolic procedure intexprnp(u,vars);
   %determines if U is an integer expression;
    if atom u then if numberp u then fixp u
                   else if (u := atsoc(u,vars)) then cdr u eq 'integer
                   else nil
     else idp car u and flagp(car u,'intfn) and intexprlisp(cdr u,vars);

symbolic procedure intexprlisp(u,vars);
   null u or intexprnp(car u,vars) and intexprlisp(cdr u,vars);

flag('(difference minus plus times),'intfn);
   % EXPT is not included in this list, because a negative exponent can
   % cause problems (i.e., result can be rational);

symbolic procedure formlis(u,vars,mode);
   begin scalar x;
   a: if null u then return reversip!* x;
      x := form1(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure formclis(u,vars,mode);
   begin scalar x;
   a: if null u then return reversip!* x;
      x := formc(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure form u;
   if null atom u and flagp(car u,'always_nform)
     then n_form u   % REDUCE 4.
    else if null !*rlisp88 then form1(u,!*vars!*,!*mode)
    else if null(!*mode eq 'symbolic)
        or flagp(u,'modefn) and null(u eq 'symbolic)
        or flagpcar(u,'modefn) and null(car u eq 'symbolic)
     then typerr("algebraic expression","Rlisp88 form")
    else form1(u,!*vars!*,!*mode);

symbolic procedure macrochk(u,mode);
   begin scalar y;
      % Expands U if CAR U is a macro and expansion allowed.
      % This model has the problem that nested macros are not expanded
      % at this point (but they will be in the compiler).
      if atom u then return u
       else if (y := expdrmacro car u)
        and (mode eq 'symbolic or idp car u and flagp(car u,'opfn))
        then return apply3(get(car y,'macrofn),cdr y,cdr u,car u)
       else return u
   end;

put('symbolic,'idfn,'symbid);

symbolic procedure symbid(u,vars);
   <>;

put('algebraic,'idfn,'algid);

symbolic procedure algid(u,vars);
   if atsoc(u,vars) or flagp(u,'share) then u else mkquote u;

put('integer,'idfn,'intid);

symbolic procedure intid(u,vars);
   begin scalar x,y;
      return if (x := atsoc(u,vars))
        then if cdr x eq 'integer then u
               else if y := get(cdr x,'integer)
                then apply2(y,u,vars)
               else if cdr x eq 'scalar then !*!*a2i(u,vars)
               else rerror('rlisp,12,
                           list(cdr x,"not convertable to INTEGER"))
      else !*!*a2i(mkquote u,vars)
   end;

symbolic procedure convertmode(exprn,vars,target,source);
   convertmode1(form1(exprn,vars,source),vars,target,source);

symbolic procedure convertmode1(exprn,vars,target,source);
   begin scalar x;
      if source eq 'real then source := 'algebraic;
      if target eq 'real then target := 'algebraic;
      if target eq source then return exprn
       else if idp exprn and (x := atsoc(exprn,vars))
          and not(cdr x memq '(integer scalar real))
          and not(cdr x eq source)
        then return convertmode(exprn,vars,target,cdr x)
       else if not (x := get(source,target))
        then typerr(source,target)
       else return apply2(x,exprn,vars)
   end;

put('algebraic,'symbolic,'!*!*a2s);

put('symbolic,'algebraic,'!*!*s2a);

symbolic procedure !*!*a2s(u,vars);
   % It would be nice if we could include the ATSOC(U,VARS) line,
   % since in many cases that would save recomputation. However,
   % in any sequential process, assignments or substitution rules
   % can change the value of a variable, so we have to check its
   % value again.  More comprehensive analysis could certainly
   % optimize this.  We could also avoid wrapping an integer, thus
   % making a mode change only occur within an expression.
   if null u then rederr "tell Hearn!!"
%   else if constantp u and null fixp u
%     or intexprnp(u,vars) and null !*composites
%                and null current!-modulus
    else if flagpcar(u,'nochange) and not(car u eq 'getel)
     then u
    % Expressions involving "random" cannot be cached.
    % We need smember rather than smemq in case the "random" is
    % in a quoted expression.
!#if (memq 'csl lispsystem!*)
    else if smember('random,u) then
     list(list('lambda,'(!*uncached),
       list('progn, '(declare (special !*uncached)), list(!*!*a2sfn,u))),t)
!#else
    else if smember('random,u) then
     list(list('lambda,'(!*uncached),list(!*!*a2sfn,u)),t)
!#endif
    else list(!*!*a2sfn,u);

symbolic procedure !*!*s2a(u,vars); u;

symbolic procedure formc(u,vars,mode);
   %this needs to be generalized;
   if !*rlisp88 and flagpcar(u,'modefn) and null(car u eq 'symbolic)
     then typerr("algebraic expression","Rlisp88 form")
    else if mode eq 'algebraic and intexprnp(u,vars) then u
    else convertmode(u,vars,'symbolic,mode);

symbolic procedure intargfn(u,vars,mode);
   % transforms array element U into expression with integer arguments.
   % Array name is treated as an algebraic variable;
   begin scalar x,y;
      y := cdr u;
   a: if y then progn(x := convertmode(car y,vars,'integer,mode) . x,
                      y := cdr y,
                      go to a);
      return 'list . form1(car u,vars,'algebraic) . reversip!* x
   end;

put('algebraic,'integer,'!*!*a2i);

symbolic procedure !*!*a2i(u,vars);
   if intexprnp(u,vars) then u else list('ieval,u);

symbolic procedure ieval u; !*s2i reval u;

flag('(ieval),'opfn);   % To make it a symbolic operator.

flag('(ieval),'nochange);

put('symbolic,'integer,'!*!*s2i);

symbolic procedure !*!*s2i(u,vars);
   if fixp u then u else list('!*s2i,u);

symbolic procedure !*s2i u;
   if fixp u then u else typerr(u,"integer");

put('integer,'symbolic,'identity);

symbolic procedure identity(u,vars); u;

symbolic procedure formbool(u,vars,mode);
   if mode eq 'symbolic then formc(u,vars,mode)
    else if atom u then if u eq 't then u
           else if not idp u or atsoc(u,vars)
           then list('boolvalue!*,u)
          else list('boolvalue!*,formc!*(u,vars,mode))
    else if intexprlisp(cdr u,vars) and get(car u,'boolfn) then u
    else if idp car u and get(car u,'boolfn)
     then get(car u,'boolfn) . formclis(cdr u,vars,mode)
    else if idp car u and flagp(car u,'boolean)
        then car u . formboollis(cdr u,vars,mode,flagp(car u,'boolargs))
    else if car u eq 'boolvalue!* then rederr("Too many formbools")
    else if car u eq 'where
     then list('boolvalue!*,
           formc!*(list('where,
                   mkquote list('bool!-eval,formbool(cadr u,vars,mode)),
                   caddr u),
                   vars,mode))
    else list('boolvalue!*,formc!*(u,vars,mode));

symbolic procedure formboollis(u,vars,mode,bool);
   begin scalar x;
   a: if null u then return reversip!* x
       else if bool then x := formbool(car u,vars,mode) . x
       else x := formc!*(car u,vars,mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure bool!-eval u; lispeval u;

flag('(bool!-eval),'noform);

flag('(bool!-eval),'opfn);  % symbolic operator bool!-eval.

flag('(bool!-eval),'noval);

symbolic procedure boolvalue!* u; u and null(u = 0);

symbolic procedure formc!*(u,vars,mode);
   begin scalar !*!*a2sfn;
      !*!*a2sfn := 'revalx;
      return formc(u,vars,mode)
   end;

symbolic procedure revalx u;
   % Defined this way to handle standard form kernels in pattern
   % matching.
   reval if not atom u and not atom car u then prepf u else u;

% Functions with side effects must be handled carefully in this model,
% otherwise they are not always evaluated within blocks.

symbolic procedure formrerror(u,vars,mode);
   begin scalar x;
      argnochk u;
      if not fixp caddr u then typerr(caddr u,"RERROR argument");
      x := formc!*(cadddr u,vars,mode);
      if idp cadr u then return list('rerror,mkquote cadr u,caddr u,x)
       else if eqcar(cadr u,'quote) and idp cadadr u
        then return list('rerror,cadr u,caddr u,x)
       else typerr(cadr u,"RERROR argument")
   end;

deflist('((rerror formrerror)),'formfn);   % For bootstrapping.

symbolic procedure formrederr(u,vars,mode);
   list('rederr,formc!*(cadr u,vars,mode));

put('rederr,'formfn,'formrederr);

symbolic procedure formreturn(u,vars,mode);
%  begin scalar x;
%     x := form1(cadr u,vars,mode);  % FORMC here would add REVAL
%     if not(mode memq '(symbolic integer real))
%        and eqcar(x,'setq)             % Should this be more general?
%       then x := list(!*!*a2sfn,x);
%     return list('return,x)
%  end;
   list('return,formc(cadr u,vars,mode));

put('return,'formfn,'formreturn);

symbolic procedure rsverr x;
   rerror('rlisp,13,list (x,"is a reserved identifier"));

symbolic procedure mksetshare(u,v);
   mksetq(u,list('progn,'(setq alglist!* (cons nil nil)),v));

symbolic procedure formsetq(u,vars,mode);
   % formsetq1 and formsetq2 are for handling assignments to lists and
   % pairs of identifiers, resp., in symbolic mode. The original
   % formsetq has been renamed to formsetq0 but remained unchanged.
   if mode neq 'symbolic then
      formsetq0 (u,vars,mode)
   else if eqcar(cadr u,'list) then
      formsetq1 (u,vars,mode)
   else if eqcar(cadr u,'cons) then
      formsetq2 (u,vars,mode)
   else
      formsetq0 (u,vars,mode);

symbolic procedure formsetq0(u,vars,mode);
   % u is a form starting with "setq"; vars is an alist, where the keys
   % are variables, and the values are bindings types for these like,
   % e.g., "scalar"; mode is either "algebraic" or "symbolic".
   begin scalar x,y,z;
     if idp(z := car(u := cdr u)) then y := atsoc(z,vars);
     if eqcar(cadr u,'quote) then mode := 'symbolic;
      % Make target always SYMBOLIC so that algebraic expressions
      % are evaluated before being stored.
      x := convertmode(cadr u,vars,'symbolic,mode);
      return if not atom z
        then if not idp car z then typerr(z,"assignment")
          else if null atom(z := macrochk(z,mode)) and arrayp car z
           then list('setel,intargfn(z,vars,mode),x)
          else if null atom z
               and cdr z and (get(car z,'rtype) eq 'vector
                              or vectorp cadr z
                              or flagpcar(cadr z,'vecfn))
           then putvect(u,vars,mode)
          else if eqcar(z,'part)
           then aconc('list .
                      mkquote 'setpart!* . formlis(cdr z,vars,mode),x)
          else if null atom z and (y := get(car z,'setqfn))
           then form1(applsmacro(y,append(cdr z,cdr u),nil),vars,mode)
          else if mode eq 'symbolic
             and (!*rlisp88 or eqcar(z,'structfetch))
          % Allow for Rlisp '88 records in general Rlisp.
           then list('rsetf,form1(z,vars,mode),x)
          else list('setk,form1(z,vars,'algebraic),x)
             % algebraic needed above, since SETK expects it.
    else if not idp z then typerr(z,"assignment")
    else if flagp(z,'reserved) and null atsoc(z,vars) then rsverr z
    else if flagp(z,'share) then mksetshare(symbid(z,vars),x)
    else if mode eq 'symbolic or y or eqcar(x,'quote)
     then mksetq(symbid(z,vars),x)
    else if vectorp cadr u or flagpcar(cadr u,'vecfn)
     then list('setv,mkquote z,cadr u)
    else list('setk,mkquote z,x)
   end;

symbolic procedure formsetq1(u,vars,mode);
   begin scalar gens,resu,li,coll;
      gens := gensym();
      resu := gensym();
      vars := (gens . 'scalar) . vars;
      li := cdr cadr u;
   a: if null li then go b;
      coll := formsetq0(list('setq, car li, list('car, gens)), vars, mode)
         . coll;
      coll := list('setq, gens, list('cdr, gens)) . coll;
      li := cdr li;
      go a;
   b: coll := list('return, resu) . coll;
      return('prog . list(gens, resu) .
             formsetq0(list('setq, gens, caddr u), vars, mode) .
             list('setq, resu, gens) .
             reversip coll)
   end;

symbolic procedure formsetq2(u,vars,mode);
   begin scalar gens,li,coll;
      gens := gensym();
      vars := (gens . 'scalar) . vars;
      li := cdr cadr u;
      coll := formsetq0(list('setq, car li, list('car, gens)), vars, mode)
         . coll;
      coll := formsetq0(list('setq, cadr li, list('cdr, gens)),vars, mode)
         . coll;
      coll := list('return, gens) . coll;
      return('prog . list gens .
             formsetq0(list('setq, gens, caddr u), vars, mode) .
             reversip coll)
   end;

put('setq,'formfn,'formsetq);

% Table of SETQFNs.

symbolic procedure setcar(a,b); progn(rplaca(a,b),b);

symbolic procedure setcdr(a,b); progn(rplacd(a,b),b);

put('car,'setqfn,'(lambda (u v) (setcar u v)));

put('cdr,'setqfn,'(lambda (u v) (setcdr u v)));

put('caar,'setqfn,'(lambda (u v) (setcar (car u) v)));

put('cadr,'setqfn,'(lambda (u v) (setcar (cdr u) v)));

put('cdar,'setqfn,'(lambda (u v) (setcdr (car u) v)));

put('cddr,'setqfn,'(lambda (u v) (setcdr (cdr u) v)));

put('caaar,'setqfn,'(lambda (u v) (setcar (caar u) v)));

put('caadr,'setqfn,'(lambda (u v) (setcar (cadr u) v)));

put('cadar,'setqfn,'(lambda (u v) (setcar (cdar u) v)));

put('caddr,'setqfn,'(lambda (u v) (setcar (cddr u) v)));

put('cdaar,'setqfn,'(lambda (u v) (setcdr (caar u) v)));

put('cdadr,'setqfn,'(lambda (u v) (setcdr (cadr u) v)));

put('cddar,'setqfn,'(lambda (u v) (setcdr (cdar u) v)));

put('cdddr,'setqfn,'(lambda (u v) (setcdr (cddr u) v)));

put('caaaar,'setqfn,'(lambda (u v) (setcar (caaar u) v)));

put('caaadr,'setqfn,'(lambda (u v) (setcar (caadr u) v)));

put('caadar,'setqfn,'(lambda (u v) (setcar (cadar u) v)));

put('caaddr,'setqfn,'(lambda (u v) (setcar (caddr u) v)));

put('cadaar,'setqfn,'(lambda (u v) (setcar (cdaar u) v)));

put('cadadr,'setqfn,'(lambda (u v) (setcar (cdadr u) v)));

put('caddar,'setqfn,'(lambda (u v) (setcar (cddar u) v)));

put('cadddr,'setqfn,'(lambda (u v) (setcar (cdddr u) v)));

put('cdaaar,'setqfn,'(lambda (u v) (setcdr (caaar u) v)));

put('cdaadr,'setqfn,'(lambda (u v) (setcdr (caadr u) v)));

put('cdadar,'setqfn,'(lambda (u v) (setcdr (cadar u) v)));

put('cdaddr,'setqfn,'(lambda (u v) (setcdr (caddr u) v)));

put('cddaar,'setqfn,'(lambda (u v) (setcdr (cdaar u) v)));

put('cddadr,'setqfn,'(lambda (u v) (setcdr (cdadr u) v)));

put('cdddar,'setqfn,'(lambda (u v) (setcdr (cddar u) v)));

put('cddddr,'setqfn,'(lambda (u v) (setcdr (cdddr u) v)));

put('nth,'setqfn,'(lambda (l i x) (setcar (pnth l i) x)));

put('getv,'setqfn,'(lambda (v i x) (putv v i x)));

put('igetv,'setqfn,'(lambda (v i x) (iputv v i x)));

symbolic procedure formfunc(u,vars,mode);
% ACN has changed this so that it only moans if the thing used with
% FUNCTION is a real macro. If it is an SMACRO that is now allowed. This
% is because I want to have functions that are defined BOTH as regular
% functions (eg for use as envisaged here) and ALSO as SMACROs so that
% direct use of them is expanded in-line.
   if idp cadr u then
     if eqcar(getd cadr u, 'macro) then
        rerror('rlisp,14,list("Macro",cadr u,"Used as Function"))
     else list('function,cadr u)
    else list('function,form1(cadr u,vars,mode));

put('function,'formfn,'formfunc);

% RLIS is a parser function that reads a list of arguments and returns
% this list as one argument.  It needs to be defined in this module for
% bootstrapping purposes since this definition only works with its form
% function.

symbolic procedure rlis;
   begin scalar x;
        x := cursym!*;
        return if flagp(scan(),'delim) then list(x,nil)
                else if !*reduce4
                 then list(x,'list . remcomma xread1 'lambda)
                else x . remcomma xread1 'lambda
   end;

symbolic procedure flagop u; begin flag(u,'flagop); rlistat u end;

symbolic procedure rlistat u;
   begin
    a:  if null u then return nil;
        put(car u,'stat,'rlis);
        u := cdr u;
        go to a
   end;

rlistat '(flagop);

symbolic procedure formrlis(u,vars,mode);
   if not flagp(car u,'flagop)
     then list(car u,'list .
                  if car u eq 'share
                    then (begin scalar x,y;
                             y := cdr u;
                          a: if null y then return reversip!* x;
                             x := mkquote car y . x;
                             y := cdr y;
                             go to a
                         end)
                   else formlis(cdr u,vars,'algebraic))
    else if not idlistp cdr u
     then typerr('!*comma!* . cdr u,"identifier list")
    else list('flag,
              'list . formlis(cdr u,vars,'algebraic),mkquote car u);

symbolic procedure mkarg(u,vars);
   % Returns the "unevaled" form of U.
   if null u or constantp u then u
    else if atom u then if atsoc(u,vars) then u else mkquote u
    else if car u memq '(quote !:dn!: !:int!:) then mkquote u
    else begin scalar x;
         a: if null u then return 'list . reversip!* x;
            x := mkarg(car u,vars) . x;
            u := cdr u;
            go to a
         end;

% Form functions needed for number input.

put('!:dn!:,'formfn,'dnform);

% symbolic procedure dnform(u,vars,mode);
%    if mode eq 'symbolic
%      then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u)
%     else progn(if !*adjprec then precmsg length explode abs cadr u,
%                mkquote(quote !:rd!: . cdr u));

symbolic procedure dnform(u,vars,mode);
   if mode eq 'symbolic
     then compress nconc!*(explode cadr u,'!. . 'e . explode cddr u)
    else progn(if !*adjprec then precmsg length explode abs cadr u,
               mkquote if cddr u >= 0
                         then decimal2internal(cadr u,cddr u)
                        else u);

put('!:int!:,'formfn,'intform);

symbolic procedure intform(u,vars,mode);
   if mode eq 'symbolic then mkquote cadr u
   else progn(precmsg length explode abs cadr u, mkquote cadr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/where.red0000644000175000017500000000412011526203062023440 0ustar  giovannigiovannimodule where;  % Support for a where construct.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% global '(fixedpreclis!*);

symbolic procedure formwhere(u,vars,mode);
   begin scalar expn,equivs,y,z;
     expn := cadr u;
     equivs := remcomma caddr u;
     if not(mode eq 'symbolic)
       then return formc(list('whereexp,'list . equivs,expn),vars,mode);
     for each j in equivs do
        if not atom j and car j memq '(equal setq)
          then <>
         else rerror(rlisp,17,list(j,"invalid in WHERE statement"));
     return formc(list('lambda,reversip z,expn) . reversip y,vars,mode)
   end;

put('where,'formfn,'formwhere);

% fixedpreclis!* := 'where . fixedpreclis!*;  % Where has special place.

% mkprec();

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/xread.red0000644000175000017500000002515611526203062023445 0ustar  giovannigiovannimodule xread; % Routines for parsing RLISP input.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% NOTE: For bootstrapping purposes, this file should not have any tab
%       characters in it.

fluid '(!*blockp !*eoldelimp !*reduce4 commentlist!*);   % !*ignoreeol

global '(cursym!* nxtsym!*);

% The conversion of an RLISP expression to LISP prefix form is carried
% out by the function XREAD.  This function initiates the scanning
% process, and then calls the auxiliary function XREAD1 to perform the
% actual parsing.  Both XREAD and XREAD1 are used by many functions
% whenever an expression must be read;

flag ('(end !*colon!* !*semicol!*),'delim);

symbolic procedure chknewnam u;
   % Check to see if U has a newnam, and return it else return U.
   begin scalar x;
      return if null(x := get(u,'newnam)) or x eq u then u
              else if idp x then chknewnam x
              else x
   end;

symbolic procedure mkvar(u,v); u;

symbolic procedure remcomma u;
   if eqcar(u,'!*comma!*) then cdr u else list u;

symbolic procedure eolcheck;
   if null !*eoldelimp then nil
    else begin
   a: if nxtsym!* eq !$eol!$
        then progn(nxtsym!* := (if cursym!* eq 'end then '!;
                                 else token()),
                   go to a)
     end;

symbolic procedure xcomment(u,commentlist);
   progn((if commentlist
           then u := 'comment . aconc(reversip commentlist,u)),
         u);

symbolic procedure xread1 u;
   begin scalar v,w,x,y,z,z1,z2,commentlist;
        % This is the basic function for parsing RLISP input, once
        % tokens have been read by TOKEN and SCAN.  Its one argument
        % U can take a number of values:
        %   FOR:     Parsing of FOR statements
        %   GROUP:   Parsing of group statements after keyword <<
        %   LAMBDA:  Parsing of lambda expressions after keyword lambda
        %   NIL:     Parsing of expressions which can have a comma at
        %            the end for example.
        %   PROC:    Parsing of procedures after keyword PROCEDURE
        %   T:       Default case with standard parsing.
        % Also, if U is flagged STRUCT, it is assumed that the arguments
        % are lists of lists, and so commas are removed.  At present,
        % only MAT is tagged in this manner.
        % The local variables are used as follows:
        % v: expression being built
        % w: prefix operator stack
        % x: infix operator stack
        % y: infix value or stat property
        % z: current symbol
        % z1: next symbol
        % z2: temporary storage;
        % commentlist: association list of read comments.
        if commentlist!*
          then progn(commentlist := commentlist!*,
                     commentlist!* := nil);
  a:    z := cursym!*;
  a1:   if null idp z then nil
         else if z eq '!*lpar!* then go to lparen
         else if z eq '!*rpar!* then go to rparen
         else if y := get(z,'infix) then go to infx
         % The next line now commented out was intended to allow a STAT
         % to be used as a label. However, it prevents the definition of
         % a diphthong whose first character is a colon.
%        else if nxtsym!* eq '!: then nil
         else if flagp(z,'delim) then go to delimit
         else if y := get(z,'stat) then go to stat
         else if null !*reduce4 and flagp(z,'type)
          then progn(w := lispapply('decstat,nil) . w, go to a);
  a2:   y := nil;
  a3:   w := z . w;
        % allow for implicit * after a number.
        if toknump z
           and null(z1 eq !$eol!$)
           and idp (z1 := chknewnam nxtsym!*)
           and null flagp(z1,'delim)
           and null(get(z1,'switch!*) and null(z1 eq '!())
           and null get(z1,'infix)
           and null (!*eoldelimp and z1 eq !$eol!$)
          then progn(cursym!* := 'times, go to a)
         else if u eq 'proc and length w > 2
          then symerr("Syntax error in procedure header",nil);
  next: z := scan();
        go to a1;
  lparen:
        eolcheck();
        y := nil;
        if scan() eq '!*rpar!* then go to lp1    % no args
         else if flagpcar(w,'struct) then z := xread1 car w
         else z := xread1 'paren;
        if flagp(u,'struct) then progn(z := remcomma z, go to a3)
         else if null eqcar(z,'!*comma!*) then go to a3
         else if null w         % then go to a3
           then (if u eq 'lambda then go to a3
                 else symerr("Improper delimiter",nil))
         else w := (car w . cdr z) . cdr w;
        go to next;
  lp1:  if w then w := list car w . cdr w;  % Function of no args.
        go to next;
  rparen:
        if null u or u eq 'group
           or u eq 'proc % and null !*reduce4
          then symerr("Too many right parentheses",nil)
         else go to end1;
  infx: eolcheck();
        if z eq '!*comma!* or null atom (z1 := scan())
                or toknump z1 then go to in1
         else if z1 eq '!*rpar!* % Infix operator used as variable.
                or z1 eq '!*comma!*
                or flagp(z1,'delim)
          then go to in2
         else if z1 eq '!*lpar!* % Infix operator in prefix position.
                    and null eolcheck()     % Side effect important
                    and null atom(z1 := xread 'paren)
                    and car z1 eq '!*comma!*
                    and (z := z . cdr z1)
          then go to a1;
  in1:  if w then go to unwind
         else if null(z := get(z,'unary))
          then symerr("Redundant operator",nil);
        v := '!*!*un!*!* . v;
        go to pr1;
% in2:  if y then if !*ignoreeol then y := nil
%                  else symerr("Redundant operator",nil);
  in2:  if y then y := nil;
        w := z . w;
  in3:  z := z1;
        go to a1;
  unwind:
        % Null w implies a delimiter was found, say, after a comma.
        if null w then symerr("Improper delimiter",nil);
        z2 := mkvar(car w,z);
  un1:  w:= cdr w;
        if null w then go to un2
        % Next line used to be toknump car w, but this test catches more
%        else if null idp car w and null eqcar(car w,'lambda)
         else if atom car w and null idp car w
%           and null eqcar(car w,'lambda)
          then symerr("Missing operator",nil);
        z2 := list(car w,z2);
        go to un1;
  un2:  v:= z2 . v;
  preced:
        if null x then if y=0 then go to end2 else nil
%        else if z eq 'setq then nil
        % Makes parsing a + b := c more natural.
         else if y= get('member,'infix)
          then typerr("NOT","infix operator");
        if cadr v eq '!*!*un!*!*
          then (if car v eq '!*!*un!*!* then go to pr1
                else z2 := list(cdar x,car v))
         else z2 := cdar x .
                     if eqcar(car v,cdar x) and flagp(cdar x,'nary)
                       then (cadr v . cdar v)
                      else list(cadr v,car v);
        x:= cdr x;
        v := z2 . cddr v;
        go to preced;
  stat: if null(y eq 'endstat) then eolcheck();
        if null(flagp(z,'go)
%          or (flagp(y,'endstatfn)
           or null(u eq 'proc) and (flagp(y,'endstatfn)
                or (null delcp nxtsym!* and null (nxtsym!* eq '!,))))
          then go to a2;
        if z eq 'procedure and !*reduce4
          then if w then if cdr w or !*reduce4
                           then symerr("proc form",nil)
                          else w := list procstat1 car w
                else w := list procstat1 nil
         else w := lispapply(y,nil) . w;
        y := nil;
        go to a;
  delimit:
        if null(cursym!* eq '!*semicol!*) then eolcheck();
        if z eq '!*colon!* and null(u eq 'for)
              and (null !*blockp or null w or null atom car w or cdr w)
           or flagp(z,'nodel)
              and (null u
                      or u eq 'group
                        and null(z memq
                                   '(!*rsqbkt!* !*rcbkt!* !*rsqb!*)))
          then symerr("Improper delimiter",nil)
         else if idp u and (u eq 'paren or flagp(u,'struct))
          then symerr("Too few right parentheses",nil);
  end1:
        if y then symerr("Improper delimiter",nil) % Probably ,).
         else if null v and null w and null x
          then return xcomment(nil,commentlist);
        y := 0;
        go to unwind;
  end2: if null cdr v then return xcomment(car v,commentlist)
         else print "Please send hearn@rand.org your program!!";
        symerr("Improper delimiter",nil)
   end;

%symbolic procedure getels u;
%   getel(car u . !*evlis cdr u);

%symbolic procedure !*evlis u;
%   mapcar(u,function lispeval);

flag ('(endstat retstat),'endstatfn);

flag ('(else then until),'nodel);

flag ('(begin),'go);

symbolic procedure xread u;
   begin
   a: scan();
      if !*eoldelimp and cursym!* eq '!*semicol!* then go to a;
      return xread1 u
   end;

symbolic procedure expread;  xread t;

flag('(expread xread),'opfn);   % To make them operators.

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/proc.red0000644000175000017500000001652511526203062023305 0ustar  giovannigiovannimodule proc;   % Procedure statement.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*nosmacros !*redeflg!* fname!* ftype!*);

global '(!*argnochk !*comp !*lose !*micro!-version cursym!* erfg!*
         ftypes!*);

fluid '(!*defn);

!*lose := t;

ftypes!* := '(expr fexpr macro);

symbolic procedure mkprogn(u,v);
   if eqcar(v,'progn) then 'progn . u . cdr v else list('progn,u,v);

symbolic procedure formproc(u,vars,mode);
   begin scalar body,fname!*,name,type,varlis,x,y,fl;
        u := cdr u;
        name := fname!* := car u;
        if cadr u then mode := cadr u;   % overwrite previous mode
        u := cddr u;
        type := ftype!* := car u;
        if flagp(name,'lose) and (!*lose or null !*defn)
          then return progn(lprim list(name,
                            "not defined (LOSE flag)"),
                        '(quote nil))
         else if !*redeflg!* and getd name
          then lprim list(name,"redefined");
        varlis := cadr u;
!#if (memq 'csl lispsystem!*)
   l:   if null varlis then go to x;
        if fluidp car varlis or globalp car varlis then
          fl := car varlis . fl;
        varlis := cdr varlis;
        go to l;
   x:   varlis := cadr u;
!#endif
        body := caddr u;
        x := if eqcar(body,'rblock) then cadr body else nil;
        y := pairxvars(varlis,x,vars,mode);
        if x then body := car body . rplaca!*(cdr body,cdr y);
        body:= form1(body,car y,mode);   % FORMC here would add REVAL.
!#if (memq 'csl lispsystem!*)
% Note the non-Common way in which the DECLARE sits within a PROGN here.
% Furthermore I only insert DECLARE for sort-of ordinary functions.
% Specifically this will not include "smacro procedure"...
        if fl and type memq '(expr fexpr macro) then
         body:=list('progn,
                    list('declare, 'special . fl),
                    body);
!#endif
        if !*nosmacros and type eq 'smacro then type := 'expr;
        if not(type eq 'smacro) and get(name,'smacro)
          then lprim list("SMACRO",name,"redefined");
        symbvarlst(varlis,body,mode);
        if type eq 'expr then body := list('de,name,varlis,body)
         else if type eq 'fexpr then body := list('df,name,varlis,body)
         else if type eq 'macro then body := list('dm,name,varlis,body)
         else if (x := get(type,'procfn))
          then return apply3(x,name,varlis,body)
         else body := list('putc,
                           mkquote name,
                           mkquote type,
                           mkquote list('lambda,varlis,body));
        if not(mode eq 'symbolic)
          then body :=
              mkprogn(list('flag,mkquote list name,mkquote 'opfn),body);
        if !*argnochk and type memq '(expr smacro)
          then body := mkprogn(list('put,mkquote name,
                                    mkquote 'number!-of!-args,
                                    length varlis),
                               body);
        if !*defn and type memq '(fexpr macro smacro)
          then lispeval body;
        return if !*micro!-version and type memq '(fexpr macro smacro)
                 then nil
                else body
   end;

put('procedure,'formfn,'formproc);

symbolic procedure pairxvars(u,v,vars,mode);
   %Pairs procedure variables and their modes, taking into account
   %the convention which allows a top level prog to change the mode
   %of such a variable;
   begin scalar x,y;
   a: if null u then return append(reversip!* x,vars) . v
       else if (y := atsoc(car u,v))
        then <>
       else if null idp car u or get(car u,'infix) or get(car u,'stat)
             then symerr(list("Invalid parameter:",car u),nil)
       else x := (car u . mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure procstat1 mode;
   begin scalar bool,u,type,x,y,z;
      bool := erfg!*;
      if fname!* then progn(bool := t, go to a5)
       else if cursym!* eq 'procedure then type := 'expr
       else progn(type := cursym!*,scan());
      if not(cursym!* eq 'procedure) then go to a5;
      if !*reduce4 then go to a1;
      x := errorset!*('(xread (quote proc)),nil);
      if errorp x then go to a3
       else if atom (x := car x) then x := list x;   % No arguments.
      fname!* := car x;   % Function name.
      if idp fname!* % and null(type memq ftypes!*)
           and (null fname!*
                or (z := gettype fname!*)
                    and null(z memq '(procedure operator)))
        then progn(typerr(list(z,fname!*),"procedure"), go to a3);
      u := cdr x;
      y := u;   % Variable list.
      if idlistp y then x := car x . y
       else lprie list(y,"invalid as parameter list");
      go to a2;
  a1: fname!* := scan();
      if not idp fname!*
        then progn(typerr(fname!*,"procedure name"), go to a3);
      scan();
      y := errorset!*(list('read_param_list,mkquote mode),nil);
      if errorp y then go to a3;
      y := car y;
      if cursym!* eq '!*colon!* then mode := read_type();
  a2: if idp fname!* and not getd fname!* then flag(list fname!*,'fnc);
         % To prevent invalid use of function name in body.
  a3: if eof!*>0 then progn(cursym!* := '!*semicol!*, go to a4);
      z := errorset!*('(xread t),nil);
      if not errorp z then z := car z;
%     if not atom z and eqcar(car z,'!*comment!*) then z := cadr z;
      if null erfg!*
        then z :=
           list('procedure,if null !*reduce4 then car x else fname!*,
                mode,type,y,z);
  a4: remflag(list fname!*,'fnc);
      fname!* := nil;
      if erfg!* then progn(z := nil,if not bool then error1());
      return z;
  a5: errorset!*('(symerr (quote procedure) t),nil);
      go to a3
   end;

symbolic procedure procstat; procstat1 nil;

deflist ('((procedure procstat) (expr procstat) (fexpr procstat)
           (emb procstat) (macro procstat) (smacro procstat)),
        'stat);

% Next line refers to bootstrapping process.

if get('symbolic,'stat) eq 'procstat then remprop('symbolic,'stat);

deflist('((lisp symbolic)),'newnam);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/array.red0000644000175000017500000001205211526203062023447 0ustar  giovannigiovannimodule array; % Array statement.

% Author: Anthony C. Hearn.
% Modifications by: Nancy Kirkwood.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These definitions are very careful about bounds checking. Appropriate
% optimizations in a given system might really speed things up.

fluid '(!*rlisp88);

global '(erfg!*);

symbolic procedure getel u;
   % Returns the value of the array element U.
   (if length n neq length cdr u
      then rerror(rlisp,21,"Incorrect array reference")
     else getel1(cadr get(car u,'avalue),cdr u,n))
    where n=get(car u,'dimension);

symbolic procedure getel1(u,v,dims);
   if null v then u
    else if not fixp car v then typerr(car v,"array index")
    else if car v geq car dims or car v < 0
     then rerror(rlisp,21,"Array out of bounds")
    else getel1(getv(u,car v),cdr v,cdr dims);

symbolic procedure setel(u,v);
   % Sets array element U to V and returns V.
   (if length n neq length cdr u
           then rerror(rlisp,22,"Incorrect array reference")
     else setel1(cadr get(car u,'avalue),cdr u,v,n))
    where n=get(car u,'dimension);

symbolic procedure setel1(u,v,w,dims);
   if not fixp car v then typerr(car v,"array index")
    else if car v geq car dims or car v < 0
     then rerror(rlisp,23,"Array out of bounds")
    else if null cdr v then putv(u,car v,w)
    else setel1(getv(u,car v),cdr v,w,cdr dims);

symbolic procedure dimension u; get(u,'dimension);


comment further support for REDUCE arrays;

symbolic procedure typechk(u,v);
   begin scalar x;
      if (x := gettype u) eq v or x eq 'parameter
        then lprim list(v,u,"redefined")
       else if x then typerr(list(x,u),v)
   end;

symbolic procedure arrayfn(u,v);
   % U is the defining mode, V a list of lists, assumed syntactically
   % correct. ARRAYFN declares each element as an array unless a
   % semantic mismatch occurs.
   begin scalar y;
      for each x in v do
         <>>>
   end;

flag('(arrayfn),'nochange);

symbolic procedure add1lis u;
   if null u then nil else (car u+1) . add1lis cdr u;

symbolic macro procedure mkarray u;
   if null !*rlisp88 then mkarray1(u,'algebraic) else
     list('mkar1,'list . cdr u);

symbolic procedure mkarray1(u,v);
   % U is a list of positive integers representing array bounds, V
   % the defining mode. Value is an array structure.
   if null u then if v eq 'symbolic then nil else 0
    else begin integer n; scalar x;
      n := car u - 1;
      x := mkvect n;
      for i:=0:n do putv(x,i,mkarray1(cdr u,v));
      return x
   end;

put('array,'stat,'rlis);

flag ('(array arrayfn),'eval);

symbolic procedure formarray(u,vars,mode);
   begin scalar x;
      x := cdr u;
      while x do <>;
      u := for each z in cdr u collect intargfn(z,vars,mode);
      %ARRAY arguments must be returned as quoted structures;
      return list('arrayfn,mkquote mode,'list . u)
   end;

put('array,'formfn,'formarray);

put('array,'rtypefn,'arraychk);

symbolic procedure arraychk u;
   % If arraychk receives NIL, it means that array name is being used
   % as an identifier. We no longer permit this.
   if null u then 'array else nil;
%  nil;

put('array,'evfn,'arrayeval);

symbolic procedure arrayeval(u,v);
   % Eventually we'll support this properly.
   if not atom u then rerror(rlisp,24,"Array arithmetic not defined")
    else u;

put('array,'lengthfn,'arraylength);

symbolic procedure arraylength u; 'list . get(u,'dimension);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/inter.red0000644000175000017500000001120411526203062023450 0ustar  giovannigiovannimodule inter; % Functions for interactive support.

% Author: Anthony C. Hearn.

% Copyright (c) 1993 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*echo !*int);

global '(!$eof!$
         !$eol!$
         !*lessspace
         cloc!*
         contl!*
         curline!*
         edit!*
         eof!*
         erfg!*
         flg!*
         ifl!*
         ipl!*
         key!*
         ofl!*
         opl!*
         techo!*);

symbolic procedure pause;
   %Must appear at the top-most level;
   if null !*int then nil
    else if key!* eq 'pause then pause1 nil
    else %typerr('pause,"lower level command");
         pause1 nil;   % Allow at lower level for now.

symbolic procedure pause1 bool;
   begin scalar x;
      if bool then
        if getd 'edit1 and erfg!* and cloc!* and yesp "Edit?"
          then return <>;
           edit1(cloc!*,nil)>>
         else if flg!* then return (edit!* := nil);
      if null ifl!* or yesp "Cont?" then return nil;
      ifl!* := list(car ifl!*,cadr ifl!*,curline!*);
      if x := assoccar(car ifl!*,contl!*)
        then <>;
      contl!* := (ifl!* . cdr ipl!* . !*echo) . contl!*;
      ifl!* := ipl!* := nil;
      rds nil;
      !*echo := techo!*
   end;

symbolic procedure assoccar(u,v);
   % Returns element of v in which caar of that element = u.
   if null v then nil
    else if u=caaar v then car v
    else assoccar(u,cdr v);

symbolic procedure yesp u;
   begin scalar ifl,ofl,x,y;
        if ifl!*
          then <>;
        if ofl!* then <>;
        if null !*lessspace then terpri();
        if atom u then prin2 u else lpri u;
        prin2t " (Y or N)";
        if null !*lessspace then terpri();
        y := setpchar '!?;
        x := yesp1();
        setpchar y;
        if ofl then wrs cdr ofl;
        if ifl then rds cadr ifl;
        cursym!* := '!*semicol!*;
        return x
   end;

symbolic procedure yesp1;
   % Basic loop for reading response.
   begin scalar bool,x,y;
    a:  x := readch();
        if x eq !$eol!$ then go to a
        % Assume an end-of-file means lost control and exit.
         else if x eq !$eof!$ then eval '(bye)
         %% else if (y := x eq 'y) or x eq 'n then return y
         else if (y := x memq '(!y !Y)) or x memq '(!n !N)
          then return y % F.J. Wright.
         else if null bool then <>;
        go to a
   end;

symbolic procedure cont;
   begin scalar fl,techo;
        if ifl!* then return nil   % CONT only active from terminal.
         else if null contl!* then rerror(rlisp,28,"No file open");
        fl := caar contl!*;
        ipl!* := fl . cadar contl!*;
        techo := cddar contl!*;
        contl!* := cdr contl!*;
        if car fl=caar ipl!* and cadr fl=cadar ipl!*
          then <>
                  else rds nil;
                 !*echo := techo>>
         else <>
   end;

deflist ('((cont endstat) (pause endstat) (retry endstat)),'stat);

flag ('(cont),'ignore);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/smacro.red0000644000175000017500000002572011526203062023623 0ustar  giovannigiovannimodule smacro;  % Support for SMACRO expansion.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%
% This function expands an  invocation of a SMACRO.
%
% Getting this right in all cases seems to be harder than I had expected!
% One simple interpretation of what an SMACRO is is that it represents
% a simple textual expansion, so after
%   smacro procedure f(a,b) E;
% any instance of f(A,B) is expanded to E|a=>A,b=>B using textual
% substitution.
% A different intent for SMACRO is that it marks a procedure to be
% compiled/expanded in-line for performance reasons. The code in Reduce
% up to 3.8 implemented something that was part way between those!
%
% Here are some of the critical cases:
%    smacro procedure f a; ... a ... a...;
%    f(A)  ->   ... A ... A ...                               (a)
%      OR  ->   ((lambda (a) ... a ... a ...) A)              (b)
% The first is what textual expansion suggests, but if the argument A
% is either an expensive-to-evaluate form or has side-effects then
% letting it appear several times within the expansion may be bad either
% for semantics or performance or both. A variation on this arises if the
% formal parameter a does not occur at all within the body of the smacro,
% or is guarded there by an IF, and the actual argument has side-effects.
% Then one version of the expansion WILL evaluate the argument while the
% other will or may not.
%
% Reduce 3.8 uses expansion (a) if either the formal a occurs at most
% once in the body OR (b) the actual argument is one of a limited number
% of sorts of form that can be seen to be side-effect free. For smacros
% with two or more arguments it can lambda-lift just some of the parameters.
%
% Here are some cases where this may cause trouble:
%    smacro procedure f a; 'nothing;
%    ... f(print x) ...                   The print does not happen.
%                                         Maybe that was expected!
%    smacro procedure f a; << if nil then a; if nil then a; nil >>;
%    ... f(print x) ...
% Reduce 3.8 uses expansion (b) and so the print DOES happen.
%
% In these examples I will be using PRINT to stand for something arbitrary
% that may have side effects, might yield different results when called twice
% (including GENSYM and CONS) or might be an expensive computation.
%
%    smacro procedure f(a, b); b . a;
%    ... f(print x, print y) ...
% uses expansion (a) and the prints happen in an order that may be
% unexpected.
%    smacro procedure f(a, b); list(a, b, b);
%    ... f(print x, print y) ...
% uses a lambda at least for b, so y only gets printed once, but probably
% before x.
%
%    smacro procedure set_cdr(a, b); << rplacd(a, b); b >>;
%    ... set_cdr(x, cons(p, q)) ...
%    ... set_cdr(x, cddr x) ...
% if CONS is tagged as side-effect free this does TWO conses and the
% results are almost certainly not what is wanted. And simple inline
% expansion in the second case returns a "wrong" value.
%
%    smacro procedure f(a, b); << a := 1; print b; a := 2; print b >>;
%    ... f(v, v+3) ...
% Oh dear: v+3 is probably not tagged as side-effect free and both a and b
% are used twice in the function body. But there seems to be a clear
% expectation that the firts argument will be textually substituted so that
% the assignments take full effect.
%
%    smacro procedure f a; ... a ... (lambda (a) ...) ...;
% This might arise if a previous smacro used (b) expansion leading to the
% embedded lambda expression, and the names used for formal in the two
% smacros happened to match. If then textual substitution is performed it
% needs to understand the scope rules of nested lambdas and progs. It
% may also need to know that a symbol at the top level of a prog names a
% label not a variable (and ditto (GO x)).
%
%   smacro procedure f x; while a do print (a := cdr a);
%   x := '(1 2 3); f x; print x;
% Depending on expansion style this prints different values at the end.
%
%   smacro procedure increment a; a := a + 1;
% This illustrates a case where it is clear that a direct textual expansion
% is expected. However despite "car x := car x + 1" being accepted syntax the
% order in which things are dons means that "increment (car x)" expands to
% and illegal (setq (car x) (plus (car x) 1)) in Reduce 3.8. And
% increment (getv(x, 2)) becomes ((lambda (a) (setq a (plus a 1))) (getv x 2)).
% because while CAR is tagged as side-effect free GETV is not.
%
% Now by and large these are cases that do not arise too often when smacros
% are used for really simple things and and manually created by people who
% understand what is going on. Well the special treatment in Reduce 3.8 as
% regards how many times a formal is used in the body of the smacro and
% whether the actual argument has side effects suggests that there have been
% problems in individual cases before! But if I try to use the smacro
% mechanism as a generic way of getting in-line compilation I may scan the
% whole source of Reduce and convert small procedures into smacros. And
% then the sorts of issue discussed here bite repeatedly!

% I hope these comments will help anybody writing their own smacros. I
% MAY introduce a new keyword, say
%   inline procedure f(x); ...;
% with unambiguous call-by-value semantics, but meanwhile in any automatic
% conversion from procedure to smacro the issues here need to be thought
% about.    ACN September 2010.

symbolic procedure applsmacro(u,vals,name);
   % U is smacro body of form (lambda  ), VALS is
   % argument list, NAME is name of smacro.
   begin scalar body,remvars,varlist,w;
      varlist := cadr u;
      body := caddr u;
      if length varlist neq length vals
        then rerror(rlisp,15,list("Argument mismatch for SMACRO",name));
      if no!-side!-effect!-listp vals or one!-entry!-listp(varlist,body)
        then return subla!-q(pair(varlist,vals),body)
       else if length varlist>1
        then <>;
      for each x in vals do
         <>;
      if null remvars then return body
       else <>;
              return w>>
   end;

symbolic procedure no!-side!-effectp u;
   if atom u then numberp u or (idp u and not(fluidp u or globalp u))
    else if car u eq 'quote then t
    else if flagp(car u,'nosideeffects)
     then no!-side!-effect!-listp cdr u
    else nil;

symbolic procedure no!-side!-effect!-listp u;
   null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u;

% This list USED to have CONS in it, which would grant expansion of
% smacros the right to duplicate expressions with CONS in them - and
% firstly that would waste memory, and (worse) it causes bugs when
% in the presence of RPLACA and RPLACD.  (ACN, Sept 2010)

flag('(car cdr
       caar cadr cdar cddr
% The expansion code is willing to duplicate expressions that use things
% flagged as side-effect free. I am not certain whether the following
% are sensible to duplicate calls of...
       caaar caadr cadar caddr cdaar cdadr cddar cdddr
       ),'nosideeffects);

% Here are some more things that do not have side effects.

flag('(not null atom eq numberp fixp floatp eqcar),'nosideeffects);

symbolic procedure one!-entryp(u,v);
   % determines if id U occurs less than twice in V.
   if atom v then t
    else if smemq(u,car v)
     then if smemq(u,cdr v) then nil else one!-entryp(u,car v)
    else one!-entryp(u,cdr v);

symbolic procedure one!-entry!-listp(u,v);
   null u or one!-entryp(car u,v) and one!-entry!-listp(cdr u,v);

% This function is (also) defined in alg/general.red but is put here
% because it is needed early(ish) in the bootstrap process.

symbolic procedure delasc(u,v);
  begin scalar w;
     while v do
      <>;
     return reversip w
  end;

% I have updated subla!-q to let it cope better with nested scoped. At
% present I have not allowed for name clashed between parameters and the
% names of PROG labels,

symbolic procedure subla!-q(u,v);
% u is an association list of substitutions, as in
%     ((name1 . value1) (name2 . value2) ...)
% and v is a bit of Lisp code. Perform the substitutions throughout
% the code, but NOT within quoted items (QUOTE literal) and NOT in
% a manner that messes up embedded bindings. This latter is
% an enhancement to the code as of September 2010 to resolve issues
% that arose when trying to use many more smacros then before.
   begin scalar x;
        if null u or null v then return v
         else if atom v
                 then return if x:= atsoc(v,u) then cdr x else v
         else if car v eq 'quote or car v eq 'go then return v
         else if (eqcar(v, 'lambda) or eqcar(v, 'prog)) and
                 not atom cdr v then <<
            x := cadr v;  % (LAMBDA x . body) or (PROG x . body)
% Now the key line - discard the bindings that get hidden.
% Right now there is a residual bug in that labels in a PROG are subject
% to substitution when they should not be! I will worry about that at some
% later stage - maybe.
            for each xx in x do u := delasc(xx, u);
            x := (subla!-q(u,car v) . subla!-q(u,cdr v));
            return x >>
         else return (subla!-q(u,car v) . subla!-q(u,cdr v))
   end;


put('smacro,'macrofn,'applsmacro);


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/list.red0000644000175000017500000002263111526203062023310 0ustar  giovannigiovannimodule list; % Define a list as a list of expressions in curly brackets.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(orig!* posn!*);

global '(cursym!* simpcount!* simplimit!*);

% Add to system table.

put('list,'tag,'list);

put('list,'rtypefn,'quotelist);

symbolic procedure quotelist u; 'list;

% Parsing interface.

symbolic procedure nconc2 (u,v);
  %. Destructive version of Append returning pointer to tail
  begin scalar w;
    if atom u then return v;
    w := u;
    while pairp cdr w do w := cdr w;
        rplacd (w,v);
        return w;
  end;

% using nconc2 here to allow for very long lists to be read
% nconc would always search the end of the list from the top

symbolic procedure xreadlist;
   % Expects a list of expressions enclosed by {, }.
   % Used to allow expressions separated by ; - treated these as progn.
   begin scalar cursym,delim,lst,lst2;
        if scan() eq '!*rcbkt!* then <>;
    a:  if null lst then << lst := lst2  := aconc(lst,xread1 'group)>>
        else lst2 := nconc2 (lst2,list(xread1 ' group));;
        cursym := cursym!*;
        if cursym eq '!*semicol!*
          then symerr("Syntax error: semicolon in list",nil)
         else if scan() eq '!*rcbkt!* and cursym eq '!*comma!*
          then symerr("Syntax error: invalid comma in list",nil);
        if cursym eq '!*rcbkt!*
          then return % if delim eq '!*semicol!*
                      %   then 'progn . lst else
                      'list . lst
         else if null delim then delim := cursym;
%        else if not(delim eq cursym)
%         then symerr("Syntax error: mixed , and ; in list",nil);
        go to a
   end;

put('!*lcbkt!*,'stat,'xreadlist);

newtok '((!{) !*lcbkt!*);

newtok '((!}) !*rcbkt!*);

flag('(!*rcbkt!*),'delim);

flag('(!*rcbkt!*),'nodel);

% Evaluation interface.

put('list,'evfn,'listeval);

put('list,'simpfn,'simpiden);  % This is a little kludgey, but allows
                              % things like dms2deg to work.

symbolic procedure getrlist u;
   if eqcar(u,'list) then cdr u
    else typerr(if eqcar(u,'!*sq) then prepsq cadr u else u,"list");

symbolic procedure listeval(u,v);
   <simplimit!*
       then <>;
     u := if atom u
            then listeval(if flagp(u,'share) then eval u
                           else if x then cadr x else typerr(u,'list),v)
                                  where x=get(u,'avalue)
           else if car u eq 'list
            then makelist for each x in cdr u collect reval1(x,v)
           else ((if x then apply2(x,cdr u,v)
                   else rerror(rlisp,19,"Illegal operation on lists"))
                 where x = get(car u,'listfn));
     simpcount!* := simpcount!* - 1;
     u>>;

symbolic procedure makelist u;
   % Make a list out of elements in u.
   'list . u;


% Length interface.

put('list,'lengthfn,'lengthcdr);

symbolic procedure lengthcdr u; length cdr u;


% Printing interface.

put('list,'prifn,'listpri);

symbolic procedure listpri l;
   % This definition is basically that of INPRINT, except that it
   % decides when to split at the comma by looking at the size of
   % the argument.
   begin scalar orig,split,u;
      u := l;
      l := cdr l;
      prin2!* get('!*lcbkt!*,'prtch);
         % Do it this way so table can change.
      orig := orig!*;
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split := treesizep(l,40);   % 40 is arbitrary choice.
   a: maprint(negnumberchk car l,0);
      l := cdr l;
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b: prin2!* get('!*rcbkt!*,'prtch);
%     terpri!* nil;
      orig!* := orig;
      return u
   end;

symbolic procedure treesizep(u,n);
   % true if u has recursively more pairs than n.
   treesizep1(u,n)=0;

symbolic procedure treesizep1(u,n);
   if atom u then n - 1
    else if (n := treesizep1(car u,n))>0 then treesizep1(cdr u,n)
    else 0;

% Definitions of operations on lists.

symbolic procedure listeval0 u;
   begin scalar v;
     if (simpcount!* := simpcount!*+1)>simplimit!*
        then <>;
     if idp u
       then if flagp(u,'share) then u := listeval0 eval u
             else if (v := get(u,'avalue)) and cadr v neq u
              then u := listeval0 cadr v;
     simpcount!* := simpcount!* - 1;
     return u
   end;

% First, second, third and rest are designed so that only the relevant
% elements need be fully evaluated.

symbolic smacro procedure rlistp u; eqcar(u,'list);

symbolic procedure rfirst u;
   begin scalar x;
      u := car u;
%     if null(getrtype(x := listeval0 u) eq 'list)
%        and null(getrtype(x := aeval u) eq 'list)
      if not rlistp(x := listeval0 u) and not rlistp(x := aeval u)
        then typerr(u,"list");
      if null cdr x then parterr(u,1) else return reval cadr x
   end;

put('first,'psopfn,'rfirst);

symbolic procedure parterr(u,v);
   msgpri("Expression",u,"does not have part",v,t);

symbolic procedure rsecond u;
   begin scalar x;
      u := car u;
      if not rlistp(x := listeval0 u) and not rlistp(x := aeval u)
        then typerr(u,"list");
      if null cdr x or null cddr x then parterr(u,2)
       else return reval caddr x
   end;

put('second,'psopfn,'rsecond);

symbolic procedure rthird u;
   begin scalar x;
      u := car u;
      if not rlistp(x := listeval0 u) and not rlistp(x := aeval u)
        then typerr(u,"list");
      if null cdr x or null cddr x or null cdddr x then parterr(u,3)
       else return reval cadddr x
   end;

put('third,'psopfn,'rthird);

deflist('((first (lambda (x) 'yetunknowntype))
          (second (lambda (x) 'yetunknowntype))
          (third (lambda (x) 'yetunknowntype))
          (part (lambda (x) 'yetunknowntype))),
        'rtypefn);

symbolic procedure rrest u;
   begin scalar x;
      argnochk('cdr . u);
      u := car u;
      if not rlistp(x := listeval0 u) and not rlistp(x := aeval u)
        then typerr(u,"list");
      if null cdr x then typerr(u,"non-empty list")
       else return 'list . for each y in cddr x collect reval y
   end;

put('rest,'psopfn,'rrest);

deflist('((first 1) (second 1) (third 1) (rest 1)),'number!-of!-args);

symbolic procedure rappend u;
   begin scalar x,y;
      argnochk('append . u);
      if null(getrtype(x := reval car u) eq 'list)
        then typerr(x,"list")
      else if null(getrtype(y := reval cadr u) eq 'list)
       then typerr(y,"list")
      else return 'list . append(cdr x,cdr y)
   end;

put('append,'psopfn,'rappend);

symbolic procedure rcons u;
   begin scalar x,y,z;
      argnochk('cons . u);
      if (y := getrtypeor(x := revlis u)) eq 'hvector
    then return if get('cons,'opmtch) and (z := opmtch('cons . x))
                   then reval z
                 else prepsq subs2 simpdot x
       else if not(getrtype cadr x eq 'list) then typerr(x,"list")
       else return 'list . car x . cdadr x
   end;

put('cons,'psopfn,'rcons);

symbolic procedure rreverse u;
   <>;

put('reverse,'psopfn,'rreverse);

% Aggregate Property.

symbolic procedure listmap(u,v);
   begin scalar x;
      x := cadr u;
      if null eqcar(x,'list) and null eqcar(x := reval1(x,v),'list)
        then typerr(cadr u,"list");
      return 'list
              . for each j in cdr x collect reval1(car u . j . cddr u,v)
   end;

put('list,'aggregatefn,'listmap);

% Sorting.

fluid '(sortfcn!*);

symbolic procedure listsort u;
   begin scalar l,n,w;
     if length u neq 2 then goto err;
     l:=cdr listeval(car u,nil);
     sortfcn!*:=cadr u;
     if(w:=get(sortfcn!*,'boolfn)) then sortfcn!*:=w;
     if null getd sortfcn!* or
      (n:=get(sortfcn!*,'number!-of!-args)) and n neq 2
        then goto err;
     return 'list.sort(l,w or
        function(lambda(x,y);
           boolvalue!* reval {sortfcn!*,mkquote x,mkquote y}));
 err: rederr "illegal call to list sort";
   end;

put('sort,'psopfn,'listsort);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/module.red0000644000175000017500000001625711526203062023631 0ustar  giovannigiovanni% module module; % Support for module and package use.

% Author: Anthony C. Hearn.

% Copyright (c) 1990 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%
% WARNING. This code is loaded quite early in the process of
% bootstrapping. As a result it has to be written such that it
% will work properly with the cut-down bootstrap version of the
% RLISP parser. Various constructions such as <<...>> are not
% available....
%

fluid '(!*backtrace !*mode !*faslp);

global '(exportslist!* importslist!* loaded!-packages!* loaded!-modules!*
         mode!-list!*);

!*mode := 'symbolic;   % initial value.

remprop('exports,'stat);

remprop('imports,'stat);

remprop('module,'stat);

symbolic procedure exports u;
   begin exportslist!* := union(u,exportslist!*) end;

symbolic procedure imports u;
   begin importslist!* := union(u,importslist!*) end;

symbolic procedure module u;
   % Sets up a module definition.
   begin
      mode!-list!* := !*mode . mode!-list!*;
      !*mode := 'symbolic
   end;

symbolic procedure endmodule;
   begin
      if null mode!-list!*
        then rederr  "ENDMODULE called outside module";
      exportslist!* := nil;
      importslist!* := nil;
      !*mode := car mode!-list!*;
      mode!-list!* := cdr mode!-list!*
   end;

deflist('((exports rlis) (imports rlis) (module rlis)),'stat);

put('endmodule,'stat,'endstat);

flag('(endmodule),'go);

flag('(module endmodule),'eval);

put('xmodule,'newnam,'module);   % Hook for module extensions.

% Support for package loading.

put('load,'stat,'rlis);

put('load,'formfn,'formload);


symbolic procedure formload(u,vars,mode);
   if eq(mode, 'symbolic) then
      list('progn,
% Adapted to maintain loaded!-modules!*
           list('setq, 'loaded!-modules!*,
              list('union, 'loaded!-modules!*, mkquote cdr u)),
           list('evload, mkquote cdr u))
   else list('load!_package, mkquote cdr u);

symbolic procedure load!-package u;
   begin scalar x,y;
      if stringp u
        then return load!-package intern intern compress explode u
   % intern intern is needed for, e.g., "../huhu".
       else if null idp u then rederr list(u,"is not a package name")
       else if memq(u,loaded!-packages!*)
%       then progn(lprim list("Package",u,"already loaded"), return u)
        then return u
       else if or(atom(x:= errorset(list('evload,list('quote,list u)),
                               nil,!*backtrace)),
                  cdr x)
        then rederr
           list("error in loading package",u,"or package not found");
      loaded!-packages!* := u . loaded!-packages!*;
      loaded!-modules!* := union(loaded!-modules!*, list u);
      x := get(u,'package);
      if x then x := cdr x;
   a: if null x then return install!-patches u
       else if null atom get(car x,'package) then load!-package car x
       else if or(atom(y := errorset(list('evload,
                                         list('quote,list car x)),
                                    nil,!*backtrace)),
                  cdr y)
        then rederr list("module",car x,"of package",u,
                         "cannot be loaded");
      loaded!-modules!* := union(loaded!-modules!*, list car x);
      x := cdr x;
      go to a
   end;

% Now a more user-friendly version.

remprop('load!_package,'stat);

remprop('packages!_to!_load,'stat);

symbolic procedure load!_package u;
   begin scalar x;
      x := u;
   a: if null x then return nil;
      load!-package car x;
      x := cdr x;
      go to a
   end;

symbolic procedure packages!_to!_load u;
   %% FJW: Load other packages at package load time only, i.e. do not
   %% load during building (hence not to be flagged eval).
   if null !*faslp then load!_package u;

put('load!_package,'stat,'rlis);

put('packages!_to!_load,'stat,'rlis);

flag('(load!-package load!_package),'eval);


% Support for patching REDUCE sources.

symbolic procedure patchstat;
   % Read a patch for a given package.
   begin scalar !*mode,u,v,x,y,z,z2;
      x := scan();   % Package name.
      scan();        % Remove semicolon.
 a:   !*mode := 'symbolic;
      y := xread nil;
      if eqcar(y,'symbolic) then y := cadr y
       else if flagpcar(y,'modefn)
        then progn(!*mode := car y, y := cadr y);
      if eq(y,'endpatch)
       then progn(u := name!-for!-patched!-version(x, z),
                  z2 :=  list('de,u,nil,'progn . reversip z) . z2,
                  z2 := list('patches!-load!-check,mkquote x,mkquote u) . z2,
                  return ('patch . reversip z2))
       else if eqcar(y,'procedure)
        then progn(
               v := cadr y,
               u := name!-for!-patched!-version(v, y),
               z := list('instate!-patches,mkquote v,mkquote u,mkquote x) . z,
               z2  := convertmode(('procedure . u . cddr y),nil,
                                  'symbolic,!*mode)
                     . z2)
       else z := convertmode(y,nil,'symbolic,!*mode) . z;
      go to a;
   end;

symbolic procedure name!-for!-patched!-version(name, extra);
   % hashtagged!-name (in CSL) constructs a name that starts with NAME but
   % then continues with a hash value based on EXTRA. The improbability of
   % hash collisions then makes it reasonable to use an interned symbol.
   if member('psl, lispsystem!*) then gensym()
    else hashtagged!-name(name,extra);

symbolic procedure instate!-patches(new,old,pkg);
  begin scalar x;
     x := getd old;
     if x then putd(new,car x,cdr x)
      else rerror('module,1,list(new,"has a badly set-up patch"));
     return nil
  end;

symbolic procedure install!-patches u;
   % Written this way for bootstrapping.
   if eq(u,'patches) then nil
    else if (u := get(u,'patchfn))
     then begin scalar !*usermode,!*redefmsg; eval list u end;

symbolic procedure patches!-load!-check(u,v);
   begin
      put(u,'patchfn,v);
      if memq(u,loaded!-packages!*) then install!-patches u
   end;

put('patch,'stat,'patchstat);

symbolic procedure formpatch(u,vars,mode);
   'progn . cdr u;

put('patch,'formfn,'formpatch);

% endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/vector.red0000644000175000017500000000774111526203062023644 0ustar  giovannigiovannimodule vector; % Definition of RLISP vectors and operations on them.

% Author: Anthony C. Hearn.

% Copyright (c) 1988 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*fastvector);

global '(cursym!*);

switch fastvector;

% Add to system table.

flag('(vec!*),'vecfn);

% Parsing interface.

symbolic procedure xreadvec;
   % Expects a list of expressions enclosed by [, ].
   begin scalar cursym,delim,lst;
        if scan() eq '!*rsqb!* then <>;
    a:      lst := aconc(lst,xread1 'group);
        cursym := cursym!*;
        scan();
        if cursym eq '!*rsqb!*
          then return if delim eq '!*semicol!* then 'progn . lst
                       else list('vec!*,'list . lst)
         else if null delim then delim := cursym
         else if not(delim eq cursym)
          then symerr("Syntax error: mixed , and ; in vector",nil);
        go to a
   end;

put('!*lsqb!*,'stat,'xreadvec);

newtok '((![) !*lsqb!*);

newtok '((!]) !*rsqb!*);

flag('(!*rsqb!*),'delim);

flag('(!*rsqb!*),'nodel);

symbolic procedure vec!* u;
   % Make a vector out of elements of u.
   begin scalar n,x;
      n := length u - 1;
      x := mkvect n;
      for i:= 0:n do <>;
      return x
   end;

% Evaluation interface.

% symbolic procedure setv(u,v);
%   <>;


% Length interface.


% Printing interface.


% Definitions of operations on vectors.

symbolic procedure getvect(u,vars,mode);
   expandgetv(car u,formlis(evalvecarg cdr u,vars,mode));

symbolic procedure expandgetv(u,v);
   if null v then u
    else expandgetv(list(if !*fastvector then 'igetv else 'getv,
                         u,car v),
                    cdr v);

symbolic procedure putvect(u,vars,mode);
   expandputv(caar u,formlis(evalvecarg cdar u,vars,mode),
              form1(cadr u,vars,mode));

symbolic procedure expandputv(u,v,w);
   if null cdr v
     then list(if !*fastvector then 'iputv else 'putv,u,car v,w)
    else expandputv(list(if !*fastvector then 'igetv else 'getv,
                         u,car v),
                    cdr v,w);

symbolic procedure evalvecarg u;
%   if u and null cdr u and vectorp car u
%     then for i:=0:upbv car u collect getv(car u,i) else
   if u and null cdr u and eqcar(car u,'vec!*)
       and eqcar(cadar u,'list)
     then cdadar u
    else u;

% Support for arrays defined in terms of vectors.

symbolic macro procedure mkarray u; {'mkar1,'list . cdr u};

symbolic procedure mkar1 u;
   begin scalar x;
      x := mkvect car u;
      if cdr u then for i:= 0:upbv x do putv(x,i,mkar1 cdr u);
      return x
   end;

symbolic macro procedure array u;
   % Create an array from the elements in u.
   list('vec!*,'list . cdr u);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/lpri.red0000644000175000017500000000667611526203062023316 0ustar  giovannigiovannimodule lpri; % Functions for printing diagnostic and error messages.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*defn !*echo !*fort !*int !*msg !*nat !*protfg errmsg!*);

global '(cursym!* erfg!* ofl!* outl!*);

symbolic procedure lpri u;
   begin
    a:  if null u then return nil;
        prin2 car u;
        prin2 " ";
        u := cdr u;
        go to a
   end;

symbolic procedure lpriw (u,v);
   begin scalar x;
        u := u . if v and atom v then list v else v;
        if ofl!* and (!*fort or not !*nat or !*defn) then go to c;
        terpri();
    a:  lpri u;
        terpri();
        if null x then go to b;
        wrs cdr x;
        return nil;
    b:  if null ofl!* then return nil;
    c:  x := ofl!*;
        wrs nil;
        go to a
   end;

symbolic procedure lprim u;
   !*msg and lpriw("***",u);

symbolic procedure lprie u;
   begin scalar x;
        if !*int then go to a;
        x:= !*defn;
        !*defn := nil;
    a:  erfg!* := t;
        lpriw ("*****",u);
        if null !*int then !*defn := x
   end;

symbolic procedure printty u;
   begin scalar ofl;
        if null !*fort and !*nat then print u;
        if null ofl!* then return nil;
        ofl := ofl!*;
        wrs nil;
        print u;
        wrs cdr ofl
   end;

symbolic procedure rerror(packagename,number,message);
   progn(errmsg!* := message, rederr message);

symbolic procedure rederr u;
   begin if not !*protfg then lprie u; error1() end;

symbolic procedure symerr(u,v);
   begin scalar x;
        erfg!* := t;
        if numberp cursym!* or not(x := get(cursym!*,'prtch))
          then x := cursym!*;
        terpri();
        if !*echo then terpri();
        outl!* := reversip!*(car outl!* . '!$!$!$ . cdr outl!*);
        comm1 t;
   a:   if null outl!* then go to b;
        prin2 car outl!*;
        outl!* := cdr outl!*;
        go to a;
   b:   terpri();
        if null v then rerror('rlisp,5,u)
         else rerror('rlisp,6,
                     x . ("invalid" .
                         (if u then list("in",u,"statement") else nil)))
   end;

symbolic procedure typerr(u,v); rerror('rlisp,6,list(u,"invalid as",v));

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/infix.red0000644000175000017500000000465511526203062023460 0ustar  giovannigiovannimodule infix; % Functions for introducing new infix operators.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*mode);

global '(preclis!*);

symbolic procedure forminfix(u,vars,mode);
   begin scalar x;
      if null(mode eq 'symbolic)
       then x := for each j in cdr u collect list('mkop,mkarg(j,vars));
      u := list(car u,mkarg(cdr u,vars));
      return if x then 'progn . aconc(x,u) else u
   end;

put('infix,'formfn,'forminfix);

symbolic procedure infix x;
   <>;

symbolic procedure precedence u;
   begin scalar x,y,z;
      preclis!* := delete(car u,preclis!*);
      y := cadr u;
      x := preclis!*;
   a: if null x then rerror(rlisp,16,list (y,"not found"))
       else if y eq car x
        then <>;
      z := car x . z;
      x := cdr x;
      go to a
   end;

deflist('((infix rlis) (precedence rlis)),'stat);

flag('(infix precedence),'eval);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rlisp/rsupport.red0000644000175000017500000001511111526203062024226 0ustar  giovannigiovannimodule rsupport;   % Basic functions needed to support RLISP and REDUCE.

% Author: Anthony C. Hearn.

% Copyright (c) 1987 The RAND Corporation.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*backtrace);

global '(!*comp);

symbolic procedure aconc(u,v);
   % Adds element v to the tail of u. u is destroyed in process.
   nconc(u,list v);

symbolic procedure arrayp u; get(u,'rtype) eq 'array;

symbolic procedure atsoc(u,v);
   % This definition allows for a search of a general list.
   if null v then nil
    else if eqcar(car v,u) then car v
    else atsoc(u,cdr v);

symbolic procedure copyd(new,old);
   % Copy the function definition from old id to new.
   begin scalar x;
      x := getd old;
      if null x
        then rerror('rlisp,1,list(old,"has no definition in copyd"));
      putd(new,car x,cdr x);
      return new
   end;

symbolic procedure eqcar(u,v); null atom u and car u eq v;

symbolic procedure errorset!*(u,v); errorset(u,v,!*backtrace);

symbolic procedure errorset2 u;
   begin scalar !*protfg;
      !*protfg := t;
      return errorset(u,nil,nil)
   end;

symbolic procedure flagpcar(u,v);
   null atom u and idp car u and flagp(car u,v);

symbolic procedure idlistp u;
   % True if u is a list of id's.
   null u or null atom u and idp car u and idlistp cdr u;

symbolic procedure listp u;
   % Returns T if U is a top level list.
   null u or null atom u and listp cdr u;

symbolic procedure mkprog(u,v); 'prog . (u . v);

symbolic procedure mkquote u; list('quote,u);

symbolic procedure mksetq(u,v);
   if atom u then list('setq,u,v)
    else begin scalar x;
       if (x := get(car u,'setfn)) then return apply2(x,u,v)
        else typerr(u,"assignment argument")
    end;

symbolic procedure pairvars(u,vars,mode);
   % Sets up pairings of parameters and modes.
   begin scalar x;
   a: if null u then return append(reversip!* x,vars)
       else if null idp car u or get(car u,'infix) or get(car u,'stat)
             then symerr(list("Invalid parameter:",car u),nil);
      x := (car u . mode) . x;
      u := cdr u;
      go to a
   end;

symbolic procedure prin2t u; progn(prin2 u, terpri(), u);

% The following is included for compatibility with some old code.
% Its use is discouraged.

symbolic procedure princ u; prin2 u;

symbolic procedure putc(name,type,body);
   % Defines a non-standard function, such as an smacro. Returns NAME.
   begin
      if !*comp and flagp(type,'compile) then compd(name,type,body)
       else put(name,type,body);
      return name
   end;

% flag('(putc),'eval);

symbolic procedure reversip u;
   begin scalar x,y;
    a:  if null u then return y;
        x := cdr u; y := rplacd(u,y); u := x;
        go to a
   end;

symbolic procedure smemq(u,v);
   % True if id U is a member of V at any level (excluding quoted
   % expressions).
   if atom v then u eq v
    else if car v eq 'quote then nil
    else smemq(u,car v) or smemq(u,cdr v);

symbolic procedure subsetp(u,v);
   % True if u is a subset of v.
   null u or car u member v and subsetp(cdr u,v);

symbolic procedure union(x,y);
   if null x then y
    else union(cdr x,if car x member y then y else car x . y);

symbolic procedure intersection(u,v);
   % This definition is consistent with PSL.
   if null u then nil
    else if car u member v
     then car u . intersection(cdr u,delete(car u,v))
    else intersection(cdr u,v);

symbolic procedure u>=v; null(uv);

symbolic procedure u neq v; null(u=v);

symbolic procedure setdiff(u,v);
   if null v then u
    else if null u then nil
    else setdiff(delete(car v,u),cdr v);

% symbolic smacro procedure u>=v; null(uv);

% symbolic smacro procedure u neq v; null(u=v);

% List changing alternates (may also be defined as copying functions).

symbolic procedure aconc!*(u,v); nconc(u,list v);  % append(u,list v);

symbolic procedure nconc!*(u,v); nconc(u,v);       % append(u,v);

symbolic procedure reversip!* u; reversip u;       % reverse u;

symbolic procedure rplaca!*(u,v); rplaca(u,v);     % v . cdr u;

symbolic procedure rplacd!*(u,v); rplacd(u,v);     % car u . v;

% The following functions should be provided in the compiler for
% efficient coding.

symbolic procedure lispapply(u,v);
   % I'd like to use idp in the following test, but the TPS package
   % stores code pointers on property lists which then get used here.
   if null atom u
     then rerror('rlisp,2,list("Apply called with non-id arg",u))
    else apply(u,v);

symbolic procedure lispeval u; eval u;

symbolic procedure apply1(u,v); apply(u,list v);

symbolic procedure apply2(u,v,w); apply(u,list(v,w));

symbolic procedure apply3(u,v,w,x); apply(u,list(v,w,x));

% The following function is needed by several modules. It is more
% REDUCE-specific than other functions in this module, but since it
% needs to be defined early on, it might as well go here.

symbolic procedure gettype u;
   % Returns a REDUCE-related type for the expression U.
   % It needs to be more table driven than the current definition.
   if numberp u then 'number
    else if null atom u or null u or null idp u then 'form
    else if get(u,'simpfn) then 'operator
    else if get(u,'avalue) then car get(u,'avalue)
    else if getd u then 'procedure
    else if globalp u then 'global
    else if fluidp u then 'fluid
    else if flagp(u,'parm) then 'parameter
    else get(u,'rtype);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/0000755000175000017500000000000011722677355022346 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/test.dat0000755000175000017500000000127111526203062024001 0ustar  giovannigiovanni% Author: Anthony C. Hearn.
% Modified by FJW for testing odesolve entirely within current directory.

on errcont;   % So that computation continues after an error.

symbolic <>$

linelength 80$   % So that logs match Unix versions better.

symbolic load!-package 'odesolve;

algebraic ODESolve_version;

in "$testfile.tst";

% The +- construct in the following is required to finesse Orthovec's
% renaming of -.

symbolic <0
	     then <>>>$

bye;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odespcfn.red0000644000175000017500000001271711526203062024631 0ustar  giovannigiovannimodule odespcfn$  % Linear special function ODEs

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <14 September 2000>

% Old version temporarily preserved for testing other developments!

% A first attempt at pattern-matching solution of special (currently
% only second-order) linear odes.  Need to add more patterns.  But
% this approach may be too slow with more patterns anyway.

% If the specfn package is not loaded then we need this declaration:
algebraic operator Airy_Ai, Airy_Bi$

algebraic operator odesolve!-specfn!*$  % internal wrapper function

algebraic procedure ODESolve!-Specfn(odecoeffs1, driver1, x);
   %% Using monic coeffs for uniqueness.
   begin scalar ode, rules, soln;
      traceode1 "Looking for special-function solutions ...";
      ode := odesolve!-specfn!*(first odecoeffs1, second odecoeffs1);
      rules := {
         %% MUST use specific x, y (not ~x, ~y) for correct matching.
         %% ~~ does not seem to work in any of these rules.
         %% odesolve(df(y,x,2) - x*y, y, x);
         odesolve!-specfn!*(-x, 0) =>
            odesolve!-solns(Airy_Ai(x), Airy_Bi(x)),
         %% odesolve(df(y,x,2) - a3*x*y, y, x);
         odesolve!-specfn!*(-~a3*x, 0) =>
            odesolve!-solns(Airy_Ai(x), Airy_Bi(x), x=a3^(1/3)*x),
         %% odesolve(df(y,x,2) - (a3*x+a2b)*y, y, x);
         odesolve!-specfn!*(-(~a3*x+~a2b), 0) =>
            odesolve!-solns(Airy_Ai(x), Airy_Bi(x),
               x=a3^(1/3)*x+a2b/a3^(2/3)),

         %% The order of the following rules matters!

         %% odesolve(x^2*df(y,x,2) + x*df(y,x) - (x^2+n2)*y, y, x);
         odesolve!-specfn!*(-(1+~n2/x^2), 1/x)
            => odesolve!-solns(BesselI(n,x), BesselK(n,x),
               n = sqrt(n2)),
         %% odesolve(x^2*df(y,x,2) + x*df(y,x) + (x^2-n2)*y, y, x);
         odesolve!-specfn!*(1-~n2/x^2, 1/x)
            => odesolve!-solns(BesselJ(n,x), BesselY(n,x),
               n = sqrt(n2)),

         %% odesolve(x^2*df(y,x,2) + x*df(y,x) - (a2*x^2+n2)*y, y, x);
         odesolve!-specfn!*(-(~a2+~n2/x^2), 1/x)
            => odesolve!-solns(BesselI(n,a*x), BesselK(n,a*x),
               n = sqrt(n2), a = sqrt(a2)),
         %% odesolve(x^2*df(y,x,2) + x*df(y,x) + (a2*x^2-n2)*y, y, x);
         odesolve!-specfn!*(~a2-~n2/x^2, 1/x)
            => odesolve!-solns(BesselJ(n,a*x), BesselY(n,a*x),
               n = sqrt(n2), a = sqrt(a2)),

         %% odesolve(x*df(y,x,2) + df(y,x) - x*y, y, x);
%%          odesolve!-specfn!*(-1, 1/x)
%%             => odesolve!-solns(BesselI(0,x), BesselK(0,x)),
         %% odesolve(x*df(y,x,2) + df(y,x) - a2*x*y, y, x);
         odesolve!-specfn!*(-~a2, 1/x)
            => odesolve!-solns(BesselI(0,a*x), BesselK(0,a*x),
               a = sqrt(a2)),

         %% odesolve(x*df(y,x,2) + df(y,x) + x*y, y, x);
%%          odesolve!-specfn!*(1, 1/x)
%%             => odesolve!-solns(BesselJ(0,x), BesselY(0,x)),
         %% odesolve(x*df(y,x,2) + df(y,x) + a2*x*y, y, x);
         odesolve!-specfn!*(~a2, 1/x)
            => odesolve!-solns(BesselJ(0,a*x), BesselY(0,a*x),
               a = sqrt(a2))

                  }$
      soln := (ode where rules);        % `where' cannot produce a list!
      if soln neq ode then <<
         traceode
            "The reduced ODE can be solved in terms of special functions.";
         soln := part(soln, 1);
         %% if symbolic !*odesolve_load_specfn then load_package specfn;
         return if driver1 then
            %% BEWARE: This driver code is not well tested!
            %% traceode "But cannot currently handle the driver term! "
            { soln, ODESolve!-PI(soln, driver1, x) }
         else { soln }
      >>
   end$

algebraic operator ODESolve!-Solns!*$
listargp ODESolve!-Solns!*$

put('ODESolve!-Solns, 'psopfn, 'ODESolve!-Solns)$

symbolic procedure ODESolve!-Solns u; % (solns, subs)
   %% Avoid invalid lists on right of replacement rule, and build full
   %% optionally substituted basis data structure:
   begin scalar solns;
      %% u := revlis u;
      solns := {'list, car u, cadr u};  % algebraic list
      if (u := cddr u) then <<          % substitutions
         u := if cdr u then 'list . u else car u;
         solns := algebraic sub(u, solns)
      >>;
      return {'ODESolve!-Solns!*, solns}
   end$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/misc.tst0000644000175000017500000000621111526203062024013 0ustar  giovannigiovanni% Miscellaneous ODESolve 1+ tests

% Check for a problem in 1.03, spotted by David Hartley
% , caused by the reval in
% `get_k_list' with caching enabled.  The following should all give
% the same result:

odesolve(df(u,x,x)=df(u,x));
odesolve(df(u,x,2)=df(u,x));
odesolve(df(u,x,x)=df(u,x), u, x);


% Linear first-order ODE:
odesolve(df(y,t) = -w*y*tan(w*t - d));
% The solution, by inspection, is y = A cos(w t - d)


% Variation of parameters:
depend y, x;

ode := df(y,x,2) + y - csc(x)$
odesolve(ode, y, x);
sub(ws, ode);
trigsimp ws;

ode := 2*df(y,x,2) + y - csc(x)$
odesolve(ode, y, x);
sub(ws, ode);
trigsimp ws;


% Bernoulli:
ode := df(y,x)*y*x^2 - y^2*x - x^3 + 1;
odesolve(ode, y, x, explicit);
sub(ws, ode);


% Implicit dependence:

% (NB: Wierd constants need to be mopped up by the arbconst
% simplification code!)

% These should all behave equivalently:
operator f, g;
depend {y, ff}, x, {gg}, y;

odesolve(df(y,x) = f(x), y, x);
odesolve(df(y,x) = ff, y, x);
odesolve(df(y,x) = g(y), y, x);
odesolve(df(y,x) = gg, y, x);
odesolve(df(y,x) = f(x)*g(y), y, x);
odesolve(df(y,x) = ff*gg, y, x);
odesolve(df(y,x) = 1/f(x)*g(y), y, x);
odesolve(df(y,x) = 1/ff*gg, y, x);
odesolve(df(y,x) = f(x)/g(y), y, x);
odesolve(df(y,x) = ff/gg, y, x);

% These should all fail (they are too implicit):
depend {ff}, y, {gg}, x;

odesolve(df(y,x) = ff, y, x);
odesolve(df(y,x) = gg, y, x);
odesolve(df(y,x) = ff*gg, y, x);
odesolve(df(y,x) = 1/ff*gg, y, x);
odesolve(df(y,x) = ff/gg, y, x);


% NONlinear ODEs:
odesolve(df(y,x) + y**(5/3)*arbconst(-1)=0);

% Do not re-evaluate the solution without turning the algint switch on!
odesolve(df(y,x,2) + c/(y^2 + k^2)^(3/2) = 0, y, x, algint);

% Good test of ODESolve!-Alg!-Solve.  Takes forever with fullroots on,
% but with fullroots off ODESolve solves it.  (Slightly tidier with
% algint, but not necessary.  However, the explicit option misses the
% non-trivial solution that can fairly easily be found by hand!)
odesolve(df(y,x,3) = 6*df(y,x)*df(y,x,2)/y - 6*df(y,x)^3/(y^2), y, x, algint);

% Hangs with algint option!
% off odesolve_plus_or_minus;
odesolve(a*tan(asin((df(y,x) - y)/(2*y))/2)^2 + a -
   2*sqrt(3)*tan(asin((df(y,x) - y)/(2*y))/2)*y + 4*sqrt(3)*y +
   tan(asin((df(y,x) - y)/(2*y))/2)^2*y -
   4*tan(asin((df(y,x) - y)/(2*y))/2)*y + 7*y, y, x);
% on odesolve_plus_or_minus;

% From: K Sudhakar 
odesolve(2*df(f,x,3)*df(f,x)*f^2*x^2 - 3*df(f,x,2)^2*x^2*f^2 +
   df(f,x)^4*x^2 - df(f,x)^2*f^2, f, x);

% Related intermediate problem:
odesolve(2*df(y,x)*x*y + x^2 - 2*x*y - y^2, y, x, explicit);


% Anharmonic oscillator problem (which apparently Maple V R5.1 solves
% in terms of a root of an expression involving unevaluated integrals
% but Maple 6 cannot!).

% General solution:
odesolve(M*L*df(phi(tt),tt,2) = -M*g*sin(phi(tt)));

% Use of `t' as independent variable:
odesolve(M*L*df(phi(t),t,2) = -M*g*sin(phi(t)));

% Conditional (eigenvalue) solution:
%% odesolve(M*L*df(phi(t),t,2) = -M*g*sin(phi(t)),
%%    {t=0, phi(t)=0, df(phi(t),t)=Pi});
%%
%% Conditional solutions need more work!  This fails with
%% ***** 0 invalid as kernel

% Try setting
%% L:=1;  g:=10;  ws;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/extend.rlg0000644000175000017500000000656211526203062024332 0ustar  giovannigiovanniREDUCE Development Version, Wed Sep 13 20:40:41 2000 ...







ODESolve 1.065

% Test and demonstration of the ODESolve extension interface

% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <17 July 2000>

% Load odesolve before inputting this file if not using test interface:
% load_package odesolve;

% Hook into the general ODE solver:

algebraic procedure ODESolve_Hook_Demo (ode, y, x);
   %% For any ODE, if the dependent variable is z then this hook
   %% procedure returns a solution corresponding to ODESolve failing
   %% to find any solution; otherwise it returns nil (nothing) and so
   %% is ignored.
   if y=z then {ode=0};


odesolve_hook_demo


% Set the hook:
symbolic(ODESolve_Before_Hook := '(ODESolve_Hook_Demo));


(odesolve_hook_demo)


% Hook into the nonlinear ODE solver:

algebraic procedure ODESolve_Non_Hook_Demo (ode, y, x, n);
   %% If the ODE is nontrivially nonlinear and the order is 3 then
   %% this hook procedure returns a solution corresponding to ODESolve
   %% failing to find any solution; otherwise it returns nil (nothing)
   %% and so is ignored.
   if n=3 then {ode=0};


odesolve_non_hook_demo


% Set the hook:
symbolic(ODESolve_Before_Non_Hook := '(ODESolve_Non_Hook_Demo));


(odesolve_non_hook_demo)


% Hook into the general linear ODE solver:

algebraic procedure ODESolve_Lin_Hook_Demo
   (odecoeffs, driver, y, x, n, m);
   %% If the ODE is linear and the order is 3 then this hook procedure
   %% returns a solution corresponding to ODESolve failing to find any
   %% solution; otherwise it returns nil (nothing) and so is ignored.
   %% (NB: Algebraic-mode lists are indexed from 1 in REDUCE!)
   if n=3 then
      {(for i := m : n sum part(odecoeffs,i+1)*df(y,x,i)) = driver};


odesolve_lin_hook_demo


% Set the hook:
symbolic(ODESolve_Before_Lin_Hook := '(ODESolve_Lin_Hook_Demo));


(odesolve_lin_hook_demo)


% Test all the hooks:

% The general ODE solver:
odesolve(df(y,x));


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

*** depend y , x

{y=arbconst(1)}
                      % hook ignored
odesolve(df(z,x));


*** Dependent var(s) assumed to be z 

*** Independent var assumed to be x 

*** depend z , x

{df(z,x)=0}
                      % hook operates

% The nonlinear ODE solver:
odesolve(y*df(y,x,2)+1);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

{2*arbconst(3)*plus_or_minus(tag_1)

                 sqrt(arbconst(2) - log(y))
  + sqrt(2)*int(----------------------------,y) - 2*plus_or_minus(tag_1)*x=0}
                    arbconst(2) - log(y)
                % hook ignored
odesolve(y*df(y,x,3)+1);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

{df(y,x,3)*y + 1=0}
                % hook operates

% The general linear ODE solver:
odesolve(df(y,x,2)+1);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

                                       2
    2*arbconst(5) + 2*arbconst(4)*x - x
{y=--------------------------------------}
                     2
                  % hook ignored
odesolve(df(y,x,3)+1);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

{df(y,x,3)=-1}
                  % hook operates

% Clear the hooks:
symbolic(ODESolve_Before_Hook := nil);


symbolic(ODESolve_Before_Non_Hook := nil);


symbolic(ODESolve_Before_Lin_Hook := nil);



end;



Time for test: 690 ms, plus GC time: 109 ms

mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/misc.rlg0000644000175000017500000002062011526203062023765 0ustar  giovannigiovanniREDUCE Development Version, Wed Sep 13 20:40:41 2000 ...







ODESolve 1.065

% Miscellaneous ODESolve 1+ tests

% Check for a problem in 1.03, spotted by David Hartley
% , caused by the reval in
% `get_k_list' with caching enabled.  The following should all give
% the same result:

odesolve(df(u,x,x)=df(u,x));


*** Dependent var(s) assumed to be u 

*** Independent var assumed to be x 

*** depend u , x

    x
{u=e *arbconst(2) + arbconst(1)}

odesolve(df(u,x,2)=df(u,x));


*** Dependent var(s) assumed to be u 

*** Independent var assumed to be x 

    x
{u=e *arbconst(4) + arbconst(3)}

odesolve(df(u,x,x)=df(u,x), u, x);


    x
{u=e *arbconst(6) + arbconst(5)}



% Linear first-order ODE:
odesolve(df(y,t) = -w*y*tan(w*t - d));


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be t 

*** depend y , t

{y=arbconst(7)*cos(d - t*w)}

% The solution, by inspection, is y = A cos(w t - d)


% Variation of parameters:
depend y, x;



ode := df(y,x,2) + y - csc(x)$


odesolve(ode, y, x);


{y=arbconst(9)*sin(x) + arbconst(8)*cos(x) - cos(x)*x + log(sin(x))*sin(x)}

sub(ws, ode);


       2                         2
 cos(x)  - csc(x)*sin(x) + sin(x)
-----------------------------------
              sin(x)

trigsimp ws;


0


ode := 2*df(y,x,2) + y - csc(x)$


odesolve(ode, y, x);


                           x                               x
{y=(2*arbconst(11)*sin(---------) + 2*arbconst(10)*cos(---------)
                        sqrt(2)                         sqrt(2)

                                           x
                                   sin(---------)
                       x                sqrt(2)
     - sqrt(2)*cos(---------)*int(----------------,x)
                    sqrt(2)            sin(x)

                            x
                    cos(---------)
                         sqrt(2)               x
     + sqrt(2)*int(----------------,x)*sin(---------))/2}
                        sin(x)              sqrt(2)

sub(ws, ode);


         x     2                           x     2
 cos(---------)  - csc(x)*sin(x) + sin(---------)
      sqrt(2)                           sqrt(2)
---------------------------------------------------
                      sin(x)

trigsimp ws;


0



% Bernoulli:
ode := df(y,x)*y*x^2 - y^2*x - x^3 + 1;


                2      3      2
ode := df(y,x)*x *y - x  - x*y  + 1

odesolve(ode, y, x, explicit);


                         3             3
    sqrt(3*arbconst(13)*x  + 6*log(x)*x  + 2)*plus_or_minus(tag_1)
{y=----------------------------------------------------------------}
                           sqrt(x)*sqrt(3)

sub(ws, ode);


0



% Implicit dependence:

% (NB: Wierd constants need to be mopped up by the arbconst
% simplification code!)

% These should all behave equivalently:
operator f, g;


depend {y, ff}, x, {gg}, y;



odesolve(df(y,x) = f(x), y, x);


{y=arbconst(14) + int(f(x),x)}

odesolve(df(y,x) = ff, y, x);


{y=arbconst(15) + int(ff,x)}

odesolve(df(y,x) = g(y), y, x);


                      1
{arbconst(16) + int(------,y) - x=0}
                     g(y)

odesolve(df(y,x) = gg, y, x);


                     1
{arbconst(17) + int(----,y) - x=0}
                     gg

odesolve(df(y,x) = f(x)*g(y), y, x);


                                         1
{arbconst(18)*f(0) - int(f(x),x) + int(------,y)=0}
                                        g(y)

odesolve(df(y,x) = ff*gg, y, x);


                         1
{arbconst(19)*ff! + int(----,y) - int(ff,x)=0}
                         gg

odesolve(df(y,x) = 1/f(x)*g(y), y, x);


                           1                    1
{arbconst(20) - f(0)*int(------,x) + f(0)*int(------,y)=0}
                          f(x)                 g(y)

odesolve(df(y,x) = 1/ff*gg, y, x);


                     1                 1
{arbconst(21) - int(----,x)*ff! + int(----,y)*ff!=0}
                     ff                gg

odesolve(df(y,x) = f(x)/g(y), y, x);


{arbconst(22)*f(0) - int(f(x),x) + int(g(y),y)=0}

odesolve(df(y,x) = ff/gg, y, x);


{arbconst(23)*ff! - int(ff,x) + int(gg,y)=0}


% These should all fail (they are too implicit):
depend {ff}, y, {gg}, x;



odesolve(df(y,x) = ff, y, x);


{df(y,x) - ff=0}

odesolve(df(y,x) = gg, y, x);


{df(y,x) - gg=0}

odesolve(df(y,x) = ff*gg, y, x);


{df(y,x) - ff*gg=0}

odesolve(df(y,x) = 1/ff*gg, y, x);


{df(y,x)*ff - gg=0}

odesolve(df(y,x) = ff/gg, y, x);


{df(y,x)*gg - ff=0}



% NONlinear ODEs:
odesolve(df(y,x) + y**(5/3)*arbconst(-1)=0);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

    2/3                                2/3
{2*y   *arbconst(24)*arbconst(-1) - 2*y   *arbconst(-1)*x + 3=0}


% Do not re-evaluate the solution without turning the algint switch on!
odesolve(df(y,x,2) + c/(y^2 + k^2)^(3/2) = 0, y, x, algint);


{2*arbconst(26)*plus_or_minus(tag_2)*c + sqrt(k)*sqrt(c)*sqrt(2)*arbconst(25)*

                         2                 2         2    2             2    2
      sqrt(arbconst(25)*k  + arbconst(25)*y  - sqrt(k  + y )*k*y)*sqrt(k  + y )
 int(---------------------------------------------------------------------------
                                 2  2               2  2    2  2
                     arbconst(25) *k  + arbconst(25) *y  - k *y

     ,y)*k + sqrt(k)*sqrt(c)*sqrt(2)

                          2                 2         2    2
       sqrt(arbconst(25)*k  + arbconst(25)*y  - sqrt(k  + y )*k*y)*y      2
 *int(---------------------------------------------------------------,y)*k
                            2  2               2  2    2  2
                arbconst(25) *k  + arbconst(25) *y  - k *y

  - 2*plus_or_minus(tag_2)*c*x=0}


% Good test of ODESolve!-Alg!-Solve.  Takes forever with fullroots on,
% but with fullroots off ODESolve solves it.  (Slightly tidier with
% algint, but not necessary.  However, the explicit option misses the
% non-trivial solution that can fairly easily be found by hand!)
odesolve(df(y,x,3) = 6*df(y,x)*df(y,x,2)/y - 6*df(y,x)^3/(y^2), y, x, algint);


{sqrt(y)*arbconst(30)*arbconst(29)*arbconst(28)

  - sqrt(y)*arbconst(29)*arbconst(28)*x - 2*sqrt(arbconst(28) + y)=0,

 y=arbconst(31)}


% Hangs with algint option!
% off odesolve_plus_or_minus;
odesolve(a*tan(asin((df(y,x) - y)/(2*y))/2)^2 + a -
   2*sqrt(3)*tan(asin((df(y,x) - y)/(2*y))/2)*y + 4*sqrt(3)*y +
   tan(asin((df(y,x) - y)/(2*y))/2)^2*y -
   4*tan(asin((df(y,x) - y)/(2*y))/2)*y + 7*y, y, x);


     x
{ - e *arbconst(32) - sqrt( - 4*sqrt(3)*y - a - 8*y) - sqrt(a)*sqrt(3)=0,

     x
  - e *arbconst(33) - sqrt( - 4*sqrt(3)*y - a - 8*y) + sqrt(a)*sqrt(3)=0}

% on odesolve_plus_or_minus;

% From: K Sudhakar 
odesolve(2*df(f,x,3)*df(f,x)*f^2*x^2 - 3*df(f,x,2)^2*x^2*f^2 +
   df(f,x)^4*x^2 - df(f,x)^2*f^2, f, x);


*** depend f , x

{arbconst(37)*arbconst(36)*arbconst(35)*log(f) + arbconst(37)*arbconst(36)

  - arbconst(36)*arbconst(35)*log(f)*log(x) - arbconst(36)*log(x) + log(f)=0,

 f=arbconst(38)}


% Related intermediate problem:
odesolve(2*df(y,x)*x*y + x^2 - 2*x*y - y^2, y, x, explicit);


             - (2*x)/(x - y_)               2      2              2
{y=root_of(e                 *arbconst(39)*e *x + x  - 2*x*y_ + y_ ,y_,tag_19)}



% Anharmonic oscillator problem (which apparently Maple V R5.1 solves
% in terms of a root of an expression involving unevaluated integrals
% but Maple 6 cannot!).

% General solution:
odesolve(M*L*df(phi(tt),tt,2) = -M*g*sin(phi(tt)));


*** phi declared operator 

*** Dependent var(s) assumed to be phi(tt) 

*** Independent var assumed to be tt 

{2*arbconst(41)*plus_or_minus(tag_20)*g + sqrt(l)*sqrt(g)*sqrt(2)

       sqrt(arbconst(40)*sin(1) + cos(phi(tt)))
 *int(------------------------------------------,phi(tt))
          arbconst(40)*sin(1) + cos(phi(tt))

  - 2*plus_or_minus(tag_20)*g*tt=0}


% Use of `t' as independent variable:
odesolve(M*L*df(phi(t),t,2) = -M*g*sin(phi(t)));


*** Dependent var(s) assumed to be phi(t) 

*** Independent var assumed to be t 

{2*arbconst(43)*plus_or_minus(tag_21)*g + sqrt(l)*sqrt(g)*sqrt(2)

       sqrt(arbconst(42)*sin(1) + cos(phi(t)))
 *int(-----------------------------------------,phi(t))
          arbconst(42)*sin(1) + cos(phi(t))

  - 2*plus_or_minus(tag_21)*g*t=0}


% Conditional (eigenvalue) solution:
%% odesolve(M*L*df(phi(t),t,2) = -M*g*sin(phi(t)),
%%    {t=0, phi(t)=0, df(phi(t),t)=Pi});
%%
%% Conditional solutions need more work!  This fails with
%% ***** 0 invalid as kernel

% Try setting
%% L:=1;  g:=10;  ws;

end;



Time for test: 24198 ms, plus GC time: 1520 ms

mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.in0000755000175000017500000000237011526203062024501 0ustar  giovannigiovanni% Input the whole package of ODESolve 1+ source files  -*- REDUCE -*-

% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <14 September 2000>

% To input the full ODESolve file set, start REDUCE in the ODESolve
% source directory (or change to it) and do

% in "odesolve.in"$


% To compile ODESolve without using the development system utilities,
% start REDUCE in the ODESolve source directory (or change to it) and
% do

% in "odesolve.red"$
% faslout odesolve;
% in "odesolve.in"$
% faslend;

% If using PSL, you will then need to move odesolve.b to a directory
% in your PSL load path, such as the main fasl directory.


in "odesolve.red"$

% See `reduce/packages/rlisp/tok.red' for details of conditional parsing.

!#if (memq 'csl lispsystem!*)           % CSL
symbolic eval!-when((eval compile),
   in_non_empty_list
      for each p in ODESolve!-subpackages!* collect concat(p, ".red"))$
!#else                                  % Assume PSL
symbolic compiletime
   in_non_empty_list
      for each p in ODESolve!-subpackages!* collect
         compress('!" . append(explode2 p, '(!. !r !e !d !")))$ % "
!#endif

end$

% eval!-when is a CSL fexpr like progn but its first argument must be
% a list of "situations" that can be one or more of the atoms eval,
% compile, load.
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimmer.rlg0000644000175000017500000014434011526203062024343 0ustar  giovannigiovanniREDUCE Development Version, Wed Sep 13 20:40:41 2000 ...







ODESolve 1.065

% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses REDUCE-style variable notation wherever possible.

on trode;


on div, intstr;

  off allfac;

            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

depend y, x;



% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y,x) + 2*x^4*y = x^3/3 + C, y, x);

This is a linear ODE of order 1.
It is solved by the integrating factor method.

      - 2*x                1     -2    1       1
    e      *arbconst(1) + ---*c*x   + ---*x - ---
                           2           6       4
{y=-----------------------------------------------}
                     2
                    x  - 2*x + 1


% (2) Linear Bernoulli 2
odesolve(-1/2*df(y,x) + y = sin x, y, x);

This is a linear ODE of order 1.
It is solved by the integrating factor method.

    2*x                2            4
{y=e   *arbconst(2) + ---*cos(x) + ---*sin(x)}
                       5            5


% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y,x,2)*(a*x+b)^2 + 4df(y,x)*(a*x+b)*a + 2y*a^2 = 0, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.
It is of the homogeneous (Euler) type (with shifted coefficients) 
and is reducible to a simpler ODE ...
It has constant coefficients.

                 2                                    2
    arbconst(4)*a *x + arbconst(4)*a*b + arbconst(3)*a
{y=-----------------------------------------------------}
                    2  2              2
                   a *x  + 2*a*b*x + b


% (4) Adjoint
odesolve((x^2-x)*df(y,x,2) + (2x^2+4x-3)*df(y,x) + 8x*y = 1, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.
But ODESolve cannot solve it using linear techniques, so ...
Interchanging dependent and independent variables ...

              2                          3              3            2  2
 - df(x,y,2)*x  + df(x,y,2)*x + 8*df(x,y) *x*y - df(x,y)  + 2*df(x,y) *x

            2              2
 + 4*df(x,y) *x - 3*df(x,y)

This is a nonlinear ODE of order 2.
Interchanging dependent and independent variables ...

           2                            2
df(y,x,2)*x  - df(y,x,2)*x + 2*df(y,x)*x  + 4*df(y,x)*x - 3*df(y,x) + 8*x*y - 1

ODE simplifier loop interrupted! 
ODESolve cannot solve this ODE!

            2                            2
{df(y,x,2)*x  - df(y,x,2)*x + 2*df(y,x)*x  + 4*df(y,x)*x - 3*df(y,x) + 8*x*y - 1

 =0}


% (5) Polynomial solutions
% (FJW: currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y,x,2) + (1-2x^2)*df(y,x) + (4x-2)*y = 0, y, x);

% (6) Dependent variable missing
odesolve(df(y,x,2) + 2x*df(y,x) = 2x, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.

Performing trivial order reduction to give the order 1

 linear ODE with coefficients (low -- high): {2*x,1}

It is solved by the integrating factor method.

                                     1
Solution of order-reduced ODE is {{-----},1}
                                      2
                                     x
                                    e


                                                      1
Restoring order, y => df(y,x,1), to give: df(y,x)={{-----},1} and re-solving ...
                                                       2
                                                      x
                                                     e


                  1
{y=arbconst(6) + ---*sqrt(pi)*arbconst(5)*erf(x) + x}
                  2


% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y,x,2) + (2x^2-3x+1)*df(y,x) + (x-1)*y = 0,
      y, x, algint);
end;

This is a linear ODE of order 2.
It has non-constant coefficients.
It is exact, and the following linear ODE of order 1 is a first integral:

         3              2    2
df(y,x)*x  - 2*df(y,x)*x  + x *y - 2*x*y + 2*y=g10
It is solved by the integrating factor method.

                -1
     - 1/2   - x           - 1/2
{y=x      *e      *(x - 2)

                                       1/x
                                      e   *sqrt(x - 2)
 *(arbconst(8) + arbconst(7)*int(--------------------------,x))}
                                           2
                                  sqrt(x)*x  - 2*sqrt(x)*x

% NB: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON ALGINT OR NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y,x,2) - 2x*df(y,x) + 2y = 3, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.
But ODESolve cannot solve it using linear techniques, so ...
Interchanging dependent and independent variables ...

                        3              3            2
 - df(x,y,2) + 2*df(x,y) *y - 3*df(x,y)  - 2*df(x,y) *x

This is a nonlinear ODE of order 2.

                                                                        - 3
This ODE can be simplified by the independent variable shift y => y - ------
                                                                        2

                                  3              2
 to give:  - df(x,y,2) + 2*df(x,y) *y - 2*df(x,y) *x=0


                                                                            G22
This ODE is equidimensional in the independent variable y -- applying y => e

 to transform to the simpler ODE: 

                            3              2
 - df(x,G22,2) + 2*df(x,G22)  - 2*df(x,G22) *x + df(x,G22)=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

                        3        2
 - df(G23,x)*G23 + 2*G23  - 2*G23 *x + G23=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

                    2
 - df(G23,x) + 2*G23  - 2*G23*x + 1=0

This is a nonlinear ODE of order 1.

It is of Riccati type and transforms into the linear second-order ODE: 

df(G23,x,2) + 2*df(G23,x)*x + 2*G23=0

It has non-constant coefficients.
It is exact, and the following linear ODE of order 1 is a first integral:

df(G23,x) + 2*G23*x=g26
It is solved by the integrating factor method.
Restoring order to give these first-order ODEs ...

sqrt(pi)*arbconst(9)*df(x,G22)*erf(i*x)*i - sqrt(pi)*arbconst(9)*erf(i*x)*i*x

     2
    x
 - e  *arbconst(9) - 2*df(x,G22) + 2*x=0

This is a nonlinear ODE of order 1.
It is separable.

df(x,G22)=0

This is a linear ODE of order 1.
It is solved by quadrature.

{arbconst(10) + sqrt(pi)*arbconst(9)

                               erf(i*x)
 *int(-----------------------------------------------------------,x)*i
                                             2
                                            x
       sqrt(pi)*arbconst(9)*erf(i*x)*i*x + e  *arbconst(9) - 2*x

                                       1
  - 2*int(-----------------------------------------------------------,x)
                                                 2
                                                x
           sqrt(pi)*arbconst(9)*erf(i*x)*i*x + e  *arbconst(9) - 2*x

         2*y - 3
  - log(---------)=0}
            2


% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y,x,2) + 2x*df(y,x) + 3y = 0, y, x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y,x,2) - 2/x^2*y = 7x^4 + 3*x^3, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.
It is of the homogeneous (Euler) type and is reducible to a simpler ODE ...
It has constant coefficients.
Constructing particular integral using `D-operator method'.

                 2                 -1    1   6    1   5
{y=arbconst(13)*x  + arbconst(12)*x   + ---*x  + ---*x }
                                         4        6


% (12) Variation of parameters
odesolve(df(y,x,2) + y = csc(x), y, x);

This is a linear ODE of order 2.
It has constant coefficients.
Constructing particular integral using `D-operator method'.
But cannot evaluate the integrals, so ...
Constructing particular integral using `variation of parameters'.
The Wronskian is 1

{y=arbconst(15)*sin(x) + arbconst(14)*cos(x) - cos(x)*x + log(sin(x))*sin(x)}


% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y,x,7) - 14df(y,x,6) + 80df(y,x,5) - 242df(y,x,4)
   + 419df(y,x,3) - 416df(y,x,2) + 220df(y,x) - 48y = 0, y, x);
remfac exp(x) >>;

This is a linear ODE of order 7.
It has constant coefficients.

    4*x                 3*x                 2*x
{y=e   *arbconst(17) + e   *arbconst(16) + e   *(arbconst(19) + arbconst(18)*x)

     x                                                2
  + e *(arbconst(22) + arbconst(21)*x + arbconst(20)*x )}


% (14) Euler
odesolve(df(y,x,4) - 4/x^2*df(y,x,2) + 8/x^3*df(y,x) - 8/x^4*y = 0, y, x);

This is a linear ODE of order 4.
It has non-constant coefficients.
It is of the homogeneous (Euler) type and is reducible to a simpler ODE ...
It has constant coefficients.

                 4                 2                                  -1
{y=arbconst(26)*x  + arbconst(25)*x  + arbconst(24)*x + arbconst(23)*x  }


% (15) Exact n-th order
odesolve((1+x+x^2)*df(y,x,3) + (3+6x)*df(y,x,2) + 6df(y,x) = 6x, y, x);

This is a linear ODE of order 3.
It has non-constant coefficients.

Performing trivial order reduction to give the order 2

                                                         2
 linear ODE with coefficients (low -- high): {6,6*x + 3,x  + x + 1}

But ODESolve cannot solve the reduced ODE! 
It is exact, and the following linear ODE of order 2 is a first integral:

           2
df(y,x,2)*x  + df(y,x,2)*x + df(y,x,2) + 4*df(y,x)*x + 2*df(y,x) + 2*y

          2
=g34 + 3*x
It is exact, and the following linear ODE of order 1 is a first integral:

         2                                                  3
df(y,x)*x  + df(y,x)*x + df(y,x) + 2*x*y + y=g34*x + g35 + x
It is solved by the integrating factor method.

                                     1                2    1   4
    arbconst(29) + arbconst(28)*x + ---*arbconst(27)*x  + ---*x
                                     2                     4
{y=--------------------------------------------------------------}
                              2
                             x  + x + 1



% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y,x) = y/(y*log y + x), y, x);

This is a nonlinear ODE of order 1.
Interchanging dependent and independent variables ...

 - df(x,y)*y + log(y)*y + x

This is a linear ODE of order 1.
It is solved by the integrating factor method.

                     1        2
{x=arbconst(30)*y + ---*log(y) *y}
                     2


% (17) Integrating factors 2
odesolve(2y*df(y,x)^2 - 2x*df(y,x) - y = 0, y, x);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

               5                  3                          2
4*df(x,G39)*G39  - 8*df(x,G39)*G39  + 3*df(x,G39)*G39 + 4*G39 *x + 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                  1/3                 2    1/3
                               2*2   *arbconst(31)*G39  - 2   *arbconst(31)
The subsidiary solution is {x=----------------------------------------------}
                                        2/3       4         2     1/3
                                     G39   *(4*G39  - 12*G39  + 9)

 and the main ODE can be solved parametrically in terms of the derivative.


                    4                 2      - 1/3             - 2/3  1/3
{{y=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

  *arbconst(31)*arbparam(1),

                    4                 2      - 1/3             - 2/3  1/3
  x=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

                           2                 4                 2      - 1/3
  *arbconst(31)*arbparam(1)  - (4*arbparam(1)  - 12*arbparam(1)  + 9)

               - 2/3  1/3
  *arbparam(1)      *2   *arbconst(31),

  arbparam(1)}}

% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y,x) + y = y^3*sin x, y, x, explicit);

This is a nonlinear ODE of order 1.
It is of Bernoulli type.

{y

      2*x                                     - 1/2
 =(5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5)*plus_or_minus(tag_1)

 }

expand_plus_or_minus ws;


       2*x                                     - 1/2
{y=(5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5),

          2*x                                     - 1/2
 y= - (5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5)}


% (19) Bernoulli 2
depend {P, Q}, x;


begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y,x) + P*y = Q*y^n, y, x);
   off allfac;  return soln
end;

This is a nonlinear ODE of order 1.
It is of Bernoulli type.

                                                  int(p,x)
   - n       int(p,x)*n - int(p,x)               e        *q
{y    *y= - e                     *((n - 1)*int(-------------,x) - arbconst(33))
                                                  int(p,x)*n
                                                 e

 }

odesolve(df(y,x) + P*y = Q*y^(2/3), y, x);

This is a nonlinear ODE of order 1.
It is of Bernoulli type.

  1/3   - 1/3*int(p,x)                 1    - 1/3*int(p,x)      int(p,x)/3
{y   =e               *arbconst(34) + ---*e               *int(e          *q,x)}
                                       3


% (20) Clairaut 1
odesolve((x^2-1)*df(y,x)^2 - 2x*y*df(y,x) + y^2 - 1 = 0, y, x, explicit);

This is a nonlinear ODE of order 1.
It is of Clairaut type.

Solution before trying to solve for dependent variable is 

            2  2               2                         2
arbconst(35) *x  - arbconst(35)  - 2*arbconst(35)*x*y + y  - 1=0


                                                              2    2
Solution before trying to solve for dependent variable is  - x  - y  + 1=0


                                     2
{y=arbconst(35)*x + sqrt(arbconst(35)  + 1),

                                     2
 y=arbconst(35)*x - sqrt(arbconst(35)  + 1),

            2
 y=sqrt( - x  + 1),

               2
 y= - sqrt( - x  + 1)}


% (21) Clairaut 2
operator f, g;


odesolve(f(x*df(y,x)-y) = g(df(y,x)), y, x);

This is a nonlinear ODE of order 1.
It is of Clairaut type.

{f(arbconst(36)*x - y) - g(arbconst(36))=0}


% (22) Equations of the form  y' = f(x,y)
odesolve(df(y,x) = (3x^2-y^2-7)/(exp(y)+2x*y+1), y, x);

This is a nonlinear ODE of order 1.
It is exact and is solved by quadrature.

                 y    3      2
{arbconst(37) + e  - x  + x*y  + 7*x + y=0}


% (23) Homogeneous
odesolve(df(y,x) = (2x^3*y-y^4)/(x^4-2x*y^3), y, x);

This is a nonlinear ODE of order 1.
It is of algebraically homogeneous type 
solved by a change of variables of the form `y = vx'.

                     3    3
{arbconst(38)*x*y + x  + y =0}


% (24) Factoring the equation
odesolve(df(y,x)*(df(y,x)+y) = x*(x+y), y, x);

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

df(y,x) + x + y=0

This is a linear ODE of order 1.
It is solved by the integrating factor method.

df(y,x) - x=0

This is a linear ODE of order 1.
It is solved by quadrature.

     - x                                        1   2
{y=e    *arbconst(39) - x + 1,y=arbconst(40) + ---*x }
                                                2


% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y,x) = x/(x^2*y^2+y^5), y, x);

This is a nonlinear ODE of order 1.
Interchanging dependent and independent variables ...

                2  2    5
 - df(x,y)*x + x *y  + y

This is a nonlinear ODE of order 1.
It is of Bernoulli type.

          3
  2  2/3*y                  3    3
{x =e      *arbconst(41) - y  - ---}
                                 2


% (26) Lagrange 1
odesolve(y = 2x*df(y,x) - a*df(y,x)^3, y, x);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

                        2
 - df(x,G58)*G58 + 3*G58 *a - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                                     4
                               4*arbconst(42) + 3*G58 *a
The subsidiary solution is {x=---------------------------}
                                             2
                                        4*G58

 and the main ODE can be solved parametrically in terms of the derivative.


                              -1    1             3
{{y=2*arbconst(42)*arbparam(2)   + ---*arbparam(2) *a,
                                    2

                            -2    3             2
  x=arbconst(42)*arbparam(2)   + ---*arbparam(2) *a,
                                  4

  arbparam(2)}}

odesolve(y = 2x*df(y,x) - a*df(y,x)^3, y, x, implicit);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

                        2
 - df(x,G59)*G59 + 3*G59 *a - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                                     4
                               4*arbconst(43) + 3*G59 *a
The subsidiary solution is {x=---------------------------}
                                             2
                                        4*G59

 and the main ODE can be solved parametrically in terms of the derivative.


                3  2                   2    2                         2
{64*arbconst(43) *a  + 128*arbconst(43) *a*x  - 144*arbconst(43)*a*x*y

                     4         4       3  2
  + 64*arbconst(43)*x  + 27*a*y  - 16*x *y =0}

% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y = 2x*df(y,x) - df(y,x)^2, y, x);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

 - df(x,G60)*G60 + 2*G60 - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                                     3
                               3*arbconst(44) + 2*G60
The subsidiary solution is {x=-------------------------}
                                            2
                                       3*G60

 and the main ODE can be solved parametrically in terms of the derivative.


                              -1    1             2
{{y=2*arbconst(44)*arbparam(3)   + ---*arbparam(3) ,
                                    3

                            -2    2
  x=arbconst(44)*arbparam(3)   + ---*arbparam(3),
                                  3

  arbparam(3)}}

odesolve(y = 2x*df(y,x) - df(y,x)^2, y, x, implicit);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

 - df(x,G61)*G61 + 2*G61 - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                                     3
                               3*arbconst(45) + 2*G61
The subsidiary solution is {x=-------------------------}
                                            2
                                       3*G61

 and the main ODE can be solved parametrically in terms of the derivative.


                  2                    3                            2  2      3
{ - 9*arbconst(45)  - 12*arbconst(45)*x  + 18*arbconst(45)*x*y + 3*x *y  - 4*y

 =0}


% (28) Riccati 1
odesolve(df(y,x) = exp(x)*y^2 - y + exp(-x), y, x);

This is a nonlinear ODE of order 1.

It is of Riccati type and transforms into the linear second-order ODE: 

df(y,x,2) + y=0

It has constant coefficients.

      - x                         - x
    e    *arbconst(46)*sin(x) - e    *cos(x)
{y=------------------------------------------}
          arbconst(46)*cos(x) + sin(x)


% (29) Riccati 2
factor x;


odesolve(df(y,x) = y^2 - x*y + 1, y, x);

This is a nonlinear ODE of order 1.

It is of Riccati type and transforms into the linear second-order ODE: 

df(y,x,2) + df(y,x)*x + y=0

It has non-constant coefficients.
It is exact, and the following linear ODE of order 1 is a first integral:

df(y,x) + x*y=g66
It is solved by the integrating factor method.

                               2
                          1/2*x
                       2*e      *arbconst(47)
{y=x + ------------------------------------------------------}
                                            - 1/2
        sqrt(pi)*sqrt(2)*arbconst(47)*erf(2      *x*i)*i - 2

remfac x;



% (30) Separable
odesolve(df(y,x) = (9x^8+1)/(y^2+1), y, x);

This is a nonlinear ODE of order 1.
It is separable.

                     9          3
{3*arbconst(48) - 3*x  - 3*x + y  + 3*y=0}


% (31) Solvable for x
odesolve(y = 2x*df(y,x) + y*df(y,x)^2, y, x);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

             5                        2
df(x,G68)*G68  - df(x,G68)*G68 - 2*G68 *x - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                               2
                               arbconst(49)*G68  - arbconst(49)
The subsidiary solution is {x=----------------------------------}
                                                2
                                             G68

 and the main ODE can be solved parametrically in terms of the derivative.


                                 -1
{{y= - 2*arbconst(49)*arbparam(4)  ,

                               -2
  x= - arbconst(49)*arbparam(4)   + arbconst(49),

  arbparam(4)}}

odesolve(y = 2x*df(y,x) + y*df(y,x)^2, y, x, implicit);

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

             5                        2
df(x,G69)*G69  - df(x,G69)*G69 - 2*G69 *x - 2*x=0

This is a first-order linear ODE solved by the integrating factor method.

                                               2
                               arbconst(50)*G69  - arbconst(50)
The subsidiary solution is {x=----------------------------------}
                                                2
                                             G69

 and the main ODE can be solved parametrically in terms of the derivative.


                  2                       2
{ - 4*arbconst(50)  + 4*arbconst(50)*x + y =0}


% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y*df(y,x) - x*df(y,x)^2, y, x)
end;

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

                      2
 - df(x,G70)*G70 - G70 *x + x=0

This is a first-order linear ODE solved by the integrating factor method.

                               arbconst(51)*G70
The subsidiary solution is {x=------------------}
                                       2
                                    G70 /2
                                   e

 and the main ODE can be solved parametrically in terms of the derivative.


                       2
      - 1/2*arbparam(5)                           2
{{y=e                   *arbconst(51)*(arbparam(5)  + 1),

                       2
      - 1/2*arbparam(5)
  x=e                   *arbconst(51)*arbparam(5),

  arbparam(5)}}


% (33) Autonomous 1
odesolve(df(y,x,2)-df(y,x) = 2y*df(y,x), y, x, explicit);

This is a nonlinear ODE of order 2.

This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: df(G71,y)*G71 - 2*G71*y - G71=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

df(G71,y) - 2*y - 1=0

This is a linear ODE of order 1.
It is solved by quadrature.
Restoring order to give these first-order ODEs ...

                             2
 - arbconst(52) + df(y,x) - y  - y=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,x)=0

This is a linear ODE of order 1.
It is solved by quadrature.

Simplifying the arbconst expressions in 4*arbconst(53)*arbconst(52)

 - arbconst(53) - 4*arbconst(52)*x

                                            2*y + 1
 + 2*sqrt(4*arbconst(52) - 1)*atan(--------------------------) + x
                                    sqrt(4*arbconst(52) - 1)

 by the rewrites ...


sqrt(4*arbconst(52) - 1) => arbconst(52)


Solution before trying to solve for dependent variable is 

                         2               2
arbconst(53)*arbconst(52)  - arbconst(52) *x

                          2*y + 1
 + 2*arbconst(52)*atan(--------------)=0
                        arbconst(52)


       1                    1                               1
{y= - ---*arbconst(52)*tan(---*arbconst(53)*arbconst(52) - ---*arbconst(52)*x)
       2                    2                               2

     1
  - ---,
     2

 y=arbconst(54)}


% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y,x,2)/y - df(y,x)^2/y^2 - 1 + 1/y^3 = 0, y, x, algint);

This is a nonlinear ODE of order 2.

This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

               2      2      3
df(G75,y)*G75*y  - G75 *y - y  + 1=0

This is a nonlinear ODE of order 1.
It is of Bernoulli type.
Restoring order to give these first-order ODEs ...

sqrt(y)*sqrt(3)*df(y,x)

                        3             3
 - sqrt(3*arbconst(56)*y  + 6*log(y)*y  + 2)*plus_or_minus(tag_4)=0

This is a nonlinear ODE of order 1.
It is separable.

{arbconst(57)*plus_or_minus(tag_4)

                                  sqrt(y)
  + sqrt(3)*int(-------------------------------------------,y)
                                      3             3
                 sqrt(3*arbconst(56)*y  + 6*log(y)*y  + 2)

  - plus_or_minus(tag_4)*x=0}


% (35) Differentiation method
odesolve(2y*df(y,x,2) - df(y,x)^2 = 1/3(df(y,x) - x*df(y,x,2))^2, y, x, explicit);

This is a nonlinear ODE of order 2.

                                                                            G84
This ODE is equidimensional in the independent variable x -- applying x => e

                                                2
 to transform to the simpler ODE:  - df(y,G84,2)  + 4*df(y,G84,2)*df(y,G84)

                                2
 + 6*df(y,G84,2)*y - 7*df(y,G84)  - 6*df(y,G84)*y=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

            2    2                  2                            2
 - df(G85,y) *G85  + 4*df(G85,y)*G85  + 6*df(G85,y)*G85*y - 7*G85  - 6*G85*y=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

            2
 - df(G85,y) *G85 + 4*df(G85,y)*G85 + 6*df(G85,y)*y - 7*G85 - 6*y=0

This is a nonlinear ODE of order 1.

It is of Lagrange type and reduces to this subsidiary ODE for x(y'): 

             5                  4                   3                   2
df(y,G86)*G86  - 8*df(y,G86)*G86  + 24*df(y,G86)*G86  - 26*df(y,G86)*G86

                                          2
 - 17*df(y,G86)*G86 + 42*df(y,G86) + 6*G86 *y - 12*G86*y - 18*y=0

This is a first-order linear ODE solved by the integrating factor method.

The subsidiary solution is {y

                     2
     arbconst(58)*G86  - 4*arbconst(58)*G86 + 7*arbconst(58)
   =---------------------------------------------------------}
                           2
                        G86  - 4*G86 + 4

 and the main ODE can be solved parametrically in terms of the derivative.

Restoring order to give these first-order ODEs ...

               2                                                           2
16*arbconst(58)  + 4*arbconst(58)*df(y,G84) - 20*arbconst(58)*y + df(y,G84)

                      2
 - 4*df(y,G84)*y + 4*y =0

This is a nonlinear ODE of order 1.
It can be (partially) solved algebraically for the single-order derivative 
and each `root ODE' will be solved separately ...

2*arbconst(58) + df(y,G84)

 - 2*sqrt( - arbconst(58) + y)*sqrt(arbconst(58))*sqrt(3) - 2*y=0

This is a nonlinear ODE of order 1.
It is separable.

2*arbconst(58) + df(y,G84)

 + 2*sqrt( - arbconst(58) + y)*sqrt(arbconst(58))*sqrt(3) - 2*y=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,G84)=0

This is a linear ODE of order 1.
It is solved by quadrature.

                                            G84
Simplifying the arbconst expressions in  - e   *arbconst(59)

 - sqrt(arbconst(58))*sqrt(3) - sqrt( - arbconst(58) + y) by the rewrites ...


sqrt(arbconst(58)) => arbconst(58)


                                            G84
Simplifying the arbconst expressions in  - e   *arbconst(60)

 + sqrt(arbconst(58))*sqrt(3) - sqrt( - arbconst(58) + y) by the rewrites ...


sqrt(arbconst(58)) => arbconst(58)


Solution before trying to solve for dependent variable is 

                                                               2
 - arbconst(59)*x - sqrt(3)*arbconst(58) - sqrt( - arbconst(58)  + y)=0


Solution before trying to solve for dependent variable is 

                                                               2
 - arbconst(60)*x + sqrt(3)*arbconst(58) - sqrt( - arbconst(58)  + y)=0


               2  2                                                         2
{y=arbconst(59) *x  + 2*sqrt(3)*arbconst(59)*arbconst(58)*x + 4*arbconst(58) ,

               2  2                                                         2
 y=arbconst(60) *x  - 2*sqrt(3)*arbconst(60)*arbconst(58)*x + 4*arbconst(58) ,

 y=arbconst(61)}


% (36) Equidimensional in x
odesolve(x*df(y,x,2) = 2y*df(y,x), y, x, explicit);

This is a nonlinear ODE of order 2.

                                                                            G95
This ODE is equidimensional in the independent variable x -- applying x => e

 to transform to the simpler ODE: df(y,G95,2) - 2*df(y,G95)*y - df(y,G95)=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: df(G96,y)*G96 - 2*G96*y - G96=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

df(G96,y) - 2*y - 1=0

This is a linear ODE of order 1.
It is solved by quadrature.
Restoring order to give these first-order ODEs ...

                               2
 - arbconst(62) + df(y,G95) - y  - y=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,G95)=0

This is a linear ODE of order 1.
It is solved by quadrature.

Simplifying the arbconst expressions in 4*arbconst(63)*arbconst(62)

 - arbconst(63) - 4*arbconst(62)*G95

                                            2*y + 1
 + 2*sqrt(4*arbconst(62) - 1)*atan(--------------------------) + G95
                                    sqrt(4*arbconst(62) - 1)

 by the rewrites ...


sqrt(4*arbconst(62) - 1) => arbconst(62)


Solution before trying to solve for dependent variable is 

                         2               2
arbconst(63)*arbconst(62)  - arbconst(62) *log(x)

                          2*y + 1
 + 2*arbconst(62)*atan(--------------)=0
                        arbconst(62)


       1
{y= - ---*arbconst(62)
       2

       1                               1                          1
 *tan(---*arbconst(63)*arbconst(62) - ---*arbconst(62)*log(x)) - ---,
       2                               2                          2

 y=arbconst(64)}


% (37) Equidimensional in y
odesolve((1-x)*(y*df(y,x,2)-df(y,x)^2) + x^2*y^2 = 0, y, x);

This is a nonlinear ODE of order 2.

                                                                          G102
This ODE is equidimensional in the dependent variable y -- applying y => e

                                                                      2
 to transform to the simpler ODE:  - df(G102,x,2)*x + df(G102,x,2) + x =0

This is a linear ODE of order 2.
It has constant coefficients.
Constructing particular integral using `D-operator method'.

                                          3        2
     arbconst(66) + arbconst(65)*x + 1/6*x  + 1/2*x  - x        x
    e                                                   *(x - 1)
{y=---------------------------------------------------------------}
                                x - 1


% (38) Exact second order
odesolve(x*y*df(y,x,2) + x*df(y,x)^2 + y*df(y,x) = 0, y, x, explicit);

This is a nonlinear ODE of order 2.

                                                                            G106
This ODE is equidimensional in the independent variable x -- applying x => e

                                                             2
 to transform to the simpler ODE: df(y,G106,2)*y + df(y,G106) =0


This ODE is autonomous -- transforming dependent variable 

                                                                         2
to derivative to give this ODE of order 1 lower: df(G107,y)*G107*y + G107 =0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

df(G107,y)*y + G107=0

This is a linear ODE of order 1.
It is solved by the integrating factor method.
Restoring order to give these first-order ODEs ...

 - arbconst(67) + df(y,G106)*y=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,G106)=0

This is a linear ODE of order 1.
It is solved by quadrature.

Solution before trying to solve for dependent variable is 

                                                       2
2*arbconst(68)*arbconst(67) - 2*arbconst(67)*log(x) + y =0


{y=sqrt( - arbconst(68) + log(x))*sqrt(arbconst(67))*sqrt(2),

 y= - sqrt( - arbconst(68) + log(x))*sqrt(arbconst(67))*sqrt(2),

 y=arbconst(69)}


% (39) Factoring differential operator
odesolve(df(y,x,2)^2 - 2df(y,x)*df(y,x,2) + 2y*df(y,x) - y^2 = 0, y, x);

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

df(y,x,2) - 2*df(y,x) + y=0

This is a linear ODE of order 2.
It has constant coefficients.

df(y,x,2) - y=0

This is a linear ODE of order 2.
It has constant coefficients.

    x                 x
{y=e *arbconst(71) + e *arbconst(70)*x,

    x                  - x
 y=e *arbconst(73) + e    *arbconst(72)}


% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y,x,2) + 3x*df(y,x) = 1/(y^3*x^4), y, x);

This is a nonlinear ODE of order 2.

                                              -1
This ODE is scale invariant -- applying y => x  *G113

 to transform to the simpler ODE: 

                 3  2                  3         4
df(G113,x,2)*G113 *x  + df(G113,x)*G113 *x - G113  - 1=0


                                                                            G115
This ODE is equidimensional in the independent variable x -- applying x => e

                                                      3       4
 to transform to the simpler ODE: df(G113,G115,2)*G113  - G113  - 1=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

                  3            4
df(G116,G113)*G113 *G116 - G113  - 1=0

This is a nonlinear ODE of order 1.
It is separable.
Restoring order to give these first-order ODEs ...

                   2                2     2       4
4*arbconst(74)*G113  + df(G113,G115) *G113  - G113  + 1=0

This is a nonlinear ODE of order 1.
It can be (partially) solved algebraically for the single-order derivative 
and each `root ODE' will be solved separately ...

df(G113,G115)*G113

                              2       4
 - sqrt( - 4*arbconst(74)*G113  + G113  - 1)*plus_or_minus(tag_6)=0

This is a nonlinear ODE of order 1.
It is separable.

{2*arbconst(75)*plus_or_minus(tag_6)

                                                     2  2    4  4         2  2
          - 2*arbconst(74) + sqrt( - 4*arbconst(74)*x *y  + x *y  - 1) + x *y
  + log(-----------------------------------------------------------------------)
                                                  2
                               sqrt(4*arbconst(74)  + 1)

  - 2*log(x)*plus_or_minus(tag_6)=0}


% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y,x,2) + 3x*df(y,x) + 2*y = 1/(y^3*x^4);


                  2                      -4  -3
ode := df(y,x,2)*x  + 3*df(y,x)*x + 2*y=x  *y

% Choose full (explicit and expanded) solution:
odesolve(ode, y, x, full);

This is a nonlinear ODE of order 2.

                                              -1
This ODE is scale invariant -- applying y => x  *G122

 to transform to the simpler ODE: 

                 3  2                  3         4
df(G122,x,2)*G122 *x  + df(G122,x)*G122 *x + G122  - 1=0


                                                                            G124
This ODE is equidimensional in the independent variable x -- applying x => e

                                                      3       4
 to transform to the simpler ODE: df(G122,G124,2)*G122  + G122  - 1=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

                  3            4
df(G125,G122)*G122 *G125 + G122  - 1=0

This is a nonlinear ODE of order 1.
It is separable.
Restoring order to give these first-order ODEs ...

                    2                  2     2         4
15*arbconst(76)*G122  - 4*df(G122,G124) *G122  - 4*G122  - 4=0

This is a nonlinear ODE of order 1.
It can be (partially) solved algebraically for the single-order derivative 
and each `root ODE' will be solved separately ...

2*df(G122,G124)*G122

                            2         4
 - sqrt(15*arbconst(76)*G122  - 4*G122  - 4)*plus_or_minus(tag_7)=0

This is a nonlinear ODE of order 1.
It is separable.

Solution before trying to solve for dependent variable is 

                                                                  2  2
                                             15*arbconst(76) - 8*x *y
2*arbconst(77)*plus_or_minus(tag_7) - asin(------------------------------)
                                                                 2
                                            sqrt(225*arbconst(76)  - 64)

 - 2*log(x)*plus_or_minus(tag_7)=0


       1
{y= - ---*sqrt(15*arbconst(76)
       2

                                       2
                - sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  ,

       1
 y= - ---*sqrt(15*arbconst(76)
       2

                                       2
                + sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  ,

    1
 y=---*sqrt(15*arbconst(76)
    2

                                    2
             - sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  ,

    1
 y=---*sqrt(15*arbconst(76)
    2

                                    2
             + sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  }
              % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));


{0,0,0,0}


% (41) Autonomous, 3rd order
odesolve((df(y,x)^2+1)*df(y,x,3) - 3df(y,x)*df(y,x,2)^2 = 0, y, x);

This is a nonlinear ODE of order 3.

Performing trivial order reduction to give the order 2 nonlinear ODE: 

           2                        2
df(y,x,2)*y  + df(y,x,2) - 3*df(y,x) *y=0


This ODE is autonomous -- transforming dependent variable 

to derivative to give this ODE of order 1 lower: 

                 2                           2
df(G131,y)*G131*y  + df(G131,y)*G131 - 3*G131 *y=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

            2
df(G131,y)*y  + df(G131,y) - 3*G131*y=0

This is a linear ODE of order 1.
It is solved by the integrating factor method.
Restoring order to give these first-order ODEs ...

         2                    2         2
 - sqrt(y  + 1)*arbconst(78)*y  - sqrt(y  + 1)*arbconst(78) + df(y,x)=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,x)=0

This is a linear ODE of order 1.
It is solved by quadrature.

                                                             2
Solution of order-reduced ODE is {arbconst(79)*arbconst(78)*y

                                                  2
    + arbconst(79)*arbconst(78) - arbconst(78)*x*y  - arbconst(78)*x

            2           2
    + sqrt(y  + 1)*y + y  + 1=0,

   y=arbconst(80)}


                                                                            2
Restoring order, y => df(y,x,1), to give: {arbconst(79)*arbconst(78)*df(y,x)

                                                      2
    + arbconst(79)*arbconst(78) - arbconst(78)*df(y,x) *x - arbconst(78)*x

             2               2
    + df(y,x)  + sqrt(df(y,x)  + 1)*df(y,x) + 1=0,

   df(y,x)=arbconst(80)} and re-solving ...


Simplifying the arbconst expressions in (arbconst(81)*arbconst(78) + sqrt(

                  2
      arbconst(79) *arbconst(78) - 2*arbconst(79)*arbconst(78)*x

                                        2
       + 2*arbconst(79) + arbconst(78)*x  - 2*x)*sqrt(arbconst(78))*i)/arbconst(

   78) by the rewrites ...


sqrt(arbconst(78)) => arbconst(78)


                                   2             2
{y=arbconst(81) + sqrt(arbconst(79) *arbconst(78)

                                  2                                  2  2
     - 2*arbconst(79)*arbconst(78) *x + 2*arbconst(79) + arbconst(78) *x  - 2*x)

              -1
 *arbconst(78)  *i,

 y=arbconst(82) + i*x,

 y=arbconst(83) - i*x,

 y=arbconst(84) + arbconst(80)*x}


% (42) Autonomous, 4th order
odesolve(3*df(y,x,2)*df(y,x,4) - 5df(y,x,3)^2 = 0, y, x);

This is a nonlinear ODE of order 4.

Performing trivial order reduction to give the order 2 nonlinear ODE: 

                         2
3*df(y,x,2)*y - 5*df(y,x) =0


This ODE is autonomous -- transforming dependent variable 

                                                                             2
to derivative to give this ODE of order 1 lower: 3*df(G136,y)*G136*y - 5*G136 =0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

3*df(G136,y)*y - 5*G136=0

This is a linear ODE of order 1.
It is solved by the integrating factor method.
Restoring order to give these first-order ODEs ...

    2/3
 - y   *arbconst(85)*y + df(y,x)=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,x)=0

This is a linear ODE of order 1.
It is solved by quadrature.

Solution of order-reduced ODE is {

      2/3                                2/3
   2*y   *arbconst(86)*arbconst(85) - 2*y   *arbconst(85)*x - 3=0,

   y=arbconst(87)}


Restoring order, y => df(y,x,2), to give: {

              2/3                                        2/3
   2*df(y,x,2)   *arbconst(86)*arbconst(85) - 2*df(y,x,2)   *arbconst(85)*x - 3

   =0,

   df(y,x,2)=arbconst(87)} and re-solving ...


                                                                  2
Simplifying the arbconst expressions in (arbconst(89)*arbconst(85) *x

                               2
    + arbconst(88)*arbconst(85)

                                                                       2
    - 3*sqrt(arbconst(86) - x)*sqrt(arbconst(85))*sqrt(6))/arbconst(85)

 by the rewrites ...


sqrt(arbconst(85)) => arbconst(85)


                                                                  2
Simplifying the arbconst expressions in (arbconst(91)*arbconst(85) *x

                               2
    + arbconst(90)*arbconst(85)

                                                                       2
    + 3*sqrt(arbconst(86) - x)*sqrt(arbconst(85))*sqrt(6))/arbconst(85)

 by the rewrites ...


sqrt(arbconst(85)) => arbconst(85)


{y=arbconst(89)*x + arbconst(88)

                                                 -3
  - 3*sqrt(arbconst(86) - x)*sqrt(6)*arbconst(85)  ,

 y=arbconst(91)*x + arbconst(90)

                                                 -3
  + 3*sqrt(arbconst(86) - x)*sqrt(6)*arbconst(85)  ,

                                    1                2
 y=arbconst(93)*x + arbconst(92) + ---*arbconst(87)*x }
                                    2



% 1.3 Special equations
% =====================

% (43) Delay
operator y;


odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);


***** Arguments of y differ -- solving delay equations is not implemented.


% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);

This is a linear ODE of order 1.
It is solved by the integrating factor method.

         a*x
{y(x,a)=e   *arbconst(94)}



% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y,x,4) = sin x, y, x,
   {x=0, y=0, df(y,x)=0, df(y,x,2)=0, df(y,x,3)=0});

This is a linear ODE of order 4.
It has constant coefficients.
Constructing particular integral using `D-operator method'.

General solution is {y

                                                  2                 3
   =arbconst(98) + arbconst(97)*x + arbconst(96)*x  + arbconst(95)*x  + sin(x)}


Applying conditions {{x=0,y=0,df(y,x)=0,df(y,x,2)=0,df(y,x,3)=0}}


             1   3
{y=sin(x) + ---*x  - x}
             6


% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y,x,2) + df(y,x) + 2x*y = 0, y, x,
   {x=0, y=1, df(y,x)=0});

This is a linear ODE of order 2.
It has non-constant coefficients.
The reduced ODE can be solved in terms of special functions.

General solution is {y

   =arbconst(100)*bessely(0,sqrt(2)*x) + arbconst(99)*besselj(0,sqrt(2)*x)}


Applying conditions {{x=0,y=1,df(y,x)=0}}


{y=besselj(0,sqrt(2)*x)}


% (47) Second-degree separable
soln :=
   odesolve(x*df(y,x)^2 - y^2 + 1 = 0, y=1, x=0, explicit);

This is a nonlinear ODE of order 1.
It can be (partially) solved algebraically for the single-order derivative 
and each `root ODE' will be solved separately ...

                        2
sqrt(x)*df(y,x) - sqrt(y  - 1)*plus_or_minus(tag_8)=0

This is a nonlinear ODE of order 1.
It is separable.

General solution is {arbconst(101)*plus_or_minus(tag_8)

                                                 2
    - 2*sqrt(x)*plus_or_minus(tag_8) + log(sqrt(y  - 1) + y)=0}


Applying conditions {{x=0,y=1}}


Solution before trying to solve for dependent variable is 

                                              2
 - 2*sqrt(x)*plus_or_minus(tag_8) + log(sqrt(y  - 1) + y)=0


soln := 

    1   2*sqrt(x)*plus_or_minus(tag_8)    1    - 2*sqrt(x)*plus_or_minus(tag_8)
{y=---*e                               + ---*e                                 }
    2                                     2

% Alternatively ...
soln where e^~x => cosh x + sinh x;


{y=cosh(2*sqrt(x)*plus_or_minus(tag_8))}

% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);


{y=cosh(2*sqrt(x)*plus_or_minus(tag_8))}

expand_plus_or_minus ws;


{y=cosh(2*sqrt(x))}


% (48) Autonomous
odesolve(df(y,x,2) + y*df(y,x)^3 = 0, y, x, {x=0, y=0, df(y,x)=2});

This is a nonlinear ODE of order 2.

This ODE is autonomous -- transforming dependent variable 

                                                                       3
to derivative to give this ODE of order 1 lower: df(G148,y)*G148 + G148 *y=0

This is a nonlinear ODE that factorizes algebraically 
and each distinct factor ODE will be solved separately ...

                 2
df(G148,y) + G148 *y=0

This is a nonlinear ODE of order 1.
It is separable.
Restoring order to give these first-order ODEs ...

                                   2
2*arbconst(102)*df(y,x) - df(y,x)*y  + 2=0

This is a nonlinear ODE of order 1.
It is separable.

df(y,x)=0

This is a linear ODE of order 1.
It is solved by quadrature.

                                                                  3
General solution is {6*arbconst(103) - 6*arbconst(102)*y - 6*x + y =0,y

   =arbconst(104)}


Applying conditions {{x=0,y=0,df(y,x)=2}}


           3
{ - 6*x + y  + 3*y=0}

%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y,x,2) + y*df(y,x)^3 = 0, y, x,
      {x=0, y=0, df(y,x)=2}, explicit);
end;


            2            1/3            2             - 1/3
{y=(sqrt(9*x  + 1) + 3*x)    - (sqrt(9*x  + 1) + 3*x)      }



% 3  Systems of equations
% =======================

% (49) Integrable combinations
depend {x, y, z}, t;


odesolve({df(x,t) = -3y*z, df(y,t) = 3x*z, df(z,t) = -x*y}, {x,y,z}, t);


odesolve-system({df(x,t) + 3*y*z,

                 df(y,t) - 3*x*z,

                 df(z,t) + x*y},{x,y,z},t)


% (50) Matrix Riccati
depend {a, b}, t;


odesolve({df(x,t) = a*(y^2-x^2) + 2b*x*y + 2c*x,
   df(y,t) = b*(y^2-x^2) - 2a*x*y + 2c*y}, {x,y}, t);


                              2      2
odesolve-system({df(x,t) + a*x  - a*y  - 2*b*x*y - 2*c*x,

                                        2      2
                 df(y,t) + 2*a*x*y + b*x  - b*y  - 2*c*y},{x,y},t)


% (51) Triangular
odesolve({df(x,t) = x*(1 + cos(t)/(2+sin(t))), df(y,t) = x - y},
   {x,y}, t);


                   - cos(t)*x + df(x,t)*sin(t) + 2*df(x,t) - sin(t)*x - 2*x
odesolve-system({-----------------------------------------------------------,
                                         sin(t) + 2

                 df(y,t) - x + y},{x,y},t)


% (52) Vector
odesolve({df(x,t) = 9x + 2y, df(y,t) = x + 8y}, {x,y}, t);


odesolve-system({df(x,t) - 9*x - 2*y,df(y,t) - x - 8*y},{x,y},t)


% (53) Higher order
odesolve({df(x,t) - x + 2y = 0, df(x,t,2) - 2df(y,t) = 2t - cos(2t)},
   {x,y}, t);


odesolve-system({df(x,t) - x + 2*y,

                 cos(2*t) + df(x,t,2) - 2*df(y,t) - 2*t},{x,y},t)


% (54) Inhomogeneous system
equ := {df(x,t) = -1/(t*(t^2+1))*x + 1/(t^2*(t^2+1))*y + 1/t,
        df(y,t) = -t^2/(t^2+1)*x + (2t^2+1)/(t*(t^2+1))*y + 1};


                      -1      -1    -2
                 t - t  *x + t   + t  *y
equ := {df(x,t)=-------------------------,
                          2
                         t  + 1

                     2      2            -1
                  - t *x + t  + 2*t*y + t  *y + 1
        df(y,t)=----------------------------------}
                               2
                              t  + 1

odesolve(equ, {x,y}, t);


                           2                  -1      -1    -2
                  df(x,t)*t  + df(x,t) - t + t  *x - t   - t  *y
odesolve-system({------------------------------------------------,
                                       2
                                      t  + 1

                           2              2      2            -1
                  df(y,t)*t  + df(y,t) + t *x - t  - 2*t*y - t  *y - 1
                 ------------------------------------------------------},{x,y},t
                                          2
                                         t  + 1

)


end;



Time for test: 20727 ms, plus GC time: 1952 ms

mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/extend.tst0000644000175000017500000000426411526203062024355 0ustar  giovannigiovanni% Test and demonstration of the ODESolve extension interface

% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <17 July 2000>

% Load odesolve before inputting this file if not using test interface:
% load_package odesolve;

% Hook into the general ODE solver:

algebraic procedure ODESolve_Hook_Demo (ode, y, x);
   %% For any ODE, if the dependent variable is z then this hook
   %% procedure returns a solution corresponding to ODESolve failing
   %% to find any solution; otherwise it returns nil (nothing) and so
   %% is ignored.
   if y=z then {ode=0};

% Set the hook:
symbolic(ODESolve_Before_Hook := '(ODESolve_Hook_Demo));

% Hook into the nonlinear ODE solver:

algebraic procedure ODESolve_Non_Hook_Demo (ode, y, x, n);
   %% If the ODE is nontrivially nonlinear and the order is 3 then
   %% this hook procedure returns a solution corresponding to ODESolve
   %% failing to find any solution; otherwise it returns nil (nothing)
   %% and so is ignored.
   if n=3 then {ode=0};

% Set the hook:
symbolic(ODESolve_Before_Non_Hook := '(ODESolve_Non_Hook_Demo));

% Hook into the general linear ODE solver:

algebraic procedure ODESolve_Lin_Hook_Demo
   (odecoeffs, driver, y, x, n, m);
   %% If the ODE is linear and the order is 3 then this hook procedure
   %% returns a solution corresponding to ODESolve failing to find any
   %% solution; otherwise it returns nil (nothing) and so is ignored.
   %% (NB: Algebraic-mode lists are indexed from 1 in REDUCE!)
   if n=3 then
      {(for i := m : n sum part(odecoeffs,i+1)*df(y,x,i)) = driver};

% Set the hook:
symbolic(ODESolve_Before_Lin_Hook := '(ODESolve_Lin_Hook_Demo));

% Test all the hooks:

% The general ODE solver:
odesolve(df(y,x));                      % hook ignored
odesolve(df(z,x));                      % hook operates

% The nonlinear ODE solver:
odesolve(y*df(y,x,2)+1);                % hook ignored
odesolve(y*df(y,x,3)+1);                % hook operates

% The general linear ODE solver:
odesolve(df(y,x,2)+1);                  % hook ignored
odesolve(df(y,x,3)+1);                  % hook operates

% Clear the hooks:
symbolic(ODESolve_Before_Hook := nil);
symbolic(ODESolve_Before_Non_Hook := nil);
symbolic(ODESolve_Before_Lin_Hook := nil);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimopbas.rlg0000644000175000017500000005302111526203062024657 0ustar  giovannigiovanniREDUCE Development Version, Wed Sep 13 20:40:41 2000 ...







ODESolve 1.065

% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses Maple-style functional notation wherever possible.
% It outputs general solutions of linear ODEs in basis format.
% It also checks all solutions.

on odesolve_basis, odesolve_check;


on div, intstr;

  off allfac;

            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

operator y;



% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y(x),x) + 2*x^4*y(x) = x^3/3 + C, y(x), x);


       - 2*x
     e
{{--------------},
    2
   x  - 2*x + 1

   1     -2    1       1
  ---*c*x   + ---*x - ---
   2           6       4
 -------------------------}
        2
       x  - 2*x + 1


% (2) Linear Bernoulli 2
odesolve(-1/2*df(y(x),x) + y(x) = sin x, y(x), x);


   2*x   2            4
{{e   },---*cos(x) + ---*sin(x)}
         5            5


% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y(x),x,2)*(a*x+b)^2 + 4df(y(x),x)*(a*x+b)*a + 2y(x)*a^2 = 0,
   y(x), x);


             2
            a                a
{{----------------------,---------}}
    2  2              2   a*x + b
   a *x  + 2*a*b*x + b


% (4) Adjoint
odesolve((x^2-x)*df(y(x),x,2) + (2x^2+4x-3)*df(y(x),x) + 8x*y(x) = 1,
   y(x), x);


               2                                  2
{df(y(x),x,2)*x  - df(y(x),x,2)*x + 2*df(y(x),x)*x  + 4*df(y(x),x)*x

  - 3*df(y(x),x) + 8*y(x)*x - 1=0}


% (5) Polynomial solutions
% (FJW: Currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y(x),x,2) + (1-2x^2)*df(y(x),x) + (4x-2)*y(x) = 0,
%    y(x), x);

% (6) Dependent variable missing
odesolve(df(y(x),x,2) + 2x*df(y(x),x) = 2x, y(x), x);


   1
{{---*sqrt(pi)*erf(x),1},x}
   2


% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y(x),x,2) + (2x^2-3x+1)*df(y(x),x) + (x-1)*y(x) = 0,
      y(x), x, algint);
end;


               -1                         1/x
    - 1/2   - x           - 1/2          e   *sqrt(x - 2)
{{x      *e      *(x - 2)      *int(--------------------------,x),
                                              2
                                     sqrt(x)*x  - 2*sqrt(x)*x

               -1
    - 1/2   - x           - 1/2
  x      *e      *(x - 2)      }}

% NB: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON ALGINT OR NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y(x),x,2) - 2x*df(y(x),x) + 2y(x) = 3, y(x), x);


***** Cannot convert nonlinear combination solution to basis!

{arbconst(2) + sqrt(pi)*arbconst(1)

                               erf(i*x)
 *int(-----------------------------------------------------------,x)*i
                                             2
                                            x
       sqrt(pi)*arbconst(1)*erf(i*x)*i*x + e  *arbconst(1) - 2*x

                                       1
  - 2*int(-----------------------------------------------------------,x)
                                                 2
                                                x
           sqrt(pi)*arbconst(1)*erf(i*x)*i*x + e  *arbconst(1) - 2*x

                3
  - log(y(x) - ---)=0}
                2


% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y(x),x,2) + 2x*df(y(x),x) + 3y(x) = 0, y(x), x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y(x),x,2) - 2/x^2*y(x) = 7x^4 + 3*x^3, y(x), x);


   -1  2   1   6    1   5
{{x  ,x },---*x  + ---*x }
           4        6


% (12) Variation of parameters
odesolve(df(y(x),x,2) + y(x) = csc(x), y(x), x);


{{cos(x),sin(x)}, - cos(x)*x + log(sin(x))*sin(x)}


% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y(x),x,7) - 14df(y(x),x,6) + 80df(y(x),x,5) - 242df(y(x),x,4)
   + 419df(y(x),x,3) - 416df(y(x),x,2) + 220df(y(x),x) - 48y(x) = 0, y(x), x);
remfac exp(x) >>;


   3*x
{{e   ,

   4*x
  e   ,

   2*x
  e   *x,

   2*x
  e   ,

   x  2
  e *x ,

   x
  e *x,

   x
  e }}


% (14) Euler
odesolve(df(y(x),x,4) - 4/x^2*df(y(x),x,2) + 8/x^3*df(y(x),x) - 8/x^4*y(x) = 0,
   y(x), x);


   -1    2  4
{{x  ,x,x ,x }}


% (15) Exact n-th order
odesolve((1+x+x^2)*df(y(x),x,3) + (3+6x)*df(y(x),x,2) + 6df(y(x),x) = 6x,
   y(x), x);


      1   2
     ---*x
      2
{{------------,
    2
   x  + x + 1

       x
  ------------,
    2
   x  + x + 1

       1
  ------------},
    2
   x  + x + 1

     1   4
    ---*x
     4
 ------------}
   2
  x  + x + 1



% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y(x),x) = y(x)/(y(x)*log y(x) + x), y(x), x);


                       1           2
{x=arbconst(4)*y(x) + ---*log(y(x)) *y(x)}
                       2


% (17) Integrating factors 2
odesolve(2y(x)*df(y(x),x)^2 - 2x*df(y(x),x) - y(x) = 0, y(x), x);


                       4                 2      - 1/3             - 2/3  1/3
{{y(x)=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

  *arbconst(5)*arbparam(1),

                    4                 2      - 1/3             - 2/3  1/3
  x=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

                          2                 4                 2      - 1/3
  *arbconst(5)*arbparam(1)  - (4*arbparam(1)  - 12*arbparam(1)  + 9)

               - 2/3  1/3
  *arbparam(1)      *2   *arbconst(5),

  arbparam(1)}}

% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y(x),x) + y(x) = y(x)^3*sin x, y(x), x, explicit);


{y(x)

      2*x                                    - 1/2
 =(5*e   *arbconst(6) + 2*cos(x) + 4*sin(x))      *sqrt(5)*plus_or_minus(tag_1)}

expand_plus_or_minus ws;


          2*x                                    - 1/2
{y(x)=(5*e   *arbconst(6) + 2*cos(x) + 4*sin(x))      *sqrt(5),

             2*x                                    - 1/2
 y(x)= - (5*e   *arbconst(6) + 2*cos(x) + 4*sin(x))      *sqrt(5)}


% (19) Bernoulli 2
operator P, Q;


begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^n, y(x), x);
   off allfac;  return soln
end;


      - n          (n - 1)*int(p(x),x)
{y(x)    *y(x)= - e

                 - int(p(x),x)*n + int(p(x),x)
 *((n - 1)*int(e                              *q(x),x) - arbconst(7))}

odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^(2/3), y(x), x);


     1/3   - 1/3*int(p(x),x)
{y(x)   =e                  *arbconst(8)

     1    - 1/3*int(p(x),x)      1/3*int(p(x),x)
  + ---*e                  *int(e               *q(x),x)}
     3


% (20) Clairaut 1
odesolve((x^2-1)*df(y(x),x)^2 - 2x*y(x)*df(y(x),x) + y(x)^2 - 1 = 0,
   y(x), x, explicit);


                                      2
{y(x)=arbconst(9)*x + sqrt(arbconst(9)  + 1),

                                      2
 y(x)=arbconst(9)*x - sqrt(arbconst(9)  + 1),

               2
 y(x)=sqrt( - x  + 1),

                  2
 y(x)= - sqrt( - x  + 1)}


% (21) Clairaut 2
operator f, g;


odesolve(f(x*df(y(x),x)-y(x)) = g(df(y(x),x)), y(x), x);


{f(arbconst(10)*x - y(x)) - g(arbconst(10))=0}


% (22) Equations of the form  y' = f(x,y)
odesolve(df(y(x),x) = (3x^2-y(x)^2-7)/(exp(y(x))+2x*y(x)+1), y(x), x);


                 y(x)       2             3
{arbconst(11) + e     + y(x) *x + y(x) - x  + 7*x=0}


% (23) Homogeneous
odesolve(df(y(x),x) = (2x^3*y(x)-y(x)^4)/(x^4-2x*y(x)^3), y(x), x);


                           3    3
{arbconst(12)*y(x)*x + y(x)  + x =0}


% (24) Factoring the equation
odesolve(df(y(x),x)*(df(y(x),x)+y(x)) = x*(x+y(x)), y(x), x);


        - x
{y(x)=e    *arbconst(13) - x + 1,

                      1   2
 y(x)=arbconst(14) + ---*x }
                      2


% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y(x),x) = x/(x^2*y(x)^2+y(x)^5), y(x), x);


             3
  2  2/3*y(x)                     3    3
{x =e         *arbconst(15) - y(x)  - ---}
                                       2


% (26) Lagrange 1
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x);


                                 -1    1             3
{{y(x)=2*arbconst(16)*arbparam(2)   + ---*arbparam(2) *a,
                                       2

                            -2    3             2
  x=arbconst(16)*arbparam(2)   + ---*arbparam(2) *a,
                                  4

  arbparam(2)}}

odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x, implicit);


                3  2                   2    2                        2
{64*arbconst(17) *a  + 128*arbconst(17) *a*x  - 144*arbconst(17)*y(x) *a*x

                     4          4            2  3
  + 64*arbconst(17)*x  + 27*y(x) *a - 16*y(x) *x =0}

% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x);


                                 -1    1             2
{{y(x)=2*arbconst(18)*arbparam(3)   + ---*arbparam(3) ,
                                       3

                            -2    2
  x=arbconst(18)*arbparam(3)   + ---*arbparam(3),
                                  3

  arbparam(3)}}

odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x, implicit);


                  2                                             3         3
{ - 9*arbconst(19)  + 18*arbconst(19)*y(x)*x - 12*arbconst(19)*x  - 4*y(x)

          2  2
  + 3*y(x) *x =0}


% (28) Riccati 1
odesolve(df(y(x),x) = exp(x)*y(x)^2 - y(x) + exp(-x), y(x), x);


         - x                         - x
       e    *arbconst(20)*sin(x) - e    *cos(x)
{y(x)=------------------------------------------}
             arbconst(20)*cos(x) + sin(x)


% (29) Riccati 2
<< factor x;  write
odesolve(df(y(x),x) = y(x)^2 - x*y(x) + 1, y(x), x);
remfac x >>;


                                  2
                             1/2*x
                          2*e      *arbconst(21)
{y(x)=x + ------------------------------------------------------}
                                               - 1/2
           sqrt(pi)*sqrt(2)*arbconst(21)*erf(2      *x*i)*i - 2


% (30) Separable
odesolve(df(y(x),x) = (9x^8+1)/(y(x)^2+1), y(x), x);


                      3               9
{3*arbconst(22) + y(x)  + 3*y(x) - 3*x  - 3*x=0}


% (31) Solvable for x
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x);


                                    -1
{{y(x)= - 2*arbconst(23)*arbparam(4)  ,

                               -2
  x= - arbconst(23)*arbparam(4)   + arbconst(23),

  arbparam(4)}}

odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x, implicit);


                  2                          2
{ - 4*arbconst(24)  + 4*arbconst(24)*x + y(x) =0}


% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y(x)*df(y(x),x) - x*df(y(x),x)^2, y(x), x)
end;


                          2
         - 1/2*arbparam(5)                           2
{{y(x)=e                   *arbconst(25)*(arbparam(5)  + 1),

                       2
      - 1/2*arbparam(5)
  x=e                   *arbconst(25)*arbparam(5),

  arbparam(5)}}


% (33) Autonomous 1
odesolve(df(y(x),x,2)-df(y(x),x) = 2y(x)*df(y(x),x), y(x), x, explicit);


{y(x)

      1                    arbconst(27)*arbconst(26) - arbconst(26)*x      1
 = - ---*arbconst(26)*tan(--------------------------------------------) - ---,
      2                                        2                           2

 y(x)=arbconst(28)}


% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y(x),x,2)/y(x) - df(y(x),x)^2/y(x)^2 - 1 + 1/y(x)^3 = 0,
   y(x), x, algint);


{arbconst(31)*plus_or_minus(tag_4) + sqrt(3)

                                     3                   3      - 1/2
 *int(sqrt(y(x))*(3*arbconst(30)*y(x)  + 6*log(y(x))*y(x)  + 2)      ,y(x))

  - plus_or_minus(tag_4)*x=0}


% (35) Differentiation method
odesolve(2y(x)*df(y(x),x,2) - df(y(x),x)^2 =
   1/3(df(y(x),x) - x*df(y(x),x,2))^2, y(x), x, explicit);


                  2  2                                                         2
{y(x)=arbconst(33) *x  + 2*sqrt(3)*arbconst(33)*arbconst(32)*x + 4*arbconst(32)

 ,

                  2  2                                                         2
 y(x)=arbconst(34) *x  - 2*sqrt(3)*arbconst(34)*arbconst(32)*x + 4*arbconst(32)

 ,

 y(x)=arbconst(35)}


% (36) Equidimensional in x
odesolve(x*df(y(x),x,2) = 2y(x)*df(y(x),x), y(x), x, explicit);


          1                    arbconst(37)*arbconst(36) - arbconst(36)*log(x)
{y(x)= - ---*arbconst(36)*tan(-------------------------------------------------)
          2                                           2

     1
  - ---,
     2

 y(x)=arbconst(38)}


% (37) Equidimensional in y
odesolve((1-x)*(y(x)*df(y(x),x,2)-df(y(x),x)^2) + x^2*y(x)^2 = 0, y(x), x);


                                             3        2
        arbconst(40) + arbconst(39)*x + 1/6*x  + 1/2*x  - x        x
       e                                                   *(x - 1)
{y(x)=---------------------------------------------------------------}
                                   x - 1


% (38) Exact second order
odesolve(x*y(x)*df(y(x),x,2) + x*df(y(x),x)^2 + y(x)*df(y(x),x) = 0,
   y(x), x, explicit);


{y(x)=sqrt( - arbconst(42) + log(x))*sqrt(arbconst(41))*sqrt(2),

 y(x)= - sqrt( - arbconst(42) + log(x))*sqrt(arbconst(41))*sqrt(2),

 y(x)=arbconst(43)}


% (39) Factoring differential operator
odesolve(df(y(x),x,2)^2 - 2df(y(x),x)*df(y(x),x,2) + 2y(x)*df(y(x),x) -
   y(x)^2 = 0, y(x), x);


       x                 x
{y(x)=e *arbconst(45) + e *arbconst(44)*x,

       x                  - x
 y(x)=e *arbconst(47) + e    *arbconst(46)}


% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y(x),x,2) + 3x*df(y(x),x) = 1/(y(x)^3*x^4), y(x), x);


{2*arbconst(49)*plus_or_minus(tag_7) + log(

                        2      - 1/2                               2      - 1/2
     - 2*(4*arbconst(48)  + 1)      *arbconst(48) + (4*arbconst(48)  + 1)

                                2  2       4  4
    *sqrt( - 4*arbconst(48)*y(x) *x  + y(x) *x  - 1)

                      2      - 1/2     2  2
     + (4*arbconst(48)  + 1)      *y(x) *x ) - 2*log(x)*plus_or_minus(tag_7)=0}


% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y(x),x,2) + 3x*df(y(x),x) + 2*y(x) = 1/(y(x)^3*x^4);


                     2                               -3  -4
ode := df(y(x),x,2)*x  + 3*df(y(x),x)*x + 2*y(x)=y(x)  *x

% Choose full (explicit and expanded) solution:
odesolve(ode, y(x), x, full);


          1
{y(x)= - ---*sqrt(15*arbconst(50)
          2

                            2                                         - 1/2  -1
     - sqrt(225*arbconst(50)  - 64)*sin(2*(arbconst(51) - log(x))))*2      *x  ,

          1
 y(x)= - ---*sqrt(15*arbconst(50)
          2

                            2                                         - 1/2  -1
     + sqrt(225*arbconst(50)  - 64)*sin(2*(arbconst(51) - log(x))))*2      *x  ,

       1
 y(x)=---*sqrt(15*arbconst(50)
       2

                                       2
                - sqrt(225*arbconst(50)  - 64)*sin(2*(arbconst(51) - log(x))))

    - 1/2  -1
 *2      *x  ,

       1
 y(x)=---*sqrt(15*arbconst(50)
       2

                                       2
                + sqrt(225*arbconst(50)  - 64)*sin(2*(arbconst(51) - log(x))))

    - 1/2  -1
 *2      *x  }
           % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));


{0,0,0,0}


% (41) Autonomous, 3rd order
odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
   y(x), x);


                                      2             2
{y(x)=arbconst(55) + sqrt(arbconst(53) *arbconst(52)

                                  2                                  2  2
     - 2*arbconst(53)*arbconst(52) *x + 2*arbconst(53) + arbconst(52) *x  - 2*x)

              -1
 *arbconst(52)  *i,

 y(x)=arbconst(56) + i*x,

 y(x)=arbconst(57) - i*x,

 y(x)=arbconst(58) + arbconst(54)*x}

% odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
%    y(x), x, implicit);
% Implicit form is currently too messy!

% (42) Autonomous, 4th order
odesolve(3*df(y(x),x,2)*df(y(x),x,4) - 5df(y(x),x,3)^2 = 0, y(x), x);


{y(x)=arbconst(63)*x + arbconst(62)

                                                 -3
  - 3*sqrt(arbconst(60) - x)*sqrt(6)*arbconst(59)  ,

 y(x)=arbconst(65)*x + arbconst(64)

                                                 -3
  + 3*sqrt(arbconst(60) - x)*sqrt(6)*arbconst(59)  ,

                                       1                2
 y(x)=arbconst(67)*x + arbconst(66) + ---*arbconst(61)*x }
                                       2



% 1.3 Special equations
% =====================

% (43) Delay
odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);


***** Arguments of y differ -- solving delay equations is not implemented.


% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);


   a*x
{{e   }}



% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y(x),x,4) = sin x, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=0, df(y(x),x,2)=0, df(y(x),x,3)=0});


                1   3
{y(x)=sin(x) + ---*x  - x}
                6


% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y(x),x,2) + df(y(x),x) + 2x*y(x) = 0, y(x), x,
   {x=0, y(x)=1, df(y(x),x)=0});


{y(x)=besselj(0,sqrt(2)*x)}


% (47) Second-degree separable
soln :=
   odesolve(x*df(y(x),x)^2 - y(x)^2 + 1 = 0, y(x)=1, x=0, explicit);


               1   2*sqrt(x)*plus_or_minus(tag_9)
soln := {y(x)=---*e
               2

             1    - 2*sqrt(x)*plus_or_minus(tag_9)
          + ---*e                                 }
             2

% Alternatively ...
soln where e^~x => cosh x + sinh x;


{y(x)=cosh(2*sqrt(x)*plus_or_minus(tag_9))}

% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);


{y(x)=cosh(2*sqrt(x)*plus_or_minus(tag_9))}

expand_plus_or_minus ws;


{y(x)=cosh(2*sqrt(x))}


% (48) Autonomous
odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=2});


     3
{y(x)  + 3*y(x) - 6*x=0}

%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
      {x=0, y(x)=0, df(y(x),x)=2}, explicit);
end;


               2            1/3            2             - 1/3
{y(x)=(sqrt(9*x  + 1) + 3*x)    - (sqrt(9*x  + 1) + 3*x)      }



% 3  Systems of equations
% =======================

% (49) Integrable combinations
operator x, z;


odesolve({df(x(t),t) = -3y(t)*z(t), df(y(t),t) = 3x(t)*z(t),
   df(z(t),t) = -x(t)*y(t)}, {x(t),y(t),z(t)}, t);


odesolve-system({df(x(t),t) + 3*y(t)*z(t),

                 df(y(t),t) - 3*x(t)*z(t),

                 df(z(t),t) + x(t)*y(t)},{x(t),y(t),z(t)},t)


% (50) Matrix Riccati
operator a, b;


odesolve({df(x(t),t) = a(t)*(y(t)^2-x(t)^2) + 2b(t)*x(t)*y(t) + 2c*x(t),
   df(y(t),t) = b(t)*(y(t)^2-x(t)^2) - 2a(t)*x(t)*y(t) + 2c*y(t)},
   {x(t),y(t)}, t);


                          2            2
odesolve-system({a(t)*x(t)  - a(t)*y(t)  - 2*b(t)*x(t)*y(t) + df(x(t),t)

                  - 2*c*x(t),

                                             2            2
                 2*a(t)*x(t)*y(t) + b(t)*x(t)  - b(t)*y(t)  + df(y(t),t)

                  - 2*c*y(t)},{x(t),y(t)},t)


% (51) Triangular
odesolve({df(x(t),t) = x(t)*(1 + cos(t)/(2+sin(t))),
   df(y(t),t) = x(t) - y(t)}, {x(t),y(t)}, t);


odesolve-system({( - cos(t)*x(t) + df(x(t),t)*sin(t) + 2*df(x(t),t)

                     - sin(t)*x(t) - 2*x(t))/(sin(t) + 2),

                 df(y(t),t) - x(t) + y(t)},{x(t),y(t)},t)


% (52) Vector
odesolve({df(x(t),t) = 9x(t) + 2y(t), df(y(t),t) = x(t) + 8y(t)},
   {x(t),y(t)}, t);


odesolve-system({df(x(t),t) - 9*x(t) - 2*y(t),

                 df(y(t),t) - x(t) - 8*y(t)},{x(t),y(t)},t)


% (53) Higher order
odesolve({df(x(t),t) - x(t) + 2y(t) = 0,
   df(x(t),t,2) - 2df(y(t),t) = 2t - cos(2t)}, {x(t),y(t)}, t);


odesolve-system({df(x(t),t) - x(t) + 2*y(t),

                 cos(2*t) + df(x(t),t,2) - 2*df(y(t),t) - 2*t},{x(t),y(t)},t)


% (54) Inhomogeneous system
equ := {df(x(t),t) = -1/(t*(t^2+1))*x(t) + 1/(t^2*(t^2+1))*y(t) + 1/t,
        df(y(t),t) = -t^2/(t^2+1)*x(t) + (2t^2+1)/(t*(t^2+1))*y(t) + 1};


                             -1         -2        -1
                     - x(t)*t   + y(t)*t   + t + t
equ := {df(x(t),t)=----------------------------------,
                                  2
                                 t  + 1

                             2                    -1    2
                     - x(t)*t  + 2*y(t)*t + y(t)*t   + t  + 1
        df(y(t),t)=-------------------------------------------}
                                      2
                                     t  + 1

odesolve(equ, {x(t),y(t)}, t);


                              2                     -1         -1         -2
                  df(x(t),t)*t  + df(x(t),t) - t + t  *x(t) - t   - y(t)*t
odesolve-system({------------------------------------------------------------,
                                             2
                                            t  + 1

                              2                 2         2
                 (df(y(t),t)*t  + df(y(t),t) + t *x(t) - t  - 2*t*y(t)

                             -1        2
                     - y(t)*t   - 1)/(t  + 1)},{x(t),y(t)},t)


end;



Time for test: 23953 ms, plus GC time: 1807 ms

mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimmerop.rlg0000644000175000017500000005445011526203062024704 0ustar  giovannigiovanniREDUCE Development Version, Wed Sep 13 20:40:41 2000 ...







ODESolve 1.065

% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses Maple-style functional notation wherever possible.

% on trode;
on div, intstr;

  off allfac;

            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

operator y;



% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y(x),x) + 2*x^4*y(x) = x^3/3 + C, y(x), x);


         - 2*x                1     -2    1       1
       e      *arbconst(1) + ---*c*x   + ---*x - ---
                              2           6       4
{y(x)=-----------------------------------------------}
                        2
                       x  - 2*x + 1


% (2) Linear Bernoulli 2
odesolve(-1/2*df(y(x),x) + y(x) = sin x, y(x), x);


       2*x                2            4
{y(x)=e   *arbconst(2) + ---*cos(x) + ---*sin(x)}
                          5            5


% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y(x),x,2)*(a*x+b)^2 + 4df(y(x),x)*(a*x+b)*a + 2y(x)*a^2 = 0,
   y(x), x);


                    2                                    2
       arbconst(4)*a *x + arbconst(4)*a*b + arbconst(3)*a
{y(x)=-----------------------------------------------------}
                       2  2              2
                      a *x  + 2*a*b*x + b


% (4) Adjoint
odesolve((x^2-x)*df(y(x),x,2) + (2x^2+4x-3)*df(y(x),x) + 8x*y(x) = 1,
   y(x), x);


               2                                  2
{df(y(x),x,2)*x  - df(y(x),x,2)*x + 2*df(y(x),x)*x  + 4*df(y(x),x)*x

  - 3*df(y(x),x) + 8*y(x)*x - 1=0}


% (5) Polynomial solutions
% (FJW: Currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y(x),x,2) + (1-2x^2)*df(y(x),x) + (4x-2)*y(x) = 0,
%    y(x), x);

% (6) Dependent variable missing
odesolve(df(y(x),x,2) + 2x*df(y(x),x) = 2x, y(x), x);


                     1
{y(x)=arbconst(6) + ---*sqrt(pi)*arbconst(5)*erf(x) + x}
                     2


% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y(x),x,2) + (2x^2-3x+1)*df(y(x),x) + (x-1)*y(x) = 0,
      y(x), x, noint);
end;


                   -1
        - 1/2   - x           - 1/2
{y(x)=x      *e      *(x - 2)

                                           1/x
                                  sqrt(x)*e   *sqrt(x - 2)
 *(arbconst(8) + arbconst(7)*int(--------------------------,x))}
                                          3      2
                                         x  - 2*x

% WARNING: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON THE NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y(x),x,2) - 2x*df(y(x),x) + 2y(x) = 3, y(x), x);


{arbconst(10) + sqrt(pi)*arbconst(9)

                               erf(i*x)
 *int(-----------------------------------------------------------,x)*i
                                             2
                                            x
       sqrt(pi)*arbconst(9)*erf(i*x)*i*x + e  *arbconst(9) - 2*x

                                       1
  - 2*int(-----------------------------------------------------------,x)
                                                 2
                                                x
           sqrt(pi)*arbconst(9)*erf(i*x)*i*x + e  *arbconst(9) - 2*x

                3
  - log(y(x) - ---)=0}
                2


% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y(x),x,2) + 2x*df(y(x),x) + 3y(x) = 0, y(x), x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y(x),x,2) - 2/x^2*y(x) = 7x^4 + 3*x^3, y(x), x);


                    2                 -1    1   6    1   5
{y(x)=arbconst(13)*x  + arbconst(12)*x   + ---*x  + ---*x }
                                            4        6


% (12) Variation of parameters
odesolve(df(y(x),x,2) + y(x) = csc(x), y(x), x);


{y(x)=arbconst(15)*sin(x) + arbconst(14)*cos(x) - cos(x)*x + log(sin(x))*sin(x)}


% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y(x),x,7) - 14df(y(x),x,6) + 80df(y(x),x,5) - 242df(y(x),x,4)
   + 419df(y(x),x,3) - 416df(y(x),x,2) + 220df(y(x),x) - 48y(x) = 0, y(x), x);
remfac exp(x) >>;


       4*x                 3*x
{y(x)=e   *arbconst(17) + e   *arbconst(16)

     2*x
  + e   *(arbconst(19) + arbconst(18)*x)

     x                                                2
  + e *(arbconst(22) + arbconst(21)*x + arbconst(20)*x )}


% (14) Euler
odesolve(df(y(x),x,4) - 4/x^2*df(y(x),x,2) + 8/x^3*df(y(x),x) - 8/x^4*y(x) = 0,
   y(x), x);


                    4                 2                                  -1
{y(x)=arbconst(26)*x  + arbconst(25)*x  + arbconst(24)*x + arbconst(23)*x  }


% (15) Exact n-th order
odesolve((1+x+x^2)*df(y(x),x,3) + (3+6x)*df(y(x),x,2) + 6df(y(x),x) = 6x,
   y(x), x);


                                        1                2    1   4
       arbconst(29) + arbconst(28)*x + ---*arbconst(27)*x  + ---*x
                                        2                     4
{y(x)=--------------------------------------------------------------}
                                 2
                                x  + x + 1



% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y(x),x) = y(x)/(y(x)*log y(x) + x), y(x), x);


                        1           2
{x=arbconst(30)*y(x) + ---*log(y(x)) *y(x)}
                        2


% (17) Integrating factors 2
odesolve(2y(x)*df(y(x),x)^2 - 2x*df(y(x),x) - y(x) = 0, y(x), x);


                       4                 2      - 1/3             - 2/3  1/3
{{y(x)=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

  *arbconst(31)*arbparam(1),

                    4                 2      - 1/3             - 2/3  1/3
  x=2*(4*arbparam(1)  - 12*arbparam(1)  + 9)      *arbparam(1)      *2

                           2                 4                 2      - 1/3
  *arbconst(31)*arbparam(1)  - (4*arbparam(1)  - 12*arbparam(1)  + 9)

               - 2/3  1/3
  *arbparam(1)      *2   *arbconst(31),

  arbparam(1)}}

% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y(x),x) + y(x) = y(x)^3*sin x, y(x), x, explicit);


{y(x)

      2*x                                     - 1/2
 =(5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5)*plus_or_minus(tag_1)

 }

expand_plus_or_minus ws;


          2*x                                     - 1/2
{y(x)=(5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5),

             2*x                                     - 1/2
 y(x)= - (5*e   *arbconst(32) + 2*cos(x) + 4*sin(x))      *sqrt(5)}


% (19) Bernoulli 2
operator P, Q;


begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^n, y(x), x);
   off allfac;  return soln
end;


      - n          int(p(x),x)*n - int(p(x),x)
{y(x)    *y(x)= - e

                 int(p(x),x)
                e           *q(x)
 *((n - 1)*int(-------------------,x) - arbconst(33))}
                  int(p(x),x)*n
                 e

odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^(2/3), y(x), x);


     1/3   - 1/3*int(p(x),x)
{y(x)   =e                  *arbconst(34)

     1    - 1/3*int(p(x),x)      int(p(x),x)/3
  + ---*e                  *int(e             *q(x),x)}
     3


% (20) Clairaut 1
odesolve((x^2-1)*df(y(x),x)^2 - 2x*y(x)*df(y(x),x) + y(x)^2 - 1 = 0,
   y(x), x, explicit);


                                        2
{y(x)=arbconst(35)*x + sqrt(arbconst(35)  + 1),

                                        2
 y(x)=arbconst(35)*x - sqrt(arbconst(35)  + 1),

               2
 y(x)=sqrt( - x  + 1),

                  2
 y(x)= - sqrt( - x  + 1)}


% (21) Clairaut 2
operator f, g;


odesolve(f(x*df(y(x),x)-y(x)) = g(df(y(x),x)), y(x), x);


{f(arbconst(36)*x - y(x)) - g(arbconst(36))=0}


% (22) Equations of the form  y' = f(x,y)
odesolve(df(y(x),x) = (3x^2-y(x)^2-7)/(exp(y(x))+2x*y(x)+1), y(x), x);


                 y(x)       2             3
{arbconst(37) + e     + y(x) *x + y(x) - x  + 7*x=0}


% (23) Homogeneous
odesolve(df(y(x),x) = (2x^3*y(x)-y(x)^4)/(x^4-2x*y(x)^3), y(x), x);


                           3    3
{arbconst(38)*y(x)*x + y(x)  + x =0}


% (24) Factoring the equation
odesolve(df(y(x),x)*(df(y(x),x)+y(x)) = x*(x+y(x)), y(x), x);


        - x
{y(x)=e    *arbconst(39) - x + 1,

                      1   2
 y(x)=arbconst(40) + ---*x }
                      2


% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y(x),x) = x/(x^2*y(x)^2+y(x)^5), y(x), x);


             3
  2  2/3*y(x)                     3    3
{x =e         *arbconst(41) - y(x)  - ---}
                                       2


% (26) Lagrange 1
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x);


                                 -1    1             3
{{y(x)=2*arbconst(42)*arbparam(2)   + ---*arbparam(2) *a,
                                       2

                            -2    3             2
  x=arbconst(42)*arbparam(2)   + ---*arbparam(2) *a,
                                  4

  arbparam(2)}}

odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x, implicit);


                3  2                   2    2                        2
{64*arbconst(43) *a  + 128*arbconst(43) *a*x  - 144*arbconst(43)*y(x) *a*x

                     4          4            2  3
  + 64*arbconst(43)*x  + 27*y(x) *a - 16*y(x) *x =0}

% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x);


                                 -1    1             2
{{y(x)=2*arbconst(44)*arbparam(3)   + ---*arbparam(3) ,
                                       3

                            -2    2
  x=arbconst(44)*arbparam(3)   + ---*arbparam(3),
                                  3

  arbparam(3)}}

odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x, implicit);


                  2                                             3         3
{ - 9*arbconst(45)  + 18*arbconst(45)*y(x)*x - 12*arbconst(45)*x  - 4*y(x)

          2  2
  + 3*y(x) *x =0}


% (28) Riccati 1
odesolve(df(y(x),x) = exp(x)*y(x)^2 - y(x) + exp(-x), y(x), x);


         - x                         - x
       e    *arbconst(46)*sin(x) - e    *cos(x)
{y(x)=------------------------------------------}
             arbconst(46)*cos(x) + sin(x)


% (29) Riccati 2
<< factor x;  write
odesolve(df(y(x),x) = y(x)^2 - x*y(x) + 1, y(x), x);
remfac x >>;


                                 2
                            1/2*x
                         2*e      *arbconst(47)
{y(x)=x + ----------------------------------------------------}
                                                i*x
           sqrt(pi)*sqrt(2)*arbconst(47)*erf(---------)*i - 2
                                              sqrt(2)


% (30) Separable
odesolve(df(y(x),x) = (9x^8+1)/(y(x)^2+1), y(x), x);


                      3               9
{3*arbconst(48) + y(x)  + 3*y(x) - 3*x  - 3*x=0}


% (31) Solvable for x
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x);


                                    -1
{{y(x)= - 2*arbconst(49)*arbparam(4)  ,

                               -2
  x= - arbconst(49)*arbparam(4)   + arbconst(49),

  arbparam(4)}}

odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x, implicit);


                  2                          2
{ - 4*arbconst(50)  + 4*arbconst(50)*x + y(x) =0}


% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y(x)*df(y(x),x) - x*df(y(x),x)^2, y(x), x)
end;


                          2
         - 1/2*arbparam(5)                           2
{{y(x)=e                   *arbconst(51)*(arbparam(5)  + 1),

                       2
      - 1/2*arbparam(5)
  x=e                   *arbconst(51)*arbparam(5),

  arbparam(5)}}


% (33) Autonomous 1
odesolve(df(y(x),x,2)-df(y(x),x) = 2y(x)*df(y(x),x), y(x), x, explicit);


{y(x)=

     1                    1                               1
  - ---*arbconst(52)*tan(---*arbconst(53)*arbconst(52) - ---*arbconst(52)*x)
     2                    2                               2

     1
  - ---,
     2

 y(x)=arbconst(54)}


% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y(x),x,2)/y(x) - df(y(x),x)^2/y(x)^2 - 1 + 1/y(x)^3 = 0,
   y(x), x, noint);


{arbconst(57)*plus_or_minus(tag_4) + sqrt(3)

                                     3                   3      - 1/2
 *int(sqrt(y(x))*(3*arbconst(56)*y(x)  + 6*log(y(x))*y(x)  + 2)      ,y(x))

  - plus_or_minus(tag_4)*x=0}


% (35) Differentiation method
odesolve(2y(x)*df(y(x),x,2) - df(y(x),x)^2 =
   1/3(df(y(x),x) - x*df(y(x),x,2))^2, y(x), x, explicit);


                  2  2                                                         2
{y(x)=arbconst(59) *x  + 2*sqrt(3)*arbconst(59)*arbconst(58)*x + 4*arbconst(58)

 ,

                  2  2                                                         2
 y(x)=arbconst(60) *x  - 2*sqrt(3)*arbconst(60)*arbconst(58)*x + 4*arbconst(58)

 ,

 y(x)=arbconst(61)}


% (36) Equidimensional in x
odesolve(x*df(y(x),x,2) = 2y(x)*df(y(x),x), y(x), x, explicit);


          1
{y(x)= - ---*arbconst(62)
          2

       1                               1                          1
 *tan(---*arbconst(63)*arbconst(62) - ---*arbconst(62)*log(x)) - ---,
       2                               2                          2

 y(x)=arbconst(64)}


% (37) Equidimensional in y
odesolve((1-x)*(y(x)*df(y(x),x,2)-df(y(x),x)^2) + x^2*y(x)^2 = 0, y(x), x);


                                             3        2
        arbconst(66) + arbconst(65)*x + 1/6*x  + 1/2*x  - x        x
       e                                                   *(x - 1)
{y(x)=---------------------------------------------------------------}
                                   x - 1


% (38) Exact second order
odesolve(x*y(x)*df(y(x),x,2) + x*df(y(x),x)^2 + y(x)*df(y(x),x) = 0,
   y(x), x, explicit);


{y(x)=sqrt( - arbconst(68) + log(x))*sqrt(arbconst(67))*sqrt(2),

 y(x)= - sqrt( - arbconst(68) + log(x))*sqrt(arbconst(67))*sqrt(2),

 y(x)=arbconst(69)}


% (39) Factoring differential operator
odesolve(df(y(x),x,2)^2 - 2df(y(x),x)*df(y(x),x,2) + 2y(x)*df(y(x),x) -
   y(x)^2 = 0, y(x), x);


       x                 x
{y(x)=e *arbconst(71) + e *arbconst(70)*x,

       x                  - x
 y(x)=e *arbconst(73) + e    *arbconst(72)}


% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y(x),x,2) + 3x*df(y(x),x) = 1/(y(x)^3*x^4), y(x), x);


{2*arbconst(75)*plus_or_minus(tag_7) + log(

                        2      - 1/2                               2      - 1/2
     - 2*(4*arbconst(74)  + 1)      *arbconst(74) + (4*arbconst(74)  + 1)

                                2  2       4  4
    *sqrt( - 4*arbconst(74)*y(x) *x  + y(x) *x  - 1)

                      2      - 1/2     2  2
     + (4*arbconst(74)  + 1)      *y(x) *x ) - 2*log(x)*plus_or_minus(tag_7)=0}


% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y(x),x,2) + 3x*df(y(x),x) + 2*y(x) = 1/(y(x)^3*x^4);


                     2                               -3  -4
ode := df(y(x),x,2)*x  + 3*df(y(x),x)*x + 2*y(x)=y(x)  *x

% Choose full (explicit and expanded) solution:
odesolve(ode, y(x), x, full);


          1
{y(x)= - ---*sqrt(15*arbconst(76)
          2

                            2                                         - 1/2  -1
     - sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))*2      *x  ,

          1
 y(x)= - ---*sqrt(15*arbconst(76)
          2

                            2                                         - 1/2  -1
     + sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))*2      *x  ,

       1
 y(x)=---*sqrt(15*arbconst(76)
       2

                                       2
                - sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  ,

       1
 y(x)=---*sqrt(15*arbconst(76)
       2

                                       2
                + sqrt(225*arbconst(76)  - 64)*sin(2*arbconst(77) - 2*log(x)))

    - 1/2  -1
 *2      *x  }
           % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));


{0,0,0,0}


% (41) Autonomous, 3rd order
odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
   y(x), x);


                                      2             2
{y(x)=arbconst(81) + sqrt(arbconst(79) *arbconst(78)

                                  2                                  2  2
     - 2*arbconst(79)*arbconst(78) *x + 2*arbconst(79) + arbconst(78) *x  - 2*x)

              -1
 *arbconst(78)  *i,

 y(x)=arbconst(82) + i*x,

 y(x)=arbconst(83) - i*x,

 y(x)=arbconst(84) + arbconst(80)*x}

% odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
%    y(x), x, implicit);
% Implicit form is currently too messy!

% (42) Autonomous, 4th order
odesolve(3*df(y(x),x,2)*df(y(x),x,4) - 5df(y(x),x,3)^2 = 0, y(x), x);


{y(x)=arbconst(89)*x + arbconst(88)

                                                 -3
  - 3*sqrt(arbconst(86) - x)*sqrt(6)*arbconst(85)  ,

 y(x)=arbconst(91)*x + arbconst(90)

                                                 -3
  + 3*sqrt(arbconst(86) - x)*sqrt(6)*arbconst(85)  ,

                                       1                2
 y(x)=arbconst(93)*x + arbconst(92) + ---*arbconst(87)*x }
                                       2



% 1.3 Special equations
% =====================

% (43) Delay
odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);


***** Arguments of y differ -- solving delay equations is not implemented.


% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);


         a*x
{y(x,a)=e   *arbconst(94)}



% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y(x),x,4) = sin x, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=0, df(y(x),x,2)=0, df(y(x),x,3)=0});


                1   3
{y(x)=sin(x) + ---*x  - x}
                6


% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y(x),x,2) + df(y(x),x) + 2x*y(x) = 0, y(x), x,
   {x=0, y(x)=1, df(y(x),x)=0});


{y(x)=besselj(0,sqrt(2)*x)}


% (47) Second-degree separable
soln :=
   odesolve(x*df(y(x),x)^2 - y(x)^2 + 1 = 0, y(x)=1, x=0, explicit);


               1   2*sqrt(x)*plus_or_minus(tag_9)
soln := {y(x)=---*e
               2

             1    - 2*sqrt(x)*plus_or_minus(tag_9)
          + ---*e                                 }
             2

% Alternatively ...
soln where e^~x => cosh x + sinh x;


{y(x)=cosh(2*sqrt(x)*plus_or_minus(tag_9))}

% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);


{y(x)=cosh(2*sqrt(x)*plus_or_minus(tag_9))}

expand_plus_or_minus ws;


{y(x)=cosh(2*sqrt(x))}


% (48) Autonomous
odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=2});


     3
{y(x)  + 3*y(x) - 6*x=0}

%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
      {x=0, y(x)=0, df(y(x),x)=2}, explicit);
end;


               2            1/3            2             - 1/3
{y(x)=(sqrt(9*x  + 1) + 3*x)    - (sqrt(9*x  + 1) + 3*x)      }



% 3  Systems of equations
% =======================

% (49) Integrable combinations
operator x, z;


odesolve({df(x(t),t) = -3y(t)*z(t), df(y(t),t) = 3x(t)*z(t),
   df(z(t),t) = -x(t)*y(t)}, {x(t),y(t),z(t)}, t);


odesolve-system({df(x(t),t) + 3*y(t)*z(t),

                 df(y(t),t) - 3*x(t)*z(t),

                 df(z(t),t) + x(t)*y(t)},{x(t),y(t),z(t)},t)


% (50) Matrix Riccati
operator a, b;


odesolve({df(x(t),t) = a(t)*(y(t)^2-x(t)^2) + 2b(t)*x(t)*y(t) + 2c*x(t),
   df(y(t),t) = b(t)*(y(t)^2-x(t)^2) - 2a(t)*x(t)*y(t) + 2c*y(t)},
   {x(t),y(t)}, t);


                          2            2
odesolve-system({a(t)*x(t)  - a(t)*y(t)  - 2*b(t)*x(t)*y(t) + df(x(t),t)

                  - 2*c*x(t),

                                             2            2
                 2*a(t)*x(t)*y(t) + b(t)*x(t)  - b(t)*y(t)  + df(y(t),t)

                  - 2*c*y(t)},{x(t),y(t)},t)


% (51) Triangular
odesolve({df(x(t),t) = x(t)*(1 + cos(t)/(2+sin(t))),
   df(y(t),t) = x(t) - y(t)}, {x(t),y(t)}, t);


odesolve-system({( - cos(t)*x(t) + df(x(t),t)*sin(t) + 2*df(x(t),t)

                     - sin(t)*x(t) - 2*x(t))/(sin(t) + 2),

                 df(y(t),t) - x(t) + y(t)},{x(t),y(t)},t)


% (52) Vector
odesolve({df(x(t),t) = 9x(t) + 2y(t), df(y(t),t) = x(t) + 8y(t)},
   {x(t),y(t)}, t);


odesolve-system({df(x(t),t) - 9*x(t) - 2*y(t),

                 df(y(t),t) - x(t) - 8*y(t)},{x(t),y(t)},t)


% (53) Higher order
odesolve({df(x(t),t) - x(t) + 2y(t) = 0,
   df(x(t),t,2) - 2df(y(t),t) = 2t - cos(2t)}, {x(t),y(t)}, t);


odesolve-system({df(x(t),t) - x(t) + 2*y(t),

                 cos(2*t) + df(x(t),t,2) - 2*df(y(t),t) - 2*t},{x(t),y(t)},t)


% (54) Inhomogeneous system
equ := {df(x(t),t) = -1/(t*(t^2+1))*x(t) + 1/(t^2*(t^2+1))*y(t) + 1/t,
        df(y(t),t) = -t^2/(t^2+1)*x(t) + (2t^2+1)/(t*(t^2+1))*y(t) + 1};


                             -1         -2        -1
                     - x(t)*t   + y(t)*t   + t + t
equ := {df(x(t),t)=----------------------------------,
                                  2
                                 t  + 1

                             2                    -1    2
                     - x(t)*t  + 2*y(t)*t + y(t)*t   + t  + 1
        df(y(t),t)=-------------------------------------------}
                                      2
                                     t  + 1

odesolve(equ, {x(t),y(t)}, t);


                              2                     -1         -1         -2
                  df(x(t),t)*t  + df(x(t),t) - t + t  *x(t) - t   - y(t)*t
odesolve-system({------------------------------------------------------------,
                                             2
                                            t  + 1

                              2                 2         2
                 (df(y(t),t)*t  + df(y(t),t) + t *x(t) - t  - 2*t*y(t)

                             -1        2
                     - y(t)*t   - 1)/(t  + 1)},{x(t),y(t)},t)


end;



Time for test: 20457 ms, plus GC time: 1387 ms

mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimmerop.tst0000644000175000017500000002052411526203062024725 0ustar  giovannigiovanni% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses Maple-style functional notation wherever possible.

% on trode;
on div, intstr;  off allfac;            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

operator y;

% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y(x),x) + 2*x^4*y(x) = x^3/3 + C, y(x), x);

% (2) Linear Bernoulli 2
odesolve(-1/2*df(y(x),x) + y(x) = sin x, y(x), x);

% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y(x),x,2)*(a*x+b)^2 + 4df(y(x),x)*(a*x+b)*a + 2y(x)*a^2 = 0,
   y(x), x);

% (4) Adjoint
odesolve((x^2-x)*df(y(x),x,2) + (2x^2+4x-3)*df(y(x),x) + 8x*y(x) = 1,
   y(x), x);

% (5) Polynomial solutions
% (FJW: Currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y(x),x,2) + (1-2x^2)*df(y(x),x) + (4x-2)*y(x) = 0,
%    y(x), x);

% (6) Dependent variable missing
odesolve(df(y(x),x,2) + 2x*df(y(x),x) = 2x, y(x), x);

% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y(x),x,2) + (2x^2-3x+1)*df(y(x),x) + (x-1)*y(x) = 0,
      y(x), x, noint);
end;
% WARNING: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON THE NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y(x),x,2) - 2x*df(y(x),x) + 2y(x) = 3, y(x), x);

% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y(x),x,2) + 2x*df(y(x),x) + 3y(x) = 0, y(x), x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y(x),x,2) - 2/x^2*y(x) = 7x^4 + 3*x^3, y(x), x);

% (12) Variation of parameters
odesolve(df(y(x),x,2) + y(x) = csc(x), y(x), x);

% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y(x),x,7) - 14df(y(x),x,6) + 80df(y(x),x,5) - 242df(y(x),x,4)
   + 419df(y(x),x,3) - 416df(y(x),x,2) + 220df(y(x),x) - 48y(x) = 0, y(x), x);
remfac exp(x) >>;

% (14) Euler
odesolve(df(y(x),x,4) - 4/x^2*df(y(x),x,2) + 8/x^3*df(y(x),x) - 8/x^4*y(x) = 0,
   y(x), x);

% (15) Exact n-th order
odesolve((1+x+x^2)*df(y(x),x,3) + (3+6x)*df(y(x),x,2) + 6df(y(x),x) = 6x,
   y(x), x);


% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y(x),x) = y(x)/(y(x)*log y(x) + x), y(x), x);

% (17) Integrating factors 2
odesolve(2y(x)*df(y(x),x)^2 - 2x*df(y(x),x) - y(x) = 0, y(x), x);
% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y(x),x) + y(x) = y(x)^3*sin x, y(x), x, explicit);
expand_plus_or_minus ws;

% (19) Bernoulli 2
operator P, Q;
begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^n, y(x), x);
   off allfac;  return soln
end;
odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^(2/3), y(x), x);

% (20) Clairaut 1
odesolve((x^2-1)*df(y(x),x)^2 - 2x*y(x)*df(y(x),x) + y(x)^2 - 1 = 0,
   y(x), x, explicit);

% (21) Clairaut 2
operator f, g;
odesolve(f(x*df(y(x),x)-y(x)) = g(df(y(x),x)), y(x), x);

% (22) Equations of the form  y' = f(x,y)
odesolve(df(y(x),x) = (3x^2-y(x)^2-7)/(exp(y(x))+2x*y(x)+1), y(x), x);

% (23) Homogeneous
odesolve(df(y(x),x) = (2x^3*y(x)-y(x)^4)/(x^4-2x*y(x)^3), y(x), x);

% (24) Factoring the equation
odesolve(df(y(x),x)*(df(y(x),x)+y(x)) = x*(x+y(x)), y(x), x);

% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y(x),x) = x/(x^2*y(x)^2+y(x)^5), y(x), x);

% (26) Lagrange 1
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x, implicit);
% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x, implicit);

% (28) Riccati 1
odesolve(df(y(x),x) = exp(x)*y(x)^2 - y(x) + exp(-x), y(x), x);

% (29) Riccati 2
<< factor x;  write
odesolve(df(y(x),x) = y(x)^2 - x*y(x) + 1, y(x), x);
remfac x >>;

% (30) Separable
odesolve(df(y(x),x) = (9x^8+1)/(y(x)^2+1), y(x), x);

% (31) Solvable for x
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x, implicit);

% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y(x)*df(y(x),x) - x*df(y(x),x)^2, y(x), x)
end;

% (33) Autonomous 1
odesolve(df(y(x),x,2)-df(y(x),x) = 2y(x)*df(y(x),x), y(x), x, explicit);

% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y(x),x,2)/y(x) - df(y(x),x)^2/y(x)^2 - 1 + 1/y(x)^3 = 0,
   y(x), x, noint);

% (35) Differentiation method
odesolve(2y(x)*df(y(x),x,2) - df(y(x),x)^2 =
   1/3(df(y(x),x) - x*df(y(x),x,2))^2, y(x), x, explicit);

% (36) Equidimensional in x
odesolve(x*df(y(x),x,2) = 2y(x)*df(y(x),x), y(x), x, explicit);

% (37) Equidimensional in y
odesolve((1-x)*(y(x)*df(y(x),x,2)-df(y(x),x)^2) + x^2*y(x)^2 = 0, y(x), x);

% (38) Exact second order
odesolve(x*y(x)*df(y(x),x,2) + x*df(y(x),x)^2 + y(x)*df(y(x),x) = 0,
   y(x), x, explicit);

% (39) Factoring differential operator
odesolve(df(y(x),x,2)^2 - 2df(y(x),x)*df(y(x),x,2) + 2y(x)*df(y(x),x) -
   y(x)^2 = 0, y(x), x);

% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y(x),x,2) + 3x*df(y(x),x) = 1/(y(x)^3*x^4), y(x), x);

% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y(x),x,2) + 3x*df(y(x),x) + 2*y(x) = 1/(y(x)^3*x^4);
% Choose full (explicit and expanded) solution:
odesolve(ode, y(x), x, full);           % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));

% (41) Autonomous, 3rd order
odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
   y(x), x);
% odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
%    y(x), x, implicit);
% Implicit form is currently too messy!

% (42) Autonomous, 4th order
odesolve(3*df(y(x),x,2)*df(y(x),x,4) - 5df(y(x),x,3)^2 = 0, y(x), x);


% 1.3 Special equations
% =====================

% (43) Delay
odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);

% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);


% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y(x),x,4) = sin x, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=0, df(y(x),x,2)=0, df(y(x),x,3)=0});

% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y(x),x,2) + df(y(x),x) + 2x*y(x) = 0, y(x), x,
   {x=0, y(x)=1, df(y(x),x)=0});

% (47) Second-degree separable
soln :=
   odesolve(x*df(y(x),x)^2 - y(x)^2 + 1 = 0, y(x)=1, x=0, explicit);
% Alternatively ...
soln where e^~x => cosh x + sinh x;
% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);
expand_plus_or_minus ws;

% (48) Autonomous
odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=2});
%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
      {x=0, y(x)=0, df(y(x),x)=2}, explicit);
end;


% 3  Systems of equations
% =======================

% (49) Integrable combinations
operator x, z;
odesolve({df(x(t),t) = -3y(t)*z(t), df(y(t),t) = 3x(t)*z(t),
   df(z(t),t) = -x(t)*y(t)}, {x(t),y(t),z(t)}, t);

% (50) Matrix Riccati
operator a, b;
odesolve({df(x(t),t) = a(t)*(y(t)^2-x(t)^2) + 2b(t)*x(t)*y(t) + 2c*x(t),
   df(y(t),t) = b(t)*(y(t)^2-x(t)^2) - 2a(t)*x(t)*y(t) + 2c*y(t)},
   {x(t),y(t)}, t);

% (51) Triangular
odesolve({df(x(t),t) = x(t)*(1 + cos(t)/(2+sin(t))),
   df(y(t),t) = x(t) - y(t)}, {x(t),y(t)}, t);

% (52) Vector
odesolve({df(x(t),t) = 9x(t) + 2y(t), df(y(t),t) = x(t) + 8y(t)},
   {x(t),y(t)}, t);

% (53) Higher order
odesolve({df(x(t),t) - x(t) + 2y(t) = 0,
   df(x(t),t,2) - 2df(y(t),t) = 2t - cos(2t)}, {x(t),y(t)}, t);

% (54) Inhomogeneous system
equ := {df(x(t),t) = -1/(t*(t^2+1))*x(t) + 1/(t^2*(t^2+1))*y(t) + 1/t,
        df(y(t),t) = -t^2/(t^2+1)*x(t) + (2t^2+1)/(t*(t^2+1))*y(t) + 1};
odesolve(equ, {x(t),y(t)}, t);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.tst0000644000175000017500000000470311526203062024704 0ustar  giovannigiovanni% Tests and demonstrations for the ODESolve 1+ package --
% an updated version of the original odesolve test file.

% Original Author: M. A. H. MacCallum
% Maintainer: F.J.Wright@Maths.QMW.ac.uk

ODESolve_version;
on trode, combinelogs;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% First-order differential equations
% (using automatic variable and dependence declaration).

% First-order quadrature case:
odesolve(df(y,x) - x^2 - e^x);

% First-order linear equation, with initial condition y = 1 at x = 0:
odesolve(df(y,x) + y * tan x - sec x, y, x, {x=0, y=1});
odesolve(cos x * df(y,x) + y * sin x - 1, y, x, {x=0, y=1});

% A simple separable case:
odesolve(df(y,x) - y^2, y, x, explicit);

% A separable case, in different variables, with the initial condition
% z = 2 at w = 1/2:
odesolve((1-z^2)*w*df(z,w)+(1+w^2)*z, z, w, {w=1/2, z=2});

% Now a homogeneous one:
odesolve(df(y,x) - (x-y)/(x+y), y, x);

% Reducible to homogeneous:
% (Note this is the previous example with origin shifted.)
odesolve(df(y,x) - (x-y-3)/(x+y-1), y, x);

% and the special case of reducible to homogeneous:
odesolve(df(y,x) - (2x+3y+1)/(4x+6y+1), y, x);

% A Bernoulli equation:
odesolve(x*(1-x^2)*df(y,x) + (2x^2 -1)*y - x^3*y^3, y, x);

% and finally, in this set, an exact case:
odesolve((2x^3 - 6x*y + 6x*y^2) + (-3x^2 + 6x^2*y - y^3)*df(y,x), y, x);

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Now for higher-order linear equations with constant coefficients

% First, examples without driving terms
% A simple one to start:
odesolve(6df(y,x,2) + df(y,x) - 2y, y, x);

% An example with repeated and complex roots:
odesolve(ode := df(y,x,4) + 2df(y,x,2) + y, y, x);

% A simple right-hand-side using the above example:
odesolve(ode = exp(x), y, x);

ode := df(y,x,2) + 4df(y,x) + 4y - x*exp(x);
% At x=1 let y=0 and df(y,x)=1:
odesolve(ode, y, x, {x=1, y=0, df(y,x)=1});

% For simultaneous equations you can use the machine, e.g. as follows:

depend z,x;
ode1 := df(y,x,2) + 5y - 4z + 36cos(7x);
ode2 := y + df(z,x,2) - 99cos(7x);
ode := df(ode1,x,2) + 4ode2;
y := rhs first odesolve(ode, y, x);
z := rhs first solve(ode1,z);
clear ode1, ode2, ode, y, z;
nodepend z,x;

% A "homogeneous" n-th order (Euler) equation:
odesolve(x*df(y,x,2) + df(y, x) + y/x + (log x)^3, y, x);

% The solution here remains symbolic (because neither REDUCE nor Maple
% can evaluate the resulting integral):
odesolve(6df(y,x,2) + df(y,x) - 2y + tan x, y, x);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odenon1.red0000644000175000017500000010321611526203062024366 0ustar  giovannigiovannimodule odenon1$  % Special form nonlinear ODEs of order 1

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@maths.qmw.ac.uk, Time-stamp: <11 August 2001>

% Original author: Malcolm MacCallum

% Basic layout is to test first for well-known special forms, namely:

%    separable
%    quasi-separable (separable after linear transformation)
%    (algebraically) homogeneous
%    quasi-homogeneous (homogeneous after linear transformation)
%    Bernoulli
%    Riccati
%    solvable for x or y, including Clairaut and Lagrange
%    exact  (FJW: general exact ode now handled elsewhere)

% and at a later stage of development to add more general methods,
% such as Prelle Singer

% Note that all cases of first order ODEs can be considered equivalent
% to searches for integrating factors.  (In particular Lie methods do
% not help here.)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%% algebraic procedure odesolve(ode, y, x);
%%    %% Temporary definition for test purposes.
%%    begin scalar !*precise, !*odesolve!-solvable!-xy, solution;
%%       ode := num !*eqn2a ode;           % returns ode as expression
%%       if (solution := ODESolve!-NonLinear1(ode, y, x)) then
%%          return solution
%%       else
%%          write "***** ODESolve cannot solve this ODE!"
%%    end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

global '(ODESolve_Before_Non1Grad_Hook ODESolve_After_Non1Grad_Hook)$

algebraic procedure ODESolve!-NonLinear1(ode, y, x);
   %% Top-level solver for non-linear first-order ODEs.
   begin scalar odecoeffs, gradient, solution, p, ode_p;
      traceode1 "Entering top-level non-linear first-order solver ...";
      %% traceode "This is a nonlinear ODE of order 1.";
      p := gensym();
      ode_p := num sub(df(y,x) = p, ode);
      %% If ode contains exponentials then the above sub can produce a
      %% denominator when there is none in ode!
      odecoeffs := coeff(ode_p, p);
      if length odecoeffs = 2 and not smember(p, odecoeffs)
      then <<                           % first DEGREE ODE
         gradient := -first odecoeffs / second odecoeffs;
         symbolic if (solution := or(
            ODESolve!-Run!-Hook(
               'ODESolve_Before_Non1Grad_Hook, {gradient, y, x}),
            ODESolve!-Separable(gradient, y, x),
            ODESolve!-QuasiSeparable(gradient, y, x),
            ODESolve!-Homogeneous(gradient, y, x),
            ODESolve!-QuasiHomog(gradient, y, x),
            ODESolve!-Bernoulli(gradient, y, x),
            ODESolve!-Riccati(gradient, y, x),
            ODESolve!-Run!-Hook(
               'ODESolve_After_Non1Grad_Hook, {gradient, y, x})))
         then return solution
      >>;
      %% If ode degree neq 1 or above solvers fail then ...

      %% A first-order ode is "solvable-for-y" if it can be put into
      %% the form y = f(x,p) where p = y'.  This form includes
      %% Clairaut and Lagrange equations as special cases.  The
      %% Lagrange form is y = xF(y') + G(y').  If F(p) = p then this
      %% is a Clairaut equation.  It is "solvable-for-x" if it can be
      %% put into the form x = f(y,p).
      if (solution := ODESolve!-Clairaut(ode, ode_p, p, y, x)) then
         return solution;
      %% Avoid infinite loops:
      symbolic if !*odesolve!-solvable!-xy then return;
      symbolic(!*odesolve!-solvable!-xy := t);
      %% "Solvable for y" includes Lagrange as a special case:
      symbolic return
         ODESolve!-Solvable!-y(ode_p, p, y, x) or
         ODESolve!-Solvable!-x(ode_p, p, y, x)
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Support routines

algebraic procedure ODENon!-Linear1(ode, y, x);
   %% Solve the linear ODE:  dy/dx = gradient(x,y) = P(x)*y + Q(x)
   %% Split into 2 procedures by FJW.
   begin scalar gradient;
      gradient := coeff(num ode, df(y,x));   % {low, high}
      gradient := -first gradient/second gradient;
      traceode!* "This is a first-order linear ODE solved by ";
      return if smember(y, gradient) then
      begin scalar P, Q;
         traceode "the integrating factor method.";
         P := lcof(num gradient,y)/den gradient;
         Q := gradient - P*y;
         return { y = ODENon!-Linear1PQ(P, Q, x) }
      end
      else <<
         traceode "quadrature.";
         % FJW: Optionally turn off final integration:
         { y = ODESolve!-Int(gradient, x) + newarbconst() }
      >>
   end$

algebraic procedure ODENon!-Linear1PQ(P, Q, x);
   %% Solve the linear ODE:  dy/dx = P(x)*y + Q(x)
   %% Called directly by ODESolve!-Bernoulli
   begin scalar intfactor, !*combinelogs;
      %% intfactor simplifies better if logs in the integral are
      %% combined:
      symbolic(!*combinelogs := t);
      intfactor := exp(int(-P, x));
      %% Optionally turn off final integration:
      return (newarbconst() + ODESolve!-Int(intfactor*Q,x))/intfactor
   end$

%% algebraic procedure unfactorize factorlist;
%%    %% Multiply out a factor list of the form
%%    %% { {factor, multiplicity}, ... }:
%%    for each fac in factorlist product first fac^second fac$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Separable ODEs

algebraic procedure ODESolve!-Separable(gradient, y, x);
   %% The ODE has the form dy/dx = gradient = F(x,y).  If F(x,y) =
   %% f(x)g(y) then the ODE is separable, in which case return the
   %% solution; otherwise return nil.
   begin scalar f, g, !*redefmsg;
      traceode1 "Testing for a separable ODE ...";

      %% Handle implicit dependence on x (ignoring that via y):
      symbolic (<< depend1(y, x, nil);
         %% Hack sub to handle implicit dependences:
         copyd('ODESolve!-old!-subsublis, 'subsublis);
         copyd('subsublis, 'ODESolve!-subsublis);
         g := errorset!*(
            {'ODESolve!-Separable1, mkquote gradient, mkquote x}, nil);
         copyd('subsublis, 'ODESolve!-old!-subsublis);
         if errorp g then RedErr {"(in ODESolve!-Separable1)", emsg!*};
         g := car g;
         if depends(g, x) then g := nil;
      >> where depl!* = depl!*);
      if not g then return;

      %% Then F(alpha,y) = f(alpha)g(y), and F(x,y)/F(alpha,y) =
      %% f(x)/f(alpha) is free of y:
      if depends(f := gradient/g, y) then return;
      traceode "It is separable.";
      %% Any separation of F(x,y) will suffice!
      %% gradient := int(1/g, y) - int(f, x) + newarbconst();
      %% Try to optimize structure of solution to avoid a likely
      %% logarithm of a function of y:
      gradient := int(1/g, y);
      gradient := if part(gradient,0) = log then
         part(gradient,1) - newarbconst()*exp(int(f, x))
      else gradient - int(f, x) + newarbconst();
      return { num gradient = 0 }
   end$

algebraic procedure ODESolve!-Separable1(gradient, x);
   %% Find a small constant alpha such that F(alpha,y) exists and
   %% F(alpha,y) neq 0, and return F(alpha,y), where F = gradient:
   begin scalar numer, denom, alpha, d, n;
      numer := num gradient;
      denom := den gradient;
      alpha := 0;
      while (d:=sub(x=alpha,denom)) = 0 or
         (n:=sub(x=alpha,numer)) = 0 do
            alpha := alpha + 1;
      return n/d
   end$

symbolic procedure ODESolve!-subsublis(u,v);
   % NOTE: This definition assumes that with the exception of *SQ and
   % domain elements, expressions do not contain dotted pairs.

   % This is the standard `subsublis' plus support for one level of
   % indirect dependence (cf. freeof), in which case sub converts the
   % dependent variable into an independent variable with a different
   % but related name.

   % u is an alist of substitutions, v is an expression to be
   % substituted:
   begin scalar x;
      return if x := assoc(v,u) then cdr x
              % allow for case of sub(sqrt 2=s2,atan sqrt 2).
              else if eqcar(v,'sqrt)
                 and (x := assoc(list('expt,cadr v,'(quotient 1 2)),u))
               then cdr x
              else if atom v then
                 if (x := assoc(v,depl!*)) and % FJW
                    %% Run through variables on which v depends:
                    << while (x := cdr x) and not assoc(car x,u) do; x >> % FJW
                 then mkid(v, '!!) else % FJW
                 v
              else if not idp car v
               then for each j in v collect ODESolve!-subsublis(u,j)
              else if x := get(car v,'subfunc) then apply2(x,u,v)
              else if get(car v,'dname) then v
              else if car v eq '!*sq then ODESolve!-subsublis(u,prepsq cadr v)
              else for each j in v collect ODESolve!-subsublis(u,j)
   end$

algebraic procedure ODESolve!-QuasiSeparable(gradient, y, x);
   %% The ODE has the form dy/dx = gradient = F(x,y).  If F(x,y) =
   %% f(y+kx) then the ODE is quasi-separable, in which case return
   %% the solution; otherwise return nil.
   begin scalar k;
      traceode1 "Testing for a quasi-separable ODE ...";
      %% F(x,y) = f(y+kx) iff df(F,x)/df(F,y) = k = constant (using
      %% PARTIAL derivatives):
      k := (df(gradient,x)/df(gradient,y) where df(y,x) => 0);
      if depends(k, x) then return;     % sufficient since y = y(x)
      traceode "It is separable after letting ", y+k*x => y;
      %% Setting u = y+kx gives du/dx = dy/dx+k = f(u)+k:
      gradient := sub(x=0, gradient) + k;
      %% => int(1/(f(u)+k),u) = x + arbconst.
      gradient := sub(y=y+k*x, int(1/gradient, y)) - x + newarbconst();
      return { num gradient = 0 }
   end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Algebraically homogeneous ODEs

algebraic procedure ODESolve!-Homogeneous(gradient, y, x);
   %% The ODE has the form dy/dx = gradient = F(x,y).  If F(x,y) =
   %% f(y/x) then the ODE is algebraically homogeneous.
   %% Setting y = vx => v + x dv/dx = F(x,vx) = f(v)
   begin scalar v;  v := gensym();
      traceode1 "Testing for a homogeneous ODE ...";
      gradient := sub(y=v*x, gradient);
      if depends(gradient, x) then return;
      traceode
         "It is of algebraically homogeneous type ",
         "solved by a change of variables of the form `y = vx'.";
      %% Integrate to give  int(1/(f(v)-v),v) = int(1/x, x) + arbconst
      %% Hence  exp int(1/(f(v)-v),v) = arbconst * x
      gradient := exp(int(1/(gradient-v), v));
      gradient := (gradient where (sqrt ~a)*(sqrt ~b) => sqrt(a*b));
      gradient := sub(v=y/x, x/gradient) + newarbconst();
      return {num gradient = 0}
   end$

%% A quasi-homogeneous first-order nonlinear ODE has the form

%% dy/dx = F(..., ((a1*x + b1*y + c1)/(a2*x + b2*y + c2))^p, ...)

%% where F is an arbitrary composition of functions and p is an
%% arbitrary power.  F may have other arguments that do not depend on
%% x or y or that depend in the same way (e.g. F may be a sum or
%% product).  The argument of F that depends on x or y will be a
%% quotient of expanded polynomials if p is a positive integer.
%% Otherwise, it will be a power of a quotient (expt (quotient ... )),
%% in which case the `expt' can be treated as part of the composition
%% F, or a quotient of powers (quotient (expt ... ) (expt ... )) which
%% must be treated separately.

algebraic procedure ODESolve!-QuasiHomog(gradient, y, x);
   %% The ODE has the form dy/dx = gradient = F(x,y).  If F(x,y) =
   %% f((a1*x + b1*y + c1)/(a2*x + b2*y + c2)) where the function f
   %% may be arbitrary then the ODE is reducible to algebraically
   %% homogeneous.  Find the first linear-rational sub-expression, and
   %% use it to try to make the ODE homogeneous:
   begin scalar tmp, n, d, soln;
      traceode1 "Testing for a quasi-homogeneous ODE ...";
      %% First, find an "argument" that is a rational function, with
      %% numerator and denominator that both depend on x.
      if not(tmp := symbolic ODESolve!-QuasiHomog1(reval gradient, x))
      then return;
      n := num tmp;  d := den tmp;
      %% Now check that numerator and denominator have the same degree
      %% in x (and y):
      if (tmp := deg(n,x)) neq deg(d,x) then return;
      %% If that degree > 1 then extract the squarefree factor:
      if tmp = 1 then                % => deg(d,x) = 1
         %% ( if deg(n,y) neq 1 or deg(d,y) neq 1 then return )
      else <<
         %% Use partial squarefree factorization to find p'th root of
         %% numerator and denominator:
         %%   If f = poly = (a x + b y + c)^p
         %%   then f' = a p(a x + b y + c)^(p-1)
         %%   => gcd(f, f') = (a x + b y + c)^(p-1)
         %%   => f / gcd(f, f') = a x + b y + c.
         n := n / gcd(n, df(n, x));     % must be linear in x and y
         %% if deg(n,x) neq 1 or deg(n,y) neq 1 then return;
         d := d / gcd(d, df(d, x));     % must be linear in x and y
         %% if deg(d,x) neq 1 or deg(d,y) neq 1 then return
      >>;
      %% Check that numerator and denominator are really LINEAR
      %% POLYNOMIALS in x and y (where y depends on x):
      if length(tmp := coeff(n, y)) neq 2 or depends(tmp, y) then return;
      if depends(second tmp, x) or      % coeff of y^1
         length(tmp := coeff(first tmp, x)) neq 2 or % coeff of y^0
         depends(tmp, x) then return;
      if length(tmp := coeff(d, y)) neq 2 or depends(tmp, y) then return;
      if depends(second tmp, x) or      % coeff of y^1
         length(tmp := coeff(first tmp, x)) neq 2 or % coeff of y^0
         depends(tmp, x) then return;
      %% The degenerate case a1*b2=a2*b1 is now treated as quasi-separable.
      traceode "It is quasi-homogeneous if ",
         "the result of shifting the origin is homogeneous ...";
      soln := first solve({n,d},{x,y});
      n := rhs first soln;  d := rhs second soln;
      gradient := sub(x=x+n, y=y+d, gradient);
      %% ODE was quasi-homogeneous iff the new ODE is homogeneous:
      if (soln := ODESolve!-Homogeneous(gradient,y,x)) then
         return sub(x=x-n, y=y-d, soln);
      traceode "... which it is not!"
   end$

%%% The calls to `depends' below are inefficient!

symbolic procedure ODESolve!-QuasiHomog1(u, x);
   %% Assumes "algebraic" form!  Get the first argument of any
   %% composition of functions that is a quotient of polynomials or
   %% symbolic powers (expt forms) that both depend on `x'.
   if atom u then nil                   % not QH, else operator ...
   else if car u eq 'quotient and       % quotient, in which
      depends(cadr u, x) and            % numerator depends on x, and
      depends(caddr u, x) then          % denominator depends on x.
         if eqcar(cadr u, 'expt) then   % symbolic powers
            ( if eqcar(caddr u, 'expt) and (caddr cadr u eq caddr caddr u)
            then {'quotient, cadr cadr u, cadr caddr u} )
         else
            ( if eqcar(cadr u, 'plus) and eqcar(caddr u, 'plus)
            then u )                    % polynomials (?)
   else  % Process first x-dependent argument of operator u:
   begin
   a: if (u := cdr u) then
         if depends(car u, x) then return ODESolve!-QuasiHomog1(car u, x)
         else go to a
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Bernoulli ODEs

symbolic operator ODESolve!-Bernoulli$

symbolic procedure ODESolve!-Bernoulli(rhs, y, x);
   %% The ODE has the form df(y,x) = rhs.  If rhs has the Bernoulli
   %% form P(x)*y + Q(x)*y^n then extract P(x), Q(x), n and return the
   %% solution else return nil.
   ( begin scalar num_rhs, den_rhs, C1, C2, d, d1, d2, d3, P, Q, n;
      traceode1 "Testing for a Bernoulli ODE ...";
      %% Degrees will be constructed in true prefix form.
      %% Need sum of two terms, both with main var (essentially) y.
      depend1(x, y, nil) where !*msg = nil;
      << updkorder y;  rhs := simp rhs >> where kord!* = kord!*;
      num_rhs := numr rhs;  den_rhs := denr rhs;
      if domainp num_rhs or not(mvar num_rhs eq y) then return;

      %% Num may have the form y^d * (y^d1 C1(x) + y^d2 C2(x)) ...
      if null red num_rhs then <<
         d := ldeg num_rhs;  num_rhs := lc num_rhs;
         if domainp num_rhs then return
      >>;

      %% Now num must have the form y^d1 C1(x) + y^d2 C2(x),
      %% where d1 > d2 and d2 = 0 is allowed (if d <> 0 or d3 <> 0).
      if (C1 := get!!y!^n!*C(num_rhs, y)) then
         << d1 := car C1;  C1 := cdr C1 >>
      else return;
      num_rhs := red num_rhs;
      %% Allow d2 = 0 => num_rhs freeof y
      if not smember(y, num_rhs) then
         << d2 := 0;  C2 := num_rhs >>
      else if red num_rhs then return
      else if (C2 := get!!y!^n!*C(num_rhs, y)) then
         << d2 := car C2;  C2 := cdr C2 >>
      else return;

      %% Den must have the form C3(x) or y^d3 C3(x).
      %% In the latter case, combine the powers of y.
      if smember(y, den_rhs) then
         if null red den_rhs and
            (den_rhs := get!!y!^n!*C(den_rhs, y)) then <<
            d3 := car den_rhs;  den_rhs := cdr den_rhs;
            d1 := {'difference, d1, d3};
            d2 := {'difference, d2, d3}
         >> else return;

      %% Simplify the degrees of y and find which is 1:
      if d then << d1 := {'plus, d1, d};  d2 := {'plus, d2, d} >>;
      d1 := aeval d1;  d2 := aeval d2;
      if d1 = 1 then << P := C1; Q := C2; n := d2 >>
      else if d2 = 1 then << P := C2; Q := C1; n := d1 >>
      else return;
      %% A final check that P, Q, n are valid:
      if Bernoulli!-depend!-check(P, y) or
         Bernoulli!-depend!-check(Q, y) or
            Bernoulli!-depend!-check(den_rhs, y) or
               Bernoulli!-depend!-check(n, x) then return;
      %% ( Last test implies Bernoulli!-depend!-check(n, y). )
      %% For testing:
      %% return {'list, mk!*sq(P ./ den_rhs), mk!*sq(Q ./ den_rhs), n};
      P := mk!*sq(P ./ den_rhs);  Q := mk!*sq(Q ./ den_rhs);
      return ODESolve!-Bernoulli1(P, Q, y, x, n)
   end ) where depl!* = depl!*$

symbolic procedure Bernoulli!-depend!-check(f, xy);
   %% f is a standard form, xy is an identifier (kernel).
   if numr difff(f, xy) then <<         % neq 0 (nil)
      traceode "It is not of Bernoulli type because ...";
      MsgPri(nil, !*f2a f, "depends (possibly implicitly) on",
         get(xy, 'odesolve!-depvar) or xy, nil);
      %% (y might be gensym -- 'odesolve!-depvar set in odeintfc)
      t
   >>$

symbolic procedure get!!y!^n!*C(u, y);
   %% Assume that u is a standard form representation of y^n * C(x)
   %% with y the leading kernel.  Return (n . C) or nil
   begin scalar n, C;
      if mvar u eq y then <<            % ?? y^n * C(x), n nonnegint
         n := ldeg u;  C := lc u;
         return if not domainp C and smember(y, mvar C) then
            ( if (C := get!!y!^n!*C1(C, y)) then
               % y^n * y^n1 * C(x), n nonnegint
               {'plus, n, car C} . cdr C )
         else n . C
      >> else                           % (y^n1)^n * C(x), n nonnegint
         return get!!y!^n!*C1(u, y)
   end$

symbolic procedure get!!y!^n!*C1(u, y);
   % u = (y^n1)^n * C(x), n nonnegint
   begin scalar n, C;
      n := mvar u;
      if not(eqcar(n, 'expt) and cadr n eq y) then return;
      n := {'times, caddr n, ldeg u};
      C := lc u;
      return n . C
   end$

algebraic procedure ODESolve!-Bernoulli1(P, Q, y, x, n);
   begin scalar !*odesolve_noint;  % Force integration?
      traceode "It is of Bernoulli type.";
      n := 1 - n;
      return if symbolic !*odesolve_explicit then
         { y = ODENon!-Linear1PQ(n*P, n*Q, x)^(1/n)*
               newroot_of_unity(n) }    % explicit form
      else { y^n = ODENon!-Linear1PQ(n*P, n*Q, x) } % implicit form
   end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Riccati ODEs

algebraic procedure ODESolve!-Riccati(rhs, y, x);
   %% The ODE has the form df(y,x) = rhs.  If rhs has the Riccati form
   %% a(x)y^2 + b(x)y + c(x) then transform to a reduced linear
   %% second-order ODE and attempt to solve it.
   symbolic if not !*odesolve_fast then % heuristic solution
   algebraic begin scalar a, b, c, soln, !*ratarg;
      traceode1 "Testing for a Riccati ODE ...";
      %% rhs may have a denominator that depends on y, so ...
      symbolic(!*ratarg := t);
      c := coeff(rhs, y);
      if length c neq 3 or depends(c, y) then return;
      a := third c;  b := second c;  c := first c;
      c := a*c;  b := -(df(a,x)/a + b);
      traceode "It is of Riccati type ",
         "and transforms into the linear second-order ODE: ",
         num(df(y,x,2) + b*df(y,x) + c*y) = 0;
      soln := {c, b, 1};                % low .. high
      soln := ODESolve!-linear!-basis(soln, 0, y, x, 2,
         if c then 0 else if b then 1 else 2); % min_order
      if not soln then <<
         traceode "But ODESolve cannot solve it!";
         return
      >>;
      %% The solution of the linear second-order ode must have the
      %% form y = arbconst(1)*y1 + arbconst(2)*y2, in which only the
      %% ratio of the arbconst's is relevant here, so ...
      soln := first soln;
      soln := newarbconst()*first soln + second soln;
      return {y = sub(y = soln, -df(y,x)/(a*y))}
      %% BEWARE: above minus sign missing in Zwillinger, first edn.
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% ODEs that are "solvable for y or x", including Clairaut and Lagrange
% as special cases.

algebraic procedure ODESolve!-Clairaut(ode, ode_p, p, y, x);
   %% Assuming that ode is first order, determine whether it is of
   %% Clairaut type f(xy'-y) = g(y'), and if so return its general
   %% solution together with a singular solution if one exists.
   begin scalar sing_soln;
      traceode1 "Testing for a Clairaut ODE ...";
      sing_soln := sub(y = x*p, ode_p);
      if depends(sing_soln, x) or depends(sing_soln, y) then
         return;                        % Not Clairaut
      traceode "It is of Clairaut type.";
      %% Look for a singular solution:
      sing_soln := solve(df(ode, x), df(y,x));
      sing_soln := for each soln in sing_soln join
         %% NB: Cannot use algebraic code to check soln because it may
         %% contain derivatives that evaluate to 0.
         if symbolic eqcar(caddr soln, 'root_of)
         then {} else {num sub(soln, ode) = 0};
      return (sub(p = newarbconst(), ode_p) = 0) . sing_soln
   end$

symbolic operator ODESolve!-Solvable!-y$
symbolic procedure ODESolve!-Solvable!-y(ode_p, p, y, x);
   %% ode_p has the form f(x,y,p) where p = y'.
   ( algebraic begin scalar c, lagrange, ode_y, ode_x;
      traceode1 "Testing for a ""solvable for y"" or Lagrange ODE ...";
      %% Is the ODE "solvable for y"?
      c := coeff(ode_p, y);
      if length c neq 2 or depends(c, y) then return;
      ode_y := -first c / second c;
      %% ode_y has the form f(x,p) where p = y' and ode is y = ode_y.
      %% If f(x,p) = xF(p) + G(p) then ode is a Lagrange equation.
      if not depends(den ode_y, x) and
         length(c:=coeff(num ode_y, x)) = 2 and
         not depends(c, x) then
         lagrange := 1;                 % Lagrange form
      symbolic depend1(p, x, t);
      ode_x := num(p - df(ode_y, x));
      if lagrange then <<
         %% ODE is a Lagrange equation, hence ode_x is a LINEAR ODE
         %% for x(p) that can be solved EXPLICITLY (using an
         %% integrating factor) for a single value of x.
         symbolic depend1(x, p, t);
         ode_x := num(ode_x where df(p,x) => 1/df(x,p));
         symbolic depend1(p, x, nil);
         traceode "It is of Lagrange type and reduces to this ",
            "subsidiary ODE for x(y'): ",
            ode_x = 0;
         ode_x := ODENon!-Linear1(ode_x, x, p)
      >> else if symbolic !*odesolve_fast then return
         traceode "Sub-solver terminated: fast mode, no heuristics!"
      else <<
         %% ode_x is an arbitrary first-order ODE for p(x), so ...
         traceode "It is ""solvable for y"" and reduces ",
            "to this subsidiary ODE for y'(x):";
         ode_x := ODESolve!-FirstOrder(ode_x, p, x);
         if not ode_x then <<
            traceode "But ODESolve cannot solve it!";
            return
         >>
      >>;
      traceode "The subsidiary solution is ", ode_x,
         " and the main ODE can be solved parametrically ",
         "in terms of the derivative.";
      return if symbolic(!*odesolve_implicit or !*odesolve_explicit) then
         %% Try to eliminate p between ode_y and ode_x else fail.
         %% Assume that the interface code will try to actually solve
         %% this for y:
         Odesolve!-Elim!-Param(ode_y, y, ode_x, p, y)
      else
         %% Return a parametric solution {y(p), x(p), p}:
         if lagrange then            % soln explicit for x
            for each soln in ode_x collect ODESolve!-Simp!-ArbParam
               sub(p=newarbparam(), {y = sub(soln, ode_y), soln, p})
         else
            for each soln in ode_x join <<
               %% Make solution as explicit as possible:
               soln := solve(soln, x);
               for each s in soln collect ODESolve!-Simp!-ArbParam
                  sub(p=newarbparam(),
                     if symbolic eqcar(caddr s, 'root_of) then
                        {y=ode_y, sub(part(rhs s, 2)=x, part(rhs s, 1)), p}
                     else {y=sub(s, ode_y), s, p})
            >>
   end ) where depl!* = depl!*$


symbolic operator ODESolve!-Solvable!-x$
symbolic procedure ODESolve!-Solvable!-x(ode_p, p, y, x);
   %% ode_p has the form f(x,y,p) where p = y'.
   not !*odesolve_fast and              % heuristic solution
   ( algebraic begin scalar c, ode_x, ode_y;
      traceode1 "Testing for a ""solvable for x"" ODE ...";
      %% Is the ODE "solvable for x"?
      c := coeff(ode_p, x);
      if length c neq 2 or depends(c, x) then return;
      ode_x := -first c / second c;
      %% ode_x has the form f(y,p) where p = y' and ode is x = ode_x.
      symbolic depend1(p, y, t);
      ode_y := num(1/p - df(ode_x, y));
      %% ode_y is an arbitrary first-order ODE for p(y), so ...
      traceode "It is ""solvable for x"" and reduces ",
         "to this subsidiary ODE for y'(y):";
      ode_y := ODESolve!-FirstOrder(ode_y, p, y);
      if not ode_y then <<
         traceode "But ODESolve cannot solve it! ";
         return
      >>;
      traceode "The subsidiary solution is ", ode_y,
         " and the main ODE can be solved parametrically ",
         "in terms of the derivative.";
      return if symbolic(!*odesolve_implicit or !*odesolve_explicit) then
         %% Try to eliminate p between ode_x and ode_y else fail.
         %% Assume that the interface code will try to actually solve
         %% this for y:
         Odesolve!-Elim!-Param(ode_x, x, ode_y, p, y)
      else
         for each soln in ode_y join <<
            %% Return a parametric solution {y(p), x(p), p}:
            %% Make solution as explicit as possible:
            soln := solve(soln, y);
            for each s in soln collect ODESolve!-Simp!-ArbParam
               sub(p=newarbparam(),
                  if symbolic eqcar(caddr s, 'root_of) then
                     {sub(part(rhs s, 2)=y, part(rhs s, 1)), x=ode_x, p}
                  else {s, x=sub(s, ode_x), p})
         >>
   end ) where depl!* = depl!*$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The arbitrary parameters in solutions:

algebraic operator arbparam$
algebraic (!!arbparam := 0)$
algebraic procedure newarbparam();
   arbparam(!!arbparam:=!!arbparam+1)$

algebraic procedure Odesolve!-Elim!-Param(ode_y, y, ode_x, p, depvar);
   %% ode_y is an expression for y and ode_x is an rlist of odesolve
   %% solutions for x, both in terms of a parameter p.  Return a list
   %% of equations corresponding to the equations in ode_x but with p
   %% eliminated with ode_y, or nil if this is not possible.
   %% depvar is the true dependent variable.
   begin scalar soln, result;
      if polynomialp(ode_y := num(y - ode_y), p) then <<
         result := {};
         while ode_x neq {} and
            polynomialp(soln := num !*eqn2a first ode_x, p)
            do <<
               result := resultant(ode_y, soln, p) . result;
               ode_x := rest ode_x
            >>;
         if ode_x = {} then
            return Odesolve!-Tidy!-Implicit(result, y)
      >>;
      ode_y := solve(ode_y, p);
      %% solve here may return a one_of construct (zimmer (4) & (19)).
      %% I don't see why, but ...
      %% (expand_cases not defined until solve loaded.)
      ode_y := expand_cases ode_y;
      if not smember(root_of, ode_y) then <<
         result := for each soln in ode_y join
            for each s in ode_x join
               if rhs s = 0 then  % s is f(x,y) = 0
                  if (s:=sub(soln, num lhs s)) neq 0 then {num s}
                  else {}
               else {num(sub(soln, rhs s) - x)};  % s is x = f(x,y)
         return Odesolve!-Tidy!-Implicit(result, depvar)
      >>;
      traceode "But cannot eliminate parameter ",
         "to make solution explicit."
   end$

algebraic procedure Odesolve!-Tidy!-Implicit(solns, depvar);
   %% Remove repeated and irrelevant factors from implicit solutions.
   for each soln in solns join
      for each fac in factorize soln join
         if smember(depvar, fac:=first fac) then {fac = 0} else {}$

switch odesolve_simp_arbparam$          % DEFAULT OFF.  TEMPORARY?

symbolic operator ODESolve!-Simp!-ArbParam$
symbolic procedure ODESolve!-Simp!-ArbParam u;
   %% Simplify arbparam expressions within parametric solution u
   %% (cf. ODESolve!-Simp!-ArbConsts)
   begin scalar !*precise, x, y, ss_x, ss_y, arbexprns_x, arbexprns_y,
      arbexprns, param;
      if not(rlistp u and length u = 4) then
         TypErr(u, "parametric ODE solution");
      if not !*odesolve_simp_arbparam then return u; % TEMPORARY?
      x := lhs cadr u;  y := lhs caddr u;
      if not(ss_x := ODESolve!-Structr(caddr cadr u, x, y, 'arbparam))
      then return u;
      if not(ss_y := ODESolve!-Structr(caddr caddr u, x, y, 'arbparam))
      then return u;
      ss_x := cdr ss_x;  ss_y := cdr ss_y;
      arbexprns_x := for each s in cdr ss_x collect caddr s;
      arbexprns_y := for each s in cdr ss_y collect caddr s;
      if null(arbexprns := intersection(arbexprns_x, arbexprns_y))
      then return u;
      arbexprns_x := cdr ss_x;  ss_x := car ss_x;
      arbexprns_y := cdr ss_y;  ss_y := car ss_y;
      arbexprns_x := for each s in arbexprns_x join
         if member(caddr s, arbexprns) then {s}
         else << ss_x := subeval{s, ss_x}; nil >>;
      arbexprns_y := for each s in arbexprns_y join
         if member(caddr s, arbexprns) then {s}
         else << ss_y := subeval{s, ss_y}; nil >>;
      traceode "Simplifying the arbparam expressions in ", u,
         " by the rewrites ...";
      param := cadddr u;
      for each s in arbexprns_x do <<
         %% s has the form ansj = "expression in arbparam(n)"
         traceode rhs s => param;
         %% Remove other occurrences of arbparam(n):
         ss_x := algebraic sub(solve(s, param), ss_x);
         %% Finally rename ansj as arbparam(n):
         ss_x := subeval{{'equal, cadr s, param}, ss_x}
      >>;
      for each s in arbexprns_y do <<
         ss_y := algebraic sub(solve(s, param), ss_y);
         ss_y := subeval{{'equal, cadr s, param}, ss_y}
      >>;
      %% Try a further heuristic simplification:
      if smember(param, den ss_x) and smember(param, den ss_y) then
      begin scalar ss_x1, ss_y1;
         ss_x1 := algebraic sub(param = 1/param, ss_x);
         if smember(param, den ss_x1) then return;
         ss_y1 := algebraic sub(param = 1/param, ss_y);
         if smember(param, den ss_y1) then return;
         traceode "Simplifying further by the rewrite ",
            param => 1/param;
         ss_x := ss_x1;  ss_y := ss_y1
      end;
      return makelist {{'equal, x, ss_x}, {'equal, y, ss_y}, param}
   end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic operator Polynomialp$

%% symbolic procedure polynomialp(pol, var);
%%    %% Returns true if numerator of pol is polynomial in var.
%%    %% Assumes on exp, mcd.
%%    begin scalar kord!*;  kord!* := {var};
%%       pol := numr simp!* pol;
%%       while not domainp pol and mvar pol eq var and
%%          (domainp lc pol or not smember(var, mvar lc pol)) do
%%             pol := red pol;
%%       return not smember(var, pol)
%%    end$

symbolic procedure Polynomialp(pol, var);
   %% Returns true if numerator of pol is polynomial in var.
   %% Assumes on exp, mcd.
   Polynomial!-Form!-p(numr simp!* pol, !*a2k var)$

symbolic procedure Polynomial!-Form!-p(sf, y);
   %% A standard form `sf' is polynomial if each of its terms is
   %% polynomial:
   domainp sf or
      (Polynomial!-Term!-p(lt sf, y) and Polynomial!-Form!-p(red sf, y))$

symbolic procedure Polynomial!-Term!-p(st, y);
   %% A standard term `st' is polynomial if either (a) its
   %% leading power is polynomial and its coefficient is free of y, or (b)
   %% its leading power is free of y and its coefficient is polynomial:
   if tvar st eq y then not smember(y, tc st)
   else if not smember(y, tvar st) then Polynomial!-Form!-p(tc st, y)$

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odeintfc.red0000644000175000017500000010532411526203062024620 0ustar  giovannigiovannimodule odeintfc$  % Enhanced ODE solver interface

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <30 October 2000>

% Use: odesolve(ode, y, x, conds, options)
%   or   dsolve(ode, y, x, conds, options)  (cf. Maple)

% The first argument must evaluate to an ODE or a list of ODEs.

% Each dependent variable y may be either an identifier or an
% operator, such as y(x), which is replaced by a new identifier
% internally.  If y(x) is specified and x is not specified then x is
% extracted from y(x) (cf. Maple).  Equations containing operators of
% the form y(x) with different arguments x are trapped, currently as
% an error, until differential-delay equation solving is implemented.

% If a dependent variable (y) does not depend on the independent
% variable (x) then y is automatically declared to depend on x, and a
% warning message to this effect is output.  Derivatives are not
% evaluated until this dependence has been enforced.  BUT NOTE THAT
% THIS DOES NOT WORK IF THE FIRST ARGUMENT IS AN ASSIGNMENT!  This is
% because the assignment is performed BEFORE the ode solver takes
% control.  This is something of an inconsistency in the current
% REDUCE algebraic processing model.

% All arguments after the first are optional but the order must be
% preserved.  If the first argument is a list of ODEs then y is
% expected to be a list of dependent variables.  If x is specified
% then y must also be specified (first).  An empty list can be used as
% a place-holder argument.  If x and/or y are missing then they are
% parsed out of the ODE.

% Thus, possible argument combinations, each of which may optionally
% be followed by conds, are: ode | ode, y | ode, y, x

% Currently, conditions can be specified only for a single ODE.

% If specified, conds must take the form of an unordered list of
% (unordered lists of) equations with either y, x, or a derivative of
% y on the left.  A single list of conditions need not be contained
% within an outer list.  Combinations of conditions are allowed.
% Conditions within one (inner) list all relate to the same x value.
% For example:

% Boundary conditions:
% {{y=y0, x=x0}, {y=y1, x=x1}, ...}

% Initial conditions:
% {x=x0, y=y0, df(y,x)=dy0, ...}

% Combined conditions:
% {{y=y0, x=x0}, {df(y,x)=dy1, x=x1}, {df(y,x)=dy2, y=y2, x=x2}, ...}

% Boundary conditions on the values of y at various values of x may
% also be specified by replacing the variables by equations with
% single values or matching lists of values on the right, of the form:

% y = y0, x = x0  |  y = {y0, y1, ...}, x = {x0, x2, ...}

% The final argument may be one of the identifiers

% implicit, explicit, laplace, numeric, series

% specifying an option.  The options "implicit" and "explicit" set the
% switches odesolve_implicit and odesolve_explicit locally.  The other
% options specify solution techniques -- they are not yet implemented.


% TO DO:
%   Improved condition code to handle eigenvalue-type BVPs.
%   Solve systems of odes, calling crack where appropriate

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% User interface
% ==============

put('odesolve, 'psopfn, 'odesolve!-eval)$
put('dsolve, 'psopfn, 'odesolve!-eval)$ % alternative (cf. Maple)
listargp odesolve, dsolve$              % May have single list arg.

symbolic procedure odesolve!-eval args;
   %% Establish a suitable global environment:
   (if !*div or !*intstr or !*factor or not !*exp or not !*mcd then
      NoInt2Int reval result else NoInt2Int result) where result =
      begin scalar !*evallhseqp, !*multiplicities, !*div, !*intstr,
            !*exp, !*mcd, !*factor, !*ifactor, !*precise,
            !*nopowers, !*algint, !*echo;
         %% Turn echo off to stop Win32 PSL REDUCE (only)
         %% outputting its trigsimp lap code at the end of
         %% odesolve.tst.  (Don't ask!)
         !*evallhseqp := !*exp := !*mcd := t;
         return odesolve!-eval1 args
      end$

symbolic procedure odesolve(ode, y, x);
   %% Direct symbolic-mode interface equivalent to MAHM's original.
   %% Calls odesolve!-eval to ensure correct environment.
   odesolve!-eval{ode, y, x}$

global '(ODESolve!-tracing!-synonyms)$
ODESolve!-tracing!-synonyms := '(trode trace tracing)$

symbolic procedure odesolve!-eval1 args;
   %% args = (ode &optional y x conds)
   %% Parse variables from ode if necessary (like solve),
   %% automatically declare y to depend on x if necessary and
   %% optionally impose conditions on the general solution.
   %% Support for systems of odes partly implemented so far.
   ( begin scalar ode, system, y, x, yconds, xconds, conds, soln;
      if null args then RedErr
         "ODESolve requires at least one argument -- the ODE";

      begin scalar df_simpfn, !*uncached;  !*uncached := t;
         % Turn off simplification of df (in case y does not yet
         % depend on x) before evaluating args (which may be lists):
         df_simpfn := get('df, 'simpfn);
         put('df, 'simpfn, 'simpiden);
         args := errorset!*({'revlis, mkquote args}, t);
         put('df, 'simpfn, df_simpfn);
         if errorp args then error1();
         args := car args
      end;

      ode := car args;  args := cdr args;
      system := rlistp ode;
      %% Find dependent and independent variables:
      %% (rlistp is a smacro defined in rlisp.red)
      if args then <<  y := car args;
         if rlistp y then
            if null cdr y then          % empty list - ignore
               y := 'empty
            else if rlistp cadr y or eqnp cadr y then
               y := nil                 % condition rlist
            else if system then
               y := makelist            % rlist of dependent variables
                  for each yy in cdr y collect !*a2k yy
            else MsgPri("ODESolve: invalid second argument",
               y, nil, nil, t)
         else if system then TypErr(y, "dependent var list")
         else if eqnp y then
            if cadr y memq 'output . ODESolve!-tracing!-synonyms then % option
               y := nil
            else << yconds := caddr y;  y := !*a2k cadr y >>
         else if not smember(y:=!*a2k y, ode) then
            y := nil                    % option
      >>;
      if y then args := cdr args;
      if args and y then <<  x := car args;
         if rlistp x then
            if null cdr x then          % empty list - ignore
               x := 'empty
            else x := nil               % condition list
         else if eqnp x then
            if cadr x memq 'output . ODESolve!-tracing!-synonyms then % option
               x := nil
            else << xconds := caddr x;  x := !*a2k cadr x >>
         else if not smember(x:=!*a2k x, ode) then
            x := nil                    % option
      >>;
      if x then args := cdr args;
      if y eq 'empty then y := nil;
      if x eq 'empty then x := nil;
      %% If x not given and y an operator (list) then extract x:
      if null x and y then
         if rlistp y then
            begin scalar yy;  yy := cdr y;
               while yy and atom car yy do yy := cdr yy;
               if yy and cdar yy then x := cadar yy;
               if not idp x then x := nil
            end
         else if pairp y and cdr y then x := cadr y;
      %% Finally, attempt to parse variables from ode if necessary:
      if null y or null x then
         %%%%% NOTE: ODE ALREADY AEVAL'ED ABOVE
         %%%%% so some of the following is now redundant !!!!!
      begin scalar df_simpfn, k_list, df_list;
         % Turn off simplification of df (in case y does not yet
         % depend on x) before evaluating ode, which may be a list:
         df_simpfn := get('df, 'simpfn);
         put('df, 'simpfn, 'simpiden);
         k_list := errorset!*({'get_k_list, mkquote ode}, t);
         put('df, 'simpfn, df_simpfn);
         if errorp k_list then error1() else k_list := car k_list;
         df_list := get_op_knl('df, car k_list);
         for each knl in cdr k_list do
            df_list := union(df_list, get_op_knl('df, knl));
         %% df_list is set of derivatives in ode(s).
         if null df_list then RedErr
            "No derivatives found -- use solve instead.";
         %% df_list = ((df y x ...) ... (df z x ...) ... )
         if null y then <<
            y := cadar df_list . nil;
            for each el in cdr df_list do
               if not member(cadr el, y) then y := cadr el . y;
            %% y is a list at this point.
            if system then
               if length ode < length y then
                  RedErr "ODESolve: under-determined system of ODEs."
               else y := makelist y     % algebraic list of vars
            else
               if cdr y then
                  MsgPri("ODESolve -- too many dependent variables:",
                     makelist y, nil, nil, t)
               else y := car y;         % single var
            MsgPri("Dependent var(s) assumed to be", y, nil, nil, nil)
         >>;
         if null x then <<
            x := caddar df_list;
            MsgPri("Independent var assumed to be", x, nil, nil, nil)
         >>;
      end;

      %% Process the ode (re-simplifying derivatives):
      EnsureDependency(y, x);
      ode := aeval ode;
      %% !*eqn2a is defined in alg.red
      if system then
         if length ode > 2 then
            %% RedErr "Solving a system of ODEs is not yet supported."
            %% Skip conditions TEMPORARILY!
            return ODESolve!-Depend(
               makelist for each o in cdr ode collect !*eqn2a o, y, x, nil)
         else
            << ode := !*eqn2a cadr ode;  y := cadr y >>
      else ode := !*eqn2a ode;

      %% Process conditions (re-simplifying derivatives):
      if args then
         if rlistp(conds := aeval car args) then <<
            args := cdr args;
            conds := if not rlistp cadr conds then conds . nil
            else cdr conds
         >> else conds := nil;
      %% Now conds should be a lisp list of rlists (of equations).
      if yconds then
         yconds := if rlistp yconds then cdr yconds else yconds . nil;
      if xconds then
         xconds := if rlistp xconds then cdr xconds else xconds . nil;
      %% Concatenate separate x & y conds onto conds list:
      while yconds and xconds do <<
         conds := {'list, {'equal, x, car xconds},
            {'equal, y, car yconds}} . conds;
         yconds := cdr yconds;  xconds := cdr xconds
      >>;
      if yconds or xconds then
         RedErr "Different condition list lengths";
      if conds then
         %% Move this into odesolve!-with!-conds?
         conds := makelist odesolve!-sort!-conds(conds, y, x);

      %% Process remaining control option arguments:
      while args do
      begin scalar arg;  arg := car args;  args := cdr args;
         if eqnp arg then               % equation argument
            if cadr arg eq 'output then
               args := caddr arg . args
            else if cadr arg memq ODESolve!-tracing!-synonyms then
               !*trode := caddr arg
            else MsgPri("Invalid ODESolve option", arg,
               "ignored.", nil, nil)
                                        % keyword argument
         else if arg memq
            '(implicit explicit expand noint verbose
               basis noswap norecurse fast check) then
            set(mkid('!*odesolve_, arg), t)
         else if arg eq 'algint then on1 'algint
         else if arg eq 'full or !*odesolve_full then
            !*odesolve_expand := !*odesolve_explicit := t
         else if arg memq ODESolve!-tracing!-synonyms then !*trode := t
         else if arg memq '(laplace numeric series) then
            RedErr{"ODESolve option", arg, "not yet implemented."}
               %% Pass remaining args to routine called
         else RedErr{"Invalid ODESolve option", arg}
      end;

      if !*odesolve_verbose then algebraic <<
         write "ODE: ", num ode=0;
         write "Dependent variable: ", y, ";  independent variable: ", x;
         write "Conditions: ", symbolic(conds or "none");
      >>;

      %% Rationalize conflicting options:
      %% Conditions override basis
      if conds then !*odesolve_basis := nil;
%%       %% Basis overrides explicit
%%       if !*odesolve_basis then !*odesolve_explicit := nil;

      %% Finally, solve the ode!
      if not getd 'ODESolve!*0 then     % for testing
         return {'ODESolve, ode, y, x, conds};
%%       soln := if conds then
%%          odesolve!-with!-conds(ode, y, x, conds)
%%       else odesolve!-depend(ode, y, x);
      if null(soln := ODESolve!-Depend(ode, y, x, conds)) then
         return algebraic {num ode=0};
      %% Done as follows because it may be easier to solve after
      %% imposing conditions than before, and it would be necessary to
      %% remove root_of's before imposing conditions anyway.
      if !*odesolve_explicit and not ODESolve!-basisp soln then
         soln := ODESolve!-Make!-Explicit(soln, y, conds);
      if !*odesolve_expand then
         soln := expand_roots_of_unity soln;
      if !*odesolve_check then
         ODE!-Soln!-Check(if !*odesolve_noint then NoInt2Int soln else soln,
            ode, y, x, conds) where !*noint = t;
      return soln

   end ) where !*odesolve_implicit = !*odesolve_implicit,
               !*odesolve_explicit = !*odesolve_explicit,
               !*odesolve_expand = !*odesolve_expand,
               !*trode = !*trode,
               !*odesolve_noint = !*odesolve_noint,
               !*odesolve_verbose = !*odesolve_verbose,
               !*odesolve_basis = !*odesolve_basis,
               !*odesolve_noswap = !*odesolve_noswap,
               !*odesolve_norecurse = !*odesolve_norecurse,
               !*odesolve_fast = !*odesolve_fast,
               !*odesolve_check = !*odesolve_check$

symbolic procedure Odesolve!-Make!-Explicit(solns, y, conds);
   <<
      %% SHOULD PROBABLY CHECK THAT Y IS NOT INSIDE AN UNEVALUATED
      %% INTEGRAL BEFORE TRYING TO SOLVE FOR IT -- IT SEEMS TO UPSET
      %% SOLVE!
      solns := for each soln in cdr solns join
         if cadr soln eq y then {soln} else <<
            %% soln is an implicit solution of ode for y
            %% for each s in cdr reval aeval {'solve, soln, y} join
            %%    %% Make this test optional?
            %%    if eqcar(caddr s, 'root_of) or eval('and .
            %%       mapcar(cdr expand_roots_of_unity subeval{s, ode},
            %%          'zerop))
            %%    then {s}
            %%    else if !*trode then algebraic write "Solution ", s,
            %%    " discarded -- does not satisfy ODE";
            traceode
               "Solution before trying to solve for dependent variable is ",
               soln;
            cdr reval aeval {'solve, soln, y}
         >>;
      %% It is reasonable to return root_of's here.
      %% Solving can produce duplicates, so ...
      %% solns := union(solns, nil); % union still necessary?

      %% Check that each explicit solution still satisfies any
      %% conditions:
      if conds then
         for each cond in cdr conds do  % each cond is an rlist
         begin scalar xcond;
            xcond := cadr cond;
            cond := makelist for each c in cddr cond collect !*eqn2a c;
            solns := for each s in solns join
               if eqcar(caddr s, 'root_of) or
                  union(cdr %% trig_simplify
                     subeval{xcond, subeval{s, cond}}, nil) = {0}
               then {s}
               else algebraic traceode "Solution ", s,
               " discarded -- does not satisfy conditions";
         end;
      makelist solns
   >>$

% Should now be able to use the standard package `trigsimp' instead!
algebraic procedure trig_simplify u;
   u where tan_half_angle_rules$

algebraic(tan_half_angle_rules := {
   sin(~u) => 2tan(u/2)/(1+tan(u/2)^2),
   cos(~u) => (1-tan(u/2)^2)/(1+tan(u/2)^2) })$
%% Cannot include tan rule -- recursive!


symbolic procedure get_k_list ode;
   %% Return set of all top-level kernels in ode or rlist of odes.
   %% (Do not cache to ensure derivatives are [eventually] evaluated
   %% properly!)
   begin scalar k_list, !*uncached;  !*uncached := t;
      %% Do not make an assignment twice:
      if eqcar(ode, 'setk) then ode := caddr ode;
      if rlistp(ode := reval ode) then <<
         k_list := get_k_list1 cadr ode;
         for each el in cddr ode do
            k_list := union(k_list, get_k_list1 el)
      >>
      else k_list := get_k_list1 ode;
      return k_list
   end$

symbolic procedure get_k_list1 ode;
   union(kernels numr o, kernels denr o)
      where o = simp !*eqn2a ode$

symbolic procedure get_op_knl(op, knl);
   %% Return set of all operator kernels within knl with op as car.
   if pairp knl then
      if car knl eq op then knl . nil
      else
         ( if op_in_car then union(op_in_car, op_in_cdr) else op_in_cdr )
            where op_in_car = get_op_knl(op, car knl),
               op_in_cdr = get_op_knl(op, cdr knl)$

symbolic procedure EnsureDependency(y, x);
   for each yy in (if rlistp y then cdr y else y . nil) do
      if not depends(yy, x) then <<
         MsgPri("depend", yy, ",", x, nil);
         depend1(yy, x, t)
      >>$


symbolic procedure odesolve!-sort!-conds(conds, y, x);
   %% conds is a lisp list of rlists of condition equations.
   %% Return a canonical condition list.
   %% Collect conditions at the same value of x, check them for
   %% consistency and sort them by increasing order of derivative.
   begin scalar cond_alist;
      for each cond in conds do
      begin scalar x_cond, y_conds, x_alist;
         if not rlistp cond then TypErr(cond, "ode condition");

         %% Extract the x condition:
         y_conds := for each c in cdr cond join
            if not CondEq(c, y, x) then
               TypErr(c, "ode condition equation")
            else if cadr c eq x then << x_cond := c; nil >>
            else c . nil;
         if null x_cond then
            MsgPri(nil, x, "omitted from ode condition", cond, t);
         if null y_conds then
            MsgPri(nil, y, "omitted from ode condition", cond, t);

         %% Build the new condition alist, with the x condition as key:
         if (x_alist := assoc(x_cond, cond_alist)) then
            nconc(x_alist, y_conds)
         else cond_alist := (x_cond . y_conds) . cond_alist
      end;
      %% Now cond_alist is a list of lists of equations, each
      %% beginning with a unique x condition.

      %% Sort the lists and return a list of rlists:
      return for each cond in cond_alist collect makelist
         if null cddr cond then cond else car cond .
         begin scalar sorted, next_sorted, this, next, result;
            sorted := sort(cdr cond, 'lessp!-deriv!-ord);
            %% sorted is a list of equations.
            while sorted and (next_sorted := cdr sorted) do <<
               if cadr(this := car sorted) eq
                  cadr(next := car next_sorted) then
                  %% Two conds have same lhs, so ...
                  ( if caddr this neq caddr next then
                     MsgPri("Inconsistent conditions:",
                        {'list, this, next}, "at", car cond, t) )
                           % otherwise ignore second copy
               else result := this . result;
               sorted := next_sorted
            >>;
            return reversip(next . result)
         end
   end$

symbolic procedure CondEq(c, y, x);
   %% Return true if c is a valid condition equation for y(x).
   %% cf. eqexpr in alg.red
   eqexpr c and ( (c := cadr c) eq x or c eq y or
      (eqcar(c, 'df) and cadr c eq y and caddr c eq x
         %% Is the following test overkill?
         and (null cdddr c or fixp cadddr c)) )$

symbolic procedure lessp!-deriv!-ord(a, b);
   %% (y=y0) < (df(y,x)=y1) and df(y,x,m)=ym < df(y,x,n)=yn iff m < n
   %% But y might be a kernel rather than an identifier!
   if atom(a := cadr a) then            % a = (y=?)
      not atom cadr b                   % b = (df(y,x,...)=?)
   else if atom(b := cadr b) then       % b = (y=?)
      not atom cadr a                   % a = (df(y,x,...)=?)
   else if not(car a eq 'df) then       % a = (y(x)=?)
      car b eq 'df                      % b = (df(y(x),x,...)=?)
   else                                 % a = (df(y,x,...)=?), any y
      car b eq 'df and                  % b = (df(y,x,...)=?)
         if null(a := cdddr a) then     % a = (df(y,x)=?)
            cdddr b                     % b = (df(y,x,n)=?), 1 < n
         else                           % a = (df(y,x,m)=?), m > 1
            (b := cdddr b) and
               car a < car b$           % b = (df(y,x,n)=?), m < n


%%% THE FOLLOWING PROCEDURE SHOULD PROBABLY INCLUDE THE CODE TO MAKE
%%% SOLUTIONS EXPLICIT BEFORE RESTORING OPERATOR FORMS FOR Y.

symbolic procedure ODESolve!-Depend(ode, y, x, conds);
   %% Check variables and dependences before really calling odesolve.
   %% If y is an operator kernel then check whether ode is a
   %% differential-delay equation, and if not solve ode with y
   %% replaced by an identifier.
   ( begin scalar xeqt, ylist, sublist;
      y := if rlistp ode then cdr y else y . nil;
      %% Using `t' as a variable causes trouble when checking
      %% dependence of *SQ forms, which may contain `t' as their last
      %% element, so...
      if x eq t then <<
         xeqt := t;  x := gensym();
         for each yy in y do if idp yy then depend1(yy, x, t);
         %% Cannot simply use `sub' on independent variables in
         %% derivatives, so...
         ode := subst(x, t, reval ode); % reval subst?
         if conds then conds := subst(x, t, reval conds); % reval subst?
         sublist := (t.x) . sublist
      >>;
      for each yy in y do
         if idp yy and not(yy eq t) then <<
            %% Locally and quietly remove any spurious inverse
            %% implicit dependence of x on y:
            ylist := yy . ylist;
            depend1(x, yy, nil) where !*msg = nil;
         >> else                        % replace variable
         begin scalar yyy;
            yyy := gensym();  depend1(yyy, x, t);
            ylist := yyy . ylist;
            put(yyy, 'odesolve!-depvar, yy); % for later access
            sublist := (yy.yyy) . sublist;
            if xeqt then yy := subeval{{'equal,t,x}, yy};
            odesolve!-delay!-check(ode, yy);
            ode := subeval{{'equal,yy,yyy}, ode};
            if conds then conds := subeval{{'equal,yy,yyy}, conds}
         end;
      ylist := reverse ylist;
      ode := if rlistp ode then
         ODESolve!-System(cdr ode, ylist, x)
      else if conds then
         odesolve!-with!-conds(ode, car ylist, x, conds)
      else ODESolve!*0(ode, car ylist, x);
      if null ode then return;
      if sublist then
      begin scalar !*NoInt;
         %% Substitute into derivatives and integrals
         %% (and turn off integration for speed).
         ode := reval ode;              % necessary?
         for each s in sublist do
            ode := subst(car s, cdr s, ode);
         %% ode := reval ode;              % necessary?
      end;
      return ode
   end ) where depl!* = depl!*$

symbolic procedure ODESolve!-System(ode, y, x);
   %% TEMPORARY
   {'ODESolve!-System, makelist ode, makelist y, x}$
algebraic operator ODESolve!-System$

symbolic procedure odesolve!-delay!-check(ode, y);
   %% Check that ode is not a differential-delay equation in y,
   %% i.e. check that every occurrence of the operator y = y(x) has
   %% the same argument (without any shifts).  This could be used as a
   %% hook to call an appropriate solver -- if there were one!
   begin scalar odelist;
      odelist := if rlistp ode then cdr ode else ode . nil;
      for each ode in odelist do
         ( for each knl in kernels numr simp ode do
            for each yy in get_op_knl(y_op, knl) do
               if not(yy eq y) then
                  MsgPri("Arguments of", y_op, "differ --",
                     "solving delay equations is not implemented.", t) )
                        where y_op = car y
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Impose initial/boundary conditions
% ==================================

% A first attempt to impose initial/boundary conditions on the
% solution of a single ode returned by odesolve.

% Solving with conditions provides access to the general solution as
% the value of the global algebraic variable ode_solution.

% If the solution is explicit then the following code could be
% simplified and should be slightly more efficient, but is it worth
% testing for an explicit solution and adding the special case code?

algebraic procedure odesolve!-with!-conds(ode, y, x, conds);
   % conds must be a list of ordered lists of the form
   %    {x=x0, y=y0, df(y,x)=y1, df(y,x,2)=y2, ...}.
   % All conditions applied at the same value of x must be collected
   % into the same list.
   % More generality is allowed only by odesolve!-eval.
   % This code could perhaps be more efficient by building a list of
   % all required derivatives of the ode solution once and for all?
   begin scalar first!!arbconst, arbconsts;
      first!!arbconst := !!arbconst + 1;

      %% Find the general solution of the ode and assign it to the
      %% global algebraic variable ode_solution:
      %1.03% ode_solution := odesolve!-depend(ode, y, x);
      ode_solution := symbolic ODESolve!*0(ode, y, x);
      if not ode_solution then return;
      traceode "General solution is ", ode_solution;
      traceode "Applying conditions ", conds;

      arbconsts :=
         for i := first!!arbconst : !!arbconst collect arbconst i;

      return for each soln in ode_solution join
         odesolve!-with!-conds1(soln, y, x, conds, arbconsts)
   end$

algebraic procedure odesolve!-with!-conds1(soln, y, x, conds, arbconsts);
   begin scalar arbconsteqns;
      %% Impose the conditions (care is needed if the solution is
      %% implicit):
      arbconsteqns := for each cond in conds join
         begin scalar xcond, ycond, dfconds, arbconsteqns;
            xcond := first cond;  cond := rest cond;
            ycond := first cond;
            if lhs ycond = y then cond := rest cond else ycond := 0;
            %% Now cond contains only conditions on derivatives.
            arbconsteqns :=
               if ycond then         % Impose the condition on y:
                  {sub(xcond := {xcond, ycond}, soln)}
               else {};
            dfconds := {};
            %% Impose the conditions on df(y, x, n).  If the solution
            %% is implicit, then in general all lower derivatives will
            %% be introduced, so ...
            while cond neq {} do
            begin scalar dfcond, result;
               %% dfcond : next highest derivative
               %% result : of substituting for all derivatives
               %% dfconds : all derivatives so far including this one
               dfcond := first cond;  cond := rest cond;
               dfconds := dfcond . dfconds;
               %% All conditions on derivatives are handled before
               %% conditions on x and y to protect against
               %% substituting for x or y in df(y,x,...):
               result := sub(dfconds, map(y => lhs dfcond, soln));
               if not(result freeof df) then % see comment below
                  RedErr "Cannot apply conditions";
               arbconsteqns := sub(xcond, result) . arbconsteqns
            end;
            return arbconsteqns
         end;

      %% Solve for the arbitrary constants:
      arbconsts := solve(arbconsteqns, arbconsts);
      %% ***** SHOULD CHECK THAT THE SOLUTION HAS SUCCEEDED! *****
      %% and substitute each distinct arbconst solution set into the
      %% general ode solution:
      return for each cond in arbconsts collect
         if rhs soln = 0 then           % implicit solution
            num sub(cond, lhs soln) = 0
         else
            sub(cond, soln)
   end$

%% The above df error can happen only if the solution is implicit and
%% a derivative is missing from the sequence, which is unlikely.
%% Should try to recover by computing the value of the missing
%% derivative from the conditions on lower order derivatives, and
%% letting solve eliminate them.  Try this later IF it ever proves
%% necessary.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Check the solution set
% ======================

% This code checks that the solution satisfies the ODE and that a
% general solution is general.

% A `solution' is either a basis solution:
%   {{b1(x), b2(x), ..., bn(x)}, PI(x)}; PI may be omitted if zero
% or a list of component solutions.

algebraic procedure ODE!-Soln!-Check(soln, ode, y, x, conds);
   %% SOLN is a LIST of solutions; ODE is a differential EXPRESSION; Y
   %% is the dependent variable; X is the independent variable; CONDS
   %% is true if conditions were specified.
   begin scalar n, !*allowdfint, !*expanddf;
      symbolic(!*allowdfint := !*expanddf := t);
      ode := num !*eqn2a ode;           % returns ode as expression
      %% Should compute order `on demand' in ODE!-Comp!-Soln!-Fails.
      n := ODE!-Order(ode, y);
      if symbolic ODESolve!-basisp soln then <<
         %% Basis solution (of linear ODE).
         %% Only arises as general solution.
         %% Remove contribution from PI if there is one:
         if arglength soln = 2 and second soln then
            ode := num sub(y = y + second soln, ode);
         if length(soln := first soln) neq n then
            write "ODESolve warning - ",
               "wrong number of functions in basis!";
         %% Test each basis function in turn:
         for each s in soln do
            if (s:=sub(y = s, ode)) and trigsimp s then
               write "ODESolve warning - ",
                  "basis function may not satisfy ODE: ", s
      >> else <<
         %% List of component solutions.
         %% Check generality:
         if not conds and ODESolve!-arbconsts soln < n then
            write "ODESolve warning - ",
               "too few arbitrary constants in general solution!";
         for each s in soln do
            if ODE!-Comp!-Soln!-Fails(s, ode, y, x, n) then
               write "ODESolve warning - ",
                  "component solution may not satisfy ODE: ", s;
      >>
   end$

% Each component solution may be
% explicit: y = f(x)
% implicit: f(x,y) = g(x,y); rhs MAY be 0
% unsolved: ode = 0, but CAN THIS CASE ARISE?
% parametric: {y = g(p), x = f(p), p}

algebraic procedure ODE!-Comp!-Soln!-Fails(soln, ode, y, x, n);
   %% SOLN is a SINGLE component solution; ODE is a differential
   %% EXPRESSION; Y is the dependent variable; X is the independent
   %% variable; N is the order of ODE.
   if symbolic eqnp soln then           % explicit, implicit or unsolved
      if lhs soln = y and rhs soln freeof y then
                                        % explicit: y = f(x)
         (if (ode := sub(soln, ode)) then trigsimp ode)
      else if rhs soln = 0 and lhs soln = ode then
         1                              % unsolved: ode = 0
      else                              % implicit: f(x,y) = 0
      begin scalar derivs, deriv;
         %% Construct in `derivs' a list of successive derivatives of
         %% the implicit solution f(x,y) up to the order of the ODE in
         %% decreasing order; each expression is linear in the highest
         %% derivative.
         derivs := {soln := num !*eqn2a soln};
         for i := 1 : n do
            derivs := (soln:=num df(soln,x)) . derivs;
         %% Substitute for each derivative in ODE in turn in
         %% decreasing order until the result is zero; if not the
         %% solution fails.
         while n > 0 and <<
            deriv := solve(first derivs, df(y,x,n)); % linear
            if deriv = {} then 0 else
               ode := num sub(first deriv, ode) >> do <<
               n := n - 1;
               derivs := rest derivs
               >>;
         if deriv = {} then <<
            write "ODESolve warning - cannot compute ", df(y,x,n);
            return 1
         >>;
         derivs := first derivs;
         ode := (ode where derivs => 0); % for tracing
         return ode                     % 0 for good solution
      end
   else if symbolic(rlistp soln and eqnp cadr soln) then
                                        % parametric: {y = g(p), x = f(p), p}
   begin scalar xx, yy, p, dp!/dx, deriv, derivs;
      yy := rhs first soln;             % Should not depend on ordering!
      xx := rhs second soln;            % Should not depend on ordering!
      p := third soln;                  % parameter
      %% Construct in `derivs' a list of successive derivatives of the
      %% parametric solution (yy,xx) up to the order of the ODE in
      %% decreasing order.
      dp!/dx := 1/df(xx,p);
      derivs := {deriv:=yy};
      for i := 1 : n do
         derivs := (deriv:=dp!/dx*df(deriv,p)) . derivs;
      %% Substitute for each derivative in ODE in turn in
      %% decreasing order until the result is zero; if not the
      %% solution fails.
      while n > 0 and (ode := num sub(df(y,x,n)=first derivs, ode)) do <<
         n := n - 1;
         derivs := rest derivs
      >>;
      return sub(y=yy, x=xx, ode)
   end
   else write "ODESolve warning - invalid solution type: ", soln$

%% Code to find the actual number of arbitrary constants in a solution:

fluid '(ODESolve!-arbconst!-args)$

symbolic operator ODESolve!-arbconsts$
symbolic procedure ODESolve!-arbconsts u;
   %% Return the number of distinct arbconsts in any sexpr u.
   begin scalar ODESolve!-arbconst!-args;
      ODESolve!-arbconsts1 u;
      return length ODESolve!-arbconst!-args
   end$

symbolic procedure ODESolve!-arbconsts1 u;
   %% Collect all the indices of arbconsts in u into a set in the
   %% fluid variable ODESolve!-arbconst!-args.
   if not atom u then
      if car u eq 'arbconst then
         (if not member(cadr u, ODESolve!-arbconst!-args) then
            ODESolve!-arbconst!-args := cadr u . ODESolve!-arbconst!-args)
      else
         << ODESolve!-arbconsts1 car u;  ODESolve!-arbconsts1 cdr u >>$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.rlg0000644000175000017500000001771111527635055024675 0ustar  giovannigiovanniFri Feb 18 21:27:25 2011 run on win32
% Tests and demonstrations for the ODESolve 1+ package --
% an updated version of the original odesolve test file.

% Original Author: M. A. H. MacCallum
% Maintainer: F.J.Wright@Maths.QMW.ac.uk

ODESolve_version;


ODESolve 1.065

on trode, combinelogs;



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% First-order differential equations
% (using automatic variable and dependence declaration).

% First-order quadrature case:
odesolve(df(y,x) - x^2 - e^x);


*** Dependent var(s) assumed to be y 

*** Independent var assumed to be x 

*** depend y , x
This is a linear ODE of order 1.
It is solved by quadrature.

                       x    3
    3*arbconst(1) + 3*e  + x
{y=---------------------------}
                3


% First-order linear equation, with initial condition y = 1 at x = 0:
odesolve(df(y,x) + y * tan x - sec x, y, x, {x=0, y=1});

This is a linear ODE of order 1.
It is solved by the integrating factor method.

General solution is {y=arbconst(2)*cos(x) + sin(x)}


Applying conditions {{x=0,y=1}}


{y=cos(x) + sin(x)}

odesolve(cos x * df(y,x) + y * sin x - 1, y, x, {x=0, y=1});

This is a linear ODE of order 1.
It is solved by the integrating factor method.

General solution is {y=arbconst(3)*cos(x) + sin(x)}


Applying conditions {{x=0,y=1}}


{y=cos(x) + sin(x)}


% A simple separable case:
odesolve(df(y,x) - y^2, y, x, explicit);

This is a nonlinear ODE of order 1.
It is separable.

Solution before trying to solve for dependent variable is 

arbconst(4)*y - x*y - 1=0


           1
{y=-----------------}
    arbconst(4) - x


% A separable case, in different variables, with the initial condition
% z = 2 at w = 1/2:
odesolve((1-z^2)*w*df(z,w)+(1+w^2)*z, z, w, {w=1/2, z=2});


*** depend z , w
This is a nonlinear ODE of order 1.
It is separable.

                                                   2    2
General solution is {4*arbconst(5) - 2*log(w*z) - w  + z =0}


                         1
Applying conditions {{w=---,z=2}}
                         2


                    2      2
{ - 8*log(w*z) - 4*w  + 4*z  - 15=0}


% Now a homogeneous one:
odesolve(df(y,x) - (x-y)/(x+y), y, x);

This is a nonlinear ODE of order 1.
It is of algebraically homogeneous type 
solved by a change of variables of the form `y = vx'.

                        2            2
{arbconst(6) + sqrt( - x  + 2*x*y + y )=0}


% Reducible to homogeneous:
% (Note this is the previous example with origin shifted.)
odesolve(df(y,x) - (x-y-3)/(x+y-1), y, x);

This is a nonlinear ODE of order 1.
It is quasi-homogeneous if the result of shifting the origin is homogeneous ...
It is of algebraically homogeneous type 
solved by a change of variables of the form `y = vx'.

                        2                  2
{arbconst(7) + sqrt( - x  + 2*x*y + 6*x + y  - 2*y - 7)=0}


% and the special case of reducible to homogeneous:
odesolve(df(y,x) - (2x+3y+1)/(4x+6y+1), y, x);

This is a nonlinear ODE of order 1.

                                   2
It is separable after letting y + ---*x => y
                                   3


{49*arbconst(8) - 3*log(14*x + 21*y + 5) - 21*x + 42*y=0}


% A Bernoulli equation:
odesolve(x*(1-x^2)*df(y,x) + (2x^2 -1)*y - x^3*y^3, y, x);

This is a nonlinear ODE of order 1.
It is of Bernoulli type.

                          5
  1    5*arbconst(9) + 2*x
{----=----------------------}
   2          4      2
  y        5*x  - 5*x


% and finally, in this set, an exact case:
odesolve((2x^3 - 6x*y + 6x*y^2) + (-3x^2 + 6x^2*y - y^3)*df(y,x), y, x);

This is a nonlinear ODE of order 1.
It is exact and is solved by quadrature.

                     4       2  2       2      4
{4*arbconst(10) + 2*x  + 12*x *y  - 12*x *y - y =0}


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Now for higher-order linear equations with constant coefficients

% First, examples without driving terms
% A simple one to start:
odesolve(6df(y,x,2) + df(y,x) - 2y, y, x);

This is a linear ODE of order 2.
It has constant coefficients.

     (7*x)/6
    e       *arbconst(12) + arbconst(11)
{y=--------------------------------------}
                   (2*x)/3
                  e


% An example with repeated and complex roots:
odesolve(ode := df(y,x,4) + 2df(y,x,2) + y, y, x);

This is a linear ODE of order 4.
It has constant coefficients.

{y=arbconst(16)*sin(x) + arbconst(15)*cos(x) + arbconst(14)*sin(x)*x

  + arbconst(13)*cos(x)*x}


% A simple right-hand-side using the above example:
odesolve(ode = exp(x), y, x);

This is a linear ODE of order 4.
It has constant coefficients.
Constructing particular integral using `D-operator method'.

{y=(4*arbconst(20)*sin(x) + 4*arbconst(19)*cos(x) + 4*arbconst(18)*sin(x)*x

                                  x
     + 4*arbconst(17)*cos(x)*x + e )/4}


ode := df(y,x,2) + 4df(y,x) + 4y - x*exp(x);


                                x
ode := df(y,x,2) + 4*df(y,x) - e *x + 4*y

% At x=1 let y=0 and df(y,x)=1:
odesolve(ode, y, x, {x=1, y=0, df(y,x)=1});

This is a linear ODE of order 2.
It has constant coefficients.
Constructing particular integral using `D-operator method'.

                                                                 3*x        3*x
                        27*arbconst(22) + 27*arbconst(21)*x + 3*e   *x - 2*e
General solution is {y=---------------------------------------------------------
                                                    2*x
                                                27*e

   }


Applying conditions {{x=1,y=0,df(y,x)=1}}


       3*x        3*x      3        3       2         2
    3*e   *x - 2*e    - 6*e *x + 5*e  + 27*e *x - 27*e
{y=-----------------------------------------------------}
                              2*x
                          27*e


% For simultaneous equations you can use the machine, e.g. as follows:

depend z,x;


ode1 := df(y,x,2) + 5y - 4z + 36cos(7x);


ode1 := 36*cos(7*x) + df(y,x,2) + 5*y - 4*z

ode2 := y + df(z,x,2) - 99cos(7x);


ode2 :=  - 99*cos(7*x) + df(z,x,2) + y

ode := df(ode1,x,2) + 4ode2;


ode :=  - 2160*cos(7*x) + df(y,x,4) + 5*df(y,x,2) + 4*y

y := rhs first odesolve(ode, y, x);

This is a linear ODE of order 4.
It has constant coefficients.
Constructing particular integral using `D-operator method'.

y := arbconst(26)*sin(x) + arbconst(25)*cos(x) + arbconst(24)*sin(2*x)

      + arbconst(23)*cos(2*x) + cos(7*x)

z := rhs first solve(ode1,z);


z := (4*arbconst(26)*sin(x) + 4*arbconst(25)*cos(x) + arbconst(24)*sin(2*x)

       + arbconst(23)*cos(2*x) - 8*cos(7*x))/4

clear ode1, ode2, ode, y, z;


nodepend z,x;



% A "homogeneous" n-th order (Euler) equation:
odesolve(x*df(y,x,2) + df(y, x) + y/x + (log x)^3, y, x);

This is a linear ODE of order 2.
It has non-constant coefficients.
It is of the homogeneous (Euler) type and is reducible to a simpler ODE ...
It has constant coefficients.
Constructing particular integral using `D-operator method'.

                                                                    3
{y=(2*arbconst(28)*sin(log(x)) + 2*arbconst(27)*cos(log(x)) - log(x) *x

               2
     + 3*log(x) *x - 3*log(x)*x)/2}


% The solution here remains symbolic (because neither REDUCE nor Maple
% can evaluate the resulting integral):
odesolve(6df(y,x,2) + df(y,x) - 2y + tan x, y, x);

This is a linear ODE of order 2.
It has constant coefficients.
Constructing particular integral using `D-operator method'.
But cannot evaluate the integrals, so ...
Constructing particular integral using `variation of parameters'.

                    7
The Wronskian is --------
                     x/6
                  6*e


       (7*x)/6                                  (7*x)/6        sin(x)
{y=(7*e       *arbconst(30) + 7*arbconst(29) - e       *int(-------------,x)
                                                              x/2
                                                             e   *cos(x)

             (2*x)/3
            e       *sin(x)          (2*x)/3
     + int(-----------------,x))/(7*e       )}
                cos(x)


end;


Time for test: 312 ms
@@@@@ Resources used: (1 3 18 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/test.bat0000755000175000017500000000101511526203062023773 0ustar  giovannigiovannirem test --- Run a REDUCE test file.

rem Author: Anthony C. Hearn.
rem Modified by FJW for testing multiple files entirely within current directory.

:loop
if "%1" == "" goto ret
set testfile=%1
shift

if %lisp% == psl goto psl

start /wait /min %reduce%\lisp\csl\%MACHINE%\csl -i %reduce%\lisp\csl\reduce.img test.dat -- %testfile%.lg

goto loop
:psl

start /wait /min %reduce%\lisp\psl\%MACHINE%\psl\bpsl -td 6000000 -f %reduce%\lisp\psl\%MACHINE%\red\reduce.img -i test.dat -o %testfile%.lg

goto loop
:ret
set testfile=
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.pdf0000644000175000017500000056627211526203062024661 0ustar  giovannigiovanni%PDF-1.3
5 0 obj
<< /S /GoTo /D (section.1) >>
endobj
8 0 obj
(Introduction)
endobj
9 0 obj
<< /S /GoTo /D (section.2) >>
endobj
12 0 obj
(Installation)
endobj
13 0 obj
<< /S /GoTo /D (section.3) >>
endobj
16 0 obj
(User interface)
endobj
17 0 obj
<< /S /GoTo /D (subsection.3.1) >>
endobj
20 0 obj
(Specifying the ODE and its variables)
endobj
21 0 obj
<< /S /GoTo /D (subsection.3.2) >>
endobj
24 0 obj
(Specifying conditions)
endobj
25 0 obj
<< /S /GoTo /D (subsection.3.3) >>
endobj
28 0 obj
(Specifying options and defaults)
endobj
29 0 obj
<< /S /GoTo /D (section.4) >>
endobj
32 0 obj
(Output syntax)
endobj
33 0 obj
<< /S /GoTo /D (section.5) >>
endobj
36 0 obj
(Solution techniques)
endobj
37 0 obj
<< /S /GoTo /D (subsection.5.1) >>
endobj
40 0 obj
(Linear solution techniques)
endobj
41 0 obj
<< /S /GoTo /D (subsection.5.2) >>
endobj
44 0 obj
(Nonlinear solution techniques)
endobj
45 0 obj
<< /S /GoTo /D (subsubsection.5.2.1) >>
endobj
48 0 obj
(First-order nonlinear solution techniques)
endobj
49 0 obj
<< /S /GoTo /D (subsubsection.5.2.2) >>
endobj
52 0 obj
(Higher-order nonlinear solution techniques)
endobj
53 0 obj
<< /S /GoTo /D (section.6) >>
endobj
56 0 obj
(Extension interface)
endobj
57 0 obj
<< /S /GoTo /D (section.7) >>
endobj
60 0 obj
(Change log)
endobj
61 0 obj
<< /S /GoTo /D (section.8) >>
endobj
64 0 obj
(Planned developments)
endobj
65 0 obj
<< /S /GoTo /D [66 0 R  /Fit ] >>
endobj
68 0 obj <<
/Length 1458      
/Filter /FlateDecode
>>
stream
xXIo6WQfhqSd6M6vC҃~|''J+᭚8gn9L̄vrŧT&h=t&3HA2ےJ-M+&3魐ROfJpE=T%z׋–D}Y`=YG 
;Nv|OZVbIx3ty"gS:Pү~]&9<"/8j34Ě`wݷy?VMݾZkrz3e6\&߇y[\*t~F+;<,tfC^hw%<yߠپ^%yؼ=UM[kD;ΐXV̀ˏw
@1@W^+ĵ`>=݁#,V $oM^ 5t=ǯ09Rh$r"٤Q"KFO1J.jP ӜYPe_xy۠IA{MQ.WxkPR,[0uRm/[&:hg,E7.%Œ$S(woA'%X>`[_A;ɑsW~j]5dh@B4͜zq'Zhi+	"o9~2-
\5s;	fldVZNzΪS*yz#hYY}B=⫺J9HTǃ)o,M;Y؞cNl[Wuu̽ݨ鞽F{:~b `;rm4&9Dk;=7#.i^zD%67c;qcD*FsEeD>'\KGAcsy8`]%;I__%=#񌵽R4>_5^
"gy],{4ZRޔc	3Su:*+@-Gqc5#^94,z$eSGzJ=Rl"88)|
c^e9EҀSPN92e\wrT_D5;HY-p9\ۉZ Si^EI@9k7^͡'ym\s,"xj#`5Wy=
\2%s)j>l
3GJ(3 *MawG|5	ɢkM-B4zƇ&42h&3Vg^6-W5AEB?3V^ZRj,DwW̖
*x"j.c:	W49(=t,Π$;pUx6\!6*!ӯȤxL/Oendstream
endobj
66 0 obj <<
/Type /Page
/Contents 68 0 R
/Resources 67 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 115 0 R
/Annots [ 83 0 R 88 0 R 92 0 R 93 0 R 94 0 R 98 0 R 99 0 R 100 0 R 101 0 R 102 0 R 103 0 R 104 0 R 105 0 R 106 0 R 107 0 R 108 0 R 112 0 R 113 0 R 114 0 R ]
>> endobj
83 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 1]
/Rect [200.306 538.557 393.009 554.497]
/Subtype /Link /A << /Type /Action /S /URI /URI (http://centaur.maths.qmw.ac.uk/) >>
>> endobj
88 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 454.603 203.908 463.514]
/Subtype /Link
/A << /S /GoTo /D (section.1) >>
>> endobj
92 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 432.685 197.662 441.596]
/Subtype /Link
/A << /S /GoTo /D (section.2) >>
>> endobj
93 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 410.767 210.931 419.678]
/Subtype /Link
/A << /S /GoTo /D (section.3) >>
>> endobj
94 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [138.75 396.875 325.411 407.723]
/Subtype /Link
/A << /S /GoTo /D (subsection.3.1) >>
>> endobj
98 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [138.75 384.919 255.866 395.768]
/Subtype /Link
/A << /S /GoTo /D (subsection.3.2) >>
>> endobj
99 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [138.75 372.964 299.923 383.812]
/Subtype /Link
/A << /S /GoTo /D (subsection.3.3) >>
>> endobj
100 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 351.046 213.858 361.812]
/Subtype /Link
/A << /S /GoTo /D (section.4) >>
>> endobj
101 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 329.129 238.508 339.977]
/Subtype /Link
/A << /S /GoTo /D (section.5) >>
>> endobj
102 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [138.75 317.173 277.95 328.022]
/Subtype /Link
/A << /S /GoTo /D (subsection.5.1) >>
>> endobj
103 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [138.75 305.218 292.479 316.066]
/Subtype /Link
/A << /S /GoTo /D (subsection.5.2) >>
>> endobj
104 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [161.664 293.263 372.789 304.111]
/Subtype /Link
/A << /S /GoTo /D (subsubsection.5.2.1) >>
>> endobj
105 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [161.664 281.308 380.898 292.156]
/Subtype /Link
/A << /S /GoTo /D (subsubsection.5.2.2) >>
>> endobj
106 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 261.327 237.069 270.238]
/Subtype /Link
/A << /S /GoTo /D (section.6) >>
>> endobj
107 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 237.472 196.754 248.32]
/Subtype /Link
/A << /S /GoTo /D (section.7) >>
>> endobj
108 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [123.806 215.554 253.182 226.403]
/Subtype /Link
/A << /S /GoTo /D (section.8) >>
>> endobj
112 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [275.25 138.815 282.224 147.227]
/Subtype /Link
/A << /S /GoTo /D (cite.Hearn-manual) >>
>> endobj
113 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [287.173 138.815 294.147 147.227]
/Subtype /Link
/A << /S /GoTo /D (cite.MacCallum-doc) >>
>> endobj
114 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [299.097 138.815 306.071 147.227]
/Subtype /Link
/A << /S /GoTo /D (cite.MacCallum-ISSAC) >>
>> endobj
69 0 obj <<
/D [66 0 R /XYZ 124.802 740.998 null]
>> endobj
70 0 obj <<
/D [66 0 R /XYZ 124.802 716.092 null]
>> endobj
87 0 obj <<
/D [66 0 R /XYZ 124.802 467.651 null]
>> endobj
6 0 obj <<
/D [66 0 R /XYZ 124.802 201.538 null]
>> endobj
67 0 obj <<
/Font << /F18 73 0 R /F17 76 0 R /F19 79 0 R /F20 82 0 R /F18 73 0 R /F31 86 0 R /F32 91 0 R /F8 97 0 R /F33 111 0 R /F19 79 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
121 0 obj <<
/Length 3081      
/Filter /FlateDecode
>>
stream
xڝZYs6~P@jy:vٻr6VQmQk9aY~rbyK4}|ݔ
O])i ήËܾMzYlnwDxzc۶zxFyes
AfNJ{đ0)hCK6y+7HP0X>	P
R^ccTD7iG9.((8pR~Et!zcJ1onDOD%~B=(49x~rYCc$x^[=-
.yn	jA+
O-D78<8BU{nK1Z:ft&XHDdXAQ,bΝ	y	VFr̘0>drwdP2a#6Q`;RFBM"$ql]ҙPvVxC|C v8Y&kPO@\<>XPMUg#Y-3Cиg=Ei1,b#<(˕G\;~Mb96JS1gƉ-h^ g#.廪H.P_XڳeCQD>MgOSZ(`8#4Ȳ#=
yY}BMx5-p0ocGnO'3Tؠ@%n*2<[{yEa9o^?%y'膇H%ͫ_⮯c¨BO4
Gy=Nf[b{(
	(0wܵ}Od;'g[A+LȨ~(8W^Imu
7,&YzQ
&й"di&7s&7C5ኼ_s2\LttGwmgA((elDN=0b3*HF${ϣa@,cB%20)X?TK0JvWOX7"P+hAʤBƏuea~bK^)A6p(1!́:9ltQy73ywSHR?6MD~-`1S?Tg !~V;T_IjlB)6ەg|XX;89 =WIo ^Ȭx
&.Q:O:X* F1.^2Ů9Q T\nŀI>4
SmQt/G. khҙp5lD!9
a-*Dd+'rPH4g-_pp/ kw:Lh"9:շ KWWF@2iSh S:ށTskZM<>uEzh2_GgZk_+KHHrA&	4JC/mB&Y`Qr$8yIPB
A"`[! g:w1gZ"L4fV,Fc} ]w
_62${b:>!;W>5a>Klq!%JN.df
8ob[B}Fv%l{c%s`‚s_*cնHdOfTƖU抿Ӻd
f(KzZĬ잙9q;r;ű8>J?ִX#hs
8cgQLTK1{Cr(m
G]=}.X\rFXT|F?L?.
9sVJ𨂒#6IQ4kr6(9vIy7b	$<+hA49ՀvjwQ5tn|[76&HG\SL$\bt&3bU
	k9xZ}ݎw7	?	CԫnOj"<õv`[IB:OE2.xIuΒ!ܤ#ͼ/rv4ig
C׎0+vxak9Lw[@B'θ֖zș'6s!oapG';K]KT<uO%C5-Bd8T(<IwciJx諥N_#gZb& MXճ*KWL"sUMsiGDқę@=/Sm#'-T7*#ĨB~ϧyt*5ɶsUbQp%!v=i3Bv&!t^4t m	P3kyc{J W*V#9?ǼD΁=ssESR@(mՋ׷/=endstream
endobj
120 0 obj <<
/Type /Page
/Contents 121 0 R
/Resources 119 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 115 0 R
/Annots [ 123 0 R 124 0 R 125 0 R 126 0 R 127 0 R 128 0 R 129 0 R 130 0 R 131 0 R 135 0 R ]
>> endobj
123 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [246.227 657.312 253.201 665.725]
/Subtype /Link
/A << /S /GoTo /D (cite.CATHODE) >>
>> endobj
124 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [294.764 645.357 301.738 653.77]
/Subtype /Link
/A << /S /GoTo /D (cite.Zimmermann) >>
>> endobj
125 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [299.081 633.402 311.036 641.814]
/Subtype /Link
/A << /S /GoTo /D (cite.FJW1) >>
>> endobj
126 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [146.554 621.446 158.509 629.859]
/Subtype /Link
/A << /S /GoTo /D (cite.FJW2) >>
>> endobj
127 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [338.816 597.536 350.771 605.949]
/Subtype /Link
/A << /S /GoTo /D (cite.Zwillinger) >>
>> endobj
128 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [419.885 585.581 426.859 593.994]
/Subtype /Link
/A << /S /GoTo /D (cite.Man) >>
>> endobj
129 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [430.412 585.581 437.386 593.994]
/Subtype /Link
/A << /S /GoTo /D (cite.Man-MacCallum) >>
>> endobj
130 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [440.939 585.581 447.913 593.994]
/Subtype /Link
/A << /S /GoTo /D (cite.Prelle-Singer) >>
>> endobj
131 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [166.407 573.626 173.381 582.039]
/Subtype /Link
/A << /S /GoTo /D (cite.CRACK-doc) >>
>> endobj
135 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [1 0 0]
/Rect [207.16 523.314 214.134 535.27]
/Subtype /Link
/A << /S /GoTo /D (section.6) >>
>> endobj
122 0 obj <<
/D [120 0 R /XYZ 124.802 740.998 null]
>> endobj
10 0 obj <<
/D [120 0 R /XYZ 124.802 428.102 null]
>> endobj
119 0 obj <<
/Font << /F8 97 0 R /F33 111 0 R /F19 79 0 R /F14 134 0 R /F31 86 0 R /F35 138 0 R /F36 141 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
153 0 obj <<
/Length 2807      
/Filter /FlateDecode
>>
stream
xڭYY~_'y֊y{fL)lI%$ =uQ%LEEXE~Fԍ&"WMv|w?~LnR7Î86 nUNnS{.{,kxA(쌃mQoy	4ʦf?~zdDʍ/|TO81{&nB]v̀r_ՌV)78T6%o{Y:=8B9-*VXaɋYSGd=nXoGy>^Ud%瑘)NB9	=62mǰ޾Qҳ?(Ik-Ja
T1YcWիV
6P,t{U:g^ B[IBx(./H+#r vvmszSfª9"#К[^Kq#AEDgW~8--vr|n:7Ihl`H냢ix
- Dc^^q!   T)ðSߤ3c6,AM.am7f%S<#fEO-چ^2(w%yܰ|O@	0_7=7Um켵֖IEPh:K
"񬌗Bds'=`x~: R9;	qK{*kjĽԴ9ddzCSϻku0ҽ ݣ(sw-*GiHVSˆ#9FH;0`֑hOd`~5QoIMG)9sS3ފ	I,iřu{-(	Hd1c$3X;АlXp>n`i'ʌD"CK@V"Ht'^jp[UC
2%%
qbY!`*'=<U:,TM3e-Q~Q9oʡe=DQMNx&
,l_VxR\Y`za묡2k0R(:w9"hl{[ӊZ&XuAGQR{091/C0l>S67*yf
)ĈI_s7,m"(tϺ?۪ʘ)^2ѰJBOʍ3mE
n0Qb
VʲPsjs]i#.s̜Bk&(xlG;]:wC5tBhK|)S8Sp!Qf4ә;loҋ1l}2"5j؈O/gJv*U_rEڍ!\XOp^%pplvRcmۜ]a\`daKݪKqسBYfxWJ,n(> MC1g_	\_p˾3iY~i3OFULBcznucB}$Dž9&<3_i9c'5.d!hq-bMboo\?'nXXa^T~od$`P&\帰R،F/1{t:uߑ@1rbqk*Wcmx} BSBmao`©.qo7j۹_yx[1@NGTz@2dš3m%+osFQ4C_R/-2J'Z*"I7eu1"P~ѻ{!`ULGdky6ӱiX])%niO]mղ$_e|(>Kչ!!)p/uo!Op+[k`5$b.rV᫑1?pu

h&@"D!{7x	ش}i%+7`
|+-\+Y?]YK"eh+EW	'WoUF"/$mz	/%U|Ac(3o/[|ɣ5x_|endstream
endobj
152 0 obj <<
/Type /Page
/Contents 153 0 R
/Resources 151 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 115 0 R
>> endobj
154 0 obj <<
/D [152 0 R /XYZ 124.802 740.998 null]
>> endobj
14 0 obj <<
/D [152 0 R /XYZ 124.802 569.627 null]
>> endobj
18 0 obj <<
/D [152 0 R /XYZ 124.802 232.717 null]
>> endobj
151 0 obj <<
/Font << /F8 97 0 R /F33 111 0 R /F19 79 0 R /F31 86 0 R /F11 157 0 R /F31 86 0 R /F35 138 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
160 0 obj <<
/Length 2615      
/Filter /FlateDecode
>>
stream
xYKWL|
77d9pF%)=UU!rz|U2W+nWϮ/޼CzY\lf/=W~ܮ+VA;0N]˫9(6ΛJHӁȚڲ+9ݎ^Ϻ#i uTh,;9p/&-6,D?ByNޔ-tT9Uc(KwRtKO[;L/2bi[>1xIYuDT8L'kfG6]~1s8R[<J#}EޜCউ]ZXgވ2rn.YL&z0\(rYZEY\FEn#'/&)n!D>I*1dIbU
3>cW'mSĪ[CQ_gD\T|a=8t傡1KHa+NV(tz-|#.O\jW1DR)rk!8VtE0([jDpqD(,BOBZ!-ы-'n!ݿ
4u]v?\aHεFlcbz^bs+fKq(mdWeSʠVd{w ׾gܘF
Q"?rNkyzSp)fg;qs+8Øxxa^wŁoyf(	pY=BvH#b(]B6
dFݗP>8:wB3ay-uv{|Çs1'a7G1Ŗ}uGE&
먝Y	v)GG$L#4GXa 
mx-`C$l4iP7Y@VCPkF!4'w,k}')br6B~l]9H2!K܀)Y6̦;&O'16MѼ: !Qا
"Vs}t%"
#_R	Du~æB\1>cTxBz/jeKB~eHcC=B&' X23M=HE~lA06ufb0yF8BLVJ#|t+~..`9:Z>@'몿Uo?Oi
27$gpwōnEFϩjh~6B$8!agP[
N*[.TDCq4ܖcPaeX4lyA8	8=楑S
c{)eM&b,,Y8Y2T%B]Wb.UQɞ@5 J1R}cJ
AlCb+].lhÅl
T`.\I_eu5o ]B%TZ;a1k(`Z`8DdcFJ|Rf5c4{}hZתɞ/|B:4T43 _c(l>Cll|b3EOOt%#es(/
٘K̨Z@.)k| Hl3seS)fnH)atBֿ)w%l\"	Wm
_ζ!RXr!ϥ7
(P6AR@FR8YP;E41p4jk.YdISl5veQ/FGNJBĄ	D;()#l:=qM&Q]J&GyiiDHcR=l4!>̓,a
X5Y4o!@]g
Fgw#*Lj|
	
0<xh#e5 }[>q76,`Rێչ#i9|JP8HRmٍIb\ ˋVp(_RMG]9WtэN+FnG9TJm-|0skhQab)\,tק?YBmg|=r-dWK>6o~ZL$&NZQendstream
endobj
159 0 obj <<
/Type /Page
/Contents 160 0 R
/Resources 158 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 115 0 R
>> endobj
161 0 obj <<
/D [159 0 R /XYZ 124.802 740.998 null]
>> endobj
22 0 obj <<
/D [159 0 R /XYZ 124.802 353.458 null]
>> endobj
158 0 obj <<
/Font << /F8 97 0 R /F11 157 0 R /F33 111 0 R /F19 79 0 R /F31 86 0 R /F32 91 0 R /F14 134 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
164 0 obj <<
/Length 907       
/Filter /FlateDecode
>>
stream
xڽVMs0+8+lV;L35=8`3SlR{{W__ЄL ywv%==	]Cb>.C|;73o8[EFxG-b:"1qJe#"5]IDyo%h=+کVANlE[{FKm䢉64,$$e_T%}.,ݼOPb)~q1&j.Ք8]=Hׄ5Zd\iCUہqV
2|ram{"YtQEX8Sdnm
rvaIɱT<*Lp9&%FKwn FCoMzhR@&E!"!n4=Hep. 0@Xױ2ڔ2ɬp8B)#
aR2yCl*r1ѐEOB1F6	RaILʥ*tf9FܣEEHsaFkhM~(Vv%%Y.*բx?oZՈddʐn%O>^Q>jV#L7Igu	B2Bjmnc3He*vx+b/Rz
r*l8E\ZN{_8޿jz,;#l** B]PԁU$;XXqZ2:0hBv+"UO7-FW^	ZwBqM~F'[hz>.5PMڧ?ه<+aG(R36endstream
endobj
163 0 obj <<
/Type /Page
/Contents 164 0 R
/Resources 162 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 115 0 R
>> endobj
165 0 obj <<
/D [163 0 R /XYZ 124.802 740.998 null]
>> endobj
162 0 obj <<
/Font << /F33 111 0 R /F8 97 0 R /F11 157 0 R /F14 134 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
168 0 obj <<
/Length 3557      
/Filter /FlateDecode
>>
stream
xn_aFY9C]-X$b)Q!:F6CRn@P839kuJGp׻~aH"I4n1խەQ|8ݮbjqͩvc]I`ؔ[{an?Ou4MV:Wq^VwY)+lm<AyrE#{e#6vC9V6oԗayF>:^RW
Ͱ8ה=ԸoQ8zxs2:	{_n0Xqj51E\yi08:XxmG}O$:uJ5q'L8-!l5@Pte6S&V"@4meʖ	/0| K*N0i[y2.O:6͹#?7tB̧)䩙B㮿%	hؘ0	v]#wb{N>j|΃GnnQcN̞K&x ,s@LGB1 dxny&d+'m(G9dnXek~25l
ꍝxU׃:3kK; *)(Ff	:ʫ ч\wPK#vJ
XQAv9k"Q[cPhN'!5f#`)Im]ܴ_ǸҊCI,l.Ln8;pXl'|ÁSEm+&NNrӳn'-gEf?vy$J0Dk;VQ3bf8Lo*gW	BrH딅`k"σPjy~Sj
c&$95NSq7Fgv6 /&/˶Bs߽|Yz?q"6K,kVN70b;|$-MeKq	1O_qGC*4PQ>< *|}"	f2`#Y+KG\KT+!nt5F{^4rq0TaN2:f5Xcq"8h<آ յPyL7RbWV 0#}wbb%[$V7x!'ɌNG(MN}KQn7%nPm
\Rr@auqnm[
dSs=8 JNМL$
b
ZG*~eSR
$>6
z	Ճ$H0BP]ko$R3Gou%VK2CL#Y`{hND8U`[cG>Ҭ00%$T˧𐏚
rWtU>@턇OhlO!˷)4
kLg8P¡qL-<ƉC'k2Gmv071M'e]3TYPE˞EydD$$	U$a`n2MX&xxY+,a/pn;PJrq4Gh"I]e0qV$-T&cþʍAKl/Ҋc+&VC/eׯbL:NYt}{(;9.r|ig0(U:q&mz'5OT_
?byt~Ew~8JVKѺKTxyX`6=*Rыc,8\!VhJH;p|?IطJ:P.Z*ehV9
ɧ`kB_ւ0HUi81^VX%sɆ7PSη2}=TQܜ؏^kUpÂ!4~d>
k[u%Ad4#R`žXaL7<4~,(g_+c-;KvrO*ЅڃGEHnCQO'Bzp`'ygRXplB5!"'b(/oWnōKNbf|9)*
3D`^U<%x,+^^X#Ńj8jNћsUٓ-vըyjIA9̤d%6*?*YOUbeeM}
Gm.S'77?
o~GAO+{-0j|J}f"*1O'$X)0<^T={HrD,tfyv~'yr7v%K0%8Ej߉ѓ$#6**+Rѐ'z=[TJh\CUYJؗ(pI>+w.ĕ>z’=0A)c5Q:zT!tQ~˯}[rKyr> endobj
169 0 obj <<
/D [167 0 R /XYZ 124.802 740.998 null]
>> endobj
26 0 obj <<
/D [167 0 R /XYZ 124.802 716.092 null]
>> endobj
166 0 obj <<
/Font << /F31 86 0 R /F8 97 0 R /F32 91 0 R /F11 157 0 R /F33 111 0 R /F19 79 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
172 0 obj <<
/Length 3971      
/Filter /FlateDecode
>>
stream
xڕZ[o~_5P@nw(QRH,hAifH]q}ύ4#/lܾsHuSqQ|E&Tqq?/]F=O06U}oU_V?ToL+,BÃ
>L	J=r3L+2U%~);r0 …4ꤰgWj:%}nӊ>rǍTݟ%RQ]l3 bErذFE^$dagB=_#*::-D$&F5=uZn]K|vk{8سI\L
d6F;|{VN
+Yfg_vdMP([T,Ԣ3/8y>$M5vQҾ҈vHC1<ͅW6J9b8C+Z?bYV^A3`b%1>sa '@A{&U@;7q+%HfLH`҂|±pLBd=7
U[2~cPXHÞf/^?ݥivB7uCU@|B:W
(#dD1摅Pbhc#kiw.Uz/ rl=$:
A&,yn\9
/ie]RCWy&W`[|xQ$\wg#I2.$;[Bp&yl'휓^SٶWv^P{"4R4J MVs@SfCQD[P|Bq	3r4P9$Ro.8c)pa2SHJ"IqZv:6K[o9FH) ܎$8A1cAt3XpY-[9]!l'hKU$ZeA5[WõVR	wO9>qq͂J"
ofʲڌ(h#Ao7
5s=C{U8ԑO4cQumOgKQj(
?fai
7ҕsyS8l)Wc4C4_98|bu&3}yxr˹48m#`|q1EtaVV.-<)nS䋣;;Z:K!jػ$ʂWP&4d
XTsKRZ"R8FǩDq/'܏	4C2#PCT!]Hrdp#<$=řM?;lݶ&Ez/ptiò2f]j.1o쩠_qڕ
,Bķ3'T{nX^DIP=U$q̉[azyVYc)s:rq'Efk%IjSPb~ p@-Dyrky%Xg츤\aԃ+vlqC-thZm]-Knd3kXQJ:46$z"34O>=HWqŠ/yz%!K&=}"P)ɈffvP!ۇ&d
R
Ekc4HIdv>BADÆxe'Nɮ cw]]TH"	_;!{
I xBCɆ8݂l5qeJSy cZӽTֆp}\I	E[%,vήoߠm"
y/Fo5^I5R}U0<3[['8kSΔ$ʭVIKjHKlhDʋθ9zYO~Po֛YN*fA^%rGNyTBD[;b	>
7|%o!c#)xUXp_yv\pF뿺W-:߷%н	LJ,CZ'Pgn^ityDLy:N|d"մsE`$W4f95RZ7(>xOA#vUpْ	F+M.>cR
mMĩ>…AэkYeDGt	huJY$aB$Jf*_I/s8$v*>҆ZvXgq;&,[4`j|SͦEv*%P=Qy#QJ~}&j#s<	!r+=v07/.
H\̍+cƙ6^ȍE"/aN+^=5i:N+!l"
&KWY'f?{:g4-ʽ]y2E1%8sC-~~wendstream
endobj
171 0 obj <<
/Type /Page
/Contents 172 0 R
/Resources 170 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 174 0 R
>> endobj
173 0 obj <<
/D [171 0 R /XYZ 124.802 740.998 null]
>> endobj
170 0 obj <<
/Font << /F8 97 0 R /F33 111 0 R /F19 79 0 R /F35 138 0 R /F11 157 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
177 0 obj <<
/Length 3538      
/Filter /FlateDecode
>>
stream
xڕZKIxdQ$@c&@2@>pӂխ;)](X;Hһ@V,$4-v>[f|3X:Y=wCt{2|yRfLPgO̯A6
=
ήk7Lf&eOx1hA:Qt/b5,t8(4K
4nlJD({j	-XއEZ~U~z[*O$>q?f6\hlq5׈z3|7J|]#}aN{k0LžaEk	@sCkƞ\JTT|.
cS~e*giA+gR[TkoK&Б-l#{	:Hqh5FsĄhLCH	%iPGXFtɴR}^nDr8DeTC'|Az:d9P|NR37FTKCUqǶy&܃@%E/$B+䱺r?Db?*ˢ_Ri\%.>np_d¾DE&쒉ZelwWZB)a7ؚIS[%<'§`moXwP|({)AZ~mC}f_lqjnw9!;I=+&tAp@͈MQ'ww)LޏX$w88BQrT2Ļo 
@ 1A4⌾ÃL\a1>K(42bײ48ҊSi'*QKO@v]׫
    ӡ_8ԥvyd'^>
pdM/KBrKĞ~i\IZ.
&0m.n4V=/<~y[@TyV4=:"Á~Ǐ(+K~	%^(JHG!ҏo娥I
S@AFh朅}{&8`QE}_N<wsޜ1A~?$}k2b˾U7+N5spbebb$&<6WYʤBTu',i8Eq#J>]6%')Jdq%$
ʚp2ԧP^NL|[7D{ë_G󔊞i{gJk@~S5fÓc΍|՝a_{HBa䇳h-)s8d_	N[{sҚ%Sk),@vNQgpLƼ:]xCSubҟ8R9k;B[|?%sOf0]L+o{Pe$rY`^e-g	gK"Rw|nfiK+6+T#H][6U?P3eGÖƏ-Wqȉ0|9o"|i쨩b7qV,E?ocVrRKյX>Ѥo+Wh
7JsN~9`@Pn_A;5hGRpdAzl
r&y}߬=-B3/
)^]5o<1;>"6DV5"6^NPÚ?ϥ*n)86mtH{f&=	UYV)I}$@>	H_>%\,Qm:
;%llrN	&ֹ\"/=Aɒ0*U
Llvxf%$eXl%SWLVIn~/r#0S̮Q[EJ7@	Ҽȑov*+hIp,B$yvqI.zҦ?ou?Y	3݇:G*csW܊x*$srJʕvxVލ>dϕth=TrCr.q/?okIx۱ž{2XM;,݇w9endstream
endobj
176 0 obj <<
/Type /Page
/Contents 177 0 R
/Resources 175 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 174 0 R
>> endobj
178 0 obj <<
/D [176 0 R /XYZ 124.802 740.998 null]
>> endobj
30 0 obj <<
/D [176 0 R /XYZ 124.802 521.253 null]
>> endobj
175 0 obj <<
/Font << /F8 97 0 R /F33 111 0 R /F19 79 0 R /F31 86 0 R /F14 134 0 R /F11 157 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
181 0 obj <<
/Length 3491      
/Filter /FlateDecode
>>
stream
xڕZIoW>QCNlc&ćCլn&e=ZMMɪW[MFy\'MJ_9<@ݿvTZD*7:T8h~2vTt)̓@e/?6kXW6fM7	^DEv4{&'xi*@7iɒhyC	'z}vM8SofۏzŽ&Veslmwe34*hʚ?CP0w^y1$tA82c۞
GfrKwE[Re\(+'>+ѾogF!;G|7x'uǩñÑ[|~028gOZqi8AK@器AGg~eKD6v;*PU}xhzSSd1~X$6uZWLJC-2Ңt<+
0c;ucVZxê(yd3T(.ucߒMDG'd7P8ZM73=iHʵN0¢舯<)9Km37ie2}{};pY<ʨ3X.nx"vg1{MRӯ$!k6]h:'fڟ鬖 mo$.8q[j6+qH&/`y	jB;
")5"n>0s
*:$}c直⪩R6vh,ރ6Ø	ApʪqAaKۊ;{~{Ŋw'0w1OĠ)nk^!*dVq]5c U7%<3*g͏c"ifdPIXC$x
OM(Eg׉UN~Ģ؃>ԏ{'7qh-3Z]L
$hThT:.:DM]0q	-LLP*pA,kaiJo%uW8Ux)Cw~޼;S_|l{+t8l?mH*LqVp[<#;af8[6B.![]@"12z&e78&+8lgS4*3D$i/xb=~ҕ#Dt d<24 b7d-;Gt~	oY*m&0~fZû@3\v3)!;̧نM(66&SNN0",+Wq%PtCrD# xl3#K!BH[}%QvC1N22QK+QȻ
@qZ0)cpuBN#vK-F
&lMB#s%q<.\jm!4=%bY KuЍح{hV6cZЇl%;-LA=6R. w (>Gq|{DaAf1
ܐsͫ,:ٴ  DSQjY$?_ֻ݆҂Ng~#׾.Vy,:A0Lre"!c&b$u %=E=sN+G1z|ڀ2˙`/:Vo59(ǙEGA~⻸R\Fгԇٔj"wD#&>.[xFߕw坬7l_C/^<N)4Q&rucd-2_z1dָ׍2s+;:UT^fyˑ|K59a<bY=L?0OqQc]E'}$Ҟ
*Jtq~4Ei㻃f
r9P.pG47
UR*"ii9aooņ{}hX؟Q,t<}by",BZ@J9DWPoi%46!*x"Dr^][8P6OMV6%]ck[%" c;wY#
8B,!=8$P*8_7bH]Kȇ˥K+&mƥwKI0bW` iu7.Z{}I_@3o%bQ,NEH$Ŀy]<i0Aӊq> endobj
182 0 obj <<
/D [180 0 R /XYZ 124.802 740.998 null]
>> endobj
34 0 obj <<
/D [180 0 R /XYZ 124.802 716.092 null]
>> endobj
38 0 obj <<
/D [180 0 R /XYZ 124.802 536.923 null]
>> endobj
179 0 obj <<
/Font << /F31 86 0 R /F8 97 0 R /F33 111 0 R /F31 86 0 R /F11 157 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
185 0 obj <<
/Length 3479      
/Filter /FlateDecode
>>
stream
xڕZKFW9inEUz/C^fC6MGZHj'~I~ԏR,GV&aٷyƖo7?<},~_6M`(_ʠL
=3UM;m|zQI㛠94jQ?/6*w֏=oZƘLSlW3	@k'XU?Q9ղ3lƩx(s$,d5{@P$˧ȃ#6;γXM[ub"BJ-E&qwh+yEhfm17}3BhapB.DֈR/Fo=+Ac@شn]r7\n'K
XR3 H"ײHҔԐ}O=:ƭyvCO4('FkĖ}ǒL6C[O_`\ehM_T{Y}c,LMAGA緫Ky'LzG,&5>d=>ʟ/bб^N-{"G20JpiƙAYӰD(Q4ombĮ
IQ00
NB=TM5А?4瑿΅hSEMR8
}aiR1ap3y&A	zx?Y08,[;P?m_Kpƍo4+gk6#GLɆ͘0	~hËtRPW""w_+v< LwPsW@\P>s*6^	Y
Ďͅ)&X6u:RX<-:	jxQEyu1_a#L*@]z/~&Z&8JSu:z=3J%Vu`B[Q"LDz$Q)7=׫`[e4y	.+ZL\[GDĈr,\+qN|?
,۪O⸐j9Vz-̻$L\mׁuӸxJu%>9yݠu'uD_HzAdL3Iܲ,~PJ#գbaeŮTy^]V`آgG~yw@Lf+5jKFwwX\LP!&6"Vչ\RF#\{ǵS3n`b2<+e`ٴy.JM4x
"znC:9+ĴB" W2DI^Ȗ:[0!1S!]D\Ma}BgwƲpup!Zkxz_Jt\s	Co
ia=WI
J(c(bmį.6VjNq=V,Sr<	`o#9N!\;J	/:%M5YhE}*\hIU'Nd&"k=
ȫqi,}*qS(
g&PX+*[^ľ̯$2N.QE
.듻h6(su էe3G"ny<*	cZZ9\ vΊ{ҨBڴnQ%L|u%LD9.hscیL_i|ewp2w)5jT&4OSE]6iJjBL=)&ъ>ƸꤓȤNQ;ScQfzfs~lq3cz>HR@}h[X(n|u%.fWy.If4fCnh8F{fL'K
q.Fh%cΐy6޹Q!(+&D?i͎й.%#VxNwze ߩ
h~A@2ׇyh#GW!Tl0$P+;.47 {wBW]8!?k7}#d31W_>ݦpY&{'4Y''eȠGG)}eqE!3o~~|"endstream
endobj
184 0 obj <<
/Type /Page
/Contents 185 0 R
/Resources 183 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 174 0 R
>> endobj
186 0 obj <<
/D [184 0 R /XYZ 124.802 740.998 null]
>> endobj
42 0 obj <<
/D [184 0 R /XYZ 124.802 559.179 null]
>> endobj
46 0 obj <<
/D [184 0 R /XYZ 124.802 250.323 null]
>> endobj
183 0 obj <<
/Font << /F8 97 0 R /F11 157 0 R /F33 111 0 R /F31 86 0 R /F32 91 0 R /F35 138 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
189 0 obj <<
/Length 4007      
/Filter /FlateDecode
>>
stream
x[Ks6WhRb|VMfT@KĊDzH*3/Hi쬳 4_?B6HUHT0[l7_|΄,b{w۟?vjxx׻>_&Hjmtk-~_*̖üЇ>Z3#eQE@Y({HfVWA%Z:=v^~mU@v,K:R5%'h8b@v-0wE4sKl|#h:L;z@O.sɖQ	Zwe}P7%ʳ埖YƊ
a=W?{"wFE)!kǸzWTE}rd	Uк*eqWOB^p+*%	늆_vM3Q͡t|A̐֊ȭFiWe_?T2^Hg
n
&J,㉾v"x
tbeyG"6 |4 IÓ}t$UC,g.kP!Q3JD`d0s8)9<,{
Ed94fk-
yD]Yq
l`thCD~~
"M'OD&!4CB瑰#!Ppݍ'4E	l_b{ݨdXlqM槛TQd:ΨJ-JFH/r=z`ˡ}97SW"H܁ǙcG.Kp./Yg>N70ŚY†f
)ZJmfbgfX!ȱhL&c1?9vD#`8%ڳ\9 	CWk)N@=[ـN&6Eew;:w ll"F{
+cg-e9OyɟJjS\kPe@qdggQH#¥ [_Uܐkd_b}@!biOlֱbXE2Ԝ?=Zhn(2ȑ&8K0և
"aLZt8[LDGQ9QdRr"l6.>by7|?覬8w|H<҆1Sf.S$;Y&V5ޡpgӊ"/:(pd$jr>&2*1 X_\CUyœ%xMƑH|%+]IX;SЇ'NPt"0bD0D[QƉCHJ4UK!8C}VM5-H, `,{
ٞG
IhrB4
yy,+E	Ѱ#y.Ns	ow\	QAy2<8R-LK@SӊGE?$-bb,lp&Rf!V|N j^¼N\LU>Ȃ['x'R&Wru
8CUO3+e?sb
3\|@cJjS4s;.`+Ո
M1IYwfVAMp|xwp9<0yf2!vvP7$ؘwsU6Ư"xDg8=LRt3{la**%|*`0V2KPPTi(ۻș[
e[L
pj(tN5ҁ1?	lj$I`@}߆ۘ޻" ˧RH>A]}k'wQHh-aۿ=8<Љal~O^lgCg5iӹ[ 93K裃'aE&>iz9Ǘw?a8<Ez;l6"uTQӱl|tU+ĿY3v#9 S}T砞5*L|
L?+[	h6e%9f!f>:J8.s;>C];O1R3!v&.5n.C=zj{|KG|4SќT+/2RnNb"LsyK>uW5;>#P&/+{ItQή
6?nQ`lA|`l]ܗisSWmnܲCVq˯I1.=Zb.E;tdvt5(E.ǡ9^$,0;y冿<D}r%݃L-53ylpAڒahE?HoŖTE2L5Vr3"sOU&S|ӝ%G͈Rjxn?yZp63κr{st@>m56jr_r/
k8SЅ܌PʆxoVK|*\hhB_Aa]D]S|sj}90ЃrÁGMtFTMW0RfhKZY@S[ErEGeU:rvխ{RdwV L"<?/)Wdky9\n&it&9>I<.N
'/yK y#3?JѽJLjTP>*0^3K<aQ##IXtqFR~
@ca 4b3o~g8\w0(Ng0-M1Sb]?&Δǻ$Mnn(^Xm)u`OۡpK*`RJu^_6}AnZ}j\jl|þpWo.'*y3b>ߕWsٕ4"pe2%%}C-;ec|&*0Ţ R[Tvﭚ`+>
c`-DIz{
b6nRܑɴ6^۪/4`ab QE>GwZ9fxE&@RT8b9Ce5I*j|T7$o^X-HKADP΁#GVl{Ur~odQi5O4x]t{"4{~sX&_}v> endobj
190 0 obj <<
/D [188 0 R /XYZ 124.802 740.998 null]
>> endobj
50 0 obj <<
/D [188 0 R /XYZ 124.802 268.285 null]
>> endobj
187 0 obj <<
/Font << /F32 91 0 R /F8 97 0 R /F11 157 0 R /F10 193 0 R /F6 196 0 R /F7 199 0 R /F13 202 0 R /F35 138 0 R /F14 134 0 R /F33 111 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
205 0 obj <<
/Length 3645      
/Filter /FlateDecode
>>
stream
xڝZKo6ϯƦ(	f6%9j-Zr)-N>Mz}UIO(m"7ybc˛w17e\(NDyᨢa9h:v~,VJ[XGiF?pˍv¯*7`$Zh>06gnQQ#I,`d&䜰c7==uv>/䵷:Fwgfb`lzS`kQ%e)9Qn_x/dA#_pdlpǙ"q56BwW𵴴[ñK	G#Oy/LdHwD*IPbk<l[
:ot!z˄%NsvzeZw8B!H+?
ׇ&ןA0"yiJ|2FR ^x#,viGmvMd
yPBN	Qqm,	Bs
Z@pىfH#={D@DpM^0+-ޏxy$/;nr
<ĬX;dB)zw2xGcpLxUő
.Y,q?^MQF;Qn	~4#	/u/a
U06W&^R.\zz{F{!Gh[f)AvϏfgy9,oQI-J
dE

ʩO&VKμG4LP&xfnMg*tTQ㳷yn()jB`<${:>CY"lD'LI'>ko;>)VBYOu^X)Q=t2aZAt% 	^6;9#eE.Pf]Ɂp:	URs0|`tV&X.NҰ-Cn?͎#(tfSv{hXlȟ׈UJl*1AP3yE|\D(*M
B\Oaerf:>ŧRHjڈSj)렪ɢvf;7a3wo8XsMJT^/U+ۙei9s/3PȷטRQ
Tk7͉y/(dj^U?T>-;F,@\^61Bs=($H"{p\^Z
f 0/
@[tPa5.+.gхoߠZޢ4fWbrmg^)WNǵUNEPƙ(3MjQ_:1PTAxfq{jc(S;SqFpstAU	MeAۑo;=+:@Z9/\/iG9>'-X5YtXgVr UgN*n`JE-XNu~v
NI&VPEcA4,@.L^yl}8.oKJ2>U;DJCΫǍ$KQ"Sf¸	<Žf+4I4!bJٵG=Ф<̊ueCwDބ%By0DܠlۉZb
tեq	,;hooJ8r缄ǞGg+I,gTE&Iv/q;džO0'rsS"nqƨ=a[ʋ(D
(zhJuGpq'{tD9`"qZ^l?h
`E݆LNxI͚M]~%YEMq2&Y;3d{8"=UGSڎq)[}
a;,ç'$oV״pcWJj9pcq[y—4t$(
{q*|k-~@(ˁ'	w*1#8NFxqOSU$_df52%$yЎ|T4O|jhETJ2J5Ss2
P)Zn[,bk
@>6ǧcPs!ӮA]ԕ˄tLdrt Z
/WAߜy~LaDh^
S7E=YWS6})HRјeu"9wce1pvJmn
ߠOEЪ@EzJ_uRSJ~1~շekܡgqYn!u'c3Jj6*X*^R)-KǍ Qs+h")A7E;LM]kI^Mgoesאdxy!-f> endobj
206 0 obj <<
/D [204 0 R /XYZ 124.802 740.998 null]
>> endobj
54 0 obj <<
/D [204 0 R /XYZ 124.802 426.165 null]
>> endobj
203 0 obj <<
/Font << /F32 91 0 R /F8 97 0 R /F11 157 0 R /F13 202 0 R /F14 134 0 R /F10 193 0 R /F35 138 0 R /F33 111 0 R /F31 86 0 R /F19 79 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
209 0 obj <<
/Length 2385      
/Filter /FlateDecode
>>
stream
xY[6~IƪH}:ES}`EBdDsN;7J]` HLp.0jV:H(
.ֻ7?",R}KؓlMdv:jUY#L̢"uOU/gY2{4]o#NBt@ΕV["Iv?i}^nqYDˎrzG#
^iw
'Wn"E/2:T
(a,nf7T-AGqX[}'tOU]
ڥk샷|\w;8<=oDݲgo+.dAmat?[q^fޜ)8kAXyꬸ0P~cs?JLtv=\vJ!D,&p=i,J?tvaQ7cc+j8-zH't8xʺ`jon`fOn;v<{ՎDaDIΰ"A#̅FB:|s)H+wA^#Ӄk\!X7GMM@5`-|]p<	u
diiPA`"r'A}&}yo4%a7>d4	9VCS$^p(%/4?7:~nX2XJ{O
IiRgQMDi8E6ΎD߆yޥC7fTYQ/nl9	ĉ~!0T`c?yXHHpL:k	g2wXXZL+'8XSу+06N$bf8ʳvm8
O܏22Rϵ2XЯL*J/S3	>3%1\tP@{ef2;R20nU5n䬦_sM5A;1AzLZ%_d€yEܳzuR6w*ewZ_k.W9E~qXV L)׫7\Qa_yhkW(uw5~laJw,0kw{et2EeB	8^fL	/F0`=I˃^C0ϔEucŤw]\}'Pߊ0N	($XfF.(}@i~
3(܁jj?=Ѩ	5퉠-cavU,2fp`Bh)o[~Ԫ3?ZN0
xg^$ QJ=0l,ei7#*ʏaDIvjVx)yLm%}vKfbK7YPߗ92Jc*![LD_ڦ
bVcfݳK_oˎʕ湅BWorлz.8-rnJP$Lti-/W|

ܾ0}b+~?+5ˇ9tΕ{_	%4)<+{endstream
endobj
208 0 obj <<
/Type /Page
/Contents 209 0 R
/Resources 207 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 218 0 R
>> endobj
210 0 obj <<
/D [208 0 R /XYZ 124.802 740.998 null]
>> endobj
211 0 obj <<
/D [208 0 R /XYZ 124.802 398.209 null]
>> endobj
212 0 obj <<
/D [208 0 R /XYZ 124.802 370.487 null]
>> endobj
213 0 obj <<
/D [208 0 R /XYZ 124.802 354.72 null]
>> endobj
214 0 obj <<
/D [208 0 R /XYZ 124.802 232.742 null]
>> endobj
215 0 obj <<
/D [208 0 R /XYZ 124.802 205.02 null]
>> endobj
216 0 obj <<
/D [208 0 R /XYZ 124.802 189.253 null]
>> endobj
217 0 obj <<
/D [208 0 R /XYZ 124.802 173.486 null]
>> endobj
207 0 obj <<
/Font << /F8 97 0 R /F33 111 0 R /F19 79 0 R /F35 138 0 R /F32 91 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
221 0 obj <<
/Length 2463      
/Filter /FlateDecode
>>
stream
xڽn_1aER[`l	&MY,gFJ\HJ6)XyxxJDZeR뛫?MU!
W7;GF\GmyW7XJ3?|~~n?뺵>|:(U*R1)7v%PE
w p%EF"79tl$n=ayl+D|u~"Ϥi-"jV֖=2kGDdN~ւ*@F@L<-^YQ$>UP$ &
iL6GxV5rFXw#q%.0տScͺHDbǛ!<*QQeѶ:%i_X2qdZe U$wKU6{{!}02h\}y;xI>@/Q-/mk1sa*R&qPn[o8yz{}cXp2,jw$WMP^=^ZCk#/,k=7~X'aޅDנY8'>ιqP"O4hAXe3p.u`ci,4pd^ŬqMnhWnǮG	\E5
ǪHHUH\6&^8v
Ku(xMF睮m1P/y+xo3qmI2cP.&<7ЃY:1pR¨Г#-=%hcd\B8=5-̌a*KNtULZ:[`cj)UeykAA ̭BE`cšb'߳.t>p1xI@T@Hr^dB+z^"mK[}	/u&
ܜR~;}zRL/S*/q,r~"w֛)`hϫL4ETej#Pg|,y=?k2XH#ȁlpa3S
.Tt>SVS`(bkh(sP=brN0zJ{=c=6M8>,/'SB 8pxs/U%m90HJ8p;XHE]C\A96*Z/*a&Kz;U<ۥ<I`5G_;y堺0T	4=;nh;_3@0
ۛ+FiTӁW?ī*^}wCWYÕN ws?xd!TCt{iaÅ@*yafqN&|	s$F$IAfRc]4Fo:j܄*;in*3!l)6udykr9З,E5WH9}*[jA84E+x#-.а$"g(_TPux&pUXbHL0N:X
"15&1Yxp6Q^LHǙ5+dRc{yw}2sPPD6WvV;t`n	n\ruz^nN5C_p/j~GlyvWHԡXnGatcNJES}:O)"`&ӓ4:7)ЋU-SY!
`먘wF˓i`ǕaíVG1zݵbBPy`E&$em__克\ʧƞ
§q#LGF㹠&KJ~}P}u0~u U`cm7XsgerfjxsTY>{$7|$hxT}b
E7/Qk9;cnEaV4`@|hߢBe_@4ZvO(He>9Y7oйsT@U,J/x<c܍ܵZ?oŕP,LC
c/
V?;xA=gp~$j9;c2jلj> endobj
222 0 obj <<
/D [220 0 R /XYZ 124.802 740.998 null]
>> endobj
223 0 obj <<
/D [220 0 R /XYZ 124.802 661.007 null]
>> endobj
224 0 obj <<
/D [220 0 R /XYZ 124.802 585.794 null]
>> endobj
225 0 obj <<
/D [220 0 R /XYZ 124.802 549.492 null]
>> endobj
226 0 obj <<
/D [220 0 R /XYZ 124.802 532.672 null]
>> endobj
227 0 obj <<
/D [220 0 R /XYZ 124.802 517.789 null]
>> endobj
228 0 obj <<
/D [220 0 R /XYZ 124.802 502.352 null]
>> endobj
229 0 obj <<
/D [220 0 R /XYZ 124.802 305.198 null]
>> endobj
230 0 obj <<
/D [220 0 R /XYZ 124.802 266.405 null]
>> endobj
231 0 obj <<
/D [220 0 R /XYZ 124.802 251.522 null]
>> endobj
219 0 obj <<
/Font << /F32 91 0 R /F33 111 0 R /F8 97 0 R /F11 157 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
234 0 obj <<
/Length 1948      
/Filter /FlateDecode
>>
stream
xڵXn6}W~qM4FV⮅財ݯ\HJU`uamᙙ3g!3!`ʳ,L!}Փg"(NϮV2.V».|ʏkV_},4bI_`-K ZGޫUzj U;yI>_VL;@$Snma'vpoɄv=Dt$auM0؋^*+u;n\{#cKڛYX/H98{YDQ%%kō"0sߏ(9nUeEIz,SzĽ, xXftkSs/W
hOfӎJh]&p$Hn+<{F'1~"kt]+?Y44FX
!G-ve=rR{<Js^'#e]l@$޻Q4Ib$aT?Q%NuJ
wʦlJ-~&#p+~b%zgZ.y [~/j=0\ggzmqȰs
şUkk9.$V8Lnm `\`f :xzn1qYIFE6IlhQFI Dnp+5͍ƀyu߮_Zް}aQE')<&bs;'7y.N2of+
F~3ESw*:&hT>GT61ʋb}Tu0jNΰ|Χ0(4RWLkuS䂸oQ$s\9+]qiUtPH%I
`FyB$&`qϝ#Kجf#/^q[@с+7D3iٕ(S<ٸ;fd
d3LPq.z@wsgt.S1S)b`+EtZ&&yhOEM#1QAK7=NO>
Y)ܚNucQ[lm2ĘK.bm;g(Chb-VT<}vvy_}Q1I3PIp8x9(t}BQ38~ǣOfSy֤}]
f3@r</Ǯ	(<ӅPn`'UL䋣#ina7團"9GHs1}z6<+:zCK_54agJ3"=&XdPq1ThB;^;=)?(Yv<uO{Tvgffzk[Rcdݠ5\ޱO;𷇱|H=ӅPhlZ)V[ewfbeśZPRQkE(Yw/G>s]iEʔY̸-I.-yԕ+NN͐R7OSDɤav=!pZgQP.juTU{ڳAd~9-^E6r-Fzz4"cǷ'N9cR}5s<SUb 7K)> endobj
235 0 obj <<
/D [233 0 R /XYZ 124.802 740.998 null]
>> endobj
58 0 obj <<
/D [233 0 R /XYZ 124.802 716.092 null]
>> endobj
62 0 obj <<
/D [233 0 R /XYZ 124.802 484.045 null]
>> endobj
232 0 obj <<
/Font << /F31 86 0 R /F32 91 0 R /F8 97 0 R /F33 111 0 R /F14 134 0 R /F11 157 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
238 0 obj <<
/Length 2995      
/Filter /FlateDecode
>>
stream
xڕYYsF~[Zs9p卑+֊t"!eJQ\}	*a0Ә믛‡?y!."?R%wW7&XݓjwgZS~&HDj5"TI+I*L.x+퇉TQe]4xu&Iz2UWgo
7El5Ǒy_@$J) ^Rgp	Li1j8QW-Y>^Xunl8-ʵt+p9_p'C%vZ„`gB}BJБ[I>2V"h
LoK|MM77x۶&G'*v܃wm&AE49C[>^(}l	 ^oEibo?^U.@7hwhv7F&E$MIhQwMLj\PxcoyZUx uz#_=fsFՀx4H8^xlՑqp4jJ7O}Wn68V]2	?+?c=4%34%H2%-51%-CY=.E>\(%|h`ܷYіLIy\{5l*F[6fz=7Y.sH`SU`C &@(x:狌0`.&z!	w˰}V}OXв#kĨߟulwdg‰@ʁ-кhcxX-0)H_?EkFԃB-kƜEkU~pf	!҇N,U&vumCOc;IohV+TCPt6C0zG*z6kґ-ERDJy7hWɨZY2vOuJF[]#0藻dvgvq	
{k;Vи€`]P6b3)|:t|_#Ɂjb
QE=BsnoOIh~k6%{t34CYoPukŨdj"u%5>$:؃9Kf!D2|FOBm6ʌ7"ܸYIFp}JLPcqflM	\dBm-GFsg}@%nd(ߍBϙۜL N9-^%3h}dCp$!3'	öؒjF&1cDlXrAsWv=mc#ʰ.#D"I'>ƸuH>w'о.ӼE:;fEӊ/FTqx#r$SY0Kd}rwdRLB@T- `6jOlSV=sf\D XC҈yHq\8nښ%8GM)+#C={WsrdpU[n
TSĝrFo|ѡ\rUliq@y&A9czWϨ4+_"[!,gΉtJ2zs$Д!AgW[5=)ed|ˀĵ|cKJ!0#łX~i>|Sw7gzz!X^9Ux֯tlN48+y9u	I|(co@$F
*c4K,?ryiS< J;>5g6TYo^NnYyeXZr0/#:Mq%C7>I/mNLmlW<@ۥǤrXƘS7;i'ưB#T_8!F[Ƨ̩Q?UDh'
C,L;bCLM2eYf6c@$HbͣODt3lJ;^љ3eNAΈvu*?K\np[CG?Bh$8p}D
,m+O	w%$]dok73X`\X" Yiti>BX	rA0NHNc
;
}]p"Aǧ9|glϵBbNCKfyQ	ә'Z{O$(җFkK(n
dHivώTE>KZ'D˝:sR_-X{?rĖķu,
8Bxɻ,%oPhH]7ChR_^-VQendstream
endobj
237 0 obj <<
/Type /Page
/Contents 238 0 R
/Resources 236 0 R
/MediaBox [0 0 595.276 841.89]
/Parent 218 0 R
/Annots [ 241 0 R 242 0 R 243 0 R 244 0 R 245 0 R 246 0 R ]
>> endobj
241 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 1]
/Rect [302.609 668.866 466.742 680.821]
/Subtype /Link /A << /Type /Action /S /URI /URI (http://www-lmc.imag.fr/CATHODE/) >>
>> endobj
242 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 1]
/Rect [144.285 657.187 313.648 668.312]
/Subtype /Link /A << /Type /Action /S /URI /URI (http://www-lmc.imag.fr/CATHODE2/) >>
>> endobj
243 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [338.722 527.894 345.696 536.307]
/Subtype /Link
/A << /S /GoTo /D (cite.Hearn-manual) >>
>> endobj
244 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 1]
/Rect [144.285 358.308 386.873 369.433]
/Subtype /Link /A << /Type /Action /S /URI /URI (http://www.loria.fr/~zimmerma/ComputerAlgebra/) >>
>> endobj
245 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 0]
/Rect [199.079 272.851 206.053 281.264]
/Subtype /Link
/A << /S /GoTo /D (cite.Hearn-manual) >>
>> endobj
246 0 obj <<
/Type /Annot
/Border [0 0 1] /H /I /C [0 1 1]
/Rect [144.285 171.011 402.564 182.136]
/Subtype /Link /A << /Type /Action /S /URI /URI (http://centaur.maths.qmw.ac.uk/Papers/Marseilles/) >>
>> endobj
239 0 obj <<
/D [237 0 R /XYZ 124.802 740.998 null]
>> endobj
240 0 obj <<
/D [237 0 R /XYZ 124.802 696.263 null]
>> endobj
142 0 obj <<
/D [237 0 R /XYZ 124.802 700.248 null]
>> endobj
116 0 obj <<
/D [237 0 R /XYZ 124.802 654.199 null]
>> endobj
118 0 obj <<
/D [237 0 R /XYZ 124.802 610.086 null]
>> endobj
117 0 obj <<
/D [237 0 R /XYZ 124.802 566.251 null]
>> endobj
147 0 obj <<
/D [237 0 R /XYZ 124.802 522.415 null]
>> endobj
148 0 obj <<
/D [237 0 R /XYZ 124.802 478.579 null]
>> endobj
143 0 obj <<
/D [237 0 R /XYZ 124.802 446.699 null]
>> endobj
149 0 obj <<
/D [237 0 R /XYZ 124.802 355.319 null]
>> endobj
150 0 obj <<
/D [237 0 R /XYZ 124.802 323.162 null]
>> endobj
144 0 obj <<
/D [237 0 R /XYZ 124.802 267.371 null]
>> endobj
145 0 obj <<
/D [237 0 R /XYZ 124.802 223.536 null]
>> endobj
146 0 obj <<
/D [237 0 R /XYZ 124.802 168.022 null]
>> endobj
236 0 obj <<
/Font << /F31 86 0 R /F8 97 0 R /F33 111 0 R /F35 138 0 R /F32 91 0 R /F7 199 0 R /F19 79 0 R >>
/ProcSet [ /PDF /Text ]
>> endobj
201 0 obj <<
/Length1 785
/Length2 673
/Length3 532
/Length 1237      
/Filter /FlateDecode
>>
stream
x}PeCʗEsJx@v/Vc CSPIeɽcoRQAw7G9WˢSVTLkt+J'yG.jLy`S~Wo7x9svniŭZV޹x{~9;ş,7kf7t`kꈞsnbvTYktؓ|{-͖בa:^Ӵ
:q$XЩv±Be5)Gطj&tLU_^֪lVVuKl40 aX;|牍e&*ڷ`/M'B"[\hoXVoGE;ȁxdMٵYlsxxOs=ݳ
a@DB	Ko=endstream
endobj
202 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 247 0 R
/FirstChar 0
/LastChar 48
/Widths 248 0 R
/BaseFont /XTDBIU+CMSY7
/FontDescriptor 200 0 R
>> endobj
200 0 obj <<
/Ascent 750
/CapHeight 683
/Descent -194
/FontName /XTDBIU+CMSY7
/ItalicAngle -14
/StemV 93
/XHeight 431
/FontBBox [-15 -951 1252 782]
/Flags 4
/CharSet (/minus/prime)
/FontFile 201 0 R
>> endobj
248 0 obj
[893 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 329 ]
endobj
247 0 obj <<
/Type /Encoding
/Differences [ 0 /minus 1/.notdef 48/prime 49/.notdef]
>> endobj
198 0 obj <<
/Length1 804
/Length2 1483
/Length3 532
/Length 2073      
/Filter /FlateDecode
>>
stream
xRiTi춊)@dQB. (K@6BR$&(, dePAQPhQPdžMQ`̯9S}1c5@Kq68{`QffNb)ؙ)(R.8-CNP!r@1f€S
l&؁!P(|>5;
xXrlP8r!C+͑
d8Ti
P9W0qGgJ'
S?Ӥ|;S0+OU+YGBn?_H*J0s JA4Hr1œM(cq9S<\`B]twو!9bqFkGQa6`:IS,f*PʽP""@0\c# QI0B4tJ1`$D09_vtDv5^9{}`H$Je,֎5T,a܎) e (٨{C4/JLA85A#j{Eͣ*ͨ"rɢLjKP(9c,ufnWBQ:7$z\k{m)~08}VV<嘔>ڗk][DXF]¨r&aΘMu@\zȩǺV{7qM.CETkcFM-FKm;\C/&B(˒/'\r{Ds7:]h2Gftj/ȋO#/wا	+A`95r3H/V%׌ܾinڱckm#>rxp]Kcƍȗ0KNWD\*}`p:\ך5gs+ӡjszKB꞊kh'֖^rINCX:OR}a$0,<8z<3CQ*1uI+ǻJ:6x} gRym8HGB9X(okw"?k(|1KDڕ-\scov94zR߆zdZ+3Z[~=n⎅ec?MުVnY12epsibF6uwݍP^i!Kz̳{xF"+Oj,\{gڬnP2."eY4>5ߓ9	Zc8b\,Vr_r%5d|Oa
i7[R;Z8Y@Zfjr>m~K7nq`L$wթMyc"#zl4N*%lO70Tu.E縑8L	M7*;-3j|~E=,Z:jz-խho]SzkI[SE$XFVs~U?ba՞[³ϹPjD^zގ[ZX%wjHzpa&W٠eѳAکifGɨ1~Eꑮk"WRV;؎ΤXd3|FT+)2~тT(nРq'bARGeX{nj`EeEmGUUcii3_|K״;CP[Sn
XdCos.@ifsxn.lMFɴycB
?|P`AX?~Gendstream
endobj
199 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 249 0 R
/FirstChar 43
/LastChar 65
/Widths 250 0 R
/BaseFont /CFDAOR+CMR7
/FontDescriptor 197 0 R
>> endobj
197 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /CFDAOR+CMR7
/ItalicAngle 0
/StemV 79
/XHeight 431
/FontBBox [-27 -250 1122 750]
/Flags 4
/CharSet (/plus/one/two/A)
/FontFile 198 0 R
>> endobj
250 0 obj
[877 0 0 0 0 0 569 569 0 0 0 0 0 0 0 0 0 0 0 0 0 0 843 ]
endobj
249 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 43/plus 44/.notdef 49/one/two 51/.notdef 65/A 66/.notdef]
>> endobj
195 0 obj <<
/Length1 778
/Length2 1214
/Length3 532
/Length 1787      
/Filter /FlateDecode
>>
stream
xRiXSW"*HR 	$mZvKBr.	a(XAa d"kM L+R@a.lIt>AlxQ ``eC@da`n`,Łp yB n:rC(@{Aq 6M$E`7^[[Bf7~,
GB^(Đ 5/	[Q7tme@	 $`G\J jNjFEJkj<JBIxdwc[rF(Bx%`aKD RT*D &`h|	GpQy["fSZSIQJߟMH2sKI"Q[kj3(F9b$Fe1DwBx 	c(>eUr\և1"=rӺc?oIȩ^Z.Jl~Q%_?Wlr*Ae~W]K;OɴjnMfY5Jc*OQ&""TY-y'{nѵbhƜx,%ś0`ZNfD5zqs¾>S^qfM-zoIJWnlxn6N{ɻ%_S{2^`Q@ЈoznN|~E^vg~yU}4%V_
IbJ|o	1w_l~6qlLx	qȠjuZQze̲NiWoZHVoIu{υCì̮'|JF:kؓu6
=AZ}~]XZQE	(Ovx?~ll#qțW4q9j@.-|TZ/hz̉3`}IvQczAm>ӸRNMݽ:S1%_KHs*E?ucywk22Glϟ
0Z5yM)_.9R7o
\sY!3ܧH*i{Iem'oJ澥Z÷p%xr	ygl>[G5W/byTtV25{v
0lUHA}՞=*p„4|w+UXm?)͞swC
,LYا7endstream
endobj
196 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 251 0 R
/FirstChar 49
/LastChar 50
/Widths 252 0 R
/BaseFont /LHYOBK+CMR5
/FontDescriptor 194 0 R
>> endobj
194 0 obj <<
/Ascent 694
/CapHeight 680
/Descent -194
/FontName /LHYOBK+CMR5
/ItalicAngle 0
/StemV 89
/XHeight 431
/FontBBox [-341 -250 1304 965]
/Flags 4
/CharSet (/one/two)
/FontFile 195 0 R
>> endobj
252 0 obj
[681 681 ]
endobj
251 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 49/one/two 51/.notdef]
>> endobj
192 0 obj <<
/Length1 853
/Length2 2411
/Length3 532
/Length 3023      
/Filter /FlateDecode
>>
stream
xRi<$CTS)flee	Jc`fCc;He7Y+[*K/!WY+KM;ΤOwp_u_~3Ky<	4oFYIߝֱ;s=3,D/&F¬(P@ ,"k;]H82@rQhK`!"
"	2W #+`L*k0pO
!5B"~AEVi@^rTA*(DӬIo_P@!TUT78_
$Q7_$+?5'80Z]r,hG, icTUtRc[p'D)Sh	h̰^-:Nom'ވxU{xiL9׸xrk\φއxMK9Mo|>9<.r*)>E8_E	3?Ibr|r@B	IThZ%oy=[ނ*/@cpLL^|2}h̚qUஹ[2A>&atӽfuj++foZsZz_vt$f)3Yy4;"׽X;""c	\h3M+n"*d0m;$ ݓW8D05cW
gE[L3~qlICvs^VOh!LZcÍ\}:*|reVjRBjALLJ.hGcz.s܉|^;uk&û;9
;$4d&J^ήVKX}}#?Od
-bhmsKm6Ce&/Zƥazs}vыRh{
hi@/kg&Ǧtu

o?ez)U|C#~mNz^mP_OKψzm=K{xP.\+rrC7<㏵3l xƜŜ'^t
3e侅,3m@g`qPDQÀfTeeU9'53"23͝rWqԿ8J@]d~xkY_{p:fQ~u뙓{K=DJe1lC
LX{QB\
y1Hl8ePԪt3qك:vOHO02hF
hvd>xwEV'&9x7%s^Ix*z->ri$ؙC]Ln͑U#iAvl٪Ldž{=gEo6(R״Eoʄ
\7:3NB3itDLLqTH}[y¢,N}#_1ИpBYXa't'rz#.vlTX$9CQfj\92<"S03iϨUmO魰%|"Im*̊DxZASL(FXtz
SNW.%x,?[|ٷ:aq; E:s{$<:Li^yoR*%MT>]/;qq`aG⨡Y@t\Κ>Vˎ|iFŽYώg:t{3pJU[/*wNw5!_u?"~a->~0_i5Dd}7hi'%6qNlY]JnR9np*#Ɣ)ZYSjD,bشhji1	qC''egkA|vTVyn!ʇun~L~͇jӶ+h+|6=#"A/4pw@dެnqPDg?0̵L&%V-}b/t	9ؙҼ2ݾvh5L9Xm'dLTrAiܳ3x^
2y{x'uMn-!`$Ȗٍꥅ>ekn44Gyhu_Fji0!ֳ6oI
GyN3
Zio:M4ۤm>|:.Z°c6Vuѩ_Zݒ1ci]$1l٢}2 D&|"Iv~O> endobj
191 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /VUAXRX+CMMI7
/ItalicAngle -14
/StemV 81
/XHeight 431
/FontBBox [0 -250 1171 750]
/Flags 4
/CharSet (/a/b/c/n/p/x/y)
/FontFile 192 0 R
>> endobj
254 0 obj
[620 502 511 0 0 0 0 0 0 0 0 0 0 706 0 589 0 0 0 0 0 0 0 648 579 ]
endobj
253 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 97/a/b/c 100/.notdef 110/n 111/.notdef 112/p 113/.notdef 120/x/y 122/.notdef]
>> endobj
156 0 obj <<
/Length1 1030
/Length2 4500
/Length3 532
/Length 5208      
/Filter /FlateDecode
>>
stream
xy8QdY"*`0dgdkØKI%zZ]%-KHv}+Y*{~=}z>{y-S'آPG{hOc8@"oȝ0"{SHC[?Ǒп4F&,91yς`˿<_oHvJM
u#7$%ȕ=d^?QU#&)I}H20O4coDVFRKs'xү/<#1K+4m0`'X㯑1K-ƛ\$/:%6L7B:aXu
wo<.ݴ[Eՙ,|ik_=/Ceҹ#N挾;3hO1o4	_@?ƹ'?0%#StO$)|{bf{OϏ=_CJ&gtt7
N
jK26Mc)hD7ltQ7.cs.PV|عgǑ܍v>\TOY}]>r]vq	e+7EK:b-5<)[+O%n!,lFE;_P凞B 2.UU9AgXT,AϘ5z_6<9g?'wTgIx9Z|HGvDN׀l~YGD{#_1Dm8}|.xz"շJU&	|n&ۈ͕DB၏D5LǠbaۣR­gܮ	A{cU=ܤɮ,|~}&EAFsb#\4rP:%]}S 4աj̅vA^~/H0/)Kᑂ8
ɓ	\_φd^F+}Hӿv0.{=wVR{lĸ~C}7!Ûj#XKbM[&^K4:wt׷Ǩ,$9qe:Y,/W-1{tni8s5sLjX)"5?n=ɀ$B/LK1V)4o8{:?-u|m].[v
ݖ>kU4hA4uxsRgeזt1Gyc*ytK!xʕ	]eʞ?_H<`u`*q/nVܛK2J0Vxr/5 ֶ΢Hcù6
RR|yu"VpG5܆pziNEm	ˈSWΪPyWwmV~FϢEY|Qmw.")-ˇzn]zUnSȃ	hVLhshˋ2m
n>5RW:ĦO8<dQMK''zz")˳\OjH9ZX0y<`=McՄ
R%+Ntƭ5f`b4(|AnFY{lN@iVN |A#C[hY6LOݦQa$bV@f,z_ƃ0X(|0J!B]>)iڟ8AEt):l)T('r\l\A>,D<|CBg&!29_]_ocAO>Fr;_=Ih̲NPgG#rZ٥YY5$@7aV\mWiO=ZT9%^!Uh^/FbRmb#bCcrn:"jԔ90tTggG'.rePhp:,L Y8Q_Pc"7vhY~hm[ Jy_f6TK3
xp衄&"-1˾QzyLlo+q:JkR=	3{%VJ:)b0GӖI'ҏ.7t%҉|$.]l'h<#.~@NEGR(R-|(yy\h"{Тs#lg"2v߆2szKYAONWMO~*?滁Qf蕛"cwAlxM뽕Gu4li]?h9._:5žNZzX۝U#pݫ|nWA|Vސ``Gt1!%{5ꎏϦ8(kN
bŘ}\86N(%c!> ^v⧍}3ӛ
c|cl3vnڄYN;$nm6쪙?4y@	֬)f{Vp5x&U=mQj
L-=P5v\5=~3.,wg^]86~zJKb!@~=M{j.Szp䳭*o#,Nqᔓ`BdtvS
E<,
NPz%B澲آvcoJc#A[iP]B‘uQދbL7>0x%r8iT*}I߈m]+o	_̩ҧGFTp[-o3YL+MoykN#cW\;6wD#_\RAsƅ*"L	8;6mgɶVR-y8
*RydVNTp|ƙtc6}!m%o{Rv
G}A uhJ|S|7-$j@jxMay5q#zsh׸,}I{{M:dFL{"(<;DBB	H53.fmVu55;IGc}Os'ww9U
:p3yX{Vng)J?.==_dfK#UyW2zT
MJ ȓ'83kl"{	@ƥ4} l]jWQc9Lv&0Pʻ87ŶS/Va+}C4#GI3<\BYog{$g2#6'n+6F/a\'=BF '1;A֗븹-)yF}q-$),/BT3K)uP"Km	qKWqd,ړo{P挩K2g88h>X9Eg=|e|`>Xu#JuH6̘8M%c
w0znG?")\Ov˜ Z+
痊RRXjY6܉"Kl/_OMZ-*?tԙo0F)e!N1y
(|N^(է!lh/bʻ輑%	KCܰqԻ5ks_
z¤Rs,iO>oBNNBZ>.?|t-wl1KzYc=Ǥy
俋|gXҡJL#8IۚJ񞌺Ldfp20Y:6cj}ezJ]jx$tun8;	)BQ
ɏKPb%k*}5:	eNx⁡<(8$T+qؐ%^BDAm{LJ.cL{B\'+ZҜ(A$PPpWvFw92BmYh@䪑gZ&ǨîtP^DdxBY_grsܸMG>}L--%KJ׮irCW|zRg1vmG!bW&&gLYgų_6Í4e%tk+
.qz7*o87ͅ\}tJ0GH&EgLF_^dZK䩬Q_Jg3
o[7mP%MDu.΍Mj9UoɘZ{7U&CEj{^pw%LG다{XT:=S\bU啺O|4tq]K5[3fYJ~~k`}X-Sѻ&|<2~91rd|IREcsI0-g9InoO mu?Hvap7!#b6ŠA=r&aV-C׿lZ4PYyM<;gGs#gޠfs6UW&g*Ub_wVj),co!¦;^uݻG:ܣ|a'
("":33fendstream
endobj
157 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 255 0 R
/FirstChar 59
/LastChar 121
/Widths 256 0 R
/BaseFont /TKYDZQ+CMMI10
/FontDescriptor 155 0 R
>> endobj
155 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /TKYDZQ+CMMI10
/ItalicAngle -14
/StemV 72
/XHeight 431
/FontBBox [-32 -250 1048 750]
/Flags 4
/CharSet (/comma/slash/greater/F/G/P/Q/a/b/c/d/f/g/k/p/v/x/y)
/FontFile 156 0 R
>> endobj
256 0 obj
[278 0 500 778 0 0 0 0 0 0 0 643 786 0 0 0 0 0 0 0 0 642 791 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 529 429 433 520 0 490 477 0 0 0 521 0 0 0 0 503 0 0 0 0 0 485 0 572 490 ]
endobj
255 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 59/comma 60/.notdef 61/slash/greater 63/.notdef 70/F/G 72/.notdef 80/P/Q 82/.notdef 97/a/b/c/d 101/.notdef 102/f/g 104/.notdef 107/k 108/.notdef 112/p 113/.notdef 118/v 119/.notdef 120/x/y 122/.notdef]
>> endobj
140 0 obj <<
/Length1 901
/Length2 2355
/Length3 532
/Length 2981      
/Filter /FlateDecode
>>
stream
xi<m+Y솲}˚Œƌ3"[vȾByʚ,I%gS=Wsw>WstV3Ƒ}ADSC@HP8DIɔ
bh2CBOB@ 5uZL`J4@TH0,ah`!d,Cc"8Dp 
A K|A<}dE#:8zV(H
a!UfDDpfOfd&oE'1A_쿍 1rP0R;2~ف8=׮
C$`Ix"!4pouB	4?@e5sz_cػY:~׮#@+#~2sJTBpL!IX2@ZJńC7IZ@ p`1à$2y`N&
#S!_֪/o=F&?X[$f02>ğȼq0_
>KrXSh3hiG̕DA+3@0c}bT*H}-}g?s b!#d~B@~Shj=U	xPr\_xʬ
%
jm`8?I&ȇΰ'BDU.9sƾ<潋Q] |Lp
9m:˧/?^))AJ&2? WG/2~;V!yT}l09_^Z Qɓ!N:dJ}wVT[!M bF!zN mzՀzG )KlÎ8]y|k
z;m''k5pvaٱ+ed\gyG4K܍R΁UE#(ڒl4s\*4vW	Db''!kvIBNdZ=d8BW98ZM*v^	BD#mGŠ}&jv%KdM_
Xgie*-Z{gG/	n'u"&ŢƮ)YQ}UΓOAr2ǜэlJNԿ_gDc,Lu%z <H3ذDў>qՕe>
ú1N[Cƛ\Oq
CWyg`F
uS)J9Qlf]dAp/TpkNRJ歝!`jb̳l
صlTi/zҴ
T>{)L;7
&Yl	МP46R?floŁyň+~|FE	k+:*OYe>k2"w_thχ2>ČLm_<ԀI`t-VSl#rNG_Gۜ
)U\ԔjD/w+mC`,c>8c9Wg['Pv)lěT="-G:Axz#d Cc=uk5%K{-(͘53@%6~kZRG3=]QdSc9g+^E4|$&Bێ> p,V>^UZp#{Kɍ!6B[9n(
aE5[{^)צkIȖIZ|,x3uS+UkW}gǎz=zܼ£3cUuqsmK	P[*栣G<<
ٸy]tVu&(ѲwzY1qK_'	$2 MCEgubo6ܲj`^LΊ|{o.r=@_$;\dbv/#Kt.z[5JAez{:Tmѫh.\!I;r-W"sqZ> endobj
139 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName /QYNVHQ+CMITT10
/ItalicAngle -14
/StemV 69
/XHeight 431
/FontBBox [11 -233 669 696]
/Flags 4
/CharSet (/plus/one/D/E/O/S/e/l/o/v)
/FontFile 140 0 R
>> endobj
258 0 obj
[525 0 0 0 0 0 525 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 525 525 0 0 0 0 0 0 0 0 0 525 0 0 0 525 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 525 0 0 0 0 0 0 525 0 0 525 0 0 0 0 0 0 525 ]
endobj
257 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 43/plus 44/.notdef 49/one 50/.notdef 68/D/E 70/.notdef 79/O 80/.notdef 83/S 84/.notdef 101/e 102/.notdef 108/l 109/.notdef 111/o 112/.notdef 118/v 119/.notdef]
>> endobj
137 0 obj <<
/Length1 1561
/Length2 11685
/Length3 532
/Length 12607     
/Filter /FlateDecode
>>
stream
xeX[ڧqw-wŽ;Cqw-^\w(mrＧ3g>5I>Yk?{-:9(
r3$5d,ll(oJ8M I0PB nv	@'AI1{@l03̬`@_gԀ.@g79
;;0ZZ;I] R4Ishª!.7R۸wt sN"?Ge&vfbv@3;խ]݁*`3+:?M UL@۟0,;@
쐉G0qv6@| 
bX;@w1+9Y_
zVj '?YV\\V3ɟ
7
`u2S9ܐ43
'$$rfHW"`u+EA%dG`C7?` ( 
 Jo⃤!H!H\i 7=⇤!Hٿ
oBBt,B_!F!D/X
?-XB/h8
B4\BȾB_r!V Dlqq3;'_<~~u+PVO
yl7[XC4@;eqd&lZ+?QOBZ<R*r*34$.J>d5^'jRg
Y@ǣMSG<3;7[vlb<[^s뀯V8`#:	+{]_DjNbݪXZ,$O}Y$Y]FOVM~BfwEaOXZSI26[\ԋEf3eCy#u>TQ`8pbb7k}B\~F(AGObX}w13%Nu3\ਙܟRZ1,ݟ\7#&"h$hvt.fI+~1ۃ͢9/"EX}%-lHxW/$fJ7>{,م!'0DJnm⋲tAu0l8x4ТтMJ}œϵ'+
Q.աO3Ptp0(?Ԃi~ke*rڣGgLVXTp
Za?P6\8Cc=*XQFuFsݟLm\*7复ūAL)7=avΐTQmz I_q!іV?
OxXŘهm*:)
x^PHV
hӕćC*3ϤGb8v-H	c4YD}2ʅӌܪQ_p7Θpg_Pp2,뫡]Q;5GBcin+'x(&b,9:|4ofS[/zGhq5%;q1Pٚ.yMʔJ)0zjY_?IK^kG:n#_NFRu[(q=,JWe\jZp@M8+-ƖL&K:+<tI趰Kv(5JAƾ\k.үa'G0rBN۴7B@yS	$RK/䠦fmw}xZngS\ZiCC-
in*TrҞ#+Ft0jRb^A0hC\pjlI%ƗF~g{YSyh6.-ˬ˻bвJόtOz|*9+0܁?#"-Ɣlm\C7}Ж!"	;WX0q&@u9mSL@9YQ&&-cF|idB&i#!qͭ{~\v
fR݋Ѝ8#t*RrٞuOOֶȋFf4X,hӟya	P>nZ|#Z,QMrp9g8dSN<}Ԥ}xiG35._!8
p-b_.[O`2xWؒDMBgv-N+,1]9B%x-(N[VDDeڨyteLl	Ѣ~bM	W1|+=Tw,ːvzPz!
#"'#4U7&wh`i7u
l^Q( 89"@-&YD>Gd/a~G""ÎΰzVe"}q3rL(Rh1Qq]Ю|wYp/vݪ13@ڱ^$0EF'vJ|9VY@`J~%voXq+XQobq{8&5_1UD%>~Ƈ$#1q3Fj.>ـOvPơ_Dφ^XdpJw{ŒɅ_ҡ0(*?դaDwWCm7_jQA{Дؗ"GץV3y^:>WpBU	SZ?	$F[hݮfiY^3H‡s˂%Նڛٺ
o}Pb
EBRhPXpq"ӕ+a
1fnBT+^Z'(/]V>	xIuە\HIHgxn#gy݇!KQ=528T/e1,x|2!cтF˳.NDrbBٙ~
ܠ-Ll1G7OلYy0VF$gT2Wl4[35%(^{3Iz7Ĩԧi]EKaTpֶ)v~}t1&Coհ3t7>]^ͷbvL3j=Zոն <-9<|CңDŕl9P,hVm`ASr>M"\huu#Oꕪݵuc#}s!Apz:wm/?9~r=7 #v6baƔEdaK&I7bǁq\6Sv<-}KBڟhe)ڒ1QɿZG}S.8_9y]]?I&o%B S(Lq-䫤@$R'V"MV$]KG30ys֗$HPsCP\ʖ-!mOS/Gꮦ*ڧ5%*雝fG3YIr@m6Y>9VKoQp&Utֶy]#ZO0Ռs?悜Hvl7ډ#[STJZґhp3+R
4Oxhj70IuKVqNsUգ,x_8"@QDcDtvVx]3bi J	89Ww% =M`wʳ-	ϒS3{t{TPG	ówE<"~4M3N.9ݚ뀋Gm(gw]?iU3!	ڢ/ߜT:~Tnhg%Շ
Q
Ѵe1}`|ܤUIcIFx+V1艾@i?\*HZFn N,#ldN
*h:n/O.Oeբ̗_(ɦ~St^ ڄ&\YN0zyutooL5*+Ktu4OJ%5FHLkjkLWM\X?r=XMg#<%_:O<|{WQ'@'t@>Zv
6	g{hfGGm^.
z[;XCL|'$ŮԲ6|HE
gn>-3(bܘ4oQXxP_$v[`NzL),yֳ60/jO^E+%>
=7yGE4#4HrT$KGLW>T7|O:gb3p\S6pt,tTaWcRC~ߡi!Q*95EHDjb#$+SIգNku|Yüa3m4P=ea9taV0QT~oކ!i2tw\`Ӧir*+1".q.:/{OQ,E~k3 &Ɛ vIQ~Y9þ	8kEb3qH%G,8+|gz7F/i8]g"B~^idF/z_wHڞC,(^{-ZV:X"$zK kTFՠj-@4EdYfG7R FT[LB	d}tyR
\hBI\ނ>tސK«|*G'jʞI7iQWX>vjDL9#4.
__jW,alAv.(-vwIqX+w-&[%zF*a? "tkLN5w`0*
6#[0N5.Q_+|A8QڭzilĈ3fX+S%ao-HP7cCv215*d%{-kro؂P	i.CBiQێju+bU6LyGSVμ(3/J
*:Lq$e6z۾cX$LȽ"`>:抈 7йiiْQFt@0=9w/Sg+F]grfo5ǝj%7piƝ=BTɞ6-7^5D?´)㽬h7ÅT8~iHpxY#}1Dŕk@<#Ode\a@VG^AMm{>fmӌ_@;A(;)8:-|cl>E~'E`'7WO򲁂۰TN.jwLc.⠕0&7r_0#}	`g6#-}>ڴXHe@&8kn
53pQ
pYJk=\rA1z\[(PKuh6x(UGKTh``
pV[ܷb͜<|#%iK6̲fzHxu.2/(#+S?-DƝ4ҳVBlTA,=#d/z`E^UA$4YxF`_DO+2zTc}Y<'H8{dN[A,iʽT
?M2q/ol1H`xVki/pՒ*)5Րi!Gv[6$
W~\YYǫ\czNth\SJ]rq採(寮t/Q\1$+3َ04O푊gfUќ~Ns|/@𝠠]+b&=7_#H?٩@G9/vHO\\sqNUUT%i/-M[Ln%kB#0%_.AܐBj8ZݪhsPvפDz8Opo;N>3wHSWHרS':EvF&Ž_B(o?e;fR5_$^.=|%Ͻre,(Vؖ1=.bDy~)Z}kx}36F"	㭔=o
f٨(a?#APWba٩Wִq>>4(6{X/(juI̅qGE"Kq]r1$E@xa<	^ -Xg>R&{	*	9#|xͯPJ{Y)r)̎/C	vZjz@/ͻQY]zzֵTvO"`gmkBK=,F\b		ft#ʔHwD &|k4Mt>)+сO
PtK[Y̘;+:4ZF6Bnʋ$y&/vrFu!B!?XTRĊ7_Vdٷ P%#R&gLѱ$ks5U0}H>g'{rEc`:$'iH#cN$
XEBD]}uzćoLܢ^ۑ\f	OQfc#.7O.@p~T~nghJn\p([ȻB%hO0' yqlx'|XCͱ)O\!˿;QFڜONog3=tTd}g D⬯po&owH/+zTIT@no;E"$LW"^ʔP堵|f qu,rB6R#:"ǔw9_U|GD&e'֍;ɱv	a}P$ibB,7u"ц|}aѽ>vVȸ)uJ#Axg=^M)a[B5o_c-A8Fo''^_
m&+"-˾.jyOx.CsGə;DTLcHO
j-yz&vw$ݖ^6*9U 
k;+Ժ)EIz`[-HȾ/KL,;94]e۳yq?Qƒ @I|oX/kH̋.}Iʝu%0jc{p[>{+Eۚ9/]m*ևHo)oKL,!ib̔ek(eoL(eWB9_DW߷IR_UyڝhݧkInR;$Zg,n`rǩVT
Fܛ3gW=4$2t=T*1\ךvr 'zW'f芮c13BDM:zYRUt!떭9Mڽ,6/M
$f_>Wф4<;AgLO!%e?*2FEz6k?uRvI^O.QL!wRtuvx?[o/udrkk˶)wLq_Y0
tmnEtUu`{kEo}9	'.$4}u-vްfbk|<Lɹmټ\Η	'o6=g,35Ɖ%x]9A\;	߸):J̼iޫ9Lx/>/xЉMI]9Jtd<(#ބНu"	[j|ᦱicYrrL~DkW []5ɐkXh8lWeLj^pe(nۜ	+C䙞1#׍ Bt
`!_L7,IeOWxu'3k,NoB'\v>$|'wF᠑r9rxJǘ
~cK^aa'[lvU	F&#L5*oa!֙E\H)wNZ=[pp.ɮj˟
M
ŻwrI
 &'Zx38,a}[o>VU|6M#HȆjIkֈq7Z7jS0${IYXw=?9D/,D^̆/ߑpT[Tܲ&E=Y)c\ZySIwZNIܑa
ZԺ"jK!(zED*.@GͿ_]PS{=8joO`Uݛ_|8Ծ/HJk|wާ(oîdN&AGK9
8Y2Cѓ^~s/o	XJT)҂yWowsl1e6wX>	*r&v?T^(>`A2i4B?ݓAOW&3a =SMg*rA|@r/=]|Z+)=֋3]IĿ2E(ճT?p΂﫥dp|gdrR(q%榅S~*`ŝɒH-9m2F
6S?'r%..Jy`S!'Or
BtUvҒE!hCno1PX2~Mv%l\PzJ_hU#|v~O3-bl3wz#EQ߼SŬQ8쌄
E@'*6d>eb}!鳮74_j2Dp1Y7P5x++ӨI%T ~Th'-ޟ6&|Beu99^FȖ1L뇈3$fvr݋m{(R°"O7n׃Y`NEVPc	Yu[O"1<oD3;3dol?Lendstream
endobj
138 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 259 0 R
/FirstChar 11
/LastChar 121
/Widths 260 0 R
/BaseFont /DLQSBW+CMTI10
/FontDescriptor 136 0 R
>> endobj
136 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /DLQSBW+CMTI10
/ItalicAngle -14
/StemV 68
/XHeight 431
/FontBBox [-163 -250 1146 969]
/Flags 4
/CharSet (/ff/quoteright/comma/hyphen/period/one/three/five/six/eight/nine/A/C/D/E/F/G/H/I/J/L/M/N/O/P/R/S/T/U/W/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/y)
/FontFile 137 0 R
>> endobj
260 0 obj
[613 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 307 0 0 0 0 307 358 307 0 0 511 0 511 0 511 511 0 511 511 0 0 0 0 0 0 0 743 0 716 755 678 653 774 743 386 525 0 627 897 743 767 678 0 729 562 716 743 0 999 0 0 0 0 0 0 0 0 0 511 460 460 511 460 307 460 511 307 0 460 256 818 562 511 511 460 422 409 332 537 460 664 0 486 ]
endobj
259 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 11/ff 12/.notdef 39/quoteright 40/.notdef 44/comma/hyphen/period 47/.notdef 49/one 50/.notdef 51/three 52/.notdef 53/five/six 55/.notdef 56/eight/nine 58/.notdef 65/A 66/.notdef 67/C/D/E/F/G/H/I/J 75/.notdef 76/L/M/N/O/P 81/.notdef 82/R/S/T/U 86/.notdef 87/W 88/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w 120/.notdef 121/y 122/.notdef]
>> endobj
133 0 obj <<
/Length1 880
/Length2 1365
/Length3 532
/Length 1988      
/Filter /FlateDecode
>>
stream
xRyteXLGcZN d-ʵ%ZXMfjiB4u[4(	=[<	q'HbL0P&BgNw,">/œf9p(@A?Z`3a&"rBƓQ.s05W.pٔ҇Nw$<	e<\69'vaҸ0Mdٷ§#"~YZ5Br{8n6>٦+p!A0@=[XJ3DcjaOdbskmZ!%GnVߺJ7*1tNW%wS-[z3'z!su넺Ph㞄pci掑ur+@:l':7M%2AͰiM_E[].}
XXCVz;unIyKgTE^fw
E	+mdYYY|sZzuYӡrip|:7ωT4Pe"'U[ʶ}|[QJ1sY nH;'KAȰQn:JbcE~szui*"+U\"a5w5tqw9\)*ĝk;>(4褘Rh۪jo.Jooov.]¾s'M9(ˎPC^&LB7Z'\r}сkåGU!
zt@'/
Z
V>oNVZ$jIŞ45kOW25/l@}bP_?]Vw)w"ץtZkY:]5cSx;B:y޵"*|7WpmWS7*^z[AI(Ghٽ7.W옮3KT?=VQMo[2OٳX7e{[)TOFөb[=#_*[q4V!yU?TAP>0՚vPNK`kkEM4,΂keWE>[ՑyM]yz.TnZ[+~r#Q*LRUS47
ّ̑V!#7\ݦ:_3ؿ]x,(ȭxH@naLC>QrI.oqSbSi+Lf?酋oS2Q64lPq~kף4E"&n	~Ҩq0uYOKC</tendstream
endobj
134 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 261 0 R
/FirstChar 0
/LastChar 120
/Widths 262 0 R
/BaseFont /MFTNCH+CMSY10
/FontDescriptor 132 0 R
>> endobj
132 0 obj <<
/Ascent 750
/CapHeight 683
/Descent -194
/FontName /MFTNCH+CMSY10
/ItalicAngle -14
/StemV 85
/XHeight 431
/FontBBox [-29 -960 1116 775]
/Flags 4
/CharSet (/minus/bullet/arrowright/braceleft/braceright/section)
/FontFile 133 0 R
>> endobj
262 0 obj
[778 0 0 0 0 0 0 0 0 0 0 0 0 0 0 500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 500 500 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 444 ]
endobj
261 0 obj <<
/Type /Encoding
/Differences [ 0 /minus 1/.notdef 15/bullet 16/.notdef 33/arrowright 34/.notdef 102/braceleft/braceright 104/.notdef 120/section 121/.notdef]
>> endobj
110 0 obj <<
/Length1 1793
/Length2 10633
/Length3 532
/Length 11675     
/Filter /FlateDecode
>>
stream
xUXڦqww !hkw@!$wBpwwkd99kުt8e-JNPN^.^1>/GI,@1(@	~0."$a#phZ@퀎5,=g+=!@k.^^5

ڂ0rRuq+vw! 
&`[vv{6Zΰj@
^\ֲpk;[8B@O5KNh
rwQUd%dxܔ@^@kN܊:Կu,@NP}oVka큀<&¾7*dl
r	
, o rz^0an.'g('g_;
-	]ݝ@kKPm[@x.h;-`rsŠ~VΎAwSq-l;p-~'"n w 
vvÂ0{qA7c_2`ߕakA
[nLZ7|~LU7j(&0l]kouN7&X=`~?$oMzz	M(;Aܬ!ܿQV7
[C<_
a&6 L0pa?®(pa. Li@@raV 7@aV+I^>y)ya#[iAA`9{r
8avPxs';PUvxxDN!K{^@+g+0/Jl&hvLbν
Լ+ Aޡ|t{|X45!mq|'çEC/SG+
zϾ(.u{uf		RyO9J r/9iy44>}ܹŝ.-75ܭJL\Q{NreXS
\mQ;7efEgzET|υuNo
tKa>
1Q7cR%l]C1ůexn*<|/I3Fu>O#4x_IS@!_mk]eˊI
ZG8F~j=7T-rОGS4g\>tn`;dd!`̾s=
[b{_XS8(;'s2WN'-z6~Ʉϼq!5^obmg@}b79ݫ\E`^
Kݶw ր61+!iG3FE3bxfyFN/En5BC!mJ]w./;ҒŽ2&Pjk4m(c8 =}%z‚e'ڴTX
`~1azG[kcZ &I@6˨W͔J[n΄1Ĭގ:Zhy{naMlqs#
!໑nd-i@;ƯBх>+
b(\7)wD\C'ߨW}!Y ^zvL9e'#Z,z١	dN26/cϵYVn:֧#X7B64hnVh@'B~+zXќ'vc(sfw:-|r\fbF~G];+1CMd
n`
k6.En%CCFz٘0\;V~jّm*:udfߞ"cN6L54iR%ܿ᪘+0~'G$~[qR4"V ..93q
5/(gTʞ51qss;Wd`waaA+,51m7*!EV3y~Š+<~;Ww2oq,/]f:[|=mּ\;lѤq߇ݙOkQ`l.c25B{15j*~د	CTCUTYvm1ζyn+v2c= QLC뽒x⨏c88Zsepg"sU!}XHxb#
?cDߕrߜvTV]Wx5{kjN
Gq`.VܵbM/hBmz6ʏn:g/|T5Ygڐʗ}Ț6Rc{v5X|sGW
eȅ%2^Oy>&p^LL{45*v*ʢeQ씅1Eά{?^EwGHb 4aTq}h-e9_߾wT5>Ajڼ(%Ro3;ſZV22x{=ɗMhlt&,=e"^DWjXQ]]xf1:ySo9WBB:8Bp-KRnb
3n{:*T9sP
֫r _潫.b:ja~eo"v"bޣB;UMQgA\&mQkx|5ŜC:֟V)Ř_N2GR;}g}!	
]苓!rΛhǟH6S%3ai++^-"ٸϹp}|2UiuԔSdXKEƷP5K8IcqR{/y5V0qZщigY:2lJ
4wb~a׏ކ9)
$+}_\Nc~t,,eq=|T騠Y8SF0KN`Y`=qee|X/rͪƥHK|t${?0&@Y9ы\<^hGK|@[^nŜ?M5(nEŁ}k0wO+m~=+vˢ2AV&vG*!%/l{k4H<'128KS?Go1ϼVF/K
|n
oIkh*ʊ[O+')#H^G[puNjeӛЪ k^"f.g#R,v@SBY6
aOiCDRi>7Ʃ{@o݇<62͡k4_*cYq82q)_<`~pð&S̝eyDo=TYp=~/mα|k$bz)%NWuQSِSh"p~]K?ɥy\2~S.pD4i|wUL<Դۖz^'X$hXRkmF"pSnBqڡmDhMUHhM>+#v KGi`U W	1@.<9$ә2I2$W/'L$U?p8!XB?^zCş},lurZ+aioyf.W?[q,kFW|"rR)@Vbm/~2}Qߟosmes\ÏZR&AF0Yfkz2x4Z:i#w5x+9-nS_cX@Nd"o_LQtuΏS(7^<'v"}y5^2ʇ'rOʼnڥUZ|^mzARbgڋKi1R$]og1dcFYl}DI̿~(4ZT>nYtT?ТaFWY 3[/aԲ+:>dQ]{M3/Txt҂?X]ma"R}/E$}8:?(gN'nXtLOftwL*@~	:leN.LxwonkdĬo68zhn5*/id3}`EM
^V1*G#1)-Z0HzUII,`~}+uB"SO8˵vPS[=1^mE5 xNO`qRQ16=T|p6˳o*Mye{5=X2'UWKT&?[ m@}K1#_gU1y
$}>EB:+;7GYkyrk75A5T
rx7&(Mxc̛VQg{?<1Kӓd伷~inDӺői6-]_E#PaJ`WQYށu7
sVD9NӲ?m˼9urAWwL.}M}VqVĚxiەno"<4~ot;>HlԓjnשI\b®kW]}ir!kWΡ'̿O62߮a3
u{CSnTPL5 qV:MK8]"VE"_1:ר"ng5Y8lxd.*h
j嬻ﻝ
'bV$߀C;/sT͐2F:yu{fB=oMt
ib,$'y}p>3~E&0.b	'UJkHn՞ÚͳQǽ8hSn[Odj,C4s뛑6ζ,2sڞ\H(fݖ0A
o3օ΀ 6x3ñN+{v<Ct"K64uD
&}%m:.D,$!z'#TF"ȟ1
HnTX}7]T-TO8jWM‹yC\o˿aeDD|
R݅%6PЁS:t2ڧ𬭮wLQލ{d*|18Ktcb8)9'j5mK|X[G`KQAL-Kyxiͦf-A`N	V	xPt9$}1A m!>ԏ5րO03? 8EAdADܲC/FLuoz)8ˇ2%9Gv_@~^~SDS&Ld?F?+/&dSgYd-?8Ph7z.'h݉RHb,4Ĺ4{
gk	ur\fE|1h<8|Ioo[gC	7'B߃n:y2@DK=qjDSL䚰ZvGSHԨԙE1p[3[Z3qݑ+EϿZ@-FvxUp(]X
a4un[hxc{_yR'^ANPW82=zs;	J=ޔіʗݳ1L?QA9У[!lAO â	;F2bZe<|0{|77n>Dn6ՆTny13j^_wP?tId1t*v_kw\@)ʤ&b`|Ljf
4!lznke+Dgmۑ%WËPGqWx?Ģ:zhzRn	=$}(V\}JD)
?^YI1-݈>bğ+~iJ_@NqOK?o,	pM@3|~J-fsa/.
zKZ>=d e3Q7y"JS\t].KYz	5NiC<$]81o9ӳ]Ky-7w/?@;Xbed?)'Db,"$EbhC_VZy6!S=~\tFJ
Vt+wL{1m$}i~e,@4KN/}:Y2jp,<}tFr
@[\6̰Ÿe.ű#ɇq-yx?c/"ᓪ*LۻD0{r|	kPeՇxrEOG"<GH0;Jq@u@Og$ϖKeޒ{|3(YU_K1|`_%*{!`83rІqd{S-u+?uuUevVѸ[W\9-FrZK>	'm4Nԍ½qA~[͞jHfH:ibQH_|q"E؅YvJMMnq59d9B)KS()g>ݵN/*tZmAcWD2_rH7}:/	sTϵlߣ&miהO(iB:o*_#4,TFfDn|l;ئi˪h\+޸>g̙ЛJ#W\`1*PXRŊ#_Wfޕ8&BDz	Lj_Tvx3FF(ґ7#Z$/̷yq=f,ҋ?&
D/cS*&x#lUљCO|,Y9Q-R4+fi
2vZBdb"s{^Qtt$4H#9<5޵\LjŹ+mŕޑAzWUWD?AFR[?;"|_]iGAۗ49RB7(˫Q(d5}*j5Tb)#{FU;"Ja4ruURS%I@t~.qo|&Ltޫ$7Dk\)"*PkDbHW|Iċ],֟4S%ɆԈ3OdO}RJ&#DqМLOʴ1il%C4f?7?肕#8lBuжb?\IO4X*XuˏsJHUT	e2EF{ٱns%@BM)MczXXJ`M"3߄BKb=6tdt";8-)T4۷|T˩󔮧kZVq8T5&R`pf\0Cu/r=Oz-`^:k|H?*n>eA1ʦخq&/Elڑr b0qU
R)᠝8ُj8Y/	"q?m`׸˄yَ3Y)bBWۆ~NoG}ͫxZbZ,Xs!t%1g6%#.{D{SІ_M
yubݹw4Ϋǖ>3|:f)$Jv^XBfX=/!IM	#YH;+@TVgWG%_+no#cu	ѥ5p{WIVi̋.Ğ%?š镨yl<:(2 Y뷤OҔA5Y$yՐ|11>fk`VRSEZcĩ;cPl+w42zll
2ԴEr&WU2/w4#Qr-;<:CU)Q؇P/î'I/|WXut¢?G!0X)-.BQ/R-ڒ쬕$]"2,C4^cb
|+$B#8
_rA\GP;Д/L.cڵr[
/=s,kZc6,,uTsd(!Fl5=<č?ۊW|xKw]IM|mdY>
PRCXœ(-&*U?4
PuۤS~>D~(Z0ߖS-KP'#n@_:=G"M^!0}J٠FΉR\nOF%-5-I=ڵߠ*ʣުda#ӺB2)\4[N[Zg[X@P.˛[ԯ?ͦdOlAFBG2:XXҷhٜ`Ɂ'=81+߲-W{_kL?yŠ)@ms;Ag|I",!MoQqBS %ѧ'V1c~mbN#_6%d:> endobj
109 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName /EGLWMP+CMTT10
/ItalicAngle 0
/StemV 69
/XHeight 431
/FontBBox [-4 -235 731 800]
/Flags 4
/CharSet (/exclam/quotedbl/dollar/parenleft/parenright/asterisk/plus/comma/hyphen/period/slash/zero/one/two/three/colon/semicolon/equal/A/B/C/D/E/G/H/I/K/L/M/N/O/P/R/S/T/underscore/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z/braceleft/braceright/asciitilde)
/FontFile 110 0 R
>> endobj
264 0 obj
[525 525 0 525 0 0 0 525 525 525 525 525 525 525 525 525 525 525 525 0 0 0 0 0 0 525 525 0 525 0 0 0 525 525 525 525 525 0 525 525 525 0 525 525 525 525 525 525 0 525 525 525 0 0 0 0 0 0 0 0 0 0 525 0 525 525 525 525 525 525 525 525 525 0 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 0 525 525 ]
endobj
263 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 33/exclam/quotedbl 35/.notdef 36/dollar 37/.notdef 40/parenleft/parenright/asterisk/plus/comma/hyphen/period/slash/zero/one/two/three 52/.notdef 58/colon/semicolon 60/.notdef 61/equal 62/.notdef 65/A/B/C/D/E 70/.notdef 71/G/H/I 74/.notdef 75/K/L/M/N/O/P 81/.notdef 82/R/S/T 85/.notdef 95/underscore 96/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z/braceleft 124/.notdef 125/braceright/asciitilde 127/.notdef]
>> endobj
96 0 obj <<
/Length1 2135
/Length2 15461
/Length3 532
/Length 16612     
/Filter /FlateDecode
>>
stream
xeTͶpKpw	h݃6݂
n-8$>d罿szfZ= 'VR67J۹330DULL"N@#K{;1#  4D<,-\T$qmN&Fvy#-h#%œ lcP	g
4egfZv(Iۙ8+l?Cn@'g_'hϨ`Z
rCO.jc`d6{[W@dS5&4tߣ.F6&v6@,%,=J.&3#g@;-ܿ5UtThkO5ddiYI3aPu,=L2AN%ngbojig`a99yƒNK;Sfdw=`fφ_BZAF0++4(hjl_NhW3	jeJI8ظ:	LmmD@?!Xڛ	m-D^@'?uq3RtpO]X)_ ]gA@\A;R[lcCLckQ tagt?A/@k!bT?ZZ"@T?rC ?rC ?rQ7q\E\TE\E\4E\E
rC c'#kwPkM?7㿟tן
2C /?כ	$fsX_0AAq0ԬB_AV:
3U2 +dsB_AV.!/Y +:#/Yy +Fig?zg?;
NnT]Ui1Pab&Ndfo* hdobV'^4S	EA[Bc|BJ1YGZOUȇPD/Q>ʓon^mZ7$g(-w+s
Ԏ`6zuݚzB88$2mCR;VDo&'BnNYöҮ_w?'=bštT9YP)#)681~P4&2'Mfi%RV"\2n/%XOmX] vDIV)P?Vx=ls 3v)LUN,٥fXO]P^M18^|a	2F^b:er`I%@ͻWTɺe@yчZ4tԃkhLim]WHBעfW4^R|_s[RO|'RL$Eᠶ8}OHK511ᥠ~~/Aq)~̤I] 
-E;2pAS(ASqY?ܭd$wSyY,Ω̹Pm%X+1{'qP-ALGˁQ=Lw1&U!iv	G\Eq{wY_o+Co(bXEMD2S,+91+ȏag7	>u}\_ -Nh^jp؅p\U؋[i{_zI~PHwAہl*B
XݥS6l(m	؍qكڋGh`YvLXnf߯5Ӫ^d$#;n&ؒpཁ_T{})Wjc6ܼx>MjhWxlΊnMW"՚hϙvx,κw-T.<VRD5|t;ŨPrj=z-K[
Sz[Yza
Oذ;	ay_I2RVL؉9QO桒=WaSdKH
9
0OEkCCPc3ZnLbfCadXf-aG.(J1b=n#y>	?ʼ$>e1zu@r1KֹiUUB㌝ӣ($V:rta|äc?#Acg^iلzDBrOv@b*>9uy)󆶦˭$<N8zQq>o*cɺ
~jNDϩT2uG|NuB~!0I"cHꩼ~]}ǺxQ5µVQM
8fs5"*$VP\  \PW"9e]K{n$Ű Y,EKJa}Z`1ckr/KȞdQ[0txOZss~)aFjӟ:^1Y]:LLƏ脖q1sکX<@5!bTW7vHqY`0#]@GuKnC\?w;AL򧸻#[bZX	veVgkk2_RjN<;Z3Xe(J9~R&Ps:{qwGu{hӿM )!1|cdrCMDX9`&!]MH-2@Wz#:	r[2*#į9%uF*t;B{".Hn]qׯoI,:6fhA&qԖBg`ևvxs9yOr6HD$rU9FnW"
e*-Pie7(	5T.B4H7l:®Y̓`i
ey>rq$gr;	rf^7-,$XZg]nhJʄao߱vt\Ih
GۅYr#x+d^|Sh
@wߕ~2kɃ&_@jm'lF?1He_g/'rP"a$-hș:yڟ
n͝r+X]	Aڧ,ެ2Գv)<(h&6u-uk~vnXrwn~Y'֑=
Q̊.&yzc;>6e߉{F|R)bڸ;Qs:P(@G4=N)BBV9X/%Q d;u1%d.Iiad\/(&^%oXSbm70*/ Tj儯aыI¢%hp
9tavG-42Vi{ n{RM
q~1س{ظ4&\"\]M
uV$wt7%40
6_Jjo)*.]xy)YGrx37GLٖ5L_KVix
r!H-E_p+򔾚{NƵJ	ngY۠̾@5PĦiIVlXrΚP7A'yw䗏F7&<+FMخ-JxG;啋02fWތvRHpBܞvKRZ>.y
$pۻ@sFKyeMR|Վ0:3i5b{
R(n=7Gwnςȡ=TY!~1+Tf(ecDU:~E|e:{Z#l.lGFs#w0iv@;s$Rf[*)85uj=34ZrW
\,4d\-ħS.qw(G"^H*ADmE=I$Yav-Jnhr iKpQICךeh%[
ģhx7)WS?dWo*H[\mnbZ	g2>TOd6Wjc2^*P@Mή5B^o.۹BN#w=Sr)	,[ǡTsdS"ד""`?Q^GX"㼱3|vC'K_:.]~_qV/MԻn!RJCKuF Ĭ0xA}	
X?X"`Iu1B!J})kx(lc0HY~@@}Ĵ\Mv𨻨3Itg5H%2@ķ4騟w
	$D(đ5r]jڒMSQ}m{~WxN%r43l9dH3Xyّ93`Va贺j9*VjI/lQ8eNţt-k(s[4vm7_[p
:oXVs´n9!On$h|jD@XM0G}pị{+n	>:B#_BV('wGTD*ݖ|V?azeku#\nI:QQ-?يx.@FTADRB;
l3$*&A,X󙑽Ay
qF`FzL~s-e"׉R#)r0gEj<Сc8ܟPQ|w'4S_(ӏUPm9,s+{7
PȨm9Tm==R`\$ɵenN@K7JJ`|ķp<`VÖ&B89|T̜9:h5݌TD.RLT.M"<@3h+{P&Ksa	y^X\Z@f J7X5m?n#6Y+{9$9NٗU
d]Vyk\*A
=yZ^ބgLPbLyŒ
0?@͌W,f}פnRMԘ,9Ϣ[կ͸.hhwuL~@AARKعN!i`&<17fl)v\\,MUtk2~"6x$t!K	f"#V@ν~ȴK	r9] Rԙ:YurʪȐ֮.).o( LduNe
gggNljì)mE$r'tyX9 Z
]lK&OZX51o)j;-7JR,GdA1)|Tb]a=Er_3\K)4-,"4͜uPNgoNnٴo+K~6s)G	|OW2robjwT X=6̄"$nq(d˞n`*]9FAT腩ҭIv/)L0))c]&ykK1l"]nRm3~3,Y DiC=Iojbpf^Zd/?#4
,i`j'閔힇y|[j

,
C-/CkJKDZw|ŽitOmj$P87tbU4"6_45aNƞՖ/T#"/*Pq>7m?̪"~Cso;74HP޴AN1W*(̜9б},A\N#:Y<'Rl Hy/d}'[7'@WAf{d\,&& REU[.u%^,MqwB# ċ3f>ӈl{wZO2`8!:_tơ:*YR֓`\Pk*!2r8V<ıGu*)ñ[];VuwS+zo	u1YxXfe	.ʐ[
/dSU4ԇ]K%49RËp-#:0`}cNBΦ젖NJeҟ	t9NK#7x4:~R[D/&h,7?cUUo׭'\BӚtzd*.;`7$۫sЯjᓾm=y;=Gfm +NUI+$z9FzOBg2޼@
c^~:j&V%Ȧhse"$Z]k|KȆ2?jH<0 X|yRHi:@`5ώ6)['$v;:+pdA}M
fqz[JQγ`)_MhZ
q7bx"%	ZU!?+OiWw1&ol0:"0lf}drm+ԡPN=ń`ΌI}
pڢkv_¬%x
nkp/=A3:;Sd:T*1I:v86XφB+s++Po귵"_*:}R9vTnbIMid@!VYv?e֍7р4\숯FN`	j%>eZb7}
9R[<@[ɸfVڏnU:A/[e>E
lliӼIjmS e3d5*>@c/ΩR&IOSU_
<\7!N/(ћmt`(0ӧ@25_XUAGT[eUl+NG
2Ex삟Uy?*'l&n=E$]
SGْܭIĖp&P W,Bu;mT*ߒ4PNb$'|8VcZS`|Bpz

j%Qpd7YF`֓`lA瘌<9cVL|=}5LfUc>=
bA%FY>s!e-l=dxc2a[!է!~W-=iCuL7M4ny܎¬)ݎJ١~M9~Ri`WI^oOCZQS{Xf7	4[ܽ{ݨwUh=JE.?e+(|rƘD7J'$BK=D~62,ޫζ0P'?tocubւT7$k{~	쳠mÅY|ݯs~:|^gfx#,gl]41j]sW<>izD}S'!tߴ
Xׅp>EK馇&rX8+t0:$"TMZ*1+
~B)9ϔ]R@-qogy@Bq%;d&~?H&Hf$ X/#lRs[! 8ݲCG}55~
gi`rĘGmjFr{]iqh֘`>y+Z5Wa/gr}Ͻ&ȷKQ(HbAKVq,,9}T
UuY"l1]FAD_]/<e\.{#o[P)ԅC[D؏
Nsق뿀5+te/*
V\G+vUJJM<16\C
DV{V0yKn-֐:
!
'6esS\K'-%=uЍ̾ut蒢豴W6C `lM\>:vHmQҋT;HU\32s9WFFX4Cz~>e%{ݩ~ׇC/i+jӍ^˴*RX<`x7uNdW]txN:%:$rHX[Y׎)Sy}4]敞~@ڔ(nI&a5Sd<)4NN0}(	a+C&U=|a%_.~Y- !(<^ۻf:{Pq;1=cڲ!r>\x@ccJb^ee&QtUb*32?4*oNxG94
26'|=Q:~e|{+'L%
H.Ӻ=TEp(
=Ɗ.h	g񰵡iyj}Tq"k/`>l*(j#Y4^QvD3s̢u(tD&՛礇ǥH-B~}'\\#졧;Pĭ'*_
;]-b)&?cLHB^Q%~.}ҒhpZL\"ʗq-9s-
)S:t?iD;h6wo8"d~yoғ%t_ˡWnݑQ>pv}U3I2S}-(U9\)c3Z$|,50Cq>;73+URF[RX3/ﻩ%@5A0Zrk6"ӠL9]PbT8\CŴk*2]PaSԜ82:no}63K9sGMf[qN5	DiN͈M,uew^-ltqͲC}#f:4(n]γf?
jޫ~ޒQͤK	m1M_bkE]zHgxwo5Ca=I@3ZJTV.+SWeqGFyZ%%z&w"d=CdRG:kfD2MS1$b,Re|dbWy6͹`1G!\!}Us"~{o$[=\9f-['T<*G8?5$\"xhzT<P9 Q\X 6TwU7@> -SECj>Wo%F[[VXXd/1\vHT0AYi^ءܻHpu؈/ӃC+.)4`}'*}%x;wӝke,uZ<u?ρ~=a:?k@LyD- U,wlhӧMGb!ANAwaaؐ4Qǫ}	b#w/p 5-'BLދOQ3$ӳ2|4s'ggL3ļ@95:[x?-GM+,6_ԄZB4:V̿9$(*NW~#a%;WuTV_ؽm&o[cD>ضQvd0qEoxE ]GMlK,Qr̜-:ZJ''6^~@D0"oAC=@ot+vR[%6ኢTFei
պ/XphPHrf)+{~iLؼ
d/j|Ş83#2Py9ʆ.^Y51$2PT&L@ND/Y/|JA01Acj{KrK췆4E}g1!`;d¦r+`B[<ޯ+?rnoaU)?@Fh_
fP(t}әRsI`N[6g\?%UX;h&uy6r`	'%?;1*6Ȝy4ٙxGe{Iٞ!~:5!/|G	ݎE9/8W驈I>F1ٷ?KTks}R8~YtVY:JͳE&jM%q6CPT_axEe;m4Nv4GQI~[KዘS8ڃkrfpjALzEb>m9sc|CL-U!Džo=	LjdXx3q
b̜##&[^om߭Ќ@ֹ'>>kg5vkQ:im:*j4.>Du&-b_g{!cRP 7$W<}m^Z߿k¸hHf<~Un7WY7.\'+"#,-!vtФpsGKs5}=/8>ڛxhmDJ4`<\kA=v#Eӵh<眦hT'aBYˏѭ%Afo"m$&C\Hϥ\o<2!	Mwphe<[Uh='\J!Ť3)JZ\R4|AU3/^4	>aJ0TOm]wnhWf?SOIȪpTm݌twDgbZme?FayCh18x:)'UFԯCGƴ'wn3!{~T~=lY㈇нۄ<
nʚCף{]r|K޶-_0:B2uǀS@phZ^'wD͍7-3ȮEhsrʪDPK%Z+9޼zް*H֕&f3(0LNNoR>#64--Uz'=Z(YJ6H^RrLfl$#|N)6ڠg,f~MApH;*w^nЫrx08CGdpYc̢jf)-oiqa6
YNh/Ekp IAanMA)jmNJF&e9A\In.tXBe,yi~rXB.J{[bڥgmN^qJh+1/W\،ř~U&4
j}Ŋpb
7uci^H>#v6w
],8%~P2qŽM/ZzV4/>OlEŦeBqֽlw[%?vGjtYGXNJ#MTFX`Qh<+~PO8L&-Zo#l퍲ubVn!)"&M{;!th<	4;<~|8ݕ99^.$sy"`0YQkƕa.KKȕfdW):,7X|wLI{31cu{Ǵ^0JNlGQ*L׻XV}v}cKb|6b&pj.<O6c@G%yv
gHԑ<gie1h.gJ{ݍ]1uNqkf~H;S)YwV5y]_Hjaʫa·\f{lDFQ{sMT,zEAgR7VF^޷D&+yӸ@	&PG"?^sI5~ۏaYnϊ:zCsĩnPQb!rKgۯ+9y@A"7.alMPY
VƗ|Fz%Q*ץE_Lѫ)gͧ3?93oQw7ʂ	(oK.qS>eLMzTSoYI{gc$~oY?irLfmBx Ç:MRNa'-PpR(kiVssN8UH⇽wa˰S}VP7POU~vyD!:,HGkiu`=E9P;kՏ>
5p>BC?3gWZH!T̸
)kJɥ&#\
*:v;6]=Rf#M\SmTH` M5𷰡utf٥gV`S'ְ4vmzl(mѧxS@]J'pO([g{{/@
ۚƟ",(Z|B9D?.ait8\\J}j͑֕fJ<;WNZ6'nae]?gA[ۏqn:n+ʑ
Eg`~Cf:H-LB7f/
jB?W4CQF!%q	jZ2Jvq$IYIgm'6't
@w*ϗxvi0Xx'j\we+@KyfR;j6
Q:;Oۏ	LtJz~ѕ>HF	M_zI$kЖC݋;n0ƹ5u~ԆaA:tg[Ck}CEXPLdMuԏ)l׻m0)J5j5;=Ǜ
wt)@ |'y8sM{LV7eYX6Ғj@&OD+,_	̓g=!649͹T8vć5`ٮJY>3j\y*~gBoL;SXOnZ9)x):dw.on@
^s;1Afp_WHϟ3g?БƲ-2wqVp
^zC$&B^xE3nJRr$vo]aR&Wc"mY'?SC,Yzé8kedw,YZ4ne{;_/^6C};er33_A?*`h(*Lخuntѣw0*~hI"Gy۰Vx{Sdl4ITjH{3%־x1@,$&iÂ;u`bjl?iiBjh\vR/~\ܩ,Îe0JJk	W]"_T	C]D:{)+
y
ׂxVjݼg`P2ٟ`uP+2~;fdds[ztln`㭢F
}lD
wQT&!Y!튺s	~/(ԭB=Ijh%I}FQaƎܣD_^lv"/K^itȪN5S>c.,߳߬)?֥NE|@1wCBMO$lԫW94>&]lk;Zl܅-]P,od<鞇x3|*bD,!U:r
&y!R%lILHY'_/öY/%UOyb`)9n!a/6~RTscO	LlFN.FN
pendstream
endobj
97 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 265 0 R
/FirstChar 11
/LastChar 123
/Widths 266 0 R
/BaseFont /WSAPZR+CMR10
/FontDescriptor 95 0 R
>> endobj
95 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /WSAPZR+CMR10
/ItalicAngle 0
/StemV 69
/XHeight 431
/FontBBox [-251 -250 1009 969]
/Flags 4
/CharSet (/ff/fi/ffi/exclam/quotedblright/percent/quoteright/parenleft/parenright/plus/comma/hyphen/period/slash/zero/one/two/three/four/five/six/seven/eight/nine/colon/semicolon/equal/question/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/bracketleft/quotedblleft/bracketright/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z/endash)
/FontFile 96 0 R
>> endobj
266 0 obj
[583 556 0 833 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 278 500 0 0 833 0 278 389 389 0 778 278 333 278 500 500 500 500 500 500 500 500 500 500 500 278 278 0 778 0 472 0 750 708 722 764 681 653 785 750 361 514 778 625 917 750 778 681 778 736 556 722 750 750 1028 750 750 611 278 500 278 0 0 278 500 556 444 556 444 306 500 556 278 306 528 278 833 556 500 556 528 392 394 389 556 528 722 528 528 444 500 ]
endobj
265 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 11/ff/fi 13/.notdef 14/ffi 15/.notdef 33/exclam/quotedblright 35/.notdef 37/percent 38/.notdef 39/quoteright/parenleft/parenright 42/.notdef 43/plus/comma/hyphen/period/slash/zero/one/two/three/four/five/six/seven/eight/nine/colon/semicolon 60/.notdef 61/equal 62/.notdef 63/question 64/.notdef 65/A/B/C/D/E/F/G/H/I/J/K/L/M/N/O/P/Q/R/S/T/U/V/W/X/Y/Z/bracketleft/quotedblleft/bracketright 94/.notdef 96/quoteleft/a/b/c/d/e/f/g/h/i/j/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y/z/endash 124/.notdef]
>> endobj
90 0 obj <<
/Length1 1544
/Length2 10065
/Length3 532
/Length 10969     
/Filter /FlateDecode
>>
stream
xU\O![
N44ng̗/9UuS}TEM@F@)- (`ebaCw-@` 
 489X ;73s0F_6@cC[!halh
P[nLQkkڿV8Ԁ@g	2++0Y"3I
9!R4iIh̬TB\ohRNJ6JOǸ9E	OZ[ښY,ppX֎@[i?̚ZJRLT1twY0;H{Y!!ߊIL,ll\CC7d'`akt]!L 0d	/)_
9sfb 'h'`Ot	A3'gRlk.Opk҄3Ddqpm-AqA҈!H
?Y. 7qC$ 2. rEɢ mQCjSA5MAh M,&!"/)f!d#!/HXa!/hB_Ѱ!_9A_r!V!A\B??g11#;l
)gjZ;e% 7?Qc'-w(e_ljy@cY1eJ}pdD1YCRM68hay{jǒ4]]RgBVO13?د3iMڗin;vwG-ǜS#EUh$>!,Au8v}֖J	f'Sj_ₙ32~`H:FA[ çw;«¹SF3P(תk(bs2m6{%4WL4pJ"꽙iN2mjnc|bd?M`m#CV+vGהUS1Ѓ'Hd..kPAkmW}95J4KD;x&λ6J0&r5r>epsdt~R:r
j6-xIO3sXS7S.[de0TOzǎ{%^`1޷k\~`ݻw(ï8$";&<>yI]sѶ_WP{ay4逗`އ	J)A``)-srealTKd1+o mRxK)9*'`&~k>M
$'[̌ͪZ\5Zv7'f	cn8i"Fy]Nig3P
u$	X'e_+]-
;C*_/OF)kl{7Z][._QnԬIba6'59v1#ehi+;ƺD~|
w	ʵ%:0̪)gU֐l5C詡VZ
5[Rgr:JДZUvEOծ\{dqoы]
1ydy5id+c"A%˜uBw= wl~w!ciyЬp8psXot0.ResBv!or0a}o!ӣhSL`/jU*x] L>mo)-οxQkbMD	GeC#21i%x>o(Bư~|إ]i?
T6,J`HN:^+bJ"-4q/Uu,Y1+]ld0_ ,zt"XXZ[o˅N,%lL"E߭U&w6eJSckhF>h/ˡwL ͋I+ZbSTkR1i'5$}.$H\ώ0QN`1F0JX[2}=Sp䙄z$^{LC-hWaQͮU(ǞzGe?vN3wK?T2^bЂ?v1&?mszwd'zO藘s	Hb>
uކz^5ol#+MwZ(8)[(oqnćlG	&ʌG*̳T*T=jFƦp$wVMMeȄwt$ФDDy@A(&>@D;w"G^(k9IH\1g*Pτw;/_ӵ#5Q܏_!acl֭v=[:dJ}K~Q=v;vx35p~W~Q)疼LoK|8%H?*
7cD!3F]2iBÀ$J@
?g,6C}
TL@rÇx_d|bŐ4doYY+hFt丷'3"!hQ%$YD[uf0keBFLT0Ө)BMc/1d)43T|8kcI؞X_;Iʹehhi-)VGcZ"iS?)97q"3:`+mkՆ5cq7˃=dbGxs0x?R3٘	>/qiĎluwReNTdV3ZIu]hA3˘-)8(u}571poa(zCΝݏm=x,קQfάju*~G{ΐDvKhCFd4tVke.7Tő	{(}wj^#Hr}/Q(FiΪSz]|s!1K4K7?!Thp%V 44NJn+<(k3Z+oI{eNũyR?tCF灨yĖ4r#fsHY[X4i0>-D2)r8m.2%Ct9;H>W.S$uzG%jwp5X6E})I7,mz~}{)Ud4%(ZT1?:Ux
-k
3ci+	n>n#E}L-z]VwЎljȈ_M'[^BC$?3'-4Ë_5VƓ0o~g~q6(o&N3A^}ٰfwxzq띝 Ez[#ԯ>?;I
Κ)=D`1ٝ%k¥EF~!|vh-fyʵaYk*WBcMA56ֶH=ϐn8ߗv|8럓D ?{{IPnjrrlohX^DYdR0ӛբ/qKd&cz&*[B"Gp0gS(LoDlii/weP;zȩ6)ZKJ	+f=5
FyH=˅ҜiC$=⶝e"1'Q8vH"uQ|ܒixV<ʬN_3l]v-d=@=|5,biI෸M}	jN~>f;{Z}.;Wt_;:b#Jo;apY4N/^L2Rģ/NjBD$տe¿i!>>V0ՊcD;h˃I1$D/ͣg^3/5r
(MNx{L,3:UwD|f܍Ǐy|rI;5iR2)%de}W	I\uH0	~Uh
iɯM%U2@ _/ݯL]b
5J.xR,%̫j
/zG
Iz	)nW‚{k`îiqzxIXmRr}asW҉N؇ 6[Xn^t6g%U\}r$f*^}Lmr ;=XԱcw1]ک.$~>qB(KPt_r77,&ڦLc=QSK?jr4b/kvDAT-?
]e&ߋNNm6DUƑV<:>'FVW#uxTm@F>A-~ڔ7B
>'4R>r#>4lFLJQt("ֺlgZb6DP!F.u'lgZnJǖ*
̱X96@RMlIoӞ.mV8+Lq*dt?p3ITH<8"Mr8qREqF]gKx6_CEhW
1U5o鴦*
˓\Z]]|xmfhS}HkUFI%NkҚ=^0|V	s*Gi
4El8:69|`I%4}68ۗmѩn
1׆_Jy+T$~XaQSz!#tG%GYe5H#ڥ
VEkj!Bk ǯII{40@jrWMjX
l4Rbux`մ9"d.M>|.(Tj{a#t95S^fڎcFm
j$^kut#5|8WYEO nR'aO9F:Qr.b̗iFAޑ$n1n8(I(˛ Tܷq'qlУ0~xp"< bT2G[}v]}4dRrZK/,~vJ.g}))g$d~ޅR
ty[kP
x{Fnj4S;;MVEKkͷѶUk悖"$ڽ
*zpW	1pהReֵƯw	Sc roaa<NuntSy1BU`,m9/Kַ;ic*l^`3kf>e%lxr;D=4%*Y1aPؓE^%{TVi/8^@lT]7=P/Q/LgA,Q6|0\W575S(_65CÍkU=s'J_[<pYruo(m;~&Җ,if_c'_jnV/n6K6RbRa_-ǀx#ޖL@eF-~(j&m!rJt?K"	L—ʄ~95sbQ3	e`>~+v`$*h*$}L!PuY{HߍqRξz`'aLL6 NJEErlݢn<AMyEKJ>|۽={JŢg{ЅEgb
e1u~ġ+/d{c秛 5)KM~G8_o\A+9%_Cн'𾎙1J#Vnn~}ҌFUT_PV64ʛɜemؠ7efbJwQHPg/:1-|~C )CQrl9#'ͷnƗJ+flg"},㲡WCr=>:^Z`ʳQFrJiGɖ{+@ٱXwjpj{S.Ɛ:ۯ(QH&Y=xKwkIPAW>Q-۞cmʞo)%ɑxO4ͤ҄ߎcK-mmi8*8>S1"7y	&Eю~q?f~wwp*:JSxS[aAJ
)R3kmA,	vO4&Oa?X.Aaߥw?(wea
/Bn<2ٟx/~d
8$i`!\H=SȗX<(tOݛPKٔ4X*g	NoIǝXMGB=eP:}@f$]Iʻ^R$8p~H;,S˥t+/bSeq1"	Su{,6`	opĽE>3
",\IhGs'[Dk>X$p
d?OYuqZjJ,Y_TG몞C*(JӇťFc1gN%BDj9H{ērr^\VNF4
pl{Sׁͥ*"$Fu_YͿ^Vx;+|*54]!Pur~&poUֈڟL`!6t#-m;}-(Ip:x?G6-vBCFi9=ϜQQ\ԈS˻W}7;8{ݳ-?b
9wDGڌZ)&i^ۇt/)g={f{SH&W\;j)5e)$e>Ւ'R3瀭{{*~]dM6,$OdZ+$
;͍}qŝY(pCee	|8˦sBe
S#sm~a#fbEq$;SᘚsQ%uUkuy`;~%B0.uz3	#OF큔
ۍJ|GLuh#HPP]ұ_>Q2xmDO4?<:tsvE`bF.1i{s_‰z\)!PS XP12AH:ҐB)]0UQސDvM@'MY@ִaFPWiAԩ}C2s3\фOzg*c!#CO"k/wfUFmVE`Zl}ͅ[BMxѴ{b5vDtԍBnS^э0C7uP.qEвf)Ę&p(fXSIh	e}`^.yPC)YzVIˋ^0u`Ivv(Tˬo'cۈfg쮂n]h(Vmg+ZQ	,M(JBMXl>[LM%e/4R986$[uv}N'z2؀*"¯ih4o
|ƲU{ӸQgoM؝wf=F,XU9ڊZnڼJUm<,VXræDeGbȓMn+u>\_:w8QrHzrW2ts{DNJ,o-RBqt?EqCwo
EV|IЯ84!K\bu)cF:7w38y0y+Z|pJ#ofF"`OIx0D3"If/\X=Af,V'7L<$	;*Lѧ/Lk{@{Մg@V,7zmׂT7ѯ6ޮ߆
V׆},n0喪E";A}䮞*L`iFI[cfQJ+5题ŏOi<#62?lA#"SX='1MVʓZLڍsLsKT`YY9}9[}tq&&(KYD|D	zs-p)M5tך2\CEFrQSh7|Gmy,.tm{kY{[=>,uHݜ-~slR`<}lAIK1C.[Nɦ/ rB`6޺..7|1-B[ܥߝ'"51tB_Eqendstream
endobj
91 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 267 0 R
/FirstChar 11
/LastChar 121
/Widths 268 0 R
/BaseFont /VWCNFY+CMBX10
/FontDescriptor 89 0 R
>> endobj
89 0 obj <<
/Ascent 694
/CapHeight 686
/Descent -194
/FontName /VWCNFY+CMBX10
/ItalicAngle 0
/StemV 114
/XHeight 444
/FontBBox [-301 -250 1164 946]
/Flags 4
/CharSet (/ff/hyphen/period/zero/one/two/three/four/five/six/seven/eight/nine/colon/A/B/C/E/F/H/I/J/O/P/Q/R/S/U/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y)
/FontFile 90 0 R
>> endobj
268 0 obj
[671 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 383 319 0 575 575 575 575 575 575 575 575 575 575 319 0 0 0 0 0 0 869 818 831 0 756 724 0 900 436 594 0 0 0 0 864 786 864 862 639 0 885 0 0 0 0 0 0 0 0 0 0 0 559 639 511 639 527 351 575 639 319 0 607 319 958 639 575 639 607 474 454 447 639 607 831 607 607 ]
endobj
267 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 11/ff 12/.notdef 45/hyphen/period 47/.notdef 48/zero/one/two/three/four/five/six/seven/eight/nine/colon 59/.notdef 65/A/B/C 68/.notdef 69/E/F 71/.notdef 72/H/I/J 75/.notdef 79/O/P/Q/R/S 84/.notdef 85/U 86/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w/x/y 122/.notdef]
>> endobj
85 0 obj <<
/Length1 1381
/Length2 7207
/Length3 532
/Length 8045      
/Filter /FlateDecode
>>
stream
xU\q	BiC)܊ HS\]
-.)^xPd߫={_su~'31~c9D!e
an NPFMqrdAD aaP
	2pgo
*W P	Za@5	U
ԁ[A!nޜ@)GG_+\Wb	P+7%
pH	f
+lG+e
h
9z!6.u8JrwwtT;U.s2NnP
n
A3/spQr;B` BPWyZfe;BC`iն
p)h*hj~Pz;SQA@/9AD߿LCLfP/#`oj2P0kr	Q-O_\pry3v<@.;wzrE?̏b;2wD@%󛄀\	QD)&T%߄ZP4!!ԛi&[h&TM߄P
	`Q w?(M?4?d@ota Jt@EjrQ7{p&5a(O@A~n=Quq(ɢ[5E+
u6Pم@ Vh}zcx\XStiۦO	BKT\.3Doaoz^SFj
$dLnyXl!_P ռ7/BH5&S_kn~CxQߑ* h(tԋ{KMRI4o̾xowU|ki=oqrMn|0tqmiY{ZQ|/٠'YS,L2|p^x3Sd|B!JYNmB
shRA9P]CK G{5Ylwʼ*afn2i\D|"dPZnL<+Jp'=[B.Tu*+ğW=:oMj"23e44vJUe&9]DW^v
I yU~T"U:EA^Ae"%eSH{:s7i_צy%$ w{c)rVQY}s!Ž2~&V6$\sԞ(-&&/qz*?$GNZZH$ƨ Q%'8 %ugNo7=7$f{tmݾg;jm;Uпu55řKOcs%Gʲqʞ!i
D>ͽs[\i*%
5#B hkIoK[~c17d9%FSܳbc.UʤW/uư?L/+zn\v䍬58O1`Ԁ8V,
8^ي_BkZ^1QxXIZC~LPUM-.]SC0;UF֭>
yR.nU=MPl2龗Z{`| 3) oMeNayu3,V7ޙW:2^7NN3Kxc"'cmfEruƖml\:6$Wå^^-MHHy@HZjYLQ2V+ڭΐU3l>>t+ZwpQ$δ:D߮t]5c$+*ѻXZп,֋*i*(9|0G\-:V#dg{
h@QWiΠ~J3z,Gn⥉$L2 pXc_,eK4/ݏoڃLb)nI7zTpiV`+fv6O4&&
n[Pvy%]j15ŐT`s.SF]!6K_Q@^YK
ۘ&Vf>@c~8*Ci2RόIEhzNWhs^}`*:Gl^'f(>%s(xV4?K~d5>lfg_JP]QNЯkmCrʂdh~SyϳaCUf0Jo6#EV쌀Ei5쩘9ĿcrWl|E5ǗTr𥓆T lL)jw*_f"*?r&lV#H"`npڒ(a-+Ǘ}2Ƀ}I3ғZ%$!Y9[v)+Y)7.?q.vWA*>*vJإ2"6&ՙI,Tfk9'IFiIktkq&fN5Ij*s8>"F\X_S~>Iɑ4ʒ)ߍD?_9zr`V\կ`Yjj:]_#)·B!joHnqBf5Ұr*Rgzq ܙi܇7>bDړo+Y8FD̘&&~fC&!QQ (SlhOKe&gޛxJ8YV9L!`}uYGҺGpA5MS	t
Oѕ6Ey!^[{gz&Mw;Ҏ`_sjDƒy>#)Sh`7U)	%"BZA2oΊd˅MjjrKȆ6>D5!3^13HB؀TkYF7Fl1fb) #"#\*'4WI\cdI-ӝ71;2%5#{`}h$;ڵhܬ({OpG߹*FxMAS)$I!¼E!=Kܽ3=N7xf%qK'+XGu\Ÿr[e?8–tdW'۩<k8$9?М~<
n5cǀӧz^e
PL/G8>P<%LIs_+	
x]׳1e8\eb{k}GrkdeG/#(]@,O|0x!1LE^
'B*pVMM<̣Fԍ!)_Ok2//ٙk驄+V"D໑}M>0P4>T=~01l`˻e	Wh$'aGZJv5RijIyޚ;403S$%8Ig{}qX#>bmib%dکoXl 	{l=	r0`j;R"ppQ2!=N4e-˚Z>zu(m	dПo<	opYHIF/j㭞¾O	Y_}ixifo:'_,a,#_Lã_ȭ8{PrX
؉:}>cw]p,Mx`+Ǐ}kYY|j3*-C\;]}z&Q[ҝMzMLSO+oP'2"XEbö7yW;Oy4ߊ̃)BlOg/FzM&X%㱳$OW}xI,YbowDxICXB&Z+(&Ls,fxpo~/9cLB+rN7Ɖ_dKeW/N9z4lHFsa#z,8Mjܰc^fW(So3L,L8i$iLO䯷kUЌ*'3SmJ3e`haGli!ECw)=?)*$e7xxdHjK^$EQ
jwFI˪Z H5;ӛ2Cf'#bZLj~;k01ß Ϥ`.w l9bgGU*Qj帽`? TGW;3/vc8QGtpJ@:fc_i~[SI|UAq`:DIC;sLax$Ӵ(Ts
^@lm9b_=_ ގ`pꏺ;:U60&A3hsio
bȡ\}zTvvO>U.,R=Ǥ7pG-5GdP}|-_Z8~ފ#ժe[dg+ UMIb\wmnre8([5eoyMW2(B6MI'
ҝ86+ѤKTP-LJ5a~!@F+ҵp!JoRG35g^L&?`?^M>&pɾP9`T*ʡ3Iܫ@cޯ:Wy)"!bQSfS4|Džl7SMJFvKcVL[]ii1:/%ϨKib	.T4]ޜ`*
ozҠ:)1jX)LI_;uHJ'\i)uҫnk}+&1^oZs0,AŻ4Ve4fׄHن
cԭ٥*+Yݎt\b/iBuD8{5V,%r^6#EeR'/,l{`	Kv䟫Zېǁ)l|ɕt"U`gBhT/?djz*X尛dQWKxDZ7aɲl&MJ"L?ƷlqmOdX
ȟh~QnAm	FUi
)RjxgD_{	φ&H$}q뱧{9TK\U[y%%[uo!v9BTjs|U?^I@Zl TIh8i.'T%D^`#ԒRn-Sq\c~Ly-4%3y<.3[÷]Yw"2^Z,Q0Q+hj'҄b9zn6l8XdȈVY?TkBf	]g)홄t> endobj
84 0 obj <<
/Ascent 694
/CapHeight 686
/Descent -194
/FontName /HSPGPP+CMBX12
/ItalicAngle 0
/StemV 109
/XHeight 444
/FontBBox [-53 -251 1139 750]
/Flags 4
/CharSet (/period/one/two/three/four/five/six/seven/eight/C/D/E/I/L/N/O/P/R/S/U/a/b/c/d/e/f/g/h/i/l/m/n/o/p/q/r/s/t/u/v/x/y)
/FontFile 85 0 R
>> endobj
270 0 obj
[313 0 0 563 563 563 563 563 563 563 563 0 0 0 0 0 0 0 0 0 0 813 862 738 0 0 0 419 0 0 676 0 880 845 769 0 839 625 0 865 0 0 0 0 0 0 0 0 0 0 0 547 625 500 625 513 344 563 625 313 0 0 313 938 625 563 625 594 459 444 438 625 594 0 594 594 ]
endobj
269 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 46/period 47/.notdef 49/one/two/three/four/five/six/seven/eight 57/.notdef 67/C/D/E 70/.notdef 73/I 74/.notdef 76/L 77/.notdef 78/N/O/P 81/.notdef 82/R/S 84/.notdef 85/U 86/.notdef 97/a/b/c/d/e/f/g/h/i 106/.notdef 108/l/m/n/o/p/q/r/s/t/u/v 119/.notdef 120/x/y 122/.notdef]
>> endobj
81 0 obj <<
/Length1 1296
/Length2 6904
/Length3 532
/Length 7708      
/Filter /FlateDecode
>>
stream
xe\m	RZahEbC;$DSZPD;<ϻG>i=_u^=Lj9%,f`Y8	5 .#äM`PXp" !~\&beH$;BMaeS5U
x
7n\	(W@vt[p9`p$ep`Ad$ZaP7[F)!?:C*vkHmj3P[a
6e?S(\fxe8B`5`i
um,SjnKUTc}S3nT+oft!H>?zj!n@?,H#P)LpGܿm3/uKp&!; 0?඄;;cpK&T?$JM(A
	PҔ~ [74CB@oBM ߄P5!r0J?AɶQ_Q=@!@:
D@T_Q@Te?5@:yQݒp'	nӂAҨj!;A}8fK3`sܯp6JeFK%cT>OƢCؖjt.Rױ]iZ<Շd|bn]LSitS~?9"joq&{kpk\\<}J6<5c=m6
c磏ȋJklH1$&EMdM
|[VrY/pZR5qqY}TnE/
蹑=fˢ>#cw|/sCMU"2"㐛ؐ'BYa5r$p!@W)
PvdgRO" 'W%>jv2S=	p }D6ϻG|54dVP;Ҿ7r45QrK߾[w!r8F{-Sv[[iNm՗gL3 5/o-⡒ohy/&ZYs^UZZEF@Yr\Z9gV7wa9"Bi±E^Dݟ,}bkU;,rzZ&/UИ~S.ysmܪexoV#r:_.  -η-o%jȯTb'4)F]w#J?,"Uq6*dI5?zκq#K|_1js-a)0^`%U#PU`n$_6TUl:QbDY:N^wBZ`D0*>Ѓ.ؙWsjot5z>.CGON1Q#c-Eǘ}ɢEUg$)4|A?.U_t€ri_X/SɎ̙/~t?+GS8V xY7s~#K?ZrynV+3K'*d,HqY}GBW{M#kpwT+nT%`fbמB/2)1H֫>o92q`]>I,-l:]I68
)J
!vBb8zTRW/Qn- i([82}|9ϧLNbЗIU澣Ō-xqfV!<ܦƮc/7䕃>z2㜍a$fZRp_ݾMS&Q'};1J+L;Of
Y\.):oZaRqbI0Q vyH54OL!@gKw<E+aڽ/4,<!Dz|#fgJbAO3%W'Sj,.ս3SoNpKnD?)686%2{vO$ o{	(ӫ\ȸW˦Zy~NV)0F
tah%ᨤ17}VaZ#t#yW:{ZP?QO릒!\Nm|lM|g&Ztcze87
r
h<.&V픓"h"ެ=mnT@7Z;|;V1|Ar	2,AJ/٭Ю#_ܳX#_>A[4m+ qKqYuKn ӹms"l;dja`)O;)f azgBc-2vs<]b3$nNw0Mf23ڢ'bY/4|Qru˸NwlJfyQIsO2ru-D-I],ݐP=8f<q/ZU=i
HƑbʩf֨84>TU\'W
k$j]kL'K*BT(@	m>s3:rux9rG|!5+agq3~9~!bׇ-a.I{wP 2㧧Q/,}R˺[kexsԸ{-s>xTJ*niAyAGPwӿTVM/!_ή
s}OE\DvBZ9m.gkw?cX_^ڋ5#(}m]5_K#EB|¶U!s9볁a,_*_d]JʌӸ>Ʈ[JGk`ȋoK)ƍ!:6XMvK{Q|=C5WS_4H.޵к=lz pPtOYHݍʭE5%@9vo֖"2B<6'{?Ch)wU#&6!ӕ,0eh6epG-э]V&X亖6&iv:A5WŘ3'@^֕3T4oqӢKxf'"\PԶC"Rc񧐮F}MlB\ܡC:j+UJ7>U0m9&=o>s%FQ(
w}!A?Or˰&n筒U}[Fջ5n+AGzuSYmccLZdTEQ+
*#,
e$b)o_p*b6u'h8%>Yf;%/j߅,oqEED%tFiA*-h>ݢgVB&tPni#UH~n0#Э&,+09-Ջ>->xp>Ok]&SYrvν/4N(@g4;Re*Xӫg>՛DR_ \e3t}݅j'=x(3?=*LSBzn 0;1k=2Zj^MV݌˾?]&MvH=Qv8ppwY jh9Zn_g]q:)]@u~A4/Y`OJn-z=A`DN
<`L]VUqzLmm>-yه[1
HO2"fE`=o9gIru]RS<$/t:^YoOb
I;LDBqAJ؟g
OC!b󟭀8)ϿIZ^=KC?͋@hX]z()|nf~.e|3	-]}ێߝ[##j!;iPnh>Ͻe&FvqJS8a\}}ț$Eod
d3rϓwʿ'b.oZĊxH6ɼOίbNe/\u5gՕtF@hh5^C2̼nG啳K^>3v/8]\ÈlD4+uĦ%&
	A4}^ȩ{E?৲wJbQ^0;lG'wEUuw{*s2FCw#ﱁD&eМr{w̞9뎵Om杓߸\LwBe.	.f'|=*AY&Kkm
/ˋlt25V=}k{5^.	cBScɡm,Ě"#߶s)Y]RISc[ս%xhl1GF=ͫy-N'gІQ!̃S~wfuQS8<5]>"L|ţI&QdH3D+$om	1/lal&iQNdN{nHHTH@UOF~!u0{HN`T@вdm$tyFgS>"N
壄DQM/쮈n`
y(}?i抓:jE3&`1\&+Ak7`~l24SšWugUV'^zY؅z8<*REo
ǖB-?JH
VTqT6,7}bPWB06)]hħdav1HL
{;ėR7q0L_-EfyH?BVUv&[_|MfdЭpV*l|Qr!:SÉ&R9SQU)õ|'xw$6iR'?5!+՞̷	.,56G٠5$qi;9ތДє6.pu2O1L:W(AS󾭶6߆8mFyh+l(tpuu~Wc@b!csOX^N{؊lVv*][ c`N͗'xlgb> endobj
80 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName /UYKJFZ+CMR12
/ItalicAngle 0
/StemV 65
/XHeight 431
/FontBBox [-34 -251 988 750]
/Flags 4
/CharSet (/comma/period/zero/one/two/four/A/E/F/J/K/L/M/N/Q/R/S/U/W/a/c/d/e/f/g/h/i/l/m/n/o/r/s/t/u/v/y)
/FontFile 81 0 R
>> endobj
272 0 obj
[272 0 272 0 490 490 490 0 490 0 0 0 0 0 0 0 0 0 0 0 0 734 0 0 0 666 639 0 0 0 503 761 612 897 734 0 0 762 721 544 0 734 0 1006 0 0 0 0 0 0 0 0 0 490 0 435 544 435 299 490 544 272 0 0 272 816 544 490 0 0 381 386 381 544 517 0 0 517 ]
endobj
271 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 44/comma 45/.notdef 46/period 47/.notdef 48/zero/one/two 51/.notdef 52/four 53/.notdef 65/A 66/.notdef 69/E/F 71/.notdef 74/J/K/L/M/N 79/.notdef 81/Q/R/S 84/.notdef 85/U 86/.notdef 87/W 88/.notdef 97/a 98/.notdef 99/c/d/e/f/g/h/i 106/.notdef 108/l/m/n/o 112/.notdef 114/r/s/t/u/v 119/.notdef 121/y 122/.notdef]
>> endobj
78 0 obj <<
/Length1 1091
/Length2 4634
/Length3 532
/Length 5355      
/Filter /FlateDecode
>>
stream
xW\S[7kBG*"Ezo!@ $!A
RJ*H&""HUAzyyߜrkoC!R22*	ic`X8
㊅2.O@FQRWTD#h#I	0p+0rz|	PW`a`i@f`0L ]FFpCaZ
a	QI1`D01PFpaz%E`a j
ӝU+ =0g±P/!mй_@VF_wkZ#ÄaA=X!$޿UM	EÑ"@
@GÂX2H+W@^h/"!ߤ&e02dDp?t	A&0ao(`ǾA)G(8LkV3YPy/hC_j1|}}@y&+ݥ=3JrXj7SzN:r(ӧuZ9I_S};ղ&91g$\n{x3+_[RCgy2<zRpjm)mI2?aaϮ3(鱹IR{i[}t+Kz\\dzi">ޞ\qaoQimeN;47_ۭ|,ǘq?\e(VcR=\rcÁl$m-s/h|*4imlL0	PY8==2aR/62Wژ[brY>
k5Sx=0r-.Y^Te㷔yΊ|COO.XvCU6*nM;BNd*Xa%!;i=ޜw~4I;׷!q^psv1L9hw_{rlL,)jhWfҽ~PElrZkT7(*:J''zY]rj޲{bc C/)	'
<9oa׽#q_4g@Y#bDeU]Nѵ-%$Lq_7ߟ#.	Eȳ^'E\Lr»Z'Ͽ,f=~QʢkB·8Q&ReOdF5Tծ]93~i]|ap!ɗ^棖}csg2c#Xp[xFEKD)~CEQyK8"x07
v8+4ԔTØ@];tZ%WaПUG?g&C3͎l/hXZ.<6ר3#(ja|пsͨ=&ԉ)a۴	GgBm]S٤84fDYgQ!ڔT¦軿$$Ċ^ʬR|ZAGt~ggROD{߷f{}Е_x"IwT}P/N;	ЈZV
I5x(Hf?7gp^󽺀X{UE
N&TޢR>pwF]sn!8hxfm.6<JTuiT+NeFŜڑq&^1m 2{E1V5G?h&mZu5bC֊LpA۟)-(w73Q&)罜B.O_[j-61A@AfuNB5ryHd{v%S/-ZvcY)%pwmK%%wb{U3ScShlu)с4H5ד({kcixN6V$#OE.oѧlu7̘_^nq'ioWR࿫ATRY2mߛ&PQert>]f-JG#~`t27JH1?/0A@G;FjuvC˓T}vz+xfIKU%Ly7Xf4xSe1vs'N9Ua!0HЙiEʦz$O<[S+MQ]]7FW[duw@#Wm"n;?+&՟q,.Sw4!w`PاΔQ=-6xiRos{|;	U]ڻ:jWӪ1^n9q94Gr^l]I& ȗJ-s/5|gx/iF%q:!֏IdTXhQLRfL4o$lWX27=p.6.1Ncbsj	^pwǕˑ{눾Āfzyw^=N=wEAM#;Tn]ovco(WjpYwZC<|+)6sT+s,AjeY;/-6m 4!w[XTVCK>vYK8pF|ՄP3ƛ
3V?:8==g?MF;OL'L:s;M=KJYLhv;OHNA̎MXc}`W;CH^Ifڏ#KPFTFG<@ܳ.Y&p2K"miOo㚒4ړ;4ۛo\eV=K;/T5}*[e
:|L^ĵWɔ
=R_MjgУC$\Y{ROcg_CdTִ)8
dp={oH|-h2PdʛF}5	;}G9;j?ƿ`lEW2skD;Ji`_^zRG|GGfo66=^fSD9fNH2RsN{HaS_y![tJ(qҹFqH(.oJopyO^F;m&ZЙ^Yq3ӹS5ẘ=uόFsٖ>`EG֋Źu{&O<׍|]er}7SXU
pLݴY	QU9qsO0]r55^%Sӄ"Z8eM9HL4ԫ 2Q!zVsb3H &~OQ~TՉo-gXIS0lw=49}5ń0j1yZyz41=o}1<|6"xɓ'Oi/^|%b{nR'IR!)o,U!.~fhIV8ɭ[|ek
vp
WyrşZîcjw{)H#M\woFk}`AGfK4&жK=~pzR|MN6Eu-۪Eⓐs
>QQ6\r
_xeazfg,Zd^[}%k-g*qs
7f2;aSx-Vrp&X⭬Jqng4B®bf8\U/nG:ƾwǰR>rlnz6=?Ҹw@0h._#$	(|]1>4+endstream
endobj
79 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 273 0 R
/FirstChar 45
/LastChar 121
/Widths 274 0 R
/BaseFont /IVTMAA+CMCSC10
/FontDescriptor 77 0 R
>> endobj
77 0 obj <<
/Ascent 514
/CapHeight 683
/Descent 0
/FontName /IVTMAA+CMCSC10
/ItalicAngle 0
/StemV 72
/XHeight 431
/FontBBox [14 -250 1077 750]
/Flags 4
/CharSet (/hyphen/A/D/M/P/R/a/c/d/e/h/i/l/m/o/p/r/s/t/u/v/x/y)
/FontFile 78 0 R
>> endobj
274 0 obj
[378 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 814 0 0 829 0 0 0 0 0 0 0 0 989 0 0 742 0 800 0 0 0 0 0 0 0 0 0 0 0 0 0 0 613 0 591 624 558 0 0 613 302 0 0 513 747 0 636 558 0 602 458 591 613 613 0 613 613 ]
endobj
273 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 45/hyphen 46/.notdef 65/A 66/.notdef 68/D 69/.notdef 77/M 78/.notdef 80/P 81/.notdef 82/R 83/.notdef 97/a 98/.notdef 99/c/d/e 102/.notdef 104/h/i 106/.notdef 108/l/m 110/.notdef 111/o/p 113/.notdef 114/r/s/t/u/v 119/.notdef 120/x/y 122/.notdef]
>> endobj
75 0 obj <<
/Length1 979
/Length2 3258
/Length3 532
/Length 3924      
/Filter /FlateDecode
>>
stream
xWXS붆I5	= Uz +1DBҤJY UA:R$"Ho"EA@H,/ϹϞfc|c3?yM-$ԝ1jN5A!Oyzů8(/<=-hTZD%gٲ7rĨO@dZ
	j3}`(]9t|U5GyVaiIpQvm1w9Dr'.Xb
]bk$N~
&+CnTr?dGF.쎞9܍7YYjyT|/օ\1QKJ_;mROɯԨ_!Ҵ>r#ǛBؽ\>Ck;;/fx*b[*dਟa\4+KI9/.3m=j>I;<"qRXe)oͭ[:Ih9u͊E~AVwM˵=nr+tqŝܚZ!8sGvu
e1IJcScCfh"2y@G-TN@]\H!5l`(.#wmW6?<~*[)ƒbnk>Clm0x#SEJss|F m]!;#
O\9)}z܎UYSm5׳Ixqܠ8?~a&gRaA(8fϔtZ|4F~4r,دȣ~3L,o*jPg"wBZ4!A6DؖX9ڭI4ˌnbA-URWjeHA7[Ngxs[oqC6Du:S;r/0b}jϮxnz4#YfdHc;se%ۃ{47h_*]?5nu^Jъlp§etOQSωI8%7SIZr<̑LOIw3hP<)o韟PVswl:̴frU]H=OR/nKNe'0gʥَ7Z^6}rJUy*=o9	}XH)He4`NՍl(x;%UO,@CNn1`Uqhٵ{l!8ʿ:Z
,mE@Lnu~C}a)6^4}F4&)Ysy*nNWjTS6ՒkE3OXD\\T?d`lC+-N>M13u˹M1Aѝe?%Ջ45&::u1HrOkS˂{&!}3iR/y,#BEnz*\N{i1}!쓳R%TY*CP%y3ePS3QNgRgGx˵73#͉vc7W71='w `ȱAhApIf0R!"}Lv
tڸ5pΝO_@s79L$p5^|r	Pb#1Mucr,	R{Å
sڍ'mC/dC,J4ԆŽNU"XW/vA9lx0pe:3Éx拦)VyJ19i{:R2yvh<1^2?AIw
/endstream
endobj
76 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 275 0 R
/FirstChar 58
/LastChar 118
/Widths 276 0 R
/BaseFont /PSOFPR+CMR17
/FontDescriptor 74 0 R
>> endobj
74 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -195
/FontName /PSOFPR+CMR17
/ItalicAngle 0
/StemV 53
/XHeight 431
/FontBBox [-33 -250 945 749]
/Flags 4
/CharSet (/colon/A/D/E/O/S/a/c/d/e/h/l/n/o/r/v)
/FontFile 75 0 R
>> endobj
276 0 obj
[250 0 0 0 0 0 0 693 0 0 707 628 0 0 0 0 0 0 0 0 0 720 0 0 0 511 0 0 0 0 0 0 0 0 0 0 0 0 0 459 0 406 511 406 0 0 511 0 0 0 250 0 511 459 0 0 354 0 0 0 485 ]
endobj
275 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 58/colon 59/.notdef 65/A 66/.notdef 68/D/E 70/.notdef 79/O 80/.notdef 83/S 84/.notdef 97/a 98/.notdef 99/c/d/e 102/.notdef 104/h 105/.notdef 108/l 109/.notdef 110/n/o 112/.notdef 114/r 115/.notdef 118/v 119/.notdef]
>> endobj
72 0 obj <<
/Length1 1261
/Length2 5931
/Length3 532
/Length 6724      
/Filter /FlateDecode
>>
stream
xgX[!4Az';H/J3@@wz ]DJE:'k}[z_ɟcg1g(`" API$	
sp( `wvA ("IȈˈIs.>(ȭW$Pق@a
0 P
hq$c_r]7;ȡ&bdtS=qMʚ|h=G˽_a;ͳ?vűuWFi_q+m,b{6>4ŚGEsPfŢ(Rp'[T%8vc&Oo;4$co_j.vֵ\[cu|t=N̲#?U3S3ty~̑ÙݎȜW2ORUZWY=$!Ͼ5-'Vix\ݢY
D|;QZzFvtYF=fOv	N%_Ŗ4
}"NY"Cf(Z,PɊɳxIPϷJ"@h`UaO#Cћ@!.qqj'n:#{| yшK!A@3:)LNҲѱ+IEYEe'޿[ j⹫(iW-ѭ\fj2uT7
83"!s7Fca&ڼC?K8576\U;c)5iH[R$T.n+h:B-BmmQpW?.Ɩk(28	ŁE()uPmF6.>T>7v"y({gt+=^?D?u$*2$)J,cğğQW!'AGUy8*
.>hyʧc,ەktQ:{'C_׌P.#)cC\|L&\O>-Q½m>πsjm(ddi99]1,z$
D-UP`?@}w
\D[x5TJV^wQI2"B[YDO~`ܧ]>[sLA
ްsYm$_'v7k=+F
>7N-otܼ%p<͠&fm^q6J:bߑ65x.jw/xUチ].MfRh.(N;${mMn)\eHS`x؁l'w@D~f9+ޚv]rV1}:(3PtؕseeB{hlGh
Kطy4Y4hեg˳M>sۋ7,K5+ .szIҕ>VKsk!=i,n'T}?>SyU:YQ{v.m'h)
yD'oG{ݍQϴfҖgvH:e<_%]D:d1vzoRLrڊ&#fp="2j'fd#ON4
]lcGѬa:h
7UE>$&uWCG\փW饷 hP-?.E+wobz/Wm9?N֪U{
|.Y8kR^R\[Js5KRTKKVrA/Oߔmlz6Wg
!t 	e5%咾Tb]1*ޟ|)LUVJu~H7e0`ՅhJf I|SCY^P6â-
Op=[{j#rwQ֛0nȳ*;I=
6W&tw*Gk<9Vw4U<~h5~g}αOhaTHvPj;EiDs]}x+Rh$~Cϕ.g	WݹM23!/2b(n|]l^_H
5:Ǝ8_OhQ5o%pL|k
?BKFh򄠮=,NjparU)Y'װ{i=,p뎛SJ;8yCjhA}n4mYnށT(˼3pOoXDuneg~apٗuH=0^Z@,7C'r히}8Æ68D X;k:OGm]vIG%Fⳗ	G6|a%"-_#(kbpgO\Ǚh!w4`vn0
Q
epT3'Im'awhn_rFksE
-- ?ܘ!#hJF,Uu*pX'\mSO'ɵ?A]Ԃr
]
LT5+@6xsG=1#i#Mb>Oޡ(mΕTg%hۅm>Fl}K֨yhSO4䀪ZTnGfTG?nW
%LO zw䮸ZX!
Y/tA_^wdQm@xH6ne"
|v
h"z%\CXpɎZ؛??8f==R<!>k9z@gjs:	zX?.:wV]ZW2)slRo	EJ3]_0ʛ.?|Jmjv[ػ/CʎPlkXCٺ{n͂QK8NgU;vN|mܷ揌gz_se,g鼘@G}1
"ei;w=ɘȒYx G
p~~I.K,ۀ4m#EVm`ʵK:5C)c,u\qOAKM>'~2P#W.yJe!8gg±Giylz dy9w>@pӣ&t	m%kZz"n\VмŞ=P.n/NL\=GEJİ*
[?]6S6*ω秧`깂3Lwe3*ˮlNְjiTS-"jjz۲}xq	8Sͫ`93dndt͖+,ő}3z Xq-l8{ǡzrahAmNVBB;8O5
^5?V4{=z/Ӈ0&`sXUa݀I/}Jm!XE=Ƴ!92"+O;;	f۾<5?tWczt|S0[Y#&\Usphc"$pSc)퓬ޗjZ]OR\	DX&[rJBq ejM$@G+(Y&Ty[rGyiL;Bn	<ɃoEu95y]wwc[OU>`c:Qd%vLW{ᩑZ&jP&!ea*EvىGY"dF	t&Y=Rf/Fѽ|4$`ݬ-V͘/8cG(<<4K,p_OaFŔeůgN]{h5<9Uy`ͦ&S`lQ2:N\>@KLhIT?qUGfw4<#E
*-"zVڂncZR{):9L5n3	64Aq:f?U?v%cZ|RXGHeb-{Yci>cWv9@肤ϯm6pqzDWPi bH+Nw>ZLـR%6[!I#
.x99bӲ")ԃ7^d
#332X372pJ10IbZJy,m?~W-F#('`endstream
endobj
73 0 obj <<
/Type /Font
/Subtype /Type1
/Encoding 277 0 R
/FirstChar 46
/LastChar 119
/Widths 278 0 R
/BaseFont /FTPLQF+CMTT12
/FontDescriptor 71 0 R
>> endobj
71 0 obj <<
/Ascent 611
/CapHeight 611
/Descent -222
/FontName /FTPLQF+CMTT12
/ItalicAngle 0
/StemV 65
/XHeight 431
/FontBBox [-1 -234 524 695]
/Flags 4
/CharSet (/period/slash/zero/one/five/six/colon/at/D/E/F/J/O/S/W/a/c/e/g/h/i/k/l/m/n/o/p/q/r/s/t/u/v/w)
/FontFile 72 0 R
>> endobj
278 0 obj
[515 515 515 515 0 0 0 515 515 0 0 0 515 0 0 0 0 0 515 0 0 0 515 515 515 0 0 0 515 0 0 0 0 515 0 0 0 515 0 0 0 515 0 0 0 0 0 0 0 0 0 515 0 515 0 515 0 515 515 515 0 515 515 515 515 515 515 515 515 515 515 515 515 515 ]
endobj
277 0 obj <<
/Type /Encoding
/Differences [ 0 /.notdef 46/period/slash/zero/one 50/.notdef 53/five/six 55/.notdef 58/colon 59/.notdef 64/at 65/.notdef 68/D/E/F 71/.notdef 74/J 75/.notdef 79/O 80/.notdef 83/S 84/.notdef 87/W 88/.notdef 97/a 98/.notdef 99/c 100/.notdef 101/e 102/.notdef 103/g/h/i 106/.notdef 107/k/l/m/n/o/p/q/r/s/t/u/v/w 120/.notdef]
>> endobj
115 0 obj <<
/Type /Pages
/Count 6
/Parent 279 0 R
/Kids [66 0 R 120 0 R 152 0 R 159 0 R 163 0 R 167 0 R]
>> endobj
174 0 obj <<
/Type /Pages
/Count 6
/Parent 279 0 R
/Kids [171 0 R 176 0 R 180 0 R 184 0 R 188 0 R 204 0 R]
>> endobj
218 0 obj <<
/Type /Pages
/Count 4
/Parent 279 0 R
/Kids [208 0 R 220 0 R 233 0 R 237 0 R]
>> endobj
279 0 obj <<
/Type /Pages
/Count 16
/Kids [115 0 R 174 0 R 218 0 R]
>> endobj
280 0 obj <<
/Type /Outlines
/First 7 0 R
/Last 63 0 R
/Count 8
>> endobj
63 0 obj <<
/Title 64 0 R
/A 61 0 R
/Parent 280 0 R
/Prev 59 0 R
>> endobj
59 0 obj <<
/Title 60 0 R
/A 57 0 R
/Parent 280 0 R
/Prev 55 0 R
/Next 63 0 R
>> endobj
55 0 obj <<
/Title 56 0 R
/A 53 0 R
/Parent 280 0 R
/Prev 35 0 R
/Next 59 0 R
>> endobj
51 0 obj <<
/Title 52 0 R
/A 49 0 R
/Parent 43 0 R
/Prev 47 0 R
>> endobj
47 0 obj <<
/Title 48 0 R
/A 45 0 R
/Parent 43 0 R
/Next 51 0 R
>> endobj
43 0 obj <<
/Title 44 0 R
/A 41 0 R
/Parent 35 0 R
/Prev 39 0 R
/First 47 0 R
/Last 51 0 R
/Count -2
>> endobj
39 0 obj <<
/Title 40 0 R
/A 37 0 R
/Parent 35 0 R
/Next 43 0 R
>> endobj
35 0 obj <<
/Title 36 0 R
/A 33 0 R
/Parent 280 0 R
/Prev 31 0 R
/Next 55 0 R
/First 39 0 R
/Last 43 0 R
/Count -2
>> endobj
31 0 obj <<
/Title 32 0 R
/A 29 0 R
/Parent 280 0 R
/Prev 15 0 R
/Next 35 0 R
>> endobj
27 0 obj <<
/Title 28 0 R
/A 25 0 R
/Parent 15 0 R
/Prev 23 0 R
>> endobj
23 0 obj <<
/Title 24 0 R
/A 21 0 R
/Parent 15 0 R
/Prev 19 0 R
/Next 27 0 R
>> endobj
19 0 obj <<
/Title 20 0 R
/A 17 0 R
/Parent 15 0 R
/Next 23 0 R
>> endobj
15 0 obj <<
/Title 16 0 R
/A 13 0 R
/Parent 280 0 R
/Prev 11 0 R
/Next 31 0 R
/First 19 0 R
/Last 27 0 R
/Count -3
>> endobj
11 0 obj <<
/Title 12 0 R
/A 9 0 R
/Parent 280 0 R
/Prev 7 0 R
/Next 15 0 R
>> endobj
7 0 obj <<
/Title 8 0 R
/A 5 0 R
/Parent 280 0 R
/Next 11 0 R
>> endobj
281 0 obj <<
/Names [(Doc-Start) 70 0 R (Item.1) 211 0 R (Item.10) 225 0 R (Item.11) 226 0 R (Item.12) 227 0 R (Item.13) 228 0 R (Item.14) 229 0 R (Item.15) 230 0 R (Item.16) 231 0 R (Item.2) 212 0 R (Item.3) 213 0 R (Item.4) 214 0 R (Item.5) 215 0 R (Item.6) 216 0 R (Item.7) 217 0 R (Item.8) 223 0 R (Item.9) 224 0 R (cite.CATHODE) 142 0 R (cite.CRACK-doc) 150 0 R (cite.FJW1) 144 0 R (cite.FJW2) 145 0 R (cite.Hearn-manual) 116 0 R (cite.MacCallum-ISSAC) 118 0 R (cite.MacCallum-doc) 117 0 R (cite.Man) 147 0 R (cite.Man-MacCallum) 148 0 R (cite.Prelle-Singer) 149 0 R (cite.Zimmermann) 143 0 R (cite.Zwillinger) 146 0 R (page.1) 69 0 R (page.10) 186 0 R (page.11) 190 0 R (page.12) 206 0 R (page.13) 210 0 R (page.14) 222 0 R (page.15) 235 0 R (page.16) 239 0 R (page.2) 122 0 R (page.3) 154 0 R (page.4) 161 0 R (page.5) 165 0 R (page.6) 169 0 R (page.7) 173 0 R (page.8) 178 0 R (page.9) 182 0 R (section*.1) 87 0 R (section*.2) 240 0 R (section.1) 6 0 R (section.2) 10 0 R (section.3) 14 0 R (section.4) 30 0 R (section.5) 34 0 R (section.6) 54 0 R (section.7) 58 0 R (section.8) 62 0 R (subsection.3.1) 18 0 R (subsection.3.2) 22 0 R (subsection.3.3) 26 0 R (subsection.5.1) 38 0 R (subsection.5.2) 42 0 R (subsubsection.5.2.1) 46 0 R (subsubsection.5.2.2) 50 0 R]
/Limits [(Doc-Start) (subsubsection.5.2.2)]
>> endobj
282 0 obj <<
/Kids [281 0 R]
>> endobj
283 0 obj <<
/Dests 282 0 R
>> endobj
284 0 obj <<
/Type /Catalog
/Pages 279 0 R
/Outlines 280 0 R
/Names 283 0 R
 /PageMode /UseOutlines /URI << /Base () >>  /ViewerPreferences << >> 
/OpenAction 65 0 R
>> endobj
285 0 obj <<
/Producer (pdfTeX-0.14f)
 /Author () /Title () /Subject () /Creator (LaTeX with hyperref package) /Producer (pdfTeX14.f) /Keywords () 
/Creator (TeX)
/CreationDate (D:20010814173600)
>> endobj
xref
0 286
0000000001 65535 f 
0000000002 00000 f 
0000000003 00000 f 
0000000004 00000 f 
0000000000 00000 f 
0000000009 00000 n 
0000006489 00000 n 
0000184010 00000 n 
0000000054 00000 n 
0000000084 00000 n 
0000011764 00000 n 
0000183924 00000 n 
0000000129 00000 n 
0000000160 00000 n 
0000015039 00000 n 
0000183799 00000 n 
0000000206 00000 n 
0000000239 00000 n 
0000015100 00000 n 
0000183725 00000 n 
0000000290 00000 n 
0000000345 00000 n 
0000018182 00000 n 
0000183638 00000 n 
0000000396 00000 n 
0000000436 00000 n 
0000023483 00000 n 
0000183564 00000 n 
0000000487 00000 n 
0000000537 00000 n 
0000031828 00000 n 
0000183476 00000 n 
0000000583 00000 n 
0000000615 00000 n 
0000035774 00000 n 
0000183351 00000 n 
0000000661 00000 n 
0000000699 00000 n 
0000035835 00000 n 
0000183277 00000 n 
0000000750 00000 n 
0000000795 00000 n 
0000039756 00000 n 
0000183166 00000 n 
0000000846 00000 n 
0000000894 00000 n 
0000039817 00000 n 
0000183092 00000 n 
0000000950 00000 n 
0000001010 00000 n 
0000044279 00000 n 
0000183018 00000 n 
0000001066 00000 n 
0000001127 00000 n 
0000048430 00000 n 
0000182930 00000 n 
0000001173 00000 n 
0000001211 00000 n 
0000057472 00000 n 
0000182842 00000 n 
0000001257 00000 n 
0000001286 00000 n 
0000057533 00000 n 
0000182767 00000 n 
0000001332 00000 n 
0000001371 00000 n 
0000002958 00000 n 
0000006548 00000 n 
0000001421 00000 n 
0000006309 00000 n 
0000006369 00000 n 
0000181400 00000 n 
0000174396 00000 n 
0000181240 00000 n 
0000173713 00000 n 
0000169511 00000 n 
0000173554 00000 n 
0000168739 00000 n 
0000163103 00000 n 
0000168578 00000 n 
0000162191 00000 n 
0000154204 00000 n 
0000162032 00000 n 
0000003231 00000 n 
0000153302 00000 n 
0000144977 00000 n 
0000153142 00000 n 
0000006429 00000 n 
0000003424 00000 n 
0000143928 00000 n 
0000132678 00000 n 
0000143768 00000 n 
0000003580 00000 n 
0000003736 00000 n 
0000003892 00000 n 
0000131176 00000 n 
0000114284 00000 n 
0000131017 00000 n 
0000004052 00000 n 
0000004212 00000 n 
0000004372 00000 n 
0000004529 00000 n 
0000004686 00000 n 
0000004846 00000 n 
0000005007 00000 n 
0000005174 00000 n 
0000005341 00000 n 
0000005498 00000 n 
0000005654 00000 n 
0000112997 00000 n 
0000101038 00000 n 
0000112835 00000 n 
0000005811 00000 n 
0000005975 00000 n 
0000006141 00000 n 
0000182281 00000 n 
0000062307 00000 n 
0000062431 00000 n 
0000062369 00000 n 
0000011825 00000 n 
0000009887 00000 n 
0000006726 00000 n 
0000011702 00000 n 
0000010098 00000 n 
0000010258 00000 n 
0000010420 00000 n 
0000010577 00000 n 
0000010734 00000 n 
0000010897 00000 n 
0000011053 00000 n 
0000011219 00000 n 
0000011385 00000 n 
0000100331 00000 n 
0000098062 00000 n 
0000100170 00000 n 
0000011547 00000 n 
0000096938 00000 n 
0000084047 00000 n 
0000096776 00000 n 
0000083408 00000 n 
0000080144 00000 n 
0000083245 00000 n 
0000062245 00000 n 
0000062617 00000 n 
0000062803 00000 n 
0000062865 00000 n 
0000062927 00000 n 
0000062493 00000 n 
0000062555 00000 n 
0000062679 00000 n 
0000062741 00000 n 
0000015161 00000 n 
0000014858 00000 n 
0000011971 00000 n 
0000014977 00000 n 
0000079447 00000 n 
0000073956 00000 n 
0000079285 00000 n 
0000018243 00000 n 
0000018001 00000 n 
0000015306 00000 n 
0000018120 00000 n 
0000019556 00000 n 
0000019375 00000 n 
0000018388 00000 n 
0000019494 00000 n 
0000023544 00000 n 
0000023302 00000 n 
0000019665 00000 n 
0000023421 00000 n 
0000027908 00000 n 
0000027727 00000 n 
0000023676 00000 n 
0000027846 00000 n 
0000182397 00000 n 
0000031889 00000 n 
0000031647 00000 n 
0000028029 00000 n 
0000031766 00000 n 
0000035896 00000 n 
0000035593 00000 n 
0000032022 00000 n 
0000035712 00000 n 
0000039878 00000 n 
0000039575 00000 n 
0000036016 00000 n 
0000039694 00000 n 
0000044340 00000 n 
0000044098 00000 n 
0000040011 00000 n 
0000044217 00000 n 
0000073520 00000 n 
0000070216 00000 n 
0000073359 00000 n 
0000069897 00000 n 
0000067831 00000 n 
0000069738 00000 n 
0000067425 00000 n 
0000065073 00000 n 
0000067266 00000 n 
0000064648 00000 n 
0000063133 00000 n 
0000064489 00000 n 
0000048491 00000 n 
0000048249 00000 n 
0000044524 00000 n 
0000048368 00000 n 
0000051753 00000 n 
0000051140 00000 n 
0000048675 00000 n 
0000051259 00000 n 
0000051321 00000 n 
0000051383 00000 n 
0000051445 00000 n 
0000051506 00000 n 
0000051568 00000 n 
0000051629 00000 n 
0000051691 00000 n 
0000182514 00000 n 
0000055155 00000 n 
0000054416 00000 n 
0000051873 00000 n 
0000054535 00000 n 
0000054597 00000 n 
0000054659 00000 n 
0000054721 00000 n 
0000054783 00000 n 
0000054845 00000 n 
0000054907 00000 n 
0000054969 00000 n 
0000055031 00000 n 
0000055093 00000 n 
0000057594 00000 n 
0000057291 00000 n 
0000055263 00000 n 
0000057410 00000 n 
0000062989 00000 n 
0000060802 00000 n 
0000057727 00000 n 
0000062121 00000 n 
0000062183 00000 n 
0000060981 00000 n 
0000061175 00000 n 
0000061370 00000 n 
0000061535 00000 n 
0000061744 00000 n 
0000061909 00000 n 
0000064979 00000 n 
0000064857 00000 n 
0000067708 00000 n 
0000067634 00000 n 
0000070128 00000 n 
0000070100 00000 n 
0000073813 00000 n 
0000073729 00000 n 
0000079877 00000 n 
0000079695 00000 n 
0000083822 00000 n 
0000083630 00000 n 
0000097633 00000 n 
0000097285 00000 n 
0000100857 00000 n 
0000100582 00000 n 
0000113779 00000 n 
0000113443 00000 n 
0000132129 00000 n 
0000131712 00000 n 
0000144619 00000 n 
0000144273 00000 n 
0000153866 00000 n 
0000153610 00000 n 
0000162727 00000 n 
0000162476 00000 n 
0000169201 00000 n 
0000168981 00000 n 
0000174115 00000 n 
0000173941 00000 n 
0000181920 00000 n 
0000181684 00000 n 
0000182615 00000 n 
0000182693 00000 n 
0000184082 00000 n 
0000185409 00000 n 
0000185448 00000 n 
0000185486 00000 n 
0000185662 00000 n 
trailer
<<
/Size 286
/Root 284 0 R
/Info 285 0 R
>>
startxref
185868
%%EOF
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odelin.red0000644000175000017500000006565511526203062024313 0ustar  giovannigiovannimodule odelin$  % Simple linear ODE solver

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <14 September 2000>

% Based in part on code by Malcolm MacCallum.

% TO DO:

%   Polynomial solutions for polynomial coeffs.

%   Check the distinction between finding a solution technique for an
%   ODE that then fails internally to solve it (e.g. failing to solve
%   an auxiliary equation) and failing to find a solution technique.
%   (Should the former be handled by `odefailure'?)


%% Techniques implemented
%% ======================
%%   First order (integrating factor)
%%   Constant coefficients
%%   Euler and shifted Euler
%%   Exact
%%   Trivial order reduction (dep var and low-order derivs missing)

%%   Second-order special function ODEs (module odespcfn)

%% Notes: Overall factors are handled in most cases by making the ODE
%% "monic".


%% Internal representation
%% =======================

%% A linear ode is represented by its list of coefficient functions
%% (odecoeffs), driver term (driver), and dependent (y) and
%% independent (x) variables.  The maximum (ode_order) and minimum
%% (min_order) derivative orders are included in the representation
%% for efficiency/convenience.  Its solution is represented as a basis
%% for the solution space of the reduced ODE together with a
%% particular integral of the full ODE.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%% algebraic procedure odesolve(ode, y, x);
%%    %% Temporary definition for test purposes.
%%    begin scalar !*precise, solution;
%%       ode := num !*eqn2a ode;           % returns ode as expression
%%       if (solution := ODESolve!-linear(ode, y, x)) then
%%          return solution
%%       else
%%          write "***** ODESolve cannot solve this ODE!"
%%    end$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

global '(ODESolve_Before_Lin_Hook ODESolve_After_Lin_Hook)$

algebraic procedure ODESolve!-linear(ode, y, x);
   %% MAIN LINEAR SOLVER
   %% Assumes ODE is an algebraically irreducible "polynomial" expression.
   begin scalar reduced_ode, auxvar, auxeqn, odecoeffs,
         first_arb, solution, driver;
      %% The following decomposition is needed FOR ALL linear ODEs.
      %% The DRIVER is the part of the ODE independent of y, such that
      %% the ODE can be expressed as REDUCED_ODE = DRIVER.
%%       driver := if part(ode, 0) = plus then
%%          -select(~u freeof y, ode) else 0;
      driver := -sub(y=0, ode);
      reduced_ode := ode + driver;
      auxvar := symbolic gensym();
      %% df(y, x, n) => m^n, where m = auxvar
      auxeqn := sub(y=e^(auxvar*x), reduced_ode)/e^(auxvar*x);
      odecoeffs := coeff(auxeqn, auxvar); % low .. high
      traceode "This is a linear ODE of order ", high_pow, ".";
      first_arb := !!arbconst + 1;
      symbolic if not(solution := ODESolve!-linear!-basis
         (odecoeffs, driver, y, x, high_pow, low_pow) or
         (not !*odesolve_fast and
         %% Add a switch to control access to this thread?
         %% It is currently necessary for Zimmer (8).
         << traceode
            "But ODESolve cannot solve it using linear techniques, so ...";
            %% NB: This will probably produce a NONLINEAR ODE!
            %% But, in desperation, try it anyway ...
            (ODESolve!-Interchange(ode, y, x) where !*odesolve_basis = nil)
         >>)) then return;
      %% Return solution as BASIS or LINEAR COMBINATION, assuming a
      %% SINGLE solution since the ODE is linear:
      return if symbolic !*odesolve_basis then % return basis
         if (part(solution, 1, 0) = equal) then
            if lhs first solution = y and % solution is explicit
         (auxeqn := ODESolve!-LinComb2Basis
            (rhs first solution, first_arb, !!arbconst)) then auxeqn
            else << write
               "***** Cannot convert nonlinear combination solution to basis!";
            solution >>
         else solution
      else                              % return linear combination
         if part(solution, 1, 0) = list then
            {y = ODESolve!-Basis2LinComb solution}
         else solution
   end$

algebraic procedure ODESolve!-linear!-basis
   (odecoeffs, driver, y, x, ode_order, min_order);
   %% Always returns the solution in basis format.
   %% Called by ODESolve!-Riccati in odenon1.
   symbolic if ode_order = 1 then
      ODESolve!-linear1(odecoeffs, driver, x)
   else or(
      ODESolve!-Run!-Hook(
         'ODESolve_Before_Lin_Hook,
         {odecoeffs,driver,y,x,ode_order,min_order}),
      ODESolve!-linearn
         (odecoeffs, driver, y, x, ode_order, min_order, nil),
      ODESolve!-Run!-Hook(
         'ODESolve_After_Lin_Hook,
         {odecoeffs,driver,y,x,ode_order,min_order}))$

algebraic procedure ODESolve!-linear!-basis!-recursive
   (odecoeffs, driver, y, x, ode_order, min_order);
   %% Always returns the solution in basis format.
   %% Internal linear solver called recursively.
   symbolic if ode_order = 1 then
      ODESolve!-linear1(odecoeffs, driver, x)
   else
      ODESolve!-linearn
         (odecoeffs, driver, y, x, ode_order, min_order, t)$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Solve a linear first-order ODE by using an integrating factor.
% Based on procedure linear1 from module ode1ord by Malcolm MacCallum.

algebraic procedure ODESolve!-linear1(odecoeffs, driver, x);
   %% Solve the linear ODE reduced_ode = driver, where
   %% reduced_ode = A(x)*(dy/dx + P(x)*y), driver = A(x)*Q(x).
   %% Uses Odesolve!-Int to optionally turn off final integration.
   begin scalar A, P, Q;
      A := second odecoeffs;
      P := first odecoeffs/A;
      Q := driver/A;
      return if P then                  % dy/dx + P(x)*y = Q(x)
         begin scalar intfactor, !*combinelogs;
            traceode "It is solved by the integrating factor method.";
            %% intfactor simplifies better if logs are combined:
            symbolic(!*combinelogs := t);
            P := (P where tan(~x) => sin(x)/cos(x));
            intfactor := exp(int(P, x));
            return if Q then
               { {1/intfactor}, Odesolve!-Int(intfactor*Q,x)/intfactor }
            else { {1/intfactor} }
         end
      else <<                           % dy/dx = Q(x)
         traceode "It is solved by quadrature.";
         if Q then {{1}, Odesolve!-Int(Q, x)} else {{1}}
      >>
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Try to solve a linear ODE of order > 1.
% Based on procedure linearn from module linearn by Malcolm MacCallum.

% If the first integral of an exact ODE has constant coefficients, is
% of Euler type or has trivally reducible order then so does the
% original ODE.  Also, trivial order reduction preserves constant
% coefficients or Euler type, and the reduced ODE is not further
% reducible.  Hence, when the linear ODE solver is called recursively
% to solve a first integral of an exact ODE or a trivially order-
% reduced ODE, the argument `recursive' is used to avoid checking
% again whether it has constant coefficients, is of Euler type or has
% trivially reducible order.

algebraic procedure ODESolve!-linearn
   (odecoeffs, driver, y, x, ode_order, min_order, recursive);
   %% Solve the linear ODE: reduced_ode = driver.
   begin scalar lcoeff, odecoeffs1, driver1, solution;
      %% Make the ODE "monic" as assumed by some solvers:
      %% (Note that this makes algebraic factorization largely
      %% irrelevant!)
      if (lcoeff := part(odecoeffs, ode_order+1)) = 1 then <<
         odecoeffs1 := odecoeffs;
         driver1 := driver
      >> else <<
         odecoeffs1 := for each c in odecoeffs collect c/lcoeff; % low .. high
         %% Could discard last element of odecoeffs1 because it must be 1!
         driver1 := driver/lcoeff
      >>;
      if recursive then goto a;

      %% Test for constant coefficients:
      if odecoeffs1 freeof x then
         return ODESolve!-LCC(odecoeffs1, driver1, x, ode_order);

      traceode "It has non-constant coefficients.";

      %% Test for Euler form:
      if (solution :=
         ODESolve!-Euler(odecoeffs1, driver1, x, ode_order))
      then return solution;

      %% Test for trivial order reduction.  The result cannot have
      %% constant coeffs or Euler form, but it could be first order or
      %% exact or ...
      if min_order neq 0 and ode_order neq min_order and
         %% else would reduce to purely algebraic equation
         (solution := ODELin!-Reduce!-Order
            (odecoeffs, driver, y, x, ode_order, min_order))
      then return solution;

   a: %% Non-trivial solution techniques for recursive calls ...

      %% Test for exact form - try monic then original form:
      if (solution :=
         ODELin!-Exact(odecoeffs1, driver1, y, x, ode_order))
      then return solution;
      if lcoeff neq 1 and (solution :=
         ODELin!-Exact(odecoeffs, driver, y, x, ode_order))
      then return solution;

      %% Add other methods here ...
      %% Null return implies failure.

      %% FINALLY, test for a second-order special-function equation:
      if ode_order = 2 and
         (solution := ODESolve!-Specfn(odecoeffs1, driver1, x))
      then return solution
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Convert between basis and linear combination formats

% Solution basis output format:  { {B1, B2, ...}, PI }
% where {Bi} is a basis for the reduced ODE and PI is a particular
% intergral for the full ODE, which may be absent.
% This corresponds to the linear-combination output format
% y = ( for each B in {B1, B2, ...} sum newarbconst()*B ) + PI.

% This agrees with Maple, e.g. Maple V Release 5 gives
% > dsolve(diff(y(x),x) + y(x) = x, output=basis);
%                          [[exp(-x)], -1 + x]
% > dsolve(diff(y(x),x) + y(x) = x);
%                       y(x) = x - 1 + exp(-x) _C1

algebraic procedure ODESolve!-Basis2LinComb solution;
   %% Convert basis { {B1, B2, ...}, PI } to linear combination:
   begin scalar lincomb;
      lincomb := for each B in first solution sum <>*B;
      %% << >> above is NECESSARY to force immediate evaluation!
      if length solution > 1 then
         lincomb := lincomb + second solution;
      return lincomb
   end$

algebraic procedure ODESolve!-LinComb2Basis
      (lincomb, first_arb, last_arb);
   %% Convert linear combination to basis { {B1, B2, ...}, PI }:
   ODESolve!-LinComb2Basis1({}, lincomb, first_arb, last_arb)$

algebraic procedure ODESolve!-LinComb2Basis1
      (basis, lincomb, first_arb, last_arb);
   %% `basis' is a LIST of independent reduced_ode solutions.
   %% Algorithm is to recursively move components from lincomb to
   %% basis.
   begin scalar coeffs, C;  C := arbconst last_arb;
      coeffs := coeff(lincomb, C);
      if high_pow > 1 or smember(C, coeffs) then
         return                         % cannot convert
      else if high_pow = 1 then <<
         basis := second coeffs . basis;
         lincomb := first coeffs
      >>;
      %% else independent of this arbconst
      return if first_arb >= last_arb then
         { basis, lincomb }
      else
         ODESolve!-LinComb2Basis1
            (basis, lincomb, first_arb, last_arb-1)
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Solve a linear, constant-coefficient ODE.
% Based on code by Malcolm MacCallum.

% There are (at least) 4 ways to get the particular integral (P.I.)
% for a given driving term on the right of the equation:

% 1. The method of undetermined coefficients: this is similar to the
% integrator in that for a given driving term one has to find the
% functional form of the P.I. and then solve for the numerical
% coefficients in it.  Making it really general is as big a task as
% rewriting the integrator.

% 2. The method of variation of parameters: this expands the P.I. as a
% sum of functions of `x' times the linearly independent solutions in
% the complementary function (C.F.).

% 3. Factorise the linear operator (done anyway for the C.F.) and then
% apply for each root `m' the operation
%   ans := exp(m*x) * int(ans * exp(-m*x))
% This is a form of the "D-operator method".  N.B. Some `m' are
% complex.

% 4. Use Laplace transforms (and some kind of table lookup for the
% inverse transforms).

% The current implementation first tries to use the "D-operator
% method", but as soon as any integral fails to evaluate it switches
% to "variation of parameters".

algebraic procedure ODESolve!-LCC(odecoeffs, driver, x, ode_order);
   % Returns a solution basis or nil (if it fails).
   begin scalar auxvar, auxeqn, i, auxroots, solutions, PI;
      traceode "It has constant coefficients.";
      %% TEMPORARY HACK -- REBUILD AUXEQN:
      auxvar := symbolic gensym();  i := -1;
      auxeqn := for each c in odecoeffs sum c*auxvar^(i:=i+1);
      % First we solve for the auxiliary roots:
      auxroots := solve(auxeqn, auxvar);
      % and check the solution carefully:
      if ode_order neq
         (for each multi in multiplicities!* sum multi) then return
            traceode "But insufficient roots of auxiliary equation!";
      solutions := auxroots;
   a: if lhs first solutions neq auxvar then return
         traceode "But auxiliary equation could not be solved!";
      if (solutions := rest solutions) neq {} then goto a;
      % Now we find the complementary solution:
      solutions := ODESolve!-LCC!-CompSoln(auxroots, x);
      % Next the particular integral:
      if driver = 0 then return { solutions };
      if not (PI := ODESolve!-LCC!-PI(auxroots, driver, x)) then
         %% (Cannot use `or' as an algebraic operator!)
         PI := ODESolve!-PI(solutions, driver, x);
      return { solutions, PI }
   end$

algebraic procedure ODESolve!-LCC!-CompSoln(auxroots, x);
   %% Construct the complimentary solution (functions) from the roots
   %% of the auxiliary equation for a linear ODE with constant
   %% coefficients.  Pairs of complex conjugate roots are converted to
   %% real trigonometric form up to the minimum of their
   %% multiplicities (regardless of complex switch and parameters).
   %% `auxroots' is a list of equations with a temporary variable on
   %% the left and an auxilliary root on the right.  The root
   %% multiplicities are stored as a list in the global variable
   %% `multiplicities!*'.  `x' is the independent variable.
   begin scalar multilist, crootlist, ans, multi, imroot, exppart;
      %% crootlist will be a list of lists of the form
      %% {unpaired_complex_root, multiplicity}.
      multilist := multiplicities!*;
      crootlist := {};  ans := {};
      for each root in auxroots do <<
         root := rhs root;
         multi := first multilist;  multilist := rest multilist;
         % Test for complex roots:
         imroot := impart!* root;
         if imroot = 0 then <<
            exppart := exp(root*x);
            for j := 1 : multi do ans := (x**(j-1)*exppart) . ans
         >> else
         begin scalar conjroot, conjmulti;
            %% Cannot assume anything about the order of the roots in
            %% auxroots, so build a list of the complex roots found to
            %% avoid using complex conjugate pairs twice.
            conjroot := conj!* root;  conjmulti := 0;
            %% Essentially do assoc followed by delete if found:
            crootlist := for each root in crootlist join
               if first root = conjroot then <<
                  conjmulti := second root; {}
               >> else {root};
            if conjmulti then           % conjugate pair found:
            begin scalar minmulti;
               exppart := exp(repart!* root*x);
               minmulti := min(multi, conjmulti);
               imroot := abs imroot;    % to avoid spurious minus sign
               imroot := (imroot where abs ~x => x); % to avoid spurious abs!
               for j := 1 : minmulti do
                  ans := (x**(j-1)*cos(imroot*x)*exppart) .
                     (x**(j-1)*sin(imroot*x)*exppart) . ans;
               if multi neq conjmulti then <<
                  %% Skip this unlikely case if possible
                  minmulti := minmulti + 1;
                  exppart := exp(root*x);
                  for j := minmulti : multi do
                     ans := (x**(j-1)*exppart) . ans;
                  exppart := exp(conjroot*x);
                  for j := minmulti : conjmulti do
                     ans := (x**(j-1)*exppart) . ans
               >>
            end
            else crootlist := {root, multi} . crootlist
         end
      >>;
      %% Finally include unpaired complex roots:
      for each root in crootlist do <<
         exppart := exp(first root*x);
         multi := second root;
         for j := 1 : multi do ans := (x**(j-1)*exppart) . ans
      >>;
      return ans
   end$

% The following procedures process complex-valued expressions with
% regard only to their EXPLICIT complexity, i.e. assuming that all
% symbolic quantities are pure real.  They need to work with the
% complex switch both on and off, which is slightly tricky!

algebraic(vars!-are!-real := {repart ~x => x, impart ~x => 0})$

algebraic procedure repart!* u;
   << u := repart u;  u where vars!-are!-real >>$

algebraic procedure impart!* u;
   << u := impart u;  u where vars!-are!-real >>$

algebraic procedure conj!* u;
   << u := conj u;  u where vars!-are!-real >>$

algebraic procedure ODESolve!-LCC!-PI(auxroots, driver, x);
   % Try to construct a particular integral using the `D-operator
   % method'.  Factorise the linear operator (done anyway for the
   % C.F.) and then apply for each root m the operation
   % ans := exp(m*x) * int(ans * exp(-m*x));
   % N.B. Some m may be complex.
   % See e.g. Stephenson, section 21.8, p 410.
   % Returns nil if any integral cannot be evaluated.
   begin scalar exp_mx, multiplicities, multi;
      traceode
         "Constructing particular integral using `D-operator method'.";
      multiplicities := multiplicities!*;
      while driver and auxroots neq {} do <<
         exp_mx := exp((rhs first auxroots)*x);
         driver := driver/exp_mx;
         multi := first multiplicities;
         while driver and multi >= 1 do <<
            driver := int(driver, x);
            if driver freeof int then multi := multi - 1 else driver := 0
         >>;
         driver := exp_mx*driver;
         auxroots := rest auxroots;
         multiplicities := rest multiplicities
      >>;
      if driver = 0 then
         traceode "But cannot evaluate the integrals, so ..."
      else return driver
   end$

algebraic procedure ODESolve!-PI(solutions, R, x);
   % Given a "monic" forced linear nth-order ODE

   %   y^(n) + a_(n-1)(x)y^(n-1) + ... + a_1(x)y = R(x)

   % and a set of n linearly independent solutions {yi(x)} to the
   % unforced ODE, construct a particular solution of the forced ODE
   % in the form of a (single) integral representation by the method
   % of variation of parameters.
   begin scalar n;
      traceode
         "Constructing particular integral using `variation of parameters'.";
      return
         if (n := length solutions) = 2 then
         begin scalar y1, y2, W;
            y1 := first solutions;  y2 := second solutions;
            %% The Wronskian, kept separate to facilitate tracing:
            W := trigsimp(y1*df(y2, x) - y2*df(y1, x));
            traceode "The Wronskian is ", W;
            R := R/W;
            return -ode!-int(y2*R, x)*y1 + ode!-int(y1*R, x)*y2
         end
         else
         begin scalar Wmat, ys, W, i;
            %% Construct the (square) Wronskian matrix of the solutions:
            Wmat := {ys := solutions};
            for i := 2 : n do
               Wmat := (ys := for each y in ys collect df(y,x)) . Wmat;
            load_package matrix;              % to define mat
            Wmat := list2mat reverse Wmat;
            %% The Wronskian (determinant), kept separate for tracing:
            W := trigsimp det Wmat;
            traceode "The Wronskian is ", W;
            R := R/W;  i := 0;
            return
               for each y in solutions sum
                  ode!-int(cofactor(Wmat, n, i:=i+1)*R, x) * y
         end
   end$

% This facility should be in the standard matrix package!
symbolic operator list2mat$
symbolic procedure list2mat M;
   % Input:  (list (list A B ...) (list C D ...) ...)
   % Output: (mat  (A B ...) (C D ...) ...)
   'mat . for each row in cdr M collect cdr row$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Special cases of non-constant coefficients:

algebraic procedure ODESolve!-Euler(odecoeffs, driver, x, ode_order);
   %% Solve a (MONIC) ODE having (essentially) the form
   %% reduced_ode = x^n df(y,x,n) + ... + a_{n-1} x df(y,x) + a_n y = driver
   %% odecoeffs = {a_n, a_{n-1} x, ..., a_0 x^n} / (a_0 x^n)
   %%           = {a_n/(a_0 x^n), a_{n-1}/(a_0 x^{n-1}), ..., a_1/(a_0 x), 1}
   begin scalar tmp, shift, i, c, solution;
      odecoeffs := reverse odecoeffs;   % high .. low

      %% Check for possible Euler or "shifted Euler" form.
      %% Find second non-zero ode coeff:
      tmp := rest odecoeffs;  i := 1;
      while first tmp = 0 do << tmp := rest tmp; i := i+1 >>;
      tmp := first tmp;                 % second non-zero ode coeff
      tmp := den tmp;                   % ax^i or a(x+b)^i
      tmp := reverse coeff(tmp, x);     % high .. low
      if high_pow neq i then return;    % not Euler
      if second tmp then <<             % "shifted Euler"
         shift := second tmp/(i*first tmp); % b
         driver := sub(x=x-shift, driver) % x -> x-b
      >>;

      tmp := {first odecoeffs};  i := 0;
      odecoeffs := rest odecoeffs;
   a: if odecoeffs neq {} then <<
         c := first odecoeffs * (x+shift)^(i:=i+1);
         if not(c freeof x) then return; % not Euler
         tmp := c . tmp;
         odecoeffs := rest odecoeffs;
         go to a
      >>;
      odecoeffs := tmp;

      traceode "It is of the homogeneous (Euler) type ",
         if shift then "(with shifted coefficients) " else "",
         "and is reducible to a simpler ODE ...";
      i := -2;
      tmp := for each c in odecoeffs sum <<
         i := i + 1;
         c * for j := 0 : i product (x-j)
      >>;
      odecoeffs := coeff(tmp, x);       % TEMPORARY HACK!
      driver := sub(x=e^x, driver*x^ode_order);
      solution := ODESolve!-LCC(odecoeffs, driver, x, ode_order);
      solution := sub(x=log x, solution);
      if shift then solution := sub(x=x+shift, solution);
      return solution
   end$

algebraic procedure ODELin!-Exact(P_list, driver, y, x, n);
   %% Computes a (linear) first integral if ODE is an exact linear
   %% n'th order ODE P_n(x) df(y,x,n) + ... + P_0(x) y = R(x).
   begin scalar P_0, C, Q_list, Q, const, soln, PI;
      P_0 := first P_list;
      P_list := reverse rest P_list;         % P_n, ..., P_1
      %% ODE is exact if C = df(P_n,x,n) - df(P_{n-1},x,{n-1}) + ...
      %% + (-1)^{n-1} df(P_1,x) + (-1)^n P_0 = 0.
      for each P in P_list do C := P - df(C,x);
      C := P_0 - df(C,x);               % C = 0 if exact
      if C then return;
      Q_list := {};
      for each P in P_list do
         Q_list := (Q := P - df(Q,x)) . Q_list; % Q_0, ..., Q_{n-1}
      driver := int(driver, x) + (const := symbolic gensym());
      %% The first integral is the LINEAR (n-1)'th order ODE
      %% Q_{n-1}(x) df(y,x,n) + ... + Q_0(x) y = int(R(x),x).
      traceode "It is exact, and the following linear ODE of order ",
         n-1, " is a first integral:";
      if symbolic !*trode then <<
         C := y;
         soln := first Q_list*y +
            ( for each Q in rest Q_list sum Q*(C := df(C,x)) );
         write soln = driver
      >>;
      %% Recurse on the order:
      C := Q_list;
      %% First-integral ODE must have min order 0, since input ODE was
      %% already order-reduced.
      soln := ODESolve!-linear!-basis!-recursive
         (Q_list, driver, y, x, n-1, 0);
      PI := second soln;                % MUST exist since driver neq 0
      PI := coeff(PI, const);           % { real PI, extra basis fn }
      return if high_pow = 1 then
         if first PI then { second PI . first soln, first PI }
         else { second PI . first soln }
      else <<
         %% This error should now be redundant!
         write "*** Internal error in ODELin!-Exact:",
            " cannot separate basis functions! ";
         write "(Probably caused by `noint' option.)";
         soln
      >>
   end$

algebraic procedure ODELin!-Reduce!-Order
   (odecoeffs, driver, y, x, ode_order, min_order);
   %% If ODE does not explicitly involve y (and perhaps low order
   %% derivatives) then simplify by reducing the effective order
   %% (unless there is only one) and try to solve the reduced ODE to
   %% give a first integral.  Applies only to ODEs of order > 1.
   begin scalar solution, PI;
      ode_order := ode_order - min_order;
      for ord := 1 : min_order do odecoeffs := rest odecoeffs;
      traceode "Performing trivial order reduction to give the order ",
         ode_order, " linear ODE with coefficients (low -- high): ",
         odecoeffs;
      solution := ODESolve!-linear!-basis!-recursive
         (odecoeffs, driver, y, x, ode_order, 0);
      if not solution then <<
         traceode "But ODESolve cannot solve the reduced ODE! ";
         return
      >>;
      traceode "Solution of order-reduced ODE is ", solution;
      traceode "Restoring order, ", y => df(y,x,min_order),
         ", to give: ", df(y,x,min_order) = solution,
         " and re-solving ...";
      %% = lin comb of fns of x, so just integrate min_order times:
      if length solution > 1 then       % PI = particular integral
         PI := second solution;
      solution := append(
         for each c in first solution collect
            ODESolve!-multi!-int(c, x, min_order),
         %% and add min_order extra basis functions:
         for i := min_order-1 step -1 until 0 collect x^i );
      return if PI then
         { solution, ODESolve!-multi!-int(PI, x, min_order) }
      else
         { solution }
   end$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.txt0000644000175000017500000000526311526203062024713 0ustar  giovannigiovanniBasic structure of ODESolve
===========================

One general rule is never to convert a linear ODE into a nonlinear
ONE!

Classification strategy:

1. LINEAR (return either basis or linear combination)
   (a) first order - integrating factor       - module odelin
   (b) higher order:-
       (i) n-th order (trivial)               - special case of (ii)
       (ii) constant coeffs                   - module odelin
       (iii) polynomial coeffs:-
           factorizable (algebraically)       - handled by making monic
           Euler & shifted Euler              - module odelin
           dependent variable missing         - module odelin
           exact                              - module odelin
           variation of parameters (for P.I.) - module odelin
           special functions (e.g. Bessel)    - module odelin
           polynomial solutions               - ???
           adjoint                            - ???
           operational calculus               - ???
           order reduction                    - ???
           factorizable (operator)            - ???
           Lie symmetry                       - ???

2. NONLINEAR
   main module odenonln(?)
   (a) first order:-
       Prelle-Singer                          - TO DO
       Bernoulli                              - done
       Clairaut                               - done
       contact                                - ???
       exact                                  - done
       homogeneous                            - done
       Lagrange                               - done
       Riccati                                - done
       Solvable for x/y                       - done
       Separable                              - done

   (b) higher order:-
       dependent variable missing             - done
       factorizable (algebraically)           - done
       factorizable (operator)                - trivial version done
       autonomous                             - done
       differentiation                        - done
       equidimensional                        - done
       exact                                  - done
       scale invariant                        - done
       contact                                - ???
       Lie symmetry                           - ???

   (c) any order
       interchange variables                  - done
       (undetermined coefficients ?)          - ???

A potential problem with this strategy is that one cannot easily pass
back an unsolved ode through the interchange chain.  Using more
symbolic mode might solve this.  For the time being, unsolved odes are
not passed back at all, but does this lose partial solutions?  THIS
NEEDS CHECKING MORE CAREFULLY!
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimmer.tst0000644000175000017500000001646011526203062024372 0ustar  giovannigiovanni% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses REDUCE-style variable notation wherever possible.

on trode;
on div, intstr;  off allfac;            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

depend y, x;

% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y,x) + 2*x^4*y = x^3/3 + C, y, x);

% (2) Linear Bernoulli 2
odesolve(-1/2*df(y,x) + y = sin x, y, x);

% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y,x,2)*(a*x+b)^2 + 4df(y,x)*(a*x+b)*a + 2y*a^2 = 0, y, x);

% (4) Adjoint
odesolve((x^2-x)*df(y,x,2) + (2x^2+4x-3)*df(y,x) + 8x*y = 1, y, x);

% (5) Polynomial solutions
% (FJW: currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y,x,2) + (1-2x^2)*df(y,x) + (4x-2)*y = 0, y, x);

% (6) Dependent variable missing
odesolve(df(y,x,2) + 2x*df(y,x) = 2x, y, x);

% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y,x,2) + (2x^2-3x+1)*df(y,x) + (x-1)*y = 0,
      y, x, algint);
end;
% NB: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON ALGINT OR NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y,x,2) - 2x*df(y,x) + 2y = 3, y, x);

% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y,x,2) + 2x*df(y,x) + 3y = 0, y, x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y,x,2) - 2/x^2*y = 7x^4 + 3*x^3, y, x);

% (12) Variation of parameters
odesolve(df(y,x,2) + y = csc(x), y, x);

% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y,x,7) - 14df(y,x,6) + 80df(y,x,5) - 242df(y,x,4)
   + 419df(y,x,3) - 416df(y,x,2) + 220df(y,x) - 48y = 0, y, x);
remfac exp(x) >>;

% (14) Euler
odesolve(df(y,x,4) - 4/x^2*df(y,x,2) + 8/x^3*df(y,x) - 8/x^4*y = 0, y, x);

% (15) Exact n-th order
odesolve((1+x+x^2)*df(y,x,3) + (3+6x)*df(y,x,2) + 6df(y,x) = 6x, y, x);


% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y,x) = y/(y*log y + x), y, x);

% (17) Integrating factors 2
odesolve(2y*df(y,x)^2 - 2x*df(y,x) - y = 0, y, x);
% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y,x) + y = y^3*sin x, y, x, explicit);
expand_plus_or_minus ws;

% (19) Bernoulli 2
depend {P, Q}, x;
begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y,x) + P*y = Q*y^n, y, x);
   off allfac;  return soln
end;
odesolve(df(y,x) + P*y = Q*y^(2/3), y, x);

% (20) Clairaut 1
odesolve((x^2-1)*df(y,x)^2 - 2x*y*df(y,x) + y^2 - 1 = 0, y, x, explicit);

% (21) Clairaut 2
operator f, g;
odesolve(f(x*df(y,x)-y) = g(df(y,x)), y, x);

% (22) Equations of the form  y' = f(x,y)
odesolve(df(y,x) = (3x^2-y^2-7)/(exp(y)+2x*y+1), y, x);

% (23) Homogeneous
odesolve(df(y,x) = (2x^3*y-y^4)/(x^4-2x*y^3), y, x);

% (24) Factoring the equation
odesolve(df(y,x)*(df(y,x)+y) = x*(x+y), y, x);

% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y,x) = x/(x^2*y^2+y^5), y, x);

% (26) Lagrange 1
odesolve(y = 2x*df(y,x) - a*df(y,x)^3, y, x);
odesolve(y = 2x*df(y,x) - a*df(y,x)^3, y, x, implicit);
% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y = 2x*df(y,x) - df(y,x)^2, y, x);
odesolve(y = 2x*df(y,x) - df(y,x)^2, y, x, implicit);

% (28) Riccati 1
odesolve(df(y,x) = exp(x)*y^2 - y + exp(-x), y, x);

% (29) Riccati 2
factor x;
odesolve(df(y,x) = y^2 - x*y + 1, y, x);
remfac x;

% (30) Separable
odesolve(df(y,x) = (9x^8+1)/(y^2+1), y, x);

% (31) Solvable for x
odesolve(y = 2x*df(y,x) + y*df(y,x)^2, y, x);
odesolve(y = 2x*df(y,x) + y*df(y,x)^2, y, x, implicit);

% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y*df(y,x) - x*df(y,x)^2, y, x)
end;

% (33) Autonomous 1
odesolve(df(y,x,2)-df(y,x) = 2y*df(y,x), y, x, explicit);

% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y,x,2)/y - df(y,x)^2/y^2 - 1 + 1/y^3 = 0, y, x, algint);

% (35) Differentiation method
odesolve(2y*df(y,x,2) - df(y,x)^2 = 1/3(df(y,x) - x*df(y,x,2))^2, y, x, explicit);

% (36) Equidimensional in x
odesolve(x*df(y,x,2) = 2y*df(y,x), y, x, explicit);

% (37) Equidimensional in y
odesolve((1-x)*(y*df(y,x,2)-df(y,x)^2) + x^2*y^2 = 0, y, x);

% (38) Exact second order
odesolve(x*y*df(y,x,2) + x*df(y,x)^2 + y*df(y,x) = 0, y, x, explicit);

% (39) Factoring differential operator
odesolve(df(y,x,2)^2 - 2df(y,x)*df(y,x,2) + 2y*df(y,x) - y^2 = 0, y, x);

% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y,x,2) + 3x*df(y,x) = 1/(y^3*x^4), y, x);

% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y,x,2) + 3x*df(y,x) + 2*y = 1/(y^3*x^4);
% Choose full (explicit and expanded) solution:
odesolve(ode, y, x, full);              % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));

% (41) Autonomous, 3rd order
odesolve((df(y,x)^2+1)*df(y,x,3) - 3df(y,x)*df(y,x,2)^2 = 0, y, x);

% (42) Autonomous, 4th order
odesolve(3*df(y,x,2)*df(y,x,4) - 5df(y,x,3)^2 = 0, y, x);


% 1.3 Special equations
% =====================

% (43) Delay
operator y;
odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);

% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);


% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y,x,4) = sin x, y, x,
   {x=0, y=0, df(y,x)=0, df(y,x,2)=0, df(y,x,3)=0});

% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y,x,2) + df(y,x) + 2x*y = 0, y, x,
   {x=0, y=1, df(y,x)=0});

% (47) Second-degree separable
soln :=
   odesolve(x*df(y,x)^2 - y^2 + 1 = 0, y=1, x=0, explicit);
% Alternatively ...
soln where e^~x => cosh x + sinh x;
% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);
expand_plus_or_minus ws;

% (48) Autonomous
odesolve(df(y,x,2) + y*df(y,x)^3 = 0, y, x, {x=0, y=0, df(y,x)=2});
%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y,x,2) + y*df(y,x)^3 = 0, y, x,
      {x=0, y=0, df(y,x)=2}, explicit);
end;


% 3  Systems of equations
% =======================

% (49) Integrable combinations
depend {x, y, z}, t;
odesolve({df(x,t) = -3y*z, df(y,t) = 3x*z, df(z,t) = -x*y}, {x,y,z}, t);

% (50) Matrix Riccati
depend {a, b}, t;
odesolve({df(x,t) = a*(y^2-x^2) + 2b*x*y + 2c*x,
   df(y,t) = b*(y^2-x^2) - 2a*x*y + 2c*y}, {x,y}, t);

% (51) Triangular
odesolve({df(x,t) = x*(1 + cos(t)/(2+sin(t))), df(y,t) = x - y},
   {x,y}, t);

% (52) Vector
odesolve({df(x,t) = 9x + 2y, df(y,t) = x + 8y}, {x,y}, t);

% (53) Higher order
odesolve({df(x,t) - x + 2y = 0, df(x,t,2) - 2df(y,t) = 2t - cos(2t)},
   {x,y}, t);

% (54) Inhomogeneous system
equ := {df(x,t) = -1/(t*(t^2+1))*x + 1/(t^2*(t^2+1))*y + 1/t,
        df(y,t) = -t^2/(t^2+1)*x + (2t^2+1)/(t*(t^2+1))*y + 1};
odesolve(equ, {x,y}, t);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.red0000644000175000017500000001610411526203062024642 0ustar  giovannigiovannimodule odesolve$  % Header for ordinary differential equation solver

% Authors: F. J. Wright and M. A. H. MacCallum
% Maintainer: F.J.Wright@maths.qmw.ac.uk, Time-stamp: <14 August 2001>

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic ODESolve_version := "ODESolve 1.065"$

global '(ODESolve!-subpackages!*)$

% Build needs repeating if this list is changed!

ODESolve!-subpackages!* := '(
   odeintfc   % User interface and condition code (FJW)
   odetop     % Top level ODESolve routines (FJW / MAHM)
   odelin     % Simple linear ODE solvers (MAHM / FJW)
   odespcfn   % Linear special function ODEs (FJW)
   odenon1    % Special form nonlinear ODEs of order 1 (MAHM / FJW)
   odenonn    % Special form nonlinear ODEs of order > 1 (FJW)
   odepatch   % Temporary REDUCE patches and extensions (FJW)
   )$

create!-package('odesolve . ODESolve!-subpackages!*, nil)$

% Modification of the "deg" function.

symbolic procedure deg(u,kern);
   <>
   where dmode!* = gdmode!*;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Common variable type declarations and macro definitions

% Switches to select solution form where possible -- off by default.
% Can also be set locally by options to odesolve.
switch odesolve_explicit$               % fully explicit
switch odesolve_expand$                 % expand roots of unity
switch odesolve_full$                   % fully explicit and expanded
switch odesolve_implicit$               % not parametric
switch odesolve_noint$                  % turn off selected integrations
switch noint$                           % turn off integration globally
switch odesolve_verbose$                % display ode & conditions
switch odesolve_basis$                  % output basis as linear ODE solution
switch odesolve_noswap$                 % do not swap variables
switch odesolve_norecurse$              % no recursion => noswap
% The `noswap' and `norecurse' switches are mainly for debugging.
switch odesolve_fast$                   % no heuristics => norecurse
% The `fast' switch disables all non-deterministic solution techniques
% (including most of those for nonlinear ODEs of order > 1).  it is
% useful if ODESolve is used as a service routine, including calling
% it recursively in a hook.  It makes ODESolve 1+ behave like the
% odesolve distributed with REDUCE versions up to and including 3.7,
% and so does not affect the odesolve.tst file.
switch odesolve_check$                  % check solution

%% switch odesolve_load_specfn$  !*odesolve_load_specfn := t$
% If on (the default) then autoload the specfn package if a solution
% is returned that involves special functions.  It can be turned off
% to save resources if ODE solutions will not be further manipulated,
% e.g. if conditions will NOT be imposed.

% Switches controlled by ODESolve:
fluid '(!*evallhseqp !*multiplicities !*div !*intstr
   !*exp !*mcd !*factor !*ifactor !*precise !*fullroots !*trigform)$

% REDUCE global variables manipulated by ODESolve:
fluid '(kord!* depl!*)$

% Common global ODESolve variables:
fluid '(!*odesolve!-solvable!-xy)$

symbolic operator member, delete, !*eqn2a, depends, smember, gensym$

symbolic smacro procedure eqnp u;
   eqcar(u, 'equal)$

symbolic smacro procedure ODESolve!-basisp soln;
   rlistp cadr soln and not eqnp cadadr soln$

% The following two statements are needed in case SOLVE has not been
% loaded before compiling this package.

global '(multiplicities!*)$  share multiplicities!*$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Tracing support

switch trode$                           % trace the algorithms used
% Assign a numerical value to !*trode for extra algorithm tracing:
share !*trode$

% rlistat is not flagged eval, so for faslout ...
deflist('((traceode rlis) (traceode!* rlis) (traceode1 rlis)), 'stat)$

global '(TraceOde!-InputList)$

symbolic procedure traceode!-print u;
   %% Print sequence of elements and terminate line with linefeed.
   %% Returns nil.
   begin scalar alg;  % non-nil if any algebraic elements to print
      alg := u := revlis nconc(TraceOde!-InputList, u);
      TraceOde!-InputList := nil;
      while alg and atom car alg do alg := cdr alg;
      if alg then <<
         terpri!* t;
         for each el in u do maprin el;
         terpri!* t
      >> else <<
         for each el in u do prin2 el;
         terpri()
      >>
   end$

symbolic procedure traceode u;
   %% Print sequence of elements and terminate line with linefeed.
   %% Returns nil.
   if !*trode then traceode!-print u$

symbolic procedure traceode!* u;
   %% Print line WITHOUT linefeed:
   %% Returns nil.
   if !*trode then
      %% Assignment necessary when TraceOde!-InputList is null:
      begin TraceOde!-InputList := nconc(TraceOde!-InputList, u) end$

symbolic procedure traceode1 u;
   %% Extra tracing -- print line with linefeed:
   %% Returns nil.
   if !*trode = 1 then traceode!-print u$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Arbitrary constants in solutions:

algebraic operator arbconst$
algebraic (!!arbconst := 0)$

algebraic procedure newarbconst();
   arbconst(!!arbconst := !!arbconst + 1)$


% General utilities:

algebraic procedure ode!-int(y, x);
   %% Currently used only in `ODESolve!-PI' in module `odelin', but
   %% should probably be used more widely, so moved here!
   int(trigsimp y, x)$

algebraic procedure ODESolve!-multi!-int(y, x, m);
   %% Integate y wrt x m times:
   %% REVISE TO INTEGRATE JUST ONCE (cf. trivial n'th order ODEs)?
   if m > 0 then ODESolve!-multi!-int(int(y,x), x, m-1) else y$

%% algebraic procedure odefailure(ode);
%%    <<
%%       %% This message moved to ODESolve!-nonlinear:
%%       %% traceode "This version of ODESOLVE cannot solve ",
%%       %%    "equations of the type given.";
%%       {ode=0}
%%    >>$

algebraic operator odesolve!-df$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odepatch.red0000644000175000017500000003711011526203062024611 0ustar  giovannigiovannimodule odepatch$  % Patches to standard REDUCE facilities

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@Maths.QMW.ac.uk, Time-stamp: <18 September 2000>

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Integrator patches
% ==================

% Avoid trying to integrate an integral to speed up some odesolve
% calls.

% NB: subst copies, even if no substitution is made.  It is therefore
% very likely to destroy uniqueness of kernels!

%% load_package int$
%% apply1('load!-package, 'int)$           % not at compile time!
packages_to_load int$                   % not at compile time!

global '(ODESolveOldSimpInt)$
(if not(s eq 'NoIntInt_SimpInt) then ODESolveOldSimpInt := s) where
   s = get('int, 'simpfn)$              % to allow reloading
put('int, 'simpfn, 'NoIntInt_SimpInt)$

fluid '(!*NoInt !*Odesolve_NoInt)$

symbolic procedure NoIntInt_SimpInt u;
   %% Patch to avoid trying to re-integrate symbolic integrals in the
   %% integrand, because it can take forever and achieve nothing!
   if !*NoInt then
   begin scalar v, varstack!*;
      % Based on int/driver/simpint1.
      % Varstack* rebound, since FORMLNR use can create recursive
      % evaluations.  (E.g., with int(cos(x)/x**2,x)).
      u := 'int . u;
      return if (v := formlnr u) neq u then <<
         v := simp subst('int!*, 'int, v);
         remakesf numr v ./ remakesf denr v
      >> else !*kk2q u
   end
   else
   if atom u or null cdr u or cddr u and (null cdddr u or cddddr u)
     then rerror(int,1,"Improper number of arguments to INT")
    else if cddr u then simpdint u      % header from simpint
   else begin scalar car_u, result;
      %% put('int, 'simpfn, 'SimpNoInt);
      car_u := mk!*sq simp!* car u;
      %% car_u := subeval{{'equal, 'Int, 'NoInt}, car_u};
      car_u := subst('NoInt, 'Int, car_u);
      u := car_u . !*a2k cadr u . nil;
      %% Prevent SimpInt from resetting itself!
      put('int, 'simpfn, ODESolveOldSimpInt);    % assumed & RESET by simpint
      result := errorset!*({ODESolveOldSimpInt, mkquote u}, t);
      put('int, 'simpfn, 'NoIntInt_SimpInt); % reset INT interface
      if errorp result then error1();
      return NoInt2Int car result;
      %% Does this cause non-unique kernels?
   end$

algebraic operator NoInt$               % Inert integration operator

%% symbolic procedure SimpNoInt u;
%%    !*kk2q('NoInt . u)$                % remain symbolic

symbolic operator Odesolve!-Int$
symbolic procedure Odesolve!-Int(y, x);
   %% Used in SolveLinear1 on ode1 to control integration.
   if !*Odesolve_NoInt then formlnr {'NoInt, y, x}
   else mk!*sq NoIntInt_SimpInt{y, x}$  % aeval{'int, y, x}$

%% put('Odesolve!-Int, 'simpfn, 'Simp!-Odesolve!-Int)$
%% symbolic procedure Simp!-Odesolve!-Int u;
%%    %% Used in SolveLinear1 on ode1 to control integration.
%%    if !*Odesolve_NoInt then !*kk2q('NoInt . u)  % must eval u!!!
%%    else NoIntInt_SimpInt u$         % aeval{'int, y, x}$

symbolic procedure NoInt2Int u;
   %% Convert all NoInt's back to Int's, without algebraic evaluation.
   subst('Int, 'NoInt, u)$

switch NoIntInt$  !*NoIntInt := t$
put('NoIntInt, 'simpfg,
   '((nil (put 'int 'simpfn 'SimpInt) (rmsubs))
     (t (put 'int 'simpfn 'NoIntInt_SimpInt))))$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Differentiator patches
% ======================

% Differentiate integrals correctly!

% NB: `ON' is flagged ignore and so not compiled, so...
on1 'allowdfint$

% To replace the versions in `reduce/packages/poly/diff.red' once
% tested.

% deflist('((dfint ((t (progn (on1 'allowdfint) (rmsubs)))))), 'simpfg);

symbolic procedure diffp(u,v);
   % U is a standard power, V a kernel.
   % Value is the standard quotient derivative of U wrt V.
   begin scalar n,w,x,y,z; integer m;
        n := cdr u;     % integer power.
        u := car u;     % main variable.
        if u eq v and (w := 1 ./ 1) then go to e
         else if atom u then go to f
         %else if (x := assoc(u,dsubl!*)) and (x := atsoc(v,cdr x))
%               and (w := cdr x) then go to e   % deriv known.
             % DSUBL!* not used for now.
         else if (not atom car u and (w:= difff(u,v)))
                  or (car u eq '!*sq and (w:= diffsq(cadr u,v)))
          then go to c  % extended kernel found.
         else if x := get(car u,'dfform) then return apply3(x,u,v,n)
         else if x:= get(car u,dfn_prop u) then nil
         else if car u eq 'plus and (w := diffsq(simp u,v))
          then go to c
         else go to h;  % unknown derivative.
        y := x;
        z := cdr u;
    a:  w := diffsq(simp car z,v) . w;
        if caar w and null car y then go to h;  % unknown deriv.
        y := cdr y;
        z := cdr z;
        if z and y then go to a
         else if z or y then go to h;  % arguments do not match.
        y := reverse w;
        z := cdr u;
        w := nil ./ 1;
    b:  % computation of kernel derivative.
        if caar y
          then w := addsq(multsq(car y,simp subla(pair(caar x,z),
                                                   cdar x)),
                          w);
        x := cdr x;
        y := cdr y;
        if y then go to b;
    c:  % save calculated deriv in case it is used again.
        % if x := atsoc(u,dsubl!*) then go to d
        %  else x := u . nil;
        % dsubl!* := x . dsubl!*;
  % d:   rplacd(x,xadd(v . w,cdr x,t));
    e:  % allowance for power.
        % first check to see if kernel has weight.
        if (x := atsoc(u,wtl!*))
          then w := multpq('k!* .** (-cdr x),w);
        m := n-1;
        % Evaluation is far more efficient if results are rationalized.
        return rationalizesq if n=1 then w
                else if flagp(dmode!*,'convert)
                     and null(n := int!-equiv!-chk
                                           apply1(get(dmode!*,'i2d),n))
                 then nil ./ 1
                else multsq(!*t2q((u .** m) .* n),w);
    f:  % Check for possible unused substitution rule.
        if not depends(u,v)
           and (not (x:= atsoc(u,powlis!*))
                 or not depends(cadddr x,v))
           and null !*depend
          then return nil ./ 1;
        % Derivative of a dependent identifier via the chain rule.
        % Suppose u(v) = u(a(v),b(v),...), i.e. given depend {u}, a,
        % b, {a, b}, v; then (essentially) depl!* = ((b v) (a v) (u b
        % a))
        if !*expanddf and not(v memq (x:=cdr atsoc(u, depl!*))) then <<
           w := nil ./ 1;
           for each a in x do
              w := addsq(w, multsq(simp{'df,u,a},simp{'df,a,v}));
           go to e
        >>;
        w := list('df,u,v);
        w := if x := opmtch w then simp x else mksq(w,1);
        go to e;
    h:  % Final check for possible kernel deriv.
        if car u eq 'df then <<         % multiple derivative
           if cadr u eq v then
              % (df (df v x y z ...) v) ==> 0 if commutedf
              if !*commutedf and null !*depend then return nil ./ 1
              else if !*simpnoncomdf and (w:=atsoc(v, depl!*))
                 and null cddr w % and (cadr w eq (x:=caddr u))
              then
                 % (df (df v x) v) ==> (df v x 2)/(df v x) etc.
                 % if single independent variable
                 <<
                    x := caddr u;
                    % w := simp {'quotient, {'df,u,x}, {'df,v,x}};
                    w := quotsq(simp{'df,u,x},simp{'df,v,x});
                    go to e
                 >>
           else if eqcar(cadr u, 'int) then
              % (df (df (int F x) A) v) ==> (df (df (int F x) v) A) ?
              % Commute the derivatives to differentiate the integral?
              if caddr cadr u eq v then
                 % Evaluating (df u v) where u = (df (int F v) A)
                 % Just return (df F A) - derivative absorbed
                 << w := 'df . cadr cadr u . cddr u;  go to j >>
              else if !*allowdfint and
                 % Evaluating (df u v) where u = (df (int F x) A)
                 % (If dfint is also on then this will not arise!)
                 % Commute only if the result simplifies:
                 not_df_p(w := diffsq(simp!* cadr cadr u, v))
              then <<
                 % Generally must re-evaluate the integral (carefully!)
                 w := 'df . reval{'int, mk!*sq w, caddr cadr u} . cddr u;
                 go to j >>;  % derivative absorbed
           if (x := find_sub_df(w:= cadr u . merge!-ind!-vars(u,v),
                                           get('df,'kvalue)))
                          then <>
                       else w := 'df . w
        >> else if !*expanddf and not atom cadr u then <<
           % Derivative of an algebraic operator u(a(v),...) via the
           % chain rule: df(u(v),v) = u_1(a(v),b(v),...)*df(a,v) + ...
           x := intern compress nconc(explode car u, '(!! !! !_));
           y := cdr u;  w := nil ./ 1;  m := 0;
           for each a in y do
           begin scalar b;
              m:=m#+1;
              if numr(b:=simp{'df,a,v}) then <<
                 z := mkid(x, m);
                 put(z, 'simpfn, 'simpiden);
                 w := addsq(w, multsq(simp(z . y), b))
              >>
           end;
           go to e
        >> else w := {'df,u,v};
   j:   if (x := opmtch w) then w := simp x
         else if not depends(u,v) and null !*depend then return nil ./ 1
         else w := mksq(w,1);
      go to e
   end$

symbolic procedure dfform_int(u, v, n);
   % Simplify a SINGLE derivative of an integral.
   % u = '(int y x) [as main variable of SQ form]
   % v = kernel
   % n = integer power
   % Return SQ form of df(u**n, v) = n*u**(n-1)*df(u, v)
   % This routine is called by diffp via the hook
   % "if x := get(car u,'dfform) then return apply3(x,u,v,n)".
   % It does not necessarily need to use this hook, but it needs to be
   % called as an alternative to diffp so that the linearity of
   % differentiation has already been applied.
   begin scalar result, x, y, dx!/dv;
      y := simp!* cadr u;  % SQ form integrand
      x := caddr u;  % kernel
      result :=
      if v eq x then y
         % Special case -- just differentiate the integral:
         % df(int(y,x), x) -> y  replacing the let rule in INT.RED
      else if not !*intflag!* and       % not in the integrator
         % If used in the integrator it can cause infinite loops,
         % e.g. in df(int(int(f,x),y),x) and df(int(int(f,x),y),y)
         !*allowdfint and               % must be on for dfint to work
         <<
            % Compute PARTIAL df(y, v), where y must depend on x, so
            % if x depends on v, temporarily replace x:
            result := if numr(dx!/dv:=diffp(x.**1,v)) then
               %% (Subst OK because all kernels.)
               subst(x, xx, diffsq(subst(xx, x, y), v)) where
                  xx = gensym()
            else diffsq(y, v);
            !*dfint or not_df_p result
         >>
      then
         % Differentiate under the integral sign:
         % df(int(y,x), v) -> df(x,v)*y + int(df(y,v), x)
         addsq(
            multsq(dx!/dv, y),
            simp{'int, mk!*sq result, x})  % MUST re-simplify it!!!
            % (Perhaps I should use prepsq -
            % kernels are normally true prefix?)
      else !*kk2q{'df, u, v};  % remain unchanged
      if n neq 1 then
         result := multsq( (((u .** (n-1)) .* n) .+ nil) ./ 1, result);
      return result
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Solve patches
% =============

% Needed for definition of `mkrootsoftag' function.
packages_to_load solve$                 % not at compile time!

endmodule$
end$

%                ***** NOT INSTALLED AT PRESENT *****

%% An algebraic solver appropriate to ODESolve, that never returns
%% implicit solutions and returns nil when it fails.  Also, it solves
%% quadratics in terms of plus_or_minus.

%% *** NB: This messes up `root_multiplicities'. ***

%% (Later also use the root_of_unity operator where appropriate.
%% Could do this by a wrapper around `solvehipow' in solve/solv1.)

% This switch controls `solve' globally once this file has been
% loaded:
switch plus_or_minus$                   % off by default

%% The integrator does not handle integrands containing the
%% `plus_or_minus' operator at all well.  This may require some
%% re-writing of the integrator (!).  Temporarily, just turn off the
%% use of the `plus_or_minus' operator when necessary.

% This switch controls some `solve' calls locally within `ODESolve':
switch odesolve_plus_or_minus$          % TEMPORARY
% off by default -- it's to odangerous at present!
% !*odesolve_plus_or_minus := t$          % TEMPORARY

symbolic operator AlgSolve$
symbolic procedure AlgSolve(u, v);
   %% Return either a list of EXPLICIT solutions of a single scalar
   %% expression `u' for variable `v' or nil.
   begin scalar soln, tail, !*plus_or_minus;
      !*plus_or_minus := t;
      tail := cdr(soln := solveeval1{u, v});
      while tail do
         if car tail eq v then tail := cdr tail
         else tail := soln := nil;
      return soln
   end$

algebraic procedure SolvePM(u, v);
   %% Solve a single scalar expression `u' for variable `v', using the
   %% `plus_or_minus' operator in the solution of quadratics.
   %% *** NB: This messes up `root_multiplicities'. ***
   symbolic(solveeval1{u, v}
      where !*plus_or_minus := !*odesolve_plus_or_minus)$

%% This is a modified version of a routine in solve/quartic

symbolic procedure solvequadratic(a2,a1,a0);
   % A2, a1 and a0 are standard quotients.
   % Solves a2*x**2+a1*x+a0=0 for x.
   % Returns a list of standard quotient solutions.
   % Modified to use root_val to compute numeric roots.  SLK.
   if !*rounded and numcoef a0 and numcoef a1 and numcoef a2
      then for each z in cdr root_val list mkpolyexp2(a2,a1,a0)
         collect simp!* z else
   begin scalar d;
      d := sqrtq subtrsq(quotsqf(exptsq(a1,2),4),multsq(a2,a0));
      a1 := quotsqf(negsq a1,2);
      return
         if !*plus_or_minus then        % FJW
            list(subs2!* quotsq(addsq(a1,
               multsq(!*kk2q newplus_or_minus(),d)),a2))
                  %% Must uniquefy here until newplus_or_minus does it
                  %% for itself!
         else
            list(subs2!* quotsq(addsq(a1,d),a2),
               subs2!* quotsq(subtrsq(a1,d),a2))
   end$

endmodule$
end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odenonn.red0000644000175000017500000005046111526203062024466 0ustar  giovannigiovannimodule odenonn$  % Special form nonlinear ODEs of order > 1

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@maths.qmw.ac.uk, Time-stamp: <14 August 2001>

% Trivial order reduction.
% Special cases of Lie symmetry, namely
%    autonomous, equidimensional and scale invariant equations.
% Simplification of arbitrary constants.

% TO DO:
%   avoid computing orders in both reduce and shift


algebraic procedure ODESolve!-nonlinearn(ode, y, x);
   %% `symbolic' mode here is ESSENTIAL, otherwise the code generated
   %% is as if this were a macro, except then it does not get eval'ed!
   symbolic ODENon!-Reduce!-Order(ode, y, x)$

%% The following defines are used to allow easy changes to the calling
%% sequence.

define ODENon!-Reduce!-Order!-Next = ODESolve!-Shift$
%% Shifting currently NEEDED for Zimmer (8) (only)!

define ODESolve!-Shift!-Next = ODESolve!-nonlinearn!*1$

switch odesolve_equidim_y$              % TEMPORARY?
symbolic(!*odesolve_equidim_y := t)$    % TEMPORARY?

algebraic procedure ODESolve!-nonlinearn!*1(ode, y, x);
   %% The order here seems to be important in practice:
   symbolic or(
      ODESolve!-Autonomous(ode, y, x),
      ODESolve!-ScaleInv(ode, y, x),    % includes equidim in x
      !*odesolve_equidim_y and
      ODESolve!-Equidim!-y(ode, y, x) )$

algebraic procedure ODENon!-Reduce!-Order(ode, y, x);
   %% If ode does not explicitly involve y and low order derivatives
   %% then simplify by reducing the effective order (unless there is
   %% only one) and then try to solve the reduced ode directly to give
   %% a first integral.  Applies only to odes of order > 1.
   begin scalar deriv_orders, min_order, max_order;
      traceode1 "Trying trivial order reduction ...";
      deriv_orders := get_deriv_orders(ode, y);
      %% Check for purely algebraic factor from some simplification,
      %% such as autonomous reduction:
      if deriv_orders = {} or deriv_orders = {0} then
         return {ode = 0};              % purely algebraic!
      %% Avoid reduction to a purely algebraic equation:
      if (min_order := min deriv_orders) = 0 or
         length deriv_orders = 1 then return
            ODENon!-Reduce!-Order!-Next(ode, y, x);
      max_order := max deriv_orders;
      ode := sub(df = odesolve!-df, ode);
      for ord := min_order : max_order do
         ode := if ord = 1 then (ode where odesolve!-df(y,x) => y)
         else (ode where odesolve!-df(y,x,ord) =>
            odesolve!-df(y,x,ord-min_order));
      ode := sub(odesolve!-df = df, ode);
      traceode "Performing trivial order reduction to give ",
         "the order ", max_order - min_order, " nonlinear ODE: ",
         ode = 0;
      ode := symbolic(
         (if max_order - min_order = 1 then % first order
            ODESolve!-nonlinear1(ode, y, x)
         else
            ODENon!-Reduce!-Order!-Next(ode, y, x))
               where !*odesolve_explicit = t);
      if not ode then <<
         traceode "Cannot solve order-reduced ODE!";
         return                         % abandon solution
      >>;
      %% ode := sub(y = df(y,x,min_order), ode);
      traceode "Solution of order-reduced ODE is ", ode;
      traceode "Restoring order, ", y => df(y,x,min_order),
         ", to give: ", sub(y = df(y,x,min_order), ode),
         " and re-solving ...";
      ode := for each soln in ode join
         %% Each `soln' here is an EQUATION for y that may be
         %% implicit.
         if lhs soln = y then           % explicit
            { y = ODESolve!-multi!-int!*(rhs soln, x, min_order) }
         else <<
            soln := solve(soln, y);
            for each s in soln collect
               if lhs s = y then        % explicit
                  y = ODESolve!-multi!-int!*(rhs s, x, min_order)
               else                     % implicit
                  %% leave unsolved for now
                  sub(y = df(y,x,min_order), s)
         >>;
      return ODESolve!-Simp!-ArbConsts(ode, y, x)
   end$

algebraic procedure ODESolve!-multi!-int!*(y, x, m);
   %% Integate y wrt x m times and add arbitrary constants:
   ODESolve!-multi!-int(y, x, m) +
      %% << >> below is NECESSARY to force immediate evaluation!
      for i := 0 : m-1 sum <>*x^i$


% Internal wrapper function for ODESolve!-Shift:
algebraic operator odesolve!-sub!*$

algebraic procedure ODESolve!-Shift(ode, y, x);
   %% A first attempt at canonicalizing an ODE by shifting the
   %% independent variable.
   symbolic if not !*odesolve_fast then % heuristic solution
   algebraic begin scalar deriv_orders, a, c, d;
      traceode1 "Looking for an independent variable shift ...";
      deriv_orders := get_deriv_orders(ode, y);
      deriv_orders := sort(deriv_orders, >);
      %% Try to find a non-trivial "coefficient" polynomial
      %% constituent c that is linear in x.
      while deriv_orders neq {} and
         (c := lcof(ode, df(y,x,first deriv_orders))) freeof x do
            deriv_orders := rest deriv_orders;
      if deriv_orders = {} then         % not shiftable
         return ODESolve!-Shift!-Next(ode, y, x);
      if (d := deg(c, x)) neq 1 then <<
         c := decompose c;
         while (c := rest c) neq {} and deg(rhs first c, x) neq 1 do;
         %% << null loop body >>
         if c neq {} then c := rhs first c;
         if deg(c, x) neq 1 then        % not shiftable
            return ODESolve!-Shift!-Next(ode, y, x)
      >>;
      %% c = ax + b is a linear component polynomial of the ode
      %% coefficients.
      if not(c freeof y) or not((c := coeff(c,x)) freeof x) or
         first c = 0 then               % not shiftable
         return ODESolve!-Shift!-Next(ode, y, x);
      c := first c / (a := second c);
      %% ode is a function of ax + b (= a(x + c)), so ...
      ode := sub(x = x - c, ode) / a^d;
      %% This will leave sub(..., df(...)) symbolic, so ...
      ode := num sub(sub = odesolve!-sub!*, ode);
      ode := (ode where odesolve!-sub!*(~a! ,~b! ) => b! );
      traceode "This ODE can be simplified by the ",
         "independent variable shift ", x => x - c,
         " to give: ", ode = 0;
      ode := ODESolve!-Shift!-Next(ode, y, x);
      if ode then return
         for each soln in ode collect
            if symbolic rlistp soln then   % parametric solution
               for each s in soln collect
                  if symbolic eqcar(s, 'equal) and lhs s = x
                  then x = rhs s - c else s
            else sub(x = x + c, soln)
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Autonomous, equidimensional and scale-invariant ODEs
% ====================================================

algebraic procedure ODESolve!-Autonomous(ode, y, x);
   %% If ODE is autonomous, i.e. x does not appear explicitly, then
   %% reduce the order by using y as independent variable and then try
   %% to solve the reduced ODE directly.  Applies only to ODEs of
   %% order > 1.  Do not apply to a linear ODE, because it will become
   %% nonlinear!
   begin scalar ode1, u, soln;
      traceode1 "Testing whether ODE is autonomous ...";
      ode1 := (ode where df(y,x) => 1, df(y,x,~n) => 1);
      if smember(x, ode1) then return;  % not autonomous
      u := gensym();
      symbolic depend1(u,x,t);  symbolic depend1(u,y,t);
      ode := (ode where df(y,x) => u, df(y,x,~n) => df(u,x,n-1));
      ode := (ode where df(u,x,~n) => u*df(df(u,x,n-1),y) when n > 1,
         %% above condition n > 1 is NECESSARY!
         df(u,x) => u*df(u,y));
      symbolic depend1(u,x,nil);
      traceode
         "This ODE is autonomous -- transforming dependent variable ",
         "to derivative to give this ODE of order 1 lower: ", ode = 0;
      ode := symbolic(ODESolve!*1(ode, u, y)
         where !*odesolve_explicit = t);
      if not ode then <<
         symbolic depend1(u,y,nil);
         traceode "Cannot solve transformed autonomous ODE!";
         return
      >>;
      ode := sub(u = df(y,x), ode);
      symbolic depend1(u,y,nil);
      traceode "Restoring order to give these first-order ODEs ...";
      soln := {};
   a: if ode neq {} then
         if (u := ODESolve!-FirstOrder(first ode, y, x)) then <<
            soln := append(soln, u);
            ode := rest ode;
            go to a
         >> else <<
            traceode "Cannot solve one of the first-order ODEs ",
               "arising from solution of transformed autonomous ODE!";
            return
         >>;
      return ODESolve!-Simp!-ArbConsts(soln, y, x)
   end$

algebraic procedure ODESolve!-ScaleInv(ode, y, x);
   %% If ODE is scale invariant, i.e. invariant under x -> a x, y ->
   %% a^p y, then transform it to an equidimensional-in-x ODE and try
   %% to solve it.  If p = 0 then it is already equidimensional-in-x
   %% as a special case.  Returns a solution or nil if this method
   %% does not lead to a solution.  PROBABLY NOT USEFUL FOR LINEAR
   %% ODES.
   begin scalar u, p, ode1, pow, !*allfac;
      traceode1 "Testing whether ODE is scale invariant or ",
         "equidimensional in the independent variable ", x, " ...";
      u := gensym();  p := gensym();
      ode1 := (ode where df(y,x,~n) => mkid(u,n)*x^(p-n),
         df(y,x) => mkid(u,1)*x^(p-1));
      %% mkid's to avoid spurious cancellations.
      ode1 := num sub(y = u*x^p, ode1);
      %% Try to choose p to make ode1 proportional to some single
      %% power of x.  Assume ode1 is a sum of terms.
      begin scalar part1, n_parts;
         part1 := part(ode1, 1);
         n_parts := arglength ode1;     % must be at least 2 terms
         for i := 2 : n_parts do <<
            parti := part(ode1, i)/part1;
            pow := df(parti, x)*x/parti;
            if pow then << pow := solve(pow, p);  n_parts := 0 >>
         >>;
         if n_parts then
            %% Scale invariant for ANY p =>
            %% equidimensional in both x and y
            return pow := {p=0};
         ode1 := (ode1 - part1)/part1;
         while pow neq {} and           % check scale invariance
            (symbolic eqcar(caddr cadr pow, 'root_of) or
               not(sub(first pow, ode1) freeof x)) do
                  pow := rest pow
      end;
      if pow = {} then return;          % not scale invariant
      if not(p := rhs first pow) then
         %% Scale invariant for p=0 =>
         %% equidimensional in x ...
         return ODESolve!-ScaleInv!-Equidim!-x(ode, y, x);
      %% ode is scale invariant (with p neq 0)
      symbolic depend1(u, x, t);
      ode := sub(y = x^p*u, ode);
      traceode "This ODE is scale invariant -- applying ", y => x^p*u,
         " to transform to the simpler ODE: ", ode = 0;
      ode := ODESolve!-ScaleInv!-Equidim!-x(ode, u, x);
      symbolic depend1(u, x, nil);
      if ode then return sub(u = y/x^p, ode);
      traceode "Cannot solve transformed scale invariant ODE!"
   end$

algebraic procedure ODESolve!-ScaleInv!-Equidim!-x(ode, y, x);
   %% ODE is equidimensional in x, i.e. invariant under x -> ax, so
   %% transform it to an autonomous ODE and try to solve it.  (This
   %% includes "reduced" Euler equations as a special case.  Could
   %% ignore terms independent of y in testing equidimensionality; if
   %% there are such terms then the simplified ODE will not be
   %% autonomous.  This generalization includes ALL Euler equations.)
   %% Returns a solution or nil if this method does not lead to a
   %% solution.
   begin scalar tt, exp_tt;
      tt := gensym();
      %% ode is equidimensional in x; x -> exp(tt):
      exp_tt := exp(tt);
      symbolic depend1(y,tt,t);
      ode := (ode where df(y,x) => df(y,tt)/exp_tt,
         df(y,x,~n) => df(df(y,x,n-1),tt)/exp_tt when
            numberp n and n > 0);  % n > 0 condition is necessary!
      ode := num sub(x = exp_tt, ode);
      traceode
         "This ODE is equidimensional in the independent variable ",
         x, " -- applying ", x => exp_tt,
         " to transform to the simpler ODE: ",
         ode = 0;
      symbolic depend1(y,x,nil);   % Necessary to avoid dependence loops
      %% ode should be autonomous PROVIDED no term independent of y
      ode := symbolic ODESolve!-Autonomous(ode, y, tt);
      symbolic depend1(y,x,t);   %%% ???
      symbolic depend1(y,tt,nil);
      if ode then return sub(tt = log x, ode);
      traceode "Cannot solve transformed equidimensional ODE!"
   end$

algebraic procedure ODESolve!-Equidim!-y(ode, y, x);
   %% If ODE is equidimensional in y, i.e. invariant under y -> ay,
   %% then simplify the ODE and try to solve the result.  Returns a
   %% solution or nil if this method does not lead to a solution.  Do
   %% not apply to a linear ODE, which is trivially equidimensional in
   %% y, because it will become nonlinear!
   begin scalar ode1, u, exp_u;
      traceode1 "Testing whether ODE is equidimensional in ",
         "the dependent variable ", y, " ...";
      u := gensym();  % to avoid spurious cancellations
      ode1 := (ode where df(y,x,~n) => y*mkid(u,n),
         df(y,x) => y*u);
      %% ode1 must be proportional to some single positive integer
      %% power of y:
      if reduct(ode1, y) or depends(lcof(ode1, y), y) then return;
      %% ode is equidimensional in y; y -> exp(u):
      exp_u := exp(u);
      symbolic depend1(u,x,t);
      ode := lcof(num sub(y = exp_u, ode), exp_u);
      %% (Lcof above to remove irrelevant factor of a power of y.)
      traceode
         "This ODE is equidimensional in the dependent variable ",
         y, " -- applying ", y => exp_u,
         " to transform to the simpler ODE: ",
         ode = 0;
      %% ode here could be ANY kind of ode.  It should be less
      %% nonlinear, but I don't think there is any guarantee that it
      %% will be linear -- is there?  Hence we must call the full
      %% general ode solver again:
      ode := ODESolve!*1(ode, u, x);
      symbolic depend1(u,x,nil);
      if not ode then <<
         traceode "Cannot solve transformed equidimensional ODE!";
         return
      >>;
      return for each soln in ode collect
         if lhs soln = u then y = exp rhs soln % retain explicit soln
         else sub(u = log y, ode)
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Simplification of Arbitrary Constants
% =====================================

algebraic procedure ODESolve!-Simp!-ArbConsts(solns, y, x);
   %% To be applied to non-parametric solutions of ODEs containing
   %% arbconsts introduced earlier.
   for each soln in solns collect
      if symbolic rlistp soln then soln else
         (ODESolve!-Simp!-ArbConsts1(lhs soln, y, x) =
            ODESolve!-Simp!-ArbConsts1(rhs soln, y, x))$

algebraic procedure ODESolve!-Simp!-ArbConsts1(soln, y, x);
   %% Simplify arbconst expressions within soln.  Messy arbconst
   %% expressions can be introduced by the integrator from simple
   %% arbconsts, and there would appear to be no way to avoid this
   %% other than to remove them after the event.
   begin scalar !*precise, ss, acexprns;
      if not(ss := ODESolve!-Structr(soln, x, y, 'arbconst))
      then return soln;
      acexprns := rest ss;  ss := first ss;
      traceode "Simplifying the arbconst expressions in ", soln,
         " by the rewrites ...";
      for each s in acexprns do <<
         %% s has the form ansj = "expression in arbconst(n)"
         %% MAY NEED TO CHECK ONLY 1 ARBCONST?
         %% n!* must be a global algebraic variable!
         rhs s where arbconst(~n) => (n!* := n);
         traceode rhs s, " => ", arbconst(n!*); % to evaluate `rhs'
         %% Remove other occurrences of arbconst(n!*):
         ss := sub(solve(s, arbconst(n!*)), ss);
         %% Finally rename ansj as arbconst(n):
         ss := sub(lhs s = arbconst(n!*), ss)
      >>;
      return ss
   end$

symbolic operator ODESolve!-Structr$
%% symbolic procedure ODESolve!-Structr(u, x, y, arbop);
%%    %% Return an rlist consisting of an expression involving variables
%%    %% ansj representing sub-structures followed by equations of the
%%    %% form ansj = sub-structure, where the sub-structures depend
%%    %% non-trivially on the arbitrary opertor arbop, essentially in the
%%    %% format returned by structr, or nil if this decomposition is not
%%    %% possible.
%%    begin scalar !*savestructr, !*precise, ss, arbexprns;
%%       !*savestructr := t;
%%       ss := cdr structr u;              % rlistat; ss = (exprn eqns)
%%       if null cdr ss then return;
%%       %% Ignore "structures" of the form ansj = arbop(i)
%%       ss := car ss . for each s in cdr ss join
%%          if eqcar(caddr(s:=reval s), arbop)
%%          then << arbexprns := s . arbexprns; nil >>
%%          else {s};
%%       %% by substituting them back into the structure list:
%%       if arbexprns then
%%          ss := cdr subeval nconc(arbexprns, {makelist ss});
%%
%%       %% Get simplifiable arbop expressions:
%%       arbexprns := nil;
%%       ss := car ss . for each s in cdr ss join
%%          begin scalar rhs_s;  rhs_s := caddr s;
%%             return if smember(arbop, rhs_s) and
%%                not(depends(rhs_s, x) or depends(rhs_s, y))
%%             then << arbexprns := s . arbexprns; nil >>
%%             else {s}
%%          end;
%%       if null arbexprns then return;
%%       %% Rebuild the rest of the stucture as ss:
%%       ss := if cdr ss then
%%          subeval nconc(cdr ss, {car ss})
%%       else car ss;
%%       return makelist(ss . arbexprns)
%%    end$

symbolic procedure ODESolve!-Structr(u, x, y, arbop);
   %% Return an rlist representing U that consists of an expression
   %% involving variables `ansj' representing sub-structures followed
   %% by equations of the form `ansj = sub-structure', where the
   %% sub-structures depend non-trivially on the arbitrary opertor
   %% ARBOP and do not depend on X or Y, essentially in the format
   %% returned by structr, or nil if this decomposition is not
   %% possible.
   begin scalar !*savestructr, !*precise, ss, arbexprns;
      !*savestructr := t;
      ss := cdr structr u;              % rlistat; ss = (exprn eqns)
      if null cdr ss then return;

      %% Ignore trivial structure of the form ansj = arbop(i) by
      %% substituting it back into the structure list:
      ss := car ss . for each s in cdr ss join
         if eqcar(caddr(s:=reval s), arbop)
         then << arbexprns := s . arbexprns; nil >>
         else {s};
      if null cdr ss then return;
      if arbexprns then
         ss := cdr subeval nconc(arbexprns, {makelist ss});

      %% Ignore structure that does not depend on arbop by
      %% substituting it back into the structure list:
      arbexprns := nil;
      ss := car ss . for each s in cdr ss join
         if not smember(arbop, s)
         then << arbexprns := s . arbexprns; nil >>
         else {s};
      if null cdr ss then return;
      if arbexprns then
         ss := cdr subeval nconc(arbexprns, {makelist ss});

      %% Ignore all structure that depends on x or y by repeatedly
      %% substituting it back into the structure list:
      arbexprns := t;
      while arbexprns and cdr ss do <<
         arbexprns := nil;
         ss := car ss . for each s in cdr ss join
            if depends(s, x) or depends(s, y)
            then << arbexprns := s . arbexprns; nil >>
            else {s};
         if arbexprns then
            ss := cdr subeval nconc(arbexprns, {makelist ss})
      >>;
      if null cdr ss then return;

      return makelist ss
   end$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odetop.red0000644000175000017500000006317511526203062024326 0ustar  giovannigiovannimodule odetop$  % Top level ODESolve routines, exact ODEs, general
                % nonlinear ODE simplifications and utilities

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% F.J.Wright@maths.qmw.ac.uk, Time-stamp: <11 August 2001>

% TO DO:
%    allow for non-trivial denominator in exact ODEs

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Code to support hooks for extending the functionality of ODESolve
% without needing to edit the main source code.  (Based on the hooks
% supported by Emacs.)  [Note that in CSL, each hook must be declared
% global (or fluid), even for interactive testing, otherwise boundp
% does not work as expected!]

% To do: Run hooks within an errorset for extra security?

symbolic procedure ODESolve!-Run!-Hook(hook, args);
   %% HOOK is the *name* of a hook; ARGS is a *list* of arguments.
   %% If HOOK is a function or is bound to a function then apply it to
   %% ARGS; if HOOK is bound to a list of functions then apply them in
   %% turn to ARGS until one of them returns non-nil and return that
   %% value.  Otherwise, return nil.
   if getd hook then apply(hook, args)
   else if boundp hook then <<
      hook := eval hook;
      if atom hook then
         getd hook and apply(hook, args)
      else
      begin scalar result;
         while hook and null(
            getd car hook and
            (result:=apply(car hook, args))) do
               hook := cdr hook;
         if hook then return result
      end
   >>$

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Code to break ODE simplifier loops
% ==================================

fluid '(odesolve!-interchange!-list!* !*odesolve!-norecurse)$

global '(ODESolve!-Standard!-x ODESolve!-Standard!-y)$

ODESolve!-Standard!-x := gensym()$
ODESolve!-Standard!-y := gensym()$

symbolic procedure ODESolve!-Standardize(ode, y, x);
   %% Return the numerator of ode in true prefix form and with
   %% standardized variable names.  (What about sign, etc.?)
   subst(ODESolve!-Standard!-y, y,
      subst(ODESolve!-Standard!-x, x, prepf numr simp!* ode))$

symbolic procedure ODESimp!-Interrupt(ode, y, x);
   begin scalar std_ode;
      ode := num !*eqn2a ode;           % Returns ode as expression.
      if member(std_ode:=ODESolve!-Standardize(ode, y, x),
         odesolve!-interchange!-list!*) then <<
            traceode "ODE simplifier loop interrupted! ";
            return t
         >>;
      odesolve!-interchange!-list!* := std_ode .
         odesolve!-interchange!-list!*
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Top-level classification of an ODE, primarily as linear or
% nonlinear.

global '(ODESolve_Before_Hook ODESolve_After_Hook)$
global '(ODESolve_Before_Non_Hook ODESolve_After_Non_Hook)$

algebraic procedure ODESolve!*0(ode, y, x);
   %% Top-level general ODE solver.  If no derivatives call solve?
   %% ***** DO NOT CALL RECURSIVELY *****
   symbolic begin scalar !*precise, solution, !*odesolve!-norecurse,
         odesolve!-interchange!-list!*, !*odesolve!-solvable!-xy;
      %% (odesolve!-interchange!-list!* and !*odesolve!-solvable!-xy
      %% are used to prevent infinite loops.)
      ode := num !*eqn2a ode;           % returns ode as expression
      if (solution := or(
         ODESolve!-Run!-Hook('ODESolve_Before_Hook, {ode,y,x}),
         ODESolve!*1(ode, y, x),
         %% Call ODESolve!-Diff once only, not in recursive loop?
         %% SHOULD apply only to nonlinear ODEs?
         not !*odesolve_fast and ODESolve!-Diff(ode, y, x),
         ODESolve!-Run!-Hook('ODESolve_After_Hook, {ode,y,x})))
      then return solution;
      traceode "ODESolve cannot solve this ODE!"
   end$

algebraic procedure ODESolve!*1(ode, y, x);
   %% Top-level discrimination between linear and nonlinear ODEs.
   %% May be called recursively.
   %% (NB: A product of linear factors is NONLINEAR!)
   symbolic if !*odesolve!-norecurse then
      traceode "ODESolve terminated: no recursion mode!"
   else if ODESimp!-Interrupt(ode, y, x) then nil else
   <<
      !*odesolve!-norecurse := !*odesolve_norecurse;
      traceode1 "Entering top-level general recursive solver ...";
      if ODE!-Linearp(ode, y) then      % linear
         ODESolve!-linear(ode, y, x)
      else  % nonlinear -- turn off basis solution
      algebraic begin scalar !*odesolve_basis, ode_factors, solns;
         %% Split into algebraic factors (which may lose exactness).
         %% For each algebraic factor, check its linearity and call
         %% appropriate (linear or nonlinear) main solver.
         %% Merge solution sets.
         traceode1 "Trying to factorize nonlinear ODE algebraically ...";
         ode_factors := factorize ode;
         %% { {factor, multiplicity}, ... }
         if length ode_factors = 1 and second first ode_factors = 1 then
            %% Guaranteed algebraically-irreducible nonlinear ODE ...
            return ODESolve!-nonlinear(ode, y, x);
         traceode "This is a nonlinear ODE that factorizes algebraically ",
            "and each distinct factor ODE will be solved separately ...";
         solns := {};
         while ode_factors neq {} do
         begin scalar fac;
            %% Discard repeated factors:
            if smember(y, fac := first first ode_factors) then
               %% Guaranteed algebraically-irreducible -- may be
               %% either algebraic or linear or nonlinear ODE ...
               if (fac := ODESolve!*2!*(fac, y, x)) then <<
                  solns := append(solns, fac);
                  ode_factors := rest ode_factors
               >>  else solns := ode_factors := {}
            else <<
               if depends(fac, x) or depends(fac, y) then
                  symbolic MsgPri("ODE factor", fac, "ignored", nil, nil);
               ode_factors := rest ode_factors
            >>;
         end;
         %% Finally check whether the UNFACTORIZED ode was exact:
         return
            if solns = {} then Odesolve!-Exact!*(ode, y, x)
            else solns
      end
   >>$

algebraic procedure ODESolve!-FirstOrder(ode, y, x);
   %% Solve an ARBITRARY first-order ODE.
   %% (Called from various other modules.)
   symbolic <<
      ode := num !*eqn2a ode;
      traceode ode = 0;
%%       if ODE!-Linearp(ode, y)        % nil <> 0 !!!
%%       then ODENon!-Linear1(ode, y, x)
%%       else ODESolve!-NonLinear1(ode, y, x)
      %% A nonlinear first-order ODE may need the full solver ...
      %% but could later arrange to pass the order rather than
      %% recompute it.
      ODESolve!*1(ode, y, x)
   >>$

algebraic procedure ODESolve!*2!*(ode, y, x);
   %% Internal discrimination between algebraic or differential factor.
   if smember(df, ode) then             % ODE
      ODESolve!*2(ode, y, x)
   else if ode = y then                 % Common special algebraic case,
      {y = 0}                           % e.g. solving autonomous ODEs.
   else solve(ode, y)$                  % General algebraic case.

algebraic procedure ODESolve!*2(ode, y, x);
   %% Internal discrimination between linear and nonlinear ODEs.  Like
   %% ODESolve!*1 but does not attempt any algebraic factorization.
   symbolic <<
      traceode1 "Entering top-level recursive solver ",
         "without algebraic factorization ...";
      traceode ode=0;
      if ODE!-Linearp(ode, y) then      % linear
         ODESolve!-linear(ode, y, x)
      else                              % nonlinear
         ODESolve!-nonlinear(ode, y, x)
   >>$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% The entry point to the non-trivially nonlinear ODE solver
% =========================================================

algebraic procedure ODESolve!-nonlinear(ode, y, x);
   %% Attempt to solve an algebraically-irreducible nonlinear ODE.
   symbolic %% if ODESimp!-Interrupt(ode, y, x) then nil else
      begin scalar ode_order;
         ode_order := ODE!-Order(ode, y);
         traceode "This is a nonlinear ODE of order ", ode_order, ".";
         return or(
            ODESolve!-Run!-Hook(
               'ODESolve_Before_Non_Hook, {ode,y,x,ode_order}),
            (if ode_order = 1 then
               ODESolve!-nonlinear1(ode, y, x)
            else
               %% ODESolve!-Diff(ode, y, x) or % TEMPORARY
               ODESolve!-nonlinearn(ode, y, x)),
            ODESolve!-Exact(ode, y, x, ode_order),
            not !*odesolve_fast and ODESolve!-Alg!-Solve(ode, y, x),
            not !*odesolve_fast and ODESolve!-Interchange(ode, y, x),
            ODESolve!-Run!-Hook(
               'ODESolve_After_Non_Hook, {ode,y,x,ode_order}))
      end$

symbolic procedure ODESolve!-Interchange(ode, y, x);
   %% Interchange x <--> y and try to solve.
   %% PROBABLY NOT DESIRABLE FOR LINEAR ODES!
   if !*odesolve_noswap then
      traceode "ODESolve terminated: no variable swap mode!"
   else
   ( begin scalar !*precise;            % Can cause trouble here
      traceode
         "Interchanging dependent and independent variables ...";
      %% Should fully canonicalize ode before comparison!!!
      %% Temporarily, just use reval to at least ensure the same format.
      %% Cannot use aeval form because simplified flag gets reset.
%%       odesolve!-interchange!-list!* :=
%%          %% reval ode . odesolve!-interchange!-list!*;
%%          ODESolve!-Standardize(ode, y, x) . odesolve!-interchange!-list!*;
      depend1(x, y, t);
      algebraic begin scalar rules;
         rules := {odesolve!-df(y,x,~n) => 1/odesolve!-df(x,y)*
            odesolve!-df(odesolve!-df(y,x,n-1),y) when n > 1,
            odesolve!-df(y,x) => 1/odesolve!-df(x,y),
            odesolve!-df(y,x,1) => 1/odesolve!-df(x,y)};
         ode := sub(df = odesolve!-df, ode);
         ode := (ode where rules);
         ode := num sub(odesolve!-df = df, ode)
      end;
      depend1(y, x, nil);   % Necessary to avoid dependence loops
      %% Now ode is an ode for x as a function of y
      traceode ode;
%%       %% if member(reval ode, odesolve!-interchange!-list!*) then
%%       if member(ODESolve!-Standardize(ode, x, y),
%%          odesolve!-interchange!-list!*) then
%%          %% Give up -- we have already interchanged variables in this
%%          %% ode once!
%%          << !*odesolve_failed := t;  return algebraic {ode=0} >>;
      ode := ODESolve!*1(ode, x, y);    % Try again ..
      if ode then return
         makelist for each soln in cdr ode join
            if smember(y, soln) then {soln} else {}
   end ) where depl!* = depl!*$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Exact equations
% ===============

% Solve an ODE if it is an exact first or second order ODE.  Exactness
% might be lost by factorizing an ode, so all exact ode routines are
% gathered together here under one master routine that can be called
% independently of any ODE simplification.

% Replace by one general routine for any order nonlinear ODE?

% The first-order code is based on code by Malcolm MacCallum.

algebraic procedure ODESolve!-Exact!*(ode, y, x);
   %% Solve an exact first or second order nonlinear ODE of unknown
   %% order.
   ODESolve!-Exact(ode, y, x, ODE!-Order(ode, y))$

algebraic procedure ODESolve!-Exact(ode, y, x, ode_order);
   %% Solve an exact first or second order nonlinear ODE of known
   %% order.
   begin scalar c, den_ode, result;
      traceode1 "Checking for an exact ode ...";
      c := coeff(num ode, df(y,x,ode_order));
      den_ode := den ode;
      if not depends(den_ode, x) then den_ode := 0;
      %% ... meaning den ode has no effect on exactness.
      %% if length c neq 2 or depends(c, df(y,x,n)) then return;
      %% NB: depends recurses indefinitely if x depends on y, i.e. after
      %% interchange at present.  But smember nearly suffices anyway!
      if length c neq 2 or smember(df(y,x,ode_order), c) then return;
      return if ode_order = 1 then
         symbolic ODESolve!-Exact!-1(c, den_ode, y, x)
      else if ode_order = 2 then
         symbolic ODESolve!-Exact!-2(c, den_ode, y, x)
   end$

symbolic procedure ODESolve!-Exact!-1(c, den_ode, y, x);
   %% Solves the ode if it is an exact (nonlinear) first order ode of
   %% the form = N dy/dx + M.
   ( algebraic begin scalar M, N;
      M := first c;  N := second c;
      symbolic depend1(y, x, nil);      % all derivatives partial
      if df(M,y) - df(N,x) and
         (not den_ode or df(M:=M/den_ode,y) - df(N:=N/den_ode,x))
      then return;
      %% traceode "This is an exact first-order ODE.";
      traceode "It is exact and is solved by quadrature.";
      return {exact1_pde(M, N, y, x) = 0}
   end ) where depl!* = depl!*$

algebraic procedure exact1_pde(M, N, y, x);
   %% Return phi(x,y) such that df(phi,x) = M(x,y), df(phi,y) =
   %% N(x,y), required to integrate first and second order exact odes.
   begin scalar int_M;  int_M := int(M, x);
      %% phi = int_M + f(y)
      %% => df(phi,y) = df(int_M,y) + df(f,y) = N
      %% => f = int(N - df(int_M,y), y)
      return num(int_M + int(N - df(int_M,y), y) + newarbconst())
   end$

symbolic procedure ODESolve!-Exact!-2(c, den_ode, y, x);
   %% Computes a first integral of ODE if it is an exact (nonlinear)
   %% second order ODE of the form f(x,y,y') y'' + g(x,y,y') = 0.
   %% *** EXTEND THIS GENERAL CODE TO HIGHER ORDER ??? ***
   ( algebraic begin scalar p, f, g, h, first_int, h_x, h_y;
      p := gensym();
      f := sub(df(y,x) = p, second c);
      g := sub(df(y,x) = p, first c);
      symbolic depend1(y, x, nil);      % all derivatives partial
      if ODESolve!-Exact!-2!-test(f, g, p, y, x)
         and (not den_ode or
            ODESolve!-Exact!-2!-test(f:=f/den_ode, g:=g/den_ode, p, y, x))
      then return;
      %% ODE is exact
      %% traceode "This is an exact second-order ODE for which ",
      %%   "a first integral can be constructed:";
      traceode "It is exact and a first integral can be constructed ...";
      h := gensym();
      symbolic depend1(h, x, t);  symbolic depend1(h, y, t);
      first_int := int(f, p) + h;
      c := df(first_int,x) + df(first_int,y)*p - g; % = 0
      %% Should be linear in p by construction -- equate coeffs:
      c := coeff(num c, p);
      if length c neq 2 or depends(c, p) then return
         traceode "but ODESolve cannot determine the arbitrary function!";
      %% MUST be linear in h_x and h_y by construction, so ...
      h_x := coeff(first c, df(h,x));  h_x := -first h_x / second h_x;
      h_y := coeff(second c, df(h,y));  h_y := -first h_y / second h_y;
      h_x := exact1_pde(h_x, h_y, y, x);
      symbolic depend1(y, x, t);
      first_int := sub(h = h_x, p = df(y,x), first_int);
      %% traceode first_int = 0;
      first_int := ODESolve!-FirstOrder(first_int, y, x);
      return
         if first_int then ODESolve!-Simp!-ArbConsts(first_int, y, x)
         else traceode "But ODESolve cannot solve it!"
   end ) where depl!* = depl!*$

algebraic procedure ODESolve!-Exact!-2!-test(f, g, p, y, x);
   if ( (df(f,x,2) + 2p*df(f,x,y) + p^2*df(f,y,2)) -
      (df(g,x,p) + p*df(g,y,p) - df(g,y)) or
         (df(f,x,p) + p*df(f,y,p) + 2df(f,y)) - df(g,p,2) ) then 1$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

switch odesolve_diff$                   % TEMPORARY?
symbolic(!*odesolve_diff := t)$         % TEMPORARY?

fluid '(!*arbvars)$

algebraic procedure ODESolve!-Diff(ode, y, x);
   %% If the derivative of ode factorizes then try to solve each
   %% factor and return the solutions, otherwise return nil.
   %% This is the inverse of detecting an exact ode!
   if symbolic !*odesolve_diff then     % TEMPORARY?
   begin scalar ode_factors, solns;
      load_package solve;  % to allow overriding !*arbvars := t
      traceode1
         "Trying to factorize derivative of ODE algebraically ...";
      ode_factors := factorize num df(ode, x);
      %% { {factor, multiplicity}, ... }
      if length ode_factors = 1 and second first ode_factors = 1 then return;
      traceode "The derivative of the ODE factorizes algebraically ",
         "and each distinct factor ODE will be solved separately ...";
      solns := {};
      while ode_factors neq {} do
      begin scalar fac, deriv_orders, first!!arbconst, arbconsts,
         !*arbvars;
         fac := first first ode_factors;  ode_factors := rest ode_factors;
         deriv_orders := get_deriv_orders(fac, y);
         %% Check for purely algebraic factor:
         if deriv_orders = {} then return;  % no y -- ignore
         if deriv_orders = {0} then return
            for each s in solve(fac, y) do
               if sub(s, ode) = 0 then solns := (s = 0) . solns;
         first!!arbconst := !!arbconst + 1;
         fac := ODESolve!*2(fac, y, x); % to avoid nasty loops
         if not fac then return solns := ode_factors := {};
         arbconsts :=
            for i := first!!arbconst : !!arbconst collect arbconst i;
         %% ***** THIS WILL WORK ONLY FOR EXPLICIT SOLUTIONS *****
         for each soln in fac do
            for each s in solve(sub(soln, ode), arbconsts) do
               solns := sub(s, soln) . solns
      end;
      if solns neq {} then return solns;
      traceode "... but cannot solve all factor ODEs.";
   end$

algebraic procedure ODESolve!-Alg!-Solve(ode, y, x);
   %% Try to solve algebraically for a single derivative and then
   %% solve each solution ode directly.
   begin scalar deriv, L, R, d, root_odes, solns;
      scalar !*fullroots, !*trigform, !*precise;
      %% symbolic(!*fullroots := t);       % Can be VERY slow!
      traceode1
         "Trying to solve algebraically for a single derivative ...";
      deriv := delete(0, get_deriv_orders(ode, y));
      if length deriv neq 1 then return; % not a single deriv
      %% Now ode is an expression in df(y,x,ord) involving no other
      %% derivatives.  Try to solve it algebraically for the
      %% derivative.
      deriv := df(y, x, first deriv);
      if not( smember(deriv, L:=lcof(ode,deriv)) or
              smember(deriv, R:=reduct(ode,deriv)) ) then
         if (d:=deg(ode,deriv)) = 1 then
            return                      % linear in single deriv
         else
            root_odes :=                % single integer power
               { num(deriv - (-R/L)^(1/d)*newroot_of_unity(d)) }
               %% Expand roots of unity later.
      else <<
         root_odes := solve(ode, deriv);
         if not(length root_odes > 1 or
            first root_multiplicities > 1) then return;
         %% Eventually, replace above 3 lines with this:
         %% root_odes := SolvePM(ode, deriv); % `use `plus_or_minus'
         root_odes := for each ode in root_odes collect
            num if symbolic eqcar(caddr ode, 'root_of) then
               sub(part(rhs ode, 2)=deriv, part(rhs ode, 1))
            else lhs ode - rhs ode
      >>;
      traceode "It can be (partially) solved algebraically ",
         "for the single-order derivative ",
         "and each `root ODE' will be solved separately ...";
      solns := {};
      while root_odes neq {} do
      begin scalar soln;
         if (soln := ODESolve!*2(first root_odes, y, x)) then <<
            solns := append(solns, soln);
            root_odes := rest root_odes
         >> else solns := root_odes := {}
      end;
      if solns neq {} then return solns
   end$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Utility procedures
% ==================

% Linearity and order tests, which are best kept separate!

%% NB: smember in ODE!-Linearp should probably be depends!

symbolic operator ODE!-Linearp$
symbolic procedure ODE!-Linearp(ode, y);
   %% ODE is assumed to be an expression (not an equation).
   %% Returns t if ODE is linear in y, nil otherwise.
   %% Assumes on exp, mcd.
   ODE!-Lin!-Form!-p(numr simp!* ode, !*a2k y)$

symbolic procedure ODE!-Lin!-Form!-p(sf, y);
   %% A standard (polynomial) form `sf' is linear if each of its terms
   %% is linear:
   domainp sf or
      (ODE!-Lin!-Term!-p(lt sf, y) and ODE!-Lin!-Form!-p(red sf, y))$

symbolic procedure ODE!-Lin!-Term!-p(st, y);
   %% A standard (polynomial) term `st' is linear if either (a) its
   %% leading power is linear and its coefficient is independent of y,
   %% or (b) its leading power is independent of y and its coefficient
   %% is linear:
   begin scalar knl;  knl := tvar st;
      return if knl eq y or (eqcar(knl, 'df) and cadr knl eq y) then
         %% Kernel knl is either y or a derivative of y (df y ...)
         tdeg st eq 1 and not depends(tc st, y)
      else if not depends(knl, y) then ODE!-Lin!-Form!-p(tc st, y)
   end$


symbolic operator ODE!-Order$
symbolic procedure ODE!-Order(u, y);
   %% u is initially an ODE, assumed to be an expression (not an
   %% equation).  Returns its order wrt. y.
   if atom u then 0
   else if car u eq 'df and cadr u eq y then
      %% u = (df y x n) or (df y x)
      (if cdddr u then cadddr u else 1)
   else
      max(ODE!-Order(car u, y), ODE!-Order(cdr u, y))$


symbolic operator get_deriv_orders$
symbolic procedure get_deriv_orders(ode, y);
%    %% Return range of orders of derivatives df(y,x,n) in ode as the
%    %% algebraic list {min_ord, min_d_ord, max_ord} where min_ord
%    %% includes 0, and min_d_ord excludes 0.
   %% Return the SET of all orders of derivatives df(y,x,n) in ode as
   %% an unsorted algebraic list.  Empty if ode freeof y.
   begin scalar result;
      ode := kernels numr simp!* ode;
      if null ode then return makelist nil;
      result := get_deriv_ords_knl(car ode, y);
      for each knl in cdr ode do
         result := union(get_deriv_ords_knl(knl, y), result);
%       return {'list, min_ord,
%          if zerop min_ord then min!* delete(0, result) else min_ord,
%             max!* result} where min_ord = min!* result
      return makelist result
   end$

symbolic procedure get_deriv_ords_knl(knl, y);
   %% Return a list of all orders of derivatives df(y,x,n) in kernel
   %% knl, treating y as df(y,x,0).
   if atom knl then (if knl eq y then (0 . nil))
   else if car knl eq 'df then
      (if cadr knl eq y then
         (if cdddr knl then cadddr knl else 1) . nil)
   else
      ( if in_car then union(in_car, in_cdr) else in_cdr )
         where in_car = get_deriv_ords_knl(car knl, y),
            in_cdr = get_deriv_ords_knl(cdr knl, y)$


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Support for an n'th root of unity operator
% ==========================================

algebraic operator root_of_unity, plus_or_minus$

fluid '(!*intflag!*)$                   % true when in the integrator

% Simplify powers of these operators, but only when not in the
% integrator, which seems to be upset by this:
algebraic let (plus_or_minus(~tag))^2 => 1 when symbolic not !*intflag!*,
   (root_of_unity(~n, ~tag))^n => 1 when symbolic not !*intflag!*$
% Should really be more general, e.g.
%    (root_of_unity(~n, ~tag))^nn => 1 when fixp(nn/n)

algebraic procedure newroot_of_unity(n);
   if n = 0 then RedErr "zeroth roots of unity undefined"
   else if numberp n and (n:=abs num n) = 1 then 1
   else if n = 2 then
      plus_or_minus(newroot_of_unity_tag())
   else
      root_of_unity(n, newroot_of_unity_tag())$

algebraic procedure newplus_or_minus;
   %% Like this for immediate evaluation, especially in symbolic mode:
   symbolic {'plus_or_minus, newroot_of_unity_tag()}$

%% fluid '(!!root_of_unity)$  !!root_of_unity := 0$

algebraic procedure newroot_of_unity_tag;
   %% symbolic mkid('tag_, !!root_of_unity := add1 !!root_of_unity)$
   symbolic mkrootsoftag()$             % defined in module solve/solve1

define expand_plus_or_minus = expand_roots_of_unity$
define expand_root_of_unity = expand_roots_of_unity$

symbolic operator expand_roots_of_unity$
flag('(expand_roots_of_unity), 'noval)$

symbolic procedure expand_roots_of_unity u;
   begin scalar !*NoInt;  !*NoInt := t;  u := aeval u;
      return makelist union(            % discard repeats
         for each uu in (if rlistp u then cdr u else {u}) join
            cdr expand_roots_of_unity1 makelist {uu}, nil)
   end$

symbolic procedure expand_roots_of_unity1 u; % u is an rlist
   ( if r then expand_roots_of_unity1 makelist append(
      (if car r eq 'plus_or_minus then
         cdr subeval{{'equal, r, -1}, u}
      else
      begin scalar n, n!-1;
         if not fixp(n := numr simp!* cadr r) then
            TypErr(n, "root of unity");
         n!-1 := sub1 n;
         return for m := 1 : n!-1 join
            cdr algebraic sub(r = exp(i*2*pi*m/n), u)
      end), cdr subeval{{'equal, r, 1}, u} )
   else u ) where r = find_root_of_unity cdr u$

symbolic procedure find_root_of_unity u; % u is a list
   if atom u then nil
   else if car u eq 'plus_or_minus then u
   else if car u eq 'root_of_unity and evalnumberp cadr u then u
   else find_root_of_unity car u or find_root_of_unity cdr u$

endmodule$

end$
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/zimopbas.tst0000644000175000017500000002071511526203062024711 0ustar  giovannigiovanni% -*- REDUCE -*-
% The Postel/Zimmermann (11/4/96) ODE test examples.
% Equation names from Postel/Zimmermann.
% This version uses Maple-style functional notation wherever possible.
% It outputs general solutions of linear ODEs in basis format.
% It also checks all solutions.

on odesolve_basis, odesolve_check;
on div, intstr;  off allfac;            % to look prettier

% 1  Single equations without initial conditions
% ==============================================

% 1.1 Linear equations
% ====================

operator y;

% (1) Linear Bernoulli 1
odesolve((x^4-x^3)*df(y(x),x) + 2*x^4*y(x) = x^3/3 + C, y(x), x);

% (2) Linear Bernoulli 2
odesolve(-1/2*df(y(x),x) + y(x) = sin x, y(x), x);

% (3) Linear change of variables (FJW: shifted Euler equation)
odesolve(df(y(x),x,2)*(a*x+b)^2 + 4df(y(x),x)*(a*x+b)*a + 2y(x)*a^2 = 0,
   y(x), x);

% (4) Adjoint
odesolve((x^2-x)*df(y(x),x,2) + (2x^2+4x-3)*df(y(x),x) + 8x*y(x) = 1,
   y(x), x);

% (5) Polynomial solutions
% (FJW: Currently very slow, and fails anyway!)
% odesolve((x^2-x)*df(y(x),x,2) + (1-2x^2)*df(y(x),x) + (4x-2)*y(x) = 0,
%    y(x), x);

% (6) Dependent variable missing
odesolve(df(y(x),x,2) + 2x*df(y(x),x) = 2x, y(x), x);

% (7) Liouvillian solutions
% (FJW: INTEGRATION IMPOSSIBLY SLOW WITHOUT EITHER ALGINT OR NOINT OPTION)
begin scalar !*allfac;  !*allfac := t;  return
   odesolve((x^3/2-x^2)*df(y(x),x,2) + (2x^2-3x+1)*df(y(x),x) + (x-1)*y(x) = 0,
      y(x), x, algint);
end;
% NB: DO NOT RE-EVALUATE RESULT WITHOUT TURNING ON ALGINT OR NOINT SWITCH

% (8) Reduction of order
% (FJW: Attempting to make explicit currently too slow.)
odesolve(df(y(x),x,2) - 2x*df(y(x),x) + 2y(x) = 3, y(x), x);

% (9) Integrating factors
% (FJW: Currently very slow, and fails anyway!)
% odesolve(sqrt(x)*df(y(x),x,2) + 2x*df(y(x),x) + 3y(x) = 0, y(x), x);

% (10) Radical solution (FJW: omitted for now)

% (11) Undetermined coefficients
odesolve(df(y(x),x,2) - 2/x^2*y(x) = 7x^4 + 3*x^3, y(x), x);

% (12) Variation of parameters
odesolve(df(y(x),x,2) + y(x) = csc(x), y(x), x);

% (13) Linear constant coefficients
<< factor exp(x);  write
odesolve(df(y(x),x,7) - 14df(y(x),x,6) + 80df(y(x),x,5) - 242df(y(x),x,4)
   + 419df(y(x),x,3) - 416df(y(x),x,2) + 220df(y(x),x) - 48y(x) = 0, y(x), x);
remfac exp(x) >>;

% (14) Euler
odesolve(df(y(x),x,4) - 4/x^2*df(y(x),x,2) + 8/x^3*df(y(x),x) - 8/x^4*y(x) = 0,
   y(x), x);

% (15) Exact n-th order
odesolve((1+x+x^2)*df(y(x),x,3) + (3+6x)*df(y(x),x,2) + 6df(y(x),x) = 6x,
   y(x), x);


% 1.2 Nonlinear equations
% =======================

% (16) Integrating factors 1
odesolve(df(y(x),x) = y(x)/(y(x)*log y(x) + x), y(x), x);

% (17) Integrating factors 2
odesolve(2y(x)*df(y(x),x)^2 - 2x*df(y(x),x) - y(x) = 0, y(x), x);
% This parametric solution is correct, cf. Zwillinger (1989) p.168 (41.10)
% (except that first edition is missing the constant C)!

% (18) Bernoulli 1
odesolve(df(y(x),x) + y(x) = y(x)^3*sin x, y(x), x, explicit);
expand_plus_or_minus ws;

% (19) Bernoulli 2
operator P, Q;
begin scalar soln, !*exp, !*allfac;  % for a neat solution
   on allfac;
   soln := odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^n, y(x), x);
   off allfac;  return soln
end;
odesolve(df(y(x),x) + P(x)*y(x) = Q(x)*y(x)^(2/3), y(x), x);

% (20) Clairaut 1
odesolve((x^2-1)*df(y(x),x)^2 - 2x*y(x)*df(y(x),x) + y(x)^2 - 1 = 0,
   y(x), x, explicit);

% (21) Clairaut 2
operator f, g;
odesolve(f(x*df(y(x),x)-y(x)) = g(df(y(x),x)), y(x), x);

% (22) Equations of the form  y' = f(x,y)
odesolve(df(y(x),x) = (3x^2-y(x)^2-7)/(exp(y(x))+2x*y(x)+1), y(x), x);

% (23) Homogeneous
odesolve(df(y(x),x) = (2x^3*y(x)-y(x)^4)/(x^4-2x*y(x)^3), y(x), x);

% (24) Factoring the equation
odesolve(df(y(x),x)*(df(y(x),x)+y(x)) = x*(x+y(x)), y(x), x);

% (25) Interchange variables
% (NB: Soln in Zwillinger (1989) wrong, as is last eqn in Table 68!)
odesolve(df(y(x),x) = x/(x^2*y(x)^2+y(x)^5), y(x), x);

% (26) Lagrange 1
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) - a*df(y(x),x)^3, y(x), x, implicit);
% root_of quartic is VERY slow if explicit option used!

% (27) Lagrange 2
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) - df(y(x),x)^2, y(x), x, implicit);

% (28) Riccati 1
odesolve(df(y(x),x) = exp(x)*y(x)^2 - y(x) + exp(-x), y(x), x);

% (29) Riccati 2
<< factor x;  write
odesolve(df(y(x),x) = y(x)^2 - x*y(x) + 1, y(x), x);
remfac x >>;

% (30) Separable
odesolve(df(y(x),x) = (9x^8+1)/(y(x)^2+1), y(x), x);

% (31) Solvable for x
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x);
odesolve(y(x) = 2x*df(y(x),x) + y(x)*df(y(x),x)^2, y(x), x, implicit);

% (32) Solvable for y
begin scalar !*allfac;  !*allfac := t;  return
   odesolve(x = y(x)*df(y(x),x) - x*df(y(x),x)^2, y(x), x)
end;

% (33) Autonomous 1
odesolve(df(y(x),x,2)-df(y(x),x) = 2y(x)*df(y(x),x), y(x), x, explicit);

% (34) Autonomous 2  (FJW: Slow without either algint or noint option.)
odesolve(df(y(x),x,2)/y(x) - df(y(x),x)^2/y(x)^2 - 1 + 1/y(x)^3 = 0,
   y(x), x, algint);

% (35) Differentiation method
odesolve(2y(x)*df(y(x),x,2) - df(y(x),x)^2 =
   1/3(df(y(x),x) - x*df(y(x),x,2))^2, y(x), x, explicit);

% (36) Equidimensional in x
odesolve(x*df(y(x),x,2) = 2y(x)*df(y(x),x), y(x), x, explicit);

% (37) Equidimensional in y
odesolve((1-x)*(y(x)*df(y(x),x,2)-df(y(x),x)^2) + x^2*y(x)^2 = 0, y(x), x);

% (38) Exact second order
odesolve(x*y(x)*df(y(x),x,2) + x*df(y(x),x)^2 + y(x)*df(y(x),x) = 0,
   y(x), x, explicit);

% (39) Factoring differential operator
odesolve(df(y(x),x,2)^2 - 2df(y(x),x)*df(y(x),x,2) + 2y(x)*df(y(x),x) -
   y(x)^2 = 0, y(x), x);

% (40) Scale invariant (fails with algint option)
odesolve(x^2*df(y(x),x,2) + 3x*df(y(x),x) = 1/(y(x)^3*x^4), y(x), x);

% Revised scale-invariant example (hangs with algint option):
ode := x^2*df(y(x),x,2) + 3x*df(y(x),x) + 2*y(x) = 1/(y(x)^3*x^4);
% Choose full (explicit and expanded) solution:
odesolve(ode, y(x), x, full);           % or "explicit, expand"
% Check it -- each solution should simplify to 0:
foreach soln in ws collect
   trigsimp sub(soln, num(lhs ode - rhs ode));

% (41) Autonomous, 3rd order
odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
   y(x), x);
% odesolve((df(y(x),x)^2+1)*df(y(x),x,3) - 3df(y(x),x)*df(y(x),x,2)^2 = 0,
%    y(x), x, implicit);
% Implicit form is currently too messy!

% (42) Autonomous, 4th order
odesolve(3*df(y(x),x,2)*df(y(x),x,4) - 5df(y(x),x,3)^2 = 0, y(x), x);


% 1.3 Special equations
% =====================

% (43) Delay
odesolve(df(y(x),x) + a*y(x-1) = 0, y(x), x);

% (44) Functions with several parameters
odesolve(df(y(x,a),x) = a*y(x,a), y(x,a), x);


% 2  Single equations with initial conditions
% ===========================================

% (45) Exact 4th order
odesolve(df(y(x),x,4) = sin x, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=0, df(y(x),x,2)=0, df(y(x),x,3)=0});

% (46) Linear polynomial coefficients -- Bessel J0
odesolve(x*df(y(x),x,2) + df(y(x),x) + 2x*y(x) = 0, y(x), x,
   {x=0, y(x)=1, df(y(x),x)=0});

% (47) Second-degree separable
soln :=
   odesolve(x*df(y(x),x)^2 - y(x)^2 + 1 = 0, y(x)=1, x=0, explicit);
% Alternatively ...
soln where e^~x => cosh x + sinh x;
% but this works ONLY with `on div, intstr; off allfac;'
% A better alternative is ...
trigsimp(soln, hyp, combine);
expand_plus_or_minus ws;

% (48) Autonomous
odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
   {x=0, y(x)=0, df(y(x),x)=2});
%% Only one explicit solution satisfies the conditions:
begin scalar !*trode, !*fullroots;  !*fullroots := t;  return
   odesolve(df(y(x),x,2) + y(x)*df(y(x),x)^3 = 0, y(x), x,
      {x=0, y(x)=0, df(y(x),x)=2}, explicit);
end;


% 3  Systems of equations
% =======================

% (49) Integrable combinations
operator x, z;
odesolve({df(x(t),t) = -3y(t)*z(t), df(y(t),t) = 3x(t)*z(t),
   df(z(t),t) = -x(t)*y(t)}, {x(t),y(t),z(t)}, t);

% (50) Matrix Riccati
operator a, b;
odesolve({df(x(t),t) = a(t)*(y(t)^2-x(t)^2) + 2b(t)*x(t)*y(t) + 2c*x(t),
   df(y(t),t) = b(t)*(y(t)^2-x(t)^2) - 2a(t)*x(t)*y(t) + 2c*y(t)},
   {x(t),y(t)}, t);

% (51) Triangular
odesolve({df(x(t),t) = x(t)*(1 + cos(t)/(2+sin(t))),
   df(y(t),t) = x(t) - y(t)}, {x(t),y(t)}, t);

% (52) Vector
odesolve({df(x(t),t) = 9x(t) + 2y(t), df(y(t),t) = x(t) + 8y(t)},
   {x(t),y(t)}, t);

% (53) Higher order
odesolve({df(x(t),t) - x(t) + 2y(t) = 0,
   df(x(t),t,2) - 2df(y(t),t) = 2t - cos(2t)}, {x(t),y(t)}, t);

% (54) Inhomogeneous system
equ := {df(x(t),t) = -1/(t*(t^2+1))*x(t) + 1/(t^2*(t^2+1))*y(t) + 1/t,
        df(y(t),t) = -t^2/(t^2+1)*x(t) + (2t^2+1)/(t*(t^2+1))*y(t) + 1};
odesolve(equ, {x(t),y(t)}, t);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/odesolve/odesolve.tex0000644000175000017500000012735111526203062024677 0ustar  giovannigiovanni\documentclass[a4paper]{article} % LaTeX2e

\usepackage{hyperref}

\newcommand{\ODESolve}[1]{\texttt{ODESolve\,#1}}
\newcommand{\odesolve}{\texttt{odesolve}}
\newcommand{\REDUCE}{\textsc{Reduce}}

\title{\ODESolve{1.065} : \\ An Enhanced \REDUCE{} ODE Solver}

\author{Francis J. Wright \\
School of Mathematical Sciences \\
Queen Mary, University of London \\
Mile End Road, London E1 4NS, UK. \\
\texttt{F.J.Wright@qmw.ac.uk} \\
\href{http://centaur.maths.qmw.ac.uk/}
{\texttt{http://centaur.maths.qmw.ac.uk/}}}

\date{14 August 2001}

\begin{document}
\maketitle

\tableofcontents

\section{Introduction}

\ODESolve{1+} is an experimental project to update and enhance the
ordinary differential equation (ODE) solver (\odesolve{}) that has
been distributed as a standard component of \REDUCE{}
\cite{Hearn-manual,MacCallum-doc,MacCallum-ISSAC} for about 10 years.
\ODESolve{1+} is intended to provide a strict superset of the
facilities provided by \odesolve{}.  This document describes a
substantial re-implementation of previous versions of \ODESolve{1+}
that now includes almost none of the original \odesolve{} code.  This
version is targeted at \REDUCE~3.7 or later, and will not run in
earlier versions.  This project is being conducted partly under the
auspices of the European CATHODE project \cite{CATHODE}.  Various test
files, including three versions based on a published review of ODE
solvers \cite{Zimmermann}, are included in the \ODESolve{1+}
distribution.  For further background see \cite{FJW1}, which describes
version 1.03.  See also \cite{FJW2}.

\ODESolve{1+} is intended to implement some solution techniques itself
(i.e.\ most of the simple and well known techniques \cite{Zwillinger})
and to provide an automatic interface to other more sophisticated
solvers, such as PSODE \cite{Man,Man-MacCallum,Prelle-Singer} and
CRACK \cite{CRACK-doc}, to handle cases where simple techniques fail.
It is also intended to provide a unified interface to other special
solvers, such as Laplace transforms, series solutions and numerical
methods, under user request.  Although none of these extensions is
explicitly implemented yet, a general extension interface is
implemented (see \S\ref{OEI}).

The main motivation behind \ODESolve{1+} is pragmatic.  It is intended
to meet user expectations, to have an easy user interface that
normally does the right thing automatically, and to return solutions
in the form that the user wants and expects.  Quite a lot of
development effort has been directed toward this aim.  Hence,
\ODESolve{1+} solves common text-book special cases in preference to
esoteric pathological special cases, and it endeavours to simplify
solutions into convenient forms.


\section{Installation}

The file \texttt{odesolve.in} inputs the full set of source files that
are required to implement \ODESolve{1+} \emph{assuming that the
current directory is the \ODESolve{1+} source directory}.  Hence,
\ODESolve{1+} can be run without compiling it in any implementation of
\REDUCE~3.7 by starting \REDUCE{} in the \ODESolve{1+} source
directory and entering the statement
\begin{verbatim}
1: in "odesolve.in"$
\end{verbatim}

However, the recommended procedure is to compile it by starting
\REDUCE{} in the \ODESolve{1+} source directory and entering the
statements
\begin{verbatim}
1: faslout odesolve;
2: in "odesolve.in"$
3: faslend;
\end{verbatim}
In CSL-\REDUCE{}, this will work only if you have write access to the
\REDUCE{} image file (\texttt{reduce.img}), so you may need to set up
a private copy first.  In PSL-\REDUCE{}, you may need to move the
compiled image file \texttt{odesolve.b} to a directory in your PSL
load path, such as the main fasl directory.  Please refer to the
documentation for your implementation of \REDUCE{} for details.  Once
a compiled version of \ODESolve{1+} has been correctly installed, it
can be loaded by entering the \REDUCE{} statement
\begin{verbatim}
1: load_package odesolve;
\end{verbatim}

A string describing the current version of \ODESolve{1+} is assigned
to the algebraic-mode variable \verb|odesolve_version|, which can be
evaluated to check what version is actually in use.

In versions of \REDUCE{} derived from the development source after 22
September 2000, use of the normal algebraic-mode \odesolve{} operator
causes the package to autoload.  However, the \ODESolve{1+} global
switches are not declared, and the symbolic mode interface provided
for backward compatibility with the previous version is not defined,
until after the package has loaded.  The former is not a huge problem
because all \ODESolve{} switches can be accessed as optional
arguments, and the backward compatibility interface should probably
not be used in new code anyway.


\section{User interface}

The principal interface is via the operator \odesolve{}.  (It also has
a synonym called \texttt{dsolve} to make porting of examples from
Maple easier, but it does not accept general Maple syntax!)  For
purposes of description I will refer to the dependent variable as
``$y$'' and the independent variable as ``$x$'', but of course the
names are arbitrary.  The general input syntax is
\begin{verbatim}
odesolve(ode, y, x, conditions, options);
\end{verbatim}
All arguments except the first are optional.  This is possible
because, if necessary, \ODESolve{1+} attempts to deduce the dependent
and independent variables used and to make any necessary
\texttt{DEPEND} declarations.  Messages are output to indicate any
assumptions or dependence declarations that are made.  Here is an
example of what is probably the shortest possible valid input:
\begin{verbatim}
odesolve(df(y,x));

*** Dependent var(s) assumed to be y

*** Independent var assumed to be x

*** depend y , x

{y=arbconst(1)}
\end{verbatim}
Output of \ODESolve{1+} messages is controlled by the standard
\REDUCE{} switch \texttt{msg}.


\subsection{Specifying the ODE and its variables}

The first argument (\texttt{ode}) is \emph{required}, and must be
either an ODE or a variable (or expression) that evaluates to an
ODE\@.  Automatic dependence declaration works \emph{only} when the
ODE is input \emph{directly} as an argument to the \odesolve{}
operator.  Here, ``ODE'' means an equation or expression containing
one or more derivatives of $y$ with respect to $x$.  Derivatives of
$y$ with respect to other variables are not allowed because
\ODESolve{1+} does not solve \emph{partial} differential equations,
and symbolic derivatives of variables other than $y$ are treated as
symbolic constants.  An expression is implicitly equated to zero, as
is usual in equation solvers.

The independent variable may be either an operator that explicitly
depends on the independent variable, e.g.\ $y(x)$ (as required in
Maple), or a simple variable that is declared (by the user or
automatically by \ODESolve{1+}) to depend on the independent variable.
If the independent variable is an operator then it may depend on
parameters as well as the independent variable.  Variables may be
simple identifiers or, more generally, \REDUCE{} ``kernels'', e.g.
\begin{verbatim}
operator x, y;
odesolve(df(y(x(a),b),x(a)) = 0);

*** Dependent var(s) assumed to be y(x(a),b)

*** Independent var assumed to be x(a)

{y(x(a),b)=arbconst(1)}
\end{verbatim}

The order in which arguments are given must be preserved, but
arguments may be omitted, except that if $x$ is specified then $y$
must also be specified, although an empty list \verb|{}| can be used
as a ``place-holder'' to represent ``no specified argument''.
Variables are distinguished from options by requiring that if a
variable is specified then it must appear in the ODE, otherwise it is
assumed to be an option.

Generally in \REDUCE{} it is not recommended to use the identifier
\verb|t| as a variable, since it is reserved in Lisp.  However, it is
very common practice in applied mathematics to use it as a variable to
represent time, and for that reason \ODESolve{1+} provides special
support to allow it as either the independent or a dependent variable.
But, of course, its use may still cause trouble in other parts of
\REDUCE!


\subsection{Specifying conditions}

If specified, the ``conditions'' argument must take the form of an
(unordered) list of (unordered lists of) equations with either $y$,
$x$, or a derivative of $y$ on the left.  A single list of conditions
need not be contained within an outer list.  Combinations of
conditions are allowed.  Conditions within one (inner) list all relate
to the same $x$ value.  For example:
\begin{description}
\item[Boundary conditions:] ~ \\
\{\{y=y0, x=x0\}, \{y=y1, x=x1\}, ...\}

\item[Initial conditions:] ~ \\
\{x=x0, y=y0, df(y,x)=dy0, ...\}

\item[Combined conditions:] ~ \\
\{\{y=y0, x=x0\}, \{df(y,x)=dy1, x=x1\}, \{df(y,x)=dy2, y=y2, x=x2\}, ...\}
\end{description}
Here is an example of boundary conditions:
\begin{verbatim}
odesolve(df(y,x,2) = y, y, x, {{x = 0, y = A}, {x = 1, y = B}});

        2*x      2*x          2
     - e   *a + e   *b*e + a*e  - b*e
{y=-----------------------------------}
                x  2    x
               e *e  - e
\end{verbatim}
Here is an example of initial conditions:
\begin{verbatim}
odesolve(df(y,x,2) = y, y, x, {x = 0, y = A, df(y,x) = B});

     2*x      2*x
    e   *a + e   *b + a - b
{y=-------------------------}
                x
             2*e
\end{verbatim}
Here is an example of combined conditions:
\begin{verbatim}
odesolve(df(y,x,2) = y, y, x, {{x=0, y=A}, {x=1, df(y,x)=B}});

     2*x      2*x          2
    e   *a + e   *b*e + a*e  - b*e
{y=--------------------------------}
               x  2    x
              e *e  + e
\end{verbatim}

Boundary conditions on the values of $y$ at various values of $x$ may
also be specified by replacing the variables by equations with single
values or matching lists of values on the right, of the form
\begin{center}
y = y0, x = x0
\end{center}
or
\begin{center}
y = \{y0, y1, ...\}, x = \{x0, x2, ...\}
\end{center}
For example
\begin{verbatim}
odesolve(df(y,x) = y, y = A, x = 0);

    x
{y=e *a}

odesolve(df(y,x,2) = y, y = {A, B}, x = {0, 1});

        2*x      2*x          2
     - e   *a + e   *b*e + a*e  - b*e
{y=-----------------------------------}
                x  2    x
               e *e  - e
\end{verbatim}


\subsection{Specifying options and defaults}

The final arguments may be one or more of the option identifiers
listed in the table below, which take precedence over the default
settings.  All options can also be specified on the right of equations
with the identifier ``output'' on the left, e.g.\ ``output = basis''.
This facility if provided mainly for compatibility with other systems
such as Maple, although it also allows options to be distinguished
from variables in case of ambiguity.  Some options can be specified on
the left of equations that assign special values to the option.
Currently, only ``trode'' and its synonyms can be assigned the value 1
to give an increased level of tracing.

The following switches set default options -- they are all off by
default.  Options set locally using option arguments override the
defaults set by switches.
\begin{center}
\begin{tabular}{lll}
\bf Switch         & \bf Option  & \bf Effect on solution \\
\hline
odesolve\_explicit & explicit    & fully explicit \\
odesolve\_expand   & expand      & expand roots of unity \\
odesolve\_full     & full        & fully explicit and expanded \\
odesolve\_implicit & implicit    & implicit instead of parametric \\
                   & algint      & turn on algint \\
odesolve\_noint    & noint       & turn off selected integrations \\
odesolve\_verbose  & verbose     & display ODE and conditions \\
odesolve\_basis    & basis       & output basis solution for linear ODE \\
                   & trode \\
trode              & trace       & turn on algorithm tracing \\
                   & tracing \\
odesolve\_fast     & fast        & turn off heuristics \\
odesolve\_check    & check       & turn on solution checking
\end{tabular}
\end{center}

An ``explicit'' solution is an equation with $y$ isolated on the left
whereas an ``implicit'' solution is an equation that determines $y$ as
one or more of its solutions.  A ``parametric'' solution expresses
both $x$ and $y$ in terms of some additional parameter.  Some solution
techniques naturally produce an explicit solution, but some produce
either an implicit or a parametric solution.  The ``explicit'' option
causes \ODESolve{1+} to attempt to convert solutions to explicit form,
whereas the ``implicit'' option causes \ODESolve{1+} to attempt to
convert parametric solutions (only) to implicit form (by eliminating
the parameter).  These solution conversions may be slow or may fail in
complicated cases.

\ODESolve{1+} introduces two operators used in solutions:
\texttt{root\_of\_unity} and \texttt{plus\_or\_minus}, the latter
being a special case of the former, i.e.\ a second root of unity.
These operators carry a tag that associates the same root of unity
when it appears in more than one place in a solution (cf.\ the
standard \texttt{root\_of} operator).  The ``expand'' option expands a
single solution expressed in terms of these operators into a set of
solutions that do not involve them.  \ODESolve{1+} also introduces two
operators \texttt{expand\_roots\_of\_unity} [which should perhaps be
named \texttt{expand\_root\_of\_unity}] and
\texttt{expand\_plus\_or\_minus}, that are used internally to perform
the expansion described above, and can be used explicitly.

The ``algint'' option turns on ``algebraic integration'' locally only
within \ODESolve{1+}.  It also loads the \texttt{algint} package if
necessary.  Algint allows \ODESolve{1+} to solve some ODEs for which
the standard \REDUCE{} integrator hangs (i.e.\ takes an extremely long
time to return).  If the resulting solution contains unevaluated
integrals then the algint switch should be turned on outside
\ODESolve{1+} before the solution is re-evaluated, otherwise the
standard integrator may well hang again!  For some ODEs, the algint
option leads to better solutions than the standard \REDUCE{}
integrator.

Alternatively, the ``noint'' option prevents \REDUCE{} from attempting
to evaluate the integrals that arise in some solution techniques.  If
\ODESolve{1+} takes too long to return a result then you might try
adding this option to see if it helps solve this particular ODE, as
illustrated in the test files.  This option is provided to speed up
the computation of solutions that contain integrals that cannot be
evaluated, because in some cases \REDUCE{} can spend a long time
trying to evaluate such integrals before returning them unevaluated.
This only affects integrals evaluated \emph{within} the \ODESolve{1+}
operator.  If a solution containing an unevaluated integral that was
returned using the ``noint'' option is re-evaluated, it may again take
\REDUCE{} a very long time to fail to evaluate the integral, so
considerable caution is recommended!  (A global switch called
``noint'' is also installed when \ODESolve{1+} is loaded, and can be
turned on to prevent \REDUCE{} from attempting to evaluate \emph{any}
integrals.  But this effect may be very confusing, so this switch
should be used only with extreme care.  If you turn it on and then
forget, you may wonder why \REDUCE{} seems unable to evaluate even
trivial integrals!)

The ``verbose'' option causes \ODESolve{1+} to display the ODE,
variables and conditions as it sees them internally, after
pre-processing.  This is intended for use in demonstrations and
possibly for debugging, and not really for general users.

The ``basis'' option causes \ODESolve{1+} to output the general
solutions of linear ODEs in basis format (explained below).  Special
solutions (of ODEs with conditions) and solutions of nonlinear ODEs
are not affected.

The ``trode'' (or ``trace'' or ``tracing'') option turns on tracing of
the algorithms used by \ODESolve{1+}.  It reports its classification
of the ODE and any intermediate results that it computes, such as a
chain of progressively simpler (in some sense) ODEs that finally leads
to a solution.  Tracing can produce a lot of output, e.g.\ see the
test log file ``\texttt{zimmer.rlg}''.  The option ``\texttt{trode =
1}'' or the global assignment ``\texttt{!*trode := 1}'' causes
\ODESolve{1+} to report every test that it tries in its classification
process, producing even more tracing output.  This is probably most
useful for debugging, but it may give the curious user further insight
into the operation of \ODESolve{1+}.

The ``fast'' option disables all non-deterministic solution techniques
(including most of those for nonlinear ODEs of order $> 1$).  It may
be most useful if \ODESolve{1+} is used as a subroutine, including
calling it recursively in a hook.  It makes \ODESolve{1+} behave like
the \odesolve{} distributed with \REDUCE{} versions up to and
including 3.7, and so does not affect the \texttt{odesolve.tst} file.
The ``fast'' option causes \ODESolve{1+} to return no solution fast in
cases where, by default, if would return either a solution or no
solution (perhaps much) more slowly.  Solution of sufficiently simple
``deterministically-solvable'' ODEs is unaffected.

The ``check'' option turns on checking of the solution.  This checking
is performed by code that is largely independent of the solver, so as
to perform a genuinely independent check.  It is not turned on by
default so as to avoid the computational overhead, which is currently
of the order of 30\%.  A check is made that each component solution
satisfies the ODE and that a general solution contains at least enough
arbitrary constants, or equivalently that a basis solution contains
enough basis functions.  Otherwise, warning messages are output.  It
is possible that \ODESolve{1+} may fail to verify a solution because
the automatic simplification fails, which indicates a failure in the
checker rather than in the solver.  This option is not yet well
tested; please report any checking failures to me (FJW).

In some cases, in particular when an implicit solution contains an
unevaluated integral, the checker may need to differentiate an
integral with respect to a variable other than the integration
variable.  In order to do this, it turns on the differentiator switch
``allowdfint'' globally.  [I hope that this setting will eventually
become the default.]  In some cases, in particular in symbolic
solutions of Clairaut ODEs, the checker may need to differentiate a
composition of operators using the chain rule.  In order to do this,
it turns on the differentiator switch ``expanddf'' locally only.
Although the code to support both these differentiator facilities has
been in \REDUCE{} for a while, they both require patches that are
currently only applied when \ODESolve{1+} is loaded.  [I hope that
these patches will eventually become part of \REDUCE{} itself.]


\section{Output syntax}

If \ODESolve{1+} is successful it outputs a list of sub-solutions that
together represent the solution of the input ODE\@.  Each sub-solution
is either an equation that defines a branch of the solution,
explicitly or implicitly, or it is a list of equations that define a
branch of the solution parametrically in the form $\{y = G(p), x =
F(p), p\}$.  Here $p$ is the parameter, which is actually represented
in terms of an operator called \texttt{arbparam} which has an integer
argument to distinguish it from other unrelated parameters, as usual
for arbitrary values in \REDUCE{}.

A general solution will contain a number of arbitrary constants
represented by an operator called \texttt{arbconst} with an integer
argument to distinguish it from other unrelated arbitrary constants.
A special solution resulting from applying conditions will contain
fewer (usually no) arbitrary constants.

The general solution of a linear ODE in basis format is a list
consisting of a list of basis functions for the solution space of the
reduced ODE followed by a particular solution if the input ODE had a
$y$-independent ``driver'' term, i.e.\ was not reduced (which is
sometimes ambiguously called ``homogeneous'').  The particular
solution is normally omitted if it is zero.  The dependent variable
$y$ does not appear in a basis solution.  The linear solver uses basis
solutions internally.

Currently, there are cases where \ODESolve{1+} cannot solve a linear ODE
using its linear solution techniques, in which case it will try
nonlinear techniques.  These may generate a solution that is not
(obviously) a linear combination of basis solutions.  In this case, if
a basis solution has been requested, \ODESolve{1+} will report that it
cannot separate the nonlinear combination, which it will return as the
default linear combination solution.

If \ODESolve{1+} fails to solve the ODE then it will return a list
containing the input ODE (always in the form of a differential
expression equated to 0).  At present, \ODESolve{1+} does not return
partial solutions.  If it fails to solve any part of the problem then
it regards this as complete failure.  (You can probably see if this
has happened by turning on algorithm tracing.)


\section{Solution techniques}

The \ODESolve{1+} interface module pre-processes the problem and applies
any conditions to the solution.  The other modules deal with the
actual solution.

\ODESolve{1+} first classifies the input ODE according to whether it
is linear or nonlinear and calls the appropriate solver.  An ODE that
consists of a product of linear factors is regarded as nonlinear.  The
second main classification is based on whether the input ODE is of
first or higher degree.

Solution proceeds essentially by trying to reduce nonlinear ODEs to
linear ones, and to reduce higher order ODEs to first order ODEs.
Only simple linear ODEs and simple first-order nonlinear ODEs can be
solved directly.  This approach involves considerable recursion within
\ODESolve{1+}.

If all solution techniques fail then \ODESolve{1+} attempts to
factorize the derivative of the whole ODE, which sometimes leads to a
solution.


\subsection{Linear solution techniques}

\ODESolve{1+} splits every linear ODE into a ``reduced ODE'' and a
``driver'' term.  The driver is the component of the ODE that is
independent of $y$, the reduced ODE is the component of the ODE that
depends on $y$, and the sign convention is such that the ODE can be
written in the form ``reduced ODE = driver''.  The reduced ODE is then
split into a list of ``ODE coefficients''.

The linear solver now determines the order of the ODE\@.  If it is 1
then the ODE is immediately solved using an integrating factor (if
necessary).  For a higher order linear ODE, \ODESolve{1+} considers a
sequence of progressively more complicated solution techniques.  For
most purposes, the ODE is made ``monic'' by dividing through by the
coefficient of the highest order derivative.  This puts the ODE into a
standard form and effectively deals with arbitrary overall algebraic
factors that would otherwise confuse the solution process.  (Hence,
there is no need to perform explicit algebraic factorization on linear
ODEs.)  The only situation in which the original non-monic form of the
ODE is considered is when checking for exactness, which may depend
critically on otherwise irrelevant overall factors.

If the ODE has constant coefficients then it can (in principle) be
solved using elementary ``D-operator'' techniques in terms of
exponentials via an auxiliary equation.  However, this works only if
the polynomial auxiliary equation can be solved.  Assuming that it can
and there is a driver term, \ODESolve{1+} tries to use a method based
on inverse ``D-operator'' techniques that involves repeated
integration of products of the solutions of the reduced ODE with the
driver.  Experience (by Malcolm MacCallum) suggests that this normally
gives the most satisfactory form of solution if the integrals can be
evaluated.  If any integral fails to evaluate, the more general method
of ``variation of parameters'', based on the Wronskian of the solution
set of the reduced ODE, is used instead.  This involves only a single
integral and so can never lead to nested unevaluated integrals.

If the ODE has non-constant coefficients then it may be of Euler
(sometimes ambiguously called ``homogeneous'') type, which can be
trivially reduced to an ODE with constant coefficients.  A shift in
$x$ is accommodated in this process.  Next it is tested for exactness,
which leads to a first integral that is an ODE of order one lower.
After that it is tested for the explicit absence of $y$ and low order
derivatives, which allows trivial order reduction.  Then the monic ODE
is tested for exactness, and if that fails and the original ODE was
non-monic then the original form is tested for exactness.

Finally, pattern matching is used to seek a solution involving special
functions, such as Bessel functions.  Currently, this is implemented
only for second-order ODEs satisfied by Bessel and Airy-integral
functions.  It could easily be extended to other orders and other
special functions.  Shifts in $x$ could also be accommodated in the
pattern matching.  [Work to enhance this component of \ODESolve{1+} is
currently in progress.]

If all linear techniques fail then \ODESolve{1+} currently calls the
variable interchange routine (described below), which takes it into
the nonlinear solver.  Occasionally, this is successful in producing
some, although not necessarily the best, solution of a linear ODE.


\subsection{Nonlinear solution techniques}

In order to handle trivial nonlinearity, \ODESolve{1+} first
factorizes the ODE algebraically, solves each factor that depends on
$y$ and then merges the resulting solutions.  Other factors are
ignored, but a warning is output unless they are purely numerical.

If all attempts at solution fail then \ODESolve{1+} checks whether the
original (unfactored) ODE was exact, because factorization could
destroy exactness.  Currently, \ODESolve{1+} handles only first and
second order nonlinear exact ODEs.

A version of the main solver applied to each algebraic factor branches
depending on whether the ODE factor is linear or nonlinear, and the
nonlinear solver branches depending on whether the order is 1 or
higher and calls one of the solvers described in the next two
sections.  If that solver fails, \ODESolve{1+} checks for exactness
(of the factor).  If that fails, it checks whether only a single order
derivative is involved and tries to solve algebraically for that.  If
successful, this decomposes the ODE into components that are, in some
sense, simpler and may be solvable.  (However, in some cases these
components are algebraically very complicated examples of simple types
of ODE that the integrator cannot in practice handle, and it can take
a very long time before returning an unevaluated integral.)

If all else fails, \ODESolve{1+} interchanges the dependent and
independent variables and calls the top-level solver recursively.  It
keeps a list of all ODEs that have entered the top-level solver in
order to break infinite loops that could arise if the solution of the
variable-interchanged ODE fails.


\subsubsection{First-order nonlinear solution techniques}

If the ODE is a first-degree polynomial in the derivative then
\ODESolve{1+} represents it in terms of the ``gradient'', which is a
function of $x$ and $y$ such that the ODE can be written as ``$dy/dx =
\textit{gradient}$''.  It then checks \emph{in sequence} for the
following special types of ODE, each of which it can (in principle)
solve:
\begin{description}
\item[Separable] The gradient has the form $f(x)g(y)$, leading
immediately to a solution by quadrature, i.e.\ the solution can be
immediately written in terms of indefinite integrals.  (This is
considered to be a solution of the ODE, regardless of whether the
integrals can be evaluated.)  The solver recognises both explicit and
implicit dependence when detecting separable form.

\item[Quasi-separable] The gradient has the form $f(y+kx)$, which is
(trivially) separable after a linear transformation.  It arises as a
special case of the ``quasi-homogeneous'' case below, but is better
treated earlier as a case in its own right.

\item[Homogeneous] The gradient has the form $f(y/x)$, which is
algebraically homogeneous.  A substitution of the form ``$y = vx$''
leads to a first-order linear ODE that is (in principle) immediately
solvable.

\item[Quasi-homogeneous] The gradient has the form $f(\frac{a_1x +
b_1y + c_1}{a_2x + b_2y + c_2})$, which is homogeneous after a linear
transformation.

\item[Bernoulli] The gradient has the form $P(x) y + Q(x) y^n$, in
which case the ODE is a first-order linear ODE for $y^{1-n}$.

\item[Riccati] The gradient has the form $a(x)y^2 + b(x)y + c(x)$, in
which case the ODE can be transformed into a \emph{linear}
second-order ODE that may be solvable.
\end{description}

If the ODE is not first-degree then it may be linear in either $x$ or
$y$.  Solving by taking advantage of this leads to a parametric
solution of the original ODE, in which the parameter corresponds to
$y'$.  It may then be possible to eliminate the parameter to give
either an implicit or explicit solution.

An ODE is ``solvable for $y$'' if it can be put into the form $y =
f(x,y')$.  Differentiating with respect to $x$ leads to a first-order
ODE for $y'(x)$, which may be easier to solve than the original ODE.
The special case that $y = xF(y') + G(y')$ is called a Lagrange (or
d'Alembert) ODE\@.  Differentiating with respect to $x$ leads to a
first-order linear ODE for $x(y')$.  The even more special case that
$y = x y' + G(y')$, which may arise in the equivalent implicit form
$F(xy'-y) = G(y')$, is called a Clairaut ODE\@.  The general solution is
given by replacing $y'$ by an arbitrary constant, and it may be
possible to obtain a singular solution by differentiating and solving
the resulting factors simultaneously with the original ODE.

An ODE is ``solvable for $x$'' if it can be put into the form $x =
f(y,y')$.  Differentiating with respect to $y$ leads to a first-order
ODE for $y'(y)$, which may be easier to solve than the original ODE.

Currently, \ODESolve{1+} recognises the above forms only if the ODE
manifestly has the specified form and does not try very hard to
actually solve for $x$ or $y$, which perhaps it should!


\subsubsection{Higher-order nonlinear solution techniques}

The techniques used here are all special cases of Lie symmetry
analysis, which is not yet applied in any general way.

Higher-order nonlinear ODEs are passed through a number of
``simplifier'' filters that are applied in succession, regardless of
whether the previous filter simplifies the ODE or not.  Currently, the
first filter tests for the explicit absence of $y$ and low order
derivatives, which allows trivial order reduction.  The second filter
tests whether the ODE manifestly depends on $x+k$ for some constant
$k$, in which case it shifts $x$ to remove $k$.

After that, \ODESolve{1+} tests for each of the following special
forms in sequence.  The sequence used here is important, because the
classification is not unique, so it is important to try the most
useful classification first.
\begin{description}
\item[Autonomous] An ODE is autonomous if it does not depend
explicitly on $x$, in which case it can be reduced to an ODE in $y'$
of order one lower.

\item[Scale invariant or equidimensional in $x$] An ODE is scale
invariant if it is invariant under the transformation $x \to ax, y \to
a^py$, where $a$ is an arbitrary indeterminate and $p$ is a constant
to be determined.  It can be reduced to an autonomous ODE, and thence
to an ODE of order one lower.  The special case $p = 0$ is called
equidimensional in $x$.  It is the nonlinear generalization of the
(reduced) linear Euler ODE.

\item[Equidimensional in $y$] An ODE is equidimensional in $y$ if it
is invariant under the transformation $y \to ay$.  An exponential
transformation of $y$ leads to an ODE of the same order that
\emph{may} be ``more linear'' and so easier to solve, but there is no
guarantee of this.  All (reduced) linear ODEs are trivially
equidimensional in $y$.
\end{description}

The recursive nature of \ODESolve{1+}, especially the thread described
in this section, can lead to complicated ``arbitrary constant
expressions''.  Arbitrary constants must be included at the point
where an ODE is solved by quadrature.  Further processing of such a
solution, as may happen when a recursive solution stack is unwound,
can lead to arbitrary constant expressions that should be re-written
as simple arbitrary constants.  There is some simple code included to
perform this arbitrary constant simplification, but it is rudimentary
and not entirely successful.


\section{Extension interface}\label{OEI}

The idea is that the ODESolve extension interface allows any user to
add solution techniques without needing to edit and recompile the main
source code, and (in principle) without needing to be intimately
familiar with the internal operation of \ODESolve{1+}.

The extension interface consists of a number of ``hooks'' at various
critical places within \ODESolve{1+}.  These hooks are modelled in
part on the hook mechanism used to extend and customize the Emacs
editor, which is a large Lisp-based system with a structure similar to
that of \REDUCE\@.  Each \ODESolve{1+} hook is an identifier which can
be defined to be a function (i.e.\ a procedure), or have assigned to
it (in symbolic mode) a function name or a (symbolic mode) list of
function names.  The function should be written to accept the
arguments specified for the particular hook, and it should return
either a solution to the specified class of ODE in the specified form
or nil.

If a hook returns a non-nil value then that value is used by
\ODESolve{1+} as the solution of the ODE at that stage of the solution
process.  [If the ODE being solved was generated internally by
\ODESolve{1+} or conditions are imposed then the solution will be
re-processed before being finally returned by \ODESolve{1+}.]  If a
hook returns nil then it is ignored and \ODESolve{1+} proceeds as if
the hook function had not been called at all.  This is the same
mechanism that it used internally by \ODESolve{1+} to run sub-solvers.
If a hook evaluates to a list of function names then they are applied
in turn to the hook arguments until a non-nil value is returned and
this is the value of the hook; otherwise the hook returns nil.  The
same code is used to run all hooks and it checks that an identifier is
the name of a function before it tries to apply it; otherwise the
identifier is ignored.  However, the hook code does not perform any
other checks, so errors within functions run by hooks will probably
terminate \ODESolve{1+} and errors in the return value will probably
cause fatal errors later in \ODESolve{1+}.  Such errors are user
errors rather than \ODESolve{1+} errors!

Hooks are defined in pairs which are inserted before and after
critical stages of the solver, which currently means the general ODE
solver, the nonlinear ODE solver, and the solver for linear ODEs of
order greater than one (on the grounds that solving first order linear
ODEs is trivial and the standard \ODESolve{1+} code should always
suffice).  The precise interface definition is as follows.

A reference to an ``algebraic expression'' implies that the \REDUCE{}
representation is a prefix or pseudo-prefix form.  A reference to a
``variable'' means an identifier (and never a more general kernel).
The ``order'' of an ODE is always an explicit positive integer.  The
return value of a hook function must always be either nil or an
algebraic-mode list (which must be represented as a prefix form).
Since the input and output of hook functions uses prefix forms (and
never standard quotient forms), hook functions can equally well be
written in either algebraic or symbolic mode, and in fact \ODESolve{1+}
uses a mixture internally.  (An algebraic-mode procedure can return
nil by returning nothing.  The integer zero is \emph{not} equivalent
to nil in the context of \ODESolve{1+} hooks.)

\noindent\hrulefill

\begin{description}
\item[Hook names:] \verb|ODESolve_Before_Hook|,
\verb|ODESolve_After_Hook|.
\item[Run before and after:] The general ODE solver.
\item[Arguments:] 3
\begin{enumerate}
\item The ODE in the form of an algebraic expression with no
denominator that must be made identically zero by the solution.
\item The dependent variable.
\item The independent variable.
\end{enumerate}
\item[Return value:] A list of equations exactly as returned by
\ODESolve{1+} itself.
\end{description}

\noindent\hrulefill

\begin{description}
\item[Hook names:] \verb|ODESolve_Before_Non_Hook|,
\verb|ODESolve_After_Non_Hook|.
\item[Run before and after:] The nonlinear ODE solver.
\item[Arguments:] 4
\begin{enumerate}
\item The ODE in the form of an algebraic expression with no
denominator that must be made identically zero by the solution.
\item The dependent variable.
\item The independent variable.
\item The order of the ODE.
\end{enumerate}
\item[Return value:] A list of equations exactly as returned by
\ODESolve{1+} itself.
\end{description}

\noindent\hrulefill
\pagebreak

\begin{description}
\item[Hook names:] \verb|ODESolve_Before_Lin_Hook|,
\verb|ODESolve_After_Lin_Hook|.
\item[Run before and after:] The general linear ODE solver.
\item[Arguments:] 6
\begin{enumerate}
\item A list of the coefficient functions of the ``reduced ODE'',
i.e.\ the coefficients of the different orders (including zero) of
derivatives of the dependent variable, each in the form of an
algebraic expression, in low to high derivative order.  [In general
the ODE will not be ``monic'' so the leading (i.e.\ last) coefficient
function will not be 1.  Hence, the ODE may contain an essentially
irrelevant overall algebraic factor.]
\item The ``driver'' term, i.e.\ the term involving only the
independent variable, in the form of an algebraic expression.  The
sign convention is such that ``reduced ODE = driver''.
\item The dependent variable.
\item The independent variable.
\item The (maximum) order ($> 1$) of the ODE.
\item The minimum order derivative present.
\end{enumerate}
\item[Return value:] A list consisting of a basis for the solution
space of the reduced ODE and optionally a particular integral of the
full ODE\@.  This list does not contain any equations, and the dependent
variable never appears in it.  The particular integral may be omitted
if it is zero.  The basis is itself a list of algebraic expressions in
the independent variable.  (Hence the return value is always a list
and its first element is also always a list.)
\end{description}

\noindent\hrulefill

\begin{description}
\item[Hook names:] \verb|ODESolve_Before_Non1Grad_Hook|, \\
\verb|ODESolve_After_Non1Grad_Hook|.
\item[Run before and after:] The solver for first-order first-degree
nonlinear (``gradient'') ODEs, which can be expressed in the form
$dy/dx = \mathrm{gradient}(y,x)$.
\item[Arguments:] 3
\begin{enumerate}
\item The ``gradient'', which is an algebraic expression involving (in
general) the dependent and independent variables, to which the ODE
equates the derivative.
\item The dependent variable.
\item The independent variable.
\end{enumerate}
\item[Return value:] A list of equations exactly as returned by
\ODESolve{1+} itself.  (In this case the list should normally contain
precisely one equation.)
\end{description}

\noindent\hrulefill
\bigskip

The file \texttt{extend.tst} contains a very simple test and
demonstration of the operation of the first three classes of hook.

This extension interface is experimental and subject to change.
Please check the version of this document (or the source code) for the
version of \ODESolve{1+} you are actually running.


\section{Change log}

\begin{description}
\item[27 February 1999] Version 1.06 frozen.
\item[13 July 2000] Version 1.061 added an extension interface.
\item[8 August 2000] Version 1.062 added the ``fast'' option.
\item[21 September 2000] Version 1.063 added the ``trace'', ``check''
  and ``algint'' options, the ``Non1Grad'' hooks, handling of implicit
  dependence in separable ODEs, and handling of the general class of
  quasi-homogeneous ODEs.
\item[28 September 2000] Version 1.064 added support for using `t' as
  a variable and replaced the version identification output by the
  \verb|odesolve_version| variable.
\item[14 August 2001] Version 1.065 fixed obscure bugs in the
  first-order nonlinear ODE handler and the arbitrary constant
  simplifier, and revised some tracing messages slightly.

\end{description}


\section{Planned developments}

\begin{itemize}

\item
Extend special-function solutions and allow shifts in $x$.

\item
Improve solution of linear ODEs, by (a) using linearity more generally
to solve as ``CF + PI'', (b) finding at least polynomial solutions of
ODEs with polynomial coefficients, (c) implementing non-trivial
reduction of order.

\item
Improve recognition of exact ODEs, and add some support for more
general use of integrating factors.

\item
Add a ``classify'' option, that turns on trode but avoids any actual
solution, to report all possible (\@?) top-level classifications.

\item
Improve arbconst and arbparam simplification.

\item
Add more standard elementary techniques and more general techniques
such as Lie symmetry, Prelle-Singer, etc.

\item
Improve integration support, preferably to remove the need for the
``noint'' option.

\item
Solve systems of ODEs, including under- and over-determined ODEs and
systems.  Link to CRACK (Wolf) and/or DiffGrob2 (Mansfield)?

\item
Move more of the implementation to symbolic-mode code.

\end{itemize}


\begin{thebibliography}{99}

\bibitem{CATHODE} CATHODE (Computer Algebra Tools for Handling
Ordinary Differential Equations)
\href{http://www-lmc.imag.fr/CATHODE/}%
{\texttt{http://www-lmc.imag.fr/CATHODE/}},
\href{http://www-lmc.imag.fr/CATHODE2/}%
{\texttt{http://www-lmc.imag.fr/CATHODE2/}}.

\bibitem{Hearn-manual} A. C. Hearn and J. P. Fitch (ed.),
\textit{REDUCE User's Manual 3.6}, RAND Publication CP78 (Rev. 7/95),
RAND, Santa Monica, CA 90407-2138, USA (1995).

\bibitem{MacCallum-ISSAC} M. A. H. MacCallum, An Ordinary Differential
Equation Solver for REDUCE, \textit{Proc.\ ISSAC~'88, ed.\ P. Gianni,
Lecture Notes in Computer Science} \textbf{358}, Springer-Verlag
(1989), 196--205.

\bibitem{MacCallum-doc} M. A. H. MacCallum, ODESOLVE, \LaTeX{} file
\texttt{reduce/doc/odesolve.tex} distributed with \REDUCE~3.6.  The
first part of this document is included in the printed REDUCE User's
Manual 3.6 \cite{Hearn-manual}, 345--346.

\bibitem{Man} Y.-K. Man, \textit{Algorithmic Solution of ODEs and
Symbolic Summation using Computer Algebra}, PhD Thesis, School of
Mathematical Sciences, Queen Mary and Westfield College, University of
London (July 1994).

\bibitem{Man-MacCallum} Y.-K. Man and M. A. H. MacCallum, A Rational
Approach to the Prelle-Singer Algorithm, \textit{J. Symbolic
Computation}, \textbf{24} (1997), 31--43.

\bibitem{Zimmermann} F. Postel and P. Zimmermann, A Review of the ODE
Solvers of \textsc{Axiom}, \textsc{Derive}, \textsc{Maple},
\textsc{Mathematica}, \textsc{Macsyma}, \textsc{MuPAD} and
\textsc{Reduce}, \textit{Proceedings of the 5th Rhine Workshop on
Computer Algebra, April 1-3, 1996, Saint-Louis, France.}
Specific references are to the version dated April 11, 1996.
The latest version of this review, together with log files for each of
the systems, is available from
\href{http://www.loria.fr/~zimmerma/ComputerAlgebra/}%
{\texttt{http://www.loria.fr/\textasciitilde zimmerma/ComputerAlgebra/}}.

\bibitem{Prelle-Singer} M. J. Prelle and M. F. Singer, Elementary
First Integrals of Differential Equations, \textit{Trans.\ AMS}
\textbf{279} (1983), 215--229.

\bibitem{CRACK-doc} T. Wolf and A. Brand, The Computer Algebra Package
\texttt{CRACK} for Investigating PDEs, \LaTeX{} file
\texttt{reduce/doc/crack.tex} distributed with \REDUCE~3.6.  A shorter
document is included in the printed REDUCE User's Manual 3.6
\cite{Hearn-manual}, 241--244.

\bibitem{FJW1} F. J. Wright, An Enhanced ODE Solver for REDUCE.
\textit{Programmirovanie} No 3 (1997), 5--22, in Russian, and
\textit{Programming and Computer Software} No 3 (1997), in English.

\bibitem{FJW2} F. J. Wright, Design and Implementation of
\ODESolve{1+} : An Enhanced REDUCE ODE Solver.  CATHODE Workshop
Report, Marseilles, May 1999, CATHODE (1999). \\
\href{http://centaur.maths.qmw.ac.uk/Papers/Marseilles/}%
{\texttt{http://centaur.maths.qmw.ac.uk/Papers/Marseilles/}}.

\bibitem{Zwillinger} D. Zwillinger, \textit{Handbook of Differential
Equations}, Academic Press.  (Second edition 1992.)

\end{thebibliography}

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/0000755000175000017500000000000011722677362022002 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specbess.red0000644000175000017500000000615511526203062024274 0ustar  giovannigiovannimodule specbess;  % Special functions package; Bessel and relatives.

% Author:  Chris Cannam, Sept-Nov 1992.
%          Winfried Neun, Nov 1992 ...
%          contribution from various authors ...

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


remprop('besseli,'simpfn);
remprop('besselj,'simpfn);
remprop('bessely,'simpfn);
remprop('besseli,'simpfn);
remprop('besselk,'simpfn);
remprop('hankel1,'simpfn);
remprop('hankel2,'simpfn);
remprop('kummerM,'simpfn);
remprop('kummerU,'simpfn);
remprop('struveh,'simpfn);
remprop('struvel,'simpfn);
remprop('lommel1,'simpfn);
remprop('lommel2,'simpfn);
remprop('whittakerm,'simpfn);
remprop('whittakerw,'simpfn);
remprop('Airy_Ai,'simpfn);
remprop('Airy_Bi,'simpfn);
remprop('Airy_AiPrime,'simpfn);
remprop('Airy_biprime,'simpfn);


create!-package ('(specbess sfbes sfkummer sfother sfairy),
                 '(contrib specfn));

symbolic smacro procedure sq2bf!*(x);
   (if fixp x then i2bf!: x
      else ((if car y neq '!:rd!: then retag cdr !*rn2rd y
               else retag cdr y) where y = !*a2f x));

symbolic smacro procedure c!:prec!:;
   (if new!*bfs then lispeval '!:bprec!: else !:prec!:);

% These functions are needed in other modules.

algebraic procedure complex!*on!*switch;
   if not symbolic !*complex then
      if symbolic !*msg then
         << off msg;
            on complex;
            on msg >>
      else on complex
   else t;

algebraic procedure complex!*off!*switch;
   if symbolic !*complex then
      if symbolic !*msg then
         << off msg; off complex; on msg >>
      else off complex
   else t;

algebraic procedure complex!*restore!*switch(fl);
   if not fl then
      if symbolic !*msg then
         << off msg;
            if symbolic !*complex then
               off complex
            else on complex;
            on msg >>
      else if symbolic !*complex then
            off complex
         else on complex;

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfbes.red0000644000175000017500000010422311526203062023562 0ustar  giovannigiovannimodule sfbes;  % Procedures and Rules for the Bessel functions.

% Author: Chris Cannam, October 1992.
%
% April 13, 2006 added an improvement proposed by Alain Moussiaux
%
% Firstly, procedures to compute values of the Bessel functions by
% direct bigfloat manipulation; also procedures for large arguments,
% using an asymptotic formula.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% These are specific to the Schoepf/Beckingham binary bigfloats, though
% easily adapted, and they should only be used with n and z both
% numeric, real and non-negative.

% Then follow procedures written in algebraic mode and used for certain
% special cases such as complex arguments.  Anybody who wishes to create
% symbolic mode complex-rounded versions is welcome to do so, with my
% blessing.

% No functions are provided to compute bessel K, though for special
% cases the ruleset handles it.


imports complex!*on!*switch, complex!*off!*switch,
   complex!*restore!*switch, sq2bf!*, sf!*eval;


% This module exports no functions.  I want to keep it available only
% through the algebraic operators, largely because the functions are
% quite a complicated lot.  If you want to use it from symbolic mode,
% use a wrapper and use the algebraic operators- it's slower, but at
% least that way you'll get the answers.

global '(logten);

algebraic operator besselJ, besselY, besselI, besselK, hankel1, hankel2;

%%%%%%%%%%%%%%%%%%%%%%%%%besselj%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% an improvement proposed by Alain Moussiaux

algebraic <<
operator !10j;
let {
!10j(1/2,~x) => sqrt(2/(pi*x))*sin(x),
!10j(-1/2,~x) => sqrt(2/(pi*x))*cos(x),
!10j(3/2,~x) => sqrt(2/(pi*x))*(sin(x)/x-cos(x)),
!10j(-3/2,~x) => sqrt(2/(pi*x))*(-cos(x)/x-sin(x)) };
>>;

algebraic procedure cvpr130108(nu,x);
begin
scalar numf,n;
%tout est scalar
%calcul de bessel nu=1/2,3/2,5/2 etc...
%et des bessel nu=-1/2,-3/2,-5/2 etc
%On renvois 100 si pas dans le cas
%bessel(5/2,x)

if nu=1/2 then
<<
%write "Nu demi entier posif =",nu;
return !10j(1/2,x)>>;

if nu=-1/2 then
<<
%write "Nu demi entier negatif =",nu;
return !10j(-1/2,x)>>;

if nu=3/2 then
<<
%write "Nu demi entier posif =",nu;
return !10j(3/2,x)>>;

if nu=-3/2 then
<<
%write "Nu demi entier negatif =",nu;
return !10j(-3/2,x)>>;

if fixp (nu*2) and (2*nu)>0 then
<<
%write "Nu demi entier posif =",nu;
numf:=num nu;

for n:=5 step 2 until numf do
<<
nu:=n/2;
!10j(nu,x):=(1/x)*(2*(nu-1)*!10j(nu-1,x)-x*!10j(nu-2,x));
>>;
%+++++++++++++
return !10j(nu,x);
>> else
if fixp(-2*nu) and 2*nu < 0 then <<
%write "Nu demi entier negatif =",nu;
numf:=-num nu;
%+++++++++++++++++++++++++
for n:=5 step 2 until numf do <<
nu:=-n/2;
!10j(nu,x):=2*(nu+1)*!10j(nu+1,x)/x-!10j(nu+2,x);
>>;
return !10j(nu,x);
>>;
end;
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

algebraic <  cvpr130108(n,x) when (numberp n and den n = 2 and
                            fixp(num n) and  abs(num n) < 6)>>;

symbolic operator do!*j, do!*y, do!*i;

algebraic (bessel!*rules := {

besselJ(~n,0)  => 1 when n=0,    % We need this form to be sure rules
                                 % are in right order.
besselJ(~n,0)  => 0
   when numberp n and n neq 0,

besselY(~n,0)  =>  infinity,

besselJ(1/2,~z)  =>  sqrt(2/(pi*z)) * sin(z),

besselJ(-1/2,~z)  =>  sqrt(2/(pi*z)) * cos(z),

besselY(-1/2,~z)  =>  sqrt(2/(pi*z)) * sin(z),

besselY(1/2,~z)  =>  - sqrt(2/(pi*z)) * cos(z),

besselK(~n,~z)  =>  sqrt(Pi/(2*z))*e^(-z)
   when (n = 1/2 or n=-1/2),

besselI(1/2,~z)  =>  1/sqrt(Pi*2*z)*(e^z - e^(-z)),

besselI(-1/2,~z)  =>  1/sqrt(pi*2*z)*(e^z + e^(-z)),

% J and Y for negative values and indices.

besselJ(~n,~z)  =>  ((-1)**n) * besselJ(-n,z)
   when numberp n and impart n=0 and n=floor n and n < 0,

besselJ(~n,~z)  =>  ((-1)**n) * besselJ(n,-z)
   when numberp n and impart n=0 and n=floor n
        and numberp z and repart z < 0,

besselY(~n,~z)  =>  ((-1)**n) * besselY(-n,z)
   when numberp n and impart n=0 and n=floor n and n < 0,

besselY(~n,~z)  =>  ((besselJ(n,z)*cos(n*pi))-(besselJ(-n,z)))/sin(n*pi)
   when not symbolic !*rounded
      and numberp n
               and (impart n neq 0 or not (repart n = floor repart n)),

% Hankel functions.

hankel1(~n,~z)  =>  sqrt(2/(pi*z)) * (exp(i*z)/i)
   when symbolic !*complex and n = 1/2,

hankel2(~n,~z)  =>  sqrt(2/(pi*z)) * (exp(-i*z)/(-i))
   when symbolic !*complex and n = 1/2,

hankel1(~n,~z)  =>  besselJ(n,z) + i * besselY(n,z)
   when symbolic !*complex and not symbolic !*rounded,

hankel2(~n,~z)  =>  besselJ(n,z) - i * besselY(n,z)
   when symbolic !*complex and not symbolic !*rounded,


% Modified Bessel functions I and K.

besselI(~n,0)  =>  (if n = 0 then 1 else 0) when numberp n,

besselI(~n,~z)  =>  besselI(-n,z)
   when numberp n and impart n=0 and n=floor n and n < 0,

besselK(~n,~z)  =>  besselK(-n,z)
   when numberp n and impart n=0 and n=floor n and n < 0,

besselK(~n,0)  =>  infinity,

besselK(~n,~z)  =>  (pi/2)*((besselI(-n,z) - besselI(n,z))/(sin(n*pi)))
   when numberp n and impart n = 0 and not (n = floor n),


% Derivatives.

% df(besselJ(~n,~z),z)  =>  -besselJ(1,z) when numberp n and n = 0,
% df(besselY(~n,~z),z)  =>  -besselY(1,z) when numberp n and n = 0,
% df(besselI(~n,~z),z)  =>  besselI(1,z) when numberp n and n = 0,
% df(besselK(~n,~z),z)  =>  -besselK(1,z) when numberp n and n = 0,

% AS (9.1.26 and 27)
df(besselJ(~n,~z),z)  =>  besselJ(n-1,z) - (n/z) * besselJ(n,z),
df(besselY(~n,~z),z)  =>  besselY(n-1,z) - (n/z) * besselY(n,z),
df(BesselK(~n,~z),z)  =>  - BesselK(n-1,z) - (n/z) * BesselK(n,z),
df(hankel1(~n,~z),z)  =>  hankel1(n-1,z) - (n/z) * hankel1(n,z),
df(hankel2(~n,~z),z)  =>  hankel2(n-1,z) - (n/z) * hankel2(n,z),
df(besselI(~n,~z),z)  => (besselI(n-1,z) + besselI(n+1,z)) / 2,


% Sending to be computed

besselJ(~n,~z)  =>  do!*j(n,z)
   when numberp n and numberp z and symbolic !*rounded,

besselY(~n,~z)  =>  do!*y(n,z)
   when numberp n and numberp z and symbolic !*rounded,

besselI(~n,~z)  =>  do!*i(n,z)
   when numberp n and numberp z and symbolic !*rounded

})$

algebraic (let bessel!*rules);


algebraic procedure do!*j(n,z);
   (if impart n = 0 and impart z = 0 and repart z > 0
    then algebraic sf!*eval('j!*calc!*s,{n,z})
    else algebraic sf!*eval('j!*calc,   {n,z}));

algebraic procedure do!*y(n,z);
   (if impart n = 0 and impart z = 0 and n = floor n
    then if repart z < 0
         then algebraic sf!*eval('y!*calc!*sc, {n,z   })
               else algebraic sf!*eval('y!*calc!*s,  {n,z,{}})
    else if impart n neq 0 or n neq floor n
               then y!*reexpress(n,z)
               else algebraic sf!*eval('y!*calc,     {n,z   }));

% What should be the value of BesselY(0,3i)?


algebraic procedure do!*i(n,z);
   (if impart n = 0 and impart z = 0 and repart z > 0
    then algebraic sf!*eval('i!*calc!*s, {n,z})
    else algebraic sf!*eval('i!*calc,    {n,z}));


algebraic procedure j!*calc!*s(n,z);
   begin scalar n0, z0, fkgamnk, result, alglist!*;
      integer prepre, precom;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if z > (2*prepre) and z > 2*n and
               (result := algebraic sf!*eval('asymp!*j!*calc,{n,z})) neq {}
      then
               << precision prepre;
                  complex!*restore!*switch(precom);
                  return result >>;
      if prepre < !!nfpd
      then precision (!!nfpd+3+floor(abs n/10))
      else precision (prepre+6+floor(abs n/10));
      n0 := n; z0 := z;
      fkgamnk := gamma(n+1);
      result :=
               algebraic sf!*eval('j!*calc!*s!*sub,{n0,z0,fkgamnk,prepre});
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;


symbolic procedure j!*calc!*s!*sub(n,z,fkgamnk,prepre);
   begin scalar result, admissable, this,
               modify, fkgamnk, zfsq, zfsqp, knk, azfsq, k;
      n := sq2bf!* n; z := sq2bf!* z;
      fkgamnk := sq2bf!* fkgamnk;
      modify := exp!:(timbf(log!:(divbf(z,bftwo!*),
               c!:prec!:()+2),n), c!:prec!:());
                     % modify := ((z/2)**n);
      zfsq := minus!:(divbf(timbf(z,z),i2bf!: 4));
                     % zfsq := (-(z**2)/4);
      azfsq := abs!: zfsq;
      result := divbf(bfone!*, fkgamnk);
      k := bfone!*; zfsqp := zfsq;
      fkgamnk := timbf(fkgamnk, plubf(n,bfone!*));

      if lessp!:(abs!: result, bfone!*) then
               admissable := abs!: divbf (bfone!*,
                  timbf (exp!:(timbf(fl2bf logten, i2bf!:(prepre +
                                  length explode fkgamnk)), 8), modify))
      else
               admissable := abs!: divbf (bfone!*,
                  timbf (exp!:(timbf(fl2bf logten, i2bf!:(prepre +
                                  length explode (1 + conv!:bf2i abs!: result))), 8),
                     modify));

      this := plubf(admissable, bfone!*);

      while greaterp!:(abs!: this, admissable) do
               << this := divbf(zfsqp, fkgamnk);
                  result := plubf (result, this);
                  k := plubf(k,bfone!*);
                  knk := timbf (k, plubf(n, k));
                  if greaterp!: (azfsq, knk) then
                     precision (precision(0) +
                     length explode(1 + conv!:bf2i divbf (azfsq, knk)));
                  zfsqp := timbf(zfsqp,zfsq);
                  fkgamnk := timbf(fkgamnk,knk) >>;
      result := timbf(result,modify);

      return mk!*sq !*f2q mkround result;
   end;

flag('(j!*calc!*s!*sub), 'opfn);


algebraic procedure asymp!*j!*calc(n,z);
   begin scalar result, admissable, alglist!*,
               modify, chi, mu, p, q, n0, z0;
      integer prepre;
      prepre := precision 0;
      if prepre < !!nfpd
      then precision (!!nfpd + 5)
      else precision (prepre+8);
      modify := sqrt(2/(pi*z));
      admissable := 1 / (10 ** (prepre + 5));
      chi := z - (n/2 + 1/4)*pi;
      mu := 4*(n**2);
      n0 := n; z0 := z;
      p := algebraic symbolic asymp!*p(n0,z0,mu,admissable);
      if p neq {} then
               << q := algebraic symbolic asymp!*q(n0,z0,mu,admissable);
                  if q neq {} then
               result := modify*(first p * cos chi - first q * sin chi)
                  else result := {} >>
      else result := {};
      precision prepre;
      return result;
   end;


algebraic procedure asymp!*y!*calc(n,z);
   begin scalar result, admissable, alglist!*,
               modify, chi, mu, p, q, n0, z0;
      integer prepre;
      prepre := precision 0;
      if prepre < !!nfpd
      then precision (!!nfpd + 5)
      else precision (prepre+8);
      modify := sqrt(2/(pi*z));
      admissable := 1 / (10 ** (prepre + 5));
      chi := z - (n/2 + 1/4)*pi;
      mu := 4*(n**2);
      n0 := n; z0 := z;
      p := algebraic symbolic asymp!*p(n0,z0,mu,admissable);
      if p neq {} then
               << q := algebraic symbolic asymp!*q(n0,z0,mu,admissable);
                  if q neq {} then
               result := modify*(first p * sin chi + first q * cos chi)
                  else result := {} >>
      else result := {};
      precision prepre;
      return result;
   end;


symbolic procedure asymp!*p(n,z,mu,admissable);
   begin scalar result, this, prev, zsq, zsqp, aj2t;
      integer k, f;
      n := sq2bf!* n; z := sq2bf!* z; mu := sq2bf!* mu;
      admissable := sq2bf!* admissable;
      k := 2; f := 1 + conv!:bf2i
               difbf(divbf(n,bftwo!*),divbf(bfone!*,i2bf!: 4));
      this := plubf(admissable, bfone!*);
      result := bfone!*;
      aj2t := asymp!*j!*2term(2, mu);
      zsq := timbf(i2bf!: 4, timbf(z, z));
      zsqp := zsq;
      while greaterp!:(abs!: this, admissable) do
               << prev := abs!: this;
                  this := timbf(i2bf!: ((-1)**(k/2)), divbf(aj2t, zsqp));
                  if greaterp!: (abs!: this, prev) and (k > f)
                  then result := this := bfz!*
                  else
                     << result := plubf(result, this);
                               zsqp := timbf(zsqp, zsq);
                               k := k + 2;
                               aj2t := timbf(aj2t, asymp!*j!*2term!*modifier(k, mu))
                     >> >>;
      if result = bfz!* then return '(list)
      else return list('list, mk!*sq !*f2q mkround result);
   end;


symbolic procedure asymp!*q(n,z,mu,admissable);
   begin scalar result, this, prev, zsq, zsqp, aj2t;
      integer k, f;
      n := sq2bf!* n; z := sq2bf!* z; mu := sq2bf!* mu;
      admissable := sq2bf!* admissable;
      k := 1; f := 1 + conv!:bf2i
               difbf(divbf(n,bftwo!*),divbf(i2bf!: 3, i2bf!: 4));
      this := plubf(admissable, bfone!*);
      result := bfz!*;
      aj2t := asymp!*j!*2term(1, mu);
      zsq := timbf(i2bf!: 4, timbf(z, z));
      zsqp := timbf(bftwo!*, z);
      while greaterp!:(abs!: this, admissable) do
               << prev := abs!: this;
                  this := timbf(i2bf!: ((-1)**((k-1)/2)), divbf(aj2t, zsqp));
                  if greaterp!: (abs!: this, prev) and (k > f)
                  then result := this := bfz!*
                  else
                     << result := plubf(result, this);
                               zsqp := timbf(zsqp, zsq);
                               k := k + 2;
                               aj2t := timbf(aj2t, asymp!*j!*2term!*modifier(k, mu))
                     >> >>;
      if result = bfz!* then return '(list)
      else return list('list, mk!*sq !*f2q mkround result);
   end;


symbolic procedure asymp!*j!*2term(k, mu);
   begin scalar result;
      result := bfone!*;
      for j := 1 step 2 until (2*k - 1) do
               result := timbf(result, difbf(mu, i2bf!: (j**2)));
      result := divbf (result, i2bf!: (factorial k * (2**(2*k))));
      return result;
   end;


symbolic procedure asymp!*j!*2term!*modifier(k, mu);
    (timbf (difbf(mu, i2bf!: ((2*k-3)**2)),
               divbf (difbf(mu, i2bf!: ((2*k-1)**2)),
                  i2bf!: ((k-1) * k * 16))));



algebraic procedure y!*calc!*s(n,z,st);
   begin scalar n0, z0, st0, ps, fkgamnk, result, alglist!*;
      integer prepre, precom;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if z > (2*prepre) and z > 2*n and
               (result := asymp!*y!*calc(n,z)) neq {}
      then
               << precision prepre;
                  complex!*restore!*switch(precom);
                  return result >>;
      if prepre < !!nfpd then precision (!!nfpd+5)
      else precision (prepre + 8);
      n0 := n; z0 := z; st0 := st;
      ps := psi 1 + psi(1+n);
      fkgamnk := gamma(n+1);
      result :=
        algebraic symbolic y!*calc!*s!*sub(n0,z0,ps,fkgamnk,prepre,st0);
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;


% The last arg to the next procedure is an algebraic list of the
% modifier, start value and (factorial n) for the series.  If this is
% (LIST) (i.e. the nil algebraic list {}), the values will be computed
% in this procedure; otherwise the values in st0 will be used.  This
% feature is used for decomposition of the computation of y at negative
% real z.  It is of course designed to make the code as hard to follow
% as possible.  Why else?

% n must be a non-negative integer for this next procedure to work.

symbolic procedure y!*calc!*s!*sub(n,z,ps,fkgamnk,prepre, st0);
   begin scalar start, result, this, ps, fc, modify,
         zfsq, zfsqp, nps, azfsq, bj, z0, n0, tpi, admissable;
      integer k, fk, fnk, difd, fcp;
      z0 := z;
      z := sq2bf!* z; ps := sq2bf!* ps;
      n := sq2bf!* n; n0 := conv!:bf2i n;
      tpi := pi!*();

      if st0 = '(LIST) then
         << modify := divbf(exp!:
                  (timbf(n, log!:(divbf(z, bftwo!*), c!:prec!:()+2)),
                     c!:prec!:()), tpi);
            bj := retag cdr !*a2f
               sf!*eval('j!*calc!*s!*sub,
                  list('list,n0,z0,fkgamnk,prepre));

            if n0 < 1 then
               << start := timbf(timbf(divbf(bftwo!*,tpi),
                        log!:(divbf(z,bftwo!*),c!:prec!:()+1)), bj);
                  fc := factorial n0 >>

            else if (n0 < 100) then
               << start := bfz!*;
                  zfsq := divbf(timbf(z,z), i2bf!: 4);
                  for k := 0:(n0-1) do
                     start := plubf(start, divbf
                        (exptbf(zfsq, k, i2bf!: factorial (n0-k-1)),
                           i2bf!: factorial k));
                  start := minus!: timbf(start, divbf(exp!:
                     (timbf(minus!: n, log!:(divbf(z, bftwo!*),
                        c!:prec!:()+2)), c!:prec!:()), tpi));
                  start := plubf (start,
                        timbf(timbf(divbf(bftwo!*,tpi),bj),
                     log!:(divbf(z,bftwo!*), c!:prec!:()+2)));
                  fc := factorial n0 >>

            else
               << zfsq := divbf(timbf(z,z), i2bf!: 4); zfsqp := bfone!*;
                  fk := 1; fnk := factorial (n0-1); fc := fnk * n0;
                  start := bfz!*;
                  for k := 0:(n0-2) do
                     << start := plubf(start,
                           timbf(i2bf!: fnk, divbf(zfsqp, i2bf!: fk)));
                        fk := fk * (k+1);
                        fnk := fnk / (n0-k-1);
                        zfsqp := timbf(zfsqp, zfsq) >>;
                  start := plubf(start,
                     timbf(i2bf!: fnk, divbf(zfsqp, i2bf!: fk)));
                  start := minus!: plubf(timbf(start,
                        divbf(bfone!*,timbf(modify,timbf(tpi,tpi)))),
                     timbf(timbf(divbf(bftwo!*,tpi), bj),
                        log!:(divbf(z,bftwo!*),c!:prec!:()+2))) >> >>
      else
         << start := sq2bf!* cadr st0;
            modify := sq2bf!* caddr st0;
            fc := cadddr st0 >>;

      zfsq := minus!: divbf(timbf(z,z),i2bf!: 4);
      azfsq := abs!: zfsq;
      result := divbf(ps, i2bf!: fc);
      k := 1; zfsqp := zfsq; fc := fc * (n0+1);
      ps := plubf(ps,plubf(bfone!*,divbf(bfone!*,plubf(n,bfone!*))));


% Note: we are assuming numberp start.  Be sure to catch other cases
% elsewhere.  (Notably for z < 0).  This goes for bessel J as well.

      if lessp!: (abs!: plubf(result, start), bfone!*) then
         admissable := abs!: divbf(divbf(bfone!*,
               exp!:(timbf(fl2bf logten, plubf(i2bf!:(prepre+2),
                  divbf(log!:(divbf(bfone!*,
                        plubf(abs!: result, abs!: start)), 5),
                     fl2bf logten))), 5)), modify)
      else admissable := abs!: divbf(divbf(bfone!*,
               exp!:(timbf(fl2bf logten, plubf(i2bf!:(prepre+2),
                  divbf(log!:(plubf(abs!: result, abs!: start), 5),
                     fl2bf logten))), 5)), modify);

      this := plubf(admissable, bfone!*);

      while greaterp!: (abs!: this, admissable) do
         << this := timbf(ps, divbf(zfsqp, i2bf!: fc));
            result := plubf(result, this);
            k := k + 1; zfsqp := timbf(zfsqp, zfsq);
            nps := plubf(ps,
               plubf(divbf(bfone!*,i2bf!: k),
                  divbf(bfone!*,i2bf!:(k+n0))));
            fcp := k * (n0+k);
            if greaterp!:(timbf(nps,azfsq),timbf(ps,i2bf!: fcp)) then
               << difd := 1 + conv!:bf2i
                     divbf(timbf(nps,azfsq),timbf(ps,i2bf!: fcp));
                  precision (precision(0) + length explode difd) >>;
            fc := fc * fcp;
            ps := nps >>;

      result := difbf(start, timbf(result, modify));
      return mk!*sq !*f2q mkround result;
   end;

algebraic procedure i!*calc!*s(n,z);
   begin scalar n0, z0, ps, fkgamnk, result, alglist!*;
      integer prepre, precom;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if prepre < !!nfpd
      then precision (!!nfpd+3+floor(abs n/10))
      else precision (prepre+8+floor(abs n/10));
      n0 := n; z0 := z;
      fkgamnk := gamma(n+1);
      result :=
               algebraic symbolic i!*calc!*s!*sub(n0,z0,fkgamnk,prepre);
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;


symbolic procedure i!*calc!*s!*sub(n,z,fkgamnk,prepre);
   begin scalar result, admissable, this,
               modify, fkgamnk, zfsq, zfsqp, knk, azfsq, k;

      n := sq2bf!* n; z := sq2bf!* z;
      fkgamnk := sq2bf!* fkgamnk;

      modify := exp!:(timbf(log!:(divbf(z,bftwo!*),
               c!:prec!:()+2),n), c!:prec!:());
                     % modify := ((z/2)**n);
      zfsq := divbf(timbf(z,z),i2bf!:(4));
                     % zfsq := (-(z**2)/4);
      azfsq := abs!: zfsq;
      result := divbf(bfone!*, fkgamnk);
      k := bfone!*; zfsqp := zfsq;
      fkgamnk := timbf(fkgamnk, plubf(n,bfone!*));

      if lessp!:(abs!: result, bfone!*) then
               admissable := abs!: divbf (bfone!*,
                  timbf (exp!:(timbf(fl2bf logten, i2bf!:(prepre +
                                  length explode fkgamnk)), 8), modify))
      else
               admissable := abs!: divbf (bfone!*,
                  timbf (exp!:(timbf(fl2bf logten, i2bf!:(prepre +
                                  length explode (1 + conv!:bf2i abs!: result))),
                               8),
                     modify));

      this := plubf(admissable, bfone!*);

      while greaterp!:(abs!: this, admissable) do
               << this := divbf(zfsqp, fkgamnk);
                  result := plubf (result, this);
                  k := plubf(k,bfone!*);
                  knk := timbf (k, plubf(n, k));
                  if greaterp!: (azfsq, knk) then
                     precision (precision(0) +
                               length explode (1 + conv!:bf2i divbf (azfsq, knk)));
                  zfsqp := timbf(zfsqp, zfsq);
                  fkgamnk := timbf(fkgamnk, knk) >>;
      result := timbf(result, modify);

      return mk!*sq !*f2q mkround result;
   end;


%
% algebraic procedure j!*calc(n,z);
%
%  Given integer n and arbitrary (I hope) z, compute and return
%  the value of the Bessel J-function, order n, at z.  Current
%  version mostly coded for speed rather than clarity.
%
%  Does work for non-integral n.
%

algebraic procedure j!*calc(n,z);
   begin scalar result, admissable, this, alglist!*,
        modify, fkgamnk, zfsq, zfsqp, azfsq, knk; % bind alglist!* to
      integer prepre, k, difd;       % stop global alglist being cleared
      prepre := precision 0;

% Don't need to check if asymptotic expansion is valid;
% if we're using this routine, it's not appropriate anyway.
%      if z > (2*prepre) and z > 2*n and
%              (result := asymp!*j!*calc(n,z)) neq {}
%      then return result;

      precision (prepre + 4);
      modify := ((z/2) ** n);
      zfsq := (-(z**2)/4); azfsq := abs zfsq;
      fkgamnk := gamma(n+1);
      result := (1 / (fkgamnk));
      k := 1; zfsqp := zfsq; fkgamnk := fkgamnk * (n+1);
      if numberp modify and impart modify = 0 then
               if (abs result) < 1 then
                  << difd := ceiling (1/abs result);
                     admissable := abs ((1 / (10 ** (prepre +
                               (symbolic length explode difd)))) / modify) >>
               else
                  << difd := ceiling abs result;
                     admissable := abs ((1 / (10 ** (prepre -
                               (symbolic length explode difd)))) / modify) >>
      else
               if (abs result) < 1 then
                  << difd := ceiling (1/abs result);
                     admissable := abs (1 / (10 ** (prepre + 10 +
                               (symbolic length explode difd)))) >>
               else
                  << difd := ceiling abs result;
                     admissable := abs (1 / (10 ** (prepre + 10 -
                               (symbolic length explode difd)))) >>;
      this := admissable + 1;

      while (abs this > admissable) do
               << this := (zfsqp / (fkgamnk));
                  result := result + this;
                  k := k + 1;                    % Maintain k as term counter,
                  knk := k * (n+k);
                  if azfsq > knk then
               <>;
            zfsqp := zfsqp * zfsq;      % zfsqp as ((-(z**2)/4)**k), and
                  fkgamnk := fkgamnk * knk >>;
                                        % fkgamnk as k! * gamma(n+k+1).
      result := result * modify;
      precision prepre;

      return result;
   end;



%
% Procedure to compute (modified) start value for
% Bessel Y computations. Also used to get imaginary
% part for certain values
%

algebraic procedure y!*modifier!*calc(n,z);
   begin scalar modify, start, zfsq, zfsqp, fc;
      integer fk, fnk, prepre;
      prepre := precision 0;
%      if prepre < !!nfpd then precision (!!nfpd + 2)
%      else precision (prepre + 2);
      modify := ((z/2)**n) / pi;

      %  Simple expression for start value when n<1.
      if (n < 1) then
               << start := ((2/pi) * log(z/2) * besselJ(n,z));
                  fc := factorial n >>

      %  If n smallish, just sum using factorials. (REDUCE
      %  seems to do smallish factorials quite quickly. In
      %  fact it does largish factorials quite quickly as well,
      %  but not quite as quickly as we can build them by
      %  per-term multiplication.)
      else if (n < 100) then
               << start := - (((z/2) ** (-n)) / pi) *
                     (for k := 0:(n-1) sum
                               ((factorial (n-k-1) * (((z**2)/4) ** k)) /
                                 (factorial k))) + ((2/pi)*log(z/2)*besselJ(n,z));
                  fc := factorial n >>

      %  If n largish, avoid computing factorials, and try
      %  to do the minimum possible real work.
      else
               << zfsq := (z**2)/4; zfsqp := 1;
                  fk := 1; fnk := factorial (n-1); fc := fnk * n;
                  start := 0;
                  for k := 0:(n-2) do
                     << start := start + (fnk * zfsqp / fk);
                               fk := fk * (k+1);
                               fnk := floor(fnk/(n-k-1));
                               zfsqp := zfsqp * zfsq >>;
                  start := start + (fnk * zfsqp / fk);
                  start := - ((1/(modify*(pi**2)))*start)+
                     ((2/pi)*log(z/2)*besselJ(n,z)) >>;

      precision prepre;
      return {start, modify, fc};
   end;


%
% algebraic procedure y!*calc(n,z);
%
%  Given integer n and arbitrary (I hope) z, compute and return
%  the value of the Bessel Y-function, order n, at z.  Current
%  version mostly coded for speed rather than clarity.
%
%  Owing to its dependence upon factorials, doesn't work for
%  non-integral n.  (But in any case it'd be very slow, particularly
%  for large non-integral n.)
%

algebraic procedure y!*calc(n,z);
   begin scalar start, result, this, ps, fc, smf,
               modify, zfsq, zfsqp, alglist!*, nps, azfsq;
      integer prepre, k, fk, fnk, difd, fcp;
      prepre := precision(0);

      precision (prepre + 8);
      smf := y!*modifier!*calc (n,z);
      start := first smf;
      modify := second smf;
      fc := third smf;

      %  Now we have the starting value: prepare the loop for
      %  the remaining terms. k will be our loop counter. p1
      %  will hold psi(k+1), and p2 psi(k+n+1); zfsqp is
      %  maintained at ((-(z**2)/4)**k); fc is k! * (n+k)!.
      %  The sum is of (p1 + p2) * zfsqp / fc, and we
      %  precompute the first term in order to get an idea
      %  of the general magnitude (it's a decreasing series).
      ps := psi 1 + psi(1+n);
      zfsq := (-(z**2)/4); azfsq := abs zfsq;
      result := ps / fc;
      k := 1; zfsqp := zfsq; fc := fc * (n+1);
      ps := ps + 1 + (1/(n+1));

      %  Having the first term and start, we check whether
      %  they're small or large and modify the maximum
      %  acceptable error accordingly.
      if numberp start then if (abs (result + start)) < 1 then
            admissable := abs ((1 / (10 **
               (prepre+2 + log10(1/(abs result + abs start)))))/modify)
               else admissable := abs ((1 / (10 ** (prepre + 2))) *
                      (log10(abs result + abs start)) / modify)
      else admissable := abs (1 / (10 ** (prepre + 10)));
      this := admissable + 1;

      %  Now sum the series.
      while ((abs this) > admissable) do
               << this := ps * (zfsqp / fc);
                  result := result + this;
                  k := k + 1; zfsqp := zfsqp * zfsq;
                  nps := ps + (1/k) + (1/(k+n));
                  fcp := k * (n+k);
                  if (nps*azfsq) > (ps*fcp) then
               <>;
                  fc := fc * fcp;                % fc ends up as k! * (n+k)!
                  ps := nps >>;

      %  Amalgamate the start value and modification, and
      %  return the answer.
      result := start - (result * modify);
      precision prepre;
      return result;
   end;




%
% algebraic procedure i!*calc(n,z);
%
%  Given integer n and arbitrary (I hope) z, compute and return
%  the value of the (modified) Bessel I-function, order n, at z.
%  Current version mostly coded for speed rather than clarity.
%
%  Does work for non-integral n.
%

algebraic procedure i!*calc(n,z);
   begin scalar result, admissable, this, prev, nprev, alglist!*,
         modify, fkgamnk, zfsq, zfsqp, knk;  % bind alglist!* to prevent
      integer prepre, k, difd;            % global alglist being cleared
      modify := ((z/2) ** n);
      prepre := precision 0;
      precision (prepre + 4);
      zfsq := (z**2)/4; azfsq := abs zfsq;
      fkgamnk := gamma(n+1);
      result := (1 / (fkgamnk));
      k := 1; zfsqp := zfsq; fkgamnk := fkgamnk * (n+1);
      if numberp modify then
               if (abs result) < 1 then
                  << difd := ceiling (1/abs result);
                     admissable := abs ((1 / (10 ** (prepre +
                               (symbolic length explode difd)))) / modify) >>
               else
                  << difd := ceiling abs result;
                     admissable := abs ((1 / (10 ** (prepre -
                               (symbolic length explode difd)))) / modify) >>
      else
               if (abs result) < 1 then
                  << difd := ceiling (1/abs result);
                     admissable := abs (1 / (10 ** (prepre + 10 +
                               (symbolic length explode difd)))) >>
               else
                  << difd := ceiling abs result;
                     admissable := abs (1 / (10 ** (prepre + 10 -
                               (symbolic length explode difd)))) >>;
      this := admissable + 1; nprev := abs this;
      while (abs this > admissable) do
               << this := (zfsqp / (fkgamnk));
                  result := result + this;
                  k := k + 1;                    % Maintain k as term counter,
                  knk := k * (n+k);
                  if azfsq > knk then
               <>;
            zfsqp := zfsqp * zfsq;      % zfsqp as ((-(z**2)/4)**k), and
                  fkgamnk := fkgamnk * knk >>;
                                        % fkgamnk as k! * gamma(n+k+1).
      result := result * modify;
      precision prepre;
      return result;
   end;



algebraic procedure k!*calc!*2(n,z);
   begin scalar result, precom;
      integer prepre;
      prepre := precision 0;
      precision (prepre + 8);
      precom := complex!*on!*switch();
      result := (pi/2)*i*exp((pi/2)*n*i)*hankel1(n,z*exp((pi/2)*i));
      complex!*restore!*switch(precom);
      precision prepre;
      return result;
   end;



%
% Function which simply rewrites bessely (with nonintegral
% order) in terms of besselj.  Turns off rounded mode to
% do so, because if rounded is on, cos(n*pi) =/= 0 for
% n*2 = floor (n*2), which can lead to some spectacular
% inaccuracies.
%

algebraic procedure y!*reexpress(n,z);
   begin scalar result, premsg;
      premsg := lisp !*msg;
      off msg;
      off rounded;
      result := ((besselJ(n,z)*cos(n*pi))-(besselJ(-n,z)))/sin(n*pi);
      on rounded;
      if premsg then on msg;
      return result;
   end;



%
% Function to make an evil blend of the symbolic and
% algebraic mode bessel-y functions where the order
% is real and the arg is real and negative.  Here the
% result will be complex (probably), but most of the
% computations involved will be with real numbers so
% the symbolic mode version will do them better.
%
% Therefore this routine, which gets the modifier
% and initial terms (the only complex bits) from the
% algebraic procedure and then gets the rest from the
% symbolic one.
%

algebraic procedure y!*calc!*sc(n,z);
   begin scalar st, ic, rc, md, fc, result, precom, prepre;
      prepre := precision 0; z := -z;
      if prepre < !!nfpd then precision (!!nfpd + 2)
      else precision (prepre + 4);
      st := y!*modifier!*calc(n,z);
      rc := - first st;
      precom := complex!*on!*switch();
      ic := impart(log(-pi/2));
      complex!*restore!*switch(precom);
      ic := ic*(2/pi)*besselj(n,-z);
      md := - second st; fc := third st;
      precision prepre;
      precom := complex!*off!*switch();
      result := y!*calc!*s(n,z,{rc,md,fc});
      complex!*restore!*switch(precom);
      if symbolic !*complex
      then result := result + i * ic
      else result := (if ic < 0 then 1 else -1) *
                  sqrt(-(ic**2)) + result;
      return result;
   end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfother.red0000644000175000017500000001602611526203062024135 0ustar  giovannigiovannimodule sfother;   % Rulesets for the Struve H and L functions, Lommel
                  % 1 and 2 functions and Whittaker M and W functions.

% Author: Chris Cannam, Nov 1992.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The aim is to re-express in terms % of other (more `standard') special
% functions. No numerical approximation code.

% Neither imports nor exports functions.
% This module contains only rulesets.

algebraic (operator struveh, struvel);

algebraic (struve!*rules := {

df(struveh(~n,~z),z)  =>
   (2/pi) - struveh(1,z) when numberp n and n = 0,

df(struveh(~n,~x),x) => (x*StruveH(-1 + n,x)- n*StruveH(n,x))/x,

df((z**n)*struveh(~n,~z),z)  => (z**n)*struveh(n-1,z),

df((z**(-n))*struveh(~n,~z),z)  =>
   (1/(sqrt(pi)*(2**n)*gamma(n+(3/2)))) - (z**(-n))*struveh(n+1,z),


struveh(~n,~z)  =>
   ((-1)**n)*besselj(-n,z)
      when numberp n and impart n = 0
         and n < 0 and (n*2)=floor(n*2) and not evenp floor(n*2),

struveh(~n,~z)  =>
   ((2/(pi*z))**(1/2))*(1-cos z) when numberp n and n=1/2,

struveh(~n,~z)  =>
   ((z/(pi*2))**(1/2)) * (1+(2/(z**2))) -
      ((2/(pi*z))**(1/2)) * (sin z + ((cos z)/z))
      when numberp n and n=3/2,

struveh(~n,~x) => (x*0.5)^(n+1)*struve_compute_term(n,x,h)
          when numberp x and numberp n and symbolic !*rounded,

struvel(~n,~x) => struve_compute_term(n,x,l)
          when numberp x and numberp n and symbolic !*rounded,

struvel(~n,~z)  =>
   besseli(-n,z)
      when numberp n and impart n = 0
         and n < 0 and (n*2)=floor(n*2) and not evenp floor(n*2),

struvel(~n,~z)  =>
   -i*(e**((-i*n*pi)/2))*struveh(n,i*z) when symbolic !*complex,

df(struvel(~n,~x),x) => (x*StruveL(-1 + n,x)- n*StruveL(n,x))/x

})$

algebraic (let struve!*rules);



algebraic (operator lommel1, lommel2);

algebraic (lommel!*rules := {

lommel1(~a,~b,~z)  =>
   -(2**a)*besselj(a,z)*gamma(a+1)+z**a
      when numberp a and numberp b and a = b+1,

lommel1(~a,~b,~z)  =>
   lommel1(a,-b,z)
      when numberp b and b < 0 and a neq b and a neq (b+1),

lommel1(~a,~b,~z)  =>
   (sqrt(pi)*(2**a)*gamma((2*a + 1)/2)*struveh(a,z))/2 when a = b,

lommel2(~a,~b,~z)  => z**b when numberp a and numberp b and a = b+1,

lommel2(~a,~b,~z)  => lommel2(a,-b,z)
      when numberp b and b < 0 and a neq b and a neq (b+1),

lommel2(~a,~b,~z)  =>
   (sqrt(pi)*(2**a)*gamma((2*a + 1)/2)*(-bessely(a,z)+struveh(a,z)))/2
      when a = b

})$

algebraic (let lommel!*rules);



algebraic (operator whittakerm, whittakerw);

algebraic (whittaker!*rules := {

whittakerm(~k,~m,~z)  =>
   exp(-z/2)*(z**(1/2+m))*kummerm(1/2+m-k,1+2*m,z),

whittakerw(~k,~m,~z)  =>
   exp(-z/2)*(z**(1/2+m))*kummeru(1/2+m-k,1+2*m,z),

df(WhittakerM(~n,~m,~z),z)  => 1/(2*z)*
        ((1+2*m-2*n)*WhittakerM(n-1,m,z) + (2*n-z)*WhittakerM(n,m,z)),

df(WhittakerW(~n,~m,~z),z)  => 1/(4*z)*
        ((1-4*m^2-4*n+4*n^2)*WhittakerW(n-1,m,z)
                 + (4*n-2*z)*WhittakerW(n,m,z))
% AS (8.5.4)

})$

algebraic (let whittaker!*rules);

%Handbook of Mathematical Functions - page 496

algebraic procedure struve_compute_term(n,x,h_or_l);

begin scalar dmode!*!*;
  lisp(dmode!*!* :=  dmode!*);
 return
  begin scalar pre,term,k,precis,result,!*complex,!*rounded,
   dmode!*,expo,!*msg;
   lisp (dmode!* := dmode!*!*);
  if h_or_l = l
        then << on complex;
                off rounded;
                expo := e^(-i*n*pi/2);
                on rounded;
                return  (-i*expo*struveh(n,i*x))>>
  else <<
   pre := precision 0;
   precis := 10.0^(-pre-2);
   result := 0;

    << if n > -2 then <>
        else for kk:=0:-(n+2) do << k:=kk+1;
                        term := (-1)^kk*(1/2*x)^(2*kk)/
                                (Gamma(kk+3/2) * Gamma(kk+n+3/2));
                        result := result + term>>;
        while abs(term) > precis do
          <<  term:= term*(-0.25)*(x^2)/((k+0.5)*(k+n+0.5));
              result := result + term;
              k := k+1>>;
  >>;  >>;
  return result;
end; end;

symbolic operator struve_compute_term;

% Lambert's W  (Omega) function.
% see: "On Lambert's W function" by R. Corless, G. Gonnet et. al.
% only the principal branch is implemented

algebraic <<

    % Remove autoload properties.
 lisp null remprop('lambert_w,'simpfn);
 lisp null remflag('(lambert_w),'full);

 operator lambert_w;

 let {    lambert_w(0) => 0,
        lambert_w(-1/e) => -1,
        sum((- ~n)^(n-1)/factorial n *~z^n,n,1,infinity)
                        => lambert_w(z),
        df(lambert_w(~z),z) => 1/((1 + lambert_w(z))*e^lambert_w z),
        log(lambert_w(~z)) => log(z) - lambert_w z,
        e^(lambert_w ~z) => ~z/lambert_w z,
        int(lambert_w(~z),z) => z*(lambert_w z -1 +1/lambert_w z),
        lambert_w(~z) =>  num_lambert_w(z)
                when numberp z and lisp !*rounded};

procedure num_lambert_w(z);

     if z=0 then 0 else

       begin scalar wjnew,wj,accu,expwj,oldprec,!*complex,olddmode!*;

         lisp setq(olddmode!* ,dmode!*);
         on complex;
         oldprec := precision 5;
         accu := 10^(- lisp !:prec!:);
         if (abs z) <= 1 then  % starting point for iteration
                 if z >= -1/e then wj := 0 else wj := log(z)
         else wj := log(z) - log(log(z));
         wjnew := 100;
         while abs(wjnew) > accu do <<
             expwj := exp(wj);
             wjnew := - (wj*expwj -z)/
                (expwj*(wj+1)-(1/2(wj+2)*(wj*expwj -z))/(wj+1));
             wj := wj + wjnew >>;

         precision oldprec;
         accu := 10^(- lisp !:prec!:);
         while abs(wjnew) > accu do <<
             expwj := exp(wj);
             wjnew := - (wj*expwj -z)/
                (expwj*(wj+1)-(1/2(wj+2)*(wj*expwj -z))/(wj+1));
             wj := wj + wjnew >>;
        lisp setq(dmode!*,olddmode!*);
         return wj;
    end;

>>;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfellipi.red0000644000175000017500000003503011526203062024266 0ustar  giovannigiovannimodule sfellipi;  % Procedures and Rules for Elliptic Integrals.

% Author: Lisa Temme, ZIB, October 1994

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic <<

%######################################################################
%DESCENDING LANDEN TRANSFORMATION

procedure landentrans(phi,alpha);

   begin scalar alpha_n!+1, alpha_n, phi_n!+1, phi_n, aNtoa0, pNtop0,
                a0toaN, p0topN;

        alpha_n := alpha;
        phi_n   := phi;
        aNtoa0 := {alpha_n};
        pNtop0 := {phi_n};

        while alpha_n > 10^(-(Symbolic !:prec!:)) do
           <<
                alpha_n!+1:= asin(2/(1+cos(alpha_n)) -1);
                phi_n!+1 := phi_n + (atan(cos(alpha_n)*tan(phi_n)))
                            + floor((floor(phi_n/(pi/2))+1)/2)*pi;

                aNtoa0 := alpha_n!+1.aNtoa0;
                pNtop0 := phi_n!+1.pNtop0;

                alpha_n := alpha_n!+1;
                phi_n   := phi_n!+1
           >>;

                a0toaN := reverse(aNtoa0);
                p0topN := reverse(pNtop0);
                return list(p0topN, a0toaN)
   end;

%######################################################################
%VALUE OF EllipticF(phi,m)

procedure F_function(phi,m);

   begin scalar alpha, bothlists, a0toaN, a1toaN, p0topN, phi_n, y,
                elptF;

        alpha  := asin(sqrt(m));
        bothlists := landentrans(phi,alpha);
        a0toaN := PART(bothlists,2);
        a1toaN := REST(a0toaN);
        p0topN := PART(bothlists,1);
        phi_n  := PART(reverse(p0topN),1);

        if phi = (pi/2)
           then
                elptF := K_function(m)
           else
                elptF :=
                phi_n *for each y in a1toaN PRODUCT(1/2)*(1+sin(y));
        return elptF
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%EllipticF definition
%====================

operator EllipticF;

EllipticFrules :=
{
        EllipticF(~phi,0)   => phi,
        EllipticF(i*~phi,0) => i*phi,
        EllipticF(~phi,1)   => ln(sec(phi)+tan(phi)),
        EllipticF(i*~phi,1) => i*atan(sinh(phi)),
        EllipticF(~phi,~m)  => Num_Elliptic(F_function,phi,m)
                              when lisp !*rounded and numberp phi
                              and numberp m
};
let EllipticFrules;

%######################################################################
%VALUE OF K(m)

procedure K_function(m);

   begin scalar AGM, aN;

        AGM := AGM_function(1,sqrt(1-m),sqrt(m));
        aN  := PART(AGM,2);
        return (pi / (2*aN));
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%EllipticK definition
%====================

EllipticKrules :=

{
        EllipticK(~m)   => K_function(m)   when lisp !*rounded
                                                 and numberp m,

        EllipticK!'(~m) => K_function(1-m) when lisp !*rounded
                                                 and numberp m
};
let EllipticKrules;

%######################################################################
%VALUE OF EllipticE(phi,m)

procedure E_function(phi,m);

   begin scalar F, N, alpha, bothlists, a0toaN, p0topN, a1toaN, p1topN,
                sinalist, sinplist, b, s, blist, c, allz, w, z, allx,
                h, x, elptE;

        F := F_function(phi,m);
        alpha := asin(sqrt(m));

        bothlists := landentrans(phi,alpha);
        a0toaN := PART(bothlists, 2);
        p0topN := PART(bothlists, 1);
        a1toaN := REST(a0toaN);
        p1topN := REST(p0topN);

        N := LENGTH(a1toaN);

        sinalist := sin(a1toaN);
        sinplist := sin(p1topN);

        b := PART(sinalist,1);
        s := b;
        blist := for each c in rest sinalist collect << b := b*c >>;
        blist := s.blist;

        allz := 0;
        for w := 1:N do
           <<
                z := (1/(2^w))*PART(blist,w);
                allz := allz + z
           >>;

        allx := 0;
        for h := 1:N do
           <<
                x := (1/(2^h))*((PART(blist,h))^(1/2))
                              *  PART(sinplist,h);

                allx := allx + x
           >>;

        elptE := F * (1 - (1/2)*((sin(PART(a0toaN,1)))^2)*(1 + allz))
                                           + sin(PART(a0toaN,1))*allx ;
        return elptE;
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%EllipticE(phi,m) definition
%====================

operator EllipticE;

JacobiErules :=

{
        EllipticE(0,~m)     => 0,
        EllipticE(~phi,0)   => phi,
        EllipticE(i*~phi,0) => i*phi,
        EllipticE(~phi,1)   => sin(phi),
        EllipticE(i*~phi,1) => i*sinh phi,
        EllipticE(-~phi,~m) => -EllipticE(phi,m),
        EllipticE(~phi,-~m) =>  EllpiticE(phi,m),

        df(EllipticE(~phi,~m),~phi) => Jacobidn(phi,m)^2,
        df(EllipticE(~phi,~m),~m)   =>

               m * (Jacobisn(phi,m) * Jacobicn(phi,m) * Jacobidn(phi,m)
                     -  EllipticE(phi,m) * Jacobicn(phi,m)^2) / (1-m^2)
                     -  m * phi * Jacobisn(phi,m)^2,

        EllipticE(~phi,~m) => Num_Elliptic(E_function,phi,m)
                              when lisp !*rounded and numberp phi
                              and numberp m,

        EllipticE(~m) => Num_Elliptic(E_function,pi/2,m)
                         when lisp !*rounded and numberp m
};
let JacobiErules;

%######################################################################
%CALCULATING THE FOUR THETA FUNCTIONS
%Theta 1 (often written H(u) - and has period 4K)
%Theta 2 (often written H1(u) -and has period 4K)
%Theta 3 (often written Theta1(u) - and has period 2K)
%Theta 4 (often written Theta(u) - and has period 2K)

procedure num_theta(a,u,m);

   begin scalar n, new, all, z, q, total;

        n := if a>2 then 1 else 0;
        new := 100;                     % To initiate loop
        all := 0;
        z := (pi*u)/(2*EllipticK(m));
        q := EXP(-pi*EllipticK(1-m)/EllipticK(m));

        while new > 10^(-(Symbolic !:prec!:)) do
          << new := if a =1 then
                        ((-1)^n)*(q^(n*(n+1)))*sin((2*n+1)*z)
                else if a=2 then (q^(n*(n+1)))*cos((2*n+1)*z)
                else if a=3 then (q^(n*n))*cos(2*n*z)
                else if a=4 then ((-1)^n)*(q^(n*n))*cos(2*n*z);
             all := new + all;
             n := n+1
           >>;
        return if a > 2 then (1 + 2*all)
                else   (2*(q^(1/4))*all);
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Theta Functions

operator EllipticTheta;


EllipticTHETArules :=
{
%Theta1rules
%-----------
        EllipticTheta(1,~u,~m) =>
                 Num_Elliptic(num_theta,1,u,m) when lisp !*rounded
                                  and numberp u and numberp m,

        EllipticTheta(1,-~u,~m) => -EllipticTheta(1,u,m),

        EllipticTheta(1,~u+EllipticK(~m),~m) =>  EllipticTheta(2,u,m),

        EllipticTheta(1,~u+(2*EllipticK(~m)),~m) =>
                                                -EllipticTheta(1,u,m),

        EllipticTheta(1,~u+i*EllipticK!'(~m),~m) =>
                         i*(EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(4,u,m),

        EllipticTheta(1,~u+2*i*EllipticK!'(~m),~m) =>
                                  -(EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(1,u,m),

        EllipticTheta(1,~u+EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                           (EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(3,u,m),

        EllipticTheta(1,~u+2*EllipticK(~m)+2*i*EllipticK!'(~m),~m) =>
                                   (EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(1,u,m),

%Theta2rules
%-----------
        EllipticTheta(2,~u,~m) =>
                 Num_Elliptic(num_theta,2,u,m) when lisp !*rounded
                                  and numberp u and numberp m,

        EllipticTheta(2,-~u,~m) =>  EllipticTheta(2,u,m),

        EllipticTheta(2,~u+EllipticK(~m),~m) => -EllipticTheta(1,u,m),

        EllipticTheta(2,~u+(2*EllipticK(~m)),~m) =>
                                                -EllipticTheta(2,u,m),

        EllipticTheta(2,~u+i*EllipticK!'(~m),~m) =>
                           (EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(3,u,m),

        EllipticTheta(2,~u+2*i*EllipticK!'(~m),~m) =>
                                   (EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(2,u,m),

        EllipticTheta(2,~u+EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                        -i*(EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(4,u,m),

        EllipticTheta(2,~u+2*EllipticK(~m)+2*i*EllipticK!'(~m),~m) =>
                                  -(EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(2,u,m),

%Theta3rules
%-----------
        EllipticTheta(3,~u,~m) =>
                 Num_Elliptic(num_theta,3,u,m) when lisp !*rounded
                                  and numberp u and numberp m,

        EllipticTheta(3,-~u,~m) =>  EllipticTheta(3,u,m),

        EllipticTheta(3,~u+EllipticK(~m),~m) =>  EllipticTheta(4,u,m),

        EllipticTheta(3,~u+(2*EllipticK(~m)),~m) =>
                                                 EllipticTheta(3,u,m),

        EllipticTheta(3,~u+i*EllipticK!'(~m),~m) =>
                           (EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(2,u,m),
        EllipticTheta(3,~u+2*i*EllipticK!'(~m),~m) =>
                                   (EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(3,u,m),

        EllipticTheta(3,~u+EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                         i*(EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(1,u,m),

        EllipticTheta(3,~u+2*EllipticK(~m)+2*i*EllipticK!'(~m),~m) =>
                                   (EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(3,u,m),

%Theta4rules
%-----------
        EllipticTheta(4,~u,~m) =>
                 Num_Elliptic(num_theta,4,u,m) when lisp !*rounded
                                  and numberp u and numberp m,

        EllipticTheta(4,-~u,~m) =>  EllipticTheta(4,u,m),

        EllipticTheta(4,~u+EllipticK(~m),~m) =>  EllipticTheta(3,u,m),

        EllipticTheta(4,~u+(2*EllipticK(~m)),~m)=>EllipticTheta(4,u,m),

        EllipticTheta(4,~u+i*EllipticK!'(~m),~m) =>
                         i*(EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(1,u,m),
        EllipticTheta(4,~u+2*i*EllipticK!'(~m),~m) =>
                                  -(EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(4,u,m),

        EllipticTheta(4,~u+EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                           (EXP(-i*pi*0.5*u/EllipticK(m)))*(nome_q^(-1/2))
                                                *EllipticTheta(2,u,m),

        EllipticTheta(4,~u+2*EllipticK(~m)+2*i*EllipticK!'(~m),~m) =>
                                  -(EXP(-i*pi*u/EllipticK(m)))*(nome_q^-1)
                                                *EllipticTheta(4,u,m),
%Error
%-----
        EllipticTheta(~a,~u,~m) =>

            printerr ("In EllipticTheta(a,u,m);   a = 1,2,3 or 4.")
                         when numberp a
                                    and not(fixp a and a<5 and a>0)
};
let EllipticTHETArules;

%######################################################################
%CALCULATING ZETA

procedure ZETA_function(u,m);

   begin scalar phi_list, clist, L, j, z, cn, phi_n;

        phi_list := PHI_function(1,sqrt(1-m),sqrt(m),u);
        clist := PART(AGM_function(1,sqrt(1-m),sqrt(m)),5);
        L := LENGTH(phi_list);
        j := 1;
        z := 0;
        while j < L do
           <<
                cn    := PART(clist,L-j);
                phi_n := PART(phi_list,1+j);
                z := cn*sin(phi_n) + z;
                j := j+1
           >>;
        return z
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%JacobiZETA definition
%=====================

operator JacobiZeta;

JacobiZETArules :=

{

        JacobiZeta(~u,0)     => 0,
        JacobiZeta(~u,1)     => tanh(u),
        JacobiZeta(-~u,~m)   => -JacobiZeta(u,m),
        JacobiZeta(~u+~v,~m) => JacobiZeta(u,m) + JacobiZeta(v,m) -
                                (m*Jacobisn(u,m)*Jacobisn(v,m)
                                                 *Jacobisn(u+v,m)),

        JacobiZeta(~u+2*EllipticK(~m),m) => JacobiZeta(u,m),
        JacobiZeta(EllipticK(~m) - ~u,m) =>
                                        -JacobiZeta(EllipticK(m)+u,m),

%       JacobiZeta(~u,~m) => JacobiZeta(u - EllipticK(m),m) -
%                            m * Jacobisn(u - EllipticK(m),m)
%                              * Jacobicd(u - EllipticK(m),m),

        JacobiZeta(~u,~m) => Num_Elliptic(ZETA_function,u,m)
                             when lisp !*rounded and numberp u
                             and numberp m
};
let JacobiZETArules;
%######################################################################
>>;
endmodule;
end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfint.red0000644000175000017500000002000211526203062023573 0ustar  giovannigiovannimodule sfint;     % Assorted Integral Functions, Ei, Si, Ci, Li etc.
                  % Includes rules and limited rounded mode evaluation
                  % for Ei, Si, si (called s_i here!), Ci, Chi, Shi,
                  % Fresnel_S, Fresnel_C and Erf;
                  % the numerical part to be improved!
%
% Author: Winfried Neun, Jun 1993
% email : neun@ZIB.de

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% added Li , Winfried Neun, Oct 1998

% For Math References, see e.g. Abramowitz/Stegun, chapter 5 and 7

% Exponential Integral etc.

algebraic operator Fresnel_C, Fresnel_S, erfc,erfi;

% algebraic operator Ci, Si, s_i, shi, chi;
% FJW: Ci, Si also defined in int (driver.red), so ...
symbolic((algebraic operator Ci, Si) where !*msg=nil);
algebraic operator s_i, shi, chi, li;

algebraic let limit(Si(~tt),~tt,infinity) => Pi/2;

algebraic
let { int(sin(~tt)/~tt,~tt,0,~z) => Si (z),
      int(cos(~a*~x)*sin(~b*~x)/x,x) => 1/2*Si(a*x+b*x)-1/2*Si(a*x-b*x),
      int(cos(~a*~x)*sin(~x)/x,x) => 1/2*Si(a*x+x)-1/2*Si(a*x-x),
      int(cos(~x)*sin(~b*~x)/x,x) => 1/2*Si(x+b*x)-1/2*Si(x-b*x),
      int(cos(~x)*sin(~x)/x,x) => 1/2*Si(2*x),
      Si(0) => 0,
      Si(-~x) => (- Si(x)),
      df(Si(~x),~x) => sin(x)/x  ,
      Si(~x) => compute_int_functions(x,Si)
                 when numberp x and lisp !*rounded
    };

algebraic
let { int(sin(~tt)/~tt,~tt,~z,infinity) => - s_i (z),
      limit(s_i(~tt),x,infinity) => 0,
      s_i(~x) => Si(x) - pi/2,
      df(s_i(~x),~x) => sin(x)/x
    };

algebraic
let { int(exp(~tt)/~tt,~tt,-infinity,~z) =>  Ei (z),
      df(Ei(~x),~x) => exp(x)/x,
      Ei(~x) => compute_int_functions(x,Ei)
         when numberp x and abs(x) <= 20 and lisp !*rounded
    };

algebraic
let { int(1/ln(~tt),~tt,0,~z) =>  li (z),
      li (~z) => Ei(log z)
    };

algebraic
let { int(cos(~tt)/~tt,~tt,~z,infinity) => - Ci (z),
      int((cos(~tt) -1)/~tt,~tt,0,~z) => Ci (z) + psi(1) -log(z),
% psi(1) may be replaced by euler_gamma one day ...
      Ci(-~x) => - Ci(x) -i*pi,
      df(Ci(~x),~x) => cos(x)/x,
      Ci(~x) => compute_int_functions(x,Ci)
         when numberp x and abs(x) <= 20 and lisp !*rounded
    };

algebraic
let { int(sinh(~tt)/~tt,~tt,0,~z) => shi (z),
      df(Shi(~x),~x) => sinh(x)/x  ,
      shi(~x) => compute_int_functions(x,shi)
         when numberp x and abs(x) <= 20 and lisp !*rounded
    };

algebraic
let { int((cosh(~tt) -1)/~tt,~tt,0,~z) => Chi (z) + psi(1) -log(z),
% psi(1) may be replaced by euler_gamma one day ...
      df(Chi(~x),~x) => cosh(x)/x  ,
      Chi(~x) => compute_int_functions(x,Chi)
         when numberp x and abs(x) <= 20 and lisp !*rounded
    };

algebraic
let { int(sin(Pi/2*~tt^2),~tt,0,~z) => Fresnel_S (z),
      Fresnel_S(-~x) => (- Fresnel_S (x)),
      Fresnel_S(i* ~x) => (-i*Fresnel_S (x)),
      limit(Fresnel_S(~tt),~tt,infinity) => 1/2,
      df(Fresnel_S(~x),~x) => sin(Pi/2*x^2) ,
      Fresnel_S (~x) => compute_int_functions(x,Fresnel_S)
              when numberp x and abs(x) <= 10 and lisp !*rounded };

algebraic
let { int(cos(Pi/2*~tt^2),~tt,0,~z) => Fresnel_C (z),
      Fresnel_C(-~x) => (- Fresnel_C (x)),
      Fresnel_C(i* ~x) => (i*Fresnel_C (x)),
      limit(Fresnel_C(~tt),~tt,infinity) => 1/2,
      df(Fresnel_C(~x),~x) => cos(Pi/2*x^2) ,
      Fresnel_C (~x) => compute_int_functions(x,Fresnel_C)
               when numberp x and abs(x) <= 10 and lisp !*rounded };

algebraic
let { limit (erf(~x),~x,infinity) => 1,
      limit (erfc(~x),~x,infinity) => 0,
      erfc (~x) => 1-erf(x),
      erfi(~z)  => -i * erf(i*z),
      int(1/e^(~tt^2),~tt,0,~z) => erf(z)/2*sqrt(pi),
      int(1/e^(~tt^2),~tt,~z,infinity) => erfc(z)/2*sqrt(pi),
      erf (~x) => compute_int_functions(x,erf)
                when numberp x and abs(x)<5 and lisp !*rounded };

algebraic procedure compute_int_functions(x,f);
   begin scalar pre,!*uncached,scale,term,n,precis,result,interm;
   pre := precision 0; precision pre;
   precis := 10^(-2 * pre);
   lisp (!*uncached := t);
   if f = Si then
           if x < 0 then result :=
                        - compute_int_functions(-x,f) else
            << n:=1; term := x; result := x;
               while abs(term) > precis do
                 << term := -1 * (term * x*x)/(2n * (2n+1));
                    result := result + term/(2n+1);
                    n := n + 1>>; >>
    else if f = Ci then
           if x < 0 then result :=
                         - compute_int_functions(-x,f) -i*pi else
              << n:=1; term := 1; result := euler!*constant + log(x);
               while abs(term) > precis do
                 << term := -1 * (term * x*x)/((2n-1) * 2n);
                    result := result + term/(2n);
                    n := n + 1>>; >>
    else  if f = Ei then
          << n:=1; term := 1; result := euler!*constant + log(x);
               while abs(term) > precis do
                 << term := (term * x)/n;
                    result := result + term/n;
                    n := n + 1>>; >>
    else  if f = Shi then
            << n:=1; term := x; result := x;
               while abs(term) > precis do
                 << term := (term * x*x)/(2n * (2n+1));
                    result := result + term/(2n+1);
                    n := n + 1>>; >>
    else  if f = Chi then
            << n:=1; term := 1; result := euler!*constant + log(x);
               while abs(term) > precis do
                 << term := (term * x*x)/((2n-1) * 2n);
                    result := result + term/(2n);
                    n := n + 1>>; >>
    else if f = erf then
           if x < 0 then result := - compute_int_functions(-x,f) else
            << n:=1; term := x; result := x;
               if floor(x*7) > pre then precision  floor(x*7);
               interm := -1 *  x*x;
               while abs(term) > precis do
                 << term := (term * interm)/n;
                    result := result + term/(2n+1);
                    n := n + 1>>;
               precision pre;
               result := result*2/sqrt(pi) ;>>
    else  if f = Fresnel_S then
            << if x > 4.0 then precision max(pre,40);
               if x > 6.0 then precision max(pre,80);
               n:=1; term := x^3*pi/2; result := term/3;
                         interm := x^4*(pi/2)^2;
               while abs(term) > precis do
                 << term := -1 * (term * interm)/(2n * (2n+1));
                    result := result + term/(4n+3);
                    n := n + 1>>; >>
    else  if f = Fresnel_C then
            << if x > 4.0 then precision max(pre,40);
               if x > 6.0 then precision max(pre,80);
               n:=1; term := x; result := x; interm := x^4*(pi/2)^2;
               while abs(term) > precis do
                 << term := -1 * (term * interm)/(2n * (2n-1));
                    result := result + term/(4n+1);
                    n := n + 1>>;  >>;
    precision pre;
    return result
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/fps.tst0000644000175000017500000000423011526203062023305 0ustar  giovannigiovanni%       Examples for the algorithmic calculation of formal 
%       Puiseux, Laurent and power series,
%
%       Wolfram Koepf, Freie Universitaet Berlin, Germany
%       (taken from the original paper and adapted to REDUCE 
%        form by Winfried Neun, ZIB Berlin)

% Formal Laurent series

fps(E^x,x);

fps(E^x/(x^3),x);

fps(x * e^(x^4),x);

fps(sin (x + y),x);

simplede (sin x,x); %find a DE for sin

simplede (sin (x)^2,x,w); % DE in w and x   

fps(asin x,x);

fps((asin x)^2,x);

fps(e^(asin x),x);

fps(e^(asinh x),x);

fps((x + sqrt(1+x^2))^A,x);

fps(e^(x^2)*erf x,x);

fps(e^x - 2 e^(-x/2) * cos(sqrt(3) * x/2 -pi/3),x);

% fps(int(e^(-a^2*t^2) * cos(2*x*t),t,0,infinity),x)  % not yet

% fps(4/x * int(e^(t^2)*erf(t),t,0,sqrt(x)/2),x);

fps(sin x * e^x,x);

fps(cos x * e^(2*x),x);

fps(1/(x-x^3),x);

fps(1/(x^2 + 3 x + 2),x);

fps(x/(1-x-x^2),x);

% Logarithmic singularities and Puisieux series

fps(sin sqrt x,x);

fps(((1 + sqrt x)/x)^(1/3),x);

fps(asech x,x);

% some more (Wolfram Koepf, priv. comm.)

fps((1+x)^alpha,x);

fps((1+sqrt(1+x))^beta,x);

fps(sin(x)^2+cos(x)^2,x);

fps(sin(x)^2*cos(x)^2,x);

fps(sin(x)*cos(x^2),x);

fps((x-1)^(-1),x);

fps(atan(x+y),x);

fps((1-x^5)^6,x);

fps(asec x,x);

fps(besseli(0,x),x);
fps(besseli(1,x),x);

fps(exp(x^(1/3)),x);
fps(log(1-x),x);
fps(exp x*sinh x,x);
fps(atan x,x);
fps(sin x+sinh x,x);
fps(sin x*sinh x,x);
fps(int(erf(x),x),x);
fps(sqrt(2-x),x);
fps(sqrt(1+x)+sqrt(1-x),x);
fps(exp(a+b*x)*exp(c+d*x),x);
fps(1/cos(asin x),x);
fps(sqrt(1-x^2)+x*asin x,x);
fps(sqrt(1-sqrt(x)),x);
fps(cos(n*acos x),x);
fps(cos x+I*sin x,x);
fps(cos(3*asinh x),x);
fps(cos(n*asinh x),x);
fps(sin(n*log(x+sqrt(1+x^2))),x);
fps(sqrt(1+x^2)*asinh x-x,x);

fps(int(erf(x)/x,x),x);
fps(asin(x)^2/x^4,x);


% we had problems here:

fps(cos(asin x),x);
fps(sinh(log x),x);
fps(atan(cot x),x);
 
% we can cure this one by defining the limit:

let limit(atan(cot ~x),x,0) => pi/2;
fps(atan(cot x),x);

fps(exp(nnn*x)*cos(mmm*x),x);
fps(sqrt(2-x^2),x);
fps(ci x,x);
fps(log(1-2*x*y+x^2),x);

FPS(sin x,x,pi);

% This one takes ages :

%fps(acos(cos(x)),x);

fps_search_depth := 7; % does not find aa DE with the default
fps(sin(x^(1/3)),x);

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/meijerg.red0000644000175000017500000007154411526203062024113 0ustar  giovannigiovannimodule meijerg;  % Meijer's G-function.

% Author : Victor Adamchik, Byelorussian University Minsk, Byelorussia.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Major modifications by: Winfried Neun, ZIB Berlin.

symbolic smacro procedure fehler();
        rerror('specialf,140,"Wrong arguments to operator MeijerG");

symbolic procedure simpMeijerG(U);

begin scalar list1,list2,list1a,list2a;

if pairp u then list1 :=car u else fehler();
if pairp cdr u then list2 := cadr u else fehler();
if not pairp cddr u then  fehler();

if not eqcar(list1,'list) then fehler();
if not eqcar(list2,'list) then fehler();

list1a := for each x in cdadr list1 collect simp reval x;
list2a := for each x in cdadr list2 collect simp reval x;

list1 := list1a . for each x in cddr list1 collect simp reval x;
list2 := list2a . for each x in cddr list2 collect simp reval x;

list1 :=gfmsq(list1,list2,simp caddr u);

if list1 = 'fail then return simp 'fail else
        list1 := prepsq list1;

if eqcar(list1,'MeijerG) then return list1 else return
                simp list1;
                        end;

put('MeijerG,'simpfn,'simpMeijerG);

if not getd('simpmeijerg) then
        flag('(f6 f8 f9 f10 f11 f12 f13 f14 f26 f27 f28 f29 f30
        f31 f32 f33 f34 f35 f36 f37 f38 f39),'internalfunction);

switch tracespecfns;

symbolic procedure GFMsq(a,b,z);
 begin scalar v1,v2; integer m,n,p,q,aa,bb;
  v1:=redpar(car b,cdr a);
  v2:=redpar(cdr b,car a);
  aa:= (cadr v2 . cadr v1);
  bb:= (car v1 . car v2);
  a := append (car aa,cdr aa);
  b := append (car bb,cdr bb);
  m:=length(car v1); n:=length(cadr v2);
  q:=m + length(car v2); p:=n + length(cadr v1);   %WN
  if !*tracespecfns then
        << prin2 list( "MeijerG<",m,n,p,q,">",a,"|",b,"|",Z,"|aa=",aa,
                       "|bb=",bb);
        terpri()>>;
  if p=0 and q=0 then return
        << rerror('specialf,141,"DIVERGENT INTEGRAL");
          'FAIL
        >>;
  if greaterp(p,q) then return GFMinvers(aa,bb,z) else
  if greaterp(q,3) or greaterp(p,3) then return
     simpGtoH(aa,bb,z) else
  if q=3 and p=1 then go to q3 else
  if q=2 and (p=0 or p=1) then go to q2 else
  if q=1 then go to q1 else
          return simpGtoH(aa,bb,z);

q1:if p=0 and n=0 and m=1 then return
      multsq(expdeg(z,car b),expdeg(simp!* 'e,negsq z)) else

   if p=1 and n=0 and m=1 and null caar b and car a = '(1 . 1)
        then return gfmexit(aa,bb,z) else
        % change in order to make defint(cos(x) *sin(x)/x) correct. WN

   if p=1 and n=0 and m=1 then return % WN
       multsq (heavisidesq diff1sq('(1 . 1),z),
               quotsq(multsq(expdeg(z,car b),
           expdeg(diff1sq('(1 . 1),z),
                  diff1sq(car a,addsq('(1 . 1),car b)))),
            gamsq(diff1sq(car a,car b))))
      else
   if p=1 and n=1 and m=0 then return  %WN
           multsq(heavisidesq diff1sq(z,'(1 . 1)),
            quotsq(multsq(expdeg(z,car b),expdeg(diff1sq
            (z,'(1 . 1)),diff1sq(car a,addsq('(1 . 1),car b)))),
            gamsq(diff1sq(car a,car b))))
   else
   if p=1 and n=1 and m=1 then return
      multsq(gamsq(diff1sq('(1 . 1),diff1sq(car a,car b))),
             multsq(expdeg(z,car b),expdeg(addsq('(1 . 1),z),
                      diff1sq(car a,addsq('(1 . 1),car b)))))
            else return  rerror('specialf,142,
                        "***** parameter error in G-function");
q2:  if p=2 then  return  simpGtoH(aa,bb,z) else
     if p=1 then go to q2p1 else
     if p=0 and m=1 then return f6(car b,cadr b,z) else
     if p=0 and m=2 then return f8(car b,cadr b,z) else
               return  rerror('specialf,143,
                        "***** parameter error in G-function");

q2p1: if m=1 and n=0 then return q2p1m1n0(a,b,z) else
      if m=2 and n=0 then return q2p1m2n0(a,b,z) else
      if m=2 and n=1 then return q2p1m2n1(a,b,z) else
                      return simpGtoH(aa,bb,z);

q3:   if p=1 then go to q3p1 else
                      return simpGtoH(aa,bb,z);

q3p1: if m=1 and n=1 then return q3p1m1n1(a,b,z) else
      if m=2 and n=0 then return q3p1m2n0(a,b,z) else
      if m=2 and n=1 then return q3p1m2n1(a,b,z) else
      if m=3 and n=0 then return q3p1m3n0(a,b,z) else
      if m=3 and n=1 then return q3p1m3n1(a,b,z) else
                      return simpGtoH(aa,bb,z);
end;

symbolic procedure GFMinvers(a,b,z);
  GFMsq( (pdifflist(('1 . 1),car b) . pdifflist('(1 . 1),cdr b)),
         (pdifflist('(1 . 1),car a) . pdifflist('(1 . 1),cdr a)),
         invsq z);

symbolic procedure f6(a,b,z);
  multsq(expdeg(z,multsq('(1 . 2),addsq(a,b))),besssq(diff1sq(a,b),
  multsq('(2 . 1),simpx1(prepsq z,1,2))));

symbolic procedure f8(a,b,z);
  multsq('(2 . 1),multsq(expdeg(z,multsq('(1 . 2),addsq(a,b))),
         macdsq(diff1sq (a,b),multsq('(2 . 1),simpx1(prepsq z,1,2)))));

%***********************************************************************
%*     Representation G-function through hypergeometric functions      *
%***********************************************************************

symbolic procedure simpGtoH(a,b,z);
   %a=((a1,,,an).(an+1,,,ap)).
   %b=((b1,,,bm).(bm+1,,,bq)).
   %z -- argument.
   %value is the generalized hypergeometric function.
   if length(car b) + length(cdr b) >= length(car a) + length(cdr a)
     then fromGtoH(a,b,z)
   else
      fromGtoH(
        cons(pdifflist('(1 . 1),car b),pdifflist('(1 . 1),cdr b)),
        cons(pdifflist('(1 . 1),car a),pdifflist('(1 . 1),cdr a)),
        invsq z);

%symbolic procedure fromGtoH(a,b,z);
   %a=((a1,,,an).(an+1,,,ap)).
   %b=((b1,,,bm).(bm+1,,,bq)).
   %z -- argument.
   %value is the generalized hypergeometric function.
%   if null car b then gfmexit(a,b,z)
%     else
%   if not null a and listfooltwo(difflist(car b,'(-1 . 1)),car a)
%      then 'FAIL
%     else
% dont understand this W.N.
% but reopened nevertheless
%  if length(car b) > length(car a) then
%     fromGtoH(
%     (pdifflist('(1 . 1),car b ) . pdifflist('(1 . 1),cdr b )),
%     (pdifflist('(1 . 1),car a ) . pdifflist('(1 . 1),cdr a )),
%     invsq(z))
%    else
%  if listfool(car b) then GFMlogcase(a,b,z)
%                    else allsimplpoles(car b,a,b,z);

symbolic procedure fromGtoH(a,b,z);
  %a=((a1,,,an).(an+1,,,ap)).
  %b=((b1,,,bm).(bm+1,,,bq)).
  %z -- argument.
  %value is the generalized hypergeometric function.
  if null car b then gfmexit(a,b,z)
    else
  if not null a and listfooltwo(difflist(car b,'(-1 . 1)),car a)
     then 'FAIL
    else
 if listfool(car b) then GFMlogcase(a,b,z)

 else
  if length car a + length cdr a <= length car b + length cdr b then
      allsimplpoles(car b,a,b,z) else allsimplpoles(car a,a,b,z);

symbolic procedure GFMexit(a,b,z);
 begin scalar mnpq,aa,bb;
  if (length car a + length cdr a) > (length car b + length cdr b)
                then return GFMexitinvers(a,b,z);
   mnpq := 'lst . list(length car b,length car a,
                       length car a + length cdr a,
                       length car b + length cdr b);
  aa:= 'lst . append (listprepsq car a, listprepsq cdr a);
  bb:= 'lst . append (listprepsq car b, listprepsq cdr b);
  return mksqnew('gfm .
        list(mnpq,aa,bb,prepsq z));
  end;

symbolic procedure GFMexitinvers(a,b,z);
  GFMexit((pdifflist('(1 . 1),car b) . pdifflist('(1 . 1),cdr b)),
          (pdifflist('(1 . 1),car a) . pdifflist('(1 . 1),cdr a)),
           invsq z) ;

symbolic procedure allsimplpoles(v,a,b,z);
  if null v then '(nil . 1) else
     addsq(infinitysimplpoles(a,(car redpar(car b,list(car v)) . cdr b)
                        ,car v,z),
            allsimplpoles(cdr v,a,b,z));

symbolic procedure infinitysimplpoles(a,b,v,z);
 begin scalar coefgam;
   coefgam:=
     quotsq(
       multsq(
         multgamma(difflist(car b,v)),
         if null a or null car a then '(1 . 1) else
           multgamma(pdifflist(addsq('(1 . 1),v), car a))),
       multsq(
         if null cdr b then '(1 . 1) else
           multgamma(pdifflist(addsq('(1 . 1),v),cdr b)),
         if null a or null cdr a then '(1 . 1) else
           multgamma(difflist(cdr a,v))));
  return multsq(multsq(coefgam,expdeg(z,v)),
            GHFsq(list(length(car a) + length(cdr a),
                       length(car b) + length(cdr b)),
             if null a then nil else
             if null car a then pdifflist(addsq('(1 . 1),v),cdr a)
               else
             append(pdifflist(addsq('(1 . 1),v),car a),
                    pdifflist(addsq('(1 . 1),v),cdr a)),
             if null cdr b then
                    pdifflist(addsq('(1 . 1),v),car b)
               else
             append(pdifflist(addsq('(1 . 1),v),car b),
                    pdifflist(addsq('(1 . 1),v),cdr b)),
             multsq(z,
             exptsq('(-1 . 1),1+length(cdr a)-length(car b)))));
end;

%***********************************************************************
%*            PARTICULAR CASES FOR G-FUNCTION, Q=2                     *
%***********************************************************************

symbolic procedure q2p1m1n0(a,b,z);
  begin scalar v;
  v:=addend(a,b,'(1 . 2));
  if null car addsq(cadr v,caddr v) then
                 return f7(car v,cadr v,z) else
                 return simpGtoH((nil . a),redpar1(b,1),z);
  end;

symbolic procedure f7(a,b,z);
  multsq(quotsq(simpfunc('cos,multsq(b,simp!* 'pi)),simpx1('pi,1,2)),
  multsq(expdeg(z,a),multsq(expdeg(simp!* 'e,multsq(z,'(1 . 2))),
  bessmsq(b,multsq(z,'(1 . 2))))));

  symbolic procedure q2p1m2n0(a,b,z);
  begin scalar v;
  v:=addend(a,b,'(1 . 2));
    if null car addsq(cadr v,caddr v) then
                return f9(car v,cadr v,z) else
                return f11(car a,car b,cadr b,z);
 end;

symbolic procedure f9(a,b,z);
   multsq(quotsq(expdeg(z,a),simpx1('pi,1,2)),
     multsq(expdeg(simp!* 'e,multsq(
       '(1 . 2),negsq z)),macdsq(b,multsq(z,'(1 . 2)))));

 symbolic procedure f11(a,b,c,z);
 multsq(expdeg(z,b),multsq(expdeg(simp!* 'e,negsq z),
        tricomisq(diff1sq(a,c),addsq('(1 . 1),diff1sq(b,c)),z)));

symbolic procedure q2p1m2n1(a,b,z);
 begin scalar v;
 v:=addend(a,b,'(1 . 2));
 if null car addsq(cadr v,caddr v) and
    ((equal(cdadr v,2) and not numberp(cadar v)) or
    not equal(cdadr v,2)) then
               return f10(car v,cadr v,z) else
               return simpGtoH((a . nil),(b . nil),z);
 end;

symbolic procedure f10(a,b,z);
  multsq(quotsq(simpx1('pi,1,2),simpfunc('cos,multsq(simp!* 'pi,b))),
  multsq(expdeg(z,a),multsq(expdeg(simp!* 'e,multsq('(1 . 2),z)),
  macdsq(b,multsq('(1 . 2),z)))));

%***********************************************************************
%*                PARTICULAR CASES FOR G-FUNCTION, Q=3                 *
%***********************************************************************

symbolic procedure q3p1m2n1(a,b,z);
  begin scalar v,v1;
    if equal(diff1sq(car a,caddr b),'(1 . 2)) then
    if equal(car a,car b) and
       ((equal(cdr diff1sq(cadr b,caddr b),2) and
       not numberp(car diff1sq(cadr b,caddr b))) or
       not equal(cdr diff1sq(cadr b,caddr b),2))
                         then return f34(caddr b,cadr b,z) else
    if equal(car a,cadr b) and
       ((equal(cdr diff1sq(car b,caddr b),2) and
       not numberp(car diff1sq(car b,caddr b))) or
       not equal(cdr diff1sq(car b,caddr b),2))
                         then return f34(caddr b,car b,z) else goto m;
    if equal(diff1sq(car a,car b),'(1 . 2)) and equal(car a,cadr b) then
                              return f35(car b,caddr b,z) else
    if equal(diff1sq(car a,cadr b),'(1 . 2)) and equal(car a,car b) then
                              return f35(cadr b,caddr b,z) else
             return simpGtoH((a . nil),redpar1(b,2),z);
 m: v:=addend(a,b,'(1 . 2));   v1:=cdr v;
    if null caar v1 and null car addsq(cadr v1,caddr v1) then
                              return f32( car v,cadr v1,z) else
    if null caadr v1 and null car addsq(car v1,caddr v1) then
                              return f32(car v,car v1,z) else
    if null caaddr v1 and null car addsq(car v1,cadr v1) and
       ((not equal(cdar v1,1) and not equal(cdar v1,2)) or
         not numberp(caar v1))
                           then  return f33(car v,car v1,z);
             return simpGtoH((a . nil),redpar1(b,2),z);
  end;

symbolic procedure f34(a,b,z);
  multsq(quotsq(simp!* 'pi,
                simpfunc('cos,multsq(simp!* 'pi,diff1sq(b,a)))),
  multsq(expdeg(z,multsq('(1 . 2),addsq(a,b))),
    diff1sq(bessmsq(diff1sq(b,a),
       multsq('(2 . 1),simpx1(prepsq z,1,2))),struvelsq(diff1sq(a,b),
              multsq('(2 . 1),simpx1(prepsq z,1,2))))));

symbolic procedure f35(a,b,z);
  multsq(simp!* 'pi,
  multsq(expdeg(z,multsq('(1 . 2),addsq(a,b))),
         diff1sq(bessmsq(diff1sq(a,b),
  multsq('(2 . 1),simpx1(prepsq z,1,2))),struvelsq(diff1sq(a,b),
         multsq('(2 . 1),simpx1(prepsq z,1,2))))));

symbolic procedure f33(c,a,z);
  multsq(quotsq(simpx1('pi,3,2),simpfunc('sin,multsq('(2 . 1),multsq(a,
  simp!* 'pi)))),multsq(expdeg(z,c),
      diff1sq(multsq(bessmsq(negsq a,simpx1
  (prepsq z,1,2)),bessmsq(negsq a,simpx1(prepsq z,1,2))),
  multsq(bessmsq(a,simpx1(prepsq z,1,2)),
         bessmsq(a,simpx1(prepsq z,1,2))))));

symbolic procedure f32(c,a,z);
  multsq(multsq('(2 . 1),simpx1('pi,1,2)),multsq(expdeg(z,c),multsq(
  bessmsq(a,simpx1(prepsq z,1,2)),macdsq(a,simpx1(prepsq z,1,2)))));

symbolic procedure q3p1m2n0(a,b,z);
  begin scalar v,v1;
   if equal(car a,caddr b) then
   if equal(diff1sq(car b,car a),'(1 . 2))
     then return f29(car b,cadr b,z)
    else if equal(diff1sq(cadr b,car a),'(1 . 2)) then
                                        return f29(cadr b,car b,z);
   v:=addend(a,b,'(1 . 2));  v1:=cdr v;
   if null caar v1 and null car addsq(cadr v1,caddr v1) then
                                        return f31(car v,cadr v1,z) else
   if null caadr v1 and null car addsq(car v1,caddr v1) then
                                        return f31(car v,car v1,z) else
   if null caaddr v1 and null car addsq(cadr v1,car v1) and
       ((equal(cdar v1,1) and not numberp(caar v1)) or
       not equal(cdar v1,1))
                  then return f30(car v,car v1,z);
             return simpGtoH((nil . a),redpar1(b,2),z);
  end;

symbolic procedure f29(a,b,z);
  multsq(expdeg(z,multsq('(1 . 2),addsq(a,b))),neumsq(diff1sq(b,a),
         multsq('(2 . 1),simpx1(prepsq z,1,2))));

symbolic procedure f30(c,a,z);
  multsq(quotsq(simpx1('pi,1,2),multsq('(2 . 1),simpfunc('sin,multsq(a,
  simp!* 'pi)))),multsq(expdeg(z,c),diff1sq(multsq(besssq(negsq a,simpx1
  (prepsq z,1,2)),besssq(negsq a,simpx1(prepsq z,1,2))),multsq(besssq(a,
  simpx1(prepsq z,1,2)),besssq(a,simpx1(prepsq z,1,2))))));

symbolic procedure f31(c,a,z);
  multsq(negsq(simpx1('pi,1,2)),multsq(expdeg(z,c),multsq(
  besssq(a,simpx1(prepsq z,1,2)),neumsq(a,simpx1(prepsq z,1,2)))));

symbolic procedure q3p1m1n1(a,b,z);
  begin scalar v,v1;
  if equal(car a,car b) then
  if equal(diff1sq(car a,caddr b),'(1 . 2))
    then return f28(car a,cadr b,z)
   else if equal(diff1sq(car a,cadr b),'(1 . 2))
    then return f28(car a,caddr b,z);
  v:=addend(a,b,'(1 . 2));  v1:=cdr v;
    if null caar v1 and null car addsq(cadr v1,caddr v1) then
                             return f26(car v,cadr v1,z) else
    if (null caadr v1 or null caaddr v1)
      and (null car addsq(car v1,cadr v1)
    or null car addsq(car v1,caddr v1)) then return f27(car v,car v1,z);
                  return simpGtoH((a . nil),redpar1(b,1),z);
  end;

symbolic procedure f26(c,a,z);
  multsq(simpx1('pi,1,2),multsq(expdeg(z,c),
         multsq(besssq(a,simpx1(prepsq z,1,2)),
                besssq(negsq a,simpx1(prepsq z,1,2)))));

  symbolic procedure f27(c,a,z);
  multsq(simpx1('pi,1,2),multsq(expdeg(z,c),multsq(
  besssq(a,simpx1(prepsq z,1,2)),besssq(a,simpx1(prepsq z,1,2)))));

symbolic procedure f28(a,b,z);
 multsq(expdeg(z,multsq('(1 . 2),diff1sq(addsq(a,b),'(1 . 2)))),
 struvehsq(diff1sq(a,addsq(b,'(1 . 2))),multsq('(2 . 1),
                        simpx1(prepsq z,1,2))));

symbolic procedure q3p1m3n0(a,b,z);
  begin scalar v,v1;
  v:=addend(a,b,'(1 . 2));  v1:=cdr v;
    if (null car(addsq(car v1,cadr v1)) and null caaddr v1) or
       (null car(addsq(car v1,caddr v1)) and null caadr v1) then
                       return f36(car v,car v1,z) else
    if null car(addsq(cadr v1,caddr v1)) and null caar v1 then
                       return f36(car v,cadr v1,z);
                   return simpGtoH((nil . a),(b . nil),z);
  end;

symbolic procedure f36(a,b,z);
  multsq(quotsq('(2 . 1),simpx1('pi,1,2)),multsq(expdeg(z,a),multsq(
  macdsq(b,simpx1(prepsq z,1,2)),macdsq(b,simpx1(prepsq z,1,2)))));

symbolic procedure q3p1m3n1(a,b,z);
    if equal(car a,car b) and null car(addsq(cadr b,caddr b)) then
                            f38(car a,cadr b,z) else
    if (equal(car a,cadr b) and null car(addsq(car b,caddr b))) or
       (equal(car a,caddr b) and null car(addsq(car b,cadr b))) then
                            f38(car a,car b,z) else
    if equal(diff1sq(car a,caddr b),'(1 . 2)) and
       null numr(addsq(addsq(car b,cadr b),
                      multf(-2,caaddr b) ./ cdaddr b))
                       then f39(caddr b,car b,z) else
    if equal(diff1sq(car a,cadr b),'(1 . 2)) and
     null numr(addsq(addsq(car b,caddr b),multf(-2,caadr b) ./ cdadr b))
                       then f39(cadr b,car b,z) else
    if equal(diff1sq(car a,car b),'(1 . 2)) and
      null numr(addsq(addsq(cadr b,caddr b),multf(-2,caar b) ./ cdar b))
                       then f39(car b,cadr b,z) else
                       simpGtoH((a . nil),(b . nil),z);

symbolic procedure f38(a,b,z);
 if parfool(diff1sq('(1 . 1),addsq(a,b))) or
    parfool(addsq('(1 . 1),diff1sq(b,a))) then
   simpGtoH((list(a) . nil),(list(a,b,negsq b) . nil),z) else
 multsq(expdeg('(4 . 1),diff1sq('(1 . 1),a)),
        multsq(multgamma(list(diff1sq( '(1 . 1),addsq(a,b)),
                addsq(b,diff1sq('(1 . 1),a)))),
                lommel2sq(diff1sq(multsq('( 2 . 1),a),'(1 . 1))
                ,multsq('(2 . 1),b),multsq('(2 . 1),
                        simpx1(prepsq z,1,2)))));

symbolic procedure f39(a,b,z);
  if not numberp(car diff1sq(a,b)) or
     not equal(cdr diff1sq(a,b),2) then
  multsq(quotsq(multsq(simpx1('pi,5,2),expdeg(z,a)),multsq('(2 . 1),
  simpfunc('cos,multsq(simp!* 'pi,diff1sq(b,a))))),multsq(hankel1sq(
  diff1sq(b,a),simpx1(prepsq z,1,2)),hankel2sq(diff1sq(b,a),
  simpx1(prepsq z,1,2)))) else
       simpGtoH((list(addsq(a,'(1 . 2))) . nil),
       (list(b,a,diff1sq(multsq('(2 . 1),a),b)) . nil),z);

%***********************************************************************
%*           Logarithmic case of Meijer's G-function                   *
%***********************************************************************

fluid '(!*infinitymultpole);

symbolic smacro procedure priznak(u,v);
 for each uu in u collect ( uu . v) ;

symbolic procedure GFMlogcase(a,b,z);
 begin scalar w;
  w:=allpoles(logcase(append(priznak(cdr a,'N),priznak(car b,'P))));
  w:=sortpoles(w);
  if null !*infinitymultpole then
              return GFMlogcasemult(w,a,b,z)
     else << !*infinitymultpole := nil;
        % to prevent lots of integrals from failing.
             return 'FAIL>>;
 end;

array res(5);

symbolic procedure allpoles uu;
  for each u in uu join
   begin scalar w;integer kr;
   while u do <<
    if equal(cdar u,'N) then kr:=kr-1
                        else kr:=kr+1;
    if kr > 0 then
     if not null cdr u then
      if not equal(caadr u,caar u) then
           w:=cons(list(
              kr,prepsq diff1sq(caadr u,caar u),negsq caar u),w)
        else w:=w
       else
          <<    w:=cons(list(kr,'infinity,negsq caar u),w);
                if not eqn(kr,1) then !*infinitymultpole:=T
          >>;
    u:=cdr u;
   >>;
  return w;
 end;

symbolic procedure logcase u;
   begin scalar blog,blognew,sb;
   sb:=u; u:=cdr sb;
 M1: if null sb then return blognew;

 M2: if null u then
           << if not null blog then
                        << blognew:=cons(blog,blognew);
                           blog:=nil
                        >>
                               else
                           blognew:=cons(list car sb,blognew);
              sb:=cdr sb;  if sb then u:=cdr sb;
              GOTO M1
           >>
          else
           if equal(caar sb,caar u) or
              and(numberp car diff1sq(caar sb,caar u),
                  equal(cdr diff1sq(caar sb,caar u),1))
             then
              << if null blog then
                    if equal(caar sb,caar u) or
                       car diff1sq(caar sb,caar u) < 0  then
                         blog:=list(car sb,car u)
                       else blog:=list(car u,car sb)
                            else
                    blog:=ordern(car u,blog);
                 sb:=delete(car u, sb);
                 if u then u:=cdr u;
                 GOTO M2
              >>
              else
              << if u then u:=cdr u;
                 GOTO M2;
              >>
end;

symbolic procedure ordern(u,v);
  %u - dotted pair (SQ . ATOM).
  %v - list of dotted pair.
  if null v then list(u)
    else
  if equal(car u,caar v) or car diff1sq(car u,caar v) > 0 then
              (car v) . ordern(u,cdr v)
    else
              u . v ;

symbolic procedure sortpoles(w);
 begin scalar w1,w2;
  while w do begin
   if equal(cadar w,'infinity) then w1:=(car w) . w1
     else w2:=(car w) . w2;
   w:=cdr w;
  end;
  return append(w2,w1);
 end;

symbolic procedure GFMlogcasemult(w,a,b,z);
  % w -- list of lists.
  if null w then (nil . 1) else
     addsq(groupresudes(car w,a,b,z),
           GFMlogcasemult(cdr w,a,b,z));

symbolic procedure groupresudes(w,a,b,z);
  % w -- (order number start).
   if not equal(cadr w,'infinity) then multpoles(w,a,b,z)
   else
   if equal(cadr w,'infinity) and car w = 1 then
      simplepoles(caddr w,a,b,z)
   else
      'FAIL;

symbolic procedure simplepoles(at,a,b,z);
 if member(at, car b) then
    infinitysimplpoles(a,(car redpar(car b,list(at)) . cdr b),
                          negsq at,z)
 else specialtransf(at,a,b,z);

symbolic procedure specialtransf(at,a,b,z);  %some changes by WN
 if listfooltwo(car b, cdr a) then
    begin scalar c, cc;
      c:=redpar(car b,cdr a);
      cc:=redpar(cdr b,car a);
      a:=(cadr cc . cadr c);
      b:=(car c . car cc);
      if listfooltwo(car b, cdr a) then
        <<
          c:=findtwoparams(car b, cdr a);
          a:=((car c) . car a ) .  car redpar(cdr a,list(car c));
          b:=(car redpar(car b,list(cadr c)) . (cadr c) . cdr b);
          return
%         multsq( expdeg('(-1 . 1), diff1sq(simp car c, simp cadr c)),
          multsq( expdeg('(-1 . 1), diff1sq(car c,  cadr c)),
                  specialtransf(at,a,b,z) )
        >>
      else
        return infinitysimplpoles( a,b,negsq at,z );
     end
 else
    begin scalar c;
      c:=redpar(cdr b,car a);
      a:=(cadr c . cdr a);
      b:=(car b . car c);
      return infinitysimplpoles( a,b,negsq at,z );
    end;

symbolic procedure findtwoparams(u, v);
 % u, v -- lists.
 begin scalar c;
   foreach uu in u do
      foreach vv in v do
        if parfool diff1sq(uu,vv)
          then << c := list(vv,uu); u := nil; v := nil>> ;
   return c;
end;

symbolic procedure multpoles (u,a,b,z);
  % u -- (order number start).
  if cadr u = 0 then (nil . 1) else
     addsq(multresude(list(car u, caddr u),a,b,z),
           multpoles(list(car u,cadr u-1,
                     diff1sq(caddr u,'(1 . 1))),a,b,z));

symbolic procedure multresude (u,a,b,z);
  % u -- (order start).
  % a,b -- parameters of G-function.
  % z - argument of G-function.
  <<
   for i:=0 step 1 until 5 do res(i):='(nil . 1);
   findresude(multlistasym(list(
          listtaylornom(listplus(car b,cadr u),simp 'eps,car u),
          listtaylornom(pdifflist(addsq('(1 . 1),negsq cadr u),car a),
                                 negsq simp 'eps,car u),
          listtaylorden(listplus(cdr a,cadr u),simp 'eps,car u),
          listtaylorden(pdifflist(addsq('(1 . 1),negsq cadr u),cdr b),
                                 negsq simp 'eps,car u),
          if equal(z,'(1 . 1)) then '(1 . 1) else
              multsq(expdeg(z,negsq cadr u),
                     seriesfordegree(car u,simp 'eps,z))),car u))
 >>;

symbolic procedure findresude u;
  begin scalar s,cc;
   cc:=prepsq(cdr u ./ 1);
   cc:= cdr algebraic coeff(cc,eps);
   while car cc = 0 do cc:=cdr cc;
   s:=if numberp car cc then simp car cc else cadr car cc;
   cc:=prepsq(car u ./ 1);
   cc:= cdr algebraic coeff(cc,eps);
   return
   multsq(invsq s,if numberp car cc then simp car cc
                                     else cadr car cc);
 end;

symbolic procedure seriesfordegree(n,v,z);
 if n=1 then '(1 . 1) else
    addsq(quotsq(multsq(exptsq(negsq v,n-1),
            exptsq(simpfunc('log,z),n-1)),gamsq((n . 1))),
          seriesfordegree(n-1,v,z));

symbolic procedure listtaylornom(u,v,n);
  % u -- list of SQ.
  % v -- EPS -> 0.
  % n -- order of the representation by the polynom.
  if null u then '(1 . 1) else
     multasym(taylornom(car u,v,n),listtaylornom(cdr u,v,n),n);

symbolic procedure multlistasym(u,n);
  if null u then '(1 . 1)
    else
     multasym(car u,multlistasym(cdr u,n),n);

symbolic procedure multasym(u,v,n);
  begin integer k;
  if null car u or null car v then return '(nil . 1);
  u:=multsq(u,v);
  if not oldpolstack(car u ./ 1) then return u;
  v:=res(0);
   while (k:=k+1) < n do
     v:=addsq(v,multsq(res(k),exptsq(simp 'eps,k)));
   return multsq(v,1 ./ cdr u);
  end;

symbolic procedure oldpolstack u;
  begin scalar cc; integer k;
   cc := prepsq u;
   cc:=cdr algebraic coeff(cc,eps);
   if null cc then return nil else k:=0;
   while not null cc do
      <<
      res(k):=if numberp car cc then simp(car cc)
                                else cadr car cc;
      cc:=cdr cc;k:=k+1;
      >>;
   return t;
  end;

symbolic procedure listtaylorden(u,v,n);
  % u -- list of SQ.
  % v -- EPS -> 0.
  % n -- order of the representation by the polynom.
  if null u then '(1 . 1) else
     multasym(taylorden(car u,v,n),listtaylorden(cdr u,v,n),n);

symbolic procedure taylornom(u,v,n);
  % u -- SQ.
  % v -- SQ is EPS -> 0.
  % n -- order of the representation by the polynom.
  if null car u then multsq(invsq v,taylorgamma('(1 . 1),v,n))
    else
  if parfool u then multlistasym(list(
     exptsq('(-1 . 1),if null car negsq u then 0 else car negsq u),
     invsq v,
     taylornom('(1 . 1),v,n),taylornom('(1 . 1),negsq v,n),
     taylorden(diff1sq('(1 . 1),u),negsq v,n)),n)
    else
     multsq(gamsq(u),taylorgamma(u,v,n));

symbolic procedure taylorden(u,v,n);
  % u -- SQ.
  % v -- SQ is EPS -> 0.
  % n -- order of the representation by the polynom.
  if parfool u then multlistasym(list(
     exptsq('(-1 . 1),if null car negsq u then 0 else car negsq u),
     v,
     taylornom(diff1sq('(1 . 1),u),negsq v,n),
     taylorden('(1 . 1),v,n),
     taylorden('(1 . 1),negsq v,n)),n)
               else
     quotsq(inversepol(taylorgamma(u,v,n),n),gamsq(u));

symbolic procedure inversepol(u,n);
  begin scalar sstack,c,w;integer k,m;
   if n=1 then return '(1 . 1);
   if null oldpolstack(car u ./ 1) then return u;
   sstack:=list('(1 . 1));  k:=2;
   while k <= n do begin
    w:=sstack;   m:=2; c:=nil . 1;
     while m <= k do begin
       c:=addsq(c,multsq(res(m-1),car w));
       m:=m+1; w:=cdr w;
     end;
    sstack:=(negsq c) . sstack;
    k:=k+1;
   end;
   w:=nil . 1;
   while sstack do begin
     w:=addsq(w,multsq(car sstack,exptsq(simp 'eps,n-1)));
     sstack:=cdr sstack;
     n:=n-1;
   end;
    return multsq(cdr u ./ 1,quotsq(w,res(0)));
  end;

symbolic procedure taylorgamma(u,v,n);
  % representation of gamma-function by the polynom of the
  % order  n  in  u  on the degree  v.
  if n=1 then '(1 . 1) else
     addsq(quotsq(multsq(exptsq(v,n-1),GammaToPsi(u,n-1)),
              gamsq(n ./ 1)),
           taylorgamma(u,v,n-1));

symbolic procedure GammaToPsi(u,n);
  if n=1 then psisq(u) else
     addsq(multsq(psisq(u),GammaToPsi(u,n-1)),
           diffsq(GammaToPsi(u,n-1),prepsq u));

algebraic <<
  operator lst,gfm;
  let gfm(lst(1,0,1,1),lst(1),lst(0),~z)=> (sign(1 + z) + sign(1 - z))/2
>>;

algebraic
   let meijerg({{},1},{{0,0},-1/2},~x) =>
        G_Fresnel_S(2*sqrt(x),-1)/(2^(-2)*sqrt(pi));


endmodule;

end;





mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfpolys.red0000644000175000017500000004354511526203062024170 0ustar  giovannigiovannimodule sfpolys;   % Assorted Polynomials
                  % will be a package of its own one day
%
% Author: Winfried Neun, Feb 1993
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% Revision 6. April 1995, using explicit formulae for the orthogonal
%                       polynomials (Abramowitz/Stegun 22.3)
% Revision  December 1995 by Wolfram Koepf
%           June 1996 by Wolfram Koepf : improved numeric codes
%           added Fibonacci numbers and Polys, W.N,  September 1998

fluid '(powlis1!*);

% Bernoulli Polynomials (see e.g. Abramowitz Stegun , chapter 23

algebraic operator bernoullip;

algebraic <<
Let {   BernoulliP (~n,0) => Bernoulli n     when fixp n and n >=0,
        BernoulliP (~n,~x) => (for k:=0:n sum (binomial(n,k) *
                         Bernoulli(k) * x^(n-k)))
                                          when fixp n and n >=0} >>;

% Euler Polynomials (see e.g. Abramowitz Stegun , chapter 23

algebraic operator EulerP ;

algebraic <<
Let {   EulerP (~n,1/2) => Euler(n)/2^n when fixp n and n >=0,
        EulerP (~n,~x) => (for k:=0:n sum (binomial(n,k) *
                         Euler(k)/2^k * (x -1/2)^(n-k)))
                                    when fixp n and n >=0}
>>;

 % Univariate orthogonal bases (for approximation etc).

% Author: H. Melenk, ZIB, Berlin

% Copyright (c): ZIB Berlin 1993, all rights resrved


algebraic procedure monomial_base(x,n);
     for i:=0:n collect x**i;

algebraic procedure trigonometric_base(x,n);
     1 . for i:=1:n join list(sin(i*x),cos(i*x));

algebraic procedure bernstein_base(x,n);
     for i:=0:n collect
         binomial(n,i)*(1-x)**(n-i)*x**i;

algebraic procedure legendre_base(x,n,a,b);
     legendre_base1(x,n,{a/2-b/2 + (1+a/2+b/2)*x,1},1,a,b);

algebraic procedure legendre_base1(x,n,base,r,a,b);
     if r>=n then reverse base else
     legendre_base1(x,n,
       (((2*r+a+b+1)*(a**2-b**2)+(2*r+a+b)*(2*r+1+a+b)*(2*r+2+a+b)*x)/
                (2*(r+1)*(r+1+a+b)*(2*r+a+b))*first base -
                2*(r+a)*(r+b)*(2r+2+a+b)/(2*(r+1)*(r+1+a+b)*
                        (2*r+a+b))*second base)
              . base, r+1,a,b);

algebraic procedure laguerre_base(x,n,a);
     laguerre_base1(x,n,{1-x+a,1},1,a);

algebraic procedure laguerre_base1(x,n,base,r,a);
     if r>=n then reverse base else
     laguerre_base1(x,n,
        ((1+2r-x+a)/(r+1)*first base - (r+a)/(r+1)*second base )
              . base, r+1,a);

algebraic procedure hermite_base(x,n);
     hermite_base1(x,n,{2*x,1},1);

algebraic procedure hermite_base1(x,n,base,r);
     if r>=n then reverse base else
     hermite_base1(x,n,
        (2x*first base - 2r*second base)
              . base, r+1);

algebraic procedure chebyshev_base_T(x,n);
     chebyshev_base_T1(x,n,{x,1},1);

algebraic procedure chebyshev_base_T1(x,n,base,r);
     if r>=n then reverse base else
     chebyshev_base_T1(x,n,
        (2x*first base - second base )
              . base, r+1);

algebraic procedure chebyshev_base_U(x,n);
     chebyshev_base_T1(x,n,{2x,1},1);

algebraic procedure gegenbauer_base1(x,n,base,r,a);
     if r>=n then reverse base else
     gegenbauer_base1(x,n,
        (2*(r+a)/(r+1)*x*first base - (r+2*a-1)/(r + 1)*second base )
              . base, r+1,a);

algebraic procedure gegenbauer_base(x,n,a);
     gegenbauer_base1(x,n,{2*a*x,1},1,a);


algebraic <<

operator HERMITEP,JACOBIP,LEGENDREP,LEGENDREQ, !~f,
         LAGUERREP,CHEBYSHEVT,CHEBYSHEVU,gegenbauerP;

let limit(~f(~n,~x),~x,~lim) => f(n,lim) when freeof (lim,infinity)
       and member (f,{LEGENDREP,CHEBYSHEVT,CHEBYSHEVU,Hermitep,
              laguerreP,BernoulliP,EulerP,LaguerreP});

let limit(~f(~n,~m,~x),~x,~lim) => f(n,m,lim) when freeof (lim,infinity)
         and member (f,{LEGENDREP,LegendreQ,gegenbauerP,laguerreP});

let limit(~f(~n,~m,~mm,~x),~x,~lim) => f(n,m,mm,lim)
      when freeof (lim,infinity) and member (f,{JacobiP});

let { % AS (22.4)
LegendreP(~n,0,0) => cos(n*Pi/2)*factorial(n)/(2^n*(factorial(n/2))^2),
% AS (8.6.1)
LegendreP(~n,~m,0) =>
        2^m/sqrt(Pi)*cos((n+m)*Pi/2)*GAMMA((n+m+1)/2)/GAMMA((n-m+2)/2),
% AS (8.6.2)
LegendreQ(~n,~m,0) =>
        2^(m-1)/sqrt(Pi)*sin((n+m)*Pi/2)*GAMMA((n+m+1)/2)
          /GAMMA((n-m+2)/2),
% AS (8.6.1)
LegendreP(~n,0) =>
        1/sqrt(Pi)*cos((n)*Pi/2)*GAMMA((n+1)/2)/GAMMA((n+2)/2),
LegendreP(~n,1) => 1,
LegendreP(~n,-1) => (-1)^n,

% AS (22.4)
GegenbauerP(~n,0,0) => 2*cos(n*Pi/2)/n,
GegenbauerP(~n,~a,0)=> cos(n*Pi/2)*GAMMA(a+n/2)
                                /(GAMMA(a)*factorial(n/2)),
ChebyshevT(~n,0) => cos(n*Pi/2),
ChebyshevU(~n,0) => cos(n*Pi/2),
ChebyshevT(~n,1) => 1,
ChebyshevU(~n,1) => n + 1 ,
ChebyshevT(~n,-1) => (-1)^n,
ChebyshevU(~n,-1) => (n+1)* (-1)^n,

LaguerreP(~n,~a,0) => binomial(n+a,n),
LaguerreP(~n,0) => 1,
LaguerreP(0,~x) => 1,
HermiteP(~n,0) => cos(n*Pi/2)*factorial(n)/factorial(n/2) }$

let  {  hermitep (~n,~x)=> (begin scalar b1,b2,bex,r;
                                r := 1; b1 := 2x; b2 := 1;
                                for i:= 1:(n-1) do <<
                                bex := 2x*b1 - 2*r*b2;
                                r := r+1; b2 := b1; b1 := bex;
                                >>;
                                return b1; end)
                when fixp n and n > 0 and numberp x ,
    % hermitep (~n,~x)=> sub(!=z = x,first reverse hermite_base (!=z,n))
    %       (factorial n * for ii:=0:floor(n/2) sum ((-1)^ii/(factorial ii *
    %     factorial(n -2ii)) * (2*x)^(n-2ii)))
    %               when fixp n and n > 0 and lisp !*rounded,
     hermitep (~n,~x)=> (begin scalar k,tmp,result,Ratio,oldslash,
                                      powlis1!*;
                        lisp setq(oldslash,remprop('slash,'opmtch));
                          % tmp:=subs(k=0,term);
                          tmp:=(2*x)**n;
                          result:=tmp;
                          % Ratio:=ratio(term,k);
                          Ratio:=-1/4/(k+1)*(n-2*k)*(n-2*k-1)/x**2;
                          for k:=0:n/2 do
                          <<
                          % tmp:=tmp*Ratio;
                            tmp:=-tmp*1/4/(k+1)*(n-2*k)*(n-2*k-1)/x**2;
                            result:=result+tmp;
                          >>;
                        lisp put('slash,'opmtch,oldslash); % restore
                          return(result);
                        end)
                       when fixp n and n > 0 ,
     hermitep (0,~x)=> 1};

let{ legendreP (~n,~x) =>
        %       (1/2^n * for ii:=0:floor(n/2) sum (binomial(n,ii) *
        %          binomial(2n-2ii,n)*(-1)^ii *x^(n-2ii)))
        (begin
        scalar k,tmp,result,Ratio,oldslash,powlis1!*;
         lisp setq(oldslash,remprop('slash,'opmtch));
         tmp:=2**(-n)*factorial(2*n)/factorial(n)**2*x**n;
         result:=tmp;
         % Ratio:=ratio(term,k);
         Ratio:=-1/2/x**2*(n-2*k-1)*(n-2*k)/(k+1)/(2*n-2*k-1);
         for k:=0:n/2 do
         <<
         % tmp:=tmp*eval(Ratio);
         tmp:=-tmp/2/x**2*(n-2*k-1)*(n-2*k)/(k+1)/(2*n-2*k-1);
         result:=result+tmp;
         >>;
         lisp put('slash,'opmtch,oldslash); % restore
         return(result);
         end) when fixp n and n > 0,

     legendreP (~n,~m,~x) => (-1)^m *(1-x^2)^(m/2)*
                                sub(!=z = x,df(legendreP (n,!=z),!=z,m))
                        when fixp n and n > 0 and fixp m and m > 0,
     jacobiP (~n,~a,~b,~x) =>
            (1/2^n * for ii:=0:n sum (binomial(n+a,ii) *
                binomial(n+b,n-ii)*(x-1)^(n-ii)*(x+1)^ii))
                when fixp n and n > 0 and numberp a and a > -1
                and numberp b and b > -1,
     jacobiP (~n,~a,~b,~x) => sub(!=z = x
                        ,first reverse legendre_base (!=z,n,a,b))
                        when fixp n and n > 0,
     legendreP (0,~x) => 1,
     legendreP (0,0,~x) => 1,
     jacobiP (0,~a,~b,~x) => 1};

let{ laguerreP(~n,~x) =>  laguerreP(~n,0,~x) when fixp n and n > 0,
        %  (for ii:=0:n sum (binomial(n,n-ii) *
        %        (-1)^ii/factorial ii *x^(ii)))
        %               when fixp n and n > 0,

     laguerreP(~n,~alpha,~x) => (begin scalar b1,b2,bex,r;
                                r := 1; b1 := 1-x+alpha; b2 := 1;
                                for i:= 1:(n-1) do <<
                                bex := (1+2r-x+alpha)/(r+1)*b1 -
                                         (r+alpha)/(r+1)*b2;
                                r := r+1; b2 := b1; b1 := bex;
                                >>;
                                return b1; end)
                when fixp n and n > 0 and numberp alpha and numberp x ,

     laguerreP(~n,~alpha,~x) =>
        %  (for ii:=0:n sum (binomial(n+alpha,n-ii) *
        %        (-1)^ii/factorial ii *x^(ii)))
        %               when fixp n and n > 0,
        (begin scalar k,tmp,result,Ratio,oldslash,powlis1!*;
          lisp setq(oldslash,remprop('slash,'opmtch));
          % tmp:=subs(k=0,term);
          if n=0 then return(1);
          tmp:=(for j:=1:n product (j+alpha))/factorial(n);
          % tmp:=prod(j+alpha,j,1,n)/factorial(n);
          result:=tmp;
          % Ratio:=ratio(term,k);
          Ratio:=-1/(alpha+k+1)*(n-k)*x/(k+1);
          for k:=0:n do
          <<
          % tmp:=tmp*Ratio;
            tmp:=-tmp/(alpha+k+1)*(n-k)*x/(k+1);
            result:=result+tmp;
          >>;
          lisp put('slash,'opmtch,oldslash); % restore
          return(result);
          end)  when fixp n and n > 0,

     laguerreP(0,~a,~x) => 1};

let {chebyshevT (~n,~x) =>
        %(n/2*for ii:=0:floor(n/2) sum ((-1)^ii*factorial (n-ii-1) /
        %   (factorial(ii) *factorial(n -2ii))* (2*x)^(n-2ii)))
        (begin
        scalar k,tmp,result,Ratio,oldslash,powlis1!*;
          lisp setq(oldslash,remprop('slash,'opmtch));
          if n=0 then return(1);
          if n=1 then return(x);
          % tmp:=subs(k=0,term);
          tmp:=2**(n-1)*x**n;
          result:=tmp;
          % Ratio:=ratio(term,k);
          Ratio:=-1/4*(n-2*k)*(n-2*k-1)/x**2/(n-k-1)/(k+1);
          for k:=0:n/2-1 do
          <<
          % tmp:=tmp*eval(Ratio);
            tmp:=-tmp/4*(n-2*k)*(n-2*k-1)/x**2/(n-k-1)/(k+1);
            result:=result+tmp;
          >>;
          lisp put('slash,'opmtch,oldslash); % restore
          return(result);
        end) when fixp n and n > 0 and not numberp x,

        chebyshevT (~n,~x) =>
         (begin
           if n=0 then return(1) else if n=1 then return(x) else
           if (floor(n/2)=n/2) then return(2*ChebyshevT(n/2,x)^2-1)
           else return(2*ChebyshevT((n-1)/2,x)*ChebyshevT((n+1)/2,x)-x)
          end) when fixp n and n > 0 and numberp x,

     chebyshevT (0,~x) => 1};

let {chebyshevU (~n,~x) =>
        %(for ii:=0:floor(n/2) sum ((-1)^ii*factorial (n-ii) /
        % (factorial(ii) *factorial(n -2ii))* (2*x)^(n-2ii)))
        (begin
        scalar k,tmp,result,Ratio,oldslash,powlis1!*;
          lisp setq(oldslash,remprop('slash,'opmtch));
          if n=0 then return(1);
          % tmp:=subs(k=0,term);
          tmp:=2**n*x**n;
          result:=tmp;
          % Ratio:=ratio(term,k);
          Ratio:=-1/4/(n-k)*(n-2*k)*(n-2*k-1)/x**2/(k+1);
          for k:=0:n/2 do
          <<
          % tmp:=tmp*eval(Ratio);
            tmp:=-tmp/4/(n-k)*(n-2*k)*(n-2*k-1)/x**2/(k+1);
            result:=result+tmp;
          >>;
          lisp put('slash,'opmtch,oldslash); % restore
          return(result);
        end) when fixp n and n > 0 and not numberp x,

        chebyshevU (~n,~x) =>
        ( begin
          if n=0 then return(1) else if n=1 then return(2*x) else
          if evenp n
            then return(2*ChebyshevT(n/2,x)*ChebyshevU(n/2,x)-1)
          else return(2*ChebyshevU((n-1)/2,x)*ChebyshevT((n+1)/2,x))
        end) when fixp n and n > 0 and numberp x,

     chebyshevU (0,~x) => 1};

let { gegenbauerP (~n,~a,~x) => (begin scalar b1,b2,bex,r;
                                r := 1; b1 := 2*a*x; b2 := 1;
                                for i:= 1:(n-1) do <<
                                bex := 2*(r+a)/(r+1)*x*b1 -
                                         (r+2*a-1)/(r + 1)*b2;
                                r := r+1; b2 := b1; b1 := bex;
                                >>;
                                return b1; end)
                when fixp n and n > 0 and numberp a and numberp x ,
        gegenbauerP (~n,~a,~x) =>
        %       (1/Gamma(a)*for ii:=0:floor(n/2) sum
        %((-1)^ii* gamma(a+n-ii)/(factorial ii *factorial(n-2ii))*
        % (2*x)^(n-2ii)))
        (begin scalar k,tmp,result,Ratio,oldslash,powlis1!*;
          lisp setq(oldslash,remprop('slash,'opmtch));
          % tmp:=subs(k=0,term);
          tmp:=(for j:=1:n product (a+j-1))/factorial(n)*2**n*x**n;
          % tmp:=prod(a+j-1,j,1,n)/factorial(n)*2**n*x**n;
          result:=tmp;
          % Ratio:=ratio(term,k);
          Ratio:=-1/4/(a+n-k-1)*(n-2*k)*(n-2*k-1)/x**2/(k+1);
          for k:=0:n/2 do
          <<
          % tmp:=tmp*eval(Ratio);
            tmp:=-tmp/4/(a+n-k-1)*(n-2*k)*(n-2*k-1)/x**2/(k+1);
            result:=result+tmp;
          >>;
          lisp put('slash,'opmtch,oldslash); % restore
          return(result);
        end)
        when fixp n and n > 0 and not(a=0),

     gegenbauerP (~n,0,~x) =>
        %(for ii:=0:floor(n/2) sum
        %((-1)^ii* factorial(n-ii-1)/(factorial ii *factorial(n-2ii))*
        %        (2*x)^(n-2ii)))
        (begin
        scalar k,tmp,result,Ratio,oldslash,powlis1!*;
          lisp setq(oldslash,remprop('slash,'opmtch));
          % tmp:=subs(k=0,term);
          tmp:=2**n*x**n/n;
          result:=tmp;
          % Ratio:=ratio(term,k);
          Ratio:=-1/4*(n-2*k)*(n-2*k-1)/x**2/(n-k-1)/(k+1);
          for k:=0:n/2 do
          <<
          % tmp:=tmp*eval(Ratio);
            tmp:=-tmp/4*(n-2*k)*(n-2*k-1)/x**2/(n-k-1)/(k+1);
            result:=result+tmp;
          >>;
          lisp put('slash,'opmtch,oldslash);
          return(result);
        end) when fixp n and n > 0 ,

%    gegenbauerP (~n,~a,~x) => sub(!=z = x,
%                               first reverse gegenbauer_base(!=z,n,a))
%                       when fixp n and n > 0,

     gegenbauerP (0,~a,~x) => 1};

% rules for differentiation

let {% AS (8.5.4)
df(LegendreP(~a,~b,~z),z)  => 1/(1-z^2)*
        ((a+b)*LegendreP(a-1,b,z) - a*z*LegendreP(a,b,z)),
df(LegendreP(~n,~z),z) => n/(1-z^2)*(LegendreP(n-1,z)-z*LegendreP(n,z)),
df(LegendreQ(~a,~b,~z),z)  => 1/(1-z^2)*
        ((a+b)*LegendreQ(a-1,b,z) - a*z*LegendreQ(a,b,z)),
% AS (22.8)
df(JacobiP(~n,~a,~b,~z),z) => 1/((1-z^2)*(2*n+a+b))*
        (2*(n+a)*(n+b)*JacobiP(n-1,a,b,z)+n*(a-b-(2*n+a+b)*z)
          *JacobiP(n,a,b,z)),
df(GegenbauerP(~n,~a,~z),z) => 1/(1-z^2)*
        ((n+2*a-1)*GegenbauerP(n-1,a,z)-n*z*GegenbauerP(n,a,z)),
df(ChebyshevT(~n,~z),z) =>
                   1/(1-z^2)*(n*ChebyshevT(n-1,z)-n*z*ChebyshevT(n,z)),
df(ChebyshevU(~n,~z),z) => 1/(1-z^2)*
        ((n+1)*ChebyshevU(n-1,z)-n*z*ChebyshevU(n,z)),
df(LaguerreP(~n,~a,~z),z) =>
        1/z*(-(n+a)*LaguerreP(n-1,a,z)+n*LaguerreP(n,a,z)),
df(LaguerreP(~n,~z),z) => 1/z*(-(n)*LaguerreP(n-1,z)+n*LaguerreP(n,z)),
df(HermiteP(~n,~z),z) => 2*n*HermiteP(n-1,z),
% AS (23.1.5)
df(BernoulliP(~n,~z),z) => n*BernoulliP(n-1,z),
% AS (23.1.5)
df(EulerP(~n,~z),z) => n*EulerP(n-1,z) };
>>;

% following ideas from John Abbott and Wolfram Koepf
% FIBONACCI NUMBERS (and Polynoms)

flag('(fibonacci fibonaccip),'opfn);
flag('(fibonacci),'integer);
put('fibonacci,'number!-of!-args,1);

symbolic procedure fibonacci(n);
 if not fixp n then mk!*sq mksqnew list ('fibonacci , n)
  else
  begin integer i3,m1;
   if n = 0 then return 0 else if abs(n)=1 then return 1;
   if n < 0 then << m1 := -1; n := abs n >>;
   i3 := fib_aux (n);
   return if (m1 = -1) then << if evenp n then (-i3) else i3; >>
                        else i3;
  end;

global '(fibonacci_alist);

symbolic << fibonacci_alist := '(( 0 . 0)
                (1 . 1) (2 . 1) (3 . 2) (4 . 3) (5 . 5)
                (6 . 8) (7 . 13) (8 . 21) (9 . 34)) >>;

symbolic procedure fib_aux (n);
   begin scalar fi;
         fi := atsoc (n,fibonacci_alist);
         if fi then return cdr fi;

         fi :=  fib_aux_aux n;
         fibonacci_alist := ( n . fi) . fibonacci_alist;
         return fi;
      end;

symbolic procedure fib_aux_aux (n); % from Wolfram Koepf, Sep 1998
                % d'apres Knuth & Ptachnik: Concrete Mathematics
  if evenp n  then (f*(f+2*fib_aux(n/2-1))) where f=fib_aux(n/2)
  else (fib_aux ((n+1)/2)^2 + fib_aux((n-1)/2)^2);

symbolic procedure fibonaccip(n,x);
 if or(not fixp n, not idp x)
         then mk!*sq mksqnew ('fibonaccip . list(n,x))
  else
  begin integer i3,i2,i1,m1;
   if n= 0 then return 0 else if n=1 then return 1;
   m1 := 1;
   if n < 0 then << m1 := -1; n := abs n >>;
   i2 := 1; i1 :=0;
   for i:=2:n do << i3 := reval list('plus,list('times, x ,i2),i1);
                        i1 := i2; i2 :=i3>>;
   return reval (list('times,list('expt,m1,list('plus,n,1)),i3));
  end;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/dilog.red0000644000175000017500000001053411526203062023557 0ustar  giovannigiovannimodule dilog;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Dilogarithm Integral and Polylogarithm function
% Lerch Phi

% Collected (most items) from Abramowitz-Stegun (27.7)
% by Winfried Neun , ZIB Berlin

% Lerch Phi from Wolfram's book

algebraic <<
operator fps;
operator Lerch_phi;
operator polylog;

let { fps(dilog ~x,~x,1) => infsum((-1)^k*(x-1)^k/k^2,k,1,infinity)};
let { df(dilog(~x),~x) => - LOG(X)/(x-1)};
let { int(log(~tt)/(~tt-1),~tt,1,~x) => -dilog x };
let { Lerch_phi(~z,~s,0) => polylog(s,z) };
let { Lerch_phi(1,~s,0) => zeta(s) };

let { dilog(exp(-~t)) => - dilog(exp t) - t^2/2,
      dilog(1/e^(~t)) => - dilog(exp t) - t^2/2,
      dilog(-~x+1) => - dilog(x) -log x * log (1-x) + pi^2/6
                        when numberp x and geq(x,0) and geq(1,x),
      dilog(~x)   => - dilog(1-x) - log (x) * log(1-x) + pi^2/6
                        when numberp x and (x > 0) and geq(1,x)
                        and not fixp(1/x),
      dilog(1/~x) => - dilog(x) -(log x)^2/2
                        when numberp x and geq(x,0),
      dilog(~x) =>   dilog(x-1) - log (x - 1) *
                        log (x)-pi^2/12-dilog( (x-1)^2)/2
                        when numberp x and geq(x,1) and geq(2,x)
                        and not (x = 0) and not fixp(1/x),
      dilog(~x) => compute_dilog(x)
                 when numberp x and lisp !*rounded and x>=0,
      dilog 2 => -pi^2/12,
      dilog 1 => 0,
      dilog 0 => pi^2/6};

let { Lerch_Phi (~z,~s,~a) => compute_lerch_phi(z,s,a)
              when lisp !*rounded and numberp z and numberp s and numberp a,
      polylog(~n,~z) =>  compute_lerch_phi(z,n,0)
              when lisp !*rounded and numberp z and numberp n };

procedure compute_dilog(x);
   if x = 0.0 then  pi^2/6
    else if x = 1.0 then  0
    else if x = 2.0 then  -pi^2/12
    else if (x >= 1.9 and x < 2.0) then
                 compute_dilog(1-(x-1)^2)/2 - compute_dilog(1-(x-1))
    else if (x > 1.9 or x < -1.0) then
                -(log x)^2/2 -compute_dilog(1/x)
    else if (x < 0.5 and x > 0.0)
                 then -log(1-x)*log(x) + pi^2/6 - compute_dilog(1-x)
    else if (x > 0.5 and x < 1.0 )
                then  -(log x)^2/2 -compute_dilog(1/x)
    else begin scalar !*uncached,yy,summa,ii,term,altern ,xm1,xm1!^ii;
                !*uncached :=t;
                yy := 10^-(lisp !:prec!:);
                summa := 0; xm1 := x-1.0; xm1!^ii := xm1;
                ii :=1; altern := -1;
                while abs(term :=(altern * xm1!^ii/(ii*ii))) >  yy do <<
                 summa := summa +  term; ii:=ii+1 ;
                 altern := -1 * altern; xm1!^ii := xm1!^ii *xm1>>;
                return summa; end;
>>;

procedure compute_lerch_phi(z,s,a);
    begin scalar !*uncached,yy,summa,k,term,pow;
           !*uncached :=t;
           term := 1; pow := 1;
           yy := 10^(-(lisp !:prec!:) -3);
           k := 0;
           summa := 0;
           while term > yy do <<
                if (a + k) neq 0 then
                << term := pow / (a+k)^s;
                   summa := summa + term>>;
                pow := pow * z;
                k := k + 1; >>;
           return summa;
    end;

endmodule;
end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/ghyper.red0000644000175000017500000006147211526203062023766 0ustar  giovannigiovannimodule ghyper;   % Generalized Hypergeometric Functions.

% Author : Victor Adamchik, Byelorussian University Minsk, Byelorussia.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Major modifications by: Winfried Neun, ZIB Berlin.

% Oct 22, 2001, hypergeometric({a,b},{0},z) returns
%         unevaluated (without error) as requested by Francis Wright


 put('GHF,'simpfn,'simpGHF)$

   symbolic procedure simpGHF u;
   if null cddr u then
        rerror('specialf,125,
              "WRONG NUMBER OF ARGUMENTS TO GHF-FUNCTION")
       else
   if or(not numberp car u,not numberp cadr u) then
        rerror('specialf,126,"INVALID AS INTEGER")
       else
   begin scalar vv,v;
   v:=redpar1(cddr u,car u);
   vv:=redpar1(cdr v,cadr u);
   if null cddr vv then return
      GHFsq(list(car u,cadr u),listsq car v,
      listsq car vv, simp cadr vv);
      return rerror ('specialf,127,
        "WRONG NUMBER OF ARGUMENTS TO GHF-FUNCTION");
   end$

 symbolic procedure GHFexit(a,b,z);
 begin scalar aa,bb;
  aa:= 'list . listprepsq a;
  bb:= 'list . listprepsq b;
  return mksqnew('hypergeometric .
        append(list(aa,bb),list(prepsq z)))$
  end;

%***********************************************************************
%*                      GHF as a polynomial                            *
%***********************************************************************

symbolic procedure listmaxsq u;
 % u - list of numbers of SQ.
 % return - max value.
 if null cdr u then car u else
 if null caar u then car u else
 if null caadr u then cadr u else
 if greaterp(caar u,caadr u) or equal(car u,cadr u) then
            listmaxsq((car u) . cddr u) else
            listmaxsq((cadr u) . cddr u)$

 symbolic procedure GHFpolynomp (u,a);
 begin scalar w1,w2;
M1:
 if null u then
   if null w1 then <>
              else <>
           else
 if parfool(car u) then (w1:=(car u) . w1)
                   else (w2:=(car u) . w2);
 u:=cdr u;
 GOTO M1;
 end$

 symbolic procedure polynom(u,a,b,z);
 % u - list of SQ.
 begin scalar s; integer k;
 if null caar(u) then return '(1 . 1) else
   s := GHFpolynomp (b,a);
   a := cdr s;
   if car s then
     if null caar a or greaterp(caar a,caar u) then
     <<%rerror('special,124,
       %        "zero in the denominator of the GHF-function");
       b:=a; a:=u;
       return GHFexit(a,b,z);
     >>
   else b:=a;
  k:=1;  s:=1 . 1;
M:
    s:=addsq(s,quotsq(multsq(multpochh(u,simp k),exptsq(z,k)),
        multpochh(append(list('(1 . 1)),b),simp k)));
    k:=k+1;
    if greaterp(k,car negsq(car u)) then return s else goto m;
   end$

%***********************************************************************
%*                   Lowering of the order GHF                         *
%***********************************************************************

 symbolic smacro procedure GHFlowering1p;
  begin scalar sa,sb,w1,w2;
  sa:=a;   sb:=b;
 M1:  if null b then << a:=sa; b:=sb; return NIL
                     >>;
 M2:  if null a then << w2:= (car b) . w2;
                        b:=cdr b;
                        a:=sa; w1:=nil;
                        GOTO M1
                     >>
                 else
      if numberp(prepsq diff1sq(car a,car b)) and
         greaterp(car(diff1sq(car a,car b)),0) then
                        <<
                         b:=car b . append(w2,cdr b);
                         a:=diff1sq(car a,car b) . append(w1,cdr a);
                         return T
                        >> else
                        <<
                         w1:=(car a) . w1;
                         a:=cdr a;
                         GOTO M2
                        >>;
   end$

 symbolic procedure lowering1(x,y,u,z);
  % x -- (m . a).
  % y -- (g . b).
  addsq(GHFsq(u,append(list(diff1sq(addsq(car x,car y),'(1 . 1))),
                            cdr x),
                append(list(car y),cdr y),z),
        multsq(GHFsq(u,append(list(addsq(car x,car y)),listplus(cdr x,
                        '(1 . 1))),
                       append(list(addsq(car y,'(1 . 1))),
                              listplus(cdr y,'(1 . 1))),z),
               quotsq(multsq(z,multlist(cdr x)),
                      multsq(car y,multlist(cdr y)))))$

 symbolic smacro procedure GHFlowering2p;
  begin scalar sa,sb,w1,wa,fl;
  if equal(z,'(1 . 1)) then return NIL;
  sa:=a;   sb:=b;
 M1:  if null b then
         << b:=sb;
            if fl then a:=wa . sa else a:= sa;
            return NIL
         >>;
 M2:  if null a then
         << b:=cdr b;
            a:=sa; w1:=nil;
            GOTO M1
         >>
                else
      if numberp(prepsq diff1sq(car b,car a)) and
         lessp(car(diff1sq(car a,car b)),0) then
               if fl then
                 if not equal(wa,car a) then
                    << b:=sb;
                       a:=list(wa,car a) . append(w1,cdr a);
                       return T
                    >>
                    else
                    <<
                       w1:=(car a) . w1;
                       a:=cdr a;
                       GOTO M2
                    >>
                 else
                 << fl:=T;
                    sa:=append(w1,cdr a);
                    wa:=car a;
                    b:=cdr b; a:=sa; w1:=nil;
                    GOTO M1
                 >>
              else
              << w1:= (car a) .w1;
                 a:=cdr a;
                 GOTO M2
              >>;
   end$

   symbolic procedure lowering2(x,b,u,z);
   % x -- (r s).(a).
  diff1sq(multsq(GHFsq(u,append(list(caar x,addsq('(1 . 1),cadar x)),
                        cdr x),b,z),
                  quotsq(cadar x,diff1sq(cadar x,caar x))),
           multsq(GHFsq(u,append(list(addsq('(1 . 1),caar x),cadar x),
                        cdr x),b,z),
                  quotsq(caar x,diff1sq(cadar x,caar x))))$

  symbolic smacro procedure GHFlowering3p;
  %return a = (mmm . a1).
   begin scalar sa,w,mmm;    % MM used in SPDE as a global.
   sa:=a;
M1: if null a then << a:=sa; return NIL >>
              else
    if not numberp(prepsq car a) then
                   <>;

    if member ('(1 . 1), a) then <>
                else << mmm:= car a;  a:=cdr a >>; % WN 2.2 94

M2:  if null a then
        if listnumberp b then << a:=mmm . w; return T >>
                         else << a:=sa; return NIL>>
                else
        if equal(car a,'(1 . 1)) then
                         <>
                                else
                         <>;
  end$

  symbolic procedure listnumberp(v);
  % v -- list of SQ.
  % value is T if numberp exist in (v).
   if null v then NIL
             else
   if numberp(prepsq car v)  then T
                             else listnumberp(cdr v)$

  symbolic procedure lowering3(a,b,u,z);
  multsq(quotsq(multlist(difflist(b,'(1 . 1))),multsq(z,multlist(
                         difflist(cdr a,'(1 . 1))))),
         diff1sq(GHFsq(u, (car a) . difflist(cdr a,'(1 . 1)),
                         difflist(b,'(1 . 1)),z),
                 GHFsq(u,append(list(diff1sq(car a,'(1 . 1))),
                    difflist(cdr a,'(1 . 1))),difflist(b,'(1 . 1)),z)))$

%***********************************************************************
%*                      GHFsq, main entry                              *
%***********************************************************************

   symbolic procedure GHFsq(u,a,b,z);
   % u -- (p q) PF.
   % a,b -- lists of SQ.
   % z -- SQ.
   begin scalar c,aaa;
   u:=redpar(a,b);
   a:=car u;b:=cadr u;u:=list(length(a), length(b));
   if null car(z) then return '(1 . 1) else
   if listparfool(b,(nil .1)) and not listparfool(a,(nil . 1)) then
       % return rerror('specialf,128,
        %"zero in the denominator of the GHF-function")
       return GHFexit(a,b,z)
      else
   aaa := GHFpolynomp(a,a);
   a := cdr aaa;
   if car aaa         then return polynom(a,a,b,z) else
   if GHFlowering1p() then return lowering1(a,b,u,z) else
   if GHFlowering2p() then return lowering2(a,b,u,z) else
   if GHFlowering3p() then return lowering3(a,b,u,z) else
   if car u = 0 and cadr u = 0 then return expdeg(simp 'e,z) else
   if car u = 0 and cadr u = 1 then return GHF01(a,b,z) else
   if car u = 1 and cadr u = 0 then
       if  z='(1 . 1) then return GHFexit(a,b,z)
       else
          return expdeg(diff1sq('(1 . 1),z),if null a then '(nil . 1)
                                          else negsq(car a))
                                                          else
   if car u = 1 and cadr u = 1 then return GHF11(a,b,z)  else
   if car u = 1 and cadr u = 2 then return GHF12(a,b,z)  else
   if car u = 2 and cadr u = 1 then return GHF21(a,b,z)  else
   if car u = cadr u + 1 then
      if (c:=GHFmid(a,b,z)) = 'FAIL
                        then return GHFexit(a,b,z)
                        else return c;

   if car u <= cadr u then return GHFexit(a,b,z);
   return rerror('specialf,131,"hypergeometric series diverges");
   end$


%***********************************************************************
%                        p = q+1                                       *
%***********************************************************************

 symbolic procedure GHFmid(a,b,z);
 begin scalar c;
  c:= redpar(a,difflist(b, '(1 . 1)));
   if length(cadr c) > 0 or length(car c) > 1 then return 'FAIL
     else
      return formulaformidcase(length(b), caar c,
                               diff1sq(car b,'(1 . 1)), z);
 end$

 symbolic procedure formulaformidcase(p,b,a,z);
 if not(p = 1) and b = '(1 . 1) and z = '(1 . 1) then
        multsq(simpx1(prepsq(multsq('(-1 . 1),a)),p,1),
               quotsq(dfpsisq(a,simp(p-1)),gamsq(simp p)))
   else
 if b = '(1 . 1) and z='(-1 . 1) then
    quotsq(multsq(simpx1(prepsq(multsq('(-1 . 2),a)),p,1),
               diff1sq(dfpsisq(multsq(a, '(1 . 2)),simp(p-1)),
                    dfpsisq(multsq(addsq('(1 . 1),a),'(1 . 2)),
                            simp(p-1)))),
           gamsq(simp p))
   else
 if z = '(1 . 1) and not numberp(prepsq b) then
    multsq(
    subsqnew(
     derivativesq(
       quotsq(gamsq(simp 'r),gamsq(addsq(simp 'r,diff1sq('(1 . 1),b)))),
       'r,simp(p-1)),
     a,'r),
    quotsq(
      multsq(multsq(simpx1(prepsq(multsq('(-1 . 1),a)),p,1), '(-1 . 1)),
             gamsq(diff1sq('(1 . 1),b))),
     gamsq(simp p)))
   else
 if z='(-1 . 1) and numberp prepsq(b) then
    begin scalar c; integer k;
    return multsq(
     subsqnew(
      derivativesq( addsq(
             <<
               k:=prepsq(b) - 1; c:='(nil . 1);
               while prepsq(k)>0 do
                <<
                c:=addsq(c, multsq(gamsq(b),
                simppochh(diff1sq(simp(1+k),simp 'r),
                          simp(prepsq(b)-1-k))));
                k:=k-1
                >>;
              c
             >>,
             quotsq(
               multsq(gamsq(diff1sq(b,simp 'r)),
                diff1sq(psisq(multsq(addsq(simp 'r,'(1 . 1)),'(1 . 2))),
                             psisq(multsq(simp 'r,'(1 . 2))))),
               multsq((2 . 1), gamsq(diff1sq('(1 . 1),simp 'r))))),
      'r,p-1), a, 'r),
    quotsq(
           multsq(simpx1(prepsq(multsq('(-1 . 1),a)),p,1), '(-1 . 1)),
           multsq(gamsq(simp p),gamsq(simp b))))
  end
 else 'FAIL$

%***********************************************************************
%*                       Particular cases                              *
%***********************************************************************

 symbolic procedure GHF01(a,b,z);
  if znak z then
   multsq(gamsq(car b),multsq(bessmsq(diff1sq(car b,'(1 . 1)),
   multsq('(2 . 1),simpx1(prepsq z,1,2))),
          expdeg(z,quotsq(diff1sq('(1 . 1),car b),'(2 . 1)))))
                     else
   multsq(gamsq(car b),multsq(besssq(diff1sq(car b,'(1 . 1)),
   multsq('(2 . 1),simpx1(prepsq(negsq z),1,2))),expdeg(negsq z,
   quotsq(diff1sq('(1 . 1),car b),'(2 . 1))))) $

  symbolic procedure GHF11(a,b,z);
  if equal(car b,multsq('(2 . 1),car a)) then
     multsq(multsq(gamsq(addsq('(1 . 2),car a)),expdeg(simp 'e,
                       multsq(z,'(1 . 2)))),
            multsq(expdeg(multsq(z,'(1 . 4)),diff1sq('(1 . 2),car a)),
                   bessmsq(diff1sq(car a,'(1 . 2)),multsq(z,'(1 . 2)))))
  else
  if equal(car a,'(1 . 2)) and equal(car b,'(3 . 2)) then
     multsq(quotsq(simpx1('pi,1,2),'(2 . 1)),
     if znak z then
       quotsq(simpfunc('erfi,simpx1(prepsq z,1,2)),simpx1(prepsq z,1,2))
               else
        quotsq(simpfunc('erf,simpx1(prepsq(negsq z),1,2)),
               simpx1(prepsq(negsq z),1,2)))
  else
  if equal(car a,'(1 . 1)) and equal(car b,'(3 . 2)) and znak z then
     multsq(multsq('(1 . 2),expdeg(simp 'e,z)),
            multsq(simpfunc('erf,simpx1(prepsq z,1,2)),simpx1(prepsq
            quotsq(simp('pi),z),1,2)))
                   else GHFexit(a,b,z)$

  symbolic procedure GHF21(a,b,z);
  if and(equal(car a,'(1 . 2)),equal(cadr a,'(1 . 2)),
         equal(car b,'(3 . 2)),znak(z))
    then
     quotsq(simpfunc('asin,simpx1(prepsq(z),1,2)),
       simpx1(prepsq(z),1,2))
    else
  if ((equal(car a,'(1 . 2)) and equal(cadr a,'(1 . 1))) or
      (equal(car a,'(1 . 1)) and equal(cadr a,'(1 . 2)))) and
       equal(car b,'(3 . 2))
    then
    <<
    if not znak(z) then
        quotsq(simpfunc('atan,simpx1(prepsq(negsq z),1,2)),
        simpx1(prepsq(negsq z),1,2)) else
%    if not equal(z,'(1 . 1)) then
%       quotsq(simpfunc('log,addsq('(1 . 1),simpx1(prepsq z,1,2))),
%       multsq(simpfunc('log,diff1sq('(1 . 1),simpx1(prepsq z,1,2))),
%       multsq('(2 . 1),simpx1(prepsq z,1,2)))) else
     if not equal(z,'(1 . 1)) then
       multsq(simpfunc('log,quotsq(addsq('(1 . 1),simpx1(prepsq z,1,2)),
                            diff1sq('(1 . 1),simpx1(prepsq z,1,2)))),
              invsq(multsq('(2 . 1),simpx1(prepsq z,1,2)))) else
    GHFexit(a,b,z)
    >>
    else
  if and(equal(car a,'(1 . 1)),equal(cadr a,'(1 . 1)),
         equal(car b,'(2 . 1)),not equal(z,'(1 . 1)))
    then
       quotsq(simpfunc('log,addsq('(1 . 1),negsq z)),negsq z)
    else
  if equal(diff1sq(addsq(car a,cadr a),car b),'(-1 . 2)) and
     (equal(multsq('(2 . 1),car a),car b) or
      equal(multsq('(2 . 1),cadr a),car b))
    then
       multsq(expdeg(addsq('(1 . 1),
              simpx1(prepsq(diff1sq('(1 . 1),z)),1,2)),
       diff1sq('(1 . 1),car b)),expdeg('(2 . 1),addsq(car b,'(-1 . 1))))
    else
  if z='(1 . 1)
     and (not numberp prepsq diff1sq(car b,addsq(car a, cadr a))
          or prepsq(diff1sq(car b,addsq(car a, cadr a))) > 0 )
    then quotsq(multsq(gamsq(car b),
                       gamsq(diff1sq(car b,addsq(car a,cadr a))) ),
                multsq(gamsq(diff1sq(car b,car a)),
                       gamsq(diff1sq(car b,cadr a))))
    else
  if car a='(1 . 1) and cadr a='(1 . 1) and numberp prepsq car b and
     prepsq car(b) > 0 and not(z='(1 . 1)) then
        formula136(prepsq car b,z) else
GHFexit(a,b,z)$

 symbolic procedure formula136(m,z);
 begin scalar c; integer k;
 c:='(nil . 1); k:=2;
 while k<=m-1 do
   << c:=addsq(c,quotsq(exptsq(diff1sq(z,'(1 . 1)),k),
                        multsq(exptsq(z,k),simp(m-k))));
      k:=k+1
   >>;
 c:=diff1sq(c,multsq(exptsq(quotsq(diff1sq(z,'(1 . 1)),z),m),
                     simpfunc('log,diff1sq('(1 . 1),z))));
 return
  multsq(c,
         quotsq(multsq(simp(m-1),z),exptsq(diff1sq(z,'(1 . 1)),2)));
 end$

  symbolic procedure GHF12(a,b,z);
  if equal(car a,'(3 . 4)) and (equal(car b,'(3 . 2)) and equal(cadr b,
     '(7 . 4)) or equal(car b,'(7 . 4)) and equal(cadr b,'(3 . 2)))
     and not znak z  then
     <>
                    else
  if equal(car a,'(1 . 4)) and (equal(car b,'(1 . 2)) and equal(cadr b,
     '(5 . 4)) or equal(car b,'(5 . 4)) and equal(cadr b,'(1 . 2)))
     and not znak z  then
     <>
            else GHFexit(a,b,z)$

symbolic smacro procedure fehler();
        rerror('specialf,139,"Wrong arguments to hypergeometric");

symbolic procedure hypergeom(U);

begin scalar list1,list2,res,res1;

if not (length(u) = 3) then fehler();
if pairp u then list1 :=car u else fehler();
if pairp cdr u then list2 := cadr u else fehler();
if not pairp cddr u then  fehler();

if not eqcar(list1,'list) then fehler();
if not eqcar(list2,'list) then fehler();

list1 := for each x in cdr list1 collect simp reval x;
list2 := for each x in cdr list2 collect simp reval x;
res := ghfsq(list (length list1,length list2),
                        list1,list2,simp caddr u);
res1 := prepsq res;
return if eqcar(res1,'hypergeometric) then res else simp res1;
                        end;

put('hypergeometric,'simpfn,'hypergeom);

% something is missing:

algebraic let {hypergeometric({1/2,1/2},{3/2},-(~x)^2) => asinh(x)/x };

algebraic let hypergeometric({~a,~b},{~c},-(~z/(1-~z))) =>
                hypergeometric({a,c-b},{c},z) * (1-z)^a;
                % Pfaff's reflection law

flag ('(permutationof),'boolean);

symbolic procedure permutationof(set1,set2);
        length set1 = length set2
         and not setdiff(set1,set2);

algebraic let {
 hypergeometric({},~lowerind,~z) =>
        3/(32*sqrt(2)*(-z)^(3/4))*
         (cosh(2*(-z*4)^(1/4))*sin(2*(-z*4)^(1/4)) -
         sinh(2*(-z*4)^(1/4))*cos(2*(-z*4)^(1/4)))
        when permutationof(lowerind,{5/4,3/2,7/4})
        and numberp z and z < 0,

 hypergeometric({},~lowerind,~z) =>
        1/(4*(-4*z)^(1/4))*
          (sinh(2*(-z*4)^(1/4))*cos(2*(-z*4)^(1/4)) +
           cosh(2*(-z*4)^(1/4))*sin(2*(-z*4)^(1/4)))
        when permutationof(lowerind,{5/4,1/2,3/4})
             and numberp z and z < 0,

 hypergeometric({},~lowerind,~z) =>
         1/(8*(-z)^(1/2))*sinh(2*(-z*4)^(1/4))*sin(2*(-z*4)^(1/4))
        when permutationof(lowerind,{3/4,5/4,3/2})
            and numberp z and z < 0,

 hypergeometric({},~lowerind,~z) =>
         cosh(2*(-z*4)^(1/4))*cos(2*(-z*4)^(1/4))
        when permutationof(lowerind,{1/4,1/2,3/4})
           and numberp z and z < 0,

 hypergeometric({},~lowerind,~z) =>
         3/(64*z^(3/4))*(sinh(4*z^(1/4)) -sin(4*z^(1/4)))
               when permutationof(lowerind,{5/4,3/2,7/4}),

 hypergeometric({},~lowerind,~z) =>
          1/(8*z^(1/4))*(sinh(4*z^(1/4)) +sin(4*z^(1/4)))
               when permutationof(lowerind,{5/4,1/2,3/4}),

 hypergeometric({},~lowerind,~z) =>
          1/(16*z^(1/2))*(cosh(4*z^(1/4)) -cos(4*z^(1/4)))
             when permutationof(lowerind,{3/4,5/4,3/2}),

 hypergeometric({},~lowerind,~z) =>
          1/2*(cosh(4*z^(1/4)) + cos(4*z^(1/4)))
            when permutationof(lowerind,{1/4,1/2,3/4})
};


algebraic
<< hypergeometric_rules:=

{ hypergeometric({~a},{},~x) => (1-x)^(-a) when not(numberp x and x=1),

% F(a;b;z)

  hypergeometric({1/2},{5/2},~x) =>
        3/(4*x)*((1+2*x)/2*sqrt(pi/x)*erfi(sqrt(x))-e^x),

  hypergeometric({1},{1/2},~x) =>
        1+sqrt(pi*x)*e^x*erf(sqrt(x)),

  hypergeometric({1},{3/2},~x) =>
        1/2*sqrt(pi/x)*e^x*erf(sqrt(x)),

  hypergeometric({1},{5/2},~x) =>
        3/(2*x)*(1/2*sqrt(pi/x)*e^(x)*erf(sqrt(x))-1),

  hypergeometric({1},{7/2},~x) =>
        5/(4*x^2)*(3/2*sqrt(pi/x)*e^x*erf(sqrt(x))-3-2*x),

  hypergeometric({3/2},{5/2},-~x) =>
        e^(-x)*hypergeometric({1},{5/2},x),

  hypergeometric({3/2},{5/2},~x) =>
        3/(2*x)*(e^x-1/2*sqrt(pi/x)*erfi(sqrt(x))),

  hypergeometric({5/2},{7/2},-~x) =>
        e^(-x)*hypergeometric({1},{7/2},x),

  hypergeometric({7/2},{9/2},-~x) =>
        e^(-x)*hypergeometric({1},{9/2},x),

  hypergeometric({~a},{~b},~x) =>
        a*(-x)^(-a)*m_gamma(a,-x) when b = a + 1,

  hypergeometric({~a},{~b},~x) =>
        (a+1)*(e^(x)+(-x-a)*(-x)^(-a-1)*m_gamma(a+1,-x))
        when b = a + 2,

% F(a,b;c;z)

  hypergeometric({-1/2,1},{3/2},-~x) =>
       (1/2)*(1+(1+x)*(atan(sqrt(x))/sqrt(x))),

  hypergeometric({-1/2,1},{3/2},~x) =>
       (1/2)*(1+(1-x)*(atanh(sqrt(x))/sqrt(x))),

  hypergeometric({1/2,1},{5/2},-~x) =>
       (3/2*-x)*(1-(1+x)*(atan(sqrt(x))/sqrt(x))),

  hypergeometric({1/2,1},{5/2},~x) =>
       (3/2*x)*(1-(1-x)*(atanh(sqrt(x))/sqrt(x))),

  hypergeometric({~a + 1/2,~a},{1/2},~x) =>
    (1-x)^(-a)*cos(2*a*atan(sqrt(-x))),

  hypergeometric({5/4,3/4},{1/2},~x) =>
    (1-x)^(-3/4)*cos(3/2*atan(sqrt(-x))),

  hypergeometric({(~n+1)/2 + 1/2,(~n+1)/2},{1/2},~x) =>
     (1-x)^(-(n+1)/2)*cos((n+1)*atan(sqrt(-x))),


  hypergeometric({7/4,5/4},{3/2},~x) =>
     2/3*(1-x)^(-3/4)/sqrt(-x)*sin(3/2*atan(sqrt(-x))),

  hypergeometric({~a + 1/2,~a},{3/2},~x) =>
    ((1-x)^(1/2-a))/((2*a-1)*sqrt(-x))*sin((2*a-1)*atan(sqrt(-x))),

  hypergeometric({(~n+2)/2 + 1/2,(~n+2)/2},{3/2},~x) =>
    ((1-x)^(1/2-(n+2)/2))/((2*(n+2)/2-1)*sqrt(-x))*sin((2*(n+2)/2-1)
                                                *atan(sqrt(-x))),

% F(a;b,c;z);

  hypergeometric({-1/2},{1/2,1/2},-~x) =>
       cos(2*sqrt(x))+2*sqrt(x)*si(2*sqrt(x)),

  hypergeometric({-1/2},{1/2,1/2},~x) =>
       cosh(2*sqrt(x))-2*x*shi(2*sqrt(x)),

  hypergeometric({-1/2},{1/2,3/2},-~x) =>
       (1/2)*(cos(2*sqrt(x))+(sin(2*sqrt(x)))/(2*sqrt(x))
                                        +2*sqrt(x)*si(2*sqrt(x))),

  hypergeometric({-1/2},{1/2,3/2},~x) =>
       (1/2)*(cosh(2*sqrt(x))+(sinh(2*sqrt(x)))/(2*sqrt(x))
                                        -2*sqrt(x)*shi(2*sqrt(x))),

  hypergeometric({-1/2},{3/2,3/2},-~x) =>
       (1/4)*(cos(2*sqrt(x))+(sin(2*sqrt(x)))/(2*sqrt(x))
                                +(1+2*x)*(si(2*sqrt(x)))/sqrt(x)),

  hypergeometric({-1/2},{3/2,3/2},~x) =>
       (1/4)*(cosh(2*sqrt(x)) +(sinh(2*sqrt(x)))/(2*sqrt(x))
                                +(1-2*x)*(shi(2*sqrt(x)))/sqrt(x)),


  hypergeometric({1/2},{3/2,3/2},-~x) =>
       si(2*sqrt(x))/(2*sqrt(x)),

  hypergeometric({1/2},{3/2,3/2},~x) =>
       shi(2*sqrt(x))/(2*sqrt(x)),


  hypergeometric({1/2},{5/2,3/2},-~x) =>
       3/(8*-x)*(2*sqrt(x)*si(2*sqrt(x))-cos(2*sqrt(x))+
                                (sin(2*sqrt(x)))/(2*sqrt(x))),

  hypergeometric({1/2},{5/2,3/2},~x) =>
       3/(8*x)*(2*sqrt(x)*shi(2*sqrt(x))-cosh(2*sqrt(x))+
                                (sinh(2*sqrt(x)))/(2*sqrt(x))),


  hypergeometric({1},{3/4,5/4},~x) =>
    1/2*sqrt(pi/sqrt(-x))*(cos(2*sqrt(-x))*fresnel_c(2*sqrt(-x))
        + sin(2*sqrt(-x))*fresnel_s(2*sqrt(-x))),

  hypergeometric({1},{5/4,7/4},~x) =>
    3*sqrt(pi)/(8*(sqrt(-x))^(3/2))*(sin(2*sqrt(-x))
        *fresnel_c(2*sqrt(-x))-cos(2*sqrt(-x))*fresnel_s(2*sqrt(-x))),

  hypergeometric({5/2},{7/2,7/2},-~x) =>
       (75/(16*x^2))*(3*si(2*sqrt(x))/(2*sqrt(x))
                - 2*sin(2*sqrt(x))/sqrt(x) + cos(2*sqrt(x))),

  hypergeometric({5/2},{7/2,7/2},~x) =>
       (75/(16*x^2))*(3*shi(2*sqrt(x))/(2*sqrt(x))
                        - 2*sinh(2*sqrt(x))/sqrt(x) + cosh(2*sqrt(x))),


  hypergeometric({~a},{~b,3/2},~x) =>
    -2^(1-2*a)*a*(sqrt(-x))^(-2*a)*
                (gamma(2*a-1)*cos(a*pi)+fresnel_s(2*sqrt(-x),2*a-1))

    when b = a + 1,

  hypergeometric({~a},{~b,1/2},~x) =>
    2^(1-2*a)*a*(sqrt(-x))^(-2*a)*
                (gamma(2*a)*cos(a*pi)-fresnel_c(2*sqrt(-x),2*a))

    when b = a + 1
};

let hypergeometric_rules;

operator Poisson!-Charlier, Toronto;

let { Toronto(~m,~n,~x) =>
           Gamma(m/2 + 1/2)/factorial n * x^(2*n-2*m+1)*exp(-x^2) *
           KummerM(m/2+1/2,1+n,x^2),

      Poisson!-Charlier(~n,~nu,~x) =>
           pochhammer(1 + nu-n,n)/(sqrt factorial n * x^(n/2))*
               sum(pochhammer(-n,i)*x^i/
                (pochhammer(1+nu-n,i) * factorial i)
           ,i,0,n)
    };
>>;


endmodule;

end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/hgrsolve.red0000644000175000017500000000712011526203062024307 0ustar  giovannigiovannimodule hypergeomRsolve;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*tracefps);

algebraic procedure hypergeomRsolve (r,k,a0);

% solves the recurrence equation
%
%  a(k+1) = r(k) * a(k), a(0) = a0

  begin scalar Re,NNN,DDD,c,p,q,ak,sols,II;

   P := {}; Q := {};
   C := 1;

   Re := R * (k + 1);

   NNN := old_factorize num Re; DDD := old_factorize den re;

   foreach nn in NNN do
   if freeof (nn,k) then c := c * nn
        else if deg(nn,k) =1 then
        << C:= c*coeffn(nn,k,1);
            P:= append (p,list(coeffn(nn,k,0)/coeffn(nn,k,1)))>>
        else if deg(nn,k) =2 then
        << c := c *  lcof(nn,k);
                sols := solve(nn,k);
                for each s in sols do
                   << for i:=1:first multiplicities!* do
                        P:= (- rhs s) . p;
                      multiplicities!* := rest multiplicities!*;
                  >>
        >>
        else rederr(" hypergeomRsolve failed");

   foreach dd in DDD do
   if freeof (DD,k) then c := c / dd
        else if deg(DD,k) =1 then
        << C:= C/coeffn(dd,k,1);
            Q:= append (Q,list(coeffn(dd,k,0)/coeffn(dd,k,1)))>>
        else if deg(DD,k) =2 then
             << c := c /  lcof(dd,k);
                sols := solve(dd,k);
                for each s in sols do
                   << for i:=1:first multiplicities!* do
                        Q:= (- rhs s) . Q;
                      multiplicities!* := rest multiplicities!*;
                  >>;
             >>
        else rederr(" hypergeomRsolve failed");

   RSOLVE := infinite;
   for each s in P do if fixp s and s < 0 then RSOLVE := finite;
   if symbolic !*traceFPS then  write "RSOLVE  = ",RSOLVE;

   P := for each s in P product pochhammer(s,k);
   Q := for each s in Q product pochhammer(s,k);

   ak := a0 * (C^k) * P/(q * factorial k);

% Do additional simplification here??

   return ak;
end;

% A special ruleset for powerseries; nn has a special meaning here and
% should be treated as integer

algebraic <<

hgspec_pochhammer :=

{ Pochhammer(~kk,~nn) => 1 when nn=0,
  Pochhammer(~kk,nn) => 0 when kk = 0,
  Pochhammer(~kk,nn) => (-1)^nn * factorial(-kk)/factorial(-kk-nn)
                        when fixp(kk) and kk <=0,
  Pochhammer(~kk,nn) => factorial(kk+nn-1)/factorial(kk-1) when fixp kk,
  Pochhammer(~kk,~w*nn) =>
     factorial(kk+w*nn-1)/factorial(kk-1) when fixp kk}
>>;

endmodule;
end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/jsymbols.red0000644000175000017500000004500511526203062024324 0ustar  giovannigiovannimodule jsymbols;

% Author: Matthew Rebbeck, ZIB.
% Advisor: Rene' Grognard.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date:   March 1994

% Version 1 (experimental code for the symbolic 6j symbol)
%            by Winfried Neun (ZIB) email: neun@zib-berlin.de

% ThreeJSymbol with reasoning on the input for optimal computing;
% Note: the code is 'pedestrian' but should be transparent and it
% seems to work !
% It reflects strongly the exploratory code I used to orientate myself
% It should be rewritten in a more 'professional' style;

load!-package 'matrix;   % Needed for matrix input.
load!-package 'solve;
load!-package 'ineq;

symbolic procedure clean_up_sqrt(input);
  %
  %  Takes input and factorises out all sqrt's.
  %
  begin
    scalar num,denom,answer;
    if not pairp input or car input neq 'quotient then answer := input
     else <<
      num := cadr input;
      denom := caddr input;
      num := collect_sqrt(num);
      denom := collect_sqrt(denom);
      answer := {'quotient,num,denom}; >>;
    return answer;
  end;

flag('(clean_up_sqrt),'opfn);


symbolic procedure collect_sqrt(input);
  %
  %  Cleans up a series of multiplied sqrt's.
  %  eg: sqrt(x)*sqrt(y)->sqrt_of(x*y).
  %
  begin
    scalar sqrt_args,extra_bit,minust,answer;
    sqrt_args := {}; extra_bit := {};
    if not pairp input then answer := input
     else <<
      if car input = 'minus then
                <>;
      if car input='times then input := cdr input else input := {input};
      for each elt in input do

      << if eqcar(elt,'sqrt)
          then sqrt_args := append(sqrt_args,{cadr elt})
           else extra_bit := append(extra_bit,{elt}); >>;
    if sqrt_args = {} then <>
     else <<
       sqrt_args:=reval append({'sqrt_of},{append({'times},sqrt_args)});
       answer := append({sqrt_args},extra_bit); >>;
     answer := append({'times},answer);
    if minust then answer := {'minus,answer}; >>;
    return answer;

end;

symbolic operator listp;

algebraic operator sqrt_of, oddexpt;

algebraic << let sqrt_of(~x) => sqrt (x) when numberp x >>;


algebraic procedure ThreeJSymbol (u1,u2,u3);
 if listp u1 and listp u2 and listp u3 then
  begin
   scalar j1,j2,j3,m1,m2,m3,tmp,lower,upper,better,best;
   matrix range(6,2);
   j1:=first u1; m1:=second u1;
   j2:=first u2; m2:=second u2;
   j3:=first u3; m3:=second u3;

   % Vanishing conditions;

   if numberp(tmp:=m1+m2+m3) and tmp neq 0 then return 0
   else if numberp(tmp:=j1+j2+j3) and tmp < -1 then return 0
   else if numberp(tmp:=j1+j2-j3) and tmp < 0 then return 0
   else if numberp(tmp:=j1-j2+j3) and tmp < 0 then return 0
   else if numberp(tmp:=j2+j3-j1) and tmp < 0 then return 0
   else if numberp(tmp:=j1+m1) and tmp < 0 then return 0
   else if numberp(tmp:=j1-m1) and tmp < 0 then return 0
   else if numberp(tmp:=j2+m2) and tmp < 0 then return 0
   else if numberp(tmp:=j2-m2) and tmp < 0 then return 0
   else if numberp(tmp:=j3+m3) and tmp < 0 then return 0
   else if numberp(tmp:=j3-m3) and tmp < 0 then return 0
   else

   % Restrictions on k

   <>
     else <>;

     % {j1,m1} <-> {j2,m2};

     lower:=range(2,1);upper:=range(2,2);
     if numberp(tmp:=j2+j1-j3) then upper:=tmp;
     if numberp(tmp:=j2-m2) then
                 if upper = infinity then
                         upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j1+m1) then
                 if upper = infinity then
                         upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j3+j1+m2) then lower = max(lower,-tmp);
     if numberp(tmp:=j1-j2-m1) then lower = max(lower,-tmp);
     range(2,1):=lower;range(2,2):=upper;
     if upper neq infinity then
      << tmp:=upper-lower+1;
      if (better = infinity) or (better > tmp) then
                         << better:=tmp;best:=2 >> >>;

     % {j1,m1} <-> {j3,m3};

     lower:=range(3,1);upper:=range(3,2);
     if numberp(tmp:=j3+j2-j1) then upper:=tmp;
     if numberp(tmp:=j3-m3) then
                if upper = infinity then
                         upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j2+m2) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j1+j2+m3) then lower = max(lower,-tmp);
     if numberp(tmp:=j2-j3-m2) then lower = max(lower,-tmp);
     range(3,1):=lower;range(3,2):=upper;
     if upper neq infinity then
      << tmp:=upper-lower+1;
      if (better = infinity) or (better > tmp) then
                 << better:=tmp;best:=3 >> >>;

     % {j2,m2} <-> {j3,m3};

     lower:=range(4,1);upper:=range(4,2);
     if numberp(tmp:=j1+j3-j2) then upper:=tmp;
     if numberp(tmp:=j1-m1) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j3+m3) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j2+j3+m1) then lower = max(lower,-tmp);
     if numberp(tmp:=j3-j1-m3) then lower = max(lower,-tmp);
     range(4,1):=lower;range(4,2):=upper;
     if upper neq infinity then
      << tmp:=upper-lower+1;
      if (better = infinity) or (better > tmp) then
                         << better:=tmp;best:=4 >> >>;

     % {j1,m1} -> {j2,m2} -> {j3,m3} -> {j1,m1};

     lower:=range(5,1);upper:=range(5,2);
     if numberp(tmp:=j2+j3-j1) then upper:=tmp;
     if numberp(tmp:=j2-m2) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j3+m3) then
                if upper = infinity
                        then upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j1+j3+m2) then lower = max(lower,-tmp);
     if numberp(tmp:=j3-j2-m3) then lower = max(lower,-tmp);
     range(5,1):=lower;range(5,2):=upper;
     if upper neq infinity then
      << tmp:=upper-lower+1;
      if (better = infinity) or (better > tmp) then
                         << better:=tmp;best:=5 >> >>;

     % {j1,m1} -> {j3,m3} -> {j2,m2} -> {j1,m1};

     lower:=range(6,1);upper:=range(6,2);
     if numberp(tmp:=j3+j1-j2) then upper:=tmp;
     if numberp(tmp:=j3-m3) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j1+m1) then
                if upper = infinity then
                        upper:=tmp else upper:=min(upper,tmp);
     if numberp(tmp:=j2+j1+m3) then lower = max(lower,-tmp);
     if numberp(tmp:=j1-j3-m1) then lower = max(lower,-tmp);
     range(6,1):=lower;range(6,2):=upper;
     if upper neq infinity then
      << tmp:=upper-lower+1;
      if (better = infinity) or (better > tmp) then
                << better:=tmp;best:=6 >> >>;

     if best = 1 then return !*3j!-symbol!:sign!*(j1-j2-m3)
      * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j1,j2,j3,m1,m2,m3)
           else  - !*3j!-symbol!:one!-term!*(k,j1,j2,j3,m1,m2,m3))

     else if best = 2 then
        return !*3j!-symbol!:sign!*((j1+j2+j3)+j2-j1-m3)
         * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j2,j1,j3,m2,m1,m3)
           else  - !*3j!-symbol!:one!-term!*(k,j2,j1,j3,m2,m1,m3))

     else if best = 3 then
        return !*3j!-symbol!:sign!*((j1+j2+j3)+j3-j2-m1)
         * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j3,j2,j1,m3,m2,m1)
           else  - !*3j!-symbol!:one!-term!*(k,j3,j2,j1,m3,m2,m1))

     else if best = 4 then
        return !*3j!-symbol!:sign!*((j1+j2+j3)+j1-j3-m2)
         * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j1,j3,j2,m1,m3,m2)
           else - !*3j!-symbol!:one!-term!*(k,j1,j3,j2,m1,m3,m2))

     else if best = 5 then
        return !*3j!-symbol!:sign!*(j2-j3-m1) * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j2,j3,j1,m2,m3,m1)
           else - !*3j!-symbol!:one!-term!*(k,j2,j3,j1,m2,m3,m1))

     else if best = 6 then
        return !*3j!-symbol!:sign!*(j3-j1-m2) * clean_up_sqrt(
         for k:=range(best,1):range(best,2) sum
          if evenp(k)
            then !*3j!-symbol!:one!-term!*(k,j3,j1,j2,m3,m1,m2)
           else  - !*3j!-symbol!:one!-term!*(k,j3,j1,j2,m3,m1,m2))

     else return lisp lpri list("ThreeJSymbol({",
                               second u1,",",third u1,
                               "},{",
                               second u2,",",third u2,
                               "},{",
                               second u3,",",third u3,
                               "}) % symbol best left as is;")
   >>
  end
 else
  " the argument must be of the form: {j1,m1},{j2,m2},{j3,m3}"$

algebraic procedure !*3j!-symbol!:sign!* u;
   if rounded then (-1)^u else (-1)^(remainder(num u,2*den u)/(den u))$

algebraic procedure !*3j!-symbol!:one!-term!*(k,j1,j2,j3,m1,m2,m3);
 sqrt(simplify_factorial(
  (  factorial(j1+j2-j3)
    *factorial(j3+j1-j2)
    *factorial(j2+j3-j1)
    *factorial(j1+m1)
    *factorial(j1-m1)
    *factorial(j2+m2)
    *factorial(j2-m2)
    *factorial(j3+m3)
    *factorial(j3-m3)
  )/(factorial(j1+j2+j3+1)
    *(factorial(k)
     *factorial(j1+j2-j3-k)
     *factorial(j3-j2+m1+k)
     *factorial(j3-j1-m2+k)
     *factorial(j1-m1-k)
     *factorial(j2+m2-k)
     )^2
  )
 ))$

algebraic <<

 operator clebsch_gordan;

let clebsch_gordan({~j1,~m1},{~j2,~m2},{~j3,~m3}) =>
       ThreeJSymbol ({~j1,~m1},{~j2,~m2},{~j3, - ~m3}) *
       (2*j3+1)^(1/2) * (-1)^(j1-j2+m3);

% The 6 J symbol
% The naming of the functions follows Landolt-Boernstein

operator SixJSymbol;

let { SixJSymbol({~j1,~j2,~j3} , {~l1,~l2,~l3}) =>
       (begin scalar nnn,mmm,!*factor,!*exp,signum;
       % necessary conditions for existence

       if (necess_6j (j1,j2,j3,l1,l2,l3) = nil) then return nil;
       on factor;
       mmm := Racah_W(j1,j2,j3,l1,l2,l3);
       nnn :=
        square_Racah_delta(j1,j2,j3) * square_Racah_delta(j1,l2,l3)*
        square_Racah_delta(l1,j2,l3) * square_Racah_delta(l1,l2,j3)
        * mmm^2;
       nnn := simplify_factorial (nnn);
       signum := sign mmm;
       if numberp signum then return (signum * sqrt nnn)
          else return (sign nnn * sqrt nnn); end)};

procedure square_Racah_delta(a,b,c);
  simplify_factorial(factorial(a+b-c) *factorial(a-b+c)
                * factorial(-a +b +c) / factorial (a + b + c +1));

procedure Racah_W(j1,j2,j3,l1,l2,l3);
 begin scalar mini,maxi,interv;

    mini := min(j1+j2+l1+l2,j2+j3+l2+l3,j3+j1+l3+l1);
    maxi := max(0,j1+j2+j3,j1+l2+l3,l1+j2+l3,l1+l2+j3);

  aaa:
    if numberp (mini - maxi) then
        return for k:=maxi:mini sum
               ((-1)^k*simplify_factorial (factorial (k+1) /
               (factorial (k-j1-j2-j3)*
                factorial (k-j1-l2-l3) *
                factorial (k-l1-j2-l3) *
                factorial (k-l1-l2-j3)*
                factorial (j1+j2+l1+l2-k)*
                factorial (j2+j3+l2+l3-k)*
                factorial (j3+j1+l3+l1-k))))
        else <<
             interv :=findinterval (j1,j2,j3,l1,l2,l3);
             if interv = {} then
              return
               sum((-1)^k* simplify_factorial
                (factorial (k+1) /
               (factorial (k-j1-j2-j3)*
                factorial (k-j1-l2-l3) *
                factorial (k-l1-j2-l3) *
                factorial (k-l1-l2-j3)*
                factorial (j1+j2+l1+l2-k)*
                factorial (j2+j3+l2+l3-k)*
                factorial (j3+j1+l3+l1-k))),k,maxi,mini)
             else        <<
               maxi := first first interv;
               mini := second first interv + maxi;
               go to aaa >>;
            >>;
 end;

% conditions for non vanishing 6j symbol see Landolt/Boernstein

procedure necess_6j(j1,j2,j3,l1,l2,l3);

 begin scalar nnn, !*rounded, dmode!*;
     off rounded;
     nnn := j1 + j2 + j3;
     if (numberp nnn) then if not fixp nnn then return nil;
     nnn := l1 + l2 + j3;
     if (numberp nnn) then if not fixp nnn then return nil;
     nnn := j1 + l2 +l3;
     if (numberp nnn) then if not fixp nnn then return nil;
     nnn := l1 + j2 +l3;
     if (numberp nnn) then if not fixp nnn then return nil;

     if not numberp j1 or  not numberp j2 or  not numberp j3
        or not numberp l1 or not numberp l2 or not numberp l3
        then return t; % don't know

 % Triangle condtions

     if  j1 + j2 - j3 >=0 and   j1 - j2 + j3 >=0 and
        -j1 + j2 + j3 >=0 and   l1 + l2 - j3 >=0 and
         l1 - l2 + j3 >=0 and  -l1 + l2 + j3 >=0 and
         j1 + l2 - l3 >=0 and   j1 - l2 + l3 >=0 and
        -j1 + l2 + l3 >=0 and   l1 + j2 - l3 >=0 and
         l1 - j2 + l3 >=0 and  -l1 + j2 + l3 >=0 then return t;
    end;

procedure aconds!-6j(j1,j2,j3,l1,l2,l3);

   { % Triangle condtions
     j1 + j2 - j3 >=0,      j1 - j2 + j3 >=0,
    -j1 + j2 + j3 >=0,
     l1 + l2 - j3 >=0,      l1 - l2 + j3 >=0,
    -l1 + l2 + j3 >=0,
     j1 + l2 - l3 >=0,      j1 - l2 + l3 >=0,
    -j1 + l2 + l3 >=0,
     l1 + j2 - l3 >=0,      l1 - j2 + l3 >=0,
    -l1 + j2 + l3 >=0,

     % condtions for the summation index

     !=k +1 >= 0,
     !=k-j1-j2-j3 >=0,
     !=k-j1-l2-l3 >=0,
     !=k-l1-j2-l3 >=0,
     !=k-l1-l2-j3 >=0,
     j1+j2+l1+l2-!=k >=0,
     j2+j3+l2+l3-!=k >=0,
     j3+j1+l3+l1-!=k >=0};

% same in Edmonds formulation

procedure conds!-6j(j1,j2,j3,l1,l2,l3);

   { % Triangle condtions
     j1 + j2 - j3 >=0,      j1 - j2 + j3 >=0,
    -j1 + j2 + j3 >=0,
     l1 + l2 - j3 >=0,      l1 - l2 + j3 >=0,
    -l1 + l2 + j3 >=0,
     j1 + l2 - l3 >=0,      j1 - l2 + l3 >=0,
    -j1 + l2 + l3 >=0,
     l1 + j2 - l3 >=0,      l1 - j2 + l3 >=0,
    -l1 + j2 + l3 >=0,

     % condtions for the summation index

     !=k >= 0,
     j1 + j2 + l1 + l2 + 1 -!=k >=0,
     j1 + j2 -j3 -!=k >=0,
     l1 + l2 - j3 -!=k >=0,
     j1 + l2 - l3 -!=k >=0,
     l1 + j2 -l3 -!=k >=0,
    -j1 -l1 + j3 + l3 + !=k >=0,
    -j2 -l2 + j3 + l3 + !=k >=0};

% conditions for non vanishing 3j symbol see Landolt/Boernstein

procedure conds!-3j (j1,j2,j3,m1,m2,m3);

 { m1 + m2 + m3 =0,
   j1 + j2 - j3 >=0,
   j1 - j2 + j3 >=0,
  -j1 + j2 + j3 >=0,
   !=k >=0,
   j1 + j2 -j3 -!=k >=0,
   j1 - m1 -!=k >=0,
   j3 + m2 -!=k >=0,
   j3 -j2 + m1 + !=k >=0,
   j3 - j1 -m2 + !=k >=0};

% Trying to find the approroate intervals for the summation in the
% 6j symbol computation using the ineq package by Herbert Melenk

procedure findinterval(j1,j2,j3,l1,l2,l3);
 begin scalar interv,svars;
  svars := lisp( 'list .
                solvevars list(simp j1,simp j2,simp j3,
                                simp l1, simp l2,simp l3));
  interv :=reverse
                ineq_solve(aconds!-6j(j1,j2,j3,l1,l2,l3)
                        ,!=k . svars,record=t);
  return findinterval1(part(first interv),0);
 end;
>>;

symbolic procedure findinterval1(maxis,minis);
(<<
  if eqcar(maxis,'equal) and cadr maxis eq '!=k then
      maxis := caddr maxis;

  if not eqcar(maxis,'!*interval!*) then
         list('list,list('list,maxis , 0))
  else <<
  minis := caddr maxis;
  maxis := cadr maxis;
  if eqcar(maxis,'max) then
                 maxis := cdr maxis else maxis := list maxis;
  if eqcar(minis,'min) then
                 minis := cdr minis else minis := list minis;
  foreach xx in maxis do
     foreach yy in minis do
        if numberp (difff :=reval list('difference,yy,xx)) then
                fixedints := {'list,xx,difff} . fixedints;
  'list  . fixedints
      >>
 >>) where fixedints = nil , difff = nil;

flag('(findinterval1),'opfn);

symbolic procedure fancy!-clebsch_gordon(u);
  begin scalar a,j1,m1,j2,m2,j,m;
    u:=cdr u; j1:=cadr car u; m1:=caddr car u;
    u:=cdr u; j2:=cadr car u; m2:=caddr car u;
    u:=cdr u; j :=cadr car u; m :=caddr car u;
    a:={j1,m1,j2,m2,'!|,j1,j2,j,m};
    return fancy!-in!-brackets(
       {'fancy!-inprint, mkquote 'times,0,mkquote a},
         '!(,'!));
  end;

put('clebsch_gordon,'fancy!-prifn, 'fancy!-clebsch_gordon);

symbolic procedure fancy!-ThreeJSymbol(u);
     fancy!-matpri2({cdr cadr u,cdr caddr u},nil,nil);

put('ThreeJSymbol,'fancy!-prifn, 'fancy!-ThreeJSymbol);

symbolic procedure fancy!-SixJSymbol(u);
     fancy!-matpri2({cdr cadr u,cdr caddr u},nil,'("{" . "}"));

put('SixJSymbol,'fancy!-prifn, 'fancy!-SixJSymbol);

symbolic procedure fancy!-NineJSymbol(u);
     fancy!-matpri2({cdr cadr u,cdr caddr u, cdr cadddr u},nil,
          '("{" . "}"));

put('NineJSymbol,'fancy!-prifn, 'fancy!-NineJSymbol);

endmodule;

end;






mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/ratalgo.red0000644000175000017500000000617111526203062024114 0ustar  giovannigiovannimodule ratalgo;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% rational algorithm for FPS package

algebraic procedure Complexapart(f,x);

    begin scalar !*factor,!*complex;
        on factor,complex;
        x := pf(f,x);
        off factor,complex;
        return x;
   end;

algebraic procedure ratalgo(p,x);
     begin scalar afp,tt,S,ak,d,c,j,ss;
     afp := Complexapart(p,x);

     S:= 0; ak := 0;

     if symbolic !*traceFPS then write " Rational Algorithm applied";

     foreach tt in afp do
        << if freeof(tt,x) then S := S + tt else
           <<
           d := 1/tt;
           if not polynomq(d,x) then <<
                if symbolic !*traceFPS then write
                         " Rational Algorithm  failed";
                S := -1 >>;
          if not (S = -1) then
          <<
           d := d/lcof(d,x); c := d * tt;
           J := deg(d,x);
           d := expt(d,1/j);
           if not polynomq(d,x) then <<
                if symbolic !*traceFPS then write
                        " Rational Algorithm  failed";
                afp := {}; d :=12;
                S := -1 >>;
           if d = x then S := S + c/d^j  else
                <<
                ss := lcof(d,x);
                d := d /ss; c := c / ss;
                xk := x -d; c:= c*(-1)^j/xk ^j;
                ak  := ak +
                   c*simplify_factorial(factorial(j + k -1)/
                        factorial(k)/factorial(j-1))/xk^k;
        >> >> >> >>;
        if S = -1 then return (-1);
        return S := S + infsum(ak*x^k,k,0,infinity)
    end;

symbolic procedure fastpart(x,n);
        reval nth( x,n +1);

flag ('(fastpart fastlength),'opfn);

symbolic procedure fastlength(x);
        length (x) -1;

symbolic procedure auxcopy(u);
   if pairp u then cons (auxcopy car u, auxcopy cdr u) else u;

% for XR

if getd 'print_format then
        print_format('(pochhammer u v),'(!( u !) !_ v));

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfgen.red0000644000175000017500000001122211526203062023556 0ustar  giovannigiovannimodule sfgen;   % Handy functions used by the special functions package.

% Author: Chris Cannam.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


exports sq2bf!*,bfprin!:roundup,sf!*eval;

symbolic procedure sf!*assoc(compare,val,alist);
   (if null alist then nil
    else if not lispeval list(compare,car car alist,val)
               then car alist
               else sf!*assoc(compare,val,cdr alist));

symbolic procedure sf!*multi!*assoc!*comparator(compare,vals,entry);
   (if null entry
    then (null vals)
    else (not null vals)
      and (lispeval list(compare,list('quote,car vals),
                                                         list('quote,car entry)))
      and (sf!*multi!*assoc!*comparator(compare,cdr vals,cdr entry)));

symbolic procedure sf!*multi!*assoc(compare,vals,alist);
   (if null alist then nil
    else if sf!*multi!*assoc!*comparator(compare,vals,car car alist)
               then car alist
               else sf!*multi!*assoc(compare,vals,cdr alist));

symbolic procedure sf!*do!*eval(expression);
   begin scalar prepre, result;
      prepre := precision 0;
      precision (prepre + 3);
      result := aeval expression;
      precision prepre;
      return result;
   end;


% It's a finite state automaton!  It's a big nested if..then..else
% construct!  It's repulsive repetitive code!  It's easy to compile
% and run quickly!  It's longer than it needs to be!  It's all of
% this and more...!   (But at least it works.)

symbolic procedure sf!*eval(name,args);
   begin scalar part1, part2, result;
      args := cdr args;
      if (part1 := assoc((name . !*complex),sf!-alist))
      then if (part2 := sf!*assoc('lessp,c!:prec!:(),cdr part1))
           then if (result :=
                       sf!*multi!*assoc('evalequal,args,cdr part2))
                      then result := cdr result
                             else if !*savesfs
                                  then setq(cdr part2,
                          (args . (result := sf!*do!*eval(name . args)))
                                              . cdr part2)
                                  else result := sf!*do!*eval(name . args)
                 else if !*savesfs
                      then setq(cdr part1,
                                   (c!:prec!:()
                                      . list ((args .
                                                (result := sf!*do!*eval(name . args)))))
                                    . cdr part1)
                      else result := sf!*do!*eval(name . args)
      else if !*savesfs
                 then sf!-alist :=
                       ((name . !*complex) .
                               list ((c!:prec!:() .
                                    list ((args .
                                                (result := sf!*do!*eval(name . args))
                                               ))))) . sf!-alist
                 else result := sf!*do!*eval(name . args);
      return result;
   end;

algebraic procedure complex!*off!*switch;
   if symbolic !*complex then
      if symbolic !*msg then
         << off msg; off complex; on msg >>
      else off complex
   else t;

algebraic procedure complex!*restore!*switch(fl);
   if not fl then
      if symbolic !*msg then
         << off msg;
            if symbolic !*complex then
               off complex
            else on complex;
            on msg >>
      else if symbolic !*complex then
            off complex
         else on complex;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn2.hlp0000644000175000017500000000303611526203062024031 0ustar  giovannigiovanni\chapter{SPECFN2: Package for special special functions}
\label{SPECFN2}
\typeout{{SPECFN2: Package for special special functions}}

{\footnotesize
\begin{center}
Victor S. Adamchik \\
Byelorussian University \\
Minsk, Belorus \\[0.1in]
and\\[0.05in]
Winfried Neun \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
e--mail: neun@sc.ZIB--Berlin.de

\end{center}
}
\ttindex{SPECFN2}
\index{Generalised Hypergeometric functions}
\index{Meijer's G function}

The (generalised) hypergeometric functions  

\begin{displaymath}
_pF_q \left( {{a_1, \ldots , a_p} \atop {b_1, \ldots ,b_q}} \Bigg\vert z \right)
\end{displaymath}

are defined in textbooks on special functions.
\section{\REDUCE{} operator HYPERGEOMETRIC}

The operator {\tt hypergeometric} expects 3 arguments, namely the 
list of upper parameters (which may be empty), the list of lower
parameters (which may be empty too), and the argument, e.g:

\begin{verbatim}

hypergeometric ({},{},z);

 Z
E

hypergeometric ({1/2,1},{3/2},-x^2);

 ATAN(X)
---------
    X
\end{verbatim}


\section{Enlarging the HYPERGEOMETRIC operator}

Since hundreds of particular cases for the generalised hypergeometric
functions can be found in the literature, one cannot expect that all
cases are known to the {\tt hypergeometric} operator.
Nevertheless the set of special cases can be augmented by adding
rules to the \REDUCE{} system, {\em e.g.}
\begin{verbatim}
let {hypergeometric({1/2,1/2},{3/2},-(~x)^2) => asinh(x)/x};
\end{verbatim}

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfpsi.red0000644000175000017500000005661411526203062023616 0ustar  giovannigiovannimodule sfpsi; % Procedures relevant to the digamma, polygamma & zeta
              % functions.

% Author: Chris Cannam, Sept/Oct '92.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Added: PSI_SIMP.RED  F.J.Wright, 2 July 1993
%        The polygamma rules are added by Y.K. Man on 9 July 1993

%        Yiu K. Man's email is: myk@maths.qmw.ac.uk

imports sq2bf!*, sf!*eval;
exports do!*psi, do!*polygamma, do!*trigamma!*halves,
   do!*zeta, do!*zeta!*pos!*intcalc;


%
% A couple of global values are used (from specfns.red) which can speed
% up psi calculations (a bit) when repeated calculations are made at the
% same level of precision.

fluid '(compute!-bernoulli);


%
% Here's an approximation sufficiently good for most purposes
%   (assuming it's right, that is); if it isn't good enough, it
%   won't be used.  This approximation is to 506 dec. places.
%

algebraic (old!*precision := precision(0));
precision 510;

algebraic procedure get!-eulers!-constant;
   begin scalar a;
      a := 577215664901532860606512090082402431 * 10^40 +
                       0421593359399235988057672348848677267776;
      a := a * 10^40 + 6467093694706329174674951463144724980708;
      a := a * 10^40 + 2480960504014486542836224173997644923536;
      a := a * 10^40 + 2535003337429373377376739427925952582470;
      a := a * 10^40 + 9491600873520394816567085323315177661152;
      a := a * 10^40 + 8621199501507984793745085705740029921354;
      a := a * 10^40 + 7861466940296043254215190587755352673313;
      a := a * 10^40 + 9925401296742051375413954911168510280798;
      a := a * 10^40 + 4234877587205038431093997361372553060889;
      a := a * 10^40 + 3312676001724795378367592713515772261027;
      a := a * 10^40 + 3492913940798430103417771778088154957066;
      a := a * 10^30 + 107501016191663340152278935868;
      a := a * (10**(-506));
      return a
   end;

algebraic (euler!*constant := get!-eulers!-constant());

algebraic precision old!*precision;
algebraic clear old!*precision;


%
% Define some suitable rules for initial simplification of psi
%   (digamma) function expressions.
%
% Comments:
%
%  When rounded mode is on, psi(number) is always computed
%     directly unless it simplifies to an expression in psi(1/2) or
%     psi(1), in which case it is simplified. Expressions in psi(1/2)
%     and psi(1) are expanded into expressions in euler!*constant.
%     If, however, the precision is greater than 500, then
%     euler!*constant is not stored sufficiently precisely, and all
%     such expressions will be computed without simplification.
%
% When rounded mode is off, psi(number) will _never_ be expanded
%     into an expression involving euler!*constant, but will always
%     be expanded into some form involving psi(p), where 0 polygamma(x,xx),

   psi(~z)  =>  infinity
      when repart z = floor repart z and impart z = 0 and z < 1,

   psi(~z)  =>  -euler!*constant
      when numberp z and z = 1
               and symbolic !*rounded and precision(0) < 501,

   psi(~z)  =>  -euler!*constant - 2 * log(2)
      when numberp z and z = (1/2)
               and symbolic !*rounded and precision(0) < 501,

   psi(~z)  =>  do!*psi(z)
      when numberp z and impart z = 0 and symbolic !*rounded,

   psi(~z)  =>  (psi(z/2) + psi((z+1)/2) + 2 * log(2)) / 2
      when numberp z and impart z = 0
               and (z/2) = floor (z/2)
                  and z > 0 and not symbolic !*rounded,

   psi(~z)  =>  psi(z-1) + (1 / (z-1))
      when numberp z and impart z = 0
               and z > 1 and not symbolic !*rounded,

   psi(~z)  =>  psi(1-z) + pi*cot(pi*(1-z))
      when numberp z and impart z = 0
               and z < 0 and not symbolic !*rounded,

   psi(~z)  =>  psi(1-z) + pi*cot(pi*(1-z))
      when numberp z and impart z = 0
         and z > 1/2 and z < 1 and not symbolic !*rounded,

   df(psi(~z),z)  =>  polygamma(1, z),

   int(psi(~z),z)  =>  log gamma(~z)

})$

algebraic (let psi!*rules);


% PSI_SIMP.RED  F.J.Wright, 2 July 1993
% The polygamma rules are added by Y.K. Man on 9 July 1993

% Support for the psi operator.
% =============================
% psi(x) = df(log Gamma(x), x) as in specfn package, etc.
% The specfn package does not currently provide the required
% simplifications.

algebraic;

% Simplify to "standard form" in which argument is allowed a numeric
% shift in the range 0 <= shift < 1:

psi_rules := {
   % Rule for integer shifts (x + 3), and non-integer shifts (x + 3/2)in
   % a non-integer number domain (on rational) or with "on intstr, div":
   psi(~x+~n) => psi(x+n-1) + 1/(x+n-1) when numberp n and n >= 1,
   psi(~x+~n) => psi(x+n+1) - 1/(x+n) when numberp n and n < 0,
   polygamma(~m,~x+~n) => polygamma(m,x+n-1)+(-1)^m*factorial(m)
        /(x+n-1)^(m+1) when numberp n and fixp m and n >= 1,
   polygamma(~m,~x+~n) => polygamma(m,x+n+1)-(-1)^(m)*factorial(m)
        /(x+n)^(m+1) when numberp n and fixp m and n < 0,
   % Rule for rational shifts (x + 3/2) in the default (integer) number
   % domain and rational arguments (x/y + 3):
   psi((~x+~n)/~d) => psi((x+n-d)/d) + d/(x+n-d) when
      numberp(n/d) and n/d >= 1,
   psi((~x+~n)/~d) => psi((x+n+d)/d) - d/(x+n) when
      numberp(n/d) and n/d < 0,
   polygamma(~m,(~x+~n)/~d) => polygamma(m,(x+n-d)/d) +
      (-1)^m*factorial(m)*d^(m+1)/(x+n-d)^(m+1) when
      fixp m and numberp(n/d) and n/d >= 1,
   polygamma(~m,(~x+~n)/~d) => polygamma(m,(x+n+d)/d) -
      (-1)^m*factorial(m)*d^(m+1)/(x+n)^(m+1) when
      fixp m and numberp(n/d) and n/d < 0
};
% NOTE: The rational-shift rule does not work with "on intstr, div".

let psi_rules;

symbolic;

%
% Rules for initial manipulation of polygamma functions.
%

symbolic (operator polygamma!*calc, trigamma!*halves, printerr,
        polygamma_aux);


symbolic procedure printerr(x); rederr x;

algebraic procedure polygamma_aux(n,m);
        for ii:=1:(n-1) sum (1/ii**(m+1));

algebraic (polygamma!*rules := {

   polygamma(~n,~x)  =>  printerr
                 "Index of Polygamma must be an integer >= 0"
        when numberp n and (not fixp n or n < -1),

   polygamma(~n,~x)  =>  psi(x)
      when numberp n and n = 0,

   polygamma(~n,~x)  =>  infinity
      when numberp x and impart x = 0 and x = floor x and x < 1,

   polygamma(~n,~x)  =>  do!*trigamma!*halves(x)
      when numberp n and n = 1 and numberp x and impart x = 0
               and (not (x = floor x) and ((2*x) = floor (2*x))) and x > 1,

   polygamma(~n,~x)  =>  ((-1) ** (n)) * (factorial n) * (- zeta(n+1) +
                         polygamma_aux(x,n))
      when fixp x and x >= 1 and not symbolic !*rounded,

   polygamma(~n,~x)  => ((-1)**n) * factorial n * (-2 * (2**n) *
               zeta(n+1) + 2 * (2**n) + zeta(n+1))
      when numberp x and x = (3/2) and not symbolic !*rounded,

   polygamma(~n,~x)  =>  do!*polygamma(n,x)
      when numberp x and symbolic !*rounded
               and numberp n and impart n = 0 and n = floor n,

   df(polygamma(~n,~x), ~x)  =>  polygamma(n+1, x),

   int(polygamma(~n,~x),~x)  =>  polygamma(n-1,x)

})$

algebraic (let polygamma!*rules);



%
% Set up rules for the initial manipulation of zeta.
%
% Comments:
%
%     Zeta of positive even numbers and negative odd numbers
%     is evaluated (in terms of pi) always when its argument
%     has magnitude less than 31, and only in rounded mode
%     otherwise.  (This is because the coefficients get a bit
%     big when the argument is over about 30.)
%

algebraic operator zeta;
symbolic (operator zeta!*calc, zeta!*pos!*intcalc);


algebraic (zeta!*rules := {

   zeta(~x)  =>  (- (1/2))
      when numberp x and x = 0,

   zeta(~x)  =>  (pi ** 2) / 6
      when numberp x and x = 2,

   zeta(~x)  =>  (pi ** 4) / 90
      when numberp x and x = 4,

   zeta(~x)  =>  infinity
      when numberp x and x = 1,

   zeta(~x)  =>  0
      when numberp x and impart x = 0 and x < 0 and (x/2) = floor(x/2),

   zeta(~x)  =>  ((2*pi)**x) / (2*factorial x)*(abs bernoulli!*calc x)
      when numberp x and impart x = 0 and x > 0
               and (x/2) = floor (x/2) and x < 31,

   zeta(~x)  =>  - (bernoulli!*calc (1-x)) / (2*x)
      when numberp x and impart x = 0 and x < 0
               and x = floor x and x > -31,

   zeta(~x)  =>  ((2*pi)**x)/(2 * factorial x)*(abs bernoulli!*calc x)
      when numberp x and impart x = 0 and x > 0
               and (x/2) = floor(x/2) and x < 201 and symbolic !*rounded,

   zeta(~x)  =>  - (bernoulli!*calc (1-x)) / (1-x)
      when numberp x and impart x = 0 and x < 0
               and x = floor x and x > -201 and symbolic !*rounded,

   zeta(~x)  =>  (2**x)*(pi**(x-1))*sin(pi*x/2)*gamma(1-x)*zeta(1-x)
      when numberp x and impart x = 0 and x < 0
               and (x neq floor x or x < -200) and symbolic !*rounded,

   zeta(~x)  =>  do!*zeta!*pos!*intcalc(fix x)
      when symbolic !*rounded and numberp x and impart(x) = 0 and x > 1
               and x = floor x and (x <= 15 or precision 0 > 100
                  or 2*x < precision 0),

   zeta(~x)  =>  do!*zeta(x)
      when numberp x and impart x = 0% and x > 1
               and symbolic !*rounded,

   df(zeta(~x),x)  =>  -(1/2)*log(2*pi)
      when numberp x and x = 0

})$

algebraic (let zeta!*rules);



algebraic procedure do!*psi(z);
   algebraic sf!*eval('psi!*calc,{z});

algebraic procedure do!*polygamma(n,z);
   algebraic sf!*eval('polygamma!*calc,{n,z});

algebraic procedure do!*trigamma!*halves(z);
   algebraic sf!*eval('trigamma!*halves,{z});

algebraic procedure do!*zeta(z);
   (if z <= 1.5 and precision(0) <= floor(4+3*z)
    then raw!*zeta(z)
    else if (3*z) > (10*precision(0)) then 1.0
    else if z > 100 then algebraic sf!*eval('zeta!*calc,{z})
    else algebraic sf!*eval('zeta!*general!*calc,{z}));

algebraic procedure do!*zeta!*pos!*intcalc(z);
   algebraic sf!*eval('zeta!*pos!*intcalc,{z});



%
% algebraic procedure psi!*calc(z);
%
%     Compute a value of psi. Works by first computing the
%     smallest positive integral x at which psi(x) is easily
%     computable to the current precision using no more
%     than the first 200 bernoulli numbers, then scaling up
%     the given argument (if necessary) so that it can be
%     computed, scaling down again afterwards.
%
%     Does not work for complex arguments.
%

algebraic procedure psi!*calc(z);
   begin scalar result, admissable, bern300, alglist!*, precom;
      integer prepre, scale, lowest;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if prepre < !!nfpd then precision (!!nfpd + 1);
      admissable := (1 / (10 ** prepre)) / 2;
      if prepre = psi!*ld(0) then lowest := psi!*ld(1)
      else
               << bern300 := abs bernoulli!*calc 300;
                  lowest := 1 +
                     symbolic conv!:bf2i exp!:
                               (divbf(log!:(divbf(sq2bf!* bern300,
                                          timbf(i2bf!: 150,
                                             sq2bf!* admissable)), 4),
                     i2bf!: 300), 3);  % Use symbolic mode so as to
                                    % force less accuracy for more speed
                  psi!*ld(0) := prepre;
                  psi!*ld(1) := lowest >> ;
      if lowest>repart z then scale := ceiling(lowest - repart z) + 20;
      z := z + scale;
      result := algebraic symbolic psi!*calc!*sub(z, scale, admissable);

      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;


symbolic procedure psi!*calc!*sub(z, scale, admissable);
   begin scalar result, zsq, zsqp, this, bk;
      integer k, orda, rp; k := 2;
      z := sq2bf!* z;
      admissable := sq2bf!* admissable;
      zsq := timbf(z,z); zsqp := zsq;
      this := plubf(admissable, bfone!*);
      result := difbf (log!: (z,c!:prec!:()),
               divbf(bfone!*, timbf(bftwo!*, z)));
      orda := order!: admissable - 5; rp := c!:prec!:();
      while greaterp!: (abs!: this, admissable) do
               << bk := sq2bf!* symbolic algebraic bernoulli!*calc k;
                  this := divide!:(bk, timbf(i2bf!: k, zsqp), rp);
                  result := difbf(result, this);
                  k := k + 2; rp := order!: this - orda;
                  zsqp := timbf(zsqp, zsq) >>;
      for n := 1:scale do
               result := difbf(result, divbf(bfone!*, difbf(z, i2bf!: n)));
      return mk!*sq !*f2q mkround result;
   end;




%
% algebraic procedure polygamma!*aux(n,z);
%
%     Used by the procedure below, to implement the Reflection
%     Formula. This obtains an expression for
%                 n
%                d
%                --- ( cot  ( pi * x ) )
%                  n
%                dx
%     and substitutes z for x into it, returning the result.
%

algebraic procedure polygamma!*aux(n,z);
   begin scalar poly;
      clear dummy!*arg;
      poly := cot(pi * dummy!*arg);
      for k := 1:n do poly := df(poly, dummy!*arg);
      dummy!*arg := z;
      return poly;
   end;



%
% algebraic procedure polygamma!*calc(n,z);
%
%     Computes a value of the polygamma function, order n,
%     at z.  N must be an integer, and z must be real.  If
%     z is negative, the Reflection Formula is applied by
%     a call to polygamma!*aux (above); then the positive
%     argument is fed to polygamma!*calc!*s which does the
%     real work.
%

algebraic procedure polygamma!*calc(n,z);
   begin scalar result, z0, prepre, precom;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if prepre < !!nfpd then precision (!!nfpd + 3)
      else precision (prepre + 3 + floor(prepre/50));
      if z > 0 then
               << z0 := z;
                  result := algebraic symbolic polygamma!*calc!*s(n,z0) >>
      else
               << z0 := 1-z;
                  result := ((-1)**n)*(pi*polygamma!*aux(n,z0) +
                     algebraic symbolic polygamma!*calc!*s(n,z0)) >>;
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;




%
% symbolic procedure polygamma!*calc!*s(n,z);
%
%     Implementation of an asymptotic series for the poly-
%     gamma functions.  Computes a scale factor which should
%     (hopefully) provide a minimum argument for which this
%     series is valid at the given order and precision; then
%     computes the series for that argument and scales down
%     again using the Recurrence Formula.
%

symbolic procedure polygamma!*calc!*s(n,z);
   begin scalar result, this, admissable, partial,
         zexp, zexp1, zsq, nfac, nfac1, kfac, rescale, signer, z0;
      integer k, nm1, nm2, rp, orda, min, scale;

      z := sq2bf!* z; signer := i2bf!:((-1)**(n-1));
      admissable := divide!:(bfone!*,i2bf!:(bf!*base**c!:prec!:()),8);

      min := 10 + conv!:bf2i
              exp!:(times!:(divide!:(bfone!*,i2bf!:(300+n),8),
              log!:(divide!:(timbf(round!:mt(i2bf!: factorial(300+n),8),
                  abs!: sq2bf!* symbolic algebraic bernoulli 300),
                times!:(admissable,round!:mt(i2bf!: factorial 300,8)),
                  8),8)),8);     % In which Chris approximates to 8 bits
                                 % and hopes to get away with it...
      scale := min - (1 + conv!:bf2i z);
      if scale < 0 then scale := 0;
      z0 := plubf(z,i2bf!: scale);

      nfac := round!:mt(i2bf!: factorial(n-1),c!:prec!:());
      zexp := texpt!:any(z0,n);
      result := plubf(divbf(nfac,zexp),
         divbf((nfac1 := timbf(i2bf!: n,nfac)),
            timbf(bftwo!*,(zexp1 := timbf(zexp,z0)))));
      nfac := nfac1; zexp := zexp1;

      nm1 := n-1; nm2 := n-2; rp := c!:prec!:();
      nfac := timbf(nfac, i2bf!: (n+1));
      kfac := bftwo!*; zexp := timbf(zexp,z0);
      zsq := timbf(z0,z0);

      partial := divbf(nfac,timbf(kfac,zexp));
      k := 2; orda := order!: admissable - 5;
      this := bfone!*;

      if null compute!-bernoulli then
         <>;

      while greaterp!:(abs!: this, admissable) do
         << result := plubf(result,
               (this := timbf(sq2bf!* retrieve!*bern k,partial)));
            k := k + 2;
            partial := divide!:(timbf(partial,i2bf!:((nm2+k)*(nm1+k))),
               timbf(zsq,i2bf!:((k-1)*k)),rp);
            rp := order!: this - orda >>;

      result := times!:(signer,result);

      if scale neq 0 then
         << rescale := bfz!*;
            nfac := round!:mt(i2bf!: factorial n,c!:prec!:());
            for k := 1:scale do
               <>;
            result := plubf(result,times!:(signer,rescale)) >>;

      return mk!*sq !*f2q mkround result;
   end;


%
% algebraic procedure trigamma!*halves(x);
%
%     Applies a formula to derive the exact value of the trigamma
%     function at x where x = n+(1/2) for n = 1, 2, ...
%

algebraic procedure trigamma!*halves(x);
   begin integer prepre; scalar result, alglist!*;
      result := (1/2) * (pi ** 2) - (4 * (for k := 1:(round (x-(1/2)))
               sum ((2*k - 1) ** (-2))));
      return result;
   end;




%
% algebraic procedure zeta!*calc(s);
%
%     Calculate zeta(s). Only valid for repart(s) > 1.
%
%     This function uses the system !*primelist!* of the first
%     500 primes.  If the system variable disappears or changes,
%     this function is helpless.
%

algebraic procedure zeta!*calc(z);
   begin scalar result, admissable, primelist,
               partialpl, this, modify, spl, alglist!*;
      integer prepre, j, rflag, thisprime, nexti;
      share spl;
      prepre := precision(0);
      precision prepre + 3;
      admissable := (1 / (10 ** (prepre + 2)));

      symbolic (spl := !*primelist!*);
      primelist := {};
      result := 1; modify := 1;
      for k := 1:10 do
               << j := symbolic car spl;
                  symbolic (spl := cdr spl);
                  primelist := (j . primelist);
                  modify := modify * (1 - (1 / (j**z))) >>;
      modify := 1 / modify;

      this := admissable + 1;
      if not symbolic cdr divide (j, 3) then j := j + 2;
      nexti := (if not symbolic cdr divide (j+1, 3) then 2 else 4);
      while ((abs this) > admissable) do
               << rflag := 1; partialpl := primelist;
                  while ((partialpl neq {}) and rflag) do
                     << thisprime := first partialpl;
                               rflag := symbolic cdr divide(j, thisprime);
                               partialpl := rest partialpl >>;
                  if rflag then result := result + (this := (1 / (j**z)));
                  j := j + nexti; nexti := 6 - nexti >>;
      result := result * modify;
      precision prepre;
      return result;
   end;


algebraic procedure zeta!*pos!*intcalc(m);
   (((-1)**m)*polygamma(m-1,3)/factorial(m-1)
      + 1 + (1/(2**m)));


algebraic procedure zeta!*error(z,terms);
   (((-1) ** (terms+2)) / ((terms+1) ** z));


algebraic procedure zeta!*general!*calc(z);
   begin scalar result, zp, admissable, z0;
               integer pre, k;
      pre := precision(0);
      admissable := algebraic symbolic
               (mk!*sq !*f2q mkround divide!:(bfone!*,i2bf!:(10 ** pre),8));
      if (z**2) < admissable
      then result := ((-1/2) - ((log(2*pi))*z)/2)
      else if pre < !!nfpd
                 then begin scalar sstt, stt;
                                sstt := (for k := 2:(pre-1) sum (k**(-z)));
                                precision (!!nfpd + 2);
                         z0 := z; zp := pre**(-z); stt := sstt + 1;
                                result := algebraic symbolic
                     zeta!*general!*calc!*sub(z0,zp,admissable,pre,stt);
                      end
           else <>;
      precision pre;
      return result;
   end;


symbolic procedure zeta!*general!*calc!*sub(z,zp,admissable,pre,stt);
   begin scalar result, prere, this, fac, pre, zk1, zk2, logz;
               integer k;

      z := sq2bf!* z;
      zp := sq2bf!* zp;
      admissable := sq2bf!* admissable;

      if stt = nil then
               << result := bfone!*; k := 1;
                  this := plus!:(admissable,bfone!*);
                  while greaterp!: (abs!: this,admissable) and k < pre-1 do
                     << k := k + 1;
                               this := texpt!:any(i2bf!: k, minus!: z);
                               result := plubf(result, this) >> >>
      else result := sq2bf!* stt;

      pre := i2bf!: pre;
      zk1 := plubf(z,bftwo!*); zk2 := plubf(z,bfone!*);
      result := plubf(result,
               timbf(zp,plubf(bfhalf!*,divbf(pre,difbf(z,bfone!*)))));
      fac := divbf(bfone!*,timbf(pre,pre));
      this := timbf(divbf(z,bftwo!*),divbf(zp,pre));
      result := plubf(result,divbf(this,i2bf!: 6));
      k := 4; prere := plubf(result,bfone!*);

      while greaterp!: (abs!: difbf(prere,result), admissable) do
               << this := divbf(timbf(this,timbf(fac,timbf(zk1,zk2))),
                                            i2bf!:(k*(k-1)));
                  prere := result;
                  result := plubf(result,timbf(
                     sq2bf!* symbolic algebraic bernoulli!*calc k, this));
                  zk1 := plus!:(zk1,bftwo!*);
                  zk2 := plus!:(zk2,bftwo!*);
                  k := k + 2; >>;

      return mk!*sq !*f2q mkround result;
   end;

algebraic array stieltjes (5);  % for use in raw zeta computations
algebraic array stf       (5);
algebraic array psi!*ld   (1);
algebraic (psi!*ld(0) := -1);   % precision at which last psi was calc'd
algebraic (psi!*ld(1) :=  0);   % lowest post-scale value acceptable at
                                % that precision


Stieltjes (0) := 0.577215664901532860606512$ % Euler's constant
Stieltjes (1) := -0.0728158233766$
Stieltjes (2) := -0.00968992187973$
Stieltjes (3) := 0.00206262773281$
Stieltjes (4) := 0.00250054826029$
Stieltjes (5) := 0.00427794456482$
Stf (0) := 1$
Stf (1) := 1$
Stf (2) := 2$
Stf (3) := 6$
Stf (4) := 24$
Stf (5) := 120$

algebraic procedure raw!*zeta(z);
   << z := z-1;
      1/z + (for m := 0:5 sum ((-1)**m * Stieltjes(m) * z**m / Stf(m)))
   >>;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/constre.red0000644000175000017500000001120711526203062024134 0ustar  giovannigiovannimodule constre;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic procedure constantRE(cap_R,leadcoeff,dffpointer,k,x);

% solve  constant RE
%
%   a(k+1) = cap_R(k) * a(k)
%
%  where leadcoeff is the leading coefficient of the RE
%  and DF is a table where DF(dffpointer+i) = df(f,x,i)

  begin scalar denr,fract,ii,m0,m1,c0,ck,S,c,df2,q,r2,lterm,nn,
        s0, leadcoeff2;
        denr := solve(leadcoeff,k);
        m0 := {};
        foreach xx in denr do
                if type_rational rhs xx then  m0 := ((rhs xx)+1) . m0;
        if not(m0 = {}) then m0 := max(m0) else m0 := 0;

        if symbolic !*traceFPS then
                 << write ">>> m0 = ",m0;
                    write "RE is constant";
                    write "RE: for all k >= ",m0,": a (k + 1) = "
                        ,cap_R * a(k);
                    write "leadcoeff := ",leadcoeff; >>;

        fract := {};
        foreach xx in denr do
                if type_fraction(rhs xx) then
                         fract := den(rhs xx) . fract;
        if not(fract = {}) then
                << q := first fract;
                   dff(dffpointer + 10) := sub(x=x^q,dff(dffpointer));
                   if symbolic !*traceFPS then <<
                        write "RE modified to nn= ",k/q;
                        write "=> f := ",dff(dffpointer + 10)>>;
                   S := constantRE(sub(k=k/q,cap_R),
                        sub(k=k/q,leadcoeff),dffpointer + 10,k,x);
                   return sub(x=x^(1/q),S); >>;

        if m0 < 0  then <<
                nn:= -m0 + 1;
                dff(dffpointer + 10) := df2 := x^nn * dff(dffpointer);
                if symbolic !*traceFPS then <<
                        write "working with ",x^nn,"*f";
                        write "=> f :=" ,df2 >>;
                S := constantRE(sub(k=k-nn,cap_R),sub(k=k-nn,leadcoeff),
                                        dffpointer + 10,k,x);
                return update_coeff(S,x,-nn);
        >>;

        if m0 = 0 then <<
                if symbolic !*traceFPS then write "PS does not exist";
                return failed>>;

        if m0 > 0  then <<
        m1 := {};
        foreach xx in denr do if type_rational rhs xx then
                         m1 := append(list (rhs xx +1),m1);
        m1 := min m1;
        if m1 < 0 then <<
                dff(dffpointer + 10) := df2 := x^(-m1)*dff(dffpointer);
        if symbolic !*traceFPS then <<
                        write "working with ",x^(-m1),"*f";
                        write "=> f :=" ,df2 >>;
                S := constantRE(sub(k=k+m1,cap_R),sub(k=k+m1,leadcoeff),
                                        dffpointer + 10,k,x);
                return update_coeff(S,x,m1)
                >>;
        >>;

        % { m1 >= 0 }

        S := 0; S0 := 0;
        for i:=0:m0 do
                <<
                if i > m1 then
                  dff(dffpointer + i) := df(dff(dffpointer + i-1),x);
                c0 := limit(dff(dffpointer + i),x,0);
                if (not numberp c0 and part(c0,0) = limit) then
                        <<  write "Could not find the limit of: "
                                ,dff(dffpointer + i),",",x,",",0;
                    rederr("problem using limit operator") >> else
                <<
                c0 := c0/factorial (i);
                S := S + c0*x^i ;
                if symbolic !*traceFPS then write " S = ",s;
                >> >>;
  return (S);

end;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/ghyper.tex0000644000175000017500000000476511526203062024016 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt ghyper}, a package for simplification of \\
generalized hypergeometric functions}
\date{}
\author{Victor S. Adamchik\\
	Wolfram Research Inc. \\
	former address : \\
	Byelorussian University, Minsk, Byelorussia\\
\\
\\
	Present \REDUCE{} form by \\
	Winfried Neun \\
	ZIB Berlin \\
        Email: {\tt Neun@sc.ZIB-Berlin.de}}
\begin{document}
\maketitle

This note describes the {\tt ghyper} package of \REDUCE{}, which is able
to do simplification of several cases of generalized hypergeometric functions. 
The simplifications are performed towards polynomials, elementary or
special functions or simpler hypergeometric functions.
Therefore this package should be used together with the \REDUCE{}
special function package.

\section{Introduction}

The (generalized) hypergeometric functions  

\begin{displaymath}
_pF_q \left( {{a_1, \ldots , a_p} \atop {b_1, \ldots ,b_q}} \Bigg\vert z \right)
\end{displaymath}

are defined in textbooks on special functions, e.g. in
\cite{Prudnikov:90}. Many well-known functions belong to this class,
e.g. exponentials, logarithms, trigonometric functions and Bessel functions.
In \cite{Graham:89} an introduction into the analysis of sums, basic
identities and applications can be found.

Several hundreds of particular values can be found in \cite{Prudnikov:90}.

\section{\REDUCE{} operator {\tt hypergeometric}}

The operator {\tt hypergeometric} expects 3 arguments, namely the 
list of upper parameters (which may be empty), the list of lower
parameters (which may be empty too), and the argument, e.g:

\begin{verbatim}

hypergeometric ({},{},z);

 Z
E

hypergeometric ({1/2,1},{3/2},-x^2);

 ATAN(X)
---------
    X
\end{verbatim}

\section{Enlarging the {\tt hypergeometric} operator}

Since hundreds of particular cases for the generalized hypergeometric
functions can be found in the literature, one cannot expect that all
cases are known to the {\tt hypergeometric} operator.
Nevertheless the set of special cases can be augmented by adding
rules to the \REDUCE{} system, e.g.

\begin{verbatim}
let {hypergeometric({1/2,1/2},{3/2},-(~x)^2) => asinh(x)/x};
\end{verbatim}

\begin{thebibliography}{9}

\bibitem{Prudnikov:90} A.~P.~Prudnikov, Yu.~A.~Brychkov, O.~I.~Marichev,
{\em Integrals and Series, Volume 3: More special functions},
Gordon and Breach Science Publishers (1990).

\bibitem{Graham:89} R.~L.~Graham, D.~E.~Knuth, O.~Patashnik,
{\em Concrete Mathematics}, Addison-Wesley Publishing Company (1989).

\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfgamm.red0000644000175000017500000004442511526203062023741 0ustar  giovannigiovannimodule sfgamm;   % Gamma function procedures and rules for REDUCE.

% Author: Chris Cannam, Sept/Oct '92

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


imports complex!*on!*switch, complex!*off!*switch,
   complex!*restore!*switch, sf!*eval;

exports do!*gamma, do!*pochhammer, do!*poch!*conj!*calc;

fluid '(COMPUTE!-BERNOULLI intlogrem);

%
%   Rule set for the gamma function.
%

%
% Comments:
%
%   Base cases are provided for gamma(1) and gamma(1/2).
%   The rules will convert gammas to factorials where appropriate.
%   A numerical value is always computed if rounded mode is on.
%

algebraic operator gamma,m_gamma; % m_gamma is the incomplete gamma
 % function which happens to be produced by definite integration.

symbolic (operator do!*gamma);


algebraic (gamma!*rules := {

   gamma(~x)  =>  1 when numberp x and x = 1,
   gamma(~x)  =>  sqrt(pi) when numberp x and x = (1/2),

   gamma(~x)  =>  factorial (x-1)
      when numberp x and impart x = 0
         and x = floor x and x > 0,

%  gamma(~x)  =>  infinity
%     when numberp x and impart x = 0
%        and x = floor x and x < 1,

   gamma(~x)  =>  gamma(x-1) * (x-1)
      when numberp x and not symbolic !*rounded
       and impart x = 0 and (64*x) = floor(64*x) and x > 1 and x < 50,

   gamma(~x)  =>  pi / (sin(pi*x) * gamma(-x) * (-x))
      when numberp x and x < 0 and not (fixp x and x < 1),

   gamma(~x)  =>  do!*gamma(x)
      when numberp x and not (fixp x and x < 1) and symbolic !*rounded,

   df(gamma(~x), x)  =>  gamma(x) * psi(x)

})$

algebraic (let gamma!*rules);


algebraic operator beta;

algebraic (beta!*rules := {

beta(~z,~w)  =>  (gamma(z) * gamma(w)) / gamma(z+w)
   when (numberp z and numberp w and impart z = 0 and impart w = 0
         and not ((z = floor z and z < 1)
               or (w = floor w and w < 1)
               or (z+w = floor (z+w) and (z+w) < 1)))
     or (numberp z and numberp w
         and (impart z neq 0 or impart w neq 0))
     or not (numberp z and numberp w),

beta(~z,~w)  =>  0
   when numberp z and numberp w and impart z = 0 and impart w = 0
      and not ((z = floor z and z < 1)
            or (w = floor w and w < 1))
      and (z+w = floor (z+w) and (z+w) < 1)

%beta(~z,~w)  =>  Infinity
%   when numberp z and numberp w and impart z = 0 and impart w = 0
%      and ((z = floor z and z < 1)
%        or (w = floor w and w < 1))
%      and not (z+w = floor (z+w) and (z+w) < 1)

})$

algebraic (let beta!*rules);



Comment Ruleset for calculating the Pochhammer symbol
        Author:  Wolfram Koepf, Freie Universitaet Berlin 1992,
        Translated to Reduce syntax by Winfried Neun, ZIB Berlin.
        Made generally safer (and uglier) by Chris Cannam, ZIB.
        ;


algebraic operator pochhammer;
symbolic (operator do!*pochhammer, do!*poch!*conj!*calc);

algebraic (pochhammer!*rules := {

df(pochhammer(~z,~k),~z) => pochhammer(~z,~k) * (Psi(z+k)-Psi(z)),

pochhammer(~z,~k)  => (-1)^k*factorial(-z)/factorial(-z-k)
   when fixp z and z<0,

pochhammer(~z,~k)  =>  ( for i:=0:(k-1) product(z + i))
   when numberp k and k < 20 and k > 0,

pochhammer(~z,~k)  =>  1
   when numberp k and k = 0,

pochhammer(~z,~k)  => factorial(z+k-1)/factorial(z-1)
   when fixp z and z > 0,

pochhammer(~z,~k -1)  =>
   2 * pochhammer(1/2,k) / (2*k -1)
      when numberp z and z = 1/2,

pochhammer(~a,~k)  =>
   factorial(2k)/((4^k) * factorial(k))
      when numberp a and a = 1/2,

pochhammer(~n,~k)  =>
   do!*pochhammer(n,k)
      when numberp n and numberp k
         and impart n = 0 and impart k = 0
            and n = floor n and k = floor k
               and n > -1 and k > 0,

pochhammer(~a,~k)  =>
   do!*pochhammer(a,k)
      when symbolic !*rounded
         and numberp k and numberp a
            and impart a = 0 and impart k = 0
               and ((a neq floor a) or (a > 0))
                  and k = floor k and k > 0,

pochhammer(~n,~k)  =>
   (-1)^k * factorial(-n) / factorial(-n-k)
      when numberp n and numberp k
         and impart n = 0
            and n = floor n and n < 1 and (-n-k) >= 0,

pochhammer(~a,~k)  =>
   pochhammer(2*a-1,2k)/((4^k) * pochhammer((2 a -1)/2,k))
      when numberp a and impart a = 0
         and (a+1/2) = floor (a+1/2) and a > 0,

pochhammer(~a,~k)  =>
   (-1)^(-a+1/2) * Pochhammer(1-a-(-a+1/2),(-a+1/2)) *
                   Pochhammer(a+(-a+1/2),k-(-a+1/2))
      when numberp a and impart a = 0
         and (a+1/2) = floor (a+1/2) and a < 0});


algebraic (special!*pochhammer!*rules := {

        % these special rules are normally disabled because
        % they produce a lot of load for the algebraic mode

pochhammer(~a,~k)*pochhammer(~b,~k)  =>
   pochhammer(2a,2k)/(4^k)
      when (b-a)=1/2,

pochhammer(~a,~k)  =>
   (-1)^(-a+1/2) * pochhammer(1-a-(-a+1/2),-a+1/2) *
      pochhammer(a +(-a +1/2),k-(-a+1/2))
         when numberp a and impart a = 0
            and (a+1/2) = floor (a+1/2) and a<0,

pochhammer(~z,~k) * pochhammer(~cz,~k)  =>
   do!*poch!*conj!*calc(z,k)
      when numberp z and numberp cz and numberp k
         and not(impart z = 0) and z = conj cz
            and impart k = 0 and k = floor k and k >= 0,

pochhammer(~a,~k)*pochhammer(~aa,~k)  =>
   factorial(3 k)/(factorial(k) * 27^k)
      when numberp a and a = 1/3 and numberp aa and aa = 2/3,

pochhammer(~a,~k) * pochhammer(~aa,~k)  =>
   factorial(1 + 3 k)/(27 ^k * factorial(k))
      when numberp a and a = 2/3 and numberp aa and aa = 4/3,

pochhammer(~b,~k) * pochhammer(~c,~k)  =>
   pochhammer(3*b,3*k)/( 27^k * pochhammer(b +2/3,k))
      when numberp b and numberp c
         and (c-b)=1/3 and (b-1/3) = floor (b-1/3) and not (b-1/3 = 0),

pochhammer(~a,~k)*pochhammer(~aa,~k)*pochhammer(~aaa,~k)  =>
   factorial(4*k)/(factorial(k) * 64^k)
      when numberp a and numberp aa and numberp aaa
         and a = 1/4 and aa = 1/2 and aaa = 3/4,

pochhammer(~a,~k)*pochhammer(~aa,~k)*
      pochhammer(~aaa,~k)*pochhammer(~aaaa,~k)  =>
   factorial(5*k)/(factorial(k) * 3125^k)
      when numberp a and numberp aa
         and numberp aaa and numberp aaaa
            and a = 1/5 and aa = 2/5 and aaa = 3/5 and aaaa = 4/5,

pochhammer(~a,~k)*pochhammer(~aa,~k)*
      pochhammer(~aaa,~k)*pochhammer(~aaaa,~k)  =>
   5*(1/5 +k)*factorial(5*k)/(factorial(k) * 3125^k)
      when numberp a and numberp aa
         and numberp aaa and numberp aaaa
            and a = 2/5 and aa = 3/5 and aaa = 4/5 and aaaa = 6/5,

pochhammer(~a,~k)*pochhammer(~aa,~k)*
      pochhammer(~aaa,~k)*pochhammer(~aaaa,~k)  =>
   (25 *(1/5+k)*(2/5 +k)*factorial(5*k)) / (factorial(k) * 2* 3125^k)
      when numberp a and numberp aa
         and numberp aaa and numberp aaaa
            and a = 3/5 and aa = 4/5 and aaa = 6/5 and aaaa = 7/5,

pochhammer(~a,~k)*pochhammer(~aa,~k)*
      pochhammer(~aaa,~k)*pochhammer(~aaaa,~k)  =>
   (125*(1/5+k)*(2/5+k)*(3/5+k)*factorial(5*k)) /
      (factorial(k) * 6 *3125^k)
         when numberp a and numberp aa
            and numberp aaa and numberp aaaa
               and a = 4/5 and aa = 6/5 and aaa = 7/5 and aaaa = 8/5,

pochhammer(~a,~k)*pochhammer(~aa,~k)*
      pochhammer(~aaa,~k)*pochhammer(~aaaa,~k)  =>
   (625*(1/5+k)*(2/5+k)*(3/5+k)*(4/5+k)*factorial(5*k)) /
      (factorial(k) * 24 *3125^k)
         when numberp a and numberp aa
            and numberp aaa and numberp aaaa
               and a = 6/5 and aa = 7/5 and aaa = 8/5 and aaaa = 9/5,

Pochhammer(~a,~k)//Pochhammer(~b,~k)  => (a + k -1)/(a - 1)
                        when (a - b)=1,

Pochhammer(~a,~k)//Pochhammer(~b,~k)  => (b - 1)/(b + k -1)
                        when (b - a)=1
})$

algebraic (let pochhammer!*rules);



algebraic procedure do!*gamma(z);
   (if impart z = 0
    then algebraic sf!*eval('gamma!*calc!*s,{z})
    else algebraic sf!*eval('gamma!*calc,{z}));



algebraic procedure gamma!*calc!*s(z);
   begin scalar scale, result, alglist!*;
      integer p, precom;
      precom := complex!*off!*switch();
      p := precision(0);
      op := lisp c!:prec!:();
      if p < !!nfpd then precision (!!nfpd + 1);
%      else precision(p+3);
      if p > 49 then
         scale := 500 + p
      else scale := 10 * (p+1);
      if z > scale then scale := 2;
      result := gamma!*calc!*s!*sub(z,scale,op);
      precision p;
      complex!*restore!*switch(precom);
      return result;
   end;



algebraic procedure gamma!*calc!*s!*sub(z,scale,op);
   begin scalar za, z1, result; integer z0;
      za := z; z0 := floor (z+1); z1 := z + scale;
      result := algebraic symbolic log!*gamma(z1,z0);
      result := (exp result / pochhammer(z,scale));
      return result;
   end;



symbolic procedure log!*gamma(z, zint);
   begin scalar result, this, zpwr, zsq, admissable, abk;
      integer k, rp, orda, magn;

      magn := bf!*base ** c!:prec!:();

      if zint < 1000 then
         if new!*bfs
         then admissable := divbf
                  (i2bf!: msd!: (1 + (factorial zint / 3)),
                   i2bf!: magn)
         else admissable := divbf
                  (i2bf!: length explode factorial zint,
                   i2bf!: magn)
      else
         admissable := divbf
               (difbf(log!:(timbf(plubf(bftwo!*,bfhalf!*),
                     sqrt!:(exptbf(i2bf!: zint,2*zint+1,bfone!*),8)),8),
                  i2bf!: zint),i2bf!: magn);

      z := sq2bf!* z;
      result := timbf(log!* z, difference!:(z, bfhalf!*));
      result := plubf((difference!: (result, z)), timbf(bfhalf!*,
         log!* timbf(pi!*(), bftwo!*)));
      this := plubf (admissable, bfone!*);
      rp := c!:prec!:(); orda := order!: admissable - 5;
      k := 2; zpwr := z; zsq := timbf (z, z);

      if (lisp null compute!-bernoulli) then
         symbolic <>;

      while greaterp!:(abs!: this, admissable) do
         << abk := retag cdr !*a2f retrieve!*bern k;
            this := divide!: (abk,
               timbf (i2bf!: (k * (k-1)), zpwr), rp);
            rp := order!: this - orda;
            result := plubf(result, this);
            zpwr := timbf (zpwr, zsq);
            k := k + 2; >>;

      return mk!*sq !*f2q mkround result;
   end;




%
% algebraic procedure loggamma!*calc!*sub(z);
%
% Procedure to calculate ln(gamma(z)); returns a 2-list of
%   the value of ln(gamma) and the final term used in the
%   constructing series. (This term is used by gamma!*calc!*sub
%   to compute the error.)
%
% Also requires to be fed the indices for the first and last
%     terms to be used in constructing the portion of the
%     series that it will construct.  Both of these values should
%     be even; if the first term's index is 2, then the initial
%     terms to construct the log gamma will also be included.
%

algebraic procedure loggamma!*calc!*sub(z, premier, dernier);
   begin scalar result, ft, sofar, div;
      if premier = 2 then result := ((z - (1/2)) * log z) - z +
         ((1/2) * log (2*pi))
      else result := 0;
      sofar := z ** (dernier-1);
      div := z ** 2;
      result := result + (ft := (bernoulli!*calc(dernier) /
         ((dernier -1) * dernier * sofar)));
      for n := (dernier-2) step -2 until premier
         do << sofar := sofar / div;
               result := result + (bernoulli!*calc(n) /
                  (n * (n-1) * sofar)) >>;
      return { result, ft };
   end;



%
% algebraic procedure gamma!*calc!*sub(z,scale);
%
% Procedure to calculate values of gamma. Given the value
%   at which to calculate and the amount by which to scale
%   up in calculation, returns (eventually) a 2-list of the value
%   of gamma and the maximum error on this value. Needs a
%   better interface -- see the gamma!*calc procedure, below.
%

algebraic procedure gamma!*calc!*sub(z,scale);
   begin scalar result, expresult, ft, err, newerr, rescale,
         admissable, alglist!*;
      integer prepre, premier, dernier;
      prepre := precision(0);
%      precision (prepre + 4);
      rescale := for k := 1:scale product (z+k-1);
      admissable := 1 / (10 ** (prepre + 4));
      err := admissable + 1;
      premier := 2;
      dernier := 50;
      result := 0;
      while (err > admissable) do
         << ft := loggamma!*calc!*sub(z+scale, premier, dernier);
            result := result + first ft;
            ft := second ft;
            expresult := exp result;
            newerr := (abs ((expresult/(exp ft)) - expresult))/rescale;
            if newerr > err or (dernier > 180 and
                     newerr > (admissable * 1000)) then
               << scale := scale * 3;
                  rescale := (for m := 1:scale product (z+m-1));
                  write ("Scaling up to scale=", scale,
                           " (from ", scale/3, ")");
                  result := 0;
                  premier := 2;
                  dernier := 100;
                  err := admissable + 1 >>
               else
               << err := newerr;
                  premier := dernier + 2;
                  dernier := dernier + 30 >> ;
         >>;
      result := expresult / rescale;
%      precision prepre;
      return { result, err };
   end;



%
% algebraic procedure gamma!*calc(z);
%
% Procedure to calculate values of gamma to (one hopes)
%   an error within the tolerance allowed by the current
%   precision. Calls gamma!*calc!*sub (above) with a scale worked
%   out by slightly ad-hoc (but apparently fairly good) methods
%   and will be generally OK for z between 1e-7 and infinity.
%
% Only works for positive z, and only in rounded mode.
%

algebraic procedure gamma!*calc(z);
   if precision(0) > 49
     then first gamma!*calc!*sub(z,500+4*precision(0))
    else first gamma!*calc!*sub(z, ceiling (exp(precision(0)/10) * 2));





%
% Functions to compute Pochhammer(a,k).
%


algebraic procedure do!*pochhammer(a,k);
   algebraic sf!*eval('pochhammer!*calc,{a,k});

algebraic procedure do!*poch!*conj!*calc(z,n);
   algebraic sf!*eval('poch!*conj!*calc,{z,n});


algebraic procedure pochhammer!*calc(a,k);
   (if fixp a and not symbolic !*rounded
   then (symbolic fac!-part(a, a+k-1))
   else pochhammer!*calc!*sub(a,k));


algebraic procedure pochhammer!*calc!*sub(a,k);
   begin scalar result, prepre, precom, a0;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if prepre < !!nfpd then precision (1+!!nfpd);
      a0 := a;
      result := if (symbolic new!*bfs)
         then algebraic symbolic pochhammer!*calc!*sub!*sub!*newbf(a,k)
         else algebraic symbolic pochhammer!*calc!*sub!*sub!*oldbf(a,k);
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;


symbolic procedure pochhammer!*calc!*sub!*sub!*oldbf(a,k);
   begin scalar result;
      if fixp a
       then result := poch!*sub!*2(0, k-1, i2bf!: a)
       else << a := sq2bf!* a;
               if order!: a < - !:prec!:
                  then result := poch!*sub!*2(0, k-1, bfone!*)
                  else if length explode mt!: a < !:prec!:/2
                              and order!: a > -2
                          then result := poch!*sub!*2(0, k-1, a)
                          else result := poch!*sub!*1(a, k-1,bfone!*)>>;
      return mk!*sq !*f2q mkround result;
   end;


symbolic procedure pochhammer!*calc!*sub!*sub!*newbf(a,k);
   begin scalar result;
      if fixp a
       then result := poch!*sub!*2(0, k-1, i2bf!: a)
       else << a := sq2bf!* a;
               if order!: a < - c!:prec!:()
                  then result := poch!*sub!*2(0, k-1, bfone!*)
                  else if preci!: a < c!:prec!:()/2 and order!: a>-2
                         then result := poch!*sub!*2(0, k-1, a)
                        else result := poch!*sub!*1(a,k-1,bfone!*)>>;
      return mk!*sq !*f2q result;
   end;


symbolic procedure poch!*sub!*1(a,k,tot);
   if k=0 then timbf(tot,a)
   else poch!*sub!*1(plus!:(a,bfone!*),k-1,timbf(tot,a));


symbolic procedure poch!*sub!*2(m,n,a);
   if m=n then plus!:(a,i2bf!: m)
   else if m = n-1 then
      timbf(plus!:(a,i2bf!: m), plus!:(a,i2bf!: n))
   else (timbf(poch!*sub!*2(m,p,a),poch!*sub!*2(p+1,n,a)))
      where p=(m+n)/2;


algebraic procedure poch!*conj!*calc(z,n);
   for i := 1:n product ((repart z + (i-1))**2 + (impart z)**2);


% lets prod (in misc package) know about gamma.

algebraic
  let { prod(~n,~n,~anf,~ende) => Gamma(ende + 1)/Gamma(anf)
                when not( fixp anf and anf < 0) ,

        prod(~n,~n,~anf) => Gamma(n+1)/Gamma(anf)
                when not( fixp anf and anf < 0),

        prod(~k +~n,k,~nanf,~nend) =>
                 gamma(nend + 1 + n)/gamma (nanf + n)
                when numberp nanf and numberp n and nanf + n > 0,

        prod(~k +~n,k,~nanf,~nend) => 0
                when numberp nanf and numberp n and nanf= - n,

        prod(~~a*~k +~n,k,~nanf,~nend) => prod(a,k,nanf,nend)*
                 gamma(nend + 1 + n/a)/gamma (nanf + n/a)
                 when freeof(a,k) and freeof (n,k),
%               when not(numberp nanf and numberp n),


%       prod(~n,~n) =>  gamma(n+1)},

        (~~u*gamma(~x+~~n0))//(~~v*gamma(x +~~n1)) =>
        (u*gamma(~x+n0))/(v*(x+n1-1)*Gamma(x+n1-1))
                 when not (numberp x and x eq 0)
                 and (fixp n0 and fixp n1 and n0
        (u*gamma(~x+n0-1)*(x+n0-1))/(v*Gamma(x+n1))
                when not (numberp x and x eq 0)
                 and (fixp n0 and fixp n1 and n0>n1  and (n0-n1)< 6)
};

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.red0000644000175000017500000001603311526203062023737 0ustar  giovannigiovannimodule specfn;  % Special functions package for REDUCE.

% Author:  Chris Cannam, Sept-Nov 1992.
%          Winfried Neun, Nov 1992 ...
%          contribution from various authors ...

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %
%                                                                %
%     Please report bugs to Winfried Neun,                       %
%                           Konrad-Zuse-Zentrum                  %
%                              fuer Informationstechnik Berlin,  %
%                           Heilbronner Str. 10                  %
%                           10711 Berlin - Wilmersdorf           %
%                           Federal Republic of Germany          %
%     or by email, neun@sc.ZIB-Berlin.de                         %
%                                                                %
%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %
%                                                                %
%     This package provides algebraic and numeric                %
%     manipulations upon various special functions:              %
%                                                                %
%              -- Bernoulli Numbers                              %
%              -- Gamma Function                                 %
%              -- Pochhammer Notation                            %
%              -- Digamma (Psi) Function and Derivatives         %
%              -- Riemann Zeta Function                          %
%              -- Bessel Functions J, Y, I and K                 %
%              -- Airy Functions                          %
%              -- Hankel Functions H1 and H2                     %
%              -- Kummer Hypergeometric Functions M and U        %
%              -- Struve, Lommel and Whittaker Functions         %
%              -- Integral funtions, Si, Ci, s_i (=si), Ei,...   %
%              -- Simplification of Factorials                   %
%              -- Solid and Spherical Harmonics                    %
%              -- Jacobi Elliptic Functions                        %
%              -- Elliptic Integrals                              %
%                                                                %
%     accessible through the new operators Bernoulli, Gamma,     %
%     Pochhammer, Psi, Polygamma, Zeta, BesselJ, BesselY,        %
%     BesselI, BesselK, Hankel1, Hankel2, KummerM, KummerU,      %
%     AiryAi, AiryBi, AiryAiPrime, AiryBiPrime,                  %
%     Elliptic{sn,cn,dn...}, Elliptic{E,F,K...}
%     Beta, StruveL, StruveH, Lommel1, Lommel2, WhittakerM       %
%     and WhittakerW, with the new switch SaveSFs.               %
%                                                                %
%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %


create!-package ('(specfn sfconsts sfgen sfbern dilog sfbinom sfpolys
                   sfsums simpfact harmonic jsymbols recsimpl sfellip
                   sfellipi sfint),
                 '(contrib specfn));

exports sq2bf!*, c!:prec!:;

switch savesfs;
on savesfs;


symbolic smacro procedure mksqnew u;
  !*p2f(car fkern(u) .* 1) ./ 1;

symbolic fluid '(bernoulli!-alist new!*bfs bf!*base sf!-alist !*savefs);

symbolic ( bernoulli!-alist := nil );
symbolic ( sf!-alist        := nil );

symbolic ( new!*bfs := fluidp '!:bprec!: );
symbolic ( bf!*base := (if new!*bfs then 2 else 10) );
symbolic ( if not globalp 'log2of10 then
               << global '(log2of10); log2of10 := 3.32193 >> );

symbolic smacro procedure sq2bf!*(x);
   (if fixp x then i2bf!: x
      else ((if car y neq '!:rd!: then retag cdr !*rn2rd y
               else retag cdr y) where y = !*a2f x));

symbolic smacro procedure c!:prec!:;
   (if new!*bfs then lispeval '!:bprec!: else !:prec!:);


% These functions are needed in other modules.

algebraic procedure complex!*on!*switch;
   if not symbolic !*complex then
      if symbolic !*msg then
         << off msg;
            on complex;
            on msg >>
      else on complex
   else t;

algebraic procedure complex!*off!*switch;
   if symbolic !*complex then
      if symbolic !*msg then
         << off msg; off complex; on msg >>
      else off complex
   else t;

algebraic procedure complex!*restore!*switch(fl);
   if not fl then
      if symbolic !*msg then
         << off msg;
            if symbolic !*complex then
               off complex
            else on complex;
            on msg >>
      else if symbolic !*complex then
            off complex
         else on complex;

%algebraic operator besselJ,besselY,besselI,besselK,hankel1,hankel2;
%algebraic (operator kummerM, kummerU, struveh, struvel
%                  ,lommel1, lommel2 ,whittakerm, whittakerw,
%                   Airy_Ai, Airy_Bi,Airy_AiPrime,Airy_biprime);

defautoload_operator(besselj,specbess);
defautoload_operator(bessely,specbess);
defautoload_operator(besseli,specbess);
defautoload_operator(besselk,specbess);
defautoload_operator(hankel1,specbess);
defautoload_operator(hankel2,specbess);
defautoload_operator(kummerM,specbess);
defautoload_operator(kummerU,specbess);
defautoload_operator(struveh,specbess);
defautoload_operator(struvel,specbess);
defautoload_operator(lommel1,specbess);
defautoload_operator(lommel2,specbess);
defautoload_operator(whittakerm,specbess);
defautoload_operator(whittakerw,specbess);
defautoload_operator(Airy_Ai,specbess);
defautoload_operator(Airy_Bi,specbess);
defautoload_operator(Airy_AiPrime,specbess);
defautoload_operator(Airy_biprime,specbess);

defautoload_operator(gamma,sfgamma);
defautoload_operator(igamma,sfgamma);
defautoload_operator(polygamma,sfgamma);
defautoload_operator(psi,sfgamma);
defautoload_operator(ibeta,sfgamma);
defautoload_operator(beta,sfgamma);
defautoload_operator(pochhammer,sfgamma);
defautoload_operator(zeta,sfgamma);

endmodule;

end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/substexp.red0000644000175000017500000000666511526203062024350 0ustar  giovannigiovannimodule substexp;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

depend ff,x;
depend f,x;
depend f,!~k;

operator pssubst;

operator a,Pproduct;

subst_rules :=

{ pssubst(- ~g,~x,~a,~n) => -pssubst(g,x,a,n),
  pssubst(~g+~h,~x,~a,~n) => pssubst(g,x,a,n) + pssubst(h,x,a,n),
  pssubst(~c*~g,~x,~a,~n) => c*pssubst(g,x,a,n)
                          when freeof(c,x) and freeof(c,g),
  pssubst(df(~f,~x,~k),~x,~a,~n) => Pochhammer(n+1,k) * a(n+k),
  pssubst(df(~f,~x),~x,~a,~n) => (n + 1)* a(n + 1),
  pssubst(~x^~j * df(~f,~x),~x,~a,~n) => Pochhammer(n+1-j,1)*a(n+1-j),
  pssubst(~x^~j * df(~f,~x,~k),~x,~a,~n)=> Pochhammer(n+1-j,k)*a(n+k-j),

  pssubst(ff*~x^~j,~x,~a,~n) => a(n-j),
  pssubst(ff*~x,~x,~a,~n)    => a(n-1),

  pssubst(df(~f,~x) *x,~x,~a,~n) => Pochhammer(n,1)*a(n),
  pssubst(df(~f,~x,~k) *x,~x,~a,~n) => Pochhammer(n,k)*a(n+k-1),

  pssubst(f,~x,~a,~n) => a(n),
  pssubst(ff,~x,~a,~n) => a(n),

  pssubst(~c,~x,~a,~n) => 0 when freeof(c,x),
  pssubst(~x^~j,~x,~a,~n) => 0 when fixp j,
  pssubst(~x,~x,~a,~n) => 0
  };

spec_pochhammer :=

{ Pochhammer(~a,~k)//Pochhammer(~b,~k) => (a + k -1)/(a - 1)
     when (a - b)=1,
  Pochhammer(~a,~k)//Pochhammer(~b,~k) => (b - 1)/(b + k -1)
     when (b - a)=1,
  Pochhammer(~z,~k) * Pochhammer(~cz,~k) =>
     prod((repart(z) + (j - 1))^2 + (impart(z))^2,j,1,k)
        when not(impart(z) = 0) and z = conj cz,
  Pochhammer(~k,~n) => 1 when n=0,
  Pochhammer(~k,~n) => Pproduct (k,n) when fixp n,
  Pproduct (~k,~ii) => 1 when ii =0,
  Pproduct (~k,~ii) => (k + ii - 1) * Pproduct (k,ii -1)}$

spec_factorial :=

{ Factorial (~n) // Factorial (~n+1) => 1/(n+1),
  Factorial (~n) * Factorial (~n) // Factorial (~n+1) =>
                                Factorial (n)/(n+1),
  Factorial (~n+1) // Factorial (~n) => (n+1),
  Factorial (~n+1) * Factorial (~n+1) // Factorial (~n) =>
                                (n+1) * Factorial (~n+1),
  (~otto ^(~k)) * Factorial (~n) // Factorial (~n +1) => otto^k  /(n+1),
  (~otto ^(~k)) * Factorial (~n+1) // Factorial (~n) =>  otto^k * (n+1),
  (~otto ^~k) * ~hugo * Factorial (~n) // Factorial (~n +1) =>
      otto^k * hugo/(n+1),
  (~otto ^~k) * ~hugo * Factorial (~n+1) // Factorial (~n) =>
      otto^k * hugo *(n+1)}$

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfigamma.red0000644000175000017500000001622111526203062024244 0ustar  giovannigiovannimodule igamma;

% Author : Daniel Hobbs , University of Bath, 1995 - 1996
%
%--------------------------------------------------------------------------
%
%  The incomplete gamma function.
%
%  igamma_iter_series(a,x,iter,sum,last_term) - iteratively computes the
%               value of an approximation to an infinite series used in
%                igamma (for x<=1 or x igamma_eval(a,x)
        when numberp(a) and numberp(x) and a>0 and x>=0 and lisp !*rounded
};

let
{
 ibeta(~a,~b,~x) => ibeta_eval(a,b,x)
        when numberp(a) and numberp(b) and numberp(x) and lisp !*rounded
             and repart(a)>0 and repart(b)>0 and x>=0 and x<=1
};


% Function igamma_iter_series:     --  cum_gamma_iter        x^i
%                                  \                       -------------
%                                  /                       (a+1)...(a+i)
%                                  --  i=1
% Uses Battacharjee's method (1970) (computed recursively).

expr procedure igamma_iter_series(a,x,iter,sum,last_term);
begin
 scalar value,this_term;

 if (last_term < 10^-(precision(0)+3)) then
  value := sum
 else
 <<
  this_term := (last_term * x / (a+iter));
  value := igamma_iter_series(a,x,iter+1,sum+this_term,this_term)
 >>;

 return value;
end;


% Function igamma_cont_frac:            1   1-a   1   2-a   2
%                                      ---  ---  ---  ---  ---  ...
%                                        x +  1 +  x +  1 +  x +
% Recursively computes fraction using
% Abramowitz and Stegun's method (1964).

expr procedure igamma_cont_frac(a,x,iter,iter_max);
begin
 scalar value;

 if (iter>iter_max) then
  value := 0
 else
  value := (iter - a)/
              (1 +      (iter/
                    (x + igamma_cont_frac(a,x,iter + 1,iter_max))));

 return value;
end;


% Function igamma_eval: returns the value at point x of the
% incomplete gamma function with order ord.

expr procedure igamma_eval(a,x);
begin
 scalar arg,frac,last_frac,acc,value;

 % Decide whether to use a series expansion or a continued fraction.
 if (x<=1 or x>
 else
 <<
  % Set required accuracy to be 3 decimal places more than
  % current precision.
  acc := 10 ^ -(precision(0)+3);
  % Obtain a starting value.
  frac := igamma_cont_frac(a,x,1,1);
  sfiterations := 1;
  % Repeat loop until successive results of continued fraction converge.
  repeat
  <<
   sfiterations := sfiterations + 1;
   last_frac := frac;
   frac := igamma_cont_frac(a,x,1,sfiterations)
  >>
  until (last_frac - frac) < acc;

  arg := exp(-x) * x^a / gamma(a);
  value := 1 - arg / (x + frac)
 >>;

 return value;
end;


% Function ibeta_cont_frac: calculates  1   c(2)  c(3)
%                                      ---  ----  ----  ...
%                                      1 +  1  +  1  +
% where
%        c(2i) =  - (a + i - 1) (b - i)   *   x
%                ---------------------------------
%                (a + 2i - 2) (a + 2i - 1) (1 - x)
% and
%      c(2i+1) =  i (a + b + i - 1)   *   x
%                -----------------------------
%                (a + 2i - 1) (a + 2i) (1 - x)

expr procedure ibeta_cont_frac(iter,iter_max,a,b,x);
begin
 scalar value,c_odd,c_even;

 if not (fixp(iter) and fixp(iter_max) and numberp(x)) then
  rederr("ibeta_cont_frac called illegally");

 if (iter>iter_max) then
  value := 0
 else
 <<
  c_even := -(a+iter-1)*(b-iter)*x / ((a+2*iter-2)*(a+2*iter-1)*(1-x));
  c_odd := iter*(a+b+iter-1)*x / ((a+2*iter-1)*(a+2*iter)*(1-x));
  value := c_even /
               (1 + (c_odd /
                       (1 + ibeta_cont_frac(iter+1,iter_max,a,b,x))))
 >>;

 return value;
end;


% Function ibeta_eval: returns the value of the incomplete beta%
% function with parameters a and b at point x. Method due to Muller (1931).

expr procedure ibeta_eval(a,b,x);
begin
 scalar last_value,value,arg,sfiterations;

 if (x=0 or x=1) then
  value := x
 else
 <<
  %
  if (repart(a+b)-2)*x > (repart(a)-1) then
   value := 1 - ibeta(b,a,1-x)
  else
  <<
   arg := gamma(a+b) * x^a * (1-x)^(b-1) / (a * gamma(a) * gamma(b));
   % A starting point of 30 levels of continued fraction.
   sfiterations := 30;
   % Starting value that will force calculation a second time at least.
   value := -1;
   repeat
   <<
    last_value := value;
    value := arg * (1/(1 + ibeta_cont_frac(1,sfiterations,a,b,x)));
    sfiterations := sfiterations + 10
   >>
   until (abs(value - last_value) < 10^-(precision(0)+3))
    or sfiterations > ibeta_max_iter;
  >>
 >>;

 % Error condition should not occur, but in case it does...
 if sfiterations > ibeta_max_iter then
 write
 "*** Warning: max iteration limit exceeded; result may not be accurate";

 return value;
end;

>>;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/harmonic.red0000644000175000017500000001145711526203062024266 0ustar  giovannigiovannimodule harmonic; % Solid & spherical harmonics.

% Author: Matthew Rebbeck, ZIB.
% Advisor: Rene' Grognard.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Date:   March 1994

% Version 0 (experimental)

% Solid Harmonics of order n (Laplace polynomials)
% are homogeneous polynomials of degree n in x,y,z
% which are solutions of Laplace equation:-

%        df(P,x,2) + df(P,y,2) + df(P,z,2) = 0.

% There are 2*n+1 independent such polynomials for any given n >=0
% and with:-

%       w!0 = z, w!+ = i*(x-i*y)/2, w!- = i*(x+i*y)/2,

% they are given by the Fourier integral:-

% S(n,m,w!-,w!0,w!+) =

%       (1/(2*pi)) *
%       for u:=-pi:pi integrate (w!0 + w!+ * exp(i*u) + w!- *
%           exp(-i*u))^n * exp(i*m*u) * du;

% which is obviously zero if |m| > n since then all terms in the
% expanded integrand contain the factor exp(i*k*u) with k neq 0,

% S(n,m,x,y,z) is proportional to
%     r^n * Legendre(n,m,cos theta) * exp(i*phi)

% Let r2 = x^2 + y^2 + z^2 and r = sqrt(r2).

% The spherical harmonics are simply the restriction of the solid
% harmonics to the surface of the unit sphere and the set of all
% spherical harmonics {n >=0; -n <= m =< n} form a complete orthogonal
% basis on it, i.e.  = Kronecker_delta(n,n') *
% Kronecker_delta(m,m') using <...|...> to designate the scalar product
% of functions over the spherical surface.

% The coefficients of the solid harmonics are normalised in what
% follows to yield an ortho-normal system of spherical harmonics.

% Given their polynomial nature, there are many recursions formulae
% for the solid harmonics and any recursion valid for Legendre functions
% can be 'translated' into solid harmonics. However the direct proof is
% usually far simpler using Laplace's definition.

% It is also clear that all differentiations of solid harmonics are
% trivial, qua polynomials.

% Some substantial reduction in the symbolic form would occur if one
% maintained throughout the recursions the symbol r2 (r cannot occur
% as it is not rational in x,y,z). Formally the solid harmonics appear
% in this guise as more compact polynomials in (x,y,z,r2).

% Only two recursions are needed:-

% (i) along the diagonal (n,n);

% (ii) along a line of constant n: (m,m),(m+1,m),...,(n,m).

% Numerically these recursions are stable.

% For m < 0 one has:-

%       S(n,m,x,y,z) = (-1)^m * S(n,-m,x,-y,z);

algebraic procedure SolidHarmonicY(n,m,x,y,z,r2);
begin scalar mp, v, Y0, Y1, Y2;

 if not (fixp(n) and fixp(m)) then  return
    rederr " SolidHarmonicY : n and m must be integers";
 if (n < 0) then return 0;
 mp := abs(m);
 if (n < mp ) then return 0;
 Y0 := 1/sqrt(4*Pi);
 if (n = 0) then return Y0;
 if (mp > 0) then
 << if m > 0 then v:=x+i*y else v:=x-i*y;
  for k:=1:mp do Y0 := - sqrt((2*k+1)/(2*k))*v*Y0;
  if (n > mp) then <<
   k := mp + 1;
   Y1 := Y0;
   Y0 := z*sqrt(2*k+1)*Y1;
   if (n > mp + 1) then for k:=mp+2:n do <<
            Y2 := Y1;
            Y1 := Y0;
            Y0 := z*sqrt((4*k*k-1)/(k*k-mp*mp))*Y1
                   -r2*sqrt(((2*k+1)*(k-mp-1)*(k+mp-1))/
                   ((2*k-3)*(k*k-mp*mp)))*Y2 >>;
                  >>;
 >> else << Y1 := Y0;
            Y0 := z*sqrt(3)*Y1;
            if n > 1 then for k:=2:n do <<
                   Y2 := Y1;
                   Y1 := Y0;
                   Y0 := ( z*sqrt(4*k*k-1)*Y1 - r2*(k-1)*
                         sqrt((2*k+1)/(2*k-3))*Y2)/k >>;
         >>;
 if m < 0 and not evenp mp then Y0 := - Y0;
 return Y0
end;

algebraic procedure SphericalHarmonicY(n,m,theta,phi);
        SolidHarmonicY(n,m,sin(theta)*cos(phi),
                sin(theta)*sin(phi),cos(theta),1)$

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.tst0000644000175000017500000002722011526203062023777 0ustar  giovannigiovanni%
%  Testing file for REDUCE Special Functions Package
%
%             Chris Cannam, ZIB Berlin
%             October 1992 -> Feb 1993
%        (only some of the time, of course)
%
%  Corrections and comments to neun@sc.zib-berlin.de
%


on savesfs;	% just in case it's off for some reason

off bfspace;	% to provide more similarity between runs
		% with old & new bigfloats

let {sinh (~x) => (exp(x) - exp (-x))/2 };
		% this will improve some results


% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     1. Bernoulli numbers

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;

procedure do!*one!*bern(x);
   write ("Bernoulli ", x, " is ", bernoulli x);

do!*one!*bern(1);
do!*one!*bern(2);
do!*one!*bern(3);
do!*one!*bern(13);
do!*one!*bern(14);
do!*one!*bern(300);
do!*one!*bern(-2);
do!*one!*bern(0);

for n := 2 step 2 until 100 do do!*one!*bern n;

on rounded;
precision 100;

do!*one!*bern(1);
do!*one!*bern(2);
do!*one!*bern(3);
do!*one!*bern(13);
do!*one!*bern(14);
do!*one!*bern(300);
do!*one!*bern(-2);
do!*one!*bern(0);
do!*one!*bern(38);
do!*one!*bern(400);


% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     2. Gamma function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


on rounded;
off complex;
precision 40;

algebraic procedure wg(x);
   write ("gamma (", x, ")  ==>  ", gamma x);

algebraic procedure wp(x);
   write ("-- precision ", x, ",  from ", precision(x));

wg (1/2);
wg (3/2);

write ("sqrt(pi)/2  ==>  ", sqrt(pi)/2);

wp(10);

for x := 0 step 5 until 100 do
   << wg (1 + x/1000);
      wg (-1 - x/13);
      wp (8+floor(x/4)) >>;

wg(1/1000000003);

off rounded;

gamma(17/2);
gamma(-17/2);
gamma(4);
gamma(0);
gamma(-4);
gamma(-17/3);

p := gamma(x**2) * gamma(x-y**gamma(y)) - (1/(gamma(4*(x-y))));
y := 1/4;
p;
x := 3;
p;
y := -3/8;
p;

on rounded, complex;
precision 50;

p;

off rounded, complex;
clear y;

p;



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     3. Beta function.  Not very interesting

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


algebraic procedure do!*one!*beta(x,y);
   write ("Beta (", x, ",", y, ") = ", beta(x,y));

do!*one!*beta(0,1);
do!*one!*beta(2,-3);
do!*one!*beta(3,2);
do!*one!*beta(a+b,(c+d)**(b-a));
do!*one!*beta(-3,4);
do!*one!*beta(-3,2);
do!*one!*beta(-3,-7.5);
do!*one!*beta((pi * 10), exp(5));

on rounded;
precision 30;

do!*one!*beta(0,1);
do!*one!*beta(2,-3);
do!*one!*beta(3,2);
do!*one!*beta(a+b,(c+d)**(b-a));
do!*one!*beta(-3,4);
do!*one!*beta(-3,2);
do!*one!*beta(-3,-7.5);
do!*one!*beta((pi * 10), exp(5));



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     4. Pochhammer notation

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;

pochhammer(4,5);
pochhammer(-4,5);
pochhammer(4,-5);
pochhammer(-4,-5);
pochhammer(17/2,12);
pochhammer(-17/2,12);
pochhammer(1/3,14)*pochhammer(2/3,15);

q := pochhammer(1/5,11)*pochhammer(2/5,11)*pochhammer(3/5,11)*
      pochhammer(1-1/5,11)*pochhammer(1,11)*pochhammer(6/5,11)*
       pochhammer(70/50,11)*pochhammer(8/5,11)*pochhammer(9/5,11);

on complex;

pochhammer(a+b*i,c)*pochhammer(a-b*i,c);

a := 2;
b := 3;
c := 5;

pochhammer(a+b*i,c)*pochhammer(a-b*i,c);

off complex;
on rounded;

pochhammer(1/5,11)*pochhammer(2/5,11)*pochhammer(3/5,11)*
 pochhammer(1-1/5,11)*pochhammer(1,11)*pochhammer(6/5,11)*
  pochhammer(70/50,11)*pochhammer(8/5,11)*pochhammer(9/5,11);

q;

pochhammer(pi,floor (pi**8));
pochhammer(-pi,floor (pi**7));
pochhammer(1.5,floor (pi**8));



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     5. Digamma function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*psi(x);
   << precision (precision(0) + 4)$
      write("Psi of ", x, " is ", psi(x) ) >> ;

clear x, y;

z := x * ((x+y)**2 + (x**y));

off rounded;

do!*one!*psi(3);
do!*one!*psi(pi);
do!*one!*psi(1.005);
do!*one!*psi(1.995);
do!*one!*psi(74);
do!*one!*psi(-1/2);
do!*one!*psi(-3);
do!*one!*psi(z);

on rounded;
precision 100;

do!*one!*psi(3);
do!*one!*psi(pi);
do!*one!*psi(1.005);
do!*one!*psi(1.995);
do!*one!*psi(74);
do!*one!*psi(-1/2);
do!*one!*psi(-3);
do!*one!*psi(z);

precision 15;

x := 8/3;
y := 7/1000;
do!*one!*psi(z);

off rounded;

clear x, y;

df(psi(z), x);
df(df(psi(z), y),x);
int(psi(z), z);

on rounded;

for k := 1 step 0.1 until 2 do do!*one!*psi(k);

off rounded;

% PSI_SIMP.TST  F.J.Wright, 2 July 1993

on evallhseqp;
factor psi;  on rat, intstr, div;  % for neater output
% Do not try using "off mcd"!

psi(x+m) - psi(x+m-1) = 1/(x+m-1);
psi(x+2) - psi(x+1) + 2*psi(x) = 1/(x+1) + 2*psi(x);
psi(x+2) + 3*psi(x) = 4*psi(x) + 1/x + 1/(x+1);

psi(x + 1) = psi(x) + 1/x;
psi(x + 3/2) = psi(x + 1/2) + 1/(x + 1/2);
psi(x - 1/2) = psi(x + 1/2) - 1/(x - 1/2);
psi((x + 3a)/a);  psi(x/y + 3);

off rat, intstr, div;  on rational;

psi(x+m) - psi(x+m-1) = 1/(x+m-1);
psi(x+2) - psi(x+1) + 2*psi(x) = 1/(x+1) + 2*psi(x);
psi(x+2) + 3*psi(x) = 4*psi(x) + 1/x + 1/(x+1);

psi(x + 1) = psi(x) + 1/x;
psi(x + 3/2) = psi(x + 1/2) + 1/(x + 1/2);
psi(x - 1/2) = psi(x + 1/2) - 1/(x - 1/2);
psi((x + 3a)/a);  psi(x/y + 3);

off rational;

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     6. Polygamma functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*pg(n,x);
   write ("Polygamma (", n, ") of ", x, " is ", polygamma(n,x));

off rounded;

do!*one!*pg(1,1/2);
do!*one!*pg(1,1);
do!*one!*pg(1,3/2);
do!*one!*pg(1,1.005);
do!*one!*pg(1,1.995);
do!*one!*pg(1,1e-10);
do!*one!*pg(2,1.45);
do!*one!*pg(3,1.99);
do!*one!*pg(4,-8.2);
do!*one!*pg(5,0);
do!*one!*pg(6,-5);
do!*one!*pg(7,200);

on rounded;
precision 100;

do!*one!*pg(1,1/2);
do!*one!*pg(1,1);
do!*one!*pg(1,3/2);
do!*one!*pg(1,1.005);
do!*one!*pg(1,1.995);
do!*one!*pg(1,1e-10);
do!*one!*pg(2,1.45);
do!*one!*pg(3,1.99);
do!*one!*pg(4,-8.2);
do!*one!*pg(5,0);
do!*one!*pg(6,-5);
do!*one!*pg(7,200);

off rounded;
clear x;


% Polygamma differentiation has already
% been tried a bit in the psi section

df(int(int(int(polygamma(3,x),x),x),x),x);

clear w, y, z;



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     7. Zeta function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*zeta(n);
   write ("Zeta of ", n, " is ", zeta n);

off rounded;
clear x, y, z;

z := x * ((x+y)**5 + (x**y));

do!*one!*zeta(0);

for k := 4 step 2 until 35 do 
   do!*one!*zeta(k);

do!*one!*zeta(-17/3);
do!*one!*zeta(190);
do!*one!*zeta(300);
do!*one!*zeta(0);
do!*one!*zeta(-44);

on rounded;
clear x, y;

for k := 3 step 3 until 36 do <<
   precision (31+k*3);
   do!*one!*zeta(k) >>;

precision 20;

do!*one!*zeta(-17/3);
do!*one!*zeta(z);

y := 3;
x := pi;

do!*one!*zeta(z);
do!*one!*zeta(190);
do!*one!*zeta(300);
do!*one!*zeta(0);
do!*one!*zeta(-44);

off rounded;



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     8. Kummer functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;

t!*kummer!*a := { 1, 2.4, -1397/10  }$
t!*kummer!*b := { 0, 1, pi, -pi, 26 }$

for each a in t!*kummer!*a do
   for each b in t!*kummer!*a do
      for each z in t!*kummer!*a do
      	 << write "KummerM(", a, ",", b, ",", z, ") = ",
      	       kummerm(a,b,z);
      	    write "KummerU(", a, ",", b, ",", z, ") = ",
      	       kummeru(a,b,z) >>;

on rounded;
precision 30;
t!*k!*c := 7;

%  To test each and every possible combination of
%  three arguments from t!*kummer!*b would take too
%  long, but we want the possibility of trying most
%  special cases.  Compromise: test every seventh
%  possibility.

for each a in t!*kummer!*b do
   for each b in t!*kummer!*b do
      for each z in t!*kummer!*b do
      	 << if t!*k!*c = 7
      	    then << write "KummerM(", a, ",", b, ",", z, ") = ",
      	       	       kummerm(a,b,z);
      	       	    write "KummerU(", a, ",", b, ",", z, ") = ",
      	       	       kummeru(a,b,z);
      	       	    t!*k!*c := 0 >>;
      	    t!*k!*c := t!*k!*c + 1 >>;

off rounded;
clear x, y, z, t!*k!*c;

df(df(kummerM(a,b,z),z),z);
df(kummerU(a,b,z),z);

z := ((x^2 + y)^5) + (x^(x+y));

df(df(kummerM(a,b,z),y),x);
df(kummerU(a,b,z),x);



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     9. Bessel functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


%  Lengthy test of the Bessel functions.  This isn't even
%  remotely exhaustive of the special cases -- though a
%  real person with lots of time could no doubt come up
%  with a better lot of tests than this automated rubbish.
%  Again, compromise by only actually doing one in five or
%  nine.  If you want a really thorough test, you can
%  easily change this to get it; but it'll take hours to
%  run.

clear p, q;

hankel1(p,q);
r := df(ws,q);

on complex;

r;
p:=3/8;
r;
q := pi;
r;

on rounded;

r;

off complex, rounded;

df(df(besselj(pp,qq)+rr * hankel1(pp*2,qq) *
      bessely(pp-qq,qq),qq),qq);

% Possible values for real args
t!*bes!*vr := { 1, pi, -pi, 26 }$

% Possible values for real and imaginary parts of complex args
t!*bes!*vc := { 0, 3, -41/2 }$

array s!*bes(4)$

s!*bes(1) := "BesselJ"$
s!*bes(2) := "BesselY"$
s!*bes(3) := "BesselI"$
s!*bes(4) := "BesselK"$

pre := 16;
precision pre;
preord := 10**pre;
t!*b!*c := 3;

algebraic procedure do!*one!*bessel(s,n,z);
   (if s = 1 then besselj(n,z)
      else if s = 2 then bessely(n,z)
      else if s = 3 then besseli(n,z)
      else besselk(n,z));

algebraic procedure pr!*bessel(s,n,z,k);
   << if t!*b!*c = k
      then
      	 << on rounded;
      	    bes1 := do!*one!*bessel(s,n,z);
      	    precision(pre+5);
      	    bes2 := do!*one!*bessel(s,n,z);
      	    if bes1 neq 0
      	       then disc := floor abs(100*(bes2-bes1)*preord/bes1)
      	       else disc := 0;
      	    precision pre;
      	    write s!*bes(s), "(", n, ",", z, ") = ", bes1;
      	    if not numberp disc then
      	       << precom := !*complex;
      	       	  on complex;
      	       	  disc := disc;
      	       	  if not precom then off complex >>;
      	    if disc neq 0
      	       then write "   (discrepancy ", disc, "% of one s.f.)";
      	    if numberp disc and disc > 200 then
      	       << write "***** WARNING  Significant Inaccuracy.";
      	       	  write "      Lower  precision result:";
      	       	  write "      ", bes1;
      	       	  write "      Higher precision result:";
      	       	  precision(pre+5); write "      ", bes2; precision pre >>;
      	    off rounded;
      	    t!*b!*c := 0 >>;
      t!*b!*c := t!*b!*c + 1 >>;

%  About to begin Bessel test.  We have a list of possible
%  values, and we test every Bessel, with every value on the
%  list as both order and argument.  Every Bessel is computed
%  twice, to different precisions (differing by 3), and any
%  discrepancy is reported.  The value reported is the diff-
%  erence between the two computed values, expressed as a
%  percentage of the unit of the least significant displayed
%  digit.  A discrepancy between 100% and 200% means that the
%  last digit of the displayed value was found to differ at
%  higher precision; values greater than 200% are cause for
%  concern.  An ideal discrepancy would be between about 1%
%  and 20%; if the value is found to be zero, no discrepancy
%  is reported.

off msg;

for s := 1:4 do
   << write(" ... Testing ", s!*bes(s), " for real domains ... ");
      for each n in t!*bes!*vr do
         for each z in t!*bes!*vr do
      	    pr!*bessel(s, n, z, 5) >>;

on complex;

for s := 1:3 do
   << write (" ... Testing  ", s!*bes(s), " for complex domains ... ");
      for each nr in t!*bes!*vc do
      	 for each ni in t!*bes!*vc do
      	    for each zr in t!*bes!*vc do
      	       for each zi in t!*bes!*vc do
      	       	  pr!*bessel(s, nr+ni*i, zr+zi*i, 9) >>;

off complex;

on msg;

write (" ...");
write ("Bessel test complete.");

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfbinom.red0000644000175000017500000001043611526203062024117 0ustar  giovannigiovannimodule sfbinom;   % Procedures for computing Binomial coefficients
                  % Stirling numbers and such
%
% Author: Winfried Neun, Feb 1993, Sep 1993

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% algebraic operator binomial;  % Now in entry.red.
deflist('((binomial simpiden)),'simpfn);

algebraic <<
 let { binomial (~n,~k) => ((for l:=0:(k-1) product (n-l))/factorial k)
                        when fixp n and fixp k and  k >=0,
       binomial (~n,~k) => 1
                when fixp n and fixp k and n >= k and k=0,
       binomial (~n,~k) => 0
                when fixp n and fixp k and n=0,
       binomial (~n,~k) => 0
                when fixp n and fixp k and k < 0,
       binomial (~n,~k) => Gamma(n+1) / Gamma (k+1) / Gamma(n-k+1)
                when numberp n and  numberp k and not(fixp (n - k) and
                (n-k) < 0),
       df(binomial(~c,~k),c) => binomial(c,k)*(Psi(1+c)-Psi(1+c-k))
     } >>;

% Some rules for quotients of binomials are still missing

algebraic operator Stirling1, Stirling2;

algebraic
 let {Stirling1(~n,~n) => 1,
      Stirling1(~n,0)  => 0 when not(n=0),
      Stirling1(~n,~n-1) => - binomial(n,2),
      Stirling1(~n,~m) => 0 when fixp n and fixp m and n < m,
      Stirling1(~n,~m) => (for k:=0:(n-m) sum
                        ( (-1)^k * binomial(n-1+k,n-m+k) *
                          binomial(2*n-m,n-m-k) * Stirling2(n-m+k,k)))
                when fixp n and fixp m and n > m,
% This rather naive implementation will cause problem
% when m - n is large !
      Stirling2(~n,~n) => 1,
      Stirling2(~n,0)  => 0 when not(n=0),
      Stirling2(~n,~n-1) => binomial(n,2),
      Stirling2(~n,~m) => 0 when fixp n and fixp m and n < m,
      Stirling2(~n,~m) => calc_stirling2(n,m)
                        when fixp n and fixp m and n >m };

algebraic procedure calc_stirling2 (n,m);

begin scalar bin_row;
bin_row := binomial_row(m);
return
((for k:=0:m sum ( (-1)^(m-k)
  * part(bin_row,k+1)*k^n))/factorial(m));
end;


symbolic procedure binomial_row (n);

        % computes nth row of the Pascal triangle

begin scalar list_of_bincoeff, newlist, old, curr;

if (not fixp n) or (n < 0) then return nil;

list_of_bincoeff := { 1 };

while N > 0 do
     << old := 0;
        newlist := {};
        while not(list_of_bincoeff = {}) do
            <<  curr := car list_of_bincoeff;
                newlist := (old + curr) . newlist;
                old := curr;
                list_of_bincoeff := rest list_of_bincoeff;
            >>;
        list_of_bincoeff := 1 . newlist;
        n := n -1
     >>;
return 'list . list_of_bincoeff;

end;

flag('(binomial_row),'opfn);

symbolic procedure Motzkin(n);

if (n:= reval n)=0 then 1 else if n=1 then 1 else
% ((3*n-3)*Motzkin(n-2) + (2*n+1)* Motzkin(n-1))/(n+2);
if not fixp n or n <0 then
         mk!*sq((list((list('motzkin,n) . 1) . 1)) . 1)
   else begin scalar vsop,oldv,newv;
    newv := oldv :=1;
    for i:=2:n do <<
       vsop := oldv;
       oldv := newv;
       newv:= ((3*i-3) * vsop + (2*i +1)*oldv)/(i+2);
       >>;
    return newv;
end;

flag('(motzkin),'opfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn2.red0000644000175000017500000002475111526203062024027 0ustar  giovannigiovannimodule specfn2;  % Part 2 of the Special functions package for REDUCE.
                 % The special Special functions.

% Author : Victor Adamchik, Byelorussian University Minsk, Byelorussia.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Major modifications by: Winfried Neun, ZIB Berlin.


%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %
%                                                                                                                %
%     Please report bugs to Winfried Neun,                                         %
%                                            Konrad-Zuse-Zentrum                                   %
%                                               fuer Informationstechnik Berlin,   %
%                                            Heilbronner Str. 10                                     %
%                           10711 Berlin - Wilmersdorf                 %
%                                            Federal Republic of Germany                        %
%     or by email, neun@sc.ZIB-Berlin.de                                           %
%                                                                                                                %
%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %
%                                                                                                                %
%     This package provides algebraic                                    %
%     manipulations upon some special functions:                    %
%                                                                                                                %
%                   -- Generalized Hypergeometric Functions           %
%                   -- Meijer's G Function                                                  %
%              -- to be extended                                 %
%                                                                                                                %
%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %


create!-package ('(specfn2 ghyper meijerg),
                 '(contrib specfn));

load_package specfn;

%  Various help utilities and smacros for hypergeometric function
%  simplification.

symbolic smacro procedure diff1sq(u,v);
   addsq(u,negsq(v))$

symbolic smacro procedure mksqnew u;
  !*p2f(car fkern(u) .* 1) ./ 1;

symbolic smacro procedure gamsq(u);
 mksqnew('GAMMA . list(prepsq u));

symbolic smacro procedure multgamma u;
   %u -- list of SQ.
   <>; p>>
     where p = '(1 . 1);

symbolic smacro procedure besssq(v,u);
 mksqnew('BesselJ . list(prepsq v,prepsq u))$

symbolic smacro procedure bessmsq(v,u);
 mksqnew('BesselI . list(prepsq v,prepsq u))$

symbolic smacro procedure simppochh(v,u);
 mksqnew('Pochhammer . list(prepsq v,prepsq u))$

symbolic procedure multpochh(u,k);
 << for each pp in u do <
    >; p>>
                 where p = '(1 . 1);

symbolic smacro procedure psisq(v);
 mksqnew('psi . list(prepsq v))$

%symbolic smacro procedure dfpsisq(v,u);
% mksqnew('dfpsi . list(prepsq v,prepsq u))$

symbolic procedure simpfunc(u,v);
 % u -- name of the function, PF.
 % v -- argument, SQ.
 begin scalar l,v1!wq;
 v1!wq:=prepsq v; l:=('!Adamchik . v1!wq);
 u:=subf(car simp!* list(u,'!Adamchik),list l);
 return u $
end$

algebraic operator intsin,intcos,ints,intfs,intfc$

symbolic procedure subsqnew(u,v,z);
% u,v -- SQ.
% z -- PF  .
begin scalar a!1,lp,a;
  a!1:=prepsq v; lp:=((z . a!1));
  a:=quotsq(subf(car u,list lp),subf(cdr u,list lp));
  return a;
end$

symbolic procedure expdeg(x,y);
% x,y -- SQ.
% value is the x**y.
 if null car y then '(1 . 1) else
 if numberp(car y) and numberp(cdr y) then
             simpx1(prepsq x,car y,cdr y) else
 quotsq(expdeg1(car x ./ 1 ,y),expdeg1(cdr x ./ 1 ,y))$

symbolic procedure expdeg1(x,y);
% x,y -- SQ.
% value is the x**y.
simp!*(prepsq(subsqnew(subsqnew(simp!*
      '(expt a!g9 b!!g9),x,'a!g9),y,'b!!g9)))$

symbolic smacro procedure difflist(u,v);
 % u -- list of SQ.
 % v -- SQ.
 % value is (u) - v.
 for each uu in u collect addsq(uu,negsq v);

symbolic procedure listplus(u,v);
% value is (u) + v.
 difflist(u,negsq v)$

 symbolic smacro procedure addlist u;
  % u -- list of PF.
  <>; p>>
    where p = '(nil . 1);

 symbolic smacro procedure listsq(u);
 % u - list of PF.
 % value is list of SQ.
 for each uu in u collect simp!* uu;

symbolic smacro procedure listmin(u);
 % u - list.
 % value is (-u).
 for each uu in u collect negsq uu;

symbolic smacro procedure multlist(u);
<< for each pp in u do <
    >; p>> where p = '(1 . 1);

symbolic procedure parfool u;
  % u -- SQ.
  % value is T if u = 0,-1,-2,...
  if null car u then t
    else
  if and(numberp car u,eqn(cdr u,1),lessp(car u,0)) then t
    else nil$

 symbolic procedure znak u;
 % u -- SQ.
  if numberp u then
     if u > 0 then T else NIL
               else
  if numberp car u then
     if car u > 0 then T else NIL
                   else
  if not null cdar u then T
                     else
  if numberp cdaar u then
     if cdaar u > 0 then T else NIL
                     else
     znak(cdaar u ./ 1)$

 symbolic procedure sdiff(a,b,n);
  % value is (1/b*d/db)**n(a)   .
  % a,n--SQ  b--PF              .
  if null car n then a else
  if and(numberp(car n),numberp(cdr n),eqn(cdr n,1),not lessp(car n,0))
                                        then
     multsq(invsq(simp!* b), diffsq(sdiff(a,b,diff1sq(n, '(1 . 1))),b))
     else
  rerror('specialf,130,"***** error parameter in sdiff")$

 symbolic procedure derivativesq(a,b,n);
  % a -- SQ.
  % b -- ATOM.
  % n -- order, SQ.
 if null n or null car n then a
 else derivativesq(diffsq(a,b),b,diff1sq(n,'(1 . 1)))$

 symbolic procedure addend( u,v,x);
  % u,v -- lists of SQ.
  % x -- SQ.
  cons(diff1sq(car u,x),difflist(v,diff1sq(car u,x)))$

 symbolic procedure parlistfool(u,v);
  %v -- list.
  %value is the T if u-(v)=0,-1,-2,...
  if null v then nil else
  if parfool(diff1sq(u,car v)) then t else
     parlistfool(u,cdr v)$

 symbolic procedure listparfool(u,v);
  %u -- list.
  %value is the T if (u)-v=0,-1,-2,...
  if null u then nil else
  if parfool(diff1sq(car u,v)) then t else
     listparfool(cdr u,v)$

 symbolic procedure listfool u;
  %u -- list.
  %value is the T if any two of the terms (u)
  %differ by an integer or zero.
  if null cdr u then nil else
  if parlistfool(car u,cdr u) or listparfool(cdr u,car u)
     then t else listfool(cdr u)$

 symbolic procedure listfooltwo(u,v);
  %u,v -- lists.
  %value is the T if (u)-(v)=0,-1,-2,...
  if null u then nil else
  if parlistfool(car u,v) then t else
     listfooltwo(cdr u,v)$

 symbolic smacro procedure pdifflist(u,v);
  % u -- SQ.
  % v -- list of SQ.
  %value is a list: u-(v).
 for each vv in v collect diff1sq(u,vv);

symbolic procedure redpar1(u,n);
 % value is a paire, car-part -- sublist of the length n
 %                   cdr-part --  .
 begin scalar bm;
  while u and not(n=0) do begin
    bm:=cons (car u,bm);
    u:=cdr u;
    n:=n-1;
  end;
  return cons(reverse bm,u);
end$

symbolic procedure redpar (l1,l2);
   begin scalar l3;
   while l2 do <<
         if member(car l2 , l1) then l1 := delete(car l2,l1)
                 else l3 := (car l2) . l3 ;
         l2 := cdr l2 >>;
   return list (l1,reverse l3);
   end;

algebraic operator Lommel,Heaviside;

symbolic smacro procedure heavisidesq(u);
 mksqnew('Heaviside . list(prepsq u));

symbolic smacro procedure StruveLsq(v,u);
 mksqnew('StruveL . list(prepsq v,prepsq u));

symbolic smacro procedure StruveHsq(v,u);
 mksqnew('StruveH . list(prepsq v,prepsq u));

symbolic smacro procedure neumsq(v,u);
 mksqnew('BesselY . list(prepsq v,prepsq u));

symbolic smacro procedure simppochh(v,u);
 mksqnew('Pochhammer . list(prepsq v,prepsq u));

symbolic smacro procedure psisq(v);
 mksqnew('psi . list(prepsq v));

symbolic smacro procedure dfpsisq(v,u);
 mksqnew('Polygamma . list(prepsq u,prepsq v));

symbolic smacro procedure Lommel2sq (u,v,w);
 mksqnew('Lommel2  . list(prepsq u,prepsq v,prepsq w));

symbolic smacro procedure tricomisq (u,v,w);
 mksqnew('KummerU . list(prepsq u,prepsq v,prepsq w));

symbolic smacro procedure macdsq (v,u);
 mksqnew('BesselK . list(prepsq v,prepsq u));

fluid '(v1!wq,a!g9,b!!g9);

symbolic smacro procedure sumlist u;
   % u -- list of the PF
   <>; p>>
    where p = '(nil . 1);

symbolic smacro procedure difflist(u,v);
 % u -- list of SQ.
 % v -- SQ.
 % value is (u) - v.
 for each uu in u collect addsq(uu,negsq v);

symbolic smacro procedure addlist u;
   % u -- list of PF.
   <>; p>>
    where p = '(nil . 1);

symbolic smacro procedure diff1sq(u,v);
  addsq(u,negsq(v));

symbolic smacro procedure listsq(u);
 % u - list of PF.
 % value is list of SQ.
 for each uu in u collect simp!* uu;

symbolic smacro procedure listmin(u);
 % u - list.
 % value is (-u).
 for each uu in u collect negsq uu;

symbolic smacro procedure multlist(u);
<< for each pp in u do <
    >; p>> where p = '(1 . 1);

symbolic smacro procedure pdifflist(u,v);
  % u -- SQ.
  % v -- list of SQ.
  %value is a list: u-(v).
 for each vv in v collect diff1sq(u,vv);

symbolic smacro procedure listprepsq(u);
 for each uu in u collect prepsq uu;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfairy.red0000644000175000017500000004436111526203062023763 0ustar  giovannigiovannimodule sfairy;  % Procedures and Rules for the Airy functions.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%***********************************************************************
%
%The following is the code to evaluate Airy Functions and their primes
%using REDUCE.
%
%Author: Stephen Scowcroft                        Date: September 1994
%
%***********************************************************************

%The first section deals with code that evaluates the Airy Functions.
%The second deals with code that evaluates the Airyprime Functions.

%For the sake of efficiency a recursive approach has been taken for all
%expressions. As a result the equations do not directly resemble those
%given in "The Handbook of Mathematical Functions" (Abramowitz & Stegun)
%although this is the source of the expressions.

% The following procedures evaluate the fseries and gseries which are
% used in the ascending series approach to calculating Airy_Ai and
% Airy_Bi.

algebraic procedure myfseries(z);

%Declared local variables used throughout the procedure.

  begin scalar summ,accu,term,zcube,int1,int2;

%These are the initial values of variables used in the procedure.

     summ := 1;
     int1 := 2;
     int2 := 3;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1;
     zcube := (z ^ 3);

%This loop calculates term without a check with the accuracy. As a
%result the code is faster and more efficient.

     for kk:=0:30 do
     <<  term := term * zcube / ((int1) * (int2));
         summ := summ + term;
         int1 := int1 + 3;
         int2 := int2 + 3;
      >>;

%Now the check against the accuracy is carried out in order to bring the
% infinite sum to an approximate summation for use later on.

     while abs(term) > accu do
     <<  term := term * zcube / ((int1) * (int2));
         summ := summ + term;
         int1 := int1 + 3;
         int2 := int2 + 3;
      >>;

%The value of the infinite sum is then returned for use in calculating
%the function.

  return summ;

end;

%This is similar to the above code. As a result the comments above
%are valid here.

algebraic procedure mygseries(z);

  begin scalar k,summ,accu,term,zcube,int1,int2;
     summ := z;
     int1 := 3;
     int2 := 4;
     accu := 10 ^(-(symbolic !:prec!:));
     term := summ;
     zcube := (z ^ 3);

     for kk:=0:30 do
     << term := term * zcube / ((int1)* (int2));
        summ := summ + term;
        int1 := int1 + 3;
        int2 := int2 + 3;
      >>;

     while abs(term) > accu do
     << term := term * zcube / ((int1)* (int2));
        summ := summ + term;
        int1 := int1 + 3;
        int2 := int2 + 3;
      >>;

  return summ;
end;

%The following procedure calls the above f and g series in order to
%calculate the Airy_Ai and Airy_Bi for specific values of z.
%There is one expression for either the Ai or Bi evaluation. This is
%because each is similar.

%The code selects which expression to calculate depending on the value
%of proc. This is done automatically every time the procedure is called.

algebraic  procedure airya2(z,proc);

  begin scalar c1,c2,summ,oldprec;

%In order to calculate the infinite sums with a high accuracy, the
%precision is changed using the following code.
%This is done automatically each time the function is called. The
%precision is then reset to the original value.

   oldprec := precision 0;
   precision (oldprec + 10);

%Initial value used within the equation.

   c1 := (3 ^ (-2/3)) / gamma(2/3);
   c2 := (3 ^ (-1/3)) / gamma(1/3);

%This part selects automatically either Ai or Bi depending on proc.

   if proc=ai then summ := (c1 * myfseries(z)) - (c2 * mygseries(z))
   else summ := sqrt(3) *  ((c1 * myfseries(z)) + (c2 * mygseries(z)));
   precision (oldprec);

 return summ;

 end;

%The following code is the procedures for calculating the infinite sums
%used in the evaluation of the asymptotic expansions of Airy Functions.

%Again this code is used in the expression for Ai and Bi. As a result
%depending on the value of proc the correct one is called.

algebraic procedure asum1(z,proc);

  begin scalar p,k,summ,accu,term,zterm;

%Initial values that are used within the procedure.

     summ := 1;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1 ;
     zterm := (2/3 * (z ^ (3/2)));

%A check to see when the infinite sum should be stopped.

     while abs(term) > accu do
     <<
        term := term * ((if proc=ai then -1 else 1) * ((3k-1/2) *
                 (3k-3/2) * (3k-5/2))
                   / (54 * (k) * (k-1/2))) / zterm;
        summ := summ + term;
        k := k+1;
      >>;

  return summ;
end;

%The following are similar to the code for asum1. As a result the above
%comments apply.

algebraic procedure asum2(z);

  begin scalar p,k,summ,accu,term,sqzterm,sqnum;
     summ := 1;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1;
     sqzterm := (2/3 * (z ^ (3/2))) ^ 2;
     sqnum := (54 ^ 2);

     while abs(term) > accu do
     <<  term := term * ((-1) * ((6k-5.5)*(6k-4.5)*(6k-3.5)*(6k-2.5)
                      *(6k-1.5)*(6k-0.5) / (sqnum * (2k)*(2k-1)
                      *(2k-1.5)*(2k-0.5)))) / sqzterm;

         summ := summ + term;
         k := k+1;
      >>;

  return summ;
end;


algebraic procedure asum3(z);

  begin scalar p,k,summ,accu,term,zterm,sqzterm,sqnum;
     zterm := (2/3 * (z ^ (3/2)));
     sqzterm := zterm ^ 2;
     sqnum := 54 ^ 2;
     summ := ((3/2)*(5/2) / 54) / zterm;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := ((3/2)*(5/2) / 54) / zterm;

     while abs(term) > accu do
     <<  term := term * ((-1) * ((6k+3)-1/2)*((6k+3)-3/2)*
                        ((6k+3)-5/2)*((6k+3)-7/2)*((6k+3)-9/2)
                       *((6k+3)-11/2)
                         /( sqnum * (2k)*(2k+1)
                      *((2k -1/2)*(2k+1/2)))) / sqzterm;

         summ := summ + term;
         k := k+1;
      >>;

  return summ;
end;

%There are two procedures depending on certain criteria for the arg of z
%for both Ai and Bi. They are asymptotic for large values of (-z) and z
%respectively. The choice as to which one is called for large values of
%z is determined in later code.

%Once again, as the expression for Ai and Bi is similar the code has
%been combined.

algebraic procedure asairyam(minusz,proc);

  begin scalar tt,p,ee,summ;
    z := - minusz;
    tt := (z ^ (-1/4));
    p := (pi ^ (-1/2));
    ee := (2/3 * (z ^ (3/2))) + (pi/4);

    if proc=ai then summ := tt * p * ((sin(ee) * asum2(z)) - (cos(ee)
                 * asum3(z)))
    else summ := tt * p * ((cos(ee) * asum2(z)) + (sin(ee) * asum3(z)));
    return summ;
   end;



algebraic procedure asairyap(z,proc);

  begin scalar tt,p,ee,summ;
    tt := (z ^ (-1/4));
    p := (pi ^ (-1/2));
    ee := e ^ ((if proc=ai then -1 else 1)*(2/3 * (z ^ (3/2))));
    if proc=ai then summ := (1/2) * tt * p * ee * asum1(z,ai)
    else summ := tt * p * ee * asum1(z,bi);
    return summ;
   end;

%The following section are the procedures that deal with the evaluation
%of the Airyprime functions.

%Similarly f and g series are calculated for use within the standard
%series approach. The same techniques for obtaining efficiency that were
%used in the code above are used here. As a result comments above apply.


algebraic procedure myfseriesp(z);

  begin scalar k,summ,accu,term,zcube,int1,int2;
     summ := ((z^2) / 2);
     int1 := 3;
     int2 := 5;
     accu := 10 ^(-(symbolic !:prec!:));
     term := ((z^2) / 2);
     zcube := z ^ 3;

     for kk:=0:30 do
     <<  term := term * zcube / ((int1) * (int2));
         summ := summ + term;
         int1 := int1 + 3;
         int2 := int2 + 3;
      >>;

     while abs(term) > accu do
     <<  term := term * zcube / ((int1) * (int2));
         summ := summ + term;
         int1 := int1 + 3;
         int2 := int2 + 3;
      >>;

  return summ;

end;

algebraic procedure mygseriesp(z);

  begin scalar k,summ,accu,term,zcube,int1,int2;
     summ := 1;
     int1 := 3;
     int2 := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1;
     zcube := z ^ 3;

     for kk:=0:30 do
     << term := term * zcube / ((int1) * (int2));
        summ := summ + term;
        int1 := int1 + 3;
        int2 := int2 + 3;
      >>;

     while abs(term) > accu do
     << term := term * zcube / ((int1) * (int2));
        summ := summ + term;
        int1 := int1 + 3;
        int2 := int2 + 3;
      >>;

  return summ;
end;

%Once again, the code for Aiprime and  Biprime is similar and have been
%combined.

algebraic procedure airyap(z,proc);

  begin scalar c1,c2,summ,oldprec;
  oldprec := precision 0;
  precision (oldprec + 10);
  c1 := (3 ^ (-2/3)) / gamma(2/3);
  c2 := (3 ^ (-1/3)) / gamma(1/3);
  if proc=aiprime
    then summ := (c1 * myfseriesp(z)) - (c2 * mygseriesp(z))
   else summ :=  sqrt(3)*((c1 * myfseriesp(z)) + (c2 * mygseriesp(z)));
  precision(oldprec);
  return summ;
end;

%The following are the procedures for calculating the infinite sums used
%in the evaluation of the asymptotic expansion of Airyprime functions.

algebraic procedure apsum1(z,proc);

  begin scalar p,k,summ,accu,term,zterm;
     summ := 1;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1;
     zterm := 2/3 * (z ^ (3/2));

     while abs(term) > accu do
     <<
        term := term * ((if proc=aiprime then -1 else 1)
                       * ((6k-7)/(6k-5) * (6k+1)/(6k-1))
                         *((3k -1/2)*(3k-3/2)*(3k-5/2)) /
                       (54 * k * (k-1/2))) / zterm;
         summ := summ + term;
         k := k+1
      >>;

  return summ;
end;

algebraic procedure apsum2(z);

  begin scalar p,k,summ,accu,term,sqzterm,sqnum;
     summ := 1;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := 1;
     sqzterm := ((2/3 * (z ^ (3/2))) ^ 2);
     sqnum := (54 ^2);

     while abs(term) > accu do
     <<  term := term * ((-1) * ((12k-13)/(12k-11) * (12k+1)/(12k-1))
                 *((6k-5.5)*(6k-4.5)*(6k-3.5)*(6k-2.5)*(6k-1.5)
                  *(6k-0.5)) / (sqnum*(2k)*(2k-1)*(2k-1.5)*(2k-0.5))
                / sqzterm);
         summ := summ + term;
         k := k+1
      >>;

  return summ;
end;

algebraic procedure apsum3(z);

  begin scalar p,k,summ,accu,term,zterm,sqzterm,sqnum;
     zterm := (2/3 * (z ^ (3/2)));
     sqzterm := zterm ^2;
     sqnum := 54 ^ 2;
     summ := (-7/5) * ((3/2)*(5/2) / 54)/ zterm;
     k := 1;
     accu := 10 ^(-(symbolic !:prec!:));
     term := (-7/5) * ((3/2)*(5/2) / 54)/ zterm;

     while abs(term) > accu do
     <<  term := term * ((-1) * ((12k-7)/(12k-5) * (12k+7)/(12k+5)))
                 *((6k+3)-1/2)*((6k+3)-3/2)*((6k+3)-5/2)*((6k+3)-7/2)*
                 ((6k+3)-9/2)*((6k+3)-11/2) / (sqnum * (2k)*(2k+1) *
                 ((2k-1/2)*(2k+1/2)))/ sqzterm;
         summ := summ + term;
         k := k+1
      >>;

  return summ;
end;

%Once again the procedures which call the above infinite sums to
%calculate Aiprime and Biprime have been combined.

algebraic procedure airyapp(z,proc);

  begin scalar tt,p;
    tt := (z ^ (1/4));
    p := (pi ^ (-1/2));
    ee := e ^ ((if proc=aiprime then -1 else 1)*(2/3 * (z ^ (3/2))));
    if proc=aiprime then summ := (1/2) * tt * p * ee * apsum1(z,ai)
    else summ := tt * p * ee * apsum1(z,bi);
    return summ;
   end;


algebraic procedure airyapm(z,proc);

  begin scalar tt,p,ee,summ;
    tt := (z ^ (1/4));
    p := (pi ^ (-1/2));
    ee := (2/3 * (z ^ (3/2))) + (pi/4);
    if proc=aiprime then summ := tt * (-p) * ((cos(ee) * apsum2(z))
                 + (sin(ee) * apsum3(z)))
    else summ := tt*p*((cos(ee) * apsum2(z)) - (sin(ee) * apsum3(z)));
    return summ;
   end;


%When using both standard series and asymptotic approaches for the
%evaluation of Airy functions, there is a point when it is more
%efficient to use the asymptotic approach.

%It therefore remains to choose a value of z where this change over
%occurs. This choice depends on the precision desired.
%A table showing various values of z and the given precision where the
%change should take place was found. This has been implemented below.

%The table appears in a paper called "Numerical Evaluation of airy
%functions with complex arguments" (Corless,Jefferey,Rasmussen),
%J. Comput Phys. 99(1992), 106-114"

algebraic procedure Ai_Asymptotic(absz);

    begin scalar prec;
       prec := lisp !:prec!:;
       return
         if prec <= 6 and absz > 5 then 1
         else if prec <= 12 and absz > 8 then 1
         else if prec <= 16 and absz > 10 then 1
         else if prec <= 23 and absz > 12 then 1
         else if prec <= 33 and absz > 15 then 1
         else 0 ;
    end;

%Finally the following code deals with selecting the correct approach a
%function should take, depending on z, the above table and the upper
%bounds of the asymptotic functions.

%This procedure also allows for the user to call the correct evaluation
%of an Airy function from the Reduce command line argument.

algebraic procedure num_airy(z,fname);

   begin scalar summ;

%This is the procedure to evaluate Airy_ai of z.

 if fname = Ai then <<
    if Ai_Asymptotic(abs(z)) = 1 then
        <>
     else summ := airya2(z,ai);

   return summ; >>

%This is the procedure to evaluate Airy_bi of z.
%Similar procedures for Airy_aiprime and Airy_biprime follow.

 else if fname = Bi then <<
     if Ai_Asymptotic(abs(z)) = 1 then
<<    if abs(arg(-z)) < ((2/3)*pi) then summ := asairyam(z,bi)
       else if abs(arg(z)) < ((1/3)*pi)  then summ := asairyap(z,bi);
>>
   else summ := airya2(z,bi);
    return summ; >>

 else if fname = Aiprime then <<
      if Ai_Asymptotic(abs(z)) = 1 then
<<
       if abs(arg(-z)) < (2/3) * pi then summ := airyapm(z,aiprime)
       else if abs(arg(z)) < pi then summ := airyapp(z,aiprime);
>>
       else summ := airyap(z,aiprime);
    return summ; >>

 else if fname = Biprime then <<
       if Ai_Asymptotic(abs(z)) = 1 then
<<
       if abs(arg(-z)) < ((2/3)*pi) then summ := airyapm(z,biprime)
       else if abs(arg(z)) < ((1/3)*pi) then summ := airyapp(z,biprime);
>>
       else  summ := airyap(z,biprime);
       return summ;>>

   end;


algebraic <<
operator Airy_Ai, Airy_Bi, Airy_Aiprime, Airy_Biprime;

%The following deals with the trivial cases of all of the Airy and
%Airyprime functions. It also calls the above code to allow the user to
%evaluate each of the four Airy function cases respectively.
%The rule for differentiation are also described.

Airy_rules := { Airy_Ai(0) => (3 ^ (-2/3)) / gamma(2/3),
                Airy_Ai(~z) => num_airy (z,Ai)
                        when symbolic !*rounded and numberp z,
                df(Airy_Ai(~z),z) => Airy_Aiprime(z),

                Airy_Bi(0) => sqrt(3) * (3 ^ (-2/3)) / gamma(2/3),
                Airy_Bi(~z) => num_airy (z,Bi)
                        when symbolic !*rounded and numberp z,
                df(Airy_Bi(~z),z) => Airy_Biprime(z),

                Airy_Aiprime(0) => -((3 ^ (-1/3)) / gamma(1/3)),
                Airy_Aiprime(~z) => num_airy (z,Aiprime)
                        when symbolic !*rounded and numberp z,
                df(Airy_Aiprime(~z),z) => z * Airy_Ai(z),

                Airy_Biprime(0) => sqrt(3) * (3 ^ (-1/3)) / gamma(1/3),
                Airy_Biprime(~z) => num_airy (z,Biprime)
                        when symbolic !*rounded and numberp z,
                df(Airy_Biprime(~z),z) => z * Airy_Bi(z)
               };

%This activates the above rule set.

let Airy_rules;

%The following is an inactive rule set that can be activated by the user
%if desired.
%When activated, it will represent the Airy functions in terms of Bessel
%Functions.

Airy2Bessel_rules :=
{ Airy_Ai(~z) => (1/3) * sqrt(z) * << (BesselI(-1/3,ee) -
                 BesselI(1/3,ee))
                  where ee => (2/3 * (z ^ (3/2))) >>
                  when numberp z and repart z >=0 ,

Airy_Ai(~minusz) => <<(sqrt(z/3) * BesselJ(1/3,ee) + BesselJ(-1/3,ee))
                  where {ee => (2/3 * (z ^ (3/2))) , z => -minusz} >>
                  when numberp z and repart z <=0,

Airy_Aiprime(~z) => -(z/3 * << (BesselI(-2/3,ee) - BesselI(2/3,ee))
                  where ee => (2/3 * (z ^ (3/2))) >>)
                  when numberp z and repart z >=0,

Airy_Aiprime(~minusz) => << (-(z)/3) * (BesselJ(-2/3,ee) -
                 BesselJ(2/3,ee))
                   where {ee => (2/3 * (z ^ (3/2))) , z => -minusz} >>
                   when numberp z and repart z <=0,

Airy_Bi(~z) => sqrt(z/3) * << (BesselI(-1/3,ee) + BesselI(1/3,ee))
                   where ee => (2/3 * (z ^ (3/2))) >>
                   when numberp z and repart z >=0,

Airy_Bi(~minusz) => << sqrt(z/3) * (BesselJ(-1/3,ee) - BesselJ(1/3,ee))
                   where {ee => (2/3 * (z ^ (3/2))) , z => -minusz}>>
                   when numberp z and repart <=0,

Airy_Biprime(~z) => (z / sqrt(3)) * << (BesselI(-2/3,ee)
                         + BesselI(2/3,ee))
                   where ee => (2/3 * (z ^ (3/2))) >>
                   when numberp z and repart z >=0,

Airy_Biprime(~minusz) => <<(z/sqrt(3)) * (BesselJ(-2/3,ee)
                         + BesselJ(2/3,ee))
                   where {ee => (2/3 * (z ^ (3/2))) , z => -minusz} >>
                   when numberp z and repart z <=0
};

>>;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfellip.red0000644000175000017500000014032011526203062024114 0ustar  giovannigiovannimodule sfellip;  % Procedures and Rules for Elliptic functions.

% Author: Lisa Temme, ZIB, October 1994

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

%ARITHMETIC GEOMETRIC MEAN

%The following procedure is the process of the Arithmetic Geometric
%Mean.

procedure AGM_function(a0,b0,c0);

   begin scalar aN, bN, cN, aN!-1, bN!-1, alist, blist, clist;

     %Initial values.

        aN!-1 := a0;
        bN!-1 := b0;
        cN    := 20; %To initiate while loop below.

     %Put initial values at end of list.

        alist := {a0}$
        blist := {b0}$
        clist := {c0}$

     %Loop to generate lists of aN,bN and cN starting with the Nth
     %value and ending with the initial value.

     %When the absolute value of cN reaches a value smaller than that
     %of the required precision the loop exits. The value of aN=bN=AGM.

        while abs(cN) > 10^(-(Symbolic !:prec!:)) do

           << %Calculations for the process of the AGM

                aN := (aN!-1 + bN!-1) / 2;
                bN := sqrt(aN!-1 * bN!-1);
                cN := (aN!-1 - bN!-1) / 2;

             %Adding the next term to each of the lists.

                alist := aN.alist;
                blist := bN.blist;
                clist := cN.clist;

             %Resetting the values in order to execute the next loop.

                aN!-1 := aN;
                bN!-1 := bN
           >>;

     %N is the number of terms in each list (excluding the initial
     % values) used to calculate the AGM.

        N := LENGTH(alist) - 1;

     %The following list contains all the items required in the
     %calculation of other procedures which use the AGM
     %ie. {N, AGM, {aN to a0},{bN to b0},{cN to c0}}

        return list(N ,aN, alist, blist, clist)

   end;
%######################################################################
%CALCULATING PHI
%               N


%The following procedure sucessively computes phi   ,phi   ,...,phi ,
%                                                N-1    N-2        0
%from the recurrence relation:
%
%       sin(2phi    - phi ) = (c /a )sin phi
%               N-1      N       N  N          N
%
%and returns a list of phi  to phi . This list is then used in the
%                        0        N
%calculation of Jacobisn, Jacobicn, Jacobidn, which in turn are used
%to calculate the remaining twelve Jacobi Functions.


procedure PHI_function(a0,b0,c0,u);

   begin scalar alist, clist,N,a_n,aN,cN,i, phi_N, phi_N!-1, phi_list;

        agm   := AGM_function(a0,b0,c0);
        alist := PART(agm,3);              % aN to a0
        clist := PART(agm,5);              % cN to c0
        N := PART(agm,1);
        a_n := PART(alist,1);              % Value of the AGM.
        phi_N := (2^N)*a_n*u;
        phi_list := {phi_N}$
        i := 1;

        while i < LENGTH(alist) do

           <<
                aN := PART(alist,i);
                cN := PART(clist,i);

                phi_N!-1 := (asin((cN/aN)*sin(phi_N)) + phi_N) / 2;
                phi_list := phi_N!-1.phi_list;
                phi_N := phi_N!-1;
                i := i+1
           >>;

     %Returns {phi_0 to phi_N}.

        return phi_list;

   end;

%######################################################################
%JACOBI AMPLITUDE


%This computes the Amplitude of u.

procedure Amplitude(u,m);
        asin(Jacobisn(u,m));

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

operator JacobiAmplitude;

JacobiAMrules :=

{
        JacobiAmplitude(~u,~m) => Amplitude(u,m) when lisp !*rounded
                                         and numberp u and numberp m
}$

let JacobiAMrules;

%######################################################################
%JACOBI FUNCTIONS

%Increases the precision used to evaluate algebraic arguments.

symbolic procedure  Num_JACOBI (u);
% check that length u >= 3 !
 if length u < 3 then
         rederr "illegal call to num_jacobisn" else
   begin scalar oldprec,res;
     oldprec := precision 0;
     precision max(oldprec,15);

    res :=  aeval u;
    precision oldprec;
    return res;

  end;

put('Num_Elliptic, 'psopfn, 'Num_JACOBI);

%######################################################################
%This procedure is called by Jacobisn when the on rounded switch is
%used. It evaluates the value of Jacobisn numerically.


procedure Num_Jacobisn(u,m);

   begin scalar phi0, Jsn;
        phi0 := PART(PHI_function(1,sqrt(1-m),sqrt(m),u),1);
        Jsn := sin(phi0);
        return Jsn
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobisn definition
%===================

operator Jacobisn;
operator EllipticK!';
operator EllipticK;

%This rule list includes all the special cases of the Jacobisn
%function.

JacobiSNrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobisn(~u,0)   => sin u,
        Jacobisn(~u,1)   => tanh u,
        Jacobisn(~u,-~m) => Jacobisn(u,m),
%Change of argument
%------------------
        Jacobisn(~u + ~v,~m) =>
                ( Jacobisn(u,m)*Jacobicn(v,m)*Jacobidn(v,m)
                + Jacobisn(v,m)*Jacobicn(u,m)*Jacobidn(u,m) )
                / (1-m*((Jacobisn(u,m))^2)*((Jacobisn(v,m))^2)),

        Jacobisn(2*~u,~m) =>
                ( 2*Jacobisn(u,m)*Jacobicn(u,m)*Jacobidn(u,m) )
                / (1-m*((Jacobisn(u,m))^4)),

        Jacobisn(~u/2,~m) =>
                ( 1- Jacobicn(u,m) ) / ( 1 + Jacobidn(u,m) ),


        Jacobisn(-~u,~m) => -Jacobisn(u,m),
        Jacobisn((~u+EllipticK(~m)),~m)   =>  Jacobicd(u,m),
        Jacobisn((~u-EllipticK(~m)),~m)   => -Jacobicd(u,m),
        Jacobisn((EllipticK(~m)-~u),~m)   =>  Jacobicd(u,m),
        Jacobisn((~u+2*EllipticK(~m)),~m) => -Jacobisn(u,m),
        Jacobisn((~u-2*EllipticK(~m)),~m) => -Jacobisn(u,m),
        Jacobisn((2*EllipticK(~m)-~u),~m) =>  Jacobisn(u,m),
        Jacobisn(~u+i*EllipticK!'(~m),~m) => (m^(-1/2))*Jacobins(u,m),

        Jacobisn((~u+2*i*EllipticK!'(~m)),~m) => Jacobisn(u,m),

        Jacobisn((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                              (m^(-1/2))*Jacobidc(u,m),

        Jacobisn((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobisn(u,m),
%Special Arguments
%-----------------
        Jacobisn(0,~m) => 0,

        Jacobisn((1/2)*EllipticK(~m),~m) =>1/((1+((1-m)^(1/2)))^(1/2)),

        Jacobisn(EllipticK(~m),~m) => 1,

        Jacobisn((1/2)*i*EllipticK!'(~m),~m) => i*m^(-1/4),

        Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                            (2^(-1/2))*m^(-1/4)*(((1+(m^(1/2)))^(1/2))
                                            + i*((1-(m^(1/2)))^(1/2))),

        Jacobisn(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) => m^(-1/4),

        Jacobisn(i*EllipticK!'(~m),~m) => infinity,

        Jacobisn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                              (1-((1-m)^(1/2)))^(-1/2),

        Jacobisn(EllipticK(~m)+i*EllipticK!'(~m),~m) => m^(-1/2),


%Derivatives, Integral
%---------------------
        df(Jacobisn(~u,~m),~u)  => Jacobicn(u,m)*Jacobidn(u,m),
        df(Jacobisn(~u,~m),~m)  => (m*Jacobisn(u,m)*Jacobicn(u,m)^2
                        - EllipticE(u,m)*Jacobicn(u,m)*Jacobidn(u,m)/m)
                        / (1-(m^2)) +  u*Jacobicn(u,m)*Jacobidn(u,m)/m,

        int(Jacobisn(~u,~m),~u) =>
                (m^(-1/2))*ln(Jacobidn(u,m)-(m^(1/2))*Jacobicn(u,m)),

%Calls Num_Jacobisn when the rounded switch is on.
%-------------------------------------------------
        Jacobisn(~u,~m) => Num_Elliptic(Num_Jacobisn, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m and IMPART(u) = 0,

        Jacobisn(~u,~m) => Num_Elliptic(complex_SN, u, m)
                           when lisp !*rounded and numberp repart u
                           and numberp impart u and numberp m
                           and IMPART(u) neq 0

}$
let JacobiSNrules;

%......................................................................
%Evaluates Jacobisn when imaginary argument.

operator complex_SN;
SNrule :=
{

        complex_SN(i*~u,~m) => i*Num_Jacobisc(u,1-m),

        complex_SN(~x + i*~y,~m) =>
                ( Num_Jacobisn(x,m)*Num_Jacobidn(y,1-m)
                + i*Num_Jacobicn(x,m)*Num_Jacobidn(x,m)
                   *Num_Jacobisn(y,1-m)*Num_Jacobicn(y,1-m) )
                / (((Num_Jacobicn(y,1-m))^2)+
                   m*((Num_Jacobisn(x,m))^2)*((Num_Jacobisn(y,1-m))^2))
}$
let SNrule;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobicn when the on rounded switch is
%used. It evaluates the value of Jacobicn numerically.

procedure Num_Jacobicn(u,m);

   begin scalar phi0, Jcn;
        phi0 := PART(PHI_function(1,sqrt(1-m),sqrt(m),u),1);
        Jcn := cos(phi0);
        return Jcn
   end;
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobicn definition
%===================

operator Jacobicn;

%This rule list includes all the special cases of the Jacobicn
%function.

JacobiCNrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobicn(~u,0)   => cos u,
        Jacobicn(~u,1)   => sech u,
        Jacobicn(~u,-~m) => Jacobicn(u,m),
%Change of Argument
%------------------
        Jacobicn(~u + ~v,~m) =>
                ( Jacobicn(u,m)*Jacobicn(v,m) - Jacobisn(u,m)
                   *Jacobidn(u,m)*Jacobisn(v,m)*Jacobidn(v,m) )
                / (1 - m*((Jacobisn(u,m))^2)*((Jacobisn(v,m))^2)),

        Jacobicn(2*~u,~m) =>
                ( ((Jacobicn(u,m))^2) - ((Jacobisn(u,m))^2)
                  *((Jacobidn(u,m))^2) )
                / (1- m*((Jacobisn(u,m))^4)),

        Jacobicn(~u/2,~m) =>
                ( Jacobidn(u,m) + Jacobicn(u,m) )
                / ( 1 + Jacobidn(u,m) ),

        Jacobicn(-~u,~m) => Jacobicn (u,m),

        Jacobicn((~u+EllipticK(~m)),~m) =>-((1-m)^(1/2))*Jacobisd(u,m),
        Jacobicn((~u-EllipticK(~m)),~m) => ((1-m)^(1/2))*Jacobisd(u,m),
        Jacobicn((EllipticK(~m)-~u),~m) => ((1-m)^(1/2))*Jacobisd(u,m),
        Jacobicn((~u+2*EllipticK(~m)),~m) => -Jacobicn(u,m),
        Jacobicn((~u-2*EllipticK(~m)),~m) => -Jacobicn(u,m),
        Jacobicn((2*EllipticK(~m)-~u),~m) => -Jacobicn(u,m),
        Jacobicn((~u+i*EllipticK!'(~m)),~m) =>
                                            -i*(m^(-1/2))*Jacobids(u,m),

        Jacobicn((~u+2*i*EllipticK!'(~m)),~m) => -Jacobicn(u,m),

        Jacobicn((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                             -i*((1-m)^(1/2))*(m^(-1/2))*Jacobinc(u,m),

        Jacobicn((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                         Jacobicn(u,m),
%Special Arguments
%-----------------
        Jacobicn(0,~m) => 1,

        Jacobicn((1/2)*EllipticK(~m),~m) =>
                                 ((1-m)^(1/4))/(1+((1-m)^(1/2)))^(1/2),

        Jacobicn(EllipticK(~m),~m) => 0,

        Jacobicn((1/2)*i*EllipticK!'(~m),~m) =>
                                       ((1+(m^(1/2)))^(1/2))/(m^(1/4)),

        Jacobicn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                           (((1-m)/(4*m))^(1/4))*(1-i),

        Jacobicn(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                  -i*(((1-(m^(1/2)))/(m^(1/2))))^(1/2),

        Jacobicn(i*EllipticK!'(~m),~m) => infinity,

        Jacobicn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                          -i*((((1-m)^(1/2))/(1-((1-m)^(1/2))))^(1/2)),

        Jacobicn(EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                  -i*(((1-m)/m)^(1/2)),
%Derivatives, Integral
%---------------------
        df(Jacobicn(~u,~m),~u)  => -Jacobisn(u,m)*Jacobidn(u,m),
        df(Jacobicn(~u,~m),~m)  => (-m*(Jacobisn(u,m)^2)*Jacobicn(u,m)
                                   + EllipticE(u,m)*Jacobisn(u,m)
                                     *Jacobidn(u,m)/m)/(1-(m^2))
                                   - u*Jacobisn(u,m)*Jacobidn(u,m)/m,

        int(Jacobicn(~u,~m),~u) => (m^(-1/2))*acos(Jacobidn(u,m)),

%Calls Num_Jacobicn when rounded switch is on.
%---------------------------------------------
        Jacobicn(~u,~m) => Num_Elliptic(Num_Jacobicn, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m and IMPART(u) = 0,

        Jacobicn(~u,~m) => Num_Elliptic(complex_CN, u, m)
                           when lisp !*rounded and numberp repart u
                           and numberp impart u and numberp m
                           and IMPART(u) neq 0
}$
let JacobiCNrules;

%......................................................................
%Evaluates Jacobicn when imaginary argument.

operator complex_CN;
CNrule :=
{

        complex_CN(i*~u,~m) => Num_Jacobinc(u,1-m),

        complex_CN(~x + i*~y,~m) =>

                ( Num_Jacobicn(x,m)*Num_Jacobicn(y,1-m)
                - i*Num_Jacobisn(x,m)*Num_Jacobidn(x,m)
                   *Num_Jacobisn(y,1-m)*Num_Jacobidn(y,1-m) )
                / (((Num_Jacobicn(y,1-m))^2)+
                   m*((Num_Jacobisn(x,m))^2)*((Num_Jacobisn(y,1-m))^2))
}$
let CNrule;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobidn when the on rounded switch is
%used. It evaluates the value of Jacobidn numerically.

procedure Num_Jacobidn(u,m);
   begin scalar PHI, phi0,  phi1, numer, denom, Jdn;
        PHI  := PHI_function(1,sqrt(1-m),sqrt(m),u);
        phi0 := PART(PHI,1);
        phi1 := PART(PHI,2);
        numer := cos(phi0);
        denom := cos(phi1 - phi0);

        if denom < 10^(-(Symbolic !:prec!:))
        then  Jdn := otherDN(u,m)
        else  Jdn := numer/denom;
        return Jdn
   end;

procedure otherDN(u,m);
   begin scalar mu, v, dn;
        mu := ((1-((1-m)^(1/2))) / (1+((1-m)^(1/2))))^2;
        v  := u / (1+(mu^(1/2)));

        dn := ((approx(v,mu))^2 - (1-(mu^(1/2))))

                / ((1+(mu^(1/2))) - (approx(v,mu))^2);
        return dn
   end;


procedure approx(u,m);
   begin scalar near;
        near := 1 - (1/2)*m*(sin(u))^2;
        return near
   end;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobidn definition
%===================

operator Jacobidn;

%This rule list includes all the special cases of the Jacobidn
%function.

JacobiDNrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobidn(~u,0)   => 1,
        Jacobidn(~u,1)   => sech u,
        Jacobidn(~u,-~m) => Jacobidn(u,m),
%Change of Argument
%------------------
        Jacobidn(~u + ~v,~m) =>
                ( Jacobidn(u,m)*Jacobidn(v,m) - m*Jacobisn(u,m)
                   *Jacobicn(u,m)*Jacobisn(v,m)*Jacobicn(v,m) )
                / (1 - m*((Jacobisn(u,m))^2)*((Jacobisn(v,m))^2)),

        Jacobidn(2*~u,~m) =>
                (  ((Jacobidn(u,m))^2) - m*((Jacobisn(u,m))^2)
                  *((Jacobicn(u,m))^2) )
                / (1- m*((Jacobisn(u,m))^4)),

        Jacobidn(~u/2,~m) =>
                ( (1-m) + Jacobidn(u,m) + m*Jacobicn(u,m))
                / ( 1 + Jacobidn(u,m) ),

        Jacobidn(-~u,~m) => Jacobidn(u,m),

        Jacobidn((~u+EllipticK(~m)),~m) => ((1-m)^(1/2))*Jacobind(u,m),
        Jacobidn((~u-EllipticK(~m)),~m) => ((1-m)^(1/2))*Jacobind(u,m),
        Jacobidn((EllipticK(~m)-~u),~m) => ((1-m)^(1/2))*Jacobind(u,m),
        Jacobidn((~u+2*EllipticK(~m)),~m) => Jacobidn(u,m),
        Jacobidn((~u-2*EllipticK(~m)),~m) => Jacobidn(u,m),
        Jacobidn((2*EllipticK(~m)-~u),~m) => Jacobidn(u,m),
        Jacobidn((~u+i*EllipticK!'(~m)),~m)   => -i*Jacobics(u,m),
        Jacobidn((~u+2*i*EllipticK!'(~m)),~m) => -Jacobidn(u,m),

        Jacobidn((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                         i*((1-m)^(1/2))*Jacobisc(u,m),

        Jacobidn((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobidn(u,m),
%Special Arguments
%-----------------
        Jacobidn(0,~m) => 1,

        Jacobidn((1/2)*EllipticK(~m),~m) => (1-m)^(1/4),

        Jacobidn(EllipticK(~m),~m) => (1-m)^(1/2),

        Jacobidn((1/2)*i*EllipticK!'(~m),~m) =>   (1+(m^(1/2)))^(1/2),

        Jacobidn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                         (((1-m)/4)^(1/4))*(((1+((1-m)^(1/2)))^(1/2))
                                        - i*((1-((1-m)^(1/2)))^(1/2))),

        Jacobidn(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                                   (1-(m^(1/2)))^(1/2),

        Jacobidn(i*EllipticK!'(~m),~m) => infinity,

        Jacobidn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                      -i*((1-m)^(1/4)),

        Jacobidn(EllipticK(~m)+i*EllipticK!'(~m),~m) => 0,

%Derivatives, Intergal
%---------------------
% Following a hint from Alain Moussiaux
%       df(Jacobidn(~u,~m),~u)  => -m *Jacobisn(u,m)*Jacobicn(u,m),
        df(Jacobidn(~u,~m),~u)  => -m**2 *Jacobisn(u,m)*Jacobicn(u,m),
        df(Jacobidn(~u,~m),~m)  => m*(-(Jacobisn(u,m)^2)*Jacobidn(u,m)
                                   + EllipticE(u,m)*Jacobisn(u,m)
                                     *Jacobicn(u,m))/(1-(m^2))
                                   - m*u*Jacobisn(u,m)*Jacobicn(u,m),

        int(Jacobidn(~u,~m),~u) => asin(Jacobisn(u,m)),

%Calls Num_Jacobidn when rounded switch is on.
%---------------------------------------------
        Jacobidn(~u,~m) => Num_Elliptic(Num_Jacobidn, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m and IMPART(u) = 0,

        Jacobidn(~u,~m) => Num_Elliptic(complex_DN, u, m)
                           when lisp !*rounded and numberp repart u
                           and numberp impart u and numberp m
                           and IMPART(u) neq 0
}$
let JacobiDNrules;

%......................................................................
%Evaluates Jacobidn when imaginary argument.

operator complex_DN;
DNrule :=
{       complex_DN(i*~u,~m) => Num_Jacobidc(u,1-m),

        complex_DN(~x + i*~y,~m) =>

        ( Num_Jacobidn(x,m)*Num_Jacobicn(y,1-m)*Num_Jacobidn(y,1-m)
        - i*m*Num_Jacobisn(x,m)*Num_Jacobicn(x,m)*Num_Jacobisn(y,1-m) )
        / ( ((Num_Jacobicn(y,1-m))^2) + m*((Num_Jacobisn(x,m))^2)
                                         *((Num_Jacobisn(y,1-m))^2) )
}$
let DNrule;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobicd when the on rounded switch is
%used. It evaluates the value of Jacobicd numerically.

procedure Num_Jacobicd(u,m);

        Num_Jacobicn(u,m) / Num_Jacobidn(u,m);


%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobicd definition
%===================

operator Jacobicd;

%This rule list includes all the special cases of the Jacobicd
%function.

JacobiCDrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobicd(~u,0)   => cos u,
        Jacobicd(~u,1)   => 1,
        Jacobicd(~u,-~m) => Jacobicd(u,m),
%Change of Argument
%------------------
        Jacobicd(-~u,~m)   => Jacobicd(u,m),
        Jacobicd((~u+EllipticK(~m)),~m)   => -Jacobisn(u,m),
        Jacobicd((~u-EllipticK(~m)),~m)   =>  Jacobisn(u,m),
        Jacobicd((EllipticK(~m)-~u),~m)   =>  Jacobisn(u,m),
        Jacobicd((~u+2*EllipticK(~m)),~m) => -Jacobicd(u,m),
        Jacobicd((~u-2*EllipticK(~m)),~m) => -Jacobicd(u,m),
        Jacobicd((2*EllipticK(~m)-~u),~m) => -Jacobicd(u,m),
        Jacobicd((~u+i*EllipticK!'(~m)),~m) =>
                                              (m^(-1/2))*Jacobidc(u,m),

        Jacobicd((~u+2*i*EllipticK!'(~m)),~m) => Jacobicd(u,m),

        Jacobicd((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                             -(m^(-1/2))*Jacobins(u,m),

        Jacobicd((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobicd(u,m),
%Special Arguments
%-----------------
        Jacobicd(0,~m) => 1,

        Jacobicd((1/2)*EllipticK(~m),~m) => 1 /(1+((1-m)^(1/2)))^(1/2),

        Jacobicd(EllipticK(~m),~m) => 0,

        Jacobicd((1/2)*i*EllipticK!'(~m),~m) => 1/(m^(1/4)),

        Jacobicd((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                           (1-i)/((m^(1/4))*(((1+((1-m)^(1/2)))^(1/2))
                                        -i*((1-((1-m)^(1/2)))^(1/2)))),

        Jacobicd(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                                          -i/(m^(1/4)),

        Jacobicd(i*EllipticK!'(~m),~m) =>
                                        Jacobicn(i*EllipticK!'(~m),~m)
                                      / Jacobidn(i*EllipticK!'(~m),~m),

        Jacobicd((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                           1/((1-((1-m)^(1/2)))^(1/2)),

        Jacobicd(EllipticK(~m)+i*EllipticK!'(~m),~m) => infinity,

%Derivatives,Integral
%--------------------
        df(Jacobicd(~u,~m),~u) => -(1 - m)*Jacobisd(u,m)*Jacobind(u,m),
        df(Jacobicd(~u,~m),~m) =>
                                ( Jacobidn(u,m)*df(Jacobicn(u,m),m)
                                - Jacobicn(u,m)*df(Jacobidn(u,m),m))
                                / ((Jacobidn(u,m))^2),

        int(Jacobicd(~u,~m),~u) =>
                m^(-1/2)*ln(Jacobind(u,m) + (m^(1/2))*Jacobisd(u,m)),

%Calls Num_Jacobicd when rounded switch is on.
%---------------------------------------------
        Jacobicd(~u,~m) => Num_Elliptic(Num_Jacobicd, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiCDrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobisd when the on rounded switch is
%used. It evaluates the value of Jacobisd numerically.

procedure Num_Jacobisd(u,m);

   Num_Jacobisn(u,m) / Num_Jacobidn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobisd definition
%===================

operator Jacobisd;

%This rule list includes all the special cases of the Jacobisd
%function.

JacobiSDrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobisd(~u,0)   => sin u,
        Jacobisd(~u,1)   => sinh u,
        Jacobisd(~u,-~m) => Jacobisd(u,m),
%Change of Argument
%------------------
        Jacobisd(-~u,~m)   => -Jacobisd(u,m),

        Jacobisd((~u+EllipticK(~m)),~m) =>((1-m)^(-1/2))*Jacobicn(u,m),
        Jacobisd((~u-EllipticK(~m)),~m) => -((1-m)^(-1/2))
                                                        *Jacobicn(u,m),

        Jacobisd((EllipticK(~m)-~u),~m) =>((1-m)^(-1/2))*Jacobicn(u,m),

        Jacobisd((~u+2*EllipticK(~m)),~m) => -Jacobisd(u,m),
        Jacobisd((~u-2*EllipticK(~m)),~m) => -Jacobisd(u,m),
        Jacobisd((2*EllipticK(~m)-~u),~m) =>  Jacobisd(u,m),

        Jacobisd((~u+i*EllipticK!'(~m)),~m) =>
                                             i*(m^(-1/2))*Jacobinc(u,m),

        Jacobisd((~u+2*i*EllipticK!'(~m)),~m) => -Jacobisd(u,m),

        Jacobisd((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                          -i*((1-m)^(-1/2))*(m^(-1/2))*Jacobids(u,m),

        Jacobisd((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                         Jacobisd(u,m),
%Special Arguments
%-----------------
        Jacobisd(0,~m) => 0,

        Jacobisd((1/2)*EllipticK(~m),~m) =>
                         1 / (((1+((1-m)^(1/2)))^(1/2))*((1-m)^(1/4))),

        Jacobisd(EllipticK(~m),~m) => 1/((1-m)^(1/2)),

        Jacobisd((1/2)*i*EllipticK!'(~m),~m) =>
                                    i*(m^(-1/4))/((1+(m^(1/2)))^(1/2)),

        Jacobisd((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m)
                / Jacobidn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobisd(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                        (m^(-1/4))/(1-(m^(1/2))^(1/2)),

        Jacobisd(i*EllipticK!'(~m),~m) =>
                                        Jacobisn(i*EllipticK!'(~m),~m)
                                      / Jacobidn(i*EllipticK!'(~m),~m),

        Jacobisd((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                         ((1-((1-m)^(1/2)))^(-1/2))/(-i*((1-m)^(1/4))),

        Jacobisd(EllipticK(~m)+i*EllipticK!'(~m),~m) => infinity,

%Derivatives, Integral
%---------------------
        df(Jacobisd(~u,~m),~u) => Jacobicd(u,m)*Jacobind(u,m),
        df(Jacobisd(~u,~m),~m) =>
                                ( Jacobidn(u,m)*df(Jacobisn(u,m),m)
                                - Jacobisn(u,m)*df(Jacobidn(u,m),m))
                                / ((Jacobidn(u,m))^2),

        int(Jacobisd(~u,~m),~u) =>
                   (m*(1-m))^(-1/2)*asin(-(m^(1/2))*(Jacobicd(u,m))),

%Calls Num_Jacobisd when rounded switch is on.
%---------------------------------------------
        Jacobisd(~u,~m) => Num_Elliptic(Num_Jacobisd, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiSDrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobind when the on rounded switch is
%used. It evaluates the value of Jacobind numerically.

procedure Num_Jacobind(u,m);

        1 / Num_Jacobidn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobind definition
%===================

operator Jacobind;

%This rule list includes all the special cases of the Jacobind
%function.

JacobiNDrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobind(~u,0)   => 1,
        Jacobind(~u,1)   => cosh u,
        Jacobind(~u,-~m) => Jacobind(u,m),
%Change of Argument
%------------------
        Jacobind(-~u,~m)   => Jacobind(u,m),

        Jacobind((~u+EllipticK(~m)),~m) =>((1-m)^(-1/2))*Jacobidn(u,m),
        Jacobind((~u-EllipticK(~m)),~m) =>((1-m)^(-1/2))*Jacobidn(u,m),
        Jacobind((EllipticK(~m)-~u),~m) =>((1-m)^(-1/2))*Jacobidn(u,m),

        Jacobind((~u+2*EllipticK(~m)),~m) => Jacobind(u,m),
        Jacobind((~u-2*EllipticK(~m)),~m) => Jacobind(u,m),
        Jacobind((2*EllipticK(~m)-~u),~m) => Jacobind(u,m),

        Jacobind((~u+i*EllipticK!'(~m)),~m)   => i*Jacobisc(u,m),
        Jacobind((~u+2*i*EllipticK!'(~m)),~m) => -Jacobind(u,m),

        Jacobind((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                       -i*((1-m)^(-1/2))*Jacobics(u,m),

        Jacobind((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobind(u,m),
%Special Arguments
%-----------------
        Jacobind(0,~m) => 1,

        Jacobind((1/2)*EllipticK(~m),~m) => 1 / ((1-m)^(1/4)),

        Jacobind(EllipticK(~m),~m) => 1 / ((1-m)^(1/2)),

        Jacobind((1/2)*i*EllipticK!'(~m),~m) =>
                                               1/((1+(m^(1/2)))^(1/2)),

        Jacobind((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                1/Jacobidn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobind(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                               1/((1-(m^(1/2)))^(1/2)),

        Jacobind(i*EllipticK!'(~m),~m) =>
                                    1 / Jacobidn(i*EllipticK!'(~m),~m),

        Jacobind((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                1 / (-i*((1-m)^(1/4))),

        Jacobind(EllipticK(~m)+i*EllipticK!'(~m),~m) => infinity,

%Derivatives, Integral
%---------------------
        df(Jacobind(~u,~m),~u) => m*Jacobisd(u,m)*Jacobicd(u,m),
        df(Jacobind(~u,~m),~m) =>
                            -(df(Jacobidn(u,m),m))/((Jacobidn(u,m))^2),

        int(Jacobind(~u,~m),~u) => (1-m)^(-1/2)*(acos(Jacobicd(u,m))),

%Calls Num_Jacobind when rounded switch is on.
%---------------------------------------------
        Jacobind(~u,~m) => Num_Elliptic(Num_Jacobind, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiNDrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobidc when the on rounded switch is
%used. It evaluates the value of Jacobidc numerically.

procedure Num_Jacobidc(u,m);

        Num_Jacobidn(u,m) / Num_Jacobicn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobidc definition
%===================

operator Jacobidc;

%This rule list includes all the special cases of the Jacobidc
%function.

JacobiDCrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobidc(~u,0)   => sec u,
        Jacobidc(~u,1)   => 1,
        Jacobidc(~u,-~m) => Jacobidc(u,m),
%Change of Argument
%------------------
        Jacobidc(-~u,~m)   => Jacobidc(u,m),

        Jacobidc((~u+EllipticK(~m)),~m) => -Jacobins(u,m),
        Jacobidc((~u-EllipticK(~m)),~m) =>  Jacobidns(u,m),
        Jacobidc((EllipticK(~m)-~u),~m) =>  Jacobins(u,m),
        Jacobidc((~u+2*EllipticK(~m)),~m)   => -Jacobidc(u,m),
        Jacobidc((~u-2*EllipticK(~m)),~m)   => -Jacobidc(u,m),
        Jacobidc((2*EllipticK(~m)-~u),~m)   => -Jacobidc(u,m),
        Jacobidc((~u+i*EllipticK!'(~m)),~m) => (m^(1/2))*Jacobicd(u,m),
        Jacobidc((~u+2*i*EllipticK!'(~m)),~m) => Jacobidc(u,m),

        Jacobidc((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                               (m^(1/2))*Jacobisn(u,m),

        Jacobidc((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobidc(u,m),
%Special Arguments
%-----------------
        Jacobidc(0,~m) => 1,

        Jacobidc((1/2)*EllipticK(~m),~m) => (1+((1-m)^(1/2)))^(1/2),

        Jacobidc(EllipticK(~m),~m) => infinity,

        Jacobidc((1/2)*i*EllipticK!'(~m),~m) => m^(1/4),

        Jacobidc((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                Jacobidn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m)
                / Jacobicn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobidc(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                                           i*(m^(1/4)),

        Jacobidc(i*EllipticK!'(~m),~m) =>
                                        Jacobidn(i*EllipticK!'(~m),~m)
                                      / Jacobicn(i*EllipticK!'(~m),~m),

        Jacobidc((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                               (1-((1-m)^(1/2)))^(1/2),

        Jacobidc(EllipticK(~m)+i*EllipticK!'(~m),~m) => 0,

%Derivatives, Integral
%---------------------
        df(Jacobidc(~u,~m),~u) => (1-m)*Jacobisc(u,m)*Jacobinc(u,m),
        df(Jacobidc(~u,~m),~m) =>
                                (Jacobicn(u,m)*df(Jacobidn(u,m),m)
                                - Jacobidn(u,m)*df(Jacobicn(u,m),m))
                                / ((Jacobicn(u,m))^2),

        int(Jacobidc(~u,~m),~u) => ln(Jacobinc(u,m) + Jacobisc(u,m)),

%Calls Num_Jacobidc when rounded switch is on.
%---------------------------------------------
        Jacobidc(~u,~m) => Num_Elliptic(Num_Jacobidc, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiDCrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobinc when the on rounded switch is
%used. It evaluates the value of Jacobinc numerically.

procedure Num_Jacobinc(u,m);

        1 / Num_Jacobicn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobinc definition
%===================

operator Jacobinc;

%This rule list includes all the special cases of the Jacobinc
%function.

JacobiNCrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobinc(~u,0)   => sec u,
        Jacobinc(~u,1)   => cosh u,
        Jacobinc(~u,-~m) => Jacobinc(u,m),
%Change of Argument
%------------------
        Jacobinc(-~u,~m)   => Jacobinc(u,m),

        Jacobinc((~u+EllipticK(~m)),~m) => -((1-m)^(-1/2))
                                                        *Jacobids(u,m),

        Jacobinc((~u-EllipticK(~m)),~m) =>((1-m)^(-1/2))*Jacobids(u,m),
        Jacobinc((EllipticK(~m)-~u),~m) =>((1-m)^(-1/2))*Jacobids(u,m),

        Jacobinc((~u+2*EllipticK(~m)),~m) => -Jacobinc(u,m),
        Jacobinc((~u-2*EllipticK(~m)),~m) => -Jacobinc(u,m),
        Jacobinc((2*EllipticK(~m)-~u),~m) => -Jacobinc(u,m),
        Jacobinc((~u+i*EllipticK!'(~m)),~m) =>
                                             i*(m^(1/2))*Jacobisd(u,m),

        Jacobinc((~u+2*i*EllipticK!'(~m)),~m) => -Jacobinc(u,m),

        Jacobinc((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                            i*((1-m)^(-1/2))*(m^(1/2))*Jacobicn(u,m),

        Jacobinc((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                         Jacobinc(u,m),
%Special Arguments
%-----------------
        Jacobinc(0,~m) => 1,

        Jacobinc((1/2)*EllipticK(~m),~m) => ((1+((1-m)^(1/2)))^(1/2))
                                                        /((1-m)^(1/4)),

        Jacobinc(EllipticK(~m),~m) => infinity,

        Jacobinc((1/2)*i*EllipticK!'(~m),~m) =>
                                       (m^(1/4))/((1+(m^(1/2)))^(1/2)),

        Jacobinc((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                             ((4*m/(1-m))^(1/4))/(1-i),

        Jacobinc(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                1 / Jacobicn(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m),

        Jacobinc(i*EllipticK!'(~m),~m) =>
                                    1 / Jacobicn(i*EllipticK!'(~m),~m),

        Jacobinc((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                1 / Jacobicn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m),

        Jacobinc(EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                   i*((m/(1-m))^(1/2)),
%Derivatives, Integral
%---------------------
        df(Jacobinc(~u,~m),~u) => Jacobisc(u,m)*Jacobidc(u,m),
        df(Jacobinc(~u,~m),~m) =>
                            -(df(Jacobicn(u,m),m))/((Jacobicn(u,m))^2),

        int(Jacobinc(~u,~m),~u) =>

         ((1-m)^(-1/2))*ln(Jacobidc(u,m)+((1-m)^(1/2))*Jacobisc(u,m)),

%Calls Num_Jacobinc when rounded switch is on.
%---------------------------------------------
        Jacobinc(~u,~m) => Num_Elliptic(Num_Jacobinc, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiNCrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobisc when the on rounded switch is
%used. It evaluates the value of Jacobisc numerically.

procedure Num_Jacobisc(u,m);

        Num_Jacobisn(u,m) / Num_Jacobicn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobisc definition
%===================

operator Jacobisc;

%This rule list includes all the special cases of the Jacobisc
%function.

JacobiSCrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobisc(~u,0)   => tan u,
        Jacobisc(~u,1)   => sinh u,
        Jacobisc(~u,-~m) => Jacobisc(u,m),
%Change of Argument
%------------------
        Jacobisc(-~u,~m)   => -Jacobisc(u,m),

        Jacobisc((~u+EllipticK(~m)),~m) => -((1-m)^(-1/2))
                                                        *Jacobics(u,m),

        Jacobisc((~u-EllipticK(~m)),~m) => -((1-m)^(-1/2))
                                                        *Jacobics(u,m),

        Jacobisc((EllipticK(~m)-~u),~m) =>((1-m)^(-1/2))*Jacobics(u,m),

        Jacobisc((~u+2*EllipticK(~m)),~m) =>  Jacobisc(u,m),
        Jacobisc((~u-2*EllipticK(~m)),~m) =>  Jacobisc(u,m),
        Jacobisc((2*EllipticK(~m)-~u),~m) => -Jacobisc(u,m),
        Jacobisc((~u+i*EllipticK!'(~m)),~m)   =>i*Jacobind(u,m),
        Jacobisc((~u+2*i*EllipticK!'(~m)),~m) => -Jacobisc(u,m),

        Jacobisc((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                        i*((1-m)^(-1/2))*Jacobidn(u,m),

        Jacobisc((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobisc(u,m),
%Special Arguments
%-----------------
        Jacobisc(0,~m) => 0,

        Jacobisc((1/2)*EllipticK(~m),~m) => 1 / ((1-m)^(1/4)),

        Jacobisc(EllipticK(~m),~m) => infinity,

        Jacobisc((1/2)*i*EllipticK!'(~m),~m) =>
                                               i/((1+(m^(1/2)))^(1/2)),

        Jacobisc((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m)
                / Jacobicn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobisc(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                               i/((1-(m^(1/2)))^(1/2)),

        Jacobisc(i*EllipticK!'(~m),~m) =>
                                      Jacobisn(i*EllipticK!'(~m),~m)
                                      / Jacobicn(i*EllipticK!'(~m),~m),

        Jacobisc((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>

                  Jacobisn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m)
                  / Jacobicn((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m),

        Jacobisc(EllipticK(~m)+i*EllipticK!'(~m),~m) =>i/((1-m)^(1/2)),


%Derivatives, Integral
%---------------------
        df(Jacobisc(~u,~m),~u) => Jacobidc(u,m)*Jacobinc(u,m),
        df(Jacobisc(~u,~m),~m) =>
                                ( Jacobicn(u,m)*df(Jacobisn(u,m),m)
                                - Jacobisn(u,m)*df(Jacobicn(u,m),m))
                                /((Jacobicn(u,m))^2),

        int(Jacobisc(~u,~m),u) =>

          ((1-m)^(-1/2))*ln(Jacobidc(u,m)+((1-m)^(1/2))*Jacobinc(u,m)),

%Calls Num_Jacobisc when rounded switch is on.
%---------------------------------------------
        Jacobisc(~u,~m) => Num_Elliptic(Num_Jacobisc, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiSCrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobins when the on rounded switch is
%used. It evaluates the value of Jacobins numerically.

procedure Num_Jacobins(u,m);

        1 / Num_Jacobisn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobins definition
%===================

operator Jacobins;

%This rule list includes all the special cases of the Jacobins
%function.

JacobiNSrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobins(~u,0)   => csc u,
        Jacobins(~u,1)   => coth u,
        Jacobins(~u,-~m) => Jacobins(u,m),
%Change of Argument
%------------------
        Jacobins(-~u,~m)   => -Jacobins(u,m),

        Jacobins((~u+EllipticK(~m)),~m)   =>  Jacobidc(u,m),
        Jacobins((~u-EllipticK(~m)),~m)   => -Jacobidc(u,m),
        Jacobins((EllipticK(~m)-~u),~m)   =>  Jacobidc(u,m),
        Jacobins((~u+2*EllipticK(~m)),~m) => -Jacobins(u,m),
        Jacobins((~u-2*EllipticK(~m)),~m) => -Jacobins(u,m),
        Jacobins((2*EllipticK(~m)-~u),~m) =>  Jacobins(u,m),
        Jacobins((~u+i*EllipticK!'(~m)),~m) => (m^(1/2))*Jacobisn(u,m),
        Jacobins((~u+2*i*EllipticK!'(~m)),~m) => Jacobins(u,m),
        Jacobins((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                               (m^(1/2))*Jacobicd(u,m),

        Jacobins((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobins(u,m),
%Special Arguments
%-----------------
        Jacobins(0,~m) => infinity,

        Jacobins((1/2)*EllipticK(~m),~m) => (1+((1-m)^(1/2)))^(1/2),

        Jacobins(EllipticK(~m),~m) => 1,

        Jacobins((1/2)*i*EllipticK!'(~m),~m) => -i*(m^(1/4)),

        Jacobins((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                1/Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobins(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>(m^(1/4)),

        Jacobins(i*EllipticK!'(~m),~m) =>

                                      1/Jacobisn(i*EllipticK!'(~m),~m),

        Jacobins((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>

                                               (1-((1-m)^(1/2)))^(1/2),

        Jacobins(EllipticK(~m)+i*EllipticK!'(~m),~m) => m^(1/2),
%Derivatives, Integral
%---------------------
        df(Jacobins(~u,~m),~u) => -Jacobids(u,m)*Jacobics(u,m),
        df(Jacobins(~u,~m),~m) =>
                            -(df(Jacobisn(u,m),m))/((Jacobisn(u,m))^2),

        int(Jacobins(~u,~m),~u) => ln(Jacobids(u,m) - Jacobics(u,m)),

%Calls Num_Jacobins when rounded switch is on.
%---------------------------------------------
        Jacobins(~u,~m) => Num_Elliptic(Num_Jacobins, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiNSrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobids when the on rounded switch is
%used. It evaluates the value of Jacobids numerically.

procedure Num_Jacobids(u,m);

        Num_Jacobidn(u,m) / Num_Jacobisn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobids definition
%===================

operator Jacobids;

%This rule list includes all the special cases of the Jacobids
%function.

JacobiDSrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobids(~u,0)   => csc u,
        Jacobids(~u,1)   => csch u,
        Jacobids(~u,-~m) => Jacobids(u,m),
%Change of Argument
%------------------
        Jacobids(-~u,~m)   =>-Jacobids(u,m),

        Jacobids((~u+EllipticK(~m)),~m) => ((1-m)^(1/2))*Jacobinc(u,m),
        Jacobids((~u-EllipticK(~m)),~m) =>-((1-m)^(1/2))*Jacobinc(u,m),
        Jacobids((EllipticK(~m)-~u),~m) => ((1-m)^(1/2))*Jacobinc(u,m),

        Jacobids((~u+2*EllipticK(~m)),~m) => -Jacobids(u,m),
        Jacobids((~u-2*EllipticK(~m)),~m) => -Jacobids(u,m),
        Jacobids((2*EllipticK(~m)-~u),~m) =>  Jacobids(u,m),
        Jacobids((~u+i*EllipticK!'(~m)),~m) =>
                                             -i*(m^(1/2))*Jacobicn(u,m),

        Jacobids((~u+2*i*EllipticK!'(~m)),~m) => -Jacobids(u,m),

        Jacobids((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                               i*((1-m)^(1/2))*(m^(1/2))*Jacobisd(u,m),

        Jacobids((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                         Jacobids(u,m),
%Special Arguments
%-----------------
        Jacobids(0,~m) => infinity,

        Jacobids((1/2)*EllipticK(~m),~m) =>
                               ((1+((1-m)^(1/2)))^(1/2))*((1-m)^(1/4)),

        Jacobids(EllipticK(~m),~m) => (1-m)^(1/2),

        Jacobids((1/2)*i*EllipticK!'(~m),~m) =>
                                    -i*(m^(1/4))*((1+(m^(1/2)))^(1/2)),

        Jacobids((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                Jacobidn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m)
                / Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobids(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                       (m^(1/4))*((1-(m^(1/2)))^(1/2)),

        Jacobids(i*EllipticK!'(~m),~m) =>
                                      Jacobidn(i*EllipticK!'(~m),~m)
                                      / Jacobisn(i*EllipticK!'(~m),~m),

        Jacobids((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                            -i*((1-m)^(1/4))*((1-((1-m)^(1/2)))^(1/2)),

        Jacobids(EllipticK(~m)+i*EllipticK!'(~m),~m) => 0,

%Derivatives, Integral
%---------------------
        df(Jacobids(~u,~m),~u) => -Jacobics(u,m)*Jacobins(u,m),
        df(Jacobids(~u,~m),~m) =>
                                (Jacobisn(u,m)*df(Jacobidn(u,m),m)
                                - Jacobidn(u,m)*df(Jacobisn(u,m),m))
                                / ((Jacobisn(u,m))^2),

        int(Jacobids(~u,~m),~u) => ln(Jacobins(u,m) - Jacobics(u,m)),

%Calls Num_Jacobids when on rounded switch is on.
%------------------------------------------------
        Jacobids(~u,~m) => Num_Elliptic(Num_Jacobids, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiDSrules;

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%This procedure is called by Jacobics when the on rounded switch is
%used. It evaluates the value of Jacobics numerically.

procedure Num_Jacobics(u,m);

        Num_Jacobicn(u,m) / Num_Jacobisn(u,m);

%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%Jacobics definition
%===================

operator Jacobics;

%This rule list includes all the special cases of the Jacobics
%function.

JacobiCSrules :=
{
%When m=0 or 1, Change of Parameter
%----------------------------------
        Jacobics(~u,0)   => cot u,
        Jacobics(~u,1)   => csch u,
        Jacobics(~u,-~m) => Jacobics(u,m),
%Change of Argument
%------------------
        Jacobics(-~u,~m)   =>-Jacobics(u,m),

        Jacobics((~u+EllipticK(~m)),~m) =>-((1-m)^(1/2))*Jacobisc(u,m),
        Jacobics((~u-EllipticK(~m)),~m) =>-((1-m)^(1/2))*Jacobisc(u,m),
        Jacobics((EllipticK(~m)-~u),~m) => ((1-m)^(1/2))*Jacobisc(u,m),
        Jacobics((~u+2*EllipticK(~m)),~m) =>  Jacobics(u,m),
        Jacobics((~u-2*EllipticK(~m)),~m) =>  Jacobics(u,m),
        Jacobics((2*EllipticK(~m)-~u),~m) => -Jacobics(u,m),
        Jacobics((~u+i*EllipticK!'(~m)),~m)   => -i*Jacobidn(u,m),
        Jacobics((~u+2*i*EllipticK!'(~m)),~m) => -Jacobics(u,m),

        Jacobics((~u+EllipticK(~m)+i*EllipticK!'(~m)),~m) =>
                                        -i*((1-m)^(1/2))*Jacobind(u,m),

        Jacobics((~u+2*EllipticK(~m)+2*i*EllipticK!'(~m)),~m) =>
                                                        -Jacobics(u,m),
%Special Arguments
%-----------------
        Jacobics(0,~m) => infinity,

        Jacobics((1/2)*EllipticK(~m),~m) => (1-m)^(1/4),

        Jacobics(EllipticK(~m),~m) => 0,

        Jacobics((1/2)*i*EllipticK!'(~m),~m) =>
                                              -i*((1+(m^(1/2)))^(1/2)),

        Jacobics((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m) =>

                Jacobicn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m)
                / Jacobisn((1/2)*(EllipticK(~m)+i*EllipticK!'(~m)),~m),

        Jacobics(EllipticK(~m)+(1/2)*i*EllipticK!'(~m),~m) =>
                                              -i*((1-(m^(1/2)))^(1/2)),

        Jacobics(i*EllipticK!'(~m),~m) =>
                                      Jacobicn(i*EllipticK!'(~m),~m)
                                      / Jacobisn(i*EllipticK!'(~m),~m),

        Jacobics((1/2)*EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                      -i*((1-m)^(1/4)),

        Jacobics(EllipticK(~m)+i*EllipticK!'(~m),~m) =>
                                                       -i*((1-m)^(1/2)),
%Derivatives, Integral
%---------------------
        df(Jacobics(~u,~m),~u) => -Jacobins(u,m)*Jacobids(u,m),
        df(Jacobics(~u,~m),~m) =>
                                ( Jacobisn(u,m)*df(Jacobicn(u,m),m)
                                - Jacobicn(u,m)*df(Jacobisn(u,m),m))
                                / ((Jacobisn(u,m))^2),

        int(Jacobics(~u,~m),~u) => ln(Jacobins(u,m) - Jacobids(u,m)),

%Calls Num_Jacobics when rounded switch is on.
%---------------------------------------------
        Jacobics(~u,~m) => Num_Elliptic(Num_Jacobics, u, m)
                           when lisp !*rounded and numberp u
                           and numberp m
}$
let JacobiCSrules;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/fps.rlg0000644000175000017500000003730011527635055023277 0ustar  giovannigiovanniFri Feb 18 21:28:06 2011 run on win32
%       Examples for the algorithmic calculation of formal 
%       Puiseux, Laurent and power series,
%
%       Wolfram Koepf, Freie Universitaet Berlin, Germany
%       (taken from the original paper and adapted to REDUCE 
%        form by Winfried Neun, ZIB Berlin)

% Formal Laurent series

fps(E^x,x);


              k
             x
infsum(--------------,k,0,infinity)
        factorial(k)


fps(E^x/(x^3),x);


               k
              x
infsum(-----------------,k,0,infinity)
                      3
        factorial(k)*x


fps(x * e^(x^4),x);


            4*k
           x   *x
infsum(--------------,k,0,infinity)
        factorial(k)


fps(sin (x + y),x);


         2*k       k
        x   *( - 1) *cos(y)*x
infsum(-----------------------,k,0,infinity)
         factorial(2*k + 1)

            2*k       k
           x   *( - 1) *sin(y)
 + infsum(---------------------,k,0,infinity)
             factorial(2*k)


simplede (sin x,x);


df(y,x,2) + y
 %find a DE for sin

simplede (sin (x)^2,x,w);


df(w,x,3) + 4*df(w,x)
 % DE in w and x   

fps(asin x,x);


            2*k
           x   *factorial(2*k)*x
infsum(------------------------------,k,0,infinity)
         2*k             2
        2   *factorial(k) *(2*k + 1)


fps((asin x)^2,x);


         2*k  2*k             2  2
        x   *2   *factorial(k) *x
infsum(----------------------------,k,0,infinity)
        factorial(2*k + 1)*(k + 1)


fps(e^(asin x),x);


         2*k  k         2
        x   *2 *prod(2*j  - 2*j + 1,j,1,k)*x
infsum(--------------------------------------,k,0,infinity)
                 factorial(2*k + 1)

            2*k         2
           x   *prod(4*j  - 8*j + 5,j,1,k)
 + infsum(---------------------------------,k,0,infinity)
                   factorial(2*k)


fps(e^(asinh x),x);


            2*k       k
         - x   *( - 1) *factorial(2*k)
infsum(--------------------------------,k,0,infinity) + x
           k             2
          4 *factorial(k) *(2*k - 1)


fps((x + sqrt(1+x^2))^A,x);


         2*k       k  2*k              - a                 a
        x   *( - 1) *2   *pochhammer(------,k)*pochhammer(---,k)
                                       2                   2
infsum(----------------------------------------------------------,k,0,infinity) 
                             factorial(2*k)

           2*k       k  2*k              - a + 1                 a + 1
          x   *( - 1) *2   *pochhammer(----------,k)*pochhammer(-------,k)*a*x
                                           2                       2
+ infsum(----------------------------------------------------------------------,
                                   factorial(2*k + 1)

         k,0,infinity)


fps(e^(x^2)*erf x,x);


           2*k           2*k
        2*x   *sqrt(pi)*2   *factorial(k)*x
infsum(-------------------------------------,k,0,infinity)
               factorial(2*k + 1)*pi


fps(e^x - 2 e^(-x/2) * cos(sqrt(3) * x/2 -pi/3),x);


           3*k  2
        9*x   *x *(k + 1)
infsum(--------------------,k,0,infinity)
        factorial(3*k + 3)


% fps(int(e^(-a^2*t^2) * cos(2*x*t),t,0,infinity),x)  % not yet

% fps(4/x * int(e^(t^2)*erf(t),t,0,sqrt(x)/2),x);

fps(sin x * e^x,x);


         k  k/2      k*pi
        x *2   *sin(------)
                      4
infsum(---------------------,k,0,infinity)
           factorial(k)


fps(cos x * e^(2*x),x);


         k  k/2           1
        x *5   *cos(atan(---)*k)
                          2
infsum(--------------------------,k,0,infinity)
              factorial(k)


fps(1/(x-x^3),x);


          k       k    k
         x *( - 1)  - x
 infsum(-----------------,k,0,infinity)*x + 1
                    k
            2*( - 1)
----------------------------------------------
                      x


fps(1/(x^2 + 3 x + 2),x);


           k  k    k
        2*x *2  - x
infsum(--------------,k,0,infinity)
                k  k
        2*( - 1) *2


fps(x/(1-x-x^2),x);


          x
fps(--------------,x,0)
                2
     (1 - x) - x


% Logarithmic singularities and Puisieux series

fps(sin sqrt x,x);


         (2*k + 1)/2       k
        x           *( - 1)
infsum(----------------------,k,0,infinity)
         factorial(2*k + 1)


fps(((1 + sqrt x)/x)^(1/3),x);


         (6*k + 1)/6             2
        x           *pochhammer(---,2*k)
                                 3
infsum(----------------------------------,k,0,infinity)
              3*factorial(2*k + 1)

            k              - 1
           x *pochhammer(------,2*k)
                           3
 + infsum(---------------------------,k,0,infinity)
               1/3
              x   *factorial(2*k)


fps(asech x,x);



% some more (Wolfram Koepf, priv. comm.)

fps((1+x)^alpha,x);


         k       k
        x *( - 1) *pochhammer( - alpha,k)
infsum(-----------------------------------,k,0,infinity)
                  factorial(k)


fps((1+sqrt(1+x))^beta,x);


          k       k  beta
         x *( - 1) *2    *pochhammer( - beta,2*k)
infsum(---------------------------------------------,k,0,infinity)
         2*k
        2   *factorial(k)*pochhammer( - beta + 1,k)


fps(sin(x)^2+cos(x)^2,x);


1


fps(sin(x)^2*cos(x)^2,x);


            2*k       k  4*k  2
           x   *( - 1) *2   *x
infsum(----------------------------,k,0,infinity)
        factorial(2*k + 1)*(k + 1)


fps(sin(x)*cos(x^2),x);


                2
fps(sin(x)*cos(x ),x,0)


fps((x-1)^(-1),x);


           k
infsum( - x ,k,0,infinity)


fps(atan(x+y),x);


fps(atan(x + y),x,0)


fps((1-x^5)^6,x);


 30      25       20       15       10      5
x   - 6*x   + 15*x   - 20*x   + 15*x   - 6*x  + 1


fps(asec x,x);



fps(besseli(0,x),x);


                2*k
               x
infsum(--------------------,k,0,infinity)
         2*k             2
        2   *factorial(k)

fps(besseli(1,x),x);


                        2*k
                       x   *x
infsum(--------------------------------------,k,0,infinity)
           2*k
        2*2   *factorial(k + 1)*factorial(k)


fps(exp(x^(1/3)),x);


            (3*k + 1)/3
           x
infsum(--------------------,k,0,infinity)
        factorial(3*k + 1)

                  k
                 x
 + infsum(----------------,k,0,infinity)
           factorial(3*k)

              (3*k + 2)/3
           3*x           *(k + 1)
 + infsum(------------------------,k,0,infinity)
             factorial(3*k + 3)

fps(log(1-x),x);


            k
         - x *x
infsum(---------,k,0,infinity)
         k + 1

fps(exp x*sinh x,x);


             k  k
            x *2 *x
infsum(------------------,k,0,infinity)
        factorial(k + 1)

fps(atan x,x);


         2*k       k
        x   *( - 1) *x
infsum(----------------,k,0,infinity)
           2*k + 1

fps(sin x+sinh x,x);


                4*k
             2*x   *x
infsum(--------------------,k,0,infinity)
        factorial(4*k + 1)

fps(sin x*sinh x,x);


             4*k       k  2*k  2
            x   *( - 1) *2   *x
infsum(------------------------------,k,0,infinity)
        factorial(4*k + 1)*(2*k + 1)

fps(int(erf(x),x),x);


*** ci already defined as operator 

*** si already defined as operator 

            2*k                k
         - x   *sqrt(pi)*( - 1)
infsum(---------------------------,k,0,infinity)
        factorial(k)*pi*(2*k - 1)

fps(sqrt(2-x),x);


            k
         - x *sqrt(2)*factorial(2*k)
infsum(------------------------------,k,0,infinity)
          k             2
         8 *factorial(k) *(2*k - 1)

fps(sqrt(1+x)+sqrt(1-x),x);


                 2*k
            - 2*x   *factorial(4*k)
infsum(--------------------------------,k,0,infinity)
         2*k               2
        4   *factorial(2*k) *(4*k - 1)

fps(exp(a+b*x)*exp(c+d*x),x);


         k  a + c        k
        x *e     *(b + d)
infsum(--------------------,k,0,infinity)
           factorial(k)

fps(1/cos(asin x),x);


         2*k
        x   *factorial(2*k)
infsum(---------------------,k,0,infinity)
         2*k             2
        2   *factorial(k)

fps(sqrt(1-x^2)+x*asin x,x);


                2*k
               x   *factorial(2*k)
infsum(-----------------------------------,k,0,infinity)
         k             2     2
        4 *factorial(k) *(4*k  - 4*k + 1)

fps(sqrt(1-sqrt(x)),x);


                 (2*k + 1)/2
              - x           *factorial(4*k)
infsum(------------------------------------------,k,0,infinity)
           4*k
        2*2   *factorial(2*k + 1)*factorial(2*k)

                    k
                 - x *factorial(4*k)
 + infsum(--------------------------------,k,0,infinity)
            2*k               2
           4   *factorial(2*k) *(4*k - 1)

fps(cos(n*acos x),x);


         2*k  2*k      n*pi                - n                 n
        x   *2   *cos(------)*pochhammer(------,k)*pochhammer(---,k)
                        2                  2                   2
infsum(--------------------------------------------------------------,k,0,
                               factorial(2*k)

       infinity) + infsum(

     2*k  2*k              - n + 1                 n + 1          n*pi
    x   *2   *pochhammer(----------,k)*pochhammer(-------,k)*sin(------)*n*x
                             2                       2             2
   --------------------------------------------------------------------------,k,
                               factorial(2*k + 1)

   0,infinity)

fps(cos x+I*sin x,x);


            k  k
           x *i
infsum(--------------,k,0,infinity)
        factorial(k)

fps(cos(3*asinh x),x);


         2*k       k         2
        x   *( - 1) *prod(4*j  - 8*j + 13,j,1,k)
infsum(------------------------------------------,k,0,infinity)
                     factorial(2*k)

fps(cos(n*asinh x),x);


         2*k       k  2*k              - i*n                 i*n
        x   *( - 1) *2   *pochhammer(--------,k)*pochhammer(-----,k)
                                        2                     2
infsum(--------------------------------------------------------------,k,0,
                               factorial(2*k)

       infinity)

fps(sin(n*log(x+sqrt(1+x^2))),x);


         2*k       k  2*k              - i*n + 1                 i*n + 1
infsum((x   *( - 1) *2   *pochhammer(------------,k)*pochhammer(---------,k)*n*x
                                          2                         2

        )/factorial(2*k + 1),k,0,infinity)

fps(sqrt(1+x^2)*asinh x-x,x);


           2*k       k  2*k                                3
        2*x   *( - 1) *2   *factorial(k + 1)*factorial(k)*x
infsum(------------------------------------------------------,k,0,infinity)
                         factorial(2*k + 3)


fps(int(erf(x)/x,x),x);


              2*k                k
           2*x   *sqrt(pi)*( - 1) *x
infsum(----------------------------------,k,0,infinity)
                            2
        factorial(k)*pi*(4*k  + 4*k + 1)

                erf(x)
 + sub(x=0,int(--------,x))
                  x

fps(asin(x)^2/x^4,x);


            2*k  2*k             2
           x   *2   *factorial(k)
infsum(-------------------------------,k,0,infinity)
                            2
        factorial(2*k + 1)*x *(k + 1)



% we had problems here:

fps(cos(asin x),x);


              2*k
           - x   *factorial(2*k)
infsum(----------------------------,k,0,infinity)
         k             2
        4 *factorial(k) *(2*k - 1)

fps(sinh(log x),x);


fps(sinh(log(x)),x,0)

fps(atan(cot x),x);


Could not find the limit of: atan(cot(x)),x,0

 
% we can cure this one by defining the limit:

let limit(atan(cot ~x),x,0) => pi/2;


fps(atan(cot x),x);


 pi - 2*x
----------
    2


fps(exp(nnn*x)*cos(mmm*x),x);


         k              2                                          2
infsum((x *((impart(mmm)  + 2*impart(mmm)*repart(nnn) + impart(nnn)

                                                       2              2    k
              - 2*impart(nnn)*repart(mmm) + repart(mmm)  + repart(nnn) )**---
                                                                           2

                       impart(nnn) - repart(mmm)                    2
            *cos(atan(---------------------------)*k) + (impart(mmm)
                       impart(mmm) + repart(nnn)

                                                         2
                - 2*impart(mmm)*repart(nnn) + impart(nnn)

                                                         2              2    k
                + 2*impart(nnn)*repart(mmm) + repart(mmm)  + repart(nnn) )**---
                                                                             2

                       impart(nnn) + repart(mmm)                    2
            *cos(atan(---------------------------)*k) - (impart(mmm)
                       impart(mmm) - repart(nnn)

                                                         2
                - 2*impart(mmm)*repart(nnn) + impart(nnn)

                                                         2              2    k
                + 2*impart(nnn)*repart(mmm) + repart(mmm)  + repart(nnn) )**---
                                                                             2

                       impart(nnn) + repart(mmm)                      2
            *sin(atan(---------------------------)*k)*i + (impart(mmm)
                       impart(mmm) - repart(nnn)

                                                         2
                + 2*impart(mmm)*repart(nnn) + impart(nnn)

                                                         2              2    k
                - 2*impart(nnn)*repart(mmm) + repart(mmm)  + repart(nnn) )**---
                                                                             2

                       impart(nnn) - repart(mmm)
            *sin(atan(---------------------------)*k)*i))/(2*factorial(k)),k,0,
                       impart(mmm) + repart(nnn)

       infinity)

fps(sqrt(2-x^2),x);


                   2*k
              - 2*x   *factorial(2*k)
infsum(------------------------------------,k,0,infinity)
                 k             2
        sqrt(2)*8 *factorial(k) *(2*k - 1)

fps(ci x,x);


                   2*k       k
                  x   *( - 1) *infinity*x
ci(0) + infsum(------------------------------,k,0,infinity)
                factorial(2*k + 1)*(2*k + 1)

fps(log(1-2*x*y+x^2),x);


                     2
fps(log(1 - 2*x*y + x ),x,0)


FPS(sin x,x,pi);


                   2*k       k
        ( - pi + x)   *( - 1) *( - pi + x)
infsum(------------------------------------,k,0,infinity)
                factorial(2*k + 1)


% This one takes ages :

%fps(acos(cos(x)),x);

fps_search_depth := 7;


fps_search_depth := 7
 % does not find aa DE with the default
fps(sin(x^(1/3)),x);


            2*k       k    k                         k
infsum(( - x   *( - 1) *108 *factorial(k)*x)/(6*46656 *factorial(3*k + 1)

                                          7                 5
          *factorial(2*k + 1)*pochhammer(---,k)*pochhammer(---,k)),k,0,infinity)
                                          6                 6

            (6*k + 2)/3       k  2*k  3*k                              k
 + infsum((x           *( - 1) *2   *3   *factorial(k + 1)*x)/(20*46656

                                                                11
             *factorial(3*k + 3)*factorial(2*k + 1)*pochhammer(----,k)
                                                                6

                          7
             *pochhammer(---,k)),k,0,infinity) + infsum(
                          6

                   (6*k + 1)/3       k  2*k  3*k
                  x           *( - 1) *2   *3   *factorial(k)
   --------------------------------------------------------------------------,k,
         k                                           7                 5
    46656 *factorial(3*k)*factorial(2*k)*pochhammer(---,k)*pochhammer(---,k)
                                                     6                 6

   0,infinity)


end;


Time for test: 2947 ms, plus GC time: 188 ms
@@@@@ Resources used: (3 38 135 518)
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfkummer.red0000644000175000017500000001277311526203062024321 0ustar  giovannigiovannimodule sfkummer; % Functions and rules for the Kummer M and U functions.

% Author: Chris Cannam, Sept/Oct 1992.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


imports complex!*on!*switch, complex!*off!*switch,
   complex!*restore!*switch, sq2bf!*;

exports kummerm!*calc;

% Provides algebraic things for both functions, and numeric for (only)
% the M function.  The amount of non-working code for the U function I
% had to cut out of this before getting this version was a sight to
% behold.

algebraic (operator kummerM, kummerU);

symbolic operator kummerm!*calc;


algebraic (kummer!*rules := {

kummerU(~a,~b,~z)  =>  ( pi / sin (pi * b)) *
      ( (kummerM(a,b,z) / (gamma(1+a-b) * gamma(b))) -
         ((z**(1-b)) * (kummerM(1+a-b,2-b,z)/(gamma(a) * gamma(2-b)))))
   when numberp b and (impart b neq 0 or b neq floor b)
      and numberp a and (impart a neq 0 or a neq floor a or a > 0)
         and not(z=0 and repart(1-b) < 0)
               and ((a-b) neq floor repart (a-b) or (a-b) > -1),

kummerU(~a,~b,~z)  =>  ( pi / sin (pi * b)) *
      ( -((z**(1-b)) * (kummerM(1+a-b,2-b,z)/(gamma(a) * gamma(2-b)))))
   when numberp b and (impart b neq 0 or b neq floor b)
      and not(z=0 and repart(1-b) < 0)
                % ComplexInfinity otherwise, but we can't calculate with
                % CI.
      and numberp a and (impart a neq 0 or a neq floor a or a > 0),



kummerM(~a,~a,~z) => exp(z) when not(fixp a and a <= 0) ,

%% fix by FJW : old form: kummerM(~a,~b,~z)  =>  exp z       when a = b,

kummerM(~a,~b,~z)  =>  ((2 * exp (z/2)) / z) * sinh (z/2)
   when numberp a and numberp b and numberp z
      and a = 1 and b = 2 and impart z = 0 and z neq 0,

kummerM(~a,~b,~z)  =>  ((-2 * i * exp (z/2)) / z) * sin (-z / (2*i))
   when numberp a and numberp b and numberp z
      and a = 1 and b = 2 and repart z = 0 and z neq 0,

kummerM(~a,~b,~z)  =>  infinity
   when numberp a and numberp b
      and impart b = 0 and b < 0 and b = floor b
               and not (impart a = 0 and a < 0 and a = floor a and a >= b),

kummerM(~a,~b,~z)  =>  do!*kummerm(a,b,z)
   when symbolic !*rounded
      and numberp a and numberp b and numberp z
               and b neq 0
                  and impart a = 0 and impart b = 0 and impart z = 0
               and not (repart b = floor repart b
                                          and repart a = floor repart a
                                          and repart a < 0 and repart b < 0
                                          and repart a >= repart b),

%%df(kummerM(~a,~b,~z),z)  =>  (a/b) * kummerM(a+1, b+1, z),

%%df(kummerU(~a,~b,~z),z)  =>  -a * kummerU(a+1,b+1,z)

% AS (13.4.13)
df(KummerM(~a,~b,~z),z)  =>
        1/z*((b-a)*KummerM(a-1,b,z)-(b-a-z)*KummerM(a,b,z)),
% AS (13.4.26)
df(KummerU(~a,~b,~z),z)  =>
        (- KummerU(a-1,b,z) + (a-b+z)*KummerU(a,b,z))/z

})$


algebraic (let kummer!*rules);



algebraic procedure do!*kummerm(a,b,z);
   algebraic sf!*eval('kummerm!*calc, {a,b,z});


algebraic procedure kummerm!*calc(a,b,z);
   begin scalar a0, b0, z0, result, alglist!*;
      integer prepre, precom;
      precom := complex!*off!*switch();
      prepre := precision 0;
      if prepre < !!nfpd then precision (!!nfpd + 1)
      else precision (prepre + 2);
      a0 := a; b0 := b; z0 := z;
      result :=
               algebraic symbolic kummerm!*calc!*sub(a0,b0,z0);
      complex!*restore!*switch(precom);
      precision prepre;
      return result;
   end;


symbolic procedure kummerm!*calc!*sub(a,b,z);
   begin scalar result, this,
               admissable, pAmod, pBmod;
      integer rp, orda, k;
      a := sq2bf!* a; b := sq2bf!* b; z := sq2bf!* z;
      result := bfone!*; k := 1;
      pAmod := timbf(a,z); pBmod := b;
      admissable := divbf(bfone!*,
               i2bf!: (bf!*base**(5 + c!:prec!:())));
      orda := order!: admissable - 5;
      this := bfone!*; rp := c!:prec!:();
      while greaterp!: (abs!: this, admissable) do
               << this := divide!:(times!:(this,pAmod),
                            times!:(pBmod, i2bf!: k),rp);
                  rp := order!: this - orda;
                  result := plus!:(result, this);
                  k := k + 1;
                  pAmod := plus!:(pAmod, z);
                  pBmod := plus!:(pBmod, bfone!*);
               >>;
      return mk!*sq !*f2q mkround result;
   end;

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/linrec.red0000644000175000017500000001465511526203062023745 0ustar  giovannigiovannimodule linrec;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% solves (simple in) homogenous linear recursion relation REC which
% has to have the form var(n)... with initial conditions
% IC in the form of list {var(1)=?,var(2)=...}
% the method used - substitution s(n)=x^n
% like e^(lambda*x) in linear homogenous ODE.

% The inhomogenous term has to be a constant.

% The following code has been developed by Richard Liska from Prague
% for the "Barry Simon Tests for PC Magazine".
% Some checks and generalizations included by W. Neun , ZIB Berlin

% the switch trlinrec turns the verbose mode on.

switch trlinrec;

algebraic procedure rsolve (rec,ic);

begin scalar mvar1,inde,constpart,lowestind,modic,modrec,indis;

mvar1 := part(mainvar rec ,0);
inde  := mainvar part(mainvar rec,1);
indis := the_indices(foreach kk in ic collect lhs kk,mvar1);
highestind := if indis neq {} then max(indis) else NIL;
nindis := the_indices(rec,mvar1);

           % applying rule : rec where r(~n) => 0

constpart := lisp aeval list('whereexp,
                list('list,list('replaceby,list(mvar1,list('!~,'n)),0)),
                rec);

if not freeof(constpart,inde) then rederr
   ("Cant solve recurrence equations with non-constant coefficients");

if eqn(constpart,0) then return
        solve_lin_rec(rec,ic)
  else
        <<  modrec := sub (inde = inde +1,rec);
            modrec := modrec -rec;
            if (highestind) then <<
% Propagate the recursion to get additional start value
            modic := sub(inde=inde -max(nindis)+ highestind+1,rec);
            for each aa in ic do modic := sub(aa,modic);
            modic := (first solve(modic,mainvar modic)) . ic >>
            else modic := ic;
            return solve_lin_rec(modrec,modic);
         >>;
end;


fluid '(linrecx!* linrecvar!*);

algebraic procedure solve_lin_rec(rec,ic);
   % solves homogenous linear recursion relation REC which
   % has to have the form var(n)... with initial conditions
   % IC in the form of list {var(1)=?,var(2)=...}
   % the method used - substitution s(n)=x^n
   % like e^(lambda*x) in linear homogenous ODE.
   % Of course some checking should be added. (Done WN)
   begin
     scalar lrec,sol,msol,gsol,j,flagg,c,linrecvar!*,errflag,nsave;
     clear n;
     linrecvar!* := part (mainvar rec,0);
     linrecx!* := lisp gensym();
     c:= lisp mkquote gensym(); %this is the dirty part. WN
     operator c;
     if(part(rec,0) eq linrecvar!*) and arglength(ic)=1 and
                part(mainvar lhs first ic,0) = linrecvar!*
                then return rhs (first ic);
      if(part(rec,0) neq plus) then return  rederr
       "Cant solve recurrence equations with non-constant coefficients";
      lrec := arglength rec;
      lrec := part(rec,lrec);
     for all n let linrecvar!*(n) = linrecx!*^n;
     lrec := lrec;
     rec:=rec /lrec;
     for all n clear linrecvar!* (n);
     rec:=num rec;
     for each j in coeff(rec,linrecx!*) do
                if (not freeof(j,part(part (part rec,1),1)))
                        then errflag := 17; %???
     if (errflag = 17) then return rederr
       "Cant solve recurrence equations with non-constant coefficients";
     j:=1;
     for each a in solve(rec,linrecx!*) do
       <1 do
           <> >>;
     if lisp !*trlinrec then write "General solution: ",linrecvar!*
                ,"(N) := ",gsol;
     if ic = {} then sol := {} else
     sol:=solve(for each a in ic collect
                        sub(n=part(lhs a,1),gsol)=rhs a,
                for i:=1:arglength ic collect c(i));
   % If some c(i) remains it can be arbitrary  complex;
     sol := lisp subla('((equal . replaceby)),sol);
     sol := lisp subla('((equal . replaceby)),sol);
     let sol;
     gsol:=gsol;
     clearrules sol;
     let moivre_expt;
     gsol:=gsol;
     clearrules moivre_expt;

     for i:=1:j do  if coeff(gsol,lisp list(c, i)) = list(gsol) then nil
        else gsol:=
           sub(lisp list(c, i) = lisp caaar makearbcomplex(),gsol);
     return gsol
   end;

% (1 + i)**n =>     %applying Moivre's formula for complex numbers

%                N/2       N*PI          N*PI
%               2   *(COS(------) + SIN(------)*I)
%                           4             4

algebraic (moivre_expt := { (~z)^(~k) =>
              Moivre(z,k) when not  freeof(z,i)});

algebraic procedure Moivre(z,k);

  begin scalar rho,phi; % what ( will happen
  rho := sqrt( (repart z)^2 + (impart z)^2);
  if repart  z = 0 then phi := pi/2 else
          phi := atan((impart z)/(repart  z));
  return rho^k *(cos(k*phi) + i * sin (k*phi));
  end;

algebraic procedure the_indices(ex,mvar);

if part(ex,0) = list then for each kk in ex join the_indices(kk,mvar)
else
begin scalar eqq,L1,L2,kern;
  eqq := ex;
  lisp (kern := union (kernels !*q2f  (numr simp eqq ./ 1),
                        kernels !*q2f (denr simp eqq ./ 1)));

  L1 := 'list . lisp  foreach k in kern join
         if atom k then nil else if eqcar(k,mvar) then
                                list cadr k else nil;

  return L1;
end;
endmodule;
end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/fps.red0000644000175000017500000000476711526203062023264 0ustar  giovannigiovannimodule fps;       % a package for the algorithmic calculation
                % of Formal Power Series

% Author : Wolfram Koepf, ZIB Berlin

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% REDUCE version by: Winfried Neun, ZIB Berlin.
%     (September 1994)

%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %
%                                                                %
%     Please report bugs to Winfried Neun,                       %
%                           Konrad-Zuse-Zentrum                  %
%                              fuer Informationstechnik Berlin,  %
%                           Heilbronner Str. 10                  %
%                           10711 Berlin - Wilmersdorf           %
%                           Federal Republic of Germany          %
%     or by email, neun@sc.ZIB-Berlin.de                         %
%                                                                %
%  ||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||  %

create!-package ('(fps simplede substexp linrec hgrsolve constre
                        ratalgo),
                 '(contrib specfn));

packages_to_load limits,factor,specfn,sfgamma;

fluid '(ps!:order!-limit);

lisp(ps!:order!-limit := 30);

algebraic << factor factorial >>;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfbern.red0000644000175000017500000002660611526203062023747 0ustar  giovannigiovannimodule sfbern;   % Procedures for computing Bernoulli numbers.
%
% Author: Chris Cannam, Oct 1992.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Module for Euler numbers added by Kerry Gaskell, Sep 1993

%
% Note there is currently no Bernoulli polynomial function.
% There was one in an older version but it won't convert directly.
% This is Something To Be Done.

fluid '(compute!-bernoulli);

imports complex!*on!*switch, complex!*off!*switch,
   complex!*restore!*switch;

exports nearest!-int!-to!-bf, bernoulli!*calc, multi!*bern,
   single!*bern, retrieve!*bern;


algebraic operator bernoulli;
symbolic operator bernoulli!*calc;


algebraic (bernoullirules := {

   bernoulli(~n)  =>  1 when numberp n and n = 0,
   bernoulli(~n)  =>  -1/2 when numberp n and n = 1,
   bernoulli(~n)  =>  0 when numberp n and impart n = 0
      and n = floor n and n/2 neq floor (n/2) and n > 0,
   bernoulli(~n)  =>  bernoulli!*calc n when numberp n
      and impart n = 0 and n = floor n and n > 0

})$

algebraic (let bernoullirules);

algebraic procedure bernoulli!*calc n;
   begin scalar precom, result, prepre;
% Loading the SPECFAUX module will do two things.  First it will
% set compute!-bernoulli to true, so that there is no future attempt
% to load it.  Then it will set up a table of values in the variable
% bernoulli!-alist, where the table is computed at compile time rather
% than load or run-time.  This will make compiling specfaux.red a fairly
% slow process.  It also has bad consequences for any attempt to run
% this code interpreted.
% Note: ACN find the "algebraic symbolic" stuff here pretty heavy
% and confusing, but without it REDUCE sticks in calls to aeval (etc)
% in places where that is not wanted.  Maybe a future version of the
% language will make mixed algebraic/symbolic mode code less delicate.
      if (lisp null compute!-bernoulli) then
         symbolic <>;
      precom := complex!*off!*switch();
      if (prepre := precision(0)) < !!nfpd
      then precision (!!nfpd + 1);
      result := algebraic symbolic retrieve!*bern(n);
      precision prepre;
      complex!*restore!*switch(precom);
      return result;
   end;

symbolic procedure retrieve!*bern n;
   begin scalar info, result;
      integer heldpre;
      info := assoc(n, bernoulli!-alist);
      if not info then result := bern!*calc (n, '(() () ()))
      else
         << info := cdr info;
            if !*rounded then
               if (heldpre := cadr info) and heldpre >= c!:prec!:() then
                     result := mk!*sq !*f2q rd!:prep caddr info
               else if (result := car info) then
                     result := mk!*sq !*f2q mkround
                                 divbf(i2bf!: caadr result,
                                       i2bf!: cdadr result)
               else result := bern!*calc(n, info)
            else if not (result := car info) then
                  result := bern!*calc(n,info) >>;
      return result;
   end;


symbolic procedure bern!*calc(n, info);
   begin scalar result;
      result := single!*bern(n/2);
      if !*rounded then
         info := list (car info, c!:prec!:(), result)
      else info := list (result, cadr info, caddr info);
      bernoulli!-alist := (n . info) . bernoulli!-alist;
      return result;
   end;



%
%  Computation of Bernoulli numbers using the algorithms of
%     one Herbert S. Wilf, presented by Sandra Fillebrown in the
%     Journal of Algorithms 13 (1992)
%
%  Chris Cannam, October 1992
%


%
% Useful auxiliary fn.
%

symbolic procedure nearest!-int!-to!-bf(x);
   (conv!:bf2i rb)
      where rb = (if lessp!:(x,bfz!*)
         then difference!:(x,bfhalf!*)
         else plus!:(x,bfhalf!*));



%
% Procedure to compute B(2k) for k = 2 ... n
%
% Returns list of even bernoullis from B(4) to B(2n),
% in reverse order; only works when compiled, owing
% to reliance upon msd!:, which is a compiled inline
% macro.
%
% If called with rounded mode off, it computes the
% exact quotient; otherwise it will usually approximate
% (to the correct precision) if it saves time to do so.
%


symbolic procedure multi!*bern(n);
   begin scalar results, primes, tprimes, r0, rk, rkm1, b2k,
         tpi, pie, tk, n2k;
       integer thisp, gn, prepre, prernd, p2k, k2, plim, d2k;

      results := nil;
      prernd := !*rounded;
      if not prernd then on rounded;
      prepre := precision 0;

      if new!*bfs then
         << gn := 2 * n * msd!: n;
            if gn < (log2of10*!!nfpd) then precision (!!nfpd + 2)
            else if prepre > (gn/3) or not prernd then
                     precision (gn/3 + 1)
            else precision (prepre + 2) >>
      else
         << gn := 2 * n * length explode n;
            if gn < !!nfpd then precision (!!nfpd + 2)
            else if prepre > gn or not prernd then
                     precision (gn + 2)
            else precision (prepre + 2) >>;

      tpi := pi!*(); pie := divbf(bfone!*, timbf(tpi, e!*()));

      if n < 1786 then primes := !*primelist!*
      else
         << primes := nil;
            for thisp := 3573 step 2 until (2*n + 1) do
               if primep thisp then primes := thisp . primes;
            primes := append(!*primelist!*, reverse primes) >>;

      r0 := sq2bf!* algebraic ((2*pi)**(-2));
      rkm1 := timbf(i2bf!: 4, r0);

      for k := 2:n do
         << k2 := 2*k;
            rk := timbf(i2bf!:(k2*(k2 - 1)), timbf(r0, rkm1));
            rkm1 := rk;

            tk := bfone!*; d2k := 1;
            plim := 1 + conv!:bf2i timbf(i2bf!: k2, pie);

            tprimes := cdr primes; thisp := car primes;
            while thisp <= plim do
               << p2k := thisp ** k2;
                  tk := timbf(tk, divbf(i2bf!: p2k, i2bf!: (p2k - 1)));
                  thisp := car tprimes;
                  tprimes := cdr tprimes >>;

            tprimes := cdr primes; thisp := car primes;
            while thisp <= k+1 do
               << if cdr divide (k2, thisp - 1) = 0 then
                     d2k := d2k * thisp;
                  thisp := car tprimes;
                  tprimes := cdr tprimes >>;
            if primep (k2 + 1) then d2k := d2k * (k2 + 1);

            n2k := timbf(timbf(rk, tk), i2bf!: d2k);
            if prernd then
               b2k := mk!*sq !*f2q mkround
                        divbf (i2bf!: (((-1)**(k+1)) *
                              nearest!-int!-to!-bf n2k),
                           i2bf!: d2k)
            else b2k := list ('!*sq, (((-1)**(k+1)) *
                           nearest!-int!-to!-bf n2k) . d2k, t);
            results := b2k . results >>;

      precision prepre;
      if not prernd then off rounded;
      return results;

   end;



%
% Procedure to compute B(2n). If it is called with rounded
% mode off, it computes the exact quotient; otherwise it
% will approximate (to the correct precision) whenever it
% saves time to do so.
%

symbolic procedure single!*bern(n);
   begin scalar result, primes, tprimes, rn, tn, n2n, pie;
      integer d2n, thisp, gn, prepre, prernd, p2n, n2, plim;

      prernd := !*rounded;
      if not prernd then on rounded;
      prepre := precision 0;

      if new!*bfs then
         << gn := 2 * n * msd!: n;
            if gn < (log2of10*!!nfpd) then precision (!!nfpd + 2)
            else if prepre > (gn/3) or not prernd then
                      precision (gn/3 + 1)
                 else precision (prepre + 2) >>
      else
         << gn := 2 * n * length explode n;
            if gn < !!nfpd then precision (!!nfpd + 2)
            else if prepre > gn or not prernd then
                     precision (gn + 1)
                 else precision (prepre + 2) >>;

      pie := divbf(bfone!*, timbf(pi!*(), e!*()));

      if n < 1786 then primes := !*primelist!*
      else
         << primes := nil;
            for thisp := 3573 step 2 until (2*n + 1) do
               if primep thisp then primes := thisp . primes;
            primes := append(!*primelist!*, reverse primes) >>;

      n2 := 2*n;
      rn := divbf(i2bf!: (2 * factorial n2),
         sq2bf!* algebraic ((2*pi)**(n2)));

      tn := bfone!*; d2n := 1;
      plim := 1 + conv!:bf2i timbf(i2bf!: n2, pie);

      tprimes := cdr primes; thisp := car primes;
      while thisp <= plim do
         << p2n := thisp ** n2;
            tn := timbf(tn, divbf(i2bf!: p2n, i2bf!: (p2n - 1)));
            thisp := car tprimes;
            tprimes := cdr tprimes >>;

      tprimes := cdr primes; thisp := car primes;
      while thisp <= n+1 do
         << if cdr divide (n2, thisp - 1) = 0 then
               d2n := d2n * thisp;
            thisp := car tprimes;
            tprimes := cdr tprimes >>;
      if primep (n2 + 1) then d2n := d2n * (n2 + 1);

      n2n := timbf(timbf(rn, tn), i2bf!: d2n);

      precision prepre;
      if prernd then
         result := mkround divbf(i2bf!: (((-1)**(n+1)) *
                     nearest!-int!-to!-bf n2n),
                  i2bf!: d2n)
      else
         << off rounded;
            result := list ('!*sq, (((-1)**(n+1)) *
               nearest!-int!-to!-bf n2n) . d2n, t) >>;

      return result;

    end;



% Euler numbers module by Kerry Gaskell

algebraic operator Euler;

algebraic
 let {    Euler(0)  => 1,
        Euler(~n) => Euler_aux(n) when fixp n and n > 0};

flag('(euler_aux),'opfn);

symbolic procedure Euler_aux(n);

if not evenp n then 0 else

begin scalar nn,list_of_bincoeff, newlist, old, curr,eulers,sum;

list_of_bincoeff := { 1 };

eulers :={ -1,1};

nn := -2;

while N > 0 do
<<      nn := nn + 1;
        old := 0;
        newlist := {};
        while not(list_of_bincoeff = {}) do

        <<  curr := first list_of_bincoeff;
            newlist := (old + curr) . newlist;
            old := curr;
            list_of_bincoeff := rest list_of_bincoeff;
        >>;

        list_of_bincoeff := 1 . newlist;
        n := n -1        ;

% now that we have got the row of Pascal's triangle
% we can use it and compute the Next Euler number.

        if nn > 0 and evenp nn then <<
           curr := list_of_bincoeff;
           old := eulers; sum := 0;
           while old do <<
              curr := cddr curr;
              sum := sum - first old * first curr;
              old := cdr old;
              >>;
           eulers := sum . eulers;
          >>;
>>;

return first eulers;
end;

endmodule;

end;


mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/fps.hlp0000644000175000017500000000567311526203062023272 0ustar  giovannigiovanni\chapter[FPS: Formal power series]%
        {FPS: Automatic calculation of formal power series}
\label{FPS}
\typeout{[FPS: Formal power series]}

{\footnotesize
\begin{center}
Wolfram Koepf and Winfried Neun\\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
e--mail: Koepf@ZIB-Berlin.de and Neun@ZIB-Berlin.de
\end{center}
}

\ttindex{FPS}

This package can expand functions of certain type into
their corresponding Laurent-Puiseux series as a sum of terms of the form
\begin{displaymath}
\sum_{k=0}^{\infty} a_{k} (x-x_{0})^{k/n + s}
\end{displaymath}
where $s$ is the `shift number', $n$ is the `Puiseux number',
and $x_0$ is the `point of development'. The following types are
supported:
\begin{itemize}
\item
{\bf functions of `rational type'}, which are either rational or have a
rational derivative of some order;
\item
{\bf functions of `hypergeometric type'} where $a_{k+m}/a_k$ is a rational
function for some integer $m$, the `symmetry number';
\item
{\bf functions of `exp-like type'} which satisfy a linear homogeneous
differential equation with constant coefficients.
\end{itemize}

{\tt FPS(f,x,x0)}\ttindex{FPS} tries to find a formal power
series expansion for {\tt f} with respect to the variable {\tt x}
at the point of development {\tt x0}.
It also works for formal Laurent (negative exponents) and Puiseux series
(fractional exponents). If the third
argument is omitted, then {\tt x0:=0} is assumed.

Example: {\tt FPS(asin(x)\verb+^+2,x)} results in
\begin{verbatim}

         2*k  2*k             2  2
        x   *2   *factorial(k) *x
infsum(----------------------------,k,0,infinity)
        factorial(2*k + 1)*(k + 1)
\end{verbatim}
If possible, the output is given using factorials. In some cases, the
use of the Pochhammer symbol {\tt pochhammer(a,k)}$:=a(a+1)\cdots(a+k-1)$
is necessary.

{\tt SimpleDE(f,x)} tries to find a homogeneous linear differential
equation with polynomial coefficients for $f$ with respect to $x$.
Make sure that $y$ is not a used variable.
The setting {\tt factor df;} is recommended to receive a nicer output form.

Examples: {\tt SimpleDE(asin(x)\verb+^+2,x)} then results in
\begin{verbatim}
            2
df(y,x,3)*(x  - 1) + 3*df(y,x,2)*x + df(y,x)
\end{verbatim}

The depth for the search of a differential equation for {\tt f} is
controlled by the variable {\tt
fps\verb+_+search\verb+_+depth};\ttindex{fps\_search\_depth} higher
values for {\tt fps\verb+_+search\verb+_+depth} will increase the
chance to find the solution, but increases the complexity as well. The
default value for {\tt fps\verb+_+search\verb+_+depth} is 5.  For {\tt
FPS(sin(x\verb+^+(1/3)),x)}, or {\tt SimpleDE(sin(x\verb+^+(1/3)),x)}
{\em e.g.}, a setting {\tt fps\verb+_+search\verb+_+depth:=6} is necessary.

The output of the FPS package can be influenced by the\ttindex{TRACEFPS}
switch {\tt tracefps}.  Setting {\tt on tracefps} causes various
prints of intermediate results.

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.tex0000644000175000017500000007475611526203062024005 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt SPECFN}: Special Functions Package for REDUCE}
\date{}
\author{Chris Cannam, et. al.\\[0.05in]
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Takustrasse 7\\
D--14195 Berlin -- Dahlem \\
Federal Republic of Germany \\[0.05in]
E--mail: neun@zib.de \\[0.05in]
Version 2.5, October 1998}
\begin{document}
\maketitle
\index{SPECFN package}
\section{Introduction}

This package provides the 'common' special functions for REDUCE.
The names of the operators and implementation details can be
found in this document.

Due to the enormous number of special functions
a package for special functions is never complete.
Several users pointed out that important classes
of special functions were missing in the first version.
These comments and other hints from a number of contributors
and users were very helpful.

The first version of this package was developed while the author
worked as a student exchange grantee at ZIB Berlin in 1992/93.
The package is maintained by ZIB Berlin after the author left the ZIB.
Therefore, please direct comments, hints and bug reports etc. to
{\tt neun@zib.de}.
Numerous contributions have been integrated after the release with
version 3.5 of REDUCE. 

This package is designed to provide algebraic and numeric manipulations of
several common special functions, namely:

\begin{itemize}
\item Bernoulli numbers and Polynomials;
\item Euler numbers and Polynomials;
\item Fibonacci numbers and Polynomials;
\item Stirling numbers;
\item Binomial Coefficients;
\item Pochhammer notation;
\item The Gamma function;
\item The psi function and its derivatives;
\item The Riemann Zeta function;
\item The Bessel functions J and Y of the first and second kinds;
\item The modified Bessel functions I and K;
\item The Hankel functions H1 and H2;
\item The Kummer hypergeometric functions M and U;
\item The Beta function, and Struve, Lommel and Whittaker functions;
\item The Airy funcions;
\item The Exponential Integral, the Sine and Cosine Integrals;
\item The Hyperbolic Sine and Cosine Integrals;
\item The Fresnel Integrals and the Error function;
\item The Dilog function;
\item The Polylogarithm and Lerch Phi function;
\item Hermite Polynomials;
\item Jacobi Polynomials;
\item Legendre Polynomials;
\item Associated Legendre Functions (Spherical and Solid Harmonics)
\item Laguerre Polynomials;
\item Chebyshev Polynomials;
\item Gegenbauer Polynomials;
\item Lambert's $\omega$ function;
\item (Jacobi's) Elliptic Functions;
\item Elliptic Integrals;
\item 3j and 6j symbols , Clebsch-Gordan coefficients;
\item and some well-known constants.
\end{itemize}

All algorithms whose sources are uncredited are culled from series or
expressions found in the Dover Handbook of Mathematical
Functions\cite{Abramowitz:72}.

There is a nice collection of plot calls for special functions
in the file \$reduce/plot/specplot.tst. 
These examples will reproduce a number of well-known pictures from
\cite{Abramowitz:72}.

\section{Compatibility with earlier \REDUCE\ versions}

For {PSL} versions,
this package is intended to be used with the new \REDUCE\ bigfloat
mechanisms which is distributed together with REDUCE 3.5 and later versions.
The package does work with the earlier bigfloat implementations,
but in order to 
ensure that it works efficiently with the new versions, it has not been
optimized for the old.

\section{Simplification and Approximation}

All of the operators supported by this package have certain algebraic
simplification rules to handle special cases, poles, derivatives and so
on.  Such rules are applied whenever they are appropriate.  However, if
the {\tt ROUNDED} switch is on, numeric evaluation is also carried out.
Unless otherwise stated below, the result of an application of a special
function operator to real or complex numeric arguments in rounded mode
will be approximated numerically whenever it is possible to do so.  All
approximations are to the current precision.

Most algebraic simplifications within the special function package 
are defined in the form of a \REDUCE\ ruleset. Therefore, in order to
get a quick insight into the simplification rules one can use the
ShowRules operator, e.g.\\

\begin{verbatim}

ShowRules BesselI;

                          1          ~z     - ~z
{besseli(~n,~z) => ---------------*(e   - e     )
                    sqrt(pi*2*~z)

                           1
  when numberp(~n) and ~n=---,
                           2

                          1          ~z     - ~z
 besseli(~n,~z) => ---------------*(e   + e     )
                    sqrt(pi*2*~z)

                              1
  when numberp(~n) and ~n= - ---,
                              2

 besseli(~n,~z) => 0

  when numberp(~z) and ~z=0 and numberp(~n) and ~n neq 0,

 besseli(~n,~z) => besseli( - ~n,~z) when numberp(~n)

  and impart(~n)=0 and ~n=floor(~n) and ~n<0,

 besseli(~n,~z) => do*i(~n,~z)

  when numberp(~n) and numberp(~z) and *rounded,

 df(besseli(~n,~z),~z)

      besseli(~n - 1,~z) + besseli(~n + 1,~z)
  => -----------------------------------------,
                         2

 df(besseli(~n,~z),~z)

  => besseli(1,~z) when numberp(~n) and ~n=0}

\end{verbatim}

Several \REDUCE\ packages (such as Sum or Limits) obtain different
(hopefully better)
results for the algebraic simplifications when the SPECFN package 
is loaded, because the later package contains some information which
may be useful and directly applicable for other packages, e.g.:

\begin{verbatim}
sum(1/k^s,k,1,infinity); % will be evaluated to 

zeta(s)
\end{verbatim}

\ttindex{savesfs}
A record is kept of all values previously approximated, so that should a
value be required which has already been computed to the current
precision or greater, it can be simply looked up.  This can result in
some storage overheads, particularly if many values are computed which
will not be needed again.  In this case, the switch {\tt savesfs} may be
turned off in order to inhibit the storage of approximated values.  The
switch is on by default.


\section{Constants}
\ttindex{Euler\_Gamma}\ttindex{Khinchin}\ttindex{Golden\_Ratio}
\ttindex{Catalan}

Some well-known constants are defined in the special function package.
Important properties of these constants which can be used to define them
are also known. Numerical values are computed  at arbitrary precision
if the switch ROUNDED is on.

\begin{itemize}
\item Euler\_Gamma : Euler's constants, also available as -$\psi(1)$;
\item Catalan : Catalan's constant;
\item Khinchin : Khinchin's constant , defined in  \cite{Khinchin:64}.
 (takes a lot of time to compute);
\item Golden\_Ratio : $\frac{1 + \sqrt{5}}{2}$ 
\end{itemize}


\section{Bernoulli Numbers and Euler Numbers}
\ttindex{Bernoulli}\index{Bernoulli numbers}
\ttindex{Euler}\index{Euler numbers}

The unary operator {\tt Bernoulli} provides notation and computation for
Bernoulli numbers.  {\tt Bernoulli(n)} evaluates to the $n$th Bernoulli
number; all of the odd Bernoulli numbers, except {\tt Bernoulli(1)}, are
zero.

The algorithms are based upon those by Herbert Wilf, presented by Sandra
Fillebrown \cite{Fillebrown:92}.  If the {\tt ROUNDED} switch is off,
the algorithms are exactly those; if it is on, some further rounding may
be done to prevent computation of redundant digits.  Hence, these
functions are particularly fast when used to approximate the Bernoulli
numbers in rounded mode.

Euler numbers are computed by the unary operator Euler, which
return the nth Euler number. The computation is derived 
directly from Pascal's triangle of binomial coefficients.
 

\section{Fibonacci Numbers and Fibonacci Polynomials}
\ttindex{Fibonacci}\index{Fibonacci numbers}
\ttindex{Fibonacci Polynomials}

The unary operator {\tt Fibonacci} provides notation and computation for
Fibonacci numbers.  {\tt Fibonacci(n)} evaluates to the $n$th Fibonacci
number. If n is a positive or negative integer, it will be evaluated following
the definition:

$F_0 = 0 ; F_1 = 1 ; F_n = F_{n-1} + F_{n-2} $

Fibonacci Polynomials are computed by the binary operator 
FibonacciP. FibonacciP(n,x) returns the $n$th Fibonaccip polynomial
in the variable x. If n is a positive or negative integer, it will be evaluated following
the definition:

$F_0(x) = 0 ; F_1(x) = 1 ; F_n(x) = x F_{n-1}(x) + F_{n-2}(x) $


\section{Stirling Numbers}
\index{Stirling Numbers}\ttindex{Stirling1}\ttindex{Stirling2}
Stirling numbers of the first and second kind are computed 
by the binary operators {\tt Stirling1} and {\tt Stirling2}
using explicit formulae.


\section{The $\Gamma$ Function, and Related Functions}
\ttindex{Gamma}\index{$\Gamma$ function}\index{Gamma function}

\subsection{The $\Gamma$ Function}

This is represented by the unary operator {\tt Gamma}.

Initial transformations applied with {\tt ROUNDED} off are: $\Gamma(n)$ for
integral $n$ is computed, $\Gamma(n+1/2)$ for integral $n$ is rewritten to
an expression in $\sqrt\pi$, $\Gamma(n+1/m)$ for natural $n$ and $m$ a
positive integral power of 2 less than or equal to 64 is rewritten to an
expression in $\Gamma(1/m)$, expressions with arguments at which there is a
pole are replaced by {\tt INFINITY}, and those with a negative (real)
argument are rewritten so as to have positive arguments.

The algorithm used for numerical approximation is an implementation of an
asymptotic series for $ln(\Gamma)$, with a scaling factor obtained from
the Pochhammer functions.

An expression for $\Gamma'(z)$ in terms of $\Gamma$ and $\psi$ is
included.



\subsection{The Pochhammer Notation}
\ttindex{Pochhammer}\index{Pochhammer notation}

The Pochhammer notation $(a)_k$ is supported by the binary operator {\tt
Pochhammer}.  With {\tt ROUNDED} off, this expression is evaluated
numerically if $a$ and $k$ are both integral, and otherwise may be
simplified where appropriate.  The simplification rules are based upon
algorithms supplied by Wolfram Koepf \cite{Koepf:92}.



\subsection{The Digamma Function, $\psi$}
\ttindex{PSI}\index{$\psi$ function}\index{psi function}\index{Digamma
function}

This is represented by the unary operator {\tt PSI}.

Initial transformations for $\psi$ are applied on a similar basis to
those for $\Gamma$; where possible, $\psi(x)$ is rewritten in
terms of $\psi(1)$ and $\psi(\frac{1}{2})$, and expressions with negative
arguments are rewritten to have positive ones.

Numerical evaluation of $\psi$ is only carried out if the argument is
real. The algorithm used is based upon an asymptotic series, with a
suitable scaler.

Relations for the derivative and integral of $\psi$ are included.


\subsection{The Polygamma Functions, $\psi^{(n)}$}
\ttindex{Polygamma}\index{$\psi^{(n)}$ functions}\index{Polygamma
functions}

The $n$th derivative of the $\psi$ function is represented by the
binary operator {\tt Polygamma}, whose first argument is $n$.

Initial manipulations on $\psi^{(n)}$ are few; where the second argument
is $1$ or $3/2$, the expression is rewritten to one involving the
Riemann $\zeta$ function, and when the first is zero it is rewritten to
$\psi$; poles are also handled.

Numerical evaluation is only carried out with real arguments. The
algorithm used is again an asymptotic series with a scaling factor; for
negative (second) arguments, a Reflection Formula is used, introducing a
term in the $n$th derivative of $\cot(z\pi)$.

Simple relations for derivatives and integrals are provided.


\subsection{The Riemann $\zeta$ Function}
\ttindex{Zeta}\index{Riemann Zeta function}\index{Zeta
function}\index{$\zeta$ function}

This is represented by the unary operator {\tt Zeta}.

With {\tt ROUNDED} off, $\zeta(z)$ is evaluated numerically for even
integral arguments in the range $-31 < z < 31$, and for odd integral
arguments in the range $-30 < z < 16$.  Outside this range the values
become a little unwieldy.

Numerical evaluation of $\zeta$ is only carried out if the argument is real.
The algorithms used for $\zeta$ are: for odd integral arguments, an
expression relating $\zeta(n)$ with $\psi^{n-1}(3)$; for even arguments, a
trivial relationship with the Bernoulli numbers; and for other arguments the
approach is either (for larger arguments) to take the first few primes in
the standard over-all-primes expansion, and then continue with the defining
series with natural numbers not divisible by these primes, or (for smaller
arguments) to use a fast-converging series obtained from \cite{Bender:78}.

There are no rules for differentiation or integration of $\zeta$.


\section{Bessel Functions}
\ttindex{BesselJ}\ttindex{BesselY}\ttindex{BesselI}\ttindex{BesselK}\ttindex{Hankel1}\ttindex{Hankel2}\index{Bessel
functions}\index{Hankel functions}

Support is provided for the Bessel functions J and Y, the modified
Bessel functions I and K, and the Hankel functions of the first and
second kinds.  The relevant operators are, respectively, {\tt BesselJ},
{\tt BesselY}, {\tt BesselI}, {\tt BesselK}, {\tt Hankel1} and {\tt
Hankel2}, which are all binary operators.

The following initial transformations are performed:

\begin{itemize}
\item trivial cases or poles of J, Y, I and K are handled;
\item J, Y, I and K with negative first argument are transformed to have
positive first argument;
\item J with negative second argument is transformed for positive second
argument;
\item Y or K with non-integral or complex second argument is transformed
into an expression in J or I respectively;
\item derivatives of J, Y and I are carried out;
\item derivatives of K with zero first argument are carried out;
\item derivatives of Hankel functions are carried out.
\end{itemize}
Also, if the {\tt COMPLEX} switch is on and {\tt ROUNDED} is off,
expressions in Hankel functions are rewritten in terms of Bessels.

No numerical approximation is provided for the Bessel K function, or for
the Hankel functions for anything other than special cases.  The
algorithms used for the other Bessels are generally implementations of
standard ascending series for J, Y and I, together with asymptotic
series for J and Y; usually, the asymptotic series are tried first, and
if the argument is too small for them to attain the current precision,
the standard series are applied.  An obvious optimization prevents an
attempt with the asymptotic series if it is clear from the outset that
it will fail.

There are no rules for the integration of Bessel and Hankel functions.


\section{Hypergeometric and Other Functions}
\ttindex{Beta}\ttindex{KummerM}\ttindex{KummerU}\ttindex{StruveH}
\ttindex{StruveL}\ttindex{Lommel1}\ttindex{Lommel2}\ttindex{WhittakerM}
\ttindex{WhittakerW}\index{Beta function}\index{$B$ function}
\index{Kummer functions}\index{Struve functions}\index{Lommel functions}
\index{Whittaker functions}\index{Hypergeometric functions}

This package also provides some support for other functions, in the form
of algebraic simplifications:
\begin{itemize}
\item The Beta function, a variation upon the $\Gamma$
function\cite{Abramowitz:72}, with the binary operator {\tt Beta};
\item The Struve {\bf H} and {\bf L} functions, through the binary
operators {\tt StruveH} and {\tt StruveL}, for which manipulations are
provided to handle special cases, simplify to more readily handled
functions where appropriate, and differentiate with respect to the second
argument;
\item The Lommel functions of the first and second kinds, through the
ternary operators {\tt Lommel1} and {\tt Lommel2}, for which manipulations
are provided to handle special cases and simplify where appropriate;
\item The Kummer confluent hypergeometric functions M and U (the
hypergeometric ${_1F_1}$ or $\Phi$, and $z^{-a}{_2F_0}$ or $\Psi$,
respectively),
with the ternary operators {\tt KummerM} and {\tt KummerU}, for which
there are manipulations for special cases and simplifications, derivatives
and, for the M function, numerical approximations for real arguments;
\item The Whittaker M and W functions, variations upon the Kummer
functions, which, with the ternary operators {\tt WhittakerM} and {\tt
WhittakerW}, simplify to expressions in the Kummer functions.
\end{itemize}

\section{Integral Functions}

The SPECFN package includes manipulation and a limited numerical
evaluation for some Integral functions, namely

erf, erfc, Si, Shi, si, Ci, Chi, Ei, li,  Fresnel\_C and Fresnel\_S.

The definitions from integral, the derviatives and some limits are
known together with some simple properties such as symmetry
conditions.

The numerical approximation for the Integral functions suffer
from the fact that the precision is not set correctly for
values of the argument above 10.0 (approx.) and from the
usage of summations even for large arguments.

$li$ is simplified towards $Ei(ln(z))$ . 

\section{Airy Functions}
\ttindex{Airy\_Ai}\ttindex{Airy\_Bi}\ttindex{Airy\_Aiprime}
\ttindex{Airy\_Biprime}\index{Airy Functions}

Support is provided for the Airy Functions Ai and Bi and for the
Airyprime Functions Aiprime and Biprime. The relevant operators are
respectively {\tt Airy\_Ai}, {\tt Airy\_Bi}, {\tt Airy\_Aiprime}, and
{\tt Airy\_Biprime}, which are all unary operators with one argument.

The following cases can be performed:

\begin{itemize}
\item Trivial cases of Airy\_Ai and Airy\_Bi and their primes are handled.
\item All cases can handle both complex and real arguments.
\item The Airy Functions can also be represented in terms of Bessel
Functions by activating an inactive rule set.
\end{itemize}

In order to activate the Airy Function to Bessel Rules one should type: \\
{\tt let Airy2Bessel\_rules;}. As a result the Airy\_Ai function,
for example will be calculated using the formula :- \\
\\
{\tt Ai(z) = } $\frac{1}{3}$\( \sqrt{z} \)[{\bf {\sl I}}$_{-1/3}$($\zeta$)
- {\bf {\sl I}}$_{1/3}$({$\zeta$})] , where
 $\zeta$ =  $\frac{2}{3} z^{\frac{2}{3}}$\\
\\
\underline{{\tt Note}}:- In order to obtain satisfactory approximations
to results both the {\tt COMPLEX} and {\tt ROUNDED} switches must be on.

The algorithms used for the Airy Functions are implementations of
standard ascending series, together with asymptotic series. At some
point it is better to use the asymptotic approach, rather than the
series. This value is calculated by the program and depends on the given
precision.

There are no rules for the integration of Airy Functions.

\section{Polynomial Functions}

Two groups are defined, some well-known orthogonal Polynomials
(Hermite, Jacobi, Legendre, Laguerre, Chebyshev, Gegenbauer)
and Euler and Bernoulli Polynomials.
The names of the \REDUCE\  operator are build by adding a P
to the name
of the polynomials, e.g. EulerP implements the Euler polynomials.
Most definitions are equivalent to \cite{Abramowitz:72}, except
for the ternary (associated) Legendre Polynomials.

\begin{verbatim}
P(n,m,x) = (-1)^m *(1-x^2)^(m/2)*df(legendreP (n,x),x,m)
\end{verbatim}

\section{Spherical and Solid Harmonics}
\ttindex{SolidHarmonicY} \ttindex{SphericalHarmonicY}
 
The relevant operators are, respectively,\\
{\tt SolidHarmonicY} and {\tt SphericalHarmonicY}.

The SolidHarmonicY operator implements the Solid Harmonics
described below. It expects 6 parameter, namely n,m,x,y,z and r2
and returns a polynomial in x,y,z and r2.

The operator
SphericalHarmonicY is a special case of SolidHarmonicY
with the usual definition:

\begin{verbatim}
algebraic procedure SphericalHarmonicY(n,m,theta,phi);
        SolidHarmonicY(n,m,sin(theta)*cos(phi),
                sin(theta)*sin(phi),cos(theta),1)$
\end{verbatim}


Solid Harmonics of order n (Laplace polynomials)
are homogeneous polynomials of degree n in x,y,z
which are solutions of Laplace equation:-

\begin{verbatim}
       df(P,x,2) + df(P,y,2) + df(P,z,2) = 0.
\end{verbatim}

There are 2*n+1 independent such polynomials for any given $n >=0$
and with:-

\begin{verbatim}
       w!0 = z, w!+ = i*(x-i*y)/2, w!- = i*(x+i*y)/2,
\end{verbatim}

they are given by the Fourier integral:-

\begin{verbatim}
 S(n,m,w!-,w!0,w!+) =

       (1/(2*pi)) *
       for u:=-pi:pi integrate (w!0 + w!+ * exp(i*u) + w!- *
           exp(-i*u))^n * exp(i*m*u) * du;
\end{verbatim}

which is obviously zero if $|m| > n$ since then all terms in the
expanded integrand contain the factor exp(i*k*u) with k neq 0,

S(n,m,x,y,z) is proportional to
\begin{verbatim}
     r^n * Legendre(n,m,cos theta) * exp(i*phi)
\end{verbatim}

Let r2 = $x^2 + y^2 + z^2$ and r = sqrt(r2).

The spherical harmonics are simply the restriction of the solid
harmonics to the surface of the unit sphere and the set of all
spherical harmonics {$n >=0; -n <= m =< n$} form a complete orthogonal
basis on it, i.e. $$ = Kronecker\_delta(n,n') *
Kronecker\_delta(m,m') using
$<...|...>$ to designate the scalar product
of functions over the spherical surface.

The coefficients of the solid harmonics are normalised in what
follows to yield an ortho-normal system of spherical harmonics.

Given their polynomial nature, there are many recursions formulae
for the solid harmonics and any recursion valid for Legendre functions
can be 'translated' into solid harmonics. However the direct proof is
usually far simpler using Laplace's definition.

It is also clear that all differentiations of solid harmonics are
trivial, qua polynomials.

Some substantial reduction in the symbolic form would occur if one
maintained throughout the recursions the symbol r2 (r cannot occur
as it is not rational in x,y,z). Formally the solid harmonics appear
in this guise as more compact polynomials in (x,y,z,r2).

Only two recursions are needed:-

(i) along the diagonal (n,n);

(ii) along a line of constant n: (m,m),(m+1,m),...,(n,m).

Numerically these recursions are stable.

For $m < 0$ one has:-

\begin{verbatim}
      S(n,m,x,y,z) = (-1)^m * S(n,-m,x,-y,z);
\end{verbatim}

\section{Jacobi's Elliptic Functions}

The following functions have been implemented:

\begin{itemize}
\item The Twelve Jacobi Functions
\item Arithmetic Geometric Mean
\item Descending Landen Transformation
\end{itemize}

\subsection{Jacobi Functions}

The following Jacobi functions are available:-

\begin{itemize}
\item Jacobisn(u,m)
\item Jacobidn(u,m)
\item Jacobicn(u,m)
\item Jacobicd(u,m)
\item Jacobisd(u,m)
\item Jacobind(u,m)
\item Jacobidc(u,m)
\item Jacobinc(u,m)
\item Jacobisc(u,m)
\item Jacobins(u,m)
\item Jacobids(u,m)
\item Jacobics(u,m)
\end{itemize}

They will be evaluated numerically if the {\tt rounded} switch is used.

\subsection{Amplitude}

The amplitude of u can be evaluated using the 
{\tt JacobiAmplitude(u,m)} command.

\subsection{Arithmetic Geometric Mean}

A procedure to evaluate the AGM of initial values \(a_0,b_0,c_0\) 
exists as \\
{\tt AGM\_function(\(a_0,b_0,c_0\))} and will return \\
$\{ N, AGM, \{ a_N, \ldots ,a_0\}, \{ b_N, \ldots ,b_0\}, 
\{c_N, \ldots ,c_0\}\}$, 
where N is the number of steps to compute the AGM to the 
desired acuracy. \\

To determine the Elliptic Integrals K($m$), E($m$) we use initial values
\(a_0 = 1\); \(b_0 = \sqrt{1-m}\) ; \(c_0 = \sqrt{m}\).


\subsection{Descending Landen Transformation}

The procedure to evaluate the Descending Landen Transformation of 
phi and alpha uses the following equations:\\
\indent \ \ \ \ \( (1+sin \alpha_{n+1})(1+cos \alpha_n)=2 \) 
\ \ \ \ where \(\alpha_{n+1}<\alpha_n\) \\
\indent \ \ \ \ \(tan(\phi_{n+1}-\phi_n)=cos \alpha_n tan \phi_n \) 
\ \ \ where \(\phi_{n+1}>\phi_n\) \\

It can be called using {\tt landentrans($\phi_0$,$\alpha_0$)}
and will return \\
$\{\{\phi_0, \ldots ,\phi_n\},\{\alpha_0, \ldots ,\alpha_n\}\}$.

\section{Elliptic Integrals}
The following functions have been implemented:

\begin{itemize}
\item Elliptic Integrals of the First Kind
\item Elliptic Integrals of the Second Kind
%\item Ellpitic Integrals of the Third Kind
\item Jacobi $\theta$ Functions
\item Jacobi $\zeta$ Function
\end{itemize}

\subsection{Elliptic F}

The Elliptic F function can be used as {\tt EllipticF($\phi$,m)} and 
will return the value of the {\underline {Elliptic Integral of the 
First Kind}}.

\subsection{Elliptic K}

The Elliptic K function can be used as {\tt EllipticK(m)} and will 
return the value of the {\underline {Complete Elliptic Integral of the
First Kind}}, K. It is often used in the calculation of other elliptic
functions

\subsection{Elliptic K$'$}

The Elliptic K$'$ function can be used as {\tt EllipticK!$'$(m)} and will 
return the value K($1-m$).

\subsection{Elliptic E}

The Elliptic E function comes with two different numbers of arguments:

It can be used with two arguments as {\tt EllipticE($\phi$,m)}
and will return the value
of the {\underline {Elliptic Integral of the Second Kind}}.

The Elliptic E function can also be used as {\tt EllipticE(m)} and 
will return the value of the {\underline {Complete Elliptic Integral 
of the Second Kind}}, E.

%\section{Ellpitic $\Pi$}
%
%The Elliptic $\pi$ function can be used as {\tt EllipticPi( )} and 
%will return the value of the {\underline {Elliptic Integral of the 
%Third Kind}}.
%
\subsection{Elliptic $\Theta$ Functions}

This can be used as {\tt EllipticTheta(a,u,m)}, where $a$ is the index 
for the theta functions ($a = 1,2,3$ or $4$) and will return $H$; 
$H_1$; $\Theta_1$; $\Theta$. (Also denoted in some texts as 
$\vartheta_1$; $\vartheta_2$; $\vartheta_3$; $\vartheta_4$.)

\subsection{Jacobi's Zeta Function Z }

This can be used as {\tt JacobiZeta(u,m)} and will return 
Jacobi Zeta. Note: the operator {\tt Zeta} will invoke Riemann's
$\zeta$ function.

\section{Lambert's W function}

Lambert's W function is the inverse of the function  $w*e^w$.
Therefore it is an important contribution for the solve package.
The function is studied extensively in \cite{Corless:92}.  
The current implementation will compute the principal branch in
ROUNDED mode only.

\section{3j symbols and Clebsch-Gordan Coefficients}
The operators {\tt ThreeJSymbol}, {\tt Clebsch\_Gordan} are defined like 
in \cite{Landolt:68} or \cite{Edmonds:57}. ThreeJSymbol expects as arguments
three lists of values \{$j_i,m_i$\}, e.g.

\begin{verbatim}
ThreeJSymbol({J+1,M},{J,-M},{1,0});
Clebsch_Gordan({2,0},{2,0},{2,0});
\end{verbatim}

\section{6j symbols }
The operator {\tt SixJSymbol} is defined like
in \cite{Landolt:68} or \cite{Edmonds:57}.
SixJSymbol expects two lists of values \{$j_1,j_2,j_3$\} and
 \{$l_1,l_2,l_3$\} as arguments, e.g.

\begin{verbatim}
SixJSymbol({7,6,3},{2,4,6});
\end{verbatim}

In the current implementation of the SixJSymbol, there is only a limited
reasoning about the minima and maxima of the summation using
the INEQ package, such that in most
cases the special 6j-symbols (see e.g. \cite{Landolt:68})
will not be found.



\section{Acknowledgements}

The contributions of Kerry Gaskell, Matthew Rebbeck, Lisa Temme,
Stephen Scowcroft and David Hobbs (all students from the University of Bath
on placement in ZIB Berlin for one year) were very helpful
to augment the package. The advise of Ren\'e Grognard (CSIRO , Australia)
for the development of the module for Clebsch-Gordan and 3j, 6j symbols
and the module for spherical and solid harmonics was very much appreciated.

\section{Table of Operators and Constants}

\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline 
$J_\nu(z)$ & {\tt BesselJ(nu,z)}\\
$Y_\nu(z)$ & {\tt BesselY(nu,z)}\\
$I_\nu(z)$ & {\tt BesselI(nu,z)}\\
$K_\nu(z)$ & {\tt BesselK(nu,z)}\\
$H^{(1)}_\nu(z)$ & {\tt Hankel1(n,z)}\\
$H^{(2)}_\nu(z)$ & {\tt Hankel2(n,z)}\\
${\bf H}_{\nu}(z)$ & {\tt StruveH(nu,z)}\\
${\bf L}_{\nu}(z)$ & {\tt StruveL(n,z)}\\
$s_{a,b}(z)$ & {\tt Lommel1(a,b,z)}\\
$S_{a,b}(z)$ & {\tt Lommel2(a,b,z)}\\
$Ai(z)$ & {\tt Airy\_Ai(z)}\\
$Bi(z)$ & {\tt Airy\_Bi(z)}\\
$Ai'(z)$ & {\tt Airy\_Aiprime(z)}\\
$Bi'(z)$ & {\tt Airy\_Biprime(z)}\\
$M(a, b, z)$ or $_1F_1(a, b; z)$ or $\Phi(a, b; z)$ &
{\tt KummerM(a,b,z)} \\
$U(a, b, z)$ or $z^{-a}{_2F_0(a, b; z)}$ or $\Psi(a, b; z)$ &
{\tt KummerU(a,b,z)}\\
$M_{\kappa,\mu}(z)$ & {\tt WhittakerM(kappa,mu,z)}\\
$W_{\kappa,\mu}(z)$ & {\tt WhittakerW(kappa,mu,z)}\\
\\
Fibonacci Numbers $F_{n}$ &  {\tt Fibonacci(n)}\\
Fibonacci Polynomials $F_{n}(x)$ &  {\tt FibonacciP(n)}\\
$B_n(x)$ & {\tt BernoulliP(n,x)}\\
$E_n(x)$ & {\tt EulerP(n,x)}\\
$C_n^{(\alpha)}(x)$ & {\tt GegenbauerP(n,alpha,x)}\\
$H_n(x)$ & {\tt HermiteP(n,x)}\\
$L_n(x)$ & {\tt LaguerreP(n,x)}\\
$L_n^{(m)}(x)$ & {\tt LaguerreP(n,m,x)}\\
$P_n(x)$ & {\tt LegendreP(n,x)}\\
$P_n^{(m)}(x)$ & {\tt LegendreP(n,m,x)}\\
\end{tabular}}

\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline
$P_n^{(\alpha,\beta)} (x)$ & {\tt JacobiP(n,alpha,beta,x)}\\
$U_n(x)$ & {\tt ChebyshevU(n,x)}\\
$T_n(x)$ & {\tt ChebyshevT(n,x)}\\
$Y_n^{m}(x,y,z,r2)$ & {\tt SolidHarmonicY(n,m,x,y,z,r2)}\\
$Y_n^{m}(\theta,\phi)$ & {\tt SphericalHarmonicY(n,m,theta,phi)}\\
$\left( {j_1 \atop m_1} {j_2 \atop m_2}
 {j_3 \atop m_3} \right)$ & {\tt ThreeJSymbol(\{j1,m1\},\{j2,m2\},\{j3,m3\})}\\
$\left( {j_1m_1j_2m_2 | j_1j_2j_3 - m_3} \right)$ &
{\tt Clebsch\_Gordan(\{j1,m1\},\{j2,m2\},\{j3,m3\})}\\
$\left\{ {j_1 \atop l_1} {j_2 \atop l_2}
 {j_3 \atop l_3} \right\}$  & {\tt SixJSymbol(\{j1,j2,j3\},\{l1,l2,l3\})}\\
\\
$sn(u|m)$ & {\tt Jacobisn(u,m)}\\
$dn(u|m)$ & {\tt Jacobidn(u,m)}\\
$cn(u|m)$ & {\tt Jacobicn(u,m)}\\
$cd(u|m)$ & {\tt Jacobicd(u,m)}\\
$sd(u|m)$ & {\tt Jacobisd(u,m)}\\
$nd(u|m)$ & {\tt Jacobind(u,m)}\\
$dc(u|m)$ & {\tt Jacobidc(u,m)}\\
$nc(u|m)$ & {\tt Jacobinc(u,m)}\\
$sc(u|m)$ & {\tt Jacobisc(u,m)}\\
$ns(u|m)$ & {\tt Jacobins(u,m)}\\
$ds(u|m)$ & {\tt Jacobids(u,m)}\\
$cs(u|m)$ & {\tt Jacobics(u,m)}\\
$F(\phi|m)$ & {\tt EllipticF(phi,m)}\\
$K(m)$ & {\tt EllipticK(m)}\\
$E(\phi|m) or E(m)$ & {\tt EllipticE(phi,m) or EllipticE(m)}\\
$H(u|m), H_1(u|m), \Theta_1(u|m), \Theta(u|m)$ & {\tt EllipticTheta(a,u,m)}\\
$\theta_1(u|m), \theta_2(u|m), \theta_3(u|m), \theta_4(u|m)$
   & {\tt EllipticTheta(a,u,m)}\\
$Z(u|m)$ & {\tt Zeta\_function(u,m)}\\
\\ 
Lambert $\omega(z)$ & {\tt Lambert\_W(z)} \\
\\
Constant & REDUCE name \\\\
Euler's $\gamma$ constant & {\tt Euler\_gamma}\\
Catalan's constant & {\tt Catalan}\\
Khinchin's constant & {\tt Khinchin}\\
Golden ratio & {\tt Golden\_ratio}\\
\end{tabular}}
\newpage
\fbox{
\begin{tabular}{r l}\\
\\
Function & Operator \\
\\
$\left( { n \atop m } \right)$ & {\tt Binomial(n,m)} \\
Motzkin(n) & {\tt Motzkin(n)}\\
Bernoulli($n$) or $ B_n $ & {\tt Bernoulli(n)} \\
Euler($n$) or $ E_n $ & {\tt Euler(n)} \\
$S_n^{(m)}$ & {\tt Stirling1(n,m)} \\
${\bf S}_n^{(m)}$ & {\tt Stirling2(n,m)} \\
$B(z,w)$ & {\tt Beta(z,w)}\\
$\Gamma(z)$ & {\tt Gamma(z)} \\
incomplete Beta $B_{x}(a,b)$ & {\tt iBeta(a,b,x)}\\
incomplete Gamma $\Gamma(a,z)$ & {\tt iGamma(a,z)} \\
$(a)_k$ & {\tt Pochhammer(a,k)} \\
$\psi(z)$ & {\tt Psi(z)} \\
$\psi^{(n)}(z)$ & {\tt Polygamma(n,z)} \\
Riemann's $\zeta(z)$ & {\tt Zeta(z)} \\
\\
$Si(z)$ & {\tt Si(z) }\\
$si(z)$ & {\tt s\_i(z) }\\
$Ci(z)$ & {\tt Ci(z) }\\
$Shi(z)$ & {\tt Shi(z) }\\
$Chi(z)$ & {\tt Chi(z) }\\
$erf(z)$ & {\tt erf(z) }\\
$erfc(z)$ & {\tt erfc(z) }\\
$Ei(z)$ & {\tt Ei(z) }\\
$li(z)$ & {\tt li(z) }\\
$C(x)$ & {\tt Fresnel\_C(x)} \\
$S(x)$ & {\tt Fresnel\_S(x)} \\
\\
$dilog(z)$ & {\tt dilog(z)} \\
$Li_{n}(z)$ & {\tt Polylog(n,z)}\\
Lerch $\Phi(z,s,a)$ & {\tt Lerch\_Phi(z,s,a)}\\
\end{tabular}}

\bibliography{specfn}
\bibliographystyle{plain}

\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfconsts.red0000644000175000017500000001157711526203062024333 0ustar  giovannigiovannimodule sfconsts; % Constants from pecial functions such as Euler_Gamma,
                 % Catalan, Khinchin.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic let Euler_gamma => compute_Euler_gamma();

symbolic flag('(compute_Euler_gamma),'opfn);

symbolic procedure compute_Euler_gamma ();

  if not(!*rounded) then mk!*sq('((((Euler_gamma . 1) . 1)) . 1))
         else aeval '(minus (psi 1));

%%%%%%%%%%%%%%%

algebraic let  Golden_Ratio = (1 + sqrt(5))/2; % for Architects

%%%%%%%%%%%%%%%%

fluid '(intlogrem);

Comment this program is taken from:

COMPUTATION OF CATALAN'S CONSTANT USING RAMANUJAN'S FORMULA

Greg J. Fee, Dept of Comp Sci, U of Waterloo,

published in ISSAC '90, ACM press ;

algebraic let catalan => compute_catalan();

symbolic flag('(compute_catalan),'opfn);

symbolic procedure compute_catalan ();

  if not(!*rounded) then mk!*sq('((((catalan . 1) . 1)) . 1)) else
   begin scalar ii,j,p,tt,s,g,!*rounded;

      g := !:prec!: + length explode !:prec!: + 3;
      p := 10^g/2;
      tt := p; s := tt; j :=1; ii := 1;

      while tt > 0 do
        << j := j+2; p := (p*ii) / j; tt := (tt * ii + p)/j;
           s := s + tt; ii := ii + 1 >>;

      return list('quotient,s,10^(g));
  end;

%%%%%%%%%%%%%%%%%%%%

algebraic <<

% Khinchin's constant =(prod((1+1/(n*(n+2)))^(ln n/ln2),n,1,infinity))
%
% translated from a (Maple code) posting by Paul Zimmermann
%       in sci.math.symbolic
%
let Khinchin => compute_Khinchin();

symbolic procedure compute_Khinchin();

 (if not(!*rounded) then mk!*sq('((((Khinchin . 1) . 1)) . 1)) else
    aeval ('compute_Khinchin1 . NIL)) where !:prec!: = !:prec!: ;

symbolic flag('(compute_Khinchin intlog),'opfn);

procedure compute_Khinchin1();
  begin scalar term,summ,acc,k,ln2,ln3,oldprec,zp;
     if evenp(oldprec := precision 0) then
             precision (oldprec+13) else
             precision (oldprec+12);
     acc := 10^(-oldprec -3);
     ln2 := log 2;
     ln3 := log 3;
     k:=2;
     term :=1; summ :=0;
     while abs(term) > acc do <<
        zp := Zetaprime(k);
        term :=(-1)^k*(2*zp-2^k*(zp+ln2/2^k+ln3/3^k))/k;
        summ := summ + term;
        k:=k+1   >>;

     summ := e^(summ /ln2+ln3/ln2*(2./3-log(5/3))+1-ln2);
     precision(oldprec);
     return summ;
  end;

procedure Zetaprime (u);

  begin scalar term,summ,n,acc,f,j,logm,m,oldprec;
     oldprec := precision 0;
     precision(oldprec+5);
     n:= u;
     lisp setq(intlogrem,nil);
     f := -df(log(x)/x^n,x)/2;
     m:= (oldprec+5)/2;
     logm := log(m);
     term := logm;
     acc := 10^(1-(oldprec +5))/2;
     j:=1;
     summ := -(for ii:=2:(fix m -1) sum intlog(ii)/ii^n) -
        (logm+1/(n-1))/m^(n-1)/(n-1)-logm/2/m^n;
     while abs(term) > acc do
          << term := Bernoulli(2*j) * sub(log(x)=logm,x=m,f);
             f := df(f,x,x)/((4j+6)*j +2);
             summ := summ -term;
             j:= j+1;
           >>;
     precision oldprec;
     return summ;
  end;

symbolic procedure intlog(n);

  ( if found := atsoc(n,intlogrem) then cdr found else
       << found := intlog1 n;
    intlogrem := (( n . found)  . intlogrem);
          found >>) where found = nil;

symbolic procedure intlog1 (n);

 (if n=2 or n=3 or n=4 or n=5 or n=7 then
                rdlog!* ('!:rd!: . (n . 0)) else
  if cdr(div := divide(n,2)) #= 0 then
                rd!:plus(intlog 2,intlog(car div)) else
  if cdr(div := divide(n,3)) #= 0 then
                rd!:plus(intlog 3,intlog(car div)) else
  if cdr(div := divide(n,5)) #= 0 then
                rd!:plus(intlog 5,intlog(car div)) else
  if cdr(div := divide(n,7)) #= 0 then
                rd!:plus(intlog 7,intlog(car div)) else
   rdlog!* ('!:rd!: . (n . 0))) where div = nil;

>>;
endmodule;

end;





mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfbdata.red0000644000175000017500000000435411526203062024070 0ustar  giovannigiovannimodule sfbdata;  % Generate necessary data for Bernoulli computation.

% Author:  Winfried Neun.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(compute!-bernoulli);

global '(!*force);

flag('(force),'switch);

flag('(on),'eval);

on force;

symbolic macro procedure mk!-bernoulli u;
   <>;

% When I read in save!-bernoulli the macro mk!-bernoulli() will get
% expanded.  This is because of the RLISP flag "*force".  The effect
% will be that the definition of save!-bernoulli() is in effect
% just   bernoulli!-alist := '((....))

symbolic procedure save!-bernoulli();
   bernoulli!-alist := mk!-bernoulli();

% I want to execute save!-bernoulli() just once to initialize the
% table.  That way even if I am running interpreted the painfully
% slow initial calculation of the table gets done only once when
% I first process this chunk of code.

save!-bernoulli()$

compute!-bernoulli := t;

off force;

remflag('(on),'eval);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/fps.tex0000644000175000017500000001437511526203062023306 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt FPS}\\ 
A Package for the\\
Automatic Calculation \\
of Formal Power Series}
\date{}
\author{Wolfram Koepf\\
	ZIB Berlin \\
	Email: {\tt  Koepf@ZIB.de}
\\
\\
	Present \REDUCE{} form by \\
	Winfried Neun \\
	ZIB Berlin \\
        Email: {\tt Neun@ZIB.de}}
\begin{document}
\maketitle

\section{Introduction}
This package can expand functions of certain type into
their corresponding Laurent-Puiseux series as a sum of terms of the form
\begin{displaymath}
\sum_{k=0}^{\infty} a_{k} (x-x_{0})^{m k/n + s}
\end{displaymath}
where $m$ is the `symmetry number', $s$ is the `shift number',
$n$ is the `Puiseux number',
and $x_0$ is the `point of development'. The following types are
supported:
\begin{itemize}
\item
{\bf functions of `rational type'}, which are either rational or have a
rational derivative of some order;
\item
{\bf functions of `hypergeometric type'} where $a(k+m)/a(k)$ is a rational
function for some integer $m$;
\item
{\bf functions of `explike type'} which satisfy a linear homogeneous
differential equation with constant coefficients.
\end{itemize}

The FPS package is an implementation of the method
presented in \cite{Koepf:92}. The implementations of this package
for {\sc Maple} (by D.\ Gruntz) and {\sc Mathematica} (by W.\ Koepf)
served as guidelines for this one.

Numerous examples can be found in \cite{Koepf:93a}--\cite{Koepf:93b}, 
most of which are contained in the test file {\tt fps.tst}. Many 
more examples can be found in the extensive bibliography of Hansen \cite{Han}.


\section{\REDUCE{} operator {\tt FPS}}
The FPS Package must be loaded first by:
\begin{verbatim}
load FPS;
\end{verbatim}
{\tt FPS(f,x,x0)} tries to find a formal power
series expansion for {\tt f} with respect to the variable {\tt x} 
at the point of development {\tt x0}. 
It also works for formal Laurent (negative exponents) and Puiseux series
(fractional exponents). If the third 
argument is omitted, then {\tt x0:=0} is assumed.

Examples: {\tt FPS(asin(x)\verb+^+2,x)} results in
\begin{verbatim}

         2*k  2*k             2  2
        x   *2   *factorial(k) *x
infsum(----------------------------,k,0,infinity)
        factorial(2*k + 1)*(k + 1)
\end{verbatim}
{\tt FPS(sin x,x,pi)} gives
\begin{verbatim}
                   2*k       k
        ( - pi + x)   *( - 1) *( - pi + x)
infsum(------------------------------------,k,0,infinity)
                factorial(2*k + 1)
\end{verbatim}
and {\tt FPS(sqrt(2-x\verb+^+2),x)} yields
\begin{verbatim}
            2*k
         - x   *sqrt(2)*factorial(2*k)
infsum(--------------------------------,k,0,infinity)
           k             2
          8 *factorial(k) *(2*k - 1)
\end{verbatim}
Note: The result contains one or more {\tt infsum} terms such that it does
not interfere with the {\REDUCE} operator {\tt sum}. In graphical oriented
REDUCE interfaces this operator results in the usual $\sum$ notation.

If possible, the output is given using factorials. In some cases, the
use of the Pochhammer symbol {\tt pochhammer(a,k)}$:=a(a+1)\cdots(a+k-1)$
is necessary.

The operator {\tt FPS} uses the operator {\tt SimpleDE} of the next section.

If an error message of type
\begin{verbatim}
Could not find the limit of:
\end{verbatim}
occurs, you can set the corresponding limit yourself and try a
recalculation. In the computation of {\tt FPS(atan(cot(x)),x,0)},
REDUCE is not able to find the value for the limit 
{\tt limit(atan(cot(x)),x,0)} since the {\tt atan} function is multi-valued.
One can choose the branch of {\tt atan} such that this limit equals
$\pi/2$ so that we may set 
\begin{verbatim}
let limit(atan(cot(~x)),x,0)=>pi/2;
\end{verbatim}
and a recalculation of {\tt FPS(atan(cot(x)),x,0)}
yields the output {\tt pi - 2*x} which is
the correct local series representation.

\section{\REDUCE{} operator {\tt SimpleDE}}

{\tt SimpleDE(f,x)} tries to find a homogeneous linear differential
equation with polynomial coefficients for $f$ with respect to $x$.
Make sure that $y$ is not a used variable.
The setting {\tt factor df;} is recommended to receive a nicer output form.

Examples: {\tt SimpleDE(asin(x)\verb+^+2,x)} then results in
\begin{verbatim}
            2
df(y,x,3)*(x  - 1) + 3*df(y,x,2)*x + df(y,x)
\end{verbatim}
{\tt SimpleDE(exp(x\verb+^+(1/3)),x)} gives
\begin{verbatim}
              2
27*df(y,x,3)*x  + 54*df(y,x,2)*x + 6*df(y,x) - y
\end{verbatim}
and {\tt SimpleDE(sqrt(2-x\verb+^+2),x)} yields
\begin{verbatim}
          2
df(y,x)*(x  - 2) - x*y
\end{verbatim}
The depth for the search of a differential equation for {\tt f} is
controlled by the variable {\tt fps\verb+_+search\verb+_+depth};
higher values for {\tt fps\verb+_+search\verb+_+depth}
will increase the chance to find the solution, but increases the
complexity as well. The default value for {\tt fps\verb+_+search\verb+_+depth} 
is 5. For {\tt FPS(sin(x\verb+^+(1/3)),x)}, or 
{\tt SimpleDE(sin(x\verb+^+(1/3)),x)} e.\ g., a setting
{\tt fps\verb+_+search\verb+_+depth:=6} is necessary.

The output of the FPS package can be influenced by the
switch {\tt tracefps}. Setting {\tt on tracefps} causes various
prints of intermediate results.

\section{Problems in the current version}
The handling of logarithmic singularities is not yet implemented.

The rational type implementation is not yet complete.

The support of special functions \cite{Koepf:94}
will be part of the next version.

\begin{thebibliography}{9}

\bibitem{Han}
E.\ R. Hansen, {\em A table of series and products.}
Prentice-Hall, Englewood Cliffs, NJ, 1975.

\bibitem{Koepf:92} Wolfram Koepf,
{\em Power Series in Computer Algebra},
J.\ Symbolic Computation 13 (1992)

\bibitem{Koepf:93a} Wolfram Koepf,
{\em Examples for the Algorithmic Calculation of Formal
Puiseux, Laurent and Power series},
SIGSAM Bulletin 27, 1993, 20-32.

\bibitem{Koepf:93b} Wolfram Koepf,
{\em Algorithmic development of power series.} In:
Artificial intelligence and symbolic mathematical computing,
ed.\ by J.\ Calmet and J.\ A.\ Campbell,
International Conference AISMC-1, Karlsruhe, Germany, August 1992, Proceedings,
Lecture Notes in Computer Science {\bf 737}, Springer-Verlag,
Berlin--Heidelberg, 1993, 195--213.

\bibitem{Koepf:94} Wolfram Koepf,
{\em Algorithmic work with orthogonal polynomials and special functions.}
Konrad-Zuse-Zentrum Berlin (ZIB), Preprint SC 94-5, 1994.

\end{thebibliography}

\end{document}



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.bib0000644000175000017500000000265111526203062023722 0ustar  giovannigiovanni@ARTICLE{Fillebrown:92,
   AUTHOR = "Sandra Fillebrown",
   TITLE = "Faster Computation of Bernoulli Numbers",
   JOURNAL = "Journal of Algorithms",
   YEAR = 1992, VOLUME = 13, PAGES = "431-445"}

@BOOK{Abramowitz:72,
   EDITOR = "Milton Abramowitz and Irene A. Stegun",
   TITLE = "Handbook of Mathematical Functions",
   PUBLISHER = "Dover Publications, New York",
   YEAR = 1972}

@ARTICLE{Koepf:92,
   AUTHOR = "Wolfram Koepf",
   TITLE = "Power Series in Computer Algebra",
   JOURNAL = "Journal of Symbolic Computation",
   YEAR = 1992, VOLUME = 13, PAGES = "581-603"}

@BOOK{Bender:78,
   AUTHOR = "Carl M. Bender and Steven A. Orszag",
   TITLE = "Advanced Mathematical Methods for Scientists and Engineers",
   PUBLISHER = "McGraw-Hill",
   YEAR = 1978}

@BOOK{Landolt:68,
   AUTHOR = "Landolt-Boernstein",
   TITLE = "Zahlenwerte und Funktionen aus Naturwissenschaften und Technik",
   PUBLISHER = "Springer",
   YEAR = 1968}

@BOOK{Edmonds:57,
   AUTHOR = "A. R. Edmonds",
   TITLE = "Angular Momentum in Quantum Mechanics",
   PUBLISHER = "Princeton University Press",
   YEAR = 1957}

@BOOK{Khinchin:64,
   AUTHOR = "Aleksandr J. Khinchin",
   TITLE = "Continued Fractions",
   PUBLISHER = "University of Chicago Press",
   YEAR = 1964}

@BOOK{Corless:92,
   AUTHOR = "R.M. Corless, G.H. Gonnet, D.E.G. Hare and D.J. Jeffrey",
   TITLE = "On Lambert's W Function",
   PUBLISHER = "Preprint, University of Waterloo",
   YEAR = 1992}



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfaux.red0000644000175000017500000000306611526203062024301 0ustar  giovannigiovannimodule specfaux;  % (Mostly) Auxiliary functions for
                  % Special functions package for REDUCE.

% Author:  Winfried Neun  Feb 1993 ...

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package ('(specfaux
                   sfbdata),
                 '(contrib specfn));

load!-package 'specfn;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfgamma.red0000644000175000017500000000405111526203062024071 0ustar  giovannigiovannimodule sfgamma;   % Gamma function procedures and rules for REDUCE.

% Author: Chris Cannam, Sept/Oct '92.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


remprop('gamma,'simpfn);
remprop('igamma,'simpfn);
remprop('beta,'simpfn);
remprop('polygamma,'simpfn);
remprop('ibeta,'simpfn);
remprop('zeta,'simpfn);
remprop('pochhammer,'simpfn);
remprop('psi,'simpfn);

create!-package ('(sfgamma sfgamm sfpsi sfigamma),'(contrib specfn));

fluid '(bernoulli!-alist new!*bfs bf!*base sf!-alist !*savefs);

bf!*base := (if new!*bfs then 2 else 10) ;

symbolic smacro procedure sq2bf!*(x);
   (if fixp x then i2bf!: x
      else ((if car y neq '!:rd!: then retag cdr !*rn2rd y
               else retag cdr y) where y = !*a2f x));

symbolic smacro procedure c!:prec!:;
   (if new!*bfs then lispeval '!:bprec!: else !:prec!:);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.hlp0000644000175000017500000002110011526203062023737 0ustar  giovannigiovanni\chapter{SPECFN: Package for special functions}
\label{SPECFN}
\typeout{{SPECFN: Package for special functions}}

{\footnotesize
\begin{center}
Chris Cannam \& Winfried Neun \\
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Heilbronner Strasse 10 \\
D--10711 Berlin--Wilmersdorf, Germany \\[0.05in]
e--mail: neun@sc.ZIB--Berlin.de
\end{center}
}
\ttindex{SPECFN}
\index{Orthogonal polynomials}

This package is designed to provide algebraic and numeric manipulations of
several common special functions, namely:

\begin{itemize}
\item Bernoulli Numbers and Euler Numbers;
\item Stirling Numbers;
\item Binomial Coefficients;
\item Pochhammer notation;
\item The Gamma function;
\item The Psi function and its derivatives;
\item The Riemann Zeta function;
\item The Bessel functions J and Y of the first and second kind;
\item The modified Bessel functions I and K;
\item The Hankel functions H1 and H2;
\item The Kummer hypergeometric functions M and U;
\item The Beta function, and Struve, Lommel and Whittaker functions;
\item The Airy functions;
\item The Exponential Integral, the Sine and Cosine Integrals;
\item The Hyperbolic Sine and Cosine Integrals;
\item The Fresnel Integrals and the Error function;
\item The Dilog function;
\item Hermite Polynomials;
\item Jacobi Polynomials;
\item Legendre Polynomials;
\item Spherical and Solid Harmonics;
\item Laguerre Polynomials;
\item Chebyshev Polynomials;
\item Gegenbauer Polynomials;
\item Euler  Polynomials;
\item Bernoulli Polynomials.
\item Jacobi Elliptic Functions and Integrals;
\item 3j symbols, 6j symbols and Clebsch Gordan coefficients;
\item and some well-known constants.
\end{itemize}



\section{Simplification and Approximation}

All of the operators supported by this package have certain algebraic
simplification rules to handle special cases, poles, derivatives and so
on.  Such rules are applied whenever they are appropriate.  However, if
the {\tt ROUNDED} switch is on, numeric evaluation is also carried out.
Unless otherwise stated below, the result of an application of a special
function operator to real or complex numeric arguments in rounded mode
will be approximated numerically whenever it is possible to do so.  All
approximations are to the current precision.

\section{Constants}
\ttindex{Euler\_Gamma}\ttindex{Khinchin}\ttindex{Golden\_Ratio}
\ttindex{Catalan}

Some well-known constants are defined in the special function package.
Important properties of these constants which can be used to define them
are also known.  Numerical values are computed at arbitrary precision
if the switch ROUNDED is on.

\begin{itemize}
\item Euler\_Gamma : Euler's constants, also available as -$\psi(1)$;
\item Catalan : Catalan's constant;
\item Khinchin : Khinchin's constant;
\item Golden\_Ratio : $\frac{1 + \sqrt{5}}{2}$ 
\end{itemize}

\section{Functions}

The functions provided by this package are given in the following
tables.

%%\index{Spherical and Solid Harmonics}\ttindex{SphericalHarmonicY}
%%\ttindex{SolidHarmonicY}
%%\ttindex{Jacobiamplitude}
%%\ttindex{JacobiZeta}

\begin{center}
\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline 
$\left( { n \atop m } \right)$ & {\tt Binomial(n,m)}\ttindex{Binomial}\index{Binomial coefficients} \\
Bernoulli($n$) or $ B_n $ & {\tt Bernoulli(n)}\ttindex{Bernoulli}\index{Bernoulli numbers} \\
Euler($n$) or $ E_n $ & {\tt Euler(n)}\ttindex{Euler}\index{Euler polynomials}  \\
$S_n^{(m)}$ & {\tt Stirling1(n,m)}\ttindex{Stirling1}\index{Stirling numbers} \\
${\bf S}_n^{(m)}$ & {\tt Stirling2(n,m)}\ttindex{Stirling2} \\
$\Gamma(z)$ & {\tt Gamma(z)}\ttindex{Gamma}\index{Gamma function} \\
$(a)_k$ & {\tt Pochhammer(a,k)}\ttindex{Pochhammer}\index{Pochhammer's symbol} \\
$\psi(z)$ & {\tt Psi(z)}\ttindex{Psi}\index{Psi function}  \\
$\psi^{(n)}(z)$ & {\tt Polygamma(n,z)}\ttindex{Polygamma}\index{Polygamma functions} \\
$Riemann's \zeta(z)$ & {\tt Zeta(z)}\ttindex{Zeta}\index{Zeta function (Riemann's)} \\
$J_\nu(z)$ & {\tt BesselJ(nu,z)}\ttindex{BesselJ}\index{Bessel functions}\\
$Y_\nu(z)$ & {\tt BesselY(nu,z)}\ttindex{BesselY}\\
$I_\nu(z)$ & {\tt BesselI(nu,z)}\ttindex{BesselI}\\
$K_\nu(z)$ & {\tt BesselK(nu,z)}\ttindex{BesselK}\\
$H^{(1)}_\nu(z)$ & {\tt Hankel1(nu,z)}\ttindex{Hankel1}\index{Hankel functions}\\
$H^{(2)}_\nu(z)$ & {\tt Hankel2(nu,z)}\ttindex{Hankel2}\\
$B(z,w)$ & {\tt Beta(z,w)}\ttindex{Beta}\index{Beta function}\\
${\bf H}_{\nu}(z)$ & {\tt StruveH(nu,z)}\ttindex{StruveH}\index{Struve functions}\\
${\bf L}_{\nu}(z)$ & {\tt StruveL(nu,z)}\ttindex{StruveL}\\
$s_{a,b}(z)$ & {\tt Lommel1(a,b,z)}\ttindex{Lommel1}\index{Lommel functions}\\
$S_{a,b}(z)$ & {\tt Lommel2(a,b,z)}\ttindex{Lommel2}\\
\end{tabular}}
\end{center}


\begin{center}
\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline
$Ai(z)$ & {\tt Airy\_Ai(z)}\ttindex{Airy\_Ai}\index{Airy functions}\\
$Bi(z)$ & {\tt Airy\_Bi(z)}\ttindex{Airy\_Bi}\\
$Ai'(z)$ & {\tt Airy\_Aiprime(z)}\ttindex{Airy\_Aiprime}\\
$Bi'(z)$ & {\tt Airy\_Biprime(z)}\ttindex{Airy\_Biprime}\\
$M(a, b, z)$ or $_1F_1(a, b; z)$ or $\Phi(a, b; z)$ &
{\tt KummerM(a,b,z)}\ttindex{KummerM}\index{Kummer functions} \\
$U(a, b, z)$ or $z^{-a}{_2F_0(a, b; z)}$ or $\Psi(a, b; z)$ &
{\tt KummerU(a,b,z)}\ttindex{KummerU}\\
$M_{\kappa,\mu}(z)$ & {\tt WhittakerM(kappa,mu,z)}\ttindex{WhittakerM}\index{Whittaker functions}\\
$W_{\kappa,\mu}(z)$ & {\tt WhittakerW(kappa,mu,z)}\ttindex{WhittakerW}\\
$B_n(x)$ & {\tt BernoulliP(n,x)}\ttindex{BernoulliP}\\
$E_n(x)$ & {\tt EulerP(n,x)}\ttindex{EulerP}\\
$C_n^{(\alpha)}(x)$ & {\tt GegenbauerP(n,alpha,x)}\ttindex{GegenbauerP}\index{Gegenbauer polynomials}\\
$H_n(x)$ & {\tt HermiteP(n,x)}\ttindex{HermiteP}\index{Hermite polynomials} \\
$L_n(x)$ & {\tt LaguerreP(n,x)}\ttindex{LaguerreP}\index{Laguerre polynomials}\\
$L_n^{(m)}(x)$ & {\tt LaguerreP(n,m,x)}\ttindex{LaguerreP}\\
$P_n(x)$ & {\tt LegendreP(n,x)}\ttindex{LegendreP}\index{Legendre polynomials}\\
$P_n^{(m)}(x)$ & {\tt LegendreP(n,m,x)}\ttindex{LegendreP}\\
$P_n^{(\alpha,\beta)} (x)$ & {\tt JacobiP(n,alpha,beta,x)}\ttindex{JacobiP}\index{Jacobi's polynomials} \\
$U_n(x)$ & {\tt ChebyshevU(n,x)}\ttindex{ChebyshevU}\index{Chebyshev polynomials} \\
$T_n(x)$ & {\tt ChebyshevT(n,x)}\ttindex{ChebyshevT}\\
\end{tabular}}
\end{center}


\begin{center}
\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline
$Y_n^{m}(x,y,z,r2)$ & {\tt SolidHarmonicY(n,m,x,y,z,r2)}\ttindex{SolidHarmonicY}\\
$Y_n^{m}(\theta,\phi)$ & {\tt SphericalHarmonicY(n,m,theta,phi)}\ttindex{SphericalHarmonicY}\\
$\left( {j_1 \atop m_1} {j_2 \atop m_2}
 {j_3 \atop m_3} \right)$ & {\tt ThreeJSymbol(\{j1,m1\},\{j2,m2\},\{j3,m3\})}\ttindex{ThreeJSymbol}\index{3j and 6j symbols}\\
$\left( {j_1m_1j_2m_2 | j_1j_2j_3 - m_3} \right)$ &
{\tt Clebsch\_Gordan(\{j1,m1\},\{j2,m2\},\{j3,m3\})}\ttindex{Clebsch\_Gordan}\index{Clebsch Gordan coefficients}\\
$\left\{ {j_1 \atop l_1} {j_2 \atop l_2}
 {j_3 \atop l_3} \right\}$  & {\tt SixJSymbol(\{j1,j2,j3\},\{l1,l2,l3\})}\ttindex{SixJSymbol}\\
\end{tabular}}
\end{center}


\begin{center}
\fbox{
\begin{tabular}{r l}\\
Function & Operator \\\\
%\hline
$Si(z)$ & {\tt Si(z) }\ttindex{Si}\\
$si(z)$ & {\tt s\_i(z) }\ttindex{s\_i}\\
$Ci(z)$ & {\tt Ci(z) }\ttindex{Ci}\\
$Shi(z)$ & {\tt Shi(z) }\ttindex{Shi}\\
$Chi(z)$ & {\tt Chi(z) }\ttindex{Chi}\\
$erf(z)$ & {\tt erf(z) }\ttindex{erf}\\
$erfc(z)$ & {\tt erfc(z) }\ttindex{erfc}\\
$Ei(z)$ & {\tt Ei(z) }\ttindex{Ei}\\
$dilog(z)$ & {\tt dilog(z)}\ttindex{dilog}\index{Dilogarithm function} \\
$C(x)$ & {\tt Fresnel\_C(x)}\ttindex{Fresnel\_C} \\
$S(x)$ & {\tt Fresnel\_S(x)}\ttindex{Fresnel\_S} \\
\\
$sn(u|m)$ & {\tt Jacobisn(u,m)}\ttindex{Jacobisn}\index{Jacobi Elliptic Functions and {Integrals}}\\
$dn(u|m)$ & {\tt Jacobidn(u,m)}\ttindex{Jacobidn}\\
$cn(u|m)$ & {\tt Jacobicn(u,m)}\ttindex{Jacobicn}\\
$cd(u|m)$ & {\tt Jacobicd(u,m)}\ttindex{Jacobicd}\\
$sd(u|m)$ & {\tt Jacobisd(u,m)}\ttindex{Jacobisd}\\
$nd(u|m)$ & {\tt Jacobind(u,m)}\ttindex{Jacobind}\\
$dc(u|m)$ & {\tt Jacobidc(u,m)}\ttindex{Jacobidc}\\
$nc(u|m)$ & {\tt Jacobinc(u,m)}\ttindex{Jacobinc}\\
$sc(u|m)$ & {\tt Jacobisc(u,m)}\ttindex{Jacobisc}\\
$ns(u|m)$ & {\tt Jacobins(u,m)}\ttindex{Jacobins}\\
$ds(u|m)$ & {\tt Jacobids(u,m)}\ttindex{Jacobids}\\
$cs(u|m)$ & {\tt Jacobics(u,m)}\ttindex{Jacobics}\\
$F(\phi|m)$ & {\tt EllipticF(phi,m)}\ttindex{EllipticF}\\
$K(m)$ & {\tt EllipticK(m)}\ttindex{EllipticK}\\
$E(\phi|m) or E(m)$ & {\tt EllipticE(phi,m) or EllipticE(m)}\ttindex{EllipticE}\\
$H(u|m), H_1(u|m), \Theta_1(u|m), \Theta(u|m)$ & {\tt EllipticTheta(a,u,m)}\ttindex{EllipticTheta}\\
$\theta_1(u|m), \theta_2(u|m), \theta_3(u|m), \theta_4(u|m)$
   & {\tt EllipticTheta(a,u,m)}\ttindex{EllipticTheta}\\
$Z(u|m)$ & {\tt Zeta\_function(u,m)}\ttindex{Zeta\_function}
\end{tabular}}
\end{center}

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/simplede.red0000644000175000017500000005137611526203062024274 0ustar  giovannigiovannimodule simplede;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*precise fps_search_depth !*protfg ps!:order!-limit);

global '(inconsistent!*);

share fps_search_depth;

fps_search_depth := 5; %the default

switch traceFPS;

algebraic <<  operator BA; operator infsum ;
                array DFF(50) >>;

put('simplede,'psopfn,'simpledeeval);

symbolic procedure simpledeeval(u);
   begin scalar res,usevar;
     if length u = 2 then
        << usevar := 'y;
           res := int_simplede(car u,cadr u);
           if eq(res,-1) then return simpledeexit(car u,cadr u,'y);
        >>
        else if length u = 3 then
                << usevar := caddr u;
                res := int_simplede(car u,cadr u);
                if eq(res,-1) then
                         return simpledeexit(car u,cadr u,usevar);
                >>
                else rederr("Wrong number of Arguments for simplede");
     res := sublis('((oddexpt . expt)(ba . a)(nn . k)),res);
     return if reval usevar = usevar then
                     sublis(list('ff . usevar),res)
                else sublis(list('ff . intern gensym()),res);
        end;

algebraic procedure int_simplede(f,x);

begin scalar cap_a,degree0fde,cap_f,j,cap_J,nnn,s,ind,deq,eqq,reqq,
        ak,terms,list1,list2,Nmax,cap_m,cap_R,ii,m,leadcoeff,m0,
        len,cap_S,result,parameters,solved,!*allfac,!*protfg;

        !*protfg := t;
        Nmax :=fps_search_depth;
        clear a;
        operator A; off allfac;
        depend ff,x;

        DFF(0) := f;

% start search for a simple DE

        for degreeofDE:=1:Nmax do
            <<  DFF(degreeofDE) := df(DFF(degreeofDE-1),x);
                eqq :=  DFF(degreeofDE) +
                       for j:=0:(degreeofDE-1) sum A(j) * DFF(j);
                eqq := RecursionSimplify(eqq);
                eqq := num eqq;
                terms := {};
                list1 := converttolist (eqq,degreeofDE+1);
                while list1 neq {} do
                     << list2 := {}; j := fastpart(list1 ,1);
                        cap_j := j; len := fastlength list1;
                        for i:=2:len do
                           if type_ratpoly(j/fastpart(list1,i),x) then
                                cap_J := cap_J + fastpart(list1,i)
                           else list2 := fastpart(list1,i) . list2;
                        terms := cap_J . terms;
                        list1 := reverse list2;
                     >>;

                ind := for j:=0:degreeofDE-1 collect a(j);

                s := savesolve(terms,ind);
                if s = {} then NIL else
                << if symbolic !*traceFPS then write "Solution: ",s;
                        result := degreeofDE; Nmax := 0 >>;
            >>;

        degreeofDE := result;

        if Nmax = 0 then << if symbolic !*traceFPS then
                         write " successful search for DE">>
          else return -1;

        for each ss in first s do << ss := sub(a(degreeofDE)=1,ss);
                                        setze(lhs ss,rhs ss)>>;

% setting up the Differential equation

        on factor;
        deq := df(ff,x,degreeofDE) +
                 for j:=0:(degreeofDE-1) sum a(j)*df(ff,x,j);
        off factor;
        deq := num deq;
        return deq;
end;

put('FPS,'psopfn,'fpseval);

symbolic procedure FPSeval(u);
   begin scalar gens,res,!*factor,!*precise;
     if length u = 2 then
        << res := PSalg(car u,cadr u);
           if eq(res,-1) then return FPSexit(car u,cadr u,0);
        return sublis('((oddexpt . expt)(ba . a) (nn . k)),res)
        >>
        else if length u = 3 then
               << gens := gensym();
               res := PSalg(sublis(list( cadr u . gens),car u),gens);
               if eq(res,-1) then return FPSexit(car u,cadr u,caddr u);
               res := sublis('((oddexpt . expt)(ba . a) (nn . k)),res);
               res := subf(caadr res, list list(gens,'plus,cadr u,
                         list('minus,caddr u)));
               return mk!*sq res;
               >>
                else rederr("Wrong number of Arguments for FPS");
        end;

algebraic procedure AsymptPowerSeries (f,x);
  sub(x=1/x,fps(sub(x=1/x,f),x));

symbolic procedure FPSexit(a,b,z);
 << erfg!* := nil; list ('FPS,a,b, z) >>$

symbolic procedure simpledeexit(a,b,z);
 << erfg!* := nil; list ('simplede,a,b, z) >>$

algebraic procedure PSalg(f,x);

begin scalar cap_a,degree0fde,cap_f,j,cap_J,nnn,s,ind,deq,eqq,reqq,
        ak,terms,list1,list2,Nmax,cap_m,cap_R,ii,m,leadcoeff,m0,
        len,cap_S,result,parameters,solved,!*allfac,!*protfg;

        f := Recursionsimplify f;
        !*protfg := t;
        Nmax :=fps_search_depth;
        clear a;
        operator A; off allfac;
        depend ff,x;

        DFF(0) := f;

% special cases

        if PolynomQ(f,x) then return f;
        if type_ratpoly(f,x) then return ratalgo(f,x);

% start search for a simple DE

        clearrules special!*pochhammer!*rules;
        clearrules spec_factorial;
        clearrules spec_pochhammer;

        for degreeofDE:=1:Nmax do
            <<  DFF(degreeofDE) := df(DFF(degreeofDE-1),x);
                eqq :=  DFF(degreeofDE) +
                       for j:=0:(degreeofDE-1) sum A(j) * DFF(j);
                eqq := RecursionSimplify(eqq);
                eqq := num eqq;
                terms := {};
                list1 := converttolist (eqq,degreeofDE+1);
                while list1 neq {} do
                     << list2 := {}; j := fastpart(list1,1); cap_j := j;
                        len := fastlength list1;
                        for i:=2:len do
                                if type_ratpoly(j/fastpart(list1,i),x)
                                  then cap_J:= cap_J + fastpart(list1,i)
                                else list2 := fastpart(list1,i) . list2;
                        terms := cap_J . terms;
                        list1 := reverse list2;
                     >>;

                ind := for j:=0:degreeofDE-1 collect a(j);

                s := savesolve(terms,ind);
                if s = {} then NIL else
                << if symbolic !*traceFPS then write "Solution: ",s;
                        result := degreeofDE; Nmax := 0 >>;
            >>;

        degreeofDE := result;

        if Nmax = 0 then << if symbolic !*traceFPS then
                         write " successful search for DE">>
          else return -1;

        for each ss in first s do << ss := sub(a(degreeofDE)=1,ss);
                                        setze(lhs ss,rhs ss)>>;

% setting up the Differential equation

        on factor;
        deq := df(ff,x,degreeofDE) +
                 for j:=0:(degreeofDE-1) sum a(j)*df(ff,x,j);
        off factor;
        deq := num deq;
        if symbolic !*traceFPS
          then write("Differential equation is: ", deq);

% transforming into Recurrence equation

        factor ba;
        let subst_rules;
        req := pssubst(deq,x,ba,nn);
        clearrules subst_rules;

        if symbolic !*traceFPS
          then write("Recurrence equation is :",req);

        ind := {};
        for ii:=-50 : 50 do
           if not(coeffn(req,ba(nn+ii),1) =0) then ind := ii . ind;
        cap_M := first ind;
        if symbolic !*traceFPS then
          write(" M, ind, parameters : ",cap_M,",",ind,",", parameters);

        leadcoeff := num coeffn(req,ba(nn+cap_M),1);
        nnn := fastlength ind;

        let special!*pochhammer!*rules;
        let spec_factorial;
        let spec_pochhammer;

        result := 0;

        if (nnn = 1) then <<
                % functions with finite representation
                if symbolic !*traceFPS then
                  write
                     "fps with finite number of non-zero coefficients";
                cap_R := sub(nn=nn+(1-cap_M),- reduct(req,ba(nn+cap_M)))
                        /(sub(nn=nn+(1-cap_M),lcof(req,ba(nn+cap_M)))
                         * Ba(nn));
                leadcoeff:= sub(nn=nn+(1-cap_M),leadcoeff);
                result := constantRE(cap_R,leadcoeff,0,nn,x);
                if result = failed then result :=0;
                >>;

% try hypergeometric case

        if (nnn = 2) then <<
                m := abs(first ind  - second ind);
                cap_R := sub(nn=nn+(m-cap_M),- reduct(req,ba(nn+cap_M)))
                        /(sub(nn=nn+(m-cap_M),lcof(req,ba(nn+cap_M)))
                          * Ba(nn));
                leadcoeff:= sub(nn=nn+(m-cap_M),leadcoeff);
                result := hypergeomRE(m,cap_R,leadcoeff,0,nn,x)
                >>;

        if result =0 then
        <<
% test for constant coefficients

        terms := for j:=0:(degreeofDE-1) join
                         if freeof(a(j),x) then {} else {T};
        if terms = {} then <<
                req := ba(k+degreeofDE) +
                         for j:=0:(degreeofDE-1) sum ba(k+j)*a(j);
                if symbolic !*traceFPS  then
                 << write("DE has constant coefficients");
                    write("DE = ",deq);
                    write("RE = ",req);
                >>;
                s := 0;
                iii := 0;
                while freeof(req,ba(k + iii)) do <<
                        s := s + limit(dff(iii),x,0) * x^iii;
                        iii := iii + 1 >>;
                m0 := iii;
        if symbolic !*traceFPS  then write "i was found : ",iii;
        if m0 <= degreeofDE-1 then
        << s := solve_lin_rec(req,for i:=m0:(degreeofDE-1) collect
                                ba(i) = limit(dff(i),x,0));
           if symbolic !*traceFPS  then write("solution : ",s);
           s:=sub(n=nn,s);
           result := infsum(s/(factorial nn) *  x^nn,nn,0,infinity)
        >> else result := s;
       >>;
      >>;

   if result = 0 or not(freeof(result,failed)) then return (-1);
   lisp (erfg!* := nil);
   result:= result;
   let hgspec_pochhammer;
   result:= result;
   clearrules  hgspec_pochhammer;
   result := verbessere (result,nil);
   return result;
end;

flag ('(verbessere), 'opfn);

symbolic procedure verbessere (x,uu);
<< if eqcar (x,'plus) then 'plus .
               foreach xx in cdr x collect verbessere(xx , nil)
  else if not (eqcar (x,'infsum)) then x
  else
  <<
   if eqcar (x,'infsum) and eqcar(cadr x,'QUOTIENT) then
     x := list('infsum ,list('QUOTIENT,
                simplify_expt cadr cadr x,simplify_expt caddr cadr x));
       uu := cadr x;
   if eqcar (x,'infsum) and eqcar(cadr x,'QUOTIENT) then
      << uu := int_simplify_factorial auxcopy cadr x >>;
   list('infsum  , uu,'nn,0,'infinity)>> >>;

symbolic procedure  zerlege u;
 if fixp u and u>0 and  (u<10000 or !*ifactor)
     then <<
        u := zfactor u;
        for each j in u join for jj :=1:cdr j collect (car j) >>
     else list(u);

symbolic procedure simplify_expt u;
  begin scalar uu,exptlist,nonexptlist,asso,numb,expo;
  uu := u;
  if eqcar(u,'times) then u := cdr u;
  while u do
      << if pairp car u and (eq (caar u,'expt)  or eq (caar u,'sqrt))
                then <<
                if numberp cadar u then numb := zerlege (cadar u)
                                else numb := list cadar u;
                expo := if eq (caar u,'sqrt) then '((quotient 1 2))
                                else cddar u;
                while numb do <<
                        if asso:= atsoc (car numb,exptlist) then
                         exptlist := (car numb .
                                list list('plus,car expo,cadr asso)) .
                                        delasc (car numb,exptlist)
                        else
                        exptlist := ((car numb) . expo) . exptlist ;
                        numb := cdr numb;
                             >>;
                     >>
         else if and(idp car u,asso := atsoc (car u,exptlist)) then
                << exptlist := (car u .
                                list list('plus,1,cadr asso)) .
                                        delasc (car u,exptlist) >>
         else nonexptlist := (car u) . nonexptlist;
        u := cdr u;
       >>;
  if null exptlist then return uu;

  for each x in exptlist do
         nonexptlist :=  ('oddexpt . x ) . nonexptlist;
  return (car uu) . nonexptlist;
  end;

fluid ('(rsolve!*!*));

algebraic procedure hypergeomRE(m,cap_R,leadcoeff,dffpointer,k,x);

% solve the hypergeometric Recurrence Equation
%
%   a(k+m) = cap_R(k) * a(k)
%
%  where leadcoeff is the leading coefficient of the RE
%  and DF is a table where DF(dffpointer+i) = df(f,x,i)

  begin scalar denr,fract,ii,m0,m1,c0,ck,S,c,df2,q,r2,lterm,nn,
        s0, leadcoeff2;
        denr := solve(leadcoeff,k);
        m0 := {};
        foreach xx in denr do
                if type_rational rhs xx then  m0 := ((rhs xx)+1) . m0;
        if not(m0 = {}) then m0 := max(m0) else m0 := 0;

        if symbolic !*traceFPS then
                 << write "RE is of hypergeometric type";
                    write "Symmetry number mm := ",m;
                    write "RE: for all k >= ",m0,": a (k + ",m,") = "
                        ,cap_R * a(k);
                    write "leadcoeff := ",leadcoeff; >>;

        fract := {};
        foreach xx in denr do
                if type_fraction(rhs xx)
                  then fract := den(rhs xx) . fract;
        if not(fract = {}) then
                << q := first fract;
                   dff(dffpointer + 10) := sub(x=x^q,dff(dffpointer));
                   if symbolic !*traceFPS then <<
                        write "RE modified to nn= ",k/q;
                        write "=> f := ",dff(dffpointer + 10)>>;
                   S := hypergeomRE(q*m,sub(k=k/q,cap_R),
                        sub(k=k/q,leadcoeff),dffpointer + 10,k,x);
                   return sub(x=x^(1/q),S); >>;

        if m0 < 0  then <<
                nn:= -m0 + remainder(-m0,m);
                dff(dffpointer + 10) := df2 := x^nn * dff(dffpointer);
                if symbolic !*traceFPS then <<
                        write "working with ",x^nn,"*f";
                        write "=> f :=" ,df2 >>;
                S := hypergeomRE(m,sub(k=k-nn,cap_R),
                                   sub(k=k-nn,leadcoeff),
                                   dffpointer + 10,k,x);
                return update_coeff(S,x,-nn) >>;

        if m0 > 0  then <<
         m1 := {};
         foreach xx in denr do if type_rational rhs xx then
                         m1 := append(list (rhs xx +1),m1);
         m1 := min m1;
         if m1 > 0 then <<
                dff(dffpointer + 10) := df2 := x^(-m1)*dff(dffpointer);
                if symbolic !*traceFPS then <<
                        write"a(k) = 0 for k < ",m1;
                        write "working with ",x^(-m1),"*f";
                        write "=> f :=" ,df2 >>;
                S := hypergeomRE(m,sub(k=k+m1,cap_R),
                                   sub(k=k+m1,leadcoeff),
                                        dffpointer + 10,k,x);
                return update_coeff(S,x,m1);
                        >> >>;

     % logarithmic singularity Baustelle
        If lisp pairp
                 errorset!*(list ('simptaylor,mkquote list(
                                        mkquote list('dff,dffpointer),
                                        mkquote x,0,1)),nil) then
        <<
        lterm := num taylortostandard(taylor(dff(dffpointer),x,0,1));
        nn := 0;
        if lisp(if  member('(log x) ,kernels !*q2f simp lterm)
                         then t else nil) % Comments?
                then <<
                        dff(dffpointer + 10):=dff(dffpointer) -lterm;
                        if symbolic !*traceFPS then
                                write "=> f :=",dff(dffpointer + 10);
                        S := hypergeomRE(m, R, leadcoeff*(k-nn),
                                dffpointer + 10,k,x);
                        RETURN(lterm+S);
                     >>;
        >>;

        S := 0; S0 := 0;
        for i:=0:(m0+m-1) do <<
           if i > 0 then
             dff(dffpointer + i) := df(dff(dffpointer + i-1),x);
           c0 := limit(dff(dffpointer + i),x,0);

           if (lisp listp reval c0 and fastpart(c0,0) = limit) then
                <<  if symbolic !*traceFPS
                        then write "Could not find the limit of: "
                        ,dff(dffpointer + i),",",x,",",0;
                    rederr("Problem using limit operator") >> else
                <<
                c0 := c0/factorial (i);
                if symbolic !*traceFPS then write " a(",i,") = ",c0;
                if not (c0 =0) then
                     << s0 := s0+c0*x^i;
                        if i < m0 then S := S + c0 * x^i % single terms
                        else
                     << ck := hypergeomRsolve(sub(k=M*k+i,cap_R),k,c0);
                        if symbolic !*traceFPS then write " ck = ",ck;
                        c :=1;
                        ck := ck/C;
                        let hgspec_pochhammer;
                        ck := ck;
                        clearrules hgspec_pochhammer;
                        if ck = 0 then S := S + c0*x^i else
                         if Rsolve!*!* = finite then S := S +
                                C*sum(ck*x^(m*k+i), k)
                         else
                         S := S + C * infsum(ck*x^(m*k+i)) ;
                        if symbolic !*traceFPS then write " S = ",s;
                >> >> >> >>;
  return (S);
end;

algebraic << let INFSUM(0) = 0>>;

% some compatibility functions for Maple sources.

symbolic flag('(savesolve type_fraction type_rational),'opfn);

algebraic procedure converttolist (express,len);
 <<
  len := fastlength express;
  for i:=1:len collect fastpart(express , i)>>;

symbolic procedure type_fraction (num);
  (if pairp num1 and fixp car num1 and fixp cdr num1
        and not onep cdr num1
   then num else nil) where num1 := simp num;

symbolic procedure type_rational(num);
 (if pairp num1 and (fixp car num1 or null car num1) and fixp cdr num1
   then t else nil) where num1 := simp num;

algebraic procedure type_ratpoly(exprn,var);
  if (PolynomQ (den exprn,var) and PolynomQ (num exprn,var))
    then t else nil;

symbolic procedure savesolve (x,y);

begin scalar !*cramer;
on cramer; % this is a temporary fix for solve !!
           % check with  fps(sin(x)^2 * cos(x)^2,x); !!
return
<< switch solveinconsistent;
   on solveinconsistent;
   inconsistent!* := NIL;
   if pairp (x := errorset!*(list ('solveeval,mkquote list(x,y)),nil))
        and not inconsistent!*
        then << x :=car x;
                if x = '(list) then x else
                if eqcar(cadr x,'equal) then % one element solution
                        list('list,x) else x>>
        else list('list) >>;
end;

algebraic procedure setze(x,y);
  let x = y;

symbolic procedure PolynomQ (x,var);

 if not fixp denr simp x then NIL else
 begin scalar kerns,kern;

 kerns := kernels !*q2f simp x;

 aa: if null kerns then return T;
     kern := first kerns;
     kerns := cdr kerns;
     if not(eq (kern, var)) and depends(kern,var)
                then return NIL else go aa;
end;

flag('(PolynomQ),'opfn);

flag ('(PolynomQ type_ratpoly),'boolean);


algebraic << operator update_coeff;

update_coeff_rules := {

 update_coeff (~a + ~b,~x,~m) => update_coeff(a,~x,~m)
                                + update_coeff(b,~x,~m),
 update_coeff (~c * ~a,~x,~m) => c * update_coeff(a,~x,~m)
        when freeof(c,x),
 update_coeff ( -  ~a,~x,~m) =>  - update_coeff(a,~x,~m),
 update_coeff (~a/~c,~x,~m) => update_coeff(a,~x,~m) /c
        when freeof(c,x) and c neq 1,
 update_coeff (~x,~x,~m) => x^(m + 1),
 update_coeff (~c,~x,~m) => c * x^m  when freeof(c,x),
 update_coeff (infsum(~xx),~x,~m) => infsum update_coeff(xx,x,m),
 update_coeff (~x^~j*~xx,~x,~m) => x^(j + m + 1)when x = xx,
 update_coeff (~x^~j*~xx^~jj,~x,~m) => x^(j + jj + m) when x = xx,
 update_coeff (~x^~j,~x,~m) => x^(j + m)}$

let update_coeff_rules >>$

endmodule;

end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfsums.red0000644000175000017500000000625411526203062024005 0ustar  giovannigiovannimodule sfsums;   % Calculation of infinite sums of reciprocal
                 % Powers, see e.g. Abramowitz/Stegun ch 23.
%
% Author: Winfried Neun, Sep 1993

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic <<

 let{
  sum((-1)^~k /(2*(~k)-1)^~n,~k,1,infinity) =>
        Pi^n*abs(Euler(n-1))/(factorial(n-1) * 2^(n+1))
        when fixp n and n > 0 and not evenp n,

  sum((-1)^~k /(2*(~k)-1)^2,~k,1,infinity) =>  - Catalan,

  sum((-1)^~k /(2*(~k)+1)^2,~k,0,infinity) =>  Catalan,

  sum(1/(2*(~k)-1)^~n,~k,1,infinity) => Zeta(n) *(1-2^(-n))
        when fixp n and n > 0 and evenp n,

  sum(1/~k^~s,~k,1,infinity) =>  Zeta(s),

  sum((-1)^~k/~k^~n,~k,1,infinity) =>  Zeta(n)* (1-2^(1-n))
        when fixp n and n > 0 and evenp n

} ;

% from  Abigail Leeves    Sep 15, 97

let {

prod((1+(1/~n**2)),~n,~r,infinity) =>
(((sinh(pi))/pi)/(prod((1+(1/~n**2)),~n,1,(~r-1))))
when (fixp r and r>=1 and r<15),

prod((1+(1/~n**3)),~n,~r,infinity) =>
(((cosh((sqrt(3)*pi)/2))/pi)/(prod((1+(1/~n**3)),~n,1,(~r-1))))
when (fixp r and r>=1 and r< 15),

prod((1+(1/~n**4)),~n,~r,infinity) =>
(((cosh(sqrt(2)*pi))-(cos(sqrt(2)*pi)))/(2*pi**2))/
        (prod((1+(1/~n**4)),~n,1,(~r-1)))
when (fixp r and r>=1 and r<15),

prod((1+(1/~n**5)),~n,~r,infinity) =>
((((Gamma(exp((2*pi*i)/5)))*(Gamma(exp((6*pi*i)/5))))**-2)/
        (prod((1+(1/~n**5)),~n,1,(~r-1))))
when (fixp r and r>=1 and r<15),

prod((1-(4/~n**2)),~n,~r,infinity) =>
(1/6)/(prod((1-(4/~n**2)),~n,3,(~r-1)))
when (fixp r and r<15 and r>=3),

prod((1-(8/~n**3)),~n,~r,infinity) =>
((sinh(sqrt(3)*pi))/(42*sqrt(3)*pi))/(prod((1-(8/~n**3)),~n,3,(~r-1)))
when (fixp r and r<15 and r>=3),

prod((1-(16/~n**4)),~n,~r,infinity) =>
((sinh(2*pi))/(120*pi))/(prod((1-(16/~n**4)),~n,3,(~r-1)))
when (fixp r and r<15 and r>=3),

prod((1-(32/~n**5)),~n,~r,infinity) =>
((1/1240)*((Gamma(2*exp((pi*i)/5)))*
(Gamma(2*exp((7*pi*i)/5)))**-2))/(prod((1-(32/~n**5)),~n,3,(~r-1)))
when (fixp r and r<15 and r>=3)

};

>>;

endmodule;

end;




mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/simpfact.red0000644000175000017500000004752011526203062024274 0ustar  giovannigiovannimodule simpfact;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%  Simplification for quotients containing factorials

%  Matthew Rebbeck ( while in placement at ZIB) - March 1994.

%  The new 'really' improved version! Simplifies plain factorials as
%  well as those raised to integer powers and 1/2.
%
%  Deals properly with the generalised factorial idea of simplifying
%  non integers, eg: (k+1/2)!/(k-1/2)! -> k+1/2.

algebraic <<
operator simplify_factorial1;
operator simplify_factorial;
operator int_simplify_factorial;

let simplify_factorial(~x) => simplify_factorial1(num x,den x);

let { simplify_factorial1(~x,~z) => int_simplify_factorial(x/z)};

let { simplify_factorial1 (~x + ~y,~z) =>
      simplify_factorial1 (x,z) + simplify_factorial1(y,z)};
>>;

symbolic procedure int_Simplify_factorial (u);
  begin
    scalar minus_num,minus_denom,test_expt;
    if not pairp u or car u neq 'quotient then u
    else
    <<
      %
      %  We firstly produce input of standard form.
      %
      if atom cadr u or atom caddr u then u
       else <<
        %
        %  Remove 'minus if there.
        %
        if car cadr u eq 'minus then
         << cadr u := cadr cadr u;
            minus_num := t; >>;
        if car caddr u eq 'minus then
         << caddr u := cadr caddr u;
            minus_denom := t; >>;

        if car cadr u eq 'factorial then cadr u := {'times,cadr u};
        if car caddr u eq 'factorial then caddr u := {'times,caddr u};
        if car cadr u eq 'oddexpt or car cadr u eq 'expt
        or car cadr u eq 'sqrt
         then cadr u := {'times,cadr u};
        if car caddr u eq 'oddexpt or car caddr u eq 'expt or
        car caddr u eq 'sqrt
         then caddr u := {'times,caddr u};
        %
        %  Test to see if input contains any 'expt's. If it does
        %  then they are converted to 'oddexpts and re converted
        %  at the end. If not (ie: either contains 'oddexpt's or
        %  no powers at all), then no conversion is done and the
        %  output is left in this oddexpt form.
        %
        if test_for_expt(cadr u) or test_for_expt(caddr u) then
        << test_expt := t;
           convert_to_oddexpt(cadr u);
           convert_to_oddexpt(caddr u); >>;

        if test_for_facts(cadr u,caddr u)
         then gothru_numerator(cadr u,caddr u);

        if minus_num then cadr u := {'minus,cadr u};
        if minus_denom then caddr u := {'minus,caddr u};

        cadr u := reval cadr u;
        caddr u := reval caddr u; >>;
        %
        %  Output converted back to 'expt form regardless of the form
        %  of the input. For this conversion to occur only if input
        %  is in 'expt form (perhaps useful with Wolfram's input)
        %  then uncomment next line...
        %if test_expt then
        u := algebraic sub(oddexpt=expt,u);
      >>;
      return u;
  end;

flag('(int_Simplify_factorial),'opfn);



symbolic procedure test_for_expt(input);
  %
  % Tests to see if 'expt occurs anywhere.
  %
  begin
    scalar found_expt,not_found;
    not_found := t;
    while input and not_found do
    <<
      if pairp car input and (caar input = 'expt or caar input = 'sqrt)
       then <>;
      input := cdr input;
    >>;
    return found_expt;
  end;

flag('(test_for_expt),'boolean);



symbolic procedure convert_to_oddexpt(input);
  %
  % Converts all expt's to standard form. ie: oddexpt(......,power).
  %
  begin
    while input do
    <<
      if pairp car input and caar input = 'expt
       then caar input := 'oddexpt;
      if pairp car input and caar input = 'sqrt then
      <<
        caar input := 'oddexpt;
        cdar input := {cadar input,{'quotient,1,2}};
      >>;
      input := cdr input;
    >>;
   end;



symbolic procedure gothru_numerator(num,denom);
  %
  % Go systematically through numerator, searching for factorials, and,
  % when  found,  comparing  with  denominator.  'change'  describes if
  % simplifications have been made or not (ie:change eq 0).
  %
  begin
    scalar change,orignum,origdenom;
    change := 0;
    orignum := num;
    origdenom := denom;
    %
    % while in numerator.
    %
    while num do
    <<
      if pairp car num and caar num eq 'oddexpt then
      <<
        if pairp cadar num and caadar num eq 'factorial then
        change := change + gothru_denominator(num,denom);
      >>
      else if pairp car num and caar num eq 'factorial then
      <<
        change := change + gothru_denominator(num,denom);
      >>;
      num := cdr num;
    >>;
    %
    %  If at end of numerator but simplifications have been made,
    %  then repeat.
    %
    if not num and not eqn(change,0) then
    <<
      if test_for_facts(orignum,origdenom)
       then gothru_numerator(orignum,origdenom);  %  Beginning.
    >>;
  end;



symbolic procedure gothru_denominator(num,denom);
  %
  % Systematically  goes  through  denominator  finding  factorials and
  % passing numerator and denom. factorials  into  oddexpt_test.  There
  % they  are  simplified  if  possible.  'Compared'  describes  if the
  % factorials were  simplified (ie: car test eq ok) or if  it was  not
  % possible.
  %
  begin
    scalar test,change;
    change := 0;

    while denom and change = 0 do
    <<
      if pairp car denom and caar denom eq 'oddexpt then
      <<
        if pairp cadar denom and caadar denom eq 'factorial then
        <<
          test := oddexpt_test(num,denom,change);
          change := change + test;
        >>;
      >>
      else if pairp car denom and caar denom eq 'factorial then
      <<
        test := oddexpt_test(num,denom,change);
        change := change + test;
      >>;
      denom := cdr denom;
    >>;
    return change;
  end;



symbolic procedure oddexpt_test(num,denom,change);
  %
  % Tests  which parts of quotient, (if any), are exponentials, passing
  % the quotient onto the relevant simplifying function.
  %
  begin
    scalar test;

    if caar num eq 'oddexpt and caar denom neq 'oddexpt then
    << test := compare_numoddexptfactorial(num,denom,change); >>
    else if caar num neq 'oddexpt and caar denom eq 'oddexpt then
    << test := compare_denomoddexptfactorial(num,denom,change); >>
    else if caar num eq 'oddexpt and caar denom eq 'oddexpt then
    << test := compare_bothoddexptfactorial(num,denom,change); >>
    else test := compare_factorial(num,denom,change);

    return test;
  end;



symbolic procedure compare_factorial (num,denom,change);
  %
  % Compares factorials, simplifying if possible.
  %
  begin
    scalar numsimp,denomsimp,diff;

    %  If both factorial arguments are of the same form.
    if numberp (reval list('difference,cadar (num),cadar(denom))) then
    <<
      change := change + 1;
      %  Difference between num. and denom. factorial arguments.
      diff :=(reval list('difference,cadar (num),cadar(denom)));
      %  If argument of num. factorial > argument of denom. factorial.
      if diff >0 then
      <<
        %  numsimp collects simplified numerator arguments.
        numsimp := for i := 1:diff collect reval {'plus,cadar denom,i};
        %  Remove num. factorial and replace with simplification.
        car num := 'times.numsimp;
        %  Remove denom. factorial.
        car denom := 1;
      >>
      else %  if diff <= 0 then
      <<
        diff := -diff;
        denomsimp := for i := 1:diff collect reval {'plus,cadar num,i};
        car denom := 'times.denomsimp;
        car num := 1;
      >>;
    >>;
    return change;
  end;



symbolic procedure compare_numoddexptfactorial (num,denom,change);
  %
  % Compares  factorials with oddexpt num., simplifying if possible.See
  % compare_factorial for more detailed comments.
  %
  begin
    scalar diff;

    if numberp (reval list('difference,car cdadar num,cadar denom))
    then
    <<
      %  New sqrt additions...
      if sqrt_test(num) then
      <<
        <<
          diff :=(reval list('difference, car cdadar num,cadar denom));
          change := change+1;
          if diff > 0 then simplify_sqrt1(num,denom,diff)
           else simplify_sqrt2(num,denom,diff);
        >>;
      >>
      %  If power is not integer or 1/2 then can't simplify.
      else if not_int_or_sqrt(num) then <<>>
      %  If oddexpt. of power 2.
      else if  eqn(caddar num-1,1) then
      <<
        %  Remove oddexpt.
        car num := car {cadar num};
        diff := (reval list('difference,cadar num,cadar denom));
        change :=  change +1;
        if diff > 0 then << simplify1(num,denom,diff); >>
        else simplify2(num,denom,diff);
      >>
      else
      <<
        %  Reduce oddexpt by one.
        car num := {caar num,cadar num,car cddar num -1};
        diff :=(reval list('difference,car cdadar num,cadar denom));
        change :=  change + 1;
        if diff >0 then << simplify1(num,denom,diff); >>
        else simplify2(cdar num,denom,diff);
      >>;
    >>;
    return change;
  end;



symbolic procedure simplify_sqrt1(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,cadar denom,i};
    cadar num := car{'times.numsimp};
    car denom := {'oddexpt,car denom,{'quotient,1,2}};
  end;



symbolic procedure simplify_sqrt2(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,car cdadar num,i};
    car denom := reval {'times,car num,car{'times.denomsimp}};
    car num := 1;
  end;



symbolic procedure simplify1(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,cadar denom,i};
    cdr num := car{'times.numsimp}.cdr num;
    car denom := 1;
  end;



symbolic procedure simplify2(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,cadar num,i};
    cdr denom := car{'times.denomsimp}.cdr denom;
    car denom := 1;
  end;



symbolic procedure compare_denomoddexptfactorial (num,denom,change);
  %
  % Compares factorials with oddexpt denom, simplifying if possible.See
  % compare_factorial and compare_numoddexptfactorial for more detailed
  % comments.
  %
  begin
    scalar change,diff;

    if numberp (reval list('difference, cadar num,car cdadar denom))
    then
    <<
      %  New sqrt additions...
      if sqrt_test(denom) then
      <<
        <<
          diff :=(reval list('difference, cadar num,car cdadar denom));
          change := change+1;
          if diff > 0 then simplify_sqrt3(num,denom,diff)
          else  %  if diff <= 0
          simplify_sqrt4(num,denom,diff);
        >>;
      >>
      else if not_int_or_sqrt(denom) then <<>>
      else if eqn(caddar denom-1,1) then
      <<
        car denom := car {cadar denom};
        diff := (reval list('difference,cadar num,cadar denom));
        change := change +1;
        if diff > 0 then simplify3(num,denom,diff)
        else  %  if diff <= 0 then
        simplify4(num,denom,diff);
      >>
      else
      <<
        car denom := {caar denom,cadar denom,car cddar denom -1};
        diff :=(reval list('difference, cadar num,car cdadar denom));
        change := change + 1;
        if diff >0 then simplify3(num,cdar denom,diff)
        else simplify4(num,denom,diff);
      >>;
    >>;
    return change;
  end;



symbolic procedure sqrt_test(input);
  %
  % tests if the expt power is 1/2. (boolean)
  %
  begin
    if caddar input = '(quotient 1 2) then return t
     else return nil;
  end;

flag('(sqrt_test),'boolean);



symbolic procedure not_int_or_sqrt(input);
  %
  % tests if the expt power is neither int or 1/2. (boolean)
  %
  begin
    if pairp caddar input and car caddar input = 'quotient
    and cdr caddar input neq '(1 2) then return t
     else return nil;
  end;

flag('(not_int_or_sqrt),'boolean);



symbolic procedure simplify_sqrt3(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,car cdadar denom,i};
    car num := reval{'times,car denom,car{'times.numsimp}};
    car denom := 1;
  end;



symbolic procedure simplify_sqrt4(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,cadar num,i};
    if diff = 0 then car denom := 1
     else cadar denom := car{'times.denomsimp};
    car num := {'oddexpt,car num,{'quotient,1,2}};
  end;



symbolic procedure simplify3(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,cadar denom,i};
    cdr num := car{'times.numsimp}.cdr num;
    car num := 1;
  end;



symbolic procedure simplify4(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,cadar num,i};
    cdr denom := car{'times.denomsimp}.cdr denom;
    car num := 1;
  end;



symbolic procedure compare_bothoddexptfactorial (num,denom,change);
  %
  % Compares factorials with both oddexpt num. & denom., simplifying if
  % possible. See previous compare_...... functions  for  more detailed
  % comments.
  %
  begin
    scalar change,diff;

    if numberp(reval list('difference,car cdadar num,car cdadar denom))
    then
    <<
      %  New sqrt additions...
      if sqrt_test(num) and sqrt_test(denom) then
      <<
        <<
          diff :=(reval list('difference, car cdadar num,car cdadar
                  denom));
          change := change+1;
          if diff > 0 then simplify_sqrt5(num,denom,diff)
           else  %  if diff <= 0
           simplify_sqrt6(num,denom,diff);
        >>;
      >>
      else if not_int_or_sqrt(num) or not_int_or_sqrt(denom) then <<>>
      %  If denom is sqrt but num is not.
      else if sqrt_test(denom) then
      <<
        diff := reval list('difference,cadr cadar num,cadr cadar denom);
        if diff > 0 then simplify_sqrt5(num,denom,diff)
         else  %  if diff <= 0 then
         simplify_sqrt6(num,denom,diff);
      >>
      %  If num is sqrt but denom is not.
      else if sqrt_test(num) then
      <<
        diff := reval list('difference,cadr cadar num,cadr cadar denom);
        if diff > 0 then simplify_sqrt7(num,denom,diff)
         else  %  if diff <= 0 then
         simplify_sqrt8(num,denom,diff);
      >>
      else if eqn(caddar num-1,1) and eqn(caddar denom-1,1) then
      <<
        car num := car {cadar num};
        car denom := car {cadar denom};
        diff := (reval list('difference,cadar num,cadar denom));
        change := change +1;
        if diff > 0 then simplify5(num,denom,diff)
         else  %  if diff <= 0 then
         simplify6(num,denom,diff);
      >>
      else if eqn(caddar num-1,1) and not eqn(caddar denom-1,1) then
      <<
        car num := car {cadar num};
        car denom := {caar denom,cadar denom,car cddar denom-1};
        diff := (reval list('difference,cadar num,car cdadar denom));
        change := change +1;
        if diff >0 then simplify5(num,cdar denom,diff)
         else  %  if diff <= 0 then
         simplify6(num,denom,diff);
      >>
      else if caddar num-1 neq 1 and caddar denom-1 eq 1 then
      <<
        car num := {caar num,cadar num,car cddar num-1};
        car denom := car {cadar denom};
        diff := (reval list('difference,car cdadar num,cadar denom));
        change := change +1;
        if diff >0 then simplify5(num,denom,diff)
        else simplify6(cdar num,denom,diff);
      >>
      else if caddar num-1 neq 1 and caddar denom-1 neq 1 then
      <<
        car num := {caar num,cadar num,car cddar num-1};
        car denom := {caar denom,cadar denom,car cddar denom-1};
        diff:=(reval list('difference,car cdadar num,car cdadar denom));
        change := change +1;
        if diff >0 then simplify5(num,cdar denom,diff)
        else simplify6(cdar num,denom,diff);
      >>;
    >>;
    return change;
  end;



symbolic procedure simplify_sqrt5(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,car cdadar denom,i};
    car num := {'times,{'oddexpt,cadar denom,{'plus,caddar num,
               {'minus,{'quotient,1,2}}}},{'oddexpt,car{'times.numsimp},
               caddar num}};
    car denom := 1;
  end;



symbolic procedure simplify_sqrt6(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,car cdadar num,i};
    car denom := {'oddexpt,car{'times.denomsimp},{'quotient,1,2}};
    caddar num := {'plus,caddar num,{'minus,{'quotient,1,2}}};
  end;



symbolic procedure simplify_sqrt7(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,car cdadar denom,i};
    car num := {'oddexpt,car{'times.numsimp},{'quotient,1,2}};
    caddar denom := {'plus,caddar denom,{'minus,{'quotient,1,2}}};
  end;



symbolic procedure simplify_sqrt8(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,car cdadar num,i};
    car denom:= {'times,{'oddexpt, cadar num,{'plus,caddar denom,
             {'minus,{'quotient,1,2}}}},{'oddexpt,car{'times.denomsimp},
              caddar denom}};
    car num := 1;
  end;



symbolic procedure simplify5(num,denom,diff);
  begin
    scalar numsimp;
    numsimp := for i := 1:diff collect reval {'plus,cadar denom,i};
    cdr num := car{'times.numsimp}.cdr num;
  end;



symbolic procedure simplify6(num,denom,diff);
  begin
    scalar denomsimp;
    diff := -diff;
    denomsimp := for i := 1:diff collect reval {'plus,cadar num,i};
    cdr denom := car{'times.denomsimp}.cdr denom;
  end;



symbolic procedure test_for_facts(num,denom);
  %
  % Systematically goes through numerator and then  denom. looking  for
  % factorials.
  % (boolean).
  %
  begin
    scalar test;
    if test_num(num) and test_denom(denom) then test := t;
    return test
  end;

flag('(test_for_facts),'boolean);



symbolic procedure test_num(num);
  %
  % Systematically goes through num., looking for  factorials.
  % (boolean).
  %
  begin
    scalar test;
    test := nil;
    if eqcar (num ,'times) or eqcar (num ,'oddexpt) then
     while num and not test do
     <<
       if pairp car num and caar num eq 'factorial then test := t
        else if pairp car num and caar num eq 'oddexpt
         then if pairp cadar num and caadar num eq 'factorial
          then test := t;
       num := cdr num;
     >>;
    return test;
  end;

flag ('(test_num),'boolean);



symbolic procedure test_denom(denom);
  %
  % Systematically goes through denominator,  looking  for  factorials.
  % (boolean).
  %
  begin
    scalar test;
    test := nil;
    if eqcar (denom ,'times) or eqcar (denom ,'oddexpt) then
    while denom and not test do
    <<
      if pairp car denom and caar denom eq 'factorial then test := t
       else if pairp car denom and caar denom eq 'oddexpt
        then if pairp cadar denom and caadar denom eq 'factorial
         then test := t;
       denom:= cdr denom;
     >>;
    return test;
  end;

flag ('(test_denom),'boolean);

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/sfrules.red0000644000175000017500000000737711526203062024157 0ustar  giovannigiovannimodule sfrules;  % Rules for definite integration.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

operator defint,choose;

put('intgggg,'simpfn,'simpintgggg);

SHARE MELLINCOEF$

defint_rules:=

{ defint(~x**(~a),~f1,~f2,~x) => intgggg(choose(f1,x),choose(f2,x),a,x),
  defint(~x,~f1,~f2,~x) => intgggg(choose(f1,x),choose(f2,x),1,x),
  defint(~x**(~a),~f1,~x) => intgggg(choose(f1,x),0,a,x),
  defint(~x,~f1,~x) => intgggg(choose(f1,x),0,1,x),
  defint(~f1,~f2,~x) => intgggg(choose(f1,x),choose(f2,x),0,x),
  defint(~f1,~x) => intgggg(choose(f1,x),0,0,x)};


let defint_rules;

choose_data :=

{ choose(1/e**(~x),~var) => f1(1,x),
  choose(sin(~x),~var)   => f1(2,x),
  choose(Heaviside (1-(~x)),~var) => f1(3,x),
  choose(Heaviside ((~p-~x)/~p),~var) => f1(3,x/p),
  choose(Heaviside ((~x)-1),~var) => f1(4,x),

  choose(~f,~var)        => unknown };  % fallthrough case

let choose_data;

fluid '(mellin!-transforms!* mellin!-coefficients!*);

symbolic (mellin!-transforms!* :=mkvect(200))$

symbolic putv(mellin!-transforms!*,0,'(1 . 1)); % undefined case
symbolic putv(mellin!-transforms!*,1,'(() (1 0 0 1) () (nil) 1 x));
symbolic putv(mellin!-transforms!*,2,'
    (() (1 0 0 2) () ((quotient 1 2) nil)
    (sqrt pi) (quotient (expt x 2) 4)));

    % the Heavisides

symbolic putv(mellin!-transforms!*,3,'(() (1 0 1 1) (1) (nil) 1 x));
symbolic putv(mellin!-transforms!*,4,'(() (0 1 1 1) (1) (nil) 1 x));



symbolic (mellin!-coefficients!* :=mkvect(200))$

symbolic procedure simpintgggg (u);

   begin scalar ff1,ff2,alpha,var,chosen_num,coef;

        ff1 := prepsq simp car u;
        if (cadr u) = 0 then ff2 := '(0 0 x) else
                ff2 := prepsq simp cadr u;
        if (ff1 = 'UNKNOWN) then return simp 'unknown;
        if (ff2 = 'UNKNOWN) then return simp 'unknown;
        alpha := caddr u;
        var := cadddr u;

        chosen_num := cadr ff1;
        put('f1,'g,getv(mellin!-transforms!*,chosen_num));
        coef := getv(mellin!-coefficients!*,chosen_num);
        if coef then MELLINCOEF:= coef else MELLINCOEF :=1;

        chosen_num := cadr ff2;
        put('f2,'g,getv(mellin!-transforms!*,chosen_num));
        coef := getv(mellin!-coefficients!*,chosen_num);
        if coef then MELLINCOEF:= coef * MELLINCOEF ;

       return
        simp list('intgg,list('f1,caddr ff1), list('f2,caddr ff2),
                  alpha,var);
   end;

 % some rules which let the results look more convenient ...

algebraic <<

 for all z let sinh(z) = (exp (z) - exp(-z))/2;
 for all z let cosh(z) = (exp (z) + exp(-z))/2;
>>;

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/specfn.rlg0000644000175000017500000057772411527635055024010 0ustar  giovannigiovanniFri Feb 18 21:28:00 2011 run on win32
%
%  Testing file for REDUCE Special Functions Package
%
%             Chris Cannam, ZIB Berlin
%             October 1992 -> Feb 1993
%        (only some of the time, of course)
%
%  Corrections and comments to neun@sc.zib-berlin.de
%


on savesfs;

	% just in case it's off for some reason

off bfspace;

	% to provide more similarity between runs
		% with old & new bigfloats

let {sinh (~x) => (exp(x) - exp (-x))/2 };


		% this will improve some results


% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     1. Bernoulli numbers

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;



procedure do!*one!*bern(x);
   write ("Bernoulli ", x, " is ", bernoulli x);


do*one*bern


do!*one!*bern(1);


                 - 1
Bernoulli 1 is ------
                 2

do!*one!*bern(2);


                1
Bernoulli 2 is ---
                6

do!*one!*bern(3);


Bernoulli 3 is 0

do!*one!*bern(13);


Bernoulli 13 is 0

do!*one!*bern(14);


                 7
Bernoulli 14 is ---
                 6

do!*one!*bern(300);


Bernoulli 300 is ( - 186387899520485901199504534184815606618219184663590593751\
                    8715320655775958174360523134990756922303410810482600528769\
                    4796420210012184158790061643029553704608291464348079647177\
                    3719535693514415158342483315425004774743357558499902912677\
                    5186293388721514970183351129809976971603227633930434923843\
                    9848295803115933725653985747628800282891676355700124156069\
                    41367995702212211519561707046505473575241)/866054419230

do!*one!*bern(-2);


Bernoulli -2 is bernoulli(-2)

do!*one!*bern(0);


Bernoulli 0 is 1


for n := 2 step 2 until 100 do do!*one!*bern n;


                1
Bernoulli 2 is ---
                6

                 - 1
Bernoulli 4 is ------
                 30

                1
Bernoulli 6 is ----
                42

                 - 1
Bernoulli 8 is ------
                 30

                 5
Bernoulli 10 is ----
                 66

                  - 691
Bernoulli 12 is --------
                  2730

                 7
Bernoulli 14 is ---
                 6

                  - 3617
Bernoulli 16 is ---------
                   510

                 43867
Bernoulli 18 is -------
                  798

                  - 174611
Bernoulli 20 is -----------
                    330

                 854513
Bernoulli 22 is --------
                  138

                  - 236364091
Bernoulli 24 is --------------
                     2730

                 8553103
Bernoulli 26 is ---------
                    6

                  - 23749461029
Bernoulli 28 is ----------------
                      870

                 8615841276005
Bernoulli 30 is ---------------
                     14322

                  - 7709321041217
Bernoulli 32 is ------------------
                       510

                 2577687858367
Bernoulli 34 is ---------------
                       6

                  - 26315271553053477373
Bernoulli 36 is -------------------------
                         1919190

                 2929993913841559
Bernoulli 38 is ------------------
                        6

                  - 261082718496449122051
Bernoulli 40 is --------------------------
                          13530

                 1520097643918070802691
Bernoulli 42 is ------------------------
                          1806

                  - 27833269579301024235023
Bernoulli 44 is ----------------------------
                            690

                 596451111593912163277961
Bernoulli 46 is --------------------------
                           282

                  - 5609403368997817686249127547
Bernoulli 48 is ---------------------------------
                              46410

                 495057205241079648212477525
Bernoulli 50 is -----------------------------
                             66

                  - 801165718135489957347924991853
Bernoulli 52 is -----------------------------------
                               1590

                 29149963634884862421418123812691
Bernoulli 54 is ----------------------------------
                               798

                  - 2479392929313226753685415739663229
Bernoulli 56 is ---------------------------------------
                                  870

                 84483613348880041862046775994036021
Bernoulli 58 is -------------------------------------
                                 354

                  - 1215233140483755572040304994079820246041491
Bernoulli 60 is ------------------------------------------------
                                    56786730

                 12300585434086858541953039857403386151
Bernoulli 62 is ----------------------------------------
                                   6

                  - 106783830147866529886385444979142647942017
Bernoulli 64 is -----------------------------------------------
                                      510

                 1472600022126335654051619428551932342241899101
Bernoulli 66 is ------------------------------------------------
                                     64722

                  - 78773130858718728141909149208474606244347001
Bernoulli 68 is -------------------------------------------------
                                       30

                 1505381347333367003803076567377857208511438160235
Bernoulli 70 is ---------------------------------------------------
                                       4686

                  - 5827954961669944110438277244641067365282488301844260429
Bernoulli 72 is ------------------------------------------------------------
                                         140100870

                 34152417289221168014330073731472635186688307783087
Bernoulli 74 is ----------------------------------------------------
                                         6

                  - 24655088825935372707687196040585199904365267828865801
Bernoulli 76 is ----------------------------------------------------------
                                            30

                 414846365575400828295179035549542073492199375372400483487
Bernoulli 78 is -----------------------------------------------------------
                                           3318

Bernoulli 80 is ( - 4603784299479457646935574969019046849794257872751288919656\
                 867)/230010

                 1677014149185145836823154509786269900207736027570253414881613
Bernoulli 82 is ---------------------------------------------------------------
                                              498

Bernoulli 84 is ( - 2024576195935290360231131160111731009989917391198090877281\
                 083932477)/3404310

Bernoulli 86 is 660714619417678653573847847426261496277830686653388931761996983/
                6

Bernoulli 88 is ( - 1311426488674017507995511424019311843345750275572028644296\
                 919890574047)/61410

Bernoulli 90 is 11790572790210827998841233512492150837752549496696471162315452\
                15727922535/272118

Bernoulli 92 is ( - 1295585948207537527989427828538576749659341483719435143023\
                 316326829946247)/1410

Bernoulli 94 is 12208138065797444696073016794132012039585084152026966214362151\
                05284649447/6

Bernoulli 96 is ( - 2116004495972665130975977281098242336730439543890602341506\
                 38733420050668349987259)/4501770

Bernoulli 98 is 67908260672905495624051117546403605607342195728504487509073961\
                249992947058239/6

Bernoulli 100 is ( - 945980378191221252952274330694937218727028415330669361333\
                    85696204311395415197247711)/33330


on rounded;


precision 100;


12


do!*one!*bern(1);


Bernoulli 1 is  - 0.5

do!*one!*bern(2);


Bernoulli 2 is 

               0.1666666666666666666666666666666666666666666666666666666666666\
               666666666666666666666666666666666666667

do!*one!*bern(3);


Bernoulli 3 is 0

do!*one!*bern(13);


Bernoulli 13 is 0

do!*one!*bern(14);


Bernoulli 14 is 

                1.166666666666666666666666666666666666666666666666666666666666\
                666666666666666666666666666666666666667

do!*one!*bern(300);


Bernoulli 300 is  - 

                 2.15214997327998682971981737675608819857345657278380670184934\
                 3925846796995824343474766557085976828531e+375

do!*one!*bern(-2);


Bernoulli -2 is bernoulli(-2)

do!*one!*bern(0);


Bernoulli 0 is 1

do!*one!*bern(38);


Bernoulli 38 is 

                4.883323189735931666666666666666666666666666666666666666666666\
                666666666666666666666666666666666666667e+14

do!*one!*bern(400);


Bernoulli 400 is  - 

                 6.84694485580645336061625858231088359767823009718062574241478\
                 1150311357197834589950328990573681886442e+549



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     2. Gamma function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


on rounded;


off complex;


precision 40;


100


algebraic procedure wg(x);
   write ("gamma (", x, ")  ==>  ", gamma x);


wg


algebraic procedure wp(x);
   write ("-- precision ", x, ",  from ", precision(x));


wp


wg (1/2);


gamma (0.5)  ==>  1.772453850905516027298167483341145182798

wg (3/2);


gamma (1.5)  ==>  0.8862269254527580136490837416705725913988


write ("sqrt(pi)/2  ==>  ", sqrt(pi)/2);


sqrt(pi)/2  ==>  0.8862269254527580136490837416705725913988


wp(10);


-- precision 10,  from 40


for x := 0 step 5 until 100 do
   << wg (1 + x/1000);
      wg (-1 - x/13);
      wp (8+floor(x/4)) >>;


gamma (1)  ==>  1

gamma (-1)  ==>  gamma(-1)

-- precision 8,  from 10

gamma (1.005)  ==>  0.99713854

gamma ( - 1.3846154)  ==>  2.7320314

-- precision 9,  from 8

gamma (1.01)  ==>  0.994325851

gamma ( - 1.76923077)  ==>  2.89933597

-- precision 10,  from 9

gamma (1.015)  ==>  0.9915612888

gamma ( - 2.153846154)  ==>   - 2.919307224

-- precision 11,  from 10

gamma (1.02)  ==>  0.98884420326

gamma ( - 2.5384615385)  ==>   - 0.91247160689

-- precision 13,  from 11

gamma (1.025)  ==>  0.9861739631483

gamma ( - 2.923076923077)  ==>   - 2.407817725014

-- precision 14,  from 13

gamma (1.03)  ==>  0.98354995055382

gamma ( - 3.3076923076923)  ==>  0.42665848359037

-- precision 15,  from 14

gamma (1.035)  ==>  0.980971560550586

gamma ( - 3.69230769230769)  ==>  0.250121998146955

-- precision 16,  from 15

gamma (1.04)  ==>  0.9784382009142447

gamma ( - 4.076923076923077)  ==>   - 0.4868211588210416

-- precision 18,  from 16

gamma (1.045)  ==>  0.975949291822951489

gamma ( - 4.46153846153846154)  ==>   - 0.064315864992688343

-- precision 19,  from 18

gamma (1.05)  ==>  0.9735042655627756432

gamma ( - 4.846153846153846154)  ==>   - 0.07308480130893001268

-- precision 20,  from 19

gamma (1.055)  ==>  0.9711025662416699039

gamma ( - 5.2307692307692307692)  ==>  0.026504298643014994546

-- precision 21,  from 20

gamma (1.06)  ==>  0.968743649511638364209

gamma ( - 5.61538461538461538462)  ==>  0.00947958151841097406813

-- precision 23,  from 21

gamma (1.065)  ==>  0.96642698229883993296188

gamma (-6)  ==>  gamma(-6)

-- precision 24,  from 23

gamma (1.07)  ==>  0.964152042541366448869499

gamma ( - 6.38461538461538461538462)  ==>   - 0.00224562428754660955672785

-- precision 25,  from 24

gamma (1.075)  ==>  0.9619183189344448686422338

gamma ( - 6.769230769230769230769231)  ==>   - 0.0014913552210721080976799

-- precision 26,  from 25

gamma (1.08)  ==>  0.95972531068282223532653464

gamma ( - 7.1538461538461538461538462)  ==>  0.0009821350464726696000373901

-- precision 28,  from 26

gamma (1.085)  ==>  0.9575725272601010524841387298

gamma ( - 7.538461538461538461538461538)  ==>  0.0002081367552774423831456972591

-- precision 29,  from 28

gamma (1.09)  ==>  0.95545948817480124076971838245

gamma ( - 7.9230769230769230769230769231)  ==>  

0.00038372470359721945415080451977

-- precision 30,  from 29

gamma (1.095)  ==>  0.95338572274293305256571929565

gamma ( - 8.30769230769230769230769230769)  ==>  

 - 0.0000487302698231202992921248405302

-- precision 31,  from 30

gamma (1.1)  ==>  0.9513507698668731836292487177265

gamma ( - 8.692307692307692307692307692308)  ==>  

 - 0.00002092711689267207910068115762837

-- precision 33,  from 31


wg(1/1000000003);


gamma (0.000000000999999997000000008999999973)  ==>  

1.00000000242278433608752313084681e+9


off rounded;



gamma(17/2);


 2027025*sqrt(pi)
------------------
       256

gamma(-17/2);


      - 512*pi
-------------------
 34459425*sqrt(pi)

gamma(4);


6

gamma(0);


gamma(0)

gamma(-4);


gamma(-4)

gamma(-17/3);


          6*pi
------------------------
                   17
 17*sqrt(3)*gamma(----)
                   3


p := gamma(x**2) * gamma(x-y**gamma(y)) - (1/(gamma(4*(x-y))));


             2            gamma(y)
      gamma(x )*gamma( - y         + x)*gamma(4*x - 4*y) - 1
p := --------------------------------------------------------
                         gamma(4*x - 4*y)

y := 1/4;


      1
y := ---
      4

p;


        2             1  gamma(1/4)
 gamma(x )*gamma( - (---)           + x)*gamma(4*x - 1) - 1
                      4
------------------------------------------------------------
                       gamma(4*x - 1)

x := 3;


x := 3

p;


                         1  gamma(1/4)
 146313216000*gamma( - (---)           + 3) - 1
                         4
------------------------------------------------
                    3628800

y := -3/8;


       - 3
y := ------
       8

p;


(128*(2490343877896875*sqrt(pi)

                   - 3  (8*pi)/(3*gamma(3/8)*sin((3*pi)/8))
              3*(------)                                    - 1
                   8
      *gamma(---------------------------------------------------) - 64))/(
                    - 3  (8*pi)/(3*gamma(3/8)*sin((3*pi)/8))
                 (------)
                    8

   7905853580625*sqrt(pi))


on rounded, complex;


*** Domain mode rounded changed to complex-rounded 

precision 50;


33


p;


 - 0.00000000058461000084165968732153392127582134179078414159599

 + 3.7721251013859508830301986850709684723938237902095e-60*i


off rounded, complex;


*** Domain mode complex-rounded changed to complex 

clear y;



p;


                 gamma(y)
 40320*gamma( - y         + 3)*gamma( - 4*y + 12) - 1
------------------------------------------------------
                  gamma( - 4*y + 12)




% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     3. Beta function.  Not very interesting

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


algebraic procedure do!*one!*beta(x,y);
   write ("Beta (", x, ",", y, ") = ", beta(x,y));


do*one*beta


do!*one!*beta(0,1);


Beta (0,1) = beta(0,1)

do!*one!*beta(2,-3);


Beta (2,-3) = beta(2,-3)

do!*one!*beta(3,2);


              1
Beta (3,2) = ----
              12

do!*one!*beta(a+b,(c+d)**(b-a));


                                                            b
                                                     (c + d)
                                 gamma(a + b)*gamma(----------)
                    b                                       a
             (c + d)                                 (c + d)
Beta (a + b,----------) = ---------------------------------------------
                    a                    a            a            b
             (c + d)              (c + d) *a + (c + d) *b + (c + d)
                           gamma(------------------------------------)
                                                      a
                                               (c + d)

do!*one!*beta(-3,4);


Beta (-3,4) = beta(-3,4)

do!*one!*beta(-3,2);


Beta (-3,2) = beta(-3,2)

do!*one!*beta(-3,-7.5);


           - 15               - 15
Beta (-3,-------) = beta(-3,-------)
            2                  2

do!*one!*beta((pi * 10), exp(5));


                          5
             5     gamma(e )*gamma(10*pi)
Beta (10*pi,e ) = ------------------------
                            5
                     gamma(e  + 10*pi)


on rounded;


precision 30;


50


do!*one!*beta(0,1);


Beta (0,1) = beta(0,1)

do!*one!*beta(2,-3);


Beta (2,-3) = beta(2,-3)

do!*one!*beta(3,2);


Beta (3,2) = 0.0833333333333333333333333333333

do!*one!*beta(a+b,(c+d)**(b-a));


                                                            b
                                                     (c + d)
                                 gamma(a + b)*gamma(----------)
                    b                                       a
             (c + d)                                 (c + d)
Beta (a + b,----------) = ---------------------------------------------
                    a                    a            a            b
             (c + d)              (c + d) *a + (c + d) *b + (c + d)
                           gamma(------------------------------------)
                                                      a
                                               (c + d)

do!*one!*beta(-3,4);


Beta (-3,4) = beta(-3,4)

do!*one!*beta(-3,2);


Beta (-3,2) = beta(-3,2)

do!*one!*beta(-3,-7.5);


Beta (-3, - 7.5) = beta(-3, - 7.5)

do!*one!*beta((pi * 10), exp(5));


Beta (31.4159265358979323846264338328,148.413159102576603421115580041) = 

3.26162024071771351768890966259e-37




% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     4. Pochhammer notation

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;



pochhammer(4,5);


6720

pochhammer(-4,5);


      - 24
---------------
 factorial(-1)

pochhammer(4,-5);


 factorial(-2)
---------------
       6

pochhammer(-4,-5);


  - 1
-------
 15120

pochhammer(17/2,12);


 157783444591397625
--------------------
        4096

pochhammer(-17/2,12);


  - 516891375
--------------
     4096

pochhammer(1/3,14)*pochhammer(2/3,15);


 148260333813553014031851192320000000
--------------------------------------
            68630377364883


q := pochhammer(1/5,11)*pochhammer(2/5,11)*pochhammer(3/5,11)*
      pochhammer(1-1/5,11)*pochhammer(1,11)*pochhammer(6/5,11)*
       pochhammer(70/50,11)*pochhammer(8/5,11)*pochhammer(9/5,11);


q := 3083594385972516709231715156294765932567301688416624945842705314534752626\
     0421323040989302952930905614937458388095527696384131072/12924697071141057\
     41986576081359316958696581423282623291015625


on complex;



pochhammer(a+b*i,c)*pochhammer(a-b*i,c);


pochhammer(a - i*b,c)*pochhammer(a + i*b,c)


a := 2;


a := 2

b := 3;


b := 3

c := 5;


c := 5


pochhammer(a+b*i,c)*pochhammer(a-b*i,c);


8950500


off complex;


on rounded;



pochhammer(1/5,11)*pochhammer(2/5,11)*pochhammer(3/5,11)*
 pochhammer(1-1/5,11)*pochhammer(1,11)*pochhammer(6/5,11)*
  pochhammer(70/50,11)*pochhammer(8/5,11)*pochhammer(9/5,11);


2.38581559706937212593793381562e+67


q;


2.38581559706937212593793381562e+67


pochhammer(pi,floor (pi**8));


2.47253079057195612235973919163e+33625

pochhammer(-pi,floor (pi**7));


5.91750008101140123889628058136e+9185

pochhammer(1.5,floor (pi**8));


1.88808885937650373473836451368e+33619




% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     5. Digamma function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*psi(x);
   << precision (precision(0) + 4)$
      write("Psi of ", x, " is ", psi(x) ) >> ;


do*one*psi


clear x, y;



z := x * ((x+y)**2 + (x**y));


         y    2            2
z := x*(x  + x  + 2*x*y + y )


off rounded;



do!*one!*psi(3);


                             1
             2*log(2) + psi(---) + psi(1) + 3
                             2
Psi of 3 is ----------------------------------
                            2

do!*one!*psi(pi);


Psi of pi is psi(pi)

do!*one!*psi(1.005);


        201           1
Psi of ----- is psi(-----) + 200
        200          200

do!*one!*psi(1.995);


                          pi                   1
                 199*cot(-----)*pi + 199*psi(-----) + 200
        399               200                 200
Psi of ----- is ------------------------------------------
        200                        199

do!*one!*psi(74);


Psi of 74 is (269426837164032294756360054754050*log(2)

                                                        1
               + 134713418582016147378180027377025*psi(---)
                                                        2

               + 2138308231460573767907619482175*psi(1)

               + 667084944417653637854891458725877)/13685172681347672114608764\
             6859200

do!*one!*psi(-1/2);


         - 1          1
Psi of ------ is psi(---) + 2
         2            2

do!*one!*psi(-3);


Psi of -3 is infinity

do!*one!*psi(z);


           y    2            2          y      3      2        2
Psi of x*(x  + x  + 2*x*y + y ) is psi(x *x + x  + 2*x *y + x*y )


on rounded;


precision 100;


62


do!*one!*psi(3);


Psi of 3 is 

            0.9227843350984671393934879099175975689578406640600764011942327651\
            1513227322233532906305293670825325048537

do!*one!*psi(pi);


Psi of 

       3.141592653589793238462643383279502884197169399375105820974944592307816\
       40628620899862803482534211706798214809 is 

0.9772133079420067332920694864061823436408346099943256380095232865318105924777\
14131730207565436292873435576949

do!*one!*psi(1.005);


Psi of 1.005 is  - 

                0.569020911344382831688295690950028809267968870263469094699243\
                7771372094405771031990077045450115105840960011306543

do!*one!*psi(1.995);


Psi of 1.995 is 

                0.419554603028108628651620272287243954692129976503405961275768\
                00237211077024989654159358528162438486780461247996589393

do!*one!*psi(74);


Psi of 74 is 

             4.297293118804667639106350362560367137919643935000983615964648570\
             79142072638532815275329153012799334519059885201047316254

do!*one!*psi(-1/2);


Psi of  - 0.5 is 

                 0.03648997397857652055902366700124443280684039533956589295287\
                 2746128345029282945897851326282715415875401365590709051546051\
                 66846

do!*one!*psi(-3);


Psi of -3 is infinity

do!*one!*psi(z);


           y    2            2          y      3      2        2
Psi of x*(x  + x  + 2*x*y + y ) is psi(x *x + x  + 2*x *y + x*y )


precision 15;


132


x := 8/3;


x := 2.66666666666667

y := 7/1000;


y := 0.007

do!*one!*psi(z);


Psi of 21.74768766103287773 is 3.056340330052438423


off rounded;



clear x, y;



df(psi(z), x);


             y      3      2        2    y      y      2            2
polygamma(1,x *x + x  + 2*x *y + x*y )*(x *y + x  + 3*x  + 4*x*y + y )

df(df(psi(z), y),x);


 2*y                     y      3      2        2
x   *log(x)*polygamma(2,x *x + x  + 2*x *y + x*y )*x*y

    2*y                     y      3      2        2
 + x   *log(x)*polygamma(2,x *x + x  + 2*x *y + x*y )*x

      y                     y      3      2        2   3
 + 3*x *log(x)*polygamma(2,x *x + x  + 2*x *y + x*y )*x

      y                     y      3      2        2   2
 + 4*x *log(x)*polygamma(2,x *x + x  + 2*x *y + x*y )*x *y

    y                     y      3      2        2     2
 + x *log(x)*polygamma(2,x *x + x  + 2*x *y + x*y )*x*y

    y                     y      3      2        2
 + x *log(x)*polygamma(1,x *x + x  + 2*x *y + x*y )*y

    y                     y      3      2        2
 + x *log(x)*polygamma(1,x *x + x  + 2*x *y + x*y )

      y              y      3      2        2   2
 + 2*x *polygamma(2,x *x + x  + 2*x *y + x*y )*x *y

      y              y      3      2        2   2
 + 2*x *polygamma(2,x *x + x  + 2*x *y + x*y )*x

      y              y      3      2        2     2
 + 2*x *polygamma(2,x *x + x  + 2*x *y + x*y )*x*y

      y              y      3      2        2
 + 2*x *polygamma(2,x *x + x  + 2*x *y + x*y )*x*y

    y              y      3      2        2
 + x *polygamma(1,x *x + x  + 2*x *y + x*y )

                  y      3      2        2   4
 + 6*polygamma(2,x *x + x  + 2*x *y + x*y )*x

                   y      3      2        2   3
 + 14*polygamma(2,x *x + x  + 2*x *y + x*y )*x *y

                   y      3      2        2   2  2
 + 10*polygamma(2,x *x + x  + 2*x *y + x*y )*x *y

                  y      3      2        2     3
 + 2*polygamma(2,x *x + x  + 2*x *y + x*y )*x*y

                  y      3      2        2
 + 4*polygamma(1,x *x + x  + 2*x *y + x*y )*x

                  y      3      2        2
 + 2*polygamma(1,x *x + x  + 2*x *y + x*y )*y

int(psi(z), z);


           y      3      2        2
log(gamma(x *x + x  + 2*x *y + x*y ))


on rounded;



for k := 1 step 0.1 until 2 do do!*one!*psi(k);


Psi of 1 is  - 0.57721566490153286060651

Psi of 1.09999999999999999999999999 is  - 0.423754940411076795168216226

Psi of 1.19999999999999999999999999483 is  - 0.2890398965921882955472079690017

Psi of 1.2999999999999999999999999948304368 is 

 - 0.16919088886679965563116117990224309

Psi of 1.39999999999999999999999999483043679294 is 

 - 0.0613845445851161457306754873481741603465

Psi of 1.499999999999999999999999994830436792938162 is 

0.03648997397857652055902366216872537099062413

Psi of 1.5999999999999999999999999948304367929381615219 is 

0.12604745277347625190600271342271679469086378102

Psi of 1.69999999999999999999999999483043679293816152191799 is 

0.20854787487349395667996417990930337500109911872963

Psi of 1.799999999999999999999999994830436792938161521917991479 is 

0.2849914332938615406087023630333301945809176983421812009

Psi of 1.8999999999999999999999999948304367929381615219179914789724 is 

0.35618416116405971922472708037210055174041765918986424485621

Psi of 1.99999999999999999999999999483043679293816152191799147897240477 is 

0.422784335098467139393487906583570145998489083710421411058968004


off rounded;



% PSI_SIMP.TST  F.J.Wright, 2 July 1993

on evallhseqp;


factor psi;

  on rat, intstr, div;

  % for neater output
% Do not try using "off mcd"!

psi(x+m) - psi(x+m-1) = 1/(x+m-1);


     1           1
-----------=-----------
 m + x - 1   m + x - 1

psi(x+2) - psi(x+1) + 2*psi(x) = 1/(x+1) + 2*psi(x);


              1                  1
2*psi(x) + -------=2*psi(x) + -------
            x + 1              x + 1

psi(x+2) + 3*psi(x) = 4*psi(x) + 1/x + 1/(x+1);


             -1                   -1
            x   + 2              x   + 2
4*psi(x) + ---------=4*psi(x) + ---------
             x + 1                x + 1


psi(x + 1) = psi(x) + 1/x;


          -1           -1
psi(x) + x  =psi(x) + x

psi(x + 3/2) = psi(x + 1/2) + 1/(x + 1/2);


         1         2              1         2
psi(x + ---) + ---------=psi(x + ---) + ---------
         2      2*x + 1           2      2*x + 1

psi(x - 1/2) = psi(x + 1/2) - 1/(x - 1/2);


         1         2              1         2
psi(x + ---) - ---------=psi(x + ---) - ---------
         2      2*x - 1           2      2*x - 1

psi((x + 3a)/a);


                          -1
     1        2*(3*x + 8*x   + 12)
psi(---*x) + ----------------------
     2             2
                  x  + 6*x + 8
  psi(x/y + 3);


                          -1  2
       -1     y*(3*x + 2*x  *y  + 6*y)
psi(x*y  ) + --------------------------
                  2              2
                 x  + 3*x*y + 2*y


off rat, intstr, div;

  on rational;



psi(x+m) - psi(x+m-1) = 1/(x+m-1);


     1           1
-----------=-----------
 m + x - 1   m + x - 1

psi(x+2) - psi(x+1) + 2*psi(x) = 1/(x+1) + 2*psi(x);


 2*psi(x)*x + 2*psi(x) + 1   2*psi(x)*x + 2*psi(x) + 1
---------------------------=---------------------------
           x + 1                       x + 1

psi(x+2) + 3*psi(x) = 4*psi(x) + 1/x + 1/(x+1);


           2                                    2
 4*psi(x)*x  + 4*psi(x)*x + 2*x + 1   4*psi(x)*x  + 4*psi(x)*x + 2*x + 1
------------------------------------=------------------------------------
                2                                    2
               x  + x                               x  + x


psi(x + 1) = psi(x) + 1/x;


 psi(x)*x + 1   psi(x)*x + 1
--------------=--------------
      x              x

psi(x + 3/2) = psi(x + 1/2) + 1/(x + 1/2);


          1        1           1                  1        1           1
 psi(x + ---)*x + ---*psi(x + ---) + 1   psi(x + ---)*x + ---*psi(x + ---) + 1
          2        2           2                  2        2           2
---------------------------------------=---------------------------------------
                     1                                       1
                x + ---                                 x + ---
                     2                                       2

psi(x - 1/2) = psi(x + 1/2) - 1/(x - 1/2);


          1        1           1                  1        1           1
 psi(x + ---)*x - ---*psi(x + ---) - 1   psi(x + ---)*x - ---*psi(x + ---) - 1
          2        2           2                  2        2           2
---------------------------------------=---------------------------------------
                     1                                       1
                x - ---                                 x - ---
                     2                                       2

psi((x + 3a)/a);


      1         2                  2          8
 psi(---*x)*x*(x  + 6*x + 8) + 6*(x  + 4*x + ---)
      2                                       3
--------------------------------------------------
                     2
                 x*(x  + 6*x + 8)
  psi(x/y + 3);


      x       2              2          2            2   2
 psi(---)*x*(x  + 3*x*y + 2*y ) + 3*y*(x  + 2*x*y + ---*y )
      y                                              3
------------------------------------------------------------
                       2              2
                   x*(x  + 3*x*y + 2*y )


off rational;



% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     6. Polygamma functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*pg(n,x);
   write ("Polygamma (", n, ") of ", x, " is ", polygamma(n,x));


do*one*pg


off rounded;



do!*one!*pg(1,1/2);


                  1                  1
Polygamma (1) of --- is polygamma(1,---)
                  2                  2

do!*one!*pg(1,1);


                         2
                       pi
Polygamma (1) of 1 is -----
                        6

do!*one!*pg(1,3/2);


                           2
                  3      pi  - 8
Polygamma (1) of --- is ---------
                  2         2

do!*one!*pg(1,1.005);


                  201                  201
Polygamma (1) of ----- is polygamma(1,-----)
                  200                  200

do!*one!*pg(1,1.995);


                  399                  399
Polygamma (1) of ----- is polygamma(1,-----)
                  200                  200

do!*one!*pg(1,1e-10);


                       1                            1
Polygamma (1) of ------------- is polygamma(1,-------------)
                  10000000000                  10000000000

do!*one!*pg(2,1.45);


                  29                  29
Polygamma (2) of ---- is polygamma(2,----)
                  20                  20

do!*one!*pg(3,1.99);


                  199                  199
Polygamma (3) of ----- is polygamma(3,-----)
                  100                  100

do!*one!*pg(4,-8.2);


                   - 41                   - 41
Polygamma (4) of ------- is polygamma(4,-------)
                    5                      5

do!*one!*pg(5,0);


Polygamma (5) of 0 is infinity

do!*one!*pg(6,-5);


Polygamma (6) of -5 is infinity

do!*one!*pg(7,200);


Polygamma (7) of 200 is (17726903568079021516229662669344581999513453462651624\
   712682433450930396569413638060869523209196416456149981841411350319061723276\
   968944831274405326841106087088051862580482604049179034792880997036306450715\
   491134920388121743532178874504889199026667348488846246287054278592284199023\
   548572837863642592371308428279823642858774260678182876022899303888558378920\
   013392172441409952343098219076353830605697314645020537255667718925997023946\
   826863459069360054494011515187931095594830347819766125471751832158677864778\
   297413490571816668099535649328289203181141151677544880676008798702466775519\
   536091686976761627732998715124407667063278175501392084867643186474774933465\
                                                                  8
   396962161891279302009565617687762042880000000000000000000000*pi  - 16820227\
   432460991991188660317955383248583163197077694391321472430675801147397894113\
   241309474829652161707416711766105349898340694530697667469860241947942732920\
   236500114448913470876512035623237448423938602084906142995199152247445505854\
   809437866123469569241946248640222536901257402027830808909074139755120553020\
   556624279638002199727273508802505439369471450464398635245844612858514905584\
   191236791869017030402868269742260341406479951357060228410068248515181595142\
   787674466216948716753957289698597496283251496652438121703517099395342367021\
   250291313681953557646793694608947926057983579614775135882107369446401248554\
   435651401852361884349691269283596626501141334161214962487130496595028983095\
   5139972163546512706990894178649281)/332379441901481653429306175050210912490\
877252424717963362795627204944935676505713641303560172432808552812159526462818\
482407311443167715586395099878270739132900972423384048825922106902366518694430\
745950915458779757277282691228353896966672481750012784165867117882267723605328\
731691535740709943298606962033030246693303602017387715928925429361947910469604\
750251103233276436606433091607681634323856824649594135073543769729862444199003\
003689857550501021762715909773708042403069021620614852595346852975209964593076\
502948221562526866293424905422559646396593953966512675164975671252040991301719\
130814280519993725908582643757436465790651101591268309746402030002476193040535\
46148691267935533164553830400000000000000000000000


on rounded;


precision 100;


63


do!*one!*pg(1,1/2);


Polygamma (1) of 0.5 is 

4.9348022005446793094172454999380755676568497036203953132066746881100224112096\
02621500886701859276116

do!*one!*pg(1,1);


Polygamma (1) of 1 is 

1.6449340668482264364724151666460251892189499012067984377355582293700074704032\
00873833628900619758705

do!*one!*pg(1,3/2);


Polygamma (1) of 1.5 is 

0.9348022005446793094172454999380755676568497036203953132066746881100224112096\
026215008867018592761159

do!*one!*pg(1,1.005);


Polygamma (1) of 1.005 is 

1.6329941567556809752535869786110269899606654266292810174237683064726679207401\
36690588658095268582677

do!*one!*pg(1,1.995);


Polygamma (1) of 1.995 is 

0.6469608286405823512476399271078276952436864784225077824256922477813603546774\
633500406650324443323374

do!*one!*pg(1,1e-10);


Polygamma (1) of 0.0000000001 is 

1.0000000000000000000164493406660781505587296600657326399164207520577564247801\
80942170336642993019363e+20

do!*one!*pg(2,1.45);


Polygamma (2) of 1.45 is  - 

0.9038374030762576882323095385298671928600903081114466582453675225591714826271\
66928803699348863802546

do!*one!*pg(3,1.99);


Polygamma (3) of 1.99 is 

0.5029071324168653201805109908625701971861516895613080444480934082942919777908\
933506993776280887706183

do!*one!*pg(4,-8.2);


Polygamma (4) of  - 8.2 is 

74935.512595774270527120292307813135522959054934662779176176297186107113915939\
37121099755096024434196

do!*one!*pg(5,0);


Polygamma (5) of 0 is infinity

do!*one!*pg(6,-5);


Polygamma (6) of -5 is infinity

do!*one!*pg(7,200);


Polygamma (7) of 200 is 

5.7240937253925583738370296815447272453468073681959561547435678473859266441297\
53317064645661270233713e-14


off rounded;


clear x;




% Polygamma differentiation has already
% been tried a bit in the psi section

df(int(int(int(polygamma(3,x),x),x),x),x);


polygamma(1,x)


clear w, y, z;





% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     7. Zeta function

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


procedure do!*one!*zeta(n);
   write ("Zeta of ", n, " is ", zeta n);


do*one*zeta


off rounded;


clear x, y, z;



z := x * ((x+y)**5 + (x**y));


         y    5      4         3  2       2  3        4    5
z := x*(x  + x  + 5*x *y + 10*x *y  + 10*x *y  + 5*x*y  + y )


do!*one!*zeta(0);


               - 1
Zeta of 0 is ------
               2


for k := 4 step 2 until 35 do 
   do!*one!*zeta(k);


                4
              pi
Zeta of 4 is -----
              90

                6
              pi
Zeta of 6 is -----
              945

                8
              pi
Zeta of 8 is ------
              9450

                 10
               pi
Zeta of 10 is -------
               93555

                     12
               691*pi
Zeta of 12 is -----------
               638512875

                    14
                2*pi
Zeta of 14 is ----------
               18243225

                       16
                3617*pi
Zeta of 16 is --------------
               325641566250

                         18
                 43867*pi
Zeta of 18 is ----------------
               38979295480125

                          20
                 174611*pi
Zeta of 20 is ------------------
               1531329465290625

                           22
                  155366*pi
Zeta of 22 is -------------------
               13447856940643125

                              24
                  236364091*pi
Zeta of 24 is -----------------------
               201919571963756521875

                             26
                   1315862*pi
Zeta of 26 is ----------------------
               11094481976030578125

                                28
                   6785560294*pi
Zeta of 28 is --------------------------
               564653660170076273671875

                                    30
                    6892673020804*pi
Zeta of 30 is ------------------------------
               5660878804669082674070015625

Zeta of 32 is zeta(32)

Zeta of 34 is zeta(34)


do!*one!*zeta(-17/3);


          - 17            - 17
Zeta of ------- is zeta(-------)
           3               3

do!*one!*zeta(190);


Zeta of 190 is zeta(190)

do!*one!*zeta(300);


Zeta of 300 is zeta(300)

do!*one!*zeta(0);


               - 1
Zeta of 0 is ------
               2

do!*one!*zeta(-44);


Zeta of -44 is 0


on rounded;


clear x, y;



for k := 3 step 3 until 36 do <<
   precision (31+k*3);
   do!*one!*zeta(k) >>;


Zeta of 3 is 1.202056903159594285399738161511449990765

Zeta of 6 is 1.017343061984449139714517929790920527901817490033

Zeta of 9 is 1.002008392826082214417852769232412060485605851394888756549

Zeta of 12 is 

              1.00024608655330804829863799804773967096041608845800340453304095\
              2133

Zeta of 15 is 

              1.00003058823630702049355172851064506258762794870685817750656993\
              2893332267156

Zeta of 18 is 

              1.00000381729326499983985646164462193973045469721895333114317442\
              9987630039542650045638

Zeta of 21 is 

              1.00000047693298678780646311671960437304596644669478493760020748\
              7376596839087898159833876638564

Zeta of 24 is 

              1.00000005960818905125947961244020793580122750391883730279586424\
              6972321724495355468544848206832825003614

Zeta of 27 is 

              1.00000000745071178983542949198100417060411945471903188256582999\
              3239578352147606271570867900837100313523764933952

Zeta of 30 is 

              1.00000000093132743241966818287176473502121981356795513681618500\
              8613360441960672940496363503624604027929086312123388047291

Zeta of 33 is 

              1.00000000011641550172700519775929738354563095165224717276359325\
              6517739947029124624567548673934974376008810870912845774213829513\
              369

Zeta of 36 is 

              1.00000000001455192189104198423592963224531842098380889412403806\
              9139542218571745865030220152998942329578185363084791339999779092\
              891491916899


precision 20;


139


do!*one!*zeta(-17/3);


Zeta of  - 5.6666666666666666667 is  - 0.0018766468228592287697

do!*one!*zeta(z);


            y    5      4         3  2       2  3        4    5
Zeta of x*(x  + x  + 5*x *y + 10*x *y  + 10*x *y  + 5*x*y  + y ) is zeta(

    y      6      5         4  2       3  3      2  4      5
   x *x + x  + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + x*y )


y := 3;


y := 3

x := pi;


x := 3.1415926535897932385


do!*one!*zeta(z);


Zeta of 27548.203250393209469 is 1

do!*one!*zeta(190);


Zeta of 190 is 1.0

do!*one!*zeta(300);


Zeta of 300 is 1

do!*one!*zeta(0);


Zeta of 0 is  - 0.5

do!*one!*zeta(-44);


Zeta of -44 is 0


off rounded;





% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     8. Kummer functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


off rounded;



t!*kummer!*a := { 1, 2.4, -1397/10  }$


t!*kummer!*b := { 0, 1, pi, -pi, 26 }$



for each a in t!*kummer!*a do
   for each b in t!*kummer!*a do
      for each z in t!*kummer!*a do
      	 << write "KummerM(", a, ",", b, ",", z, ") = ",
      	       kummerm(a,b,z);
      	    write "KummerU(", a, ",", b, ",", z, ") = ",
      	       kummeru(a,b,z) >>;


KummerM(1,1,1) = e

KummerU(1,1,1) = kummeru(1,1,1)

             12      2/5  2
KummerM(1,1,----) = e   *e
             5

             12                  12
KummerU(1,1,----) = kummeru(1,1,----)
             5                   5

              - 1397          1
KummerM(1,1,---------) = ------------
               10          7/10  139
                          e    *e

              - 1397                   - 1397
KummerU(1,1,---------) = kummeru(1,1,---------)
               10                       10

           12                  12
KummerM(1,----,1) = kummerm(1,----,1)
           5                   5

                              2           12                  12
                     2*gamma(---)*(gamma(----)*e - kummerm(1,----,1))
           12                 5           5                   5
KummerU(1,----,1) = --------------------------------------------------
           5                                   12
                                      5*gamma(----)
                                               5

           12   12                12   12
KummerM(1,----,----) = kummerm(1,----,----)
           5    5                 5    5

           12   12
KummerU(1,----,----) = 
           5    5

        2       2/5  2/5        12    2       4/5  2/5            12   12
 gamma(---)*(5*e   *5   *gamma(----)*e  - 12*2   *3   *kummerm(1,----,----))
        5                       5                                 5    5
-----------------------------------------------------------------------------
                              4/5  2/5        12
                          30*2   *3   *gamma(----)
                                              5

           12    - 1397                12    - 1397
KummerM(1,----,---------) = kummerm(1,----,---------)
           5      10                   5      10

           12    - 1397               2
KummerU(1,----,---------) = (2*gamma(---)*(
           5      10                  5

               7/10     2/5            12    - 1397    139
       - 1397*e    *1397   *kummerm(1,----,---------)*e
                                       5      10

              2/5        12            7/10     2/5        12    139
       - 10*10   *gamma(----)))/(6985*e    *1397   *gamma(----)*e   )
                         5                                 5

            - 1397                   - 1397
KummerM(1,---------,1) = kummerm(1,---------,1)
             10                       10

            - 1397
KummerU(1,---------,1) = 
             10

             1397               - 1397          3*pi
 1397*gamma(------)*kummerm(1,---------,1)*sin(------) - 10*e*pi
              10                 10              10
-----------------------------------------------------------------
                            1417        3*pi
                  10*gamma(------)*sin(------)
                             10          10

            - 1397   12                 - 1397   12
KummerM(1,---------,----) = kummerm(1,---------,----)
             10      5                   10      5

            - 1397   12
KummerU(1,---------,----) = ( - 4868940170769807140163734629614870951763530546\
             10      5
   631554678436906268603895538747067202821442117249242625797089485978560806001\
                                    2/5  2/5  7/10  2
   0798787187515790195560655355904*e   *2   *3    *e *pi + 2004596689573651914\
   834381033324557143448090555188728353940095378016295057932438794523477554321\
            7/10        1397               - 1397   12        3*pi
   2890625*5    *gamma(------)*kummerm(1,---------,----)*sin(------))/(1434929\
                         10                 10      5          10
   627468612680625899093288874118430988228481552150279237922703146068670321255\
                      7/10        1417        3*pi
   92231750488281250*5    *gamma(------)*sin(------))
                                   10          10

            - 1397    - 1397                 - 1397    - 1397
KummerM(1,---------,---------) = kummerm(1,---------,---------)
             10        10                     10        10

            - 1397    - 1397
KummerU(1,---------,---------) = (1397*( - 15215998257931517360033101903862815\
             10        10
      223888543388957222106115555299202666279048867916168002482075600873075777\
      814303704269392393284644411305647344643215427879407971076364582034085385\
      160268928702508481521778353248095651747223572373118125240197785695254459\
      776199438476999663624567921028135476855359579600382069871166959862260275\
      271370315144729355759279591209107609434598035344309681771044690476129730\
                                                           7/10
      6235868715700448137787799653833690839289133*( - 1397)    *pi + 100000000\
      000000000000000000000000000000000000000000000000000000000000000000000000\
                                                                   7/10   7/10
      00000000000000000000000000000000000000000000000000000000000*e    *10

              1397               - 1397    - 1397        3*pi    139
      *gamma(------)*kummerm(1,---------,---------)*sin(------)*e   ))/(100000\
               10                 10        10            10
   000000000000000000000000000000000000000000000000000000000000000000000000000\
                                                                 7/10   7/10
   000000000000000000000000000000000000000000000000000000000000*e    *10

           1417        3*pi    139
   *gamma(------)*sin(------)*e   )
            10          10

         12                  12
KummerM(----,1,1) = kummerm(----,1,1)
         5                   5

         12                  12
KummerU(----,1,1) = kummeru(----,1,1)
         5                   5

         12     12              12     12
KummerM(----,1,----) = kummerm(----,1,----)
         5      5               5      5

         12     12              12     12
KummerU(----,1,----) = kummeru(----,1,----)
         5      5               5      5

         12      - 1397              12      - 1397
KummerM(----,1,---------) = kummerm(----,1,---------)
         5        10                 5        10

         12      - 1397              12      - 1397
KummerU(----,1,---------) = kummeru(----,1,---------)
         5        10                 5        10

         12   12
KummerM(----,----,1) = e
         5    5

                                 2               - 2          2*pi
                        2*gamma(---)*kummerm(1,------,1)*sin(------) + 5*e*pi
         12   12                 5               5             5
KummerU(----,----,1) = -------------------------------------------------------
         5    5                                12        2*pi
                                      5*gamma(----)*sin(------)
                                               5          5

         12   12   12      2/5  2
KummerM(----,----,----) = e   *e
         5    5    5

         12   12   12
KummerU(----,----,----) = 
         5    5    5

    2/5  4/5  2/5  2       2/5        2               - 2   12        2*pi
 6*e   *2   *3   *e *pi + 5   *gamma(---)*kummerm(1,------,----)*sin(------)
                                      5               5     5          5
-----------------------------------------------------------------------------
                        4/5  2/5        12        2*pi
                     6*2   *3   *gamma(----)*sin(------)
                                        5          5

         12   12    - 1397          1
KummerM(----,----,---------) = ------------
         5    5      10          7/10  139
                                e    *e

         12   12    - 1397
KummerU(----,----,---------) = (
         5    5      10

         7/10   2/5        2               - 2    - 1397        2*pi    139
    - 4*e    *10   *gamma(---)*kummerm(1,------,---------)*sin(------)*e
                           5               5       10            5

               2/5            7/10     2/5        12        2*pi    139
    + 1397*1397   *pi)/(1397*e    *1397   *gamma(----)*sin(------)*e   )
                                                  5          5

         12    - 1397                12    - 1397
KummerM(----,---------,1) = kummerm(----,---------,1)
         5      10                   5      10

         12    - 1397                     1431            1431   1417
KummerU(----,---------,1) = ( - 10*gamma(------)*kummerm(------,------,1)*pi + 
         5      10                         10              10     10

               1417          1397          12            12    - 1397
   1397*gamma(------)*gamma(------)*gamma(----)*kummerm(----,---------,1)
                10            10           5             5      10

         3*pi               1431          1417          12        3*pi
   *sin(------))/(10*gamma(------)*gamma(------)*gamma(----)*sin(------))
          10                 10            10           5          10

         12    - 1397   12              12    - 1397   12
KummerM(----,---------,----) = kummerm(----,---------,----)
         5      10      5               5      10      5

         12    - 1397   12
KummerU(----,---------,----) = (2004596689573651914834381033324557143448090555\
         5      10      5
                                                            7/10        1417
   1887283539400953780162950579324387945234775543212890625*5    *gamma(------)
                                                                         10

           1397          12            12    - 1397   12        3*pi
   *gamma(------)*gamma(----)*kummerm(----,---------,----)*sin(------) - 48689\
            10           5             5      10      5          10
   401707698071401637346296148709517635305466315546784369062686038955387470672\
                                                                             2/5
   028214421172492426257970894859785608060010798787187515790195560655355904*2

     7/10        1431            1431   1417   12
   *3    *gamma(------)*kummerm(------,------,----)*pi)/(143492962746861268062\
                  10              10     10    5
   589909328887411843098822848155215027923792270314606867032125592231750488281\
        7/10        1431          1417          12        3*pi
   250*5    *gamma(------)*gamma(------)*gamma(----)*sin(------))
                     10            10           5          10

         12    - 1397    - 1397              12    - 1397    - 1397
KummerM(----,---------,---------) = kummerm(----,---------,---------)
         5      10        10                 5      10        10

         12    - 1397    - 1397
KummerU(----,---------,---------) = (1397*( - 15215998257931517360033101903862\
         5      10        10
      815223888543388957222106115555299202666279048867916168002482075600873075\
      777814303704269392393284644411305647344643215427879407971076364582034085\
      385160268928702508481521778353248095651747223572373118125240197785695254\
      459776199438476999663624567921028135476855359579600382069871166959862260\
      275271370315144729355759279591209107609434598035344309681771044690476129\
                                                              7/10        1431
      7306235868715700448137787799653833690839289133*( - 1397)    *gamma(------)
                                                                           10

                1431   1417    - 1397
      *kummerm(------,------,---------)*pi + 100000000000000000000000000000000\
                 10     10      10
      000000000000000000000000000000000000000000000000000000000000000000000000\
                                            7/10        1417          1397
      00000000000000000000000000000000000*10    *gamma(------)*gamma(------)
                                                         10            10

              12            12    - 1397    - 1397        3*pi
      *gamma(----)*kummerm(----,---------,---------)*sin(------)))/(1000000000\
              5             5      10        10            10
   000000000000000000000000000000000000000000000000000000000000000000000000000\
                                                              7/10        1431
   00000000000000000000000000000000000000000000000000000000*10    *gamma(------)
                                                                           10

           1417          12        3*pi
   *gamma(------)*gamma(----)*sin(------))
            10           5          10

          - 1397                   - 1397
KummerM(---------,1,1) = kummerm(---------,1,1)
           10                       10

          - 1397                   - 1397
KummerU(---------,1,1) = kummeru(---------,1,1)
           10                       10

          - 1397     12               - 1397     12
KummerM(---------,1,----) = kummerm(---------,1,----)
           10        5                 10        5

          - 1397     12               - 1397     12
KummerU(---------,1,----) = kummeru(---------,1,----)
           10        5                 10        5

          - 1397      - 1397               - 1397      - 1397
KummerM(---------,1,---------) = kummerm(---------,1,---------)
           10          10                   10          10

          - 1397      - 1397               - 1397      - 1397
KummerU(---------,1,---------) = kummeru(---------,1,---------)
           10          10                   10          10

          - 1397   12                 - 1397   12
KummerM(---------,----,1) = kummerm(---------,----,1)
           10      5                   10      5

          - 1397   12
KummerU(---------,----,1) = (
           10      5

               1411             - 1397   12          pi
   7055*gamma(------)*kummerm(---------,----,1)*sin(----)*pi + 2794
                10               10      5           10

           1397          12          2             - 1411    - 2          3*pi
   *gamma(------)*gamma(----)*gamma(---)*kummerm(---------,------,1)*sin(------)
            10           5           5              10       5             10

         2*pi               12        2*pi
   *sin(------))/(50*gamma(----)*sin(------)*pi)
          5                 5          5

          - 1397   12   12               - 1397   12   12
KummerM(---------,----,----) = kummerm(---------,----,----)
           10      5    5                 10      5    5

          - 1397   12   12            2/5        1397          12          2
KummerU(---------,----,----) = (1397*5   *gamma(------)*gamma(----)*gamma(---)
           10      5    5                         10           5           5

              - 1411    - 2   12        3*pi        2*pi
   *kummerm(---------,------,----)*sin(------)*sin(------)
               10       5     5          10          5

            4/5  2/5        1411             - 1397   12   12        pi
    + 8466*2   *3   *gamma(------)*kummerm(---------,----,----)*sin(----)*pi)/(
                             10               10      5    5         10

       4/5  2/5        12        2*pi
   60*2   *3   *gamma(----)*sin(------)*pi)
                       5          5

          - 1397   12    - 1397               - 1397   12    - 1397
KummerM(---------,----,---------) = kummerm(---------,----,---------)
           10      5      10                   10      5      10

          - 1397   12    - 1397
KummerU(---------,----,---------) = (
           10      5      10

            2/5        1411             - 1397   12    - 1397        pi
   1411*1397   *gamma(------)*kummerm(---------,----,---------)*sin(----)*pi - 4
                        10               10      5      10           10

      2/5        1397          12          2
   *10   *gamma(------)*gamma(----)*gamma(---)
                  10           5           5

              - 1411    - 2    - 1397        3*pi        2*pi            2/5
   *kummerm(---------,------,---------)*sin(------)*sin(------))/(10*1397
               10       5       10            10          5

           12        2*pi
   *gamma(----)*sin(------)*pi)
           5          5

          - 1397    - 1397
KummerM(---------,---------,1) = e
           10        10

          - 1397    - 1397
KummerU(---------,---------,1) = 
           10        10

             1397           1417                  1417
 1397*gamma(------)*(gamma(------)*e - kummerm(1,------,1))
              10             10                    10
------------------------------------------------------------
                                1417
                      10*gamma(------)
                                 10

          - 1397    - 1397   12      2/5  2
KummerM(---------,---------,----) = e   *e
           10        10      5

          - 1397    - 1397   12                  1397
KummerU(---------,---------,----) = (1397*gamma(------)*(717464813734306340312\
           10        10      5                    10
      949546644437059215494114240776075139618961351573034335160627961158752441\
             2/5  7/10        1417    2
      40625*e   *5    *gamma(------)*e  - 243447008538490357008186731480743547\
                               10
      588176527331577733921845313430194776937353360141072105862462131289854474\
                                                    2/5  7/10
      29892804030005399393593757895097780327677952*2   *3

                  1417   12
      *kummerm(1,------,----)))/(717464813734306340312949546644437059215494114\
                   10    5
                                                           7/10        1417
   240776075139618961351573034335160627961158752441406250*5    *gamma(------))
                                                                        10

          - 1397    - 1397    - 1397          1
KummerM(---------,---------,---------) = ------------
           10        10        10          7/10  139
                                          e    *e

          - 1397    - 1397    - 1397                  1397
KummerU(---------,---------,---------) = (1397*gamma(------)*( - 2125674956633\
           10        10        10                      10
      032975196624335969635286777229511437323928224343075298612479183126847888\
      669946745961441968686160658227486434117341864824259398934046657195274753\
      293559368132110161728306889569339740434868592435948758962549087133060524\
      602096055630661627048030735061555236853008352138567630526116693733270173\
      375161002024292757760455410433025718690999571358891912333038013345537600\
                                                                            7/10
      06254341494325951532336811508595833526048489556116405666102486918801*e

                7/10            1417    - 1397    139
      *( - 1397)    *kummerm(1,------,---------)*e    + 1000000000000000000000\
                                 10      10
      000000000000000000000000000000000000000000000000000000000000000000000000\
                                                        7/10        1417
      00000000000000000000000000000000000000000000000*10    *gamma(------)))/(
                                                                     10
   100000000000000000000000000000000000000000000000000000000000000000000000000\
                                                                        7/10
   0000000000000000000000000000000000000000000000000000000000000000000*e

      7/10        1417    139
   *10    *gamma(------)*e   )
                   10


on rounded;


precision 30;


20

t!*k!*c := 7;


t*k*c := 7


%  To test each and every possible combination of
%  three arguments from t!*kummer!*b would take too
%  long, but we want the possibility of trying most
%  special cases.  Compromise: test every seventh
%  possibility.

for each a in t!*kummer!*b do
   for each b in t!*kummer!*b do
      for each z in t!*kummer!*b do
      	 << if t!*k!*c = 7
      	    then << write "KummerM(", a, ",", b, ",", z, ") = ",
      	       	       kummerm(a,b,z);
      	       	    write "KummerU(", a, ",", b, ",", z, ") = ",
      	       	       kummeru(a,b,z);
      	       	    t!*k!*c := 0 >>;
      	    t!*k!*c := t!*k!*c + 1 >>;


KummerM(0,0,0) = kummerm(0,0,0)

KummerU(0,0,0) = kummeru(0,0,0)

KummerM(0,1,3.14159265358979323846264338328) = 1

KummerU(0,1,3.14159265358979323846264338328) = kummeru(0,1,

   3.14159265358979323846264338328)

KummerM(0,3.14159265358979323846264338328,26) = 1

KummerU(0,3.14159265358979323846264338328,26) = kummeru(0,

   3.14159265358979323846264338328,26)

KummerM(0,26,1) = 1

KummerU(0,26,1) = kummeru(0,26,1)

KummerM(1,0, - 3.14159265358979323846264338328) = kummerm(1,0,

    - 3.14159265358979323846264338328)

KummerU(1,0, - 3.14159265358979323846264338328) = kummeru(1,0,

    - 3.14159265358979323846264338328)

KummerM(1,3.14159265358979323846264338328,0) = 1

KummerU(1,3.14159265358979323846264338328,0) = kummeru(1,

   3.14159265358979323846264338328,0)

KummerM(1, - 3.14159265358979323846264338328,3.14159265358979323846264338328) = 

2692.89480079631357528203659153

KummerU(1, - 3.14159265358979323846264338328,3.14159265358979323846264338328) = 

0.129554194296952806409644905659

KummerM(1,26,26) = 7.74565667206271943920803547594

KummerU(1,26,26) = kummeru(1,26,26)

KummerM(3.14159265358979323846264338328,1,1) = 10.2259987795328570162092950355

KummerU(3.14159265358979323846264338328,1,1) = kummeru(

   3.14159265358979323846264338328,1,1)

KummerM(3.14159265358979323846264338328,3.14159265358979323846264338328,

 - 3.14159265358979323846264338328) = 0.0432139182637722497744177371717

KummerU(3.14159265358979323846264338328,3.14159265358979323846264338328,

 - 3.14159265358979323846264338328) = ( - 0.137891580772667438638357954721

                                        2.14159265358979323846264338328
   *( - 3.14159265358979323846264338328)

    + 1.22938452238615186004844111454)/

                                    2.14159265358979323846264338328
( - 3.14159265358979323846264338328)

KummerM(3.14159265358979323846264338328,26,0) = 1

KummerU(3.14159265358979323846264338328,26,0) = kummeru(

   3.14159265358979323846264338328,26,0)

KummerM( - 3.14159265358979323846264338328,0,3.14159265358979323846264338328) = 

kummerm( - 3.14159265358979323846264338328,0,3.14159265358979323846264338328)

KummerU( - 3.14159265358979323846264338328,0,3.14159265358979323846264338328) = 

kummeru( - 3.14159265358979323846264338328,0,3.14159265358979323846264338328)

KummerM( - 3.14159265358979323846264338328,1,26) = 

6.18522226564722800173513559462e+5

KummerU( - 3.14159265358979323846264338328,1,26) = kummeru(

    - 3.14159265358979323846264338328,1,26)

KummerM( - 3.14159265358979323846264338328, - 3.14159265358979323846264338328,1

) = 2.71828182845904523536028747135

KummerU( - 3.14159265358979323846264338328, - 3.14159265358979323846264338328,1

) = 19.2419564406028465661346237348

KummerM( - 3.14159265358979323846264338328,26, - 3.14159265358979323846264338328

) = 1.42892253084220157246185820464

KummerU( - 3.14159265358979323846264338328,26, - 3.14159265358979323846264338328

) = kummeru( - 3.14159265358979323846264338328,26,

             - 3.14159265358979323846264338328)

KummerM(26,1,0) = 1

KummerU(26,1,0) = kummeru(26,1,0)

KummerM(26,3.14159265358979323846264338328,3.14159265358979323846264338328) = 

3.91638029828702661403357541917e+5

KummerU(26,3.14159265358979323846264338328,3.14159265358979323846264338328) = 

4.18995913372628050180833640475e-32

KummerM(26, - 3.14159265358979323846264338328,26) = 

2.19471945265322419268333614674e+34

KummerU(26, - 3.14159265358979323846264338328,26) = 0


off rounded;


clear x, y, z, t!*k!*c;



df(df(kummerM(a,b,z),z),z);


                 2
(kummerm(2,3,z)*z  - 2*kummerm(2,3,z)*z + 2*kummerm(2,3,z) + 2*kummerm(1,3,z)*z

                                          2
  - 4*kummerm(1,3,z) + 2*kummerm(0,3,z))/z

df(kummerU(a,b,z),z);


 kummeru(2,3,z)*z - kummeru(2,3,z) - kummeru(1,3,z)
----------------------------------------------------
                         z


z := ((x^2 + y)^5) + (x^(x+y));


      x + y    10      8         6  2       4  3      2  4    5
z := x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y


df(df(kummerM(a,b,z),y),x);


  4*x + 4*y
(x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2      4*x + 4*y
 *log(x) *x + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       4*x + 4*y
 *x + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         3*x + 3*y
 *y + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11       3*x + 3*y
 *log(x) *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9         3*x + 3*y
 *log(x) *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  2       3*x + 3*y
 *log(x) *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  3       3*x + 3*y
 *log(x) *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  4      3*x + 3*y
 *log(x) *x *y  + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    5    3*x + 3*y
 *log(x) *x*y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2        3*x + 3*y
 *log(x) *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11      3*x + 3*y
 *x   + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         3*x + 3*y
 *x  *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10       3*x + 3*y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9        3*x + 3*y
 *x *y + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9       3*x + 3*y
 *x  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  2       3*x + 3*y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8         3*x + 3*y
 *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  2       3*x + 3*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7         3*x + 3*y
 *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  3       3*x + 3*y
 *x *y  + 60*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2       3*x + 3*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  3       3*x + 3*y
 *x *y  + 30*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2       3*x + 3*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  4       3*x + 3*y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       3*x + 3*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  4       3*x + 3*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       3*x + 3*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  5       3*x + 3*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4      3*x + 3*y
 *x *y  + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     5      3*x + 3*y
 *x*y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4    3*x + 3*y
 *x*y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         3*x + 3*y
 *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6    3*x + 3*y
 *y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         3*x + 3*y
 *y + 5*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 5

   3*x + 3*y
 *x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      3*x + 3*y
  20*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      3*x + 3*y
  20*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       3*x + 3*y
 + 30*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       3*x + 3*y
 + 30*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       3*x + 3*y
 + 20*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       3*x + 3*y
 + 20*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

      3*x + 3*y
 + 5*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

     3*x + 3*y
  5*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  + 

  3*x + 3*y
 x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y ) + 2

   3*x + 3*y
 *x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2        3*x + 3*y
 *log(x) *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         3*x + 3*y
 *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       2*x + 2*y
 *y + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  21       2*x + 2*y
 *log(x) *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  19         2*x + 2*y
 *log(x) *x  *y + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  17  2        2*x + 2*y
 *log(x) *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  15  3        2*x + 2*y
 *log(x) *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  13  4        2*x + 2*y
 *log(x) *x  *y  + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11  5        2*x + 2*y
 *log(x) *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9  6        2*x + 2*y
 *log(x) *x *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  7       2*x + 2*y
 *log(x) *x *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  8       2*x + 2*y
 *log(x) *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  9    2*x + 2*y
 *log(x) *x *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    10    2*x + 2*y
 *log(x) *x*y   + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2      2*x + 2*y
 *log(x) *x + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   21    2*x + 2*y
 *x   + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20         2*x + 2*y
 *x  *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20       2*x + 2*y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19         2*x + 2*y
 *x  *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19       2*x + 2*y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18  2        2*x + 2*y
 *x  *y  + 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18         2*x + 2*y
 *x  *y + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17  2       2*x + 2*y
 *x  *y  + 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17         2*x + 2*y
 *x  *y + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  3        2*x + 2*y
 *x  *y  + 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  2        2*x + 2*y
 *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  3        2*x + 2*y
 *x  *y  + 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  2        2*x + 2*y
 *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  4         2*x + 2*y
 *x  *y  + 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  3        2*x + 2*y
 *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  4        2*x + 2*y
 *x  *y  + 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  3        2*x + 2*y
 *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  5         2*x + 2*y
 *x  *y  + 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  4        2*x + 2*y
 *x  *y  + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  5         2*x + 2*y
 *x  *y  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  4        2*x + 2*y
 *x  *y  + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  6         2*x + 2*y
 *x  *y  + 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  5       2*x + 2*y
 *x  *y  - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10        2*x + 2*y
 *x   + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  6         2*x + 2*y
 *x *y  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  5       2*x + 2*y
 *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9        2*x + 2*y
 *x  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  7         2*x + 2*y
 *x *y  + 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  6       2*x + 2*y
 *x *y  - 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8          2*x + 2*y
 *x *y + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  7        2*x + 2*y
 *x *y  + 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  6       2*x + 2*y
 *x *y  - 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7          2*x + 2*y
 *x *y + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  8        2*x + 2*y
 *x *y  + 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  7        2*x + 2*y
 *x *y  - 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2       2*x + 2*y
 *x *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  8        2*x + 2*y
 *x *y  + 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  7       2*x + 2*y
 *x *y  - 60*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2       2*x + 2*y
 *x *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  9        2*x + 2*y
 *x *y  + 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  8       2*x + 2*y
 *x *y  - 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       2*x + 2*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  9       2*x + 2*y
 *x *y  + 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  8       2*x + 2*y
 *x *y  - 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       2*x + 2*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  10       2*x + 2*y
 *x *y   + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  9       2*x + 2*y
 *x *y  - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4    2*x + 2*y
 *x *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     10       2*x + 2*y
 *x*y   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     9       2*x + 2*y
 *x*y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4    2*x + 2*y
 *x*y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       2*x + 2*y
 *x + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11    2*x + 2*y
 *y   + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

          2*x + 2*y
 *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5   19
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

     2*x + 2*y
 10*x

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

       2*x + 2*y
 + 50*x

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

     2*x + 2*y
 90*x

               x + y    10      8         6  2       4  3      2  4    5   17
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

       2*x + 2*y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   16  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         2*x + 2*y
  + 400*x

               x + y    10      8         6  2       4  3      2  4    5   16
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

        2*x + 2*y
 + 360*x

               x + y    10      8         6  2       4  3      2  4    5   15  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         2*x + 2*y
  + 360*x

               x + y    10      8         6  2       4  3      2  4    5   14  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          2*x + 2*y
  + 1400*x

               x + y    10      8         6  2       4  3      2  4    5   14  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         2*x + 2*y
  + 840*x

               x + y    10      8         6  2       4  3      2  4    5   13  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         2*x + 2*y
  + 840*x

               x + y    10      8         6  2       4  3      2  4    5   12  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          2*x + 2*y
  + 2800*x

               x + y    10      8         6  2       4  3      2  4    5   12  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          2*x + 2*y
  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5   11  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          2*x + 2*y
  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5   10  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          2*x + 2*y
  + 3500*x

               x + y    10      8         6  2       4  3      2  4    5   10  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

       2*x + 2*y
  + 2*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

       2*x + 2*y
 1260*x

               x + y    10      8         6  2       4  3      2  4    5   9  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 10*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

       2*x + 2*y
 1260*x

               x + y    10      8         6  2       4  3      2  4    5   8  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

         2*x + 2*y
 + 2800*x

               x + y    10      8         6  2       4  3      2  4    5   8  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

      2*x + 2*y
 840*x

               x + y    10      8         6  2       4  3      2  4    5   7  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 40*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

       2*x + 2*y
  840*x

               x + y    10      8         6  2       4  3      2  4    5   6  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

         2*x + 2*y
 + 1400*x

               x + y    10      8         6  2       4  3      2  4    5   6  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 20*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        2*x + 2*y
 + 120*x

               x + y    10      8         6  2       4  3      2  4    5   6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

       2*x + 2*y
  360*x

               x + y    10      8         6  2       4  3      2  4    5   5  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 60*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        2*x + 2*y
 + 360*x

               x + y    10      8         6  2       4  3      2  4    5   4  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        2*x + 2*y
 + 400*x

               x + y    10      8         6  2       4  3      2  4    5   4  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 40*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        2*x + 2*y
 + 120*x

               x + y    10      8         6  2       4  3      2  4    5   4  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   3  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 40*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   2  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 50*x

               x + y    10      8         6  2       4  3      2  4    5   2  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 - 30*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   2  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5     9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  -

      2*x + 2*y
  10*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

      2*x + 2*y
  10*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y   - 

    2*x + 2*y
 8*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  - 

  2*x + 2*y
 x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y ) + 2

   2*x + 2*y
 *x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11       2*x + 2*y
 *log(x) *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9         2*x + 2*y
 *log(x) *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  2       2*x + 2*y
 *log(x) *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  3       2*x + 2*y
 *log(x) *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  4      2*x + 2*y
 *log(x) *x *y  + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    5      2*x + 2*y
 *log(x) *x*y  - 3*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2        2*x + 2*y
 *log(x) *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11      2*x + 2*y
 *x   + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         2*x + 2*y
 *x  *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10       2*x + 2*y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         2*x + 2*y
 *x *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9       2*x + 2*y
 *x  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  2       2*x + 2*y
 *x *y  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8         2*x + 2*y
 *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  2       2*x + 2*y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7         2*x + 2*y
 *x *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  3        2*x + 2*y
 *x *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2       2*x + 2*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  3       2*x + 2*y
 *x *y  + 60*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2       2*x + 2*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  4       2*x + 2*y
 *x *y  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       2*x + 2*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  4       2*x + 2*y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       2*x + 2*y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  5       2*x + 2*y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4      2*x + 2*y
 *x *y  + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     5       2*x + 2*y
 *x*y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4      2*x + 2*y
 *x*y  - 3*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         2*x + 2*y
 *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6      2*x + 2*y
 *y  - 3*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

          2*x + 2*y
 *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

     2*x + 2*y
 10*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      2*x + 2*y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      2*x + 2*y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       2*x + 2*y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

      2*x + 2*y
  10*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  + 

  2*x + 2*y
 x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y ) + 2

   2*x + 2*y
 *x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2        2*x + 2*y
 *log(x) *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

         2*x + 2*y
 *x + 2*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       x + y
 *y + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  21       x + y
 *log(x) *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  19         x + y
 *log(x) *x  *y + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  17  2        x + y
 *log(x) *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  15  3        x + y
 *log(x) *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  13  4        x + y
 *log(x) *x  *y  + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11  5    x + y
 *log(x) *x  *y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11        x + y
 *log(x) *x   + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9  6      x + y
 *log(x) *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9          x + y
 *log(x) *x *y + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  7       x + y
 *log(x) *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  2       x + y
 *log(x) *x *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  8       x + y
 *log(x) *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  3       x + y
 *log(x) *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  9      x + y
 *log(x) *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  4    x + y
 *log(x) *x *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    10    x + y
 *log(x) *x*y   - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    5       x + y
 *log(x) *x*y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   30      x + y
 *x   + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   29        x + y
 *x   + 140*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   28         x + y
 *x  *y + 70*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   27          x + y
 *x  *y + 910*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   26  2        x + y
 *x  *y  + 455*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   25  2         x + y
 *x  *y  + 3640*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   24  3         x + y
 *x  *y  + 1820*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   23  3          x + y
 *x  *y  + 10010*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   22  4         x + y
 *x  *y  + 5005*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   21  4    x + y
 *x  *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   21          x + y
 *x   + 20020*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20  5    x + y
 *x  *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20         x + y
 *x  *y - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20          x + y
 *x   + 10010*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19  5       x + y
 *x  *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19         x + y
 *x  *y - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19          x + y
 *x   + 30030*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18  6       x + y
 *x  *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18  2        x + y
 *x  *y  - 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18            x + y
 *x  *y + 15015*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17  6       x + y
 *x  *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17  2       x + y
 *x  *y  - 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17            x + y
 *x  *y + 34320*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  7       x + y
 *x  *y  + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  3        x + y
 *x  *y  - 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  2          x + y
 *x  *y  + 17160*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  7        x + y
 *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  3        x + y
 *x  *y  - 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  2          x + y
 *x  *y  + 30030*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  8        x + y
 *x  *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  4         x + y
 *x  *y  - 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  3          x + y
 *x  *y  + 15015*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  8        x + y
 *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  4        x + y
 *x  *y  - 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  3          x + y
 *x  *y  + 20020*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  9        x + y
 *x  *y  + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  5         x + y
 *x  *y  - 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  4          x + y
 *x  *y  + 10010*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  9        x + y
 *x  *y  + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  5         x + y
 *x  *y  - 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  4    x + y
 *x  *y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11          x + y
 *x   + 10010*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  10        x + y
 *x  *y   + 252*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  6         x + y
 *x  *y  - 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  5    x + y
 *x  *y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         x + y
 *x  *y + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         x + y
 *x   + 5005*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  10        x + y
 *x *y   + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  6         x + y
 *x *y  - 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  5      x + y
 *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         x + y
 *x *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         x + y
 *x  + 3640*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  11        x + y
 *x *y   + 210*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  7         x + y
 *x *y  - 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  6      x + y
 *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  2       x + y
 *x *y  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8           x + y
 *x *y + 1820*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  11        x + y
 *x *y   + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  7        x + y
 *x *y  - 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  6       x + y
 *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  2       x + y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7          x + y
 *x *y + 910*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  12        x + y
 *x *y   + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  8        x + y
 *x *y  - 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  7       x + y
 *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  3        x + y
 *x *y  + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2        x + y
 *x *y  + 455*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  12       x + y
 *x *y   + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  8        x + y
 *x *y  - 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  7       x + y
 *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  3       x + y
 *x *y  + 60*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2        x + y
 *x *y  + 140*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  13       x + y
 *x *y   + 45*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  9        x + y
 *x *y  - 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  8       x + y
 *x *y  - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  4       x + y
 *x *y  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       x + y
 *x *y  + 70*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  13       x + y
 *x *y   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  9       x + y
 *x *y  - 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  8      x + y
 *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  4       x + y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  14       x + y
 *x *y   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  10       x + y
 *x *y   - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  9      x + y
 *x *y  - 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  5       x + y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     14    x + y
 *x*y   + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     10       x + y
 *x*y   - 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     9    x + y
 *x*y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     5       x + y
 *x*y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4    x + y
 *x*y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11    x + y
 *y   - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6      x + y
 *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5   29
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

    x + y
 5*x

               x + y    10      8         6  2       4  3      2  4    5   28
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

        x + y
 + 100*x

               x + y    10      8         6  2       4  3      2  4    5   28
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

     x + y
 70*x

               x + y    10      8         6  2       4  3      2  4    5   27
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

       x + y
 + 70*x

               x + y    10      8         6  2       4  3      2  4    5   26  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 1300*x

               x + y    10      8         6  2       4  3      2  4    5   26
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

        x + y
 + 455*x

               x + y    10      8         6  2       4  3      2  4    5   25  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  + 455*x

               x + y    10      8         6  2       4  3      2  4    5   24  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 7800*x

               x + y    10      8         6  2       4  3      2  4    5   24  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 1820*x

               x + y    10      8         6  2       4  3      2  4    5   23  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 1820*x

               x + y    10      8         6  2       4  3      2  4    5   22  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 28600*x

               x + y    10      8         6  2       4  3      2  4    5   22  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 5005*x

               x + y    10      8         6  2       4  3      2  4    5   21  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 5005*x

               x + y    10      8         6  2       4  3      2  4    5   20  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 71500*x

               x + y    10      8         6  2       4  3      2  4    5   20  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

     x + y
  + x

               x + y    10      8         6  2       4  3      2  4    5   20
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

        x + y
 10010*x

               x + y    10      8         6  2       4  3      2  4    5   19  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

        x + y
  - 10*x

               x + y    10      8         6  2       4  3      2  4    5   19
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

        x + y
 10010*x

               x + y    10      8         6  2       4  3      2  4    5   18  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

            x + y
  + 128700*x

               x + y    10      8         6  2       4  3      2  4    5   18  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

        x + y
  - 20*x

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

        x + y
 15015*x

               x + y    10      8         6  2       4  3      2  4    5   17  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

        x + y
  - 90*x

               x + y    10      8         6  2       4  3      2  4    5   17
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

          x + y
 + 15015*x

               x + y    10      8         6  2       4  3      2  4    5   16  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

            x + y
  + 171600*x

               x + y    10      8         6  2       4  3      2  4    5   16  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

        x + y
  - 45*x

               x + y    10      8         6  2       4  3      2  4    5   16  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 160*x

               x + y    10      8         6  2       4  3      2  4    5   16
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

          x + y
 + 17160*x

               x + y    10      8         6  2       4  3      2  4    5   15  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 360*x

               x + y    10      8         6  2       4  3      2  4    5   15  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 17160*x

               x + y    10      8         6  2       4  3      2  4    5   14  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

            x + y
  + 171600*x

               x + y    10      8         6  2       4  3      2  4    5   14  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 240*x

               x + y    10      8         6  2       4  3      2  4    5   14  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 560*x

               x + y    10      8         6  2       4  3      2  4    5   14  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 15015*x

               x + y    10      8         6  2       4  3      2  4    5   13  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 840*x

               x + y    10      8         6  2       4  3      2  4    5   13  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 15015*x

               x + y    10      8         6  2       4  3      2  4    5   12  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

            x + y
  + 128700*x

               x + y    10      8         6  2       4  3      2  4    5   12  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  - 630*x

               x + y    10      8         6  2       4  3      2  4    5   12  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  - 1120*x

               x + y    10      8         6  2       4  3      2  4    5   12  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 10010*x

               x + y    10      8         6  2       4  3      2  4    5   11  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  - 1260*x

               x + y    10      8         6  2       4  3      2  4    5   11  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

           x + y
  + 10010*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   10          x + y
 *y   + 71500*x

               x + y    10      8         6  2       4  3      2  4    5   10  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  - 1008*x

               x + y    10      8         6  2       4  3      2  4    5   10  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  - 1400*x

               x + y    10      8         6  2       4  3      2  4    5   10  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

     x + y
  - x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

       x + y
 5005*x

               x + y    10      8         6  2       4  3      2  4    5   9  10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

          x + y
  - 1260*x

               x + y    10      8         6  2       4  3      2  4    5   9  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

       x + y
 5005*x

               x + y    10      8         6  2       4  3      2  4    5   8  11
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

           x + y
  + 28600*x

               x + y    10      8         6  2       4  3      2  4    5   8  10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

          x + y
  - 1050*x

               x + y    10      8         6  2       4  3      2  4    5   8  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

         x + y
 - 1120*x

               x + y    10      8         6  2       4  3      2  4    5   8  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

      x + y
 + 5*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y -

      x + y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

       x + y
 1820*x

               x + y    10      8         6  2       4  3      2  4    5   7  11
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

         x + y
  - 840*x

               x + y    10      8         6  2       4  3      2  4    5   7  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

        x + y
  1820*x

               x + y    10      8         6  2       4  3      2  4    5   6  12
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

          x + y
  + 7800*x

               x + y    10      8         6  2       4  3      2  4    5   6  11
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

         x + y
  - 720*x

               x + y    10      8         6  2       4  3      2  4    5   6  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 560*x

               x + y    10      8         6  2       4  3      2  4    5   6  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 30*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 120*x

               x + y    10      8         6  2       4  3      2  4    5   6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

       x + y
  455*x

               x + y    10      8         6  2       4  3      2  4    5   5  12
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

         x + y
  - 360*x

               x + y    10      8         6  2       4  3      2  4    5   5  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 455*x

               x + y    10      8         6  2       4  3      2  4    5   4  13
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

          x + y
  + 1300*x

               x + y    10      8         6  2       4  3      2  4    5   4  12
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

         x + y
  - 315*x

               x + y    10      8         6  2       4  3      2  4    5   4  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 160*x

               x + y    10      8         6  2       4  3      2  4    5   4  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 50*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 120*x

               x + y    10      8         6  2       4  3      2  4    5   4  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 70*x

               x + y    10      8         6  2       4  3      2  4    5   3  13
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

        x + y
  - 90*x

               x + y    10      8         6  2       4  3      2  4    5   3  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 70*x

               x + y    10      8         6  2       4  3      2  4    5   2  14
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

         x + y
  + 100*x

               x + y    10      8         6  2       4  3      2  4    5   2  13
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

        x + y
  - 80*x

               x + y    10      8         6  2       4  3      2  4    5   2  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 20*x

               x + y    10      8         6  2       4  3      2  4    5   2  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 35*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 40*x

               x + y    10      8         6  2       4  3      2  4    5   2  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

      x + y
 + 5*x

               x + y    10      8         6  2       4  3      2  4    5     14
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y   

       x + y
 - 10*x

               x + y    10      8         6  2       4  3      2  4    5     9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

      x + y
  10*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

     x + y
  5*x

               x + y    10      8         6  2       4  3      2  4    5   15
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y   - 

    x + y
 9*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y   + 

    x + y
 9*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  + 

  x + y              x + y    10      8         6  2       4  3      2  4    5
 x     *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  11      x + y
 *log(x) *x   + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  9         x + y
 *log(x) *x *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  7  2       x + y
 *log(x) *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  5  3      x + y
 *log(x) *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2  3  4    x + y
 *log(x) *x *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

        2    5       x + y
 *log(x) *x*y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   20       x + y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   19        x + y
 *x   + 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   18         x + y
 *x  *y + 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   17          x + y
 *x  *y + 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   16  2        x + y
 *x  *y  + 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   15  2         x + y
 *x  *y  + 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   14  3        x + y
 *x  *y  + 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   13  3         x + y
 *x  *y  + 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   12  4         x + y
 *x  *y  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11  4    x + y
 *x  *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   11         x + y
 *x   + 2520*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10  5    x + y
 *x  *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         x + y
 *x  *y - 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10         x + y
 *x   + 1260*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9  5      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         x + y
 *x *y - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         x + y
 *x  + 1680*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  6      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8  2        x + y
 *x *y  - 160*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8          x + y
 *x *y + 840*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  6       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  2       x + y
 *x *y  - 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7          x + y
 *x *y + 720*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  7       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  3        x + y
 *x *y  - 240*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2        x + y
 *x *y  + 360*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  7       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  3        x + y
 *x *y  - 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2        x + y
 *x *y  + 180*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  8       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  4        x + y
 *x *y  - 160*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       x + y
 *x *y  + 90*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  8      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  4       x + y
 *x *y  - 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       x + y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  9      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  5       x + y
 *x *y  - 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     9    x + y
 *x*y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     5       x + y
 *x*y  - 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4    x + y
 *x*y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6       x + y
 *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5   19
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

     x + y
 10*x

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

        x + y
 + 100*x

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

     x + y
 90*x

               x + y    10      8         6  2       4  3      2  4    5   17
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

       x + y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   16  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  + 800*x

               x + y    10      8         6  2       4  3      2  4    5   16
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

        x + y
 + 360*x

               x + y    10      8         6  2       4  3      2  4    5   15  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  + 360*x

               x + y    10      8         6  2       4  3      2  4    5   14  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 2800*x

               x + y    10      8         6  2       4  3      2  4    5   14  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  + 840*x

               x + y    10      8         6  2       4  3      2  4    5   13  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

         x + y
  + 840*x

               x + y    10      8         6  2       4  3      2  4    5   12  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 5600*x

               x + y    10      8         6  2       4  3      2  4    5   12  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5   11  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 1260*x

               x + y    10      8         6  2       4  3      2  4    5   10  5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

          x + y
  + 7000*x

               x + y    10      8         6  2       4  3      2  4    5   10  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

     x + y
  + x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

       x + y
 1260*x

               x + y    10      8         6  2       4  3      2  4    5   9  5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 20*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

       x + y
 1260*x

               x + y    10      8         6  2       4  3      2  4    5   8  6
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

         x + y
 + 5600*x

               x + y    10      8         6  2       4  3      2  4    5   8  5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 15*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      x + y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

      x + y
 840*x

               x + y    10      8         6  2       4  3      2  4    5   7  6
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 80*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

       x + y
  840*x

               x + y    10      8         6  2       4  3      2  4    5   6  7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

         x + y
 + 2800*x

               x + y    10      8         6  2       4  3      2  4    5   6  6
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 70*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 120*x

               x + y    10      8         6  2       4  3      2  4    5   6
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

       x + y
  360*x

               x + y    10      8         6  2       4  3      2  4    5   5  7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 120*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 360*x

               x + y    10      8         6  2       4  3      2  4    5   4  8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 800*x

               x + y    10      8         6  2       4  3      2  4    5   4  7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 - 110*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 120*x

               x + y    10      8         6  2       4  3      2  4    5   4  2
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   3  8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 80*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 90*x

               x + y    10      8         6  2       4  3      2  4    5   2  9
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

        x + y
 + 100*x

               x + y    10      8         6  2       4  3      2  4    5   2  8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 - 75*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   2  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5     9
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  -

      x + y
  20*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

      x + y
  10*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y   - 

     x + y
 19*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  + 

     x + y
 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   10       x + y
 *x   + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9       x + y
 *x  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   8         x + y
 *x *y + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7          x + y
 *x *y + 120*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   6  2       x + y
 *x *y  + 60*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  2       x + y
 *x *y  + 80*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   4  3       x + y
 *x *y  + 40*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  3       x + y
 *x *y  + 20*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   2  4       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     4       x + y
 *x*y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  + 

     x + y
 10*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      x + y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   7
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      x + y
  40*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   5  2
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   3  3
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5     4
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  +

      x + y
  10*x

               x + y    10      8         6  2       4  3      2  4    5   5
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  + 

                 x + y    10      8         6  2       4  3      2  4    5   38
 50*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   

                    x + y    10      8         6  2       4  3      2  4    5
 + 900*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   36
 *x  *y + 7650

               x + y    10      8         6  2       4  3      2  4    5   34  2
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 40800

               x + y    10      8         6  2       4  3      2  4    5   32  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 153000

               x + y    10      8         6  2       4  3      2  4    5   30  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 428400

               x + y    10      8         6  2       4  3      2  4    5   28  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                    x + y    10      8         6  2       4  3      2  4    5
  - 60*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   28
 *x   + 928200

               x + y    10      8         6  2       4  3      2  4    5   26  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                     x + y    10      8         6  2       4  3      2  4    5
  - 780*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   26
 *x  *y + 1591200

               x + y    10      8         6  2       4  3      2  4    5   24  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 4680*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   24  2
 *x  *y  + 2187900

               x + y    10      8         6  2       4  3      2  4    5   22  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  - 17160

               x + y    10      8         6  2       4  3      2  4    5   22  3
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 2431000

               x + y    10      8         6  2       4  3      2  4    5   20  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  - 42900

               x + y    10      8         6  2       4  3      2  4    5   20  4
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 2187900

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   10
 *y   - 77220

               x + y    10      8         6  2       4  3      2  4    5   18  5
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                    x + y    10      8         6  2       4  3      2  4    5
  + 60*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   18
 *x   + 1591200

               x + y    10      8         6  2       4  3      2  4    5   16
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   11
 *y   - 102960

               x + y    10      8         6  2       4  3      2  4    5   16  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                     x + y    10      8         6  2       4  3      2  4    5
  + 480*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   16
 *x  *y + 928200

               x + y    10      8         6  2       4  3      2  4    5   14
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   12
 *y   - 102960

               x + y    10      8         6  2       4  3      2  4    5   14  7
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 1680*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   14  2
 *x  *y  + 428400

               x + y    10      8         6  2       4  3      2  4    5   12
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   13
 *y   - 77220

               x + y    10      8         6  2       4  3      2  4    5   12  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 3360*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   12  3
 *x  *y  + 153000

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   14
 *y   - 42900

               x + y    10      8         6  2       4  3      2  4    5   10  9
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 4200*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   10  4
 *x  *y  + 40800

               x + y    10      8         6  2       4  3      2  4    5   8  15
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

  - 17160

               x + y    10      8         6  2       4  3      2  4    5   8  10
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 3360*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   8  5
 *x *y  + 7650

               x + y    10      8         6  2       4  3      2  4    5   6  16
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 4680*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   6  11
 *x *y   + 1680

               x + y    10      8         6  2       4  3      2  4    5   6  6
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                    x + y    10      8         6  2       4  3      2  4    5
 + 900*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   4  17
 *x *y   - 780

               x + y    10      8         6  2       4  3      2  4    5   4  12
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                     x + y    10      8         6  2       4  3      2  4    5
  + 480*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   4  7
 *x *y  + 50

               x + y    10      8         6  2       4  3      2  4    5   2  18
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                    x + y    10      8         6  2       4  3      2  4    5
  - 60*kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   2  13
 *x *y   + 60

               x + y    10      8         6  2       4  3      2  4    5   2  8
 *kummerm(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                    x + y    10      8         6  2       4  3      2  4    5
 + 100*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   28
 *x   + 1300

               x + y    10      8         6  2       4  3      2  4    5   26
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

                     x + y    10      8         6  2       4  3      2  4    5
 + 7800*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   24  2
 *x  *y  + 28600

               x + y    10      8         6  2       4  3      2  4    5   22  3
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 71500

               x + y    10      8         6  2       4  3      2  4    5   20  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 128700

               x + y    10      8         6  2       4  3      2  4    5   18  5
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                     x + y    10      8         6  2       4  3      2  4    5
  - 160*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   18
 *x   + 171600

               x + y    10      8         6  2       4  3      2  4    5   16  6
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 1280*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   16
 *x  *y + 171600

               x + y    10      8         6  2       4  3      2  4    5   14  7
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 4480*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   14  2
 *x  *y  + 128700

               x + y    10      8         6  2       4  3      2  4    5   12  8
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 8960*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   12  3
 *x  *y  + 71500

               x + y    10      8         6  2       4  3      2  4    5   10  9
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  - 11200

               x + y    10      8         6  2       4  3      2  4    5   10  4
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

  + 28600

               x + y    10      8         6  2       4  3      2  4    5   8  10
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 8960*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   8  5
 *x *y  + 7800

               x + y    10      8         6  2       4  3      2  4    5   6  11
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 4480*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   6  6
 *x *y  + 1300

               x + y    10      8         6  2       4  3      2  4    5   4  12
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                      x + y    10      8         6  2       4  3      2  4    5
  - 1280*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   4  7
 *x *y  + 100

               x + y    10      8         6  2       4  3      2  4    5   2  13
 *kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                     x + y    10      8         6  2       4  3      2  4    5
  - 160*kummerm(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   2  8
 *x *y  + 100

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

                  x + y    10      8         6  2       4  3      2  4    5   16
 800*kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

 *y + 2800

               x + y    10      8         6  2       4  3      2  4    5   14  2
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 5600*kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   12  3
 *x  *y  + 7000

               x + y    10      8         6  2       4  3      2  4    5   10  4
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 5600*kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   8  5
 *x *y  + 2800

               x + y    10      8         6  2       4  3      2  4    5   6  6
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                    x + y    10      8         6  2       4  3      2  4    5
 + 800*kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   4  7
 *x *y  + 100

               x + y    10      8         6  2       4  3      2  4    5   2  8
 *kummerm(0,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y )

      2*x + 2*y      x + y  10       x + y  8         x + y  6  2
/(x*(x          + 2*x     *x   + 10*x     *x *y + 20*x     *x *y

            x + y  4  3       x + y  2  4      x + y  5    20       18
      + 20*x     *x *y  + 10*x     *x *y  + 2*x     *y  + x   + 10*x  *y

            16  2        14  3        12  4        10  5        8  6        6  7
      + 45*x  *y  + 120*x  *y  + 210*x  *y  + 252*x  *y  + 210*x *y  + 120*x *y

            4  8       2  9    10
      + 45*x *y  + 10*x *y  + y  ))

df(kummerU(a,b,z),x);


  2*x + 2*y
(x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       2*x + 2*y
 *x + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x + 

  2*x + 2*y
 x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y + 

  x + y              x + y    10      8         6  2       4  3      2  4    5
 x     *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

          11      x + y
 *log(x)*x   + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   9         x + y
 *x *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   7  2       x + y
 *x *y  + 10*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   5  3      x + y
 *x *y  + 5*x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

   3  4    x + y
 *x *y  + x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

     5    x + y
 *x*y  - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       x + y
 *x + x

               x + y    10      8         6  2       4  3      2  4    5   11
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

  x + y              x + y    10      8         6  2       4  3      2  4    5
 x     *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   10         x + y
 *x  *y + 10*x

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   + 

    x + y
 5*x

               x + y    10      8         6  2       4  3      2  4    5   9
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

     x + y
  5*x

               x + y    10      8         6  2       4  3      2  4    5   8  2
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   8
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y +

      x + y
  10*x

               x + y    10      8         6  2       4  3      2  4    5   7  2
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5   6  3
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 60*x

               x + y    10      8         6  2       4  3      2  4    5   6  2
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5   5  3
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5   4  4
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 40*x

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

      x + y
 + 5*x

               x + y    10      8         6  2       4  3      2  4    5   3  4
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

      x + y
 + 5*x

               x + y    10      8         6  2       4  3      2  4    5   2  5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

       x + y
 + 10*x

               x + y    10      8         6  2       4  3      2  4    5   2  4
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

    x + y
 + x

               x + y    10      8         6  2       4  3      2  4    5     5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x*y  -

   x + y              x + y    10      8         6  2       4  3      2  4    5
  x     *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

       x + y
 *x + x

               x + y    10      8         6  2       4  3      2  4    5   6
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*y  - 

  x + y              x + y    10      8         6  2       4  3      2  4    5
 x     *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

       x + y
 *y - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*log(x)

       x + y
 *x - x

               x + y    10      8         6  2       4  3      2  4    5
 *kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x - 

  x + y              x + y    10      8         6  2       4  3      2  4    5
 x     *kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

                      x + y    10      8         6  2       4  3      2  4    5
 *y + 10*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   20
 *x   + 90

               x + y    10      8         6  2       4  3      2  4    5   18
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y 

                    x + y    10      8         6  2       4  3      2  4    5
 + 360*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   16  2
 *x  *y  + 840

               x + y    10      8         6  2       4  3      2  4    5   14  3
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                      x + y    10      8         6  2       4  3      2  4    5
  + 1260*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   12  4
 *x  *y  + 1260

               x + y    10      8         6  2       4  3      2  4    5   10  5
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x  *y

                    x + y    10      8         6  2       4  3      2  4    5
  - 10*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   10
 *x   + 840

               x + y    10      8         6  2       4  3      2  4    5   8  6
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                   x + y    10      8         6  2       4  3      2  4    5   8
 - 40*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

 *y + 360

               x + y    10      8         6  2       4  3      2  4    5   6  7
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                   x + y    10      8         6  2       4  3      2  4    5   6
 - 60*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   2
 *y  + 90

               x + y    10      8         6  2       4  3      2  4    5   4  8
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                   x + y    10      8         6  2       4  3      2  4    5   4
 - 40*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   3
 *y  + 10

               x + y    10      8         6  2       4  3      2  4    5   2  9
 *kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                   x + y    10      8         6  2       4  3      2  4    5   2
 - 10*kummeru(2,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   4
 *y  - 10

               x + y    10      8         6  2       4  3      2  4    5   10
 *kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x   - 

                 x + y    10      8         6  2       4  3      2  4    5   8
 40*kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y

                    x + y    10      8         6  2       4  3      2  4    5
  - 60*kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )

   6  2
 *x *y  - 40

               x + y    10      8         6  2       4  3      2  4    5   4  3
 *kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x *y  

                   x + y    10      8         6  2       4  3      2  4    5   2
 - 10*kummeru(1,3,x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y )*x

   4       x + y    10      8         6  2       4  3      2  4    5
 *y )/(x*(x      + x   + 5*x *y + 10*x *y  + 10*x *y  + 5*x *y  + y ))




% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

%     9. Bessel functions

% =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


%  Lengthy test of the Bessel functions.  This isn't even
%  remotely exhaustive of the special cases -- though a
%  real person with lots of time could no doubt come up
%  with a better lot of tests than this automated rubbish.
%  Again, compromise by only actually doing one in five or
%  nine.  If you want a really thorough test, you can
%  easily change this to get it; but it'll take hours to
%  run.

clear p, q;



hankel1(p,q);


hankel1(p,q)

r := df(ws,q);


      hankel1(p - 1,q)*q - hankel1(p,q)*p
r := -------------------------------------
                       q


on complex;



r;


 besselj(p - 1,q)*q - besselj(p,q)*p + i*bessely(p - 1,q)*q - i*bessely(p,q)*p
-------------------------------------------------------------------------------
                                       q

p:=3/8;


      3
p := ---
      8

r;


               - 5          3*pi                   - 5          3*pi
(8*i*besselj(------,q)*cos(------)*q + 8*besselj(------,q)*sin(------)*q
               8             8                     8             8

                  - 3                    5
  + 3*i*besselj(------,q) + 8*i*besselj(---,q)*q
                  8                      8

                 3          3*pi                3          3*pi
  - 3*i*besselj(---,q)*cos(------) - 3*besselj(---,q)*sin(------))/(8
                 8           8                  8           8

         3*pi
   *sin(------)*q)
          8

q := pi;


q := pi

r;


               - 5           3*pi                    - 5           3*pi
(8*i*besselj(------,pi)*cos(------)*pi + 8*besselj(------,pi)*sin(------)*pi
               8              8                      8              8

                  - 3                     5
  + 3*i*besselj(------,pi) + 8*i*besselj(---,pi)*pi
                  8                       8

                 3           3*pi                3           3*pi
  - 3*i*besselj(---,pi)*cos(------) - 3*besselj(---,pi)*sin(------))/(8
                 8            8                  8            8

         3*pi
   *sin(------)*pi)
          8


on rounded;


*** Domain mode complex changed to complex-rounded 


r;


 - 0.119366207318921501826662822529

*hankel1(0.375,3.14159265358979323846264338328)

 + hankel1( - 0.625,3.14159265358979323846264338328)


off complex, rounded;


*** Domain mode complex-rounded changed to rounded 


df(df(besselj(pp,qq)+rr * hankel1(pp*2,qq) *
      bessely(pp-qq,qq),qq),qq);


                      2
(besselj(pp - 2,qq)*qq  - 2*besselj(pp - 1,qq)*pp*qq + besselj(pp - 1,qq)*qq

                     2
  + besselj(pp,qq)*pp  + besselj(pp,qq)*pp

                                               2
  + bessely(pp - qq,qq)*hankel1(2*pp - 2,qq)*qq *rr

  - 4*bessely(pp - qq,qq)*hankel1(2*pp - 1,qq)*pp*qq*rr

  + bessely(pp - qq,qq)*hankel1(2*pp - 1,qq)*qq*rr

                                             2
  + 4*bessely(pp - qq,qq)*hankel1(2*pp,qq)*pp *rr

  + 2*bessely(pp - qq,qq)*hankel1(2*pp,qq)*pp*rr

                                                    2
  + df(bessely(pp - qq,qq),qq,2)*hankel1(2*pp,qq)*qq *rr

                                                        2
  + 2*df(bessely(pp - qq,qq),qq)*hankel1(2*pp - 1,qq)*qq *rr

                                                              2
  - 4*df(bessely(pp - qq,qq),qq)*hankel1(2*pp,qq)*pp*qq*rr)/qq


% Possible values for real args
t!*bes!*vr := { 1, pi, -pi, 26 }$



% Possible values for real and imaginary parts of complex args
t!*bes!*vc := { 0, 3, -41/2 }$



array s!*bes(4)$



s!*bes(1) := "BesselJ"$


s!*bes(2) := "BesselY"$


s!*bes(3) := "BesselI"$


s!*bes(4) := "BesselK"$



pre := 16;


pre := 16

precision pre;


30

preord := 10**pre;


preord := 10000000000000000

t!*b!*c := 3;


t*b*c := 3


algebraic procedure do!*one!*bessel(s,n,z);
   (if s = 1 then besselj(n,z)
      else if s = 2 then bessely(n,z)
      else if s = 3 then besseli(n,z)
      else besselk(n,z));


do*one*bessel


algebraic procedure pr!*bessel(s,n,z,k);
   << if t!*b!*c = k
      then
      	 << on rounded;
      	    bes1 := do!*one!*bessel(s,n,z);
      	    precision(pre+5);
      	    bes2 := do!*one!*bessel(s,n,z);
      	    if bes1 neq 0
      	       then disc := floor abs(100*(bes2-bes1)*preord/bes1)
      	       else disc := 0;
      	    precision pre;
      	    write s!*bes(s), "(", n, ",", z, ") = ", bes1;
      	    if not numberp disc then
      	       << precom := !*complex;
      	       	  on complex;
      	       	  disc := disc;
      	       	  if not precom then off complex >>;
      	    if disc neq 0
      	       then write "   (discrepancy ", disc, "% of one s.f.)";
      	    if numberp disc and disc > 200 then
      	       << write "***** WARNING  Significant Inaccuracy.";
      	       	  write "      Lower  precision result:";
      	       	  write "      ", bes1;
      	       	  write "      Higher precision result:";
      	       	  precision(pre+5); write "      ", bes2; precision pre >>;
      	    off rounded;
      	    t!*b!*c := 0 >>;
      t!*b!*c := t!*b!*c + 1 >>;


pr*bessel


%  About to begin Bessel test.  We have a list of possible
%  values, and we test every Bessel, with every value on the
%  list as both order and argument.  Every Bessel is computed
%  twice, to different precisions (differing by 3), and any
%  discrepancy is reported.  The value reported is the diff-
%  erence between the two computed values, expressed as a
%  percentage of the unit of the least significant displayed
%  digit.  A discrepancy between 100% and 200% means that the
%  last digit of the displayed value was found to differ at
%  higher precision; values greater than 200% are cause for
%  concern.  An ideal discrepancy would be between about 1%
%  and 20%; if the value is found to be zero, no discrepancy
%  is reported.

off msg;



for s := 1:4 do
   << write(" ... Testing ", s!*bes(s), " for real domains ... ");
      for each n in t!*bes!*vr do
         for each z in t!*bes!*vr do
      	    pr!*bessel(s, n, z, 5) >>;


 ... Testing BesselJ for real domains ... 

BesselJ(1, - 3.141592653589793) =  - 0.2846153431797528

BesselJ(3.141592653589793,26) =  - 0.006989220174690161

   (discrepancy 5% of one s.f.)

BesselJ(26,1) = 3.660826744416803e-35

 ... Testing BesselY for real domains ... 

BesselY(1,3.141592653589793) = 0.358872916776719

BesselY(3.141592653589793, - 3.141592653589793) = 

                                          6.283185307179586
 0.1545613960392598*( - 1.570796326794897)                  - 4.829362563540275
--------------------------------------------------------------------------------
                                          3.141592653589793
                    ( - 1.570796326794897)

BesselY( - 3.141592653589793,26) =  - 0.1386083623177915

 ... Testing BesselI for real domains ... 

BesselI(1,1) = 0.565159103992485

BesselI(3.141592653589793,3.141592653589793) = 1.011423335928613

BesselI( - 3.141592653589793, - 3.141592653589793) =  - 0.8856101155917482

 + 0.4221616153281286*i

BesselI(26,26) = 68397.86776155122

 ... Testing BesselK for real domains ... 

BesselK(3.141592653589793,1) = 9.025908765806763

BesselK( - 3.141592653589793,3.141592653589793) = 0.1107526602738113

   (discrepancy 1% of one s.f.)

BesselK(26, - 3.141592653589793) = besselk(26, - 3.141592653589793)


on complex;



for s := 1:3 do
   << write (" ... Testing  ", s!*bes(s), " for complex domains ... ");
      for each nr in t!*bes!*vc do
      	 for each ni in t!*bes!*vc do
      	    for each zr in t!*bes!*vc do
      	       for each zi in t!*bes!*vc do
      	       	  pr!*bessel(s, nr+ni*i, zr+zi*i, 9) >>;


 ... Testing  BesselJ for complex domains ... 

BesselJ(0, - 20.5 + 3.0*i) = 1.05389016561334 + 1.410918160335249*i

BesselJ(3*i, - 20.5 + 3.0*i) = 0.01225787392170983 + 0.01066256817009466*i

BesselJ( - 20.5*i, - 20.5 + 3.0*i) =  - 6.607837931625446e+38

 + 7.203284455482089e+38*i

BesselJ(3, - 20.5 + 3.0*i) = 1.568613483726435 - 0.7011991107137573*i

BesselJ(3 + 3*i, - 20.5 + 3.0*i) = 0.007904103001381543 - 0.006566520928092784*i

BesselJ(3.0 - 20.5*i, - 20.5 + 3.0*i) =  - 7.069920310202644e+37

 - 1.753271554229047e+37*i

BesselJ( - 20.5, - 20.5 + 3.0*i) = 0.1758742246345278 - 0.332739860634916*i

BesselJ( - 20.5 + 3.0*i, - 20.5 + 3.0*i) = 0.08815299110072903

 - 0.1369698556512304*i

BesselJ( - 20.5 - 20.5*i, - 20.5 + 3.0*i) =  - 5.364748129151297e+46

 + 2.608178375230083e+47*i

 ... Testing  BesselY for complex domains ... 

BesselY(0, - 20.5 + 3.0*i) =  - 1.404746667469566 + 1.060048452645186*i

BesselY(3*i, - 20.5 + 3.0*i) = 0.4973091982659732 + 0.7985114801567726*i

BesselY( - 20.5*i, - 20.5 + 3.0*i) =  - 7.203284455482089e+38

 - 6.607837931625446e+38*i

   (discrepancy 10% of one s.f.)

BesselY(3, - 20.5 + 3.0*i) = 0.6963128100601111 + 1.576222640523309*i

BesselY(3 + 3*i, - 20.5 + 3.0*i) =  - 1.117333163968302 + 0.9789575771194796*i

BesselY(3.0 - 20.5*i, - 20.5 + 3.0*i) = 1.753271554229047e+37

 - 7.069920310202644e+37*i

BesselY( - 20.5, - 20.5 + 3.0*i) = 0.2353954565395826 + 0.144691313932682*i

BesselY( - 20.5 + 3.0*i, - 20.5 + 3.0*i) =  - 0.1527215881543493

 + 0.2371137974094512*i

BesselY( - 20.5 - 20.5*i, - 20.5 + 3.0*i) =  - 2.608178375230083e+47

 - 5.364748129151297e+46*i

 ... Testing  BesselI for complex domains ... 

BesselI(0, - 20.5 + 3.0*i) =  - 6.891185608459107e+7 - 1.506065792318474e+7*i

BesselI(3*i, - 20.5 + 3.0*i) =  - 6879.511500081906 - 1745.250262122384*i

BesselI( - 20.5*i, - 20.5 + 3.0*i) = 4.756052726395977e+40

 - 1.836844915663626e+40*i

BesselI(3, - 20.5 + 3.0*i) = 5.56813934269752e+7 + 1.026348768124686e+7*i

BesselI(3 + 3*i, - 20.5 + 3.0*i) = 5917.619873410601 - 1360.623977225443*i

BesselI(3.0 - 20.5*i, - 20.5 + 3.0*i) = 1.125266362182384e+40

 - 3.487618645712341e+39*i

BesselI( - 20.5, - 20.5 + 3.0*i) =  - 0.0005935206748136158

 - 0.001045512507192035*i

BesselI( - 20.5 + 3.0*i, - 20.5 + 3.0*i) = 0.0001367212493519011

 - 0.00008899048591346719*i

BesselI( - 20.5 - 20.5*i, - 20.5 + 3.0*i) =  - 4.705541285798881e+45

 + 6.968045629188714e+45*i


off complex;



on msg;



write (" ...");


 ...

write ("Bessel test complete.");


Bessel test complete.


end;


Time for test: 1310 ms, plus GC time: 125 ms
@@@@@ Resources used: (2 23 284 560)
mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/recsimpl.red0000644000175000017500000001466111526203062024304 0ustar  giovannigiovannimodule recsimpl; % Simplification of expressions involving recursions
                 % for special functions.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Wolfram Koepf, ZIB Berlin , May 1994

% Reduce version (developed from the Maple version) by Winfried Neun.

fluid '(spec_nnnnn);

flag ('(spec_check_n),'boolean);

algebraic procedure trim (u);

  if u = {} then {} else
      if member(first u,rest u) then trim rest u
         else first u . trim rest u;

algebraic procedure adelete (v,u);

  if u = {} then {} else
      if v = first u then adelete(v, rest u)
         else first u . adelete(v, rest u);

algebraic procedure RecursionSimplify (ex);

begin scalar eqq,L1,L2,L3,L4,L5,F,Nargs,n,a,x,kern;

  eqq := ex;
  lisp (kern := union (kernels !*q2f  (numr simp eqq ./ 1),
                        kernels !*q2f (denr simp eqq ./ 1)));

  L1 := 'list . lisp  foreach k in kern join if atom k then nil else
                                list k;
  L2 := 'list . lisp foreach k in kern join if atom k then nil else
                                list (car k , -1 + length k);

  while not(l2 = {}) do <<

        F:=  first l2; L2 := rest L2;
        Nargs := first l2; L2 := rest L2;
        L3 := foreach kk in L1 join
                 if part(kk,0) = F  and
                         lisp equal(-1 + length (prepsq cadr kk),Nargs)
                 then list kk else list ('list);
       L4:= foreach kk in L3 collect lisp ('list . cddr prepsq cadr kk);
       L4 := trim L4;
       foreach kkk in L4 do  <<
          L5 := foreach kkkk in L3 join
                if kkk = lisp ('list . cddr prepsq cadr kkkk)
                then lisp list('list , cadr prepsq cadr kkkk)
                        else {};
         while length L5 > 2 do <<
                n := max(L5);
                if member(n-1,L5) and member(n-2,L5) then
                   <<   spec_nnnnn:= n;
                        let Spec_recrules;
                        eqq := eqq;
                        spec_nnnnn:= nil;
                        clearrules Spec_recrules;
                   >>;
                L5 := adelete(n,L5);

                >>; >>; >>;
return eqq;
  end;

algebraic procedure spec_check_n(n);
   if n = spec_nnnnn then t else nil;


algebraic (
Spec_Recrules :={
% AS (9.1.27)

BesselJ(~n,~z) => - BesselJ(n-2,z) + (2*(n-1)/z)*BesselJ(n-1,z)
when spec_check_n(n),
% AS (9.1.27)

BesselY(~n,~z) => - BesselY(n-2,z) + (2*(n-1)/z)*BesselY(n-1,z)
when spec_check_n(n),
% AS (9.6.26)

BesselI(~n,~z) => BesselI(n-2,z) - (2*(n-1)/z)*BesselI(n-1,z)
when spec_check_n(n),
% AS (9.6.26)

BesselK(~n,~z) => BesselK(n-2,z) + (2*(n-1)/z)*BesselK(n-1,z)
when spec_check_n(n),
% AS (9.1.27)

Hankel1(~n,~z) => - Hankel1(n-2,z) + (2*(n-1)/z)*Hankel1(n-1,z)
when spec_check_n(n),
% AS (9.1.27)

Hankel2(~n,~z) => - Hankel2(n-2,z) + (2*(n-1)/z)*Hankel2(n-1,z)
when spec_check_n(n),
% AS (13.4.2)

KummerM(~a,~b,~z) => 1/(a-1)*
        ((b-a+1)*KummerM(a-2,b,z) + (2*a-2-b+z)*KummerM(a-1,b,z))
when spec_check_n(a),

% AS (13.4.15)
KummerU(~a,~b,~z) => -1/((a-1)*(a-b))*
        (KummerU(a-2,b,z) + (b-2*a+2-z)*KummerU(a-1,b,z))
when spec_check_n(a),
% AS (13.4.29)

WhittakerM(~n,~m,~z) => 1/(2*m+2*n-1)*
        ((3+2*m-2*n)*WhittakerM(n-2,m,z)
           + (4*n-4-2*z)*WhittakerM(n-1,m,z))
when spec_check_n(n),
% AS (13.4.31)

WhittakerW(~n,~m,~z) => 1/4*
((-9+4*m^2+12*n-4*n^2)*WhittakerW(n-2,m,z)
    - (8*n-8-4*z)*WhittakerW(n-1,m,z))
when spec_check_n(n),
% AS (8.5.3)

LegendreP(~a,~b,~z) => 1/(a-b)*
        (-(a-1+b)*LegendreP(a-2,b,z) + (2*a-1)*z*LegendreP(a-1,b,z))
when spec_check_n(a),

LegendreQ(~a,~b,~z) => 1/(a-b)*
        (-(a-1+b)*LegendreQ(a-2,b,z) + (2*a-1)*z*LegendreQ(a-1,b,z))
when spec_check_n(a),
% AS (22.7)

JacobiP(~n,~a,~b,~z) => 1/(2*n*(a + b + n)*(-2 + a + b + 2*n))*
((2*(1-a-n)*(-1+b+n)*(a+b+2*n)*JacobiP(n-2,a,b,z)) +
((a^2-b^2)*(-1+a+b+2*n)+(-2+a+b+2*n)*(-1+a+b+2*n)*(a+b+2*n)*z)*
JacobiP(n-1,a,b,z)) when spec_check_n(n),

GegenbauerP(~n,~a,~z) => 1/n*(
     -(n+2*a-2)*GegenbauerP(n-2,a,z) + 2*(n-1+a)*z*GegenbauerP(n-1,a,z))
when spec_check_n(n),

ChebyshevT(~n,~z) => - ChebyshevT(n-2,z) +2*z*ChebyshevT(n-1,z)
when spec_check_n(n),

ChebyshevU(~n,~z) => - ChebyshevU(n-2,z) +2*z*ChebyshevU(n-1,z)
when spec_check_n(n),

% Two arguments version:
 LegendreP(~n,~z) =>
 1/n*(-(n-1)*LegendreP(n-2,z)+(2*n-1)*z*LegendreP(n-1,z))
 when spec_check_n(n),

LaguerreP(~n,~a,~z) => 1/n*
        (-(n-1+a)*LaguerreP(n-2,a,z) + (2*n+a-1-z)*LaguerreP(n-1,a,z))
when spec_check_n(n),

LaguerreP(~n,~z) => 1/n*
        (-(n-1)*LaguerreP(n-2,z) + (2*n-1-z)*LaguerreP(n-1,z))
when spec_check_n(n),

HermiteP(~n,~z) => -2*(n-1)*HermiteP(n-2,z) + 2*z*HermiteP(n-1,z)
when spec_check_n(n) ,

struveH(~nnnnn,~x)=>
((x^2*struveH(-3 + nnnnn,x) + 5*x*struveH(-2 + nnnnn,x) -
        4*nnnnn*x*struveH(-2 + nnnnn,x) + 2*struveH(-1 + nnnnn,x) -
        6*nnnnn*struveH(-1 + nnnnn,x) + 4*nnnnn^2*struveH(-1 + nnnnn,x)
        + x^2*struveH(-1 + nnnnn,x))/(-x + 2*nnnnn*x))
  when spec_check_n(nnnnn),

%(* AS (12.2.4)-(12.2.5) *)

struveL(~nnnnn,~x) => ((-(x*struveL(-3 + nnnnn, x)) +
(-1 + 4*(-1 + nnnnn))*struveL(-2 + nnnnn, x) +
((-2*(-1 + nnnnn) - 4*(-1 + nnnnn)^2 + x^2)*struveL(-1 + nnnnn, x))/x)/
(1 + 2*(-1 + nnnnn))) when spec_check_n(nnnnn) } )$

% can be locally applied with where.

endmodule;

end;



mathpiper-0.81f+svn4469+dfsg3/src/packages/specfn/meijerg.tex0000644000175000017500000000506711526203062024136 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{{\tt meijerG}, a package for simplification\\
of Meijer's G function}
\date{}
\author{Victor S. Adamchik\\
	Wolfram Research Inc. \\
	former address : \\
	Byelorussian University, Minsk, Byelorussia\\
\\
\\
	Present \REDUCE{} form by \\
	Winfried Neun \\
	ZIB Berlin \\
        Email: {\tt Neun@sc.ZIB-Berlin.de}}
\begin{document}
\maketitle

This note describes the {\tt meijerG} package of \REDUCE{}, which is able
to do simplification of several cases of Meijer's G function. 
The simplifications are performed towards polynomials, elementary or
special functions or (generalized) hypergeometric functions.
Therefore this package should be used together with the \REDUCE{}
special function and hypergeometric (ghyper) package.

\section{Introduction}

The function 

\begin{displaymath}
G_{p q}^{m n} \left( z \  \Bigg\vert \  {(a_p) \atop (b_q)} \right)
\end{displaymath}

has been studied by C.~S.~Meijer beginning in 1936 and has been
called Meijer's G function later on. The complete definition of Meijer's
G function can be found in \cite{Prudnikov:90}.
Many well-known functions can be written as G functions,
e.g. exponentials, logarithms, trigonometric functions, Bessel functions
and hypergeometric functions.

Several hundreds of particular values can be found in \cite{Prudnikov:90}.

\section{\REDUCE{} operator {\tt meijerg}}

The operator {\tt meijerg} expects 3 arguments, namely the 
list of upper parameters (which may be empty), the list of lower
parameters (which may be empty too), and the argument.

The first element of the lists has to be the list of the
first m or n resp. parameter, e.g.

To describe 
\begin{displaymath}
G_{1 1}^{1 0} \left( x \  \Bigg\vert \  {1 \atop 0} \right)
\end{displaymath}

one has to write 
\begin{verbatim}

MeijerG({{},1},{{0}},x); % and the result is:

 HEAVISIDE( - X + 1)
---------------------
      GAMMA(1)

\end{verbatim}
and for
\begin{displaymath}
G_{0 2}^{1 0} \left( \frac{x^2}{4} \  \Bigg\vert \ {} \atop  {1+ \frac{1}{4} }
{1-\frac{1}{4}} \right)
\end{displaymath}
\begin{verbatim}

MeijerG({{}},{{1+1/4},1-1/4},(x^2)/4) * sqrt pi;


                   1      2
 SQRT(PI)*BESSELJ(---,X)*X
                   2
----------------------------
             4

\end{verbatim}

Note: Using the special function package these results will be
simplified further.

\begin{thebibliography}{9}

\bibitem{Prudnikov:90} A.~P.~Prudnikov, Yu.~A.~Brychkov, O.~I.~Marichev,
{\em Integrals and Series, Volume 3: More special functions},
Gordon and Breach Science Publishers (1990).

\end{thebibliography}
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/0000755000175000017500000000000011722677356021325 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tritstx.tex0000644000175000017500000001561611526203062023556 0ustar  giovannigiovanni\TRIexa{Integration}{TeXindent}{1000}{int(1+x+x**2,x);}
$$\displaylines{\qdd
\frac{x\cdot 
      \(2\cdot x^{2}
        +3\cdot x
        +6
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2*(2*x**2+x)**2,x);}
$$\displaylines{\qdd
\frac{x^{5}\cdot 
      \(60\cdot x^{2}
        +70\cdot x
        +21
      \)
      }{
      105}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*(x**2+2*x+1),x);}
$$\displaylines{\qdd
\frac{x^{2}\cdot 
      \(3\cdot x^{2}
        +8\cdot x
        +6
      \)
      }{
      12}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/x,x);}
$$\displaylines{\qdd
\ln 
\(x
\)
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((x+1)**3/(x-1)**4,x);}
$$\displaylines{\qdd
\(3\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{3}
  -9\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{2}
  +9\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  -3\cdot \ln 
  \(x
    -1
  \)
  -6\cdot x^{3}
  -2
\)
/\nl 
\(3\cdot 
  \(x^{3}
    -3\cdot x^{2}
    +3\cdot x
    -1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x*(x-1)*(x+1)**2),x);}
$$\displaylines{\qdd
\(\ln 
  \(x
    -1
  \)
  \cdot x
  +\ln 
  \(x
    -1
  \)
  +3\cdot \ln 
  \(x
    +1
  \)
  \cdot x\nl 
  \off{327680}
  +3\cdot \ln 
  \(x
    +1
  \)
  -4\cdot \ln 
  \(x
  \)
  \cdot x
  -4\cdot \ln 
  \(x
  \)
  +2\cdot x
\)
/\nl 
\(4\cdot 
  \(x
    +1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/((x-p)*(x-q)),x);}
$$\displaylines{\qdd
\frac{\ln 
      \(p
        -x
      \)
      \cdot a\cdot p
      +\ln 
      \(p
        -x
      \)
      \cdot b
      -\ln 
      \(q
        -x
      \)
      \cdot a\cdot q
      -\ln 
      \(q
        -x
      \)
      \cdot b}{
      p
      -q}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(a*x**2+b*x+c),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{4\cdot a\cdot c
            -b^{2}}\cdot \arctan 
      \(\frac{2\cdot a\cdot x
              +b}{
              \sqrt{4\cdot a\cdot c
                    -b^{2}}}
      \)
      }{
      4\cdot a\cdot c
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/(1+x**2),x);}
$$\displaylines{\qdd
\frac{\ln 
      \(x^{2}
        +1
      \)
      \cdot a
      +2\cdot \arctan 
      \(x
      \)
      \cdot b}{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x**2-2*x+3),x);}
$$\displaylines{\qdd
\frac{\sqrt{2}
      \cdot \arctan 
      \(\frac{x
              -1}{
              \sqrt{2}}
      \)
      }{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/((x-1)*(x**2+1))**2,x);}
$$\displaylines{\qdd
\(\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{3}
  -\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{2}
  +\ln 
  \(x^{2}
    +1
  \)
  \cdot x
  -\ln 
  \(x^{2}
    +1
  \)
  \nl 
  \off{327680}
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{3}
  +2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{2}
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x\nl 
  \off{327680}
  +2\cdot \ln 
  \(x
    -1
  \)
  +\arctan 
  \(x
  \)
  \cdot x^{3}
  -\arctan 
  \(x
  \)
  \cdot x^{2}\nl 
  \off{327680}
  +\arctan 
  \(x
  \)
  \cdot x
  -\arctan 
  \(x
  \)
  -x^{3}
  -2\cdot x
  +1
\)
/\nl 
\(4\cdot 
  \(x^{3}
    -x^{2}
    +x
    -1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-a)*(x-b)*(x-c)),x);}
$$\displaylines{\qdd
\(\ln 
  \(a
    -x
  \)
  \cdot a\cdot b
  -\ln 
  \(a
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(b
    -x
  \)
  \cdot a\cdot b\nl 
  \off{327680}
  +\ln 
  \(b
    -x
  \)
  \cdot b\cdot c
  +\ln 
  \(c
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(c
    -x
  \)
  \cdot b\cdot c
\)
/\nl 
\(a^{2}\cdot b
  -a^{2}\cdot c
  -a\cdot b^{2}
  +a\cdot c^{2}
  +b^{2}\cdot c
  -b\cdot c^{2}
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{-\ln 
      \(a^{2}
        +x^{2}
      \)
      +\ln 
      \(b^{2}
        +x^{2}
      \)
      }{
      2\cdot 
      \(a^{2}
        -b^{2}
      \)
      }
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{\arctan 
      \(\frac{x}{
              a}
      \)
      \cdot a
      -\arctan 
      \(\frac{x}{
              b}
      \)
      \cdot b}{
      a^{2}
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-1)*(x**2+1)),x);}
$$\displaylines{\qdd
\frac{-\ln 
      \(x^{2}
        +1
      \)
      +2\cdot \ln 
      \(x
        -1
      \)
      +2\cdot \arctan 
      \(x
      \)
      }{
      4}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/(1+x**3),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{3}\cdot \arctan 
      \(\frac{2\cdot x
              -1}{
              \sqrt{3}}
      \)
      +\ln 
      \(x^{2}
        -x
        +1
      \)
      -2\cdot \ln 
      \(x
        +1
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**3/((x-1)**2*(x**3+1)),x);}
$$\displaylines{\qdd
\(-
  \(4\cdot \ln 
    \(x^{2}
      -x
      +1
    \)
    \cdot x
  \)
  +4\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  \nl 
  \off{327680}
  +9\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  -9\cdot \ln 
  \(x
    -1
  \)
  -\ln 
  \(x
    +1
  \)
  \cdot x
  +\ln 
  \(x
    +1
  \)
  -6\cdot x
\)
/\nl 
\(12\cdot 
  \(x
    -1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(-\ln 
    \(-
      \(\sqrt{2}\cdot x
      \)
      +x^{2}
      +1
    \)
    +\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
    \nl 
    \off{1277951}
    -2\cdot \arctan 
    \(\frac{\sqrt{2}
            -2\cdot x}{
            \sqrt{2}}
    \)
    +2\cdot \arctan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
  \)
\)
/8
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(\ln 
    \(-
      \(\sqrt{2}\cdot x
      \)
      +x^{2}
      +1
    \)
    -\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
    \nl 
    \off{1277951}
    -2\cdot \arctan 
    \(\frac{\sqrt{2}
            -2\cdot x}{
            \sqrt{2}}
    \)
    +2\cdot \arctan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
  \)
\)
/8
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**2+x**4),x);}
$$\displaylines{\qdd
\(2\cdot 
  \sqrt{3}\cdot \arctan 
  \(\frac{2\cdot x
          -1}{
          \sqrt{3}}
  \)
  +2\cdot 
  \sqrt{3}\cdot \arctan 
  \(\frac{2\cdot x
          +1}{
          \sqrt{3}}
  \)
  \nl 
  \off{327680}
  -3\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  +3\cdot \ln 
  \(x^{2}
    +x
    +1
  \)
\)
/12
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(sin x**2/x,x);}
$$\displaylines{\qdd
\int 
\frac{\sin 
      \(x
      \)
      ^{2}}{
      x}\,dx
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);}
$$\displaylines{\qdd
\int 
\frac{\cos 
      \(\frac{\xi }{
              \sin 
              \(x
              \)
              }
      \)
      \cdot \cos 
      \(x
      \)
      \cdot x}{
      \sin 
      \(x
      \)
      ^{2}}\,dx
\cr}$$
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tritst.tex0000644000175000017500000001571511526203062023366 0ustar  giovannigiovanni\TRIexa{Integration}{TeXindent}{1000}{int(1+x+x**2,x);}
$$\displaylines{\qdd
\frac{x\cdot 
      \(2\cdot x^{2}
        +3\cdot x
        +6
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2*(2*x**2+x)**2,x);}
$$\displaylines{\qdd
\frac{x^{5}\cdot 
      \(60\cdot x^{2}
        +70\cdot x
        +21
      \)
      }{
      105}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*(x**2+2*x+1),x);}
$$\displaylines{\qdd
\frac{x^{2}\cdot 
      \(3\cdot x^{2}
        +8\cdot x
        +6
      \)
      }{
      12}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/x,x);}
$$\displaylines{\qdd
\ln 
\(x
\)
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((x+1)**3/(x-1)**4,x);}
$$\displaylines{\qdd
\(3\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{3}
  -9\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{2}
  +9\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  -3\cdot \ln 
  \(x
    -1
  \)
  -6\cdot x^{3}
  -2
\)
/\nl 
\(3\cdot 
  \(x^{3}
    -3\cdot x^{2}
    +3\cdot x
    -1
  \)
\)
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x*(x-1)*(x+1)**2),x);}
$$\displaylines{\qdd
\(\ln 
  \(x
    -1
  \)
  \cdot x
  +\ln 
  \(x
    -1
  \)
  +3\cdot \ln 
  \(x
    +1
  \)
  \cdot x\nl 
  \off{327680}
  +3\cdot \ln 
  \(x
    +1
  \)
  -4\cdot \ln 
  \(x
  \)
  \cdot x
  -4\cdot \ln 
  \(x
  \)
  +2\cdot x
\)
/\nl 
\(4\cdot 
  \(x
    +1
  \)
\)
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/((x-p)*(x-q)),x);}
$$\displaylines{\qdd
\frac{\ln 
      \(p
        -x
      \)
      \cdot a\cdot p
      +\ln 
      \(p
        -x
      \)
      \cdot b
      -\ln 
      \(q
        -x
      \)
      \cdot a\cdot q
      -\ln 
      \(q
        -x
      \)
      \cdot b}{
      p
      -q}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(a*x**2+b*x+c),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{4\cdot a\cdot c
            -b^{2}}\cdot \arctan 
      \(\frac{2\cdot a\cdot x
              +b}{
              \sqrt{4\cdot a\cdot c
                    -b^{2}}}
      \)
      }{
      4\cdot a\cdot c
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/(1+x**2),x);}
$$\displaylines{\qdd
\frac{2\cdot \arctan 
      \(x
      \)
      \cdot b
      +\ln 
      \(x^{2}
        +1
      \)
      \cdot a}{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x**2-2*x+3),x);}
$$\displaylines{\qdd
\frac{\sqrt{2}
      \cdot \arctan 
      \(\frac{x
              -1}{
              \sqrt{2}}
      \)
      }{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/((x-1)*(x**2+1))**2,x);}
$$\displaylines{\qdd
\(\arctan 
  \(x
  \)
  \cdot x^{3}
  -\arctan 
  \(x
  \)
  \cdot x^{2}
  +\arctan 
  \(x
  \)
  \cdot x\nl 
  \off{327680}
  -\arctan 
  \(x
  \)
  +\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{3}
  -\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{2}\nl 
  \off{327680}
  +\ln 
  \(x^{2}
    +1
  \)
  \cdot x
  -\ln 
  \(x^{2}
    +1
  \)
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{3}\nl 
  \off{327680}
  +2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{2}
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  +2\cdot \ln 
  \(x
    -1
  \)
  -x^{3}
  -2\cdot x
  +1
\)
/\nl 
\(4\cdot 
  \(x^{3}
    -x^{2}
    +x
    -1
  \)
\)
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-a)*(x-b)*(x-c)),x);}
$$\displaylines{\qdd
\(\ln 
  \(a
    -x
  \)
  \cdot a\cdot b
  -\ln 
  \(a
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(b
    -x
  \)
  \cdot a\cdot b\nl 
  \off{327680}
  +\ln 
  \(b
    -x
  \)
  \cdot b\cdot c
  +\ln 
  \(c
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(c
    -x
  \)
  \cdot b\cdot c
\)
/\nl 
\(a^{2}\cdot b
  -a^{2}\cdot c
  -a\cdot b^{2}
  +a\cdot c^{2}
  +b^{2}\cdot c
  -b\cdot c^{2}
\)
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{-\ln 
      \(a^{2}
        +x^{2}
      \)
      +\ln 
      \(b^{2}
        +x^{2}
      \)
      }{
      2\cdot 
      \(a^{2}
        -b^{2}
      \)
      }
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{\arctan 
      \(\frac{x}{
              a}
      \)
      \cdot a
      -\arctan 
      \(\frac{x}{
              b}
      \)
      \cdot b}{
      a^{2}
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-1)*(x**2+1)),x);}
$$\displaylines{\qdd
\frac{2\cdot \arctan 
      \(x
      \)
      -\ln 
      \(x^{2}
        +1
      \)
      +2\cdot \ln 
      \(x
        -1
      \)
      }{
      4}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/(1+x**3),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{3}\cdot \arctan 
      \(\frac{2\cdot x
              -1}{
              \sqrt{3}}
      \)
      +\ln 
      \(x^{2}
        -x
        +1
      \)
      -2\cdot \ln 
      \(x
        +1
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**3/((x-1)**2*(x**3+1)),x);}
$$\displaylines{\qdd
\(-
  \(4\cdot \ln 
    \(x^{2}
      -x
      +1
    \)
    \cdot x
  \)
  +4\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  \nl 
  \off{327680}
  +9\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  -9\cdot \ln 
  \(x
    -1
  \)
  -\ln 
  \(x
    +1
  \)
  \cdot x
  +\ln 
  \(x
    +1
  \)
  -6\cdot x
\)
/\nl 
\(12\cdot 
  \(x
    -1
  \)
\)
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(-
    \(2\cdot \arctan 
      \(\frac{\sqrt{2}
              -2\cdot x}{
              \sqrt{2}}
      \)
    \)
    +2\cdot \arctan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
    \nl 
    \off{1277951}
    -\ln 
    \(-
      \(\sqrt{2}\cdot x
      \)
      +x^{2}
      +1
    \)
    +\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
  \)
\)
/8
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(-
    \(2\cdot \arctan 
      \(\frac{\sqrt{2}
              -2\cdot x}{
              \sqrt{2}}
      \)
    \)
    +2\cdot \arctan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
    \nl 
    \off{1277951}
    +\ln 
    \(-
      \(\sqrt{2}\cdot x
      \)
      +x^{2}
      +1
    \)
    -\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
  \)
\)
/8
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**2+x**4),x);}
$$\displaylines{\qdd
\(2\cdot 
  \sqrt{3}\cdot \arctan 
  \(\frac{2\cdot x
          -1}{
          \sqrt{3}}
  \)
  +2\cdot 
  \sqrt{3}\cdot \arctan 
  \(\frac{2\cdot x
          +1}{
          \sqrt{3}}
  \)
  \nl 
  \off{327680}
  -3\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  +3\cdot \ln 
  \(x^{2}
    +x
    +1
  \)
\)
/12
\nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(sin x**2/x,x);}
$$\displaylines{\qdd
\frac{-ci
      \(2\cdot x
      \)
      +\ln 
      \(x
      \)
      }{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);}
$$\displaylines{\qdd
\int 
\frac{\cos 
      \(\frac{\xi }{
              \sin 
              \(x
              \)
              }
      \)
      \cdot \cos 
      \(x
      \)
      \cdot x}{
      \sin 
      \(x
      \)
      ^{2}}\,dx
\cr}$$
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tri.tst0000644000175000017500000000452611526203062022643 0ustar  giovannigiovanni% load tri;

global '(textest!*);

symbolic procedure texexa(code);
   begin
     prin2 "\TRIexa{"; prin2 textest!*;
     if !*TeXindent then prin2 "}{TeXindent}{" else
     if !*TeXbreak  then prin2 "}{TeXBreak}{" else
     if !*TeX then prin2 "TeX" else prin2 "}{---}{";
     if !*TeXbreak then prin2 tolerance!* else prin2 "---";
     prin2 "}{"; prin2 code; prin2 "}"; terpri()
   end;

algebraic procedure exa(expression,code);
   begin symbolic texexa code; return expression end;

% ----------------------------------------------------------------------
% Examples from the Integrator Test File
% ----------------------------------------------------------------------

symbolic(textest!*:="Integration");

texsetbreak(120,1000);

on texindent;

off echo;

% out "log/tritst.tex";

exa(int(1+x+x**2,x),
       "int(1+x+x**2,x);");
exa(int(x**2*(2*x**2+x)**2,x),
       "int(x**2*(2*x**2+x)**2,x);");
exa(int(x*(x**2+2*x+1),x),
       "int(x*(x**2+2*x+1),x);");
exa(int(1/x,x),
       "int(1/x,x);");
exa(int((x+1)**3/(x-1)**4,x),
       "int((x+1)**3/(x-1)**4,x);");
exa(int(1/(x*(x-1)*(x+1)**2),x),
       "int(1/(x*(x-1)*(x+1)**2),x);");
exa(int((a*x+b)/((x-p)*(x-q)),x),
       "int((a*x+b)/((x-p)*(x-q)),x);");
exa(int(1/(a*x**2+b*x+c),x),
       "int(1/(a*x**2+b*x+c),x);");
exa(int((a*x+b)/(1+x**2),x),
       "int((a*x+b)/(1+x**2),x);");
exa(int(1/(x**2-2*x+3),x),
       "int(1/(x**2-2*x+3),x);");

% Rational function examples from Hardy, Pure Mathematics, p 253 et seq.

exa(int(1/((x-1)*(x**2+1))**2,x),
       "int(1/((x-1)*(x**2+1))**2,x);");
exa(int(x/((x-a)*(x-b)*(x-c)),x),
       "int(x/((x-a)*(x-b)*(x-c)),x);");
exa(int(x/((x**2+a**2)*(x**2+b**2)),x),
       "int(x/((x**2+a**2)*(x**2+b**2)),x);");
exa(int(x**2/((x**2+a**2)*(x**2+b**2)),x),
       "int(x**2/((x**2+a**2)*(x**2+b**2)),x);");
exa(int(x/((x-1)*(x**2+1)),x),
       "int(x/((x-1)*(x**2+1)),x);");
exa(int(x/(1+x**3),x),
       "int(x/(1+x**3),x);");
exa(int(x**3/((x-1)**2*(x**3+1)),x),
       "int(x**3/((x-1)**2*(x**3+1)),x);");
exa(int(1/(1+x**4),x),
       "int(1/(1+x**4),x);");
exa(int(x**2/(1+x**4),x),
       "int(x**2/(1+x**4),x);");
exa(int(1/(1+x**2+x**4),x),
       "int(1/(1+x**2+x**4),x);");

exa(int(sin x**2/x,x),
       "int(sin x**2/x,x);");
exa(int(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x),
       "int(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);");

% shut "log/tritst.tex";

off tex;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tri.latex0000755000175000017500000010205211526203062023142 0ustar  giovannigiovanni%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%               Typesetting REDUCE output with TeX             %%%%%
%%%%%                       by Werner Antweiler                    %%%%%
%%%%%              University of Cologne Computer Center           %%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\input tridefs
\def\9{\TeX-REDUCE-Interface}
%
% LaTeX Version
%
\documentstyle[twocolumn]{article}
\begin{document}
%
% Titel
%
\title{\Huge A \9}
\author{Werner Antweiler\thanks{All three authors are with:
        Rechenzentrum der Universit\"{a}t zu K\"{o}ln
        (University of Cologne Computer Center),
        Abt. Anwendungssoftware (Application Software
        Department), Robert-Koch-Stra\ss e 10, 5000 K\"{o}ln 41,
        West Germany.}   \\
        Andreas Strotmann\\
        Volker Winkelmann\\
        University of Cologne Computer Center, West Germany}
\date{Revised Version, \today}
\maketitle
%
\section{Introduction}
%
REDUCE is a well known computer algebra system invented by
Anthony C. Hearn. While every effort was made to improve
the system's algebraic capabilities, the readability of the
output remained poor by modern typesetting standards.
Although a pretty-printer is already incorporated in REDUCE,
the output is produced only in line-printer quality.
The simple idea to produce high quality output from REDUCE
is to link REDUCE with Donald E. Knuth's famous \TeX\ typesetting
language. This draft reviews our efforts in this direction.
Our major goals we pursue with TRI are:
\begin{itemize}
\item  We want to produce REDUCE-output in typesetting quality.
\item  The intermediate files (\TeX-input files) should be easy to edit.
       The reason is that it is likely that the proposed
       line-breaks are sub-optimal from the user's point of view.
\item  We apply a \TeX-like algorithm which ``optimizes''
       the line-breaking over the whole expression. This differs
       fundamentally from the standard left-to-right,
       one-line look-ahead
       pretty-printers of REDUCE, LISP and the like.
\end{itemize}
We introduce a program written in RLISP\footnote{the REDUCE
implementation language, an extended Standard LISP with an
ALGOL-like syntax.} which typesets REDUCE
formulas with \TeX. Our \9 incorporates three
levels of \TeX\ output: without line breaking, with line breaking,
and with line breaking plus indentation. While speed
without line breaking is comparable to that achieved with
REDUCE's pretty-printer, line breaking consumes much more CPU time.
Nevertheless, we reckon with a cost increase due to line breaking
which is almost linear in the length of the expression to be broken.
Our line breaking algorithm mimics \TeX's line breaking in a
rather rudimentary fashion.
This paper deals with some of the ideas and algorithms we have
programmed and it summarizes some of the experiments we have made
with our program.
Furthermore, at the end of this paper we provide a small user's manual
which gives a short introduction to the use of our \9.
For simplicity's sake the name ``\9'' will be abbreviated to ``TRI''
in this paper.
%
\section{From REDUCE to \TeX: basic concepts}
%
The function {\tt TeXvarpri} is the interface to the algebraic
portion of REDUCE. It first calls a function named {\tt makeprefix}.
Its job is to change a REDUCE algebraic expression to a standard
prefix list while retaining the tree structure of the whole expression.
After this has been done, the
new intermediate expression is passed to the most important module
of TRI: the {\tt maketag/makefunc}-family of functions.
These functions recursively expand the structured list
(or operator tree) into a flat list, translating each REDUCE symbol or
expression into so-called \TeX-items on passing by.
For that reason, the resulting list is called the \TeX-item list.
If the simple \TeX-mode (without line breaking) was chosen, this list
is then printed immediately without further considerations.
Translation and printing this way is almost as fast as with
the standard REDUCE pretty printer.\par
When line-breaking has been enabled things get a bit more complicated.
The greatest effort with TRI was to implement the line-breaking
algorithm. More than half of the entire TRI code deals with this
task.
The ultimate goal is to add some ``break items'', i.e. \verb|\nl|-%
\TeX-commands\footnote{This is not a \TeX-primitive but a TRI-specific
\TeX-macro command which expands into a lot of stuff.},
marking --- in a certain way --- optimal line-breaks.
Additionally, these break items can be followed immediately by
``indentation items'', i.e. \verb|\OFF{...}| \TeX-commands\footnote{see
previous footnote}, specifying the amount of indentation
(in scaled points) applicable for the next new line.
The problem is to choose the right points where to insert these
special \TeX-items. Therefore, the \TeX-item list undergoes
three further transformation steps.\par
First, the \TeX-item list gets enlarged by so-called ``glue items''.
Glue items are two-element lists, where the first element is a width
info and the second element is a penalty info.
The width is determined according to the class of the two \TeX-items
to the left and to the right. Each \TeX-item is associated with
one out of eight classes. Following Knuth's \TeX book [Knu86],
these classes are ORD (for ordinary items),
LOP (for large operators such as square roots),
BIN and REL (for binary and relational operators), OPN and CLO (for
opening and closing parentheses), PCT (for punctuation) and finally
INN (for ``inner'' items such as \TeX-brackets and -macros).
The data for the width information is stored in a matrix.
Therefore, for each pair of classes it is easy to determine how much
(if any) space should be inserted between two consecutive \TeX-items.
\par
The ``penalty'' is
a value in the range of $-10000\ldots+10000$ indicating a mark-up on a
potential break-point, thus determining if this point is a 
fairly good (if negative) or bad (if positive) choice.
The amount of penalty depends heuristically
(a) on the kind of \TeX-items surrounding the glue item,
(b) on the bracket nesting, and finally
(c) on special characteristics.\footnote{For example, the plus-  and
the difference operator have special impact on the amount of
penalty. These operators are considered as extremely good places
for breaking up a line.}\par
During the second level, the \TeX-item list is transformed
into a so-called breaklist consisting of {\em active} and
{\em passive} nodes.
A passive node is simply a width info giving the total width of 
\TeX-items not interspersed by glue items. On the other hand,
active nodes are glue items enlarged by a third element, the
offset info, indicating an indentation level which is used later
for computing the actual amount of indentation.
Active nodes are used as potential breakpoints.
Moreover, while creating the breaklist, the \TeX-item list will be
modified if necessary according to the length of fractions and square
roots which cannot be broken if retained in their ``classical''
form. Hence fractions look like {\tt (...)/(...)} if they don't fit
into a single line, especially in the case of large
polynomial fractions.\par
The third and most important level is the line-breaking algorithm
itself. The idea how to break lines is based
on the article by Knuth/Plass(1981). Line-breaking can occur at
active nodes only. So, you can loop through the breaklist considering
all potential break-points. But in order to find a suitable way
in a reasonable amount of time you have to limit the number of
potential breakpoints considered. This is performed by associating
a ``badness'' with each potential breakpoint, describing how
good looking or bad looking a line turns out.
If the badness is less than
a given amount of ``tolerance'' --- as set by the user --- 
then an active node is considered to be feasible and becomes
a delta node. A delta node is simply an active node enlarged
by four further infos: an identification number for this node,
a pointer to the best feasible break-point (i.e. delta-node)
to come from,%
\footnote{If one were to break the formula at this delta-node, the
best place to start this line  is given by this pointer. Note that
this pointer points backward through the list. When all delta nodes
have been inserted, you start at the very last delta node (which
is always at the end of breaklist) and skip backward from one
delta node to the next delta node pointed at. Thus, you find the
best way to break up the list.}
the total amount of demerits (a compound value derived from
badness and penalty) accumulated so far, and a value indicating
the amount of indentation applied to a new line beginning at this
node.
When the function dealing with line-breaking has stepped through
the list, the breakpoints will have been determined.
Afterwards all glue items (i.e. active nodes)
are deleted from the \TeX-item list while break- and indentation-%
items for those nodes marked as break-points are inserted.
\par
Finally the \TeX-item list is printed with regular ASCII-characters.
The readabiltiy of the intermediate output is low,
but it should be quite good enough for users to do some final
editing work.
Nevertheless, the nesting structure of the term is kept
visible when printed, so it will be easy to distinguish between
parenthesis levels simply by considering the amount of indentation.
% ----------------------------------------------------------------------
\section{Postprocessing with the module ``tridefs.tex''}
% ----------------------------------------------------------------------
When a \TeX-output file has been created with TRI it has to be
processed by \TeX\ itself. But before you run \TeX\ you should make sure
the file looks the way you want it. Sometimes you will 
find it necessary to add some \TeX-code of your own or delete some
other \TeX-code. This is also the right time to
check the line breaks marked by \verb|\nl|-commands.
This job is up to you before you finally run \TeX.\par
During the \TeX-run the sizes of brackets are determined. This task is
not done by TRI. In order to produce proper sized brackets
we put some \verb|\left(| and \verb|\right)| \TeX-commands
where brackets are opened or closed. A new problem arises when
an expression has been broken up into several lines. Since, for every
line, the number of \verb|\left(| and \verb|\right)|
\TeX-commands must match
but bracketed expressions may start in one line and end in another,
we have to insert the required number of ``dummy'' parentheses
(i.e.  \verb|\right.| and \verb|\left.| \TeX-commands)
at the end of the current line and the beginning of the following line.
This task is handled by the \verb|\nl|-\TeX-macro.\par
There is a caveat against this method.
Since opening and closing brackets
needn't lie in the same line, it is possible that the height of the
brackets can differ although they should correspond in height. That will
happen if the height of the text in the opening line has a height
different from the text in the closing line. We haven't found a 
way of tackling this problem yet, but we think it is possible to program
a small \TeX-macro for this task.\par
There is at least one more line of \TeX-code you have to
insert by hand into the \TeX-input file produced by TRI. This line runs
\begin{verbatim}
\input tridefs
\end{verbatim}
and inputs the module {\tt tridefs.tex} into the file. This is necessary
because otherwise \TeX\ won't know how to deal with our macro calls.
If you use the \TeX-input file as a ``stand-alone'' file, don't
forget a final \verb|\bye| at the end of the text. If you use
code produced by TRI as part of a larger text then simply put
the input-line just at the beginning of your text.
%
\section{Experiments}
%
We have tested TRI on a Micro-VAX operating under ULTRIX,
with no other users working during this phase in order to minimize
interference with other processes, e.g., caused by paging.
The TRI code has been compiled with the PSL~3.4 compiler.
The following table presents results obtained with a small number of
different terms. All data were measured in CPU-seconds
as displayed by LISP's TIME-facility.
For expressions where special packages such as {\tt solve} and {\tt int}
were involved we have taken only effective output-time, i.e. the time
consumption caused by producing the output and not by calculating
the algebraic result.\footnote{That means we assigned the result of an
evaluation to an itermediate variable, and then we printed this
intermediate variable. Thus we could eliminate the time overhead
produced by ``pure'' evaluation. Nevertheless, in terms of effective
interactive answering time, the sum of evaluation and printing time
might be much more interesting than the ``pure'' printing time.
In such a context the percentage overhead caused by printing is
the critical point. But since we talk about printing we decided
to document the ``pure'' printing time.} First we display
the six expressions we have tested.\par
$$(x+y)^{12}\eqno(1)$$
$$(x+y)^{24}\eqno(2)$$
$$(x+y)^{36}\eqno(3)$$
$$(x+y)^{16}/(v-w)^{16}\eqno(4)$$
$$solve((1+\xi)x^2-2\xi x+\xi,x)\eqno(5)$$
$$solve(x^3+x^2\mu+\nu,x)\eqno(6)$$
The following table shows the results:
%
\medskip
\begin{center}
{\tt
\begin{tabular}{|c|r|r|r|r|} \hline
{\small\rm No.}&{\small\rm normal}&{\small\rm TeX}&
{\small\rm Break}&{\small\rm Indent}\\
\hline
1& 0.65& 0.75& 3.30& 3.37\\
2& 1.38& 1.79&11.81&12.10\\
3& 2.31& 3.11&19.33&19.77\\
4& 1.87& 2.26&11.78& 9.64\\
5& 0.46& 0.75& 0.90& 0.88\\
6& 4.52&21.52&31.34&29.78\\
\hline
\end{tabular}
}
\medskip
\end{center}
%
This short table should give you an impression of the
performance of TRI. It goes without saying that on other machines
results may turn out which are quite different from our results. But our
intention is to show the relative and not the absolute performance.
Note that printing times are a function of expression complexity,
as shown by rows three and six.
% ----------------------------------------------------------------------
\section{User's Guide to the TRI}
% ----------------------------------------------------------------------
If you intend to use TRI you are required to load the compiled code.
This can be performed with the command
\begin{verbatim}
load!-package 'tri;
\end{verbatim}
During the load, some default initializations are performed. The
default page width is set to 15 centimeters, the tolerance for
line breaking is set to 20 by default. Moreover, TRI is enabled
to translate greek names, e.g. TAU or PSI, into equivalent \TeX\
symbols, e.g. $\tau$ or $\psi$, respectively. Letters are printed
lowercase as defined through assertion of the set LOWERCASE. The whole
operation produces the following lines of output
\begin{verbatim}
% TeX-REDUCE-Interface 0.50
% set GREEK asserted
% set LOWERCASE asserted
% \hsize=150mm
% \tolerance 20
\end{verbatim}
Make sure you have at least version 0.50 installed at your site.
Now you can switch the three TRI modes on and off as you like.
You can use the switches alternatively and incrementally.
That means you have to switch on TeX for receiving standard
\TeX-output, or TeXBreak to receive broken \TeX-output, or
TeXIndent to receive broken  \TeX-output plus indentation.
More specifically, if you switch off {\tt TeXBreak} you implicitly quit
{\tt TeXIndent}, too, or, if you switch off {\tt TeX}, you
implicitly quit {\tt TeXBreak} and, consequently, {\tt TeXIndent}.\par
The most crucial point in defining how TRI breaks multiple lines
of \TeX-code is your choice of the page width and the tolerance.
As mentioned earlier, ``tolerance'' is related to \TeX's famous
line-breaking algorithm. The value of ``tolerance'' determines which
potential breakpoints are considered feasible and which are not. The
higher the tolerance, the more breakpoints become feasible as determined
by the value of ``badness'' associated with each breakpoint. Breakpoints
are considered feasible if the badness is less than the tolerance.
You can easily change the tolerance using
\begin{verbatim}
TeXtolerance(tolerance);
\end{verbatim}
where the {\em tolerance} is a positive integer in the closed interval
$[0,10000]$.
A tolerance of 0 means that actually no breakpoint will be considered
feasible (except those carrying a negative penalty), while a value
of 10000 allows any breakpoint to be considered feasible.
Obviously, the choice of a tolerance has a great impact on the time
consumption of our line-breaking algorithm since time consumption
increases in proportion to the number of feasible breakpoints.
So, the question is what values to choose. For line-breaking without
indentation, suitable values for the tolerance lie between 10 and 100.
As a rule of thumb, you should use higher values the deeper the term
is nested --- if you can estimate. If you use indentation, you have to
use much higher tolerance values. This is necessary because badness
is worsened by indentation. Accordingly, TRI has to try harder to find
suitable places where to break. Reasonable values for tolerance
here lie between 700 and 1500. A value of 1000 should be your first
guess. That will work for most expressions in a reasonable amount of
time.\par
The page width of the \TeX\ output page,
measured in millimeters\footnote{You can
also specify page width in scaled points (sp).
Note: 1~pt = 65536~sp = 1/72.27~inch. The function automatically chooses
the appropiate dimension according to the size: all values greater than
400 are considered to be scaled points.}, can be changed by using
\begin{verbatim}
TeXpagewidth(page-width);
\end{verbatim}
You should choose a page width according to your purposes,
but allow a few centimeters for errors in TRI's attempt to
emulate \TeX's metric.
For example, specify 140 millimeters for an effective page width of
150 or 160 millimeters. That way you have a certain safety-margin to
the borders of the page.\par
Sometimes you want to add your own translations for REDUCE-symbols
to be mapped to \TeX-items.
For such a task, TRI provides a function named
{\tt TeXlet} which binds any REDUCE-symbol to one of the predefined
\TeX-items. A call to this function has the following syntax:
\begin{verbatim}
TeXlet(REDUCE-symbol,TeX-item)
\end{verbatim}
Three examples show how to do it right:
\begin{verbatim}
TeXlet(velocity,'!v);
TeXlet(gamma,"\Gamma ");
TeXlet(acceleration,"\vartheta ");
\end{verbatim}
Besides this method of single assertions you can choose to assert
one of (currently) two standard sets providing substitutions
for lowercase and greek letters. These sets are loaded by default.
You can switch these sets on or off using the functions
\begin{verbatim}
TeXassertset setname;
TeXretractset setname;
\end{verbatim}
where the setnames {\tt GREEK} and {\tt LOWERCASE}
are currently defined and available.
So far you have learned only how to connect REDUCE-atoms with predefined
\TeX-items but not how to create new \TeX-items itself. We provide a
way for adding standard \TeX-items of any class {\tt ORD, BIN, REL,
OPN, CLO, PCT} and {\tt LOP} except for class {\tt INN} which is
reserved for internal use by TRI only. You can call the function
\begin{verbatim}
TeXitem(item,class,list-of-widths)
\end{verbatim}
e.g. together with a binding
\begin{verbatim}
TeXitem("\nabla ",ORD,
        {546135,437818,377748});
TeXlet(NABLA,"\nabla ");
\end{verbatim}
where {\em item} is a legal \TeX-code name\footnote{Please note that
any \TeX-name ending with a letter must be followed by a blank
to prevent interference with letters of following \TeX-items.
Note also that you can legalize a name by defining it as a \TeX-macro
and declaring its width.},
{\em class} is one of seven classes (see above) and {\em list-of-widths}
is a non-empty list of elements, each one representing the width of
the item in successive super-/subscript depth levels.
That means that the first entry is the width in display mode,
the second stands for scriptstyle and the third stands for
scriptscriptstyle in \TeX-terminology.
Starting with version 0.50, all arguments can be supplied without
quotation marks, i.e., LISP notation is no longer required
but still possible.\par
But how can you retrieve the width information required?
For this purpose we provide a small interactive \TeX\ facility
called {\tt redwidth.tex}.
It repeatedly prompts you for the \TeX-items for which you want
to retrieve the width information.\par
Finally, another command is supplied which displays all
information stored about a specific \TeX-item.
If, for example, you  call
\begin{verbatim}
TeXdisplay(NABLA);
\end{verbatim}
TRI will respond with
\begin{verbatim}
% TeX item \nabla  is of class ORD and
                 has following widths:
% 8.333358pt  6.680572pt  5.763977pt 
\end{verbatim}
%
\section{Examples}
%
Some examples shall demonstrate the capabilities of TRI.
For each example we state (a) the REDUCE command (i.e.
the input), (b) the tolerance if it differs from the default, and
(c) the output as produced in a \TeX\ run. The examples are
displayed at the end of this article.\par
% 
\section{Caveats}
% 
Techniques for printing mathematical expressions are available
everywhere. TRI adds only a highly specialized version for
most REDUCE output. The emphasis is on the word {\em most}.
One major caveat is that we cannot print SYMBOLIC-mode output
from REDUCE. This could be done best in a WEB-like programming-plus-%
documentation style. Nevertheless, as Knuth's WEB is allready available
for PASCAL and C, hopefully someone will write a LISP-WEB or a
REDUCE-WEB as well.\par
\LaTeX\ users will be disappointed that we have not mentioned yet if and
how TRI co-operates with \LaTeX. Nevertheless, TRI can be used
together with \LaTeX, as this document proves. But there are some
important restrictions. First, read in the module ``tridefs.tex''
at the very beginning of a \LaTeX-run, before you apply any
\LaTeX-specific command. Furthermore, the \TeX-macros used
in this module {\em do} interfere with \LaTeX's own macros.
You cannot use \LaTeX's \verb|\(|, \verb|\)|, \verb|\[| and \verb|\]|
commands while you are using ``tridefs.tex''. If you avoid to
use them you should be able to run TRI with \LaTeX\ smoothly.
\par
Whenever you discover a bug in our program please let us
know. Send us a short report accompanied by an output listing.%
\footnote{You can reach us via electronic mail at the following
address: reduce@rrz.uni-koeln.de} We will try to fix the error.
% 
\section{Distribution}
% 
The whole TRI package consists of following files:
\begin{itemize}
\item {\tt tri.latex}: This text as a \TeX-input file.
\item {\tt tri.tex}: A long version of this report, where we explain
      our breaking algorithm thoroughly.
\item {\tt tri.red}: This is the REDUCE-LISP source code
      for TRI (approximately 58 KBytes of code).
\item {\tt tridefs.tex}: The \TeX-input file to be used together with
      output from TRI.
\item {\tt redwidth.tex}: This is the \TeX-input file for interactive
      determination of \TeX-item widths.
\item {\tt tritest.red}: Run this REDUCE file to check if TRI works
      correctly.
\item {\tt tritest.tex}: When you have run the file {\tt tritest.red},
      just make a \TeX\ run with this file to see all the nice things
      TRI is able to produce.
\end{itemize}
You can obtain TRI package from a network library at The
RAND Corporation, Santa Monica, Ca./USA.
Simply send a note {\tt send index} to the network address
{\tt reduce-netlib@rand.org} and you will receive a description
on how to use the REDUCE netlib followed by a directory.
Specific files may be requested with the command
{\tt send }{\em library file}, where {\em library} is one the
catalogues containing the different REDUCE packages, and {\em file}
is the name of a particular file. For example, you can use
the message {\tt send tex tri.red} to obtain the RLISP-code of
the \9.
% ----------------------------------------------------------------------
\begin{thebibliography}{Knu88}
\bibitem[Ant86]{an:be}Antweiler, W.; Strotmann, A.; Pfenning, Th.;
        Winkelmann, V.: {\em Zwischenbericht \"{u}ber den Status der
        Arbeiten am REDUCE-\TeX-Anschlu\ss.}
        Internal Paper, Rechenzentrum an der Universit\"{a}t
        zu K\"{o}ln, November 1986.
\bibitem[Ant89]{an:Ab}Antweiler, W.: {\em A \TeX{}-REDUCE-Interface.}
        Arbeits\-bericht RRZK 8901 des Regionalen Rechen\-zentrums an der
        Uni\-versi\-t\"{a}t zu K\"{o}ln, Februar 1989.
\bibitem[Fat87]{fa:Te}Fateman, Richard J.:
        {\em\TeX\ Output from MACSYMA-like Systems.}
        ACM SIGSAM Bulletin, Vol. 21, No. 4, Issue \#82, pp. 1--5,
        November 1987.
\bibitem[Knu81]{kn:br}Knuth, Donald E.; Plass, Michael F.:
        {\em Breaking Paragraphs into Lines.}
        Software---Practice and Experience, Vol. 11,
        pp. 1119--1184, 1981.
\bibitem[Knu86]{kn:Te}Knuth, Donald E.: {\em The \TeX\-book.}
        Addison-Wesley, Readings/Ma. Sixth printing, 1986.
\bibitem[Hea87]{he:RE}Hearn, Anthony C.: {\em REDUCE User's Manual,
        Version 3.3.} The RAND Corporation, Santa Monica, Ca.,
        July 1987.
\end{thebibliography}
%
%
\onecolumn
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%                                                              %%%%%
%%%%%                    Examples for the TRI                      %%%%%
%%%%%                                                              %%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
\TRIexa{Standard}{TeXindent}{250}{\verb|(x+y)**16/(v-w)**16|}
$$\displaylines{\qdd
\(x^{16}
  +16\cdot x^{15}\cdot y
  +120\cdot x^{14}\cdot y^{2}
  +560\cdot x^{13}\cdot y^{3}\nl 
  \OFF{327680}
  +1820\cdot x^{12}\cdot y^{4}
  +4368\cdot x^{11}\cdot y^{5}
  +8008\cdot x^{10}\cdot y^{6}\nl 
  \OFF{327680}
  +11440\cdot x^{9}\cdot y^{7}
  +12870\cdot x^{8}\cdot y^{8}
  +11440\cdot x^{7}\cdot y^{9}\nl 
  \OFF{327680}
  +8008\cdot x^{6}\cdot y^{10}
  +4368\cdot x^{5}\cdot y^{11}
  +1820\cdot x^{4}\cdot y^{12}\nl 
  \OFF{327680}
  +560\cdot x^{3}\cdot y^{13}
  +120\cdot x^{2}\cdot y^{14}
  +16\cdot x\cdot y^{15}
  +y^{16}
\)
/\nl 
\(v^{16}
  -16\cdot v^{15}\cdot w
  +120\cdot v^{14}\cdot w^{2}
  -560\cdot v^{13}\cdot w^{3}\nl 
  \OFF{327680}
  +1820\cdot v^{12}\cdot w^{4}
  -4368\cdot v^{11}\cdot w^{5}
  +8008\cdot v^{10}\cdot w^{6}
  -11440\cdot v^{9}\cdot w^{7}\nl 
  \OFF{327680}
  +12870\cdot v^{8}\cdot w^{8}
  -11440\cdot v^{7}\cdot w^{9}
  +8008\cdot v^{6}\cdot w^{10}
  -4368\cdot v^{5}\cdot w^{11}\nl 
  \OFF{327680}
  +1820\cdot v^{4}\cdot w^{12}
  -560\cdot v^{3}\cdot w^{13}
  +120\cdot v^{2}\cdot w^{14}
  -16\cdot v\cdot w^{15}
  +w^{16}
\)
\Nl}$$
\TRIexa{Integration}{TeX}{-}{\verb|int(1/(x**3+2),x)|}
$$
-
\(\frac{2^{\frac{1}{
                 3}}\cdot 
        \(2\cdot 
          \sqrt{3}\cdot 
          \arctan 
          \(\frac{2^{\frac{1}{
                           3}}
                  -2\cdot x}{
                  2^{\frac{1}{
                           3}}\cdot 
                  \sqrt{3}}
          \)
          +
          \ln 
          \(2^{\frac{2}{
                     3}}
            -2^{\frac{1}{
                      3}}\cdot x
            +x^{2}
          \)
          -2\cdot 
          \ln 
          \(2^{\frac{1}{
                     3}}
            +x
          \)
        \)
        }{
        12}
\)
$$
\TRIexa{Integration}{TeXindent}{1000}%
{\verb|int(1/(x{*}{*}4+3*x{*}{*}2-1,x)|}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(3\cdot 
    \sqrt{
          \sqrt{13}
          -3}\cdot 
    \sqrt{13}\cdot 
    \ln 
    \(-
      \(\sqrt{
              \sqrt{13}
              -3}\cdot 
        \sqrt{2}
      \)
      +2\cdot x
    \)
    \nl 
    \OFF{2260991}
    -3\cdot 
    \sqrt{
          \sqrt{13}
          -3}\cdot 
    \sqrt{13}\cdot 
    \ln 
    \(\sqrt{
            \sqrt{13}
            -3}\cdot 
      \sqrt{2}
      +2\cdot x
    \)
    \nl 
    \OFF{2260991}
    +13\cdot 
    \sqrt{
          \sqrt{13}
          -3}\cdot 
    \ln 
    \(-
      \(\sqrt{
              \sqrt{13}
              -3}\cdot 
        \sqrt{2}
      \)
      +2\cdot x
    \)
    \nl 
    \OFF{2260991}
    -13\cdot 
    \sqrt{
          \sqrt{13}
          -3}\cdot 
    \ln 
    \(\sqrt{
            \sqrt{13}
            -3}\cdot 
      \sqrt{2}
      +2\cdot x
    \)
    \nl 
    \OFF{2260991}
    +6\cdot 
    \sqrt{
          \sqrt{13}
          +3}\cdot 
    \sqrt{13}\cdot 
    \arctan 
    \(\frac{2\cdot x}{
            \sqrt{
                  \sqrt{13}
                  +3}\cdot 
            \sqrt{2}}
    \)
    \nl 
    \OFF{2260991}
    -26\cdot 
    \sqrt{
          \sqrt{13}
          +3}\cdot 
    \arctan 
    \(\frac{2\cdot x}{
            \sqrt{
                  \sqrt{13}
                  +3}\cdot 
            \sqrt{2}}
    \)
  \)
\)
/104
\Nl}$$
\TRIexa{Solving Equations}{TeXindent}{1000}%
{\verb|solve(x**3+x**2*mu+nu=0,x)|}
$$\displaylines{\qdd
\{x=
  \[-
    \(\(\(9\cdot 
          \sqrt{4\cdot \mu ^{3}\cdot \nu 
                +27\cdot \nu ^{2}}
          -2\cdot 
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot 
          \sqrt{3}\cdot \nu 
        \)
        ^{\frac{2}{
                3}}\cdot 
        \sqrt{3}\cdot i\nl 
        \OFF{3675021}
        +
        \(9\cdot 
          \sqrt{4\cdot \mu ^{3}\cdot \nu 
                +27\cdot \nu ^{2}}
          -2\cdot 
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot 
          \sqrt{3}\cdot \nu 
        \)
        ^{\frac{2}{
                3}}\nl 
        \OFF{3675021}
        +2\cdot 
        \(9\cdot 
          \sqrt{4\cdot \mu ^{3}\cdot \nu 
                +27\cdot \nu ^{2}}
          -2\cdot 
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot 
          \sqrt{3}\cdot \nu 
        \)
        ^{\frac{1}{
                3}}\cdot \nl 
        \OFF{3675021}
        2^{\frac{1}{
                 3}}\cdot 3^{\frac{1}{
                                   6}}\cdot 
        \mu 
        -2^{\frac{2}{
                  3}}\cdot 
        \sqrt{3}\cdot 3^{\frac{1}{
                                  3}}\cdot 
        i\cdot \mu ^{2}
        +2^{\frac{2}{
                  3}}\cdot 3^{\frac{1}{
                                    3}}\cdot 
        \mu ^{2}
      \)
      /\nl 
      \OFF{3347341}
      \(6\cdot 
        \(9\cdot 
          \sqrt{4\cdot \mu ^{3}\cdot \nu 
                +27\cdot \nu ^{2}}
          -2\cdot 
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot 
          \sqrt{3}\cdot \nu 
        \)
        ^{\frac{1}{
                3}}\cdot 2^{\frac{1}{
                                  3}}\cdot 
        3^{\frac{1}{
                 6}}
      \)
    \)
  \]
  \CO\nl 
  \OFF{327680}
  x=
  \[\(\(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{2}{
              3}}\cdot 
      \sqrt{3}\cdot i\nl 
      \OFF{2837617}
      -
      \(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{2}{
              3}}\nl 
      \OFF{2837617}
      -2\cdot 
      \(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{1}{
              3}}\cdot \nl 
      \OFF{2837617}
      2^{\frac{1}{
               3}}\cdot 3^{\frac{1}{
                                 6}}\cdot \mu 
      -2^{\frac{2}{
                3}}\cdot 
      \sqrt{3}\cdot 3^{\frac{1}{
                                3}}\cdot i\cdot 
      \mu ^{2}
      -2^{\frac{2}{
                3}}\cdot 3^{\frac{1}{
                                  3}}\cdot 
      \mu ^{2}
    \)
    /\nl 
    \OFF{2509937}
    \(6\cdot 
      \(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}
    \)
  \]
  \CO\nl 
  \OFF{327680}
  x=
  \[\(\(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{2}{
              3}}\nl 
      \OFF{2837617}
      -
      \(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot \nl 
        \OFF{3675021}
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}\cdot \mu 
      +2^{\frac{2}{
                3}}\cdot 3^{\frac{1}{
                                  3}}\cdot 
      \mu ^{2}
    \)
    /\nl 
    \OFF{2509937}
    \(3\cdot 
      \(9\cdot 
        \sqrt{4\cdot \mu ^{3}\cdot \nu 
              +27\cdot \nu ^{2}}
        -2\cdot 
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot 
        \sqrt{3}\cdot \nu 
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}
    \)
  \]
\}
\Nl}$$
\TRIexa{Matrix Printing}{TeX}{--}{%
\verb|mat((1,a-b,1/(c-d)),(a**2-b**2,1,sqrt(c)),((a+b)/(c-d),sqrt(d),1))|
}
$$
\pmatrix{1&a
         -b&
         \frac{1}{
               c
               -d}\cr 
         a^{2}
         -b^{2}&1&
         \sqrt{c}\cr 
         \frac{a
               +b}{
               c
               -d}&
         \sqrt{d}&1\cr 
         }
$$
%
%
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tri.rlg0000644000175000017500000002012211527635055022617 0ustar  giovannigiovanniFri Feb 18 21:28:54 2011 run on win32
% TeX-REDUCE-Interface 0.70
% set greek asserted
% set lowercase asserted
% set Greek asserted
% set Uppercase asserted
% \tolerance 10
% \hsize=150mm
% load tri;

global '(textest!*);



symbolic procedure texexa(code);
   begin
     prin2 "\TRIexa{"; prin2 textest!*;
     if !*TeXindent then prin2 "}{TeXindent}{" else
     if !*TeXbreak  then prin2 "}{TeXBreak}{" else
     if !*TeX then prin2 "TeX" else prin2 "}{---}{";
     if !*TeXbreak then prin2 tolerance!* else prin2 "---";
     prin2 "}{"; prin2 code; prin2 "}"; terpri()
   end;


texexa


algebraic procedure exa(expression,code);
   begin symbolic texexa code; return expression end;


exa


% ----------------------------------------------------------------------
% Examples from the Integrator Test File
% ----------------------------------------------------------------------

symbolic(textest!*:="Integration");


"Integration"


texsetbreak(120,1000);

% \tolerance 1000
% \hsize=120mm


on texindent;



off echo;

\TRIexa{Integration}{TeXindent}{1000}{int(1+x+x**2,x);}
$$\displaylines{\qdd
\frac{x\cdot 
      \(2\cdot x^{2}
        +3\cdot x
        +6
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2*(2*x**2+x)**2,x);}
$$\displaylines{\qdd
\frac{x^{5}\cdot 
      \(60\cdot x^{2}
        +70\cdot x
        +21
      \)
      }{
      105}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*(x**2+2*x+1),x);}
$$\displaylines{\qdd
\frac{x^{2}\cdot 
      \(3\cdot x^{2}
        +8\cdot x
        +6
      \)
      }{
      12}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/x,x);}
$$\displaylines{\qdd
\ln 
\(x
\)
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((x+1)**3/(x-1)**4,x);}
$$\displaylines{\qdd
\frac{3\cdot \ln 
      \(x
        -1
      \)
      \cdot x^{3}
      -9\cdot \ln 
      \(x
        -1
      \)
      \cdot x^{2}
      +9\cdot \ln 
      \(x
        -1
      \)
      \cdot x
      -3\cdot \ln 
      \(x
        -1
      \)
      -6\cdot x^{3}
      -2}{
      3\cdot 
      \(x^{3}
        -3\cdot x^{2}
        +3\cdot x
        -1
      \)
      }
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x*(x-1)*(x+1)**2),x);}
$$\displaylines{\qdd
\(\ln 
  \(x
    -1
  \)
  \cdot x
  +\ln 
  \(x
    -1
  \)
  +3\cdot \ln 
  \(x
    +1
  \)
  \cdot x\nl 
  \off{327680}
  +3\cdot \ln 
  \(x
    +1
  \)
  -4\cdot \ln 
  \(x
  \)
  \cdot x
  -4\cdot \ln 
  \(x
  \)
  +2\cdot x
\)
/\nl 
\(4\cdot 
  \(x
    +1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/((x-p)*(x-q)),x);}
$$\displaylines{\qdd
\frac{\ln 
      \(p
        -x
      \)
      \cdot a\cdot p
      +\ln 
      \(p
        -x
      \)
      \cdot b
      -\ln 
      \(q
        -x
      \)
      \cdot a\cdot q
      -\ln 
      \(q
        -x
      \)
      \cdot b}{
      p
      -q}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(a*x**2+b*x+c),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{4\cdot a\cdot c
            -b^{2}}\cdot \atan 
      \(\frac{2\cdot a\cdot x
              +b}{
              \sqrt{4\cdot a\cdot c
                    -b^{2}}}
      \)
      }{
      4\cdot a\cdot c
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int((a*x+b)/(1+x**2),x);}
$$\displaylines{\qdd
\frac{2\cdot \atan 
      \(x
      \)
      \cdot b
      +\ln 
      \(x^{2}
        +1
      \)
      \cdot a}{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(x**2-2*x+3),x);}
$$\displaylines{\qdd
\frac{\sqrt{2}
      \cdot \atan 
      \(\frac{x
              -1}{
              \sqrt{2}}
      \)
      }{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/((x-1)*(x**2+1))**2,x);}
$$\displaylines{\qdd
\(\atan 
  \(x
  \)
  \cdot x^{3}
  -\atan 
  \(x
  \)
  \cdot x^{2}
  +\atan 
  \(x
  \)
  \cdot x
  -\atan 
  \(x
  \)
  \nl 
  \off{327680}
  +\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{3}
  -\ln 
  \(x^{2}
    +1
  \)
  \cdot x^{2}
  +\ln 
  \(x^{2}
    +1
  \)
  \cdot x
  -\ln 
  \(x^{2}
    +1
  \)
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{3}\nl 
  \off{327680}
  +2\cdot \ln 
  \(x
    -1
  \)
  \cdot x^{2}
  -2\cdot \ln 
  \(x
    -1
  \)
  \cdot x
  +2\cdot \ln 
  \(x
    -1
  \)
  -x^{3}
  -2\cdot x
  +1
\)
/\nl 
\(4\cdot 
  \(x^{3}
    -x^{2}
    +x
    -1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-a)*(x-b)*(x-c)),x);}
$$\displaylines{\qdd
\(\ln 
  \(a
    -x
  \)
  \cdot a\cdot b
  -\ln 
  \(a
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(b
    -x
  \)
  \cdot a\cdot b\nl 
  \off{327680}
  +\ln 
  \(b
    -x
  \)
  \cdot b\cdot c
  +\ln 
  \(c
    -x
  \)
  \cdot a\cdot c
  -\ln 
  \(c
    -x
  \)
  \cdot b\cdot c
\)
/\nl 
\(a^{2}\cdot b
  -a^{2}\cdot c
  -a\cdot b^{2}
  +a\cdot c^{2}
  +b^{2}\cdot c
  -b\cdot c^{2}
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{-\ln 
      \(a^{2}
        +x^{2}
      \)
      +\ln 
      \(b^{2}
        +x^{2}
      \)
      }{
      2\cdot 
      \(a^{2}
        -b^{2}
      \)
      }
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/((x**2+a**2)*(x**2+b**2)),x);}
$$\displaylines{\qdd
\frac{\atan 
      \(\frac{x}{
              a}
      \)
      \cdot a
      -\atan 
      \(\frac{x}{
              b}
      \)
      \cdot b}{
      a^{2}
      -b^{2}}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/((x-1)*(x**2+1)),x);}
$$\displaylines{\qdd
\frac{2\cdot \atan 
      \(x
      \)
      -\ln 
      \(x^{2}
        +1
      \)
      +2\cdot \ln 
      \(x
        -1
      \)
      }{
      4}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x/(1+x**3),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{3}\cdot \atan 
      \(\frac{2\cdot x
              -1}{
              \sqrt{3}}
      \)
      +\ln 
      \(x^{2}
        -x
        +1
      \)
      -2\cdot \ln 
      \(x
        +1
      \)
      }{
      6}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**3/((x-1)**2*(x**3+1)),x);}
$$\displaylines{\qdd
\(-4\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  \cdot x
  +4\cdot \ln 
  \(x^{2}
    -x
    +1
  \)
  +9\cdot \ln 
  \(x
    -1
  \)
  \cdot x\nl 
  \off{327680}
  -9\cdot \ln 
  \(x
    -1
  \)
  -\ln 
  \(x
    +1
  \)
  \cdot x
  +\ln 
  \(x
    +1
  \)
  -6\cdot x
\)
/\nl 
\(12\cdot 
  \(x
    -1
  \)
\)
\Nl}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(-2\cdot \atan 
    \(\frac{\sqrt{2}
            -2\cdot x}{
            \sqrt{2}}
    \)
    +2\cdot \atan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
    -\ln 
    \(-
      \sqrt{2}\cdot x
      +x^{2}
      +1
    \)
    +\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
  \)
\)
/8
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x**2/(1+x**4),x);}
$$\displaylines{\qdd
\(\sqrt{2}\cdot 
  \(-2\cdot \atan 
    \(\frac{\sqrt{2}
            -2\cdot x}{
            \sqrt{2}}
    \)
    +2\cdot \atan 
    \(\frac{\sqrt{2}
            +2\cdot x}{
            \sqrt{2}}
    \)
    +\ln 
    \(-
      \sqrt{2}\cdot x
      +x^{2}
      +1
    \)
    -\ln 
    \(\sqrt{2}\cdot x
      +x^{2}
      +1
    \)
  \)
\)
/8
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(1/(1+x**2+x**4),x);}
$$\displaylines{\qdd
\frac{2\cdot 
      \sqrt{3}\cdot \atan 
      \(\frac{2\cdot x
              -1}{
              \sqrt{3}}
      \)
      +2\cdot 
      \sqrt{3}\cdot \atan 
      \(\frac{2\cdot x
              +1}{
              \sqrt{3}}
      \)
      -3\cdot \ln 
      \(x^{2}
        -x
        +1
      \)
      +3\cdot \ln 
      \(x^{2}
        +x
        +1
      \)
      }{
      12}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(sin x**2/x,x);}
$$\displaylines{\qdd
\frac{-ci
      \(2\cdot x
      \)
      +\ln 
      \(x
      \)
      }{
      2}
\cr}$$
\TRIexa{Integration}{TeXindent}{1000}{int(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x);}
$$\displaylines{\qdd
\int {\frac{\cos 
            \(\frac{\xi }{
                    \sin 
                    \(x
                    \)
                    }
            \)
            \cdot \cos 
            \(x
            \)
            \cdot x}{
            \sin 
            \(x
            \)
            ^{2}}\,dx}
\cr}$$


Time for test: 31 ms
@@@@@ Resources used: (0 0 13 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tritest.tex0000644000175000017500000000265711526203062023534 0ustar  giovannigiovanni\relax
% ----------------------------------------------------------------------
% The REDUCE-TeX-Interface Test Package
% ----------------------------------------------------------------------
% File:    TRITEST.TEX
% Author:  Werner Antweiler, RRZK/UCCC, Cologne/West Germany
% Date:    01-Sep-88
% Version: 1.4
% This module defines macros to be used for processing output produced
% by a testing run with the REDUCE-TeX-Interface
% ----------------------------------------------------------------------
\input redtri
\hsize=175mm
\font\caps=cmcsc10
\font\smallcaps=cmcsc10 at 8pt
\def\today{\ifcase\month\or January\or February\or March\or April\or May\or
June\or July\or August\or September\or October\or November\or December\fi
\space\number\day,\space\number\year}
% verbatim
\def\uncatcodespecials{\def\do##1{\catcode`##1=12}\dospecials\do\"}
\def\setupverbatim{\tt\Obeylines\uncatcodespecials\obeyspaces}
\def\newlinepar{~\par}
{\catcode`\^^M=\active %
  \gdef\Obeylines{\catcode`\^^M=\active\def^^M{\newlinepar}}}%
{\obeyspaces\global\let =\ }
\def\verbatim{\par\begingroup\parskip=0pt plus 1pt
              \setupverbatim\doverbatim}
\def\verb{\begingroup\setupverbatim\doverb}
\def\doverb#1{\def\next##1#1{##1\endgroup}\next}
% ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- ** -- **
\centerline{\bf Tests for the REDUCE-\TeX-Interface}\bigskip
\centerline{\rm compiled by W. Antweiler, \today}\bigskip\bigskip
\input tritst
\bye
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/redtri.tex0000644000175000017500000000512511526203062023320 0ustar  giovannigiovanni\relax
% ======================================================================
%    T h e  T e X - R e d u c e - I n t e r f a c e:   TeX-Module
% ======================================================================
% (C) 1987 by Rechenzentrum der Universitaet zu Koeln
%             (University of Cologne Computer Center)
%             Abt. Anwendungssoftware
%             (Application Software Department)
%             Robert-Koch-Str. 10
%             5000 Koeln 41
%             Federal Republic of Germany
%             e-mail: reduce@rrz.uni-koeln.de
% All rights reserved.  Permission to copy without fee all  or  part  of
% this  software  product is hereby granted provided that the copies are
% not made or distributed for direct commercial  advantage,  this  copy-
% right notice and its date appear,  and notice is given that copying is
% by permission of the authors.  To copy otherwise requires a fee and/or
% specific permission.
% ======================================================================
% 25-Jul-89               Author: Werner Antweiler          Version 0.10
% ======================================================================
%
\def\frac#1#2{{#1\over#2}}
\def\CO{,}\def\<{\langle}\def\>{\rangle}\def\d{\hbox{\rm d}}
\newcount\parenthesis \parenthesis=0 \newcount\n
\def\({\global\advance\parenthesis by1\left(}
\def\){\global\advance\parenthesis by-1\right)}
\def\{{\global\advance\parenthesis by1\left\lbrace}
\def\}{\global\advance\parenthesis by-1\right\rbrace}
\def\[{\relax} % dummy parenthesis
\def\]{\relax} % dummy parenthesis
\def\Loop#1\Repeat{\global\n=0\global\let\body=#1\iterate}
\def\iterate{\body\let\next=\iterate\else\let\next=\relax\fi\next}
\def\ldd{\ifnum\n<\parenthesis\global\advance\n by1
\left.\nulldelimiterspace=0pt\mathsurround=0pt}
\def\rdd{\ifnum\n<\parenthesis\global\advance\n by1
\right.\nulldelimiterspace=0pt\mathsurround=0pt}
\def\nl{\Loop\rdd\Repeat\hfill\cr\qdd\Loop\ldd\Repeat{}}
\def\OFF#1{\hskip#1sp\relax}
\def\off#1{\hskip#1sp\relax}
\def\Nl{\hfill\cr}
\def\qdd{\quad\quad}
% ---------------- special code for TRI examples --------------
\newcount\exacount\exacount=0\font\caps=cmcsc10
\def\Istrut{\vrule height11pt depth4pt width0pt}
\def\TRIexa#1#2#3#4{\global\advance\exacount by1\par\filbreak
{\offinterlineskip
  \vbox{\hrule\hbox to\hsize{\Istrut\vrule
      \hbox to 8mm{\hfil\caps\the\exacount\hfil}\vrule
      \quad\rm#1\hfill\vrule
      \hbox to 32mm{\hfill{\caps Mode: }{\tt #2}\hfill}\vrule
      \hbox to 32mm{\hfill{\caps Tolerance: }{\tt #3}\hfill}\vrule}
    \hrule\hbox to\hsize{\Istrut\vrule\hfill#4\hfill\vrule}\hrule}
}\nobreak}
% End.
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tridefs.tex0000644000175000017500000000512511526203062023467 0ustar  giovannigiovanni\relax
% ======================================================================
%    T h e  T e X - R e d u c e - I n t e r f a c e:   TeX-Module
% ======================================================================
% (C) 1987 by Rechenzentrum der Universitaet zu Koeln
%             (University of Cologne Computer Center)
%             Abt. Anwendungssoftware
%             (Application Software Department)
%             Robert-Koch-Str. 10
%             5000 Koeln 41
%             Federal Republic of Germany
%             e-mail: reduce@rrz.uni-koeln.de
% All rights reserved.  Permission to copy without fee all  or  part  of
% this  software  product is hereby granted provided that the copies are
% not made or distributed for direct commercial  advantage,  this  copy-
% right notice and its date appear,  and notice is given that copying is
% by permission of the authors.  To copy otherwise requires a fee and/or
% specific permission.
% ======================================================================
% 25-Jul-89               Author: Werner Antweiler          Version 0.10
% ======================================================================
%
\def\frac#1#2{{#1\over#2}}
\def\CO{,}\def\<{\langle}\def\>{\rangle}\def\d{\hbox{\rm d}}
\newcount\parenthesis \parenthesis=0 \newcount\n
\def\({\global\advance\parenthesis by1\left(}
\def\){\global\advance\parenthesis by-1\right)}
\def\{{\global\advance\parenthesis by1\left\lbrace}
\def\}{\global\advance\parenthesis by-1\right\rbrace}
\def\[{\relax} % dummy parenthesis
\def\]{\relax} % dummy parenthesis
\def\Loop#1\Repeat{\global\n=0\global\let\body=#1\iterate}
\def\iterate{\body\let\next=\iterate\else\let\next=\relax\fi\next}
\def\ldd{\ifnum\n<\parenthesis\global\advance\n by1
\left.\nulldelimiterspace=0pt\mathsurround=0pt}
\def\rdd{\ifnum\n<\parenthesis\global\advance\n by1
\right.\nulldelimiterspace=0pt\mathsurround=0pt}
\def\nl{\Loop\rdd\Repeat\hfill\cr\qdd\Loop\ldd\Repeat{}}
\def\OFF#1{\hskip#1sp\relax}
\def\off#1{\hskip#1sp\relax}
\def\Nl{\hfill\cr}
\def\qdd{\quad\quad}
% ---------------- special code for TRI examples --------------
\newcount\exacount\exacount=0\font\caps=cmcsc10
\def\Istrut{\vrule height11pt depth4pt width0pt}
\def\TRIexa#1#2#3#4{\global\advance\exacount by1\par\filbreak
{\offinterlineskip
  \vbox{\hrule\hbox to\hsize{\Istrut\vrule
      \hbox to 8mm{\hfil\caps\the\exacount\hfil}\vrule
      \quad\rm#1\hfill\vrule
      \hbox to 32mm{\hfill{\caps Mode: }{\tt #2}\hfill}\vrule
      \hbox to 32mm{\hfill{\caps Tolerance: }{\tt #3}\hfill}\vrule}
    \hrule\hbox to\hsize{\Istrut\vrule\hfill#4\hfill\vrule}\hrule}
}\nobreak}
% End.
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tri.red0000644000175000017500000022030511526203062022576 0ustar  giovannigiovanni% TeX-REDUCE-Interface 0.70
% set GREEK asserted
% set LOWERCASE asserted
% \tolerance 10
% \hsize=150mm
module tri;

% ======================================================================
%           T h e  T e X - R e d u c e - I n t e r f a c e
% ======================================================================
% (C) 1987/1988 by Rechenzentrum der Universitaet zu Koeln
%                  (University of Cologne Computer Center)
%                  Abt. Anwendungssoftware
%                  (Application Software Department)
%                  ATTN: Werner Antweiler
%                  Robert-Koch-Str. 10
%                  5000 Koeln 41
%                  Federal Republic of Germany
%                  E-Mail: reduce@rrz.Uni-Koeln.DE
% This  software  product  has  been  developed by
% WERNER ANTWEILER  at the  University of Cologne Computer Center,  West
% Germany. The TeX-Reduce-Interface  has been totally written in REDUCE-
% LISP.
% ======================================================================
% Authors: Werner Antweiler, Andreas Strotmann, Volker Winkelmann.
% Modifications: David Hartley.
%
% Last Update: 14-Jul-96                                    Version 0.70
% Permission to distribute under BSD License granted by authors January 2009
% ======================================================================


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%
%
%
%
%                              Section Survey
% ----------------------------------------------------------------------
% Section Contents                                                  Page
% ----------------------------------------------------------------------
% 0       Main Procedure (and Interfacing)                             2
% 1       Creating a TeX item list                                     5
% 1.1     Operator Administration Routines                             5
% 1.2     Prefix to Infix Conversion                                   6
% 1.3     Making a TeX item                                            9
% 2       Inserting Glue Items                                        16
% 3       Line Breaking                                               18
% 3.1     Resolving Fraction Expressions                              20
% 3.2     Creating a Break List                                       21
% 3.3     Major Line Breaking Routine                                 23
% 4       TeX-Output Routines                                         28
% 5       User Interface                                              30
% ----------------------------------------------------------------------
% Note: page breaks (form feeds) are indicated by "%ff" lines
%ff
% ----------------------------------------------------------------------
% Section 0: Global Variables, Main Procedure and Interfacing
% ----------------------------------------------------------------------


% IMPORTANT NOTICE FOR REDUCE 3.2 USERS:
% This code was written to run under REDUCE 3.3.   Users  of  REDUCE 3.2
% therefore  have  to change two lines of this code before compiling it:
% 1) the line `switch ...;` must be deleted
% 2) the construct `FOR EACH ... IN ... JOIN ...` must be changed
%    to `FOR EACH ... IN ... CONC ...` because only the latter is
%    accepted by REDUCE 3.2.
% Furthermore, the TRI supports features of REDUCE that are new in ver-
% sion 3.3. You cannot take advantage of them under version 3.2. In
% particular, some of the examples in the accompanying test file may
% fail.

create!-package('(tri),'(contrib misc));

fluid '(
% -----------------+---------------------------------------------------+
% FLUID VARIABLES  | EXPLANATION                                       |
% -----------------+---------------------------------------------------+
  !*tex            % flag to be switched ON and OFF (TeX Output Mode)
  !*texbreak       % flag to be switched ON and OFF (Break Facility)
  !*texindent      % flag to be switched ON and OFF (Indentation Mode)
  texstack!*       % stack to save expressions for an unfilled line
  hsize!*          % total page width in scaled points (sp)
                   % note: 65536sp = 1pt = 1/72.27 inch
  hss!*            % total line stretchability/shrinkability (in sp)
  hww!*            % optimum page fit width (= 3/4 hsize)    (in sp)
  tolerance!*      % value within break points are considered to be
                   % feasible  (range: 0..10000)
  !*lower    % used in REDUCE 3.5 to make everything lower case
% -----------------+---------------------------------------------------+
);

global '(
% ------------------+---------------------------------------------------+
% GLOBAL VARIABLES  | EXPLANATION                                       |
% ------------------+---------------------------------------------------+
  metricu!*         % EXCALC
  indxl!*           % EXCALC
% ------------------+---------------------------------------------------+
);

% declare switches:
switch tex,texbreak,texindent;

% declare switch dependencies:
put('texindent,'simpfg,'((t (progn (setq !*tex t)
                                   (setq !*texbreak t)))  ));
put('texbreak,'simpfg,'((t (setq !*tex t)) ));
put('tex,'simpfg,'((nil (progn (setq !*texbreak nil)
                               (setq !*texindent nil))) ));

symbolic procedure tri!-error(strlst,errclass);
<< for each x in strlst do prin2 x; terpri();
   if errclass='fatal then
      rederr "Aborting."
>>;

% Code called by ASSGNPRI.

symbolic procedure texpri(u,v,w);
   (if x and get(x,'texprifn) then apply3(get(x,'texprifn),u,v,w)
     else texvarpri(u,v,w)) where x = getrtype u;

symbolic procedure texvarpri(u,v,w); % same parameters as above
begin scalar !*lower;
   if w memq '(first only) then texstack!*:=nil;
   if v then for each x in reverse v do u:=list('setq,x,u);
   texstack!* := nconc(texstack!*,mktag(u,0,nil));
   if (w=t) or (w='only) or (w='last) then
   << if !*texbreak then
      << texstack!* := insertglue(texstack!*);
         texstack!* := trybreak(texstack!*,breaklist(texstack!*))
      >>;
      texout(texstack!*,!*texbreak); texstack!*:=nil
   >>;
   %if (null w) or (w eq 'first) then
   %  texstack!* := nconc(texstack!*,list '!\!q!u!a!d! );
   nil
end;
%ff
% The following procedure interfaces to E. Schruefer's EXCALC package.
% Courtesy: E. Schruefer.

put('form!-with!-free!-indices,'texprifn,'texindxpri);

symbolic procedure texindxpri(u,v,w);
   begin scalar metricu,il,dnlist,uplist,r,x,y,z;
     if v then go to a;
     metricu := metricu!*;
     metricu!* := nil;
     il := allind !*t2f lt numr simp0 u;
     for each j in il do
          if atom revalind j
             then uplist := j . uplist
           else dnlist := cadr j . dnlist;
         for each j in intersection(uplist,dnlist) do
             il := delete(j,delete(revalind
                                  lowerind j,il));
         metricu!* := metricu;
     y := flatindxl il;
     r := simp!* u;
     for each j in mkaindxc(y,nil) do
       <>;
     return u;
  a: v := car v;
     y := flatindxl allindk v;
     for each j in if flagp(car v,'antisymmetric) and
                      coposp cdr v then comb(indxl!*,length y)
                    else mkaindxc(y,nil) do
       <>;
      return u
    end;
%ff
% ----------------------------------------------------------------------
% Section 1: Creating a TeX item list
% ----------------------------------------------------------------------
%
% Linearization is performed by expanding REDUCE prefix expressions into
% a so called "TeX item list".  Any TeX item is a readable TeX primitive
% or macro (i.e. a LISP atom), with properties 'CLASS, 'TEXTAG, 'TEXNAME
% and eventually 'TEXPREC, 'TEXPATT and 'TEXUBY bound to them, depending
% on what kind of TeX item it actually is.  (See Section 1.3 for further
% information.)
%    A REDUCE expression is expanded using the two  functions  "mktag"
% and "makefunc". Function "mktag" identifies the operator and is able
% to put some brackets around the expression if necessary. "makefunc" is
% a pattern oriented 'unification' function, which matches the arguments
% of a REDUCE expression in order of appearance with so called 'unifica-
% tion tags',  as explained below.   "mktag" and "makefunc" are highly
% recursive functions.
%    The patterns mentioned above are lists (consisting of 'tags') asso-
% ciated with each REDUCE operator.   A tag is defined as either an atom
% declared  as  a  TeX item  or one of the following 'unification tags':
%    (F)  ............ insert operator
%    (X)  ............ insert non-associative argument
%    (Y)  ............ insert (left/right-) associative argument
%    (Z)  ............ insert superscript/subscript argument
%    (R)  ............ use tail recursion to unify remaining arguments
%                      (associativity depends on previous (X) or (Y) )
%    (L)  ............ insert a list of arguments (eat up all arguments)
%    (M)  ............ insert a matrix (and eat up all arguments)
%    (APPLY ) ... apply function  to remaining argument list
% ----------------------------------------------------------------------

% ----------------------------------------------------------------------
% Section 1.1: Operator Administration Routines
% ----------------------------------------------------------------------

symbolic procedure makeop(op,prec,patt,uby);
<< put(op,'texprec,prec); put(op,'texpatt,patt);
   put(op,'texuby,if uby then (car uby).(cadr uby) else nil.nil)
>>;

symbolic procedure makeops(l);
for each w in l do makeop(car w,cadr w,caddr w,cadddr w);
%ff
makeops('(
%-----------+----------+---------------------+-------------------------+
% Name      |Precedence|Expansion List       |Unary/Binary Interchange |
%-----------+----------+---------------------+-------------------------+
(setq             1     ((x) (f) !\![ (x) !\!]) nil)
(or              30     ((x) (f) (r))           nil)
(and             40     ((x) (f) (r))           nil)
(equal           50     ((x) (f) !\![ (x) !\!]) nil)
(replaceby       50     ((x) (f) !\![ (x) !\!]) nil)
(greaterp        50     ((x) (f) !\![ (x) !\!]) nil)
(lessp           50     ((x) (f) !\![ (x) !\!]) nil)
(geq             50     ((x) (f) !\![ (x) !\!]) nil)
(leq             50     ((x) (f) !\![ (x) !\!]) nil)
(neq             50     ((x) (f) !\![ (x) !\!]) nil)
(member          50     ((x) (f) (x))           nil)
(when            50     ((x) (f) (x))           nil)
(plus           100     ((x) (f) (r))           (minus difference))
(minus          100     ((f) (y))               nil)
(difference     100     ((x) (f) (y))           nil)
(union          100     ((x) (f) (r))           nil)
(setdiff        100     ((x) (f) (y))           nil)
(taylor!*       100     ((apply maketaylor))    nil) % precedence like plus
(times          200     ((x) (f) (r))           (recip quotient))
(wedge          200     ((x) (f) (r))           nil) % EXCALC
(quotient       200     ((f) (z) !}!{ (z) !})   nil)
(intersection   200     ((x) (f) (r))           nil)
(!*sq           200     ((apply make!*sq))      nil) % precedence like quotient
(recip          700     ((f) !1 !}!{ (z) !})    nil)
(expt           850     ((x) !^!{ (z) !})       nil)
(sqrt           800     ((f) !  !  !  (z) !})   nil)
(!:rd!:         999     ((apply make!:rd!:))    nil)
(!:cr!:         999     ((apply makedomain))    nil)
(!:gi!:         999     ((apply makedomain))    nil)
(!:rn!:         999     ((apply makedomain))    nil)
(!:crn!:        999     ((apply makedomain))    nil)
(!:mod!:        999     ((apply makedomain))    nil)
(!:dn!:         999     ((apply makedomain))    nil)
(!:int!:        999     ((apply makedomain))    nil)
(not            999     ((f) (y))               nil)
(mat            999     ((f) (m !\!c!r!  !&) !}) nil)
(list           999     (!\!{ (l !\co! ) !\!})  nil)
(df             999     ((apply makedf))        nil)
(int            999     ((apply makeint))       nil)
(limit          999     ((apply makelimit))     nil)
(limit!+        999     ((apply makelimit))     nil)
(limit!-        999     ((apply makelimit))     nil)
(sum            999     ((apply makelimit))     nil)
(prod           999     ((apply makelimit))     nil)
(!~             999     ((f) (y))               nil)
(!*interval!*   999     ((x) !. !. (x))         nil)
(innerprod      999     (!{ !\!r!m!  !i !}
                            !_!{ (z) !} (x))    nil) % EXCALC
(liedf          999     (!\!h!b!o!x!  !{ !\!i!t!  !\!$ !}
                            !_!{ (z) !} (x))    nil) % EXCALC
(hodge          999     ((f) (y))               nil) % EXCALC
(partdf         999     ((f) (apply makepartdf)) nil)          % EXCALC
(d              999     (!\!d!  (x))            nil)           % EXCALC
(!:ps!:         999     ((apply make!:ps!:))    nil)           % TPS
(rest!_order    999     (!{ !\!r!m!  !O !} (x)) nil)           % TPS
%-----------+----------+----------------------+------------------------+
));

% ----------------------------------------------------------------------
% Section 1.2 : Prefix to Infix Conversion
% ----------------------------------------------------------------------

symbolic procedure mktag(tag,prec,assf);
% analyze an operator and decide what to do
% parameters: tag ....... the term itself
%             prec ...... outer precedence
%             assf ...... outer associativity flag
if null tag then nil else
if atom tag then texexplode(tag) else
begin
  scalar tagprec,term;
  tagprec:=get(car tag,'texprec) or 999; % get the operator's precedence
  term:=makefunc(car tag,cdr tag,tagprec); % expand expression and if it
  % is necessary, put a left and a right bracket around the expression.
  if (assf and (prec = tagprec)) or (tagprec < prec)
  then term:=nconc('!\!( . term , '!\!) . nil);
  return(term)
end;

symbolic procedure makearg(l,s);
% collect arguments from a list  and put seperators  between them
if null l then nil
else if null cdr l then mktag(car l,0,nil)
     else nconc(mktag(car l,0,nil), s . makearg(cdr l,s));

symbolic procedure makemat(m,v,h);
% make a matrix  and use   as a horizontal seperator and  as
% a vertical terminator.
if null m then nil else nconc(makearg(car m,h), v . makemat(cdr m,v,h));
%ff
smacro procedure istag(v,w); car v=w;
smacro procedure unary(uby);  car uby;
smacro procedure binary(uby); cdr uby;
smacro procedure lcopy(a); for each x in a collect x;

symbolic procedure makefunc(op,arg,prec);
begin
  scalar term,tag,a,pattern,uby;
  term:=nil;
  pattern:=get(op,'texpatt)
           or ( if flagp(op,'indexvar) then '((apply makeexcinx))
                                       else '( (f) !\!( (l !,) !\!) ));
  uby:=get(op,'texuby);
  while pattern do
  << tag:=car pattern; pattern:=cdr pattern;
     if (atom tag) then a:=tag.nil
     else if (not atom car tag) then a:=nil
     else if istag(tag,'f) then
       % test for unary to binary operator interchange
       if arg and (not atom car arg) and uby and (caar arg=unary(uby))
       then << a:=texexplode(binary(uby)); arg:=cadar arg.cdr arg >>
       else a:=texexplode(op)
     else if istag(tag,'apply)
          then << a:=apply3(cadr tag,op,arg,prec); arg:=nil >>
     else if null arg then a:=nil
     else if istag(tag,'x)
          then << a:=mktag(car arg,prec,nil); arg:=cdr arg >>
     else if istag(tag,'y)
          then << a:=mktag(car arg,prec,t); arg:=cdr arg >>
     else if istag(tag,'z)
          then << a:=mktag(car arg,0,nil); arg:=cdr arg >>
     else if istag(tag,'r) then
       if cdr arg % more than one argument ?
       then << pattern:=get(op,'texpatt); a:=nil >>
       else << a:=mktag(car arg,prec,nil); arg:=cdr arg >>
     else if istag(tag,'l)
          then << a:=makearg(arg,cadr tag); arg:=nil >>
     else if istag(tag,'m)
          then << a:=makemat(arg,cadr tag,caddr tag); arg:=nil >>
     else a:=nil;
     if a then term:=nconc(term,a)
  >>;
  return(term)
end;
%ff
symbolic procedure make!*sq(op,arg,prec);
   % Convert !*sq's to true prefix form
   mktag(prepreform prepsq!* sqhorner!* car arg,0,nil);

symbolic procedure makedf(op,arg,prec); % DF operators are tricky
begin
  scalar dfx,f,vvv; integer degree;
  dfx:=lcopy(f:=texexplode op); degree:=0;
  nconc(dfx,mktag(car arg,prec,nil)); dfx:=nconc(dfx,list '!}!{);
  for each item in cdr arg do
    if numberp(item) then
    << dfx:= nconc(dfx,'!^!{ .texexplode(item));
       dfx:= nconc(dfx,list '!});
       degree:=degree+item-1;
    >>
    else
    << dfx:= nconc(dfx,append(f,mktag(item,prec,nil))); degree:=degree+1
    >>;
  if degree>1 then
  << vvv:=nconc(texexplode(degree), '!} . cdr dfx);
     rplacd(dfx,'!^!{ . vvv)
  >>;
  return ('!\!f!r!a!c!{ . nconc(dfx, list '!}))
end;

symbolic procedure makepartdf(op,arg,prec); % EXCALC extension
if cdr arg then
  ('!_!{ . nconc(makearg(cdr arg,'!,), '!} . mktag(car arg,prec,nil)))
else ('!_!{ . nconc(mktag(car arg,prec,nil), list '!}));

smacro procedure inxextend(item,ld,rd);
  nconc(result,ld.nconc(texexplode(item),list rd));

symbolic procedure makeexcinx(op,arg,prec); % EXCALC extension
begin scalar result;
  result:=nconc('!{.nil,texexplode(op));
  for each item in arg do
    if numberp item then
       if minusp item then  inxextend(-item,'!{!}!_!{,'!})
       else                 inxextend(item ,'!{!}!^!{,'!}) else
    if atom item then       inxextend(item ,'!{!}!^!{,'!}) else
    if car item='minus then inxextend(cadr item ,'!{!}!_!{,'!})
    else                    inxextend('! ,'!{!}!_!{,'!});
  return nconc(result,'!}.nil)
end;

symbolic procedure make!:rd!:(op,arg,prec);
   begin scalar digits,str; integer dotpos,xp;
   op := rd!:explode(op . arg);
   digits := car op; xp := cadr op; dotpos := caddr op;
   for i:=1:dotpos do
   << str := car digits . str;
      digits := cdr digits; if null digits then digits := '(!0) >>;
   str := '!. . str;
   for each c in digits do str := c . str;
   if not(xp=0) then
   << for each c in '(!\!, !1 !0 !^!{) do str := c . str;
      for each c in explode2 xp do str := c . str;
      str := '!} . str >>;
   return reverse str;
   end;

symbolic procedure makedomain(op,arg,prec);
   if get(op,'prepfn) then
      mktag(apply1(get(op,'prepfn),op . arg),prec,nil)
   else if get(op,'prepfn2) then
      mktag(apply1(get(op,'prepfn2),op . arg),prec,nil)
   else if get(op,'simpfn) then
      mktag(apply1(get(op,'simpfn),op . arg),prec,nil)
   else rerror(tri,000,
      {"Don't know how to print domain",get(op,'dname) or op});

symbolic procedure makelimit(op,arg,prec);
   % for operators like limit, sum and prod which may have limit scripts
   begin scalar a,term,limits;
   if arg then limits := cdr arg;
   term := texexplode(op);
   if limits then
   << a := '!_!{ . mktag(car limits,0,nil);
      limits := cdr limits;
      term := nconc(term,a) >>;
   if limits then
   << a :=
               if op = 'limit then '!\!t!o!                      % spaces critical
            else if op = 'limit!+ then '!\!u!p!a!r!r!o!w!     %
            else if op = 'limit!- then '!\!d!o!w!n!a!r!r!o!w! %
            else '!=;
      a := a . mktag(car limits,0,nil);
      limits := cdr limits;
      term := nconc(term,a) >>;
   if limits then
   << a := '!} . '!^!{ . mktag(car limits,0,nil);
      term := nconc(term,a) >>;
   a := '!{ . if arg then mktag(car arg,prec,nil) else nil;
   if arg and cdr arg then a := '!} . a;
   term := nconc(term,a);
   term := nconc(term,'!} . nil);
   return term;
   end;

symbolic procedure texgroup u;
   % surround u by TeX {}
   % NB Destructive!!
   nconc('!{ . if null u or listp u then u else {u},'!} . nil);

symbolic procedure makeint(op,arg,prec);
   % for operators like int which may have limit scripts
   begin scalar a,term,limits;
   if arg and cdr arg then limits := cddr arg;
   term := texexplode(op);
   if limits then
   << a := '!_!{ . cdr texgroup mktag(car limits,0,nil);
      limits := cdr limits;
      term := nconc(term,a) >>;
   if limits then
   << a := '!^!{ . cdr texgroup mktag(car limits,0,nil);
      limits := cdr limits;
      term := nconc(term,a) >>;
   a := if arg then mktag(car arg,0,nil);
   a := nconc(a,if arg and cdr arg then '!\!, . '!d . mktag(cadr arg,0,nil));
   term := nconc(term,texgroup a);
   return term;
   end;

symbolic procedure maketaylor(op,arg,prec);
   mktag(apply1(get(op,'fancy!-reform),op . arg),prec,nil);

% The following is part of the interface to TPS.
% Andreas Strotmann, 19 Mar 93

% ps:numberp smacro required for compilation; copied over from tps.red

symbolic smacro procedure ps!:numberp u;
  numberp u or (car u neq '!:ps!: and get(car u,'dname));

% fluid declaration to avoid compiler warnings
fluid '(ps!:exp!-lim);

% symbolic procedure ps!:prin!: p;
symbolic procedure make!:ps!:(op, arg, prec);  % TPS interface,
%  (lambda (first,u,delta,symbolic!-exp!-pt,about,atinf);
 (lambda (first,u,delta,symbolic!-exp!-pt,about,atinf,texps,p);
  <<  % if !*nat and posn!*<20 then orig!*:=posn!*;
      atinf:=(about='ps!:inf);
      ps!:find!-order p;
      delta:=prepf((ps!:depvar p) .** 1 .*1 .+
              (negf  if atinf then nil
                      % expansion about infinity
                      else if idp about then !*k2f about
                      else if ps!:numberp about then !*n2f about
                      else if (u:=!*pre2dp about) then !*n2f u
                      else !*k2f(symbolic!-exp!-pt:= compress
                         append(explode ps!:depvar p, explode '0))));
%      if symbolic!-exp!-pt then prin2!* "[";
%      prin2!* "{";
      texps := nconc(texps, list '!\!{ );
%
      for i:=(ps!:order p): ps!:exp!-lim do
        << u:=ps!:term(p,i);
           if not null numr u then
              <>
                                        texps := nconc(texps, list '!-)
                                        >>
                  else if not first then % prin2!* " + ";
                                        texps := nconc(texps, list '!+);
                first := nil;
%                if posn!*>55 then <>;
                if denr u neq 1 then % prin2!* "(";
                                     texps := nconc(texps, list '!\!( );
                if u neq '(1 . 1) then
                        % maprint(prepsq u,get('times,'infix))
                        texps := nconc(texps,
                                       mktag(prepsq u,
                                             get('times, 'texprec),
                                             nil))
                  else if i=0 then % prin2!* 1;
                                   texps := nconc(texps, list '!1);
                if denr u neq 1 then % prin2!* ")";
                                     texps := nconc(texps, list '!\!) );
                if i neq 0 and u neq '(1 . 1) then % prin2!* "*";
                        texps := nconc(texps,list get('times,'texname));
                if i neq 0 then
                % xprinf(!*p2f mksp(delta,
                %        if atinf then -i else i),nil,nil)
                  texps := (lambda i;
                             nconc(texps,
                                   mktag (if (i = 1) then delta
                                            else list('expt, delta, i),
                                          get('times, 'texprec),
                                          nil)))
                           (if atinf then -i else i);
              >>
       >>;
      if first then % prin2!* "0";
                    texps := nconc(texps, list '!0 );
      % if posn!*>55 then terpri!* nil;
      u:=ps!:exp!-lim +1;
      texps := (lambda u;
                nconc(texps,
                      '!+ . mktag(list('rest!_order,
                                        if (u = 1) then delta
                                            else list('expt, delta, u)),
                                  get('plus, 'texprec),
                                  nil)))
                (if atinf then -u else u);
      %if (u=1) and not atinf and (about neq 0) then
      %      prin2!* " + O"
      %else prin2!* " + O(";
      %xprinf(!*p2f mksp(delta,if atinf then -u else u),nil,nil);
      %if (u=1) and not atinf and (about neq 0) then
      %        prin2!* "}"
      %   else prin2!* ")}";
      texps := nconc(texps, list '!\!} );
      if symbolic!-exp!-pt then
        << %if posn!*>45 then terpri!* nil;
           %prin2!* "  where ";
           texps := nconc(texps, list '!_!{ );
           %prin2!* symbolic!-exp!-pt;
           texps := nconc(texps, texexplode symbolic!-exp!-pt);
           %prin2!* " = ";
           texps := nconc(texps, list '!= );
           %maprin about;
           texps := nconc(texps, mktag(makeprefix about,
                                         get('equal, 'texprec),  nil));
           texps := nconc(texps, list '!} );
           %prin2!* "]"
        >>;
  texps
  >>)
%  (t,nil,nil,nil,ps!:expansion!-point p,nil);
 (t,nil,nil,nil,ps!:expansion!-point(op . arg),nil,nil,op . arg);

%ff
% ----------------------------------------------------------------------
% Section 1.3 : Making a TeX Item
% ----------------------------------------------------------------------
% Properties of TeX items:
%   'CLASS ..... one of the following class specifiers
%      'ORD .... ordinary symbols
%      'LOP .... large operators
%      'BIN .... binary operators
%      'REL .... relational operators
%      'OPN .... opening symbols (left parenthesis)
%      'CLO .... closing symbols (right parenthesis)
%      'PCT .... punctuation symbols
%      'INN .... inner TeX group delimiters
%  'TEXTAG ..... one of the following lists or atoms
%       .. an atom describing an 'INN class group delimiter
%      (  ) ... where is
%                 ..... width for text style        (cmmi10)
%                 ..... width for scriptstyle       (cmmi8)
%                 ..... width for scriptscriptstyle (cmmi5)
% The parital lists of the list which is passed to makeitems have the
% following general structure:
%  (     ... )
%  where is
%       .... the atom which actually is the TeX code
%       ....... the 'CLASS property as explained above
%       ..... the 'TEXTAG property as explained above
%       etc. ..... atoms which will be bound to specific TeX items
%                      by its property 'TEXNAME
% ----------------------------------------------------------------------

smacro procedure triassert(name,item); put(name,'texname,item);
smacro procedure assertl(l); for each v in l do triassert(car v,cadr v);
smacro procedure retract(name); put(name,'texname,nil);
smacro procedure retractl(l); for each v in l do retract(car v);
smacro procedure gettexitem(a); get(a,'texname) or (get(a,'class)and a);

put ('texitem,'stat,'rlis); % handle argument passing for func. TeXitem

symbolic procedure texitem(arglist);
begin scalar x,ok,item,class,tag;
  if length arglist neq 3
  then rederr "Usage: TeXitem(item,class,width-list);";
  item:=car arglist; class:= cadr arglist; tag:= caddr arglist;
  ok:=memq(class,'(ord bin rel pct opn clo lop));
  if not ok then << prin2 "% illegal item class "; print class >>;
  if atom tag then ok:=nil else
  << if car(tag)='list then tag:=cdr tag; % accept algebraic lists
     for each x in tag do if not numberp x then ok:=nil
  >>;
  if not ok then << prin2 "% illegal width tag "; print tag >>;
  if ok then
  << item:=intern(item); put(item,'class,class); put(item,'textag,tag)
  >>;
  prin2 "% Item "; prin2 item;
  if not ok then prin2 "not "; prin2 " added"; terpri();
  return nil
end;
%ff
symbolic procedure makeitems(l);
for each w in l do
  begin scalar iw;
   iw:=intern(car w);
   put(iw,'class,cadr w); put(iw,'textag,caddr w);
   for each v in cdddr w do triassert(v,iw);
  end;

fluid '(texunknowncounter!*);
texunknowncounter!*:= 0;

symbolic procedure unknownitem(a);
<< texunknowncounter!* := texunknowncounter!* +1;
   prin2 "% non-fatal error: unknown atom "; prin2 a;
   prin2 " replaced by ?_{"; prin2 texunknowncounter!*;
   prin2 "}"; terpri();
   '!? . '!_!{ . nconc(explode texunknowncounter!*, list '!})
>>;

symbolic procedure texexplode(a);
begin scalar b;
  b:=if a and (atom a) then
     (gettexitem(a)
      or if numberp(a) then texcollect(explode(a))
         else if stringp(a) then strcollect(explode2(a))
         else texexplist(texcollect(explode2(a))));
   b:=if null b then list '!  else if not atom b then b else list b;
   return b
end;

symbolic procedure texcollect(l);
  for each el in l join
    if null gettexitem(el) then unknownitem(el)
    else gettexitem(el).nil;

smacro procedure strtexitem(e);
  if e='!  then list '!\!        % space after ! is necessary
  else if e='!	 then list '!\!   % there is a tab before the "then"
  else if liter(e) then {e}
  else if gettexitem(e) then {gettexitem(e)}
  else unknownitem(e); % or '! ;

symbolic procedure strcollect(l);
  for each el in l join strtexitem el;

symbolic procedure texexplist(r);
begin scalar r,v;
  v:=nil;
  for each rl on r do
    if digit(car rl) and not v then v:=rl
    else if v and not digit(car rl) then v:=nil;
  if v then
  << rplacd(v,car v.cdr v); rplaca(v,'!_!{); nconc(r,'!}.nil) >>;
  return r
end;
%ff
makeitems('(
  (!                    inn     dmy)   % no nonsense dummy item
  (!{                   inn     beg)   % begin of a TeX inner group
  (!^!{                 inn     sup)   % superscript
  (!_!{                 inn     sub)   % subscript nolimits
  (!{!}!^!{             inn     sup)   % spread superscript
  (!{!}!_!{             inn     sub)   % spread subscript
  (!}!{                 inn     sep)   % general group seperator
  (!}!^!{               inn     esp)   % end of group and superscript
  (!}!_!{               inn     esb)   % end of group and subscript
  (!}                   inn     end)   % end of TeX inner group
  (!\!f!r!a!c!{         inn     frc    recip quotient)  % fraction group
  (!\!s!q!r!t!{         inn     frc    sqrt)            % square root
  (!\!p!m!a!t!r!i!x!{   inn     mat    mat)             % matrix group
  (!&                   inn     tab)   % horizontal tabulation
  (!\!c!r!              inn     cr )   % vertical tabulation
  (!\!n!l!              inn     cr )   % vertical tabulation (special)
  (!\!(                 opn     (327680 276707 241208)) % test value
  (!\!)                 clo     (327680 276707 241208)) % ...
  (!\!{                 opn     (327680 276707 241208)) % ...
  (!\!}                 clo     (327680 276707 241208)) % ...
  (!\![                 opn     (0))
  (!\!]                 clo     (0))
  (!\!<                 opn     (254863 212082 195700))
  (!\!>                 clo     (254863 212082 195700))
  (!\!,                 ord     (80960))
  (!\!q!u!a!d!          rel     (655360))
  (!                    ord     (0)) % dummy item
  (!\!r!m!              ord     (0)) % dummy def of font change
  (!\!i!t!              ord     (0)) % dummy def of font change
  (!\!b!f!              ord     (0)) % dummy def of font change
  (!\!h!b!o!x!          ord     (0)) % dummy def of box opening
  (!!                   ord     (182045 148367 131984))
  (!?                   ord     (309476 247127 211630))
  (!\!l!b!r!a!c!e!      ord     (327681 268516 241211) !{)
  (!\!r!b!r!a!c!e!      ord     (327681 268516 241211) !})
  (!\!l!b!r!a!c!k!      ord     (182045 148367 131984) ![)
  (!\!r!b!r!a!c!k!      ord     (182045 148367 131984) !])
  (!\!b!a!c!k!s!l!a!s!h!   ord  (327681 268516 241211) !\)
  (!\!%                 ord     (546135 430537 359544) !%)
  (!\!#                 ord     (546135 430537 359544) !#)
  (!\!&                 ord     (509726 402320 336788) !&)
  (!@                   ord     (509726 402320 336788))
  (!\!_                 ord     (235930) !_)
  (!\!$                 ord     (327681 261235 223008) !$)
  (!;                   ord     (182045 148367 131984))
  (!:                   ord     (182045 148367 131984))
  (!.                   ord     (182045 148367 131984))
  (!,                   ord     (182045 148367 131984))
  (!|                   ord     (182045 148367 131984))
  (!'                   ord     (183865 177267))
  (!`                   ord     (182045 148367 131984))
  (!\!                  ord     (218453))
%ff
% Fonts  ammi10, ammi7, ammi5; ordered by index number
  (!\!G!a!m!m!a!        ord     (394126 317121 266467))
  (!\!D!e!l!t!a!        ord     (546133 451470 377742))
  (!\!T!h!e!t!a!        ord     (481689 395400 331866))
  (!\!L!a!m!b!d!a!      ord     (418702 346612 293546))
  (!\!X!i!              ord     (447374 366819 309020))
  (!\!P!i!              ord     (553870 446190 368185))
  (!\!S!i!g!m!a!        ord     (511090 417791 348842))
  (!\!U!p!s!i!l!o!n!    ord     (382293 320398 275342))
  (!\!P!h!i!            ord     (436906 364088 309475))
  (!\!P!s!i!            ord     (419430 354622 304150))
  (!\!O!m!e!g!a         ord     (461596 382217 322806))
  (!\!a!l!p!h!a!        ord     (419233 350253 299280))
  (!\!b!e!t!a!          ord     (370688 303376 259231))
  (!\!g!a!m!m!a!        ord     (353318 296277 256227))
  (!\!d!e!l!t!a!        ord     (273066 229467 203070))
  (!\!e!p!s!i!l!o!n!    ord     (266012 222822 197791))
  (!\!z!e!t!a!          ord     (223686 195060 178221))
  (!\!e!t!a!            ord     (352407 300373 261688))
  (!\!t!h!e!t!a!        ord     (298553 247580 216177))
  (!\!i!o!t!a!          ord     (231955 198883 180224))
  (!\!k!a!p!p!a!        ord     (377590 315392 271246))
  (!\!l!a!m!b!d!a!      ord     (382293 320398 275342))
  (!\!m!u!              ord     (394885 326314 278528))
  (!\!n!u!              ord     (341940 283534 244849))
  (!\!x!i!              ord     (327680 276707 241208))
  (!\!p!i!              ord     (370293 312456 270222))
  (!\!r!h!o!            ord     (329728 269699 232379))
  (!\!s!i!g!m!a!        ord     (361737 300646 258776))
  (!\!t!a!u!            ord     (250083 220910 200430))
  (!\!u!p!s!i!l!o!n!    ord     (354076 299008 259413))
  (!\!p!h!i!            ord     (390485 322764 275888))
  (!\!c!h!i!            ord     (410055 334506 283534))
  (!\!p!s!i!            ord     (426894 357262 304924))
  (!\!o!m!e!g!a!        ord     (407931 339968 290360))
  (!\!v!a!r!e!p!s!i!l!o!n!  ord (312433 358776 225097))
  (!\!v!a!r!t!h!e!t!a!  ord     (388513 326997 281713))
  (!\!v!a!r!p!i!        ord     (504945 424800 359719))
  (!\!v!a!r!r!h!o!      ord     (329728 369699 232379))
  (!\!v!a!r!s!i!g!m!a!  ord     (312433 258776 225097))
  (!\!v!a!r!p!h!i!      ord     (465123 383749 323675))
  % omitted: codes 40-47
  (!0   ord     (327680 276707 241208))
  (!1   ord     (327680 276707 241208))
  (!2   ord     (327680 276707 241208))
  (!3   ord     (327680 276707 241208))
  (!4   ord     (327680 276707 241208))
  (!5   ord     (327680 276707 241208))
  (!6   ord     (327680 276707 241208))
  (!7   ord     (327680 276707 241208))
  (!8   ord     (327680 276707 241208))
  (!9   ord     (327680 276707 241208))
  (!.   pct     (182044 160198 150186) cons)
  (!,   rel     (182044 160198 150186))
  (!\co!  rel   (182044 160198 150186))
%ff
  % omitted: code 60
  (!/   bin     (327680 262143 204800))
  % omitted : codes 62,63
  (!\!p!a!r!t!i!a!l!    ord     (384341 314982 268105)  partdf df)
  (!A   ord     (491520 404866 339057))
  (!B   ord     (497095 406550 339569))
  (!C   ord     (542583 439273 363451))
  (!D   ord     (542583 439273 363451))
  (!E   ord     (468400 387026 326360))
  (!F   ord     (412330 331684 277845))
  (!G   ord     (515276 418884 348660))
  (!H   ord     (544768 439409 363520))
  (!I   ord     (288085 236475 204913))
  (!J   ord     (371825 302512 257706))
  (!K   ord     (556373 450104 371598))
  (!L   ord     (446008 369914 312888))
  (!M   ord     (635790 512227 420408))
  (!N   ord     (526563 424846 352142))
  (!O   ord     (499893 409964 343244))
  (!P   ord     (420750 341242 286606))
  (!Q   ord     (518098 424527 354622))
  (!R   ord     (482417 399041 335644))
  (!S   ord     (392760 323128 274887))
  (!T   ord     (382976 318122 272270))
  (!U   ord     (447465 366409 309179))
  (!V   ord     (375011 304014 260266))
  (!W   ord     (577991 469310 389973))
  (!X   ord     (533845 433811 359651))
  (!Y   ord     (388210 317485 270506))
  (!Z   ord     (429170 352256 397642))
  % omitted: codes 91-96
  (!a   ord     (346415 291999 253770))
  (!b   ord     (281258 235383 207621))
  (!c   ord     (283610 240571 212810))
  (!d   ord     (341105 277890 242392))
  (!e   ord     (283610 240571 212810))
  (!f   ord     (320853 260778 224369))
  (!g   ord     (300980 247580 215995))
  (!h   ord     (377590 315392 271246))
  (!i   ord     (231500 191601 174762))
  (!j   ord     (238933 198883 177493))
  (!k   ord     (341181 296265 248490))
  (!l   ord     (195546 169756 157468))
  (!m   ord     (575411 479687 402318))
  (!n   ord     (393367 334051 288540))
  (!o   ord     (317667 264510 230377))
  (!p   ord     (329728 277435 242392))
  (!q   ord     (292560 245577 215995))
  (!r   ord     (277466 235292 208668))
  (!s   ord     (307200 253041 219818))
  (!t   ord     (234837 204799 186595))
  (!u   ord     (375163 319487 277162))
  (!v   ord     (317667 269881 236657))
  (!w   ord     (463303 386389 327680))
  (!x   ord     (361813 296732 253951))
  (!y   ord     (321308 273066 239388))
  (!z   ord     (304772 257137 225735))
  % omitted: codes 123-127
%ff
  % Fonts amsy10, amsy7, amsy5; not ordered.
  (!+           bin     (509724 422343 354986)  plus)
  (!-           bin     (509724 422343 354986)  difference minus)
  (!*           ord     (509724 422343 354986) hodge)
  (!"           ord     (509724 422343 354986))
  (!\!c!d!o!t!  bin     (182044 160198 150186)  times)
  (!=           rel     (509724 422343 354986)  eq equal)
  (!:!=         rel     (691771 550687 468772)  setq)
  (!\!s!u!m!    lop     (1000000 700000 500000)  sum)
  (!\!p!r!o!d!  lop     (1000000 700000 500000)  prod)
  (!\!i!n!t!    lop     (1000000 700000 500000)  int)
  (!\!l!i!m!    ord     (910221 771866 678114)  limit limit!+ limit!-)
  (!\!s!i!n!    ord     (804635 687398 612123)  sin)
  (!\!c!o!s!    ord     (877454 745653 657634)  cos)
  (!\!t!a!n!    ord     (946630 800994 700869)  tan)
  (!\!l!n!      ord     (700000 600000 500000)  log)
  (!\!e!x!p!    ord     (1001243 844685 735003)  exp)
  (!\!a!r!c!t!a!n!  ord (1824539 1543734 1356227)  atan)
  (!\!w!e!d!g!e!    ord (436908 353167 309480) wedge !^)
  (!\!b!a!c!k!s!l!a!s!h!  ord (327681 268516 241211) !\ setdiff)
  (!\!d!        ord     (364090))
  (!\!l!a!n!d!  bin     (436908 353167 309480) and)
  (!\!l!o!r!    bin     (436908 353167 309480) or)
  (!\!l!n!o!t!  ord     (436908 353167 309480) not)
  (!\!c!a!p!    bin     (436908 353167 309480) intersection)
  (!\!c!u!p!    bin     (436908 353167 309480) union)
  (!\!i!n!      rel     (436908 353167 309480) member)
  (!\!t!o!      rel     (655361 522469 446015))
  (!\!u!p!a!r!r!o!w!      rel     (327681 268516 241211))
  (!\!d!o!w!n!a!r!r!o!w!  rel     (327681 268516 241211))
  (!<           rel     (509726 409601 354991) lessp)
  (!>           rel     (509726 409601 354991) greaterp)
  (!\!l!e!q!    rel     (509726 409601 354991) leq)
  (!\!g!e!q!    rel     (509726 409601 354991) geq)
  (!\!n!e!q!    rel     (509726 402230 336788) neq)
  (!\!m!i!d!    rel     (182045 155648 150188) when)
  (!\!f!o!r!a!l!l!  ord (364090 296733 263968) !~)
  (!\!R!i!g!h!t!a!r!r!o!w!   rel     (655361 522469 446015)  replaceby)
  (!(           ord     (254863 204801 177495))
  (!)           ord     (254863 204801 177495))
  (!\!i!n!f!t!y!    ord (655361 522469 446015) infinity)
  % The rest are non-standard TeX macros defined in tridefs.tex
  (!\!c!d!o!t!  ord     (109224 89505 80403)     times)
  (!\!a!s!i!n!  ord     (1132319 906677 780527)  asin)
  (!\!a!c!o!s!  ord     (1205136 963111 826038)  acos)
  (!\!a!t!a!n!  ord     (1274315 1016723 869275) atan)
  (!\!A!l!p!h!a!    ord (491521 386847 321314))
  (!\!B!e!t!a!  ord     (464215 366366 306295))
  (!\!E!p!s!i!l!o!n!  ord (446010 352257 294916))
  (!\!Z!e!t!a!  ord     (400498 317669 268520))
  (!\!E!t!a!    ord     (491521 386847 321314))
  (!\!I!o!t!a!  ord     (236658 189328 162021))
  (!\!K!a!p!p!a!    ord (509726 400956 332691))
  (!\!M!u!      ord     (600748 471498 389581))
  (!\!N!u!      ord     (491521 386847 321314))
  (!\!R!h!o!    ord     (446010 352257 294916))
  (!\!T!a!u!    ord     (473316 374103 314031))
  (!\!C!h!i!    ord     (491521 386847 321314))
  (!\!O!m!e!g!a!    ord (473316 374103 314031))
));
%ff
% ----------------------------------------------------------------------
% You  can  choose  to  have  some  default  TEXNAME properties for your
% variables.  Function "trimakeset" defines a set of such default names.
% If  you want to activate the set,  call "TeXassertset()" , or
% if  you want to deactivate the set,  call "TeXretractset()" .
% The current s available are:
%    *     GREEK    : lowercase greek letters
%    *     LOWERCASE: roman lowercase letters
% ----------------------------------------------------------------------
% handle argument passing
deflist( '((texassertset rlis) (texretractset rlis)), 'stat);

symbolic procedure texassertset(arglist);
if length arglist neq 1 then rederr "Usage: TeXassertset(setname);"
else begin scalar sym; sym:= car arglist;
  if get('texsym,sym) then
  << assertl(get('texsym,sym)); prin2 "% set ";
     prin2 sym; prin2 " asserted"; terpri()
  >> else << prin2 "% no such set"; terpri() >>
end;

symbolic procedure texretractset(arglist);
if length arglist neq 1 then rederr "Usage: TeXretractset(setname);"
else begin scalar sym; sym := car arglist;
  if get('texsym,sym) then
  << retractl(get('texsym,sym)); prin2 "% set ";
     prin2 sym; prin2 " retracted"; terpri()
  >> else << prin2 "% no such set"; terpri() >>
end;

symbolic procedure trimakeset(sym,a!_set);
   <>;

trimakeset('greek,'(
  (alpha        !\!a!l!p!h!a!   )
  (beta         !\!b!e!t!a!     )
  (gamma        !\!g!a!m!m!a!   )
  (delta        !\!d!e!l!t!a!   )
  (epsilon      !\!e!p!s!i!l!o!n! )
  (zeta         !\!z!e!t!a!     )
  (eta          !\!e!t!a!       )
  (theta        !\!t!h!e!t!a!   )
  (iota         !\!i!o!t!a!     )
  (kappa        !\!k!a!p!p!a!   )
  (lambda       !\!l!a!m!b!d!a! )
  (mu           !\!m!u!         )
  (nu           !\!n!u!         )
  (xi           !\!x!i!         )
  (pi           !\!p!i!         )
  (rho          !\!r!h!o!       )
  (sigma        !\!s!i!g!m!a!   )
  (tau          !\!t!a!u!       )
  (upsilon      !\!u!p!s!i!l!o!n! )
  (phi          !\!p!h!i!       )
  (chi          !\!c!h!i!       )
  (psi          !\!p!s!i!       )
  (omega        !\!o!m!e!g!a!   ) ));
trimakeset('lowercase,'(
  (a !a) (b !b) (c !c) (d !d) (e !e) (f !f) (g !g) (h !h) (i !i) (j !j)
  (k !k) (l !l) (m !m) (n !n) (o !o) (p !p) (q !q) (r !r) (s !s) (t !t)
  (u !u) (v !v) (w !w) (x !x) (y !y) (z !z) ));
trimakeset('!Greek,'(
  (!Alpha        !\!A!l!p!h!a!   )
  (!Beta         !\!B!e!t!a!     )
  (!Gamma        !\!G!a!m!m!a!   )
  (!Delta        !\!D!e!l!t!a!   )
  (!Epsilon      !\!E!p!s!i!l!o!n! )
  (!Zeta         !\!Z!e!t!a!     )
  (!Eta          !\!E!t!a!       )
  (!Theta        !\!T!h!e!t!a!   )
  (!Iota         !\!I!o!t!a!     )
  (!Kappa        !\!K!a!p!p!a!   )
  (!Lambda       !\!L!a!m!b!d!a! )
  (!Mu           !\!M!u!         )
  (!Nu           !\!N!u!         )
  (!Xi           !\!X!i!         )
  (!Pi           !\!P!i!         )
  (!Rho          !\!R!h!o!       )
  (!Sigma        !\!S!i!g!m!a!   )
  (!Tau          !\!T!a!u!       )
  (!Upsilon      !\!U!p!s!i!l!o!n! )
  (!Phi          !\!P!h!i!       )
  (!Chi          !\!C!h!i!       )
  (!Psi          !\!P!s!i!       )
  (!Omega        !\!O!m!e!g!a!   ) ));
trimakeset('!Uppercase,'(
  (!A !A) (!B !B) (!C !C) (!D !D) (!E !E) (!F !F) (!G !G) (!H !H) (!I !I)
  (!J !J) (!K !K) (!L !L) (!M !M) (!N !N) (!O !O) (!P !P) (!Q !Q) (!R !R)
  (!S !S) (!T !T) (!U !U) (!V !V) (!W !W) (!X !X) (!Y !Y) (!Z !Z) ));
%ff
% ----------------------------------------------------------------------
% Section 2: Inserting Glue into a TeX-Item-List
% ----------------------------------------------------------------------
%
% Glue Items to be inserted between consecutive TeX-Items (similar to
% what TeX does with its items, but this table is slightly modified.)
%
%    Class|ORD|LOP|BIN|REL|OPN|CLO|PCT|INN|
%    -----+---+---+---+---+---+---+---+---+
%    ORD  | 0 | 1 |(2)|(3)| 0 | 0 | 0 | 0 |
%    LOP  | 1 | 1 | * |(3)| 0 | 0 | 0 |(1)|
%    BIN  |(2)|(2)| * | * |(2)| * | * |(2)|
%    REL  |(3)|(3)| * | 0 |(3)| 0 | 0 |(3)|     columns: right items
%    OPN  | 0 | 0 | * | 0 | 0 | 0 | 0 | 0 |     lines:   left items
%    CLO  | 0 | 1 |(2)|(3)| 0 | 0 | 0 | 0 |
%    PCT  |(1)|(1)| * |(1)|(1)|(1)|(1)|(1)|
%    INN  | 0 | 1 |(2)|(3)|(1)| 0 |(1)| 0 |
%    -----+---+---+---+---+---+---+---+---+
%
% The glue items and its meanings:
%   0 ......... no space
%   1 (1) ..... thin space   (no space if sub-/superscript)
%   2 (2) ..... medium space (no space if sub-/superscript)
%   3 (3) ..... thick space  (no space if sub-/superscript)
%   * ......... this case never arises (really?)
% ----------------------------------------------------------------------

symbolic procedure makeglue(mx);
if null mx then nil else
begin
  scalar id1,id2,row,col;
  row:=cdr mx; id1:=car mx;
  while(row) do
  << id2:=car mx; col:=car row;
     while (col) do
     << put(car id1,car id2,car col);
        col:=cdr col; id2:=cdr id2
     >>;
     row:=cdr row; id1:=cdr id1
  >>
end;

makeglue('(
(ord lop bin rel opn clo pct inn)
( 0   1  -2  -3   0   0   0   0 )
( 1   1   0  -3   0   0   0  -1 )
(-2  -2   0   0  -2   0   0  -2 )
(-3  -3   0   0  -3   0   0  -3 )
( 0   0   0   0   0   0   0   0 )
( 0   1  -2  -3   0   0   0   0 )
(-1  -1   0  -1  -1  -1  -1  -1 )
( 0   1  -2  -3  -1   0  -1   0 )
));

smacro procedure kindof(item);  get(item,'textag);
smacro procedure classof(item); get(item,'class);
%ff
smacro procedure groupbeg(kind); % beginning of a group
  memq(kind,'(beg sup sub frc mat));
smacro procedure groupend(kind); (kind='end);
smacro procedure grouphs(kind);  (kind='tab);
smacro procedure groupvs(kind); % vertical group seperator
  memq(kind,'(esp esb sep cr));

symbolic procedure interglue(left,right,depth,nesting);
% compute the glue to be inserted between two TeX items
% parameters: left,right .......... left/right TeX item
%             depth ............... superscript/subscript level
%             nesting ............. depth of parenthesis level
% a glue item is a list consisting of two numbers, i.e.
%            ( )
% where  is the width of the glue in scaled points and 
% is a negative numeric value indicating 'merits' for a breakpoint.
if (null left)or(null right)or(not atom left)or(not atom right) then nil
else begin
  scalar glue,lc,rc; % glue code and item classes
  lc:=classof(left); rc:=classof(right); glue:=get(lc,rc);
  if null(glue) then return nil;
  if (left='!\co! ) then return(list(0,-10000));
  if glue<0 then if depth>0 then return nil else glue:=(-glue);
  if glue=1 then return(list(80960,nesting*10 +20))
  else if glue=2 then
  << if (left='!+ or left='!-) then return nil;
     if (right='!+) then return(list(163840,nesting*30-390));
     if (right='!- and (lc='ord or lc='clo))
     then return(list(163840,nesting*30-210));
     if (left='!\!c!d!o!t! ) then return(list(163840,nesting*10+50));
     if (right='!\!c!d!o!t! ) then return nil;
     return(list(163840,nesting*10))
  >>
  else if glue=3 then return(list(655360,nesting*10-50)) else return nil
end;

symbolic procedure insertglue(term);
% insert glue into a TeX-Item-List
begin
  scalar glueitem,succ,pred,prev,backup; integer depth,nesting;
  depth:=nesting:=0; succ:=nil; backup:=term;
  while term do
  << pred:=succ; succ:=car term;
     glueitem:=interglue(pred,succ,depth,nesting);
     if glueitem then rplacd(prev,glueitem.term);
     prev:=term; term:=cdr term;
     if classof(succ)='inn then
     << if (groupbeg kindof succ) and
           (not ((kindof(succ)='frc) and (depth=0)))
        then depth:=depth+1
        else if (groupend kindof succ) and (depth>0) then depth:=depth-1
     >>
     else if classof(succ)='opn then nesting:=nesting+1
     else if classof(succ)='clo then nesting:=nesting-1
  >>;
  return(backup)
end;
%ff
% ----------------------------------------------------------------------
% Section 3 : Line Breaking
% ----------------------------------------------------------------------
%
%     How to break up a TeX item list into several independent lines
% ----------------------------------------------------------------------
% Setting break points requires "breaklists". A  breaklist is a sequence
% of passive and active nodes,  where each active node is followed by an
% pasive node and vice versa. Active nodes represent glue items. Passive
% nodes are integer atoms which represent the width of a sequence of or-
% dinary  TeX  items.   This sequence must not be interspersed with glue
% items.  Every breaklist consists of at least one passive node surroun-
% ded by delta nodes representing the beginning and ending of the list.
%         ::= (    ...
%                                         ...
%                                        )
%       ::= (    )
%      ::= 
%        ::= (   
%                              )
% The breaklist will be created using the function "breaklist".  Setting
% the break points (i.e. break items) in the breaklist is done using the
% functions "trybreak".  During  this  phase, some active nodes are con-
% sidered to be "feasible" break points. Thus, they will be extended and
% named "delta nodes" furtheron. By default the first and last node in a
% breaklist are delta nodes.  When trybreak has finished, the 's of
% the delta nodes recursively pointed to  from  the  last  delta  node's
%  represent the best path for breaking the whole breaklist.
% It is:
%         : width of item (including glue items)
%       : a numeric value which prohibits line breaking (if
%                  negative, line breaking will be merited)
%        : distance to most previous opening bracket
%        : the identity number of the delta node {1,2,3,...}
%           : pointer to the best delta node to come from with
%                  respect to the minimal demerits path. note: a zero
%                  pointer indicates the very bottom of the stack
%      : total demerits distance to delta node which is
%                  pointed to by 
%   : amount of indentation when breaking at this point
% ----------------------------------------------------------------------
%ff
symbolic procedure width(item,style);
begin scalar tag;
   tag:=get(item,'textag);
   if null tag then tri!-error(list("cannot find item ",item),'fatal);
   while (style>0)and(cdr tag) do << tag:=cdr tag; style:=style-1 >>;
   return car tag or 0
end;

smacro procedure sp2mm(x); (x/186468); % scaled points to millimeters

symbolic procedure settolerance(tol);
<< if tol<0 then tol:=0 else if tol>10000 then tol:=10000;
   prin2 "% \tolerance "; print tol; tolerance!*:=tol; nil
>>;
symbolic procedure setpagewidth(hsize);
% hsize can be given either in millimeters or scaled points.
<< if hsize>400 then hsize!*:=hsize else hsize!*:=hsize*186468;
   prin2 "% \hsize="; prin2 sp2mm(hsize!*); prin2 "mm"; terpri();
   hss!*:=float hsize!*/6;      % default stretch/shrink width
   hww!*:=float (3*hsize!*)/4;  % optimum line width
>>;
symbolic procedure setbreak(hsize,tol);
<< settolerance(tol); setpagewidth(hsize) >>;

smacro procedure badness(hlen,ibadness);
% The badness is 100*(hlen/hss)**3, corrected for indentation badness
begin
  real r;
  r:=abs(hlen-hww!*)/hss!*;
  return fix min(10000.0,r*r*r*100.0+ibadness)
end;

smacro procedure isglue(l);         (not atom l) and (numberp car l);
smacro procedure isactive(x);       not numberp x;
smacro procedure ispassive(x);      numberp x;
smacro procedure isdelta(x);        cdddr x;
smacro procedure addup(x);          if x then eval('plus.x) else 0;
smacro procedure tpush(stack,item); stack:=item.stack;

smacro procedure tpop(stack);
  if null stack then nil % Error
  else begin scalar z; z:=car stack; stack:=cdr stack; return(z) end;

smacro procedure poke(stack,ptr,val);
if null ptr then stack:=nconc(stack,val.nil)
else << if val>car(ptr) then rplaca(ptr,val); ptr:=cdr ptr >>;

smacro procedure concatenate(l);
begin scalar r;
  for each e in l do r:=nconc(r,explode e);
  return compress r
end;
%ff
% ----------------------------------------------------------------------
% Section 3.1:  Resolving Fraction Expressions
% ----------------------------------------------------------------------

symbolic procedure resolve(term);
% resolve a  \frac{...}{...}  sequence and transform it into a   .../...
% sequence, where any ... argument may become parenthesized depending on
% the question if there is any non-ORD-class item within this argument.
% Furthermore, resolve a \sqrt{...} expression to \(...\)^{\frac{1}{2}}.
begin
  scalar item,l,m,r,lflag,rflag;
  integer depth;
  l:=term;                            % save pointer to functor
  depth:=0; m:=r:=lflag:=rflag:=nil; item:=t;
  while term and item do
  << item:=car term;                  % take first item from list
     if classof(item)='inn then       % check inner class item
     << item:=kindof(item);
        if groupbeg(item) then depth:=depth+1
        else if groupend(item) then
          if depth=1 then             % outermost level ?
          << r:=term; item:=nil       % save pointer to right bracket
          >>                          % and quit using item as a flag
          else depth:=depth-1
        else if groupvs(item) then    % if outermost level then save
         if (depth=1) then m:=term    % pointer to intermediate brackets
     >>
     else if not(classof(item)='ord) then % non-ORD-class item ?
     << if m then rflag:=t else lflag:=t
     >>;
     term:=cdr term                   % step ahead
  >>;
  if car l='!\!f!r!a!c!{ then
  << if lflag and rflag
       then item:=list('!/,list(655360,-10000))
       else item:=list('!/);
     if lflag then << rplaca(l,'!\!(); item:='!\!).item >>
     else rplaca(l,'! );
     if rflag then << rplaca(r,'!\!)); nconc(item,'!\!(.nil) >>
     else rplaca(r,'! );
     rplaca(m,car item); item:=cdr item;
     if item then rplacd(m,nconc(item,cdr m))
  >> else if car l='!\!s!q!r!t!{ then
  << rplaca(l,'!\!(); rplaca(r,'!\!));
     rplacd(r,'!^!{ .  '!1 . '!/ . '!2 . '!} . cdr r)
  >>;
  return(l)                           % return changed list pointer
end;
%ff
% ----------------------------------------------------------------------
% Section 3.2 : Create a Break List
% ----------------------------------------------------------------------

symbolic procedure breaklist(term);
begin
  scalar item,result,kind,vstack,hstack,fstack,pstack,p,flag,backup;
  integer depth,acc,aux,lopw,total,indent;
  p:=result:=vstack:=hstack:=fstack:=nil; backup:=term;
  depth:=total:=acc:=lopw:=indent:=0;
  while term do
  << item:=car term; flag:=t;              % get first item from term
     if null item
     then tri!-error(list("found NIL in term : ",backup),'fatal);
     if (isglue(item)) then                % do we have glue ahead ?
       if (depth<1) then                   % are we on the top level ?
       << % insert a passive node followed by an active node, clear acc.
          total:=total+acc+car item; nconc(item,indent.nil);
          result:=nconc(result,acc.item.nil); acc:=0
       >>
       else acc:=acc+car item              % add up glue width
     else if (classof(item)='lop) then lopw:=width(item,depth)
     else if classof(item)='inn then
       << kind:=kindof(item);
          if kind='frc then
          << tpush(fstack,term); tpush(fstack,depth)
          >>;
          if groupend(kind) then           % end of TeX group ?
          << depth:=depth-1;               % decrement term depth
             if acc>0                      % if  hasn't been poked
             then poke(vstack,p,acc);      % yet, then poke it
             acc:=tpop(hstack);            % get old acc value
             aux:=addup(vstack);           % compute vstack width
             if fstack and (depth=car fstack) then
             << tpop(fstack);              % first waste depth info
                if aux>hww!* then          % check if it doesn't fit
                << term:=resolve tpop fstack;% resolve fraction
                   flag:=nil               % evaluate new list
                >>
                else                       % waste fraction term pointer
                << tpop(fstack); acc:=acc+aux
                >>
             >> else acc:=acc+aux;
             p:=tpop(hstack); vstack:=tpop(hstack) % reset old status
          >>
          else if groupbeg(kind) then      % begin of TeX group ?
          << depth:=depth+1;               % increment term depth
             tpush(hstack,vstack);         % save current  and
             tpush(hstack,p);              % current 
     as well as
             tpush(hstack,acc);            % current  to 
             acc:=0; p:=vstack:=nil;       % clear vertical stack
             if lopw>0 then poke(vstack,p,lopw); lopw:=0
          >>
          else if grouphs(kind) then       % horizontal separator ?
          << poke(vstack,p,acc); acc:=0    % poke  to 
          >>
          else if groupvs(kind) then       % vertical separator ?
          << poke(vstack,p,acc); acc:=0; p:=vstack % reset
          >>
       >>
%ff
     else if depth<1 then
     << aux:=width(item,depth);            % add up item width
        if classof(item)='opn then
        << tpush(pstack,indent); indent:=total+acc+aux
        >>;
        if classof(item)='clo then indent:=tpop(pstack) or 0;
        acc:=acc+aux
     >>
     else acc:=acc+width(item,depth);      % add up item width
     if lopw>0 then << acc:=acc+lopw; lopw:=0 >>;
     if flag then term:=cdr term
  >>;
  if acc then total:=total+acc;
  if (total>;

smacro procedure findindent(offt,ptr);
if offt=lastoff and ptr=lastptr then lastindent else
begin % search the deltastack for previous indentation
  scalar node,p,stack; integer tot;
  stack:=deltastack; p:=lastptr:=ptr; lastoff:=offt;
  while stack do
  << if p=idof (node:=car stack) then
     << p:=ptrof node; tot:=totalof node;
        if tot>;
     if stack then stack:=cdr stack;
  >>;
  return(lastindent:=offt-tot+indentof node)
end;
%ff
symbolic procedure trybreak(term,brkl);
% parameters: term .... TeX item list, as created by "interglue"
%             brkl .... the breaklist to be processed by this routine
begin
  scalar bottom,top,base,item,deltastack,pred;
  integer depth;               % depth of expression when rebuilding
  integer feasible,id;         % number of feasible delta node
  integer len,total;           % current and total length so far
  integer dm,basedm;           % current and base demerits
  integer bd;                  % current badness
  integer penalty;
  integer offset,baseoffset;   % current and base parenthesis offset
  integer baseptr;             % pointer to best way to come from
  integer indent,baseindent;   % current and base indentation
  integer lastoff,lastindent,lastptr; % temp. var. for speedup
  real indentbadness;          % correction for indentation badness
  if null brkl then goto retain;
  bottom:=brkl;
  lastoff:=lastptr:=lastindent:=feasible:=indent:=total:=0;
  while bottom do
  << top:=cdr bottom; base:=car bottom; pred:=tailof base;
     id:=idof base;            % id of current delta node
     if penaltyof base=-10000  % break item ?
     then rplaca(cdr pred,0);  % new line
     basedm:=cadr pred;        % demerits so far
     % save the delta node to the delta-stack. thus deltastack holds
     % all the feasible breakpoints in reverse order.
     deltastack:=base.deltastack;
     len:=baseindent:=indentof(base); % indentation for this line
     indentbadness:=2500.0*(float(baseindent)/float(hww!*));
     baseoffset:=offsetof base;% current offset amount
     baseptr:=car pred;        % pointer to best node to come from
     total:=total+widthof base;% correct total length
%--- debug ---
% prin2 "Base ["; prin2 id; prin2 "] basedm="; prin2 basedm;
% prin2 " ibd="; prin2 indentbadness;
% prin2 " indent="; prin2 baseindent; terpri();
%--- debug ---
%ff
     while top and lentotal
                       then indent:=offset-total+baseindent
                       else if offset>
                 >>
              >>
              else             % create a new delta node
              << feasible:=feasible+1;
                 if !*texindent then
                   if offset>total
                   then indent:=offset-total+baseindent
                   else if offset>;
%--- debug ---
% prin2 "-->["; prin2 idof item; prin2 "] dm="; prin2 dm;
% prin2 " bd="; prin2 bd; prin2 " p="; prin2 penalty;
% if !*TeXindent then << prin2 " ind="; prin2 indent >>; terpri();
%--- debug ---
              if penalty=-10000 then top:=nil
           >>;
           len:=len+car item   % count the length anyway
        >>;
        if top then top:=cdr top
     >>;
%ff
     rplaca(cdr base,total);   % replace penalty by total width so far
     bottom:=cdr bottom;       % depart from this delta node
     while bottom and (ispassive(car bottom) or not isdelta(car bottom))
     do stepahead(bottom,total); % move to next delta node in list
  >>;
  bottom:=deltastack; feasible:=-1; top:=nil;
  while bottom do              % loop thru the delta-node stack
  << id:=idof car bottom;      % id is the current id number
     if id=feasible then       % is this node the one pointed to?
     << feasible:=ptrof car bottom; % feasible is the new back-pointer
        top:=id.top;           % save the path element
     >>;
     bottom:=cdr bottom        % step ahead
  >>;                          % now deltastack contains the best path
  deltastack:=cdr top;         % in forward order
%--- debug ---
% print term; print deltastack;
%--- debug ---
  if car deltastack= -1 then
  << prin2 "% Warning:    no suitable way of breaking found"; terpri();
     prin2 "% ========    retry with a greater tolerance..."; terpri();
     prin2 "% (output will produce overfull box if printed)"; terpri()
  >>;
  brkl:=cdr brkl;              % strip the dummy node at the list's head
%ff
  % --------------------------------------------------------------------
  % now remove all glue items but retain all break items
  retain: % ------------------------------------------------------------
  offset:=depth:=0; bottom:=term;
  if brkl then brkl:=cdr brkl; % ensure first item is an active node
  while term and (cdr term) do
  << item:=car term;
     if isglue(item) then           % if this is a glue item
       if (depth=0) and brkl then   % and we are on the top level
       << top:=car brkl;
          if isdelta(top) then      % consider delta nodes only
          << if (idof top=car deltastack) then % break point?
             << deltastack:=cdr deltastack;
%--- debug ---
% prin2 "% ["; prin2 idof top; prin2 "] ";
% prin2 sp2mm(totalof(top)+indentof(top)-offset); terpri();
% offset:=totalof(top);
%--- debug ---
                if (len:=indentof top)>0
                then rplacd(pred,'!\!n!l! . offsetitem(len) . cdr term)
                else rplacd(pred,'!\!n!l! . cdr term)
             >>
             else rplacd(pred,cdr term)
          >>
          else rplacd(pred,cdr term);
          if brkl and (cdr brkl)    % check for next active node
          then brkl:=cddr brkl      % skip to next active node
       >>
       else rplacd(pred,cdr term)  % remove glue item
     else if classof(item)='inn then
     << if groupbeg(kindof(item)) then depth:=depth+1 else
        if groupend(kindof(item)) then depth:=depth-1
     >>;
     pred:=term; term:=cdr term
  >>;
%--- debug ---
% top:=car term; prin2 "% [-1] ";
% prin2 sp2mm(totalof(top)+indentof(top)-offset); terpri();
%--- debug ---
  return(bottom)
end;
%ff
% ----------------------------------------------------------------------
% Section 4 : Output of TeX-Code
% ----------------------------------------------------------------------

symbolic procedure texstrlen(s);
begin
  integer length;
  scalar flag;
  length:=0; flag:=nil;
  for each c in s do
    if not flag and c='!! then flag:=t
    else << length:=length+1; flag:=nil >>;
  return length
end;

smacro procedure newline();
  if nlflag then cc:=indent
  else if (cc>indent) then << terpri(); cc:=indent; nlflag:=t >>;

%ff
symbolic procedure texout(itemlist,flag);
if null itemlist then nil else
begin
   integer cc,len,indent,ccmax,lines;
   scalar item,class,tag,oldtag,lasttag,indentstack,ispd,nlflag;
   ccmax:=64; cc:=indent:=lines:=0;        % initializations
   tag:=ispd:=nlflag:=indentstack:=nil;    % initializations
   prin2('!$!$);                           % begin TeX math group
   if flag then prin2('!\!d!i!s!p!l!a!y!l!i!n!e!s!{!\!q!d!d);
   terpri();                               % start new line
   while itemlist do
   << item:=car itemlist; itemlist:=cdr itemlist;
      len:=texstrlen(explode(item)); oldtag:=nil; lasttag:=tag or class;
      class:=classof(item); tag:=(class='inn)and(kindof(item));
      %ispd:=(class='ORD)and itemlist and(classof(car itemlist)='OPN);
      if (tag='mat)or(tag='frc)or(class='opn) %or ispd
      then newline();                      % start new line
      if (groupbeg(tag))or(class='opn) then
      << tpush(indentstack,indent);        % push it to the stack
         tpush(indentstack,lasttag);       % the reason for pushing
         if (cc+cc < ccmax)                % within left half of page ?
         then if ((class='opn)and(lasttag='ord))or % predicate?
                 (groupbeg(tag)and not((tag='frc)or(tag='mat)))
           then indent:=cc+len             % take current position
           else indent:=indent+len         % compute new indentation
      >>
      else if (groupend(tag))or(class='clo) then
      << oldtag:=tpop(indentstack); indent:=tpop(indentstack)
      >>;
      if (cc+len > ccmax) or      % beyond right margin ?
         (item='!+)or(item='!-)or(class='clo) % important item?
      then newline();
      if nlflag then << nlflag:=nil; spaces(cc) >>;
      if tag='cr  then lines:=lines+1;
      if not(item='! ) then prin2(item);   % print the item and
      cc:=cc+len;                          % count the characters
      if groupvs(tag) or                   % vertical seperator ?
         (groupend(tag) and                % end of a large group,
          ((oldtag='frc) or (oldtag='mat)))% i.e. fraction, matrix ?
         or (class='clo) or                % closing parenthesis ?
         (((class='rel)or(class='bin))and  % binary/relational operator?
          (cc+cc+cc > ccmax+ccmax))        % within last third of page?
         or item='!,  or null class
      then newline()
   >>;
   newline();                              % start final line
   if flag then
     if lines=0 then prin2('!\!c!r!})
     else prin2('!\!N!l!});                % end multi-line output
   prin2('!$!$); terpri(); return(nil)     % end math group
end;
%ff
% ----------------------------------------------------------------------
% Section 5: User Interface
% ----------------------------------------------------------------------
% handle argument passing for following the functions, compelling that
% properties are used during compile time
deflist( '((texdisplay rlis) (texlet rlis)), 'stat);

algebraic procedure texsetbreak(hsize,tol); lisp setbreak(hsize,tol);
algebraic procedure textolerance(tol); lisp settolerance(tol);
algebraic procedure texpagewidth(hsize); lisp setpagewidth(hsize);

symbolic procedure texlet(arglist);
begin scalar class,sym,item;
  if length arglist neq 2 then rederr "Usage: TeXlet(symbol,item);";
  sym:= car arglist; item:=intern cadr arglist; class:=classof(item);
  if null class then
  << prin2 "% No such TeX symbol available"; terpri()
  >>
  else if (class='inn) then % prevent from TeXequiv'ing inner symbols
  << prin2 "% cannot assign inner TeX symbols yet"; terpri()
  >>
  else triassert(sym,item);
  return nil
end;

symbolic procedure texdisplay(arglist);
begin scalar item,tag,class;
  if length arglist neq 1 then rederr "Usage: TeXdisplay(item);";
  item:=get(car arglist,'texname);
  if not item then
  << prin2 "% "; prin2 car arglist; prin2 " is not defined"; terpri()
  >>;
  if not item then return nil;
  tag:=get(item,'textag);  class:=get(item,'class);
  prin2 "% TeX item "; prin2 item; prin2 " is of class "; prin2 class;
  prin2 " and has following widths: "; terpri(); prin2 "% ";
  for each w in tag do
  begin real v; v:=w/65536.0; prin2 v; prin2 "pt  " end;
  terpri(); return nil
end;

% ----------------------- share name between both modes ----------------

symbolic operator texlet;
symbolic operator texitem;
symbolic operator texdisplay;
symbolic operator texassertset;
symbolic operator texretractset;

% ------------------------ Default Initializations ---------------------

<< prin2 "% TeX-REDUCE-Interface 0.70"; terpri() >>;
texassertset(greek); texassertset(lowercase);
texassertset '!Greek; texassertset '!Uppercase;
textolerance(10); texpagewidth(150);

endmodule;


end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/tri.tex0000644000175000017500000024373511526203062022640 0ustar  giovannigiovanni\relax
% **********************************************************************
% ****                                                              ****
% ****   DRAFT: The TeX-REDUCE-Interface                            ****
% ****   Werner Antweiler, University of Cologne, August 1, 1988    ****
% ****                                                              ****
% **********************************************************************
\magnification=1200
\hoffset=10truemm\hsize=16truecm\vsize=10truein
\tolerance 1500 \hbadness=800
\parindent=12pt \parskip=0pt \displayindent=30pt
\baselineskip=12pt plus0.1pt minus0.2pt
\newdimen\narrowskip \narrowskip=10pt
% Make Use of 12pt-Fonts Default
%
\font\caps=cmcsc10
\font\smallcaps=cmcsc10 at 10truept
\font\small=cmr8
\font\smallit=cmti8
\font\smallbf=cmbx8
\font\smalltt=cmtt8
\font\big=cmbx10 at 15pt
%
\catcode`\"=\active \let"=\" \let\3=\ss
\def\zB{z.B.\ }
\def\D{\char'042}
\def\B{\char'134}
% -----------
% Hilfsmacros
% -----------
\def\ttq{\par\vskip3.6135pt\begingroup\baselineskip=14.454pt
\parindent=30pt\parskip=0pt\let\par=\endgraf\obeyspaces\obeylines\tt\ttf}
{\obeylines\gdef\ttf^^M#1\endtt{\vbox{#1}\endgroup\par\noindent}}
{\obeyspaces\gdef {\ }}
\def\iq#1{{\it#1\/}}
\def\quote{\par\begingroup\leftskip=\parindent
 \baselineskip=9.03pt\small\noindent}
\def\endquote{\par\endgroup\par}
\def\today{\ifcase\month\or January\or February\or March\or April\or May\or
June\or July\or August\or September\or October\or November\or December\fi
\space\number\day, \number\year}
\def\endpage{\par\vfill\eject}
\newcount\Defcount \Defcount=0
\def\Def#1\par{\global\advance\Defcount by1\par
\vskip3.6135pt{\baselineskip=14.454pt
\noindent\bf Definition \the\Defcount:\sl\enspace#1\par}}
\let\YY=\let % now you can send the control sequence \YY
\newcount\Figcount \Figcount=0
\def\VFig{\vFig\smalltt}
\def\VVFig{\vFig\tt}
\def\vFig#1{\midinsert\global\advance\Figcount by 1
   \message{[Fig. \the\Figcount]}
   \vbox\bgroup
     \hrule height.6pt
     \hbox to\hsize\bgroup
       \vrule width.6pt \hskip 9.4pt
       \vbox\bgroup
         \advance\hsize by-20pt \line{}
         \vskip 9.4pt \nointerlineskip
         \let\vtt=#1\verbatim}
\def\endVFig#1:#2\par{\vskip 9.4pt
       \egroup \hss \vrule width.6pt
     \egroup \hrule height.6pt
     \vskip3pt\baselineskip=\narrowskip
     \noindent\smallbf Fig. \the\Figcount: #1.
     \small #2\par
   \egroup\endinsert}
% ------------------
% Fussnotensteuerung
% ------------------
\newcount\notenumber\notenumber=0
\def\vfootnote#1{\insert\footins\bgroup
  \interlinepenalty=\interfootnotelinepenalty
  \splittopskip=\ht\strutbox \splitmaxdepth=\dp\strutbox
  \floatingpenalty=20000 \leftskip=0pt \rightskip=0pt
  \spaceskip=0pt \xspaceskip=0pt
  \item{#1}\footstrut\futurelet\next\fooot}
\def\fooot{\ifcat\bgroup\noexpand\next\let\next\foooot
           \else\let\next\foot\fi\next}
\def\foooot{\bgroup\aftergroup\oofoot\let\next}
\def\foot#1{#1\oofoot}
\def\oofoot{\strut\egroup}
\def\note#1{\global\advance\notenumber by1
\begingroup\small\baselineskip=\narrowskip
\setbox\strutbox=\hbox{\vrule height7.0pt depth3.0pt width0pt}%
\footnote{$^{\the\notenumber}$}{\bgroup\small\baselineskip=\narrowskip
#1\egroup}\endgroup}
% -----------------------------------
% Seitenkopf und Fusszeilen-Steuerung
% -----------------------------------
\pageno=1
\headline={\ifnum\pageno=1\hfill\else\hfill\rm---\ \folio\ ---\hfill\fi}
\footline={\hfil}
% ------------------
% Inhaltsverzeichnis
% ------------------
\let\ZZ=\let % now you can send the control sequence \ZZ
\newcount\seccount \seccount=0
\newcount\subseccount \subseccount=0
\newcount\subsubseccount \subsubseccount=0
\def\secnum{\number\seccount%
\ifnum\subseccount=0\else.\number\subseccount\fi%
\ifnum\subsubseccount=0\else.\number\subsubseccount\fi}
% --------
% Textteil
% --------
\newbox\secbox
\def\secindent#1#2#3{\par\bigskip\begingroup
   \message{\secnum #1}\setbox\secbox=\hbox{#3\secnum\hskip1.5em}
   \hangafter=1\hangindent=\wd\secbox\baselineskip=\ht\secbox
   \advance\baselineskip by5pt
    \noindent #3\box\secbox#1
   \par\endgroup\nobreak\smallskip
   \nobreak\smallskip\vskip-\parskip\noindent}
\def\sec#1\par{\global\advance\seccount by1\global\subseccount=0
   \global\subsubseccount=0\secindent{#1}{0}\bf}
\def\subsec#1\par{\global\advance\subseccount by1
   \global\subsubseccount=0\secindent{#1}{1}\bf}
\def\subsubsec#1\par{\global\advance\subsubseccount by1
   \secindent{#1}{2}\bf}
% --------------
% Spezial Makros
% --------------
\def\center{\vskip\parskip\begingroup
            \parindent=0pt \parskip=0pt plus 1pt
            \rightskip=0pt plus 1fill \leftskip=0pt plus 1fill
            \obeylines}
\def\endcenter{\endgroup}
\def\flushleft{\vskip\parskip\begingroup
            \parindent=0pt \parskip=0pt plus 1pt
            \rightskip=0pt plus 1fill \leftskip=0pt
            \obeylines}
\def\endflushleft{\endgroup}
\def\flushright{\vskip\parskip\begingroup
            \parindent=0pt \parskip=0pt plus 1pt
            \rightskip=0pt \leftskip=0pt plus 1fill
            \obeylines}
\def\endflushright{\endgroup}
\def\itemize#1{\par\begingroup\parindent=#1}
\def\litem#1{\par\hang\noindent\hbox to \parindent{#1\hfil}}
\def\ritem#1{\par\hang\noindent\hbox to \parindent{\hfil#1\enspace}}
\def\sitemize#1{\par\begingroup\parindent=#1\baselineskip=\narrowskip\small}
\def\enditemize{\par\endgroup\par}
\def\bitem{\ritem{$\bullet$}}
% ------------
% Mathe-Makros
% ------------
\newcount\eqcount \eqcount=0
\newcount\eqoffcount
\def\adveq{\global\advance\eqcount by1}
\def\eqcon{\adveq(\number\eqcount)}
\def\eqco{\eqno{\eqcon}}
\def\ceqc#1{(\number\eqcount.#1)}
\def\ceqalign{\adveq\eqalignno}
\def\eqoff#1{\eqoffcount=\eqcount\advance\eqoffcount by-#1%
(\the\eqoffcount)}
\catcode`\*=\active \def*{\ifmmode\cdot\else\char'52\fi}
% Spezialmakros
\def\aut#1 \ttl#2 \pub#3 \ref#4 \dat#5 \inx#6 \^^M{\par
{\baselineskip=\narrowskip
 \parindent=24pt\hang\noindent{\smallcaps#1}\small\ (#6) #2. #3, #5%
 \ifx\\#4\else, #4\fi.\par}\medskip\penalty0}
\def\example{\par\vskip5pt\flushleft\tt\parindent=50pt}
\def\endexample{\endflushleft\vskip5pt\noindent\ignorespaces}
\def\i#1{{\it #1\/}}
\def\t#1{{\tt #1}}
\def\VAX{$\mu$VAX-I\kern-0.1em I}
% ----------------------------------------------------------------------
% Verbatim Mode Macros
% ----------------------------------------------------------------------
\def\uncatcodespecials{\def\do##1{\catcode`##1=12}\dospecials\do\"}
\let\vtt=\tt
\def\setupverbatim{\vtt\Obeylines\uncatcodespecials\obeyspaces}
\def\newlinepar{~\par}
{\catcode`\^^M=\active % these lines must end with `%'
  \gdef\Obeylines{\catcode`\^^M=\active\def^^M{\newlinepar}}}%
{\obeyspaces\global\let =\ }
\def\verbatim{\par\begingroup\parskip=0pt plus 1pt
              \ifx\vtt\smalltt\baselineskip=10pt\fi
              \setupverbatim\doverbatim}
{\catcode`\|=0 \catcode`\\=12
 |Obeylines|gdef|doverbatim^^M#1\endverbatim{#1|endgroup}}
\def\verb{\begingroup\setupverbatim\doverb}
\def\doverb#1{\def\next##1#1{##1\endgroup}\next}
% ----------------------------------------------------------------------
% REDUCE-LISP Programming Language Documentation
% ----------------------------------------------------------------------
\newdimen\xindent \dimen\xindent=15pt
\catcode`\@=\active
\def\@{\char'100}
\def@{\hskip\dimen\xindent\ignorespaces}
\def\gets{$\leftarrow$}
\def\\#1/{{\it#1\/\kern.05em}} % italic type for identifiers
\def\&{{\bf#1\/}}           % boldface type for reserved words
\def\.#1.{{\tt#1\/}}           % typewriter type for strings
\def\!#1!{{\rm$\langle$ #1 $\rangle$\/}}   % roman for operations
\def\[#1]{{\rm$\{$ #1 $\}$}}   % comments in roman
\def\DOC{\midinsert\global\advance\Figcount by 1
   \message{[Fig. \the\Figcount]}
   \vbox\bgroup
     \hrule height.6pt
     \hbox to\hsize\bgroup
       \vrule width.6pt \hskip 9.4pt
       \vbox\bgroup
         \advance\hsize by-20pt \line{}
         \vskip 9.4pt \nointerlineskip
         \parindent=0pt \parskip=0pt plus 1pt
             \rightskip=0pt plus 1fill \leftskip=0pt
             \begingroup\obeylines}
\def\endDOC{\endgroup\endDoc}
\def\endDoc#1:#2\par{\vskip 9.4pt
       \egroup \hss \vrule width.6pt
     \egroup \hrule height.6pt
     \vskip3pt\baselineskip=\narrowskip
     \noindent\smallbf Fig. \the\Figcount: #1.\ \small#2\par
   \egroup\endinsert}
% ----------------------------------------------------------------------
% Titel
% ----------------------------------------------------------------------
\line{}
\vskip10mm
\center\big\baselineskip=24pt
Typesetting REDUCE output with \TeX
--- A REDUCE-\TeX-Interface ---
\endcenter
\vskip13mm
\center\baselineskip=12pt
\smallcaps Werner Antweiler
\smallcaps Andreas Strotmann
\smallcaps Volker Winkelmann
\small University of Cologne Computer Center, West Germany{\parindent=12pt%
\note{The authors are with: %
Rechenzentrum der Universit"at zu K"oln (University of Cologne %
Computer Center), %
Abt. Anwendungssoftware (Application Software Department), %
Robert-Koch-Stra\3e 10, 5000 K"oln 41, West Germany.}}
\small\today
\endcenter
\vskip15mm
\begingroup\narrower\narrower\baselineskip=\narrowskip
\noindent\smallbf Abstract: \small
REDUCE is a well known computer algebra system invented by
Anthony C. Hearn.
Although a pretty-printer is already incorporated in REDUCE,
the output is produced only in line-printer quality.
The simple idea to produce high quality output from REDUCE
is to link REDUCE with Donald E. Knuth's famous \TeX\ typesetting
language. This draft reviews our efforts in this direction.
We introduce a program written in REDUCE-Lisp which is able to typeset REDUCE
formulas using \TeX. Our REDUCE-\TeX-Interface incorporates three
levels of \TeX\ output: without line breaking, with line breaking,
and with line breaking plus indentation. This paper deals with
some of the ideas we have put into LISP-code and it summarizes some of our
experiments we have made with it yet. Furthermore, we compile a small
user's manual introducing to the use of our REDUCE-\TeX-Interface.
\par\bigskip
\noindent\smallbf Keywords: \small
Line-Breaking Algorithm, LISP, Prefix-to-Infix Conversion,
REDUCE, \TeX, Typesetting
\par\endgroup\vskip10mm
\rm
%begin(text)
% ----------------------------------------------------------------------
\sec Introduction\par
% ----------------------------------------------------------------------
REDUCE is a well known computer algebra system invented by
Anthony C. Hearn. While every effort was made to improve
the system's algebraic capabilities, the readability of the
output remained poor by modern typesetting standards.
Although a pretty-printer is already incorporated in REDUCE,
the output is produced only in line-printer quality.
The simple idea to produce high quality output from REDUCE
is to link REDUCE with Donald E. Knuth's famous \TeX\ typesetting
language. This draft reviews our efforts in this direction.
We introduce a program written in REDUCE-Lisp to typeset REDUCE
formulas with \TeX. Our REDUCE-\TeX-Interface incorporates three
levels of \TeX\ output: without line breaking, with line breaking,
and with line breaking plus indentation. While speed
without line breaking is comparable to that achieved with
REDUCE's pretty-printer, line breaking consumes much more CPU time.
Nevertheless, we reckon with a cost increase due to line breaking
which is almost linear in the length of the expression to be broken.
This paper deals with some of the ideas and algorithms we have
programmed and it summarizes some of the experiments we have made
with our program.
Furthermore, at the end of this paper we provide a small user's manual
which gives a short introduction to the use of our REDUCE-\TeX-Interface.
For simplicity's sake the name ``REDUCE-\TeX-Interface'' will be
abbreviated to ``TRI'' in this paper.\note{The reason why it was called
TRI and not RTI is simply due to the fact that TRI corresponds better
to the three-level (``tri-level'') mode.}
At this point we should mention major goals we pursue with TRI:
\bitem We want to produce REDUCE-output in typesetting quality.\par
\bitem The intermediate files (\TeX-input files) should be easy to edit.
       The reason is that it is likely that the proposed
       line-breaks are sub-optimal from the user's point of view.\par
\bitem We apply a \TeX-like algorithm which ``optimizes''
       the line-breaking over the whole expression. This differs
       fundamentally from the standard left-to-right, one-line look-ahead
       pretty-printers of REDUCE, LISP and the like.\par
% ----------------------------------------------------------------------
\sec From REDUCE to \TeX: concepts\par
% ----------------------------------------------------------------------
REDUCE uses the function \t{varpri} to decide how to output a REDUCE
expression. The function gets three arguments: the expression to be
printed, a list of variables to each of which the expression to be
printed gets assigned, and a flag which determines if the expression to be
printed is the first, last or only expression in the line. \t{varpri}
may be called consecutively for preparing a line for output. So, our
task is to assemble all expressions before finally printing them.
When !*TeX is true, \t{varpri} redirects output to our function
\t{TeXvarpri}, which receives a REDUCE expression, translates it into
\TeX\ and pushes it onto a variable called \t{TeXStack*} before
eventually printing it once the line is completed.\par
The \t{TeXvarpri} function first calls a function named \t{makeprefix}.
Its job is to change a REDUCE algebraic expression to a standard prefix list
while retaining the tree structure of the whole expression. Generally, this
is done using a call \t{prepsq*(simp(expression))}, but lists and
matrices need some special treatment. After this has been done the
new intermediate expression is passed to the most important module
of the TRI: the \t{mktag/makefunc}-family.\note{The whole family currently
has five members. The ``parents'' are the mktag and makefunc
functions which do the most burdensome job. The ``children'' are
\t{makearg, makemat and makeDF} which handle special cases such as
list construnction or differentiation operators. We do not review
the minor functions since they are easily understandable.}
These functions recursively expand the structured list (or operator tree)
into a flat list, translating each REDUCE symbol or
expression into so-called \TeX-items on passing by.
For that reason, this list is called the \TeX-item list.
If the simple \TeX-mode (without line breaking) was chosen this list
is then printed immediately without further considerations.
Translation and printing this way is almost as fast as with
the standard REDUCE pretty printer.\par
When line-breaking has been enabled things get a bit more complicated.
The greatest effort with TRI was to implement the line-breaking
algorithm. More than half of the entire TRI code deals with this
task.
The ultimate goal is to add some ``break items'', i.e. \verb|\nl|-%
\TeX-commands\note{This is not a \TeX-primitive but a TRI-specific
\TeX-macro command which expands into a lot of stuff.},
marking --- in a certain way --- optimal line-breaks.
Additionally, these break items can be followed immediately by
``indentation items'', i.e. \verb|\OFF{...}| \TeX-commands\note{see
previous footnote}, specifying
the amount of indentation applicable for the next new line.
The problem is to choose the right points where to insert these
special \TeX-items. Therefore, the \TeX-item list undergoes
three further transformation steps.\par
First, the \TeX-item list gets enlarged by so-called ``glue items''.
Glue items are two-element lists, where the first element is a width
info and the second element is a penalty info. The ``penalty'' is
a value in the range $-10000\ldots+10000$ indicating a mark-up on a
potential break-point, thus determining if this point is a
fairly good (if negative) or bad (if positive) choice.
The amount of penalty depends (a) on the kind of \TeX-items
surrounding the glue item, (b) on the bracket nesting, and finally
(c) on special characteristics.\note{For example, the plus-  and
the difference operator have special impact on the amount of
penalty.} The function handling this job is named
\t{insertglue} which implicitly calls the function
\t{interglue}. The latter determines the glue item to insert
between a left and a right \TeX-item.\par
During the second level, the \TeX-item list becomes transformed
into a so-called breaklist consisting of active and passive nodes.
A passive node is simply a width info giving the total width of
\TeX-items not interspersed by glue items. On the other hand,
active nodes are glue items enlarged by a third element, the
offset info, indicating an indentation level which is used later
for computing the actual amount of indentation.
Active nodes are used as potential breakpoints.
Moreover, while creating the breaklist, the \TeX-item list will be
modified if necessary according to the length of fractions and square
roots which cannot be broken if retained in their ``classical''
form. Hence fractions look like \t{(...)/(...)} if they don't fit
into a single line, especially in the case of large polynomial fractions.
The major function for this job is named \t{breaklist} which
calls \t{resolve} if necessary.
\par
The third and most important level is the line-breaking algorithm
itself. This algorithm embedded in the function \t{trybreak}
will be described below. The idea how to break lines is based
on the article by Knuth/Plass(1981). Line-breaking can occur at
active nodes only. So, you can loop through the breaklist considering
all potential break-points. But in order to find a suitable way
in a reasonable amount of time you have to limit the number of
potential breakpoints considered. This is performed by associating
a ``badness'' with each potential breakpoint, describing how
good looking or bad looking a line turns out. If the badness is less than
a given amount of ``tolerance'' --- as set by the user ---
then an active node is considered to be feasible and becomes
a delta node. A delta node is simply an active node enlarged
by four further infos: an identification number for this node,
a pointer to the best feasible break-point (i.e. delta-node) to come from%
\note{If one were to break the formula at this delta-node, the
best place to start this line  is given by this pointer.}
the total amount of demerits (i.e. a compound value derived from
badness and penalty) accumulated so far, and a value indicating
the amount of indentation applied to a new line beginning at this
node.
When \t{trybreak} has stepped through the list, the breakpoints
will have been determined. Afterwards all glue items (i.e. active nodes)
are deleted from the \TeX-item list while break- and indentation-%
items for those nodes marked as break-points are inserted.
\par
Finally the \TeX-item list is printed with regular ASCII-characters.
We didn't put much emphasis on the question on how to format the
intermediate output since it will be input directly into
\TeX. The best way to characterize the routine \t{texout}
is to call it quick and dirty. The readabiltiy of the output
is low, but it may be quite good enough for users
to do some final editing work.
Nevertheless, \t{texout} keeps the nesting structure of the term
visible when printed, so it will be easy to distinguish between
parenthesis levels simply by considering the amount of indentation.
% ----------------------------------------------------------------------
\sec Creating a \TeX-item list\par
% ----------------------------------------------------------------------
The first \TeX-specific step in preparing a typesettable  equivalent
of a REDUCE expression is to expand the operator tree generated by
REDUCE into a so-called \TeX-item list. The operator tree is
preprocessed by \t{makeprefix} in order to receive an operator tree
in standard prefix notation. A \TeX-item is either a character (letter or
digit or special character) or a \TeX-primitive
or -macro (i.e. a LISP symbol), with properties \t{'CLASS}, \t{'TEXTAG},
\t{'TEXNAME} and (only if the item represents an operator)
\t{'TEXPREC}, \t{'TEXPATT} and  \t{'TEXUBY}
bound to them, depending on what kind of \TeX-item it actually is.
The latter three properties are used for operators only. \t{'TEXPREC}
is the precedence of the operator, a number between 0 and 999.
Here the value itself is less important than the position with
respect to other operators' precedences. The remaining properties
will be described later.
\par
First let's have a look at how a REDUCE expression arriving at TRI's main
entry --- the function \t{TeXvarpri} --- is transformed through
several levels of TRI-processing. For instance, let us consider
the expression $(x-y)^{12}$, which expands into a polynomial
$x^{12}-12*x^{11}*y+\cdots-12*x*y^{11}+y^{12}$ when evaluated.
REDUCE uses a special form to store an expression. This form is
called ``standard quotient'' because it in fact represents a quotient of two
polynomials. The contents of the following figure 1 shows the
``standard quotient'' form of our example.\par
% ----------------------------------------------------------------------
\VFig
(*SQ ((((X . 12)           .    1)
       ((X . 11) ((Y . 1)  .  -12))
       ((X . 10) ((Y . 2)  .   66))
       ((X . 9)  ((Y . 3)  . -220))
       ((X . 8)  ((Y . 4)  .  495))
       ((X . 7)  ((Y . 5)  . -792))
       ((X . 6)  ((Y . 6)  .  924))
       ((X . 5)  ((Y . 7)  . -792))
       ((X . 4)  ((Y . 8)  .  495))
       ((X . 3)  ((Y . 9)  . -220))
       ((X . 2)  ((Y . 10) .   66))
       ((X . 1)  ((Y . 11) .  -12))
       ((Y . 12)           .    1)
) . 1) T)
\endverbatim
\endVFig Standard Quotient Notation: This form is the way REDUCE represents
terms.\par
% ----------------------------------------------------------------------
\noindent The term has been indented by hand to retain the structure
of this expression. Actually the denominator is 1 as you easily find out
from the last line.\note{The ``T'' in the last line is an ``already-%
simplified''-flag indicating that the term doesn't need to undergo any more
processing.} Obviously the standard-quotient form is a bit complicated
for further manipulations. It can be changed to a real prefix
notation as displayed in figure 2. Here, too, the term was edited
by hand to make it a bit more readable and comparable to the other
forms.\note{``Edit'' only means we have provided some additional
indentation. We have changed neither the expression nor its structure.}
Note that \t{PLUS} is not a binary but a $n$-ary operator,
i.e. it takes an arbitrary number of arguments, while \t{MINUS} is
always a unary operator.\note{The same problem arises with the
RECIP-operator which is the unary form of the binary QUOTIENT-%
operator.} This causes a bit of trouble because real
binary operators are much easier to handle. To tackle this problem
we have introduced the \t{'TEXUBY} property, which is used to change
a unary into a binary form if possible.\par
% ----------------------------------------------------------------------
\VFig
(PLUS                   (EXPT X 12)
      (MINUS (TIMES  12 (EXPT X 11)       Y   ))
             (TIMES  66 (EXPT X 10) (EXPT Y  2))
      (MINUS (TIMES 220 (EXPT X  9) (EXPT Y  3)))
             (TIMES 495 (EXPT X  8) (EXPT Y  4))
      (MINUS (TIMES 792 (EXPT X  7) (EXPT Y  5)))
             (TIMES 924 (EXPT X  6) (EXPT Y  6))
      (MINUS (TIMES 792 (EXPT X  5) (EXPT Y  7)))
             (TIMES 495 (EXPT X  4) (EXPT Y  8))
      (MINUS (TIMES 220 (EXPT X  3) (EXPT Y  9)))
             (TIMES  66 (EXPT X  2) (EXPT Y 10))
      (MINUS (TIMES  12       X     (EXPT Y 11)))
                                    (EXPT Y 12))
\endverbatim
\endVFig Prefix Notation: This list represents the state after
application of {\smalltt makeprefix}\par
% ----------------------------------------------------------------------
A REDUCE expression is expanded using the two  functions \t{mktag}
and \t{makefunc}. Function \t{mktag} identifies the operator and is
able to put some brackets around the expression if necessary.
\t{makefunc} is a pattern oriented ``unification''\note{in the
terminology of the programming language Prolog} function, which matches
arguments of a REDUCE expression in order of appearance with so-called
``unification tags'', as explained below. Thus, \t{mktag} and
\t{makefunc} are mutually dependent and highly recursive functions.\par
A ``unification tag list'' is a list (or a pattern, if you like)
which consists of single ``unfication tags''.
Each REDUCE operator is associated with a unification pattern.
While expanding the expression, each tag is replaced by the appropiate
\TeX-item or partial \TeX-item list created subsequently.
A tag is defined as either an atom declared  as a \TeX-item or one of
the following:\par\itemize{27mm}\smallskip
\litem{(F)}insert operator
\litem{(X)}insert non-associative argument
\litem{(Y)}insert a left- or right-associative argument
\litem{(Z)}insert superscript/subscript argument
\litem{(R)}use tail recursion to unify remaining arguments (necessary
with operators having more than two arguments, e.g. the plus operator;
associativity depends on previous (X) or (Y) tag)
\litem{(L \i{hs})}insert a list of arguments (eat up all arguments on
passing by); put \i{hs} as a horizontal separator between the arguments
(e.g., a separator could be a comma for simple argument lists.)
\litem{(M \i{vs} \i{hs})}insert a matrix (and eat up all arguments on
passing by); put \i{vs} as a vertical separator and \i{hs} as a
horizontal separator between the rows and columns
\litem{(APPLY \i{fun})}apply function \i{fun} to remaining argument list
\par\enditemize\smallskip
\noindent
These ``tags'' are assembled to a tag-list or pattern, respectively.
For each functor (i.e. the head of a prefix list, e.g. \t{PLUS},
\t{MINUS} or \t{SQRT}) such a list is bound to its property
\t{'TEXPATT}. For instance, the functor \t{PLUS} has got the pattern
\t{((X) (F) (R))} bound to it, and the functor \t{EXPT} possesses the
pattern \verb|((X) ^{ (Z) })|.
The following two boxes with pseudo-code  (figures 3 and 4)
survey the two major functions performing the expansion of a
prefix REDUCE-expression into a TeX-item list.\par
% ----------------------------------------------------------------------
\DOC
\&function& \\mktag/(\\tag/,\\outer-precedence/,\\associative/);
\&begin&
@  \&if& \!tag is empty! \&then return nil&
@  \&else if& \!tag is an atom! \&then return& \!get the \TeX-item for%
 \\tag/!
@  \&else begin& \[the tag is a list]
@  @  \\precedence/\gets\!precedence of this tag or 999!
@  @  \[now expand the expression, the first element is the]
@  @  \[functor, the following elements are the arguments]
@  @  \\term/\gets\\makefunc/(\&car& \\tag/,\&cdr& \\tag/,\\precedence/);
@  @  \[check for parentheses: term is surrounded by parentheses in order]
@  @  \[to prevent it from overruling by precedence]
@  @  \&if& (\\associative/ \&and& (\\precedence/ = \\outer-precedence/))
@  @  @   \&or& (\\precedence/ $<$ \\outer-precedence/)
@  @  \&then& \\term/\gets\!put a pair of brackets around \\term/!;
@  @  \&return& \\term/
@  \&end&
\&end&;
\endDOC The function {\smalltt mktag}: This function deals with the
transformation from prefix notation to \TeX\ notation. One important
task of it is to decide whether or not brackets should be placed
around the term.\par
% ----------------------------------------------------------------------
At this point, the way we use our LISP pseudo-code should be
explained. Words typeset in boldface are reserved words, e.g.
\&begin& and \&end&. We use a PASCAL-like syntax which is actually
used by REDUCE-Lisp, too, but with a few differences: we use the
word \&function& to indicate that a value is returned\note{REDUCE-Lisp
uses the phrase ``symbolic procedure'' here.}, and
we use \&return& to return the value of the function and therefore
to exit the function. This is in contrast to the use of \t{return}
in REDUCE-Lisp, where \t{return} is used only to return the value
of a begin-end-block. Identifiers are printed in italics. Where
identifiers are used as logical values, e.g. in conditions, they
are either false if their value is \&nil& or true otherwise,
regardless of their exact value. Pseudo-operations are printed
in roman and are put in angle brackets. Comments, too, are printed
in roman but they are put in curly brackets. Assignments are
typeset by the assignment operator \gets, thus indicating the
direction of assignment. Semicolons are used (as in PASCAL and REDUCE) as
separators. In order to improve readability, mathematical expressions
are given in mathematical form instead of real code. Finally,
the operator {\tt ::=} is used to identify a pseudo-code-operation
with its real code. We do not provide proper data type declarations
for variables since this seems to be superfluous in LISP where you
only deal with atoms and lists.
% ----------------------------------------------------------------------
\DOC
\&function& \\makefunc/(\\functor/,\\argument-list/,\\precedence/);
\&begin&
@  \\term/\gets\&nil&;
@  \\pattern/\gets\!pattern of this functor or default pattern!;
@  \&while& \\pattern/ \&do& \[as long as pattern isn't empty]
@  \&begin&
@  @  \\tag/\gets\&car& \\pattern/;
@  @  \\pattern/\gets\&cdr& \\pattern/;
@  @  \&if& \!\\tag/ is an atom! \&then& \\aux/\gets\&nil&
@  @  \&else if& \!tag is (F)! \&then& \\aux/\gets\!get the \TeX-item for%
  \\functor/!
@  @  \&else if& \!\\argument-list/ is empty! \&then& \\aux/\gets\&nil&
@  @  \&else if& \!tag is (X)! \&then&
@  @  \&begin&
@  @  @  \\aux/\gets\\mktag/(\&car& \\argument-list/,\\precedence/,\&nil&);
@  @  @  \\argument-list/\gets\&cdr& \\argument-list/
@  @  \&end&
@  @  \&else if& \!tag is (Y)! \&then&
@  @  \&begin&
@  @  @  \\aux/\gets\\mktag/(\&car& \\argument-list/,\\precedence/,\&T&);
@  @  @  \\argument-list/\gets\&cdr& \\argument-list/
@  @  \&end&
@  @  \&else if& \!tag is (R)! \&then& \[tail recursive pattern]
@  @  @  \&if cdr& \\argument-list/ \[more than one argument remaining?]
@  @  @  \&then begin&
@  @  @  @  \\pattern/\gets\!pattern for \\functor/!;
@  @  @  @  \\argument-list/\gets\&nil&
@  @  @  \&end&
@  @  @  \&else begin&
@  @  @  @  \\aux/\gets\\mktag/(\&car& \\argument-list/,\\precedence/,%
\&nil&);
@  @  @  @  \\argument-list/\gets\&cdr& \\argument-list/
@  @  @  \&end&
@  @  \&else if& \!tag is (L \\hs/), (M \\vs hs/) or (APPLY xxx)! \&then&
@  @  \&begin&
@  @  @  \\aux/\gets\!result from call to a special routine!;
@  @  @  \\argument-list/\gets\&nil&
@  @  \&end&
@  @  \&else& \\aux/\gets\&nil&;
@  @  \&if& \\aux/ \&then& \!concatenate it to the end of term!
@  \&end&;
@  \&return& \\term/
\&end&;
\endDOC The function {\smalltt makefunc}: As well as the function
{\smalltt mktag} this function performs the prefix-to-\TeX\
notation. Its major task is to ``unify'' operators and their
arguments with predefined patterns in order to build up lists of
\TeX-items.\par
% ----------------------------------------------------------------------
You can bind a \TeX-item to any REDUCE atom (except the
operators) you like. This is supported by binding the \TeX-item
to the specific atom by its property \t{'TEXNAME}.
You  can  choose  to  have  some  default  \t{'TEXNAME}
properties for your variables. Function \t{makeset} defines a set of
such default names. At the moment, two sets are provided for greek
and for lowercase letters. Refer to the User's Guide for how you can
use them.\par
But now turn back to the state of modifications our example term
has undergone. With our set of functions we have expanded the prefix form
into a \TeX-item list consisting of single \TeX-items such as
numbers, letters, \TeX-macros, \TeX-primitives and other \TeX\
symbols. The result is shown in figure 5. The \verb|\cdot|
command is the multiplication sign, whereas \verb|^{| indicates
the beginning of a superscript. (The term has been edited by hand
to provide for proper indentation.)\par
% ----------------------------------------------------------------------
\VFig
(              x ^{ 1 2 }
-   1 2 \cdot  x ^{ 1 1 } \cdot  y
+   6 6 \cdot  x ^{ 1 0 } \cdot  y ^{   2 }
- 2 2 0 \cdot  x ^{   9 } \cdot  y ^{   3 }
+ 4 9 5 \cdot  x ^{   8 } \cdot  y ^{   4 }
- 7 9 2 \cdot  x ^{   7 } \cdot  y ^{   5 }
+ 9 2 4 \cdot  x ^{   6 } \cdot  y ^{   6 }
- 7 9 2 \cdot  x ^{   5 } \cdot  y ^{   7 }
+ 4 9 5 \cdot  x ^{   4 } \cdot  y ^{   8 }
- 2 2 0 \cdot  x ^{   3 } \cdot  y ^{   9 }
+   6 6 \cdot  x ^{   2 } \cdot  y ^{ 1 0 }
-   1 2 \cdot  x          \cdot  y ^{ 1 1 }
+                                y ^{ 1 2 } )
\endverbatim
\endVFig A \TeX-item list: A \TeX-item is either a letter, a digit or
another plain character, or it is a \TeX-command. Every \TeX-item
belongs to one out of eight \TeX-item-classes.\par
% ----------------------------------------------------------------------
The last box in this chapter (i.e. figure 6) is a verbatim copy of the
output from TRI for our example.
Because our example will be used to demonstrate
line-breaking, too, some additional commands appear which won't occur
in normal \TeX-mode. These additional commands you find at the beginning
and ending of the output and as \verb|\nl|-commands within the output.
Nevertheless, the structure of the output would be much the same with
our normal \TeX-mode.
% ----------------------------------------------------------------------
\VFig
$$\displaylines{\qdd
x^{12}
-12\cdot x^{11}\cdot y
+66\cdot x^{10}\cdot y^{2}
-220\cdot x^{9}\cdot y^{3}
+495\cdot x^{8}\cdot y^{4}
-792\cdot x^{7}\cdot y^{5}\nl
+924\cdot x^{6}\cdot y^{6}
-792\cdot x^{5}\cdot y^{7}
+495\cdot x^{4}\cdot y^{8}
-220\cdot x^{3}\cdot y^{9}
+66\cdot x^{2}\cdot y^{10}
-12\cdot x\cdot y^{11}
+y^{12}
\Nl}$$
\endverbatim
\endVFig Output produced by the TRI: This \TeX-code has to be postprocessed
by \TeX. This example includes commands for line-breaking as produced
with the second level of TRI.\par
% ----------------------------------------------------------------------
The actual printing of TRI output in this example is easily readable
since the expression is not deeply nested.  Complications arise if
expressions to be printed are deeply nested, use many subscripts
and superscripts, have fractions and large operators and the like.
Then output  structure is worsened, especially if the whole expression
extends over several lines. We provide a ``cheap'' way of indentation
to retain some of the structure, but our solution is far from perfect.
As the need for post-TRI-editing rises the output from TRI should be
made better. However, our quick-and-dirty solution should suffice.
% ----------------------------------------------------------------------
\sec Breaking REDUCE expressions into lines\par
% ----------------------------------------------------------------------
As mentioned earlier, there are a few properties bound to each
\TeX-item, two of them dealing with line-breaking.
The following list gives you a survey of these two properties and
the values they can take:\par
\smallskip\itemize{17mm}
\litem{\t{'CLASS}}one of the following class specifiers
\itemitem{\t{'ORD\ }}ordinary symbols
\itemitem{\t{'LOP\ }}large operators, such as integrals
\itemitem{\t{'BIN\ }}binary operators
\itemitem{\t{'REL\ }}relational operators
\itemitem{\t{'OPN\ }}opening symbols (left parentheses)
\itemitem{\t{'CLO\ }}closing symbols (right parentheses)
\itemitem{\t{'PCT\ }}punctuation symbols
\itemitem{\t{'INN\ }}inner \TeX\ group delimiters
\litem{\t{'TEXTAG}}this is either an atom describing an \t{'INN} class
or a list of widths defining the width of a \TeX-item, where
succeeding elements of the list will be used depending on the
\TeX\ inner group level (i.e. the nesting of subscripts or superscripts)
\par\enditemize\smallskip\noindent
Glue items are to be inserted between consecutive \TeX-items (similar to
what \TeX\ does with its items). The following table specifies for
each left and right class of a \TeX-item the corresponding glue measure.
The glue item values have following meanings: 0 = no space,
1 = thin space, 2 = medium space, and 3 = thick space.
An asterisk means that this case never arises, and
values put in brackets indicate no space in the case of sub- or
superscripts.\par
%
\midinsert
\def\tablerule{\noalign{\hrule}}
$$\vbox{\offinterlineskip
\halign{&\vrule#&\quad\hfil\tt#\hfil\quad\cr
\tablerule
&\strut\rm Left&&\multispan{15}\hfil\rm Right Class\hfil&\cr
&&&\multispan{15}\hrulefill&\cr
&\strut\rm Class&&ORD&&LOP&&BIN&&REL&&OPN&&CLO&&PCT&&INN&\cr
\tablerule
&\strut ORD&&0&&1&&(2)&&(3)&&0&&0&&0&&0&\cr
&\strut LOP&&1&&1&&*&&(3)&&0&&0&&0&&(1)&\cr
&\strut BIN&&(2)&&(2)&&*&&*&&(2)&&*&&*&&(2)&\cr
&\strut REL&&(3)&&(3)&&*&&0&&(3)&&0&&0&&(3)&\cr
&\strut OPN&&0&&0&&*&&0&&0&&0&&0&&0&\cr
&\strut CLO&&0&&1&&(2)&&(3)&&0&&0&&0&&0&\cr
&\strut PCT&&(1)&&(1)&&*&&(1)&&(1)&&(1)&&(1)&&(1)&\cr
&\strut INN&&0&&1&&(2)&&(3)&&(1)&&0&&(1)&&0&\cr
\tablerule}}$$
\endinsert
Actually, a glue item is a list consisting of two elements --- a width
info characterizing the width of this item (in scaled points)
and a ``penalty'' to be used if a line should be broken at
this point.
The algorithm for inserting glue items is easily described:
for every consecutive pair of \TeX-items, get their classes and create
a glue item according to the value found in the glue item table.
For some special \TeX-items use special penalties instead of the default
values. That's all.\par
Let us return to our example from the last chapter. When the functions
\t{insertglue} and \t{interglue} have finished, the \TeX-item list
will be left (temporarily) extended with glue items. You can find
them as the two-element lists in the example. All glue items there
have (by chance) the same width 163840. But they have different
penalties 0, 50 and -390. The latter therefore indicates a very good breaking
point because it is a negative penalty, i.e. a bonus.
See the following figure 7 for the changes made to the \TeX-item list.
% ----------------------------------------------------------------------
\VFig
(                          x ^{ 1 2 } (163840 0)
-   1 2 \cdot  (163840 50) x ^{ 1 1 } \cdot  (163840 50) y          %
(163840 -390)
+   6 6 \cdot  (163840 50) x ^{ 1 0 } \cdot  (163840 50) y ^{   2 } %
(163840    0)
- 2 2 0 \cdot  (163840 50) x ^{   9 } \cdot  (163840 50) y ^{   3 } %
(163840 -390)
+ 4 9 5 \cdot  (163840 50) x ^{   8 } \cdot  (163840 50) y ^{   4 } %
(163840    0)
- 7 9 2 \cdot  (163840 50) x ^{   7 } \cdot  (163840 50) y ^{   5 } %
(163840 -390)
+ 9 2 4 \cdot  (163840 50) x ^{   6 } \cdot  (163840 50) y ^{   6 } %
(163840    0)
- 7 9 2 \cdot  (163840 50) x ^{   5 } \cdot  (163840 50) y ^{   7 } %
(163840 -390)
+ 4 9 5 \cdot  (163840 50) x ^{   4 } \cdot  (163840 50) y ^{   8 } %
(163840    0)
- 2 2 0 \cdot  (163840 50) x ^{   3 } \cdot  (163840 50) y ^{   9 } %
(163840 -390)
+   6 6 \cdot  (163840 50) x ^{   2 } \cdot  (163840 50) y ^{ 1 0 } %
(163840    0)
-   1 2 \cdot  (163840 50) x          \cdot  (163840 50) y ^{ 1 1 } %
(163840 -390)
+                                                        y ^{ 1 2 } )
\endverbatim
\endVFig A \TeX-item list extended with glue items: \par
%
%
Setting break points requires the creation of a ``breaklist''.
A  breaklist is a sequence of passive and active nodes, where each
active node is followed by a passive node and vice versa.
Active nodes represent glue items.
Passive nodes are integer atoms which represent the width of a sequence
of ordinary \TeX-items which must not be interspersed with glue
items.  Each breaklist consists of (at least one) passive nodes surrounded
by delta nodes representing the beginning and ending of the list.
\medskip
\settabs\+\indent&passive-node\quad&\cr
\+&\i{breaklist}    &::= ( \i{delta-node} \i{inner-list} \i{delta-node} )\cr
\+&\i{inner-list}   &::= \i{passive-node} \i{active-node} \dots
                         \i{passive-node}\cr
\+&\i{active-node}  &::= ( \i{width} \i{penalty} \i{offset} )\cr
\+&\i{passive-node} &::= \i{width}\cr
\+&\i{delta-node}   &::= \i{active-node} $+$ \i{appendix}\cr
\+&\i{appendix}     &::= ( \i{id-number} \i{ptr} \i{demerits}
                         \i{indentation} )\cr
\medskip
The breaklist will be created using the function \t{breaklist}.
line breaking is performed with this list only; the \TeX-item list
becomes modified only indirectly since the active nodes are shared.
That means that the active nodes aren't copied while creating the breaklist.
Instead, their memory addresses are put into the breaklist as a reference.
This is both memory saving and necessary, since later we deal
with the \TeX-item list itself again in order to insert \verb|\nl|-commands.
So remember there exist two lists sharing all the active nodes
(and hence all the delta nodes). Figure 8 contains
the breaklist from our $(x-y)^{12}$ example. Bear in mind that
passive nodes are sums of widths. The first line and the last line contain
the beginning and ending delta nodes, respectively.
By default, their \i{id-numbers} are 0 and -1, respectively.
%
% ----------------------------------------------------------------------
\VFig
((0 0 0 0 0 0 0)
 915227 (163840    0 0) 1347128 (163840 50 0) 1097271 (163840 50 0)
 321308 (163840 -390 0) 1347128 (163840 50 0) 1097271 (163840 50 0)
 598015 (163840    0 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840 -390 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840    0 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840 -390 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840    0 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840 -390 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840    0 0) 1674808 (163840 50 0)  820564 (163840 50 0)
 598015 (163840 -390 0) 1347128 (163840 50 0)  820564 (163840 50 0)
 874722 (163840    0 0) 1347128 (163840 50 0)  543857 (163840 50 0)
 874722 (163840 -390 0) 1384446
 (0 0 41140184 -1 0 2147483647 0))
\endverbatim
\endVFig  A breaklist: Three types of objects are included in a breaklist.
Active nodes are the lists with three elements. Delta nodes contain
exactly seven elements. Passive nodes are integer atoms representing
a width.\par
% ----------------------------------------------------------------------
%
The task of setting the break points (i.e. break items) in the breaklist
is up to the function \t{trybreak}. During  this  phase, some active nodes
are selected as ``feasible'' break points. Thus, they will be extended and
called ``delta nodes'' furtheron. By default, the first and last node in a
breaklist are delta nodes.  When trybreak has finished, the \i{ptr}'s of
the delta nodes point back to the best preceding delta node
in terms of minimal total demerits. So, by stepping through this pointer
list, it is easy to find the best path for breaking the whole breaklist
apart. We use some terminology we'd like to explain:
\itemize{27mm}\medskip
\litem{\i{width}}width of this item (both active and passive nodes)
\litem{\i{penalty}}a numeric value which prohibits line breaking (if
negative, line breaking will be merited)
\litem{\i{offset}}distance to the most recent opening bracket
\litem{\i{id-number}}the identification number of this delta node (1,2,3,...)
\litem{\i{ptr}}pointer to the best delta node to come from with
respect to the minimal demerits path. (Note: a zero
pointer indicates the very beginning of the breaklist)
\litem{\i{demerits}}total demerits accumulated so far
\litem{\i{indentation}}amount of indentation when breaking at this point
\par\enditemize\medskip
The algorithm itself will be described now.
To determine the ``quality'' of a line we introduce a value called
``badness''. It simply is a heuristic describing how good-looking a
line comes out. This concept is due to Knuth/Plass(1981) and is a major
concept
of \TeX. We use a slightly different heuristic here. We do not measure
badness in terms of ``stretchability'' and ``shrinkability''.
Instead we measure how ``full'' a line is, where ``full''
means that three quarters of the page width are optimal.
Furthermore we add a surplus badness for the indentation: the less
indentation the better.
The badness is a value between 0 and 10000 and is calculated with
the following code (displayed in figure 9).
Surprisingly, we got a higher speed with floating point arithmetic
here than with integer arithmetic.
% ----------------------------------------------------------------------
\DOC
\&function& \\badnessof/(\\length/,\\indentation/);
\&begin&
@  \\temp/\gets\&abs&(\\length/$-{3\over4}*$\\pagewidth/)/(${1\over6}*$%
\\pagewidth/);
@  \&return min&($10000,100*temp^3+2500*$\\indentation/$/$\\pagewidth/)
\&end&;
\endDOC The badness function: ``Badness'' is just a heuristic to compute
a numerical value describing how ``good-looking'' a line comes out.
A correction term is applied to provide for indentation.\par
% ----------------------------------------------------------------------
Figure 10 summarizes the line breaking algorithm. The code
is part of the function \t{trybreak} and describes the ``heart'' of
our algorithm.
Basically, it consists of two loops: the outer loop steps through
the breaklist considering each delta node as a potential start of a
new line while the inner loop looks ahead exactly one line (bounded
by the \i{page-width} or by the rightmost delta-node) checking each
active node if it is a feasible breakpoint, and if so, saving it as the best
path of breaking. Or to put it in another way, simply imagine a
window as wide as a page which moves over the unbroken expression
from the very left to the very right. The left end of the window
is put on every feasible breakpoint determined earlier. The right
end of the window just defines the border of the search for feasible
breakpoints within the window.
% ----------------------------------------------------------------------
\DOC
\\bottom/\gets\\breaklist/;\quad\\pagewidth/\gets\ %
\!user defined page width!;
\!set all variables not mentioned explicitly to zero or nil!;
\&while& \\bottom/ \&do&
\&begin&  \[try a new line starting at this delta node]
@  \\base/\gets\&car& \\bottom/; \\top/\gets\&cdr& \\bottom/;
@  \\baseid/\gets\\idof/ \\base/; \\baseptr/\gets\\ptrof/ \\base/;
@  \\basedemerits/\gets\\demeritsof/ \\base/;
@  \\baseoffset/\gets\\offsetof/ \\base/;
@  \\baseindent/\gets\\length/\gets\\indentof/ \\base/;
@  \\total/\gets\\total/+\\widthof/ \\base/;
@  \&while& \\top/ \&and& \\length$<$pagewidth/ \&do&
@  \&begin& \[consider this node for end of the line]
@  @  \\node/\gets\&car& \\top/;
@  @  \\penalty/\gets\\penaltyof/ \\node/;
@  @  \&if& \!node is a passive node!
@  @  \&then& \\len/\gets\\len/+\\node/
@  @  \&else begin& \[node is an active node]
@  @  @  \\badness/\gets\ \!compute current badness from \\length/ and%
 \\baseindent/!
@  @  @  \\penalty/\gets\\penaltyof/ \\node/; \\offset/\gets\\offsetof/%
 \\node/;
@  @  @  \&if& \\badness $<$ tolerance/
@  @  @  \&or& \\badness $< 1-$penalty/
@  @  @  \&or& \!this is the rightmost delta node!
@  @  @  \&then begin& \[we have a feasible breakpoint]
@  @  @  @  \\demerits/\gets\\basedemerits/+\\badness/$^2+$\\penalty/$*$%
\&abs&(\\penalty/);
@  @  @  @  \&if& \!node is a delta node!
@  @  @  @  \&then begin&
@  @  @  @  @  \&if& \\demerits$<$demeritsof node/ \[better path found?]
@  @  @  @  @  \&then begin&
@  @  @  @  @  @  \!save current \\demerits/ and \\baseid/ to \\node/!;
@  @  @  @  @  @  \!compute amount of indentation!
@  @  @  @  @  \&end&
@  @  @  @  \&end&
@  @  @  @  \&else begin&
@  @  @  @  @  \\feasible/\gets\\feasible/+1;
@  @  @  @  @  \!create new delta node with \\feasible, baseid, demerits/!;
@  @  @  @  @  \!compute amount of indentation!
@  @  @  @  \&end&;
@  @  @  @  \&if& \\penalty/$=-10000$ \&then& \\top/\gets\&nil&%
 \[must break here]
@  @  @  \&end;&
@  @  @  \\length/\gets\\length/+\\wdithof node/
@  @ \&end&;
@  @ \&if& \\top/ \&then& \\top/\gets\&cdr& \\top/
@  \&end&;
@  \!save the total length so far to the delta node!;
@  \!step ahead to next delta node and count total length!
\&end&;
\endDOC The code segment from {\smalltt trybreak} dealing with line-breaking:
\par
% ----------------------------------------------------------------------
Earlier we introduced the concept of ``badness'' derived from \TeX.
But actually this is not the only measure answering the question whether
a certain point in the breaklist is feasible or not. There are three
conditions which decide whether a breakpoint is feasible or not.
The first condition requires the badness to be smaller than the value
of \i{tolerance} as specified by the user. This condition can be overridden
if the active node under consideration has a negative penalty whose
(absolute, i.e. positive) amount is greater than the badness.
That means you can buy a breakpoint if you've got enough money
(i.e. a bonus = negative penalty) to pay the price (i.e. the badness).
The third condition just forces the rightmost delta node to be
considered feasible anyway.\note{This is necessary since the end
of the expression is naturally a breakpoint even if it is a bad one,
and the last delta node is needed for accounting purposes as well as
for storing the pointer to the preceding breakpoints.}
At this point we introduce a second measure called ``demerits'' which
is defined as the sum of the demerits so far (i.e. up to the
beginning of the line currently under consideration), the squared
badness and the sign-propagated square of the penalty.\note{The
latter is evaluated as the product of the value (which can
be positive or negative) and the absolute value (which can be
positive only).} Now we have a measure which not only refers to
the current line but to the previous lines, too. Therefore, our
modified {\caps Knuth}-algorithm ``optimizes'' not only over
\i{one} line but over \i{all} lines.\par
Figure 11 should make clear what is happening to the breaklist
and the \TeX-item list. For readability purposes we display the latter,
but really it is the breaklist under consideration within \t{trybreak}.
As in the previous display of our example, you can identify the
active-nodes. These are the three element number lists. The third
element which is zero here is used as an offset width to the last
opening bracket. This information is used for indentation.
The delta-nodes are remarkable. These are the number lists with seven
elements. Count them by their fourth element. They run 0, 1, 2
through 8, 9, -1. The fifth element gives you the way back through the
list. Start at the last delta-node. There the best way to come from
is 1. So go to delta-node 1 where you find 0 as the best way to come
from. Delta-node 0 is the beginning, so you're finished. The sixth element
stands for the total demerits so far. The seventh element stands for
the amount of indentation. Here it is a zero because the term isn't
nested in our example.
% ----------------------------------------------------------------------
\VFig
(                                       (     0        0 0 0 0       0 0)
                             x ^{ 1 2 } (163840    0 0)
- 1 2   \cdot  (163840 50 0) x ^{ 1 1 }
        \cdot  (163840 50 0) y          (163840 -390 0)
+ 6 6   \cdot  (163840 50 0) x ^{ 1 0 }
        \cdot  (163840 50 0) y ^{   2 } (163840    0 0)
- 2 2 0 \cdot  (163840 50 0) x ^{   9 }
        \cdot  (163840 50 0) y ^{   3 } (163840 -390 0)
+ 4 9 5 \cdot  (163840 50 0) x ^{   8 }
        \cdot  (163840 50 0) y ^{   4 } (163840    0 0)
- 7 9 2 \cdot  (163840 50 0) x ^{   7 }
        \cdot  (163840 50 0) y ^{   5 } (163840 18624949 0 1 0 -151875 0)
+ 9 2 4 \cdot                           (163840 20463597 0 2 0    2500 0)
                             x ^{   6 }
        \cdot                           (163840 21448001 0 3 0    2500 0)
                             y ^{   6 } (163840 22209856 0 4 0       1 0)
- 7 9 2 \cdot  (163840 50 0) x ^{   5 }
        \cdot  (163840 50 0) y ^{   7 } (163840 25794763 0 5 0 -142299 0)
+ 4 9 5 \cdot  (163840 50 0) x ^{   4 }
        \cdot  (163840 50 0) y ^{   8 } (163840 0 0)
- 2 2 0 \cdot  (163840 50 0) x ^{   3 }
        \cdot  (163840 50 0) y ^{   9 } (163840 32964577 0 6 1 -207875 0)
+ 6 6   \cdot  (163840 50 0) x ^{   2 }
        \cdot  (163840 50 0) y ^{ 1 0 } (163840 0 0)
- 1 2   \cdot                           (163840 38009479 0 7 1 -149350 0)
                             x
        \cdot                           (163840 38717176 0 8 1 -149374 0)
                             y ^{ 1 1 } (163840 39755738 0 9 1 -303975 0)
+ y ^{ 1 2 }                            (     0 41140184 ?-1 1 -151866 ?)
\endverbatim
\endVFig A \TeX-item list extended with delta-nodes: From this list
the line-breaking way can be derived. Start with node --1, go to node
1 and from there to node 0. That makes one break point at node 1.\par
We haven't mentioned how we generate indentation yet. Generally speaking,
indentation is entirely directed by brackets, either round, curly, or
dummy brackets. But how do we compute the amount of indentation?
   First let's turn to the code segment which deals with this problem
within the big line-braking algorithm shown before. The contents of
figure 12 explains what happens to the amount of indentation.
% ----------------------------------------------------------------------
\DOC
\!compute amount of indentation! ::=
\&begin&
@  \&if& \\offset/$>$\\total/
@  \&then& \\indent/\gets\\offset$-$total$+$baseindent/ \ \ %
\[opening bracket case]
@  \&else if& \\offset$<$baseoffset/
@  @  \&then& \\indent/\gets\\findindent/() \ \ \ \ \ \ \ \ %
\ \ \ \[closing bracket case]
@  @  \&else& \\indent/\gets\\baseindent/; \ \ \ \ \ \ \ \ \ %
\ \ \ \ \[no change case]
@  \!save \\indent/ to delta-node!
\&end&;
\endDOC The code segment from {\smalltt trybreak} dealing with indentation:
\par
% ----------------------------------------------------------------------
The logic of this code segment is easily summarized. The \i{offset}
is a measure of how distant the last opening bracket is from the beginning
of the whole expression. So in the case where \i{offset} is greater than
the total width accumulated until the very beginning of the line, the
indentation is just the difference between \i{total}
 and the sum of \i{offset}
and the amount of indentation \i{baseindent} for the currently line.
That'll work if the line currently under consideration contains at least
one opening bracket which hasn't become closed in the same line.
This case may be labelled the ``opening bracket case''.
But what shall we do in the other cases? We have to decide if we've got
a ``closing bracket case'', i.e. if we have at least one more closing
bracket than we have opening brackets, or if we've got a ``no change
case'', i.e. the number of opening brackets in the current line matches
the number of closing brackets in this line. This decision is made by
comparing \i{offset}$<$\i{baseoffset}. If the \i{baseoffset}, i.e.
the offset at the beginning of the line, is greater than \i{offset},
i.e. the offset at the current point, then we've got the ``closing
bracket case'', otherwise we've got the ``no change case''.
In the latter, the amount of indentation for the next line is just
the amount of indentation for the current line. But the ``closing
bracket case'' causes us much trouble. So we need an extra function dealing
with this case, as displayed in figure 13.
% ----------------------------------------------------------------------
\DOC
\¯o function& \\findindent/;
\[macro functions share all variables of outer code blocks]
\&begin& \[first check if we can save search time for equal destination]
@  \&if& \\offset/$=$\\lastoffset/ \&and& \\baseptr/$=$\\lastbaseptr/
@  \&then return& \\lastindent/
@  \&else begin& \[search the delta-node-stack for previous indentation]
@  @  \\stack/\gets\\deltastack/; \\lastoffset/\gets\\offset/;
@  @  \\p/\gets\\lastbaseptr/\gets\\baseptr/;
@  @  \&while& \\stack/ \&do& \[as long as we have a delta-node ahead]
@  @  \&begin&
@  @  @  \\node/\gets\&car& \\stack/; \[current delta-node]
@  @  @  \&if& \\p$=$idof node/ \&then begin&
@  @  @  @  \\p/\gets\\ptrof node/; \\local/\gets\\totalof node/;
@  @  @  @  \&if& \\local$<$offset/ \&then& \\stack/\gets\&nil&
@  @  @  \&end&;
@  @  @  \&if& \\stack/ \&then& \\stack/\gets\&cdr& \\stack/
@  @  \&end&;
@  @  \\lastindent/\gets\\offset$-$local$+$indentof node/;
@  @  \&return& \\lastindent/
@  \&end&
\&end&;
\endDOC The macro function findindent: This macro is used to compute the
amount of indentation in the ``closing bracket case''. It causes some
trouble since we have to travel back to previous delta nodes.\par
% ----------------------------------------------------------------------
This macro\note{Macros become expanded where they are called and thus
share all variable names defined in the code block where they are called.
So, there is no need for argument passing if certain variable names in
the code block don't differ from call to call.} searches the list
of delta-nodes previously created until it reaches a delta-node (at
least the very first delta-node in the breaklist) where the total
width accumulated so far, i.e. the variable \i{local}, is less than
\i{offset}, i.e. the offset at the end of the line under consideration,
and computes the amount of indentation from the difference of
\i{offset} and \i{local} plus the amount of indentation so far.
Plainly speaking, we go back the lines until we find a line where
we find the opening parenthesis matching the closing parenthesis
in the current line. When we've found it, we compute the amount of
indentation as described in the ``opening bracket case'', but with
\i{local} instead of \i{total}.
% ----------------------------------------------------------------------
\sec Postprocessing with the \TeX\ module ``tridefs.tex''\par
% ----------------------------------------------------------------------
When a \TeX-output-file has been created with the TRI it has to be
processed by \TeX\ itself. But before you run \TeX\ you should make sure
the file looks the way you want it. Sometimes you will
find it necessary to add some \TeX-code of your own or delete some
other \TeX-code. This job is up to you before you finally run \TeX.\par
During the \TeX-run the sizes of brackets are determined. This task is
not done by the TRI. In order to produce proper sized brackets
we put some \verb|\left(| and \verb|\right)| \TeX-commands
where brackets are opened or closed. A new problem arises when
an expression has been broken up into several lines. Since, for every
line, the number of \verb|\left(| and \verb|\right)| \TeX-commands must
match but bracketed expressions may start in one line and end in another,
we have to insert the required number of ``dummy'' parentheses
(i.e.  \verb|\right.| and \verb|\left.| \TeX-commands)
at the end of the current line and the beginning of the following line.
Therefore, we have to keep track of the depth of bracketing.
See the following figure 14 for the \TeX-code actually applied.\par
There is a caveat against this method. Since opening and closing brackets
needn't lie in the same line, it is possible that the height of the
brackets can differ although they should correspond in height. That will
happen if the height of the text in the opening line has a height
different from the text in the closing line. We haven't found a
way of tackling this problem yet, but we think it is possible to program
a little \TeX-macro for this task.
Furthermore, some macros deal with tricks we had to use in order to
provide for indentation, fraction handling and the like.
\VVFig
\def\qdd{\quad\quad}         % simply a double quad
\def\frac#1#2{{#1\over#2}}   % fractions from prefix notation
\newcount\parenthesis        % nesting of brackets
\parenthesis=0               % intialize
\newcount\n                  % a temporary variable
% ---- round and curly brackets ----
\def\({\global\advance\parenthesis by1\left(}
\def\){\global\advance\parenthesis by-1\right)}
\def\{{\global\advance\parenthesis by1\left\lbrace}
\def\}{\global\advance\parenthesis by-1\right\rbrace}
\def\[{\relax} % dummy parenthesis
\def\]{\relax} % dummy parenthesis
% ---- provide for looping using tail recursion ----
%      \loop ...what... \repeat
\def\loop#1\repeat{\global\n=0\global\let\body=#1\iterate}
\def\iterate{\body\let\next=\iterate\else\let\next=\relax\fi\next}
% ---- conditions and statements for loop interior
\def\ldd{\ifnum\n<\parenthesis\global\advance\n by1
\left.\nulldelimiterspace=0pt\mathsurround=0pt}
\def\rdd{\ifnum\n<\parenthesis\global\advance\n by1
\right.\nulldelimiterspace=0pt\mathsurround=0pt}
% ---- newline statement as issued by TRI ----
\def\nl{\loop\rdd\repeat\hfill\cr\quad\quad\loop\ldd\repeat{}}
% ---- indentation statement as issued by TRI ----
\def\OFF#1{\hskip#1sp\relax}
% ---- last newline statement before end of math group ----
\def\Nl{\hfill\cr}
\endverbatim
\endVFig The file ``tridefs.tex'': This is the code you have
to use on the \TeX\ side in order to typeset output produced by our
TRI.\par
\noindent There is at least one more line of \TeX-code you have to
insert by hand into the \TeX-input-file produced by TRI. This line runs
\verbatim
\input tridefs
\endverbatim\noindent
and inputs the module \t{tridefs.tex} into the file. This is necessary
because otherwise \TeX\ won't know how to deal with our macro calls.
If you use the \TeX-input-file as a ``stand-alone'' file, don't
forget a final \verb|\bye| at the end of the text. If you use
code produced by TRI as part of a larger text then simply put
the input-line just once at the beginning of your text.
% ----------------------------------------------------------------------
\sec Experiments\par
% ----------------------------------------------------------------------
We measured performance using the TIME-facility of REDUCE, which can be
switched on and off with the two commands
\example
ON TIME;
OFF TIME;
\endexample
We have tested our TRI on a \VAX\ operating under VAX/VMS,
with no other users operating during this phase in order to minimize
interference with other processes, e.g. caused by paging.
The TRI code has been compiled with the PSL~3.2a-Compiler.
The following table presents results obtained with a small number of
different terms. All data were measured in CPU-seconds
as displayed by LISP's TIME-facility.
For expressions where special packages such as \t{solve} and \t{int}
were involved we have taken only effective output-time, i.e. the time
consumption caused by producing the output and not by evaluating
the algebraic result.\note{That means we assigned the result of an
evaluation to an itermediate variable, and then we printed this
intermediate variable. Thus we could eliminate the time overhead
produced by ``pure'' evaluation. Nevertheless, in terms of effective
interactive answering time, the sum of evaluation and printing time
might be much more interesting than the ``pure'' printing time.
In such a context the percentage overhead caused by printing is
the critical point. But since we talk about printing we decided
to document the ``pure'' printing time.}\par
\def\strut{\vrule height8pt depth4pt width0pt}
\def\tablerule{\noalign{\hrule}}
\def\hdbox#1{\hbox to 12truemm{\small\hfil#1\hfil}}
\def\[#1]{$\scriptstyle#1$\hfil}
$$\vbox{
\offinterlineskip
\halign{&\strut\vrule#&\quad\hfil\smalltt#\quad\cr
\tablerule
&{\smallbf REDUCE-}\hfil&&\hdbox{\small nor-}&&
\hdbox{TeX}&&\hdbox{\small TeX-}&&\hdbox{\small TeX-}&\cr
&{\smallbf Expression}\hfil&&\hdbox{\small mal}&&
&&\hdbox{\small Break}&&\hdbox{\small Indent}&\cr
\tablerule
&\[(x+y)^{12}]&& 0.82&& 0.75&& 3.42&& 3.47&\cr
&\[(x+y)^{24}]&& 2.00&& 2.22&&12.52&&12.41&\cr
&\[(x+y)^{36}]&& 4.40&& 4.83&&21.48&&21.44&\cr
&\[(x+y)^{16}/(v-w)^{16}]&& 2.27&& 2.38&&12.18&&12.19&\cr
&\[solve((1+\xi)x^2-2\xi x+\xi,x)]&& 0.41&& 0.62&& 0.89&& 0.87&\cr
&\[solve(x^3+x^2\mu+\nu,x)]&& 4.21&&20.84&&31.82&&40.43&\cr
\tablerule
}}$$\vskip5pt
\noindent This short table should give you an impression of the
performance of TRI. It goes without saying that on other machines
results may turn out which are quite different from our results. But our
intention is to show the relative and not the absolute performance.
Note that printing times are a function of expression complexity,
as shown by rows three and six.
% ----------------------------------------------------------------------
\sec User's Guide to the REDUCE-\TeX-Interface\par
% ----------------------------------------------------------------------
If you intend to use the TRI you are required to load the compiled code.
This can be performed with the command
\example
load!-package 'tri;
\endexample
During the load, some default initializations are performed. The
default page width is set to 15 centimeters, the tolerance for
page breaking is set to 20 by default. Moreover, TRI is enabled
to translate greek names, e.g. TAU or PSI, into equivalent \TeX\
symbols, e.g. $\tau$ or $\psi$, respectively. Letters are printed
lowercase as defined through assertion of the set LOWERCASE. The whole
operation produces the following lines of output
\example
*** Function TEXVARPRI redefined
\% set GREEK asserted
\% set LOWERCASE asserted
\% \B hsize=150mm
\% \B tolerance 20
\endexample
Now you can switch on and off the three TRI modes as you like.
You can use the switches alternatively and incrementally.
That means you have to switch on TeX for receiving standard
\TeX-output, or TeXBreak to receive broken \TeX-output, or
TeXIndent to receive broken  \TeX-output plus indentation.
Thus, the three levels of TRI are enabled or disabled according to:
\example
On TeX;          \% switch TeX is on
On TeXBreak;     \% switches TeX and TeXBreak are on
On TeXIndent;    \% switches TeX, TeXBreak and TeXIndent are on
Off TeXIndent;   \% switch TeXIndent is off
Off TeXBreak;    \% switches TeXBreak and TeXIndent are off
Off TeX;         \% all three switches are off
\endexample
More specifically, if you switch off {\tt TeXBreak} you implicitly quit
{\tt TeXIndent}, too, or, if you switch off {\tt TeX} you implicitly quit
{\tt TeXBreak} and, consequently, {\tt TeXIndent}.\par
The most crucial point in defining how TRI breaks multiple lines
of \TeX-code is your choice of the page width and the tolerance.
As mentioned earlier, ``tolerance'' is related to \TeX's famous
line-breaking algorithm. The value of ``tolerance'' determines which
potential breakpoints are considered feasible and which not. The
higher the tolerance, the more breakpoints become feasible as determined
by the value of ``badness'' associated with each breakpoint. Breakpoints
are considered feasible if the badness is less than the tolerance.
You can easily set values for page width and tolerance using
\example
TeXsetbreak(\i{page-width},\i{tolerance});
\endexample
where \i{page-width} is measured in millimeters\note{You can
also specify page width in scaled points (sp).
Note: 1~pt = 65536~sp = 1/72.27~inch. The function automatically chooses
the appropiate dimension according to the size: all values greater than
400 are considered to be scaled points.} and the \i{tolerance} is
a positive integer in the closed interval $[0\ldots10000]$.
You should choose a page width according to your purposes,
but allow a few centimeters for errors in TRI's metric.
For example, specify 140 millimeters for an effective 150 or 160
millimeter wide page. That way you have a certain safety-margin to
the borders of the page. Now let's turn to the tolerance.
A tolerance of 0 means that actually no breakpoint will be considered
feasible (except those carrying a negative penalty), while a value
of 10000 allows any breakpoint to be considered feasible.
Obviously, the choice of a tolerance has a great impact on the time
consumption of our line-breaking algorithm since time consumption
increases in proportion to the number of feasible breakpoints.
So, the question is what values to choose. For line-breaking without
indentation, suitable values for the tolerance lie between 10 and 100.
As a rule of thumb, you should use higher values the deeper the term
is nested --- if you can estimate. If you use indentation, you have to
use much higher tolerance values. This is necessary because badness
is worsened by indentation. So, TRI has to try harder to find
suitable places where to break. Reasonable values for tolerance
here lie between 700 and 1500. A value of 1000 should be your first
guess. That'll work for most expressions in a reasonable amount of
time.\par
Sometimes you want to add your own REDUCE-symbol-to-\TeX-item
translations. For such a task, TRI provides a function named
\t{TeXlet} which binds any REDUCE-symbol to one of the predefined
\TeX-items. A call to this function has the following syntax:
\example
TeXlet(\i{REDUCE-symbol},\i{\TeX-item})
\endexample
Three examples show how to do it right:
\example
TeXlet('velocity,'!v);
TeXlet('gamma,\verb|'!\!G!a!m!m!a! |);
TeXlet('acceleration,\verb|'!\!v!a!r!t!h!e!t!a! |);
\endexample
Besides this method of single assertions you can choose to assert
one of (currently) two standard sets providing substitutions
for lowercase and greek letters. These sets are loaded by default.
You can switch these sets on or off using the functions
\example
TeXassertset \i{setname};
TeXretractset \i{setname};
\endexample
where the setnames currently defined are \t{'GREEK} and \t{'LOWERCASE}.
So far you have learned only how to connect REDUCE-atoms with predefined
\TeX-items but not how to create new \TeX-items itself. We provide a
way for adding standard \TeX-items of any class \t{'ORD, 'BIN, 'REL,
'OPN, 'CLO, 'PCT} and \t{LOP} except for class \t{'INN} which is
reserved for internal use by TRI only. You can call the function
\example
TeXitem(\i{item},\i{class},\i{list-of-widths})
\endexample
e.g. together with a binding
\example
TeXitem(\verb|'!\!n!a!b!l!a! |,'ORD,'(655360 327680 163840))
TeXlet('NABLA,\verb|'!\!n!a!b!l!a! |);
\endexample
where \i{item} is a legal \TeX-code name\note{Please note that
any \TeX-name ending with a letter must be followed by a blank
to prevent from interference with letters of following \TeX-items.
Note also that you can legalize a name by defining it as a \TeX-macro.},
\i{class} is one of seven classes (see above) and \i{list-of-width}
is a non-empty list of elements each one representing the width of
the item in successive super-/subscript depth levels. That means that the
first entry is the breadth in display mode, the second stands for
scriptstyle and the third stands for scriptscriptstyle in \TeX-%
terminology. But how can you retrieve the width information required?
For this purpose we provide the following small interactive \TeX\ facility
called \t{redwidth.tex} documented in figure 15. Simply call
\example
tex redwidth
\endexample
on your local machine. Then you are prompted for the \TeX-item
you want the width information for. Type ``end'' when you
want to finish the session.
\VVFig
\newbox\testbox\newcount\xxx\newif\ifOK\def\endloop{end }
\def\widthof#1{\message{width is: }\wwidthof{$\displaystyle#1$}
\wwidthof{$\scriptstyle#1$}\wwidthof{$\scriptscriptstyle#1$}}
\def\wwidthof#1{\setbox\testbox=\hbox{#1}\xxx=\wd\testbox
\message{[\the\wd\testbox=\the\xxx sp]}}
\loop\message{Type in TeX item or say 'end': }\read-1 to\answer
  \ifx\answer\endloop\OKfalse\else\OKtrue\fi
  \ifOK\widthof{\answer}
\repeat
\end
\endverbatim
\endVFig The file ``redwidth.tex'': This \TeX\ code you can use to
determine the width of specific \TeX-items.\par
Finally let us discuss how you can compile the TRI into a binary.
(We refer to PSL, but other LISP versions work quite similar.)
First of all start REDUCE. Than type in\par
\verbatim
on comp;
symbolic;
faslout "tri";
in "tri.red";
faslend;
bye;
\endverbatim\noindent
We stress the fact that this procedure is definitely LISP dependent.
Ask your local REDUCE or LISP wizards how to adapt to it.
% ----------------------------------------------------------------------
\sec Examples\par
% ----------------------------------------------------------------------
Some examples --- which we think might be representative ---
shall demonstrate the capabilities of our TRI.
For each example we state (a) the REDUCE command (i.e.
the input), (b) the tolerance if it differs from the default, and
(c) the output as produced in a \TeX\ run.\par
\newcount\exacount\exacount=0
\def\strut{\vrule height11pt depth4pt width0pt}
\def\exa#1 \mod#2 \tol#3 \cod#4 \^^M{\global\advance\exacount by1\par
{\offinterlineskip
  \vbox{
    \hrule
    \line{\strut\vrule
      \hbox to 8mm{\hfil\caps\the\exacount\hfil}\vrule
      \quad\rm#1\hfill\vrule
      \hbox to 32mm{\hfill{\smallcaps Mode: }{\tt #2}\hfill}\vrule
      \hbox to 32mm{\hfill{\smallcaps Tolerance: }{\tt #3}\hfill}\vrule}
    \hrule
    \line{\strut\vrule\hfill\tt#4\hfill\vrule}
    \hrule}
}\nobreak}
\bigskip\input tridefs
% ------------------------------ Examples ------------------------------
\exa Standard
\mod TeXindent
\tol 250
\cod (x+y){*}{*}16{/}(v-w){*}{*}16;
\
$$\displaylines{\qdd
\(x^{16}
  +16\cdot x^{15}\cdot y
  +120\cdot x^{14}\cdot y^{2}
  +560\cdot x^{13}\cdot y^{3}\nl
  \OFF{327680}
  +1820\cdot x^{12}\cdot y^{4}
  +4368\cdot x^{11}\cdot y^{5}
  +8008\cdot x^{10}\cdot y^{6}\nl
  \OFF{327680}
  +11440\cdot x^{9}\cdot y^{7}
  +12870\cdot x^{8}\cdot y^{8}
  +11440\cdot x^{7}\cdot y^{9}\nl
  \OFF{327680}
  +8008\cdot x^{6}\cdot y^{10}
  +4368\cdot x^{5}\cdot y^{11}
  +1820\cdot x^{4}\cdot y^{12}\nl
  \OFF{327680}
  +560\cdot x^{3}\cdot y^{13}
  +120\cdot x^{2}\cdot y^{14}
  +16\cdot x\cdot y^{15}
  +y^{16}
\)
/\nl
\(v^{16}
  -16\cdot v^{15}\cdot w
  +120\cdot v^{14}\cdot w^{2}
  -560\cdot v^{13}\cdot w^{3}\nl
  \OFF{327680}
  +1820\cdot v^{12}\cdot w^{4}
  -4368\cdot v^{11}\cdot w^{5}
  +8008\cdot v^{10}\cdot w^{6}
  -11440\cdot v^{9}\cdot w^{7}\nl
  \OFF{327680}
  +12870\cdot v^{8}\cdot w^{8}
  -11440\cdot v^{7}\cdot w^{9}
  +8008\cdot v^{6}\cdot w^{10}
  -4368\cdot v^{5}\cdot w^{11}\nl
  \OFF{327680}
  +1820\cdot v^{4}\cdot w^{12}
  -560\cdot v^{3}\cdot w^{13}
  +120\cdot v^{2}\cdot w^{14}
  -16\cdot v\cdot w^{15}
  +w^{16}
\)
\Nl}$$
\exa Integration
\mod TeX
\tol -;
\cod int(1/(x{*}{*}3+2),x)
\
$$
-
\(\frac{2^{\frac{1}{
                 3}}\cdot
        \(2\cdot
          \sqrt{3}\cdot
          \arctan
          \(\frac{2^{\frac{1}{
                           3}}
                  -2\cdot x}{
                  2^{\frac{1}{
                           3}}\cdot
                  \sqrt{3}}
          \)
          +
          \ln
          \(2^{\frac{2}{
                     3}}
            -2^{\frac{1}{
                      3}}\cdot x
            +x^{2}
          \)
          -2\cdot
          \ln
          \(2^{\frac{1}{
                     3}}
            +x
          \)
        \)
        }{
        12}
\)
$$
\exa Integration
\mod TeXindent
\tol 1000
\cod int(1/(x{*}{*}4+3*x{*}{*}2-1,x);
\
$$\displaylines{\qdd
\(\sqrt{2}\cdot
  \(3\cdot
    \sqrt{
          \sqrt{13}
          -3}\cdot
    \sqrt{13}\cdot
    \ln
    \(-
      \(\sqrt{
              \sqrt{13}
              -3}\cdot
        \sqrt{2}
      \)
      +2\cdot x
    \)
    \nl
    \OFF{2260991}
    -3\cdot
    \sqrt{
          \sqrt{13}
          -3}\cdot
    \sqrt{13}\cdot
    \ln
    \(\sqrt{
            \sqrt{13}
            -3}\cdot
      \sqrt{2}
      +2\cdot x
    \)
    \nl
    \OFF{2260991}
    +13\cdot
    \sqrt{
          \sqrt{13}
          -3}\cdot
    \ln
    \(-
      \(\sqrt{
              \sqrt{13}
              -3}\cdot
        \sqrt{2}
      \)
      +2\cdot x
    \)
    \nl
    \OFF{2260991}
    -13\cdot
    \sqrt{
          \sqrt{13}
          -3}\cdot
    \ln
    \(\sqrt{
            \sqrt{13}
            -3}\cdot
      \sqrt{2}
      +2\cdot x
    \)
    \nl
    \OFF{2260991}
    +6\cdot
    \sqrt{
          \sqrt{13}
          +3}\cdot
    \sqrt{13}\cdot
    \arctan
    \(\frac{2\cdot x}{
            \sqrt{
                  \sqrt{13}
                  +3}\cdot
            \sqrt{2}}
    \)
    \nl
    \OFF{2260991}
    -26\cdot
    \sqrt{
          \sqrt{13}
          +3}\cdot
    \arctan
    \(\frac{2\cdot x}{
            \sqrt{
                  \sqrt{13}
                  +3}\cdot
            \sqrt{2}}
    \)
  \)
\)
/104
\Nl}$$
\exa Solving Equations
\mod TeXindent
\tol 1000
\cod solve(x{*}{*}3+x{*}{*}2*mu+nu=0,x);
\
$$\displaylines{\qdd
\{x=
  \[-
    \(\(\(9\cdot
          \sqrt{4\cdot \mu ^{3}\cdot \nu
                +27\cdot \nu ^{2}}
          -2\cdot
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot
          \sqrt{3}\cdot \nu
        \)
        ^{\frac{2}{
                3}}\cdot
        \sqrt{3}\cdot i\nl
        \OFF{3675021}
        +
        \(9\cdot
          \sqrt{4\cdot \mu ^{3}\cdot \nu
                +27\cdot \nu ^{2}}
          -2\cdot
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot
          \sqrt{3}\cdot \nu
        \)
        ^{\frac{2}{
                3}}\nl
        \OFF{3675021}
        +2\cdot
        \(9\cdot
          \sqrt{4\cdot \mu ^{3}\cdot \nu
                +27\cdot \nu ^{2}}
          -2\cdot
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot
          \sqrt{3}\cdot \nu
        \)
        ^{\frac{1}{
                3}}\cdot \nl
        \OFF{3675021}
        2^{\frac{1}{
                 3}}\cdot 3^{\frac{1}{
                                   6}}\cdot
        \mu
        -2^{\frac{2}{
                  3}}\cdot
        \sqrt{3}\cdot 3^{\frac{1}{
                                  3}}\cdot
        i\cdot \mu ^{2}
        +2^{\frac{2}{
                  3}}\cdot 3^{\frac{1}{
                                    3}}\cdot
        \mu ^{2}
      \)
      /\nl
      \OFF{3347341}
      \(6\cdot
        \(9\cdot
          \sqrt{4\cdot \mu ^{3}\cdot \nu
                +27\cdot \nu ^{2}}
          -2\cdot
          \sqrt{3}\cdot \mu ^{3}
          -27\cdot
          \sqrt{3}\cdot \nu
        \)
        ^{\frac{1}{
                3}}\cdot 2^{\frac{1}{
                                  3}}\cdot
        3^{\frac{1}{
                 6}}
      \)
    \)
  \]
  \,\nl
  \OFF{327680}
  x=
  \[\(\(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{2}{
              3}}\cdot
      \sqrt{3}\cdot i\nl
      \OFF{2837617}
      -
      \(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{2}{
              3}}\nl
      \OFF{2837617}
      -2\cdot
      \(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{1}{
              3}}\cdot \nl
      \OFF{2837617}
      2^{\frac{1}{
               3}}\cdot 3^{\frac{1}{
                                 6}}\cdot \mu
      -2^{\frac{2}{
                3}}\cdot
      \sqrt{3}\cdot 3^{\frac{1}{
                                3}}\cdot i\cdot
      \mu ^{2}
      -2^{\frac{2}{
                3}}\cdot 3^{\frac{1}{
                                  3}}\cdot
      \mu ^{2}
    \)
    /\nl
    \OFF{2509937}
    \(6\cdot
      \(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}
    \)
  \]
  \,\nl
  \OFF{327680}
  x=
  \[\(\(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{2}{
              3}}\nl
      \OFF{2837617}
      -
      \(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot \nl
        \OFF{3675021}
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}\cdot \mu
      +2^{\frac{2}{
                3}}\cdot 3^{\frac{1}{
                                  3}}\cdot
      \mu ^{2}
    \)
    /\nl
    \OFF{2509937}
    \(3\cdot
      \(9\cdot
        \sqrt{4\cdot \mu ^{3}\cdot \nu
              +27\cdot \nu ^{2}}
        -2\cdot
        \sqrt{3}\cdot \mu ^{3}
        -27\cdot
        \sqrt{3}\cdot \nu
      \)
      ^{\frac{1}{
              3}}\cdot 2^{\frac{1}{
                                3}}\cdot 3^{
      \frac{1}{
            6}}
    \)
  \]
\}
\Nl}$$
\exa Matrix Printing
\mod TeX
\tol --
\cod mat((1,a-b,1/(c-d)),(a*{*}2-b*{*}2,1,sqrt(c)),((a+b)/(c-d),sqrt(d),1));
\
$$
\pmatrix{1&a
         -b&
         \frac{1}{
               c
               -d}\cr
         a^{2}
         -b^{2}&1&
         \sqrt{c}\cr
         \frac{a
               +b}{
               c
               -d}&
         \sqrt{d}&1\cr
         }
$$
% ----------------------------------------------------------------------
\sec Caveats\par
% ----------------------------------------------------------------------
Techniques for printing mathematical expressions are available
everywhere. This TRI adds only a highly specialized version for
most REDUCE output. The emphasis is on the word \i{most}.
One major caveat is that we cannot print SYMBOLIC-mode output
from REDUCE. This could be done best in a WEB-like programming-plus-%
documentation style. Nevertheless, as Knuth's WEB is already available
for PASCAL and C, hopefully someone will write a LISP-WEB or a
REDUCE-WEB as well.\par
Whenever you discover a bug in our program please let us
know. Send us a short report accompanied by an output listing.\note{You
can reach us with e-mail at the following addresses:
Werner Antweiler: antweil\@epas.utoronto.ca, Andreas Strotmann:
strotmann@rrz.uni-koeln.de and Volker Winkelmann:
winkelmann@rrz.uni-koeln.de.} We'll try to fix the error.
The whole TRI package consists of following files:\par
\itemize{3cm}
\litem{\tt tri.tex}This text as a \TeX-input file.\par
\litem{\tt tri.red}The REDUCE-LISP source code for the TRI.\par
\litem{\tt tridefs.tex}The \TeX-input file to be used together with
       output from the TRI.\par
\litem{\tt redwidth.tex}The \TeX-input file for interactive determination
       of \TeX-item widths.\par
\litem{\tt tritest.red}Run this REDUCE file to check if
       TRI works correctly.\par
\litem{\tt tritest.tex}When you have run {\tt tritest.red} just make a
       \TeX\ run with this file to see all the nice things TRI is able
       to produce.\par
\enditemize
% ----------------------------------------------------------------------
\sec References\par
% ----------------------------------------------------------------------
\aut Antweiler, W.; Strotmann, A.; Pfenning, Th.; Winkelmann, V.
\ttl Zwischenbericht "uber den Status der Arbeiten am
     REDUCE-\TeX-Anschlu\3
\pub Internal Paper, Rechenzentrum der Universit"at zu K"oln
\ref \\
\dat November 1986
\inx 1986
\
\aut Fateman, Richard J.
\ttl \TeX\ Output from MACSYMA-like Systems
\pub ACM SIGSAM Bulletin, Vol. 21, No. 4, Issue \#82
\ref pp. 1--5
\dat November 1987
\inx 1987
\
\aut Knuth, Donald E.; Plass, Michael F.
\ttl Breaking Paragraphs into Lines
\pub Software---Practice and Experience, Vol. 11
\ref pp. 1119--1184
\dat 1981
\inx 1981
\
\aut Knuth, Donald E.
\ttl The \TeX book
\pub Addison-Wesley, Readings/Ma.
\ref \\
\dat sixth printing, 1986
\inx 1986
\
\aut Hearn, Anthony C.
\ttl REDUCE User's Manual, Version 3.3
\pub The RAND Corporation, Santa Monica, Ca.
\ref \\
\dat July 1987
\inx 1987
\
\bye
mathpiper-0.81f+svn4469+dfsg3/src/packages/tri/redwidth.tex0000644000175000017500000000121411526203062023634 0ustar  giovannigiovanni\relax
% ---------------------------------------------------------------------
% Interactive module for retrieving width information for T.R.I.
% ---------------------------------------------------------------------
\newbox\testbox\newcount\xxx\newif\ifOK
\def\widthof#1{\message{width is: }
\wwidthof{$\displaystyle#1$}
\wwidthof{$\scriptstyle#1$}
\wwidthof{$\scriptscriptstyle#1$}}
\def\wwidthof#1{\setbox\testbox=\hbox{#1}
\xxx=\wd\testbox\message{[\the\wd\testbox=\the\xxx sp]}}
\def\endloop{end }
\loop\message{Type in TeX item or say 'end': }
  \read-1 to\answer
  \ifx\answer\endloop\OKfalse\else\OKtrue\fi
  \ifOK\widthof{\answer}
\repeat
\end
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/0000755000175000017500000000000011722677360021500 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/plot/bild2.ps0000644000175000017500000004774611526203062023044 0ustar  giovannigiovanni%!PS-Adobe-2.0
%%Creator: gnuplot
%%DocumentFonts: Helvetica
%%BoundingBox: 50 50 554 770
%%Pages: (atend)
%%EndComments
/gnudict 40 dict def
gnudict begin
/Color false def
/Solid false def
/gnulinewidth 5.000 def
/vshift -46 def
/dl {10 mul} def
/hpt 31.5 def
/vpt 31.5 def
/M {moveto} bind def
/L {lineto} bind def
/R {rmoveto} bind def
/V {rlineto} bind def
/vpt2 vpt 2 mul def
/hpt2 hpt 2 mul def
/Lshow { currentpoint stroke M
  0 vshift R show } def
/Rshow { currentpoint stroke M
  dup stringwidth pop neg vshift R show } def
/Cshow { currentpoint stroke M
  dup stringwidth pop -2 div vshift R show } def
/DL { Color {setrgbcolor Solid {pop []} if 0 setdash }
 {pop pop pop Solid {pop []} if 0 setdash} ifelse } def
/BL { stroke gnulinewidth 2 mul setlinewidth } def
/AL { stroke gnulinewidth 2 div setlinewidth } def
/PL { stroke gnulinewidth setlinewidth } def
/LTb { BL [] 0 0 0 DL } def
/LTa { AL [1 dl 2 dl] 0 setdash 0 0 0 setrgbcolor } def
/LT0 { PL [] 0 1 0 DL } def
/LT1 { PL [4 dl 2 dl] 0 0 1 DL } def
/LT2 { PL [2 dl 3 dl] 1 0 0 DL } def
/LT3 { PL [1 dl 1.5 dl] 1 0 1 DL } def
/LT4 { PL [5 dl 2 dl 1 dl 2 dl] 0 1 1 DL } def
/LT5 { PL [4 dl 3 dl 1 dl 3 dl] 1 1 0 DL } def
/LT6 { PL [2 dl 2 dl 2 dl 4 dl] 0 0 0 DL } def
/LT7 { PL [2 dl 2 dl 2 dl 2 dl 2 dl 4 dl] 1 0.3 0 DL } def
/LT8 { PL [2 dl 2 dl 2 dl 2 dl 2 dl 2 dl 2 dl 4 dl] 0.5 0.5 0.5 DL } def
/P { stroke [] 0 setdash
  currentlinewidth 2 div sub M
  0 currentlinewidth V stroke } def
/D { stroke [] 0 setdash 2 copy vpt add M
  hpt neg vpt neg V hpt vpt neg V
  hpt vpt V hpt neg vpt V closepath stroke
  P } def
/A { stroke [] 0 setdash vpt sub M 0 vpt2 V
  currentpoint stroke M
  hpt neg vpt neg R hpt2 0 V stroke
  } def
/B { stroke [] 0 setdash 2 copy exch hpt sub exch vpt add M
  0 vpt2 neg V hpt2 0 V 0 vpt2 V
  hpt2 neg 0 V closepath stroke
  P } def
/C { stroke [] 0 setdash exch hpt sub exch vpt add M
  hpt2 vpt2 neg V currentpoint stroke M
  hpt2 neg 0 R hpt2 vpt2 V stroke } def
/T { stroke [] 0 setdash 2 copy vpt 1.12 mul add M
  hpt neg vpt -1.62 mul V
  hpt 2 mul 0 V
  hpt neg vpt 1.62 mul V closepath stroke
  P  } def
/S { 2 copy A C} def
end
%%EndProlog
%%Page: 1 1
gnudict begin
gsave
50 50 translate
0.040 0.040 scale
0 setgray
/Helvetica findfont 140 scalefont setfont
newpath
LTb
3600 4829 M
(Enneper Surface) Cshow
LT0
LT1
4115 2259 M
433 -207 V
-244 -20 R
244 20 V
-697 211 R
453 -231 V
-453 231 R
264 -4 V
-363 199 R
354 -200 V
-255 5 R
-377 222 R
372 -224 V
-372 224 R
278 -27 V
LT0
2751 2928 M
371 85 V
-371 -85 R
30 -21 V
318 75 V
23 31 V
6 0 R
331 87 V
3099 2982 M
6 0 R
0 4 V
6 0 R
275 72 V
73 42 V
2347 2848 M
402 80 V
-402 -80 R
90 -12 V
342 68 V
-28 24 R
708 172 R
6 0 R
291 88 V
3386 3058 M
18 4 R
0 4 V
6 0 R
229 68 V
117 54 V
LT1
3457 2647 M
288 -188 V
-271 26 R
-306 211 R
306 -212 V
-306 212 R
289 -49 V
LT0
3756 3188 M
6 0 R
252 88 V
3639 3134 M
18 4 R
0 4 V
12 0 R
0 4 V
6 0 R
183 63 V
156 67 V
1914 2774 M
432 76 V
-432 -76 R
154 -3 V
360 68 V
-81 9 R
LT1
3225 2825 M
234 -180 V
-291 51 R
-237 199 R
240 -196 V
-240 196 R
294 -70 V
LT0
4014 3276 M
6 0 R
208 86 V
3858 3209 M
36 12 R
0 4 V
18 4 R
0 4 V
12 0 R
0 4 V
6 0 R
0 4 V
12 0 R
0 4 V
12 0 R
0 4 V
6 0 R
0 4 V
12 0 R
0 4 V
6 0 R
6 4 V
6 0 R
0 4 V
6 0 R
6 4 V
6 0 R
30 13 V
190 80 V
LT1
4309 2263 M
410 -185 V
-171 -26 R
6 0 R
165 26 V
-604 181 R
12 0 R
182 4 V
LT0
1454 2708 M
462 64 V
-462 -64 R
223 3 V
378 60 V
-141 3 R
1185 208 R
0 -4 R
7 -29 V
240 66 V
36 40 V
6 0 R
0 4 V
LT1
3963 2441 M
342 -180 V
-190 -2 R
-363 199 R
12 0 R
199 -17 V
LT0
2781 2907 M
6 -4 R
52 -20 V
264 68 V
-4 31 R
287 76 R
-40 -43 R
6 0 R
0 4 V
6 0 R
201 63 V
60 44 V
6 0 R
0 4 V
LT1
3054 2990 M
48 -44 R
114 -116 V
6 0 R
0 -4 V
-291 69 R
-170 185 R
108 -124 V
54 -60 R
6 -4 V
-168 188 R
276 -88 V
643 -383 R
276 -168 V
-204 17 R
-295 189 R
12 0 R
0 -4 V
6 0 R
205 -34 V
LT0
3639 3134 M
-80 -52 R
6 0 R
0 4 V
6 0 R
169 60 V
102 56 V
6 0 R
0 4 V
2437 2836 M
12 -4 R
102 -13 V
282 64 V
-52 24 R
LT1
4228 3362 M
6 0 R
162 82 V
4038 3282 M
66 36 R
6 0 V
12 8 R
6 0 V
6 4 R
6 0 V
0 4 R
6 0 V
0 4 R
12 0 V
0 4 R
18 7 V
220 95 V
3457 2768 M
222 -160 V
-222 39 R
-232 178 R
6 0 R
0 -4 V
6 0 R
220 -53 V
LT0
3858 3209 M
-118 -63 R
24 8 R
0 4 V
6 0 R
6 4 V
6 0 R
0 4 V
6 0 R
101 40 V
96 52 V
6 0 R
12 8 V
6 0 R
0 4 V
12 0 R
0 4 V
6 0 R
0 4 V
LT1
2943 3140 M
108 -144 V
-290 84 R
-107 169 R
108 -168 V
-108 168 R
289 -109 V
LT0
971 2650 M
486 60 V
971 2650 M
296 10 V
390 48 V
-203 0 R
614 63 R
18 0 R
157 -11 V
300 56 V
-106 20 R
LT1
3289 2914 M
162 -140 V
6 0 R
0 -4 V
-232 55 R
-171 165 R
90 -32 R
145 -44 V
LT0
3346 3015 M
-11 -41 R
12 40 V
-12 -40 R
174 57 V
48 48 V
6 0 R
0 4 V
3106 2949 M
31 -34 R
84 28 R
114 32 V
0 -1 R
224 108 R
-50 -51 R
6 0 R
0 4 V
6 0 R
136 51 V
78 56 V
6 0 R
0 4 V
LT1
4113 2433 M
325 -158 V
-129 -12 R
12 0 R
117 12 V
-475 166 R
12 0 R
138 -8 V
LT0
2839 2883 M
6 -4 R
75 -23 V
36 12 V
150 81 R
932 333 R
-149 -76 R
111 55 R
132 68 R
6 0 V
LT1
4396 3444 M
6 0 R
113 78 V
4176 3349 M
0 4 R
6 0 V
0 4 R
6 0 V
0 4 R
82 50 V
245 111 V
4438 2275 M
6 0 R
379 -165 V
-104 -32 R
6 0 R
98 32 V
-514 153 R
-464 319 R
264 -148 V
-146 7 R
-283 168 R
12 0 R
0 -4 V
6 0 R
147 -23 V
-959 692 R
54 -132 V
-286 107 R
-47 153 R
48 -152 V
-48 152 R
279 -128 V
290 -227 R
12 -12 V
72 -88 R
24 -28 V
6 0 R
0 -4 V
-236 75 R
-111 150 R
6 0 R
0 -4 V
6 0 R
221 -89 V
456 -324 R
198 -136 V
6 0 R
0 -4 V
-156 26 R
-223 159 R
6 0 R
0 -4 V
6 0 R
163 -41 V
LT0
3740 3146 M
-83 -60 R
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
101 41 V
90 60 V
6 0 R
0 4 V
6 0 R
0 4 V
1677 2711 M
18 0 R
223 -4 V
312 56 V
-162 8 R
483 48 R
12 0 R
122 -21 V
228 60 V
-74 25 R
LT1
3471 2853 M
156 -128 V
6 0 R
0 -4 V
-176 47 R
-168 146 R
6 0 R
0 -4 V
6 0 R
170 -57 V
-358 312 R
60 -116 V
6 0 R
0 -4 V
-236 95 R
-57 134 R
6 0 R
221 -109 V
1063 184 R
-176 -88 R
36 28 R
6 0 V
0 4 R
31 15 V
156 76 V
0 4 R
6 0 V
0 4 R
6 0 V
0 4 R
6 0 V
LT0
3335 2974 M
0 -4 R
11 -36 V
139 50 V
18 40 V
6 0 R
0 4 V
380 178 R
-113 -71 R
30 12 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
40 20 V
78 52 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
LT1
3358 2969 M
24 -28 R
84 -84 V
6 0 R
0 -4 V
-183 61 R
-113 133 R
6 0 R
0 -4 V
6 0 R
12 -8 V
-317 356 R
6 -116 V
-282 127 R
0 4 R
12 130 V
264 -145 V
LT0
3509 3031 M
-24 -47 R
6 0 R
0 4 V
6 0 R
105 42 V
48 52 V
6 0 R
0 4 V
2243 2760 M
18 0 R
174 -16 V
240 52 V
-124 23 R
LT1
4515 3522 M
0 4 R
66 66 V
4270 3411 M
0 4 R
6 0 V
0 4 R
41 46 V
264 127 V
LT0
3657 3086 M
-55 -56 R
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
75 33 V
78 60 V
6 0 R
0 4 V
2920 2856 M
6 -4 R
78 -20 V
0 -4 R
6 0 V
8 -1 R
119 88 R
LT1
3955 2565 M
250 -132 V
-92 0 R
12 0 R
80 0 V
-360 149 R
12 0 R
0 -4 V
6 0 R
92 -13 V
-199 125 R
186 -120 V
6 0 R
0 -4 V
-103 16 R
-213 141 R
6 0 R
0 -4 V
6 0 R
112 -29 V
-465 382 R
6 -12 V
-121 -13 R
-63 118 R
6 0 R
0 -4 V
6 0 R
166 -89 V
-194 193 R
12 -100 V
-223 109 R
-3 117 R
6 0 R
208 -126 V
506 -461 R
150 -112 V
6 0 R
0 -4 V
-127 35 R
-161 130 R
6 0 R
0 -4 V
6 0 R
120 -45 V
602 -371 R
6 0 R
295 -140 V
-68 -18 R
6 4 R
62 14 V
-393 140 R
-113 828 R
-136 -82 R
53 35 R
LT0
3776 3135 M
-81 -64 R
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
43 21 V
84 60 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
1267 2660 M
24 0 R
289 0 V
318 44 V
-221 7 R
LT1
3494 2906 M
102 -96 V
6 0 R
0 -4 V
-131 47 R
-113 116 R
42 -20 R
94 -43 V
4506 2293 M
6 0 R
351 -146 V
-40 -37 R
0 4 R
40 33 V
-425 128 R
2883 3391 M
0 4 R
47 93 V
-311 48 R
0 4 R
66 109 V
245 -161 V
LT0
3485 2984 M
-3 -43 R
0 44 V
0 -44 R
89 40 V
24 44 V
6 0 R
0 4 V
-255 -95 R
30 -38 R
78 32 R
30 12 V
-2 1 R
LT1
3267 3158 M
24 -84 V
-178 91 R
-16 100 R
6 0 R
164 -107 V
1003 253 R
4073 3308 M
0 4 R
6 0 V
0 4 R
24 32 V
210 112 V
0 4 R
6 0 V
LT0
2685 2798 M
12 0 R
136 -24 V
180 48 V
-93 34 R
682 174 R
-31 -49 R
6 0 R
0 4 V
6 0 R
58 29 V
42 48 V
6 0 R
0 4 V
6 0 R
0 4 V
LT1
3426 2995 M
48 -60 R
12 -24 V
6 0 R
0 -4 V
-134 62 R
-67 103 R
6 0 R
0 -4 V
6 0 R
6 -8 V
-212 205 R
0 4 R
30 78 V
-244 44 R
47 97 R
6 -4 R
191 -137 V
LT0
3864 3179 M
-102 -75 R
37 25 R
1918 2707 M
18 0 R
238 -12 V
246 52 V
-177 13 R
1452 311 R
-54 -57 R
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
31 17 V
60 60 V
6 0 R
0 4 V
6 0 R
0 4 V
LT1
3396 3069 M
-105 3 R
-24 86 R
6 -4 R
102 -72 V
316 -315 R
142 -101 V
-77 24 R
18 -4 R
0 -4 V
6 0 R
53 -16 V
-230 138 R
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
70 -29 V
-424 391 R
0 4 R
16 65 V
-186 38 R
30 82 R
6 -4 R
150 -116 V
307 -371 R
90 -84 V
6 0 R
0 -4 V
6 0 R
0 -4 V
-89 40 R
-109 102 R
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
72 -38 V
243 -190 R
6 0 R
178 -110 V
-62 9 R
12 0 R
0 -4 V
6 0 R
44 -5 V
-261 134 R
471 -489 R
60 -164 R
23 -64 V
-83 228 R
267 101 R
4310 1973 M
276 84 V
12 0 R
0 4 V
-632 72 R
26 -225 V
-26 225 R
84 24 V
177 44 R
3992 1908 M
318 64 V
4073 3308 M
-156 -94 R
16 26 R
36 24 R
6 0 V
0 4 R
120 76 V
0 4 R
6 0 V
LT0
3018 2827 M
110 -30 R
62 84 R
292 60 R
0 -4 R
6 -20 V
7 -15 R
12 4 R
52 32 V
12 44 V
LT1
3523 2933 M
12 -16 R
48 -56 V
6 0 R
0 -4 V
-95 49 R
-68 89 R
LT0
3571 2981 M
-12 -43 R
6 0 R
44 27 V
24 44 V
6 0 R
0 4 V
LT1
4017 2556 M
6 0 R
221 -116 V
-39 -7 R
12 0 R
27 7 V
-289 125 R
539 -263 R
6 0 R
262 133 V
205 -230 V
4637 2071 M
210 88 R
120 46 V
4581 3592 M
0 4 R
12 58 V
4317 3465 M
-3 45 R
0 -44 V
0 44 R
279 144 V
3688 1876 M
27 221 V
252 36 V
-1 0 R
3688 1876 M
306 32 V
2930 3488 M
0 4 R
94 72 V
-339 85 R
0 4 R
119 88 V
220 -177 V
372 -495 R
0 20 R
5 37 V
-134 32 R
16 69 R
6 -4 R
112 -97 V
LT0
3762 3104 M
-72 -65 R
18 12 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
6 12 V
6 0 R
12 16 V
6 0 R
6 12 V
6 0 R
12 16 V
6 0 R
0 4 V
6 0 R
0 4 V
6 0 R
0 4 V
2435 2744 M
18 0 R
186 -21 V
192 52 V
-146 23 R
LT1
3127 3347 M
6 4 R
67 58 V
-270 79 R
94 76 R
6 -4 R
170 -151 V
LT0
3641 3014 M
-32 -49 R
6 0 R
0 4 V
6 0 R
21 15 V
36 44 V
6 0 R
0 4 V
6 0 R
0 4 V
LT1
3283 3227 M
6 4 R
47 46 V
-209 70 R
73 62 R
6 -4 R
130 -128 V
581 -63 R
-118 -85 R
5 14 R
440 -703 R
6 0 R
270 -124 V
-14 -23 R
12 24 R
2 -1 V
-315 117 R
-719 610 R
-90 26 R
5 57 R
6 -4 R
24 -28 V
4762 2435 M
6 0 R
258 167 V
271 -228 V
4967 2205 M
6 0 R
324 169 V
3587 2885 M
61 -66 V
-58 37 R
24 -16 R
0 -4 V
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
16 -9 V
-125 114 R
18 -12 R
0 -4 V
6 0 R
40 -32 V
3403 1875 M
79 215 V
234 8 V
-28 -222 R
-285 -1 R
282 4 V
-37 940 R
0 -4 R
94 -74 V
-51 26 R
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
0 -4 V
6 0 R
27 -14 V
-152 115 R
339 -528 R
24 -124 R
18 -72 V
-42 196 R
209 70 R
3966 2133 M
172 265 R
108 48 R
105 53 V
108 -152 V
6 0 R
0 -4 V
4227 2201 M
-826 925 R
6 4 R
31 35 V
-155 62 R
53 50 R
6 -4 R
96 -108 V
LT0
3559 2938 M
0 -4 R
0 -28 V
2 -4 R
6 4 R
27 19 V
12 40 V
-111 -63 R
24 -32 R
40 68 R
LT1
4314 3510 M
4103 3348 M
-16 29 R
12 -28 V
-12 28 R
228 132 V
3553 2939 M
18 -32 R
6 -12 V
-54 38 R
-34 63 R
LT0
3690 3039 M
-48 -55 R
14 8 R
6 4 R
0 4 V
6 0 R
0 8 V
6 0 R
0 4 V
6 0 R
0 8 V
6 0 R
6 12 V
6 0 R
6 12 V
6 0 R
0 4 V
6 0 R
0 4 V
LT1
3742 2741 M
0 -4 R
127 -85 V
-36 14 R
18 -4 R
0 -4 V
6 0 R
12 -6 V
-178 115 R
LT0
2833 2774 M
12 0 R
146 -27 V
78 32 V
-51 48 R
LT1
3715 2097 M
0 4 R
12 186 V
54 12 V
148 29 R
3715 2097 M
LT0
3609 2965 M
-15 -40 R
6 4 R
14 10 V
24 44 V
6 0 R
0 4 V
LT1
3486 3043 M
-85 83 R
37 39 R
6 -4 R
36 -52 V
871 -610 R
6 0 R
204 132 V
198 -196 V
4494 2302 M
-695 827 R
-85 -74 R
-3 4 R
158 -407 R
6 0 R
158 -96 V
-16 0 R
12 0 R
4 0 V
-200 110 R
-497 611 R
6 0 R
82 29 V
-224 103 R
6 0 R
105 41 V
113 -144 V
LT0
3642 2984 M
-28 -45 R
7 2 R
6 4 R
0 8 V
6 0 R
0 8 V
6 0 R
0 8 V
6 4 R
0 8 V
6 0 R
0 8 V
6 0 R
0 4 V
LT1
3591 2896 M
18 -32 V
6 0 R
0 -8 V
6 -4 R
0 -4 V
-34 37 R
36 -32 R
0 -4 V
-70 90 R
24 -28 R
14 -15 V
LT0
3561 2902 M
11 -27 R
19 21 R
0 8 R
6 20 V
LT1
3200 3409 M
-176 155 R
6 0 R
132 53 V
144 -168 V
4520 2316 M
325 -128 R
12 -32 R
6 -12 V
-357 149 R
3438 3165 M
6 0 R
61 19 V
-169 93 R
88 29 R
0 -4 R
81 -118 V
116 -333 R
12 -8 R
0 -4 V
12 -8 R
0 -4 V
3 -8 R
-61 66 R
297 -393 R
150 60 R
0 4 V
6 0 R
6 7 V
12 -24 V
3929 2328 M
158 1049 R
3933 3240 M
-24 15 R
12 -8 V
-12 8 R
180 120 V
3482 2090 M
0 4 R
58 181 V
186 12 V
-11 -190 R
-233 -7 R
LT0
3594 2925 M
-3 -29 R
6 4 R
4 5 V
12 32 V
LT1
3024 3564 M
-220 177 R
6 0 R
162 68 V
192 -192 V
346 -544 R
-72 92 R
67 19 R
0 -4 R
30 -56 V
511 -561 R
6 0 R
157 101 V
144 -168 V
-215 -98 R
-412 51 R
0 -120 R
0 -44 V
0 164 R
158 43 R
3727 2287 M
-16 772 R
-55 -67 R
-9 -5 R
3141 1906 M
127 207 V
216 -24 V
-81 -214 R
-262 31 R
264 -32 V
1621 728 R
0 4 R
256 199 V
338 -226 V
5297 2374 M
6 0 R
317 205 V
LT0
3676 2793 M
66 -52 R
-94 78 R
LT1
4561 2631 M
0 4 R
204 161 V
258 -192 V
4762 2435 M
LT0
3614 2939 M
-13 -34 R
0 -4 R
2 2 V
0 4 V
6 4 R
0 4 V
6 8 R
0 8 V
6 4 R
0 8 V
LT1
3597 2894 M
6 -8 R
0 -4 V
-12 14 R
-12 32 R
18 -32 R
0 -4 V
LT0
3607 2868 M
14 -17 R
-30 45 R
1580 2660 M
24 0 R
299 -8 V
258 40 V
-243 15 R
LT1
4209 2664 M
0 4 R
158 127 V
198 -160 V
4351 2499 M
-704 488 R
-26 -46 R
-12 -12 R
225 -301 R
42 24 R
78 48 V
90 -140 V
-160 -68 R
-285 414 R
12 -4 R
-2 0 V
-23 42 R
20 -1 R
0 -36 R
3 -5 V
300 353 R
3804 3143 M
-30 3 R
108 92 R
6 0 V
0 4 R
18 12 V
3559 3084 M
-54 100 R
6 0 R
87 -2 V
12 -36 V
LT0
3601 2905 M
-2 -20 R
6 12 R
0 4 V
-6 -16 R
0 -6 R
6 12 R
0 12 V
-4 -28 R
6 -7 R
-10 26 R
LT1
3540 2275 M
0 4 R
36 144 V
4 10 R
146 16 R
3540 2275 M
66 668 R
18 -8 R
15 -11 V
-48 80 R
48 -80 R
0 36 V
LT0
3634 2829 M
42 -36 R
-55 58 R
LT1
3505 3184 M
-81 122 R
6 0 R
113 7 V
54 -132 V
LT0
3758 2725 M
110 -78 R
-126 94 R
LT1
3601 2884 M
6 -4 R
-1 -2 V
-7 28 R
7 -28 R
0 24 V
348 -202 R
0 4 R
118 95 V
138 -128 V
4046 2563 M
-437 339 R
6 -4 R
13 -18 V
-22 63 R
22 -63 R
12 44 V
LT0
3609 2853 M
19 -35 R
-21 50 R
LT1
3609 2929 M
-6 -26 R
-10 -17 R
13 -8 R
3 24 R
4 -47 R
6 8 R
6 20 V
-201 423 R
-113 144 R
6 0 R
143 17 V
84 -152 V
95 -391 R
6 -4 R
36 -36 V
-42 40 R
2 64 R
18 -8 R
46 -28 V
-24 -68 R
24 68 V
3268 2113 M
0 4 R
101 174 V
174 -16 V
-61 -185 R
-214 23 R
373 875 R
-12 86 R
84 -32 R
5 1 V
-13 -91 R
0 4 R
13 87 V
63 -305 R
12 -32 V
6 0 R
0 -4 V
-18 36 R
84 71 V
90 -104 V
-121 -77 R
-206 252 R
6 -4 R
17 -38 V
-23 42 R
11 44 R
12 -86 R
30 48 V
LT0
2174 2695 M
18 0 R
246 -19 V
186 44 V
-189 24 R
1165 105 R
8 -31 R
1 35 R
-9 -4 R
LT1
3697 2691 M
66 40 R
18 8 V
0 -1 R
-65 -156 R
58 564 R
-63 -87 R
-34 -9 R
4 -166 R
6 -4 R
43 -57 V
-49 61 R
24 68 R
6 -4 R
70 -55 V
-51 -70 R
51 70 V
-168 -38 R
15 25 R
-9 -67 R
24 20 R
6 4 V
-20 237 R
-31 108 R
6 0 R
66 -16 V
45 -9 R
0 -112 R
0 -4 V
15 -218 R
0 -4 R
54 -76 V
-54 80 R
51 70 R
6 -4 R
78 -80 V
-84 -71 R
-130 100 R
0 -8 R
6 -16 V
6 0 R
0 -4 V
-12 28 R
30 46 R
-6 -108 R
18 12 R
36 28 V
136 -7 R
6 4 R
72 94 V
126 -108 V
-115 -99 R
-279 76 R
55 47 R
-33 -132 R
375 108 R
6 4 R
104 124 V
180 -132 V
4209 2664 M
-504 288 R
13 91 R
6 0 R
100 -56 V
-43 -94 R
0 8 R
43 86 V
LT0
3628 2818 M
32 -45 R
-26 56 R
-6 -11 R
LT1
3619 2813 M
32 25 R
-29 -86 R
-311 698 R
-149 167 R
6 0 R
174 30 V
114 -180 V
325 -574 R
43 94 R
6 -4 R
114 -76 V
-79 -98 R
502 -14 R
6 4 R
142 157 V
252 -160 V
4561 2631 M
LT0
2639 2723 M
12 0 R
198 -25 V
138 48 V
-154 28 R
LT1
3598 3182 M
-55 131 R
6 0 R
142 -18 V
18 -116 V
3369 2291 M
0 4 R
79 148 V
114 -8 V
-22 -160 R
-171 16 R
349 752 R
-3 114 R
90 -32 R
49 -18 V
-30 -120 R
0 4 R
30 116 V
LT0
2991 2747 M
12 0 R
138 -24 V
0 -4 R
6 0 V
7 0 R
-26 78 R
LT1
3943 2907 M
0 4 R
67 120 V
174 -104 V
4072 2799 M
474 908 R
48 -52 V
4314 3510 M
-57 34 R
54 -36 V
-54 36 R
289 163 V
3824 2987 M
30 120 R
6 0 R
150 -76 V
-67 -124 R
822 -111 R
0 4 R
192 194 V
324 -188 V
5026 2602 M
3448 2443 M
0 4 R
24 44 V
35 76 R
73 -134 R
-132 10 R
2907 1968 M
172 197 V
186 -52 V
3141 1906 M
-234 62 R
234 -64 V
21 1713 R
-190 192 R
6 0 R
208 43 V
156 -208 V
201 -331 R
-83 154 R
6 0 R
175 -7 V
54 -168 V
20 -135 R
-24 138 R
6 0 R
168 -42 V
-11 -146 R
0 4 R
6 60 V
6 60 R
-1 22 V
317 -326 R
0 4 R
98 154 V
234 -128 V
4367 2795 M
915 10 R
0 4 R
241 234 V
410 -221 V
5620 2579 M
6 4 R
307 239 V
4257 3544 M
4087 3377 M
-63 17 R
66 -16 V
-66 16 R
234 152 V
3854 3107 M
11 146 R
6 0 R
24 -8 V
54 -20 R
114 -42 V
-53 -152 R
0 4 R
53 148 V
3079 2165 M
0 4 R
142 165 V
150 -44 V
3268 2113 M
-189 52 R
931 866 R
53 152 R
6 0 R
210 -96 V
-97 -160 R
3221 2334 M
0 4 R
114 140 V
114 -36 V
-80 -151 R
-148 43 R
114 144 R
0 4 R
54 64 V
36 50 R
23 -153 R
-113 35 R
125 989 R
-118 180 R
6 0 R
213 3 V
78 -188 V
385 -68 R
3909 3255 M
-67 2 R
24 0 R
6 -4 V
6 0 R
30 0 V
-66 4 R
6 4 R
174 132 V
-331 -98 R
-50 165 R
6 0 R
207 -34 V
12 -148 V
649 -322 R
0 4 R
134 190 V
312 -156 V
4765 2796 M
-923 461 R
-68 -111 R
-68 -12 R
159 119 R
-11 173 R
6 0 R
150 -40 V
53 -203 R
0 4 R
18 112 V
199 -214 R
0 4 R
81 183 V
288 -124 V
4515 2956 M
LT0
3154 2719 M
162 -28 R
-70 77 R
LT1
4063 3183 M
31 181 R
84 -28 R
180 -64 V
-78 -187 R
-938 562 R
-156 205 R
6 0 R
252 16 V
114 -220 V
3248 2537 M
66 60 V
51 51 R
-30 -170 R
-87 59 R
84 -56 V
1625 513 R
0 4 R
175 229 V
390 -184 V
5282 2805 M
3641 3460 M
-80 190 R
6 0 R
247 -24 V
42 -200 V
2706 2058 M
215 186 V
162 -80 V
2907 1968 M
-201 90 R
198 -88 V
197 434 R
150 128 V
-3 5 R
-27 -203 R
-120 70 R
120 -72 V
LT0
2849 2698 M
12 0 R
201 -27 V
84 44 V
-155 32 R
LT1
2921 2244 M
0 4 R
180 156 V
-22 -239 R
-158 79 R
LT0
2438 2676 M
12 0 R
256 -24 V
132 44 V
-199 27 R
LT1
3854 3426 M
-40 200 R
6 0 R
281 -52 V
-7 -210 R
0 80 R
7 130 V
548 -424 R
0 4 R
114 222 V
372 -152 V
4957 2994 M
LT0
1903 2652 M
18 0 R
312 -17 V
192 44 V
-251 16 R
LT1
3190 2620 M
42 32 V
100 69 R
-84 -184 R
-58 83 R
60 -80 V
2273 503 R
0 4 R
223 271 V
483 -214 V
5933 2822 M
0 4 R
296 278 V
4094 3364 M
7 210 R
6 0 R
132 -36 V
122 -266 R
0 4 R
48 172 V
-48 -176 R
58 219 R
36 -12 R
306 -100 V
4649 3150 M
3561 3650 M
-117 218 R
6 0 R
291 -12 V
72 -232 V
3013 2498 M
174 120 V
3 2 R
-89 -216 R
-88 94 R
84 -88 V
4146 3566 M
102 -20 V
4024 3394 M
-113 4 R
240 168 R
-5 0 V
293 181 R
102 -40 V
4257 3544 M
-111 22 R
6 4 R
287 177 V
LT0
3062 2671 M
12 0 R
150 -20 V
47 -10 R
-117 78 R
LT1
2799 2350 M
216 144 V
-2 4 R
-92 -254 R
-122 106 R
120 -100 V
895 1376 R
-73 230 R
6 0 R
331 -41 V
24 -240 V
3167 2727 M
164 89 R
3190 2620 M
-23 107 R
18 -76 R
6 -24 V
1941 600 R
0 4 R
154 264 V
456 -176 V
5523 3043 M
2544 2177 M
252 168 V
3 5 R
-93 -292 R
-162 119 R
162 -116 V
4101 3574 M
-23 241 R
6 0 R
348 -68 V
-13 -256 R
344 -115 R
0 4 R
90 256 V
438 -144 V
5132 3227 M
LT0
2706 2652 M
12 0 R
255 -28 V
84 44 V
-208 30 R
LT1
4419 3491 M
30 251 R
18 -4 R
6 -4 V
6 0 R
6 -4 V
6 0 R
360 -92 V
-88 -262 R
2963 2616 M
12 8 V
24 8 R
0 4 V
168 91 R
3013 2498 M
-50 118 R
54 -116 V
-300 -18 R
246 136 V
0 -2 R
2799 2350 M
-82 132 R
84 -128 V
LT0
2233 2635 M
18 0 R
312 -24 V
138 44 V
-263 21 R
LT1
2425 2323 M
288 160 V
4 -1 R
2544 2177 M
-119 146 R
120 -140 V
411 574 R
211 -30 R
2963 2616 M
-7 141 R
6 -136 R
0 -4 V
4269 3775 M
132 -20 R
0 -4 V
24 0 R
0 -4 V
4146 3566 M
-171 7 R
2680 2638 M
12 8 V
6 0 R
6 4 V
6 0 R
0 4 V
246 103 R
2717 2482 M
-37 156 R
36 -156 V
LT0
2563 2611 M
12 0 R
108 -12 V
207 -18 R
-184 71 R
LT1
2355 2496 M
246 108 V
79 34 R
2425 2323 M
-70 173 R
72 -176 V
4032 3788 M
-57 -215 R
-232 -8 R
2337 2693 M
343 -55 R
2355 2496 M
-18 197 R
6 -72 R
12 -124 V
407 526 R
42 12 V
191 -113 R
2694 2819 M
36 112 R
32 92 V
2377 2916 M
384 104 V
-67 -201 R
2337 2693 M
30 164 R
10 59 V
514 333 R
196 -141 R
-325 -85 R
0 4 R
6 0 V
0 4 R
12 28 V
-299 103 R
198 44 V
83 -183 R
2377 2916 M
0 4 R
104 242 V
171 270 R
239 -183 R
-410 -87 R
0 4 R
132 208 V
283 349 R
189 -227 R
-433 -64 R
LT0
LTb
971 1221 M
4304 601 L
6229 1674 L
2896 2294 M
4432 2006 M
6229 1674 L
971 1221 M
1632 912 V
996 1216 M
55 30 V
831 1124 M
(-2000) Rshow
1406 1140 M
55 30 V
1241 1049 M
(-1500) Rshow
1817 1064 M
55 30 V
1652 973 M
(-1000) Rshow
2227 987 M
55 30 V
2062 895 M
(-500) Rshow
2638 911 M
55 30 V
2473 820 M
(0) Rshow
3049 835 M
55 30 V
2884 743 M
(500) Rshow
3459 758 M
55 30 V
3294 666 M
(1000) Rshow
3869 682 M
55 30 V
3704 590 M
(1500) Rshow
4279 606 M
55 30 V
4114 515 M
(2000) Rshow
4257 620 M
61 -11 V
185 -34 R
(-2000) Lshow
4494 752 M
61 -11 V
185 -34 R
(-1500) Lshow
4731 884 M
61 -11 V
185 -34 R
(-1000) Lshow
4969 1017 M
61 -11 V
185 -34 R
(-500) Lshow
5206 1149 M
61 -11 V
185 -34 R
(0) Lshow
5443 1281 M
61 -11 V
185 -34 R
(500) Lshow
5680 1413 M
61 -11 V
185 -34 R
(1000) Lshow
5917 1545 M
61 -11 V
185 -34 R
(1500) Lshow
6154 1677 M
61 -11 V
185 -34 R
(2000) Lshow
971 1936 M
63 0 V
-126 0 R
(-300) Rshow
971 2175 M
63 0 V
-126 0 R
(-200) Rshow
971 2413 M
63 0 V
-126 0 R
(-100) Rshow
971 2650 M
54 0 R
9 0 V
-126 0 R
(0) Rshow
971 2889 M
63 0 V
-126 0 R
(100) Rshow
971 3127 M
63 0 V
-126 0 R
(200) Rshow
971 3366 M
63 0 V
-126 0 R
(300) Rshow
971 1221 M
0 1428 V
0 4 R
0 713 V
LTa
2157 643 M
(x) Cshow
6100 983 M
(y) Cshow
971 3723 M
(z) Cshow
stroke
grestore
end
showpage
%%Trailer
%%Pages: 1
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/bild1.ps0000644000175000017500000002434411526203062023030 0ustar  giovannigiovanni%!PS-Adobe-2.0
%%Creator: gnuplot
%%DocumentFonts: Helvetica
%%BoundingBox: 50 50 554 770
%%Pages: (atend)
%%EndComments
/gnudict 40 dict def
gnudict begin
/Color false def
/Solid false def
/gnulinewidth 5.000 def
/vshift -46 def
/dl {10 mul} def
/hpt 31.5 def
/vpt 31.5 def
/M {moveto} bind def
/L {lineto} bind def
/R {rmoveto} bind def
/V {rlineto} bind def
/vpt2 vpt 2 mul def
/hpt2 hpt 2 mul def
/Lshow { currentpoint stroke M
  0 vshift R show } def
/Rshow { currentpoint stroke M
  dup stringwidth pop neg vshift R show } def
/Cshow { currentpoint stroke M
  dup stringwidth pop -2 div vshift R show } def
/DL { Color {setrgbcolor Solid {pop []} if 0 setdash }
 {pop pop pop Solid {pop []} if 0 setdash} ifelse } def
/BL { stroke gnulinewidth 2 mul setlinewidth } def
/AL { stroke gnulinewidth 2 div setlinewidth } def
/PL { stroke gnulinewidth setlinewidth } def
/LTb { BL [] 0 0 0 DL } def
/LTa { AL [1 dl 2 dl] 0 setdash 0 0 0 setrgbcolor } def
/LT0 { PL [] 0 1 0 DL } def
/LT1 { PL [4 dl 2 dl] 0 0 1 DL } def
/LT2 { PL [2 dl 3 dl] 1 0 0 DL } def
/LT3 { PL [1 dl 1.5 dl] 1 0 1 DL } def
/LT4 { PL [5 dl 2 dl 1 dl 2 dl] 0 1 1 DL } def
/LT5 { PL [4 dl 3 dl 1 dl 3 dl] 1 1 0 DL } def
/LT6 { PL [2 dl 2 dl 2 dl 4 dl] 0 0 0 DL } def
/LT7 { PL [2 dl 2 dl 2 dl 2 dl 2 dl 4 dl] 1 0.3 0 DL } def
/LT8 { PL [2 dl 2 dl 2 dl 2 dl 2 dl 2 dl 2 dl 4 dl] 0.5 0.5 0.5 DL } def
/P { stroke [] 0 setdash
  currentlinewidth 2 div sub M
  0 currentlinewidth V stroke } def
/D { stroke [] 0 setdash 2 copy vpt add M
  hpt neg vpt neg V hpt vpt neg V
  hpt vpt V hpt neg vpt V closepath stroke
  P } def
/A { stroke [] 0 setdash vpt sub M 0 vpt2 V
  currentpoint stroke M
  hpt neg vpt neg R hpt2 0 V stroke
  } def
/B { stroke [] 0 setdash 2 copy exch hpt sub exch vpt add M
  0 vpt2 neg V hpt2 0 V 0 vpt2 V
  hpt2 neg 0 V closepath stroke
  P } def
/C { stroke [] 0 setdash exch hpt sub exch vpt add M
  hpt2 vpt2 neg V currentpoint stroke M
  hpt2 neg 0 R hpt2 vpt2 V stroke } def
/T { stroke [] 0 setdash 2 copy vpt 1.12 mul add M
  hpt neg vpt -1.62 mul V
  hpt 2 mul 0 V
  hpt neg vpt 1.62 mul V closepath stroke
  P  } def
/S { 2 copy A C} def
end
%%EndProlog
%%Page: 1 1
gnudict begin
gsave
50 50 translate
0.040 0.040 scale
0 setgray
/Helvetica findfont 140 scalefont setfont
newpath
LTa
840 2917 M
6129 0 V
3905 351 M
0 4618 V
LTb
840 351 M
63 0 V
6066 0 R
-63 0 V
756 351 M
(-2.5) Rshow
840 864 M
63 0 V
6066 0 R
-63 0 V
756 864 M
(-2) Rshow
840 1377 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(-1.5) Rshow
840 1890 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(-1) Rshow
840 2403 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(-0.5) Rshow
840 2917 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(0) Rshow
840 3430 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(0.5) Rshow
840 3943 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(1) Rshow
840 4456 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(1.5) Rshow
840 4969 M
63 0 V
6066 0 R
-63 0 V
-6150 0 R
(2) Rshow
840 351 M
0 63 V
0 4555 R
0 -63 V
840 211 M
(-6) Cshow
1862 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(-4) Cshow
2883 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(-2) Cshow
3905 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(0) Cshow
4926 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(2) Cshow
5948 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(4) Cshow
6969 351 M
0 63 V
0 4555 R
0 -63 V
0 -4695 R
(6) Cshow
840 351 M
6129 0 V
0 4618 V
-6129 0 V
840 351 L
140 2660 M
currentpoint gsave translate 90 rotate 0 0 M
(x) Cshow
grestore
3904 71 M
(y) Cshow
LT0
1351 351 M
0 4618 R
6458 351 M
0 4618 R
3910 2933 M
0 -5 V
-11 -8 V
-25 -2 V
-12 1 V
-2 0 V
-2 -2 V
-4 -1 V
-54 15 V
-37 11 V
-28 12 V
-10 5 V
-12 6 V
-26 15 V
-67 42 V
-17 13 V
-10 7 V
-37 32 V
-25 23 V
-28 27 V
-31 33 V
-31 34 V
-26 31 V
-27 33 V
-31 38 V
-26 36 V
-24 32 V
-24 34 V
-26 37 V
-32 48 V
-22 34 V
-25 38 V
-34 54 V
-25 40 V
-17 28 V
-20 33 V
-18 30 V
-9 16 V
-32 53 V
-9 16 V
-8 13 V
-44 78 V
-35 62 V
-29 51 V
-24 43 V
-23 42 V
-27 49 V
-8 15 V
-10 19 V
-47 85 V
-9 18 V
-35 65 V
-33 63 V
-37 68 V
-38 73 V
-8 15 V
-9 17 V
-19 36 V
-3 5 V
-4 9 V
-1 2 V
-1 0 V
0 2 V
-6 11 V
-37 70 V
-23 46 V
-14 27 V
-41 77 V
-3 7 V
-9 18 V
-18 34 V
-3 6 V
-8 16 V
3889 2893 M
-12 26 V
20 22 V
8 25 V
1 28 V
11 24 V
-3 72 V
2 91 V
6 63 V
5 39 V
6 48 V
3 25 V
6 37 V
4 27 V
17 96 V
3 15 V
3 12 V
19 87 V
11 46 V
15 56 V
21 72 V
24 72 V
12 35 V
18 52 V
32 78 V
26 60 V
26 52 V
8 17 V
18 34 V
18 34 V
17 28 V
21 34 V
40 58 V
13 18 V
26 33 V
27 29 V
13 14 V
38 33 V
32 24 V
24 15 V
2 1 V
26 11 V
15 4 V
47 4 V
7 -1 V
5 0 V
5 -1 V
10 -3 V
58 -41 V
27 -45 V
29 -85 V
8 -42 V
5 -36 V
3 -71 V
0 -26 V
-2 -47 V
-2 -29 V
-3 -31 V
-12 -96 V
-5 -25 V
-11 -55 V
-14 -59 V
-18 -67 V
-23 -73 V
-21 -60 V
-29 -76 V
-2 -6 V
-31 -68 V
-32 -65 V
-29 -55 V
-16 -28 V
-14 -24 V
-32 -50 V
-1 -2 V
0 -1 V
-16 -22 V
-15 -22 V
-25 -33 V
-51 -60 V
-40 -43 V
-16 -16 V
-33 -30 V
-30 -24 V
-23 -17 V
-35 -22 V
-25 -14 V
-26 -14 V
-30 -13 V
-3 -1 V
-33 -12 V
-39 -8 V
-35 -6 V
-13 -2 V
-9 1 V
-14 -25 V
-1 -58 V
1 -53 V
4 -68 V
2 -32 V
4 -37 V
3 -43 V
6 -53 V
1 -7 V
15 -110 V
9 -56 V
15 -76 V
14 -69 V
18 -82 V
28 -107 V
19 -71 V
20 -68 V
22 -71 V
31 -92 V
13 -39 V
29 -82 V
8 -22 V
22 -60 V
28 -73 V
12 -30 V
19 -50 V
18 -45 V
26 -64 V
30 -71 V
4 -10 V
11 -27 V
46 -108 V
5 -12 V
26 -60 V
28 -62 V
11 -24 V
22 -49 V
22 -50 V
27 -59 V
10 -23 V
13 -29 V
24 -52 V
19 -41 V
22 -47 V
23 -51 V
15 -33 V
5 -9 V
8 -17 V
8 -19 V
8 -16 V
6 -12 V
9 -21 V
6 -12 V
37 -7 R
-14 30 V
-7 18 V
-8 18 V
-11 24 V
-10 23 V
-3 8 V
-7 15 V
-8 19 V
-2 4 V
-22 52 V
-17 40 V
-33 76 V
-27 65 V
-21 51 V
-21 53 V
-28 68 V
-24 63 V
-17 44 V
-18 47 V
-28 75 V
-13 37 V
-23 66 V
-19 57 V
-13 38 V
-17 52 V
-7 25 V
-30 101 V
-3 10 V
-1 5 V
-18 66 V
-15 61 V
-13 57 V
-9 43 V
-7 38 V
-5 29 V
-6 32 V
-7 49 V
-2 15 V
-2 17 V
-3 25 V
-8 93 V
-1 21 V
-1 9 V
0 21 V
0 88 V
4 66 V
6 55 V
13 77 V
2 8 V
19 80 V
13 44 V
20 58 V
38 93 V
22 49 V
8 18 V
21 43 V
15 31 V
12 25 V
12 25 V
10 21 V
11 21 V
13 27 V
9 19 V
26 51 V
22 46 V
12 25 V
5 10 V
23 50 V
16 33 V
8 18 V
3 8 V
7 15 V
16 37 V
4 10 V
15 35 V
15 35 V
29 75 V
27 74 V
7 20 V
21 61 V
22 72 V
2 6 V
1 6 V
5 15 V
32 121 V
4 17 V
4 16 V
23 106 V
6 35 V
4 25 V
4 23 V
9 64 V
6 58 V
4 44 V
3 56 V
1 63 V
0 45 V
-1 24 V
-4 48 V
-8 67 V
-14 68 V
-29 78 V
-27 52 V
-3 5 V
-1 2 V
-5 6 V
-67 58 V
-13 7 V
-10 3 V
-41 7 V
-33 -1 V
-38 -7 V
-35 -14 V
-10 -5 V
-18 -9 V
-23 -13 V
-26 -18 V
-33 -26 V
-22 -20 V
-35 -33 V
-36 -38 V
-49 -59 V
-3 -4 V
-3 -3 V
-5 -8 V
-48 -65 V
-2 -3 V
-26 -38 V
-25 -39 V
0 -1 V
-1 -1 V
-31 -51 V
-33 -56 V
-1 -2 V
-46 -83 V
-5 -9 V
-2 -4 V
-28 -53 V
-24 -47 V
-4 -9 V
-29 -56 V
-27 -56 V
-23 -46 V
-21 -42 V
-12 -22 V
-8 -16 V
-20 -39 V
-21 -38 V
-30 -50 V
-33 -50 V
-42 -53 V
-2 -3 V
-2 -2 V
-37 -35 V
-26 -19 V
-25 -13 V
-26 -10 V
-26 -5 V
-23 -1 V
-21 1 V
-22 4 V
-26 8 V
-34 14 V
-9 5 V
-28 16 V
-32 24 V
-24 18 V
-21 18 V
-16 14 V
-7 8 V
-19 18 V
-8 8 V
-27 29 V
-34 39 V
-8 9 V
currentpoint stroke M
-16 19 V
-57 73 V
-5 6 V
-2 4 V
-34 46 V
-31 44 V
-7 10 V
-30 44 V
-27 41 V
-10 15 V
-12 19 V
-27 42 V
-23 36 V
-22 37 V
-26 41 V
-24 40 V
-10 17 V
-37 63 V
-12 19 V
-26 46 V
-35 61 V
-23 40 V
-21 38 V
-31 54 V
-12 22 V
-15 27 V
-31 56 V
-15 28 V
-7 12 V
-7 12 V
-8 15 V
-23 41 V
-25 48 V
-23 41 V
-36 67 V
-5 11 V
-5 8 V
4768 360 M
-8 18 V
-14 34 V
-20 49 V
-7 16 V
-6 15 V
-29 71 V
-18 45 V
-19 49 V
-24 63 V
-22 58 V
-7 17 V
-7 20 V
-30 81 V
-5 14 V
-2 7 V
-23 63 V
-17 50 V
-11 34 V
-23 71 V
-13 44 V
-17 57 V
-18 61 V
-11 42 V
-19 73 V
-14 60 V
-32 162 V
-1 0 V
0 1 V
-22 167 V
-6 73 V
-3 70 V
0 9 V
0 82 V
7 121 V
6 53 V
2 14 V
4 25 V
6 38 V
7 35 V
2 12 V
5 21 V
22 90 V
10 38 V
20 65 V
20 61 V
10 28 V
6 15 V
10 29 V
6 17 V
21 55 V
22 56 V
16 41 V
1 4 V
1 2 V
2 4 V
29 74 V
29 73 V
5 14 V
5 13 V
6 16 V
7 17 V
31 82 V
16 43 V
20 56 V
23 63 V
22 66 V
19 59 V
16 52 V
22 75 V
1 3 V
1 1 V
9 35 V
7 25 V
5 20 V
1 0 V
9 37 V
22 92 V
18 82 V
0 3 V
1 3 V
12 65 V
17 108 V
9 67 V
1 15 V
2 19 V
6 69 V
4 66 V
1 59 V
0 65 V
0 12 V
-6 82 V
-7 62 V
-5 30 V
-10 51 V
-10 38 V
-19 56 V
-22 49 V
-27 45 V
-34 41 V
-6 5 V
-43 28 V
-46 20 V
-49 5 V
-56 -6 V
-68 -24 V
-12 -6 V
-48 -27 V
-40 -28 V
-18 -15 V
-18 -15 V
-23 -20 V
-28 -26 V
-6 -6 V
-5 -5 V
-4 -4 V
-17 -17 V
-20 -21 V
-37 -42 V
-7 -8 V
-5 -6 V
-8 -10 V
-38 -47 V
-47 -63 V
-32 -44 V
-14 -21 V
-23 -33 V
-19 -29 V
-10 -16 V
-11 -17 V
-22 -34 V
-24 -37 V
-21 -34 V
-24 -36 V
-37 -60 V
-37 -59 V
-33 -51 V
-25 -36 V
-41 -58 V
-6 -9 V
-6 -7 V
-32 -40 V
-31 -36 V
-30 -30 V
-32 -27 V
-13 -9 V
-26 -17 V
-50 -23 V
-8 -3 V
-41 -8 V
-27 -1 V
-20 2 V
-22 3 V
-58 19 V
-1 0 V
0 1 V
-1 0 V
-65 37 V
-29 20 V
-15 12 V
-38 32 V
-39 38 V
-7 7 V
-14 15 V
-51 56 V
-10 12 V
-6 7 V
-5 6 V
-35 43 V
-30 39 V
-30 41 V
-24 33 V
-23 31 V
-24 35 V
-22 32 V
-13 20 V
-24 37 V
-27 41 V
-6 9 V
-7 11 V
-42 67 V
-7 12 V
-23 37 V
-24 39 V
-11 19 V
-25 41 V
-25 42 V
-18 31 V
-20 33 V
-3 6 V
-3 6 V
-5 7 V
-11 20 V
-6 10 V
-27 48 V
-18 30 V
-8 16 V
-14 24 V
-25 44 V
-3 5 V
-2 5 V
-2 3 V
-1 1 V
-9 16 V
-9 17 V
4802 353 M
-4 10 V
-2 4 V
-1 3 V
-9 22 V
-8 21 V
-4 10 V
-22 57 V
-25 64 V
-3 8 V
-1 5 V
-20 53 V
-19 51 V
-20 55 V
-16 47 V
-13 37 V
-9 26 V
-14 41 V
-7 21 V
-5 17 V
-12 38 V
-20 62 V
-18 63 V
-4 14 V
-4 13 V
-17 61 V
-10 40 V
-12 46 V
-13 55 V
-10 43 V
-15 74 V
-17 91 V
-3 19 V
-2 15 V
-11 82 V
-8 74 V
-2 30 V
-5 70 V
-2 73 V
0 34 V
3 87 V
4 64 V
6 67 V
10 71 V
2 15 V
12 70 V
13 60 V
10 43 V
8 36 V
19 71 V
18 63 V
8 27 V
9 30 V
9 27 V
5 15 V
9 28 V
10 31 V
2 7 V
14 42 V
27 78 V
15 44 V
1 3 V
26 77 V
10 29 V
4 11 V
19 56 V
17 49 V
8 24 V
14 43 V
14 44 V
13 39 V
12 38 V
18 59 V
16 53 V
19 69 V
11 37 V
7 27 V
14 53 V
11 45 V
12 50 V
13 59 V
6 25 V
3 14 V
12 59 V
21 118 V
1 7 V
0 5 V
1 3 V
1 4 V
0 3 V
11 80 V
7 57 V
6 55 V
4 48 V
5 80 V
2 86 V
0 33 V
-3 75 V
-5 68 V
-7 57 V
-9 58 V
-24 98 V
-11 36 V
-11 28 V
-21 46 V
-20 35 V
-14 20 V
-9 13 V
-9 10 V
-2344 3 R
16 -27 V
14 -24 V
6 -10 V
2 -4 V
6 -9 V
5 -10 V
12 -20 V
20 -33 V
16 -26 V
15 -25 V
19 -31 V
21 -34 V
28 -45 V
31 -49 V
12 -18 V
28 -43 V
28 -42 V
29 -43 V
30 -43 V
5 -7 V
4 -7 V
14 -19 V
56 -75 V
3 -4 V
34 -44 V
32 -40 V
7 -8 V
8 -9 V
40 -46 V
53 -56 V
35 -33 V
33 -29 V
36 -28 V
32 -22 V
10 -6 V
46 -24 V
49 -19 V
3 -1 V
2 -1 V
45 -8 V
59 0 V
37 7 V
39 13 V
36 19 V
11 6 V
30 21 V
33 26 V
4 3 V
currentpoint stroke M
48 46 V
16 18 V
22 24 V
27 32 V
23 28 V
28 36 V
12 16 V
20 26 V
34 46 V
32 45 V
34 48 V
34 47 V
10 14 V
39 53 V
24 32 V
17 22 V
17 23 V
37 48 V
5 6 V
32 39 V
28 33 V
30 35 V
36 39 V
42 44 V
16 16 V
22 20 V
43 38 V
21 17 V
16 12 V
17 12 V
9 7 V
9 6 V
stroke
grestore
end
showpage
%%Trailer
%%Pages: 1
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/plot.red0000644000175000017500000000717411526203062023145 0ustar  giovannigiovannimodule plot; % device and driver independent plot services.

% Author: Herbert Melenk.
% Adjusted by A C Norman to be compatible with CSL - the original
% was written to be fairly PSL-specific.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Minor corrections by Winfried Neun (October 1995)

create!-package('(plot plotsynt plotexp2 pltpara plotexp3 plotimp2
                  plotimp3 plotnum parray xvect),
                nil);

global '(

      plotdriver!*         % modulename of the actual driver.

      plotmax!*            % maximal floating point number which
                           % gnuplot supports on the machine
                           % (mostly IEEE double or single precision).

      plotmin!*            % lower bound (=1/plotmax!*)

      variation!*          %  definition of y-bigstep for smooth

      plotoptions!*        % list for collecting the options.

);

fluid '(

      plotderiv!*          %  derivative for 2d plot

);

!#if(or (errorp (errorset '!*writingfaslfile nil nil))
        (not !*writingfaslfile)
        (errorp (errorset '(load fcomp) nil nil)))
%  prin2t "*** No support for fast float!";
   symbolic macro procedure fdeclare u; nil;
   symbolic macro procedure thefloat u; cadr u;
!#endif

% Create .. as infix operator.

newtok '((!. !.) !*interval!*);

put('!*interval!*,'prtch,'! !.!.! );

if null get('!*interval!*,'simpfn)
  then <>;

 % Reestablished these routines in order to support singularity handling
 % (which was better in some respects in Reduce 3.5) %WN

symbolic procedure ploteval3xysingular(ff,f,x,xx,dx,y,yy,dy,zhi,zlo);
 % set up an iteration approaching a critical point.
   <>;

symbolic procedure ploteval3xysingular1(ff,f,x,xx,dx,y,yy,dy,zhi,zlo,w,c);
  if null w then nil else if c>8 then nil else
  if w>zhi then zhi else
  if w>;
    if !*show_grid and null cdr plot!-contour!*
         then g:= imp2!-show!-meshes();
    plotdriver(plot!-2imp,x,y,ll,g,car rx,cadr rx,car ry,cadr ry);
  end;

symbolic procedure imp2!-init();
  << imp2!-finit();
     if null imp2!-trias!* then imp2!-trias!* :=mkxvect()>>;

symbolic procedure imp2!-finit();
  <>;

symbolic procedure mk!-point(x0,y0,fcn);
         (if caddr point then point else
            rederr("Implicit function cannot be plotted")
         ) where point = {x0,y0,apply2(fcn,x0,y0)};

!#if (member 'csl lispsystem!*)
    symbolic procedure deletip1 (u,v);
       % Auxiliary function for DeletIP.
       pairp cdr v and
          (if u=cadr v then rplacd(v,cddr v) else deletip1(u,cdr v));

    symbolic procedure deletip (u,v);
       % Destructive DELETE.
       if not pairp v then v
        else if u=car v then cdr v
        else <>;
!#endif

symbolic procedure imp2!-delete!-pt!-reference(i,p);
    cdr cddr p := deletip(i,cdddr p);

symbolic procedure mk!-tria(i,p1,p2,p3);
  % make a triangle from 3 points. If the number is given,
  % reuse it. Otherwise generate a fresh number.
  begin scalar p; integer i;
    i := i or (imp2!-triacount!* := imp2!-triacount!* #+1);
    p:={i,p1,p2,p3,imp2!-tria!-zerop!*(p1,p2,p3)};
    xputv(imp2!-trias!*,i,p);
    aconc(p1,i); aconc(p2,i); aconc(p3,i);
      if !*imp2!-trace then print!-tria("new triangle ",p);
    return p;
  end;

symbolic procedure print!-tria(tx,w);
  <>;

symbolic procedure imp2!-tria!-zerop!*(p1,p2,p3);
 % Here I test whether the triangle contains a zero line.
  begin scalar f1,f2,f3;
    f1 := caddr p1;
    f2 := caddr p2;
    f3 := caddr p3;
    return f1*f2 <= 0.0 or f1*f3 <= 0.0;
  end;

symbolic procedure imp2!-tria!-zerop(w);
 % Fast access to stored zerop property.
     cadddr cdr w;

symbolic procedure imp2!-neighbours p;
 % Compute the direct neighbours of p - the traingles which have
 % two nodes respectively one complete edge in common with p.
  begin scalar l,p1,p2,p3; integer n;
   if fixp p then p:=xgetv(imp2!-trias!*,p);
   n:= car p; p:=cdr p;
   p1:=delete(n,cdddr car p);
   p2:=delete(n,cdddr cadr p);
   p3:=delete(n,cdddr caddr p);
   l:={find!-one!-common(p1,p2),
       find!-one!-common(p2,p3),
       find!-one!-common(p3,p1)};
   while nil memq l do l:=deletip(nil,l);
   return for each w in l collect xgetv(imp2!-trias!*,w);
  end;

symbolic procedure imp2!-edge!-length(p1,p2);
  begin scalar dx,dy;
    fdeclare('imp2!-edge!-length,dx,dy);
    dx:=thefloat car p1 - thefloat car p2;
    dy:=thefloat cadr p1 - thefloat cadr p2;
    return sqrt(dx*dx + dy*dy)
  end;

symbolic procedure imp2!-tria!-surface w;
 begin scalar x1,x2,x3,y1,y2,y3,p1,p2,p3;
   fdeclare('imp2!-tria!-surface,x1,x2,x3,y1,y2,y3);
   w:=cdr w;
   x1:=car (p1:=car w); y1:=cadr p1;
   x2:=car (p2:=cadr w); y2:=cadr p2;
   x3:=car (p3:=caddr w); y3:=cadr p3;
   return abs ((0.5*(x1*(y2-y3) + x2*(y3-y1) + x3*(y1-y2))));
 end;

symbolic procedure imp2!-tria!-length w;
 begin scalar p1,p2,p3;
   w:=cdr w;
   p1:=car w; p2:=cadr w; p3:=caddr w;
   return
    (0.3*(imp2!-edge!-length(p1,p2)
            + imp2!-edge!-length(p2,p3)
              + imp2!-edge!-length(p3,p1)));
 end;

symbolic procedure imp2!-tria!-midpoint(w);
   <>;

symbolic procedure imp2!-tria!-goodpoint(w,fn);
 % Here I assume that there is a zero in the triangle. Compute
 % a point inside the triangle which is as close as possible
 % to the desired line, but without local recomputation of
 % function values.
 begin scalar p1,p2,p3,f1,f2,f3,s1,s2,s3;
   w:=cdr w;
   p1:=car w; p2:=cadr w; p3:=caddr w;
   if (f1:=caddr p1)=0.0 then return {car p1,cadr p1} else
   if (f2:=caddr p2)=0.0 then return {car p2,cadr p2} else
   if (f3:=caddr p3)=0.0 then return {car p3,cadr p3};
   s1:=f1<0.0; s2:=f2<0.0; s3:=f3<0.0;
   return if s1=s2 then
       imp2!-tria!-goodpoint1(p1,f1,p3,f3,p2,f2,fn)
   else if s1=s3 then
       imp2!-tria!-goodpoint1(p1,f1,p2,f2,p3,f3,fn)
   else
       imp2!-tria!-goodpoint1(p2,f2,p1,f1,p3,f3,fn)
 end;

%symbolic procedure imp2!-tria!-goodpoint1(p1,f1,p2,f2,p3,f3,fn);
% % Now I know that f2 has the opposite sign to f1 and f3.
% % I take the linearly interpolated zero of f on p1-p2 and p2-p3
% % return their arithmetic mean value which lies inside the
% % triangle.
%  begin scalar x1,x2,y1,y2,s;
%    fdeclare (x1,x2,y1,y2,s,f1,f2,f3);
%    s:=f1-f2;
%    x1:=(f1*thefloat car p2  - f2*thefloat car p1)/s;
%    y1:=(f1*thefloat cadr p2 - f2*thefloat cadr p1)/s;
%    s:=f3-f2;
%    x2:=(f3*thefloat car p2  - f2*thefloat car p3)/s;
%    y2:=(f3*thefloat cadr p2 - f2*thefloat cadr p3)/s;
%    return {(x1+x2)*0.5, (y1+y2)*0.5};
%  end;

symbolic procedure imp2!-tria!-goodpoint1(p1,f1,p2,f2,p3,f3,fn);
 % Now I know that f2 has the opposite sign to f1 and f3.
 % F1 and f3 are non-zero.
 % I use the midpoint of the p1-p3 edge and look for an
 % approximation of a zero on the connection of the midpoint
 % and p2 using regula falsi.
  begin scalar x1,x2,y1,y2,x3,y3,s;
    fdeclare (x1,x2,x3,y1,y2,y3,s,f1,f2,f3);
    f1:=(f1+f3)*0.5;
    x1:=(thefloat car p1  + thefloat car p3)*0.5;
    y1:=(thefloat cadr p1  + thefloat cadr p3)*0.5;
    x2:=car p2; y2:=cadr p2;
    s:=f2-f1;
    x3:=(x1*f2 - x2*f1)/s;
    y3:=(y1*f2 - y2*f1)/s;
    f3:=apply2(fn,x3,y3);
    if f2*f3>=0 then
    <>
      else
    <>;
 done:
    return{x3,y3};
  end;

symbolic procedure imp2!-tri!-refine!-one!-tria (w,fn);
 % Refine one triangle by inserting a new point in the mid
 % of the longest edge. Also, refine the triangle adjacent
 % to that edge with the same point.
  begin scalar p1,p2,p3,pn,xn,yn,new,nb,y; integer i;
    scalar x1,x2,y1,y2,d1,d2,d3,s;
    fdeclare (x1,x2,y1,y2,s,d1,d2,d3);
   if fixp w then w :=xgetv(imp2!-trias!*,w); % record.
     if !*imp2!-trace then print!-tria("refine ",w);
   i:=car w; w :=cdr w;

     % delete reference to this triangle.
   imp2!-delete!-pt!-reference(i,car w);
   imp2!-delete!-pt!-reference(i,cadr w);
   imp2!-delete!-pt!-reference(i,caddr w);

     % find longest edge
   d1:=imp2!-edge!-length(car w,cadr w);
   d2:=imp2!-edge!-length(cadr w,caddr w);
   d3:=imp2!-edge!-length(car w,caddr w);
   if d1>=d2 and d1>=d3 then
     <>
   else if d2>=d1 and d2>=d3 then
     <>
   else
     <>;
    % identify the neighbour triangle.
   nb := find!-one!-common(cdddr p1,cdddr p2);
    % compute new point almost at the mid.
   s:=0.45+0.01*random(10);
   x1:=car p1; y1:=cadr p1;
   x2:=car p2; y2:=cadr p2;
   xn:=x1*s+x2*(1.0-s);
   yn:=y1*s+y2*(1.0-s);
   pn:=mk!-point(xn,yn,fn);
construct:
    % construct new triangles
   new:=mk!-tria(i,p1,pn,p3).new;
   new:=mk!-tria(nil,p2,pn,p3).new;
    % update the neighbour, if there is one
   if null nb then return new;
   w:=nb; nb:=nil;
   if fixp w then w :=xgetv(imp2!-trias!*,w); % record.
   i:=car w; w:=cdr w;
   imp2!-delete!-pt!-reference(i,car w);
   imp2!-delete!-pt!-reference(i,cadr w);
   imp2!-delete!-pt!-reference(i,caddr w);

    % find the far point
   p3 := if not((y:=car w) eq p1 or y eq p2) then y else
         if not((y:=cadr w) eq p1 or y eq p2) then y else
         caddr w;
   goto construct;
  end;

%symbolic procedure imp2!-tri!-refine!-one!-tria!-center (w,fn);
% % Refine one triangle by inserting a new point in the center.
%  begin scalar p1,p2,p3,pn,xn,yn,new,nb,y; integer i;
%    scalar x1,x2,x3,y1,y2,y3;
%   fdeclare (x1,x2,x3,y1,y2,y3);
%   if fixp w then w :=xgetv(imp2!-trias!*,w); % record.
%     if !*imp2!-trace then print!-tria("refine ",w);
%   i:=car w; w :=cdr w;
%
%     % delete reference to this triangle.
%   imp2!-delete!-pt!-reference(i,car w);
%   imp2!-delete!-pt!-reference(i,cadr w);
%   imp2!-delete!-pt!-reference(i,caddr w);
%
%    % compute center.
%   p1:=car w; p2:=cadr w; p3:=caddr w;
%   x1:=car p1; y1:=cadr p1;
%   x2:=car p2; y2:=cadr p2;
%   x3:=car p3; y3:=cadr p3;
%   xn:=(x1+x2+x3)*0.33333;
%   yn:=(y1+y2+y3)*0.33333;
%   pn:=mk!-point(xn,yn,fn);
%construct:
%    % construct new triangles
%   new:=mk!-tria(i,p1,p2,pn).new;
%   new:=mk!-tria(nil,p2,p3,pn).new;
%   new:=mk!-tria(nil,p1,p3,pn).new;
%   return new;
%  end;

symbolic procedure find!-one!-common(u,v);
  % fast equivalent to "car intersection(u,v)".
  if null u then nil else
  if memq(car u,v) then car u else
     find!-one!-common(cdr u,v);

%%%%%% Main program for implicit plot.

symbolic procedure imp2!-plot(xlo,xhi,ylo,yhi,pts,fcn);
  begin scalar p1,p2,p3,p4,sf,z;
   imp2!-init();
    % setup initial triangularization.
   p1:=mk!-point(xlo,ylo,fcn);
   p2:=mk!-point(xhi,ylo,fcn);
   p3:=mk!-point(xhi,yhi,fcn);
   p4:=mk!-point(xlo,yhi,fcn);
   mk!-tria(nil,p1,p2,p3);
   mk!-tria(nil,p1,p3,p4);
   sf:=((xhi-xlo)+(yhi-ylo))*1.5/float pts;
   z:=imp2!-plot!-refine(sf,fcn);
     if !*imp2!-trace then
       for each w in z do print!-tria("zero triangle:",w);
if !*test_plot then print "collect";
   z:=imp2!-plot!-collect(z);
if !*test_plot then print "draw";
   z:=imp2!-plot!-draw(z,fcn);
   if not !*show_grid then imp2!-finit();
   return z;
 end;

symbolic procedure imp2!-plot!-refine(sflimit,fcn);
  begin scalar z,zn,w,s,limit2,again;
    integer i,j;
    limit2 := 0.15*sflimit;

  % In the first stage I refine all triangles until they
  % are fine enough for a coarse overview.
    again := t;

if !*test_plot then print "phase1";
phase1:
    z:=nil; again:=nil;
    for i:=imp2!-triacount!* step -1 until 1 do
    << w := xgetv(imp2!-trias!*,i);
       if imp2!-tria!-length w > sflimit then
           <>
        else if not again and imp2!-tria!-zerop w
           then z:=car w.z;
    >>;
    j:=j #+ 1;
    if j+j #< plot!-refine!* or again then goto phase1;

 % Next I refine further only the triangles which contain a zero.
 % I must store in z only the numbers of triangles because these
 % may be modified as side effects by copying.

if !*test_plot then print "phase2";
phase2:
    for each w in z do
      if (s:=imp2!-tria!-length (w:=xgetv(imp2!-trias!*,w))) >limit2
         then <>;
    z:=zn; zn:=nil;
    if z then goto phase2;

 % In the third phase I refine those critical triangles futher:
 % non-zeros with two zero neighbours. These may be turning points
 % or bifurcations.

if !*test_plot then print "phase3";
phase3:
    for i:=imp2!-triacount!* step -1 until 1 do
      imp2!-refine!-phase3(i,i,plot!-refine!*/2,fcn,limit2*0.3);

 % Return the final list of zeros in ascending order.
    z:=for i:=1:imp2!-triacount!* join
      if imp2!-tria!-zerop(w:=xgetv(imp2!-trias!*,i)) then {w};
   return z;
  end;

symbolic procedure imp2!-refine!-phase3(i,low,lev,fn,lth);
  begin scalar w; integer c;
    if lev=0 then return nil;
    w:=if numberp i then xgetv(imp2!-trias!*,i) else i;
    if car w car w1 and imp2!-tria!-zerop w2 then
            q:=(w1.w2) . q;

 lineloop:
     if null q then return lines;
     l:={caar q, (p:=cdar q)}; q:= cdr q;
      % first I extend the back end.
     while q and p do
     <<
       if(s:= atsoc(p,q)) then l:=nconc(l,{p:=cdr s}) else
       if(s:=rassoc(p,q)) then l:=nconc(l,{p:=car s});
       if s then q:=delete(s,q) else p:=nil;
     >>;

      % next I extend the front end.
     p:=car l;
     while q and p do
     <<
       if(s:=rassoc(p,q)) then l:=(p:=car s).l else
       if(s:= atsoc(p,q)) then l:=(p:=cdr s).l;
       if s then q:=delete(s,q) else p:=nil;
     >>;

     lines := l.lines;
     goto lineloop;
   end;

symbolic procedure imp2!-plot!-draw(l,fn);
  begin scalar r,s,q;
  q:=for each w in l collect
   <>
   >>;
  return q;
  end;


symbolic procedure imp2!-show!-meshes();
 % generate plot of meshes;
  begin scalar d,l,w,s,p1,p2; integer i;
    i:=1;
 loop:
    w:=xgetv(imp2!-trias!*,i);
    if null w then
    <>;
    w:=cdr w;
    d:= {{car car w, cadr car w},
         {car cadr w,cadr cadr w},
         {car caddr w,cadr caddr w},
         {car car w, cadr car w}} ;
    while d and cdr d do
    < car p2 then <>;
      s:={p1,p2};
      if not member(s,l) then l:=s.l
    >>;
    i:=i+1;
    goto loop;
   end;

endmodule; % plotimp2

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/gnuplotex3.ps0000644000175000017500000023375411526203062024154 0ustar  giovannigiovanni%!%!PS-Adobe-2.0 EPSF-1.2
%%Title: printscreen.ps3
%%Creator: DECW$PRINTSCREEN V2 EFT-1 
%%CreationDate: 27-OCT-1993  
%%Pages: 1 
%%BoundingBox:85 95 527 696
%%EndComments 
%%EndProlog 
%%Page: 1 1 
15 dict begin
/temp-save save def
128 93 translate
%% 90 rotate
%%605 444 scale
302 222 scale
/scale { pop pop } bind def
/showpage {} def
%%BeginDocument: Image Services
%!PS-Adobe-2.0 EPSF-1.2
%%Title: Bitmap Image 
%%Creator: VAS V1.1 
%%BoundingBox: 0 0 157 115 
%%Pages: 1 1 
%%EndComments 
/DEC_IMG_dict 50 dict def 
DEC_IMG_dict begin 
/inch {72 mul} def end 
%%EndProlog 
%%Page: 1 1 
save 
DEC_IMG_dict begin 
/pic 82 string def 
/afterimage { 
} def 
/btimage 
{npix nscans nbits [npix 0 0 nscans neg 0 nscans] 
{currentfile pic readhexstring pop} 
image afterimage} bind def 
/npix 652 def 
/nscans 479 def 
/nbits 1 def 
npix inch 300 div nscans inch 300 div scale 
btimage
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa6aaaaa0555554d5555555555555555555555555555555555555555555555555555555555555555555555555555555555555
555555555555555555555555555555555555555555555555555555555555555555555550aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa6aaaaa6555554d5555555555555
555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555550aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa6aaaaa0555554d5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555551a800008000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000040000a153ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffff51aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6aaa9a1535554d55555555555555555555555555555555555555555555555555555
55555555555557fffffffffff5555555555555555555555555555555555555555555555555555555555555555555555555555551aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabfffffffffffaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
9aaaa6aaa9a1535554d555555555555555555555555555555555555555555555555555555555555555555783fffff9ff355555555555555555555555555555555555555555555555555555555555555555555555557ff551aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab39ffff
f9ff3aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6ea89a1535554d55555555555555555555555555555555555555555555555555555555555555555567f2664998615555555555555555555555555555555555555555555555555555555555555555555555555555551aabffaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa7f126449333aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9abea6ea89a1537544d5555555555555555555555555555555555555555555555555555555555555555556613264c9333555555555555555
5555555555555555555555555555555555555555555555555555557155555551aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa793264c9333aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6ea89a1536004d555555555555555555555
5555555555555555555555555555555555555555555556793264c93335555555555555555555555555555555555555555555555555555555555555555555556155555551aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab39324449332aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6ea89a0535554d5555555555555555555555555555555555555555555555555555555555555555557853324998795555555555555555555555555555555555555555555555555555555555555555555555555555550aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaabfffffcfffffaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6c009a0535554d5555555555555555555555555555555555555555555555555555555555555555557fffffcfffff5555555555555555555555555555555555555555555555555555555
555555555555555555555550aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaabfffffcfffffaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa9aaaa6aaa9a052000080000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000000000000000000000001000040001500000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
0100fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50
a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffffffffffffffffff9fbfffffbfffffffff3ffffbfffbff9ffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffbfb7ffffbfffffffffbff7fb7ffbefbffffffffffff
ffa051fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff7f77ffff7fffffffffbff7fb7ffbab7ffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffff61961f71c69c7f87bc61c21c7b83fffffffffffffffa651ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffef7aaeeeeba6bbfbbbbb7bb7fbbc7fff00001fffffff56a9ffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffdf7aaedefbaecffbbbbb7bb7c3b83fffffffffffffffac51ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffdf7aaedefbaef7fbbbbb7bb7bbbabfffffffffffffff56a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffbf6aa1beebaebbb87bbb6bb6bbfeffffffffffffffffa651ffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffbf9bafbf1c6ec71bf1c79c39c3bfffffffffffffffff56a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffefffff
ffffbbffffffffffffffffffffffffffffaa51ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffffffbffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffff56a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffbfffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffa151fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe3fffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffffffffdbfffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffefbfffffffffffffffffffffffffffffffffffffffffffffffffff
ffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffe7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff97fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff7fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff9f7f
dfffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc7fffdfffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff2ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffbfffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff3effbfefffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffffffffffffff8ffffbfefffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe3ffffbfefffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffbff7fffefffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffff7bff7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffcffff7fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50
a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff3ffff7fdfefffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffc7fdffffdfefffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffff87fffffffffffffffffffffffffffffffffffffffffffffffffff7fdffffdff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffff
ffffffffffffffffffffffbe1ffffffffffffffffffffffffffffffffffffffffffffffffef7fdff7ffff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffff80ffffffffffffffffffffffffffffffffffffffffffffff9fffdffbfffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffb67fffffffffffffffffffffffffffffffffffffffffffe7ffffffbfdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffff
ffbfffbf9bffffffffffffffffffffffffffffffffffffffffff8ffbffffbfdff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffbffffffc0fffffffffffffffffffffffffffffffffffffffffeffbfeffffeff7ffffffffffffffffffffffffff
ffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffbfffffff7c3ffffffffffffffffffffffffffffffffffffffdeffbfeffffeff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffbfffbfff7ff03fffff
fffffffffffffffffffffffffffffff3fffbfeffbffff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffbfffffff4fffffffffffffffffffffffffffffffffff8ffffffeffbfffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffa851ffffffffffffffffffffffffffffffffffffffffffff7fffffff7c3fffffffffffffffffffffffffffffffff5ff7ffffffbfefffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffff7fff7fff7ffffff3ffffffffffffffffffffff
fffffffffbdff7fdffffbfeffbffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffff7fffffff7ffffffc0fffffffffffffffffffffffffffffe7dff7fdfeffffeffbffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffff
ffffffffffffffffffffffffffffffffff7fffffff7fff7ffffc3fffffffffffffffffffffffffff9ffff7fdff7fffeffbffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffe0ffffffffffffffffffffff7fff7ffeffff7ffffff03ffffffffffffffffffffffffe3ffffffdff7f
dffffbffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9fffffffffffffffffdffffffffffffffffffffffffff7fffffff7fff7ffed9ffffffffffffffffffffffffbfefffffff7fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffbffffffff
ffffffffffffffffff7ffffffeffff7ffffe667ffffffffffffffffffff7bfeffbffffffdff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff7ffffffffffffffffffffff7fff7ffeffffffff7ffffff89fffffffffffffffffffcfffeffbfdffffdff7fdffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffefffffffffffffffffffffff7ffffffeffffffff7ffefffef87fffffffffffffffff3fffeffbfdff7ffff7fdffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffe0ffffffffffffffffffffff7fffff
fefffefffffffeffffffe7fffffffffffffffc7fdffffbfeff7ffff7fdffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffff7fff7ffefffefffffffefffffff81fffffffffffffff7fdffffffeff7feffffdffffffffffffffffffffffffffffffffff
ffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffff7ffffffefffefffdfffefffef87fffffffffffef7fdfefffffffbfefffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffff7ffffffefffefffffffeff
feffe01fffffffff9fffdff7fbffffffeffbffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffefffefffefffffffefffffffefffefffef87ffffffc7ffffff7fbfeffffeffbfdffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffa051fffffffffffffffffffffffffffffffffffffffefffffffefffffffefffdfffdfffffffeffe03ffff2ffbffff7fdfeffbffffbfdffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9fffffffffffffffffffffffffffffffffffffffefffffffefffefffffffdfffffffffffefffff0ff3f7fbf
effffdfeffbffffbfeffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851fffffffffffffffffffffffffffffffffffffffefffefffefffefffffffdfffffffdfffdffffffc0ff7fbfeffffffeffbfeffffeffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffff
fffffffffffffffffffffffffffffefffffffefffefffdfffdfffdfffffffdfff33fffbfeff7ffffffbfefffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffefffffffefffefffffffdfffdfffffffbffeff0ffffeff7fdffffffeffbffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffefffefffdfffffffefffffffdfffdfffdfffbffffff8ffffff7fdff7ffff7fbfeffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffff
fffffefffffffdfffffffefffdfffdfffffffdfffbff7ffff01ffffbfdff7fdffffdfeffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffefffffffdfffdfffffffdfffffffffffdfffffcfffffdd0f7fffdff7fdffffdfeffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffefffefffdfffdfffffffdfffffffdfffdfffff3fffffdffc3ffffff7fdff7fffeffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffefffffffdff
fefffdfffdfffdfffffffbcbfffffbfff87bffffffdff7ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffefffffffdfffdfffffffdfffdfffffff7fdfffffbfffbe1fefffffff7fdffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffefffefffdfffffffdfffffffdfffdfffbfff4fdfffffffffbff80ffbffff7fdff7fffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffefffffffdfffffffdfffbfffdfffffffbff
f3fffffffffffbfffb67bfeffffdff7fffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffdfffffffdfffdfffffffbfffffffffffbffc7fffffffbfffbfffbf99feffffdff7fffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ff
fffffffffffffffffffffffffffffffffffffdfffdfffdfffdfffffffbfffffffbfffbffb7fefffff7ffffffffffa0effbffff7fffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffdfffffffdfffdfffbfffbfffbfffffffbfefffff7ffffffffff
fb67fbffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffdfffffffdfffdfffffffbfffbfffffdffff7ffff7fff7fffbfffbf9bbfeffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffff
fffffffffffffffffdfffdfffdfffffffdfffffffbfffbfff7f3ffff7ffffffff7fffbfffbffc07effbfffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffdff07ffffffffffffffffffffffdfffffffbfffffffdfffbfffbfffffff7cffbfffffffffff7fff7ffffffffe0ffbfffffffff
ffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffaff7fffffffffffffffffffffffdfffffffbfffdfffffffbfffffffffff72ffbffffffeffff7fff7ffffffffff81bfffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffff77f7fffffffffffffffffffffffdff
fdfffbfffbfffffffbfffffffbfff7effbffbfffeffffffffffffbfffbfff68fffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffff77f4fc3ffffffffffffffffffffffffdfffffffbfffdfffbfffbfffbfff3effdffdfffeffffffffffff7fffbfff7f33fffffffffffffffffffffffffff
ffffffffffffffffffffffffffa051ffffffffffff77f3783ffffffffffffffffffffffffdfffffffbfffdfffffffbfffbffcfffffffdfffeffff7fff7fff7fffbffffffc1ffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffff77ff79fffffffffffffffffffffdfffdfffbfffffffdffffff
fbfffbff1fffffffdffffffff7fff7fff7fffbfffffff6cfffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffff77ff79fffffffffffffffffffffdfffffffbfffffffbfffbfffbfffffedff7fdfffffffffff7fff7fffffffffff7fff7f33fffffffffffffffffffffffffffffffffffffffffff
ffffff50a9ffffffffffffaf7779fffffffffffffffffffffdfffffffbfffbfffffff7fffffffff7dff7fdffffffdfffeffff7fffffffffff7ffffffc1ffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffde38f9fffffffffffffffffffffdfffbfffbfffbfffffff7fffffff7cffff7fdffefff
dffffffffffff7fff7fff7fffffff6cfffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffff7ff9fffffffffffffffffffffffffbfffffffbfffbfff7fffbfff7bffff7fefff7ffdffffffffffff7fff7ffeffff7fffff33fffffffffffffffffffffffffffffffffffffffffffffa051ffffffffff
fffffff9fffffffffffffffffffffffffbfffffffbfffbfffffffbfff63feffffffff7ffdfffeffff7fff7fff7fffffff7ffffffc3ffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff9fffffffffffffffffffffbfffbfffbfffffffbfffffff7fff5bfeffffffff7ffffffeffff7fff7fff7ff
fffff7fff7ffed9fffffffffffffffffffffffffffffffffffffffffffa051fffffffffff7ffb079fffffffffffffffffffffbfffffffbfffffffbfff7fff7ffefbfeffbfeffffffffffeffff7ffffffffffefffeffff7ffffe67fffffffffffffffffffffffffffffffffffffffff50a9ffffffffffebffb7f9ffffffffffff
fffffffffbfffffffbfffbfffffff7ffffff9fffeffbfeffffffbfffefffefffffffffffeffffffff7ffffff8fffffffffffffffffffffffffffffffffffffffffa051ffffffffffddff37f9fffffffffffffffffffffbfffbfff7fffbfffffff7fffffe7ffffffbfefffdffbffffffffffff7fff7ffeffffffff7ffefffefff
ffffffffffffffffffffffffffffffffffffff50a9ffffffffffddfeb4f83ffffffffffffffffffffffffbfffffffbfffbfff7fff7f97fdffffbff7ffdffbffffffffffff7fff7ffefffefffffffefffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffddfeb3783ffffffffffffffffffffffffbffffff
f7fffbfffffff7ff7fdfeffffffffdffbfffefffeffff7fff7ffffffefffffffeffff7ffffffffffffffffffffffffffffffffffffffff56a9ffffffffffddfdbf79fffffffffffffffffffffbfffbfff7fffffffbfffffff79f7fdff7fffffffeffffffefffefffeffff7ffffffefffefffefffe7ffffffffffffffffffffff
ffffffffffffffffffa651ffffffffffddfc1f79fffffffffffffffffffffbfffffff7fffffffbfff7fff47fffdff7fdff7fffffffffdfffefffffffffffefffefffefffffffe7ffffffffffffffffffffffffffffffffffffffff5ca9ffffffffffebdfb779fffffffffffffffffffffbfffffff7fff7fffffff7fff2ffffff
f7fdff7fffff7fffdfffefffffffffffefffffffefffffffe7ffffffffffffffffffffffffffffffffffffffffa651fffffffffff78fb8f9fffffffffffffffffffffbfff7fff7fff7fffffff7fffeffbffffffdff7fff7f7fffffffffffeffff7ffefffffffefffdfffe7ffffffffffffffffffffffffffffffffffffffff56
a9ffffffffffffdffff9fffffffffffffffffffffffff7fffffff7fff7ffefff3effbfdffffdffbfff7f7fffffffffffefffefffefffefffffffdffff7ffffffffffffffffffffffffffffffffffffffffa651fffffffffffffffff9fffffffffffffffffffffffff7fffffff7fff7fffff8ffffbfeff7ffffffff7effffdfff
efffefffefffffffefffffffdffff7ffffffffffffffffffffffffffffffffffffffff5aa9fffffffffffffffff9fffffffffffffffffffff7fff7fff7fffffff7ffffe3ffffbfeff7ffffffffbfffffdfffefffefffefffffffefffefffdfffd7ffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffff9
fffffffffffffffffffff7fffffff7fffffff7ffeffbff7fffeff7fdffbfffffffffdfffefffffffffffdfffefffefffffffdbffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffdffef9fffffffffffffffffffff7fffffff7fff7ffffffef7bff7ffffffbfeffbffffeffffdfffefffffffffffdfffffff
efffffffdbffffffffffffffffffffffffffffffffffffffffa651ffffffffffffaffef9fffffffffffffffffffff7fff7fff7fff7ffffffecffff7fbffffffeffdfffdeffffffffffffefffefffdfffffffefffdfffdbffffffffffffffffffffffffffffffffffffffff50a9ffffffffffff77fcf9ffffffffffffffffffff
fffff7fffffff7fff7ffe3ffff7fdfeffffeffdfffddffffffffffffefffefffdfffdfffffffdffffbffffffffffffffffffffffffffffffffffffffffa051ffffffffffff77faf83ffffffffffffffffffffffff7fffffff7fff7ffc7fdffffdfeffbffffffffedffffbfffdfffefffefffffffdfffffffdffffbffffffffff
ffffffffffffffffffffffffffffff51a9ffffffffffff77faf83ffffffffffffffffffff7fff7ffeffffffff7ffb7fdffffdfeffbffffffffefffffbfffdfffefffefffffffdfffdfffdfffdbffffffffffffffffffffffffffffffffffffffffa151ffffffffffff77f6f9fffffffffffffffffffff7ffffffeffffffff7fd
f7fdff7ffff7fbfeffdfffffffffbfffdfffffffffffdfffdfffdfffffffdbffffffffffffffffffffffffffffffffffffffff51a9ffffffffffff77f079fffffffffffffffffffff7ffffffefffeffffff3fffdffbffffffbfeffdffffdffffbfffdfffffffffffdfffffffdfffffffdbffffffffffffffffffffffffffffff
ffffffffffa151ffffffffffffaf7ef9fffffffffffffffffffff7ffefffefffefffffefffffffbfdfffffff7feffff3ffffffffffffdfffefffdfffffffdfffbfffdbffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffde3ef9ffffffffffffffffffffffffefffffffeffff7effbffffbfdff7ffff7fef
fff3ffffffffffffdfffefffdfffdfffffffbffffbffffffffffffffffffffffffffffffffffffffffa151ffffffffffffff7ff9ffffffffffffffffffffffffefffffffefffefeffbfeffffdff7fdfffffffffbffffbfffdfffdfffefffffffdfffffffbffffbffffffffffffffffffffffffffffffffffffffff51a9ffffff
fffffffffff9fffffffffffffffffffff7ffefffefffffffefeffbfeffffeff7fdfffffffffbffffbfffdfffdfffdfffffffdfffdfffbfffbbffffffffffffffffffffffffffffffffffffffffa151fffffffffffffffff9fffffffffffffffffffff7ffffffefffffffefeffbfeffbffff7fdff7feffffbffffbfffdfffffff
ffffdfffdfffdfffffffbbffffffffffffffffffffffffffffffffffffffff51a9fffffffffff7fc1079ffffffffffffffffffffefffffffefffefffffeffffeffbffffffdff7feffffbffffbfffdfffffffffffbfffffffdfffffffbbffffffffffffffffffffffffffffffffffffffffa151ffffffffffebffd7f9ffffffff
ffffffffffffefffefffefffefffffd7ffffffbfefffffff7ff7fff5ffffffffffffdfffdfffbfffffffdfffbfffbdffffffffffffffffffffffffffffffffffffffff51a9ffffffffffddffb7f9ffffffffffffffffffffffffefffffffefffefd7fdffffdfeffbffffbff7fffdffffffffffffdfffdfffbfffdfffffffbfff
fdffffffffffffffffffffffffffffffffffffffffa151ffffffffffddff74f83fffffffffffffffffffffffefffffffefffefd7fdfeffffeffbfdffffffffffffff7fffbfffdfffdfffffffbfffffffbffffdffffffffffffffffffffffffffffffffffffffff51a9ffffffffffddfe33783fffffffffffffffffffefffefff
efffffffefd7fdfeffffeffbfefffffffff7ffff7fffbfffdfffdfffffffbfffdfffbfffbdffffffffffffffffffffffffffffffffffffffffa051ffffffffffddffdf79ffffffffffffffffffffefffffffefffffffefdffdff7fdffffbfeffbff7fff6ffff7fffbfffffffffffbfffbfffdfffffffbdffffffffffffffffff
ffffffffffffffffffffff50a9ffffffffffddffdf79ffffffffffffffffffffefffffffdfffefffffdfffff7fdffffffeffbff7fff6ffff7fffbfffffffffffbfffffffbfffffffbdffffffffffffffffffffffffffffffffffffffffa051ffffffffffebddd779ffffffffffffffffffffefffefffdfffefffffdbffffffdf
f7ffffffbffbffeeffffffffffffbfffdfffbfffffffbfffbfffbdffffffffffffffffffffffffffffffffffffffff50a9fffffffffff78e38f9ffffffffffffffffffffffffdfffffffdfffefdbfdffffdff7fbffffbffbffff7fffffffffffbfffdfffbfffbfffffffbffffdffffffffffffffffffffffffffffffffffffff
ffa051ffffffffffffdffff9ffffffffffffffffffffffffdfffffffdfffefbbfdff7ffff7fbfeffffffffffffff7fffbfffbfffdfffffffbfffffff7ffffdffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffffefffdfffdfffffffefbbfeff7ffff7fdfeffffffffefffff
7fffbfffbfffdfffffffbfffbfff7fffbdffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffffefffffffdfffffffdfbffeff7feffffdfeffdffbffefbfff7fffbfffffffffffbfffbfffbfffffffbdffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffff
fff9ffffffffffffffffffffefffffffdfffdfffffbfffff7fefffffff7fdffbffefbffeffffbfffffffffffbfffffffbfffffff7dffffffffffffffffffffffffffffffffffffffffa051ffffffffffffdff079ffffffffffffffffffffefffdfffdfffdfffffbbffffffeff7ffffffdffdffdfbfffffffffffbfffbfffbfff
ffffbfff7fff7dffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffafff79ffffffffffffffffffffffffdfffffffdfffdfbbfeffffeff7fdffffdffdffffdfffffffffffbfffbfff7fffbfffffff7ffffdffffffffffffffffffffffffffffffffffffffffa051ffffffffffff77fef9ffffffffffffffff
ffffffffdfffffffdfffdfbdfeffbffffbfdff7ffffffffffffeffff7fffbfffbfffffffbfffffff7ffffeffffffffffffffffffffffffffffffffffffffff50a9ffffffffffff77fdf83fffffffffffffffffffdfffdfffdfffffffdf7dfeffbffffbfdff7fffffffdffffeffff7fffbfffbfffffffbfffbfff7fff7effffff
ffffffffffffffffffffffffffffffffffa051ffffffffffff77f8f83fffffffffffffffffffdfffffffdfffffffdf7ffeffbfeffffdff7feffdffdfeffeffff7fffffffffff7fff7fffbfffffff7effffffffffffffffffffffffffffffffffffffff50a9ffffffffffff77ff79ffffffffffffffffffffdfffffffdfffdfff
ff7fffffbfefffffff7feffdffbfeffeffff7fffffffffff7fffffffbfffffff7effffffffffffffffffffffffffffffffffffffffa051ffffffffffff77ff79ffffffffffffffffffffdfffdfffdfffdfffff7dfffffff7fbffffffeffeffbfefffffffffffbfffbfff7fffffffbfff7fff7effffffffffffffffffffffffff
ffffffffffffff58a9ffffffffffffaf7779ffffffffffffffffffffffffdfffffffdfffdf7dff7ffff7fbfeffffeffeffffefffffffffffbfffbfff7fff7fffffff7ffffeffffffffffffffffffffffffffffffffffffffffa051ffffffffffffde38f9ffffffffffffffffffffffffbfffffffdfffdf7dff7fdffffbfeffbf
fffffffffffeffff7fff7fffbfffffff7fffffff7ffffeffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffff7ff9ffffffffffffffffffffdfffbfffbfffffffdf7dff7fdffffbfeffbfffffffbffffdffff7fff7fffbfffffff7fff7fff7fff7effffffffffffffffffffffffffffffffffffffffa051ff
fffffffffffffff9ffffffffffffffffffffdfffffffbfffffffdeffff7fdff7fffeffbfeffeffbff7fdffff7fffffffffff7fff7fff7fffffff7effffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffffdfffffffbfffbffffeffffffdff7ffffffbff7ff7f7ffbfdffff7fff
ffffffff7fffffff7fffffff7effffffffffffffffffffffffffffffffffffffffa051fffffffffff7fe3079ffffffffffffffffffffdfffbfffbfffbffffefefffffff7fdfffffff7ff7f7ffbffffffffff7fffbfff7fffffff7ffeffff7effffffffffffffffffffffffffffffffffffffff58a9ffffffffffebfdd7f9ffff
ffffffffffffffffffffbfffffffbfffbefeffbffff7fdff7ffff7ff7ffffbffffffffff7fff7fff7fff7ffffffefffffeffffffffffffffffffffffffffffffffffffffffa051ffffffffffddfdd7f9ffffffffffffffffffffffffbfffffffbfffbefeffbfdffffdff7fbffffffffffffdfffeffff7fff7fffffff7ffffffe
fffffeffffffffffffffffffffffffffffffffffffffff58a9ffffffffffddffd4f83fffffffffffffffffffbfffbfffbfffffffbefeffbfdffffdff7fdfffffff7ffffdfffeffff7fff7fffffff7fff7ffefffefeffffffffffffffffffffffffffffffffffffffffa851ffffffffffddffb3783fffffffffffffffffffbfff
ffffbfffffffbeffffbfeffbffff7fdff7ff7f7ffdfdfffefffffffffffeffff7fff7ffffffefeffffffffffffffffffffffffffffffffffffffff50a9ffffffffffddff7f79ffffffffffffffffffffbfffffffbfffbffffefeffffeffbffffffdff7ffbefffdfdfffefffffffffffeffffffff7ffffffeff7fffffffffffff
ffffffffffffffffffffffffffa851ffffffffffddfeff79ffffffffffffffffffffbfffbfffbfffbffffdfe7ffffffbfefffffffbffbefffeffffffffff7fff7ffeffffffff7ffefffeff7fffffffffffffffffffffffffffffffffffffff50a9ffffffffffebddf779ffffffffffffffffffffffffbfffffffbfffbdfe7fbf
fffbfeff7ffffbffbffffeffffffffff7fff7ffefffefffffffeffffff7fffffffffffffffffffffffffffffffffffffffa851fffffffffff78c18f9ffffffffffffffffffffffff7fffffffbfffbdfe7fbfeffffeff7fdffffffffffffbfffeffff7fff7ffffffefffffffeffffff7fffffffffffffffffffffffffffffffff
ffffff50a9ffffffffffffdffff9ffffffffffffffffffffbfff7fff7fffffffbdfe7fdfeffffeffbfdffffffefffffbfffeffff7fff7ffffffefffefffefffeff7fffffffffffffffffffffffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffffbfffffff7fffffffbdfdffdfeffbffffbfdffbffbdff
ff7bfffefffffffffffefffefffefffffffeff7fffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffffbfffffff7fff7ffffdfdffffeffdffffffeffbffddffff7bfffefffffffffffefffffffefffffffeff7fffffffffffffffffffffffffffffffffffffffa051ffffffffff
ffdff8f9ffffffffffffffffffffbfff7fff7fff7ffffdfd7ffffffdfefffffffbffddffffbffffffffeffff7ffefffffffefffdfffeff0fffffffffffffffffffffffffffffffffffffff50a9ffffffffffffaff779ffffffffffffffffffffffff7fffffff7fffbbfd7fdffffdfeffbffffdffdfffffbffffffffeffff7ffe
fffefffffffdffffff7c3fffffffffffffffffffffffffffffffffffffa851ffffffffffff77f779ffffffffffffffffffffffff7fffffff7fff7bfdbfdff7ffff7fbfeffffffffffffbfffefffeffff7ffffffefffffffdffffff7fd9ffffffffffffffffffffffffffffffffffff50a9ffffffffffff77ff783fffffffffff
ffffffffbfff7fff7fffffff7bfdbfdff7ffff7fbfeffffffdfffffbfffdfffefffefffffffefffefffdfffdff77fe67ffffffffffffffffffffffffffffffffffa051ffffffffffff77fef83fffffffffffffffffffbfffffff7fffffff7bfdffdff7fdffffbfeffdffdbffffdbfffdfffffffffffefffefffefffffffdff4f
fff83fffffffffffffffffffffffffffffffff50a9ffffffffffff77fdf9ffffffffffffffffffff7fffffff7fff7ffffbfdfffff7fdffffffeffdffebffffdbfffdfffffffffffefffffffefffffffdff3ffffbd9ffffffffffffffffffffffffffffffffa851ffffffffffff77fbf9ffffffffffffffffffff7fff7fff7fff
7ffffbfbbffffffdff7ffffffdffebffffdffffffffefffefffdfffffffefffdfffdff0fffdffe67ffffffffffffffffffffffffffffff58a9ffffffffffffaf77f9ffffffffffffffffffffffff7fffffff7fff7bfbbfeffffeff7fdffffdffefffffeffffffffefffefffdfffefffffffdffffffb6ff3ffff81fffffffffff
ffffffffffffffffffa051ffffffffffffde3079ffffffffffffffffffffffff7fffffff7fff77fbbfeffbffff7fdff7fffffffffff7fffdfffefffefffffffefffffffdffffffbf1efffff3f87fffffffffffffffffffffffffff50a9ffffffffffffff7ff9ffffffffffffffffffff7ffeffff7fffffff77fbbfeffbffff7f
dff7fffffbfffff7fffdfffefffefffffffdfffefffdfffdffbff83fffffffe03fffffffffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffff7fffffff7fffffff77fbffeffbfeffffdff7feffe7fffff7fffdfffffffffffdfffdfffefffffffdffbfe7f0ff3ffff9d9ffffffffffffffffffffffff58
a9fffffffffffffffff9ffffffffffffffffffff7ffffffeffff7ffff7fbfffffbfefffffff7fefff7fffff7fffdfffffffffffdfffffffdfffffffdffbfffffc07ffff7fe6fffffffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffff1ffefffeffff7ffff7fbdffffffeffbffffffefff7fffff3ffff
fffdfffefffdfffffffdfffdfffdffbe7ffff3b3ffbffff07fffffffffffffffffffff50a9fffffffffff7ff7079fffffffffffffffffffcecfefffffffeffff77fbdff7fffeffbfdffffefff7fffff3fffffffdfffefffdfffdfffffffdffffff80ffffeffcde7ffff7b3ffffffffffffffffffffa051ffffffffffebfe77f9
fffffffffffffffffffbff32fffffffeffff77f7dff7fbffffbfeff7fffff7ffffedfffdfffdfffefffffffdfffffffbffffff8f67ff7fffe0ffffbffccfffffffffffffffffff50a9ffffffffffddfd77f9ffffffffffffffffffdffffc3ffeffffffff77f7dff7fdffffbfeffbfffff7ffffeffffdfffdfffefffffffdfffd
fffbfffdffbff9bcffffef67fe7ffff1ffffffffffffffffffa051ffffffffffddff74f83fffffffffffffffff3ffffbd9fefffffffeeff7fff7fdff7fffeffbff7ffbfffffffffbfffffffffffdfffdfffdfffffffdffbfffc0ffff7ff9bdffffe1ffffffffffffffffff50a9ffffffffffddff73783ffffffffffffffffc1f
ffdffe66fffeffffeff7fffffdff7ffffffbff7febffffff7ffbfffffffffffdfffffffdfffffffbffbfffcf67fcffffc07ffff9ffffffffffffffffffa051ffffffffffddff7f79fffffffffffffffff3f87f3ffff81ffeffffeff7efffffff7fbfffffff7fdfffffdfbffffffdfffdfffdfffffffdfffbfffbffbffffff9bb
ffffefe1fe79ffffffffffffffffff50a9ffffffffffddff7f79ffffffffffffffffffffe07ffff7f87efffeeff7eff7ffff7fdfefffff7fdfffffdfdffffffdfffdfffdfffdfffffffbffffff87fcffffc0ffff7fff81f9ffffffffffffffffffa051ffffffffffebdf7779ffffffffffffffff3ffff3b3ffbfffe01ffeeff7
effbfdffffdfeffbffffbeffffdfdffbfffdfffdfffffffdfffffffbffffffbb73ffffdfc3fcffffe7f9ffffffffffffffffff50a9fffffffffff78c18f9fffffffffffffff8fffffffcce7ffff9f87eeff7effbfdffffdfeffbfffffeffffdffffbfffdfffdfffffffdfffdfffbfffbffbf80fffeffff01ffffdff9ffffffff
ffffffffffa051ffffffffffffdffff9ffffffffffffffe767ffbffff07ffff7ffe06feffffbfdff7ffff7fbffbfff7ffffffffbfffffffffffbfffdfffdfffffffbffdf9fc3f9ffffcecffefff9ffffffffffffffffff50a9fffffffffffffffff9fffffffffffffffff99e7ffff3b3ffbffff39feffffffeff7ffffffdffbf
7f7ffffff7fbfffffffffffbfffffffdfffffffbffdfffff03fffffff339fff9ffffffffffffffffffa051fffffffffffffffff9ffffffffffffff7fffe0ffffeffcde7fffffdfefefffffffbfdfffffffbf7fffffbffbfffffdfffdfffbfffffffdfffbfffbffd9ffff9d9ffeffffc7fff9ffffffffffffffffff50a9ffffff
ffffffdffdf9fffffffffffffcffffe767ff7fffe07fffbfdfeff7fbffffbfdff7ffffbf7fffff7ffdfffffbfffdfffbfffbfffffffbffffffc3ffffffe679ffffcffff9ffffffffffffffffffa051ffffffffffffaff9f9fffffffffffff1fffffff9bcffffe7b3fe7fdfeff7fbfeffffdff7fdfffeffdfff7ffdfbfffbfffd
fffffffbfffffffbffffffdd9ffdffff83ffffbffff9ffffffffffffffffff50a9ffffffffffff77f5f9ffffffffffffcecfff7fffc0fffffffcddffdfefe7fbfeffffeff7fdffffffdfff7ffffbfffbfffdfffffffbfffbfffbfffbffdfe6f3ffff3d9ffdfffff9ffffffffffffffffffa051ffffffffffff77fdf83fffffff
fffffff37cffffcf67fe7fffe07fdfefeffdfeffbffff7fdffbfffeffffffffbfffffffffffbfffbfffbfffffffbffdfff07ffffffe673fffff9ffffffffffffffffff50a9ffffffffffff77fdf83ffffffffffeffff81fffffff9b9ffffe7b1dfefeffffeffbffffffdffddffefffffffb7fffffffffffbfffffffbfffffffb
ffdfff7b3ff3ffff8ffffff9ffffffffffffffffffa051ffffffffffff77fdf9fffffffffff9ffffdecffcffffc07ffffffedfdfe7ffffffbfefffffffddfffffeffffbffffbfffdfffbfffffffbfff7fffbffdffbffcdcfffff3ffffff9ffffffffffffffffff50a9ffffffffffff77fdf9ffffffffffc1fffefff333ffffcf
e1fe7fffbfdfe7fdffffbfeffbffffddfffffeffffdffffbfffbfffbfffbfffffff7ffffffdfe7fffe03fffffffffff9ffffffffffffffffffa051ffffffffffffaf7df9ffffffffffbf87f9ffffc0ffffffff81ffff9fdfd7fdff7fffeffbfefffbfffbfeffffe7fffbfffbfffffffbfffffff7ffffffc3dffffe7f0ff3ffff
fff9ffffffffffffffffff50a9ffffffffffffde3079fffffffffdfffe03ffff9fc3fcffffcecfff3fdfdbfdff7fffeffbfefffffffbfdfffff7fffbfffbfffffffbfffbfff7fff7ffdd87fffffffc0ffffffff9ffffffffffffffffffa051ffffffffffffff7ff9fffffffff3ffff9d9fffffff01fffffff37cbfdfdffdff7f
dffffbfeffdffffdfffffff7fffffffffff7fffbfffbfffffff7ffddfe1fe7ffff3ffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffc7ffffffe679ffffcecffeffff81bfdfdfffff7fdffffffeffd7fffdfffffff7fffffffffff7fffffffbfffffff7ffd3fff80ffffefffffffff9ffffffffffffffff
ffa051fffffffffffffffff9ffffffff3b3ffdffff83ffffbff379ffff9ebfdfdbffffffdff7ffffffe7fffffbffffe9fffbfffbfff7fffffffbfff7fff7ffeffffe767ff7fffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffccf3ffff3d9ffdffff81ffffffbfdfdbfeffffdff7fbffffeffffffbff
ffeefffbfffbfff7fff7fffffff7ffffffeffffdff99cffffffffff9ffffffffffffffffffa051fffffffffff7ff7079fffffffbffff07ffffffe6f3ffffbf87f9ff7fbfdbfeff7ffff7fbfeffefffff7bffffdffffbfffbfffffff7fffffff7ffffffe3ffeffffe3ffffffffff9ffffffffffffffffff50a9ffffffffffebfe
b7f9ffffffe7fffe7b3ff3ffff03fffdfffe07ff7fbfdbfeffbffff7fdff7fefffff7bffffdfcff7fffbfffffff7fff7fff7fff7ffed8f9ffffe7ffffffffff9ffffffffffffffffffa651ffffffffffddfdd7f9ffffff0fffffffcdcfffff7f0ff3ffffc1ff7fbfbffeffbfeffffdff7ff7ffffbffffffff7fffffffff7fff7
fff7fffffff7ffeff61ffffdfffffffffff9ffffffffffffffffff56a9ffffffffffddfdd4f83ffffef67fe7fffe03fffbfffc2fffff3f877fbfbfffffbfefffffff7ffbffffbffffffffbfffffffff7fffffff7fffffff7ffeff9ecffeffffffffffff9ffffffffffffffffffac51ffffffffffddfdd3783ffff7ff999ffffe
7f0fe7ffff83fffffffe7fbfbdffffffeff7ffffffbdfffff7ffff7ffff7fffbfff7fffffff7ffeffff7ffefffff339ffffffffffff9ffffffffffffffffff56a9ffffffffffddfddf79ffffcffffe07fffffffc1fffff7f0ff3ffff7fbfbdfeffffeff7fdffff7ffffff7ffff7fff37fffbfff7fff7ffffffefffffffef9fff
fc7ffffffffffff9ffffffffffffffffffa651ffffffffffddfddf79ffffbffffcfe1fe7ffff07fffbfffc07ffff7fbfbdff7fbffffbfdff7effffffeffffeffffc7fffbfffffff7ffffffefffffffe67ffff9fffffffffffff9ffffffffffffffffff56a9ffffffffffebdeb779fffe0ffffffff81ffffefe1fe7ffff3b3ffa
ffbfbdff7fbffffbfdff7effbfffe3fffdfffff3fff7fffffff7fff7ffefffe7ffe81ffffffffffffffffff9ffffffffffffffffffaa51fffffffffff78f78f9fff9fc3fcfffff07fff7fff80ffffeffcde6ff7fbfff7fbfeffffdff7fffcfffecffffffffecfffffff7fff7fff7ffffffe7ffe3f87f9ffffffffffffff9ffff
ffffffffffffff50a9ffffffffffffdffff9fffffff01ffffcfe1fcffffe767ff7fffe06ff7fbfffffdfefffffffbffff7ff9fdfffffffdfdffffff7fffffff7ffffffe7ffefffe07ffffffffffffff9ffffffffffffffffffa051fffffffffffffffff9ff9ffffcecfffffff81fffffff99cffffe7aff7fbdffffffeffbffff
f7ffffff7fe7fbffffbfe3f7ffeffffffff7ffefffe7ffeffff9fffffffffffffff9ffffffffffffffffff56a9fffffffffffffffff9fe3ffffbff37cffffcecfff7fffe0ffffffeff7f7eff7ffff7fbfefff7fffffffffbf7fffffffff7ffeffff7ffffffeffff7ffeffff7fffffffffffffff9ffffffffffffffffffa051ff
fffffffffffffdf9f9d9ffdffff81fffffff33cffffcf67fe7feff7f7eff7fdffffbfeffaffffeffffff37ffffffff17fffffff7ffffffeffffbfff1ffbffffffffffffffff9ffffffffffffffffff50a9fffffffffffffffaf9f7fe6f3ffff9ecffeffffc1fffffff9b9ffeff7f7eff7fdffffbfeff8fffff73ffffc3fffdff
ffe3ffffffeffff7ffefffebfff6de7ffffffffffffffff9ffffffffffffffffffa151fffffffffffffff779bffff03fffffff379ffffdecffcffffc07feff7f7fffbfdff7fffeff73ffffafffff3d9ffbffff9cffefffeffff7ffffffebfff7e1fffffffffffffffff9ffffffffffffffffff51a9fffffffffffffff7787fff
f9d9ff9ffff83fffefff333ffffcfe1dff7f7fffffdff7fffffeffffffc3ffffffe6f7ffff7fc3efffffffefffffffebfff7e7fffffffffffffffff9ffffffffffffffffffa151fffffffffffffff7787ffff7fe6e7ffffbd9ff9ffffc0ffffffff8feff7efffffff7fdffffff3fff3d9ffbffff03ffffffff2fffffffefffef
ffe0fff7fffffffffffffffffff9ffffffffffffffffff51a9fffffffffffffff779b3ffbffff03fffdffe677ffff9fc3fcffffdfeff7effbffff7fdff77ffcfffffe6e7ffff9d9ffbffffc3ffefffffffefffff07f77ffffffffffffffffff9ffffffffffffffffffa151fffffffffffffff779fcce7ffff3d9ff3ffff81fff
fffff01ffffdfeff7effbfeffffdff6ffffffbffff07ffff7fe6e7ffff9d9fefffffffdffffff834fffffffffffffffffff9ffffffffffffffffff51a9fffffffffffffffaf9fff07fffeffe6efffff3f87f9ffffcecffedfefeff7fbfeffffdff5ffffce7ffff3b3ffbffff07ffffffe66fffefffdfffefffc3ffffffffffff
fffffff9ffffffffffffffffffa151fffffffffffffffdf9ffffb3ff7ffff03fffffffe03ffffbff379dfefeffffbfeffbffff3fffff0ffffeffcde7ffff7b3ffdffff83ffefffffffeffffffffffffffffffffffff9ffffffffffffffffff51a9fffffffffffffffff9fffffcdcffffe7f0ff3ffff9d9ffdffff81dfefeff7f
ffeffbffff1ffffe767ff7fffe07fffbffccf3ffff7d9fefffffffdffffffffffffffffffffffff9ffffffffffffffffffa151fffffffffffffffff9ffffffe07fffffffc07ffff7fe6f3ffffbf9fefeff7ffffffbfefce7ffffff9bcffffe7b3fe7ffff03fffbffe663ffdfffc07ffffffffffffffffffffff9ffffffffffff
ffffff51a9fffffffffffffffff9ffffffffe1fe7ffff3b3ffbffff07fffdffbfefeff7fdffffbfefffe1ff7fffc0fffffffcddfffff7f0fe7ffff8d9fdfffe001fffffffffffffffffffff9ffffffffffffffffffa151fffffffffffffffff9ffffffffff80ffffeffcde7ffff7b3ff3ffbfdfefe7fdfeffffeeffff9cffffc
f67fe7fffe07fffbfffc1fffff3fe6dfffff8007fffffffffffffffffff9ffffffffffffffffff51a9fffffffffffffffff9ffffffffffff67ff7fffe07fffbffcdefffbfdfefe7fdff7fffe9ffffe1fffffff9b9ffffefe1fe7ffff83ffffffff07ffdffe001ffffffffffffffffff9ffffffffffffffffffa151ffffffffff
fffffff9fffffffffffff99cfffff3b3fe7fffe03ffbfdfefeffdff7fbfe3ffffdecffcffffc07fff7fff85ffffe7f0ff3ffff3b3fdffff8007ffffffffffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffe07fffeffcddfffff7f0fbfdfdf9fffff7fdf9cfffefff373ffffcfe1fcfffff07ffff
fffc07ffffffccdfffffe001fffffffffffffff9ffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffe1ff7fffe07fffbfffc3fdfde7bffffffdfffc7f9ffff80ffffffff83ffffefe1fe7ffff3b3ffbffff1fffffff800ffffffffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffff
ffffff84ffffcfe1fe7ffff3fdfd9fbfdffffddfffb77ffff9fc3fcffffe0ffff7fff80ffffeffcde7ffff3ffffffffc003ffffffffffff9ffffffffffffffffffa051fffffffffffffffff9fffffffffffffffffff87fffffff80ffffe7fdfc7fbfeff7ff3ffff81ffffffff03ffffdfc3fcffffe767ff7fffe0fffffffffff
fffff000fffffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffffe07cffffe767ff77fdfdffbfeff7fc3ffff3f87f9ffff9d9ffeffff01ffffdff9bcffffef67ffbffffffffffffc003fffffffff9ffffffffffffffffffa051fffffffffffffffff9fffffffffffffffffffff801ffffdff9
9cf7fbf3ffffeff7f3d9ffffffe03ffffffe6f9ffffcecffeffffc0ffff7ff99e7ffffffffffffff000ffffffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffffe0fecffeffffe077fbcffffffffbfffe6f3ffff9d9ffdffff03ffffbff379ffffcf67fcffffe1ffffffffffffffffc007ffffff9
ffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffffc3fff339ffffe7e7fb3fffbfffffbffff07ffff7fe6f3ffff3d9ffdffff81fffffff9bbffffcffffffffffffffffffe001fffff9ffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffffff0fffffc1ffffdff7f8ffffdfeffe7fff
f3b3ffbffff07ffffffe673ffff9ecffcffffc0fffffffffffffffffffffffff8007fff9ffffffffffffffffffa051fffffffffffffffff9fffffffffffffffffffc3ffffffecffefff7f3ffffdfeff87fffeffcde7ffff7b3ff3ffff83fffffff373ffffdfc3fcffffffffffffffffffffffe001ff9ffffffffffffffffff50
a9fffffffffffffffff9fffffffffffffffffff0fffffffff339ffefcfffffdfefe7b7ff7fffe07fffbffcccfffff3d9ff9ffff81fffeffff03ffffffffffffffffffffffff80079ffffffffffffffffffa051fffffffffffffffff9ffffffffffffffffffc3ffffffffffc0ffee3ffffffff7dff8fcffffe7b3fe7ffff07fff
fffe6e7ffffbf87f9ffffcffffffffffffffffffffffffffe001ffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffffff0fffffffffffffc3e9fffffffffeffffc0fffffffcddffffe7b3ff3ffff01fffdfffe03ffffbffffffffffffffffffffffffffff83ffffffffffffffffffa051fffffffffffffffff9
fffffffffffffffffc3fffffffffffffff07ffffffdff9ffffcf67fe7fffe0fffffffcdcfffff3f87f3ffff9d9ffdfffffffffffffffffffffffffffffc1ffffffffffffffffff50a9fffffffffffffffff9fffffffffffffffff0ffffffffffffffffffffffffdff0fffffff9b9ffffef67fe7fffe03fffffffe07ffffffe67
3fffffffffffffffffffffffffffff07ffffffffffffffffffa851fffffffffffffffff9ffffffffffffffffc3ffffffffffffffffffffffffdfcf6ffcffffc0ffff7ff9b9ffffe7f0ff3ffff3b3ffdffff8fffffffffffffffffffffffffffffc1fffffffffffffffffff50a9fffffffffffffffff9ffffffffffffffff0fff
ffffffffffffffffffffffefbff1f3ffffcf67fcffffc07fffffffc07ffffffccf3ffff9fffffffffffffffffffffffffffff07fffffffffffffffffffa851fffffffffffffffff9fffffffffffffffc1ffffffffffffffffffffffffffdffff81fffffff9b1ffffcfe1fe7ffff3b3ffbffff07ffff7ffffffffffffffffffff
ffffffffe1ffffffffffffffffffff50a9fffffffffffffffff9fffffffffffffff07ffffffffffffffffffffffffff3ffff9ecffcffffc6cfffffff80ffffeffcde7ffff7b3ffbfffffffffffffffffffffffffffff87ffffffffffffffffffffa051fffffffffffffffff9ffffffffffffffc1ffffffffffffffffffffffff
ffe1fffffff361fffffff37cffffe767ff7fffe0ffffbffcce7ffffffffffffffffffffffffffffe1fffffffffffffffffffff50a9fffffffffffffffff9ffffffffffffff07fffffffffffffffffffffffffffecff9ffff8edffeffff81ffffdff9bcffffef67fe7ffff1fffffffffffffffffffffffffffff87fffffffffff
ffffffffffa851fffffffffffffffff9fffffffffffffc1ffffffffffffffffffffffffffffff363ffff7fe3f9ffffdecffeffffc0ffff7ff9bdffffe7ffffffffffffffffffffffffffffe1ffffffffffffffffffffff50a9fffffffffffffffff9fffffffffffff07fffffffffffffffffffffffffffffff8d9ffbffff03ff
fefff379ffffdfc3fcffffc07fffffffffffffffffffffffffffffffff87ffffffffffffffffffffffa851fffffffffffffffff9ffffffffffffe1ffffffffffffffffffffffffffffffffffe6e7ffff9d9ff9ffff80fffeffff0bffffcfe1fe7ffffffffffffffffffffffffffffe1fffffffffffffffffffffff58a9ffffff
fffffffffff9ffffffffffff87ffffffffffffffffffffffffffffffffffff07ffff7fe677ffff9fc3f9ffffe0ffffffff81fffffffffffffffffffffffffffff87fffffffffffffffffffffffa051fffffffffffffffff9fffffffffffe1ffffffffffffffffffffffffffffffffffffffb3ffbffff81ffffffff07ffffdfc3
fcffffe7ffffffffffffffffffffffffffffe1ffffffffffffffffffffffff58a9fffffffffffffffff9fffffffffff87fffffffffffffffffffffffffffffffffffffffcce7ffff9f87f9ffffc1fffeffff01ffffdfffffffffffffffffffffffffffff87ffffffffffffffffffffffffa051fffffffffffffffff9ffffffff
ffe1ffffffffffffffffffffffffffffffffffffffffff03ffff7ffe07ffffbf87f9ffffcecffefffffffffffffffffffffffffffffe1fffffffffffffffffffffffff58a9fffffffffffffffff9ffffffffff87ffffffffffffffffffffffffffffffffffffffffffff0ffbffffc1fffdfffe03ffffbff339ffffffffffffff
fffffffffffffff87fffffffffffffffffffffffffa051fffffffffffffffff9fffffffffe1ffffffffffffffffffffffffffffffffffffffffffffffc27ffff3f87f3ffff9d9ffdffffc7ffffffffffffffffffffffffffffe1ffffffffffffffffffffffffff50a9fffffffffffffffff9fffffffff87fffffffffffffffff
ffffffffffffffffffffffffffffffc3fffefffe07ffff7fe6f3ffffcfffffffffffffffffffffffffffff87ffffffffffffffffffffffffffa051fffffffffffffffff9ffffffffe1ffffffffffffffffffffffffffffffffffffffffffffffffff0fe7ffff3b3ffbffff03ffffbffffffffffffffffffffffffffffe0fffff
ffffffffffffffffffffff50a9fffffffffffffffff9ffffffff87fffffffffffffffffffffffffffffffffffffffffffffffffffc0ffffeffcde7ffff3d9ffdfffffffffffffffffffffffffffff83fffffffffffffffffffffffffffa051fffffffffffffffff9fffffffe0fffffffffffffffffffffffffffffffffffffff
fffffffffffffff67ff7fffe07ffffffe673ffffffffffffffffffffffffffffe0ffffffffffffffffffffffffffff58a9fffffffffffffffff9fffffff83fffffffffffffffffffffffffffffffffffffffffffffffffffffff99cffffe7b3ff3ffff8fffffffffffffffffffffffffffff83ffffffffffffffffffffffffff
ffa051fffffffffffffffff9ffffffe0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffe07ffffffcdcfffff3ffffffffffffffffffffffffffffe0fffffffffffffffffffffffffffff50a9fffffffffffffffff9ffffff83fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe
1fe7fffe03fffffffffffffffffffffffffffffffff83fffffffffffffffffffffffffffffa051fffffffffffffffff9fffffe0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff80ffffe7f0ff3ffffffffffffffffffffffffffffe0ffffffffffffffffffffffffffffff58a9ffffffffffffff
fff9fffff83ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff67ffffffc0fffffffffffffffffffffffffffff83ffffffffffffffffffffffffffffffa851fffffffffffffffff9fffff0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff99e7fffe7fffffff
fffffffffffffffffffffe0fffffffffffffffffffffffffffffff50a9fffffffffffffffff9ffffc3fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe0ffffdfffffffffffffffffffffffffffffc3fffffffffffffffffffffffffffffffa051fffffffffffffffff9ffff0fffffffffff
fffffffffffffffffffffffffffffffffffffffffffffffffffffffffff67feffffffffffffffffffffffffffffff0ffffffffffffffffffffffffffffffff50a9fffffffffffffffff9fffc3fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff9b9fffffffffffffffffffffffffffff
c3ffffffffffffffffffffffffffffffffa851fffffffffffffffff9fff0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc7fffffffffffffffffffffffffffff0fffffffffffffffffffffffffffffffff50a9fffffffffffffffff9ffc3ffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffffffffc3fffffffffffffffffffffffffffffffffa051fffffffffffffffff9ff0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffffffff0ffffffffffffffffffff
ffffffffffffff50a9fffffffffffffffff9fc3ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffffffffffc3ffffffffffffffffffffffffffffffffffa051fffffffffffffffff9f0ffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffffffffe7fffffffffffffffffffffffffff0fffffffffffffffffffffffffffffffffff50a9fffffffffffffffff9c3fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffffffc3fffffffffffffffffffffffffffffffffffa051ff
fffffffffffffff907fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffffff0ffffffffffffffffffffffffffffffffffff50a9fffffffffffffffff81fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fe7fffffffffffffffffffffffffc3ffffffffffffffffffffffffffffffffffffa051fffffffffffffffffc0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffffffff0fffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffc003f
fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffffc3fffffffffffffffffffffffffffffffffffffa051fffffffffffffffffff000fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffff
fffffff0ffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffc003fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffffffc1ffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffff000fffffffffffffffff
fffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffffff07ffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffc007ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffffc1fffffffffffff
ffffffffffffffffffffffffffa051ffffffffffffffffffffffffe001fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffff07fffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffff8007ffffffffffffffffffffffffffffffff
fffffffffffffffffffffffffffffffffe7fffffffffffffffffffffc1ffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffe001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffff07ffffffffffffffffffffffffffffffffff
ffffff50a9fffffffffffffffffffffffffffff8007ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffffffc1fffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffe001ffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffe7ffffffffffffffffffff07fffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffff800ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffffc1ffffffffffffffffffffffffffffffffffffffffffa051ffffffffff
fffffffffffffffffffffffc003ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffff07ffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffff000fffffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffff
fffffffffffffe1fffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffc003fffffffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffff87fffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffff
ffffffff000ffffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffffe1ffffffffffffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffc007ffffffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffff87ffffff
ffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffe001fffffffffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffffe1fffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffff8007ffff
fffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffffff87fffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffe001ffffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffffe1ffffffffffffffffffffffffffff
ffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffff8007ffffffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffff87fffffffffffffffffffffffeefffffffffffffffffffff56a9ffffffffffffffffffffffffffffffffffffffffffffffe001ffffffffffffffffffff
fffffffffffffffffffffffffe7ffffffffffffffe1fffffffffffffffffffffffff5fffffffffffffffffffffa651ffffffffffffffffffffffffffffffffffffffffffffffff800ffffffffffffffffffffffffffffffffffffffffffffe7ffffffffffffff87fffffffffffffffffffffffffbfffffffffffffffffffff5c
a9fffffffffffffffffffffffffffffffffffffffffffffffffc003ffffffffffffffffffffffffffffffffffffffffffe7fffffffffffffe1ffffffffffffffffffffffffffbfffffffffffffffffffffa651fffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffffffffffffffffffffffffffffffff
fffffe7fffffffffffff87ffffffffffffffffffffffffff5fffffffffffffffffffff56a9ffffffffffffffffffffffffffffffffffffffffffffffffffffc003fffffffffffffffffffffffffffffffffffffffe7ffffffffffffe1ffffffffffffffffffffffffffeefffffffffffffffffffffa651ffffffffffffffffff
ffffffffffffffffffffffffffffffffffff000ffffffffffffffffffffffffffffffffffffffe7ffffffffffff87fffffffffffffffffffffffffffffffffffffffffffffffff5aa9fffffffffffffffffffffffffffffffffffffffffffffffffffffffc007ffffffffffffffffffffffffffffffffffffe7fffffffffffe0
ffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffe001fffffffffffffffffffffffffffffffffffe7fffffffffff83ffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffff8007fffffffffffffffffffffffffffffffffe7ffffffffffe0fffffffffffffffffffffffffffffffffffffffffffffffffffa651fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe001ffffffffffffffffffffffffffffffffe7ffffffffff83fffffffffffffffffffff
ffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff8007ffffffffffffffffffffffffffffffe7fffffffffe0ffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffe003fffffffffffffffffffffffffffffe7fffffffff83ffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffffffffffffffffffffffffe7ffffffffe0fffffffffffffffffffffffffffffffffffffffffff
ffffffffffa151fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc003ffffffffffffffffffffffffffe7ffffffff83fffffffffffffffffffffffffffffffffffffffffffffffffffff51a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffff
fffffffffffffffffe7fffffffe0ffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc003fffffffffffffffffffffffe7fffffffc3ffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffffffffffffffffffe7fffffff0fffffffffffffffffffffffffffffffffffffffffffffffffffffffa151fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc007ffffffffffffffffffffe7f
fffffc3fffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe001fffffffffffffffffffe7ffffff0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffff8007fffffffffffffffffe7fffffc3ffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe001ffffffffffffffffe7fffff0fffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffa151fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff8007ffffffffffffffe7ffffc3fffffffffffffffffffffffffffffffffffffffffffffffffffffffff51a9ffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffe003fffffffffffffe7ffff0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa151ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffffffffe7fffc3ffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffff51a9fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc003ffffffffffe7fff0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
fffffffffffffffff000fffffffffe7ffc3fffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc003fffffffe7ff0ffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff000ffffffe7fc3ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffeeffffffffffffffffffffffffffffffffffffffff
fc007ffffe7f0fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffeeffffffffffffffffffffffffffffffffffffffffffe001fffe7c1fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffff
ffffffffffffffffffffffffffffffeeffffffffffffffffffffffffffffffffffffffffffff8007fe707fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffecfffffffffffffffffffffffffffffffffffffffffffffe001e41ffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9fffffffffffffffffffffffffffffffffffffffffffff2fffffffffffffffffffffffffffffffffffffffffffffff80007ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffff
fffffffffffeffffffffffffffffffffffffffffffffffffffffffffffffe01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffeeffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffa051fffffffffffffffffffffffffffffffffffffffffffff1ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffa851ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50
a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff58a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffff00fdfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50a9ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffa051ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff50abffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa0555554d5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555550aaaaaaaaaaaaaaaa
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa6aaaaa0555554d55555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555
55555555555555555555555555555555555555555555555555555550aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa6aaaaa6
restore showpage end 
%%Trailer 

%%EndDocument
temp-save restore
end
showpage
%%Trailer 
%End-of-file
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/parray.red0000644000175000017500000000333511526203062023460 0ustar  giovannigiovannimodule parray; % multidimensional arrays.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure mk!-p!-array3(nx,ny,nz);
  <>
       where w=mkvect(nx#+1);

symbolic procedure mk!-p!-array2(ny,nz);
  <>
       where w=mkvect(ny#+1);

symbolic procedure p!-get3(v,i,j,k);
  igetv(igetv(igetv(v,i),j),k);

symbolic procedure p!-put3(v,i,j,k,w);
  iputv(igetv(igetv(v,i),j),k,w);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/turtle.tex0000644000175000017500000004457711526203062023544 0ustar  giovannigiovanni\documentstyle[11pt,epsfig]{article}
\title{{\bf Turtle Graphics Interface for REDUCE \\
            Version 3}}
\author{Caroline Cotter \\ Konrad--Zuse--Zentrum f\"ur Informationstechnik
        Berlin \\ E--mail: cotter@zib.de}
\date{October 1998}
\newcommand{\syntax}{\textsl{SYNTAX: }}
\newcommand{\abb}{\textsl{Abbreviated form: }}

\begin{document}

\maketitle


\section{Introduction}
 This program is a simple implementation of the ``Turtle Graphics''
style of drawing graphs in {\small REDUCE}. The background and ideas of
``Turtle Graphics'' are outlined below.

\subsection{Turtle Graphics}

 Turtle Graphics was originally developed in the 1960's as part of the
LOGO system, and used in the classroom as an introduction to graphics
and using computers to help with mathematics.

The LOGO language was created as part of an experiment to test the idea
that programming may be used as an educational discipline to teach children.
It was first intended to be used for problem solving, for illustrating
mathematical concepts usually difficult to grasp, and for creation of
experiments with abstract ideas.

At first LOGO had no graphics capabilities, but fast development enabled
the incorporation of graphics, known as ``Turtle Graphics'' into the
language. ``Turtle Graphics'' is regarded by many as the main use of
LOGO.


{\bf Main Idea:}\ \ To use simple commands directing a turtle, such as
forward, back, turnleft, in order to construct pictures as opposed to
drawing lines connecting cartesian coordinate points.

The `turtle' is at all times determined by its state \{$x$,$y$,$a$,$p$\}-
where $x$,$y$ determine its position in the {\mbox (x,y)-plane}, $a$
determines the angle (which describes the direction the turtle is
facing) and $p$ signals whether the pen is up or down (i.\ e.\ \  whether or
not it is drawing on the paper).


\section{Implementation}
Some alterations to the original ``Turtle Graphics'' commands have been
made in this implementation due to the design of the graphics package
{\em gnuplot} used in {\small REDUCE}.

\begin{itemize}
 \item It is not possible to draw lines individually and to see each
        seperate line as it is added to the graph since gnuplot
        automatically replaces the last graph each time it calls on
        the plot function.

       Thus the whole sequence of commands must be input together if
        the complete picture is to be seen.
 \item This implementation does not make use of the standard turtle
        commands `pen-up' or `pen-down' . Instead, `set' commands are
        included which allow the turtle to move without drawing a line.
 \item No facility is provided here to change the pen-colour, but gnuplot
        does have the capability to handle a few different colours (which
        could be included later).
 \item Many of the commands are long and difficult to type out repeatedly,
        therefore all the commands included under {\em `Turtle Functions'}
        (below) are listed alongside an equivalent abbreviated form.
 \item The user has no control over the range of output that can be seen
        on the screen since the gnuplot program automatically adjusts the
        picture to fit the window. Hence the size of each specified `step'
        the turtle takes in any direction is not a fixed unit of length,
        rather it is relative to the scale chosen by gnuplot.
\end{itemize}


\section{Turtle Functions}
 As previously mentioned, the turtle is determined at all times by its
state \{$x$,$y$,$a$\}: its position on the \mbox{(x,y)-plane} and its
angle($a$) - its {\em heading} - which determines the direction the
turtle is facing, in degrees, relative anticlockwise to the positive
x-axis.     
       
\subsection{User Setting Functions}
\begin{description}
 \item[setheading] Takes a number as its argument and resets the heading
       to this number. If the number entered is negative or greater than
       or equal to 360 then it is automatically checked to lie between 0
       and 360.

       Returns the turtle position \{$x$,$y$\}

       \syntax\ {\tt setheading($\theta$)}

       \abb\ {\tt sh($\theta$)}
 \item[leftturn]  The turtle is turned anticlockwise through the
       stated number of degrees. Takes a number as its argument and
       resets the heading by adding this number to the previous heading
       setting.

       Returns the turtle position \{$x$,$y$\}

       \syntax\ {\tt leftturn($\alpha$)}

       \abb\ {\tt slt($\alpha$)}
 \item[rightturn] Similar to {\tt leftturn}, but the turtle is turned
       clockwise through the stated number of degrees. Takes a number as
       its argument and resets the heading by subtracting this number from
       the previous heading setting.

       Returns the turtle position \{$x$,$y$\}

       \syntax\ {\tt rightturn($\beta$)}

       \abb\ {\tt srt($\beta$)}
 \item[setx] Relocates the turtle in the x direction. Takes a number as
       its argument and repositions the state of the turtle by changing its
       x-coordinate.

       Returns \{\}

       \syntax\ {\tt setx($x$)}

       \abb\ {\tt sx($x$)}
 \item[sety] Relocates the turtle in the y direction. Takes a number as   
       its argument and repositions the state of the turtle by changing its
       y-coordinate.

       Returns \{\}

       \syntax\ {\tt sety($y$)}

       \abb\ {\tt sy($y$)}
 \item[setposition] Relocates the turtle from its current position to the 
       new cartesian coordinate position described. Takes a pair of
       numbers as its arguments and repositions the state of the turtle by 
       changing the x and y coordinates.

       Returns \{\}

       \syntax\ {\tt setposition($x$,$y$)}

       \abb\ {\tt spn($x$,$y$)}
 \item[setheadingtowards] Resets the heading so that the turtle is facing
       towards the given point, with respect to its current position on
       the coordinate axes. Takes a pair of numbers as its arguments and
       changes the heading, but the turtle stays in the same place.

       Returns the turtle position \{$x$,$y$\}

       \syntax\ {\tt setheadingtowards($x$,$y$)}

       \abb\ {\tt shto($x$,$y$)}
 \item[setforward] Relocates the turtle from its current position by
       moving forward (in the direction of its heading) the number of
       steps given. Takes a number as its argument and repositions the
       state of the turtle by changing the x and y coordinates.

       Returns \{\}

       \syntax\ {\tt setforward($n$)}

       \abb\ {\tt sfwd($n$)}
 \item[setback] As with {\tt setforward}, but moves back (in the opposite
       direction of its heading) the number of steps given.

       Returns \{\}

       \syntax\ {\tt setback($n$)}

       \abb\ {\tt sbk($n$)}
\end{description}

\subsection{Line-Drawing Functions}
\begin{description}
 \item[forward] Moves the turtle forward (in the direction its heading)
       the number of steps given. Takes a number as its argument and draws
       a line from its current position to a new position on the
       coordinate plane. The x and y coordinates are reset to the new
       values.

       Returns the list of points  
    \{ \{{\it old} $x$,{\it old} $y$\}, \{{\it new} $x$,{\it new} $y$\} \}

       \syntax\ {\tt forward($s$)}
 
       \abb\ {\tt fwd($s$)}
 \item[back] As with {\tt forward} except the turtle moves back (in the
       opposite direction to its heading) the number of steps given.

       Returns the list of points
    \{ \{{\it old} $x$,{\it old} $y$\}, \{{\it new} $x$,{\it new} $y$\} \}

       \syntax\ {\tt back($s$)}

       \abb\ {\tt bk($s$)}
 \item[move] Moves the turtle to a specified point on the coordinate
       plane. Takes a pair of numbers as its arguments and draws a line
       from its current position to the position described. The x and y
       coordinates are set to these new values.

       Returns the list of points 
    \{ \{{\it old} $x$,{\it old} $y$\}, \{{\it new} $x$,{\it new} $y$\} \}

       \syntax\ {\tt move($x$,$y$)}

       \abb\ {\tt mv($x$,$y$)}
\end{description}

\subsection{Plotting Functions}
\begin{description}
 \item[draw] This is the function the user calls within {\small REDUCE} to
       draw the list of turtle commands given into a picture. Takes a list
       as its argument, with each seperate command being seperated by a
       comma, and returns the graph drawn by following the commands.

       \syntax\ {\tt draw\{}{\it command(command\_args)}{\tt ,\ldots,}      
                              {\it command(command\_args)}{\tt \}}
       \underline{Note:} all commands may be entered in either long or
                         shorthand form, and with a space
                         before the arguments instead of parentheses only
                         if just one argument is needed. Commands taking
                         more than one argument must be written in
                         parentheses and arguments seperated by a comma.
 \item[fdraw] This function is also called in {\small REDUCE} by the user 
       and outputs the same as the {\tt draw} command, but it takes a
       filename as its argument. The file which is called upon by {\tt
       fdraw} must contain only the turtle commands and other functions
       defined by the user for turtle graphics. (This is intended to make
       it easier for the user to make small changes without constantly
       typing out long series of commands.)

       \syntax\ {\tt fdraw\{"}{\it filename}{\tt "\}}
       \underline{Note:} commands may be entered in long or shorthand form
                         but each command must be written on a separate
                         line of the file. Also, arguments are to be
                         written without parentheses and separated with a
                         space, not a comma, regardless of the number of
                         arguments given to the function.
\end{description}

\subsection{Other Important Functions}
\begin{description}
 \item[info] This function is called on its own in {\small REDUCE} to tell
       user the current state of the turtle. Takes no arguments but
       returns a list containing the current values of the x and y
       coordinates and the heading variable.

       Returns the list \{{\it x\_coord},{\it y\_coord},{\it heading}\}

       \syntax\ {\tt info()} or simply {\tt info}
 \item[clearscreen] This is also called on its own in {\small REDUCE} to
       get rid of the last gnuplot window, displaying the last turtle
       graphics picture, and to reset all the variables to 0. Takes no
       arguments and returns no printed output to the screen but the
       graphics window is simply cleared.

       \syntax\ {\tt clearscreen()} or simply {\tt clearscreen}

       \abb\ {\tt cls()} or {\tt cls}
 \item[home] This is a command which can be called within a plot function
       as well as outside of one. Takes no arguments, and simply resets
       the x and y coordinates and the heading variable to 0. When used in 
       a series of turtle commands, it moves the turtle from its current
       position to the origin and sets the direction of the turtle along
       the x-axis, without drawing a line.

       Returns \{0,0\}

       \syntax\ {\tt home()} or simply {\tt home}
\end{description}

\subsection{Defining Functions}

  It is possible to use conditional statements (if \ldots\ then \ldots\
else \ldots) and `for' statements (for i:=\ldots collect\{\ldots\}) in
calls to draw. However, care must be taken - when using conditional
statements the final else statement must return a point or at least
\{x\_coord,y\_coord\} if the picture is to be continued at that point.
Also, `for' statements {\em must} include `collect' followed by a list of
turtle commands (in addition, the variable must begin counting from 0 if
it is to be joined to the previous list of turtle commands at that point
exactly, e.\ g.\ \ for i:=0:10 collect \{\ldots\}).


\syntax\ \{\small {(For user-defined Turtle functions)}\} 
\begin{tabbing}
\ \ \= set \ \ \ \=tabs\=                                       \kill
 \> {\tt procedure {\it func\_name(func\_args)};}                  \\
 \> {\tt begin [scalar {\it additional variables}];}               \\   
 \> \> \vdots                                                      \\
 \> \> {\it (the procedure body containing some turtle commands)}  \\
 \> \> \vdots                                                      \\ 
 \> \> {\tt return} {\it (a list, or label to a list, of turtle commands}\\
 \> \>            \>{\it as accepted by {\tt draw})}\\
 \> {\tt end;} \\
\end{tabbing}

  For convenience, it is recommended that all user defined functions, such
as those involving {\tt if\ldots then\ldots else\ldots} or {\tt for
i:=\ldots collect\{\ldots\}} are defined together in a separate file, then
called into {\small REDUCE} using the {\tt in "{\it filename}"} command.

\newpage

\section{Examples}

The following examples are taken from the tur.tst file. 
Examples 1,2,5 \& 6 are simple calls to draw. Examples 3 \& 4 show how 
more complicated commands can be built (which can take their own set of
arguments) using procedures. Examples 7 \& 8 show the difference between
the draw and fdraw commands.

\begin{verbatim}
% (1) Draw 36 rays of length 100

draw {for i:=1:36 collect{setheading(i*10), forward 100, back 100} };
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put (0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg1.ps}}}}
\end{picture}

\begin{verbatim}
% (2) Draw 12 regular polygons with 12 sides of length 40,each polygon
%forming an angle of 360/n degrees with the previous one. 

draw {for i:=1:12 collect
          {leftturn(30), for j:=1:12 collect
                             {forward 40, leftturn(30)}} };
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put (0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg4.ps}}}}
\end{picture}

\begin{verbatim}
% (3) A "peak" pattern - an example of a recursive procedure.

procedure peak(r);
begin;
  return for i:=0:r collect
             {move(x_coord+5,y_coord-10), move(x_coord+10,y_coord+60),
              move(x_coord+10,y_coord-60),move(x_coord+5,y_coord+10)};
end;

draw {home(), peak(3)};
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put (0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg5a.ps}}}}
\end{picture}  

\begin{verbatim}
%This procedure can then be part of a longer chain of commands:

draw {home(), move(5,50), peak(3), move(x_coord+10,-100),
      peak(2), move(x_coord+10,0)};
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put (0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg5b.ps}}}}
\end{picture}  

\begin{verbatim}
% (4)  Write a recursive procedure which draws "trees" such that every
%branch is half the length of the previous branch.

procedure tree(a,b);         %Here: a is the start length, b is the
                             %number of levels
begin;
  return if fixpb and b>0           %checking b is a positive integer

            then {leftturn(45), forward a, tree(a/2,b-1),
                  back a, rightturn(90), forward a, tree(a/2,b-1),
                  back a, leftturn(45)}
         else {x_coord,y_coord};    %default: Turtle stays still
end;

draw {home(), tree(130,7)};
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put(0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg6a.ps}}}}
\end{picture}  

\begin{verbatim}
% (5)  A 36-point star.

draw {home(), for i:=1:36 collect
                  {leftturn(10), forward 100, leftturn(10), back 100} };
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put(0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg7.ps}}}}
\end{picture}  

\begin{verbatim}
% (6) Draw 100 equilateral triangles with the leading points
%equally spaced on a circular path.

draw {home(), for i:=1:100 collect
                  {forward 150, rightturn(60), back(150),
                   rightturn(60), forward 150, setheading(i*3.6)} };
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put(0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg8.ps}}}}
\end{picture}  

\begin{verbatim}
% (7) Two or more graphs can be drawn together (this is easier
%if the graphs are named). Here we show graphs 2 and 6 on top of one
%another:

gr2:={home(), for i:=1:12 collect
                  {leftturn(30), for j:=1:12 collect
                                     {forward 40, leftturn(30)}} }$

gr6:={home(), for i:=1:100 collect
                  {forward 150, rightturn(60), back(150),
                   rightturn(60), forward 150, setheading(i*3.6)} }$

draw {gr2, gr6};
\end{verbatim}

\unitlength=1cm
\begin{picture}(8,8)(0,0)
\put(0,8){\rotatebox{270}{\resizebox{8cm}{8cm}{\epsfbox{eg9.ps}}}}
\end{picture}  

\begin{verbatim}
% (8) Example 7 could have been tackled another way, which makes use of 
%the fdraw command.
%By inputting gr2 and gr6 as procedures into reduce, they can then be 
%used at any time in the same reduce session in a call to draw and even
%fdraw.

%First save the procedures in a file, say fxp (fdraw example procedures):

procedure gr2;
begin;
  return {home, for i:=1:12 collect
                    {leftturn(30), for j:=1:12 collect
                                       {forward 40, leftturn(30)}} };
end;

procedure gr6;
begin;
  return {home(), for i:=1:100 collect
                  {forward 150, rightturn(60), back(150),
                   rightturn(60), forward 150, setheading(i*3.6)} };
end;

%Then create another file where the functions may be called to fdraw,
%e.g. fx:

gr2
gr6

%Now in reduce, after loading the turtle package just type the following:

in "fxp";
fdraw '"fx";

%..and the graphs will appear.

%This method is useful if the user wants to define many of their own
%functions, and, using fdraw, subtle changes can be made quickly without 
%having to type out the whole string of commands to plot each time. It 
%is particularly useful if there are several pictures to plot at once and 
%it is an easy way to build pictures so that the difference an extra 
%command makes to the overall picture can be clearly seen.
%(In the above example, the file called to fdraw was only 2 lines long,
%so this method did not have any advantage over the normal draw command. 
%However, when the list of commands is longer it is clearly advantageous 
%to use fdraw)


\end{verbatim}


\section{References}

\begin{enumerate}
 \item {\bf An Implementation of Turtle Graphics for Teaching Purposes}\\
         Zoran I. Putnik \& Zoram d.Budimac

 \item {\bf Mapletech -} Maple in Mathematics and the Sciences,\\ 
        Special Issue 1994\\
       {\bf An Implementation of ``Turtle Graphics'' in Maple V}\\
         Eugenio Roanes Lozano \&  Eugenio Roanes Macias

\end{enumerate}

\end{document}


mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/plotimp3.red0000644000175000017500000000743211526203062023733 0ustar  giovannigiovannimodule plotimp3; % Implicit plot: compute the varity {x,y,z|f(x,y,z)=0}.

% Author: Herbert Melenk, ZIB Berlin.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% data structure: cubes.

symbolic procedure ploteval3impl(x,y,z);
  begin scalar rx,ry,rz,f,fcn;
     rx:=plotrange(x,
      reval(plot_xrange or '(!*interval!* -10 10)));
     ry:=plotrange(y,
      reval(plot_yrange or '(!*interval!* -10 10)));
     rz:=plotrange(z,
      reval(plot_zrange or '(!*interval!* -10 10)));
     fcn := car reverse plotfunctions!*;
     f:= ploteval3impl1(cdar plotfunctions!*,
         x,car rx,cadr rx,
         y,car ry,cadr ry,
         z,car rz,cadr rz);
     plotdriver(plot!-3exp!-reg,x,y,z,f);
  end;

symbolic procedure ploteval3impl1(f,x,xlo,xhi,y,ylo,yhi,z,zlo,zhi);
   begin scalar u,dx,dy,dz,xx,yy,zz,l,ff,pts,val,w,q,qq,pt,found,done;
        integer nx,ny,nz;
     ff := rdwrap f;
     xlo:=rdwrap xlo; xhi:=rdwrap xhi;
     ylo:=rdwrap ylo; yhi:=rdwrap yhi;
     dx:=float(xhi-xlo)/float(nx:=plot!-points(x));
     dy:=float(yhi-ylo)/float(ny:=plot!-points(y));
     dz:=float(zhi-zlo)/float(nz:=plot!-points(z));
     pts := mk!-p!-array3(nx,ny,nz);
     val:= mk!-p!-array3(nx,ny,nz);

        % Step 1: compute a complete grid in 3d.
     for i:=0:nx do
     <<
       xx:=(xlo+i*dx);
       for j:=0:ny do
       <<
        yy:=(ylo+j*dy);
        for k:=0:nz do
        <<
          zz:=(zlo+k*dz);
          p!-put3(pts,i,j,k,{xx,yy,zz});
          u:=plotevalform(ff,f,{x . xx,y . yy,z . zz});
          if eqcar(u,'overflow) then u:=1.0;
          p!-put3(val,i,j,k,u);
        >>;
       >>
     >>;

        % Step 2: extract zero points.
   done := t;
   while done do
   <>;
        {t,t,car pt,cadr pt,found}
       >>;
     if done then l:=w.l;
    >>;
    return ploteval3xy3 l;
   end;

symbolic procedure ploteval3impl3(p1,f1,p2,f2);
  % linear interpolation
  <<
    fdeclare(f1,f2,p1,p2);
    (f1*p2 - f2*p1)/(f1-f2)>>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/plot/plotsynt.red0000644000175000017500000002173511526203062024062 0ustar  giovannigiovannimodule plotsynt; % Support for the syntax of the plot command.

% Author: Herbert Melenk.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(bye!-actions!*);

% Create .. as the infix operator if not yet done.

!*msg := nil;  % prevent message  ".. redefined" during load

newtok '( (!. !.) !*interval!*);

if not(gettype '!*interval!* = 'operator) then
<<
   precedence .., or;
   algebraic operator ..;
   put('!*interval!*,'PRTCH,'! !.!.! );
>>;

mkop 'point;

!*msg := t;

fluid '(plot!-points!* plot!-refine!* plot!-contour!*);

global '(plot_xrange plot_yrange plot_zrange);
share plot_xmesh,plot_ymesh,plot_xrange,plot_yrange,plot_zrange;

fluid '(plotprecision!*);

plotprecision!* := 0.9995;

fluid '(!*show_grid test_plot);

switch show_grid;
switch test_plot; % for test printouts

if null plotmax!* then
<<
   load!-package 'arith;
   if not !!plumax then roundconstants();
   plotmax!* := !!plumax;     % IEEE double precision
>>;

plotmin!*:= 1.0/plotmax!*;


fluid '(plotranges!* plotfunctions!*  plotstyle!* !*plotoverflow
        !*roundbf);

put('plot,'psopfn,'ploteval);

symbolic procedure ploteval u;
  begin scalar m,!*exp;
    if null plotdriver!* then
      rederr "no active device driver for PLOT";
    m:=plotrounded(nil);
    plot!-points!* := {20};
    plot!-refine!* := 8;
    !*plotoverflow := nil;
    plotranges!* := plotfunctions!* := nil;
    plotstyle!* := 'lines;
    bye!-actions!* := union('((plotreset)),bye!-actions!*);
    plotdriver(init);
    for each option in u do ploteval1 plot!-reval option;
    errorset('(ploteval2),t,nil);
    plotrounded(m);
  end;

symbolic procedure plot!-reval u;
 % Protected call reval: simplify u, but don't call any
 % algebraic procedure.
   begin scalar w;
     w:={nil};
     u:=plot!-reval1(u,w);
     return car w and u or reval u;
   end;

symbolic procedure plot!-reval1(u,w);
  if idp u then reval u else
  if atom u or eqcar(u,'!:dn!:) or get(car u,'dname) then u else   %WN
  if eq (car u,'!*sq) then plot!-reval1(reval u,w) else
     <> else
   << if flagp(car u,'opfn) then car w:=t;
    car u . for each q in cdr u collect plot!-reval1(q,w) >> >>;

symbolic procedure ploteval1 option;
   begin scalar x,do;
     do := get(plotdriver!*,'do);
     if pairp option and (x:=get(car option,do))
             then apply(x,list option) else
     if pairp option and (x:=get(car option,'plot!-do))
             then apply(x,list option) else
     if eqcar(option,'equal) and (x:=get(cadr option,do))
             then apply(x,list caddr option) else
     if eqcar(option,'equal) and (x:=get(cadr option,'plot!-do))
             then apply(x,list caddr option)
       else ploteval0 option;
   end;

symbolic procedure ploteval0 option;
  begin scalar l,r,opt,w;
    opt:=get(plotdriver!*,'option);
    if flagp(option,opt) then
      <>;
    if eqcar(option,'list) then
      <
%               prints up to and including that character, which
%               should be a blank.
    if indblanks=0 and initialblanks>3 and flg='more then <<
        initialblanks:=initialblanks - 3;
        lmar:=lmar - 3;
        return 'moved!-left >>;
fblank:
    if bn=0 then <<
% No blank found - can do no more for now.
% If flg='more I am in trouble and so have to print
% a continuation mark. in the other cases I can just exit.
        if not(flg = 'more) then return 'empty;
        if atom car buffero then
% continuation mark not needed if last char printed was
% special (e.g. lpar or rpar).
            prin2 "%+"; %continuation marker.
        terpri();
        lmar:=0;
        return 'continued >>
    else <<
        spaces initialblanks;
        initialblanks:=0 >>;
    buffero:=cdr buffero;
    bn:=bn - 1;
    lmar:=lmar+1;
    c:=car buffero;
    if atom c then << prin2 c; go to fblank >>
    else if blankp c then if not atom blankstoskip then <<
        prin2 '! ;
        indblanks:=indblanks - 1;
% blankstoskip = (stack-frame . skip-count).
        if c eq car blankstoskip then <<
            rplacd(blankstoskip,cdr blankstoskip - 1);
            if cdr blankstoskip=0 then blankstoskip:=t >>;
        go to fblank >>
      else go to blankfound
    else if car c='lpar or car c='lsquare then <<
        prin2 get(car c,'ppchar);
        if flg='none then go to fblank;
% now I want to flag this level for indentation.
        c:=cdr c; %the stack frame.
        if not null blanklist c then go to fblank;
        if depth c>indentlevel then << %new indentation.
% this level has not emitted any blanks yet.
            indentlevel:=depth c;
            setindenting(c,'indent) >>;
        go to fblank >>
    else if car c='rpar or car c='rsquare then <<
        if cdr c>
    else error(0,list(c,"UNKNOWN TAG IN OVERFLOW"));
blankfound:
    if eqcar(blanklist c,buffero) then
        setblanklist(c,nil);
% at least one entry on blanklist ought to be valid, so if I
% print the last blank I must kill blanklist totally.
    indblanks:=indblanks - 1;
% check if next level represents new indentation.
    if depth c>indentlevel then <<
        if flg='none then << %just print an ordinary blank.
            prin2 '! ;
            go to fblank >>;
% here I increase the indentation level by one.
        if blankstoskip then blankstoskip:=nil
        else <<
            indentlevel:=depth c;
            setindenting(c,'indent) >> >>;
%otherwise I was indenting at that level anyway.
    if blankcount c>(thin!* - 1) then << %long thin list fix-up here.
        blankstoskip:=c . ((blankcount c) - 2);
        setindenting(c,'thin);
        setblankcount(c,1);
        indentlevel:=(depth c) - 1;
        prin2 '! ;
        go to fblank >>;
    setblankcount(c,(blankcount c) - 1);
    terpri();
    lmar:=initialblanks:=depth c;
    if buffero eq flg then return 'to!-flg;
    if blankstoskip or not (flg='more) then go to fblank;
% keep going unless call was of type 'more'.
    return 'more; %try some more.
  end;

put('lpar,'ppchar,'!();
put('lsquare,'ppchar,'![);
put('rpar,'ppchar,'!));
put('rsquare,'ppchar,'!]);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rprint/rprint.red0000644000175000017500000005767211526203062024055 0ustar  giovannigiovannimodule rprint;  % The Standard LISP to REDUCE pretty-printer.

% Author: Anthony C. Hearn.
% Modifications by: Francis J. Wright.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(rprint),'(util));

fluid '(!*lower !*n buffp combuff!* curmark curpos orig pretop
        pretoprinf rmar rprifn!* rterfn!*);

comment RPRIFN!* allows output from RPRINT to be handled differently,
        RTERFN!* allows end of lines to be handled differently;

pretop := 'op; pretoprinf := 'oprinf;

symbolic procedure rprint u;
   begin integer !*n; scalar buff,buffp,curmark,rmar,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      rmar := linelength nil;
      x := get('!*semicol!*,pretop);
      !*n := 0;
      mprino1(u,list(caar x,cadar x));
      prin2ox ";";
      omarko curmark;
      prinos buff
   end;

symbolic procedure rprin1 u;
   begin scalar buff,buffp,curmark,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      x := get('!*semicol!*,pretop);
      mprino1(u,list(caar x,cadar x));
      omarko curmark;
      prinos buff
   end;

symbolic procedure mprino u; mprino1(u,list(0,0));

symbolic procedure mprino1(u,v);
   begin scalar x;
        if x := atsoc(u,combuff!*)
          then <>;
      if numberp u and u<0 and (x := get('difference,pretop))
        then return begin scalar p;
        x := car x;
        p := not(car x>cadr v) or not(cadr x>car v);
        if p then prin2ox "(";
        prinox u;
        if p then prinox ")"
       end
       else if atom u then return prinox u
      else if not atom car u and (x:=strangeop u)
          then return mprino1(x,v)
      else if not atom car u
           then <>
       else if x := get(car u,pretoprinf)
        then return begin scalar p;
           p := car v>0
                 and not(car u memq
                           '(list procedure prog quote rblock string));
           if p then prin2ox "(";
           apply1(x,cdr u);
           if p then prin2ox ")"
         end
       else if x := get(car u,pretop)
        then return if car x then inprinox(u,car x,v)
% Next line commented out since not all user infix operators are binary.
%                    else if cddr u then rederr "Syntax error"
                     else if null cadr x then inprinox(u,list(100,1),v)
                     else inprinox(u,list(100,cadr x),v)
       else if flagp(car u,'modefn) and eqcar(cadr u,'procedure)
        then return proceox(cadadr u . car u . cdr cddadr u)
       else prinox car u;
      if rlistatp car u then return rlpri cdr u;
      u := cdr u;
      if null u then prin2ox "()"
      else mprargs(u,v)
   end;

symbolic procedure strangeop u;
  % U is a non-atomic operator; try to find a better print form for it.
  % The commented definition doesn't check the complexity of the
  % argument, and so can lead to more computation.
% if caar u='lambda and length cadar u=1 then
%   subst(cadr u,car cadar u,car cddar u);
   nil;

symbolic procedure mprargs(u,v);
   if null cdr u then <>
   else inprinox('!*comma!* . u,list(0,0),v);

symbolic procedure inprinox(u,x,v);
   begin scalar p;
      p := not(car x>cadr v) or not(cadr x>car v);
      if p then prin2ox "("; omark '(m u);
      inprino(car u,x,cdr u);
      if p then prin2ox ")"; omark '(m d)
   end;

symbolic procedure inprino(opr,v,l);
   begin scalar flg,x;
      curmark := curmark+2;
      x := get(opr,pretop);
      if x and car x
        then <>;
      while l do
        <>
           else if opr eq 'setq
            then <>
               else <>
                     where y = flagp(opr,'spaced))
   get(opr,'prtch);

flag('(cons),'spaced);

flag('(add mult over to),'spaced);  % So that we don't have 1./1 etc.

symbolic procedure prin2ox u;
   <>;

symbolic procedure explodex u;
   % "Explodes" atom U without including escape characters.
   if numberp u then explode u
    else if stringp u then reversip cdr reversip cdr explode u
    else explodex1 explode u;

symbolic procedure explodex1 u;
   if null u then nil
    else if car u eq '!! then cadr u . explodex1 cddr u
    else check!-downcase car u . explodex1 cdr u;

symbolic procedure explodey u;
   begin scalar v;
      v := explode u;
      if idp u then v := for each x in v collect check!-downcase x;
      return v
   end;

symbolic procedure check!-downcase u;
   begin scalar z;
      return if liter u
                and (z := atsoc(u,
                     '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e)
                       (!F . !f) (!G . !g) (!H . !h) (!I . !i) (!J . !j)
                       (!K . !k) (!L . !l) (!M . !m) (!N . !n) (!O . !o)
                       (!P . !p) (!Q . !q) (!R . !r) (!S . !s) (!T . !t)
                       (!U . !u) (!V . !v) (!W . !w) (!X . !x) (!Y . !y)
                       (!Z . !z))))
               then cdr z
              else u
   end;

symbolic procedure prinox u;
   <>
    where x = get(u,'oldnam);

symbolic procedure omark u;
   <>;

symbolic procedure omarko u; omark list(u,0);

symbolic procedure comprox u;
   begin scalar x;
        if car buffp = '(0 0)
          then return <>;
        x := car buffp;
        rplaca(buffp,list(curmark+1,3));
        for each j in u do prin2ox j;
        omark x
   end;

symbolic procedure rlistatp u;
   get(u,'stat) member '(endstat rlis);

symbolic procedure rlpri u;
   if null u then nil
    else begin
      prin2ox " ";
      omark '(m u);
      inprino('!*comma!*,list(0,0),u);
      omark '(m d)
   end;

symbolic procedure condox u;
   begin scalar x;
      omark '(m u);
      curmark := curmark+2;
      while u do
        <>;
          mprino cadar u;
          if x then prin2ox ")";
          u := cdr u;
          if u then <>;
          if u and null cdr u and caar u eq 't
            then <>>>;
      curmark := curmark - 2;
      omark '(m d)
   end;

put('cond,pretoprinf,'condox);

symbolic procedure ifox u;
  begin
% Common Lisp stype IF.
    scalar p, a, b;
    p := car u;
    u := cdr u;
    if u then << a := car u; u := cdr u >>;
    if u then << b := car u; u := cdr u >>;
    condox list(list(p, a), list(t, b))
  end;

put('if,pretoprinf,'ifox);

symbolic procedure blockox u;
   begin
      omark '(m u);
      curmark := curmark+2;
      prin2ox "begin ";
      if car u then varprx car u;
      u := labchk cdr u;
      omark list(curmark,if eqcar(car u,'!*label) then 1 else 3);
      while u do
        <>;
      omark list(curmark - 1,-1);
      prin2ox " end";
      curmark := curmark - 2;
      omark '(m d)
   end;

symbolic procedure retox u;
   begin
      omark '(m u);
      curmark := curmark+2;
      prin2ox "return ";
      omark '(m u);
      mprino car u;
      curmark := curmark - 2;
      omark '(m d);
      omark '(m d)
   end;

put('return,pretoprinf,'retox);

symbolic procedure varprx u;
   begin scalar typ;
       while u do
        <>
           else <>;
                prinox (typ := cdar u);
                  prin2ox " "; omark '(m u); prinox caar u>>;
           u := cdr u>>;
      prin2ox "; ";
      omark '(m d)
   end;

put('rblock,pretoprinf,'blockox);

symbolic procedure progox u;
%  The reverse in the following seems wrong.
%  blockox((for each j in reverse car u collect j . 'scalar) . cdr u);
   blockox((for each j in car u collect j . 'scalar) . cdr u);

symbolic procedure labchk u;
   begin scalar x;
      for each z in u do if atom z
        then x := list('!*label,z) . x else x := z . x;
       return reversip x
   end;

put('prog,pretoprinf,'progox);

symbolic procedure gox u;
   <>;

put('go,pretoprinf,'gox);

symbolic procedure labox u;
   <>;

put('!*label,pretoprinf,'labox);

symbolic procedure quotoxx u;
   begin
      if stringp u then return prinox u;
      prin2ox "'";
      u := car u;
      if atom u then return prinox u;
      curmark := curmark+1;
      prin2ox "(";
      omark '(m u);
  a:  if atom u then <>
       else <>>>;
      if u then go to a;
      omark '(m d);
      prin2ox ")";
      curmark := curmark - 1
   end;

symbolic procedure quotox u;
   if stringp u then prinox u else <>;

symbolic procedure prinsox u;
   if atom u then prinox u
    else <>
                         else prin2ox " ">>>>;
           omark '(m d);
           prin2ox ")";
           curmark := curmark - 1>>;

put('quote,pretoprinf,'quotox);

symbolic procedure prognox u;
   begin
      curmark := curmark+1;
      prin2ox "<<";
      omark '(m u);
      while u do <>>>;
      omark '(m d);
      prin2ox ">>";
      curmark := curmark - 1
   end;

put('prog2,pretoprinf,'prognox);

put('progn,pretoprinf,'prognox);

symbolic procedure listox u;
   begin
      curmark := curmark+1;
      prin2ox "{";
      omark '(m u);
      while u do <>>>;
                if u then <>>>;
      omark '(m d);
      prin2ox "}";
      curmark := curmark - 1
   end;

put('list,pretoprinf,'listox);

symbolic procedure repeatox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "repeat ";
      mprino car u;
      prin2ox " until ";
      omark list(curmark,3);
      mprino cadr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('repeat,pretoprinf,'repeatox);

symbolic procedure whileox u;
   begin
      curmark := curmark+1;
     omark '(m u);
      prin2ox "while ";
      mprino car u;
      prin2ox " do ";
      omark list(curmark,3);
      mprino cadr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('while,pretoprinf,'whileox);

symbolic procedure procox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      if cadddr cdr u then <>;
      prin2ox "procedure ";
      procox1(car u,cadr u,caddr u)
   end;

symbolic procedure procox1(u,v,w);
   begin
      prinox u;
      if v then mprargs(v,list(0,0));
      prin2ox "; ";
      omark list(curmark,3);
      mprino w;
      curmark := curmark - 1;
      omark '(m d)
   end;

put('proc,pretoprinf,'procox);

symbolic procedure proceox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      if cadr u then <>;
      if not(caddr u eq 'expr) then <>;
      prin2ox "procedure ";
      proceox1(car u,cadddr u,car cddddr u)
   end;

symbolic procedure proceox1(u,v,w);
   % Prettyprint the procedure's argument list, any active annotation,
   % and its body.
   begin scalar annot;
      prinox u;
      if v
        then <>;
      prin2ox "; ";
      if annot := get(u,'active!-annotation) then
            <>;
      omark list(curmark,3);
      mprino w;
      curmark := curmark - 1;
      omark '(m d)
   end;

put('procedure,pretoprinf,'proceox);

symbolic procedure proceox0(u,v,w,x);
   proceox list(u,'symbolic,v,for each j in w collect j . 'symbolic,x);

symbolic procedure deox u;
   proceox0(car u,'expr,cadr u,caddr u);

put('de,pretoprinf,'deox);

% symbolic procedure dfox u;
%   proceox0(car u,'fexpr,cadr u,caddr u);

%put('df,pretoprinf,'dfox);  % Commented out because of confusion with
                             % differentiation.  We also want to
                             % discourage use of fexpr in REDUCE.

symbolic procedure dsox u;
   proceox0(car u,'smacro,cadr u,caddr u);

put('ds,pretoprinf,'dsox);

symbolic procedure stringox u;
   <>;

put('string,pretoprinf,'stringox);

symbolic procedure lambdox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      procox1('lambda,car u,cadr u)
   end;

put('lambda,pretoprinf,'lambdox);

symbolic procedure eachox u;
   <>;
     mprino car u>>;

put('foreach,pretoprinf,'eachox);

symbolic procedure forox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "for ";
      mprino car u;
      prin2ox " := ";
      mprino caadr u;
      if cadr cadr u neq 1
        then <>
       else prin2ox ":";
      mprino caddr cadr u;
      prin2ox " ";
      mprino caddr u;
      prin2ox " ";
      omark list(curmark,3);
      mprino cadddr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('for,pretoprinf,'forox);

symbolic procedure forallox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "for all ";
      inprino('!*comma!*,list(0,0),car u);
      if cadr u
        then <>;
      prin2ox " ";
      omark list(curmark,3);
      mprino caddr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('forall,pretoprinf,'forallox);

comment Support for printing algebraic mode code;

put('aeval!*,pretoprinf,'aevalox);

put('aeval,pretoprinf,'aevalox);

put('revalx,pretoprinf,'aevalox);       % FJW.

symbolic procedure aevalox(u);
      mprino aevalox1 car u;

symbolic procedure aevalox1 u;
  % unquote and listify.
  if eqcar(u,'quote) then cadr u else
  if eqcar(u,'list) then
    for each q in u collect aevalox1 q else u;

symbolic procedure minuspox u;
  if eqcar(car u,'difference) then
     mprino('lessp.cdar u) else mprino('lessp.car u.'(0));

put('minusp,pretoprinf,'minuspox);
put('aminusp!:,pretoprinf,'minuspox);
put('evalequal,pretoprinf,function (lambda u;mprino('equal.u)));
put('evalgreaterp,pretoprinf,function (lambda u;mprino('greaterp.u)));
put('evalgeq,pretoprinf,function (lambda u;mprino('geq.u)));
put('evallessp,pretoprinf,function (lambda u;mprino('lessp.u)));
put('evalleq,pretoprinf,function (lambda u;mprino('leq.u)));
put('evalneq,pretoprinf,function (lambda u;mprino('neq.u)));
put('!:dn!:,pretoprinf,function (lambda u;
                mprino(float car u*expt(float 10,cdr u))));
put('!:rd!:,pretoprinf,function (lambda u;
                mprino(if atom u then u else
                        float car u*expt(float 2,cdr u))));
put('plus2,pretoprinf,function(lambda u;mprino('plus.u)));


comment Declarations needed by old parser;

if null get('!*semicol!*,'op)
  then <>;

% Code for printing active comments.

symbolic procedure princom u;
   % Print an active comment.
   begin scalar w,x,y,z; integer n;
      x := explode2 u;
      % Process first line.
      while car x eq '!  do x := cdr x;
      while x and car x neq !$eol!$ do <>;
      while y and car y eq '!  do y := cdr y;
      w := reversip!* y;    % Header line.
      % Process remaining lines.
      while x and (x := cdr x) do
       <>;
         while x and car x neq !$eol!$ do <>;
         while y and car y eq '!  do y := cdr y;
         z := (n . reversip!* y) . z>>;
      % Find line with least blanks.
      y := z;
      if y
        then <>;
      while z do <>;
      % Now merge lines where possible.
      while y do
       <>)
               else bool := nil;
           x := car u . x; u := cdr u>>;
      rplacd(buffp,reversip!* x);
      while cdr buffp do buffp := cdr buffp
   end;


comment RPRINT MODULE, Part 2;

fluid '(orig curpos);

symbolic procedure prinos u;
   begin integer curpos;
        scalar !*lower,orig;
      orig := list posn();
      curpos := car orig;
      prinoy(u,0);
      terpri0x()
   end;

symbolic procedure prinoy(u,n);
   begin scalar x;
      if car(x := spaceleft(u,n)) then return prinom(u,n)
       else if null cdr x then return if car orig<10 then prinom(u,n)
       else <>
      else begin
        a: u := prinoy(u,n+1);
           if null cdr u or caar u<=n then return;
           terpri0x();
           spaces20x(curpos := car orig+cadar u);
           go to a end;
      return u
   end;

symbolic procedure spaceleft(u,mark);
   %U is an expanded buffer of characters delimited by non-atom marks
   %of the form: '(M ...) or '(INT INT))
   %MARK is an integer;
   begin integer n; scalar flg,mflg;
      n := rmar - curpos;
      u := cdr u;   %move over the first mark;
      while u and not flg and n>=0 do
        <=caar u then <>
           else mflg := t;
          u := cdr u>>;
      return ((n>=0) . mflg)
   end;

symbolic procedure prinom(u,mark);
   begin integer n; scalar flg,x;
      n := curpos;
      u := cdr u;
      while u and not flg do
        <>
          else if caar u eq 'm
           then if cadar u eq 'u then orig := n . orig
                 else if cadar u eq 'l
                  then (if chars2 cdr u > (rmar - posn())
                          then <>)
                 else orig := cdr orig
           % Check for long thin lists.
           else if mark>=caar u
              and not(x memq '(!,) % '(!, ! )
                       and rmar - n - 6>charspace(u,x,mark))
            then <>;
          u := cdr u>>;
      curpos := n;
        if mark=0 and cdr u
          then <>;
          %must be a top level constant;
      return u
   end;

symbolic procedure chars2 u; chars21(u,0);

symbolic procedure chars21(u,n);
   if eqcar(car u,'m) then n else chars21(cdr u,n+1);

symbolic procedure charspace(u,char,mark);
   % Determines if there is space until the next character CHAR.
   begin integer n;
      n := 0;
      while u do
        <0 do <>;

symbolic procedure prin2rox u;
   begin integer m,n; scalar x,y;
      m := rmar - 12;
      n := rmar - 1;
      while u do
        if car u eq '!"
          then <>
                  else nil;
                 prin20x '!";
                 u := cdr u;
                 while not(car u eq '!") do
                   <>;
                 prin20x '!";
                 u := cdr u;
                 !*n := !*n+2;
                 x := y := nil>>
         else if atom car u and not(car u eq '!  and (!*n=0 or null x
              or cdr u and breakp cadr u or breakp x and not(y eq '!!)))
          then <m and not breakp car u and nospace(u,n - !*n)
          then <> else nil>>
         else u := cdr u
   end;

symbolic procedure nospace(u,n);
   if n<1 then t
    else if null u then nil
    else if not atom car u then nospace(cdr u,n)
    else if not(car u eq '!!) and (cadr u eq '!  or breakp cadr u)
     then nil
    else nospace(cdr u,n - 1);

symbolic procedure breakp u;
   u member '(!< !> !; !: != !) !+ !- !, !' !");

symbolic procedure stringspace(u,n);
   if n<1 then nil else car u eq '!" or stringspace(cdr u,n - 1);


comment Some interfaces needed;

symbolic procedure prin20x u;
   if rprifn!* then apply1(rprifn!*,u) else prin2 u;

symbolic procedure terpri0x;
   if rterfn!* then lispeval {rterfn!*} else terpri();

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/rprint/fmprint.red0000644000175000017500000013713011526203062024202 0ustar  giovannigiovannimodule fmprint; % Fancy output package for symbolic expressions.
                % using TEX as intermediate language.

% Author: Herbert Melenk, using ideas of maprin.red (A.C.H, A.C.N).

% Modifications:
%               fancy!-mode!* commented out, since it applies only to
%               very old versions. /

% Copyright (c) 2003 Anthony C. Hearn, Konrad-Zuse-Zentrum.
%           All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%   8-Sep-94
%               introduced data driven formatting (print-format)

%  12-Apr-94
%               removed print function for dfp
%               removed some unused local variables
%               corrected output for conditional expressions and
%                 aeval/aeval* forms

%  17_Mar-94    corrected line breaks in Taylor expressions
%               rational exponents use /
%               vertical bar for SUB expressions
%               explicit * for product of two quotients (Taylor)

% switches
%
%    ON FANCY          enable algebraic output processing by this module
%
%    ON FANCY_TEX      under ON FANCY: display TEX equivalent
%

% properties used in this module:
%
%     fancy-prifn      print function for an operator
%
%     fancy-pprifn     print function for an oeprator including current
%                      operator precedence for infix printing
%
%     fancy!-flatprifn print function for objects which require
%                      special printing if prefix operator form
%                      would have been used, e.g. matrix, list
%
%     fancy-prtch      string for infix printing of an operator
%
%     fancy-special-symbol
%                      print expression for a non-indexed item
%                      string with TEX expression  "\alpha"
%                         or
%                      number referring ASCII symbol code
%
%     fancy-infix-symbol    special-symbol for infix operators
%
%     fancy-prefix-symbol   special symbol for prefix operators
%
%     fancy!-symbol!-length  the number of horizontal units needed for
%                      the symbol.  A standard character has 2 units.


%  94-Jan-26 - Output for Taylor series repaired.
%  94-Jan-17 - printing of index for Bessel function repaired.
%            - New functions for local encapsulation of printing
%              independent of smacro fancy!-level.
%            - Allow printing of upper case symbols locally
%              controlled by *fancy-lower

%  93-Dec-22 Vectors printed with square brackets.

create!-package('(fmprint),nil);

fluid  '(
         !*list
         !*nat
         !*nosplit
         !*ratpri
         !*revpri
         overflowed!*
         p!*!*
         testing!-width!*
         tablevel!*
         sumlevel!*
         outputhandler!*
         outputhandler!-stack!*
         posn!*
         obrkp!*    % outside-brackets-p
         );

global '(!*eraise charassoc!* initl!* nat!*!* spare!* ofl!*);

switch list,ratpri,revpri,nosplit;

% Global variables initialized in this section.

fluid '(
      fancy!-switch!-on!*
      fancy!-switch!-off!*
          !*fancy!-mode
          fancy!-pos!*
          fancy!-line!*
          fancy!-page!*
          fancy!-bstack!*
          !*fancy_tex
          !*fancy!-lower    % control of conversion to lower case
%         fancy!-mode!*
      );

switch fancy_tex; % output TEX equivalent.

% fancy!-mode!* := if '!6 = car reverse explode2 getenv "reduce" then 36
%                  else 35;

% fancy!-mode!* := 36;   % This needs to be more than 35.
fancy!-switch!-on!* := int2id 16$
fancy!-switch!-off!* := int2id 17$
!*fancy!-lower := t;

global '(fancy_lower_digits fancy_print_df);

share fancy_lower_digits; % T, NIL or ALL.

if null fancy_lower_digits then fancy_lower_digits:=t;

share fancy_print_df;     % PARTIAL, TOTAL, INDEXED.

if null fancy_print_df then  fancy_print_df := 'partial;
switch fancy;

put('fancy,'simpfg,
  '((t (fmp!-switch t))
    (nil (fmp!-switch nil)) ));


symbolic procedure fmp!-switch mode;
      if mode then
        <> else
          rederr "FANCY is not current output handler"
        >>;

symbolic procedure fancy!-out!-header();
    if not !*fancy_tex then prin2 fancy!-switch!-on!*;

symbolic procedure fancy!-out!-trailer();
  <>;

symbolic procedure fancy!-tex s;
  % test output: print tex string.
   <>;

symbolic procedure fancy!-out!-item(it);
  if atom it then prin2 it else
  if eqcar(it,'ascii) then writechar(cadr it) else
  if eqcar(it,'tab) then
     for i:=1:cdr it do prin2 "\>"
    else
  if eqcar(it,'bkt) then
     begin scalar m,b,l; integer n;
      m:=cadr it; b:=caddr it; n:=cadddr it;
      l := b member '( !( !{ );
   %  if m then prin2 if l then "\left" else "\right"
   % else
      if n> 0 then
      <>;
      if b member '(!{ !}) then prin2 "\";
      prin2 b;
    end
    else
      rederr "unknown print item";

symbolic procedure set!-fancymode bool;
  if bool neq !*fancy!-mode then
    <>;

symbolic procedure fancy!-output(mode,l);
  % Interface routine.
  if ofl!* or posn!*>2 or not !*nat then
     % not terminal handler or current output line non-empty.
   <>;

symbolic procedure fancy!-flush();
     << fancy!-terpri!* t;
        for each line in reverse fancy!-page!* do
        if line and not eqcar(car line,'tab) then
        <>;
        set!-fancymode nil;
      >> where !*lower=nil;

%---------------- primitives -----------------------------------

symbolic procedure fancy!-special!-symbol(u,n);
   if numberp u then
     <>
    else fancy!-prin2!*(u,n);

symbolic procedure fancy!-prin2 u;
    fancy!-prin2!*(u,nil);

symbolic procedure fancy!-prin2!*(u,n);
  if numberp u and not testing!-width!* then fancy!-prin2number u
     else
  (begin scalar str,id; integer l;
    str := stringp u; id := idp u and not digit u;
    u:= if atom u then explode2 u where !*lower=!*fancy!-lower
        else {u};
    l := if numberp n then n else 2*length u;
    if id and not numberp n then
       u:=fancy!-lower!-digits(fancy!-esc u);
    for each x in u do
    <10 and fancy!-pos!* #> ll then fancy!-terpri!*(t);
     fancy!-prin2!*(car u,2); u:=cdr u;
   >>;
  end;

symbolic procedure fancy!-esc u;
   if not('!_ memq u) then u else
   (if car u eq '!_ then '!\ . w else w)
      where w = car u . fancy!-esc cdr u;

symbolic procedure fancy!-lower!-digits u;
    (if null m then u else if m = 'all or
        fancy!-lower!-digitstrail(u,nil) then
           fancy!-lower!-digits1(u,nil)
     else u
     ) where m=fancy!-mode 'fancy_lower_digits;

symbolic procedure fancy!-lower!-digits1(u,s);
  begin scalar c,q,r,w,x;
 loop:
    if u then <> else c:=nil;
    if null s then
      if not digit c and c then w:=c.w else
      << % need to close the symbol w;
         w:=reversip w;
         q:=intern compress w;
         if stringp (x:=get(q,'fancy!-special!-symbol))
            then w:=explode2 x;
         r:=nconc(r,w);
         if digit c then <> else w:=nil;
      >>
    else
      if digit c then w:=c.w else
      << % need to close the number w.
        w:='!_ . '!{ . reversip('!} . w);
        r:=nconc(r,w);
        if c then <> else w:=nil;
      >>;
    if w then goto loop;
    return r;
  end;




symbolic procedure fancy!-lower!-digitstrail(u,s);
   if null u then s else
   if not s and digit car u then
          fancy!-lower!-digitstrail(cdr u,t) else
   if s and not digit car u then nil
   else fancy!-lower!-digitstrail(cdr u,s);

symbolic procedure fancy!-terpri!* u;
   <<
     if fancy!-line!* then
         fancy!-page!* := fancy!-line!* . fancy!-page!*;
     fancy!-pos!* :=tablevel!* #* 10;
     fancy!-line!*:= {'tab . tablevel!*};
     overflowed!* := nil
   >>;

symbolic macro procedure fancy!-level u;
 % unwind-protect for special output functions.
  {'prog,'(pos fl w),
      '(setq pos fancy!-pos!*),
      '(setq fl fancy!-line!*),
      {'setq,'w,cadr u},
      '(cond ((eq w 'failed)
              (setq fancy!-line!* fl)
              (setq fancy!-pos!* pos))),
       '(return w)};

symbolic procedure fancy!-begin();
  % collect current status of fancy output. Return as a list
  % for later recovery.
  {fancy!-pos!*,fancy!-line!*};

symbolic procedure fancy!-end(r,s);
  % terminates a fancy print sequence. Eventually resets
  % the output status from status record  if the result 
  % signals an overflow.
  <>

        else if x := get(car l,'infix) then
        << p := not(x>p);
          w:= if p then fancy!-in!-brackets(
            {'fancy!-inprint,mkquote car l,x,mkquote cdr l},
               '!(,'!))
              else
            fancy!-inprint(car l,x,cdr l);
        >>
        else if x:= get(car l,'fancy!-flatprifn) then
            w:=apply(x,{l})
        else
        <<
           w:=fancy!-prefix!-operator(car l);
           obrkp!* := nil;
           if w neq 'failed then
             w:=fancy!-print!-function!-arguments cdr l;
        >>;

        return if testing!-width!* and overflowed!*
              or w='failed then fancy!-fail(pos,fl) else nil;
    end ) where obrkp!*=obrkp!*;

symbolic procedure fancy!-convert(l,m);
  % special converters.
  if eqcar(l,'expt) and cadr l= 'e and
     ( m='infix or treesizep(l,20) )
        then {'exp,caddr l}
    else l;

symbolic procedure fancy!-print!-function!-arguments u;
  % u is a parameter list for a function.
    fancy!-in!-brackets(
       u and {'fancy!-inprint, mkquote '!*comma!*,0,mkquote u},
            '!(,'!));

symbolic procedure fancy!-maprint!-atom(l,p);
 fancy!-level
  begin scalar x;
     if(x:=get(l,'fancy!-special!-symbol))
           then fancy!-special!-symbol(x,
                get(l,'fancy!-special!-symbol!-size) or 2)
     else
     if vectorp l then
       <>
     else
     if not numberp l or (not (l<0) or p<=get('minus,'infix))
         then fancy!-prin2!*(l,'index)
     else
     fancy!-in!-brackets(
          {'fancy!-prin2!*,mkquote l,t}, '!(,'!));
     return if testing!-width!* and overflowed!* then 'failed
              else nil;
  end;

put('print_indexed,'psopfn,'(lambda(u)(flag u 'print!-indexed)));

symbolic procedure fancy!-print!-indexlist l;
   fancy!-print!-indexlist1(l,'!_,nil);

symbolic procedure fancy!-print!-indexlist1(l,op,sep);
  % print index or exponent lists, with or without separator.
 fancy!-level
  begin scalar w,testing!-width!*,obrkp!*;
    testing!-width!* :=t;
    fancy!-prin2!*(op,0);
    fancy!-prin2!*('!{,0);
    w:=fancy!-inprint(sep or 'times,0,l);
    fancy!-prin2!*("}",0);
    return w;
  end;

symbolic procedure fancy!-print!-one!-index i;
 fancy!-level
  begin scalar w,testing!-width!*,obrkp!*;
    testing!-width!* :=t;
    fancy!-prin2!*('!_,0);
    fancy!-prin2!*('!{,0);
    w:=fancy!-inprint('times,0,{i});
    fancy!-prin2!*("}",0);
    return w;
  end;

symbolic procedure fancy!-in!-brackets(u,l,r);
  % put form into brackets (round, curly,...).
  % u: form to be evaluated,
  % l,r: left and right brackets to be inserted.
  fancy!-level
   (begin scalar fp,w,r1,r2,rec;
     rec := {0};
     fancy!-bstack!* := rec . fancy!-bstack!*;
     fancy!-adjust!-bkt!-levels fancy!-bstack!*;
     fp := length fancy!-page!*;
     fancy!-prin2!* (r1:='bkt.nil.l.rec, 2);
     w := eval u;
     fancy!-prin2!* (r2:='bkt.nil.r.rec, 2);
       % no line break: use \left( .. \right) pair.
     if fp = length fancy!-page!* then
     <>;
     return w;
   end)
    where fancy!-bstack!* = fancy!-bstack!*;


symbolic procedure fancy!-adjust!-bkt!-levels u;
   if null u or null cdr u then nil
   else if caar u >= caadr u then
    <>;

symbolic procedure fancy!-exptpri(l,p);
% Prints expression in an exponent notation.
   (begin scalar !*list,pp,q,w,w1,w2,pos,fl;
      pos:=fancy!-pos!*; fl:=fancy!-line!*;
      pp := not((q:=get('expt,'infix))>p);  % Need to parenthesize
      w1 := cadr l; w2 := caddr l;
      testing!-width!* := t;
      if eqcar(w2,'quotient) and cadr w2 = 1
          and (fixp caddr w2 or liter caddr w2) then
         return fancy!-sqrtpri!*(w1,caddr w2);
      if eqcar(w2,'quotient) and eqcar(cadr w2,'minus)
          then w2 := list('minus,list(car w2,cadadr w2,caddr w2))
          else w2 := negnumberchk w2;
      if fancy!-maprint(w1,q)='failed
            then return fancy!-fail(pos,fl);
     fancy!-prin2!*("^",0);
     if eqcar(w2,'quotient) and fixp cadr w2 and fixp caddr w2 then
      <>
           else w:=fancy!-maprint!-tex!-bkt(w2,0,nil);
     if w='failed then return fancy!-fail(pos,fl) ;
    end) where !*ratpri=!*ratpri,
           testing!-width!*=testing!-width!*;

put('expt,'fancy!-pprifn,'fancy!-exptpri);

symbolic procedure fancy!-inprint(op,p,l);
  (begin scalar x,y,w, pos,fl;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
      % print product of quotients using *.
     if op = 'times and eqcar(car l,'quotient) and
       cdr l and eqcar(cadr l,'quotient) then
        op:='!*;
     if op eq 'plus and !*revpri then l := reverse l;
     if not get(op,'alt) then
     <<
        if op eq 'not then
         << fancy!-oprin op;
            return  fancy!-maprint(car l,get('not,'infix));
         >>;
        if op eq 'setq and not atom (x := car reverse l)
             and idp car x and (y := getrtype x)
             and (y := get(get(y,'tag),'fancy!-setprifn))
            then return apply2(y,car l,x);
        if not atom car l and idp caar l
              and
           ((x := get(caar l,'fancy!-prifn))
                   or (x := get(caar l,'fancy!-pprifn)))
              and (get(x,op) eq 'inbrackets)
            % to avoid mix up of indices and exponents.
          then<<
               fancy!-in!-brackets(
                {'fancy!-maprint,mkquote car l,p}, '!(,'!));
              >>
           else if !*nosplit and not testing!-width!* then
                fancy!-prinfit(car l, p, nil)
           else w:=fancy!-maprint(car l, p);
          l := cdr l
      >>;
     if testing!-width!* and (overflowed!* or w='failed)
            then return fancy!-fail(pos,fl);
     if !*list and obrkp!* and memq(op,'(plus minus)) then
        <>;
     if !*nosplit and not testing!-width!* then
          % main line:
         fancy!-inprint1(op,p,l)
     else w:=fancy!-inprint2(op,p,l);
     if testing!-width!* and w='failed then return fancy!-fail(pos,fl);
   end
   ) where tablevel!*=tablevel!*, sumlevel!*=sumlevel!*;


symbolic procedure fancy!-inprint1(op,p,l);
   % main line (top level) infix printing, allow line break;
  begin scalar lop,space;
   space := flagp(op,'spaced);
   for each v in l do
   <>;
     if space then fancy!-prin2!*("\,",1);
     fancy!-prinfit(negnumberchk v, p, nil)
   >>;
  end;

symbolic procedure fancy!-inprint2(op,p,l);
   % second line
  begin scalar lop,space,w;
   space := flagp(op,'spaced);
   for each v in l do
    if not testing!-width!* or w neq 'failed then
     <>;
   return w;
  end;

symbolic procedure fancy!-inprintlist(op,p,l);
   % inside algebraic list
fancy!-level
 begin scalar fst,w,v;
  loop:
   if null l then return w;
   v := car l; l:= cdr l;
   if fst then
       << fancy!-prin2!*("\,",1);
          w:=fancy!-oprin op;
          fancy!-prin2!*("\,",1);
       >>;
   if w eq 'failed  and testing!-width!* then return w;
   w:= if w eq 'failed then fancy!-prinfit(v,0,op)
                    else fancy!-prinfit(v,0,nil);
   if w eq 'failed  and testing!-width!* then return w;
   fst := t;
   goto loop;
  end;

put('times,'fancy!-prtch,"\,");

symbolic procedure fancy!-oprin op;
 fancy!-level
  begin scalar x;
    if (x:=get(op,'fancy!-prtch)) then fancy!-prin2!*(x,1)
      else
    if (x:=get(op,'fancy!-infix!-symbol))
           then fancy!-special!-symbol(x,get(op,'fancy!-symbol!-length)
                                            or 4)
      else
    if null(x:=get(op,'prtch)) then fancy!-prin2!*(op,t)
      else
    << if !*list and obrkp!* and op memq '(plus minus)
        and sumlevel!*=2
       then
        if testing!-width!* then return 'failed
            else fancy!-terpri!* t;
       fancy!-prin2!*(x,t);
    >>;
    if overflowed!* then return 'failed
   end;

put('alpha,'fancy!-special!-symbol,"\alpha");
put('beta,'fancy!-special!-symbol,"\beta");
put('gamma,'fancy!-special!-symbol,"\gamma");
put('delta,'fancy!-special!-symbol,"\delta");
put('epsilon,'fancy!-special!-symbol,"\epsilon");
put('zeta,'fancy!-special!-symbol,"\zeta");
put('eta,'fancy!-special!-symbol,"\eta");
put('theta,'fancy!-special!-symbol,"\theta");
put('iota,'fancy!-special!-symbol,"\iota");
put('kappa,'fancy!-special!-symbol,"\kappa");
put('lambda,'fancy!-special!-symbol,"\lambda");
put('mu,'fancy!-special!-symbol,"\mu");
put('nu,'fancy!-special!-symbol,"\nu");
put('xi,'fancy!-special!-symbol,"\xi");
put('pi,'fancy!-special!-symbol,"\pi");
put('rho,'fancy!-special!-symbol,"\rho");
put('sigma,'fancy!-special!-symbol,"\sigma");
put('tau,'fancy!-special!-symbol,"\tau");
put('upsilon,'fancy!-special!-symbol,"\upsilon");
put('phi,'fancy!-special!-symbol,"\phi");
put('chi,'fancy!-special!-symbol,"\chi");
put('psi,'fancy!-special!-symbol,"\psi");
put('omega,'fancy!-special!-symbol,"\omega");

if 'a neq '!A then deflist('(
    (!Alpha 65) (!Beta 66) (!Chi 67) (!Delta 68)
    (!Epsilon 69)(!Phi 70) (!Gamma 71)(!Eta 72)
    (!Iota 73) (!vartheta 74)(!Kappa 75)(!Lambda 76)
    (!Mu 77)(!Nu 78)(!O 79)(!Pi 80)(!Theta 81)
    (!Rho 82)(!Sigma 83)(!Tau 84)(!Upsilon 85)
    (!Omega 87) (!Xi 88)(!Psi 89)(!Zeta 90)
    (!varphi 106)
       ),'fancy!-special!-symbol);

put('infinity,'fancy!-special!-symbol,"\infty");

% some symbols form the upper ASCII part of the symbol font

put('partial!-df,'fancy!-special!-symbol,182);
put('partial!-df,'fancy!-symbol!-length,8);
put('empty!-set,'fancy!-special!-symbol,198);
put('not,'fancy!-special!-symbol,216);
put('not,'fancy!-infix!-symbol,216);

 % symbols as infix opertors
put('leq,'fancy!-infix!-symbol,163);
put('geq,'fancy!-infix!-symbol,179);
put('neq,'fancy!-infix!-symbol,185);
put('intersection,'fancy!-infix!-symbol,199);
put('union,'fancy!-infix!-symbol,200);
put('member,'fancy!-infix!-symbol,206);
put('and,'fancy!-infix!-symbol,217);
put('or,'fancy!-infix!-symbol,218);
put('when,'fancy!-infix!-symbol,239);
put('!*wcomma!*,'fancy!-infix!-symbol,",\,");

put('replaceby,'fancy!-infix!-symbol,222);
put('replaceby,'fancy!-symbol!-length,8);

 % symbols as prefix functions
% put('gamma,'fancy!-functionsymbol,71);  % big Gamma
%
put('!~,'fancy!-functionsymbol,34);     % forall
put('!~,'fancy!-symbol!-length,8);

 % arbint, arbcomplex.
put('arbcomplex,'fancy!-functionsymbol,227);
put('arbint,'fancy!-functionsymbol,226);

flag('(arbcomplex arbint),'print!-indexed);

% flag('(delta),'print!-indexed);         % Dirac delta symbol.
% David Hartley voted against..

% The following definitions allow for more natural printing of
% conditional expressions within rule lists.

symbolic procedure fancy!-condpri0 u;
   fancy!-condpri(u,0);

symbolic procedure fancy!-condpri(u,p);
 fancy!-level
  begin scalar w;
    if p>0 then fancy!-prin2 "\bigl(";
    while (u := cdr u) and w neq 'failed do
      <>;
          if w neq 'failed then w := fancy!-maprin0 cadar u;
          if cdr u then <>>>;
     if p>0 then fancy!-prin2 "\bigr)";
     if overflowed!* or w='failed then return 'failed;
   end;

put('cond,'fancy!-pprifn,'fancy!-condpri);
put('cond,'fancy!-flatprifn,'fancy!-condpri0);

symbolic procedure fancy!-revalpri u;
   fancy!-maprin0 fancy!-unquote cadr u;

symbolic procedure fancy!-unquote u;
  if eqcar(u,'list) then for each x in cdr u collect
      fancy!-unquote x
  else if eqcar(u,'quote) then cadr u else u;

put('aeval,'fancy!-prifn,'fancy!-revalpri);
put('aeval!*,'fancy!-prifn,'fancy!-revalpri);
put('reval,'fancy!-prifn,'fancy!-revalpri);
put('reval!*,'fancy!-prifn,'fancy!-revalpri);

put('aminusp!:,'fancy!-prifn,'fancy!-patpri);
put('aminusp!:,'fancy!-pat,'(lessp !&1 0));

symbolic procedure fancy!-patpri u;
  begin scalar p;
    p:=subst(fancy!-unquote  cadr u,'!&1,
             get(car u,'fancy!-pat));
    return fancy!-maprin0 p;
  end;

symbolic procedure fancy!-boolvalpri u;
   fancy!-maprin0 cadr u;

put('boolvalue!*,'fancy!-prifn,'fancy!-boolvalpri);

symbolic procedure fancy!-quotpri u;
   begin scalar n1,n2,fl,w,pos,testing!-width!*;
     if overflowed!* then return 'failed;
     testing!-width!*:=t;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     fancy!-prin2!*("\frac",0);
     w:=fancy!-maprint!-tex!-bkt(cadr u,0,t);
     n1 := fancy!-pos!*;
     if w='failed
       then return fancy!-fail(pos,fl);
     fancy!-pos!* := pos;
     w := fancy!-maprint!-tex!-bkt(caddr u,0,nil);
     n2 := fancy!-pos!*;
     if w='failed
       then return fancy!-fail(pos,fl);
     fancy!-pos!* := max(n1,n2);
     return t;
  end;

symbolic procedure fancy!-maprint!-tex!-bkt(u,p,m);
  % Produce expression with tex brackets {...} if
  % necessary. Ensure that {} unit is in same formula.
  % If m=t brackets will be inserted in any case.
  begin scalar w,pos,fl,testing!-width!*;
    testing!-width!*:=t;
    pos:=fancy!-pos!*;
    fl:=fancy!-line!*;
   if not m and (numberp u and 0<=u and u <=9 or liter u) then
   << fancy!-prin2!*(u,t);
      return if overflowed!* then fancy!-fail(pos,fl);
   >>;
   fancy!-prin2!*("{",0);
   w := fancy!-maprint(u,p);
   fancy!-prin2!*("}",0);
   if w='failed then return fancy!-fail(pos,fl);
  end;

symbolic procedure fancy!-fail(pos,fl);
 <<
     overflowed!* := nil;
     fancy!-pos!* := pos;
     fancy!-line!* := fl;
     'failed
 >>;

put('quotient,'fancy!-prifn,'fancy!-quotpri);

symbolic procedure fancy!-prinfit(u, p, op);
% Display u (as with maprint) with op in front of it, but starting
% a new line before it if there would be overflow otherwise.
   begin scalar pos,fl,w,ll,f;
     if pairp u and (f:=get(car u,'fancy!-prinfit)) then
        return apply(f,{u,p,op});
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       if w neq 'failed then w := fancy!-maprint(u,p);
     end;
     if w neq 'failed then return t;
     fancy!-line!*:=fl; fancy!-pos!*:=pos;
     if testing!-width!* and w eq 'failed then return w;

     if op='plus and eqcar(u,'minus) then <>;
       % if at least half the line is still free and the
       % object causing the overflow has been a number,
       % let it break.
     if fancy!-pos!* < (ll:=linelength(nil)) then
             if numberp u then return fancy!-prin2number u else
         if eqcar(u,'!:rd!:) then return fancy!-rdprin u;
       % generate a line break if we are not just behind an
       % opening bracket at the beginning of a line.
     if fancy!-pos!* > linelength nil #/ 2 or
          not eqcar(fancy!-last!-symbol(),'bkt) then
           fancy!-terpri!* nil;
     return fancy!-maprint(u, p);
   end;

%-----------------------------------------------------------
%
%   support for print format property
%
%-----------------------------------------------------------

symbolic procedure print_format(f,pat);
  % Assign a print pattern p to the operator form f.
put(car f, 'print!-format, (cdr f . pat) . get(car f, 'print!-format));

symbolic operator print_format;

symbolic procedure fancy!-print!-format(u,p);
 fancy!-level
  begin scalar fmt,fmtl,a;
   fmtl:=get(car u,'print!-format);
 l:
   if null fmtl then return 'failed;
   fmt := car fmtl; fmtl := cdr fmtl;
   if length(car fmt) neq length cdr u then goto l;
   a:=pair(car fmt,cdr u);
   return fancy!-print!-format1(cdr fmt,p,a);
  end;

symbolic procedure fancy!-print!-format1(u,p,a);
  begin scalar w,x,y,pl,bkt,obkt,q;
   if eqcar(u,'list) then u:= cdr u;
   while u and w neq 'failed do
   <> else
           if x eq '!) then <>;
           fancy!-prin2!*(x,1)>> else
        if x eq '!_ or x eq '!^ then <> else
        if q:=assoc(x,a) then fancy!-maprint(cdr q,p) else
        fancy!-maprint(x,p);
     if obkt then fancy!-prin2!*('!},0);
    >>;
    return w;
  end;


%-----------------------------------------------------------
%
%   some operator specific print functions
%
%-----------------------------------------------------------

symbolic procedure fancy!-prefix!-operator(u);
 % Print as function, but with a special character.
   begin scalar sy;
     sy :=
       get(u,'fancy!-functionsymbol) or get(u,'fancy!-special!-symbol);
     if sy
      then fancy!-special!-symbol(sy,get(u,'fancy!-symbol!-length) or 2)
      else fancy!-prin2!*(u,t);
   end;

put('sqrt,'fancy!-prifn,'fancy!-sqrtpri);

symbolic procedure fancy!-sqrtpri(u);
    fancy!-sqrtpri!*(cadr u,2);

symbolic procedure fancy!-sqrtpri!*(u,n);
  fancy!-level
   begin
     if not numberp n and not liter n then return 'failed;
     fancy!-prin2!*("\sqrt",0);
     if n neq 2 then
     <>;
     return fancy!-maprint!-tex!-bkt(u,0,t);
   end;


symbolic procedure fancy!-sub(l,p);
% Prints expression in an exponent notation.
  if get('expt,'infix)<=p then
      fancy!-in!-brackets({'fancy!-sub,mkquote l,0},'!(,'!))
    else
   fancy!-level
    begin scalar eqs,w;
      l:=cdr l;
      while cdr l do <>;
      l:=car l;
      testing!-width!* := t;
      w := fancy!-maprint(l,get('expt,'infix));
      if w='failed then return w;
      fancy!-prin2!*("\bigl",0);
      fancy!-prin2!*("|",1);
      fancy!-prin2!*('!_,0);
      fancy!-prin2!*("{",0);
      w:=fancy!-inprint('!*comma!*,0,eqs);
      fancy!-prin2!*("}",0);
      return w;
   end;

put('sub,'fancy!-pprifn,'fancy!-sub);


put('factorial,'fancy!-pprifn,'fancy!-factorial);

symbolic procedure fancy!-factorial(u,n);
  fancy!-level
   begin scalar w;
     w := (if atom cadr u then fancy!-maprint(cadr u,9999)
              else
           fancy!-in!-brackets({'fancy!-maprint,mkquote cadr u,0},
                               '!(,'!))
          );
     fancy!-prin2!*("!",2);
     return w;
   end;

put('binomial,'fancy!-prifn,'fancy!-binomial);

symbolic procedure fancy!-binomial(u,n);
  fancy!-level
   begin scalar w1,w2;
     fancy!-prin2!*("\left(\begin{array}{c}",2);
     w1 := fancy!-maprint(cadr u,0);
     fancy!-prin2!*("\\",0);
     w2 := fancy!-maprint(caddr u,0);
     fancy!-prin2!*("\end{array}\right)",2);
     if w1='failed or w2='failed then return 'failed;
   end;

symbolic procedure fancy!-intpri(u,p);
  if p>get('times,'infix) then
    fancy!-in!-brackets({'fancy!-intpri,mkquote u,0},'!(,'!))
   else
  fancy!-level
  begin scalar w1,w2,lo,hi,var;
     var := caddr u;
     if cdddr u then lo:=cadddr u;
     if lo and cddddr u then hi := car cddddr u;
     if fancy!-height(cadr u,1.0) > 3 then
         fancy!-prin2!*("\Int ",0)
       else
         fancy!-prin2!*("\int ",0);
     if lo then  << fancy!-prin2!*('!_,0);
                  fancy!-maprint!-tex!-bkt(lo,0,nil);
                 >>;
     if hi then << fancy!-prin2!*('!^,0);
                  fancy!-maprint!-tex!-bkt(hi,0,nil);
                 >>;
     w1:=fancy!-maprint(cadr u,0);
     fancy!-prin2!*("\,d\,",2);
     w2:=fancy!-maprint(caddr u,0);
     if w1='failed or w2='failed then return 'failed;
   end;

symbolic procedure fancy!-height(u,h);
  % estimate the height of an expression.
    if atom u then h
    else if car u = 'minus then fancy!-height(cadr u,h)
    else if car u = 'plus or car u = 'times then
      eval('max. for each w in cdr u collect fancy!-height(w,h))
    else if car u = 'expt then
         fancy!-height(cadr u,h) + fancy!-height(caddr u,h*0.8)
    else if car u = 'quotient then
         fancy!-height(cadr u,h) + fancy!-height(caddr u,h)
    else if get(car u,'simpfn) then fancy!-height(cadr u,h)
    else h;

put('int,'fancy!-pprifn,'fancy!-intpri);

symbolic procedure fancy!-sumpri!*(u,p,mode);
  if p>get('minus,'infix) then
    fancy!-in!-brackets({'fancy!-sumpri!*,mkquote u,0,mkquote mode},
                         '!(,'!))
   else
  fancy!-level
   begin scalar w,w0,w1,lo,hi,var;
     var := caddr u;
     if cdddr u then lo:=cadddr u;
     if lo and cddddr u then hi := car cddddr u;
     w:=if lo then {'equal,var,lo} else var;
     if mode = 'sum then
        fancy!-prin2!*("\sum",0) % big SIGMA
     else if mode = 'prod then
        fancy!-prin2!*("\prod",0); % big PI
     fancy!-prin2!*('!_,0);
     fancy!-prin2!*('!{,0);
     if w then w0:=fancy!-maprint(w,0);
     fancy!-prin2!*('!},0);
     if hi then <>;
     fancy!-prin2!*('!\!, ,1);
     w1:=fancy!-maprint(cadr u,0);
     if w0='failed or w1='failed then return 'failed;
   end;

symbolic procedure fancy!-sumpri(u,p); fancy!-sumpri!*(u,p,'sum);

put('sum,'fancy!-pprifn,'fancy!-sumpri);
put('infsum,'fancy!-pprifn,'fancy!-sumpri);

symbolic procedure fancy!-prodpri(u,p); fancy!-sumpri!*(u,p,'prod);

put('prod,'fancy!-pprifn,'fancy!-prodpri);

symbolic procedure fancy!-limpri(u,p);
  if p>get('minus,'infix) then
    fancy!-in!-brackets({'fancy!-limpri,mkquote u,0},'!(,'!))
   else
  fancy!-level
   begin scalar w,lo,var;
     var := caddr u;
     if cdddr u then lo:=cadddr u;
     fancy!-prin2!*("\lim",6);
     fancy!-prin2!*('!_,0);
     fancy!-prin2!*('!{,0);
     fancy!-maprint(var,0);
     fancy!-prin2!*("\to",0);
     fancy!-maprint(lo,0);
     fancy!-prin2!*('!},0);
     w:=fancy!-maprint(cadr u,0);
     return w;
   end;

put('limit,'fancy!-pprifn,'fancy!-limpri);

symbolic procedure fancy!-listpri(u);
 fancy!-level
 (if null cdr u then fancy!-maprint('empty!-set,0)
   else
  fancy!-in!-brackets(
   {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote cdr u},
               '!{,'!})
  );

put('list,'fancy!-prifn,'fancy!-listpri);
put('list,'fancy!-flatprifn,'fancy!-listpri);

put('!*sq,'fancy!-reform,'fancy!-sqreform);

symbolic procedure fancy!-sqreform u;
    prepsq!* sqhorner!* cadr u;

put('df,'fancy!-pprifn,'fancy!-dfpri);

% 9-Dec-93: 'total repaired

symbolic procedure fancy!-dfpri(u,l);
  (if flagp(cadr u,'print!-indexed) or
      pairp cadr u and flagp(caadr u,'print!-indexed)
    then fancy!-dfpriindexed(u,l)
   else if m = 'partial then fancy!-dfpri0(u,l,'partial!-df)
   else if m = 'total then fancy!-dfpri0(u,l,'!d)
   else if m = 'indexed then fancy!-dfpriindexed(u,l)
   else rederr "unknown print mode for DF")
        where m=fancy!-mode('fancy_print_df);

symbolic procedure fancy!-partialdfpri(u,l);
     fancy!-dfpri0(u,l,'partial!-df);

symbolic procedure fancy!-dfpri0(u,l,symb);
 if null cddr u then fancy!-maprin0{'times,symb,cadr u} else
 if l >= get('expt,'infix) then % brackets if exponented
  fancy!-in!-brackets({'fancy!-dfpri0,mkquote u,0,mkquote symb},
                      '!(,'!))
   else
 fancy!-level
  begin scalar x,d,q; integer n,m;
    u:=cdr u;
    q:=car u;
    u:=cdr u;
    while u do
    <> else m:=1;
      n:=n+m;
      d:= append(d,{symb,if m=1 then x else {'expt,x,m}});
    >>;
    return fancy!-maprin0
    {'quotient, {'times,if n=1 then symb else
                                    {'expt,symb,n},q},
       'times. d};
  end;

symbolic procedure fancy!-dfpriindexed(u,l);
   if null cddr u then fancy!-maprin0{'times,'partial!-df,cadr u} else
   begin scalar w;
      w:=fancy!-maprin0 cadr u;
      if testing!-width!* and w='failed then return w;
      w :=fancy!-print!-indexlist fancy!-dfpriindexedx(cddr u,nil);
      return w;
   end;

symbolic procedure fancy!-dfpriindexedx(u,p);
  if null u then nil else
  if numberp car u then
   append(for i:=2:car u collect p,fancy!-dfpriindexedx(cdr u,p))
     else
  car u . fancy!-dfpriindexedx(cdr u,car u);

put('!:rd!:,'fancy!-prifn,'fancy!-rdprin);
put('!:rd!:,'fancy!-flatprifn,'fancy!-rdprin);

symbolic procedure fancy!-rdprin u;
 fancy!-level
  begin scalar digits; integer dotpos,xp;
   u:=rd!:explode u;
   digits := car u; xp := cadr u; dotpos := caddr u;
   return fancy!-rdprin1(digits,xp,dotpos);
  end;

symbolic procedure fancy!-rdprin1(digits,xp,dotpos);
  begin scalar str;
   if xp>0 and dotpos+xp>;
    % build character string from number.
   for i:=1:dotpos do
   <400 then return 'failed;

      if x then
      << fancy!-maprint(x,0); fancy!-prin2!*(":=",4) >>;
      fl := fancy!-line!*; fp := fancy!-pos!*;
         %  remaining room for the columns.
      rw := linelength(nil)-2 -(fancy!-pos!*+2);
      rw := rw/cols;
      fmat := for each row in u collect
        for each elt in row collect
          if not fail then
          <maxpos then maxpos:=fancy!-pos!*;
            if w='failed or fancy!-pos!*>rw
              then fail:=t else
               (fancy!-line!*.fancy!-pos!*)
          >>;
     if fail then return 'failed;
     testing!-width!* := nil;
       % restore output line.
     fancy!-pos!* := fp; fancy!-line!* := fl;
       % TEX header
     fancy!-prin2!*(bldmsg("\left%w\begin{array}{",
                        if bkt then car bkt else "("),0);
     for i:=1:cols do fancy!-prin2!*("c",0);
     fancy!-prin2!*("}",0);
       % join elements.
     while fmat do
     <>;
  % if the next row does not fit on the current print line
  % we move it completely to a new line.
       if fst then
        w:= fancy!-level
         fancy!-in!-brackets(
          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
            '!(,'!)) where testing!-width!*=t;
       if w eq 'failed then fancy!-terpri!* t;
       if not fst or w eq 'failed then
         fancy!-in!-brackets(
          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
            '!(,'!));
       fst := t;
     >>;
  end;

put('mat,'fancy!-flatprifn,'fancy!-matpriflat);

symbolic procedure fancy!-matfit(u,p,op);
% Prinfit routine for matrix.
% a new line before it if there would be overflow otherwise.
 fancy!-level
   begin scalar pos,fl,fp,w,ll;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       if w neq 'failed then w := fancy!-matpri(u);
     end;
     if w neq 'failed or
       (w eq 'failed and testing!-width!*) then return w;
     fancy!-line!*:=fl; fancy!-pos!*:=pos; w:=nil;
     fp := fancy!-page!*;
% matrix: give us a second chance with a fresh line
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       fancy!-terpri!* nil;
       if w neq 'failed then w := fancy!-matpri u;
     end;
     if w neq 'failed then return t;
     fancy!-line!*:=fl; fancy!-pos!*:=pos; fancy!-page!*:=fp;

     ll:=linelength nil;
     if op then fancy!-oprin op;
     if atom u or fancy!-pos!* > ll #/ 2 then fancy!-terpri!* nil;
     return fancy!-matpriflat(u);
   end;

put('mat,'fancy!-prinfit,'fancy!-matfit);

put('taylor!*,'fancy!-reform,'Taylor!*print1);

endmodule;

module fancy_specfn;

put('besseli,'fancy!-prifn,'fancy!-bessel);
put('besselj,'fancy!-prifn,'fancy!-bessel);
put('bessely,'fancy!-prifn,'fancy!-bessel);
put('besselk,'fancy!-prifn,'fancy!-bessel);
put('besseli,'fancy!-functionsymbol,'(ascii 73));
put('besselj,'fancy!-functionsymbol,'(ascii 74));
put('bessely,'fancy!-functionsymbol,'(ascii 89));
put('besselk,'fancy!-functionsymbol,'(ascii 75));

symbolic procedure fancy!-bessel(u);
 fancy!-level
  begin scalar w;
   fancy!-prefix!-operator car u;
   w:=fancy!-print!-one!-index cadr u;
   if testing!-width!* and w eq 'failed then return w;
   return fancy!-print!-function!-arguments cddr u;
  end;

% Hypergeometric functions.

put('empty!*,'fancy!-special!-symbol,32);

put('hypergeometric,'fancy!-prifn,'fancy!-hypergeometric);

symbolic procedure fancy!-hypergeometric u;
 fancy!-level
  begin scalar w,a1,a2,a3;
   a1 :=cdr cadr u;
   a2 := cdr caddr u;
   a3 := cadddr u;
   fancy!-special!-symbol(get('empty!*,'fancy!-special!-symbol),nil);
   w:=fancy!-print!-one!-index length a1;
   if testing!-width!* and w eq 'failed then return w;
   fancy!-prin2!*("F",nil);
   w:=fancy!-print!-one!-index length a2;
   if testing!-width!* and w eq 'failed then return w;
   fancy!-prin2!*("(",nil);
   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
   fancy!-prin2!*("\,",1);
   w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
   fancy!-prin2!*("\,",1);
   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
   fancy!-prin2!*(")",nil);
   return w;
  end;

% hypergeometric({1,2,u/w,v},{5,6},sqrt x);

put('meijerg,'fancy!-prifn,'fancy!-meijerG);

symbolic procedure fancy!-meijerG u;
 fancy!-level
  begin scalar w,a1,a2,a3;
   integer n,m,p,q;
   a1 :=cdr cadr u;
   a2 := cdr caddr u;
   a3 := cadddr u;
   m:=length cdar a2;
   n:=length cdar a1;
   a1 := append(cdar a1 , cdr a1);
   a2 := append(cdar a2 , cdr a2);
   p:=length a1; q:=length a2;
   fancy!-prin2!*("G",nil);
   w := w eq 'failed or
        fancy!-print!-indexlist1({m,n},'!^,nil);
   w := w eq 'failed or
        fancy!-print!-indexlist1({p,q},'!_,nil);
   fancy!-prin2!*("(",nil);
   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
   w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
   fancy!-prin2!*(")",nil);
   return w;
  end;

% meijerg({{},1},{{0}},x);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/0000755000175000017500000000000011722677361022016 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/dfprin.red0000644000175000017500000002153611526203062023764 0ustar  giovannigiovannimodule dfprin;     % Printing for derivatives plus other options
                   % suggested by the Twente group

% Author: A. C. Norman,  reconstructing ideas from Ben Hulshof,
%                      Pim van den Heuvel and Hans van Hulzen.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*fort !*nat !*noarg depl!* posn!*);

global '(!*dfprint farglist!*);

switch dfprint,noarg;

!*dfprint := nil;  % This is OFF by default because switching it on
                   % changes Reduce output in a way that might upset
                   % customers who have not found out about this switch.
                   % Perhaps in later releases of the code (and when the
                   % manual reflects this upgrade) it will be possible
                   % to make 'on dfprint' the default. Some sites may of
                   % course wish to arrange things otherwise...

!*noarg := t;      % If dfprint is enabled I am happy for noarg to be
                   % the expected option.

farglist!* := nil;

symbolic procedure dfprintfn u;
% Display derivatives - if suitable flags are set this uses
% subscripts to denote differentiation and loses the arguments to
% functions.
   if not !*nat or !*fort or not !*dfprint then 'failed
   else begin
      scalar w;
      w := layout!-formula('!!df!! . cdr u, 0, nil);
      if w = nil then return 'failed
      else putpline w
   end;

put('df, 'prifn, 'dfprintfn);

symbolic procedure dflayout u;
% This is a prifn for !!df!!, which is used internally when I am
% formatting derivatives, but which should only ever be seen in
% testing!-width!* mode and never at all by the end-user.
  (begin
      scalar op, args, w;
      w := car (u := cdr u);
      u := cdr u;
      % Noarg must be off if an integral occurs.
      if smember('int,w) then !*noarg := nil;
      % Treat plus, times, etc. differently from REDUCE operators.
      if !*noarg and (atom w or not get(car w, 'op)) then <<
         if atom w then <<
            op := w;
            args := assoc(op, depl!*);         % Implicit args
            if args then args := cdr args >>
         else <<
            op := car w;
            args := cdr w >>;                  % Explicit args
         remember!-args(op, args);
         w := op >>;
      maprin w;
      if u then <<
         u := layout!-formula('!!dfsub!! . u, 0, nil); % subscript line
         if null u then return 'failed;
         w := 1 + cddr u;
         putpline((update!-pline(0, -w, caar u) . cdar u) .
                  ((cadr u - w) . (cddr u - w))) >>
   end) where !*noarg = !*noarg;

symbolic procedure dfsublayout u;
% This is a prifn for !!dfsub!!, which is used internally when I am
% formatting derivatives, but which should only ever be seen in
% testing!-width!* mode and never at all by the end-user.
   begin
      scalar dfcase, firstflag, w;
% This is used as a prifn for both df and other things with
% subscripts - dfcase remembers which.
      dfcase := (car u = '!!dfsub!!);
      u := cdr u;
      firstflag := t;
      while u do <<
         w := car u;
         u := cdr u;
         if firstflag then firstflag := nil
          else prin2!* ",";
         if dfcase and u and numberp car u then <<
            prin2!* car u;
            u := cdr u >>;
         maprin w >>
   end;

put('!!df!!, 'prifn, 'dflayout);
put('!!dfsub!!, 'prifn, 'dfsublayout);

symbolic procedure remember!-args(op, args);
% This records information that can be displayed by the user
% issuing the command 'FARG'.
   begin
      scalar w;
      w := assoc(op, farglist!*);
      if null w then farglist!* := (op . args) . farglist!*
   end;

symbolic procedure farg;
% Implementation of FARG: display implicit argument data
   begin
      scalar newname;
      prin2!* "The operators have the following ";
      prin2!* "arguments or dependencies";
      terpri!* t;
      for each p in farglist!* do <<
         prin2!* car p;
         prin2!* "=";
% To avoid clever pieces of code getting rid of argument displays
% here I convert the name of the function into a string so that
% maprin produces a simple but complete display. Since I expect
% farg to be called but rarely this does not seem overexpensive
         newname := compress ('!" . append(explode2 car p, '(!")));
         maprin(newname . cdr p);
         terpri!* t >>
   end;

put('farg, 'stat, 'endstat);

symbolic procedure clfarg;
% Clear record of implicit args
   farglist!* := nil;

put('clfarg, 'stat, 'endstat);

symbolic procedure setprifn(u, fn);
% Establish (or clear) prifn property for a list of symbols
   for each n in u do
      if idp n then <<
% Things listed here will be declared operators now if they have
% not been so declared earlier.
         if not operatorp n then mkop n;
         if fn then put(n, 'prifn, fn)
          else remprop(n, 'prifn) >>
       else lprim list(n, "not an identifier");

symbolic procedure indexprin u;
% Print helper-function when integer-valued arguments are to be shown as
% subscripts
   if not !*nat or !*fort then 'failed
   else begin
      scalar w;
      w := layout!-formula('!!index!! . u, 0, nil);
      if w = nil then return 'failed
      else putpline w
   end;

symbolic procedure indexpower(u, n);
% Print helper-function when integer-valued arguments are to be shown as
% subscripts with exponent n
    begin
      scalar w;
      w := layout!-formula('!!indexpower!! . n . u, 0, nil);
      if w = nil then return 'failed
      else putpline w
   end;

symbolic procedure indexlayout u;
% This is a prifn for !!index!!, which is used internally when I am
% formatting index forms, but which should only ever be seen in
% testing!-width!* mode and never at all by the end-user.
   begin
      scalar w;
      w := car (u := cdr u);
      u := cdr u;
      maprin w;
      if u then <<
         u := layout!-formula('!!indexsub!! . u, 0, nil);
            % subscript line
         if null u then return 'failed;
         w := 1 + cddr u;
         putpline((update!-pline(0, -w, caar u) . cdar u) .
                  ((cadr u - w) . (cddr u - w))) >>
   end;

symbolic procedure indexpowerlayout u;
% Format a subscripted object raised to some power.
   begin
      scalar n, w, pos, maxpos;
      n := car (u := cdr u);  % The exponent
      w := car (u := cdr u);
      u := cdr u;
      maprin w;
      w := layout!-formula(n, 0, nil);
      pos := posn!*;
      putpline((update!-pline(0, 1 - cadr w, caar w) . cdar w) .
               (1 . (1 + cddr w - cadr w)));
      maxpos := posn!*;
      posn!* := pos;
      if u then <<
         u := layout!-formula('!!indexsub!! . u, 0,nil);
             % subscript line
         if null u then return 'failed;
         w := 1 + cddr u;
         putpline((update!-pline(0, -w, caar u) . cdar u) .
                  ((cadr u - w) . (cddr u - w))) >>;
      posn!* := max(posn!*, maxpos)
   end;

put('!!index!!, 'prifn, 'indexlayout);
put('!!indexpower!!, 'prifn, 'indexpowerlayout);
put('!!indexsub!!, 'prifn, 'dfsublayout);

symbolic procedure noargsprin u;
% Print helper-function when arguments for a function are to be hidden,
% but remembered for display via farg
   if not !*nat or !*fort then 'failed
    else <<
       remember!-args(car u, cdr u);
       maprin car u >>;

symbolic procedure doindex u;
% Establish some function names to have args treated as index values
   setprifn(u, 'indexprin);

symbolic procedure offindex u;
% Clear effect of doindex
   setprifn(u, nil);

symbolic procedure donoargs u;
% Identify functions where args are to be hidden
   setprifn(u, 'noargsprin);

symbolic procedure offnoargs u;
% Clear effect of donoargs
   setprifn(u, nil);

put('doindex, 'stat, 'rlis);
put('offindex, 'stat, 'rlis);
put('donoargs, 'stat, 'rlis);
put('offnoargs, 'stat, 'rlis);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/fortpri.red0000644000175000017500000002506011526203062024163 0ustar  giovannigiovannimodule fortpri; % FORTRAN output package for expressions.

% Author: Anthony C. Hearn.

% Modified by: James Davenport after Francoise Richard, April 1988.
%              Herbert Melenk (introducing C output style), October 1994

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid  '(!*fort
         !*fortupper
         !*period
         scountr
         explis
         fbrkt
         fvar
         nchars
         svar
         posn!*
         fortlang!*);

switch fortupper;

global '(card_no
         charassoc!*
         fort_width
         fort_lang
         spare!*
         varnam!*);

%   The global fort_exponent is defined in the module arith/smlbflot.

% Global variables initialized in this section.

% SPARE!* should be set in the system dependent code module.

card_no:=20;
charassoc!* :=
         '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e) (!F . !f)
           (!G . !g) (!H . !h) (!I . !i) (!J . !j) (!K . !k) (!L . !l)
           (!M . !m) (!N . !n) (!O . !o) (!P . !p) (!Q . !q) (!R . !r)
           (!S . !s) (!T . !t) (!U . !u) (!V . !v) (!W . !w) (!X . !x)
           (!Y . !y) (!Z . !z));
fort_width := 70;
posn!* := 0;
varnam!* := 'ans;
fort_lang := 'fort;

flag ('(card_no fort_width fort_lang),'share);

put('fort_array,'stat,'rlis);

flag('(fort_array),'flagop);

symbolic procedure varname u;
   % Sets the default variable assignment name.
   if not idp car u then typerr(car u,"identifier")
    else varnam!* := car u;

rlistat '(varname);

symbolic procedure flength(u,chars);
   if chars<0 then chars
    else if atom u
     then chars-if numberp u then if fixp u then flatsizec u+1
                                   else flatsizec u
                 else flatsizec((lambda x; if x then x else u)
                                   get(u,'prtch))
    else flength(car u,flenlis(cdr u,chars)-2);

symbolic procedure flenlis(u,chars);
   if null u then chars
    else if chars<0 then chars
    else if atom u then flength(u,chars)
    else flenlis(cdr u,flength(car u,chars));

symbolic procedure fmprint(l,p);
   begin scalar x,w;
        if null l then return nil
         else if atom l then <<
           if l eq 'e then return
%            if fortlang!*='c then "exp(1.0)" else "EXP(1.0)";
             fprin2!* "EXP(1.0)";
           if fixp l and !*period then return fmprint(i2rd!* l,p);
           if not numberp l or
              not(l<0) then return fprin2!* l;
           fprin2!* "(";
           fbrkt := nil . fbrkt;
           fprin2!* l;
           fprin2!* ")";
           return fbrkt := cdr fbrkt >>
         else if stringp l then return fprin2!* l
         else if not atom car l then fmprint(car l,p)
         else if x := get(car l,'fort)
          then return apply2(x,l,p)
         else if ((x := get(car l,'pprifn))
             and not((x := apply2(x,l,p)) eq 'failed)) or
                 ((x := get(car l,'prifn))
             and not((x := apply1(x,l)) eq 'failed))
          then return x
         else if x := get(car l,'infix) then <<
            p := not(x>p);
            if p then <>;
            fnprint(car l,x,cdr l);
            if p then <>;
            return >>
         else fprin2!* car l;
        w:= fortlang!* = 'c and flagp(car l,'fort_array);
        fprin2!* if w then "[" else "(";
        fbrkt := nil . fbrkt;
        x := !*period;
        % Assume no period printing for non-operators (e.g., matrices).
        if gettype car l neq 'operator or flagp(car l,'fort_array)
                   then !*period := nil;
        if cdr l then fnprint(if w then "][" else '!*comma!*,0,cdr l);
        !*period := x;
        fprin2!* if w then "]" else ")";
        return fbrkt := cdr fbrkt
   end;

symbolic procedure fnprint(op,p,l);
   begin
        if op eq 'expt then return fexppri(p,l)
         else if not get(op,'alt) then <<
           fmprint(car l,p);
           l := cdr l >>;
        for each v in l do <<
          if atom v or not (op eq get(car v,'alt)) then foprin op;
          fmprint(v,p) >>
   end;

symbolic procedure fexppri(p,l);
   % Next line added by James Davenport after Francoise Richard.
   if car l eq 'e then fmprint('exp . cdr l,p)
   % C entry by Herbert Melenk.
    else if fortlang!*='c then
       if fixp cadr l and cadr l >0 and cadr l<4 then
           fmprint('times . for i:=1:cadr l collect car l,p)
       else fmprint('pow.l,p)
    else begin scalar pperiod;
      fmprint(car l,p);
      foprin 'expt;
      pperiod := !*period;
      if numberp cadr l then !*period := nil else !*period := t;
      fmprint(cadr l,p);
      !*period := pperiod
   end;

put('pow,'simpfn,'simpiden);

symbolic procedure foprin op;
   (if null x then fprin2!* op else fprin2!* x) where x=get(op,'prtch);

symbolic procedure fvarpri(u,v,w);
   %prints an assignment in FORTRAN notation;
   begin integer scountr,llength,nchars; scalar explis,fvar,svar;
        fortlang!* := reval fort_lang;
        if not(fortlang!* memq '(fort c)) then
           typerr(fortlang!*,"target language");
        if not posintegerp card_no
          then typerr(card_no,"FORTRAN card number");
        if not posintegerp fort_width
          then typerr(fort_width,"FORTRAN line width");
        llength := linelength fort_width;
        if stringp u
          then return <>;
        if eqcar(u,'!*sq) then u := prepsq!* sqhorner!* cadr u;
        scountr := 0;
        nchars := if fortlang!* = 'c then 999999
            else ((linelength nil-spare!*)-12)*card_no;
           %12 is to allow for indentation and end of line effects;
        svar := varnam!*;
        fvar := if null v then (if fortlang!*='fort then svar else nil)
                 else car v;
        if posn!*=0 and w then fortpri(fvar,u,w)
         else fortpri(nil,u,w);
                % should mean expression preceded by a string.
        linelength llength
   end;

symbolic procedure fortpri(fvar,xexp,w);
   begin scalar fbrkt;
      if eqcar(xexp,'list)
        then <>;
        if flength(xexp,nchars)<0
          then xexp := car xexp . fout(cdr xexp,car xexp,w);
        if fvar
          then <>
                             else spaces 5;
                prin2 if fortlang!*='c then "  " else ". ";
                posn!* := n+7>>;
        fprin2 u;
        if fixp u and !*period then prin2 "."
   end;

symbolic procedure prin2!-downcase u;
   for each c in explode2 u do
      if liter c then prin2 red!-char!-downcase c else prin2 c;

symbolic procedure prin2!-upcase u;
   for each c in explode2 u do
      if liter c then prin2 red!-char!-upcase c else prin2 c;

symbolic procedure fprin2 u;
   % Prints id or string u so that case of all characters depends on
   % !*fortupper. Note !*lower setting only relevant here for PSL.
   (if !*fortupper then prin2!-upcase u else prin2!-downcase u)
    where !*lower = nil;

symbolic procedure red!-char!-downcase u;
   (if x then cdr x else u) where x = atsoc(u,charassoc!*);

symbolic procedure red!-char!-upcase u;
   (if x then car x else u) where x = rassoc(u,charassoc!*);

symbolic procedure fterpri(u);
   <>;

symbolic procedure genvar;
   intern compress append(explode svar,explode(scountr := scountr + 1));

mkop 'no_period;  % for printing of expressions with period locally off.

put('no_period,'fort,'fo_no_period);

symbolic procedure fo_no_period(u,p);
   begin scalar !*period; fmprint(cadr u,p) end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/prend.red0000644000175000017500000001063411526203062023607 0ustar  giovannigiovannimodule prend;

% Author: Arthur C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*clisp);

switch clisp;

% These parts come from rend.red.....

comment
vdu(23, 235,   0,   0, 224,  48,  24,  24,  24,  24, % mat-top-r
    23, 236,  24,  24,  24,  24,  12,   7,   0,   0, % mat-bottom-l
    23, 237,   0,  30,  51,  97,  97,  51,  30,   0, % infinity left
    23, 238,   0, 120, 204, 134, 134, 204, 120,   0, % infinity right
    23, 239,   24, 24,  24,  24,   0,   0,   0,   0, % pi bottom
    23, 240,   0,   0, 127,  54,  54,  54,  54,   0, % pi
    23, 241,   0,   0,   0, 255,   0,   0,   0,   0, % fraction bar
    23, 242,   0,   0,   7,  12,  24,  24,  24,  24, % int-top
    23, 243,  24,  24,  24,  24,  24,  24,  24,  24, % int-mid
    23, 244,  24,  24,  24,  24,  48, 224,   0,   0, % int-bottom
    23, 245,  28,   6,   6,  62, 102, 102,  60,   0, % curly d
    23, 246,   6,   6,  12,  12, 236,  56,  24,   0, % square root
    23, 247,   0,   0,   0, 127,  96,  48,  24,  12, % sigma top left
    23, 248,   0,   0,   0, 254,   6,   0,   0,   0, % sigma top right
    23, 249,   6,   3,   1,   0,   1,   3,   6,  12, % sigma mid left
    23, 250,   0,   0, 128, 192, 128,   0,   0,   0, % sigma middle
    23, 251,  24,  48,  96, 127,   0,   0,   0,   0, % sigma bottom left
    23, 252,   0,   0,   6, 254,   0,   0,   0,   0, % sigma bottom rght
    23, 253,   0,   0,   0, 127,  24,  24,  24,  24, % pi top left
    23, 254,   0,   0,   0, 254,  24,  24,  24,  24  % pi top right
    );


% The following four functions are local to this module, and need to
% be defined in CLISP systems (and clisp turned on).

symbolic procedure character u; nil;

symbolic procedure clearbuff; nil;

symbolic procedure packbyte u; nil;

symbolic procedure mkatom; nil;

put('!.pi, 'clisp!-character, character 240);
put('bar, 'clisp!-character, character 241);
put('int!-top, 'clisp!-character, character 242);
put('int!-mid, 'clisp!-character, character 243);
put('int!-low, 'clisp!-character, character 244);
put('d, 'clisp!-character, character 245);
put('sqrt, 'clisp!-character, character 246);
put('vbar, 'clisp!-character, character 243);
put('sum!-top, 'clisp!-character,
    << clearbuff();
       packbyte 247; packbyte 241; packbyte 248;
       mkatom() >>);
put('sum!-mid, 'clisp!-character,
    << clearbuff();
       packbyte 249; packbyte 250; packbyte 32;
       mkatom() >>);
put('sum!-low, 'clisp!-character,
    << clearbuff();
       packbyte 251; packbyte 241; packbyte 252;
       mkatom() >>);
put('prod!-top, 'clisp!-character,
    << clearbuff();
       packbyte 253; packbyte 241; packbyte 254;
       mkatom() >>);
put('prod!-mid, 'clisp!-character,
    << clearbuff();
       packbyte 243; packbyte 32; packbyte 243;
       mkatom() >>);
put('prod!-low, 'clisp!-character,
    << clearbuff();
       packbyte 239; packbyte 32; packbyte 239;
       mkatom() >>);
put('infinity, 'clisp!-character,
    << clearbuff();
       packbyte 237; packbyte 238;
       mkatom() >>);

put('mat!-top!-l, 'clisp!-character, character 242);
put('mat!-top!-r, 'clisp!-character, character 235);
put('mat!-low!-l, 'clisp!-character, character 236);
put('mat!-low!-r, 'clisp!-character, character 244);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/xprint.red0000644000175000017500000003310011526203062024014 0ustar  giovannigiovannimodule xprint; % Display sums, products and integrals in 2D.

% Author: A C Norman, 1992 (and various much earlier occasions).

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Print some things using PC characters that will make some things
% look really pretty.  Note that the effect can depend on you having
% a suitable code-page selected - if you have trouble you can always
% go "off msdos;" and use the default display.

fluid '(!*csl);

switch msdos;

remflag('(symbol), 'lose); % Defined in mathpr.red; this version updates

symbolic procedure symbol x;
  begin
    scalar y;
    if !*msdos then y := get(x, 'msdos!-character);
    if y = nil then y := get(x, 'symbol!-character);
    return y
  end;

symbolic procedure character u;
   string!-compress list u;

symbolic procedure string!-compress u;
   % In CSL when compress is given an integer in its list it treats it
   % as a character code.  PSL needs a more complicated construction.
  if !*csl then compress u else
   begin scalar n,v,c;
     n:=length u;
     v := mkstring(n-1);
     for i:=0:(n-1) do
      setf(strbyt(strinf(v),i),
       if numberp(c:=nth(u,n)) then c else id2int c);
     return v;
   end;


% When nat is enabled I use some programmable characters to
% draw pi, fraction bars and integral signs. (symbol 's) returns
% a character-object, and I use
%   .pi         pi
%   bar         solid horizontal bar                    -
%   int-top     top hook of integral sign               /
%   int-mid     vertical mid-stroke of integral sign    |
%   int-low     lower hook of integral sign             /
%   d           curly-d for use with integral display   d
%   sqrt        square root sign                        sqrt
%   sum-top     ---
%   sum-mid     >              for summation
%   sum-low     ---
%   prod-top             ---
%   prod-mid             | |   for products
%   prod-low             | |
%   infinity    infinity sign
%   mat!-top!-l               for display of matrices
%   mat!-top!-r
%   mat!-mid!-l
%   mat!-mid!-r
%   mat!-low!-l
%   mat!-low!-r
%   vbar            |


<< put('!.pi, 'msdos!-character, character 227);
   put('bar, 'msdos!-character, character 196);
   put('int!-top, 'msdos!-character, character 244);
   put('int!-mid, 'msdos!-character, character 179);
   put('int!-low, 'msdos!-character, character 245);
   put('d, 'msdos!-character, character 235);
   put('sqrt, 'msdos!-character, character 251);
   put('vbar, 'msdos!-character, character 179);
   put('sum!-top, 'msdos!-character, string!-compress '(196 196 196));
   put('sum!-mid, 'msdos!-character, ">  ");
   put('sum!-low, 'msdos!-character, string!-compress '(196 196 196));
   put('prod!-top, 'msdos!-character, string!-compress '(194 196 194));
   put('prod!-mid, 'msdos!-character, string!-compress '(179 !! !  179));
   put('prod!-low, 'msdos!-character, string!-compress '(179 !! !  179));
   put('infinity, 'msdos!-character, character 236);

   put('mat!-top!-l, 'msdos!-character, character 218);
   put('mat!-top!-r, 'msdos!-character, character 191);
   put('mat!-mid!-l, 'msdos!-character, character 179);
   put('mat!-mid!-r, 'msdos!-character, character 179);
   put('mat!-low!-l, 'msdos!-character, character 192);
   put('mat!-low!-r, 'msdos!-character, character 217);

   put('!.pi, 'symbol!-character, 'pi);
   put('bar, 'symbol!-character, '!-);
   put('int!-top, 'symbol!-character, '!/);
   put('int!-mid, 'symbol!-character, '!|);
   put('int!-low, 'symbol!-character, '!/);
   put('d, 'symbol!-character, '!d);   % This wants to remain lower case
   put('vbar, 'symbol!-character, '!|);
   put('sum!-top, 'symbol!-character, "---");
   put('sum!-mid, 'symbol!-character, ">  ");
   put('sum!-low, 'symbol!-character, "---");
   put('prod!-top, 'symbol!-character, "---");
   put('prod!-mid, 'symbol!-character, "| |");
   put('prod!-low, 'symbol!-character, "| |");
   put('infinity, 'symbol!-character, 'infinity);
      % In effect nothing special

   put('mat!-top!-l, 'symbol!-character, '![);
   put('mat!-top!-r, 'symbol!-character, '!]);
   put('mat!-mid!-l, 'symbol!-character, '![);
   put('mat!-mid!-r, 'symbol!-character, '!]);
   put('mat!-low!-l, 'symbol!-character, '![);
   put('mat!-low!-r, 'symbol!-character, '!]) >>;

fluid  '(!*fort
         !*nat
         ycoord!*
         ymin!*
         ymax!*
         posn!*
         orig!*
         pline!*);

global '(spare!*);

load_package matrix;         % Load before redefining bits of this.
remflag('(matpri1), 'lose);  % Was in matrix.red - redefined here.

symbolic procedure matpri1(u,x);
   % Prints a matrix canonical form U with name X.
   % Tries to do fancy display if nat flag is on.
   begin scalar m,n,r,l,w,e,ll,ok,name,nw,widths,firstflag,toprow,lbar,
                rbar,realorig;
      if !*fort
        then <>;
                    m := m+1>>;
               return nil>>;
      terpri!* t;
      if x and !*nat then <<
         name := layout!-formula(x, 0, nil);
         if name then <<
           nw := cdar name + 4;
           ok := !*nat >>>>
       else <>;
      ll := linelength nil - spare!* - orig!*;
      m := length car u;
      widths := mkvect(1 + m);
      for i := 1:m do putv(widths, i, 1);
      % Collect sizes for all elements to see if it will fit in
      % displayed matrix form.
      % We need to compute things wrt a zero orig for the following
      % code to work properly.
      realorig := orig!*;
      orig!* := 0;
      if ok then for each y in u do
       < ll then ok := nil
                else <<
                  l := e . l;
                  putv(widths, n, col) >> end;
            n := n+1>>;
         r := (reverse l) . r >>;
         if ok then <<
         % Matrix will fit in displayed representation.
         % Compute format with respect to 0 posn.
         firstflag := toprow := t;
         r := for each py on reverse r collect begin
            scalar y, ymin, ymax, pos, pl, k, w;
            ymin := ymax := 0;
            pos := 1;    % Since "[" is of length 1.
            k := 1;
            pl := nil;
            y := car py;
            for each z in y do <<
               w := getv(widths, k);
               pl := append(update!-pline(pos+(w-cdar z)/2,0,caar z),
                            pl);      % Centre item in its field
               pos := pos + w + 2;    % 2 blanks between cols
               k := k + 1;
               ymin := min(ymin, cadr z);
               ymax := max(ymax, cddr z) >>;
            k := nil;
            if firstflag then firstflag := nil
             else ymax := ymax + 1;   % One blank line between rows
            for h := ymax step -1 until ymin do <<
%              if toprow then <<
%                 lbar := symbol 'mat!-top!-l;
%                 rbar := symbol 'mat!-top!-r;
%                 toprow := nil >>
%               else if h = ymin and null cdr py then <<
%                 lbar := symbol 'mat!-low!-l;
%                 rbar := symbol 'mat!-low!-r >>
%               else
                << lbar := symbol 'mat!-mid!-l;
                   rbar := symbol 'mat!-mid!-r>>;
               pl := ((((pos - 2) . (pos - 1)) . h) . rbar) . pl;
               k := (((0 . 1) . h) . lbar) . k >>;
            return (append(pl, k) . pos) . (ymin . ymax) end;
         orig!* := realorig;
         w := 0;
         for each y in r do w := w + (cddr y - cadr y + 1);
               % Total height.
         n := w/2;  % Height of mid-point.
         u := nil;
         for each y in r do <<
            u := append(update!-pline(0, n - cddr y, caar y), u);
            n := n - (cddr y - cadr y + 1) >>;
         if x then <>;
         pline!* := append(update!-pline(posn!*,ycoord!*,u),
                           pline!*);
         ymax!* := max(ycoord!* + w/2, ymax!*);
         ymin!* := min(ycoord!* + w/2 - w, ymin!*);
         terpri!*(not !*nat)>>
      else <>; matpri2 u>>
   end;

symbolic procedure intprint u;
   if not !*nat or !*fort then 'failed
   else begin
      scalar m;
      prin2!* symbol 'int!-mid;
      m := posn!* - 1;
      pline!* := (((m . posn!*) . (ycoord!* + 1)) .
                      symbol 'int!-top) . pline!*;
      pline!* := (((m . posn!*) . (ycoord!* - 1)) .
                      symbol 'int!-low) . pline!*;
      if ycoord!*+1>ymax!* then ymax!* := ycoord!*+1;
      if ymin!*>ycoord!*-1 then ymin!* := ycoord!*-1;
      maprin cadr u;
      prin2!* " ";
      prin2!* symbol 'd;
      maprin caddr u
   end;

put('int, 'prifn, 'intprint);

symbolic procedure sqrtprint u;
   if not !*nat or !*fort then 'failed
   else begin
      scalar m;
      m := symbol 'sqrt;
% The square-root sign may not be available as a symbol - if it is
% not then I will not do anything special here
      if m=nil then return 'failed;
      prin2!* m;
      u := cadr u;
      if not atom u or (numberp u and u < 0) then <<
   prin2!* "(";
          m := t >>
       else m := nil;
      maprin u;
      if m then prin2!* ")"
   end;

put('sqrt, 'prifn, 'sqrtprint);

symbolic procedure sumprint(u,p);
   sppri(u, p, symbol 'sum!-top, symbol 'sum!-mid, symbol 'sum!-low);

symbolic procedure prodprint(u,p);
   sppri(u, p, symbol 'prod!-top, symbol 'prod!-mid, symbol 'prod!-low);

symbolic procedure sppri(u, p, top, mid, low);
   if not !*nat or !*fort then 'failed
   else begin
      scalar w1,w2,w3,o1,o2,o3,o4,m,ll,bkt;
      if null (u := cdr u) then return 'failed;
% Format is
%   (sum body var low high)
      o1 := car u;     % The body
      if null (u := cdr u) then return 'failed;
      o2 := car u;     % The variable involved
      if null (u := cdr u) then return 'failed;
      o3 := car u;     % The low limit
      if null (u := cdr u) then return 'failed;
      o4 := car u;     % The high limit
      if (u := cdr u) then return 'failed;
      w2 := list('equal, o2, o3);
      w1 := o4;
      u := o1;
      ll := linelength nil - spare!*;
      spare!* := spare!* + ll/2;
      if w1 then <<
          if null (w1 := layout!-formula(w1, 0, nil)) then <<
             spare!* := spare!* - ll/2;
             return 'failed >> >>
      else w1 := (nil . 0) . (0 . -1);
      if w2 then <<
          if null (w2 := layout!-formula(w2, 0, nil)) then <<
             spare!* := spare!* - ll/2;
             return 'failed >> >>
      else w2 := (nil . 0) . (0 . -1);
      spare!* := spare!* - ll/2;
      m := 0 . 3;
      w3 := list(((m . 1) . top),
                 ((m . 0) . mid),
                 ((m . -1) . low));  % Pline structure for big symbol;
      m := max(cdar w1, cdar w2, 3);
% Here I decide if the entire sum needs to be put in parens. I am
% not at present certain that I have this test just the way it
% ought to be, but at least this is an approximation.
      bkt := p >= get('plus, 'infix);
      if bkt then m := m + 1;
      if posn!* + m > ll then terpri!* t;
      if bkt then prin2!* "(";
      o1 := (m - cdar w1)/2 + posn!* - orig!*;
      o2 := (m - cdar w2)/2 + posn!* - orig!*;
      o3 := (m - 3)/2 + posn!*;
      pline!* := append(
         update!-pline(o3, ycoord!*, w3),
         append(update!-pline(o1, ycoord!* + 2 - cadr w1, caar w1),
                append(update!-pline(o2, ycoord!* - 2 - cddr w2,
                                     caar w2), pline!*)));
      ymax!* := max(ymax!*, ycoord!* + 2 + cddr w1 - cadr w2);
      ymin!* := min(ymin!*, ycoord!* - 2 - cddr w2 + cadr w2);
      posn!* := posn!* + m;
      maprint(u, get('minus, 'infix));
      if bkt then prin2!* ")"
   end;

put('sum, 'pprifn, 'sumprint);
put('product, 'pprifn, 'prodprint);

put('sumprint, 'expt, 'inbrackets);
put('prodprint, 'expt, 'inbrackets);

symbolic procedure factpri u;
   if not !*nat or !*fort then 'failed
   else <<
      maprint(cadr u, 100);
      prin2!* "!" >>;

put('fact, 'prifn, 'factpri);

algebraic;

operator fact, sum, product;

endmodule;

end;

mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/sqprint.red0000644000175000017500000001513611526203062024201 0ustar  giovannigiovannimodule sqprint;   % Routines for printing standard forms and quotients.

% Author: Anthony C. Hearn.

% Copyright (c) 1996 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modified by A. C. Norman, 1987.

fluid  '(!*fort
         !*horner
         !*nat
         !*nero
         !*pri
         !*prin!#
         overflowed!*
         orig!*
         outputhandler!*
         posn!*
         testing!-width!*
         ycoord!*
         ymax!*
         ymin!*
         wtl!*);

testing!-width!* := overflowed!* := nil;

global '(!*eraise);

switch horner;

% When nat is enabled I use some programmable characters to
% draw pi, fraction bars and integral signs. (symbol 's) returns
% a character-object, and I use
%   .pi         pi
%   bar         solid horizontal bar                    -
%   int-top     top hook of integral sign               /
%   int-mid     vertical mid-stroke of integral sign    |
%   int-low     lower hook of integral sign             /
%   d           curly-d for use with integral display   d
%   sqrt        square root sign                        sqrt
%   sum-top     ---
%   sum-mid     >              for summation
%   sum-low     ---
%   prod-top             ---
%   prod-mid             | |   for products
%   prod-low             | |
%   infinity    infinity sign
%   mat!-top!-l     /          for display of matrices
%   mat!-top!-r     \
%   mat!-low!-l     \
%   mat!-low!-r     /
%   vbar            |


symbolic procedure !*sqprint u; sqprint cadr u;

put('!*sq,'prifn,'!*sqprint);

symbolic procedure printsq u; <>;

symbolic procedure sqprint u;
   % Mathprints the standard quotient u.
   begin scalar flg,z,!*prin!#;
        !*prin!# := t;
        z := orig!*;
        if !*nat and posn!*<20 then orig!* := posn!*;
        if !*pri or wtl!* then maprin prepreform prepsq!* sqhorner!* u
         else if cdr u neq 1
           then <>
         else xprinf2 car u;
        return (orig!* := z)
   end;

symbolic procedure prepreform u;
   % U is an algebraic expression prepared for output by prepsq*.
   % Reform inner kernel arguments if these contain references to a
   % variable which has been declared in a factor or order statement.
   prepreform1(u,append(ordl!*,factors!*));

symbolic procedure prepreform1(u,l);
   if atom u or get(car u,'dname) then u else
      begin scalar w,l1;
         l1 := l;
         while null w and l1 do
           if smemq(car l1,cdr u) then w:=t else l1:=cdr l1;
         if null w then return u;
         if memq(car u,'(plus difference minus times quotient))
           or null get(car u,'simpfn) then w := nil;
        return if car u eq '!*sq
                 then prepreform1(prepsq!* sqhorner!* cadr u,l)
                else car u . for each p in cdr u collect
               prepreform1(if w
                             then prepsq!* sqhorner!* simp!* p else p,l)
      end;

symbolic procedure sqhorner!* u;
  if not !*horner then u else
   hornersq(reorder numr u ./ hornerf reorder denr u)
     where kord!* = append(ordl!*,kord!*);

symbolic procedure printsf u; <>;

symbolic procedure prinsf u; if null u then prin2!* 0 else xprinf2 u;

symbolic procedure xprinf(u,flg,w);
   % U is a standard form, flg determines whether parens are needed.
   % W is currently unused.
   % Procedure prints the form and returns NIL.
   begin flg and prin2!* "("; xprinf2 u; flg and prin2!* ")" end;

symbolic procedure xprinf2 u;
   begin scalar v;
      while not domainp u do <>;
      if null u then return nil
       else if minusf u then <>
       else if v then oprin 'plus;
      if atom u then prin2!* u else maprin u
   end;

symbolic procedure xprint(u,flg);
   % U is a standard term.
   % Flg is a flag which is true if a term has preceded this term.
   % Procedure prints the term and returns NIL.
   begin scalar v,w;
      v := tc u;
      u := tpow u;
      if (w := kernlp v) and w neq 1
        then <>>>;
      if flg then oprin 'plus;
      if w and w neq 1 then <>;
      xprinp u;
      if v neq 1 then <>
   end;

symbolic procedure xprinp u;
   % U is a standard power.  Procedure prints term and returns NIL.
   begin
      % Process main variable.
      if atom car u then prin2!* car u
       else if not atom caar u or caar u eq '!*sq then
        <>
       else if caar u eq 'plus then maprint(car u,100)
       else maprin car u;
      % Process degree.
      if (u := cdr u)=1 then return nil
       else if !*nat and !*eraise
        then <ymax!* then ymax!* := ycoord!*>>
       else prin2!* get('expt,'prtch);
      prin2!* if numberp u and minusp u then list u else u;
      if !*nat and !*eraise
        then <ycoord!* then ymin!* := ycoord!*>>
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/mprint.red0000644000175000017500000003667311526203062024023 0ustar  giovannigiovannimodule mprint; % Basic output package for symbolic expressions.

% Authors: Anthony C. Hearn and Arthur C. Norman.

% Copyright (c) 1991 RAND.  All rights reserved.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid  '(!*fort
         !*list
         !*nat
         !*nosplit
         !*ratpri
         !*revpri
         bool!-functions!*
         obrkp!*
         overflowed!*
         orig!*
         outputhandler!*
         pline!*
         posn!*
         p!*!*
         testing!-width!*
         ycoord!*
         ymax!*
         ymin!*
         rprifn!*
         rterfn!*);

fluid '(!*TeX);

global '(!*eraise initl!* nat!*!* spare!* !*asterisk);

switch list,ratpri,revpri,nosplit,asterisk;

% Global variables initialized in this section.

% SPARE!* should be set in the system dependent code module,
% but is now assumed to be zero.

!*asterisk := t;
!*eraise := t;
!*nat := nat!*!* := t;
!*nosplit := t;            % Expensive, maybe??
obrkp!* := t;
orig!*:=0;
posn!* := 0;
ycoord!* := 0;
ymax!* := 0;
ymin!* := 0;

initl!* := append('(orig!* pline!*),initl!*);

put('orig!*,'initl,0);

flag('(linelength),'opfn);  %to make it a symbolic operator;

symbolic procedure mathprint l;
   << terpri!* t;
      maprin l;
      terpri!* t >>;

symbolic procedure maprin u;
   if outputhandler!* then apply2(outputhandler!*,'maprin,u)
    else if not overflowed!* then maprint(u,0);

symbolic procedure maprint(l,p!*!*);
   % Print expression l at bracket level p!*!* without terminating
   % print line.  Special cases are handled by:
   %    pprifn: a print function that includes bracket level as 2nd arg.
   %     prifn: a print function with one argument.
   begin scalar p,x,y;
        p := p!*!*;     % p!*!* needed for (expt a (quotient ...)) case.
        if null l then return nil
         else if atom l
          then <>;
                 return l >>
         else if not atom car l then maprint(car l,p)
         else if ((x := get(car l,'pprifn)) and
                   not(apply2(x,l,p) eq 'failed)) or
                 ((x := get(car l,'prifn)) and
                   not(apply1(x,l) eq 'failed))
          then return l
         else if x := get(car l,'infix) then <<
           p := not(x>p);
           if p then <<
             y := orig!*;
             prin2!* "(";
             orig!* := if posn!*<18 then posn!* else orig!*+3 >>;
% (expt a b) was dealt with using a pprifn sometime earlier than this
           inprint(car l,x,cdr l);
           if p then <<
              prin2!* ")";
              orig!* := y >>;
           return l >>
         else prin2!* car l;
        prin2!* "(";
        obrkp!* := nil;
        y := orig!*;
        orig!* := if posn!*<18 then posn!* else orig!*+3;
        if cdr l then inprint('!*comma!*,0,cdr l);
        obrkp!* := t;
        orig!* := y;
        prin2!* ")";
        return l
    end;

symbolic procedure vec!-maprin(u,p!*!*);
   <>;
     maprint(getv(u,upbv(u)),p!*!*);
     prin2!* '!]>>;

symbolic procedure exptpri(l,p);
% Prints expression in an exponent notation.
   begin scalar !*list,x,pp,q,w1,w2;
      if not !*nat or !*fort then return 'failed;
      pp := not((q:=get('expt,'infix))>p);  % Need to parenthesize
      w1 := cadr l;
      w2 := caddr l;
      if !*eraise and not atom w1 and
         (x := get(car w1, 'prifn)) and
         get(x, 'expt) = 'inbrackets then
% Special treatment here to avoid muddle between exponents and
% raised indices
            w1 := layout!-formula(w1, 0, 'inbrackets)
% Very special treatment for things that will be displayed with
% subscripts
       else if x = 'indexprin and not (indexpower(w1, w2)='failed)
         then return nil
       else w1 := layout!-formula(w1, q, nil);
      if null w1 then return 'failed;
      begin scalar !*ratpri;
% I do not display fractions with fraction bars in exponent
% expressions, since it usually seems excessive. Also (-p)/q gets
% turned into -(p/q) for printing here
         if eqcar(w2,'quotient) and eqcar(cadr w2,'minus)
          then w2 := list('minus,list(car w2,cadadr w2,caddr w2))
          else w2 := negnumberchk w2;
         w2 := layout!-formula(w2, if !*eraise then 0 else q, nil)
      end;
      if null w2 then return 'failed;
      l := cdar w1 + cdar w2;
      if pp then l := l + 2;
      if l > linelength nil - spare!* - orig!* then return 'failed;
      if l > linelength nil - spare!* - posn!* then terpri!* t;
      if pp then prin2!* "(";
      putpline w1;
      if !*eraise then l := 1 - cadr w2
       else << oprin 'expt; l := 0 >>;
      putpline ((update!-pline(0, l, caar w2) . cdar w2) .
                ((cadr w2 + l) . (cddr w2 + l)));
      if pp then prin2!* ")"
   end;

put('expt,'pprifn,'exptpri);

symbolic procedure inprint(op,p,l);
   begin scalar x,y,z;
        if op='times and !*nat and null !*asterisk then
        <>;
        if op eq 'plus and !*revpri then l := reverse l;
            % print sum arguments in reverse order.
        if not get(op,'alt) then <<
        if op eq 'not then oprin op else
          if op eq 'setq and not atom (x := car reverse l)
             and idp car x and (y := getrtype x)
             and (y := get(get(y,'tag),'setprifn))
            then return apply2(y,car l,x);
          if null atom car l and idp caar l
              and !*nat and
              ((x := get(caar l,'prifn)) or (x := get(caar l,'pprifn)))
              and (get(x,op) eq 'inbrackets)
            % to avoid mix up of indices and exponents.
            then<>
           else if !*nosplit and not testing!-width!* then
                prinfit(car l, p, nil)
           else maprint(car l, p);
          l := cdr l >>;
        if !*nosplit and not testing!-width!* then
% The code here goes to a certain amount of trouble to try to arrange
% that terms are never split across lines. This will slow
% printing down a bit, but I hope the improvement in formatting will
% be worth that.
              for each v in l do
               if atom v or not(op eq get(car v,'alt))
                then <<
% It seems to me that it looks nicer to put +, - etc on the second
% line, but := and comma usually look better on the first one when I
% need to split things.
                   if op memq '(setq !*comma!*) then <<
                      oprin op;
                      prinfit(negnumberchk v, p, nil) >>
                    else prinfit(negnumberchk v, p, op) >>
                else prinfit(v, p, nil)
         else for each v in l do <<
               if atom v or not(op eq get(car v,'alt))
                then <>
              % difficult problem of negative numbers needing to be in
              % prefix form for pattern matching.
               else maprint(v,p) >>
   end;

symbolic procedure flatsizec u;
   if null u then 0
    else if atom u then lengthc u
    else flatsizec car u + flatsizec cdr u + 1;

symbolic procedure oprin op;
   (lambda x;
         if null x then <>
          else if !*fort then prin2!* x
          else if !*list and obrkp!* and op memq '(plus minus)
           then if testing!-width!* then overflowed!* := t
                 else <>
          else if flagp(op,'spaced)
           then <>
          else prin2!* x)
   get(op,'prtch);

symbolic procedure prin2!* u;
    if outputhandler!* then apply2(outputhandler!*,'prin2!*,u)
     else begin integer m,n,p; scalar x;
      if x := get(u,'oldnam) then u := x;
      if overflowed!* then return 'overflowed
      else if !*fort then return fprin2!* u
      else if !*nat then <<
        if u = 'pi then u := symbol '!.pi
         else if u = 'infinity then u := symbol 'infinity>>;
      n := lengthc u;
      % Suggested by Wolfram Koepf:
      if fixp u and n>50 and !*rounded then return rd!:prin i2rd!* u;
      m := posn!* #+ n;
      p := linelength nil - spare!*;
      return if m<=p
                or (not testing!-width!*
       % The next line controls whether to add a newline before a long id.
       % At present it causes one in front of a number too.
                   and <>)
               then add_prin_char(u,m)
             % Identifier longer than one line.
              else if testing!-width!*
               then <>
              else prin2lint(u,posn!* #+ 1,p #- 1)
   end;

symbolic procedure add_prin_char(u,n);
   if null !*nat then if stringp u or get(u,'switch!*) or digit u
                        or get(car explode2 u,'switch!*) then prin2 u
                       else prin1 u
    else <>;

symbolic procedure prin2lint(u,m,n);
   begin scalar v,bool;
      % bool prevents an initial backslash.
      v := explode2 u;
      if null !*nat then <>;
   a: if not(m#>;
      bool := t; add_prin_char(car v,m);
      v := cdr v; m := m #+ 1;
      go to a;
   b: if null v then return(posn!* := m #- 1)
       else if bool then add_prin_char("\",m);
   c: if !*nat then terpri!* nil else <>;
      m := posn!* #+ 1;
      go to a
  end;

symbolic procedure terpri!* u;
   begin integer n;
        if outputhandler!* then return apply2(outputhandler!*,'terpri,u)
         else if testing!-width!* then return overflowed!* := t
         else if !*fort then return fterpri(u)
         else if !*nat and pline!*
          then <<
           pline!* := reverse pline!*;
           for n := ymax!* step -1 until ymin!* do <<
             scprint(pline!*,n);
             terpri() >>;
           pline!* := nil >>;
        if u then terpri();
        posn!* := orig!*;
        ycoord!* := ymax!* := ymin!* := 0
   end;

symbolic procedure scprint(u,n);
   begin scalar m;
        posn!* := 0;
        for each v in u do <<
           if cdar v=n then <<
             if not((m:= caaar v-posn!*)<0) then spaces m;
             prin2 cdr v;
             posn!* := cdaar v >> >>
   end;


% Formatted printing of expressions.

% This one should be eliminated.

symbolic procedure writepri(u,v); assgnpri(eval u,nil,v);

symbolic procedure exppri(u,v); assgnpri(u,nil,v);

symbolic procedure assgnpri(u,v,w);
   begin scalar x;
   % U is expression being printed.
   % V is a list of expressions assigned to U.
   % W is an id that indicates if U is the first, only or last element
   %  in the current set (or NIL otherwise).
   % Returns NIL.
    testing!-width!* := overflowed!* := nil;
    if null u then u := 0;
    if !*nero and u=0 then return nil;
    % Special cases.  These tests need to be generalized.
    if !*TeX then return texpri(u,v,w)
     else if getd 'vecp and vecp u then return vecpri(u,'mat);
    if (x := getrtype u) and flagp(x,'sprifn) and null outputhandler!*
      then <>;
    if w memq '(first only) then terpri!* t;
    v := evalvars v;
    if !*fort then <>;
    maprin if v then 'setq . aconc(v,u) else u;
    if null w or w eq 'first then return nil
     else if not !*nat then prin2!* "$";
    terpri!*(not !*nat);
    return nil
   end;

symbolic procedure evalvars u;
   % Used only in ASSGNPRI. We may need to expand the second test.
   % At the moment, it catches things like x-y:=0.
   if null u then nil
    else if atom car u or flagp(caar u,'intfn)
     then car u . evalvars cdr u
    else if get(get(caar u,'rtype),'setelemfn)
     then (caar u . revlis_without_mode cdar u) . evalvars cdr u
    else (caar u . revlis cdar u) . evalvars cdr u;

symbolic procedure revlis_without_mode u;
   for each j in u collect (reval j where dmode!* := nil);


% Definition of some symbols and their access function.

symbolic procedure symbol s;
   get(s,'symbol!-character);

put('!.pi, 'symbol!-character, 'pi);
put('bar, 'symbol!-character, '!-);
put('int!-top, 'symbol!-character, '!/);
put('int!-mid, 'symbol!-character, '!|);
put('int!-low, 'symbol!-character, '!/);
put('d, 'symbol!-character, '!d);       % This MUST be lower case
%%put('sqrt, 'symbol!-character, 'sqrt);% No useful fallback here
put('vbar, 'symbol!-character, '!|);
put('sum!-top, 'symbol!-character, "---");
put('sum!-mid, 'symbol!-character, ">  ");
put('sum!-low, 'symbol!-character, "---");
put('prod!-top, 'symbol!-character, "---");
put('prod!-mid, 'symbol!-character, "| |");
put('prod!-low, 'symbol!-character, "| |");
put('infinity, 'symbol!-character, 'infinity);
    % In effect nothing special

put('mat!-top!-l, 'symbol!-character, '![);
put('mat!-top!-r, 'symbol!-character, '!]);
put('mat!-mid!-l, 'symbol!-character, '![);
put('mat!-mid!-r, 'symbol!-character, '!]);
put('mat!-low!-l, 'symbol!-character, '![);
put('mat!-low!-r, 'symbol!-character, '!]);


% The following definitions allow for more natural printing of
% conditional expressions within rule lists.

bool!-functions!* :=
  for each x in {'equal,'greaterp,'lessp,'geq,'leq,'neq,'numberp}
      collect get(x,'boolfn) . x;

symbolic procedure condpri(u,p);
   <0 then prin2!* "(";
     while (u := cdr u) do
        <>;
          maprin cadar u;
          if cdr u then <>>>;
     if p>0 then prin2!* ")">>;

put('cond,'pprifn,'condpri);

symbolic procedure revalpri u;
   maprin eval cadr u;

put('aeval,'prifn,'revalpri);

put('reval,'prifn,'revalpri);

symbolic procedure boolvalpri u;
   maprin cadr u;

put('boolvalue!*,'prifn,'boolvalpri);

put('prog,'prifn,'progpri);

put('progn,'prifn,'progpri);

symbolic procedure progpri u;
   (rprint u) where rprifn!* = 'prin2!*,
       rterfn!* = function(lambda();terpri!* nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/mintro.red0000644000175000017500000001054511526203062024010 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

comment
I have put in support for the things that the Twente brigade had, and
indeed when used with care they have jolly good effects on readability.
I have also tinkered with what I had before quite a bit both to clean up
the code in a few places but mostly to fix the odd bug or so. I am
beginning to be quite cheerful about what it now looks like & so am
sending you this copy to play with. The main thing I do not know how
to decide is the default setting of !*nosplit which slows things down
(by doing much more look-ahead during printing) but can sometimes
improve the selection of points to split lines. I suspect very strongly
that behaviour where things are really too bit to split will always be
ugly - if you spot any particular disaster areas and can think of
good fixups....
Here it is, then: given I have the matrix printing & the dfprint option
in too I think this is tolerably compact.


    EXTRA FEATURES OF THE CLISP VERSION

By default use is made of some programmable characters so that integrals,
fractions and square roots are displayed neatly when 'on nat' is selected.
This use of special characters can be disabled by setting
        off clisp
which can be needed if the output from Reduce is to be sent to a printer
that can not handle the special characters. The function
        lisp spool ""
automatically switches off the clisp flag for this reason, so that the
transcript file only contains ordinary characters.

When they will fit matrices are displayed spread out on the page.
The forms sum(low,high,body), product(low,high,body) are displayed
as formal sums and products (but are not otherwise special at
all), as in
        sum(k=0,infinity,a(k)*x^k/fact k)
where fact now evaluates as the factorial (for positive integer
arguments, and infinity displays as an infinity sign (but does
not have any other special properties). The variable pi displays
as a greek pi character.

A set of facilities suggested by the Algebra group at Twente have been
included - these cause formal derivatives to be displayed as subscript
expressions, and allow other operators to show their arguments as
subscripts. After
        on dfprint
a derivative df(y(a,b),a) will be displayed as y with a suffix a,
and df(y(a,b),a,2,b) will display as
         y
          2a,b
After
         doindex p,q,r
all arguments of the operators p, q and r will be displayed as
subscripts. This effect can be undone by using
         offindex p,q,r
A related declaration
         donoarg p,q
causes all arguments in references to the operators p and q to
be hidden, and offnoargs p,q will cancel the effect. If arguments
have been supressed in this way the statement
        farg
will show what has been hidden.
        clfarg
will reset the record of information about hidden arguments.

A flag called nosplit (which is by default on) causes the Reduce
print code to try harder than has previously been the case to
avoid splitting terms across lines of output. having this switch
enabled slows down printing somewhat, and if this becomes
inconvenient the previous arrangements can be (approximately)
restored by
        off nosplit

;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/mathpr.red0000644000175000017500000000302311526203062023764 0ustar  giovannigiovannimodule mathpr;  % Header module for mathpr package.

% Author: Anthony C. Hearn.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(mathpr mprint sqprint ratprin dfprin % prend specprin
                  fortpri),
                nil);

flag('(mathpr),'core_package);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/ratprin.red0000644000175000017500000001331011526203062024150 0ustar  giovannigiovannimodule ratprin;   % Printing standard quotients.

% Author: Eberhard Schruefer.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Modifications by: Anthony C. Hearn & A. C. Norman.

fluid  '(!*fort
         !*list
         !*mcd
         !*nat
         !*ratpri
         dmode!*
         ycoord!*
         ymin!*
         ymax!*
         orig!*
         pline!*
         posn!*
         p!*!*);

global '(spare!*);

switch ratpri;

!*ratpri := t;   % default value if this module is loaded.

put('quotient,'prifn,'quotpri);
put('quotpri, 'expt, 'inbrackets);

symbolic procedure quotpri u;
   % *mcd is included here since it uses rational domain elements.
   begin scalar dmode;
      if null !*ratpri or null !*nat or !*fort or !*list or null !*mcd
           then return 'failed
       else if flagp(dmode!*,'ratmode)
        then <>;
      u := ratfunpri1 u;
      if dmode then dmode!* := dmode;
      return u
   end;

symbolic procedure ratfunpri1 u;
   begin scalar x,y,ch,pln,pld;
         integer heightnum,heightden,orgnum,orgden,fl,w;
     spare!* := spare!* + 2;
     if (pln := layout!-formula(cadr u, 0, nil)) and
        (pld := layout!-formula(caddr u, 0, nil)) then <<
         spare!* := spare!* - 2;
         fl := 2 + max(cdar pln, cdar pld);
         if fl>(linelength nil - spare!* - posn!*) then terpri!* t;
         w := (cdar pln - cdar pld);   % Width difference num vs. den
         if w > 0 then << orgnum := 0; orgden := w / 2 >>
          else << orgnum := (-w) / 2; orgden := 0 >>;
         heightnum := cddr pln - cadr pln + 1;
         heightden := cddr pld - cadr pld + 1;
         pline!* :=
            append(
               update!-pline(orgnum + posn!* + 1 - orig!*,
                             1 - cadr pln + ycoord!*,
                             caar pln),
               append(update!-pline(orgden + posn!* + 1 - orig!*,
                                    ycoord!* - cddr pld - 1,
                                    caar pld),
                      pline!*));
         ymin!* := min(ymin!*, ycoord!* - heightden);
         ymax!* := max(ymax!*, ycoord!* + heightnum);
         ch := symbol 'bar;
         for j := 1:fl do prin2!* ch >>
      else <<
         % Here the miserable thing will not fit on one line
         spare!* := spare!* - 2;    % Restore
         u :=  cdr u;
         x := get('quotient,'infix);
         if p!*!* then y := p!*!*>x else y := nil;
         if y then prin2!* "(";
         maprint(car u,x);
         oprin 'quotient;
         maprint(negnumberchk cadr u,x);
         if y then prin2!* ")">>
    end;

symbolic procedure layout!-formula(u, p, op);
% This procedure forms a pline!* structure for an expression that
% will fit upon a single line. It returns the pline* together with
% height, depth and width information. If the line would not fit
% it returns nil. Note funny treatment of orig!* and width here.
% If op is non-nil oprin it too - if it is 'inbrackets do that.
   begin
      scalar ycoord!*, ymin!*, ymax!*, posn!*, pline!*,
             testing!-width!*, overflowed!*;
      pline!* := overflowed!* := nil;
      ycoord!* := ymin!* := ymax!* := 0;
      posn!* := orig!*;
      testing!-width!* := t;
      if op then <<
         if op = 'inbrackets then prin2!* "("
          else oprin op >>;
      maprint(u, p);
      if op = 'inbrackets then prin2!* ")";
      if overflowed!* then return nil
       else return (pline!* . (posn!* - orig!*)) . (ymin!* . ymax!*)
   end;

symbolic procedure update!-pline(x,y,pline);
   % Adjusts origin of expression in pline by (x,y).
   if x=0 and y=0 then pline
    else for each j in pline collect
            (((caaar j #+ x) . (cdaar j #+ x)) . (cdar j #+ y)) . cdr j;

symbolic procedure prinfit(u, p, op);
% Display u (as with maprint) with op in front of it, but starting
% a new line before it if there would be overflow otherwise.
   begin
      scalar w;
      if not !*nat or testing!-width!* then <<
         if op then oprin op;
         return maprint(u, p) >>;
      w := layout!-formula(u, p, op);
      if w = nil then <<
         if op then oprin op;
         return maprint(u, p) >>;
      putpline w
   end;

symbolic procedure putpline w;
   begin
      if posn!* #+ cdar w > linelength nil #- spare!* then terpri!* t;
      pline!* :=
         append(update!-pline(posn!* #- orig!*, ycoord!*, caar w),
                pline!*);
      posn!* := posn!* #+ cdar w;
      ymin!* := min(ymin!*, cadr w #+ ycoord!*);
      ymax!* := max(ymax!*, cddr w #+ ycoord!*)
  end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathpr/specprin.red0000644000175000017500000001303111526203062024314 0ustar  giovannigiovannimodule specprin;   % Printing other special forms.

% Author: A. C. Norman.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid  '(!*fort
         !*nat
         ycoord!*
         ymin!*
         ymax!*
         posn!*
         orig!*
         pline!*);

global '(spare!*);

symbolic procedure intprint u;
   if not !*nat or !*fort then 'failed
   else begin
      scalar m;
      prin2!* symbol 'int!-mid;
      m := posn!* - 1;
      pline!* := (((m . posn!*) . (ycoord!* + 1)) .
                      symbol 'int!-top) . pline!*;
      pline!* := (((m . posn!*) . (ycoord!* - 1)) .
                      symbol 'int!-low) . pline!*;
      if ycoord!*+1>ymax!* then ymax!* := ycoord!*+1;
      if ymin!*>ycoord!*-1 then ymin!* := ycoord!*-1;
      maprin cadr u;
      prin2!* " ";
      prin2!* symbol 'd;
      maprin caddr u
   end;

put('int, 'prifn, 'intprint);

symbolic procedure sqrtprint u;
   if not !*nat or !*fort then 'failed
   else begin
      scalar m;
      m := symbol 'sqrt;
% The square-root sign may not be available as a symbol - if it is
% not then I will not do anything special here
      if m=nil then return 'failed;
      prin2!* m;
      u := cadr u;
      if not atom u or (numberp u and u < 0) then <<
          prin2!* "(";
          m := t >>
       else m := nil;
      maprin u;
      if m then prin2!* ")"
   end;

put('sqrt, 'prifn, 'sqrtprint);

symbolic procedure sumprint(u,p);
   sppri(u, p, symbol 'sum!-top, symbol 'sum!-mid, symbol 'sum!-low);

symbolic procedure prodprint(u,p);
   sppri(u, p, symbol 'prod!-top, symbol 'prod!-mid, symbol 'prod!-low);

symbolic procedure sppri(u, p, top, mid, low);
   if not !*nat or !*fort then 'failed
   else begin
      scalar w1,w2,w3,o1,o2,o3,m,ll,bkt;
      if null (u := cdr u) then return 'failed;
      w2 := car u;          % low limit
      if null (u := cdr u) then <<
          u := w2;          % Only a body - no limits
          w2 := nil >>
      else <<
          w1 := car u;      % high limit
          if null (u := cdr u) then <<
              u := w1;      % no high limit
              w1 := nil >>
          else u := car u >>;
      ll := linelength nil - spare!*;
      spare!* := spare!* + ll/2;
      if w1 then <<
          if null (w1 := layout!-formula(w1, 0, nil)) then <<
             spare!* := spare!* - ll/2;
             return 'failed >> >>
      else w1 := (nil . 0) . (0 . -1);
      if w2 then <<
          if null (w2 := layout!-formula(w2, 0, nil)) then <<
             spare!* := spare!* - ll/2;
             return 'failed >> >>
      else w2 := (nil . 0) . (0 . -1);
      spare!* := spare!* - ll/2;
      m := 0 . 3;
      w3 := list(((m . 1) . top),
                 ((m . 0) . mid),
                 ((m . -1) . low));  % Pline structure for big symbol;
      m := max(cdar w1, cdar w2, 3);
% Here I decide if the entire sum needs to be put in parens. I am
% not at present certain that I have this test just the way it
% ought to be, but at least this is an approximation.
      bkt := p >= get('plus, 'infix);
      if bkt then m := m + 1;
      if posn!* + m > ll then terpri!* t;
      if bkt then prin2!* "(";
      o1 := (m - cdar w1)/2 + posn!* - orig!*;
      o2 := (m - cdar w2)/2 + posn!* - orig!*;
      o3 := (m - 3)/2 + posn!*;
      pline!* := append(
         update!-pline(o3, ycoord!*, w3),
         append(update!-pline(o1, ycoord!* + 2 - cadr w1, caar w1),
                append(update!-pline(o2, ycoord!* - 2 - cddr w2,
                                     caar w2), pline!*)));
      ymax!* := max(ymax!*, ycoord!* + 2 + cddr w1 - cadr w2);
      ymin!* := min(ymin!*, ycoord!* - 2 - cddr w2 + cadr w2);
      posn!* := posn!* + m;
      maprint(u, get('minus, 'infix));
      if bkt then prin2!* ")"
   end;

put('sum, 'pprifn, 'sumprint);
put('product, 'pprifn, 'prodprint);

put('sumprint, 'expt, 'inbrackets);
put('prodprint, 'expt, 'inbrackets);

symbolic procedure factpri u;
   if not !*nat or !*fort then 'failed
   else <<
      maprint(cadr u, 100);
      prin2!* "!" >>;

put('fact, 'prifn, 'factpri);

algebraic;

% sum(low-limit, high-limit, body)
% product(low-limit, high-limit, body);
%
% degenerate cases display as if
% sum(low-limit, body)
% sum(body)

% fact n     factorial function


operator fact, sum, product;

for all n such that numberp n and fixp n and n >= 0
   let fact n = for i := 1:n product i;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/0000755000175000017500000000000011722677364021334 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpsrev.red0000644000175000017500000002231311526203062023332 0ustar  giovannigiovannimodule tpsrev; % Power Series Reversion & Composition

% Author: Alan Barnes   November 1988
%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% If y is a power series in x then psreverse expresses x as a power
% series in y-y0 where y0 is zero order term of y.
% This is known as power series reversion (functional inverse)
% pscompose functionally composes two power series
%
%Two new prefix operators are introduced PSREV and PSCOMP.
%These appear in the expression part of the power series objects
%generated by calls to psreverse and pscompose respectively.
%The  argument of PSREV is the 'generating  series' of the
%series (PS1 say) to be inverted. This is a generalised power series
%object  which looks like a standard power series object except that
%each of its terms is itself a power series (rather than a standard
%quotient), the  nth term being the power series of the nth power of
%PS1. The expression part of the generating series is (PSGEN ).
%
%When power series PS1 and PS2 are composed (i.e. PS2 is substituted
%for the expansion variable of PS1 and the result expressed as a power
%series in the expansion variable of PS2), the expression part of
%the power series object generated is
%              (PSCOMP  )
%The generating series should only appear inside the operators PSREV
%and PSCOMP and not at 'top level'. It cannot sensibly be printed with
%the power series print function. Special functions are needed to
%access and modify terms of the generating series, although these
%are simply defined in terms of the functions for manipulating
%standard power series objects.
%% The algorithms used are based on those described in
%Feldmar E & Kolbig K S, Computer Physics Commun.  39, 267-284 (1986).

fluid '(ps);

put('psreverse, 'simpfn, 'simppsrev);

symbolic procedure simppsrev a;
 if length a=1 then apply('simppsrev1,a)
 else rerror(tps,33,"Wrong number of arguments to PSREVERSE");

symbolic procedure simppsrev1(series);
 begin scalar rev,psord, depvar,about, knownps, ps!:level;
   ps!:level:=0;
   series:=prepsqxx simp!* series;
   if not ps!:p series then
      rerror(tps,34,
           "Argument should be a : simppsrev");
   ps!:find!-order series;
   depvar:=ps!:depvar series;
   if (psord:=ps!:order series)=1 then
        about:=0
    else if (psord=0) and (ps!:evaluate(series,1) neq (nil ./ 1)) then
        about := prepsqxx ps!:get!-term(series,0)
    else if psord =-1 then about:='ps!:inf
    else rerror(tps,35,"Series cannot be inverted:  simppsrev");
   rev:=ps!:compile(list('psrev,series),depvar,about);
   if ps!:expansion!-point series = 'ps!:inf then <<
      rev := make!-ps(list('quotient,1,rev),
                      ps!:value rev,depvar,about);
      ps!:find!-order rev>>;
   return rev ./ 1;
 end;

symbolic procedure ps!:generating!-series(a,psord,inverted);
 begin scalar ps;
   ps:=make!-ps(list('psgen, a,inverted),ps!:value a,
                      ps!:depvar a, ps!:expansion!-point a);
   ps!:set!-order(ps,psord);
   ps!:set!-rthpow(ps,psord);
   return ps
 end;

symbolic smacro procedure ps!:get!-rthpow(genseries,r);
  ps!:get!-term(genseries,r);

symbolic procedure ps!:set!-rthpow(genseries,r);
 begin scalar rthpow, series, power;
    series:=ps!:expression genseries;
    power:= if rand2 series then -r else r;
    series:=rand1 series;
    if power = 0 then
       rthpow := 1
    else if power=1 then
       rthpow := series
    else <<
      if power = -1 then
          rthpow := list('quotient, 1, series)
      else if power = 2 then
          rthpow := list('times, series, series)
      else
          rthpow := list('expt, series, power, 1);
      power := if rator rthpow = 'expt then
                    list('expt, series, power)
               else rthpow;
      rthpow := make!-ps(rthpow, ps!:arg!-values power,
                         ps!:depvar series,ps!:expansion!-point series);
      ps!:find!-order rthpow >>;
    ps!:set!-term(genseries,r,rthpow);
    return rthpow
 end;

symbolic procedure ps!:term!-rthpow(genseries,r,n);
 begin scalar term,series;
  series:= ps!:get!-rthpow(genseries,r);
  if null series then
     for i:=ps!:last!-term genseries +1:r do
        series:=ps!:set!-rthpow(genseries,i);
  term:=  ps!:evaluate(series,n);
  return term
 end;

put('psrev,'ps!:crule,'ps!:rev!-crule);

symbolic procedure ps!:rev!-crule(a,d,n);
  begin scalar series;
    series :=rand1 a;
    if (n neq 'ps!:inf) and (n neq 0) then
       series := ps!:remove!-constant series;
    series := make!-ps(list('psrev,
                       ps!:generating!-series(series,1,
                                              if n='ps!:inf then t
                                              else nil)),
                       list('psrev,ps!:value rand1 a, d, n),d,n);
    ps!:find!-order series;
    return series;
  end;

symbolic procedure ps!:remove!-constant(ps);
 ps!:compile(list('difference, ps,prepsqxx ps!:evaluate(ps,0)),
             ps!:depvar ps,
             ps!:expansion!-point ps);

put('psrev,'ps!:erule,'ps!:rev!-erule);
put('psrev,'ps!:order!-fn,'ps!:rev!-orderfn);


symbolic procedure ps!:rev!-orderfn ps;
   begin scalar u;
     u:=ps!:expansion!-point ps!:get!-rthpow(rand1 ps!:expression ps,1);
     return if (u=0) or (u = 'ps!:inf) then 1
            else 0
   end;


symbolic procedure ps!:rev!-erule(a,n);
 begin scalar genseries,x,z;
  z:=nil ./ 1; genseries:=rand1 a;
  if n=0 then
    if (x:=ps!:expansion!-point ps!:get!-rthpow(genseries,1))='ps!:inf
     then return (nil ./ 1)
     else return simp!* x;
  if n=1 then
      return invsq ps!:term!-rthpow(genseries,1,1);
  for i:=1:n-1 do
        z:=addsq(z,multsq(ps!:evaluate(ps,i),
                          ps!:term!-rthpow(genseries,i,n)));
  return quotsq(negsq z,ps!:term!-rthpow(genseries,n,n))
 end;

put('pscomp,'ps!:crule,'ps!:comp!-crule);
put('pscomp,'ps!:erule,'ps!:comp!-erule);
put('pscomp,'ps!:order!-fn,'ps!:comp!-orderfn);

symbolic procedure ps!:comp!-orderfn ps;
 begin scalar u;
   u:=ps!:find!-order rand1 ps!:expression ps;
   return
     if u=0 then 0
     else
       ps!:find!-order(ps!:get!-rthpow(rand2 ps!:expression ps,u));
 end;


symbolic procedure ps!:comp!-crule(a,d,n);
  begin scalar series1,series2,n1;
     series1:=rand1 a; series2:=rand2 a;
     n1 := ps!:expansion!-point series1;
     if (n1 neq 0) and (n1 neq 'ps!:inf) then
        series2:=ps!:remove!-constant series2;
     a:= make!-ps(list('pscomp,series1,
                       ps!:generating!-series(series2,
                                              ps!:order series1,
                                              if n1='ps!:inf then t
                                              else nil)),
                  append(ps!:arg!-values a, list(d,n)), d, n);
    ps!:find!-order a;
    return a;
  end;

symbolic procedure ps!:comp!-erule(a,n);
 begin scalar aa,genseries,z,psord1;
  z:=nil ./ 1; aa:=rand1 a; genseries:=rand2 a;
  psord1:=ps!:order aa;
  for i:=psord1:n do
        z:=addsq(z,multsq(ps!:evaluate(aa,i),
                          ps!:term!-rthpow(genseries,i,n)));
   return z
 end;


put('pscompose, 'simpfn, 'simppscomp);

symbolic procedure simppscomp a;
  if length a=2 then  apply('simppscomp1,a)
   else rerror(tps,36,
     "Args should be ,:  simppscomp");

symbolic procedure simppscomp1(ps1,ps2);
  begin scalar x,d,n1,n, knownps, ps!:level;
    ps!:level:=0;
    ps1:=prepsqxx simp!* ps1;
    if ps!:numberp ps1 then
      return ((if zerop ps1 then nil else ps1) ./ 1);
    if not ps!:p ps1 or not ps!:p(ps2:=prepsqxx simp!* ps2) then
      rerror(tps,37,
      "Args should be ,:  simppscomp");
    ps!:find!-order ps1;
    x:=ps!:find!-order ps2;
    d:= ps!:depvar ps2;
    n1:= ps!:expansion!-point ps1;
    n:= ps!:expansion!-point ps2;
    if (x >0 and n1 = 0) or
       (x <0 and n1 = 'ps!:inf) or
       (x=0 and n1=prepsqxx ps!:evaluate(ps2,0))
     then  return ps!:compile(list('pscomp,ps1,ps2),d,n) ./ 1
     else rerror(tps,38,"Series cannot be composed:  simppscomp");
 end;

algebraic operator psrev,pscomp;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tps.red0000644000175000017500000003205311526203062022617 0ustar  giovannigiovannimodule tps; % Extendible Power Series.

% Author: Alan Barnes .
% Version 1.54 January 1996.
%
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



% A power series object is a tagged tuple of the following form:
%
% (:ps: . [,
%          ,
%          ,
%          ,
%          ,
%          ,
%          ])
%
%  is the exponent of the first term of the series and is also
%          used to modify the index when accessing components of the
%          series which are addressed by power
%
%  the power of the last term generated in the series so far
%             used in evaluator when computing new terms
%
%  is the dependent variable of this expansion, needed, in
%          particular, for printing and when combining two series
%
%  is self-explanatory except that
%          ps!:inf denotes expansion about infinity
%
%   is the originating prefix form which is needed to allow for
%          power series variables appearing inside other power series
%          expressions
%
%   is an alist containing the terms of the series computed so
%          far, access is controlled using  as an index base.
%
%  is a power series object corresponding to the prefix
%          form of which the expansion was requested, the first element
%          of which is the ps!:operator and the rest of which are the
%          ps!:operands which may themselves be pso's
%
%  used to indicate whether power series object
%                       needs re-simplifying = sqvar
%
% In addition we have the following degenerate forms of power series
% object:
%        
%        (!:ps!: . )  the value of  is a vector
%        as above(used in automatically generated recurrence relations)
%           2nd argument of DF, INT etc.
%
% The last two should never appear at top-level in any power series
% object


create!-package('(tps tpscomp tpseval tpsdom tpsfns tpsrev
                  tpssum tpsmisc tpsconv),
                '(contrib tps));

fluid '(ps!:exp!-lim  knownps ps!:level  ps!:max!-order);

% Some structure selectors and referencers.

symbolic smacro procedure rands e;
  cdr e;

symbolic smacro procedure rand1 e;
   cadr e;

symbolic smacro procedure rand2 e;
   caddr e;

symbolic smacro procedure rator e;
  car e;

symbolic smacro procedure ps!:domainp u;
   atom u or (car u neq '!:ps!:) and not listp u;

symbolic smacro procedure ps!:p u;
  pairp u and (car u = '!:ps!:);

symbolic smacro procedure ps!:atom u;
   atom u or (car u neq '!:ps!: and get(car u,'dname));

symbolic smacro procedure ps!:numberp u;
   numberp u or (pairp u and car u neq '!:ps!: and get(car u,'dname));

symbolic procedure constantpsp u;
     ps!:numberp u or ps!:expression u eq 'psconstant;

symbolic procedure ps!:getv(ps,i);
   if eqcar(ps,'!:ps!:) then
        if idp cdr ps then getv(eval cdr ps,i)
        else getv(cdr ps,i)
   else rerror(tps,1,list("PS:GETV: not a ps",ps));

symbolic procedure ps!:putv(ps,i,v);
     if eqcar(ps,'!:ps!:) then
        if idp cdr ps then putv(eval cdr ps,i,v)
        else putv(cdr ps,i,v)
     else rerror(tps,2,list("PS:PUTV: not a ps",ps));

symbolic procedure ps!:order ps;
   if ps!:atom ps then 0
   else ps!:getv(ps,0);

symbolic smacro procedure ps!:set!-order(ps,n);
   ps!:putv(ps,0,n);

symbolic procedure ps!:last!-term ps;
   if ps!:atom ps then ps!:max!-order
   else  ps!:getv(ps,1);

symbolic (ps!:max!-order:= 2147483647);
% symbolic here seems to be essential in Cambridge Lisp systems

symbolic smacro procedure ps!:set!-last!-term (ps,n);
   ps!:putv(ps,1,n);

symbolic procedure ps!:depvar ps;
   if ps!:atom ps then nil
   else ps!:getv(ps,2);

symbolic smacro procedure ps!:set!-depvar(ps,x);
   ps!:putv(ps,2,x);

symbolic procedure ps!:expansion!-point ps;
   if ps!:atom ps then nil
   else ps!:getv(ps,3);

symbolic smacro procedure ps!:set!-expansion!-point(ps,x);
   ps!:putv(ps,3,x);

symbolic procedure ps!:value ps;
   if ps!:atom ps then if ps then ps else 0
   else ps!:getv(ps,4);

symbolic smacro procedure ps!:set!-value(ps,x);
   ps!:putv(ps,4,x);

symbolic smacro procedure ps!:terms ps;
   if ps!:atom ps then list (0 . ( ps . 1))
   else ps!:getv(ps,5);

symbolic smacro procedure ps!:set!-terms(ps,x);
   ps!:putv(ps,5,x);

symbolic procedure ps!:expression ps;
   if ps!:atom ps then ps
   else ps!:getv(ps,6);

symbolic smacro procedure ps!:set!-expression(ps,x);
   ps!:putv(ps,6,x);

symbolic smacro procedure ps!:operator ps;
   car ps!:getv(ps,6);

symbolic smacro procedure ps!:operands ps;
   cdr ps!:getv(ps,6);

symbolic procedure ps!:get!-term(ps,i);
    (lambda(psorder, pslast);
       if ipslast then nil
       else begin scalar term;
               term:=assoc(i-psorder, ps!:terms ps);
               return if term then cdr term
                      else nil ./ 1;
            end)
    (ps!:order ps, ps!:last!-term ps);

symbolic procedure ps!:set!-term(ps,n,x);
% it is only safe to set terms of order >= order of series
% and order > last!-term of series, otherwise mathematical
% inconsistencies could arise.
% Value of last!-term now updated automatically by this procedure
begin scalar psorder, terms;
   psorder := ps!:order ps;
   if n < psorder then
      rerror(tps,3,list (n, "less than the order of ", ps))
   else if n <= ps!:last!-term ps then
      rerror(tps,4,list (n, "less than power of last term of ", ps));
   terms := ps!:terms ps;
   if atom x or (numr x neq nil) then
      % atom test is relevant only for ps!:generating!-series
      if terms then nconc(terms,list((n-psorder).x))
      else ps!:set!-terms(ps,list((n-psorder).x))
   else if n=psorder then
      ps!:set!-order(ps,n+1);
   ps!:set!-last!-term(ps,n);
end;

symbolic operator pstruncate;

symbolic procedure pstruncate(ps,n);
<< n := ieval n;
   ps := prepsqxx simp!* ps;
   if ps!:numberp ps then
       if n geq 0 then
         if atom ps then ps else apply1(get(car ps, 'prepfn), ps)
       else 0
   else if ps!:p ps then
      prep!:ps(ps, n)
   else typerr(ps, "power series:  truncate")
>>;

put('psexplim, 'simpfn, 'simppsexplim);

symbolic (ps!:exp!-lim := 6); % default depth of expansion
% symbolic here seems to be essential in Cambridge Lisp systems

symbolic procedure simppsexplim u;
 begin integer n;
    n:=ps!:exp!-lim;
    if u then ps!:exp!-lim := ieval carx(u,'psexplim);
    return (if n=0 then nil ./ 1 else n ./ 1);
 end;

symbolic procedure simpps a;
    if length a = 3 then apply('simpps1,a)
    else rerror(tps,5,
          "Args should be ,, and :  simpps");

put('ps,'simpfn,'simpps);

symbolic procedure simpps1(form,depvar,about);
  if form=nil then
     rerror(tps,6,"Args should be ,, and : simpps")
  else if not kernp simp!* depvar then
     typerr(depvar, "kernel:  simpps")
  else if  smember(depvar,(about:=prepsqxx simp!* about)) then
     rerror(tps,7,"Expansion point depends on depvar:  simpps")
  else
     begin scalar knownps, ps!:level;
        ps!:level := 0;
        return ps!:compile(ps!:presimp form, depvar,
                           if about='infinity then 'ps!:inf else about)
                    ./ 1
     end;

put('psterm,'simpfn,'simppsterm);

symbolic procedure simppsterm a;
  if length a=2 then apply('simppsterm1, a)
  else
     rerror(tps,8,
            "Args should be of form ,: simppsterm");

symbolic procedure simppsterm1(p,n);
 << n := ieval n;
    p := prepsqxx simp!* p;
    if ps!:numberp p then
       if n neq 0 or p=0 then nil ./ 1 else p ./ 1
    else if ps!:p p then
       << ps!:find!-order p; ps!:evaluate(p,n)>>
    else typerr(p, "power series:  simppsterm1")
 >>;

put('psorder,'simpfn,'simppsorder);
put('pssetorder,'simpfn,'simppssetorder);

symbolic procedure simppsorder u;
  << u := prepsqxx simp!* carx(u,'psorder);
     if ps!:numberp u then
        if u=0 then !*k2q 'undefined else nil ./ 1
     else if ps!:p u then
        !*n2f ps!:find!-order u ./ 1
     else typerr(u,"power series:  simppsorder")
  >>;

symbolic procedure simppssetorder u;
  (lambda (psord,ps);
    if not ps!:p ps then typerr(ps,"power series: simppssetorder")
    else if not fixp psord then
        typerr(psord, "integer: simppssetorder")
    else <>)
  (prepsqxx simp!* carx(cdr u,'pssetorder), prepsqxx simp!* car u);

put('psexpansionpt,'simpfn,'simppsexpansionpt);

symbolic procedure simppsexpansionpt u;
  << u:=prepsqxx simp!* carx(u,'psexpansionpt);
     if ps!:numberp u then !*k2q 'undefined
     else if ps!:p u then
        (lambda about;
                if about neq 'ps!:inf then
                   if about then simp!* about else !*k2q 'undefined
                else !*k2q 'infinity )
        (ps!:expansion!-point u)
     else typerr(u,"power series:  simppsexpansionpt")
  >>;

put('psdepvar,'simpfn,'simppsdepvar);

symbolic procedure simppsdepvar u;
  << u := prepsqxx simp!* carx(u,'psdepvar);
     if ps!:numberp u then !*k2q 'undefined
     else if ps!:p u then
            if (u:=ps!:depvar u) then !*k2q u else !*k2q 'undefined
     else typerr(u,"power series:  simppsdepvar")
  >>;

put('psfunction,'simpfn,'simppsfunction);

symbolic procedure simppsfunction u;
  << u := prepsqxx simp!* carx(u,'psfunction);
     if ps!:numberp u then u ./ 1
     else if ps!:p u then simp!* ps!:value u
     else typerr(u,"power series:  simppsfunction")
  >>;

symbolic procedure ps!:presimp form;
 if (pairp form) and
    ((rator form = 'expt) or (rator form = 'int)) then
        list(rator form, prepsort rand1 form, prepsort rand2 form)
 else prepsort form;

symbolic procedure prepsort u;
  % Improves log handling if logsort is defined.  S.L. Kameny.
  if getd 'logsort then logsort u else prepsqxx simp!* u;

symbolic procedure !*pre2dp u;
begin scalar x;
    u:=simp!* u;
    return  if fixp denr u then
               if denr u = 1 and domainp(x := numr u) then x
            else if fixp numr u then mkrn(numr u, denr u)
end;

flag('(!:ps!:),'full);

put('!:ps!:, 'simpfn, 'simp!:ps!:);

symbolic procedure simp!:ps!: ps;
      simp!:ps1 ps ./ 1;

symbolic procedure simp!:ps1 ps;
 if atom ps or car ps neq '!:ps!: or idp cdr ps then ps
 else if car getv(cdr ps,7) and null !*resimp then ps
 else
    begin scalar terms, simpfn, ex;
      ex := ps!:expression ps;
      if (pairp ex and rator ex ='psgen) then
           simpfn:= 'simp!:ps1
      else simpfn:= 'resimp;
      terms:=ps!:terms ps;
      % next operation depends on fact that terms are stored in an
      % association list
      ps!:set!-terms(ps,
                     foreach term in terms
                       collect (car term . apply1(simpfn, cdr term)));
      if atom ex or rator ex = 'ps!:summation then nil
      else<>;
      putv(cdr ps,7,!*sqvar!*);
      return ps
    end;

put('pschangevar,'simpfn,'simppschangevar);

symbolic procedure simppschangevar u;
  (lambda (newvar, ps, oldvar);
     if not ps!:p ps then
        typerr(ps,"power series: simppschangevar")
     else if not kernp newvar then
        typerr(prepsqxx newvar, "kernel: simppschangevar")
     else
        <>
          else rerror(tps,10,"Can't change variable of constant series")
        >>)
   (simp!* carx(cdr u,'pschangevar), prepsqxx simp!* car u,nil);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpsmisc.red0000644000175000017500000001004511526203062023470 0ustar  giovannigiovannimodule tpsmisc;
% Miscellaneous Support Functions added August 1993
% Author: Alan Barnes .

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(gensym!-list);

% build a new copy of a power-series structure with no shared elements

symbolic procedure ps!:copy(ps);
begin scalar gensym!-list, new;
  new := ps!:copy1 ps;
  if gensym!-list then fix!-up!-links(ps,new);
  return new;
end;

symbolic procedure ps!:copy1 ps;
  if ps!:atom ps or car ps neq '!:ps!: then ps
  else begin scalar new, old, newexp;
     old := cdr ps;
     if idp old then <<
       new :=  gensym();
       gensym!-list := (eval old . new) . gensym!-list;
       return car ps . new >>;
     new := mkvect 7;
     for i := 0:7 do putv(new, i, getv(old, i));
     old := ps!:expression ps;
     new := car ps . new;
     if listp old then <<
       newexp := rator old . foreach arg in rands old collect
                                                       ps!:copy1 arg;
       ps!:set!-expression(new, newexp);
       if rator old = 'psgen then <<
          % terms are shared power series so need to be copied
          newexp := ps!:replace(rand1 old, rand1 newexp, ps!:terms ps);
          ps!:set!-terms(new, newexp)
       >>
     >>;
     return new;
   end;

symbolic procedure ps!:replace(p,q,terms);
   foreach term in terms collect (car term . ps!:copy2(cdr term,p,q));

symbolic procedure ps!:copy2(ps, p, q);
% copy series ps. If structure p is shared in ps,
% then q is shared in the copy
% this rigmarole avoids recomputation of terms of base series in PSGEN

  if ps!:atom ps or car ps neq '!:ps!: then ps
  else if ps = p then q
  else
   begin scalar new, old, newexp;
     old := cdr ps;     % this is always a vector (I hope!!)
     new := mkvect 7;
     for i := 0:7 do putv(new, i, getv(old, i));
     old := ps!:expression ps;
     new := car ps . new;
     if listp old then <<
       newexp := rator old . foreach arg in rands old collect
                                    ps!:copy2(arg,p,q);
       ps!:set!-expression(new, newexp);
     >>;
     return new;
   end;


symbolic procedure fix!-up!-links(p,q);
    if ps!:atom p or car p neq '!:ps!: then nil
    else
      begin scalar x, args1, args2;
        if (x :=assoc(cdr p,gensym!-list)) then set(cdr x, cdr q);
        if not idp cdr p then <<
          x := ps!:expression p;
          if listp x then <<
             args1 := cdr x;
             args2 := cdr ps!:expression q;
             while args1 do <<
               fix!-up!-links(car args1, car args2);
               args1 :=cdr args1; args2 := cdr args2
             >>
          >>
        >>;
      end;

put('pscopy,'simpfn,'simppscopy);

symbolic procedure simppscopy u;
  << u:=prepsqxx simp!* carx(u,'pscopy);
     if ps!:p u then simp!* ps!:copy u
     else typerr(u,"power series:  simppscopy")
  >>;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpscomp.red0000644000175000017500000004077311526203062023506 0ustar  giovannigiovannimodule tpscomp; % Compile prefix expression into network of
                % communicating power series.

% Authors: Julian Padget & Alan Barnes

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The compiler is rule driven by looking for a compilation rule (crule)
% property on the property list of the operator.  If a rule does not
% exist the expression is differentiated to get an expression which is
% amenable to compilation but the process takes care to check for the
% existence of cycles in the derivatives e.g. sine and cosine.
%
% The result is an power series object which can be evaluated by the
% power series evaluator.

%fluid '(unknowns !*exp knownps ps!:max!-order ps!:specials dfdx);
fluid '(unknowns !*exp  knownps ps!:max!-order ps!:specials
        ps!:level ps!:max!-level);

ps!:specials := list('psrev, 'pscomp, 'int);

symbolic (ps!:max!-level:= 20);

symbolic procedure ps!:compile(form,depvar,about);
  if idp form then
          make!-ps!-id(form,depvar,about)
   else  if ps!:numberp form then form
   else if ps!:p form then
      if (ps!:expansion!-point form=about)and(ps!:depvar form=depvar)
        then form
      else ps!:compile(ps!:value form,depvar,about)
   else if memq(rator form, ps!:specials) then
      apply(get(car form,'ps!:crule), list(form,depvar,about))
   else (if dfdx=0 then
           << about:=(rator form).(foreach arg in rands form collect
                           if ps!:p arg then
                              << ps!:find!-order arg;
                                 prepsq ps!:evaluate(arg,0)>>
                           else subst(about,depvar,arg));
              make!-constantps(simp!* about, form, depvar)>>
         else if get(car form,'ps!:crule) then
                apply(get(car form,'ps!:crule),list(form,depvar,about))
         else (if tmp then '!:ps!:  .  cdr tmp
%               else ps!:unknown!-crule(form, depvar, about))
               else ps!:unknown!-crule((car form) .
                                       foreach arg in cdr form collect
                                          ps!:compile(arg,depvar,about),
                                       depvar,about))
                 where tmp = assoc(form,knownps))
      where dfdx=prepsqxx simp!* list('df,ps!:arg!-values form, depvar);

symbolic procedure make!-ps!-id(id,depvar,about);
begin scalar ps;
  ps:=make!-ps(id,id,depvar,about);
  if id=depvar then
      if about='ps!:inf then <<
         ps!:set!-order(ps, -1);
         ps!:set!-terms(ps, list (0 . (1 ./ 1)))>>
      else <<
         about :=  if idp about then !*k2q about
                   else if ps!:numberp about then !*n2f about ./ 1
                   else simp!* about;
         if numr about then <<
            ps!:set!-order(ps, 0);
            ps!:set!-terms(ps, list(0 . about, 1 . (1 ./ 1)))>>
         else <<
            ps!:set!-order(ps, 1);
            ps!:set!-terms(ps, list(0 . (1 ./ 1)))>>
       >>
  else <<
     ps!:set!-order(ps, 0);
     ps!:set!-terms(ps, list(0 .  !*k2q id))>>;
  ps!:set!-last!-term(ps,ps!:max!-order);
  return ps
end;

symbolic procedure make!-constantps(u,v,d);
% u is a constant standard quotient, v is a corresponding prefix form
begin scalar ps;
      ps:=get('tps,'tag) . mkvect 7;
      ps!:set!-order(ps,0);
      ps!:set!-expression(ps, 'psconstant);
      ps!:set!-value(ps, v);
      ps!:set!-last!-term(ps,ps!:max!-order);
      ps!:set!-terms(ps,list(0 . u));
      ps!:set!-depvar(ps,d);
      putv(cdr ps, 7, !*sqvar!*);
      return ps
end;

symbolic procedure make!-ps(form,exp,depvar,about);
begin scalar ps;
      ps:=get('tps,'tag) . mkvect 7;
      ps!:set!-order(ps,0);
      ps!:set!-expression(ps,form);
      ps!:set!-value(ps,exp);
      ps!:set!-depvar(ps,depvar);
      ps!:set!-expansion!-point(ps,about);
      ps!:set!-last!-term(ps,-1);
      putv(cdr ps, 7, !*sqvar!*);
      return ps;
end;

symbolic procedure ps!:plus!-crule(a,d,n);
begin scalar pluses, minuses;
   foreach term in rands a do
      if pairp term and rator term = 'minus  then
           minuses := rand1 term . minuses
      else
           pluses := term . pluses;

   if not null pluses then <<
     if not null cdr pluses then
        pluses := make!-ps('plus . foreach term in pluses collect
                                      ps!:compile(term,d,n),
                           ps!:arg!-values('plus . pluses),d,n)
     else
        pluses := ps!:compile(car pluses,d,n);
     ps!:find!-order pluses>>;

   if not null minuses then <<
     if not null cdr minuses then
        minuses := make!-ps('plus . foreach term in minuses collect
                                      ps!:compile(term,d,n),
                            ps!:arg!-values('plus . minuses),d,n)
     else
        minuses := ps!:compile(car minuses,d,n);
     ps!:find!-order minuses>>;

   if null minuses then
       return pluses
   else if null pluses then
       a:= (make!-ps(ps, ps!:arg!-values ps,d,n)
               where ps = 'minus . list minuses)
   else a:= (make!-ps(ps, ps!:arg!-values ps, d,n)
               where ps = 'difference . list(pluses, minuses));
   ps!:find!-order a;
   return a;
end;

put('plus,'ps!:crule,'ps!:plus!-crule);

symbolic procedure ps!:unary!-crule(a,d,n);
   make!-ps(list(rator a,ps!:compile(rand1 a,d,n)),
                 ps!:arg!-values a,d,n);

symbolic procedure ps!:minus!-crule(a,d,n);
 if ps!:numberp cadr a then
    !:minus cadr a
 else  ps!:unary!-crule(a,d,n);

put('minus,'ps!:crule, 'ps!:minus!-crule);
put('sqrt,'ps!:crule,'ps!:unary!-crule);
put('cbrt,'ps!:crule,'ps!:unary!-crule);

symbolic procedure ps!:binary!-crule(a,d,n);
<>;

put('difference,'ps!:crule,'ps!:binary!-crule);

symbolic procedure ps!:nary!-crule(a,d,n);
% called from ps!:times!-crule so args are already power series
<>;


symbolic procedure ps!:times!-crule(a,d,n);
begin scalar prod, variables, constants;
   prod := foreach arg in rands a collect ps!:compile(arg,d,n);
   foreach arg in prod do
      if ps!:numberp arg or
         (not idp cdr arg and ps!:expression arg = 'psconstant) then
           constants := arg . constants
      else variables := arg . variables;
   if not null variables then
      if null cdr variables then
         variables := car variables
      else variables := ps!:nary!-crule('times . variables, d, n);
   if null constants then
      return variables
   else <<
      prod := 1 ./  1;
      foreach arg in constants do
          prod := multsq(prod, if ps!:numberp arg then
                                                     (if arg=0 then nil else arg) ./ 1
                               else ps!:get!-term(arg,0));
      if variables then
         a:= make!-ps(list('psmult, prod, variables),
                      ps!:arg!-values a,d,n)
      else
         return make!-constantps(prod, ps!:arg!-values a, d);
      ps!:find!-order a;
      return a>>;
end;

put('times,'ps!:crule,'ps!:times!-crule);
put('quotient,'ps!:crule,'ps!:quotient!-crule);

symbolic procedure ps!:quotient!-crule(a,d,n);
% forms such as (quotient (expt  ) (expt  )) are
% detected here and transformed into (expt (difference  )) to
% help avoid certain essential singularities
begin scalar r1, r2;
  r1 := rand1 a; r2 := rand2 a;
  if eqcar(r1,'expt) and eqcar(r2,'expt) and
        ((rand1 r1)=(rand1 r2)) then
    return ps!:compile(list('expt, rand1 r1,
                            list('difference, rand2 r1, rand2 r2)),
                        d,n);
    r1:=ps!:compile(rand1 a, d, n);
    if (ps!:numberp r1 or
        (not idp cdr r1 and ps!:expression r1 = 'psconstant))
           and eqcar(r2, 'expt) then
     << r2:=ps!:compile(list('expt,rand1 r2,prepsqxx simpminus cddr r2),
                         d,n);
      return
             if onep r1 then r2
        else <<
           a := make!-ps(list('psmult, if ps!:numberp r1 then r1 ./ 1
                                       else ps!:get!-term(r1,0),
                               r2),
                         ps!:arg!-values a,d,n);
           ps!:find!-order a;
             a>>
      >>;
    r2:=ps!:compile(rand2 a, d, n);

    if ps!:numberp r2 or
         (not idp cdr r2 and ps!:expression r2 = 'psconstant) then
      << r2 := if ps!:numberp r2 then 1 ./ r2
               else invsq ps!:get!-term(r2,0);
         a:= make!-ps(list('psmult, r2, r1), ps!:arg!-values a,d,n)>>
    else
         a:= make!-ps(list('quotient, r1, r2), ps!:arg!-values a,d,n);
    ps!:find!-order a;
    return a;
end;

symbolic procedure ps!:int!-crule(a,d,n);
begin scalar r,arg1, psord, intvar;
  intvar := rand2 a;
  if not idp intvar then
    typerr(intvar, "kernel: ps!:int!-crule");
  if depends(intvar, n) then
    rerror(tps,11,
       "Can't integrate series when expansion point is non-constant ");
  arg1:=ps!:compile(prepsqxx simp!* rand1 a,d,n);
  r:= make!-ps(list('int,arg1,intvar), ps!:arg!-values a,d,n);
  psord:= ps!:find!-order arg1;
  if d=intvar then
     if ps!:expansion!-point(arg1) neq 'ps!:inf then
       <>
     else  % expansion about infinity
         if (psord < 2) and (ps!:evaluate(arg1,1) neq (nil ./ 1)) then
           rerror(tps,13,"Logarithmic Singularity at Infinity");
  ps!:find!-order r;
  return r;
end;

put('int,'ps!:crule,'ps!:int!-crule);

symbolic procedure ps!:log!-crule(a,d,n);
begin scalar r, dfdx, f;
  f := ps!:compile(rand1 a, d, n);
  if ps!:order f neq 0 then
        rerror(tps,14, "Logarithmic Singularity");
  dfdx := ps!:compile(prepsq simp!* list('df, f, d), d, n);
  r := ps!:compile(list('quotient, dfdx, f), d, n);
  r := make!-ps(list('int, r, d), ps!:arg!-values a, d, n);
  ps!:set!-term(r,0, simp!* list('log, prepsq ps!:get!-term(f,0)));
  ps!:find!-order r;
  return r;
end;

put('log,'ps!:crule, 'ps!:log!-crule);

symbolic procedure ps!:arg!-values funct;
  (rator funct) . (foreach arg in rands funct collect
                     if ps!:atom arg then arg
                     else if ps!:p arg then ps!:value arg
                     else ps!:arg!-values arg);

symbolic procedure ps!:unknown!-crule(a,d,n);
% unknowns is an alist structure, the CAR of which is the
% form which was differentiated and the CDR is a dotted pair whose
% CDR is a gensym'ed identifier which is used to build
% the cyclic structures used to represent a recurrence relation.

   (lambda (aval,tmp);
     if (tmp:=assoc(aval, unknowns)) then  '!:ps!: . cdr tmp
     else if ps!:level > ps!:max!-level then
             rerror(tps,15, "Recursion too deep in ps!:unknown!-crule")
     else
        (lambda(dfdx, unknowns);
           (lambda(r, s); <<
              ps!:level:=ps!:level+1;
              %intern s;  %  not needed, but useful for debugging.
              global list s;  % This is definitely needed in UOLISP.
% it is important to set s before recursing to find the power series
% expansion of dfdx as this may involve evaluating s
              set(s,cdr r);
% it is also important to determine the first non-zero term of the
% series (assumed to be of order >= 0) before recursing in case
% the original series is encountered again in the recursion
              ps!:unknown!-term1(r, a);
              dfdx := ps!:compile(dfdx,d,n);
% the next test is intended to detect the case when a function f(x)
% (say) is expanded about a point x=a (say) at which f has a pole or
% essential singuarity, but where the Reduce simplifier returns a
% seemingly well-defined value for f when x=a.
              if ps!:order dfdx < 0 then
                 rerror(tps, 16, "Pole or Logarithmic Singularity");
              ps!:set!-expression(r,list('int, dfdx, d));
              knownps:=(aval . s) . knownps;
              ps!:level:=ps!:level-1;
              r
            >> )
            (make!-ps(nil,aval,d,n), cdar unknowns))
            (ps!:differentiate(a,d), (aval . gensym()) . unknowns)
   )
    (ps!:arg!-values a,nil);

symbolic procedure ps!:unknown!-term1(ps,a);
% There is an implicit assumption that the order of the series >=0 here
begin scalar psord, term, about, infmult, x;
   psord := 0;
   about := ps!:expansion!-point ps;
   x := ps!:depvar ps;
loop:
   term := simp!* ps!:first!-term a;
   ps!:set!-term(ps, psord, term);
   if numr term = nil then <<
      psord := psord+1;
      if psord > ps!:max!-order then
         rerror('tps, 17, list(ps!:value ps,
                                            "has zero expansion to order",
                                psord));
      a := list('quotient, list('df, a, x), psord);
      if about = 'ps!:inf then <<
         if psord = 1 then
            infmult := ps!:compile(list('minus, list('times, x, x)),
                                   x, about);
         a := list('times, infmult, a)>>;
      a := prepsqxx simp!* a;
      go loop>>;
end;

symbolic procedure ps!:first!-term(l);
  if atom l then  l
  else if ps!:p l then
     if ps!:find!-order l < 0 then
          rederr "Possible essential singularity"
     else prepsqxx ps!:get!-term(l,0)
  else
    car l . foreach arg in cdr l collect ps!:first!-term arg;

symbolic procedure ps!:differentiate(a,v);
   (lambda x;
      if eqcar(x,'df) then
         rerror(tps,18,
           list("ps:differentiate: no rule to differentiate function",
                 car a, "when it has", length a - 1, "arguments"))
      else
         x)
   ((lambda (!*exp);
        prepsqxx simp!* list ('df, a, v)) nil);


symbolic procedure ps!:expt!-crule(a,d,n);
% we will assume that forms like (expt (expt  ) ) will
% continue to be transformed by SIMP!* into (expt  (times  ))
% this is very important for the avoidance of essential singularities
%
% If the exponent is equivalent to a rational number there is a
% convenient algorithm for exponentiation. So use it, otherwise
% use a^b = exp(b*log a) and use the algorithm for exp(power-series)
%
begin scalar eflg,exp1,exp2,b,psvalue;
   b := rand1 a;
   if not ps!:p b or constantpsp b then
      eflg := evalequal(b,prepsq simp!* aeval 'e);
   exp1:=rand2 a;
   if (ps!:p exp1 and constantpsp exp1) then exp1:=ps!:value exp1;
   begin scalar alglist!*, dmode!*;
        exp2:=simp!* exp1;
   end;
   psvalue:=ps!:arg!-values a;
   if (atom numr exp2 and atom denr exp2) then
        <>
   else return
     << exp2 := ps!:compile(if eflg then exp1
                            else list('times, exp1, list('log,b)), d,n);
        make!-ps(list('exp, exp2), psvalue, d, n)>>;
   b := ps!:compile(b,d,n);
   if exp2=1 then
      if exp1=nil then
         return if ps!:zerop!: b
                then rerror(tps,19,"0**0 formed: ps:expt-crule")
                else 1
      else if exp1=1 then return b
      else if exp1=2 then
         a := make!-ps(list('times,b,b),psvalue,d,n)
      else if exp1 = -1 then
         a:= make!-ps(list('quotient,1,b),psvalue,d,n)
      else a := make!-ps(list('expt,b,exp1,1),psvalue,d,n)
   else a := make!-ps(list('expt,b,exp1,exp2),psvalue,d,n);
   ps!:find!-order a;
   return a;
end;

put('expt,'ps!:crule,'ps!:expt!-crule);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpsconv.red0000644000175000017500000001120011526203062023474 0ustar  giovannigiovannimodule tpsconv;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


%*****************************************************************
%
%     Functions converting power series objects to prefix forms
%
%*****************************************************************


exports prep!:ps, ps!:print1, ps!:print, ps!:print0;

fluid '(ps!:exp!-lim !*fort !*nat );

symbolic procedure prep!:ps(ps, highest!-order);
begin scalar x, var, inv;
   var := ps!:mkvar ps;
   inv := (ps!:expansion!-point ps = 'ps!:inf);
   return replus
      for j := ps!:find!-order ps : highest!-order join
               << x := prepsq!* ps!:evaluate(ps,j);
            if x = 0 then nil
             else
               {retimes ((if eqcar (x, 'quotient)
                              and eqcar (cadr x, 'minus) then
                            {'minus, {'quotient, cadr cadr x, caddr x}}
                          else x) . ps!:mkpow(var, j, inv))}
         >>;
end;

% symbolic procedure ps!:mkpow(bas, exp, inverted);
%    if exp = 0 then {1}
%    else if exp > 0 then
%       (if inverted then {{'quotient, 1, x}} else {x})
%         where x = (if exp = 1 then bas else {'expt,bas, exp})
%    else
%       (if inverted then {x} else {{'quotient, 1, x}})
%                where x = (if exp = -1 then bas
%                           else {'expt,bas, -exp});

Comment
 The following coding treats negative order terms in expansions
 about infinity in the same way as Taylor (ie. 1 over negative powers
  of x), whereas the code above prints these as positive powers of x;


symbolic procedure ps!:mkpow(bas, exp, inverted);
   if exp = 0 then {1}
   else
      (if inverted then {{'quotient, 1, x}} else {x})
         where x = (if exp = 1 then bas else {'expt,bas, exp});

symbolic procedure ps!:mkvar ps;
begin scalar var0, var;
  var := ps!:depvar ps;
  var0 := ps!:expansion!-point ps;
  if var0 = 0 or var0 = 'ps!:inf then
     return var
  else if numberp var0 and var0 < 0 then
     return {'plus, var, -var0}
  else if eqcar(var0, 'minus) then
     return {'plus, var, cadr var0}
  else if eqcar(var0, 'quotient) and eqcar(cadr var0, 'minus) then
     return {'plus, var, {'quotient, cadadr var0, caddr var0}}
  else
     return {'difference, var, var0};
end;

symbolic procedure ps!:big!-o(ps, ord);
  %
  % Generates a big-O notation for power series
  %
  "O" . ps!:mkpow(ps!:mkvar ps,
                  ord,
                            (ps!:expansion!-point ps = 'ps!:inf));

symbolic procedure ps!:print1 u;
begin scalar prepexpr, rest;
    prepexpr := prep!:ps(u, ps!:exp!-lim);
    rest := {ps!:big!-o(u, ps!:exp!-lim+1)};
    return
       if not eqcar (prepexpr, 'plus) then
          'plus . (prepexpr or 0) . rest
       else
          nconc (prepexpr, rest);
end;

put('!:ps!:, 'fancy!-reform, 'ps!:print1);

symbolic procedure ps!:print(u,p);
  if !*fort then
     fmprint(prep!:ps(u,ps!:exp!-lim),p)
  else if null !*nat then
             maprint('ps . (ps!:value u) . (ps!:depvar u) .
                   {(if about = 'ps!:inf then 'infinity
                     else if about = nil then 'undefined else about)
                      where about = ps!:expansion!-point u},
                p)
  else if constantpsp u then
             maprint(prepsqxx ps!:get!-term(u, 0), p)
  else maprint(ps!:print1 u, p);

symbolic procedure ps!:print0 u;
    ps!:print(u,0);

Comment We need another printing function for use with the
        TeX-REDUCE interface; %not yet done;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpsdom.red0000644000175000017500000001471311526203062023322 0ustar  giovannigiovannimodule tpsdom; % Domain definitions for truncated power series.

% Authors: Julian Padget & Alan Barnes.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(ps!:exp!-lim ps!:max!-order);
global '(domainlist!*);

symbolic (domainlist!*:=union('(!:ps!:),domainlist!*));
% symbolic here seems to be essential in Cambridge Lisp systems

put('tps,'tag,'!:ps!:);
put('!:ps!:,'dname,'tps);
flag('(!:ps!:),'field);
put('!:ps!:,'i2d,'i2ps);
put('!:ps!:,'minusp,'ps!:minusp!:);
put('!:ps!:,'plus,'ps!:plus!:);
put('!:ps!:,'times,'ps!:times!:);
put('!:ps!:,'difference,'ps!:difference!:);
put('!:ps!:,'quotient,'ps!:quotient!:);
put('!:ps!:,'zerop,'ps!:zerop!:);
put('!:ps!:,'onep,'ps!:onep!:);
put('!:ps!:,'prepfn,'ps!:prepfn!:);
%put('!:ps!:,'specprn,'ps!:prin!:);
put('!:ps!:,'prifn,'ps!:print0);
put('!:ps!:,'pprifn,'ps!:print);
put('!:ps!:,'intequivfn,'psintequiv!:);
put('!:ps!:,'expt,'ps!:expt!:);

% conversion functions

put('!:ps!:,'!:mod!:,mkdmoderr('!:ps!:,'!:mod!:));
% put('!:ps!:,'!:gi!:,mkdmoderr('!:ps!:,'!:gi!:));
% put('!:ps!:,'!:bf!:,mkdmoderr('!:ps!:,'!:bf!:));
% put('!:ps!:,'!:rn!:,mkdmoderr('!:ps!:,'!:rn!:));
put('!:rn!:,'!:ps!:,'!*d2ps);
put('!:ft!:,'!:ps!:,'!*d2ps);
put('!:bf!:,'!:ps!:,'!*d2ps);
put('!:gi!:,'!:ps!:,'!*d2ps);
put('!:gf!:,'!:ps!:,'!*d2ps);
put('!:rd!:,'!:ps!:,'!*d2ps);
put('!:cr!:,'!:ps!:,'!*d2ps);
put('!:crn!:,'!:ps!:,'!*d2ps);

symbolic procedure psintequiv!: u;
  if idp cdr u or ps!:depvar u or denr(u:=ps!:get!-term(u,0)) neq 1
  then nil
  else if domainp (u:=numr u) then
        if atom u then if null u then 0 else u
        else (if x  and (x:= apply1(x,u)) then x else nil)
               where x = get(car u,'intequivfn)
  else nil;

symbolic procedure i2ps u;
   u;

symbolic procedure !*d2ps u;
  make!-constantps ((u ./ 1), prepsqxx(u ./ 1), nil);

%  begin scalar ps;
%      ps:=get('tps,'tag) . mkvect 7;
%      ps!:set!-order(ps,0);
%      ps!:set!-expression(ps,list ('psconstant, u ./ 1));
%      ps!:set!-value(ps,u:=prepsqxx( u ./ 1));
%      ps!:set!-last!-term(ps,ps!:max!-order);
%      ps!:set!-terms(ps,list ( 0 . simp!* u)));
%     return ps
%   end;

symbolic procedure ps!:minusp!: u;
   nil;   % what else makes sense?

symbolic procedure ps!:plus!:(u,v);
   ps!:operator!:('plus,u,v);

symbolic procedure ps!:difference!:(u,v);
   ps!:operator!:('difference,u,v);

symbolic procedure ps!:times!:(u,v);
   ps!:operator!:('times,u,v);

symbolic procedure ps!:quotient!:(u,v);
   ps!:operator!:('quotient,u,v);


symbolic procedure ps!:diff!:(u,v);
  (( if idp deriv then
        make!-ps!-id(deriv,ps!:depvar u,ps!:expansion!-point u)
      else if numberp deriv then
              if zerop deriv then nil
              else deriv
      else <<
         u:=make!-ps(list('df,u,v), deriv,
                     ps!:depvar u,ps!:expansion!-point u);
         ps!:find!-order u;
         u
      >>)
  ./ 1)
   where (deriv = prepsqxx simp!* list('df, ps!:value u,v));

put('!:ps!:,'domain!-diff!-fn,'ps!:diff!:);

symbolic procedure ps!:depends!-fn(u,v);
   depends(ps!:value u, v);

put('!:ps!:, 'domain!-depends!-fn, 'ps!:depends!-fn);

symbolic procedure ps!:operator!:(op,u,v);
% u and v are domain elements at least one of which is a power series
   begin scalar value,x,x0,y,y0;
      if not ps!:p v  then
        << x:=ps!:depvar u; x0:= ps!:expansion!-point u >>
      else if not ps!:p u then
        << x:=ps!:depvar v; x0:= ps!:expansion!-point v>>
      else % both are power series
        <>;
        if null x0 then  % both are constant power series
           << if x and y then
                if x eq y then nil else
                  rerror(tps,31,
                  list("power series dependent variables differ in ",
                        op))
              else if y then x:=y;
              if ps!:p u then u:= ps!:value u;
              if ps!:p v then v:= ps!:value v;
              value := simp!* list(op, u, v);
              if denr value=1 and domainp numr value then
                 return numr value
              else
                 return make!-constantps(value, prepsqxx value, x) >>;
        if x and y then
          if x eq y then nil
          else rerror(tps,32,
                  list("power series dependent variables differ in ",
                        op))
        else if y then x:=y;
        value:= simp!* list(op,ps!:value u,ps!:value v);
        if denr value=1 and domainp numr value then return numr value;
        u:= make!-ps(list(op,u,v), prepsqxx value,x,x0);
        ps!:find!-order u;
        return u;
  end;

symbolic procedure ps!:zerop!: u;
  (numberp v and zerop v) where v=ps!:value u;

symbolic procedure ps!:onep!: u;
  onep ps!:value u;

symbolic procedure ps!:prepfn!: u;
   u;

initdmode 'tps;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tps.tst0000644000175000017500000000352011526203062022654 0ustar  giovannigiovanni% Author: Alan Barnes 

psexplim 8;
% expand as far as 8th power (default is 6)

cos!-series:=ps(cos x,x,0);
sin!-series:=ps(sin x,x,0);
atan!-series:=ps(atan x,x,0);
tan!-series:=ps(tan x,x,0);

cos!-series*tan!-series;        % should series for sin(x)
df(cos!-series,x);              % series for sin(x) again

cos!-series/atan!-series;       % should be expanded


tmp:=ps(1/(1+x^2),x,infinity);
df(tmp,x);
ps(df(1/(1+x^2),x),x,infinity);

tmp*x;  % not expanded as a single power series
ps(tmp*x,x,infinity);   % now expanded

ps(1/(a*x-b*x^2),x,a/b);   % pole at expansion point

ps(cos!-series*x,x,2);

tmp:=ps(x/atan!-series,x,0);
tmp1:=ps(atan!-series/x,x,0);
tmp*tmp1;               % should be 1, of course


cos!-sin!-series:=ps(cos sin!-series,x,0);
% cos(sin(x))
tmp:=cos!-sin!-series^2;
tmp1:=ps((sin(sin!-series))^2,x,0);
tmp+tmp1;               % sin^2 + cos^2
psfunction tmp1;
% function represented by power series tmp1

tmp:=tan!-series^2;
psdepvar tmp;
% in case we have forgotten the dependent variable
psexpansionpt tmp;      % .... or the expansion point
psterm(tmp,6);  % select 6th term
psterm(tmp,10); % select 10th term (series extended automtically)

tmp1:=ps(1/(cos x)^2,x,0);
tmp1-tmp;       % sec^2-tan^2

ps(int(e^(x^2),x),x,0); % integrator not called
tmp:=ps(1/(y+x),x,0);
ps(int(tmp,y),x,0);     % integrator called on each coefficient

pscompose(cos!-series,sin!-series);
% power series composition cos(sin(x)) again
cos!-sin!-series;
% should be same as previous result
psfunction cos!-sin!-series;

tmp:=ps(log x,x,1);
tmp1:=pscompose(tmp, cos!-series);
% power series composition of log(cos(x))
df(tmp1,x);     % series for -tan x

psreverse tan!-series;
% should be series for atan x
atan!-series;
tmp:=ps(e^x,x,0);
psreverse tmp;
% NB expansion of log x  in powers of (x-1)

pschangevar(tan!-series,y);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpseval.red0000644000175000017500000003673611526203062023503 0ustar  giovannigiovannimodule tpseval; % Evaluator for truncated power series.

% Authors: Julian Padget & Alan Barnes

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The evaluator interprets the results of the compilation phase and
% is also rule driven until I get round to getting the compilation
% phase to produce directly executable code

% The evaluation functions live on the erule property of the name.

fluid '(ps ps!:order!-limit ps!:max!-order);

% Printing functions now in module tpsconv

% symbolic procedure ps!:prin!: p;
% if constantpsp p then
%   maprint(prepsqxx ps!:get!-term(p,0), 0)
% else
%  (lambda (first,u,delta,symbolic!-exp!-pt,about,atinf);
%   <<  if !*nat and posn!*<20 then orig!*:=posn!*;
%       atinf:=(about='ps!:inf);
%       ps!:find!-order p;
%       delta:=prepf((ps!:depvar p) .** 1 .*1 .+
%               (negf  if atinf then nil
%                       % expansion about infinity
%                       else if idp about then !*k2f about
%                       else if ps!:numberp about then !*n2f about
%                       else if (u:=!*pre2dp about) then !*n2f u
%                       else !*k2f(symbolic!-exp!-pt:= compress
%                          append(explode ps!:depvar p, explode '0))));
%       if symbolic!-exp!-pt then prin2!* "[";
%       prin2!* "{";
%       for i:=(ps!:order p): ps!:exp!-lim do
%         << u:=ps!:get!-term(p,i);
%            if null u then u := ps!:evaluate!-next(p,i);
%            if not null numr u then
%               <>
%                   else if not first then prin2!* " + ";
%                 first := nil;
%                 if posn!*>55 then <>;
%                 if denr u neq 1 then prin2!* "(";
%                 if u neq '(1 . 1) then
%                         maprint(prepsqxx u,get('times,'infix))
%                   else if i=0 then prin2!* 1;
%                 if denr u neq 1 then prin2!* ")";
%                 if i neq 0 and u neq '(1 . 1) then prin2!* "*";
%                 if i neq 0 then
%                 xprinf(!*p2f mksp(delta,
%                        if atinf then -i else i),nil,nil)
%               >>
%        >>;
%       if first then prin2!* "0";
%       if posn!*>55 then terpri!* nil;
%       u:=ps!:exp!-lim +1;
%       if (u=1) and not atinf and (about neq 0) then
%             prin2!* " + O"
%       else prin2!* " + O(";
%       xprinf(!*p2f mksp(delta,if atinf then -u else u),nil,nil);
%       if (u=1) and not atinf and (about neq 0) then
%               prin2!* "}"
%          else prin2!* ")}";
%       if symbolic!-exp!-pt then
%         << if posn!*>45 then terpri!* nil;
%            prin2!* "  where ";
%            prin2!* symbolic!-exp!-pt;
%            prin2!* " = ";
%            maprin about;
%            prin2!* "]"
%         >>;
%       terpri!* nil;
%  >>)
%  (t,nil,nil,nil,ps!:expansion!-point p,nil);
%


symbolic procedure ps!:unknown!-order ps;
  (lambda (u, v);
          if v >= u then u
          else rerror(tps,20,
                      list("Can't find the order of ",ps!:value ps)))
   (ps!:order ps, ps!:last!-term ps);

symbolic procedure ps!:find!-order ps;
  if null ps then 0
  else if idp ps then ps  % second arg of DF etc are identifiers
  else if ps!:numberp ps then 0
  else if eqcar(ps,'!:ps!:) then <<
     if idp cdr ps then ps!:unknown!-order ps
     else if atom ps!:expression ps then ps!:order ps
     else ps!:find!-order1(ps)>>
  else rerror(tps,21,"Unexpected form in ps!:find!-order");

symbolic procedure ps!:find!-order1(ps);
begin scalar psoperator,psord,pslast;
      psord:=ps!:order ps;
      pslast:=ps!:last!-term ps;
      if psord leq pslast then
         return psord;

      psoperator:=ps!:operator ps;
      psord:=apply(get(psoperator,'ps!:order!-fn), list ps);
      ps!:set!-order(ps,psord);
      ps!:set!-last!-term(ps,psord-1);

      if ps!:value ps =0 then
         % prevents infinite loop if we have exact cancellation
         <>
      else while ps!:evaluate!-next(ps,psord)=(nil ./ 1 ) do
      % in case we have finite # of cancellations in a sum or difference
          < ps!:order!-limit then
                rerror(tps,22,list("Expression ", ps!:value ps,
                                   " has zero expansion to order ",
                                   psord))
            % We may not always be able to recognise zero,
            % so give up after specified number of iterations.
          >>;
      return psord
end;

symbolic (ps!:order!-limit:=100);
% symbolic here seems to be essential in Cambridge Lisp systems

put('psordlim, 'simpfn, 'simppsordlim);

symbolic procedure simppsordlim u;
begin integer n;
   n:=ps!:order!-limit;
   if u then ps!:order!-limit := ieval carx(u,'psordlim);
   return (if n=0 then nil ./ 1 else n ./ 1);
end;

put('plus,'ps!:order!-fn, 'ps!:plus!-orderfn);
put('int,'ps!:order!-fn,'ps!:int!-orderfn);
put('df,'ps!:order!-fn,'ps!:df!-orderfn);
put('quotient,'ps!:order!-fn, 'ps!:quotient!-orderfn);
put('times,'ps!:order!-fn, 'ps!:times!-orderfn);
put('minus,'ps!:order!-fn, 'ps!:minus!-orderfn);
put('difference,'ps!:order!-fn, 'ps!:difference!-orderfn);

symbolic procedure ps!:int!-orderfn ps;
begin scalar u,v;
     v := ps!:depvar ps;
     u := ps!:find!-order(rand1 ps!:expression ps);
     return
        if v=rand2 ps!:expression ps then
          if ps!:expansion!-point ps neq 'ps!:inf then
            if u=-1 then rerror(tps,23,"Logarithmic Singularity")
            else u+1
          else   % expansion about infinity
            if u=1 then rerror(tps,24,"Logarithmic Singularity")
            else u-1
          else u;
end;

symbolic procedure ps!:df!-orderfn ps;
begin scalar u, v, pt, dfvar;
     v:= ps!:expression ps;
     u := ps!:find!-order(rand1 v);
     dfvar := rand2 v;
     pt := ps!:expansion!-point ps;
     return
        if ps!:depvar ps = dfvar then
           if pt neq 'ps!:inf then
              if u=0 then 0 else u-1
           else if u=0 then 2 else u+1    % expansion about infinity
        else if depends(pt, dfvar) then if u=0 then 0 else u-1
             else u;
end;

symbolic procedure ps!:quotient!-orderfn ps;
begin scalar u,v;
     v := ps!:expression ps;
     u := ps!:find!-order(rand1 v);
     v := ps!:find!-order(rand2 v);
     return difference(u,v);
end;

symbolic procedure ps!:times!-orderfn ps;
begin scalar u,v;
     v := ps!:expression ps;
     u := ps!:find!-order(rand1 v);
     v := ps!:find!-order(rand2 v);
     return plus2(u,v);
end;

%symbolic procedure ps!:plus!-orderfn ps;
%  eval cons('min ,  mapcar(rands ps!:expression ps, 'ps!:find!-order));

symbolic procedure ps!:plus!-orderfn ps;
  % Re-worked by ACN to avoid excessive numbers of args.
   begin scalar w, m;
      if null ps then return 0;
      w := mapcar(rands ps!:expression ps, 'ps!:find!-order);
      m := car w;
      for each z in cdr w do if z < m then m := z;
      return m
   end;

symbolic procedure ps!:minus!-orderfn ps;
  ps!:find!-order(rand1 ps!:expression ps);

symbolic procedure ps!:difference!-orderfn ps;
begin scalar u,v;
     v := ps!:expression ps;
     u := ps!:find!-order(rand1 v);
     v := ps!:find!-order(rand2 v);
     return min2(u,v);
end;

put('sqrt,'ps!:order!-fn,'ps!:sqrt!-orderfn);
put('sqrt,'ps!:erule,'ps!:sqrt!-erule);

symbolic procedure ps!:sqrt!-orderfn ps;
begin scalar u;
  u:=ps!:find!-order rand1 ps!:expression ps;
  return
     (if v*2=u then v else rerror(tps,25,"Branch Point in Sqrt"))
      where v=u/2
end;

symbolic procedure ps!:sqrt!-erule(a,n);
begin scalar aa,x,y,z;
  aa:=rand1 a;  z:= nil ./ 1;
  y:=ps!:order aa;
  x:=ps!:order(ps);   %order of sqrt ps
  if n=x then return simpexpt(list(prepsqxx ps!:evaluate(aa,y),
                                   '(quotient 1 2)));
  for k:=1:n-x do
              z:=addsq(z,
                    multsq(((lambda y; if y=0 then nil else y)
                             (k*3-2*n+y)) ./ 1,
                          multsq(ps!:evaluate(aa,k+y),
                               ps!:evaluate(ps,n-k))));
            return quotsq(z,multsq(2*(n-x) ./ 1,ps!:evaluate(aa,y)))
end;

%  alternative algorithm (for order 0 only)
%  for i:=1:n-1 do
%    z:=addsq(z,multsq(multsq( i ./ 1,ps!:evaluate(ps,i)),
%                      ps!:evaluate(ps,n-i)));
%    z:=multsq(z, 1 ./ (n+1));
%  return quotsq(addsq(ps!:evaluate(aa,n),negsq z),
%                multsq(2 ./ 1,ps!:evaluate(b,x)))


put('cbrt,'ps!:order!-fn,'ps!:cbrt!-orderfn);
put('cbrt,'ps!:erule,'ps!:cbrt!-erule);

symbolic procedure ps!:cbrt!-orderfn ps;
begin scalar u;
   u:=ps!:find!-order rand1 ps!:expression ps;
   return
      (if v*3=u then v else rerror(tps,26,"Branch Point in Cbrt"))
       where v=u/3
end;

symbolic procedure ps!:cbrt!-erule(a,n);
begin scalar aa,x,y,z;
  aa:=rand1 a;  z:= nil ./ 1;
  y:=ps!:order aa;
  x:=ps!:order(ps);   %order of cbrt ps
  if n=x then return simpexpt(list(prepsqxx ps!:evaluate(aa,y),
                                   '(quotient 1 3)));
  for k:=1:n-x do
              z:=addsq(z,
                    multsq(((lambda y; if y=0 then nil else y)
                             (k*4-3*n+y)) ./ 1,
                          multsq(ps!:evaluate(aa,k+y),
                               ps!:evaluate(ps,n-k))));
            return quotsq(z,multsq(3*(n-x) ./ 1,ps!:evaluate(aa,y)))
end;

symbolic procedure ps!:evaluate(ps,i);
begin scalar term;
   term:=ps!:get!-term (ps,i);
   if term then return term;
   for j:=ps!:last!-term(ps)+1:i do
      term:= ps!:evaluate!-next(ps,j);
   return term;
end;

symbolic procedure ps!:evaluate!-next(ps,n);
% The appropriate evaluation rule for the operator
% in the ps is selected and invoked
begin scalar next;
    next := apply(get(ps!:operator ps,'ps!:erule),
                  list(ps!:expression ps,n));
    ps!:set!-term(ps,n,next:=simp!* prepsqxx next);
    return next;
end;

symbolic procedure ps!:plus!-erule(a,n);
begin scalar z;
      z := nil ./ 1;
      foreach term in rands a do
           z:=addsq(z, ps!:evaluate(term, n));
      return z
end;

put('plus,'ps!:erule,'ps!:plus!-erule);

symbolic procedure ps!:minus!-erule(a,n);
   negsq ps!:evaluate(rand1 a,n);

put('minus,'ps!:erule,'ps!:minus!-erule);

symbolic procedure ps!:difference!-erule(a,n);
   addsq(ps!:evaluate(rand1 a,n),
         negsq ps!:evaluate(rand2 a,n));

put('difference,'ps!:erule,'ps!:difference!-erule);

symbolic procedure ps!:times!-erule(a,n);
begin scalar aa,b,x,y,y1,z;
   aa:=rand1 a; b:= rand2 a; z:= nil ./ 1;
   x:=ps!:order(aa);
   y:=ps!:order(ps);    % order of product ps
   y1 := ps!:order b;
   for i := 0:n-y do if n-x-i>=y1 then
     z:= addsq(z,multsq(ps!:evaluate(aa,i+x),
                        ps!:evaluate(b,n-x-i)));
   return z
end;

put('times,'ps!:erule,'ps!:times!-erule);

symbolic procedure ps!:quotient!-erule(a,n);
begin scalar aa,b,x,y,z;
  aa:=rand1 a; b:=rand2 a; z:= nil ./ 1;
  y:=ps!:order(b);
  x:=ps!:order(ps);   %order of quotient ps
  for i:=1:n-x do
    z:=addsq(z,multsq(ps!:evaluate(b,i+y),
                      ps!:evaluate(ps,n-i)));
  return quotsq(addsq(ps!:evaluate(aa,n+y),negsq z),
                      ps!:evaluate(b,y))
end;

put('quotient,'ps!:erule,'ps!:quotient!-erule);

% the next two functions deal more efficiently with common special
% cases of multiplication or division by a constant
% the constmult operator is produced by
% ps!:times!-crule and ps!:quotient!-crule
%

put('psmult,'ps!:order!-fn, 'ps!:constmult!-orderfn);
put('psmult,'ps!:erule,'ps!:constmult!-erule);

symbolic procedure ps!:constmult!-orderfn ps;
  ps!:find!-order rand2 ps!:expression ps;

symbolic procedure ps!:constmult!-erule(a,n);
    multsq(rand1 a, ps!:evaluate(rand2 a,n));

symbolic procedure ps!:df!-erule(a,n);
begin scalar dfvar, series, about;
  dfvar := rand2 a;
  series := rand1 a;
  about := ps!:expansion!-point series;
  return
    if dfvar = ps!:depvar series then
       if about neq 'ps!:inf then
          multsq((n+1) ./ 1,ps!:evaluate(series, n+1))
      else multsq((1-n) ./ 1,ps!:evaluate(series, n-1))
    else if depends(about, dfvar) then
         addsq(diffsq(ps!:evaluate(series,n),dfvar),
               multsq((-n-1) ./ 1, multsq(ps!:evaluate(series,n+1),
                                          diffsq(simp!* about,dfvar))))
    else diffsq(ps!:evaluate(series,n),dfvar);
end;

put('df,'ps!:erule,'ps!:df!-erule);

symbolic procedure ps!:int!-erule(a,n);
  if rand2 a=ps!:depvar rand1 a then
     if ps!:expansion!-point rand1 a neq 'ps!:inf then
         quotsq(ps!:evaluate(rand1 a,n-1), n ./ 1)
     else quotsq(ps!:evaluate(rand1 a,n+1),-n ./ 1)
  else simpint list(prepsqxx ps!:evaluate(rand1 a,n),rand2 a);

put('int,'ps!:erule,'ps!:int!-erule);

symbolic procedure ps!:expt!-orderfn ps;
begin scalar u, v, w, expres;
     expres := ps!:expression ps;
     u:= ps!:find!-order rand1 expres;
     v:= rand2 expres;
     w := cadddr expres;
     if cdr(v:=divide(u * v,w))=0 then return car v
     else rerror(tps,27,"Branch Point in EXPT")
end;

symbolic procedure ps!:expt!-erule(a,n);
begin scalar base,x,y,z,p,q;
   base:= rand1 a;
   p:=rand2 a; q:=cadddr a;
   y:=ps!:order(base);
   z:= ps!:order ps;         % order of exponential
   if n=z then <<
         if q =1 then x := p else x := list('quotient, p, q);
         return simpexpt(list(prepsqxx ps!:evaluate(base,y),x))>>
   else << x:= nil ./ 1;
           for k:=1:n-z do
              x:=addsq(x,
                       multsq(((lambda num; if num=0 then nil else num)
                               (k*p+q*(k-n+z))) ./ q,
                              multsq(ps!:evaluate(base,k+y),
                                     ps!:evaluate(ps,n-k))));
            return quotsq(x,multsq((n-z) ./ 1, ps!:evaluate(base,y)))
        >>;
  end;

put('expt,'ps!:erule, 'ps!:expt!-erule);
put('expt,'ps!:order!-fn,'ps!:expt!-orderfn);

symbolic procedure ps!:exp!-orderfn ps;
  if ps!:find!-order rand1 ps!:expression ps<0 then
      rerror(tps, 28, "Essential Singularity in EXP")
  else 0;

symbolic procedure ps!:exp!-erule(a,n);
begin scalar exp1, x;
   exp1:= rand1 a;
   if n=0 then
      return simpexpt(list('e, prepsqxx ps!:evaluate(exp1,0)));
   x:= nil ./ 1;
   for k:=0:n-1 do
       x:=addsq(x, multsq((n-k) ./ 1,
                          multsq(ps!:evaluate(exp1,n-k),
                                 ps!:evaluate(ps,k))));
   return quotsq(x, n ./ 1);
end;

put('exp,'ps!:erule, 'ps!:exp!-erule);
put('exp,'ps!:order!-fn,'ps!:exp!-orderfn);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tps.rlg0000644000175000017500000002226011527635055022644 0ustar  giovannigiovanniFri Feb 18 21:28:01 2011 run on win32
% Author: Alan Barnes 

psexplim 8;


6

% expand as far as 8th power (default is 6)

cos!-series:=ps(cos x,x,0);


                   1   2    1    4     1    6      1     8      9
cos-series := 1 - ---*x  + ----*x  - -----*x  + -------*x  + O(x )
                   2        24        720        40320

sin!-series:=ps(sin x,x,0);


                   1   3     1    5     1     7      9
sin-series := x - ---*x  + -----*x  - ------*x  + O(x )
                   6        120        5040

atan!-series:=ps(atan x,x,0);


                    1   3    1   5    1   7      9
atan-series := x - ---*x  + ---*x  - ---*x  + O(x )
                    3        5        7

tan!-series:=ps(tan x,x,0);


                   1   3    2    5    17    7      9
tan-series := x + ---*x  + ----*x  + -----*x  + O(x )
                   3        15        315


cos!-series*tan!-series;


     1   3     1    5     1     7      9
x - ---*x  + -----*x  - ------*x  + O(x )
     6        120        5040
        % should series for sin(x)
df(cos!-series,x);


        1   3     1    5     1     7      9
 - x + ---*x  - -----*x  + ------*x  + O(x )
        6        120        5040
              % series for sin(x) again

cos!-series/atan!-series;


 -1    1       77    3    313    5    104539    7      9
x   - ---*x - -----*x  + ------*x  - ---------*x  + O(x )
       6       360        3024        1814400
       % should be expanded


tmp:=ps(1/(1+x^2),x,infinity);


        1      1      1      1        1
tmp := ---- - ---- + ---- - ---- + O(----)
         2      4      6      8        9
        x      x      x      x        x

df(tmp,x);


      1        1        1        1
 - 2*---- + 4*---- - 6*---- + O(----)
       3        5        7        9
      x        x        x        x

ps(df(1/(1+x^2),x),x,infinity);


      1        1        1        1
 - 2*---- + 4*---- - 6*---- + O(----)
       3        5        7        9
      x        x        x        x


tmp*x;


  1      1      1      1        1
(---- - ---- + ---- - ---- + O(----))*x
   2      4      6      8        9
  x      x      x      x        x
  % not expanded as a single power series
ps(tmp*x,x,infinity);


 1     1      1      1        1
--- - ---- + ---- - ---- + O(----)
 x      3      5      7        9
       x      x      x        x
   % now expanded

ps(1/(a*x-b*x^2),x,a/b);


                              2                3                 4
    1        a  -1    b      b         a      b         a  2    b         a  3
 - ---*(x - ---)   + ---- - ----*(x - ---) + ----*(x - ---)  - ----*(x - ---)
    a        b         2      3        b       4        b        5        b
                      a      a                a                 a

     5                 6                 7                 8
    b         a  4    b         a  5    b         a  6    b         a  7
 + ----*(x - ---)  - ----*(x - ---)  + ----*(x - ---)  - ----*(x - ---)
     6        b        7        b        8        b        9        b
    a                 a                 a                 a

     9
    b          a  8           a  9
 + -----*(x - ---)  + O((x - ---) )
     10        b              b
    a
   % pole at expansion point

ps(cos!-series*x,x,2);


                                                                  2
2*cos(2) + (cos(2) - 2*sin(2))*(x - 2) - (cos(2) + sin(2))*(x - 2)

     - 3*cos(2) + 2*sin(2)         3    cos(2) + 2*sin(2)         4
 + ------------------------*(x - 2)  + -------------------*(x - 2)
              6                                12

    5*cos(2) - 2*sin(2)         5     - cos(2) - 3*sin(2)         6
 + ---------------------*(x - 2)  + ----------------------*(x - 2)
            120                              360

     - 7*cos(2) + 2*sin(2)         7    cos(2) + 4*sin(2)         8
 + ------------------------*(x - 2)  + -------------------*(x - 2)
             5040                             20160

            9
 + O((x - 2) )


tmp:=ps(x/atan!-series,x,0);


            1   2    4    4    44    6     428    8      9
tmp := 1 + ---*x  - ----*x  + -----*x  - -------*x  + O(x )
            3        45        945        14175

tmp1:=ps(atan!-series/x,x,0);


             1   2    1   4    1   6    1   8      9
tmp1 := 1 - ---*x  + ---*x  - ---*x  + ---*x  + O(x )
             3        5        7        9

tmp*tmp1;


1
               % should be 1, of course


cos!-sin!-series:=ps(cos sin!-series,x,0);


                       1   2    5    4    37    6     457    8      9
cos-sin-series := 1 - ---*x  + ----*x  - -----*x  + -------*x  + O(x )
                       2        24        720        40320

% cos(sin(x))
tmp:=cos!-sin!-series^2;


            2    2   4    14   6    37    8      9
tmp := 1 - x  + ---*x  - ----*x  + -----*x  + O(x )
                 3        45        315

tmp1:=ps((sin(sin!-series))^2,x,0);


         2    2   4    14   6    37    8      9
tmp1 := x  - ---*x  + ----*x  - -----*x  + O(x )
              3        45        315

tmp+tmp1;


       9
1 + O(x )
               % sin^2 + cos^2
psfunction tmp1;


           2
sin(sin(x))

% function represented by power series tmp1

tmp:=tan!-series^2;


        2    2   4    17   6    62    8      9
tmp := x  + ---*x  + ----*x  + -----*x  + O(x )
             3        45        315

psdepvar tmp;


x

% in case we have forgotten the dependent variable
psexpansionpt tmp;


0
      % .... or the expansion point
psterm(tmp,6);


 17
----
 45
  % select 6th term
psterm(tmp,10);


 1382
-------
 14175
 % select 10th term (series extended automtically)

tmp1:=ps(1/(cos x)^2,x,0);


             2    2   4    17   6    62    8      9
tmp1 := 1 + x  + ---*x  + ----*x  + -----*x  + O(x )
                  3        45        315

tmp1-tmp;


       9
1 + O(x )
       % sec^2-tan^2

ps(int(e^(x^2),x),x,0);


     1   3    1    5    1    7      9
x + ---*x  + ----*x  + ----*x  + O(x )
     3        10        42
 % integrator not called
tmp:=ps(1/(y+x),x,0);


        1     1        1    2    1    3    1    4    1    5    1    6    1    7
tmp := --- - ----*x + ----*x  - ----*x  + ----*x  - ----*x  + ----*x  - ----*x
        y      2        3         4         5         6         7         8
              y        y         y         y         y         y         y

           1    8      9
        + ----*x  + O(x )
            9
           y

ps(int(tmp,y),x,0);


          1        1     2     1     3     1     4     1     5     1     6
log(y) + ---*x - ------*x  + ------*x  - ------*x  + ------*x  - ------*x
          y          2           3           4           5           6
                  2*y         3*y         4*y         5*y         6*y

     1     7     1     8      9
 + ------*x  - ------*x  + O(x )
       7           8
    7*y         8*y
     % integrator called on each coefficient

pscompose(cos!-series,sin!-series);


     1   2    5    4    37    6     457    8      9
1 - ---*x  + ----*x  - -----*x  + -------*x  + O(x )
     2        24        720        40320

% power series composition cos(sin(x)) again
cos!-sin!-series;


     1   2    5    4    37    6     457    8      9
1 - ---*x  + ----*x  - -----*x  + -------*x  + O(x )
     2        24        720        40320

% should be same as previous result
psfunction cos!-sin!-series;


cos(sin(x))


tmp:=ps(log x,x,1);


                1         2    1         3    1         4    1         5
tmp := x - 1 - ---*(x - 1)  + ---*(x - 1)  - ---*(x - 1)  + ---*(x - 1)
                2              3              4              5

           1         6    1         7    1         8            9
        - ---*(x - 1)  + ---*(x - 1)  - ---*(x - 1)  + O((x - 1) )
           6              7              8

tmp1:=pscompose(tmp, cos!-series);


            1   2    1    4    1    6     17    8      9
tmp1 :=  - ---*x  - ----*x  - ----*x  - ------*x  + O(x )
            2        12        45        2520

% power series composition of log(cos(x))
df(tmp1,x);


        1   3    2    5    17    7      9
 - x - ---*x  - ----*x  - -----*x  + O(x )
        3        15        315
     % series for -tan x

psreverse tan!-series;


     1   3    1   5    1   7      9
x - ---*x  + ---*x  - ---*x  + O(x )
     3        5        7

% should be series for atan x
atan!-series;


     1   3    1   5    1   7      9
x - ---*x  + ---*x  - ---*x  + O(x )
     3        5        7

tmp:=ps(e^x,x,0);


                1   2    1   3    1    4     1    5     1    6     1     7
tmp := 1 + x + ---*x  + ---*x  + ----*x  + -----*x  + -----*x  + ------*x
                2        6        24        120        720        5040

             1     8      9
        + -------*x  + O(x )
           40320

psreverse tmp;


         1         2    1         3    1         4    1         5    1         6
x - 1 - ---*(x - 1)  + ---*(x - 1)  - ---*(x - 1)  + ---*(x - 1)  - ---*(x - 1)
         2              3              4              5              6

    1         7    1         8            9
 + ---*(x - 1)  - ---*(x - 1)  + O((x - 1) )
    7              8

% NB expansion of log x  in powers of (x-1)

pschangevar(tan!-series,y);


     1   3    2    5    17    7      9
y + ---*y  + ----*y  + -----*y  + O(y )
     3        15        315


end;


Time for test: 1 ms, plus GC time: 15 ms
@@@@@ Resources used: (0 0 12 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tps.tex0000644000175000017500000004244411526203062022652 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{Truncated Power Series}
\date{}
\author{Alan Barnes \\
Dept. of Computer Science and Applied Mathematics \\
Aston University, Aston Triangle, \\
Birmingham B4 7ET \\ GREAT BRITAIN \\
Email: barnesa@aston.ac.uk \\[0.1in]
and \\[0.1in]
Julian Padget \\
School of Mathematics, University of Bath \\
Claverton Down, Bath, BA2 7AY \\
GREAT BRITAIN \\
Email: jap@maths.bath.ac.uk}
\begin{document}
\maketitle
\index{power series} \index{truncated power series}
\index{Barnes, Alan} \index{Padget, Julian}
\section{Introduction}
\index{Power series expansions}
This package implements formal power series expansions in one
variable using the domain mechanism of REDUCE. This means that power
series objects can be added, multiplied, differentiated etc. like other
first class objects in the system. A lazy evaluation scheme is used in
the package and thus terms of the series are not evaluated until they
are required for printing or for use in calculating terms in other
power series. The series are extendible giving the user the impression
that the full infinite series is being manipulated.  The errors that
can sometimes occur using series that are truncated at some fixed depth
(for example when a term in the required series depends on terms of an
intermediate series beyond the truncation depth) are thus avoided.

Below we give a brief description of the operators available in the
power series package together with some examples of their use.

\subsection{PS Operator}

Syntax:

\noindent{\tt PS}(EXPRN:{\em algebraic},DEPVAR:{\em kernel},
ABOUT:{\em algebraic}):{\em ps object}

\index{PS operator}
The {\tt PS} operator returns a  power series object
(a tagged domain element)
representing the univariate formal power series expansion of EXPRN with
respect to the dependent variable DEPVAR about the expansion point
ABOUT.  EXPRN may itself contain power series objects.

The algebraic expression ABOUT should simplify to an expression
which is independent of the dependent variable DEPVAR, otherwise
an error will result.  If ABOUT is the identifier {\tt INFINITY}
then the power series expansion about DEPVAR = $\infty$ is
obtained in ascending powers of 1/DEPVAR.

\index{PSEXPLIM operator}
If the command is terminated by a semi-colon, a power series object
representing EXPRN is compiled and then a number of terms of the
power series expansion are evaluated and printed.  The expansion is
carried out as far as the value specified by {\tt PSEXPLIM}.  If,
subsequently, the value of {\tt PSEXPLIM} is increased, sufficient
information is stored in the power series object to enable the
additional terms to be calculated without recalculating the terms
already obtained.

If the command is terminated by a dollar symbol, a power series object
is compiled, but at most one term is calculated at this stage.

If the function has a pole at the expansion point then the correct
Laurent series expansion will be produced.

\noindent The following examples are valid uses of {\tt PS}:
\begin{verbatim}
    psexplim 6;
    ps(log x,x,1);
    ps(e**(sin x),x,0);
    ps(x/(1+x),x,infinity);
    ps(sin x/(1-cos x),x,0);
\end{verbatim}

\index{power series ! of user defined function}
New user-defined functions may be expanded provided the user provides
LET rules giving

\begin{enumerate}
\item the value of the function at the expansion point
\item a differentiation rule for the new function.
\end{enumerate}

\noindent For example
\begin{verbatim}
    operator sech;
    forall x let df(sech x,x)= - sech x * tanh x;
    let sech 0 = 1;
    ps(sech(x**2),x,0);
\end{verbatim}
 
\index{power series ! of integral}
The power series expansion of an integral may also be obtained (even if
REDUCE cannot evaluate the integral in closed form).  An example of
this is

\begin{verbatim}
    ps(int(e**x/x,x),x,1);
\end{verbatim}
 
Note that if the integration variable is the same as the expansion
variable then REDUCE's integration package is not called; if on the
other hand the two variables are different then the integrator is
called to integrate each of the coefficients in the power series
expansion of the integrand.  The constant of integration is zero by
default.   
 
\subsection{PSEXPLIM Operator}

\index{PSEXPLIM Operator}
Syntax:

\hspace*{2em} {\tt PSEXPLIM}(UPTO:{\em integer}):{\em integer}

\hspace*{4em} or

\hspace*{2em} {\tt PSEXPLIM}():{\em integer}

Calling this operator sets an internal variable of the
TPS package to the value of UPTO (which should evaluate to an integer).
The value returned is the previous value of this variable.
The default value is six.
 
If {\tt PSEXPLIM} is called with no argument, the current value for
the expansion limit is returned.
 

\subsection{PSORDLIM Operator}

\index{PSORDLIM operator}
Syntax:

\hspace*{2em} {\tt PSORDLIM}(UPTO:{\em integer}):{\em integer}

\hspace*{4em} or

\hspace*{2em} {\tt PSORDLIM}():{\em integer}

An internal variable is set to the value of {\tt UPTO} (which should
evaluate to an integer). The value returned is the previous value of
the variable.  The default value is 15.

If {\tt PSORDLIM} is called with no argument, the current value is
returned.

The significance of this control is that the system attempts to find
the order of the power series required, that is the order is the
degree of the first non-zero term in the power series.  If the order
is greater than the value of this variable an error message is given
and the computation aborts. This prevents infinite loops in examples
such as

\begin{verbatim}
        ps(1 - (sin x)**2 - (cos x)**2,x,0);
\end{verbatim}

where the expression being expanded is identically zero, but is not
recognized as such by REDUCE.


\subsection{PSTERM Operator}

\index{PSTERM operator}
Syntax:

\hspace*{2em} {\tt PSTERM}(TPS:{\em power series object},
NTH:{\em integer}):{\em algebraic}

The operator {\tt PSTERM} returns the NTH term of the existing
power series object TPS. If NTH does not evaluate to
an integer or TPS to a power series object an error results.  It
should be noted that an integer is treated as a power series.


\subsection{PSORDER Operator}

\index{PSORDER operator}
Syntax:

\hspace*{2em} {\tt PSORDER}(TPS:{\em power series object}):{\em integer}

The operator {\tt PSORDER} returns the order, that is the degree of
the first non-zero term, of the power series object TPS.
TPS should evaluate to a power series object or an error results. If
TPS is zero, the identifier {\tt UNDEFINED} is returned.

\subsection{PSSETORDER Operator}

\index{PSSETORDER operator}
Syntax:

\hspace*{2em} {\tt PSSETORDER}(TPS:{\em power series object},
ORD:{\em integer}):{\em integer}

The operator {\tt PSSETORDER} sets the order of the power series
TPS to the value ORD, which should evaluate to an integer. If
TPS does not evaluate to a power series object, then an error
occurs. The value returned by this operator is the previous order of
TPS, or 0 if the order of TPS was undefined.  This
operator is useful for setting the order of the power series of a
function defined by a differential equation in cases where the power
series package is inadequate to determine the order automatically.


\subsection{PSDEPVAR Operator}

\index{PSDEPVAR operator}
Syntax:

\hspace*{2em} {\tt PSDEPVAR}(TPS:{\em power series object})
:{\em identifier}

The operator {\tt PSDEPVAR} returns the expansion variable of the
power series object TPS. TPS should evaluate to a power
series object or an integer, otherwise an error results. If TPS
is an integer, the identifier {\tt UNDEFINED} is returned.

\subsection{PSEXPANSIONPT operator}

\index{PSEXPANSIONPT operator}
Syntax:

\hspace*{2em}
{\tt PSEXPANSIONPT}(TPS:{\em power series object}):{\em algebraic}

The operator {\tt PSEXPANSIONPT} returns the expansion point of the
power series object TPS. TPS should evaluate to a power
series object or an integer, otherwise an error results. If TPS
is integer, the identifier {\tt UNDEFINED} is returned. If the
expansion is about infinity, the identifier {\tt INFINITY} is
returned.

\subsection{PSFUNCTION Operator}

\index{PSFUNCTION operator}
Syntax:

\hspace*{2em}
{\tt PSFUNCTION}(TPS:{\em power series object}):{\em algebraic}

The operator {\tt PSFUNCTION} returns the function whose expansion
gave rise to the power series object TPS. TPS should
evaluate to a power series object or an integer, otherwise an error
results.

\subsection{PSCHANGEVAR Operator}

\index{PSCHANGEVAR operator}
Syntax:

\hspace*{2em} {\tt PSCHANGEVAR}(TPS:{\em power series object},
X:{\em kernel}):{\em power series object}

The operator {\tt PSCHANGEVAR} changes the dependent variable of the
power series object TPS to the variable X. TPS
should evaluate to a power series object and X to a kernel,
otherwise an error results.  Also X should not appear as a
parameter in TPS. The power series with the new dependent
variable is returned.

\subsection{PSREVERSE Operator}

\index{PSREVERSE operator}
Syntax:

\hspace*{2em}
{\tt PSREVERSE}(TPS:{\em power series object}):{\em power series}

Power series reversion.  The power series TPS is functionally
inverted.  Four cases arise:

\begin{enumerate}
\item If the order of the series is 1, then the expansion point of the
inverted series is 0. 

\item If the order is 0 {\em and} if the first order term in TPS
is non-zero, then the expansion point of the inverted series is taken
to be the coefficient of the zeroth order term in TPS.

\item If the order is -1 the expansion point of the inverted series
is the point at infinity.  In all other cases a REDUCE error is
reported because the series cannot be inverted as a power series.
Puiseux \index{Puiseux expansion} expansion would be required to
handle these cases. 

\item If the expansion point of TPS is finite it becomes the
zeroth order term in the inverted series. For expansion about 0 or the
point at infinity the order of the inverted series is one.
\end{enumerate}

If TPS is not a power series object after evaluation an error results.

\noindent Here are some examples:
\begin{verbatim}
        ps(sin x,x,0);
        psreverse(ws); % produces series for asin x about x=0.
        ps(exp x,x,0);
        psreverse ws; % produces series for log x about x=1.
        ps(sin(1/x),x,infinity);
        psreverse(ws); % series for 1/asin(x) about x=0.
\end{verbatim}

\subsection{PSCOMPOSE Operator}

\index{PSCOMPOSE operator}
Syntax:

\hspace*{2em} {\tt PSCOMPOSE}(TPS1:{\em power series},
TPS2:{\em power series}):{\em power series}

\index{power series ! composition}
{\tt PSCOMPOSE} performs power series composition.
The power series TPS1 and TPS2 are functionally composed.
That is to say that TPS2 is substituted for the expansion
variable in TPS1 and the result expressed as a power series. The
dependent variable and expansion point of the result coincide with
those of TPS2.  The following conditions apply to power series
composition:

\begin{enumerate}
\item If the expansion point of TPS1 is 0 then the order of the
TPS2 must be at least 1.

\item If the expansion point of TPS1 is finite, it should
coincide with the coefficient of the zeroth order term in TPS2.
The order of TPS2 should also be non-negative in this case.

\item If the expansion point of TPS1 is the point at infinity
then the order of TPS2 must be less than or equal to -1.

\end{enumerate}

If these conditions do not hold the series cannot be composed (with
the current algorithm terms of the inverted series would involve
infinite sums) and a REDUCE error occurs.

\noindent Examples of power series composition include the following.

\begin{verbatim}
    a:=ps(exp y,y,0);  b:=ps(sin x,x,0); 
    pscompose(a,b);
    % Produces the power series expansion of exp(sin x)
    % about x=0.

    a:=ps(exp z,z,1); b:=ps(cos x,x,0);
    pscompose(a,b);
    % Produces the power series expansion of exp(cos x)
    % about x=0.

    a:=ps(cos(1/x),x,infinity);  b:=ps(1/sin x,x,0);
    pscompose(a,b);
    % Produces the power series expansion of cos(sin x)
    % about x=0.
\end{verbatim}

\subsection{PSSUM Operator}

\index{PSSUM operator}
Syntax:

\begin{tabbing}
\hspace*{2em} {\tt PSSUM}(\=J:{\em kernel} = LOWLIM:{\em integer},
COEFF:{\em algebraic}, X:{\em kernel}, \\ 
\> ABOUT:{\em algebraic}, POWER:{\em algebraic}):{\em power series}
\end{tabbing}

The formal power series sum for J from LOWLIM to {\tt INFINITY} of 

\begin{verbatim}
      COEFF*(X-ABOUT)**POWER
\end{verbatim}

or if ABOUT is given as {\tt INFINITY}

\begin{verbatim}
      COEFF*(1/X)**POWER
\end{verbatim}

is constructed and returned. This enables power series whose general
term is known to be constructed and manipulated using the other
procedures of the power series package. 

J and X should be distinct simple kernels. The algebraics
ABOUT,  COEFF and POWER should not depend on the
expansion variable X, similarly the algebraic ABOUT should
not depend on the summation variable J.  The algebraic POWER should be
a strictly increasing integer valued function of J for J in the range
LOWLIM to {\tt INFINITY}.

\begin{verbatim}
   pssum(n=0,1,x,0,n*n);
   % Produces the power series summation for n=0 to
   % infinity of x**(n*n).

   pssum(m=1,(-1)**(m-1)/(2m-1),y,1,2m-1);
   % Produces the power series expansion of atan(y-1)
   % about y=1.

   pssum(j=1,-1/j,x,infinity,j);
   % Produces the power series expansion of log(1-1/x)
   % about the point at infinity.

   pssum(n=0,1,x,0,2n**2+3n) + pssum(n=1,1,x,0,2n**2-3n);
   % Produces the power series summation for n=-infinity
   % to +infinity of x**(2n**2+3n).
\end{verbatim}

\subsection{PSCOPY Operator}

\index{PSCOPY operator}
Syntax:

\hspace*{2em} {\tt PSCOPY}(TPS:{\em power series}):{\em power series}

This procedure returns a copy of the power series {\tt TPS}. The copy
has no shared sub-structures in common with the original series.  This
enables substitutions to be performed on the series without
side-effects on previously computed objects. For example:

\begin{verbatim}
    clear a;
    b := ps(sin(a*x)), x, 0);
    b where a => 1;
\end{verbatim}

will result in {\tt a} being set to 1 in each of the terms of the
power series and the resulting expressions being simplified. Owing to
the way power series objects are implemented using Lisp vectors, this
has the side-effect that the value of {\tt b} is changed.  This may be
avoided by copying the series with {\tt PSCOPY} before applying the
substitution, thus:

\begin{verbatim}
    b := ps(sin(a*x)), x, 0);
    pscopy b where a => 1;
\end{verbatim}

\subsection{PSTRUNCATE Operator}

\index{PSTRUNCATE operator}
Syntax:

\hspace*{2em} {\tt PSTRUNCATE}(TPS:{\em power series} POWER: {\em integer)}
:{\em algebraic}

This procedure truncates the power series {\tt TPS} discarding terms
of order higher than {\tt POWER}. The series is extended automtically
if the value of {\tt POWER} is greater than the order of last term
calculated to date.

\begin{verbatim}
    b := ps(sin x, x, 0);
    a := pstruncate(b, 11);
\end{verbatim}

will result in {\tt a} being set to the eleventh order polynomial
resulting in truncating the series for $sin x$ after the term
involving $x^{11}$. 

If {\tt POWER} is less than the order of the series then $0$ is
returned.  If {\tt POWER} does not simplify to an integer or if 
{\tt TPS} is not a power series object then Reduce errors result.

\subsection{Arithmetic Operations}

\index{power series ! arithmetic}
As power series objects are domain elements they may be combined
together in algebraic expressions in algebraic mode of REDUCE in the
normal way.
 
For example if A and B are power series objects then the commands
such as:

\index{+ ! power series} \index{- ! power series}
\index{/ ! power series} \index{* ! power series}
\index{** ! power series}
\begin{verbatim}
    a*b;
    a/b;
    a**2+b**2;
\end{verbatim}

will produce power series objects representing the product,quotient
and the sum of the squares of the power series objects A and B
respectively.
 
\subsection{Differentiation}

\index{power series ! differentiation}
If A is a power series object depending on X then the input
{\tt df(a, x);} will produce the power series expansion of the
derivative of A with respect to X.

{\em Note} however that currently the input  {\tt int(a, x);} will
not work as intended; instead one must input
{\tt ps(int(a, x),x,0);}
in order to obtain the power series expansion of the integral of
{\tt a}.

\section{Restrictions and Known Bugs}

If A is a power series object and X is a variable
which evaluates to itself then currently expressions such as {\tt a*x}
do not evaluate to a single power series object (although the 
result is formally valid).  Instead use {\tt ps(a*x,x,0)} {\em etc.}.

Similarly expressions such as {\tt sin(A)} where {\tt A} is a PS object
currently will not be expanded. For example:

\begin{verbatim}
    a:=ps(1/(1+x),x,0);
    b:=sin a;
\end{verbatim}

will not expand {\tt sin(1/(1+x))} as a power series. In fact

\begin{verbatim}
          SIN(1 - X + X**2 - X**3 + .....)
\end{verbatim}

will be returned. However,

\begin{verbatim} 
    b:=ps(sin(a),x,0);
\end{verbatim}

or

\begin{verbatim} 
    b:=ps(sin(1/(1+x)),x,0);
\end{verbatim}

should work as intended.

The handling of functions with essential singularities is currently
erratic: usually an error message

\hspace*{2em} {\tt ***** Essential Singularity}

or

\hspace*{2em} {\tt ***** Logarithmic Singularity}

occurs but occasionally a division by
zero error or some drastic error like (for PSL) binding stack
overflow may occur.
 
There is no simple way to write the results of power series
calculation to a file and read them back into REDUCE at a later
stage.
\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpssum.red0000644000175000017500000001134411526203062023344 0ustar  giovannigiovannimodule tpssum;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Written by Alan Barnes.  September 1990
% Allows power series whose general term is given to be manipulated.
%
%   pssum(=, , , , );
%
%         summation variable                  (a kernel)
%         lower limit of summation            (an integer)
%          general coefficient of power series (algebraic)
%         expansion variable of series        (a kernel)
%          expansion point of series           (algebraic)
%          general exponent of power series    (algebraic)
%  must be a strictly increasing function of 
%         this is now partially checked by the system


symbolic procedure ps!:summation!-erule(a,n);
begin scalar power, coeff,sumvar,current!-index,last!-exp,current!-exp;
   current!-index:= rand2 a;
   sumvar:= rand1 a; coeff := cdddr a;
   power:= cadr coeff; coeff:=car coeff;
   last!-exp:= ieval reval subst(current!-index,sumvar,power);
   repeat <<
     current!-index:=current!-index+1;
     current!-exp:= ieval reval subst(current!-index,sumvar,power);
     if current!-exp leq last!-exp then
       rerror(tps,39,"Exponent not strictly increasing: ps:summation");
     if  current!-exp < n then <<
         ps!:set!-term(ps,current!-exp,
                        simp!* subst(current!-index,sumvar,coeff));
         rplaca(cddr a,current!-index)>>;
     last!-exp:=current!-exp>>
   until current!-exp geq n;
   return if current!-exp = n then <<
              rplaca(cddr a,current!-index);
              simp!* subst(current!-index,sumvar,coeff) >>
          else (nil ./ 1)
end;

put('ps!:summation, 'ps!:erule, 'ps!:summation!-erule);
put('ps!:summation, 'simpfn, 'simpiden);
put('pssum, 'simpfn, 'simppssum);

symbolic procedure simppssum a;
begin scalar !*nosubs,from,sumvar,lowlim,coeff,
              power,depvar,about,psord,term;
   if length a neq 5 then rerror(tps,40,
   "Args should be ,,,,: simppssum");
   !*nosubs := t;  % We don't want left side of eqns to change.
   from := reval car a;
   !*nosubs := nil;
   if not eqexpr from then
      errpri2(car a,t)
   else <>;
   coeff:= prepsqxx simp!* cadr a;
   a:= cddr a;
   depvar := car a; about:=prepsqxx simp!* cadr a;
   if about = 'infinity then about := 'ps!:inf;
   power:= prepsqxx simp!* caddr a;
   if not kernp simp!* depvar then
        typerr(depvar, "kernel:  simppssum")
   else if depvar=sumvar then  rerror(tps,41,
           "Summation and expansion variables are the same:  simppssum")
   else if  smember(depvar,about) then
        rerror(tps,42,"Expansion point depends on depvar:  simppssum")
   else if  smember(sumvar,about) then rerror(tps,43,
            "Expansion point depends on summation var:  simppssum")
   else if not smember(sumvar,power) then rerror(tps,44,
         "Exponent does not depend on summation variable: simppssum");
   lowlim:=lowlim-1;
   repeat <<
     lowlim:=lowlim+1;
     psord:= ieval reval subst(lowlim,sumvar,power)>>
   until (term:=simp!* subst(lowlim,sumvar,coeff)) neq '(nil . 1);
   ps:=make!-ps(list('ps!:summation,sumvar,lowlim,coeff,power),
                list('ps!:summation,from,coeff,depvar,about,power),
                depvar, about);
   ps!:set!-order(ps,psord);
   ps!:set!-term(ps,psord, term);
   return (ps ./ 1)
end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tps/tpsfns.red0000644000175000017500000001026111526203062023323 0ustar  giovannigiovannimodule tpsfns;
% Expansion of elementary functions as power series using DOMAINVALCHK
% Example sin a where a is a power series will now be expanded
%
% Author: Alan Barnes, March 1989
% Currently only ps!:expt!: ever gets called and that only for
% integer exponents

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid '(!*numval);

put('exp, '!:ps!:, 'ps!:exp!:);
put('log, '!:ps!:, 'ps!:log!:);

put('sin, '!:ps!:, 'ps!:sin!:);
put('cos, '!:ps!:, 'ps!:cos!:);
put('tan, '!:ps!:, 'ps!:tan!:);

put('asin, '!:ps!:, 'ps!:asin!:);
put('acos, '!:ps!:, 'ps!:acos!:);
put('atan, '!:ps!:, 'ps!:atan!:);

put('sinh, '!:ps!:, 'ps!:sinh!:);
put('cosh, '!:ps!:, 'ps!:cosh!:);
put('tanh, '!:ps!:, 'ps!:tanh!:);

put('asinh, '!:ps!:, 'ps!:asinh!:);
put('acosh, '!:ps!:, 'ps!:acosh!:);
put('atanh, '!:ps!:, 'ps!:atanh!:);

put('expt, '!:ps!:, 'ps!:expt!:);

% the above is grotty but necessary as unfortunately DOMAINVALCHK
% passes arglist of sin (rather than sin . arglist) to ps!:sin!: etc

symbolic procedure ps!:expt!:(base,exp);
% currently this only gets called when exp is an integer
% but it should work in general
 begin scalar depvar,about, knownps, ps!:level;
% begin scalar !*numval, depvar,about, knownps;
% NB binding of !*numval avoids infinite loop. Not necessary now -- AB?
   ps!:level := 0;
   about:= ps!:expansion!-point base;
   if null about then <<
       about:= ps!:expansion!-point exp;
       depvar:=ps!:depvar exp>>
   else depvar:=ps!:depvar base;
   return
    if null about then    % we have two constant power series
      << if ps!:p base then base := ps!:value base;
         if ps!:p exp then exp := ps!:value exp;
         about := simp!* list('expt, base, exp);
         make!-constantps (about, prepsqxx about, depvar) >>
    else
      ps!:expt!-crule(list('expt, base,exp),depvar,about)
 end;


symbolic procedure ps!:unary!:fn(fn, arg);
 begin scalar !*numval, knownps, ps!:level;
% NB binding of !*numval avoids infinite loop
   ps!:level := 0;
   return ps!:compile(list(fn, arg),
                      ps!:depvar arg,
                      ps!:expansion!-point arg)
 end;

symbolic procedure ps!:cos!: arg;
  ps!:unary!:fn('cos,arg);

symbolic procedure ps!:sin!: arg;
  ps!:unary!:fn('sin,arg);

symbolic procedure ps!:tan!: arg;
  ps!:unary!:fn('tan,arg);

symbolic procedure ps!:log!: arg;
  ps!:unary!:fn('log,arg);

symbolic procedure ps!:exp!: arg;
  ps!:unary!:fn('exp,arg);

symbolic procedure ps!:cosh!: arg;
  ps!:unary!:fn('cosh,arg);

symbolic procedure ps!:sinh!: arg;
  ps!:unary!:fn('sinh,arg);

symbolic procedure ps!:tanh!: arg;
  ps!:unary!:fn('tanh,arg);

symbolic procedure ps!:asin!: arg;
  ps!:unary!:fn('asin,arg);

symbolic procedure ps!:acos!: arg;
  ps!:unary!:fn('acos,arg);

symbolic procedure ps!:atan!: arg;
  ps!:unary!:fn('atan,arg);

symbolic procedure ps!:asinh!: arg;
  ps!:unary!:fn('asinh,arg);

symbolic procedure ps!:acosh!: arg;
  ps!:unary!:fn('acosh,arg);

symbolic procedure ps!:atanh!: arg;
  ps!:unary!:fn('atanh,arg);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/0000755000175000017500000000000011722677357022034 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncdip.red0000644000175000017500000002066111526203062023606 0ustar  giovannigiovannimodule ncdip; % Non-commutative distributive polynomials.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


symbolic procedure ncdsetup!* u;
 % U is a list of algebraic arguments:
 % 1. list of variables,
 % 2. list of commutator relations in explicit form x*y=y*x + r
 %    where ord(r) < ord(x*y) .
 % All variable pairs whitch do not occur here are considered
 % communtative.
  begin scalar x,y,w,vars,lh,z,lv,r,q;
    vars := for each x in cdr listeval(car u,nil)
       collect reval x;
    ncdipcircular!*:=nil;
    if null vdpsortmode!* then vdpsortmode!*:= 'lex;
    vdpinit2 (ncdipvars!*:=vars);
    lv:=length vars;
    ncdipbase!*:=mkvect lv;
    ncdiptable!*:=mkvect lv;
    for i:=1:lv do putv(ncdiptable!*,i,mkvect lv);
    q:=cdr listeval(cadr u,nil);
    while q do
    <>
       else typerr(r,"commutator ")>>end;

symbolic procedure ncdipndx(x,vars,n);
if null vars then 0 else if x=car vars then n else ncdipndx(x,cdr vars,n #+ 1);

%------------ noncom multiply ----------------------------

symbolic procedure vdp!-nc!-m!*p(bc,ev,p);
  % multiply polynomial p left by monomial (bc,ev).
  begin scalar r,s;
   r:=dip2vdp dip!-nc!-m!*p(bc,ev,vdppoly p);
   if !*gsugar then
   <>;
   return r end;

symbolic procedure vdp!-nc!-prod(u,v);
  % non-commutative product of two distributive polynomials.
  begin scalar r;
   r:=dip2vdp dip!-nc!-prod(vdppoly u,vdppoly v);
   if !*gsugar then r:=gsetsugar(r,gsugar u + gsugar v);
   return r end;

symbolic procedure dip!-nc!-prod(u,v);
  % We distribute first over the shorter of the two factors.
  if length u < length v then dip!-nc!-prod!-distleft(u,v)
        else dip!-nc!-prod!-distright(u,v);

symbolic procedure dip!-nc!-prod!-distleft(u,v);
  if dipzero!? u then u else
   dipsum(dip!-nc!-m!*p!-distleft(diplbc u,dipevlmon u,v),
          dip!-nc!-prod!-distleft(dipmred u,v));

symbolic procedure dip!-nc!-m!*p!-distleft(bc,ev,p);
   if dipzero!? p then nil else
   begin scalar lev,lbc,q;
     lev:=dipevlmon p;lbc:=diplbc p;
     p:=dip!-nc!-m!*p!-distleft(bc,ev,dipmred p);
     q:=dip!-nc!-ev!-prod(bc,ev,lbc,lev);
     return dipsum(p,q)end;

symbolic procedure dip!-nc!-prod!-distright(u,v);
  if dipzero!? v then v else
   dipsum(dip!-nc!-m!*p!-distright(u,diplbc v,dipevlmon v),
          dip!-nc!-prod!-distright(u,dipmred v));

symbolic procedure dip!-nc!-m!*p!-distright(p,bc,ev);
   if dipzero!? p then nil else
   begin scalar lev,lbc,q;
     lev:=dipevlmon p;lbc:=diplbc p;
     p:=dip!-nc!-m!*p!-distright(dipmred p,bc,ev);
     q:=dip!-nc!-ev!-prod(lbc,lev,bc,ev);
     return dipsum(p,q)end;

symbolic procedure dip!-nc!-ev!-prod(bc1,ev1,bc2,ev2);
  % compute (bc1*ev1) * (bc2*ev2). Result is a dip.
   dip!-nc!-ev!-prod1(ev1,1,dipfmon(bcprod(bc1,bc2),ev2));

symbolic procedure dip!-nc!-ev!-prod1(ev,n,r);
  % loop over ev and n (counter). NOTE: ev must be processed from right to left!
   if null ev then r else
      dip!-nc!-ev!-prod2(car ev,n,dip!-nc!-ev!-prod1(cdr ev,n#+1,r));


symbolic procedure dip!-nc!-ev!-prod2(j,n,r);
  % muliply x_n^j * r
  if j=0 or dipzero!? r then r else
 begin scalar ev,bc,r0,w,s,evl,evr;integer i;
    ev:=dipevlmon r;bc:=diplbc r;
    r:=dip!-nc!-ev!-prod2(j,n,dipmred r);
     % collect the variables in ev which do not commute with x_n;
    w:=getv(ncdipbase!*,n);
    while w and nth(ev,car w)=0 do w:=cdr w;
     % no commutator?
    if null w then
      <>;
     % We handle now the leftmost commutator and
     % push the rest of the problem down to the recursion:
     % split the monmial into parts left and
     % right of the noncom variable and multiply these.
    w:=car w;s:=nth(ev,w);
     % Split the ev into left and right part.
    i:=0;for each e in ev do <>
          else if i=w then <>
          else             <> >>;
    evl:=reversip evl;evr:=reversip evr;
    r0:=dip!-nc!-get!-commutator(n,j,w,s);
         % multiply by left exponent
    r0:=if ncdipcircular!* then
       <> else
       <>;
  done:return dipsum(r0,r)end;

symbolic procedure dip!-nc!-get!-commutator(n1,e1,n2,e2);
  % Compute the commutator for y^e1*x^e2 where y is
  % the n1-th variable and x is the n2-th variable.
  % The commutators for power products are computed
  % recursively when needed. They are stored in a data base.
  % I assume here that the commutator for (1,1) has been
  % put into the data base before. We update the table
  % in place by nconc-ing new pairs to its end.
  begin scalar w,r,p;
    w:=getv(getv(ncdiptable!*,n1),n2);p:=e1.e2;
    if (r:=assoc(p,w)) then return cdr r;
      % compute new commutator recursively:
      % first e1 downwards, then e2
    r:=if e1>1 then
      % compute y^e1*x^e2 as  y*(y^(e1-1)*x^e2)
       dip!-nc!-ev!-prod2(1,n1,dip!-nc!-get!-commutator(n1,e1#-1,n2,e2))
     else
      % compute y*x^e2 as (y*x^(e2-1))*x
       dip!-nc!-prod(dip!-nc!-get!-commutator(n1,1,n2,e2#-1),dipfvarindex n2);
    nconc(w,{(p.r)});
    return r end;

symbolic procedure dipfvarindex n;
  % Make a dip from a single variable index.
a2dip nth(dipvars!*,n);


symbolic procedure dipevadd1var(e,n,ev);
  % add e into the nth position of ev.
if null ev or n<1 then ev else
 if n=1 then (car ev #+ e).cdr ev else car ev.dipevadd1var(e,n#-1,cdr ev);

% ------------ conversion algebraic => nc dip --------------

symbolic procedure a2ncdip a;
  if atom a then a2dip a else
  if car a = 'difference then
   a2ncdip{'plus,cadr a,{'times,-1,caddr a}} else
  if car a = 'minus then
   a2ncdip{'times,-1,cadr a} else
  if car a='expt and fixp caddr a then
   a2ncdip('times.for i:=1:caddr a collect cadr a) else
  if car a='plus then
   begin scalar r;
     r:=a2ncdip cadr a;
     for each w in cddr a do r:=dipsum(r,a2ncdip w);
     return r end  else
  if car a='times then
   begin scalar r;
     r:=a2ncdip cadr a;
     for each w in cddr a do r:=dip!-nc!-prod(r,a2ncdip w);
     return r end  else
  if car a='!*sq then a2ncdip prepsq cadr a else a2dip a;

symbolic procedure a2ncvdp a;dip2vdp a2ncdip a;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncpoly.tex0000644000175000017500000002531411526203062024043 0ustar  giovannigiovanni\documentstyle[11pt,reduce]{article}
\title{NCPOLY: Computation in non--commutative polynomial ideals}
\date{}
\author{
Herbert Melenk\\[0.05in]
Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
Takustrasse 7 \\
D--14195 Berlin -- Dahlem \\
Germany \\[0.05in]
E--mail: melenk@zib.de \\[0.1in]
Joachim Apel\\[0.05in]
Institut f\"ur Informatik \\[0.05in]
Universit\"at Leipzig \\[0.05in]
Augustusplatz 10--11\\[0.05in]
D--04109 Leipzig \\[0.05in]
Germany \\[0.05in]
E--mail: apel@informatik.uni--leipzig.de \\[0.05in]
}

\begin{document}
\maketitle

\index{Groebner Bases}
\section{Introduction}

{\small REDUCE} supports a very general mechanism for computing
with objects under a non--commutative multiplication, where
commutator relations must be introduced explicitly by rule
sets when needed. The package {\bf NCPOLY} allows you to
set up automatically a consistent environment for computing in an algebra
where the non--commutativity is defined by Lie-bracket commutators.
The package uses the {\small REDUCE} {\bf noncom}
mechanism for elementary polynomial arithmetic; the commutator
rules are automatically computed from the Lie brackets.
You can perform polynomial arithmetic directly, including
{\bf division} and {\bf factorization}.
Additionally {\bf NCPOLY} supports computations in a one sided ideal (left or right),
especially one sided {\bf Gr\"obner} bases and {\bf polynomial reduction}.

\section{Setup, Cleanup}

Before the computations can start the environment for a
non--commutative computation must be defined by a
call to {\bf nc\_setup}:
\begin{verbatim}
    nc_setup([,][,
    ]);
\end{verbatim}
where

$$ is a list of variables; these must include the
non--commutative quantities.

$$ is a list of equations \verb&* - *=&
where $$ and $$ are members of $$, and $$ is
a polynomial.

$$ is either $left$ or $right$ selecting a left or a
right one sided ideal. The initial direction is $left$.

{\bf nc\_setup} generates from $$ the necessary
rules to support an algebra where all monomials are
ordered corresponding to the given variable sequence.
All pairs of variables which are not explicitly covered in
the commutator set are considered as commutative and the
corresponding rules are also activated.

The second parameter in {\bf nc\_setup} may be
omitted if the operator is called for the second time,
e.g. with a reordered variable sequence. In such a case
the last commutator set is used again.

Remarks: \begin{itemize}
\item The variables need not be declared {\bf noncom} -
    {\bf nc\_setup} performs all necessary declarations.
\item The variables need not be formal operator expressions;
    {\bf nc\_setup} encapsulates a variable $x$ internally
    as \verb+nc!*(!_x)+ expressions anyway where the operator $nc!*$
    keeps the noncom property.
\item The commands {\bf order} and {\bf korder} should be avoided
    because {\bf nc\_setup} sets these such that the computation
    results are printed in the correct term order.
\end{itemize}

Example:
\begin {verbatim}
   nc_setup({KK,NN,k,n},
              {NN*n-n*NN= NN, KK*k-k*KK= KK});

   NN*n;            ->   NN*n
   n*NN;            ->   NN*n - NN
   nc_setup({k,n,KK,NN});
   NN*n - NN        ->   n*NN;

\end{verbatim}
Here $KK,NN,k,n$ are non--commutative variables where
the commutators are described as $[NN,n]=NN$, $[KK,k]=KK$.

The current term order must be compatible with the commutators:
the product $*$ must precede all terms on the right hand
side $$ under the current term order. Consequently
\begin{itemize}
\item the maximal degree of $$ or $$ in $$ is 1,
\item in a total degree ordering the total degree of $$ may be
not higher than 1,
\item in an elimination degree order (e.g. $lex$) all variables in
$$ must be below the minimum of $$ and $$.
\item If $$ does not contain any variables or has at most $$ or
$$, any term order can be selected.
\end{itemize}

If you want to use the non--commutative variables or results from
non--commutative computations later in commutative operations
it might be necessary to switch off the non--commutative
evaluation mode because not
all operators in REDUCE are prepared for that environment. In
such a case use the command
\begin{verbatim}
    nc_cleanup;
\end{verbatim}
without parameters. It removes all internal rules and definitions
which {\bf nc\_setup} had introduced. To reactive non--commutative
call {\bf nc\_setup} again.

\section{Left and right ideals}

A (polynomial) left ideal $L$ is defined by the axioms

$u \in L, v \in L \Longrightarrow u+v \in L$

$u \in L \Longrightarrow k*u \in L$ for an arbitrary polynomial $k$

where ``*'' is the non--commutative multiplication. Correspondingly,
a right ideal $R$ is defined by

$u \in R, v \in R \Longrightarrow u+v \in R$

$u \in R \Longrightarrow u*k \in R$ for an arbitrary polynomial $k$

\section{Gr\"obner bases}

When a non--commutative environment has been set up
by {\bf nc\_setup}, a basis for a left or right polynomial ideal
can be transformed into a Gr\"obner basis by the operator
{\bf nc\_groebner}:
\begin{verbatim}
   nc_groebner();
\end{verbatim}
Note that the variable set and variable sequence must be
defined before in the {\bf nc\_setup} call. The term order
for the Gr\"obner calculation can be set by using the
{\bf torder} declaration. The internal steps of the
Gr\"obner calculation can be watched by setting the
switches {\bf trgroeb} (=list all internal basis polynomials)
or {\bf trgroebs} (=list additionally the $S$-polynomials)
\footnote{The command \verb+lisp(!*trgroebfull:=t);+ causes additionally
all elementary polynomial operations to be printed.}.


For details about {\bf torder}, {\bf trgroeb} and {\bf trgroebs}
see the {\bf {\small REDUCE} GROEBNER} manual.
\begin{verbatim}
2: nc_setup({k,n,NN,KK},{NN*n-n*NN=NN,KK*k-k*KK=KK},left);

3: p1 := (n-k+1)*NN - (n+1);

p1 :=  - k*nn + n*nn - n + nn - 1

4: p2 := (k+1)*KK -(n-k);

p2 := k*kk + k - n + kk

5: nc_groebner ({p1,p2});

{k*nn - n*nn + n - nn + 1,

 k*kk + k - n + kk,

 n*nn*kk - n*kk - n + nn*kk - kk - 1}

\end{verbatim}
Important: Do not use the operators of the GROEBNER
package directly as they would not consider the non--commutative
multiplication.

\section{Left or right polynomial division}

The operator {\bf nc\_divide} computes the one sided quotient and remainder of
two polynomials:
\begin{verbatim}
    nc_divide(,);
\end{verbatim}
The result is a list with quotient and remainder.
The division is performed as a pseudo--division, multiplying
$$ by coefficients if necessary. The result $\{,\}$
is defined by the relation

  $*=* + $ for direction $left$ and

  $*=* + $ for direction $right$,

where $$ is an expression that does not contain any of the
ideal variables, and the leading term of $$ is lower than
the leading term of $$ according to the actual term order.

\section{Left or right polynomial reduction}

For the computation of the one sided remainder of a polynomial
modulo a given set of other polynomials the operator
{\bf nc\_preduce} may be used:
\begin{verbatim}
    nc_preduce(,);
\end{verbatim}
The result of the reduction is unique (canonical) if
and only if $$ is a one sided Gr\"obner basis.
Then the computation is at the same time an ideal
membership test: if the result is zero, the
polynomial is member of the ideal, otherwise not.

\section{Factorization}

\subsection{Technique}

Polynomials in a non--commutative ring cannot be factored
using the ordinary {\bf factorize} command of {\small REDUCE}.
Instead one of the operators of this section must be used:
\begin{verbatim}
   nc_factorize();
\end{verbatim}
The result is a list of factors of $$. A list
with the input expression is returned if it is irreducible.

As non--commutative factorization is not unique, there is
an additional operator which computes all possible factorizations
\begin{verbatim}
   nc_factorize_all();
\end{verbatim}
The result is a list of factor decompositions of $$.
If there are no factors at all the result list has only one
member which is a list containing the input polynomial.

\subsection{Control of the factorization}

In contrast to factoring in commutative polynomial rings, the non--commutative
factorization is rather time consuming. Therefore two additional
operators allow you to reduce the amount of computing time when
you look only for isolated factors in special context, e.g. factors
with a limited degree or factors which contain only explicitly
specified variables:
\begin{verbatim}
    left_factor([,[,]])
   right_factor([,[,]])
    left_factors([,[,]])
   right_factors([,[,]])
\end{verbatim}
where $$ is the form under investigation,
$$ is an optional list of variables which must appear in the
factor, and $$
is an optional integer degree bound for the total degree of the
factor, a zero for an unbounded search, or a monomial
(product of powers of the variables) where each exponent
is an individual degree bound for its base variable; unmentioned
variables are allowed in arbitrary degree. The operators
$*\_factor$ stop when they have found one factor, while
the operators $*\_factors$ select all one--sided factors
within the given range. If there is no factor of the
desired type, an empty list is returned by $*\_factors$
while the routines $*\_factor$ return the input polynomial.

\subsection{Time of the factorization}

The share variable $nc\_factor\_time$ sets an upper limit
for the time to be spent for a call to the non--commutative
factorizer. If the value is a positive integer, a
factorization is terminated with an error message as soon
as the time limit is reached. The time units are milliseconds.

\subsection{Usage of SOLVE}

The factorizer internally uses $solve$, which is controlled
by the \REDUCE \ switch $varopt$. This switch (which per default
is set $on$) allows, to reorder the variable sequence, which is
favourable for the normal system. It should be avoided to set $varopt$
$off$, when using the non--commutative factorizer, unless very small
polynomials are used.

\section{Output of expressions}

It is often desirable to have the commutative parts (coefficients)
in a non--commutative operation condensed by factorization. The operator
\begin{verbatim}
   nc_compact()
\end{verbatim}
collects the coefficients to the powers of the lowest possible
non-commutative variable.
\begin{verbatim}
load ncpoly;

nc_setup({n,NN},{NN*n-n*NN=NN})$
p1 := n**4 + n**2*nn + 4*n**2 + 4*n*nn + 4*nn + 4;

       4    2         2
p1 := n  + n *nn + 4*n  + 4*n*nn + 4*nn + 4

nc_compact p1;

  2     2          2
(n  + 2)  + (n + 2) *nn
\end{verbatim}
\end{document}

mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncpoly.rlg0000644000175000017500000000617111527635055024043 0ustar  giovannigiovanniFri Feb 18 21:27:56 2011 run on win32
nc_setup({k,n,NN,KK},{NN*n-n*NN=NN,KK*k-k*KK=KK},left);



 p1 := (n-k+1)*NN - (n+1);


p1 :=  - k*nn + n*nn - n + nn - 1

 p2 := (k+1)*KK -(n-k);


p2 := k*kk + k - n + kk

 l_g:=nc_groebner ({p1,p2});


l_g := {k*nn - n*nn + n - nn + 1,

        k*kk + k - n + kk,

        n*nn*kk - n*kk - n + nn*kk - kk - 1}


 nc_preduce(p1+p2,l_g);


0


 nc_divide  (k*p1+p2,p1);


{k,k*kk + k - n + kk}

 nc_divide  (k*p1+p2,2*p1);


{k,2*k*kk + 2*k - 2*n + 2*kk}

 nc_divide  (2*k*k*p1 + k*p1 + p2,2*p1);


    2
{2*k  + k,

 2*k*kk + 2*k - 2*n + 2*kk}

 
 nc_factorize (p1*p2);


{ - k*nn + n*nn - n + nn - 1,

 k*kk + k - n + kk}


nc_setup({k,n,NN,KK},{NN*n-n*NN=NN,KK*k-k*KK=KK},right);


nc_factorize (p1*p2);


{ - k*nn + n*nn - n + nn - 1,

 k*kk + k - n + kk}


% applications to shift operators

nc_setup({n,NN},{NN*n-n*NN=1},left);


n*NN;


n*nn

nc_factorize(ws);


{n,nn}

nc_setup({n,NN},{NN*n-n*NN=1},right);


n*NN;


n*nn

nc_factorize(ws);


{n,nn}

nc_setup({NN,n},{NN*n-n*NN=1},right);


n*NN;


nn*n - 1

nc_factorize(ws);


{n,nn}

nc_setup({NN,n},{NN*n-n*NN=1},left);


n*NN;


nn*n - 1

nc_factorize(ws);


{n,nn}


% Applications to partial differential equations

nc_setup({x,Dx},{Dx*x-x*Dx=1});



p:= 2*Dx^2 + x* Dx^3 + 3*x*Dx + x^2*Dx^2 + 14 + 7*x*Dx;


      2   2       3                 2
p := x *dx  + x*dx  + 10*x*dx + 2*dx  + 14

nc_factorize p;


                   2
{x*dx + 2,x*dx + dx  + 7}

right_factor(p,1);


 2   2       3                 2
x *dx  + x*dx  + 10*x*dx + 2*dx  + 14
 % no factor of degr 1
right_factor(p,2);


         2
x*dx + dx  + 7

left_factor(p,2);


x*dx + 2


nc_setup({x,Dx},{Dx*x-x*Dx=1});



q := x**2*dx**2 + 2*x**2*dx + x*dx**3 + 2*x*dx**2 
    + 8*x*dx + 16*x + 2*dx**2 + 4*dx$



nc_factorize q;


          2
{x*dx + dx  + 7,

 x,

 dx + 2}

right_factor(q,1);


dx + 2

right_factor(q,1,{x});


 2   2      2          3         2                       2
x *dx  + 2*x *dx + x*dx  + 2*x*dx  + 8*x*dx + 16*x + 2*dx  + 4*dx
  % no such right factor
right_factor(q,1,{dx});


dx + 2


% looking for factor with degree bound for an individual variable

q := x**6*dx + x**5*dx**2 + 12*x**5 + 10*x**4*dx + 20*x**3 
+ x**2*dx**3 - x**2*dx**2 + x*dx**4 - x*dx**3 + 8*x*dx**2 
- 8*x*dx + 2*dx**3 - 2*dx**2$



right_factor(q,dx);


 6       5   2       5       4          3    2   3    2   2       4       3
x *dx + x *dx  + 12*x  + 10*x *dx + 20*x  + x *dx  - x *dx  + x*dx  - x*dx

         2                3       2
 + 8*x*dx  - 8*x*dx + 2*dx  - 2*dx

right_factor(q,dx^2);


 4     2
x  + dx  - dx


% some coefficient sports
nc_setup({NN,n},{NN*n-n*NN=1},left);


q:=(n*nn)^2;


       2  2
q := nn *n  - 3*nn*n + 1

nc_factorize q;


{n,

 nn,

 n,

 nn}

nc_preduce(q,{c1+c2*n + c3*nn + c4*n*nn});


   2       2                        2        2          2      2
(c3 *c4)*nn  + (2*c1*c3*c4 - 2*c2*c3  + c3*c4 )*nn + (c2 *c4)*n

                     2           2         2
 + (2*c1*c2*c4 - 2*c2 *c3 - c2*c4 )*n + (c1 *c4 - 2*c1*c2*c3 + c2*c3*c4)

nc_divide(q,n);


   2
{nn *n - 3*nn,1}


nc_cleanup;



end;


Time for test: 1154 ms, plus GC time: 141 ms
@@@@@ Resources used: (2 26 6 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncfactor.red0000644000175000017500000003430011526203062024303 0ustar  giovannigiovannimodule ncfactor;  % factorization for non-commutative polynomials.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% version 1.4: using the commutative factorizer as preprocessor.
% Oct 2001: using "sove", hoping, that the user did not switch off 'varopt'.

share nc_factor_time;    % time limit in milliseconds.

nc_factor_time:=0;

algebraic operator cc!*;

symbolic procedure nc_factorize u;
 begin scalar r,o,!*gsugar,comm,cr,cl;
   o:=apply1('torder,'(gradlex));
   nc!-gsetup();
   comm := nc_commfactors!* u;
   cl:=car comm; u:=cadr comm;cr:=caddr comm;
   if constant_exprp u then (if u neq 1 then cl:=u.cl)
      else
     r:=for each p in nc_factorize0(a2ncvdp u,nil,nil,nil,nil,nil)
          collect num vdp2a p;
   o:=apply1('torder,{o});
   return'list.append(cl,append(r,cr))end;

symbolic operator nc_factorize;

% copyd('nc_commfactors!*,'nc_commfactors);
symbolic procedure nc_commfactors u;
 begin scalar o,!*gsugar,comm,cr,cl;
   o:=apply1('torder,'(gradlex));
   nc!-gsetup();
   comm:=nc_commfactors!* u;
   cl:=car comm;u:=cadr comm;cr:=caddr comm;
   o:=apply1('torder,{o});
   return{'list,'list.cl,u,'list.cr}end;

symbolic operator nc_commfactors;

symbolic procedure nc_commfactors!* u;
 (begin scalar f,ff,uu,comm,l,crl,cll,!*ncg!-right,w;
   uu:=sublis(ncpi!-names!*,numr simp u);
   comm:=(fctrf reorder uu) where ncmp!*=nil;
   if null cddr comm and cdadr comm=1 then
   <>;
   l:=for each f in cdr comm join
     for i:=1:cdr f collect reval prepf car f;
   if !*trnc then writepri("testing commutative factors:",'only);
   uu:=a2ncvdp u;
   while l do
   <>
     else
     if vdpzero!? cdr<>
       then<>
     else if !*trnc then writepri(" -- discarded",'last)>>;
  if null crl and null cll then go to no_comm;
  u:=vdp2a uu;
  if !*trnc then
    <>;
 no_comm:return {crl,u,cll};
 end)where right=!*ncg!-right;

symbolic procedure nc_dir();if !*ncg!-right then " right" else " left";

symbolic procedure oneside!-factor(w,m,all);
 % NOTE: we must perform a factorization based on left
 % division (m='l) for obtaining a right factor.
 begin scalar u,d,r,mx,o,!*gsugar;
    % preprocessing for psopfn.
  d:=r:=0;
  u:=reval car w;
  if cdr w then<>;
    % preparing for the altorithm.
  o:=apply1('torder,'(gradlex));
  nc!-gsetup();
  if r=0 or r='(list)then r:=nil else
  <>;
  d:=reval d;
  if d=0 then d:=1000 else if not fixp d then<>;
  r:=nc_factorize0(a2ncvdp u,m,d,r,mx,all);
  o:=apply1('torder,{o});
  return for each w in r collect num vdp2a w end;

put('left_factor,'psopfn,
     function (lambda(w);<>));

put('left_factors,'psopfn,
     function (lambda(w);'list. oneside!-factor(w,'r,t)));

put('right_factor,'psopfn,
     function (lambda(w);<>));

put('right_factors,'psopfn,
     function (lambda(w);'list.oneside!-factor(w,'l,t)));

algebraic procedure nc_factorize_all u;
  % Compute all possible factorizations based on successive
  % right factor extraction.
 begin scalar !*ncg!-right,d,f,w,wn,q,r,trnc,nc_factor_time!*;
   nc_factor_time!*:=lisp time();
   trnc:=lisp !*trnc;lisp(!*trnc:=nil);
   w:={{u}};r:={};lisp(!*ncg!-right:=nil);
 loop:if w={} then go to done;
   lisp(wn:='(list));
   for each c in w do
   <>>>;
   w:=wn; go to loop;
 done:lisp(!*trnc:=trnc);
   return r end;

symbolic procedure nc_factorize0(u,m,d,rs,mx,all);
 <>where nc_factor_time!*=nc_factor_time!*;

symbolic procedure nc_factorize1(u,m,d,rs,mx,all);
 % split all left(right) factor of u off.
 % u:  polynomial,
 % m:  mode: restriction for left or right factor:
 % d:  maximum degree restriction,
 % r:  variable set restriction (r is an exponent vector).
 % mx: maximum exponent for each variable (is an exponent vector).
 % all: true if we look for all right(left) factors.
 begin scalar ev,evl,evlx,f,ff,!*ncg!-right;
  nc_factorize_timecheck();
  mx:=if null mx then for each y in vdpvars!* collect 1000 else
    for each y in mx collect if y>0 then y else 1000;
  if !*trnc then<>;
  ev:=vdpevlmon u;
  if vevzero!? ev then return{u};
  d:=d or vevtdeg ev/2;
  evlx:=sort(nc_factorize1!-evl ev,function(lambda(x,y);vevcomp(x,y)<0));
  if m='r then go to r;
    % factors up to n
  evl:=evlx;
  while (null f or all) and evl and vevtdeg car evl<=d do
  <>;
  if f or m='l then go to c;
    % right factors up to tdg-n
  d:=vevtdeg ev -d;
r:!*ncg!-right:=t;
  evl:=evlx;
  while (null f or all)and evl and vevtdeg car evl<=d do
  <>;
c:if null f then return if m then nil else{u};
  if all then return f;
    % only one factor wanted?
  if m then return{cdr f};
  ff:=nc_factorize1(car f,nil,nil,nil,mx,all);
  return if !*ncg!-right then append({cdr f},ff)else append(ff,{cdr f})end;

symbolic procedure nc_factorize1!-evl u;
  % Collect all monomials dividing u.
   if null u then'(nil) else
   (for i:=0:car u join
     for each e in w collect i.e)where w=nc_factorize1!-evl cdr u;

algebraic operator ncc!@;

symbolic procedure nc_factorize2(u,ev,rs,mx,all);
  begin scalar ar,p,q,vl,r,s,so,sol,w,y;integer n;
   scalar !*bcsubs2;
   nc_factorize_timecheck();
   p:=a2dip 0;
   if !*trnc then
   < ";
     vdpprin2 vdpfmon(a2bc 1,ev);
     prin2 " < time so far:";
     prin2 (time()-nc_factor_time!*);
     prin2t "ms">>;
     % establish formal Ansatz.
   for each e in nc_factorize2evl(ev,rs,mx) do
   <>;
   w:=p;
   while not dipzero!? w do<>;
   vl:=reversip vl;
   p:=dip2vdp p;
     %  prin2 "complete Ansatz:";vdpprint p;
     % pseudo division.
   r:=nc!-normalform(u,{p},nil,nil);
   nc_factorize_timecheck();
   while not vdpzero!? r do<>;
   if !*trnc then
   <>;
     % solve system
     % 1. look for a free variable:
     %###### but that must be the leading variable!!!
   for each v in vl do if not smember(v,s) then so:=v;
   if !*trnc and so then<>;
   if so then sol:={(so.1).for each v in vl collect v.0};
   if null sol or all then sol:=append(sol,nc_factsolve(s,vl,all));
   if null sol then return nil;
   if !*trnc then
   <>;
   % prin2 "check internal solution:";
   % for each e in s do writepri(mkquote aeval sublis(so,e),'only);
   >>;
coll:nc_factorize_timecheck();
   so:=car sol;sol:=cdr sol;
   y:=dip2vdp dippolish dipsubf(so,vdppoly p);
     % leading term preserved?
  % if vdpevlmon y neq vdpevlmon p then
   %  return nil;
   %  prin2 "computed factor:";vdpprint y;
   if vevzero!? vdpevlmon y then
      if not all then return nil else
      if sol then go to coll else go to done_all;
     % turn on bcsubs2 if there is an algebraic number.
   if smemq('expt,y) or smemq('sqrt,y) or smemq('root_of,y) then !*bcsubs2:=t;
   w:=nc!-qremf(u,y);
   if not vdpzero!? cdr w then
    < ";vdpprint car w;
      prin2 "rem: ";vdpprint cdr w;
       rederr "noncom factorize">>;
   if !*trnc then
   < ";
     vdpprin2 car w;prin2t " < and";prin2 " > ";
     vdpprin2 y;prin2t " <";terpri()>>;
   ar:=y.ar;
   if all then if sol then go to coll else go to done_all;
done_one:return car w.y;
done_all:return ar end;

symbolic procedure nc_factsolve(s,vl,all);
  begin scalar v,sb,ns,so,soa,sol,nz,w,q,z,r,abort;
    % 1st phase: divide out leading term variable,
    % remove zero products, and terminate for explicitly
    % unsolvable system.
   v:=numr simp car vl;
   ns:=for each e in s collect numr simp e;
    % remove factors of leading coefficient,
    % remove trivial parts and propagate them into system.
   r:=t;
   while r do
   <>
       else if not member(e,ns)then ns:=e.ns>>>>;
   if abort or null vl then return nil;
   nc_factorize_timecheck();
     % all equations solved, free variable(s) left
   if null ns and vl then
   <>;
     % solve the system.
   s:=for each e in ns collect prepf e;
   if !*trnc then
    <>;
        % modification HM 24.10.2001: introduction of the fluid variable
        % '*varoptt' and setting it 't' locally.
   w:=(cdr solveeval{'list.s,'list.vl} where dipvars!*=nil);
     % Select appropriate solution.
 loop:nc_factorize_timecheck();
   if null w then go to done;
   so:=cdr car w;w:=cdr w;soa:=nil;
   if smemq('i,so)and null !*complex then go to loop;
     % Insert values for non occurring variables.
   for each y in vl do if not smember(y,so)then<>;
   for each y in so do
   <>;
     % don't accept solution with leading term 0.
   if not nz then go to loop;
   q:=assoc(car vl,soa);
   if null q or cdr q=0 then go to loop;
   % Make sure solutions are in lowest terms.
   soa:=for each j in soa collect(car j.sublis(soa,cdr j));
   sol:=soa.sol;
   if all then go to loop;
 done:sol:=for each s in sol collect append(sb,s);
   if !*trnc then
    <>;
   return sol end;

symbolic procedure dipsubf(a,u);
  % construct polynomial u with coefficients from a.
 if dipzero!? u then nil else
  <>
      where q=assoc(bc2a diplbc u,a),r=dipsubf(a,dipmred u);

symbolic procedure dippolish p1;diprectoint(p1,diplcm p1);

symbolic procedure nc_factorize_unwrap(u,s);
   if atom u then u else
   if eqcar(u,'arbcomplex)then 1 else
   (if q then cdr q else
   for each x in u collect nc_factorize_unwrap(x,s))where q=assoc(u,s);

symbolic procedure nc_factorize2evl(ev,rs,mx);
  % make list of monomials below ev in gradlex ordering,
  % but only those which occur in rs (if that is non-nil)
  % and which have the maximal degress of mx.
 for each q in nc_factorize2!-evl1(min(evtdeg mx,evtdeg ev),length ev,rs)
  join if not vevcompless!?(ev,q) and vevmtest!?(mx,q)then{q};

symbolic procedure nc_factorize2!-evl1(n,m,rs);
% Collect all 'm' exponent vectors with total degree <='n'.
   if m=0 then'(nil)else
   for i:=0:(if null rs or car rs>0 then n else 0)join
     for each e in nc_factorize2!-evl1(n#-i,m#-1,if rs then cdr rs)
       collect i.e;

symbolic procedure nc_factorize_timecheck();
   if fixp nc_factor_time and nc_factor_time>0 and
     (time() - nc_factor_time!*) > nc_factor_time
       then rederr "time overflow in noncom. factorization";

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncenv.red0000644000175000017500000000775111526203062023627 0ustar  giovannigiovannimodule ncenv; % Non-communtative polynomial ring environment.

% This module organizes an environment for computing with
% non-commutative polynomials in algebraic mode, and an embedding
% for non-commutative Groebner bases.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig

% Copyright: Konrad-Zuse-Zentrum Berlin, 1994

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


share ncpi!-brackets!*,ncpi!-comm!-rules!*,ncpi!-name!-rules!*;

algebraic operator nc!*;
algebraic noncom nc!*;

put('nc!*,'prifn,'pri!-nc!*);
put('nc!*,'dipprifn,'dippri!-nc!*);

symbolic procedure pri!-nc!* u;
   prin2!*(w and cdr w or u) where w=assoc(u,ncpi!-names!*);

symbolic procedure dippri!-nc!* u;
   dipprin2(w and cdr w or u) where w=assoc(u,ncpi!-names!*);

symbolic procedure ncpi!-setup u;
  begin scalar vars,al,b,b0,f,m,rs,rn,na,rh,lh,s,x,y,w,!*evallhseqp;
   if (w:=member('left,u)) or (w:=member('right,u)) then
   <>;
   ncpi!-names!*:=na;
   ncpi!-name!-rules!*:='list.rn;
   m:=for i:=1:length vars -1 join
     for j:=i+1:length vars collect nth(vars,i).nth(vars,j);
   if cdr u then ncpi!-brackets!*:=listeval(cadr u,nil);
   if null ncpi!-brackets!* then rederr "commutator relations missing";
   for each b in cdr ncpi!-brackets!* do
   <>;
     m:=delete(y.x,m);
     rs:={'replaceby,{'times,x,y},{'plus,{'times,y,x},rh}}.rs>>;
    % Initialize non-commutative distributive Polynomials.
   ncdsetup!*{'list.vars,'list.rs};
   apply('korder,{vars});
   apply('order,{vars});
    % Rules for commutating objects.
   for each c in m do
     rs:={'replaceby,{'times,cdr c,car c},{'times,car c,cdr c}}.rs;
   ncpi!-comm!-rules!*:='list.rs;
   algebraic let ncpi!-comm!-rules!*,ncpi!-name!-rules!* end;

put('nc_setup,'psopfn,'ncpi!-setup);

symbolic procedure nc_cleanup();
   <>;

put('nc_cleanup,'stat,'endstat);

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncpoly.tst0000644000175000017500000000300411526203062024045 0ustar  giovannigiovanninc_setup({k,n,NN,KK},{NN*n-n*NN=NN,KK*k-k*KK=KK},left);

 p1 := (n-k+1)*NN - (n+1);
 p2 := (k+1)*KK -(n-k);
 l_g:=nc_groebner ({p1,p2});

 nc_preduce(p1+p2,l_g);

 nc_divide  (k*p1+p2,p1);
 nc_divide  (k*p1+p2,2*p1);
 nc_divide  (2*k*k*p1 + k*p1 + p2,2*p1);
 
 nc_factorize (p1*p2);

nc_setup({k,n,NN,KK},{NN*n-n*NN=NN,KK*k-k*KK=KK},right);
nc_factorize (p1*p2);

% applications to shift operators

nc_setup({n,NN},{NN*n-n*NN=1},left);
n*NN;
nc_factorize(ws);
nc_setup({n,NN},{NN*n-n*NN=1},right);
n*NN;
nc_factorize(ws);
nc_setup({NN,n},{NN*n-n*NN=1},right);
n*NN;
nc_factorize(ws);
nc_setup({NN,n},{NN*n-n*NN=1},left);
n*NN;
nc_factorize(ws);

% Applications to partial differential equations

nc_setup({x,Dx},{Dx*x-x*Dx=1});

p:= 2*Dx^2 + x* Dx^3 + 3*x*Dx + x^2*Dx^2 + 14 + 7*x*Dx;
nc_factorize p;
right_factor(p,1); % no factor of degr 1
right_factor(p,2);
left_factor(p,2);

nc_setup({x,Dx},{Dx*x-x*Dx=1});

q := x**2*dx**2 + 2*x**2*dx + x*dx**3 + 2*x*dx**2 
    + 8*x*dx + 16*x + 2*dx**2 + 4*dx$

nc_factorize q;
right_factor(q,1);
right_factor(q,1,{x});  % no such right factor
right_factor(q,1,{dx});

% looking for factor with degree bound for an individual variable

q := x**6*dx + x**5*dx**2 + 12*x**5 + 10*x**4*dx + 20*x**3 
+ x**2*dx**3 - x**2*dx**2 + x*dx**4 - x*dx**3 + 8*x*dx**2 
- 8*x*dx + 2*dx**3 - 2*dx**2$

right_factor(q,dx);
right_factor(q,dx^2);

% some coefficient sports
nc_setup({NN,n},{NN*n-n*NN=1},left);
q:=(n*nn)^2;
nc_factorize q;
nc_preduce(q,{c1+c2*n + c3*nn + c4*n*nn});
nc_divide(q,n);

nc_cleanup;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncgroeb.red0000644000175000017500000001722711526203062024134 0ustar  giovannigiovannimodule ncgroeb; % Groebner for noncommutative one sided ideals.

% Author: H. Melenk, ZIB Berlin, J. Apel, University of Leipzig.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Following Carlo Traverso's model.

switch gsugar;

symbolic procedure nc!-groebeval u;
  begin scalar g;
    nc!-gsetup();
    u:=car u;
    g:=for each p in cdr listeval(u,nil) collect a2ncvdp reval p;
    g:=nc!-traverso g;
    return 'list.for each w in g collect vdp2a w end;

put('nc_groebner,'psopfn,'nc!-groebeval);

symbolic procedure nc!-preduce u;
  begin scalar g,p,!*gsugar;
    nc!-gsetup();
    g:=for each p in cdr listeval(cadr u,nil) collect a2ncvdp reval p;
    p:=a2ncvdp reval car u;
    p:=nc!-normalform(p,g,nil,nil);
    return vdp2a p end;

put('nc_preduce,'psopfn,'nc!-preduce);

symbolic procedure nc!-div u;
  begin scalar g,p,!*gsugar;
    nc!-gsetup();
    g:=a2ncvdp reval cadr u;
    p:=a2ncvdp reval car u;
    p:=nc!-qremf(p,g);
    return{'list,vdp2a car p,vdp2a cdr p}end;

put('nc_divide,'psopfn,'nc!-div);

symbolic procedure nc!-gsetup();
 <<    factortime!*:=0;
       groetime!*:=time();
       vdpinit2 ncdipvars!*;
       vdponepol(); % we construct dynamically
       hcount!*:=mcount!*:=fcount!*:=pcount!*:=0;
       bcount!*:=b4count!*:=hzerocount!*:=0;
       basecount!*:=0;!*gcd:=t;glterms:=list('list);
       groecontcount!*:=10;
       !*nc!-traverso!-sloppy:=!*vdpinteger:=t;
       if null ncdipbase!* then
        rederr "non-commutative ideal initialization missing">>;

!*gsugar:=t;

symbolic procedure nc!-traverso g0;
  begin scalar g,d,s,h,p;
  g0:=for each fj in g0 collect gsetsugar(vdpenumerate vdpsimpcont fj,nil);
main_loop:if null g0 and null d then return nc!-traverso!-final g;
    if g0 then<>
       else
         <>;
            if vevzero!? vdpevlmon h then % base 1 found
                  <<   !*trgroeb and groebmess5(p,h);
                       d:=g:=g0:=nil>>>>;
         h:=groebenumerate h;!*trgroeb and groebmess5(p,h);
          % new pair list
         d:=nc!-traverso!-pairlist(h,g,d);
          % new basis
         g:=nconc(g,{h});
         go to main_loop end;

symbolic procedure nc!-traverso!-pairlist(gk,g,d);
  % gk: new polynomial,
  % g:  current basis,
  % d:  old pair list.
  begin scalar ev,r,n,nn,q;
     % delete triange relations from old pair list.
    d:=nc!-traverso!-pairs!-discard1(gk,d);
     % build new pair list.
    ev:=vdpevlmon gk;
    for each p in g do n:=groebmakepair(p,gk).n;
     % discard multiples: collect survivers in n
    <>where !*gsugar=!*gsugar;
    nn:=n;n:=nil;
    for each p in nn do
    <>;
    return groebcplistmerge(d,reversip n) end;

symbolic procedure nc!-traverso!-pairs!-discard1(gk,d);
  % crit B
  begin scalar gi,gj,tij,evk;
   evk:=vdpevlmon gk;
   for each pij in d do
   <>;
   return d end;

symbolic procedure vevstrictlydivides!?(ev1,ev2);
   not(ev1=ev2)and vevdivides!?(ev1,ev2);

symbolic procedure nc!-traverso!-final g;
  % final reduction and sorting;
  begin scalar r,p,!*gsugar;
   g:=vdplsort g; % descending
   while g do
   <>;
   return reversip r end;

symbolic procedure nc!-fullprint(comm,cu,u,tu,cv,v,tv,r);
  < ";
    vdpprint tu;
    vdpprin2 cv;prin2 " * P("; prin2 vdpnumber v; prin2 ")=> ";
    vdpprint tv;
    prin2t "               ====>";
    vdpprint r;
    prin2t " - - - - - - -">>;

symbolic procedure nc!-spoly(u,v);
 % Compute S-polynomial.
  begin scalar cu,cv,tu,tv,bl,l,r;
    l:=vev!-cofac(vdpevlmon u,vdpevlmon v);
    bl:=vbc!-cofac(vdplbc u,vdplbc v);
    cu:=vdpfmon(car bl, car l);
    cv:=vdpfmon(cdr bl, cdr l);
    if !*ncg!-right then <>
    else <>;
    nccof!*:=cu.cv;
    r:=vdpdif(tu,tv);
    if !*trgroebfull then nc!-fullprint("S polynomial:",cu,u,tu,cv,v,tv,r);
    return r end;

symbolic procedure nc!-qremf(u,v);
 % compute (u/v, remainder(u,v)).
  begin scalar ev,cv,q;
   q:=a2vdp 0;
   if vdpzero!? u then return q.q;
   ev:=vdpevlmon v;cv:=vdplbc v;
   while not vdpzero!? u and vevdivides!?(ev,vdpevlmon u) do
   <>;
   return q.u end;

symbolic procedure nc!-reduce1(u,bu,eu,v);
 % Compute u - w*v such that monomial (bu*x^eu) in u is deleted.
  begin scalar cu,cv,tu,tv,bl,l,r;
    l:=vev!-cofac(eu,vdpevlmon v);
    bl:=vbc!-cofac(bu,vdplbc v);
    cu:=vdpfmon(car bl,car l);
    cv:=vdpfmon(cdr bl,cdr l);
    if !*ncg!-right then
    <>
    else <>;
    nccof!*:=cu.cv;
    r:=vdpdif(tu,tv);
    if !*trgroebfull then
      nc!-fullprint("Reduction step:",cu,u,tu,cv,v,tv,r);
     %%%% if null yesp "cont" then rederr "abort";
    return r end;

symbolic procedure nc!-normalform(s,g,mode,cmode);
<>;

symbolic procedure nc!-normalform2(s,g,cmode);
 % Normal form 2: full reduction.
  begin scalar g0,ev,f,s1,b;
loop:s1:=s;
        % unwind to last reduction point.
     if ev then while vevcomp(vdpevlmon s1,ev)>0 do s1:=vdpred s1;
loop2:if vdpzero!? s1 then return s;
     ev:=vdpevlmon s1;b:=vdplbc s1;
     g0:=g;f:=nil;
     while null f and g0 do
      if vevdivides!?(vdpevlmon car g0,ev) then f:=car g0 else g0:=cdr g0;
     if null f then<>;
     s:=nc!-reduce1(s,b,ev,f);
     if !*trgroebs then<>;
     if cmode then s:=groebsimpcontnormalform s;
     go to loop end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/ncpoly/ncpoly.red0000644000175000017500000000570211526203062024014 0ustar  giovannigiovannimodule ncpoly; % Computing in non-commutative polynomial rings and
               % ideals.

% Author: H. Melenk, ZIB-Berlin, J. Apel, University of Leipzig.

% Copyright: Konrad-Zuse-Zentrum Berlin, 1994

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package ('(ncpoly ncenv ncdip ncgroeb ncfactor ncout),
                 '(contrib ncpoly));

fluid '(
 basecount!*
 bcount!*
 b4count!*
 dipvars!*
 factortime!*
 fcount!*
 glterms!*
 groecontcount!*
 groetime!*
 hcount!*
 hzerocount!*
 mcount!*
 nccof!*             % cofactors after a reduction step
 ncdipbase!*         % vector:
                     % the i-th entry is a list (j1,j2...)
                     % where j1,j2 ... < i
                     %    and x_i * x_j neq x_j*x_i
 ncdipcircular!*     % t if one variable appears in more than one
                     % commutator
 ncdiptable!*        % 2-dim array:
                     % then entry (i,j) keeps the powers of the
                     % commutator [x_i,x_j] where j>;
  w:=simp u where !*factor=nil,!*factors=nil,!*exp=t;
  d:=denr w;
  r:=nc_compactr(numr w,reverse vl,t1,t2);
  return mk!*sq (r./d)end;

symbolic procedure nc_compactr(u,vl,t1,t2);
  begin scalar x,xn,y,q,w,r,s;
    integer n,m;
  x:=car vl; vl := cdr vl;
  w:=nc_compactd u;
  n:=-1;
loop:if null w then goto done;
  n:=n+1;
  xn:=if n=0 then 1 else x .** n .* 1 .+ nil;
  q:=nc_compactx(w,x,xn);
  w:=cdr q;q:=car q;
  if q then
  begin scalar !*factor,!*exp;
     if null vl or null cdr vl or 2>
       <>
     then
      <>
     else
      <>;
     r:=addf(multf(q,xn),r)end;
  goto loop;
done:return r end;

symbolic operator nc_compact;

symbolic procedure nc_compactd u;
  % convert standard form into list (=sum) of monomials.
    if domainp u then {u} else
    append(for each s in nc_compactd lc u collect lpow u .* s .+nil,
           red u and nc_compactd red u);

symbolic procedure nc_compactx(u,x,xn);
  % Extract sum of terms which contain multiples of power xn. Divide xn out.
 begin scalar yes,no,w;
   for each r in u do
    if xn=1 and not smember(x,r) then yes:=r.yes
       else
    if (w:=quotf(r,xn)) and not smember(x,w) then yes:=w.yes else no:=r.no;
   return yes.no end;

endmodule;;end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/tmprint/0000755000175000017500000000000011722677365022224 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/tmprint/tmprint.red0000644000175000017500000023265711526203062024411 0ustar  giovannigiovanni% ----------------------------------------------------------------------
% $Id: tmprint.red,v 1.15 2006/06/29 20:04:29 sturm Exp $
% ----------------------------------------------------------------------
% Copyright (c) 1993-1994, 1999, 2003-2005 A. Dolzmann, T. Hearn, A.
% Grozin, H. Melenk, W. Neun, A. Norman, A. Seidl, and T. Sturm
%
% Permission is hereby granted, free of charge, to any person
% obtaining a copy of this software and associated documentation files
% (the "Software"), to deal in the Software without restriction,
% including without limitation the rights to use, copy, modify, merge,
% publish, distribute, sublicense, and/or sell copies of the Software,
% and to permit persons to whom the Software is furnished to do so,
% subject to the following conditions:
%
% The above copyright notice and this permission notice shall be
% included in all copies or substantial portions of the Software.
%
% THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
% EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
% MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
% NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
% BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
% ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
% CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
% SOFTWARE.
% ----------------------------------------------------------------------
% $Log: tmprint.red,v $
% Revision 1.15  2006/06/29 20:04:29  sturm
% There are now two different linelength patches for the two Lisps. Arthur
% hat pointed out that he does not want any at all. We have to understand
% that, and find a clean solution!
%
% Revision 1.14  2006/06/27 16:49:39  sturm
% The linelength hack did not work the way it was. PSL did not really extend
% the line length.
% Redesigned prompt.
%
% Revision 1.13  2005/10/15 11:21:32  seidl
% Released under a MIT-style licence, as all authors have agreed.
%
% Revision 1.12  2005/08/25 17:06:02  sturm
% Declare lispsystem!* fluid instead of global. In PSL it is in fact fluid, and
% according to Arthur this is compatible with CSL.
%
% Revision 1.11  2005/08/24 15:29:24  seidl
% Changes of fancy!-intpri as suggested by Winfried Neun: bounds of the
% intregral are printed now.
%
% Revision 1.10  2004/11/20 20:50:14  seidl
% Linelength hack established again, only if Texmacs runs. Removed
% centering and curly brackets from fancy-out-header and -trailer.
% New switch promptnumbers, turned off only if Texmacs is running.
%
% Revision 1.9  2004/11/19 00:52:26  seidl
% fancy!-out!-header and fancy!-out!-trailer were split up between the
% different lisps although they are the same. Now there is one version
% again. Fixed the unbalanced parentheses problem around \displaystyle.
%
% Revision 1.8  2004/11/18 20:44:16  seidl
% Further changes by ACN to help with CSL-based systems:
% (*) use of \mathit{A} for \Alpha and related changes to avoid direct
% reference to character codes
% (*) added texsymbol(), texbox(), texfbox() and texstring() formatting
% at least for the benefit of those debugging.
% (*) new fluids !*standard!-output!* !*math!-output!* !*spool!-output!*
% (*) changes to fancy!-output
% (*) splitted fancy!-flush between csl and psl
% (*) changes to fancy!-binomial
%
% Revision 1.7  2004/11/09 01:11:17  seidl
% Changes by ACN to help with CSL-based systems
% (*) switch redfront_mode made present in the CSL build to control
% whether prompt colouring is generated via escapes and an external
% package or by the underlying Lisp system directly. I think this MAY be
% useful for PSL too but did not enable it there to avoid introducing
% inconsistencies with current behaviour.
% (*) elaborate scheme to try to arrange that screen display and log-file
% stuff both end up in good style in the CSL case.
%
% Revision 1.6  2004/09/24 10:42:41  seidl
% Taken over changes by A C Norman related to CSL, except of whitespace
% changes:
%
% This version is being hacked by ACN to make it CSL-friendly. Perhaps
% the main part of that will be re-working string processing operations
% so that they are less sensitive to the exact behaviours of intern and
% compress and looking carefully at the way that things with control
% characters in get printed.
% So that I can work on this comfortably I will expand tabs to blanks
% and mend places where this results in very obviously damaged layout.
%
% Remove fancy!-mode!* since Reduce 3.5 is now rather ancient history.
%
% Revision 1.5  2004/08/12 13:04:23  seidl
% Version for the Reduce development system for inclusion into Reduce 3.8.
%
% Revision 1.4  2003/11/20 13:10:44  sturm
% I think the protocol to Texmacs was not clean. One int2id 5 deleted.
%
% Revision 1.3  2003/11/20 12:23:01  sturm
% Temporary remflag lose on break_prompt for reloading.
% Removed linelength hack.
% Removed overflowed!* test in fancy!-maprin0 instead of linelength hack.
% Do not explode atoms starting with "\" in fancy!-prin2!*.
% Dirty, but apparently working.
%
% Revision 1.2  2003/11/20 11:06:12  sturm
% Texmacs now basically runs.
% Linelength workaround does not function anymore due to missing filter.
%
% Revision 1.1  2003/11/11 11:08:57  sturm
% Inital check-in.
% This is the original version by Andrey Grozin as obtained from fmprint.red
% via patching.
%
% ----------------------------------------------------------------------
module tmprint; % Output module for TeXmacs interface
% this is fmprint with minor modifications

% Fancy output package for symbolic expressions.
% using TEX as intermediate language.

% Author: Herbert Melenk, using ideas of maprin.red (A.C.H, A.C.N).

% Copyright (c) 1993 RAND, Konrad-Zuse-Zentrum.  All rights reserved.

%   8-Sep-94
%               introduced data driven formatting (print-format)

%  12-Apr-94
%               removed print function for dfp
%               removed some unused local variables
%               corrected output for conditional expressions and
%                 aeval/aeval* forms

%  17_Mar-94    corrected line breaks in Taylor expressions
%               rational exponents use /
%               vertical bar for SUB expressions
%               explicit * for product of two quotients (Taylor)

% switches
%
%    ON FANCY          enable algebraic output processing by this module
%
%    ON FANCY_TEX      under ON FANCY: display TEX equivalent
%

% properties used in this module:
%
%     fancy-prifn      print function for an operator
%
%     fancy-pprifn     print function for an oeprator including current
%                      operator precedence for infix printing
%
%     fancy!-flatprifn print function for objects which require
%                      special printing if prefix operator form
%                      would have been used, e.g. matrix, list
%
%     fancy-prtch      string for infix printing of an operator
%
%     fancy-special-symbol
%                      print expression for a non-indexed item
%                      string with TEX expression  "\alpha"
%                         or
%                      number referring ASCII symbol code
%
%     fancy-infix-symbol    special-symbol for infix operators
%
%     fancy-prefix-symbol   special symbol for prefix operators
%
%     fancy!-symbol!-length  the number of horizontal units needed for
%                      the symbol.  A standard character has 2 units.


%  94-Jan-26 - Output for Taylor series repaired.
%  94-Jan-17 - printing of index for Bessel function repaired.
%            - New functions for local encapsulation of printing
%              independent of smacro fancy!-level.
%            - Allow printing of upper case symbols locally
%              controlled by *fancy-lower

%  93-Dec-22 Vectors printed with sqare brackets.

create!-package('(tmprint),nil);

fluid  '(
         !*list
         !*nat
         !*nosplit
         !*ratpri
         !*revpri
         overflowed!*
         p!*!*
         testing!-width!*
         tablevel!*
         sumlevel!*
         outputhandler!*
         outputhandler!-stack!*
         posn!*
         long!*
         obrkp!*    % outside-brackets-p
            );

global '(!*eraise charassoc!* initl!* nat!*!* spare!* ofl!*);

switch list,ratpri,revpri,nosplit;

% Temp experiment while investigating a possible for for an interaction with
% "on list"      @@@@@@@@@
switch acn;

% Global variables initialized in this section.

fluid '(
      fancy!-switch!-on!*
      fancy!-switch!-off!*
      !*fancy!-mode
      fancy!-pos!*
      fancy!-line!*
      fancy!-page!*
      fancy!-bstack!*
      !*fancy_tex
      !*fancy!-lower    % control of conversion to lower case
      );

switch fancy_tex; % output TEX equivalent.

fancy!-switch!-on!* := int2id 16$
fancy!-switch!-off!* := int2id 17$
!*fancy!-lower := nil;

global '(fancy_lower_digits fancy_print_df);

share fancy_lower_digits; % T, NIL or ALL.

if null fancy_lower_digits then fancy_lower_digits:=t;

share fancy_print_df;     % PARTIAL, TOTAL, INDEXED.

if null fancy_print_df then  fancy_print_df := 'partial;
switch fancy;

put('fancy,'simpfg,
  '((t (fmp!-switch t))
    (nil (fmp!-switch nil)) ));


symbolic procedure fmp!-switch mode;
      if mode then
        <> else
          rederr "FANCY is not current output handler"
        >>;

fluid '(lispsystem!*);

procedure texmacsp;
   % Texmacs predicate. Returns [t] iff Texmacs is running.
   if getenv("TEXMACS_REDUCE_PATH") then t;

copyd('linelength!-orig,'linelength);
remd('linelength);

!#if (memq 'psl lispsystem!*)

procedure linelength(a);
   if texmacsp() then linelength!-orig(30000) else linelength!-orig(a);

!#else

procedure linelength(a);
   if texmacsp() then 30000 else linelength!-orig(a);

!#endif

% The next two functions provide abstraction for conversion between
% strings and lists of character objects.

!#if (memq 'csl lispsystem!*)

% Under CSL the eventual state will be that IF output is going directly
% to a window that can support maths display then I will send stuff there
% so it gets displayed using the CSL embedded code. If on the other hand
% output is going to a pipe or a file or basically anything other than
% directly to the screen I will issue the codes that texmacs likes to see.
%

% Convert a list of character objects into a string.
% (The function list!-to!-string already exists...)

% Convert a string into a list of character objects.
smacro procedure string!-to!-list a;
    explode2 a;

% Print a string without ANY conversion or adjustment, so if the string
% has control characters etc in it they get transmitted unchanged. Well
% let me express some reservations about what might happen if the string
% contains tabs and newlines - the lower level system IO code might
% interpret same...
smacro procedure raw!-print!-string s;
    prin2 s;

% Print the character whose code is n.
smacro procedure writechar n;
    tyo n;    % Like "prin2 int2id n"

% Convert a symbol or string to characters but ensure that all
% output characters are folded to lower case.
% CSL already has explode2lc;

!#else

smacro procedure list!-to!-string a;
    compress ('!" . append(a, '(!")));

smacro procedure string!-to!-list a;
    explode2 a;

% I do not know if this has to be like this in PSL, but it reflects
% what was in the code.
symbolic procedure raw!-print!-string s;
     for each x in string!-to!-list s do prin2 x;
% writechar already exists in PSL.

symbolic procedure explode2lc s;
    explode2 s where !*lower = t;

!#endif

symbolic procedure fancy!-tex s;
  % test output: print tex string.
   <>;

symbolic procedure fancy!-out!-item(it);
  if atom it then prin2 it else
  if eqcar(it,'ascii) then writechar(cadr it) else
  if eqcar(it,'tab) then
      for i:=1:cdr it do prin2 " "
    else
  if eqcar(it,'bkt) then
     begin scalar m,b,l; integer n;
      m:=cadr it; b:=caddr it; n:=cadddr it;
      l := b member '( !( !{ );
   %  if m then prin2 if l then "\left" else "\right"
   % else
%      if n> 0 then
%      <>;
      if l then prin2 "\left" else prin2 "\right";
      if b member '(!{ !}) then prin2 "\";
      prin2 b;
    end
    else
      rederr "unknown print item";

symbolic procedure set!-fancymode bool;
  if bool neq !*fancy!-mode then
    <>;

!#if (memq 'csl lispsystem!*)
fluid '(!*standard!-output!* !*math!-output!* !*spool!-output!*);
!#endif

symbolic procedure fancy!-output(mode,l);
% Interface routine.

% ACN does not understand the "posn!*>2" filter here. To avoid some
% bad consequences it was having for my new screen/log-file stuff it now only
% applies in maprin mode not terpri mode, but it would be nice if somebody
% could explain to me just why it was needed in the first case at all.  I can
% imagine that if "on fancy" is acticated when there is still some partly-
% printed expression (in non-fancy mode) buffered up the terpri!* to flush it
% may need special care. But if that is what it is about I would suggest that
% treatment be applied in fmp!-switch not here...

   if ofl!* or (mode='maprin and posn!*>2) or not !*nat then <<
% not terminal handler or current output line non-empty.
      if mode = 'maprin then maprin l
      else terpri!*(l) >> where outputhandler!* = nil
      else
% I want to do some more magic for CSL here. In CSL the system can be launched
% or run-time configured so that a transcript of screen output goes to a
% file, the "log file". In the CSL sources the handle for this file is known
% as "spool_file". It does not look sensible to me that TeX-ified maths
% should go there even if that is what best goes to the screen. Thus I think I
% want fancy mode in CSL with a spool_file enabled to do something rather like
%
%    wrs math-output-destination;
%    fancy!-maprin0 expression;
%    wrs spool_file;
%    maprin0 expression;
%    wrs undivided standard output;
%
% Rather than using "wrs" here I will re-bind the CSL variable
% *standard-output*. This achieves a similar effect but guarantees that
% the regular situation is restored if there is ANY sort of exit from the
% maths display code - eg a user-generated interrupt. It I had used wrs then
% I could perhaps have restored things using errorset, but this feels easier.
% Also this little section of code is pretty CSL-specific since it is
% working with the CSL-embedded display code, so I do not feel bad about
% going beyond Standard Lisp.
%
% A further wrinkle on this wants to be that garbage collector and diagnostic
% output always goes to the undivided standard output in the normal way, and
% this output to the "math-output" stream can never be interrupted by any
% such. If a section of maths display is not completed then the maths output
% will find that it has a fancy_header but no fancy_trailer, and any request
% for user input or any error exit will force terminate it leaving a visibly
% incomplete fragment (which the display code can detect and ignore).
%
% Note that the risk of error or garbage collection during maths display is
% not actually terribly high since  all that is done between the generation
% of header & trailer is a load of calls to fancy!-out!-item, ie ready
% prepared sequences of items get printed. Also the normal maprin just buffers
% things up and only displays them when terpri!* is called. So I can afford to
% use both fancy!-maprin0 and maprin and then fuss about destinations a bit
% more at terpri!* time.  In this regard observe that because I have got here
% I know I on in "on nat" mode. In that case setting pline!* to nil has the
% effect of discarding any built-up layout.
   <>;
!#endif
         fancy!-maprin0 l >>
      else <<
!#if (memq 'csl lispsystem!*)
         if getd 'math!-display and
            math!-display 0 and
            math!-display 1 then <<
            terpri!* l where outputhandler!* = nil
                       where !*standard!-output!* = !*spool!-output!* >>;
!#endif
         fancy!-flush() >> >>;

symbolic procedure fancy!-out!-header();
    <<
       if posn()>0 then terpri();
       prin2 int2id 2;
       prin2 "latex:\black$\displaystyle "
    >>;

symbolic procedure fancy!-out!-trailer();
    <<
       prin2 "$";
       prin2 int2id 5
    >>;

!#if (memq 'csl lispsystem!*)

symbolic procedure fancy!-flush();
  begin
    fancy!-terpri!* t;
    if getd 'math!-display and math!-display 0 then <<
      math!-display 2; % clear out any previous junk
      for each line in reverse fancy!-page!* do
        if line and not eqcar(car line,'tab) then <<
          for each it in reverse line do fancy!-out!-item it;
          terpri() >>;
      math!-display 3 >> where !*standard!-output!*=!*math!-output!*
    else for each line in reverse fancy!-page!* do
      if line and not eqcar(car line,'tab) then <<
         fancy!-out!-header();
         for each it in reverse line do fancy!-out!-item it;
         fancy!-out!-trailer() >>;
    set!-fancymode nil
  end;

!#else

symbolic procedure fancy!-flush();
  begin
    scalar !*lower;  % Rebinding *lower is needed for PSL here
    fancy!-terpri!* t;
        for each line in reverse fancy!-page!* do
      if line and not eqcar(car line,'tab) then <<
         fancy!-out!-header();
          for each it in reverse line do fancy!-out!-item it;
         fancy!-out!-trailer() >>;
     set!-fancymode nil
  end;

!#endif

%---------------- primitives -----------------------------------

symbolic procedure fancy!-special!-symbol(u,n);
   if numberp u then
     <>
    else fancy!-prin2!*(u,n);

symbolic procedure fancy!-prin2 u;
    fancy!-prin2!*(u,nil);

symbolic procedure fancy!-prin2!*(u,n);
   if atom u and eqcar(explode2 u,'!\) then
      fancy!-line!* := u . fancy!-line!*
   else if numberp u and not testing!-width!* then fancy!-prin2number u
     else
  (begin scalar str,id; integer l;
    str := stringp u; id := idp u and not digit u; long!*:=nil;
     u:= if atom u then <<
             if !*fancy!-lower then explode2lc u
             else explode2 u >>
        else {u};
    if cdr u then long!*:=t;
    if car u = '!\ then long!*:=nil;
    l := if numberp n then n else 2*length u;
    if id and not numberp n then
       u:=fancy!-lower!-digits(fancy!-esc u);
    if long!* then
       %% fancy!-line!* := '!{ . '!m . '!r . '!h . '!t . '!a . '!m . '!\ . fancy!-line!*;
       fancy!-line!* := '!\mathrm!{ . fancy!-line!*;
    for each x in u do
    < 2 #* (linelength nil #+1 ) then overflowed!*:=t;
  end) where !*lower = !*lower;

symbolic procedure fancy!-last!-symbol();
   if fancy!-line!* then car fancy!-line!*;

charassoc!* :=
         '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e) (!F . !f)
           (!G . !g) (!H . !h) (!I . !i) (!J . !j) (!K . !k) (!L . !l)
           (!M . !m) (!N . !n) (!O . !o) (!P . !p) (!Q . !q) (!R . !r)
           (!S . !s) (!T . !t) (!U . !u) (!V . !v) (!W . !w) (!X . !x)
           (!Y . !y) (!Z . !z));

symbolic procedure red!-char!-downcase u;
   (if x then cdr x else u) where x = atsoc(u,charassoc!*);

symbolic procedure fancy!-prin2number u;
  % we print a number eventually causing a line break
  % for very big numbers.
  if testing!-width!* then  fancy!-prin2!*(u,t) else
     fancy!-prin2number1 (if atom u then explode2 u else u);

symbolic procedure fancy!-prin2number1 u;
  begin integer c,ll;
   ll := 2 #* (linelength nil #+1 );
   while u do
   <10 and fancy!-pos!* #> ll then fancy!-terpri!*(t);
     fancy!-prin2!*(car u,2); u:=cdr u;
   >>;
  end;

symbolic procedure fancy!-esc u;
   if not('!_ memq u) then u else
   (if car u eq '!_ then '!\ . w else w)
      where w = car u . fancy!-esc cdr u;

symbolic procedure fancy!-lower!-digits u;
    (if null m then u else if m = 'all or
        fancy!-lower!-digitstrail(u,nil) then
           fancy!-lower!-digits1(u,nil)
     else u
     ) where m=fancy!-mode 'fancy_lower_digits;

symbolic procedure fancy!-lower!-digits1(u,s);
  begin scalar c,q,r,w,x;
 loop:
    if u then <> else c:=nil;
    if null s then
      if not digit c and c then w:=c.w else
      << % need to close the symbol w;
         w:=reversip w;
         q:=intern compress w;
	 % The following test "explode q = w" is a hack to avoid the
	 % problem that in CSL compress '(a l p h a !\ !_) is just
	 % alpha. In PSL it is !_, which is not correct either but
	 % this does not cause problems here:
         if explode q = w and stringp (x:=get(q,'fancy!-special!-symbol))
            then w:=explode2 x;
         if cdr w then
            if car w = '!\ then long!*:=nil else long!*:=t
         else long!*:=nil;
         r:=nconc(r,w);
         if digit c then <> else w:=nil;
      >>
    else
      if digit c then w:=c.w else
      << % need to close the number w.
        w:='!_ . '!{ . reversip('!} . w);
        r:=nconc(r,w);
        if c then <> else w:=nil;
      >>;
    if w then goto loop;
    return r;
  end;




symbolic procedure fancy!-lower!-digitstrail(u,s);
   if null u then s else
   if not s and digit car u then
          fancy!-lower!-digitstrail(cdr u,t) else
   if s and not digit car u then nil
   else fancy!-lower!-digitstrail(cdr u,s);

symbolic procedure fancy!-terpri!* u;
   <<
     if fancy!-line!* then
         fancy!-page!* := fancy!-line!* . fancy!-page!*;
     fancy!-pos!* :=tablevel!* #* 10;
     fancy!-line!*:= {'tab . tablevel!*};
     overflowed!* := nil
   >>;

symbolic macro procedure fancy!-level u;
 % unwind-protect for special output functions.
  {'prog,'(pos fl w),
      '(setq pos fancy!-pos!*),
      '(setq fl fancy!-line!*),
      {'setq,'w,cadr u},
      '(cond ((eq w 'failed)
              (setq fancy!-line!* fl)
              (setq fancy!-pos!* pos))),
       '(return w)};

symbolic procedure fancy!-begin();
  % collect current status of fancy output. Return as a list
  % for later recovery.
  {fancy!-pos!*,fancy!-line!*};

symbolic procedure fancy!-end(r,s);
  % terminates a fancy print sequence. Eventually resets
  % the output status from status record  if the result 
  % signals an overflow.
  <>

        else if x := get(car l,'infix) then
        << p := not(x>p);
          w:= if p then fancy!-in!-brackets(
            {'fancy!-inprint,mkquote car l,x,mkquote cdr l},
               '!(,'!))
              else
            fancy!-inprint(car l,x,cdr l);
        >>
        else if x:= get(car l,'fancy!-flatprifn) then
            w:=apply(x,{l})
        else
        <<
           w:=fancy!-prefix!-operator(car l);
           obrkp!* := nil;
           if w neq 'failed then
             w:=fancy!-print!-function!-arguments cdr l;
        >>;

        return if testing!-width!* and overflowed!*
              or w='failed then fancy!-fail(pos,fl) else nil;
    end ) where obrkp!*=obrkp!*;

symbolic procedure fancy!-convert(l,m);
  % special converters.
  if eqcar(l,'expt) and cadr l= 'e and
     ( m='infix or treesizep(l,20) )
        then {'exp,caddr l}
    else l;

symbolic procedure fancy!-print!-function!-arguments u;
  % u is a parameter list for a function.
    fancy!-in!-brackets(
       u and {'fancy!-inprint, mkquote '!*comma!*,0,mkquote u},
            '!(,'!));

symbolic procedure fancy!-maprint!-atom(l,p);
% This should be where any atomic entity provided by the user gets
% treated. The "ordinarily special" cases are
%   (a) Things like the names "alpha", "beta", "geq", "partial-df" and
%       a whole bunch more that have a fancy!-special!-symbol property
%       indicating that they stand for some special character.
%   (b) vectors, which get displayed as eg [1,2,3,4]
%   (c) negative numbers in cases where they should be rendered in
%       parentheses to avoid ambiguity in the output.
% In the original code here all other cases where merely delegated to
% fancy!-prin2!*.
%
% There are however some "less ordinary" special cases that arise when
% material from the user clashes with TeX. I am at present aware of
% five cases of oddity:
%   (1) Strings: If the user puts a string in the input it ought to end
%                up rendered literally come what may. At present it tends
%                to get transcrioned to the TeX stream unaltered, and if the
%                string has TeX special characters in it the result can be
%                odd!
%   (2) Names with special characters within. For instance "abc!%def" leads
%                to TeX that says "\mathrm{abc%def}" and the "%" there is
%                treated as a comment marker, leading to disaster.
%   (3) Names that alias a TeX directive. Eg "on revpri; (1+!\big)^3;". This
%                case can include explicit cases that could be held to
%                be deliberate such as !\alpha, but the fancy!-special!-symbol
%                scheme ought to make that unnecessary.
%   (4) Names (or strings) containing characters outside the LaTeX fonts that
%                are used by default. Mostly these will be special LaTeX
%                control characters, but e.g. if a user could get a "pounds
%                sterling" character into a name...
%   (5) All the follow-on joys that go beyond just (4) and correspond to
%       "Internationalisation"!
% I view all of these as illustrating the fact that interfacing between the
% core of Reduce and its front-end using a textual interface like this is
% unsatisfactory, even though it has been a good place-holder and a path of
% least resistance. The problems noted here only escalate if you imagine
% delevloping the graphical front-end to support cut and (particularly)
% paste operations where the same sorts of textual conversion would need to
% be done but consistently and in the other direction. It also makes the
% issue about who takes responsibility for line breaks a muddled one.
%
% Going via LaTeX is not automatically or comfortably 1:1, it loses structural
% information and it adds the inefficiency of the conversion done here which
% feeds instantly into a TeX parser that tries to reconstruct a box-structure
% that could be closely related to a Lisp prefix form.
%
% So in the long term I would really like to discard this and go directly
% from the Reduce internal form to a box-structure that can be used for
% layout and rendering.
%
% If an identifier contains one of the TeX special characters (other than
% underscore) I will just display it as in \mathrm{} context. Doing so will
% override any detection of trailing digits that could otherwise end up
% displayed as subscripts.
%
% I suspect that I really want to render strings in the cmtt fixed-pitch font,
% but at present I am not confident that Reduce always makes a careful enough
% distinction about what it provides as string and what as symbol data here.
 fancy!-level
  begin scalar x;
     if (x:=get(l,'fancy!-special!-symbol)) then
         fancy!-special!-symbol(x,
                get(l,'fancy!-special!-symbol!-size) or 2)
     else if vectorp l then <<
         fancy!-prin2!*("[",0);
         l:=for i:=0:upbv l collect getv(l,i);
         x:=fancy!-inprint(",",0,l);
         fancy!-prin2!*("]",0);
         return x >>
     else if stringp l or (idp l and contains!-tex!-special l) then <<
         fancy!-line!* := '!\mathrm!{ . fancy!-line!*;
         for each c in explodec l do fancy!-tex!-character c;
         fancy!-line!* := '!} . fancy!-line!* >>
     else if not numberp l or (not (l<0) or p<=get('minus,'infix))
         then fancy!-prin2!*(l,'index)
     else fancy!-in!-brackets({'fancy!-prin2!*,mkquote l,t}, '!(,'!));
     return (if testing!-width!* and overflowed!* then 'failed else nil);
  end;

symbolic procedure contains!-tex!-special x;
% Checks if an identifier contains any character that could "upset" TeX
% in its name. Note that as a special case I do NOT count underscore as
% special here!
  begin
    scalar u;
    u:= (if !*fancy!-lower then explode2lc x
         else explode2 x);
top:if null u then return nil
    else if memq(car u, '(!# !$ !% !& !{ !} !~ !^ !\)) or
            car u eq blank or car u eq tab or car u eq !$eol!$ then return t;
    u := cdr u;
    go to top
  end;


symbolic procedure fancy!-tex!-character c;
% This arranges to print something even if it is a funny character as
% far as TeX is concerned. I display a tab as two spaces, and a newline
% as $eol$ and rather hope that neither ever arises. I also need to check
% that my TeX parser can handle all these...
  if c = '!# or
     c = '!$ or
     c = '!% or
     c = '!& or
     c = '!_ or
     c = '!{ or
     c = '!} then fancy!-line!* := c . '!\ . fancy!-line!*
  else if c = '!~ then fancy!-line!* := '!{!\textasciitilde!} . fancy!-line!*
  else if c = '!^ then fancy!-line!* := '!{!\textasciicircum!} . fancy!-line!*
  else if c = '!\ then fancy!-line!* := '!{!\textbackslash!} . fancy!-line!*
  else if c = blank   then fancy!-line!* := '!~ . fancy!-line!*
  else if c = tab     then fancy!-line!* := '!~ . '!~ . fancy!-line!*
  else if c = !$eol!$ then fancy!-line!* := '!\!$eol!\!$ . fancy!-line!*
  else fancy!-line!* := c . fancy!-line!*;

put('print_indexed,'psopfn,'(lambda(u)(flag u 'print!-indexed)));

symbolic procedure fancy!-print!-indexlist l;
   fancy!-print!-indexlist1(l,'!_,nil);

symbolic procedure fancy!-print!-indexlist1(l,op,sep);
  % print index or exponent lists, with or without separator.
 fancy!-level
  begin scalar w,testing!-width!*,obrkp!*;
    testing!-width!* :=t;
    fancy!-prin2!*(op,0);
    fancy!-prin2!*('!{,0);
    w:=fancy!-inprint(sep or 'times,0,l);
    fancy!-prin2!*("}",0);
    return w;
  end;

symbolic procedure fancy!-print!-one!-index i;
 fancy!-level
  begin scalar w,testing!-width!*,obrkp!*;
    testing!-width!* :=t;
    fancy!-prin2!*('!_,0);
    fancy!-prin2!*('!{,0);
    w:=fancy!-inprint('times,0,{i});
    fancy!-prin2!*("}",0);
    return w;
  end;

symbolic procedure fancy!-in!-brackets(u,l,r);
  % put form into brackets (round, curly,...).
  % u: form to be evaluated,
  % l,r: left and right brackets to be inserted.
  fancy!-level
   (begin scalar fp,w,r1,r2,rec;
     rec := {0};
     fancy!-bstack!* := rec . fancy!-bstack!*;
     fancy!-adjust!-bkt!-levels fancy!-bstack!*;
     fp := length fancy!-page!*;
     fancy!-prin2!* (r1:='bkt.nil.l.rec, 2);
     w := eval u;
     fancy!-prin2!* (r2:='bkt.nil.r.rec, 2);
       % no line break: use \left( .. \right) pair.
     if fp = length fancy!-page!* then
     <>;
     return w;
   end)
    where fancy!-bstack!* = fancy!-bstack!*;


symbolic procedure fancy!-adjust!-bkt!-levels u;
   if null u or null cdr u then nil
   else if caar u >= caadr u then
    <>;

symbolic procedure fancy!-exptpri(l,p);
% Prints expression in an exponent notation.
   (begin scalar !*list,pp,q,w,w1,w2,pos,fl;
      pos:=fancy!-pos!*; fl:=fancy!-line!*;
      pp := not((q:=get('expt,'infix))>p);  % Need to parenthesize
      w1 := cadr l; w2 := caddr l;
      testing!-width!* := t;
      if eqcar(w2,'quotient) and cadr w2 = 1
          and (fixp caddr w2 or liter caddr w2) then
         return fancy!-sqrtpri!*(w1,caddr w2);
      if eqcar(w2,'quotient) and eqcar(cadr w2,'minus)
          then w2 := list('minus,list(car w2,cadadr w2,caddr w2))
          else w2 := negnumberchk w2;
      if fancy!-maprint(w1,q)='failed
            then return fancy!-fail(pos,fl);
     fancy!-prin2!*("^",0);
     if eqcar(w2,'quotient) and fixp cadr w2 and fixp caddr w2 then
      <>
           else w:=fancy!-maprint!-tex!-bkt(w2,0,nil);
     if w='failed then return fancy!-fail(pos,fl) ;
    end) where !*ratpri=!*ratpri,
           testing!-width!*=testing!-width!*;

put('expt,'fancy!-pprifn,'fancy!-exptpri);

symbolic procedure fancy!-inprint(op,p,l);
  (begin scalar x,y,w, pos,fl;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
      % print product of quotients using *.
     if op = 'times and eqcar(car l,'quotient) and
       cdr l and eqcar(cadr l,'quotient) then
        op:='!*;
     if op eq 'plus and !*revpri then l := reverse l;
     if not get(op,'alt) then
     <<
        if op eq 'not then
         << fancy!-oprin op;
            return  fancy!-maprint(car l,get('not,'infix));
         >>;
        if op eq 'setq and not atom (x := car reverse l)
             and idp car x and (y := getrtype x)
             and (y := get(get(y,'tag),'fancy!-setprifn))
            then return apply2(y,car l,x);
        if not atom car l and idp caar l
              and
           ((x := get(caar l,'fancy!-prifn))
                   or (x := get(caar l,'fancy!-pprifn)))
              and (get(x,op) eq 'inbrackets)
            % to avoid mix up of indices and exponents.
          then<<
               fancy!-in!-brackets(
                {'fancy!-maprint,mkquote car l,p}, '!(,'!));
              >>
           else if !*nosplit and not testing!-width!* then
                fancy!-prinfit(car l, p, nil)
           else w:=fancy!-maprint(car l, p);
          l := cdr l
      >>;
     if testing!-width!* and (overflowed!* or w='failed)
            then return fancy!-fail(pos,fl);
     if !*list and obrkp!* and memq(op,'(plus minus)) then
        <>;
     if !*nosplit and not testing!-width!* then
          % main line:
         fancy!-inprint1(op,p,l)
     else w:=fancy!-inprint2(op,p,l);
     if testing!-width!* and w='failed then return fancy!-fail(pos,fl);
   end
   ) where tablevel!*=tablevel!*, sumlevel!*=sumlevel!*;


symbolic procedure fancy!-inprint1(op,p,l);
   % main line (top level) infix printing, allow line break;
  begin scalar lop;
   for each v in l do
   <>;
     fancy!-prinfit(negnumberchk v, p, nil)
   >>;
  end;

symbolic procedure fancy!-inprint2(op,p,l);
   % second line
  begin scalar lop,w;
   for each v in l do
    if not testing!-width!* or w neq 'failed then
     <>;
   return w;
  end;

symbolic procedure fancy!-inprintlist(op,p,l);
   % inside algebraic list
fancy!-level
 begin scalar fst,w,v;
  loop:
   if null l then return w;
   v := car l; l:= cdr l;
   if fst then
       << fancy!-prin2!*("\,",1);
          w:=fancy!-oprin op;
          fancy!-prin2!*("\,",1);
       >>;
   if w eq 'failed  and testing!-width!* then return w;
   w:= if w eq 'failed then fancy!-prinfit(v,0,op)
                    else fancy!-prinfit(v,0,nil);
   if w eq 'failed  and testing!-width!* then return w;
   fst := t;
   goto loop;
  end;

put('times,'fancy!-prtch,"\*");

symbolic procedure fancy!-oprin op;
 fancy!-level
  begin scalar x;
    if (x:=get(op,'fancy!-prtch)) then fancy!-prin2!*(x,1)
      else
    if (x:=get(op,'fancy!-infix!-symbol))
           then fancy!-special!-symbol(x,get(op,'fancy!-symbol!-length)
                                            or 4)
      else
    if null(x:=get(op,'prtch)) then fancy!-prin2!*(op,t)
      else
    << if !*list and obrkp!* and op memq '(plus minus)
        and sumlevel!*=2
       then
        if testing!-width!* and not (!*acn and !*list) then return 'failed
            else fancy!-terpri!* t;
       fancy!-prin2!*(x,t);
    >>;
    if overflowed!* then return 'failed
   end;

put('alpha,'fancy!-special!-symbol,"\alpha");
put('beta,'fancy!-special!-symbol,"\beta");
put('gamma,'fancy!-special!-symbol,"\gamma");
put('delta,'fancy!-special!-symbol,"\delta");
put('epsilon,'fancy!-special!-symbol,"\varepsilon");
put('zeta,'fancy!-special!-symbol,"\zeta");
put('eta,'fancy!-special!-symbol,"\eta");
put('theta,'fancy!-special!-symbol,"\theta");
put('iota,'fancy!-special!-symbol,"\iota");
put('kappa,'fancy!-special!-symbol,"\varkappa");
put('lambda,'fancy!-special!-symbol,"\lambda");
put('mu,'fancy!-special!-symbol,"\mu");
put('nu,'fancy!-special!-symbol,"\nu");
put('xi,'fancy!-special!-symbol,"\xi");
put('pi,'fancy!-special!-symbol,"\pi");
put('rho,'fancy!-special!-symbol,"\rho");
put('sigma,'fancy!-special!-symbol,"\sigma");
put('tau,'fancy!-special!-symbol,"\tau");
put('upsilon,'fancy!-special!-symbol,"\upsilon");
put('phi,'fancy!-special!-symbol,"\phi");
put('chi,'fancy!-special!-symbol,"\chi");
put('psi,'fancy!-special!-symbol,"\psi");
put('omega,'fancy!-special!-symbol,"\omega");

!#if (memq 'csl lispsystem!*)

deflist('(
% Many of these are just the same glyphs as ordinary upper case letters,
% and so for compatibility with external viewers I map those ones onto
% letters with the "\mathit" qualifier to force the font.
     (!Alpha "\mathit{A}") (!Beta "\mathit{B}") (!Chi "\Chi ")
     (!Delta "\Delta ") (!Epsilon "\mathit{E}") (!Phi "\Phi ")
     (!Gamma "\Gamma ") (!Eta "\mathit{H}") (!Iota "\mathit{I}")
     (!vartheta "\vartheta") (!Kappa "\Kappa ") (!Lambda "\Lambda ")
     (!Mu "\mathit{M}") (!Nu "\mathit{N}") (!O "\mathit{O}")
     (!Pi "\Pi ") (!Theta "\Theta ") (!Rho "\mathit{R}")
     (!Sigma "\Sigma ") (!Tau "\Tau ") (!Upsilon "\Upsilon ")
     (!Omega "\Omega ") (!Xi "\Xi ") (!Psi "\Psi ")
     (!Zeta "\mathit{Z}") (!varphi "\varphi ")
        ),'fancy!-special!-symbol);

!#else

if 'a neq '!A then deflist('(
    (!Alpha 65) (!Beta 66) (!Chi 67) (!Delta 68)
    (!Epsilon 69)(!Phi 70) (!Gamma 71)(!Eta 72)
    (!Iota 73) (!vartheta 74)(!Kappa 75)(!Lambda 76)
    (!Mu 77)(!Nu 78)(!O 79)(!Pi 80)(!Theta 81)
    (!Rho 82)(!Sigma 83)(!Tau 84)(!Upsilon 85)
    (!Omega 87) (!Xi 88)(!Psi 89)(!Zeta 90)
    (!varphi 106)
       ),'fancy!-special!-symbol);

!#endif

put('infinity,'fancy!-special!-symbol,"\infty ");
put('partial!-df,'fancy!-special!-symbol,"\partial ");
%put('partial!-df,'fancy!-symbol!-length,8);
put('empty!-set,'fancy!-special!-symbol,"\emptyset ");
put('not,'fancy!-special!-symbol,"\neg ");
put('not,'fancy!-infix!-symbol,"\neg ");
put('leq,'fancy!-infix!-symbol,"\leq ");
put('geq,'fancy!-infix!-symbol,"\geq ");
put('neq,'fancy!-infix!-symbol,"\neq ");
put('intersection,'fancy!-infix!-symbol,"\cap ");
put('union,'fancy!-infix!-symbol,"\cup ");
put('member,'fancy!-infix!-symbol,"\in ");
put('and,'fancy!-infix!-symbol,"\wedge ");
put('or,'fancy!-infix!-symbol,"\vee ");
put('when,'fancy!-infix!-symbol,"|");
put('!*wcomma!*,'fancy!-infix!-symbol,",\,");
put('replaceby,'fancy!-infix!-symbol,"\Rightarrow ");
%put('replaceby,'fancy!-symbol!-length,8);
%put('gamma,'fancy!-functionsymbol,71);  % big Gamma
put('!~,'fancy!-functionsymbol,"\forall ");     % forall
%put('!~,'fancy!-symbol!-length,8);

% arbint, arbcomplex.
%put('arbcomplex,'fancy!-functionsymbol,227);
%put('arbint,'fancy!-functionsymbol,226);
%flag('(arbcomplex arbint),'print!-indexed);

% flag('(delta),'print!-indexed);         % Dirac delta symbol.
% David Hartley voted against..

% The following definitions allow for more natural printing of
% conditional expressions within rule lists.

symbolic procedure fancy!-condpri0 u;
   fancy!-condpri(u,0);

symbolic procedure fancy!-condpri(u,p);
 fancy!-level
  begin scalar w;
    if p>0 then fancy!-prin2 "\left(";
    while (u := cdr u) and w neq 'failed do
      <>;
          if w neq 'failed then w := fancy!-maprin0 cadar u;
          if cdr u then <>>>;
     if p>0 then fancy!-prin2 "\right)";
     if overflowed!* or w='failed then return 'failed;
   end;

put('cond,'fancy!-pprifn,'fancy!-condpri);
put('cond,'fancy!-flatprifn,'fancy!-condpri0);

symbolic procedure fancy!-revalpri u;
   fancy!-maprin0 fancy!-unquote cadr u;

symbolic procedure fancy!-unquote u;
  if eqcar(u,'list) then for each x in cdr u collect
      fancy!-unquote x
  else if eqcar(u,'quote) then cadr u else u;

put('aeval,'fancy!-prifn,'fancy!-revalpri);
put('aeval!*,'fancy!-prifn,'fancy!-revalpri);
put('reval,'fancy!-prifn,'fancy!-revalpri);
put('reval!*,'fancy!-prifn,'fancy!-revalpri);

put('aminusp!:,'fancy!-prifn,'fancy!-patpri);
put('aminusp!:,'fancy!-pat,'(lessp !&1 0));

symbolic procedure fancy!-patpri u;
  begin scalar p;
    p:=subst(fancy!-unquote  cadr u,'!&1,
             get(car u,'fancy!-pat));
    return fancy!-maprin0 p;
  end;

symbolic procedure fancy!-boolvalpri u;
   fancy!-maprin0 cadr u;

put('boolvalue!*,'fancy!-prifn,'fancy!-boolvalpri);

symbolic procedure fancy!-quotpri u;
   begin scalar n1,n2,fl,w,pos,testing!-width!*;
     if overflowed!* or (!*acn and !*list) then return 'failed;
     testing!-width!*:=t;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     fancy!-prin2!*("\frac",0);
     w:=fancy!-maprint!-tex!-bkt(cadr u,0,t);
     n1 := fancy!-pos!*;
     if w='failed
       then return fancy!-fail(pos,fl);
     fancy!-pos!* := pos;
     w := fancy!-maprint!-tex!-bkt(caddr u,0,nil);
     n2 := fancy!-pos!*;
     if w='failed
       then return fancy!-fail(pos,fl);
     fancy!-pos!* := max(n1,n2);
     return t;
  end;

symbolic procedure fancy!-maprint!-tex!-bkt(u,p,m);
  % Produce expression with tex brackets {...} if
  % necessary. Ensure that {} unit is in same formula.
  % If m=t brackets will be inserted in any case.
  begin scalar w,pos,fl,testing!-width!*;
    testing!-width!*:=t;
    pos:=fancy!-pos!*;
    fl:=fancy!-line!*;
   if not m and (numberp u and 0<=u and u <=9 or liter u) then
   << fancy!-prin2!*(u,t);
      return if overflowed!* then fancy!-fail(pos,fl);
   >>;
   fancy!-prin2!*("{",0);
   w := fancy!-maprint(u,p);
   fancy!-prin2!*("}",0);
   if w='failed then return fancy!-fail(pos,fl);
  end;

symbolic procedure fancy!-fail(pos,fl);
 <<
     overflowed!* := nil;
     fancy!-pos!* := pos;
     fancy!-line!* := fl;
     'failed
 >>;

put('quotient,'fancy!-prifn,'fancy!-quotpri);

symbolic procedure fancy!-prinfit(u, p, op);
% Display u (as with maprint) with op in front of it, but starting
% a new line before it if there would be overflow otherwise.
   begin scalar pos,fl,w,ll,f;
     if pairp u and (f:=get(car u,'fancy!-prinfit)) then
        return apply(f,{u,p,op});
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       if w neq 'failed then w := fancy!-maprint(u,p);
     end;
     if w neq 'failed then return t;
     fancy!-line!*:=fl; fancy!-pos!*:=pos;
     if testing!-width!* and w eq 'failed then return w;

     if op='plus and eqcar(u,'minus) then <>;
       % if at least half the line is still free and the
       % object causing the overflow has been a number,
       % let it break.
     if fancy!-pos!* < (ll:=linelength(nil)) then
             if numberp u then return fancy!-prin2number u else
         if eqcar(u,'!:rd!:) then return fancy!-rdprin u;
       % generate a line break if we are not just behind an
       % opening bracket at the beginning of a line.
     if fancy!-pos!* > linelength nil #/ 2 or
          not eqcar(fancy!-last!-symbol(),'bkt) then
           fancy!-terpri!* nil;
     return fancy!-maprint(u, p);
   end;

%-----------------------------------------------------------
%
%   support for print format property
%
%-----------------------------------------------------------

symbolic procedure print_format(f,pat);
  % Assign a print pattern p to the operator form f.
put(car f, 'print!-format, (cdr f . pat) . get(car f, 'print!-format));

symbolic operator print_format;

symbolic procedure fancy!-print!-format(u,p);
 fancy!-level
  begin scalar fmt,fmtl,a;
   fmtl:=get(car u,'print!-format);
 l:
   if null fmtl then return 'failed;
   fmt := car fmtl; fmtl := cdr fmtl;
   if length(car fmt) neq length cdr u then goto l;
   a:=pair(car fmt,cdr u);
   return fancy!-print!-format1(cdr fmt,p,a);
  end;

symbolic procedure fancy!-print!-format1(u,p,a);
  begin scalar w,x,y,pl,bkt,obkt,q;
   if eqcar(u,'list) then u:= cdr u;
   while u and w neq 'failed do
   <> else
           if x eq '!) then <>;
           fancy!-prin2!*(x,1)>> else
        if x eq '!_ or x eq '!^ then <> else
        if q:=assoc(x,a) then fancy!-maprint(cdr q,p) else
        fancy!-maprint(x,p);
     if obkt then fancy!-prin2!*('!},0);
    >>;
    return w;
  end;


%-----------------------------------------------------------
%
%   some operator specific print functions
%
%-----------------------------------------------------------

symbolic procedure fancy!-prefix!-operator(u);
 % Print as function, but with a special character.
   begin scalar sy;
     sy :=
       get(u,'fancy!-functionsymbol) or get(u,'fancy!-special!-symbol);
     if sy
      then fancy!-special!-symbol(sy,get(u,'fancy!-symbol!-length) or 2)
      else fancy!-prin2!*(u,t);
   end;

put('sqrt,'fancy!-prifn,'fancy!-sqrtpri);

symbolic procedure fancy!-sqrtpri(u);
    fancy!-sqrtpri!*(cadr u,2);

symbolic procedure fancy!-sqrtpri!*(u,n);
  fancy!-level
   begin
     if not numberp n and not liter n then return 'failed;
     fancy!-prin2!*("\sqrt",0);
     if n neq 2 then
     <>;
     return fancy!-maprint!-tex!-bkt(u,0,t);
   end;


symbolic procedure fancy!-sub(l,p);
% Prints expression in an exponent notation.
  if get('expt,'infix)<=p then
      fancy!-in!-brackets({'fancy!-sub,mkquote l,0},'!(,'!))
    else
   fancy!-level
    begin scalar eqs,w;
      l:=cdr l;
      while cdr l do <>;
      l:=car l;
      testing!-width!* := t;
      w := fancy!-maprint(l,get('expt,'infix));
      if w='failed then return w;
%      fancy!-prin2!*("\bigl",0);
      fancy!-prin2!*("|",1);
      fancy!-prin2!*('!_,0);
      fancy!-prin2!*("{",0);
      w:=fancy!-inprint('!*comma!*,0,eqs);
      fancy!-prin2!*("}",0);
      return w;
   end;

put('sub,'fancy!-pprifn,'fancy!-sub);


put('factorial,'fancy!-pprifn,'fancy!-factorial);

symbolic procedure fancy!-factorial(u,n);
  fancy!-level
   begin scalar w;
     w := (if atom cadr u then fancy!-maprint(cadr u,9999)
              else
           fancy!-in!-brackets({'fancy!-maprint,mkquote cadr u,0},
                               '!(,'!))
          );
     fancy!-prin2!*("!",2);
     return w;
   end;

put('binomial,'fancy!-prifn,'fancy!-binomial);

symbolic procedure fancy!-binomial u;
  fancy!-level
   begin scalar w1,w2;
     fancy!-prin2!*("\left(\begin{matrix}",2);
     w1 := fancy!-maprint(cadr u,0);
     fancy!-prin2!*("\\",0);
     w2 := fancy!-maprint(caddr u,0);
     fancy!-prin2!*("\end{matrix}\right)",2);
     if w1='failed or w2='failed then return 'failed;
   end;

symbolic procedure fancy!-intpri(u,p);
% Fancy integral print.
   if p>get('times,'infix) then
      fancy!-in!-brackets({'fancy!-intpri,mkquote u,0},'!(,'!))
   else
      fancy!-level
         begin scalar w0,w1,w2,hi,lo;
            if cdddr u then lo:=cadddr u;
            if lo and cddddr u then hi := car cddddr u;
            if fancy!-height(cadr u,1.0) > 3 then
               fancy!-prin2!*("\int ",0) % big integral wanted
            else
               fancy!-prin2!*("\int ",0);
            if lo then <<
               fancy!-prin2!*('!_,0);
               fancy!-prin2!*('!{,0);
               w0 := fancy!-maprint(lo,0);
               fancy!-prin2!*('!},0);
            >>;
            if hi then <<
               fancy!-prin2!*('!^,0);
               fancy!-maprint!-tex!-bkt(hi,0,nil);
            >>;
            w1:=fancy!-maprint(cadr u,0);
            fancy!-prin2!*("\,d\,",2);
            w2:=fancy!-maprint(caddr u,0);
            if w1='failed or w2='failed or w0='failed then return 'failed;
         end;

symbolic procedure fancy!-height(u,h);
  % Fancy height. Estimate the height of an expression, this is a
  % subroutine of fancy!-intpri.
    if atom u then h
    else if car u = 'minus then fancy!-height(cadr u,h)
    else if car u = 'plus or car u = 'times then
      eval('max. for each w in cdr u collect fancy!-height(w,h))
    else if car u = 'expt then
         fancy!-height(cadr u,h) + fancy!-height(caddr u,h*0.8)
    else if car u = 'quotient then
         fancy!-height(cadr u,h) + fancy!-height(caddr u,h)
    else if get(car u,'simpfn) then fancy!-height(cadr u,h)
    else h;

put('int,'fancy!-pprifn,'fancy!-intpri);

symbolic procedure fancy!-sumpri!*(u,p,mode);
  if p>get('minus,'infix) then
    fancy!-in!-brackets({'fancy!-sumpri!*,mkquote u,0,mkquote mode},
                         '!(,'!))
   else
  fancy!-level
   begin scalar w,w0,w1,lo,hi,var;
     var := caddr u;
     if cdddr u then lo:=cadddr u;
     if lo and cddddr u then hi := car cddddr u;
     w:=if lo then {'equal,var,lo} else var;
     if mode = 'sum then
        fancy!-prin2!*("\sum",0) % big SIGMA
     else if mode = 'prod then
        fancy!-prin2!*("\prod",0); % big PI
     fancy!-prin2!*('!_,0);
     fancy!-prin2!*('!{,0);
     if w then w0:=fancy!-maprint(w,0);
     fancy!-prin2!*('!},0);
     if hi then <>;
     fancy!-prin2!*('!\!, ,1);
     w1:=fancy!-maprint(cadr u,0);
     if w0='failed or w1='failed then return 'failed;
   end;

symbolic procedure fancy!-sumpri(u,p); fancy!-sumpri!*(u,p,'sum);

put('sum,'fancy!-pprifn,'fancy!-sumpri);
put('infsum,'fancy!-pprifn,'fancy!-sumpri);

symbolic procedure fancy!-prodpri(u,p); fancy!-sumpri!*(u,p,'prod);

put('prod,'fancy!-pprifn,'fancy!-prodpri);

symbolic procedure fancy!-limpri(u,p);
  if p>get('minus,'infix) then
    fancy!-in!-brackets({'fancy!-sumpri,mkquote u,0},'!(,'!))
   else
  fancy!-level
   begin scalar w,lo,var;
     var := caddr u;
     if cdddr u then lo:=cadddr u;
     fancy!-prin2!*("\lim",6);
     fancy!-prin2!*('!_,0);
     fancy!-prin2!*('!{,0);
     fancy!-maprint(var,0);
     fancy!-prin2!*("\rightarrow",0);
     fancy!-maprint(lo,0);
     fancy!-prin2!*('!},0);
     w:=fancy!-maprint(cadr u,0);
     return w;
   end;

put('limit,'fancy!-pprifn,'fancy!-limpri);

symbolic procedure fancy!-listpri(u);
 fancy!-level
 (if null cdr u then fancy!-maprint('empty!-set,0)
   else
  fancy!-in!-brackets(
   {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote cdr u},
               '!{,'!})
  );

put('list,'fancy!-prifn,'fancy!-listpri);
put('list,'fancy!-flatprifn,'fancy!-listpri);

put('!*sq,'fancy!-reform,'fancy!-sqreform);

symbolic procedure fancy!-sqreform u;
    prepsq!* sqhorner!* cadr u;

put('df,'fancy!-pprifn,'fancy!-dfpri);

% 9-Dec-93: 'total repaired

symbolic procedure fancy!-dfpri(u,l);
  (if flagp(cadr u,'print!-indexed) or
      pairp cadr u and flagp(caadr u,'print!-indexed)
    then fancy!-dfpriindexed(u,l)
   else if m = 'partial then fancy!-dfpri0(u,l,'partial!-df)
   else if m = 'total then fancy!-dfpri0(u,l,'!d)
   else if m = 'indexed then fancy!-dfpriindexed(u,l)
   else rederr "unknown print mode for DF")
        where m=fancy!-mode('fancy_print_df);

symbolic procedure fancy!-partialdfpri(u,l);
     fancy!-dfpri0(u,l,'partial!-df);

symbolic procedure fancy!-dfpri0(u,l,symb);
 if null cddr u then fancy!-maprin0{'times,symb,cadr u} else
 if l >= get('expt,'infix) then % brackets if exponented
  fancy!-in!-brackets({'fancy!-dfpri0,mkquote u,0,mkquote symb},
                      '!(,'!))
   else
 fancy!-level
  begin scalar x,d,q; integer n,m;
    u:=cdr u;
    q:=car u;
    u:=cdr u;
    while u do
    <> else m:=1;
      n:=n+m;
      d:= append(d,{symb,if m=1 then x else {'expt,x,m}});
    >>;
    return fancy!-maprin0
    {'quotient, {'times,if n=1 then symb else
                                    {'expt,symb,n},q},
       'times. d};
  end;

symbolic procedure fancy!-dfpriindexed(u,l);
   if null cddr u then fancy!-maprin0{'times,'partial!-df,cadr u} else
   begin scalar w;
      w:=fancy!-maprin0 cadr u;
      if testing!-width!* and w='failed then return w;
      w :=fancy!-print!-indexlist fancy!-dfpriindexedx(cddr u,nil);
      return w;
   end;

symbolic procedure fancy!-dfpriindexedx(u,p);
  if null u then nil else
  if numberp car u then
   append(for i:=2:car u collect p,fancy!-dfpriindexedx(cdr u,p))
     else
  car u . fancy!-dfpriindexedx(cdr u,car u);

put('!:rd!:,'fancy!-prifn,'fancy!-rdprin);
put('!:rd!:,'fancy!-flatprifn,'fancy!-rdprin);

symbolic procedure fancy!-rdprin u;
 fancy!-level
  begin scalar digits; integer dotpos,xp;
   u:=rd!:explode u;
   digits := car u; xp := cadr u; dotpos := caddr u;
   return fancy!-rdprin1(digits,xp,dotpos);
  end;

symbolic procedure fancy!-rdprin1(digits,xp,dotpos);
  begin scalar str;
   if xp>0 and dotpos+xp>;
    % build character string from number.
   for i:=1:dotpos do
   <400 then return 'failed;

      if x then
      << fancy!-maprint(x,0); fancy!-prin2!*(":=",4) >>;
      fl := fancy!-line!*; fp := fancy!-pos!*;
         %  remaining room for the columns.
      rw := linelength(nil)-2 -(fancy!-pos!*+2);
      rw := rw/cols;
      fmat := for each row in u collect
        for each elt in row collect
          if not fail then
          <maxpos then maxpos:=fancy!-pos!*;
            if w='failed or fancy!-pos!*>rw
              then fail:=t else
               (fancy!-line!*.fancy!-pos!*)
          >>;
     if fail then return 'failed;
     testing!-width!* := nil;
       % restore output line.
     fancy!-pos!* := fp; fancy!-line!* := fl;
       % TEX header
     fancy!-prin2!*(bldmsg("\left%w\begin{matrix}",
                        if bkt then car bkt else "("),0);
       % join elements.
     while fmat do
     <>;
  % if the next row does not fit on the current print line
  % we move it completely to a new line.
       if fst then
        w:= fancy!-level
         fancy!-in!-brackets(
          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
            '!(,'!)) where testing!-width!*=t;
       if w eq 'failed then fancy!-terpri!* t;
       if not fst or w eq 'failed then
         fancy!-in!-brackets(
          {'fancy!-inprintlist,mkquote '!*wcomma!*,0,mkquote v},
            '!(,'!));
       fst := t;
     >>;
  end;

put('mat,'fancy!-flatprifn,'fancy!-matpriflat);

symbolic procedure fancy!-matfit(u,p,op);
% Prinfit routine for matrix.
% a new line before it if there would be overflow otherwise.
 fancy!-level
   begin scalar pos,fl,fp,w,ll;
     pos:=fancy!-pos!*;
     fl:=fancy!-line!*;
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       if w neq 'failed then w := fancy!-matpri(u);
     end;
     if w neq 'failed or
       (w eq 'failed and testing!-width!*) then return w;
     fancy!-line!*:=fl; fancy!-pos!*:=pos; w:=nil;
     fp := fancy!-page!*;
% matrix: give us a second chance with a fresh line
     begin scalar testing!-width!*;
       testing!-width!*:=t;
       if op then w:=fancy!-oprin op;
       fancy!-terpri!* nil;
       if w neq 'failed then w := fancy!-matpri u;
     end;
     if w neq 'failed then return t;
     fancy!-line!*:=fl; fancy!-pos!*:=pos; fancy!-page!*:=fp;

     ll:=linelength nil;
     if op then fancy!-oprin op;
     if atom u or fancy!-pos!* > ll #/ 2 then fancy!-terpri!* nil;
     return fancy!-matpriflat(u);
   end;

put('mat,'fancy!-prinfit,'fancy!-matfit);

put('taylor!*,'fancy!-reform,'Taylor!*print1);

endmodule;

module fancy_specfn;

put('sin,'fancy!-prifn,'fancy!-sin);
put('cos,'fancy!-prifn,'fancy!-cos);
put('tan,'fancy!-prifn,'fancy!-tan);
put('cot,'fancy!-prifn,'fancy!-cot);
put('sec,'fancy!-prifn,'fancy!-sec);
put('csc,'fancy!-prifn,'fancy!-csc);
put('asin,'fancy!-prifn,'fancy!-asin);
put('acos,'fancy!-prifn,'fancy!-acos);
put('atan,'fancy!-prifn,'fancy!-atan);
put('sinh,'fancy!-prifn,'fancy!-sinh);
put('cosh,'fancy!-prifn,'fancy!-cosh);
put('tanh,'fancy!-prifn,'fancy!-tanh);
put('coth,'fancy!-prifn,'fancy!-coth);
put('exp,'fancy!-prifn,'fancy!-exp);
put('log,'fancy!-prifn,'fancy!-log);
put('ln,'fancy!-prifn,'fancy!-ln);
put('max,'fancy!-prifn,'fancy!-max);
put('min,'fancy!-prifn,'fancy!-min);
%put('repart,'fancy!-prifn,'fancy!-repart);
%put('impart,'fancy!-prifn,'fancy!-impart);

symbolic procedure fancy!-sin(u);
 fancy!-level
  begin
   fancy!-prin2!*("\sin",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-cos(u);
 fancy!-level
  begin
   fancy!-prin2!*("\cos",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-tan(u);
 fancy!-level
  begin
   fancy!-prin2!*("\tan",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-cot(u);
 fancy!-level
  begin
   fancy!-prin2!*("\cot",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-sec(u);
 fancy!-level
  begin
   fancy!-prin2!*("\sec",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-csc(u);
 fancy!-level
  begin
   fancy!-prin2!*("\csc",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-asin(u);
 fancy!-level
  begin
   fancy!-prin2!*("\arcsin",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-acos(u);
 fancy!-level
  begin
   fancy!-prin2!*("\arccos",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-atan(u);
 fancy!-level
  begin
   fancy!-prin2!*("\arctan",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-sinh(u);
 fancy!-level
  begin
   fancy!-prin2!*("\sinh",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-cosh(u);
 fancy!-level
  begin
   fancy!-prin2!*("\cosh",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-tanh(u);
 fancy!-level
  begin
   fancy!-prin2!*("\tanh",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-coth(u);
 fancy!-level
  begin
   fancy!-prin2!*("\coth",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-exp(u);
 fancy!-level
  begin
   fancy!-prin2!*("\exp",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-log(u);
 fancy!-level
  begin
   fancy!-prin2!*("\log",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-ln(u);
 fancy!-level
  begin
   fancy!-prin2!*("\ln",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-max(u);
 fancy!-level
  begin
   fancy!-prin2!*("\max",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-min(u);
 fancy!-level
  begin
   fancy!-prin2!*("\min",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-repart(u);
 fancy!-level
  begin
   fancy!-prin2!*("\Re",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

symbolic procedure fancy!-impart(u);
 fancy!-level
  begin
   fancy!-prin2!*("\Im",0);
   return fancy!-print!-function!-arguments cdr u;
  end;

put('besseli,'fancy!-prifn,'fancy!-bessel);
put('besselj,'fancy!-prifn,'fancy!-bessel);
put('bessely,'fancy!-prifn,'fancy!-bessel);
put('besselk,'fancy!-prifn,'fancy!-bessel);
put('besseli,'fancy!-functionsymbol,'(ascii 73));
put('besselj,'fancy!-functionsymbol,'(ascii 74));
put('bessely,'fancy!-functionsymbol,'(ascii 89));
put('besselk,'fancy!-functionsymbol,'(ascii 75));

symbolic procedure fancy!-bessel(u);
 fancy!-level
  begin scalar w;
   fancy!-prefix!-operator car u;
   w:=fancy!-print!-one!-index cadr u;
   if testing!-width!* and w eq 'failed then return w;
   return fancy!-print!-function!-arguments cddr u;
  end;

% Hypergeometric functions.

put('empty!*,'fancy!-special!-symbol,32);  % no longer used?

put('hypergeometric,'fancy!-prifn,'fancy!-hypergeometric);

symbolic procedure fancy!-hypergeometric u;
 fancy!-level
  begin scalar w,a1,a2,a3;
   a1 :=cdr cadr u;
   a2 := cdr caddr u;
   a3 := cadddr u;
   %fancy!-special!-symbol(get('empty!*,'fancy!-special!-symbol),nil);
   fancy!-prin2!*("{}",0);
   w:=fancy!-print!-one!-index length a1;
   if testing!-width!* and w eq 'failed then return w;
   fancy!-prin2!*("F",nil);
   w:=fancy!-print!-one!-index length a2;
   if testing!-width!* and w eq 'failed then return w;
   fancy!-prin2!*("\left(\left.",nil);
   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
   fancy!-prin2!*("\,",1);
   %w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
   fancy!-prin2!*("\right|\,",1);
   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
   fancy!-prin2!*("\right)",nil);
   return w;
  end;

% hypergeometric({1,2,u/w,v},{5,6},sqrt x);

put('meijerg,'fancy!-prifn,'fancy!-meijerG);

symbolic procedure fancy!-meijerG u;
 fancy!-level
  begin scalar w,a1,a2,a3;
   integer n,m,p,q;
   a1 :=cdr cadr u;
   a2 := cdr caddr u;
   a3 := cadddr u;
   m:=length cdar a2;
   n:=length cdar a1;
   a1 := append(cdar a1 , cdr a1);
   a2 := append(cdar a2 , cdr a2);
   p:=length a1; q:=length a2;
   fancy!-prin2!*("G",nil);
   w := w eq 'failed or
        fancy!-print!-indexlist1({m,n},'!^,nil);
   w := w eq 'failed or
        fancy!-print!-indexlist1({p,q},'!_,nil);
   fancy!-prin2!*("\left(",nil);
   w := w eq 'failed or fancy!-prinfit(a3,0,nil);
   %w := w eq 'failed or fancy!-special!-symbol(124,1);    % vertical bar
   fancy!-prin2!*("\left|",1);
   w := w eq 'failed or fancy!-print!-indexlist1(a1,'!^,'!*comma!*);
   w := w eq 'failed or fancy!-print!-indexlist1(a2,'!_,'!*comma!*);
   fancy!-prin2!*("\right.\right)",nil);
   return w;
  end;

% meijerg({{},1},{{0}},x);

% Now a few things that can be useful for testing this code...

symbolic <<
% Arrange that if this file is loaded twice you do not get silly messages
% to do with redefinition of these.
  if not get('texsym, 'simpfn) then
    algebraic operator texsym, texbox, texfbox, texstring >>;

% texsym(!Longleftarrow) should generate \Longleftarrow (etc). This
% might plausibly be useful while checking that the interface can render
% all TeX built-in keywords properly. Furthermore I allow extra args, so
% that eg texsym(stackrel,f,texsym(longrightarrow)) turns into
%   \stackrel{f}{\longrightarrow}

put('texsym,'fancy!-prifn,'fancy!-texsym);

symbolic procedure fancy!-texsym u;
   fancy!-level
    begin
      if null u then return;
      fancy!-prin2 list!-to!-string ('!\ . explode2 cadr u);
      u := cddr u;
      while u do <<
         fancy!-line!* := "{" . fancy!-line!*;
         fancy!-maprint(car u, 0);
         fancy!-line!* := "}" . fancy!-line!*;
         u := cdr u >>
    end;

% texstring("arbitrary tex stuff",...)
% where atoms (eg strings and words) are just passed to tex but
% more complicated items go through fancy!-maprint.

put('texstring,'fancy!-prifn,'fancy!-texstring);

symbolic procedure fancy!-texstring u;
   fancy!-level
    for each s in cdr u do <<
      if not atom s then fancy!-maprint(s, 0)
      else <<
         if not stringp s then s := list!-to!-string explode2 s;
         fancy!-line!* := s . fancy!-line!* >> >>;

% texbox(h) is a box of given height (in points)
% texbox(h, d) is a box of given height and depth
%              height is amount above the reference line, depth is amount
%              below.
% textbox(h, d, c) is a box of given size with some specified content

% All these draw a frame around the space used so you can see what is
% goin on.

% The idea that this may be useful when checking how layouts cope with
% various sizes of content, eg big delimiters, square root signs etc. So I
% can test with "for i := 10:40 do write sqrt(texbox(i))" etc.
% to test sqrt with arguments of height 10, 11, ... to 40 points. Note that
% certainly with the CSL version the concept of a "point" is a bit vauge!
% However if I were to imagine that my screen was at 75 pixels per inch I
% could with SOME reason interpret point as meaning pixel, and that is
% what I will do. At present what I might do about hard-copy output is
% pretty uncertain. If height and depth are given as 0 and there is a
% content them the content will define the box size.

put('texbox,'fancy!-prifn,'fancy!-texbox);

symbolic procedure fancy!-texbox u;
   fancy!-level
    begin
      scalar height, depth, contents;
      contents := nil;
      u := cdr u;
      height := car u;
      u := cdr u;
      if u then <<
         depth := car u;
         u := cdr u;
         if u then contents := car u >>;
      if not numberp height then height:=0;
      if not numberp depth then depth:=0;
      if height=0 and depth=0 and null contents then height:=10;
      fancy!-prin2 "\fbox{";
      if height neq 0 or depth neq 0 then << % insert a rule
         fancy!-line!* := "\rule" . fancy!-line!*;
         if depth neq 0 then <<
            fancy!-line!* := "[-" . fancy!-line!*;
            fancy!-line!* := depth . fancy!-line!*;
            fancy!-line!* := "pt]" . fancy!-line!* >>;
         fancy!-line!* := "{0pt}{" . fancy!-line!*;
         fancy!-line!* := (height+depth) . fancy!-line!*;
         fancy!-line!* := "pt}" . fancy!-line!* >>;
      if contents then contents := fancy!-maprint(contents, 0)
      else fancy!-line!* := "\rule{10pt}{0pt}" . fancy!-line!*;
      fancy!-prin2 "}";
      return contents
    end;

% texfbox is a simplified version of texbox, and just draws a box around the
% expression it is given.

put('texfbox,'fancy!-prifn,'fancy!-texfbox);

symbolic procedure fancy!-texfbox u;
   fancy!-level
    begin
      fancy!-prin2 "\fbox{";
      u := fancy!-maprint(cadr u, 0);
      fancy!-prin2 "}";
      return u
    end;



endmodule;

module promptcolor;
% Adapted from Prompt coloring for redfront.

fluid '(lispsystem!*);

fluid '(promptstring!* tm_switches!* tm_switches!-this!-sl!* lessspace!*);

fluid '(!*promptnumbers);
switch promptnumbers;
if texmacsp () then % We don't want prompt numbers in a Texmacs worksheet
   off1 'promptnumbers
else
   on1 'promptnumbers;

tm_switches!* := {!*msg,!*output};

off1 'msg;
off1 'output;

procedure tm_bprompt();
   % Begin of prompt.
   {int2id 2,'c,'h,'a,'n,'n,'e,'l,'!:,'p,'r,'o,'m,'p,'t,int2id 5,
      int2id 2,'l,'a,'t,'e,'x,'!:,'!R,'!E,'!D,'!U,'!C,'!E};

procedure tm_eprompt();
   % End of prompt
   {'!],'!\,'! ,int2id 5};

% This always gets a list of the characters that make up the prompt...
procedure tm_coloredp(ec);
      eqcar(ec, car tm_bprompt());

procedure tm_nconcn(l);
   % Taken from rltools.
   if cdr l then nconc(car l,tm_nconcn cdr l) else car l;

symbolic procedure tm_prunelhead(l, l1);
    if null l or null l1 then l else tm_prunelhead(cdr l, cdr l1);

procedure tm_pruneltail(l,l1);
   reversip tm_prunelhead(reversip l,l1);

procedure tm_pslp();
   'psl memq lispsystem!*;

if tm_pslp() then <<
   tm_switches!-this!-sl!* := {!*usermode};
   off1 'usermode
>>;

procedure tm_color(c);
   % Color prompt. This will handle EITHER an identifier OR a string, and
   % it returns the same sort of object. It wraps tm_bprompt() and
   % tm_eprompt() around the text it is passed.
   begin scalar ec, sf;
      if stringp c then <<
               ec := string!-to!-list c;
               sf := t >>
      else ec := explode2 c;   % Original code has explode not explode2 here.
      ec := '!  . ec; % add space
      if not !*promptnumbers then << % strip numbers from prompt
               while ec and memq(car ec,'(!  !0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) do
            ec := cdr ec;
         ec := if ec and eqcar(ec,'!*) then {'!*};
      >>;
      ec := append(tm_bprompt(), append(ec, tm_eprompt()));
      ec := list!-to!-string ec;
      if sf then return ec
      else return intern ec
   end;

procedure tm_uncolor(c);
   % Uncolor prompt.
   begin scalar ec, sf;
      if stringp c then <<
           ec := string!-to!-list c;
           sf := t >>
       else ec := explode2 c;  % cf explode?
       if not tm_coloredp ec then return c;
       ec := tm_prunelhead(ec, tm_bprompt());
       if car ec eq '!  then ec := cdr ec; % strip space
       ec := tm_pruneltail(ec, tm_eprompt());
       ec := list!-to!-string ec;
       if sf then return ec
       else return intern ec
   end;

procedure tm_setpchar!-psl(c);
   begin scalar w;
      w := tm_setpchar!-orig c;
      promptstring!* := tm_color promptstring!*;
      return tm_uncolor w
   end;

!#if (memq 'csl lispsystem!*)

switch redfront_mode;

% I do not think there is any merit in even definning this if I am not
% using CSL.

procedure tm_setpchar!-csl(c);
% With CSL in many cases the system does prompt colouring at a lower level
% in the code, so the stuff here is not necessary. However if CSL is used
% with an external redfront of texmacs interface I will want to activate
% this special stuff. So I provide a switch redfront_mode that controls
% what I do. I expect to run with this module loaded almost all of the time
% which is why I want a control via switch rather than through just
% "load tmprint". I note that if CSL is loaded from a script that attaches it
% to redfront of som eother interface that the invocation can use
%      -D*redfront_mode
% to preset the switch, which ought to be a small enough burden to be
% tolerable!
   if !*redfront_mode then tm_uncolor tm_setpchar!-orig tm_color c
   else tm_setpchar!-orig c;

!#endif

if not getd 'tm_setpchar!-orig then copyd('tm_setpchar!-orig,'setpchar);

if tm_pslp() then
   copyd('setpchar,'tm_setpchar!-psl)
else
   copyd('setpchar,'tm_setpchar!-csl);

procedure tm_yesp!-psl(u);
   begin scalar ifl,ofl,x,y;
      if ifl!* then <<
         ifl := ifl!* := {car ifl!*,cadr ifl!*,curline!*};
         rds nil
      >>;
      if ofl!* then <<
         ofl:= ofl!*;
          wrs nil
      >>;
      if null !*lessspace then
          terpri();
      if atom u then
          prin2 u
      else
          lpri u;
      if null !*lessspace then
          terpri();
      y := setpchar "?";
      x := yesp1();
      setpchar y;
      if ofl then wrs cdr ofl;
      if ifl then rds cadr ifl;
      cursym!* := '!*semicol!*;
      return x
   end;

if tm_pslp() then <<
   remflag('(yesp),'lose);
   copyd('tm_yesp!-orig,'yesp);
   copyd('yesp,'tm_yesp!-psl);
   flag('(yesp),'lose)
>>;

% Color PSL prompts, in case user falls through:

procedure tm_compute!-prompt!-string(count,level);
   tm_color tm_compute!-prompt!-string!-orig(count,level);

if tm_pslp() then <<
   copyd('tm_compute!-prompt!-string!-orig,'compute!-prompt!-string);
   copyd('compute!-prompt!-string,'tm_compute!-prompt!-string)
>>;

procedure tm_break_prompt();
   <<
      prin2 "break["; prin2 breaklevel!*; prin2 "]";
      promptstring!* := tm_color promptstring!*
   >>;

if tm_pslp() then <<
   remflag('(break_prompt),'lose);
   copyd('break_prompt,'tm_break_prompt);
   flag('(break_prompt),'lose);
>>;

if tm_pslp() then
   onoff('usermode,car tm_switches!-this!-sl!*);

onoff('msg,car tm_switches!*);
onoff('output,cadr tm_switches!*);

crbuf!* := nil;
inputbuflis!* := nil;
lessspace!* := t;
statcounter := 0;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/0000755000175000017500000000000011722677364021142 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pmpatch.red0000644000175000017500000001306011526203062023250 0ustar  giovannigiovannimodule pmpatch; % Patches to make pattern matcher run in REDUCE 3.4.

% Author: Kevin McIsaac.
% Changes by Rainer M .Schoepf

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% remflag('(evenp),'opfn);

% remprop('list,'evfn);

% remprop('list,'rtypefn);

% Redefine LISTEVAL so that the arguments are always returned in prefix
% form.

global '(simpcount!* simplimit!*);

symbolic procedure listeval(u,v);
   <simplimit!*
       then <>;
     u := if atom u
            then listeval(if flagp(u,'share) then eval u
                           else cadr get(u,'avalue),v)
           else car u . for each x in cdr u collect reval1(x,t);
     simpcount!* := simpcount!*-1;
     u>>;


% Allow EXPR as a keyword in patterns.

% remprop('expr,'stat);

% Make REVAL of an equation return a simplified value.

fluid '(substitution);

symbolic procedure equalreval u;
  if null substitution then 'equal . car u . list reval cadr u
   else if evalequal(car u,cadr u) then t
   else 0;

% Define function to prevent simplification of arguments of symbolic
% operators.
% If the i'th element of `list' is `nil' then the i'th argument of `fn'
% is left unsimplified by simp.  If `list' is longer that the argument
% list of `fn' then the extra indicators are ignored.  If `list' is
% shorter than the argument list of `fn' then the remaining arguments
% are simplified, eq nosimp(cat,'(nil T nil)) will cause the 1 and third
% arguments of the functions `cat' to be left un simplified.

symbolic procedure nosimp(fn,list);
  <>;

symbolic operator nosimp;

flag('(nosimp), 'noval);

symbolic procedure fnreval(u,v,mode);
   % Simplify list u according to list v. If mode is NIL use AEVAL
   % else use REVAL.
   if null u then nil
    else if v eq t then u
    else if null v then for each j in u collect reval1(j ,mode)
    else ((if car v then car u
           else reval1(car u, mode)) . fnreval(cdr u,cdr v,mode));

% Next two routines are changes to module SIMP to add NOSIMP code.

symbolic procedure opfneval u;
   lispeval(car u . for each j in
                  (if flagp(car u,'noval) then cdr u
                  else fnreval(cdr u,get(car u,'nosimp),t))
                            collect mkquote j);

fluid '(ncmp!* subfg!*);

symbolic procedure simpiden u;
   % Convert the operator expression U to a standard quotient.
   % Note: we must use PREPSQXX and not PREPSQ* here, since the REVOP1
   % in SUBS3T uses PREPSQXX, and terms must be consistent to prevent a
   % loop in the pattern matcher.
   begin scalar bool,fn,x,y,z,n;
    fn := car u; u := cdr u;
    if x := valuechk(fn,u) then return x;
    if not null u and eqcar(car u,'list)
      then return mksq(list(fn,aeval car u),1);
    % *** Following line added to add nosimp code.
    x := fnreval(u, get(fn, 'nosimp),nil);
%    x := for each j in cdr u collect aeval j;
    u := for each j in x collect
              if eqcar(j,'!*sq) then prepsqxx cadr j
               else if numberp j then j
               else <>;
    if u and car u=0
       and flagp(fn,'odd) and not flagp(fn,'nonzero)
      then return nil ./ 1;
    u := fn . u;
    if flagp(fn,'noncom) then ncmp!* := t;
    if null subfg!* then go to c
     else if flagp(fn,'linear) and (z := formlnr u) neq u
      then return simp z
     else if z := opmtch u then return simp z
     else if z := get(car u,'opvalfn) then return apply1(z,u);
 %    else if null bool and (z := domainvalchk(fn,
 %                for each j in x collect simp j))
 %     then return z;
    c:  if flagp(fn,'symmetric) then u := fn . ordn cdr u
         else if flagp(fn,'antisymmetric)
          then <>;
    if (flagp(fn,'even) or flagp(fn,'odd))
       and x and minusf numr(x := simp car x)
     then <>;
    u := mksq(u,1);
    return if y then negsq u else u
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pmrules2.red0000644000175000017500000005330611526203062023374 0ustar  giovannigiovannimodule pmrules2;  % More rules for PM Pattern matcher.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% NOTE:  This module is supplied for information purposes only.  It
%        still needs work to run properly in REDUCE 3.4.  However,
%        the examples are sufficiently useful that the module is
%        included in the distribution.

load!-package 'pmrules; % This loads both PM and PMRULES.

algebraic;

% Absolute Value Function.

% Use the name XAbs to avoid problems with abs.

xabs(?a*?b) ::- xabs(?a)*xabs(?b);
xabs(?a/?b)  ::- xabs(?a)/xabs(?b);
xabs(?a^?n)  ::- xabs(?a)^?n;
xabs(?x _=posp(?x)) :- ?x;
xabs(?x _=posp(-?x)) :- -?x;


% XComb -generalization of Comb to general real arguments.

% Author: Paul C Abbott, Univ. of Western Australia, Nov 85.

comb(?a,?b)::- gamma(?a+1)/gamma(?b+1)/gamma(?a-?b+1);
comb(?a,?n _=natp(?n+1))::- (-1)^?n *poc(-?a,?n)/fctl(?n);


% Parity testing simplification.

% Author: J Gottschalk, Univ. of Western Australia, Mar 85.

% SMP already realizes that Evenp[x]:1 => Intp[x]:1 ;

% Use the name XEvenp to avoid probles with evenp.

XEvenp((??x _=XEvenp(??x))+(?y _=XEvenp(?y))) :- t;
XEvenp((??x _= oddp(??x))+(?y _= oddp(?y))) :- t;
XEvenp((??x _= oddp(??x))+(?y _=XEvenp(?y))) :- 0;
XEvenp((??x _= intp(??x)) * (?y _=XEvenp(?y))) :- t;
XEvenp((??x _= oddp(??x)) * (?y _= oddp(?y))) :- 0;
XEvenp(( ?x _= XEvenp(?x))^(?y _= intp(?y))) :- t;
XEvenp(( ?x _=  oddp(?x))^(?y _= intp(?y))) :- 0;

oddp((??x _= oddp(??x))+(?y _= oddp(?y))) :- 0;
oddp((??x _=XEvenp(??x))+(?y _=XEvenp(?y))) :- 0;
oddp((??x _= oddp(??x))+(?y _=XEvenp(?y))) :- t;
oddp((??x _= intp(??x)) * (?y _=XEvenp(?y))) :- 0;
oddp((??x _= oddp(??x)) * (?y _= oddp(?y))) :- t;
oddp(( ?x _= XEvenp(?x))^(?y _= intp(?y))) :- 0;
oddp(( ?x _=  oddp(?x))^(?y _= intp(?y))) :- t;


% Legendre polynomials in ?x of order ?n, ?n a natural number.

operator legp;

legp(?x,0) :- 1;

legp(?x,1) :- ?x;

legp(?x,?n _=natp(?n))
   ::- ((2*?n-1)*?x*legp(?x,?n-1)-(?n-1)*legp(?x,?n-2))/?n;

% Using Mset.

operator mlegp;

mlegp(?x,0) :- 1;
mlegp(?x,1) :- ?x;
mlegp(?x,?n _=natp(?n))
   ::- ((2*?n-1)*?x*mlegp(?x,?n-1)-(?n-1)*mlegp(?x,?n-2))/?n;


comment * Generalized hypergeometric functions: elementary identities *;

% Author: John Gottschalk, Univ. of Western Australia, Sep 84.

comment P: XWarning is automatically loaded. ;
 ;
% Keywords:: hypergeometric: generalized hypergeometric functions:
%       Ghg: sums: summation: gauss: vandermonde: saalschutz: whipple:
%       kummer: watson: dixon: dougall.

comment This file contains assignments and substitutions for rewriting
        special generalized hypergeometric functions in terms of Gamma
        and Polygamma functions. ;

comment These identities are from Appendix 3 of Slater "Generalized
        Hypergeometric Functions", Cambridge University Press,1966.
        Those that have been omitted may be simply derived form other
        results, for example equation III.25 is is a result of equation
        III.11. ;

flag('(#), 'symmetric);

% Some commonly used theorems can be called by the following names:

intdiff      ::-  sghg(0,{1,2,3,4});
gauss        ::-  sghg(0,5);
vandermonde  ::-  sghg(0,6);
saalschutz   ::-  sghg(0,7);
whipple      ::-  sghg(0,8);
kummer       ::-  sghg(0,9);
watson       ::-  sghg(0,10);
dixon        ::-  sghg(0,11);
dougall      ::-  sghg(0,12);
nearlypoised ::-  sghg(0,{13,14,15});
wellpoised   ::-  flat({sghg(0,{16,17,18,19}),dixon,dougall,kummer});

comment The patterns are written with a "=" sign as the pattern matcher
        in version 1.5.0. will return a 0 for matches like
        Match[a/2+1/2,(a+1)/2], but use of Eq gets around this problem;

comment  Reduction for 2F1(1,a:a+m:-1) when m is a natural number. ;

%SGhg(0,1) :- Ghg(2,1,#(1,?a),#(?b _=Natp(?b-?a)),-1) ->
%     (-1)^(?b-?a-1) *Gamma(?b)/
%     (2*Gamma(?a)) *Sum((-1)^n/(Gamma(n+1) *Gamma(?b-?a-n))
%     * (Psi(?b/2-n/2)-Psi(?b/2-n/2-1/2)),{n,0,?b-?a-1}) ;

%SGhg(0,2) :- Ghg(?p _=?p>2,?p-1,#(1,??a),
%                #(??b) _=Union({??b})-Union({??a}) = {1},1) -->
%     -Psi(?p-2,{??a}(1)) * (-1)^?p * ({??a}(1))^(?p-1)/Fctl(?p-2);

%SGhg(0,3) :- Ghg(?p _=?p>2,?p-1,#(1,??a),
%            #(??b) _=Union({??b})-Union({??a}) = {1},-1) -->
%     (Psi(?p-2,({??a}(1))/2+1/2)-Psi(?p-2,({??a}(1))/2)) * (-1)^?p
%     * ({??a}(1))^(?p-1) *2^(1-?p)/Fctl(?p-2);

sghg(0,4) :- ghg(3,2,#(1,?a,?b),#(?a+1,?b+1),1 _=symbwt(?b~=?a)) ->
     ?a *?b/(?a-?b) * (psi(?a)-psi(?b));

comment  Gauss's theorem ;
sghg(0,5) :- ghg(2,1,#(?a,?b),#(?c),1) ->
     gamma(?c) *gamma(?c-?a-?b)/(gamma(?c-?a) *gamma(?c-?b));

comment  Vandermonde's theorem ;
sghg(0,6) :- ghg(2,1,#(?a,?n _=natp(1-?n)),#(?c),1)
           -> poc(?c-?a,-?n)/poc(?c,-?n);

comment  Saalschutz's theorem ;
sghg(0,7) :- ghg(3,2,#(?a,?b,?n _=natp(1-?n)),
                     #(?c,?d _=?d=?a+?b+?n-?c+1),1) ->
     gamma(?c-?a-?n) *gamma(?c-?b-?n) *gamma(?c) *gamma(?c-?a-?b)/
     (gamma(?c-?a) *gamma(?c-?b) *gamma(?c-?n) *gamma(?c-?a-?b-?n));

comment  Whipple's theorem ;
sghg(0,8) :- ghg(3,2,#(?a,?b _=?b=1-?a,?c),#(?d,?e) _=?d+?e=1+2*?c,1) ->
     pi *2^(1-2*?c) *gamma(?d) *gamma(?e)/
     (gamma((?a+?e)/2) *gamma((?a+?d)/2) *gamma((?d+?e)/2)
      *gamma((?b+?d)/2));

comment  Kummer's theorem ;
sghg(0,9) :- ghg(2,1,#(?a,?b),#(?c _=?c=1+?a-?b),-1) ->
    gamma(1+?a-?b) *gamma(1+?a/2)/(gamma(1+?a) *gamma(1+?a/2-?b)) ;

comment  Watson's Theorem ;
sghg(0,10) :- ghg(3,2,#(?a,?b,?c),#(?d _=?d=(1+?a+?b)/2,?e _=?e=2*?c),1)->
   gamma(1/2) *gamma(?c+1/2) *gamma((1+?a+?b)/2) *gamma((1-?a-?b)/2+?c)/
   (gamma((1+?a)/2) *gamma((1+?b)/2) *gamma((1-?a)/2+?c)
    *gamma((1-?b)/2+?c));

comment  Dixon's theorem ;
sghg(0,11):- ghg(3,2,#(?a,?b,?c),#(?d _=?d=1+?a-?b,?e _=?e=1+?a-?c),1) ->
     gamma(1+?a/2) *gamma(1+?a-?b)*gamma(1+?a-?c)*gamma(1+?a/2-?b-?c)/
     (gamma(1+?a)*gamma(1+?a/2-?b)*gamma(1+?a/2-?c)*gamma(1+?a-?b-?c));

comment  Dougall's theorem ;
sghg(0,12) :- ghg(7,6,#(?a,?f _=?f=1+?a/2,?b,?c,?d,?e,?n _=natp(1-?n) &
     1+2*?a-?b-?c-?d-?e-?n=0),
     #(?g _=?g=?a/2,?h _=?h=1+?a-?b,?i _=?i=1+?a-?c,?j _=?j=1+?a-?d,
                                    ?k _=?k=1+?a-?e,?l _=?l=1+?a-?n),1) ->
     poc(1+?a,-?n) *poc(1+?a-?b-?c,-?n) *poc(1+?a-?b-?d,-?n)
        *poc(1+?a-?c-?d,-?n)/
     (poc(1+?a-?b,-?n) *poc(1+?a-?c,-?n) *poc(1+?a-?d,-?n)
        *poc(1+?a-?b-?c-?d,-?n));

comment  Appendix III.15 in Slater's book ;
sghg(0,13) :- ghg(3,2,#(?a,?c _=?c=1+?a/2,?n _=natp(1-?n)),
                      #(?d _=?d=?a/2,?b),1) ->
                 (?b-?a-1+?n) *poc(?b-?a,-?n-1)/poc(?b,-?n);

comment  Appendix III.16 in Slater's book ;
sghg(0,14) :- ghg(3,2,#(?a,?b,?n _=natp(1-?n)),
                          #(?c _=?c=1+?a-?b,?d _=?d=1+2*?b+?n),1) ->
     poc(?a-2*?b,-?n) *poc(1+?a/2-?b,-?n) *poc(-?b,-?n)/
     (poc(1+?a-?b,-?n) *poc(?a/2-?b,-?n) *poc(-2*?b,-?n));

comment  Appendix III.17 in Slater's book ;
sghg(0,15) :- ghg(4,3,#(?a,?c _=?c=1+?a/2,?b,?n _=natp(1-?n)),
          #(?d _=?d=?a/2,?e _=?e=1+?a-?b,?f _=?f=1+2*?b+?n),1) ->
     poc(?a-2*?b,-?n) *poc(-?b,-?n)/(poc(1+?a-?b,-?n) *poc(-2*?b,-?n));

comment  Appendix III.19 in Slater's book ;
sghg(0,16) :- ghg(7,6,#(?a,?b,?c _=?c=1+?a/2,?d _=?d=1/2+?b,
  ?e _=?e=?a-2*?b,?f _=?f=1+2*?a-2*?b-?n,?n _=natp(1-?n)),
  #(?g _=?g=?a/2,?h _=?h=1+?a-?b,?i _=?i=?a+1/2-?b,?j _=?j=1+2*?b,
    ?k _=?k=2*?b-?a+?n,?l _=?l=1+?a-?n),1) ->
  poc(1+?a,-?n) *poc(1+2*?a-4*?b,-?n)/(poc(1+?a-2*?b,-?n)
      *poc(1+2*?a-2*?b,-?n));

comment  Appendix III.20 in Slater's book ;
sghg(0,17) :- ghg(4,3,#(?a,?b,?n _=natp(1-?n),?c _=?c=1/2+?a),
          #(?d _=?d=?b/2+?n/2,?e _=?e=?b/2+?n/2+1/2,?f _=?f=1+2*?a),1) ->
     poc(?b+?n-2*?a,-?n)/poc(?b+?n,-?n);

comment  Appendix III.10 in Slater's book ;
sghg(0,18) :- ghg(4,3,#(?a,?b,?c,?d _=?d=1+?a/2),
  #(?e _=?e=?a/2,?f _=?f=1+?a-?b,?g _=?g=1+?a-?c),-1) ->
     gamma(1+?a-?b) *gamma(1+?a-?c)/(gamma(1+?a) *gamma(1+?a-?b-?c));

comment  Appendix III.12 in Slater's book ;
sghg(0,19) :- ghg(5,4,#(?a,?b,?c,?d,?e _=?e=1+?a/2),
  #(?f _=?f=?a/2,?g _=?g=1+?a-?b,?h _=?h=1+?a-?c,?i _=?i=1+?a-?d),1) ->
  gamma(1+?a-?b) *gamma(1+?a-?c) *gamma(1+?a-?d) *gamma(1+?a-?b-?c-?d)/
  (gamma(1+?a)*gamma(1+?a-?b-?c)*gamma(1+?a-?b-?d)*gamma(1+?a-?c-?d));

comment  The ?y _=?y=?x is needed to overcome a bug. It should be removed
  later. ;

ghg(?p,?q,#(?x,??a),#(?y _=?y = ?x & ~natp(1-?y),??b),?z) ::-
                                 ghg(?p-1,?q-1,#(??a),#(??b),?z);
ghg(?p,1,#(?x,??a),#(?y _=?y = ?x & ~natp(1-?y)),?z)
     :- ghg(?p-1,0,#(??a),#(),?z);
ghg(1,?q,#(?x),#(?y _=?y = ?x & ~natp(1-?y),??b),?z)
     :- ghg(0,?q-1,#(),#(??b),?z);
ghg(1,1,#(?x),#(?y _=?y = ?x & ~natp(1-?y)),?z)      :- e^?z;

ghg(1,0,#(?a),?b,?z )         :-  (1-?z)^(-?a);
ghg(0,0,?a,?b,?z)             :-  e^?z;
%Ghg(?p,?q,#(0,??a),#(??b) _=~In(?1 _=Natp(1-?1),{??b},2),?z) :-  1;
ghg(?p,?q,#(??t),#(??b),0)    :-  1;

comment  If one of the bottom parameters is zero or a negative integer
         the hypergeometric functions may be singular, so the presence
         of a functions of this type causes a warning message to
         be printed. ;
comment Note In seems to have an off by one level spec., so this may
   need changing in future. ;

comment W: Sum[Smp] is redefined to be Inf.
    The identities may not be correct if one of the bottom parameters
    is a negative integer, even though the function may be well-behaved.
    The convergence of hypergeometric series should be checked using the
    file XCvgt before the identities here are used. ;


% ------------------------------ gauss1 --------------------------------
% Generalized Hypergeometric functions - transformations on pFqs.
% Keywords: Hypergeometric, Ghg, Transformations, reversal of series,
% Saalschutz.

% Author: Kevin McIsaac, Univ. of Western Australia, Jul 85.


% Some of this code references sum. This causes a problem in REDUCE.

gamma({??a}) ::- ap(times,map(gamma,{??a}));

%_Gamma(Init) ::- Loadonce(XGammaV);
%_Poc(Init)   ::- Loadonce(XPocV);

% SRev reverses finite Hypergeometric series.

sghg(6,1) :- srev ::-
  ghg(?p,?q,#(?m _=natp(1-?m),??a),#(??b),?z) -->
   ap(times,map(poc(?1,-?m),{??a}))/ap(times,map(poc(?1,-?m),{??b}))*
       (-?z)^(-?m)
   *ghg(?q+1,?p-1,ap(#,cat({?m},map(1-?1+?m,{??b}))),
                  ap(#,map(1-?1+?m,{??a})),
                  (-1)^(-1 + ?p + ?q)/?z);

% If there is more than one -ve integer in the numerator the smallest
% should be used.  In the current implementation the largest is used
% because of the natural ordering of Comm functions.

% The followong are commented out since in leads to an infinite recursion
%
%comment :SSaal
%        Saalschutzs theorem in non-terminating form;
%

sghg(6,2) :- ssaal:-
    ghg(3,2,#(?e,?f,?g),#(?b,?c _=(?e+?f+?g+1=?b+?c)),1) ->
        gamma({?e,?f,?g,?e+?b-1,?f+?b-1,?g+?b-1})
           /gamma({?c-?e,?c-?f,?c-?g})-
        gamma({?b,1+?g-?c,1+?f-?c,1+?e-?c,?c-1})
           /gamma({1-?c,1+?b-?c,?e,?f,?g})
        *ghg(3,2,#(1+?e-?c,1+?f-?c,1+?g-?c),#(2-?c,1+?b-?c),1);

comment : SDixon
        Generalization of Dixons theorem, Slater p52 (2.3.3.7);
sghg(6,3) :- sdixon :-
   ghg(3,2,#(?a,?b,?c),#(?e,?f),1) ->
        gamma({?e,?f,?e+?f-?a-?b-?c})
           /gamma({?a,?e+?f-?a-?c,?e+?f-?a-?b})*
        ghg(3,2,#(?e-?a,?f-?a,?e+?f-?a-?b-?c),
                #(?e+?f-?a-?c,?e+?f-?a-?b),1);

comment : SGhg[6,4]
        Three term relations, Slater p 115 (4.3.4);

sghg(6,4) :-
   ghg(3,2,#(?a,?b,?c),#(?d,?e),1) ->
   gamma({1-?a,?d,?e,?c-?b})/gamma({?e-?b,?d-?b,1+?b-?a,?c})
   *ghg(3,2,#(?b,1+?b-?d,1+?b-?e),#(1+?b-?c,1+?b-?a),1) +
   gamma({1-?a,?d,?e,?b-?c})/gamma({?e-?c,?d-?c,1+?c-?a,?b})
   *ghg(3,2,#(?c,1+?c-?e,1+?c-?d),#(1+?c-?b,1+?c-?a),1);

comment : SGhg[6,5]
     transforms a nearly-poised 3F2(-1) to a 4F3(1). Page 33 of Bailey;

sghg(6,5) :- ghg(3,2,#(?a,?b,?c),#(?d,?e _=?e+?c=?d+?b),-1) -->
   ap(gamma({?k-?b,?k-?c})/gamma({?k,?k-?b-?c})
      *ghg(4,3,#(?b,?c,?k/2-?a/2,?k/2+1/2-?a/2),
               #(?k-?a,?k/2,?k/2+1/2),1),
      {?b+?d});

%comment  SGhg[6,6][?n]
%       writes Ghg[p,q,#[a1,..,ap],#[b1,..,bq],z] in terms of
%       Ghg[p+1,q+1,#[1,a1+n,..,ap+n],#[n+1,b1+n,..,bq+n],z] for
%       n positive or negative. ;
%SGhg(6,6,(?n _=Natp(1+?n)) :- Ghg(?p,?q,#(??a),#(??b),?z) -->
%   Ap(Sum,{Ap(times,Map(Poc(?1,%r),{??a})) *?z^%r/
%         (Ap(times,Map(Poc(?1,%r),{??b})) *Gamma(%r+1)),
%         {%r,0,?n-1}}) +
%   Ap(times,Map(Poc(?1,?n),{??a})) *?z^?n /
%  (Ap(times,Map(Poc(?1,?n),{??b})) *Gamma(1+?n))
%   *Ghg(?p+1,?q+1,Ap(#,Cat({??a}+?n,{1})),
%     ap(#,cat({??b}+?n,{1+?n})),?z);
%
%SGhg(6,6,(?n _=Natp(-?n)) :- Ghg(?p,?q,#(??a),#(??b),?z) -->
%  -Ap(Sum,{Ap(times,Map(Gamma(?1+%r)/Gamma(?1),{??a})) *?z^%r/
%         (Ap(times,Map(Poc(?1,%r),{??b})) *Gamma(%r+1)),
%         {%r,?n,-1}}) +
%   Ap(times,Map(Gamma(?1+?n)/Gamma(?1),{??a})) *?z^?n/
%  (Ap(times,Map(Poc(?1,?n),{??b})) *Gamma(1+?n))
%   *Ghg(?p+1,?q+1,Ap(#,Cat({??a}+?n,{1})),
%                   ap(#,cat({??b}+?n,{1+?n})),?z);

sghg(6,7) :- ghg(6,5,#(?a,1+?a/2,?c,?d,?e,?f),
                    #(?a/2,1+?a-?c,1+?a-?d,1+?a-?e,1+?a-?f),-1) ->
  gamma(1+?a-?e) *gamma(1+?a-?f)/(gamma(1+?a) *gamma(1+?a-?e-?f))
  *ghg(3,2,#(1+?a-?c-?d,?e,?f),#(1+?a-?c,1+?a-?d),1);

sghg(6,8) :- ghg(6,5,#(?a,?b _=?b=1+?a/2,?c,?d,?e,?n _=natp(1-?n)),
                    #(?f _=?f=?a/2,?g _=?g=1+?a-?c,?h _=?h=1+?a-?d,
                    ?i _=?i=1+?a-?e,?j _=?j=1+?a-?n),-1) ->
  gamma(1+?a-?e) *gamma(1+?a-?n)/(gamma(1+?a) *gamma(1+?a-?e-?n))
  *ghg(3,2,#(1+?a-?c-?d,?e,?n),#(1+?a-?c,1+?a-?d),1);

%_XGhg6(Loaded) :- 1;


comment Special Elementary Cases of Gausses Series;

comment Abramowitz & Stegun, 15.1;

comment Incomplete. Rest of transformations must be added.

xgauss(1,3) :- Ghg(2,1,#(1,1),#(2),?z) -> 1/?z * Ln(1-?z);

xgauss(1,4) :- ghg(2,1,#(1/2,1),#(3/2),?z) ->
                1/(2*sqrt(?z))*ln((1+sqrt(?z))/(1-sqrt(?z)));

xgauss(1,5) :- ghg(2,1,#(1/2,1),#(3/2),?z) ->
                1/sqrt(-?z) * arctan(sqrt(-?z));

xgauss(1,6) :-{ghg(2,1,#(1/2,1/2),#(3/2),?z) ->
                1/sqrt(?z) * arcsin(sqrt(?z)),
               ghg(2,1,#(1,1),#(3/2),?z) ->
                1/((1-?z)*sqrt(?z)) * arcsin(sqrt(?z))};

xgauss(1,7) :-{ghg(2,1,#(1/2,1/2),#(3/2),?z) ->
                1/sqrt(-?z) * ln(sqrt(?z)+(1-?z)),
               ghg(2,1,#(1,1),#(3/2),?z) ->
                1/((1+?z)*sqrt(-?z)) * ln(sqrt(?z)+(1-?z))};

xgauss(1,8) :- ghg(2,1,#(?a,?b),#(?b),?z) -> (1-?z)^(-?a);

xgauss(1,9) :- ghg(2,1,#(?a,?a+1/2),#(1/2),?z) ->
                1/2*((1+sqrt(z))^(-2*?a) + (1-sqrt(?z))^(-2*?a));

xgauss(1,10):- ghg(2,1,#(?a,?a+1/2),#(3/2),?z) ->
                1/(2*sqrt(?z)*(1-2*?a))*
                    ((1+sqrt(z))^(-2*?a) + (1-sqrt(?z))^(-2*?a));

comment Incomplete. Rest of transformations must be added.;



comment Hypergeometric functions. Transformations of the argument; ;
comment Abramowitiz & Stegun 15.3
comment   Linear transformations *;

sgauss(3,3):-   ghg(2,1,#(?a,?b),#(?c),?z) ->
                  (1-?z)^(?c-?b-?a)*ghg(2,1,#(?c-?a,?c-?b),#(?c),?z);

sgauss(3,4):-    ghg(2,1,#(?a,?b),#(?c),?z) ->
                   ghg(2,1,#(?a,?c-?b),#(?c),?z/(?z-1))/(1-?z)^?a;

sgauss(3,5):-  ghg(2,1,#(?a,?b),#(?c),?z) ->
                gamma(?c)*gamma(?c-?a-?b)/(gamma(?c-?a)*gamma(?c-?b))*
                ghg(2,1,#(?a,?b),#(?a+?b-?c+1),1-?z)
                +(1-?z)^(?c-?a-?b)*gamma(?c)*gamma(?a+?b-?c)/(gamma(?a)*
                gamma(?b))*ghg(2,1,#(?c-?a,?c-?b),#(?c-?a-?b+1),1-?z);

sgauss(3,6):-    ghg(2,1,#(?a,?b),#(?c),?z) ->
                   1/(-?z)^?a*gamma(?c)*gamma(?b-?a)
                    /(gamma(?b)*gamma(?c-?a))*
                   ghg(2,1,#(?a,1-?c+?a),#(1-?b+?a),1/?z)
                   +1/(-?z)^?b*gamma(?c)*gamma(?a-?b)
                     /(gamma(?a)*gamma(?c-?b))*
                   ghg(2,1,#(?b,1-?c+?b),#(1-?a+?b),1/?z);

sgauss(3,7):-    ghg(2,1,#(?a,?b),#(?c),?z) ->
                   1/(1-?z)^?a*gamma(?c)*gamma(?b-?a)
                      /(gamma(?b)*gamma(?c-?a))*
                   ghg(2,1,#(?a,?c-?b),#(?a-?b+1),1/(1-?z))
                   +1/(1-?z)^?b*gamma(?c)*gamma(?a-?b)
                        /(gamma(?a)*gamma(?c-?b))*
                   ghg(2,1,#(?b,?c-?a),#(?b-?a+1),1/(1-?z));


sgauss(3,8):-    ghg(2,1,#(?a,?b),#(?c),?z) ->
                   1/?z^?a*gamma(?c)*gamma(?c-?a-?b)/ (gamma(?c-?a)*
                   gamma(?c-?b))*ghg(2,1,#(?a,?a-?c+1),
                                         #(?a+?b-?c+1),1-1/?z)
                +(1-?z)^(?c-?a-?b)*?z^(?a-?c) *
                gamma(?c)*gamma(?a+?b-?c)/(gamma(?a)*gamma(?b)) *
                ghg(2,1,#(?c-?a,1-?a),#(?c-?a-?b+1),1-1/?z);


comment*  Quadratic transformations *;


sgauss(3,15):-     ghg(2,1,#(?a,?b),#(2*?b),?z) ->
                      (1-?z)^(-?a/2)*ghg(2,1,#(?a/2,?b-?a/2),#(?b+1),
                         ?z^2/(4*?z-4));

sgauss(3,16):-     ghg(2,1,#(?a,?b),#(2*?b),?z) ->
                 (1-?z/2)^(-?a)*ghg(2,1,#(?a/2,?a/2+1/2),
                                        #(?b+1/2),?z^2/(2-?z)^2);

sgauss(3,17):-   ghg(2,1,#(?a,?b),#(2*?b),?z) ->
                    (1/2+sqrt(1-?z)/2)^(-2*?a)
                      *ghg(2,1,#(?a,?a-?b+1/2),#(?b+1/2),
                              ((1-sqrt(1-?z))/(1+sqrt(1-?z)))^2);

sgauss(3,18):-    ghg(2,1,#(?a,?b),#(2*?b),?z) -> (1-?z)^(-?a/2)
               *ghg(2,1,#(?a,2*?b-?a),#(?b+1/2),-(1-sqrt(1-?z))^2
                    /(4*sqrt(1-?z)));

sgauss(3,19):-    ghg(2,1,#(?a,?b _=?b=?a+1/2),#(?c),?z) ->
                     (1/2+sqrt(1-?z)/2)^(-2*?a)
               *ghg(2,1,#(2*?a,2*?a-?c+1),#(?c),(1-sqrt(1-?z))
                     /(1+sqrt(1-?z)));

sgauss(3,20):- {ghg(2,1,#(?a,?b _=?b=?a+1/2),#(?c),?z) ->
                       (1-sqrt(?z))^(-2*?a)
               *ghg(2,1,#(2*?a,?c-1/2),#(2*?c-1),
                     -2*sqrt(?z)/(1-sqrt(?z))),
                  ghg(2,1,#(?a,?b _=?b=?a+1/2),#(?c),?z) ->
                       (1+sqrt(?z))^(-2*?a)
               *ghg(2,1,#(2*?a,?c-1/2),#(2*?c-1),
                     2*sqrt(?z)/(1+sqrt(?z)))};

sgauss(3,21):-    ghg(2,1,#(?a,?b _=?b=?a+1/2),#(?c),?z) -> 1/(1-?z)^?a
               *ghg(2,1,#(2*?a,2*?c-2*?a-1),#(?c),(sqrt(1-?z)-1)
                                                  /(2*sqrt(1-?z)));

sgauss(3,22):-    ghg(2,1,#(?a,?b),#(?a+?b+1/2),?z) ->
                ghg(2,1,#(2*?a,2*?b),#(?a+?b+1/2),1/2-sqrt(1-?z)/2);

sgauss(3,23):-    ghg(2,1,#(?a,?b),#(?a+?b+1/2),?z) ->
                     (1/2+sqrt(1-?z)/2)^(-2*?a)
                       *ghg(2,1,#(2*?a,?a-?b+1/2),#(?a+?b+1/2),
                            (sqrt(1-?z)-1)/(sqrt(1-?z)+1));

sgauss(3,24):-    ghg(2,1,#(?a,?b),#(?a+?b-1/2),?z) ->
                  1/sqrt(1-?z)*ghg(2,1,#(2*?a-1,2*?b-1),#(?a+?b-1/2),
                                   1/2-sqrt(1-?z)/2);

sgauss(3,25):-    ghg(2,1,#(?a,?b),#(?a+?b-1/2),?z) ->
                     (1/2+sqrt(1-?z)/2)^(1-2*?a)/sqrt(1-?z)
                      *ghg(2,1,#(2*?a-1,?a-?b+1/2),#(?a+?b-1/2),
                          (sqrt(1-?z)-1)/(sqrt(1-?z)+1));

sgauss(3,26):-    ghg(2,1,#(?a,?b),#(?a-?b+1),?z) ->
                1/(1+?z)^(2*?a)*ghg(2,1,#(?a/2,?a/2+1/2),#(?a-?b+1),
                                    4*?z/(1+?z)^2);

sgauss(3,27):- {ghg(2,1,#(?a,?b),#(?a-?b+1),?z) -> (1+sqrt(?z))^(-2*?a)
                 *ghg(2,1,#(?a,?a-?b+1/2),#(2*?a-2*?b+1),
                      4*sqrt(?z)/(1+sqrt(?z))^2),
                ghg(2,1,#(?a,?b),#(?a-?b+1),?z) -> (1-sqrt(?z))^(-2*?a)
               *ghg(2,1,#(?a,?a-?b+1/2),#(2*?a-2*?b+1),
                      -4*sqrt(?z)/(1-sqrt(?z))^2)};

sgauss(3,28):-    ghg(2,1,#(?a,?b),#(?a-?b+1),?z) ->
                1/(1-?z)^?a*ghg(2,1,#(?a/2,?a/2-?b+1/2),#(?a-?b+1),
                    -4*?z/(1-?z)^2);

sgauss(3,29):-    ghg(2,1,#(?a,?b),#((?a+?b+1)/2),?z) ->
                ghg(2,1,#(?a/2,?b/2),#((?a+?b+1)/2),-4*?z*(?z-1));

sgauss(3,30):-   ghg(2,1,#(?a,?b),#(?a/2+?b/2+1/2),?z) -> 1/(1-2*?z)^?a
                     *ghg(2,1,#(?a/2,?a/2+1/2),#(?a/2+?b/2+1/2),
                          4*?z*(?z-1)/(1-2*?z)^2);

sgauss(3,31):-    ghg(2,1,#(?a,1-?a),#(?c),?z) ->
                    (1-?z)^(?c-1)*ghg(2,1,#(?c/2-?a/2,?c/2+?a/2-1/2),
                                      #(?c),4*?z-4*?z^2);

sgauss(3,32):-    ghg(2,1,#(?a,1-?a),#(?c),?z) ->
                      (1-?z)^(?c-1)* (1-2*?z)^(?a-?c)
                        *ghg(2,1,#(?c/2-?a/2,?c/2-?a/2+1/2),#(?c),
                             4*?z*(?z-1)/(1-2*?z)^2);


% Gaussian hypergeometric functions. Orthogonal polynomials.
% Abramowitz and Stegun section 15.4.

sgauss(4,3):-   ghg(2,1,#(?n _=intp(-?n),-?n),#(1/2),?x)
                     -> chet(-?n,1-2 *?x);

sgauss(4,4):-   ghg(2,1,#(?n _=intp(-?n),1-?n),#(1),?x)
                     -> legp(-?n,1-2 *?x);

sgauss(4,5):-   ghg(2,1,#(?n _=intp(-?n),?a-?n),#(?a/2+1/2),?x) ->
                fctl(-?n)/poc(?a,-?n) *geg(-?n,?a/2,1-2 *?x);

sgauss(4,6):-   ghg(2,1,#(?n _=intp(-?n),?c),#(?a),?x) ->
                fctl(-?n)/poc(?a,-?n)*jacp(-?n,?a-1,?c-?a+?n,1-2*?x);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pattperm.red0000644000175000017500000001323011526203062023447 0ustar  giovannigiovannimodule pattperm;   % Rest of unify --- argument permutation, etc.

% Author: Kevin McIsaac.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% When sym!-assoc is off, PM does not force normal generic variables to
% take more than one argument if a multi-generic symbol is present. This
% makes the patterns much more efficient but not fully searched. Sane
% patterns do not require this.  For example
% m(a+b+c,?a+??c) will return {?a -> a, ??c -> null!-fn(b,c)} but not
% {?a -> a+b, ??c -> c} or {?a -> a+b+c, ??c -> null!-fn()}

fluid '(symm op r p i upb identity expand acontract mcontract comb);

global('(!*sym!-assoc))$

global('(!*udebug))$      %print out next information

symbolic procedure first0(u,n);
   if n>0 then car u . first0(cdr u,n-1) else nil;

symbolic procedure last0(u,n);
   if n<1 then u else last0(cdr u,n-1);

symbolic procedure list!-mgen u;
   % Count the number of top level mgen atoms.
   begin integer i;
      for each j in u do if atom j and mgenp(j) then i := i+1;
      return i
   end;

symbolic procedure initarg(u);
   begin scalar  assoc, mgen, flex, filler; integer n, lmgen;
      symm := flagp(op,'symmetric);
      n := length(p) - length(r) + 1;
      identity := ident(op);
      mgen  := mgenp(car r);
      lmgen := list!-mgen(cdr r);
      assoc := flagp(op,'assoc)
                  and not(symm and(lmgen > 0) and not !*sym!-assoc);
      flex :=  (length(r)>1) and (assoc or lmgen);
      filler:= n > 1 or (identity and length p > 0);
      %
      mcontract := mgen and filler;
      acontract := assoc and filler and not mgen;
      expand := identity and (n < 1 or flex);
      %
      i := if flex or n < 1 then
              if mgen then 0
              else 1
           else n;
      upb := if identity then length p else n + lmgen;
      if symm then comb := initcomb u
   end;

symbolic procedure nextarg u;
   if symm then s!-nextarg u else o!-nextarg u;

symbolic procedure o!-nextarg u;
   begin scalar args;
      if !*udebug then uprint(nil);
      args :=
         if (i = 1)   and (i <= upb) then u
         else if (i = 0)   and (i <= upb) then '(null!-fn).u
         else if acontract and (i <= upb)
          then mval((op . first0(u,i)) . last0(u,i))
         else if mcontract and (i <= upb)
          then ('null!-fn . first0(u,i)) . last0(u,i)
         else if expand then <>;
      i := i + 1;
      return args
   end;

symbolic procedure s!-nextarg u;
   begin scalar v, args;
      if !*udebug then uprint(nil);
           if null comb then<< i := i + 1; comb := initcomb u>>;
      args :=
      if (v := getcomb(u,comb) ) then
         if (i = 1)   and (i <= upb) then caar v . cdr v
         else if (i = 0)   and (i <= upb) then '(null!-fn).u
         else if acontract and (i <= upb) then mval((op.car(v)).cdr v)
         else if mcontract and (i <= upb) then ('null!-fn.car(v)).cdr v
         else if expand then <>
         else nil
       else if (i = 0)   and (i <= upb) then '(null!-fn).u
       else if expand then <>;
      return args
   end;

symbolic procedure getcomb(u,v);
   begin scalar group;
      comb :=  nextcomb(v,i);
      group := car comb;
      comb := cdr comb;
      return if group then group . setdiff(u,group) else nil
   end$

symbolic procedure uprint(u);
   <>;
     if mcontract then <>;
     if acontract then <>;
        prin2(" upb = ");prin2(upb); prin2(" i = ");prin2(i);
     if symm then <>;
     terpri()>>$


symbolic procedure initcomb(u); u.nil$

symbolic procedure nextcomb(env,n);
   % Env is of the form args . env, where args is a list of arguments.
   % Value is list of all combinations of n elements from the list u.
   begin scalar args, nenv, v; integer i;
      args := car env; nenv := cdr env;
      return
         if n=0 then nil.nil
         else if (i:=length(args) - n)<0 then list(nil)
         else if i = 0 then args.nil
         else if nenv then <>
         else <>
   end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pmrules.red0000644000175000017500000000624611526203062023313 0ustar  giovannigiovannimodule pmrules;   % Basic rules for PM pattern matcher.

% Author:  Kevin McIsaac.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


algebraic;

% Define logical operators;
% These routines are used so often they should be coded in LISP
% for efficiency.

operator ~; deflist('((!~ !~)),'unary); %precedence ~,not;

infix &; deflist('((!& !&)),'unary); precedence &, and;

remprop('!&,'rtypefn);  % Interference with FIDE package.

infix |; deflist('((!| !|)),'unary); precedence |, or;

flag('( & |), 'nary);

flag('( & |),'symmetric);

&(t) :- t; % We must have this else the fourth rule => &(t) -> &() -> 0

&(0) :- 0;

&(0, ??b) :- 0;

&(t, ??b) ::- &(??b);

&(?a,?a,??b) ::- &(?a,??b);

&(?a,~?a,??b) ::- 0;

|(t) :- t;
|(0) :- 0;
|(t,??a) :- t;
|(0,??a) ::- |(??a);
|(?a,?a,??b) ::- |(?a,??b);
|(?a,~?a) :- t;
|(?a,~?a,??b) ::- |(??b);

~(t) :- 0;
~(0) :- t;


% Define SMP predicates in terms of their REDUCE equivalents.


symbolic procedure simpbool u;
  begin scalar x;
  x := get(car u,'boolfn) or car u;
  u := for each j in cdr u collect reval j;
  u := apply (x, u);
  return (if u then !*k2f T else 0) ./ 1
 end;

flag('(numberp fixp), 'full);

put('numberp,'simpfn,'simpbool);
put('fixp,'simpfn,'simpbool);



operator numbp, posp, intp, natp, oddp, evnp, complexp, listp;

numbp(?n _=numberp(?n)) :- t;
numbp(?n/?m _=(numberp(?n)&numberp(?m))) :- t;

posp(?n _=(numbp(?n)&?n > 0)) :- t;
posp(?n _=(numbp(?n)&~(?n > 0))) :- 0;

intp(?n _=(numbp(?n)&fixp(?n))) :- t;
intp(?n _=(numbp(?n)&~ fixp(?n))) :- 0;

natp(?i _=(numbp(?i)& intp(?i)&?i>0)) :-t;
natp(?i _=(numbp(?i)&~(intp(?i)&?i>0))) :- 0;

oddp(?x _=(numbp(?x)&intp((?x+1)/2))) :- t;
oddp(?x _=(numbp(?x)&~ intp((?x+1)/2))) :- 0;

evnp(?x _=(numbp(?x)&intp(?x/2))) :- t;
evnp(?x _=(numbp(?x)&~ intp(?x/2))) :- 0;

complexp(i) :- t;
complexp(??b*i) :- t;
complexp(??a + i) :- t;
complexp(??a + ??b*i) :- t;

listp({??x}) :- t;
listp(?x) :- 'nil;

%Polyp
%Primep
%Projp
%Ratp
%Contp
%Fullp
%Symbp

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.rlg0000644000175000017500000001773011527635055022266 0ustar  giovannigiovanniFri Feb 18 21:27:59 2011 run on win32

*** ~ already defined as operator 
% Tests of PM.

% TESTS OF BASIC CONSTRUCTS.

operator f, h$



% A "literal" template.

m(f(a),f(a));


t


% Not literally equal.

m(f(a),f(b));



%Nested operators.

m(f(a,h(b)),f(a,h(b)));


t


% A "generic" template.

m(f(a,b),f(a,?a));


{?a->b}

m(f(a,b),f(?a,?b));


{?a->a,?b->b}


% ??a takes "rest" of arguments.

m(f(a,b),f(??a));


{??a->[a,b]}


% But ?a does not.

m(f(a,b),f(?a));



% Conditional matches.

m(f(a,b),f(?a,?b _=(?a=?b)));



m(f(a,a),f(?a,?b _=(?a=?b)));


{?a->a,?b->a}


% "plus" is symmetric.

m(a+b+c,c+?a+?b);


{?a->a,?b->b}


%It is also associative.

m(a+b+c,c+?a);


{?a->a + b}


% Note the effect of using multi-generic symbol is different.

m(a+b+c,c+??c);


{??c->[a,b]}


%Flag h as associative.

flag('(h),'assoc);



m(h(a,b,d,e),h(?a,d,?b));


{?a->h(a,b),?b->e}


% Substitution tests.

s(f(a,b),f(a,?b)->?b^2);


 2
b


s(a+b,a+b->a*b);


a*b


% "associativity" is used to group a+b+c in to (a+b) + c.

s(a+b+c,a+b->a*b);


a*b + c


% Only substitute top at top level.

s(a+b+f(a+b),a+b->a*b,inf,0);


f(a + b) + a*b



% SIMPLE OPERATOR DEFINITIONS.

% Numerical factorial.

operator nfac$



s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},1);


3*nfac(2)


s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);


6*nfac(1)


si(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});


6


% General factorial.

operator gamma,fac;



fac(?x _=Natp(?x)) ::- ?x*fac(?x-1);


hold(?x*fac(?x - 1))


fac(0)  :- 1;


1


fac(?x) :- Gamma(?x+1);


gamma(?x + 1)


fac(3);


6


fac(3/2);


       5
gamma(---)
       2


% Legendre polynomials in ?x of order ?n, ?n a natural number.

operator legp;



legp(?x,0) :- 1;


1


legp(?x,1) :- ?x;


?x


legp(?x,?n _=natp(?n))
   ::- ((2*?n-1)*?x*legp(?x,?n-1)-(?n-1)*legp(?x,?n-2))/?n;


      (2*?n - 1)*?x*legp(?x,?n - 1) - (?n - 1)*legp(?x,?n - 2)
hold(----------------------------------------------------------)
                                 ?n


legp(z,5);


        4       2
 z*(63*z  - 70*z  + 15)
------------------------
           8


legp(a+b,3);


    3       2           2            3
 5*a  + 15*a *b + 15*a*b  - 3*a + 5*b  - 3*b
---------------------------------------------
                      2


legp(x,y);


legp(x,y)



% TESTS OF EXTENSIONS TO BASIC PATTERN MATCHER.

comment *: MSet[?exprn,?val] or ?exprn ::: ?val
	assigns the value ?val to the projection ?exprn in such a way
	as to store explicitly each form of ?exprn requested. *;

 
Nosimp('mset,(t t));



Newtok '((!: !: !: !-) Mset);



infix :::-;



precedence Mset,RSetd;



?exprn :::- ?val ::- (?exprn ::- (?exprn :- ?val ));


hold(?exprn::-(?exprn:-?val))


scs := sin(?x)^2 + Cos(?x)^2 -> 1;


              2          2
scs := cos(?x)  + sin(?x) ->1


% The following pattern substitutes the rule sin^2 + cos^2 into a sum of
% such terms.  For 2n terms (ie n sin and n cos) the pattern has a worst
% case complexity of O(n^3).

operator trig,u;



trig(?i) :::- Ap(+, Ar(?i,sin(u(?1))^2+Cos(u(?1))^2));


                                       2             2
hold(trig(?i):-ap(plus,ar(?i,sin(u(?1))  + cos(u(?1)) )))


if si(trig 1,scs) = 1 then write("Pm ok") else Write("PM failed");


Pm ok


if si(trig 10,scs) = 10 then write("Pm ok") else Write("PM failed");


Pm ok


% The next one takes about 70 seconds on an HP 9000/350, calling UNIFY
% 1927 times.

% if si(trig 50,scs) = 50 then write("Pm ok") else Write("PM failed");

% Hypergeometric Function simplification.

newtok '((!#) !#);


*** # redefined 


flag('(#), 'symmetric);



operator #,@,ghg;



xx := ghg(4,3,@(a,b,c,d),@(d,1+a-b,1+a-c),1);


xx := ghg(4,3,@(a,b,c,d),@(d,a - b + 1,a - c + 1),1)


S(xx,sghg(3));


*** sghg declared operator 

ghg(4,3,@(a,b,c,d),@(d,a - b + 1,a - c + 1),1)


s(ws,sghg(2));


ghg(4,3,@(a,b,c,d),@(d,a - b + 1,a - c + 1),1)


yy := ghg(3,2,@(a-1,b,c/2),@((a+b)/2,c),1);


                         c      a + b
yy := ghg(3,2,@(a - 1,b,---),@(-------,c),1)
                         2        2


S(yy,sghg(1));


                   c      a + b
ghg(3,2,@(a - 1,b,---),@(-------,c),1)
                   2        2


yy := ghg(3,2,@(a-1,b,c/2),@(a/2+b/2,c),1);


                         c      a + b
yy := ghg(3,2,@(a - 1,b,---),@(-------,c),1)
                         2        2


S(yy,sghg(1));


                   c      a + b
ghg(3,2,@(a - 1,b,---),@(-------,c),1)
                   2        2


% Some Ghg theorems.

flag('(@), 'symmetric);



% Watson's Theorem.

SGhg(1) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=(1+?a+?b)/2,?e _=?e=2*?c),1) -> 
     Gamma(1/2)*Gamma(?c+1/2)*Gamma((1+?a+?b)/2)*Gamma((1-?a-?b)/2+?c)/
     (Gamma((1+?a)/2)*Gamma((1+?b)/2)*Gamma((1-?a)/2+?c)
	*Gamma((1-?b)/2+?c));


                                           1 + ?a + ?b
sghg(1) := ghg(3,2,@(?a,?b,?c),@(?d _= ?d=-------------,?e _= ?e=2*?c),1)->(
                                                2

                      - ?a - ?b + 2*?c + 1          2*?c + 1
              gamma(-----------------------)*gamma(----------)
                               2                       2

                      ?a + ?b + 1          1             - ?a + 2*?c + 1
              *gamma(-------------)*gamma(---))/(gamma(------------------)
                           2               2                   2

                       - ?b + 2*?c + 1          ?a + 1          ?b + 1
              *gamma(------------------)*gamma(--------)*gamma(--------))
                             2                    2               2


% Dixon's theorem.

SGhg(2) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=1+?a-?b,?e _=?e=1+?a-?c),1) -> 
     Gamma(1+?a/2)*Gamma(1+?a-?b)*Gamma(1+?a-?c)*Gamma(1+?a/2-?b-?c)/
     (Gamma(1+?a)*Gamma(1+?a/2-?b)*Gamma(1+?a/2-?c)*Gamma(1+?a-?b-?c));


sghg(2) := ghg(3,2,@(?a,?b,?c),@(?d _= ?d=1 + ?a - ?b,?e _= ?e=1 + ?a - ?c),1)->

                                                         ?a - 2*?b - 2*?c + 2
           (gamma(?a - ?b + 1)*gamma(?a - ?c + 1)*gamma(----------------------)
                                                                  2

                    ?a + 2
            *gamma(--------))/(gamma(?a - ?b - ?c + 1)*gamma(?a + 1)
                      2

                      ?a - 2*?b + 2          ?a - 2*?c + 2
              *gamma(---------------)*gamma(---------------))
                            2                      2


SGhg(3) := Ghg(?p,?q,@(?a,??b),@(?a,??c),?z)
		   -> Ghg(?p-1,?q-1,@(??b),@(??c),?z);


sghg(3) := 

ghg(?p,?q,@(??b,?a),@(??c,?a),?z)->ghg(?p - 1,?q - 1,@(??b),@(??c),?z)


SGhg(9) := Ghg(1,0,@(?a),?b,?z )       ->  (1-?z)^(-?a);


                                        1
sghg(9) := ghg(1,0,@(?a),?b,?z)->---------------
                                             ?a
                                  ( - ?z + 1)

SGhg(10) := Ghg(0,0,?a,?b,?z)          ->  E^?z;


                                ?z
sghg(10) := ghg(0,0,?a,?b,?z)->e

SGhg(11) := Ghg(?p,?q,@(??t),@(??b),0) ->  1;


sghg(11) := ghg(?p,?q,@(??t),@(??b),0)->1


% If one of the bottom parameters is zero or a negative integer the
% hypergeometric functions may be singular, so the presence of a
% functions of this type causes a warning message to be printed.

% Note it seems to have an off by one level spec., so this may need
% changing in future.
%
% Reference: AS 15.1; Slater, Generalized Hypergeometric Functions,
%     Cambridge University Press,1966.

s(Ghg(3,2,@(a,b,c),@(b,c),z),SGhg(3));


ghg(2,1,@(a,b),@(b),z)


si(Ghg(3,2,@(a,b,c),@(b,c),z),{SGhg(3),Sghg(9)});


      1
-------------
           a
 ( - z + 1)


S(Ghg(3,2,@(a-1,b,c),@(a-b,a-c),1),sghg 2);


                                  a - 2*b - 2*c + 1          a + 1
 gamma(a - b)*gamma(a - c)*gamma(-------------------)*gamma(-------)
                                          2                    2
---------------------------------------------------------------------
                         a - 2*b + 1          a - 2*c + 1
 gamma(a - b - c)*gamma(-------------)*gamma(-------------)*gamma(a)
                              2                    2


end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 14 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.red0000644000175000017500000001500311526203062022227 0ustar  giovannigiovannimodule pm;   % The PM Pattern Matcher.

% Author: Kevin McIsaac.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


create!-package('(pm pmpatch pattdefn pmintrfc pattperm unify pmrules),
                '(contrib pm));

remflag('(i),'reserved);  % This package uses I as a global index!!

remprop('gamma,'simpfn);  % These routines clash with SPECFN.


Comment This is a fairly basic set of definitions for Ap, Map and Ar.
        It needs some work. The routine Ar is particularly bad;

% Pattern directed application.

symbolic operator ap;

symbolic procedure ap(f,v);
   if car v neq 'list then typerr(v,'ap)
   else if not genexp f then
      if atom f then f . cdr v
      else append(f,cdr v)
   else
   begin scalar nv;
      nv := idsort union(findnewvars f,nil);
      v  := cdr v;
      f := sublis(npair(nv, v), f);
      if length nv < length v then f := append(f,pnth(v,length nv +1));
      return f
    end;

symbolic procedure npair(u, v);
   % Forms list of pairs from unequal length list. Terminates at end of
   % shortest list.
   if u and v then (car u . car v) . npair(cdr u, cdr v) else nil;

%Pattern directed MAP

put('map,'psopfn,'map0);

symbolic procedure map0 arg;
   if length arg < 2 then nil
   else map1(car arg,cadr arg,if length arg >= 3 then caddr arg else 1);

symbolic procedure map1(fn,v,dep);
   if dep>0 then car v . for each j in cdr v collect map1(fn,j,dep-1)
   else ap(fn,if atom v or car v neq 'list then list('list, v) else v);

put('ar, 'psopfn, 'ar0);

% ARange of ARray statement.

symbolic procedure ar0 arg;
   if length arg <= 1 then nil
    else ar1(car arg, if length arg >= 2 then cadr arg else 'list);

symbolic procedure ar1(arg,fn);
if fixp arg then ar4(list(list(1,arg,1)),fn)
else if atom arg or car arg neq 'list then typerr(arg,'ar)
else ar4(for each j in cdr arg collect aarg(j), fn);

symbolic procedure aarg(arg);
   revlis(
   if fixp arg or genp(arg) then list(1, arg, 1)
   else if atom arg  or car arg neq 'list then typerr(arg,'ar)
   else begin scalar l;
      arg := cdr arg;
      l := length arg;
      return if l = 1 then list(1, car arg, 1)
              else if l = 2 then list(car arg, cadr arg, 1)
              else if l = 3 then list(car arg, cadr arg, caddr arg)
              else typerr(arg,"Ar")
     end);

symbolic procedure ar4(lst,fn);
   begin scalar s, u, v, w;
      u := caar lst; v := cadar lst; w := caddar lst; lst := cdr lst;
      while u <= v do
      << s := append(s,list u);
         u := u + w>>;
         return if length(lst)=0 then
            if fn eq 'list then 'list . s
            else  map1(fn, 'list . s, 1)
         else 'list . for each j in cdr map1(list(lst, fn),'list . s, 1)
                         collect ar4(car j, cdr j);
   end;

put('cat, 'psopfn, 'catx);

symbolic procedure catx u;
   % Concatenate two lists.
   (if not eqcar(x,'list) then typerr(car u,"list")
     else if not eqcar(y,'list) then typerr(cadr u,"list")
     else 'list . append(cdr x,cdr y))
   where x=reval car u, y=reval cadr u;


%Relational operators.

symbolic procedure simpeq(arg);
   begin scalar x;
      if length arg < 2 then typerr('equal . arg,"relation");
      arg := reval('difference . arg);
      arg := if numberp arg then reval(arg = 0)
              else <>;
      return mksq(arg,1)
   end;

symbolic procedure simpgt(arg);
   begin scalar x;
      if length arg < 2 then typerr('greaterp . arg,"relation");
      arg := reval('difference . arg);
      arg := if numberp arg then reval(arg > 0)
              else <>;
      return mksq(arg,1)
   end;

symbolic procedure simpge(arg);
   begin scalar x;
      if length arg < 2 then typerr('geq . arg,"relation");
      arg := reval('difference . arg);
      arg := if numberp arg then reval(arg >= 0)
              else <>;
      return mksq(arg,1)
   end;

symbolic procedure simplt(arg);
   simpgt(list(cadr arg,car arg));

symbolic procedure simple(arg);
   simpge(list(cadr arg,car arg));

put('equal, 'simpfn, 'simpeq);

put('greaterp, 'simpfn, 'simpgt);

put('geq, 'simpfn, 'simpge);

put('lessp, 'simpfn, 'simplt);

put('leq, 'simpfn, 'simple);


% Form function for !?.

symbolic procedure formgen(u,vars,mode);
   begin scalar x;
     u := cadr u;
     if atom u
       then if u eq '!?
             then <>
             else <>
     else if car u neq '!?
      then <>
     else if car u eq '!? and atom cadr u
      then <>
     else
     <>;
      return list('progn,'put . x,form1(u,vars,mode))
   end;

put('!?,'formfn,'formgen)$

endmodule;

end;



endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.hlp0000644000175000017500000001223211526203062022241 0ustar  giovannigiovanni\chapter{PM: A REDUCE pattern matcher}
\label{PM}
\typeout{{PM: A REDUCE pattern matcher}}

{\footnotesize
\begin{center}
Kevin McIsaac \\
The University of Western Australia \\
Australia\\[0.05in]
e--mail: kevin@wri.com
\end{center}
}
\ttindex{PM}

PM is a general pattern matcher similar in style to those found in systems
such as SMP and Mathematica.

A template is any expression composed of literal elements ({\em e.g.\ }{\tt
5}, {\tt a} or {\tt a+1}) and specially denoted pattern variables
({\em e.g.\ }{\tt ?a} or {\tt ??b}).  Atoms
beginning with `?' are called generic variables and match any expression.
Atoms beginning with `??' are called multi-generic variables and match any
expression or any sequence of expressions including the null or empty
sequence.  A sequence is an expression of the form `[a1, a2,...]'.  When
placed in a function argument list the brackets are removed, {\em
i.e.\ }f([a,1]) $\rightarrow$ f(a,1) and f(a,[1,2],b) $\rightarrow$ f(a,1,2,b).

A template is said to match an  expression  if the template is literally
equal to the expression or if by replacing any of the generic or
multi-generic symbols occurring in the template, the template can be made
to be literally equal to the expression.  These replacements are called the
bindings for the generic variables.  A replacement is an expression of the
form {\tt exp1 -> exp2}, which means exp1 is replaced by exp2, or
{\tt exp1 --> exp2}, which is the same except exp2 is not simplified
until after the 
substitution for exp1 is made.  If the expression has any of the
properties; associativity, commutativity, or an identity element, they are
used to determine if the expressions match.  If an attempt to match the
template to the expression fails the matcher backtracks, unbinding generic
variables, until it reached a place were it can make a different choice.

The matcher also supports semantic matching.  Briefly, if a subtemplate
does not match the corresponding subexpression because they have different
structures then the two are equated and the matcher continues matching the
rest of the expression until all the generic variables in the subexpression
are bound.  The equality is then checked.  This is controlled by the switch
\ttindex{SEMANTIC}{\tt semantic}.  By default it is on.

\section{The Match Function}

{\tt M(exp,template)}\ttindex{M}

The template is matched against the expression.  If the template is
literally equal to the expression {\tt T} is returned.  If the
template is literally equal to the expression after replacing the
generic variables by their bindings then the set of bindings is
returned as a set of replacements.  Otherwise {\tt NIL} is returned.

\begin{verbatim}
OPERATOR F;

M(F(A),F(A));

T

M(F(A,B),F(A,?A));

{?A->B}

M(F(A,B),F(??A));

{??A->[A,B]}

m(a+b+c,c+?a+?b);

{?a->a,?b->b}

m(a+b+c,b+?a);

{?a->a + c}
\end{verbatim}

This example shows the effects of semantic matching, using the
associativity and commutativity of {\tt +}.

\section {Qualified Matching}

A template may be qualified by the use of the conditional operator
{\tt \_=',}\ttindex{\_=} standing for {\bf such that}.  When a
such-that condition is encountered in a template it is held until all
generic variables appearing in logical-exp are bound.  On the binding
of the last generic variable logical-exp is simplified and if the
result is not {\tt T} the condition fails and the pattern matcher
backtracks.  When the template has been fully parsed any remaining
held such-that conditions are evaluated and compared to {\tt T}.

\begin{verbatim}
load_package pm;

operator f;

if (m(f(a,b),f(?a,?b_=(?a=?b)))) then write "yes" else write"no";

no

m(f(a,a),f(?a,?b_=(?a=?b)));

{?B->A,?A->A}
\end{verbatim}
{\typeout {This is not true}}

\section{Substituting for replacements}

The operator {\tt S}\ttindex{S} substitutes the replacements in an
expression.

{\tt S(exp,{temp1->sub1,temp2->sub2,...},rept, depth);}

will do the substitutions for a maximum of {\tt rept} and to a depth of
{\tt depth}, using a breadth-first search and replace.  {\tt rept} and
{\tt depth} may be omitted when they default to 1 and infinity.

{\tt SI(exp,{temp1->sub1,temp2->sub2,...}, depth)}\ttindex{SI}

will substitute  infinitely many times until  expression  stops
changing.

{\tt SD(exp,{temp1->sub1,temp2->sub2,...},rept, depth)}\ttindex{SD}

is a depth-first version of {\tt S}.


\begin{verbatim}
s(f(a,b),f(a,?b)->?b^2);

 2
b

s(a+b,a+b->a*b);

a*b


operator nfac;

s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});

3*nfac(2)

s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);

6*nfac(1)

si(nfac(4),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});

24

s(a+b+f(a+b),a+b->a*b,inf,0);

f(a + b) + a*b

\end{verbatim}


\section{Programming with Patterns}

There are also facilities to use this pattern-matcher as a programming
language.  The operator {\tt :-}\ttindex{:-} can be used  to declare
that while simplifying all matches of a template should be replaced by
some expression.  The operator {\tt ::-} is the same except that the
left hand side is not simplified.

\begin{verbatim}
operator fac, gamma;

fac(?x_=Natp(?x)) ::- ?x*fac(?x-1);

HOLD(FAC(?X-1)*?X)

fac(0)  :- 1;

1

fac(?x) :- Gamma(?x+1);

GAMMA(?X + 1)

fac(3);

6

fac(3/2);

GAMMA(5/2)
\end{verbatim}

mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/unify.red0000644000175000017500000000674511526203062022762 0ustar  giovannigiovannimodule unify;   % Main part of unify code.

% Author: Kevin McIsaac.
% Changes by Rainer M. Schoepf 1991.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% The switch semantic, default on, controls use of semantic matching.

fluid '(!*semantic substitution);

switch semantic;

!*semantic := t;

symbolic procedure amatch(r,p,suchl,pmstack);
   if atom r then unify(nil,mval list r,list p,suchl, pmstack)
    else if not(atom p or (car r neq car p)) then
            unify(car r,mval  cdr r, cdr p, suchl, pmstack)
    else if suchp r then amatch(cadr r, p, caddr r . suchl, pmstack)
    else if !*semantic then resume(list('equal,r,p).suchl, pmstack);

symbolic procedure suspend(op,r,p,suchl, pmstack);
   % Process the interrupting operator.
   amatch(car r, car p,suchl,list(op.cdr r,op.cdr p ). pmstack);

symbolic procedure resume(suchl,pmstack);
   % Resume interrupted operator.
   if pmstack then amatch(caar pmstack,cadar pmstack,suchl,cdr pmstack)
    else if chk(suchl) eq t then bsubs substitution;

symbolic procedure unify(op,r,p,suchl,pmstack);
   if null r and null p then resume(suchl,pmstack) % Bottom of arg list.
    else if null(r) then
        <>
    else if null(p) and not (ident(op ) or mgenp(car r)) then
%       <>
        nil
    else
      begin scalar mmatch, st, arg, symm, comb, identity,
             mcontract, acontract, expand; integer i, upb;
         if pm!:free(car r) then  suchl := genp(car r).suchl;
         initarg(p);
         while (not(mmatch) and (arg := nextarg(p))) do
            begin
               if not atom(car r)
                 then mmatch := suspend(op,r,arg,suchl, pmstack)
               else if (pm!:free(car r)) then
               begin
                  bind(car r, car arg);
                     if (st := chk suchl) then
                        mmatch := unify(op,mval cdr r,cdr arg,st,
                                        pmstack);
                  unbind(car r);
               end
               else if meq(car r, car arg)
                then mmatch := unify(op,mval cdr r,cdr arg,suchl,
                                     pmstack)
            end;
         return mmatch
       end;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.tst0000644000175000017500000000772511526203062022303 0ustar  giovannigiovanni% Tests of PM.

% TESTS OF BASIC CONSTRUCTS.

operator f, h$

% A "literal" template.

m(f(a),f(a));

% Not literally equal.

m(f(a),f(b));

%Nested operators.

m(f(a,h(b)),f(a,h(b)));

% A "generic" template.

m(f(a,b),f(a,?a));
m(f(a,b),f(?a,?b));

% ??a takes "rest" of arguments.

m(f(a,b),f(??a));

% But ?a does not.

m(f(a,b),f(?a));

% Conditional matches.

m(f(a,b),f(?a,?b _=(?a=?b)));

m(f(a,a),f(?a,?b _=(?a=?b)));

% "plus" is symmetric.

m(a+b+c,c+?a+?b);

%It is also associative.

m(a+b+c,c+?a);

% Note the effect of using multi-generic symbol is different.

m(a+b+c,c+??c);

%Flag h as associative.

flag('(h),'assoc);

m(h(a,b,d,e),h(?a,d,?b));

% Substitution tests.

s(f(a,b),f(a,?b)->?b^2);

s(a+b,a+b->a*b);

% "associativity" is used to group a+b+c in to (a+b) + c.

s(a+b+c,a+b->a*b);

% Only substitute top at top level.

s(a+b+f(a+b),a+b->a*b,inf,0);


% SIMPLE OPERATOR DEFINITIONS.

% Numerical factorial.

operator nfac$

s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},1);

s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);

si(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});

% General factorial.

operator gamma,fac;

fac(?x _=Natp(?x)) ::- ?x*fac(?x-1);

fac(0)  :- 1;

fac(?x) :- Gamma(?x+1);

fac(3);

fac(3/2);

% Legendre polynomials in ?x of order ?n, ?n a natural number.

operator legp;

legp(?x,0) :- 1;

legp(?x,1) :- ?x;

legp(?x,?n _=natp(?n))
   ::- ((2*?n-1)*?x*legp(?x,?n-1)-(?n-1)*legp(?x,?n-2))/?n;

legp(z,5);

legp(a+b,3);

legp(x,y);


% TESTS OF EXTENSIONS TO BASIC PATTERN MATCHER.

comment *: MSet[?exprn,?val] or ?exprn ::: ?val
	assigns the value ?val to the projection ?exprn in such a way
	as to store explicitly each form of ?exprn requested. *;
 
Nosimp('mset,(t t));

Newtok '((!: !: !: !-) Mset);

infix :::-;

precedence Mset,RSetd;

?exprn :::- ?val ::- (?exprn ::- (?exprn :- ?val ));

scs := sin(?x)^2 + Cos(?x)^2 -> 1;

% The following pattern substitutes the rule sin^2 + cos^2 into a sum of
% such terms.  For 2n terms (ie n sin and n cos) the pattern has a worst
% case complexity of O(n^3).

operator trig,u;

trig(?i) :::- Ap(+, Ar(?i,sin(u(?1))^2+Cos(u(?1))^2));

if si(trig 1,scs) = 1 then write("Pm ok") else Write("PM failed");

if si(trig 10,scs) = 10 then write("Pm ok") else Write("PM failed");

% The next one takes about 70 seconds on an HP 9000/350, calling UNIFY
% 1927 times.

% if si(trig 50,scs) = 50 then write("Pm ok") else Write("PM failed");

% Hypergeometric Function simplification.

newtok '((!#) !#);

flag('(#), 'symmetric);

operator #,@,ghg;

xx := ghg(4,3,@(a,b,c,d),@(d,1+a-b,1+a-c),1);

S(xx,sghg(3));

s(ws,sghg(2));

yy := ghg(3,2,@(a-1,b,c/2),@((a+b)/2,c),1);

S(yy,sghg(1));

yy := ghg(3,2,@(a-1,b,c/2),@(a/2+b/2,c),1);

S(yy,sghg(1));

% Some Ghg theorems.

flag('(@), 'symmetric);

% Watson's Theorem.

SGhg(1) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=(1+?a+?b)/2,?e _=?e=2*?c),1) -> 
     Gamma(1/2)*Gamma(?c+1/2)*Gamma((1+?a+?b)/2)*Gamma((1-?a-?b)/2+?c)/
     (Gamma((1+?a)/2)*Gamma((1+?b)/2)*Gamma((1-?a)/2+?c)
	*Gamma((1-?b)/2+?c));

% Dixon's theorem.

SGhg(2) := Ghg(3,2,@(?a,?b,?c),@(?d _=?d=1+?a-?b,?e _=?e=1+?a-?c),1) -> 
     Gamma(1+?a/2)*Gamma(1+?a-?b)*Gamma(1+?a-?c)*Gamma(1+?a/2-?b-?c)/
     (Gamma(1+?a)*Gamma(1+?a/2-?b)*Gamma(1+?a/2-?c)*Gamma(1+?a-?b-?c));

SGhg(3) := Ghg(?p,?q,@(?a,??b),@(?a,??c),?z)
		   -> Ghg(?p-1,?q-1,@(??b),@(??c),?z);

SGhg(9) := Ghg(1,0,@(?a),?b,?z )       ->  (1-?z)^(-?a);
SGhg(10) := Ghg(0,0,?a,?b,?z)          ->  E^?z;
SGhg(11) := Ghg(?p,?q,@(??t),@(??b),0) ->  1;

% If one of the bottom parameters is zero or a negative integer the
% hypergeometric functions may be singular, so the presence of a
% functions of this type causes a warning message to be printed.

% Note it seems to have an off by one level spec., so this may need
% changing in future.
%
% Reference: AS 15.1; Slater, Generalized Hypergeometric Functions,
%     Cambridge University Press,1966.

s(Ghg(3,2,@(a,b,c),@(b,c),z),SGhg(3));

si(Ghg(3,2,@(a,b,c),@(b,c),z),{SGhg(3),Sghg(9)});

S(Ghg(3,2,@(a-1,b,c),@(a-b,a-c),1),sghg 2);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pmintrfc.red0000644000175000017500000004065611526203062023451 0ustar  giovannigiovannimodule pmintrfc;  % Interface for pattern matcher.

% Author: Kevin McIsaac.
% Changes by Rainer M. Schoepf 1991.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% For some reason, this doesn't like being compiled as a module.

% REDUCE syntax for pattern matching.
%
% ?a
%   This is an ordinary pattern matching variable. It can any value.
%
% ??a
%   This is a segment pattern variable. I can take any value as does ?a
%   or a set of values.
%
% ?a_=cond
%   ?a can only be matched is the condition does not evaluate to false
%
% exp1 -> exp2
%   exp1 is replaced by exp2
%
% exp1 --> exp2
%   exp1 is replaced by exp2, RHS is quoted. exp2 is simplified after
%   replacement
%
% M(exp,pat)
%   Returns a list of replacements for pm variables in pat such that pat
%   and exp are equal. Where defined the properties of symmetry, assoc-
%   iativity and the identity element are used to match the expressions.
%
% S(exp,rep,rpt:1,depth:Inf) or S(exp,{rep1,rep2,...},rpt:1,depth:Inf)
%  The lhs of rep is matched against exp and subexpressions of exp.
%  When a match is found the replacements for pm variables in rhs are
%  substituted into the lhs and the resultant expression is used as a
%  replacement.  This is done to a maximum (tree) depth of dept, with a
%  maximum number of repeats rpt, to a (tree) depth of dept.

% S(exp,rep,depth:Inf) or S(exp,{rep1,rep2,...},depth:Inf)
%   Shorthand notation for S with Inf number of rpt's
%
% exp1 :- exp2
%   exp1 is  added  to a  global  list of  automatic  replacements. Most
%   specific  rules are ordered  before less specific  rules.  If a rule
%   already exists the the rule is replaced unless exp2 is null in which
%   case the rule is deleted.
%
% exp1 ::- exp2
%   as above except the RHS is quoted.
%
fluid '(!*trpm rpt subfg!* substitution varstack!*);

switch trpm;

put('m,'psopfn,'mx);

symbolic procedure mx u; pm_m1(reval car u,reval cadr u);

symbolic procedure pm_m1(exp, temp);
   begin scalar substitution, mmatch, count, freevars;
      count := 0;
      freevars := idsort union(findnewvars temp,nil);
      substitution := if freevars then freevars else t;
      for each j in freevars do newenv j;
      mmatch := amatch(temp, exp, t, nil);
      for each j in freevars do restorenv j;
      if mmatch then return
         if freevars then 'list . for each j in pair(freevars, mmatch)
                                      collect list('rep, car j, cdr j)
         else t
   end;

symbolic procedure fixreplist(repset);
   % Check that repset is properly formed and add multi-generic
   % variables to assoc functions.
   begin scalar replist;
      if car(repset) memq '(rep repd) then replist := list(repset)
       else replist := cdr repset;
      replist := for each rep in replist collect fixrep(rep);
      return replist
   end;

Comment It is necessary to replace all free variables by unique ones
        in order to avoid confusion during the superset operation.
        To this end we generate replace them by special gensyms
        before putting them in the rules database.  This is not
        visible to the user;

fluid '(pm!:gensym!-count!*);

symbolic (pm!:gensym!-count!* := 0);

symbolic procedure pm!:gensym;
  compress ('!? . '!_ .
    explode (pm!:gensym!-count!* := pm!:gensym!-count!* + 1));

fluid '(freevarlist!*);

symbolic procedure make!-unique!-freevars form;
  if atom form then
    if get(form,'gen) then begin scalar x;
      x := atsoc (form, freevarlist!*);
      if null x then << x := (form . pm!:gensym());
                        put (cdr x, 'gen, t);
                        freevarlist!* := x .  freevarlist!*>>;
      return cdr x
     end
     else form
    else for each x in form collect make!-unique!-freevars x;

symbolic procedure fixrep(repl);
   << (repl := make!-unique!-freevars repl) where freevarlist!* := nil;
   % Should check if the extra multi-generic variables are required.
   if flagp(caadr repl,'assoc) then
      if flagp(caadr repl,'symmetric) then
         list(car repl,append(cadr repl,list('!?!?!;)),
            list(caadr repl,caddr repl,'!?!?!;))
      else
         list(car repl,caadr(repl) .
              ('!?!?!^ . append(cdadr repl,list('!?!?!;))),
            list(caadr repl,'!?!?!^,caddr repl,'!?!?!;))
   else repl >>;


put('s,'psopfn,'sx);

symbolic procedure sx arg;
   % Fill in args for s0. Default: repeat 1, depth Inf.
   reval
      s0(reval car arg, reval cadr arg,
            if cddr arg then reval caddr arg  else 1,
            if cddr arg and cdddr arg then reval car cdddr arg
             else 'inf);

put('si,'psopfn,'si!-x);

symbolic procedure si!-x arg;
   % Fill in args for s0. Default: repeat Inf, depth Inf.
   reval
      s0(reval car arg,reval cadr arg, 'inf,
            if cddr arg then reval caddr arg  else 'inf);

symbolic procedure s0(exp, repset,rpt,depth);
   % Breadth first search.  Rpt is passed as a fluid.
   if length repset <= 1 or not memq(car repset,'(rep repd list))
     then exp
    else if (depth neq 'inf and depth < 0)
          or (rpt neq 'inf and rpt <=0)  or atom(exp) then exp
    else sbreadth(exp,fixreplist repset,depth) ;

symbolic procedure sbreadth(exp,replist,depth);
   % Substitute a set of replacements into  the root expression until
   % expression stops changing, then recurse on all the sub expressions.
   <>;

symbolic procedure ssbreadth(exp,replist,depth);
   begin scalar newexp, new,  reps;
      if (depth neq 'inf and depth < 0)
          or (rpt neq 'inf and rpt <= 0)  or atom(exp) then return exp;
      repeat
      begin
         new := nil;
         reps := replist;
       a:   exp := reval for each subexp in exp collect
               << newexp := sroot1(subexp,car reps) ;
                  new := new or (subexp neq newexp);
                  newexp
               >>;
         if not (new or null(reps := cdr reps)) then go to a;
      end
      until(atom exp or not new);
      return
         if (depth neq 'inf and depth <= 0)
             or (rpt neq 'inf and rpt <= 0)  or atom(exp) then exp
         else for each subexp in exp collect
               ssbreadth(subexp,replist,
                         if depth neq 'inf then depth-1 else depth)
   end;


put('sd,'psopfn,'sdx);

symbolic procedure sdx arg;
   % Fill in args for sd0. Default: repeat 1, depth inf.
   reval
      sd0(reval car arg,reval  cadr arg,
            if cddr arg then reval caddr arg  else 1,
            if cddr arg and cdddr arg then reval car cdddr arg
             else 'inf);

put('sdi,'psopfn,'sdi);

symbolic procedure sdi arg;
   % Fill in args for sd0. Default: repeat Inf, depth Inf.
   reval
      sd0(reval car arg,reval  cadr arg, 'inf,
            if cddr arg then reval caddr arg  else 'inf);

symbolic procedure sd0(exp, repset,rpt,depth);
   % Depth first search.
   if length repset <= 1 or not memq(car repset,'(rep repd list))
     then exp
    else if (depth neq 'inf and depth < 0)
       or (rpt neq 'inf and rpt <= 0)  or atom(exp) then exp
    else sdepth(exp,fixreplist repset,depth) ;

symbolic procedure sdepth(exp,replist,depth);
   <>;

symbolic procedure sroot(exp,replist);
   % Substitute a set of replacements into a root expression until the
   % expression stops changing.  When a replacement succeeds the
   % substitution process restarts on the new expression at the
   % beginning of the replacement list.
   begin scalar oldexp, reps;
      if  (rpt neq 'inf and rpt <=0)  or atom(exp) then return exp;
      repeat
       begin
         oldexp := exp;
         reps := replist;
       a:   exp := sroot1(exp,car reps);
         if not(exp neq oldexp or null(reps := cdr reps)) then go to a;
         if exp neq oldexp then exp := reval exp
       end
      until(atom exp or exp eq oldexp);
      return exp;
   end;

symbolic procedure sroot1(exp,rep);
   % Try to substitute a single replacement into a root expression once
   % only.
   begin scalar freevars,substitution,mmatch;
      if (rpt neq 'inf and rpt <=0)  or
           atom(exp) or (car(exp) neq caadr(rep)) then return exp;
      freevars := union(findnewvars cadr rep,nil);
      substitution := caddr rep;
      for each j in freevars do newenv j;
      if !*trpm then <>;
      mmatch := amatch(cadr rep, exp, t,nil);
      if !*trpm
        then <>
                else <>;
               terpri()>>;
      for each j in freevars do restorenv j;
      return if mmatch then
             << if (rpt neq 'inf) then rpt := rpt - 1;
                embed!-null!-fn mmatch>>
             else exp
   end;

symbolic procedure embed!-null!-fn u;
   if atom u then u
    else for each j in u conc
       if atom j then list(j)
        else if car j eq 'null!-fn then embed!-null!-fn cdr j
        else list(embed!-null!-fn j);

algebraic operator null!-fn;

% Code for printing null-fn(a,b,...) as [a,b,...]. Modeled on LIST code.

put('null!-fn,'prifn,'null!-fn!-pri);

fluid '(orig!* posn!*);

symbolic procedure null!-fn!-pri l;
   % This definition is basically that of INPRINT, except that it
   % decides when to split at the comma by looking at the size of
   % the argument.
   (begin scalar split,u;
      u := l;
      l := cdr l;
      prin2!* "[";
      orig!* := if posn!*<18 then posn!* else orig!*+3;
      if null l then go to b;
      split := treesizep(l,40);   % 40 is arbitrary choice.
   a: maprint(negnumberchk car l,0);
      l := cdr l;
      if null l then go to b;
      oprin '!*comma!*;
      if split then terpri!* t;
      go to a;
   b: prin2!* "]";
      return u
   end)
    where orig!* := orig!*;

% Assignments and automatic replacements.

symbolic operator rset;

symbolic procedure rset(temp,exp);
   % Add new rule to rule list. If RHS is null then delete rule.
   if atom temp then setk(temp,exp)
    else begin scalar oldsubfg!*,varstack!*;
             %rebind subfg. Don't do this do that(yuck..lisp..)
             % rebind varstack!* since the template is simplified again
      oldsubfg!* := subfg!*; subfg!* := nil;
      temp := reval temp;
      put(car temp,'opmtch,
          rinsert(fixrep('rset . list(temp,exp)),
                  get(car temp,'opmtch)));
      subfg!* := oldsubfg!*;
      return exp
    end;

symbolic operator rsetd;

symbolic procedure rsetd(temp,exp);
   % Delayed version.
   if atom temp then 'hold . setk(temp,exp)
    else 'hold . list
      begin scalar oldsubfg!*,varstack!*;
           %rebind subfg. Don't do this do that(yuck..lisp..)
         oldsubfg!* := subfg!*; subfg!* := nil;
         temp := reval temp;
         put(car temp,'opmtch,
             rinsert(fixrep('rsetd . list(temp,exp)),
                     get(car temp,'opmtch)));
         subfg!* := oldsubfg!*;
         return exp
      end;

symbolic procedure rinsert(rule,rulelist);
% Insert rule in rule list so that most specific rules are found first.
% Use super-set idea, due to Grief.  If an equivalent rule exits then
% replace with new rule.  A new rule will be placed as far down the rule
% list as possible If the RHS of rule is nil then delete the rule.

if null rulelist or not atom caar rulelist then rule . rulelist
   else
     (lambda ss;
       if ss eq 'equal then
          if cadr rule then rule . cdr(rulelist)
          else cdr(rulelist)
       else if ss eq 't then rule . rulelist
       else car(rulelist) . rinsert(rule,cdr rulelist))
     superset(cadar rulelist,cadr rule);

symbolic procedure superset(temp1,temp2);
   begin scalar mmatch;
      mmatch := pm_m1(temp2,temp1);
      return(
         if null mmatch then nil
         else if mmatch eq 't then 'equal
         else if not bound2gen(cdr mmatch) then t
         else if null (mmatch := pm_m1(temp1,temp1)) then  t
         else 'equal)
   end;

symbolic procedure bound2gen(replist);
   % True if all Generic variables are bound to generic variables.
   null replist or (genp(caddar replist) and bound2gen(cdr replist));

symbolic operator arep;

symbolic procedure arep(replist);
   % Add the replacements in replist to the list of automatically
   % applied replacements.
   if atom replist then replist
    else if car replist eq 'rep
     then list('rset ,cadr replist,caddr replist)
    else if car replist eq 'repd
     then list('rsetd,cadr replist,caddr replist)
    else if car replist eq 'list then
%    '!*set!* . for each rep in cdr replist collect arep(rep)
     'list . for each rep in cdr replist collect arep(rep)
    else nil;

symbolic operator drep;

symbolic procedure drep(replist);
   % Delete the replacements in replist from the list of automatically
   % applied replacements.
   if atom replist then replist
    else if car replist eq 'rep  then list('rset ,cadr replist,nil)
    else if car replist eq 'repd then list('rsetd,cadr replist,nil)
    else if car replist eq 'list then
%     '!*set!*.for each rep in cdr replist collect Drep(rep)
     'list . for each rep in cdr replist collect drep(rep)
    else nil;

symbolic procedure opmtch(exp);
   begin scalar oldexp, replist, rpt;
      rpt := 'inf;
      replist := get(car exp, 'opmtch);
      if null(replist) or null subfg!* then return nil;
      oldexp := exp;
      repeat
      exp := if (atom caar replist) then sroot1(exp, car replist)
             else oldmtch(exp,car replist)
      until (exp neq oldexp or null(replist := cdr replist));
      return if exp eq oldexp then nil else exp
   end;

symbolic procedure oldmtch(exp,rule);
   begin scalar x, y;
      y := mcharg(cdr exp, car rule,car exp);
      while (y and null x) do
      <>;
      return if x then x else exp
   end;

put('!?,'gen,t);

put('!?!?!;,'mgen,t);

put('!?!?!$,'mgen,t);

put('!?!?!^,'mgen,t);

symbolic operator prop!-alg;

newtok '((!_) prop!-alg);

symbolic procedure prop!-alg(f);
   begin scalar x;
      x := prop f;
      while x do <>
   end;

symbolic operator preceq;

symbolic procedure preceq(u,v);
   % Give u same precedence as v.
   <>;

newtok '((!: !- )    rset);
newtok '((!: !: !- ) rsetd);
newtok '((!- !>)    rep);
newtok '((!- !- !>) repd);
newtok '((!_ !=) such!-that);

flag ('(such!-that), 'spaced);  % _ adjacent to symbols causes problems.

algebraic;

infix :-;
nosimp(:-,'(t nil));
%precedence :-,:=;  %can't do this

infix ::-;
nosimp(::-,'(t t));
precedence rsetd,rset;

infix ->;
precedence ->,rsetd;

infix -->;
nosimp(-->,'(nil t));
precedence -->,->;

infix _=;
nosimp(_=,'(nil t));
precedence _=,-->;

operator hold;
nosimp(hold,t);
flag('(rset rsetd rep repd such!-that), 'right);
preceq(rsetd,rset);
preceq(-->,->);

flag('(plus times expt),'assoc);

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.tex0000644000175000017500000002420311526203062022257 0ustar  giovannigiovanni\documentclass{article}

\usepackage[dvipdfm]{graphicx}
\usepackage[dvipdfm]{color}
\usepackage[dvipdfm]{hyperref}

\usepackage{a4}
\setlength{\parindent}{0cm}

\title{PM - A REDUCE Pattern Matcher}
\author{Kevin McIsaac \\
	The University of Western Australia \\
	 and \\
	 The RAND Corporation \\
	 kevin@wri.com}
\date{}


\begin{document}
\maketitle

PM is a general pattern matcher similar in style to those found in systems
such as SMP and Mathematica, and is based on the pattern matcher described
in Kevin McIsaac, \char`\"{}Pattern Matching Algebraic Identities\char`\"{},
SIGSAM Bulletin, 19 (1985), 4-13. \\
\ \\
The following is a description of its structure. \\
\ \\
A template is any expression composed of literal elements (e.g. \char`\"{}5\char`\"{},
\char`\"{}a\char`\"{} or \char`\"{}a+1\char`\"{}) and specially denoted pattern 
variables (e.g. ?a or ??b). Atoms beginning with `?' are called generic variables 
and match any expression. \\
\ \\
Atoms beginning with `??' are called multi-generic variables and match any
expression or any sequence of expressions including the null or empty
sequence. A sequence is an expression of the form `{[}a1, a2,...{]}'. When
placed in a function argument list the brackets are removed, i.e. f({[}a,1{]})
$->$ f(a,1) and f(a,{[}1,2{]},b) $->$ f(a,1,2,b). \\
\ \\
A template is said to match an expression if the template is literally
equal to the expression or if by replacing any of the generic or
multi-generic symbols occurring in the template, the template can be made
to be literally equal to the expression. These replacements are called the
bindings for the generic variables. A replacement is an expression of the
form `exp1 $->$ exp2', which means exp1 is replaced by exp2, or `exp1 $-->$
exp2', which is the same except exp2 is not simplified until after the
substitution for exp1 is made. If the expression has any of the
properties; associativity, commutativity, or an identity element, they are
used to determine if the expressions match. If an attempt to match the
template to the expression fails the matcher backtracks, unbinding generic
variables, until it reached a place were it can make a different choice.
It then proceeds along the new branch. \\
\ \\
The current matcher proceeds from left to right in a depth first search of
the template expression tree. Rearrangements of the expression are
generated when the match fails and the matcher backtracks. \\
\ \\
The matcher also supports semantic matching. Briefly, if a subtemplate
does not match the corresponding subexpression because they have different
structures then the two are equated and the matcher continues matching the
rest of the expression until all the generic variables in the subexpression
are bound. The equality is then checked. This is controlled by the switch
`semantic'. By default it is on. \\

\pagebreak

{\tt M($exp,temp$)} \\
\ \\
\begin{tabular}{lp{11cm}}
\hspace*{0.2cm} & The template, temp, is matched against the expression, exp. If the
template is literally equal to the expression `T' is returned. If the
template is literally equal to the expression after replacing the
generic variables by their bindings then the set of bindings is returned
as a set of replacements. Otherwise 0 (nil) is returned. \\
\end{tabular} \\
\ \\
\ \\
{\bf Examples:} \\
\ \\


 A \char`\"{}literal\char`\"{} template

 m(f(a),f(a));

 T



 Not literally equal

 m(f(a),f(b));

 0



 Nested operators

 m(f(a,h(b)),f(a,h(b)));

 T



 a \char`\"{}generic\char`\"{} template

 m(f(a,b),f(a,?a));

 \{?A$->$B\}



 m(f(a,b),f(?a,?b));

 \{?B$->$B,?A$->$A\}



 The Multi-Generic symbol, ??a, takes \char`\"{}rest\char`\"{} of arguments

 m(f(a,b),f(??a));

 \{??A$->${[}A,B{]}\}



 but the Generic symbol, ?a, does not

 m(f(a,b),f(?a));

 0



 Flag h as associative

 flag('(h),'assoc);

 Associativity is used to \char`\"{}group\char`\"{} terms together

 m(h(a,b,d,e),h(?a,d,?b));

 \{?B$->$E,?A'$->$H(A,B)\}



 \char`\"{}plus\char`\"{} is a symmetric function

 m(a+b+c,c+?a+?b);

 \{?B$->$A,?A$->$B\}



 it is also associative

 m(a+b+c,b+?a);

 \{?A$->$C + A\}



 Note the affect of using multi-generic symbol is different

 m(a+b+c,b+??c);

 \{??C$->${[}C,A{]}\}



temp \_= logical-exp \\
\ \\
A template may be qualified by the use of the conditional operator `\_=',
such!-that. When a such!-that condition is encountered in a template it
is held until all generic variables appearing in logical-exp are bound.

On the binding of the last generic variable logical-exp is simplified
and if the result is not `T' the condition fails and the pattern matcher
backtracks. When the template has been fully parsed any remaining held
such-that conditions are evaluated and compared to `T'. \\
\ \\
{\bf Examples:} \\
\ \\
 m(f(a,b),f(?a,?b\_=(?a=?b)));

 0


 m(f(a,a),f(?a,?b\_=(?a=?b)));

 \{?B$->$A,?A$->$A\}



 Note that f(?a,?b\_=(?a=?b)) is the same as f(?a,?a)



S(exp,\{temp1$->$sub1,temp2$->$sub2,...\},rept, depth) \\
\ \\
Substitute the set of replacements into exp, resubstituting a maximum of
'rept' times and to a maximum depth 'depth'. 'Rept' and 'depth' have the
default values of 1 and infinity respectively. Essentially S is a
breadth first search and replace.

Each template is matched against exp until a successful match occurs.

Any replacements for generic variables are applied to the rhs of that
replacement and exp is replaced by the rhs. The substitution process is
restarted on the new expression starting with the first replacement. If
none of the templates match exp then the first replacement is tried
against each sub-expression of exp. If a matching template is found
then the sub-expression is replaced and process continues with the next
sub-expression.

When all sub-expressions have been examined, if a match was found, the
expression is evaluated and the process is restarted on the
sub-expressions of the resulting expression, starting with the first
replacement. When all sub-expressions have been examined and no match
found the sub-expressions are reexamined using the next replacement.
Finally when this has been done for all replacements and no match found
then the process recures on each sub-expression.


The process is terminated after rept replacements or when the expression
no longer changes.



Si(exp,\{temp1$->$sub1,temp2$->$sub2,...\}, depth)


Substitute infinitely many times until expression stops changing.
Short hand notation for S(exp,\{temp1$->$sub1,temp2$->$sub2,...\},Inf,
depth)


Sd(exp,\{temp1$->$sub1,temp2$->$sub2,...\},rept, depth)


Depth first version of Substitute.\\
\ \\
{\bf Examples:} \\
\ \\
 s(f(a,b),f(a,?b)$->$?b\^{}2);

 2

 B



 s(a+b,a+b$->$a{*}b);

 B{*}A



 \char`\"{}associativity\char`\"{} is used to group a+b+c in to (a+b)
+ c

 s(a+b+c,a+b$->$a{*}b);

 B{*}A + C


The next three examples use a rule set that defines the factorial function.

Substitute once

 s(nfac(3),\{nfac(0)$->$1,nfac(?x)$->$?x{*}nfac(?x-1)\});

 3{*}NFAC(2)


Substitute twice

 s(nfac(3),\{nfac(0)$->$1,nfac(?x)$->$?x{*}nfac(?x-1)\},2);

 6{*}NFAC(1)


Substitute until expression stops changing

 si(nfac(3),\{nfac(0)$->$1,nfac(?x)$->$?x{*}nfac(?x-1)\});

 6


Only substitute at the top level

 s(a+b+f(a+b),a+b$->$a{*}b,inf,0);

 F(B + A) + B{*}A


temp :- exp \\
\ \\
If during simplification of an expression, temp matches some
sub-expression then that sub-expression is replaced by exp. If there is
a choice of templates to apply the least general is used.

If a old rule exists with the same template then the old rule is
replaced by the new rule. If exp is `nil' the rule is retracted.



temp ::- exp


Same as temp :- exp, but the lhs is not simplified until the replacement
is made \\
\ \\
{\bf Examples:} \\
\ \\
Define the factorial function of a natural number as a recursive function
and a termination condition. For all other values write it as a Gamma
Function. Note that the order of definition is not important as the rules
are reordered so that the most specific rule is tried first.

Note the use of `::-' instead of `:-' to stop simplification of
the LHS. Hold stops its arguments from being simplified. \\
\ \\
 fac(?x\_=Natp(?x)) ::- ?x{*}fac(?x-1);

 HOLD(FAC(?X-1){*}?X)



 fac(0) :- 1;

 1



 fac(?x) :- Gamma(?x+1);

 GAMMA(?X + 1)



 fac(3);

 6



 fac(3/2);

 GAMMA(5/2)



Arep(\{rep1,rep2,..\}) \\
\ \\
In future simplifications automatically apply replacements rep1,
rep2...~ until the rules are retracted. In effect it replaces the
operator `$->$' by `:-' in the set of replacements \{rep1, rep2,...\}.



Drep(\{rep1,rep2,..\})



 Delete the rules rep1, rep2,... \\
\ \\
As we said earlier, the matcher has been constructed along the lines of the
pattern matcher described in McIsaac with the addition of such-that
conditions and `semantic matching' as described in Grief. To make a
template efficient some consideration should be given to the structure of
the template and the position of such-that statements. In general the
template should be constructed to that failure to match is recognize as
early as possible. The multi-generic symbol should be used when ever
appropriate, particularly with symmetric functions. For further details
see McIsaac. \\
\ \\
{\bf Examples:} \\
\ \\
 f(?a,?a,?b) is better that f(?a,?b,?c\_=(?a=?b))

 ?a+??b is better than ?a+?b+?c...

The template, f(?a+?b,?a,?b), matched against f(3,2,1) is
matched as f(?e\_=(?e=?a+?b),?a,?b) when semantic matching is allowed. \\

{\bf Switches} \\
\ \\
{\tt TRPM} \\
Produces a trace of the rules applied during a substitution. This is
useful to see how the pattern matcher works, or to understand an
unexpected result. \\
\ \\
In general usage the following switches need not be considered. \\
\ \\
{\tt SEMANTIC} \\
Allow semantic matches, e.g. f(?a+?b,?a,?b) will match f(3,2,1) even
though the matcher works from left to right. \\
\ \\
{\tt SYM!-ASSOC} \\
Limits the search space of symmetric associative functions when the
template contains multi-generic symbols so that generic symbols will not
the function. For example: m(a+b+c,?a+??b) will return \{?a $->$ a, ??b$->$
{[}b,c{]}\} or \{?a $->$ b, ??b$->$ {[}a,c{]}\} or \{?a $->$ c, ??b$->$ {[}a,b{]}\}
but no \{?a $->$ a+b, ??b$->$ c\} etc. No sane template should require these 
types of matches. However they can be made available by turning the switch off.

\end{document}
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pm.txt0000644000175000017500000002411711526203062022302 0ustar  giovannigiovanni

                       PM - A REDUCE Pattern Matcher


                               Kevin McIsaac

                    The University of Western Australia
                                    and
                           The RAND Corporation

                              kevin@wri.com


PM is a general pattern matcher similar in style to those found in systems
such as SMP and Mathematica, and is based on the pattern matcher described
in Kevin McIsaac, "Pattern Matching Algebraic Identities", SIGSAM Bulletin,
19 (1985), 4-13.  The following is a description of its structure.

A template is any expression composed of literal elements (e.g. "5", "a" or
"a+1") and specially denoted pattern variables (e.g. ?a or ??b).  Atoms
beginning with `?' are called generic variables and match any expression.
Atoms beginning with `??' are called multi-generic variables and match any
expression or any sequence of expressions including the null or empty
sequence.  A sequence is an expression of the form `[a1, a2,...]'.  When
placed in a function argument list the brackets are removed, i.e. f([a,1])
-> f(a,1) and f(a,[1,2],b) -> f(a,1,2,b).

A template is said to match an  expression  if the template is literally
equal to the expression or if by replacing any of the generic or
multi-generic symbols occurring in the template, the template can be made
to be literally equal to the expression.  These replacements are called the
bindings for the generic variables.  A replacement is an expression of the
form `exp1 -> exp2', which means exp1 is replaced by exp2, or `exp1 -->
exp2', which is the same except exp2 is not simplified until after the
substitution for exp1 is made.  If the expression has any of the
properties; associativity, commutativity, or an identity element, they are
used to determine if the expressions match.  If an attempt to match the
template to the expression fails the matcher backtracks, unbinding generic
variables, until it reached a place were it can make a different choice.
It then proceeds along the new branch.

The current matcher proceeds from left to right in a depth first search of
the template expression tree.  Rearrangements of the expression are
generated when the match fails and the matcher backtracks.

The matcher also supports semantic matching.  Briefly, if a subtemplate
does not match the corresponding subexpression because they have different
structures then the two are equated and the matcher continues matching the
rest of the expression until all the generic variables in the subexpression
are bound.  The equality is then checked.  This is controlled by the switch
`semantic'.  By default it is on.

M(exp,temp)

   The template, temp, is matched against the expression, exp.  If the
   template is literally equal to the expression `T' is returned.  If the
   template is literally equal to the expression after replacing the
   generic variables by their bindings then the set of bindings is returned
   as a set of replacements.  Otherwise 0 (nil) is returned.

Examples:

        A "literal" template
        m(f(a),f(a));
        T

        Not literally equal
        m(f(a),f(b));
        0

        Nested operators
        m(f(a,h(b)),f(a,h(b)));
        T

        a "generic" template
        m(f(a,b),f(a,?a));
        {?A->B}

        m(f(a,b),f(?a,?b));
        {?B->B,?A->A}

        The Multi-Generic symbol, ??a, takes "rest" of arguments
        m(f(a,b),f(??a));
        {??A->[A,B]}

        but the Generic symbol, ?a, does not
        m(f(a,b),f(?a));
        0

        Flag h as associative
        flag('(h),'assoc);
        Associativity is used to "group" terms together
        m(h(a,b,d,e),h(?a,d,?b));
        {?B->E,?A->H(A,B)}

        "plus" is a symmetric function
        m(a+b+c,c+?a+?b);
        {?B->A,?A->B}

        it is also associative
        m(a+b+c,b+?a);
        {?A->C + A}

        Note the affect of using multi-generic symbol is different
        m(a+b+c,b+??c);
        {??C->[C,A]}

temp _= logical-exp

   A template may be qualified by the use of the conditional operator `_=',
   such!-that.  When a such!-that condition is encountered in a template it
   is held until all generic variables appearing in logical-exp are bound.
   On the binding of the last generic variable logical-exp is simplified
   and if the result is not `T' the condition fails and the pattern matcher
   backtracks.  When the template has been fully parsed any remaining held
   such-that conditions are evaluated and compared to `T'.

Examples:

        m(f(a,b),f(?a,?b_=(?a=?b)));
        0

        m(f(a,a),f(?a,?b_=(?a=?b)));
        {?B->A,?A->A}

        Note that f(?a,?b_=(?a=?b)) is the same as f(?a,?a)

S(exp,{temp1->sub1,temp2->sub2,...},rept, depth)

   Substitute the set of replacements into exp, resubstituting a maximum of
   'rept' times and to a maximum depth 'depth'. 'Rept' and 'depth' have the
   default values of 1 and infinity respectively.  Essentially S is a
   breadth first search and replace.

   Each template is matched against exp until a successful match occurs.
   Any replacements for generic variables are applied to the rhs of that
   replacement and exp is replaced by the rhs.  The substitution process is
   restarted on the new expression starting with the first replacement.  If
   none of the templates match exp then the first replacement is tried
   against each sub-expression of exp.  If a matching template is found
   then the sub-expression is replaced and process continues with the next
   sub-expression.

   When all sub-expressions have been examined, if a match was found, the
   expression is evaluated and the process is restarted on the
   sub-expressions of the resulting expression, starting with the first
   replacement.  When all sub-expressions have been examined and no match
   found the sub-expressions are reexamined using the next replacement.
   Finally when this has been done for all replacements and no match found
   then the process recures on each sub-expression.

   The process is terminated after rept replacements or when the expression
   no longer changes.

Si(exp,{temp1->sub1,temp2->sub2,...}, depth)

   Substitute  infinitely many times until  expression  stops  changing.
   Short  hand  notation  for   S(exp,{temp1->sub1,temp2->sub2,...},Inf,
   depth)

Sd(exp,{temp1->sub1,temp2->sub2,...},rept, depth)

   Depth first version of Substitute.

Examples:

        s(f(a,b),f(a,?b)->?b^2);
         2
        B

        s(a+b,a+b->a*b);
        B*A

        "associativity" is used to group a+b+c in to (a+b) + c
        s(a+b+c,a+b->a*b);
        B*A + C

The next three examples use a rule set that defines the factorial function.
        Substitute once
        s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});
        3*NFAC(2)

        Substitute twice
        s(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)},2);
        6*NFAC(1)

        Substitute until expression stops changing
        si(nfac(3),{nfac(0)->1,nfac(?x)->?x*nfac(?x-1)});
        6

        Only substitute at the top level
        s(a+b+f(a+b),a+b->a*b,inf,0);
        F(B + A) + B*A



temp :- exp

   If during simplification of an expression, temp matches some
   sub-expression then that sub-expression is replaced by exp.  If there is
   a choice of templates to apply the least general is used.

   If a old rule exists with the same template then the old rule is
   replaced by the new rule.  If exp is `nil' the rule is retracted.

temp ::- exp

   Same as temp :- exp, but the lhs is not simplified until the replacement
   is made

   Examples:

Define the factorial function of a natural number as a recursive function
and a termination condition.  For all other values write it as a Gamma
Function.  Note that the order of definition is not important as the rules
are reordered so that the most specific rule is tried first.

        Note the use of `::-' instead of `:-' to stop  simplification of
        the LHS. Hold stops its arguments from being simplified.
        fac(?x_=Natp(?x)) ::- ?x*fac(?x-1);
        HOLD(FAC(?X-1)*?X)

        fac(0)  :- 1;
        1

        fac(?x) :- Gamma(?x+1);
        GAMMA(?X + 1)

        fac(3);
        6

        fac(3/2);
        GAMMA(5/2)

Arep({rep1,rep2,..})

   In  future  simplifications  automatically  apply  replacements  re1,
   rep2...  until the rules are  retracted.  In effect it  replaces  the
   operator `->' by `:-' in the set of replacements {rep1, rep2,...}.

Drep({rep1,rep2,..})

   Delete the rules rep1, rep2,...

As we said earlier, the matcher has been constructed along the lines of the
pattern matcher described in McIsaac with the addition of such-that
conditions and `semantic matching' as described in Grief.  To make a
template efficient some consideration should be given to the structure of
the template and the position of such-that statements.  In general the
template should be constructed to that failure to match is recognize as
early as possible.  The multi-generic symbol should be used when ever
appropriate, particularly with symmetric functions.  For further details
see McIsaac.

Examples:

        f(?a,?a,?b) is better that f(?a,?b,?c_=(?a=?b))
        ?a+??b      is better than ?a+?b+?c...
        The template,  f(?a+?b,?a,?b),  matched  against  f(3,2,1) is
        matched as f(?e_=(?e=?a+?b),?a,?b) when semantic matching is allowed.


                                    Switches
                                    --------

TRPM
   Produces a trace of the rules applied during a substitution.  This is
   useful to see how the pattern matcher works, or to understand an
   unexpected result.

In general usage the following switches need not be considered.

SEMANTIC
   Allow semantic matches, e.g. f(?a+?b,?a,?b) will match f(3,2,1) even
   though the matcher works from left to right.

SYM!-ASSOC
   Limits the search space of symmetric associative functions when the
   template contains multi-generic symbols so that generic symbols will not
   the function.  For example: m(a+b+c,?a+??b) will return {?a -> a, ??b->
   [b,c]} or {?a -> b, ??b-> [a,c]} or {?a -> c, ??b-> [a,b]} but no {?a ->
   a+b, ??b-> c} etc.  No sane template should require these types of
   matches.  However they can be made available by turning the switch off.
mathpiper-0.81f+svn4469+dfsg3/src/packages/pm/pattdefn.red0000644000175000017500000001076211526203062023427 0ustar  giovannigiovannimodule pattdefn; %Notational conveniences and low level routines for the
                 % UNIFY code.

% Author: Kevin McIsaac.
% Changes by Rainer M. Schoepf 1991.

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


fluid('(freevars op r p i upb
        identity expand acontract mcontract comb count symm ))$

% Binding routines.  These would be more efficient with a more direct
% mechanism.

symbolic procedure bind(u, v);         %push the value of v onto the
   put(u,'binding,v.get(u,'binding))$   %binding stack of u

symbolic procedure binding(u);              %Top most binding on stack
   (lambda x; if x then car x) get(u,'binding)$

symbolic procedure unbind(u);                  %pop binding off stack
   put(u,'binding, cdr get(u,'binding))$

symbolic procedure newenv(u);           % Mark a new environment.
   bind(u, 'unbound)$                   % Give UNIFY lexical scoping.

symbolic procedure restorenv(u);        % Should include error checks?
   unbind(u)$

symbolic procedure pm!:free(u);       % Is u a pm unbound free variable?
   binding(u) eq 'unbound$

symbolic procedure bound(u);           % Is u a pm bound free variable?
   (lambda x;  x and (x neq 'unbound)) binding u;

symbolic procedure meq(u,v);
 (lambda x;
%    (if (x and (x neq 'unbound)) then x else u) eq meval v )
     (if (x and (x neq 'unbound)) then x else u) = v)
          binding u;

% This has been fixed.
% symbolic procedure meval(u);
%    if eqcar(u,'minus) and numberp cadr u then -cadr u else u;


% Currently Mval does nothing.  It should be defined so that nosimp
% functions are handled properly.  By leaving it out the PM will not
% dynamically change pattern it is working on.  I.e.,
% m(f(1,2,3+c),f(?a,?b,?a+?b+?c)) will now return True.  If the code
% commented out is restored then this will give the expected result.
% However m(f(1_=natp 1),f(?a_=natp ?a)), where natp(?x) :- t, will not
% work.

symbolic procedure mval(u); u;
%===>   if not atom u then (reval bsubs(car u)) . cdr u
%===>   else bsubs u;

symbolic procedure bsubs(u);
   % Replaces free atoms by their bindings.  Would be nice to mark
   % expressions that no longer contain bunbound free variables
   if null u then u
   else if atom u then if bound(u) then binding u else u
   else for each j in u collect bsubs j;

symbolic procedure ident(op);
get(op,'identity)$

symbolic procedure genp(u);
   atom u and (get(u,'gen) or mgenp(u))$

symbolic procedure mgenp(u);
   atom u and get(u,'mgen)$

symbolic procedure suchp u;             %Is this a such that condition?
   not atom u and car u eq 'such!-that$

% False if any SUCH conditions are in wich all free variable are bound
% does not simplify to T.  Should we return free expressions partially
% simplified?

symbolic procedure chk u;
null u or u eq t or
(lambda x;
   if freexp(x) then
      (lambda y; if null y then nil
                 else if y eq t then list x
                 else x.y) chk(cdr u)
   else if reval(x) eq t then chk(cdr u) else nil) bsubs car u$

symbolic procedure findnewvars u;
   if atom u then if genp u then list u else nil
    else for each j in u conc findnewvars j;

symbolic procedure freexp u;
   if atom u then pm!:free u else freexp car u or freexp cdr u;

symbolic procedure genexp u;
   if atom u then genp u else genexp car u or genexp cdr u;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/org/0000755000175000017500000000000011722677373017537 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/0000755000175000017500000000000011722677351021524 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/0000755000175000017500000000000011722677341022140 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/text/0000755000175000017500000000000011722677341023124 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/text/consoles/0000755000175000017500000000000011722677341024751 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/text/consoles/Console.java0000644000175000017500000001436511477357006027227 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.text.consoles;

//import org.mathpiper.lisp.UtilityFunctions;

import java.io.*;
import org.mathpiper.Version;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;


/**
 * Provides a command line console which can be used to interact with a mathpiper instance.
 */
public class Console {

    private Interpreter interpreter;
    private boolean suppressOutput = false;


    public Console() {
        //MathPiper needs an output stream to send "side effect" output to.
        //StandardFileOutputStream stdoutput = new StandardFileOutputStream(System.out);
        interpreter = Interpreters.getSynchronousInterpreter();
    }


    void addDirectory(String directory) {
        interpreter.addScriptsDirectory(directory);
    }


    String readLine(InputStreamReader aStream) {
        StringBuffer line = new StringBuffer();
        try {
            int c = aStream.read();
            while (c != '\n') {
                line.append((char) c);
                c = aStream.read();
            }
        } catch (Exception e) {
            System.out.println(e.toString());
        }
        return line.toString();
    }


    String evaluate(String input) {
        //return (String) interpreter.evaluate(input);
        EvaluationResponse response = interpreter.evaluate(input, true);

        String responseString = "";

        if (suppressOutput == false) {
            responseString = "Result> " + response.getResult() + "\n";
        } else {
            responseString = "Result> " + "OUTPUT SUPPRESSED\n";
            this.suppressOutput = false;
        }


        if (!response.getSideEffects().equalsIgnoreCase("")) {
            responseString = responseString + "Side Effects>\n" + response.getSideEffects() + "\n";
        }

        if (!response.getExceptionMessage().equalsIgnoreCase("")) {
            responseString = responseString + response.getExceptionMessage() + " Source file name: " + response.getSourceFileName() + ", Near line number: " + response.getLineNumber() + "\n";
        }
        else if (response.getException() != null)
        {
            response.getException().printStackTrace();
        }


        return responseString;
    }//end evaluate.


    /**
     * A Read Evaluate Print Loop for implementing text consoles.
     *
     * @param in console input.
     * @param out console output.
     */
    public void repl(InputStream inputStream, PrintStream out) {
        out.println("\nMathPiper version '" + Version.version + "'.");
        out.println("See http://mathpiper.org for more information and documentation on MathPiper.");
        out.println("Place a backslash at the end of a line to enter multiline input.");
        out.println("To exit MathPiper, enter \"Exit()\" or \"exit\" or \"quit\" or Ctrl-c.\n");
        /*TODO fixme
        System.out.println("Type ?? for help. Or type ?function for help on a function.\n");
        System.out.println("Type 'restart' to restart MathPiper.\n");
         */
        //out.println("To see example commands, keep typing Example()\n");

        //piper.Evaluate("BubbleSort(N(PSolve(x^3-3*x^2+2*x,x)), \"<\");");

        boolean quitting = false;
        String oneOrMoreLineInput = "";
        String input;
        while (!quitting) {
            out.print("In> ");
            input = readLine(new InputStreamReader(inputStream));
            input = input.trim();

            if (input.endsWith("\\")) {
                oneOrMoreLineInput += input.substring(0, input.length() - 1);
                continue;
            } else {
                oneOrMoreLineInput += input;
            }

            oneOrMoreLineInput = oneOrMoreLineInput.trim();

            if(oneOrMoreLineInput.endsWith(";;"))
            {
                this.suppressOutput = true;
            }
            String responseString = evaluate(oneOrMoreLineInput);

            oneOrMoreLineInput = "";

            out.println(responseString);

            if (input.equalsIgnoreCase("exit") || input.equalsIgnoreCase("quit")) {

                quitting = true;
            }
        }
    }//end repl.


    /**
     * The normal entry point for running mathpiper from a command line.  It processes command line arguments,
     * sets mathpiper's standard output to System.out, then enters a REPL (Read, Evaluate, Print Loop).  Currently,
     * the console only supports the --rootdir and --archive command line options.
     *
     * @param argv
     */
    public static void main(String[] argv) {
        Console console = new Console();
        String defaultDirectory = null;
        String archive = null;



        int i = 0;
        while (i < argv.length) {
            if (argv[i].equals("--rootdir")) {
                i++;
                defaultDirectory = argv[i];
            }
            if (argv[i].equals("--archive")) {
                i++;
                archive = argv[i];
            } else {
                break;
            }
            i++;
        }

        //Change the default directory. tk.
        if (defaultDirectory != null) {
            console.addDirectory(defaultDirectory);
        }

        if (i < argv.length) {
            for (; i < argv.length; ++i) {
                String cmd = "LoadScript(\"".concat(argv[i]).concat("\");");
                System.out.println(console.evaluate(cmd));
            }
        } else {
            console.repl(System.in, System.out);
        }



    }//end main.
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/0000755000175000017500000000000011722677373022731 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/0000755000175000017500000000000011722677341024222 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Des10.gif0000644000175000017500000001515211272077141025561 0ustar  giovannigiovanniwt	aleph.gifsrjava.awt.RectangleðjjtIheightIwidthIxIyxp
t	alpha.gifsq~t	amalg.gifsq~
 t	angle.gifsq~
0t
approx.gifsq~
@tast.gifsq~Pt	asymp.gifsq~

`tbeta.gifsq~
	ptbigcirc.gifsq~
tbigtriangledown.gifsq~
tbigtriangleup.gifsq~

tbot.gifsq~	t
bowtie.gifsq~

tBox.gifsq~	
t
bullet.gifsq~tcap.gifsq~		tcdot.gifsq~t	cdots.gifsq~tchi.gifsq~	
 tcirc.gifsq~0tclubsuit.gifsq~
tcong.gifsq~	
tcup.gifsq~		 t
dagger.gifsq~
0t	dashv.gifsq~
	@tddagger.gifsq~
Pt	ddots.gifsq~`t	delta.gifsq~
ptDeltaBig.gifsq~
tdiamond.gifsq~tDiamondBig.gifsq~
tdiamondsuit.gifsq~
tdiv.gifsq~	
t	doteq.gifsq~
t
downarrow.gifsq~
tDownarrowBig.gifsq~
tell.gifsq~
temptyset.gifsq~
tepsilon.gifsq~ t	equiv.gifsq~
0teta.gifsq~	4t
exists.gifsq~4tflat.gifsq~4 t
forall.gifsq~
	40tFourier.gifsq~
4@t	frown.gifsq~4Pt	gamma.gifsq~	4`tGammaBig.gifsq~4ptge.gifsq~
4tgeq.gifsq~
4tgets.gifsq~4tgg.gifsq~	4thbar.gifsq~
4t
heartsuit.gifsq~
4thookleftarrow.gifsq~4thookrightarrow.gifsq~4tIm.gifsq~
4t	imath.gifsq~4tin.gifsq~		4 t	infty.gifsq~40tint.gifsq~	Ntiota.gifsq~Nt	jmath.gifsq~
N tJoin.gifsq~

N0t	kappa.gifsq~N@t
lambda.gifsq~
NPt
LambdaBig.gifsq~
N`tLaplace.gifsq~

Npt	ldots.gifsq~Ntle.gifsq~
Ntleadsto.gifsq~Nt
leftarrow.gifsq~NtLeftarrowBig.gifsq~
Ntleftharpoondown.gifsq~Ntleftharpoonup.gifsq~Ntleftrightarrow.gifsq~NtLeftrightarrowBig.gifsq~Ntleq.gifsq~
Ntlhd.gifsq~

N tll.gifsq~	N0tlongleftarrow.gifsq~htLongleftarrowBig.gifsq~htlongleftrightarrow.gifsq~h tLongleftrightarrowBig.gifsq~h0tlongmapsto.gifsq~h@tlongrightarrow.gifsq~hPtLongrightarrowBig.gifsq~h`t
mapsto.gifsq~hptmho.gifsq~

htmid.gifsq~ht
models.gifsq~
htmp.gifsq~
	htmu.gifsq~	ht	nabla.gifsq~htnatural.gifsq~
htnearrow.gifsq~
htneg.gifsq~	htneq.gifsq~htni.gifsq~		h tnu.gifsq~h0tnwarrow.gifsq~
todot.gifsq~
toint.gifsq~	 t	omega.gifsq~
0tOmegaBig.gifsq~

@t
ominus.gifsq~
Pt	oplus.gifsq~
`t
oslash.gifsq~
pt
otimes.gifsq~
tparallel.gifsq~
tpartial.gifsq~
tperp.gifsq~	tphi.gifsq~
t
PhiBig.gifsq~

tpi.gifsq~	t	PiBig.gifsq~
tpm.gifsq~
	tprec.gifsq~
t
preceq.gifsq~
 t	prime.gifsq~0tprod.gifsq~
t
propto.gifsq~tpsi.gifsq~

 t
PsiBig.gifsq~

0tRe.gifsq~
@trhd.gifsq~

Ptrho.gifsq~	`trightarrow.gifsq~ptRightarrowBig.gifsq~
trightharpoondown.gifsq~trightharpoonup.gifsq~trightleftharpoons.gifsq~
tsearrow.gifsq~
tsetminus.gifsq~t	sharp.gifsq~
t	sigma.gifsq~tSigmaBig.gifsq~
tsim.gifsq~
t	simeq.gifsq~
 t	smile.gifsq~0t
spadesuit.gifsq~t	sqcap.gifsq~
	t	sqcup.gifsq~
	 tsqsubset.gifsq~	
0tsqsubseteq.gifsq~@tsqsupset.gifsq~	
Ptsqsupseteq.gifsq~`tstar.gifsq~pt
subset.gifsq~	
tsubseteq.gifsq~
tsucc.gifsq~
t
succeq.gifsq~
tsum.gifsq~t
supset.gifsq~	
tsupseteq.gifsq~
tswarrow.gifsq~
ttau.gifsq~t	theta.gifsq~
tThetaBig.gifsq~

 t	times.gifsq~
0tto.gifsq~ttop.gifsq~
ttriangle.gifsq~

 ttriangleleft.gifsq~0ttriangleright.gifsq~@t	unlhd.gifsq~

Pt	unrhd.gifsq~

`tuparrow.gifsq~
ptUparrowBig.gifsq~
tupdownarrow.gifsq~tUpdownarrowBig.gifsq~

t	uplus.gifsq~		tupsilon.gifsq~tUpsilonBig.gifsq~

tvarepsilon.gifsq~t
varphi.gifsq~	
t	varpi.gifsq~
t
varrho.gifsq~	tvarsigma.gifsq~ tvartheta.gifsq~
0t	vdash.gifsq~

t	vdots.gifsq~tvee.gifsq~		 t	wedge.gifsq~		0twp.gifsq~		@twr.gifsq~
Ptxi.gifsq~
`t	XiBig.gifsq~	ptzeta.gifsq~
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Fonts10.gif0000644000175000017500000001205611272077141026137 0ustar  giovannigiovanniGIF89a@,@DߐT"
;^7)	b*j^r	ޑpMlg
%6HC.v3rAþfRb p44doW7uR1G"Gw%(t妸Ui5冢wWtƥi	GJWZgiw
Qi!7{	06FkjcˇM2jܶ-m*}MBs-	-|u.!uf;BUi3HbM"ttP@V5!	"B ALH~d΂/zhTΤyb4Tg5ҬSd˚%,ԝxkk]rHFg?MH\* D5`Ӎ9`f
=.u;\ʜ<auu'?F7t~x9s]nrzA^Gg-ӗGN4$ouщ_o4G/ɁHl9}݁FtWiYirR~G]{7\!V6c8457o5(բecR:"z9iVEKr-)`0BIuNg@dff`frvމgzfGy]	xM.BhQ&ka↢j%((bh裬aw)hAb{Z
puzޣJ5꟒v*AGGmbܘkjx$Ŧ(I4[e/BB
5:-qNOL*XV^Kn2nW2ujd'L+H_$n.`^nnR%6a)5I?[w]ks1S/L[*0k2=*B BZ̦b\9qC?!R	N5Ukwu^bMdg-haMi]k"eaϿ1(-0^lgxCշ.jt+L79+ܱ[w1BJ09&ߊf܄aOjw\̰(V1׀C_k|[ͨOK.W+>|>պC9Â6?+O-q# vlGN#
ߒ2s&uܠCpN!	Op,l9#wB2E4;Ð@lJ5sKo!ǐZk\J'VGud
o[ u-Ṅcߐľ6hGvQe)bPcã9Q8ҎCdL>#ps.O	臁
dk32"zgIj~9`i0q#N)KXdcY5kЖa!AG	"P噬#FWYd9_NʚN<䌥1WtRl;	xs|aη̢96%SRAg["3JT
a&Y7
oh3%J KJ/P$M E>ʣ(KtҴ#)L-a6z]'#Fv;}:GVTF
cZϮxP\
F.$#Xz]X5(&PP6lj=4t*iOԪv[c
 q>r$2ҥ[g(fP#SS;8Qiqf]eJJE14ܩRy$/^*d}{׾e8$5o}ٶL+%׿pU4e-״39{D*%^=7fYW9I11^lҩZKG5q5(?u,9#*<9ٳ4=c!:DeJy㤖E6mhaDb4{t8"}.
/j>uW}rxg0t"e\CMJ@#hfeT]xZy:WkKFFXowz(ekvE=]GBls[If:m+{|,]d~h.yXG>o w:z;5ګ{@Jgx2CnZ3LNl/[P+̩i:TLdQ2OцSr|N:5{!)p_f-p/)9E۹dXn는Mz
r;1[fgÐEӍw+_&0&[	a\z(/25me;53bxg]S.FzAʹpJc7P('THg=`FZG F=&7at{Նz6Fm88}
kFXD(T8v62'O8Ce(I*7ՒyÅ42Mfb`$Ec(eUuԊw Kl]k(w&{ixDR(Xh&GyvoEۈHZxx$ewugG%z8@m%%W:j4IJ)'twW~YB'\	a)cs3Sc;oGA(fNf:D[PqvmR8hh*F+g9e\8ghG9<є]ontz؃c4J=v)%)EG`993)-p"ـhvqdJX[[aoEbI`TEU/H9-7Jaٝ0)/%fع%w(StHO,hbtd)JjXG9e6Ǒ&J{v3^	lvx59e頱)hlVk,(##	
v Ǟ|נQ:i=e6~P
/F#oCZb[X%\x,":IWhph6zV	P^wkj TM):uAi
    JxJ 9Lu3J~
fE*ǦMz%b#-`b%I4fщ7iyjuWQwtG땡ʛXsI`A#[7%~
;T:oG[rK[M[LGkmxؑ}5D<+C.xٚxZe˶qOK}9+tcX>:s~KPF*y>ʦ?ۆ"	%sFXFQ;ڶh˶[Yxq?V+[;}yp8R^N6HZl{@j{'(;V'KB*c K66!bc6RS+KS4|P =q{؛9F{dj⪸>s€)8he9I}WK!覼<<Y~jl$X&du$53z}R?"<†YL{پ
e!sM1It5\7ljB٠YhâYخKy;EMQCุXbvksJd18ڼrcX~et|QEthLȉȭAܞjؑ赗p֒?~D|3R,7Ҳ>n*Ɇ[E9mӣ]ݑ,;}J6rIˊ9+h6yQxIP@oլ|Ǔ|h
̻3e38zHK1d=fi;XZ'M	#0&=̷jK2
?JrC¯5
Tl_ubcҋRӵzlr\FưǺ<)j:;m\g0ܙH1i3j*97Mg">W]e|LJgӋHc;w ;e[ĻXf-*5gYy5l
ٓMٕmٗ]}{:)
<g?93֧ٔ7˓iw~BꔉR(to>U]PS׽kcH}`Զ:x͡TDR
j6;{j{ȺY&
ۅB''N`g|[A懊
~Y
edz}Ll 2QCkNϐ"!^hU@5ldP=k?=81=CFz
qvuuIXۥ;`MzEݰ,{5$2m4
7^[m=wR^P>VHir^naN_FEiͿhяjo
΂-I)N.
aeK֗ZNWK"韞;mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/EqToken.java0000644000175000017500000001377611272077141026441 0ustar  giovannigiovanni/*****************************************************************************
*                                                                            *
*                               T O K E N                                    *
*                                  for                                       *
*                         HotEqn Equation Applet                             *
*                                                                            *
******************************************************************************
*       Liste aller unterst�tzten Token                                      *
*       Token werden vom Scanner erkannt und vom Parser ausgewertet.         *
******************************************************************************

Copyright 2006 Stefan M�ller and Christian Schmid

This file is part of the HotEqn package.

    HotEqn is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; 
    HotEqn is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .

**************   Version 2.0     *********************************************
*        1997 Chr. Schmid, S. Mueller                                        *
*                                                                            *
* 22.12.1997  Separation from HotEqn.java                            (2.00p) * 
* 30.12.1997  new EqToken constructor                                (2.00s) * 
* 31.12.1997  <> Angle new                                           (2.00t) *
* 13.01.1998  new media tracking, cached images                      (2.00z4)* 
* 18.01.1998  Image cache realized by hash table                     (2.01a) *
* 27.10.2002  Package atp introduced                                 (3.12)  * 
**************   Release of Version 4.00 *************************************
* 14.07.2003  Adapted to XPCom. Same as 3.12,only mHotEqn affected    (4.00) *
*                                                                            *
*****************************************************************************/

package org.mathpiper.ui.gui.hoteqn;

class EqToken {
  public  int     typ;      // type of token
  public  String  stringS;  // symbol id
 
  // Tokenliste         | Token         | int   |  Bedeutung
  // -------------------------------------------------------------
  public final static int EOF           =   0;  // End of Equation
  public final static int Id            =   1;  // Variable
  public final static int Num           =   2;  // Numeral            
  public final static int BeginSym      =   3;  // logische Klammer {
  public final static int EndSym        =   4;  // logische Klammer }
  public final static int ANGLE         =   5;  // Klammer < oder >
  public final static int AndSym        =   7;  // &  Trennzeichen (array) 
  public final static int DBackSlash    =   8;  // \\ Trennzeichen (array)
  public final static int FUNC          =   9;  // \sin \cos ... nicht kursiv!!

  public final static int SUP           =  10;  // ^ Hochstellen
  public final static int SUB           =  11;  // _ Tiefstellen
  public final static int FRAC          =  12;  // Bruch
  public final static int SQRT          =  13;  // Wurzel  
  public final static int VEC           =  14;  // Vektor    
  public final static int ARRAY         =  15;  // Vektoren u. Matrizen    
  public final static int LEFT          =  16;  // Left
  public final static int RIGHT         =  17;  // Right
  public final static int SYMBOP        =  18;  // Greek and operational symbols without descents
  public final static int SYMBOPD       =  19;  // Greek and operational symbols with descents
  public final static int SYMBOLBIG     =  20;  // Summe Produkt Integral 
  public final static int ACCENT        =  22;  // Akzente ^~.�`..
  public final static int LIM           =  24;  // Limes
  public final static int SpaceChar     =  25;  // space ' ' 

  public final static int BEGIN         =  50;  // begin{array}   
  public final static int END           =  51;  // end{array}   

  public final static int Null          =  99;  //  Nix (sollte nie erreicht werden)
  public final static int Invalid       = 100;  //  Falsches Zeichen
 
  public final static int Op            = 108;  // <>#~;:,+-*/=! 
  public final static int Paren         = 109;  // ( [ \{ \| | ) ] \} 
  public final static int NOT           = 110;  // negation \not
  public final static int SPACE         = 113;  // additional horizantal space  
  public final static int CHOOSE        = 114;  // { ... \choose ... }  
  public final static int ATOP          = 115;  // { ... \atop ... }  
  public final static int OverLINE      = 116;  // overline{...}  
  public final static int UnderLINE     = 117;  // underline{...}  
  public final static int OverBRACE     = 118;  // overbrace{...}^{...}
  public final static int UnderBRACE    = 119;  // underbrace{...}_{...}
  public final static int STACKREL      = 120;  // stackrel{...}{...}
  public final static int FGColor       = 121;  // \fgcolor  
  public final static int BGColor       = 122;  // \bgcolor 
  public final static int FBOX          = 123;  // \fbox  
  public final static int MBOX          = 124;  // \mbox 


  // Constructor mit Initialisierung
  public  EqToken(int typ, String stringS) {
    this.typ      =  typ; 
    this.stringS  =  stringS;
  } 

  public  EqToken(int typ) {
    this.typ      =  typ; 
    this.stringS  =  "";
  } 

  // Constructor ohne Initialisierung
  public  EqToken() {
    this.typ      =  0; 
    this.stringS  =  "";
  } 
} // end class EqToken 


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Des8.gif0000644000175000017500000001515211272077141025510 0ustar  giovannigiovanniwt	aleph.gifsrjava.awt.RectangleðjjtIheightIwidthIxIyxpt	alpha.gifsq~
t	amalg.gifsq~	
t	angle.gifsq~'t
approx.gifsq~	4tast.gifsq~At	asymp.gifsq~	Ntbeta.gifsq~
[tbigcirc.gifsq~
htbigtriangledown.gifsq~		utbigtriangleup.gifsq~	tbot.gifsq~	t
bowtie.gifsq~
tBox.gifsq~t
bullet.gifsq~tcap.gifsq~tcdot.gifsq~t	cdots.gifsq~
tchi.gifsq~	tcirc.gifsq~tclubsuit.gifsq~
tcong.gifsq~	
tcup.gifsq~t
dagger.gifsq~
't	dashv.gifsq~4tddagger.gifsq~
At	ddots.gifsq~
Nt	delta.gifsq~	[tDeltaBig.gifsq~	htdiamond.gifsq~utDiamondBig.gifsq~	tdiamondsuit.gifsq~
	tdiv.gifsq~	t	doteq.gifsq~	t
downarrow.gifsq~
tDownarrowBig.gifsq~	tell.gifsq~temptyset.gifsq~tepsilon.gifsq~t	equiv.gifsq~	teta.gifsq~*t
exists.gifsq~	*
tflat.gifsq~	*t
forall.gifsq~	*'tFourier.gifsq~*4t	frown.gifsq~
*At	gamma.gifsq~*NtGammaBig.gifsq~	*[tge.gifsq~
	*htgeq.gifsq~
	*utgets.gifsq~*tgg.gifsq~*thbar.gifsq~*t
heartsuit.gifsq~	*thookleftarrow.gifsq~*thookrightarrow.gifsq~*tIm.gifsq~	*t	imath.gifsq~*tin.gifsq~*t	infty.gifsq~*tint.gifsq~
?tiota.gifsq~?
t	jmath.gifsq~?tJoin.gifsq~
?'t	kappa.gifsq~?4t
lambda.gifsq~?At
LambdaBig.gifsq~	?NtLaplace.gifsq~?[t	ldots.gifsq~
?htle.gifsq~
	?utleadsto.gifsq~?t
leftarrow.gifsq~?tLeftarrowBig.gifsq~
?tleftharpoondown.gifsq~?tleftharpoonup.gifsq~?tleftrightarrow.gifsq~?tLeftrightarrowBig.gifsq~	?tleq.gifsq~
	?tlhd.gifsq~?tll.gifsq~?tlongleftarrow.gifsq~TtLongleftarrowBig.gifsq~T
tlongleftrightarrow.gifsq~TtLongleftrightarrowBig.gifsq~T'tlongmapsto.gifsq~T4tlongrightarrow.gifsq~TAtLongrightarrowBig.gifsq~TNt
mapsto.gifsq~T[tmho.gifsq~
Thtmid.gifsq~Tut
models.gifsq~	
Ttmp.gifsq~Ttmu.gifsq~Tt	nabla.gifsq~		Ttnatural.gifsq~
Ttnearrow.gifsq~
Ttneg.gifsq~Ttneq.gifsq~
Ttni.gifsq~Ttnu.gifsq~Ttnwarrow.gifsq~
itodot.gifsq~	i
toint.gifsq~
it	omega.gifsq~i'tOmegaBig.gifsq~
i4t
ominus.gifsq~	iAt	oplus.gifsq~	iNt
oslash.gifsq~	i[t
otimes.gifsq~	ihtparallel.gifsq~
	iutpartial.gifsq~itperp.gifsq~	itphi.gifsq~
it
PhiBig.gifsq~itpi.gifsq~it	PiBig.gifsq~	
itpm.gifsq~itprec.gifsq~	it
preceq.gifsq~
	it	prime.gifsq~itprod.gifsq~

~t
propto.gifsq~~
tpsi.gifsq~
~t
PsiBig.gifsq~~'tRe.gifsq~
~4trhd.gifsq~~Atrho.gifsq~~Ntrightarrow.gifsq~~[tRightarrowBig.gifsq~
~htrightharpoondown.gifsq~~utrightharpoonup.gifsq~~trightleftharpoons.gifsq~~tsearrow.gifsq~
~tsetminus.gifsq~~t	sharp.gifsq~
~t	sigma.gifsq~~tSigmaBig.gifsq~	~tsim.gifsq~	~t	simeq.gifsq~	~t	smile.gifsq~
~t
spadesuit.gifsq~
	t	sqcap.gifsq~	
t	sqcup.gifsq~	tsqsubset.gifsq~
'tsqsubseteq.gifsq~

4tsqsupset.gifsq~
Atsqsupseteq.gifsq~

Ntstar.gifsq~[t
subset.gifsq~	htsubseteq.gifsq~
	utsucc.gifsq~	t
succeq.gifsq~
	tsum.gifsq~
t
supset.gifsq~	tsupseteq.gifsq~
	tswarrow.gifsq~
ttau.gifsq~t	theta.gifsq~tThetaBig.gifsq~t	times.gifsq~tto.gifsq~ttop.gifsq~	
ttriangle.gifsq~	ttriangleleft.gifsq~'ttriangleright.gifsq~4t	unlhd.gifsq~At	unrhd.gifsq~Ntuparrow.gifsq~
[tUparrowBig.gifsq~	htupdownarrow.gifsq~utUpdownarrowBig.gifsq~
t	uplus.gifsq~tupsilon.gifsq~tUpsilonBig.gifsq~tvarepsilon.gifsq~t
varphi.gifsq~t	varpi.gifsq~
t
varrho.gifsq~tvarsigma.gifsq~tvartheta.gifsq~t	vdash.gifsq~t	vdots.gifsq~
tvee.gifsq~t	wedge.gifsq~'twp.gifsq~	4twr.gifsq~
Atxi.gifsq~
Nt	XiBig.gifsq~		[tzeta.gifsq~
hmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Des14.gif0000644000175000017500000001515211272077141025565 0ustar  giovannigiovanniwt	aleph.gifsrjava.awt.RectangleðjjtIheightIwidthIxIyxpt	alpha.gifsq~	t	amalg.gifsq~.t	angle.gifsq~Et
approx.gifsq~\tast.gifsq~st	asymp.gifsq~tbeta.gifsq~tbigcirc.gifsq~tbigtriangledown.gifsq~tbigtriangleup.gifsq~tbot.gifsq~
t
bowtie.gifsq~tBox.gifsq~+t
bullet.gifsq~	Btcap.gifsq~Ytcdot.gifsq~pt	cdots.gifsq~tchi.gifsq~

tcirc.gifsq~	tclubsuit.gifsq~'tcong.gifsq~'tcup.gifsq~'.t
dagger.gifsq~'Et	dashv.gifsq~'\tddagger.gifsq~'st	ddots.gifsq~'t	delta.gifsq~
'tDeltaBig.gifsq~'tdiamond.gifsq~

'tDiamondBig.gifsq~'tdiamondsuit.gifsq~'tdiv.gifsq~'t	doteq.gifsq~'+t
downarrow.gifsq~
'BtDownarrowBig.gifsq~'Ytell.gifsq~'ptemptyset.gifsq~

'tepsilon.gifsq~		't	equiv.gifsq~'teta.gifsq~
Nt
exists.gifsq~Ntflat.gifsq~	N.t
forall.gifsq~NEtFourier.gifsq~N\t	frown.gifsq~Nst	gamma.gifsq~
NtGammaBig.gifsq~Ntge.gifsq~Ntgeq.gifsq~Ntgets.gifsq~Ntgg.gifsq~
Nthbar.gifsq~Nt
heartsuit.gifsq~N+thookleftarrow.gifsq~NBthookrightarrow.gifsq~NYtIm.gifsq~Npt	imath.gifsq~	Ntin.gifsq~Nt	infty.gifsq~Ntint.gifsq~utiota.gifsq~	ut	jmath.gifsq~
u.tJoin.gifsq~uEt	kappa.gifsq~	u\t
lambda.gifsq~ust
LambdaBig.gifsq~
utLaplace.gifsq~ut	ldots.gifsq~utle.gifsq~utleadsto.gifsq~
ut
leftarrow.gifsq~utLeftarrowBig.gifsq~utleftharpoondown.gifsq~u+tleftharpoonup.gifsq~uBtleftrightarrow.gifsq~uYtLeftrightarrowBig.gifsq~uptleq.gifsq~utlhd.gifsq~utll.gifsq~
utlongleftarrow.gifsq~&tLongleftarrowBig.gifsq~%tlongleftrightarrow.gifsq~&.tLongleftrightarrowBig.gifsq~$Etlongmapsto.gifsq~'\tlongrightarrow.gifsq~&stLongrightarrowBig.gifsq~%t
mapsto.gifsq~tmho.gifsq~tmid.gifsq~	t
models.gifsq~tmp.gifsq~tmu.gifsq~
t	nabla.gifsq~+tnatural.gifsq~	Btnearrow.gifsq~Ytneg.gifsq~ptneq.gifsq~tni.gifsq~tnu.gifsq~	tnwarrow.gifsq~todot.gifsq~
toint.gifsq~.t	omega.gifsq~	EtOmegaBig.gifsq~\t
ominus.gifsq~
st	oplus.gifsq~
t
oslash.gifsq~
t
otimes.gifsq~
tparallel.gifsq~
tpartial.gifsq~tperp.gifsq~
tphi.gifsq~t
PhiBig.gifsq~+tpi.gifsq~	Bt	PiBig.gifsq~Ytpm.gifsq~ptprec.gifsq~t
preceq.gifsq~t	prime.gifsq~
tprod.gifsq~t
propto.gifsq~tpsi.gifsq~.t
PsiBig.gifsq~EtRe.gifsq~\trhd.gifsq~strho.gifsq~
trightarrow.gifsq~tRightarrowBig.gifsq~trightharpoondown.gifsq~trightharpoonup.gifsq~trightleftharpoons.gifsq~tsearrow.gifsq~tsetminus.gifsq~+t	sharp.gifsq~	Bt	sigma.gifsq~	
YtSigmaBig.gifsq~ptsim.gifsq~t	simeq.gifsq~
t	smile.gifsq~t
spadesuit.gifsq~t	sqcap.gifsq~
t	sqcup.gifsq~
.tsqsubset.gifsq~Etsqsubseteq.gifsq~\tsqsupset.gifsq~stsqsupseteq.gifsq~tstar.gifsq~t
subset.gifsq~tsubseteq.gifsq~tsucc.gifsq~t
succeq.gifsq~tsum.gifsq~t
supset.gifsq~+tsupseteq.gifsq~Btswarrow.gifsq~Yttau.gifsq~	
pt	theta.gifsq~tThetaBig.gifsq~t	times.gifsq~

tto.gifsq~8ttop.gifsq~8ttriangle.gifsq~8.ttriangleleft.gifsq~8Ettriangleright.gifsq~8\t	unlhd.gifsq~8st	unrhd.gifsq~8tuparrow.gifsq~
8tUparrowBig.gifsq~8tupdownarrow.gifsq~
8tUpdownarrowBig.gifsq~8t	uplus.gifsq~8tupsilon.gifsq~	8tUpsilonBig.gifsq~8+tvarepsilon.gifsq~	
8Bt
varphi.gifsq~
8Yt	varpi.gifsq~	8pt
varrho.gifsq~
8tvarsigma.gifsq~
8tvartheta.gifsq~8t	vdash.gifsq~_t	vdots.gifsq~
_tvee.gifsq~_.t	wedge.gifsq~_Etwp.gifsq~
_\twr.gifsq~_stxi.gifsq~
_t	XiBig.gifsq~
_tzeta.gifsq~_mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/EqScanner.java0000644000175000017500000006401211335460653026743 0ustar  giovannigiovanni/*****************************************************************************
*                                                                            *
*                             S C A N N E R                                  *
*                                  for                                       *
*                         HotEqn Equation Applet                             *
*                                                                            *
******************************************************************************
*    Die Klasse "EqScanner" stellt Methoden zur Erkennung                    *
*    der Elemente (Token) in einer equation zur Verf�gung.                  *
******************************************************************************

Copyright 2006 Stefan M�ller and Christian Schmid

This file is part of the HotEqn package.

    HotEqn is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; 
    HotEqn is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .

******************************************************************************
* Methoden:                                                                  *
*       EqToken    nextToken()      next Token                           *
*       boolean    EoT()            true, if Tokenende achieved              *
*       void       start()          countT=-1: Scanner reset, but            *
*                                   not rescan.                              *
*       int        get_count()      value "countT" (for recursive Token)     *
*       void       set_count(int)   calls init() and jumps up countT=int     *
*       void       setEquation(eq)  eq scan and in TokenV store              *
*                                                                            *
* Methoden (intern):                                                         *
*       EqToken    ScanNextToken() next Token out equations string        *
*       char       getChar()      current char                             *
*       void       advance()      eine Stelle weiterschalten                 *
*                                                                            *
**************   Version 2.0     *********************************************
*        1997,1998 Chr. Schmid, S. Mueller                                   *
*                                                                            *
* 22.12.1997  Separation from HotEqn.java                            (2.00p) * 
* 22.12.1997  \choose \atop                                                  *
* 23.12.1997  overline underline overbrace underbrace stackrel begin end     *
* 30.12.1997  \choose mapped to \atop + ()                           (2.00s) *
*             setEquation, ScanInit combined                                 *
* 31.12.1997  <> Angle new                                           (2.00t) * 
* 01.01.1998  Tokens stored dynamically (limit 500 tokens removed)   (2.00v) * 
* 08.01.1998  Rearranged and new symbols                             (2.00z1)* 
* 13.01.1998  new media tracking, cached images, get/set_img neu     (2.00z4)*
*             Symbols and greek symbols scanning reorganized                 *
* 18.01.1998  Image cache realized by hash table                     (2.01a) *
*             get_img and set_img removed                                    *
* 27.02.1998  \sqrt[ ]{}                                             (2.01c) *
* 03.05.1998  bug: if \ is last char --> StringIndexOutOfBoundsExc.. (2.02a) *
*             line 335: additional EOF-checking                              *
* 21.05.1998  getSelectedArea(count1,count2) return the selected part(2.03)  *
* 27.10.2002  Package atp introduced                                 (3.12)  * 
**************   Release of Version 4.00 *************************************
* 14.07.2003  Adapted to XPCom. Same as 3.12,only mHotEqn affected   (4.00)  *
* 14.09.2006  \sech and \csch added                                  (4.02)  *
*                                                                            *
*****************************************************************************/

package org.mathpiper.ui.gui.hoteqn;

//package bHotEqn;

//import atp.*;
import java.util.*;

class EqScanner {
   private String    equation;                           // equation than String
   private int       count;                              // Character Position
   private int       countT;                             // Token Position
   private EqToken   token;                              // Momentary Token
   private boolean   EOF              = false;           // File end Variable
   //public  boolean inScanPaint      = false;           // Scan  semaphore
   private Vector    TokenV = new Vector (50,50);        // dynamic Vector with alln Tokens
   private boolean   selectB          = false;           // find selected area
   private boolean   collectB         = false;
   private int       selectCount1     = 0;
   private int       selectCount2     = 0;
   private StringBuffer selectSB      = new StringBuffer("");

public EqScanner(String equation) {
   // Constructor
   token         = new EqToken(EqToken.Null);
   setEquation(equation);
}

public String getSelectedArea(int count1, int count2) {
   // return the mouse-selected part of the equation as a LaTeX-string

   selectCount1 = Math.min(count1, count2);
   selectCount2 = Math.max(count1, count2);
   selectB      = true;
   selectSB     = new StringBuffer("");

   setEquation(this.equation);  // New scan, strike ends.

   selectB      = false;
   return selectSB.toString();
}

public void setEquation(String equation) {
   //if (inScanPaint)  return; // Semaphore
   //inScanPaint=true;
   // To share the equation
   this.equation = equation;

   // Scanner back space und EINmal equation scannen.
   // Tokens in TokenV store

   int i             = 0;
   int ii            = 0;
   int countBeginEnd = 0;

   EOF       = false;
   countT    = -1;
   count     = -1;
   TokenV.removeAllElements();  // all remove the old token.
   advance();                   // empty eauation intercept.
   while (!EOF) {
      countT ++;
      if (selectB && (countT == selectCount1 )) collectB=true;
      TokenV.addElement(ScanNextToken());
      if (selectB && (countT == selectCount2 )) collectB=false;
      //System.out.println("scanNextToken "+((EqToken)TokenV.lastElement()).stringS);
   }
   countT = -1;

   // Eliminate language conflicts:
   // { ... \choose ... } --> \choose{ ... }{ ... }
   // { ... \atop ... }   --> \atop{ ... }{ ... }
   while ( i < TokenV.size() ) {   
      if (((EqToken)TokenV.elementAt(i)).typ == EqToken.CHOOSE){

          // single { search
          ii            = i-1; 
          countBeginEnd = 0;
          while ( ii>0 ) {
             if ( ((EqToken)TokenV.elementAt(ii)).typ == EqToken.EndSym )        countBeginEnd--;
             else if ( ((EqToken)TokenV.elementAt(ii)).typ == EqToken.BeginSym ) countBeginEnd++;
             if ( countBeginEnd == 1 ) break; 
             ii--;
          } // end while ii

          // single } search
          int jj        = i+1;
          countBeginEnd = 0;
          while ( jj < TokenV.size() ) {
             if ( ((EqToken)TokenV.elementAt(jj)).typ == EqToken.EndSym )        countBeginEnd++;
             else if ( ((EqToken)TokenV.elementAt(jj)).typ == EqToken.BeginSym ) countBeginEnd--;
             if ( countBeginEnd == 1 ) break; 
             jj++;
          } // end while jj
          if ((countBeginEnd == 1) && (ii >=0)) {
 
             // right bracket ) insert
             TokenV.insertElementAt(new EqToken(EqToken.Paren,")"),jj+1);
             TokenV.insertElementAt(new EqToken(EqToken.RIGHT),jj+1);

             // at \choose }{ insert
             TokenV.setElementAt(new EqToken(EqToken.EndSym),i);
             TokenV.insertElementAt(new EqToken(EqToken.BeginSym),i+1);

             // \atop einsetzen mit bracket (
             TokenV.insertElementAt(new EqToken(EqToken.ATOP),ii);
             TokenV.insertElementAt(new EqToken(EqToken.Paren,"("),ii);
             TokenV.insertElementAt(new EqToken(EqToken.LEFT),ii);

             i +=4; // 4 Token nach rechts ger�ckt

         } // end if

      } // end if \choose
      else if ( ((EqToken)TokenV.elementAt(i)).typ == EqToken.ATOP ){

          // single { search
          ii            = i-1; 
          countBeginEnd = 0;
          while ( ii>0 ) {
             if ( ((EqToken)TokenV.elementAt(ii)).typ == EqToken.EndSym )        countBeginEnd--;
             else if ( ((EqToken)TokenV.elementAt(ii)).typ == EqToken.BeginSym ) countBeginEnd++;
             if ( countBeginEnd == 1 ) break; 
             ii--;
          } // end while ii
          if ( ii >= 0 ) {

             // at \atop }{ insert
             TokenV.setElementAt(new EqToken(EqToken.EndSym),i);
             TokenV.insertElementAt(new EqToken(EqToken.BeginSym),i+1);

             // \atop copy to new location
             TokenV.insertElementAt(new EqToken(EqToken.ATOP),ii);
             i +=2; // 2 Token nach rechts ger�ckt

         } // end if

      } // end if \atop

      i++;
   } // end while i

   // Eliminate language conflicts:
   // \sqrt[ ... ]{ ... } --> \sqrt[ ... }{ ... }
   i = 0;
   while ( i < TokenV.size()-2 ) {   
      if (((EqToken)TokenV.elementAt(i)).typ == EqToken.SQRT){
          if (((EqToken)TokenV.elementAt(i+1)).typ == EqToken.Paren) {
             ii             = i+2;  
             countBeginEnd  = 0;
             int countParen = 1;
             while ( ii= TokenV.size() ) {
      countT = TokenV.size()-1;
      return new EqToken(EqToken.Null);
   }
   else {
      return (EqToken)TokenV.elementAt(countT);
   }
} // end nextToken

public boolean EoT() {
   // True if End Of Tokens
   return countT == TokenV.size()-1;
} // end EoT

private char getChar() {
   return equation.charAt(count);  
} // end nextChar

private void advance() {
   if (collectB) selectSB.append(equation.charAt(count));
   if (count < equation.length()-1) {
          count++;
          EOF = false;}
   else { count = equation.length();
          EOF   = true;}
} // end advance

private EqToken ScanNextToken() {
  // Determination of next Tokens
  // Token are separated by delimiters.
  StringBuffer SBuffer = new StringBuffer("");
  String       SBufferString = new String("");
  EqToken      SlashToken = new EqToken();
  char         eqchar;
  boolean      tag     = false; // alround Boolean  
 
  while (!EOF) {
      eqchar = getChar(); // current Char out Equation
      switch (eqchar) {
      case '\n':
      case '\r':
      case '\t': advance();
                 break;
      case ' ': advance();           
                return new EqToken(EqToken.SpaceChar,new String(" "));
      case '+': case '-': case '*': case '/':
      case '=': case '<': case '>': case '#':
      case '~': case ';': case ':': case ',':
      case '!': advance();
                return new EqToken(EqToken.Op,String.valueOf(eqchar));
      case '{': advance();
                return new EqToken(EqToken.BeginSym);
      case '}': advance();
                return new EqToken(EqToken.EndSym);
      case '[': 
      case ']': 
      case '(': 
      case ')': 
      case '|': advance();
                return new EqToken(EqToken.Paren,String.valueOf(eqchar));
      case '&': advance();
                return new EqToken(EqToken.AndSym);

      case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': 
      case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': 
      case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
      case 'v': case 'w': case 'x': case 'y': case 'z':
      case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': 
      case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': 
      case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': 
      case 'V': case 'W': case 'X': case 'Y': case 'Z': case '\'': case'@':
              SBuffer.append(eqchar);
              advance();
              tag = false;
              while (!EOF && !tag) {
                 eqchar = getChar();
                 switch (eqchar) {
                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': 
                 case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
                 case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': 
                 case 's': case 't': case 'u': case 'v': case 'w': case 'x':
                 case 'y': case 'z':
                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 
                 case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
                 case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
                 case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
                 case 'Y': case 'Z': case '\'': case'@':
                    SBuffer.append(eqchar);
                    advance();
                    break;
                 default: 
                    tag = true;
                    break;     
                 }
              }
              return new EqToken(EqToken.Id,SBuffer.toString());

      case '0': case '1': case '2': case '3': case '4': case '5': case '6':
      case '7': case '8': case '9': case '.':
              SBuffer.append(eqchar);
              advance();
              tag = false;
              while (!EOF && !tag) {
                 eqchar = getChar();
                 switch (eqchar) {
                 case '0': case '1': case '2': case '3': case '4': case '5': 
                 case '6': case '7': case '8': case '9': case '.':
                    SBuffer.append(eqchar);
                    advance();
                    break;
                 default: 
                    tag = true;
                    break;     
                 }
              }
              return new EqToken(EqToken.Num,SBuffer.toString());

      case '\\':
      // /////////////////////////////////////
      // all Token with BACKSLASH begin
      // It is always \command  (in command are only letters)
      advance();
      tag = false;
      if (EOF) break;
      eqchar = getChar();
         switch (eqchar) {
         case '\\': advance();
                    return new EqToken(EqToken.DBackSlash);
         case '{': advance();
                   return new EqToken(EqToken.Paren,String.valueOf(eqchar));
         case '|': advance();
                   return new EqToken(EqToken.Paren,"||");
         case '}': advance();
                   return new EqToken(EqToken.Paren,String.valueOf(eqchar));
         case ',': advance();
                   return new EqToken(EqToken.SPACE,"3");
         case ':': advance();
                   return new EqToken(EqToken.SPACE,"4");
         case ';': advance();
                   return new EqToken(EqToken.SPACE,"5");
         case '!': advance();
                   return new EqToken(EqToken.SPACE,"-3");

         case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': 
         case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': 
         case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
         case 'v': case 'w': case 'x': case 'y': case 'z':
         case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': 
         case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': 
         case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': 
         case 'V': case 'W': case 'X': case 'Y': case 'Z': 
              SBuffer.append(eqchar);
              advance();
              tag = false;
              while (!EOF && !tag) {
                 eqchar = getChar();
                 switch (eqchar) {
                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': 
                 case 'g': case 'h': case 'i': case 'j': case 'k': case 'l':
                 case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': 
                 case 's': case 't': case 'u': case 'v': case 'w': case 'x':
                 case 'y': case 'z':
                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': 
                 case 'G': case 'H': case 'I': case 'J': case 'K': case 'L':
                 case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R':
                 case 'S': case 'T': case 'U': case 'V': case 'W': case 'X':
                 case 'Y': case 'Z': 
                    SBuffer.append(eqchar);
                    advance();
                    break;
                 default: 
                    tag = true;
                    break;     
                 }
              }
             SBufferString=SBuffer.toString();
             if (SBufferString.equals("acute"))
                  return new EqToken(EqToken.ACCENT,"�"); 
             if (SBufferString.equals("array"))
                   return new EqToken(EqToken.ARRAY);
             if (SBufferString.equals("bar"))
                   return new EqToken(EqToken.VEC,"bar"); 
             if (SBufferString.equals("ddot"))
                   return new EqToken(EqToken.ACCENT,".."); 
             if (SBufferString.equals("dot"))
                   return new EqToken(EqToken.ACCENT,".");
             if (SBufferString.equals("frac"))
                   return new EqToken(EqToken.FRAC);
             if (SBufferString.equals("grave"))
                   return new EqToken(EqToken.ACCENT,"`"); 
             if (SBufferString.equals("hat"))
                   return new EqToken(EqToken.ACCENT,"^"); 
             if (SBufferString.equals("int"))
                   return new EqToken(EqToken.SYMBOLBIG,"int");
             if (SBufferString.equals("oint"))
                   return new EqToken(EqToken.SYMBOLBIG,"oint");
             if (SBufferString.equals("left"))
                   return new EqToken(EqToken.LEFT);
             if (SBufferString.equals("limsup"))
                   return new EqToken(EqToken.LIM,"lim sup");
             if (SBufferString.equals("liminf"))
                   return new EqToken(EqToken.LIM,"lim inf");
             if (SBufferString.equals("prod"))
                   return new EqToken(EqToken.SYMBOLBIG,"prod");
             if (SBufferString.equals("right"))
                   return new EqToken(EqToken.RIGHT);
             if (SBufferString.equals("sqrt"))
                   return new EqToken(EqToken.SQRT);
             if (SBufferString.equals("sum"))
                   return new EqToken(EqToken.SYMBOLBIG,"sum"); 
             if (SBufferString.equals("tilde"))
                   return new EqToken(EqToken.ACCENT,"~");
             if (SBufferString.equals("vec"))
                   return new EqToken(EqToken.VEC);
             if (SBufferString.equals("widehat"))
                   return new EqToken(EqToken.VEC,"widehat");
             if (SBufferString.equals("widetilde"))
                   return new EqToken(EqToken.VEC,"widetilde");
             if (SBufferString.equals("quad"))
                   return new EqToken(EqToken.SPACE,"18");
             if (SBufferString.equals("qquad"))
                   return new EqToken(EqToken.SPACE,"36");
             if (SBufferString.equals("backslash"))
                   return new EqToken(EqToken.Num,"\\");
             if (SBufferString.equals("langle"))
                   return new EqToken(EqToken.ANGLE,"<");
             if (SBufferString.equals("rangle"))
                   return new EqToken(EqToken.ANGLE,">");

             if (SBufferString.equals("not"))
                   return new EqToken(EqToken.NOT);                 

             if (SBufferString.equals("atop"))
                   return new EqToken(EqToken.ATOP);
             if (SBufferString.equals("choose"))
                   return new EqToken(EqToken.CHOOSE);

             if (SBufferString.equals("overline"))
                   return new EqToken(EqToken.OverLINE);
             if (SBufferString.equals("underline"))
                   return new EqToken(EqToken.UnderLINE);

             if (SBufferString.equals("overbrace"))
                   return new EqToken(EqToken.OverBRACE);
             if (SBufferString.equals("underbrace"))
                   return new EqToken(EqToken.UnderBRACE);

             if (SBufferString.equals("stackrel"))
                   return new EqToken(EqToken.STACKREL);

             if (SBufferString.equals("begin"))
                   return new EqToken(EqToken.BEGIN);
             if (SBufferString.equals("end"))
                   return new EqToken(EqToken.END);

             if (SBufferString.equals("fgcolor"))
                   return new EqToken(EqToken.FGColor);
             if (SBufferString.equals("bgcolor"))
                   return new EqToken(EqToken.BGColor);

             if (SBufferString.equals("fbox"))
                   return new EqToken(EqToken.FBOX);
             if (SBufferString.equals("mbox"))
                   return new EqToken(EqToken.MBOX);

             if (" arccos arcsin arctan arg cos cosh cot coth csc csch def deg dim exp hom ker lg ln log sec sech sin sinh tan tanh "
                .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.FUNC,SBufferString);
             if (" det gcd inf lim max min Pr sup "
                .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.LIM,SBufferString);

             if ((" alpha delta epsilon iota kappa lambda nu omega pi sigma theta tau upsilon varepsilon varpi vartheta"
                 +" pm mp times div cdot cdots ldots ast star amalg cap cup uplus sqcap sqcup vee wedge wr circ bullet diamond lhd rhd oslash odot Box bigtriangleup triangleleft triangleright oplus ominus otimes"
                 +" ll subset sqsubset in vdash models gg supset sqsupset ni dashv perp neq doteq approx cong equiv propto prec sim simeq asymp smile frown bowtie succ"
                 +" aleph forall hbar exists imath neg flat ell Re angle Im backslash mho Box prime emptyset triangle nabla partial top bot Join infty vdash dashv"
                 +" Fourier Laplace leftarrow gets hookrightarrow leftharpoondown rightarrow to rightharpoondown leadsto leftrightarrow mapsto hookleftarrow leftharpoonup rightharpoonup rightleftharpoons longleftarrow longrightarrow longleftrightarrow longmapsto ")
                 .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.SYMBOP,SBufferString);

             if ((" beta chi eta gamma mu psi phi rho varrho varsigma varphi xi zeta"
                 +" le leq ge geq vdots ddots natural jmath bigtriangledown sharp uparrow downarrow updownarrow nearrow searrow swarrow nwarrow succeq mid preceq paralll subseteq sqsubseteq supseteq sqsupseteq clubsuit diamondsuit heartsuit spaofuit wp dagger ddagger setminus unlhd unrhd bigcirc ")
                 .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.SYMBOPD,SBufferString);

             if ((" Delta Gamma Lambda Omega Pi Phi Psi Sigma Theta Upsilon Xi"
                 +" Leftarrow Rightarrow Leftrightarrow Longleftarrow Longrightarrow Longleftrightarrow Diamond ")
                 .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.SYMBOP,SBufferString+"Big");

             if ((" Uparrow Downarrow Updownarrow ")
                 .indexOf(" "+SBufferString+" ")>=0) return new EqToken(EqToken.SYMBOPD,SBufferString+"Big");
 
         default :
                   tag = true;
                   advance();
                   System.out.println("Scanner invalid tag: \\"+SBuffer.toString());
                   return new EqToken(EqToken.Invalid);
         } // end switch \command (all backslash commands)

         
      case '^': advance();
                return new EqToken(EqToken.SUP);
      case '_': advance();
                return new EqToken(EqToken.SUB);
      default:  advance();
                System.out.println("Scanner invalid character: "+eqchar);
                return new EqToken(EqToken.Invalid);
      } // end switch
   } // end while
   return new EqToken(EqToken.Null);
} // end ScanNextToken


} // end class EqScanner

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Fonts18.gif0000644000175000017500000003105311272077141026145 0ustar  giovannigiovanniGIF89aD,Dc 42l|p֠.eLם`»d %>R4-eTU/	!mDĞIS.Kh[>Egrr7UX3eŨVI8W9#7s٧idhY`'Wy+1$	z\KDzZܜskKe;ܘ$>
z]:99[pq"w{@H/h뭓6&#e}wn{jp5_5?̷\}ER}hܵw4ZYm~B4g8W2ih-tոnU^R*^¢z)砓R'E>xlK"hWN颈&cRH_Ԛ&M8d\樥+&ID)'suh!g]jhmn(z{F
أ EOzzi2tꏓ>SiJ]DJ&˟ź[
K(>fc@QR*O ;۰T>#GӒގLbcf-n+HbI}Kps:pOlŸJlGV*r̎jD0!r	R˩Ɵ2ߌa
3QKB1tK4?tN?.CMuՑ벼e/ʊy:R#;5/UiB/{iwXV-b Ol1-]$[Aީdgj拇<{}F8{r~ٷs5ۘ3'
g^FG;^7}ĵ. dj#\QEC<5AW7jD9i0z3J,ߠV@gP*剰#saC;.'>1m1Xn\m^$c)MKKTc=աu'>zWS%[
r%{#NW*֩!!O0TeX6F6^geJnՃӍ9ȤfBZbbg
jMgnYFM-h$!*.e\IL$XVF"VXE ղS"ro^7Lyw8]%Ü/Wk"Pw.Z*X͕&r+7~v/35Qbb]/TfK/L>2KZ{?أLL3xm{&l\îⱓ鸙;X9fo9\/$Yl-MƑ24%q
rxN,V0;AIVr?c[0zOYˊګzw\:ڷ-	lhl[RSbvI5]N`{XhZu_z4YKoXet5Z?k2s*lZ/SE9.vхխ{(&VنP5dlVEUɬ>/oӻX7?p3{78OP,8o=<9@t
#i.+_w1|5e{d,'ċBNc#Tڃ:Lڍ~_<BFoe1lWi7{'$s
fXtBbj'e%}q)Q+wKhdzt`=5|Ft'Bo[Jb}?6msUrGlgw6Sh/K3Sh(>#,h税>Վ(Hhȏ)7'-CedM~2\xvq*|TdK#3Avjb&V	X8xSni($I&X9b0+FuvU&pBV4[LJҵAxc.y#EYmEK?Zva		BkgiV&X>0hBP62ckH{pX['
d-pH5d
ɋMLvi_GqF8K^Z"w)7X]8	bh.IdHŨ'`gHRtnDNp- EﴙgZu鐥m6/Y]?IJ$|∵Kf@j(vHLtEYɹIJspaVLśQLnz	$r=tzPHu:F%W(a9{e+苏	Z^O2.yDQh%GZuan%Jyh%FY3W.XFX_%uh2n-Zi4x8tfeNT99G)?nrmHԷ5cQ9sV*i9}wRzSlBGI0ƧDQ1POu4ᨑK)2jʩ꩟
*Jj${VըMʜ؟38^;j:4JQF2f誶)ڱ'	:"gTYjL¬ׂ7X:<*fh;IȚ@9f7RvEx(ʌV
#ş
c#jz8dgX)w*ְDg4WF]37f$tzwWxT/U1e
K4gyq{#⮭J[93(yن=1xFT+){I.-ʰ^k4MOk]ӺٺMB\y7K9+)tzf{PA
#V%*nIKTUZmh;7y
znԚxPioz>Y%b۶X[NwĴ>:WXJlJ-zHnk+`]*=5yaڢ鰾[291QOGKer*	Q,SKbg!,#L%l')ɯh	EG	[aع@G5Aw{Lry:Q;xi2xmR_i4'D5
TjTf\Br@øThEBzbܺTb9:=\+oy>.'Zq˻ehW}K̖LR6֐ZN	=tkR\ܽyz^Ch,*jJ:Û|˚~H8q-L)b˴:Ī̙jʬC<#,,;8qlFRi,ZGZZ\Β;| ~4΁hJV	8|ܩZ\ɶ
9LϦ,vyEdF2 cܚW\
Њe+:zg*tZ+&]SyVY_ 0+[ӯG4fT,zܺS՘MLWR)ByLBn	tN^j茌L=N^MʶK
^qo@PG6?;զ,"z?U0ȕ.Ni;ݕ-OҾyfB=n=ԝPLEV'.08Ms?5UKM/0-cmYS[2]9+#cSekmoq/sO%lUMBg-4iil(͆)+epl^Ҟ15_ZW)ԔW7__lDk)J~ό5rZ.W	gjLᴏѵA&ڙ̘x:2
vj"loWn¾=ܻk7¶K|O@ˇJE!Qa1{jwP,փu3iddn2Fd%KrYmE{mu0iY

tmm/5|N^.ИSMl06q#&C3y
UE_P]."k']ZOmVO
KL?yM`H}v +yYs%QYi4ő-/S=[	dǨkmWi wG5yVkx>]Td,=|Yv3GzSyRl+E؋%t GrO=
O]0Tzikn25~y+j9ym1qS>=v1^e;?}]`ӏ{qw=/|_(r	tl@	zNsgN &	Ng4'{cA*o
qC=
@)hoe2جm	72QwNw"B3[ .2b*KXؘ O^"lhFoQcC80q#˝HE>vyٽ󕑐@*@-JQD1fR:,G"}&yD	J><3I6v``<9PżfJ-II57ǽIfiڹ^2xP槆QR\ƜiNB%AJǎn#ekOC3D%y*zs7H7j):'ѕJ w%%ZD&9FhH[,^D5Q
U`OT]ZLj_+K᫦3seD!zđ/zTvW7%*)ZyԀ1$Uy,S_j[
\;+-փ]S@J_bul,16*]N麔W51J&(,iRYqeecVGe|ërI.q[UbV.O:ƥyxћ^PzU{;}jڠ◿E0_xt#y4
vp|O8Y$1a
o	dofD6!/BAF.Gp{^ԑP(c0{⨑°}Suw,ǭ_5_>;@;rm6.f[{LX\Ljg*1PAqvOcjE9:]	1v)b8$'ݻ0w5v|-eRM㪠aOfEJb+Tf1}~@]+?s;xMFla&vv֭ѫs:Jtִj1J
/V}֤KZȃ6sv7Φ{-iN֝Trg<cl+CVƅD3kl678Iid:-bFz/qāj`úܙ8^\xIS:\FGKꝿ fx*/:֎lw4ypyۡ/:ң[tqGa:'{+/jMr.y4ǧ.ZE*C<2Ӝ;]yƱ&p:p1gᪧ$Õ،`u:_?^;5ԃg[vryR7|/w}O{c-R@py6UMt~ByqTڗq}IEOyvll
 >W؏fMO@/Z-qPlmdOjΊsϔJah"0o@N#PςP6Ok.&KmI20
2I..#zP.7(
	
BK
m.G05>OLpP
0
hNࢠP	7@M*
Je?41Cd$HptKސ(͸!EӶb.=jPq+*W|q	9qMf
upqrʒpkoƑ1ߑD
o['DO	уU'(O2zqH}v#Kim0"=U2&n$ї&g̕
ѺAњ@(%#χЩ ..(,\ol 0)SBpH2*}r1.o.#$?PR//JK0dF0!12%11g,3&(2=s4[D4Qsn&S5NJ.L|<~mz@\Rh8
*"ol#a28sNS3Sw1zp;:Rp+R3C	/
*3qJ>H%:wH2!	30>f>RWA`sPDN
TE
T'GDzzO>-O	A
몟$
/=u;K</#T,Q$QHKC8HIӓMFtE/t?4;BLS4rMs9"OjwNפ%CJ
OPPdzy@
=cOmS2ʐO5NREaB6@;>-%SOMUa5{VjRs5AϝR.nM,ԯT隇ўTREt4S͛@
PPU;Xm\EU}5Kɓ]i,}5^0X^#U9)A\^ECa
6b-$bUo,6c.4c%c=6d[EdIdM6eUe]eao
ZNg
N7y*Y`wf9f3ErVeOkthhkn6H':0r3GōgYNjeji	kN@լjo
rqj!o8rZ]-#i)hoVXhFE3OukE=n6'^mUM')5.7nln9&s6w%@iG7fƔvktV
vm_@vsq6{{3NSzz7Wlv%|PvzEymKWUO}x_j|jwW^386wu}mJӴ:[+egG7--8=7I.MLQa79u^jCwk3giuMCq/Wk$BUyoBǴ+oW/:I]%`w5X˸uW8
&ֈS{KYcUXi;Ϗ?e5x8a8Yc195y9=A964/[5j
v
0a!kg[ihA0Dh)Cs'5:X)Y(ys"C
YYW4;j:5#tSpo[OVK\Z$3r
,5[Ĺԙ[\ιKƞGAnMZJ:IeNw*9}
կ+6!Eb׍c/'k9~O_MS"8_y1!d	WUەpwP8Zt}tk{١퇢}eԟu,étZ֋wUZĝIN~9{Zug.7Cpiz:n(!
Գ׬M?d*K7۵yWF_!IS"ڮ3Ü	94f)u4Lzn%У3Iӻ%MD;{b0ձ;Yx8{BxeYf;"uڐ`y–;)|-Y79\=g$}͘H\EQ\FSE98'<ӱ}}]Ӽy|ȉȍȑ,>ĨmyXbe%h)gQ+7>~>~?}x.!S[}wJA(B_\j{)mxֿ,QrFf#J\ߝԝz4+XPgqQY@R}cGgw{lؽŬcfR2!.}@4C#%$F;|}9&	ђQͅ\WO}o:? ,?/!C/rˌp葫`Q֜wz?08y1?^d*%vWOeZkh׸	pY>n1'u"ŧUKS`\S!_d\Ȏ%RCb_Ti*ccN(Ũk&^nXVls2+Zu1Rtw)yѢX-%v}7OJ'q+A;*^js!CI F4(1,Σ$[Τy,IH
zuLa A2e4u.$goaύ5Y-Y;2-7^PC9*֬Z_ǒ
ʥΛeײm-KtoҭkdܻzK.l0Ċ3n1Ȓ'Sl2̚7s3Т)})U=Y\lL,kh$ldR
vdթ]Ȗ =ܳ%5ZozXZ-c߱wy'xJXtiu͗La4M^WSE#VM{9[|]O1F$sWoOތbT5rW(6ZDCi<&51]n?d+DᖰA#Xח.GС iʛ#&GBgyFVNVٜvIMz&ҧl䦠m>_~ÀXχ]sN-#uYo\4fjY>jݨW)r@$DH*iڦ	k6Ģyݫ-B")՘00o\
k)vc}Ǒ/[ҥ {_;)jawzkjG5KƱx^ls%2	x2S0g2183c:ZT}tdg))M;OK=uSQS}5F5]{5a=6e}6i6m6q]?(iJD6sIuסn0M[?|BF_Rgslv+|r -$)I
a,G>M(a}3쯔Nhπ|82&7ߪIa>w
Org7/~.r;ߞx=L0Tb7Yo= G{1_EUp6Ӌ^Ȕ
nxb_v@l+!7huP!ưu4
C+J_f1=ɂh	Ʋ1fjuctłL)wwH-rQ9S']W@e}!	]AGk4YSF6D+ ~gFAC$9I%+#B4Z1pPDO],csI^_$&2&6RȻ)ͦ(Ӽ&6mr&8)q<':өu|'<)i;mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Fonts12.gif0000644000175000017500000001567111272077141026147 0ustar  giovannigiovanniGIF89aJ,Jb)cNsS.
Jൌʬjn?[|\:APDGsD5Jl{-*Mna_3wf4bF76HȵX	Yv5Ǘ)wVxvXf4X	+G':(v|j{U'
L)L:;l"
Tgi*-f=\mzYZk IbHyC6CiiGvJh#Ć>X4۷p"",´5C
Nn
浄<	ec.1lʨB
Mb£Erej(VBIJmkJ刂g[e+EZѾ`Ɠ'P#MjpUC̈́Ku&忙,8`8ɲNV![~;wgt]{]>`?nm;|O	F=Cl:˗WMܼfkջx?+K[JY
H jAW`
dgyQm	^&5dT5&X8!HWE8'Ρ0FȠ7
:^ؔD}ݢȉШE^C!mЇ8yn0ViGdj8ȴW:[2L187TheRXJ']Ej2O/&5{2eDS[r^`pDBf(Bjgh"G}OVlˤN-n\r☓UX ^+R	.ɡq!z+V)i|l*d&"#
7*N.ֻsnf:/Iw븞0p*q_bovr&r&r*r.sb'5RSlGQM7޵㮛-#BtӶJ/IZKW6bN[slLx{6p\1|#]$7z4Fg@-e
3_RwYcC8e3ֶ& x1	ɈHl(q[Rd,?:ӢAv/*g8r)P8&fuJ̒(8^XI\Ւ>0f]FSS*tsԚZh$6Wؐ'( E'2# 5I+0TJh4_Q=҉2QDw-?%C>Onwl)EC裕RA@eZ;A$IH^ԥtGpd!&ar>|9%j *5xn(B>%&VEvVӠ
(;]m5D^/|49ʃ",ʧg.G|3K6R>!k'=(\HbLg55\V
ְud-YϊִulmN4cH8+Y^r=&(hu|e*&Ru )P\H~S#e$iؙ,njz>iϤ|\%rI:VOdV7yCpdTϢhiTr2M0UW=$+L8}g'axW&rE'Fܤ){Źh
K[r(f*/4y.:-E5_@c;%bvй>{X?jb[ppznYOZЗvp_٘–4ό$MZns3:8ߊLd>xoj~jYp.)HtBNsK:կk}\/^i{s$&~qNthq``|?ϥ
,^,HW+ں1&Dv](qSd۳[F9tǣAt9KL{`we][aU+
vj=I<芧AyóWH߻~kn;>I&՝<o~]?S\}7}'Fx*?LGrle'P}wxp|w'pFrv}
9u#e|R3s{~W{xvԁenbs4Vx})jUe6%Rd78t>uv,rŖEx5W2ԧdoFO}VxsN`UcHehggh^4?'~FkyK?i`Gn"3vc68҂xSVja@8A8pW}'$Kiƅ'AA$mDmJ)TT:W. g9_1w6sy0GH<xY"{qƊry.@s|xŌh؋=Gt%68OLKӌFnf"oȉ$EՎ
ȆO}JO~d*֨W8tIɸI49lC.sT,|9fj08LĶu749ّdE0GMO	Q)SI~gFebzPX[ΆauSE@!AyL4H^I0o8H8?ZiQf[xl8\ERzp&{`旲z9~oWQV6@Pra3eɚѴh|Ywecim&:7)ItFZliKRX	6$GÂwl	P5OI\Ǚo(!U=l!4rs|8(eGIɛJ՞LhxHxV6Xi]ԅPED_CveYlxq[vН"?c|;8^'Ֆ)CxPɝ0*'9r*ju7Z/2tr8UKʤMO
Q*VIH,czj|)zsc-B
K76>	`aZog`v)Z
WJiɣ	$j9\iMG?U),H9G1٦jZӌ%SgizXʧ@)FȜ.RVԨ)Sʩd{id
Jd#pyHʙUbs*
fI+j׊d[*Cz*H	/گ]n=5ljʆkjE2	Ԡ:3ۣ9JmX69*YRʳ=?˓?N8!@6W*`I'QyZT6$nk	2ȑ9e6:Sca}fz:Ѳw\SYʶ,M**Zx^B~Ĉj,[[q0mg
~*xis&|6U+Ba 퉍튳1K-qٍYg9L (Jakn8jvm5))s[;K$V걬EĻKymU*{0`RIZ@E7v2Z)l	rdj$ʶ˯˔r۶H
]k"5}vJ{F+RD!Lk&_\f[!BN|J˪\NH9
ګ8r@ku;CGSȜ~{='=rRT|ljFyH,Ji{I.xA
{W"W8
}۾..+W0\BB\}wܥ/iGE<_"ɚŤ><+`l,|ߗd§8b"i6ۅ,3e=̀KOi,L匰MΩc5,y{
ʸr#| ܇s9w(bByX+tQ}|/Auc9ŷ9}Ҁj$5h;#lv$а6lnt"TS`锞3~ۅZ|}k	Y,9m|P[(
hp,n=~1\5GZI:ޏJ5ʺ]a|b+wsEQKeVNPR~"BaMBj<ȉ^T3.NhȅlWzR|}iax55()
̢|@ǃ,M=R8Cb!xenzSloo/·
{Zum{}8P
/褝Lu}/߽!K1u`ANTsP4ҪBɳ}[?ؾqR>YS=9aD
I²-\!WgV2aOfE*^3=x!#%')+-/13579;=?ACE;rN P/^LZӴfSmTpg)Lvj}k8t&[ԚS]_]&~l){Ղ}ӢəGi]glJ0k½;խxqǑ'Wysϡ3>'J)SXWdQ9S*vh'K4)}^%'^XjrFrD=)t<>tOA=fʐs/2ĩA0Bhĵ&
8|dlhJT씰HeF^BRñ8z2FH)J+J1drB'Y[`쒡$
R$".

******************************************************************************
*                                                                            *
* Constructor:                                                               *
*   cHotEqn()                Construtor without any initial equation.        *
*   cHotEqn(String equation) Construtor with initial equation to display.    *
*   cHotEqn(String equation, Applet app, String name)                        *
*                            The same as above if used in an applet          *
*                            with applet name.                               *
*                                                                            *
* Public Methods:                                                            *
*   void setEquation(String equation)  Sets the current equation.            *
*   String getEquation()               Returns the current equation.         *
*   void setDebug(boolean debug)       Switches debug mode on and off.       *
*   boolean isDebug()                  Returns the debug mode.               * 
*   void setFontname(String fontname)  Sets one of the java fonts.           *
*   String getFontname()               Returns the current fontname.         *
*   void setFontsizes(int g1, int g2, int g3, int g4) Sets the fontsizes     *
*                                      for rendering. Possible values are    *
*                                      18, 14, 16, 12, 10 and 8.             *
*   void setBackground(Color BGColor)  Sets the background color.            *
*                                      Overrides method in class component.  *           
*   Color getBackground()              Returns the used background color.    *
*                                      Overrides method in class component.  *           
*   void setForeground(Color FGColor)  Sets the foreground color.            *
*                                      Overrides method in class component.  * 
*   Color getForeground()              Returns the used foreground color.    *
*                                      Overrides method in class component.  * 
*   void setBorderColor(Color border)  Sets color of the optional border.    *
*   Color getBorderColor()             Returns the color of the border.      * 
*   void setBorder(boolean borderB)    Switches the border on or off.        * 
*   boolean isBorder()                 Returns wether or not a border is     *
*                                      displayed.                            *
*   void setRoundRectBorder(boolean borderB)                                 *
*                                      Switches between a round and a        *
*                                      rectangular border.                   *
*                                      TRUE: round border                    *
*                                      FALSE: rectangular border             *
*   boolean isRoundRectBorder()        Returns if the border is round or     *
*                                      rectangular.                          *
*   void setEnvColor(Color env)        Sets color of the environment.        *
*   Color getEnvColor()                Returns the color of the environment. * 
*   void setHAlign(String halign)      Sets the horizontal alignment.        *
*                                      Possible values are: left, center and *
*                                      right.                                *
*   String getHAlign()                 Returns the horizontal alignment.     *
*   void setVAlign(String valign)      Sets the vertical alignment.          *
*                                      Possible values are: top, middle and  *
*                                      bottom.                               *
*   public String getVAlign()          Returns the vertical alignment.       *
*   void setEditable(boolean editableB)  Makes the component almost editable.*
*                                      Parts of the displayed equation are   *
*                                      selectable when editable is set true. *
*                                      This is turned on by default.         *
*   boolean isEditable()               Returns wether or not the equation    *
*                                      is editable (selectable).             *
*   String getSelectedArea()           Return selected area of an equation.  *
*   Dimension getPreferredSize()       Returns the prefered size required to *
*                                      display the entire shown equation.    *
*                                      Overrides method in class component.  *
*   Dimension getMinimumSize()         This method return the same value as  *
*                                      getPreferedSize                       *
*                                      Overrides method in class component.  *
*   Dimension getSizeof(String equation) Returns the size required to        *
*                                      display the given equation.           *
*   void addActionListener(ActionListener listener)                          *
*                                      Adds the specified action listener to *
*                                      receive action events from this text  *
*                                      field.                                *
*   void removeActionListener(ActionListener listener)                       *
*                                      Removes the specified action listener *
*                                      to receive action events from this    *
*                                      text field.                           *
*   Image getImage()                   Returns the HotEqn image              *  
*                                                                            *
******************************************************************************
************  Version 0.x                *************************************
* 15.07.1996  Beginn                                                         *
* 18.07.1996  Parameter Erweiterung                                          *
* 22.07.1996  Scanner: Token Tabelle                                         *
* 24.07.1996  Br�che \frac{ }{ }                                             *
* 25.07.1996  Wurzel \sqrt{}, Tief _, Hoch ^, rekur. Schrift                 *
* **********  Version 1.0                *************************************
* 26.07.1996  Array \array                                                   *
* 29.07.1996  Klammern \left ( | \{ \[ \right ) | \} \]                      *
*             public setEquation(String equation) f�r JS                     *
* 30.07.1996  Griechische Symbole in Scanner                                 *
* 04.08.1996  Greek Symbole werden EINZELN vom Netz geladen                  *
* 05.08.1996  Greek Zeichensatz erneuern (schwarz-weiss Prob.)               *
* **********  Version 1.01               *************************************
* 29.08.1996  \sum Summen, \prod Produkte                                    *
* **********  Version 1.02               *************************************
* 23.09.1996  Diverse Akzente \bar \hat \acute \grave \dot                   *
*             \tilde \ddot                                                   *
* **********  Version 1.03               *************************************
* 24.09.1996  �bergabemechanismus zwischen den verschiedenen                 *
*             Applets auf einer HTML-Seite                                   *
* **********  Version 1.04               *************************************
*             evalMFile bei Mouse-Klick (->JS->Plugin)                       *
*             engGetFull                                                     *
* 14.10.1996  Matrix2LaTeX holt aktuelle Matrix vom Plugin                   *
*               und ruft setRightSide auf                                    *
* 15.10.1996  Alle Plugin-Funktionen mit Argument, muessen                   *
*                das Argument aus JS holen "var VCLabHandle"                 *
************  Version 1.05               *************************************
* 18.10.1996  L�sung Applet -> Plugin (alles zur�ck !!)                      * 
************  Version 1.1                *************************************
* 04.01.1997  Integral \int_{}^{}                                            *
*             Limes \lim \infty \arrow                                       *
* 22.01.1997  Korrektur der engGetFull() Methode                             *
******************************************************************************
**************   Release of Version 2.0  *************************************
*                                                                            *
*        1997 Chr. Schmid, S. Mueller                                        *
*             Redesign wegen Matlab 5                                        *
* 05.11.1997  Umbenennungen der Parameter                                    *
*             alt:             neu:                                          *
*             engEvalString    mEvalString                                   *
*             eval             mEvalString                                   *
*             evalMFile        mEvalMFile                                    *
*             engGetFull       mGetArray                                     *
*             Matrix2LaTeX     mMatrix2LaTeX                                 *
* 09.11.1997  Background und Foreground Color, Border, Size                  *
* 10.11.1997  Separation into HotEqn(no MATLAB) and mHotEqn(MATLAB) version  *
* 12.11.1997  Scanner compactified, parser small changes:                    *
*             new methof: adjustBox for recalculation of box size after      * 
*             function calls.                                                *
*             \sin \cos .... not italics                                     *
* 16.11.1997  setEquation(String LeftSideS, String RightSideS) method added  *
* 23.11.1997  Paint not reentrant                                            *
* 13.11.1997  Binary operators         (Kopka: LaTeX: Kap. 5.3.3) prepared   * 
*  (2.00c)    quantities and their negation    ( "    Kap. 5.3.4)    "       *
*             Arrows                           ( "    Kap. 5.3.5)    "       *
*             various additional symbols       ( "    Kap. 5.3.6)    "       *
*             additional horizontal spaces \, \; \: \!            prepared   *
*             \not                                                prepared   *
* 29.11.1997  Scanner optimized (2.00d)                                      *
* 30.11.1997  Paint buffered (2.00e)                                         *
* 03.12.1997  horizontal spaces, \not, \not{} implemented       (2.00f) *
* 06.12.1997  ! cdot cdots lim sup etc. ( ) oint arrows some symb.   (2.00g) *
* 08.12.1997  left and right []                                      (2.00h) *
* 08.12.1997  default font plain                                     (2.00i) *
* 11.12.1997  SINGLE (false) argument and STANDARD (true)                    *
*             (e.g. \not A or \not{a+B} ) for all commands, where single     *
*             or multiple arguments are allowed (_ ^ \sum ... )      (2.00j) * 
* 13.12.1997  A_i^2 (i plotted over 2, according to LaTex)           (2.00k) *
* 14.12.1997  LaTeX Syntax for brackets, beautified array,frac,fonts (2.00l) *
* 18.12.1997  scanner reduced to one scan, tokens now stored in array(2.00m) *
* 19.12.1997  all bracket types implemented by font/draw             (2.00n) *
* 20.12.1997  bracket section new, Null,ScanInit deadlock removed    (2.00o) *
* 22.12.1997  separation of HotEqn.java EqScanner.java EqToken.java  (2.00p) *
*             \choose \atop                                                  *
* 26.12.1997  overline underline overbrace underbrace stackrel       (2.00q) *
*             \fgcolor{rrggbb}{...} \bgcolor{rrggbb}{...}            (2.00r) *
* 30.12.1997  ScanInit,setEqation combined \choose modified to \atop (2.00s) *
*             and some other minor optimizations                             *
* 31.12.1997  overline underline sqrt retuned                        (2.00t) *
*             overbrace and underbrace uses arc, new <> Angle                *
*             right brackets with SUB and SUP                                *
* 31.12.1997  getWidth()  getHeight() Ermittl. d. Groesse v. aussen  (2.00u) *
*             \begin{array}{...} ... \end{array}                             *
* 01.01.1998  Tokens stored dynamically (limit 500 tokens removed)   (2.00v) *
*             Some minor optimization in serveral functions                  *
* 02.01.1998  \fbox \mbox \widehat \widetilde                        (2.00w) *
* 02.01.1998  drawArc used for brackets, \widetilde good             (2.00x) *
* 03.01.1998  expect()-methods to check on expected tokens           (2.00y) *
* 04.01.1998  redesign of thread synchronization, getWidth|Height OK (2.00y1)*
*             some minor optimization in parser and documentation            *
* 04.01.1998  minor error with SpaceChar corrected                           *
*             \begin{eqnarray} implemented                           (2.00z) * 
* 08.01.1998  minor corrections for TeX-generated fonts              (2.00z1)*
* 09.01.1998  *{} for \begin{array} implemented                      (2.00z2)*  
* 13.01.1998  new media tracking, cached images, FGBGcolor corrected (2.00z4)* 
* 15.01.1998  Synchronisation with update changed because of overrun (2.00z5)* 
*             Default space for erroneous images                             *
*                                                                            *
* 17.01.1998  Separation into HotEqn and dHotEqn version.            (2.01)  *
*             HotEqn is only for Eqn. viewing and dHotEqn includes           *
*             all public methods. The mHotEqn is now based on dHotEqn.       *
*             Hourglass activity indicator added.                            *
* 18.01.1998  Image cache realized by hash table                     (2.01a) *
* 06.02.1998  New align parameter halign, valign. Correct alignment  (2.01b) *
* 27.02.1998  \sqrt[ ]{}                                             (2.01c) *
* 04.03.1998  Better spacing within brackets                         (2.01d) *
******************************************************************************
*     1998    S. Mueller, Chr. Schmid                                        *
* 19.01.1998  AWT component for use in other applications (like buttons,     *
*             scrollbars, labels, textareas,...)                     (2.01b) *
* 10.03.1998  adjustments                                            (2.01b1)*
* 11.03.1998  migration to JDK1.1.5                                  (2.01d1)*
* 14.03.1998  migration to the new event model and public methods    (2.01d2)*
* 20.03.1998  setPreferredSize() setMinimumSize()                    (2.01d3)*
* 04.04.1998  this.getSize()... in paint wieder eingebaut            (2.01d4)*
*             PropertyChange... ---> automatic resize of bean                *
* 11.04.1998  java-files renamed cHotEqn.java --> bHotEqn.java (Bean)(2.01d5)*
*             setBorder() setRoundRectBorder()                               *
* 12.04.1998  partial rearranging of variables and methods                   *
*             bHotEqn -> separated into cHotEqn & bHotEqn            (2.02)  *
* 26.04.1998  possible workarround for getImage()-problem            (2.02a) *
* 27.04.1998  Toolkit.getDefaultToolkit().getImage() is buggy for            *
*             Netscape 4.04 and 4.05 (JDK1.1x) (see getSymbol(...)           *
* 02.05.1998  image-loading problem solved                           (2.02b) *
*             output to System.out only if debug==true                       *
* 09.05.1998  selectable equations     (minor error correction 2.01f)(2.03)  *
* 30.03.1998  GreekFontDescents corrected (better for Communicator)  (2.01e) *
* 12.05.1998  see mHotEqn and EqScanner                              (2.01f) *
* 22.05.1998  modified border radius calculation                     (2.01g) *
* 10.04.1999  corrected alpha value in Color Mask Filter             (2.01h) *
* 21.05.1998  selection almost completed                             (2.03a) *                                
* 24.05.1998  setEditable(), isEditable(), getselectedArea()         (2.03b) *
*             fontsize-problem solved, starts with editable=true             *
**************   Release of Version 3.00 *************************************
*     2001    Chr. Schmid                                                    *
* 18.01.2001  modified according to old HotEqn, SymbolLoader added, three    *
*             parameter constructor for applet context with applet name,     *
*             events corrected, edit mode highlight with transparency        *
* 14.05.2001  getImage method added                                   (3.01) *
* 15.06.2001  getImage method returns null when Image not ready       (3.02) *
* 01.12.2001  edit mode on mouse down,drag,up and new string search   (3.03) *
* 18.02.2002  faster version with one scan in generateImage           (3.04) *
* 19.02.2002  Environment color parameter + methods                   (3.04) * 
* 20.02.2002  New SymbolLoader with packed gif files (fast and small) (3.10) * 
* 23.03.2002  New method getSizeof to determine size of equation      (3.11) * 
* 27.10.2002  Package atp introduced                                  (3.12) * 
**************   Release of Version 4.00 *************************************
* 14.07.2003  Adapted to XPCom. Same as 3.12,only mHotEqn affected    (4.00) *
* 27.09.2004  Symbol loader Image file read instead of -1 now 0       (4.01) *
* 14.09.2006  \sech and \csch added                                   (4.02) *
*****************************************************************************/

// **** localWidth u. localHeight nur bei getPreferredSize() zur�ckgeben

package org.mathpiper.ui.gui.hoteqn;

// package bHotEqn;  // for Bean-compilation to avoid double filenames

//import atp.*;
import java.util.*;
import java.awt.*;
import java.awt.image.*;
import java.awt.event.*;
import java.applet.Applet; // wenn Component von Applet aufgerufen wird.
import java.net.URL;       // for image loading in beans
import java.io.InputStream;  //
import java.io.IOException;
import java.io.*;
import java.util.StringTokenizer;

public class cHotEqn extends Component 
                     implements MouseListener, MouseMotionListener {

private static final String  VERSION = "cHotEqn V 4.02 ";

private int       width          = 0;
private int       height         = 0;
private String    nameS          = null;
private String    equation       = null;
private String    Fontname       = "Helvetica";

ActionListener    actionListener;     // Post action events to listeners

private EqScanner eqScan;
private EqToken   eqTok;

private Font f1 = new Font(Fontname,Font.PLAIN, 16);   
private Font f2 = new Font(Fontname,Font.PLAIN, 14);
private Font f3 = new Font(Fontname,Font.PLAIN, 11);
private Font f4 = new Font(Fontname,Font.PLAIN, 10);

private static final float mk = 2.0f;     // Umschaltfaktor f�r Klammerndarstellung (font,zeichnen)

private static final int GreekFontSizes[]    = { 8,10,12,14,18 }; // vorhandene GreekFonts
private static final int GreekFontDescents[] = { 2, 3, 4, 5, 6 }; // vorhandene GreekFonts Descents
private int GreekSize[]                      = {14,12,10, 8};
private int GreekDescent[]                   = { 3, 3, 3, 3};
private static final int EmbedFontSizes[]    = { 9,11,14,16,22 }; // zugeordnete normale Fonts

/* greek font embedding characteristic based on Helvetica

 nominal font size  18  14  12  10   8
   greek leading     1   0   0   0   0
   greek height     23  16  15  13  11
   greek ascent     18  14  12  10   8
   greek descent     6   5   4   3   2
   embed size       22  16  14  11   9
   embed leading     1   1   0   0   0
   embed height     26  19  16  14  12
   embed ascent     20  15  13  11   9
   embed descent     6   3   3   3   3
*/

private Image   bufferImage;                     // double buffer image
private boolean imageOK          = false;
private int     localWidth       = 0;
private int     localHeight      = 0;

private Color   BGColor          = Color.white;
private Color   EnvColor         = Color.white;
private Color   FGColor          = Color.black;
private Color   BorderColor      = Color.red;
private boolean borderB          = false;
private boolean roundRectBorderB = false; 
private int     border           = 0;
private String  halign           = "left";
private String  valign           = "top";
private int     xpos             = 0;
private int     ypos             = 0;
private boolean drawn            = false;       // drawn Semaphore fuer paint

private SymbolLoader symbolLoader;              // flexible fontloader
private MediaTracker tracker;                   // global image tracker
private Hashtable imageH = new Hashtable (13);  // Hashtable fuer Image Cache (Primzahl) 

private Applet  app;  // Applet-Handle: wegen Netscape 4.x Bug mit Toolkit...getImage()  
public  boolean appletB          = false;      // true wenn fuer HotEqn - cHotEqn benutzt
public  boolean beanB            = false;      // true wenn als Bean benutzt    
public  boolean debug            = true;       // debug-Meldungen

private boolean editMode         = false;      // Editor mode: select parts of equation
private boolean editableB        = true;
private int     mouse1X          = 0;
private int     mouse1Y          = 0;
private int     mouse2X          = 0;
private int     mouse2Y          = 0;
private int     xOFF             = 0;
private int     yOFF             = 0;
private int     y0 = 0;
private int     x0 = 0;
private int     y1 = 0;
private int     x1 = 0;
private int     editModeRec    = 5;
private boolean editModeFind   = false;
private int     editModeCount1 = 0;
private int     editModeCount2 = 0;
private Image   selectImage;

//*************************  Constructor ()  ****************************************
public  cHotEqn() {
  this("cHotEqn", null, "cHotEqn");
}

public  cHotEqn(String equation) {
  this(equation, null, "cHotEqn");
}

public cHotEqn(String equation, Applet app, String nameS) {
   this.app       = app;                // Handle fuer Applet fuer Applet.getImage()
   this.equation  = equation;
   this.nameS     = nameS;
   addMouseListener(this);
   addMouseMotionListener(this);
   if (app != null)  appletB=true; 
   symbolLoader   = new SymbolLoader();      // Fontlader
   tracker        = new MediaTracker(this);  // Mediatracker fuer Images
   eqScan         = new EqScanner(equation); // Scanner zur Erkennung der Token
   System.out.println(VERSION+nameS);
}

//*************************  Public Methods ***********************************

public void setEquation(String equation) {
    this.equation = equation;
    eqScan.setEquation(equation);
    drawn   = false;
    imageOK = false;
    repaint();
} 
public String getEquation() { return equation; }

public void printStatus( String s) {
   if (debug) System.out.println(nameS + " " + s);
}

private void displayStatus( String s) {
   if (debug) {if (appletB) app.showStatus(nameS + " " + s); else printStatus(s);}
}

public Image getImage() {
	if (imageOK) return bufferImage; else return null;
}

public void setDebug(boolean debug) {
   this.debug = debug;
}
public boolean isDebug() { return debug; }

public void   setFontname(String fontname) { Fontname = fontname;}
public String getFontname()                { return Fontname;}

public void setFontsizes(int gsize1, int gsize2, int gsize3, int gsize4) {
   int    size1  = 16;
   int    size2  = 14;
   int    size3  = 11;
   int    size4  =  9;

   GreekSize[0]=0;
   GreekSize[1]=0;
   GreekSize[2]=0;
   GreekSize[3]=0;

   // Fontgr��en f�r alle Zeichen und die Griechischen Symbole und Sonderzeichen
   for (int i=0; i width)   {toosmall=true; xpos=0;}
     if (localHeight > height) {toosmall=true; ypos=1;}
     // Calculate position
     int xoff=border;
     int yoff=border; 
     switch (xpos) {
       case 0: break;
       case 1: xoff=(width-area0.dx)/2; break;
       case 2: xoff=width-border-area0.dx-1; break;
     }
     switch (ypos) {
       case 0: break;
       case 1: yoff=border-(localHeight-height)/2; break;
       case 2: yoff=height-border-area0.dy_neg-area0.dy_pos; break;
     }
     //System.out.println("nach 1. eqn");
     g.drawImage(genImage,xoff,yoff,xoff+area0.dx,yoff+area0.dy_pos+area0.dy_neg+1,0,height-area0.dy_pos,area0.dx,height+area0.dy_neg+1 ,this);
     //System.out.println("nach 2. eqn");
     geng.dispose();
     if (toosmall) printStatus("(width,height) given=("+width+","+height
                                   +") used=("+localWidth+","+localHeight+")");
     imageOK = true;
     drawn   = true;
     xOFF=xoff;
     yOFF=yoff+area0.dy_pos;
     notify(); // notifiy that painting has been completed
} // end generateImage

/*  slower version with two scans
private synchronized void generateImage (Graphics g) {
     BoxC area  = new BoxC();
     BoxC area0 = new BoxC();
     g.setFont(f1);
     g.setColor(BGColor);
     g.fillRect(0,0,width,height);
     border=0;
     if (borderB && roundRectBorderB) {
       g.setColor(EnvColor);
       g.fillRect(0,0,width,height);
       g.setColor(BGColor);
       g.fillRoundRect(0,0,width-1,height-1,20,20);
       g.setColor(BorderColor);
       g.drawRoundRect(0,0,width-1,height-1,20,20);
       border=5;
     } else {
       if (borderB && !roundRectBorderB) {
         g.setColor(BorderColor);
         g.drawRect(0,0,width-1,height-1);
         border=5;
       }
     }
     g.setColor(FGColor);

     //FontMetrics fM  = g.getFontMetrics();
     //System.out.println("getAscent     = "+fM.getAscent()      );
     //System.out.println("getDescent    = "+fM.getDescent()     );
     //System.out.println("getHeight     = "+fM.getHeight()      );
     //System.out.println("getLeading    = "+fM.getLeading()     );
     //System.out.println("getMaxAdvance = "+fM.getMaxAdvance()  );
     //System.out.println("getMaxAscent  = "+fM.getMaxAscent()   );
     //System.out.println("getMaxDecent  = "+fM.getMaxDecent()   );
     //System.out.println("getMaxDescent = "+fM.getMaxDescent()  );
   
     // Scanner zur�cksetzen & Gleichung in d. Mitte d. Fensters 

     //imageH.clear();  // Image Cache leeren (nicht erforderlich)
     //System.out.println("vor 1. eqn");
     eqScan.start();
     area0 = eqn(0,150, false, g, 1);
     displayStatus(" ");
     
     // set alignment
     xpos=0; // left
     if (halign.equals("center"))     xpos=1;
     else if (halign.equals("right")) xpos=2;
           
     ypos=0; // top      
     if (valign.equals("middle"))      ypos=1;
     else if (valign.equals("bottom")) ypos=2;
                  
     // Calculate actual size
     localWidth  = 1+area0.dx+2*border;
     localHeight = 1+area0.dy_pos+area0.dy_neg+2*border;

     // Test size and modify alignment if too small
     boolean toosmall = false; 
     if (localWidth > width)   {toosmall=true; xpos=0;}
     if (localHeight > height) {toosmall=true; ypos=1;}
     // Calculate position
     int xoff=border;
     int yoff=area0.dy_pos+border; 
     switch (xpos) {
       case 0: break;
       case 1: xoff=(width-area0.dx)/2; break;
       case 2: xoff=width-border-area0.dx-1; break;
     }
     switch (ypos) {
       case 0: break;
       case 1: yoff=border+area0.dy_pos-(localHeight-height)/2; break;
       case 2: yoff=height-border-area0.dy_neg-1; break;
     }
     //System.out.println("nach 1. eqn");
     eqScan.start();
     area = eqn(xoff,yoff,true,g,1);
     //System.out.println("nach 2. eqn"); 
     if (toosmall) printStatus("(width,height) given=("+width+","+height
                                   +") used=("+localWidth+","+localHeight+")");
     imageOK = true;
     drawn   = true;
     xOFF=xoff;
     yOFF=yoff;
     notify(); // notifiy that painting has been completed
} // end generateImage
*/


//***************************************************************************
//***************************************************************************
//***************             Parser-Routinen              ******************
private BoxC eqn(int x, int y, boolean disp, Graphics g, int rec){
   // different number of parameters
   return eqn(x, y, disp, g, rec, true); // Standard Argument (e.g. A_{.....})
} // end eqn


private BoxC eqn(int x, int y, boolean disp, Graphics g, int rec, boolean Standard_Single){
// Parameter: Baselinekoordinaten:         x und y
//            Zeichnen oder Gr��e berechnen: disp (true/false)
//            Rekursionstiefe (Br�che, Hoch,Tief,...)
//            Single (e.g. A_3)(false) o. Standard argument (e.g. A_{3+x})(true)

// die Methode: boxReturn = adjustBox(box,boxReturn) ersetzt die separate
//              Berechnung der neuen Boxgr��en nach einem Funktionsaufruf
   BoxC        box       = new BoxC();  // f�r R�ckgaben von Funktionsaufrufen
   BoxC        boxReturn = new BoxC();  // akkumuliert die max. Boxgr��e 

   boolean Standard_Single_flag = true;
   boolean Space_flag           = false;
   boolean editModeFindLEFT = false;
   int editModeCount = 0;
   int editModeCountLEFT = 0;
   int eqToktyp;
   //String eqTokstringS;

   while (!eqScan.EoT() && Standard_Single_flag) {
     eqTok = eqScan.nextToken();
     if (editMode && disp) editModeCount = eqScan.get_count();

     Space_flag = false; 
     //System.out.print (eqTok.typ);
	 //if ( disp) System.out.println("Token ="+eqTok.typ);
	 editModeCountLEFT = editModeCount;
     eqToktyp = eqTok.typ;
     //eqTokstringS = eqTok.stringS;

     switch(eqTok.typ) {
     case EqToken.AndSym:
     case EqToken.DBackSlash:
     case EqToken.END:
     case EqToken.EndSym:
     case EqToken.RIGHT:
               if (editModeFind && disp) { 
				  //System.out.println("RighteditModeCount ="+editModeCount);
                  if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
                  if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
               }
               return boxReturn;
     case EqToken.ACCENT:
               box = ACCENT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.ANGLE:
               box = ANGLE(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.ARRAY:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = ARRAY(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.BEGIN:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = BEGIN(x+boxReturn.dx,y,disp,g,rec); 
               break;
     case EqToken.BeginSym:
               box = eqn(x+boxReturn.dx,y,disp,g,rec,true); 
               break;
     case EqToken.FGColor:
               box = FG_BGColor(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.BGColor:
               box = FG_BGColor(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.FBOX:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = FBOX(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.Id:
               box = Id(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.NOT:
               box = NOT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.Op: 
               box = Op(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.FRAC:
               box = FRAC(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.ATOP:
               box = FRAC(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.FUNC:
     case EqToken.Num:
               box = Plain(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SYMBOP:
               box = SYMBOP(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.SYMBOPD:
               box = SYMBOP(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.LEFT:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = LEFT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.LIM:
               box = LIM(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.MBOX:
               box = MBOX(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.OverBRACE:
               box = OverBRACE(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.UnderBRACE:
               box = UnderBRACE(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.OverLINE:
               box = OverUnderLINE(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.UnderLINE:
               box = OverUnderLINE(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.Paren:
               box = Paren(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SPACE:
               box = SPACE(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SQRT:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = SQRT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.STACKREL:
               box = STACKREL(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.SUP:
               box = SUP(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.SUB:
               box = SUB(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.SYMBOLBIG:
               box = SYMBOLBIG(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.VEC:
               box = VEC(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.SpaceChar:
               box = new BoxC(0,0,0);
               // bei SpaceChar gilt immer noch eqn(...,false) (single eqn)
               Space_flag = true;   
               break;
     case EqToken.Invalid:
     case EqToken.Null:
               box = new BoxC(0,0,0);
               break;
     default:
               printStatus("Parser: unknown token: "+eqTok.typ+" "+eqTok.stringS);
               // einfach ignorieren 
     } // end switch

	if (disp)  {
		if (editMode)  {
			//System.out.println("x+boxReturn.dx = "+(x+boxReturn.dx)+" mouse1X = "+mouse1X+" x+boxReturn.dx+box.dx ="+(x+boxReturn.dx+box.dx));
			if (!editModeFind) {
				if ( x+boxReturn.dx    <= mouse1X                    &&  
					 mouse1X           <= (x+boxReturn.dx+box.dx)    && 
					 (y-box.dy_pos)    <= mouse1Y                    && 
					 mouse1Y           <= (y+box.dy_neg) ) {
					//System.out.println("Anfang token "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					x0 = x1 = mouse1X;
					y0 = y1 = mouse1Y;
					editModeFind   = true;
					editModeCount1 = editModeCount;
					editModeCount2 = editModeCount;
				}
			}
			if (!editModeFind) {
				if ( x+boxReturn.dx    <= mouse2X                    &&  
					 mouse2X           <= (x+boxReturn.dx+box.dx)    && 
					 (y-box.dy_pos)    <= mouse2Y                    && 
					 mouse2Y           <= (y+box.dy_neg) ) {
					//System.out.println("Anfang2token "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					x0 = x1 = mouse2X;
					y0 = y1 = mouse2Y;
					editModeFind = true;
					editModeCount1 = editModeCount;
					editModeCount2 = editModeCount;
					int dummyX = mouse2X;
					int dummyY = mouse2Y;
					mouse2X    = mouse1X;
					mouse2Y    = mouse1Y;
					mouse1X    = dummyX;
					mouse1Y    = dummyY;
				}
			}
			//System.out.println("Token ="+eqToktyp+" editModeFind ="+editModeFind+" editModeFindLEFT ="+editModeFindLEFT);
			if (editModeFind) {
				//System.out.println("Mitte token  "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec+" "+editModeCount1+" "+editModeCount2);
				x0 = Math.min(x0, x + boxReturn.dx);
				x1 = Math.max(x1, x + boxReturn.dx + box.dx);
				y0 = Math.min(y0, y - box.dy_pos);
				y1 = Math.max(y1, y + box.dy_neg);
				//g.setColor(Color.green);
				//g.drawRect(x0, y0, x1-x0, y1-y0);
				//g.setColor(FGColor);
				if (editModeRec>rec) editModeRec = rec;
     			switch(eqToktyp) {
     				case EqToken.LEFT :
     				case EqToken.FBOX :
     				case EqToken.MBOX :
     				case EqToken.BEGIN :
     				case EqToken.ARRAY :
     				case EqToken.SQRT :
						editModeFindLEFT = true;
						if (editModeCountLEFT > editModeCount2) editModeCount2 = editModeCountLEFT;
						if (editModeCountLEFT < editModeCount1) editModeCount1 = editModeCountLEFT;
						editModeCount = eqScan.get_count();
						//System.out.println("MBOX/FBOX/LEFT handling");
				} // end switch
				if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
				if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
				//System.out.println("editModeCount1 "+editModeCount1);
				//System.out.println("editModeCount2 "+editModeCount2);
				if ( x+boxReturn.dx    <= mouse2X                    &&  
				     mouse2X           <= (x+boxReturn.dx+box.dx)    && 
				     (y-box.dy_pos)    <= mouse2Y                    && 
				     mouse2Y           <= (y+box.dy_neg)  ) {
					//System.out.println("Ende token   "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					//g.setColor(Color.red);
					//g.drawRect(x0, y0, x1-x0, y1-y0);
					//g.setColor(FGColor);
					if (editModeRec == rec) {
						editMode     = false;
						editModeFind = false;
						//System.out.println("editModeCount "+editModeCount);
					}
				}
			} // end editModeFind
		} // end editMode
		if (editModeFindLEFT) {
			//System.out.println("find LEFT token  "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec+" "+editModeCount1+" "+editModeCount2);
			x0 = Math.min(x0, x + boxReturn.dx);
			x1 = Math.max(x1, x + boxReturn.dx + box.dx);
			y0 = Math.min(y0, y - box.dy_pos);
			y1 = Math.max(y1, y + box.dy_neg);
			//g.setColor(Color.green);
			//g.drawRect(x0, y0, x1-x0, y1-y0);
			//g.setColor(FGColor);
   			switch(eqToktyp) {
   				case EqToken.LEFT :
   				case EqToken.FBOX :
   				case EqToken.MBOX :
   				case EqToken.BEGIN :
   				case EqToken.ARRAY :
   				case EqToken.SQRT :
				if (editModeCountLEFT > editModeCount2) editModeCount2 = editModeCountLEFT;
				if (editModeCountLEFT < editModeCount1) editModeCount1 = editModeCountLEFT;
				editModeCount = eqScan.get_count();
				//System.out.println("MBOX/FBOX/LEFT handling");
			} // end switch
			if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
			if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
			//System.out.println("editModeCount1 "+editModeCount1);
			//System.out.println("editModeCount2 "+editModeCount2);
			editModeFindLEFT = false;
		} // end editModeFindLEFT
	} // end disp

	boxReturn.dx    += box.dx; 
	boxReturn.dy_pos = Math.max(boxReturn.dy_pos,box.dy_pos);
	boxReturn.dy_neg = Math.max(boxReturn.dy_neg,box.dy_neg); 
	if (!Standard_Single && !Space_flag) Standard_Single_flag = false;   // Single argument (e.g. A_3)
	} // end while
    return boxReturn;
} // end eqn


//************************************************************************
private BoxC ACCENT(int x, int y, boolean disp, Graphics g, int rec) {
// Akzente: \dot \ddot \hat \grave \acute \tilde 
// eqTok.stringS enth�lt das/die darzustellende(n) Zeichen
   BoxC        box      = new BoxC();
   int         count    = 0;
   FontMetrics fM       = g.getFontMetrics();
   String      accentS  = eqTok.stringS;
   

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count(); 


   // Gr��e der Argument-Box berechnen
   box    = eqn(x,y,false,g,rec,false);
   int dx = Math.max(box.dx,fM.stringWidth(accentS));
   int dy_pos = box.dy_pos + (int)(fM.getAscent()/2); 
   int dy_neg = box.dy_neg; 

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
 
      // Argument zeichnen
      box = eqn(x,y,true,g,rec,false);

      // Mittenverschiebung ausrechenen
      int d_dx = 3*(int)( (dx-fM.stringWidth(accentS))/4 );

      if (accentS.equals(".") | accentS.equals("..")) {
         g.drawString(accentS,x+d_dx,y-fM.getAscent());
         }
      else if (accentS.equals("�") | accentS.equals("`")) {
         g.drawString(accentS,x+d_dx,y-(int)(fM.getAscent()/3));
         }
      else g.drawString(accentS,x+d_dx,y-(int)(fM.getAscent()*2/3));
   } // end disp
   return new BoxC(dx,dy_pos,dy_neg);  
} // end ACCENT

//************************************************************************
private BoxC ANGLE(int x, int y, boolean disp, Graphics g) {
   // Spitze Klammern < und >

   BoxC        box      = new BoxC();
   FontMetrics fM       = g.getFontMetrics();
   int dx     = g.getFont().getSize()/2;
   int dy_pos = fM.getHeight()-fM.getDescent();
   int dy_neg = fM.getDescent();

   // nur bei disp zeichnen
   if (disp) {
      int yp     = y-dy_pos+1;
      int yn     = y+dy_neg-1;
      int m      = (yp+yn)/2;
      if (eqTok.stringS.equals("<")) {
         g.drawLine(x+dx,yp,x,m);
         g.drawLine(x,m,x+dx,yn);
      } else {
         g.drawLine(x,yp,x+dx,m);
         g.drawLine(x+dx,m,x,yn);
      }
    } // end disp
   return new BoxC(dx,dy_pos,dy_neg);  
} // end ACCENT

//************************************************************************
private BoxC ARRAY(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx        = 0;
   int         dy_pos    = 0;
   int         dy_neg    = 0;
   int         dy_pos_max= 0;
   int         dx_eqn[]      = new int[100];  // Breite Spaltenelemente
   int         dy_pos_eqn[]  = new int[100];  // H�he   Zeilenelemente
   int         dy_neg_eqn[]  = new int[100];  // H�he   Zeilenelemente
   BoxC        box       = new BoxC();
   int         count     = 0;
   FontMetrics fM        = g.getFontMetrics();
   // Abstand 1 quad hinter Element
   int quad              = g.getFont().getSize();

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count(); 

   // "{" vom Scanner holen
   if (!expect(EqToken.BeginSym, "ARRAY: BeginSym")) return new BoxC(0,0,0);  

   // Schleife: Zeilen
   for (int y_i = 0; y_i<99; y_i++) {
      dy_pos = 0;
      dy_neg = 0;

      // Schleife: Spalten
      for (int x_i=0; x_i<99; x_i++) {
         // Gr��e der Argument-Box berechnen
         box  = eqn(x,y,false,g,rec);

         dy_pos = Math.max(dy_pos,box.dy_pos); 
         dy_neg = Math.max(dy_neg,box.dy_neg); 

         // Breitesten Elemente pro Spalte
         dx_eqn[x_i] = Math.max(dx_eqn[x_i],box.dx+quad);

         // Trennzeichen am SPALTENende
         if ((eqTok.typ==EqToken.DBackSlash) || 
             (eqTok.typ==EqToken.EndSym)) break;
      } // end Spalten

      // H�chste und tiefste Zeilenh�he
      dy_pos_eqn[y_i] = Math.max(dy_pos_eqn[y_i],dy_pos);
      dy_neg_eqn[y_i] = Math.max(dy_neg_eqn[y_i],dy_neg);
      dy_pos_max += (dy_pos + dy_neg); 

      // Trennzeichen am ARRAY-Ende
      if (eqTok.typ == EqToken.EndSym) break;
   } // end Zeilen


   // maximale Zeilenbreite bestimmen
   int dx_max = 0;
   for (int i=0; i<99; i++) dx_max += dx_eqn[i];

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos_max/2-fM.getDescent(),dx_max,dy_pos_max);
 
      // "{" vom Scanner holen
      expect(EqToken.BeginSym, "ARRAY: Begin");  

     // Schleife: Zeilen
     dy_pos = 0;
     for (int y_i=0; y_i<99; y_i++) {
        dx     = 0;
        if (y_i==0) { dy_pos  = dy_pos_eqn[y_i]; }
           else     { dy_pos += (dy_neg_eqn[y_i-1] + dy_pos_eqn[y_i]); }
        // Schleife: Spalten
        for (int x_i=0; x_i<99; x_i++) {
           // Gr��e der Argument-Box berechnen
           box = eqn(x+dx,y-dy_pos_max/2-fM.getDescent()+dy_pos,true,g,rec);
           dx     += dx_eqn[x_i];

           // Trennzeichen am SPALTENende
           if ((eqTok.typ == EqToken.DBackSlash) ||
               (eqTok.typ == EqToken.EndSym)) break;
        } // end Spalten
        // Trennzeichen am ARRAY-Ende
        if (eqTok.typ == EqToken.EndSym) break;
     } // end Zeilen
   } // end disp

   return new BoxC(dx_max-quad,dy_pos_max/2+fM.getDescent(),dy_pos_max/2-fM.getDescent());  
} // end ARRAY

//************************************************************************
private BoxC BEGIN(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx,     dx_max                 = 0;
   int         dy_pos, dy_neg, dy_top, dy_max = 0;
   int         dx_eqn[]      = new int[100];  // Breite Spaltenelemente
   int         dy_pos_eqn[]  = new int[100];  // H�he   Zeilenelemente
   int         dy_neg_eqn[]  = new int[100];  // H�he   Zeilenelemente
   int         format[]      = new int[100];  // Format 1-l 2-c 3-r 4-@
   int         format_count[]= new int[100];  // f�r getcount() bei @-Einsch�ben
   int         format_dx     = 0;             // dx     bei @-Einsch�ben
   int         format_dy_pos = 0;             // dy_pos bei @-Einsch�ben
   int         format_dy_neg = 0;             // dy_neg bei @-Einsch�ben
   BoxC        box           = new BoxC();
   int         count         = 0;
   FontMetrics fM            = g.getFontMetrics();
   int         quad          = g.getFont().getSize();
   int         i             = 0; 
   boolean     flag          = false;
   boolean     flag_end      = false;
   boolean     format_flag   = true;
   boolean     array_eqnarray= true;          // default: \begin{array}
   int         times         = 0; // Zahl bei *{xxx}
   int count2 =0;

   if (!expect(EqToken.BeginSym))  return new BoxC(0,0,0);   

   if (eqScan.nextToken().stringS.equals("eqnarray")) array_eqnarray = false;

   if (!expect(EqToken.EndSym, "BEGIN: EndSym")) return new BoxC(0,0,0);  

   if (array_eqnarray) {
     count = eqScan.get_count();
     if (!expect(EqToken.BeginSym)) {
        // NO format-string
        format_flag = false;
        eqScan.set_count(count);
     }
   }


   if (array_eqnarray && format_flag) {
      // *********** Format Angaben erkennen ********* 
      // l left(1)    c center(2)   r right(3)
      // @{...} Einschub statt Zwischenraum(4) 

      EqToken token = new EqToken();
      token = eqScan.nextToken();

      while (token.typ != EqToken.EndSym) {
         StringBuffer SBuffer = new StringBuffer(token.stringS); 
         for (int z=0; z")) {
     g.drawLine(ddh,m,dh,yp);
     g.drawLine(ddh,m,dh,yn);
  }
  else if (Bracket.equals("{")) {
     for (int i=s;i<2+s;i++) {
        int dpi=d+i;
        arc(g,dd+i,ypr,r,180,-60);
        g.drawLine(dpi,ypr,dpi,m-r);
        arc(g,x+i,m-r,r,0,-90);
        arc(g,x+i,m+r,r,0,90);
        g.drawLine(dpi,m+r,dpi,ynr);
        arc(g,dd+i,ynr,r,180,60);
     }
  }
  else if (Bracket.equals("}")) {
     for (int i=s;i<2+s;i++) {
        int dpi=d+i;
        arc(g,x+i,ypr,r,0,60);
        g.drawLine(dpi,ypr,dpi,m-r);
        arc(g,dd+i,m-r,r,-180,90);
        arc(g,dd+i,m+r,r,180,-90);
        g.drawLine(dpi,m+r,dpi,ynr);
        arc(g,x+i,ynr,r,0,-60);
     }
  }
} // drawBracket 

//************************************************************************
private BoxC LEFT(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx_left      = 0;
   int         dx_right     = 0;
   BoxC        box          = new BoxC();
   int         count        = 0;
   Font        localFont    = g.getFont();
   int         quad         = localFont.getSize();
   int         mkq          = (int)(mk * quad);
   int         space        = quad/9;
   Font BracketFont;
   FontMetrics BracketMetrics;

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp)  count = eqScan.get_count();

   // Klammertyp f�r linke Seite vom Scanner holen
   String LeftBracket    = eqScan.nextToken().stringS;

   // Gr��e der Argument-Box berechnen
   box    = eqn(x,y,false,g,rec);
   int dx     = box.dx;
   int dy_pos = box.dy_pos;  
   int dy_neg = box.dy_neg; 
   int yp     = y-dy_pos+1;
   int yn     = y+dy_neg-1;
 
   // Klammertyp f�r rechte Seite vom Scanner holen
   String RightBracket = eqScan.nextToken().stringS;

   // Klammergr��e berechnen
   int BracketSize    = dy_pos+dy_neg-2;

   BracketFont = new Font("Helvetica",Font.PLAIN,BracketSize);
   g.setFont(BracketFont);   
   BracketMetrics = g.getFontMetrics();
   if (LeftBracket.equals("<") || LeftBracket.equals(">")) {
      dx_left = quad;
   }
   else if (BracketSize < mkq) {
      dx_left  = BracketMetrics.stringWidth(LeftBracket);
      if ("([{)]}".indexOf(LeftBracket) >= 0) dx_left += space;
   }
   else dx_left = quad;

   if (RightBracket.equals("<") || RightBracket.equals(">")) {
      dx_right = quad;
   }
   else if (BracketSize < mkq) {
      dx_right = BracketMetrics.stringWidth(RightBracket);
      if ("([{)]}".indexOf(RightBracket) >= 0) dx_right += space;
   }
   else dx_right = quad;
   g.setFont(localFont);

   // hinter Klammer Hoch-/Tiefstellung
   int count2 = eqScan.get_count();
   // "SUB"
   int SUB_dx = 0;
   int SUB_baseline = 0;  
   if (eqScan.nextToken().typ == EqToken.SUB) {
      box    = SUB(x,y,false,g,rec,false);
      SUB_dx=box.dx;
      SUB_baseline = yn+box.dy_pos-(box.dy_pos+box.dy_neg)/2;
      dy_neg += (box.dy_pos+box.dy_neg)/2;
   } else eqScan.set_count(count2); 
   int count1 = eqScan.get_count();

   // "SUP"
   int SUP_dx = 0;
   int SUP_baseline = 0; 
   if (eqScan.nextToken().typ == EqToken.SUP) {
      box    = SUP(x,y,false,g,rec,false);
      SUP_dx = box.dx;
      SUP_baseline = yp+box.dy_pos-(box.dy_pos+box.dy_neg)/2;
      dy_pos += (box.dy_pos+box.dy_neg)/2;
   } else eqScan.set_count(count1); 
   SUB_dx = Math.max(SUB_dx,SUP_dx);

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x+dx_left,y-dy_pos,dx,dy_pos+dy_neg);

      // linker Klammertyp vom Scanner holen
      LeftBracket = eqScan.nextToken().stringS;
      if (!LeftBracket.equals(".")) {
         if (BracketSize < mkq && !(LeftBracket.equals("<") || LeftBracket.equals(">"))) { 
            // linke Klammern mit font zeichnen
            g.setFont(BracketFont);
            g.drawString(LeftBracket,x,yn-BracketMetrics.getDescent()
                                         -BracketMetrics.getLeading()/2);
            g.setFont(localFont);
         } else 
            //linke Klammern direkt zeichnen
            drawBracket (g,LeftBracket,x,dx_left,yp,yn,quad,0);
      }

      // Argument zeichnen
      box = eqn(x+dx_left,y,true,g,rec);

      // rechter Klammertyp vom Scanner holen
      RightBracket = eqScan.nextToken().stringS;
      if (!RightBracket.equals(".")) {
         if (BracketSize < mkq && !(RightBracket.equals("<") || RightBracket.equals(">"))) { 
            // rechte Klammern mit font zeichnen
            g.setFont(BracketFont);
            if ("([{)]}".indexOf(RightBracket) < 0) space = 0;
            g.drawString(RightBracket,x+dx+dx_left+space,yn-BracketMetrics.getDescent()
                                                     -BracketMetrics.getLeading()/2);
            g.setFont(localFont); 
         } else 
            //rechte Klammern direkt zeichnen
           drawBracket (g,RightBracket,x+dx+dx_left,dx_right,yp,yn,-quad,-1); 
      }
      // hinter Klammer Hoch-/Tiefstellung
      count2 = eqScan.get_count();
      // "SUB" 
      if (expect(EqToken.SUB)) 
         box = SUB(x+dx+dx_left+dx_right,SUB_baseline,true,g,rec,false);
      else eqScan.set_count(count2); 
      count1 = eqScan.get_count();
      // "SUP" 
      if (expect(EqToken.SUP)) 
         box = SUP(x+dx+dx_left+dx_right,SUP_baseline,true,g,rec,false);
      else eqScan.set_count(count1); 
    } // end disp
   return new BoxC(dx+dx_left+dx_right+SUB_dx,dy_pos+2,dy_neg+2);  
} // end LEFT

//************************************************************************
private BoxC LIM(int x, int y, boolean disp, Graphics g, int rec){
   int     dx       = 0;
   BoxC    box      = new BoxC();
   int SUB_dx       = 0;
   int SUB_baseline = 0;

   FontMetrics fM       = g.getFontMetrics();
   String stringS = eqTok.stringS;

   // es mu� Scanner sp�ter zur�ckgesetzt werden
   int count = eqScan.get_count();

   int im_dx = dx = fM.stringWidth(stringS);
   int dy_pos = fM.getHeight()-fM.getDescent();
   int dy_neg = fM.getDescent();

   if (expect(EqToken.SUB)) {
      box    = SUB(x,y,false,g,rec,false);
      SUB_dx=box.dx;
      dx = Math.max(dx,box.dx);
      SUB_baseline = box.dy_pos;
      dy_neg = box.dy_pos+box.dy_neg;
   } else eqScan.set_count(count); 
 
   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 
      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
      g.drawString(stringS,x+(dx-im_dx)/2,y);
      if (expect(EqToken.SUB))
         box = SUB(x+(dx-SUB_dx)/2,y+SUB_baseline,true,g,rec,false);
      else eqScan.set_count(count); 
   } // end disp

   return new BoxC(dx,dy_pos,dy_neg);  
} // end LIM

//************************************************************************
private BoxC MBOX(int x, int y, boolean disp, Graphics g) {
   // \mbox{...}  plain text within equations 
   int         dx       = 0; 
   int         dy_pos   = 0;
   int         dy_neg   = 0;
   BoxC        box      = new BoxC();

   // "{" vom Scanner holen
   if (!expect(EqToken.BeginSym)) return new BoxC(0,0,0);  

   while (!eqScan.EoT()) {
      eqTok = eqScan.nextToken();
      if (eqTok.typ != EqToken.EndSym) { 
         box = Plain(x+dx, y, disp, g);
         dx += box.dx;
         dy_pos = Math.max(dy_pos,box.dy_pos);
         dy_neg = Math.max(dy_neg,box.dy_neg);
      }
      else break;
   }

   return new BoxC(dx, dy_pos, dy_neg);  
} // end MBOX

//**********************************************************************
private BoxC NOT(int x, int y, boolean disp, Graphics g, int rec){
// Negation: \not    or \not{  }
   BoxC    box      = new BoxC();

   box    = eqn(x,y,disp,g,rec,false);  

   if (disp) g.drawLine(x + box.dx/4 ,     y + box.dy_neg,
                        x + (box.dx*3)/4,  y - box.dy_pos );
   return box;  
} // end NOT

//************************************************************************
private BoxC Op(int x, int y, boolean disp, Graphics g) {
// Operatoren
   FontMetrics fM       = g.getFontMetrics();
 
   if (disp) g.drawString(eqTok.stringS,x+1,y);
   return new BoxC(fM.stringWidth(eqTok.stringS) + 2,
                   fM.getHeight()-fM.getDescent(),
                   fM.getDescent());  
} // end Op

//*************************************************************************
private BoxC OverBRACE(int x, int y, boolean disp, Graphics g, int rec) {
   int         count    = 0;
   BoxC        box      = new BoxC();
   int r                = g.getFont().getSize()/4;
   int rh               = r/2;
   int SUP_dx           = 0;
   int SUP_base         = 0;
   int SUP_dy           = 0;

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count(); 

   // Gr��e der Argument-Box berechnen
   box          = eqn(x,y,false,g,rec,false);
   int dx       = box.dx;
   int dxh      = dx/2;
   int x_middle = dxh;
   int dy_pos   = box.dy_pos;
   int dy_neg   = box.dy_neg;

   // "SUP" behandeln, FALLS vorhanden
   int count1 = eqScan.get_count();
   if (expect(EqToken.SUP)) {
      box      = SUP(x,y,false,g,rec,false);
      SUP_dx   = box.dx;
      x_middle = Math.max(x_middle,SUP_dx/2);
      SUP_base = dy_pos     + box.dy_neg;
      SUP_dy   = box.dy_pos + box.dy_neg;
   } else eqScan.set_count(count1); 

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count);
      int xx   = x + x_middle-dxh;  
      box      = eqn(xx, y, true, g, rec, false);
      int rred = (int)(r*0.86602540378444);
      for (int i=0;i<2;i++) {
         int ypi = y-dy_pos-rh+i;
         arc(g,xx+rred,ypi+r,r,90,60);
         g.drawLine(xx+rred,ypi,xx+dxh-r,ypi);
         arc(g,xx+dxh-r,ypi-r,r,0,-90);
         arc(g,xx+dxh+r,ypi-r,r,-90,-90);
         g.drawLine(xx+dxh+r,ypi,xx+dx-rred,ypi);
         arc(g,xx+dx-rred,ypi+r,r,90,-60);
      }
      count1 = eqScan.get_count();
      if (expect(EqToken.SUP)) 
         box = SUP(x+x_middle-SUP_dx/2, y-SUP_base-r-rh,true,g,rec,false);
      else eqScan.set_count(count1); 
   } // end disp

   dy_pos += SUP_dy + r + rh ;
   dx = Math.max(dx,SUP_dx);

   return new BoxC(dx,dy_pos,dy_neg); 
} // end OverBRACE


//*************************************************************************
private BoxC UnderBRACE(int x, int y, boolean disp, Graphics g, int rec) {
   int         count    = 0;
   BoxC        box      = new BoxC();
   int r                = g.getFont().getSize()/4;
   int rh               = r/2;
   int SUB_dx           = 0;
   int SUB_base         = 0;
   int SUB_dy           = 0;

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count(); 

   // Gr��e der Argument-Box berechnen
   box      = eqn(x,y,false,g,rec,false);
   int dx       = box.dx;
   int dxh      = dx/2;
   int x_middle = dxh;
   int dy_pos   = box.dy_pos;
   int dy_neg   = box.dy_neg;

   // "SUB" behandeln, FALLS vorhanden
   int count1 = eqScan.get_count();
   if (expect(EqToken.SUB)) {
      box      = SUB(x,y,false,g,rec,false);
      SUB_dx   = box.dx;
      x_middle = Math.max(x_middle,SUB_dx/2);
      SUB_base = dy_neg     + box.dy_pos;
      SUB_dy   = box.dy_pos + box.dy_neg;
   } else eqScan.set_count(count1); 

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 
      int xx   = x + x_middle-dxh;  
      box      = eqn(xx, y, true, g, rec, false);
      int rred = (int)(r*0.86602540378444);
      for (int i=0;i<2;i++) {
         int ypi = y+dy_neg+rh-i;
         arc(g,xx+rred,ypi-r,r,-90,-60);
         g.drawLine(xx+rred,ypi,xx+dxh-r,ypi);
         arc(g,xx+dxh-r,ypi+r,r,90,-90);
         arc(g,xx+dxh+r,ypi+r,r,90,90);
         g.drawLine(xx+dxh+r,ypi,xx+dx-rred,ypi);
         arc(g,xx+dx-rred,ypi-r,r,-90,60);
      }
      count1 = eqScan.get_count();
      if (eqScan.nextToken().typ == EqToken.SUB) 
         box = SUB(x+x_middle-SUB_dx/2, y+SUB_base+r+rh,true,g,rec,false);
      else eqScan.set_count(count1); 
   } // end disp

   dy_neg += SUB_dy + r + rh ;
   dx = Math.max(dx,SUB_dx);

   return new BoxC(dx,dy_pos,dy_neg); 
} // end UnderBRACE

//************************************************************************
private BoxC OverUnderLINE(int x, int y, boolean disp, Graphics g, int rec, 
                          boolean OverUnder) {
   int         count    = 0;
   BoxC        box      = new BoxC();
  
   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count(); 

   // Gr��e der Argument-Box berechnen
   box = eqn(x,y,false,g,rec,false);
   if (OverUnder)  box.dy_pos += 2; // Platz �ber Strich
   else            box.dy_neg += 2; // Platz unter Strich
   int dy_pos=box.dy_pos;
   int dy_neg=box.dy_neg;
   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 
      if (OverUnder)  g.drawLine(x+1, y-dy_pos+2, x+box.dx-1, y-dy_pos+2);
      else            g.drawLine(x, y+dy_neg-2, x+box.dx, y+dy_neg-2);
      box = eqn(x,y,true,g,rec,false);
   } 
   return new BoxC(box.dx,dy_pos,dy_neg); 
} // end OverUnderLINE

//************************************************************************
private BoxC Paren(int x, int y, boolean disp, Graphics g){
   FontMetrics fM = g.getFontMetrics();
   int space      = g.getFont().getSize()/9;
   int dx         = fM.stringWidth(eqTok.stringS);
   int i = "([{)]}".indexOf(eqTok.stringS);
   if (i >= 0) {
      dx += space;
      if (i > 2 ) x += space;
   }
   if (disp) g.drawString(eqTok.stringS,x,y);
   return new BoxC( dx,
                    fM.getHeight()-fM.getDescent(),
                    fM.getDescent());
} // end Paren

//************************************************************************
private BoxC Plain(int x, int y, boolean disp, Graphics g){
   FontMetrics fM       = g.getFontMetrics();

   if (disp) g.drawString(eqTok.stringS,x,y);
   return new BoxC( fM.stringWidth(eqTok.stringS),
                    fM.getHeight()-fM.getDescent(),
                    fM.getDescent());
} // end Plain

//************************************************************************
private BoxC SPACE(int x, int y, boolean disp, Graphics g){
   // additional positive or negative space between elements
   int         dx     = 0;
   Font font = g.getFont();
   try                            { dx = Integer.parseInt(eqTok.stringS);}
   catch (NumberFormatException e){ dx = 0; }
   dx     =  ( dx * font.getSize()) / 18;
   return new BoxC(dx,0,0);  
} // end SPACE

//************************************************************************
private BoxC SQRT(int x, int y, boolean disp, Graphics g, int rec) {
   BoxC        box      = new BoxC();
   int         count    = 0;
   FontMetrics fM       = g.getFontMetrics();
   int dx_n             = 0;
   int dy_pos_n         = 0;
   int dy_neg_n         = 0;
   int dy_n             = 0;
   boolean n_sqrt       = false;

   // nur bei disp=true mu� Scanner sp�ter zur�ckgesetzt werden
   if (disp) count = eqScan.get_count();

   // etwas Platz f�r den Haken der Wurzel
   int dx_Haken  = fM.stringWidth("A");
   int dx_Hakenh = dx_Haken/2;


   // \sqrt[...]{...}
   int     count1 = eqScan.get_count();
   EqToken token  = new EqToken();
   token          = eqScan.nextToken();
   if (token.stringS.equals("[")) {
      // Gr��e der [n.ten] Wurzel
      rec_Font(g,rec+1);
      box    = eqn(x,y,false,g,rec+1,true);
      rec_Font(g,rec);
      dx_n     = box.dx;
      dy_pos_n = box.dy_pos;
      dy_neg_n = box.dy_neg;
      dy_n     = dy_neg_n + dy_pos_n;
      n_sqrt   = true;
   } 
   else eqScan.set_count(count1);  

   // Gr��e der Argument-Box berechnen
   box    = eqn(x,y,false,g,rec,false);
   int dx     = box.dx +  dx_Haken;
   int dy_pos = box.dy_pos + 2;  // zus�tzlicher Platz �ber Querstrich
   int dy_neg = box.dy_neg; 

   if (n_sqrt & dx_n>dx_Hakenh) dx += dx_n - dx_Hakenh;

   // nur bei disp=true wird Scanner zur�ckgesetzt
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
 
      // Wurzelzeichen
      int dx_n_h = 0;
      if (n_sqrt & dx_n > dx_Hakenh) dx_n_h = dx_n - dx_Hakenh;
      g.drawLine(x+dx_n_h+1,y-dy_pos/2,           x+dx_n_h+dx_Hakenh,y+dy_neg-1);
      g.drawLine(x+dx_n_h+dx_Hakenh,y+dy_neg-1,  x+dx_n_h+dx_Haken-2,y-dy_pos+2);
      g.drawLine(x+dx_n_h+dx_Haken-2,y-dy_pos+2,  x+dx,y-dy_pos+2 );

      if (n_sqrt) {
         token  = eqScan.nextToken(); 
         rec_Font(g,rec+1);
         if (dx_n>=dx_Hakenh){
               g.drawLine(x+1,y-dy_pos/2, x+dx_n_h+1,y-dy_pos/2);
               box = eqn(x+1,y- dy_pos/2 - dy_neg_n-1,true,g,rec+1,true);
         }
         else  box = eqn(x+1+(dx_Hakenh-dx_n),y- dy_pos/2 - dy_neg_n-1,true,g,rec+1,true);
         rec_Font(g,rec);
      }

      // Argument zeichnen
      box = eqn(x+dx_n_h+dx_Haken,y,true,g,rec,false);

   } // end disp

   if (n_sqrt & dy_pos/2 deren Gr��e zur�ckgibt.                      **
//***********************************************************************
class BoxC {
  public int dx;
  public int dy_pos;
  public int dy_neg;
  
  public BoxC(int dx, int dy_pos, int dy_neg) {
     // Constructor MIT Initialisierung
     this.dx     = dx;
     this.dy_pos = dy_pos;
     this.dy_neg = dy_neg;  }

  public BoxC() {
     // Constructor OHNE Initialisierung
     this.dx     = 0;
     this.dy_pos = 0;
     this.dy_neg = 0;  }   
} // end class BoxC


//*************************************************************
//** Filter-Class, die als R�ckgabewert das Pixel veraendert **
//** mit mask wird der RGB-Farbwert rrggbb vorgegeben, der   **
//** den Farbwert schwarz ersetzt.                           **
class ColorMaskFilter extends RGBImageFilter {
  Color color;
  boolean maskORinvert = false;

//Filter for normal Image
  ColorMaskFilter (Color mask) {
    color = mask;
    maskORinvert = false;
    canFilterIndexColorModel = true;
  }

//Filter for highlight
  ColorMaskFilter (Color mask, boolean maskB) {
    color = mask;
    maskORinvert = maskB;
    canFilterIndexColorModel = true;
  }

  public int filterRGB(int x, int y, int pixel) {
    if (maskORinvert)  return 0x1fff0000;  // rot transparent
    int p = pixel & 0xffffff;
    if (p == 0xffffff) {return p;} else {return 255 << 24 | color.getRGB();} 
  }

} // end ColorMaskFilter

// SymbolLoader for packed font files (fast speed)
class SymbolLoader {
private ImageProducer [] imageSources = {null,null,null,null,null};
private String [] fontsizes = {"8","10","12","14","18"};	
private Hashtable fontdesH = new Hashtable (189);
//Fonts are included in HotEqn zip/jar file
private static boolean kLocalFonts=true;

public SymbolLoader() { }
// dummy constructor

public Image getImage( boolean  appletB, boolean beanB, String filenameS,
                Graphics g,      Applet   app) {
	StringTokenizer st = new StringTokenizer(filenameS, "/");
	String fontsize = st.nextToken();
	fontsize = (st.nextToken()).substring(5);
	String fn = st.nextToken();
	int	k =	-1;
	for	(boolean loop =	true; loop;) {
		if (fontsizes[++k].equals(fontsize)) loop=false;
		if (k==4) loop=false;
	}
	//System.out.println(fontsizes[k]);
	if (imageSources[k] == null) { 			
		imageSources[k]=getBigImage(appletB, beanB,  "Fonts"+fontsize+".gif",  app);
		String desname = "Des"+fontsize+".gif";
		BufferedInputStream istream = null;
		// load font descriptors
		try {
			if (kLocalFonts) {
				InputStream ip = getClass().getResourceAsStream(desname);
				//System.out.println("ip");
				istream = new BufferedInputStream(getClass().getResourceAsStream(desname));
				//System.out.println("nlocal");
			} else {
				//Try loading external Font files in component/applet/bean specific manner
				if (!appletB & !beanB) {
					// component code
					istream = new BufferedInputStream((new URL(desname)).openStream());
				} else if (appletB) { 
					// applet code
					istream = new BufferedInputStream((new URL(app.getCodeBase(), desname)).openStream());
					//System.out.println("file");
				} else {
					// bean code
					// beanB==true
					try {
						istream = new BufferedInputStream(getClass().getResource(desname).openStream());
					} catch (Exception ex) { }
				}
			}
			ObjectInputStream p = new ObjectInputStream(istream);
			int len = (int)p.readInt();
			for (int i=0;i imageBytes.length) {  //haven't yet allocated enough space
          byte[] tempImageBytes= (byte[]) imageBytes.clone();
          imageBytes = new byte[totalBytes];
          System.arraycopy(tempImageBytes, 0, imageBytes, 0, alreadyRead);
        }
      }
      if (numBytes == 0) break;
    }
    //Create an ImageProducer from the image bytes
    source = Toolkit.getDefaultToolkit().createImage(imageBytes).getSource();
  }
  catch (Exception io) {}
  return source;
} // end getLocalImageSource

} // end class SymbolLoader

/* 
// SymbolLoader for unpacked font files (slow speed)
class SymbolLoader {

public SymbolLoader() { }
// dummy constructor

//Fonts are included in HotEqn zip/jar file
private static boolean kLocalFonts=true;

public Image getImage( boolean  appletB, boolean beanB, String filenameS,
                Graphics g,      Applet   app) {
  ImageProducer imageSource=null;
  Image image=null;

  if(kLocalFonts) {
    imageSource = getLocalImageSource(filenameS);
  }
  if(imageSource==null) { //Fonts are not local
    kLocalFonts=false;  //don't attempt to load local fonts anymore

    //Try loading external Font files in component/applet/bean specific manner
    if (!appletB & !beanB) {
      // component code
      imageSource=Toolkit.getDefaultToolkit().getImage( filenameS ).getSource();
    } else if (appletB) { 
      // applet code
      imageSource= app.getImage(app.getCodeBase(), filenameS ).getSource();
    } else {
      // bean code
      // beanB==true
      try {
        URL url = getClass().getResource(  filenameS );
        imageSource = (ImageProducer) url.getContent();
      } catch (Exception ex) {
      }
    }
  }
  if(imageSource!=null) {
    image = Toolkit.getDefaultToolkit().createImage(new FilteredImageSource(
               imageSource, new ColorMaskFilter(g.getColor())));
  }
  return image;
} // end getImage

ImageProducer getLocalImageSource(String resourceName) {
  //Try loading images from jar
  ImageProducer source = null;
  try {
    // Next line assumes that Fonts are in the same jar file as SymbolLoader
    // Since resourceName doesn't start with a "/", resourceName is treated
    // as the relative path to the image file from the directory where
    // SymbolLoader.class is.
    InputStream imageStream = getClass().getResourceAsStream(resourceName);
    int numBytes = imageStream.available();//System.out.println(numBytes);
    byte[] imageBytes = new byte[numBytes];
//System.out.println(numBytes);
    // Note: If all bytes are immediately available, the while loop just
    // executes once and could be replaced by the line:
    // imageStream.read(imageBytes,0,numBytes);
    // This may always be the case for the small Font images

    int alreadyRead = 0;
    int justRead = 0;
    while (justRead != -1) {
      justRead = imageStream.read(imageBytes,alreadyRead,numBytes);
      if(justRead != -1) { //didn't get all the bytes
        alreadyRead += justRead; //Total Read so far
        numBytes = imageStream.available(); //Amount left to read
        int totalBytes = alreadyRead + numBytes; //total bytes needed to
                                                 //store everything we know about
//System.out.println("+"+numBytes);
        if((totalBytes) > imageBytes.length) {  //haven't yet allocated enough space
          byte[] tempImageBytes= (byte[]) imageBytes.clone();
          imageBytes = new byte[totalBytes];
          System.arraycopy(tempImageBytes, 0, imageBytes, 0, alreadyRead);
        }
      }
    }
    //Create an ImageProducer from the image bytes
    source = Toolkit.getDefaultToolkit().createImage(imageBytes).getSource();
  }
  catch (Exception io) {}
  return source;
} // end getLocalImageSource

} // end class SymbolLoader
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Fonts14.gif0000644000175000017500000002102211272077141026134 0ustar  giovannigiovanniGIF89a,by*S)XjulUW6X.n:-͕rk56ads@R"(Z#09waN#'4]Pv&zǥGAgb6Iv(CWQy&sR'6XIV5:(ԄE	XjI:Ӛ((wx[
XS|Dz	r<
ʮ6OO\">
ҩzjlg
Z,ZwbzR&0v^y7B?)c8Qx1c>;4eŗN=H0TvGٴ/|$4_Q	ᴡ`NdlVv4kJ4Yn9h6_g'HFkaQwպF_rHx;#)YyNbɴ)luX`]\ƫC^2ӓpú]
y)Na+w!yIQ'^X剅֧[;>ݟu%'`qg%a^`ug{~b
x"Xم	d	(Hcj"G|<dB
fT~6dN>y/B	g QeZ.'梗b	d4Րٝ9tnIgU\dkJ6a^%g7~[,!s]kDgVSDw
:mT9VfŦQSbZjoѤC
ٔ)0J]dJiym߰HdN{6M,PYA8%
e$h@KOrgv2ۺ-bIO?衮H+f[TW|Ŏ6Zm@Kz.(8v,,JF,1,ajpflK	,N	*Cсܫ2~"\"JoDcJ13:pRC-0%%Od#+	V/wpɵ̈́+T+eE6~uˇ7MvHgCxmNNBg,꥓ꮿ.N{Vl{;O|/|?}OO=6x( CsR^Ռ.E@`/tl!nuTٳ,-~'%p#4q:#E}"@JKڐA5-V{WI4S\2X
rN!OZyOy+K&HQ dqqEhåR9=@|D[kE/H"j9
Og<!w#eda?M'ߓ9
9,]G$:
H6E&!F%GxO>_#ّIiE(t|e"ȡ\ꒌsPPZ1K3*a|1mK08LqiTZAIg}|$igYzHj~J(h=!TB,}E)UB螋ZD>ǝR -Mt{\JҘΥ2McԦ4ݩOWZ)t{*۠ΗfX7_ښ̈2B_VTU#*d)wp`(dO4E&6no'yΙvdYYh.BOuhj{
&̔VfWQ~cg
!Tr%M*+c3pmQڰxLb)Gжd%WI˜֬epʘדe87[N@E+5˜[䎐,:Zhvc[Kյm/7v_򮤠,3G7.]jJ띒%/<9Ä
 ~#!֬*m|"k^]vĥtOʭ	q,^"O,>Fꕙ$uыVC^jzC>qIb47P^p`
4
Gdb!z2NCehACk+!::/|-׽B'J>Tͤ'g#5X\)VjKN2`7[w+͎xAmڍ(M#,uqn]û+:6y=i?d7b>™8^=mϑZhVWg.VOI-k|NݸYv
N~RJ?!da6u'~mG<%Z}v
&=D$<mΨ'qXzIz!,+Z~o~ϝdA[2oyh*N46a"^Q.sgWs
b@=v^vrj5e#lW8t=Lw|(MTn7GzxmwlvvDOO0/WA?~=l5%&~~K#~7m8N[Tn(wEM$y hwx`he[J|QK/9wfJ1f~Ƅ;a!U:8Ba7p/5օB$6q}RHP}EsDdUp_%ZiCAR_Ŧ7uY}q[b"yG	8bhMֆ!WJWeЉz7DAͳxhM"w{ebaH:Wf^؋389(HhŘ>9paO[ǀLD/%[xx-&Xer=Lh	ՁF`s
0ox  h	ZpJɡFx;)O,( 䇁*8@\W}Iu6vXϒ{q%i+'bgմsɚSuE.F_f6yp2O]0e 2TؖLHXGxJXR>Y1g~{XVdZ!jݳ9l*ke.^@WGfQCsst{[zxЙ^ۙlj֦-{E^MZ1Ţ3y).*m"i˔OzXpT3ZdZyrwɕ	!ǘ**}ʩګu:P"vJo3q8GJկk;Z&Hpj3w
;ְʡ#O'ؚ%+˲è1K5k79;;T:q=JDII珂!WLZcE^\vfJrH(3^kjKHR76ku~Kr,6O|Erú1BuUEvˋ,1f2xjELK[oT"zj>9MC"x:I׮hiVXy5CLmե&izAa+6ɸ{yB,G[msKk1hiȋHk.ktK{4xK`uX)H0ۊ{p„AW׋ay!|Q6©p@)ɿ.vChk+J)jD0-džZd9>W{&
⩫D%PfETT5NJ:sԃUp+^A8>!
D\MEBUm'f$l@lS<_ۣ.#-nEqe^WTN^`ʳUhX-2}\iMJ=Ş.%G~\^9Θn^^~D;Sّz\TnEdFz̷N\ͪ]-Թ
J}r.	ϬdS|̀D+?N|Ǿ8ۉ*MCKl _@&'_RU'md\^-γcmoq/sOmV*YYAZ=JvH^L1.R*u5Iڍ/El
Nx⨕o
v^[[B_hx$c[	,邿]_9{-/xb
.V@	k}e)_N]x<ÉHe9B0nvnvM1u9{!0Ǝ35އ:$gFwUS=ol*OtB(1g]a[,N&Wv7
3zHnֲܘ憰Ш!u\"\.7

yfz8UAcW+a!=XRFIE9PSiɈ<B-iDvx+FL9q'AU1?r8
YqUB1bc-;29d /vTȉ(9gqXgO?Wʋ~ӯ\V|]c4,0ţzȟsOvio[
8XS	MXI_g]s:;>5|
fp߿|>+{?u#7Sn%Iu/͈h|3k;/[
z<t)VBAOBaΰqPoP<;FBDӎ-htF%IdBQ&mь4 MrDo25.Ü(#sƵN84Pms/
1ERAK9STQIe4RQMӻTm՞|UYU[qU]y_
6E˓:1۫N|$*CR*írPb4DʡF!3r66
YEQ0k6g6s]Hy2u?-[seӣuwKBzdz|8e%E
X)}y˗$j3lQȊmoF(̴hآM(eMY~jG+ĘCm9Q8WLxklvcr綗͵۷%|;gvJ1]I4p^hqa5wqE[o+wɜ`ն.|#f\eMU'U9H~1x
&'ݧO[Y^Rblߗ/VlN{PdDK-Տ__UAiOA~M9p";PWMYRS@=!X T'AM*:iTR41Y7fB!,׃EsbBqx>a

&lQDi~X/Ub>ܜx@-IBn؂Lg?+ΰպ9pW$6>yq蹵KmdY7Qo["6G(Aׄ2{38nU,H104\K"PlR<+K.KH -3+шʦ-iWD&1	k&o41Cp3](͠s]&
hlÃ%<_~jBa\YQjBi\ß=b9aUV,hIT	Utr<کf>ML<~ҨMuSUNUh|I]KSjSOAIHr+p^y/ETr.TS?(:t/Mh!6eLòTA2ۊ:KZȑWet%,^Φ3Vǒ\fIymPmL$m5WiTb4tV6-[=Ta5ZAJqt.Ě1	:\].lKXxYAd򲏓:X庺,kH7#Uɞ]')tո2K"
ߢLYxHPfVeV΄0*n=QDME[aS͠XGq*gacg9d!E6򑑜d%/MvɲZnfe
)"k7.,p(:ޙƀ6ZH3Wѹj'\~.Snlh*SN忺iKͨ)#XdhD%c=%QVKDs1J[YWPяl'TYoKAYiVlnvgL({ͻ.7W}rY:\^d٫	h-VuX&3ӲMmzV5q
Q,?qMWq7E5y
Tuѷ)|-w~1.ӚNy(35Üɓ[S=ρtE7zߩ
ί\].Ri=TJ
0qϑYZa{yM
gwN3s>4˼8n~ujZ8焯[M<?t-ܵ5%xR6bmك?O,AQZ)L1p-#3xGr׻'̛Qq~v+CScKՋ-e̍wߝh[~]Kh)ýicדMZ${lnr͎.--%dLhmjf:ХW+T.M2ltx0p0	Pfpp&&`r!ZKŜhEpNp_喀!(ƒj<	DmN0ԨD`PN
6
hָ+=PQLj:*Z۞ѦBˌq(o_vD=q9
V>,AOvƏ"M:za@n<ћZ@٤.1jٜCUv.ig	C4᲏V~zа &d wLo	8#A2$Er$I$M$
Q2%Ur%Y%Q;mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/sHotEqn.java0000644000175000017500000033464711374677025026471 0ustar  giovannigiovanni/*****************************************************************************
*                                                                            *
*                 HotEqn Equation Viewer Swing Component                     *
*                                                                            *
******************************************************************************
* Java-Coponent to view mathematical Equations provided in the LaTeX language*
******************************************************************************

Copyright 2006 Stefan Muller and Christian Schmid

This file is part of the HotEqn package.

    HotEqn is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; 
    HotEqn is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .

******************************************************************************
*                                                                            *
* Constructor:                                                               *
*   sHotEqn()                Construtor without any initial equation.        *
*   sHotEqn(String equation) Construtor with initial equation to display.    *
*   sHotEqn(String equation, JApplet app, String name)                       *
*                            The same as above if used in an applet          *
*                            with applet name.                               *
*                                                                            *
* Public Methods:                                                            *
*   void setEquation(String equation)  Sets the current equation.            *
*   String getEquation()               Returns the current equation.         *
*   void setDebug(boolean debug)       Switches debug mode on and off.       *
*   boolean isDebug()                  Returns the debug mode.               * 
*   void setFontname(String fontname)  Sets one of the java fonts.           *
*   String getFontname()               Returns the current fontname.         *
*   void setFontsizes(int g1, int g2, int g3, int g4) Sets the fontsizes     *
*                                      for rendering. Possible values are    *
*                                      18, 14, 16, 12, 10 and 8.             *
*   void setBackground(Color BGColor)  Sets the background color.            *
*                                      Overrides method in class component.  *           
*   Color getBackground()              Returns the used background color.    *
*                                      Overrides method in class component.  *           
*   void setForeground(Color FGColor)  Sets the foreground color.            *
*                                      Overrides method in class component.  * 
*   Color getForeground()              Returns the used foreground color.    *
*                                      Overrides method in class component.  * 
*   void setBorderColor(Color border)  Sets color of the optional border.    *
*   Color getBorderColor()             Returns the color of the border.      * 
*   void setBorder(boolean borderB)    Switches the border on or off.        * 
*   boolean isBorder()                 Returns wether or not a border is     *
*                                      displayed.                            *
*   void setRoundRectBorder(boolean borderB)                                 *
*                                      Switches between a round and a        *
*                                      rectangular border.                   *
*                                      TRUE: round border                    *
*                                      FALSE: rectangular border             *
*   boolean isRoundRectBorder()        Returns if the border is round or     *
*                                      rectangular.                          *
*   void setEnvColor(Color env)        Sets color of the environment.        *
*   Color getEnvColor()                Returns the color of the environment. * 
*   void setHAlign(String halign)      Sets the horizontal alignment.        *
*                                      Possible values are: left, center and *
*                                      right.                                *
*   String getHAlign()                 Returns the horizontal alignment.     *
*   void setVAlign(String valign)      Sets the vertical alignment.          *
*                                      Possible values are: top, middle and  *
*                                      bottom.                               *
*   public String getVAlign()          Returns the vertical alignment.       *
*   void setEditable(boolean editableB)  Makes the component almost editable.*
*                                      Parts of the displayed equation are   *
*                                      selectable when editable is set true. *
*                                      This is turned on by default.         *
*   boolean isEditable()               Returns wether or not the equation    *
*                                      is editable (selectable).             *
*   String getSelectedArea()           Return selected area of an equation.  *
*   Dimension getPreferredSize()       Returns the prefered size required to *
*                                      display the entire shown equation.    *
*                                      Overrides method in class component.  *
*   Dimension getMinimumSize()         This method return the same value as  *
*                                      getPreferedSize                       *
*                                      Overrides method in class component.  *
*   Dimension getSizeof(String equation) Returns the size required to        *
*                                      display the given equation.           *
*   void addActionListener(ActionListener listener)                          *
*                                      Adds the specified action listener to *
*                                      receive action events from this text  *
*                                      field.                                *
*   void removeActionListener(ActionListener listener)                       *
*                                      Removes the specified action listener *
*                                      to receive action events from this    *
*                                      text field.                           *
*   Image getImage()                   Returns the HotEqn image              *  
*                                                                            *
******************************************************************************
************  Version 0.x                *************************************
* 15.07.1996  Start.                                                         *
* 18.07.1996  Parameter Expansion                                            *
* 22.07.1996  Scanner: Token Table                                           *
* 24.07.1996  Fraction \frac{ }{ }                                           *
* 25.07.1996  Root \sqrt{}, Tief _, High ^, recursive. Font.                 *
* **********  Version 1.0                *************************************
* 26.07.1996  Array \array                                                   *
* 29.07.1996  Parentheses \left ( | \{ \[ \right ) | \} \]                   *
*             public setEquation(String equation) for JS                     *
* 30.07.1996  Greek symbols in Scanner                                       *
* 04.08.1996  Greek Symbols isolation to be downloaded from the net.         *
* 05.08.1996  Greek character set refresh (black and white Prob.)               *
* **********  Version 1.01               *************************************
* 29.08.1996  \sum Sum, \prod Product                                        *
* **********  Version 1.02               *************************************
* 23.09.1996  Various large \bar \hat \acute \grave \dot                   *
*             \tilde \ddot                                                   *
* **********  Version 1.03               *************************************
* 24.09.1996  Handing over mechanism between the various                     *
*             applets on an HTML page.                                       *
* **********  Version 1.04               *************************************
*             evalMFile at mouse-click (->JS->Plugin)                        *
*             engGetFull                                                     *
* 14.10.1996  Matrix2LaTeX retrieves current matrix by the plugin            *
*               and calls on setRightSide.                                   *
* 15.10.1996  All plugin functions with arguments that have to               *
*                the argument from JS fetch "var VCLabHandle"                *
************  Version 1.05               *************************************
* 18.10.1996  Solution Applet -> Plugin (everything back to results !!)      *
************  Version 1.1                *************************************
* 04.01.1997  Integral \int_{}^{}                                            *
*             Limits \lim \infty \arrow                                      *
* 22.01.1997  Corrected the engGetFull() method                              *
******************************************************************************
**************   Release of Version 2.0  *************************************
*                                                                            *
*        1997 Chr. Schmid, S. Mueller                                        *
*             Redesigned for Matlab 5                                        *
* 05.11.1997  Renaming of the parameters                                     *
*             old:             new:                                          *
*             engEvalString    mEvalString                                   *
*             eval             mEvalString                                   *
*             evalMFile        mEvalMFile                                    *
*             engGetFull       mGetArray                                     *
*             Matrix2LaTeX     mMatrix2LaTeX                                 *
* 09.11.1997  Background and Foreground Color, Border, Size                  *
* 10.11.1997  Separation into HotEqn(no MATLAB) and mHotEqn(MATLAB) version  *
* 12.11.1997  Scanner compactified, parser small changes:                    *
*             new methof: adjustBox for recalculation of box size after      * 
*             function calls.                                                *
*             \sin \cos .... not italics                                     *
* 16.11.1997  setEquation(String LeftSideS, String RightSideS) method added  *
* 23.11.1997  Paint not reentrant                                            *
* 13.11.1997  Binary operators         (Kopka: LaTeX: Kap. 5.3.3) prepared   * 
*  (2.00c)    quantities and their negation    ( "    Kap. 5.3.4)    "       *
*             Arrows                           ( "    Kap. 5.3.5)    "       *
*             various additional symbols       ( "    Kap. 5.3.6)    "       *
*             additional horizontal spaces \, \; \: \!            prepared   *
*             \not                                                prepared   *
* 29.11.1997  Scanner optimized (2.00d)                                      *
* 30.11.1997  Paint buffered (2.00e)                                         *
* 03.12.1997  horizontal spaces, \not, \not{} implemented       (2.00f) *
* 06.12.1997  ! cdot cdots lim sup etc. ( ) oint arrows some symb.   (2.00g) *
* 08.12.1997  left and right []                                      (2.00h) *
* 08.12.1997  default font plain                                     (2.00i) *
* 11.12.1997  SINGLE (false) argument and STANDARD (true)                    *
*             (e.g. \not A or \not{a+B} ) for all commands, where single     *
*             or multiple arguments are allowed (_ ^ \sum ... )      (2.00j) * 
* 13.12.1997  A_i^2 (i plotted over 2, according to LaTex)           (2.00k) *
* 14.12.1997  LaTeX Syntax for brackets, beautified array,frac,fonts (2.00l) *
* 18.12.1997  scanner reduced to one scan, tokens now stored in array(2.00m) *
* 19.12.1997  all bracket types implemented by font/draw             (2.00n) *
* 20.12.1997  bracket section new, Null,ScanInit deadlock removed    (2.00o) *
* 22.12.1997  separation of HotEqn.java EqScanner.java EqToken.java  (2.00p) *
*             \choose \atop                                                  *
* 26.12.1997  overline underline overbrace underbrace stackrel       (2.00q) *
*             \fgcolor{rrggbb}{...} \bgcolor{rrggbb}{...}            (2.00r) *
* 30.12.1997  ScanInit,setEqation combined \choose modified to \atop (2.00s) *
*             and some other minor optimizations                             *
* 31.12.1997  overline underline sqrt retuned                        (2.00t) *
*             overbrace and underbrace uses arc, new <> Angle                *
*             right brackets with SUB and SUP                                *
* 31.12.1997  getWidth()  getHeight() Ermittl. d. Groesse v. aussen  (2.00u) *
*             \begin{array}{...} ... \end{array}                             *
* 01.01.1998  Tokens stored dynamically (limit 500 tokens removed)   (2.00v) *
*             Some minor optimization in serveral functions                  *
* 02.01.1998  \fbox \mbox \widehat \widetilde                        (2.00w) *
* 02.01.1998  drawArc used for brackets, \widetilde good             (2.00x) *
* 03.01.1998  expect()-methods to check on expected tokens           (2.00y) *
* 04.01.1998  redesign of thread synchronization, getWidth|Height OK (2.00y1)*
*             some minor optimization in parser and documentation            *
* 04.01.1998  minor error with SpaceChar corrected                           *
*             \begin{eqnarray} implemented                           (2.00z) * 
* 08.01.1998  minor corrections for TeX-generated fonts              (2.00z1)*
* 09.01.1998  *{} for \begin{array} implemented                      (2.00z2)*  
* 13.01.1998  new media tracking, cached images, FGBGcolor corrected (2.00z4)* 
* 15.01.1998  Synchronisation with update changed because of overrun (2.00z5)* 
*             Default space for erroneous images                             *
*                                                                            *
* 17.01.1998  Separation into HotEqn and dHotEqn version.            (2.01)  *
*             HotEqn is only for Eqn. viewing and dHotEqn includes           *
*             all public methods. The mHotEqn is now based on dHotEqn.       *
*             Hourglass activity indicator added.                            *
* 18.01.1998  Image cache realized by hash table                     (2.01a) *
* 06.02.1998  New align parameter halign, valign. Correct alignment  (2.01b) *
* 27.02.1998  \sqrt[ ]{}                                             (2.01c) *
* 04.03.1998  Better spacing within brackets                         (2.01d) *
******************************************************************************
*     1998    S. Mueller, Chr. Schmid                                        *
* 19.01.1998  AWT component for use in other applications (like buttons,     *
*             scrollbars, labels, textareas,...)                     (2.01b) *
* 10.03.1998  adjustments                                            (2.01b1)*
* 11.03.1998  migration to JDK1.1.5                                  (2.01d1)*
* 14.03.1998  migration to the new event model and public methods    (2.01d2)*
* 20.03.1998  setPreferredSize() setMinimumSize()                    (2.01d3)*
* 04.04.1998  this.getSize()... in paint reinstalled.                (2.01d4)*
*             PropertyChange... ---> automatic resize of bean                *
* 11.04.1998  java-files renamed cHotEqn.java --> bHotEqn.java (Bean)(2.01d5)*
*             setBorder() setRoundRectBorder()                               *
* 12.04.1998  partial rearranging of variables and methods                   *
*             bHotEqn -> separated into cHotEqn & bHotEqn            (2.02)  *
* 26.04.1998  possible workarround for getImage()-problem            (2.02a) *
* 27.04.1998  Toolkit.getDefaultToolkit().getImage() is buggy for            *
*             Netscape 4.04 and 4.05 (JDK1.1x) (see getSymbol(...)           *
* 02.05.1998  image-loading problem solved                           (2.02b) *
*             output to System.out only if debug==true                       *
* 09.05.1998  selectable equations     (minor error correction 2.01f)(2.03)  *
* 30.03.1998  GreekFontDescents corrected (better for Communicator)  (2.01e) *
* 12.05.1998  see mHotEqn and EqScanner                              (2.01f) *
* 22.05.1998  modified border radius calculation                     (2.01g) *
* 10.04.1999  corrected alpha value in Color Mask Filter             (2.01h) *
* 21.05.1998  selection almost completed                             (2.03a) *                                
* 24.05.1998  setEditable(), isEditable(), getselectedArea()         (2.03b) *
*             fontsize-problem solved, starts with editable=true             *
**************   Release of Version 3.00 *************************************
*     2001    Chr. Schmid                                                    *
* 18.01.2001  modified according to old HotEqn, SymbolLoader added, three    *
*             parameter constructor for applet context with applet name,     *
*             events corrected, edit mode highlight with transparency        *
* 14.05.2001  getImage method added                                   (3.01) *
* 15.06.2001  getImage method returns null when Image not ready       (3.02) *
* 01.12.2001  edit mode on mouse down,drag,up and new string search   (3.03) *
* 18.02.2002  faster version with one scan in generateImage           (3.04) *
* 19.02.2002  Environment color parameter + methods                   (3.04) * 
* 20.02.2002  New SymbolLoader with packed gif files (fast and small) (3.10) * 
* 23.03.2002  New method getSizeof to determine size of equation      (3.11) * 
* 27.10.2002  Package atp introduced                                  (3.12) * 
**************   Release of Version 4.00 *************************************
* 28.10.2002  Swing version forked from cHotEqn 3.12                  (4.00) * 
*             Thanks to Markus Schlicht                                      * 
*****************************************************************************/

package org.mathpiper.ui.gui.hoteqn;

// **** localWidth u. localHeight only at getPreferredSize() to give back

// package bHotEqn;  // for Bean-compilation to avoid double filenames

import java.util.*;
//changed 13.10.2002 //import java.awt.*; 
import java.awt.image.*; 
import java.awt.event.*;
//changed 13.10.2002 //import java.applet.Applet; // If component is called by applet.
import java.net.URL;       // for image loading in beans
import java.io.*;
import java.util.StringTokenizer;

import javax.swing.*; //changed 13.10.2002
import java.awt.Font; //changed 13.10.2002
import java.awt.Color; //changed 13.10.2002
import java.awt.Image; //changed 13.10.2002
import java.awt.Graphics; //changed 13.10.2002
import java.awt.MediaTracker; //changed 13.10.2002
import java.awt.Dimension; //changed 13.10.2002
import java.awt.Toolkit; //changed 13.10.2002
import java.awt.AWTEventMulticaster; //changed 13.10.2002
import java.awt.AWTEvent; //changed 13.10.2002
import java.awt.Polygon; //changed 13.10.2002
import java.awt.FontMetrics; //changed 13.10.2002
import java.awt.Rectangle; //changed 13.10.2002

public class sHotEqn extends JComponent //changed 13.10.2002
                     implements MouseListener, MouseMotionListener {

private static final String  VERSION = "sHotEqn V 4.00 ";

private int       width          = 0;
private int       height         = 0;
private String    nameS          = null;
private String    equation       = null;
private String    Fontname       = "Helvetica";

ActionListener    actionListener;     // Post action events to listeners

private EqScanner eqScan;
private EqToken   eqTok;

private Font f1 = new Font(Fontname,Font.PLAIN, 16);   
private Font f2 = new Font(Fontname,Font.PLAIN, 14);
private Font f3 = new Font(Fontname,Font.PLAIN, 11);
private Font f4 = new Font(Fontname,Font.PLAIN, 10);

private static final float mk = 2.0f;     // Switchable factor for parentheses (font,draw)

private static final int GreekFontSizes[]    = { 8,10,12,14,18 }; // Default GreekFonts
private static final int GreekFontDescents[] = { 2, 3, 4, 5, 6 }; // Default GreekFonts Descents
private int GreekSize[]                      = {14,12,10, 8};
private int GreekDescent[]                   = { 3, 3, 3, 3};
private static final int EmbedFontSizes[]    = { 9,11,14,16,22 }; // Assigned normal Fonts

/* greek font embedding characteristic based on Helvetica

 nominal font size  18  14  12  10   8
   greek leading     1   0   0   0   0
   greek height     23  16  15  13  11
   greek ascent     18  14  12  10   8
   greek descent     6   5   4   3   2
   embed size       22  16  14  11   9
   embed leading     1   1   0   0   0
   embed height     26  19  16  14  12
   embed ascent     20  15  13  11   9
   embed descent     6   3   3   3   3
*/

private Image   bufferImage;                     // double buffer image
private boolean imageOK          = false;
private int     localWidth       = 0;
private int     localHeight      = 0;

private Color   BGColor          = Color.white;
private Color   EnvColor         = Color.white;
private Color   FGColor          = Color.black;
private Color   BorderColor      = Color.red;
private boolean borderB          = false; //If true, draws a border around the component.
private boolean roundRectBorderB = false; //Makes the border rounded.
private int     border           = 0;
private String  halign           = "left";
private String  valign           = "top";
private int     xpos             = 0;
private int     ypos             = 0;
private boolean drawn            = false;       // drawn Semaphore for paint

private sSymbolLoader symbolLoader;              // flexible fontloader
private MediaTracker tracker;                   // global image tracker
private Hashtable imageH = new Hashtable (13);  // Hashtable for Image Cache (prime)

private JApplet  app;  //changed 13.10.2002 // Applet-Handle: because Netscape 4.x Bug mit Toolkit...getImage()
public  boolean appletB          = false;      // true if for HotEqn - sHotEqn used
public  boolean beanB            = false;      // true when used as bean.
public  boolean debug            = false;       // debug-reporting.

private boolean editMode         = false;      // Editor mode: select parts of equation
private boolean editableB        = true;
private int     mouse1X          = 0;
private int     mouse1Y          = 0;
private int     mouse2X          = 0;
private int     mouse2Y          = 0;
private int     xOFF             = 0;
private int     yOFF             = 0;
private int     y0 = 0;
private int     x0 = 0;
private int     y1 = 0;
private int     x1 = 0;
private int     editModeRec    = 5;
private boolean editModeFind   = false;
private int     editModeCount1 = 0;
private int     editModeCount2 = 0;
private Image   selectImage;

//*************************  Constructor ()  ****************************************
public  sHotEqn() {
  this("sHotEqn", null, "sHotEqn");
}

public  sHotEqn(String equation) {
  this(equation, null, "sHotEqn");
}

public sHotEqn(String equation, JApplet app, String nameS) {//changed 13.10.2002
   this.app       = app;                // Handle for Applet for Applet.getImage()
   this.equation  = equation;
   this.nameS     = nameS;
   addMouseListener(this);
   addMouseMotionListener(this);
   if (app != null)  appletB=true; 
   symbolLoader   = new sSymbolLoader();      // Font loader.
   tracker        = new MediaTracker(this);  // Media tracker for Images
   eqScan         = new EqScanner(equation); // Scanner to detect the Token.
   //System.out.println(VERSION+nameS);
}

//*************************  Public Methods ***********************************

public void setEquation(String equation) {
    this.equation = equation;
    eqScan.setEquation(equation);
    drawn   = false;
    imageOK = false;
    repaint();
} 
public String getEquation() { return equation; }

public void printStatus( String s) {
   if (debug) System.out.println(nameS + " " + s);
}

private void displayStatus( String s) {
   if (debug) {if (appletB) app.showStatus(nameS + " " + s); else printStatus(s);}
}

public Image getImage() {
	if (imageOK) return bufferImage; else return null;
}

public void setDebug(boolean debug) {
   this.debug = debug;
}
public boolean isDebug() { return debug; }

public void   setFontname(String fontname) { Fontname = fontname;}
public String getFontname()                { return Fontname;}

public void setFontsizes(int gsize1, int gsize2, int gsize3, int gsize4) {
   int    size1  = 16;
   int    size2  = 14;
   int    size3  = 11;
   int    size4  =  9;

   GreekSize[0]=0;
   GreekSize[1]=0;
   GreekSize[2]=0;
   GreekSize[3]=0;

   // Fontlargen for all the characters and the Greek symbols and special characters.
   for (int i=0; i width)   {toosmall=true; xpos=0;}
     if (localHeight > height) {toosmall=true; ypos=1;}
     // Calculate position
     int xoff=border;
     int yoff=border; 
     switch (xpos) {
       case 0: break;
       case 1: xoff=(width-area0.dx)/2; break;
       case 2: xoff=width-border-area0.dx-1; break;
     }
     switch (ypos) {
       case 0: break;
       case 1: yoff=border-(localHeight-height)/2; break;
       case 2: yoff=height-border-area0.dy_neg-area0.dy_pos; break;
     }
     //System.out.println("after 1. eqn");
     g.drawImage(genImage,xoff,yoff,xoff+area0.dx,yoff+area0.dy_pos+area0.dy_neg+1,0,height-area0.dy_pos,area0.dx,height+area0.dy_neg+1 ,this);
     //System.out.println("after 2. eqn");
     geng.dispose();
     if (toosmall) printStatus("(width,height) given=("+width+","+height +") used=("+localWidth+","+localHeight+")");
     imageOK = true;
     drawn   = true;
     xOFF=xoff;
     yOFF=yoff+area0.dy_pos;
     notify(); // notifiy that painting has been completed
} // end generateImage

/*  slower version with two scans
private synchronized void generateImage (Graphics g) {
     BoxC area  = new BoxC();
     BoxC area0 = new BoxC();
     g.setFont(f1);
     g.setColor(BGColor);
     g.fillRect(0,0,width,height);
     border=0;
     if (borderB && roundRectBorderB) {
       g.setColor(EnvColor);
       g.fillRect(0,0,width,height);
       g.setColor(BGColor);
       g.fillRoundRect(0,0,width-1,height-1,20,20);
       g.setColor(BorderColor);
       g.drawRoundRect(0,0,width-1,height-1,20,20);
       border=5;
     } else {
       if (borderB && !roundRectBorderB) {
         g.setColor(BorderColor);
         g.drawRect(0,0,width-1,height-1);
         border=5;
       }
     }
     g.setColor(FGColor);

     //FontMetrics fM  = g.getFontMetrics();
     //System.out.println("getAscent     = "+fM.getAscent()      );
     //System.out.println("getDescent    = "+fM.getDescent()     );
     //System.out.println("getHeight     = "+fM.getHeight()      );
     //System.out.println("getLeading    = "+fM.getLeading()     );
     //System.out.println("getMaxAdvance = "+fM.getMaxAdvance()  );
     //System.out.println("getMaxAscent  = "+fM.getMaxAscent()   );
     //System.out.println("getMaxDecent  = "+fM.getMaxDecent()   );
     //System.out.println("getMaxDescent = "+fM.getMaxDescent()  );
   
     // Scanner reset & equation in d. Mitte d. Fensters

     //imageH.clear();  // Image Cache leeren (nicht erforderlich)
     //System.out.println("before 1. eqn");
     eqScan.start();
     area0 = eqn(0,150, false, g, 1);
     displayStatus(" ");
     
     // set alignment
     xpos=0; // left
     if (halign.equals("center"))     xpos=1;
     else if (halign.equals("right")) xpos=2;
           
     ypos=0; // top      
     if (valign.equals("middle"))      ypos=1;
     else if (valign.equals("bottom")) ypos=2;
                  
     // Calculate actual size
     localWidth  = 1+area0.dx+2*border;
     localHeight = 1+area0.dy_pos+area0.dy_neg+2*border;

     // Test size and modify alignment if too small
     boolean toosmall = false; 
     if (localWidth > width)   {toosmall=true; xpos=0;}
     if (localHeight > height) {toosmall=true; ypos=1;}
     // Calculate position
     int xoff=border;
     int yoff=area0.dy_pos+border; 
     switch (xpos) {
       case 0: break;
       case 1: xoff=(width-area0.dx)/2; break;
       case 2: xoff=width-border-area0.dx-1; break;
     }
     switch (ypos) {
       case 0: break;
       case 1: yoff=border+area0.dy_pos-(localHeight-height)/2; break;
       case 2: yoff=height-border-area0.dy_neg-1; break;
     }
     //System.out.println("after 1. eqn");
     eqScan.start();
     area = eqn(xoff,yoff,true,g,1);
     //System.out.println("after 2. eqn");
     if (toosmall) printStatus("(width,height) given=("+width+","+height
                                   +") used=("+localWidth+","+localHeight+")");
     imageOK = true;
     drawn   = true;
     xOFF=xoff;
     yOFF=yoff;
     notify(); // notifiy that painting has been completed
} // end generateImage
*/


//***************************************************************************
//***************************************************************************
//***************             Parser-routine              ******************
private BoxC eqn(int x, int y, boolean disp, Graphics g, int rec){
   // different number of parameters
   return eqn(x, y, disp, g, rec, true); // Standard Argument (e.g. A_{.....})
} // end eqn


private BoxC eqn(int x, int y, boolean disp, Graphics g, int rec, boolean Standard_Single){
// Parameter: Baseline coordinates:         x and y
//            or drawing large calculate: disp (true/false)
//            Recursion (break, high,low,...)
//            Single (e.g. A_3)(false) o. Standard argument (e.g. A_{3+x})(true)

// the method: boxReturn = adjustBox(box,boxReturn) replaces the separate
//              calculation of the new box size after a function call
   BoxC        box       = new BoxC();  // for R�ckgaben function calls
   BoxC        boxReturn = new BoxC();  // accumulates the max. box size

   boolean Standard_Single_flag = true;
   boolean Space_flag           = false;
   boolean editModeFindLEFT = false;
   int editModeCount = 0;
   int editModeCountLEFT = 0;
   int eqToktyp;
   //String eqTokstringS;

   while (!eqScan.EoT() && Standard_Single_flag) {
     eqTok = eqScan.nextToken();
     if (editMode && disp) editModeCount = eqScan.get_count();

     Space_flag = false; 
     //System.out.print (eqTok.typ);
	 //if ( disp) System.out.println("Token ="+eqTok.typ);
	 editModeCountLEFT = editModeCount;
     eqToktyp = eqTok.typ;
     //eqTokstringS = eqTok.stringS;

     switch(eqTok.typ) {
     case EqToken.AndSym:
     case EqToken.DBackSlash:
     case EqToken.END:
     case EqToken.EndSym:
     case EqToken.RIGHT:
               if (editModeFind && disp) { 
				  //System.out.println("RighteditModeCount ="+editModeCount);
                  if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
                  if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
               }
               return boxReturn;
     case EqToken.ACCENT:
               box = ACCENT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.ANGLE:
               box = ANGLE(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.ARRAY:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = ARRAY(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.BEGIN:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = BEGIN(x+boxReturn.dx,y,disp,g,rec); 
               break;
     case EqToken.BeginSym:
               box = eqn(x+boxReturn.dx,y,disp,g,rec,true); 
               break;
     case EqToken.FGColor:
               box = FG_BGColor(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.BGColor:
               box = FG_BGColor(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.FBOX:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = FBOX(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.Id:
               box = Id(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.NOT:
               box = NOT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.Op: 
               box = Op(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.FRAC:
               box = FRAC(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.ATOP:
               box = FRAC(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.FUNC:
     case EqToken.Num:
               box = Plain(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SYMBOP:
               box = SYMBOP(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.SYMBOPD:
               box = SYMBOP(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.LEFT:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = LEFT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.LIM:
               box = LIM(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.MBOX:
               box = MBOX(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.OverBRACE:
               box = OverBRACE(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.UnderBRACE:
               box = UnderBRACE(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.OverLINE:
               box = OverUnderLINE(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.UnderLINE:
               box = OverUnderLINE(x+boxReturn.dx,y,disp,g,rec,false);
               break;
     case EqToken.Paren:
               box = Paren(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SPACE:
               box = SPACE(x+boxReturn.dx,y,disp,g);
               break;
     case EqToken.SQRT:
			   if (editModeFind && disp) editModeFindLEFT = true;
               box = SQRT(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.STACKREL:
               box = STACKREL(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.SUP:
               box = SUP(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.SUB:
               box = SUB(x+boxReturn.dx,y,disp,g,rec,true);
               break;
     case EqToken.SYMBOLBIG:
               box = SYMBOLBIG(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.VEC:
               box = VEC(x+boxReturn.dx,y,disp,g,rec);
               break;
     case EqToken.SpaceChar:
               box = new BoxC(0,0,0);
               // bei SpaceChar gilt immer noch eqn(...,false) (single eqn)
               Space_flag = true;   
               break;
     case EqToken.Invalid:
     case EqToken.Null:
               box = new BoxC(0,0,0);
               break;
     default:
               printStatus("Parser: unknown token: "+eqTok.typ+" "+eqTok.stringS);
               //ignore
     } // end switch

	if (disp)  {
		if (editMode)  {
			//System.out.println("x+boxReturn.dx = "+(x+boxReturn.dx)+" mouse1X = "+mouse1X+" x+boxReturn.dx+box.dx ="+(x+boxReturn.dx+box.dx));
			if (!editModeFind) {
				if ( x+boxReturn.dx    <= mouse1X                    &&  
					 mouse1X           <= (x+boxReturn.dx+box.dx)    && 
					 (y-box.dy_pos)    <= mouse1Y                    && 
					 mouse1Y           <= (y+box.dy_neg) ) {
					//System.out.println("Top token "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					x0 = x1 = mouse1X;
					y0 = y1 = mouse1Y;
					editModeFind   = true;
					editModeCount1 = editModeCount;
					editModeCount2 = editModeCount;
				}
			}
			if (!editModeFind) {
				if ( x+boxReturn.dx    <= mouse2X                    &&  
					 mouse2X           <= (x+boxReturn.dx+box.dx)    && 
					 (y-box.dy_pos)    <= mouse2Y                    && 
					 mouse2Y           <= (y+box.dy_neg) ) {
					//System.out.println("Top2token "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					x0 = x1 = mouse2X;
					y0 = y1 = mouse2Y;
					editModeFind = true;
					editModeCount1 = editModeCount;
					editModeCount2 = editModeCount;
					int dummyX = mouse2X;
					int dummyY = mouse2Y;
					mouse2X    = mouse1X;
					mouse2Y    = mouse1Y;
					mouse1X    = dummyX;
					mouse1Y    = dummyY;
				}
			}
			//System.out.println("Token ="+eqToktyp+" editModeFind ="+editModeFind+" editModeFindLEFT ="+editModeFindLEFT);
			if (editModeFind) {
				//System.out.println("Mitte token  "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec+" "+editModeCount1+" "+editModeCount2);
				x0 = Math.min(x0, x + boxReturn.dx);
				x1 = Math.max(x1, x + boxReturn.dx + box.dx);
				y0 = Math.min(y0, y - box.dy_pos);
				y1 = Math.max(y1, y + box.dy_neg);
				//g.setColor(Color.green);
				//g.drawRect(x0, y0, x1-x0, y1-y0);
				//g.setColor(FGColor);
				if (editModeRec>rec) editModeRec = rec;
     			switch(eqToktyp) {
     				case EqToken.LEFT :
     				case EqToken.FBOX :
     				case EqToken.MBOX :
     				case EqToken.BEGIN :
     				case EqToken.ARRAY :
     				case EqToken.SQRT :
						editModeFindLEFT = true;
						if (editModeCountLEFT > editModeCount2) editModeCount2 = editModeCountLEFT;
						if (editModeCountLEFT < editModeCount1) editModeCount1 = editModeCountLEFT;
						editModeCount = eqScan.get_count();
						//System.out.println("MBOX/FBOX/LEFT handling");
				} // end switch
				if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
				if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
				//System.out.println("editModeCount1 "+editModeCount1);
				//System.out.println("editModeCount2 "+editModeCount2);
				if ( x+boxReturn.dx    <= mouse2X                    &&  
				     mouse2X           <= (x+boxReturn.dx+box.dx)    && 
				     (y-box.dy_pos)    <= mouse2Y                    && 
				     mouse2Y           <= (y+box.dy_neg)  ) {
					//System.out.println("Ende token   "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec);
					//g.setColor(Color.red);
					//g.drawRect(x0, y0, x1-x0, y1-y0);
					//g.setColor(FGColor);
					if (editModeRec == rec) {
						editMode     = false;
						editModeFind = false;
						//System.out.println("editModeCount "+editModeCount);
					}
				}
			} // end editModeFind
		} // end editMode
		if (editModeFindLEFT) {
			//System.out.println("find LEFT token  "+eqToktyp+" "+eqTokstringS+" "+rec+" "+editModeRec+" "+editModeCount1+" "+editModeCount2);
			x0 = Math.min(x0, x + boxReturn.dx);
			x1 = Math.max(x1, x + boxReturn.dx + box.dx);
			y0 = Math.min(y0, y - box.dy_pos);
			y1 = Math.max(y1, y + box.dy_neg);
			//g.setColor(Color.green);
			//g.drawRect(x0, y0, x1-x0, y1-y0);
			//g.setColor(FGColor);
   			switch(eqToktyp) {
   				case EqToken.LEFT :
   				case EqToken.FBOX :
   				case EqToken.MBOX :
   				case EqToken.BEGIN :
   				case EqToken.ARRAY :
   				case EqToken.SQRT :
				if (editModeCountLEFT > editModeCount2) editModeCount2 = editModeCountLEFT;
				if (editModeCountLEFT < editModeCount1) editModeCount1 = editModeCountLEFT;
				editModeCount = eqScan.get_count();
				//System.out.println("MBOX/FBOX/LEFT handling");
			} // end switch
			if (editModeCount > editModeCount2) editModeCount2 = editModeCount;
			if (editModeCount < editModeCount1) editModeCount1 = editModeCount;
			//System.out.println("editModeCount1 "+editModeCount1);
			//System.out.println("editModeCount2 "+editModeCount2);
			editModeFindLEFT = false;
		} // end editModeFindLEFT
	} // end disp

	boxReturn.dx    += box.dx; 
	boxReturn.dy_pos = Math.max(boxReturn.dy_pos,box.dy_pos);
	boxReturn.dy_neg = Math.max(boxReturn.dy_neg,box.dy_neg); 
	if (!Standard_Single && !Space_flag) Standard_Single_flag = false;   // Single argument (e.g. A_3)
	} // end while
    return boxReturn;
} // end eqn


//************************************************************************
private BoxC ACCENT(int x, int y, boolean disp, Graphics g, int rec) {
// accents: \dot \ddot \hat \grave \acute \tilde
// eqTok.stringS contain the be displayed(n) character
   BoxC        box      = new BoxC();
   int         count    = 0;
   FontMetrics fM       = g.getFontMetrics();
   String      large  = eqTok.stringS;
   

   //Only disp=true must Scanner later reset will
   if (disp) count = eqScan.get_count(); 


   // large Argument-Box calculate
   box    = eqn(x,y,false,g,rec,false);
   int dx = Math.max(box.dx,fM.stringWidth(large));
   int dy_pos = box.dy_pos + (int)(fM.getAscent()/2); 
   int dy_neg = box.dy_neg; 

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
 
      // Argument draw
      box = eqn(x,y,true,g,rec,false);

      // Mittenverschiebung ausrechenen
      int d_dx = 3*(int)( (dx-fM.stringWidth(large))/4 );

      if (large.equals(".") | large.equals("..")) {
         g.drawString(large,x+d_dx,y-fM.getAscent());
         }
      else if (large.equals("�") | large.equals("`")) {
         g.drawString(large,x+d_dx,y-(int)(fM.getAscent()/3));
         }
      else g.drawString(large,x+d_dx,y-(int)(fM.getAscent()*2/3));
   } // end disp
   return new BoxC(dx,dy_pos,dy_neg);  
} // end ACCENT

//************************************************************************
private BoxC ANGLE(int x, int y, boolean disp, Graphics g) {
   // Spitze Klammern < und >

   BoxC        box      = new BoxC();
   FontMetrics fM       = g.getFontMetrics();
   int dx     = g.getFont().getSize()/2;
   int dy_pos = fM.getHeight()-fM.getDescent();
   int dy_neg = fM.getDescent();

   // only disp draw
   if (disp) {
      int yp     = y-dy_pos+1;
      int yn     = y+dy_neg-1;
      int m      = (yp+yn)/2;
      if (eqTok.stringS.equals("<")) {
         g.drawLine(x+dx,yp,x,m);
         g.drawLine(x,m,x+dx,yn);
      } else {
         g.drawLine(x,yp,x+dx,m);
         g.drawLine(x+dx,m,x,yn);
      }
    } // end disp
   return new BoxC(dx,dy_pos,dy_neg);  
} // end ACCENT

//************************************************************************
private BoxC ARRAY(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx        = 0;
   int         dy_pos    = 0;
   int         dy_neg    = 0;
   int         dy_pos_max= 0;
   int         dx_eqn[]      = new int[100];  // Breite columnselemente
   int         dy_pos_eqn[]  = new int[100];  // H�he   rowselemente
   int         dy_neg_eqn[]  = new int[100];  // H�he   rowselemente
   BoxC        box       = new BoxC();
   int         count     = 0;
   FontMetrics fM        = g.getFontMetrics();
   // Abstand 1 quad hinter Element
   int quad              = g.getFont().getSize();

   // only disp=true only Scanner later reset will
   if (disp) count = eqScan.get_count(); 

   // "{" vom Scanner holen
   if (!expect(EqToken.BeginSym, "ARRAY: BeginSym")) return new BoxC(0,0,0);  

   // loop: rows
   for (int y_i = 0; y_i<99; y_i++) {
      dy_pos = 0;
      dy_neg = 0;

      // loop: columns
      for (int x_i=0; x_i<99; x_i++) {
         // large der Argument-Box calculate
         box  = eqn(x,y,false,g,rec);

         dy_pos = Math.max(dy_pos,box.dy_pos); 
         dy_neg = Math.max(dy_neg,box.dy_neg); 

         // Breitesten Elemente pro column
         dx_eqn[x_i] = Math.max(dx_eqn[x_i],box.dx+quad);

         // delimiter am columnsende
         if ((eqTok.typ==EqToken.DBackSlash) || 
             (eqTok.typ==EqToken.EndSym)) break;
      } // end columns

      // H�chste und tiefste rowsh�he
      dy_pos_eqn[y_i] = Math.max(dy_pos_eqn[y_i],dy_pos);
      dy_neg_eqn[y_i] = Math.max(dy_neg_eqn[y_i],dy_neg);
      dy_pos_max += (dy_pos + dy_neg); 

      // delimiter am ARRAY-Ende
      if (eqTok.typ == EqToken.EndSym) break;
   } // end rows


   // maximum rows wide determine
   int dx_max = 0;
   for (int i=0; i<99; i++) dx_max += dx_eqn[i];

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos_max/2-fM.getDescent(),dx_max,dy_pos_max);
 
      // "{" vom Scanner holen
      expect(EqToken.BeginSym, "ARRAY: Begin");  

     // loop: rows
     dy_pos = 0;
     for (int y_i=0; y_i<99; y_i++) {
        dx     = 0;
        if (y_i==0) { dy_pos  = dy_pos_eqn[y_i]; }
           else     { dy_pos += (dy_neg_eqn[y_i-1] + dy_pos_eqn[y_i]); }
        // loop: columns
        for (int x_i=0; x_i<99; x_i++) {
           // large der Argument-Box calculate
           box = eqn(x+dx,y-dy_pos_max/2-fM.getDescent()+dy_pos,true,g,rec);
           dx     += dx_eqn[x_i];

           // delimiter am columnsende
           if ((eqTok.typ == EqToken.DBackSlash) ||
               (eqTok.typ == EqToken.EndSym)) break;
        } // end columns
        // delimiter am ARRAY-Ende
        if (eqTok.typ == EqToken.EndSym) break;
     } // end rows
   } // end disp

   return new BoxC(dx_max-quad,dy_pos_max/2+fM.getDescent(),dy_pos_max/2-fM.getDescent());  
} // end ARRAY

//************************************************************************
private BoxC BEGIN(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx,     dx_max                 = 0;
   int         dy_pos, dy_neg, dy_top, dy_max = 0;
   int         dx_eqn[]      = new int[100];  // Breite columns elemente
   int         dy_pos_eqn[]  = new int[100];  // H�he   rows element
   int         dy_neg_eqn[]  = new int[100];  // H�he   rows elemente
   int         format[]      = new int[100];  // Format 1-l 2-c 3-r 4-@
   int         format_count[]= new int[100];  // f�r getcount() bei @-Einsch�ben
   int         format_dx     = 0;             // dx     bei @-Einsch�ben
   int         format_dy_pos = 0;             // dy_pos bei @-Einsch�ben
   int         format_dy_neg = 0;             // dy_neg bei @-Einsch�ben
   BoxC        box           = new BoxC();
   int         count         = 0;
   FontMetrics fM            = g.getFontMetrics();
   int         quad          = g.getFont().getSize();
   int         i             = 0; 
   boolean     flag          = false;
   boolean     flag_end      = false;
   boolean     format_flag   = true;
   boolean     array_eqnarray= true;          // default: \begin{array}
   int         times         = 0; // Zahl bei *{xxx}
   int count2 =0;

   if (!expect(EqToken.BeginSym))  return new BoxC(0,0,0);   

   if (eqScan.nextToken().stringS.equals("eqnarray")) array_eqnarray = false;

   if (!expect(EqToken.EndSym, "BEGIN: EndSym")) return new BoxC(0,0,0);  

   if (array_eqnarray) {
     count = eqScan.get_count();
     if (!expect(EqToken.BeginSym)) {
        // NO format-string
        format_flag = false;
        eqScan.set_count(count);
     }
   }


   if (array_eqnarray && format_flag) {
      // *********** Format Angaben erkennen ********* 
      // l left(1)    c center(2)   r right(3)
      // @{...} Einschub statt Zwischenraum(4) 

      EqToken token = new EqToken();
      token = eqScan.nextToken();

      while (token.typ != EqToken.EndSym) {
         StringBuffer SBuffer = new StringBuffer(token.stringS); 
         for (int z=0; z")) {
     g.drawLine(ddh,m,dh,yp);
     g.drawLine(ddh,m,dh,yn);
  }
  else if (Bracket.equals("{")) {
     for (int i=s;i<2+s;i++) {
        int dpi=d+i;
        arc(g,dd+i,ypr,r,180,-60);
        g.drawLine(dpi,ypr,dpi,m-r);
        arc(g,x+i,m-r,r,0,-90);
        arc(g,x+i,m+r,r,0,90);
        g.drawLine(dpi,m+r,dpi,ynr);
        arc(g,dd+i,ynr,r,180,60);
     }
  }
  else if (Bracket.equals("}")) {
     for (int i=s;i<2+s;i++) {
        int dpi=d+i;
        arc(g,x+i,ypr,r,0,60);
        g.drawLine(dpi,ypr,dpi,m-r);
        arc(g,dd+i,m-r,r,-180,90);
        arc(g,dd+i,m+r,r,180,-90);
        g.drawLine(dpi,m+r,dpi,ynr);
        arc(g,x+i,ynr,r,0,-60);
     }
  }
} // drawBracket 

//************************************************************************
private BoxC LEFT(int x, int y, boolean disp, Graphics g, int rec) {
   int         dx_left      = 0;
   int         dx_right     = 0;
   BoxC        box          = new BoxC();
   int         count        = 0;
   Font        localFont    = g.getFont();
   int         quad         = localFont.getSize();
   int         mkq          = (int)(mk * quad);
   int         space        = quad/9;
   Font BracketFont;
   FontMetrics BracketMetrics;

   // only disp=true only Scanner later reset will
   if (disp)  count = eqScan.get_count();

   // Klammertyp f�r linke Seite vom Scanner holen
   String LeftBracket    = eqScan.nextToken().stringS;

   // large der Argument-Box calculate
   box    = eqn(x,y,false,g,rec);
   int dx     = box.dx;
   int dy_pos = box.dy_pos;  
   int dy_neg = box.dy_neg; 
   int yp     = y-dy_pos+1;
   int yn     = y+dy_neg-1;
 
   // Klammertyp f�r rechte Seite vom Scanner holen
   String RightBracket = eqScan.nextToken().stringS;

   // Klammerlarge calculate
   int BracketSize    = dy_pos+dy_neg-2;

   BracketFont = new Font("Helvetica",Font.PLAIN,BracketSize);
   g.setFont(BracketFont);   
   BracketMetrics = g.getFontMetrics();
   if (LeftBracket.equals("<") || LeftBracket.equals(">")) {
      dx_left = quad;
   }
   else if (BracketSize < mkq) {
      dx_left  = BracketMetrics.stringWidth(LeftBracket);
      if ("([{)]}".indexOf(LeftBracket) >= 0) dx_left += space;
   }
   else dx_left = quad;

   if (RightBracket.equals("<") || RightBracket.equals(">")) {
      dx_right = quad;
   }
   else if (BracketSize < mkq) {
      dx_right = BracketMetrics.stringWidth(RightBracket);
      if ("([{)]}".indexOf(RightBracket) >= 0) dx_right += space;
   }
   else dx_right = quad;
   g.setFont(localFont);

   // hinter Klammer Hoch-/Tiefstellung
   int count2 = eqScan.get_count();
   // "SUB"
   int SUB_dx = 0;
   int SUB_baseline = 0;  
   if (eqScan.nextToken().typ == EqToken.SUB) {
      box    = SUB(x,y,false,g,rec,false);
      SUB_dx=box.dx;
      SUB_baseline = yn+box.dy_pos-(box.dy_pos+box.dy_neg)/2;
      dy_neg += (box.dy_pos+box.dy_neg)/2;
   } else eqScan.set_count(count2); 
   int count1 = eqScan.get_count();

   // "SUP"
   int SUP_dx = 0;
   int SUP_baseline = 0; 
   if (eqScan.nextToken().typ == EqToken.SUP) {
      box    = SUP(x,y,false,g,rec,false);
      SUP_dx = box.dx;
      SUP_baseline = yp+box.dy_pos-(box.dy_pos+box.dy_neg)/2;
      dy_pos += (box.dy_pos+box.dy_neg)/2;
   } else eqScan.set_count(count1); 
   SUB_dx = Math.max(SUB_dx,SUP_dx);

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x+dx_left,y-dy_pos,dx,dy_pos+dy_neg);

      // linker Klammertyp vom Scanner holen
      LeftBracket = eqScan.nextToken().stringS;
      if (!LeftBracket.equals(".")) {
         if (BracketSize < mkq && !(LeftBracket.equals("<") || LeftBracket.equals(">"))) { 
            // linke Klammern mit font draw
            g.setFont(BracketFont);
            g.drawString(LeftBracket,x,yn-BracketMetrics.getDescent()
                                         -BracketMetrics.getLeading()/2);
            g.setFont(localFont);
         } else 
            //linke Klammern direkt draw
            drawBracket (g,LeftBracket,x,dx_left,yp,yn,quad,0);
      }

      // Argument draw
      box = eqn(x+dx_left,y,true,g,rec);

      // rechter Klammertyp vom Scanner holen
      RightBracket = eqScan.nextToken().stringS;
      if (!RightBracket.equals(".")) {
         if (BracketSize < mkq && !(RightBracket.equals("<") || RightBracket.equals(">"))) { 
            // rechte Klammern mit font draw
            g.setFont(BracketFont);
            if ("([{)]}".indexOf(RightBracket) < 0) space = 0;
            g.drawString(RightBracket,x+dx+dx_left+space,yn-BracketMetrics.getDescent()
                                                     -BracketMetrics.getLeading()/2);
            g.setFont(localFont); 
         } else 
            //rechte Klammern direkt draw
           drawBracket (g,RightBracket,x+dx+dx_left,dx_right,yp,yn,-quad,-1); 
      }
      // hinter Klammer Hoch-/Tiefstellung
      count2 = eqScan.get_count();
      // "SUB" 
      if (expect(EqToken.SUB)) 
         box = SUB(x+dx+dx_left+dx_right,SUB_baseline,true,g,rec,false);
      else eqScan.set_count(count2); 
      count1 = eqScan.get_count();
      // "SUP" 
      if (expect(EqToken.SUP)) 
         box = SUP(x+dx+dx_left+dx_right,SUP_baseline,true,g,rec,false);
      else eqScan.set_count(count1); 
    } // end disp
   return new BoxC(dx+dx_left+dx_right+SUB_dx,dy_pos+2,dy_neg+2);  
} // end LEFT

//************************************************************************
private BoxC LIM(int x, int y, boolean disp, Graphics g, int rec){
   int     dx       = 0;
   BoxC    box      = new BoxC();
   int SUB_dx       = 0;
   int SUB_baseline = 0;

   FontMetrics fM       = g.getFontMetrics();
   String stringS = eqTok.stringS;

   // es only Scanner later reset will
   int count = eqScan.get_count();

   int im_dx = dx = fM.stringWidth(stringS);
   int dy_pos = fM.getHeight()-fM.getDescent();
   int dy_neg = fM.getDescent();

   if (expect(EqToken.SUB)) {
      box    = SUB(x,y,false,g,rec,false);
      SUB_dx=box.dx;
      dx = Math.max(dx,box.dx);
      SUB_baseline = box.dy_pos;
      dy_neg = box.dy_pos+box.dy_neg;
   } else eqScan.set_count(count); 
 
   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 
      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
      g.drawString(stringS,x+(dx-im_dx)/2,y);
      if (expect(EqToken.SUB))
         box = SUB(x+(dx-SUB_dx)/2,y+SUB_baseline,true,g,rec,false);
      else eqScan.set_count(count); 
   } // end disp

   return new BoxC(dx,dy_pos,dy_neg);  
} // end LIM

//************************************************************************
private BoxC MBOX(int x, int y, boolean disp, Graphics g) {
   // \mbox{...}  plain text within equations 
   int         dx       = 0; 
   int         dy_pos   = 0;
   int         dy_neg   = 0;
   BoxC        box      = new BoxC();

   // "{" vom Scanner holen
   if (!expect(EqToken.BeginSym)) return new BoxC(0,0,0);  

   while (!eqScan.EoT()) {
      eqTok = eqScan.nextToken();
      if (eqTok.typ != EqToken.EndSym) { 
         box = Plain(x+dx, y, disp, g);
         dx += box.dx;
         dy_pos = Math.max(dy_pos,box.dy_pos);
         dy_neg = Math.max(dy_neg,box.dy_neg);
      }
      else break;
   }

   return new BoxC(dx, dy_pos, dy_neg);  
} // end MBOX

//**********************************************************************
private BoxC NOT(int x, int y, boolean disp, Graphics g, int rec){
// Negation: \not    or \not{  }
   BoxC    box      = new BoxC();

   box    = eqn(x,y,disp,g,rec,false);  

   if (disp) g.drawLine(x + box.dx/4 ,     y + box.dy_neg,
                        x + (box.dx*3)/4,  y - box.dy_pos );
   return box;  
} // end NOT

//************************************************************************
private BoxC Op(int x, int y, boolean disp, Graphics g) {
// Operatoren
   FontMetrics fM       = g.getFontMetrics();
 
   if (disp) g.drawString(eqTok.stringS,x+1,y);
   return new BoxC(fM.stringWidth(eqTok.stringS) + 2,
                   fM.getHeight()-fM.getDescent(),
                   fM.getDescent());  
} // end Op

//*************************************************************************
private BoxC OverBRACE(int x, int y, boolean disp, Graphics g, int rec) {
   int         count    = 0;
   BoxC        box      = new BoxC();
   int r                = g.getFont().getSize()/4;
   int rh               = r/2;
   int SUP_dx           = 0;
   int SUP_base         = 0;
   int SUP_dy           = 0;

   // only disp=true only Scanner later reset will
   if (disp) count = eqScan.get_count(); 

   // large der Argument-Box calculate
   box          = eqn(x,y,false,g,rec,false);
   int dx       = box.dx;
   int dxh      = dx/2;
   int x_middle = dxh;
   int dy_pos   = box.dy_pos;
   int dy_neg   = box.dy_neg;

   // "SUP" behandeln, FALLS beforehanden
   int count1 = eqScan.get_count();
   if (expect(EqToken.SUP)) {
      box      = SUP(x,y,false,g,rec,false);
      SUP_dx   = box.dx;
      x_middle = Math.max(x_middle,SUP_dx/2);
      SUP_base = dy_pos     + box.dy_neg;
      SUP_dy   = box.dy_pos + box.dy_neg;
   } else eqScan.set_count(count1); 

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count);
      int xx   = x + x_middle-dxh;  
      box      = eqn(xx, y, true, g, rec, false);
      int rred = (int)(r*0.86602540378444);
      for (int i=0;i<2;i++) {
         int ypi = y-dy_pos-rh+i;
         arc(g,xx+rred,ypi+r,r,90,60);
         g.drawLine(xx+rred,ypi,xx+dxh-r,ypi);
         arc(g,xx+dxh-r,ypi-r,r,0,-90);
         arc(g,xx+dxh+r,ypi-r,r,-90,-90);
         g.drawLine(xx+dxh+r,ypi,xx+dx-rred,ypi);
         arc(g,xx+dx-rred,ypi+r,r,90,-60);
      }
      count1 = eqScan.get_count();
      if (expect(EqToken.SUP)) 
         box = SUP(x+x_middle-SUP_dx/2, y-SUP_base-r-rh,true,g,rec,false);
      else eqScan.set_count(count1); 
   } // end disp

   dy_pos += SUP_dy + r + rh ;
   dx = Math.max(dx,SUP_dx);

   return new BoxC(dx,dy_pos,dy_neg); 
} // end OverBRACE


//*************************************************************************
private BoxC UnderBRACE(int x, int y, boolean disp, Graphics g, int rec) {
   int         count    = 0;
   BoxC        box      = new BoxC();
   int r                = g.getFont().getSize()/4;
   int rh               = r/2;
   int SUB_dx           = 0;
   int SUB_base         = 0;
   int SUB_dy           = 0;

   // only disp=true only Scanner later reset will
   if (disp) count = eqScan.get_count(); 

   // large der Argument-Box calculate
   box      = eqn(x,y,false,g,rec,false);
   int dx       = box.dx;
   int dxh      = dx/2;
   int x_middle = dxh;
   int dy_pos   = box.dy_pos;
   int dy_neg   = box.dy_neg;

   // "SUB" behandeln, FALLS beforehanden
   int count1 = eqScan.get_count();
   if (expect(EqToken.SUB)) {
      box      = SUB(x,y,false,g,rec,false);
      SUB_dx   = box.dx;
      x_middle = Math.max(x_middle,SUB_dx/2);
      SUB_base = dy_neg     + box.dy_pos;
      SUB_dy   = box.dy_pos + box.dy_neg;
   } else eqScan.set_count(count1); 

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 
      int xx   = x + x_middle-dxh;  
      box      = eqn(xx, y, true, g, rec, false);
      int rred = (int)(r*0.86602540378444);
      for (int i=0;i<2;i++) {
         int ypi = y+dy_neg+rh-i;
         arc(g,xx+rred,ypi-r,r,-90,-60);
         g.drawLine(xx+rred,ypi,xx+dxh-r,ypi);
         arc(g,xx+dxh-r,ypi+r,r,90,-90);
         arc(g,xx+dxh+r,ypi+r,r,90,90);
         g.drawLine(xx+dxh+r,ypi,xx+dx-rred,ypi);
         arc(g,xx+dx-rred,ypi-r,r,-90,60);
      }
      count1 = eqScan.get_count();
      if (eqScan.nextToken().typ == EqToken.SUB) 
         box = SUB(x+x_middle-SUB_dx/2, y+SUB_base+r+rh,true,g,rec,false);
      else eqScan.set_count(count1); 
   } // end disp

   dy_neg += SUB_dy + r + rh ;
   dx = Math.max(dx,SUB_dx);

   return new BoxC(dx,dy_pos,dy_neg); 
} // end UnderBRACE

//************************************************************************
private BoxC OverUnderLINE(int x, int y, boolean disp, Graphics g, int rec, 
                          boolean OverUnder) {
   int         count    = 0;
   BoxC        box      = new BoxC();
  
   // only disp=true only Scanner later reset will
   if (disp) count = eqScan.get_count(); 

   // large der Argument-Box calculate
   box = eqn(x,y,false,g,rec,false);
   if (OverUnder)  box.dy_pos += 2; // place over Strich
   else            box.dy_neg += 2; // place unter Strich
   int dy_pos=box.dy_pos;
   int dy_neg=box.dy_neg;
   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 
      if (OverUnder)  g.drawLine(x+1, y-dy_pos+2, x+box.dx-1, y-dy_pos+2);
      else            g.drawLine(x, y+dy_neg-2, x+box.dx, y+dy_neg-2);
      box = eqn(x,y,true,g,rec,false);
   } 
   return new BoxC(box.dx,dy_pos,dy_neg); 
} // end OverUnderLINE

//************************************************************************
private BoxC Paren(int x, int y, boolean disp, Graphics g){
   FontMetrics fM = g.getFontMetrics();
   int space      = g.getFont().getSize()/9;
   int dx         = fM.stringWidth(eqTok.stringS);
   int i = "([{)]}".indexOf(eqTok.stringS);
   if (i >= 0) {
      dx += space;
      if (i > 2 ) x += space;
   }
   if (disp) g.drawString(eqTok.stringS,x,y);
   return new BoxC( dx,
                    fM.getHeight()-fM.getDescent(),
                    fM.getDescent());
} // end Paren

//************************************************************************
private BoxC Plain(int x, int y, boolean disp, Graphics g){
   FontMetrics fM       = g.getFontMetrics();

   if (disp) g.drawString(eqTok.stringS,x,y);
   return new BoxC( fM.stringWidth(eqTok.stringS),
                    fM.getHeight()-fM.getDescent(),
                    fM.getDescent());
} // end Plain

//************************************************************************
private BoxC SPACE(int x, int y, boolean disp, Graphics g){
   // additional positive or negative space between elements
   int         dx     = 0;
   Font font = g.getFont();
   try                            { dx = Integer.parseInt(eqTok.stringS);}
   catch (NumberFormatException e){ dx = 0; }
   dx     =  ( dx * font.getSize()) / 18;
   return new BoxC(dx,0,0);  
} // end SPACE

//************************************************************************
private BoxC SQRT(int x, int y, boolean disp, Graphics g, int rec) {
   BoxC        box      = new BoxC();
   int         count    = 0;
   FontMetrics fM       = g.getFontMetrics();
   int dx_n             = 0;
   int dy_pos_n         = 0;
   int dy_neg_n         = 0;
   int dy_n             = 0;
   boolean n_sqrt       = false;

   // only disp=true only Scanner later reset will
   if (disp) count = eqScan.get_count();

   // something place for the hook of the root.
   int dx_Haken  = fM.stringWidth("A");
   int dx_Hakenh = dx_Haken/2;


   // \sqrt[...]{...}
   int     count1 = eqScan.get_count();
   EqToken token  = new EqToken();
   token          = eqScan.nextToken();
   if (token.stringS.equals("[")) {
      // large der [n.ten] root
      rec_Font(g,rec+1);
      box    = eqn(x,y,false,g,rec+1,true);
      rec_Font(g,rec);
      dx_n     = box.dx;
      dy_pos_n = box.dy_pos;
      dy_neg_n = box.dy_neg;
      dy_n     = dy_neg_n + dy_pos_n;
      n_sqrt   = true;
   } 
   else eqScan.set_count(count1);  

   // large der Argument-Box calculate
   box    = eqn(x,y,false,g,rec,false);
   int dx     = box.dx +  dx_Haken;
   int dy_pos = box.dy_pos + 2;  // additional place over overbar
   int dy_neg = box.dy_neg; 

   if (n_sqrt & dx_n>dx_Hakenh) dx += dx_n - dx_Hakenh;

   // only disp=true is Scanner reset
   if (disp) {
      eqScan.set_count(count); 

      //g.drawRect(x,y-dy_pos,dx,dy_pos+dy_neg);
 
      // root character
      int dx_n_h = 0;
      if (n_sqrt & dx_n > dx_Hakenh) dx_n_h = dx_n - dx_Hakenh;
      g.drawLine(x+dx_n_h+1,y-dy_pos/2,           x+dx_n_h+dx_Hakenh,y+dy_neg-1);
      g.drawLine(x+dx_n_h+dx_Hakenh,y+dy_neg-1,  x+dx_n_h+dx_Haken-2,y-dy_pos+2);
      g.drawLine(x+dx_n_h+dx_Haken-2,y-dy_pos+2,  x+dx,y-dy_pos+2 );

      if (n_sqrt) {
         token  = eqScan.nextToken(); 
         rec_Font(g,rec+1);
         if (dx_n>=dx_Hakenh){
               g.drawLine(x+1,y-dy_pos/2, x+dx_n_h+1,y-dy_pos/2);
               box = eqn(x+1,y- dy_pos/2 - dy_neg_n-1,true,g,rec+1,true);
         }
         else  box = eqn(x+1+(dx_Hakenh-dx_n),y- dy_pos/2 - dy_neg_n-1,true,g,rec+1,true);
         rec_Font(g,rec);
      }

      // Argument draw
      box = eqn(x+dx_n_h+dx_Haken,y,true,g,rec,false);

   } // end disp

   if (n_sqrt & dy_pos/2 imageBytes.length) {  //haven't yet allocated enough space
          byte[] tempImageBytes= (byte[]) imageBytes.clone();
          imageBytes = new byte[totalBytes];
          System.arraycopy(tempImageBytes, 0, imageBytes, 0, alreadyRead);
        }
      }
      if (numBytes == 0) break;
    }
    //Create an ImageProducer from the image bytes
    source = Toolkit.getDefaultToolkit().createImage(imageBytes).getSource();
  }
  catch (Exception io) {}
  return source;
} // end getLocalImageSource

} // end class sSymbolLoader

/* 
// sSymbolLoader for unpacked font files (slow speed)
class sSymbolLoader {

public sSymbolLoader() { }
// dummy constructor

//Fonts are included in HotEqn zip/jar file
private static boolean kLocalFonts=true;

public Image getImage( boolean  appletB, boolean beanB, String filenameS,
                Graphics g,      JApplet   app) {
  ImageProducer imageSource=null;
  Image image=null;

  if(kLocalFonts) {
    imageSource = getLocalImageSource(filenameS);
  }
  if(imageSource==null) { //Fonts are not local
    kLocalFonts=false;  //don't attempt to load local fonts anymore

    //Try loading external Font files in component/applet/bean specific manner
    if (!appletB & !beanB) {
      // component code
      imageSource=Toolkit.getDefaultToolkit().getImage( filenameS ).getSource();
    } else if (appletB) { 
      // applet code
      imageSource= app.getImage(app.getCodeBase(), filenameS ).getSource();
    } else {
      // bean code
      // beanB==true
      try {
        URL url = getClass().getResource(  filenameS );
        imageSource = (ImageProducer) url.getContent();
      } catch (Exception ex) {
      }
    }
  }
  if(imageSource!=null) {
    image = Toolkit.getDefaultToolkit().createImage(new FilteredImageSource(
               imageSource, new ColorMaskFilter(g.getColor())));
  }
  return image;
} // end getImage

ImageProducer getLocalImageSource(String resourceName) {
  //Try loading images from jar
  ImageProducer source = null;
  try {
    // Next line assumes that Fonts are in the same jar file as sSymbolLoader
    // Since resourceName doesn't start with a "/", resourceName is treated
    // as the relative path to the image file from the directory where
    // sSymbolLoader.class is.
    InputStream imageStream = getClass().getResourceAsStream(resourceName);
    int numBytes = imageStream.available();//System.out.println(numBytes);
    byte[] imageBytes = new byte[numBytes];
//System.out.println(numBytes);
    // Note: If all bytes are immediately available, the while loop just
    // executes once and could be replaced by the line:
    // imageStream.read(imageBytes,0,numBytes);
    // This may always be the case for the small Font images

    int alreadyRead = 0;
    int justRead = 0;
    while (justRead != -1) {
      justRead = imageStream.read(imageBytes,alreadyRead,numBytes);
      if(justRead != -1) { //didn't get all the bytes
        alreadyRead += justRead; //Total Read so far
        numBytes = imageStream.available(); //Amount left to read
        int totalBytes = alreadyRead + numBytes; //total bytes needed to
                                                 //store everything we know about
//System.out.println("+"+numBytes);
        if((totalBytes) > imageBytes.length) {  //haven't yet allocated enough space
          byte[] tempImageBytes= (byte[]) imageBytes.clone();
          imageBytes = new byte[totalBytes];
          System.arraycopy(tempImageBytes, 0, imageBytes, 0, alreadyRead);
        }
      }
    }
    //Create an ImageProducer from the image bytes
    source = Toolkit.getDefaultToolkit().createImage(imageBytes).getSource();
  }
  catch (Exception io) {}
  return source;
} // end getLocalImageSource

} // end class sSymbolLoader
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Des18.gif0000644000175000017500000001515211272077141025571 0ustar  giovannigiovanniwt	aleph.gifsrjava.awt.RectangleðjjtIheightIwidthIxIyxpt	alpha.gifsq~t	amalg.gifsq~:t	angle.gifsq~Wt
approx.gifsq~ttast.gifsq~t	asymp.gifsq~tbeta.gifsq~tbigcirc.gifsq~tbigtriangledown.gifsq~tbigtriangleup.gifsq~"tbot.gifsq~?t
bowtie.gifsq~\tBox.gifsq~yt
bullet.gifsq~
tcap.gifsq~tcdot.gifsq~	t	cdots.gifsq~ tchi.gifsq~
tcirc.gifsq~
'tclubsuit.gifsq~3tcong.gifsq~3tcup.gifsq~3:t
dagger.gifsq~3Wt	dashv.gifsq~3ttddagger.gifsq~3t	ddots.gifsq~ 3t	delta.gifsq~3tDeltaBig.gifsq~3tdiamond.gifsq~
3tDiamondBig.gifsq~3"tdiamondsuit.gifsq~3?tdiv.gifsq~3\t	doteq.gifsq~3yt
downarrow.gifsq~3tDownarrowBig.gifsq~3tell.gifsq~3temptyset.gifsq~3tepsilon.gifsq~
3
t	equiv.gifsq~3'teta.gifsq~ft
exists.gifsq~ftflat.gifsq~
f:t
forall.gifsq~fWtFourier.gifsq~ftt	frown.gifsq~"ft	gamma.gifsq~ftGammaBig.gifsq~ftge.gifsq~ftgeq.gifsq~ftgets.gifsq~f"tgg.gifsq~f?thbar.gifsq~f\t
heartsuit.gifsq~fythookleftarrow.gifsq~ fthookrightarrow.gifsq~!ftIm.gifsq~ft	imath.gifsq~	ftin.gifsq~f
t	infty.gifsq~f'tint.gifsq~tiota.gifsq~
t	jmath.gifsq~
:tJoin.gifsq~Wt	kappa.gifsq~tt
lambda.gifsq~t
LambdaBig.gifsq~tLaplace.gifsq~t	ldots.gifsq~ tle.gifsq~tleadsto.gifsq~ "t
leftarrow.gifsq~?tLeftarrowBig.gifsq~\tleftharpoondown.gifsq~	ytleftharpoonup.gifsq~tleftrightarrow.gifsq~tLeftrightarrowBig.gifsq~tleq.gifsq~tlhd.gifsq~
tll.gifsq~'tlongleftarrow.gifsq~1tLongleftarrowBig.gifsq~2tlongleftrightarrow.gifsq~1:tLongleftrightarrowBig.gifsq~2Wtlongmapsto.gifsq~3ttlongrightarrow.gifsq~2tLongrightarrowBig.gifsq~2t
mapsto.gifsq~tmho.gifsq~tmid.gifsq~t
models.gifsq~"tmp.gifsq~?tmu.gifsq~\t	nabla.gifsq~ytnatural.gifsq~
tnearrow.gifsq~tneg.gifsq~tneq.gifsq~tni.gifsq~
tnu.gifsq~'tnwarrow.gifsq~todot.gifsq~toint.gifsq~:t	omega.gifsq~WtOmegaBig.gifsq~tt
ominus.gifsq~t	oplus.gifsq~t
oslash.gifsq~t
otimes.gifsq~tparallel.gifsq~tpartial.gifsq~"tperp.gifsq~?tphi.gifsq~\t
PhiBig.gifsq~ytpi.gifsq~t	PiBig.gifsq~tpm.gifsq~tprec.gifsq~t
preceq.gifsq~
t	prime.gifsq~'tprod.gifsq~2t
propto.gifsq~2tpsi.gifsq~2:t
PsiBig.gifsq~2WtRe.gifsq~2ttrhd.gifsq~2trho.gifsq~2trightarrow.gifsq~2tRightarrowBig.gifsq~2trightharpoondown.gifsq~	2trightharpoonup.gifsq~2"trightleftharpoons.gifsq~2?tsearrow.gifsq~2\tsetminus.gifsq~2yt	sharp.gifsq~
2t	sigma.gifsq~2tSigmaBig.gifsq~2tsim.gifsq~
2t	simeq.gifsq~
2
t	smile.gifsq~"2't
spadesuit.gifsq~et	sqcap.gifsq~et	sqcup.gifsq~e:tsqsubset.gifsq~eWtsqsubseteq.gifsq~ettsqsupset.gifsq~etsqsupseteq.gifsq~etstar.gifsq~et
subset.gifsq~etsubseteq.gifsq~etsucc.gifsq~e"t
succeq.gifsq~e?tsum.gifsq~e\t
supset.gifsq~eytsupseteq.gifsq~etswarrow.gifsq~ettau.gifsq~
et	theta.gifsq~etThetaBig.gifsq~e
t	times.gifsq~
e'tto.gifsq~ttop.gifsq~ttriangle.gifsq~:ttriangleleft.gifsq~Wttriangleright.gifsq~tt	unlhd.gifsq~t	unrhd.gifsq~tuparrow.gifsq~tUparrowBig.gifsq~tupdownarrow.gifsq~tUpdownarrowBig.gifsq~"t	uplus.gifsq~?tupsilon.gifsq~\tUpsilonBig.gifsq~ytvarepsilon.gifsq~t
varphi.gifsq~t	varpi.gifsq~t
varrho.gifsq~tvarsigma.gifsq~
tvartheta.gifsq~'t	vdash.gifsq~t	vdots.gifsq~
tvee.gifsq~:t	wedge.gifsq~Wtwp.gifsq~ttwr.gifsq~
txi.gifsq~t	XiBig.gifsq~tzeta.gifsq~mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Fonts8.gif0000644000175000017500000000732111272077141026065 0ustar  giovannigiovanniGIF89a,D` 툂5#ONAEBYBQ/\o$ϰv茘08ZL5!Q`GgۢJ>Klg-Jq|&v“7פ7a"W'eWSفxuQZHFؗɥFzq9ۑIhj4|jF$*HP%O^Ě\ZnRk&ŵt2T+pb˚PSxӴӔivKI8iDZ!xb+
U0*Uohz?+HwnwY'o5-.NUn1:F^n*C={ܟw><
˛?>Ҧvo%E<ܣa5jSeɹ1ie{auH'Q_
&aRy=Q j^Fe`@qsH©"N*1X4aUd"=("!*:YT;dU0.IH^`Ȣ@4Ny5韖-~8aY[+ϙW˄E~U\^1uhN^f)z/)~QB$lNWM4ǔv[Gic
Ujr$Zʕ([mY=HErI笝,xIԦiJ7ɓNԆ[Z˖c&A 亯zGխ=(Vn'ӰZf@?:^K	G)J⺉c6Ջg
LL!&Wׯjh<&EkW&Lvle%H~CEn)HX$eԑ՜v:?]Ĕ
'x3'^"orNָ'jV
)_T$XKe6	T'߻O(ԾJް?w
mc(cc-b2N{bR/3 ǽdfP̄&֏&leQRzN} ,,(iqhDZ:r2gb^N{fVrC7nFp4?;BaH|;ٙ'MS?70w{hU~x58) GLiXiV=X2hm|F8凭D)jMqBp8&聑8:RG7yh8Sdٗi)IyQtlP
&P^	@4Qk_&)I#YbIuZ9;\aw]rSd&m[9|È]v[
68$}:D
%iW9>vne%	xv(rg#GKʤ	}K?j
xUH)q\Q@We[PfVeoڸzh3];:T%O> ygEF
ꂶ#8kE'#Fڤ
*ih|[H&@D&%~UX,E	`ب&ykʧE%_Ƃ
V
=z}ԝGrh
/AhG/Å:JŕTRB
ZZ)éog
YJʰ
R;mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/hoteqn/Des12.gif0000644000175000017500000001515211272077141025563 0ustar  giovannigiovanniwt	aleph.gifsrjava.awt.RectangleðjjtIheightIwidthIxIyxpt	alpha.gifsq~t	amalg.gifsq~
(t	angle.gifsq~
 * All properties in this class are bound: when a properties value
 * is changed, all PropertyChangeListeners are fired.
 * 
 * @author Hans Muller
 */
public class MultiSplitPane extends JPanel {
    private AccessibleContext accessibleContext = null;
    private boolean continuousLayout = true;
    private DividerPainter dividerPainter = new DefaultDividerPainter();

    /**
     * Creates a MultiSplitPane with it's LayoutManager set to 
     * to an empty MultiSplitLayout.
     */
    public MultiSplitPane() {
	super(new MultiSplitLayout());
	InputHandler inputHandler = new InputHandler();
	addMouseListener(inputHandler);
	addMouseMotionListener(inputHandler);
	addKeyListener(inputHandler);
	setFocusable(true);
    }

    /** 
     * A convenience method that returns the layout manager cast 
     * to MutliSplitLayout.
     * 
     * @return this MultiSplitPane's layout manager
     * @see java.awt.Container#getLayout
     * @see #setModel
     */
    public final MultiSplitLayout getMultiSplitLayout() {
	return (MultiSplitLayout)getLayout();
    }

    /** 
     * A convenience method that sets the MultiSplitLayout model.
     * Equivalent to getMultiSplitLayout.setModel(model)
     * 
     * @param model the root of the MultiSplitLayout model
     * @see #getMultiSplitLayout
     * @see MultiSplitLayout#setModel
     */
    public final void setModel(Node model) {
	getMultiSplitLayout().setModel(model);
    }

    /** 
     * A convenience method that sets the MultiSplitLayout dividerSize
     * property. Equivalent to 
     * getMultiSplitLayout().setDividerSize(newDividerSize).
     * 
     * @param dividerSize the value of the dividerSize property
     * @see #getMultiSplitLayout
     * @see MultiSplitLayout#setDividerSize
     */
    public final void setDividerSize(int dividerSize) {
	getMultiSplitLayout().setDividerSize(dividerSize);
    }

    /**
     * Sets the value of the continuousLayout property.
     * If true, then the layout is revalidated continuously while
     * a divider is being moved.  The default value of this property
     * is true.
     *
     * @param continuousLayout value of the continuousLayout property
     * @see #isContinuousLayout
     */
    public void setContinuousLayout(boolean continuousLayout) {
        boolean oldContinuousLayout = continuousLayout;
        this.continuousLayout = continuousLayout;
        firePropertyChange("continuousLayout", oldContinuousLayout, continuousLayout);
    }

    /**
     * Returns true if dragging a divider only updates
     * the layout when the drag gesture ends (typically, when the 
     * mouse button is released).
     *
     * @return the value of the continuousLayout property
     * @see #setContinuousLayout
     */
    public boolean isContinuousLayout() {
        return continuousLayout;
    }

    /** 
     * Returns the Divider that's currently being moved, typically
     * because the user is dragging it, or null.
     * 
     * @return the Divider that's being moved or null.
     */
    public Divider activeDivider() {
	return dragDivider;
    }

    /**
     * Draws a single Divider.  Typically used to specialize the
     * way the active Divider is painted.  
     * 
     * @see #getDividerPainter
     * @see #setDividerPainter
     */
    public static abstract class DividerPainter {
	/**
	 * Paint a single Divider.       
	 * 
	 * @param g the Graphics object to paint with
	 * @param divider the Divider to paint
	 */
	public abstract void paint(Graphics g, Divider divider);
    }

    private class DefaultDividerPainter extends DividerPainter {
	public void paint(Graphics g, Divider divider) {
	    if ((divider == activeDivider()) && !isContinuousLayout()) {
		Graphics2D g2d = (Graphics2D)g;
		g2d.setColor(Color.black);
		g2d.fill(divider.getBounds());
	    }
	}
    }

    /** 
     * The DividerPainter that's used to paint Dividers on this MultiSplitPane.
     * This property may be null.
     * 
     * @return the value of the dividerPainter Property
     * @see #setDividerPainter
     */
    public DividerPainter getDividerPainter() {
	return dividerPainter;
    }

    /** 
     * Sets the DividerPainter that's used to paint Dividers on this 
     * MultiSplitPane.  The default DividerPainter only draws
     * the activeDivider (if there is one) and then, only if 
     * continuousLayout is false.  The value of this property is 
     * used by the paintChildren method: Dividers are painted after
     * the MultiSplitPane's children have been rendered so that 
     * the activeDivider can appear "on top of" the children.
     * 
     * @param dividerPainter the value of the dividerPainter property, can be null
     * @see #paintChildren
     * @see #activeDivider
     */
    public void setDividerPainter(DividerPainter dividerPainter) {
	this.dividerPainter = dividerPainter;
    }

    /**
     * Uses the DividerPainter (if any) to paint each Divider that
     * overlaps the clip Rectangle.  This is done after the call to
     * super.paintChildren() so that Dividers can be 
     * rendered "on top of" the children.
     * 
    
     * {@inheritDoc}
     */
    protected void paintChildren(Graphics g) {
	super.paintChildren(g);
	DividerPainter dp = getDividerPainter();
	Rectangle clipR = g.getClipBounds();
	if ((dp != null) && (clipR != null)) {
            Graphics dpg = g.create();
            try {
		MultiSplitLayout msl = getMultiSplitLayout();
		for(Divider divider : msl.dividersThatOverlap(clipR)) {
		    dp.paint(dpg, divider);
		}
            }
            finally {
		dpg.dispose();
            }
	}
    }

    private boolean dragUnderway = false;
    private MultiSplitLayout.Divider dragDivider = null;
    private Rectangle initialDividerBounds = null;
    private boolean oldFloatingDividers = true;
    private int dragOffsetX = 0;
    private int dragOffsetY = 0;
    private int dragMin = -1;
    private int dragMax = -1;
    
    private void startDrag(int mx, int my) {
	requestFocusInWindow();
	MultiSplitLayout msl = getMultiSplitLayout();
	MultiSplitLayout.Divider divider = msl.dividerAt(mx, my);
	if (divider != null) {
	    MultiSplitLayout.Node prevNode = divider.previousSibling();
	    MultiSplitLayout.Node nextNode = divider.nextSibling();
	    if ((prevNode == null) || (nextNode == null)) {
		dragUnderway = false;
	    }
	    else {
		initialDividerBounds = divider.getBounds();
		dragOffsetX = mx - initialDividerBounds.x;
		dragOffsetY = my - initialDividerBounds.y;
		dragDivider  = divider;
		Rectangle prevNodeBounds = prevNode.getBounds();
		Rectangle nextNodeBounds = nextNode.getBounds();
		if (dragDivider.isVertical()) {
		    dragMin = prevNodeBounds.x;
		    dragMax = nextNodeBounds.x + nextNodeBounds.width;
		    dragMax -= dragDivider.getBounds().width;
		}
		else {
		    dragMin = prevNodeBounds.y;
		    dragMax = nextNodeBounds.y + nextNodeBounds.height;
		    dragMax -= dragDivider.getBounds().height;
		}
		oldFloatingDividers = getMultiSplitLayout().getFloatingDividers();
		getMultiSplitLayout().setFloatingDividers(false);
		dragUnderway = true;
	    }
	}
	else {
	    dragUnderway = false;
	}
    }

    private void repaintDragLimits() {
	Rectangle damageR = dragDivider.getBounds();
	if (dragDivider.isVertical()) {
	    damageR.x = dragMin;
	    damageR.width = dragMax - dragMin;
	}
	else {
	    damageR.y = dragMin;
	    damageR.height = dragMax - dragMin;
	}
	repaint(damageR);
    }

    private void updateDrag(int mx, int my) {
	if (!dragUnderway) {
	    return;
	}
	Rectangle oldBounds = dragDivider.getBounds();
	Rectangle bounds = new Rectangle(oldBounds);
	if (dragDivider.isVertical()) {
	    bounds.x = mx - dragOffsetX;
	    bounds.x = Math.max(bounds.x, dragMin);
	    bounds.x = Math.min(bounds.x, dragMax);
	}
	else {
	    bounds.y = my - dragOffsetY;
	    bounds.y = Math.max(bounds.y, dragMin);
	    bounds.y = Math.min(bounds.y, dragMax);
	}
	dragDivider.setBounds(bounds);
	if (isContinuousLayout()) {
	    revalidate();
	    repaintDragLimits();
	}
	else {
	    repaint(oldBounds.union(bounds));
	}
    }

    private void clearDragState() {
	dragDivider = null;
	initialDividerBounds = null;
	oldFloatingDividers = true;
	dragOffsetX = dragOffsetY = 0;
	dragMin = dragMax = -1;
	dragUnderway = false;
    }

    private void finishDrag(int x, int y) {
	if (dragUnderway) {
	    clearDragState();
	    if (!isContinuousLayout()) {
		revalidate();
		repaint();
	    }
	}
    }
    
    private void cancelDrag() {       
	if (dragUnderway) {
	    dragDivider.setBounds(initialDividerBounds);
	    getMultiSplitLayout().setFloatingDividers(oldFloatingDividers);
	    setCursor(Cursor.getPredefinedCursor(Cursor.DEFAULT_CURSOR));
	    repaint();
	    revalidate();
	    clearDragState();
	}
    }

    private void updateCursor(int x, int y, boolean show) {
	if (dragUnderway) {
	    return;
	}
	int cursorID = Cursor.DEFAULT_CURSOR;
	if (show) {
	    MultiSplitLayout.Divider divider = getMultiSplitLayout().dividerAt(x, y);
	    if (divider != null) {
		cursorID  = (divider.isVertical()) ? 
		    Cursor.E_RESIZE_CURSOR : 
		    Cursor.N_RESIZE_CURSOR;
	    }
	}
	setCursor(Cursor.getPredefinedCursor(cursorID));
    }


    private class InputHandler extends MouseInputAdapter implements KeyListener {

	public void mouseEntered(MouseEvent e) {
	    updateCursor(e.getX(), e.getY(), true);
	}

	public void mouseMoved(MouseEvent e) {
	    updateCursor(e.getX(), e.getY(), true);
	}

	public void mouseExited(MouseEvent e) {
	    updateCursor(e.getX(), e.getY(), false);
	}

	public void mousePressed(MouseEvent e) {
	    startDrag(e.getX(), e.getY());
	}
	public void mouseReleased(MouseEvent e) {
	    finishDrag(e.getX(), e.getY());
	}
	public void mouseDragged(MouseEvent e) {
	    updateDrag(e.getX(), e.getY());	    
	}
        public void keyPressed(KeyEvent e) { 
	    if (e.getKeyCode() == KeyEvent.VK_ESCAPE) {
		cancelDrag();
	    }
	}
        public void keyReleased(KeyEvent e) { }
	public void keyTyped(KeyEvent e) { }
    }

    public AccessibleContext getAccessibleContext() {
        if( accessibleContext == null ) {
            accessibleContext = new AccessibleMultiSplitPane();
        }
        return accessibleContext;
    }
    
    protected class AccessibleMultiSplitPane extends AccessibleJPanel {
        public AccessibleRole getAccessibleRole() {
            return AccessibleRole.SPLIT_PANE;
        }
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/simulator/0000755000175000017500000000000011722677337024750 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/simulator/Points.java0000644000175000017500000000417111144352613027053 0ustar  giovannigiovanni

package org.mathpiper.ui.gui.simulator;




import java.awt.Color;
import java.awt.Graphics;
import java.util.ArrayList;
import java.util.Collections;
import java.util.List;


public class Points
{
  private List pointsList = Collections.synchronizedList(new ArrayList());

  //private static final int DOTSIZE = 4;
  //private static final int RADIUS = DOTSIZE/2;
  private static final int MAXPOINTS = 40;

  private static volatile Color color = new Color(0,0,0);

  private static volatile int plotWidth = 4;


  private int pWidth, pHeight;   // panel dimensions
  private long startTime;        // in ms



  public Points(int pW, int pH)
  {
    pWidth = pW; pHeight = pH;

  }

  public synchronized void addPoint(int x, int y)
  {
      pointsList.add(new Point(x,y, color, plotWidth));
  }

  public synchronized void clear()
  {
      pointsList.clear();
  }


 

  public synchronized void draw(Graphics g)
  // draw a black worm with a red head
  {
    
      //g.setColor(color);

      for(Point point : pointsList)
      {
        g.setColor(point.getColor());
        g.fillOval(point.getX(), point.getY(), point.getPlotWidth(), point.getPlotWidth());
      }

    
  }  // end of draw()

  class Point
  {
      private int x;
      private int y;
      private Color color;
      private int plotWidth;

      private Point(int x, int y, Color color, int plotWidth)
      {
          this.x=x;
          this.y=y;
          this.color = color;
          this.plotWidth = plotWidth;
      }

        public int getX() {
            return x;
        }

        public int getY() {
            return y;
        }

        public Color getColor() {
            return this.color;
        }

        public int getPlotWidth() {
            return this.plotWidth;
        }

  }

public static synchronized void setColor(int red, int green, int blue)
{
    if( (red >= 0) && (red <= 255) && (green >= 0) && (green <= 255) && (blue >= 0) && (blue <= 255) )
    {
        color = new Color(red, green, blue);
    }
}

  public static void setPlotWidth(int plotWidthParam)
  {
       plotWidth = plotWidthParam;
  }

}  // end of Worm class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/simulator/SimulatorPanel.java0000644000175000017500000003176111144352613030543 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.simulator;

import javax.swing.*;
import java.awt.event.*;
import java.awt.*;
import java.text.DecimalFormat;

//import com.sun.j3d.utils.timer.J3DTimer;
public class SimulatorPanel extends JPanel implements Runnable {

    private static final int PWIDTH = 505;   // size of panel
    private static final int PHEIGHT = 505;
    private static long MAX_STATS_INTERVAL = 1000000000L;
    // private static long MAX_STATS_INTERVAL = 1000L;
    // record stats every 1 second (roughly)
    private static final int NO_DELAYS_PER_YIELD = 16;
    /* Number of frames with a delay of 0 ms before the animation thread yields
    to other running threads. */
    private static int MAX_FRAME_SKIPS = 5;   // was 2;
    // no. of frames that can be skipped in any one animation loop
    // i.e the games state is updated but not rendered
    private static int NUM_FPS = 10;
    // number of FPS values stored to get an average
    // used for gathering statistics
    private long statsInterval = 0L;    // in ns
    private long prevStatsTime;
    private long totalElapsedTime = 0L;
    private long simulatorStartTime;
    private int timeSpentInGame = 0;    // in seconds
    private long frameCount = 0;
    private double fpsStore[];
    private long statsCount = 0;
    private double averageFPS = 0.0;
    private long framesSkipped = 0L;
    private long totalFramesSkipped = 0L;
    private double upsStore[];
    private double averageUPS = 0.0;
    private DecimalFormat df = new DecimalFormat("0.##");  // 2 dp
    private DecimalFormat timedf = new DecimalFormat("0.####");  // 4 dp
    private Thread animator;           // the thread that performs the animation
    private boolean running = false;   // used to stop the animation thread
    private boolean isPaused = false;
    private long period;                // period between drawing in _nanosecs_
    private SimulatorFrame wcTop;
    private Points points;       // the worm
    // used at game termination
    private boolean gameOver = false;
    private int score = 0;
    private Font font;
    private FontMetrics metrics;

    // off screen rendering
    private Graphics dbg;
    private Image dbImage = null;

    public SimulatorPanel(SimulatorFrame wc, long period) {
        wcTop = wc;
        this.period = period;

        setBackground(Color.white);
        setPreferredSize(new Dimension(PWIDTH, PHEIGHT));

        setFocusable(true);
        requestFocus();    // the JPanel now has focus, so receives key events
        readyForTermination();

        points = new Points(PWIDTH, PHEIGHT);

        addMouseListener(new MouseAdapter() {

            public void mousePressed(MouseEvent e) {
                testPress(e.getX(), e.getY());
            }
        });

        // set up message font
        font = new Font("SansSerif", Font.BOLD, 24);
        metrics = this.getFontMetrics(font);

        // initialise timing elements
        fpsStore = new double[NUM_FPS];
        upsStore = new double[NUM_FPS];
        for (int i = 0; i < NUM_FPS; i++) {
            fpsStore[i] = 0.0;
            upsStore[i] = 0.0;
        }
    } //end SimulatorPanel.

    public void plotPoint(int x, int y)
    {
        points.addPoint(x, y);
    }

    private void readyForTermination() {
        addKeyListener(new KeyAdapter() {
            // listen for esc, q, end, ctrl-c on the canvas to
            // allow a convenient exit from the full screen configuration

            public void keyPressed(KeyEvent e) {
                int keyCode = e.getKeyCode();
                if ((keyCode == KeyEvent.VK_ESCAPE) || (keyCode == KeyEvent.VK_Q) ||
                        (keyCode == KeyEvent.VK_END) ||
                        ((keyCode == KeyEvent.VK_C) && e.isControlDown())) {
                    running = false;
                }
            }
        });
    }  // end of readyForTermination()

    public void addNotify() // wait for the JPanel to be added to the JFrame before starting
    {
        super.addNotify();   // creates the peer
        startSimulator();         // start the thread
    }

    private void startSimulator() // initialise and start the thread
    {
        if (animator == null || !running) {
            animator = new Thread(this);
            animator.start();
        }
    } // end of startSimulator()


    // ------------- game life cycle methods ------------
    // called by the JFrame's window listener methods
    public void resumeSimulator() // called when the JFrame is activated / deiconified
    {
        isPaused = false;
    }

    public void pauseSimulator() // called when the JFrame is deactivated / iconified
    {
        isPaused = true;
    }

    public void stopSimulator() // called when the JFrame is closing
    {
        running = false;
    }

    // ----------------------------------------------
    private void testPress(int x, int y) // is (x,y) near the head or should an obstacle be added?
    {
       /* if (!isPaused && !gameOver) {
            if (fred.nearHead(x, y)) {   // was mouse press near the head?
                gameOver = true;
                score = (40 - timeSpentInGame) + (40 - obs.getNumObstacles());
            // hack together a score
            } else {   // add an obstacle if possible
                if (!fred.touchedAt(x, y)) // was the worm's body untouched?
                {
                    obs.add(x, y);
                }
            }
        }*/
    }  // end of testPress()

    public void run() /* The frames of the animation are drawn inside the while loop. */ {
        long beforeTime, afterTime, timeDiff, sleepTime;
        long overSleepTime = 0L;
        int noDelays = 0;
        long excess = 0L;

        simulatorStartTime = System.nanoTime(); //J3DTimer.getValue();
        prevStatsTime = simulatorStartTime;
        beforeTime = simulatorStartTime;

        running = true;

        while (running) {
            simulatorUpdate();
            simulatorRender();
            paintScreen();

            afterTime = System.nanoTime(); //J3DTimer.getValue();
            timeDiff = afterTime - beforeTime;
            sleepTime = (period - timeDiff) - overSleepTime;

            if (sleepTime > 0) {   // some time left in this cycle
                try {
                    Thread.sleep(sleepTime / 1000000L);  // nano -> ms
                } catch (InterruptedException ex) {
                }
                overSleepTime = (System.nanoTime() - afterTime) - sleepTime;
            } else {    // sleepTime <= 0; the frame took longer than the period
                excess -= sleepTime;  // store excess time value
                overSleepTime = 0L;

                if (++noDelays >= NO_DELAYS_PER_YIELD) {
                    Thread.yield();   // give another thread a chance to run
                    noDelays = 0;
                }
            }

            beforeTime = System.nanoTime(); //J3DTimer.getValue();

            /* If frame animation is taking too long, update the game state
            without rendering it, to get the updates/sec nearer to
            the required FPS. */
            int skips = 0;
            while ((excess > period) && (skips < MAX_FRAME_SKIPS)) {
                excess -= period;
                simulatorUpdate();    // update state but don't render
                skips++;
            }
            framesSkipped += skips;

            storeStats();
        }

        printStats();
        //System.exit(0);   // so window disappears
    } // end of run()

    private void simulatorUpdate() {
        if (!isPaused && !gameOver) {
            //fred.move();
        }
    }  // end of gameUpdate()

    private void simulatorRender() {
        if (dbImage == null) {
            dbImage = createImage(PWIDTH, PHEIGHT);
            if (dbImage == null) {
                System.out.println("dbImage is null");
                return;
            } else {
                dbg = dbImage.getGraphics();
            }
        }

        // clear the background
        dbg.setColor(Color.white);
        dbg.fillRect(0, 0, PWIDTH, PHEIGHT);

        dbg.setColor(Color.blue);
        dbg.setFont(font);

        // report frame count & average FPS and UPS at top left
        // dbg.drawString("Frame Count " + frameCount, 10, 25);
        
        //dbg.drawString("Average FPS/UPS: " + df.format(averageFPS) + ", " + df.format(averageUPS), 20, 25);  // was (10,55)

        //dbg.setColor(Color.black);

        points.draw(dbg);

        if (gameOver) {
            simulationOverMessage(dbg);
        }
    }  // end of gameRender()

    private void simulationOverMessage(Graphics g) // center the game-over message in the panel
    {
        String msg = "Game Over. Your Score: " + score;
        int x = (PWIDTH - metrics.stringWidth(msg)) / 2;
        int y = (PHEIGHT - metrics.getHeight()) / 2;
        g.setColor(Color.red);
        g.setFont(font);
        g.drawString(msg, x, y);
    }  // end of gameOverMessage()

    private void paintScreen() // use active rendering to put the buffered image on-screen
    {
        Graphics g;
        try {
            g = this.getGraphics();
            if ((g != null) && (dbImage != null)) {
                g.drawImage(dbImage, 0, 0, null);
            }
            g.dispose();
        } catch (Exception e) {
            System.out.println("Graphics context error: " + e);
        }
    } // end of paintScreen()

    private void storeStats() /* The statistics:
    - the summed periods for all the iterations in this interval
    (period is the amount of time a single frame iteration should take),
    the actual elapsed time in this interval,
    the error between these two numbers;

    - the total frame count, which is the total number of calls to run();

    - the frames skipped in this interval, the total number of frames
    skipped. A frame skip is a game update without a corresponding render;

    - the FPS (frames/sec) and UPS (updates/sec) for this interval,
    the average FPS & UPS over the last NUM_FPSs intervals.

    The data is collected every MAX_STATS_INTERVAL  (1 sec).
     */ {
        frameCount++;
        statsInterval += period;

        if (statsInterval >= MAX_STATS_INTERVAL) {     // record stats every MAX_STATS_INTERVAL
            long timeNow = System.nanoTime(); //J3DTimer.getValue();
            timeSpentInGame = (int) ((timeNow - simulatorStartTime) / 1000000000L);  // ns --> secs
            wcTop.setTimeSpent(timeSpentInGame);

            long realElapsedTime = timeNow - prevStatsTime;   // time since last stats collection
            totalElapsedTime += realElapsedTime;

            double timingError =
                    ((double) (realElapsedTime - statsInterval) / statsInterval) * 100.0;

            totalFramesSkipped += framesSkipped;

            double actualFPS = 0;     // calculate the latest FPS and UPS
            double actualUPS = 0;
            if (totalElapsedTime > 0) {
                actualFPS = (((double) frameCount / totalElapsedTime) * 1000000000L);
                actualUPS = (((double) (frameCount + totalFramesSkipped) / totalElapsedTime) * 1000000000L);
            }

            // store the latest FPS and UPS
            fpsStore[(int) statsCount % NUM_FPS] = actualFPS;
            upsStore[(int) statsCount % NUM_FPS] = actualUPS;
            statsCount = statsCount + 1;

            double totalFPS = 0.0;     // total the stored FPSs and UPSs
            double totalUPS = 0.0;
            for (int i = 0; i < NUM_FPS; i++) {
                totalFPS += fpsStore[i];
                totalUPS += upsStore[i];
            }

            if (statsCount < NUM_FPS) { // obtain the average FPS and UPS
                averageFPS = totalFPS / statsCount;
                averageUPS = totalUPS / statsCount;
            } else {
                averageFPS = totalFPS / NUM_FPS;
                averageUPS = totalUPS / NUM_FPS;
            }
            /*
            System.out.println(timedf.format( (double) statsInterval/1000000000L) + " " +
            timedf.format((double) realElapsedTime/1000000000L) + "s " +
            df.format(timingError) + "% " +
            frameCount + "c " +
            framesSkipped + "/" + totalFramesSkipped + " skip; " +
            df.format(actualFPS) + " " + df.format(averageFPS) + " afps; " +
            df.format(actualUPS) + " " + df.format(averageUPS) + " aups" );
             */
            framesSkipped = 0;
            prevStatsTime = timeNow;
            statsInterval = 0L;   // reset
        }
    }  // end of storeStats()

    public void clear()
    {
        points.clear();
    }

   public void setColor(int red, int green, int blue)
  {
       Points.setColor(red, green, blue);
  }

  public void setPlotWidth(int plotWidth)
  {
       Points.setPlotWidth(plotWidth);
  }

    private void printStats() {
        /*System.out.println("Frame Count/Loss: " + frameCount + " / " + totalFramesSkipped);
        System.out.println("Average FPS: " + df.format(averageFPS));
        System.out.println("Average UPS: " + df.format(averageUPS));
        System.out.println("Time Spent: " + timeSpentInGame + " secs");*/
    }  // end of printStats()
}  // end of SimulatorPanel class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/simulator/SimulatorFrame.java0000644000175000017500000000643311144352613030534 0ustar  giovannigiovanni

package org.mathpiper.ui.gui.simulator;




import javax.swing.*;
import java.awt.*;
import java.awt.event.*;


public class SimulatorFrame extends JFrame implements WindowListener, ActionListener
{
  private static int DEFAULT_FPS = 10; //;80;

  private SimulatorPanel simulatorPanel;        // where the worm is drawn
  private JTextField jtfBox;   // displays no.of boxes used
  private JTextField jtfTime;  // displays time spent in game


  public SimulatorFrame(long period)
  { 
      super("MathPiper Simulator");
      setDefaultCloseOperation(javax.swing.WindowConstants.DISPOSE_ON_CLOSE);

   if(period == -1)
   {
    int fps = DEFAULT_FPS;

    period = (long) 1000.0/fps;
    //System.out.println("fps: " + fps + "; period: " + period + " ms");

    period = period*1000000;    // ms --> nanosecs
   }

    makeGUI(period);

    addWindowListener( this );
    pack();
    setResizable(true);
    setVisible(true);
  }  // end of WormChase() constructor

  public SimulatorFrame()
  {
        this(-1);
  }

  public void plotPoint(int x, int y)
  {
      simulatorPanel.plotPoint(x, y);
  }

  private void makeGUI(long period)
  {
    Container container = getContentPane();    // default BorderLayout used

    simulatorPanel = new SimulatorPanel(this, period);
    container.add(simulatorPanel, "Center");

    JPanel ctrls = new JPanel();   // a row of textfields
    ctrls.setLayout( new BoxLayout(ctrls, BoxLayout.X_AXIS));

    jtfBox = new JTextField("Boxes used: 0");
    jtfBox.setEditable(false);
    ctrls.add(jtfBox);

    jtfTime = new JTextField("Time Spent: 0 secs");
    jtfTime.setEditable(false);
    ctrls.add(jtfTime);

    JButton closeButton = new JButton("Clear");
    closeButton.addActionListener(this);

    JPanel buttonPanel = new JPanel();
    buttonPanel.add(closeButton);

    container.add(buttonPanel, "South");
  }  // end of makeGUI()

  public void actionPerformed(ActionEvent e)
  {
        simulatorPanel.clear();
  }


  public void setBoxNumber(int no)
  {  jtfBox.setText("Boxes used: " + no);  }

  public void setTimeSpent(long t)
  {  jtfTime.setText("Time Spent: " + t + " secs"); }


  // ----------------- window listener methods -------------

  public void windowActivated(WindowEvent e)
  { simulatorPanel.resumeSimulator();  }

  public void windowDeactivated(WindowEvent e)
  {  simulatorPanel.pauseSimulator();  }


  public void windowDeiconified(WindowEvent e)
  {  simulatorPanel.resumeSimulator();  }

  public void windowIconified(WindowEvent e)
  {  simulatorPanel.pauseSimulator(); }


  public void windowClosing(WindowEvent e)
  {  simulatorPanel.stopSimulator();  }


  public void windowClosed(WindowEvent e) {}
  public void windowOpened(WindowEvent e) {}

  public void setColor(int red, int green, int blue)
  {
       simulatorPanel.setColor(red, green, blue);
  }

  public void setPlotWidth(int plotWidth)
  {
       simulatorPanel.setPlotWidth(plotWidth);
  }

  // ----------------------------------------------------

  public static void main(String args[])
  {
    int fps = DEFAULT_FPS;
    if (args.length != 0)
      fps = Integer.parseInt(args[0]);

    long period = (long) 1000.0/fps;
    //System.out.println("fps: " + fps + "; period: " + period + " ms");

    new SimulatorFrame(period*1000000L);    // ms --> nanosecs
  }

} // end of WormChase class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/Utility.java0000644000175000017500000000141111506507632025222 0ustar  giovannigiovannipackage org.mathpiper.ui.gui;

import java.io.File;
import javax.swing.JComponent;
import javax.swing.JFileChooser;
import org.mathpiper.ui.gui.consoles.ResultHolder;

public class Utility {

    public static void saveImageOfComponent(JComponent component) {
        JFileChooser saveImageFileChooser = new JFileChooser();

        int returnValue = saveImageFileChooser.showSaveDialog(component);

        if (returnValue == JFileChooser.APPROVE_OPTION) {
            File exportImageFile = saveImageFileChooser.getSelectedFile();
            try {
                ScreenCapture.createImage(component, exportImageFile.getAbsolutePath());
            } catch (java.io.IOException ioe) {
                ioe.printStackTrace();
            }//end try/catch.

        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/0000755000175000017500000000000011722677340023653 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/HelpEvent.java0000644000175000017500000000125611417764103026407 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.help;


public class HelpEvent
{
    private String filePath = null;

    private String sourceCode = null;


    public HelpEvent()
    {
        super();
    }


    public HelpEvent(String filePath, String sourceCode)
    {
    	this.filePath = filePath;
    	
        this.sourceCode = sourceCode;
    }


    
    public String getFilePath() {
        return filePath;
    }


    public void setFilePath(String filePath) {
        this.filePath = filePath;
    }
    

    public String getSourceCode() {
        return sourceCode;
    }


    public void setSourceCode(String sourceCode) {
        this.sourceCode = sourceCode;
    }



}//end class.mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/data/0000755000175000017500000000000011722677340024564 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/FunctionInfo.java0000644000175000017500000000333711372447047027125 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=1:

package org.mathpiper.ui.gui.help;

public class FunctionInfo
{
	private String name;
        private String access;
	private String description;

	public FunctionInfo()
	{
	}

	public FunctionInfo(String name, String description)
	{
		this.name = name;
		this.description = description;
                this.access = "public";
	}//end constructor.


        public FunctionInfo(String name, String access, String description)
	{
		this.name = name;
                this.access = access;
		this.description = description;

	}//end constructor.


	public void setName(String name)
	{
		this.name = name;
	}//end method.

	public void setDescription(String description)
	{
		this.description = description;
	}//end method.

	public String getDescription()
	{
		return description;
	}//end method.


	public String getAccess()
	{
		return access;
	}//end method.

	public String toString()
	{
		return(this.name);
	}//end method.

}//end class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/RenderedLatex.java0000644000175000017500000000217011412252600027224 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.help;

import java.awt.Color;
import java.awt.Dimension;
import java.awt.Insets;
import javax.swing.JLabel;
import javax.swing.JScrollPane;
import org.scilab.forge.jlatexmath.TeXConstants;
import org.scilab.forge.jlatexmath.TeXFormula;
import org.scilab.forge.jlatexmath.TeXIcon;
import org.scilab.forge.jlatexmath.DefaultTeXFont;
import org.scilab.forge.jlatexmath.cyrillic.CyrillicRegistration;
import org.scilab.forge.jlatexmath.greek.GreekRegistration;

public class RenderedLatex extends JLabel {

    public RenderedLatex() {
        super();
        //this.setText("Hello.");


    }


    public void setLatex(String latexString) {
        
        DefaultTeXFont.registerAlphabet(new CyrillicRegistration());
	DefaultTeXFont.registerAlphabet(new GreekRegistration());
	TeXFormula formula = new TeXFormula(latexString);
	TeXIcon icon = formula.createTeXIcon(TeXConstants.STYLE_DISPLAY, 17);
	icon.setInsets(new Insets(1, 1, 1, 1));
        this.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
        this.setAlignmentY(icon.getBaseLine());
        this.setIcon(icon);

    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/FunctionInfoTree.java0000644000175000017500000001155711372447047027750 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=1:
package org.mathpiper.ui.gui.help;


import java.awt.Color;
import java.awt.Component;
import javax.swing.JTree;
import javax.swing.tree.*;


public class FunctionInfoTree extends JTree {

    private DefaultTreeCellRenderer renderer = new DefaultTreeCellRenderer() {

        @Override
        public Component getTreeCellRendererComponent(JTree tree, Object value,
                boolean sel, boolean expanded, boolean leaf, int row,
                boolean hasFocus) {

            super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf,
                    row, hasFocus);

            if (value instanceof DefaultMutableTreeNode) {
                DefaultMutableTreeNode DefaultMutableTreeNode = (DefaultMutableTreeNode) value;
                Object userObject = DefaultMutableTreeNode.getUserObject();

                if (!(userObject instanceof String)) {

                    FunctionInfo functionInfo = (FunctionInfo) userObject;

                    String access = functionInfo.getAccess();

                    if (access.equals("private")) {
                        //this.setTextSelectionColor(Color.RED);
                        //this.setTextNonSelectionColor(Color.RED);
                        this.setForeground(Color.RED);
                    }
                    else if (access.equals("experimental")) {
                        //this.setTextSelectionColor(Color.RED);
                        //this.setTextNonSelectionColor(Color.RED);
                        this.setForeground(new Color(155,0,153));
                    } else {
                        //this.setTextSelectionColor(Color.BLACK);
                        //this.setTextNonSelectionColor(Color.BLACK);
                        this.setForeground(Color.BLACK);
                    }

                }//end if.
            }//end if.


            return this;
        }


    };


    public FunctionInfoTree() {
        super();
        this.setCellRenderer(renderer);
    }


    public FunctionInfoTree(DefaultMutableTreeNode node) {
        super(node);
        this.setCellRenderer(renderer);
    }


    public FunctionInfoTree(TreeModel model) {
        super(model);
        this.setCellRenderer(renderer);
    }


    public void setNode(DefaultMutableTreeNode node) {
        setModel(new DefaultTreeModel(node));
    }//end method.


    public String getToolTipText(java.awt.event.MouseEvent e) {
        DefaultMutableTreeNode node = null;
        FunctionInfo functionInfo = null;
        String tip = null;
        TreePath path = getPathForLocation(e.getX(), e.getY());

        if (path != null) {
            node = (DefaultMutableTreeNode) path.getLastPathComponent();
            Object object = node.getUserObject();
            if(object instanceof FunctionInfo)
            {
                functionInfo = (FunctionInfo) object;
                tip = functionInfo.getDescription();
            }
            else
            {
                tip = (String) object;
            }//end if/else.
            
        }//end if.

        return tip == null ? null : tip;

    }//end method.


    // If expand is true, expands all nodes in the tree.
    // Otherwise, collapses all nodes in the tree.
    public void collapseAll() {
        DefaultMutableTreeNode root = (DefaultMutableTreeNode) this.getModel().getRoot();

        // Traverse tree from root
        expandAll(this, new TreePath(root), false);
    }


    private void expandAll(JTree tree, TreePath parent, boolean expand) {
        // Traverse children
        DefaultMutableTreeNode node = (DefaultMutableTreeNode) parent.getLastPathComponent();
        if (node.getChildCount() >= 0) {
            for (java.util.Enumeration e = node.children(); e.hasMoreElements();) {
                TreeNode n = (TreeNode) e.nextElement();
                TreePath path = parent.pathByAddingChild(n);
                expandAll(tree, path, expand);
            }
        }

        // Expansion or collapse must be done bottom-up
        if (expand) {
            tree.expandPath(parent);
        } else {
            tree.collapsePath(parent);
        }
    }


}//end class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/HelpListener.java0000644000175000017500000000021111417656732027111 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.help;


public interface HelpListener
{
    public void helpEvent(HelpEvent helpEvent);

}// end interface.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/help/FunctionTreePanel.java0000644000175000017500000015411211617645503030106 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 *///}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.help;

import java.awt.BorderLayout;
import java.awt.Container;
import java.awt.Dimension;
import java.awt.Font;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.ItemEvent;
import java.awt.event.ItemListener;
import java.io.BufferedInputStream;
import java.io.BufferedReader;
import java.io.FileNotFoundException;
import java.io.IOException;
import java.io.InputStream;
import java.io.InputStreamReader;
import java.io.RandomAccessFile;
import java.net.URL;
import java.util.ArrayList;
import java.util.Arrays;
import java.util.Enumeration;
import java.util.HashMap;
import java.util.List;
import java.util.Map;
import java.util.Vector;
import java.util.regex.Matcher;
import java.util.regex.Pattern;
import javax.swing.Box;
import javax.swing.BoxLayout;
import javax.swing.JButton;
import javax.swing.JCheckBox;
import javax.swing.JEditorPane;
import javax.swing.JFrame;
import javax.swing.JLabel;
import javax.swing.JList;
import javax.swing.JPanel;
import javax.swing.JScrollBar;
import javax.swing.JScrollPane;
import javax.swing.JSplitPane;
import javax.swing.JTabbedPane;
import javax.swing.JTextField;
import javax.swing.ListSelectionModel;
import javax.swing.SwingUtilities;
import javax.swing.ToolTipManager;
import javax.swing.event.HyperlinkEvent;
import javax.swing.event.HyperlinkListener;
import javax.swing.event.ListSelectionEvent;
import javax.swing.event.ListSelectionListener;
import javax.swing.event.TreeSelectionEvent;
import javax.swing.event.TreeSelectionListener;
import javax.swing.tree.DefaultMutableTreeNode;
import javax.swing.tree.DefaultTreeModel;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;

public class FunctionTreePanel extends JPanel implements TreeSelectionListener, HyperlinkListener {

    private JScrollPane docsScrollPane;
    private String[][] userFunctionsData;
    private String[][] programmerFunctionsData;
    private String[][] operatorsData;
    private DefaultMutableTreeNode userFunctionsNode;
    private DefaultMutableTreeNode programmerFunctionsNode;
    private DefaultMutableTreeNode operatorsNode;
    private List allFunctions;
    private FunctionInfoTree functionsTree;
    private Map documentationIndex;
    private RandomAccessFile documentFile;
    private JEditorPane editorPane;
    private static StringBuilder seeFunctionsBuilder = new StringBuilder();
    private List pageList;
    private ToolPanel toolPanel = null;
    private String selectedFunctionName = "";
    private boolean showPrivateFunctions = false;
    private boolean showExperimentalFunctions = true;
    private JScrollPane treeViewScrollPane;
    private JSplitPane splitPane;
    private JPanel treePanel;
    private ArrayList helpListeners;


    public FunctionTreePanel() throws FileNotFoundException {
        
        helpListeners = new ArrayList();

        this.setLayout(new BorderLayout());

        pageList = new ArrayList();
        pageList.add("HomePage");

        InputStream functionCategoriesStream = FunctionTreePanel.class.getResourceAsStream("/org/mathpiper/ui/gui/help/data/function_categories.txt");

        if (functionCategoriesStream == null) {
            throw new FileNotFoundException("The file function_categories.txt was not found.");
        }

        loadCategories(functionCategoriesStream);

        InputStream documentationIndexStream = FunctionTreePanel.class.getResourceAsStream("/org/mathpiper/ui/gui/help/data/documentation_index.txt");

        if (documentationIndexStream == null) {
            throw new FileNotFoundException("The file documentation_index.txt was not found.");
        }

        loadDocumentationIndex(documentationIndexStream);

        createTree();

        ToolTipManager.sharedInstance().registerComponent(functionsTree);

        treePanel = new JPanel();
        treePanel.setLayout(new BorderLayout());
        treePanel.add(functionsTree);
        treeViewScrollPane = new JScrollPane(treePanel);
        treeViewScrollPane.getVerticalScrollBar().setUnitIncrement(60);
        treeViewScrollPane.getVerticalScrollBar().setBlockIncrement(180);



        editorPane = new JEditorPane();
        editorPane.setEditable(false);
        editorPane.setEditorKit(new javax.swing.text.html.HTMLEditorKit());
        editorPane.addHyperlinkListener(this);
        //editorPane.putClientProperty(JEditorPane.HONOR_DISPLAY_PROPERTIES, Boolean.TRUE);

        //JdocsScrollPane editorScrollPane = new JScrollPane(editorPane);
        docsScrollPane = new JScrollPane(editorPane, JScrollPane.VERTICAL_SCROLLBAR_AS_NEEDED, JScrollPane.HORIZONTAL_SCROLLBAR_AS_NEEDED);


        JTabbedPane tabbedPane = new JTabbedPane();

        JPanel treePanelContainer = new JPanel();


        //Collapse tree button.
        JButton collapseButton = new javax.swing.JButton("Collapse");
        collapseButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                collapse();
            }

        });
        collapseButton.setEnabled(true);
        collapseButton.setToolTipText("Collapse function tree.");
        add(collapseButton);

        treePanelContainer.setLayout(new BorderLayout());

        Box treeToolPanel = new Box(BoxLayout.X_AXIS);

        treeToolPanel.add(collapseButton);

        treeToolPanel.add(Box.createHorizontalGlue());

        treePanelContainer.add(treeToolPanel, BorderLayout.NORTH);

        treePanelContainer.add(treeViewScrollPane);

        tabbedPane.addTab("Functions", null, treePanelContainer, "Functions tree.");

        tabbedPane.addTab("Search", null, new SearchPanel(), "Search the function descriptions.");


        splitPane = new JSplitPane(JSplitPane.HORIZONTAL_SPLIT, tabbedPane, docsScrollPane);
        splitPane.setOneTouchExpandable(true);
        //tree.getPreferredScrollableViewportSize().width;
        splitPane.setDividerLocation(290);
        this.add(splitPane);

        toolPanel = new ToolPanel();
        home();

    }//end constructor.


    private void loadCategories(InputStream inputStream) {
        BufferedReader categoriesFile = null;
        List userFunctions = new ArrayList();
        List programmerFunctions = new ArrayList();
        List operators = new ArrayList();




        try {
            categoriesFile = new BufferedReader(new InputStreamReader(inputStream));

            String line;


            while ((line = categoriesFile.readLine()) != null) {
                line = line + ",Alphabetical";

                List functionDatalineFields = parseCSV(line);

                String functionCategory = functionDatalineFields.get(0).trim();

                functionDatalineFields.remove(0);

                String[] functionDatalineFieldsArray = functionDatalineFields.toArray(new String[functionDatalineFields.size()]);  //line.split(",");

                if (functionCategory.equalsIgnoreCase("User Functions")) {
                    userFunctions.add(functionDatalineFieldsArray);
                } else if (functionCategory.equalsIgnoreCase("Programmer Functions")) {
                    programmerFunctions.add(functionDatalineFieldsArray);
                } else {
                    operators.add(functionDatalineFieldsArray);
                }

            }//end while.

            userFunctionsData = (String[][]) userFunctions.toArray(new String[userFunctions.size()][]);
            programmerFunctionsData = (String[][]) programmerFunctions.toArray(new String[programmerFunctions.size()][]);
            operatorsData = (String[][]) operators.toArray(new String[operators.size()][]);

        } catch (Exception e) {
            e.printStackTrace();
        } finally {
            try {
                if (categoriesFile != null) {
                    categoriesFile.close();
                }
            } catch (IOException ex) {
                ex.printStackTrace();
            }
        }//end finally. 

    }//end method.


    private List parseCSV(String line) {
        List list = new ArrayList();
        String CSV_PATTERN = "\"([^\"]+?)\",?|([^,]+),?|,";
        Pattern csvRE = Pattern.compile(CSV_PATTERN);
        Matcher m = csvRE.matcher(line);
        // For each field
        while (m.find()) {
            String match = m.group();
            if (match == null) {
                break;
            }
            if (match.endsWith(",")) {  // trim trailing ,
                match = match.substring(0, match.length() - 1);
            }
            if (match.startsWith("\"")) { // assume also ends with
                match = match.substring(1, match.length() - 1);
            }
            //if (match.length() == 0)
            //match = null;
            list.add(match);
        }
        return list;
    }


    private void populateUserFunctionNodeWithCategories() {
        userFunctionsNode = new DefaultMutableTreeNode(new FunctionInfo("User Functions", "Functions for MathPiper users."));

        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Alphabetical", "All functions in alphabetical order.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Analytic Geometry", "Functions that are related to analytic geometry.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Built In", "Functions that are implemented in Java.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Calculus Related (Symbolic)", "Functions for differentiation, integration, and solving of equations.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Combinatorics", "Combinatorics related functions.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Constants (Mathematical)", "Mathematical constants.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Constants (System)", "System related constants.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Control Flow", "Controls the order in which statements or function calls are executed.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Differential Equations", "In this section, some facilities for solving differential equations are described. Currently only simple equations without auxiliary conditions are supported.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Expression Manipulation", "This section describes functions which allow expressions to be manipulated.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Expression Simplification", "This section describes functions that allow simplification of expressions.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Functional Operators", "These operators can help the user to program in the style of functional programming languages such as Miranda or Haskell.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Input/Output", "Functions for input, output, and plotting.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Linear Algebra", "Functions used to manipulate vectors (represented as lists) and matrices (represented as lists of lists).")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Lists (Operations)", "Most objects that can be of variable size are represented as lists.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Matrices (Predicates)", "Predicates related to matrices.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Matrices (Special)", "Various special matricies")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numeric", "Functions that calculate numerically (like those found on a scientific calculator.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numbers (Complex)", "Functions that allow manipulation of complex numbers.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numbers (Operations)", "Besides the usual arithmetical operations, MathPiper defines some more advanced operations on numbers. Many of them also work on polynomials.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numbers (Predicates)", "Predicates relating to numbers.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numbers (Random)", "Random number related functions.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Number Theory", "Functions that are of interest in number theory. They typically operate on integers")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Polynomials (Operations)", "Functions to manipulate polynomials, including functions for constructing and evaluating orthogonal polynomials.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Polynomials (Special)", "Special polynomials.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Predicates", "A predicate is a function that returns a boolean value, i.e. True or False.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Propositional Logic", "Functions for propositional logic.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Series", "Functions which operate on series.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Solvers (Numeric)", "Functions for solving equations numerically.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Solvers (Symbolic)", "By solving one tries to find a mathematical object that meets certain criteria.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Special Functions", "In this section, special and transcendental mathematical functions are described.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Statistics & Probability", "Statistics & Probability.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("String Manipulation", "Functions for manipulating strings.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Transforms", "In this section, some facilities for various transforms are described.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Trigonometry (Numeric)", "Functions for working with trigonometry numerically.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Trigonometry (Symbolic)", "Functions for working with trigonometry symbolically.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Variables", "Functions that work with variables.")));
        userFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Visualization", "Functions that help visualize data.")));

    }//end method.


    private void populateProgrammerFunctionNodeWithCategories() {
        programmerFunctionsNode = new DefaultMutableTreeNode(new FunctionInfo("Programmer Functions", "Functions for MathPiper code developers."));

        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Alphabetical", "All functions in alphabetical order.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Built In", "MathPiper has a small set of built-in functions and a large library of user-defined functions. Some built-in functions are in this section.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Debugging", "Functions used for debugging MathPiper code.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Error Reporting", "Functions which are useful for reporting errors to the user.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Native Objects", "Functions for allowing the MathPiper interpreter access native code.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Numerical (Arbitrary Precision)", "Functions for programming numerical calculations with arbitrary precision.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Programming", "Functions which are useful for writing MathPiper scripts.")));
        programmerFunctionsNode.add(new DefaultMutableTreeNode(new FunctionInfo("Testing", "Functions for verifying the correct operation of MathPiper code.")));

    }//end method.


    private void populateNode(DefaultMutableTreeNode treeNode, String[][] functionDataStringArray) {
        for (int row = 0; row < functionDataStringArray.length; row++) {

            if (this.showPrivateFunctions == true && functionDataStringArray[row][1].equals("private")) {
                //Pass through to populate.
            } else if (this.showExperimentalFunctions == true && functionDataStringArray[row][1].equals("experimental")) {
                //Pass through to populate.
            } else if (functionDataStringArray[row][1].equals("public")) {
                //Pass through to populate.
            } else {
                //Skip populate.
                continue;
            }

            //Populate.
            for (int column = 3; column < functionDataStringArray[row].length; column++) {
                String category = functionDataStringArray[row][column];
                //System.out.println("XXXXX " + descriptionsStringArray[row][column]);


                boolean hasCategory = false;
                Enumeration children = treeNode.children();
                for (; children.hasMoreElements();) {
                    DefaultMutableTreeNode child = (DefaultMutableTreeNode) children.nextElement();
                    if (child.getUserObject().toString().equalsIgnoreCase(category)) //Add leaf to existing category.
                    {
                        child.add(new DefaultMutableTreeNode(new FunctionInfo(functionDataStringArray[row][0], functionDataStringArray[row][1], functionDataStringArray[row][2])));
                        hasCategory = true;
                    }


                }//end for.

                if (hasCategory == false) {
                    DefaultMutableTreeNode leaf = new DefaultMutableTreeNode(new FunctionInfo(functionDataStringArray[row][0], functionDataStringArray[row][1], functionDataStringArray[row][2]));
                    DefaultMutableTreeNode categoryNode = new DefaultMutableTreeNode(functionDataStringArray[row][column]);
                    categoryNode.add(leaf);
                    treeNode.add(categoryNode);
                }

            }//end column for.



        }//end row for.

    }//end method.


    private void processFunctionData() {
        allFunctions = new java.util.ArrayList();

        int progFuncDescIndex = 0;
        int userFuncDescIndex = 0;

        boolean endFlag = false;

        while (endFlag != true) {

            String[] functionData = new String[4];

            if (userFuncDescIndex != userFunctionsData.length && progFuncDescIndex != programmerFunctionsData.length) {

                if (userFunctionsData[userFuncDescIndex][0].compareToIgnoreCase(programmerFunctionsData[progFuncDescIndex][0]) == 0) {
                    //If the same function is in the user function list and the programmer function list, skip the one in the
                    //user function list and use the one which is in the programmer function list.
                    userFuncDescIndex++;
                }//end if.


                if (userFunctionsData[userFuncDescIndex][0].compareToIgnoreCase(programmerFunctionsData[progFuncDescIndex][0]) < 0) {
                    functionData[0] = userFunctionsData[userFuncDescIndex][0];
                    functionData[1] = userFunctionsData[userFuncDescIndex][1];
                    functionData[2] = userFunctionsData[userFuncDescIndex][2];
                    functionData[3] = "All Functions";
                    allFunctions.add(functionData);
                    //System.out.println("USER: " + desc[0] + " position: " + userFuncDescIndex);
                    userFuncDescIndex++;
                } else {
                    functionData[0] = programmerFunctionsData[progFuncDescIndex][0];
                    functionData[1] = programmerFunctionsData[progFuncDescIndex][1];
                    functionData[2] = programmerFunctionsData[progFuncDescIndex][2];
                    functionData[3] = "All Functions";
                    allFunctions.add(functionData);
                    //System.out.println("Programmer: " + desc[0] + " position: " + progFuncDescIndex);
                    progFuncDescIndex++;
                }
            } else if (userFuncDescIndex != userFunctionsData.length) {
                functionData[0] = userFunctionsData[userFuncDescIndex][0];
                functionData[1] = userFunctionsData[userFuncDescIndex][1];
                functionData[2] = userFunctionsData[userFuncDescIndex][2];
                functionData[3] = "All Functions";
                allFunctions.add(functionData);
                userFuncDescIndex++;
            } else if (progFuncDescIndex != programmerFunctionsData.length) {
                functionData[0] = programmerFunctionsData[progFuncDescIndex][0];
                functionData[1] = programmerFunctionsData[progFuncDescIndex][1];
                functionData[2] = programmerFunctionsData[progFuncDescIndex][2];
                functionData[3] = "All Functions";
                allFunctions.add(functionData);
                progFuncDescIndex++;
            } else {
                endFlag = true;
            }
        }//end while.


    }//end method.


    public void createTree() {

        this.populateUserFunctionNodeWithCategories();

        this.populateProgrammerFunctionNodeWithCategories();

        operatorsNode = new DefaultMutableTreeNode(new FunctionInfo("Operators", "Operators."));

        processFunctionData();


        DefaultMutableTreeNode mathpiperFunctionsRootNode = new DefaultMutableTreeNode(new FunctionInfo("MathPiper Functions                                           ", "All MathPiper functions and constants."));

        String[][] allFunctionsArray = (String[][]) allFunctions.toArray(new String[allFunctions.size()][]);

        populateNode(mathpiperFunctionsRootNode, allFunctionsArray);

        populateNode(userFunctionsNode, userFunctionsData);
        mathpiperFunctionsRootNode.add(userFunctionsNode);

        populateNode(programmerFunctionsNode, programmerFunctionsData);
        mathpiperFunctionsRootNode.add(programmerFunctionsNode);

        populateNode(operatorsNode, operatorsData);
        mathpiperFunctionsRootNode.add(operatorsNode);

        DefaultTreeModel model = new DefaultTreeModel(mathpiperFunctionsRootNode);



        functionsTree = new FunctionInfoTree(model);

        functionsTree.getSelectionModel().setSelectionMode(javax.swing.tree.TreeSelectionModel.SINGLE_TREE_SELECTION);
        functionsTree.addTreeSelectionListener(this);
        functionsTree.setShowsRootHandles(true);


    }//end method.


    private void loadDocumentationIndex(InputStream inputStream) {
        documentationIndex = new HashMap();
        try {
            BufferedReader documentationIndexReader = new BufferedReader(new InputStreamReader(inputStream));

            String line;
            while ((line = documentationIndexReader.readLine()) != null) {

                String[] values = line.split(",");

                if (values[0].indexOf(";") != -1) {
                    String[] functionNames = values[0].split(";");
                    for (String name : functionNames) {
                        documentationIndex.put(name, values[1] + "," + values[2]);
                    }//end for.
                } else {
                    documentationIndex.put(values[0], values[1] + "," + values[2]);
                }//end else.
            }//end while.

            documentationIndexReader.close();

        } catch (java.io.IOException e) {
            e.printStackTrace();
        }
    }//end method.


    public void valueChanged(TreeSelectionEvent e) {
        DefaultMutableTreeNode node = (DefaultMutableTreeNode) functionsTree.getLastSelectedPathComponent();
        //System.out.println("XXXXX");
        if (node == null) //Nothing is selected.
        {
            return;
        }

        Object nodeInfo = node.getUserObject();
        if (node.isLeaf()) {
            selectedFunctionName = nodeInfo.toString();
            viewFunction(selectedFunctionName, true);
        } else {
            //toolPanel.sourceButtonEnabled(false);
            //Note:tk:Perhaps display top of chapter here?
        }
    }//end method.


    public boolean viewFunction(String functionName, boolean save) {

        if (this.documentationIndex.containsKey(functionName)) {

            String functionIndexesString = (String) this.documentationIndex.get(functionName);
            String[] functionIndexes = functionIndexesString.split(",");
            int startIndex = Integer.parseInt(functionIndexes[0]);
            int endIndex = Integer.parseInt(functionIndexes[1]);
            int length = endIndex - startIndex;
            byte[] documentationData = new byte[length];
            //char[] documentationData = new char[length];
            //System.out.println("yyyy " + functionName + "  " + startIndex + " " + endIndex + " " + length);
            try {

                BufferedInputStream documentationStream = new BufferedInputStream(FunctionTreePanel.class.getResourceAsStream("/org/mathpiper/ui/gui/help/data/documentation.txt"));

                if (documentationStream == null) {
                    throw new FileNotFoundException("The file documentation.txt was not found.");
                }

                documentationStream.skip(startIndex);
                documentationStream.read(documentationData, 0, length);
                //docsStream.close();




                String documentationDataString = new String(documentationData);

                //documentationDataString = documentationDataString.replace("$", "");

                String html = textToHtml(documentationDataString);

                html = processLatex(html);

                setPage(functionName, html, save);

                //functionInfo = nodeInfo;
                //displayFunctionDocs(functionInfo.toString());
            } catch (IOException ex) {
                ex.printStackTrace();
            }//end catch.

            return true;


        } else {
            return false;
        }
    }//end method.


    public static String processLatex(String html) {
        StringBuilder stringBuilder = new StringBuilder();

        int startIndex = -1;

        int endIndex = -1;

        for (int index = 0; index < html.length(); index++) {
            if (html.charAt(index) == '$') {
                if (html.charAt(index - 1) == '\\') {
                    //Strip \ character in escaped \$.
                    stringBuilder.deleteCharAt(stringBuilder.length() - 1);
                    stringBuilder.append(html.charAt(index));
                } else {
                    if (startIndex == -1) {
                        startIndex = index + 1;

                        endIndex = 0;
                    } else {
                        endIndex = index;

                        String latexCode = html.substring(startIndex, endIndex);

                        latexCode = latexCode.replace(" ", "");

                        //String latexEmbedString = "  ";

                        String latexEmbedString = "  ";

                        //System.out.println("LATEX: " + latexEmbedString);

                        stringBuilder.append(latexEmbedString);

                        startIndex = -1;

                        endIndex = -1;
                    }//end else.

                }//end else.
            } else {
                if (endIndex == -1) {
                    stringBuilder.append(html.charAt(index));
                }
            }
        }//end for.


        return stringBuilder.toString();
    }


    private static String applyBold(String line) {


        //line = line.replaceAll("\\{", "");
        //line = line.replaceAll("\\}", "");

        StringBuilder stringBuilder = new StringBuilder();

        int startIndex = -1;

        int endIndex = -1;

        for (int index = 0; index < line.length(); index++) {
            if (line.charAt(index) == '{') {
                stringBuilder.append("");
            } else if (line.charAt(index) == '}') {
                stringBuilder.append("");
            } else {
                stringBuilder.append(line.charAt(index));
            }

        }//end for.


        return stringBuilder.toString();
    }//end method.


    /*private static String applyPre(String line) {
    line = line.replaceAll("\\[", "
    ");
    line = line.replaceAll("\\]", "
    ");
    return line;
    }//end method.
     */
    public static String textToHtml(String scriptCode) {
//s = "*CMD D --- take derivative of expression with respect to variable\n*STD\n*CALL\n	D(variable) expression\n	D(list) expression\n	D(variable,n) expression\n\n*PARMS\n\n{variable} -- variable\n\n{list} -- a list of variables\n\n{expression} -- expression to take derivatives of\n\n{n} -- order of derivative\n\n*DESC\n\nThis function calculates the derivative of the expression {expr} with\nrespect to the variable {var} and returns it. If the third calling\nformat is used, the {n}-th derivative is determined. Yacas knows\nhow to differentiate standard functions such as {Ln}\nand {Sin}.\n\nThe {D} operator is threaded in both {var} and\n{expr}. This means that if either of them is a list, the function is\napplied to each entry in the list. The results are collected in\nanother list which is returned. If both {var} and {expr} are a\nlist, their lengths should be equal. In this case, the first entry in\nthe list {expr} is differentiated with respect to the first entry in\nthe list {var}, the second entry in {expr} is differentiated with\nrespect to the second entry in {var}, and so on.\n\nThe {D} operator returns the original function if $n=0$, a common\nmathematical idiom that simplifies many formulae.\n\n*E.G.\n\n	In> D(x)Sin(x*y)\n	Result: y*Cos(x*y);\n	In> D({x,y,z})Sin(x*y)\n	Result: {y*Cos(x*y),x*Cos(x*y),0};\n	In> D(x,2)Sin(x*y)\n	Result: -Sin(x*y)*y^2;\n	In> D(x){Sin(x),Cos(x)}\n	Result: {Cos(x),-Sin(x)};\n\n*SEE Integrate, Taylor, Diverge, Curl\n";

        String convertedScriptCode = scriptCode;

        //convertedScriptCode = convertedScriptCode.replaceAll("\\$.*\\$", "\b");

        convertedScriptCode = convertedScriptCode.replace("&", "&");
        convertedScriptCode = convertedScriptCode.replace("<", "<");
        convertedScriptCode = convertedScriptCode.replace(">", ">");

        String[] lines = convertedScriptCode.split("\n");

        StringBuilder html = new StringBuilder();

        html.append("\n");

        for (int x = 0; x < lines.length; x++) {
            //foldOutput = foldOutput + lines[x];

            String line = lines[x].trim();

            if (line.startsWith("*CMD")) {
                line = line.substring(line.indexOf(" "), line.length());
                html.append("
    \n
    " + line + "\n
    \n\n");

            } else if (line.startsWith("*STD")) {
                html.append("
    Standard library
    \n\n");
            } else if (line.startsWith("*CORE")) {
                html.append("
    Built in function
    \n\n");
            } else if (line.startsWith("*CALL")) {
                html.append("
     Calling format:\n
    \n\n\n
    \n");

                while (true) {
                    x++;

                    if (x == lines.length) {
                        //This code exits the converter if it is the last *XXX command in the document.
                        break;
                    }//end if.

                    line = lines[x].trim();

                    if (line.startsWith("*")) {
                        x--;
                        break;
                    }
                    if (line.equalsIgnoreCase("")) {
                        continue;
                    }

                    html.append(line);
                    html.append("\n");
                }//end while.

                html.append("
    \n
    \n\n");
            } else if (line.startsWith("*PARMS")) {
                html.append("
    \nParameters:\n
    \n");

                while (true) {
                    x++;

                    if (x == lines.length) {
                        //This code exits the converter if it is the last *XXX command in the document.
                        break;
                    }//end if.

                    line = lines[x].trim();

                    if (line.startsWith("*")) {
                        x--;
                        break;
                    }
                    if (line.equalsIgnoreCase("")) {
                        continue;
                    }

                    line = applyBold(line);
                    //foldOutput = foldOutput + line;

                    html.append("\n
    \n");
                    html.append(line);
                    html.append("\n");
                }//end while.

                html.append("\n
    \n\n");
            } else if (line.startsWith("*DESC")) {
                html.append("
    \nDescription:\n
    \n");

                while (true) {
                    x++;

                    if (x == lines.length) {
                        //This code exits the converter if it is the last *XXX command in the document.
                        break;
                    }//end if.

                    line = lines[x].trim();

                    if (line.startsWith("*")) {
                        x--;
                        break;
                    }
                    if (line.equalsIgnoreCase("")) {
                        html.append("\n
    \n");
                        continue;
                    }

                    line = applyBold(line);
                    //line = applyPre(line);  Removed the [] 
     symbol replacement because it clashes with normal brackets.



                    html.append(line);
                    html.append("\n");
                }//end while.

                html.append("\n");
            } else if (line.startsWith("*E.G.")) {
                html.append("
    \nExamples:\n
    \n\n\n
    ");

                while (true) {
                    x++;

                    if (x == lines.length) {
                        //This code exits the converter if it is the last *XXX command in the document.
                        break;
                    }//end if.

                    line = lines[x];

                    line = line.replace("/%", "%");

                    if (line.startsWith("*")) {
                        x--;
                        break;
                    }
                    if (line.equalsIgnoreCase("")) {
                        html.append("\n");
                        continue;
                    }

                    line = line.replaceAll(">", ">");


                    html.append(line);
                    html.append("\n");
                }//end while.

                html.append("\n
    \n
    \n");
            } else if (line.startsWith("*SEE")) {

                //line = lines[x].trim();
                line = line.substring(4, line.length());
                line = line.replace(" ", "");

                String[] seeFunctions = line.split(",");

                for (String seeFunction : seeFunctions) {
                    seeFunctionsBuilder.append("" + seeFunction + ", ");
                }

                html.append("
    See also:
    " + seeFunctionsBuilder.toString() + "\n");

                seeFunctionsBuilder.delete(0, seeFunctionsBuilder.length());

            } else if (line.startsWith("*SOURCE")) {

                html.append("
     
    Source:
    ");

                line = line.substring(7, line.length());
                line = line.trim();
                
                if(line.endsWith(".mpw"))
                {
                        html.append(line);
                	html.append("
     View source code\n");
                }
                else
                {
                	html.append(
                	"This is a built-in function and its source file is written in Java. 
    " + 
			"The path to the Java source code for this function is: 
    " + line.substring(1, line.length()) + "

    " +
			"The source code can be browsed on the MathPiper project site at: 
    " +
			"http://code.google.com/p/mathpiper/source/browse/");
			
                }//end else.
                
            }//end else/if.



        }//end for.

        html.append("\n");
        
        
        Pattern p = Pattern.compile("\\$.*\\$");
        Matcher originalCodeMatcher = p.matcher(scriptCode);
        Matcher htmlMatcher = p.matcher(html); // get a matcher object
        StringBuffer convertedCodeStringBuffer = new StringBuffer();
        
        while(htmlMatcher.find()){
            originalCodeMatcher.find();
            String latexCode = originalCodeMatcher.group();
            latexCode = latexCode.replace("\\", "\\\\");
            latexCode = latexCode.replace("$", "\\$");
            htmlMatcher.appendReplacement(convertedCodeStringBuffer,latexCode);
        }
        htmlMatcher.appendTail(convertedCodeStringBuffer);

        String convertedCode = convertedCodeStringBuffer.toString();

        return convertedCode;

    }//end method.


    public void hyperlinkUpdate(HyperlinkEvent event) {
        //System.out.println(event.toString());
        URL url = event.getURL();
//System.out.println("YYYPiperDocsYYY: " + url.getPath() + " reference: " + url.getRef() + " query: " + url.getQuery() );
        if (event.getEventType() == HyperlinkEvent.EventType.ACTIVATED) {

            String functionName = "";

            if (url != null) {
            	    
            //System.out.println("XXXXX: " + url);
            	        
                String protocol = url.getProtocol();
                
                if (protocol.equalsIgnoreCase("file")) {
                    String mpwFilePath = url.getFile();
                    
                    if(mpwFilePath.endsWith(".mpw"))
                    {

			    java.io.InputStream inputStream = FunctionTreePanel.class.getResourceAsStream(mpwFilePath);
	
			    if (inputStream != null) //File is on the classpath.
			    {
	
				try{
				    String mpwFileText = convertStreamToString(inputStream);
				    
				    HelpEvent helpEvent = new HelpEvent(mpwFilePath, mpwFileText);
	
				    this.notifyListeners(helpEvent);
	
				    inputStream.close();
				}
				catch(Exception e)
				{
				    System.out.println(e.getMessage());
				}
	
			    }//end if.
                    
		    }else
		    {
		    	   //.java file.
		           //HelpEvent helpEvent = new HelpEvent(mpwFilePath, null);
		           //this.notifyListeners(helpEvent);
		    }

                } else {
                    String urlString = url.toString();
                    functionName = urlString.substring(7, urlString.length());
                }
                
                
                
                
            } else {
                //Hack to get around problem of null url object being returned for the := operator.
                if (event.getDescription().contains("http://:=")) {
                    functionName = ":=";
                }
            }
            
            //System.out.println(functionName);
            viewFunction(functionName, true);



        }//end if.  + getRef())

    }//end method.

    private int pageIndex = -1;


    private void setPage(String functionName, String html, boolean save) {
        editorPane.setText(html);

        //HTMLEditorKit editorKit = (HTMLEditorKit) editorPane.getEditorKit();
        //Style style = editorKit.getStyleSheet().getRule("object");


        //forward button logic.
        if (pageIndex + 1 == pageList.size()) {
            toolPanel.forwardButtonEnabled(false);
        } else {
            toolPanel.forwardButtonEnabled(true);
        }//end else.




        if (save) {
            if (pageIndex >= 0 && functionName == pageList.get(pageIndex)) {
                //System.out.println("VVVVVM Same URL");
                return;
            }//end if.
            if (pageIndex + 1 != pageList.size()) {
                pageList = pageList.subList(0, pageIndex + 1);
                toolPanel.forwardButtonEnabled(false);
            }//end if.


            pageList.add(functionName);
            pageIndex++;
        }//end if.


        //back button logic.
        if (pageIndex <= 0) {
            toolPanel.backButtonEnabled(false);
        } else {
            toolPanel.backButtonEnabled(true);
        }//end else.

        //System.out.println("TTTTT " + pageList );


        final JScrollBar verticalScrollBar = docsScrollPane.getVerticalScrollBar();
        SwingUtilities.invokeLater(new Runnable() {

            public void run() {
                verticalScrollBar.setValue(verticalScrollBar.getMinimum());
            }

        });


    }//end method.


    private String getSource() {
        Interpreter interpreter = Interpreters.getSynchronousInterpreter();
        //item = list.getSelectedValue();

        EvaluationResponse evaluationResponse = interpreter.evaluate("FindFunction(\"" + selectedFunctionName + "\");");
        String location = evaluationResponse.getResult();

        return location;
    }//end method.


    private void collapse() {
        functionsTree.collapseAll();
    }//end method.


    private void back() {
        if (pageIndex != 0) {
            String functionName = (String) pageList.get(--pageIndex);

            if (functionName.equals("HomePage")) {
                home();
            } else {
                this.viewFunction(functionName, false);
            }

        }//end if.
    }//end method.


    private void forward() {
        String functionName = (String) pageList.get(++pageIndex);

        if (functionName.equals("HomePage")) {
            home();
        } else {
            this.viewFunction(functionName, false);
        }

    }//end method.


    private void home() {
        //toolPanel.sourceButtonEnabled(false);
        
        String homePageText = "
    MathPiper Function Documentation.
     \n"
         + "
    \n"
         + "Open the tree nodes to the left to access the function documentation. \n";


        setPage("HomePage", homePageText, true);
    }//end method.


        public String convertStreamToString(InputStream inputStream) throws IOException {

        if (inputStream != null) {
            StringBuilder stringBuilder = new StringBuilder();
            String line;

            try {
                BufferedReader reader = new BufferedReader(new InputStreamReader(inputStream, "UTF-8"));
                while ((line = reader.readLine()) != null) {
                    stringBuilder.append(line).append("\n");
                }
            } finally {
                inputStream.close();
            }
            return stringBuilder.toString();
        } else {
            return "";
        }
    }//end method.



    public void addHelpListener(HelpListener listener) {
        helpListeners.add(listener);
    }

    public void removeHelpListener(HelpListener listener) {
        helpListeners.remove(listener);
    }

    protected void notifyListeners(HelpEvent helpEvent) {

        for (HelpListener listener : helpListeners) {
            listener.helpEvent(helpEvent);
        }//end for.

    }//end method.



    public JPanel getToolPanel() {
        return toolPanel;
    }//end method.

    private class ToolPanel extends JPanel implements ItemListener {

        private JLabel label;
        //private JButton sourceButton;
        private JButton backButton;
        private JButton forwardButton;
        private JButton homeButton;
        private JButton fontSizeIncreaseButton;
        private JButton fontSizeDecreaseButton;
        private JCheckBox showExperimentalFunctionsCheckBox;
        private JCheckBox showPrivateFunctionsCheckBox;
        private boolean isShowPrivateFunctions = false;


        private ToolPanel() {
            setLayout(new BoxLayout(this, BoxLayout.X_AXIS));



            //View source button.
            /*sourceButton = new javax.swing.JButton("Source");
            sourceButton.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent evt) {
                    //source();
                }

            });
            sourceButton.setEnabled(false);
            sourceButton.setToolTipText("View script source.");
            add(sourceButton);*/


            showExperimentalFunctionsCheckBox = new JCheckBox("Experimental");
            showExperimentalFunctionsCheckBox.setSelected(true);
            showExperimentalFunctionsCheckBox.addItemListener(this);
            add(showExperimentalFunctionsCheckBox);

            showPrivateFunctionsCheckBox = new JCheckBox("Private");
            showPrivateFunctionsCheckBox.setSelected(false);
            showPrivateFunctionsCheckBox.addItemListener(this);
            add(showPrivateFunctionsCheckBox);


            add(Box.createGlue());

            //fontSize increase button.
            fontSizeIncreaseButton = new javax.swing.JButton("Font+");
            fontSizeIncreaseButton.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent evt) {

                    Font font = editorPane.getFont();

                    int fontSize = font.getSize();
                    fontSize = fontSize += 2;

                    editorPane.setFont(font.deriveFont(fontSize));

                    System.out.println("Increasing font size.");


                    //editorPane.

                }//end method.

            });
            fontSizeIncreaseButton.setEnabled(true);
            //add(fontSizeIncreaseButton);



            //back button.
            backButton = new javax.swing.JButton("Back");
            backButton.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent evt) {
                    back();
                }

            });
            backButton.setEnabled(false);
            add(backButton);


            //forward button.
            forwardButton = new javax.swing.JButton("Forward");
            forwardButton.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent evt) {
                    forward();
                }

            });
            forwardButton.setEnabled(false);
            add(forwardButton);


            //Home button.
            homeButton = new javax.swing.JButton("Home");
            homeButton.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent evt) {
                    home();
                }

            });
            homeButton.setEnabled(true);
            add(homeButton);




        }//end constructor.


        //public void sourceButtonEnabled(Boolean state) {
        //    sourceButton.setEnabled(state);
        //}//end method.


        public void backButtonEnabled(Boolean state) {
            backButton.setEnabled(state);
        }//end method.


        public void forwardButtonEnabled(Boolean state) {
            forwardButton.setEnabled(state);
        }//end method.


        public void itemStateChanged(ItemEvent ie) {
            Object source = ie.getSource();

            if (source == showPrivateFunctionsCheckBox || source == showExperimentalFunctionsCheckBox) {
                if (source == showPrivateFunctionsCheckBox) {

                    if (ie.getStateChange() == ItemEvent.SELECTED) {
                        showPrivateFunctions = true;
                    } else {
                        showPrivateFunctions = false;
                    }//end if/else.

                } else if (source == showExperimentalFunctionsCheckBox) {

                    if (ie.getStateChange() == ItemEvent.SELECTED) {
                        showExperimentalFunctions = true;
                    } else {
                        showExperimentalFunctions = false;
                    }//end if/else.


                }//end if.

                treePanel.removeAll();
                createTree();
                treePanel.add(functionsTree);
                treeViewScrollPane.revalidate();

            }//End if.


        }//end method.

    }//end class.

    private class SearchPanel extends JPanel implements ActionListener, ListSelectionListener {

        private JTextField searchTextField;
        private Vector hits = new Vector();
        private JScrollPane listScroller;
        private JList list;


        public SearchPanel() {
            this.setLayout(new BorderLayout());

            searchTextField = new JTextField();

            searchTextField.setActionCommand("search");

            searchTextField.addActionListener(this);

            this.add(searchTextField, BorderLayout.NORTH);


            hits.add("Enter a search term or phrase into the");
            hits.add("above text field and press  to search.");
            hits.add(" ");
            hits.add("Select a returned function to view its documentation.");

            list = new JList(hits);
            list.setSelectionMode(ListSelectionModel.SINGLE_INTERVAL_SELECTION);
            list.addListSelectionListener(this);
            list.setVisibleRowCount(-1);

            listScroller = new JScrollPane(list, JScrollPane.VERTICAL_SCROLLBAR_AS_NEEDED, JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);

            this.add(listScroller);


        }//end constructor.


        public void actionPerformed(ActionEvent e) {
            if (e.getActionCommand().equals("search")) {
                JTextField textField = (JTextField) e.getSource();

                String searchString = textField.getText();

                searchString = searchString.toLowerCase();

                hits.removeAllElements();

                int index = 0;

                //Search user functions.
                hits.add("USER FUNCTIONS:");

                for (index = 0; index < userFunctionsData.length; index++) {
                    if (userFunctionsData[index][0].toLowerCase().contains(searchString) || userFunctionsData[index][2].toLowerCase().contains(searchString)) {
                        hits.add(userFunctionsData[index][0] + " -- " + userFunctionsData[index][2] + ".");
                    }
                }//end for.


                //Search programmer functions.
                hits.add(" ");
                hits.add("PROGRAMMER FUNCTIONS:");

                for (index = 0; index < programmerFunctionsData.length; index++) {
                    if (programmerFunctionsData[index][0].toLowerCase().contains(searchString) || programmerFunctionsData[index][2].toLowerCase().contains(searchString)) {
                        hits.add(programmerFunctionsData[index][0] + " -- " + programmerFunctionsData[index][2] + ".");
                    }
                }//end for.


                //Search operators.
                hits.add(" ");
                hits.add("OPERATORS:");

                for (index = 0; index < operatorsData.length; index++) {
                    if (operatorsData[index][0].toLowerCase().contains(searchString) || operatorsData[index][2].toLowerCase().contains(searchString)) {
                        hits.add(operatorsData[index][0] + " -- " + operatorsData[index][2] + ".");
                    }
                }//end for.


                list.setListData(hits);

                listScroller.revalidate();

            }//end if.

        }//end method.


        public void valueChanged(ListSelectionEvent e) {
            JList list = (JList) e.getSource();
            if (!list.getSelectionModel().getValueIsAdjusting()) {
                String function = (String) list.getSelectedValue();
                if (function != null) {
                    String functionName = function.split("-")[0].trim();
                    viewFunction(functionName, true);
                }
            }
        }//end method.


    }//end class.


    public static void main(String[] args) {

        JFrame frame = new javax.swing.JFrame();
        frame.setDefaultCloseOperation(JFrame.DISPOSE_ON_CLOSE);

        FunctionTreePanel functionTreePanel = null;

        try {

            functionTreePanel = new FunctionTreePanel();

            Container contentPane = frame.getContentPane();
            contentPane.add(functionTreePanel.getToolPanel(), BorderLayout.NORTH);
            contentPane.add(functionTreePanel, BorderLayout.CENTER);

            frame.pack();

            frame.setTitle("MathPiper Help");
            frame.setSize(new Dimension(700, 700));
            //frame.setResizable(false);
            frame.setPreferredSize(new Dimension(700, 700));
            frame.setLocationRelativeTo(null); // added

            frame.setVisible(true);

        } catch (FileNotFoundException fnfe) {
            System.out.println(fnfe.getMessage());
        }



    }//end main.
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/ScreenCapture.java0000644000175000017500000001536411506507632026336 0ustar  giovannigiovannipackage org.mathpiper.ui.gui;


/*This code was obtained from http://www.discoverteenergy.com/files/ScreenImage.java
  There was no license associated with the code. */

import java.awt.*;
import java.awt.event.*;
import java.awt.image.*;
import java.io.*;
import javax.imageio.*;
import javax.swing.*;

public class ScreenCapture
{
	/*
	 *  Create a BufferedImage for Swing components.
	 *  The entire component will be captured to an image.
	 *
	 *  @param	 component Swing component to create image from
	 *  @param	 fileName name of file to be created or null
	 *  @return	image the image for the given region
	 *  @exception IOException if an error occurs during writing
	*/
	public static BufferedImage createImage(JComponent component, String fileName)
		throws IOException
	{
		Dimension d = component.getSize();

		if (d.width == 0)
		{
			d = component.getPreferredSize();
			component.setSize( d );
		}

		Rectangle region = new Rectangle(0, 0, d.width, d.height);
		return ScreenCapture.createImage(component, region, fileName);
	}

	/*
	 *  Create a BufferedImage for Swing components.
	 *  All or part of the component can be captured to an image.
	 *
	 *  @param	 component Swing component to create image from
	 *  @param	 region The region of the component to be captured to an image
	 *  @param	 fileName name of file to be created or null
	 *  @return	image the image for the given region
	 *  @exception IOException if an error occurs during writing
	*/
	public static BufferedImage createImage(JComponent component, Rectangle region, String fileName)
		throws IOException
	{
		boolean opaqueValue = component.isOpaque();
		component.setOpaque( true );
		BufferedImage image = new BufferedImage(region.width, region.height, BufferedImage.TYPE_INT_RGB);
		Graphics2D g2d = image.createGraphics();
		g2d.setClip( region );
		component.paint( g2d );
		g2d.dispose();
		component.setOpaque( opaqueValue );
		ScreenCapture.writeImage(image, fileName);
		return image;
	}

	/*
	 *  Create a BufferedImage for AWT components.
	 *
	 *  @param	 component AWT component to create image from
	 *  @param	 fileName name of file to be created or null
	 *  @return	image the image for the given region
	 *  @exception AWTException see Robot class constructors
	 *  @exception IOException if an error occurs during writing
	*/
	public static BufferedImage createImage(Component component, String fileName)
		throws AWTException, IOException
	{
		Point p = new Point(0, 0);
		SwingUtilities.convertPointToScreen(p, component);
		Rectangle region = component.getBounds();
		region.x = p.x;
		region.y = p.y;
		return ScreenCapture.createImage(region, fileName);
	}

	/**
	 *  Convenience method to create a BufferedImage of the desktop
	 *
	 *  @param	 fileName name of file to be created or null
	 *  @return	image the image for the given region
	 *  @exception AWTException see Robot class constructors
	 *  @exception IOException if an error occurs during writing
	 */
	public static BufferedImage createDesktopImage(String fileName)
		throws AWTException, IOException
	{
		Dimension d = Toolkit.getDefaultToolkit().getScreenSize();
		Rectangle region = new Rectangle(0, 0, d.width, d.height);
		return ScreenCapture.createImage(region, fileName);
	}

	/**
	 *  Create a BufferedImage from a rectangular region on the screen.
	 *
	 *  @param	 region region on the screen to create image from
	 *  @param	 fileName name of file to be created or null
	 *  @return	image the image for the given region
	 *  @exception AWTException see Robot class constructors
	 *  @exception IOException if an error occurs during writing
	 */
	public static BufferedImage createImage(Rectangle region, String fileName)
		throws AWTException, IOException
	{
		BufferedImage image = new Robot().createScreenCapture( region );
		ScreenCapture.writeImage(image, fileName);
		return image;
	}

	/**
	 *  Write a BufferedImage to a File.
	 *
	 *  @param	 image image to be written
	 *  @param	 fileName name of file to be created
	 *  @exception IOException if an error occurs during writing
	*/
	public static void writeImage(BufferedImage image, String fileName)
		throws IOException
	{
		if (fileName == null) return;

		int offset = fileName.lastIndexOf( "." );
		String type = offset == -1 ? "png" : fileName.substring(offset + 1);

		ImageIO.write(image, type, new File( fileName ));
	}

	public static void main(String args[])
		throws Exception
	{
		final JFrame frame = new JFrame();
		final JTextArea textArea = new JTextArea(30, 60);
		final JScrollPane scrollPane = new JScrollPane( textArea );
		frame.getContentPane().add( scrollPane );

		JMenuBar menuBar = new JMenuBar();
		frame.setJMenuBar( menuBar );
		JMenu menu = new JMenu( "File" );
		ScreenCapture.createImage(menu, "menu.jpg");
		menuBar.add( menu );
		JMenuItem menuItem = new JMenuItem( "Frame Image" );
		menu.add( menuItem );
		menuItem.addActionListener( new ActionListener()
		{
			public void actionPerformed(ActionEvent e)
			{
				//  Let the menu close and repaint itself before taking the image

				new Thread()
				{
					public void run()
					{
						try
						{
							Thread.sleep(50);
							System.out.println("Creating frame.jpg");
							frame.repaint();
							ScreenCapture.createImage(frame, "frame.jpg");
						}
						catch(Exception exc) { System.out.println(exc); }
					}
				}.start();
			};
		});

		final JButton button = new JButton("Create Images");
		button.addActionListener( new ActionListener()
		{
			public void actionPerformed(ActionEvent e)
			{
				try
				{
					System.out.println("Creating desktop.jpg");
					ScreenCapture.createDesktopImage( "desktop.jpg" );
					System.out.println("Creating frame.jpg");
					ScreenCapture.createImage(frame, "frame.jpg");
					System.out.println("Creating scrollpane.jpg");
					ScreenCapture.createImage(scrollPane, "scrollpane.jpg");
					System.out.println("Creating textarea.jpg");
					ScreenCapture.createImage(textArea, "textarea.jpg");
					System.out.println("Creating button.jpg");
					ScreenCapture.createImage(button, "button.jpg");
					button.setText("button refreshed");
					button.paintImmediately(button.getBounds());
					System.out.println("Creating refresh.jpg");
					ScreenCapture.createImage(button, "refresh.jpg");
					System.out.println("Creating region.jpg");
					Rectangle r = new Rectangle(0, 0, 100, 16);
					ScreenCapture.createImage(textArea, r, "region.png");
				}
				catch(Exception exc) { System.out.println(exc); }
			}
		});
		frame.getContentPane().add(button, BorderLayout.SOUTH);

		try
		{
			FileReader fr = new FileReader( "ScreenCapture.java" );
			BufferedReader br = new BufferedReader(fr);
			textArea.read( br, null );
			br.close();
		}
		catch(Exception e) {}

		frame.setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
		frame.pack();
		frame.setLocationRelativeTo( null );
		frame.setVisible(true);
	}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/MultiSplitLayout.java0000644000175000017500000012522011114425455027065 0ustar  giovannigiovanni/*
 * $Id: MultiSplitLayout.java,v 1.15 2005/10/26 14:29:54 hansmuller Exp $
 *
 * Copyright 2004 Sun Microsystems, Inc., 4150 Network Circle,
 * Santa Clara, California 95054, U.S.A. All rights reserved.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 * 
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 */

package org.mathpiper.ui.gui;

import java.awt.Component;
import java.awt.Container;
import java.awt.Dimension;
import java.awt.Insets;
import java.awt.LayoutManager;
import java.awt.Rectangle;
import java.beans.PropertyChangeListener;
import java.beans.PropertyChangeSupport;
import java.io.IOException;
import java.io.Reader;
import java.io.StreamTokenizer;
import java.io.StringReader;
import java.util.ArrayList;
import java.util.Collections;
import java.util.HashMap;
import java.util.Iterator;
import java.util.List;
import java.util.ListIterator;
import java.util.Map;
import javax.swing.UIManager;


/**
 * The MultiSplitLayout layout manager recursively arranges its
 * components in row and column groups called "Splits".  Elements of
 * the layout are separated by gaps called "Dividers".  The overall
 * layout is defined with a simple tree model whose nodes are 
 * instances of MultiSplitLayout.Split, MultiSplitLayout.Divider, 
 * and MultiSplitLayout.Leaf. Named Leaf nodes represent the space 
 * allocated to a component that was added with a constraint that
 * matches the Leaf's name.  Extra space is distributed
 * among row/column siblings according to their 0.0 to 1.0 weight.
 * If no weights are specified then the last sibling always gets
 * all of the extra space, or space reduction.
 * 
 * 
    
 * Although MultiSplitLayout can be used with any Container, it's
 * the default layout manager for MultiSplitPane.  MultiSplitPane
 * supports interactively dragging the Dividers, accessibility, 
 * and other features associated with split panes.
 * 
 * 
    
 * All properties in this class are bound: when a properties value
 * is changed, all PropertyChangeListeners are fired.
 * 
 * @author Hans Muller
 * @see MultiSplitPane
 */

public class MultiSplitLayout implements LayoutManager {
    private final Map childMap = new HashMap();
    private final PropertyChangeSupport pcs = new PropertyChangeSupport(this);
    private Node model;
    private int dividerSize;
    private boolean floatingDividers = true;

    /**
     * Create a MultiSplitLayout with a default model with a single
     * Leaf node named "default".  
     * 
     * #see setModel
     */
    public MultiSplitLayout() { 
	this(new Leaf("default"));
    }
    
    /**
     * Create a MultiSplitLayout with the specified model.
     * 
     * #see setModel
     */
    public MultiSplitLayout(Node model) {
	this.model = model;
        this.dividerSize = UIManager.getInt("SplitPane.dividerSize"); 
	if (this.dividerSize == 0) {
            this.dividerSize = 7;
        }
    }

    public void addPropertyChangeListener(PropertyChangeListener listener) {
        if (listener != null) {
	    pcs.addPropertyChangeListener(listener);
        }
    }
    public void removePropertyChangeListener(PropertyChangeListener listener) {
        if (listener != null) {
	    pcs.removePropertyChangeListener(listener);
        }
    }
    public PropertyChangeListener[] getPropertyChangeListeners() {
        return pcs.getPropertyChangeListeners();
    }

    private void firePCS(String propertyName, Object oldValue, Object newValue) {
	if (!(oldValue != null && newValue != null && oldValue.equals(newValue))) {
	    pcs.firePropertyChange(propertyName, oldValue, newValue);
        }
    }

    /**
     * Return the root of the tree of Split, Leaf, and Divider nodes
     * that define this layout.  
     * 
     * @return the value of the model property
     * @see #setModel
     */
    public Node getModel() { return model; }

    /**
     * Set the root of the tree of Split, Leaf, and Divider nodes
     * that define this layout.  The model can be a Split node
     * (the typical case) or a Leaf.  The default value of this
     * property is a Leaf named "default".
     * 
     * @param model the root of the tree of Split, Leaf, and Divider node
     * @throws IllegalArgumentException if model is a Divider or null
     * @see #getModel
     */
    public void setModel(Node model) {
	if ((model == null) || (model instanceof Divider)) {
	    throw new IllegalArgumentException("invalid model");
	}
	Node oldModel = model;
	this.model = model;
	firePCS("model", oldModel, model);
    }

    /**
     * Returns the width of Dividers in Split rows, and the height of 
     * Dividers in Split columns.
     *
     * @return the value of the dividerSize property
     * @see #setDividerSize
     */
    public int getDividerSize() { return dividerSize; }

    /**
     * Sets the width of Dividers in Split rows, and the height of 
     * Dividers in Split columns.  The default value of this property
     * is the same as for JSplitPane Dividers.
     *
     * @param dividerSize the size of dividers (pixels)
     * @throws IllegalArgumentException if dividerSize < 0
     * @see #getDividerSize
     */
    public void setDividerSize(int dividerSize) {
	if (dividerSize < 0) {
	    throw new IllegalArgumentException("invalid dividerSize");
	}
	int oldDividerSize = this.dividerSize;
	this.dividerSize = dividerSize;
	firePCS("dividerSize", oldDividerSize, dividerSize);
    }

    /**
     * @return the value of the floatingDividers property
     * @see #setFloatingDividers
     */
    public boolean getFloatingDividers() { return floatingDividers; }


    /**
     * If true, Leaf node bounds match the corresponding component's 
     * preferred size and Splits/Dividers are resized accordingly.  
     * If false then the Dividers define the bounds of the adjacent
     * Split and Leaf nodes.  Typically this property is set to false
     * after the (MultiSplitPane) user has dragged a Divider.
     * 
     * @see #getFloatingDividers
     */
    public void setFloatingDividers(boolean floatingDividers) {
	boolean oldFloatingDividers = this.floatingDividers;
	this.floatingDividers = floatingDividers;
	firePCS("floatingDividers", oldFloatingDividers, floatingDividers);
    }


    /** 
     * Add a component to this MultiSplitLayout.  The
     * name should match the name property of the Leaf
     * node that represents the bounds of child.  After
     * layoutContainer() recomputes the bounds of all of the nodes in
     * the model, it will set this child's bounds to the bounds of the
     * Leaf node with name.  Note: if a component was already
     * added with the same name, this method does not remove it from 
     * its parent.  
     * 
     * @param name identifies the Leaf node that defines the child's bounds
     * @param child the component to be added
     * @see #removeLayoutComponent
     */
    public void addLayoutComponent(String name, Component child) {
	if (name == null) {
	    throw new IllegalArgumentException("name not specified");
	}
	childMap.put(name, child);
    }

    /**
     * Removes the specified component from the layout.
     * 
     * @param child the component to be removed
     * @see #addLayoutComponent
     */
    public void removeLayoutComponent(Component child) {
	String name = child.getName();
	if (name != null) {
	    childMap.remove(name);
	}
    }

    private Component childForNode(Node node) {
	if (node instanceof Leaf) {
	    Leaf leaf = (Leaf)node;
	    String name = leaf.getName();
	    return (name != null) ? childMap.get(name) : null;
	}
	return null;
    }


    private Dimension preferredComponentSize(Node node) {
	Component child = childForNode(node);
	return (child != null) ? child.getPreferredSize() : new Dimension(0, 0);
	
    }

    private Dimension minimumComponentSize(Node node) {
	Component child = childForNode(node);
	return (child != null) ? child.getMinimumSize() : new Dimension(0, 0);
	
    }

    private Dimension preferredNodeSize(Node root) {
	if (root instanceof Leaf) {
	    return preferredComponentSize(root);
	}
	else if (root instanceof Divider) {
	    int dividerSize = getDividerSize();
	    return new Dimension(dividerSize, dividerSize);
	}
	else {
	    Split split = (Split)root;
	    List splitChildren = split.getChildren();
	    int width = 0;
	    int height = 0;
	    if (split.isRowLayout()) { 
		for(Node splitChild : splitChildren) {
		    Dimension size = preferredNodeSize(splitChild);
		    width += size.width;
		    height = Math.max(height, size.height);
		}
	    }
	    else {
		for(Node splitChild : splitChildren) {
		    Dimension size = preferredNodeSize(splitChild);
		    width = Math.max(width, size.width);
		    height += size.height;
		}
	    }
	    return new Dimension(width, height);
	}
    }

    private Dimension minimumNodeSize(Node root) {
	if (root instanceof Leaf) {
	    Component child = childForNode(root);
	    return (child != null) ? child.getMinimumSize() : new Dimension(0, 0);
	}
	else if (root instanceof Divider) {
	    int dividerSize = getDividerSize();
	    return new Dimension(dividerSize, dividerSize);
	}
	else {
	    Split split = (Split)root;
	    List splitChildren = split.getChildren();
	    int width = 0;
	    int height = 0;
	    if (split.isRowLayout()) { 
		for(Node splitChild : splitChildren) {
		    Dimension size = minimumNodeSize(splitChild);
		    width += size.width;
		    height = Math.max(height, size.height);
		}
	    }
	    else {
		for(Node splitChild : splitChildren) {
		    Dimension size = minimumNodeSize(splitChild);
		    width = Math.max(width, size.width);
		    height += size.height;
		}
	    }
	    return new Dimension(width, height);
	}
    }

    private Dimension sizeWithInsets(Container parent, Dimension size) {
	Insets insets = parent.getInsets();
	int width = size.width + insets.left + insets.right;
	int height = size.height + insets.top + insets.bottom;
	return new Dimension(width, height);
    }

    public Dimension preferredLayoutSize(Container parent) {
	Dimension size = preferredNodeSize(getModel());
	return sizeWithInsets(parent, size);
    }

    public Dimension minimumLayoutSize(Container parent) {
	Dimension size = minimumNodeSize(getModel());
	return sizeWithInsets(parent, size);
    }


    private Rectangle boundsWithYandHeight(Rectangle bounds, double y, double height) {
	Rectangle r = new Rectangle();
	r.setBounds((int)(bounds.getX()), (int)y, (int)(bounds.getWidth()), (int)height);
	return r;
    }

    private Rectangle boundsWithXandWidth(Rectangle bounds, double x, double width) {
	Rectangle r = new Rectangle();
	r.setBounds((int)x, (int)(bounds.getY()), (int)width, (int)(bounds.getHeight()));
	return r;
    }


    private void minimizeSplitBounds(Split split, Rectangle bounds) {
	Rectangle splitBounds = new Rectangle(bounds.x, bounds.y, 0, 0);
	List splitChildren = split.getChildren();
	Node lastChild = splitChildren.get(splitChildren.size() - 1);
	Rectangle lastChildBounds = lastChild.getBounds();
	if (split.isRowLayout()) {
	    int lastChildMaxX = lastChildBounds.x + lastChildBounds.width;
	    splitBounds.add(lastChildMaxX, bounds.y + bounds.height);
	}
	else {
	    int lastChildMaxY = lastChildBounds.y + lastChildBounds.height;
	    splitBounds.add(bounds.x + bounds.width, lastChildMaxY);
	}
	split.setBounds(splitBounds);
    }


    private void layoutShrink(Split split, Rectangle bounds) {
	Rectangle splitBounds = split.getBounds();
	ListIterator splitChildren = split.getChildren().listIterator();
	Node lastWeightedChild = split.lastWeightedChild();

	if (split.isRowLayout()) {
	    int totalWidth = 0;          // sum of the children's widths
	    int minWeightedWidth = 0;    // sum of the weighted childrens' min widths
	    int totalWeightedWidth = 0;  // sum of the weighted childrens' widths
	    for(Node splitChild : split.getChildren()) {
		int nodeWidth = splitChild.getBounds().width;
		int nodeMinWidth = Math.min(nodeWidth, minimumNodeSize(splitChild).width);
		totalWidth += nodeWidth;
		if (splitChild.getWeight() > 0.0) {
		    minWeightedWidth += nodeMinWidth;
		    totalWeightedWidth += nodeWidth;
		}
	    }

	    double x = bounds.getX();
	    double extraWidth = splitBounds.getWidth() - bounds.getWidth();
	    double availableWidth = extraWidth;
	    boolean onlyShrinkWeightedComponents = 
		(totalWeightedWidth - minWeightedWidth) > extraWidth;

	    while(splitChildren.hasNext()) {
		Node splitChild = splitChildren.next();
		Rectangle splitChildBounds = splitChild.getBounds();
		double minSplitChildWidth = minimumNodeSize(splitChild).getWidth();
		double splitChildWeight = (onlyShrinkWeightedComponents)
		    ? splitChild.getWeight()
		    : (splitChildBounds.getWidth() / (double)totalWidth);

		if (!splitChildren.hasNext()) {
		    double newWidth =  Math.max(minSplitChildWidth, bounds.getMaxX() - x); 
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, newWidth);
		    layout2(splitChild, newSplitChildBounds);
		}
		else if ((availableWidth > 0.0) && (splitChildWeight > 0.0)) {
		    double allocatedWidth = Math.rint(splitChildWeight * extraWidth);
		    double oldWidth = splitChildBounds.getWidth();
		    double newWidth = Math.max(minSplitChildWidth, oldWidth - allocatedWidth);
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, newWidth);
		    layout2(splitChild, newSplitChildBounds);
		    availableWidth -= (oldWidth - splitChild.getBounds().getWidth());
		}
		else {
		    double existingWidth = splitChildBounds.getWidth();
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, existingWidth);
		    layout2(splitChild, newSplitChildBounds);
		}
		x = splitChild.getBounds().getMaxX();
	    }
	}

	else {
	    int totalHeight = 0;          // sum of the children's heights
	    int minWeightedHeight = 0;    // sum of the weighted childrens' min heights
	    int totalWeightedHeight = 0;  // sum of the weighted childrens' heights
	    for(Node splitChild : split.getChildren()) {
		int nodeHeight = splitChild.getBounds().height;
		int nodeMinHeight = Math.min(nodeHeight, minimumNodeSize(splitChild).height);
		totalHeight += nodeHeight;
		if (splitChild.getWeight() > 0.0) {
		    minWeightedHeight += nodeMinHeight;
		    totalWeightedHeight += nodeHeight;
		}
	    }

	    double y = bounds.getY();
	    double extraHeight = splitBounds.getHeight() - bounds.getHeight();
	    double availableHeight = extraHeight;
	    boolean onlyShrinkWeightedComponents = 
		(totalWeightedHeight - minWeightedHeight) > extraHeight;

	    while(splitChildren.hasNext()) {
		Node splitChild = splitChildren.next();
		Rectangle splitChildBounds = splitChild.getBounds();
		double minSplitChildHeight = minimumNodeSize(splitChild).getHeight();
		double splitChildWeight = (onlyShrinkWeightedComponents)
		    ? splitChild.getWeight()
		    : (splitChildBounds.getHeight() / (double)totalHeight);

		if (!splitChildren.hasNext()) {
		    double oldHeight = splitChildBounds.getHeight();
		    double newHeight =  Math.max(minSplitChildHeight, bounds.getMaxY() - y); 
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, newHeight);
		    layout2(splitChild, newSplitChildBounds);
		    availableHeight -= (oldHeight - splitChild.getBounds().getHeight());
		}
		else if ((availableHeight > 0.0) && (splitChildWeight > 0.0)) {
		    double allocatedHeight = Math.rint(splitChildWeight * extraHeight);
		    double oldHeight = splitChildBounds.getHeight();
		    double newHeight = Math.max(minSplitChildHeight, oldHeight - allocatedHeight);
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, newHeight);
		    layout2(splitChild, newSplitChildBounds);
		    availableHeight -= (oldHeight - splitChild.getBounds().getHeight());
		}
		else {
		    double existingHeight = splitChildBounds.getHeight();
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, existingHeight);
		    layout2(splitChild, newSplitChildBounds);
		}
		y = splitChild.getBounds().getMaxY();
	    }
	}

	/* The bounds of the Split node root are set to be 
	 * big enough to contain all of its children. Since 
	 * Leaf children can't be reduced below their 
	 * (corresponding java.awt.Component) minimum sizes, 
	 * the size of the Split's bounds maybe be larger than
	 * the bounds we were asked to fit within.
	 */
	minimizeSplitBounds(split, bounds);
    }


    private void layoutGrow(Split split, Rectangle bounds) {
	Rectangle splitBounds = split.getBounds();
	ListIterator splitChildren = split.getChildren().listIterator();
	Node lastWeightedChild = split.lastWeightedChild();

	/* Layout the Split's child Nodes' along the X axis.  The bounds 
	 * of each child will have the same y coordinate and height as the 
	 * layoutGrow() bounds argument.  Extra width is allocated to the 
	 * to each child with a non-zero weight:
	 *     newWidth = currentWidth + (extraWidth * splitChild.getWeight())
	 * Any extraWidth "left over" (that's availableWidth in the loop
	 * below) is given to the last child.  Note that Dividers always
	 * have a weight of zero, and they're never the last child.
	 */
	if (split.isRowLayout()) {
	    double x = bounds.getX();
	    double extraWidth = bounds.getWidth() - splitBounds.getWidth();
	    double availableWidth = extraWidth;

	    while(splitChildren.hasNext()) {
		Node splitChild = splitChildren.next();
		Rectangle splitChildBounds = splitChild.getBounds();
		double splitChildWeight = splitChild.getWeight();

		if (!splitChildren.hasNext()) {  
		    double newWidth = bounds.getMaxX() - x; 
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, newWidth);
		    layout2(splitChild, newSplitChildBounds);
		}
		else if ((availableWidth > 0.0) && (splitChildWeight > 0.0)) {
		    double allocatedWidth = (splitChild.equals(lastWeightedChild)) 
			? availableWidth
			: Math.rint(splitChildWeight * extraWidth);
		    double newWidth = splitChildBounds.getWidth() + allocatedWidth;
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, newWidth);
		    layout2(splitChild, newSplitChildBounds);
		    availableWidth -= allocatedWidth;
		}
		else {
		    double existingWidth = splitChildBounds.getWidth();
		    Rectangle newSplitChildBounds = boundsWithXandWidth(bounds, x, existingWidth);
		    layout2(splitChild, newSplitChildBounds);
		}
		x = splitChild.getBounds().getMaxX();
	    }
	}

	/* Layout the Split's child Nodes' along the Y axis.  The bounds 
	 * of each child will have the same x coordinate and width as the 
	 * layoutGrow() bounds argument.  Extra height is allocated to the 
	 * to each child with a non-zero weight:
	 *     newHeight = currentHeight + (extraHeight * splitChild.getWeight())
	 * Any extraHeight "left over" (that's availableHeight in the loop
	 * below) is given to the last child.  Note that Dividers always
	 * have a weight of zero, and they're never the last child.
	 */
	else {
	    double y = bounds.getY();
	    double extraHeight = bounds.getMaxY() - splitBounds.getHeight();
	    double availableHeight = extraHeight;

	    while(splitChildren.hasNext()) {
		Node splitChild = splitChildren.next();
		Rectangle splitChildBounds = splitChild.getBounds();
		double splitChildWeight = splitChild.getWeight();
		
		if (!splitChildren.hasNext()) {
		    double newHeight = bounds.getMaxY() - y; 
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, newHeight);
		    layout2(splitChild, newSplitChildBounds);
		}
		else if ((availableHeight > 0.0) && (splitChildWeight > 0.0)) {
		    double allocatedHeight = (splitChild.equals(lastWeightedChild)) 
			? availableHeight
			: Math.rint(splitChildWeight * extraHeight);
		    double newHeight = splitChildBounds.getHeight() + allocatedHeight;
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, newHeight);
		    layout2(splitChild, newSplitChildBounds);
		    availableHeight -= allocatedHeight;
		}
		else {
		    double existingHeight = splitChildBounds.getHeight();
		    Rectangle newSplitChildBounds = boundsWithYandHeight(bounds, y, existingHeight);
		    layout2(splitChild, newSplitChildBounds);
		}
		y = splitChild.getBounds().getMaxY();
	    }
	}
    }


    /* Second pass of the layout algorithm: branch to layoutGrow/Shrink
     * as needed.
     */
   private void layout2(Node root, Rectangle bounds) {
	if (root instanceof Leaf) {
	    Component child = childForNode(root);
	    if (child != null) {
		child.setBounds(bounds);
	    }
	    root.setBounds(bounds);
	}
	else if (root instanceof Divider) {
	    root.setBounds(bounds);
	}
	else if (root instanceof Split) {
	    Split split = (Split)root;
	    boolean grow = split.isRowLayout() 
		? (split.getBounds().width <= bounds.width)
		: (split.getBounds().height <= bounds.height);
	    if (grow) {
		layoutGrow(split, bounds);
		root.setBounds(bounds);
	    }
	    else {
		layoutShrink(split, bounds);
                // split.setBounds() called in layoutShrink()
	    }
	}
    }


    /* First pass of the layout algorithm.
     * 
     * If the Dividers are "floating" then set the bounds of each
     * node to accomodate the preferred size of all of the 
     * Leaf's java.awt.Components.  Otherwise, just set the bounds
     * of each Leaf/Split node so that it's to the left of (for
     * Split.isRowLayout() Split children) or directly above
     * the Divider that follows.
     * 
     * This pass sets the bounds of each Node in the layout model.  It
     * does not resize any of the parent Container's
     * (java.awt.Component) children.  That's done in the second pass,
     * see layoutGrow() and layoutShrink().
     */
    private void layout1(Node root, Rectangle bounds) {
	if (root instanceof Leaf) {
	    root.setBounds(bounds);
	}
	else if (root instanceof Split) {
	    Split split = (Split)root;
	    Iterator splitChildren = split.getChildren().iterator();
	    Rectangle childBounds = null;
	    int dividerSize = getDividerSize();
	    
	    /* Layout the Split's child Nodes' along the X axis.  The bounds 
	     * of each child will have the same y coordinate and height as the 
	     * layout1() bounds argument.  
	     * 
	     * Note: the column layout code - that's the "else" clause below
	     * this if, is identical to the X axis (rowLayout) code below.
	     */
	    if (split.isRowLayout()) {
		double x = bounds.getX();
		while(splitChildren.hasNext()) {
		    Node splitChild = splitChildren.next();
		    Divider dividerChild = 
			(splitChildren.hasNext()) ? (Divider)(splitChildren.next()) : null;

		    double childWidth = 0.0;
		    if (getFloatingDividers()) {
			childWidth = preferredNodeSize(splitChild).getWidth();
		    }
		    else {
			if (dividerChild != null) {
			    childWidth = dividerChild.getBounds().getX() - x;
			}
			else {
			    childWidth = split.getBounds().getMaxX() - x;
			}
		    }
		    childBounds = boundsWithXandWidth(bounds, x, childWidth);
		    layout1(splitChild, childBounds);

		    if (getFloatingDividers() && (dividerChild != null)) {
			double dividerX = childBounds.getMaxX();
			Rectangle dividerBounds = boundsWithXandWidth(bounds, dividerX, dividerSize);
			dividerChild.setBounds(dividerBounds);
		    }
		    if (dividerChild != null) {
			x = dividerChild.getBounds().getMaxX();
		    }
		}
	    }

	    /* Layout the Split's child Nodes' along the Y axis.  The bounds 
	     * of each child will have the same x coordinate and width as the 
	     * layout1() bounds argument.  The algorithm is identical to what's
	     * explained above, for the X axis case.
	     */
	    else {
		double y = bounds.getY();
		while(splitChildren.hasNext()) {
		    Node splitChild = splitChildren.next();
		    Divider dividerChild = 
			(splitChildren.hasNext()) ? (Divider)(splitChildren.next()) : null;

		    double childHeight = 0.0;
		    if (getFloatingDividers()) {
			childHeight = preferredNodeSize(splitChild).getHeight();
		    }
		    else {
			if (dividerChild != null) {
			    childHeight = dividerChild.getBounds().getY() - y;
			}
			else {
			    childHeight = split.getBounds().getMaxY() - y;
			}
		    }
		    childBounds = boundsWithYandHeight(bounds, y, childHeight);
		    layout1(splitChild, childBounds);

		    if (getFloatingDividers() && (dividerChild != null)) {
			double dividerY = childBounds.getMaxY();
			Rectangle dividerBounds = boundsWithYandHeight(bounds, dividerY, dividerSize);
			dividerChild.setBounds(dividerBounds);
		    }
		    if (dividerChild != null) {
			y = dividerChild.getBounds().getMaxY();
		    }
		}
	    }
	    /* The bounds of the Split node root are set to be just
	     * big enough to contain all of its children, but only
	     * along the axis it's allocating space on.  That's 
	     * X for rows, Y for columns.  The second pass of the 
	     * layout algorithm - see layoutShrink()/layoutGrow() 
	     * allocates extra space.
	     */
	    minimizeSplitBounds(split, bounds);
	}
    }

    /** 
     * The specified Node is either the wrong type or was configured
     * incorrectly.
     */
    public static class InvalidLayoutException extends RuntimeException {
	private final Node node;
	public InvalidLayoutException (String msg, Node node) {
	    super(msg);
	    this.node = node;
	}
	/** 
	 * @return the invalid Node.
	 */
	public Node getNode() { return node; }
    }

    private void throwInvalidLayout(String msg, Node node) {
	throw new InvalidLayoutException(msg, node);
    }

    private void checkLayout(Node root) {
	if (root instanceof Split) {
	    Split split = (Split)root;
	    if (split.getChildren().size() <= 2) {
		throwInvalidLayout("Split must have > 2 children", root);
	    }
	    Iterator splitChildren = split.getChildren().iterator();
	    double weight = 0.0;
	    while(splitChildren.hasNext()) {
		Node splitChild = splitChildren.next();
		if (splitChild instanceof Divider) {
		    throwInvalidLayout("expected a Split or Leaf Node", splitChild);
		}
		if (splitChildren.hasNext()) {
		    Node dividerChild = splitChildren.next();
		    if (!(dividerChild instanceof Divider)) {
			throwInvalidLayout("expected a Divider Node", dividerChild);
		    }
		}
		weight += splitChild.getWeight();
		checkLayout(splitChild);
	    }
	    if (weight > 1.0) {
		throwInvalidLayout("Split children's total weight > 1.0", root);
	    }
	}
    }

    /** 
     * Compute the bounds of all of the Split/Divider/Leaf Nodes in 
     * the layout model, and then set the bounds of each child component
     * with a matching Leaf Node.
     */
    public void layoutContainer(Container parent) {
	checkLayout(getModel());
	Insets insets = parent.getInsets();
	Dimension size = parent.getSize();
	int width = size.width - (insets.left + insets.right);
	int height = size.height - (insets.top + insets.bottom);
	Rectangle bounds = new Rectangle(insets.left, insets.top, width, height);
	layout1(getModel(), bounds); 
	layout2(getModel(), bounds); 
    }


    private Divider dividerAt(Node root, int x, int y) {
	if (root instanceof Divider) {
            Divider divider = (Divider)root;
	    return (divider.getBounds().contains(x, y)) ? divider : null;
	}
	else if (root instanceof Split) {
	    Split split = (Split)root;
	    for(Node child : split.getChildren()) {
		if (child.getBounds().contains(x, y)) {
		    return dividerAt(child, x, y);
		}
	    }
	}
	return null;
    }

    /** 
     * Return the Divider whose bounds contain the specified
     * point, or null if there isn't one.
     * 
     * @param x x coordinate
     * @param y y coordinate
     * @return the Divider at x,y
     */
    public Divider dividerAt(int x, int y) {
	return dividerAt(getModel(), x, y);
    }

    private boolean nodeOverlapsRectangle(Node node, Rectangle r2) {
	Rectangle r1 = node.getBounds();
	return 
	    (r1.x <= (r2.x + r2.width)) && ((r1.x + r1.width) >= r2.x) &&
	    (r1.y <= (r2.y + r2.height)) && ((r1.y + r1.height) >= r2.y);
    }

    private List dividersThatOverlap(Node root, Rectangle r) {
	if (nodeOverlapsRectangle(root, r) && (root instanceof Split)) {
	    List dividers = new ArrayList();
	    for(Node child : ((Split)root).getChildren()) {
		if (child instanceof Divider) {
		    if (nodeOverlapsRectangle(child, r)) {
			dividers.add((Divider)child);
		    }
		}
		else if (child instanceof Split) {
		    dividers.addAll(dividersThatOverlap(child, r));
		}
	    }
            return dividers;
	}
	else {
	    return Collections.emptyList();
	}
    }

    /**
     * Return the Dividers whose bounds overlap the specified
     * Rectangle.
     * 
     * @param r target Rectangle
     * @return the Dividers that overlap r
     * @throws IllegalArgumentException if the Rectangle is null
     */
    public List dividersThatOverlap(Rectangle r) {
	if (r == null) {
	    throw new IllegalArgumentException("null Rectangle");
	}
	return dividersThatOverlap(getModel(), r);
    }


    /** 
     * Base class for the nodes that model a MultiSplitLayout.
     */
    public static abstract class Node {
	private Split parent = null;  
	private Rectangle bounds = new Rectangle();
	private double weight = 0.0;

	/** 
	 * Returns the Split parent of this Node, or null.
	 *
	 * @return the value of the parent property.
	 * @see #setParent
	 */
	public Split getParent() { return parent; }

	/**
	 * Set the value of this Node's parent property.  The default
	 * value of this property is null.
	 * 
	 * @param parent a Split or null
	 * @see #getParent
	 */
	public void setParent(Split parent) {
	    this.parent = parent;
	}
	
	/**
	 * Returns the bounding Rectangle for this Node.
	 * 
	 * @return the value of the bounds property.
	 * @see #setBounds
	 */
	public Rectangle getBounds() { 
	    return new Rectangle(this.bounds);
	}

	/**
	 * Set the bounding Rectangle for this node.  The value of 
	 * bounds may not be null.  The default value of bounds
	 * is equal to new Rectangle(0,0,0,0).
	 * 
	 * @param bounds the new value of the bounds property
	 * @throws IllegalArgumentException if bounds is null
	 * @see #getBounds
	 */
	public void setBounds(Rectangle bounds) {
	    if (bounds == null) {
		throw new IllegalArgumentException("null bounds");
	    }
	    this.bounds = new Rectangle(bounds);
	}

	/** 
	 * Value between 0.0 and 1.0 used to compute how much space
	 * to add to this sibling when the layout grows or how
	 * much to reduce when the layout shrinks.
	 * 
	 * @return the value of the weight property
	 * @see #setWeight
	 */
	public double getWeight() { return weight; }

	/** 
	 * The weight property is a between 0.0 and 1.0 used to
	 * compute how much space to add to this sibling when the
	 * layout grows or how much to reduce when the layout shrinks.
	 * If rowLayout is true then this node's width grows
	 * or shrinks by (extraSpace * weight).  If rowLayout is false,
	 * then the node's height is changed.  The default value
	 * of weight is 0.0.
	 * 
	 * @param weight a double between 0.0 and 1.0
	 * @see #getWeight
	 * @see MultiSplitLayout#layoutContainer
	 * @throws IllegalArgumentException if weight is not between 0.0 and 1.0
	 */
	public void setWeight(double weight) {
	    if ((weight < 0.0)|| (weight > 1.0)) {
		throw new IllegalArgumentException("invalid weight");
	    }
	    this.weight = weight;
	}

	private Node siblingAtOffset(int offset) {
	    Split parent = getParent();
	    if (parent == null) { return null; }
	    List siblings = parent.getChildren();
	    int index = siblings.indexOf(this);
	    if (index == -1) { return null; }
	    index += offset;
	    return ((index > -1) && (index < siblings.size())) ? siblings.get(index) : null;
	}
	    
	/** 
	 * Return the Node that comes after this one in the parent's
	 * list of children, or null.  If this node's parent is null,
	 * or if it's the last child, then return null.
	 * 
	 * @return the Node that comes after this one in the parent's list of children.
	 * @see #previousSibling
	 * @see #getParent
	 */
	public Node nextSibling() {
	    return siblingAtOffset(+1);
	}

	/** 
	 * Return the Node that comes before this one in the parent's
	 * list of children, or null.  If this node's parent is null,
	 * or if it's the last child, then return null.
	 * 
	 * @return the Node that comes before this one in the parent's list of children.
	 * @see #nextSibling
	 * @see #getParent
	 */
	public Node previousSibling() {
	    return siblingAtOffset(-1);
	}
    }

    /** 
     * Defines a vertical or horizontal subdivision into two or more
     * tiles.
     */
    public static class Split extends Node {
	private List children = Collections.emptyList();
	private boolean rowLayout = true;

	/**
	 * Returns true if the this Split's children are to be 
	 * laid out in a row: all the same height, left edge
	 * equal to the previous Node's right edge.  If false,
	 * children are laid on in a column.
	 * 
	 * @return the value of the rowLayout property.
	 * @see #setRowLayout
	 */
	public boolean isRowLayout() { return rowLayout; }

	/**
	 * Set the rowLayout property.  If true, all of this Split's
	 * children are to be laid out in a row: all the same height,
	 * each node's left edge equal to the previous Node's right
	 * edge.  If false, children are laid on in a column.  Default
	 * value is true.
	 * 
	 * @param rowLayout true for horizontal row layout, false for column
	 * @see #isRowLayout
	 */
	public void setRowLayout(boolean rowLayout) {
	    this.rowLayout = rowLayout;
	}

	/** 
	 * Returns this Split node's children.  The returned value
	 * is not a reference to the Split's internal list of children
	 * 
	 * @return the value of the children property.
	 * @see #setChildren
	 */
	public List getChildren() { 
	    return new ArrayList(children);
	}

	/**
	 * Set's the children property of this Split node.  The parent
	 * of each new child is set to this Split node, and the parent
	 * of each old child (if any) is set to null.  This method
	 * defensively copies the incoming List.  Default value is
	 * an empty List.
	 * 
	 * @param children List of children
	 * @see #getChildren
	 * @throws IllegalArgumentException if children is null
	 */
	public void setChildren(List children) {
	    if (children == null) {
		throw new IllegalArgumentException("children must be a non-null List");
	    }
	    for(Node child : this.children) {
		child.setParent(null);
	    }
	    this.children = new ArrayList(children);
	    for(Node child : this.children) {
		child.setParent(this);
	    }
	}

	/**
	 * Convenience method that returns the last child whose weight
	 * is > 0.0.
	 * 
	 * @return the last child whose weight is > 0.0.
	 * @see #getChildren
	 * @see Node#getWeight
	 */
	public final Node lastWeightedChild() {
	    List children = getChildren();
	    Node weightedChild = null;
	    for(Node child : children) {
		if (child.getWeight() > 0.0) {
		    weightedChild = child;
		}
	    }
	    return weightedChild;
	}

	public String toString() {
	    int nChildren = getChildren().size();
	    StringBuffer sb = new StringBuffer("MultiSplitLayout.Split");
	    sb.append(isRowLayout() ? " ROW [" : " COLUMN [");
	    sb.append(nChildren + ((nChildren == 1) ? " child" : " children"));
	    sb.append("] ");
	    sb.append(getBounds());
	    return sb.toString();
	}
    }


    /**
     * Models a java.awt Component child.
     */
    public static class Leaf extends Node {
	private String name = "";

	/**
	 * Create a Leaf node.  The default value of name is "". 
	 */
	public Leaf() { }

	/**
	 * Create a Leaf node with the specified name.  Name can not
	 * be null.
	 * 
	 * @param name value of the Leaf's name property
	 * @throws IllegalArgumentException if name is null
	 */
	public Leaf(String name) {
	    if (name == null) {
		throw new IllegalArgumentException("name is null");
	    }
	    this.name = name;
	}

	/**
	 * Return the Leaf's name.
	 * 
	 * @return the value of the name property.
	 * @see #setName
	 */
	public String getName() { return name; }

	/**
	 * Set the value of the name property.  Name may not be null.
	 * 
	 * @param name value of the name property
	 * @throws IllegalArgumentException if name is null
	 */
	public void setName(String name) {
	    if (name == null) {
		throw new IllegalArgumentException("name is null");
	    }
	    this.name = name;
	}

	public String toString() {
	    StringBuffer sb = new StringBuffer("MultiSplitLayout.Leaf");
	    sb.append(" \"");
	    sb.append(getName());
	    sb.append("\""); 
	    sb.append(" weight=");
	    sb.append(getWeight());
	    sb.append(" ");
	    sb.append(getBounds());
	    return sb.toString();
	}
    }


    /** 
     * Models a single vertical/horiztonal divider.
     */
    public static class Divider extends Node {
	/**
	 * Convenience method, returns true if the Divider's parent
	 * is a Split row (a Split with isRowLayout() true), false
	 * otherwise. In other words if this Divider's major axis
	 * is vertical, return true.
	 * 
	 * @return true if this Divider is part of a Split row.
	 */
	public final boolean isVertical() {
	    Split parent = getParent();
	    return (parent != null) ? parent.isRowLayout() : false;
	}

	/** 
	 * Dividers can't have a weight, they don't grow or shrink.
	 * @throws UnsupportedOperationException
	 */
	public void setWeight(double weight) {
	    throw new UnsupportedOperationException();
	}

	public String toString() {
	    return "MultiSplitLayout.Divider " + getBounds().toString();
	}
    }


    private static void throwParseException(StreamTokenizer st, String msg) throws Exception {
	throw new Exception("MultiSplitLayout.parseModel Error: " + msg);
    }

    private static void parseAttribute(String name, StreamTokenizer st, Node node) throws Exception {
	if ((st.nextToken() != '=')) {
	    throwParseException(st, "expected '=' after " + name);
	}
	if (name.equalsIgnoreCase("WEIGHT")) {
	    if (st.nextToken() == StreamTokenizer.TT_NUMBER) {
		node.setWeight(st.nval);
	    }
	    else { 
		throwParseException(st, "invalid weight");
	    }
	}
	else if (name.equalsIgnoreCase("NAME")) {
	    if (st.nextToken() == StreamTokenizer.TT_WORD) {
		if (node instanceof Leaf) {
		    ((Leaf)node).setName(st.sval);
		}
		else {
		    throwParseException(st, "can't specify name for " + node);
		}
	    }
	    else {
		throwParseException(st, "invalid name");
	    }
	}
	else {
	    throwParseException(st, "unrecognized attribute \"" + name + "\"");
	}
    }

    private static void addSplitChild(Split parent, Node child) {
	List children = new ArrayList(parent.getChildren());
	if (children.size() == 0) {
	    children.add(child);
	}
	else {
	    children.add(new Divider());
	    children.add(child);
	}
	parent.setChildren(children);
    }

    private static void parseLeaf(StreamTokenizer st, Split parent) throws Exception {
	Leaf leaf = new Leaf();
	int token;
	while ((token = st.nextToken()) != StreamTokenizer.TT_EOF) {
	    if (token == ')') {
		break;
	    }
	    if (token == StreamTokenizer.TT_WORD) {
		parseAttribute(st.sval, st, leaf);
	    }
	    else {
		throwParseException(st, "Bad Leaf: " + leaf);
	    }
	}
	addSplitChild(parent, leaf);
    }

    private static void parseSplit(StreamTokenizer st, Split parent) throws Exception {
	int token;
	while ((token = st.nextToken()) != StreamTokenizer.TT_EOF) {
	    if (token == ')') {
		break;
	    }
	    else if (token == StreamTokenizer.TT_WORD) {
		if (st.sval.equalsIgnoreCase("WEIGHT")) {
		    parseAttribute(st.sval, st, parent);
		}
		else {
		    addSplitChild(parent, new Leaf(st.sval));
		}
	    }
	    else if (token == '(') {
		if ((token = st.nextToken()) != StreamTokenizer.TT_WORD) {
		    throwParseException(st, "invalid node type");
		}
		String nodeType = st.sval.toUpperCase();
		if (nodeType.equals("LEAF")) {
		    parseLeaf(st, parent);
		}
		else if (nodeType.equals("ROW") || nodeType.equals("COLUMN")) {
		    Split split = new Split();
		    split.setRowLayout(nodeType.equals("ROW"));
		    addSplitChild(parent, split);
		    parseSplit(st, split);
		}
		else {
		    throwParseException(st, "unrecognized node type '" + nodeType + "'");
		}
	    }
	}
    }

    private static Node parseModel (Reader r) {
	StreamTokenizer st = new StreamTokenizer(r);
	try {
	    Split root = new Split();
	    parseSplit(st, root);
	    return root.getChildren().get(0);
	}
	catch (Exception e) {
	    System.err.println(e);
	}
	finally {
	    try { r.close(); } catch (IOException ignore) {}
	}
	return null;
    }

    /**
     * A convenience method that converts a string to a 
     * MultiSplitLayout model (a tree of Nodes) using a 
     * a simple syntax.  Nodes are represented by 
     * parenthetical expressions whose first token 
     * is one of ROW/COLUMN/LEAF.  ROW and COLUMN specify
     * horizontal and vertical Split nodes respectively, 
     * LEAF specifies a Leaf node.  A Leaf's name and 
     * weight can be specified with attributes, 
     * name=myLeafName weight=myLeafWeight.
     * Similarly, a Split's weight can be specified with
     * weight=mySplitWeight.
     * 
     * 
     For example, the following expression generates
     * a horizontal Split node with three children:
     * the Leafs named left and right, and a Divider in 
     * between:
     * 
         * (ROW (LEAF name=left) (LEAF name=right weight=1.0))
     * 
    
     * 
     * 
     Dividers should not be included in the string, 
     * they're added automatcially as needed.  Because 
     * Leaf nodes often only need to specify a name, one
     * can specify a Leaf by just providing the name.
     * The previous example can be written like this:
     * 
         * (ROW left (LEAF name=right weight=1.0))
     * 
    
     * 
     * 
    Here's a more complex example.  One row with
     * three elements, the first and last of which are columns
     * with two leaves each:
     * 
         * (ROW (COLUMN weight=0.5 left.top left.bottom) 
     *      (LEAF name=middle)
     *      (COLUMN weight=0.5 right.top right.bottom))
     * 
    
     * 
     * 
     * 
     This syntax is not intended for archiving or 
     * configuration files .  It's just a convenience for
     * examples and tests.
     * 
     * @return the Node root of a tree based on s.
     */
    public static Node parseModel(String s) {
	return parseModel(new StringReader(s));
    }


    private static void printModel(String indent, Node root) {
	if (root instanceof Split) {
	    Split split = (Split)root;
	    System.out.println(indent + split);
	    for(Node child : split.getChildren()) {
		printModel(indent + "  ", child);
	    }
	}
	else {
	    System.out.println(indent + root);
	}
    }

    /** 
     * Print the tree with enough detail for simple debugging.
     */
    public static void printModel(Node root) {
	printModel("", root);
    }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/0000755000175000017500000000000011722677341025122 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/GuiConsole.java0000644000175000017500000000427511131060345030024 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets;

import java.awt.BorderLayout;
import java.awt.Color;
import java.awt.Dimension;
import javax.swing.JFrame;
import javax.swing.JTextField;

public class GuiConsole extends JFrame {

    /** Creates new form Calculator */
    public GuiConsole() {
        this.setSize(500, 500);
        this.setPreferredSize(new Dimension(500, 500));
        this.setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
        this.setBackground(Color.WHITE);

        ConsolePanel consolePanel = new ConsolePanel();
        //TempPanel consolePanel = new TempPanel();
        this.getContentPane().add(consolePanel);
        this.getContentPane().add(new JTextField(20),BorderLayout.NORTH);
        this.pack();
        consolePanel.init();
        consolePanel.start();

        /*//Make textField get the focus whenever frame is activated.
        this.addWindowFocusListener(new WindowAdapter() {

            public void windowGainedFocus(WindowEvent e) {
                consolePanel.requestFocusInWindow();
            }
        });*/




    }

    /**
     * @param args the command line arguments
     */
    public static void main(String args[]) {

        java.awt.EventQueue.invokeLater(new Runnable() {

            public void run() {
                new GuiConsole().setVisible(true);
            }
        });
    }
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/TreePanel.java0000644000175000017500000001613011355317372027642 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets;

import java.awt.BasicStroke;
import java.awt.Color;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Graphics2D;
import java.awt.RenderingHints;
import java.util.LinkedList;
import java.util.Queue;
import javax.swing.JPanel;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Position;
import org.mathpiper.ui.gui.worksheets.symbolboxes.ScaledGraphics;
import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;

public class TreePanel extends JPanel implements ViewPanel {

    protected SymbolBox symbolBox;
    protected double viewScale = 1;
    private Queue queue = new LinkedList();
    private int[] lastOnRasterArray = new int[10000];
    private int maxTreeY = 0;
    private boolean paintedOnce = false;

    public TreePanel(SymbolBox symbolBox, double viewScale) {
        this.symbolBox = symbolBox;
        this.setOpaque(true);
        this.viewScale = viewScale;
        this.setBackground(Color.white);

        for(int index = 0; index < lastOnRasterArray.length; index++)
        {
            lastOnRasterArray[index] = -1;
        }//end for.

    }

    public void paint(Graphics g) {
        super.paint(g);
        Graphics2D g2d = (Graphics2D) g;
        g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));

        g2d.setStroke(new BasicStroke((float) (2), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
        g2d.setColor(Color.black);
        g2d.setBackground(Color.white);
        ScaledGraphics sg = new ScaledGraphics(g2d);
        sg.setLineThickness(0);
        sg.setViewScale(viewScale);

        int x = 0;
        int y = 0;
        symbolBox.calculatePositions(sg, 3, new Position(x , y));


        for(int index = 0; index < lastOnRasterArray.length; index++)
        {
            lastOnRasterArray[index] = -1;
        }//end for.

        maxTreeY = 0;
        
        layoutTree(symbolBox, 50/*yPosition*/,  -20/*position*/, null, sg);


        queue.add(symbolBox);

        SymbolBox currentNode;


        while (!queue.isEmpty()) {
            currentNode = queue.remove();

            if (currentNode != null) {
                String nodeString = currentNode.toString();

                sg.drawText(nodeString, currentNode.getTreeX(), currentNode.getTreeY() );//xPosition, yPosition);

                SymbolBox[] children = currentNode.getChildren();

                if (children != null) {
                    for (SymbolBox child : children) {
                        if (child != null) {
                            queue.add(child);

                            sg.setColor(Color.BLACK);
                            sg.setLineThickness(1.5);
                            sg.drawLine(currentNode.getTreeX() + currentNode.getTextWidth(sg)/2, currentNode.getTreeY() + 4, child.getTreeX() + child.getTextWidth(sg)/2, child.getTreeY() - child.getTextHeight(sg) + 3);

                        }
                    }

                }//end if.

                
            } else {
                System.out.print("");
            }

            if(paintedOnce == false)
            {
                super.revalidate();
                paintedOnce = true;
            }

        }//end while.

    }

    public Dimension getPreferredSize() {
        
        if(paintedOnce == false)
        {
            return new Dimension(0,0);
        }

        int maxWidth = 0;

        int index = 0;

        for(; index < lastOnRasterArray.length; index++)
        {
            if(lastOnRasterArray[index] > maxWidth)
            {
                maxWidth = lastOnRasterArray[index];
            }//end if.

        }//end for.

        maxWidth = (int) ((maxWidth + 100) * viewScale);

        int maxHeight = (int) ((maxTreeY) * viewScale);

        return(new Dimension(maxWidth, maxHeight));

    }//end method.


    public void setViewScale(double viewScale) {
        this.viewScale = viewScale;
        this.revalidate();
        this.repaint();
    }


    //Layout algorithm from "Aesthetic Layout of Generalized Trees" by Anthony Bloesch.
    private int layoutTree(SymbolBox tree, int yPosition,  int position, SymbolBox parent, ScaledGraphics sg)
    {
        int Y_SEPARATION = 35;
        int MIN_X_SEPARATION = 20;

        int branchPosition;
        int i;
        int leftPosition;
        int rightPosition;
        int width;

        int interBranchSpace = 75;


        if(tree == null)
        {
            return position;
        }
        else /* Place subtree. */
        {
            /* Ensure the nominal position of the node is to the right of any other node. */
            for(i = yPosition - Y_SEPARATION; i < yPosition+tree.getTextHeight(sg); i++)
            {
                int lastOnRaster = lastOnRasterArray[i];
                
                int possibleNewPosition = (lastOnRaster + MIN_X_SEPARATION + tree.getTextWidth(sg)/2);

                if(possibleNewPosition > position)
                {
                    position = possibleNewPosition;
                }//end if.
                
            }//end for.


            if(tree.getChildren().length >= 1){ /* Place branches if they exist. */

                if(tree.getChildren().length > 1) {

                    width = (tree.getChildren()[0].getTextWidth(sg) +
                            tree.getChildren()[tree.getChildren().length-1].getTextWidth(sg))/2 +
                            (tree.getChildren().length-1)*MIN_X_SEPARATION;

                    for(i=1; i < tree.getChildren().length-1; i++)
                        width += tree.getChildren()[i].getTextWidth(sg);}

                else
                    width = 0;

                branchPosition = position - width/2;
                /* Position far left branch. */
                leftPosition = layoutTree(tree.getChildren()[0], yPosition + tree.getTextHeight(sg) + Y_SEPARATION,
                         branchPosition, tree, sg);

                /* Position the other branches if they exist. */
                rightPosition = leftPosition;
                for(i = 1; i < tree.getChildren().length; i++){
                    branchPosition += MIN_X_SEPARATION +
                            (tree.getChildren()[i-1].getTextWidth(sg) +
                            tree.getChildren()[i].getTextWidth(sg))/2;
                    rightPosition = layoutTree(tree.getChildren()[i], yPosition + tree.getTextHeight(sg) + Y_SEPARATION,
                             branchPosition, tree, sg);
                } /* for */

                position = (leftPosition+rightPosition)/2;

            }//end if tree -> nrBranches >= 1 */

            /* Add node to list. */
            for(i = yPosition - Y_SEPARATION; i < yPosition+tree.getTextHeight(sg); i++)
            {
                lastOnRasterArray[i] = position + ((tree.getTextWidth(sg) + interBranchSpace) + 1)/2;
                if(i > maxTreeY)
                {
                    maxTreeY = i;
                }//end if.
            }//end for.


            tree.setTreeX(position);

            tree.setTreeY(yPosition);

            return position;


        }//end else.


    }//end method.

}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/hints/0000755000175000017500000000000011722677340026246 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/hints/HintWindow.java0000644000175000017500000000774611326263630031212 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets.hints;

import org.mathpiper.ui.gui.worksheets.*;


public class HintWindow
{
	public  String[] iText = new String[64];
	public  String[] iDescription = new String[64];

	public  boolean iAllowSelection = true;
	public  int iNrDescriptions;
	public  int iMaxWidth;
	public  int iTextSize;
	public  int iCurrentPos;
	public  int iNrLines;

	public  HintWindow(int aTextSize)
	{
		iNrLines = 0;
		iNrDescriptions = 0;
		iMaxWidth = 0;
		iTextSize = aTextSize;
		iCurrentPos = 0;
	}
	public  void addLine(String aText)
	{
		if (iNrLines >= 20) return;
		iText[iNrLines] = aText;
		iNrLines++;
		iMaxWidth = 0;
	}
	public  void addDescription(String aText)
	{
		if (iNrDescriptions >= 20) return;
		iDescription[iNrDescriptions] = aText;
		iNrDescriptions++;
		iMaxWidth = 0;
	}
	public  void draw(int x, int y, MathPiperGraphicsContext  aGraphicsContext)
	{
		aGraphicsContext.setFontSize(0,iTextSize);
		if (iMaxWidth == 0)
		{
			int i;
			for (i=0;iiMaxWidth)
					iMaxWidth = width;
			}
			for (i=0;iiMaxWidth)
					iMaxWidth = width;
			}
			iMaxWidth = iMaxWidth + 8;
		}

		//System.out.println("iNrLines = "+iNrLines);
		//System.out.println("iMaxWidth = "+iMaxWidth);

		int ix = x;
		int iy = y;
		int w = 5+iMaxWidth;
		int h = height(aGraphicsContext);
		iy -= (h+4);

		if (!iAllowSelection)
			aGraphicsContext.setColor(221,221,238);
		else
			aGraphicsContext.setColor(221,221,238);
		aGraphicsContext.fillRect(ix,iy,w,h);
		aGraphicsContext.setColor(0,0,0);
		aGraphicsContext.drawRect(ix,iy,w,h);

		int i;

		//System.out.println("iTextSize = "+iTextSize);
		//System.out.println("aGraphicsContext.FontHeight() = "+aGraphicsContext.FontHeight());

		for (i=0;i0)
		{
			int offset = (iNrLines+1)*aGraphicsContext.fontHeight()+7;

			aGraphicsContext.drawLine(ix+6,iy+offset-4-aGraphicsContext.fontHeight(),ix+w-6,iy+offset-4-aGraphicsContext.fontHeight());

			aGraphicsContext.setFontSize(1,iTextSize);
			for (i=0;i0)
		{
			aGraphicsContext.setFontSize(1,iTextSize);
			h += iNrDescriptions*aGraphicsContext.fontHeight()+2;
			// space for line
			h+=7;
		}
		return h;
	}

}



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/hints/Hints.java0000644000175000017500000000202411326263630030165 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets.hints;


public class Hints
{
	public  HintItem[] hintTexts = new HintItem[1024];
	int[] hoffsets = new int[256];

	public  Hints()
	{
		nrHintTexts = 0;
	}
	public  int nrHintTexts;

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/hints/HintItem.java0000644000175000017500000000170511326263630030626 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets.hints;

public class HintItem
{
	public  String base;
	public  String hint;
	public  String description;
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/hints/hints.txt0000644000175000017500000010337511326263630030136 0ustar  giovannigiovanni:Abs:Abs(x):absolute value or modulus of complex number:
:Add:Add(val1, val2, ...):find sum of a list of values:
:Add:Add({list})::
:Append:Append(list, expr):append an entry at the end of a list:
:Apply:Apply(fn, arglist):apply a function to arguments:
:ArcCos:ArcCos(x):inverse trigonometric function arc-cosine:
:ArcSin:ArcSin(x):inverse trigonometric function arc-sine:
:ArcTan:ArcTan(x):inverse trigonometric function arc-tangent:
:Arg:Arg(x):argument of a complex number:
:Array'Create:Array'Create(size,init):create array:
:Array'CreateFromList:Array'CreateFromList(list):convert list to array:
:Array'Get:Array'Get(array,index):fetch array element:
:Array'Set:Array'Set(array,index,element):set array element:
:Array'Size:Array'Size(array):get array size:
:Array'ToList:Array'ToList(array):convert array to list:
:Assert:Assert("str") pred::
:Assert:Assert("str", expr) pred:signal "soft" custom error:
:Assert:Assert() pred::
:Assoc:Assoc(key, alist):return element stored in association list:
:AssocDelete:AssocDelete(alist, "key"):delete an entry in an association list:
:AssocDelete:AssocDelete(alist, {key, value})::
:AssocIndices:AssocIndices(alist):return the keys in an association list:
:Atom:Atom("string"):convert string to atom:
:BaseVector:BaseVector(k, n):base vector:
:Bernoulli:Bernoulli(index):Bernoulli numbers and polynomials:
:Bernoulli:Bernoulli(index, x)::
:BernoulliDistribution:BernoulliDistribution(p):Bernoulli distribution:
:BigOh:BigOh(poly, var, degree):drop all terms of a certain order in a polynomial:
:Bin:Bin(n, m):binomial coefficients:
:BinSplitData:BinSplitData(n1,n2, a, b, c, d):computations of series by the binary splitting method:
:BinSplitFinal:BinSplitFinal({P,Q,B,T}):computations of series by the binary splitting method:
:BinSplitNum:BinSplitNum(n1, n2, a, b, c, d):computations of series by the binary splitting method:
:BinomialDistribution:BinomialDistribution(p,n):binomial distribution:
:BitAnd:BitAnd(n,m):bitwise and operation:
:BitOr:BitOr(n,m):bitwise or operation:
:BitXor:BitXor(n,m):bitwise xor operation:
:Bodied:Bodied("op", precedence):define function syntax (bodied function):
:BracketRational:BracketRational(x, eps):find optimal rational approximations:
:BubbleSort:BubbleSort(list, compare):sort a list:
:Builtin'Precision'Get:Builtin'Precision'Get():get the current precision:
:Builtin'Precision'Set:Builtin'Precision'Set(n):set the precision:
:CForm:CForm(expr):export expression to C++ code:
:CachedConstant:CachedConstant(cache, Cname, Cfunc):precompute multiple-precision constants:
:CanProve:CanProve(proposition):try to prove statement:
:Catalan:Catalan:Catalan's Constant:
:CatalanNumber:CatalanNumber(n):return the {n}th Catalan Number:
:Ceil:Ceil(x):round a number upwards:
:CharacteristicEquation:CharacteristicEquation(matrix,var):get characteristic polynomial of a matrix:
:Check:Check(predicate,"error text"):report "hard" errors:
:ChiSquareTest:ChiSquareTest(observed,expected):Pearson's ChiSquare test:
:ChiSquareTest:ChiSquareTest(observed,expected,params)::
:Cholesky:Cholesky(A):find the Cholesky Decomposition:
:Clear:Clear(var, ...):undo an assignment:
:ClearError:ClearError("str"):custom errors handlers:
:ClearErrors:ClearErrors():simple error handlers:
:CoFactor:CoFactor(M,i,j):cofactor of a matrix:
:Coef:Coef(expr, var, order):coefficient of a polynomial:
:Complex:Complex(r, c):construct a complex number:
:Concat:Concat(list1, list2, ...):concatenate lists:
:ConcatStrings:ConcatStrings(strings):concatenate strings:
:Conjugate:Conjugate(x):complex conjugate:
:ContFrac:ContFrac(x):continued fraction expansion:
:ContFrac:ContFrac(x, depth)::
:ContFracEval:ContFracEval(list):manipulate continued fractions:
:ContFracEval:ContFracEval(list, rest)::
:ContFracList:ContFracList(frac):manipulate continued fractions:
:ContFracList:ContFracList(frac, depth)::
:Contains:Contains(list, expr):test whether a list contains a certain element:
:Content:Content(expr):content of a univariate polynomial:
:Cos:Cos(x):trigonometric cosine function:
:Count:Count(list, expr):count the number of occurrences of an expression:
:CrossProduct:CrossProduct(a,b):outer product of vectors:
:Curl:Curl(vector, basis):curl of a vector field:
:CurrentFile:CurrentFile():return current input file:
:CurrentLine:CurrentLine():return current line number on input:
:Cyclotomic:Cyclotomic(n,x):construct the cyclotomic polynomial:
:D:D(list) expression::
:D:D(variable) expression:take derivative of expression with respect to variable:
:D:D(variable,n) expression::
:Decimal:Decimal(frac):decimal representation of a rational:
:DefLoad:DefLoad(name):load a {.def} file:
:DefMacroRuleBase:DefMacroRuleBase(name,params):define a function as a macro:
:DefMacroRuleBaseListed:DefMacroRuleBaseListed("name", params):define macro with variable number of arguments:
:DefaultTokenizer:DefaultTokenizer():select the default syntax tokenizer for parsing the input:
:Degree:Degree(expr):degree of a polynomial:
:Degree:Degree(expr, var)::
:Delete:Delete(list, n):delete an element from a list:
:Denom:Denom(expr):denominator of an expression:
:DestructiveAppend:DestructiveAppend(list, expr):destructively append an entry to a list:
:DestructiveDelete:DestructiveDelete(list, n):delete an element destructively from a list:
:DestructiveInsert:DestructiveInsert(list, n, expr):insert an element destructively into a list:
:DestructiveReplace:DestructiveReplace(list, n, expr):replace an entry destructively in a list:
:DestructiveReverse:DestructiveReverse(list):reverse a list destructively:
:Determinant:Determinant(M):determinant of a matrix:
:Diagonal:Diagonal(A):extract the diagonal from a matrix:
:DiagonalMatrix:DiagonalMatrix(d):construct a diagonal matrix:
:Difference:Difference(l1, l2):return the difference of two lists:
:Div:Div(x,y):Determine divisor of two mathematical objects:
:Diverge:Diverge(vector, basis):divergence of a vector field:
:Divisors:Divisors(n):number of divisors:
:DivisorsList:DivisorsList(n):the list of divisors:
:DivisorsSum:DivisorsSum(n):the sum of  divisors:
:Dot:Dot(t1,t2):get dot product of tensors:
:Drop:Drop(list, -n)::
:Drop:Drop(list, n):drop a range of elements from a list:
:Drop:Drop(list, {m,n})::
:DumpErrors:DumpErrors():simple error handlers:
:Echo:Echo(item):high-level printing routine:
:Echo:Echo(item,item,item,...)::
:Echo:Echo(list)::
:EigenValues:EigenValues(matrix):get eigenvalues of a matrix:
:EigenVectors:EigenVectors(A,eigenvalues):get eigenvectors of a matrix:
:Eliminate:Eliminate(var, value, expr):substitute and simplify:
:EndOfFile:EndOfFile:end-of-file marker:
:Equals:Equals(a,b):check equality:
:Euler:Euler(index):Euler numbers and polynomials:
:Euler:Euler(index,x)::
:Eulerian:Eulerian(n,m):Eulerian numbers:
:Eval:Eval(expr):force evaluation of expression:
:EvalFormula:EvalFormula(expr):print an evaluation nicely with ASCII art:
:EvaluateHornerScheme:EvaluateHornerScheme(coeffs,x):fast evaluation of polynomials:
:Exp:Exp(x):exponential function:
:Expand:Expand(expr):transform a polynomial to an expanded form:
:Expand:Expand(expr, var)::
:Expand:Expand(expr, varlist)::
:ExpandBrackets:ExpandBrackets(expr):expand all brackets:
:ExtraInfo'Get:ExtraInfo'Get(expr):annotate objects with additional information:
:ExtraInfo'Set:ExtraInfo'Set(expr,tag):annotate objects with additional information:
:Factor:Factor(x):factorization, in pretty form:
:FactorialSimplify:FactorialSimplify(expression):Simplify hypergeometric expressions containing factorials:
:Factorize:Factorize(list):product of a list of values:
:Factorize:Factorize(var, from, to, body)::
:Factors:Factors(x):factorization:
:False:False:boolean constant representing false:
:FermatNumber:FermatNumber(n):return the {n}th Fermat Number:
:FillList:FillList(expr, n):fill a list with a certain expression:
:Find:Find(list, expr):get the index at which a certain element occurs:
:FindFile:FindFile(name):find a file in the current path:
:FindFunction:FindFunction(function):find the library file where a function is defined:
:FindRealRoots:FindRealRoots(p):find the real roots of a polynomial:
:FlatCopy:FlatCopy(list):copy the top level of a list:
:Flatten:Flatten(expression,operator):flatten expression w.r.t. some operator:
:Floor:Floor(x):round a number downwards:
:For:For(init, pred, incr) body:C-style {for} loop:
:ForEach:ForEach(var, list) body:loop over all entries in list:
:FromBase:FromBase(base,"string"):conversion of a number from non-decimal base to decimal base:
:FromFile:FromFile(name) body:connect current input to a file:
:FromString:FromString(str) body;:connect current input to a string:
:FullForm:FullForm(expr):print an expression in LISP-format:
:FuncList:FuncList(expr):list of functions used in an expression:
:FuncListArith:FuncListArith(expr):list of functions used in an expression:
:FuncListSome:FuncListSome(expr, list):list of functions used in an expression:
:Function:Function("op", {arglist, ...}) body::
:Function:Function("op", {arglist}) body::
:Function:Function() func(arglist):declare or define a function:
:Function:Function() func(arglist, ...)::
:Gamma:Gamma(x):Euler's Gamma function:
:GarbageCollect:GarbageCollect():do garbage collection on unused memory:
:GaussianFactors:GaussianFactors(z):factorization in Gaussian integers:
:GaussianGcd:GaussianGcd(z,w):greatest common divisor in Gaussian integers:
:GaussianNorm:GaussianNorm(z):norm of a Gaussian integer:
:Gcd:Gcd(list)::
:Gcd:Gcd(n,m):greatest common divisor:
:GenericTypeName:GenericTypeName(object):get type name:
:GetCoreError:GetCoreError():get "hard" error string:
:GetError:GetError("str"):custom errors handlers:
:GetErrorTableau:GetErrorTableau():custom errors handlers:
:GetTime:GetTime(expr):measure the time taken by an evaluation:
:GlobalPop:GlobalPop()::
:GlobalPop:GlobalPop(var):restore variables using a global stack:
:GlobalPush:GlobalPush(expr):save variables using a global stack:
:GoldenRatio:GoldenRatio:the Golden Ratio:
:GreaterThan:GreaterThan(a,b):comparison predicate:
:GuessRational:GuessRational(x):find optimal rational approximations:
:GuessRational:GuessRational(x, digits)::
:HarmonicNumber:HarmonicNumber(n):return the {n}th Harmonic Number:
:HarmonicNumber:HarmonicNumber(n,r)::
:HasExpr:HasExpr(expr, x):check for expression containing a subexpression:
:HasExprArith:HasExprArith(expr, x):check for expression containing a subexpression:
:HasExprSome:HasExprSome(expr, x, list):check for expression containing a subexpression:
:HasFunc:HasFunc(expr, func):check for expression containing a function:
:HasFuncArith:HasFuncArith(expr, func):check for expression containing a function:
:HasFuncSome:HasFuncSome(expr, func, list):check for expression containing a function:
:Head:Head(list):the first element of a list:
:HeapSort:HeapSort(list, compare):sort a list:
:HessianMatrix:HessianMatrix(function,var):create the Hessian matrix:
:HilbertInverseMatrix:HilbertInverseMatrix(n):create a Hilbert inverse matrix:
:HilbertMatrix:HilbertMatrix(n):create a Hilbert matrix:
:HilbertMatrix:HilbertMatrix(n,m)::
:Hold:Hold(expr):keep expression unevaluated:
:HoldArg:HoldArg("operator",parameter):mark argument as not evaluated:
:HoldArgNr:HoldArgNr("function", arity, argNum):specify argument as not evaluated:
:Horner:Horner(expr, var):convert a polynomial into the Horner form:
:I:I:imaginary unit:
:Identity:Identity(n):make identity matrix:
:If:If(pred, then):branch point:
:If:If(pred, then, else)::
:Im:Im(x):imaginary part of a complex number:
:InNumericMode:InNumericMode():determine if currently in numeric mode:
:InProduct:InProduct(a,b):inner product of vectors (deprecated):
:InVerboseMode:InVerboseMode():set verbose output mode:
:Infinity:Infinity:constant representing mathematical infinity:
:Infix:Infix("op"):define function syntax (infix operator):
:Infix:Infix("op", precedence)::
:Insert:Insert(list, n, expr):insert an element into a list:
:IntLog:IntLog(n, base):integer part of logarithm:
:IntNthRoot:IntNthRoot(x, n):integer part of $n$-th root:
:IntPowerNum:IntPowerNum(x, n, mult, unity):optimized computation of integer powers:
:Integrate:Integrate(var) expr::
:Integrate:Integrate(var, x1, x2) expr:integration:
:Intersection:Intersection(l1, l2):return the intersection of two lists:
:Inverse:Inverse(M):get inverse of a matrix:
:InverseTaylor:InverseTaylor(var, at, order) expr:Taylor expansion of inverse:
:IsAmicablePair:IsAmicablePair(m,n):test for a pair of amicable numbers:
:IsAtom:IsAtom(expr):test for an atom:
:IsBodied:IsBodied("op"):check for function syntax:
:IsBoolean:IsBoolean(expression):test for a Boolean value:
:IsBound:IsBound(var):test for a bound variable:
:IsCFormable:IsCFormable(expr):check possibility to export expression to C++ code:
:IsCFormable:IsCFormable(expr, funclist)::
:IsCarmichaelNumber:IsCarmichaelNumber(n):test for a Carmichael number:
:IsComposite:IsComposite(n):test for a composite number:
:IsConstant:IsConstant(expr):test for a constant:
:IsCoprime:IsCoprime(list)::
:IsCoprime:IsCoprime(m,n):test if integers are coprime :
:IsDiagonal:IsDiagonal(A):test for a diagonal matrix:
:IsError:IsError("str")::
:IsError:IsError():check for custom error:
:IsEven:IsEven(n):test for an even integer:
:IsEvenFunction:IsEvenFunction(expression,variable):Return true if function is an even function, False otherwise:
:IsFreeOf:IsFreeOf(var, expr):test whether expression depends on variable:
:IsFreeOf:IsFreeOf({var, ...}, expr)::
:IsFunction:IsFunction(expr):test for a composite object:
:IsGaussianInteger:IsGaussianInteger(z):test for a Gaussian integer:
:IsGaussianPrime:IsGaussianPrime(z):test for a Gaussian prime:
:IsGaussianUnit:IsGaussianUnit(z):test for a Gaussian unit:
:IsGeneric:IsGeneric(object):check for generic object:
:IsHermitian:IsHermitian(A):test for a Hermitian matrix:
:IsIdempotent:IsIdempotent(A):test for an idempotent matrix:
:IsInfinity:IsInfinity(expr):test for an infinity:
:IsInfix:IsInfix("op"):check for function syntax:
:IsIrregularPrime:IsIrregularPrime(n):test for an irregular prime:
:IsList:IsList(expr):test for a list:
:IsLowerTriangular:IsLowerTriangular(A):test for a lower triangular matrix:
:IsMatrix:IsMatrix(expr):test for a matrix:
:IsMatrix:IsMatrix(pred,expr)::
:IsNegativeInteger:IsNegativeInteger(n):test for a negative integer:
:IsNegativeNumber:IsNegativeNumber(n):test for a negative number:
:IsNegativeReal:IsNegativeReal(expr):test for a numerically negative value:
:IsNonObject:IsNonObject(expr):test whether argument is not an {Object()}:
:IsNonZeroInteger:IsNonZeroInteger(n):test for a nonzero integer:
:IsNotZero:IsNotZero(n):test for a nonzero number:
:IsNumber:IsNumber(expr):test for a number:
:IsNumericList:IsNumericList({list}):test for a list of numbers:
:IsOdd:IsOdd(n):test for an odd integer:
:IsOddFunction:IsOddFunction(expression,variable):Return true if function is an odd function, False otherwise:
:IsOrthogonal:IsOrthogonal(A):test for an orthogonal matrix:
:IsPositiveInteger:IsPositiveInteger(n):test for a positive integer:
:IsPositiveNumber:IsPositiveNumber(n):test for a positive number:
:IsPositiveReal:IsPositiveReal(expr):test for a numerically positive value:
:IsPostfix:IsPostfix("op"):check for function syntax:
:IsPrefix:IsPrefix("op"):check for function syntax:
:IsPrime:IsPrime(n):test for a prime number:
:IsPrimePower:IsPrimePower(n):test for a power of a prime number:
:IsPromptShown:IsPromptShown():test for the Yacas prompt option:
:IsQuadraticResidue:IsQuadraticResidue(m,n):functions related to finite groups:
:IsRational:IsRational(expr):test whether argument is a rational:
:IsScalar:IsScalar(expr):test for a scalar:
:IsSkewSymmetric:IsSkewSymmetric(A):test for a skew-symmetric matrix:
:IsSmallPrime:IsSmallPrime(n):test for a (small) prime number:
:IsSquareFree:IsSquareFree(n):test for a square-free number:
:IsSquareMatrix:IsSquareMatrix(expr):test for a square matrix:
:IsSquareMatrix:IsSquareMatrix(pred,expr)::
:IsString:IsString(expr):test for an string:
:IsSymmetric:IsSymmetric(A):test for a symmetric matrix:
:IsTwinPrime:IsTwinPrime(n):test for a twin prime:
:IsUnitary:IsUnitary(A):test for a unitary matrix:
:IsUpperTriangular:IsUpperTriangular(A):test for an upper triangular matrix:
:IsVector:IsVector(expr):test for a vector:
:IsVector:IsVector(pred,expr)::
:IsZero:IsZero(n):test whether argument is zero:
:IsZeroVector:IsZeroVector(list):test whether list contains only zeroes:
:JacobiSymbol:JacobiSymbol(m,n):functions related to finite groups:
:JacobianMatrix:JacobianMatrix(functions,variables):calculate the Jacobian matrix of $n$ functions in $n$ variables:
:KnownFailure:KnownFailure(test):Mark a test as a known failure:
:LagrangeInterpolant:LagrangeInterpolant(xlist, ylist, var):polynomial interpolation:
:LambertW:LambertW(x):Lambert's $W$ function:
:LaplaceTransform:LaplaceTransform(t,s,func)	:Laplace Transform:
:Lcm:Lcm(list)::
:Lcm:Lcm(n,m):least common multiple:
:LeadingCoef:LeadingCoef(poly):leading coefficient of a polynomial:
:LeadingCoef:LeadingCoef(poly, var)::
:LeftPrecedence:LeftPrecedence("op",precedence):set operator precedence:
:LegendreSymbol:LegendreSymbol(m,n):functions related to finite groups:
:Length:Length(object):the length of a list or string:
:LessThan:LessThan(a,b):comparison predicate:
:LeviCivita:LeviCivita(list):totally anti-symmetric Levi-Civita symbol:
:Limit:Limit(var, val) expr:limit of an expression:
:Limit:Limit(var, val, dir) expr::
:LispRead:LispRead():read expressions in LISP syntax:
:LispReadListed:LispReadListed():read expressions in LISP syntax:
:List:List(expr1, expr2, ...):construct a list:
:Listify:Listify(expr):convert a function application to a list:
:Ln:Ln(x):natural logarithm:
:LnCombine:LnCombine(expr):combine logarithmic expressions using standard logarithm rules:
:LnExpand:LnExpand(expr):expand a logarithmic expression using standard logarithm rules:
:Load:Load(name):evaluate all expressions in a file:
:Local:Local(var, ...):declare new local variables:
:LocalSymbols:LocalSymbols(var1, var2, ...) body:create unique local symbols with given prefix:
:LogicTest:LogicTest(variables,expr1,expr2):verifying equivalence of two expressions:
:LogicVerify:LogicVerify(question,answer):verifying equivalence of two expressions:
:Macro:Macro("op", {arglist, ...}) body::
:Macro:Macro("op", {arglist}) body::
:Macro:Macro() func(arglist):declare or define a macro:
:Macro:Macro() func(arglist, ...)::
:MakeVector:MakeVector(var,n):vector of uniquely numbered variable names:
:Map:Map(fn, list):apply an $n$-ary function to all entries in a list:
:MapArgs:MapArgs(expr, fn):apply a function to all top-level arguments:
:MapSingle:MapSingle(fn, list):apply a unary function to all entries in a list:
:MatchLinear:MatchLinear(x,expr):match an expression to a polynomial of degree one in a variable:
:MathAbs:MathAbs(x)     (absolute value of x, or |x| )::
:MathAdd:MathAdd(x,y)      (add two numbers)::
:MathAnd:MathAnd(...):built-in logical "and":
:MathArcCos:MathArcCos(x)   (inverse cosine)::
:MathArcCosh:MathArcCosh(x)  (inverse hyperbolic cosine)::
:MathArcSin:MathArcSin(x)   (inverse sine)::
:MathArcSinh:MathArcSinh(x)  (inverse hyperbolic sine)::
:MathArcTan:MathArcTan(x)   (inverse tangent)::
:MathArcTanh:MathArcTanh(x)  (inverse hyperbolic tangent)::
:MathCeil:MathCeil(x)    (smallest integer not smaller than x)::
:MathCos:MathCos(x)     (cosine)::
:MathCosh:MathCosh(x)     (hyperbolic cosine)::
:MathDiv:MathDiv(x,y)    (integer division, result is an integer)::
:MathDivide:MathDivide(x,y)   (divide two numbers)::
:MathExp:MathExp(x)     (exponential, base 2.718...)::
:MathFloor:MathFloor(x)   (largest integer not larger than x)::
:MathGcd:MathGcd(n,m)      (Greatest Common Divisor)::
:MathGetExactBits:MathGetExactBits(x):manipulate precision of floating-point numbers:
:MathLog:MathLog(x)     (natural logarithm, for x>0)::
:MathMod:MathMod(x,y)    (remainder of division, or x mod y)::
:MathMultiply:MathMultiply(x,y) (multiply two numbers)::
:MathNot:MathNot(expression):built-in logical "not":
:MathOr:MathOr(...):built-in logical "or":
:MathPower:MathPower(x,y) (power, x ^ y)::
:MathSetExactBits:MathSetExactBits(x,bits):manipulate precision of floating-point numbers:
:MathSin:MathSin(x)     (sine)::
:MathSinh:MathSinh(x)     (hyperbolic sine)::
:MathSqrt:MathSqrt(x)    (square root, must be x>=0)::
:MathSubtract:MathSubtract(x,y) (subtract two numbers)::
:MathTan:MathTan(x)     (tangent)::
:MathTanh:MathTanh(x)     (hyperbolic tangent)::
:MatrixPower:MatrixPower(mat,n):get nth power of a square matrix:
:MatrixSolve:MatrixSolve(A,b):solve a system of equations:
:Max:Max(list)::
:Max:Max(x,y):maximum of a number of values:
:MaxEvalDepth:MaxEvalDepth(n):set the maximum evaluation depth:
:MaximumBound:MaximumBound(p):return upper bounds on the absolute values of real roots of a polynomial:
:Min:Min(list)::
:Min:Min(x,y):minimum of a number of values:
:MinimumBound:MinimumBound(p):return lower bounds on the absolute values of real roots of a polynomial:
:Minor:Minor(M,i,j):get principal minor of a matrix:
:Mod:Mod(x,y):Determine remainder of two mathematical objects after dividing one by the other:
:Moebius:Moebius(n):the Moebius function:
:MoebiusDivisorsList:MoebiusDivisorsList(n):the list of divisors and Moebius values:
:Monic:Monic(poly):monic part of a polynomial:
:Monic:Monic(poly, var)::
:MultiplyNum:MultiplyNum(x,y):optimized numerical multiplication:
:MultiplyNum:MultiplyNum(x,y,z,...)::
:MultiplyNum:MultiplyNum({x,y,z,...})::
:N:N(expression):try determine numerical approximation of expression:
:N:N(expression, precision)::
:NFunction:NFunction("newname","funcname", {arglist}):make wrapper for numeric functions:
:NearRational:NearRational(x):find optimal rational approximations:
:NearRational:NearRational(x, digits)::
:NewLine:NewLine():print one or more newline characters:
:NewLine:NewLine(nr)::
:Newton:Newton(expr, var, initial, accuracy):solve an equation numerically with Newton's method:
:Newton:Newton(expr, var, initial, accuracy,min,max)::
:NewtonNum:NewtonNum(func, x0)::
:NewtonNum:NewtonNum(func, x0, prec0)::
:NewtonNum:NewtonNum(func, x0, prec0, order):low-level optimized Newton's iterations:
:NextPrime:NextPrime(i):generate a prime following a number:
:Nl:Nl():the newline character:
:NonN:NonN(expr):calculate part in non-numeric mode:
:Normalize:Normalize(v):normalize a vector:
:Not:Not expr:logical negation:
:NrArgs:NrArgs(expr):return number of top-level arguments:
:Nth:Nth(list, n):return the $n$-th element of a list:
:NthRoot:NthRoot(m,n):calculate/simplify nth root of an integer:
:NumRealRoots:NumRealRoots(p):return the number of real roots of a polynomial:
:Numer:Numer(expr):numerator of an expression:
:OMDef:OMDef(yacasForm, cd, name):define translations from Yacas to OpenMath and vice-versa.:
:OMDef:OMDef(yacasForm, cd, name, yacasToOM)::
:OMDef:OMDef(yacasForm, cd, name, yacasToOM, omToYacas)::
:OMForm:OMForm(expression):convert Yacas expression to OpenMath:
:OMRead:OMRead():convert expression from OpenMath to Yacas expression:
:Object:Object("pred", exp):create an incomplete type:
:OdeOrder:OdeOrder(eqn):return order of an ODE:
:OdeSolve:OdeSolve(expr1==expr2):general ODE solver:
:OdeTest:OdeTest(eqn,testsol):test the solution of an ODE:
:OldSolve:OldSolve(eq, var):old version of {Solve}:
:OldSolve:OldSolve(eqlist, varlist)::
:OpLeftPrecedence:OpLeftPrecedence("op"):get operator precedence:
:OpPrecedence:OpPrecedence("op"):get operator precedence:
:OpRightPrecedence:OpRightPrecedence("op"):get operator precedence:
:OrthoG:OrthoG(n, a, x);:Gegenbauer orthogonal polynomials:
:OrthoGSum:OrthoGSum(c, a, x);:sums of series of orthogonal polynomials:
:OrthoH:OrthoH(n, x);:Hermite orthogonal polynomials:
:OrthoHSum:OrthoHSum(c, x);:sums of series of orthogonal polynomials:
:OrthoL:OrthoL(n, a, x);:Laguerre orthogonal polynomials:
:OrthoLSum:OrthoLSum(c, a, x);:sums of series of orthogonal polynomials:
:OrthoP:OrthoP(n, a, b, x);::
:OrthoP:OrthoP(n, x);:Legendre and Jacobi orthogonal polynomials:
:OrthoPSum:OrthoPSum(c, a, b, x);::
:OrthoPSum:OrthoPSum(c, x);:sums of series of orthogonal polynomials:
:OrthoPoly:OrthoPoly(name, n, par, x):internal function for constructing orthogonal polynomials:
:OrthoPolySum:OrthoPolySum(name, c, par, x):internal function for computing series of orthogonal polynomials:
:OrthoT:OrthoT(n, x);:Chebyshev polynomials:
:OrthoTSum:OrthoTSum(c, x);:sums of series of orthogonal polynomials:
:OrthoU:OrthoU(n, x);:Chebyshev polynomials:
:OrthoUSum:OrthoUSum(c, x);:sums of series of orthogonal polynomials:
:OrthogonalBasis:OrthogonalBasis(W):create an orthogonal basis :
:OrthonormalBasis:OrthonormalBasis(W):create an orthonormal basis :
:Outer:Outer(t1,t2):get outer tensor product:
:PAdicExpand:PAdicExpand(n, p):p-adic expansion:
:PDF:PDF(dist,x):probability density function:
:PSolve:PSolve(poly, var):solve a polynomial equation:
:Partition:Partition(list, n):partition a list in sublists of equal length:
:PatchLoad:PatchLoad(name):execute commands between {} in file:
:PatchString:PatchString(string):execute commands between {} in strings:
:Permutations:Permutations(list):get all permutations of a list:
:Pi:Pi:mathematical constant, $pi$:
:Plot2D:Plot2D(f(x)):adaptive two-dimensional plotting:
:Plot2D:Plot2D(f(x), a b)::
:Plot2D:Plot2D(f(x), a b, option=value)::
:Plot2D:Plot2D(f(x), a b, option=value, ...)::
:Plot2D:Plot2D(list, ...)::
:Plot3DS:Plot3DS(f(x,y)):three-dimensional (surface) plotting:
:Plot3DS:Plot3DS(f(x,y), a b, c d)::
:Plot3DS:Plot3DS(f(x,y), a b, c d, option=value)::
:Plot3DS:Plot3DS(f(x,y), a b, c d, option=value, ...)::
:Plot3DS:Plot3DS(list, ...)::
:Pop:Pop(stack, n):remove an element from a stack:
:PopBack:PopBack(stack):remove an element from the bottom of a stack:
:PopFront:PopFront(stack):remove an element from the top of a stack:
:Postfix:Postfix("op"):define function syntax (postfix operator):
:Postfix:Postfix("op", precedence)::
:Prefix:Prefix("op"):define function syntax (prefix operator):
:Prefix:Prefix("op", precedence)::
:PrettyForm:PrettyForm(expr):print an expression nicely with ASCII art:
:PrimitivePart:PrimitivePart(expr):primitive part of a univariate polynomial:
:PrintList:PrintList(list):print list with padding:
:PrintList:PrintList(list, padding);::
:Prog:Prog(statement1, statement2, ...):block of statements:
:ProperDivisors:ProperDivisors(n):the number of proper divisors:
:ProperDivisorsSum:ProperDivisorsSum(n):the sum of proper divisors:
:Pslq:Pslq(xlist,precision):search for integer relations between reals:
:Push:Push(stack, expr):add an element on top of a stack:
:RadSimp:RadSimp(expr):simplify expression with nested radicals:
:RamanujanSum:RamanujanSum(k,n):compute the "Ramanujan sum":
:RandVerifyArithmetic:RandVerifyArithmetic(n):Special purpose arithmetic verifiers:
:Random:Random():(pseudo-) random number generator:
:RandomIntegerMatrix:RandomIntegerMatrix(rows,cols,from,to):generate a matrix of random integers:
:RandomIntegerVector:RandomIntegerVector(nr, from, to):generate a vector of random integers:
:RandomPoly:RandomPoly(var,deg,coefmin,coefmax):construct a random polynomial:
:RandomSeed:RandomSeed(init):(pseudo-) random number generator:
:Rationalize:Rationalize(expr):convert floating point numbers to fractions:
:Re:Re(x):real part of a complex number:
:Read:Read():read an expression from current input:
:ReadCmdLineString:ReadCmdLineString(prompt):read an expression from command line and return in string:
:ReadToken:ReadToken():read a token from current input:
:RemoveDuplicates:RemoveDuplicates(list):remove any duplicates from a list:
:Replace:Replace(list, n, expr):replace an entry in a list:
:Retract:Retract("function",arity):erase rules for a function:
:Reverse:Reverse(list):return the reversed list (without touching the original):
:ReversePoly:ReversePoly(f, g, var, newvar, degree):solve $h(f(x)) = g(x) + O(x^n)$ for $h$:
:RightAssociative:RightAssociative("op"):declare associativity:
:RightPrecedence:RightPrecedence("op",precedence):set operator precedence:
:Rng:Rng(r):manipulate random number generators as objects:
:RngCreate:RngCreate():manipulate random number generators as objects:
:RngCreate:RngCreate(init)::
:RngCreate:RngCreate(option==value,...)::
:RngSeed:RngSeed(r, init):manipulate random number generators as objects:
:Round:Round(x):round a number to the nearest integer:
:RoundTo:RoundTo(number,precision):Round a real-valued result to a set number of digits:
:Rule:Rule("operator", arity,:define a rewrite rule:
:RuleBase:RuleBase(name,params):define function with a fixed number of arguments:
:RuleBaseArgList:RuleBaseArgList("operator", arity):obtain list of arguments:
:RuleBaseListed:RuleBaseListed("name", params):define function with variable number of arguments:
:Secure:Secure(body):guard the host OS:
:Select:Select(pred, list):select entries satisfying some predicate:
:Set:Set(var, exp):assignment:
:SetGlobalLazyVariable:SetGlobalLazyVariable(var,value):global variable is to be evaluated lazily:
:ShiftLeft:ShiftLeft(expr,bits)::
:ShiftRight:ShiftRight(expr,bits)::
:Sign:Sign(x):sign of a number:
:Simplify:Simplify(expr):try to simplify an expression:
:Sin:Sin(x):trigonometric sine function:
:Solve:Solve(eq, var):solve an equation:
:SolveMatrix:SolveMatrix(M,v):solve a linear system:
:Space:Space():print one or more spaces:
:Space:Space(nr)::
:Sparsity:Sparsity(matrix):get the sparsity of a matrix:
:Sqrt:Sqrt(x):square root:
:SquareFree:SquareFree(p):return the square-free part of polynomial:
:SquareFreeDivisorsList:SquareFreeDivisorsList(n):the list of square-free divisors:
:StirlingNumber1:StirlingNumber1(n,m):return the {n,m}th Stirling Number of the first kind:
:String:String(atom):convert atom to string:
:StringMid'Get:StringMid'Get(index,length,string):retrieve a substring:
:StringMid'Set:StringMid'Set(index,substring,string):change a substring:
:Subfactorial:Subfactorial(m):factorial and related functions:
:Subst:Subst(from, to) expr:perform a substitution:
:SuchThat:SuchThat(expr, var):special purpose solver:
:Sum:Sum(var, from, to, body):find sum of a sequence:
:SumForDivisors:SumForDivisors(var,n,expr):loop over divisors:
:SumTaylorNum:SumTaylorNum(x, NthTerm, TermFactor, order)::
:SumTaylorNum:SumTaylorNum(x, NthTerm, order):optimized numerical evaluation of Taylor series:
:SumTaylorNum:SumTaylorNum(x, ZerothTerm, TermFactor, order)::
:Swap:Swap(list, i1, i2):swap two elements in a list:
:SylvesterMatrix:SylvesterMatrix(poly1,poly2,variable):calculate the Sylvester matrix of two polynomials:
:SystemCall:SystemCall(str):pass a command to the shell:
:Table:Table(body, var, from, to, step):evaluate while some variable ranges over interval:
:TableForm:TableForm(list):print each entry in a list on a line:
:Tail:Tail(list):returns a list without its first element:
:Take:Take(list, -n)::
:Take:Take(list, n):take a sublist from a list, dropping the rest:
:Take:Take(list, {m,n})::
:Tan:Tan(x):trigonometric tangent function:
:Taylor:Taylor(var, at, order) expr:univariate Taylor series expansion:
:TeXForm:TeXForm(expr):export expressions to $LaTeX$:
:TestYacas:TestYacas(question,answer):verifying equivalence of two expressions:
:Time:Time(expr):measure the time taken by a function:
:ToBase:ToBase(base, number):conversion of a number in decimal base to non-decimal base:
:ToFile:ToFile(name) body:connect current output to a file:
:ToStdout:ToStdout() body:select initial output stream for output:
:ToString:ToString() body:connect current output to a string:
:ToeplitzMatrix:ToeplitzMatrix(N):create a Toeplitz matrix:
:Trace:Trace(M):trace of a matrix:
:TraceExp:TraceExp(expr):evaluate with tracing enabled:
:TraceRule:TraceRule(template) expr:turn on tracing for a particular function:
:TraceStack:TraceStack(expression):show calling stack after an error occurs:
:Transpose:Transpose(M):get transpose of a matrix:
:TrapError:TrapError(expression,errorHandler):trap "hard" errors:
:TrigSimpCombine:TrigSimpCombine(expr):combine products of trigonometric functions:
:True:True:boolean constant representing true:
:TruncRadian:TruncRadian(r):remainder modulo $2*Pi$:
:Type:Type(expr):return the type of an expression:
:UnFence:UnFence("operator",arity):change local variable scope for a function:
:UnFlatten:UnFlatten(list,operator,identity):inverse operation of Flatten:
:UnList:UnList(list):convert a list to a function application:
:Undefined:Undefined:constant signifying an undefined result:
:Union:Union(l1, l2):return the union of two lists:
:UniqueConstant:UniqueConstant():create a unique identifier:
:Until:Until(pred) body:loop until a condition is met:
:Use:Use(name):load a file, but not twice:
:V:V(expression):set verbose output mode:
:VandermondeMatrix:VandermondeMatrix(vector):create the Vandermonde matrix:
:VarList:VarList(expr):list of variables appearing in an expression:
:VarListArith:VarListArith(expr):list of variables appearing in an expression:
:VarListSome:VarListSome(expr, list):list of variables appearing in an expression:
:Verify:Verify(question,answer):verifying equivalence of two expressions:
:VerifyArithmetic:VerifyArithmetic(x,n,m):Special purpose arithmetic verifiers:
:VerifyDiv:VerifyDiv(u,v):Special purpose arithmetic verifiers:
:While:While(pred) body:loop while a condition is met:
:WithValue:WithValue(var, val, expr):temporary assignment during an evaluation:
:WithValue:WithValue({var,...}, {val,...}, expr)::
:Write:Write(expr, ...):low-level printing routine:
:WriteString:WriteString(string):low-level printing routine for strings:
:WronskianMatrix:WronskianMatrix(func,var):create the Wronskian matrix:
:XmlExplodeTag:XmlExplodeTag(xmltext):convert XML strings to tag objects:
:XmlTokenizer:XmlTokenizer():select an XML syntax tokenizer for parsing the input:
:ZeroMatrix:ZeroMatrix(n):make a zero matrix:
:ZeroMatrix:ZeroMatrix(n, m)::
:ZeroVector:ZeroVector(n):create a vector with all zeroes:
:Zeta:Zeta(x):Riemann's Zeta function:
:::::::
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ViewPanel.java0000644000175000017500000000021311341703727027646 0ustar  giovannigiovanni
package org.mathpiper.ui.gui.worksheets;


public interface ViewPanel {

    void setViewScale(double viewScale);

    void repaint();

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/MathPiperGraphicsContext.java0000644000175000017500000000472411131060345032673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets;


import java.awt.*; 

public class MathPiperGraphicsContext
{
	Graphics graphics;
	int xtop;
	int ytop;
	
	public MathPiperGraphicsContext(Graphics g,int x, int y)
	{
		graphics = g;
		xtop = x;
		ytop = y;
	}

	public void setColor(int red, int green, int blue)
	{
		graphics.setColor(new Color(red,green,blue));
	}
	
	public void drawText(int x, int y, String text)
	{
		graphics.drawString(text,x+xtop,y+ytop);
	}
	
	public void drawLine(int x0, int y0, int x1, int y1)
	{
		graphics.drawLine(xtop+x0,ytop+y0,xtop+x1,ytop+y1);
	}
	
	public void drawRoundRect(int x,int y, int width, int height, int arc)
	{
		graphics.drawRoundRect(xtop+x,ytop+y,width,height,arc,arc);
	}
	
	public void drawRect(int x,int y, int width, int height)
	{
		graphics.drawRect(xtop+x,ytop+y,width,height);
	}
	
	public void fillRoundRect(int x,int y, int width, int height,int arc)
	{
		graphics.fillRoundRect(xtop+x,ytop+y,width,height,arc,arc);
	}
	
	public void fillRect(int x,int y, int width, int height)
	{
		graphics.fillRect(xtop+x,ytop+y,width,height);
	}
	
	public int fontHeight()
	{
		FontMetrics fontMetrics = graphics.getFontMetrics();
		return fontMetrics.getHeight();
	}
	
	public int fontDescent()
	{
		FontMetrics fontMetrics = graphics.getFontMetrics();
		return fontMetrics.getDescent();
	}
	
	public int textWidthInPixels(String text)
	{
		FontMetrics fontMetrics = graphics.getFontMetrics();
		return fontMetrics.stringWidth(text);
	}
	
	public int setFontSize(int aBold, int aSize)
	{
		if (aBold != 0)
			graphics.setFont(new Font("Helvetica", Font.BOLD, aSize));
		else
			graphics.setFont(new Font("Helvetica", Font.PLAIN, aSize));
		return 1;
	}
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/GrapherApplet.java0000644000175000017500000000617611326263630030525 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets;

import org.mathpiper.ui.gui.worksheets.mathoutputlines.Grapher;
import java.awt.*;
import java.awt.event.*;

public class GrapherApplet extends java.applet.Applet implements KeyListener
{
	Dimension offDimension;
	Image offImage;
	Graphics offGraphics;

	Grapher grapher;

	String iRenderOperations;

	public void init()
	{
		iRenderOperations = getParameter("CallList");
		if (iRenderOperations == null)
			iRenderOperations = "";
		grapher = new Grapher(iRenderOperations);
		addKeyListener(this);
		repaint();
	}

	public void	keyReleased(KeyEvent e) {}
	public void	keyTyped(KeyEvent e) {}
	public void keyPressed(KeyEvent e)
	{
		double scf = 1.05;
		switch (e.getKeyChar())
		{
		case 'o':
		case 'O':
			grapher.xmin *= scf;
			grapher.xmax *= scf;
			offImage = null; offGraphics = null; repaint();
			break;
		case 'p':
		case 'P':
			grapher.xmin /= scf;
			grapher.xmax /= scf;
			offImage = null; offGraphics = null; repaint();
			break;

		case 'a':
		case 'A':
			grapher.ymin *= scf;
			grapher.ymax *= scf;
			offImage = null; offGraphics = null; repaint();
			break;
		case 'z':
		case 'Z':
			grapher.ymin /= scf;
			grapher.ymax /= scf;
			offImage = null; offGraphics = null; repaint();
			break;
		}
	}


	public void start()
	{
		repaint();
	}

	public void stop()
	{
		offImage = null;
		offGraphics = null;
	}

	void drawToOffscreen()
	{
		// Create the offscreen graphics context
		Dimension d = getSize();
		if ((offGraphics == null)
		                || (d.width != offDimension.width)
		                || (d.height != offDimension.height))
		{
			offDimension = d;
			offImage = createImage(d.width, d.height);
			offGraphics = offImage.getGraphics();
			paintFrame(offGraphics);
		}
	}
	public void update(Graphics g)
	{
		drawToOffscreen();

		// Paint the frame into the image
		synchronized(offImage)
		{
			// Paint the image onto the screen
			g.drawImage(offImage, 0, 0, null);
		}
	}

	public void paint(Graphics g)
	{
		drawToOffscreen();
		if (offImage != null)
		{
			synchronized(offImage)
			{
				g.drawImage(offImage, 0, 0, null);
			}
		}
	}

	synchronized public void paintFrame(Graphics g)
	{
		Dimension d = getSize();
		grapher.paint(g, 0, 0, d);
	}
};

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ConsolePanel.java0000644000175000017500000014600111422223770030337 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets;

import org.mathpiper.ui.gui.worksheets.hints.Hints;
import org.mathpiper.ui.gui.worksheets.hints.HintWindow;
import org.mathpiper.ui.gui.worksheets.hints.HintItem;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedStringLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.MathOutputLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedGraph2DLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedFormulaLine;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.io.CachedStandardFileInputStream;

import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import java.awt.datatransfer.Clipboard;
import java.awt.datatransfer.ClipboardOwner;
import java.awt.datatransfer.Transferable;
import java.awt.datatransfer.StringSelection;
import java.awt.datatransfer.DataFlavor;
import java.awt.*;
import java.awt.event.*;
import java.io.*;
import java.net.*;
import javax.swing.JPanel;
import org.mathpiper.Version;
import org.mathpiper.interpreters.EvaluationResponse;

public class ConsolePanel extends JPanel implements KeyListener, FocusListener, ClipboardOwner, MouseListener, MouseMotionListener, Console
{

    AppletOutput out;
    boolean focusGained = false;
    boolean scrolling = false;
    int yDown = 0;
    int yStart = 0;
    boolean calculating = false;
    MathPiperOutputStream stdoutput = null;
    Interpreter interpreter = null;
    StringBuffer outputStringBuffer = new StringBuffer();
    boolean gotDatahubInit = false;
    final static int nrLines = 100;
    MathOutputLine lines[] = new MathOutputLine[nrLines];
    int currentLine = 0;
    int totalLinesHeight = 0;
    String inputLine = new String();
    String gatheredMultiLine = new String();
    int cursorPos = 0;
    final int inset = 5;
    final static String inputPrompt = "In> ";
    final static String outputPrompt = "Result: ";
    static final int fontHeight = 14;
    private Font font = new Font("Verdana", Font.PLAIN, fontHeight);
    private static final int nrHistoryLines = 100;
    public static String history[] = new String[nrHistoryLines];
    public static int currentHistoryLine = 0;
    static int historyBrowse = 0;
    boolean inputDirty = true;
    boolean outputDirty = true;
    Image piperLogo = null;
    Image offImg = null;
    Graphics offGra = null;
    Color bkColor = new Color(255, 255, 255);
    HintWindow hintWindow = null;
    Hints the_hints = new Hints();
    boolean thumbMoused = false;
    int scrollWidth = 16;
    int thumbPos = 0;
    String lastMatchedWord = "";
    String matchToInsert = "";
    int ito = -1;
    String lastError;


    public ConsolePanel()
    {

        System.out.println("XXXXX");

    }//end constructor.

    /// Applet initialization
    public void init()
    {
        System.out.println("Initializing.");
        this.setSize(500, 500); //todo:tk:
        
        setBackground(bkColor);
        setLayout(null);
        this.setPreferredSize(new Dimension(500,500));
        this.setFocusable(true);
        requestFocus();
        addKeyListener(this);
        addFocusListener(this);
        addMouseListener(this);
        addMouseMotionListener(this);

        out = new AppletOutput(this);
        resetInput();

        //String hintsfilename = getDocumentBase().toString();
        String hintsfilename = ""; //todo:tk:need to determine path.

        int slash = hintsfilename.lastIndexOf('/');
        if (slash >= 0)
        {
            hintsfilename = hintsfilename.substring(0, slash + 1);
        }
        hintsfilename = hintsfilename + "hints.txt";
        loadHints(hintsfilename);
    }

    public void focusGained(FocusEvent evt)
    {
     System.out.println("FocusedGained.");
        focusGained = true;
        inputDirty = true;
        outputDirty = true;
        if (!gotDatahubInit)
        {
            start();
        }
        repaint();
    }

    public void focusLost(FocusEvent evt)
    {
     System.out.println("FocusedLost.");
        focusGained = false;
        inputDirty = true;
        outputDirty = true;
        repaint();
    }

    public void mouseClicked(MouseEvent event)
    {
    }

    public void mouseEntered(MouseEvent event)
    {
        requestFocusInWindow();
    }

    public void mouseExited(MouseEvent event)
    {
    }

    public void mousePressed(MouseEvent event)
    {
     System.out.println("MousePressed.");
     
        scrolling = false;
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (canvasHeight < totalLinesHeight)
        {
            int x = event.getX();
            int y = event.getY();
            if (x > w - scrollWidth && y < canvasHeight)
            {

                if (y >= thumbPos + 2 && y <= thumbPos + 2 + th)
                {
                    yDown = y;
                    yStart = thumbPos;
                } else
                {
                    thumbPos = y - 2;
                    clipThumbPos();
                }
                scrolling = true;
                thumbMoused = true;
                outputDirty = true;
                repaint();
            }
        }
    }

    public void mouseReleased(MouseEvent event)
    {
        System.out.println("MouseReleased.");
        if (scrolling)
        {
            scrolling = false;
            return;
        } else if (hintWindow != null)
        {
            if (matchToInsert.length() > 0)
            {
                inputLine = inputLine.substring(0, ito) + matchToInsert + inputLine.substring(ito, inputLine.length());
                cursorPos += matchToInsert.length();
                refreshHintWindow();
                repaint();
                return;
            }
        }
    }

    public void mouseMoved(MouseEvent event)
    {
        System.out.println("MouseMoved.");
        boolean newthumbMoused = false;
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (canvasHeight < totalLinesHeight)
        {
            int x = event.getX();
            int y = event.getY();
            if (x > getWidth() - scrollWidth && y < canvasHeight)
            {
                newthumbMoused = true;
            }
        }
        if (thumbMoused != newthumbMoused)
        {
            thumbMoused = newthumbMoused;
            outputDirty = true;
            repaint();
        }
    }

    void clipThumbPos()
    {
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        if (thumbPos < 0)
        {
            thumbPos = 0;
        }
        if (thumbPos > canvasHeight - th - 4)
        {
            thumbPos = canvasHeight - th - 4;
        }
    }

    public void mouseDragged(MouseEvent event)
    {
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (scrolling)
        {
            int x = event.getX();
            int y = event.getY();
            thumbPos = yStart + (y - yDown);
            clipThumbPos();
            outputDirty = true;
            repaint();
        }
    }

    public void lostOwnership(Clipboard clipboard, Transferable contents)
    {
    }

    public void start()
    {
        clearOutputLines();
        if (false /*TODO remove loading the logo piperLogo == null*/)
        {
            try
            {
                //String fname = getDocumentBase().toString();
                String fname = ""; //todo:tk:need to deterrmine path.
                int ind = fname.lastIndexOf("/");
                if (ind > 0)
                {
                    fname = fname.substring(0, ind + 1) + "piper.gif";
                    //piperLogo = getImage(new URL(fname)); //todo
                }
            } catch (Exception e)
            {
            }
        }



        //String docBase = getDocumentBase().toString();
        String docBase = ""; //todo:tk.
        //interpreter = Interpreters.getSynchronousInterpreter(docBase); //todo:tk.
        interpreter = Interpreters.getSynchronousInterpreter();

        interpreter.getEnvironment().iCurrentInput = new CachedStandardFileInputStream(interpreter.getEnvironment().iInputStatus);


        if (piperLogo != null)
        {
            //addLine(new ImageLine(piperLogo, this)); //todo:tk.
        }
        {
            String s = null;
            int bkred = 255;
            int bkgrn = 255;
            int bkblu = 255;
            //s = getParameter("bkred"); //todo:tk.
            if (s != null)
            {
                bkred = Integer.parseInt(s);
            }
            //s = getParameter("bkgrn");  //todo:tk.
            if (s != null)
            {
                bkgrn = Integer.parseInt(s);
            }
            //s = getParameter("bkblu");  //todo:tk.
            if (s != null)
            {
                bkblu = Integer.parseInt(s);
            }
            bkColor = new Color(bkred, bkgrn, bkblu);
            setBackground(bkColor);
        }
        {



            Font font = new Font("helvetica", Font.PLAIN, 12);
            Color c = new Color(96, 96, 96);

            addLineStatic(100, "", "", font, c);
            addLineStatic(100, "", "", font, c);
            addLineStatic(100, "", "MathPiper version '" + Version.version + "'.", font, c);
            addLineStatic(100, "", "Type 'restart' to restart MathPiper, or 'cls' to clear screen.\n", font, c);
            addLineStatic(100, "", "To see example commands, keep typing 'Example();'\n", font, c);
        }
        /*{
            String docbase = getDocumentBase().toString();

            if (docbase.substring(0, 4).equals("file"))
            {
                int pos = docbase.lastIndexOf("/");
                String zipFileName = docbase.substring(0, pos + 1) + "mathpiper.jar";
                zipFileName = "file://" + zipFileName.substring(5,zipFileName.length());
                if (getParameter("debug") != null)
                {
                    AddLineStatic(100, "", " '" + zipFileName + "'.", font, Color.red);
                }
               try
                {
                    java.util.zip.ZipFile z = new java.util.zip.ZipFile(new File(new java.net.URI(zipFileName)));
                    UtilityFunctions.zipFile = z;
                } catch (Exception e)
                {
                    out.println("Failed to find mathpiper.jar");
                    out.println("" + zipFileName + " : \n");
                    out.println(e.toString());
                }
            }
            if (docbase.startsWith("http"))
            {
                //jar:http://www.xs4all.nl/~apinkus/interpreter.jar!/
                int pos = docbase.lastIndexOf("/");
                String scriptBase = "jar:" + docbase.substring(0, pos + 1) + "mathpiper.jar!/";
                if (getParameter("debug") != null)
                {
                    AddLineStatic(100, "", " '" + scriptBase + "'.", font, Color.red);
                }

                interpreter.evaluate("DefaultDirectory(\"" + scriptBase + "\");");
            }
        }*/

        try
        {
            out.println("");
        } catch (Exception e)
        {
            out.println(e);
        }

        //This is where the initialization parameters from the browser are initialized. tk.
        int i = 1;
        while (true)
        {
            String argn = "init" + i;

            //String s = getParameter(argn);
            String s = null; //todo:tk.

            if (s == null)
            {
                break;
            }
            s = unescape(s);

            EvaluationResponse response = interpreter.evaluate(s);

            i++;
        }

        gotDatahubInit = false;
        tryInitThroughDatahub();

        i = 1;
        while (true)
        {
            String argn = "history" + i;

            //String s = getParameter(argn);
            String s = null; //todo:tk.

            if (s == null)
            {
                break;
            }
            s = unescape(s);
            appendHistoryLine(s);
            i++;
        }

        resetInput();
    }

    void tryInitThroughDatahub()
    {
        /*if (!gotDatahubInit)
        {
            //programMode browser parameter is used here. tk.

            //String programMode = getParameter("programMode");
            String programMode = null;

            if (programMode == null)
            {
                gotDatahubInit = true;
            } else
            {
                try
                {
                    Applet dataHub = getAppletContext().getApplet("datahub");
                    if (dataHub != null)
                    {
                        org.mathpiper.ui.gui.applets.storage.DatahubApplet cons = (org.mathpiper.ui.gui.applets.storage.DatahubApplet) dataHub;
                        cons.setProgramMode(programMode);

                        String programContentsToLoad = "[" + cons.getProgram() + "];";
                        gotDatahubInit = true; // We're already satisfied here, as we got the contents from the datahub.
                        invokeCalculationSilent(programContentsToLoad);
                    }
                } catch (Exception e)
                {
                }
            }
        }//end if.*/
    }

    public void stop()
    {
    }

    public void appendHistoryLine(String line)
    {
        //TODO optimize! We need to wrap around the history buffer, this is inefficient.
        if (currentHistoryLine == nrHistoryLines)
        {
            int i;
            for (i = 0; i < currentHistoryLine - 1; i++)
            {
                history[i] = history[i + 1];
            }
            currentHistoryLine--;
        }
        history[currentHistoryLine] = line;
        currentHistoryLine++;
    }

    private String unescape(String s)
    {
        StringBuffer buf = new StringBuffer();
        int i, nr = s.length();
        for (i = 0; i < nr; i++)
        {
            if (s.charAt(i) == '\'' && s.charAt(i + 1) == '\'')
            {
                buf.append('\"');
                i++;
            } else
            {
                buf.append(s.charAt(i));
            }
        }
        return buf.toString();
    }

    public void resetInput()
    {
        if (inputLine.length() > 0)
        {
            if (inputLine.charAt(inputLine.length() - 1) != '\\')
            {
                gatheredMultiLine = "";
            }
        }
        inputLine = "";
        cursorPos = 0;
        historyBrowse = currentHistoryLine;
        inputDirty = true;
    }

    /// Applet destruction
    public void destroy()
    {
    }

    public void keyPressed(KeyEvent e)
    {
        System.out.println("KeyPressed.");
        processKeyEvent(e);
    }

    public void keyTyped(KeyEvent e)
    {
        System.out.println("KeyPressed.");
        //    processKeyEvent(e);
    }

    public void keyReleased(KeyEvent e)
    {
        System.out.println("KeyPressed.");
        //    processKeyEvent(e);
    }

    public void setClipboardContents(String aString)
    {
        StringSelection stringSelection = new StringSelection(aString);
        Clipboard clipboard = Toolkit.getDefaultToolkit().getSystemClipboard();
        clipboard.setContents(stringSelection, this);
    }

    public String getClipboardContents()
    {
        String result = "";
        Clipboard clipboard = Toolkit.getDefaultToolkit().getSystemClipboard();
        //odd: the Object param of getContents is not currently used
        Transferable contents = clipboard.getContents(null);
        boolean hasTransferableText = (contents != null) &&
                contents.isDataFlavorSupported(DataFlavor.stringFlavor);
        if (hasTransferableText)
        {
            try
            {
                result = (String) contents.getTransferData(DataFlavor.stringFlavor);
            } catch (java.awt.datatransfer.UnsupportedFlavorException ex)
            {
                //highly unlikely since we are using a standard DataFlavor
                System.out.println(ex);
            } catch (IOException ex)
            {
                System.out.println(ex);
            }
        }
        return result;
    }

    protected void processKeyEvent(KeyEvent e)
    {
        inputDirty = true;
        if ((e.getModifiers() & InputEvent.CTRL_MASK) == InputEvent.CTRL_MASK)
        {
            if (KeyEvent.KEY_PRESSED != e.getID())
            {
                return;
            }
            if (e.getKeyCode() == (int) 'C')
            {
                //out.println("Copy");
                setClipboardContents(gatheredMultiLine + inputLine);
            } else if (e.getKeyCode() == (int) 'V')
            {
                try
                {
                    String toInsert = getClipboardContents();
                    if (toInsert != null)
                    {
                        int cr = toInsert.indexOf('\n');
                        while (cr >= 0)
                        {
                            inputLine = inputLine + toInsert.substring(0, cr);
                            toInsert = toInsert.substring(cr + 1, toInsert.length());
                            cr = toInsert.indexOf('\n');

                            appendHistoryLine(inputLine);
                            addLinesStatic(48, inputPrompt, inputLine);
                            if (inputLine.charAt(inputLine.length() - 1) == '\\')
                            {
                                gatheredMultiLine = gatheredMultiLine + inputLine.substring(0, inputLine.length() - 1);
                            } else
                            {
                                performRequest("Result: ", gatheredMultiLine + inputLine, true);
                            }
                            resetInput();
                        }
                        inputLine = inputLine + toInsert;
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                } catch (Exception ex)
                {
                }
            } else
            {
                return;
            }
        }

        if (KeyEvent.KEY_PRESSED == e.getID())
        {
            if (e.VK_SHIFT == e.getKeyCode())
            {
                return;
            }
            if (e.VK_CONTROL == e.getKeyCode())
            {
                return;
            }
            if (e.VK_ALT == e.getKeyCode())
            {
                return;
            } else if (e.VK_HOME == e.getKeyCode())
            {
                cursorPos = 0;
            } /*Does not seem to work?
            else if (e.VK_COPY == e.getKeyCode())
            {
            System.out.println("COPY");
            }
            else if (e.VK_PASTE == e.getKeyCode())
            {
            System.out.println("PASTE");
            }
             */ else if (e.VK_END == e.getKeyCode())
            {
                cursorPos = inputLine.length();
            } else if (e.VK_LEFT == e.getKeyCode())
            {
                if (cursorPos > 0)
                {
                    cursorPos--;
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_BACK_SPACE == e.getKeyCode())
            {
                if (cursorPos > 0)
                {
                    cursorPos--;
                    inputLine = new StringBuffer(inputLine).delete(cursorPos, cursorPos + 1).toString();
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_DELETE == e.getKeyCode())
            {
                if (inputLine.length() > 0)
                {
                    if (cursorPos == inputLine.length())
                    {
                        cursorPos--;
                    }
                    inputLine = new StringBuffer(inputLine).delete(cursorPos, cursorPos + 1).toString();
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_ESCAPE == e.getKeyCode())
            {
                if (hintWindow != null)
                {
                    hintWindow = null;
                } else
                {
                    resetInput();
                }
                repaint();
                return;
            } else if (e.VK_UP == e.getKeyCode())
            {
                boolean handled = false;
                if (hintWindow != null)
                {
                    if (hintWindow.iAllowSelection)
                    {
                        handled = true;
                        if (hintWindow.iCurrentPos > 0)
                        {
                            hintWindow.iCurrentPos--;
                            repaint();
                        }
                    }
                }

                if (!handled)
                {
                    handled = true;
                    String prefix = inputLine.substring(0, cursorPos);
                    int i = historyBrowse - 1;
                    while (i > 0)
                    {
                        if (history[i].startsWith(prefix))
                        {
                            break;
                        }
                        i--;
                    }
                    if (i >= 0 && i != historyBrowse && history[i].startsWith(prefix))
                    {
                        historyBrowse = i;
                        inputLine = history[historyBrowse];
                    }
                }
            } else if (e.VK_DOWN == e.getKeyCode())
            {
                boolean handled = false;
                if (hintWindow != null)
                {
                    if (hintWindow.iAllowSelection)
                    {
                        handled = true;
                        if (hintWindow.iCurrentPos < hintWindow.iNrLines - 1)
                        {
                            hintWindow.iCurrentPos++;
                            repaint();
                        }
                    }
                }

                if (!handled)
                {
                    String prefix = inputLine.substring(0, cursorPos);
                    int i = historyBrowse + 1;
                    while (i < currentHistoryLine)
                    {
                        if (history[i].startsWith(prefix))
                        {
                            break;
                        }
                        i++;
                    }
                    if (i < currentHistoryLine && history[i].startsWith(prefix))
                    {
                        historyBrowse = i;
                        inputLine = history[historyBrowse];
                    } else
                    {
                        int pos = cursorPos;
                        resetInput();
                        inputLine = prefix;
                        cursorPos = pos;
                    }
                }
            } else if (e.VK_RIGHT == e.getKeyCode())
            {
                boolean handled = false;

                if (!handled)
                {
                    handled = true;
                    if (cursorPos < inputLine.length())
                    {
                        cursorPos++;
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                }
            } else if (e.VK_ENTER == e.getKeyCode())
            {
                boolean handled = false;

                if (!handled)
                {
                    if (cursorPos == ito && matchToInsert.length() > 0)
                    {
                        //System.out.println("matchToInsert = "+matchToInsert);
                        handled = true;
                        inputLine = inputLine.substring(0, ito) + matchToInsert + inputLine.substring(ito, inputLine.length());
                        cursorPos += matchToInsert.length();
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                }
                if (!handled)
                {
                    if (hintWindow != null)
                    {
                        if (cursorPos == ito && hintWindow.iAllowSelection)
                        {
                            handled = true;
                            String item = hintWindow.iText[hintWindow.iCurrentPos];
                            if (lastMatchedWord.equals(item))
                            {
                                item = "(";
                            } else
                            {
                                item = item.substring(lastMatchedWord.length(), item.length());
                            }
                            inputLine = inputLine.substring(0, ito) + item + inputLine.substring(ito, inputLine.length());
                            cursorPos += item.length();
                            refreshHintWindow();
                            repaint();
                            return;
                        }
                    }
                }
                if (!handled)
                {
                    if (inputLine.length() > 0)
                    {
                        appendHistoryLine(inputLine);
                        addLinesStatic(48, inputPrompt, inputLine);
                        if (inputLine.charAt(inputLine.length() - 1) == '\\')
                        {
                            gatheredMultiLine = gatheredMultiLine + inputLine.substring(0, inputLine.length() - 1);
                        } else
                        {
                            performRequest("Result: ", gatheredMultiLine + inputLine, true);
                        }
                        resetInput();
                        refreshHintWindow();
                        repaint(0);
                    }
                }
            }
            inputDirty = true;
            repaint();
        } else if (KeyEvent.KEY_TYPED == e.getID())
        {
            int c = (int) e.getKeyChar();
            if (c >= 32 && c < 127)
            {
                inputLine = new StringBuffer(inputLine).insert(cursorPos, e.getKeyChar()).toString();
                cursorPos++;
                refreshHintWindow();
                inputDirty = true;
                repaint();
            }
        }
    }

    boolean directCommand(String inputLine)
    {
        if (inputLine.equals("restart"))
        {
            stop();
            start();
            return true;
        } else if (inputLine.equals("cls"))
        {
            clearOutputLines();
            return true;
        }

        /*else if (inputLine.equals(":test"))
        {
            try
            {
                Applet dataHub = getAppletContext().getApplet("datahub");
                if (dataHub != null)
                {
                    org.mathpiper.ui.gui.applets.storage.DatahubApplet cons = (org.mathpiper.ui.gui.applets.storage.DatahubApplet) dataHub;
                    String programContentsToLoad = "[" + cons.getTestcode() + "];";
                    invokeCalculationSilent(programContentsToLoad);
                }
            } catch (Exception e)
            {
            }
            return true;
        } else if (inputLine.equals("?license") || inputLine.equals("?licence") || inputLine.equals("?warranty"))
        {
            try
            {
                getAppletContext().showDocument(new URL("gpl.html"), "license");
            } catch (Exception e)
            {
            }
            return true;
        }*/
        return false;
    }

    void performRequest(String outputPrompt, String inputLine, boolean doRepaint)
    {
        boolean succeed = false;
        if (directCommand(inputLine))
        {
            return;
        } else
        {
            resetInput();
            refreshHintWindow();

            calculating = true;
            if (doRepaint)
            {
                paint(getGraphics());
            }
            outputStringBuffer.delete(0, outputStringBuffer.length());
            //String response = "";
            EvaluationResponse response = null;

            response = interpreter.evaluate(inputLine);


            outputStringBuffer.append(response.getSideEffects());//todo:tk:hack to try to determine why outputStringBuffer is always being added as an output line as an empty string.

            calculating = false;

            addOutputLine(outputStringBuffer.toString());
            if (response.isExceptionThrown() == true)
            {
                addLinesStatic(48, "Error> ", response.getExceptionMessage());
            }
            //AddLinesStatic(48, outputPrompt, response.getSideEffects());//TODO:tk: latex results are returned as a side effect, but normal results are not.  Also, what is a static line?.
            succeed = true;
        }
        {
            if (!succeed)
            {
                out.println("Request failed");
            }
        }
    }

    void addLinesStatic(int indent, String prompt, String str)
    {
        int pos;
        while ((pos = str.indexOf('\n')) >= 0)
        {
            addLineStatic(indent, prompt, str.substring(0, pos), font, Color.black);
            str = str.substring(pos + 1, str.length());
        }
        if (str.length() > 0)
        {
            addLineStatic(indent, prompt, str, font, Color.black);
        }
    }










    void clearOutputLines()
    {
        int i;
        for (i = 0; i < nrLines; i++)
        {
            lines[i] = null;
        }
        totalLinesHeight = 0;
        thumbPos = 0;
        outputDirty = true;
    }

    void addLine(MathOutputLine aLine)
    {
        {
            createOffscreenImage();
            if (lines[currentLine] != null)
            {
                totalLinesHeight -= lines[currentLine].height(offGra);
            }
            lines[currentLine] = aLine;
            if (lines[currentLine] != null)
            {
                totalLinesHeight += lines[currentLine].height(offGra);
            }
            currentLine = (currentLine + 1) % nrLines;
            {
                int canvasHeight = getHeight() - fontHeight - 1;
                if (canvasHeight < totalLinesHeight)
                {
                    int th = calcThumbHeight();
                    thumbPos = canvasHeight - th - 4;
                }
            }
            outputDirty = true;
        }
    }

    void addLine(int index, String text)
    {
        addLineStatic(index, text);
        repaint(0);
    }

    public void addLineStatic(int indent, String text)
    {
        addLineStatic(indent, "", text, font, Color.black);
    }
    Color iPromptColor = new Color(128, 128, 128);
    Font iPromptFont = new Font("Verdana", Font.PLAIN, 12);

    void addLineStatic(int indent, String prompt, String text, Font aFont, Color aColor)
    {
        addLine(new PromptedStringLine(indent, prompt, text, iPromptFont, aFont, iPromptColor, aColor));
        outputDirty = true;
    }

    /// Drawing current view
    public void update(Graphics g)
    {
        paint(g);
    }

    void createOffscreenImage()
    {
        // draw an offScreen drawing
        Dimension dim = getSize();
        if (offGra == null)
        {
            offImg = createImage(dim.width, dim.height);//note:tk.
            offGra = offImg.getGraphics();
        }
    }

    public void paint(Graphics g)
    {
        createOffscreenImage();

        // Render image
        paintToBitmap(offGra);
        // put the OffScreen image OnScreen
        g.drawImage(offImg, 0, 0, null);
        if (hintWindow != null)
        {
            if (g instanceof Graphics2D)
            {
                Graphics2D g2d = null;
                g2d = (Graphics2D) g;
                g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));
            }
            MathPiperGraphicsContext context = new MathPiperGraphicsContext(g, 0, 0);
            context.setFontSize(1, fontHeight/*12*/);
            int nr_total_lines = 1;
            Dimension d = getSize();
            hintWindow.draw(5, (int) (d.getHeight() - context.fontHeight() - nr_total_lines * context.fontHeight()), context);
        }
    }

    int calcThumbHeight()
    {
        int canvasHeight = getHeight() - fontHeight - 1;
        int hgt = ((canvasHeight - 4) * canvasHeight) / totalLinesHeight;
        if (hgt < 16)
        {
            hgt = 16;
        }
        return hgt;
    }

    public void paintToBitmap(Graphics g)
    {
        synchronized (this)
        {
            if (g instanceof Graphics2D)
            {
                Graphics2D g2d = null;
                g2d = (Graphics2D) g;
                g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));

                g2d.setStroke(new BasicStroke((float) (2), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
            }

            FontMetrics metrics = getFontMetrics(font);

            g.setColor(bkColor);
            int yfrom = 0;

            g.setFont(font);
            int inHeight = fontHeight;

            int yto = getHeight();
            if (!outputDirty)
            {
                yfrom += getHeight() - inHeight;
            }
            if (!inputDirty)
            {
                yto -= inHeight;
            }
            g.clearRect(0, yfrom, getWidth(), yto);
            g.setColor(Color.black);

            int i;
            int y = getHeight() - inHeight - g.getFontMetrics().getHeight();

            int canvasHeight = getHeight() - fontHeight - 1;
            if (outputDirty)
            {
                y -= totalLinesHeight;
                if (canvasHeight < totalLinesHeight)
                {
                    int th = calcThumbHeight();
                    double scale = (1.0 * thumbPos) / (canvasHeight - th - 4);
                    y += (int) ((1 - scale) * (totalLinesHeight - canvasHeight));
                }
                g.setClip(0, 0, getWidth(), getHeight() - fontHeight - 1);
                for (i = 0; i < nrLines; i++)
                {
                    int index = (currentLine + i) % nrLines;
                    if (lines[index] != null)
                    {
                        if (y + lines[index].height(g) > 0)
                        {
                            lines[index].draw(g, inset, y);
                        }
                        y += lines[index].height(g);
                    }
                }
                g.setClip(0, 0, getWidth(), getHeight());
                int w = getWidth();
                //System.out.println("height = "+totalLinesHeight+", screen = "+(canvasHeight));
                if (canvasHeight < totalLinesHeight)
                {
                    int thumbHeight = calcThumbHeight();
                    g.setColor(Color.white);
                    g.fillRect(w - scrollWidth, 0, scrollWidth, canvasHeight);

                    if (thumbMoused)
                    {
                        g.setColor(new Color(192, 192, 240));
                    } else
                    {
                        g.setColor(new Color(124, 124, 224));
                    }
                    g.fillRect(w - scrollWidth + 2, thumbPos + 2, scrollWidth - 4, thumbHeight);

                    g.setColor(Color.black);
                    g.drawRect(w - scrollWidth, 0, scrollWidth, canvasHeight);

                    g.drawRect(w - scrollWidth + 2, thumbPos + 2, scrollWidth - 4, thumbHeight);
                }
            }
            y = getHeight() - g.getFontMetrics().getDescent();
            outputDirty = false;
            if (focusGained && !calculating)
            {
                if (inputDirty)
                {
                    if (y + fontHeight > 0)
                    {
                        int promptLength = metrics.stringWidth(inputPrompt);
                        g.setColor(Color.red);
                        g.setFont(font);

                        g.drawString(inputPrompt, inset, y);
                        g.drawString(inputLine, inset + promptLength, y);
                        int cursorLocation = promptLength;
                        for (i = 0; i < cursorPos; i++)
                        {
                            cursorLocation += metrics.charWidth(inputLine.charAt(i));
                        }
                        y += g.getFontMetrics().getDescent();
                        g.setColor(Color.blue);
                        g.drawLine(inset + cursorLocation, y - 2, inset + cursorLocation, y - fontHeight + 1);
                    //TODO remove?            g.drawLine(inset+cursorLocation+1,y-2,inset+cursorLocation+1,y-fontHeight+1);
                    }
                }
            } else
            {
                String toPrint = "Click here to enter an expression";
                if (calculating)
                {
                    toPrint = "Calculating...";
                }

                int promptLength = metrics.stringWidth(toPrint);
                g.setColor(Color.blue);
                g.setFont(font);

                g.drawString(toPrint, inset, y);
                y += g.getFontMetrics().getDescent();
            }
            inputDirty = false;
        }
    }



    void loadHints(String filename)
    {
        CharacterDataReader file = new CharacterDataReader();
        int opened = 0;
        try
        {
            URL url = new URL(filename);
            opened = file.open(url);
        } catch (Exception e)
        {
        }
        if (opened != 0)
        {
            String line = file.readLine();
            String[] tokens = new String[16];
            int nrTokens = 0;
            while (line != null)
            {
                if (line.substring(0, 2).equals("::"))
                {
                    break;
                }
                int i = 0;
                nrTokens = 0;
                while (i < line.length())
                {
                    int start = i;
                    while (line.charAt(i) != ':')
                    {
                        i++;
                    }
                    tokens[nrTokens] = line.substring(start, i);
                    nrTokens++;
                    i++;
                }
                if (nrTokens > 3)
                {
                    HintItem hi = new HintItem();
                    hi.base = tokens[1];
                    hi.hint = tokens[2];
                    hi.description = tokens[3];
                    the_hints.hintTexts[the_hints.nrHintTexts] = hi;
                    the_hints.nrHintTexts++;
                }

                line = file.readLine();
            }
            file.close();
        } else
        {
            out.println("could not read hints");
        }
    }

    HintWindow createHints(int fontsize)
    {
        HintWindow hw = new HintWindow(fontsize);
        return hw;
    }

    void addHintLine(HintWindow hints, String aText, String aDescription)
    {
        hints.addLine(aText);
        if (aDescription.length() > 0)
        {
            hints.addDescription(aDescription);
        }
    }

    HintWindow tryToHint(String text, int length)
    {
        HintWindow hints = null;
        int nrhints = the_hints.nrHintTexts;
        int i, start;
        start = 0;
        if (start < 0)
        {
            return null;
        }
        for (i = start; i < nrhints; i++)
        {
            if (text.charAt(0) > the_hints.hintTexts[i].base.charAt(0))
            {
                continue;
            }
            if (text.charAt(0) < the_hints.hintTexts[i].base.charAt(0))
            {
                continue;
            }
            int baselen = the_hints.hintTexts[i].base.length();
            if (length == baselen)
            {
                if (text.substring(0, baselen).equals(the_hints.hintTexts[i].base))
                {
                    if (hints == null)
                    {
                        hints = createHints(12 /*iDefaultFontSize*/);
                        hints.iAllowSelection = false;
                    }
                    addHintLine(hints, the_hints.hintTexts[i].hint, the_hints.hintTexts[i].description);
                }
            }
        }
        return hints;
    }

    void refreshHintWindow()
    {
        ito = cursorPos;

        while (true)
        {
            if (ito == inputLine.length())
            {
                break;
            }
            if (!MathPiperTokenizer.isAlpha(inputLine.charAt(ito)))
            {
                break;
            }
            ito++;
        }
        if (ito > 0)
        {
            int c = inputLine.charAt(ito - 1);
            if (c == ',' || c == ')')
            {
                int braces = -1;
                if (c == ')')
                {
                    ito--;
                    braces = -2;
                }
                while (braces != 0)
                {
                    if (ito <= 0)
                    {
                        break;
                    }
                    if (inputLine.charAt(ito - 1) == '(')
                    {
                        braces++;
                    }
                    if (inputLine.charAt(ito - 1) == ')')
                    {
                        braces--;
                    }
                    ito--;
                }
            }
        }
        if (ito > 0)
        {
            if (inputLine.charAt(ito - 1) == '(')
            {
                ito--;
            }
        }
        if (ito == 0)
        {
            while (true)
            {
                if (ito == cursorPos)
                {
                    break;
                }
                if (!MathPiperTokenizer.isAlpha(inputLine.charAt(ito)))
                {
                    break;
                }
                ito++;
            }
        }
        int ifrom = ito;
        while (true)
        {
            if (ifrom == 0)
            {
                break;
            }
            char c = inputLine.charAt(ifrom - 1);
            if (!MathPiperTokenizer.isAlpha(c) && !MathPiperTokenizer.isDigit(c))
            {
                break;
            }
            ifrom--;
        }
        // Name of function *has* to start with alphabetic letter
        while (ifrom < ito && MathPiperTokenizer.isDigit(inputLine.charAt(ifrom)))
        {
            ifrom++;
        }
        matchToInsert = "";
        lastMatchedWord = "";
        if (ito > ifrom)
        {
            lastMatchedWord = inputLine.substring(ifrom, ito);
        }

        hintWindow = null;
        if (lastMatchedWord.length() > 0)
        {
            //System.out.println("word is "+word);

            int nr = lastMatchedWord.length();
            int maxHintLines = 18;
            String texts[] = new String[maxHintLines + 1];
            int nrHintLines = 0;

            int i;
            for (i = 0; i < the_hints.nrHintTexts; i++)
            {
                if (nrHintLines == maxHintLines)
                {
                    break;
                }
                if (nr <= (the_hints.hintTexts[i].base).length() &&
                        lastMatchedWord.equals(the_hints.hintTexts[i].base.substring(0, nr)))
                {
                    boolean add = true;
                    if (nrHintLines > 0)
                    {
                        if (texts[nrHintLines - 1].equals(the_hints.hintTexts[i].base))
                        {
                            add = false;
                        }
                    }
                    if (add)
                    {
                        texts[nrHintLines++] = the_hints.hintTexts[i].base;
                    }
                    // Exact match, keep this one line
                    if (nrHintLines == 1 && ito != cursorPos && lastMatchedWord.equals(the_hints.hintTexts[i].base))
                    {
                        break;
                    }
                }
            }

            if (nrHintLines == maxHintLines)
            {
                texts[nrHintLines++] = "...";
            }
            if (nrHintLines == 1)
            {
                if (lastMatchedWord.length() < texts[0].length())
                {
                    matchToInsert = texts[0].substring(lastMatchedWord.length(), texts[0].length());
                }
                hintWindow = tryToHint(texts[0], texts[0].length());
            } else if (nrHintLines > 1)
            {
                hintWindow = createHints(12);
                hintWindow.iAllowSelection = true;

                for (i = 0; i < nrHintLines; i++)
                {
                    addHintLine(hintWindow, texts[i], "");
                }
            }
        }
    }

    public void invokeCalculation(String expression)
    {
        if (!gotDatahubInit)
        {
            start();
        }
        appendHistoryLine(expression);
        addLinesStatic(48, "In> ", expression);
        resetInput();
        refreshHintWindow();
        inputDirty = true;
        outputDirty = true;
        performRequest("Result: ", expression, false);
        inputDirty = true;
        outputDirty = true;
        repaint();
    }

    public String calculate(String expression)
    {
        if (!gotDatahubInit)
        {
            start();
        //String result = "";
        }
        EvaluationResponse evaluationResponse = null;

        evaluationResponse = interpreter.evaluate(expression);

        lastError = evaluationResponse.getExceptionMessage();  //Note:tk: need to check for null value.
        return evaluationResponse.getResult();
    }

    public String getLastError()
    {
        if (lastError != null)
        {
            return lastError;
        } else
        {
            return "";
        }
    }

    private void addOutputLine(String outp)
    {
        if (outp.length() > 0)
        {
            int dollarPos = outp.indexOf("$");
            while (dollarPos >= 0)
            {
                // Print plain text before the dollared content
                if (dollarPos > 0)
                {
                    addLinesStatic(48, "", outp.substring(0, dollarPos));
                }
                // Strip off the left dollar sign
                outp = outp.substring(dollarPos + 1, outp.length());

                // Find the right dollar sign, and split there too
                dollarPos = outp.indexOf("$");
                String dollared = outp.substring(0, dollarPos);
                outp = outp.substring(dollarPos + 1, outp.length());

                //System.out.println("Dollared: "+dollared);
                int plotPos = dollared.indexOf("plot2d:");
                if (plotPos >= 0)
                {
                    dollared = dollared.substring(plotPos + 7);
                    //System.out.println("Plotting: ["+dollared+"]");
                    addLine(new PromptedGraph2DLine(48, "Result:", iPromptFont, iPromptColor, dollared));
                } else
                {
                    addLine(new PromptedFormulaLine(48, "Result:", iPromptFont, iPromptColor, dollared));
                }
                dollarPos = outp.indexOf("$");
            }
            // If there is some plain text left at the end, print
            if (outp.length() > 0)
            {
                addLinesStatic(48, "", outp.toString());
            }
        }
        outputDirty = true;
    }

    public void addInputLine(String expression)
    {
        synchronized (this)
        {
            if (!gotDatahubInit)
            {
                start();
            }
            appendHistoryLine(expression);
            addLinesStatic(48, "In> ", expression);
            resetInput();
            refreshHintWindow();
            inputDirty = true;
            outputDirty = true;
            calculating = true;
        }
        repaint();
    }

    public void invokeCalculationSilent(String expression)
    {
        synchronized (this)
        {
            if (directCommand(expression))
            {
                return;
            } else
            {
                outputStringBuffer.delete(0, outputStringBuffer.length());
                EvaluationResponse evaluationResponse = null;

                evaluationResponse = interpreter.evaluate(expression);

                calculating = false;
                addOutputLine(outputStringBuffer.toString());
                if (evaluationResponse != null && evaluationResponse.getExceptionMessage() != null)
                {
                    addLinesStatic(48, "Error> ", evaluationResponse.getExceptionMessage());
                }

                resetInput();
                refreshHintWindow();
                inputDirty = true;
                outputDirty = true;
            }
        }
        repaint();
    }

    public void stopCurrentCalculation()
    {
        //interpreter.getEnvironment().iEvalDepth = interpreter.getEnvironment().iMaxEvalDepth + 100;
        interpreter.haltEvaluation();

    }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/Console.java0000644000175000017500000000170111131060345027346 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets;

public interface Console
{
    void addLineStatic(int indent, String text);

}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/latexparser/0000755000175000017500000000000011722677341027454 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/latexparser/SymbolBoxStack.java0000644000175000017500000001241711341703727033223 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.latexparser;

import org.mathpiper.ui.gui.worksheets.symbolboxes.*;


public class SymbolBoxStack {

    SymbolBox[] stack = new SymbolBox[1024];

    int stackDepth = 0;


    public SymbolBox pop() {
        stackDepth--;

        SymbolBox result = stack[stackDepth];

        return result;
    }

    void push(SymbolBox aSbox) {

        stack[stackDepth] = aSbox;

        stackDepth++;
    }

    public int stackDepth() {

        return stackDepth;
    }

    public void process(String aType) {

        if (aType.equals("=") || aType.equals("\\neq") || aType.equals("+") || aType.equals(",") || aType.equals("\\wedge") || aType.equals("\\vee") || aType.equals("<") || aType.equals(">") || aType.equals("<=") || aType.equals(">=")) {

            SymbolBox right = pop();
            SymbolBox left = pop();
            push(new InfixOperator(left, new SymbolName(aType), right));
        } else if (aType.equals("/")) {

            SymbolBox denom = pop();
            SymbolBox numer = pop();
            push(new Fraction(numer, denom));
        } else if (aType.equals("-/2")) {

            SymbolBox right = pop();
            SymbolBox left = pop();
            push(new InfixOperator(left, new SymbolName("-"), right));
        } else if (aType.equals("-/1")) {

            SymbolBox right = pop();
            push(new PrefixOperator(new SymbolName("-"), right));
        } else if (aType.equals("~")) {

            SymbolBox right = pop();
            push(new PrefixOperator(new SymbolName("~"), right));
        } else if (aType.equals("!")) {

            SymbolBox left = pop();
            push(new PrefixOperator(left, new SymbolName("!")));
        } else if (aType.equals("*")) {

            SymbolBox right = pop();
            SymbolBox left = pop();
            push(new InfixOperator(left, new SymbolName(""), right));
        } else if (aType.equals("[func]")) {

            SymbolBox right = pop();
            SymbolBox left = pop();
            push(new PrefixOperator(left, right));
        } else if (aType.equals("^")) {

            SymbolBox right = pop();
            SymbolBox left = pop();
            boolean appendToExisting = false;

            if (left instanceof SuperSubFix) {

                SuperSubFix sbox = (SuperSubFix) left;

                if (!sbox.hasSuperfix()) {
                    appendToExisting = true;
                }
            }

            if (appendToExisting) {

                SuperSubFix sbox = (SuperSubFix) left;
                sbox.setSuperfix(right);
                push(sbox);
            } else {
                push(new SuperSubFix(left, right, null));
            }
        } else if (aType.equals("_")) {

            SymbolBox right = pop();
            SymbolBox left = pop();

            if (left instanceof SuperSubFix) {

                SuperSubFix sbox = (SuperSubFix) left;
                sbox.setSubfix(right);
                push(sbox);
            } else {
                push(new SuperSubFix(left, null, right));
            }
        } else if (aType.equals("[sqrt]")) {

            SymbolBox left = pop();
            push(new SquareRoot(left));
        } else if (aType.equals("[sum]")) {
            push(new Sum());
        } else if (aType.equals("[int]")) {
            push(new Integral());
        } else if (aType.equals("[roundBracket]")) {

            SymbolBox left = pop();
            push(new Bracket(left, "(", ")"));
        } else if (aType.equals("[squareBracket]")) {

            SymbolBox left = pop();
            push(new Bracket(left, "[", "]"));
        } else if (aType.equals("[accoBracket]")) {

            SymbolBox left = pop();
            push(new Bracket(left, "{", "}"));
        } else if (aType.equals("[grid]")) {

            SymbolBox widthBox = pop();
            SymbolBox heightBox = pop();
            int width = Integer.parseInt(((SymbolName) widthBox).iSymbol);
            int height = Integer.parseInt(((SymbolName) heightBox).iSymbol);
            Grid grid = new Grid(width, height);
            int i;
            int j;

            for (j = height - 1; j >= 0; j--) {

                for (i = width - 1; i >= 0; i--) {

                    SymbolBox value = pop();
                    grid.setSBox(i, j, value);
                }
            }

            push(grid);
        } else {
            push(new SymbolName(aType));
        }
    }

    public void processLiteral(String aExpression) {
        push(new SymbolName(aExpression));
    }
}//end class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/latexparser/TexParser.java0000644000175000017500000002313611355310103032217 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.latexparser;

import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;


public class TexParser
{

	static String singleOps = "^_+=,";
	int currentPos;
	String iCurrentExpression;
	String nextToken;

        private boolean showToken = false;

	private void showToken(String sourceName)
	{
		System.out.println(sourceName + ": " + nextToken);
	}

	void nextToken()
	{
		nextToken = "";

		if (currentPos == iCurrentExpression.length())
		{

			if(showToken) showToken("End of expression");

			return;
		}


		while (currentPos < iCurrentExpression.length() && isSpace(iCurrentExpression.charAt(currentPos)))
                {
                        //Skip spaces.
			currentPos++;
                }

		if (currentPos == iCurrentExpression.length())
		{
                        //Return if at end of expression.

			if(showToken) showToken("End of expression");
			return;
		}
		else if (isAlNum(iCurrentExpression.charAt(currentPos)))
		{

			int startPos = currentPos;

			while (currentPos < iCurrentExpression.length() && isAlNum(iCurrentExpression.charAt(currentPos)))
			{
				currentPos++;
			}

			nextToken = iCurrentExpression.substring(startPos, currentPos);

			if(showToken) showToken("Is alpha numeric");
			return;
		}

		int c = iCurrentExpression.charAt(currentPos);

		if (c == '{')
		{
			nextToken = "{";
			currentPos++;

			if(showToken) showToken("Left brace");
			return;
		}
		else if (c == '}')
		{
			nextToken = "}";
			currentPos++;

			if(showToken) showToken("Right brace");
			return;
		}
		else if (singleOps.indexOf(c) >= 0)
		{
			nextToken = "" + (char)c;
			currentPos++;

			if(showToken) showToken("Single operator");
			return;
		}
		else if (c == '\\')
		{

			int startPos = currentPos;

			while (currentPos < iCurrentExpression.length() && (isAlNum(iCurrentExpression.charAt(currentPos)) || iCurrentExpression.charAt(currentPos) == '\\'))
			{
				currentPos++;
			}

			nextToken = iCurrentExpression.substring(startPos, currentPos);

			if(showToken) showToken("Backslash");
			return;
		}

		if(showToken) showToken("No match");
	}

	boolean matchToken(String token)
	{

		if (nextToken.equals(token))

			return true;

		System.out.println("Found " + nextToken + ", expected " + token);

		return false;
	}

	public SymbolBox parse(String aExpression)
	{
		iCurrentExpression = aExpression;
		currentPos = 0;
		nextToken();

		return parseTopExpression();
	}

	SymbolBox parseTopExpression()
	{

		SymbolBoxStack builder = new SymbolBoxStack();

		parseOneExpression10(builder);

		SymbolBox expression = builder.pop();

		return expression;
	}

	void parseOneExpression10(SymbolBoxStack builder)
	{
		parseOneExpression20(builder);

		// = ,
		while (nextToken.equals("=") || nextToken.equals("\\neq") || nextToken.equals(","))
		{

			String token = nextToken;
			nextToken();
			parseOneExpression20(builder);
			builder.process(token);
		}
	}

	void parseOneExpression20(SymbolBoxStack builder)
	{
		parseOneExpression25(builder);

		// +, -
		while (nextToken.equals("+") || nextToken.equals("-") || nextToken.equals("\\wedge") || nextToken.equals("\\vee") || nextToken.equals("<") || nextToken.equals(">") || nextToken.equals("\\leq") || nextToken.equals("\\geq"))
		{

			String token = nextToken;

			if (token.equals("-"))
				token = "-/2";
			else if (token.equals("\\leq"))
				token = "<=";
			else if (token.equals("\\geq"))
				token = ">=";

			nextToken();
			parseOneExpression25(builder);
			builder.process(token);
		}
	}

	void parseOneExpression25(SymbolBoxStack builder)
	{
		parseOneExpression30(builder);

		// implicit *
		while (nextToken.length() > 0 && !nextToken.equals("+") && !nextToken.equals("-") && !nextToken.equals("=") && !nextToken.equals("\\neq") && !nextToken.equals("}") && !nextToken.equals("&") && !nextToken.equals("\\wedge") && !nextToken.equals("\\vee") && !nextToken.equals("<") && !nextToken.equals(">") && !nextToken.equals("\\leq") && !nextToken.equals("\\geq") && !nextToken.equals("\\end") && !nextToken.equals("\\\\") && !nextToken.equals("\\right)") && !nextToken.equals("\\right]") && !nextToken.equals(","))
		{

			//System.out.println("nextToken = "+nextToken);
			String token = "*";
			parseOneExpression30(builder);

			//System.out.println("After: nextToken = "+nextToken);
			builder.process(token);
		}
	}

	void parseOneExpression30(SymbolBoxStack builder)
	{
		parseOneExpression40(builder);

		// _, ^
		while (nextToken.equals("_") || nextToken.equals("^") || nextToken.equals("!"))
		{

			if (nextToken.equals("!"))
			{
				builder.process(nextToken);
				nextToken();
			}
			else
			{

				String token = nextToken;
				nextToken();
				parseOneExpression40(builder);
				builder.process(token);
			}
		}
	}

	void parseOneExpression40(SymbolBoxStack builder)
	{

		// atom
		if (nextToken.equals("{"))
		{
			nextToken();
			parseOneExpression10(builder);

			if (!nextToken.equals("}"))
			{
				System.out.println("Got " + nextToken + ", expected }");

				return;
			}
		}
		else if (nextToken.equals("\\left("))
		{
			nextToken();
			parseOneExpression10(builder);

			if (!nextToken.equals("\\right)"))
			{
				System.out.println("Got " + nextToken + ", expected \\right)");

				return;
			}

			builder.process("[roundBracket]");
		}
		else if (nextToken.equals("\\left["))
		{
			nextToken();
			parseOneExpression10(builder);

			if (!nextToken.equals("\\right]"))
			{
				System.out.println("Got " + nextToken + ", expected \\right]");

				return;
			}

			builder.process("[squareBracket]");
		}
		else if (nextToken.equals("\\sqrt"))
		{
			nextToken();
			parseOneExpression25(builder);
			builder.process("[sqrt]");

			return;
		}
		else if (nextToken.equals("\\exp"))
		{
			nextToken();
			builder.process("e");
			parseOneExpression40(builder);
			builder.process("^");

			return;
		}
		else if (nextToken.equals("\\imath"))
		{
			builder.process("i");
		}
		else if (nextToken.equals("\\mathrm"))
		{
			nextToken();

			if (!matchToken("{"))

				return;

			int startPos = currentPos;

			while (currentPos < iCurrentExpression.length() && iCurrentExpression.charAt(currentPos) != '}')
				currentPos++;

			String literal = iCurrentExpression.substring(startPos, currentPos);
			currentPos++;
			builder.processLiteral(literal);
			nextToken();

			return;
		}
		else if (nextToken.equals("-"))
		{
			nextToken();
			parseOneExpression30(builder);
			builder.process("-/1");

			return;
		}
		else if (nextToken.equals("\\neg"))
		{
			nextToken();
			parseOneExpression30(builder);
			builder.process("~");

			return;
		}
		else if (nextToken.equals("\\sum"))
		{
			builder.process("[sum]");
		}
		else if (nextToken.equals("\\int"))
		{
			builder.process("[int]");
		}
		else if (nextToken.equals("\\frac"))
		{
			nextToken();
			parseOneExpression40(builder);
			parseOneExpression40(builder);
			builder.process("/");

			return;
		}
		else if (nextToken.equals("\\begin"))
		{
			nextToken();

			if (!matchToken("{"))

				return;

			nextToken();

			String name = nextToken;
			nextToken();

			if (!matchToken("}"))

				return;

			if (name.equals("array"))
			{

				int nrColumns = 0;
				int nrRows = 0;
				nextToken();

				if (!matchToken("{"))

					return;

				nextToken();

				String coldef = nextToken;
				nextToken();

				if (!matchToken("}"))

					return;

				nrColumns = coldef.length();
				nrRows = 1;
				nextToken();

				while (!nextToken.equals("\\end"))
				{
					parseOneExpression10(builder);

					if (nextToken.equals("\\\\"))
					{
						nrRows++;
						nextToken();
					}
					else if (nextToken.equals("&"))
					{
						nextToken();
					}
					else
					{

						//  System.out.println("END? "+nextToken);
					}
				}

				nextToken();

				if (!matchToken("{"))

					return;

				nextToken();

				String name2 = nextToken;
				nextToken();

				if (!matchToken("}"))

					return;

				if (name2.equals("array"))
				{
					builder.process("" + nrRows);
					builder.process("" + nrColumns);
					builder.process("[grid]");
				}
			}
		}
		else
		{
			builder.process(nextToken);
		}

		nextToken();
	}

	boolean isSpace(int c)
	{

		if (c == ' ' || c == '\t' || c == '\r' || c == '\n')

			return true;

		return false;
	}

	boolean isAlNum(int c)
	{

		if (isSpace(c))

			return false;

		if (c == '{')

			return false;

		if (c == '}')

			return false;

		if (c == '\\')

			return false;

		if (singleOps.indexOf(c) >= 0)

			return false;

		return true;
	}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/AppletOutput.java0000644000175000017500000000324311131060345030415 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets;

import java.io.IOException;

class AppletOutput {

    public AppletOutput(Console aApplet) {
        iApplet = aApplet;
    }
    Console iApplet;

    public void write(int c) throws IOException {
        if (c == '\n') {
            iApplet.addLineStatic(0, buffer.toString());
            buffer = new StringBuffer();
        } else {
            buffer.append((char) c);
        }
    }

    public void print(String s) {
        try {
            int i, nr;
            nr = s.length();
            for (i = 0; i < nr; i++) {
                write(s.charAt(i));
            }
        } catch (IOException e) {
        }
    }

    public void println(Exception e) {
        println(e.getMessage());
    }

    public void println(String s) {
        print(s);
        print("\n");
    }
    StringBuffer buffer = new StringBuffer();
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ConsoleApplet.html0000644000175000017500000000241011316535576030557 0ustar  giovannigiovanni

   Applet HTML Page






    Applet HTML Page
    


    

               
'            
'            
'            
'            
            Java support does not seem to be installed in your browser, so the console is not available.





    


    Generated by NetBeans IDE

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/MathPanel.java0000644000175000017500000001276511355317372027646 0ustar  giovannigiovanni

package org.mathpiper.ui.gui.worksheets;

import java.awt.BasicStroke;
import java.awt.Color;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Graphics2D;
import java.awt.RenderingHints;
import java.awt.event.MouseEvent;
import java.awt.event.MouseListener;
import javax.swing.JPanel;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Bounds;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Position;
import org.mathpiper.ui.gui.worksheets.symbolboxes.ScaledGraphics;
import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;

    public class MathPanel extends JPanel implements ViewPanel, MouseListener
    {
        protected SymbolBox symbolBox;
        protected double viewScale = 1;
        private boolean paintedOnce = false;
        private int xOffset = 0;
        private int yOffset = 0;

        public MathPanel(SymbolBox symbolBox, double viewScale)
        {
            this.symbolBox = symbolBox;
            this.setOpaque(true);
            this.viewScale = viewScale;
            this.setBackground(Color.white);

            this.addMouseListener(this);
     

            //Bounds bounds = search(symbolBox);

            //xOffset = Math.abs((int) bounds.left);
            //yOffset = Math.abs((int) bounds.top);



        }


        public void paint(Graphics g)
        {
            super.paint(g);
            Graphics2D g2d = (Graphics2D) g;
            g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));

            g2d.setStroke(new BasicStroke((float) (2), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
            g2d.setColor(Color.black);
            g2d.setBackground(Color.white);
            ScaledGraphics sg = new ScaledGraphics(g2d);
            sg.setLineThickness(0);
            sg.setViewScale(viewScale);

            //int iIndent = 0;
            double calculatedAscent = symbolBox.getCalculatedAscent();

            if(paintedOnce == false)
            {
                symbolBox.calculatePositions(sg, 3, new Position(0, 0));
                Bounds bounds = search(symbolBox);

                xOffset = Math.abs((int) bounds.left);
                yOffset = Math.abs((int) bounds.top);

                super.revalidate();
                
                paintedOnce = true;
                
            }//end if.

            symbolBox.calculatePositions(sg, 3, new Position(xOffset, yOffset));
            SymbolBox.setSequence(1);
            symbolBox.render(sg);
            
        }

 
        public Dimension getPreferredSize() {
           if(paintedOnce)
           {
                Bounds maxBounds = search(symbolBox);

                //System.out.println(maxBounds.toString());

                Dimension scaledDimension = maxBounds.getScaledDimension(this.viewScale);

                return scaledDimension;
           }
           else
           {
                return new Dimension(700,600);
           }
            
        }//end method.

        
        public void setViewScale(double viewScale)
        {
            this.viewScale = viewScale;
            this.revalidate();
            this.repaint();
        }


        public Bounds search(SymbolBox currentNode)
        {
            Bounds myBounds = currentNode.getScaledBounds(viewScale);

            double topMost = myBounds.getTop();
            double bottomMost = myBounds.getBottom();
            double leftMost = myBounds.getLeft();
            double rightMost = myBounds.getRight();
            /*
            double topMost = currentNode.getCalculatedPosition().getY() - currentNode.getDimension().getHeight() ;
            double bottomMost = currentNode.getCalculatedPosition().getY();
            double leftMost = currentNode.getCalculatedPosition().getX();
            double rightMost = currentNode.getCalculatedPosition().getX() + currentNode.getDimension().getWidth();
             */

            SymbolBox[] children = currentNode.getChildren();

            if(children.length != 0)
            {
                for(SymbolBox child:children)
                {
                    if(child != null)
                    {
                        Bounds bounds = search(child);

                        if(bounds.getTop() < topMost)
                        {
                            topMost = bounds.getTop();
                        }

                        if(bounds.getBottom() > bottomMost)
                        {
                            bottomMost = bounds.getBottom();
                        }

                        if(bounds.getLeft() < leftMost)
                        {
                            leftMost = bounds.getLeft();
                        }

                        if(bounds.getRight() > rightMost)
                        {
                            rightMost = bounds.getRight();
                        }

                        //return new Bounds(topMost, bottomMost, leftMost, rightMost);
                    }
                }

            }//end if.

            return new Bounds(topMost, bottomMost, leftMost, rightMost);
        }//end method.


        public void mouseClicked(MouseEvent me)
        {
            System.out.println("X: " + me.getX() + "   Y: " + me.getY());
        }

        public void mouseEntered(MouseEvent me)
        {
        }

        public void mouseExited(MouseEvent me)
        {
        }

        public void mousePressed(MouseEvent me)
        {
        }

        public void mouseReleased(MouseEvent me)
        {
        }
        
        


    }//end class.mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/CharacterDataReader.java0000644000175000017500000000350111131060345031555 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets;

import java.net.*;
import java.io.*;

public class CharacterDataReader
{
	BufferedReader in;

	public CharacterDataReader()
	{
	}
	public int open(URL source)
	{
		String mark = null;
		in = null;
		try
		{
			//      URL source = new URL(getCodeBase(), fileName);
			//TODO remove?      in = new DataInputStream(source.openStream());
			in = new BufferedReader(new InputStreamReader(source.openStream()));


			mark = in.readLine();
			//      while(null != (aLine = in.readLine()))
			//        System.out.println(aLine);
		}
		catch(Exception e)
		{
			in = null;
			//       e.printStackTrace();
		}

		//System.out.println("File type: "+mark+" version "+dataFormatVersion);
		if (in != null)
			return 1;
		return 0;
	}
	public String readLine()
	{
		try
		{
			String mark = in.readLine();
			return mark;
		}
		catch (Exception e)
		{
		}
		return null;
	}

	public void close()
	{
		try
		{
			if (in != null)
			{
				in.close();
			}
		}
		catch (Exception e)
		{
		}
		in = null;
	}

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ScreenCapturePanel.java0000644000175000017500000000341111506507632031502 0ustar  giovannigiovanni
package org.mathpiper.ui.gui.worksheets;

import java.awt.Color;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.MouseEvent;
import java.awt.event.MouseListener;
import javax.swing.JMenuItem;
import javax.swing.JPanel;
import javax.swing.JPopupMenu;
import org.mathpiper.ui.gui.Utility;


public class ScreenCapturePanel extends JPanel implements MouseListener{
    
    public ScreenCapturePanel()
    {
        this.addMouseListener(this);
        this.setBackground(Color.white);
    }


    public void mousePressed(MouseEvent e) {
        //eventOutput("Mouse pressed (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseReleased(MouseEvent e) {
        //eventOutput("Mouse released (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseEntered(MouseEvent e) {
        //eventOutput("Mouse entered", e);
    }


    public void mouseExited(MouseEvent e) {
        //eventOutput("Mouse exited", e);
    }


    public void mouseClicked(MouseEvent e) {
        //eventOutput("Mouse clicked (# of clicks: "  + e.getClickCount() + ")", e);

                int buttonNumber = e.getButton();

                if (buttonNumber == MouseEvent.BUTTON3) {
                    JPopupMenu popup = new JPopupMenu();
                    JMenuItem menuItem = new JMenuItem("Save image to file");
                    menuItem.addActionListener(new ActionListener() {

                        public void actionPerformed(ActionEvent e) {
                           Utility.saveImageOfComponent(ScreenCapturePanel.this);
                        }

                    });

                    popup.add(menuItem);
                    popup.show(ScreenCapturePanel.this, 10, 10);


                }
    }//end method.
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/MathPanelController.java0000644000175000017500000000405411346642446031705 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets;

import java.awt.event.ItemEvent;
import java.awt.event.ItemListener;
import javax.swing.JCheckBox;
import javax.swing.JLabel;
import javax.swing.JPanel;
import javax.swing.JSlider;
import javax.swing.event.ChangeEvent;
import javax.swing.event.ChangeListener;
import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;

public class MathPanelController extends JPanel implements ChangeListener, ItemListener {

    private JSlider scaleSlider;
    private ViewPanel viewPanel;

    public MathPanelController(ViewPanel viewPanel, double initialValue) {
        super();
        this.viewPanel = viewPanel;

        scaleSlider = new JSlider(JSlider.HORIZONTAL, 1, 100, (int) (initialValue*10));
        scaleSlider.addChangeListener(this);

        //Turn on labels at major tick marks.
        //framesPerSecond.setMajorTickSpacing(10);
        //framesPerSecond.setMinorTickSpacing(1);
        //framesPerSecond.setPaintTicks(true);
        scaleSlider.setPaintLabels(true);

        this.add(new JLabel("Adjust Scale"));
        this.add(scaleSlider);

        JCheckBox drawBoundingBoxCheckBox = new JCheckBox("Draw Bounding Boxes");

        drawBoundingBoxCheckBox.setSelected(SymbolBox.isDrawBoundingBox());

        drawBoundingBoxCheckBox.addItemListener(this);

        this.add(drawBoundingBoxCheckBox);


    }

    public void stateChanged(ChangeEvent e) {

        JSlider source = (JSlider) e.getSource();
        //if (!source.getValueIsAdjusting()) {
        int intValue = (int) source.getValue();
        double doubleValue = intValue / 10.0;
        //System.out.println("XXX: " + doubleValue);
        viewPanel.setViewScale(doubleValue);
        viewPanel.repaint();

        //}
        }//end method.

    public void itemStateChanged(ItemEvent e) {
        if (e.getStateChange() == ItemEvent.SELECTED) {
            SymbolBox.setDrawBoundingBox(true);
            viewPanel.repaint();

        } else {
            SymbolBox.setDrawBoundingBox(false);
            viewPanel.repaint();
        }

    }//end method.
    }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ListPanel.java0000644000175000017500000003265211564547425027673 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets;

import java.awt.BasicStroke;
import java.awt.Color;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Graphics2D;
import java.awt.RenderingHints;
import java.util.LinkedList;
import java.util.Queue;
import java.util.Stack;
import javax.swing.JPanel;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Bounds;
import org.mathpiper.ui.gui.worksheets.symbolboxes.ScaledGraphics;

public class ListPanel extends JPanel implements ViewPanel {

    private ConsNode headNode;
    protected double viewScale = 1;
    private Queue levelQueue = new LinkedList();
    private Stack sequenceStack = new Stack();
    private boolean paintedOnce = false;
    private int largestX = 0;
    private int largestY = 0;

    /*
        The code in this constructor rearranges the cons cells that are in a Lisp list into a row-oriented data
        structure that more closely reflects the way the list will be displayed graphically.
     */

    public ListPanel(Environment aEnvironment, int aStackTop, ConsPointer consPointer, double viewScale) {
        super();
        this.setOpaque(true);
        this.viewScale = viewScale;
        this.setBackground(Color.white);

        String sublistName = "(   )";

        int startY = 0;

        int yStep = 1;

        try {

            Cons headCons = consPointer.getCons();

            headNode = new ConsNode();
            if (headCons instanceof SublistCons) {
                headNode.setName(sublistName);
            } else {
                headNode.setName(headCons.car().toString());
            }

            headNode.setY(startY);

            if (headCons == null) {
                throw new Exception("Null cons.");
            }


            ConsXHolder consXHolder = new ConsXHolder(headCons.copy(aEnvironment, false), headNode);

            sequenceStack.push(consXHolder);

            ConsNode currentNode = null;

            while (!sequenceStack.empty()) {
                consXHolder = sequenceStack.pop();

                //Remove rest because it has already been processed.
                consXHolder.getCons().cdr().setCons(null);

                ConsPointer currentConsPointer = new ConsPointer(consXHolder.getCons());

                currentNode = consXHolder.getConsNode();

                while (currentConsPointer.cdr().getCons() != null || (currentConsPointer.car() instanceof ConsPointer && ((ConsPointer) currentConsPointer.car()).getCons() != null)) {

                    if (currentConsPointer.cdr().getCons() != null) {

                        currentConsPointer.goNext(aStackTop, aEnvironment);

                        ConsNode newNode = new ConsNode();

                        if (!(currentConsPointer.getCons() instanceof SublistCons)) {
                            String name = currentConsPointer.getCons().toString();
                            newNode.setName(name);
                        } else {
                            newNode.setName(sublistName);
                        }

                        currentNode.setCdr(newNode);

                        currentNode = newNode;

                        if (currentConsPointer.getCons() instanceof SublistCons) {
                            sequenceStack.push(new ConsXHolder(currentConsPointer.getCons().copy(aEnvironment, false), currentNode));

                            if (currentConsPointer.getCons().cdr().getCons() == null) {
                                break;
                            }//end if.

                        }//end if.

                    } else {
                        if ((currentConsPointer.car() instanceof ConsPointer && ((ConsPointer) currentConsPointer.car()).getCons() == null))//! (currentConsPointer.getCons() instanceof SublistCons)) //(ConsPointer)currentConsPointer.car()).getCons() == null
                        {
                            break;
                        }

                        currentConsPointer.goSub(aStackTop, aEnvironment);

                        if (currentConsPointer.getCons() instanceof SublistCons) {
                            sequenceStack.push(new ConsXHolder(currentConsPointer.getCons().copy(aEnvironment, false), currentNode)); //currentNode.getX()));
                        }//end if.

                        ConsNode newNode = new ConsNode();

                        if (!(currentConsPointer.getCons() instanceof SublistCons)) {
                            String name = currentConsPointer.getCons().toString();
                            newNode.setName(name);
                        } else {
                            newNode.setName(sublistName);
                        }

                        currentNode.setCar(newNode);

                        currentNode = newNode;

                        levelQueue.add(currentNode);

                    }//end else.

                }//end goNext while.

            }//end while.


            int y = startY;

            while (levelQueue.peek() != null) {
                ConsNode consNode = levelQueue.poll();
                consNode.setY(y += yStep);

                if (consNode.getY() > largestY) {
                    largestY = consNode.getY();
                }
            }

        } catch (Exception e) {
            e.printStackTrace();
        }


    }


    public void paint(Graphics g) {
        super.paint(g);
        Graphics2D g2d = (Graphics2D) g;
        g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));

        g2d.setStroke(new BasicStroke((float) (2), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
        g2d.setColor(Color.black);
        g2d.setBackground(Color.white);
        ScaledGraphics sg = new ScaledGraphics(g2d);
        sg.setLineThickness(1);
        sg.setViewScale(viewScale);
        int height = ScaledGraphics.fontForSize(1);
        sg.setFontSize(height);

        if (headNode != null) {
            drawBox(headNode, 0, sg);

        }//end if

        if (paintedOnce == false) {
            super.revalidate();

            paintedOnce = true;
        }

    }//end method.


    private void drawBox(ConsNode currentNode, double previousRightX, ScaledGraphics sg) {
        /*
        This method displays the cons cells which are in the row-oriented
        data structure that was created in the constructor.
         */

        int height = 25;
        int xGap = 10;
        int yGap = 10;
        int textOffset = 0;


        if (currentNode == null) {
            return;
        }


        double x = previousRightX + xGap;

        int y = currentNode.getY() * (height + yGap) + yGap;

        String name = currentNode.getName();

        double textWidth = sg.getScaledTextWidth(name);

        if (textWidth < 25) {
            textOffset = ((int) (25 - textWidth) / 2) + 1;
            textWidth = 25;
        } else {
            textOffset = 3;
            textWidth += 5;
        }

        double boxWidth = textWidth + 25;

        //Draw cons cell rectangle.
        sg.drawRectangle(x, y, boxWidth, height);

        //Draw cons cell dividing line.
        sg.drawLine(x + textWidth, y, x + textWidth, y + height);


        if (name != null) {
            sg.setColor(Color.BLUE);
            sg.drawscaledText(name, x + textOffset, y + 15, 1.0);
            sg.setColor(Color.BLACK);
        }

        if (currentNode.getCdr() != null)
        {
            currentNode.getCdr().setY(currentNode.getY());

            sg.drawLine(x + boxWidth - 12, y + 12, x + boxWidth + xGap, y + 12);
        }
        else
        {
            //Draw cdr diagonal line nil symbol.
            sg.drawLine(x + textWidth, y + height, x + boxWidth, y);
        }


        if (largestX < (int) (x + boxWidth + xGap)) {
            largestX = (int) (x + boxWidth + xGap);
        }


        if (currentNode.getCar() != null) {
            sg.drawLine(x + 13, y + 12, x + 13, currentNode.getCar().getY() * (height + yGap) + yGap);
        }
        else
        {
            //Draw car diagonal line nil symbol code goes here.
        }

        
        drawBox(currentNode.getCdr(), x + boxWidth, sg);

        drawBox(currentNode.getCar(), previousRightX, sg);


    }//end method.


    public Dimension getPreferredSize() {
        if (paintedOnce) {
            Bounds maxBounds = new Bounds(0, (largestY + 1) * (25 + 10) + 10, 0, largestX);

            Dimension scaledDimension = maxBounds.getScaledDimension(this.viewScale);

            return scaledDimension;
        } else {
            return new Dimension(700, 600);
        }

    }//end method.


    public void setViewScale(double viewScale) {
        this.viewScale = viewScale;
        this.revalidate();
        this.repaint();
    }

    private class ConsNode {

        private ConsNode car;
        private ConsNode cdr;
        private String name = "";
        private int y;


        public ConsNode() {
        }


        public ConsNode getCar() {
            return car;
        }


        public void setCar(ConsNode down) {
            this.car = down;
        }


        public ConsNode getCdr() {
            return cdr;
        }


        public void setCdr(ConsNode right) {
            this.cdr = right;
        }


        public String getName() {
            return name;
        }


        public void setName(String name) {
            this.name = name;
        }


        public int getY() {
            return y;
        }


        public void setY(int y) {
            this.y = y;
        }

    }//end class.

    private class ConsXHolder {

        private Cons cons;
        private ConsNode consNode;


        public ConsXHolder(Cons cons, ConsNode consNode) {
            this.cons = cons;

            this.consNode = consNode;
        }


        public Cons getCons() {
            return cons;
        }


        public void setCons(Cons cons) {
            this.cons = cons;
        }


        public ConsNode getConsNode() {
            return consNode;
        }


        public void setConsNode(ConsNode consNode) {
            this.consNode = consNode;
        }

    }//end class.


    /*
    Drawing Lists as Box Diagrams (from http://www.gnu.org/s/emacs/manual/html_node/elisp/Box-Diagrams.html)

    A list can be illustrated by a diagram in which the cons cells are shown as pairs of boxes, like dominoes. (The Lisp reader cannot read such an illustration; unlike the textual notation, which can be understood by both humans and computers, the box illustrations can be understood only by humans.) This picture represents the three-element list (rose violet buttercup):

    --- ---      --- ---      --- ---
    |   |   |--> |   |   |--> |   |   |--> nil
    --- ---      --- ---      --- ---
    |            |            |
    |            |            |
    --> rose     --> violet   --> buttercup

    In this diagram, each box represents a slot that can hold or refer to any Lisp object. Each pair of boxes represents a cons cell. Each arrow represents a reference to a Lisp object, either an atom or another cons cell.

    In this example, the first box, which holds the car of the first cons cell, refers to or holds rose (a symbol). The second box, holding the cdr of the first cons cell, refers to the next pair of boxes, the second cons cell. The car of the second cons cell is violet, and its cdr is the third cons cell. The cdr of the third (and last) cons cell is nil.

    Here is another diagram of the same list, (rose violet buttercup), sketched in a different manner:

    ---------------       ----------------       -------------------
    | car   | cdr   |     | car    | cdr   |     | car       | cdr   |
    | rose  |   o-------->| violet |   o-------->| buttercup |  nil  |
    |       |       |     |        |       |     |           |       |
    ---------------       ----------------       -------------------

    A list with no elements in it is the empty list; it is identical to the symbol nil. In other words, nil is both a symbol and a list.

    Here is the list (A ()), or equivalently (A nil), depicted with boxes and arrows:

    --- ---      --- ---
    |   |   |--> |   |   |--> nil
    --- ---      --- ---
    |            |
    |            |
    --> A        --> nil

    Here is a more complex illustration, showing the three-element list, ((pine needles) oak maple), the first element of which is a two-element list:

    --- ---      --- ---      --- ---
    |   |   |--> |   |   |--> |   |   |--> nil
    --- ---      --- ---      --- ---
    |            |            |
    |            |            |
    |             --> oak      --> maple
    |
    |     --- ---      --- ---
    --> |   |   |--> |   |   |--> nil
    --- ---      --- ---
    |            |
    |            |
    --> pine     --> needles

    The same list represented in the second box notation looks like this:

    --------------       --------------       --------------
    | car   | cdr  |     | car   | cdr  |     | car   | cdr  |
    |   o   |   o------->| oak   |   o------->| maple |  nil |
    |   |   |      |     |       |      |     |       |      |
    -- | ---------       --------------       --------------
    |
    |
    |        --------------       ----------------
    |       | car   | cdr  |     | car     | cdr  |
    ------>| pine  |   o------->| needles |  nil |
    |       |      |     |         |      |
    --------------       ----------------
     */
}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/0000755000175000017500000000000011722677341030367 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedStringLine.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedStringLine0000644000175000017500000000446211326263630034101 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import java.awt.Color;
import java.awt.Font;
import java.awt.FontMetrics;
import java.awt.Graphics;

public class PromptedStringLine extends MathOutputLine {

    public PromptedStringLine(int aIndent, String aPrompt, String aText, Font aPromptFont, Font aFont, Color aPromptColor, Color aColor) {
        iIndent = aIndent;
        iPrompt = aPrompt;
        iText = aText;
        iPromptFont = aPromptFont;
        iFont = aFont;
        iPromptColor = aPromptColor;
        iColor = aColor;
    }

    public void draw(Graphics g, int x, int y) {
        {
            g.setColor(iPromptColor);
            g.setFont(iPromptFont);
            FontMetrics fontMetrics = g.getFontMetrics();
            g.drawString(iPrompt, x, y + fontMetrics.getAscent());
            if (iIndent != 0) {
                x += iIndent;
            } else {
                x += fontMetrics.stringWidth(iPrompt);
            }
        }
        {
            g.setColor(iColor);
            g.setFont(iFont);
            FontMetrics fontMetrics = g.getFontMetrics();
            g.drawString(iText, x, y + fontMetrics.getAscent());
        }
    }

    public int height(Graphics g) {
        g.setFont(iFont);
        FontMetrics fontMetrics = g.getFontMetrics();
        return fontMetrics.getHeight();
    }
    int iIndent;
    private String iPrompt;
    private String iText;
    private Font iPromptFont;
    private Font iFont;
    private Color iPromptColor;
    private Color iColor;
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/ImageLine.java0000644000175000017500000000313211326263630033053 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import java.applet.Applet;
import java.awt.Color;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Image;

public class ImageLine extends MathOutputLine {

    Color bkColor = new Color(255, 255, 255); //TODO:tk:This variable was originally in ConsoleApplet.

    public ImageLine(Image aImage, Applet aApplet) {
        iImage = aImage;
        iApplet = aApplet;
    }

    public void draw(Graphics g, int x, int y) {
        if (iImage != null) {
            Dimension d = iApplet.getSize();
            g.drawImage(iImage, (d.width - iImage.getWidth(iApplet)) / 2, y, bkColor, iApplet);
        }
    }

    public int height(Graphics g) {
        return iImage.getHeight(iApplet);
    }
    Image iImage;
    Applet iApplet;
}
././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/MathOutputLine.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/MathOutputLine.jav0000644000175000017500000000202511326263630034002 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import java.awt.Graphics;

public abstract class MathOutputLine {

    public abstract void draw(Graphics g, int x, int y);

    public abstract int height(Graphics g);
}
././@LongLink0000000000000000000000000000015300000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedGraph2DLine.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedGraph2DLin0000644000175000017500000000324711326263630033715 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import org.mathpiper.ui.gui.worksheets.*;
import java.awt.Color;
import java.awt.Dimension;
import java.awt.Font;
import java.awt.Graphics;

public class PromptedGraph2DLine extends MathOutputLine {

    public PromptedGraph2DLine(int aIndent, String aPrompt, Font aPromptFont, Color aPromptColor, String aLine) {
        iIndent = aIndent;
        iPrompt = aPrompt;
        iPromptFont = aPromptFont;
        iPromptColor = aPromptColor;
        iGrapher = new Grapher(aLine);
    }
    Grapher iGrapher;

    public void draw(Graphics g, int x, int y) {
        iGrapher.paint(g, x, y, size);
    }

    public int height(Graphics g) {
        return size.height;
    }
    Dimension size = new Dimension(320, 240);
    int iIndent;
    private String iPrompt;
    private Font iPromptFont;
    private Color iPromptColor;
}

././@LongLink0000000000000000000000000000015300000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedFormulaLine.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/PromptedFormulaLin0000644000175000017500000000527511341631636034100 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import org.mathpiper.ui.gui.worksheets.latexparser.TexParser;
import org.mathpiper.ui.gui.worksheets.*;
import org.mathpiper.ui.gui.worksheets.symbolboxes.ScaledGraphics;
import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;
import java.awt.Color;
import java.awt.Font;
import java.awt.FontMetrics;
import java.awt.Graphics;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Position;

public class PromptedFormulaLine extends MathOutputLine {

    SymbolBox sBoxExpression;

    public PromptedFormulaLine(int aIndent, String aPrompt, Font aPromptFont, Color aPromptColor, String aLine) {
        iIndent = aIndent;
        iPrompt = aPrompt;
        iPromptFont = aPromptFont;
        iPromptColor = aPromptColor;

        TexParser parser = new TexParser();
        sBoxExpression = parser.parse(aLine);
    }

    public void draw(Graphics g, int x, int y) {
        int hgt = height(g);
        {
            g.setColor(iPromptColor);
            g.setFont(iPromptFont);
            FontMetrics fontMetrics = g.getFontMetrics();
            g.drawString(iPrompt, x, y + fontMetrics.getAscent() + (hgt - fontMetrics.getHeight()) / 2);
        }

        g.setColor(Color.black);
        ScaledGraphics sg = new ScaledGraphics(g);
        sg.setLineThickness(0);
        sBoxExpression.calculatePositions(sg, 3, new Position(x + iIndent, (y + sBoxExpression.getCalculatedAscent() + 10)));
        sBoxExpression.render(sg);
    }

    public int height(Graphics g) {
        if (height == -1) {
            ScaledGraphics sg = new ScaledGraphics(g);
            sBoxExpression.calculatePositions(sg, 3, new Position(0, 0));
            height = (int) sBoxExpression.getDimension().height + 20;
        }
        return height;
    }
    int height = -1;
    int iIndent;
    private String iPrompt;
    private Font iPromptFont;
    private Color iPromptColor;
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/Grapher.java0000644000175000017500000002710011326263630032612 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import java.awt.*;

public class Grapher {

    public double xmin, ymin, xmax, ymax;
    String iCallList;
    String execList;
    String token;
    int graphx = 0;
    int graphy = 0;
    int graphWidth = 10;
    int graphHeight = 10;
    int axesFontHeight = 12;
    FontMetrics fontMetrics = null;
    int exampleWidth = 48;

    public Grapher(String aCallList) {
        xmin = 1e200;
        ymin = 1e200;
        xmax = -xmin;
        ymax = -ymin;
        iCallList = aCallList;
        runCallList(null);
    }

    void nextToken() {
        int startPos = 0;
        while (startPos < execList.length() && execList.charAt(startPos) == ' ') {
            startPos++;
        }
        int endPos = startPos;
        while (endPos < execList.length() && execList.charAt(endPos) != ' ') {
            endPos++;
        }
        token = execList.substring(startPos, endPos);
        execList = execList.substring(endPos);
    }

    void runCallList(Graphics g) {
        try {
            Graphics2D g2d = null;
            if (g != null) {
                if (g instanceof Graphics2D) {
                    g2d = (Graphics2D) g;
                }
            }

            execList = iCallList;
            nextToken();
            while (token.length() > 0) {
                if (token.equals("lines2d")) {
                    int i;
                    nextToken();
                    int nr = Integer.parseInt(token);
                    nextToken();
                    double x2, y2 = 0;
                    x2 = Float.parseFloat(token);
                    nextToken();
                    y2 = Float.parseFloat(token);
                    if (g == null) {
                        if (xmin > x2) {
                            xmin = x2;
                        }
                        if (xmax < x2) {
                            xmax = x2;
                        }
                        if (ymin > y2) {
                            ymin = y2;
                        }
                        if (ymax < y2) {
                            ymax = y2;
                        }
                    }
                    double x1, y1;
                    for (i = 1; i < nr; i++) {
                        x1 = x2;
                        y1 = y2;
                        nextToken();
                        x2 = Float.parseFloat(token);
                        nextToken();
                        y2 = Float.parseFloat(token);
                        if (g == null) {
                            if (xmin > x2) {
                                xmin = x2;
                            }
                            if (xmax < x2) {
                                xmax = x2;
                            }
                            if (ymin > y2) {
                                ymin = y2;
                            }
                            if (ymax < y2) {
                                ymax = y2;
                            }
                        }
                        if (g != null) {
                            int xPix1 = (int) (graphx + graphWidth * (x1 - xmin) / (xmax - xmin));
                            int yPix1 = (int) (graphy + graphHeight * (1.0 - (y1 - ymin) / (ymax - ymin)));
                            int xPix2 = (int) (graphx + graphWidth * (x2 - xmin) / (xmax - xmin));
                            int yPix2 = (int) (graphy + graphHeight * (1.0 - (y2 - ymin) / (ymax - ymin)));
                            g.drawLine(xPix1, yPix1, xPix2, yPix2);
                        }
                    }
                } else if (token.equals("pencolor")) {
                    nextToken();
                    int red = Integer.parseInt(token);
                    nextToken();
                    int green = Integer.parseInt(token);
                    nextToken();
                    int blue = Integer.parseInt(token);
                    if (g != null) {
                        g.setColor(new Color(red, green, blue));
                    }
                } else if (token.equals("pensize")) {
                    nextToken();
                    float width = Float.parseFloat(token);
                    if (g != null) {
                        if (g2d != null) {
                            g2d.setStroke(new BasicStroke(width, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
                        }
                    }
                } else {
                    //TODO raise an exception here
                    return;
                }
                nextToken();
            }
        } catch (Exception e) {
            //TODO handle exception here
        }
    }

    void determineGraphBounds(int xleft, int ytop, Dimension d) {
        if (fontMetrics != null) {
            exampleWidth = fontMetrics.stringWidth("100000");
        }
        graphx = xleft + exampleWidth;
        graphy = ytop + axesFontHeight;
        graphWidth = d.width - (3 * exampleWidth) / 2;
        graphHeight = d.height - 3 * axesFontHeight;
    }

    public void paint(Graphics g, int xleft, int ytop, Dimension d) {
        Shape clip = g.getClip();
        Rectangle r = clip.getBounds();
        Graphics2D g2d = null;
        if (g instanceof Graphics2D) {
            g2d = (Graphics2D) g;
        }
        if (g2d != null) {
            g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));
        }
        int clipHeight = d.height;
        if (ytop + clipHeight > r.y + r.height) {
            clipHeight = r.y + r.height - ytop;
        }
        g.setClip(xleft, ytop, d.width, clipHeight);

        // Erase the previous image
        g.setColor(Color.white);
        g.fillRect(xleft, ytop, d.width, d.height);

        Font font;
        font = new Font("Verdana", Font.PLAIN, axesFontHeight);
        g.setFont(font);
        fontMetrics = g.getFontMetrics(font);
        determineGraphBounds(xleft, ytop, d);

        Color grey = new Color(164, 164, 164);

        double x, y;

        PlotRange xRange = new PlotRange(xmin, xmax, d.width / ((3 * exampleWidth) / 2));
        int xtick = ((int) (xmin / xRange.TickSize() - 1));
        if (xRange.TickSize() * xtick < xmin) {
            xtick = xtick + 1;
        }
        double xstart = xRange.TickSize() * xtick;
        {
            g.setColor(Color.black);
            for (x = xstart; x <= xmax; x += xRange.TickSize()) {
                int xPix = (int) (graphx + graphWidth * (x - xmin) / (xmax - xmin));
                g.setColor(grey);
                g.drawLine(xPix, graphy, xPix, graphy + graphHeight);
                g.setColor(Color.black);
                String num = xRange.Format(xtick);
                int numWidth = fontMetrics.stringWidth(num);
                g.drawString(num, xPix - numWidth / 2, graphy + graphHeight + fontMetrics.getAscent());
                xtick++;
            }

            PlotRange yRange = new PlotRange(ymin, ymax, d.height / (axesFontHeight * 2));
            int ytick = ((int) (ymin / yRange.TickSize() - 1));
            if (yRange.TickSize() * ytick < ymin) {
                ytick = ytick + 1;
            }
            double ystart = yRange.TickSize() * ytick;
            for (y = ystart; y <= ymax; y += yRange.TickSize()) {
                int yPix = (int) (graphy + graphHeight * (ymax - y) / (ymax - ymin));
                g.setColor(grey);
                g.drawLine(graphx, yPix, graphx + graphWidth, yPix);
                g.setColor(Color.black);
                String num = yRange.Format(ytick);
                int numWidth = fontMetrics.stringWidth(num);
                g.drawString(num, graphx - numWidth - 8, yPix + fontMetrics.getAscent() - (axesFontHeight) / 2);
                ytick++;
            }
        }

        int graphClipHeight = graphHeight;
        if (graphy + graphClipHeight > r.y + r.height) {
            graphClipHeight = r.y + r.height - graphy;
        }

        g.setClip(graphx, graphy, graphWidth, graphClipHeight);
        runCallList(g);
        g.setClip(xleft, ytop, d.width, clipHeight);
        g.setColor(Color.black);
        if (g2d != null) {
            g2d.setStroke(new BasicStroke(3.0f, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
        }
        g.drawRect(graphx, graphy, graphWidth, graphHeight);
        g.setClip(clip);
    }

    /*
     * Determine the ticks of the graph. The calling routine should first determine the minimum and maximum values, and
     * the number of steps (based on size of the axis to draw relative to font size).
     *
     * Steps will always be m*10^n, for some suitable n, with m either 1, 2 or 5.
     */
    class PlotRange {

        public PlotRange(double aMinValue, double aMaxValue, int aMaxSteps) {
            iMinValue = aMinValue;
            iMaxValue = aMaxValue;
            iMaxSteps = aMaxSteps;

            //TODO handle zero length range
            double range = aMaxValue - aMinValue;
            iN = (int) (Math.log(range) / Math.log(10) - 1);
            iN = iN - 1;
            iStep = 1;
            for (;;) {
                double tickSize = TickSize();
                int nrSteps = (int) (range / tickSize);
                if (nrSteps <= aMaxSteps) {
                    break;
                }
                switch (iStep) {
                    case 1:
                        iStep = 2;
                        break;
                    case 2:
                        iStep = 5;
                        break;
                    case 5:
                        iN++;
                        iStep = 1;
                        break;
                }
            }
        }

        public double TickSize() {
            return iStep * Math.pow(10, iN);
        }

        public String Format(int tick) {
            String result = "";
            int fct = tick * iStep;
            if (iN >= 0 && iN < 3) {
                if (iN > 0) {
                    fct = fct * 10;
                }
                if (iN > 1) {
                    fct = fct * 10;
                }
                result = "" + fct;
            } else {
                int n = iN;
                if (fct == 10 * (fct / 10)) {
                    fct /= 10;
                    n += 1;
                }
                String ex = "";
                if (n != 0 && tick != 0) {
                    ex = "e" + n;
                }
                result = "" + fct + ex;
            }
            return result;
        }
        double iMinValue;
        double iMaxValue;
        int iMaxSteps;
        public int iN;
        public int iStep;
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/mathoutputlines/StringLine.java0000644000175000017500000000313111326263630033276 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.mathoutputlines;

import java.awt.Color;
import java.awt.Font;
import java.awt.FontMetrics;
import java.awt.Graphics;

public class StringLine extends MathOutputLine {

    StringLine(String aText, Font aFont, Color aColor) {
        iText = aText;
        iFont = aFont;
        iColor = aColor;
    }

    public void draw(Graphics g, int x, int y) {
        g.setColor(iColor);
        g.setFont(iFont);
        FontMetrics fontMetrics = g.getFontMetrics();
        g.drawString(iText, x, y + fontMetrics.getHeight());
    }

    public int height(Graphics g) {
        g.setFont(iFont);
        FontMetrics fontMetrics = g.getFontMetrics();
        return fontMetrics.getHeight();
    }
    private String iText;
    private Font iFont;
    private Color iColor;
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/LatexRenderingController.java0000644000175000017500000000371111414545133032735 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets;

import java.awt.Dimension;
import javax.swing.JLabel;
import javax.swing.JPanel;
import javax.swing.JSlider;
import javax.swing.event.ChangeEvent;
import javax.swing.event.ChangeListener;

import org.scilab.forge.jlatexmath.TeXConstants;
import org.scilab.forge.jlatexmath.TeXFormula;
import org.scilab.forge.jlatexmath.TeXIcon;

public class LatexRenderingController extends JPanel implements ChangeListener {

    private JSlider scaleSlider;
    private JLabel texLabel;
    private TeXFormula texFormula;

    public LatexRenderingController(TeXFormula texFormula, JLabel texLabel, int initialValue) {
        super();
        this.texFormula = texFormula;
        this.texLabel = texLabel;

        TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, initialValue);
        texLabel.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
        texLabel.setAlignmentY(icon.getBaseLine());
        texLabel.setIcon(icon);

        scaleSlider = new JSlider(JSlider.HORIZONTAL, 1, 500, initialValue);
        scaleSlider.addChangeListener(this);

        //Turn on labels at major tick marks.
        //framesPerSecond.setMajorTickSpacing(10);
        //framesPerSecond.setMinorTickSpacing(1);
        //framesPerSecond.setPaintTicks(true);
        scaleSlider.setPaintLabels(true);

        this.add(new JLabel("Adjust Scale"));
        this.add(scaleSlider);

    }

    public void stateChanged(ChangeEvent e) {

        JSlider source = (JSlider) e.getSource();
        //if (!source.getValueIsAdjusting()) {
        int intValue = (int) source.getValue();

        TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, intValue);
        texLabel.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
        texLabel.setAlignmentY(icon.getBaseLine());
        texLabel.setIcon(icon);
        texLabel.repaint();

        //}
        }//end method.


    }//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/FormulaViewApplet.java0000644000175000017500000000721111355310103031352 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.worksheets;

import org.mathpiper.ui.gui.worksheets.latexparser.TexParser;
import org.mathpiper.ui.gui.worksheets.symbolboxes.ScaledGraphics;
import org.mathpiper.ui.gui.worksheets.symbolboxes.SymbolBox;

import java.awt.*;
import java.applet.*;
import org.mathpiper.ui.gui.worksheets.symbolboxes.Position;

public class FormulaViewApplet extends Applet
{
	Image offImage = null;
	Graphics offGraphics = null;
	Dimension offDimension = null;

	SymbolBox expression = null;

	public void init()
	{
		setBackground(Color.white);
		setLayout(null);
	}

	public void start()
	{
		repaint();
	}

	public void stop()
	{
		offImage = null;
		offGraphics = null;
	}



	public void update(Graphics g)
	{
		Dimension d = getSize();
		// Create the offscreen graphics context
		if ((offGraphics == null)
		                || (d.width != offDimension.width)
		                || (d.height != offDimension.height))
		{
			offDimension = d;
			offImage = createImage(d.width, d.height);
			offGraphics = offImage.getGraphics();
			// Paint the frame into the image
			paintFrame(offGraphics);
		}

		// Paint the image onto the screen
		g.drawImage(offImage, 0, 0, null);
	}

	/**
	  * Paint the previous frame (if any).
	  */
	public void paint(Graphics g)
	{
		//System.out.println("paint");
		Dimension d = getSize();
		if ((offGraphics == null)
		                || (d.width != offDimension.width)
		                || (d.height != offDimension.height))
		{
			offDimension = d;
			offImage = createImage(d.width, d.height);
			offGraphics = offImage.getGraphics();

			// Paint the frame into the image
			paintFrame(offGraphics);
		}
		if (offImage != null)
		{
			g.drawImage(offImage, 0, 0, null);
		}
	}

	void paintFrame(Graphics g)
	{
		//System.out.println("paintFrame");
		// Tell the rendering system we'd like to have anti-aliasing please
		if (g instanceof Graphics2D)
		{
			Graphics2D g2d = null;
			g2d = (Graphics2D)g;
			g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING,
			                      RenderingHints.VALUE_ANTIALIAS_ON));
		}

		// Clear Background
		Dimension d = getSize();
		//    g.setColor(Color.white);
		//   g.fillRect(0, 0, d.getTextWidth, d.getTextHeight);

		// All graphics should be black from now on
		g.setColor(Color.black);

		ScaledGraphics sg = new ScaledGraphics(g);

		sg.setLineThickness(0);

		if (expression == null)
		{
			String s = getParameter("expression");
			if (s != null)
			{
				System.out.println("re-rendering the whole formula!");
				TexParser parser = new TexParser();
				expression = parser.parse(s);
			}
		}
		if (expression != null)
		{
			expression.calculatePositions(sg, 3, new Position(1, d.height/2));
			expression.render(sg);
		}
	}

}


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/0000755000175000017500000000000011722677341027470 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/SymbolBox.java0000644000175000017500000000714511355317372032255 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Color;
import java.util.List;

public abstract class SymbolBox {

    static boolean drawBoundingBox = false;
    static int sequence = 0;

    protected Dimensions iDimension;

    protected Position iPosition;
    int iSize;
    double iAscent;

    private boolean endOfLevel = false;

    private int treeX;

    private int treeY;

    public static int getSequence() {
        return sequence;
    }

    public static void setSequence(int sequence) {
        SymbolBox.sequence = sequence;
    }


    abstract public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition);

    abstract public void render(ScaledGraphics sg);

    public Dimensions getDimension() {
        return iDimension;
    }

    public Position getCalculatedPosition() {
        return iPosition;
    }

    public int getSetSize() {
        return iSize;
    }

    public double getCalculatedAscent() {
        return iAscent;
    }

    public void drawBoundingBox(ScaledGraphics sg, Color color) {
        sg.setColor(color);
        sg.setLineThickness(0);
        double x0 = iPosition.x;
        double y0 = iPosition.y - getCalculatedAscent();
        double x1 = x0 + iDimension.width;
        double y1 = y0 + iDimension.height;

        sg.drawLine(x0, y0, x1, y0);
        sg.drawLine(x1, y0, x1, y1);
        sg.drawLine(x1, y1, x0, y1);
        sg.drawLine(x0, y1, x0, y0);

        sg.drawscaledText("" + sequence++, x0, y0 + 3, .2);



        sg.setColor(Color.black);
    }//end method.

    public static void setDrawBoundingBox(boolean drawBoundingBox) {
        SymbolBox.drawBoundingBox = drawBoundingBox;
    }

    public static boolean isDrawBoundingBox() {
        return drawBoundingBox;
    }

    public Bounds getScaledBounds(double scale)
    {
        scale = 1;
        double x0 = iPosition.x * scale;
        double y0 = (iPosition.y - getCalculatedAscent()) * scale;
        double x1 = (x0 + iDimension.width) * scale;
        double y1 = (y0 + iDimension.height) * scale;

        return new Bounds(y0, y1, x0, x1);
    }


    public abstract SymbolBox[] getChildren();
    
    

    public boolean isEndOfLevel() {
        return endOfLevel;
    }

    public void setEndOfLevel(boolean endOfLevel) {
        this.endOfLevel = endOfLevel;
    }


    public int getTextWidth(ScaledGraphics sg)
    {
        return (int) sg.getScaledTextWidth(toString());
    }

    public int getTextHeight(ScaledGraphics sg)
    {
        return (int) sg.getScaledTextHeight(toString());
    }

    public int getTreeX() {
        return treeX;
    }

    public void setTreeX(int treeX) {
        this.treeX = treeX;
    }

    public int getTreeY() {
        return treeY;
    }

    public void setTreeY(int treeY) {
        this.treeY = treeY;
    }


}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Grid.java0000644000175000017500000000674711341631636031230 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;



public class Grid extends CompoundExpression {

    int iHeight;
    double[] iHeights;
    int iWidth;
    double[] iWidths;

    private SymbolBox iExpressions[];

    public Grid(int aWidth, int aHeight) {
        //super(aWidth * aHeight);
        iExpressions = new SymbolBox[aWidth * aHeight];
        iWidth = aWidth;
        iHeight = aHeight;
    }

    public void setSBox(int x, int y, SymbolBox aExpression) {
        iExpressions[x + iWidth * y] = aExpression;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {

        int spacing = 12;
        iSize = aSize;
        iPosition = aPosition;

        // Get dimensions first
        if (iDimension == null) {

            int i;
            int j;

            for (i = 0; i < iWidth * iHeight; i++) {
                iExpressions[i].calculatePositions(sg, aSize, null);
            }

            iWidths = new double[iWidth];
            iHeights = new double[iHeight];

            for (i = 0; i < iWidth; i++) {
                iWidths[i] = 0;
            }

            for (i = 0; i < iHeight; i++) {
                iHeights[i] = 0;
            }

            for (i = 0; i < iWidth; i++) {

                for (j = 0; j < iHeight; j++) {

                    Dimensions d = iExpressions[i + iWidth * j].getDimension();

                    if (iWidths[i] < d.width) {
                        iWidths[i] = d.width;
                    }

                    if (iHeights[j] < d.height) {
                        iHeights[j] = d.height;
                    }
                }
            }

            double totalWidth = 0;

            for (i = 0; i < iWidth; i++) {
                totalWidth = totalWidth + iWidths[i];
            }

            double totalHeight = 0;

            for (j = 0; j < iHeight; j++) {
                totalHeight = totalHeight + iHeights[j];
            }

            iDimension = new Dimensions(totalWidth + spacing * (iWidth), totalHeight + spacing * (iHeight));
            iAscent = iDimension.height / 2;
        }

        if (aPosition != null) {

            int i;
            int j;
            double h = -iAscent;

            for (j = 0; j < iHeight; j++) {

                double maxAscent = -10000;

                for (i = 0; i < iWidth; i++) {

                    if (maxAscent < iExpressions[i + j * iWidth].iAscent) {
                        maxAscent = iExpressions[i + j * iWidth].iAscent;
                    }
                }

                h = h + maxAscent;

                double w = 0;

                for (i = 0; i < iWidth; i++) {
                    iExpressions[i + j * iWidth].calculatePositions(sg, aSize, new Position( (aPosition.x + w),  (aPosition.y + h)));
                    w += iWidths[i] + spacing;
                }

                h = h - maxAscent;
                h = h + iHeights[j] + spacing;
            }
        }
    }//end calculatePositions.


    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        int i;

        for (i = 0; i < iExpressions.length; i++) {

            if (iExpressions[i] != null) {
                iExpressions[i].render(sg);
            }
        }//end for.

    }//end render.


    public SymbolBox[] getChildren()
    {
        return this.iExpressions;
    }//end method.



    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Sum.java0000644000175000017500000000237511342172407031075 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Color;

public class Sum extends SymbolBox {

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {

        int height = ScaledGraphics.fontForSize(aSize);
        sg.setFontSize(height);
        iSize = aSize;
        iPosition = aPosition;
        iAscent = height / 2 + sg.getAscent();
        iDimension = new Dimensions((4 * height) / 3, 2 * height);
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg, Color.RED);

        int height = ScaledGraphics.fontForSize(iSize);
        sg.setLineThickness(2);

        double x0 = iPosition.x;
        double y0 = iPosition.y - iAscent;
        double x1 = x0 + iDimension.width;
        double y1 = y0 + iDimension.height;
        sg.drawLine(x1, y0, x0, y0);
        sg.drawLine(x0, y0, x0 + (2 * height) / 4, (y0 + y1) / 2);
        sg.drawLine(x0 + (2 * height) / 4, (y0 + y1) / 2, x0, y1);
        sg.drawLine(x0, y1, x1, y1);
    }



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[0];
    }//end method.




    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/PrefixOperator.java0000644000175000017500000000402411341631636033276 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;



public class PrefixOperator extends CompoundExpression {

    private SymbolBox iLeft;

    private SymbolBox iRight;

    public PrefixOperator(SymbolBox aLeft, SymbolBox aRight) {
        //super(2);
        iLeft = aLeft;
        iRight = aRight;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;

        // Get dimensions first
        if (iDimension == null) {
            iLeft.calculatePositions(sg, aSize, null);
            iRight.calculatePositions(sg, aSize, null);

            Dimensions dleft = iLeft.getDimension();
            Dimensions dright = iRight.getDimension();
            double height = dleft.height;

            if (height < dright.height) {
                height = dright.height;
            }

            iDimension = new Dimensions(dleft.width + dright.width + 2, height);
            iAscent = iLeft.getCalculatedAscent();

            if (iAscent < iRight.getCalculatedAscent()) {
                iAscent = iRight.getCalculatedAscent();
            }
        }

        if (aPosition != null) {

            Dimensions dleft = iLeft.getDimension();
            Dimensions dright = iRight.getDimension();
            iLeft.calculatePositions(sg, aSize, new Position(aPosition.x, aPosition.y)); /*+(iAscent-iLeft.getCalculatedAscent())*/
            iRight.calculatePositions(sg, aSize, new Position( (aPosition.x + dleft.width + 2), aPosition.y)); /*+(iAscent-iRight.getCalculatedAscent())*/
        }
    }//end calculatePositions.


    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iLeft.render(sg);

        iRight.render(sg);
    }//end render.



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[] {this.iLeft, this.iRight};
    }//end method.




    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/SuperSubFix.java0000644000175000017500000001347311342172407032551 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;


public class SuperSubFix extends CompoundExpression {

    double iExtent = 0;
    double iSubOffset = 0;
    double iSuperOffset = 0;

    private SymbolBox iExpr;

    private SymbolBox iSuperfix;

    private SymbolBox iSubfix;

    public SuperSubFix(SymbolBox aExpr, SymbolBox aSuperfix, SymbolBox aSubfix) {

        iExpr = aExpr;
        iSuperfix = aSuperfix;
        iSubfix = aSubfix;
    }

    public void setSuperfix(SymbolBox aExpression) {
        iSuperfix = aExpression;
    }

    public void setSubfix(SymbolBox aExpression) {
        iSubfix = aExpression;
    }

    public boolean hasSuperfix() {

        return (iSuperfix != null);
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;

        // Get dimensions first
        if (iDimension == null) {

            Dimensions dsfix = new Dimensions(0, 0);
            Dimensions dlfix = new Dimensions(0, 0);
            iExpr.calculatePositions(sg, aSize, null);

            if (iSuperfix != null) {
                iSuperfix.calculatePositions(sg, aSize - 1, null);
            }

            if (iSubfix != null) {
                iSubfix.calculatePositions(sg, aSize - 1, null);
            }

            Dimensions dexpr = iExpr.getDimension();

            if (iSuperfix != null) {
                dsfix = iSuperfix.getDimension();
            }

            if (iSubfix != null) {
                dlfix = iSubfix.getDimension();
            }

            if (iExpr instanceof Sum || iExpr instanceof Integral) {
                iSuperOffset = 0;
                iSubOffset = 0;

                if (iSuperfix != null) {
                    iExtent = iExtent + iSuperfix.iAscent;
                }

                if (iSubfix != null) {
                    iExtent = iExtent + iSubfix.iAscent;
                }

                double fixMaxWidth = dsfix.width;

                if (dlfix.width > fixMaxWidth) {
                    fixMaxWidth = dlfix.width;
                }

                if (dexpr.width > fixMaxWidth) {
                    fixMaxWidth = dexpr.width;
                }

                iDimension = new Dimensions(fixMaxWidth, (dexpr.height + iExtent));
            } else {

                if (iSuperfix != null) {
                    iSuperOffset = iSuperfix.getDimension().height - iSuperfix.iAscent - iExpr.getDimension().height / 4;
                    iExtent = iExtent + iSuperOffset + iSuperfix.iAscent;
                }

                if (iSubfix != null) {
                    iSubOffset = iSubfix.iAscent;

                    double delta = iSubOffset + (iSubfix.getDimension().height - iSubfix.iAscent) - (iExpr.getDimension().height - iExpr.iAscent);
                    iExtent = iExtent + delta;
                }

                double fixMaxWidth = dsfix.width;

                if (dlfix.width > fixMaxWidth) {
                    fixMaxWidth = dlfix.width;
                }

                iDimension = new Dimensions(dexpr.width + fixMaxWidth, (dexpr.height + iExtent));
            }

            iAscent = iExpr.getCalculatedAscent() + iExtent;

            if (iSubfix != null) {
                iAscent = iAscent - iSubfix.getDimension().height;
            }
        }

        if (aPosition != null) {

            Dimensions dsfix = new Dimensions(0, 0);
            Dimensions dlfix = new Dimensions(0, 0);
            Dimensions dexpr = iExpr.getDimension();

            if (iSuperfix != null) {
                dsfix = iSuperfix.getDimension();
            }

            if (iSubfix != null) {
                dlfix = iSubfix.getDimension();
            }

            iExpr.calculatePositions(sg, aSize, new Position(aPosition.x, aPosition.y));

            if (iExpr instanceof Sum || iExpr instanceof Integral) {

                if (iSuperfix != null) {
                    iSuperfix.calculatePositions(sg, aSize - 1, new Position(aPosition.x,  (aPosition.y - iExpr.iAscent - dsfix.height)));
                }

                if (iSubfix != null) {
                    iSubfix.calculatePositions(sg, aSize - 1, new Position(aPosition.x,  (aPosition.y + iSubfix.iAscent + dlfix.height)));
                }
            } else {

                if (iSuperfix != null) {
                    iSuperfix.calculatePositions(sg, aSize - 1, new Position( (aPosition.x + dexpr.width),  (aPosition.y - iExpr.iAscent - iSuperOffset)));
                }

                if (iSubfix != null) {
                    iSubfix.calculatePositions(sg, aSize - 1, new Position( (aPosition.x + dexpr.width),  (aPosition.y + iSubOffset)));
                }
            }
        }
    }//end calculate positions.

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iExpr.render(sg);

        if(iSuperfix != null)
        {
            iSuperfix.render(sg);
        }
        
        if(iSubfix != null)
        {
            iSubfix.render(sg);
        }
    }



    public SymbolBox[] getChildren()
    {
        if(this.iSuperfix == null)
        {
            return new SymbolBox[] {this.iExpr, this.iSubfix};
        }
        else if(this.iSubfix == null)
        {
            return new SymbolBox[] {this.iExpr, this.iSuperfix};
        }
        else
        {
            return new SymbolBox[] {this.iExpr, this.iSuperfix, this.iSubfix};
        }
        
    }//end method.




    public String toString()
    {   
        String returnString = "";
        
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Integral.java0000644000175000017500000000321411342433016032063 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Color;

public class Integral extends SymbolBox {

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {

        int height = ScaledGraphics.fontForSize(aSize);
        sg.setFontSize(height);
        iSize = aSize;
        iPosition = aPosition;
        iAscent = height / 2 + sg.getAscent();
        iDimension = new Dimensions((1 * height) / 2, 2 * height);
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg, Color.RED);

        int height = ScaledGraphics.fontForSize(iSize);
        sg.setLineThickness(2);

        double x0 = iPosition.x;
        double y0 = iPosition.y - iAscent;
        double x1 = x0 + iDimension.width;
        double y1 = y0 + iDimension.height;
        sg.drawLine(x1, y0, x1 - iDimension.width / 4, y0);
        sg.drawLine(x1 - iDimension.width / 4, y0, x1 - (2 * iDimension.width) / 4, y0 + iDimension.width / 4);
        sg.drawLine(x1 - (2 * iDimension.width) / 4, y0 + iDimension.width / 4, x1 - (2 * iDimension.width) / 4, y0 + iDimension.height - iDimension.width / 4);
        sg.drawLine(x1 - (2 * iDimension.width) / 4, y0 + iDimension.height - iDimension.width / 4, x1 - (3 * iDimension.width) / 4, y0 + iDimension.height);
        sg.drawLine(x1 - (3 * iDimension.width) / 4, y0 + iDimension.height, x0, y0 + iDimension.height);
    }



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[0];
    }//end method.




    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Dimensions.java0000644000175000017500000000240111341112700032414 0ustar  giovannigiovanni
package org.mathpiper.ui.gui.worksheets.symbolboxes;


public class Dimensions {


    public double width;


    public double height;




    public Dimensions() {
	this(0, 0);
    }


    public Dimensions(Dimensions d) {
	this(d.width, d.height);
    }


    public Dimensions(double width, double height) {
	this.width = width;
	this.height = height;
    }


    public double getWidth() {
	return width;
    }


    public double getHeight() {
	return height;
    }


    public void setSize(double width, double height) {
	this.width = width;
	this.height = height;
    }


    public Dimensions getSize() {
	return new Dimensions(width, height);
    }


    public void setSize(Dimensions d) {
	setSize(d.width, d.height);
    }


    public void setSize(int width, int height) {
    	this.width = width;
    	this.height = height;
    }


    public boolean equals(Object obj) {
	if (obj instanceof Dimensions) {
	    Dimensions d = (Dimensions)obj;
	    return (width == d.width) && (height == d.height);
	}
	return false;
    }


    public int hashCode() {
        double sum = width + height;
        return (int) (sum * (sum + 1)/2 + width);
    }


    public String toString() {
	return getClass().getName() + "[width=" + width + ",height=" + height + "]";
    }
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/SquareRoot.java0000644000175000017500000000321511341631636032432 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;

public class SquareRoot extends CompoundExpression {

    private SymbolBox iExpression;

    public SquareRoot(SymbolBox aExpression) {
        iExpression = aExpression;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;

        if (iDimension == null) {
            iExpression.calculatePositions(sg, aSize, null);

            Dimensions dim = iExpression.getDimension();
            iDimension = new Dimensions( (dim.width + 6), dim.height + 3);
            iAscent = iExpression.getCalculatedAscent() + 3;
        }

        if (aPosition != null) {

            Dimensions dim = iExpression.getDimension();
            iExpression.calculatePositions(sg, aSize, new Position( (aPosition.x + 6), aPosition.y));
        }
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iExpression.render(sg);

        sg.setLineThickness(1);

        Dimensions dim = iExpression.getDimension();
        double x0 = iPosition.x;
        double y0 = iPosition.y - iAscent;
        double x1 = x0 + dim.width + 6;
        double y1 = y0 + dim.height + 6;
        sg.drawLine(x0, y0 + 1, x0 + 3, y1 - 1);
        sg.drawLine(x0 + 3, y1 - 1, x0 + 6, y0 + 2);
        sg.drawLine(x0 + 6, y0 + 1, x1, y0 + 1);
    }



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[] {this.iExpression};
    }//end method.




    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/InfixOperator.java0000644000175000017500000000511011341703727033114 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;


public class InfixOperator extends CompoundExpression {

    private SymbolBox iLeft;

    private SymbolBox iInfix;

    private SymbolBox iRight;

    public InfixOperator(SymbolBox aLeft, SymbolBox aInfix, SymbolBox aRight) {
        iLeft = aLeft;
        iInfix = aInfix;
        iRight = aRight;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;

        // Get dimensions first
        if (iDimension == null) {
            iLeft.calculatePositions(sg, aSize, null);
            iInfix.calculatePositions(sg, aSize, null);
            iRight.calculatePositions(sg, aSize, null);

            Dimensions dleft = iLeft.getDimension();
            Dimensions dinfix = iInfix.getDimension();
            Dimensions dright = iRight.getDimension();
            double height = dleft.height;

            if (height < dinfix.height) {
                height = dinfix.height;
            }

            if (height < dright.height) {
                height = dright.height;
            }

            iDimension = new Dimensions(dleft.width + dinfix.width + dright.width + 4, height);
            iAscent = iLeft.getCalculatedAscent();

            if (iAscent < iInfix.getCalculatedAscent()) {
                iAscent = iInfix.getCalculatedAscent();
            }

            if (iAscent < iRight.getCalculatedAscent()) {
                iAscent = iRight.getCalculatedAscent();
            }
        }

        if (aPosition != null) {

            Dimensions dleft = iLeft.getDimension();
            Dimensions dinfix = iInfix.getDimension();
            Dimensions dright = iRight.getDimension();
            iLeft.calculatePositions(sg, aSize, new Position(aPosition.x, aPosition.y));
            iInfix.calculatePositions(sg, aSize, new Position( (aPosition.x + dleft.width + 2), aPosition.y) );
            iRight.calculatePositions(sg, aSize, new Position( (aPosition.x + dleft.width + dinfix.width + 4), aPosition.y));
        }
    }//end calculatePositions.


    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iLeft.render(sg);

        iInfix.render(sg);

        iRight.render(sg);
    }//end render.



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[] {this.iLeft, this.iInfix, this.iRight};
    }//end method.




    public String toString()
    {
        String returnString = ""; //this.iInfix.toString();
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Bounds.java0000644000175000017500000000236011344041476031560 0ustar  giovannigiovanni
package org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Dimension;


public class Bounds {


    public double top;

    public double bottom;

    public double left;

    public double right;




    public Bounds() {
	this(0, 0, 0, 0);
    }


    public Bounds(double top, double bottom, double left, double right) {
	this.top = top;
        this.bottom = bottom;
        this.left = left;
        this.right = right;
    }

    public double getBottom() {
        return bottom;
    }

    public void setBottom(double bottom) {
        this.bottom = bottom;
    }

    public double getLeft() {
        return left;
    }

    public void setLeft(double left) {
        this.left = left;
    }

    public double getRight() {
        return right;
    }

    public void setRight(double right) {
        this.right = right;
    }

    public double getTop() {
        return top;
    }

    public void setTop(double top) {
        this.top = top;
    }


    public Dimension  getScaledDimension(double scale)
    {
        return new Dimension((int)( (right - left)*scale), (int)( (bottom - top)*scale) );
    }


    public String toString() {
	return "[top=" + top + ",bottom=" + bottom + ",left=" + left + ",right=" + right + "]";
    }
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/SymbolName.java0000644000175000017500000001073111342172407032372 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Color;

public class SymbolName extends SymbolBox {

    public String iSymbol;

    public SymbolName(String aSymbol) {
        iSymbol = aSymbol;

        if (iSymbol.indexOf("\\") == 0) {

            if (iSymbol.equals("\\pi")) {
            } else if (iSymbol.equals("\\infty")) {
            } else if (iSymbol.equals("\\cdot")) {
            } else if (iSymbol.equals("\\wedge")) {
            } else if (iSymbol.equals("\\vee")) {
            } else if (iSymbol.equals("\\neq")) {
            } else {
                iSymbol = iSymbol.substring(1);
            }
        }
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {

        int height = ScaledGraphics.fontForSize(aSize);
        sg.setFontSize(height);
        iSize = aSize;
        iPosition = aPosition;

        if (iSymbol.equals("\\pi") || iSymbol.equals("\\wedge") || iSymbol.equals("\\vee")) {
            iDimension = new Dimensions(sg.getScaledTextWidth("M"), height);
            iAscent = sg.getAscent();
        } else if (iSymbol.equals("\\neq")) {
            iDimension = new Dimensions(sg.getScaledTextWidth("="), height);
            iAscent = sg.getAscent();
        } else if (iSymbol.equals("\\infty")) {
            iDimension = new Dimensions(sg.getScaledTextWidth("oo"), height);
            iAscent = sg.getAscent();
        } else if (iSymbol.equals("\\cdot")) {
            iDimension = new Dimensions(sg.getScaledTextWidth("."), height);
            iAscent = sg.getAscent();
        } else {
            iAscent = sg.getAscent();
            iDimension = new Dimensions(sg.getScaledTextWidth(iSymbol), height);
        }
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg, Color.RED);

        if (iSymbol.equals("\\pi")) {

            double deltax = 0.15 * iDimension.width;
            double deltay = 0.2 * iDimension.height;
            sg.drawLine( (iPosition.x + 1 * deltax),  (iPosition.y - iAscent + 2 * deltay),  (iPosition.x + iDimension.width - 1 * deltax),  (iPosition.y - iAscent + 2 * deltay));
            sg.drawLine( (iPosition.x + 2 * deltax),  (iPosition.y - iAscent + 2 * deltay),  (iPosition.x + 2 * deltax),  (iPosition.y - iAscent + iDimension.height + 0 * deltay));
            sg.drawLine( (iPosition.x + iDimension.width - 2 * deltax),  (iPosition.y - iAscent + 2 * deltay),  (iPosition.x + iDimension.width - 2 * deltax),  (iPosition.y - iAscent + iDimension.height + 0 * deltay));
        } else if (iSymbol.equals("\\wedge") || iSymbol.equals("\\vee")) {

            double deltax = 0.15 * iDimension.width;
            double deltay = 0.2 * iDimension.height;
            double ytip = (iPosition.y - iAscent + iDimension.height + 0 * deltay);
            double ybase = (iPosition.y - iAscent + 2 * deltay);

            if (iSymbol.equals("\\wedge")) {

                double swap = ytip;
                ytip = ybase;
                ybase = swap;
            }

            sg.drawLine( (iPosition.x + 1 * deltax), ybase, iPosition.x + iDimension.width / 2, ytip);
            sg.drawLine( (iPosition.x + iDimension.width - 1 * deltax), ybase, iPosition.x + iDimension.width / 2, ytip);
        } else if (iSymbol.equals("\\neq")) {
            sg.setFontSize(ScaledGraphics.fontForSize(iSize));
            sg.drawText("=", iPosition.x, iPosition.y);
            sg.drawLine(iPosition.x + (2 * iDimension.width) / 3, iPosition.y - iAscent + (2 * iDimension.height) / 6, iPosition.x + (1 * iDimension.width) / 3, iPosition.y - iAscent + (6 * iDimension.height) / 6);
        } else if (iSymbol.equals("\\infty")) {
            sg.setFontSize(ScaledGraphics.fontForSize(iSize));
            sg.drawText("o", iPosition.x + 1, iPosition.y);
            sg.drawText("o", iPosition.x + sg.getScaledTextWidth("o") - 2, iPosition.y);
        } else if (iSymbol.equals("\\cdot")) {

            int height = ScaledGraphics.fontForSize(iSize);
            sg.setFontSize(height);
            sg.drawText(".", iPosition.x, iPosition.y - height / 3);
        } else {
            sg.setFontSize(ScaledGraphics.fontForSize(iSize));
            sg.drawText(iSymbol, iPosition.x, iPosition.y);
        }
    }



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[0];
    }//end method.




    public String toString()
    {
        String returnString = "";
        
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/ScaledGraphics.java0000644000175000017500000001211211344040537033173 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.*;

public class ScaledGraphics {

    private double viewScale = 1.0;
    private Graphics iG = null;
    private Graphics2D iG2D = null;
    int prevGray = -1;
    int prevSetFontSize = -1;
    FontMetrics metrics = null;

    public ScaledGraphics(Graphics g) {
        iG = g;
        if (g instanceof Graphics2D) {
            iG2D = (Graphics2D) g;
        }
    }

    public void setLineThickness(double aThickness) {
        if (iG2D != null) {
            iG2D.setStroke(new BasicStroke((float) (aThickness * viewScale), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
        }
    }

    public void drawLine(double x0, double y0, double x1, double y1) {
        iG.drawLine((int) (x0 * viewScale), (int) (y0 * viewScale), (int) (x1 * viewScale), (int) (y1 * viewScale));
    }


    public void drawArc(double x,double y,double width,double height,int startAngle,int arcAngle) {
        //iG.drawLine((int) (x0 * viewScale), (int) (y0 * viewScale), (int) (x1 * viewScale), (int) (y1 * viewScale));
        iG.drawArc((int) (x * viewScale), (int) (y * viewScale), (int) (width * viewScale), (int) (height * viewScale), startAngle, arcAngle);
    }

    public void drawRectangle(double x, double y, double width, double height) {
        iG.drawRect((int) (x * viewScale), (int) (y * viewScale), (int) (width * viewScale), (int) (height * viewScale));
    }

    public void setGray(int aGray) {
        if (prevGray != aGray) {
            prevGray = aGray;
            iG.setColor(new Color(aGray, aGray, aGray));
        }
    }

    public void drawText(String text, double x, double y) {
        iG.drawString(text, (int) (x * viewScale), (int) (y * viewScale));
    }

    public void drawscaledText(String text, double x, double y, double scale) {
        double normalFontSize = getFontSize();

        double scaledFontSize = normalFontSize * scale;

        setFontSize(scaledFontSize);

        iG.drawString(text, (int) (x * viewScale), (int) (y * viewScale));

        setFontSize(normalFontSize);

    }


    public void setFontSize(double aSize) {
        int newFontSize = (int) (viewScale * aSize);
        if (prevSetFontSize != newFontSize) {
            prevSetFontSize = newFontSize;
            Font f = new Font("Verdana", Font.PLAIN, newFontSize);
            if (f != null) {
                iG.setFont(f);
                metrics = iG.getFontMetrics();
            }
        }
    }

    public double getFontSize() {
        return  (prevSetFontSize / viewScale);
    }

    public double getScaledTextWidth(String text) {
        java.awt.geom.Rectangle2D textBoundingRectangle = metrics.getStringBounds(text, iG);
        return  (textBoundingRectangle.getWidth() / viewScale);
    }

    public double getScaledTextHeight(String text) {
        java.awt.geom.Rectangle2D textBoundingRectangle = metrics.getStringBounds(text, iG);
        return  (textBoundingRectangle.getHeight() / viewScale);
    }

    public double getTextWidth(String text) {
        java.awt.geom.Rectangle2D textBoundingRectangle = metrics.getStringBounds(text, iG);
        return  textBoundingRectangle.getWidth();
    }

    public double getTextHeight(String text) {
        java.awt.geom.Rectangle2D textBoundingRectangle = metrics.getStringBounds(text, iG);
        return  textBoundingRectangle.getHeight();
    }

    public double getAscent() {
        return (metrics.getAscent() / viewScale);
    }

    public double getDescent() {
        return  (metrics.getDescent() / viewScale);
    }

    public void setViewScale(double aViewScale) {
        viewScale = aViewScale;
    }

    public void setColor(Color color) {
        if (iG2D != null) {
            iG2D.setColor(color);
        } else if (iG != null) {
            iG.setColor(color);
        }

    }//end method.
    
    public static int fontForSize(int aSize) {

        if (aSize > 3) {
            aSize = 3;
        }

        if (aSize < 0) {
            aSize = 0;
        }

        switch (aSize) {

            case 0:
                return 6;

            case 1:
                return 8;

            case 2:
                return 12;

            case 3:
                return 16;

            default:
                return 16;
        }//end switch.
        
    }//end method.


}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Position.java0000644000175000017500000000217111341146766032137 0ustar  giovannigiovanni

package org.mathpiper.ui.gui.worksheets.symbolboxes;




public class Position {

    public double x;


    public double y;


    public Position() {
	this(0, 0);
    }


    public Position(Position p) {
	this(p.x, p.y);
    }


    public Position(double x, double y) {
	this.x = x;
	this.y = y;
    }


    public double getX() {
	return x;
    }


    public double getY() {
	return y;
    }


    public Position getLocation() {
	return new Position(x, y);
    }


    public void setLocation(Position p) {
	setLocation(p.x, p.y);
    }


    public void setLocation(int x, int y) {
	move(x, y);
    }


    public void setLocation(double x, double y) {
	this.x = x;
	this.y = y;
    }


    public void move(double x, double y) {
	this.x = x;
	this.y = y;
    }


    public void translate(double dx, double dy) {
	this.x += dx;
	this.y += dy;
    }


    public boolean equals(Object obj) {
	if (obj instanceof Position) {
	    Position pt = (Position)obj;
	    return (x == pt.x) && (y == pt.y);
	}
	return super.equals(obj);
    }


    public String toString() {
	return getClass().getName() + "[x=" + x + ",y=" + y + "]";
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Fraction.java0000644000175000017500000000477111341631636032103 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.worksheets.symbolboxes;

public class Fraction extends CompoundExpression {

    private int iDashheight = 0;

    private SymbolBox iNumerator;

    private SymbolBox iDenominator;

    public Fraction(SymbolBox aNumerator, SymbolBox aDenominator) {

        iNumerator = aNumerator;

        iDenominator = aDenominator;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;
        iDashheight = ScaledGraphics.fontForSize(iSize);

        if (iDimension == null) {
            iNumerator.calculatePositions(sg, aSize, null);
            iDenominator.calculatePositions(sg, aSize, null);

            Dimensions ndim = iNumerator.getDimension();
            Dimensions ddim = iDenominator.getDimension();
            double width = ndim.width;

            if (width < ddim.width) {
                width = ddim.width;
            }

            iDimension = new Dimensions(width, ndim.height + ddim.height + iDashheight);
            iAscent = ndim.height + iDashheight;
        }

        if (aPosition != null) {

            Dimensions ndim = iNumerator.getDimension();
            Dimensions ddim = iDenominator.getDimension();
            double ynumer = aPosition.y - ndim.height + iNumerator.getCalculatedAscent() - iDashheight;
            double ydenom = aPosition.y + iDenominator.getCalculatedAscent();
            iNumerator.calculatePositions(sg, aSize, new Position( (aPosition.x + (iDimension.width - ndim.width) / 2), ynumer));
            iDenominator.calculatePositions(sg, aSize, new Position( (aPosition.x + (iDimension.width - ddim.width) / 2), ydenom));
        }
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iNumerator.render(sg);
        
        iDenominator.render(sg);

        Dimensions ndim = iNumerator.getDimension();
        Dimensions ddim = iDenominator.getDimension();
        double width = ndim.width;

        if (width < ddim.width) {
            width = ddim.width;
        }

        sg.setLineThickness(1);
        sg.drawLine(iPosition.x, iPosition.y - iDashheight / 2 + 2, iPosition.x + width, iPosition.y - iDashheight / 2 + 2);
    }



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[] {this.iNumerator, this.iDenominator};
    }//end method.





    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/Bracket.java0000644000175000017500000001134311355310103031666 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */
package org.mathpiper.ui.gui.worksheets.symbolboxes;

public class Bracket extends CompoundExpression {

    double iBracketWidth;
    String iClose;
    double iFontSize;
    String iOpen;

    private SymbolBox iExpression;

    public Bracket(SymbolBox aExpression, String aOpen, String aClose) {
        //super(1);
        iOpen = aOpen;
        iClose = aClose;
        iExpression = aExpression;
    }

    public void calculatePositions(ScaledGraphics sg, int aSize, Position aPosition) {
        iSize = aSize;
        iPosition = aPosition;

        if (iDimension == null) {
            iExpression.calculatePositions(sg, aSize, null);

            Dimensions dim = iExpression.getDimension();
            iFontSize =  dim.height;
            sg.setFontSize( dim.height);
            iBracketWidth = ScaledGraphics.fontForSize(aSize) / 2;
            iDimension = new Dimensions(dim.width + 2 * iBracketWidth, dim.height);
            iAscent = iExpression.getCalculatedAscent();
        }

        if (aPosition != null) {

            Dimensions dim = iExpression.getDimension();
            iExpression.calculatePositions(sg, aSize, new Position(aPosition.x + iBracketWidth, aPosition.y));
        }
    }

    public void render(ScaledGraphics sg) {

        if(drawBoundingBox) drawBoundingBox(sg);

        iExpression.render(sg);

        Dimensions dim = iExpression.getDimension();
        drawBracket(sg, iOpen, iPosition.x, iPosition.y - getCalculatedAscent());
        drawBracket(sg, iClose, iPosition.x + dim.width + iBracketWidth, iPosition.y - getCalculatedAscent());
    }

    void drawBracket(ScaledGraphics sg, String bracket, double x, double y) {

        Dimensions dim = iExpression.getDimension();

        if (bracket.equals("[") || bracket.equals("]")) {

            int margin = 2;
            sg.setLineThickness(2);

            if (bracket.equals("[")) {
                sg.drawLine(x + margin, y, x + margin, y + dim.height);
            } else {
                sg.drawLine(x + iBracketWidth - margin, y, x + iBracketWidth - margin, y + dim.height);
            }

            sg.setLineThickness(1);
            sg.drawLine(x + iBracketWidth - margin, y, x + margin, y);
            sg.drawLine(x + margin, y + dim.height, x + iBracketWidth - margin, y + dim.height);
        } else if (bracket.equals("(") || bracket.equals(")")) {

            double xstart;
            double xend;

            if (bracket.equals("(")) {
                xstart = x + iBracketWidth;
                xend = x;
            } else {
                xstart = x;
                xend = x + iBracketWidth;
            }

            double delta = xend - xstart;

            double[] steps = new double[3];

            double verticalOffset = 2;

            steps[0] = 0.2;
            steps[1] = 0.6;
            steps[2] = 0.8;

            sg.setLineThickness(1.1);
            sg.drawLine( (xstart + (delta * steps[0])), y + verticalOffset + (0 * dim.height) / 6,  xstart + (delta * steps[1]), y + verticalOffset + (1 * dim.height) / 6);

            sg.setLineThickness(1.3);
            sg.drawLine( (xstart + (delta * steps[1])), y + verticalOffset + (1 * dim.height) / 6,  xstart + (delta * steps[2]), y + verticalOffset + (2 * dim.height) / 6);

            sg.setLineThickness(1.5);
            sg.drawLine( (xstart + (delta * steps[2])), y + verticalOffset + (2 * dim.height) / 6,  xstart + (delta * steps[2]), y + verticalOffset + (4 * dim.height) / 6);

            sg.setLineThickness(1.3);
            sg.drawLine( (xstart + (delta * steps[2])), y + verticalOffset + (4 * dim.height) / 6, xstart + (delta * steps[1]), y + verticalOffset + (5 * dim.height) / 6);

            sg.setLineThickness(1.1);
            sg.drawLine( (xstart + (delta * steps[1])), y + verticalOffset + (5 * dim.height) / 6, xstart + (delta * steps[0]), y + verticalOffset + (6 * dim.height) / 6);


           /* sg.setColor(Color.RED);
            sg.setLineThickness(1.6);
            sg.drawLine( (xstart + (delta * steps[2])), y + (2 * dim.getTextHeight) / 6,  xstart + (delta * steps[2]), y + (4 * dim.getTextHeight) / 6);

            sg.drawArc(xstart + (delta * .8), y + (0 * dim.getTextHeight)/6,30, 30, 180, -60);
            sg.setColor(Color.black);*/

        } else {
            sg.setFontSize(iFontSize);

            double offset = (iFontSize - iAscent) / 2;
            sg.drawText(bracket, x, y + offset);
        }
    }//end method.



    public SymbolBox[] getChildren()
    {
        return new SymbolBox[] {this.iExpression};
    }//end method.



    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/CompoundExpression.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/symbolboxes/CompoundExpression.jav0000644000175000017500000000226311355310103034017 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */
package org.mathpiper.ui.gui.worksheets.symbolboxes;

import java.awt.Color;

abstract class CompoundExpression extends SymbolBox {

    //SymbolBox[] iExpressions;

   /* CompoundExpression(int aNrSubExpressions) {
        iExpressions = new SymbolBox[aNrSubExpressions];
    }*/

    public void render(ScaledGraphics sg) {

    }

    
    public void drawBoundingBox(ScaledGraphics sg) {

        drawBoundingBox(sg, Color.BLUE);
        /*sg.setColor(Color.blue);
        sg.setLineThickness(0);

        double x0 = iPosition.x;
        double y0 = iPosition.y - getCalculatedAscent();
        double x1 = x0 + iDimension.getTextWidth;
        double y1 = y0 + iDimension.getTextHeight;
        sg.drawLine(x0, y0, x1, y0);
        sg.drawLine(x1, y0, x1, y1);
        sg.drawLine(x1, y1, x0, y1);
        sg.drawLine(x0, y1, x0, y0);

        sg.drawscaledText("" + sequence++, x0, y0 + 3, .2);

        sg.setColor(Color.black);*/



    }



    public String toString()
    {
        String returnString = "";
        return returnString;
    }//end method.

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/ConsoleApplet.java0000644000175000017500000014072111422223770030530 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets;

import org.mathpiper.ui.gui.worksheets.hints.Hints;
import org.mathpiper.ui.gui.worksheets.hints.HintWindow;
import org.mathpiper.ui.gui.worksheets.hints.HintItem;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedStringLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.ImageLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.MathOutputLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedGraph2DLine;
import org.mathpiper.ui.gui.worksheets.mathoutputlines.PromptedFormulaLine;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.io.CachedStandardFileInputStream;

import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import java.awt.datatransfer.Clipboard;
import java.awt.datatransfer.ClipboardOwner;
import java.awt.datatransfer.Transferable;
import java.awt.datatransfer.StringSelection;
import java.awt.datatransfer.DataFlavor;
import java.awt.*;
import java.awt.event.*;
import java.applet.*;
import java.io.*;
import java.net.*;
import org.mathpiper.Version;
import org.mathpiper.interpreters.EvaluationResponse;

public class ConsoleApplet extends Applet implements KeyListener, FocusListener, ClipboardOwner, MouseListener, MouseMotionListener, Console
{

    AppletOutput out;
    boolean focusGained = false;
    boolean scrolling = false;
    int yDown = 0;
    int yStart = 0;
    boolean calculating = false;
    MathPiperOutputStream stdoutput = null;
    Interpreter interpreter = null;
    StringBuffer outputStringBuffer = new StringBuffer();
    boolean gotDatahubInit = false;
    final static int nrLines = 100;
    MathOutputLine lines[] = new MathOutputLine[nrLines];
    int currentLine = 0;
    int totalLinesHeight = 0;
    String inputLine = new String();
    String gatheredMultiLine = new String();
    int cursorPos = 0;
    final int inset = 5;
    final static String inputPrompt = "In> ";
    final static String outputPrompt = "Result: ";
    static final int fontHeight = 14;
    private Font font = new Font("Verdana", Font.PLAIN, fontHeight);
    private static final int nrHistoryLines = 100;
    public static String history[] = new String[nrHistoryLines];
    public static int currentHistoryLine = 0;
    static int historyBrowse = 0;
    boolean inputDirty = true;
    boolean outputDirty = true;
    Image piperLogo = null;
    Image offImg = null;
    Graphics offGra = null;
    Color bkColor = new Color(255, 255, 255);
    HintWindow hintWindow = null;
    Hints the_hints = new Hints();
    boolean thumbMoused = false;
    int scrollWidth = 16;
    int thumbPos = 0;
    String lastMatchedWord = "";
    String matchToInsert = "";
    int ito = -1;
    String lastError;
    /// Applet initialization
    public void init()
    {
        setBackground(bkColor);
        setLayout(null);
        this.setPreferredSize(new Dimension(400,400));
        addKeyListener(this);
        addFocusListener(this);
        addMouseListener(this);
        addMouseMotionListener(this);

        out = new AppletOutput(this);
        resetInput();

        String hintsfilename = getDocumentBase().toString();
        int slash = hintsfilename.lastIndexOf('/');
        if (slash >= 0)
        {
            hintsfilename = hintsfilename.substring(0, slash + 1);
        }
        hintsfilename = hintsfilename + "hints.txt";
        loadHints(hintsfilename);
    }

    public void focusGained(FocusEvent evt)
    {
        focusGained = true;
        inputDirty = true;
        outputDirty = true;
        if (!gotDatahubInit)
        {
            start();
        }
        repaint();
    }

    public void focusLost(FocusEvent evt)
    {
        focusGained = false;
        inputDirty = true;
        outputDirty = true;
        repaint();
    }

    public void mouseClicked(MouseEvent event)
    {
    }

    public void mouseEntered(MouseEvent event)
    {
    }

    public void mouseExited(MouseEvent event)
    {
    }

    public void mousePressed(MouseEvent event)
    {
        scrolling = false;
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (canvasHeight < totalLinesHeight)
        {
            int x = event.getX();
            int y = event.getY();
            if (x > w - scrollWidth && y < canvasHeight)
            {

                if (y >= thumbPos + 2 && y <= thumbPos + 2 + th)
                {
                    yDown = y;
                    yStart = thumbPos;
                } else
                {
                    thumbPos = y - 2;
                    clipThumbPos();
                }
                scrolling = true;
                thumbMoused = true;
                outputDirty = true;
                repaint();
            }
        }
    }

    public void mouseReleased(MouseEvent event)
    {
        if (scrolling)
        {
            scrolling = false;
            return;
        } else if (hintWindow != null)
        {
            if (matchToInsert.length() > 0)
            {
                inputLine = inputLine.substring(0, ito) + matchToInsert + inputLine.substring(ito, inputLine.length());
                cursorPos += matchToInsert.length();
                refreshHintWindow();
                repaint();
                return;
            }
        }
    }

    public void mouseMoved(MouseEvent event)
    {
        boolean newthumbMoused = false;
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (canvasHeight < totalLinesHeight)
        {
            int x = event.getX();
            int y = event.getY();
            if (x > getWidth() - scrollWidth && y < canvasHeight)
            {
                newthumbMoused = true;
            }
        }
        if (thumbMoused != newthumbMoused)
        {
            thumbMoused = newthumbMoused;
            outputDirty = true;
            repaint();
        }
    }

    void clipThumbPos()
    {
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        if (thumbPos < 0)
        {
            thumbPos = 0;
        }
        if (thumbPos > canvasHeight - th - 4)
        {
            thumbPos = canvasHeight - th - 4;
        }
    }

    public void mouseDragged(MouseEvent event)
    {
        int th = calcThumbHeight();
        int canvasHeight = getHeight() - fontHeight - 1;
        int w = getWidth();
        if (scrolling)
        {
            int x = event.getX();
            int y = event.getY();
            thumbPos = yStart + (y - yDown);
            clipThumbPos();
            outputDirty = true;
            repaint();
        }
    }

    public void lostOwnership(Clipboard clipboard, Transferable contents)
    {
    }

    public void start()
    {
        clearOutputLines();
        if (false /*TODO remove loading the logo piperLogo == null*/)
        {
            try
            {
                String fname = getDocumentBase().toString();
                int ind = fname.lastIndexOf("/");
                if (ind > 0)
                {
                    fname = fname.substring(0, ind + 1) + "piper.gif";
                    piperLogo = getImage(new URL(fname));
                }
            } catch (Exception e)
            {
            }
        }


        //stdoutput = new StringOutputStream(outp);
        String docBase = getDocumentBase().toString();
        interpreter = Interpreters.getSynchronousInterpreter(docBase);
        interpreter.getEnvironment().iCurrentInput = new CachedStandardFileInputStream(interpreter.getEnvironment().iInputStatus);


        if (piperLogo != null)
        {
            addLine(new ImageLine(piperLogo, this));
        }
        {
            String s;
            int bkred = 255;
            int bkgrn = 255;
            int bkblu = 255;
            s = getParameter("bkred");
            if (s != null)
            {
                bkred = Integer.parseInt(s);
            }
            s = getParameter("bkgrn");
            if (s != null)
            {
                bkgrn = Integer.parseInt(s);
            }
            s = getParameter("bkblu");
            if (s != null)
            {
                bkblu = Integer.parseInt(s);
            }
            bkColor = new Color(bkred, bkgrn, bkblu);
            setBackground(bkColor);
        }
        {



            Font font = new Font("helvetica", Font.PLAIN, 12);
            Color c = new Color(96, 96, 96);

            addLineStatic(100, "", "", font, c);
            addLineStatic(100, "", "", font, c);
            addLineStatic(100, "", "MathPiper version '" + Version.version + "'.", font, c);
            addLineStatic(100, "", "Type 'restart' to restart MathPiper, or 'cls' to clear screen.\n", font, c);
            addLineStatic(100, "", "To see example commands, keep typing 'Example();'\n", font, c);
        }
        /*{
            String docbase = getDocumentBase().toString();

            if (docbase.substring(0, 4).equals("file"))
            {
                int pos = docbase.lastIndexOf("/");
                String zipFileName = docbase.substring(0, pos + 1) + "mathpiper.jar";
                zipFileName = "file://" + zipFileName.substring(5,zipFileName.length());
                if (getParameter("debug") != null)
                {
                    AddLineStatic(100, "", " '" + zipFileName + "'.", font, Color.red);
                }
               try
                {
                    java.util.zip.ZipFile z = new java.util.zip.ZipFile(new File(new java.net.URI(zipFileName)));
                    UtilityFunctions.zipFile = z;
                } catch (Exception e)
                {
                    out.println("Failed to find mathpiper.jar");
                    out.println("" + zipFileName + " : \n");
                    out.println(e.toString());
                }
            }
            if (docbase.startsWith("http"))
            {
                //jar:http://www.xs4all.nl/~apinkus/interpreter.jar!/
                int pos = docbase.lastIndexOf("/");
                String scriptBase = "jar:" + docbase.substring(0, pos + 1) + "mathpiper.jar!/";
                if (getParameter("debug") != null)
                {
                    AddLineStatic(100, "", " '" + scriptBase + "'.", font, Color.red);
                }

                interpreter.evaluate("DefaultDirectory(\"" + scriptBase + "\");");
            }
        }*/

        try
        {
            out.println("");
        } catch (Exception e)
        {
            out.println(e);
        }

        //This is where the initialization parameters from the browser are initialized. tk.
        int i = 1;
        while (true)
        {
            String argn = "init" + i;
            String s = getParameter(argn);
            if (s == null)
            {
                break;
            }
            s = unescape(s);

            EvaluationResponse response = interpreter.evaluate(s);

            i++;
        }

        gotDatahubInit = false;
        tryInitThroughDatahub();

        i = 1;
        while (true)
        {
            String argn = "history" + i;
            String s = getParameter(argn);
            if (s == null)
            {
                break;
            }
            s = unescape(s);
            appendHistoryLine(s);
            i++;
        }

        resetInput();
    }

    void tryInitThroughDatahub()
    {
        if (!gotDatahubInit)
        {
            //programMode browser parameter is used here. tk.
            String programMode = getParameter("programMode");
            if (programMode == null)
            {
                gotDatahubInit = true;
            } else
            {
                try
                {
                    Applet dataHub = getAppletContext().getApplet("datahub");
                    if (dataHub != null)
                    {
                        org.mathpiper.ui.gui.applets.storage.DatahubApplet cons = (org.mathpiper.ui.gui.applets.storage.DatahubApplet) dataHub;
                        cons.setProgramMode(programMode);

                        String programContentsToLoad = "[" + cons.getProgram() + "];";
                        gotDatahubInit = true; // We're already satisfied here, as we got the contents from the datahub.
                        invokeCalculationSilent(programContentsToLoad);
                    }
                } catch (Exception e)
                {
                }
            }
        }
    }

    public void stop()
    {
    }

    public void appendHistoryLine(String line)
    {
        //TODO optimize! We need to wrap around the history buffer, this is inefficient.
        if (currentHistoryLine == nrHistoryLines)
        {
            int i;
            for (i = 0; i < currentHistoryLine - 1; i++)
            {
                history[i] = history[i + 1];
            }
            currentHistoryLine--;
        }
        history[currentHistoryLine] = line;
        currentHistoryLine++;
    }

    private String unescape(String s)
    {
        StringBuffer buf = new StringBuffer();
        int i, nr = s.length();
        for (i = 0; i < nr; i++)
        {
            if (s.charAt(i) == '\'' && s.charAt(i + 1) == '\'')
            {
                buf.append('\"');
                i++;
            } else
            {
                buf.append(s.charAt(i));
            }
        }
        return buf.toString();
    }

    public void resetInput()
    {
        if (inputLine.length() > 0)
        {
            if (inputLine.charAt(inputLine.length() - 1) != '\\')
            {
                gatheredMultiLine = "";
            }
        }
        inputLine = "";
        cursorPos = 0;
        historyBrowse = currentHistoryLine;
        inputDirty = true;
    }

    /// Applet destruction
    public void destroy()
    {
    }

    public void keyPressed(KeyEvent e)
    {
        processKeyEvent(e);
    }

    public void keyTyped(KeyEvent e)
    {
        //    processKeyEvent(e);
    }

    public void keyReleased(KeyEvent e)
    {
        //    processKeyEvent(e);
    }

    public void setClipboardContents(String aString)
    {
        StringSelection stringSelection = new StringSelection(aString);
        Clipboard clipboard = Toolkit.getDefaultToolkit().getSystemClipboard();
        clipboard.setContents(stringSelection, this);
    }

    public String getClipboardContents()
    {
        String result = "";
        Clipboard clipboard = Toolkit.getDefaultToolkit().getSystemClipboard();
        //odd: the Object param of getContents is not currently used
        Transferable contents = clipboard.getContents(null);
        boolean hasTransferableText = (contents != null) &&
                contents.isDataFlavorSupported(DataFlavor.stringFlavor);
        if (hasTransferableText)
        {
            try
            {
                result = (String) contents.getTransferData(DataFlavor.stringFlavor);
            } catch (java.awt.datatransfer.UnsupportedFlavorException ex)
            {
                //highly unlikely since we are using a standard DataFlavor
                System.out.println(ex);
            } catch (IOException ex)
            {
                System.out.println(ex);
            }
        }
        return result;
    }

    protected void processKeyEvent(KeyEvent e)
    {
        inputDirty = true;
        if ((e.getModifiers() & InputEvent.CTRL_MASK) == InputEvent.CTRL_MASK)
        {
            if (KeyEvent.KEY_PRESSED != e.getID())
            {
                return;
            }
            if (e.getKeyCode() == (int) 'C')
            {
                //out.println("Copy");
                setClipboardContents(gatheredMultiLine + inputLine);
            } else if (e.getKeyCode() == (int) 'V')
            {
                try
                {
                    String toInsert = getClipboardContents();
                    if (toInsert != null)
                    {
                        int cr = toInsert.indexOf('\n');
                        while (cr >= 0)
                        {
                            inputLine = inputLine + toInsert.substring(0, cr);
                            toInsert = toInsert.substring(cr + 1, toInsert.length());
                            cr = toInsert.indexOf('\n');

                            appendHistoryLine(inputLine);
                            addLinesStatic(48, inputPrompt, inputLine);
                            if (inputLine.charAt(inputLine.length() - 1) == '\\')
                            {
                                gatheredMultiLine = gatheredMultiLine + inputLine.substring(0, inputLine.length() - 1);
                            } else
                            {
                                performRequest("Result: ", gatheredMultiLine + inputLine, true);
                            }
                            resetInput();
                        }
                        inputLine = inputLine + toInsert;
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                } catch (Exception ex)
                {
                }
            } else
            {
                return;
            }
        }

        if (KeyEvent.KEY_PRESSED == e.getID())
        {
            if (e.VK_SHIFT == e.getKeyCode())
            {
                return;
            }
            if (e.VK_CONTROL == e.getKeyCode())
            {
                return;
            }
            if (e.VK_ALT == e.getKeyCode())
            {
                return;
            } else if (e.VK_HOME == e.getKeyCode())
            {
                cursorPos = 0;
            } /*Does not seem to work?
            else if (e.VK_COPY == e.getKeyCode())
            {
            System.out.println("COPY");
            }
            else if (e.VK_PASTE == e.getKeyCode())
            {
            System.out.println("PASTE");
            }
             */ else if (e.VK_END == e.getKeyCode())
            {
                cursorPos = inputLine.length();
            } else if (e.VK_LEFT == e.getKeyCode())
            {
                if (cursorPos > 0)
                {
                    cursorPos--;
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_BACK_SPACE == e.getKeyCode())
            {
                if (cursorPos > 0)
                {
                    cursorPos--;
                    inputLine = new StringBuffer(inputLine).delete(cursorPos, cursorPos + 1).toString();
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_DELETE == e.getKeyCode())
            {
                if (inputLine.length() > 0)
                {
                    if (cursorPos == inputLine.length())
                    {
                        cursorPos--;
                    }
                    inputLine = new StringBuffer(inputLine).delete(cursorPos, cursorPos + 1).toString();
                    refreshHintWindow();
                    repaint();
                    return;
                }
            } else if (e.VK_ESCAPE == e.getKeyCode())
            {
                if (hintWindow != null)
                {
                    hintWindow = null;
                } else
                {
                    resetInput();
                }
                repaint();
                return;
            } else if (e.VK_UP == e.getKeyCode())
            {
                boolean handled = false;
                if (hintWindow != null)
                {
                    if (hintWindow.iAllowSelection)
                    {
                        handled = true;
                        if (hintWindow.iCurrentPos > 0)
                        {
                            hintWindow.iCurrentPos--;
                            repaint();
                        }
                    }
                }

                if (!handled)
                {
                    handled = true;
                    String prefix = inputLine.substring(0, cursorPos);
                    int i = historyBrowse - 1;
                    while (i > 0)
                    {
                        if (history[i].startsWith(prefix))
                        {
                            break;
                        }
                        i--;
                    }
                    if (i >= 0 && i != historyBrowse && history[i].startsWith(prefix))
                    {
                        historyBrowse = i;
                        inputLine = history[historyBrowse];
                    }
                }
            } else if (e.VK_DOWN == e.getKeyCode())
            {
                boolean handled = false;
                if (hintWindow != null)
                {
                    if (hintWindow.iAllowSelection)
                    {
                        handled = true;
                        if (hintWindow.iCurrentPos < hintWindow.iNrLines - 1)
                        {
                            hintWindow.iCurrentPos++;
                            repaint();
                        }
                    }
                }

                if (!handled)
                {
                    String prefix = inputLine.substring(0, cursorPos);
                    int i = historyBrowse + 1;
                    while (i < currentHistoryLine)
                    {
                        if (history[i].startsWith(prefix))
                        {
                            break;
                        }
                        i++;
                    }
                    if (i < currentHistoryLine && history[i].startsWith(prefix))
                    {
                        historyBrowse = i;
                        inputLine = history[historyBrowse];
                    } else
                    {
                        int pos = cursorPos;
                        resetInput();
                        inputLine = prefix;
                        cursorPos = pos;
                    }
                }
            } else if (e.VK_RIGHT == e.getKeyCode())
            {
                boolean handled = false;

                if (!handled)
                {
                    handled = true;
                    if (cursorPos < inputLine.length())
                    {
                        cursorPos++;
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                }
            } else if (e.VK_ENTER == e.getKeyCode())
            {
                boolean handled = false;

                if (!handled)
                {
                    if (cursorPos == ito && matchToInsert.length() > 0)
                    {
                        //System.out.println("matchToInsert = "+matchToInsert);
                        handled = true;
                        inputLine = inputLine.substring(0, ito) + matchToInsert + inputLine.substring(ito, inputLine.length());
                        cursorPos += matchToInsert.length();
                        refreshHintWindow();
                        repaint();
                        return;
                    }
                }
                if (!handled)
                {
                    if (hintWindow != null)
                    {
                        if (cursorPos == ito && hintWindow.iAllowSelection)
                        {
                            handled = true;
                            String item = hintWindow.iText[hintWindow.iCurrentPos];
                            if (lastMatchedWord.equals(item))
                            {
                                item = "(";
                            } else
                            {
                                item = item.substring(lastMatchedWord.length(), item.length());
                            }
                            inputLine = inputLine.substring(0, ito) + item + inputLine.substring(ito, inputLine.length());
                            cursorPos += item.length();
                            refreshHintWindow();
                            repaint();
                            return;
                        }
                    }
                }
                if (!handled)
                {
                    if (inputLine.length() > 0)
                    {
                        appendHistoryLine(inputLine);
                        addLinesStatic(48, inputPrompt, inputLine);
                        if (inputLine.charAt(inputLine.length() - 1) == '\\')
                        {
                            gatheredMultiLine = gatheredMultiLine + inputLine.substring(0, inputLine.length() - 1);
                        } else
                        {
                            performRequest("Result: ", gatheredMultiLine + inputLine, true);
                        }
                        resetInput();
                        refreshHintWindow();
                        repaint(0);
                    }
                }
            }
            inputDirty = true;
            repaint();
        } else if (KeyEvent.KEY_TYPED == e.getID())
        {
            int c = (int) e.getKeyChar();
            if (c >= 32 && c < 127)
            {
                inputLine = new StringBuffer(inputLine).insert(cursorPos, e.getKeyChar()).toString();
                cursorPos++;
                refreshHintWindow();
                inputDirty = true;
                repaint();
            }
        }
    }

    boolean directCommand(String inputLine)
    {
        if (inputLine.equals("restart"))
        {
            stop();
            start();
            return true;
        } else if (inputLine.equals("cls"))
        {
            clearOutputLines();
            return true;
        } else if (inputLine.equals(":test"))
        {
            try
            {
                Applet dataHub = getAppletContext().getApplet("datahub");
                if (dataHub != null)
                {
                    org.mathpiper.ui.gui.applets.storage.DatahubApplet cons = (org.mathpiper.ui.gui.applets.storage.DatahubApplet) dataHub;
                    String programContentsToLoad = "[" + cons.getTestcode() + "];";
                    invokeCalculationSilent(programContentsToLoad);
                }
            } catch (Exception e)
            {
            }
            return true;
        } else if (inputLine.equals("?license") || inputLine.equals("?licence") || inputLine.equals("?warranty"))
        {
            try
            {
                getAppletContext().showDocument(new URL("gpl.html"), "license");
            } catch (Exception e)
            {
            }
            return true;
        }
        return false;
    }

    void performRequest(String outputPrompt, String inputLine, boolean doRepaint)
    {
        boolean succeed = false;
        if (directCommand(inputLine))
        {
            return;
        } else
        {
            resetInput();
            refreshHintWindow();

            calculating = true;
            if (doRepaint)
            {
                paint(getGraphics());
            }
            outputStringBuffer.delete(0, outputStringBuffer.length());
            //String response = "";
            EvaluationResponse response = null;

            response = interpreter.evaluate(inputLine);

            
            outputStringBuffer.append(response.getSideEffects());//todo:tk:hack to try to determine why outputStringBuffer is always being added as an output line as an empty string.

            calculating = false;

            addOutputLine(outputStringBuffer.toString());

            
            if (response.isExceptionThrown() == true)
            {
                addLinesStatic(48, "Error> ", response.getExceptionMessage());
            }
            //AddLinesStatic(48, outputPrompt, response.getSideEffects());//TODO:tk: latex results are returned as a side effect, but normal results are not.  Also, what is a static line?.
            succeed = true;
        }
        {
            if (!succeed)
            {
                out.println("Request failed");
            }
        }
    }

    void addLinesStatic(int indent, String prompt, String str)
    {
        int pos;
        while ((pos = str.indexOf('\n')) >= 0)
        {
            addLineStatic(indent, prompt, str.substring(0, pos), font, Color.black);
            str = str.substring(pos + 1, str.length());
        }
        if (str.length() > 0)
        {
            addLineStatic(indent, prompt, str, font, Color.black);
        }
    }










    void clearOutputLines()
    {
        int i;
        for (i = 0; i < nrLines; i++)
        {
            lines[i] = null;
        }
        totalLinesHeight = 0;
        thumbPos = 0;
        outputDirty = true;
    }

    void addLine(MathOutputLine aLine)
    {
        {
            createOffscreenImage();
            if (lines[currentLine] != null)
            {
                totalLinesHeight -= lines[currentLine].height(offGra);
            }
            lines[currentLine] = aLine;
            if (lines[currentLine] != null)
            {
                totalLinesHeight += lines[currentLine].height(offGra);
            }
            currentLine = (currentLine + 1) % nrLines;
            {
                int canvasHeight = getHeight() - fontHeight - 1;
                if (canvasHeight < totalLinesHeight)
                {
                    int th = calcThumbHeight();
                    thumbPos = canvasHeight - th - 4;
                }
            }
            outputDirty = true;
        }
    }

    void addLine(int index, String text)
    {
        addLineStatic(index, text);
        repaint(0);
    }

    public void addLineStatic(int indent, String text)
    {
        addLineStatic(indent, "", text, font, Color.black);
    }
    Color iPromptColor = new Color(128, 128, 128);
    Font iPromptFont = new Font("Verdana", Font.PLAIN, 12);

    void addLineStatic(int indent, String prompt, String text, Font aFont, Color aColor)
    {
        addLine(new PromptedStringLine(indent, prompt, text, iPromptFont, aFont, iPromptColor, aColor));
        outputDirty = true;
    }

    /// Drawing current view
    public void update(Graphics g)
    {
        paint(g);
    }

    void createOffscreenImage()
    {
        // draw an offScreen drawing
        Dimension dim = getSize();
        if (offGra == null)
        {
            offImg = createImage(dim.width, dim.height);
            offGra = offImg.getGraphics();
        }
    }

    public void paint(Graphics g)
    {
        createOffscreenImage();

        // Render image
        paintToBitmap(offGra);
        // put the OffScreen image OnScreen
        g.drawImage(offImg, 0, 0, null);
        if (hintWindow != null)
        {
            if (g instanceof Graphics2D)
            {
                Graphics2D g2d = null;
                g2d = (Graphics2D) g;
                g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));
            }
            MathPiperGraphicsContext context = new MathPiperGraphicsContext(g, 0, 0);
            context.setFontSize(1, fontHeight/*12*/);
            int nr_total_lines = 1;
            Dimension d = getSize();
            hintWindow.draw(5, (int) (d.getHeight() - context.fontHeight() - nr_total_lines * context.fontHeight()), context);
        }
    }

    int calcThumbHeight()
    {
        int canvasHeight = getHeight() - fontHeight - 1;
        int hgt = ((canvasHeight - 4) * canvasHeight) / totalLinesHeight;
        if (hgt < 16)
        {
            hgt = 16;
        }
        return hgt;
    }

    public void paintToBitmap(Graphics g)
    {
        synchronized (this)
        {
            if (g instanceof Graphics2D)
            {
                Graphics2D g2d = null;
                g2d = (Graphics2D) g;
                g2d.addRenderingHints(new RenderingHints(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON));

                g2d.setStroke(new BasicStroke((float) (2), BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND));
            }

            FontMetrics metrics = getFontMetrics(font);

            g.setColor(bkColor);
            int yfrom = 0;

            g.setFont(font);
            int inHeight = fontHeight;

            int yto = getHeight();
            if (!outputDirty)
            {
                yfrom += getHeight() - inHeight;
            }
            if (!inputDirty)
            {
                yto -= inHeight;
            }
            g.clearRect(0, yfrom, getWidth(), yto);
            g.setColor(Color.black);

            int i;
            int y = getHeight() - inHeight - g.getFontMetrics().getHeight();

            int canvasHeight = getHeight() - fontHeight - 1;
            if (outputDirty)
            {
                y -= totalLinesHeight;
                if (canvasHeight < totalLinesHeight)
                {
                    int th = calcThumbHeight();
                    double scale = (1.0 * thumbPos) / (canvasHeight - th - 4);
                    y += (int) ((1 - scale) * (totalLinesHeight - canvasHeight));
                }
                g.setClip(0, 0, getWidth(), getHeight() - fontHeight - 1);
                for (i = 0; i < nrLines; i++)
                {
                    int index = (currentLine + i) % nrLines;
                    if (lines[index] != null)
                    {
                        if (y + lines[index].height(g) > 0)
                        {
                            lines[index].draw(g, inset, y);
                        }
                        y += lines[index].height(g);
                    }
                }
                g.setClip(0, 0, getWidth(), getHeight());
                int w = getWidth();
                //System.out.println("height = "+totalLinesHeight+", screen = "+(canvasHeight));
                if (canvasHeight < totalLinesHeight)
                {
                    int thumbHeight = calcThumbHeight();
                    g.setColor(Color.white);
                    g.fillRect(w - scrollWidth, 0, scrollWidth, canvasHeight);

                    if (thumbMoused)
                    {
                        g.setColor(new Color(192, 192, 240));
                    } else
                    {
                        g.setColor(new Color(124, 124, 224));
                    }
                    g.fillRect(w - scrollWidth + 2, thumbPos + 2, scrollWidth - 4, thumbHeight);

                    g.setColor(Color.black);
                    g.drawRect(w - scrollWidth, 0, scrollWidth, canvasHeight);

                    g.drawRect(w - scrollWidth + 2, thumbPos + 2, scrollWidth - 4, thumbHeight);
                }
            }
            y = getHeight() - g.getFontMetrics().getDescent();
            outputDirty = false;
            if (focusGained && !calculating)
            {
                if (inputDirty)
                {
                    if (y + fontHeight > 0)
                    {
                        int promptLength = metrics.stringWidth(inputPrompt);
                        g.setColor(Color.red);
                        g.setFont(font);

                        g.drawString(inputPrompt, inset, y);
                        g.drawString(inputLine, inset + promptLength, y);
                        int cursorLocation = promptLength;
                        for (i = 0; i < cursorPos; i++)
                        {
                            cursorLocation += metrics.charWidth(inputLine.charAt(i));
                        }
                        y += g.getFontMetrics().getDescent();
                        g.setColor(Color.blue);
                        g.drawLine(inset + cursorLocation, y - 2, inset + cursorLocation, y - fontHeight + 1);
                    //TODO remove?            g.drawLine(inset+cursorLocation+1,y-2,inset+cursorLocation+1,y-fontHeight+1);
                    }
                }
            } else
            {
                String toPrint = "Click here to enter an expression";
                if (calculating)
                {
                    toPrint = "Calculating...";
                }

                int promptLength = metrics.stringWidth(toPrint);
                g.setColor(Color.blue);
                g.setFont(font);

                g.drawString(toPrint, inset, y);
                y += g.getFontMetrics().getDescent();
            }
            inputDirty = false;
        }
    }



    void loadHints(String filename)
    {
        CharacterDataReader file = new CharacterDataReader();
        int opened = 0;
        try
        {
            URL url = new URL(filename);
            opened = file.open(url);
        } catch (Exception e)
        {
        }
        if (opened != 0)
        {
            String line = file.readLine();
            String[] tokens = new String[16];
            int nrTokens = 0;
            while (line != null)
            {
                if (line.substring(0, 2).equals("::"))
                {
                    break;
                }
                int i = 0;
                nrTokens = 0;
                while (i < line.length())
                {
                    int start = i;
                    while (line.charAt(i) != ':')
                    {
                        i++;
                    }
                    tokens[nrTokens] = line.substring(start, i);
                    nrTokens++;
                    i++;
                }
                if (nrTokens > 3)
                {
                    HintItem hi = new HintItem();
                    hi.base = tokens[1];
                    hi.hint = tokens[2];
                    hi.description = tokens[3];
                    the_hints.hintTexts[the_hints.nrHintTexts] = hi;
                    the_hints.nrHintTexts++;
                }

                line = file.readLine();
            }
            file.close();
        } else
        {
            out.println("could not read hints");
        }
    }

    HintWindow createHints(int fontsize)
    {
        HintWindow hw = new HintWindow(fontsize);
        return hw;
    }

    void addHintLine(HintWindow hints, String aText, String aDescription)
    {
        hints.addLine(aText);
        if (aDescription.length() > 0)
        {
            hints.addDescription(aDescription);
        }
    }

    HintWindow tryToHint(String text, int length)
    {
        HintWindow hints = null;
        int nrhints = the_hints.nrHintTexts;
        int i, start;
        start = 0;
        if (start < 0)
        {
            return null;
        }
        for (i = start; i < nrhints; i++)
        {
            if (text.charAt(0) > the_hints.hintTexts[i].base.charAt(0))
            {
                continue;
            }
            if (text.charAt(0) < the_hints.hintTexts[i].base.charAt(0))
            {
                continue;
            }
            int baselen = the_hints.hintTexts[i].base.length();
            if (length == baselen)
            {
                if (text.substring(0, baselen).equals(the_hints.hintTexts[i].base))
                {
                    if (hints == null)
                    {
                        hints = createHints(12 /*iDefaultFontSize*/);
                        hints.iAllowSelection = false;
                    }
                    addHintLine(hints, the_hints.hintTexts[i].hint, the_hints.hintTexts[i].description);
                }
            }
        }
        return hints;
    }

    void refreshHintWindow()
    {
        ito = cursorPos;

        while (true)
        {
            if (ito == inputLine.length())
            {
                break;
            }
            if (!MathPiperTokenizer.isAlpha(inputLine.charAt(ito)))
            {
                break;
            }
            ito++;
        }
        if (ito > 0)
        {
            int c = inputLine.charAt(ito - 1);
            if (c == ',' || c == ')')
            {
                int braces = -1;
                if (c == ')')
                {
                    ito--;
                    braces = -2;
                }
                while (braces != 0)
                {
                    if (ito <= 0)
                    {
                        break;
                    }
                    if (inputLine.charAt(ito - 1) == '(')
                    {
                        braces++;
                    }
                    if (inputLine.charAt(ito - 1) == ')')
                    {
                        braces--;
                    }
                    ito--;
                }
            }
        }
        if (ito > 0)
        {
            if (inputLine.charAt(ito - 1) == '(')
            {
                ito--;
            }
        }
        if (ito == 0)
        {
            while (true)
            {
                if (ito == cursorPos)
                {
                    break;
                }
                if (!MathPiperTokenizer.isAlpha(inputLine.charAt(ito)))
                {
                    break;
                }
                ito++;
            }
        }
        int ifrom = ito;
        while (true)
        {
            if (ifrom == 0)
            {
                break;
            }
            char c = inputLine.charAt(ifrom - 1);
            if (!MathPiperTokenizer.isAlpha(c) && !MathPiperTokenizer.isDigit(c))
            {
                break;
            }
            ifrom--;
        }
        // Name of function *has* to start with alphabetic letter
        while (ifrom < ito && MathPiperTokenizer.isDigit(inputLine.charAt(ifrom)))
        {
            ifrom++;
        }
        matchToInsert = "";
        lastMatchedWord = "";
        if (ito > ifrom)
        {
            lastMatchedWord = inputLine.substring(ifrom, ito);
        }

        hintWindow = null;
        if (lastMatchedWord.length() > 0)
        {
            //System.out.println("word is "+word);

            int nr = lastMatchedWord.length();
            int maxHintLines = 18;
            String texts[] = new String[maxHintLines + 1];
            int nrHintLines = 0;

            int i;
            for (i = 0; i < the_hints.nrHintTexts; i++)
            {
                if (nrHintLines == maxHintLines)
                {
                    break;
                }
                if (nr <= (the_hints.hintTexts[i].base).length() &&
                        lastMatchedWord.equals(the_hints.hintTexts[i].base.substring(0, nr)))
                {
                    boolean add = true;
                    if (nrHintLines > 0)
                    {
                        if (texts[nrHintLines - 1].equals(the_hints.hintTexts[i].base))
                        {
                            add = false;
                        }
                    }
                    if (add)
                    {
                        texts[nrHintLines++] = the_hints.hintTexts[i].base;
                    }
                    // Exact match, keep this one line
                    if (nrHintLines == 1 && ito != cursorPos && lastMatchedWord.equals(the_hints.hintTexts[i].base))
                    {
                        break;
                    }
                }
            }

            if (nrHintLines == maxHintLines)
            {
                texts[nrHintLines++] = "...";
            }
            if (nrHintLines == 1)
            {
                if (lastMatchedWord.length() < texts[0].length())
                {
                    matchToInsert = texts[0].substring(lastMatchedWord.length(), texts[0].length());
                }
                hintWindow = tryToHint(texts[0], texts[0].length());
            } else if (nrHintLines > 1)
            {
                hintWindow = createHints(12);
                hintWindow.iAllowSelection = true;

                for (i = 0; i < nrHintLines; i++)
                {
                    addHintLine(hintWindow, texts[i], "");
                }
            }
        }
    }

    public void invokeCalculation(String expression)
    {
        if (!gotDatahubInit)
        {
            start();
        }
        appendHistoryLine(expression);
        addLinesStatic(48, "In> ", expression);
        resetInput();
        refreshHintWindow();
        inputDirty = true;
        outputDirty = true;
        performRequest("Result: ", expression, false);
        inputDirty = true;
        outputDirty = true;
        repaint();
    }

    public String calculate(String expression)
    {
        if (!gotDatahubInit)
        {
            start();
        //String result = "";
        }
        EvaluationResponse evaluationResponse = null;

        evaluationResponse = interpreter.evaluate(expression);

        lastError = evaluationResponse.getExceptionMessage();  //Note:tk: need to check for null value.
        return evaluationResponse.getResult();
    }

    public String getLastError()
    {
        if (lastError != null)
        {
            return lastError;
        } else
        {
            return "";
        }
    }

    private void addOutputLine(String outp)
    {
        if (outp.length() > 0)
        {
            int dollarPos = outp.indexOf("$");
            while (dollarPos >= 0)
            {
                // Print plain text before the dollared content
                if (dollarPos > 0)
                {
                    addLinesStatic(48, "", outp.substring(0, dollarPos));
                }
                // Strip off the left dollar sign
                outp = outp.substring(dollarPos + 1, outp.length());

                // Find the right dollar sign, and split there too
                dollarPos = outp.indexOf("$");
                String dollared = outp.substring(0, dollarPos);
                outp = outp.substring(dollarPos + 1, outp.length());

                //System.out.println("Dollared: "+dollared);
                int plotPos = dollared.indexOf("plot2d:");
                if (plotPos >= 0)
                {
                    dollared = dollared.substring(plotPos + 7);
                    //System.out.println("Plotting: ["+dollared+"]");
                    addLine(new PromptedGraph2DLine(48, "Result:", iPromptFont, iPromptColor, dollared));
                } else
                {
                    addLine(new PromptedFormulaLine(48, "Result:", iPromptFont, iPromptColor, dollared));
                }
                dollarPos = outp.indexOf("$");
            }
            // If there is some plain text left at the end, print
            if (outp.length() > 0)
            {
                addLinesStatic(48, "", outp.toString());
            }
        }
        outputDirty = true;
    }

    public void addInputLine(String expression)
    {
        synchronized (this)
        {
            if (!gotDatahubInit)
            {
                start();
            }
            appendHistoryLine(expression);
            addLinesStatic(48, "In> ", expression);
            resetInput();
            refreshHintWindow();
            inputDirty = true;
            outputDirty = true;
            calculating = true;
        }
        repaint();
    }

    public void invokeCalculationSilent(String expression)
    {
        synchronized (this)
        {
            if (directCommand(expression))
            {
                return;
            } else
            {
                outputStringBuffer.delete(0, outputStringBuffer.length());
                EvaluationResponse evaluationResponse = null;

                evaluationResponse = interpreter.evaluate(expression);

                calculating = false;
                addOutputLine(outputStringBuffer.toString());
                if (evaluationResponse != null && evaluationResponse.getExceptionMessage() != null)
                {
                    addLinesStatic(48, "Error> ", evaluationResponse.getExceptionMessage());
                }

                resetInput();
                refreshHintWindow();
                inputDirty = true;
                outputDirty = true;
            }
        }
        repaint();
    }

    public void stopCurrentCalculation()
    {
        //interpreter.getEnvironment().iEvalDepth = interpreter.getEnvironment().iMaxEvalDepth + 100;
        interpreter.haltEvaluation();
    }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/worksheets/SelectSymbol.java0000644000175000017500000000657211131060345030364 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.worksheets;

public class SelectSymbol
{

	public int iheight;
	public int ispacing;
	public int iwidth;
	public int ix;
	public int iy;
	public int nr_symbols;
	String[] symbols = new String[64];

	public SelectSymbol(int width, int spacing)
	{
		ix = iy = 0;
		nr_symbols = 0;
		iwidth = width;
		ispacing = spacing;

		int i;
		iheight = 0;
		addSymbol("0");
		addSymbol("1");
		addSymbol("(");
		addSymbol(")");
		addSymbol("[");
		addSymbol("]");
		addSymbol("{");
		addSymbol("}");
		addSymbol("+");
		addSymbol("-");
		addSymbol("*");
		addSymbol("/");
		addSymbol(".");
		addSymbol(",");
		addSymbol(";");
		addSymbol(":");
		addSymbol("!");
		addSymbol("#");
		addSymbol("_");
		addSymbol("^");
		addSymbol("<");
		addSymbol(">");
		addSymbol("<=");
		addSymbol(">=");
		addSymbol(":=");
		addSymbol("=");
		addSymbol("!");
		addSymbol("@");
		iheight = (nr_symbols + iwidth - 1) / iwidth;
	}

	public void draw(int xpos, int ypos, MathPiperGraphicsContext aGraphicsContext)
	{
		aGraphicsContext.setFontSize(0, 12);
		aGraphicsContext.setColor(255, 255, 255);
		aGraphicsContext.fillRect(xpos, ypos, iwidth * ispacing, iheight * aGraphicsContext.fontHeight());
		aGraphicsContext.setColor(0, 0, 0);
		aGraphicsContext.drawRect(xpos, ypos, iwidth * ispacing, iheight * aGraphicsContext.fontHeight());

		int x;
		int y;
		aGraphicsContext.setColor(128, 128, 128);

		for (y = 0; y < iheight; y++)
		{
			aGraphicsContext.drawLine(xpos, ypos + y * aGraphicsContext.fontHeight(), xpos + iwidth * ispacing, ypos + y * aGraphicsContext.fontHeight());
		}

		for (x = 0; x < iwidth; x++)
		{
			aGraphicsContext.drawLine(xpos + x * ispacing, ypos, xpos + x * ispacing, ypos + iheight * aGraphicsContext.fontHeight());
		}

		aGraphicsContext.setColor(0, 0, 0);

		for (y = 0; y < iheight; y++)
		{

			for (x = 0; x < iwidth; x++)
			{

				if (ix == x && iy == y)
				{
					aGraphicsContext.setColor(128, 128, 128);
					aGraphicsContext.fillRect(xpos + x * ispacing, ypos + y * aGraphicsContext.fontHeight(), ispacing, aGraphicsContext.fontHeight());
					aGraphicsContext.setColor(0, 0, 0);
				}

				if (symbols[y * iwidth + x] != null)
				{
					aGraphicsContext.drawText(xpos + x * ispacing + (ispacing - aGraphicsContext.textWidthInPixels(symbols[y * iwidth + x])) / 2, ypos + (y + 1) * aGraphicsContext.fontHeight() - aGraphicsContext.fontDescent(), symbols[y * iwidth + x]);
				}
			}
		}
	}

	public void addSymbol(String sym)
	{
		symbols[nr_symbols++] = sym;
	}

	public int height(MathPiperGraphicsContext aGraphicsContext)
	{

		return iheight * aGraphicsContext.fontHeight();
	}
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/controlpanel/0000755000175000017500000000000011722677337025431 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/controlpanel/HaltButton.java0000644000175000017500000000377311165261710030353 0ustar  giovannigiovanni/*
 * $Id: MultiSplitLayout.java,v 1.15 2005/10/26 14:29:54 hansmuller Exp $
 *
 * Copyright 2004 Sun Microsystems, Inc., 4150 Network Circle,
 * Santa Clara, California 95054, U.S.A. All rights reserved.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 */
package org.mathpiper.ui.gui.controlpanel;

import javax.swing.JButton;

public class HaltButton extends JButton {

    private static HaltButton singletonInstance;

    private HaltButton() {
        this.setText("Halt Execution");
        setForeground(java.awt.Color.RED);
        setEnabled(false);
        addActionListener(new java.awt.event.ActionListener() {

            public void actionPerformed(java.awt.event.ActionEvent evt) {

                try {
                    org.mathpiper.interpreters.Interpreter interpreter = org.mathpiper.interpreters.Interpreters.getSynchronousInterpreter();
                    interpreter.haltEvaluation();
                } catch (Exception e) {
                    e.printStackTrace();
                } finally {
                    setEnabled(false);
                }

            }
        });
    }//end constructor.

    public static  HaltButton getInstance() {
        if (singletonInstance == null) {
            singletonInstance = new HaltButton();
        }
        return singletonInstance;
    }//end method.
    
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/EnvironmentViewer.java0000644000175000017500000007000211520672140027240 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui;

import java.awt.BorderLayout;
import java.awt.Dimension;
import javax.swing.JFrame;
import org.mathpiper.lisp.Environment;
import java.awt.Container;
import java.awt.Point;
import java.awt.Toolkit;
import java.awt.datatransfer.DataFlavor;
import java.awt.datatransfer.StringSelection;
import java.awt.datatransfer.Transferable;
import java.awt.datatransfer.UnsupportedFlavorException;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;
import java.io.IOException;
import java.io.Reader;
import java.util.ArrayList;
import java.util.Arrays;
import java.util.Collections;
import java.util.Comparator;
import java.util.Iterator;
import java.util.List;
import java.util.Map;
import javax.swing.CellEditor;
import javax.swing.JButton;
import javax.swing.JMenuItem;
import javax.swing.JPanel;
import javax.swing.JPopupMenu;
import javax.swing.JScrollPane;
import javax.swing.JSplitPane;
import javax.swing.JTable;
import javax.swing.JTextArea;
import javax.swing.ListSelectionModel;
import javax.swing.SwingUtilities;
import javax.swing.event.ListSelectionEvent;
import javax.swing.event.ListSelectionListener;
import javax.swing.table.AbstractTableModel;
import org.mathpiper.lisp.GlobalVariable;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.rulebases.Rule;
import org.mathpiper.lisp.rulebases.MultipleArityRulebase;
import org.mathpiper.lisp.rulebases.SingleArityRulebase;
import org.mathpiper.ui.gui.MultiSplitLayout.Divider;
import org.mathpiper.ui.gui.MultiSplitLayout.Leaf;
import org.mathpiper.ui.gui.MultiSplitLayout.Split;

/**
 * Provides a GUI viewer for a runtime environment.
 */
public class EnvironmentViewer implements ActionListener {

    private JTextArea textArea = new JTextArea(4, 8);
    private List tables = new ArrayList();
    private JFrame frame;
    private FunctionNameComparator functionNameComparator = new FunctionNameComparator();
    private JPopupMenu popupMenu = new JPopupMenu();


    public EnvironmentViewer() {
        super();
    }


    public JFrame getViewerFrame(Environment aEnvironment) {

        frame = new javax.swing.JFrame();
        frame.setDefaultCloseOperation(JFrame.DISPOSE_ON_CLOSE);

        //siteTable.getModel().fireTableDataChanged();

        Leaf one = new Leaf("one");
        Leaf two = new Leaf("two");
        Leaf three = new Leaf("three");
        Leaf four = new Leaf("four");

        one.setWeight(0.15);
        two.setWeight(0.28);
        three.setWeight(0.28);
        four.setWeight(0.29);

        List children = Arrays.asList(one, new Divider(), two, new Divider(), three, new Divider(), four);
        MultiSplitLayout.Split modelRoot = new Split();
        modelRoot.setChildren(children);
        MultiSplitPane multiSplitPane = new MultiSplitPane();
        multiSplitPane.getMultiSplitLayout().setModel(modelRoot);




        textArea.setEditable(false);
        JScrollPane outputPane = new JScrollPane(textArea);


        JSplitPane splitPane = new JSplitPane(JSplitPane.VERTICAL_SPLIT, multiSplitPane, outputPane);
        splitPane.setOneTouchExpandable(true);
        splitPane.setDividerLocation(150);


        Dimension minimumSize = new Dimension(100, 100);
        multiSplitPane.setMinimumSize(minimumSize);
        textArea.setMinimumSize(minimumSize);


        Container contentPane = frame.getContentPane();
        contentPane.add(splitPane);





        //Add global state.
        JTable table = this.getGlobalStateTable(aEnvironment);
        tables.add(table);
        JScrollPane scrollPane = new JScrollPane(table);
        tables.add(scrollPane);
        multiSplitPane.add(scrollPane, "one");

        //Add user functions.
        table = this.getUserFunctionsTable(aEnvironment);
        tables.add(table);
        scrollPane = new JScrollPane(table);
        tables.add(scrollPane);
        multiSplitPane.add(scrollPane, "two");

        //Add builtin functions.
        table = this.getBuiltinFunctionsTable(aEnvironment);
        tables.add(table);
        scrollPane = new JScrollPane(table);
        tables.add(scrollPane);
        multiSplitPane.add(scrollPane, "three");

        //Add tokens.
        table = this.getTokenTable(aEnvironment);
        tables.add(table);
        scrollPane = new JScrollPane(table);
        tables.add(scrollPane);
        multiSplitPane.add(scrollPane, "four");

        JPanel buttonsPanel = new JPanel();

        JButton refreshButton = new JButton("Refresh");
        refreshButton.addActionListener(this);
        refreshButton.setActionCommand("refresh");
        buttonsPanel.add(refreshButton);

        JButton clearButton = new JButton("Clear");
        clearButton.addActionListener(this);
        clearButton.setActionCommand("clear");
        buttonsPanel.add(clearButton);

        contentPane.add(buttonsPanel, BorderLayout.NORTH);




        frame.pack();
//frame.setAlwaysOnTop(true);
        frame.setTitle("MathPiper Environment");
        frame.setSize(new Dimension(700, 400));
        //frame.setResizable(false);
        frame.setPreferredSize(new Dimension(700, 400));
        frame.setLocationRelativeTo(null); // added

        frame.setVisible(true);

        return frame;
    }


    public void actionPerformed(ActionEvent ae) {
        String actionCommand = ae.getActionCommand();

        if (actionCommand.equalsIgnoreCase("refresh")) {
            this.refresh();
        } else if (actionCommand.equalsIgnoreCase("clear")) {
            textArea.setText("");
        }

    }//end method.


    private void refresh() {
        Iterator tablesIterator = tables.iterator();
        while (tablesIterator.hasNext()) {
            JTable table = (JTable) tablesIterator.next();
            JScrollPane scrollPane = (JScrollPane) tablesIterator.next();
            //AbstractTableModel model = (AbstractTableModel) table.getModel();
            //model.fireTableDataChanged();

            SwingUtilities.updateComponentTreeUI(scrollPane);
        }
    }


    /**
     * Returns a GUI table which contains a sorted list of the user functions.
     * 
     * @param aEnvironment the environment to view
     * @return a JTable which contains the user function names
     */
    public JTable getUserFunctionsTable(Environment aEnvironment) {
        JTable table = new JTable();

        table.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);
        table.getSelectionModel().addListSelectionListener(new FunctionListener(table, aEnvironment));

        final java.util.Map map = (java.util.Map) aEnvironment.getUserFunctions().getMap();

        table.setModel(new AbstractTableModel() {

            private static final long serialVersionUID = 1L;


            public int getColumnCount() {
                return 1;
            }


            public int getRowCount() {
                return map.size();
            }


            public String getColumnName(int column) {
                if (column == 0) {
                    return "User Functions";
                } else {
                    return "";
                }
            }


            public Object getValueAt(int rowIndex, int columnIndex) {
                if (columnIndex == 0) {
                    return getKey(rowIndex);
                } else {
                    return map.get(getKey(rowIndex));
                } // if-else

            }


            private String getKey(int a_index) {
                String retval = "";
                ArrayList keyList = new ArrayList(map.keySet());
                Collections.sort(keyList, functionNameComparator);

                // for (int i = 0; i < a_index + 1; i++) {
                //         retval = e.next();
                // } // for
                retval = (String) keyList.get(a_index);

                return retval;
            }

        });

        table.addMouseListener(new MouseAdapter() {

            private void maybeShowPopup(MouseEvent e) {
                JTable jTable = (JTable) e.getSource();

                if (e.isPopupTrigger() && jTable.isEnabled()) {
                    Point p = new Point(e.getX(), e.getY());
                    int col = jTable.columnAtPoint(p);
                    int row = jTable.rowAtPoint(p);

                    // translate table index to model index
                    int mcol = jTable.getColumn(
                            jTable.getColumnName(col)).getModelIndex();

                    if (row >= 0 && row < jTable.getRowCount()) {
                        cancelCellEditing(jTable);

                        // create popup menu...
                        JPopupMenu contextMenu = createContextMenu(row, mcol, jTable, map);

                        // ... and show it
                        if (contextMenu != null
                                && contextMenu.getComponentCount() > 0) {
                            contextMenu.show(jTable, p.x, p.y);
                        }
                    }
                }
            }


            public void mousePressed(MouseEvent e) {
                maybeShowPopup(e);
            }


            public void mouseReleased(MouseEvent e) {
                maybeShowPopup(e);
            }

        });

        return table;
    }//end class


    /**
     * Returns a GUI table which contains a sorted list of the builtin functions.
     * 
     * @param aEnvironment the environment to view
     * @return a JTable which contains the built in function names
     */
    public JTable getBuiltinFunctionsTable(Environment aEnvironment) {
        JTable table = new JTable();

        table.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);
        table.getSelectionModel().addListSelectionListener(new DummyListener(table, aEnvironment));

        final java.util.Map map = (java.util.Map) aEnvironment.getBuiltinFunctions().getMap();

        table.setModel(new AbstractTableModel() {

            private static final long serialVersionUID = 1L;


            public int getColumnCount() {
                return 1;
            }


            public int getRowCount() {
                return map.size();
            }


            public String getColumnName(int column) {
                if (column == 0) {
                    return "Built-In Functions";
                } else {
                    return "";
                }
            }


            public Object getValueAt(int rowIndex, int columnIndex) {
                if (columnIndex == 0) {
                    return getKey(rowIndex);
                } else {
                    return map.get(getKey(rowIndex));
                } // if-else

            }


            private String getKey(int a_index) {
                String retval = "";
                ArrayList keyList = new ArrayList(map.keySet());
                Collections.sort(keyList, functionNameComparator);

                // for (int i = 0; i < a_index + 1; i++) {
                //         retval = e.next();
                // } // for
                retval = (String) keyList.get(a_index);

                return retval;
            }

        });

        return table;
    }//end class


    /**
     * Returns a GUI table which contains a sorted list of the global variables.
     * 
     * @param aEnvironment the environment to view
     * @return a JTable which contains the global variable names
     */
    public JTable getGlobalStateTable(Environment aEnvironment) {
        JTable table = new JTable();

        table.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);
        table.getSelectionModel().addListSelectionListener(new GlobalVariableListener(table, aEnvironment));

        final java.util.Map map = (java.util.Map) aEnvironment.getGlobalState().getMap();

        table.setModel(new AbstractTableModel() {

            private static final long serialVersionUID = 1L;


            public int getColumnCount() {
                return 2;
            }


            public int getRowCount() {
                return map.size();
            }


            public String getColumnName(int column) {
                if (column == 0) {
                    return "Global Variables";
                } else {
                    return "Values";
                }
            }


            public Object getValueAt(int rowIndex, int columnIndex) {
                if (columnIndex == 0) {
                    return getKey(rowIndex);
                } else {
                    return map.get(getKey(rowIndex));
                } // if-else

            }


            private String getKey(int a_index) {
                String retval = "";
                ArrayList keyList = new ArrayList(map.keySet());
                Collections.sort(keyList, functionNameComparator);

                // for (int i = 0; i < a_index + 1; i++) {
                //         retval = e.next();
                // } // for
                retval = (String) keyList.get(a_index);

                return retval;
            }

        });


        table.addMouseListener(new MouseAdapter() {

            private void maybeShowPopup(MouseEvent e) {
                JTable jTable = (JTable) e.getSource();

                if (e.isPopupTrigger() && jTable.isEnabled()) {
                    Point p = new Point(e.getX(), e.getY());
                    int col = jTable.columnAtPoint(p);
                    int row = jTable.rowAtPoint(p);

                    // translate table index to model index
                    int mcol = jTable.getColumn(
                            jTable.getColumnName(col)).getModelIndex();

                    if (row >= 0 && row < jTable.getRowCount()) {
                        cancelCellEditing(jTable);

                        // create popup menu...
                        JPopupMenu contextMenu = createContextMenu(row, mcol, jTable, map);

                        // ... and show it
                        if (contextMenu != null
                                && contextMenu.getComponentCount() > 0) {
                            contextMenu.show(jTable, p.x, p.y);
                        }
                    }
                }
            }


            public void mousePressed(MouseEvent e) {
                maybeShowPopup(e);
            }


            public void mouseReleased(MouseEvent e) {
                maybeShowPopup(e);
            }

        });


        return table;
    }//end method.


    /**
     * Returns a GUI table which contains a sorted list of the tokens.
     * 
     * @param aEnvironment the environment to view
     * @return a JTable which contains the token names
     */
    public JTable getTokenTable(Environment aEnvironment) {
        JTable table = new JTable();

        table.setSelectionMode(ListSelectionModel.SINGLE_SELECTION);
        table.getSelectionModel().addListSelectionListener(new DummyListener(table, aEnvironment));

        final java.util.Map m_hash = (java.util.Map) aEnvironment.getTokenHash().getMap();

        table.setModel(new AbstractTableModel() {

            private static final long serialVersionUID = 1L;


            public int getColumnCount() {
                return 1;
            }


            public int getRowCount() {
                return m_hash.size();
            }


            public String getColumnName(int column) {
                if (column == 0) {
                    return "Tokens";
                } else {
                    return "";
                }
            }


            public Object getValueAt(int rowIndex, int columnIndex) {
                if (columnIndex == 0) {
                    return getKey(rowIndex);
                } else {
                    return m_hash.get(getKey(rowIndex));
                } // if-else

            }


            private String getKey(int a_index) {
                String retval = "";
                ArrayList keyList = new ArrayList(m_hash.keySet());
                Collections.sort(keyList, functionNameComparator);

                // for (int i = 0; i < a_index + 1; i++) {
                //         retval = e.next();
                // } // for
                retval = (String) keyList.get(a_index);

                return retval;
            }

        });

        return table;
    }//end method.

    private class GlobalVariableListener implements ListSelectionListener {

        private JTable table;
        private Environment iEnvironment;


        public GlobalVariableListener(JTable table, Environment aEnvironment) {
            this.table = table;
            this.iEnvironment = aEnvironment;
        }


        public void valueChanged(ListSelectionEvent event) {
            if (event.getValueIsAdjusting()) {
                return;
            }

            ListSelectionModel listSelectionModel = (ListSelectionModel) event.getSource();
            if (listSelectionModel.isSelectionEmpty()) {
                return;
            }

            int row = table.getSelectionModel().getLeadSelectionIndex();

            String name = (String) table.getValueAt(row, 0);
            GlobalVariable o = (GlobalVariable) table.getValueAt(row, 1);
            try {
                String data = Utility.printMathPiperExpression(-1, o.getValue(), iEnvironment, 0);
                //System.out.println(data);
                textArea.append(name + ": " + data + "\n");
                textArea.setCaretPosition(textArea.getDocument().getLength());
            } catch (Exception ex) {
                System.out.print(ex);
            }

            table.clearSelection();

        }//end method

    }//end class.

    private class FunctionListener implements ListSelectionListener {

        private JTable table;
        private Environment iEnvironment;


        public FunctionListener(JTable table, Environment aEnvironment) {
            this.table = table;
            this.iEnvironment = aEnvironment;
        }


        public void valueChanged(ListSelectionEvent event) {
            if (event.getValueIsAdjusting()) {
                return;
            }

            ListSelectionModel listSelectionModel = (ListSelectionModel) event.getSource();
            if (listSelectionModel.isSelectionEmpty()) {
                return;
            }

            //System.out.println(event);

            int row = table.getSelectionModel().getLeadSelectionIndex();

            String name = (String) table.getValueAt(row, 0);

            MultipleArityRulebase multipleArityUserfunction = (MultipleArityRulebase) table.getModel().getValueAt(row, 1);

            String defFileLocation = multipleArityUserfunction.iFileLocation;
            String location = "Not specified in a .def file.";
            if (defFileLocation != null) {
                location = defFileLocation;
            }



            textArea.append("-------------------------------------------------------------------------------------------------------------\n");
            textArea.append("Name: " + name + "\n");
            textArea.append("Source Script: " + location + "\n\n");

            Iterator multipleArityUserFunctionIterator = multipleArityUserfunction.getFunctions();

            while (multipleArityUserFunctionIterator.hasNext()) {
                SingleArityRulebase userFunction = (SingleArityRulebase) multipleArityUserFunctionIterator.next();
                Iterator rulesIterator = userFunction.getRules();

                while (rulesIterator.hasNext()) {

                    Rule branchRuleBase = (Rule) rulesIterator.next();

                    String ruleDump = org.mathpiper.lisp.Utility.dumpRule(-1, branchRuleBase, iEnvironment, userFunction);
                    textArea.append(ruleDump);
                    textArea.append("\n");
                    textArea.setCaretPosition(textArea.getDocument().getLength());


                }//end while.

            }//end while.

            table.clearSelection();

        }//end method.

    }//end class.

    private class DummyListener implements ListSelectionListener {

        private JTable table;
        private Environment iEnvironment;


        public DummyListener(JTable table, Environment aEnvironment) {
            this.table = table;
            this.iEnvironment = aEnvironment;
        }


        public void valueChanged(ListSelectionEvent event) {
            if (event.getValueIsAdjusting()) {
                return;
            }

            ListSelectionModel listSelectionModel = (ListSelectionModel) event.getSource();
            if (listSelectionModel.isSelectionEmpty()) {
                return;
            }

            table.clearSelection();

        }//end method.

    } //end class.

    private class FunctionNameComparator implements Comparator {

        public int compare(String s1, String s2) {
            return s1.compareToIgnoreCase(s2);
        }//end method.

    }//end class.

//============================
    private static final String PROP_CHANGE_QUANTITY = "CHANGE_QUANTITY";


    private static String getClipboardContents(Object requestor) {
        Transferable t = Toolkit.getDefaultToolkit().getSystemClipboard().getContents(requestor);
        if (t != null) {
            DataFlavor df = DataFlavor.stringFlavor;
            if (df != null) {
                try {
                    Reader r = df.getReaderForText(t);
                    char[] charBuf = new char[512];
                    StringBuffer buf = new StringBuffer();
                    int n;
                    while ((n = r.read(charBuf, 0, charBuf.length)) > 0) {
                        buf.append(charBuf, 0, n);
                    }
                    r.close();
                    return (buf.toString());
                } catch (IOException ex) {
                    ex.printStackTrace();
                } catch (UnsupportedFlavorException ex) {
                    ex.printStackTrace();
                }
            }
        }
        return null;
    }


    private static boolean isClipboardContainingText(Object requestor) {
        Transferable t = Toolkit.getDefaultToolkit().getSystemClipboard().getContents(requestor);
        return t != null
                && (t.isDataFlavorSupported(DataFlavor.stringFlavor) || t.isDataFlavorSupported(DataFlavor.plainTextFlavor));
    }


    private static void setClipboardContents(String s) {
        StringSelection selection = new StringSelection(s);
        Toolkit.getDefaultToolkit().getSystemClipboard().setContents(
                selection, selection);
    }

    private JPanel jContentPane;
    private JScrollPane jScrollPane;


    private void cancelCellEditing(JTable table) {
        CellEditor ce = table.getCellEditor();
        if (ce != null) {
            ce.cancelCellEditing();
        }
    }


    private JPopupMenu createContextMenu(final int rowIndex, final int columnIndex, JTable table, Map map) {

        final Map finalMap = map;

        JPopupMenu contextMenu = new JPopupMenu();

        final JTable jTable = table;

        JMenuItem copyMenu = new JMenuItem();
        copyMenu.setText("Copy");
        copyMenu.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {
                Object value = jTable.getModel().getValueAt(rowIndex,
                        columnIndex);
                setClipboardContents(value == null ? "" : value.toString());
            }

        });
        contextMenu.add(copyMenu);

        JMenuItem pasteMenu = new JMenuItem();
        pasteMenu.setText("Paste");
        if (isClipboardContainingText(this) && table.getModel().isCellEditable(rowIndex, columnIndex)) {
            pasteMenu.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent e) {
                    String value = getClipboardContents(EnvironmentViewer.this);
                    jTable.getModel().setValueAt(value, rowIndex,
                            columnIndex);
                }

            });
        } else {
            pasteMenu.setEnabled(false);
        }
        contextMenu.add(pasteMenu);


        JMenuItem unbindMenu = new JMenuItem();
        unbindMenu.setText("Unbind");

        unbindMenu.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {

                Object object = jTable.getModel().getValueAt(rowIndex, columnIndex);

                if (object instanceof String) {
                    String string = (String) object;

                    finalMap.remove(string);

                    EnvironmentViewer.this.refresh();
                }
                int x = 1;
            }

        });

        contextMenu.add(unbindMenu);



        switch (columnIndex) {
            case 1:
                break;
            case 2:
                break;
            /*
            case 3:
                contextMenu.addSeparator();
                ActionListener changer = new ActionListener() {

                    public void actionPerformed(ActionEvent e) {
                        JMenuItem sourceItem = (JMenuItem) e.getSource();
                        Object value = sourceItem.getClientProperty(PROP_CHANGE_QUANTITY);
                        if (value instanceof Integer) {
                            Integer changeValue = (Integer) value;
                            Integer currentValue = (Integer) jTable.getModel().getValueAt(rowIndex, columnIndex);
                            jTable.getModel().setValueAt(
                                    new Integer(currentValue.intValue()
                                    + changeValue.intValue()), rowIndex,
                                    columnIndex);
                        }
                    }

                };
                JMenuItem changeItem = new JMenuItem();
                changeItem.setText("+1");
                changeItem.putClientProperty(PROP_CHANGE_QUANTITY,
                        new Integer(1));
                changeItem.addActionListener(changer);
                contextMenu.add(changeItem);

                changeItem = new JMenuItem();
                changeItem.setText("-1");
                changeItem.putClientProperty(PROP_CHANGE_QUANTITY,
                        new Integer(-1));
                changeItem.addActionListener(changer);
                contextMenu.add(changeItem);

                changeItem = new JMenuItem();
                changeItem.setText("+10");
                changeItem.putClientProperty(PROP_CHANGE_QUANTITY,
                        new Integer(10));
                changeItem.addActionListener(changer);
                contextMenu.add(changeItem);

                changeItem = new JMenuItem();
                changeItem.setText("-10");
                changeItem.putClientProperty(PROP_CHANGE_QUANTITY,
                        new Integer(-10));
                changeItem.addActionListener(changer);
                contextMenu.add(changeItem);

                changeItem = null;
                break;
            case 4:
                break;
             */
            default:
                break;
        }
        return contextMenu;
    }


    private JPanel getJContentPane() {
        if (jContentPane == null) {
            jContentPane = new JPanel();
            jContentPane.setLayout(new BorderLayout());
            jContentPane.add(getJScrollPane(),
                    java.awt.BorderLayout.CENTER);
        }
        return jContentPane;
    }


    private JScrollPane getJScrollPane() {
        if (jScrollPane == null) {
            jScrollPane = new JScrollPane();
            //jScrollPane.setViewportView(getJTable());
        }
        return jScrollPane;
    }

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/applets/0000755000175000017500000000000011722677340024373 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/applets/storage/0000755000175000017500000000000011722677340026037 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/applets/storage/DatahubApplet.java0000644000175000017500000001204611122043567031413 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.ui.gui.applets.storage;

import org.mathpiper.ui.gui.applets.*;
import java.applet.*;
import java.net.*;
import java.io.*;


/* This little applet should facilitate communication between Java and Javascript.
 * The idea is to allow Javascript to set data in this applet at various times, and
 * for the main MathPiper console to then get that data at startup, when it is loaded.
 *
 * The MathPiper console thus does not need to be loaded always, but this applet should
 * always be there.
 */


public class DatahubApplet extends Applet
{
	static Article consoleProgram = new Article("You can start entering your own program between the code delimiters below.\n\n{{code:\n:code}}\n"+
	                                "\n\n{{example:Example();:example}}");
	static Article journalProgram = new Article("No article loaded yet.");
	static Article tutorialProgram = new Article("{{code: Echo(\"Welcome to the MathPiper tutorial!\"); :code}}");
	static int currentProgram = 0;

	public void init()
	{
		String programMode = getParameter("programMode");
		if (programMode != null)
		{
			setProgramMode(programMode);
			String articleFromFile = getParameter("articleFromFile");
			if (articleFromFile != null)
			{
				setArticleFromFile(articleFromFile);
			}

			String article = getParameter("article");
			if (article != null)
			{
				setArticle(article);
			}
		}
	}

	Article currentArticle()
	{
		switch (currentProgram)
		{
		case 2:
			return tutorialProgram;
		case 1:
			return journalProgram;
		case 0:
		default:
			return consoleProgram;
		}
	}
	public String getProgram()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().codeBody;
		}
	}

	public String getExample()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().getExample();
		}
	}

	public String getTestcode()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().getTestcode();
		}
	}


	public String getNrExamples()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().getNrExamples();
		}
	}


	public String getArticle()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().iArticle;
		}
	}
	public String getArticleBody()
	{
		synchronized(consoleProgram)
		{
			return currentArticle().articleBody;
		}
	}

	public void setArticle(String p)
	{
		//System.out.println("article:\n"+p);
		synchronized(consoleProgram)
		{
			p = unescape(p);
			currentArticle().setArticle(p);
		}
	}

	public void setProgramMode(String mode)
	{
		synchronized(consoleProgram)
		{
			if (mode.equals("console"))
			{
				currentProgram = 0;
			}
			else if (mode.equals("journal"))
			{
				currentProgram = 1;
			}
			else if (mode.equals("tutorial"))
			{
				currentProgram = 2;
			}
		}
	}

	String readArticleFromFile(String urlStr)
	{
		String docbase = getDocumentBase().toString();
		int pos = docbase.lastIndexOf('/');
		if (pos > -1)
		{
			docbase = docbase.substring(0,pos+1);
		}
		else
		{
			docbase = "";
		}
		docbase = docbase+urlStr;

		String prog = "";
		try
		{
			URL url = new URL(docbase);
			BufferedReader in = new BufferedReader(new InputStreamReader(url.openStream()));

			if (in != null)
			{
				while (true)
				{
					try
					{
						String mark = in.readLine();
						if (mark == null)
							break;
						prog = prog + mark + "\n";
					}
					catch (Exception e)
					{
					}
				}
				in.close();
			}
		}
		catch(Exception e)
		{
		}
		return prog;
	}


	private int unhex(int c)
	{
		if (c>='0' && c <= '9')
		{
			return (c-'0');
		}
		if (c>='a' && c <= 'f')
		{
			return 10 + (c-'a');
		}
		if (c>='A' && c <= 'F')
		{
			return 10 + (c-'A');
		}
		return 65;
	}
	private String unescape(String s)
	{
		StringBuffer buf = new StringBuffer();
		int i,nr=s.length();
		for(i=0;i0)
		{
			result = examples[currentExample];
			currentExample++;
			if (currentExample == nrExamples)
			{
				currentExample = 0;
			}
		}
		return result;
	}

	public String getTestcode()
	{
		return testCode;
	}

	public String getNrExamples()
	{
		return ""+nrExamples;
	}

	void processText(String aString)
	{
		int pos = aString.indexOf("\n\n");
		if (pos == -1)
		{
			pos = aString.indexOf("\r\n\r\n");
		}
		if (pos == -1)
		{
			articleBody = articleBody + aString;
			return;
		}
		else
		{
			articleBody = articleBody + aString.substring(0, pos) + "\n

    \n";
			processText(aString.substring(pos + 2));
		}
	}
	void processBody(String aString)
	{
		int maxNrEntries = 10;
		String keys[] = new String[maxNrEntries];
		String values[] = new String[maxNrEntries];
		int nrEntries = 0;
		while (aString.length() > 0)
		{
			int pos = aString.indexOf("{{");
			if (pos == -1)
			{
				processText(aString);
				return;
			}
			processText(aString.substring(0, pos));
			aString = aString.substring(pos + 2);
			pos = aString.indexOf(":");
			String name = aString.substring(0, pos);
			aString = aString.substring(pos + 1);

			String toProcess = null;
			pos = name.indexOf(",");
			if (pos > -1)
			{
				toProcess = name.substring(pos+1);
				name = name.substring(0,pos);
			}

			String close = ":" + name + "}}";
			pos = aString.indexOf(close);
			String data = aString.substring(0, pos);
			aString = aString.substring(pos + close.length());

			nrEntries = 0;
			if (toProcess != null)
			{
				int pos3 = toProcess.indexOf(",");
				if (pos3 == -1)
					pos3 = toProcess.length();
				while (pos3>=0)
				{
					int pos2 = toProcess.indexOf(".");
					if (pos2 != -1)
					{
						keys[nrEntries] = toProcess.substring(0,pos2);
						values[nrEntries] = toProcess.substring(pos2+1,pos3);
						nrEntries++;
						if (nrEntries == maxNrEntries)
							break;
					}
					if (pos3 < toProcess.length())
					{
						toProcess = toProcess.substring(pos3+1);
						pos3 = toProcess.indexOf(",");
						if (pos3 == -1)
							pos3 = toProcess.length();
					}
					else
					{
						toProcess = "";
						pos3 = -1;
					}
				}
			}

			if (name.equals("title"))
			{
				articleBody = articleBody + "
    " + data + "
    ";
			}
			else if (name.equals("code"))
			{
				boolean addToArticle = true;

				int i;
				for (i=0;i
    " + data + "
    ";
				}
			}
			else if (name.equals("test"))
			{
				testCode = testCode + data;
			}
			else if (name.equals("expr"))
			{
				articleBody = articleBody + "" + data + "";
			}
			else if (name.equals("math"))
			{
				// Example:
				// {{math,heightPixels.120,widthPixels.700: ... :math}}
				int height=70;
				int i;
				for (i=0;i
    ";
			}
			else if (name.equals("example"))
			{
				if (nrExamples < 100)
				{
					examples[nrExamples] = data;
					nrExamples++;
				}
			}
		}
	}
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/0000755000175000017500000000000011722677340024550 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/ResultHolder.java0000644000175000017500000001563411506507632030034 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.Color;
import java.awt.Cursor;
import java.awt.Dimension;
import java.awt.Font;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;
import java.awt.event.MouseListener;
import javax.swing.BoxLayout;
import javax.swing.JLabel;
import javax.swing.JMenuItem;
import javax.swing.JPanel;
import javax.swing.JPopupMenu;
import javax.swing.JTextField;
import org.mathpiper.ui.gui.Utility;

import org.scilab.forge.jlatexmath.JMathTeXException;
import org.scilab.forge.jlatexmath.TeXConstants;
import org.scilab.forge.jlatexmath.TeXFormula;
import org.scilab.forge.jlatexmath.TeXIcon;

public class ResultHolder extends JPanel implements RenderingComponent, MouseListener {

    private TeXFormula texFormula;
    private JLabel renderedResult;
    private JTextField codeResult;
    private JTextField latexResult;
    private String resultString;
    private String latexString;
    private int toggle = 0;
    private SpinButton spinButton;
    private GoAwayButton goAwayButton;


    public ResultHolder(String latexString, String resultString, int fontPointSize) {


        this.latexString = latexString;
        this.resultString = resultString;


        this.renderedResult = new JLabel();

        try {
            texFormula = new TeXFormula(latexString);
            TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, fontPointSize);
            renderedResult.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
            renderedResult.setAlignmentY(icon.getBaseLine());
            renderedResult.setIcon(icon);
        } catch (JMathTeXException e) {
            renderedResult.setText(resultString);
            renderedResult.setAlignmentY(.9f);
        }




        renderedResult.setCursor(Cursor.getPredefinedCursor(Cursor.DEFAULT_CURSOR));
        renderedResult.setToolTipText("Click to see text versions of this expression.");
        renderedResult.addMouseListener(new MouseAdapter() {

            public void mouseClicked(MouseEvent e) {
                //eventOutput("Mouse clicked (# of clicks: "  + e.getClickCount() + ")", e);

                int buttonNumber = e.getButton();

                if (buttonNumber == MouseEvent.BUTTON3) {
                    JPopupMenu popup = new JPopupMenu();
                    JMenuItem menuItem = new JMenuItem("Save image to file");
                    menuItem.addActionListener(new ActionListener() {

                        public void actionPerformed(ActionEvent e) {
                           Utility.saveImageOfComponent(ResultHolder.this);
                        }

                    });

                    popup.add(menuItem);
                    popup.show(ResultHolder.this, 10, 10);


                } else {
                    toggle = 0;
                    toggleView();
                }

            }

        }//end method.
                );

        codeResult = new JTextField(resultString);
        codeResult.setAlignmentY(.7f);
        codeResult.setEditable(false);
        codeResult.setBackground(Color.white);
        Font newFontSize = new Font(codeResult.getFont().getName(), codeResult.getFont().getStyle(), fontPointSize);
        codeResult.setFont(newFontSize);
        codeResult.setMaximumSize(codeResult.getPreferredSize());
        codeResult.repaint();


        latexResult = new JTextField("$" + latexString + "$");
        latexResult.setAlignmentY(.7f);
        latexResult.setEditable(false);
        latexResult.setBackground(Color.white);
        newFontSize = new Font(latexResult.getFont().getName(), latexResult.getFont().getStyle(), fontPointSize);
        latexResult.setFont(newFontSize);
        latexResult.setMaximumSize(latexResult.getPreferredSize());
        latexResult.repaint();


        this.setBackground(Color.white);

        this.setOpaque(true);

        this.setLayout(new BoxLayout(this, BoxLayout.X_AXIS));

        this.add(renderedResult);


        spinButton = new SpinButton();
        spinButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                ResultHolder.this.toggleView();
            }//end method.

        });
        spinButton.setEnabled(true);
        spinButton.setAlignmentY(.9f);


        goAwayButton = new GoAwayButton();
        goAwayButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                ResultHolder.this.goAway();
            }//end method.

        });
        goAwayButton.setEnabled(true);
        goAwayButton.setAlignmentY(.9f);

        this.addMouseListener(this);

    }//end constructor.


    public void setScale(int scaleValue) {

        TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, scaleValue);
        renderedResult.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
        renderedResult.setAlignmentY(icon.getBaseLine());
        renderedResult.setIcon(icon);
        renderedResult.repaint();


        Font newFontSize = new Font(codeResult.getFont().getName(), codeResult.getFont().getStyle(), scaleValue);
        codeResult.setFont(newFontSize);
        codeResult.setMaximumSize(codeResult.getPreferredSize());
        codeResult.repaint();


        newFontSize = new Font(latexResult.getFont().getName(), latexResult.getFont().getStyle(), scaleValue);
        latexResult.setFont(newFontSize);
        latexResult.setMaximumSize(latexResult.getPreferredSize());
        latexResult.repaint();

    }//end method.


    void eventOutput(String eventDescription, MouseEvent e) {
        System.out.println(eventDescription + " detected on " + e.getComponent().getClass().getName() + ".");

    }


    public void mousePressed(MouseEvent e) {
        //eventOutput("Mouse pressed (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseReleased(MouseEvent e) {
        //eventOutput("Mouse released (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseEntered(MouseEvent e) {
        //eventOutput("Mouse entered", e);
    }


    public void mouseExited(MouseEvent e) {
        //eventOutput("Mouse exited", e);
    }


    public void mouseClicked(MouseEvent e) {
        //eventOutput("Mouse clicked (# of clicks: "  + e.getClickCount() + ")", e);
        toggle = 0;
        toggleView();

    }//end method.


    public void toggleView() {
        this.removeAll();

        if (toggle == 1) {
            toggle = 0;
            this.add(latexResult);
        } else {
            toggle = 1;

            this.add(codeResult);
        }

        this.add(spinButton);
        this.add(goAwayButton);

        this.revalidate();
        this.repaint();
    }


    private void goAway() {
        this.removeAll();
        this.add(renderedResult);
    }


    public String getCodeResult() {
        return resultString;
    }

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/RenderingComponent.java0000644000175000017500000000015611427462202031204 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;


public interface RenderingComponent
{
    void setScale(int scale);
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/Console.java0000644000175000017500000010730511363503630027012 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.consoles;

import java.awt.BorderLayout;
import java.awt.Color;
import java.awt.Container;
import java.awt.Dimension;
import java.awt.Font;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.ItemEvent;
import java.awt.event.ItemListener;
import java.awt.event.KeyEvent;
import java.awt.event.KeyListener;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;
import java.util.Stack;
import javax.swing.text.Element;
import javax.swing.text.AttributeSet;
import javax.swing.Box;
import javax.swing.BoxLayout;
import javax.swing.ButtonGroup;
import javax.swing.JButton;
import javax.swing.JCheckBox;
import javax.swing.JComponent;
import javax.swing.JFrame;
import javax.swing.JMenuItem;
import javax.swing.JOptionPane;
import javax.swing.JPanel;
import javax.swing.JPopupMenu;
import javax.swing.JRadioButton;
import javax.swing.JScrollPane;
import javax.swing.JSeparator;
import javax.swing.JSplitPane;
import javax.swing.JTextArea;
import javax.swing.JTextPane;
import javax.swing.SwingUtilities;
import javax.swing.text.BadLocationException;
import javax.swing.text.DefaultEditorKit;
import javax.swing.text.Document;
import javax.swing.text.MutableAttributeSet;
import javax.swing.text.SimpleAttributeSet;
import javax.swing.text.StyleConstants;
import javax.swing.text.StyleContext;
import javax.swing.text.StyledDocument;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.interpreters.ResponseListener;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

public class Console extends javax.swing.JPanel implements ActionListener, KeyListener, ResponseListener, ItemListener, MathPiperOutputStream {

    private boolean suppressOutput = false;
    private final Color green = new Color(0, 130, 0);
    private final Color purple = new Color(153, 0, 153);
    private Interpreter interpreter = Interpreters.getAsynchronousInterpreter();
    private StringBuilder input = new StringBuilder();
    private JButton haltButton, clearConsoleButton, clearRawButton, helpButton, button2, button3;
    private JCheckBox rawOutputCheckBox;
    private JCheckBox showRawOutputCheckBox;
    private JTextArea rawOutputTextArea;
    private ColorPane textPane;
    private MathPiperOutputStream currentOutput;
    private JScrollPane typePane;
    private char[] typedKey = new char[1];
    private JPanel consoleButtons;
    private JPanel rawButtons;
    private boolean deleteFlag = false;
    private int fontSize = 12;
    private Font bitstreamVera;
    private StringBuilder inputLines;
    private int responseInsertionOffset = -1;
    private boolean encounteredIn = false;
    private boolean noLinesBetweenInAndEndOfTextArea = false;
    private JSplitPane splitPane;
    private int splitPaneDividerLocation = 400;
    private JScrollPane rawOutputScrollPane;
    private JPanel rawOutputPanel;
    private JPopupMenu Pmenu;
    private Stack history = new java.util.Stack();
    private boolean controlKeyDown = false;
    private int historyIndex = -1;
    private int caretPositionWhenEnterWasPressed = -1;
    private JRadioButton numericModeButton;
    private JRadioButton symbolicModeButton;
    private ButtonGroup resultModeGroup;
    private boolean numericResultMode = false;

    private String helpMessage =
            "Enter an expression after any In> prompt and press  or  to evaluate it.\n\n" +
            "Type In> on the left end of any line to create your own input prompt.\n\n" +
            "Use  and  to navigate through the command line history.\n\n" +
            "The console window is an editable text area, so you can add text to it and remove text from \n" +
            "it as needed.\n\n" +
            "Placing ;; after the end of the line of input will suppress the output.\n\n" +
            "The Raw Output checkbox sends all side effects output to the raw output text area.";

    public Console() {

        inputLines = new StringBuilder();


        this.setLayout(new BorderLayout());

        //keySendQueue = new java.util.concurrent.ArrayBlockingQueue(30);

        consoleButtons = new JPanel();
        consoleButtons.setLayout(new BoxLayout(consoleButtons, BoxLayout.X_AXIS));


        rawOutputPanel = new JPanel();
        rawOutputPanel.setLayout(new BorderLayout());
        rawButtons = new JPanel();
        rawButtons.setLayout(new BoxLayout(rawButtons, BoxLayout.X_AXIS));



        //textArea = new JTextArea(30, 20);
        textPane = new ColorPane();

        textPane.append(purple, "MathPiper version " + org.mathpiper.Version.version + ".\n");
        textPane.append(purple, "Enter an expression after any In> prompt and press  or  to evaluate it.\n");


        textPane.append(Color.BLACK, "\nIn> ");
        textPane.setCaretPosition(textPane.getDocument().getLength());

        //java.io.InputStream inputStream = org.gjt.sp.jedit.jEdit.getPlugin("org.mathpiper.ide.u6502plugin.U6502Plugin").getPluginJAR().getClassLoader().getResourceAsStream( "resources/ttf-bitstream-vera-1.10/VeraMono.ttf" );

        //bitstreamVera = Font.createFont (Font.TRUETYPE_FONT, inputStream);
        //bitstreamVera = bitstreamVera.deriveFont(fontSize);
        //typeArea.setFont(bitstreamVera);


        textPane.addKeyListener(this);
        typePane = new JScrollPane(textPane);
        //guiBox.add(typePane);



        haltButton = new JButton("Halt Calculation");
        haltButton.setEnabled(false);
        haltButton.setForeground(Color.RED);
        haltButton.addActionListener(this);
        consoleButtons.add(haltButton);

/*
        numericModeButton = new JRadioButton("Numeric Mode");
        numericModeButton.addItemListener(this);
        symbolicModeButton = new JRadioButton("Symbolic Mode");
        symbolicModeButton.addItemListener(this);
        if(numericResultMode)
        {
            numericModeButton.setSelected(true);
        }
        else
        {
            symbolicModeButton.setSelected(true);
        }
        resultModeGroup = new ButtonGroup();
        resultModeGroup.add(numericModeButton);
        resultModeGroup.add(symbolicModeButton);
        consoleButtons.add(numericModeButton);
        consoleButtons.add(symbolicModeButton);
*/

        button2 = new JButton("Font-");
        button2.addActionListener(this);
        consoleButtons.add(button2);
        button3 = new JButton("Font+");
        button3.addActionListener(this);
        consoleButtons.add(button3);

        rawOutputCheckBox = new JCheckBox("Raw Side Effects");
        rawOutputCheckBox.addItemListener(this);
        rawButtons.add(rawOutputCheckBox);
        this.rawOutputTextArea = new JTextArea();
        rawOutputTextArea.setEditable(false);
        rawOutputTextArea.setText("Raw output text area.\n\n");


        showRawOutputCheckBox = new JCheckBox("Show Raw");
        showRawOutputCheckBox.addItemListener(this);
        consoleButtons.add(showRawOutputCheckBox);

        consoleButtons.add(Box.createGlue());


        clearConsoleButton = new JButton("Clear");
        clearConsoleButton.addActionListener(this);
        consoleButtons.add(clearConsoleButton);


        clearRawButton = new JButton("Clear Raw");
        clearRawButton.addActionListener(this);
        rawButtons.add(clearRawButton);


        helpButton = new JButton("Help");
        helpButton.addActionListener(this);
        consoleButtons.add(helpButton);



        this.add(consoleButtons, BorderLayout.NORTH);

        this.rawOutputPanel.add(rawButtons, BorderLayout.NORTH);

        //this.add(guiBox, BorderLayout.CENTER);


        rawOutputScrollPane = new JScrollPane(rawOutputTextArea);
        rawOutputPanel.add(rawOutputScrollPane);


        splitPane = new JSplitPane(JSplitPane.VERTICAL_SPLIT, typePane, null);
        splitPane.setOneTouchExpandable(true);
        splitPane.setDividerLocation(splitPaneDividerLocation);

        this.add(splitPane);



        this.addPopupMenu();


    }//Constructor.

    public void actionPerformed(ActionEvent event) {
        Object src = event.getSource();

        if (src == haltButton) {
            interpreter.haltEvaluation();
        } else if (src == button2) {
            this.fontSize -= 2;

            //bitstreamVera = bitstreamVera.deriveFont(fontSize);
            //typeArea.setFont(bitstreamVera);
            this.setJTextPaneFont(textPane, fontSize);
        } else if (src == button3) {
            this.fontSize += 2;
            //bitstreamVera = bitstreamVera.deriveFont(fontSize);
            //typeArea.setFont(bitstreamVera);
            this.setJTextPaneFont(textPane, fontSize);
        } else if (src == helpButton) {
            JOptionPane.showMessageDialog(this, this.helpMessage);
        } else if (src == clearConsoleButton) {
            this.textPane.setText("");
            this.textPane.append(Color.BLACK, "In> ");
        } else if (src == clearRawButton) {
            this.rawOutputTextArea.setText("");
        }

    }//end method.

    public void itemStateChanged(ItemEvent ie) {
        Object source = ie.getSource();

        if (source == rawOutputCheckBox) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                Environment environment = interpreter.getEnvironment();
                this.currentOutput = environment.iCurrentOutput;
                environment.iCurrentOutput = this;
            } else {
                Environment environment = interpreter.getEnvironment();
                environment.iCurrentOutput = this.currentOutput;
            }//end if/else.
        } else if (source == showRawOutputCheckBox) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                splitPane.add(rawOutputPanel);
                splitPane.setDividerLocation(splitPaneDividerLocation);
                splitPane.revalidate();
            } else {
                splitPane.remove(2);
                splitPane.revalidate();
            }//end if/else.
        } else if (source == numericModeButton) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                this.numericResultMode = true;
            } else {
                this.numericResultMode = false;
            }//end if/else.
        } else if (source == symbolicModeButton) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                this.numericResultMode = false;
            } else {
                this.numericResultMode = true;
            }//end if/else.

        }//end if/else.
    }//end method.

    public void putChar(char aChar) throws Exception {
        if (rawOutputTextArea != null && currentOutput != null) {
            this.rawOutputTextArea.append("" + aChar);
            this.rawOutputTextArea.setCaretPosition(this.rawOutputTextArea.getDocument().getLength());
            this.currentOutput.putChar(aChar);
        }//end if.
    }//end method.

    public void write(String aString) throws Exception {
        int i;
        for (i = 0; i < aString.length(); i++) {
            putChar(aString.charAt(i));
        }
    }//end method.

    public void keyPressed(KeyEvent e) {
        int keyCode = (int) e.getKeyCode();

        if (keyCode == KeyEvent.VK_CONTROL) {
            this.controlKeyDown = true;
        }//end if.


        if (keyCode == KeyEvent.VK_UP && this.controlKeyDown) {
            //System.out.println("up");

            if (!history.empty() && historyIndex != history.size() - 1) {


                historyIndex++;
                //System.out.println(history.get((history.size()-1) - historyIndex));

                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> " + (String) history.get((history.size() - 1) - historyIndex), lineStartOffset, lineEndOffset);

                } catch (BadLocationException ble) {
                    //Eat exception.
                }


            }//end if.

        }//end if.


    }//end method.

    public void keyReleased(KeyEvent e) {
        int keyCode = (int) e.getKeyCode();

        if (keyCode == KeyEvent.VK_CONTROL) {
            this.controlKeyDown = false;
        }//end if.


        if (keyCode == KeyEvent.VK_DOWN && this.controlKeyDown) {
            //System.out.println("down");

            if (!history.empty() && (!(historyIndex < 1))) {


                historyIndex--;
                //System.out.println(history.get((history.size()-1) - historyIndex));

                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> " + (String) history.get((history.size() - 1) - historyIndex), lineStartOffset, lineEndOffset);

                } catch (BadLocationException ble) {
                    //Eat exception.
                }

            } else if (!history.empty() && historyIndex == 0) {
                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> ", lineStartOffset, lineEndOffset);

                    this.historyIndex = -1;

                } catch (BadLocationException ble) {
                    //Eat exception.;
                }

            }//end else.
        }//end if.

    }//end method.

    public void keyTyped(KeyEvent e) {

        char key = e.getKeyChar();

        //System.out.println((int)key);

        if ((int) key == e.VK_ENTER || (int) key == 13) { //== 10) {
            try {

                //System.out.println("key pressed"); //TODO remove.

                //System.out.println("LN: " + lineNumber + "  LSO: " + lineStartOffset + "  LEO: " + lineEndOffset  );
                if (!e.isShiftDown()) {
                    textPane.replaceRange("", textPane.getCaretPosition() - 1, textPane.getCaretPosition());
                }//end if.

                caretPositionWhenEnterWasPressed = textPane.getCaretPosition();

                int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                //lineNumber--;
                String line = "";

                int lineStartOffset = textPane.getLineStartOffset(lineNumber);

                int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);

                if (line.startsWith("In> \n") || line.startsWith("In>\n")) {
                    //textPane.replaceRange("In> \n", lineStartOffset, lineEndOffset); //Just leave the In> there.
                    //textPane.setCaretPosition(lineEndOffset- 1);
                    } else if (line.startsWith("In>")) {

                    captureInputLines(lineNumber);

                    clearPreviousResponse();


                    String code = inputLines.toString().trim();

                    // System.out.println("1: " + code);

                    if (code.endsWith(";;")) {
                        this.suppressOutput = true;
                    }

                    code = code.replaceAll(";;;", ";");
                    code = code.replaceAll(";;", ";");

                    //code = code.replaceAll("\\\\", "");

                    //System.out.println("2: " + code);

                    history.push(code.substring(0, code.length() - 1));
                    this.historyIndex = -1;

                    if (code.length() > 0) {
                        interpreter.addResponseListener(this);
                        interpreter.evaluate("[" + code + "];", true);
                        haltButton.setEnabled(true);

                    }//end if.


                } else {
                    textPane.insert(Color.BLACK, "\n", caretPositionWhenEnterWasPressed);
                }



                //input.delete(0, input.length());
                // typeArea.append(response.getResult());

            } catch (BadLocationException ex) {
                System.out.println(ex.getMessage() + " , " + ex.offsetRequested());
            }

            //typeArea.append(new String(typedKey));
            //typeArea.setCaretPosition( typeArea.getDocument().getLength() );
       /* } else if ((int) key == 22) {
            try {
            String clipBoard = (String) java.awt.Toolkit.getDefaultToolkit().getSystemClipboard().getData(java.awt.datatransfer.DataFlavor.stringFlavor);

            if (clipBoard.length() != 0) {
            char[] chars = clipBoard.toCharArray();
            for (int x = 0; x < chars.length; x++) {
            //buffer.put((int) chars[x]);
            }//end for.
            //setReceiveDataRegisterFull(true);
            }//end if.

            } catch (NullPointerException ev) {
            ev.printStackTrace();
            } catch (IllegalStateException ev) {
            ev.printStackTrace();
            } catch (java.awt.datatransfer.UnsupportedFlavorException ev) {
            ev.printStackTrace();
            } catch (java.io.IOException ev) {
            ev.printStackTrace();
            }//*/
        } else {
            //System.out.println(key);
            //registers[0] = (int) key;
            if ((int) key == e.VK_BACK_SPACE) {  //== 8) {
                deleteFlag = true;
            }

            input.append(key);
            //typeArea.append(Character.toString(key));
            //buffer.put((int) key);
            //setReceiveDataRegisterFull(true);
        }
    }//end method.

    public void response(EvaluationResponse response) 
    {
/*
        if(this.numericResultMode)
        {
            try{
                Interpreter syncronousInterpreter = Interpreters.getSynchronousInterpreter();

                Cons atomCons = AtomCons.getInstance(syncronousInterpreter.getEnvironment(), -1, "N");

                atomCons.cdr().setCons(response.getResultList().getCons());

                Cons subListCons = SublistCons.getInstance(syncronousInterpreter.getEnvironment(), atomCons);

                ConsPointer inputExpressionPointer = new ConsPointer(subListCons);

                response = syncronousInterpreter.evaluate(inputExpressionPointer);
            }
            catch(Exception e)
            {
                e.printStackTrace();
            }
        }//end if.
*/



        //final int caretPosition = responseInsertionOffset;

        int offsetIndex = responseInsertionOffset;

        final int initialOffset = offsetIndex;

        String extraNewline = "";
        if (!encounteredIn) {

            if (noLinesBetweenInAndEndOfTextArea == true) {
                extraNewline = "\n";// + result + "\n\nIn> ";
                offsetIndex++;
            }

        }//end if.*/

        final int responseOffset = offsetIndex;
        String result;
        if (this.suppressOutput == false) {
            result = "Result: " + response.getResult().trim();
        } else {
            result = "Result: " + "OUTPUT SUPPRESSED";

            this.suppressOutput = false;
        }


        String sideEffects = null;
        int sideEffectsOffset = 0;
        int sideEffectsLength = 0;
        if (!response.getSideEffects().equalsIgnoreCase("")) {
            sideEffectsOffset = responseOffset + result.length();
            sideEffects = "\nSide Effects:\n" + response.getSideEffects();
            sideEffectsLength = sideEffects.length();
        }


        String exception = null;
        int exceptionOffset = 0;
        int exceptionLength = 0;
        if (response.isExceptionThrown()) {
            exceptionOffset = responseOffset + result.length() + sideEffectsOffset;
            exception = "\nException: " + response.getExceptionMessage();
            exceptionLength = exception.length();
        }





        final String finalExtraNewline = extraNewline;
        final String finalResult = result;
        final String finalSideEffects = sideEffects;
        final String finalException = exception;

        final int finalSideEffectsOffset = sideEffectsOffset;
        final int finalExceptionOffset = exceptionOffset;
        final int insertInOffset = responseOffset + result.length() + sideEffectsLength + exceptionLength;
        final int finalCaretPositionWhenEnterWasPressed = caretPositionWhenEnterWasPressed;



        /* if (insertionPointLine == lineCount - 1) {
        SwingUtilities.invokeLater(new Runnable() {

        public void run() {
        haltButton.setEnabled(false);
        textArea.append(Color.BLACK, finalOutput);
        }


        });

        //textArea.setCaretPosition( textArea.getDocument().getLength() );
        } else {*/
        SwingUtilities.invokeLater(new Runnable() {

            public void run() {
                haltButton.setEnabled(false);


                textPane.insert(Color.BLACK, finalExtraNewline, initialOffset); //finalExtraNewline

                textPane.insert(Color.BLUE, finalResult, responseOffset);

                if (finalSideEffects != null) {
                    textPane.insert(green, finalSideEffects, finalSideEffectsOffset);
                }

                if (finalException != null) {
                    textPane.insert(Color.RED, finalException, finalExceptionOffset);
                }


                if (!encounteredIn) {

                    textPane.insert(Color.BLACK, "\n\nIn> ", insertInOffset);

                } else {
                    //textPane.setCaretPosition(caretPosition - 1);
                    textPane.setCaretPosition(finalCaretPositionWhenEnterWasPressed);

                }


            }//end method.
        });

        //}//end if/else.

    }//end method.

    public boolean remove() {
        return true;
    }

    private void clearPreviousResponse() {

        try {
            int lineNumber = textPane.getLineOfOffset(responseInsertionOffset - 1);

            if (responseInsertionOffset == -1 || lineNumber == textPane.getLineCount()) {
                encounteredIn = false;
                return;
            }

            String line = "";
            int lineStartOffset = 0;
            int lineEndOffset = 0;

            do {

                lineNumber++;
                lineStartOffset = textPane.getLineStartOffset(lineNumber);
                lineEndOffset = textPane.getLineEndOffset(lineNumber);
                line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);

            } while (!line.startsWith("In>") && lineNumber < textPane.getLineCount());

            textPane.replaceRange("\n\n\n", responseInsertionOffset - 1, lineStartOffset);
            encounteredIn = line.startsWith("In>");
            return;

        } catch (BadLocationException ex) {
            encounteredIn = false;
            textPane.replaceRange("\n\n\n", responseInsertionOffset, textPane.getDocument().getLength());
            return;
        }
    }//end method.

    private void captureInputLines(int lineNumber) {

        inputLines.delete(0, inputLines.length());

        try {
            int lineStartOffset = textPane.getLineStartOffset(lineNumber);
            int lineEndOffset = textPane.getLineEndOffset(lineNumber);
            String line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);

            if (line.startsWith("In>")) {
                //Scan backwards to first line that does not start with In>.
                do {
                    lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    lineEndOffset = textPane.getLineEndOffset(lineNumber);
                    line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);
                    lineNumber--;

                } while (line.startsWith("In>") && lineNumber != -1);//end do/while.

                if (lineNumber != -1) {
                    lineNumber++;
                }


                //Scan forwards to first line that does not start with In>.
                boolean pastInputLines = false;
                noLinesBetweenInAndEndOfTextArea = false;
                do {
                    lineNumber++;
                    lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    lineEndOffset = textPane.getLineEndOffset(lineNumber);
                    line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset).trim();
                    if (line.startsWith("In>")) {
                        String eol = new String(line);
                        inputLines.append(line.substring(3, line.length()).trim());
                        responseInsertionOffset = lineEndOffset;
                        if (!eol.endsWith(";") && !eol.endsWith("\\\n")) {
                            inputLines.append(";");
                        }//end if.
                    } else {
                        pastInputLines = true;
                    }


                } while (!pastInputLines && lineNumber < textPane.getLineCount());//end while.

            }//end if.

        } catch (BadLocationException ex) {
            noLinesBetweenInAndEndOfTextArea = true;
        }


    }//end method.

    public void setHaltButtonEnabledState(boolean state) {
        this.haltButton.setEnabled(state);

    }//end method.

    public class ColorPane extends JTextPane {

        public void append(Color c, String s) { // better implementation--uses
            // StyleContext
            StyleContext sc = StyleContext.getDefaultStyleContext();
            AttributeSet aset = sc.addAttribute(SimpleAttributeSet.EMPTY,
                    StyleConstants.Foreground, c);

            int len = getDocument().getLength(); // same value as
            // getText().length();
            setCaretPosition(len); // place caret at the end (with no selection)
            setCharacterAttributes(aset, false);
            replaceSelection(s); // there is no selection, so inserts at caret
        }//end method.

        public void insert(Color c, String str, int pos) {

            Font font = getFont();

            MutableAttributeSet attrs = getInputAttributes();


            StyleConstants.setFontFamily(attrs, font.getFamily());
            StyleConstants.setFontSize(attrs, fontSize);
            StyleConstants.setForeground(attrs, c);

            //StyleContext sc = StyleContext.getDefaultStyleContext();
            //MutableAttributeSet aset = this.getInputAttributes();
            //AttributeSet aset = sc.addAttribute(SimpleAttributeSet.EMPTY, StyleConstants.Foreground, c);
            setCaretPosition(pos); // place caret at the end (with no selection)
            setCharacterAttributes(attrs, false);
            replaceSelection(str);



        }

        /**
         * Translates an offset into the components text to a
         * line number.
         *
         * @param offset the offset >= 0
         * @return the line number >= 0
         * @exception BadLocationException thrown if the offset is
         *   less than zero or greater than the document length.
         */
        public int getLineOfOffset(int offset) throws BadLocationException {
            Document doc = getDocument();
            if (offset < 0) {
                throw new BadLocationException("Can't translate offset to line", -1);
            } else if (offset > doc.getLength()) {
                throw new BadLocationException("Can't translate offset to line", doc.getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                return map.getElementIndex(offset);
            }
        }

        /**
         * Determines the number of lines contained in the area.
         *
         * @return the number of lines > 0
         */
        public int getLineCount() {
            Element map = getDocument().getDefaultRootElement();
            return map.getElementCount();
        }

        /**
         * Determines the offset of the start of the given line.
         *
         * @param line  the line number to translate >= 0
         * @return the offset >= 0
         * @exception BadLocationException thrown if the line is
         * less than zero or greater or equal to the number of
         * lines contained in the document (as reported by
         * getLineCount).
         */
        public int getLineStartOffset(int line) throws BadLocationException {
            int lineCount = getLineCount();
            if (line < 0) {
                throw new BadLocationException("Negative line", -1);
            } else if (line >= lineCount) {
                throw new BadLocationException("No such line", getDocument().getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                Element lineElem = map.getElement(line);
                return lineElem.getStartOffset();
            }
        }

        /**
         * Determines the offset of the end of the given line.
         *
         * @param line  the line >= 0
         * @return the offset >= 0
         * @exception BadLocationException Thrown if the line is
         * less than zero or greater or equal to the number of
         * lines contained in the document (as reported by
         * getLineCount).
         */
        public int getLineEndOffset(int line) throws BadLocationException {
            int lineCount = getLineCount();
            if (line < 0) {
                throw new BadLocationException("Negative line", -1);
            } else if (line >= lineCount) {
                throw new BadLocationException("No such line", getDocument().getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                Element lineElem = map.getElement(line);
                int endOffset = lineElem.getEndOffset();
                // hide the implicit break at the end of the document
                return ((line == lineCount - 1) ? (endOffset - 1) : endOffset);
            }
        }

        /**
         * Replaces text from the indicated start to end position with the
         * new text specified.  Does nothing if the model is null.  Simply
         * does a delete if the new string is null or empty.
         * 
    
         * This method is thread safe, although most Swing methods
         * are not.
         *
         * @param str the text to use as the replacement
         * @param start the start position >= 0
         * @param end the end position >= start
         * @exception IllegalArgumentException  if part of the range is an
         *  invalid position in the model
         * @see #insert
         * @see #replaceRange
         */
        public void replaceRange(String str, int start, int end) {
            if (end < start) {
                throw new IllegalArgumentException("end before start");
            }


            Font font = getFont();

            MutableAttributeSet attrs = getInputAttributes();


            StyleConstants.setFontFamily(attrs, font.getFamily());
            StyleConstants.setFontSize(attrs, fontSize);


            setCharacterAttributes(attrs, false);
            this.select(start, end);
            replaceSelection(str);

        }//end method.
    }//end class

    public void setJTextPaneFont(JTextPane textPane, int fontSize) {

        Font font = textPane.getFont();

        MutableAttributeSet attrs = textPane.getInputAttributes();

        StyleConstants.setFontFamily(attrs, font.getFamily());
        StyleConstants.setFontSize(attrs, fontSize);

        StyledDocument doc = textPane.getStyledDocument();


        doc.setCharacterAttributes(0, doc.getLength() + 1, attrs, false);
    }//end method.

    public static class PopupTriggerMouseListener extends MouseAdapter {

        private JPopupMenu popup;
        private JComponent component;

        public PopupTriggerMouseListener(JPopupMenu popup, JComponent component) {
            this.popup = popup;
            this.component = component;
        }

        //some systems trigger popup on mouse press, others on mouse release, we want to cater for both
        private void showMenuIfPopupTrigger(MouseEvent e) {
            if (e.isPopupTrigger()) {
                popup.show(component, e.getX() + 3, e.getY() + 3);
            }
        }

        //according to the javadocs on isPopupTrigger, checking for popup trigger on mousePressed and mouseReleased
        //should be all  that is required
        //public void mouseClicked(MouseEvent e)
        public void mousePressed(MouseEvent e) {
            showMenuIfPopupTrigger(e);
        }

        public void mouseReleased(MouseEvent e) {
            showMenuIfPopupTrigger(e);
        }
    }//end method.

    private void addPopupMenu() {
        final JPopupMenu menu = new JPopupMenu();
        final JMenuItem copyItem = new JMenuItem();
        copyItem.setAction(textPane.getActionMap().get(DefaultEditorKit.copyAction));
        copyItem.setText("Copy");

        final JMenuItem cutItem = new JMenuItem();
        cutItem.setAction(textPane.getActionMap().get(DefaultEditorKit.cutAction));
        cutItem.setText("Cut");

        final JMenuItem pasteItem = new JMenuItem("Paste");
        pasteItem.setAction(textPane.getActionMap().get(DefaultEditorKit.pasteAction));
        pasteItem.setText("Paste");

        final JMenuItem selectAllItem = new JMenuItem("Select All");
        selectAllItem.setAction(textPane.getActionMap().get(DefaultEditorKit.selectAllAction));
        selectAllItem.setText("Select All");

        final JMenuItem insertPrompt = new JMenuItem("Insert In>");
        insertPrompt.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {
                textPane.insert(Color.BLACK, "In> ", textPane.getCaretPosition());
            }
        });
        insertPrompt.setText("Insert In>");

        menu.add(copyItem);
        menu.add(cutItem);
        menu.add(pasteItem);
        menu.add(new JSeparator());
        menu.add(selectAllItem);
        menu.add(new JSeparator());
        menu.add(insertPrompt);


        textPane.add(menu);
        textPane.addMouseListener(new PopupTriggerMouseListener(menu, textPane));
    }//end method.

    public static void main(String[] args) {
        Console console = new Console();

        JFrame frame = new javax.swing.JFrame();
        Container contentPane = frame.getContentPane();
        contentPane.add(console, BorderLayout.CENTER);
        //frame.setAlwaysOnTop(true);
        frame.setSize(new Dimension(800, 600));
        frame.setDefaultCloseOperation(frame.DISPOSE_ON_CLOSE);
        //frame.setResizable(false);
        frame.setPreferredSize(new Dimension(800, 600));
        frame.setLocationRelativeTo(null); // added
        frame.pack();
        frame.setVisible(true);
    }//end main.
}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/StructureDialog.java0000644000175000017500000000100311422075334030515 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import javax.swing.*;

public class StructureDialog extends JDialog {

    EditorPaneStructure pnlStructure;
    public StructureDialog(JEditorPane source) {
        //super(parent, "Structure");
        super();

        pnlStructure=new EditorPaneStructure(source);
        pnlStructure.refresh();
        getContentPane().add(pnlStructure);
        setSize(700,500);
        setLocationRelativeTo(null);

        setDefaultCloseOperation(JDialog.DISPOSE_ON_CLOSE);
    }
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/GraphicConsole.java0000644000175000017500000015417311562051265030320 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.ui.gui.consoles;


import java.awt.BorderLayout;
import java.awt.Color;
import java.awt.Container;
import java.awt.Dimension;
import java.awt.FlowLayout;
import java.awt.Font;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.FocusEvent;
import java.awt.event.FocusListener;
import java.awt.event.ItemEvent;
import java.awt.event.ItemListener;
import java.awt.event.KeyEvent;
import java.awt.event.KeyListener;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;
import java.awt.event.WindowAdapter;
import java.awt.event.WindowEvent;
import java.io.BufferedReader;
import java.io.BufferedWriter;
import java.io.File;
import java.io.FileInputStream;
import java.io.FileNotFoundException;
import java.io.FileWriter;
import java.io.IOException;
import java.io.InputStreamReader;
import java.util.Stack;
import javax.swing.BorderFactory;
import javax.swing.text.Element;
import javax.swing.Box;
import javax.swing.BoxLayout;
import javax.swing.ButtonGroup;
import javax.swing.JButton;
import javax.swing.JCheckBox;
import javax.swing.JComponent;
import javax.swing.JFileChooser;
import javax.swing.JFrame;
import javax.swing.JMenu;
import javax.swing.JMenuBar;
import javax.swing.JMenuItem;
import javax.swing.JOptionPane;
import javax.swing.JPanel;
import javax.swing.JPopupMenu;
import javax.swing.JRadioButton;
import javax.swing.JScrollPane;
import javax.swing.JSeparator;
import javax.swing.JSplitPane;
import javax.swing.JTextArea;
import javax.swing.JTextPane;
import javax.swing.SwingUtilities;
import javax.swing.text.BadLocationException;
import javax.swing.text.DefaultEditorKit;
import javax.swing.text.Document;
import javax.swing.text.MutableAttributeSet;
import javax.swing.text.SimpleAttributeSet;
import javax.swing.text.Style;
import javax.swing.text.StyleConstants;
import javax.swing.text.StyledDocument;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.interpreters.ResponseListener;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

public class GraphicConsole extends javax.swing.JPanel implements ActionListener, KeyListener, ResponseListener, ItemListener, FocusListener, MathPiperOutputStream {

    ResultHolder resultHolder;
    private boolean suppressOutput = false;
    private final Color green = new Color(0, 130, 0);
    private final Color purple = new Color(153, 0, 153);
    private Interpreter interpreter = Interpreters.getAsynchronousInterpreter();
    private StringBuilder input = new StringBuilder();
    private JButton haltButton, clearConsoleButton, clearRawButton, helpButton, smallerFontButton, largerFontButton;
    private JCheckBox rawOutputCheckBox;
    private boolean isCodeResult = false;
    private JCheckBox codeResultCheckBox;
    private JCheckBox showRawOutputCheckBox;
    private JTextArea rawOutputTextArea;
    private ColorPane textPane;
    private MathPiperOutputStream currentOutput;
    private JScrollPane typePane;
    private JPanel consoleButtons;
    private JPanel rawButtons;
    private int fontSize = 12;
    private int resultHolderAdjustment = 3;
    private StringBuilder inputLines;
    private int responseInsertionOffset = -1;
    private boolean encounteredIn = false;
    private boolean noLinesBetweenInAndEndOfTextArea = false;
    private JSplitPane splitPane;
    private int splitPaneDividerLocation = 400;
    private JScrollPane rawOutputScrollPane;
    private JPanel rawOutputPanel;
    private JPopupMenu Pmenu;
    private Stack history = new java.util.Stack();
    private boolean controlKeyDown = false;
    private int historyIndex = -1;
    private int caretPositionWhenEnterWasPressed = -1;
    private boolean deleteFlag = false;
    private JRadioButton numericModeButton;
    private JRadioButton symbolicModeButton;
    private ButtonGroup resultModeGroup;
    private boolean numericResultMode = false;
    private JMenuBar menuBar;
    private JFileChooser fileChooser;
    private String helpMessage =
            "Enter an expression after any In> prompt and press  or  to evaluate it.\n\n" +
            "Type In> on the left end of any line to create your own input prompt.\n\n" +
            "Use  and  to navigate through the command line history.\n\n" +
            "Click on any result to obtain a code or a LaTeX version of it.\n\n" +
            "The console window is an editable text area, so you can add text to it and remove text from \n" +
            "it as needed.\n\n" +
            "Placing ;; after the end of the line of input will suppress the output.\n\n" +
            "The Raw Output checkbox sends all side effects output to the raw output text area.";


    public GraphicConsole() {

        inputLines = new StringBuilder();


        this.setLayout(new BorderLayout());

        //keySendQueue = new java.util.concurrent.ArrayBlockingQueue(30);



        consoleButtons = new JPanel();
        consoleButtons.setLayout(new BoxLayout(consoleButtons, BoxLayout.X_AXIS));


        rawOutputPanel = new JPanel();
        rawOutputPanel.setLayout(new BorderLayout());
        rawButtons = new JPanel();
        rawButtons.setLayout(new BoxLayout(rawButtons, BoxLayout.X_AXIS));



        //textArea = new JTextArea(30, 20);
        textPane = new ColorPane();

        textPane.append(purple, "MathPiper version " + org.mathpiper.Version.version + ".\n");
        textPane.append(purple, "Enter an expression after any In> prompt and press  or  to evaluate it.\n");


        textPane.append(Color.BLACK, "\nIn> \n");
        textPane.setCaretPosition(textPane.getDocument().getLength() - 1);

        //java.io.InputStream inputStream = org.gjt.sp.jedit.jEdit.getPlugin("org.mathpiper.ide.u6502plugin.U6502Plugin").getPluginJAR().getClassLoader().getResourceAsStream( "resources/ttf-bitstream-vera-1.10/VeraMono.ttf" );

        //bitstreamVera = Font.createFont (Font.TRUETYPE_FONT, inputStream);
        //bitstreamVera = bitstreamVera.deriveFont(fontSize);
        //typeArea.setFont(bitstreamVera);


        textPane.addKeyListener(this);
        typePane = new JScrollPane(textPane);
        //guiBox.add(typePane);

        StyledDocument document = textPane.getStyledDocument();
        SimpleAttributeSet attrs = new SimpleAttributeSet();
        StyleConstants.setFontSize(attrs, fontSize);
        document.setCharacterAttributes(0, document.getLength() + 1, attrs, false);
        document.setParagraphAttributes(0, document.getLength() + 1, attrs, true);



        haltButton = new JButton("Halt Calculation");
        haltButton.setEnabled(false);
        haltButton.setForeground(Color.RED);
        haltButton.addActionListener(this);
        consoleButtons.add(haltButton);



        smallerFontButton = new JButton("Font-");
        smallerFontButton.addActionListener(this);
        consoleButtons.add(smallerFontButton);
        largerFontButton = new JButton("Font+");
        largerFontButton.addActionListener(this);
        consoleButtons.add(largerFontButton);

        rawOutputCheckBox = new JCheckBox("Raw Side Effects");
        rawOutputCheckBox.addItemListener(this);
        rawButtons.add(rawOutputCheckBox);
        this.rawOutputTextArea = new JTextArea();
        rawOutputTextArea.setEditable(false);
        rawOutputTextArea.setText("Raw output text area.\n\n");

        codeResultCheckBox = new JCheckBox("Code Result");
        codeResultCheckBox.setToolTipText("Show results in code format instead of traditional mathematics format.");
        codeResultCheckBox.addItemListener(this);
        consoleButtons.add(codeResultCheckBox);

        showRawOutputCheckBox = new JCheckBox("Show Raw");
        showRawOutputCheckBox.addItemListener(this);
        consoleButtons.add(showRawOutputCheckBox);

        consoleButtons.add(Box.createGlue());


        clearConsoleButton = new JButton("Clear");
        clearConsoleButton.addActionListener(this);
        consoleButtons.add(clearConsoleButton);


        clearRawButton = new JButton("Clear Raw");
        clearRawButton.addActionListener(this);
        rawButtons.add(clearRawButton);


        helpButton = new JButton("Help");
        helpButton.addActionListener(this);
        consoleButtons.add(helpButton);



        JButton structureButton = new javax.swing.JButton("Structure");
        structureButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {

                new StructureDialog(textPane).setVisible(true);

            }//end method.

        });
        structureButton.setEnabled(true);
        //consoleButtons.add(structureButton);



        JButton testButton = new javax.swing.JButton("Test");
        testButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                MathPiperDocument document = (MathPiperDocument) textPane.getDocument();

                /*SimpleAttributeSet attrs = new SimpleAttributeSet();
                StyleConstants.setFontSize(attrs, fontSize + 5);
                document.setCharacterAttributes(0, document.getLength() + 1, attrs, false);*/

                //document.scanTree(fontSize);

                document.scanViews(textPane, fontSize);

            }//end method.

        });
        testButton.setEnabled(true);
        //consoleButtons.add(testButton);


        

        this.rawOutputPanel.add(rawButtons, BorderLayout.NORTH);

        //this.add(guiBox, BorderLayout.CENTER);


        rawOutputScrollPane = new JScrollPane(rawOutputTextArea);
        rawOutputPanel.add(rawOutputScrollPane);


        splitPane = new JSplitPane(JSplitPane.VERTICAL_SPLIT, typePane, null);
        splitPane.setOneTouchExpandable(true);
        splitPane.setDividerLocation(splitPaneDividerLocation);

        this.add(splitPane);


        this.addPopupMenu();

        this.fileChooser = new JFileChooser();


        JPanel menuAndToolPanel = new JPanel();

        menuAndToolPanel.setLayout(new BoxLayout(menuAndToolPanel, BoxLayout.Y_AXIS));


        this.menuBar = new MenuBar();


        //menuBar.setBorder(BorderFactory.createCompoundBorder( BorderFactory.createLineBorder(Color.red), menuBar.getBorder())); //For testing.

        menuAndToolPanel.add(menuBar);
        
        menuAndToolPanel.add(consoleButtons);

        this.add(menuAndToolPanel, BorderLayout.NORTH);


    }//Constructor.


    public void actionPerformed(ActionEvent event) {
        Object src = event.getSource();

        if (src == haltButton) {
            interpreter.haltEvaluation();
        } else if (src == smallerFontButton) {
            this.fontSize -= 2;

            MathPiperDocument document = (MathPiperDocument) textPane.getDocument();
            /*
            document.putProperty("ZOOM_FACTOR", new Double(zoomScale));
            document.refresh();*/

            this.setJTextPaneFont(textPane, fontSize);
            document.scanViews(textPane, fontSize + resultHolderAdjustment);
        } else if (src == largerFontButton) {
            this.fontSize += 2;

            MathPiperDocument document = (MathPiperDocument) textPane.getDocument();
            /*document.putProperty("ZOOM_FACTOR", new Double(zoomScale));
            document.refresh();*/

            this.setJTextPaneFont(textPane, fontSize);
            document.scanViews(textPane, fontSize + resultHolderAdjustment);


        } else if (src == helpButton) {
            JOptionPane.showMessageDialog(this, this.helpMessage);
        } else if (src == clearConsoleButton) {
            this.textPane.setText("");
            this.textPane.append(Color.BLACK, "In> \n");
            textPane.setCaretPosition(textPane.getDocument().getLength() - 1);
        } else if (src == clearRawButton) {
            this.rawOutputTextArea.setText("");
        }

        textPane.requestFocusInWindow();

    }//end method.


    public void itemStateChanged(ItemEvent ie) {
        Object source = ie.getSource();

        if (source == codeResultCheckBox) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                isCodeResult = true;
            } else {
                isCodeResult = false;
            }//end if/else.
        }
        if (source == rawOutputCheckBox) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                Environment environment = interpreter.getEnvironment();
                this.currentOutput = environment.iCurrentOutput;
                environment.iCurrentOutput = this;
            } else {
                Environment environment = interpreter.getEnvironment();
                environment.iCurrentOutput = this.currentOutput;
            }//end if/else.
        } else if (source == showRawOutputCheckBox) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                splitPane.add(rawOutputPanel);
                splitPane.setDividerLocation(splitPaneDividerLocation);
                splitPane.revalidate();
            } else {
                splitPane.remove(2);
                splitPane.revalidate();
            }//end if/else.
        } else if (source == numericModeButton) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                this.numericResultMode = true;
            } else {
                this.numericResultMode = false;
            }//end if/else.
        } else if (source == symbolicModeButton) {
            if (ie.getStateChange() == ItemEvent.SELECTED) {
                this.numericResultMode = false;
            } else {
                this.numericResultMode = true;
            }//end if/else.

        }//end if/else.

        textPane.requestFocusInWindow();
    }//end method.


    public void putChar(char aChar) throws Exception {
        if (rawOutputTextArea != null && currentOutput != null) {
            this.rawOutputTextArea.append("" + aChar);
            this.rawOutputTextArea.setCaretPosition(this.rawOutputTextArea.getDocument().getLength());
            this.currentOutput.putChar(aChar);
        }//end if.
    }//end method.


    public void write(String aString) throws Exception {
        int i;
        for (i = 0; i < aString.length(); i++) {
            putChar(aString.charAt(i));
        }
    }//end method.


    public void keyPressed(KeyEvent e) {
        int keyCode = (int) e.getKeyCode();

        if (keyCode == KeyEvent.VK_CONTROL) {
            this.controlKeyDown = true;
        }//end if.


        if (keyCode == KeyEvent.VK_UP && this.controlKeyDown) {
            //System.out.println("up");

            if (!history.empty() && historyIndex != history.size() - 1) {


                historyIndex++;
                //System.out.println(history.get((history.size()-1) - historyIndex));

                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> " + (String) history.get((history.size() - 1) - historyIndex) + "\n", lineStartOffset, lineEndOffset);

                    textPane.setCaretPosition(textPane.getLineEndOffset(lineNumber) - 1);

                } catch (BadLocationException ble) {
                    //Eat exception.
                }


            }//end if.

        }//end if.


    }//end method.


    public void keyReleased(KeyEvent e) {
        int keyCode = (int) e.getKeyCode();

        if (keyCode == KeyEvent.VK_CONTROL) {
            this.controlKeyDown = false;
        }//end if.


        if (keyCode == KeyEvent.VK_DOWN && this.controlKeyDown) {
            //System.out.println("down");

            if (!history.empty() && (!(historyIndex < 1))) {


                historyIndex--;
                //System.out.println(history.get((history.size()-1) - historyIndex));

                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> " + (String) history.get((history.size() - 1) - historyIndex) + "\n", lineStartOffset, lineEndOffset);

                    textPane.setCaretPosition(textPane.getLineEndOffset(lineNumber) - 1);

                } catch (BadLocationException ble) {
                    //Eat exception.
                }

            } else if (!history.empty() && historyIndex == 0) {
                try {
                    int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                    int lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                    textPane.replaceRange("In> \n", lineStartOffset, lineEndOffset);

                    textPane.setCaretPosition(textPane.getLineEndOffset(lineNumber) - 1);

                    this.historyIndex = -1;

                } catch (BadLocationException ble) {
                    //Eat exception.;
                }

            }//end else.
        }//end if.

    }//end method.


    public void keyTyped(KeyEvent e) {

        char key = e.getKeyChar();

        //System.out.println((int)key);

        if ((int) key == e.VK_ENTER || (int) key == 13) { //== 10) {
            try {

                //System.out.println("key pressed"); //TODO remove.

                //System.out.println("LN: " + lineNumber + "  LSO: " + lineStartOffset + "  LEO: " + lineEndOffset  );
                if (!e.isShiftDown()) {
                    textPane.replaceRange("", textPane.getCaretPosition() - 1, textPane.getCaretPosition());
                }//end if.

                caretPositionWhenEnterWasPressed = textPane.getCaretPosition();

                int lineNumber = textPane.getLineOfOffset(textPane.getCaretPosition());
                //lineNumber--;
                String line = "";

                int lineStartOffset = textPane.getLineStartOffset(lineNumber);

                int lineEndOffset = textPane.getLineEndOffset(lineNumber);

                line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);


                if (line.startsWith("In>")) {
                    //Check for a RenderingComponent in the input line.
                    int lineIndex = 3;
                    for (int lineOffsetIndex = lineStartOffset + 3; lineOffsetIndex < lineEndOffset; lineOffsetIndex++) {
                        Element element = textPane.getStyledDocument().getCharacterElement(lineOffsetIndex);
                        if (element.isLeaf()) {
                            Object object = element.getAttributes().getAttribute(StyleConstants.ComponentAttribute);

                            if (object instanceof LatexComponent) {
                                line = line.subSequence(0, lineIndex) + " " + object.toString() + " " + line.substring(lineIndex);

                                System.out.println(line);
                            }
                        }
                        lineIndex++;
                    }//end for
                }


                if (line.startsWith("In>") && line.substring(3).trim().equals("")) {
                } else if (line.startsWith("In>")) {

                    //String eol = new String(line);
                    String code = line.substring(3, line.length()).trim();
                    responseInsertionOffset = lineEndOffset;

                    /*if (!eol.endsWith(";") && !eol.endsWith("\\\n")) {
                    code = code + ";";
                    }//end if.*/

                    if (!code.endsWith(";")) {
                        code = code + ";";
                    }

                    clearPreviousResponse();


                    // System.out.println("1: " + code);

                    if (code.endsWith(";;")) {
                        this.suppressOutput = true;
                    }

                    code = code.replaceAll(";;;", ";");
                    code = code.replaceAll(";;", ";");

                    //code = code.replaceAll("\\\\", "");

                    //System.out.println("2: " + code);

                    history.push(code.substring(0, code.length() - 1));
                    this.historyIndex = -1;

                    if (code.length() > 0) {
                        interpreter.addResponseListener(this);
                        interpreter.evaluate("[" + code + "];", true);
                        haltButton.setEnabled(true);

                    }//end if.


                } else {
                    textPane.insert(Color.BLACK, "\n", caretPositionWhenEnterWasPressed);
                }



                //input.delete(0, input.length());
                // typeArea.append(response.getResult());

            } catch (BadLocationException ex) {
                System.out.println(ex.getMessage() + " , " + ex.offsetRequested());
            }

            //typeArea.append(new String(typedKey));
            //typeArea.setCaretPosition( typeArea.getDocument().getLength() );
       /* } else if ((int) key == 22) {
            try {
            String clipBoard = (String) java.awt.Toolkit.getDefaultToolkit().getSystemClipboard().getData(java.awt.datatransfer.DataFlavor.stringFlavor);

            if (clipBoard.length() != 0) {
            char[] chars = clipBoard.toCharArray();
            for (int x = 0; x < chars.length; x++) {
            //buffer.put((int) chars[x]);
            }//end for.
            //setReceiveDataRegisterFull(true);
            }//end if.

            } catch (NullPointerException ev) {
            ev.printStackTrace();
            } catch (IllegalStateException ev) {
            ev.printStackTrace();
            } catch (java.awt.datatransfer.UnsupportedFlavorException ev) {
            ev.printStackTrace();
            } catch (java.io.IOException ev) {
            ev.printStackTrace();
            }//*/
        } else {
            //System.out.println(key);
            //registers[0] = (int) key;
            if ((int) key == e.VK_BACK_SPACE) {  //== 8) {
                deleteFlag = true;
            }

            input.append(key);
            //typeArea.append(Character.toString(key));
            //buffer.put((int) key);
            //setReceiveDataRegisterFull(true);
        }
    }//end method.


    public void response(EvaluationResponse response) {

        resultHolder = new ResultHolder("Error in GraphicConsole.", "Error in GraphicConsole.", fontSize + resultHolderAdjustment);

        Object responseObject = response.getObject();

        if (response.isExceptionThrown()) {
            resultHolder = new ResultHolder("Exception", "Exception", fontSize + resultHolderAdjustment);
        }
        else if (responseObject instanceof java.awt.Component)
        {
            String className = responseObject.getClass().toString();

            resultHolder = new ResultHolder(className.replace(" ", "\\vspace{20 mm"), className, fontSize + resultHolderAdjustment);
        } else {

            if (responseObject == null && response.getResultList() != null) {


                if (!isCodeResult) {
                    try {
                        Interpreter syncronousInterpreter = Interpreters.getSynchronousInterpreter();

                        //Evaluate Hold function.
                        Cons holdAtomCons = AtomCons.getInstance(syncronousInterpreter.getEnvironment(), -1, "Hold");
                        holdAtomCons.cdr().setCons(response.getResultList().getCons());
                        Cons holdSubListCons = SublistCons.getInstance(syncronousInterpreter.getEnvironment(), holdAtomCons);
                        ConsPointer holdInputExpressionPointer = new ConsPointer(holdSubListCons);


                        //Evaluate TeXForm function.
                        Cons texFormAtomCons = AtomCons.getInstance(syncronousInterpreter.getEnvironment(), -1, "TeXForm");
                        texFormAtomCons.cdr().setCons(holdInputExpressionPointer.getCons());
                        Cons texFormSubListCons = SublistCons.getInstance(syncronousInterpreter.getEnvironment(), texFormAtomCons);
                        ConsPointer texFormInputExpressionPointer = new ConsPointer(texFormSubListCons);
                        EvaluationResponse latexResponse = syncronousInterpreter.evaluate(texFormInputExpressionPointer);

                        String latexString = latexResponse.getResult();

                        latexString = Utility.stripEndQuotesIfPresent(null, -1, latexString);

                        latexString = Utility.stripEndDollarSigns(latexString);

                        resultHolder = new ResultHolder(latexString, response.getResult(), fontSize + resultHolderAdjustment);


                        //Set the % variable to the original result.
                        Environment iEnvironment = syncronousInterpreter.getEnvironment();
                        String percent = (String) iEnvironment.getTokenHash().lookUp("%");
                        iEnvironment.setGlobalVariable(-1, percent, response.getResultList(), true);


                    } catch (Exception e) {
                        e.printStackTrace();
                    }
                } else {
                    resultHolder = new ResultHolder(response.getResult(), response.getResult(), fontSize + resultHolderAdjustment);
                }

            }//end if

        }//end if.


        //final int caretPosition = responseInsertionOffset;

        int offsetIndex = responseInsertionOffset;

        final int initialOffset = offsetIndex;

        String extraNewline = "";
        if (!encounteredIn) {

            if (noLinesBetweenInAndEndOfTextArea == true) {
                extraNewline = "\n";// + result + "\n\nIn> ";
                offsetIndex++;
            }

        }//end if.*/

        final int responseOffset = offsetIndex;
        String result;
        if (this.suppressOutput == false) {
            result = "Result: ";// + response.getResult().trim();
            if (isCodeResult) {
                result = result + response.getResult().trim();
            }
        } else {
            result = "Result: " + "OUTPUT SUPPRESSED";
        }


        String sideEffects = null;
        int sideEffectsOffset = 0;
        int sideEffectsLength = 0;
        if (!response.getSideEffects().equalsIgnoreCase("")) {
            sideEffectsOffset = responseOffset + result.length();
            sideEffects = "\nSide Effects:\n" + response.getSideEffects();
            sideEffectsLength = sideEffects.length();
        }


        String exception = null;
        int exceptionOffset = 0;
        int exceptionLength = 0;
        if (response.isExceptionThrown()) {
            exceptionOffset = responseOffset + result.length() + sideEffectsOffset;
            exception = "\nException: " + response.getExceptionMessage();
            exceptionLength = exception.length();
        }





        final String finalExtraNewline = extraNewline;
        final String finalResult = result;
        final String finalSideEffects = sideEffects;
        final String finalException = exception;

        final int finalSideEffectsOffset = sideEffectsOffset;
        final int finalExceptionOffset = exceptionOffset;
        final int insertInOffset = responseOffset + result.length() + sideEffectsLength + exceptionLength;
        final int finalCaretPositionWhenEnterWasPressed = caretPositionWhenEnterWasPressed;
        final ResultHolder resultHolderFinal = resultHolder;
        final EvaluationResponse responseFinal = response;
        final boolean isCodeResultFinal = isCodeResult;
        final boolean suppressOutputFinal = suppressOutput;

        this.suppressOutput = false;

        /* if (insertionPointLine == lineCount - 1) {
        SwingUtilities.invokeLater(new Runnable() {

        public void run() {
        haltButton.setEnabled(false);
        textArea.append(Color.BLACK, finalOutput);
        }


        });

        //textArea.setCaretPosition( textArea.getDocument().getLength() );
        } else {*/
        SwingUtilities.invokeLater(new Runnable() {

            public void run() {
                haltButton.setEnabled(false);


                textPane.insert(Color.BLACK, finalExtraNewline, initialOffset); //finalExtraNewline

                textPane.insert(Color.BLUE, finalResult, responseOffset);

                if (finalSideEffects != null) {
                    textPane.insert(green, finalSideEffects, finalSideEffectsOffset);
                }

                if (finalException != null) {
                    textPane.insert(Color.RED, finalException, finalExceptionOffset);
                }


                if (!encounteredIn) {

                    textPane.insert(Color.BLACK, "\n\nIn> ", insertInOffset);

                } else {
                    //textPane.setCaretPosition(caretPosition - 1);
                    textPane.setCaretPosition(finalCaretPositionWhenEnterWasPressed);

                }


                if (!suppressOutputFinal && !isCodeResultFinal) {

                    try {

                        StyledDocument doc = (StyledDocument) textPane.getDocument();

                        Style style = doc.addStyle("RenderingComponent", null);



                        Object responseObject = responseFinal.getObject();

                        if (false) {//responseObject instanceof JPanel) {
                            //Histogram({3,4,3,2,2,3,3,4,5,5,6,5,4,3,2,1,2,3,3,4,5,4,5,6})
                            JPanel responseObjectJPanel = (JPanel) responseObject;
                            Resizable resizer = new Resizable(responseObjectJPanel);

                            //resizer.setBounds(50, 50, 200, 150);
                            StyleConstants.setComponent(style, resizer);
                            doc.insertString(responseOffset + 8, responseObject.getClass().toString(), style);
                        } else {
                            StyleConstants.setComponent(style, resultHolderFinal);
                            doc.insertString(responseOffset + 8, resultHolderFinal.getCodeResult(), style);
                        }





                    } catch (BadLocationException e) {
                        e.printStackTrace();
                    }

                }//end if.


            }//end method.

        });

        //}//end if/else.

    }//end method.


    public boolean remove() {
        return true;
    }


    private void clearPreviousResponse() {

        try {
            int lineNumber = textPane.getLineOfOffset(responseInsertionOffset - 1);

            if (responseInsertionOffset == -1 || lineNumber == textPane.getLineCount()) {
                encounteredIn = false;
                return;
            }

            String line = "";
            int lineStartOffset = 0;
            int lineEndOffset = 0;

            do {

                lineNumber++;
                lineStartOffset = textPane.getLineStartOffset(lineNumber);
                lineEndOffset = textPane.getLineEndOffset(lineNumber);
                line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);

            } while (!line.startsWith("In>") && lineNumber < textPane.getLineCount());

            textPane.replaceRange("\n\n\n", responseInsertionOffset - 1, lineStartOffset);
            encounteredIn = line.startsWith("In>");
            return;

        } catch (BadLocationException ex) {
            encounteredIn = false;
            textPane.replaceRange("\n\n\n", responseInsertionOffset, textPane.getDocument().getLength());
            return;
        }
    }//end method.


    private void captureInputLines(int lineNumber) {

        inputLines.delete(0, inputLines.length());

        try {
            int lineStartOffset = textPane.getLineStartOffset(lineNumber);
            int lineEndOffset = textPane.getLineEndOffset(lineNumber);
            String line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);

            if (line.startsWith("In>")) {

                //Scan backwards to first line that does not start with In>.
                do {
                    lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    lineEndOffset = textPane.getLineEndOffset(lineNumber);
                    line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset);
                    lineNumber--;

                } while (line.startsWith("In>") && lineNumber != -1);//end do/while.

                if (lineNumber != -1) {
                    lineNumber++;
                }


                //Scan forwards to first line that does not start with In>.
                boolean pastInputLines = false;
                noLinesBetweenInAndEndOfTextArea = false;
                do {
                    lineNumber++;
                    lineStartOffset = textPane.getLineStartOffset(lineNumber);
                    lineEndOffset = textPane.getLineEndOffset(lineNumber);
                    line = textPane.getText(lineStartOffset, lineEndOffset - lineStartOffset).trim();
                    if (line.startsWith("In>")) {
                        String eol = new String(line);
                        inputLines.append(line.substring(3, line.length()).trim());
                        responseInsertionOffset = lineEndOffset;
                        if (!eol.endsWith(";") && !eol.endsWith("\\\n")) {
                            inputLines.append(";");
                        }//end if.
                    } else {
                        pastInputLines = true;
                    }


                } while (!pastInputLines && lineNumber < textPane.getLineCount());//end while.

            }//end if.*/

        } catch (BadLocationException ex) {
            noLinesBetweenInAndEndOfTextArea = true;
        }


    }//end method.


    public void setHaltButtonEnabledState(boolean state) {
        this.haltButton.setEnabled(state);

    }//end method.

    class ColorPane extends JTextPane {

        public ColorPane() {
            super();
            //this.getDocument().putProperty("i18n", Boolean.FALSE);
            //this.getDocument().putProperty("ZOOM_FACTOR", new Double(zoomScale));
            this.setDocument(new MathPiperDocument());

        }


        public void append(Color c, String s) { // better implementation--uses // StyleContext.
            MutableAttributeSet attrs = getInputAttributes();
            //attrs.removeAttribute("size");
            //SimpleAttributeSet attrs = new SimpleAttributeSet();
            //StyleConstants.setFontSize(attrs, fontSize);


            //StyleConstants.setFontSize(attrs, fontSize);


            StyleConstants.setForeground(attrs, c);

            int len = getDocument().getLength(); // same value as // getText().length();
            setCaretPosition(len); // place caret at the end (with no selection).
            setCharacterAttributes(attrs, false);


            /*try {
            this.getDocument().insertString(this.getCaretPosition(), s, attrs);
            } catch (BadLocationException e) {
            }*/

            replaceSelection(s); // there is no selection, so inserts at caret.
        }//end method.


        public void insert(Color c, String str, int pos) {



            MutableAttributeSet attrs = getInputAttributes();
            //attrs.removeAttribute(StyleConstants.FontSize);
            //SimpleAttributeSet attrs = new SimpleAttributeSet();

            //StyleConstants.setFontSize(attrs, fontSize);


            //StyleConstants.setFontFamily(attrs, font.getFamily());
            //StyleConstants.setFontSize(attrs, fontSize);
            StyleConstants.setForeground(attrs, c);

            //StyleContext sc = StyleContext.getDefaultStyleContext();
            //MutableAttributeSet aset = this.getInputAttributes();
            //AttributeSet aset = sc.addAttribute(SimpleAttributeSet.EMPTY, StyleConstants.Foreground, c);
            setCaretPosition(pos); // place caret at the end (with no selection)
            setCharacterAttributes(attrs, false);

            /*try {
            this.getDocument().insertString(this.getCaretPosition(), str, attrs);
            } catch (BadLocationException e) {
            }*/



            replaceSelection(str); // there is no selection, so inserts at caret.

        }


        /**
         * Translates an offset into the components text to a
         * line number.
         *
         * @param offset the offset >= 0
         * @return the line number >= 0
         * @exception BadLocationException thrown if the offset is
         *   less than zero or greater than the document length.
         */
        public int getLineOfOffset(int offset) throws BadLocationException {
            Document doc = getDocument();
            if (offset < 0) {
                throw new BadLocationException("Can't translate offset to line", -1);
            } else if (offset > doc.getLength()) {
                throw new BadLocationException("Can't translate offset to line", doc.getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                return map.getElementIndex(offset);
            }
        }


        /**
         * Determines the number of lines contained in the area.
         *
         * @return the number of lines > 0
         */
        public int getLineCount() {
            Element map = getDocument().getDefaultRootElement();
            return map.getElementCount();
        }


        /**
         * Determines the offset of the start of the given line.
         *
         * @param line  the line number to translate >= 0
         * @return the offset >= 0
         * @exception BadLocationException thrown if the line is
         * less than zero or greater or equal to the number of
         * lines contained in the document (as reported by
         * getLineCount).
         */
        public int getLineStartOffset(int line) throws BadLocationException {
            int lineCount = getLineCount();
            if (line < 0) {
                throw new BadLocationException("Negative line", -1);
            } else if (line >= lineCount) {
                throw new BadLocationException("No such line", getDocument().getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                Element lineElem = map.getElement(line);
                return lineElem.getStartOffset();
            }
        }


        /**
         * Determines the offset of the end of the given line.
         *
         * @param line  the line >= 0
         * @return the offset >= 0
         * @exception BadLocationException Thrown if the line is
         * less than zero or greater or equal to the number of
         * lines contained in the document (as reported by
         * getLineCount).
         */
        public int getLineEndOffset(int line) throws BadLocationException {
            int lineCount = getLineCount();
            if (line < 0) {
                throw new BadLocationException("Negative line", -1);
            } else if (line >= lineCount) {
                throw new BadLocationException("No such line", getDocument().getLength() + 1);
            } else {
                Element map = getDocument().getDefaultRootElement();
                Element lineElem = map.getElement(line);
                int endOffset = lineElem.getEndOffset();
                // hide the implicit break at the end of the document
                return ((line == lineCount - 1) ? (endOffset - 1) : endOffset);
            }
        }


        /**
         * Replaces text from the indicated start to end position with the
         * new text specified.  Does nothing if the model is null.  Simply
         * does a delete if the new string is null or empty.
         * 
    
         * This method is thread safe, although most Swing methods
         * are not.
         *
         * @param str the text to use as the replacement
         * @param start the start position >= 0
         * @param end the end position >= start
         * @exception IllegalArgumentException  if part of the range is an
         *  invalid position in the model
         * @see #insert
         * @see #replaceRange
         */
        public void replaceRange(String str, int start, int end) {
            if (end < start) {
                throw new IllegalArgumentException("end before start");
            }


            Font font = getFont();

            MutableAttributeSet attrs = getInputAttributes();


            StyleConstants.setFontFamily(attrs, font.getFamily());
            StyleConstants.setFontSize(attrs, fontSize);


            setCharacterAttributes(attrs, false);
            this.select(start, end);
            replaceSelection(str);

        }//end method.

    }//end class


    public void setJTextPaneFont(JTextPane textPane, int fontSize) {

        StyledDocument document = textPane.getStyledDocument();
        SimpleAttributeSet attrs = new SimpleAttributeSet();
        StyleConstants.setFontSize(attrs, fontSize);
        document.setCharacterAttributes(0, document.getLength() + 1, attrs, false);
        document.setParagraphAttributes(0, document.getLength() + 1, attrs, true);

        MutableAttributeSet attrs2 = textPane.getInputAttributes();
        StyleConstants.setFontSize(attrs2, fontSize);

    }//end method.

    public static class PopupTriggerMouseListener extends MouseAdapter {

        private JPopupMenu popup;
        private JComponent component;


        public PopupTriggerMouseListener(JPopupMenu popup, JComponent component) {
            this.popup = popup;
            this.component = component;
        }

        //some systems trigger popup on mouse press, others on mouse release, we want to cater for both

        private void showMenuIfPopupTrigger(MouseEvent e) {
            if (e.isPopupTrigger()) {
                popup.show(component, e.getX() + 3, e.getY() + 3);
            }
        }

        //according to the javadocs on isPopupTrigger, checking for popup trigger on mousePressed and mouseReleased
        //should be all  that is required
        //public void mouseClicked(MouseEvent e)

        public void mousePressed(MouseEvent e) {
            showMenuIfPopupTrigger(e);
        }


        public void mouseReleased(MouseEvent e) {
            showMenuIfPopupTrigger(e);
        }

    }//end method.


    public JMenuBar getMenuBar() {
        return menuBar;
    }


    private void addPopupMenu() {
        final JPopupMenu menu = new JPopupMenu();

        final JMenuItem copyItem = new JMenuItem();
        copyItem.setAction(textPane.getActionMap().get(DefaultEditorKit.copyAction));
        copyItem.setText("Copy");
        menu.add(copyItem);

        final JMenuItem cutItem = new JMenuItem();
        cutItem.setAction(textPane.getActionMap().get(DefaultEditorKit.cutAction));
        cutItem.setText("Cut");
        menu.add(cutItem);

        final JMenuItem pasteItem = new JMenuItem("Paste");
        pasteItem.setAction(textPane.getActionMap().get(DefaultEditorKit.pasteAction));
        pasteItem.setText("Paste");
        menu.add(pasteItem);

        menu.add(new JSeparator());

        final JMenuItem selectAllItem = new JMenuItem("Select All");
        selectAllItem.setAction(textPane.getActionMap().get(DefaultEditorKit.selectAllAction));
        selectAllItem.setText("Select All");
        menu.add(selectAllItem);

        menu.add(new JSeparator());

        final JMenuItem insertPrompt = new JMenuItem("Insert In>");
        insertPrompt.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {
                textPane.insert(Color.BLACK, "In> ", textPane.getCaretPosition());
            }

        });
        insertPrompt.setText("Insert In>");
        menu.add(insertPrompt);

        final JMenuItem insertLatex = new JMenuItem("Insert LaTeX");
        insertLatex.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {
                textPane.insertComponent(new LatexComponent(GraphicConsole.this.fontSize + GraphicConsole.this.resultHolderAdjustment, GraphicConsole.this));
            }

        });
        insertLatex.setText("Insert LaTeX");
        //menu.add(insertLatex);



        final JMenuItem insertMathPiperCode = new JMenuItem("Insert MathPiper Code Renderer");
        insertMathPiperCode.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {

                LatexComponent codeComponent = new LatexComponent(GraphicConsole.this.fontSize + GraphicConsole.this.resultHolderAdjustment, GraphicConsole.this);

                codeComponent.setLatexMode(false);

                textPane.insertComponent(codeComponent);

                codeComponent.giveFocus();

            }

        });
        insertMathPiperCode.setText("Insert MathPiper Code Renderer");
        menu.add(insertMathPiperCode);




        textPane.add(menu);
        textPane.addMouseListener(new PopupTriggerMouseListener(menu, textPane));
    }//end method.


    public void giveFocus() {
        textPane.requestFocusInWindow();
    }


    public void focusGained(FocusEvent e) {
    }


    public void focusLost(FocusEvent e) {
        if (e.getSource() instanceof RenderingComponent) {
            giveFocus();
        }
    }


    public static void main(String[] args) {
        final GraphicConsole console = new GraphicConsole();

        JFrame frame = new javax.swing.JFrame();
        Container contentPane = frame.getContentPane();
        contentPane.add(console, BorderLayout.CENTER);
        //frame.setAlwaysOnTop(true);
        frame.setSize(new Dimension(800, 600));
        frame.setDefaultCloseOperation(frame.DISPOSE_ON_CLOSE);
        frame.setTitle("Graphic Console");
        //frame.setResizable(false);

        //frame.setJMenuBar(console.getMenuBar());


        //Make textField get the focus whenever frame is activated.
        frame.addWindowFocusListener(new WindowAdapter() {

            public void windowGainedFocus(WindowEvent e) {
                console.giveFocus();
            }

        });

        frame.setPreferredSize(new Dimension(800, 600));
        frame.setLocationRelativeTo(null); // added
        frame.pack();
        frame.setVisible(true);
    }//end main.

    class MenuBar extends JMenuBar {

        public MenuBar() {

            //setLayout(new BoxLayout(this, BoxLayout.X_AXIS));

            FlowLayout layout = new FlowLayout();

            layout.setAlignment(FlowLayout.LEFT);

            layout.setVgap(0);

            this.setLayout(layout);



            JMenu fileMenu = new JMenu("File");
            JMenu editMenu = new JMenu("Edit");
            add(fileMenu);
            add(editMenu);


            JMenuItem newAction = new JMenuItem("New");
            newAction.setText("New");
            newAction.addActionListener(new ActionListener() {

                public void actionPerformed(ActionEvent ae) {
                }

            });


            JMenuItem openAction = new JMenuItem();
            openAction.setText("Open");
            openAction.addActionListener(new FileOperationListener());
            fileMenu.add(openAction);

            JMenuItem saveAction = new JMenuItem();
            saveAction.setText("Save");
            saveAction.addActionListener(new FileOperationListener());
            fileMenu.add(saveAction);

            //JMenuItem exitAction = new JMenuItem("Exit");
            //fileMenu.add(exitAction);

            JMenuItem copyAction = new JMenuItem();
            copyAction.setAction(textPane.getActionMap().get(DefaultEditorKit.copyAction));
            copyAction.setText("Copy");
            editMenu.add(copyAction);

            JMenuItem cutAction = new JMenuItem();
            cutAction.setAction(textPane.getActionMap().get(DefaultEditorKit.cutAction));
            cutAction.setText("Cut");
            editMenu.add(cutAction);

            JMenuItem pasteAction = new JMenuItem();
            pasteAction.setAction(textPane.getActionMap().get(DefaultEditorKit.pasteAction));
            pasteAction.setText("Paste");
            editMenu.add(pasteAction);



            /*
            JCheckBoxMenuItem checkAction = new JCheckBoxMenuItem("Check Action");

            JRadioButtonMenuItem radioAction1 = new JRadioButtonMenuItem(
            "Radio Button1");
            JRadioButtonMenuItem radioAction2 = new JRadioButtonMenuItem(
            "Radio Button2");

            ButtonGroup bg = new ButtonGroup();
            bg.add(radioAction1);
            bg.add(radioAction2);
            fileMenu.add(newAction);
            fileMenu.add(checkAction);
            fileMenu.addSeparator();
            editMenu.addSeparator();
            editMenu.add(radioAction1);
            editMenu.add(radioAction2);
             */



        }//end constructor.


    }//end class.

    class FileOperationListener implements ActionListener {

        public void actionPerformed(ActionEvent e) {
            String command = e.getActionCommand();
            int retVal;
            boolean exists;

            //set the current directory to the application's current directory
            try {
                //create a file object containing the cannonical path of the desired file
                File f = new File(new File("untitled.txt").getCanonicalPath());
                //set the selected file
                fileChooser.setSelectedFile(f);
            } catch (IOException ex3) {
                ex3.printStackTrace();
            }



            if (command.equals("Save")) {
                //show the dialog; wait until dialog is closed
                retVal = fileChooser.showSaveDialog(null);
                //Approve(Save was clicked)
                if (retVal == JFileChooser.APPROVE_OPTION) {
                    //get the currently selected file
                    File thefile = fileChooser.getSelectedFile();
                    String nameOfFile = "";
                    nameOfFile = thefile.getPath();
                    //check if the file exists
                    exists = (new File(nameOfFile)).exists();
                    if (!exists) {
                        System.out.println("Does not exist");
                        //If the file does not already exist, it is automatically created.
                        try {
                            BufferedWriter out = new BufferedWriter(new FileWriter(nameOfFile));
                            out.write(textPane.getText());
                            out.close();
                        } catch (IOException ex1) {
                            ex1.printStackTrace();
                        }
                    } else {
                        //System.out.println(" Exists");
                        //Save over a file.
                        try {
                            BufferedWriter out = new BufferedWriter(new FileWriter(nameOfFile, false));
                            out.write(textPane.getText());
                            out.close();
                        } catch (IOException ex2) {
                        }
                    }//end else.
                    /*
                    if (thefile != null) {
                        if (thefile.isDirectory()) {
                            JOptionPane.showMessageDialog(null, "You chose this directory: " + thefile.getPath());
                        } else {
                            JOptionPane.showMessageDialog(null, "You chose this file: " + thefile.getPath());

                            //to append to the existing file
                            //out = new FileOutputStream(theFile, true);
                        }
                    }*/
                } else if (retVal == JFileChooser.CANCEL_OPTION) {
                    //Cancel or the close dialog icon was clicked
                    JOptionPane.showMessageDialog(null, "User cancelled operation. No file was chosen.");
                } else if (retVal == JFileChooser.ERROR_OPTION) {
                    //The selected process did not complete successfully
                    JOptionPane.showMessageDialog(null, "An error occured. No file was chosen.");
                } else {
                    JOptionPane.showMessageDialog(null, "Unknown operation occured.");
                }
            } else if (command.equals("Open")) {
                retVal = fileChooser.showOpenDialog(null);
                //Approve(Save was clicked)
                if (retVal == JFileChooser.APPROVE_OPTION) {

                    String filePath = fileChooser.getSelectedFile().getPath();
                    try {
                        FileInputStream fr = new FileInputStream(filePath);
                        InputStreamReader isr = new InputStreamReader(fr, "UTF-8");
                        BufferedReader reader = new BufferedReader(isr);
                        StringBuffer buffer = new StringBuffer();

                        String line = null;
                        while ((line = reader.readLine()) != null) {
                            buffer.append(line + "\n");
                        }

                        reader.close();

                        textPane.setText(buffer.toString());
                    } catch (FileNotFoundException ex) {
                        JOptionPane.showMessageDialog(null, "The file was not found.");
                    }catch (IOException ex) {
                        ex.printStackTrace();
                    }

                }

            }//end else if.



        }//end of ActionPerformed method

    }//end of action listener

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/Resizable.java0000644000175000017500000001013311423200443027311 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.BorderLayout;
import java.awt.Component;
import java.awt.Cursor;
import java.awt.Dimension;
import java.awt.Point;
import java.awt.Rectangle;
import java.awt.event.MouseEvent;

import javax.swing.JComponent;
import javax.swing.event.MouseInputAdapter;
import javax.swing.event.MouseInputListener;

// Resizable.java

public class Resizable extends JComponent {

  public Resizable(Component comp) {
    this(comp, new ResizableBorder(8));
  }

  public Resizable(Component comp, ResizableBorder border) {
    setLayout(new BorderLayout());
    //this.setLayout(new BoxLayout(this, BoxLayout.X_AXIS));
    add(comp);
    addMouseListener(resizeListener);
    addMouseMotionListener(resizeListener);
    setBorder(border);
  }

  private void resize() {
      if (getParent() != null && getParent() instanceof JComponent) {
        ((JComponent)getParent()).revalidate();
      }
  }

  MouseInputListener resizeListener = new MouseInputAdapter() {
    public void mouseMoved(MouseEvent me) {
      if (hasFocus()) {
          ResizableBorder border = (ResizableBorder)getBorder();
          setCursor(Cursor.getPredefinedCursor(border.getCursor(me)));
      }
    }

    public void mouseExited(MouseEvent mouseEvent) {
       setCursor(Cursor.getDefaultCursor());
    }

    private int cursor;
    private Point startPos = null;

    public void mousePressed(MouseEvent me) {
      ResizableBorder border = (ResizableBorder)getBorder();
      cursor = border.getCursor(me);
      startPos = me.getPoint();
      requestFocus();
      repaint();
    }

    public void mouseDragged(MouseEvent me) {

      if (startPos != null) {

        int x = getX();
        int y = getY();
        int w = getWidth();
        int h = getHeight();

        int dx = me.getX() - startPos.x;
        int dy = me.getY() - startPos.y;

        switch (cursor) {
          case Cursor.N_RESIZE_CURSOR:
            if (!(h - dy < 50)) {
              setBounds(x, y + dy, w, h - dy);
              resize();
            }
            break;

          case Cursor.S_RESIZE_CURSOR:
            if (!(h + dy < 50)) {
              setBounds(x, y, w, h + dy);
              startPos = me.getPoint();
              resize();
            }
            break;

          case Cursor.W_RESIZE_CURSOR:
            if (!(w - dx < 50)) {
              setBounds(x + dx, y, w - dx, h);
              resize();
            }
            break;

          case Cursor.E_RESIZE_CURSOR:
            if (!(w + dx < 50)) {
              setBounds(x, y, w + dx, h);
              startPos = me.getPoint();
              resize();
            }
            break;

          case Cursor.NW_RESIZE_CURSOR:
            if (!(w - dx < 50) && !(h - dy < 50)) {
              setBounds(x + dx, y + dy, w - dx, h - dy);
              resize();
            }
            break;

          case Cursor.NE_RESIZE_CURSOR:
            if (!(w + dx < 50) && !(h - dy < 50)) {
              setBounds(x, y + dy, w + dx, h - dy);
              startPos = new Point(me.getX(), startPos.y);
              resize();
            }
            break;

          case Cursor.SW_RESIZE_CURSOR:
            if (!(w - dx < 50) && !(h + dy < 50)) {
              setBounds(x + dx, y, w - dx, h + dy);
              startPos = new Point(startPos.x, me.getY());
              resize();
            }
            break;

          case Cursor.SE_RESIZE_CURSOR:
            if (!(w + dx < 50) && !(h + dy < 50)) {
              setBounds(x, y, w + dx, h + dy);
              startPos = me.getPoint();
              resize();
            }
          break;

          case Cursor.MOVE_CURSOR:
            Rectangle bounds = getBounds();
            bounds.translate(dx, dy);
            setBounds(bounds);
            resize();
          }


          setCursor(Cursor.getPredefinedCursor(cursor));
        }
     }

   public void mouseReleased(MouseEvent mouseEvent) {
     startPos = null;
    }
  };

          public Dimension getMinimumSize() {
            return getPreferredSize();
        }


        public Dimension getMaximumSize() {
            return getPreferredSize();
        }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/GoAwayButton.java0000644000175000017500000000625011423120044027757 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.BasicStroke;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Color;

import java.awt.Cursor;
import java.awt.Graphics2D;
import java.awt.RenderingHints;
import javax.swing.*;
import javax.swing.plaf.UIResource;


public class GoAwayButton extends JButton implements SwingConstants
{

        private Color shadow;
        private Color darkShadow;
        private Color highlight;

        private BasicStroke redXStroke = new BasicStroke(2, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND);

        public GoAwayButton() {
	    super();

            this.setBackground(UIManager.getColor("control"));
            this.shadow = UIManager.getColor("controlShadow");
            this.darkShadow = UIManager.getColor("controlDkShadow");
            this.highlight = UIManager.getColor("controlLtHighlight");

            setCursor(Cursor.getPredefinedCursor(Cursor.DEFAULT_CURSOR));

            this.setToolTipText("Go back to the traditional math view of this expression.");
	}



	public void paint(Graphics g) {
            Graphics2D g2d = (Graphics2D) g;

            g2d.setRenderingHint(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON);

	    Color origColor;
	    boolean isPressed, isEnabled;
	    int w, h, size;

            w = getSize().width;
            h = getSize().height;
	    origColor = g2d.getColor();
	    isPressed = getModel().isPressed();
	    isEnabled = isEnabled();

            g2d.setColor(getBackground());
            g2d.fillRect(1, 1, w-2, h-2);

            /// Draw the border
	    if (getBorder() != null && !(getBorder() instanceof UIResource)) {
		paintBorder(g2d);
	    } else if (isPressed) {
                g2d.setColor(shadow);
                g2d.drawRect(0, 0, w-1, h-1);
            } else {
                //Use the background color set above
                g2d.drawLine(0, 0, 0, h-1);
                g2d.drawLine(1, 0, w-2, 0);

                g2d.setColor(highlight);    //Inner 3D border.
                g2d.drawLine(1, 1, 1, h-3);
                g2d.drawLine(2, 1, w-3, 1);

                g2d.setColor(shadow);       //Inner 3D border.
                g2d.drawLine(1, h-2, w-2, h-2);
                g2d.drawLine(w-2, 1, w-2, h-3);

                g2d.setColor(darkShadow);     //Backdrop shadow.
                g2d.drawLine(0, h-1, w-1, h-1);
                g2d.drawLine(w-1, h-1, w-1, 0);
            }


            if(h < 6 || w < 6)      {
                g2d.setColor(origColor);
                return;
            }

            if (isPressed) {
                g2d.translate(1, 1);
            }


            g2d.setColor(Color.RED);
            g2d.setStroke(redXStroke);

            g2d.drawLine(3, 4, 10, 11);
            g2d.drawLine(10, 4, 3, 11);






            if (isPressed) {
                g2d.translate(-1, -1);
	    }


	    g2d.setColor(origColor);

        }


        public Dimension getPreferredSize() {
            return new Dimension(16, 16);
        }


        public Dimension getMinimumSize() {
            return getPreferredSize();
        }


        public Dimension getMaximumSize() {
            return getPreferredSize();
        }


}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/SpinButton.java0000644000175000017500000000630211423120044027477 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.BasicStroke;
import java.awt.Dimension;
import java.awt.Graphics;
import java.awt.Color;

import java.awt.Cursor;
import java.awt.Graphics2D;
import java.awt.RenderingHints;
import javax.swing.*;
import javax.swing.plaf.UIResource;


public class SpinButton extends JButton implements SwingConstants
{

        private Color shadow;
        private Color darkShadow;
        private Color highlight;

        private BasicStroke thickStroke = new BasicStroke(2, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND);

        public SpinButton() {
	    super();

            this.setBackground(UIManager.getColor("control"));
            this.shadow = UIManager.getColor("controlShadow");
            this.darkShadow = UIManager.getColor("controlDkShadow");
            this.highlight = UIManager.getColor("controlLtHighlight");

            setCursor(Cursor.getPredefinedCursor(Cursor.DEFAULT_CURSOR));

            this.setToolTipText("Select a different text view of this expression.");
	}



	public void paint(Graphics g) {
            Graphics2D g2d = (Graphics2D) g;

            g2d.setRenderingHint(RenderingHints.KEY_ANTIALIASING, RenderingHints.VALUE_ANTIALIAS_ON);

	    Color origColor;
	    boolean isPressed, isEnabled;
	    int w, h, size;

            w = getSize().width;
            h = getSize().height;
	    origColor = g2d.getColor();
	    isPressed = getModel().isPressed();
	    isEnabled = isEnabled();

            g2d.setColor(getBackground());
            g2d.fillRect(1, 1, w-2, h-2);

            /// Draw the border
	    if (getBorder() != null && !(getBorder() instanceof UIResource)) {
		paintBorder(g2d);
	    } else if (isPressed) {
                g2d.setColor(shadow);
                g2d.drawRect(0, 0, w-1, h-1);
            } else {
                //Use the background color set above
                g2d.drawLine(0, 0, 0, h-1);
                g2d.drawLine(1, 0, w-2, 0);

                g2d.setColor(highlight);    //Inner 3D border.
                g2d.drawLine(1, 1, 1, h-3);
                g2d.drawLine(2, 1, w-3, 1);

                g2d.setColor(shadow);       //Inner 3D border.
                g2d.drawLine(1, h-2, w-2, h-2);
                g2d.drawLine(w-2, 1, w-2, h-3);

                g2d.setColor(darkShadow);     //Backdrop shadow.
                g2d.drawLine(0, h-1, w-1, h-1);
                g2d.drawLine(w-1, h-1, w-1, 0);
            }


            if(h < 6 || w < 6)      {
                g2d.setColor(origColor);
                return;
            }

            if (isPressed) {
                g2d.translate(1, 1);
            }


            g2d.setColor(Color.BLUE);
            g2d.setStroke(thickStroke);

            g2d.drawLine(7, 12, 7, 3);

            g2d.drawLine(7,3, 3, 6);
            g2d.drawLine(7,3, 11, 6);






            if (isPressed) {
                g2d.translate(-1, -1);
	    }


	    g2d.setColor(origColor);

        }


        public Dimension getPreferredSize() {
            return new Dimension(16, 16);
        }


        public Dimension getMinimumSize() {
            return getPreferredSize();
        }


        public Dimension getMaximumSize() {
            return getPreferredSize();
        }


}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/ResizableComponent.java0000644000175000017500000000207111423200443031176 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.Color;
import java.awt.Dimension;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;

import javax.swing.JFrame;
import javax.swing.JPanel;


/* ResizableComponent.java */

public class ResizableComponent extends JFrame {

  private JPanel panel = new JPanel(null);
  private Resizable resizer;


  public ResizableComponent() {

      add(panel);

      JPanel area = new JPanel();
      area.setBackground(Color.white);
      resizer = new Resizable(area);
      resizer.setBounds(50, 50, 200, 150);
      panel.add(resizer);


      setDefaultCloseOperation(JFrame.EXIT_ON_CLOSE);
      setSize(new Dimension(350, 300));
      setTitle("Resizable Component");
      setLocationRelativeTo(null);

      addMouseListener(new MouseAdapter() {
        public void mousePressed(MouseEvent me) {

          requestFocus();
          resizer.repaint();
        }
      });
  }

  public static void main(String[] args) {
      ResizableComponent rc = new ResizableComponent();
      rc.setVisible(true);
  }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/LatexComponent.java0000644000175000017500000002120311503734166030346 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.Color;
import java.awt.Cursor;
import java.awt.Dimension;
import java.awt.Font;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.FocusListener;
import java.awt.event.MouseAdapter;
import java.awt.event.MouseEvent;
import java.awt.event.MouseListener;
import javax.swing.BoxLayout;
import javax.swing.JLabel;
import javax.swing.JPanel;
import javax.swing.JTextField;

import javax.swing.event.DocumentEvent;
import javax.swing.event.DocumentListener;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.lisp.Utility;
import org.scilab.forge.jlatexmath.JMathTeXException;
import org.scilab.forge.jlatexmath.TeXConstants;
import org.scilab.forge.jlatexmath.TeXFormula;
import org.scilab.forge.jlatexmath.TeXIcon;

public class LatexComponent extends JPanel implements RenderingComponent, MouseListener {

    private TeXFormula texFormula;
    private JLabel renderedResult;
    private JTextField inputTextField;
    private String resultString;
    private String latexString;
    private int toggle = 0;
    private SpinButton spinButton;
    private GoAwayButton goAwayButton;
    private int fontPointSize;
    private boolean latexMode = false;
    private final GraphicConsole console;


    public LatexComponent(int fontPointSize, GraphicConsole console) {

        this.console = console;

        this.fontPointSize = fontPointSize;

        this.latexString = "\\square";



        this.renderedResult = new JLabel();

        try {
            texFormula = new TeXFormula(latexString);
            TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, fontPointSize);
            renderedResult.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
            renderedResult.setAlignmentY(icon.getBaseLine());
            renderedResult.setIcon(icon);
        } catch (JMathTeXException e) {
            renderedResult.setText(resultString);
            renderedResult.setAlignmentY(.9f);
        }




        renderedResult.setCursor(Cursor.getPredefinedCursor(Cursor.DEFAULT_CURSOR));
        renderedResult.setToolTipText("Click to see text versions of this expression.");
        renderedResult.addMouseListener(new MouseAdapter() {

            public void mouseClicked(MouseEvent e) {
                //eventOutput("Mouse clicked (# of clicks: "  + e.getClickCount() + ")", e);
                toggle = 0;
                toggleView();
            }

        }//end method.
                );


        inputTextField = new JTextField(10);
        inputTextField.setAlignmentY(.7f);
        inputTextField.setEditable(true);
        inputTextField.setBackground(Color.white);
        Font newFontSize = new Font(inputTextField.getFont().getName(), inputTextField.getFont().getStyle(), fontPointSize);
        inputTextField.setFont(newFontSize);
        inputTextField.setMaximumSize(inputTextField.getPreferredSize());
        inputTextField.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                //The enter key was pressed in the inputTextField.
                removeAll();
                add(renderedResult);
                LatexComponent.this.console.giveFocus();
            }//end method.

        });

        inputTextField.getDocument().addDocumentListener(new DocumentListener() {

            public void changedUpdate(DocumentEvent e) {
            }


            public void insertUpdate(DocumentEvent e) {
                editCode();
            }


            public void removeUpdate(DocumentEvent e) {
                editCode();
            }

        });


        inputTextField.repaint();


        this.setBackground(Color.white);

        this.setOpaque(true);

        this.setLayout(new BoxLayout(this, BoxLayout.X_AXIS));

        //this.add(latexResult);


        spinButton = new SpinButton();
        spinButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                LatexComponent.this.toggleView();
            }//end method.

        });
        spinButton.setEnabled(true);
        spinButton.setAlignmentY(.9f);


        goAwayButton = new GoAwayButton();
        goAwayButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                //LatexComponent.this.goAway();
                //System.out.println(inputTextField.getText());
            }//end method.

        });
        goAwayButton.setEnabled(true);
        goAwayButton.setAlignmentY(.9f);

        this.addMouseListener(this);


        this.add(renderedResult);
        this.add(inputTextField);


        this.setFocusable(true);


    }//end constructor.


    public void giveFocus()
    {
        inputTextField.requestFocusInWindow();
    }


    public void setScale(int scaleValue) {

        this.fontPointSize = scaleValue;

        TeXIcon icon = texFormula.createTeXIcon(TeXConstants.STYLE_DISPLAY, fontPointSize);
        renderedResult.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
        renderedResult.setAlignmentY(icon.getBaseLine());
        renderedResult.setIcon(icon);
        renderedResult.repaint();



        Font newFontSize = new Font(inputTextField.getFont().getName(), inputTextField.getFont().getStyle(), fontPointSize);
        inputTextField.setFont(newFontSize);
        inputTextField.setMaximumSize(inputTextField.getPreferredSize());
        inputTextField.repaint();

    }//end method.


    void eventOutput(String eventDescription, MouseEvent e) {
        //System.out.println(eventDescription + " detected on " + e.getComponent().getClass().getName() + ".");

    }


    public void mousePressed(MouseEvent e) {
        //eventOutput("Mouse pressed (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseReleased(MouseEvent e) {
        //eventOutput("Mouse released (# of clicks: " + e.getClickCount() + ")", e);
    }


    public void mouseEntered(MouseEvent e) {
        //eventOutput("Mouse entered", e);
    }


    public void mouseExited(MouseEvent e) {
        //eventOutput("Mouse exited", e);
    }


    public void mouseClicked(MouseEvent e) {
        //eventOutput("Mouse clicked (# of clicks: "  + e.getClickCount() + ")", e);
        toggle = 0;
        toggleView();

    }//end method.


    public void toggleView() {
        this.removeAll();

        this.add(renderedResult);
        this.add(inputTextField);

        this.revalidate();
        this.repaint();
    }


    private void goAway() {
        this.removeAll();
        this.add(renderedResult);
    }


    public String getCodeResult() {
        return resultString;
    }


    public boolean isLatexMode() {
        return latexMode;
    }


    public void setLatexMode(boolean latexMode) {
        this.latexMode = latexMode;
    }


    


    public void editCode() {

        if (this.latexMode) {

            latexString = inputTextField.getText();
        } else {
            Interpreter mathPiperInterpreter = Interpreters.getSynchronousInterpreter();

            String mathPiperCode = inputTextField.getText();
            EvaluationResponse response = mathPiperInterpreter.evaluate("TeXForm(" + mathPiperCode + ");");

            if (response.isExceptionThrown()) {
                return;
            }

            latexString = response.getResult();

            if(latexString.equals("TeXForm()"))
            {
                latexString = "\\square";
            }
            
            try{

            latexString = Utility.stripEndQuotesIfPresent(null, -1, latexString);

            latexString = Utility.stripEndDollarSigns(latexString);
            }
            catch(Exception e)
            {

            }
        }

        //System.out.println(latexString);

        TeXFormula texFormula2 = null;
        try {
            texFormula2 = new TeXFormula(latexString);
            TeXIcon icon = texFormula2.createTeXIcon(TeXConstants.STYLE_DISPLAY, this.fontPointSize);
            renderedResult.setPreferredSize(new Dimension(icon.getIconWidth(), icon.getIconHeight()));
            renderedResult.setAlignmentY(icon.getBaseLine());
            renderedResult.setIcon(icon);
            renderedResult.repaint();
            
            
            texFormula = texFormula2;
        } catch (Exception ex) {
        }

    }



    public String toString()
    {
        if(latexMode)
        {
            return this.latexString;
        }
        else
        {
            return this.inputTextField.getText();
        }
    }

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/MathPiperDocument.java0000644000175000017500000000743211427462202031000 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.util.Stack;
import javax.swing.JTextPane;
import javax.swing.event.DocumentEvent;
import javax.swing.text.AbstractDocument.DefaultDocumentEvent;
import javax.swing.text.AbstractDocument.ElementEdit;
import javax.swing.text.ComponentView;
import javax.swing.text.DefaultStyledDocument;
import javax.swing.text.Element;
import javax.swing.text.View;

//Code from http://java-sl.com/tip_refresh_view.html. Stanislav Lapitsky
public class MathPiperDocument extends DefaultStyledDocument {

    public void refresh() {
        refresh(0, getLength());
    }


    public void refresh(int offset, int len) {
        DefaultDocumentEvent changes = new DefaultDocumentEvent(offset, len,
                DocumentEvent.EventType.CHANGE);
        Element root = getDefaultRootElement();
        Element[] removed = new Element[0];
        Element[] added = new Element[0];
        changes.addEdit(new ElementEdit(root, 0, removed, added));
        changes.end();
        fireChangedUpdate(changes);
    }


    public void scanTree(int fontSize) {
        Element root = this.getDefaultRootElement();
        Stack nodes = new Stack();
        nodes.push(root);
        Element currentNode;
        while (!nodes.isEmpty()) {
            currentNode = nodes.pop();

            int numberOfChildren = currentNode.getElementCount();

            for (int i = 0; i < numberOfChildren; i++) {
                Element child = currentNode.getElement(i);
                nodes.push(child);
            }

            //System.out.print(currentNode.getName() + "   " + currentNode.isLeaf() + "    " + currentNode.toString() );

            /*Enumeration attributeNames = currentNode.getAttributes().getAttributeNames();
            while(attributeNames.hasMoreElements())
            {
            System.out.println("   " + attributeNames.nextElement().toString());
            }*/




            /*if (currentNode.isLeaf()) {
            SimpleAttributeSet attrs = new SimpleAttributeSet(currentNode.getAttributes());
            StyleConstants.setFontSize(attrs, fontSize);
            this.setCharacterAttributes(currentNode.getStartOffset(), 1, attrs, true);
            }*/

            if (currentNode instanceof ComponentView) {
                ComponentView componentView = (ComponentView) currentNode;
                //System.out.println(componentView.getParent());
                /*
                ResultHolder resultHolder = (ResultHolder) componentView.getComponent();
                resultHolder.setScale(fontSize);
                */

            }

        }//end while.




    }//end method.


    public void scanViews(JTextPane textPane, int fontSize) {

        View root = textPane.getUI().getRootView(textPane);
        Stack nodes = new Stack();
        nodes.push(root);
        View currentNode;
        while (!nodes.isEmpty()) {
            currentNode = nodes.pop();

            for (int i = 0; i < currentNode.getViewCount(); i++) {
                View child = currentNode.getView(i);

                nodes.push(child);

            }//end for.

            if (currentNode instanceof ComponentView) {
                ComponentView componentView = (ComponentView) currentNode;

                //System.out.println(componentView.getParent());

                Object object = componentView.getComponent();

                if(object instanceof RenderingComponent )
                {
                    RenderingComponent renderingComponent = (RenderingComponent) object;
                    renderingComponent.setScale(fontSize);
                }
            }

            /*if (currentNode instanceof ParagraphView) {
                ParagraphView paragraphView = (ParagraphView) currentNode;

            }*/

        }//end while.

    }//end method.

}//end class.


    
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/EditorPaneStructure.java0000644000175000017500000002515611422075334031367 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import javax.swing.*;
import javax.swing.event.TreeSelectionListener;
import javax.swing.event.TreeSelectionEvent;
import javax.swing.tree.*;
import javax.swing.text.*;
import java.awt.*;
import java.awt.event.*;
import java.lang.reflect.Field;
import java.util.Enumeration;

public class EditorPaneStructure extends JPanel {

    JEditorPane sourcePane;
    JLabel lblViewBounds = new JLabel() {

        public void paint(Graphics g) {
            super.paint(g);
            g.setColor(new Color(200, 200, 255, 128));
            g.fillRect(0, 0, getWidth(), getHeight());
        }

    };
    JTree trDocument = new JTree() {

        public String getToolTipText(MouseEvent event) {
            return processDocumentTooltip(event);
        }

    };
    JTree trView = new JTree() {

        public String getToolTipText(MouseEvent event) {
            return processViewTooltip(event);
        }

    };
    JButton btnRefresh = new JButton("Refresh");


    public EditorPaneStructure(JEditorPane source) {
        this.sourcePane = source;

        init();
        initListeners();
    }


    protected void init() {

        setLayout(new BorderLayout());

        JPanel treePanel = new JPanel();

        treePanel.setLayout(new GridBagLayout());

        treePanel.add(new JLabel("Document structure"), new GridBagConstraints(0, 0, 1, 1, 1, 0, GridBagConstraints.WEST, GridBagConstraints.HORIZONTAL, new Insets(5, 5, 5, 5), 0, 0));
        JScrollPane scroll = new JScrollPane(trDocument);
        scroll.setPreferredSize(new Dimension(300, 200));
        treePanel.add(scroll, new GridBagConstraints(0, 1, 1, 1, 1, 1, GridBagConstraints.WEST, GridBagConstraints.BOTH, new Insets(5, 5, 5, 5), 0, 0));
        treePanel.add(new JLabel("Views structure (Select node to highlight the view's bounds)"), new GridBagConstraints(0, 2, 1, 1, 1, 0, GridBagConstraints.WEST, GridBagConstraints.HORIZONTAL, new Insets(5, 5, 5, 5), 0, 0));

        scroll = new JScrollPane(trView);
        scroll.setPreferredSize(new Dimension(300, 200));
        treePanel.add(scroll, new GridBagConstraints(0, 3, 1, 1, 1, 1, GridBagConstraints.WEST, GridBagConstraints.BOTH, new Insets(5, 5, 5, 5), 0, 0));

        treePanel.add(btnRefresh, new GridBagConstraints(0, 5, 1, 1, 0, 0, GridBagConstraints.EAST, GridBagConstraints.NONE, new Insets(5, 5, 5, 5), 0, 0));
        btnRefresh.setToolTipText("Press here to refresh trees");

        this.add(treePanel);


        JPanel buttonPanel = new JPanel();

        JButton refreshButton = new javax.swing.JButton("Refresh");
        refreshButton.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent evt) {
                EditorPaneStructure.this.refresh();
            }//end method.

        });
        refreshButton.setEnabled(true);
        buttonPanel.add(refreshButton);

        this.add(buttonPanel, BorderLayout.NORTH);
    }


    protected void initListeners() {
        btnRefresh.addActionListener(new ActionListener() {

            public void actionPerformed(ActionEvent e) {
                refresh();
            }

        });

        trView.addTreeSelectionListener(new TreeSelectionListener() {

            public void valueChanged(TreeSelectionEvent e) {
                if (e.getNewLeadSelectionPath() != null) {
                    DefaultMutableTreeNode node = (DefaultMutableTreeNode) e.getNewLeadSelectionPath().getLastPathComponent();
                    View v = (View) node.getUserObject();
                    if (v.getParent() == null) {
                        View vParent = (View) ((DefaultMutableTreeNode) node.getParent()).getUserObject();
                        v = vParent.getView(vParent.getViewIndex(v.getStartOffset(), Position.Bias.Forward));
                    }
                    Rectangle r = getAllocation(v, sourcePane).getBounds();
                    lblViewBounds.setBounds(r);
                    sourcePane.add(lblViewBounds);
                    sourcePane.repaint();
                }
            }

        });
    }


    public void refresh() {
        if (sourcePane != null) {
            Document doc = sourcePane.getDocument();

            Element elem = doc.getDefaultRootElement();
            if (elem instanceof TreeNode) {
                trDocument.setModel(new DefaultTreeModel((TreeNode) elem));
            } else {
                DefaultMutableTreeNode node1 = new DefaultMutableTreeNode(elem);
                buildElementsTree(node1, elem);
                trDocument.setModel(new DefaultTreeModel(node1));
            }
            int row = 0;
            while (row < trDocument.getRowCount()) {
                trDocument.expandRow(row);
                row++;
            }
            trDocument.setToolTipText(" ");

            View v = sourcePane.getUI().getRootView(sourcePane);
            DefaultMutableTreeNode node = new DefaultMutableTreeNode(v);
            buildViewTree(node, v);
            trView.setModel(new DefaultTreeModel(node));
            row = 0;
            while (row < trView.getRowCount()) {
                trView.expandRow(row);
                row++;
            }
            trView.setToolTipText(" ");
        }
    }


    public void buildElementsTree(DefaultMutableTreeNode root, Element elem) {
        for (int i = 0; i < elem.getElementCount(); i++) {
            AttributeSet attrs = getAttributes(elem.getElement(i));
            String str = elem.getElement(i).toString() + " " + attrs.getClass().getName() + "@" + Integer.toHexString(attrs.hashCode());
            DefaultMutableTreeNode node = new DefaultMutableTreeNode(str);
            root.add(node);
            buildElementsTree(node, elem.getElement(i));
        }
    }


    public void buildViewTree(DefaultMutableTreeNode root, View v) {
        for (int i = 0; i < v.getViewCount(); i++) {
            DefaultMutableTreeNode node = new DefaultMutableTreeNode(v.getView(i));
            root.add(node);
            buildViewTree(node, v.getView(i));
        }
    }


    protected AttributeSet getAttributes(Element elem) {
        if (elem instanceof AbstractDocument.AbstractElement) {
            try {
                Field f = AbstractDocument.AbstractElement.class.getDeclaredField("attributes");
                f.setAccessible(true);
                AttributeSet res = (AttributeSet) f.get(elem);
                return res;
            } catch (NoSuchFieldException e) {
                e.printStackTrace();
            } catch (IllegalAccessException e) {
                e.printStackTrace();
            }
        }

        return null;
    }


    protected String processDocumentTooltip(MouseEvent e) {
        int rn = trDocument.getRowForLocation(e.getX(), e.getY());
        if (trDocument.getPathForRow(rn) != null) {
            Element tn = (Element) trDocument.getPathForRow(rn).getLastPathComponent();
            StringBuffer buff = new StringBuffer();
            buff.append("");
            buff.append("Start offset: ").append(tn.getStartOffset()).append("
    ");
            buff.append("End offset: ").append(tn.getEndOffset()).append("
    ");
            buff.append("Child count: ").append(tn.getElementCount()).append("
    ");
            buff.append("Text: \"").append(getText(tn.getDocument(), tn.getStartOffset(), tn.getEndOffset())).append("\"
    ");
            buff.append("Attributes: ").append("
    ");
            Enumeration names = tn.getAttributes().getAttributeNames();
            while (names.hasMoreElements()) {
                Object name = names.nextElement();
                Object value = tn.getAttributes().getAttribute(name);
                buff.append("  ").append(name).append(":").append(value).append("
    ");
            }
            buff.append("");
            return buff.toString();
        }

        return null;
    }


    protected String getText(Document doc, int startOffset, int endOffset) {
        try {
            String text = doc.getText(startOffset, endOffset - startOffset);
            text = text.replaceAll("\n", "\\\\n");
            text = text.replaceAll("\t", "\\\\t");
            text = text.replaceAll("\r", "\\\\r");

            return text;
        } catch (BadLocationException e1) {
            e1.printStackTrace();
        }

        return null;
    }


    protected String processViewTooltip(MouseEvent e) {
        int rn = trView.getRowForLocation(e.getX(), e.getY());
        if (trView.getPathForRow(rn) != null) {
            View tn = (View) ((DefaultMutableTreeNode) trView.getPathForRow(rn).getLastPathComponent()).getUserObject();
            StringBuffer buff = new StringBuffer();
            buff.append("");
            buff.append("Start offset: ").append(tn.getStartOffset()).append("
    ");
            buff.append("End offset: ").append(tn.getEndOffset()).append("
    ");
            buff.append("Child count: ").append(tn.getViewCount()).append("
    ");
            buff.append("Text: \"").append(getText(tn.getDocument(), tn.getStartOffset(), tn.getEndOffset())).append("\"
    ");
            if (tn.getAttributes() != null) {
                buff.append("Attributes: ").append("
    ");
                Enumeration names = tn.getAttributes().getAttributeNames();
                while (names.hasMoreElements()) {
                    Object name = names.nextElement();
                    Object value = tn.getAttributes().getAttribute(name);
                    buff.append("  ").append(name).append(":").append(value).append("
    ");
                }
            }
            buff.append("");
            return buff.toString();
        }

        return null;
    }


    protected static Shape getAllocation(View v, JEditorPane edit) {
        Insets ins = edit.getInsets();
        View vParent = v.getParent();
        int x = ins.left;
        int y = ins.top;
        while (vParent != null) {
            int i = vParent.getViewIndex(v.getStartOffset(), Position.Bias.Forward);
            Shape alloc = vParent.getChildAllocation(i, new Rectangle(0, 0, Short.MAX_VALUE, Short.MAX_VALUE));
            x += alloc.getBounds().x;
            y += alloc.getBounds().y;

            vParent = vParent.getParent();
        }

        if (v instanceof BoxView) {
            int ind = v.getParent().getViewIndex(v.getStartOffset(), Position.Bias.Forward);
            Rectangle r2 = v.getParent().getChildAllocation(ind, new Rectangle(0, 0, Integer.MAX_VALUE, Integer.MAX_VALUE)).getBounds();

            return new Rectangle(x, y, r2.width, r2.height);
        }

        return new Rectangle(x, y, (int) v.getPreferredSpan(View.X_AXIS), (int) v.getPreferredSpan(View.Y_AXIS));
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/ui/gui/consoles/ResizableBorder.java0000644000175000017500000000604411423200443030455 0ustar  giovannigiovannipackage org.mathpiper.ui.gui.consoles;

import java.awt.Color;
import java.awt.Component;
import java.awt.Cursor;
import java.awt.Graphics;
import java.awt.Insets;
import java.awt.Rectangle;
import java.awt.event.MouseEvent;

import javax.swing.SwingConstants;
import javax.swing.border.Border;

// ResizableBorder.java

public class ResizableBorder implements Border {
  private int dist = 8;

  int locations[] =
  {
    SwingConstants.NORTH, SwingConstants.SOUTH, SwingConstants.WEST,
    SwingConstants.EAST, SwingConstants.NORTH_WEST,
    SwingConstants.NORTH_EAST, SwingConstants.SOUTH_WEST,
    SwingConstants.SOUTH_EAST
  };

  int cursors[] =
  {
    Cursor.N_RESIZE_CURSOR, Cursor.S_RESIZE_CURSOR, Cursor.W_RESIZE_CURSOR,
    Cursor.E_RESIZE_CURSOR, Cursor.NW_RESIZE_CURSOR, Cursor.NE_RESIZE_CURSOR,
    Cursor.SW_RESIZE_CURSOR, Cursor.SE_RESIZE_CURSOR
  };

  public ResizableBorder(int dist) {
    this.dist = dist;
  }

  public Insets getBorderInsets(Component component) {
      return new Insets(dist, dist, dist, dist);
  }

  public boolean isBorderOpaque() {
      return false;
  }

  public void paintBorder(Component component, Graphics g, int x, int y,
                          int w, int h) {
      g.setColor(Color.black);
      g.drawRect(x + dist / 2, y + dist / 2, w - dist, h - dist);

      if (component.hasFocus()) {


        for (int i = 0; i < locations.length; i++) {
          Rectangle rect = getRectangle(x, y, w, h, locations[i]);
          g.setColor(Color.WHITE);
          g.fillRect(rect.x, rect.y, rect.width - 1, rect.height - 1);
          g.setColor(Color.BLACK);
          g.drawRect(rect.x, rect.y, rect.width - 1, rect.height - 1);
        }
      }
  }

  private Rectangle getRectangle(int x, int y, int w, int h, int location) {
      switch (location) {
      case SwingConstants.NORTH:
          return new Rectangle(x + w / 2 - dist / 2, y, dist, dist);
      case SwingConstants.SOUTH:
          return new Rectangle(x + w / 2 - dist / 2, y + h - dist, dist,
                               dist);
      case SwingConstants.WEST:
          return new Rectangle(x, y + h / 2 - dist / 2, dist, dist);
      case SwingConstants.EAST:
          return new Rectangle(x + w - dist, y + h / 2 - dist / 2, dist,
                               dist);
      case SwingConstants.NORTH_WEST:
          return new Rectangle(x, y, dist, dist);
      case SwingConstants.NORTH_EAST:
          return new Rectangle(x + w - dist, y, dist, dist);
      case SwingConstants.SOUTH_WEST:
          return new Rectangle(x, y + h - dist, dist, dist);
      case SwingConstants.SOUTH_EAST:
          return new Rectangle(x + w - dist, y + h - dist, dist, dist);
      }
      return null;
  }

  public int getCursor(MouseEvent me) {
      Component c = me.getComponent();
      int w = c.getWidth();
      int h = c.getHeight();

      for (int i = 0; i < locations.length; i++) {
          Rectangle rect = getRectangle(0, 0, w, h, locations[i]);
          if (rect.contains(me.getPoint()))
              return cursors[i];
      }

      return Cursor.MOVE_CURSOR;
  }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/0000755000175000017500000000000011722677325023173 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/0000755000175000017500000000000011722677321025177 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/0000755000175000017500000000000011722677324026132 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PrettyReaderGet.java0000644000175000017500000000370211523200452032030 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class PrettyReaderGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        if (aEnvironment.iPrettyReaderName == null)
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"\""));
        } else
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.iPrettyReaderName));
        }
    }
}



/*
%mathpiper_docs,name="PrettyReaderGet",categories="User Functions;Built In"
*CMD PrettyReaderGet --- get routine that is currently used as pretty-reader

*CORE

*CALL
	PrettyReaderGet()

*DESC

{PrettyReaderGet()} returns the current reader, or it returns
an empty string if the default pretty printer is used.



*E.G.

In> PrettyReaderGet()
Result: ""

*SEE Read, LispRead, OMRead, PrettyPrinterSet, PrettyPrinterGet, PrettyReaderSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MetaKeys.java0000644000175000017500000000470011357471613030515 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;


public class MetaKeys extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer objectPointer = new ConsPointer();
        objectPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        Map metadataMap = objectPointer.getCons().getMetadataMap();

        if (metadataMap == null || metadataMap.isEmpty()) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, aEnvironment.iListAtom.copy( aEnvironment, false)));

            return;
        }//end if.


        java.util.Set keySet = (java.util.Set) metadataMap.keySet();

        Cons head = Utility.iterableToList(aEnvironment, aStackTop, keySet);
        
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,head));




    }//end method.


}//end class.



/*
%mathpiper_docs,name="MetaKeys",categories="User Functions;Built In"
*CMD MetaKeys --- returns the metadata keys for a value or an unbound variable
*CORE
*CALL
MetaKeys(value_or_unbound_variable)

*PARMS

{value_or_unbound_variable} -- a value or an unbound variable

*DESC
Returns the metadata keys for a value or an unbound variables.  The metadata is
held in an associative list.

*SEE MetaGet, MetaSet, MetaValues, Unbind
%/mathpiper_docs
 */mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PipeFromFile.java0000644000175000017500000000742711523200452031307 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.InputStatus;
import org.mathpiper.lisp.Environment;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class PipeFromFile extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);
        ConsPointer evaluated = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, getArgumentPointer(aEnvironment, aStackTop, 1));

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "PipeFromFile");
        String orig =  (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "PipeFromFile");

        String hashedname = aEnvironment.getTokenHash().lookUpUnStringify(orig);

        InputStatus oldstatus = aEnvironment.iInputStatus;
        MathPiperInputStream previous = aEnvironment.iCurrentInput;
        try
        {
            aEnvironment.iInputStatus.setTo(hashedname);
            MathPiperInputStream input = // new StdFileInput(hashedname, aEnvironment.iInputStatus);
                    Utility.openInputFile(aEnvironment, aEnvironment.iInputDirectories, hashedname, aEnvironment.iInputStatus);
            aEnvironment.iCurrentInput = input;
            // Open file
            LispError.check(aEnvironment, aStackTop, input != null, LispError.FILE_NOT_FOUND);

            // Evaluate the body
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 2));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iCurrentInput = previous;
            aEnvironment.iInputStatus.restoreFrom(oldstatus);
        }
    //Return the getTopOfStackPointer
    }
}



/*
%mathpiper_docs,name="PipeFromFile",categories="User Functions;Input/Output;Built In"
*CMD PipeFromFile --- connect current input to a file
*CORE
*CALL
	PipeFromFile(name) body

*PARMS

{name} - string, the name of the file to read

{body} - expression to be evaluated

*DESC

The current input is connected to the file "name". Then the expression
"body" is evaluated. If some functions in "body" try to read
from current input, they will now read from the file "name". Finally, the
file is closed and the result of evaluating "body" is returned.

*E.G. notest

Suppose that the file {foo} contains

	2 + 5;

Then we can have the following dialogue:

In> PipeFromFile("foo") res := Read();
Result: 2+5;
In> PipeFromFile("foo") res := ReadToken();
Result: 2;

*SEE PipeToFile, FromString, Read, ReadToken
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsInfix.java0000644000175000017500000000351511523200452030331 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsInfix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iInfixOperators);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), op != null);
    }
}



/*
%mathpiper_docs,name="IsInfix",categories="User Functions;Predicates;Built In"
*CMD IsInfix --- check for function syntax
*CORE
*CALL
	IsInfix("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Check whether the function with given name {"op"} has been declared as a
"bodied", infix, postfix, or prefix operator, and  return {True} or {False}.

*E.G.

In> IsInfix("+");
Result: True;

*SEE Bodied, PrecedenceGet,IsBodied,IsPostfix,IsPrefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MetaValues.java0000644000175000017500000000552611506531763031047 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import java.util.Iterator;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;


public class MetaValues extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer objectPointer = new ConsPointer();
        objectPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        Map metadataMap = objectPointer.getCons().getMetadataMap();

        if (metadataMap == null || metadataMap.isEmpty()) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, aEnvironment.iListAtom.copy( aEnvironment, false)));

            return;
        }//end if.


        ConsPointer consPointer = new ConsPointer();

        Cons head = aEnvironment.iListAtom.copy( aEnvironment, false);

        consPointer.setCons(head);

        java.util.Collection valueCollection = (java.util.Collection) metadataMap.values();

        Iterator valueIterator = valueCollection.iterator();

        while(valueIterator.hasNext())
        {
           Cons cons = (Cons) valueIterator.next();

           consPointer.getCons().cdr().setCons(cons);

           consPointer.goNext(aStackTop, aEnvironment);

        }//end while.



        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,head));




    }//end method.


}//end class.



/*
%mathpiper_docs,name="MetaValues",categories="User Functions;Built In"
*CMD MetaValues --- returns the metadata values for a value or an unbound variable
*CORE
*CALL
MetaValues(value_or_unbound_variable)

*PARMS


{value_or_unbound_variable} -- a value or an unbound variable


*DESC

Returns the metadata values for a value or an unbound variable.  The metadata is
held in an associative list.



*SEE MetaGet, MetaSet, MetaKeys, Unbind
%/mathpiper_docs
 */mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BuiltinPrecisionGet.java0000644000175000017500000000343111523200452032677 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class BuiltinPrecisionGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // decimal getPrecision
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + aEnvironment.getPrecision()));
    }
}



/*
%mathpiper_docs,name="BuiltinPrecisionGet",categories="Programmer Functions;Numerical (Arbitrary Precision);Built In"
*CMD BuiltinPrecisionGet --- get the current precision
*CORE
*CALL
	BuiltinPrecisionGet()

*DESC

This command returns the current precision, as set by {BuiltinPrecisionSet}.

*E.G.

In> BuiltinPrecisionGet();
Result: 10;
In> BuiltinPrecisionSet(20);
Result: True;
In> BuiltinPrecisionGet();
Result: 20;

*SEE BuiltinPrecisionSet, N

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Not.java0000644000175000017500000000473611523200452027526 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class Not extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        if (Utility.isTrue(aEnvironment, evaluated, aStackTop) || Utility.isFalse(aEnvironment, evaluated, aStackTop))
        {
            Utility.not(aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), aEnvironment, evaluated);
        } else
        {
            ConsPointer ptr = new ConsPointer();
            ptr.setCons(getArgumentPointer(aEnvironment, aStackTop, 0).getCons().copy( aEnvironment, false));
            ptr.cdr().setCons(evaluated.getCons());
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,ptr.getCons()));
        }
    }
}



/*
%mathpiper_docs,name="Not",categories="User Functions;Predicates;Built In"
*CMD Not --- logical negation
*CORE
*CALL
	Not expr

*PARMS

{expr} -- a boolean expression

*DESC

Not returns the logical negation of the argument expr. If {expr} is
{False} it returns {True}, and if {expr} is {True}, {Not expr} returns {False}.
If the argument is neither {True} nor {False}, it returns the entire
expression with evaluated arguments.

*E.G.

In> Not True
Result: False;
In> Not False
Result: True;
In> Not(a)
Result: Not a;

*SEE And, Or
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/TraceRule.java0000644000175000017500000000523111523200452030643 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class TraceRule extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispTraceRule");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}



/*
%mathpiper_docs,name="TraceRule",categories="User Functions;Control Flow;Built In",access="private"
*CMD TraceRule --- turn on tracing for a particular function
*CORE
*CALL
	TraceRule(template) expr

*PARMS

{template} -- template showing the operator to trace

{expr} -- expression to evaluate with tracing on

*DESC

The tracing facility is turned on for subexpressions of the form
"template", and the expression "expr" is evaluated. The template
"template" is an example of the function to trace on. Specifically, all
subexpressions with the same top-level operator and arity as "template"
are shown. The subexpressions are displayed before (indicated with {TrEnter}) and after ({TrLeave})
evaluation. In between, the arguments are shown before and after
evaluation ({TrArg}). Only functions defined in
scripts can be traced.

This is useful for tracing a function that is called from within
another function. This way you can see how your function behaves
in the environment it is used in.

*E.G. notest

In> TraceRule(x+y) 2+3*5+4;
	    TrEnter(2+3*5+4);
	      TrEnter(2+3*5);
	          TrArg(2, 2);
	          TrArg(3*5, 15);
	      TrLeave(2+3*5, 17);
	        TrArg(2+3*5, 17);
	        TrArg(4, 4);
	    TrLeave(2+3*5+4, 21);
Result: 21;

*SEE TraceStack, TraceExp
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Break.java0000644000175000017500000000334711235446460030022 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.BreakException;
import org.mathpiper.lisp.Environment;

/**
 *
 *
 */
public class Break extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         throw new BreakException();
    }
    
}//end class.



/*
%mathpiper_docs,name="Break",categories="User Functions;Control Flow;Built In"
*CMD Break --- break out of a loop
*CORE
*CALL

    Break()

*DESC

If Break is executed inside of a While, Until, For, or ForEach loop, it will
cause the loop to be exited.

*E.G.

/%mathpiper

x := 1;

While(x <= 10)
[
    Echo(x);

    If(x = 5, Break());

    x++;
];

/%/mathpiper

    /%output,preserve="false"
      Result: True

      Side Effects:
      1
      2
      3
      4
      5
.   /%/output

*SEE While, Until, For, ForEach, Continue
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Delete.java0000644000175000017500000000352011523200452030156 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Delete extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.delete(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="Delete",categories="User Functions;Lists (Operations);Built In"
*CMD Delete --- delete an element from a list
*CORE
*CALL
	Delete(list, n)

*PARMS

{list} -- list from which an element should be removed

{n} -- index of the element to remove

*DESC

This command deletes the n-th element from "list". The first
parameter should be a list, while "n" should be a positive integer
less than or equal to the length of "list". The entry with index
"n" is removed (the first entry has index 1), and the resulting list
is returned.

*E.G.

In> Delete({a,b,c,d,e,f}, 4);
Result: {a,b,c,e,f};

*SEE DestructiveDelete, Insert, Replace
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RightAssociativeSet.java0000644000175000017500000000465711332771351032725 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class RightAssociativeSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "RightAssociativeSet");
        String orig = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "RightAssociativeSet");
        aEnvironment.iInfixOperators.setRightAssociative(aStackTop, Utility.getSymbolName(aEnvironment, orig));
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="RightAssociativeSet",categories="Programmer Functions;Programming;Built In"
*CMD RightAssociativeSet --- declare associativity
*CORE
*CALL
	RightAssociativeSet("op")

*PARMS

{"op"} -- string, the name of a function

*DESC
This makes the operator right-associative. For example:
	RightAssociativeSet("*")
would make multiplication right-associative. Take care not to abuse this
function, because the reverse, making an infix operator left-associative, is
not implemented. (All infix operators are by default left-associative until
they are declared to be right-associative.)

*SEE PrecedenceGet, LeftPrecedenceGet, RightPrecedenceGet, LeftPrecedenceSet, RightPrecedenceSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Hold.java0000644000175000017500000000361411417443641027661 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  tkosan
 */
public class Hold extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons().copy( aEnvironment, false));
    }
}

/*
%mathpiper_docs,name="Hold",categories="Programmer Functions;Programming;Built In"
*CMD Hold --- keep expression unevaluated
*CORE
*CALL
	Hold(expr)

*PARMS

{expr} -- expression to keep unevaluated

*DESC

The expression "expr" is returned unevaluated. This is useful to
prevent the evaluation of a certain expression in a context in which
evaluation normally takes place.

The function {ListToFunction()} also leaves its result unevaluated.
 Both functions stop the process of evaluation (no more rules will be applied).

*E.G.

In> Echo({ Hold(1+1), "=", 1+1 });
Result: True
Side Effects:
{1+1,"=",2} 

*SEE Eval, HoldArgument, ListToFunction
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MetaEntries.java0000644000175000017500000000703211357472433031215 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import java.util.Iterator;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;


public class MetaEntries extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer objectPointer = new ConsPointer();
        objectPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        Map metadataMap = objectPointer.getCons().getMetadataMap();

        if (metadataMap == null || metadataMap.isEmpty()) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, aEnvironment.iListAtom.copy(aEnvironment, false)));

            return;
        }//end if.


        ConsPointer consPointer = new ConsPointer();

        Cons head = aEnvironment.iListAtom.copy(aEnvironment, false);

        consPointer.setCons(head);

        java.util.Set keySet = (java.util.Set) metadataMap.keySet();

        Iterator keyIterator = keySet.iterator();

        java.util.Collection valueCollection = (java.util.Collection) metadataMap.values();

        Iterator valueIterator = valueCollection.iterator();

        while (keyIterator.hasNext()) {


            //Add -> operator cons.
            Cons operatorCons = AtomCons.getInstance(aEnvironment, aStackTop, "->");



            //Add key cons.
            String key = (String) keyIterator.next();

            Cons keyCons = AtomCons.getInstance(aEnvironment, aStackTop, key);

            operatorCons.cdr().setCons(keyCons);


            
            //Add value cons.
            Cons valueCons = (Cons) metadataMap.get(key);
            keyCons.cdr().setCons(valueCons);



            //Place entry in list.
            consPointer.getCons().cdr().setCons(SublistCons.getInstance(aEnvironment, operatorCons));

            consPointer.goNext(aStackTop, aEnvironment);




        }//end while.



        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, head));




    }//end method.


}//end class.



/*
%mathpiper_docs,name="MetaEntries",categories="User Functions;Built In"
*CMD MetaValues --- returns the metadata values for a value or an unbound variable
*CORE
*CALL
MetaValues(value_or_unbound_variable)

*PARMS


{value_or_unbound_variable} -- a value or an unbound variable


*DESC

todo:tk: not functional yet.

Returns the metadata values for a value or an unbound variable.  The metadata is
held in an associative list.



*SEE MetaGet, MetaSet, MetaKeys, Unbind
%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Modulo.java0000644000175000017500000000514711345636344030241 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Modulo extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.mod(null,aStackTop, x, y);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="ModuloN",categories="User Functions;Numeric;Built In"
*CMD ModuloN --- remainder of division or x modulo y (arbitrary-precision math function)
*CORE
*CALL
	ModuloN(x,y) ()

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In> Modulo(2,3)
Result: 2

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RightPrecedenceSet.java0000644000175000017500000000631411333354275032503 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class RightPrecedenceSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "RightPrecedenceSet");
        String orig = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "RightPrecedenceSet");

        ConsPointer index = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, index, getArgumentPointer(aEnvironment, aStackTop, 2));
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "RightPrecedenceSet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "RightPrecedenceSet");
        int ind = Integer.parseInt ( (String) index.car(), 10);

        aEnvironment.iInfixOperators.setRightPrecedence(aStackTop, Utility.getSymbolName(aEnvironment, orig), ind);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="RightPrecedenceSet",categories="User Functions;Built In"
*CMD RightPrecedenceSet --- set operator precedence
*CORE
*CALL
	RightPrecedenceSet("op",precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer

*DESC

{"op"} should be an infix operator. This function call tells the
infix expression printer to bracket the right hand side of
the expression if its precedence is larger than precedence.

This functionality was required in order to display expressions like {a-(b-c)}
correctly. Thus, {a+b+c} is the same as {a+(b+c)}, but {a-(b-c)} is not
the same as {a-b-c}.

Note that the right precedence of an infix operator does not affect the way MathPiper interprets expressions typed by the user. You cannot make MathPiper parse {a-b-c} as {a-(b-c)} unless you declare the operator "{-}" to be right-associative.

*SEE PrecedenceGet, LeftPrecedenceGet, RightPrecedenceGet, LeftPrecedenceSet, RightAssociativeSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Read.java0000644000175000017500000000411011523200452027623 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.parsers.MathPiperParser;

/**
 *
 * 
 */
public class Read extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        MathPiperParser parser = new MathPiperParser(aEnvironment.iCurrentTokenizer,
                aEnvironment.iCurrentInput,
                aEnvironment,
                aEnvironment.iPrefixOperators,
                aEnvironment.iInfixOperators,
                aEnvironment.iPostfixOperators,
                aEnvironment.iBodiedOperators);
        // Read expression
        parser.parse(aStackTop, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="Read",categories="User Functions;Input/Output;Built In"
*CMD Read --- read an expression from current input
*CORE
*CALL
	Read()

*DESC

Read an expression from the current input, and return it unevaluated. When
the end of an input file is encountered, the token atom {EndOfFile} is returned.

*E.G.

In> PipeFromString("2+5;") Read();
Result: 2+5;
In> PipeFromString("") Read();
Result: EndOfFile;

*SEE PipeFromFile, PipeFromString, LispRead, ReadToken, Write
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/GlobalVariablesGet.java0000644000175000017500000000454111554752464032474 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import java.util.ArrayList;
import java.util.Collections;
import java.util.Comparator;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *
 */
public class GlobalVariablesGet extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        java.util.Set variablesSet = ((Map) aEnvironment.getGlobalState().getMap()).keySet();
        
        java.util.List variablesList = new ArrayList(variablesSet);

        Collections.sort(variablesList, new NameComparator() );

        Cons head = Utility.iterableToList(aEnvironment, aStackTop, variablesList);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, head));

    }//end method.



    private class NameComparator implements Comparator{

        public int compare(String s1, String s2) {
            return s1.compareToIgnoreCase(s2);
        }//end method.
    }//end class.

}//end class.



/*
%mathpiper_docs,name="GlobalVariablesGet",categories="User Functions;Variables"
*CMD GlobalVariablesGet --- return a list which contains the names of all the global variables

*CALL
GlobalVariablesGet()


*DESC
Return a list which contains the names of all the global variables.

*E.G.
In> GlobalVariablesGet()
Result> {\$CacheOfConstantsN1,%,I,\$numericMode2}

%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Replace.java0000644000175000017500000000357311523200452030337 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Replace extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.replace(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="Replace",categories="User Functions;Lists (Operations);Built In"
*CMD Replace --- replace an entry in a list

*CORE

*CALL
	Replace(list, n, expr)

*PARMS

{list} -- list of which an entry should be replaced

{n} -- index of entry to replace

{expr} -- expression to replace the n-th entry with

*DESC

The n-th entry of "list" is replaced by the expression
"expr". This is equivalent to calling {Delete} and
{Insert} in sequence. To be precise, the expression
{Replace(list, n, expr)} has the same result as the
expression {Insert(Delete(list, n), n, expr)}.

*E.G.

In> Replace({a,b,c,d,e,f}, 4, x);
Result: {a,b,c,x,e,f};

*SEE Delete, Insert, DestructiveReplace
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BitOr.java0000644000175000017500000000337311345636344030020 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class BitOr extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.bitOr(x, y, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper_docs,name="BitOr",categories="User Functions;Built In"
*CMD BitOr --- bitwise or operation
*CORE
*CALL
	BitOr(n,m)

*DESC
This function returns the bitwise "or"
of two numbers.

*SEE BitAnd, BitXor

%/mathpiper_docs
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BitXor.java0000644000175000017500000000340011345636344030177 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class BitXor extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.bitXor(x, y, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper_docs,name="BitXor",categories="User Functions;Built In"
*CMD BitXor --- bitwise xor operation
*CORE
*CALL
	BitXor(n,m)

*DESC
This function returns the bitwise "xor"
of two numbers.

*SEE BitAnd, BitOr

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FindFile.java0000644000175000017500000000531211502266107030443 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class FindFile extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);

        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "FindFile");
        String orig = (String)  evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "FindFile");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        String filename = Utility.findFile(oper, aEnvironment.iInputDirectories);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(filename)));
    }
}



/*
%mathpiper_docs,name="FindFile",categories="User Functions;Input/Output;Built In"
*CMD FindFile --- find a file in the current path
*CORE
*CALL
	FindFile(name)

*PARMS

{name} -- string, name of the file or directory to find

*DESC

The result of this command is the full path to the file that would be
opened when the command {Load(name)} would be
invoked. This means that the input directories are subsequently
searched for a file called "name". If such a file is not found, {FindFile} returns an empty string.

{FindFile("")} returns the name of the default directory (the car one on the search path).

*SEE Load, DefaultDirectory
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MetaGet.java0000644000175000017500000000406011357471613030320 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */
package org.mathpiper.builtin.functions.core;


import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;


public class MetaGet extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer objectPointer = new ConsPointer();
        objectPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        ConsPointer keyPointer = new ConsPointer();
        keyPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, keyPointer, 2, "MetaGet");


        Map metadataMap = objectPointer.getCons().getMetadataMap();

        if (metadataMap == null) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "Empty"));

            return;
        }//end if.


        Cons valueCons = (Cons) metadataMap.get((String) keyPointer.getCons().car());


        if (valueCons == null) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "Empty"));
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(valueCons);
        }



    }//end method.


}//end class.



/*
%mathpiper_docs,name="MetaGet",categories="User Functions;Built In"
*CMD MetaGet --- returns the metadata for a value or an unbound variable
*CORE
*CALL
MetaGet(value_or_unbound_variable, key_string)

*PARMS

{value_or_unbound_variable} -- a value or an unbound variable

{key_string} -- a string which is the key for the given value


*DESC

Returns the metadata for a value or an unbound variables.  The metadata is
held in an associative list.



*SEE MetaSet, MetaKeys, MetaValues, Unbind
%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ExceptionGet.java0000644000175000017500000001306411502301211031346 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class ExceptionGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        if(aEnvironment.iException == null)
        {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }
        else
        {
            Throwable exception = aEnvironment.iException;

            String type = null;

            String message = null;

            if(exception instanceof EvaluationException)
            {
               EvaluationException evaluationException = (EvaluationException) exception;

               type = evaluationException.getType();
            }
            else
            {
                type = exception.getClass().getName();
            }

            message = exception.getMessage();


            JavaObject exceptionObject = new JavaObject(exception);

            
            
            //Create type association list.
            Cons typeListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons typeNameAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"type\"");

            Cons typeValueValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, Utility.toMathPiperString(aEnvironment, aStackTop, type));

            typeListAtomCons.cdr().setCons(typeNameAtomCons);

            typeNameAtomCons.cdr().setCons(typeValueValueAtomCons);

            Cons typeSublistCons = SublistCons.getInstance(aEnvironment, typeListAtomCons);




            //Create message association list.
            Cons messageListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons messageNameAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"message\"");

            Cons messageValueValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, Utility.toMathPiperString(aEnvironment, aStackTop, message));

            messageListAtomCons.cdr().setCons(messageNameAtomCons);

            messageNameAtomCons.cdr().setCons(messageValueValueAtomCons);

            Cons messageSublistCons = SublistCons.getInstance(aEnvironment, messageListAtomCons);



            //Create exception object association list.
            Cons exceptionObjectListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons exceptionObjectNameAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"exceptionObject\"");

            Cons exceptionObjectValueValueAtomCons = BuiltinObjectCons.getInstance(aEnvironment, aStackTop, exceptionObject);

            exceptionObjectListAtomCons.cdr().setCons(exceptionObjectNameAtomCons);

            exceptionObjectNameAtomCons.cdr().setCons(exceptionObjectValueValueAtomCons);

            Cons exceptionObjectSublistCons = SublistCons.getInstance(aEnvironment, exceptionObjectListAtomCons);



            //Create result list.
            typeSublistCons.cdr().setCons(messageSublistCons);

            messageSublistCons.cdr().setCons(exceptionObjectSublistCons);

            //exceptionSublistCons.cdr().setCons(xxxSublistCons);

            //xxxSublistCons.cdr().setCons(yyySublistCons);

            Cons resultListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            resultListAtomCons.cdr().setCons(typeSublistCons);

            Cons resultSublistCons = SublistCons.getInstance(aEnvironment, resultListAtomCons);




            getTopOfStackPointer(aEnvironment, aStackTop).setCons(resultSublistCons);

        }
    }
}



/*
%mathpiper_docs,name="ExceptionGet",categories="Programmer Functions;Built In"
*CMD ExceptionGet --- returns the exception object which was thrown.
*CORE
*CALL
	ExceptionGet()

*DESC

ExceptionGet is designed to be used in the {exceptionHandler} argument of {ExceptionCatch} and it
 returns an association list which contains information about the caught exception.  If {ExceptionGet} is
 evaluated outside of {ExceptionCatch}, it always returns {False};
{ExceptionCatch} and {ExceptionGet} are used in combination to write
an exception handler.

*E.G.

In> ExceptionGet()
Result: False


 
In> ExceptionCatch(Check(1 = 2, "Test", "Throwing a test exception."), Echo(ExceptionGet()))
Result: True
Side Effects:
{{"type","Test"},{"message","Throwing a test exception."},{"exceptionObject",class org.mathpiper.exceptions.EvaluationException}}

*SEE Check, ExceptionCatch

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ArrayGet.java0000644000175000017500000000551011333354275030507 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.Array;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ArrayGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        BuiltinContainer gen = (BuiltinContainer) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, gen != null, 1,"ArrayGet");
        LispError.checkArgument(aEnvironment, aStackTop, gen.typeName().equals("\"Array\""), 1, "ArrayGet");

        ConsPointer sizearg = new ConsPointer();
        sizearg.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        LispError.checkArgument(aEnvironment, aStackTop, sizearg.getCons() != null, 2, "ArrayGet");
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.car() instanceof String, 2, "ArrayGet");

        int size = Integer.parseInt( (String) sizearg.car(), 10);

        LispError.checkArgument(aEnvironment, aStackTop, size > 0 && size <= ((Array) gen).size(), 2, "ArrayGet");
        Cons object = ((Array) gen).getElement(size, aStackTop, aEnvironment);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(object.copy( aEnvironment, false));
    }
}//end class.



/*
%mathpiper_docs,name="ArrayGet",categories="Programmer Functions;Native Objects;Built In"
*CMD ArrayGet --- fetch array element
*CORE
*CALL
	ArrayGet(array,index)

*DESC
Returns the element at position index in the array passed. Arrays are treated
as base-one, so {index} set to 1 would return the car element.

Arrays can also be accessed through the {[]} operators. So
{array[index]} would return the same as {ArrayGet(array, index)}.

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RulebaseDefined.java0000644000175000017500000000520711520672140032005 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.rulebases.SingleArityRulebase;

/**
 *
 *  
 */
public class RulebaseDefined extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer name = new ConsPointer();
        name.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        String orig = (String) name.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "RulebaseDefined");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        ConsPointer sizearg = new ConsPointer();
        sizearg.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.getCons() != null, 2, "RulebaseDefined");
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.car() instanceof String, 2, "RulebaseDefined");

        int arity = Integer.parseInt( (String) sizearg.car(), 10);

        SingleArityRulebase userFunc = aEnvironment.getRulebase((String)aEnvironment.getTokenHash().lookUp(oper), arity, aStackTop);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), userFunc != null);
    }
}





/*
%mathpiper_docs,name="RulebaseDefined",categories="Programmer Functions;Programming;Built In"
*CMD RulebaseDefined --- predicate function which indicates whether or not a rulebase is defined.
*CORE
*CALL
    RulebaseDefined(name)

*PARMS

{name} -- string, name of rulebase

*DESC
This is a predicate function which indicates whether or not a rulebase is defined.

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/UnicodeToString.java0000644000175000017500000000416211447334206032051 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class UnicodeToString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        String str;
        str =  (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, str != null, 2, "UnicodeToString");
        LispError.checkArgument(aEnvironment, aStackTop, Utility.isNumber(str, false), 2, "UnicodeToString");
        char asciiCode = (char) Integer.parseInt(str, 10);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"" + asciiCode + "\""));
    }
}



/*
%mathpiper_docs,name="UnicodeToString",categories="User Functions;String Manipulation;Built In",access="experimental"
*CMD UnicodeToString --- creates a single character string from the character's unicode value
*CORE
*CALL
	UnicodeToString(n)
 
*PARMS
 {n} - a unicode value

*DESC
This function creates a single character string from the character's unicode value.

*E.G.
In> UnicodeToString(65)
Result> "A"

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastArcSin.java0000644000175000017500000000407511506531763030774 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *  
 */
public class FastArcSin extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;
        
        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.asin(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The argument must have a value between -1 and 1.", "FastArcSin", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastArcSin",categories="Programmer Functions;Built In"
*CMD FastArcSin --- double-precision math function
*CORE
*CALL
	FastArcSin(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LeftPrecedenceSet.java0000644000175000017500000000630311333354275032316 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class LeftPrecedenceSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "LeftPrecedenceSet");
        String orig =  (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "LeftPrecedenceSet");

        ConsPointer index = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, index, getArgumentPointer(aEnvironment, aStackTop, 2));
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "LeftPrecedenceSet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "LeftPrecedenceSet");
        int ind = Integer.parseInt( (String) index.car(), 10);

        aEnvironment.iInfixOperators.setLeftPrecedence(aStackTop, Utility.getSymbolName(aEnvironment, orig), ind);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="LeftPrecedenceSet",categories="User Functions;Built In"
*CMD LeftPrecedenceSet --- set operator precedence
*CORE
*CALL
	LeftPrecedenceSet("op",precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer

*DESC

{"op"} should be an infix operator. This function call tells the
infix expression printer to bracket the left  hand side of
the expression if its precedence is larger than precedence.

This functionality was required in order to display expressions like {a-(b-c)}
correctly. Thus, {a+b+c} is the same as {a+(b+c)}, but {a-(b-c)} is not
the same as {a-b-c}.

Note that the left precedence of an infix operator does not affect the way MathPiper interprets expressions typed by the user. You cannot make MathPiper parse {a-b-c} as {a-(b-c)} unless you declare the operator "{-}" to be right-associative.

*SEE PrecedenceGet, LeftPrecedenceGet, RightPrecedenceGet, RightAssociativeSet, RightPrecedenceSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MacroBind.java0000644000175000017500000000353011445560600030622 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MacroBind extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.setVar(aEnvironment, aStackTop, true, false);
    }
}



/*
%mathpiper_docs,name="MacroBind",categories="Programmer Functions;Programming;Built In"
*CMD MacroBind --- define rules in functions
*CORE
*DESC

This function has the same effect as its non-macro counterpart, except
that its arguments are evaluated before the required action is performed.
This is useful in macro-like procedures or in functions that need to define new
rules based on parameters.

Make sure that the arguments of {Macro}... commands evaluate to expressions that would normally be used in the non-macro version!

*SEE Bind, Unbind, Local, Rulebase, Rule, `, MacroUnbind, MacroLocal, MacroRulebase, MacroRulebaseListed, MacroRule
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Nth.java0000644000175000017500000000315511332771351027522 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Nth extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        String str;
        str = (String) getArgumentPointer(aEnvironment, aStackTop, 2).car();
        LispError.checkArgument(aEnvironment, aStackTop, str != null, 2, "Nth");
        LispError.checkArgument(aEnvironment, aStackTop, Utility.isNumber(str, false), 2, "Nth");
        int index = Integer.parseInt(str);
        Utility.nth(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1), index);
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Prog.java0000644000175000017500000000551311333433374027701 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.ReturnException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


/**
 *
 *  
 */
public class Prog extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        // Allow accessing previous locals.
        aEnvironment.pushLocalFrame(false, "Prog");

        try {

            ConsPointer resultPointer = new ConsPointer();

            Utility.putTrueInPointer(aEnvironment, resultPointer);

            // Evaluate args one by one.
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
            consTraverser.goNext(aStackTop);
            while (consTraverser.getCons() != null) {
                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, resultPointer, consTraverser.getPointer());
                consTraverser.goNext(aStackTop);
            }

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(resultPointer.getCons());

        } catch (Exception e) {
            throw e;
        } finally {
            aEnvironment.popLocalFrame(aStackTop);
        }
    }


}



/*
%mathpiper_docs,name="Prog",categories="Programmer Functions;Programming;Built In"
*CMD Prog --- block of statements
*CORE
*CALL
	Prog(statement1, statement2, ...)

*PARMS

{statement1}, {statement2} -- expressions

*DESC

The {Prog} and the {[ ... ]} construct have the same effect: they evaluate all
arguments in order and return the result of the last evaluated expression.

{Prog(a,b);} is the same as typing {[a;b;];} and is very useful for writing out
function bodies. The {[ ... ]} construct is a syntactically nicer version of the
{Prog} call; it is converted into {Prog(...)} during the parsing stage.

*SEE [, ], ReturnFromBlock
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsGreaterThan.java0000644000175000017500000000314711516131015031461 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class IsGreaterThan extends BuiltinFunction
{

    LexGreaterThan compare = new LexGreaterThan();

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        compare.Compare(aEnvironment, aStackTop);
    }
}//end class.



/*
%mathpiper_docs,name="IsGreaterThan",categories="User Functions;Predicates;Built In"
*CMD IsGreaterThan --- comparison predicate
*CORE
*CALL
	IsGreaterThan(a,b)

*PARMS
{a}, {b} -- decimal numbers or strings
*DESC
Compare decimal numbers or strings (lexicographically).

*E.G.
In> IsGreaterThan(1,1)
Result: False;
In> IsGreaterThan("b","a")
Result: True;

*SEE IsLessThan, IsEqual
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsString.java0000644000175000017500000000406311523200452030521 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        boolean resultBoolean ;
         if( result.car() instanceof String  )
         {
             resultBoolean = Utility.isString(   (String) result.car() );

         }
        else{
            resultBoolean = false;
        }
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), resultBoolean);
                
    }
}



/*
%mathpiper_docs,name="IsString",categories="User Functions;Predicates;Built In"
*CMD IsString --- test for an string
*CORE
*CALL
	IsString(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is a string. A string is a text
within quotes, e.g. {"duh"}.

*E.G.

In> IsString("duh");
Result: True;
In> IsString(duh);
Result: False;

*SEE IsAtom, IsNumber
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MacroRulePattern.java0000644000175000017500000000325511500331432032206 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MacroRulePattern extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.newRule(aEnvironment, aStackTop, true);
    }
}




/*
%mathpiper_docs,name="MacroRulePattern",categories="Programmer Functions;Programming;Built In"
*CMD MacroRulePattern --- defines a rule which uses a pattern as its predicate

*CALL
	MacroRulePattern("operator", arity, precedence, pattern) body
*PARMS

{"operator"} -- string, name of function

{arity}, {precedence} -- integers

{pattern} -- a pattern object

{body} -- expression, body of rule

*DESC
This function defines a rule which uses a pattern as its predicate.

*SEE RulePattern
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PrettyPrinterGet.java0000644000175000017500000000372511523200452032256 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class PrettyPrinterGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        if (aEnvironment.iPrettyPrinterName == null)
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"\""));
        } else
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.iPrettyPrinterName));
        }
    }
}



/*
%mathpiper_docs,name="PrettyPrinterGet",categories="User Functions;Built In"
*CMD PrettyPrinterGet --- get routine to use as pretty-printer

*CORE

*CALL
	PrettyPrinterGet()

*DESC

{PrettyPrinterGet()} returns the current pretty printer, or it returns
an empty string if the default pretty printer is used.



*E.G.

In> PrettyPrinterGet()
Result: ""

*SEE PrettyForm, Write, TeXForm, CForm, OMForm, PrettyReaderSet, PrettyReaderGet, PrettyPrinterSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsPostfix.java0000644000175000017500000000352711523200452030713 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsPostfix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPostfixOperators);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), op != null);
    }
}



/*
%mathpiper_docs,name="IsPostfix",categories="User Functions;Predicates;Built In"
*CMD IsPostfix --- check for function syntax
*CORE
*CALL
	IsPostfix("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Check whether the function with given name {"op"} has been declared as a
"bodied", infix, postfix, or prefix operator, and  return {True} or {False}.

*E.G.

In> IsPostfix("!");
Result: True;

*SEE Bodied, PrecedenceGet,IsBodied,IsInfix,IsPrefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ArraySet.java0000644000175000017500000000577111333354275030534 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.Array;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class ArraySet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        BuiltinContainer gen = (BuiltinContainer) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, gen != null, 1, "ArraySet");
        LispError.checkArgument(aEnvironment, aStackTop, gen.typeName().equals("\"Array\""), 1, "ArraySet");

        ConsPointer sizearg = new ConsPointer();
        sizearg.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        LispError.checkArgument(aEnvironment, aStackTop, sizearg.getCons() != null, 2, "ArraySet");
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.car() instanceof String, 2, "ArraySet");

        int size = Integer.parseInt( (String) sizearg.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, size > 0 && size <= ((Array) gen).size(), 2, "ArraySet");

        ConsPointer obj = new ConsPointer();
        obj.setCons(getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        ((Array) gen).setElement(size, obj.getCons(), aStackTop, aEnvironment);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}//end class.



/*
%mathpiper_docs,name="ArraySet",categories="Programmer Functions;Native Objects;Built In"
*CMD ArraySet --- set array element
*CORE
*CALL
	ArraySet(array,index,element)

*DESC
Sets the element at position index in the array passed to the value
passed in as argument to element. Arrays are treated
as base-one, so {index} set to 1 would set car element.

Arrays can also be accessed through the {[]} operators. So
{array[index] := element} would do the same as {ArraySet(array, index,element)}.

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MetaSet.java0000644000175000017500000001452011357471613030336 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;


import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;


public class MetaSet extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer objectPointer = new ConsPointer();
        objectPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        ConsPointer keyPointer = new ConsPointer();
        keyPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, keyPointer, 2, "MetaSet");


        ConsPointer value = new ConsPointer();
        value.setCons(getArgumentPointer(aEnvironment, aStackTop, 3).getCons());


        

        Map metadataMap = objectPointer.getCons().getMetadataMap();

        if(metadataMap == null)
        {
            metadataMap = new HashMap();

            objectPointer.getCons().setMetadataMap(metadataMap);
        }//end if.



        String keyString =(String) keyPointer.getCons().car();;

        metadataMap.put(keyString, value.getCons());

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(objectPointer.getCons());

        return;

/*
        //Local variable check.
        ConsPointer variablePointer = aEnvironment.getLocalVariable((String) object.car());


        if (variablePointer != null) {
            //Is an unbound local variable.


            //Check to see if the value already has metadata associated with it.
            ConsPointer metadataPointer = variablePointer.getCons().getMetadataMap();
            if (metadataPointer.getCons() == null) {
                //Create new meta data list.

                Cons listCons = SublistCons.getInstance(aEnvironment, AtomCons.getInstance(aEnvironment, "List"));

                ConsPointer listConsPointer = new ConsPointer(listCons);

                variablePointer.getCons().setMetadataMap(listConsPointer);

                getTopOfStackPointer(aEnvironment, aStackTop).setCons(variablePointer.getCons().getMetadataMap().getCons());

                return;

            } else {

                //Return existing meta
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(metadataPointer.getCons());

                return;
            }//end if/else.


        }//end if.





        //Check for global variable.
        variablePointer = new ConsPointer(aEnvironment);
        aEnvironment.getGlobalVariable((String) object.car(), variablePointer);

        if (variablePointer.getCons() != null) {


            //Check to see if the value already has metadata associated with it.
            ConsPointer metadataPointer = variablePointer.getCons().getMetadataMap();
            if (metadataPointer.getCons() == null) {
                //Create new meta data list.

                Cons listCons = SublistCons.getInstance(aEnvironment, AtomCons.getInstance(aEnvironment, "List"));

                ConsPointer listConsPointer = new ConsPointer(listCons);

                variablePointer.getCons().setMetadataMap(listConsPointer);

                getTopOfStackPointer(aEnvironment, aStackTop).setCons(variablePointer.getCons().getMetadataMap().getCons());

                return;

            } else {

                //Return existing meta
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(metadataPointer.getCons());

                return;
            }//end if/else.

        }//end if.




        //If this point has been reached then we are dealing with an unbound variable.
        ConsPointer metaDataPointer = object.getCons().getMetadataMap();

        if (metaDataPointer.getCons() == null) {
            //Create new meta data list.

            Cons listCons = SublistCons.getInstance(aEnvironment, AtomCons.getInstance(aEnvironment, "List"));

            ConsPointer listConsPointer = new ConsPointer(listCons);

            object.getCons().setMetadataMap(listConsPointer);

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(listCons);

        } else {

            //Return existing meta
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(metaDataPointer.getCons());

            return;
        }//end if/else.
 *
 * */

    }//end method.


}//end class.


/*
%mathpiper_docs,name="MetaSet",categories="User Functions;Built In"
 *CMD MetaSet --- set the metadata for a value or an unbound variable
 *CORE
 *CALL
MetaSet(value_or_unbound_variable, key_string, value)

 *PARMS

{value_or_unbound_variable} -- a value or an unbound variable

{key_string} -- a string which will be the key for the given value

{value} -- a value such as a string, symbolic atom, or list

 *DESC

Adds metadata to values and unbound variables.  The metadata is
held in an associative list.  MetaSet returns the given value or unbound variable
as a result after it has had metadata added to it.

*E.G.
In> a := MetaSet(b,"TAG",DATA)
Result: b

In> a
Result: b

In> MetaKeys(a)
Result: {"TAG"}

In> MetaValues(a)
Result: {DATA}

In> MetaGet(a,"TAG")
Result: DATA


In> a := MetaSet(3,"TAG",DATA)
Result: 3

In> a
Result: 3

In> MetaKeys(a)
Result: {"TAG"}

In> MetaValues(a)
Result: {DATA}

In> MetaGet(a,"TAG")
Result: DATA


In>  f(x) := MetaSet(x^2,"TAG",DATA)
Result: True

In> f(x)
Result: x^2

In> MetaKeys(f(x))
Result: {"TAG"}

In> MetaValues(f(x))
Result: {DATA}

In> MetaGet(f(x),"TAG")
Result: DATA


*SEE MetaGet, MetaKeys, MetaValues, Unbind
%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ApplyFast.java0000644000175000017500000000602711523151705030672 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class ApplyFast extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer oper = new ConsPointer();
        oper.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        ConsPointer args = new ConsPointer();
        args.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        LispError.checkArgument(aEnvironment, aStackTop, args.car() instanceof ConsPointer, 2, "ApplyFast");
        LispError.check(aEnvironment, aStackTop, ((ConsPointer) args.car()).getCons() != null, 2);

        // Apply a pure string
        if (oper.car() instanceof String)
        {
            Utility.applyString(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop),
                    (String) oper.car(),
                    ((ConsPointer) args.car()).cdr());
        } else
        {   // Apply a pure function {args,body}.

            ConsPointer args2 = new ConsPointer();
            args2.setCons(((ConsPointer) args.car()).cdr().getCons());
            LispError.checkArgument(aEnvironment, aStackTop, oper.car() instanceof ConsPointer, 1, "ApplyFast");
            LispError.checkArgument(aEnvironment, aStackTop, ((ConsPointer) oper.car()).getCons() != null, 1, "ApplyFast");
            Utility.applyPure(aStackTop, oper, args2, getTopOfStackPointer(aEnvironment, aStackTop), aEnvironment);
        }
    }
}



/*
%mathpiper_docs,name="ApplyFast",categories="User Functions;Functional Operators",access="private"
*CMD ApplyFast --- a fast built-in version of the Apply function
*CALL
	ApplyFast(fn, arglist)

*PARMS

{fn} -- function to apply

{arglist} -- list of arguments

*DESC
This function is a fast built-in version of the Apply function.

*E.G.
In> ApplyFast("+", {5,9});
Result: 14

In> ApplyFast({{x,y}, x-y^2}, {Cos(a), Sin(a)});
Result: Cos(a)-Sin(a)^2

In>  ApplyFast(Lambda({x,y}, x-y^2), {Cos(a), Sin(a)});
Result: Cos(a)-Sin(a)^2

*SEE Apply
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Floor.java0000644000175000017500000000343011506531763030052 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Floor extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.floor(x);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }

}//end class.

/*
%mathpiper_docs,name="FloorN",categories="User Functions;Numeric;Built In"
 *CMD FloorN --- largest integer not larger than x (arbitrary-precision math function)
 *CORE
 *CALL
FloorN(x)

 *DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

 *E.G.
In>
Result>

%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PatchLoad.java0000644000175000017500000000630611506531763030635 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.io.InputStatus;
import org.mathpiper.io.StandardFileInputStream;

/**
 *
 *  
 */
public class PatchLoad extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "PatchLoad");
        String string = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, string != null, 1, "PatchLoad");
        
        String oper = Utility.toNormalString(aEnvironment, aStackTop, string);
        String hashedName = (String) aEnvironment.getTokenHash().lookUp(oper);

        InputStatus oldStatus = new InputStatus(aEnvironment.iInputStatus);
        aEnvironment.iInputStatus.setTo(hashedName);

        StandardFileInputStream newInput = 
            new StandardFileInputStream(oper, aEnvironment.iInputStatus);

        String inputString = new String(newInput.startPtr());

        Utility.doPatchString(inputString, aEnvironment.iCurrentOutput, aEnvironment, aStackTop);

        aEnvironment.iInputStatus.restoreFrom(oldStatus);

        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="PatchLoad",categories="User Functions;Input/Output;Built In"
*CMD PatchLoad --- execute commands between {} in file
*CORE
*CALL
	PatchLoad(name)

*PARMS

{name} -- string, name of the file to "patch"

*DESC

{PatchLoad} loads in a file and outputs the contents to the current
output. The file can contain blocks delimited by {}
(meaning "MathPiper Begin" and "MathPiper End"). The piece of text between
such delimiters is treated as a separate file with MathPiper instructions,
which is then loaded and executed. All output of write statements
in that block will be written to the same current output.

This is similar to the way PHP works. You can have a static text file
with dynamic content generated by MathPiper.

*SEE PatchString, LoadScript
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DebugLine.java0000644000175000017500000000226111226771211030621 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DebugLine extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        throw new Exception("Cannot call DebugLine in non-debug version of MathPiper");
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsInteger.java0000644000175000017500000000464511506531763030673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsInteger extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

//        LispError.check(result.type().equals("Number"), LispError.KLispErrInvalidArg);
        BigNumber num = (BigNumber) result.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        if (num == null)
        {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        } else
        {
            Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), num.isInteger());
        }
    }
}



/*
%mathpiper_docs,name="IsInteger",categories="User Functions;Predicates;Built In"
*CMD IsInteger --- test to see if a number is an integer
*CORE
*CALL
	IsInteger(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is an integer number. There are two kinds
of numbers, integers (e.g. 6) and decimals (e.g. -2.75 or 6.0).
*E.G.

In> IsInteger(6);
Result: True;

In> IsInteger(3.25);
Result: False;

In> IsInteger(1/2);
Result: False;

In> IsInteger(3.2/10);
Result: False;

*SEE IsString, IsAtom, IsInteger, IsDecimal, IsPositiveNumber, IsNegativeNumber, IsNumber
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DestructiveDelete.java0000644000175000017500000000423311523200452032402 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DestructiveDelete extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.delete(aEnvironment, aStackTop, true);
    }
}



/*
%mathpiper_docs,name="DestructiveDelete",categories="User Functions;Lists (Operations);Built In"
*CMD DestructiveDelete --- delete an element destructively from a list
*CORE
*CALL
	DestructiveDelete(list, n)

*PARMS

{list} -- list from which an element should be removed

{n} -- index of the element to remove

*DESC

This is the destructive counterpart of {Delete}. This
command yields the same result as the corresponding call to
{Delete}, but the original list is modified. So if a
variable is bound to "list", it will now be bound to the list with
the n-th entry removed.

Destructive commands run faster than their nondestructive counterparts
because the latter copy the list before they alter it.

*E.G.

In> lst := {a,b,c,d,e,f};
Result: {a,b,c,d,e,f};
In> Delete(lst, 4);
Result: {a,b,c,e,f};
In> lst;
Result: {a,b,c,d,e,f};
In> DestructiveDelete(lst, 4);
Result: {a,b,c,e,f};
In> lst;
Result: {a,b,c,e,f};

*SEE Delete, DestructiveInsert, DestructiveReplace
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefaultDirectory.java0000644000175000017500000000567211523200452032237 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class DefaultDirectory extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "DefaultDirectory");
        String orig =  (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "DefaultDirectory");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);
        aEnvironment.iInputDirectories.add(oper);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}


/*
%mathpiper_docs,name="DefaultDirectory",categories="User Functions;Built In"
*CMD DefaultDirectory --- add directory to path for MathPiper scripts
*CORE
*CALL
	DefaultDirectory(path)

*PARMS

{path} -- a string containing a full path where MathPiper script files reside

*DESC

When loading files, MathPiper is also allowed to
look in the folder "path". {path} will be prepended
to the file name before trying to load the file.
This means that "path" should end with a forward slash (under Unix-like
operating systems).

MathPiper car tries to load a file from the current
directory, and otherwise it tries to load from
directories defined with this function, in the
order they are defined. Note there will be at least one directory
specified at start-up time, defined during compilation. This
is the directory MathPiper searches for the initialization scripts
and standard scripts.

MathPiper allows you to configure a few things at startup. The file
{~/.mathpiperrc} is written in the MathPiper language and
will be executed when MapthPiper is run. This function
can be useful in the {~/.MathPiperrc} file.

*E.G.

In> DefaultDirectory("/home/user/myscripts/");
Result: True;

*SEE Load, Use, DefLoad, FindFile
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MacroRulebase.java0000644000175000017500000000350311445560600031510 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
	public class MacroRulebase extends BuiltinFunction
	{
		public void evaluate(Environment aEnvironment,int aStackTop) throws Exception
		{
			org.mathpiper.lisp.Utility.rulebase(aEnvironment, aStackTop, false);
		}
	}



/*
%mathpiper_docs,name="MacroRulebase",categories="Programmer Functions;Programming;Built In"
*CMD MacroRulebase --- define rules in functions
*CORE
*DESC

This function has the same effect as its non-macro counterpart, except
that its arguments are evaluated before the required action is performed.
This is useful in macro-like procedures or in functions that need to define new
rules based on parameters.

Make sure that the arguments of {Macro}... commands evaluate to expressions that would normally be used in the non-macro version!

*SEE Bind, Unbind, Local, Rulebase, Rule, `, MacroBind, MacroUnbind, MacroLocal, MacroRulebaseListed, MacroRule
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Gcd.java0000644000175000017500000000507711523200452027462 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Gcd extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.gcd(x, y, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="GcdN",categories="User Functions;Numeric;Built In"
*CMD GcdN --- Greatest Common Divisor (arbitrary-precision math function)
*CORE
*CALL
	GcdN(n,m)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ArraySize.java0000644000175000017500000000414211333354275030702 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.Array;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ArraySize extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        BuiltinContainer gen = (BuiltinContainer) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, gen != null, 1, "ArraySize");
        LispError.checkArgument(aEnvironment, aStackTop, gen.typeName().equals("\"Array\""), 1, "ArraySize");
        int size = ((Array) gen).size();
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + size));
    }
}//end class.



/*
%mathpiper_docs,name="ArraySize",categories="Programmer Functions;Native Objects;Built In"
*CMD ArraySize --- get array size
*CORE
*CALL
	ArraySize(array)

*DESC
Returns the size of an array (number of elements in the array).

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/SystemCall.java0000644000175000017500000000610111523200452031032 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import java.io.BufferedReader;
import java.io.InputStreamReader;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class SystemCall extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "SystemCall");
        String orig = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "SystemCall");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);
        String ls_str;
        Process ls_proc = Runtime.getRuntime().exec(oper);
        // getCons its output (your input) stream
        BufferedReader ls_in = new BufferedReader(new InputStreamReader(ls_proc.getInputStream()));

        while ((ls_str = ls_in.readLine()) != null)
        {
            aEnvironment.write(ls_str);
            aEnvironment.write("\n");
        }
    }
}


/*
%mathpiper_docs,name="SystemCall",categories="User Functions;Control Flow;Built In"
*CMD SystemCall --- pass a command to the shell
*CORE
*CALL
	SystemCall(str)

*PARMS

{str} -- string containing the command to call

*DESC

The command contained in the string "str" is executed by the
underlying operating system (OS).
The return value of {SystemCall} is {True} or {False} according to the exit code of the command.

The {SystemCall} function is not allowed in the body of the {Secure} command and will lead to an error.

*E.G. notest

In a UNIX environment, the command {SystemCall("ls")} would print the contents of the current directory.

In> SystemCall("ls")
	AUTHORS
	COPYING
	ChangeLog
... (truncated to save space)
Result: True;

The standard UNIX command {test} returns success or failure depending on conditions.
For example, the following command will check if a directory exists:

In> SystemCall("test -d scripts/")
Result: True;

Check that a file exists:
In> SystemCall("test -f COPYING")
Result: True;
In> SystemCall("test -f nosuchfile.txt")
Result: False;

*SEE Secure
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LeftPrecedenceGet.java0000644000175000017500000000521411523200452032266 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.LispError;

/**
 *
 *  
 */
public class LeftPrecedenceGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iInfixOperators);
        if (op == null)
        {  // infix and postfix operators have left precedence

            op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPostfixOperators);
            LispError.check(aEnvironment, aStackTop, op != null, LispError.IS_NOT_INFIX);
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + op.iLeftPrecedence));
    }
}



/*
%mathpiper_docs,name="LeftPrecedenceGet",categories="Programmer Functions;Programming;Built In"
*CMD LeftPrecedenceGet --- get operator precedence
*CORE
*CALL
	LeftPrecedenceGet("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Returns the precedence of the function named "op" which should have been declared as a bodied function or an infix, postfix, or prefix operator. Generates an error message if the string str does not represent a type of function that can have precedence.

For infix operators, right precedence can differ from left precedence. Bodied functions and prefix operators cannot have left precedence, while postfix operators cannot have right precedence; for these operators, there is only one value of precedence.

*E.G.
In> LeftPrecedenceGet("!")
Result: 0;

*SEE PrecedenceGet,RightPrecedenceGet,LeftPrecedence,RightPrecedenceSet,RightAssociativeSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LispReadListed.java0000644000175000017500000000432011523200452031623 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.parsers.Parser;

/**
 *
 *  
 */
public class LispReadListed extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Parser parser = new Parser(aEnvironment.iCurrentTokenizer,
                aEnvironment.iCurrentInput,
                aEnvironment);
        parser.iListed = true;
        // Read expression
        parser.parse(aStackTop, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="LispReadListed",categories="User Functions;Input/Output;Built In"
*CMD LispReadListed --- read expressions in LISP syntax
*CORE
*CALL
	LispReadListed()

*DESC

The function {LispReadListed} reads a LISP expression and returns
it in a list, instead of the form usual to MathPiper (expressions).
The result can be thought of as applying {FunctionToList} to {LispRead}.
The function {LispReadListed} is more useful for reading arbitrary LISP expressions, because the
first object in a list can be itself a list (this is never the case for MathPiper expressions where the first object in a list is always a function atom).

*E.G. notest

In> PipeFromString("(+ a b)")LispReadListed()
Result: {+,a,b};

*SEE PipeFromFile, PipeFromString, Read, ReadToken, LispForm, LispRead
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ShiftRight.java0000644000175000017500000000347311345636344031055 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class ShiftRight extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber n = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        long nrToShift = n.toLong();
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.shiftRight(x, (int) nrToShift, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper_docs,name="ShiftRight",categories="User Functions;Built In"
*CMD ShiftRight --- built-in bitwise shift right operation
*CORE
*CALL
	ShiftRight(expr,bits)

*DESC

Shift bits to the right.

*SEE ShiftLeft
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ArrayCreate.java0000644000175000017500000000440711333354275031177 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.Array;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ArrayCreate extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer sizearg = new ConsPointer();
        sizearg.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        LispError.checkArgument(aEnvironment, aStackTop, sizearg.getCons() != null, 1, "ArrayCreate");
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.car() instanceof String, 1, "ArrayCreate");

        int size = Integer.parseInt( (String) sizearg.car(), 10);

        ConsPointer initarg = new ConsPointer();
        initarg.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        Array array = new Array(aEnvironment, size, initarg.getCons());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, array));
    }
}//end class.



/*
%mathpiper_docs,name="ArrayCreate",categories="Programmer Functions;Native Objects;Built In"
*CMD ArrayCreate --- create array
*CORE
*CALL
	ArrayCreate(size,init)

*DESC
Creates an array with {size} elements, all initialized to the
value {init}.

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Unbind.java0000644000175000017500000000547411357471613030223 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Unbind extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer) {

            ConsPointer subList = (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList);
            consTraverser.goNext(aStackTop);
            int nr = 1;
            while (consTraverser.getCons() != null)
            {
                String variableName;
                variableName =  (String) consTraverser.car();
                LispError.checkArgument(aEnvironment, aStackTop, variableName != null, nr, "Unbind");
                aEnvironment.unbindVariable(aStackTop, variableName);
                consTraverser.goNext(aStackTop);
                nr++;
            }
        }
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="Unbind",categories="User Functions;Variables;Built In"
*CMD Unbind --- undo an assignment
*CORE
*CALL
	Unbind(var, ...)

*PARMS

{var} -- name of variable to be unbound

*DESC

All assignments made to the variables listed as arguments are
undone. From now on, all these variables remain unevaluated (until a
subsequent assignment is made). Also unbinds any metadata that may have
been set in an unbound variable.  If a * wildcard character is passed in
 as the variable name, all local and global variables are unbound.

*E.G.
In> a := 5;
Result> 5;

In> a^2;
Result> 25;

In> Unbind(a);
Result> True;

In> a^2;
Result> a^2;

In> Unbind(*)
Result> True

*SEE Bind, :=
%/mathpiper_docs
*/


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/JavaCall.java0000644000175000017500000002157011522660430030443 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import java.util.ArrayList;
import java.util.List;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.builtin.javareflection.Invoke;
import org.mathpiper.builtin.javareflection.JavaField;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.NumberCons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *
 */
public class JavaCall extends BuiltinFunction {

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer) {

            ConsPointer subList = (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList);

            //Skip past List type.
            consTraverser.goNext(aStackTop);

            //Obtain the Java object to call.
            Cons argumentCons = consTraverser.getPointer().getCons();

            BuiltinContainer builtinContainer = null;

            if (argumentCons != null) {




                if (argumentCons.car() instanceof String) {
                    String firstArgumentString = (String) argumentCons.car();
                    //Strip leading and trailing quotes.
                    firstArgumentString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop,firstArgumentString);
                    Object clas = Class.forName(firstArgumentString);
                    builtinContainer = new JavaObject(clas);
                } else if (argumentCons.car() instanceof BuiltinContainer) {
                    builtinContainer = (BuiltinContainer) argumentCons.car();
                }//end else.


                if (builtinContainer != null) {


                    consTraverser.goNext(aStackTop);
                    argumentCons = consTraverser.getPointer().getCons();
                    String methodName = (String) argumentCons.car();
                    //Strip leading and trailing quotes.
                    methodName = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, methodName);

                    consTraverser.goNext(aStackTop);

                    ArrayList argumentArrayList = new ArrayList();

                    while (consTraverser.getCons() != null) {
                        argumentCons = consTraverser.getPointer().getCons();

                        Object argument = null;

                        if (argumentCons instanceof NumberCons) {
                            NumberCons numberCons = (NumberCons) argumentCons;
                            BigNumber bigNumber = (BigNumber) numberCons.getNumber(aEnvironment.getPrecision(), aEnvironment);

                            if (bigNumber.isInteger()) {
                                argument = bigNumber.toInt();
                            } else {
                                argument = bigNumber.toDouble();
                            }
                        } else if (argumentCons instanceof AtomCons) {
                            String string = (String) ((AtomCons) argumentCons).car();
                            if (string != null) {

                                if (Utility.isString(string)) { //MathPiper string.
                                    argument = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, (String) string);
                                } else { //Atom.
                                    if (string.equals("True")) {
                                        argument = Boolean.TRUE;
                                    }//end if.

                                    if (string.equals("False")) {
                                        argument = Boolean.FALSE;
                                    }//end if.
                                }//end if/else.

                            }//end if.
                        } else {
                            argument = argumentCons.car();


                            if (argument instanceof JavaObject) {
                                argument = ((JavaObject) argument).getObject();
                            }

                        }//end if/else.


                        argumentArrayList.add(argument);

                        consTraverser.goNext(aStackTop);

                    }//end while.


                    Object[] argumentsArray = (Object[]) argumentArrayList.toArray(new Object[0]);

                    Object targetObject = builtinContainer.getObject();

                    Object returnObject = null;
                            
                    if(targetObject instanceof Class)
                    { 
                        try
                        {
                            returnObject = Invoke.invokeStatic((Class) targetObject, methodName, argumentsArray);
                        }
                        catch(Exception e1)
                        {
                            try
                            {
                                returnObject = JavaField.getField((Class) targetObject, methodName, true).get(null);
                            }
                            catch(Exception e2)
                            {
                                LispError.raiseError("Method or field " + methodName + " does not exist.", "", -2, null);
                            }
                        }
                    }
                    else
                    {
                        returnObject = Invoke.invokeInstance(targetObject, methodName, argumentsArray, true);
                    }

                    if (returnObject instanceof List) {
                        Cons listCons = Utility.iterableToList(aEnvironment, aStackTop, (List) returnObject);

                        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, listCons));
                    } else {
                        JavaObject response = new JavaObject(returnObject);
                        if (response == null || response.getObject() == null) {
                            Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                            return;
                        }
                        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));
                    }


                    return;

                }//end if.

            }//end if.

        }//end if.

        Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));

    }//end method.
}




/*
%mathpiper_docs,name="JavaCall",categories="Programmer Functions;Built In;Native Objects",access="experimental"
*CMD JavaCall --- calls a method on a Java object and returns the result as a Java object
*CALL
    JavaCall(javaObject, methodName, methodParameter1, methodParameter2, ...)

*PARMS
{javaObject} -- a Java object

{methodName} -- the name of a method to call on the Java object (it can be either a string or an atom)

{methodParameters} -- zero or more parameters which will be sent to the method

*DESC
This function calls a method on {javaObject} and returns the result as a Java object.  The returned Java object
can be converted into a MathPiper data structure by passing it to JavaToValue, or in can be passed
to JavaCall or JavaAccess for further processing.

*E.G.
In> javaString := JavaNew("java.lang.String", "Hello")
Result: java.lang.String

In> javaString := JavaCall(javaString, "replace", "e", "o")
Result: java.lang.String

In> JavaToValue(javaString)
Result: Hollo

In> JavaAccess(javaString, "charAt", 0)
Result: H

*SEE JavaNew, JavaAccess, JavaToValue
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CustomEvalResult.java0000644000175000017500000000261611262036106032245 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CustomEvalResult extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : CustomEvalResult");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsNumber.java0000644000175000017500000000504011474666260030521 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsNumber extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), result.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment) != null);
    }
}



/*
%mathpiper_docs,name="IsNumber",categories="User Functions;Predicates;Built In"
*CMD IsNumber --- test for a number
*CORE
*CALL
	IsNumber(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is a number. There are two kinds
of numbers, integers (e.g. 6) and reals (e.g. -2.75 or 6.0). Note that a
complex number is represented by the {Complex}
function, so {IsNumber} will return {False}.  The value {False} will be returned
for all expressions which are lists, but the user should be especially aware of expression
lists which might appear to be numbers, such as those returned by Hold(-1) (see below).
 

*E.G.
In> IsNumber(6);
Result: True;

In> IsNumber(3.25);
Result: True;

In> IsNumber(I);
Result: False;

In> IsNumber(-1)
Result: True

In> LispForm(-1)
Result: -1
Side Effects:
-1

In> Hold(-1)
Result: -1

In> IsNumber(Hold(-1))
Result: False

In> LispForm(Hold(-1))
Result: -1
Side Effects:
(- 1 )

In> IsNumber("duh");
Result: False;

*SEE IsAtom, IsString, IsInteger, IsDecimal, IsPositiveNumber, IsNegativeNumber, Complex
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Insert.java0000644000175000017500000000444411523200452030226 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Insert extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.insert(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="Insert",categories="User Functions;Lists (Operations);Built In"
*CMD Insert --- insert an element into a list
*CORE
*CALL
	Insert(list, n, expr)

*PARMS

{list} -- list in which "expr" should be inserted

{n} -- index at which to insert

{expr} -- expression to insert in "list"

*DESC

The expression "expr" is inserted just before the n-th entry in
"list". The first parameter "list" should be a list, while "n"
should be a positive integer less than or equal to the length of
"list" plus one. The expression "expr" is placed between the
entries in "list" with entries "n-1" and "n". There are two
border line cases: if "n" is 1, the expression "expr" is placed in
front of the list (just as by the {:} operator); if "n"
equals the length of "list" plus one, the expression "expr" is
placed at the end of the list (just as by {Append}). In any
case, the resulting list is returned.

*E.G.

In> Insert({a,b,c,d}, 4, x);
Result: {a,b,c,x,d};
In> Insert({a,b,c,d}, 5, x);
Result: {a,b,c,d,x};
In> Insert({a,b,c,d}, 1, x);
Result: {x,a,b,c,d};

*SEE DestructiveInsert, :, Append, Delete, Remove
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FunctionToList.java0000644000175000017500000000460311523200452031703 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class FunctionToList extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer, 1, "FunctionToList");
        ConsPointer head = new ConsPointer();
        head.setCons(aEnvironment.iListAtom.copy( aEnvironment, false));
        head.cdr().setCons(((ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car()).getCons());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,head.getCons()));
    }
}



/*
%mathpiper_docs,name="FunctionToList",categories="User Functions;Lists (Operations);Built In"
*CMD FunctionToList --- convert a function application to a list
*CORE
*CALL
	FunctionToList(expr)

*PARMS

{expr} -- expression to be converted

*DESC

The parameter "expr" is expected to be a compound object, i.e. not
an atom. It is evaluated and then converted to a list. The car entry
in the list is the top-level operator in the evaluated expression and
the other entries are the arguments to this operator. Finally, the
list is returned.

*E.G.

In> FunctionToList(Cos(x));
Result: {Cos,x};
In> FunctionToList(3*a);
Result: {*,3,a};

*SEE List, ListToFunction, IsAtom
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ToAtom.java0000644000175000017500000000422211523200452030157 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ToAtom extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "ToAtom");
        String orig =  (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "ToAtom");
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpUnStringify(orig)));
    }
}




/*
%mathpiper_docs,name="ToAtom",categories="User Functions;String Manipulation"
*CMD ToAtom --- convert string to atom
*CORE
*CALL
	ToAtom("string")

*PARMS

{"string"} -- a string

*DESC

Returns an atom with the string representation given
as the evaluated argument. Example: {ToAtom("foo");} returns
{foo}.


*E.G.

In> ToAtom("a")
Result: a;

*SEE ToString, ExpressionToString
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LexCompare2.java0000644000175000017500000000726411333354275031122 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.collections.TokenMap;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.NumberCons;

/**
 *
 *  
 */
abstract public class LexCompare2
{

    abstract boolean lexFunction(String f1, String f2, TokenMap aHashTable, int aPrecision);

    abstract boolean numFunction(BigNumber n1, BigNumber n2);

    void Compare(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer argument1 = new ConsPointer();

        ConsPointer argument2 = new ConsPointer();

        argument1.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        argument2.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());


        //LispError.check(argument1.getCons() instanceof NumberCons || argument1.getCons() instanceof AtomCons, "The first argument must be a non-complex decimal number or a string.","LexCompare2");
        //LispError.check(argument2.getCons() instanceof NumberCons || argument2.getCons() instanceof AtomCons, "The second argument must be a non-complex decimal number or a string.","LexCompare2");

        LispError.checkArgumentTypeWithError(aEnvironment, aStackTop, argument1.getCons() instanceof NumberCons || argument1.getCons() instanceof AtomCons, 1, "The first argument must be a non-complex decimal number or a string.","LexCompare2");
        LispError.checkArgumentTypeWithError(aEnvironment, aStackTop, argument2.getCons() instanceof NumberCons || argument2.getCons() instanceof AtomCons, 2, "The second argument must be a non-complex decimal number or a string.","LexCompare2");


        boolean cmp;
        BigNumber n1 = (BigNumber) argument1.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        BigNumber n2 = (BigNumber) argument2.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);

        if (n1 != null && n2 != null)
        {
            cmp = numFunction(n1, n2);
        } else
        {

            String str1;
            String str2;
            str1 =  (String) argument1.car();
            str2 = (String) argument2.car();
            LispError.checkArgument(aEnvironment, aStackTop, str1 != null, 1, "LexCompare2");
            LispError.checkArgument(aEnvironment, aStackTop, str2 != null, 2, "LexCompare2");
            // the getPrecision argument is ignored in "lex" functions
            cmp = lexFunction(str1, str2,
                    aEnvironment.getTokenHash(),
                    aEnvironment.getPrecision());
        }

        Utility.putBooleanInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop), cmp);
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastPower.java0000644000175000017500000000362111333354275030704 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class FastPower extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x, y;
        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        double result = Math.pow(x.toDouble(), y.toDouble());
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(result);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper,name="FastPower",categories="Programmer Functions;Built In"
*CMD FastPower --- double-precision math function
*CORE
*CALL
	FastPower(x,y)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastArcSin

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/StringToUnicode.java0000644000175000017500000000470711506531763032061 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class StringToUnicode extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "StringToUnicode");
        String str = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, str != null, 1, "StringToUnicode");
        LispError.check(str.length() == 3, "The string must be one character long.", "StringToUnicode", aStackTop, aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, str.charAt(0) == '\"', 1, "StringToUnicode");
        LispError.checkArgument(aEnvironment, aStackTop, str.charAt(str.length() - 1) == '\"', 1, "StringToUnicode");

        int unicodeValue = (int) str.charAt(1);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + unicodeValue));
    }
}



/*
%mathpiper_docs,name="StringToUnicode",categories="User Functions;String Manipulation;Built In",access="experimental"
*CMD StringToUnicode --- returns the unicode value of the character in a single character string
*CORE
*CALL
	StringToUnicode(s)

*PARMS
 {s} - a single character string

*DESC
This function returns the unicode value of the character in a single character string.

*E.G.
In> StringToUnicode("A")
Result> 65

%/mathpiper_docs
*/




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Eval.java0000644000175000017500000000421311523200452027643 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 * 
 */
public class Eval extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));
    }
}//end class


/*
%mathpiper_docs,name="Eval",categories="User Functions;Control Flow;Built In"
*CMD Eval --- force evaluation of expression
*CORE
*CALL
	Eval(expr)

*PARMS

{expr} -- expression to evaluate

*DESC

This function explicitly requests an evaluation of the expression
"expr", and returns the result of this evaluation.

*E.G.

In> a := x;
Result: x;
In> x := 5;
Result: 5;
In> a;
Result: x;
In> Eval(a);
Result: 5;

The variable {a} is bound to {x},
and {x} is bound to 5. Hence evaluating {a} will give {x}. Only when an extra
evaluation of {a} is requested, the value 5 is
returned.

Note that the behavior would be different if we had exchanged the
assignments. If the assignment {a := x} were given
while {x} had the value 5, the variable {a} would also get the value 5 because the assignment
operator {:=} evaluates the right-hand side.

*SEE Hold, HoldArgument, :=
%/mathpiper_docs

 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ToString.java0000644000175000017500000000470511422223770030541 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *
 */
public class ToString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "ToString");

        String orig = null;
        if(evaluated.car() instanceof String)
        {
                 orig = (String) evaluated.car();
        }
        else if(evaluated.car() instanceof BuiltinContainer)
        {
            BuiltinContainer container = (BuiltinContainer) evaluated.car();
            orig = container.getObject().toString();
        }

        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "ToString");

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(orig)));
    }
}



/*
%mathpiper_docs,name="ToString",categories="User Functions;String Manipulation;Built In"
*CMD ToString --- convert atom to string
*CORE
*CALL
	ToString(atom)

*PARMS

{atom} -- an atom

*DESC

{ToString} is the inverse of {ToAtom}: turns {atom} into {"atom"}.

*E.G.
In> ToString(a)
Result: "a";

*SEE ToAtom, ExpressionToString
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BitAnd.java0000644000175000017500000000337711345636344030146 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class BitAnd extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.bitAnd(x, y, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="BitAnd",categories="User Functions;Built In"
*CMD BitAnd --- bitwise and operation
*CORE
*CALL
	BitAnd(n,m)


*DESC
This function returns the bitwise "and"
of two numbers.

*SEE BitOr, BitXor

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FindFunction.java0000644000175000017500000000701011523200452031340 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.rulebases.MultipleArityRulebase;

/**
 *
 *  
 */
public class FindFunction extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);

        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "FindFunction");
        String orig =  (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "FindFunction");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        MultipleArityRulebase multiUserFunc = aEnvironment.getMultipleArityRulebase(aStackTop, (String)aEnvironment.getTokenHash().lookUp(oper), false);

        String fileLocation =  "\"\"" ;
        
        if (multiUserFunc != null )
        {
            /*DefFile def = multiUserFunc.iFileToOpen;
            if (def != null)
            {
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, def.iFileName));
                return;
            }*/
            if(multiUserFunc.iFileLocation != null)
            {
                fileLocation = multiUserFunc.iFileLocation;
            }
            else
            {
               fileLocation = "Function is defined, but it has no body.";
            }

        }//end if

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, fileLocation));
    }//end method

}//end class.



/*
%mathpiper_docs,name="FindFunction",categories="User Functions;Built In"
*CMD FindFunction --- find the library file where a function is defined
*CORE
*CALL
	FindFunction(function)

*PARMS

{function} -- string, the name of a function

*DESC

This function is useful for quickly finding the file where a standard library
function is defined. It is likely to only be useful for developers. The
function {FindFunction} scans the {.def} files that were loaded at start-up.
This means that functions that are not listed in {.def} files will not be found with {FindFunction}.

*E.G.

In> FindFunction("Sum")
Result: "sums.rep/code.ys";
In> FindFunction("Integrate")
Result: "integrate.rep/code.ys";

*SEE Vi
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Or.java0000644000175000017500000001055011523200452027335 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class Or extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer nogos = new ConsPointer();
        int nrnogos = 0;

        ConsPointer evaluated = new ConsPointer();

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null)
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, consTraverser.getPointer());
            if (Utility.isTrue(aEnvironment, evaluated, aStackTop))
            {
                Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                return;
            } else if (!Utility.isFalse(aEnvironment, evaluated, aStackTop))
            {
                ConsPointer ptr = new ConsPointer();
                nrnogos++;

                ptr.setCons(evaluated.getCons().copy( aEnvironment, false));
                ptr.cdr().setCons(nogos.getCons());
                nogos.setCons(ptr.getCons());
            }
            consTraverser.goNext(aStackTop);
        }

        if (nogos.getCons() != null)
        {
            if (nrnogos == 1)
            {
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(nogos.getCons());
            } else
            {
                ConsPointer ptr = new ConsPointer();

                Utility.reverseList(aEnvironment, ptr, nogos);
                nogos.setCons(ptr.getCons());

                ptr.setCons(getArgumentPointer(aEnvironment, aStackTop, 0).getCons().copy( aEnvironment, false));
                ptr.cdr().setCons(nogos.getCons());
                nogos.setCons(ptr.getCons());
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,nogos.getCons()));
            }
        //aEnvironment.CurrentPrinter().Print(getTopOfStackPointer(aEnvironment, aStackTop), *aEnvironment.CurrentOutput());
        } else
        {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }
    }
}



/*
%mathpiper_docs,name="Or",categories="User Functions;Predicates;Built In"
*CMD Or --- logical disjunction
*CORE
*CALL
	a1 Or a2
Precedence:
*EVAL PrecedenceGet("Or")
	Or(a1, a2, a3, ..., aN)

*PARMS

{a}1, ..., {a}N -- boolean expressions (may evaluate to {True} or {False})

*DESC

This function returns {True} if an argument is encountered
that is true (scanning from left to right). The
{Or} operation is "lazy", i.e. it returns {True} as soon as a {True} argument
is found (from left to right). If an argument other than {True} or
{False} is encountered, an unevaluated {Or} expression is returned with all
arguments that didn't evaluate to {True} or {False} yet.
 {And(...)} and {Or(...)} do also exist, defined in the script
library. You can redefine them as infix operators yourself, so you have the
choice of precedence. In the standard scripts they are in fact declared as
infix operators, so you can write {expr1 And expr}.

*E.G.

In> True Or False
Result: True;
In> False Or a
Result: Or(a);
In> Or(False,a,b,True)
Result: True;

*SEE And, Not
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsList.java0000644000175000017500000000347411523200452030173 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsList extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), Utility.isSublist(result));
    }
}



/*
%mathpiper_docs,name="IsList",categories="User Functions;Predicates;Built In"
*CMD IsList --- test for a list
*CORE
*CALL
	IsList(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is a list. A list is a sequence
between curly braces, e.g. {{2, 3, 5}}.

*E.G.

In> IsList({2,3,5});
Result: True;
In> IsList(2+3+5);
Result: False;

*SEE IsFunction
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsFunction.java0000644000175000017500000000370311523200452031040 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsFunction extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop),
                result.car() instanceof ConsPointer);
    }
}



/*
%mathpiper_docs,name="IsFunction",categories="User Functions;Predicates;Built In"
*CMD IsFunction --- test for a composite object
*CORE
*CALL
	IsFunction(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is a composite object, i.e. not an
atom. This includes not only obvious functions such as {f(x)}, but also expressions such as {x+5} and lists.

*E.G.

In> IsFunction(x+5);
Result: True;
In> IsFunction(x);
Result: False;

*SEE IsAtom, IsList, Type
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/SetExactBits.java0000644000175000017500000000574711523200452031333 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class SetExactBits extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(x);

        // do nothing for integers
        if (!(z.isInteger()))
        {
            z.setPrecision((int) (Utility.bitsToDigits((long) (y.toDouble()), 10)));
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}



/*
%mathpiper_docs,name="SetExactBitsN",categories="Programmer Functions;Numerical (Arbitrary Precision);Built In"
*CMD SetExactBitsN --- manipulate precision of floating-point numbers
*CORE
*CALL
	SetExactBitsN(x,bits)

*PARMS
{x} -- an expression evaluating to a floating-point number

{bits} -- integer, number of bits

*DESC
Each floating-point number in MathPiper has an internal precision counter that stores the number of exact bits in the mantissa.
The number of exact bits is automatically updated after each arithmetic operation to reflect the gain or loss of precision due to round-off.
The function {SetExactBitsN} sets the precision flags of individual number objects.

This function is only meaningful for floating-point numbers.
(All integers are always exact.)
For integer {x}, the function {SetExactBitsN} returns the unmodified integer {x}.

*REM FIXME - these examples currently do not work because of bugs

*E.G.
The default precision of 10 decimals corresponds to 33 bits:
In> GetExactBitsN(1000.123)
Result: 33;
In> x:=SetExactBitsN(10., 20)
Result: 10.;
In> GetExactBitsN(x)
Result: 20;
Prepare a "floating zero" representing an interval [-4, 4]:
In> x:=SetExactBitsN(0., -2)
Result: 0.;
In> x=0
Result: True;

*SEE BuiltinPrecisionSet, BuiltinPrecisionGet, GetExactBitsN
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RulePattern.java0000644000175000017500000000323711500331432031224 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class RulePattern extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.newRule(aEnvironment, aStackTop, true);
    }
}




/*
%mathpiper_docs,name="RulePattern",categories="Programmer Functions;Programming;Built In"
*CMD RulePattern --- defines a rule which uses a pattern as its predicate
 
*CALL
	RulePattern("operator", arity, precedence, pattern) body
*PARMS

{"operator"} -- string, name of function

{arity}, {precedence} -- integers

{pattern} -- a pattern object

{body} -- expression, body of rule

*DESC
This function defines a rule which uses a pattern as its predicate.

*SEE MacroRulePattern
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefLoadFunction.java0000644000175000017500000000454311502266107031774 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.DefFile;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.rulebases.MultipleArityRulebase;

/**
 *
 *  
 */
public class DefLoadFunction extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer namePointer = new ConsPointer();
        namePointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        String orig = (String)  namePointer.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "DefLoadFunction");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        MultipleArityRulebase multiUserFunction =
                aEnvironment.getMultipleArityRulebase(aStackTop, (String)aEnvironment.getTokenHash().lookUp(oper), true);
        if (multiUserFunction != null)
        {
            if (multiUserFunction.iFileToOpen != null)
            {
                DefFile def = multiUserFunction.iFileToOpen;
                if (!def.iIsLoaded)
                {
                    multiUserFunction.iFileToOpen = null;
                    Utility.loadScriptOnce(aEnvironment, aStackTop, def.iFileName);
                }//end if.
            }//end if.
        }//end if.
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MaxEvalDepth.java0000644000175000017500000000715211523200452031303 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class MaxEvalDepth extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer index = new ConsPointer();
        index.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 1, "MaxEvalDepth");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 1, "MaxEvalDepth");

        int ind = Integer.parseInt( (String) index.car(), 10);
        aEnvironment.iMaxEvalDepth = ind;
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}

/*
%mathpiper_docs,name="MaxEvalDepth",categories="User Functions;Control Flow;Built In"
*CMD MaxEvalDepth --- set the maximum evaluation depth
*CORE
*CALL
	MaxEvalDepth(n)

*PARMS

{n} -- new maximum evaluation depth

*DESC

Use this command to set the maximum evaluation depth to the integer
"n". The default value is 1000. The function {MaxEvalDepth} returns {True}.

The point of having a maximum evaluation depth is to catch any
infinite recursion. For example, after the definition {f(x) := f(x)}, evaluating the expression {f(x)} would call {f(x)}, which would
call {f(x)}, etc. The interpreter will halt if
the maximum evaluation depth is reached and an error message will be printed. Also indirect recursion, e.g.
the pair of definitions {f(x) := g(x)} and {g(x) := f(x)}, will be caught.

*E.G. notest

An example of an infinite recursion, caught because the maximum
evaluation depth is reached.

In> f(x) := f(x)
Result: True;
In> f(x)
	Error on line 1 in file [CommandLine]
	Max evaluation stack depth reached.
	Please use MaxEvalDepth to increase the stack
	size as needed.

However, a long calculation may cause the maximum evaluation depth to
be reached without the presence of infinite recursion. The function {MaxEvalDepth} is meant for these cases.

In> 10 # g(0) <-- 1;
Result: True;
In> 20 # g(n_IsPositiveInteger) <-- \
	  2 * g(n-1);
Result: True;
In> g(1001);
	Error on line 1 in file [CommandLine]
	Max evaluation stack depth reached.
	Please use MaxEvalDepth to increase the stack
	size as needed.

In> MaxEvalDepth(10000);
Result: True;
In> g(1001);
Result: 21430172143725346418968500981200036211228096234
	1106721488750077674070210224987224498639675763139171
	6255189345835106293650374290571384628087196915514939
	7149607869135549648461970842149210124742283755908364
	3060929499671638825347975351183310878921541258291423
	92955373084335320859663305248773674411336138752;
%/mathpiper_docs
 */mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastArcCos.java0000644000175000017500000000406311506531763030764 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class FastArcCos extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;

        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.acos(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The argument must have a value between -1 and 1.", "FastArcCos", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastArcCos",categories="Programmer Functions;Built In"
*CMD FastArcCos --- double-precision math function
*CORE
*CALL
	FastArcCos(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Rule.java0000644000175000017500000000404011522464622027673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Rule extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.newRule(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="Rule",categories="Programmer Functions;Programming;Built In"
*CMD Rule --- define a rewrite rule
*CORE
*CALL
	Rule("operator", arity, precedence, predicate) body
*PARMS

{"operator"} -- string, name of function

{arity}, {precedence} -- integers

{predicate} -- function returning boolean

{body} -- expression, body of rule

*DESC

Define a rule for the function "operator" with
"arity", "precedence", "predicate" and
"body". The "precedence" goes from low to high: rules with low precedence will be applied first.

The arity for a rules database equals the number of arguments. Different
rules databases can be built for functions with the same name but with
a different number of arguments.

Rules with a low precedence value will be tried before rules with a high value, so
a rule with precedence 0 will be tried before a rule with precedence 1.
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PatternMatches.java0000644000175000017500000000536211333354275031720 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.PatternContainer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class PatternMatches extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer pattern = new ConsPointer();
        pattern.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        BuiltinContainer gen = (BuiltinContainer) pattern.car();
        LispError.checkArgument(aEnvironment, aStackTop, gen != null, 1, "PatternMatches");
        LispError.checkArgument(aEnvironment, aStackTop, gen.typeName().equals("\"Pattern\""), 1, "PatternMatches");

        ConsPointer list = new ConsPointer();
        list.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        PatternContainer patclass = (PatternContainer) gen;

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, list);
        LispError.checkArgument(aEnvironment, aStackTop, consTraverser.getCons() != null, 2, "PatternMatches");
        LispError.checkArgument(aEnvironment, aStackTop, consTraverser.car() instanceof ConsPointer, 2, "PatternMatches");
        consTraverser.goSub(aStackTop);
        LispError.checkArgument(aEnvironment, aStackTop, consTraverser.getCons() != null, 2, "PatternMatches");
        consTraverser.goNext(aStackTop);

        ConsPointer ptr = consTraverser.getPointer();
        LispError.checkArgument(aEnvironment, aStackTop, ptr != null, 2, "PatternMatches");
        boolean matches = patclass.matches(aEnvironment, aStackTop, ptr);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), matches);
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/TellUser.java0000644000175000017500000000461711506531763030540 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import javax.swing.JOptionPane;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class TellUser extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "TellUser");

        Object argument = getArgumentPointer(aEnvironment, aStackTop, 1).car();

        LispError.check(argument instanceof String, "The argument to TellUser must be a string.", "INTERNAL", aStackTop, aEnvironment);

        String messageString = (String) argument;

        LispError.checkArgument(aEnvironment, aStackTop, messageString != null, 1, "TellUser");

        messageString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, messageString);

        JOptionPane.showMessageDialog(null, messageString, "Message from MathPiper", JOptionPane.INFORMATION_MESSAGE);

        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }//end method.

}//end class.



/*
%mathpiper_docs,name="TellUser",categories="User Functions;Input/Output;Built In"
*CMD AskUser --- displays a message to the user in a dialog.
*CORE
*CALL
	TellUser(message)

*PARMS

{message} -- a message to display to the user

*DESC

This function allows a message to be displayed to the user.  The message will be
displayed in a GUI dialog box.

*SEE AskUser
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ExpressionToString.java0000644000175000017500000000430711506531763032626 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


/**
 *
 *
 */
public class ExpressionToString extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "ExpressionToString");



        String expressionString = Utility.printMathPiperExpression(aStackTop, evaluated, aEnvironment, 0);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"" + expressionString + "\""));


    }//end method.


}//end class.



/*
%mathpiper_docs,name="ExpressionToString",categories="User Functions;String Manipulation;Built In"
*CMD ExpressionToString --- convert an expression to a string
*CORE
*CALL
	ExpressionToString(expression)

*PARMS

{expression} -- a MathPiper expression

*DESC

This function converts a MathPiper expression into string form.

*E.G.

In> ExpressionToString(x^2)
Result> "x^2"

*SEE Atom, String
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FromBase.java0000644000175000017500000000736111523200452030461 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class FromBase extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get the base to convert to:
        // Evaluate car argument, and store getTopOfStackPointer in oper
        ConsPointer oper = new ConsPointer();
        oper.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        // check that getTopOfStackPointer is a number, and that it is in fact an integer
//        LispError.check(oper.type().equals("Number"), LispError.KLispErrInvalidArg);
        BigNumber num = (BigNumber)  oper.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, num != null, 1, "FromBase");
        // check that the base is an integer between 2 and 32
        LispError.checkArgument(aEnvironment, aStackTop, num.isInteger(), 1, "FromBase");

        // Get a short platform integer from the car argument
        int base = (int) (num.toDouble());

        // Get the number to convert
        ConsPointer fromNum = new ConsPointer();
        fromNum.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        String str2;
        str2 =  (String) fromNum.car();
        LispError.checkArgument(aEnvironment, aStackTop, str2 != null, 2, "FromBase");

        // Added, unquote a string
        LispError.checkArgument(aEnvironment, aStackTop, Utility.isString(str2), 2, "FromBase");
        str2 = aEnvironment.getTokenHash().lookUpUnStringify(str2);

        // convert using correct base
        BigNumber z = new BigNumber(str2, aEnvironment.getPrecision(), base);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}

/*
%mathpiper_docs,name="FromBase",categories="User Functions;Numbers (Operations);Built In"
*CMD FromBase --- conversion of a number from non-decimal base to decimal base
*CORE
*CALL
	FromBase(base,"string")

*PARMS

{base} -- integer, base to convert to/from

{number} -- integer, number to write out in a different base

{"string"} -- string representing a number in a different base

*DESC

In MathPiper, all numbers are written in decimal notation (base 10).


{FromBase} converts an integer, written as a string in base
{base}, to base 10. {ToBase} converts {number},
written in base 10, to base {base}.

*REM where is this p-adic capability? - sw
These functions use the p-adic expansion capabilities of the built-in
arbitrary precision math libraries.

Non-integer arguments are not supported.

*E.G.

Write the binary number {111111} as a decimal number:

In> FromBase(2,"111111")
Result: 63;


*SEE PAdicExpand,ToBase
%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Set.java0000644000175000017500000000575211417517007027531 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

/**
 * Used to create sets like List() is used to create lists.
 *
 */
public class Set extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer allPointer = new ConsPointer();
        allPointer.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
        ConsTraverser tail = new ConsTraverser(aEnvironment, allPointer);
        tail.goNext(aStackTop);
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null) {
            ConsPointer evaluated = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, consTraverser.getPointer());
            tail.getPointer().setCons(evaluated.getCons());
            tail.goNext(aStackTop);
            consTraverser.goNext(aStackTop);
        }


        Cons head = SublistCons.getInstance(aEnvironment, AtomCons.getInstance(aEnvironment, aStackTop, "RemoveDuplicates"));

        ((ConsPointer) head.car()).cdr().setCons(SublistCons.getInstance(aEnvironment, allPointer.getCons()));

        ConsPointer removeDuplicatesResultPointer = new ConsPointer();

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, removeDuplicatesResultPointer, new ConsPointer(head));
        
        ConsPointer resultPointer = new ConsPointer();

        resultPointer.setCons(aEnvironment.iSetAtom.copy(aEnvironment, false));

        removeDuplicatesResultPointer.goSub(aStackTop, aEnvironment);

        resultPointer.getCons().cdr().setCons(removeDuplicatesResultPointer.cdr().getCons());

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,resultPointer.getCons()));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BuiltinAssoc.java0000644000175000017500000000450511333354275031373 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;


/**
 *
 *  
 */
public class BuiltinAssoc extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        // key to find
        ConsPointer key = new ConsPointer();
        key.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // assoc-list to find it in
        ConsPointer list = new ConsPointer();
        list.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        Cons listCons;

        //check that it is a compound object
        LispError.checkArgument(aEnvironment, aStackTop, list.car() instanceof ConsPointer, 2, "BuiltinAssoc");
        listCons = ((ConsPointer) list.car()).getCons();
        LispError.checkArgument(aEnvironment, aStackTop, listCons != null, 2, "BuiltinAssoc");
        listCons = listCons.cdr().getCons();

        Cons result = Utility.associativeListGet(aEnvironment, aStackTop, key, listCons);

        if (result != null) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(result);

        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "Empty"));
        }


    }//end method.


}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ConcatenateStrings.java0000644000175000017500000000522711523200452032560 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ConcatenateStrings extends BuiltinFunction
{

    void ConcatenateStrings(StringBuffer aStringBuffer, Environment aEnvironment, int aStackTop) throws Exception
    {
        aStringBuffer.append('\"');
        int arg = 1;

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car() );
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null)
        {
            LispError.checkIsString(aEnvironment, aStackTop, consTraverser.getPointer(), arg, "ConcatenateStrings");
            String thisString =  (String) consTraverser.car();
            String toAppend = thisString.substring(1, thisString.length() - 1);
            aStringBuffer.append(toAppend);
            consTraverser.goNext(aStackTop);
            arg++;
        }
        aStringBuffer.append('\"');
    }

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        StringBuffer strBuffer = new StringBuffer("");
        ConcatenateStrings(strBuffer, aEnvironment, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, strBuffer.toString()));
    }
}




/*
%mathpiper_docs,name="ConcatStrings",categories="User Functions;String Manipulation;Built In"
*CMD ConcatStrings --- concatenate strings
*CORE
*CALL
	ConcatStrings(strings)

*PARMS

{strings} -- one or more strings

*DESC

Concatenates strings.

*E.G.

In> ConcatStrings("a","b","c")
Result: "abc";

*SEE :
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RulebaseListed.java0000644000175000017500000000647511523200452031677 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class RulebaseListed extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.rulebase(aEnvironment, aStackTop, true);
    }
}



/*
%mathpiper_docs,name="RulebaseListed",categories="Programmer Functions;Programming;Built In"
*CMD RulebaseListed --- define function with variable number of arguments
*CORE
*CALL
	RulebaseListed("name", params)

*PARMS

{"name"} -- string, name of function

{params} -- list of arguments to function

*DESC

The command {RulebaseListed} defines a new function. It essentially works the
same way as {Rulebase}, except that it declares a new function with a variable
number of arguments. The list of parameters {params} determines the smallest
number of arguments that the new function will accept. If the number of
arguments passed to the new function is larger than the number of parameters in
{params}, then the last argument actually passed to the new function will be a
list containing all the remaining arguments.

A function defined using {RulebaseListed} will appear to have the arity equal
to the number of parameters in the {param} list, and it can accept any number
of arguments greater or equal than that. As a consequence, it will be impossible to define a new function with the same name and with a greater arity.

The function body will know that the function is passed more arguments than the
length of the {param} list, because the last argument will then be a list. The
rest then works like a {Rulebase}-defined function with a fixed number of
arguments. Transformation rules can be defined for the new function as usual.


*E.G.

The definitions

	RulebaseListed("f",{a,b,c})
	10 # f(_a,_b,{_c,_d}) <--
	  Echo({"four args",a,b,c,d});
	20 # f(_a,_b,c_IsList) <--
	  Echo({"more than four args",a,b,c});
	30 # f(_a,_b,_c) <-- Echo({"three args",a,b,c});
give the following interaction:

In> f(A)
Result: f(A);
In> f(A,B)
Result: f(A,B);
In> f(A,B,C)
	three args A B C
Result: True;
In> f(A,B,C,D)
	four args A B C D
Result: True;
In> f(A,B,C,D,E)
	more than four args A B {C,D,E}
Result: True;
In> f(A,B,C,D,E,E)
	more than four args A B {C,D,E,E}
Result: True;

The function {f} now appears to occupy all arities greater than 3:

In> Rulebase("f", {x,y,z,t});
	CommandLine(1) : Rule base with this arity
	  already defined


*SEE Rulebase, Retract, Echo
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/InDebugMode.java0000644000175000017500000000233611226771211031110 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class InDebugMode extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Time.java0000644000175000017500000000532011523200452027652 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import java.math.BigDecimal;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.printers.MathPiperPrinter;

/**
 *
 *  
 */
public class Time extends BuiltinFunction
{

     private Time()
    {
    }

    public Time(Environment aEnvironment)
    {
        aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "Time");
    }//end constructor.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigDecimal startTime = new BigDecimal(System.nanoTime());

        ConsPointer res = new ConsPointer();

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, res, getArgumentPointer(aEnvironment, aStackTop, 1));

        BigDecimal endTime = new BigDecimal(System.nanoTime());

        BigDecimal timeDiff;

        timeDiff = endTime.subtract(startTime);

        timeDiff = timeDiff.movePointLeft(9);
        
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + timeDiff));
    }
}



/*
%mathpiper_docs,name="Time",categories="User Functions;Built In;Input/Output"
*CMD Time --- measure the time taken by an evaluation
*CORE
*CALL
	Time() expr
*PARMS
{expr} -- any expression
*DESC
The function {Time() expr} evaluates the expression {expr} and returns the time needed for the evaluation.
The result is returned as a floating-point number of seconds.
The value of the expression {expr} is lost.

The result is the "user time" as reported by the OS, not the real ("wall clock") time.
Therefore, any CPU-intensive processes running alongside MathPiper will not significantly affect the result of {Time}.

*E.G.
In> Time() Simplify((a*b)/(b*a))
Result: 0.09;

*SEE EchoTime, SystemTimer

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/SystemTimer.java0000644000175000017500000000325111332771351031253 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *
 */
public class SystemTimer extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        long currentTime = System.nanoTime();

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + currentTime));
    }//end method.

}//end class.



/*
%mathpiper_docs,name="SystemTimer",categories="User Functions;Built In;Input/Output"
*CMD SystemTimer --- return the current time in nanoseconds
*CORE
*CALL
	SystemTimer()

*DESC
This function returns the current value of the system timer in nanoseconds.

*E.G.
In> SystemTimer()
Result: 1624308347733;

*SEE Time, EchoTime

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LoadScript.java0000644000175000017500000000446411340055520031031 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class LoadScript extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);

        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "LoadScript");
        String orig = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "LoadScript");

        Utility.loadScript(aEnvironment, aStackTop, orig);
        
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
         
    }
}



/*
%mathpiper_docs,name="LoadScript",categories="User Functions;Input/Output;Built In"
*CMD LoadScript --- evaluate all expressions in a script file
*CORE
*CALL
	LoadScript(name)

*PARMS

{name} -- string, name of the script file to load

*DESC

The file "name" is opened. All expressions in the file are read and
evaluated. {LoadScript} always returns {true}.

*SEE LoadScriptOnce, DefLoad, DefaultDirectory, FindFile
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FileSize.java0000644000175000017500000000512511502266107030477 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.InputStatus;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class FileSize extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer fnameObject = new ConsPointer();
        fnameObject.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, fnameObject, 1, "FileSize");
        String fname = Utility.toNormalString(aEnvironment, aStackTop, (String) fnameObject.car());
        String hashedname = (String) aEnvironment.getTokenHash().lookUp(fname);

        long fileSize = 0;
        InputStatus oldstatus = new InputStatus(aEnvironment.iInputStatus);
        aEnvironment.iInputStatus.setTo(hashedname);
        try
        {
            // Open file
            MathPiperInputStream newInput = // new StdFileInput(hashedname, aEnvironment.iInputStatus);
                    Utility.openInputFile(aEnvironment, aEnvironment.iInputDirectories, hashedname, aEnvironment.iInputStatus);

            LispError.check(aEnvironment, aStackTop, newInput != null, LispError.FILE_NOT_FOUND, "FileSize");
            fileSize = newInput.startPtr().length();
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iInputStatus.restoreFrom(oldstatus);
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + fileSize));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsAtom.java0000644000175000017500000000350111523200452030147 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsAtom extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), result.car() instanceof String);
    }
}



/*
%mathpiper_docs,name="IsAtom",categories="User Functions;Predicates;Built In"
*CMD IsAtom --- test for an atom
*CORE
*CALL
	IsAtom(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is an atom. Numbers, strings, and
variables are all atoms.

*E.G.

In> IsAtom(x+5);
Result: False;
In> IsAtom(5);
Result: True;

*SEE IsFunction, IsNumber, IsString
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/XmlTokenizer.java0000644000175000017500000000644011523200452031413 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class XmlTokenizer extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.iCurrentTokenizer = aEnvironment.iXmlTokenizer;
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="XmlTokenizer",categories="User Functions;Input/Output;Built In"
*CMD XmlTokenizer --- select an XML syntax tokenizer for parsing the input
*CORE
*CALL
	XmlTokenizer()

*DESC

A "tokenizer" is an internal routine in the kernel that parses the input into MathPiper expressions.
This affects all input typed in by a user at the prompt and also the input redirected from files or strings using {PipeFromFile} and {FromString} and read using {Read} or {ReadToken}.

The MathPiper environment currently supports some experimental tokenizers for
various syntaxes. {XmlTokenizer} switches to an XML syntax.
Note that setting the tokenizer is a global side effect.
One typically needs
to switch back to the default tokenizer when finished reading the special syntax.

Care needs to be taken when kernel errors are raised during a non-default tokenizer operation (as with any global change in the environment).
Errors need to be
caught with the {TrapError} function. The error handler code should re-instate
the default tokenizer,
or else the user will be unable to continue the session
(everything a user types will be parsed using a non-default tokenizer).

When reading XML syntax, the supported formats are the same as those of {XmlExplodeTag}.
The parser does not validate anything in the XML input.
After an XML token has been read in, it can be converted into an
MathPiper expression with {XmlExplodeTag}.
Note that when reading XML, any plain text between tags is returned as one token.
Any malformed XML will be treated as plain text.


*E.G. notest

In> [XmlTokenizer(); q:=ReadToken(); \
	  DefaultTokenizer();q;]
	Result: ;

Note that:
*	1. after switching to {XmlTokenizer} the {In>} prompt disappeared; the user typed {} and the {Result:} prompt with the resulting expression appeared.
*	2. The resulting expression is an atom with the string representation {};
it is not a string.

*SEE OMRead, TrapError, XmlExplodeTag, ReadToken, PipeFromFile, FromString, DefaultTokenizer
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Multiply.java0000644000175000017500000000514111523200452030574 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Multiply extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.multiply(x, y, aEnvironment.getPrecision());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="MultiplyN",categories="User Functions;Numeric;Built In"
*CMD MultiplyN --- multiply two numbers (arbitrary-precision math function)
*CORE
*CALL
	MultiplyN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RulebaseArgumentsList.java0000644000175000017500000000624311520672140033251 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.lisp.rulebases.SingleArityRulebase;

/**
 *
 *  
 */
public class RulebaseArgumentsList extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer name = new ConsPointer();
        name.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        String orig = (String) name.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "RulebaseArgumentsList");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        ConsPointer sizearg = new ConsPointer();
        sizearg.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.getCons() != null, 2, "RulebaseArgumentsList");
        LispError.checkArgument(aEnvironment, aStackTop, sizearg.car() instanceof String, 2, "RulebaseArgumentsList");

        int arity = Integer.parseInt( (String) sizearg.car(), 10);

        SingleArityRulebase userFunc = aEnvironment.getRulebase((String)aEnvironment.getTokenHash().lookUp(oper), arity, aStackTop);
        
        LispError.check(userFunc != null, "User function for this arity is not defined.", "RulebaseArgumentsList", aStackTop, aEnvironment);

        ConsPointer list = userFunc.argList();
        ConsPointer head = new ConsPointer();
        head.setCons(aEnvironment.iListAtom.copy( aEnvironment, false));
        head.cdr().setCons(list.getCons());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,head.getCons()));
    }
}



/*
%mathpiper_docs,name="RulebaseArgumentsList",categories="Programmer Functions;Programming;Built In"
*CMD RulebaseArgumentsList --- obtain list of arguments
*CORE
*CALL
	RulebaseArgumentsList("operator", arity)

*PARMS
{"operator"} -- string, name of function

{arity} -- integer

*DESC

Returns a list of atoms, symbolic parameters specified in the {Rulebase} call
for the function named {"operator"} with the specific {arity}.

*SEE Rulebase, HoldArgumentNumber, HoldArgument
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/XmlExplodeTag.java0000644000175000017500000001460511523200452031477 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;

/**
 *
 *  
 */
public class XmlExplodeTag extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer out = new ConsPointer();
        out.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, out, 1, "XmlExplodeTag");

        String str = (String) out.car();
        int strInd = 0;
        strInd++;
        if (str.charAt(strInd) != '<')
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(out.getCons());
            return;
        }
        LispError.checkArgument(aEnvironment, aStackTop, str.charAt(strInd) == '<', 1, "XmlExplodeTag");
        strInd++;
        String type = "\"Open\"";

        if (str.charAt(strInd) == '/')
        {
            type = "\"Close\"";
            strInd++;
        }
        String tag = new String();

        tag = tag + "\"";
        while (MathPiperTokenizer.isAlpha(str.charAt(strInd)))
        {
            char c = str.charAt(strInd);
            strInd++;
            if (c >= 'a' && c <= 'z')
            {
                c = (char) (c + ('A' - 'a'));
            }
            tag = tag + c;
        }
        tag = tag + "\"";

        Cons info = null;

        while (str.charAt(strInd) == ' ')
        {
            strInd++;
        }
        while (str.charAt(strInd) != '>' && str.charAt(strInd) != '/')
        {
            String name = new String();
            name = name + "\"";

            while (MathPiperTokenizer.isAlpha(str.charAt(strInd)))
            {
                char c = str.charAt(strInd);
                strInd++;
                if (c >= 'a' && c <= 'z')
                {
                    c = (char) (c + ('A' - 'a'));
                }
                name = name + c;
            }
            name = name + "\"";
            LispError.checkArgument(aEnvironment, aStackTop, str.charAt(strInd) == '=', 1, "XmlExplodeTag");
            strInd++;
            LispError.checkArgument(aEnvironment, aStackTop, str.charAt(strInd) == '\"', 1, "XmlExplodeTag");
            String value = new String();

            value = value + (str.charAt(strInd));
            strInd++;
            while (str.charAt(strInd) != '\"')
            {
                value = value + (str.charAt(strInd));
                strInd++;
            }
            value = value + (str.charAt(strInd));
            strInd++;

            //printf("[%s], [%s]\n",name.String(),value.String());
            {
                Cons ls = AtomCons.getInstance(aEnvironment, aStackTop, "List");
                Cons nm = AtomCons.getInstance(aEnvironment, aStackTop, name);
                Cons vl = AtomCons.getInstance(aEnvironment, aStackTop, value);
                nm.cdr().setCons(vl);
                ls.cdr().setCons(nm);
                Cons newinfo = SublistCons.getInstance(aEnvironment, ls);
                newinfo.cdr().setCons(info);
                info = newinfo;
            }
            while (str.charAt(strInd) == ' ')
            {
                strInd++;

            //printf("End is %c\n",str[0]);
            }
        }
        if (str.charAt(strInd) == '/')
        {
            type = "\"OpenClose\"";
            strInd++;
            while (str.charAt(strInd) == ' ')
            {
                strInd++;
            }
        }
        {
            Cons ls = AtomCons.getInstance(aEnvironment, aStackTop, "List");
            ls.cdr().setCons(info);
            info = SublistCons.getInstance(aEnvironment, ls);
        }

        Cons xm = AtomCons.getInstance(aEnvironment, aStackTop, "XmlTag");
        Cons tg = AtomCons.getInstance(aEnvironment, aStackTop, tag);
        Cons tp = AtomCons.getInstance(aEnvironment, aStackTop, type);
        info.cdr().setCons(tp);
        tg.cdr().setCons(info);
        xm.cdr().setCons(tg);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, xm));

    }
}



/*
%mathpiper_docs,name="XmlExplodeTag",categories="User Functions;Input/Output;Built In"
*CMD XmlExplodeTag --- convert XML strings to tag objects
*CORE
*CALL
	XmlExplodeTag(xmltext)
*PARMS

{xmltext} -- string containing some XML tokens

*DESC

{XmlExplodeTag} parses the car XML token in {xmltext}
and returns a MathPiper expression.

The following subset of XML syntax is supported currently:

*	{} -- an opening tag
*	{} -- a closing tag
*	{} -- an open/close tag
*	plain (non-tag) text

The tag options take the form {paramname="value"}.

If given an XML tag, {XmlExplodeTag} returns a structure of the form {XmlTag(name,params,type)}.
In the returned object,
{name} is the (capitalized) tag name, {params} is an assoc list with
the options (key fields capitalized), and type can be either "Open", "Close" or "OpenClose".

If given a plain text string, the same string is returned.


*E.G.
In> XmlExplodeTag("some plain text")
Result: "some plain text";
In> XmlExplodeTag("")
Result: XmlTag("A",{{"ALIGN","left"},
	  {"NAME","blah blah"}},"Open");
In> XmlExplodeTag("
    ")
Result: XmlTag("P",{},"Close");
In> XmlExplodeTag("
    ")
Result: XmlTag("BR",{},"OpenClose");

*SEE XmlTokenizer
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LispForm.java0000644000175000017500000000442511523200452030514 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.printers.LispPrinter;

/**
 *
 * 
 */
public class LispForm extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispPrinter printer = new LispPrinter();
        printer.print(aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), aEnvironment.iCurrentOutput, aEnvironment);
        aEnvironment.write("\n");
    }
}



/*
%mathpiper_docs,name="LispForm",categories="User Functions;Input/Output;Built In"
*CMD LispForm --- print an expression in LISP-format
*CORE
*CALL
	LispForm(expr)

*PARMS

{expr} -- expression to be printed in LISP-format

*DESC

Evaluates "expr", and prints it in LISP-format on the current
output. It is followed by a newline. The evaluated expression is also
returned.

This can be useful if you want to study the internal representation of
a certain expression.

*E.G. notest

In> LispForm(a+b+c);
	(+ (+ a b )c )
Result: a+b+c;
In> LispForm(2*I*b^2);
	(* (Complex 0 2 )(^ b 2 ))
Result: Complex(0,2)*b^2;

The first example shows how the expression {a+b+c} is
internally represented. In the second example, {2*I} is
first evaluated to {Complex(0,2)} before the expression
is printed.

*SEE LispRead, ViewList
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsPrefix.java0000644000175000017500000000352011523200452030505 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsPrefix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPrefixOperators);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), op != null);
    }
}



/*
%mathpiper_docs,name="IsPrefix",categories="User Functions;Predicates;Built In"
*CMD IsPrefix --- check for function syntax
*CORE
*CALL
	IsPrefix("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Check whether the function with given name {"op"} has been declared as a
"bodied", infix, postfix, or prefix operator, and  return {True} or {False}.

*E.G.

In> IsPrefix("-")
Result: True

*SEE Bodied, PrecedenceGet,IsBodied,IsInfix,IsPostfix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastArcTan.java0000644000175000017500000000402711506531763030762 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class FastArcTan extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;

        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.atan(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The argument is NaN.", "FastArcTan", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastArcTan",categories="Programmer Functions;Built In"
*CMD FastArcTan --- double-precision math function
*CORE
*CALL
	FastArcTan(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Version.java0000644000175000017500000000407311523200452030405 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Version extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"" + org.mathpiper.Version.version + "\""));
    }
}



/*
%mathpiper_docs,name="Version",categories="User Functions;Built In"
*CMD Version --- show version of MathPiper
*CORE
*CALL
	Version()

*DESC

The function {Version()} returns a string representing the version of the currently running MathPiper interpreter.

*E.G. notest

In> Version()
Result: "1.0.48rev3";
In> IsLessThan(Version(), "1.0.47")
Result: False;
In> GreaterThan(Version(), "1.0.47")
Result: True;

The last two calls show that the {IsLessThan} and {GreaterThan}
functions can be used for comparing version numbers. This
method is only guaranteed, however, if the version is always expressed
in the form {d.d.dd} as above.

*REM
Note that on the Windows platforms the output may be different:
In> Version()
Result: "Windows-latest";

*SEE IsLessThan, GreaterThan
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LocalSymbols.java0000644000175000017500000000710011523200452031355 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.behaviours.LocalSymbolSubstitute;

/**
 *
 *  
 */
public class LocalSymbols extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int numberOfArguments = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        int numberOfSymbols = numberOfArguments - 2;

        String atomNames[] = new String[numberOfSymbols];
        String localAtomNames[] = new String[numberOfSymbols];

        int uniqueNumber = aEnvironment.getUniqueId();
        int i;
        for (i = 0; i < numberOfSymbols; i++)
        {
            String atomName = (String) getArgumentPointer(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0), i + 1).car();
            LispError.checkArgument(aEnvironment, aStackTop, atomName != null, i + 1, "LocalSymbols");
            atomNames[i] = atomName;
            String newAtomName = "$" + atomName + uniqueNumber;
            String variable = (String) aEnvironment.getTokenHash().lookUp(newAtomName);
            localAtomNames[i] = variable;
        }
        LocalSymbolSubstitute substituteBehaviour = new LocalSymbolSubstitute(aEnvironment, atomNames, localAtomNames, numberOfSymbols);
        ConsPointer result = new ConsPointer();
        Utility.substitute(aEnvironment, aStackTop, result, getArgumentPointer(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0), numberOfArguments - 1), substituteBehaviour);
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), result);
    }
}//end class.




/*
%mathpiper_docs,name="LocalSymbols",categories="User Functions;Variables;Built In"
*CMD LocalSymbols --- create unique local symbols with given prefix
*STD
*CALL
	LocalSymbols(var1, var2, ...) body

*PARMS

{var1}, {var2}, ... -- atoms, symbols to be made local

{body} -- expression to execute

*DESC

Given the symbols passed as the first arguments to LocalSymbols a set of local
symbols will be created, and creates unique ones for them, typically of the
form {\$}, where {symbol} was the symbol entered by the user,
and {number} is a unique number. This scheme was used to ensure that a generated
symbol can not accidentally be entered by a user.

This is useful in cases where a guaranteed free variable is needed,
for example, in the macro-like functions ({For}, {While}, etc.).

*E.G. notest

In> LocalSymbols(a,b)a+b
Result: \$a6+ \$b6;

*SEE UniqueConstant
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/JavaToValue.java0000644000175000017500000000776611506531763031172 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *
 */
public class JavaToValue extends BuiltinFunction {

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        Object argument = getArgumentPointer(aEnvironment, aStackTop, 1).car();

        if (argument instanceof JavaObject) {
            String atomValue = "";

            JavaObject javaObject = (JavaObject) argument;

            Object object = javaObject.getObject();

            if (object != null) {

                if (object instanceof java.lang.Boolean) {
                    if (((Boolean) object).booleanValue() == true) {
                        atomValue = "True";
                    } else {
                        atomValue = "False";
                    }
                } else if (object instanceof String[]) {
                    
                    String[] stringArray = (String[]) object;

                    Cons listAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

                    Cons sublistCons = SublistCons.getInstance(aEnvironment, listAtomCons);

                    ConsPointer consPointer = new ConsPointer(listAtomCons);

                    for(String javaString : stringArray)
                    {
                        Cons atomCons = AtomCons.getInstance(aEnvironment, aStackTop, Utility.toMathPiperString(aEnvironment, aStackTop, javaString));

                        consPointer.cdr().setCons(atomCons);

                        consPointer.goNext(aStackTop, aEnvironment);
                    }//end for.

                    getTopOfStackPointer(aEnvironment, aStackTop).setCons(sublistCons);
                    
                    return;

                } else {
                    atomValue = (String) javaObject.getObject().toString().trim();
                }

                getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, atomValue));

                return;
            }
        } else {
            LispError.raiseError("The argument must be a JavaObject.", "JavaToValue", aStackTop, aEnvironment);
        }


        Utility.putFalseInPointer(aEnvironment, null);
    }//end method.
}//end class.





/*
%mathpiper_docs,name="JavaToValue",categories="Programmer Functions;Built In;Native Objects",access="experimental"
*CMD JavaToValue --- converts a Java object into a MathPiper data structure
*CALL
    JavaToValue(javaObject)

*PARMS
{javaObject} -- a Java object

*DESC
This function is used to convert a Java object into a MathPiper data structure.  It is typically 
used with JavaCall.

*E.G.
In> javaString := JavaNew("java.lang.String", "Hello")
Result: java.lang.String

In> JavaToValue(javaString)
Result: Hello

*SEE JavaCall, JavaAccess, JavaNew
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RoundToN.java0000644000175000017500000000724411602741206030500 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.NumberCons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *
 */
public class RoundToN extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        BigNumber requestedPrecision = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);



        Cons argument1 = getArgumentPointer(aEnvironment, aStackTop, 1).getCons();

        if(argument1 instanceof NumberCons)
        {

            BigNumber decimalToBeRounded = new BigNumber(org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1));

            if(decimalToBeRounded.getPrecision() != requestedPrecision.toInt())
            {
                decimalToBeRounded.setPrecision(requestedPrecision.toInt());
            }

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(decimalToBeRounded));

            return;

        }
        else if (argument1 instanceof SublistCons)
        {
            ConsPointer consPointer = new ConsPointer(argument1);

            consPointer.goSub(aStackTop, aEnvironment);

            String functionName = ((String) consPointer.car());

            if(functionName.equals("Complex"))
            {
                consPointer.goNext(aStackTop, aEnvironment);

                BigNumber realPart = (BigNumber) ((NumberCons) (consPointer.getCons())).getNumber(aEnvironment.getPrecision(), aEnvironment);

                if(realPart.getPrecision() != requestedPrecision.toInt())
                {
                    realPart.setPrecision(requestedPrecision.toInt());
                }//end if.

                consPointer.goNext(aStackTop, aEnvironment);

                BigNumber imaginaryPart = (BigNumber) ((NumberCons) (consPointer.getCons())).getNumber(aEnvironment.getPrecision(), aEnvironment);

                if(imaginaryPart.getPrecision() != requestedPrecision.toInt())
                {
                    imaginaryPart.setPrecision(requestedPrecision.toInt());
                }//end if.



                Cons complexAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "Complex");

                Cons realNumberCons = new NumberCons(realPart);

                complexAtomCons.cdr().setCons(realNumberCons);

                Cons imaginaryNumberCons = new NumberCons(imaginaryPart);

                realNumberCons.cdr().setCons(imaginaryNumberCons);

                Cons complexSublistCons = SublistCons.getInstance(aEnvironment, complexAtomCons);

                getTopOfStackPointer(aEnvironment, aStackTop).setCons(complexSublistCons);
                
                return;
                
            }//end if.


        }//end else.

        LispError.raiseError("The first argument must be a number.", "RoundToN", aStackTop, aEnvironment);

    }//end method.


}//end class.



/*
%mathpiper_docs,name="RoundToN",categories="User Functions;Numeric;Built In"
*CMD RoundToN --- rounds a decimal number to a given precision
*CORE
*CALL
	RoundToN(decimalNumber, precision)

*PARMS
{decimalNumber} -- a decimal number to be rounded
{precision} -- precision to round the number to

*DESC

This command rounds a decimal number to a given precision.

*E.G.
In> RoundToN(7.57809824,2)
Result> 7.6

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/StackSize.java0000644000175000017500000000260211262036106030657 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class StackSize extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispStackSize");//TODO FIXME

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Ceil.java0000644000175000017500000000500511523200452027630 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Ceil extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.negate(x);
        z.floor(z);
        z.negate(z);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="CeilN",categories="User Functions;Numeric;Built In"
*CMD CeilN --- natural logarithm for x > 0 (arbitrary-precision math function)
*CORE
*CALL
	CeilN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ExceptionCatch.java0000644000175000017500000001012111502301211031640 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class ExceptionCatch extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        try
        {
            //Return the first argument.
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));
        } catch (Throwable exception)
        {   //Return the second argument.
            //e.printStackTrace();
            Boolean interrupted = Thread.currentThread().interrupted(); //Clear interrupted condition.
            aEnvironment.iException = exception;
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 2));
            aEnvironment.iException = null;
        }
    }
}



/*
%mathpiper_docs,name="ExceptionCatch",categories="Programmer Functions;Error Reporting;Built In"
*CMD ExceptionCatch --- catches exceptions
*CORE
*CALL
	ExceptionCatch(expression, exceptionHandler)

*PARMS

{expression} -- expression to evaluate (causing potential error)

{exceptionHandler} -- expression which is evaluated to handle the exception

*DESC
ExceptionCatch evaluates its argument {expression} and returns the
result of evaluating {expression}. If an exception is thrown,
{errorHandler} is evaluated, returning its return value instead.

{ExceptionGet} can be used to obtain information about the caught exception.


 
*E.G.


In> ExceptionCatch(Check(1 = 2, "Test", "Throwing a test exception."), "This string is returned if an exception is thrown.");
Result: "This string is returned if an exception is thrown."




/%mathpiper,title="Example of how to use ExceptionCatch and ExceptionGet in test code (long version)."
[
  Local(exception);

  exception := False;

  ExceptionCatch(Check(1 = 2, "Test", "Throwing a test exception."), exception := True);

  Verify(exception, True);

];
/%/mathpiper

    /%output,preserve="false"
      Result: True
.   /%/output





/%mathpiper,title="Example of how to use ExceptionCatch and ExceptionGet in test code (short version)."

//ExceptionGet returns False if there is no exception or an association list if there is.
Verify( ExceptionCatch(Check(1 = 2, "Test", "Throwing a test exception."), ExceptionGet()) = False, False);

/%/mathpiper

    /%output,preserve="false"
      Result: True
.   /%/output





/%mathpiper,title="Example of how to handle a caught exception."

TestFunction(x) :=
[

    Check(IsInteger(x), "Argument", "The argument must be an integer.");

];




caughtException := ExceptionCatch(TestFunction(1.2), ExceptionGet());

Echo(caughtException);

NewLine();

Echo("Type: ", caughtException["type"]);

NewLine();

Echo("Message: ", caughtException["message"]);


/%/mathpiper

    /%output,preserve="false"
      Result: True

      Side Effects:
      {{"type","Argument"},{"message","The argument must be an integer."},{"exceptionObject",class org.mathpiper.exceptions.EvaluationException}}

      Type: Argument

      Message: The argument must be an integer.

.   /%/output

*SEE Check, ExceptionGet

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/HistorySize.java0000644000175000017500000000420111523200452031245 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class HistorySize extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispHistorySize");//TODO FIXME

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}



/*
%mathpiper_docs,name="HistorySize",categories="User Functions;Built In"
*CMD HistorySize --- set size of history file
*CORE
*CALL
	HistorySize(n)

*PARMS

{n} -- number of lines to store in history file

*DESC

When exiting, MathPiper saves the command line history to a
file {~/.MathPiper_history}. By default it will
save the last 1024 lines. The default can be
overridden with this function. Passing -1 tells the system to save all
lines.

MathPiper allows you to configure a few things at startup. The file
{~/.mathpiperrc} is written in the MathPiper language and
will be executed when MapthPiper is run. This function
can be useful in the {~/.MathPiperrc} file.

*E.G.

In> HistorySize(200)
Result: True;
In> quit

*SEE quit
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Bodied.java0000644000175000017500000000477611523200452030160 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Bodied extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.multiFix(aEnvironment, aStackTop, aEnvironment.iBodiedOperators);
    }
}



/*
%mathpiper_docs,name="Bodied",categories="Programmer Functions;Programming;Built In"
*CMD Bodied --- define function syntax (bodied function)
*CORE
*CALL
	Bodied("op", precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer (evaluated)

*DESC

Declares a special syntax for the function to be parsed as a bodied operator.

"Bodied" functions have all arguments except the first one inside parentheses and the last argument outside, for example:
	For(pre, condition, post) statement;
Here the function {For} has 4 arguments and the last argument is placed outside the parentheses.
The {precedence} of a "bodied" function refers to how tightly the last argument is bound to the parentheses.
This makes a difference when the last argument contains other operators.
For example, when taking the derivative
	D(x) Sin(x)+Cos(x)
both {Sin} and {Cos} are under the derivative because the bodied function {D} binds less tightly than the infix operator "{+}".

Function name can be any string but meaningful usage and readability would
require it to be either made up entirely of letters or entirely of non-letter
characters (such as "+", ":" etc.).
Precedence is optional (will be set to 0 by default).

*E.G.
In> todo

*SEE IsBodied, PrecedenceGet, Infix, Postfix, Prefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PrecedenceGet.java0000644000175000017500000000576111523200452031462 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.LispError;

/**
 *
 *  
 */
public class PrecedenceGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iInfixOperators);
        if (op == null)
        {  // also need to check for a postfix or prefix operator

            op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPrefixOperators);
            if (op == null)
            {
                op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPostfixOperators);
                if (op == null)
                {  // or maybe it's a bodied function

                    op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iBodiedOperators);
                    LispError.check(aEnvironment, aStackTop, op != null, LispError.IS_NOT_INFIX);
                }
            }
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + op.iPrecedence));
    }
}



/*
%mathpiper_docs,name="PrecedenceGet",categories="Programmer Functions;Programming;Built In"
*CMD PrecedenceGet --- get operator precedence
*CORE
*CALL
	PrecedenceGet("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Returns the precedence of the function named "op" which should have been declared as a bodied function or an infix, postfix, or prefix operator. Generates an error message if the string str does not represent a type of function that can have precedence.

For infix operators, right precedence can differ from left precedence. Bodied functions and prefix operators cannot have left precedence, while postfix operators cannot have right precedence; for these operators, there is only one value of precedence.

*E.G.
In> PrecedenceGet("+")
Result: 6;

*SEE LeftPrecedenceGet,RightPrecedenceGet,LeftPrecedenceSet,RightPrecedenceSet,RightAssociativeSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PipeToFile.java0000644000175000017500000001062411523200452030757 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import java.io.FileOutputStream;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.StandardFileOutputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class PipeToFile extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);

        ConsPointer evaluated = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, getArgumentPointer(aEnvironment, aStackTop, 1));

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "PipeToFile");
        String orig = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "PipeToFile");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        // Open file for writing
        FileOutputStream localFP = new FileOutputStream(oper, true);

        LispError.check(aEnvironment, aStackTop, localFP != null, LispError.FILE_NOT_FOUND);

        StandardFileOutputStream newStream = new StandardFileOutputStream(localFP);

        MathPiperOutputStream originalStream = aEnvironment.iCurrentOutput;

        aEnvironment.iCurrentOutput = newStream;

        try
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 2));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            localFP.flush();
            localFP.close();
            aEnvironment.iCurrentOutput = originalStream;
        }
    }
}



/*
%mathpiper_docs,name="PipeToFile",categories="User Functions;Input/Output;Built In"
*CMD PipeToFile --- connect current output to a file
*CORE
*CALL
	PipeToFile(name) body

*PARMS

{name} -- string, the name of the file to write the result to

{body} -- expression to be evaluated

*DESC

The current output is connected to the file "name". Then the expression
"body" is evaluated. Everything that the commands in "body" print
to the current output, ends up in the file "name". Finally, the
file is closed and the result of evaluating "body" is returned.

If the file is opened again, the new information will be appended to the
existing information in the file.

*E.G. notest

Here is how one can create a file with C code to evaluate an expression:

In> PipeToFile("expr1.c") WriteString(CForm(Sqrt(x-y)*Sin(x)) );
Result> True;

The file {expr1.c} was created in the current working directory and it
contains the line sqrt(x-y)*sin(x)


As another example, take a look at the following command:

In> [ Echo("Result:");  PrettyForm(Taylor(x,0,9) Sin(x)); ];
Result:

	     3    5      7       9
	    x    x      x       x
	x - -- + --- - ---- + ------
	    6    120   5040   362880

Result> True;

Now suppose one wants to send the output of this command to a
file. This can be achieved as follows:

In> PipeToFile("out") [ Echo("Result:");  PrettyForm(Taylor(x,0,9) Sin(x)); ];
Result> True;

After this command the file {out} contains:


Result:

	     3    5      7       9
	    x    x      x       x
	x - -- + --- - ---- + ------
	    6    120   5040   362880


*SEE PipeFromFile, PipeToString, Echo, Write, WriteString, PrettyForm, Taylor
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CommonLispTokenizer.java0000644000175000017500000000262611262036106032740 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CommonLispTokenizer extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispCommonLispTokenizer");//TODO FIXME

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FlatCopy.java0000644000175000017500000000433711523200452030504 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class FlatCopy extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer copied = new ConsPointer();
        Utility.flatCopy(aEnvironment, aStackTop, copied, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,copied.getCons()));
    }
}



/*
%mathpiper_docs,name="FlatCopy",categories="User Functions;Lists (Operations);Built In"
*CMD FlatCopy --- copy the top level of a list
*CORE
*CALL
	FlatCopy(list)

*PARMS

{list} -- list to be copied

*DESC

A copy of "list" is made and returned. The list is not recursed
into, only the car level is copied. This is useful in combination
with the destructive commands that actually modify lists in place (for
efficiency).

*E.G.

The following shows a possible way to define a command that reverses a
list nondestructively.

In> reverse(l_IsList) <-- DestructiveReverse \
	  (FlatCopy(l));
Result: True;
In> lst := {a,b,c,d,e};
Result: {a,b,c,d,e};
In> reverse(lst);
Result: {e,d,c,b,a};
In> lst;
Result: {a,b,c,d,e};
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Rulebase.java0000644000175000017500000000370211417443641030533 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Rulebase extends BuiltinFunction
{
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.rulebase(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="Rulebase",categories="Programmer Functions;Programming;Built In"
*CMD Rulebase --- define function with a fixed number of arguments
*CORE
*CALL
	Rulebase(name,params)

*PARMS

{name} -- string, name of function

{params} -- list of arguments to function

*DESC
Define a new rules table entry for a
function "name", with {params} as the parameter list. Name can be
either a string or simple atom.

In the context of the transformation rule declaration facilities
this is a useful function in that it allows the stating of argument
names that can he used with HoldArgument.

Functions can be overloaded: the same function can be defined
with different number of arguments.


*SEE MacroRulebase, RulebaseListed, MacroRulebaseListed, HoldArgument, Retract
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DebugFile.java0000644000175000017500000000226111226771211030611 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DebugFile extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        throw new Exception("Cannot call DebugFile in non-debug version of MathPiper");
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefLoad.java0000644000175000017500000000512611333354275030272 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class DefLoad extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.check(aEnvironment, aStackTop, aEnvironment.iSecure == false, LispError.SECURITY_BREACH);

        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "DefLoad");
        String orig =  (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "DefLoad");

        Utility.loadDefFile(aEnvironment, aStackTop, orig);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="DefLoad",categories="User Functions;Input/Output;Built In"
*CMD DefLoad --- load a {.def} file
*CORE
*CALL
	DefLoad(name)

*PARMS

{name} -- string, name of the file (without {.def} suffix)

*DESC

The suffix {.def} is appended to "name" and the
file with this name is loaded. It should contain a list of functions,
terminated by a closing brace \} (the end-of-list delimiter). This
tells the system to load the file "name" as soon as the user calls
one of the functions named in the file (if not done so already). This
allows for faster startup times, since not all of the rules databases
need to be loaded, just the descriptions on which files to load for
which functions.

*SEE Load, Use, DefaultDirectory
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LoadScriptOnce.java0000644000175000017500000000466311340055520031637 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class LoadScriptOnce extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "LoadScriptOnce");
        String orig = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "LoadScriptOnce");

        Utility.loadScriptOnce(aEnvironment, aStackTop, orig);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}


/*
%mathpiper_docs,name="LoadScriptOnce",categories="User Functions;Control Flow;Input/Output;Built In"
*CMD LoadScriptOnce --- load a script file (but not twice)
*CORE
*CALL
	LoadScriptOnce(name)

*PARMS

{name} -- name of the script file to load

*DESC

If the file "name" has been loaded before, either by an earlier call
to {LoadScriptOnce} or via the {DefLoad}
mechanism, nothing happens. Otherwise all expressions in the file are
read and evaluated. {LoadScriptOnce} always returns {True}.

The purpose of this function is to make sure that the file will at
least have been loaded, but is not loaded twice.

*SEE LoadScript, DefLoad, DefaultDirectory
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ToBase.java0000644000175000017500000000675411523200452030145 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ToBase extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get the base to convert to:
        // Evaluate car argument, and store getTopOfStackPointer in oper
        ConsPointer oper = new ConsPointer();
        oper.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        // check that getTopOfStackPointer is a number, and that it is in fact an integer
//        LispError.check(oper.type().equals("Number"), LispError.KLispErrInvalidArg);
        BigNumber num =(BigNumber) oper.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, num != null, 1, "ToBase");
        // check that the base is an integer between 2 and 32
        LispError.checkArgument(aEnvironment, aStackTop, num.isInteger(), 1, "ToBase");

        // Get a short platform integer from the car argument
        int base = (int) (num.toLong());

        // Get the number to convert
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        // convert using correct base
        String str;
        str = x.numToString(aEnvironment.getPrecision(), base);
        // Get unique string from hash table, and create an atom from it.

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(str)));
    }
}


/*
%mathpiper_docs,name="ToBase",categories="User Functions;Numbers (Operations);Built In"
*CMD ToBase --- conversion of a number in decimal base to non-decimal base
*CORE
*CALL
	ToBase(base, number)

*PARMS

{base} -- integer, base to convert to/from

{number} -- integer, number to write out in a different base

{"string"} -- string representing a number in a different base

*DESC

In MathPiper, all numbers are written in decimal notation (base 10).
The two functions {FromBase}, {ToBase} convert numbers between base 10 and a different base.
Numbers in non-decimal notation are represented by strings.


*REM where is this p-adic capability? - sw
These functions use the p-adic expansion capabilities of the built-in
arbitrary precision math libraries.

Non-integer arguments are not supported.

*E.G.


Write the (decimal) number {255} in hexadecimal notation:

In> ToBase(16,255)
Result: "ff";

*SEE PAdicExpand,FromBase
%/mathpiper_docs
 */mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CustomEvalStop.java0000644000175000017500000000261611262036106031714 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CustomEvalStop extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispCustomEvalStop");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BackQuote.java0000644000175000017500000001001111523200452030623 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class BackQuote extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.behaviours.BackQuoteSubstitute behaviour = new org.mathpiper.lisp.behaviours.BackQuoteSubstitute(aEnvironment);
        ConsPointer result = new ConsPointer();
        Utility.substitute(aEnvironment, aStackTop, result, getArgumentPointer(aEnvironment, aStackTop, 1), behaviour);
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), result);
    }
}



/*
%mathpiper_docs,name="`",categories="Operators"
*A {`}
*CMD Backquoting --- macro expansion (LISP-style backquoting)
*CORE
*CALL
	`(expression)

*PARMS

{expression} -- expression containing "{@var}" combinations to substitute the value of variable "{var}"

*DESC

Backquoting is a macro substitution mechanism. A backquoted {expression}
is evaluated in two stages: first, variables prefixed by {@} are evaluated
inside an expression, and second, the new expression is evaluated.

To invoke this functionality, a backquote {`} needs to be placed in front of
an expression. Parentheses around the expression are needed because the
backquote binds tighter than other operators.

The expression should contain some variables (assigned atoms) with the special
prefix operator {@}. Variables prefixed by {@} will be evaluated even if they
are inside function arguments that are normally not evaluated (e.g. functions
declared with {HoldArgument}). If the {@var} pair is in place of a function name,
e.g. "{@f(x)}", then at the first stage of evaluation the function name itself
is replaced, not the return value of the function (see example); so at the
second stage of evaluation, a new function may be called.

One way to view backquoting is to view it as a parametric expression
generator. {@var} pairs get substituted with the value of the variable {var}
even in contexts where nothing would be evaluated. This effect can be also
achieved using {ListToFunction} and {Hold} but the resulting code is much more
difficult to read and maintain.

This operation is relatively slow since a new expression is built
before it is evaluated, but nonetheless backquoting is a powerful mechanism
that sometimes allows to greatly simplify code.

*E.G.

This example defines a function that automatically evaluates to a number as
soon as the argument is a number (a lot of functions  do this only when inside
a {N(...)} section).

In> Decl(f1,f2) := \
In>   `(@f1(x_IsNumber) <-- N(@f2(x)));
Result: True;
In> Decl(nSin,Sin)
Result: True;
In> Sin(1)
Result: Sin(1);
In> nSin(1)
Result: 0.8414709848;

This example assigns the expression {func(value)} to variable {var}. Normally
the first argument of {Bind} would be unevaluated.

In> SetF(var,func,value) := \
In>     `(Bind(@var,@func(@value)));
Result: True;
In> SetF(a,Sin,x)
Result: True;
In> a
Result: Sin(x);


*SEE MacroBind, MacroLocal, MacroRulebase, Hold, HoldArgument, DefMacroRulebase, MacroExpand
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CurrentLine.java0000644000175000017500000000365411332771351031227 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CurrentLine extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + aEnvironment.iInputStatus.lineNumber()));
    }
}



/*
%mathpiper_docs,name="CurrentLine",categories="Programmer Functions;Error Reporting;Built In"
*CMD CurrentLine --- return current line number on input
*CORE
*CALL
	CurrentLine()

*DESC

The function {CurrentLine} returns a string
with the current line of the input file.

These functions are most useful in batch file calculations, where
there is a need to determine at which line an error occurred.
One can define a function

	tst() := Echo({CurrentFile(),CurrentLine()});
which can then be inserted into the input file at various places,
to see how far the interpreter reaches before an error occurs.

*SEE Echo, CurrentFile

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Infix.java0000644000175000017500000000423611523200452030036 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Infix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.multiFix(aEnvironment, aStackTop, aEnvironment.iInfixOperators);
    }
}



/*
%mathpiper_docs,name="Infix",categories="User Functions;Built In"
*CMD Infix --- define function syntax (infix operator)
*CORE
*CALL
	Infix("op")
	Infix("op", precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer (evaluated)

*DESC

Declares a special syntax for the function to be parsed as an  infix operator.

"Infix" functions must have two arguments and are syntactically placed between their arguments.
Names of infix functions can be arbitrary, although for reasons of readability they are usually made of non-alphabetic characters.

Function name can be any string but meaningful usage and readability would
require it to be either made up entirely of letters or entirely of non-letter
characters (such as "+", ":" etc.).
Precedence is optional (will be set to 0 by default).

*E.G.
In> Infix("##", 5)
Result: True;
In> a ## b ## c
Result: a##b##c;

*SEE IsBodied, PrecedenceGet, Bodied, Postfix, Prefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsDecimal.java0000644000175000017500000000462611422223770030624 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class IsDecimal extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer result = new ConsPointer();
        result.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        Object cons = result.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);

        BigNumber bigNumber;
        if(cons instanceof BigNumber)
        {
            bigNumber = (BigNumber) cons;

            Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop),  bigNumber.isDecimal());
        }
        else
        {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }


    }
}



/*
%mathpiper_docs,name="IsDecimal",categories="User Functions;Predicates;Built In"
*CMD IsDecimal --- test to see if a number is a decimal
*CORE
*CALL
	IsDecimal(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether "expr" is a decimal number. There are two kinds
of numbers, integers (e.g. 6) and decimals (e.g. -2.75 or 6.0).
*E.G.

In> IsDecimal(3.25);
Result: True;

In> IsDecimal(6);
Result: False;

In> IsDecimal(1/2);
Result: False;

In> IsDecimal(3.2/10);
Result: False;

*SEE IsString, IsAsom, IsInteger, IsPositiveNumber, IsNegativeNumber, IsNumber
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Exit.java0000644000175000017500000000217211226771211027675 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Exit extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Runtime.getRuntime().exit(0);
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/List.java0000644000175000017500000000521611523200452027673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class List extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer allPointer = new ConsPointer();
        allPointer.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
        ConsTraverser tail = new ConsTraverser(aEnvironment, allPointer);
        tail.goNext(aStackTop);
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null) {
            ConsPointer evaluated = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, consTraverser.getPointer());
            tail.getPointer().setCons(evaluated.getCons());
            tail.goNext(aStackTop);
            consTraverser.goNext(aStackTop);
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, allPointer.getCons()));
    }

}



/*
%mathpiper_docs,name="List",categories="User Functions;Lists (Operations);Built In"
*CMD List --- construct a list
*CORE
*CALL
	List(expr1, expr2, ...)

*PARMS

{expr1}, {expr2} -- expressions making up the list

*DESC

A list is constructed whose car entry is "expr1", the second entry
is "expr2", and so on. This command is equivalent to the expression
"{expr1, expr2, ...}".

*E.G.

In> List();
Result: {};
In> List(a,b);
Result: {a,b};
In> List(a,{1,2},d);
Result: {a,{1,2},d};

*SEE ListToFunction, FunctionToList
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Write.java0000644000175000017500000000501111523200452030043 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class Write extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer arguments = getArgumentPointer(aEnvironment, aStackTop, 1);
        
        if (arguments.type() == Utility.SUBLIST) {

            ConsPointer subList = (ConsPointer) arguments.car();
            
            ConsPointer consTraverser = new ConsPointer( subList.getCons());
            consTraverser.goNext(aStackTop, aEnvironment);
            while (consTraverser.getCons() != null)
            {
                aEnvironment.iCurrentPrinter.print(aStackTop, consTraverser, aEnvironment.iCurrentOutput, aEnvironment);
                consTraverser.goNext(aStackTop, aEnvironment);
            }
        }
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="Write",categories="User Functions;Input/Output;Built In"
*CMD Write --- low-level printing routine
*CORE
*CALL
	Write(expr, ...)

*PARMS

{expr} -- expression to be printed

*DESC

The expression "expr" is evaluated and written to the current
output. Note that Write accept an arbitrary number of arguments, all
of which are written to the current output (see second
example). {Write} always returns {True}.

*E.G. notest

In> Write(1);
	1Result: True;
In> Write(1,2);
	 1 2Result: True;

Write does not write a newline, so the {Result:} prompt
immediately follows the output of {Write}.

*SEE Echo, WriteString
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastTan.java0000644000175000017500000000400511506531763030330 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class FastTan extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;

        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.tan(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The result is NaN.", "FastTan", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastTan",categories="Programmer Functions;Built In"
*CMD FastTan --- double-precision math function
*CORE
*CALL
	FastTan(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Delay.java0000644000175000017500000000356011425211710030016 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class Delay extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber milliseconds = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        Thread.sleep(milliseconds.toLong());

        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}//end class.



/*
%mathpiper_docs,name="Delay",categories="User Functions;Built In;Input/Output"
*CMD Delay --- delays execution of a program for a specified number of milliseconds
*CORE
*CALL
	Delay(ms)

 *PARAMS
 {ms} -- the number of milliseconds to delay

*DESC

This function delays execution of a program for the specified number of milliseconds.
The delay can be terminated by pressing the "Halt Calculation" button.

*E.G.
In> Delay(1000)
Result: True

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Quotient.java0000644000175000017500000000555011523200452030571 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Quotient extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        if (x.isInteger() && y.isInteger())
        {  // both integer, perform integer division

            BigNumber z = new BigNumber(aEnvironment.getPrecision());
            z.divide(x, y, aEnvironment.getPrecision());
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
            return;
        } else
        {
            throw new Exception("LispDiv: error: both arguments must be integer");
        }
    }
}//end class.



/*
%mathpiper_docs,name="QuotientN",categories="User Functions;Numeric;Built In"
*CMD QuotientN --- integer division result is an integer (arbitrary-precision math function)
*CORE
*CALL
	QuotientN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/StringMidGet.java0000644000175000017500000000604211523200452031316 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class StringMidGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, evaluated, 3, "StringMidGet");
        String orig = (String) evaluated.car();

        ConsPointer index = new ConsPointer();
        index.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 1, "StringMidGet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 1, "StringMidGet");
        int from = Integer.parseInt( (String) index.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, from > 0, 1, "StringMidGet");

        index.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "StringMidGet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "StringMidGet");
        int count = Integer.parseInt( (String) index.car(), 10);


        String str = "\"" + orig.substring(from, from + count) + "\"";
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, str));
    }
}



/*
%mathpiper_docs,name="StringMidGet",categories="User Functions;String Manipulation;Built In"
*CMD StringMidGet --- retrieve a substring
*CORE
*CALL
	StringMidGet(index,length,string)

*PARMS

{index} -- index of substring to get

{length} -- length of substring to get

{string} -- string to get substring from

*DESC

{StringMidGet} returns a part of a string. Substrings can also be
accessed using the {[]} operator.

*E.G.

In> StringMidGet(3,2,"abcdef")
Result: "cd";
In> "abcdefg"[2 .. 4]
Result: "bcd";

*SEE StringMidSet, Length
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefaultTokenizer.java0000644000175000017500000000517411523200452032242 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class DefaultTokenizer extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.iCurrentTokenizer = aEnvironment.iDefaultTokenizer;
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="DefaultTokenizer",categories="User Functions;Input/Output;Built In"
*CMD DefaultTokenizer --- select the default syntax tokenizer for parsing the input
*CORE
*CALL
	DefaultTokenizer()

*DESC

A "tokenizer" is an internal routine in the kernel that parses the input into MathPiper expressions.
This affects all input typed in by a user at the prompt and also the input redirected from files or strings using {PipeFromFile} and {FromString} and read using {Read} or {ReadToken}.

The MathPiper environment currently supports some experimental tokenizers for
various syntaxes. {DefaultTokenizer} switches to the tokenizer used for
default MathPiper syntax.
Note that setting the tokenizer is a global side effect.
One typically needs
to switch back to the default tokenizer when finished reading the special syntax.

Care needs to be taken when kernel errors are raised during a non-default tokenizer operation (as with any global change in the environment).
Errors need to be
caught with the {TrapError} function. The error handler code should re-instate
the default tokenizer,
or else the user will be unable to continue the session
(everything a user types will be parsed using a non-default tokenizer).


*E.G. notest

In>


*SEE OMRead, TrapError, XmlExplodeTag, ReadToken, PipeFromFile, FromString, XmlTokenizer
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Add.java0000644000175000017500000000654211523200452027453 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;


import org.mathpiper.lisp.Environment;

import org.mathpiper.lisp.Utility;

/**
 *Corresponds to the MathPiper function AddN.
 *If called with one argument (unary plus), this argument is
 *converted to BigNumber. If called with two arguments (binary plus),
 *both argument are converted to a BigNumber, and these are added
 *together at the current getPrecision. The sum is returned.
 * See: getNumber(), BigNumber::Add().
 *  
 */
public class Add extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int length = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        if (length == 2)
        {
            BigNumber x;
            x = Utility.getNumber(aEnvironment, aStackTop, 1);
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(x));
            return;
        } else
        {
            BigNumber x = Utility.getNumber(aEnvironment, aStackTop, 1);
            BigNumber y = Utility.getNumber(aEnvironment, aStackTop, 2);
            int bin = aEnvironment.getPrecision();
            BigNumber z = new BigNumber(bin);
            z.add(x, y, aEnvironment.getPrecision());
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
            return;
        }
    }
}//end class.



/*
%mathpiper_docs,name="AddN",categories="User Functions;Numeric"
*CMD AddN --- add two numbers (arbitrary-precision math function)
*CORE
*CALL
	AddN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsPromptShown.java0000644000175000017500000000331511262036106031555 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class IsPromptShown extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispIsPromptShown");//TODO FIXME

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}//end class.



/*
%mathpiper_docs,name="IsPromptShown",categories="Programmer Functions;Built In"
*CMD IsPromptShown --- test for the MathPiper prompt option
*CORE
*CALL
	IsPromptShown()

*DESC
Returns {False} if MathPiper has been started with the option to suppress the prompt, and {True} otherwise.

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MacroRulebaseListed.java0000644000175000017500000000221111506531763032656 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MacroRulebaseListed extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        org.mathpiper.lisp.Utility.rulebase(aEnvironment, aStackTop, true);
    }

}



/*
%mathpiper_docs,name="MacroRulebaseListed",categories="Programmer Functions;Programming;Built In"
*CMD MacroRulebaseListed --- define rules in functions
*CORE
*DESC

This function has the same effect as its non-macro counterpart, except
that its arguments are evaluated before the required action is performed.
This is useful in macro-like procedures or in functions that need to define new
rules based on parameters.

Make sure that the arguments of {Macro}... commands evaluate to expressions that would normally be used in the non-macro version!

*SEE Bind, Unbind, Local, Rulebase, Rule, `, MacroBind, MacroUnbind, MacroLocal, MacroRulebase, MacroRule
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Return.java0000644000175000017500000000227311325241135030242 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.ReturnException;
import org.mathpiper.lisp.Environment;

/**
 *
 *
 */
public class Return extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         throw new ReturnException();
    }

}//end class.



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/While.java0000644000175000017500000001023411422223770030032 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.BreakException;
import org.mathpiper.exceptions.ContinueException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;


/**
 *
 *  
 */
public class While extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer arg1 = getArgumentPointer(aEnvironment, aStackTop, 1);
        ConsPointer arg2 = getArgumentPointer(aEnvironment, aStackTop, 2);

        ConsPointer predicate = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, predicate, arg1);

        ConsPointer evaluated = new ConsPointer();

        int beforeStackTop = -1;
        int beforeEvaluationDepth = -1;
        
        try {
            while (Utility.isTrue(aEnvironment, predicate, aStackTop)) {

                beforeStackTop = aEnvironment.iArgumentStack.getStackTopIndex();
                beforeEvaluationDepth = aEnvironment.iEvalDepth;

                try {

                    aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, arg2);

                } catch (ContinueException ce) {
                    aEnvironment.iArgumentStack.popTo(beforeStackTop, aStackTop, aEnvironment);
                    aEnvironment.iEvalDepth = beforeEvaluationDepth;
                    Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                }//end continue catch.

                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, predicate, arg1);

            }//end while.

            LispError.checkArgument(aEnvironment, aStackTop, Utility.isFalse(aEnvironment, predicate, aStackTop), 1, "While");

        } catch (BreakException be) {
              aEnvironment.iArgumentStack.popTo(beforeStackTop, aStackTop, aEnvironment);
              aEnvironment.iEvalDepth = beforeEvaluationDepth;
        }

        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }


}

/*
%mathpiper_docs,name="While",categories="User Functions;Control Flow;Built In"
*CMD While --- loop while a condition is met
*CORE
*CALL
While(pred) body

*PARMS
{pred} -- predicate deciding whether to keep on looping

{body} -- expression to loop over

*DESC

Keep on evaluating "body" while "pred" evaluates to {True}. More precisely, {While}
evaluates the predicate "pred", which should evaluate to either {True} or {False}. If the result is {True}, the expression "body" is evaluated and then
the predicate "pred" is again evaluated. If it is still {True}, the expressions "body" and "pred" are again
evaluated and so on until "pred" evaluates to {False}. At that point, the loop terminates and {While}
returns {True}.

In particular, if "pred" immediately evaluates to {False}, the body is never executed. {While} is the fundamental looping construct on which
all other loop commands are based. It is equivalent to the {while} command in the programming language C.

*E.G. notest

In> x := 0;
Result: 0;
In> While (x! < 10^6) \
[ Echo({x, x!}); x++; ];
0  1
1  1
2  2
3  6
4  24
5  120
6  720
7  5040
8  40320
9  362880
Result: True;

*SEE Until, For, ForEach, Break, Continue
%/mathpiper_docs
 */
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DigitsToBits.java0000644000175000017500000000423711333354275031346 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class DigitsToBits extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        long result = 0;  // initialize just in case

        if (x.isInteger() && x.isSmall() && y.isInteger() && y.isSmall())
        {
            // bits_to_digits uses unsigned long, see numbers.h
            int base = (int) y.toDouble();
            result = Utility.digitsToBits((long) (x.toDouble()), base);
        } else
        {
            throw new EvaluationException("BitsToDigits: error: arguments (" + x.toDouble() + ", " + y.toDouble() + ") must be small integers",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
        }
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo((long) result);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/If.java0000644000175000017500000000727511523200452027325 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class If extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int nrArguments = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        LispError.check(aEnvironment, aStackTop, nrArguments == 3 || nrArguments == 4, LispError.WRONG_NUMBER_OF_ARGUMENTS);

        ConsPointer predicate = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, predicate, getArgumentPointer(aEnvironment, aStackTop, 1));

        if (Utility.isTrue(aEnvironment, predicate, aStackTop))
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0), 2));
        } else
        {
            LispError.checkArgument(aEnvironment, aStackTop, Utility.isFalse(aEnvironment, predicate, aStackTop), 1, "If");
            if (nrArguments == 4)
            {
                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0), 3));
            } else
            {
                Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            }
        }
    }
}


/*
%mathpiper_docs,name="If",categories="User Functions;Control Flow;Built In"
*CMD If --- branch point
*CORE
*CALL
	If(pred, then)
	If(pred, then, else)

*PARMS

{pred} -- predicate to test

{then} -- expression to evaluate if "pred" is {True}

{else} -- expression to evaluate if "pred" is {False}

*DESC

This command implements a branch point. The predicate "pred" is
evaluated, which should result in either {True} or {False}. In the first case, the expression "then" is
evaluated and returned. If the predicate yields {False}, the expression "else" (if present) is evaluated and
returned. If there is no "else" branch (i.e. if the first calling
sequence is used), the {If} expression returns {False}.

*E.G.

The sign function is defined to be 1 if its argument is positive and
-1 if its argument is negative. A possible implementation is
In> mysign(x) := If (IsPositiveReal(x), 1, -1);
Result: True;
In> mysign(Pi);
Result: 1;
In> mysign(-2.5);
Result: -1;
Note that this will give incorrect results, if "x" cannot be
numerically approximated.
In> mysign(a);
Result: -1;
Hence a better implementation would be
In> mysign(_x)_IsNumber(N(x)) <-- If \
	  (IsPositiveReal(x), 1, -1);
Result: True;
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/JavaNew.java0000644000175000017500000001262211506531763030327 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import java.util.ArrayList;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.builtin.javareflection.Invoke;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.NumberCons;

/**
 *
 *
 */
public class JavaNew extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer) {

            ConsPointer subList = (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList);

            //Skip past List type.
            consTraverser.goNext(aStackTop);

            Cons argumentCons = consTraverser.getPointer().getCons();

            if (argumentCons != null) {

                String fullyQualifiedClassName = (String) argumentCons.car();
                //Strip leading and trailing quotes.
                fullyQualifiedClassName = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, fullyQualifiedClassName);

                consTraverser.goNext(aStackTop);

                ArrayList argumentArrayList = new ArrayList();

                while (consTraverser.getCons() != null) {
                    argumentCons = consTraverser.getPointer().getCons();

                    Object argument = null;

                    if(argumentCons instanceof NumberCons)
                    {
                        NumberCons numberCons = (NumberCons) argumentCons;
                        BigNumber bigNumber = (BigNumber) numberCons.getNumber(aEnvironment.getPrecision(), aEnvironment);

                        if(bigNumber.isInteger())
                        {
                            argument = bigNumber.toInt();
                        }
                        else
                        {
                            argument = bigNumber.toDouble();
                        }
                    }
                    else
                    {
                        argument = argumentCons.car();


                        if (argument instanceof String) {
                            argument = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, (String)argument);
                        }

                        if(argument instanceof JavaObject)
                        {
                            argument = ((JavaObject)argument).getObject();
                        }
                    }//end if/else.

                    argumentArrayList.add(argument);

                    consTraverser.goNext(aStackTop);

                }//end while.

                Object[] argumentsArray = (Object[]) argumentArrayList.toArray(new Object[0]);

                Object o = Invoke.invokeConstructor(fullyQualifiedClassName, argumentsArray);

                JavaObject response = new JavaObject(o);

                //JavaObject response = JavaObject.instantiate(fullyQualifiedClassName, argumentsArray);
                //System.out.println("XXXXXXXXXXX: " + response);

                if (response == null) {
                    Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                    return;
                } else {
                    getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));
                    return;
                }//end if/else.



            }//end if.

        }//end if.

        Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));

    }//end method.
}




/*
%mathpiper_docs,name="JavaNew",categories="Programmer Functions;Built In;Native Objects",access="experimental"
*CMD JavaNew --- instantiates a Java object
*CALL
    JavaNew(fullyQualifiedClassName, constructorParameter1, constructorParameter2, ...)

*PARMS
{fullyQualifiedClassName} -- (string) the fully qualified name of a Java class

{constructorParameters} -- zero or more parameters which will be sent to the constructor

*DESC
This function instantiates a Java object and then returns it as a result.

*E.G.
In> javaString := JavaNew("java.lang.String", "Hello")
Result: java.lang.String

In> javaString := JavaAccess(javaString, "toUpperCase")
Result: HELLO

*SEE JavaCall, JavaAccess, JavaToValue
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Subtract.java0000644000175000017500000000632111523200452030545 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Subtract extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int length = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        if (length == 2)
        {
            BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
            BigNumber z = new BigNumber(x);
            z.negate(x);
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
            return;
        } else
        {
            BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
            BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
            BigNumber yneg = new BigNumber(y);
            yneg.negate(y);
            BigNumber z = new BigNumber(aEnvironment.getPrecision());
            z.add(x, yneg, aEnvironment.getPrecision());
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
            return;
        }
    }
}//end class.




/*
%mathpiper_docs,name="SubtractN",categories="User Functions;Numeric;Built In"
*CMD SubtractN --- subtract two numbers (arbitrary-precision math function)
*CORE
*CALL
	SubtractN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CustomEvalLocals.java0000644000175000017500000000262211262036106032201 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CustomEvalLocals extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : LispCustomEvalLocals");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PipeToString.java0000644000175000017500000000521311523200452031344 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.StringOutputStream;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.io.MathPiperOutputStream;

/**
 *
 *  
 */
public class PipeToString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        StringBuffer oper = new StringBuffer();
        StringOutputStream newOutput = new StringOutputStream(oper);
        MathPiperOutputStream previous = aEnvironment.iCurrentOutput;
        aEnvironment.iCurrentOutput = newOutput;
        try
        {
            // Evaluate the body
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));

            //Return the getTopOfStackPointer
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(oper.toString())));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iCurrentOutput = previous;
        }
    }
}



/*
%mathpiper_docs,name="PipeToString",categories="User Functions;Input/Output;Built In"
*CMD PipeToString --- connect current output to a string
*CORE
*CALL
	PipeToString() body

*PARMS

{body} -- expression to be evaluated

*DESC

The commands in "body" are executed. Everything that is printed on
the current output, by {Echo} for instance, is
collected in a string and this string is returned.

*E.G.

In> str := PipeToString() [ WriteString(  \
	  "The square of 8 is "); Write(8^2); ];
Result: "The square of 8 is  64";

*SEE PipeFromFile, PipeToString, Echo, Write, WriteString
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/AskUser.java0000644000175000017500000000545711503734166030360 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import javax.swing.JOptionPane;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.BreakException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;

/**
 *
 *  
 */
public class AskUser extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "AskUser");


        Object argument = getArgumentPointer(aEnvironment, aStackTop, 1).car();

        LispError.check(argument instanceof String, "The argument to AskUser must be a string.", "INTERNAL", aStackTop, aEnvironment);

        String messageString = (String) argument;

        LispError.checkArgument(aEnvironment, aStackTop, messageString != null, 1, "AskUser");


        messageString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, messageString);

        String userInputString = JOptionPane.showInputDialog(null, messageString, "Message from MathPiper", JOptionPane.INFORMATION_MESSAGE);

        if(userInputString == null)
        {
            throw new BreakException();
        }//end method.

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"" + userInputString + "\""));
    }//end method.

}//end class.



/*
%mathpiper_docs,name="AskUser",categories="User Functions;Input/Output;Built In"
*CMD AskUser --- displays an input dialog to the user
*CORE
*CALL
	AskUser(message)

*PARMS

{message} -- a message which indicates what kind of input to enter

*DESC

This function allows information to be obtained from the user in the
form of a string.  A GUI dialog box will be displayed which the user
can use to enter their input.  If the user selects the cancel button,
the Break() function will be executed.

*SEE TellUser
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Secure.java0000644000175000017500000000373411332771351030222 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Secure extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        boolean prevSecure = aEnvironment.iSecure;
        aEnvironment.iSecure = true;
        try
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iSecure = prevSecure;
        }
    }
}



/*
%mathpiper_docs,name="Secure",categories="User Functions;Built In"
*CMD Secure --- guard the host OS
*CORE
*CALL
	Secure(body)

*PARMS

{body} -- expression

*DESC

{Secure} evaluates {body} in a "safe" environment, where files cannot be opened
and system calls are not allowed. This can help protect the system
when e.g. a script is sent over the
Internet to be evaluated on a remote computer, which is potentially unsafe.

*SEE SystemCall
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DestructiveReverse.java0000644000175000017500000000454411523200452032620 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class DestructiveReverse extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer reversed = new ConsPointer();
        reversed.setCons(aEnvironment.iListAtom.copy( aEnvironment, false));
        Utility.reverseList(aEnvironment, reversed.cdr(), ((ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car()).cdr());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,reversed.getCons()));
    }
}



/*
%mathpiper_docs,name="DestructiveReverse",categories="User Functions;Lists (Operations);Built In"
*CMD DestructiveReverse --- reverse a list destructively
*CORE
*CALL
	DestructiveReverse(list)

*PARMS

{list} -- list to reverse

*DESC

This command reverses "list" in place, so that the original is
destroyed. This means that any variable bound to "list" will now have
an undefined content, and should not be used any more.
The reversed list is returned.

Destructive commands are faster than their nondestructive
counterparts. {Reverse} is the non-destructive version of
this function.

*E.G.

In> lst := {a,b,c,13,19};
Result: {a,b,c,13,19};
In> revlst := DestructiveReverse(lst);
Result: {19,13,c,b,a};
In> lst;
Result: {a};

*SEE FlatCopy, Reverse
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CurrentFile.java0000644000175000017500000000370611332771351031215 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CurrentFile extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(aEnvironment.iInputStatus.fileName())));
    }
}



/*
%mathpiper_docs,name="CurrentFile",categories="Programmer Functions;Error Reporting;Built In"
*CMD CurrentFile --- return current input file
*CORE
*CALL
	CurrentFile()

*DESC

The functions {CurrentFile} returns a string
with the file name of the current file .

This function is most useful in batch file calculations, where
there is a need to determine at which line an error occurred.
One can define a function

	tst() := Echo({CurrentFile(),CurrentLine()});
which can then be inserted into the input file at various places,
to see how far the interpreter reaches before an error occurs.

*SEE Echo, CurrentLine

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/SetGlobalLazyVariable.java0000644000175000017500000000544611523200452033147 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class SetGlobalLazyVariable extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.setVar(aEnvironment, aStackTop, false, true);
    }
}




/*
%mathpiper_docs,name="SetGlobalLazyVariable",categories="User Functions;Variables;Built In"
*CMD SetGlobalLazyVariable --- global variable is to be evaluated lazily
*CORE
*CALL
	SetGlobalLazyVariable(var,value)

*PARMS

{var} -- variable (held argument)

{value} -- value to be set to (evaluated before it is assigned)

*DESC

{SetGlobalLazyVariable} enforces that a global variable will re-evaluate
when used. This functionality doesn't survive if {Unbind(var)}
is called afterwards.

Places where this is used include the global variables {%} and {I}.

The use of lazy in the name stems from the concept of lazy evaluation.
The object the global variable is bound to will only be evaluated when
called. The {SetGlobalLazyVariable} property only holds once: after
that, the result of evaluation is stored in the global variable, and it won't be reevaluated again:

In> SetGlobalLazyVariable(a,Hold(Taylor(x,0,30)Sin(x)))
Result: True

Then the first time you call {a} it evaluates {Taylor(...)} and assigns the result to {a}. The next time
you call {a} it immediately returns the result.
{SetGlobalLazyVariable} is called for {%} each time {%} changes.

The following example demonstrates the sequence of execution:

In> SetGlobalLazyVariable(test,Hold(Write("hello")))
Result: True

The text "hello" is not written out to screen yet. However, evaluating
the variable {test} forces the expression to be evaluated:

In> test
	"hello"Result: True

*E.G.

In> Set(a,Hold(2+3))
Result: True
In> a
Result: 2+3
In> SetGlobalLazyVariable(a,Hold(2+3))
Result: True
In> a
Result: 5


*SEE Bind, Unbind, Local, %, I
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BitsToDigits.java0000644000175000017500000000423711333354275031346 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class BitsToDigits extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        long result = 0;  // initialize just in case

        if (x.isInteger() && x.isSmall() && y.isInteger() && y.isSmall())
        {
            // bits_to_digits uses unsigned long, see numbers.h
            int base = (int) y.toDouble();
            result = Utility.bitsToDigits((long) (x.toDouble()), base);
        } else
        {
            throw new EvaluationException("BitsToDigits: error: arguments (" + x.toDouble() + ", " + y.toDouble() + ") must be small integers",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
        }
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo((long) result);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/And.java0000644000175000017500000001075411523200452027465 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class And extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer nogos = new ConsPointer();
        int nrnogos = 0;
        ConsPointer evaluated = new ConsPointer();

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null)
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, consTraverser.getPointer());
            if (Utility.isFalse(aEnvironment, evaluated, aStackTop))
            {
                Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                return;
            } else if (!Utility.isTrue(aEnvironment, evaluated, aStackTop))
            {
                ConsPointer ptr = new ConsPointer();
                nrnogos++;
                ptr.setCons(evaluated.getCons().copy( aEnvironment, false));
                ptr.cdr().setCons(nogos.getCons());
                nogos.setCons(ptr.getCons());
            }

            consTraverser.goNext(aStackTop);
        }

        if (nogos.getCons() != null)
        {
            if (nrnogos == 1)
            {
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(nogos.getCons());
            } else
            {
                ConsPointer ptr = new ConsPointer();

                Utility.reverseList(aEnvironment, ptr, nogos);
                nogos.setCons(ptr.getCons());

                ptr.setCons(getArgumentPointer(aEnvironment, aStackTop, 0).getCons().copy( aEnvironment, false));
                ptr.cdr().setCons(nogos.getCons());
                nogos.setCons(ptr.getCons());
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,nogos.getCons()));

            //aEnvironment.CurrentPrinter().Print(getTopOfStackPointer(aEnvironment, aStackTop), *aEnvironment.CurrentOutput());
            }
        } else
        {
            Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }
    }
}



/*
%mathpiper_docs,name="And",categories="User Functions;Predicates;Built In"
*CMD And --- logical conjunction
*CORE
*CALL
	a1 And a2
Precedence:
*EVAL PrecedenceGet("And")

	And(a1, a2, a3, ..., aN)

*PARMS

{a}1, ..., {a}N -- boolean values (may evaluate to {True} or {False})

*DESC

This function returns {True} if all arguments are true. The
{And} operation is "lazy", i.e. it returns {False} as soon as a {False} argument
is found (from left to right).  This is faster, but also means that none of the
arguments should cause side effects when they are evaluated.
 If an argument other than {True} or
{False} is encountered a new {And} expression is returned with all
arguments that didn't evaluate to {True} or {False} yet.
{And(...)} and {Or(...)} do also exist, defined in the script
library. You can redefine them as infix operators yourself, so you have the
choice of precedence. In the standard scripts they are in fact declared as
infix operators, so you can write {expr1 And expr}.

*E.G.

In> True And False
Result: False;
In> And(True,True)
Result: True;
In> False And a
Result: False;
In> True And a
Result: And(a);
In> And(True,a,True,b)
Result: b And a;

*SEE Or, Not
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LispRead.java0000644000175000017500000000436411523200452030466 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.parsers.Parser;

/**
 *
 *  
 */
public class LispRead extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Parser parser = new Parser(aEnvironment.iCurrentTokenizer,
                aEnvironment.iCurrentInput,
                aEnvironment);
        // Read expression
        parser.parse(aStackTop, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="LispRead",categories="User Functions;Input/Output;Built In"
*CMD LispRead --- read expressions in LISP syntax
*CORE
*CALL
	LispRead()

*DESC

The function {LispRead} reads an expression in the LISP syntax from the current input, and returns
it unevaluated. When the end of an input file is encountered, the
special token atom {EndOfFile} is returned.

The MathPiper expression {a+b} is written in the LISP syntax as {(+ a b)}. The advantage of this syntax is that it is
less ambiguous than the infix operator grammar that MathPiper uses by
default.

*E.G. notest

In> PipeFromString("(+ a b)") LispRead();
Result: a+b;
In> PipeFromString("(List (Sin x) (- (Cos x)))") \
	  LispRead();
Result: {Sin(x),-Cos(x)};
In> PipeFromString("(+ a b)")LispRead()
Result: a+b;

*SEE PipeFromFile, PipeFromString, Read, ReadToken, LispForm, LispReadListed
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastLog.java0000644000175000017500000000345711333354275030340 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class FastLog extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;
        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        double result = Math.log(x.toDouble());
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(result);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastLog",categories="Programmer Functions;Built In"
*CMD FastLog --- double-precision natural logarithm
*CORE
*CALL
	FastLog(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastPower, FastArcSin

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ExitRequested.java0000644000175000017500000000234011226771211031554 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class ExitRequested extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/GenericTypeName.java0000644000175000017500000000401011523200452031766 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class GenericTypeName extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.car() instanceof BuiltinContainer, 1, "GenericTypeName");
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, ((BuiltinContainer) evaluated.car()).typeName()));
    }
}//end class.



/*
%mathpiper_docs,name="GenericTypeName",categories="Programmer Functions;Native Objects;Built In"
*CMD GenericTypeName --- get type name
*CORE
*CALL
	GenericTypeName(object)

*DESC
Returns a string representation of
the name of a generic object.

*E.G.

In> GenericTypeName(ArrayCreate(10,1))
Result: "Array";

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/First.java0000644000175000017500000000333211523200452030044 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class First extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.nth(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1), 1);
    }
}



/*
%mathpiper_docs,name="First",categories="User Functions;Lists (Operations);Built In"
*CMD First --- the first element of a list
*CORE
*CALL
	First(list)

*PARMS

{list} -- a list

*DESC

This function returns the first element of a list. If it is applied to
a general expression, it returns the first operand. An error is
returned if "list" is an atom.

*E.G.

In> First({a,b,c})
Result: a;
In> First(f(a,b,c));
Result: a;

*SEE Rest, Length
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Subst.java0000644000175000017500000000510311523200452030053 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Subst extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer from = new ConsPointer(), to = new ConsPointer(), body = new ConsPointer();
        from.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        to.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        body.setCons(getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        org.mathpiper.lisp.behaviours.ExpressionSubstitute behaviour = new org.mathpiper.lisp.behaviours.ExpressionSubstitute(aEnvironment, from, to);
        Utility.substitute(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), body, behaviour);
    }
}


/*
%mathpiper_docs,name="Subst",categories="User Functions;Expression Manipulation;Built In"
*CMD Subst --- perform a substitution
*CORE
*CALL
	Subst(from, to) expr

*PARMS

{from} -- expression to be substituted

{to} -- expression to substitute for "from"

{expr} -- expression in which the substitution takes place

*DESC

This function substitutes every occurrence of "from" in "expr" by
"to". This is a syntactical substitution: only places where "from"
occurs as a subexpression are affected.

*E.G.

In> Subst(x, Sin(y)) x^2+x+1;
Result: Sin(y)^2+Sin(y)+1;
In> Subst(a+b, x) a+b+c;
Result: x+c;
In> Subst(b+c, x) a+b+c;
Result: a+b+c;

The explanation for the last result is that the expression {a+b+c} is internally stored as {(a+b)+c}. Hence {a+b} is a subexpression, but {b+c} is not.

*SEE WithValue, /:
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PatternCreate.java0000644000175000017500000000522211420662456031532 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.PatternContainer;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class PatternCreate extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer patternPointer = new ConsPointer();
        patternPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        ConsPointer postPredicatePointer = new ConsPointer();
        postPredicatePointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        ConsTraverser patternPointerTraverser = new ConsTraverser(aEnvironment, patternPointer);
        LispError.checkArgument(aEnvironment, aStackTop, patternPointerTraverser.getCons() != null, 1, "PatternCreate");
        LispError.checkArgument(aEnvironment, aStackTop, patternPointerTraverser.car() instanceof ConsPointer, 1, "PatternCreate");
        patternPointerTraverser.goSub(aStackTop);
        LispError.checkArgument(aEnvironment, aStackTop, patternPointerTraverser.getCons() != null, 1, "PatternCreate");
        patternPointerTraverser.goNext(aStackTop);

        patternPointer = patternPointerTraverser.getPointer();


        org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher matcher = new org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher(aEnvironment, aStackTop, patternPointer, postPredicatePointer);
        PatternContainer patternContainer = new PatternContainer(matcher);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, patternContainer));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/JavaAccess.java0000644000175000017500000000477211506531763031006 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *
 */
public class JavaAccess extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer args = new ConsPointer();

        args.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        args.goSub(aStackTop, aEnvironment);

        args.goNext(aStackTop, aEnvironment);

        ConsPointer result = new ConsPointer();

        Utility.applyString(aEnvironment, aStackTop, result, "\"JavaCall\"", args);

        Utility.applyString(aEnvironment, aStackTop, result, "\"JavaToValue\"", result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(result.getCons());

    }//end method.
}



/*
%mathpiper_docs,name="JavaAccess",categories="Programmer Functions;Built In;Native Objects",access="experimental"
*CMD JavaAccess --- calls a method on a Java object and converts the result into a MathPiper data structure
*CALL
    JavaAccess(javaObject, methodName, methodParameter1, methodParameter2, ...)

*PARMS
{javaObject} -- a Java object

{methodName} -- the name of a method to call on the Java object (it can be either a string or an atom)

{methodParameters} -- zero or more parameters which will be sent to the method

*DESC
This is a convenience function which can be used instead of using JavaCall and JavaToValue.

*E.G.
In> javaString := JavaNew("java.lang.String", "Hello")
Result: java.lang.String

In> JavaAccess(javaString, "charAt",1)
Result: e

*SEE JavaNew, JavaCall, JavaToValue
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Postfix.java0000644000175000017500000000444711523200452030421 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Postfix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int nrArguments = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        if (nrArguments == 2)
        {
            Utility.singleFix(0, aEnvironment, aStackTop, aEnvironment.iPostfixOperators);
        } else
        {
            Utility.multiFix(aEnvironment, aStackTop, aEnvironment.iPostfixOperators);
        }
    }
}



/*
%mathpiper_docs,name="Postfix",categories="User Functions;Built In"
*CMD Postfix --- define function syntax (postfix operator)
*CORE
*CALL
	Postfix("op")
	Postfix("op", precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer (evaluated)

*DESC

Declares a special syntax for the function to be parsed as a bodied, infix, postfix,
or prefix operator.

"Postfix" functions must have one argument and are syntactically placed after their argument.

Function name can be any string but meaningful usage and readability would
require it to be either made up entirely of letters or entirely of non-letter
characters (such as "+", ":" etc.).
Precedence is optional (will be set to 0 by default).

*E.G.
In> todo

*SEE IsBodied, PrecedenceGet, Bodied, Infix, Prefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ShiftLeft.java0000644000175000017500000000346511345636344030673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class ShiftLeft extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber n = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        long nrToShift = n.toLong();
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.shiftLeft(x, (int) nrToShift, null, aStackTop);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper_docs,name="ShiftLeft",categories="User Functions;Built In"
*CMD ShiftLeft --- built-in bitwise shift left operation
*CORE
*CALL
	ShiftLeft(expr,bits)

*DESC

Shift bits to the left.

*SEE ShiftRight
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Concatenate.java0000644000175000017500000000541411523200452031204 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *  
 */
public class Concatenate extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer all = new ConsPointer();
        all.setCons(aEnvironment.iListAtom.copy( aEnvironment, false));
        ConsTraverser tail = new ConsTraverser(aEnvironment, all);
        tail.goNext(aStackTop);
        int arg = 1;

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car());
        consTraverser.goNext(aStackTop);
        while (consTraverser.getCons() != null)
        {
            LispError.checkIsList(aEnvironment, aStackTop, consTraverser.getPointer(), arg, "Concatenate");
            Utility.flatCopy(aEnvironment, aStackTop, tail.getPointer(), ((ConsPointer) consTraverser.getPointer().car()).cdr());
            while (tail.getCons() != null)
            {
                tail.goNext(aStackTop);
            }
            consTraverser.goNext(aStackTop);
            arg++;
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment,all.getCons()));
    }
}



/*
%mathpiper_docs,name="Concat",categories="User Functions;Lists (Operations);Built In"
*CMD Concat --- concatenate lists
*CORE
*CALL
	Concat(list1, list2, ...)

*PARMS

{list1}, {list2}, ... -- lists to concatenate

*DESC

The lists "list1", "list2", ... are evaluated and
concatenated. The resulting big list is returned.

*E.G.

In> Concat({a,b}, {c,d});
Result: {a,b,c,d};
In> Concat({5}, {a,b,c}, {{f(x)}});
Result: {5,a,b,c,{f(x)}};

*SEE ConcatStrings, :, Insert
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ReadToken.java0000644000175000017500000000643411523200452030637 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;

/**
 *
 * 
 */
public class ReadToken extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        MathPiperTokenizer tok = aEnvironment.iCurrentTokenizer;
        String result;
        result = tok.nextToken(aEnvironment, aStackTop, aEnvironment.iCurrentInput, aEnvironment.getTokenHash());

        if (result.length() == 0)
        {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(aEnvironment.iEndOfFileAtom.copy( aEnvironment, false));
            return;
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, result));
    }
}



/*
%mathpiper_docs,name="ReadToken",categories="User Functions;Input/Output;Built In"
*CMD ReadToken --- read a token from current input
*CORE
*CALL
	ReadToken()

*DESC

Read a token from the current input, and return it unevaluated.
The returned object is a MathPiper atom (not a string).
When
the end of an input file is encountered, the token atom {EndOfFile} is returned.

A token is for computer languages what a word is for human languages:
it is the smallest unit in which a command can be divided, so that the
semantics (that is the meaning) of the command is in some sense a
combination of the semantics of the tokens. Hence {a := foo} consists of three tokens, namely {a}, {:=}, and {foo}.

The parsing of the string depends on the syntax of the language.
The part of the kernel that does the parsing is the "tokenizer".
MathPiper can parse its own syntax (the default tokenizer) or it can be instructed to parse XML or C++ syntax using the directives {DefaultTokenizer} or {XmlTokenizer}.
Setting a tokenizer is a global action that affects all {ReadToken} calls.

*E.G. notest

In> PipeFromString("a := Sin(x)") While \
	  ((tok := ReadToken()) != EndOfFile) \
	  Echo(tok);
	a
	:=
	Sin
	(
	x
	)
Result: True;

We can read some junk too:
In> PipeFromString("-$3")ReadToken();
Result: -$;
The result is an atom with the string representation {-$}.
MathPiper assumes that {-$} is an operator symbol yet to be defined.
The "{3}" will be in the next token.
(The results will be different if a non-default tokenizer is selected.)


*SEE PipeFromFile, PipeFromString, Read, LispRead, DefaultTokenizer
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BitCount.java0000644000175000017500000000264311333354275030524 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class BitCount extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(x.bitCount());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Prefix.java0000644000175000017500000000433111523200452030212 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Prefix extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.multiFix(aEnvironment, aStackTop, aEnvironment.iPrefixOperators);
    }
}



/*
%mathpiper_docs,name="Prefix",categories="User Functions;Built In"
*CMD Prefix --- define function syntax (prefix operator)
*CORE
*CALL
	Prefix("op")
	Prefix("op", precedence)

*PARMS

{"op"} -- string, the name of a function

{precedence} -- nonnegative integer (evaluated)

*DESC

"Prefix" functions must have one argument and are syntactically placed before their argument.

Function name can be any string but meaningful usage and readability would
require it to be either made up entirely of letters or entirely of non-letter
characters (such as "+", ":" etc.).
Precedence is optional (will be set to 0 by default).

*E.G.
In> YY x := x+1;
	CommandLine(1) : Error parsing expression

In> Prefix("YY", 2)
Result: True;
In> YY x := x+1;
Result: True;
In> YY YY 2*3
Result: 12;

Note that, due to a current parser limitation, a function atom that is declared prefix cannot be used by itself as an argument.

In> YY
	CommandLine(1) : Error parsing expression

*SEE IsBodied, PrecedenceGet, Bodied, Infix, Postfix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Abs.java0000644000175000017500000000505011447327057027501 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Abs extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(x);
        if (x.sign() < 0)
        {
            z.negate(x);
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.



/*
%mathpiper_docs,name="AbsN",categories="User Functions;Numeric;Built In"
*CMD AbsN --- absolute value of x or |x| (arbitrary-precision math function)
*CORE
*CALL
	AbsN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In> AbsN(-1)
Result: 1

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PipeToStdout.java0000644000175000017500000000430311523200452031357 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.io.MathPiperOutputStream;

/**
 *
 *  
 */
public class PipeToStdout extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        MathPiperOutputStream previous = aEnvironment.iCurrentOutput;
        aEnvironment.iCurrentOutput = aEnvironment.iInitialOutput;
        try
        {
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iCurrentOutput = previous;
        }
    }
}



/*
%mathpiper_docs,name="PipeToStdout",categories="User Functions;Input/Output;Built In"
*CMD PipeToStdout --- select initial output stream for output
*CORE
*CALL
	PipeToStdout() body

*PARMS

{body} -- expression to be evaluated

*DESC

When using {PipeToString} or {PipeToFile}, it might happen that something needs to be
written to the standard default initial output (typically the screen). {PipeToStdout} can be used to select this stream.

*E.G.

In> PipeToString()[Echo("aaaa");PipeToStdout()Echo("bbbb");];
	bbbb
Result: "aaaa
	"

*SEE PipeToString, PipeToFile
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DumpNumber.java0000644000175000017500000000444211506531763031053 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.Cons;

/**
 *
 *  
 */
public class DumpNumber extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        Cons resultCons = x.dumpNumber(aEnvironment, aStackTop);

        /*
        ConsPointer isVerbosePointer = Utility.lispEvaluate(aEnvironment, aStackTop, "InVerboseMode();");

        if(((String)isVerbosePointer.car()).equals("True"))
        {
            x.dumpNumber(aEnvironment, aStackTop, aEnvironment.iCurrentOutput);
        }
        */

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(resultCons);


    }//end method.

}//end class.




/*
%mathpiper_docs,name="DumpNumber",categories="Programmer Functions;Numerical (Arbitrary Precision);Built In"
*CMD DumpNumber --- prints the implementation details of a number
*CORE
*CALL
	DumpNumber(x)

*PARAMS
 * 
{x} -- an integer or decimal number.


*DESC

This function prints the implementation details of an integer or decimal number.

*E.G.
In> DumpNumber(4)
Result> {{"type","BigInteger"},{"value",4}}

In> DumpNumber(3.2)
Result> {{"type","BigDecimal"},{"value",3.2},{"precision",2},{"unscaledValue",32},{"scale",1}}

In> DumpNumber(3.2)["precision"]
Result> 2

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefMacroRulebaseListed.java0000644000175000017500000000332011445560600033271 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DefMacroRulebaseListed extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.defMacroRulebase(aEnvironment, aStackTop, true);
    }
}



/*
%mathpiper_docs,name="DefMacroRulebaseListed",categories="Programmer Functions;Programming;Built In"
*CMD DefMacroRulebaseListed --- define macro with variable number of arguments
*CORE
*CALL
	DefMacroRulebaseListed("name", params)

*PARMS

{"name"} -- string, name of function

{params} -- list of arguments to function

*DESC

This does the same as {DefMacroRulebase} (define a macro), but with a variable
number of arguments, similar to {RulebaseListed}.

*SEE Rulebase, RulebaseListed, `, DefMacroRulebase
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PatchString.java0000644000175000017500000000511511506531763031221 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.InputStatus;
import org.mathpiper.io.StringOutputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;

/**
 *
 *  
 */
public class PatchString extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        String unpatchedString = 
            (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, unpatchedString != null, 2, "PatchString");
        
        InputStatus oldStatus = new InputStatus(aEnvironment.iInputStatus);
        aEnvironment.iInputStatus.setTo("STRING");
        
        StringBuffer resultBuffer = new StringBuffer();
        StringOutputStream resultStream = new StringOutputStream(resultBuffer);
        
        Utility.doPatchString(unpatchedString, resultStream, aEnvironment, aStackTop);
        
        aEnvironment.iInputStatus.restoreFrom(oldStatus);
        
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, resultBuffer.toString()));
    }


}//end class.



/*
%mathpiper_docs,name="PatchString",categories="User Functions;String Manipulation;Built In"
*CMD PatchString --- execute commands between {} in strings
*CORE
*CALL
	PatchString(string)

*PARMS

{string} -- a string to patch

*DESC

This function does the same as PatchLoad, but it works on a string
in stead of on the contents of a text file. See PatchLoad for more
details.

*E.G.
In> PatchString("Two plus three is  ");
Result: "Two plus three is 5 ";

*SEE PatchLoad
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/GarbageCollect.java0000644000175000017500000000242611226771211031624 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class GarbageCollect extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.getTokenHash().garbageCollect();
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CustomEvalExpression.java0000644000175000017500000000262611262036106033127 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CustomEvalExpression extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : CustomEvalExpression");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/WriteString.java0000644000175000017500000000555211523200452031244 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class WriteString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "WriteString");
        String str = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, str != null, 1, "WriteString");
        LispError.checkArgument(aEnvironment, aStackTop, str.charAt(0) == '\"', 1, "WriteString");
        LispError.checkArgument(aEnvironment, aStackTop, str.charAt(str.length() - 1) == '\"', 1, "WriteString");

        int i = 1;
        int nr = str.length() - 1;
        //((*str)[i] != '\"')
        for (i = 1; i < nr; i++)
        {
            aEnvironment.iCurrentOutput.putChar(str.charAt(i));
        }
        // pass last printed character to the current printer
        aEnvironment.iCurrentPrinter.rememberLastChar(str.charAt(nr - 1));  // hacky hacky

        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="WriteString",categories="User Functions;Input/Output;Built In"
*CMD WriteString --- low-level printing routine for strings
*CORE
*CALL
	WriteString(string)

*PARMS

{string} -- the string to be printed

*DESC

The expression "string" is evaluated and written to the current
output without quotation marks. The argument should be a
string. WriteString always returns True.

*E.G. notest

In> Write("Hello, world!");
	"Hello, world!"Result: True;
In> WriteString("Hello, world!");
	Hello, world!Result: True;

This example clearly shows the difference between Write and
WriteString. Note that Write and WriteString do not write a newline,
so the {Result:} prompt immediately follows the output.

*SEE Echo, Write
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Retract.java0000644000175000017500000000621111417206705030371 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Retract extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "Retract");
        String orig = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "Retract");
        String oper = Utility.getSymbolName(aEnvironment, orig);

        ConsPointer arityPointer = new ConsPointer();
        arityPointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, arityPointer.car() instanceof String, 2, "Retract");
        String arityString = (String) arityPointer.car();
        if(arityString.equalsIgnoreCase("*"))
        {
            aEnvironment.retractRule(oper, -1, aStackTop, aEnvironment);
        }
        else
        {
            int arity = Integer.parseInt(arityString, 10);
            aEnvironment.retractRule(oper, arity, aStackTop, aEnvironment);
        }
  
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="Retract",categories="User Functions;Built In"
*CMD Retract --- erase rules for a function
*CORE
*CALL
	Retract("function",arity)

*PARMS
{"function"} -- string, name of function

{arity} -- positive integer or *

*DESC

Remove a rulebase for the function named {"function"} with the specific {arity}, if it exists at all. This will make
MathPiper forget all rules defined for a given function with the given arity. Rules for functions with
the same name but different arities are not affected unless the * wildcard character is used.  If * is used for the
arity, then all arities of the rulebase are removed.

Assignment {:=} of a function automatically does a single arity retract to the function being (re)defined.

*SEE RulebaseArgumentsList, Rulebase, :=
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MacroRule.java0000644000175000017500000000350311500331432030644 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MacroRule extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.newRule(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="MacroRule",categories="Programmer Functions;Programming;Built In"
*CMD MacroRule --- define rules in functions
*CORE
*DESC

This function has the same effect as its non-macro counterpart, except
that its arguments are evaluated before the required action is performed.
This is useful in macro-like procedures or in functions that need to define new
rules based on parameters.

Make sure that the arguments of {Macro}... commands evaluate to expressions that would normally be used in the non-macro version!

*SEE Bind, Unbind, Local, Rulebase, Rule, `, MacroBind, MacroUnbind, MacroLocal, MacroRulebase, MacroRulebaseListed
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Bind.java0000644000175000017500000000346011523200452027633 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Bind extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.setVar(aEnvironment, aStackTop, false, false);
    }
}



/*
%mathpiper_docs,name="Bind",categories="User Functions;Variables;Built In"
*CMD Bind --- assignment
*CORE
*CALL
	Bind(var, exp)

*PARMS

{var} -- variable which should be assigned

{exp} -- expression to assign to the variable

*DESC

The expression "exp" is evaluated and assigned it to the variable
named "var". The first argument is not evaluated. The value True
is returned.

The statement {Bind(var, exp)} is equivalent to {var := exp}, but the {:=} operator
has more uses, e.g. changing individual entries in a list.

*E.G.

In> Bind(a, Sin(x)+3);
Result: True;
In> a;
Result: Sin(x)+3;

*SEE Unbind, :=
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastSin.java0000644000175000017500000000400511506531763030337 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class FastSin extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;

        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.sin(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The result is NaN.", "FastSin", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastSin",categories="Programmer Functions;Built In"
*CMD FastSin --- double-precision math function
*CORE
*CALL
	FastSin(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MathNegate.java0000644000175000017500000000263311333354275031011 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MathNegate extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.negate(x);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/RightPrecedenceGet.java0000644000175000017500000000554111523200452032454 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.LispError;

/**
 *
 *  
 */
public class RightPrecedenceGet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iInfixOperators);
        if (op == null)
        {   // bodied, infix and prefix operators have right precedence

            op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iPrefixOperators);
            if (op == null)
            {   // or maybe it's a bodied function

                op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iBodiedOperators);
                LispError.check(aEnvironment, aStackTop, op != null, LispError.IS_NOT_INFIX);
            }
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + op.iRightPrecedence));
    }
}



/*
%mathpiper_docs,name="RightPrecedenceGet",categories="Programmer Functions;Programming;Built In"
*CMD RightPrecedenceGet --- get operator precedence
*CORE
*CALL
	RightPrecedenceGet("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Returns the precedence of the function named "op" which should have been declared as a bodied function or an infix, postfix, or prefix operator. Generates an error message if the string str does not represent a type of function that can have precedence.

For infix operators, right precedence can differ from left precedence. Bodied functions and prefix operators cannot have left precedence, while postfix operators cannot have right precedence; for these operators, there is only one value of precedence.

*E.G.
In> RightPrecedenceGet("+")
Result: 70

*SEE PrecedenceGet,LeftPrecedenceGet,LeftPrecedenceSet,RightPrecedenceSet,RightAssociativeSet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/HoldArgument.java0000644000175000017500000000525511417443641031367 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class HoldArgument extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "HoldArgument");
        String orig =  (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "HoldArgument");

        // The arguments
        String tohold =  (String) getArgumentPointer(aEnvironment, aStackTop, 2).car();
        LispError.checkArgument(aEnvironment, aStackTop, tohold != null, 2, "HoldArgument");
        aEnvironment.holdArgument(aStackTop, Utility.getSymbolName(aEnvironment, orig), tohold, aEnvironment);
        // Return true
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="HoldArgument",categories="Programmer Functions;Programming;Built In"
*CMD HoldArgument --- mark argument as not evaluated
*CORE
*CALL
	HoldArgument("operator",parameter)

*PARMS

{"operator"} -- string, name of a function

{parameter} -- atom, symbolic name of parameter

*DESC
Specify that parameter should
not be evaluated before used. This will be
declared for all arities of "operator", at the moment
this function is called, so it is best called
after all {Rulebase} calls for this operator.
"operator" can be a string or atom specifying the
function name.

The {parameter} must be an atom from the list of symbolic
arguments used when calling {Rulebase}.

*SEE Rulebase, HoldArgumentNumber, RulebaseArgumentsList
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastIsPrime.java0000644000175000017500000000376211333354275031166 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class FastIsPrime extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        //TODO fixme this routine should actually be called SlowIsPrime ;-)
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        long n = x.toLong();
        long result = 1;

        // We only want people to pass in small integers
        if (n > 65538)
        {
            result = 0;
        }
        int i = 2;
        int max = (int) (1 + Math.sqrt(n));
        //System.out.println("n = "+n+" max = "+max);
        while (i <= max && result == 1)
        {
            //System.out.println(""+n+"%"+i+" = "+(n%i));
            if ((n % i) == 0)
            {
                result = 0;
            }
            i++;
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(result);
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/CustomEval.java0000644000175000017500000000260211262036106031041 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class CustomEval extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : CustomEval");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsLessThan.java0000644000175000017500000000312311516131015030770 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class IsLessThan extends BuiltinFunction
{

    LexLessThan compare = new LexLessThan();

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        compare.Compare(aEnvironment, aStackTop);
    }
}//end class.




/*
%mathpiper_docs,name="IsLessThan",categories="User Functions;Predicates;Built In"
*CMD IsLessThan --- comparison predicate
*CORE
*CALL
	IsLessThan(a,b)

*PARMS
{a}, {b} -- decimal numbers or strings
*DESC
Compare decimal numbers or strings (lexicographically).

*E.G.
In> IsLessThan(1,1)
Result: False;
In> IsLessThan("a","b")
Result: True;

*SEE IsGreaterThan, IsEqual
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Factorial.java0000644000175000017500000000414711345636344030705 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class Factorial extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons().getNumber(0, aEnvironment) != null, 1, "Factorial");
        ConsPointer arg = getArgumentPointer(aEnvironment, aStackTop, 1);

        //TODO fixme I am sure this can be optimized still
//        LispError.check(arg.type().equals("Number"), LispError.INVALID_ARGUMENT);
        int nr = (int) ((BigNumber) arg.getCons().getNumber(0, aEnvironment)).toLong();
        LispError.check(aEnvironment, aStackTop, nr >= 0, LispError.INVALID_ARGUMENT, "Factorial");
        BigNumber fac = new BigNumber( "1", 10, 10);
        int i;
        for (i = 2; i <= nr; i++)
        {
            BigNumber m = new BigNumber( "" + i, 10, 10);
            m.multiply(fac, m, 0);
            fac = m;
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(fac));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MathIsSmall.java0000644000175000017500000000255511226771211031147 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class MathIsSmall extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), x.isSmall());
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ViewConsole.java0000644000175000017500000000521411506531763031230 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import java.awt.Dimension;
import java.awt.BorderLayout;
import java.awt.Container;
import javax.swing.JFrame;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.ui.gui.consoles.Console;

/**
 *
 *
 */
public class ViewConsole extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Console console = new Console();

        JFrame frame = new javax.swing.JFrame();
        Container contentPane = frame.getContentPane();
        contentPane.add(console, BorderLayout.CENTER);
        //frame.setAlwaysOnTop(true);
        frame.setSize(new Dimension(800, 600));
        frame.setDefaultCloseOperation(JFrame.DISPOSE_ON_CLOSE);
        //frame.setResizable(false);
        frame.setPreferredSize(new Dimension(800, 600));
        frame.setLocationRelativeTo(null); // added
        frame.pack();
        frame.setVisible(true);

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="ViewConsole",categories="User Functions;Built In"
*CMD ViewConsole --- show the console window
*CORE
*CALL
    ViewConsole()

*DESC

Shows the console window.

*E.G.
The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewConsole()
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/TraceStack.java0000644000175000017500000000635711523200452031013 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class TraceStack extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        aEnvironment.write("Function not yet implemented : TraceStack");////TODO fixme

        throw new EvaluationException("Function not yet supported",aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
    }
}



/*
%mathpiper_docs,name="TraceStack",categories="User Functions;Control Flow;Built In",access="private"
*CMD TraceStack --- show calling stack after an error occurs
*CORE
*CALL
	TraceStack(expression)

*PARMS

{expression} -- an expression to evaluate

*DESC

TraceStack shows the calling stack after an error occurred.
It shows the last few items on the stack, not to flood the screen.
These are usually the only items of interest on the stack.
This is probably by far the most useful debugging function in
MathPiper. It shows the last few things it did just after an error
was generated somewhere.

For each stack frame, it shows if the function evaluated was a
built-in function or a user-defined function, and for the user-defined
function, the number of the rule it is trying whether it was evaluating
the pattern matcher of the rule, or the body code of the rule.

This functionality is not offered by default because it slows
down the evaluation code.

*E.G. notest

Here is an example of a function calling itself recursively,
causing MathPiper to flood its stack:

In> f(x):=f(Sin(x))
Result: True;
In> TraceStack(f(2))
	Debug> 982 :  f (Rule # 0 in body)
	Debug> 983 :  f (Rule # 0 in body)
	Debug> 984 :  f (Rule # 0 in body)
	Debug> 985 :  f (Rule # 0 in body)
	Debug> 986 :  f (Rule # 0 in body)
	Debug> 987 :  f (Rule # 0 in body)
	Debug> 988 :  f (Rule # 0 in body)
	Debug> 989 :  f (Rule # 0 in body)
	Debug> 990 :  f (Rule # 0 in body)
	Debug> 991 :  f (Rule # 0 in body)
	Debug> 992 :  f (Rule # 0 in body)
	Debug> 993 :  f (Rule # 0 in body)
	Debug> 994 :  f (Rule # 0 in body)
	Debug> 995 :  f (User function)
	Debug> 996 :  Sin (Rule # 0 in pattern)
	Debug> 997 :  IsList (Internal function)
	Error on line 1 in file [CommandLine]
	Max evaluation stack depth reached.
	Please use MaxEvalDepth to increase the stack
	size as needed.

*SEE TraceExp, TraceRule
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Type.java0000644000175000017500000000460711523200452027704 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;


import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


/**
 *
 *  
 */
public class Type extends BuiltinFunction {

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer evaluated = new ConsPointer();

        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        String functionType = Utility.functionType(evaluated);

        if (functionType.equals("")) {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "\"\""));
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, aEnvironment.getTokenHash().lookUpStringify(functionType)));
        }
    }//end method.


}//end class.



/*
%mathpiper_docs,name="Type",categories="User Functions;Lists (Operations);Built In"
*CMD Type --- return the type of an expression
*CORE
*CALL
	Type(expr)

*PARMS

{expr} -- expression to examine

*DESC

The type of the expression "expr" is represented as a string and
returned. So, if "expr" is a list, the string {"List"} is returned. In general, the top-level
operator of "expr" is returned. If the argument "expr" is an atom,
the result is the empty string {""}.

*E.G.

In> Type({a,b,c});
Result: "List";
In> Type(a*(b+c));
Result: "*";
In> Type(123);
Result: "";

*SEE IsAtom, ArgumentsCount
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsEqual.java0000644000175000017500000000375611333354275030346 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsEqual extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated1 = new ConsPointer();
        evaluated1.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        ConsPointer evaluated2 = new ConsPointer();
        evaluated2.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop),
                Utility.equals(aEnvironment, aStackTop, evaluated1, evaluated2));
    }
}//end class.




/*
%mathpiper_docs,name="IsEqual",categories="User Functions;Built In"
*CMD IsEqual --- check equality
*CORE
*CALL
	IsEqual(a,b)

*DESC
Compares evaluated {a} and {b} recursively
(stepping into expressions). So "IsEqual(a,b)" returns
"True" if the expressions would be printed exactly
the same, and "False" otherwise.

*SEE GreaterThan, IsLessThan

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LexLessThan.java0000644000175000017500000000236211332473164031163 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.lisp.collections.TokenMap;

/**
 *
 *  
 */
public class LexLessThan extends LexCompare2
{

    boolean lexFunction(String f1, String f2, TokenMap aHashTable, int aPrecision)
    {
        return f1.compareTo(f2) < 0;
    }

    boolean numFunction(BigNumber n1, BigNumber n2)
    {
        return n1.lessThan(n2) && !n1.equals(n2);
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DestructiveInsert.java0000644000175000017500000000430211523200452032441 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DestructiveInsert extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.insert(aEnvironment, aStackTop, true);
    }
}



/*
%mathpiper_docs,name="DestructiveInsert",categories="User Functions;Lists (Operations);Built In"
*CMD DestructiveInsert --- insert an element destructively into a list
*CORE
*CALL
	DestructiveInsert(list, n, expr)

*PARMS

{list} -- list in which "expr" should be inserted

{n} -- index at which to insert

{expr} -- expression to insert in "list"

*DESC

This is the destructive counterpart of {Insert}. This
command yields the same result as the corresponding call to
{Insert}, but the original list is modified. So if a
variable is bound to "list", it will now be bound to the list with
the expression "expr" inserted.

Destructive commands run faster than their nondestructive counterparts
because the latter copy the list before they alter it.

*E.G.

In> lst := {a,b,c,d};
Result: {a,b,c,d};
In> Insert(lst, 2, x);
Result: {a,x,b,c,d};
In> lst;
Result: {a,b,c,d};
In> DestructiveInsert(lst, 2, x);
Result: {a,x,b,c,d};
In> lst;
Result: {a,x,b,c,d};

*SEE Insert, DestructiveDelete, DestructiveReplace
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Check.java0000644000175000017500000000657511503734166030022 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Check extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer pred = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, pred, getArgumentPointer(aEnvironment, aStackTop, 1));
        if (!Utility.isTrue(aEnvironment, pred, aStackTop))
        {
            ConsPointer type = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, type, getArgumentPointer(aEnvironment, aStackTop, 2));
            LispError.checkIsString(aEnvironment, aStackTop, type, 2, "Check");
            
            
            
            ConsPointer message = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, message, getArgumentPointer(aEnvironment, aStackTop, 3));
            LispError.checkIsString(aEnvironment, aStackTop, message, 3, "Check");



            throw new EvaluationException( Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, (String) type.car()), Utility.toNormalString(aEnvironment, aStackTop, (String) message.car()), aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber(), "Check");
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(pred.getCons());
    }
}



/*
%mathpiper_docs,name="Check",categories="Programmer Functions;Error Reporting;Built In"
*CMD Check --- throw an exception if a predicate expression returns False
*CORE
*CALL
	Check(predicate, "exceptionType", "exceptionMessage")

*PARMS

{predicate} -- expression returning {True} or {False}

{"exceptionType"} -- string which indicates the type of the exception

{"exceptionMessage"} -- string which holds the exception message

*DESC
If {predicate} does not evaluate to {True},
the current operation will be stopped and an exception will be thrown.
This facility can be used to assure that some condition
is satisfied during evaluation of expressions.

Exceptions that are thrown by this function can be caught by the {ExceptionCatch} function.



*E.G.

In> Check(IsInteger(2.3), "Argument", "The argument must be an integer.")
Result: Exception
Exception: The argument must be an integer.


*SEE ExceptionCatch, ExceptionGet

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/FastCos.java0000644000175000017500000000400511506531763030332 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;

/**
 *
 *
 */
public class FastCos extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x;

        x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        double xDouble = x.toDouble();

        double result = Math.cos(xDouble);

        if(Double.isNaN(result))
        {
            LispError.raiseError("The result is NaN.", "FastCos", aStackTop, aEnvironment);
        }

        BigNumber z = new BigNumber(aEnvironment.getPrecision());

        z.setTo(result);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}//end class.




/*
%mathpiper,name="FastCos",categories="Programmer Functions;Built In"
*CMD FastCos --- double-precision math function
*CORE
*CALL
	FastCos(x)

*PARMS
{a} -- a number

*DESC
This function uses the Java math library. It
should be faster than the arbitrary precision version.

*SEE FastLog, FastPower

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/ListToFunction.java0000644000175000017500000000567011523200452031710 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class ListToFunction extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "ListToFunction");
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer, 1, "ListToFunction");
        Cons atom = ((ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car()).getCons();
        LispError.checkArgument(aEnvironment, aStackTop, atom != null, 1, "ListToFunction");
        LispError.checkArgument(aEnvironment, aStackTop, atom.car() == aEnvironment.iListAtom.car(), 1, "ListToFunction");
        Utility.tail(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 1));
    }
}



/*
%mathpiper_docs,name="ListToFunction",categories="User Functions;Lists (Operations);Built In"
*CMD ListToFunction --- convert a list to a function application
*CORE
*CALL
	ListToFunction(list)

*PARMS

{list} -- list to be converted

*DESC

This command converts a list to a function application. The car
entry of "list" is treated as a function atom, and the following entries
are the arguments to this function. So the function referred to in the
car element of "list" is applied to the other elements.

Note that "list" is evaluated before the function application is
formed, but the resulting expression is left unevaluated. The functions {ListToFunction()} and {Hold()} both stop the process of evaluation.

*E.G.

In> ListToFunction({Cos, x});
Result: Cos(x);
In> ListToFunction({f});
Result: f();
In> ListToFunction({Taylor,x,0,5,Cos(x)});
Result: Taylor(x,0,5)Cos(x);
In> Eval(%);
Result: 1-x^2/2+x^4/24;

*SEE List, FunctionToList, Hold
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Local.java0000644000175000017500000001035411523200452030011 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Local extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer) {

            ConsPointer subList = (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList);
            consTraverser.goNext(aStackTop);

            int nr = 1;
            while (consTraverser.getCons() != null)
            {
                String variable = (String) consTraverser.car();
                LispError.checkArgument(aEnvironment, aStackTop, variable != null, nr, "Local");
                // printf("Variable %s\n",variable.String());
                aEnvironment.newLocalVariable(variable, null, aStackTop);
                consTraverser.goNext(aStackTop);
                nr++;
            }
        }
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="Local",categories="User Functions;Variables;Built In"
*CMD Local --- declare new local variables
*CORE
*CALL
	Local(var, ...)

*PARMS

{var} -- name of variable to be declared as local

*DESC

All variables in the argument list are declared as local
variables. The arguments are not evaluated. The value True is
returned.

By default, all variables in MathPiper are global. This means that the
variable has the same value everywhere. But sometimes it is useful to
have a private copy of some variable, either to prevent the outside
world from changing it or to prevent accidental changes to the outside
world. This can be achieved by declaring the variable local. Now only
expressions within the {Prog} block (or its
syntactic equivalent, the {[  ]} block) can access
and change it. Functions called within this block cannot access the
local copy unless this is specifically allowed with {UnFence}.

*E.G.

In> a := 3;
Result: 3;

In> [ a := 4; a; ];
Result: 4;
In> a;
Result: 4;

In> [ Local(a); a := 5; a; ];
Result: 5;
In> a;
Result: 4;

In the car block, {a} is not declared local and
hence defaults to be a global variable. Indeed, changing the variable
inside the block also changes the value of {a}
outside the block. However, in the second block {a}
is defined to be local and now the value outside the block stays the
same, even though {a} is assigned the value 5 inside
the block.

*SEE LocalSymbols, Prog, [], UnFence
%/mathpiper_docs
*/


/*
%mathpiper_docs,name="MacroLocal",categories="Programmer Functions;Programming;Built In"
*CMD MacroLocal --- define rules in functions
*CORE
*DESC

This function has the same effect as its non-macro counterpart, except
that its arguments are evaluated before the required action is performed.
This is useful in macro-like procedures or in functions that need to define new
rules based on parameters.

Make sure that the arguments of {Macro}... commands evaluate to expressions that would normally be used in the non-macro version!

*SEE Bind, Unbind, Local, Rulebase, Rule, `, MacroBind, MacroUnbind, MacroRulebase, MacroRulebaseListed, MacroRule
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Rest.java0000644000175000017500000000406211523200452027673 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Rest extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer first = new ConsPointer();
        Utility.tail(aEnvironment, aStackTop, first, getArgumentPointer(aEnvironment, aStackTop, 1));
        Utility.tail(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), first);
        ConsPointer head = new ConsPointer();
        head.setCons(aEnvironment.iListAtom.copy( aEnvironment, false));
        head.cdr().setCons(((ConsPointer) getTopOfStackPointer(aEnvironment, aStackTop).car()).getCons());
        ((ConsPointer) getTopOfStackPointer(aEnvironment, aStackTop).car()).setCons(head.getCons());
    }
}



/*
%mathpiper_docs,name="Rest",categories="User Functions;Lists (Operations);Built In"
*CMD Rest --- returns a list without its car element
*CORE
*CALL
	Rest(list)

*PARMS

{list} -- a list

*DESC

This function returns "list" without its car element.

*E.G.

In> Rest({a,b,c})
Result: {b,c};

*SEE First, Length
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Divide.java0000644000175000017500000000646011523200452030166 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class Divide extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber y = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        // if both arguments are integers, then BigNumber::Divide would perform an integer divide, but we want a float divide here.
        if (x.isInteger() && y.isInteger())
        {
            // why can't we just say BigNumber temp; ?
            BigNumber tempx = new BigNumber(aEnvironment.getPrecision());
            tempx.setTo(x);
            tempx.becomeFloat(aEnvironment.getPrecision());  // coerce x to float

            BigNumber tempy = new BigNumber(aEnvironment.getPrecision());
            tempy.setTo(y);
            tempy.becomeFloat(aEnvironment.getPrecision());  // coerce x to float

            z.divide(tempx, tempy, aEnvironment.getPrecision());
        } else
        {
            z.divide(x, y, aEnvironment.getPrecision());
        }
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
        return;
    }
}//end class.



/*
%mathpiper_docs,name="DivideN",categories="User Functions;Numeric;Built In"
*CMD DivideN --- divide two numbers (arbitrary-precision math function)
*CORE
*CALL
	DivideN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/BuiltinPrecisionSet.java0000644000175000017500000000715011523200452032715 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class BuiltinPrecisionSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer index = new ConsPointer();
        index.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 1, "BuiltinPrecisionSet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 1, "BuiltinPrecisionSet");

        int ind = Integer.parseInt( (String) index.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, ind > 0, 1, "BuiltinPrecisionSet");
        aEnvironment.setPrecision(ind);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="BuiltinPrecisionSet",categories="Programmer Functions;Numerical (Arbitrary Precision);Built In"
*CMD BuiltinPrecisionSet --- set the precision
*CORE
*CALL
	BuiltinPrecisionSet(n)

*PARMS

{n} -- integer, new value of precision

*DESC

This command sets the number of decimal digits to be used in calculations.
All subsequent floating point operations will allow for
at least {n} digits of mantissa.

This is not the number of digits after the decimal point.
For example, {123.456} has 3 digits after the decimal point and 6 digits of mantissa.
The number {123.456} is adequately computed by specifying {BuiltinPrecisionSet(6)}.

The call {BuiltinPrecisionSet(n)} will not guarantee that all results are precise to {n} digits.

When the precision is changed, all variables containing previously calculated values
remain unchanged.
The {BuiltinPrecisionSet} function only makes all further calculations proceed with a different precision.

Also, when typing floating-point numbers, the current value of {BuiltinPrecisionSet} is used to implicitly determine the number of precise digits in the number.

*E.G.

In> BuiltinPrecisionSet(10)
Result: True;
In> N(Sin(1))
Result: 0.8414709848;
In> BuiltinPrecisionSet(20)
Result: True;
In> x:=N(Sin(1))
Result: 0.84147098480789650665;

The value {x} is not changed by a {BuiltinPrecisionSet()} call:

In> [ BuiltinPrecisionSet(10); x; ]
Result: 0.84147098480789650665;

The value {x} is rounded off to 10 digits after an arithmetic operation:

In> x+0.
Result: 0.8414709848;

In the above operation, {0.} was interpreted as a number which is precise to 10 digits (the user does not need to type {0.0000000000} for this to happen).
So the result of {x+0.} is precise only to 10 digits.

*SEE BuiltinPrecisionGet, N

%/mathpiper_docs
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/UnFence.java0000644000175000017500000000522511417206705030314 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class UnFence extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "UnFence");
        String orig = (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "UnFence");

        // The arity
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 2).getCons() != null, 2, "UnFence");
        LispError.checkArgument(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 2).car() instanceof String, 2, "UnFence");
        int arity = Integer.parseInt( (String) getArgumentPointer(aEnvironment, aStackTop, 2).car(), 10);

        aEnvironment.unfenceRule(aStackTop, Utility.getSymbolName(aEnvironment, orig), arity);

        // Return true
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="UnFence",categories="User Functions;Built In"
*CMD UnFence --- change local variable scope for a function
*CORE
*CALL
	UnFence("operator",arity)

*PARMS
{"operator"} -- string, name of function

{arity} -- positive integers

*DESC

When applied to a user function, the bodies
defined for the rules for "operator" with given
arity can see the local variables from the calling
function. This is useful for defining macro-like
procedures (looping and such).

The standard library functions {For} and {ForEach} use {UnFence}.
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsBodied.java0000644000175000017500000000354011523200452030440 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsBodied extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op = Utility.operatorInfo(aEnvironment, aStackTop, aEnvironment.iBodiedOperators);
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), op != null);
    }
}



/*
%mathpiper_docs,name="IsBodied",categories="User Functions;Predicates;Built In"
*CMD IsBodied --- check for function syntax
*CORE
*CALL
	IsBodied("op")

*PARMS

{"op"} -- string, the name of a function

*DESC

Check whether the function with given name {"op"} has been declared as a
"bodied", operator, and  return {True} or {False}.

*E.G.

In> IsBodied("While");
Result: True;
In> IsBodied("Sin");
Result: False;

*SEE Bodied, PrecedenceGet,IsInfix,IsPostfix,IsPrefix
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Continue.java0000644000175000017500000000365011254215222030546 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.ContinueException;
import org.mathpiper.lisp.Environment;

/**
 *
 *
 */
public class Continue extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         throw new ContinueException();
    }

}//end class.



/*
%mathpiper_docs,name="Continue",categories="User Functions;Control Flow;Built In"
*CMD Continue --- skips executing the remainder of code in this loop iteration and begins the next iteration
*CORE
*CALL

    Continue()

*DESC

If Continue is executed inside of a While, Until, For, or ForEach loop, all the code between
the continue command and the end of the loop will be skipped and the next loop iteration
will be started.

*E.G.

/%mathpiper

x := 0;

While(x < 8)
[
    x++;

    If(x = 5, Continue());

    Echo(x);

];

/%/mathpiper

    /%output,preserve="false"
      Result: True

      Side Effects:
      1
      2
      3
      4
      6
      7
      8
.   /%/output

*SEE While, Until, For, ForEach, Break
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PrettyReaderSet.java0000644000175000017500000000603711523200452032050 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class PrettyReaderSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int nrArguments = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        if (nrArguments == 1)
        {
            aEnvironment.iPrettyReaderName = null;
        } else
        {
            LispError.check(aEnvironment, aStackTop, nrArguments == 2, LispError.WRONG_NUMBER_OF_ARGUMENTS);
            ConsPointer oper = new ConsPointer();
            oper.setCons(getArgumentPointer(aEnvironment, aStackTop, 0).getCons());
            oper.goNext(aStackTop, aEnvironment);
            LispError.checkIsString(aEnvironment, aStackTop, oper, 1, "PrettyReaderSet");
            aEnvironment.iPrettyReaderName = (String) oper.car();
        }
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="PrettyReaderSet",categories="User Functions;Built In"
*CMD PrettyReaderSet --- set routine to use as pretty-reader

*CORE

*CALL
	PrettyReaderSet(reader)
	PrettyReaderSet()

*PARMS

{reader} -- a string containing the name of a function that can read an expression from current input.


*DESC

This function sets up the function reader to read in the input on
the command line. This can be reset to the internal reader with {PrettyReaderSet()} (when no argument is given, the system returns to the default).

Currently implemented PrettyReaders are: {LispRead}, {OMRead}.

MathPiper allows you to configure a few things at startup. The file
{~/.mathpiperrc} is written in the MathPiper language and
will be executed when MapthPiper is run. This function
can be useful in the {~/.MathPiperrc} file.

*E.G.

In> Taylor(x,0,5)Sin(x)
Result: x-x^3/6+x^5/120
In> PrettyReaderSet("LispRead")
Result: True
In> (Taylor x 0 5 (Sin x))
Result: x-x^3/6+x^5/120

*SEE Read, LispRead, OMRead, PrettyPrinterSet, PrettyPrinterGet, PrettyReaderGet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsBound.java0000644000175000017500000000431611523200452030323 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsBound extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        
        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof String)
        {
            String str =  (String) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            ConsPointer val = new ConsPointer();
            aEnvironment.getGlobalVariable(aStackTop, str, val);
            if (val.getCons() != null)
            {
                Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
                return;
            }
        }
        Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="IsBound",categories="User Functions;Predicates;Built In"
*CMD IsBound --- test for a bound variable
*CORE
*CALL
	IsBound(var)

*PARMS

{var} -- variable to test

*DESC

This function tests whether the variable "var" is bound, i.e. whether
it has been assigned a value. The argument "var" is not evaluated.

*E.G.

In> IsBound(x);
Result: False;
In> x := 5;
Result: 5;
In> IsBound(x);
Result: True;

*SEE IsAtom
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/GetExactBits.java0000644000175000017500000000652311523200452031310 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class GetExactBits extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber numberToCheck = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber numberToReturn = new BigNumber(aEnvironment.getPrecision());
        numberToReturn.setTo(
                (numberToCheck.isInteger())
                ? numberToCheck.bitCount() // for integers, return the bit count
                : Utility.digitsToBits((long) (numberToCheck.getPrecision()), 10) // for floats, return the getPrecision
                );
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(numberToReturn));
    }
}



/*
%mathpiper_docs,name="GetExactBitsN",categories="Programmer Functions;Numerical (Arbitrary Precision);Built In"
*CMD GetExactBitsN --- manipulate precision of floating-point numbers
*CORE
*CALL
	GetExactBitsN(x)

*PARMS
{x} -- an expression evaluating to a floating-point number


*DESC
Each floating-point number in MathPiper has an internal precision counter that stores the number of exact bits in the mantissa.
The number of exact bits is automatically updated after each arithmetic operation to reflect the gain or loss of precision due to round-off.
The functions {GetExactBitsN} queries the precision flags of individual number objects.

{GetExactBitsN(x)} returns an integer number $n$ such that {x} represents a real number in the interval [$x*(1-2^(-n))$, $x*(1+2^(-n))$] if $x!=0$ and in the interval [$-2^(-n)$, $2^(-n)$] if $x=0$.
The integer $n$ is always nonnegative unless {x} is zero (a "floating zero").
A floating zero can have a negative value of the number $n$ of exact bits.

This function is only meaningful for floating-point numbers.
(All integers are always exact.)
For integer {x}, the function {GetExactBitsN} returns the bit count of {x}.

*REM FIXME - these examples currently do not work because of bugs

*E.G.
The default precision of 10 decimals corresponds to 33 bits:
In> GetExactBitsN(1000.123)
Result: 33;
In> x:=SetExactBits(10., 20)
Result: 10.;
In> GetExactBitsN(x)
Result: 20;
Prepare a "floating zero" representing an interval [-4, 4]:
In> x:=SetExactBits(0., -2)
Result: 0.;
In> x=0
Result: True;

*SEE BuiltinPrecisionSet, BuiltinPrecisionGet, SetExactBitsN
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/StringMidSet.java0000644000175000017500000000630011523200452031327 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.*;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *  
 */
public class StringMidSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, evaluated, 3, "StringMidSet");
        String orig = (String) evaluated.car();
        ConsPointer index = new ConsPointer();
        index.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 1, "StringMidSet");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 1, "StringMidSet");
        int from = Integer.parseInt( (String) index.car(), 10);

        LispError.checkArgument(aEnvironment, aStackTop, from > 0, 1, "StringMidSet");

        ConsPointer ev2 = new ConsPointer();
        ev2.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkIsString(aEnvironment, aStackTop, ev2, 2, "StringMidSet");
        String replace =(String)  ev2.car();

        LispError.check(aEnvironment, aStackTop, from + replace.length() - 2 < orig.length(), LispError.INVALID_ARGUMENT);
        String str;
        str = orig.substring(0, from);
        str = str + replace.substring(1, replace.length() - 1);
        //System.out.println("from="+from+replace.length()-2);
        str = str + orig.substring(from + replace.length() - 2, orig.length());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, str));
    }
}



/*
%mathpiper_docs,name="StringMidSet",categories="User Functions;String Manipulation;Built In"
*CMD StringMidSet --- change a substring
*CORE
*CALL
	StringMidSet(index,substring,string)

*PARMS

{index} -- index of substring to get

{substring} -- substring to store

{string} -- string to store substring in.

*DESC

Set (change) a part of a string. It leaves the original alone, returning
a new changed copy.

*E.G.

In> StringMidSet(3,"XY","abcdef")
Result: "abXYef";

*SEE StringMidGet, Length
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PrettyPrinterSet.java0000644000175000017500000000634011523200452032266 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class PrettyPrinterSet extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        int nrArguments = Utility.listLength(aEnvironment, aStackTop, getArgumentPointer(aEnvironment, aStackTop, 0));
        if (nrArguments == 1)
        {
            aEnvironment.iPrettyPrinterName = null;
        } else
        {
            LispError.check(aEnvironment, aStackTop, nrArguments == 2, LispError.WRONG_NUMBER_OF_ARGUMENTS);
            ConsPointer oper = new ConsPointer();
            oper.setCons(getArgumentPointer(aEnvironment, aStackTop, 0).getCons());
            oper.goNext(aStackTop, aEnvironment);
            LispError.checkIsString(aEnvironment, aStackTop, oper, 1, "PrettyPrinterSet");
            aEnvironment.iPrettyPrinterName = (String) oper.car();
        }
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}



/*
%mathpiper_docs,name="PrettyPrinterSet",categories="User Functions;Built In"
*CMD PrettyPrinterSet --- set routine to use as pretty-printer

*CORE

*CALL
	PrettyPrinterSet(printer)
	PrettyPrinterSet()

*PARMS

{printer} -- a string containing the name of a function that can "pretty-print" an expression.


*DESC

This function sets up the function printer to print out the results on
the command line. This can be reset to the internal printer with {PrettyPrinterSet()} (when no argument is given, the system returns to the default).

Currently implemented prettyprinters are: {PrettyForm}, {TeXForm}, {Print}, {OMForm}, {CForm} and {DefaultPrint}.

MathPiper allows you to configure a few things at startup. The file
{~/.mathpiperrc} is written in the MathPiper language and
will be executed when MapthPiper is run. This function
can be useful in the {~/.MathPiperrc} file.

*E.G.

In> Taylor(x,0,5)Sin(x)
Result: x-x^3/6+x^5/120;
In> PrettyPrinterSet("PrettyForm");

	True

In> Taylor(x,0,5)Sin(x)

	     3    5
	    x    x
	x - -- + ---
	    6    120

In> PrettyPrinterSet();
Result: True;
In> Taylor(x,0,5)Sin(x)
Result: x-x^3/6+x^5/120;

*SEE PrettyForm, Write, TeXForm, CForm, OMForm, PrettyReaderSet, PrettyReaderGet, PrettyPrinterGet
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/MathSign.java0000644000175000017500000000263711333354275030512 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class MathSign extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);
        BigNumber z = new BigNumber(aEnvironment.getPrecision());
        z.setTo(x.sign());
        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(z));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/Length.java0000644000175000017500000000624011523200452030177 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.Array;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class Length extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Object argument =getArgumentPointer(aEnvironment, aStackTop, 1).car();
        

        if (argument instanceof ConsPointer)
        {
            int num = Utility.listLength(aEnvironment, aStackTop, ((ConsPointer)argument).cdr());
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + num));
            return;
        }//end if.
        
        
        
        if (argument instanceof BuiltinContainer)
        {
            BuiltinContainer gen = (BuiltinContainer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            if (gen.typeName().equals("\"Array\""))
            {
                int size = ((Array) gen).size();
                getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + size));
                return;
            }
        //  CHK_ISLIST_CORE(aEnvironment,aStackTop,getArgumentPointer(aEnvironment, aStackTop, 1),1);
        }//end if.



        LispError.check(aEnvironment, aStackTop, argument instanceof String, LispError.INVALID_ARGUMENT, "Length");
        String string =  (String) argument;
        if (Utility.isString(string))
        {
            int num = string.length() - 2;
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, "" + num));
            return;
        }//end if.
        

    }//end method..

}//end class.



/*
%mathpiper_docs,name="Length",categories="User Functions;Lists (Operations);Built In"
*CMD Length --- the length of a list or string
*CORE
*CALL
	Length(object)

*PARMS

{object} -- a list, array or string

*DESC

Length returns the length of a list.
This function also works on strings and arrays.

*E.G.

In> Length({a,b,c})
Result: 3;
In> Length("abcdef");
Result: 6;

*SEE First, Rest, Nth, Count
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DestructiveReplace.java0000644000175000017500000000435211523200452032555 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DestructiveReplace extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        Utility.replace(aEnvironment, aStackTop, true);
    }
}



/*
%mathpiper_docs,name="DestructiveReplace",categories="User Functions;Lists (Operations);Built In"
*CMD DestructiveReplace --- replace an entry destructively in a list

*CORE

*CALL
	DestructiveReplace(list, n, expr)

*PARMS

{list} -- list of which an entry should be replaced

{n} -- index of entry to replace

{expr} -- expression to replace the n-th entry with

*DESC

This is the destructive counterpart of {Replace}. This
command yields the same result as the corresponding call to
{Replace}, but the original list is modified. So if a
variable is bound to "list", it will now be bound to the list with
the expression "expr" inserted.

Destructive commands run faster than their nondestructive counterparts
because the latter copy the list before they alter it.

*E.G.

In> lst := {a,b,c,d,e,f};
Result: {a,b,c,d,e,f};
In> Replace(lst, 4, x);
Result: {a,b,c,x,e,f};
In> lst;
Result: {a,b,c,d,e,f};
In> DestructiveReplace(lst, 4, x);
Result: {a,b,c,x,e,f};
In> lst;
Result: {a,b,c,x,e,f};

*SEE Replace, DestructiveDelete, DestructiveInsert
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/IsGeneric.java0000644000175000017500000000337311333354275030646 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class IsGeneric extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        Utility.putBooleanInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop), evaluated.car() instanceof BuiltinContainer);
    }
}//end class.



/*
%mathpiper_docs,name="IsGeneric",categories="Programmer Functions;Native Objects;Built In"
*CMD IsGeneric --- check for generic object
*CORE
*CALL
	IsGeneric(object)

*DESC
Returns {True} if an object is of a generic object type.

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/DefMacroRulebase.java0000644000175000017500000001164211523200452032123 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;

/**
 *
 *  
 */
public class DefMacroRulebase extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.Utility.defMacroRulebase(aEnvironment, aStackTop, false);
    }
}



/*
%mathpiper_docs,name="DefMacroRulebase",categories="Programmer Functions;Programming;Built In"
*CMD DefMacroRulebase --- define a function as a macro
*CORE
*CALL
	DefMacroRulebase(name,params)

*PARMS

{name} -- string, name of a function

{params} -- list of arguments

*DESC

{DefMacroRulebase} is similar to {Rulebase}, with the difference that it declares a macro,
instead of a function.
After this call, rules can be defined for the function "{name}", but their interpretation will be different.

With the usual functions, the evaluation model is that of the applicative-order model of
substitution, meaning that first the arguments are evaluated, and then the function
is applied to the result of evaluating these arguments. The function is entered, and the
code inside the function can not access local variables outside of its own local variables.

With macros, the evaluation model is that of the normal-order model of substitution,
meaning that all occurrences of variables in an expression are first substituted into the
body of the macro, and only then is the resulting expression evaluated in its
calling environment. This is important, because then in principle a macro body
can access the local variables from the calling environment, whereas functions can not do that.

As an example, suppose there is a function {square}, which squares its argument, and a function
{add}, which adds its arguments. Suppose the definitions of these functions are:

	add(x,y) <-- x+y;
and
	square(x) <-- x*x;
In applicative-order mode (the usual way functions are evaluated), in the following expression
	add(square(2),square(3))
first the arguments to {add} get evaluated. So, first {square(2)} is evaluated.
To evaluate this, first {2} is evaluated, but this evaluates to itself. Then
the {square} function is applied to it, {2*2}, which returns 4. The same
is done for {square(3)}, resulting in {9}. Only then, after evaluating these two
arguments, {add} is applied to them, which is equivalent to
	add(4,9)
resulting in calling {4+9}, which in turn results in {13}.

In contrast, when {add} is a macro, the arguments to {add} are first
expanded. So
	add(square(2),square(3))
first expands to
	square(2) + square(3)
and then this expression is evaluated, as if the user had written it directly.
In other words, {square(2)} is not evaluated before the macro has been fully expanded.


Macros are useful for customizing syntax, and compilers can potentially
greatly optimize macros, as they can be inlined in the calling environment,
and optimized accordingly.

There are disadvantages, however. In interpreted mode, macros are slower,
as the requirement for substitution means that a new expression to be evaluated
has to be created on the fly. Also, when one of the parameters to the macro
occur more than once in the body of the macro, it is evaluated multiple times.

When defining transformation rules for macros, the variables to be substituted
need to be preceded by the {@} operator, similar to the back-quoting mechanism.
Apart from that, the two are similar, and all transformation rules can also be
applied to macros.

Macros can co-exist with functions with the same name but different arity.
For instance, one can have a function {foo(a,b)}
with two arguments, and a macro {foo(a,b,c)} with three arguments.


*E.G.

The following example defines a macro {myfor}, and shows one use, referencing
a variable {a} from the calling environment.

In> DefMacroRulebase("myfor",{init,pred,inc,body})
Result: True;
In> myfor(_init,_pred,_inc,_body)<--[@init;While(@pred)[@body;@inc;];True;];
Result: True;
In> a:=10
Result: 10;
In> myfor(i:=1,i<10,i++,Echo(a*i))
	10
	20
	30
	40
	50
	60
	70
	80
	90
Result: True;
In> i
Result: 10;

*SEE Rulebase, `, DefMacroRulebaseListed
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/LexGreaterThan.java0000644000175000017500000000236711332473164031653 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.lisp.collections.TokenMap;

/**
 *
 *  
 */
public class LexGreaterThan extends LexCompare2
{

    boolean lexFunction(String f1, String f2, TokenMap aHashTable, int aPrecision)
    {
        return f1.compareTo(f2) > 0;
    }

    boolean numFunction(BigNumber n1, BigNumber n2)
    {
        return !(n1.lessThan(n2) || n1.equals(n2));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/core/PipeFromString.java0000644000175000017500000000652711523200452031676 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.core;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.io.InputStatus;
import org.mathpiper.io.StringInputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/**
 *
 * 
 */
public class PipeFromString extends BuiltinFunction
{

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        ConsPointer evaluated = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, evaluated, getArgumentPointer(aEnvironment, aStackTop, 1));

        // Get file name
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.getCons() != null, 1, "PipeFromString");
        String orig =  (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "PipeFromString");
        String oper = Utility.toNormalString(aEnvironment, aStackTop, orig);

        InputStatus oldstatus = aEnvironment.iInputStatus;
        aEnvironment.iInputStatus.setTo("String");
        StringInputStream newInput = new StringInputStream(new StringBuffer(oper), aEnvironment.iInputStatus);

        MathPiperInputStream previous = aEnvironment.iCurrentInput;
        aEnvironment.iCurrentInput = newInput;
        try
        {
            // Evaluate the body
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), getArgumentPointer(aEnvironment, aStackTop, 2));
        } catch (Exception e)
        {
            throw e;
        } finally
        {
            aEnvironment.iCurrentInput = previous;
            aEnvironment.iInputStatus.restoreFrom(oldstatus);
        }

    //Return the getTopOfStackPointer
    }
}



/*
%mathpiper_docs,name="PipeFromString",categories="User Functions;Input/Output;Built In"
*CMD PipeFromString --- connect current input to a string
*CORE
*CALL
	PipeFromString(str) body;

*PARMS

{str} -- a string containing the text to parse

{body} -- expression to be evaluated

*DESC

The commands in "body" are executed, but everything that is read
from the current input is now read from the string "str". The
result of "body" is returned.

*E.G.

In> PipeFromString("2+5; this is never read") \
	  res := Read();
Result: 2+5;
In> PipeFromString("2+5; this is never read") \
	  res := Eval(Read());
Result: 7;

*SEE PipeToString, PipeFromFile, Read, ReadToken
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/0000755000175000017500000000000011722677373027033 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewMath.java0000644000175000017500000002033511506507632031413 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.awt.BorderLayout;
import java.awt.Color;
import java.awt.Container;
import java.awt.Dimension;
import javax.swing.Box;
import javax.swing.JFrame;
import javax.swing.JPanel;
import javax.swing.JScrollPane;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.SublistCons;

import javax.swing.JLabel;

import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.ui.gui.worksheets.LatexRenderingController;
import org.mathpiper.ui.gui.worksheets.ScreenCapturePanel;
import org.scilab.forge.jlatexmath.TeXFormula;

/**
 *
 *
 */
public class ViewMath extends BuiltinFunction {

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
                "ViewMathInternal");

       String[] parameters = new String[] {"expression","size"};
       Utility.declareFunction("ViewMath", parameters, "ViewMathInternal(expression, size);", aEnvironment, LispError.TODO);


       parameters = new String[] {"expression"};
       Utility.declareFunction("ViewMath", parameters, "ViewMathInternal(expression, 2);", aEnvironment, LispError.TODO);


    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        //Utility.lispEvaluate(aEnvironment, "TeXForm(x^2);");

        Cons head = SublistCons.getInstance(aEnvironment, AtomCons.getInstance(aEnvironment, aStackTop, "TeXForm"));

        ((ConsPointer) head.car()).cdr().setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());


        ConsPointer resultPointer = new ConsPointer();

        ConsPointer viewScalePointer = new ConsPointer();
        viewScalePointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, resultPointer, viewScalePointer);
        BigNumber viewScale = (BigNumber) resultPointer.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, viewScale != null, 1, "ViewMath");


        

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, resultPointer, new ConsPointer(head));

        String texString = (String) resultPointer.car();
        texString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, texString);
        texString = texString.substring(1, texString.length());
        texString = texString.substring(0, texString.length() - 1);



        JFrame frame = new JFrame();
        Container contentPane = frame.getContentPane();
        frame.setBackground(Color.WHITE);
        contentPane.setBackground(Color.WHITE);




        /*
        DebugGraphics.setFlashCount(10);
        DebugGraphics.setFlashColor(Color.red);
        DebugGraphics.setFlashTime(1000);
        RepaintManager.currentManager(panel).setDoubleBufferingEnabled(false);
        panel.setDebugGraphicsOptions(DebugGraphics.FLASH_OPTION);
        panel.setDebugGraphicsOptions(DebugGraphics.LOG_OPTION);
         */



        /*
        //MathPiper built-in math viewer.
        TexParser parser = new TexParser();
        SymbolBox sBoxExpression = parser.parse(texString);
        JTabbedPane tabbedPane = new JTabbedPane();
        //Math viewer.
        JPanel mathControllerPanel = new JPanel();
        mathControllerPanel.setLayout(new BorderLayout());
        MathPanel mathPanel = new MathPanel(sBoxExpression, viewScale.toDouble());
        MathPanelController mathPanelScaler = new MathPanelController(mathPanel, viewScale.toDouble());
        JScrollPane scrollPane = new JScrollPane(mathPanel,JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
        mathControllerPanel.add(scrollPane);
        mathControllerPanel.add(mathPanelScaler, BorderLayout.NORTH);
        tabbedPane.addTab("Math Form", null, mathControllerPanel, "Math expression viewer.");
        //Tree viewer.
        JPanel treeControllerPanel = new JPanel();
        treeControllerPanel.setLayout(new BorderLayout());
        TreePanel treePanel = new TreePanel(sBoxExpression,viewScale.toDouble());
        MathPanelController treePanelScaler = new MathPanelController(treePanel,viewScale.toDouble());
        JScrollPane treeScrollPane = new JScrollPane(treePanel,JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
        treeControllerPanel.add(treeScrollPane);
        treeControllerPanel.add(treePanelScaler, BorderLayout.NORTH);
        tabbedPane.addTab("Parse Tree", null, treeControllerPanel, "Parse tree viewer..");
        */





        Box box = Box.createVerticalBox();



        //JLatexMath
	TeXFormula formula = new TeXFormula(texString);
        JLabel latexLabel = new JLabel();
        JPanel latexPanelController = new LatexRenderingController(formula, latexLabel, 100);

        JPanel screenCapturePanel = new ScreenCapturePanel();

        screenCapturePanel.add(latexLabel);

        JScrollPane jMathTexScrollPane = new JScrollPane(screenCapturePanel,JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
        jMathTexScrollPane.getViewport().setBackground(Color.WHITE);
        box.add(jMathTexScrollPane);


        //box.add(tabbedPane); //MathPiper's built-in math viewer.
        

        contentPane.add(box);

        contentPane.add(latexPanelController, BorderLayout.NORTH);


        frame.setAlwaysOnTop(false);
        frame.setTitle("Math Viewer");
        frame.setSize(new Dimension(300, 200));
        frame.setResizable(true);
        frame.setLocationRelativeTo(null);

        frame.pack();
        frame.setVisible(true);


        //getTopOfStackPointer(aEnvironment, aStackTop).setCons(resultPointer.getCons()); //This use to print Latex code.

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

    }//end method.


}//end class.




/*
%mathpiper_docs,name="ViewMath",categories="User Functions;Built In;Visualization"
*CMD ViewMath --- display an expression in traditional form

*CALL
    ViewMath(expression)

*Params
{expression} -- an expression to view

*DESC
Display an expression in traditional form.

*E.G.
In> ViewMath(Expand((2*x)*(x+3)*(x+4)));

In> ViewMath(15*x^2 * Hold(Integrate(x,0,Infinity)Exp(-x^2)));


 
/%mathpiper

index := 1;

expressionsList := {};

While(index <= 9)
[
   expressionsList := Append(expressionsList, RandomPoly(x,3,1,10));

   index++;
];

matrix := Partition(expressionsList,3);

ViewMath(matrix);

/%/mathpiper
 
 
 
The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.
 
In> frame := ViewMath(x^2)
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

*SEE ViewList, ViewLatex
%/mathpiper_docs
*/

././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/NormalDistributionValue.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/NormalDistributionValue.j0000644000175000017500000000442611376414313034025 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.cern.Probability;
import org.mathpiper.builtin.library.statdistlib.Normal;
import org.mathpiper.builtin.library.statdistlib.Uniform;
import org.mathpiper.lisp.Environment;



public class NormalDistributionValue extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "NormalDistributionValue");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber mean = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        //LispError.check(mean.isInteger() && mean.toInt() >= 0, "The first argument must be an integer which is greater than 0.", "NormalDistributionValue", aStackTop, aEnvironment);

        BigNumber sigma = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        //LispError.check(sigma.toDouble() >= 0, "The second argument must be greater than 0.", "NormalDistributionValue", aStackTop, aEnvironment);

        double randomVariableDouble = Normal.random(mean.toDouble(), sigma.toDouble(), new Uniform());

        BigNumber randomVariable = new BigNumber(aEnvironment.getPrecision());

        randomVariable.setTo(randomVariableDouble);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(randomVariable));

    }//end method.

}//end class.



/*
%mathpiper_docs,name="NormalDistributionValue",categories="User Functions;Built In;Statistics & Probability",access="experimental
*CMD NormalDistributionValue --- returns a value from the normal distribution
*CALL
    NormalDistributionValue(mean, standardDeviation)

*PARMS
{mean} -- the mean of the distribution
{standardDeviation} -- the standard deviation of the distribution

*DESC
This function returns a value from the given normal distribution.

*E.G.
In> NormalDistributionValue(3,2)
Result> 5.440398494

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/StackTraceOff.java0000644000175000017500000000436111400400116032325 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class StackTraceOff extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "StackTraceOff");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         Evaluator.stackTraceOff();
         aEnvironment.write("Stack tracing is off.\n");
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}




/*
%mathpiper_docs,name="StackTraceOff",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD StackTraceOff --- clears the flag which will show a stack trace when an exception is thrown
*CALL
    StackTraceOff()

*DESC
This function clears the flag which will show the current state of the user function stack and the built in function stack
when an exception is thrown.

See the StackTraceOn function for more information.

*SEE StackTrace, StackTraceOn, TraceSome, TraceExcept, TraceOn, TraceOff
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/OneTailAlphaToTScore.java0000644000175000017500000000430611474775346033630 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.cern.Probability;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;



public class OneTailAlphaToTScore extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "OneTailAlphaToTScore");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber degreesOfFreedom = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        LispError.check(degreesOfFreedom.isInteger() && degreesOfFreedom.toInt() >= 0, "The first argument must be an integer which is greater than 0.", "OneTailAlphaToTScore", aStackTop, aEnvironment);

        BigNumber alpha = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        LispError.check(alpha.toDouble() >= 0 && alpha.toDouble() <= .5, "The second argument must be greater than 0 and less than or equal to .5.", "OneTailAlphaToTScore", aStackTop, aEnvironment);

        double cdf = Probability.studentTInverse(alpha.toDouble()*2, (int) degreesOfFreedom.toLong());

        BigNumber tScore = new BigNumber(aEnvironment.getPrecision());

        tScore.setTo(cdf);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(tScore));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="OneTailAlphaToTScore",categories="User Functions;Statistics & Probability"
*CMD OneTailAlphaToTScore --- convert a one-tail alpha to a t-score

*CALL

    OneTailAlphaToTScore(degreesOfFreedom, alpha)

*PARMS

{degreesOfFreedom} -- integer, the degrees of freedom

{alpha} -- the one tailed alpha value

*DESC

Calculates the t value for the given one tail alpha value and degrees of freedom.

*E.G.
In> OneTailAlphaToTScore(9,.025)
Result> 2.262157163


%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/Maxima.java0000644000175000017500000001650011412252415031072 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.ConsPointer;
import java.util.ArrayList;
import java.util.regex.Matcher;
import java.util.regex.Pattern;
import java.io.*;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class Maxima extends BuiltinFunction {

    private static Maxima maximaInstance = null;
    private StringBuffer responseBuffer;
    private Pattern inputPromptPattern;
    private InputStream inputStream;
    private OutputStream outputStream;
    private String response;
    private String startMessage;
    private String fileSearchMaximaAppendResponse;
    private String fileSearchLispAppendResponse;
    private boolean keepRunning;
    private String prompt;
    private boolean maximaInstalled = false;

    /** Creates a new instance of MaximaWrapper */
    public Maxima() {

/*

        ArrayList command = new ArrayList();
        //command.add("C:\\Program Files\\Maxima-5.15.0\\bin\\maxima.bat");

        String maximaPath = "/usr/bin/maxima";
        File maximaCommandFile = new File(maximaPath);
        if(maximaCommandFile.exists())
        {
        command.add(maximaPath);

        try {
            ProcessBuilder processBuilder = new ProcessBuilder(command);
            Process maximaProcess = processBuilder.start();
            inputStream = maximaProcess.getInputStream();
            outputStream = maximaProcess.getOutputStream();
            responseBuffer = new StringBuffer();
            inputPromptPattern = Pattern.compile("\\n\\(%i[0-9]+\\)|MAXIMA>");
            startMessage = getResponse();

            send("display2d:false;\n");
            getResponse();
            maximaInstalled = true;
        } catch (Throwable t) {
            t.printStackTrace();
        }


        
        //System.out.println("M+");
        }
        else
        {
            //System.out.println("M-");
        }
        

*/

    /*//Add temporary files directory to maxima search path.
    File tempFile = File.createTempFile("mathpiperide", ".tmp");
    tempFile.deleteOnExit();
    String searchDirectory = tempFile.getParent() + File.separator + "###.{mac,mc}";
    searchDirectory = searchDirectory.replace("\\","/");
    send("file_search_maxima: append (file_search_maxima, [\"" + searchDirectory + "\"])$\n");
    fileSearchMaximaAppendResponse = getResponse();


    //Add temporary files directory to lisp search path.
    searchDirectory = tempFile.getParent() + File.separator + "###.{lisp,lsp}";
    searchDirectory = searchDirectory.replace("\\","/");
    send("file_search_lisp: append (file_search_lisp, [\"" + searchDirectory + "\"])$\n");
    fileSearchLispAppendResponse = getResponse();
    //System.out.println("FFF " + fileSearchMaximaAppendResponse);*/

    }//end constructor.

    public String getStartMessage() {
        return startMessage;
    }//end method.

    public String getPrompt() {
        return prompt;
    }//end method.

    public static Maxima getInstance() throws Throwable {
        if (maximaInstance == null) {
            maximaInstance = new Maxima();
        }
        return maximaInstance;
    }//end method.

    public synchronized void send(String send) throws Throwable {
        outputStream.write(send.getBytes());
        outputStream.flush();
    }//end send.

    protected String getResponse() throws Throwable {
        boolean keepChecking = true;

        mainLoop:
        while (keepChecking) {
            int serialAvailable = inputStream.available();
            if (serialAvailable == 0) {
                try {
                    Thread.sleep(100);
                } catch (InterruptedException ie) {
                    System.out.println("Maxima session interrupted.");
                }
                continue mainLoop;
            }//end while

            byte[] bytes = new byte[serialAvailable];

            inputStream.read(bytes, 0, serialAvailable);
            responseBuffer.append(new String(bytes));
            response = responseBuffer.toString();
            //System.out.println("SSSSS " + response);
            Matcher matcher = inputPromptPattern.matcher(response);
            if (matcher.find()) {
                //System.out.println("PPPPPP found end");
                responseBuffer.delete(0, responseBuffer.length());
                int promptIndex = response.lastIndexOf("(%");
                if (promptIndex == -1) {
                    promptIndex = response.lastIndexOf("MAX");
                }
                prompt = response.substring(promptIndex, response.length());
                response = response.substring(0, promptIndex);
                keepChecking = false;

            }//end if.

        }//end while.

        return response;

    }//end method

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "Maxima");
        
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer expressionPointerr = new ConsPointer();
        expressionPointerr.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, expressionPointerr.getCons() != null, 1, "Maxima");
        String orig = (String) expressionPointerr.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "Maxima");

        if(maximaInstalled)
        {
        orig = orig.substring(1,orig.length()-1); //Strip quotes.

        try {
            send(orig + ";\n");
            String response = getResponse();
            
            if(response.startsWith("\n"))
            {
                response = response.substring(1);
            }

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, response));
        } catch (Throwable t) {
            t.printStackTrace();
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }
        }
        else
        {
            aEnvironment.write("Maxima is not installed.");
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }


    }
}//end class.


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/IncompleteGamma.java0000644000175000017500000000317611334223061032723 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.cern.Gamma;
import org.mathpiper.lisp.Environment;



public class IncompleteGamma extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "IncompleteGamma");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber a = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        double resultValue = Gamma.incompleteGammaComplement(x.toDouble(),  a.toDouble());

        BigNumber result = new BigNumber(aEnvironment.getPrecision());

        result.setTo(resultValue);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(result));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="IncompleteGamma",categories="User Functions;Statistics & Probability"
*CMD IncompleteGamma --- the incomplete gamma function
*CORE
*CALL
    IncompleteGamma(a, x)

*PARMS
{a} -- the parameter of the gamma distribution

{x} -- the integration end point

*DESC

The incomplete gamma function.

*E.G.
In> IncompleteBeta(.2,.2,.2)
Result> 0.3927221644


%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/FScoreToProbability.java0000644000175000017500000000525211334223061033543 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.jscistats.FDistribution;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;



public class FScoreToProbability extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "FScoreToProbability");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber degreesOfFreedom1 = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        LispError.check(degreesOfFreedom1.isInteger() && degreesOfFreedom1.toInt() >= 0, "The first argument must be an integer which is greater than 0.", "FScoreToProbability", aStackTop, aEnvironment);

        BigNumber degreesOfFreedom2 = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        LispError.check(degreesOfFreedom2.isInteger() && degreesOfFreedom2.toInt() >= 0, "The second argument must be an integer which is greater than 0.", "FScoreToProbability", aStackTop, aEnvironment);

        BigNumber fScore = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 3);

        LispError.check(fScore.toDouble() >= 0, "The third argument must be greater than 0.", "FScoreToProbability", aStackTop, aEnvironment);

        
        FDistribution fDistribution = new FDistribution(degreesOfFreedom1.toDouble(),degreesOfFreedom2.toDouble());

        double probability = fDistribution.cumulative(fScore.toDouble());

        BigNumber cumulativeProbability = new BigNumber(aEnvironment.getPrecision());

        cumulativeProbability.setTo(probability);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(cumulativeProbability));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="FScoreToProbability",categories="User Functions;Statistics & Probability"
*CMD FScoreToProbability --- calculates the cumulative probability for a given f-score

*CALL

    FScoreToProbability(degreesOfFreedom1, degreesOfFreedom2, fScore)

*PARMS
{degreesOfFreedom1} -- integer, the first degree of freedom

{degreesOfFreedom2} -- integer, the second degree of freedom

{fScore} -- the fScore

*DESC
Calculates the cumulative probability for a given f-score.

*E.G.
In> FScoreToProbability(1,1,161.448)
Result> 0.9500000557


%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/SetPlotColor.java0000644000175000017500000000477511334223061032260 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class SetPlotColor extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "SetPlotColor");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         ConsPointer consPointer = new ConsPointer();
         aEnvironment.getGlobalVariable(aStackTop, "Simulator", consPointer);
         org.mathpiper.ui.gui.simulator.SimulatorFrame simulator =  (org.mathpiper.ui.gui.simulator.SimulatorFrame) ((BuiltinContainer)consPointer.car()).getObject();

         Cons redCons = getArgumentPointer(aEnvironment, aStackTop, 1).getCons();
         Cons greenCons = getArgumentPointer(aEnvironment, aStackTop, 2).getCons();
         Cons blueCons = getArgumentPointer(aEnvironment, aStackTop, 3).getCons();
         int redValue = Integer.parseInt( (String) redCons.car());
         int greenValue = Integer.parseInt( (String) greenCons.car());
         int blueValue = Integer.parseInt( (String) blueCons.car());
         simulator.setColor(redValue, greenValue, blueValue);
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/Import.java0000644000175000017500000000475511503734166031152 0ustar  giovannigiovanni
/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.util.List;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *
 */
public class Import extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "Import");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {

        ConsPointer pathPointer = getArgumentPointer(aEnvironment, aStackTop, 1);


        LispError.checkIsString(aEnvironment, aStackTop, pathPointer, 1, "Import");

        String path = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, (String) pathPointer.car());

        /*org.mathpiper.builtin.javareflection.Import.addImport(path);
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));*/


        List failList = BuiltinFunction.addOptionalFunctions(aEnvironment, path);

        if(failList.isEmpty())
        {
            Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        }
        else
        {
            aEnvironment.write("Could not load " + path);
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }//end if/else

    }//end method.

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/Ring.java0000644000175000017500000000442411503734166030570 0ustar  giovannigiovanni
/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 *
 */
public class Ring extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "Ring");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {

        ConsPointer pathPointer = getArgumentPointer(aEnvironment, aStackTop, 1);


        LispError.checkIsString(aEnvironment, aStackTop, pathPointer, 1, "Ring");

        String configurationString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, (String) pathPointer.car());

        org.mathpiper.builtin.library.jas.Ring ring = new org.mathpiper.builtin.library.jas.Ring(aEnvironment, configurationString);

        JavaObject response = new JavaObject(ring);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));
        return;


    }//end method.

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/TraceToStdio.java0000644000175000017500000000335111504313012032213 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class TraceToStdio extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "TraceToStdio");
    }//end method.


    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         Evaluator.TRACE_TO_STANDARD_OUT = true;

         aEnvironment.write("Tracing to stdio is on.\n");
         
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/TraceOff.java0000644000175000017500000000425711400407716031360 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class TraceOff extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "TraceOff");
    }//end method.


    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         Evaluator.traceOff();
         aEnvironment.write("Tracing is off.\n");
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}




/*
%mathpiper_docs,name="TraceOff",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD TraceOff --- disables a complete trace of all the functions that are called when an expression is evaluated
*CALL
    TraceOff()

*DESC
This function disables a complete trace of all the functions that are called when an expression is evaluated.

See TraceOn for more information.

*SEE StackTrace, StackTraceOn, StackTraceOff, TraceSome, TraceExcept, TraceOn
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/SysOut.java0000644000175000017500000000642411400400116031116 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.io.StringOutput;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.ConsTraverser;

/**
 *
 *
 */
public class SysOut extends BuiltinFunction {
    
    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "SysOut");
    }//end method.



    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        StringOutput out = new StringOutput();
        if (getArgumentPointer(aEnvironment, aStackTop, 1).car() instanceof ConsPointer) {

            ConsPointer subList = (ConsPointer) getArgumentPointer(aEnvironment, aStackTop, 1).car();
            
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList);
            consTraverser.goNext(aStackTop);
            while (consTraverser.getCons() != null)
            {
                aEnvironment.iCurrentPrinter.print(aStackTop, consTraverser.getPointer(), out, aEnvironment);
                consTraverser.goNext(aStackTop);
            }
        }
        String output = out.toString();
        output = output.replace("\"", "");
        System.out.println(output);
        aEnvironment.iCurrentOutput.write(output);
        aEnvironment.iCurrentOutput.write("\n");
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));

    }//end method.


}//end class.




/*
%mathpiper_docs,name="SysOut",categories="User Functions;Built In;Input/Output",access="experimental"
*CMD SysOut --- similar to the Write function, except a copy of the output is also sent to Java's System.out stream
*CALL
    SysOut()

*DESC
If a function prints side effect output, the output is not displayed until the function returns.  If a function
throws an exception, the output may not be displayed at all.  Therefore, sometimes it is desireable to see
the output as it is printed instead of waiting until the function returns.  SysOut
is similar to the Write function, except it also sends a copy of its side effect output to Java's System.out
stream so that it can be viewed immediately.

*SEE Write
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewEnvironment.java0000644000175000017500000000477111414301026033017 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import javax.swing.JFrame;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.BuiltinObjectCons;

/**
 *
 *  
 */
public class ViewEnvironment extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewEnvironment");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         org.mathpiper.ui.gui.EnvironmentViewer viewer = new org.mathpiper.ui.gui.EnvironmentViewer();

         JFrame frame = viewer.getViewerFrame(aEnvironment);

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));
    }
}




/*
%mathpiper_docs,name="ViewEnvironment",categories="User Functions;Built In"
*CMD ViewEnvironment --- show the console window
*CORE
*CALL
    ViewEnvironment()

*DESC

Shows the MathPiper environment.

*E.G.
The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewEnvironment()
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ProbabilityToFScore.java0000644000175000017500000000526011334223061033542 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.jscistats.FDistribution;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;



public class ProbabilityToFScore extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ProbabilityToFScore");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber degreesOfFreedom1 = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        LispError.check(degreesOfFreedom1.isInteger() && degreesOfFreedom1.toInt() >= 0, "The first argument must be an integer which is greater than 0.", "ProbabilityToFScore", aStackTop, aEnvironment);

        BigNumber degreesOfFreedom2 = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        LispError.check(degreesOfFreedom2.isInteger() && degreesOfFreedom2.toInt() >= 0, "The second argument must be an integer which is greater than 0.", "ProbabilityToFScore", aStackTop, aEnvironment);

        BigNumber probability = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 3);

        LispError.check(probability.toDouble() >= 0, "The third argument must be greater than 0.", "ProbabilityToFScore", aStackTop, aEnvironment);


        FDistribution fDistribution = new FDistribution(degreesOfFreedom1.toDouble(),degreesOfFreedom2.toDouble());

        double fScoreValue = fDistribution.inverse(probability.toDouble());

        BigNumber fScore = new BigNumber(aEnvironment.getPrecision());

        probability.setTo(fScoreValue);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(probability));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="ProbabilityToFScore",categories="User Functions;Statistics & Probability"
*CMD ProbabilityToFScore --- calculates the f-score for a given cumulative probability

*CALL

    ProbabilityToFScore(degreesOfFreedom1, degreesOfFreedom2, probability)

*PARMS

{degreesOfFreedom1} -- integer, the first degree of freedom

{degreesOfFreedom2} -- integer, the second degree of freedom

{probability} -- the cumulative probability

*DESC
Calculates the calculates the f-score for a given cumulative probability.

*E.G.
In> ProbabilityToFScore(1,1,.95)
Result> 161.4476388


%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewList.java0000644000175000017500000000614011506507632031433 0ustar  giovannigiovannipackage org.mathpiper.builtin.functions.optional;

import java.awt.BorderLayout;
import java.awt.Color;
import java.awt.Container;
import java.awt.Dimension;
import javax.swing.JFrame;
import javax.swing.JPanel;
import javax.swing.JScrollPane;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.ui.gui.worksheets.ListPanel;
import org.mathpiper.ui.gui.worksheets.MathPanelController;
import org.mathpiper.ui.gui.worksheets.ScreenCapturePanel;

public class ViewList extends BuiltinFunction {

    public void plugIn(Environment aEnvironment) throws Exception {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewList");
    }//end method.



    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer expressionPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        JFrame frame = new JFrame();
        Container contentPane = frame.getContentPane();
        frame.setBackground(Color.WHITE);
        contentPane.setBackground(Color.WHITE);

        ListPanel listPanel = new ListPanel(aEnvironment, aStackTop, expressionPointer, 2);

        MathPanelController mathPanelScaler = new MathPanelController(listPanel, 2.0);

        JPanel screenCapturePanel = new ScreenCapturePanel();

        screenCapturePanel.add(listPanel);

        JScrollPane scrollPane = new JScrollPane(screenCapturePanel, JScrollPane.VERTICAL_SCROLLBAR_ALWAYS, JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);

        contentPane.add(scrollPane);
        contentPane.add(mathPanelScaler, BorderLayout.NORTH);

        frame.setAlwaysOnTop(false);
        frame.setTitle("List Viewer");
        frame.setSize(new Dimension(300, 200));
        frame.setResizable(true);
        frame.setLocationRelativeTo(null);

        frame.pack();
        frame.setVisible(true);

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

    }//end method.

}//end class.





/*
%mathpiper_docs,name="ViewList",categories="User Functions;Built In;Visualization"
*CMD ViewList --- display an expression in Lisp box diagram form

*CALL
    ViewList(expression)

*Params
{expression} -- an expression to view

*DESC
Display an expression in Lisp box diagram form.

*E.G.
In> ViewList(x^2)

In> ViewList(2*x^3+14*x^2+24*x)

 

The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewList(x^2)
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

*SEE LispForm, ViewMath
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/TraceSome.java0000644000175000017500000001172211504231423031537 0ustar  giovannigiovanni
/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.util.ArrayList;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.printers.MathPiperPrinter;

/**
 *
 *
 */
public class TraceSome extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
                "TraceSome");
        aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "TraceSome");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {

        ConsPointer functionListPointer = getArgumentPointer(aEnvironment, aStackTop, 1);
        ConsPointer bodyPointer = getArgumentPointer(aEnvironment, aStackTop, 2);

        // Get function list.
        LispError.checkArgument(aEnvironment, aStackTop, functionListPointer.getCons() != null, 1, "TraceSome");
        ConsPointer result = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result , functionListPointer);
        String functionNamesString =  (String) result.car();
        LispError.checkArgument(aEnvironment, aStackTop, functionNamesString != null, 1, "TraceSome");

        
        //Place function names into a List and then set this as the trace function list in Evaluator.
        functionNamesString = functionNamesString.replace("\"", "");
        String[] functionNames = functionNamesString.split(",");
        ArrayList functionNamesList = new ArrayList();
        for(String functionName : functionNames)
        {
            functionNamesList.add(functionName.trim());
        }//end for.
        Evaluator.setTraceFunctionList(functionNamesList);


        //Evaluate expresstion with tracing on.
        Evaluator.traceOn();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), bodyPointer);
        Evaluator.traceOff();
        Evaluator.setTraceFunctionList(null);


       // UtilityFunctions.internalTrue(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));


    }//end method.

}//end class.




/*
%mathpiper_docs,name="TraceSome",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD TraceSome --- trace the given functions which are evaluated in the given expression
*CORE
*CALL
	TraceSome("function_name,function_name,function_name,...") expression

*PARMS

{"function_name,function_name,function_name,..."} -- a string which contains the names of functions to trace separated by commas.

{expression} -- an expression to trace.

*DESC

Outputs a trace of the functions which are listed in the given string and are evaluated in the given expression


*E.G.
In> TraceSome("Factors,FactorizeInt") Factor(8)
Result> True
Side Effects>
Enter<**** user rulebase>{(Factors,Factors(p));
    Arg(p->8);
    **** Rule in function (Factors) matched: Precedence: 10, Parameters: arg1, Predicates: (Pattern) IsInteger(p), True,     Variables: p,    Types: Variable, Body: FactorizeInt(p)
    Enter<**** user rulebase>{(FactorizeInt,FactorizeInt(p));
        Arg(p->8);
        **** Rule in function (FactorizeInt) matched: Precedence: 3, Parameters: arg1, Predicates: (Pattern) IsInteger(n), True,     Variables: n,    Types: Variable, Body: [    Local(small'powers);    n:=Abs(n);    If(Gcd(ProductPrimesTo257(),n)>1,small'powers:=TrialFactorize(n,257),small'powers:={n});    n:=small'powers[1];    If(n=1,Tail(small'powers),[        If(InVerboseMode(),Echo({"FactorizeInt: Info: remaining number ",n}));        SortFactorList(PollardCombineLists(Tail(small'powers),PollardRhoFactorize(n)));]);]
    Leave<**** user rulebase>}(FactorizeInt(p)->{{2,3}});
Leave<**** user rulebase>}(Factors(p)->{{2,3}});


*SEE TraceExcept, StackTrace, StackTraceOn, StackTraceOff, TraceOff

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewSimulator.java0000644000175000017500000000404711334223061032471 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class ViewSimulator extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewSimulator");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         org.mathpiper.ui.gui.simulator.SimulatorFrame  simulator = new org.mathpiper.ui.gui.simulator.SimulatorFrame();
         JavaObject javaObject = new JavaObject(simulator);
         aEnvironment.setGlobalVariable(aStackTop, "Simulator", new ConsPointer( BuiltinObjectCons.getInstance(aEnvironment, aStackTop, javaObject)), false);
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewGraphicConsole.java0000644000175000017500000000617511415301703033416 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import java.awt.Dimension;
import java.awt.BorderLayout;
import java.awt.Container;
import javax.swing.JFrame;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.ui.gui.consoles.GraphicConsole;

/**
 *
 *
 */
public class ViewGraphicConsole extends BuiltinFunction
{

        public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewGraphicConsole");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        GraphicConsole console = new GraphicConsole();

        JFrame frame = new javax.swing.JFrame();
        Container contentPane = frame.getContentPane();
        contentPane.add(console, BorderLayout.CENTER);
        //frame.setAlwaysOnTop(true);
        frame.setSize(new Dimension(800, 600));
        frame.setDefaultCloseOperation(frame.DISPOSE_ON_CLOSE);
        //frame.setResizable(false);
        frame.setTitle("Graphic Console");
        frame.setPreferredSize(new Dimension(800, 600));
        frame.setLocationRelativeTo(null); // added
        frame.pack();
        frame.setVisible(true);

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="ViewGraphicConsole",categories="User Functions;Built In",access="experimental"
*CMD ViewConsole --- show the console window
*CORE
*CALL
    ViewGraphicConsole()

*DESC

Shows the graphic console window.

*E.G.
The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewGraphicConsole()
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/SimulatorPlot.java0000644000175000017500000000451511334223061032475 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class SimulatorPlot extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "SimulatorPlot");
    }//end method.
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         ConsPointer consPointer = new ConsPointer();
         aEnvironment.getGlobalVariable(aStackTop, "Simulator", consPointer);
         org.mathpiper.ui.gui.simulator.SimulatorFrame simulator =  (org.mathpiper.ui.gui.simulator.SimulatorFrame)  ((BuiltinContainer)consPointer.car()).getObject();
         
         Cons xCons = getArgumentPointer(aEnvironment, aStackTop, 1).getCons();
         Cons yCons = getArgumentPointer(aEnvironment, aStackTop, 2).getCons();
         int xValue = Integer.parseInt( (String) xCons.car());
         int yValue = Integer.parseInt( (String) yCons.car());
         simulator.plotPoint(xValue,yValue);
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/TraceOn.java0000644000175000017500000001052111400407716031211 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *  
 */
public class TraceOn extends BuiltinFunction {

    public void plugIn(Environment aEnvironment) throws Exception {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "TraceOn");
    }//end method.


    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        Evaluator.traceOn();
        aEnvironment.write("Tracing is on.\n");
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }//end method.
    
}//end class.




/*
%mathpiper_docs,name="TraceOn",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD TraceOn --- enables a complete trace of all the functions that are called when an expression is evaluated
*CALL
    TraceOn()

*DESC
This function enables a complete trace of all the functions that are called when an expression is evaluated.
The tracing output can become very long, very quickly so this form of complete tracing is only useful
for tracing relatively simple expressions.  TraceSome and TraceExcept can be used as an alternative to reduce
the amount of tracing output that is generated.

The first time a function is called during a MathPiper session, it needs to be loaded
and converted into Lisp code.  If tracing is enabled when functions are being loaded, the loading code
will also be traced.  This loading code can be caused to not appear in the trace by simply evaluating the
expression to be traced once with tracing off and then evaluating it again with tracing on.

In the example below, the {output} attribute of the {%mathpiper} fold is set to {trace} so that the output
is placed into a {%mathpiper_trace} fold.  This will enable the trace output to be syntax highlighted.

*E.G.
/%mathpiper,output="trace"

TraceOn();

2 + 3;

TraceOff();

/%/mathpiper

    /%mathpiper_trace,preserve="false"
      Result: True

      Side Effects:
      Tracing is on.
          Enter<**** user rulebase>{(+, 2+3);
              Arg(arg1 -> 2);
              Arg(arg2 -> 3);
              Enter{(IsNumber, IsNumber(x));
                  Arg(parameter1 -> 2);
              Leave}(IsNumber(x) -> True,    Local variables: y -> 3, x -> 2, arg2 -> 3, arg1 -> 2, );
              Enter{(IsNumber, IsNumber(y));
                  Arg(parameter1 -> 3);
              Leave}(IsNumber(y) -> True,    Local variables: y -> 3, x -> 2, arg2 -> 3, arg1 -> 2, );
              **** Rule in function (+) matched: Precedence: 50, Parameters: arg1, arg2, Predicates: (Pattern) IsNumber(x), IsNumber(y), True,     Variables: x, y,     Types: Variable, Variable,    Body: AddN(x, y)
              Enter{(AddN, AddN(x,y));
                  Arg(parameter1 -> 2);
                  Arg(parameter2 -> 3);
              Leave}(AddN(x,y) -> 5,    Local variables: y -> 3, x -> 2, arg2 -> 3, arg1 -> 2, );
          Leave<**** user rulebase>}(2+3 -> 5,    Local variables: y -> 3, x -> 2, arg2 -> 3, arg1 -> 2, );
          Enter{(TraceOff, TraceOff());
      Tracing is off.

.   /%/mathpiper_trace

*SEE StackTrace, StackTraceOn, StackTraceOff, TraceSome, TraceExcept, TraceOff
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewLatex.java0000644000175000017500000001627311506507632031605 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.awt.BorderLayout;
import java.awt.Container;
import java.awt.Dimension;
import javax.swing.Box;
import javax.swing.JFrame;
import javax.swing.JScrollPane;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;

import java.awt.Color;

import javax.swing.JLabel;

import javax.swing.JPanel;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.ui.gui.worksheets.LatexRenderingController;
import org.mathpiper.ui.gui.worksheets.ScreenCapturePanel;
import org.scilab.forge.jlatexmath.TeXFormula;
import org.scilab.forge.jlatexmath.DefaultTeXFont;

import org.scilab.forge.jlatexmath.cyrillic.CyrillicRegistration;
import org.scilab.forge.jlatexmath.greek.GreekRegistration;

/**
 *
 *
 */
public class ViewLatex extends BuiltinFunction {

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewLatexInternal");

       String[] parameters = new String[] {"expression","size"};
       Utility.declareFunction("ViewLatex", parameters, "ViewLatexInternal(expression, size);", aEnvironment, LispError.TODO);


       parameters = new String[] {"expression"};
       Utility.declareFunction("ViewLatex", parameters, "ViewLatexInternal(expression, 2);", aEnvironment, LispError.TODO);


        DefaultTeXFont.registerAlphabet(new CyrillicRegistration());
	DefaultTeXFont.registerAlphabet(new GreekRegistration());


    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        String latexString = null;

        ConsPointer consPointer = null;

        Object expressionPointer = getArgumentPointer(aEnvironment, aStackTop, 1).car();

        if (expressionPointer instanceof String)
        {
            latexString = (String) expressionPointer;

            latexString = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, latexString);

            latexString = Utility.stripEndDollarSigns(latexString);
        }
        else
        {
            LispError.raiseError("The first argument must be a string which contains Latex code.", "ViewLatex", aStackTop, aEnvironment);
        }//end else.



        ConsPointer resultPointer = new ConsPointer();

        ConsPointer viewScalePointer = new ConsPointer();
        viewScalePointer.setCons(getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, resultPointer, viewScalePointer);
        BigNumber viewScale = (BigNumber) resultPointer.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, viewScale != null, 1, "ViewLatex");

        /*sHotEqn hotEqn = new sHotEqn();
        hotEqn.setFontsizes(18,18,18,18);
        hotEqn.setEquation(latexString);
        JScrollPane hotEqnScrollPane = new JScrollPane(hotEqn,JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
        */




        //MathPiper built-in math viewer.
        /*TexParser parser = new TexParser();
        SymbolBox sBoxExpression = parser.parse(latexString);
        MathPanel mathPanel = new MathPanel(sBoxExpression, viewScale.toDouble());
        MathPanelController mathPanelScaler = new MathPanelController(mathPanel, viewScale.toDouble());
        JScrollPane mathPiperScrollPane = new JScrollPane(mathPanel,JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
         */

        JFrame frame = new JFrame();
        Container contentPane = frame.getContentPane();
        frame.setBackground(Color.WHITE);
        contentPane.setBackground(Color.WHITE);

        /*
        DebugGraphics.setFlashCount(10);
        DebugGraphics.setFlashColor(Color.red);
        DebugGraphics.setFlashTime(1000);
        RepaintManager.currentManager(panel).setDoubleBufferingEnabled(false);
        panel.setDebugGraphicsOptions(DebugGraphics.FLASH_OPTION);
        panel.setDebugGraphicsOptions(DebugGraphics.LOG_OPTION);
         */

        Box box = Box.createVerticalBox();


        //JLateXMath
	TeXFormula formula = new TeXFormula(latexString);
        JLabel latexLabel = new JLabel();
        JPanel latexPanelController = new LatexRenderingController(formula, latexLabel, 100);

        JPanel screenCapturePanel = new ScreenCapturePanel();

        screenCapturePanel.add(latexLabel);

        JScrollPane jMathTexScrollPane = new JScrollPane(screenCapturePanel, JScrollPane.VERTICAL_SCROLLBAR_ALWAYS,JScrollPane.HORIZONTAL_SCROLLBAR_ALWAYS);
        jMathTexScrollPane.getViewport().setBackground(Color.WHITE);
        box.add(jMathTexScrollPane);

        contentPane.add(box);

        contentPane.add(latexPanelController, BorderLayout.NORTH);

        //box.add(mathPiperScrollPane);

        frame.setAlwaysOnTop(false);
        frame.setTitle("MathPiper");
        frame.setSize(new Dimension(300, 200));
        frame.setResizable(true);
        frame.setLocationRelativeTo(null);

        frame.pack();
        frame.setVisible(true);


        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));


    }//end method.


}//end class.





/*
%mathpiper_docs,name="ViewLatex",categories="User Functions;Visualization"
*CMD ViewLatex --- display rendered Latex code

*CALL
    ViewLatex(string)

*Params
{string} -- a string which contains Latex code

*DESC
Display rendered Latex code.  Note: backslashes must be escaped
with a backslash.
 
*E.G.
In> ViewLatex("2\\sum_{i=1}^n a_i")
Result: javax.swing.JFrame



The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewLatex("2\\sum_{i=1}^n a_i")
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

*SEE ViewMath
%/mathpiper_docs
*/



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/TraceExcept.java0000644000175000017500000001476011504231423032071 0ustar  giovannigiovanni
/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.util.ArrayList;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.printers.MathPiperPrinter;

/**
 *
 *
 */
public class TraceExcept extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
                "TraceExcept");
        aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "TraceExcept");
    }//end method.
    
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {

        ConsPointer functionListPointer = getArgumentPointer(aEnvironment, aStackTop, 1);
        ConsPointer bodyPointer = getArgumentPointer(aEnvironment, aStackTop, 2);

        // Get function list.
        LispError.checkArgument(aEnvironment, aStackTop, functionListPointer.getCons() != null, 1, "TraceExcept");
        ConsPointer result = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result , functionListPointer);
        String functionNamesString =  (String) result.car();


        LispError.checkArgument(aEnvironment, aStackTop, functionNamesString != null, 1, "TraceExcept");


        //Place function names into a List and then set this as the trace function list in Evaluator.
        functionNamesString = functionNamesString.replace("\"", "");
        String[] functionNames = functionNamesString.split(",");
        ArrayList functionNamesList = new ArrayList();
        for(String functionName : functionNames)
        {
            functionNamesList.add(functionName.trim());
        }//end for.
        Evaluator.setTraceExceptFunctionList(functionNamesList);


        //Evaluate expresstion with tracing on.
        Evaluator.traceOn();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), bodyPointer);
        Evaluator.traceOff();
        Evaluator.setTraceExceptFunctionList(null);

    }//end method.

}//end class.




/*
%mathpiper_docs,name="TraceExcept",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD TraceExcept --- trace all the functions but the given functions an expression
*CORE
*CALL
	TraceExcept("function_name,function_name,function_name,...") expression

*PARMS

{"function_name,function_name,function_name,..."} -- a string which contains the names of functions not to trace separated by commas.

{expression} -- an expression to trace.

*DESC

Outputs a trace of all the functions which are evaluated in the given expression except those which are listed in the given string.  An empty
function list string means trace all of the functions which are evaluated in the given expression.


*E.G.

In> TraceExcept("") 2+3-6 //An empty function list means trace all functions.
Result> True
Side Effects>
Enter<**** user rulebase>{(-,2+3-6);
    Enter<**** user rulebase>{(+,2+3);
        Arg(2->2);
        Arg(3->3);
        Enter{(IsNumber,IsNumber(x));
            Arg(x->2);
        Leave}(IsNumber(x)->True);
        Enter{(IsNumber,IsNumber(y));
            Arg(y->3);
        Leave}(IsNumber(y)->True);
        **** Rule in function (+) matched: Precedence: 50, Parameters: arg1, arg2, Predicates: (Pattern) IsNumber(x), IsNumber(y), True,     Variables: x, y,    Types: Variable, Variable, Body: AddN(x,y)
        Enter{(AddN,AddN(x,y));
            Arg(x->2);
            Arg(y->3);
        Leave}(AddN(x,y)->5);
    Leave<**** user rulebase>}(2+3->5);
    Arg(2+3->5);
    Arg(6->6);
    Enter{(IsList,IsList($x8));
        Arg($x8->5);
    Leave}(IsList($x8)->False);
    Enter{(IsNumber,IsNumber(x));
        Arg(x->5);
    Leave}(IsNumber(x)->True);
    Enter{(IsNumber,IsNumber(y));
        Arg(y->6);
    Leave}(IsNumber(y)->True);
    **** Rule in function (-) matched: Precedence: 50, Parameters: arg1, arg2, Predicates: (Pattern) IsNumber(x), IsNumber(y), True,     Variables: x, y,    Types: Variable, Variable, Body: SubtractN(x,y)
    Enter{(SubtractN,SubtractN(x,y));
        Arg(x->5);
        Arg(y->6);
    Leave}(SubtractN(x,y)->-1);
Leave<**** user rulebase>}(2+3-6->-1);


In> TraceExcept("IsList, IsNumber") 2+3-6
Result> True
Side Effects>
Enter<**** user rulebase>{(-,2+3-6);
    Enter<**** user rulebase>{(+,2+3);
        Arg(2->2);
        Arg(3->3);
        **** Rule in function (+) matched: Precedence: 50, Parameters: arg1, arg2, Predicates: (Pattern) IsNumber(x), IsNumber(y), True,     Variables: x, y,    Types: Variable, Variable, Body: AddN(x,y)
        Enter{(AddN,AddN(x,y));
            Arg(x->2);
            Arg(y->3);
        Leave}(AddN(x,y)->5);
    Leave<**** user rulebase>}(2+3->5);
    Arg(2+3->5);
    Arg(6->6);
    **** Rule in function (-) matched: Precedence: 50, Parameters: arg1, arg2, Predicates: (Pattern) IsNumber(x), IsNumber(y), True,     Variables: x, y,    Types: Variable, Variable, Body: SubtractN(x,y)
    Enter{(SubtractN,SubtractN(x,y));
        Arg(x->5);
        Arg(y->6);
    Leave}(SubtractN(x,y)->-1);
Leave<**** user rulebase>}(2+3-6->-1);


 *SEE TraceSome, StackTrace, StackTraceOn, StackTraceOff, TraceOff

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/MacroExpand.java0000644000175000017500000000642611450024436032067 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.printers.MathPiperPrinter;

/**
 *
 *
 */
public class MacroExpand extends BuiltinFunction
{
    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
                "MacroExpand");
	
	aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "MacroExpand");
    }//end method.


    //todo:tk:this function is not complete yet.  It currently only expands backquoted expressions.
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        org.mathpiper.lisp.behaviours.BackQuoteSubstitute behaviour = new org.mathpiper.lisp.behaviours.BackQuoteSubstitute(aEnvironment);

        ConsPointer result = new ConsPointer();

        ConsPointer argument = getArgumentPointer(aEnvironment, aStackTop, 1);

        Cons argumentCons = argument.getCons();

        argument = ((ConsPointer) argumentCons.car()).cdr();

        Utility.substitute(aEnvironment, aStackTop, result, argument, behaviour);

        String substitutedResult = Utility.printMathPiperExpression(aStackTop, result, aEnvironment, 0);

        aEnvironment.write(substitutedResult);
	
	aEnvironment.write("\n");

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, getTopOfStackPointer(aEnvironment, aStackTop), result);

    }//end method.

}//end class.




/*
%mathpiper_docs,name="MacroExpand",categories="Programmer Functions;Built In;Programming",access="experimental"
*CMD MacroExpand --- shows the expanded form of a macro
*CALL
    MacroExpand() macro

*PARMS
{macro} -- a macro to expand

*DESC
This function shows the expanded form of the Lisp-like macros that MathPiper supports.
Note: only back quoted macros are supported at this time.

*E.G.
//Bind the variable var to the atom Echo.
In> var := Echo;
Result: Echo

//Show the macro in expanded form.
In> MacroExpand()`(@var(2,"Hello"))
Result: True
Side Effects:
Echo(2,"Hello")
2 Hello

//Execute the macro.
In> `(@var(2,"Hello"))
Result: True
Side Effects:
2 Hello

*SEE `
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/StackTraceOn.java0000644000175000017500000000746711400400116032201 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class StackTraceOn extends BuiltinFunction {

    public void plugIn(Environment aEnvironment) throws Exception {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "StackTraceOn");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        Evaluator.stackTraceOn();
        aEnvironment.write("Stack tracing is on.\n");
        Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }//end method.

}//end class.




/*
%mathpiper_docs,name="StackTraceOn",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD StackTraceOn --- sets the flag which will show a stack trace when an exception is thrown
*CALL
    StackTraceOn()

*DESC
This function sets the flag which will show the current state of the user function stack and the built in function stack
when an exception is thrown.

It is currently somewhat difficult to follow the stack traces at points where user functions call built in
functions and vice versa because there are no clear markers which indicate where control leave one stack
and enters the other.  However, even with this difficulty, the StackTrace function has still been proven
to be a useful debugging tool.

*E.G.
/%mathpiper

TestFunction() :=
[
    IsLessThan(Complex(1,1),3);
];


StackTraceOn();

TestFunction();

StackTraceOff();

/%/mathpiper

    /%error,preserve="false"
      Result: In function "IsLessThan" :
      bad argument number 1(counting from 1) :
      The first argument must be a non-complex decimal number or a string.
      The offending argument Complex(1,1) evaluated to Complex(1,1)


      ========================================= Start Of Built In Function Stack Trace
      0: LoadScript
         1: -> "/tmp/mathpiperide917565545585604790.mpw_tmp"
      -----------------------------------------
      2: Prog
         3: -> IsLessThan(Complex(1,1),3)
      -----------------------------------------
      4: IsLessThan
         5: -> Complex(1,1)
         6: -> 3
      ========================================= End Of Built In Function Stack Trace



      ========================================= Start Of User Function Stack Trace
      0: Prog
      -----------------------------------------
      1: TestFunction
      -----------------------------------------
      2: 
      ========================================= End Of User Function Stack Trace

       In function: TestFunction, Error near line 14

      Side Effects:
      Stack tracing is on.

.   /%/error

*SEE StackTrace, StackTraceOff, TraceSome, TraceExcept, TraceOn, TraceOff
%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/PanAxiom.java0000644000175000017500000001514011412252255031373 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.ConsPointer;
import java.util.ArrayList;
import java.util.regex.Matcher;
import java.util.regex.Pattern;
import java.io.*;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class PanAxiom extends BuiltinFunction {

    private static PanAxiom FriCASInstance = null;
    private StringBuffer responseBuffer;
    private Pattern inputPromptPattern;
    private InputStream inputStream;
    private OutputStream outputStream;
    private String response;
    private String startMessage;
    private String fileSearchMaximaAppendResponse;
    private String fileSearchLispAppendResponse;
    private boolean keepRunning;
    private String prompt;
    private boolean fricasInstalled = false;

    /** Creates a new instance of MaximaWrapper */
    public PanAxiom() {


        /*
        ArrayList command = new ArrayList();
        //command.add("C:\\Program Files\\Maxima-5.15.0\\bin\\maxima.bat");

        String fricasPath = "/home/tkosan/checkouts/usr/local/bin/fricas";
        File fricasCommandFile = new File(fricasPath);
        if(fricasCommandFile.exists())
        {
            command.add(fricasPath);
            command.add("-nox");
            command.add("-noclef");


        try {
            ProcessBuilder processBuilder = new ProcessBuilder(command);
            Process fricasProcess = processBuilder.start();
            inputStream = fricasProcess.getInputStream();
            outputStream = fricasProcess.getOutputStream();
            responseBuffer = new StringBuffer();
            inputPromptPattern = Pattern.compile("\\n\\([0-9]+\\) \\->");
            startMessage = getResponse();

            send("2+2\n");
            getResponse();

            fricasInstalled = true;
        } catch (Throwable t) {
            t.printStackTrace();

        }



        //System.out.println("M+");
        }
        else
        {
            //System.out.println("M-");
        }




    */

    }//end constructor.

    public String getStartMessage() {
        return startMessage;
    }//end method.

    public String getPrompt() {
        return prompt;
    }//end method.

    public static PanAxiom getInstance() throws Throwable {
        if (FriCASInstance == null) {
            FriCASInstance = new PanAxiom();
        }
        return FriCASInstance;
    }//end method.

    public synchronized void send(String send) throws Throwable {
        outputStream.write(send.getBytes());
        outputStream.flush();
    }//end send.

    protected String getResponse() throws Throwable {
        boolean keepChecking = true;

        mainLoop:
        while (keepChecking) {
            int serialAvailable = inputStream.available();
            if (serialAvailable == 0) {
                try {
                    Thread.sleep(100);
                } catch (InterruptedException ie) {
                    System.out.println("FriCAS session interrupted.");
                }
                continue mainLoop;
            }//end while

            byte[] bytes = new byte[serialAvailable];

            inputStream.read(bytes, 0, serialAvailable);
            responseBuffer.append(new String(bytes));
            response = responseBuffer.toString();
            //System.out.println("SSSSS " + response);
            Matcher matcher = inputPromptPattern.matcher(response);
            if (matcher.find()) {
                //System.out.println("PPPPPP found end");

                responseBuffer.delete(0, responseBuffer.length());

                /*
                int promptIndex = response.lastIndexOf("(%");
                if (promptIndex == -1) {
                    promptIndex = response.lastIndexOf("MAX");
                }
                prompt = response.substring(promptIndex, response.length());
                response = response.substring(0, promptIndex);
                */

                keepChecking = false;

            }//end if.

        }//end while.

        return response;

    }//end method

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "Maxima");

    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {
        ConsPointer expressionPointerr = new ConsPointer();
        expressionPointerr.setCons(getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, expressionPointerr.getCons() != null, 1, "Maxima");
        String orig = (String) expressionPointerr.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "Maxima");

        if(fricasInstalled)
        {
        orig = orig.substring(1,orig.length()-1); //Strip quotes.

        try {
            send(orig + ";\n");
            String response = getResponse();

            if(response.startsWith("\n"))
            {
                response = response.substring(1);
            }

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(AtomCons.getInstance(aEnvironment, aStackTop, response));
        } catch (Throwable t) {
            t.printStackTrace();
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }
        }
        else
        {
            aEnvironment.write("FriCAS is not installed.");
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
        }


    }
}//end class.


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/StackTrace.java0000644000175000017500000000763411400400116031700 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class StackTrace extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "StackTrace");
    }//end method.


    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         String dump = aEnvironment.iArgumentStack.dump(aStackTop, aEnvironment);

         aEnvironment.write(dump);

         dump = aEnvironment.dumpLocalVariablesFrame(aStackTop);

         aEnvironment.write(dump);
         
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="StackTrace",categories="Programmer Functions;Built In;Debugging",access="experimental"
*CMD StackTrace --- shows the current state of the user function stack and the built in function stack
*CALL
    StackTrace()

*DESC
This function shows the current state of the user function stack and the built in function stack.

It is currently somewhat difficult to follow the stack traces at points where user functions call built in
functions and vice versa because there are no clear markers which indicate where control leave one stack
and enters the other.  However, even with this difficulty, the StackTrace function has still been proven
to be a useful debugging tool.

*E.G.
/%mathpiper
TestFunction() :=
[
    index := 1;
    While(index < 10)
    [
        If(index = 5, StackTrace());

        index++;
    ];

];
/%/mathpiper


In> TestFunction()
Result: True
Side Effects:


========================================= Start Of Built In Function Stack Trace
0: Prog
   1: -> TestFunction()
-----------------------------------------
2: Prog
   3: -> index:=1
   4: -> While(index<10)[
    If(index=5,StackTrace());
    index++;
]

-----------------------------------------
5: index<10
-----------------------------------------
6: [
    If(index=5,StackTrace());
    index++;
]

-----------------------------------------
7: Prog
   8: -> If(index=5,StackTrace())
   9: -> index++
-----------------------------------------
10: index=5
-----------------------------------------
11: {StackTrace()}
-----------------------------------------
12: StackTrace
========================================= End Of Built In Function Stack Trace



========================================= Start Of User Function Stack Trace
0: Prog
-----------------------------------------
1: Prog
-----------------------------------------
2: TestFunction
-----------------------------------------
3: Prog
-----------------------------------------
4: 
========================================= End Of User Function Stack Trace

*SEE StackTraceOn, StackTraceOff, TraceSome, TraceExcept, TraceOn, TraceOff
%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewHelp.java0000644000175000017500000000675511414301026031407 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import java.awt.BorderLayout;
import java.awt.Container;
import java.awt.Dimension;
import java.io.FileNotFoundException;
import javax.swing.JFrame;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.ui.gui.help.FunctionTreePanel;

/**
 *
 *
 */
public class ViewHelp extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewHelp");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        JFrame frame = new javax.swing.JFrame();

        frame.setDefaultCloseOperation(JFrame.DISPOSE_ON_CLOSE);

        FunctionTreePanel functionTreePanel = null;

        try {

            functionTreePanel = new FunctionTreePanel();

            Container contentPane = frame.getContentPane();
            contentPane.add(functionTreePanel.getToolPanel(), BorderLayout.NORTH);
            contentPane.add(functionTreePanel, BorderLayout.CENTER);

            frame.pack();

            frame.setTitle("MathPiper Help");
            frame.setSize(new Dimension(700, 700));
            //frame.setResizable(false);
            frame.setPreferredSize(new Dimension(700, 700));
            frame.setLocationRelativeTo(null); // added

            frame.setVisible(true);

            JavaObject response = new JavaObject(frame);

            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

        } catch (FileNotFoundException fnfe) {
            LispError.raiseError("The help application data file was not found.", "ViewHelp", aStackTop, aEnvironment);
        }


         
    }//end method.

}//end class.




/*
%mathpiper_docs,name="ViewHelp",categories="User Functions;Built In"
*CMD ViewHelp --- display the function help window
*CORE
*CALL
    ViewHelp()

*DESC

Displays the function help window.

*E.G.
The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewHelp()
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

%/mathpiper_docs
*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/ViewHtml.java0000644000175000017500000001143211503734166031425 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.optional;

import java.awt.Container;
import java.awt.Dimension;
import javax.swing.JEditorPane;
import javax.swing.JFrame;
import javax.swing.JScrollPane;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.ui.gui.help.FunctionTreePanel;

/**
 *
 *
 */
public class ViewHtml extends BuiltinFunction {

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "ViewHtml");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        String htmlText = null;
        
        ConsPointer consPointer = null;

        Object argument = getArgumentPointer(aEnvironment, aStackTop, 1).car();

        if (argument instanceof String)
        {
            htmlText = (String) argument;

            htmlText = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, htmlText);
        }
        else if (argument instanceof BuiltinContainer)
        {
            BuiltinContainer builtinContainer = (BuiltinContainer) argument;
            LispError.check(builtinContainer.typeName().equals("java.lang.String"), "Argument must be a MathPiper string or a Java String object.", "ViewHtml", aStackTop, aEnvironment);
            htmlText = (String) builtinContainer.getObject();
        }
        else
        {
            LispError.raiseError("Argument must be a MathPiper string or a Java String object.", "ViewHtml", aStackTop, aEnvironment);
        }//end else.

        htmlText = FunctionTreePanel.processLatex(htmlText);

        JFrame frame = new JFrame();
        Container contentPane = frame.getContentPane();
        contentPane.setLayout(new java.awt.BorderLayout());
        JEditorPane editorPane = new JEditorPane();
        editorPane.setEditorKit(new javax.swing.text.html.HTMLEditorKit());
        JScrollPane editorScrollPane = new JScrollPane(editorPane);
        editorScrollPane.setVerticalScrollBarPolicy(JScrollPane.VERTICAL_SCROLLBAR_ALWAYS);
        editorPane.setEditable(false);
        editorPane.setText(htmlText);
        contentPane.add(editorScrollPane);
        frame.pack();
        frame.setAlwaysOnTop(false);
        frame.setTitle("MathPiper");
        frame.setSize(new Dimension(750, 650));
        frame.setResizable(true);
        //frame.setPreferredSize(new Dimension(400, 400));
        frame.setLocationRelativeTo(null);
        frame.setVisible(true);

        JavaObject response = new JavaObject(frame);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, response));

    }//end method.
}//end class.




/*
%mathpiper_docs,name="ViewHtml",categories="User Functions;Built In;Visualization"
*CMD ViewHtml --- display rendered HTML code

*CALL
    ViewHtml(string)

*Params
{string} -- a string which contains HTML code

*DESC
Display rendered HTML code.

*E.G.
/%html

    
    HTML Demo
    

    
        
    HTML demo 1.
    


        
    LaTeX math formulas can be placed into the HTML code.
    
        \$x_{j}\$

    

/%/html



The ViewXXX functions all return a reference to the Java JFrame windows which they are displayed in.
This JFrame instance can be used to hide, show, and dispose of the window.

In> frame := ViewHtml("Hello")
Result: javax.swing.JFrame

In> JavaCall(frame, "hide")
Result: True

In> JavaCall(frame, "show")
Result: True

In> JavaCall(frame, "dispose")
Result: True

%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/IncompleteBeta.java0000644000175000017500000000341111334223061032544 0ustar  giovannigiovanni

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.library.cern.Gamma;
import org.mathpiper.lisp.Environment;



public class IncompleteBeta extends BuiltinFunction{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "IncompleteBeta");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
        BigNumber a = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 1);

        BigNumber b = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 2);

        BigNumber x = org.mathpiper.lisp.Utility.getNumber(aEnvironment, aStackTop, 3);

        double resultValue = Gamma.incompleteBeta(a.toDouble(), b.toDouble(), x.toDouble());

        BigNumber result = new BigNumber(aEnvironment.getPrecision());

        result.setTo(resultValue);

        getTopOfStackPointer(aEnvironment, aStackTop).setCons(new org.mathpiper.lisp.cons.NumberCons(result));

    }//end method.

}//end class.




/*
%mathpiper_docs,name="IncompleteBeta",categories="User Functions;Statistics & Probability"
*CMD IncompleteBeta --- the incomplete beta function
*CALL
    IncompleteBeta(a, b, x)

*PARMS
{a} -- the alpha parameter of the beta distribution

{b} -- the beta parameter of the beta distribution

{x} -- the integration end point

*DESC

The incomplete gamma function.

*E.G.
In> IncompleteGamma(2.5,3.6)
Result> 0.3188972206


%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/optional/SetPlotWidth.java0000644000175000017500000000427211334223061032251 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin.functions.optional;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 *
 *
 */
public class SetPlotWidth extends BuiltinFunction
{

    public void plugIn(Environment aEnvironment) throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                "SetPlotWidth");
    }//end method.

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception
    {
         ConsPointer consPointer = new ConsPointer();
         aEnvironment.getGlobalVariable(aStackTop, "Simulator", consPointer);
         org.mathpiper.ui.gui.simulator.SimulatorFrame simulator =  (org.mathpiper.ui.gui.simulator.SimulatorFrame) ((BuiltinContainer)consPointer.car()).getObject();

         Cons redCons = getArgumentPointer(aEnvironment, aStackTop, 1).getCons();
         int plotWidth = Integer.parseInt( (String) redCons.car());

         simulator.setPlotWidth(plotWidth);
         Utility.putTrueInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/0000755000175000017500000000000011722677320026657 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/0000755000175000017500000000000011722677320030774 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/CumulativePlot.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/CumulativePlot.0000644000175000017500000001540111334223061033737 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;

import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartFrame;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.data.xy.IntervalXYDataset;
import org.mathpiper.lisp.cons.BuiltinObjectCons;

/**
 *
 *
 */
public class CumulativePlot extends BuiltinFunction {

    private Map defaultOptions;

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "CumulativePlot");

        defaultOptions = new HashMap();
        defaultOptions.put("title", null);
        defaultOptions.put("xAxisLabel", null);
        defaultOptions.put("yAxisLabel", "Cumulative Frequency");
        defaultOptions.put("seriesTitle", "");
        defaultOptions.put("orientation", PlotOrientation.VERTICAL);
        defaultOptions.put("legend", true);
        defaultOptions.put("toolTips", true);
        defaultOptions.put("binMinumum", null);
        defaultOptions.put("binMaximum", null);
        defaultOptions.put("numberOfBins", null);

    }//end method.

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer argumentsPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        LispError.check(aEnvironment, aStackTop, Utility.isSublist(argumentsPointer), LispError.INVALID_ARGUMENT, "CumulativePlot");

        argumentsPointer.goSub(aStackTop, aEnvironment); //Go to sub list.

        argumentsPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        LispError.check(aEnvironment, aStackTop, Utility.isList(argumentsPointer), LispError.NOT_A_LIST, "CumulativePlot");

        ConsPointer dataListPointer = (ConsPointer) argumentsPointer.car(); //Grab the first member of the list.

        ConsPointer optionsPointer = (ConsPointer) argumentsPointer.cdr();
        
        Map userOptions = ChartUtility.optionsListToJavaMap(aEnvironment, aStackTop, optionsPointer, defaultOptions);


        IntervalXYDataset dataSet = ChartUtility.listToCumulativeDataset(aEnvironment, aStackTop, dataListPointer, userOptions);

        //createXYBarChart(java.lang.String title, java.lang.String xAxisLabel, boolean dateAxis, java.lang.String yAxisLabel, IntervalXYDataset dataset, PlotOrientation orientation, boolean legend, boolean tooltips, boolean urls)

        JFreeChart chart = ChartFactory.createXYBarChart(
                (String) userOptions.get("title"), //title.
                (String) userOptions.get("xAxisLabel"), //x axis label.
                false,
                (String) userOptions.get("yAxisLabel"), //y axis label.
                dataSet, //
                (PlotOrientation) userOptions.get("orientation"), //orientation.
                ((Boolean) userOptions.get("legend")).booleanValue(), //legend.
                ((Boolean) userOptions.get("toolTips")).booleanValue(),//tool tips.
                false);//urls.

        XYPlot plot = (XYPlot) chart.getPlot();
        plot.setDomainCrosshairVisible(true);
        plot.setDomainCrosshairLockedOnData(true);
        plot.setRangeCrosshairVisible(true);
        plot.setRangeCrosshairLockedOnData(true);
        plot.setDomainZeroBaselineVisible(true);
        plot.setRangeZeroBaselineVisible(true);
        plot.setDomainPannable(true);
        plot.setRangePannable(true);
        NumberAxis domainAxis = (NumberAxis) plot.getDomainAxis();
        domainAxis.setAutoRangeIncludesZero(false);


//create and display a frame...  Import("org/mathpiper/builtin/functions/plugins/jfreechart/")
//ChartFrame frame = new ChartFrame(null, chart);frame.pack();frame.setVisible(true);


        if (chart == null) {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(new ChartPanel(chart))));
            return;
        }//end if/else.


    }//end method.
    
}//end class.







/*
%mathpiper_docs,name="CumulativePlot",categories="User Functions;Visualization"
*CMD CumulativePlot --- displays a graphic cumulative plot
*CORE
*CALL
	CumulativePlot(list, option, option, option...)

*PARMS

{list} -- a list which contains the values

{numberOfBins} -- the number of bins in the histogram

{title} -- the title of the histogram

{xAxisLabel} -- the label for the x axis

{yAxisLabel} -- the label for the y axis

{seriesTitle} -- the title for a single data series


*DESC

Creates a cumulative plot. Options are entered using the -> operator.
For example, here is how to set the {title} option: {title -> "Example Title"}.

*E.G.
/%mathpiper,title=""

samples := {
438,413,444,468,445,472,474,454,455,449,
450,450,450,459,466,470,457,441,450,445,
487,430,446,450,456,433,455,459,423,455,
451,437,444,453,434,454,448,435,432,441,
452,465,466,473,471,464,478,446,459,464,
441,444,458,454,437,443,465,435,444,457,
444,471,471,458,459,449,462,460,445,437,
461,453,452,438,445,435,454,428,454,434,
432,431,455,447,454,435,425,449,449,452,
471,458,445,463,423,451,440,442,441,439
};

CumulativePlot(samples,numberOfBins -> 10, title -> "Cumulative Plot", xAxisLabel -> "X Axis", yAxisLabel -> "Y Axis", seriesTitle -> "Series Title");

/%/mathpiper


%/mathpiper_docs
*/

././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/ChartUtility.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/ChartUtility.ja0000644000175000017500000002414611561325013033732 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;


import java.util.ArrayList;
import java.util.Arrays;
import java.util.List;
import java.util.Map;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.data.statistics.HistogramDataset;
import org.jfree.data.xy.DefaultXYDataset;
import org.jfree.data.xy.IntervalXYDataset;
import org.jfree.data.xy.XYBarDataset;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


public class ChartUtility {


    public static Map optionsListToJavaMap(Environment aEnvironment, int aStackTop, ConsPointer argumentsPointer, Map defaultOptions) throws Exception {

        Map userOptions = Utility.optionsListToJavaMap(aEnvironment, aStackTop, argumentsPointer, defaultOptions);


        if (userOptions.containsKey("orientation")) {
                    if (userOptions.get("orientation").equals("vertical")) {
                        userOptions.put("orientation", PlotOrientation.VERTICAL);
                    } else if (userOptions.get("orientation").equals("horizontal")) {
                        userOptions.put("orientation", PlotOrientation.HORIZONTAL);
                    } else {
                        userOptions.put("orientation", PlotOrientation.VERTICAL);
                    }//end if/else.
                }

        return userOptions;
    }//end method.



    public static HistogramDataset listToHistogramDataset(Environment aEnvironment, int aStackTop, ConsPointer dataListPointer, Map userOptions) throws Exception {

        HistogramDataset dataSet = new HistogramDataset();

        if (Utility.isNestedList(aEnvironment, aStackTop, dataListPointer)) {

            List dataSeriesList = new ArrayList();
            dataListPointer.goNext(aStackTop, aEnvironment); //Strip List tag.
            int seriesIndex = 1;
            int dataSize = 0;
            while (dataListPointer.getCons() != null) {
                double[] dataValues = JavaObject.lispListToJavaDoubleArray(aEnvironment, aStackTop, (ConsPointer) dataListPointer.car());
                if (dataValues.length > dataSize)
                    dataSize = dataValues.length;
                String seriesTitle = "";
                if (userOptions.containsKey("series" + seriesIndex + "Title")) {
                    seriesTitle = (String) userOptions.get("series" + seriesIndex + "Title");
                }
                dataSeriesList.add(seriesTitle);
                dataSeriesList.add(dataValues);
                seriesIndex++;
                dataListPointer.goNext(aStackTop, aEnvironment);
            }//end while.

            int numberOfBins = Math.max((int) Math.sqrt(dataSize), 5);

            if (userOptions.get("numberOfBins") != null) {
                numberOfBins = (int) ((Double)userOptions.get("numberOfBins")).doubleValue();
            }

            Double binMinimum = (Double) userOptions.get("binMinimum");
            Double binMaximum = (Double) userOptions.get("binMaximum");

            int seriesIndex2 = 0;
            while (seriesIndex > 1) {
                String seriesTitle = (String) dataSeriesList.get(seriesIndex2++);
                double[] dataValues = (double[]) dataSeriesList.get(seriesIndex2++);
                if (binMinimum != null && binMaximum != null)
                    dataSet.addSeries(seriesTitle, dataValues, numberOfBins, binMinimum, binMaximum);
                else
                    dataSet.addSeries(seriesTitle, dataValues, numberOfBins);
                seriesIndex--;
            }//end while.

        } else {//Just a single series.
            double[] dataValues = JavaObject.lispListToJavaDoubleArray(aEnvironment, aStackTop, dataListPointer);

            int numberOfBins = Math.max((int) Math.sqrt(dataValues.length),5);
            Double numberOfBinsDouble = (Double) userOptions.get("numberOfBins");
            if (numberOfBinsDouble != null) {
                numberOfBins = (int) numberOfBinsDouble.doubleValue();
            }//end if.


            Double binMinimum = (Double) userOptions.get("binMinimum");
            Double binMaximum = (Double) userOptions.get("binMaximum");

            if (binMinimum != null && binMaximum != null) {
                dataSet.addSeries((String) userOptions.get("seriesTitle"), dataValues, numberOfBins, binMinimum, binMaximum);
            } else {
                dataSet.addSeries((String) userOptions.get("seriesTitle"), dataValues, numberOfBins);
            }
            //argumentsPointer.goNext();
        }//end if/else
        return dataSet;

    }//end method.


    public static XYBarDataset listToCumulativeDataset(Environment aEnvironment, int aStackTop, ConsPointer dataListPointer, Map userOptions) throws Exception {

        LispError.check(aEnvironment, aStackTop, !Utility.isNestedList(aEnvironment, aStackTop, dataListPointer), LispError.INVALID_ARGUMENT, "ChartUtility");


        int numberOfBins = 15;

        Double numberOfBinsDouble = (Double) userOptions.get("numberOfBins");
        if (numberOfBinsDouble != null) {
            numberOfBins = (int) numberOfBinsDouble.doubleValue();
        }//end if.


        double[] dataValues = JavaObject.lispListToJavaDoubleArray(aEnvironment, aStackTop, dataListPointer);


        Arrays.sort(dataValues);

        double minimumValue = Math.floor(dataValues[0]);
        double maximumValue = Math.floor(dataValues[dataValues.length - 1]);


        double[] cumulativeValues = new double[numberOfBins];
        double[] binLabels = new double[numberOfBins];

        double step = (maximumValue - minimumValue) / numberOfBins;

        int binIndex = 0;

        double binStartValue = minimumValue;

        int valuesInBinCount = 0;

        int index = 0;

        double binEndValue = 0;



        for (binEndValue = minimumValue + step; Math.floor(binEndValue) <= maximumValue; binEndValue = binEndValue + step, binStartValue = binStartValue + step ){


            while ( index != dataValues.length && (Math.floor(dataValues[index]) <= Math.floor(binEndValue))) {
                valuesInBinCount++;
                index++;
            }//end for.

            double binAverageValue = (binEndValue - binStartValue) / 2;

            double binLabelValue = binStartValue + binAverageValue;

            //System.out.println("bin start: " + binStartValue + "   bin end: " + binEndValue + "   bin label: " + binLabelValue);

            binLabels[binIndex] = binLabelValue;

            cumulativeValues[binIndex] = valuesInBinCount;


            binIndex++;

        }//end for.

        double[][] combinedValues = new double[][]{binLabels, cumulativeValues};


        //Double binMinimum = (Double) userOptions.get("binMinimum");
        //Double binMaximum = (Double) userOptions.get("binMaximum");
        String seriesTitle = (String) userOptions.get("seriesTitle");


        DefaultXYDataset dataSet = new DefaultXYDataset();
        dataSet.addSeries(seriesTitle, combinedValues);

        //argumentsPointer.goNext();

        return new XYBarDataset(dataSet, step);

    }//end method.



    public static DefaultXYDataset listToXYDataset(Environment aEnvironment, int aStackTop, ConsPointer dataListPointer, Map userOptions) throws Exception {

        LispError.check(aEnvironment, aStackTop, Utility.isNestedList(aEnvironment, aStackTop, dataListPointer), LispError.INVALID_ARGUMENT, "ChartUtility");

        DefaultXYDataset dataSet = new DefaultXYDataset();

        dataListPointer.goNext(aStackTop, aEnvironment); //Strip List tag.
        int seriesIndex = 1;
        while (dataListPointer.getCons() != null) {
            double[] dataXValues = JavaObject.lispListToJavaDoubleArray(aEnvironment, aStackTop, (ConsPointer) dataListPointer.car());
            dataListPointer.goNext(aStackTop, aEnvironment);
            double[] dataYValues = JavaObject.lispListToJavaDoubleArray(aEnvironment, aStackTop, (ConsPointer) dataListPointer.car());

            String seriesTitle = "series" + seriesIndex;
            if (userOptions.containsKey("series" + seriesIndex + "Title")) {
                seriesTitle = (String) userOptions.get("series" + seriesIndex + "Title");
            }

            LispError.check(aEnvironment, aStackTop, dataXValues.length == dataYValues.length, LispError.LIST_LENGTHS_MUST_BE_EQUAL, "ChartUtility");

            dataSet.addSeries(seriesTitle, new double[][]{dataXValues, dataYValues});

            seriesIndex++;
            dataListPointer.goNext(aStackTop, aEnvironment);
        }//end while.


        return dataSet;

    }//end method.



    public static IntervalXYDataset listToIntervalXYDataset(Environment aEnvironment, int aStackTop, ConsPointer dataListPointer, Map userOptions) throws Exception {

        DefaultXYDataset xYDataset = listToXYDataset(aEnvironment, aStackTop, dataListPointer, userOptions);

        int seriesCount = xYDataset.getSeriesCount();
        LispError.check(aEnvironment, aStackTop, seriesCount != 0, LispError.INVALID_ARGUMENT, "ChartUtility");

        //int seriesItemCount =  xYDataset.getItemCount(0);

        //double lowXValue = xYDataset.getXValue(0, 0);

        //double highXValue = xYDataset.getXValue(0, seriesItemCount-1);

        double barWidth = xYDataset.getXValue(0, 1) - xYDataset.getXValue(0, 0);

        return new XYBarDataset(xYDataset, barWidth);
    }//end method.


}//end class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/LineChart.java0000644000175000017500000001573011334223061033502 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;


import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartFrame;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.chart.renderer.xy.XYBarRenderer;
import org.jfree.data.xy.IntervalXYDataset;
import org.mathpiper.lisp.cons.BuiltinObjectCons;


public class LineChart extends BuiltinFunction {

    private Map defaultOptions;


    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "LineChart");

        defaultOptions = new HashMap();
        defaultOptions.put("title", null);
        defaultOptions.put("xAxisLabel", null);
        defaultOptions.put("yAxisLabel", null);
        defaultOptions.put("seriesTitle", "");
        defaultOptions.put("orientation", PlotOrientation.VERTICAL);
        defaultOptions.put("legend", true);
        defaultOptions.put("toolTips", true);
        defaultOptions.put("domainCrosshair", true);
        defaultOptions.put("rangeCrosshair", true);

    }//end method.

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer argumentsPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        LispError.check(aEnvironment, aStackTop, Utility.isSublist(argumentsPointer), LispError.INVALID_ARGUMENT, "LineChart");

        argumentsPointer.goSub(aStackTop, aEnvironment); //Go to sub list.

        argumentsPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        LispError.check(aEnvironment, aStackTop, Utility.isList(argumentsPointer), LispError.NOT_A_LIST, "LineChart");

        ConsPointer dataListPointer = (ConsPointer) argumentsPointer.car(); //Grab the first member of the list.

        ConsPointer optionsPointer = (ConsPointer) argumentsPointer.cdr();

        Map userOptions = ChartUtility.optionsListToJavaMap(aEnvironment, aStackTop, optionsPointer, defaultOptions);

        IntervalXYDataset dataSet = ChartUtility.listToIntervalXYDataset(aEnvironment, aStackTop, dataListPointer, userOptions);


        JFreeChart chart = ChartFactory.createXYLineChart(
                (String) userOptions.get("title"), //title.
                (String) userOptions.get("xAxisLabel"), //x axis label.
                (String) userOptions.get("yAxisLabel"), //y axis label.
                dataSet, //
                (PlotOrientation) userOptions.get("orientation"), //orientation.
                ((Boolean) userOptions.get("legend")).booleanValue(), //legend.
                ((Boolean) userOptions.get("toolTips")).booleanValue(),//tool tips.
                false);//urls.

        XYPlot plot = (XYPlot) chart.getPlot();
        plot.setDomainCrosshairVisible(((Boolean) userOptions.get("domainCrosshair")).booleanValue());
        plot.setDomainCrosshairLockedOnData(true);
        plot.setRangeCrosshairVisible(((Boolean) userOptions.get("rangeCrosshair")).booleanValue());
        plot.setRangeCrosshairLockedOnData(true);
        plot.setDomainZeroBaselineVisible(true);
        plot.setRangeZeroBaselineVisible(true);
        plot.setDomainPannable(true);
        plot.setRangePannable(true);
        NumberAxis domainAxis = (NumberAxis) plot.getDomainAxis();
        domainAxis.setAutoRangeIncludesZero(false);


        //Create and display a frame...  Import("org/mathpiper/builtin/functions/plugins/jfreechart/")
        //ChartFrame frame = new ChartFrame(null, chart);frame.pack();frame.setVisible(true);


        if (chart == null) {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(new ChartPanel(chart))));
            return;
        }//end if/else.


    }//end method.
    
}//end class.






/*
%mathpiper_docs,name="LineChart",categories="User Functions;Visualization"
*CMD LineChart --- displays a graphic line chart
*CORE
*CALL
	LineChart({domain_list, range_list}, option, option, option...)
    LineChart({domain_list_1, range_list_1, domain_list_2, range_list_2,...}, option, option, option...)

*PARMS

{domain_list} -- a list which contains the domain values

{range_list} -- a list which contains the range values that go with the domain_list values

{title} -- the title of the line chart

{xAxisLabel} -- the label for the x axis

{yAxisLabel} -- the label for the y axis

{seriesTitle} -- the title for a single data series

{seriesTitle} -- the title for more than one series.  can be 1, 2, 3, etc.

*DESC

Creates either a single line chart or multiple line charts on the same plot. Options are entered using the -> operator.
For example, here is how to set the {title} option: {title -> "Example Title"}.

*E.G.
/%mathpiper,title=""

claim := 1 .. 40;
days := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
LineChart({claim, days}, title -> "Line Chart", series1Title -> "Series 1", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


/%mathpiper,title=""

claim := 1 .. 40;
days1 := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
days2 := RandomIntegerVector(Length(claim), 20, 50);
LineChart({claim, days1, claim, days2}, title -> "Line Chart", series1Title -> "Series 1", series2Title -> "Series 2", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


%/mathpiper_docs
*/
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/BarChart.java0000644000175000017500000001611411334223061033314 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;


import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartFrame;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.chart.renderer.xy.XYBarRenderer;
import org.jfree.data.xy.IntervalXYDataset;
import org.mathpiper.lisp.cons.BuiltinObjectCons;


public class BarChart extends BuiltinFunction {

    private Map defaultOptions;


    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "BarChart");

        defaultOptions = new HashMap();
        defaultOptions.put("title", null);
        defaultOptions.put("xAxisLabel", null);
        defaultOptions.put("yAxisLabel", null);
        defaultOptions.put("seriesTitle", "");
        defaultOptions.put("orientation", PlotOrientation.VERTICAL);
        defaultOptions.put("legend", true);
        defaultOptions.put("toolTips", true);
        defaultOptions.put("domainCrosshair", true);
        defaultOptions.put("rangeCrosshair", true);

    }//end method.

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);

    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer argumentsPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        LispError.check(aEnvironment, aStackTop, Utility.isSublist(argumentsPointer), LispError.INVALID_ARGUMENT, "BarChart");

        argumentsPointer.goSub(aStackTop, aEnvironment); //Go to sub list.

        argumentsPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        LispError.check(aEnvironment, aStackTop, Utility.isList(argumentsPointer), LispError.NOT_A_LIST, "BarChart");

        ConsPointer dataListPointer = (ConsPointer) argumentsPointer.car(); //Grab the first member of the list.

        ConsPointer optionsPointer = (ConsPointer) argumentsPointer.cdr();

        Map userOptions = ChartUtility.optionsListToJavaMap(aEnvironment, aStackTop, optionsPointer, defaultOptions);

        IntervalXYDataset dataSet = ChartUtility.listToIntervalXYDataset(aEnvironment, aStackTop, dataListPointer, userOptions);


        JFreeChart chart = ChartFactory.createXYBarChart(
                (String) userOptions.get("title"), //title.
                (String) userOptions.get("xAxisLabel"), //x axis label.
                false,
                (String) userOptions.get("yAxisLabel"), //y axis label.
                dataSet, //
                (PlotOrientation) userOptions.get("orientation"), //orientation.
                ((Boolean) userOptions.get("legend")).booleanValue(), //legend.
                ((Boolean) userOptions.get("toolTips")).booleanValue(),//tool tips.
                false);//urls.

        XYPlot plot = (XYPlot) chart.getPlot();
        plot.setDomainCrosshairVisible(((Boolean) userOptions.get("domainCrosshair")).booleanValue());
        plot.setDomainCrosshairLockedOnData(true);
        plot.setRangeCrosshairVisible(((Boolean) userOptions.get("rangeCrosshair")).booleanValue());
        plot.setRangeCrosshairLockedOnData(true);
        plot.setDomainZeroBaselineVisible(true);
        plot.setRangeZeroBaselineVisible(true);
        plot.setDomainPannable(true);
        plot.setRangePannable(true);
        NumberAxis domainAxis = (NumberAxis) plot.getDomainAxis();
        domainAxis.setAutoRangeIncludesZero(false);

        XYBarRenderer renderer = (XYBarRenderer) plot.getRenderer();
        renderer.setMargin(0.10);

        // create and display a frame...  Import("org/mathpiper/builtin/functions/plugins/jfreechart/")
        // ChartFrame frame = new ChartFrame(null, chart);frame.pack();frame.setVisible(true);


        if (chart == null) {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(new ChartPanel(chart))));
            return;
        }//end if/else.


    }//end method.
    
}//end class.







/*
%mathpiper_docs,name="BarChart",categories="User Functions;Visualization"
*CMD BarChart --- displays a graphic bar chart
*CORE
*CALL
	BarChart({x_axis_list, y_axis_list}, option, option, option...)
    BarChart({x_axis_list_1, y_axis_list_1, x_axis_list_2, y_axis_list_2,...}, option, option, option...)

*PARMS

{x_axis_list} -- a list which contains the x axis values

{y_axis_list} -- a list which contains the y axis values that go with the x axis values

{title} -- the title of the scatter plot

{xAxisLabel} -- the label for the x axis

{yAxisLabel} -- the label for the y axis

{seriesTitle} -- the title for a single data series

{seriesTitle} -- the title for more than one series.  can be 1, 2, 3, etc.

*DESC

Creates either a single bar chart or multiple bar charts on the same plot. Options are entered using the -> operator.
For example, here is how to set the {title} option: {title -> "Example Title"}.

*E.G.
/%mathpiper,title=""

claim := 1 .. 40;
days := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
BarChart({claim, days}, title -> "Bar Chart", series1Title -> "Series 1", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


/%mathpiper,title=""

claim := 1 .. 40;
days1 := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
days2 := RandomIntegerVector(Length(claim), 20, 50);
BarChart({claim, days1, claim, days2}, title -> "Bar Chart", series1Title -> "Series 1", series2Title -> "Series 2", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


%/mathpiper_docs
*/

././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/ScatterPlot.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/ScatterPlot.jav0000644000175000017500000001563211334223061033735 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;

import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartFrame;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.data.xy.XYDataset;
import org.mathpiper.lisp.cons.BuiltinObjectCons;


public class ScatterPlot extends BuiltinFunction {

    private Map defaultOptions;

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "ScatterPlot");

        defaultOptions = new HashMap();
        defaultOptions.put("title", null);
        defaultOptions.put("xAxisLabel", null);
        defaultOptions.put("yAxisLabel", null);
        defaultOptions.put("seriesTitle", "");
        defaultOptions.put("orientation", PlotOrientation.VERTICAL);
        defaultOptions.put("legend", true);
        defaultOptions.put("toolTips", true);
        defaultOptions.put("domainCrosshair", true);
        defaultOptions.put("rangeCrosshair", true);

    }//end method.

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer argumentsPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        LispError.check(aEnvironment, aStackTop, Utility.isSublist(argumentsPointer), LispError.INVALID_ARGUMENT, "ScatterPlot");

        argumentsPointer.goSub(aStackTop, aEnvironment); //Go to sub list.

        argumentsPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        LispError.check(aEnvironment, aStackTop, Utility.isList(argumentsPointer), LispError.NOT_A_LIST, "ScatterPlot");

        ConsPointer dataListPointer = (ConsPointer) argumentsPointer.car(); //Grab the first member of the list.

        ConsPointer optionsPointer = (ConsPointer) argumentsPointer.cdr();

        Map userOptions = ChartUtility.optionsListToJavaMap(aEnvironment, aStackTop, optionsPointer, defaultOptions);

        XYDataset dataSet = ChartUtility.listToXYDataset(aEnvironment, aStackTop, dataListPointer, userOptions);

        JFreeChart chart = ChartFactory.createScatterPlot(
                (String) userOptions.get("title"), //title.
                (String) userOptions.get("xAxisLabel"), //x axis label.
                (String) userOptions.get("yAxisLabel"), //y axis label.
                dataSet, //
                (PlotOrientation) userOptions.get("orientation"), //orientation.
                ((Boolean) userOptions.get("legend")).booleanValue(), //legend.
                ((Boolean) userOptions.get("toolTips")).booleanValue(),//tool tips.
                false);//urls.

        XYPlot plot = (XYPlot) chart.getPlot();
        plot.setDomainCrosshairVisible(((Boolean) userOptions.get("domainCrosshair")).booleanValue());
        plot.setDomainCrosshairLockedOnData(true);
        plot.setRangeCrosshairVisible(((Boolean) userOptions.get("rangeCrosshair")).booleanValue());
        plot.setRangeCrosshairLockedOnData(true);
        plot.setDomainZeroBaselineVisible(true);
        plot.setRangeZeroBaselineVisible(true);
        plot.setDomainPannable(true);
        plot.setRangePannable(true);
        NumberAxis domainAxis = (NumberAxis) plot.getDomainAxis();
        domainAxis.setAutoRangeIncludesZero(false);

// create and display a frame...  Import("org/mathpiper/builtin/functions/plugins/jfreechart/")
//ChartFrame frame = new ChartFrame(null, chart);frame.pack();frame.setVisible(true);


        if (chart == null) {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(new ChartPanel(chart))));
            return;
        }//end if/else.


    }//end method.
    
}//end class.





/*
%mathpiper_docs,name="ScatterPlot",categories="User Functions;Visualization"
*CMD ScatterPlot --- displays a graphic scatter plot
*CORE
*CALL
	ScatterPlot({domain_list, range_list}, option, option, option...)
    ScatterPlot({domain_list_1, range_list_1, domain_list_2, range_list_2,...}, option, option, option...)

*PARMS

{domain_list} -- a list which contains the domain values

{range_list} -- a list which contains the range values that go with the domain_list values

{title} -- the title of the scatter plot

{xAxisLabel} -- the label for the x axis

{yAxisLabel} -- the label for the y axis

{seriesTitle} -- the title for a single data series

{seriesTitle} -- the title for more than one series.  can be 1, 2, 3, etc.

*DESC

Creates either a single scatter plot or multiple scatter plots on the same plot. Options are entered using the -> operator.
For example, here is how to set the {title} option: {title -> "Example Title"}.

*E.G.
/%mathpiper,title=""

claim := 1 .. 40;
days := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
ScatterPlot({claim, days}, title -> "Scatter Plot", series1Title -> "Series 1", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


/%mathpiper,title=""

claim := 1 .. 40;
days1 := {48,41,35,36,37,26,36,46,35,47,35,34,36,42,43,36,56,32,46,30,37,43,17,26,28,27,45,33,22,27,16,22,33,30,24,23,22,30,31,17};
days2 := RandomIntegerVector(Length(claim), 20, 50);
ScatterPlot({claim, days1, claim, days2}, title -> "Scatter Plot", series1Title -> "Series 1", series2Title -> "Series 2", xAxisLabel -> "Claim", yAxisLabel -> "Days");

/%/mathpiper


%/mathpiper_docs
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/functions/plugins/jfreechart/Histogram.java0000644000175000017500000001672611334223061033574 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin.functions.plugins.jfreechart;

import java.util.HashMap;
import java.util.Map;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;


import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartFrame;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.chart.renderer.xy.StandardXYBarPainter;
import org.jfree.chart.renderer.xy.XYBarRenderer;
import org.jfree.data.statistics.HistogramDataset;
import org.mathpiper.lisp.cons.BuiltinObjectCons;

/**
 *
 *
 */
public class Histogram extends BuiltinFunction {

    private Map defaultOptions;

    public void plugIn(Environment aEnvironment)  throws Exception
    {
        aEnvironment.getBuiltinFunctions().setAssociation(
                new BuiltinFunctionEvaluator(this, 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                "Histogram");

        defaultOptions = new HashMap();
        defaultOptions.put("title", null);
        defaultOptions.put("xAxisLabel", null);
        defaultOptions.put("yAxisLabel", null);
        defaultOptions.put("seriesTitle", "");
        defaultOptions.put("orientation", PlotOrientation.VERTICAL);
        defaultOptions.put("legend", true);
        defaultOptions.put("toolTips", true);
        defaultOptions.put("binMinumum", null);
        defaultOptions.put("binMaximum", null);
        defaultOptions.put("numberOfBins", null);

    }//end method.

    //private StandardFileOutputStream out = new StandardFileOutputStream(System.out);
    public void evaluate(Environment aEnvironment, int aStackTop) throws Exception {

        ConsPointer argumentsPointer = getArgumentPointer(aEnvironment, aStackTop, 1);

        LispError.check(aEnvironment, aStackTop, Utility.isSublist(argumentsPointer), LispError.INVALID_ARGUMENT, "Histogram");

        argumentsPointer.goSub(aStackTop, aEnvironment); //Go to sub list.

        argumentsPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        LispError.check(aEnvironment, aStackTop, Utility.isList(argumentsPointer), LispError.NOT_A_LIST, "Histogram");

        ConsPointer dataListPointer = (ConsPointer) argumentsPointer.car(); //Grab the first member of the list.

        ConsPointer optionsPointer = (ConsPointer) argumentsPointer.cdr();

        Map userOptions = ChartUtility.optionsListToJavaMap(aEnvironment, aStackTop, optionsPointer, defaultOptions);



        HistogramDataset dataSet = ChartUtility.listToHistogramDataset(aEnvironment, aStackTop, dataListPointer, userOptions);

        JFreeChart chart = ChartFactory.createHistogram(
                (String) userOptions.get("title"), //title.
                (String) userOptions.get("xAxisLabel"), //x axis label.
                (String) userOptions.get("yAxisLabel"), //y axis label.
                dataSet, //
                (PlotOrientation) userOptions.get("orientation"), //orientation.
                ((Boolean) userOptions.get("legend")).booleanValue(), //legend.
                ((Boolean) userOptions.get("toolTips")).booleanValue(),//tool tips.
                false);//urls.

        XYPlot plot = (XYPlot) chart.getPlot();
        plot.setDomainPannable(true);
        plot.setRangePannable(true);
        plot.setForegroundAlpha(0.85f);
        NumberAxis yAxis = (NumberAxis) plot.getRangeAxis();
        yAxis.setStandardTickUnits(NumberAxis.createIntegerTickUnits());
        XYBarRenderer renderer = (XYBarRenderer) plot.getRenderer();
        renderer.setDrawBarOutline(true);
        renderer.setBarPainter(new StandardXYBarPainter());
        renderer.setShadowVisible(false);

//create and display a frame...  Import("org/mathpiper/builtin/functions/plugins/jfreechart/")
//ChartFrame frame = new ChartFrame(null, chart);frame.pack();frame.setVisible(true);


        if (chart == null) {
            Utility.putFalseInPointer(aEnvironment, getTopOfStackPointer(aEnvironment, aStackTop));
            return;
        } else {
            getTopOfStackPointer(aEnvironment, aStackTop).setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(new ChartPanel(chart))));
            return;
        }//end if/else.


    }//end method.
    
}//end class.





/*
%mathpiper_docs,name="Histogram",categories="User Functions;Visualization"
*CMD Histogram --- displays a graphic histogram
*CORE
*CALL
	Histogram(list, option, option, option...)
    Histogram({list1, list2, list3...}, option, option, option...)

*PARMS

{list} -- a list which contains the values

{list1, list2, list3...} -- the data for multiple histograms is passed in as a list of lists

{binMinimum} -- the minimum bin value

{binMaximum} -- the maximum bin value

{numberOfBins} -- the number of bins in the histogram

{title} -- the title of the histogram

{xAxisLabel} -- the label for the x axis

{yAxisLabel} -- the label for the y axis

{seriesTitle} -- the title for a single data series

{seriesTitle} -- the title for more than one series.  can be 1, 2, 3, etc.

*DESC

Creates either a single histogram or multiple histograms on the same plot. Options are entered using the -> operator.
For example, here is how to set the {title} option: {title -> "Example Title"}.

*E.G.
/%mathpiper

Histogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0});

/%/mathpiper


/%mathpiper

Histogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0, 4.2}, seriesTitle -> "Options Example", xAxisLabel -> "X Axis", yAxisLabel -> "Y Axis");

/%/mathpiper


/%mathpiper

Histogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0, 4.2}, orientation -> "horizontal");

/%/mathpiper


/%mathpiper,title=""

pileESamples := {16.375,16.375,17.125,16,14.375,17.25,16.625,16,17,17.25,17,15.875,16.625,16.125,17.125,16.875,16.375,16.375,16.875,17.125,17,16.75,17.25,17.125,15.375};
pileDSamples := {18.25,19.25,18.25,15.625,17.625,17.5,17.125,17.125,17.5,14.5,17.375,16.875,17.75,18.875,14.875,19.25,18.125,16.25,16.125,16.75,17.25,17.375,17.125,17.5,16.625};

Histogram({pileDSamples, pileESamples}, title -> "Wood Piles", series1Title -> "Pile D", series2Title -> "Pile E");

/%/mathpiper


/%mathpiper,title=""

numberOfRoles := 1000;

dieRolesList := RandomIntegerVector(numberOfRoles,1,6);

Histogram(dieRolesList, binMinimum -> .5, binMaximum -> 6.5, numberOfBins -> 6, title -> "Single Die Rolls", xAxisLabel -> "Number Rolled", yAxisLabel -> "Frequency", seriesTitle -> String(numberOfRoles) : " Roles");

/%/mathpiper


%/mathpiper_docs
*/

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/PatternContainer.java0000644000175000017500000000455411420662456027320 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

//import org.mathpiper.parametermatchers.PatternContainer;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher;

/**
 * Allows a org.mathpiper.parametermatchers.ParametersPatternMatcher to be placed into a org.mathpiper.lisp.BuiltinObject.
 * 
 */
public class PatternContainer extends BuiltinContainer {

    protected ParametersPatternMatcher iPatternMatcher;


    public PatternContainer(org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher aPatternMatcher) {
        iPatternMatcher = aPatternMatcher;
    }


    public ParametersPatternMatcher getPattern() {
        return iPatternMatcher;
    }


    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aArguments) throws Exception {
        LispError.lispAssert(iPatternMatcher != null, aEnvironment, aStackTop);
        boolean result;
        result = iPatternMatcher.matches(aEnvironment, aStackTop, aArguments);
        return result;
    }


    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception {
        LispError.lispAssert(iPatternMatcher != null, aEnvironment, aStackTop);
        boolean result;
        result = iPatternMatcher.matches(aEnvironment, aStackTop, aArguments);
        return result;
    }

    //From BuiltinContainer

    public String typeName() {
        return "\"Pattern\"";
    }


    public Object getObject() {
        return this;
    }

}


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/Array.java0000644000175000017500000000350411417142425025103 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin;

import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointerArray;


public class Array extends BuiltinContainer
{
	ConsPointerArray iArray;

	public Array(Environment aEnvironment, int aSize,Cons aInitialItem)
	{
		iArray = new ConsPointerArray(aEnvironment, aSize,aInitialItem);
	}

	public String typeName()
	{
		return "\"Array\"";
	}

	public int size()
	{
		return iArray.size();
	}
	public Cons getElement(int aItem, int aStackTop, Environment aEnvironment) throws Exception
	{
		LispError.lispAssert(aItem>0 && aItem<=iArray.size(), aEnvironment, aStackTop);
		return iArray.getElement(aItem-1).getCons();
	}
	public void setElement(int aItem,Cons aObject, int aStackTop, Environment aEnvironment) throws Exception
	{
		LispError.lispAssert(aItem>0 && aItem<=iArray.size(), aEnvironment, aStackTop);
		iArray.setElement(aItem-1,aObject);
	}

    public Object getObject()
    {
        return this;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/BuiltinFunctionEvaluator.java0000644000175000017500000002561111417413030031020 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

// new-style evaluator, passing arguments onto the stack in Environment
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.builtin.BuiltinFunction;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.SublistCons;

public class BuiltinFunctionEvaluator extends Evaluator {
    // FunctionFlags can be ORed when passed to the constructor of this function

    public static int Function = 0;    // Function: evaluate arguments. todo:tk:not used.
    public static int Macro = 1;       // Function: don't evaluate arguments
    public static int Fixed = 0;     // fixed number of arguments. todo:tk:not used.
    public static int Variable = 2;  // variable number of arguments
    BuiltinFunction iCalledBuiltinFunction;
    int iNumberOfArguments;
    int iFlags;
    boolean showFlag = false;

    public BuiltinFunctionEvaluator(BuiltinFunction aCalledBuiltinFunction, int aNumberOfArguments, int aFlags) {
        iCalledBuiltinFunction = aCalledBuiltinFunction;
        iNumberOfArguments = aNumberOfArguments;
        iFlags = aFlags;
    }

    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResultPointer, ConsPointer aArgumentsPointer) throws Exception {
        ConsPointer[] argumentsResultPointerArray = null;
        /*Trace code*/
        if (isTraced()) {
            ConsPointer argumentsPointer = new ConsPointer();
            argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));

            String functionName = "";
            if (argumentsPointer.car() instanceof ConsPointer) {
                ConsPointer sub = (ConsPointer) argumentsPointer.car();
                if (sub.car() instanceof String) {
                    functionName = (String) sub.car();
                }
            }//end function.
            if (Evaluator.isTraceFunction(functionName)) {
                showFlag = true;
                Evaluator.traceShowEnter(aEnvironment, argumentsPointer, "builtin");
            } else {
                showFlag = false;
            }//end else.
            argumentsPointer.setCons(null);

            //Creat an array which holds pointers to each argument.  This will be used for printing the arguments.
            if (iNumberOfArguments == 0) {
                argumentsResultPointerArray = null;
            } else {
                LispError.lispAssert(iNumberOfArguments > 0, aEnvironment, aStackTop);
                argumentsResultPointerArray = new ConsPointer[iNumberOfArguments];
            }//end if.
        }//end if.



        if ((iFlags & Variable) == 0) { //This function has a fixed number of arguments.

            //1 is being added to the number of arguments to take into account
            // the function name that is at the beginning of the argument list.
            ConsPointer argumentsPointer = new ConsPointer();

            argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));

            String functionName = "";
            
            if (argumentsPointer.car() instanceof ConsPointer) {
                ConsPointer sub = (ConsPointer) argumentsPointer.car();
                if (sub.car() instanceof String) {
                    functionName = (String) sub.car();
                }
            }//end function.
            LispError.checkNumberOfArguments(aStackTop, iNumberOfArguments + 1, aArgumentsPointer, aEnvironment, functionName);
        }

        int stackTop = aEnvironment.iArgumentStack.getStackTopIndex();

        // Push a place holder for the result and initialize it to the function name for error reporting purposes.
        aEnvironment.iArgumentStack.pushArgumentOnStack(aArgumentsPointer.getCons(), aStackTop, aEnvironment);

        ConsPointer argumentsConsTraverser = new ConsPointer( aArgumentsPointer.getCons());

        //Strip the function name from the head of the list.
        argumentsConsTraverser.goNext(aStackTop, aEnvironment);

        int i;
        int numberOfArguments = iNumberOfArguments;

        if ((iFlags & Variable) != 0) {//This function has a  variable number of arguments.
            numberOfArguments--;
        }//end if.

        ConsPointer argumentResultPointer = new ConsPointer();

        // Walk over all arguments, evaluating them only if this is a function. *****************************************************

        if ((iFlags & Macro) != 0) {//This is a macro, not a function.

            for (i = 0; i < numberOfArguments; i++) {
                //Push all arguments on the stack.
                LispError.check(aEnvironment, aStackTop, argumentsConsTraverser.getCons() != null, LispError.WRONG_NUMBER_OF_ARGUMENTS, "INTERNAL");

                if (isTraced() && argumentsResultPointerArray != null && showFlag) {
                    argumentsResultPointerArray[i] = new ConsPointer();
                    argumentsResultPointerArray[i].setCons(argumentsConsTraverser.getCons().copy(aEnvironment, false));
                }

                aEnvironment.iArgumentStack.pushArgumentOnStack(argumentsConsTraverser.getCons().copy(aEnvironment, false), aStackTop, aEnvironment);
                argumentsConsTraverser.goNext(aStackTop, aEnvironment);
            }

            if ((iFlags & Variable) != 0) {//This macro has a variable number of arguments.
                ConsPointer head = new ConsPointer();
                head.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
                head.cdr().setCons(argumentsConsTraverser.getCons());
                aEnvironment.iArgumentStack.pushArgumentOnStack(SublistCons.getInstance(aEnvironment, head.getCons()), aStackTop, aEnvironment);
            }//end if.

        } else {//This is a function, not a macro.

            for (i = 0; i < numberOfArguments; i++) {
                LispError.check(aEnvironment, aStackTop, argumentsConsTraverser.getCons() != null, LispError.WRONG_NUMBER_OF_ARGUMENTS, "INTERNAL");
                LispError.check(aEnvironment, aStackTop, argumentsConsTraverser != null, LispError.WRONG_NUMBER_OF_ARGUMENTS, "INTERNAL");
                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, argumentResultPointer, argumentsConsTraverser);

                if (isTraced() && argumentsResultPointerArray != null && showFlag) {
                    argumentsResultPointerArray[i] = new ConsPointer();
                    argumentsResultPointerArray[i].setCons(argumentResultPointer.getCons().copy(aEnvironment, false));
                }

                aEnvironment.iArgumentStack.pushArgumentOnStack(argumentResultPointer.getCons(), aStackTop, aEnvironment);
                argumentsConsTraverser.goNext(aStackTop, aEnvironment);
            }//end for.

            if ((iFlags & Variable) != 0) {//This function has a variable number of arguments.

                //LispString res;

                //printf("Enter\n");

                ConsPointer head = new ConsPointer();
                head.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
                head.cdr().setCons(argumentsConsTraverser.getCons());
                ConsPointer listPointer = new ConsPointer();
                listPointer.setCons(SublistCons.getInstance(aEnvironment, head.getCons()));


                /*
                PrintExpression(res, list,aEnvironment,100);
                printf("before %s\n",res.String());
                 */

                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, argumentResultPointer, listPointer);

                /*
                PrintExpression(res, arg,aEnvironment,100);
                printf("after %s\n",res.String());
                 */

                aEnvironment.iArgumentStack.pushArgumentOnStack(argumentResultPointer.getCons(), aStackTop, aEnvironment);
                //printf("Leave\n");
                                    /*Trace code */

            }//end if.
        }//end else.


        /*Trace code */
        if (isTraced() && argumentsResultPointerArray != null && showFlag == true) {

            ConsPointer traceArgumentPointer = new ConsPointer( aArgumentsPointer.getCons());

            traceArgumentPointer.goNext(aStackTop, aEnvironment);

            int parameterIndex = 1;
            if ((iFlags & Variable) != 0) {//This function has a  variable number of arguments.

                while (traceArgumentPointer.getCons() != null) {
                    Evaluator.traceShowArg(aEnvironment, new ConsPointer( AtomCons.getInstance(aEnvironment, aStackTop, "parameter" + parameterIndex++)), traceArgumentPointer);
                    traceArgumentPointer.goNext(aStackTop, aEnvironment);
                }//end while.

            } else {
                for (i = 0; i < argumentsResultPointerArray.length; i++) {

                    /*      if (argumentsResultPointerArray[i] == null) {
                    argumentsResultPointerArray[i] = new ConsPointer(AtomCons.getInstance(aEnvironment, "NULL"));
                    }*/

                    Evaluator.traceShowArg(aEnvironment, new ConsPointer( AtomCons.getInstance(aEnvironment, aStackTop, "parameter" + parameterIndex++)), argumentsResultPointerArray[i]);

                    traceArgumentPointer.goNext(aStackTop, aEnvironment);
                }//end for.

            }

        }//end if.


        iCalledBuiltinFunction.evaluate(aEnvironment, stackTop); //********************** built in function is called here.


        aResultPointer.setCons(aEnvironment.iArgumentStack.getElement(stackTop, aStackTop, aEnvironment).getCons());

        if (isTraced() && showFlag == true) {
            ConsPointer argumentsPointer = new ConsPointer();
            argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
            String localVariables = aEnvironment.getLocalVariables(aStackTop);
            Evaluator.traceShowLeave(aEnvironment, aResultPointer, argumentsPointer, "builtin", localVariables);
            argumentsPointer.setCons(null);
        }//end if.

        aEnvironment.iArgumentStack.popTo(stackTop, aStackTop, aEnvironment);
    }
}


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/BigNumber.java0000644000175000017500000007305511346344604025713 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.LispError;
import java.math.*;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.NumberCons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 * 
 *
 */
public class BigNumber {

    BigInteger javaBigInteger = null;
    BigDecimal javaBigDecimal = null;
    int iPrecision;
    //int iTensExp;//TODO:tk:the purpose of this variable needs to be determined.
    private static BigDecimal zero = new BigDecimal("0");
    private static BigDecimal one = new BigDecimal("1");
    private static BigDecimal two = new BigDecimal("2");
    private static BigDecimal ten = new BigDecimal("10");


    public static boolean numericSupportForMantissa() {
        return true;
    }


    //constructors
    /**
     * Create a BigNumber with the specified precision and base.
     *
     * @param aString
     * @param aBasePrecision
     * @param aBase
     */
    public BigNumber( String aString, int aBasePrecision, int aBase/*=10*/) {


        setTo(aString, aBasePrecision, aBase);
    }

    /**
     * Create a copy of a BigNumber.
     *
     * @param aOther
     */
    public BigNumber(BigNumber aOther) {
        setTo(aOther);
    }


    // no constructors from int or double to avoid automatic conversions. TODO:tk:What does this mean?
    /**
     * Create a BigNumber with the given precision and initialize it to 0.
     * 
     * @param aPrecision
     */
    public BigNumber(int aPrecision/* = 20*/) {
        iPrecision = aPrecision;
        //iTensExp = 0;
        javaBigInteger = new BigInteger("0");
    }

    /**
     * Set this BigNumber to the same value as another BigNumber.
     *
     * @param aOther
     */
    public void setTo(BigNumber aOther) {
        iPrecision = aOther.getPrecision();
        //iTensExp = aOther.iTensExp;
        javaBigInteger = aOther.javaBigInteger;
        javaBigDecimal = aOther.javaBigDecimal;
    }

    /**
     * Set this BigNumber to a value specified in the given string using the given precision.
     *
     * @param aString
     * @param aPrecision
     * @param aBase
     */
    public void setTo(String aString, int aPrecision, int aBase/*=10*/) {
        javaBigInteger = null;
        javaBigDecimal = null;
        aString = aString.replace("+","");
        boolean isFloat = isFloat(aString, aBase);

        iPrecision = aPrecision;

        //iTensExp = 0;
        if (isFloat) {

            
            javaBigDecimal = new BigDecimal(aString, new MathContext(aPrecision));

            /*
            int decimalPos;
            decimalPos = aString.indexOf("e");
            if (decimalPos < 0) {
                decimalPos = aString.indexOf("E");
            }
            if (decimalPos > 0) // will never be zero
            {
                iTensExp = Integer.parseInt(aString.substring(decimalPos + 1, aString.length()));
                aString = aString.substring(0, decimalPos);
            }

            javaBigDecimal = new BigDecimal(aString); //TODO FIXME does not listen to aBase!!!
            if (javaBigDecimal.scale() > iPrecision) {
                iPrecision = javaBigDecimal.scale();
            }*/


        } else {
            javaBigInteger = new BigInteger(aString, aBase);
        }

    }

    /**
     * Set this BigNumber to the value of the specified Java long.
     *
     * @param javaLong
     */
    public void setTo(long javaLong) {
        setTo("" + javaLong, iPrecision, 10);
    }

    /**
     * Set this BigNumber to the value of the specified Java int.
     *
     * @param javaInt
     */
    public void setTo(int javaInt) {
        setTo((long) javaInt);
    }

    /**
     * Set this BigNumber to the value of the specified Java double.
     * 
     * @param javaDouble
     */
    public void setTo(double javaDouble) {
        setTo("" + javaDouble, iPrecision, 10);
    }

    /**
     * Is the specified string representing a floating point number?
     * 
     * @param aString
     * @param aBase
     * @return
     */
    boolean isFloat(String aString, int aBase) {
        if (aString.indexOf('.') >= 0) {
            return true;
        }
        if (aBase > 10) {
            return false;
        }
        if (aString.indexOf('e') >= 0) {
            return true;
        }
        if (aString.indexOf('E') >= 0) {
            return true;
        }
        return false;
    }

    // Convert back to other types.
    /**
     * Return a string representation of this BigNumber which has the specified precision and base.
     * @param aPrecision
     * @param aBase
     * @return
     */
    public String numToString(int aPrecision, int aBase/*=10*/) {
        if (javaBigInteger != null) {
            return javaBigInteger.toString(aBase);
        } else {
            String result = javaBigDecimal.toPlainString();
            result = result.replace("+", "");
            //System.out.println("BigNumResult: " + result);
            /*
            
            int extraExp = 0;
            // Parse out the exponent
            {
                int pos = result.indexOf("E");
                if (pos < 0) {
                    pos = result.indexOf("e");
                }
                if (pos > 0) {
                    extraExp = Integer.parseInt(result.substring(pos + 1));
                    result = result.substring(0, pos);
                }
            }


            int dotPos = result.indexOf('.');
            if (dotPos >= 0) {
                int endpos = result.length();
                while (endpos > dotPos && result.charAt(endpos - 1) == '0') {
                    endpos--;
                }
                if (endpos > 1) {
                    if (result.charAt(endpos - 1) == '.' && result.charAt(endpos - 2) >= '0' && result.charAt(endpos - 2) <= '9') {
                        endpos--;
                    }
                }
                result = result.substring(0, endpos);
                }//end if.
            
                if ((iTensExp + extraExp) != 0) {
                    result = result + "e" + (iTensExp + extraExp);
                }
		
		*/
            
            return result;
        }
    }//end method.

    /**
     * Return an approximate representation of this BigNumber as a Java double.
     *
     * @return
     */
    public double toDouble() {
        if (javaBigInteger != null) {
            return javaBigInteger.doubleValue();
        } else {
            return javaBigDecimal.doubleValue();
        }
    }

    /**
     * Return a representation of this BigNumber as a Java long.
     * @return
     */
    public long toLong() {
        if (javaBigInteger != null) {
            return javaBigInteger.longValue();
        } else {
            return javaBigDecimal.longValue();
        }
    }


    /**
     * Return a representation of this BigNumber as a Java int.
     * @return
     */
    public int toInt() {
        if (javaBigInteger != null) {
            return javaBigInteger.intValue();
        } else {
            return javaBigDecimal.intValue();
        }
    }



    /**
     * Determines if the specified BigNumber is equal in value to this one.
     *
     * @param aOther
     * @return
     */
    public boolean equals(BigNumber aOther) {
        if (javaBigInteger != null) {
            if (aOther.javaBigInteger == null) {
                //hier
                BigDecimal x = getDecimal(this);
                if (x.compareTo(aOther.javaBigDecimal) == 0) {
                    return true;
                }
                return false;
            }
            return (javaBigInteger.compareTo(aOther.javaBigInteger) == 0);
        }
        if (javaBigDecimal != null) {
            BigDecimal thisd = javaBigDecimal;
            BigDecimal otherd = aOther.javaBigDecimal;
            if (otherd == null) {
                otherd = getDecimal(aOther);
            }
           /* if (iTensExp > aOther.iTensExp) {
                thisd = thisd.movePointRight(iTensExp - aOther.iTensExp);
            } else if (iTensExp < aOther.iTensExp) {
                otherd = otherd.movePointRight(iTensExp - aOther.iTensExp);
            }*/
            return (thisd.compareTo(otherd) == 0);
        }
        return true;
    }//end method.

    /**
     * Determines if this BigNumber is an integer.
     *
     * @return
     */
    public boolean isInteger() {
        return (javaBigInteger != null && javaBigDecimal == null);
    }



    /**
     * Determines if this BigNumber is a decimal.
     *
     * @return
     */
    public boolean isDecimal() {
        return (javaBigDecimal != null && javaBigInteger == null);
    }



    /**
     * Determines if this BigNumber is less than 65535.  (Floating point not implemented yet).
     *
     * @return
     */
    public boolean isSmall() {
        if (isInteger()) {
            BigInteger i = javaBigInteger.abs();
            return (i.compareTo(new BigInteger("65535")) < 0); //TODO: Should this be 65536?
        } else // a function to test smallness of a float is not present in ANumber, need to code a workaround to determine whether a number fits into double.
        {
            //TODO fixme
            return true;
        /*
        LispInt tensExp = iNumber->iTensExp;
        if (tensExp<0)tensExp = -tensExp;
        return
        (
        iNumber->iPrecision <= 53  // standard float is 53 bits
        && tensExp<1021 // 306  // 1021 bits is about 306 decimals
        );
        // standard range of double precision is about 53 bits of mantissa and binary exponent of about 1021
         */
        }
    }

    /**
     * Convert this BigNumber to an integer.
     */
    public void becomeInteger() {
        if (javaBigDecimal != null) {
            javaBigInteger = javaBigDecimal.toBigInteger();
            javaBigDecimal = null;
        }
    }

    /**
     * Convert this BigNumber to a float which has the specified precision.
     * @param aPrecision
     */
    public void becomeFloat(int aPrecision/*=0*/) {
        if (javaBigInteger != null) {
            javaBigDecimal = new BigDecimal(javaBigInteger);
            //iTensExp = 0;
            javaBigInteger = null;
        }
    }

    /**
     * Determine if this BigNumber is less than the specified BigNumber.
     *
     * @param aOther
     * @return
     */
    public boolean lessThan(BigNumber aOther) {
        boolean floatResult = (javaBigDecimal != null || aOther.javaBigDecimal != null);
        if (floatResult) {
            BigDecimal dX = getDecimal(this);
            BigDecimal dY = getDecimal(aOther);
            return dX.compareTo(dY) < 0;
        } else {
            return javaBigInteger.compareTo(aOther.javaBigInteger) < 0;
        }
    }


    //arithmetic.
    /**
     * Multiply the specified BigNumbers using the specified precision and place the result in this BigNumber.
     *
     * @param aX
     * @param aY
     * @param aPrecision
     */
    public void multiply(BigNumber aX, BigNumber aY, int aPrecision) {
        boolean floatResult = (aX.javaBigDecimal != null || aY.javaBigDecimal != null);
        if (floatResult) {
            BigDecimal dX = getDecimal(aX);
            BigDecimal dY = getDecimal(aY);
            javaBigInteger = null;
            javaBigDecimal = dX.multiply(dY,new MathContext(aPrecision));
            //int newScale = iPrecision;
            //if (newScale < javaBigDecimal.scale()) {
            //    javaBigDecimal = javaBigDecimal.setScale(newScale, BigDecimal.ROUND_HALF_EVEN);
            //}
            //iTensExp = aX.iTensExp + aY.iTensExp;
        } else {
            javaBigDecimal = null;
            javaBigInteger = aX.javaBigInteger.multiply(aY.javaBigInteger);
        }
    }

    /**
     * Add the specified BigNumberss using the specified precision and place the result in this BigNumber.
     *
     * @param aX
     * @param aY
     * @param aPrecision
     */
    public void add(BigNumber aX, BigNumber aY, int aPrecision) {
        boolean floatResult = (aX.javaBigDecimal != null || aY.javaBigDecimal != null);
        if (floatResult) {
            BigDecimal dX = getDecimal(aX);
            BigDecimal dY = getDecimal(aY);

            javaBigInteger = null;
           /* if (aX.iTensExp > aY.iTensExp) {
                dY = dY.movePointLeft(aX.iTensExp - aY.iTensExp);
                iTensExp = aX.iTensExp;
            } else if (aX.iTensExp < aY.iTensExp) {
                dX = dX.movePointLeft(aY.iTensExp - aX.iTensExp);
                iTensExp = aY.iTensExp;
            }*/
            javaBigDecimal = dX.add(dY,new MathContext(aPrecision));
        } else {
            javaBigDecimal = null;
            javaBigInteger = aX.javaBigInteger.add(aY.javaBigInteger);
        }
    }

    /**
     * Negate the specified BigNumber and place the result in this BigNumber.
     * 
     * @param aX
     */
    public void negate(BigNumber aX) {
        if (aX.javaBigInteger != null) {
            javaBigDecimal = null;
            javaBigInteger = aX.javaBigInteger.negate();
        }
        if (aX.javaBigDecimal != null) {
            javaBigInteger = null;
            javaBigDecimal = aX.javaBigDecimal.negate();
            //iTensExp = aX.iTensExp;
        }
    }

    /**
     * Divide the specified BigNumbers using the specified precision and place the result in this Big.
     *
     * @param aX
     * @param aY
     * @param aPrecision
     */
    public void divide(BigNumber aX, BigNumber aY, int aPrecision) {
        //Note: if the two arguments are integers, this method should return an integer result!
        boolean floatResult = (aX.javaBigDecimal != null || aY.javaBigDecimal != null);
        if (floatResult) {
            BigDecimal dX = getDecimal(aX);
            BigDecimal dY = getDecimal(aY);
            javaBigInteger = null;

            javaBigDecimal = dX.divide(dY,new MathContext(aPrecision));

            /*int newScale = aPrecision + aY.getPrecision();
            if (newScale > dX.scale()) {
                dX = dX.setScale(newScale);
            }
            javaBigDecimal = dX.divide(dY, BigDecimal.ROUND_HALF_EVEN);
            iPrecision = javaBigDecimal.scale();*/
            //iTensExp = aX.iTensExp - aY.iTensExp;
        } else {
            javaBigDecimal = null;
            javaBigInteger = aX.javaBigInteger.divide(aY.javaBigInteger);
        }
    }

    /**
     * Perform y mod z on the two specified integers.  The result is placed into this BigNumber.
     * 
     * @param aY
     * @param aZ
     * @throws java.lang.Exception
     */
    public void mod(Environment aEnvironment,int aStackTop, BigNumber aY, BigNumber aZ) throws Exception {
        LispError.check(aEnvironment, aStackTop, aY.javaBigInteger != null, LispError.NOT_AN_INTEGER, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, aZ.javaBigInteger != null, LispError.NOT_AN_INTEGER, "INTERNAL");
        //TODO fixme    LispError.check(!IsZero(aZ),LispError.INVALID_ARGUMENT);
        javaBigInteger = aY.javaBigInteger.mod(aZ.javaBigInteger);
        javaBigDecimal = null;
    }

    /**
     * Print the internal state of this number.  Used for debugging purposes.
     *
     * @param aOutput
     * @throws java.lang.Exception
     */
    public void dumpNumber(Environment aEnvironment, int aStackTop, MathPiperOutputStream aOutput) throws Exception {
        if (javaBigInteger != null) {
            aOutput.write("BigInteger: " + javaBigInteger.toString() + "\n");
        } else {
            aOutput.write("BigDecimal: " + javaBigDecimal.toPlainString() + "   Precision: " + javaBigDecimal.precision()  + "   Unscaled Value: " + javaBigDecimal.unscaledValue() + "   Scale: " + javaBigDecimal.scale() + ".\n");
        }

    }//end method.


    public Cons dumpNumber(Environment aEnvironment, int aStackTop) throws Exception
    {
        Cons resultSublistCons = null;


        if(javaBigInteger != null)
        {
            //Create type association list.
            Cons typeListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons typeAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"type\"");

            Cons typeValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"BigInteger\"");

            typeListAtomCons.cdr().setCons(typeAtomCons);

            typeAtomCons.cdr().setCons(typeValueAtomCons);

            Cons typeSublistCons = SublistCons.getInstance(aEnvironment, typeListAtomCons);


            //Create value association list.
            Cons valueListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons valueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"value\"");

            Cons valueValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, javaBigInteger.toString());

            valueListAtomCons.cdr().setCons(valueAtomCons);

            valueAtomCons.cdr().setCons(valueValueAtomCons);

            Cons valueSublistCons = SublistCons.getInstance(aEnvironment, valueListAtomCons);


            //Create result list.
            typeSublistCons.cdr().setCons(valueSublistCons);

            Cons resultListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            resultListAtomCons.cdr().setCons(typeSublistCons);

            resultSublistCons = SublistCons.getInstance(aEnvironment, resultListAtomCons);
        }
        else
        {
            //Create type association list.
            Cons typeListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons typeAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"type\"");

            Cons typeValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"BigDecimal\"");

            typeListAtomCons.cdr().setCons(typeAtomCons);

            typeAtomCons.cdr().setCons(typeValueAtomCons);

            Cons typeSublistCons = SublistCons.getInstance(aEnvironment, typeListAtomCons);


            //Create value association list.
            Cons valueListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons valueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"value\"");

            Cons valueValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, javaBigDecimal.toPlainString());

            valueListAtomCons.cdr().setCons(valueAtomCons);

            valueAtomCons.cdr().setCons(valueValueAtomCons);

            Cons valueSublistCons = SublistCons.getInstance(aEnvironment, valueListAtomCons);


            //Create precision association list.
            Cons precisionListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons precisionAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"precision\"");

            Cons precisionValueAtomCons = new NumberCons(new BigNumber("" + javaBigDecimal.precision(), this.iPrecision, 10));

            precisionListAtomCons.cdr().setCons(precisionAtomCons);

            precisionAtomCons.cdr().setCons(precisionValueAtomCons);

            Cons precisionSublistCons = SublistCons.getInstance(aEnvironment, precisionListAtomCons);


            //Create unscaled value association list.
            Cons unscaledValueListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons unscaledValueAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"unscaledValue\"");

            Cons unscaledValueValueAtomCons = new NumberCons(new BigNumber("" + javaBigDecimal.unscaledValue(), this.iPrecision, 10));

            unscaledValueListAtomCons.cdr().setCons(unscaledValueAtomCons);

            unscaledValueAtomCons.cdr().setCons(unscaledValueValueAtomCons);

            Cons unscaledValueSublistCons = SublistCons.getInstance(aEnvironment, unscaledValueListAtomCons);


            //Create scale association list.
            Cons scaleListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            Cons scaleAtomCons = AtomCons.getInstance(aEnvironment, aStackTop, "\"scale\"");

            Cons scaleValueAtomCons = new NumberCons(new BigNumber("" + javaBigDecimal.scale(), this.iPrecision, 10));

            scaleListAtomCons.cdr().setCons(scaleAtomCons);

            scaleAtomCons.cdr().setCons(scaleValueAtomCons);

            Cons scaleSublistCons = SublistCons.getInstance(aEnvironment, scaleListAtomCons);


            //Create result list.
            typeSublistCons.cdr().setCons(valueSublistCons);

            valueSublistCons.cdr().setCons(precisionSublistCons);

            precisionSublistCons.cdr().setCons(unscaledValueSublistCons);

            unscaledValueSublistCons.cdr().setCons(scaleSublistCons);

            Cons resultListAtomCons = aEnvironment.iListAtom.copy(aEnvironment, false);

            resultListAtomCons.cdr().setCons(typeSublistCons);

            resultSublistCons = SublistCons.getInstance(aEnvironment, resultListAtomCons);

        }//end else.




        return resultSublistCons;
        
    }//end method.



    public String toString() {
        if (javaBigInteger != null) {
            return ("BigInteger: " + javaBigInteger.toString() + "   \n");
        } else {

            return ("BigDecimal: " + javaBigDecimal.toPlainString() + "   Precision: " + javaBigDecimal.precision()  + "   Unscaled Value: " + javaBigDecimal.unscaledValue() + "   Scale: " + javaBigDecimal.scale() + ".\n");
        }
    }




    /**
     * Perform a floor operation on the specified BigNumber, if possible, and place the result into this BigNumber.
     * @param aX
     */
    public void floor(BigNumber aX) {
        if (aX.javaBigDecimal != null) {
            BigDecimal d = aX.javaBigDecimal;

           /* if (aX.iTensExp != 0) {
                d = d.movePointRight(aX.iTensExp);
            }
            BigInteger rounded = d.toBigInteger();

            if (aX.javaBigDecimal.signum() < 0) {
                BigDecimal back = new BigDecimal(rounded);
                BigDecimal difference = aX.javaBigDecimal.subtract(back);
                if (difference.signum() != 0) {
                    rounded = rounded.add(new BigInteger("-1"));
                }

                // javaBigInteger = d.round(new MathContext(d.precision(),RoundingMode.FLOOR)).toBigInteger();TODO:tk:This code produces errors.

            }
            javaBigInteger = rounded;*/

           
            //int precision = d.precision();

            //int scale = d.scale();

            BigDecimal flooredDecimal = d.setScale(0, RoundingMode.FLOOR);

            //BigDecimal flooredDecimal = d.round(new MathContext(1,RoundingMode.FLOOR));

            javaBigInteger = flooredDecimal.toBigInteger();
            
        } else {
            javaBigInteger = aX.javaBigInteger;
        }
        javaBigDecimal = null;
    }

    /**
     * Set the precision of this BigNumber (in bits).
     *
     * @param aPrecision
     */
    public void setPrecision(int aPrecision) {
        iPrecision = aPrecision;
        if (javaBigDecimal != null) {
           // if (javaBigDecimal.scale() > aPrecision) {
           //     javaBigDecimal = javaBigDecimal.setScale(aPrecision, BigDecimal.ROUND_HALF_EVEN);
           // }
           if(javaBigDecimal.precision() > aPrecision)
           {
               javaBigDecimal = new BigDecimal(javaBigDecimal.toString(),new MathContext(aPrecision));
           }

        }
    }

    /// Bitwise operations.
    /**
     * Shift the specified BigNumber to the left the specified number of bits and place the result in this BigNumber.
     *
     * @param aX
     * @param aNrToShift
     * @throws java.lang.Exception
     */
    public void shiftLeft(BigNumber aX, int aNrToShift, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigDecimal = null;
        javaBigInteger = aX.javaBigInteger.shiftLeft(aNrToShift);
    }

    /**
     * Shift the specified BigNumber to the right the specified number of bits and place the result in this BigNumber.
     * @param aX
     * @param aNrToShift
     * @throws java.lang.Exception
     */
    public void shiftRight(BigNumber aX, int aNrToShift, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigDecimal = null;
        javaBigInteger = aX.javaBigInteger.shiftRight(aNrToShift);
    }

    /**
     * Perform a GCD operation on the specified BigNumbers and place the result in this BigNumber.
     *
     * @param aX
     * @param aY
     * @throws java.lang.Exception
     */
    public void gcd(BigNumber aX, BigNumber aY, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        LispError.lispAssert(aY.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigInteger = aX.javaBigInteger.gcd(aY.javaBigInteger);
        javaBigDecimal = null;
    }

    /**
     * Perform a bitwise AND operation on the specified BigNumbers and place the result in this BigNumber.
     *
     * @param aX
     * @param aY
     * @throws java.lang.Exception
     */
    public void bitAnd(BigNumber aX, BigNumber aY, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        LispError.lispAssert(aY.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigInteger = aX.javaBigInteger.and(aY.javaBigInteger);
        javaBigDecimal = null;
    }

    /**
     * Perform a bitwise OR operation on the specified BigNumbers and place the result in this BigNumber.
     * @param aX
     * @param aY
     * @throws java.lang.Exception
     */
    public void bitOr(BigNumber aX, BigNumber aY, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        LispError.lispAssert(aY.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigInteger = aX.javaBigInteger.or(aY.javaBigInteger);
        javaBigDecimal = null;
    }

    /**
     * Perform a bitwise XOR operation on the specified BigNumbers and place the result in this BigNumber.
     *
     * @param aX
     * @param aY
     * @throws java.lang.Exception
     */
    public void bitXor(BigNumber aX, BigNumber aY, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        LispError.lispAssert(aY.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigInteger = aX.javaBigInteger.xor(aY.javaBigInteger);
        javaBigDecimal = null;
    }

    /**
     * Perform a bitwise NOT operation on the specified BigNumber and place the result in this BigNumber.
     *
     * @param aX
     * @throws java.lang.Exception
     */
    void bitNot(BigNumber aX, Environment aEnvironment, int aStackTop) throws Exception {
        LispError.lispAssert(aX.javaBigInteger != null, aEnvironment, aStackTop);
        javaBigInteger = aX.javaBigInteger.not();
        javaBigDecimal = null;
    }

    /**
     * If this BigNumber is an integer, its number of significant bits is returned and if it is a decimal, its binary exponent is returned.  
     * The binary exponent is a shortcut for a binary logarithm.
     * 
     * @return
     */
    public long bitCount() {
        //TODO fixme check that it works as needed
        if (javaBigInteger != null) {
            return javaBigInteger.abs().bitLength();
        }

        {
            BigDecimal d = javaBigDecimal.abs();
            //if (iTensExp != 0) {
            //    d = d.movePointRight(iTensExp);
            //}
            if (d.compareTo(one) > 0) {
                return d.toBigInteger().bitLength();
            }
            BigDecimal integerPart = new BigDecimal(d.toBigInteger());
            integerPart = integerPart.negate();
            d = d.add(integerPart);
            if (d.compareTo(zero) == 0) {
                return 0;
            }
            int bitCount = 0;

            //TODO OPTIMIZE
            d = d.multiply(two);
            while (d.compareTo(one) < 0) {
                d = d.multiply(two);
                bitCount--;
            }
            return bitCount;
        }
    }

    /**
     * Returns the sign of this BigNumber.
     * 
     * @return -1, 0, or 1
     */
    public int sign() {
        if (javaBigInteger != null) {
            return javaBigInteger.signum();
        }
        if (javaBigDecimal != null) {
            return javaBigDecimal.signum();
        }

        return 0;
    }

    /**
     * Returns the precision of this BigNumber.
     *
     * @return
     */
    public int getPrecision() {
        return iPrecision;
    }

    /**
     * Return a decimal representation of this BigNumber.
     *
     * @param aNumber
     * @return
     */
    BigDecimal getDecimal(BigNumber aNumber) {
        if (aNumber.javaBigDecimal != null) {
            return aNumber.javaBigDecimal;
        }
        return new BigDecimal(aNumber.javaBigInteger, new MathContext(iPrecision));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/0000755000175000017500000000000011722677325026167 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/JavaField.java0000644000175000017500000001364611357267756030700 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;
import java.lang.reflect.*;
import java.util.Hashtable;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Utility;

/** 
 * Provides dynamic field access.

 If the field is static (or a Class is given) we cache the Field.
 Otherwise, we cache a class-> field map.
 * @author Peter Norvig, Copyright 1998, peter@norvig.com,     license
 * subsequently modified by Jscheme project members
 * licensed under zlib licence (see license.txt)
**/

public class JavaField extends Reflector {

  /** Maps field name -> Class -> Field **/
  static final Hashtable fieldTable     = new Hashtable(20);
  static final Hashtable fieldTablePriv = new Hashtable(20);
  
  static Hashtable fieldTable0(boolean isPrivileged) {
    if (isPrivileged) return fieldTablePriv;
    else return fieldTable;
  }

  /**
     Return the field named name in Class c.
     Priviledged fields are made accessible if the JVM allows it.
     
    Memoized.
  **/
  public static Field getField(Class c, String name, boolean isPrivileged) throws Exception {
    try{
      return isPrivileged
	? getDeclaredField(c, name)
	: c.getField(name);
    } catch(NoSuchFieldException e2) {
      return((Field)E.error("no such field: " + c+"."+name));
    } catch(Exception e) {
      return((Field)E.error
	     ("error accessing field: " + c+"."+name+ " is "+e));
    }
  }

  private static Hashtable getFieldClassTable
    (String name, boolean isPrivileged) {
    Hashtable ft = fieldTable0(isPrivileged);
    Hashtable table = ((Hashtable) ft.get(name));
    if (table == null) {
      table = new Hashtable(3);
      ft.put(name, table);
    }
    return table;
  }

  /** Wander over the declared fields, returning the first named
      name **/
   private static Field getDeclaredField (Class c, String name)
     throws NoSuchFieldException {
   try{
    Field[] fs = ((Field[]) Invoke.makeAccessible(c.getDeclaredFields()));
    for (int i = 0; i < fs.length; i++)
      if (fs[i].getName().equals(name)) return fs[i];
    Class s = c.getSuperclass();
    if (s != null) return getDeclaredField(s, name);
    else return ((Field) E.error
		 ("\n\nERROR: no field: \""+name+"\" for class \""+c+"\""));
   }catch(Exception e) {
       return c.getField(name);}
  }

  String className;
  transient Field f;
  boolean isStatic = false;
  /** Map Class -> Field **/
  transient Hashtable classTable;

  public JavaField(String name, Class c) throws Exception {
    this(name, c, false);
  }

  public JavaField(String name, Class c, boolean isPrivileged) throws Exception {
    this.name = name;
    this.isPrivileged=isPrivileged;
    if (c != null) this.className = c.getName();
    reset();
  }

  protected synchronized void reset() throws Exception {
    Class c = (className == null) ? null : Import.classNamed(className);
    if (c != null) {
      f = getField(c, name, isPrivileged);
      isStatic = Modifier.isStatic(f.getModifiers());
      minArgs = (isStatic) ? 0 : 1;
      maxArgs = (Modifier.isFinal(f.getModifiers())) ? minArgs : minArgs+1;
    } else {
      classTable = getFieldClassTable(name, isPrivileged);
      minArgs = 1;
      maxArgs = 2;
    }}


  /*
  public Object[] makeArgArray(Object[] code,
                               Evaluator eval,
                               LexicalEnvironment lexenv) {
    int L = code.length - 1;
    if (L == 0 && isStatic) return StaticReflector.args0;
    else if (L == 1)
      return new Object[] { eval.execute(code[1], lexenv) };
    else if (L == 2 && !isStatic)
      return new Object[] { eval.execute(code[1], lexenv),
			      eval.execute(code[2], lexenv) };
    else return ((Object[]) E.error("Wrong number of arguments to field " +
				    this + " " + U.stringify(code)));
  }*/


  /*
  public Object[] makeArgArray (ConsPointer args) throws Exception{
    int L = Utility.listLength(null, -1, args);//   args.length();
    if (L == 0 && isStatic) return StaticReflector.args0;
    else if (L == 1) return new Object[] { args.cdr() };
    else if (L == 2 && !isStatic)
      return new Object[] { args.cdr(), args.second() };
    else return ((Object[]) E.error("Wrong number of arguments to field " +
				    this + " " + U.stringify(args)));
  }*/

  public Object apply(Object[] args) throws Exception {
    int L = args.length;
    if (isStatic) {
      if (L == 1) return setStaticFieldValue(f, args[0]);
      else return getStaticFieldValue(f);
    } else {
      if (L == 1) return getFieldValue(args[0], getTargetField(args[0]));
      else return setFieldValue(args[0],
				getTargetField(args[0]),
				args[1]);
    }
  }

  public Field getTargetField(Object target) throws Exception {
    if (f != null) return f;
    Class c = target.getClass();
    Field it = ((Field) classTable.get(c));
    if (it != null) return it;
    it = getField(c, this.name, this.isPrivileged);
    if (it == null) return (Field) E.error(U.stringify(target) +
					   " does not have a field "
					   + this.name);
    classTable.put(c, it);
    return it;
  }

  public Object getFieldValue(Object target, Field f) throws Exception {
    try { return f.get(target); }
    catch (IllegalAccessException e) {
      return ((Object) E.error("Illegal Access to field: " + f + " in " +
			       U.stringify(target)));
    }}

  public Object setFieldValue(Object target, Field f, Object value) {
    try {
      Object old = f.get(target);
      f.set(target, value);
      return old;
    } catch (IllegalAccessException e) {
      return null;		// Sorry.
    }
  }

  public Object getStaticFieldValue(Field f) {
    try {
      return f.get(null);
    } catch(IllegalAccessException e) {
      return null;		//  Sorry.
    }
  }

  public Object setStaticFieldValue(Field f, Object value) {
    try {
      Object old = f.get(null);
      f.set(null, value);
      return old;
    } catch(IllegalAccessException e) {
      return null;		//  Sorry.
    }
  }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/JavaMethod.java0000644000175000017500000001151611357267756031067 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

import java.lang.reflect.Method;
import java.util.Hashtable;
import org.mathpiper.lisp.cons.ConsPointer;

/** This class allows you to call any Java method, just by naming it,
 * and doing the dispatch at runtime.
 * @author Peter Norvig, Copyright 1998, peter@norvig.com, license
 * subsequently modified by Jscheme project members
 * licensed under zlib licence (see license.txt)
**/

public class JavaMethod extends Reflector {

  public static final Object[] ZERO_ARGS = new Object[0];

  private String methodClass;
  /** Parameter/method table for a specific method. **/
  private transient Object[] methodTable;
  private boolean isStatic;
  /** Do we know the Class that this method applies to? **/
  private boolean isSpecific;
  /** Class -> methodTable map. **/
  private transient Hashtable classMethodTable;
  
  public boolean isStatic() { return this.isStatic;}
  
  /**

     If the method is static then Class c is not null.  For instance
     methods, if Class c is not null, then it is used at construction
     time to create a method table.  Otherwise, the class of the
     method is determined at call time from the target, and the method
     table is constructed then and cached. Examples (see DynamicVariable.java):

      
          new JavaMethod("getProperties", System.class, true) - static method
      new JavaMethod("put", Hashtable.class,false)        - specific instance method.
      new JavaMethod("put", null, false)                  - unspecified instance method
      
    
   **/

   public JavaMethod(String name, Class c, boolean isStatic, boolean isPrivileged) throws Exception {
    this.name = name;
    if (c != null) this.methodClass = c.getName();
    this.isStatic = isStatic;
    this.isSpecific = (c!=null);
    this.minArgs = isStatic ? 0 : 1;
    this.isPrivileged=isPrivileged;
    reset();
   }

    public JavaMethod(String name, Class c, boolean isStatic) throws Exception {
      this(name,c,isStatic,false);
    }

    public JavaMethod(String name, Class c) throws Exception {
      this(name,c,(c!=null));
    }      

  protected synchronized void reset() throws Exception {
    if (isSpecific) {
      methodTable = Invoke.methodTable0(Import.classNamed(methodClass),
					name,
					isStatic,
                                        isPrivileged);
      if (methodTable.length == 0) {
          methodTable = null;
          E.warn(  "No such "+ (isStatic?" static ":" instance ") + 
                    " method \"" + name + (isSpecific?("\" in class "+methodClass):""));
      }
    } else classMethodTable = new Hashtable(5);
  }

  public Object[] instanceMethodTable(Class c) throws Exception {
    Object[] ms = ((Object[]) classMethodTable.get(c));
    if (ms != null) return ms;
    ms = Invoke.methodTable0(c, name, isStatic, isPrivileged);
    if (ms != null && ms.length > 0) {
      classMethodTable.put(c, ms);
      return ms;
    } else return (Object[]) E.error(c + " has no methods for " + this.name);
  }

  /**
     For a static method, args is an Object[] of arguments.
     For an instance method, args is (vector target (vector arguments));
   **/
  public Object apply(Object[] args) throws Exception{
    if (!(isSpecific)) {
      Object[] methodTable = instanceMethodTable(args[0].getClass());
      Object[] as = (Object[]) args[1];
      Method m = (Method) Invoke.findMethod(methodTable, as);
      return Invoke.invokeRawMethod(m, args[0], as);
    } else {
      if (methodTable == null) return E.error(this + " has no methods");
      if (isStatic) {
	Method m = (Method) Invoke.findMethod(methodTable, args);
	return Invoke.invokeRawMethod(m, null, args);
      } else {
	Object[] as = (Object[]) args[1];
        Method m = (Method) Invoke.findMethod(methodTable, as);
        return Invoke.invokeRawMethod(m, args[0], as);
      }
    }
  }


  /*
  public Object[] makeArgArray(Object[] code,
                               Evaluator eval,
                               LexicalEnvironment lexenv) {
    if (isStatic) {
      int L = code.length - 1;
      if (L == 0) return ZERO_ARGS;
    
      Object[] args = new Object[L];
      for (int i = 0; i < L; i++)
	args[i] = eval.execute(code[i+1], lexenv);
      return args;
    } else {
      int L = code.length - 2;
      if (L < 0)
	return ((Object[])
		E.error("Wrong number of arguments in application: "
			+ U.stringify(code)));
      Object target = eval.execute(code[1], lexenv);
      if (L == 0) return new Object[] { target, ZERO_ARGS };
    
      Object[] args = new Object[L];
      for (int i = 0; i < L; i++)
	args[i] = eval.execute(code[i+2], lexenv);
      return new Object[] { target, args };
    }
  }
      
  public Object[] makeArgArray (ConsPointer args) {
    if (isStatic) return U.listToVector(args);
    else return new Object[] { args.first, U.listToVector(args.rest)} ;
  }

  */
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/Invoke.java0000644000175000017500000005016311357267756030301 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

/**  
 * @author Ken R. Anderson, Copyright 2000, kanderso@bbn.com, license
 * subsequently modified by Jscheme project members
 * licensed under zlib licence (see license.txt)
 */

//import java.lang.reflect.AccessibleObject;  // only  in JDK1.2 revision:
import java.lang.reflect.Constructor;
import java.lang.reflect.InvocationTargetException;
import java.lang.reflect.Method;
import java.lang.reflect.Member;
import java.lang.reflect.Modifier;
import java.util.Enumeration;
import java.util.Hashtable;
import java.util.Vector;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.lisp.cons.ConsPointer;

/** 
    Provides dynamic Java method invocation through Java's Reflection
    interface.  For a good discussion of a Scheme implementation, and
    the issues involved with dynamic method invocation in Java see:
   
   
     Michael Travers, Java Q & A, Dr. Dobb's Journal, Jan., 2000,
   p. 103-112.

   
    Primitive types are not widened because it would make method
   selection more ambiguous.  By memoizing constructorTable() and
   methodTable() dynamic method lookup can be done without consing.

   
    You'll notice that Java doesn't make this very easy.  For
   example it would be nice if Method and Constructor shared an
   Invokable interface.

   
    Privileged methods can be invoked if the JVM allows it.
   
   
    The name of a method to be invoked can be any nonnull Object
   with a .toString() that names a method.  It should probably be
   changed to String.
 **/

public class Invoke {

  /** Each bucket in an method table contains a Class[] of
      parameterTypes and the corresponding method or constructor. **/
  public static final int BUCKET_SIZE = 2;

  public static Object peek(Object target, String name) throws Exception {
    return peek0(target.getClass(), name, target);
  }
  
  public static Object peekStatic(Class c, String name) throws Exception {
    return peek0(c, name, c);
  }

  private static Object peek0(Class c, String name, Object target) throws Exception {
    try {
      return c.getField(name).get(target);
    } catch (NoSuchFieldException e) {
      return E.error(target + " has no field named " + name);
    } catch (IllegalAccessException e) {
      return E.error("Can't access the " + name + " field of " + target);
    }
  }

  public static Object poke(Object target, String name, Object value) throws Exception {
    return poke0(target.getClass(), name, target, value);
  }
  
  public static Object pokeStatic(Class c, String name, Object value) throws Exception {
    return poke0(c, name, c, value);
  }

  private static Object poke0(Class c, String name, Object target, 
			      Object value) throws Exception {
    try {
      c.getField(name).set(target, value);
      return value;
    } catch (NoSuchFieldException e) {
      return E.error(target + " has no field named " + name);
    } catch (IllegalAccessException e) {
      return E.error("Can't access the " + name + " field of " + target);
    }
  }

  public static Object invokeConstructor(String c, Object[] args) throws Exception{
    Object[] ms = constructorTable(c, false);
    return invokeRawConstructor (((Constructor) findMethod(ms, args)), args);
  }

  public static Object invokeRawConstructor(Constructor m, Object[] args) throws Exception{
    try {
      return m.newInstance(args);
    } catch (InvocationTargetException e) { 
	//throw new BacktraceException(e.getTargetException(),new Object[]{m,args});
        throw e; //todo:tk.
    } catch (InstantiationException e) {
      return E.error("Error during instantiation: ", U.list(e, m, args));
    } catch (IllegalAccessException e) { 
      return E.error("Bad constructor application:", U.list(e, m, args));
    }
  }

  public static Object invokeStatic(Class c, String name, Object[] args) throws Exception{
    return invokeMethod(c, c, name, args, true, false);
  }

  public static Object invokeInstance(Object target, String name,
				      Object[] args,boolean isPrivileged) throws Exception{
    return invokeMethod(target.getClass(), target, name, args, false,
			isPrivileged);
  }

  public static Object invokeMethod(Class c, Object target, String name,
				    Object[] args, boolean isStatic,
				    boolean isPrivileged) throws Exception{
    Object[] ms = methodTable(c, name, isStatic,isPrivileged);
    return invokeRawMethod((Method) findMethod(ms, args), target, args);
  }

  public static Object invokeRawMethod(Method m, Object target, Object[] args) throws Exception{
    try {
	  return m.invoke(target, args);
    } catch (InvocationTargetException e) {
	//throw new BacktraceException(e.getTargetException(),new Object[]{m,target,args});
        throw e; //todo:tk.
    } catch (IllegalAccessException e) { 
	return E.error("Bad method application from a private class: ", U.list(e, m, args));
    } catch (java.lang.IllegalArgumentException e) {
      if (args == null) return E.error(e + "\n " + m.toString() + "\n called with target: " + U.stringify(target) + " and a null argument vector.");
	else return E.error(e + "\nARGUMENT MISMATCH for method \n\n  "+m.toString() +"\n called with " + U.vectorToList(args));
    }
  }
  public static final Hashtable constructorCache = new Hashtable(50);
  public static final Hashtable constructorCachePriv = new Hashtable(50);

  /** Return the constructor table for the named class. **/
  public static Object[] constructorTable(String c, boolean isPrivileged) throws Exception {
    if (isPrivileged) return constructorTable0Priv(c);
    else return constructorTable0(c);
  }

  public static Object[] constructorTable0Priv(String c) throws Exception {
    Object[] result = ((Object[]) constructorCachePriv.get(c));
    if (result == null) {
	try{
	  result = methodArray(makeAccessible(Import.classNamed(c).
					      getDeclaredConstructors()));
        }catch(Exception e){
	    result = methodArray(Import.classNamed(c).getConstructors());}
      constructorCachePriv.put(c, result);
    }
    if (result.length == 0)
      return((Object[]) E.error("Constructor " + c +
				" has no methods."));
    else return result;
  }

  public static Object[] constructorTable0(String c) throws Exception {
    Object[] result = ((Object[]) constructorCache.get(c));
    if (result == null) {
      result = methodArray(Import.classNamed(c).getConstructors());
      constructorCache.put(c, result);
    }
    if (result.length == 0)
      return((Object[]) E.error("Constructor " + c +
				" has no methods."));
    else return result;
  }
  /** Static method name -> Class -> parameter[]/method array. **/
  public static final Hashtable staticCache = new Hashtable(50);
  /** Instance method name -> Class -> parameter[]/method array. **/
  public static final Hashtable instanceCache = new Hashtable(100);
  private static Hashtable getMethodCache(boolean isStatic) {
    return (isStatic) ? staticCache : instanceCache;
  }

  private static Hashtable getNameTable(Hashtable table, String name) {
    Hashtable nameTable = ((Hashtable) table.get(name));
    if (nameTable != null) return ((Hashtable) nameTable);
    else {
      nameTable = new Hashtable(10);
      table.put(name, nameTable);
      return ((Hashtable) nameTable);
    }
  }

  /** Returns a Class -> prameter[]/method array for the method named
   * name. **/
  public static Hashtable getClassTable (String name, boolean isStatic) {
    return getNameTable(getMethodCache(isStatic), name);
  }

  public static Object[] getCachedMethodTable
    (Class c, String name, boolean isStatic) {
    return ((Object[]) getNameTable(getMethodCache(isStatic), name) .get(c));
  }

  public static void putCachedMethodTable
    (Class c, String name, boolean isStatic, Object value) {
    getNameTable(getMethodCache(isStatic), name).put(c, value);
  }

  public static Object[] methodTable0
    (Class c, String name, boolean isStatic,boolean isPrivileged) {
    String internalName = isPrivileged?name.concat("#"):name;
    Object[] result1 = getCachedMethodTable(c, internalName, isStatic);
    if (result1 == null) {
      result1 = methodTableLookup(c, name, isStatic,isPrivileged);
      putCachedMethodTable(c, internalName, isStatic, result1);
    }
    return result1;
  }

  public static Object[] methodTable
    (Class c, String name, boolean isStatic,boolean isPrivileged) throws Exception {
    Object[] result1 = methodTable0(c, name, isStatic,isPrivileged);
    if (result1 == null || result1.length == 0)
	if (isStatic)
	    return ((Object[]) E.error ("ERROR: \nNO STATIC METHOD  OF TYPE  \n\n  ("+ c.getName()+"."+ name+ " ...)"));
        else
	    return ((Object[]) E.error("ERROR: \nNO INSTANCE METHOD OF TYPE \n\n  (."+ name+ " "+ c.getName() +" ...)"));
    else return result1;
  }

  public static Object[] methodTableLookup(Class c, String name,boolean isStatic,boolean isPrivileged) {
    if (isStatic) return methodTableLookupStatic(c, name,isPrivileged);
    else return methodTableLookupInstance(c, name, isPrivileged);
  }

  public static Object[] methodTableLookupStatic(Class c, String name, boolean isPrivileged) {
    Method[] ms = getMethods(c,isPrivileged);
    Vector result = new Vector(ms.length);
    for(int i = 0; i < ms.length; i++) {
      Method m = ms[i];
      if (Modifier.isStatic(m.getModifiers()) && m.getName().equals(name))
	result.addElement(m);
    }
    Object[] result1 = new Object[result.size()];
    result.copyInto(result1);
    return methodArray(result1);
  }

  public static Object[] methodTableLookupInstance(Class c, String name) {
      return methodTableLookupInstance(c, name,false);
  }

  public static Object[] methodTableLookupInstance(Class c, String name,
						   boolean isPrivileged) {
    Vector result = methodVector(c, name, isPrivileged);
    Object[] result1 = new Object[result.size()];
    result.copyInto(result1);
    return methodArray(result1);
    }

  public static Vector methodVector(Class c, String name) {
     return methodVector(c,name,false);
  }

  public static Vector methodVector(Class c, String name, boolean isPrivileged) {
    return methodVectorMerge(c, name, new Vector(10),isPrivileged);
  }

  /** Add new methods to your superclasses table. **/
  public static Vector methodVectorMerge(Class c, String name, Vector result) {
     return methodVectorMerge(c, name, result, false);
  }

  public static Vector methodVectorMerge(Class c, String name, Vector result,boolean isPrivileged) {
    Class s = c.getSuperclass();

    if (s != null) result = methodVectorMerge(s, name, result,isPrivileged);
    Class[] is = c.getInterfaces();
    for (int i = 0; i < is.length; i = i + 1) 
      result = methodVectorMerge(is[i], name, result,isPrivileged);

    Method[] ms = getMethods(c,isPrivileged);  
    for(int i = 0; i < ms.length; i++) {
      Method m = ms[i];
      if ((!Modifier.isStatic(m.getModifiers())) &&
          // KRA 25OCT04: Fixes problem with .append in JDK 1.5.0
	  ((isPrivileged ||
	    (Modifier.isPublic(m.getModifiers()) &&
	     Modifier.isPublic(m.getDeclaringClass().getModifiers())))
	   &&
           m.getName().equals(name)))
        maybeAdd(result, m);
        
    }
    return result;
  }
  
  /** Only add an instance method if no superclass provides one. **/
  private static void maybeAdd(Vector result, Method m1) {
    for(int i = 0; i < result.size(); i++) {
      Method m2 = ((Method) result.elementAt(i));
	if(parameterTypesMatch(getParameterTypes(m1), getParameterTypes(m2)))
	  return;
    }
    result.addElement(m1);
  }

  private static Class[] getParameterTypes(Object m) {
    return (m instanceof Method) ? ((Method) m).getParameterTypes() :
      ((Constructor) m).getParameterTypes();
  }

  /** Returns Object[] of parameterType, method pairs. **/
  private static Object[] methodArray(Object[] v) {
    Object[] result = new Object[v.length*BUCKET_SIZE];
    for(int i = 0; i < v.length; i++) {
      result[i*BUCKET_SIZE] = getParameterTypes(v[i]);
      result[i*BUCKET_SIZE+1] = v[i];
    }
    return result;
  }

  /** Do the paramter types of an instance method match? **/
  public static boolean parameterTypesMatch(Class[] p1, Class[] p2) {
    if (p1.length == p2.length) {
      for (int i = 0; i < p1.length; i++)
	if (p1[i] != p2[i]) return false;
      return true;
    } else return false;
  }

  /** Find the most applicable method.  For instance methods
      getMethods() has already handled the "this" argument, so
      instance and static methods are matched the same way. **/

  public static Object findMethod(Object[] methods, Object[] args) throws Exception {
    if (methods.length == BUCKET_SIZE)
         return methods[1]; // Hope it works!
    return findMethodNoOpt(methods,args);
   }

  static Object findMethodNoOpt(Object[] methods, Object[] args) throws Exception {
    int best = -1;
    for(int m1 = 0; m1 < methods.length; m1 = m1 + BUCKET_SIZE) {
      Class[] p1 = ((Class[]) methods[m1]);
      if (isApplicable(p1, args) &&
	  (best == -1 || !moreApplicable(((Class[]) methods[best]), p1)))
	best = m1;
    }
    if (best != -1) return methods[best+1];

    // print debugging info
    StringBuffer alts = new StringBuffer();
    for(int m1 = 0; m1 < methods.length; m1 = m1 + BUCKET_SIZE)
	if (methods[m1+1] instanceof Member)
           alts.append("   * "+methods[m1+1] +"\n");
	else {
            Class[] ts=(Class[]) methods[m1];
            alts.append("   * "+methods[m1+1]+" ( ");
	    for (int i=0;iThis is only used by (method).
  **/
  public static Method findMethod(String name, Object target, ConsPointer types) throws Exception {
    try {
      return U.toClass(target).getMethod(name, toClassArray(types, 0));
    } catch(NoSuchMethodException e) {
      return ((Method) E.error("No method: ", U.list(name, target, types)));
    }
  }

  /** Look up a particular constructor given its name, and the name of its
      declaring class, and a list of argument type names.
      
    This is only used by (constructor).
  **/
  public static Constructor findConstructor(Object target, ConsPointer types) throws Exception{
    try {
      return U.toClass(target).getConstructor(toClassArray(types, 0));
    } catch(NoSuchMethodException e) {
      return ((Constructor) E.error("No constructor: ", U.list(target, types)));
    }
  }

  public static Constructor findConstructor(String target, Object[] arguments) throws Exception{
     Class[] argumentsArray = new Class[arguments.length];

     for(int index = 0; index < arguments.length; index++)
     {
         Object argument = arguments[index];
         if(argument instanceof JavaObject)
         {
             argument = ((JavaObject)argument).getObject();
         }

         argumentsArray[index] = U.toClass(argument.getClass());
     }//for.

     Constructor constructor = U.toClass(target).getConstructor(argumentsArray);

     return constructor;
  }

  public static Class[] toClassArray(ConsPointer types, int n) throws Exception{
    if (types.getCons() == null /*types == Pair.EMPTY*/) return new Class[n];
    else {
      Class[] cs = toClassArray(((ConsPointer) types.getCons().cdr()), n + 1);
      cs[n] = U.toClass(types.car());
      return cs;
    }
  }

  /** Return all the methods for this class.  If you can't get all, for
   * some reason,, just return the public ones.
   
    Memoizable.
   **/
  public static Method[] getMethods(Class c,boolean isPrivileged) {
    Method[] methods = getAllMethods(c,isPrivileged);
    return (methods == null) ? c.getMethods() : methods;
  }

  /** Return all the methods on this class, and make them accessable.
      If you can't for some reason, return null;
  **/
  private static Method[] getAllMethods(Class c) {
      return getAllMethods(c,false);
  }

  private static Method[] getAllMethods(Class c,boolean isPrivileged) {
      if (isPrivileged)
          try{return ((Method[]) makeAccessible(getAllMethods0(c)));}
          catch(Exception e){return null;}
      else return null;
  }

  /**
     In some situations you may not be able to get declared methods.
     We only try once.
   **/
  static final boolean ALLOW_PRIVATE_ACCESS=true;
  private static boolean CAN_GET_DECLARED_METHODS = ALLOW_PRIVATE_ACCESS
    ? canGetDeclaredMethods() : false;
  private static boolean canGetDeclaredMethods () {
    try {
      Invoke.class.getDeclaredMethods();
      return true;
    } catch (Exception e) {return false;}}

  private static Method[] getAllMethods0 (Class c) {
    if (CAN_GET_DECLARED_METHODS) {
      Hashtable table = new Hashtable(35);
      collectDeclaredMethods(c, table);
      Enumeration e = ((Enumeration) table.elements());
      Method[] ms = new Method[table.size()];
      for (int i=0; e.hasMoreElements(); i++)
	ms[i] = ((Method)e.nextElement());
      return ms;
    }	
    else return null;
  }

  private static void collectDeclaredMethods(Class c, Hashtable h) {
    Method[] ms = c.getDeclaredMethods();
    for (int i = 0; i < ms.length; i++) h.put(ms[i], ms[i]);
    Class[] is = c.getInterfaces();
    for (int j = 0; j < is.length; j++) collectDeclaredMethods(is[j], h);
    Class sup = c.getSuperclass();
    if (sup != null) collectDeclaredMethods(sup, h);
  }

  /**
     Check that this JVM has AccessibleObject.
     We only try once.
   **/
  static Method SETACCESSIBLE = getSetAccessibleMethod();
  private static Method getSetAccessibleMethod() {
    try {
      Class c = Class.forName("java.lang.reflect.AccessibleObject");
      Class ca = Class.forName("[Ljava.lang.reflect.AccessibleObject;");
      return c.getMethod("setAccessible", new Class[] { ca, Boolean.TYPE });
    } catch (Exception e) {return null;}}

  /** Items should be of type AccessibleObject[] but we can't say that
      on JVM's older than JDK 1.2
      
    Also used by JavaField.
  **/
  static Object[] makeAccessible(Object[] items) {
    if (items != null && SETACCESSIBLE != null) {
      // AccessibleObject.setAccessible(items, true);
      try {
	SETACCESSIBLE.invoke(null, new Object[] { items, Boolean.TRUE });
      } catch (Exception e) {}
    }
    return items;
  }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/Reflector.java0000644000175000017500000000215511357267756030771 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

import java.util.Enumeration;
import java.util.Vector;

/** A Reflector contains one or more Java metaobjects that are cached.
    They need to be reset() when the classpath is reset.
**/


public abstract class Reflector {  // todo:tk extends { Procedure {

  //todo:tk:added these variables because they were inherited from Procedure.
  public String name = "??";
  public int minArgs = 0;
  public int maxArgs = Integer.MAX_VALUE;


  public static final Vector reflectors = new Vector(100);

  /** Reset all know reflectors **/
  public static void resetAll() throws Exception {
    Enumeration i = reflectors.elements();
    while (i.hasMoreElements())
      ((Reflector) i.nextElement()).reset();
  }

  public boolean isPrivileged = false;

  /** Add yourself to the reflectors **/
  public Reflector() {
    reflectors.addElement(this);
  }

  /** Reset your classpath dependent state.  This method can't be
      abstract.
  **/
  protected synchronized void reset() throws Exception {}

  protected Object readResolve() throws Exception {
    reset();
    return this;
  }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/Import.java0000644000175000017500000001601011357267756030311 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

/**  
     Class importing.

  @author Ken R. Anderson, Copyright 2000, kanderso@bbn.com, license
  subsequently modified by Jscheme project members
  licensed under zlib licence (see license.txt)

   
    Import provides support for Scheme's (import)
   procedure.  It is roughly like Java's import statement, with
   important differences described below.

   
    (import) can be used to import a single class, such as:
   
       (import "java.util.Date")
   
    

   Or all the classes of a package using the wildcard "*":

   
       (import "java.util.*")
   
    

   
     However, using wildcard imports is not recommend
   (deprecated) for the following reasons:

   
      

   
    • Class name lookup using wildcards requires generating class names
   that do not exits.  While this is fast for an application, it can
   take about a second for each lookup in an applet.

   
    • Conflicts between imports are identified at (import) time,
   rather than later in runtime.
   
    

**/
import java.util.Hashtable;
import java.util.Vector;
import java.util.Enumeration;

public class Import {

  private static ClassLoader CLASSLOADER = Import.class.getClassLoader();
  static {
   try {
         Thread.currentThread().setContextClassLoader
            (Import.class.getClassLoader());}
   catch (Exception e) {;}
  }
    
  /** Get the ClassLoader used to look up classes. **/
  public static synchronized ClassLoader getClassLoader() {
    return CLASSLOADER;
  }
  /** Set the ClassLoader used to look up classes. **/
  public static synchronized void setClassLoader(ClassLoader cl) {
    CLASSLOADER = cl;
      Thread.currentThread().setContextClassLoader(cl);
  }

  /**
     Fields singles and wilds should be HashSets which won't exist
     until JDK 1.2.  So we simulate them with Vectors, which existed
     since JDK 1.0.
   **/
  public static final Vector singles = new Vector(50);
  public static final Vector wilds = new Vector(50);
  public static final Hashtable table = new Hashtable (200);

  // KRA 17AUG01: Eventually add these as singles and wilds.
  static {
    addImport("java.lang.Object");
    addImport("java.lang.*");
    addImport("java.lang.reflect.*");
    addImport("java.util.*");
    addImport("jsint.*");
  }

  /** Add an import, clearing the cache if it's wild. **/
  public static synchronized void addImport(String name) {
    // System.out.println("addImport: " + name);
    if (name.endsWith("*")) {
      addNew(wilds, new WildImporter(name));
      table.clear();
    } else addNew(singles, new SingleImporter(name));
  }

  /* Use Vector to simulate a HashSet. */
  private static void addNew(Vector v, Object x) {
    if (x != null &&!v.contains(x)) v.addElement(x);
  }

  /**
     Find a Class named name either relative to imports, or
     absolute, or error. Names of the form $name are
     interpreted as absolute specifications for package-less classes
     for historical reasons.  
   **/
  public static Class classNamed(String name) throws Exception {
    Class c = maybeClassNamed(name);
    return (c == null) ?
      (Class) E.error("Can't find class " + name + "."):
      c;
  }

  /** Returns a class or return null. **/
  public static synchronized Class maybeClassNamed(String name) throws Exception {
    Class c = ((Class) table.get(name)); // Cached?
    if (c != null) return c;
    c = classNamedLookup(name);
    if (c != null) table.put(name, c);
    return c;
  }

  private static Class classNamedLookup(String name) throws Exception {
    if (name.endsWith("[]"))
      return classNamedArray(name.substring(0, name.length() - "[]".length()));
    Class c = classNamedImported(name);
    if (c != null) return c;
    return primitiveClassNamed(name);
  }

  /**
     Search for class named name looking in singles.
     Search packageless classes and wilds only if necessary.
  **/
  private static Class classNamedImported(String name) {
    Vector classes = find(singles, name, new Vector(5));
    if (name.lastIndexOf(".") == -1) { // No package prefix.
      if (classes.size() == 0) classes = classNamedNoPackage(name, classes);
      if (classes.size() == 0) classes = find(wilds, name, classes);
    } else addNew(classes, Import.forName(name));
    return returnClass(name, classes);
  }

  private static Class returnClass(String name, Vector classes) {
    int L = classes.size();
    if (L == 0) return null;
    if (L == 1) return ((Class) classes.elementAt(0));
    else 
      return ((Class) E.warn("Class " + name + " is ambiguous " + classes +
			     " choosing " + ((Class) classes.elementAt(0))));
  }

  private static Vector classNamedNoPackage(String name, Vector classes) {
    addNew(classes, Import.forName((name.startsWith("$"))
				   ? name.substring(1,name.length())
				   : name));
    return classes;
  }

  public static Vector find(Vector imports, String name, Vector classes) {
    Enumeration is = imports.elements();
    while (is.hasMoreElements()) 
      addNew(classes, ((Importer) is.nextElement()).classNamed(name));
    return classes;
  }

  /** name is the name of the component class. **/
  private static Class classNamedArray(String name)  throws Exception {
    Class c = classNamed(name);
    if (c.isPrimitive()) return classNamedArrayPrimitive(c);
    if (c.isArray()) return Import.forName("[" + c.getName());
    else return Import.forName("[L" + c.getName() + ";");
  }

  /** Ask the ClassLoader for a class given its full name. **/
  public static Class forName(String name) {
    ClassLoader loader = getClassLoader();
    if (loader == null) 
      try { return Class.forName(name);}
    catch (ClassNotFoundException e) { return null;}
    else
      try { return loader.loadClass(name); }
    catch (ClassNotFoundException e) { return null; }
    // KRA 28JUN00: Renu found this!    
    catch (NoClassDefFoundError e) { return null; } 
  }

  /** Class.forName() doesn't work for primitive types. **/
  private static Class primitiveClassNamed(String name) {
    return
      name.equals("void")    ?      Void.TYPE :
      name.equals("boolean") ?   Boolean.TYPE :
      name.equals("byte")    ?      Byte.TYPE :
      name.equals("char")    ? Character.TYPE :
      name.equals("short")   ?     Short.TYPE :
      name.equals("int")     ?   Integer.TYPE :
      name.equals("long")    ?      Long.TYPE :
      name.equals("float")   ?     Float.TYPE :
      name.equals("double")  ?    Double.TYPE :
      null;
  }

  private static Class classNamedArrayPrimitive(Class c) {
    return
   // (c == void.class)    ?      void[].class :
      (c == boolean.class) ?   boolean[].class :
      (c == byte.class)    ?      byte[].class :
      (c == char.class)    ?      char[].class :
      (c == short.class)   ?     short[].class :
      (c == int.class)     ?       int[].class :
      (c == long.class)    ?      long[].class :
      (c == float.class)   ?     float[].class :
      (c == double.class)  ?    double[].class :
      null;
  }

  private Import() {}		// Don't make one yourself.
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/JavaConstructor.java0000644000175000017500000000257111357267756032175 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;
import java.lang.reflect.Constructor;

/** Provides dynamic constructors.
 * @author Peter Norvig, Copyright 1998, peter@norvig.com, license
 * subsequently modified by Jscheme project members
 * licensed under zlib licence (see license.txt)
 **/

public class JavaConstructor extends StaticReflector {

  private transient Object[] methods;

  /** Depricated! **/
  public JavaConstructor(Class c) throws Exception {
    this(c.getName());
  }

  public JavaConstructor(String c, boolean isPrivileged) throws Exception {
    this.name = c;
    this.isPrivileged = isPrivileged;
    this.reset();
  }

  public JavaConstructor(String c) throws Exception {
      this(c,false);
  }

  public Object apply(Object[] args) throws Exception{
    return Invoke.invokeRawConstructor
      (((Constructor) Invoke.findMethod(methods, args)), args);
  }

  protected synchronized void reset() throws Exception {
    methods = Invoke.constructorTable(name, isPrivileged);

    int min = Integer.MAX_VALUE;
    int max = 0;

    for(int i = 0; i < methods.length; i = i + Invoke.BUCKET_SIZE) {
      int n = ((Object[]) methods[i]).length;
      if (n < min) min = n;
      if (n > max) max = n;
    }
    minArgs = min;
    maxArgs = max;
  }

  /** Code is like (vector Hashtable. 10), ie the first element is the
      Constructor. **/
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/WildImporter.java0000644000175000017500000000201511357267756031460 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

import java.util.Hashtable;

/** An Importer that can handle a wildcard, like "java.io.*". **/
public class WildImporter implements Importer {
  String prefix;

  public WildImporter(String name) {
    this.prefix = name.substring(0, name.length() - "*".length());
  }
      
  public Class classNamed(String name) {
    try {
      return (name.startsWith(prefix))
	? Import.forName(name)
	: (name.indexOf(".") == -1)
	? Import.forName(prefix + name)
	: null;
    } catch (java.lang.SecurityException  se) {
      // Can come back from Netscape. Assume the guessed name doesn't exist.
      return null;
    } catch (Throwable t) {
      E.warn(this + " " + name + " " + t);
      return null;
    }
  }

  public boolean equals(Object x) {
    return this.getClass() == x.getClass() &&
      this.prefix == ((WildImporter)x).prefix;
  }

  public int hashCode() {return this.prefix.hashCode();}

  public String toString() {return "(import " + prefix + "*)";}

  public void reset() {}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/Importer.java0000644000175000017500000000031011357267756030634 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

/** Used by Import.  One for each (import) expression. **/
public interface Importer {
  public Class classNamed(String name);
  public void reset();
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/StaticReflector.java0000644000175000017500000000205211357267756032135 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;
import java.lang.reflect.Constructor;

/** StaticReflector's like JavaConstructor and Generic can share this behavior.
 * @author Peter Norvig, Copyright 1998, peter@norvig.com, license
 * subsequently modified by Jscheme project members
 * licensed under zlib licence (see license.txt)
 **/

public abstract class StaticReflector extends Reflector {

  public static final Object[] args0 = new Object[0];

  /** Code is an Object[] who's first element is a JavaConstructor, and
   * remaining elements are arguments.
  **/
  /*
  public Object[] makeArgArray(Object[] code,
                               Evaluator eval,
                               LexicalEnvironment lexenv) {
    int L = code.length - 1;
    if (L == 0) return args0;
    
    Object[] args = new Object[L];
    for (int i = 0; i < L; i++)
      args[i] = eval.execute(code[i+1], lexenv);
    return args;
  }

  public Object[] makeArgArray (ConsPointer args) {
    return U.listToVector(args);
  }
   * */
}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/U.java0000644000175000017500000000372111357267756027250 0ustar  giovannigiovanni

package org.mathpiper.builtin.javareflection;

import org.mathpiper.lisp.cons.ConsPointer;


public class U {

  public static Class toClass(Object c) throws Exception {
    if (c instanceof Class) return (Class) c;
    else return Import.classNamed(stringify(c, false));
  }



  /** Convert x to a String giving its external representation.
   * Strings and characters are quoted. **/
  public static String stringify(Object x) { return stringify(x, true); }

  /** Convert x to a String giving its external representation.
   * Strings and characters are quoted iff quoted is true.. **/
  public static String stringify(Object x, boolean quoted) {
    // Handle these cases without consing:
    if (x instanceof String && !quoted) return ((String) x);
    /*else if (x instanceof Symbol) return ((Symbol) x).toString();
    else return stringify(x, quoted, new StringBuffer()).toString();*/

      return "";
  }//end method


    /** Creates a three element list. **/
  public static ConsPointer list(Object a, Object b, Object c) {
    //return new Pair(a, new Pair(b, new Pair(c, Pair.EMPTY)));
      return null;
  }

  /** Creates a two element list. **/
  public static ConsPointer list(Object a, Object b) {
    //return new Pair(a, new Pair(b, Pair.EMPTY));
      return null;
  }

  /** Creates a one element list. **/
  public static ConsPointer list(Object a) {
    //return new Pair(a, Pair.EMPTY);
      return null;
  }


  public static Object[] listToVector(Object x) {
    /*Pair list = toList(x);
    int L = list.length();
    Object[] result = new Object[L];
    for (int i = 0; isPair(list); i++, list = toList(list.rest))
      result[i] = first(list);
    return result; todo:tk */
      return null;
  }


  public static ConsPointer vectorToList(Object vec) {
    /*Pair result = Pair.EMPTY;
    for (int i = Array.getLength(vec)-1; i>=0; i--) {
      result = new Pair(Array.get(vec, i), result);
    }
    return result;*/
      return null;
  }

}//end class
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/E.java0000644000175000017500000000241411357267756027226 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

import org.mathpiper.lisp.LispError;


/**
   Error routines.
**/

public class E {

  /** Throw an error message with an associated object. **/
  public static Object error(String message, Object x) throws Exception {
      //throw new SchemeException(message,x);
      LispError.raiseError(message, "", -2, null);
      return null;
  }
  

  public static Object error(String message) throws Exception{
    return  error(message,null);
  }

  /** Call error, complaining that we got the wrong type. **/
  public static Object typeError(String type, Object x) throws Exception{
    return error("expected object of type " + type + ", but got: ", x);
  }

  /** Print a warning. **/
  public static Object warn(String message) {
    //Scheme.currentEvaluator().getError().println("** WARNING: " + message);
    return message;
  }
  
   /** Print a warning. **/
  public static Object warn(String message, Object x) {
    return warn(message + shortStringify(x));
  }

  /** It's nice to get an error, but not one large enough to choke EMACS. **/
  public static String shortStringify(Object x) {
    //String s = U.stringify(x);
    //if (s.length() > 1000) return s.substring(0,1000) + "...";
    //return s; todo:tk.
      return "";
  }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/javareflection/SingleImporter.java0000644000175000017500000000155711357267756032014 0ustar  giovannigiovannipackage org.mathpiper.builtin.javareflection;

/** An Importer that knows how to import a single class. **/
public class SingleImporter implements Importer {
  String fullName;
  Class c;

  public SingleImporter(String fullName) {
    this.fullName = fullName;
    reset();
  }

  public Class classNamed(String name) {
    /* An import may occur before the class is on the classpath,
       so Import.forName() will return null. **/
    if (c == null) reset();
    return (fullName.equals(name) || fullName.endsWith("."+name))
      ? c : null;
  }

  public boolean equals(Object x) {
    return this.getClass() == x.getClass() &&
      this.fullName == ((SingleImporter)x).fullName;
  }

  public int hashCode() {return this.fullName.hashCode();}

  public String toString() {return "(import " + fullName + ")";}

  public void reset() {this.c = Import.forName(fullName);}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/JavaObject.java0000644000175000017500000000617011627037512026042 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

import java.util.ArrayList;
import java.util.List;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;

public class JavaObject extends BuiltinContainer {

    private Object javaObject;

    public JavaObject(Object javaObject) {
        this.javaObject = javaObject;
    }



    public String typeName() {
        return javaObject.getClass().getName();
    }//end method.


    public Object getObject() {
        return javaObject;
    }//end method.


    public static List lispListToJavaList(Environment aEnvironment, int aStackTop,ConsPointer lispList) throws Exception {
        LispError.check(aEnvironment, aStackTop, Utility.isList(lispList), LispError.NOT_A_LIST, "INTERNAL");
        
        lispList.goNext(aStackTop, aEnvironment);

        ArrayList javaList = new ArrayList();

        while (lispList.getCons() != null) {

            Object item = lispList.car();
            //item = narrow(item);
            javaList.add(item);

            lispList.goNext(aStackTop, aEnvironment);

        }//end while.

        return javaList;
    }//end method.


    public static double[] lispListToJavaDoubleArray(Environment aEnvironment, int aStackTop, ConsPointer lispListPointer) throws Exception {
        LispError.check(aEnvironment, aStackTop, Utility.isList(lispListPointer), LispError.NOT_A_LIST, "INTERNAL");

        lispListPointer.goNext(aStackTop, aEnvironment); //Remove List designator.

        double[] values = new double[Utility.listLength(aEnvironment, aStackTop, lispListPointer)];

        int index = 0;
        while (lispListPointer.getCons() != null) {

            Object item = lispListPointer.car();

            LispError.check(aEnvironment, aStackTop, item instanceof String, LispError.INVALID_ARGUMENT, "INTERNAL");
            String itemString = (String) item;

            try {
                values[index++] = Double.parseDouble(itemString);
            } catch (NumberFormatException nfe) {
                LispError.raiseError("Can not convert into a double." , "INTERNAL", aStackTop, aEnvironment);
            }//end try/catch.

            lispListPointer.goNext(aStackTop, aEnvironment);

        }//end while.

        return values;
        
    }//end method.

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/BuiltinFunction.java0000644000175000017500000017426111523146134027151 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

import java.net.URISyntaxException;
import java.util.ArrayList;
import java.util.HashSet;
import java.util.List;

import org.mathpiper.builtin.functions.core.Abs;
import org.mathpiper.builtin.functions.core.Add;
import org.mathpiper.builtin.functions.core.And;
import org.mathpiper.builtin.functions.core.ApplyFast;
import org.mathpiper.builtin.functions.core.ArrayCreate;
import org.mathpiper.builtin.functions.core.ArrayGet;
import org.mathpiper.builtin.functions.core.ArraySet;
import org.mathpiper.builtin.functions.core.ArraySize;
import org.mathpiper.builtin.functions.core.AskUser;
import org.mathpiper.builtin.functions.core.ToAtom;
import org.mathpiper.builtin.functions.core.BackQuote;
import org.mathpiper.builtin.functions.core.BitAnd;
import org.mathpiper.builtin.functions.core.BitCount;
import org.mathpiper.builtin.functions.core.BitOr;
import org.mathpiper.builtin.functions.core.BitXor;
import org.mathpiper.builtin.functions.core.BitsToDigits;
import org.mathpiper.builtin.functions.core.Bodied;
import org.mathpiper.builtin.functions.core.BuiltinAssoc;
import org.mathpiper.builtin.functions.core.BuiltinPrecisionGet;
import org.mathpiper.builtin.functions.core.BuiltinPrecisionSet;
import org.mathpiper.builtin.functions.core.Ceil;
import org.mathpiper.builtin.functions.core.UnicodeToString;
import org.mathpiper.builtin.functions.core.Check;
import org.mathpiper.builtin.functions.core.Unbind;
import org.mathpiper.builtin.functions.core.CommonLispTokenizer;
import org.mathpiper.builtin.functions.core.Concatenate;
import org.mathpiper.builtin.functions.core.ConcatenateStrings;
import org.mathpiper.builtin.functions.core.CurrentFile;
import org.mathpiper.builtin.functions.core.CurrentLine;
import org.mathpiper.builtin.functions.core.CustomEval;
import org.mathpiper.builtin.functions.core.CustomEvalExpression;
import org.mathpiper.builtin.functions.core.CustomEvalLocals;
import org.mathpiper.builtin.functions.core.CustomEvalResult;
import org.mathpiper.builtin.functions.core.CustomEvalStop;
import org.mathpiper.builtin.functions.core.DebugFile;
import org.mathpiper.builtin.functions.core.DebugLine;
import org.mathpiper.builtin.functions.core.DefLoad;
import org.mathpiper.builtin.functions.core.DefLoadFunction;
import org.mathpiper.builtin.functions.core.DefMacroRulebase;
import org.mathpiper.builtin.functions.core.DefMacroRulebaseListed;
import org.mathpiper.builtin.functions.core.DefaultDirectory;
import org.mathpiper.builtin.functions.core.DefaultTokenizer;
import org.mathpiper.builtin.functions.core.Delete;
import org.mathpiper.builtin.functions.core.DestructiveDelete;
import org.mathpiper.builtin.functions.core.DestructiveInsert;
import org.mathpiper.builtin.functions.core.DestructiveReplace;
import org.mathpiper.builtin.functions.core.DestructiveReverse;
import org.mathpiper.builtin.functions.core.DigitsToBits;
import org.mathpiper.builtin.functions.core.Quotient;
import org.mathpiper.builtin.functions.core.Divide;
import org.mathpiper.builtin.functions.core.DumpNumber;
import org.mathpiper.builtin.functions.core.IsEqual;
import org.mathpiper.builtin.functions.core.Eval;
import org.mathpiper.builtin.functions.core.Exit;
import org.mathpiper.builtin.functions.core.ExitRequested;
import org.mathpiper.builtin.functions.core.ExpressionToString;
import org.mathpiper.builtin.functions.core.Factorial;
import org.mathpiper.builtin.functions.core.FastArcSin;
import org.mathpiper.builtin.functions.core.FastIsPrime;
import org.mathpiper.builtin.functions.core.FastLog;
import org.mathpiper.builtin.functions.core.FastPower;
import org.mathpiper.builtin.functions.core.FileSize;
import org.mathpiper.builtin.functions.core.FindFile;
import org.mathpiper.builtin.functions.core.FindFunction;
import org.mathpiper.builtin.functions.core.First;
import org.mathpiper.builtin.functions.core.FlatCopy;
import org.mathpiper.builtin.functions.core.Floor;
import org.mathpiper.builtin.functions.core.FromBase;
import org.mathpiper.builtin.functions.core.PipeFromFile;
import org.mathpiper.builtin.functions.core.PipeFromString;
import org.mathpiper.builtin.functions.core.LispForm;
import org.mathpiper.builtin.functions.core.GarbageCollect;
import org.mathpiper.builtin.functions.core.Gcd;
import org.mathpiper.builtin.functions.core.GenericTypeName;
import org.mathpiper.builtin.functions.core.ExceptionGet;
import org.mathpiper.builtin.functions.core.GetExactBits;
import org.mathpiper.builtin.functions.core.IsGreaterThan;
import org.mathpiper.builtin.functions.core.HistorySize;
import org.mathpiper.builtin.functions.core.Hold;
import org.mathpiper.builtin.functions.core.HoldArgument;
import org.mathpiper.builtin.functions.core.If;
import org.mathpiper.builtin.functions.core.InDebugMode;
import org.mathpiper.builtin.functions.core.Infix;
import org.mathpiper.builtin.functions.core.Insert;
import org.mathpiper.builtin.functions.core.IsAtom;
import org.mathpiper.builtin.functions.core.IsBodied;
import org.mathpiper.builtin.functions.core.IsBound;
import org.mathpiper.builtin.functions.core.IsDecimal;
import org.mathpiper.builtin.functions.core.IsFunction;
import org.mathpiper.builtin.functions.core.IsGeneric;
import org.mathpiper.builtin.functions.core.IsInfix;
import org.mathpiper.builtin.functions.core.IsInteger;
import org.mathpiper.builtin.functions.core.IsList;
import org.mathpiper.builtin.functions.core.IsNumber;
import org.mathpiper.builtin.functions.core.IsPostfix;
import org.mathpiper.builtin.functions.core.IsPrefix;
import org.mathpiper.builtin.functions.core.IsPromptShown;
import org.mathpiper.builtin.functions.core.IsString;
import org.mathpiper.builtin.functions.core.LeftPrecedenceSet;
import org.mathpiper.builtin.functions.core.Length;
import org.mathpiper.builtin.functions.core.IsLessThan;
import org.mathpiper.builtin.functions.core.LispRead;
import org.mathpiper.builtin.functions.core.LispReadListed;
import org.mathpiper.builtin.functions.core.FunctionToList;
import org.mathpiper.builtin.functions.core.LoadScript;
import org.mathpiper.builtin.functions.core.Local;
import org.mathpiper.builtin.functions.core.LocalSymbols;
import org.mathpiper.builtin.functions.core.MacroRulePattern;
import org.mathpiper.builtin.functions.core.MacroRule;
import org.mathpiper.builtin.functions.core.MacroRulebase;
import org.mathpiper.builtin.functions.core.MacroRulebaseListed;
import org.mathpiper.builtin.functions.core.MacroBind;
import org.mathpiper.builtin.functions.core.MathIsSmall;
import org.mathpiper.builtin.functions.core.MathNegate;
import org.mathpiper.builtin.functions.core.MathSign;
import org.mathpiper.builtin.functions.core.MaxEvalDepth;
import org.mathpiper.builtin.functions.core.MetaEntries;
import org.mathpiper.builtin.functions.core.MetaGet;
import org.mathpiper.builtin.functions.core.MetaKeys;
import org.mathpiper.builtin.functions.core.MetaSet;
import org.mathpiper.builtin.functions.core.MetaValues;
import org.mathpiper.builtin.functions.core.Modulo;
import org.mathpiper.builtin.functions.core.Multiply;
import org.mathpiper.builtin.functions.core.RulePattern;
import org.mathpiper.builtin.functions.core.Not;
import org.mathpiper.builtin.functions.core.Nth;
import org.mathpiper.builtin.functions.core.LeftPrecedenceGet;
import org.mathpiper.builtin.functions.core.PrecedenceGet;
import org.mathpiper.builtin.functions.core.RightPrecedenceGet;
import org.mathpiper.builtin.functions.core.Or;
import org.mathpiper.builtin.functions.core.PatchLoad;
import org.mathpiper.builtin.functions.core.PatchString;
import org.mathpiper.builtin.functions.core.PatternCreate;
import org.mathpiper.builtin.functions.core.PatternMatches;
import org.mathpiper.builtin.functions.core.Postfix;
import org.mathpiper.builtin.functions.core.Prefix;
import org.mathpiper.builtin.functions.core.PrettyPrinterGet;
import org.mathpiper.builtin.functions.core.PrettyPrinterSet;
import org.mathpiper.builtin.functions.core.PrettyReaderGet;
import org.mathpiper.builtin.functions.core.PrettyReaderSet;
import org.mathpiper.builtin.functions.core.Prog;
import org.mathpiper.builtin.functions.core.Read;
import org.mathpiper.builtin.functions.core.ReadToken;
import org.mathpiper.builtin.functions.core.Replace;
import org.mathpiper.builtin.functions.core.Rest;
import org.mathpiper.builtin.functions.core.Retract;
import org.mathpiper.builtin.functions.core.RightAssociativeSet;
import org.mathpiper.builtin.functions.core.RightPrecedenceSet;
import org.mathpiper.builtin.functions.core.RoundToN;
import org.mathpiper.builtin.functions.core.Rule;
import org.mathpiper.builtin.functions.core.Rulebase;
import org.mathpiper.builtin.functions.core.RulebaseArgumentsList;
import org.mathpiper.builtin.functions.core.RulebaseDefined;
import org.mathpiper.builtin.functions.core.RulebaseListed;
import org.mathpiper.builtin.functions.core.Secure;
import org.mathpiper.builtin.functions.core.Bind;
import org.mathpiper.builtin.functions.core.SetExactBits;
import org.mathpiper.builtin.functions.core.SetGlobalLazyVariable;
import org.mathpiper.builtin.functions.core.ShiftLeft;
import org.mathpiper.builtin.functions.core.ShiftRight;
import org.mathpiper.builtin.functions.core.StackSize;
import org.mathpiper.builtin.functions.core.StringMidGet;
import org.mathpiper.builtin.functions.core.StringMidSet;
import org.mathpiper.builtin.functions.core.ToString;
import org.mathpiper.builtin.functions.core.Subst;
import org.mathpiper.builtin.functions.core.Subtract;
import org.mathpiper.builtin.functions.core.SystemCall;
import org.mathpiper.builtin.functions.core.TellUser;
import org.mathpiper.builtin.functions.core.ToBase;
import org.mathpiper.builtin.functions.core.PipeToFile;
import org.mathpiper.builtin.functions.core.PipeToStdout;
import org.mathpiper.builtin.functions.core.PipeToString;
import org.mathpiper.builtin.functions.core.TraceRule;
import org.mathpiper.builtin.functions.core.TraceStack;
import org.mathpiper.builtin.functions.core.ExceptionCatch;
import org.mathpiper.builtin.functions.core.UnFence;
import org.mathpiper.builtin.functions.core.ListToFunction;
import org.mathpiper.builtin.functions.core.LoadScriptOnce;
import org.mathpiper.builtin.functions.core.While;
import org.mathpiper.builtin.functions.core.Write;
import org.mathpiper.builtin.functions.core.WriteString;
import org.mathpiper.builtin.functions.core.XmlExplodeTag;
import org.mathpiper.builtin.functions.core.XmlTokenizer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.printers.MathPiperPrinter;

import java.io.*;
import org.mathpiper.builtin.functions.core.Delay;
import org.mathpiper.builtin.functions.core.FastArcCos;
import org.mathpiper.builtin.functions.core.FastArcTan;
import org.mathpiper.builtin.functions.core.FastCos;
import org.mathpiper.builtin.functions.core.FastSin;
import org.mathpiper.builtin.functions.core.FastTan;
import org.mathpiper.builtin.functions.core.GlobalVariablesGet;
import org.mathpiper.builtin.functions.core.JavaAccess;
import org.mathpiper.builtin.functions.core.JavaCall;
import org.mathpiper.builtin.functions.core.JavaNew;
import org.mathpiper.builtin.functions.core.JavaToValue;
import org.mathpiper.builtin.functions.core.StringToUnicode;

public abstract class BuiltinFunction {

	public static synchronized List addOptionalFunctions(Environment aEnvironment, String functionsPath) {

		List failList = new ArrayList();

		try {
			String[] listing = getResourceListing(BuiltinFunction.class, functionsPath);
			for (int x = 0; x < listing.length; x++) {

				String fileName = listing[x];

				if (!fileName.toLowerCase().endsWith(".class")) {
					continue;
				}


				fileName = fileName.substring(0, fileName.length() - 6);
				fileName = functionsPath + fileName;
				fileName = fileName.replace("/", ".");

				//System.out.println(fileName);

				try {
					Class functionClass = Class.forName(fileName, true, BuiltinFunction.class.getClassLoader());

					//System.out.println("CLASS :" + functionClass.toString() + "   CLASSLOADER: " + BuiltinFunction.class.getClassLoader().toString());

					Object functionObject = functionClass.newInstance();
					if (functionObject instanceof BuiltinFunction) {
						BuiltinFunction function = (BuiltinFunction) functionObject;
						function.plugIn(aEnvironment);
					}//end if.
				} catch (ClassNotFoundException cnfe) {
					System.out.println("Class not found: " + fileName);
				} catch (InstantiationException ie) {
					System.out.println("Can not instantiate class: " + fileName);
				} catch (IllegalAccessException iae) {
					System.out.println("Illegal access of class: " + fileName);
				} catch (NoClassDefFoundError ncdfe) {
					//System.out.println("Class not found: " + fileName);
					failList.add(fileName);
				}

			}//end for.



		} catch (Exception e) {
			e.printStackTrace();
		}




		return failList;
	}//end method.

	public abstract void evaluate(Environment aEnvironment, int aStackTop) throws Exception;

	public static ConsPointer getTopOfStackPointer(Environment aEnvironment, int aStackTop) throws Exception {
		return aEnvironment.iArgumentStack.getElement(aStackTop, aStackTop, aEnvironment);
	}

	public static ConsPointer getArgumentPointer(Environment aEnvironment, int aStackTop, int argumentPosition) throws Exception {
		return aEnvironment.iArgumentStack.getElement(aStackTop + argumentPosition, aStackTop, aEnvironment);
	}

	public static ConsPointer getArgumentPointer(Environment aEnvironment, int aStackTop, ConsPointer cur, int n) throws Exception {
		LispError.lispAssert(n >= 0, aEnvironment, aStackTop);

		ConsPointer loop = cur;
		while (n != 0) {
			n--;
			loop = loop.cdr();
		}
		return loop;
	}

	public void plugIn(Environment aEnvironment) throws Exception{
	}//end method.

	public static void addCoreFunctions(Environment aEnvironment) {
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "While");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "Rule");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "MacroRule");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "RulePattern");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "MacroRulePattern");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "PipeFromFile");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "PipeFromString");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "PipeToFile");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "PipeToString");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "PipeToStdout");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "TraceRule");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "Subst");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "LocalSymbols");
		aEnvironment.iBodiedOperators.setOperator(MathPiperPrinter.KMaxPrecedence, "BackQuote");
		aEnvironment.iPrefixOperators.setOperator(0, "`");
		aEnvironment.iPrefixOperators.setOperator(0, "@");
		aEnvironment.iPrefixOperators.setOperator(0, "_");
		aEnvironment.iInfixOperators.setOperator(0, "_");

		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Hold(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Hold");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Eval(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Eval");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Write(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "Write");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new WriteString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "WriteString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LispForm(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LispForm");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefaultDirectory(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DefaultDirectory");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PipeFromFile(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "PipeFromFile");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PipeFromString(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "PipeFromString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Read(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Read");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ReadToken(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ReadToken");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PipeToFile(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "PipeToFile");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PipeToString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "PipeToString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PipeToStdout(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "PipeToStdout");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LoadScript(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LoadScript");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Bind(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Bind");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MacroBind(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "MacroBind");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Unbind(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "Unbind");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Unbind(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "MacroUnbind");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Local(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "Local");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Local(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "MacroLocal");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new First(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "First");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Nth(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathNth");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Rest(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Rest");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DestructiveReverse(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DestructiveReverse");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Length(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Length");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.List(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "List");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Set(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "Set");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ListToFunction(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ListToFunction");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FunctionToList(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FunctionToList");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Concatenate(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "Concat");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ConcatenateStrings(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "ConcatStrings");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Delete(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Delete");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DestructiveDelete(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DestructiveDelete");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Insert(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Insert");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DestructiveInsert(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DestructiveInsert");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Replace(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Replace");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DestructiveReplace(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DestructiveReplace");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ToAtom(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ToAtom");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ToString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ToString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ExpressionToString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ExpressionToString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new UnicodeToString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "UnicodeToString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new StringToUnicode(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "StringToUnicode");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FlatCopy(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FlatCopy");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Prog(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "Prog");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new While(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "While");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new If(), 2, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "If");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Check(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Check");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ExceptionCatch(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "ExceptionCatch");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ExceptionGet(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ExceptionGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Prefix(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Prefix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Infix(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Infix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Postfix(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Postfix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Bodied(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Bodied");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Rulebase(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Rulebase");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MacroRulebase(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MacroRulebase");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RulebaseListed(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "RulebaseListed");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MacroRulebaseListed(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MacroRulebaseListed");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefMacroRulebase(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "DefMacroRulebase");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefMacroRulebaseListed(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "DefMacroRulebaseListed");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new HoldArgument(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "HoldArgument");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Rule(), 5, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Rule");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MacroRule(), 5, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MacroRule");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new UnFence(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "UnFence");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Retract(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Retract");
		/* aEnvironment.getBuiltinFunctions().setAssociation(
		new BuiltinFunctionEvaluator(new Not(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		"NotN");*/
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Not(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Not"); //Alias.
		/*aEnvironment.getBuiltinFunctions().setAssociation(
		new BuiltinFunctionEvaluator(new And(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		"AndN");*/
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new And(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "And"); //Alias.
		/*aEnvironment.getBuiltinFunctions().setAssociation(
		new BuiltinFunctionEvaluator(new Or(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		"OrN");*/
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Or(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "Or"); //Alias.
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsEqual(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsEqual");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsEqual(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "="); //Alias.
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsLessThan(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsLessThan");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsGreaterThan(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsGreaterThan");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsFunction(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsFunction");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsAtom(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsAtom");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsNumber(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsNumber");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsDecimal(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsDecimal");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsInteger(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsInteger");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsList(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsList");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsBound(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "IsBound");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Multiply(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MultiplyN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Add(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "AddN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Subtract(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "SubtractN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Divide(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DivideN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BuiltinPrecisionSet(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BuiltinPrecisionSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new GetExactBits(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "GetExactBitsN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new SetExactBits(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "SetExactBitsN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BitCount(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathBitCount");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MathSign(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathSign");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MathIsSmall(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathIsSmall");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MathNegate(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathNegate");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Floor(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FloorN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Ceil(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CeilN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Abs(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "AbsN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Modulo(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ModuloN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Quotient(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "QuotientN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BitsToDigits(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BitsToDigits");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DigitsToBits(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DigitsToBits");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Gcd(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "GcdN");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new SystemCall(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "SystemCall");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastSin(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastSin");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastArcSin(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastArcSin");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastCos(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastCos");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastArcCos(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastArcCos");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastTan(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastTan");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastArcTan(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastArcTan");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastLog(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastLog");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastPower(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastPower");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ShiftLeft(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ShiftLeft");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ShiftRight(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ShiftRight");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FromBase(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FromBase");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ToBase(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ToBase");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MaxEvalDepth(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MaxEvalDepth");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefLoad(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DefLoad");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LoadScriptOnce(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LoadScriptOnce");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RightAssociativeSet(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RightAssociativeSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LeftPrecedenceSet(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LeftPrecedenceSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RightPrecedenceSet(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RightPrecedenceSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsBodied(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsBodied");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsInfix(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsInfix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsPrefix(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsPrefix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsPostfix(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsPostfix");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PrecedenceGet(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PrecedenceGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LeftPrecedenceGet(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LeftPrecedenceGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RightPrecedenceGet(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RightPrecedenceGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BuiltinPrecisionGet(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BuiltinPrecisionGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BitAnd(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BitAnd");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BitOr(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BitOr");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BitXor(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "BitXor");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Secure(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Secure");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FindFile(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FindFile");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FindFunction(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FindFunction");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsGeneric(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsGeneric");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new GenericTypeName(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "GenericTypeName");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ArrayCreate(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ArrayCreate");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ArraySize(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ArraySize");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ArrayGet(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ArrayGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ArraySet(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ArraySet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CustomEval(), 4, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "CustomEval");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CustomEvalExpression(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CustomEval'Expression");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CustomEvalResult(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CustomEval'Result");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CustomEvalLocals(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CustomEval'Locals");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CustomEvalStop(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CustomEval'Stop");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new TraceRule(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "TraceRule");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new TraceStack(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "TraceStack");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LispRead(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LispRead");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LispReadListed(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "LispReadListed");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Type(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Type");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new StringMidGet(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "StringMidGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new StringMidSet(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "StringMidSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PatternCreate(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PatternCreate");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PatternMatches(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PatternMatches");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RulebaseDefined(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RulebaseDefined");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefLoadFunction(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DefLoadFunction");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RulebaseArgumentsList(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RulebaseArgumentsList");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RulePattern(), 5, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "RulePattern");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MacroRulePattern(), 5, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MacroRulePattern");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Subst(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Subst");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new LocalSymbols(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Macro),
		        "LocalSymbols");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FastIsPrime(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FastIsPrime");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Factorial(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MathFac");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ApplyFast(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ApplyFast");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PrettyReaderSet(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "PrettyReaderSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PrettyPrinterSet(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
		        "PrettyPrinterSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PrettyPrinterGet(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PrettyPrinterGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PrettyReaderGet(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PrettyReaderGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new GarbageCollect(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "GarbageCollect");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new SetGlobalLazyVariable(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "SetGlobalLazyVariable");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PatchLoad(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PatchLoad");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new PatchString(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "PatchString");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MetaSet(), 3, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MetaSet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MetaGet(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MetaGet");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MetaKeys(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MetaKeys");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MetaValues(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MetaValues");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new MetaEntries(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "MetaEntries");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DefaultTokenizer(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DefaultTokenizer");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CommonLispTokenizer(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CommonLispTokenizer");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new XmlTokenizer(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "XmlTokenizer");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new XmlExplodeTag(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "XmlExplodeTag");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BuiltinAssoc(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Builtin'Assoc");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CurrentFile(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CurrentFile");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new CurrentLine(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "CurrentLine");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new BackQuote(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "`");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DumpNumber(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DumpNumber");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new InDebugMode(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "InDebugMode");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DebugFile(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DebugFile");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new DebugLine(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "DebugLine");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Version(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Version");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new Exit(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Exit");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new ExitRequested(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsExitRequested");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new HistorySize(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "HistorySize");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new StackSize(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "StaSiz");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new IsPromptShown(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "IsPromptShown");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new AskUser(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "AskUser");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new TellUser(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "TellUser");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Time(aEnvironment), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Macro),
		        "Time");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new FileSize(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "FileSize");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.SystemTimer(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "SystemTimer");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Break(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Break");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Continue(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Continue");
		/*aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.Return(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "Return");*/
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new org.mathpiper.builtin.functions.core.ViewConsole(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "ViewConsole");
		aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new RoundToN(), 2, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "RoundToN");
                aEnvironment.getBuiltinFunctions().setAssociation(
		        new BuiltinFunctionEvaluator(new GlobalVariablesGet(), 0, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
		        "GlobalVariablesGet");
                aEnvironment.getBuiltinFunctions().setAssociation(
                        new BuiltinFunctionEvaluator(new JavaAccess(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                        "JavaAccess");
                aEnvironment.getBuiltinFunctions().setAssociation(
                    new BuiltinFunctionEvaluator(new JavaCall(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                    "JavaCall");
                aEnvironment.getBuiltinFunctions().setAssociation(
                    new BuiltinFunctionEvaluator(new JavaNew(), 1, BuiltinFunctionEvaluator.Variable | BuiltinFunctionEvaluator.Function),
                    "JavaNew");
                aEnvironment.getBuiltinFunctions().setAssociation(
                    new BuiltinFunctionEvaluator(new JavaToValue(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                    "JavaToValue");
                aEnvironment.getBuiltinFunctions().setAssociation(
                    new BuiltinFunctionEvaluator(new Delay(), 1, BuiltinFunctionEvaluator.Fixed | BuiltinFunctionEvaluator.Function),
                    "Delay");

	}//end method.




	public static String[] getResourceListing(Class loadedClass, String path) throws URISyntaxException, IOException {

            InputStream inputStream = loadedClass.getClassLoader().getResourceAsStream(path + "plugins_list.txt");

            if(inputStream == null)
            {
                return null;
            }

            BufferedReader pluginListFileReader =  new BufferedReader(new InputStreamReader(inputStream));



            java.util.Set result = new HashSet();

            String name = null;
            while ((name = pluginListFileReader.readLine()) != null) {
                    name = name.trim();
                    result.add(name);
            }
            return result.toArray(new String[result.size()]);




/*		URL dirURL = loadedClass.getClassLoader().getResource(path);
		if (dirURL != null && dirURL.getProtocol().equals("file")) {

			return new File(dirURL.toURI()).list();
		}

		if (dirURL == null) {

			String loadedClassName = loadedClass.getName().replace(".", "/") + ".class";
			dirURL = loadedClass.getClassLoader().getResource(loadedClassName);
		}


		if (dirURL.getProtocol().equals("jar")) {

			String jarPath = dirURL.getPath().substring(5, dirURL.getPath().indexOf("!"));

			JarFile jar = new JarFile(URLDecoder.decode(jarPath, "UTF-8"));

			Enumeration entries = jar.entries();

			java.util.Set result = new HashSet();

			while (entries.hasMoreElements()) {
				String name = entries.nextElement().getName();
				if (name.startsWith(path)) {
					String entry = name.substring(path.length());
					int checkSubdirectory = entry.indexOf("/");
					if (checkSubdirectory >= 0) {

						entry = entry.substring(0, checkSubdirectory);
					}
					result.add(entry);
				}
			}
			return result.toArray(new String[result.size()]);
		}//end if.

		if (dirURL.getProtocol().equals("jeditresource")) {

			try {

				Class jEditJARClassLoaderClass = BuiltinFunction.class.getClassLoader().getClass();

				if (jEditJARClassLoaderClass != null) {

					Method method = jEditJARClassLoaderClass.getMethod("getZipFile", new java.lang.Class[0]);

					ZipFile zipFile = (ZipFile) method.invoke(BuiltinFunction.class.getClassLoader(), new Object[0]);

					Enumeration entries = zipFile.entries();

					java.util.Set result = new HashSet();

					while (entries.hasMoreElements()) {
						ZipEntry zipEntry = (ZipEntry) entries.nextElement();
						String name =  zipEntry.getName();
						if (name.startsWith(path)) {
							String entry = name.substring(path.length());
							int checkSubdirectory = entry.indexOf("/");
							if (checkSubdirectory >= 0) {

								entry = entry.substring(0, checkSubdirectory);
							}
							result.add(entry);
						}
					}
					return result.toArray(new String[result.size()]);

				}//end if.


			} catch (NoSuchMethodException nsme) {
				nsme.printStackTrace();
			} catch (IllegalAccessException iae) {
				iae.printStackTrace();
			} catch(java.lang.reflect.InvocationTargetException ite){
				ite.printStackTrace();
			}catch (NoClassDefFoundError ncdfe) {
				ncdfe.printStackTrace();
			}


		}//end if.


		throw new UnsupportedOperationException("Cannot list files for URL " + dirURL);
 * */
	}//end method.


}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/0000755000175000017500000000000011722677320024632 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/cern/0000755000175000017500000000000011722677320025561 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/cern/Constants.java0000644000175000017500000000472011302167404030372 0ustar  giovannigiovanni/*
Copyright © 1999 CERN - European Organization for Nuclear Research.
Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose
is hereby granted without fee, provided that the above copyright notice appear in all copies and
that both that copyright notice and this permission notice appear in supporting documentation.
CERN makes no representations about the suitability of this software for any purpose.
It is provided "as is" without expressed or implied warranty.
*/

package org.mathpiper.builtin.library.cern;

/**
 * Defines some useful constants.
 */
public class Constants {
  /*
   * machine constants
   */
	protected static final double MACHEP =  1.11022302462515654042E-16;
	protected static final double MAXLOG =  7.09782712893383996732E2;
	protected static final double MINLOG = -7.451332191019412076235E2;
	protected static final double MAXGAM = 171.624376956302725;
	protected static final double SQTPI  =  2.50662827463100050242E0;
	protected static final double SQRTH  =  7.07106781186547524401E-1;
	protected static final double LOGPI  =  1.14472988584940017414;

	protected static final double big = 4.503599627370496e15;
	protected static final double biginv =  2.22044604925031308085e-16;


	/*
 * MACHEP =  1.38777878078144567553E-17       2**-56
 * MAXLOG =  8.8029691931113054295988E1       log(2**127)
 * MINLOG = -8.872283911167299960540E1        log(2**-128)
 * MAXNUM =  1.701411834604692317316873e38    2**127
 *
 * For IEEE arithmetic (IBMPC):
 * MACHEP =  1.11022302462515654042E-16       2**-53
 * MAXLOG =  7.09782712893383996843E2         log(2**1024)
 * MINLOG = -7.08396418532264106224E2         log(2**-1022)
 * MAXNUM =  1.7976931348623158E308           2**1024
 *
 * The global symbols for mathematical constants are
 * PI     =  3.14159265358979323846           pi
 * PIO2   =  1.57079632679489661923           pi/2
 * PIO4   =  7.85398163397448309616E-1        pi/4
 * SQRT2  =  1.41421356237309504880           sqrt(2)
 * SQRTH  =  7.07106781186547524401E-1        sqrt(2)/2
 * LOG2E  =  1.4426950408889634073599         1/log(2)
 * SQ2OPI =  7.9788456080286535587989E-1      sqrt( 2/pi )
 * LOGE2  =  6.93147180559945309417E-1        log(2)
 * LOGSQ2 =  3.46573590279972654709E-1        log(2)/2
 * THPIO4 =  2.35619449019234492885           3*pi/4
 * TWOOPI =  6.36619772367581343075535E-1     2/pi
 */

/**
 * Makes this class non instantiable, but still let's others inherit from it.
 */
protected Constants() {}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/cern/Gamma.java0000644000175000017500000003514011302167404027440 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.cern;

/*
Copyright © 1999 CERN - European Organization for Nuclear Research.
Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose
is hereby granted without fee, provided that the above copyright notice appear in all copies and
that both that copyright notice and this permission notice appear in supporting documentation.
CERN makes no representations about the suitability of this software for any purpose.
It is provided "as is" without expressed or implied warranty.
*/


/**
 * Gamma and Beta functions.
 * 
    
 * Implementation:
 * 
    
 * Some code taken and adapted from the Java 2D Graph Package 2.4,
 * which in turn is a port from the Cephes 2.2 Math Library (C).
 * Most Cephes code (missing from the 2D Graph Package) directly ported.
 *
 * @author wolfgang.hoschek@cern.ch
 * @version 0.9, 22-Jun-99
 */
public class Gamma  extends Constants {
/**
 * Makes this class non instantiable, but still let's others inherit from it.
 */
protected Gamma() {}
/**
 * Returns the beta function of the arguments.
 * 
     *                   -     -
 *                  | (a) | (b)
 * beta( a, b )  =  -----------.
 *                     -
 *                    | (a+b)
 * 
    
 */
static public double beta(double a, double b) throws ArithmeticException {
	double y;

	y = a + b;
	y = gamma(y);
	if( y == 0.0 ) return 1.0;

	if( a > b ) {
		y = gamma(a)/y;
		y *= gamma(b);
	}
	else {
		y = gamma(b)/y;
		y *= gamma(a);
	}

	return(y);
}
/**
 * Returns the Gamma function of the argument.
 */
static public double gamma(double x) throws ArithmeticException {

double P[] = {
			   1.60119522476751861407E-4,
			   1.19135147006586384913E-3,
			   1.04213797561761569935E-2,
			   4.76367800457137231464E-2,
			   2.07448227648435975150E-1,
			   4.94214826801497100753E-1,
			   9.99999999999999996796E-1
			  };
double Q[] = {
			   -2.31581873324120129819E-5,
				5.39605580493303397842E-4,
			   -4.45641913851797240494E-3,
				1.18139785222060435552E-2,
				3.58236398605498653373E-2,
			   -2.34591795718243348568E-1,
				7.14304917030273074085E-2,
				1.00000000000000000320E0
			   };
//double MAXGAM = 171.624376956302725;
//double LOGPI  = 1.14472988584940017414;

double p, z;
int i;

double q = Math.abs(x);

if( q > 33.0 ) {
   if( x < 0.0 ) {
		p = Math.floor(q);
	if( p == q ) throw new ArithmeticException("gamma: overflow");
	i = (int)p;
	z = q - p;
	if( z > 0.5 ) {
		p += 1.0;
		z = q - p;
	}
	z = q * Math.sin( Math.PI * z );
	if( z == 0.0 ) throw new ArithmeticException("gamma: overflow");
	z = Math.abs(z);
	z = Math.PI/(z * stirlingFormula(q) );

		return -z;
   } else {
	return stirlingFormula(x);
   }
 }

 z = 1.0;
   while( x >= 3.0 ) {
  	     x -= 1.0;
	 z *= x;
   }

   while( x < 0.0 ) {
	 if( x == 0.0 ) {
			throw new ArithmeticException("gamma: singular");
		 } else
	 if( x > -1.E-9 ) {
			 return( z/((1.0 + 0.5772156649015329 * x) * x) );
		 }
	 z /= x;
	 x += 1.0;
   }

   while( x < 2.0 ) {
	 if( x == 0.0 ) {
			throw new ArithmeticException("gamma: singular");
		 } else
	 if( x < 1.e-9 ) {
  	        return( z/((1.0 + 0.5772156649015329 * x) * x) );
		 }
	 z /= x;
	 x += 1.0;
}

	if( (x == 2.0) || (x == 3.0) ) 	return z;

	x -= 2.0;
	p = Polynomial.polevl( x, P, 6 );
	q = Polynomial.polevl( x, Q, 7 );
	return  z * p / q;

}
/**
 * Returns the Incomplete Beta Function evaluated from zero to xx; formerly named ibeta.
 *
 * @param aa the alpha parameter of the beta distribution.
 * @param bb the beta parameter of the beta distribution.
 * @param xx the integration end point.
 */
public static double incompleteBeta( double aa, double bb, double xx ) throws ArithmeticException {
		double a, b, t, x, xc, w, y;
		boolean flag;

		if( aa <= 0.0 || bb <= 0.0 ) throw new
						  ArithmeticException("ibeta: Domain error!");

		if( (xx <= 0.0) || ( xx >= 1.0) ) {
  	       if( xx == 0.0 ) return 0.0;
   	       if( xx == 1.0 ) return 1.0;
		   throw new ArithmeticException("ibeta: Domain error!");
	    }

		flag = false;
		if( (bb * xx) <= 1.0 && xx <= 0.95) {
	        t = powerSeries(aa, bb, xx);
		    return t;
	    }

		w = 1.0 - xx;

		/* Reverse a and b if x is greater than the mean. */
		if( xx > (aa/(aa+bb)) ) {
	       flag = true;
	       a = bb;
	       b = aa;
	       xc = xx;
	       x = w;
	    } else {
  	       a = aa;
	       b = bb;
	       xc = w;
	       x = xx;
	    }

		if( flag  && (b * x) <= 1.0 && x <= 0.95) {
 	       t = powerSeries(a, b, x);
	       if( t <= MACHEP ) 	t = 1.0 - MACHEP;
	       else  		        t = 1.0 - t;
		   return t;
	    }

		/* Choose expansion for better convergence. */
		y = x * (a+b-2.0) - (a-1.0);
		if( y < 0.0 )
	                  w = incompleteBetaFraction1( a, b, x );
		else
	                  w = incompleteBetaFraction2( a, b, x ) / xc;

		/* Multiply w by the factor
		   a      b   _             _     _
		  x  (1-x)   | (a+b) / ( a | (a) | (b) ) .   */

		y = a * Math.log(x);
		t = b * Math.log(xc);
		if( (a+b) < MAXGAM && Math.abs(y) < MAXLOG && Math.abs(t) < MAXLOG ) {
	        t = Math.pow(xc,b);
	        t *= Math.pow(x,a);
	        t /= a;
	        t *= w;
	        t *= gamma(a+b) / (gamma(a) * gamma(b));
			if( flag ) {
 	           if( t <= MACHEP ) 	t = 1.0 - MACHEP;
	           else  		        t = 1.0 - t;
	        }
			return t;
	    }
		/* Resort to logarithms.  */
		y += t + logGamma(a+b) - logGamma(a) - logGamma(b);
		y += Math.log(w/a);
		if( y < MINLOG )
	                    t = 0.0;
		else
	                    t = Math.exp(y);

		if( flag ) {
 	           if( t <= MACHEP ) 	t = 1.0 - MACHEP;
	           else  		        t = 1.0 - t;
	    }
		return t;
   }
/**
 * Continued fraction expansion #1 for incomplete beta integral; formerly named incbcf.
 */
static double incompleteBetaFraction1( double a, double b, double x ) throws ArithmeticException {
	   double xk, pk, pkm1, pkm2, qk, qkm1, qkm2;
	   double k1, k2, k3, k4, k5, k6, k7, k8;
	   double r, t, ans, thresh;
	   int n;

	   k1 = a;
	   k2 = a + b;
	   k3 = a;
	   k4 = a + 1.0;
	   k5 = 1.0;
	   k6 = b - 1.0;
	   k7 = k4;
	   k8 = a + 2.0;

	   pkm2 = 0.0;
	   qkm2 = 1.0;
	   pkm1 = 1.0;
	   qkm1 = 1.0;
	   ans = 1.0;
	   r = 1.0;
	   n = 0;
	   thresh = 3.0 * MACHEP;
	   do {
	      xk = -( x * k1 * k2 )/( k3 * k4 );
	      pk = pkm1 +  pkm2 * xk;
	      qk = qkm1 +  qkm2 * xk;
	      pkm2 = pkm1;
	      pkm1 = pk;
	      qkm2 = qkm1;
	      qkm1 = qk;

	      xk = ( x * k5 * k6 )/( k7 * k8 );
	      pk = pkm1 +  pkm2 * xk;
	      qk = qkm1 +  qkm2 * xk;
	      pkm2 = pkm1;
	      pkm1 = pk;
	      qkm2 = qkm1;
	      qkm1 = qk;

	      if( qk != 0 )		r = pk/qk;
	      if( r != 0 ) {
		       t = Math.abs( (ans - r)/r );
		       ans = r;
		  }	else
		       t = 1.0;

	      if( t < thresh ) return ans;

	      k1 += 1.0;
		  k2 += 1.0;
	  	  k3 += 2.0;
	  	  k4 += 2.0;
	  	  k5 += 1.0;
	  	  k6 -= 1.0;
	  	  k7 += 2.0;
	  	  k8 += 2.0;

	  	  if( (Math.abs(qk) + Math.abs(pk)) > big ) {
	  		pkm2 *= biginv;
	  		pkm1 *= biginv;
	  		qkm2 *= biginv;
	  		qkm1 *= biginv;
		  }
	  	  if( (Math.abs(qk) < biginv) || (Math.abs(pk) < biginv) ) {
	  		pkm2 *= big;
	  		pkm1 *= big;
	  		qkm2 *= big;
	  		qkm1 *= big;
		  }
	   } while( ++n < 300 );

	return ans;
   }
/**
 * Continued fraction expansion #2 for incomplete beta integral; formerly named incbd.
 */
static double incompleteBetaFraction2( double a, double b, double x ) throws ArithmeticException {
		 double xk, pk, pkm1, pkm2, qk, qkm1, qkm2;
		 double k1, k2, k3, k4, k5, k6, k7, k8;
		 double r, t, ans, z, thresh;
		 int n;

		 k1 = a;
		 k2 = b - 1.0;
		 k3 = a;
		 k4 = a + 1.0;
		 k5 = 1.0;
		 k6 = a + b;
		 k7 = a + 1.0;
		 k8 = a + 2.0;

		 pkm2 = 0.0;
		 qkm2 = 1.0;
		 pkm1 = 1.0;
		 qkm1 = 1.0;
		 z = x / (1.0-x);
		 ans = 1.0;
		 r = 1.0;
		 n = 0;
		 thresh = 3.0 * MACHEP;
		 do {
	         xk = -( z * k1 * k2 )/( k3 * k4 );
	         pk = pkm1 +  pkm2 * xk;
	         qk = qkm1 +  qkm2 * xk;
	         pkm2 = pkm1;
	         pkm1 = pk;
	         qkm2 = qkm1;
	         qkm1 = qk;

	         xk = ( z * k5 * k6 )/( k7 * k8 );
	         pk = pkm1 +  pkm2 * xk;
	         qk = qkm1 +  qkm2 * xk;
	         pkm2 = pkm1;
	         pkm1 = pk;
	         qkm2 = qkm1;
	         qkm1 = qk;

	         if( qk != 0 )  r = pk/qk;
	         if( r != 0 ) {
		         t = Math.abs( (ans - r)/r );
		         ans = r;
		     } else
		         t = 1.0;

	         if( t < thresh ) return ans;

	         k1 += 1.0;
	         k2 -= 1.0;
	         k3 += 2.0;
	         k4 += 2.0;
	         k5 += 1.0;
	         k6 += 1.0;
	         k7 += 2.0;
	         k8 += 2.0;

	         if( (Math.abs(qk) + Math.abs(pk)) > big ) {
		        pkm2 *= biginv;
		        pkm1 *= biginv;
		        qkm2 *= biginv;
		        qkm1 *= biginv;
		     }
	         if( (Math.abs(qk) < biginv) || (Math.abs(pk) < biginv) ) {
		        pkm2 *= big;
		        pkm1 *= big;
		        qkm2 *= big;
		        qkm1 *= big;
		     }
	    } while( ++n < 300 );

		return ans;
	 }
/**
 * Returns the Incomplete Gamma function; formerly named igamma.
 * @param a the parameter of the gamma distribution.
 * @param x the integration end point.
 */
static public double incompleteGamma(double a, double x)
						 throws ArithmeticException {


		double ans, ax, c, r;

		if( x <= 0 || a <= 0 ) return 0.0;

		if( x > 1.0 && x > a ) return 1.0 - incompleteGammaComplement(a,x);

	   /* Compute  x**a * exp(-x) / gamma(a)  */
		ax = a * Math.log(x) - x - logGamma(a);
		if( ax < -MAXLOG ) return( 0.0 );

		ax = Math.exp(ax);

		/* power series */
		r = a;
		c = 1.0;
		ans = 1.0;

		do {
  	    r += 1.0;
	    c *= x/r;
	    ans += c;
	}
		while( c/ans > MACHEP );

		return( ans * ax/a );

	 }
/**
 * Returns the Complemented Incomplete Gamma function; formerly named igamc.
 * @param a the parameter of the gamma distribution.
 * @param x the integration start point.
 */
static public double incompleteGammaComplement( double a, double x ) throws ArithmeticException {
		double ans, ax, c, yc, r, t, y, z;
		double pk, pkm1, pkm2, qk, qkm1, qkm2;

		if( x <= 0 || a <= 0 ) return 1.0;

		if( x < 1.0 || x < a ) return 1.0 - incompleteGamma(a,x);

		ax = a * Math.log(x) - x - logGamma(a);
		if( ax < -MAXLOG ) return 0.0;

		ax = Math.exp(ax);

		/* continued fraction */
		y = 1.0 - a;
		z = x + y + 1.0;
		c = 0.0;
		pkm2 = 1.0;
		qkm2 = x;
		pkm1 = x + 1.0;
		qkm1 = z * x;
		ans = pkm1/qkm1;

		do {
  	    c += 1.0;
	    y += 1.0;
	    z += 2.0;
	    yc = y * c;
	    pk = pkm1 * z  -  pkm2 * yc;
	    qk = qkm1 * z  -  qkm2 * yc;
	    if( qk != 0 ) {
		r = pk/qk;
		t = Math.abs( (ans - r)/r );
		ans = r;
	    } else
		t = 1.0;

	    pkm2 = pkm1;
	    pkm1 = pk;
	    qkm2 = qkm1;
	    qkm1 = qk;
	    if( Math.abs(pk) > big ) {
		pkm2 *= biginv;
		pkm1 *= biginv;
		qkm2 *= biginv;
		qkm1 *= biginv;
	    }
	} while( t > MACHEP );

		return ans * ax;
	 }
/**
 * Returns the natural logarithm of the gamma function; formerly named lgamma.
 */
public static double logGamma(double x) throws ArithmeticException {
	double p, q, w, z;

		 double A[] = {
					   8.11614167470508450300E-4,
					   -5.95061904284301438324E-4,
						7.93650340457716943945E-4,
					   -2.77777777730099687205E-3,
						8.33333333333331927722E-2
					   };
		 double B[] = {
					   -1.37825152569120859100E3,
					   -3.88016315134637840924E4,
					   -3.31612992738871184744E5,
					   -1.16237097492762307383E6,
					   -1.72173700820839662146E6,
					   -8.53555664245765465627E5
					   };
		 double C[] = {
					   /* 1.00000000000000000000E0, */
					   -3.51815701436523470549E2,
					   -1.70642106651881159223E4,
					   -2.20528590553854454839E5,
					   -1.13933444367982507207E6,
					   -2.53252307177582951285E6,
					   -2.01889141433532773231E6
					  };

		 if( x < -34.0 ) {
  	   q = -x;
	   w = logGamma(q);
	   p = Math.floor(q);
	   if( p == q ) throw new ArithmeticException("lgam: Overflow");
	   z = q - p;
	   if( z > 0.5 ) {
		p += 1.0;
		z = p - q;
 	   }
	   z = q * Math.sin( Math.PI * z );
	   if( z == 0.0 ) throw new
							   ArithmeticException("lgamma: Overflow");
	   z = LOGPI - Math.log( z ) - w;
	   return z;
	 }

		 if( x < 13.0 ) {
  	   z = 1.0;
	   while( x >= 3.0 ) {
		x -= 1.0;
		z *= x;
	   }
	   while( x < 2.0 ) {
		if( x == 0.0 ) throw new
								ArithmeticException("lgamma: Overflow");
		z /= x;
		x += 1.0;
	   }
	   if( z < 0.0 ) z = -z;
	   if( x == 2.0 ) return Math.log(z);
	   x -= 2.0;
	   p = x * Polynomial.polevl( x, B, 5 ) / Polynomial.p1evl( x, C, 6);
 	   return( Math.log(z) + p );
	 }

		 if( x > 2.556348e305 ) throw new
						  ArithmeticException("lgamma: Overflow");

		 q = ( x - 0.5 ) * Math.log(x) - x + 0.91893853320467274178;
		 //if( x > 1.0e8 ) return( q );
		 if( x > 1.0e8 ) return( q );

		 p = 1.0/(x*x);
		 if( x >= 1000.0 )
	     q += ((   7.9365079365079365079365e-4 * p
		      - 2.7777777777777777777778e-3) *p
		     + 0.0833333333333333333333) / x;
		 else
	     q += Polynomial.polevl( p, A, 4 ) / x;
		 return q;
	 }
/**
 * Power series for incomplete beta integral; formerly named pseries.
 * Use when b*x is small and x not too close to 1.
 */
static double powerSeries( double a, double b, double x ) throws ArithmeticException {
	double s, t, u, v, n, t1, z, ai;

	ai = 1.0 / a;
	u = (1.0 - b) * x;
	v = u / (a + 1.0);
	t1 = v;
	t = u;
	n = 2.0;
	s = 0.0;
	z = MACHEP * ai;
	while( Math.abs(v) > z ) {
	       u = (n - b) * x / n;
	       t *= u;
	       v = t / (a + n);
	       s += v;
	       n += 1.0;
	    }
	s += t1;
	s += ai;

	u = a * Math.log(x);
	if( (a+b) < MAXGAM && Math.abs(u) < MAXLOG ) {
	        t = Gamma.gamma(a+b)/(Gamma.gamma(a)*Gamma.gamma(b));
	        s = s * t * Math.pow(x,a);
	    } else {
	       t = Gamma.logGamma(a+b) - Gamma.logGamma(a) - Gamma.logGamma(b) + u + Math.log(s);
	       if( t < MINLOG ) 	s = 0.0;
	       else  	            s = Math.exp(t);
	    }
	return s;
}
/**
 * Returns the Gamma function computed by Stirling's formula; formerly named stirf.
 * The polynomial STIR is valid for 33 <= x <= 172.
 */
static double stirlingFormula(double x) throws ArithmeticException {
		double STIR[] = {
					 7.87311395793093628397E-4,
					-2.29549961613378126380E-4,
					-2.68132617805781232825E-3,
					 3.47222221605458667310E-3,
					 8.33333333333482257126E-2,
					};
		double MAXSTIR = 143.01608;

		double w = 1.0/x;
		double  y = Math.exp(x);

		w = 1.0 + w * Polynomial.polevl( w, STIR, 4 );

		if( x > MAXSTIR ) {
	       /* Avoid overflow in Math.pow() */
	       double v = Math.pow( x, 0.5 * x - 0.25 );
	       y = v * (v / y);
	} else {
			   y = Math.pow( x, x - 0.5 ) / y;
	}
		y = SQTPI * y * w;
		return y;
	 }
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/cern/Probability.java0000644000175000017500000005613511302167404030705 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.cern;

/*
Copyright © 1999 CERN - European Organization for Nuclear Research.
Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose
is hereby granted without fee, provided that the above copyright notice appear in all copies and
that both that copyright notice and this permission notice appear in supporting documentation.
CERN makes no representations about the suitability of this software for any purpose.
It is provided "as is" without expressed or implied warranty.
*/



/**
 * Custom tailored numerical integration of certain probability distributions.
 * 
    
 * Implementation:
 * 
    
 * Some code taken and adapted from the Java 2D Graph Package 2.4,
 * which in turn is a port from the Cephes 2.2 Math Library (C).
 * Most Cephes code (missing from the 2D Graph Package) directly ported.
 *
 * @author peter.gedeck@pharma.Novartis.com
 * @author wolfgang.hoschek@cern.ch
 * @version 0.91, 08-Dec-99
 */
public class Probability extends Constants {
	/*************************************************
	 *    COEFFICIENTS FOR METHOD  normalInverse()   *
	 *************************************************/
	/* approximation for 0 <= |y - 0.5| <= 3/8 */
	protected static final double P0[] = {
		-5.99633501014107895267E1,
		 9.80010754185999661536E1,
		-5.66762857469070293439E1,
		 1.39312609387279679503E1,
		-1.23916583867381258016E0,
		};
	protected static final double Q0[] = {
		/* 1.00000000000000000000E0,*/
		 1.95448858338141759834E0,
		 4.67627912898881538453E0,
		 8.63602421390890590575E1,
		-2.25462687854119370527E2,
		 2.00260212380060660359E2,
		-8.20372256168333339912E1,
		 1.59056225126211695515E1,
		-1.18331621121330003142E0,
		};


	/* Approximation for interval z = sqrt(-2 log y ) between 2 and 8
	 * i.e., y between exp(-2) = .135 and exp(-32) = 1.27e-14.
	 */
	protected static final double P1[] = {
		 4.05544892305962419923E0,
		 3.15251094599893866154E1,
		 5.71628192246421288162E1,
		 4.40805073893200834700E1,
		 1.46849561928858024014E1,
		 2.18663306850790267539E0,
		-1.40256079171354495875E-1,
		-3.50424626827848203418E-2,
		-8.57456785154685413611E-4,
		};
	protected static final double Q1[] = {
		/*  1.00000000000000000000E0,*/
		 1.57799883256466749731E1,
		 4.53907635128879210584E1,
		 4.13172038254672030440E1,
		 1.50425385692907503408E1,
		 2.50464946208309415979E0,
		-1.42182922854787788574E-1,
		-3.80806407691578277194E-2,
		-9.33259480895457427372E-4,
		};

	/* Approximation for interval z = sqrt(-2 log y ) between 8 and 64
	 * i.e., y between exp(-32) = 1.27e-14 and exp(-2048) = 3.67e-890.
	 */
	protected static final double  P2[] = {
		  3.23774891776946035970E0,
		  6.91522889068984211695E0,
		  3.93881025292474443415E0,
		  1.33303460815807542389E0,
		  2.01485389549179081538E-1,
		  1.23716634817820021358E-2,
		  3.01581553508235416007E-4,
		  2.65806974686737550832E-6,
		  6.23974539184983293730E-9,
		};
	protected static final double  Q2[] = {
		/*  1.00000000000000000000E0,*/
		  6.02427039364742014255E0,
		  3.67983563856160859403E0,
		  1.37702099489081330271E0,
		  2.16236993594496635890E-1,
		  1.34204006088543189037E-2,
		  3.28014464682127739104E-4,
		  2.89247864745380683936E-6,
		  6.79019408009981274425E-9,
		};

/**
 * Makes this class non instantiable, but still let's others inherit from it.
 */
protected Probability() {}
/**
 * Returns the area from zero to x under the beta density
 * function.
 * 
     *                          x
 *            -             -
 *           | (a+b)       | |  a-1      b-1
 * P(x)  =  ----------     |   t    (1-t)    dt
 *           -     -     | |
 *          | (a) | (b)   -
 *                         0
 * 
    
 * This function is identical to the incomplete beta
 * integral function Gamma.incompleteBeta(a, b, x).
 *
 * The complemented function is
 *
 * 1 - P(1-x)  =  Gamma.incompleteBeta( b, a, x );
 *
 */
static public double beta(double a, double b, double x ) {
	return Gamma.incompleteBeta( a, b, x );
}
/**
 * Returns the area under the right hand tail (from x to
 * infinity) of the beta density function.
 *
 * This function is identical to the incomplete beta
 * integral function Gamma.incompleteBeta(b, a, x).
 */
static public double betaComplemented(double a, double b, double x ) {
	return Gamma.incompleteBeta( b, a, x );
}
/**
 * Returns the sum of the terms 0 through k of the Binomial
 * probability density.
 * 
     *   k
 *   --  ( n )   j      n-j
 *   >   (   )  p  (1-p)
 *   --  ( j )
 *  j=0
 * 
    
 * The terms are not summed directly; instead the incomplete
 * beta integral is employed, according to the formula
 * 
    
 * y = binomial( k, n, p ) = Gamma.incompleteBeta( n-k, k+1, 1-p ).
 * 
    
 * All arguments must be positive,
 * @param k end term.
 * @param n the number of trials.
 * @param p the probability of success (must be in (0.0,1.0)).
 */
static public double binomial(int k, int n, double p) {
	if( (p < 0.0) || (p > 1.0) ) throw new IllegalArgumentException();
	if( (k < 0) || (n < k) ) throw new IllegalArgumentException();

	if( k == n ) return( 1.0 );
	if( k == 0 ) return Math.pow( 1.0-p, n-k );

	return Gamma.incompleteBeta( n-k, k+1, 1.0 - p );
}
/**
 * Returns the sum of the terms k+1 through n of the Binomial
 * probability density.
 * 
     *   n
 *   --  ( n )   j      n-j
 *   >   (   )  p  (1-p)
 *   --  ( j )
 *  j=k+1
 * 
    
 * The terms are not summed directly; instead the incomplete
 * beta integral is employed, according to the formula
 * 
    
 * y = binomialComplemented( k, n, p ) = Gamma.incompleteBeta( k+1, n-k, p ).
 * 
    
 * All arguments must be positive,
 * @param k end term.
 * @param n the number of trials.
 * @param p the probability of success (must be in (0.0,1.0)).
 */
static public double binomialComplemented(int k, int n, double p) {
	if( (p < 0.0) || (p > 1.0) ) throw new IllegalArgumentException();
	if( (k < 0) || (n < k) ) throw new IllegalArgumentException();

	if( k == n ) return( 0.0 );
	if( k == 0 ) return 1.0 - Math.pow( 1.0-p, n-k );

	return Gamma.incompleteBeta( k+1, n-k, p );
}
/**
 * Returns the area under the left hand tail (from 0 to x)
 * of the Chi square probability density function with
 * v degrees of freedom.
 * 
     *                                  inf.
 *                                    -
 *                        1          | |  v/2-1  -t/2
 *  P( x | v )   =   -----------     |   t      e     dt
 *                    v/2  -       | |
 *                   2    | (v/2)   -
 *                                   x
 * 
    
 * where x is the Chi-square variable.
 * 
    
 * The incomplete gamma integral is used, according to the
 * formula
 * 
    
 * y = chiSquare( v, x ) = incompleteGamma( v/2.0, x/2.0 ).
 * 
    
 * The arguments must both be positive.
 *
 * @param v degrees of freedom.
 * @param x integration end point.
 */
static public double chiSquare(double v, double x) throws ArithmeticException {
	if( x < 0.0 || v < 1.0 ) return 0.0;
	return Gamma.incompleteGamma( v/2.0, x/2.0 );
}
/**
 * Returns the area under the right hand tail (from x to
 * infinity) of the Chi square probability density function
 * with v degrees of freedom.
 * 
     *                                  inf.
 *                                    -
 *                        1          | |  v/2-1  -t/2
 *  P( x | v )   =   -----------     |   t      e     dt
 *                    v/2  -       | |
 *                   2    | (v/2)   -
 *                                   x
 * 
    
 * where x is the Chi-square variable.
 *
 * The incomplete gamma integral is used, according to the
 * formula
 *
 * y = chiSquareComplemented( v, x ) = incompleteGammaComplement( v/2.0, x/2.0 ).
 *
 *
 * The arguments must both be positive.
 *
 * @param v degrees of freedom.
 */
static public double chiSquareComplemented(double v, double x) throws ArithmeticException {
	if( x < 0.0 || v < 1.0 ) return 0.0;
	return Gamma.incompleteGammaComplement( v/2.0, x/2.0 );
}
/**
 * Returns the error function of the normal distribution; formerly named erf.
 * The integral is
 * 
     *                           x
 *                            -
 *                 2         | |          2
 *   erf(x)  =  --------     |    exp( - t  ) dt.
 *              sqrt(pi)   | |
 *                          -
 *                           0
 * 
    
 * Implementation:
 * For 0 <= |x| < 1, erf(x) = x * P4(x**2)/Q5(x**2); otherwise
 * erf(x) = 1 - erfc(x).
 * 
    
 * Code adapted from the Java 2D Graph Package 2.4,
 * which in turn is a port from the Cephes 2.2 Math Library (C).
 *
 * @param a the argument to the function.
 */
static public double errorFunction(double x) throws ArithmeticException {
	double y, z;
	final double T[] = {
					 9.60497373987051638749E0,
					 9.00260197203842689217E1,
					 2.23200534594684319226E3,
					 7.00332514112805075473E3,
					 5.55923013010394962768E4
					};
	final double U[] = {
				   //1.00000000000000000000E0,
					 3.35617141647503099647E1,
					 5.21357949780152679795E2,
					 4.59432382970980127987E3,
					 2.26290000613890934246E4,
					 4.92673942608635921086E4
					};

	if( Math.abs(x) > 1.0 ) return( 1.0 - errorFunctionComplemented(x) );
	z = x * x;
	y = x * Polynomial.polevl( z, T, 4 ) / Polynomial.p1evl( z, U, 5 );
	return y;
}
/**
 * Returns the complementary Error function of the normal distribution; formerly named erfc.
 * 
     *  1 - erf(x) =
 *
 *                           inf.
 *                             -
 *                  2         | |          2
 *   erfc(x)  =  --------     |    exp( - t  ) dt
 *               sqrt(pi)   | |
 *                           -
 *                            x
 * 
    
 * Implementation:
 * For small x, erfc(x) = 1 - erf(x); otherwise rational
 * approximations are computed.
 * 
    
 * Code adapted from the Java 2D Graph Package 2.4,
 * which in turn is a port from the Cephes 2.2 Math Library (C).
 *
 * @param a the argument to the function.
 */
static public double errorFunctionComplemented(double a) throws ArithmeticException {
	double x,y,z,p,q;

	double P[] = {
					 2.46196981473530512524E-10,
					 5.64189564831068821977E-1,
					 7.46321056442269912687E0,
					 4.86371970985681366614E1,
					 1.96520832956077098242E2,
					 5.26445194995477358631E2,
					 9.34528527171957607540E2,
					 1.02755188689515710272E3,
					 5.57535335369399327526E2
					};
	double Q[] = {
					//1.0
					  1.32281951154744992508E1,
					  8.67072140885989742329E1,
					  3.54937778887819891062E2,
					  9.75708501743205489753E2,
					  1.82390916687909736289E3,
					  2.24633760818710981792E3,
					  1.65666309194161350182E3,
					  5.57535340817727675546E2
					 };

	double R[] = {
					  5.64189583547755073984E-1,
					  1.27536670759978104416E0,
					  5.01905042251180477414E0,
					  6.16021097993053585195E0,
					  7.40974269950448939160E0,
					  2.97886665372100240670E0
					 };
	double S[] = {
					//1.00000000000000000000E0,
					  2.26052863220117276590E0,
					  9.39603524938001434673E0,
					  1.20489539808096656605E1,
					  1.70814450747565897222E1,
					  9.60896809063285878198E0,
					  3.36907645100081516050E0
					 };

	if( a < 0.0 )   x = -a;
	else            x = a;

	if( x < 1.0 )   return 1.0 - errorFunction(a);

	z = -a * a;

	if( z < -MAXLOG ) {
		 if( a < 0 )  return( 2.0 );
		 else         return( 0.0 );
	}

	z = Math.exp(z);

	if( x < 8.0 ) {
	  p = Polynomial.polevl( x, P, 8 );
	  q = Polynomial.p1evl( x, Q, 8 );
	} else {
	  p = Polynomial.polevl( x, R, 5 );
	  q = Polynomial.p1evl( x, S, 6 );
	}

	y = (z * p)/q;

	if( a < 0 ) y = 2.0 - y;

	if( y == 0.0 ) {
			if( a < 0 ) return 2.0;
			else        return( 0.0 );
	 }

	return y;
}
/**
 * Returns the integral from zero to x of the gamma probability
 * density function.
 * 
     *                x
 *        b       -
 *       a       | |   b-1  -at
 * y =  -----    |    t    e    dt
 *       -     | |
 *      | (b)   -
 *               0
 * 
    
 * The incomplete gamma integral is used, according to the
 * relation
 *
 * y = Gamma.incompleteGamma( b, a*x ).
 *
 * @param a the paramater a (alpha) of the gamma distribution.
 * @param b the paramater b (beta, lambda) of the gamma distribution.
 * @param x integration end point.
 */
static public double gamma(double a, double b, double x ) {
	if( x < 0.0 ) return 0.0;
	return Gamma.incompleteGamma(b, a*x);
}
/**
 * Returns the integral from x to infinity of the gamma
 * probability density function:
 * 
     *               inf.
 *        b       -
 *       a       | |   b-1  -at
 * y =  -----    |    t    e    dt
 *       -     | |
 *      | (b)   -
 *               x
 * 
    
 * The incomplete gamma integral is used, according to the
 * relation
 * 
    
 * y = Gamma.incompleteGammaComplement( b, a*x ).
 *
 * @param a the paramater a (alpha) of the gamma distribution.
 * @param b the paramater b (beta, lambda) of the gamma distribution.
 * @param x integration end point.
 */
static public double gammaComplemented(double a, double b, double x ) {
	if( x < 0.0 ) return 0.0;
	return Gamma.incompleteGammaComplement(b, a*x);
}
/**
 * Returns the sum of the terms 0 through k of the Negative Binomial Distribution.
 * 
     *   k
 *   --  ( n+j-1 )   n      j
 *   >   (       )  p  (1-p)
 *   --  (   j   )
 *  j=0
 * 
    
 * In a sequence of Bernoulli trials, this is the probability
 * that k or fewer failures precede the n-th success.
 * 
    
 * The terms are not computed individually; instead the incomplete
 * beta integral is employed, according to the formula
 * 
    
 * y = negativeBinomial( k, n, p ) = Gamma.incompleteBeta( n, k+1, p ).
 *
 * All arguments must be positive,
 * @param k end term.
 * @param n the number of trials.
 * @param p the probability of success (must be in (0.0,1.0)).
 */
static public double negativeBinomial(int k, int n, double p) {
	if( (p < 0.0) || (p > 1.0) ) throw new IllegalArgumentException();
	if(k < 0) return 0.0;

	return Gamma.incompleteBeta( n, k+1, p );
}
/**
 * Returns the sum of the terms k+1 to infinity of the Negative
 * Binomial distribution.
 * 
     *   inf
 *   --  ( n+j-1 )   n      j
 *   >   (       )  p  (1-p)
 *   --  (   j   )
 *  j=k+1
 * 
    
 * The terms are not computed individually; instead the incomplete
 * beta integral is employed, according to the formula
 * 
    
 * y = negativeBinomialComplemented( k, n, p ) = Gamma.incompleteBeta( k+1, n, 1-p ).
 *
 * All arguments must be positive,
 * @param k end term.
 * @param n the number of trials.
 * @param p the probability of success (must be in (0.0,1.0)).
 */
static public double negativeBinomialComplemented(int k, int n, double p) {
	if( (p < 0.0) || (p > 1.0) ) throw new IllegalArgumentException();
	if(k < 0) return 0.0;

	return Gamma.incompleteBeta( k+1, n, 1.0-p );
}
/**
 * Returns the area under the Normal (Gaussian) probability density
 * function, integrated from minus infinity to x (assumes mean is zero, variance is one).
 * 
     *                            x
 *                             -
 *                   1        | |          2
 *  normal(x)  = ---------    |    exp( - t /2 ) dt
 *               sqrt(2pi)  | |
 *                           -
 *                          -inf.
 *
 *             =  ( 1 + erf(z) ) / 2
 *             =  erfc(z) / 2
 * 
    
 * where z = x/sqrt(2).
 * Computation is via the functions errorFunction and errorFunctionComplement.
 */
static public double normal( double a) throws ArithmeticException {
	double x, y, z;

	x = a * SQRTH;
	z = Math.abs(x);

	if( z < SQRTH ) y = 0.5 + 0.5 * errorFunction(x);
	else {
		y = 0.5 * errorFunctionComplemented(z);
		if( x > 0 )  y = 1.0 - y;
	}

	return y;
}
/**
 * Returns the area under the Normal (Gaussian) probability density
 * function, integrated from minus infinity to x.
 * 
     *                            x
 *                             -
 *                   1        | |                 2
 *  normal(x)  = ---------    |    exp( - (t-mean) / 2v ) dt
 *               sqrt(2pi*v)| |
 *                           -
 *                          -inf.
 *
 * 
    
 * where v = variance.
 * Computation is via the functions errorFunction.
 *
 * @param mean the mean of the normal distribution.
 * @param variance the variance of the normal distribution.
 * @param x the integration limit.
 */
static public double normal(double mean, double variance, double x) throws ArithmeticException {
	if (x>0)
		return 0.5 + 0.5*errorFunction((x-mean)/Math.sqrt(2.0*variance));
	else
		return 0.5 - 0.5*errorFunction((-(x-mean))/Math.sqrt(2.0*variance));
}
/**
 * Returns the value, x, for which the area under the
 * Normal (Gaussian) probability density function (integrated from
 * minus infinity to x) is equal to the argument y (assumes mean is zero, variance is one); formerly named ndtri.
 * 
    
 * For small arguments 0 < y < exp(-2), the program computes
 * z = sqrt( -2.0 * log(y) );  then the approximation is
 * x = z - log(z)/z  - (1/z) P(1/z) / Q(1/z).
 * There are two rational functions P/Q, one for 0 < y < exp(-32)
 * and the other for y up to exp(-2).
 * For larger arguments,
 * w = y - 0.5, and  x/sqrt(2pi) = w + w**3 R(w**2)/S(w**2)).
 *
 */
static public double normalInverse( double y0) throws ArithmeticException {
	double x, y, z, y2, x0, x1;
	int code;

	final double s2pi = Math.sqrt(2.0*Math.PI);

	if( y0 <= 0.0 ) throw new IllegalArgumentException();
	if( y0 >= 1.0 ) throw new IllegalArgumentException();
	code = 1;
	y = y0;
	if( y > (1.0 - 0.13533528323661269189) ) { /* 0.135... = exp(-2) */
		y = 1.0 - y;
		code = 0;
	}

	if( y > 0.13533528323661269189 ) {
		y = y - 0.5;
		y2 = y * y;
		x = y + y * (y2 * Polynomial.polevl( y2, P0, 4)/Polynomial.p1evl( y2, Q0, 8 ));
		x = x * s2pi;
		return(x);
	}

	x = Math.sqrt( -2.0 * Math.log(y) );
	x0 = x - Math.log(x)/x;

	z = 1.0/x;
	if( x < 8.0 ) /* y > exp(-32) = 1.2664165549e-14 */
		x1 = z * Polynomial.polevl( z, P1, 8 )/Polynomial.p1evl( z, Q1, 8 );
	else
		x1 = z * Polynomial.polevl( z, P2, 8 )/Polynomial.p1evl( z, Q2, 8 );
	x = x0 - x1;
	if( code != 0 )
		x = -x;
	return( x );
}
/**
 * Returns the sum of the first k terms of the Poisson distribution.
 * 
     *   k         j
 *   --   -m  m
 *   >   e    --
 *   --       j!
 *  j=0
 * 
    
 * The terms are not summed directly; instead the incomplete
 * gamma integral is employed, according to the relation
 * 
    
 * y = poisson( k, m ) = Gamma.incompleteGammaComplement( k+1, m ).
 *
 * The arguments must both be positive.
 *
 * @param k number of terms.
 * @param mean the mean of the poisson distribution.
 */
static public double poisson(int k, double mean) throws ArithmeticException {
	if( mean < 0 ) throw new IllegalArgumentException();
	if( k < 0 ) return 0.0;
	return Gamma.incompleteGammaComplement((double)(k+1) ,mean);
}
/**
 * Returns the sum of the terms k+1 to Infinity of the Poisson distribution.
 * 
     *  inf.       j
 *   --   -m  m
 *   >   e    --
 *   --       j!
 *  j=k+1
 * 
    
 * The terms are not summed directly; instead the incomplete
 * gamma integral is employed, according to the formula
 * 
    
 * y = poissonComplemented( k, m ) = Gamma.incompleteGamma( k+1, m ).
 *
 * The arguments must both be positive.
 *
 * @param k start term.
 * @param mean the mean of the poisson distribution.
 */
static public double poissonComplemented(int k, double mean) throws ArithmeticException {
	if( mean < 0 ) throw new IllegalArgumentException();
	if( k < -1 ) return 0.0;
	return Gamma.incompleteGamma((double)(k+1),mean);
}
/**
 * Returns the integral from minus infinity to t of the Student-t
 * distribution with k > 0 degrees of freedom.
 * 
     *                                      t
 *                                      -
 *                                     | |
 *              -                      |         2   -(k+1)/2
 *             | ( (k+1)/2 )           |  (     x   )
 *       ----------------------        |  ( 1 + --- )        dx
 *                     -               |  (      k  )
 *       sqrt( k pi ) | ( k/2 )        |
 *                                   | |
 *                                    -
 *                                   -inf.
 * 
    
 * Relation to incomplete beta integral:
 * 
    
 * 1 - studentT(k,t) = 0.5 * Gamma.incompleteBeta( k/2, 1/2, z )
 * where z = k/(k + t**2).
 * 
    
 * Since the function is symmetric about t=0, the area under the
 * right tail of the density is found by calling the function
 * with -t instead of t.
 *
 * @param k degrees of freedom.
 * @param t integration end point.
 */
static public double studentT(double k, double t) throws ArithmeticException {
	if( k <= 0 ) throw new IllegalArgumentException();
	if( t == 0 ) return( 0.5 );

	double cdf = 0.5 * Gamma.incompleteBeta( 0.5*k, 0.5, k / (k + t * t) );

	if (t >= 0) cdf = 1.0 - cdf; // fixes bug reported by stefan.bentink@molgen.mpg.de

	return cdf;
}
/**
 * Returns the value, t, for which the area under the
 * Student-t probability density function (integrated from
 * minus infinity to t) is equal to 1-alpha/2.
 * The value returned corresponds to usual Student t-distribution lookup
 * table for talpha[size].
 * 
    
 * The function uses the studentT function to determine the return
 * value iteratively.
 *
 * @param alpha probability
 * @param size size of data set
 */
public static double studentTInverse(double alpha, int size) {
	 double cumProb = 1-alpha/2; // Cumulative probability
	 double f1,f2,f3;
	 double x1,x2,x3;
	 double g,s12;

	 cumProb = 1-alpha/2; // Cumulative probability
	 x1 = normalInverse(cumProb);

	 // Return inverse of normal for large size
	 if (size > 200) {
		return x1;
	 }

	 // Find a pair of x1,x2 that braket zero
	 f1 = studentT(size,x1)-cumProb;
	 x2 = x1; f2 = f1;
	 do {
		if (f1>0) {
		   x2 = x2/2;
		} else {
		   x2 = x2+x1;
		}
		f2 = studentT(size,x2)-cumProb;
	 } while (f1*f2>0);

	 // Find better approximation
	 // Pegasus-method
	 do {
		// Calculate slope of secant and t value for which it is 0.
		s12 = (f2-f1)/(x2-x1);
		x3 = x2 - f2/s12;

		// Calculate function value at x3
		f3 = studentT(size,x3)-cumProb;
		if (Math.abs(f3)<1e-8) { // This criteria needs to be very tight!
		   // We found a perfect value -> return
		   return x3;
		}

		if (f3*f2<0) {
		   x1=x2; f1=f2;
		   x2=x3; f2=f3;
		} else {
		   g = f2/(f2+f3);
		   f1=g*f1;
		   x2=x3; f2=f3;
		}
	 } while(Math.abs(x2-x1)>0.001);

	 if (Math.abs(f2)<=Math.abs(f1)) {
		return x2;
	 } else {
		return x1;
	 }
}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/cern/Polynomial.java0000644000175000017500000000456611302167404030551 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.cern;


/*
Copyright © 1999 CERN - European Organization for Nuclear Research.
Permission to use, copy, modify, distribute and sell this software and its documentation for any purpose
is hereby granted without fee, provided that the above copyright notice appear in all copies and
that both that copyright notice and this permission notice appear in supporting documentation.
CERN makes no representations about the suitability of this software for any purpose.
It is provided "as is" without expressed or implied warranty.
*/



/**
 * Polynomial functions.
 */
public class Polynomial extends Constants {
/**
 * Makes this class non instantiable, but still let's others inherit from it.
 */
protected Polynomial() {}
/**
 * Evaluates the given polynomial of degree N at x, assuming coefficient of N is 1.0.
 * Otherwise same as polevl().
 * 
     *                     2          N
 * y  =  C  + C x + C x  +...+ C x
 *        0    1     2          N
 *
 * where C  = 1 and hence is omitted from the array.
 *        N
 *
 * Coefficients are stored in reverse order:
 *
 * coef[0] = C  , ..., coef[N-1] = C  .
 *            N-1                   0
 *
 * Calling arguments are otherwise the same as polevl().
 * 
    
 * In the interest of speed, there are no checks for out of bounds arithmetic.
 *
 * @param x argument to the polynomial.
 * @param coef the coefficients of the polynomial.
 * @param N the degree of the polynomial.
 */
public static double p1evl( double x, double coef[], int N ) throws ArithmeticException {
	double ans;

	ans = x + coef[0];

	for(int i=1; iN at x.
 * 
     *                     2          N
 * y  =  C  + C x + C x  +...+ C x
 *        0    1     2          N
 *
 * Coefficients are stored in reverse order:
 *
 * coef[0] = C  , ..., coef[N] = C  .
 *            N                   0
 * 
    
 * In the interest of speed, there are no checks for out of bounds arithmetic.
 *
 * @param x argument to the polynomial.
 * @param coef the coefficients of the polynomial.
 * @param N the degree of the polynomial.
 */
public static double polevl( double x, double coef[], int N ) throws ArithmeticException {
	double ans;
	ans = coef[0];

	for(int i=1; i<=N; i++) ans = ans*x+coef[i];

	return ans;
}
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/0000755000175000017500000000000011722677320026641 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/TDistribution.java0000644000175000017500000000442111324235205032276 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The TDistribution class provides an object for encapsulating student's t-distributions.
* @version 1.0
* @author Jaco van Kooten
*/
public final class TDistribution extends ProbabilityDistribution {
        private int dgrFreedom;
        private double logPdfFreedom;

        /**
        * Constructor for student's t-distribution.
        * @param r degrees of freedom.
        */
        public TDistribution(int r) {
                if(r<=0)
                        throw new OutOfRangeException("The degrees of freedom must be greater than zero.");
                dgrFreedom=r;
                logPdfFreedom=-SpecialMath.logBeta(0.5*dgrFreedom,0.5)-0.5*Math.log(dgrFreedom);
        }
        /**
        * Returns the degrees of freedom.
        */
        public int getDegreesOfFreedom() {
                return dgrFreedom;
        }
        /**
        * Probability density function of a student's t-distribution.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                double logPdf=logPdfFreedom;
                logPdf-=(0.5*(dgrFreedom+1))*Math.log(1.0+(X*X)/dgrFreedom);
                return Math.exp(logPdf);
        }
        /**
        * Cumulative student's t-distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                double A=0.5*SpecialMath.incompleteBeta((dgrFreedom)/(dgrFreedom+X*X),0.5*dgrFreedom,0.5);
                return X>0 ? 1-A : A;
        }
        /**
	* Inverse of the cumulative student's t-distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                if(probability==0.0)
                        return -Double.MAX_VALUE;
                if(probability==1.0)
                        return Double.MAX_VALUE;
                if(probability==0.5)
                        return 0.0;
                return findRoot(probability, 0.0, -0.5*Double.MAX_VALUE, 0.5*Double.MAX_VALUE);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/ExtraMath.java0000644000175000017500000003266011324235205031376 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
 * The extra math library.
 * Provides extra functions not in java.lang.Math class.
 * This class cannot be subclassed or instantiated because all methods are static.
 * @version 1.2
 * @author Mark Hale
 */
public final class ExtraMath extends AbstractMath {
    private ExtraMath() {}
    
    /**
     * Rounds a number to so many significant figures.
     * @param x a number to be rounded.
     * @param significant number of significant figures to round to.
     */
    public static double round(final double x, final int significant) {
        if(x == 0.0)
            return x;
        else if(significant == 0)
            return 0.0;
        final double signedExp = log10(Math.abs(x)) - significant;
        if(signedExp < 0.0) {
            // keep the exponent positive so factor is representable
            final double factor = Math.pow(10.0, Math.floor(-signedExp));
            return Math.round(x*factor)/factor;
        } else {
            final double factor = Math.pow(10.0, Math.ceil(signedExp));
            return Math.round(x/factor)*factor;
        }
    }
    /**
     * Returns a random number within a specified range.
     */
    public static double random(double min, double max) {
        return (max-min)*Math.random()+min;
    }
    /**
     * Returns the sign of a number.
     * @return 1 if x>0.0, -1 if x<0.0, else 0.
     */
    public static int sign(double x) {
        if(x > 0.0)
            return 1;
        else if(x < 0.0)
            return -1;
        else
            return 0;
    }
    /**
     * Returns sqrt(x2+y2).
     */
    public static double hypot(final double x,final double y) {
        final double xAbs=Math.abs(x);
        final double yAbs=Math.abs(y);
        if(xAbs==0.0 && yAbs==0.0)
            return 0.0;
        else if(xAbsb.
     * @param a an integer.
     * @param b a positive integer.
     */
    public static int pow(int a, int b) {
        if(b < 0) {
            throw new IllegalArgumentException(b+" must be a positive integer.");
        } else if(b == 0) {
            return 1;
        } else {
            if(a == 0) {
                return 0;
            } else if(a == 1) {
                return 1;
            } else if(a == 2) {
                return 1<a.
     * @param a a positive integer.
     */
    public static int pow2(int a) {
        return 1<double value.
     * 
    The identity is:
     * 
    coth(x) = (ex + e-x)/(ex - e-x),
    
     * in other words, {@linkplain Math#cosh cosh(x)}/{@linkplain Math#sinh sinh(x)}.
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, then the result is NaN.
     * 
    • If the argument is zero, then the result is an infinity with the same sign as the argument.
     * 
    • If the argument is positive infinity, then the result is +1.0.
     * 
    • If the argument is negative infinity, then the result is -1.0.
     * 
    
     * @param x The number whose hyperbolic cotangent is sought
     * @return The hyperbolic cotangent of x
     */
    public static double
            coth(double x) {
        return 1.0D/tanh(x);
    } //coth
    
    /**
     * Returns the hyperbolic cosecant of a double value.
     * 
    The identity is:
     * 
    csch(x) = (2/(ex - e-x),
     * in other words, 1/{@linkplain Math#sinh sinh(x)}.
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, then the result is NaN.
     * 
    • If the argument is zero, then the result is an infinity with the same sign as the argument.
     * 
    • If the argument is positive infinity, then the result is +0.0.
     * 
    • If the argument is negative infinity, then the result is -0.0.
     * 
    
     * @param x The number whose hyperbolic cosecant is sought
     * @return The hyperbolic cosecant of x
     */
    public static double
            csch(double x) {
        return 1.0D/sinh(x);
    } //csch
    
    /**
     * Returns the hyperbolic secant of a double value.
     * 
    The identity is:
     * 
    sech(x) = (2/(ex + e-x),
     * in other words, 1/{@linkplain Math#cosh cosh(x)}.
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, then the result is NaN.
     * 
    • If the argument is an infinity (positive or negative), then the result is +0.0.
     * 
    
     * @param x The number whose hyperbolic secant is sought
     * @return The hyperbolic secant of x
     */
    public static double
            sech(double x) {
        return 1.0D/cosh(x);
    } //sech
    
    /**
     * Returns the inverse hyperbolic sine of a double value.
     * 
    The identity is:
     * 
    asinh(x) = ln(x + sqrt(x2 + 1))
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, then the result is NaN.
     * 
    • If the argument is infinite, then the result is an infinity with the same sign as the argument.
     * 
    • If the argument is zero, then the result is a zero with the same sign as the argument.
     * 
    
     * @param x The number whose inverse hyperbolic sine is sought
     * @return The inverse hyperbolic sine of x
     */
    public static double
            asinh(double x) {
        //Math.hypot(Double.NEGATIVE_INFINITY, 1.0D) is Double.POSITIVE_INFINITY
        //return Double.isInfinite(x) ? x : (x == 0.0) ? x : Math.log(x + Math.hypot(x, 1.0D));
        return Double.isInfinite(x) ? x : (x == 0.0) ? x : Math.log(x+Math.sqrt(x*x+1.0));
    } //asinh
    
    /**
     * Returns the inverse hyperbolic cosine of a double value.
     * Note that cosh(�acosh(x)) = x; this function arbitrarily returns the positive branch.
     * 
    The identity is:
     * 
    acosh(x) = ln(x � sqrt(x2 - 1))
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN or less than one, then the result is NaN.
     * 
    • If the argument is a positive infinity, then the result is (positive) infinity.
     * 
    • If the argument is one, then the result is (positive) zero.
     * 
    
     * @param x The number whose inverse hyperbolic cosine is sought
     * @return The inverse hyperbolic cosine of x
     */
    public static double
            acosh(double x) {
        return Math.log(x + Math.sqrt(x*x - 1.0D));
    } //acosh
    
    /**
     * Returns the inverse hyperbolic tangent of a double value.
     * 
    The identity is:
     * 
    atanh(x) = (1/2)*ln((1 + x)/(1 - x))
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, an infinity, or has a modulus of greater than one, then the result is NaN.
     * 
    • If the argument is plus or minus one, then the result is infinity with the same sign as the argument.
     * 
    • If the argument is zero, then the result is a zero with the same sign as the argument.
     * 
    
     * @param x A double specifying the value whose inverse hyperbolic tangent is sought
     * @return A double specifying the inverse hyperbolic tangent of x
     */
    public static double
            atanh(double x) {
        //return (Math.log1p(x) - Math.log1p(-x))/2.0D;
        return (x != 0.0) ? (Math.log(1.0D + x)-Math.log(1.0D - x))/2.0D : x;
    } //atanh
    
    /**
     * Returns the inverse hyperbolic cotangent of a double value.
     * 
    The identity is:
     * 
    acoth(x) = (1/2)*ln((x + 1)/(x - 1))
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN or a modulus of less than one, then the result is NaN.
     * 
    • If the argument is an infinity, then the result is zero with the same sign as the argument.
     * 
    • If the argument is plus or minus one, then the result is infinity with the same sign as the argument.
     * 
    
     * @param x The number whose inverse hyperbolic cotangent is sought
     * @return  The inverse hyperbolic cotangent of x
     */
    public static double
            acoth(double x) {
//    return (Math.log1p(x) - Math.log(x - 1.0D))/2.0D; // Difference of two same-sign infinities is NaN
        if (Double.isInfinite(x)) return (x < 0.0) ? -0.0D : +0.0D;
        //return (x == -1.0D) ? Double.NEGATIVE_INFINITY : (Math.log1p(x) - Math.log(x - 1.0D))/2.0D;
        return (x == -1.0D) ? Double.NEGATIVE_INFINITY : (Math.log(x+1.0) - Math.log(x - 1.0D))/2.0D;
    } //acoth
    
    /**
     * Returns the inverse hyperbolic cosecant of a double value.
     * 
    The identity is:
     * 
    acsch(x) = ln((1 - sqrt(1 + x2))/x) for x < 0;
     * 
    acsch(x) = ln((1 + sqrt(1 + x2))/x) for x > 0.
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, then the result is NaN.
     * 
    • If the argument is an infinity, then the result is zero with the same sign as the argument.
     * 
    • If the argument is zero, then the result is infinity with the same sign as the argument.
     * 
    
     * @param x The number whose inverse hyperbolic cosecant is sought
     * @return The inverse hyperbolic cosecant of x
     */
    public static double
            acsch(double x) {
//    return (x < 0) ? Math.log((1.0D - Math.sqrt(Math.hypot(1.0, x)))/x) : Math.log((1.0D + Math.sqrt(1.0, x))/x);
        
        if (Double.isInfinite(x)) return (x < 0.0) ? -0.0D : +0.0D;
        //log(+infinity) is +infinity, but log(-infinity) is NaN
        return (x == 0.0D) ? 1.0/x : Math.log((1.0D + sign(x)*Math.sqrt(x*x+1.0))/x);
    } //acsch
    
    /**
     * Returns the inverse hyperbolic secant of a double value.
     * Note that sech(�asech(x)) = x; this function arbitrarily returns the positive branch.
     * 
    The identity is:
     * 
    asech(x) = ln((1 + sqrt(1 - x2))/x).
     * 
    Special cases:
     * 
      
     * 
    • If the argument is NaN, less than zero, or greater than one, then the result is NaN.
     * 
    • If the argument is zero, then the result is infinity with the same sign as the argument.
     * 
    
     * @param x The number whose hyperbolic secant is sought
     * @return The hyperbolic secant of x
     */
    public static double
            asech(double x) {
        //log(+infinity) is +infinity, but log(-infinity) is NaN
        return (x == 0.0D) ? 1.0/x : Math.log((1.0D + Math.sqrt(1.0D - x*x))/x);
    } //asech
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/BetaDistribution.java0000644000175000017500000000432211324235205032746 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The BetaDistribution class provides an object for encapsulating beta distributions.
* @version 1.0
* @author Jaco van Kooten
*/
public final class BetaDistribution extends ProbabilityDistribution {
        private double p,q;

        /**
        * Constructs a beta distribution.
        * @param dgrP degrees of freedom p.
        * @param dgrQ degrees of freedom q.
        */
        public BetaDistribution(double dgrP,double dgrQ) {
                if(dgrP<=0 || dgrQ<=0)
                        throw new OutOfRangeException("The degrees of freedom must be greater than zero.");
                p=dgrP;
                q=dgrQ;
        }
        /**
        * Returns the degrees of freedom p.
        */
        public double getDegreesOfFreedomP() {
                return p;
        }
        /**
        * Returns the degrees of freedom q.
        */
        public double getDegreesOfFreedomQ() {
                return q;
        }
        /**
        * Probability density function of a beta distribution.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X);
                if(X==0.0 || X==1.0)
                        return 0.0;
                return Math.exp(-SpecialMath.logBeta(p,q)+(p-1.0)*Math.log(X)+(q-1.0)*Math.log(1.0-X));
        }
        /**
        * Cumulative beta distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X);
                return SpecialMath.incompleteBeta(X,p,q);
        }
        /**
	* Inverse of the cumulative beta distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                if(probability==0.0)
                        return 0.0;
                if(probability==1.0)
                        return 1.0;
                return findRoot(probability, 0.5, 0.0, 1.0);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/GammaDistribution.java0000644000175000017500000000464111324235205033121 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The GammaDistribution class provides an object for encapsulating gamma distributions.
* @version 1.0
* @author Jaco van Kooten
*/
public final class GammaDistribution extends ProbabilityDistribution {
        private double shape;

        /**
        * Constructs a gamma distribution.
        * @param s the shape parameter.
        */
        public GammaDistribution(double s) {
                if(s<=0.0)
                        throw new OutOfRangeException("The shape parameter should be (strictly) positive.");
                shape=s;
        }
        /**
        * Returns the shape parameter.
        */
        public double getShapeParameter() {
                return shape;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return shape;
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return shape;
        }
        /**
        * Probability density function of a gamma distribution.
        * P(X) = Xs-1 e-X/Gamma(s).
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                if(X==0.0)
                        return 0.0;
                else
                        return Math.exp(-SpecialMath.logGamma(shape)-X+(shape-1)*Math.log(X));
        }
        /**
        * Cumulative gamma distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return SpecialMath.incompleteGamma(shape,X);
        }
        /**
	* Inverse of the cumulative gamma distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                if(probability==0.0)
                        return 0.0;
                if(probability==1.0)
                        return Double.MAX_VALUE;
                return findRoot(probability, shape, 0.0, Double.MAX_VALUE);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/OutOfRangeException.java0000644000175000017500000000112611324235205033362 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats; 

/**
* This exception occurs if an argument in a statistics function is out-of-range.
* @version 1.0
* @author Jaco van Kooten
*/
public class OutOfRangeException extends IllegalArgumentException {
        /**
        * Constructs an OutOfRangeException with no detail message.
        */
        public OutOfRangeException() {
        }
        /**
        * Constructs an OutOfRangeException with the specified detail message.
        */
        public OutOfRangeException(String s) {
                super(s);
        }
}
	
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/AbstractMath.java0000644000175000017500000000051511324235205032050 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The AbstractMath superclass provides an abstract encapsulation of maths.
* All classes with a postfix of Math should extend this class.
* @version 1.0
* @author Mark Hale
*/
public abstract class AbstractMath extends Object {
        protected AbstractMath() {}
}

././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/ProbabilityDistribution.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/ProbabilityDistribution.ja0000644000175000017500000000740411324235205034030 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The ProbabilityDistribution superclass provides an object for encapsulating probability distributions.
* @version 1.0
* @author Jaco van Kooten
*/
public abstract class ProbabilityDistribution extends Object {
        /**
        * Constructs a probability distribution.
        */
        public ProbabilityDistribution() {}
        /**
        * Probability density function.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public abstract double probability(double X);
        /**
        * Cumulative distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public abstract double cumulative(double X);
        /**
	* Inverse of the cumulative distribution function.
        * @return the value X for which P(x<X).
        */
        public abstract double inverse(double probability);
        /**
	* Check if the range of the argument of the distribution method is between lo and hi.
        * @exception OutOfRangeException If the argument is out of range.
        */
        protected final void checkRange(double x, double lo, double hi) {
                if(xhi)
                        throw new OutOfRangeException("The argument of the distribution method should be between "+lo+" and "+hi+".");
        }
        /**
	* Check if the range of the argument of the distribution method is between 0.0 and 1.0.
        * @exception OutOfRangeException If the argument is out of range.
        */
        protected final void checkRange(double x) {
        	if(x<0.0 || x>1.0)
        		throw new OutOfRangeException("The argument of the distribution method should be between 0.0 and 1.0.");
        }

        private static final double FINDROOT_ACCURACY = 1.0e-15;
        private static final int FINDROOT_MAX_ITERATIONS = 150;
        /**
        * This method approximates the value of X for which P(x<X)=prob.
        * It applies a combination of a Newton-Raphson procedure and bisection method
        * with the value guess as a starting point. Furthermore, to ensure convergency
        * and stability, one should supply an inverval [xLo,xHi] in which the probalility
        * distribution reaches the value prob. The method does no checking, it will produce
        * bad results if wrong values for the parameters are supplied - use it with care.
        */
        protected final double findRoot(double prob,double guess,double xLo,double xHi) {
                double x=guess,xNew=guess;
                double error,pdf,dx=1.0;
                int i=0;
                while(Math.abs(dx)>FINDROOT_ACCURACY && i++xHi || pdf==0.0) {
                                xNew=(xLo+xHi)/2.0;
                                dx=xNew-x;
                        }
                        x=xNew;
                }
                return x;
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/NumericalConstants.java0000644000175000017500000000226211324235205033310 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* A collection of useful numbers (stored to maximum precision).
* @version 1.0
* @author Mark Hale
*/
public interface NumericalConstants {
        /**
        * Square root of 2.
        */
        double SQRT2=1.4142135623730950488016887242096980785696718753769;
        /**
        * Two times pi.
        * @jsci.planetmath Pi
        */
        double TWO_PI=6.2831853071795864769252867665590057683943387987502;
        /**
        * Square root of 2pi.
        */
        double SQRT2PI=2.5066282746310005024157652848110452530069867406099;
        /**
        * Natural logarithm of 10.
        */
        double LOG10=2.30258509299404568401799145468436420760110148862877;
        /**
        * Euler's gamma constant.
        * @jsci.planetmath EulersConstant
        */
        double GAMMA=0.57721566490153286060651209008240243104215933593992;
        /**
        * Golden ratio.
        * @jsci.planetmath GoldenRatio
        */
        double GOLDEN_RATIO=1.6180339887498948482045868343656381177203091798058;
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/ParetoDistribution.java0000644000175000017500000000517511324235205033334 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The ParetoDistribution class provides an object for encapsulating Pareto distributions.
* @version 0.2
* @author Mark Hale
*/
public final class ParetoDistribution extends ProbabilityDistribution {
        private double shape;
        private double scale;

        /**
        * Constructs a Pareto distribution.
        * @param sh the shape.
        * @param sc the scale.
        */
        public ParetoDistribution(double sh,double sc) {
                if(sh<0.0)
                        throw new OutOfRangeException("The shape parameter should be positive.");
                shape=sh;
                if(sc<0.0)
                        throw new OutOfRangeException("The scale paremeter should be positive.");
                scale=sc;
        }
        /**
        * Returns the shape parameter.
        */
        public double getShapeParameter() {
                return shape;
        }
        /**
        * Returns the scale parameter.
        */
        public double getScaleParameter() {
                return scale;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return shape*scale/(shape-1.0);
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return shape*scale*scale/((shape-2.0)*(shape-1.0)*(shape-1.0));
        }
        /**
        * Probability density function of a Pareto distribution.
        * P(X) = (a/X) (s/X)a.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                if(Xe-lambdaX.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return lambda*Math.exp(-lambda*X);
        }
        /**
        * Cumulative exponential distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return 1.0-Math.exp(-lambda*X);
        }
        /**
	* Inverse of the cumulative exponential distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return -Math.log(1.0-probability)/lambda;
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/GeometricDistribution.java0000644000175000017500000000443211324235205034013 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The GeometricDistribution class provides an object for encapsulating geometric distributions.
* @version 0.2
* @author Mark Hale
*/
public final class GeometricDistribution extends ProbabilityDistribution {
        private double success;
        private double failure;

        /**
        * Constructs a geometric distribution.
        * @param prob the probability of success.
        */
        public GeometricDistribution(double prob) {
                if(prob<0.0 || prob>1.0)
                        throw new OutOfRangeException("The probability should be between 0.0 and 1.0.");
                success=prob;
                failure=1.0-prob;
        }
        /**
        * Returns the success parameter.
        */
        public double getSuccessParameter() {
                return success;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return 1.0/success;
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return failure/(success*success);
        }
        /**
        * Probability density function of a geometric distribution.
        * P(X) = p (1-p)X-1.
        * @param X should be integer-valued.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return success*Math.pow(failure,X-1);
        }
        /**
        * Cumulative geometric distribution function.
        * @param X should be integer-valued.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return 1.0-Math.pow(failure,X);
        }
        /**
	* Inverse of the cumulative geometric distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return Math.log(1.0-probability)/Math.log(failure);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/CauchyDistribution.java0000644000175000017500000000462311324235205033313 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The CauchyDistribution class provides an object for encapsulating Cauchy distributions.
* @version 0.2
* @author Mark Hale
*/
public final class CauchyDistribution extends ProbabilityDistribution {
        private double alpha;
        private double gamma;

        /**
        * Constructs the standard Cauchy distribution.
        */
        public CauchyDistribution() {
                this(0.0,1.0);
        }
        /**
        * Constructs a Cauchy distribution.
        * @param location the location parameter.
        * @param scale the scale parameter.
        */
        public CauchyDistribution(double location,double scale) {
                if(scale<0.0)
                        throw new OutOfRangeException("The scale parameter should be positive.");
                alpha=location;
                gamma=scale;
        }
        /**
        * Returns the location parameter.
        */
        public double getLocationParameter() {
                return alpha;
        }
        /**
        * Returns the scale parameter.
        */
        public double getScaleParameter() {
                return gamma;
        }
        /**
        * Probability density function of a Cauchy distribution.
        * P(X) = Gamma/(pi(Gamma2+(X-alpha)2)).
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                final double y=X-alpha;
                return gamma/(Math.PI*(gamma*gamma+y*y));
        }
        /**
        * Cumulative Cauchy distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                return 0.5+Math.atan((X-alpha)/gamma)/Math.PI;
        }
        /**
	* Inverse of the cumulative Cauchy distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return alpha-gamma/Math.tan(Math.PI*probability);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/ChiSqrDistribution.java0000644000175000017500000000370211324235205033265 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The ChiSqrDistribution class provides an object for encapsulating chi-squared distributions.
* @version 1.0
* @author Jaco van Kooten
*/
public final class ChiSqrDistribution extends ProbabilityDistribution {
        private double r;
// The ChiSqr and Gamma distributions are closely related.
        private GammaDistribution gamma;

        /**
        * Constructs a chi-squared distribution.
        * @param dgr degrees of freedom.
        */
        public ChiSqrDistribution(double dgr) {
                if(dgr<=0.0)
                        throw new OutOfRangeException("The degrees of freedom must be greater than zero.");
                r=dgr;
                gamma=new GammaDistribution(0.5*r);
        }
        /**
        * Returns the degrees of freedom.
        */
        public double getDegreesOfFreedom() {
                return r;
        }
        /**
        * Probability density function of a chi-squared distribution.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                return 0.5*gamma.probability(0.5*X);
        }
        /**
        * Cumulative chi-squared distribution function.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return SpecialMath.incompleteGamma(0.5*r,0.5*X);
        }
        /**
	* Inverse of the cumulative chi-squared distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                if(probability==1.0)
                        return Double.MAX_VALUE;
                else
                        return 2.0*gamma.inverse(probability);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/PoissonDistribution.java0000644000175000017500000000466511324235205033537 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The PoissonDistribution class provides an object for encapsulating Poisson distributions.
* @version 0.3
* @author Mark Hale
*/
public final class PoissonDistribution extends ProbabilityDistribution {
        private double lambda;

        /**
        * Constructs a Poisson distribution.
        * @param interval the interval.
        */
        public PoissonDistribution(double interval) {
                if(interval<=0.0)
                        throw new OutOfRangeException("The interval should be (strictly) positive.");
                lambda=interval;
        }
        /**
        * Returns the interval parameter.
        */
        public double getIntervalParameter() {
                return lambda;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return lambda;
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return lambda;
        }
        /**
        * Probability density function of a Poisson distribution.
        * P(X) = lambdaXe-lambda/X!.
        * @param X should be integer-valued.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return Math.exp(X*Math.log(lambda)-lambda-ExtraMath.logFactorial(X));
        }
        /**
        * Cumulative Poisson distribution function.
        * @param X should be integer-valued.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                double sum=0.0;
                for(double i=0.0;i<=X;i++)
                        sum+=probability(i);
                return sum;
        }
        /**
	* Inverse of the cumulative Poisson distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return Math.round(findRoot(probability,lambda,0.0,Double.MAX_VALUE));
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/SpecialMath.java0000644000175000017500000020725411324235205031676 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;

/**
* The special function math library.
* This class cannot be subclassed or instantiated because all methods are static.
* @version 1.2
* @author Mark Hale
*/
public final class SpecialMath extends AbstractMath implements NumericalConstants {
        private SpecialMath() {}

// Some IEEE machine constants
        /**
        * Relative machine precision.
        */
        private final static double EPS=2.22e-16;
        /**
        * The smallest positive floating-point number such that 1/xminin is machine representable.
        */
        private final static double XMININ=2.23e-308;


// CHEBYSHEV SERIES

// series for ai0        on the interval  1.25000d-01 to  3.33333d-01
//                                        with weighted error   7.87e-17
//                                         log weighted error  16.10
//                               significant figures required  14.69
//                                    decimal places required  16.76

        private final static double ai0cs[]={
                0.07575994494023796,
                0.00759138081082334,
                0.00041531313389237,
                0.00001070076463439,
                -0.00000790117997921,
                -0.00000078261435014,
                0.00000027838499429,
                0.00000000825247260,
                -0.00000001204463945,
                0.00000000155964859,
                0.00000000022925563,
                -0.00000000011916228,
                0.00000000001757854,
                0.00000000000112822,
                -0.00000000000114684,
                0.00000000000027155,
                -0.00000000000002415,
                -0.00000000000000608,
                0.00000000000000314,
                -0.00000000000000071,
                0.00000000000000007};

// series for ai02       on the interval  0.          to  1.25000d-01
//                                        with weighted error   3.79e-17
//                                         log weighted error  16.42
//                               significant figures required  14.86
//                                    decimal places required  17.09
        private final static double ai02cs[]={
                0.05449041101410882,
                0.00336911647825569,
                0.00006889758346918,
                0.00000289137052082,
                0.00000020489185893,
                0.00000002266668991,
                0.00000000339623203,
                0.00000000049406022,
                0.00000000001188914,
                -0.00000000003149915,
                -0.00000000001321580,
                -0.00000000000179419,
                0.00000000000071801,
                0.00000000000038529,
                0.00000000000001539,
                -0.00000000000004151,
                -0.00000000000000954,
                0.00000000000000382,
                0.00000000000000176,
                -0.00000000000000034,
                -0.00000000000000027,
                0.00000000000000003};

// series for ai1        on the interval  1.25000d-01 to  3.33333d-01
//                                        with weighted error   6.98e-17
//                                         log weighted error  16.16
//                               significant figures required  14.53
//                                    decimal places required  16.82

        private final static double ai1cs[]={
                -0.02846744181881479,
                -0.01922953231443221,
                -0.00061151858579437,
                -0.00002069971253350,
                0.00000858561914581,
                0.00000104949824671,
                -0.00000029183389184,
                -0.00000001559378146,
                0.00000001318012367,
                -0.00000000144842341,
                -0.00000000029085122,
                0.00000000012663889,
                -0.00000000001664947,
                -0.00000000000166665,
                0.00000000000124260,
                -0.00000000000027315,
                0.00000000000002023,
                0.00000000000000730,
                -0.00000000000000333,
                0.00000000000000071,
                -0.00000000000000006};

// series for ai12       on the interval  0.          to  1.25000d-01
//                                        with weighted error   3.55e-17
//                                         log weighted error  16.45
//                               significant figures required  14.69
//                                    decimal places required  17.12

        private final static double ai12cs[]={
                0.02857623501828014,
                -0.00976109749136147,
                -0.00011058893876263,
                -0.00000388256480887,
                -0.00000025122362377,
                -0.00000002631468847,
                -0.00000000383538039,
                -0.00000000055897433,
                -0.00000000001897495,
                0.00000000003252602,
                0.00000000001412580,
                0.00000000000203564,
                -0.00000000000071985,
                -0.00000000000040836,
                -0.00000000000002101,
                0.00000000000004273,
                0.00000000000001041,
                -0.00000000000000382,
                -0.00000000000000186,
                0.00000000000000033,
                0.00000000000000028,
                -0.00000000000000003};

// series for aif        on the interval -1.00000d+00 to  1.00000d+00
//                                        with weighted error   1.09e-19
//                                         log weighted error  18.96
//                               significant figures required  17.76
//                                    decimal places required  19.44

        private final static double aifcs[]={
                -0.03797135849666999750,
                0.05919188853726363857,
                0.00098629280577279975,
                0.00000684884381907656,
                0.00000002594202596219,
                0.00000000006176612774,
                0.00000000000010092454,
                0.00000000000000012014,
                0.00000000000000000010};

// series for aig        on the interval -1.00000d+00 to  1.00000d+00
//                                        with weighted error   1.51e-17
//                                         log weighted error  16.82
//                               significant figures required  15.19
//                                    decimal places required  17.27

        private final static double aigcs[]={
                0.01815236558116127,
                0.02157256316601076,
                0.00025678356987483,
                0.00000142652141197,
                0.00000000457211492,
                0.00000000000952517,
                0.00000000000001392,
                0.00000000000000001};

// series for aip        on the interval  0.          to  1.00000d+00
//                                        with weighted error   5.10e-17
//                                         log weighted error  16.29
//                               significant figures required  14.41
//                                    decimal places required  17.06

        private final static double aipcs[]={
                -0.0187519297793868,
                -0.0091443848250055,
                0.0009010457337825,
                -0.0001394184127221,
                0.0000273815815785,
                -0.0000062750421119,
                0.0000016064844184,
                -0.0000004476392158,
                0.0000001334635874,
                -0.0000000420735334,
                0.0000000139021990,
                -0.0000000047831848,
                0.0000000017047897,
                -0.0000000006268389,
                0.0000000002369824,
                -0.0000000000918641,
                0.0000000000364278,
                -0.0000000000147475,
                0.0000000000060851,
                -0.0000000000025552,
                0.0000000000010906,
                -0.0000000000004725,
                0.0000000000002076,
                -0.0000000000000924,
                0.0000000000000417,
                -0.0000000000000190,
                0.0000000000000087,
                -0.0000000000000040,
                0.0000000000000019,
                -0.0000000000000009,
                0.0000000000000004,
                -0.0000000000000002,
                0.0000000000000001,
                -0.0000000000000000};

// series for am21       on the interval -1.25000d-01 to  0.
//                                        with weighted error   2.89e-17
//                                         log weighted error  16.54
//                               significant figures required  14.15
//                                    decimal places required  17.34

        private final static double am21cs[]={
                0.0065809191761485,
                0.0023675984685722,
                0.0001324741670371,
                0.0000157600904043,
                0.0000027529702663,
                0.0000006102679017,
                0.0000001595088468,
                0.0000000471033947,
                0.0000000152933871,
                0.0000000053590722,
                0.0000000020000910,
                0.0000000007872292,
                0.0000000003243103,
                0.0000000001390106,
                0.0000000000617011,
                0.0000000000282491,
                0.0000000000132979,
                0.0000000000064188,
                0.0000000000031697,
                0.0000000000015981,
                0.0000000000008213,
                0.0000000000004296,
                0.0000000000002284,
                0.0000000000001232,
                0.0000000000000675,
                0.0000000000000374,
                0.0000000000000210,
                0.0000000000000119,
                0.0000000000000068,
                0.0000000000000039,
                0.0000000000000023,
                0.0000000000000013,
                0.0000000000000008,
                0.0000000000000005,
                0.0000000000000003,
                0.0000000000000001,
                0.0000000000000001,
                0.0000000000000000,
                0.0000000000000000,
                0.0000000000000000};

// series for ath1       on the interval -1.25000d-01 to  0.
//                                        with weighted error   2.53e-17
//                                         log weighted error  16.60
//                               significant figures required  15.15
//                                    decimal places required  17.38

        private final static double ath1cs[]={
                -0.07125837815669365,
                -0.00590471979831451,
                -0.00012114544069499,
                -0.00000988608542270,
                -0.00000138084097352,
                -0.00000026142640172,
                -0.00000006050432589,
                -0.00000001618436223,
                -0.00000000483464911,
                -0.00000000157655272,
                -0.00000000055231518,
                -0.00000000020545441,
                -0.00000000008043412,
                -0.00000000003291252,
                -0.00000000001399875,
                -0.00000000000616151,
                -0.00000000000279614,
                -0.00000000000130428,
                -0.00000000000062373,
                -0.00000000000030512,
                -0.00000000000015239,
                -0.00000000000007758,
                -0.00000000000004020,
                -0.00000000000002117,
                -0.00000000000001132,
                -0.00000000000000614,
                -0.00000000000000337,
                -0.00000000000000188,
                -0.00000000000000105,
                -0.00000000000000060,
                -0.00000000000000034,
                -0.00000000000000020,
                -0.00000000000000011,
                -0.00000000000000007,
                -0.00000000000000004,
                -0.00000000000000002};

// series for am22       on the interval -1.00000d+00 to -1.25000d-01
//                                        with weighted error   2.99e-17
//                                         log weighted error  16.52
//                               significant figures required  14.57
//                                    decimal places required  17.28

        private final static double am22cs[]={
                -0.01562844480625341,
                0.00778336445239681,
                0.00086705777047718,
                0.00015696627315611,
                0.00003563962571432,
                0.00000924598335425,
                0.00000262110161850,
                0.00000079188221651,
                0.00000025104152792,
                0.00000008265223206,
                0.00000002805711662,
                0.00000000976821090,
                0.00000000347407923,
                0.00000000125828132,
                0.00000000046298826,
                0.00000000017272825,
                0.00000000006523192,
                0.00000000002490471,
                0.00000000000960156,
                0.00000000000373448,
                0.00000000000146417,
                0.00000000000057826,
                0.00000000000022991,
                0.00000000000009197,
                0.00000000000003700,
                0.00000000000001496,
                0.00000000000000608,
                0.00000000000000248,
                0.00000000000000101,
                0.00000000000000041,
                0.00000000000000017,
                0.00000000000000007,
                0.00000000000000002};

// series for ath2       on the interval -1.00000d+00 to -1.25000d-01
//                                        with weighted error   2.57e-17
//                                         log weighted error  16.59
//                               significant figures required  15.07
//                                    decimal places required  17.34

        private final static double ath2cs[]={
                0.00440527345871877,
                -0.03042919452318455,
                -0.00138565328377179,
                -0.00018044439089549,
                -0.00003380847108327,
                -0.00000767818353522,
                -0.00000196783944371,
                -0.00000054837271158,
                -0.00000016254615505,
                -0.00000005053049981,
                -0.00000001631580701,
                -0.00000000543420411,
                -0.00000000185739855,
                -0.00000000064895120,
                -0.00000000023105948,
                -0.00000000008363282,
                -0.00000000003071196,
                -0.00000000001142367,
                -0.00000000000429811,
                -0.00000000000163389,
                -0.00000000000062693,
                -0.00000000000024260,
                -0.00000000000009461,
                -0.00000000000003716,
                -0.00000000000001469,
                -0.00000000000000584,
                -0.00000000000000233,
                -0.00000000000000093,
                -0.00000000000000037,
                -0.00000000000000015,
                -0.00000000000000006,
                -0.00000000000000002};

// series for bi0        on the interval  0.          to  9.00000d+00
//                                        with weighted error   2.46e-18
//                                         log weighted error  17.61
//                               significant figures required  17.90
//                                    decimal places required  18.15

        private final static double bi0cs[]={
                -0.07660547252839144951,
                1.927337953993808270,
                0.2282644586920301339,
                0.01304891466707290428,
                0.00043442709008164874,
                0.00000942265768600193,
                0.00000014340062895106,
                0.00000000161384906966,
                0.00000000001396650044,
                0.00000000000009579451,
                0.00000000000000053339,
                0.00000000000000000245};

// series for bj0        on the interval  0.          to  1.60000d+01
//                                        with weighted error   7.47e-18
//                                         log weighted error  17.13
//                               significant figures required  16.98
//                                    decimal places required  17.68

        private final static double bj0cs[]={
                0.100254161968939137,
                -0.665223007764405132,
                0.248983703498281314,
                -0.0332527231700357697,
                0.0023114179304694015,
                -0.0000991127741995080,
                0.0000028916708643998,
                -0.0000000612108586630,
                0.0000000009838650793,
                -0.0000000000124235515,
                0.0000000000001265433,
                -0.0000000000000010619,
                0.0000000000000000074};

// series for bm0        on the interval  0.          to  6.25000d-02
//                                        with weighted error   4.98e-17
//                                         log weighted error  16.30
//                               significant figures required  14.97
//                                    decimal places required  16.96

        private final static double bm0cs[]={
                0.09284961637381644,
                -0.00142987707403484,
                0.00002830579271257,
                -0.00000143300611424,
                0.00000012028628046,
                -0.00000001397113013,
                0.00000000204076188,
                -0.00000000035399669,
                0.00000000007024759,
                -0.00000000001554107,
                0.00000000000376226,
                -0.00000000000098282,
                0.00000000000027408,
                -0.00000000000008091,
                0.00000000000002511,
                -0.00000000000000814,
                0.00000000000000275,
                -0.00000000000000096,
                0.00000000000000034,
                -0.00000000000000012,
                0.00000000000000004};

// series for bth0       on the interval  0.          to  6.25000d-02
//                                        with weighted error   3.67e-17
//                                         log weighted error  16.44
//                               significant figures required  15.53
//                                    decimal places required  17.13

        private final static double bth0cs[]={
                -0.24639163774300119,
                0.001737098307508963,
                -0.000062183633402968,
                0.000004368050165742,
                -0.000000456093019869,
                0.000000062197400101,
                -0.000000010300442889,
                0.000000001979526776,
                -0.000000000428198396,
                0.000000000102035840,
                -0.000000000026363898,
                0.000000000007297935,
                -0.000000000002144188,
                0.000000000000663693,
                -0.000000000000215126,
                0.000000000000072659,
                -0.000000000000025465,
                0.000000000000009229,
                -0.000000000000003448,
                0.000000000000001325,
                -0.000000000000000522,
                0.000000000000000210,
                -0.000000000000000087,
                0.000000000000000036};

// series for by0        on the interval  0.          to  1.60000d+01
//                                        with weighted error   1.20e-17
//                                         log weighted error  16.92
//                               significant figures required  16.15
//                                    decimal places required  17.48

        private final static double by0cs[]={
                -0.011277839392865573,
                -0.12834523756042035,
                -0.10437884799794249,
                0.023662749183969695,
                -0.002090391647700486,
                0.000103975453939057,
                -0.000003369747162423,
                0.000000077293842676,
                -0.000000001324976772,
                0.000000000017648232,
                -0.000000000000188105,
                0.000000000000001641,
                -0.000000000000000011};

// series for bi1        on the interval  0.          to  9.00000d+00
//                                        with weighted error   2.40e-17
//                                         log weighted error  16.62
//                               significant figures required  16.23
//                                    decimal places required  17.14

        private final static double bi1cs[]={
                -0.001971713261099859,
                0.40734887667546481,
                0.034838994299959456,
                0.001545394556300123,
                0.000041888521098377,
                0.000000764902676483,
                0.000000010042493924,
                0.000000000099322077,
                0.000000000000766380,
                0.000000000000004741,
                0.000000000000000024};

// series for bj1        on the interval  0.          to  1.60000d+01
//                                        with weighted error   4.48e-17
//                                         log weighted error  16.35
//                               significant figures required  15.77
//                                    decimal places required  16.89

        private final static double bj1cs[]={
                -0.11726141513332787,
                -0.25361521830790640,
                0.050127080984469569,
                -0.004631514809625081,
                0.000247996229415914,
                -0.000008678948686278,
                0.000000214293917143,
                -0.000000003936093079,
                0.000000000055911823,
                -0.000000000000632761,
                0.000000000000005840,
                -0.000000000000000044};

// series for bm1        on the interval  0.          to  6.25000d-02
//                                        with weighted error   5.61e-17
//                                         log weighted error  16.25
//                               significant figures required  14.97
//                                    decimal places required  16.91

        private final static double bm1cs[]={
                0.1047362510931285,
                0.00442443893702345,
                -0.00005661639504035,
                0.00000231349417339,
                -0.00000017377182007,
                0.00000001893209930,
                -0.00000000265416023,
                0.00000000044740209,
                -0.00000000008691795,
                0.00000000001891492,
                -0.00000000000451884,
                0.00000000000116765,
                -0.00000000000032265,
                0.00000000000009450,
                -0.00000000000002913,
                0.00000000000000939,
                -0.00000000000000315,
                0.00000000000000109,
                -0.00000000000000039,
                0.00000000000000014,
                -0.00000000000000005};

// series for bth1       on the interval  0.          to  6.25000d-02
//                                        with weighted error   4.10e-17
//                                         log weighted error  16.39
//                               significant figures required  15.96
//                                    decimal places required  17.08

        private final static double bth1cs[]={
                0.74060141026313850,
                -0.004571755659637690,
                0.000119818510964326,
                -0.000006964561891648,
                0.000000655495621447,
                -0.000000084066228945,
                0.000000013376886564,
                -0.000000002499565654,
                0.000000000529495100,
                -0.000000000124135944,
                0.000000000031656485,
                -0.000000000008668640,
                0.000000000002523758,
                -0.000000000000775085,
                0.000000000000249527,
                -0.000000000000083773,
                0.000000000000029205,
                -0.000000000000010534,
                0.000000000000003919,
                -0.000000000000001500,
                0.000000000000000589,
                -0.000000000000000237,
                0.000000000000000097,
                -0.000000000000000040};

// series for by1        on the interval  0.          to  1.60000d+01
//                                        with weighted error   1.87e-18
//                                         log weighted error  17.73
//                               significant figures required  17.83
//                                    decimal places required  18.30

        private final static double by1cs[]={
                0.03208047100611908629,
                1.262707897433500450,
                0.00649996189992317500,
                -0.08936164528860504117,
                0.01325088122175709545,
                -0.00089790591196483523,
                0.00003647361487958306,
                -0.00000100137438166600,
                0.00000001994539657390,
                -0.00000000030230656018,
                0.00000000000360987815,
                -0.00000000000003487488,
                0.00000000000000027838,
                -0.00000000000000000186};



        /**
        * Evaluates a Chebyshev series.
        * @param x value at which to evaluate series
        * @param series the coefficients of the series
        */
        public static double chebyshev(double x, double series[]) {
                double twox,b0=0.0,b1=0.0,b2=0.0;
                twox=2*x;
                for(int i=series.length-1;i>-1;i--) {
                        b2=b1;
                        b1=b0;
                        b0=twox*b1-b2+series[i];
                }
                return 0.5*(b0-b2);
        }
        /**
        * Airy function.
        * Based on the NETLIB Fortran function ai written by W. Fullerton.
        */
        public static double airy(double x) {
                if(x<-1.0) {
                        return airyModPhase(x);
                } else if(x>1.0)
                        return expAiry(x)*Math.exp(-2.0*x*Math.sqrt(x)/3.0);
                else {
                        final double z=x*x*x;
                        return 0.375+(chebyshev(z,aifcs)-x*(0.25+chebyshev(z,aigcs)));
                }
        }
        /**
        * Airy modulus and phase.
        * Based on the NETLIB Fortran subroutine r9aimp written by W. Fullerton.
        * @return the real part, i.e. modulus*cos(phase).
        */
        private static double airyModPhase(double x) {
                double modulus, phase;
                if(x < -2.0) {
                        double z = 16.0/(x*x*x)+1.0;
                        modulus = 0.3125+chebyshev(z, am21cs);
                        phase = -0.625+chebyshev(z, ath1cs);
                } else {
                        double z = (16.0/(x*x*x)+9.0)/7.0;
                        modulus = 0.3125+chebyshev(z, am22cs);
                        phase = -0.625+chebyshev(z, ath2cs);
                }
                final double sqrtx = Math.sqrt(-x);
                modulus = Math.sqrt(modulus/sqrtx);
                phase = Math.PI/4.0-x*sqrtx*phase;
                return modulus*Math.cos(phase);
        }
        /**
        * Exponential scaled Airy function.
        * Based on the NETLIB Fortran function aie written by W. Fullerton.
        */
        private static double expAiry(double x) {
                if(x<-1.0) {
                        return airyModPhase(x);
                } else if(x<=1.0) {
                        final double z=x*x*x;
                        return 0.375+(chebyshev(z,aifcs)-x*(0.25+chebyshev(z,aigcs)))*Math.exp(2.0*x*Math.sqrt(x)/3.0);
                } else {
                        final double sqrtx=Math.sqrt(x);
                        final double z=2.0/(x*sqrtx)-1.0;
                        return (0.28125+chebyshev(z,aipcs))/Math.sqrt(sqrtx);
                }
        }
        /**
        * Bessel function of first kind, order zero.
        * Based on the NETLIB Fortran function besj0 written by W. Fullerton.
        */
        public static double besselFirstZero(double x) {
                double y=Math.abs(x);
                if(y>4.0) {
                        final double z=32/(y*y)-1;
                        final double amplitude=(0.75+chebyshev(z,bm0cs))/Math.sqrt(y);
                        final double theta=y-Math.PI/4.0+chebyshev(z,bth0cs)/y;
                        return amplitude*Math.cos(theta);
                } else if(y==0.0)
                        return 1.0;
                else
                        return chebyshev(0.125*y*y-1,bj0cs);
        }
        /**
        * Modified Bessel function of first kind, order zero.
        * Based on the NETLIB Fortran function besi0 written by W. Fullerton.
        */
        public static double modBesselFirstZero(double x) {
                double y=Math.abs(x);
                if(y>3.0)
                        return Math.exp(y)*expModBesselFirstZero(x);
                else
                        return 2.75+chebyshev(y*y/4.5-1.0, bi0cs);
        }
        /**
        * Exponential scaled modified Bessel function of first kind, order zero.
        * Based on the NETLIB Fortran function besi0e written by W. Fullerton.
        */
        private static double expModBesselFirstZero(double x) {
                final double y=Math.abs(x);
                if(y>3.0) {
                        if(y>8.0)
                                return (0.375+chebyshev(16.0/y-1.0, ai02cs))/Math.sqrt(y);
                        else
                                return (0.375+chebyshev((48.0/y-11.0)/5.0, ai0cs))/Math.sqrt(y);
                } else
                        return Math.exp(-y)*(2.75+chebyshev(y*y/4.5-1.0, bi0cs));
        }
        /**
        * Bessel function of first kind, order one.
        * Based on the NETLIB Fortran function besj1 written by W. Fullerton.
        */
        public static double besselFirstOne(double x) {
                double y=Math.abs(x);
                if(y>4.0) {
                        final double z=32.0/(y*y)-1.0;
                        final double amplitude=(0.75+chebyshev(z, bm1cs))/Math.sqrt(y);
                        final double theta=y-3.0*Math.PI/4.0+chebyshev(z, bth1cs)/y;
                        return Math.abs(amplitude)*x*Math.cos(theta)/Math.abs(x);
                } else if(y==0.0)
                        return 0.0;
                else
                        return x*(0.25+chebyshev(0.125*y*y-1.0, bj1cs));
        }
        /**
        * Modified Bessel function of first kind, order one.
        * Based on the NETLIB Fortran function besi1 written by W. Fullerton.
        */
        public static double modBesselFirstOne(double x) {
                final double y=Math.abs(x);
                if(y>3.0)
                        return Math.exp(y)*expModBesselFirstOne(x);
                else if(y==0.0)
                        return 0.0;
                else
                        return x*(0.875+chebyshev(y*y/4.5-1.0, bi1cs));
        }
        /**
        * Exponential scaled modified Bessel function of first kind, order one.
        * Based on the NETLIB Fortran function besi1e written by W. Fullerton.
        */
        private static double expModBesselFirstOne(double x) {
                final double y=Math.abs(x);
                if(y>3.0) {
                        if(y>8.0)
                                return x/y*(0.375+chebyshev(16.0/y-1.0, ai12cs))/Math.sqrt(y);
                        else
                                return x/y*(0.375+chebyshev((48.0/y-11.0)/5.0, ai1cs))/Math.sqrt(y);
                } else if(y==0.0)
                        return 0.0;
                else
                        return Math.exp(-y)*x*(0.875+chebyshev(y*y/4.5-1.0, bi1cs));
        }
        /**
        * Bessel function of second kind, order zero.
        * Based on the NETLIB Fortran function besy0 written by W. Fullerton.
        */
        public static double besselSecondZero(double x) {
                if(x>4.0) {
                        final double z=32.0/(x*x)-1.0;
                        final double amplitude=(0.75+chebyshev(z, bm0cs))/Math.sqrt(x);
                        final double theta=x-Math.PI/4+chebyshev(z, bth0cs)/x;
                        return amplitude*Math.sin(theta);
                } else
                        return (Math.log(0.5)+Math.log(x))*besselFirstZero(x)+0.375+chebyshev(0.125*x*x-1.0,by0cs)*2.0/Math.PI;
        }
        /**
        * Bessel function of second kind, order one.
        * Based on the NETLIB Fortran function besy1 written by W. Fullerton.
        */
        public static double besselSecondOne(double x) {
                if(x>4.0) {
                        final double z=32.0/(x*x)-1.0;
                        final double amplitude=(0.75+chebyshev(z, bm1cs))/Math.sqrt(x);
                        final double theta=x-3.0*Math.PI/4.0+chebyshev(z, bth1cs)/x;
                        return amplitude*Math.sin(theta);
                } else
                        return 2.0*Math.log(0.5*x)*besselFirstOne(x)/Math.PI+(0.5+chebyshev(0.125*x*x-1.0, by1cs))/x;
        }

        private final static double LOGSQRT2PI=Math.log(SQRT2PI);

// Gamma function related constants
        private final static double g_p[] = { -1.71618513886549492533811,
                24.7656508055759199108314, -379.804256470945635097577,
                629.331155312818442661052, 866.966202790413211295064,
                -31451.2729688483675254357, -36144.4134186911729807069,
                66456.1438202405440627855 };
        private final static double g_q[] = { -30.8402300119738975254353,
                315.350626979604161529144, -1015.15636749021914166146,
                -3107.77167157231109440444, 22538.1184209801510330112,
                4755.84627752788110767815, -134659.959864969306392456,
                -115132.259675553483497211 };
        private final static double g_c[] = { -0.001910444077728,8.4171387781295e-4,
                -5.952379913043012e-4, 7.93650793500350248e-4,
                -0.002777777777777681622553, 0.08333333333333333331554247,
                0.0057083835261 };
        /**
        * The largest argument for which gamma(x) is representable in the machine.
        */
        public final static double GAMMA_X_MAX_VALUE = 171.624;

        /**
        * Gamma function.
        * Based on public domain NETLIB (Fortran) code by W. J. Cody and L. Stoltz
    
        * Applied Mathematics Division
    
        * Argonne National Laboratory
    
        * Argonne, IL 60439
    
        * 
    
        * References:
        * 
      
        * 
    1. "An Overview of Software Development for Special Functions", W. J. Cody, Lecture Notes in Mathematics, 506, Numerical Analysis Dundee, 1975, G. A. Watson (ed.), Springer Verlag, Berlin, 1976.
        * 
    2. Computer Approximations, Hart, Et. Al., Wiley and sons, New York, 1968.
        * 
    
        * From the original documentation:
        * 
    
        * This routine calculates the GAMMA function for a real argument X. 
	* Computation is based on an algorithm outlined in reference 1. 
	* The program uses rational functions that approximate the GAMMA 
	* function to at least 20 significant decimal digits.  Coefficients 
	* for the approximation over the interval (1,2) are unpublished. 
	* Those for the approximation for X .GE. 12 are from reference 2. 
	* The accuracy achieved depends on the arithmetic system, the 
	* compiler, the intrinsic functions, and proper selection of the 
	* machine-dependent constants. 
        * 
    
	* Error returns:
    
	* The program returns the value XINF for singularities or when overflow would occur.
        * The computation is believed to be free of underflow and overflow.
	* 
    
        * @return Double.MAX_VALUE if overflow would occur, i.e. if abs(x) > 171.624
        * @jsci.planetmath GammaFunction
        * @author Jaco van Kooten
	*/
        public static double gamma(double x) {
                double fact=1.0, xden, xnum;
                int i, n=0;
                double y=x, z, y1;
                boolean parity=false;
                double res, sum, ysq;

                if (y <= 0.0) {
// ----------------------------------------------------------------------
//  Argument is negative
// ----------------------------------------------------------------------
                        y = -(x);
                        y1 = (int)y;
                        res = y - y1;
                        if (res != 0.0) {
                                if (y1 != (((int)(y1*0.5)) * 2.0))
                                        parity = true;
                                fact = -Math.PI/ Math.sin(Math.PI * res);
                                y++;
                        } else 
                                return Double.MAX_VALUE;
                }
// ----------------------------------------------------------------------
//  Argument is positive
// ----------------------------------------------------------------------
                if (y < EPS) {
// ----------------------------------------------------------------------
//  Argument .LT. EPS
// ----------------------------------------------------------------------
                        if (y >= XMININ) 
                                res = 1.0 / y;
                        else 
                                return Double.MAX_VALUE;
                } else if (y < 12.0) {
                        y1 = y;
                        if (y < 1.0) {
// ----------------------------------------------------------------------
//  0.0 .LT. argument .LT. 1.0
// ----------------------------------------------------------------------
                                z = y;
                                y++;
                        } else {
// ----------------------------------------------------------------------
//  1.0 .LT. argument .LT. 12.0, reduce argument if necessary
// ----------------------------------------------------------------------
                                n = (int)y - 1;
                                y -= (double) n;
                                z = y - 1.0;
                        }
// ----------------------------------------------------------------------
//  Evaluate approximation for 1.0 .LT. argument .LT. 2.0
// ----------------------------------------------------------------------
                        xnum = 0.0;
                        xden = 1.0;
                        for (i = 0; i < 8; ++i) {
                                xnum = (xnum + g_p[i]) * z;
                                xden = xden * z + g_q[i];
                        }
                        res = xnum / xden + 1.0;
                        if (y1 < y) 
// ----------------------------------------------------------------------
//  Adjust result for case  0.0 .LT. argument .LT. 1.0
// ----------------------------------------------------------------------
                                res /= y1;
                        else if (y1 > y) {
// ----------------------------------------------------------------------
//  Adjust result for case  2.0 .LT. argument .LT. 12.0
// ----------------------------------------------------------------------
                                for (i = 0; i < n; ++i) {
                                        res *= y;
                                        y++;
                                }
                        }
                } else {
// ----------------------------------------------------------------------
//  Evaluate for argument .GE. 12.0
// ----------------------------------------------------------------------
                        if (y <= GAMMA_X_MAX_VALUE) {
                                ysq = y * y;
                                sum = g_c[6];
                                for (i = 0; i < 6; ++i)
                                        sum = sum / ysq + g_c[i];
                                sum = sum / y - y + LOGSQRT2PI;
                                sum += (y - 0.5) * Math.log(y);
                                res = Math.exp(sum);
                        } else 
                                return Double.MAX_VALUE;
                }
// ----------------------------------------------------------------------
//  Final adjustments and return
// ----------------------------------------------------------------------
                if (parity)
                        res = -res;
                if (fact != 1.0)
                        res = fact / res;
                return res;
        } 

        /**
        * The largest argument for which logGamma(x) is representable in the machine.
        */
        public final static double LOG_GAMMA_X_MAX_VALUE = 2.55e305;

// Log Gamma related constants
        private final static double lg_d1 = -0.5772156649015328605195174;
        private final static double lg_d2 = 0.4227843350984671393993777;
        private final static double lg_d4 = 1.791759469228055000094023;
        private final static double lg_p1[] = { 4.945235359296727046734888,
                201.8112620856775083915565, 2290.838373831346393026739,
                11319.67205903380828685045, 28557.24635671635335736389,
                38484.96228443793359990269, 26377.48787624195437963534,
                7225.813979700288197698961 };
        private final static double lg_q1[] = { 67.48212550303777196073036,
                1113.332393857199323513008, 7738.757056935398733233834,
                27639.87074403340708898585, 54993.10206226157329794414,
                61611.22180066002127833352, 36351.27591501940507276287,
                8785.536302431013170870835 };
        private final static double lg_p2[] = { 4.974607845568932035012064,
                542.4138599891070494101986, 15506.93864978364947665077,
                184793.2904445632425417223, 1088204.76946882876749847,
                3338152.967987029735917223, 5106661.678927352456275255,
                3074109.054850539556250927 };
        private final static double lg_q2[] = { 183.0328399370592604055942,
                7765.049321445005871323047, 133190.3827966074194402448,
                1136705.821321969608938755, 5267964.117437946917577538,
                13467014.54311101692290052, 17827365.30353274213975932,
                9533095.591844353613395747 };
        private final static double lg_p4[] = { 14745.02166059939948905062,
                2426813.369486704502836312, 121475557.4045093227939592,
                2663432449.630976949898078, 29403789566.34553899906876,
                170266573776.5398868392998, 492612579337.743088758812,
                560625185622.3951465078242 };
        private final static double lg_q4[] = { 2690.530175870899333379843,
                639388.5654300092398984238, 41355999.30241388052042842,
                1120872109.61614794137657, 14886137286.78813811542398,
                101680358627.2438228077304, 341747634550.7377132798597,
                446315818741.9713286462081 };
        private final static double lg_c[] = { -0.001910444077728,8.4171387781295e-4,
                -5.952379913043012e-4, 7.93650793500350248e-4,
                -0.002777777777777681622553, 0.08333333333333333331554247,
                0.0057083835261 };
//       Rough estimate of the fourth root of logGamma_xBig
        private final static double lg_frtbig = 2.25e76;
        private final static double pnt68 = 0.6796875;

// Function cache for logGamma
        private static final ThreadLocal logGammaCache_res=new ThreadLocal() {
            protected Object initialValue() {
                return new Double(0.0);
            }
            
        };
        private static final ThreadLocal logGammaCache_x=new ThreadLocal() {
            protected Object initialValue() {
                return new Double(0.0);
            }
        };

	/**
        * The natural logarithm of the gamma function.
        * Based on public domain NETLIB (Fortran) code by W. J. Cody and L. Stoltz
    
        * Applied Mathematics Division
    
        * Argonne National Laboratory
    
        * Argonne, IL 60439
    
        * 
    
        * References:
        * 
      
        * 
    1. W. J. Cody and K. E. Hillstrom, 'Chebyshev Approximations for the Natural Logarithm of the Gamma Function,' Math. Comp. 21, 1967, pp. 198-203.
        * 
    2. K. E. Hillstrom, ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, May, 1969.
        * 
    3. Hart, Et. Al., Computer Approximations, Wiley and sons, New York, 1968.
        * 
    
        * From the original documentation:
        * 
    
        * This routine calculates the LOG(GAMMA) function for a positive real argument X.
        * Computation is based on an algorithm outlined in references 1 and 2.
        * The program uses rational functions that theoretically approximate LOG(GAMMA)
        * to at least 18 significant decimal digits.  The approximation for X > 12 is from reference 3,
        * while approximations for X < 12.0 are similar to those in reference 1, but are unpublished.
        * The accuracy achieved depends on the arithmetic system, the compiler, the intrinsic functions,
        * and proper selection of the machine-dependent constants.
        * 
    
        * Error returns:
    
        * The program returns the value XINF for X .LE. 0.0 or when overflow would occur.
        * The computation is believed to be free of underflow and overflow.
        * 
    
        * @return Double.MAX_VALUE for x < 0.0 or when overflow would occur, i.e. x > 2.55E305
        * @author Jaco van Kooten
	*/
        public static double logGamma(double x) {
                double xden, corr, xnum;
                int i;
                double y, xm1, xm2, xm4, res, ysq;

                if (x == ((Double) logGammaCache_x.get()).doubleValue())
                        return ((Double) logGammaCache_res.get()).doubleValue();
                
                y = x;
                if (y > 0.0 && y <= LOG_GAMMA_X_MAX_VALUE) {
                        if (y <= EPS) {
                                res = -Math.log(y);
                        } else if (y <= 1.5) {
// ----------------------------------------------------------------------
//  EPS .LT. X .LE. 1.5
// ----------------------------------------------------------------------
                                if (y < pnt68) {
                                        corr = -Math.log(y);
                                        xm1 = y;
                                } else {
                                        corr = 0.0;
                                        xm1 = y - 1.0;
                                }
                                if (y <= 0.5 || y >= pnt68) {
                                        xden = 1.0;
                                        xnum = 0.0;
                                        for (i = 0; i < 8; i++) {
                                                xnum = xnum * xm1 + lg_p1[i];
                                                xden = xden * xm1 + lg_q1[i];
                                        }
                                        res = corr + xm1 * (lg_d1 + xm1 * (xnum / xden));
                                } else {
                                        xm2 = y - 1.0;
                                        xden = 1.0;
                                        xnum = 0.0;
                                        for (i = 0; i < 8; i++) {
                                                xnum = xnum * xm2 + lg_p2[i];
                                                xden = xden * xm2 + lg_q2[i];
                                        }
                                        res = corr + xm2 * (lg_d2 + xm2 * (xnum / xden));
                                }
                        } else if (y <= 4.0) {
// ----------------------------------------------------------------------
//  1.5 .LT. X .LE. 4.0
// ----------------------------------------------------------------------
                                xm2 = y - 2.0;
                                xden = 1.0;
                                xnum = 0.0;
                                for (i = 0; i < 8; i++) {
                                        xnum = xnum * xm2 + lg_p2[i];
                                        xden = xden * xm2 + lg_q2[i];
                                }
                                res = xm2 * (lg_d2 + xm2 * (xnum / xden));
                        } else if (y <= 12.0) {
// ----------------------------------------------------------------------
//  4.0 .LT. X .LE. 12.0
// ----------------------------------------------------------------------
                                xm4 = y - 4.0;
                                xden = -1.0;
                                xnum = 0.0;
                                for (i = 0; i < 8; i++) {
                                        xnum = xnum * xm4 + lg_p4[i];
                                        xden = xden * xm4 + lg_q4[i];
                                }
                                res = lg_d4 + xm4 * (xnum / xden);
                        } else {
// ----------------------------------------------------------------------
//  Evaluate for argument .GE. 12.0
// ----------------------------------------------------------------------
                                res = 0.0;
                                if (y <= lg_frtbig) {
                			res = lg_c[6];
                			ysq = y * y;
                			for (i = 0; i < 6; i++)
                        		    	res = res / ysq + lg_c[i];
                                }
                                res /= y;
                                corr = Math.log(y);
                                res = res + LOGSQRT2PI - 0.5 * corr;
                                res += y * (corr - 1.0);
                        }
                } else {
// ----------------------------------------------------------------------
//  Return for bad arguments
// ----------------------------------------------------------------------
                        res = Double.MAX_VALUE;
                }
// ----------------------------------------------------------------------
//  Final adjustments and return
// ----------------------------------------------------------------------
                logGammaCache_x.set(new Double(x));
                logGammaCache_res.set(new Double(res));
                return res;
        }

        private final static int MAX_ITERATIONS = 1000000000;
        // lower value = higher precision
        private final static double PRECISION = 4.0*EPS;

        /**
        * Incomplete gamma function.
        * The computation is based on approximations presented in Numerical Recipes, Chapter 6.2 (W.H. Press et al, 1992).
        * @param a require a>=0
        * @param x require x>=0
        * @return 0 if x<0, a<=0 or a>2.55E305 to avoid errors and over/underflow
        * @author Jaco van Kooten
        */
        public static double incompleteGamma(double a, double x) {
                if (x <= 0.0 || a <= 0.0 || a > LOG_GAMMA_X_MAX_VALUE)
                        return 0.0;
                if (x < (a+1.0))
                        return gammaSeriesExpansion(a,x);
                else 
                        return 1.0-gammaFraction(a,x);
        }
        /**
        * @author Jaco van Kooten
        */
        private static double gammaSeriesExpansion(double a, double x) {
                double ap = a;
                double del = 1.0/a;
                double sum = del;
                for (int n=1; n < MAX_ITERATIONS; n++) {
                        ++ap;
                        del *= x/ap;
                        sum += del;
                        if (del < sum*PRECISION)
                                return sum*Math.exp(-x + a*Math.log(x) - logGamma(a));
                }
                throw new RuntimeException("Maximum iterations exceeded: please file a bug report.");
        }
        /**
        * @author Jaco van Kooten
        */
        private static double gammaFraction(double a, double x) {
                double b=x+1.0-a;
                double c=1.0/XMININ;
                double d=1.0/b;
                double h=d;
                double del=0.0;
                double an; 
                for (int i=1; iPRECISION; i++) {
                        an = -i*(i-a);
                        b += 2.0;
                        d=an*d+b;
                        c=b+an/c;
                        if (Math.abs(c) < XMININ)
                                c=XMININ;
                        if (Math.abs(d) < XMININ)
                                c=XMININ;
                        d=1.0/d;
                        del=d*c;
                        h *= del;
                }
                return Math.exp(-x + a*Math.log(x) - logGamma(a))*h;
        }
        /**
        * Beta function.
        * @param p require p>0
        * @param q require q>0
        * @return 0 if p<=0, q<=0 or p+q>2.55E305 to avoid errors and over/underflow
        * @author Jaco van Kooten
        */
        public static double beta(double p, double q) {
                if (p <= 0.0 || q <= 0.0 || (p+q) > LOG_GAMMA_X_MAX_VALUE)
                        return 0.0;
                else
                        return Math.exp(logBeta(p,q));
	}

// Function cache for logBeta
        private static final ThreadLocal logBetaCache_res=new ThreadLocal() {
            protected Object initialValue() {
                return new Double(0.0);
            }
        };
        private static final ThreadLocal logBetaCache_p=new ThreadLocal() {
            protected Object initialValue() {
                return new Double(0.0);
            }
        };
        private static final ThreadLocal logBetaCache_q=new ThreadLocal() {
            protected Object initialValue() {
                return new Double(0.0);
            }
        };

        /**
        * The natural logarithm of the beta function.
        * @param p require p>0
        * @param q require q>0
        * @return 0 if p<=0, q<=0 or p+q>2.55E305 to avoid errors and over/underflow
        * @author Jaco van Kooten
        */
        public static double logBeta(double p, double q) {
                if (p != ((Double) logBetaCache_p.get()).doubleValue()
                    || q != ((Double) logBetaCache_q.get()).doubleValue()) {
                        logBetaCache_p.set(new Double(p));
                        logBetaCache_q.set(new Double(q));
                        double res;
                        if (p <= 0.0 || q <= 0.0 || (p+q) > LOG_GAMMA_X_MAX_VALUE)
                                res = 0.0;
                        else
                                res = logGamma(p)+logGamma(q)-logGamma(p+q);
                        logBetaCache_res.set(new Double(res));
                        return res;
                } else {
                        return ((Double) logBetaCache_res.get()).doubleValue();
                }
        }
        /**
        * Incomplete beta function.
        * The computation is based on formulas from Numerical Recipes, Chapter 6.4 (W.H. Press et al, 1992).
        * @param x require 0<=x<=1
        * @param p require p>0
        * @param q require q>0
        * @return 0 if x<0, p<=0, q<=0 or p+q>2.55E305 and 1 if x>1 to avoid errors and over/underflow
        * @author Jaco van Kooten
        */
	public static double incompleteBeta(double x, double p, double q) {
                if (x <= 0.0) 
        		return 0.0;
                else if (x >= 1.0)
                        return 1.0;
                else if (p <= 0.0 || q <= 0.0 || (p+q) > LOG_GAMMA_X_MAX_VALUE)
        		return 0.0;
                else {
                        final double beta_gam=Math.exp(-logBeta(p,q) + p*Math.log(x) + q*Math.log(1.0-x));
                        if (x < (p+1.0)/(p+q+2.0))
                                return beta_gam*betaFraction(x,p,q)/p;
        		else
        			return 1.0-(beta_gam*betaFraction(1.0-x,q,p)/q);
                }
        }
        /**
	* Evaluates of continued fraction part of incomplete beta function.
        * Based on an idea from Numerical Recipes (W.H. Press et al, 1992).
        * @author Jaco van Kooten
        */
	private static double betaFraction(double x, double p, double q) {
        	int m, m2;
        	double sum_pq, p_plus, p_minus, c =1.0 , d, delta, h, frac;
        	sum_pq  = p + q;
        	p_plus  = p + 1.0;
        	p_minus = p - 1.0;
        	h=1.0-sum_pq*x/p_plus;
        	if (Math.abs(h) < XMININ)
                        h=XMININ;
        	h=1.0/h;
                frac = h;
        	m=1;
        	delta = 0.0;
        	while (m <= MAX_ITERATIONS && Math.abs(delta-1.0) > PRECISION ) {
                        m2=2*m;
                // even index for d 
        		d=m*(q-m)*x/((p_minus+m2)*(p+m2));
        		h=1.0+d*h;
        		if (Math.abs(h) < XMININ)
                                h=XMININ;
        		h=1.0/h;
        		c=1.0+d/c;
        		if (Math.abs(c) < XMININ)
                                c=XMININ;
        		frac *= h*c;
                // odd index for d
        		d = -(p+m)*(sum_pq+m)*x/((p+m2)*(p_plus+m2));
        		h=1.0+d*h;
        		if (Math.abs(h) < XMININ)
                                h=XMININ;
        		h=1.0/h;
        		c=1.0+d/c;
        		if (Math.abs(c) < XMININ)
                                c=XMININ;
                        delta=h*c;
                        frac *= delta;
                        m++;
                }
                return frac;
        }

// ====================================================
// Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
//
// Developed at SunSoft, a Sun Microsystems, Inc. business.
// Permission to use, copy, modify, and distribute this
// software is freely granted, provided that this notice 
// is preserved.
// ====================================================
//
//			     x
//		      2      |\
//     erf(x)  =  ---------  | exp(-t*t)dt
//	 	   sqrt(pi) \| 
//			     0
//
//     erfc(x) =  1-erf(x)
//  Note that 
//		erf(-x) = -erf(x)
//		erfc(-x) = 2 - erfc(x)
//
// Method:
//	1. For |x| in [0, 0.84375]
//	    erf(x)  = x + x*R(x^2)
//          erfc(x) = 1 - erf(x)           if x in [-.84375,0.25]
//                  = 0.5 + ((0.5-x)-x*R)  if x in [0.25,0.84375]
//	   where R = P/Q where P is an odd poly of degree 8 and
//	   Q is an odd poly of degree 10.
//						 -57.90
//			| R - (erf(x)-x)/x | <= 2
//	
//
//	   Remark. The formula is derived by noting
//          erf(x) = (2/sqrt(pi))*(x - x^3/3 + x^5/10 - x^7/42 + ....)
//	   and that
//          2/sqrt(pi) = 1.128379167095512573896158903121545171688
//	   is close to one. The interval is chosen because the fix
//	   point of erf(x) is near 0.6174 (i.e., erf(x)=x when x is
//	   near 0.6174), and by some experiment, 0.84375 is chosen to
// 	   guarantee the error is less than one ulp for erf.
//
//      2. For |x| in [0.84375,1.25], let s = |x| - 1, and
//         c = 0.84506291151 rounded to single (24 bits)
//         	erf(x)  = sign(x) * (c  + P1(s)/Q1(s))
//         	erfc(x) = (1-c)  - P1(s)/Q1(s) if x > 0
//			  1+(c+P1(s)/Q1(s))    if x < 0
//         	|P1/Q1 - (erf(|x|)-c)| <= 2**-59.06
//	   Remark: here we use the taylor series expansion at x=1.
//		erf(1+s) = erf(1) + s*Poly(s)
//			 = 0.845.. + P1(s)/Q1(s)
//	   That is, we use rational approximation to approximate
//			erf(1+s) - (c = (single)0.84506291151)
//	   Note that |P1/Q1|< 0.078 for x in [0.84375,1.25]
//	   where 
//		P1(s) = degree 6 poly in s
//		Q1(s) = degree 6 poly in s
//
//      3. For x in [1.25,1/0.35(~2.857143)], 
//         	erfc(x) = (1/x)*exp(-x*x-0.5625+R1/S1)
//         	erf(x)  = 1 - erfc(x)
//	   where 
//		R1(z) = degree 7 poly in z, (z=1/x^2)
//		S1(z) = degree 8 poly in z
//
//      4. For x in [1/0.35,28]
//         	erfc(x) = (1/x)*exp(-x*x-0.5625+R2/S2) if x > 0
//			= 2.0 - (1/x)*exp(-x*x-0.5625+R2/S2) if -6 x >= 28
//         	erf(x)  = sign(x) *(1 - tiny)  (raise inexact)
//         	erfc(x) = tiny*tiny (raise underflow) if x > 0
//			= 2 - tiny if x<0
//
//      7. Special case:
//         	erf(0)  = 0, erf(inf)  = 1, erf(-inf) = -1,
//         	erfc(0) = 1, erfc(inf) = 0, erfc(-inf) = 2, 
//	   	erfc/erf(NaN) is NaN
//

// Coefficients for approximation to  erf on [0,0.84375]
        private final static double e_efx=1.28379167095512586316e-01;
//        private final static double efx8=1.02703333676410069053e00;
        private final static double ePp[]={
                1.28379167095512558561e-01,
                -3.25042107247001499370e-01,
                -2.84817495755985104766e-02,
                -5.77027029648944159157e-03,
                -2.37630166566501626084e-05};
        private final static double eQq[]={
                3.97917223959155352819e-01,
                6.50222499887672944485e-02,
                5.08130628187576562776e-03,
                1.32494738004321644526e-04,
                -3.96022827877536812320e-06};
// Coefficients for approximation to  erf  in [0.84375,1.25] 
        private final static double ePa[]={
                -2.36211856075265944077e-03,
                4.14856118683748331666e-01,
                -3.72207876035701323847e-01,
                3.18346619901161753674e-01,
                -1.10894694282396677476e-01,
                3.54783043256182359371e-02,
                -2.16637559486879084300e-03};
        private final static double eQa[]={
                1.06420880400844228286e-01,
                5.40397917702171048937e-01,
                7.18286544141962662868e-02,
                1.26171219808761642112e-01,
                1.36370839120290507362e-02,
                1.19844998467991074170e-02};
        private final static double e_erx=8.45062911510467529297e-01;

	/**
        * Error function.
        * Based on C-code for the error function developed at Sun Microsystems.
        * @author Jaco van Kooten
	*/
        public static double error(double x) {
        	double P,Q,s,retval;
        	final double abs_x = (x >= 0.0 ? x : -x);
                if ( abs_x < 0.84375 ) {                               // 0 < |x| < 0.84375
                        if (abs_x < 3.7252902984619141e-9 )     // |x| < 2**-28
                                retval = abs_x + abs_x*e_efx;
                        else {
        			s = x*x;
         			P = ePp[0]+s*(ePp[1]+s*(ePp[2]+s*(ePp[3]+s*ePp[4])));
        			Q = 1.0+s*(eQq[0]+s*(eQq[1]+s*(eQq[2]+s*(eQq[3]+s*eQq[4]))));
        			retval = abs_x + abs_x*(P/Q);
           		}
        	} else if (abs_x < 1.25) {                             // 0.84375 < |x| < 1.25
        		s = abs_x-1.0;
                        P = ePa[0]+s*(ePa[1]+s*(ePa[2]+s*(ePa[3]+s*(ePa[4]+s*(ePa[5]+s*ePa[6])))));
                        Q = 1.0+s*(eQa[0]+s*(eQa[1]+s*(eQa[2]+s*(eQa[3]+s*(eQa[4]+s*eQa[5])))));
                        retval = e_erx + P/Q;
	       } else if (abs_x >= 6.0) 
                        retval = 1.0;
                else                                                    // 1.25 < |x| < 6.0 
                        retval = 1.0-complementaryError(abs_x);
                return (x >= 0.0) ? retval : -retval;
        }

// Coefficients for approximation to  erfc in [1.25,1/.35]
        private final static double eRa[]={
                -9.86494403484714822705e-03,
                -6.93858572707181764372e-01,
                -1.05586262253232909814e01, 
                -6.23753324503260060396e01, 
                -1.62396669462573470355e02, 
                -1.84605092906711035994e02, 
                -8.12874355063065934246e01, 
                -9.81432934416914548592e00};
        private final static double eSa[]={
                1.96512716674392571292e01, 
                1.37657754143519042600e02,
                4.34565877475229228821e02,
                6.45387271733267880336e02,
                4.29008140027567833386e02,
                1.08635005541779435134e02,
                6.57024977031928170135e00,
                -6.04244152148580987438e-02};
// Coefficients for approximation to  erfc in [1/.35,28]
        private final static double eRb[]={
                -9.86494292470009928597e-03, 
                -7.99283237680523006574e-01, 
                -1.77579549177547519889e01, 
                -1.60636384855821916062e02, 
                -6.37566443368389627722e02, 
                -1.02509513161107724954e03, 
                -4.83519191608651397019e02};
        private final static double eSb[]={
                3.03380607434824582924e01, 
                3.25792512996573918826e02, 
                1.53672958608443695994e03,
                3.19985821950859553908e03,
                2.55305040643316442583e03,
                4.74528541206955367215e02,
                -2.24409524465858183362e01};

	/**
        * Complementary error function.
        * Based on C-code for the error function developed at Sun Microsystems.
        * @author Jaco van Kooten
	*/
	public static double complementaryError(double x) {
          	double s,retval,R,S;
                final double abs_x =(x>=0.0 ? x : -x);
                if (abs_x < 1.25)
        		retval = 1.0-error(abs_x);
                else if (abs_x > 28.0)
                        retval=0.0;
                else {						// 1.25 < |x| < 28 
                        s = 1.0/(abs_x*abs_x);
                        if (abs_x < 2.8571428) {                // ( |x| < 1/0.35 ) 
                                R=eRa[0]+s*(eRa[1]+s*(eRa[2]+s*(eRa[3]+s*(eRa[4]+s*(eRa[5]+s*(eRa[6]+s*eRa[7]))))));
        	    		S=1.0+s*(eSa[0]+s*(eSa[1]+s*(eSa[2]+s*(eSa[3]+s*(eSa[4]+s*(eSa[5]+s*(eSa[6]+s*eSa[7])))))));
        		} else {	  				// ( |x| > 1/0.35 )
                                R=eRb[0]+s*(eRb[1]+s*(eRb[2]+s*(eRb[3]+s*(eRb[4]+s*(eRb[5]+s*eRb[6])))));
        	    		S=1.0+s*(eSb[0]+s*(eSb[1]+s*(eSb[2]+s*(eSb[3]+s*(eSb[4]+s*(eSb[5]+s*eSb[6]))))));
 			}
                        retval =  Math.exp(-x*x - 0.5625 + R/S)/abs_x;
                }
                return (x >= 0.0) ? retval : 2.0-retval;
	}
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/WeibullDistribution.java0000644000175000017500000000444311324235205033502 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The WeibullDistribution class provides an object for encapsulating Weibull distributions.
* @version 0.2
* @author Mark Hale
*/
public final class WeibullDistribution extends ProbabilityDistribution {
        private double shape;

        /**
        * Constructs a Weibull distribution.
        * @param sh the shape.
        */
        public WeibullDistribution(double sh) {
                if(sh<=0.0)
                        throw new OutOfRangeException("The shape parameter should be positive.");
                shape=sh;
        }
        /**
        * Returns the shape parameter.
        */
        public double getShapeParameter() {
                return shape;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return SpecialMath.gamma(1.0+1.0/shape);
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return SpecialMath.gamma(1.0+2.0/shape)-getMean()*getMean();
        }
        /**
        * Probability density function of a Weibull distribution.
        * P(X) = s Xs-1 exp(-Xs).
        * @param X should be integer-valued.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                final double XpowShape=Math.pow(X,shape);
                return shape*XpowShape/X*Math.exp(-XpowShape);
        }
        /**
        * Cumulative Weibull distribution function.
        * @param X should be integer-valued.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,Double.MAX_VALUE);
                return 1.0-Math.exp(-Math.pow(X,shape));
        }
        /**
	* Inverse of the cumulative Weibull distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return Math.pow(-Math.log(1.0-probability),1.0/shape);
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/BinomialDistribution.java0000644000175000017500000000514311324235205033627 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The BinomialDistribution class provides an object for encapsulating binomial distributions.
* @version 0.1
* @author Mark Hale
*/
public final class BinomialDistribution extends ProbabilityDistribution {
        private int n;
        private double p;

        /**
        * Constructs a binomial distribution.
        * @param trials the number of trials.
        * @param prob the probability.
        */
        public BinomialDistribution(int trials,double prob) {
                if(trials<=0)
                        throw new OutOfRangeException("The number of trials should be (strictly) positive.");
                n=trials;
                if(prob<0.0 || prob>1.0)
                        throw new OutOfRangeException("The probability should be between 0 and 1.");
                p=prob;
        }
        /**
        * Returns the number of trials.
        */
        public int getTrialsParameter() {
                return n;
        }
        /**
        * Returns the probability.
        */
        public double getProbabilityParameter() {
                return p;
        }
        /**
        * Returns the mean.
        */
        public double getMean() {
                return n*p;
        }
        /**
        * Returns the variance.
        */
        public double getVariance() {
                return n*p*(1.0-p);
        }
        /**
        * Probability density function of a binomial distribution.
        * @param X should be integer-valued.
        * @return the probability that a stochastic variable x has the value X, i.e. P(x=X).
        */
        public double probability(double X) {
                checkRange(X,0.0,n);
                return ExtraMath.binomial(n,X)*Math.pow(p,X)*Math.pow(1.0-p,n-X);
        }
        /**
        * Cumulative binomial distribution function.
        * @param X should be integer-valued.
	* @return the probability that a stochastic variable x is less then X, i.e. P(x<X).
        */
        public double cumulative(double X) {
                checkRange(X,0.0,n);
                double sum=0.0;
                for(double i=0.0;i<=X;i++)
                        sum+=probability(i);
                return sum;
        }
        /**
	* Inverse of the cumulative binomial distribution function.
        * @return the value X for which P(x<X).
        */
        public double inverse(double probability) {
                checkRange(probability);
                return Math.floor(findRoot(probability,n/2.0,0.0,n));
        }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jscistats/NormalDistribution.java0000644000175000017500000000742311324235205033330 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jscistats;


/**
* The NormalDistribution class provides an object for encapsulating normal distributions.
* @version 1.1
* @author Jaco van Kooten
*/
public final class NormalDistribution extends ProbabilityDistribution implements NumericalConstants {
        private double mean,variance;
        private double pdfDenominator,cdfDenominator;

        /**
        * Constructs the standard normal distribution (zero mean and unity variance).
        */
        public NormalDistribution() {
                this(0.0,1.0);
        }
        /**
        * Constructs a normal distribution.
        * @param mu the mean.
        * @param var the variance.
        */
        public NormalDistribution(double mu,double var) {
                mean=mu;
                if(var<=0.0) 
                        throw new OutOfRangeException("The variance should be (strictly) positive.");
                variance=var;
                pdfDenominator=SQRT2PI*Math.sqrt(variance);
                cdfDenominator=SQRT2*Math.sqrt(variance);
        }
        /**
        * Constructs a normal distribution from a data set.
        * @param array a sample.
        * @author Mark Hale
        */
        public NormalDistribution(double array[]) {
                double sumX=array[0];
                double sumX2=array[0]*array[0];
                for(int i=1;i 1)
    	return 0;
        y = Misc.beta(a, b);
/*!*     a = pow(x, a - 1);  *!*/
        a = java.lang.Math.pow(x, a - 1);
/*!*     b = pow(1.0 - x, b - 1.0);  *!*/
        b = java.lang.Math.pow(1.0 - x, b - 1.0);
    /*!* #ifndef IEEE_754 /*4!*/
	//        if(errno) return Double.NaN;
    /*!* #endif /*4!*/
        return a * b / y;
    }

    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double pin, double qin);
     *
     *  DESCRIPTION
     *
     *    Returns distribution function of the Beta distribution.
     *    (The incomplete Beta ratio).
     *
     *  NOTES
     *
     *    This routine is a translation into C of a Fortran subroutine
     *    by W. Fullerton of Los Alamos Scientific Laboratory.
     *
     *  REFERENCE
     *
     *    Bosten and Battiste (1974).
     *    Remark on Algorithm 179,
     *    CACM 17, p153, (1974).
     */
    
    /*!* #include "DistLib.h" /*4!*/


    
    static double  pbeta_raw(double x, double pin, double qin)
    {
        double ans, c, finsum, p, ps, p1, q, term, xb, xi, y;
        int n, i, ib;
	double eps = 0;
	double alneps = 0;
	double sml = 0;
	double alnsml = 0;
    
        if (eps == 0) {
            eps = Misc.d1mach(3);
/*!*         alneps = log(eps);  *!*/
            alneps = java.lang.Math.log(eps);
            sml = Misc.d1mach(1);
/*!*         alnsml = log(sml);  *!*/
            alnsml = java.lang.Math.log(sml);
        }
    
        y = x;
        p = pin;
        q = qin;
    
        /* swap tails if x is greater than the mean */
    
        if (p / (p + q) < x) {
            y = 1 - y;
            p = qin;
            q = pin;
        }
    
        if ((p + q) * y / (p + 1) < eps) {
    
    	/* tail approximation */
    
            ans = 0;
/*!*         xb = p * log(Math.max(y, sml)) - log(p) - Misc.lbeta(p, q);  *!*/
            xb = p * java.lang.Math.log(Math.max(y, sml)) - java.lang.Math.log(p) - Misc.lbeta(p, q);
            if (xb > alnsml && y != 0)
/*!*             ans = exp(xb);  *!*/
                ans = java.lang.Math.exp(xb);
            if (y != x || p != pin)
                ans = 1 - ans;
        }
        else {
    
            /* evaluate the infinite sum first.  term will equal */
            /* y^p / Beta(ps, p) * (1 - ps)-sub-i * y^i / fac(i) */
    
/*!*         ps = q - floor(q);  *!*/
            ps = q - java.lang.Math.floor(q);
            if (ps == 0)
                ps = 1;
/*!*         xb = p * log(y) - Misc.lbeta(ps, p) - log(p);  *!*/
            xb = p * java.lang.Math.log(y) - Misc.lbeta(ps, p) - java.lang.Math.log(p);
            ans = 0;
            if (xb >= alnsml) {
/*!*             ans = exp(xb);  *!*/
                ans = java.lang.Math.exp(xb);
                term = ans * p;
                if (ps != 1) {
                    n = (int) Math.max(alneps/java.lang.Math.log(y), 4.0);
    		for(i=1 ; i<= n ; i++) {
                        xi = i;
                        term = term * (xi - ps) * y / xi;
                        ans = ans + term / (p + xi);
                    }
                }
            }
    
            /* now evaluate the finite sum, maybe. */
    
            if (q > 1) {
/*!*             xb = p * log(y) + q * log(1 - y) - Misc.lbeta(p, q) - log(q);  *!*/
                xb = p * java.lang.Math.log(y) + q * java.lang.Math.log(1 - y) - Misc.lbeta(p, q) - java.lang.Math.log(q);
                ib = (int) Math.max(xb / alnsml, 0.0);
/*!*             term = exp(xb - ib * alnsml);  *!*/
                term = java.lang.Math.exp(xb - ib * alnsml);
                c = 1 / (1 - y);
                p1 = q * c / (p + q - 1);
    
                finsum = 0;
                n = (int) q;
                if (q == n)
                    n = n - 1;
    	    for(i=1 ; i<=n ; i++) {
                    if (p1 <= 1 && term / eps <= finsum)
                        break;
                    xi = i;
                    term = (q - xi + 1) * c * term / (p + q - xi);
                    if (term > 1) {
                        ib = ib - 1;
                        term = term * sml;
    		}
                    if (ib == 0)
                        finsum = finsum + term;
                }
                ans = ans + finsum;
            }
            if (y != x || p != pin)
                ans = 1 - ans;
            ans = Math.max(Math.min(ans, 1.0), 0.0);
        }
        return ans;
    }
    
    public static double cumulative(double x, double pin, double qin)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(pin) || Double.isNaN(qin))
    	return x + pin + qin;
    /*!* #endif /*4!*/
    
        if (pin <= 0 || qin <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0)
    	return 0;
        if (x >= 1)
    	return 1;
        return pbeta_raw(x, pin, qin);
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
    
     * Reference:
     * Cran, G. W., K. J. Martin and G. E. Thomas (1977).
     *	Remark AS R19 and Algorithm AS 109,
     *	Applied Statistics, 26(1), 111-114.
     * Remark AS R83 (v.39, 309-310) and the correction (v.40(1) p.236)
     *	have been incorporated in this version.
     */
    
    
    /*!* #include "DistLib.h" /*4!*/
    
    static double  zero = 0.0; 
    
    /* set the exponent of accu to -2r-2 for r digits of accuracy */
    /*!* #ifdef OLD 
      static double  acu = 1.0e-32; 
      static double  lower = 0.0001; 
      static double  upper = 0.9999; 
    *4!*/
    /*!* #else/*---- NEW ---- -- still fails for p = 1e11, q=.5*/ /*4!*/
    
    static double  fpu = 3e-308; 
    /* acu_min:  Minimal value for accuracy 'acu' which will depend on (a,p);
    	     acu_min >= fpu ! */
    static double  acu_min = 1e-300; 
    static double  lower = fpu; 
    static double  upper = 1-2.22e-16; 
    
    /*!* #endif /*4!*/
    
    static double  const1 = 2.30753; 
    static double  const2 = 0.27061; 
    static double  const3 = 0.99229; 
    static double  const4 = 0.04481; 
    
    static volatile double xtrunc;
    
    public static double quantile(double alpha, double p, double q)
    {
    	int swap_tail, i_pb, i_inn;
    	double a, adj, logbeta, g, h, pp, prev, qq, r, s, t, tx, w, y, yprev;
    	double acu;
    	double xinbta;
    
    	/* define accuracy and initialize */
    
    	xinbta = alpha;
    
    	/* test for admissibility of parameters */
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(p) || Double.isNaN(q) || Double.isNaN(alpha))
    		return p + q + alpha;
    /*!* #endif /*4!*/
    	if(p < zero || q < zero || alpha < zero || alpha > 1) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    	if (alpha == zero || alpha == 1)
    		return alpha;
    
    	logbeta = Misc.lbeta(p, q);
    
    	/* change tail if necessary;  afterwards   0 < a <= 1/2	 */
    	if (alpha <= 0.5) {
    		a = alpha;	pp = p; qq = q; swap_tail = 0;
    	} else { /* change tail, swap  p <-> q :*/
    		a = 1 - alpha; pp = q; qq = p; swap_tail = 1;
    	}
    
    	/* calculate the initial approximation */
    
/*!* 	r = sqrt(-log(a * a));  *!*/
    	r = java.lang.Math.sqrt(-java.lang.Math.log(a * a));
    	y = r - (const1 + const2 * r) / (1 + (const3 + const4 * r) * r);
    	if (pp > 1 && qq > 1) {
    		r = (y * y - 3) / 6;
    		s = 1 / (pp + pp - 1);
    		t = 1 / (qq + qq - 1);
    		h = 2 / (s + t);
/*!* 		w = y * sqrt(h + r) / h - (t - s) * (r + 5 / 6 - 2 / (3 * h));  *!*/
    		w = y * java.lang.Math.sqrt(h + r) / h - (t - s) * (r + 5 / 6 - 2 / (3 * h));
/*!* 		xinbta = pp / (pp + qq * exp(w + w));  *!*/
    		xinbta = pp / (pp + qq * java.lang.Math.exp(w + w));
    	} else {
    		r = qq + qq;
    		t = 1 / (9 * qq);
/*!* 		t = r * pow(1 - t + y * sqrt(t), 3);  *!*/
    		t = r * java.lang.Math.pow(1 - t + y * java.lang.Math.sqrt(t), 3);
    		if (t <= zero)
/*!* 			xinbta = 1 - exp((log((1 - a) * qq) + logbeta) / qq);  *!*/
    			xinbta = 1 - java.lang.Math.exp((java.lang.Math.log((1 - a) * qq) + logbeta) / qq);
    		else {
    			t = (4 * pp + r - 2) / t;
    			if (t <= 1)
/*!* 				xinbta = exp((log(a * pp) + logbeta) / pp);  *!*/
    				xinbta = java.lang.Math.exp((java.lang.Math.log(a * pp) + logbeta) / pp);
    			else
    				xinbta = 1 - 2 / (t + 1);
    		}
    	}
    
    	/* solve for x by a modified newton-raphson method, */
    	/* using the function pbeta_raw */
    
    	r = 1 - pp;
    	t = 1 - qq;
    	yprev = zero;
    	adj = 1;
    	if (xinbta < lower)
    	  xinbta = lower;
    	else if (xinbta > upper)
    	  xinbta = upper;
    
    	/* Desired accuracy should depend on  (a,p)
    	 * This is from Remark .. on AS 109, adapted.
    	 * However, it's not clear if this is "optimal" for IEEE double prec.
    
    	 * acu = Math.max(acu_min, pow(10., -25. - 5./(pp * pp) - 1./(a * a)));
    
    	 * NEW: 'acu' accuracy NOT for squared adjustment, but simple;
    	 * ---- i.e.,  "new acu" = sqrt(old acu)
    
    	 */
    	acu = Math.max(acu_min, java.lang.Math.pow(10., -13 - 2.5/(pp * pp) - 0.5/(a * a)));
    	tx = prev = zero;	/* keep -Wall happy */
    
L_converged:	{
    	for (i_pb=0; i_pb < 1000; i_pb++) {
    		y = pbeta_raw(xinbta, pp, qq);
    		/* y = pbeta_raw2(xinbta, pp, qq, logbeta); */
    /*!* #ifdef IEEE_754 /*4!*/
    		if(Double.isInfinite(y))
    /*!* #else /*4!*/
		    //    		if (errno)
    /*!* #endif /*4!*/
		    //    		{ throw new java.lang.ArithmeticException("Math Error: DOMAIN"); return Double.NaN; }
    		y = (y - a) *
/*!* 			exp(logbeta + r * log(xinbta) + t * log(1 - xinbta));  *!*/
    			java.lang.Math.exp(logbeta + r * java.lang.Math.log(xinbta) + t * java.lang.Math.log(1 - xinbta));
    		if (y * yprev <= zero)
    			prev = Math.max(java.lang.Math.abs(adj),fpu);
    		g = 1;
    		for (i_inn=0; i_inn < 1000;i_inn++) {
    		  adj = g * y;
    		  if (java.lang.Math.abs(adj) < prev) {
    		    tx = xinbta - adj; /* trial new x */
    		    if (tx >= zero && tx <= 1) {
    		      if (prev <= acu)	  break L_converged;
    		      if (java.lang.Math.abs(y) <= acu) break L_converged;
    		      if (tx != zero && tx != 1)
    			break;
    		    }
    		  }
    		  g /= 3;
    		}
    		xtrunc = tx;	/* this prevents trouble with excess FPU */
    				/* precision on some machines. */
    		if (xtrunc == xinbta)
    			break L_converged;
    		xinbta = tx;
    		yprev = y;
    	}
    	/*-- NOT converged: Iteration count --*/
    	throw new java.lang.ArithmeticException("Math Error: PRECISION");
    }   

    	if (swap_tail==1)
    		xinbta = 1 - xinbta;
    	return xinbta;
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /* Reference:
     * R. C. H. Cheng (1978).
     * Generating Beta variates with nonintegral shape parameters.
     * Communications of the ACM 21, 317-322.
     * (Algorithms BB and BC)
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
/*!* double random(double aa, double bb) *!*/
    public static double random(double aa, double bb, Uniform uniformDistribution)
    {
    	int qsame;
      
	double expmax = 0.0;
	double a=0.0, b=0.0, delta=0.0, r=0.0, s=0.0, t=0.0, u1=0.0;
	double u2=0.0, v=0.0, w=0.0, y=0.0, z=0.0;
	double alpha=0.0, beta=0.0, gamma=0.0, k1=0.0, k2=0.0;
	double olda = -1.0;
	double oldb = -1.0;

    
    
    	if (expmax == 0.0)
/*!* 		expmax = log(Double.MAX_VALUE);  *!*/
    		expmax = java.lang.Math.log(Double.MAX_VALUE);
    
    	/*!* qsame = (olda == aa) && (oldb == bb); *!*/
    	qsame = ( (olda == aa) && (oldb == bb) )?1:0;
    
    	if (!(qsame==1)) {
    		if (aa > 0.0 && bb > 0.0) {
    			olda = aa;
    			oldb = bb;
    		} else {
    			throw new java.lang.ArithmeticException("Math Error: DOMAIN");
			//    			return Double.NaN;
    		}
    	}

    deliver: {

    	if (Math.min(aa, bb) <= 1.0) {	/* Algorithm BC */
    		if (!(qsame==1)) {
    			a = Math.max(aa, bb);
    			b = Math.min(aa, bb);
    			alpha = a + b;
    			beta = 1.0 / b;
    			delta = 1.0 + a - b;
    			k1 = delta * (0.0138889 + 0.0416667 * b) /
    			    (a * beta - 0.777778);
    			k2 = 0.25 + (0.5 + 0.25 / delta) * b;
    		}
    		for(;;) {
 			u1 = uniformDistribution.random();
 			u2 = uniformDistribution.random();

    			if (u1 < 0.5) {
    				y = u1 * u2;
    				z = u1 * y;
    				if (0.25 * u2 + z - y >= k1)
    					continue;
    			} else {
    				z = u1 * u1 * u2;
    				if (z <= 0.25)
    					break;
    				if (z >= k2)
    					continue;
    			}
/*!* 			v = Beta * log(u1 / (1.0 - u1));  *!*/
    			v = beta * java.lang.Math.log(u1 / (1.0 - u1));
    			if (v <= expmax)
/*!* 				w = a * exp(v);  *!*/
    				w = a * java.lang.Math.exp(v);
    			else
    				w = Double.MAX_VALUE;
/*!* 			if (alpha * (log(alpha / (b + w)) + v) - 1.3862944  *!*/
    			if (alpha * (java.lang.Math.log(alpha / (b + w)) + v) - 1.3862944
/*!* 			    >= log(z))  *!*/
    			    >= java.lang.Math.log(z))
    				break deliver;
    		}
/*!* 		v = Beta * log(u1 / (1.0 - u1));  *!*/
    		v = beta * java.lang.Math.log(u1 / (1.0 - u1));
    		if (v <= expmax)
/*!* 			w = a * exp(v);  *!*/
    			w = a * java.lang.Math.exp(v);
    		else
    			w = Double.MAX_VALUE;
    	} else {		/* Algorithm BB */
    		if (!(qsame==1)) {
    			a = Math.min(aa, bb);
    			b = Math.max(aa, bb);
    			alpha = a + b;
/*!* 			Beta = sqrt((alpha - 2.0) / (2.0 * a * b - alpha));  *!*/
    			beta = java.lang.Math.sqrt((alpha - 2.0) / (2.0 * a * b - alpha));
    			gamma = a + 1.0 / beta;
    		}
    		do {
/*!* 			u1 = uniformDistribution.random();  *!*/
    			u1 = uniformDistribution.random();
/*!* 			u2 = uniformDistribution.random();  *!*/
    			u2 = uniformDistribution.random();
/*!* 			v = Beta * log(u1 / (1.0 - u1));  *!*/
    			v = beta * java.lang.Math.log(u1 / (1.0 - u1));
    			if (v <= expmax)
/*!* 				w = a * exp(v);  *!*/
    				w = a * java.lang.Math.exp(v);
    			else
    				w = Double.MAX_VALUE;
    			z = u1 * u1 * u2;
    			r = gamma * v - 1.3862944;
    			s = a + r - w;
    			if (s + 2.609438 >= 5.0 * z)
    				break;
/*!* 			t = log(z);  *!*/
    			t = java.lang.Math.log(z);
    			if (s > t)
    				break;
    		}
/*!* 		while (r + alpha * log(alpha / (b + w)) < t);  *!*/
    		while (r + alpha * java.lang.Math.log(alpha / (b + w)) < t);
    	}
    
	} // deliver:
    	return (aa != a) ? b / (b + w) : w / (b + w);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Constants.java0000644000175000017500000000774011330004150031763 0ustar  giovannigiovanni/*  DistLib : A C Library of Special Functions
 *  Copyright (C) 1998 R Core Team
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * data translated from C using perl script translate.pl
 * script version 0.00
 */

package org.mathpiper.builtin.library.statdistlib;

/**
 * Class defining constants.
 */

public class Constants { 
        
    /* 30 Decimal-place constants computed with bc -l (scale=32; proper round) */
    
    public static final double  M_SQRT_2 = 1.4142135623730950488016887242097; 
    /* 1/sqrt(2) */
    public static final double  M_1_SQRT_2 = 0.707106781186547524400844362105; 
    /* sqrt(32) */
    public static final double  M_SQRT_32 = 5.656854249492380195206754896838; 
    
    public static final double  M_LN_2 = 0.693147180559945309417232121458176568; 
    public static final double  M_LOG10_2 = 0.301029995663981195213738894724493027; 
    
    public static final double  M_PI   = 3.141592653589793238462643383279502884197169399375; 
    public static final double  M_PI_half = 1.570796326794896619231321691640; 

    /* 1/pi */
    public static final double  M_1_PI =  0.31830988618379067153776752674502872406891929148;

   /* pi/2 */
    public static final double  M_PI_2 =  1.57079632679489661923132169163975144209858469969;

    /* sqrt(pi),  1/sqrt(2pi),  sqrt(2/pi) : */
    public static final double  M_SQRT_PI = 1.772453850905516027298167483341; 
    public static final double  M_1_SQRT_2PI = 0.398942280401432677939946059934; 
    public static final double  M_SQRT_2dPI = 0.79788456080286535587989211986876; 

    /* log(sqrt(pi)) = log(pi)/2 : */
    public static final double  M_LN_SQRT_PI = 0.5723649429247000870717136756765293558; 
    /* log(sqrt(2*pi)) = log(2*pi)/2 : */
    public static final double  M_LN_SQRT_2PI = 0.91893853320467274178032973640562; 
    /* log(sqrt(pi/2)) = log(pi/2)/2 : */
    public static final double  M_LN_SQRT_PId2 = 0.225791352644727432363097614947441; 
        
    public static final double  ME_NONE = 0; 
    public static final double  ME_DOMAIN = 1; 
    public static final double  ME_RANGE = 2; 
    public static final double  ME_NOCONV = 3; 
    public static final double  ME_PRECISION = 4; 
    public static final double  ME_UNDERFLOW = 5; 

    /* constants taken from float.h for gcc 2.90.29 for Linux 2.0 i386  */
    /* -- should match Java since both are supposed to be IEEE 754 compliant */

    /* Radix of exponent representation */
    public static final int    FLT_RADIX   = 2;

    /* Difference between 1.0 and the minimum float/double greater than 1.0 */
    public static final double FLT_EPSILON = 1.19209290e-07F;
    public static final double DBL_EPSILON = 2.2204460492503131e-16; 
    
    /* Number of decimal digits of precision in a float/double */
    public static final int FLT_DIG = 6;
    public static final int DBL_DIG = 15;          

    /* Number of base-FLT_RADIX digits in the significand of a double */
    public static final int FLT_MANT_DIG = 24;
    public static final int DBL_MANT_DIG = 53;

    /* Minimum int x such that FLT_RADIX**(x-1) is a normalised double */
    public static final int FLT_MIN_EXP = -125;
    public static final int DBL_MIN_EXP = -1021;

    /* Maximum int x such that FLT_RADIX**(x-1) is a representable double */
    public static final int FLT_MAX_EXP = 128;
    public static final int DBL_MAX_EXP = 1024;    
    
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Noncentral_t.java0000644000175000017500000000660111376411123032444 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Noncentral_t
  { 
    /*
     *  Algorithm AS 243  Appl. Statist. (1989), Vol.38, No. 1.
     *
     *  Cumulative probability at t of the non-central t-distribution
     *  with df degrees of freedom (may be fractional) and non-centrality
     *  parameter delta.
     *
     *  NOTE
     *
     *    Requires the following auxiliary routines:
     *
     *        lgammafn(x)       - log gamma function
     *        Beta.cumulative(x, a, b)  - incomplete Beta function
     *        Normal.cumulative(x)        - Normal distribution function
     *
     *  CONSTANTS
     *
     *    M_SQRT_2dPI  = 1/ {gamma(1.5) * sqrt(2)} = sqrt(2 / pi)
     *    M_LN_SQRT_PI = ln(sqrt(pi)) = ln(pi)/2
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double t, double df, double delta)
    {
        double a, albeta, b, del, en, errbd, geven, godd;
	double lambda, p, q, rxb, s, tnc, tt, x, xeven, xodd;
        boolean negdel;
    
        /* note - itrmax and errmax may be changed to suit one's needs. */
    
        final double itrmax = 100.1;
        final double errmax = 1.e-12;
    
        final double zero = 0.0;
        final double half = 0.5;
        final double one = 1.0;
        final double two = 2.0;
    
        tnc = zero;
        if (df <= zero) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        tt = t;
        del = delta;
        negdel = false;
        if (t < zero) {
    	negdel = true;
    	tt = -tt;
    	del = -del;
        }
        /* initialize twin series */
        /* (guenther, j. statist. computn. simuln.  vol.6, 199, 1978). */
    
        en = one;
        x = t * t / (t * t + df);
        if (x > zero) {
    	lambda = del * del;
/*!* 	p = half * exp(-half * lambda); *!*/
    	p = half * java.lang.Math.exp(-half * lambda);
    	q = Constants.M_SQRT_2dPI * p * del;
    	s = half - p;
    	a = half;
    	b = half * df;
/*!* 	rxb = pow(one - x, b); *!*/
    	rxb = java.lang.Math.pow(one - x, b);
/*!* 	albeta = Constants.M_LN_SQRT_PI + lgammafn(b) - lgammafn(a + b); *!*/
    	albeta = Constants.M_LN_SQRT_PI + Misc.lgammafn(b) - Misc.lgammafn(a + b);
    	xodd = Beta.cumulative(x, a, b);
/*!* 	godd = two * rxb * exp(a * log(x) - albeta); *!*/
    	godd = two * rxb * java.lang.Math.exp(a * java.lang.Math.log(x) - albeta);
    	xeven = one - rxb;
    	geven = b * x * rxb;
    	tnc = p * xodd + q * xeven;
    
    	/* while(true) until convergence */
    
    	do {
    	    a = a + one;
    	    xodd = xodd - godd;
    	    xeven = xeven - geven;
    	    godd = godd * x * (a + b - one) / a;
    	    geven = geven * x * (a + b - half) / (a + half);
    	    p = p * lambda / (two * en);
    	    q = q * lambda / (two * en + one);
    	    s = s - p;
    	    en = en + one;
    	    tnc = tnc + p * xodd + q * xeven;
    	    errbd = two * s * (xodd - godd);
    	}
    	while (errbd > errmax && en <= itrmax);
        }
        if (en <= itrmax)
    	throw new java.lang.ArithmeticException("Math Error: PRECISION");
        tnc = tnc + Normal.cumulative(- del, zero, one);
        if (negdel)
    	tnc = one - tnc;
        return tnc;
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Wilcox.java0000644000175000017500000001374011376411123031265 0ustar  giovannigiovanni/*
 *  DistLib : A C Library of Special Functions
 *  Copyright (C) 1998 R Core Team
 * 
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 * 
 * data translated from C using perl script translate.pl
 * script version 0.00
 */

package org.mathpiper.builtin.library.statdistlib;

//import org.apache.commons.logging.Log;
//import org.apache.commons.logging.LogFactory;

/**
 * Wrapper of functions for Wilcoxon distribution.
 * 
    
 * This actually the Mann-Whitney Ux statistic.
 */

public class Wilcox {
  //private static Log log = LogFactory.getLog(Wilcox.class);

  public static final int  WILCOX_MMAX = 50; 
  public static final int  WILCOX_NMAX = 50; 

  /**
   * check values for too large and log complaint
   */
  private static boolean checkSizesLarge(final double m, final double n) {
    if (m >= WILCOX_MMAX) {
      //log.info("m should be less than %d\n"+ WILCOX_MMAX);
      return false;
    }
    if (n >= WILCOX_NMAX) {
      //log.info("n should be less than %d\n"+ WILCOX_NMAX);
      return false;
    }
    return true;    
  }
  
  /**
   * round sizes to integer
   */
  private static void roundSizes(double m, double n) {
    m = Math.floor(m + 0.5);
    n = Math.floor(n + 0.5);
  }

  // table of exact cumulative probabilities
  static private double w[][][] = new double[WILCOX_MMAX][WILCOX_NMAX][];

  /**
   *    The density of the Wilcoxon distribution.
   */
  static private double cwilcox(int k, int m, int n) {
    int u = m * n;
    int c = (int)(u / 2);

    if ((k < 0) || (k > u)) return(0);
    if (k > c) k = u - k;
    int i = m;
    int j = n;
    if (m >= n) {
      i = n;
      j = m;
    }
    if (w[i][j] == null) {
      w[i][j] = new double[c + 1];
      for (int l = 0; l <= c; l++)
        w[i][j][l] = -1;
    }
    if (w[i][j][k] < 0) {
      if ((i == 0) || (j == 0))
        w[i][j][k] = (k == 0)?1.0:0.0;
      else
        w[i][j][k] = cwilcox(k - n, m - 1, n) + cwilcox(k, m, n - 1);
    }
    return(w[i][j][k]);
  }

  /**
   * density function
   * @param x
   * @param m
   * @param n
   * @return density
   */
  public static double density(double x, double m, double n) {
    /*!* #ifdef IEEE_754 /*4!*/
    /* NaNs propagated correctly */
    if (Double.isNaN(x) || Double.isNaN(m) || Double.isNaN(n)) return x + m + n;
    /*!* #endif /*4!*/
    roundSizes(m,n);
    if (m <= 0 || n <= 0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //        return Double.NaN;
    }
    if (!checkSizesLarge(m,n)) return Double.NaN;
    
    /*!*   x = floor(x + 0.5); *!*/
    x = java.lang.Math.floor(x + 0.5);
    if ((x < 0) || (x > m * n))
      return 0;
    /*!*   return(cwilcox(x, m, n) / choose(m + n, n)); *!*/
    return(cwilcox((int) x, (int) m, (int) n) / Misc.choose(m + n, n));
  }

  /**
   * Cumulative distribution function of the Wilcoxon distribution.
   */
  public static double cumulative(double x, double m, double n) {

    /*!* #ifdef IEEE_754 /*4!*/
    if (Double.isNaN(x) || Double.isNaN(m) || Double.isNaN(n))
      return x + m + n;
    if (Double.isInfinite(m) || Double.isInfinite(n)) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //        return Double.NaN;
    }
    /*!* #endif /*4!*/
    roundSizes(m,n);
    if (m <= 0 || n <= 0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //        return Double.NaN;
    }
    if (!checkSizesLarge(m,n)) return Double.NaN;
    /*!*   x = floor(x + 0.5); *!*/
    x = java.lang.Math.floor(x + 0.5);
    if (x < 0.0) return 0;
    if (x >= m * n) return 1;
    double p = 0.0;
    for (int i = 0; i <= x; i++)
      p += density(i, m, n);
    return(p);
  }

  /**
   * The quantile function of the Wilcoxon distribution.
   */
  public static double  quantile(double x, double m, double n) {

    /*!* #ifdef IEEE_754 /*4!*/
    if (Double.isNaN(x) || Double.isNaN(m) || Double.isNaN(n))
      return x + m + n;
    if(Double.isInfinite(x) || Double.isInfinite(m) || Double.isInfinite(n)) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //    	return Double.NaN;
    }
    /*!* #endif /*4!*/

    roundSizes(m,n);
    if (x < 0 || x > 1 || m <= 0 || n <= 0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //    	return Double.NaN;
    };
    if (!checkSizesLarge(m,n)) return Double.NaN;

    if (x == 0) return(0.0);
    if (x == 1) return(m * n);
    double p = 0.0;
    double q = 0.0;
    for (;;) {
      /* Don't call cumulative() for efficiency */
      p += density(q, m, n);
      if (p >= x)
        return(q);
      q++;
    }
  }

  /**
   *    Random variates from the Wilcoxon distribution.
   */
  public static double random(double m, double n) {

    /*!* #ifdef IEEE_754 /*4!*/
    /* NaNs propagated correctly */
    if (Double.isNaN(m) || Double.isNaN(n)) return(m + n);
    /*!* #endif /*4!*/
    roundSizes(m,n);
    if ((m < 0) || (n < 0)) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
      //        return Double.NaN;
    }
    if ((m == 0) || (n == 0))
      return(0);
    double r = 0.0;
    int k = (int) (m + n);
    int[] x = new int[k];
    for (int i = 0; i < k; i++)
      x[i] = i;
    for (int i = 0; i < n; i++) {
      /*!*     j = floor(k * sunif()); *!*/
      int j = (int) java.lang.Math.floor(k * Uniform.random());
      r += x[j];
      x[j] = x[--k];
    }
    return(r - n * (n - 1) / 2);
  }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/NoncentralChiSquare.java0000644000175000017500000002110311376411123033720 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class NoncentralChiSquare
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(x, df, lambda);
     *
     *  DESCRIPTION
     *
     *    The density of the noncentral Chisquare distribution with
     *    "df" degrees of freedom and noncentrality parameter "lambda".
     *
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double df, double lambda)
    {
    	double dens, i, lambda2, psum, sum, weight;
    	final int maxiter = 100;
    	final double eps = 1.e-14;
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(df) || Double.isNaN(lambda))
    		return x + df + lambda;
    /*!* #endif /*4!*/
    
    	if (lambda < 0 || df <= 0) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    	}
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isInfinite(df) || Double.isInfinite(lambda)) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    /*!* #endif /*4!*/
    
    	if(x <= 0) return 0;
    
    	dens = Chisquare.density(x, df);
    	if(lambda == 0)
    		return dens;
    
    	lambda2 = 0.5 * lambda;
/*!* 	weight = exp(-lambda2); *!*/
    	weight = java.lang.Math.exp(-lambda2);
    	sum = weight * dens;
    	psum = weight;
    	for(i=1 ; i t=%12g\n",v,x2,f2,t); *!*/
	//        REprintf("\t v=java.lang.Math.exp(-th/2)=%12g, x/2=%12g, f/2=%12g ==> t=%12g\n",v,x2,f2,t);
    /*!* #endif /*4!*/
    
        /* check if (f+2n) is greater than x */
    
        flag = false;
        n = 1; twon = n*2;
    L_End: for(;;) {
    /*!* #ifdef DEBUG_pnch /*4!*/
	    //    	REprintf(" _OL_: n=%d",n);
    /*!* #endif /*4!*/
    	if (!(f + twon - x > zero)) {
    	    /* evaluate the next term of the */
    	    /* expansion and then the partial sum */
    	    u *= lam / n;
    	    v += u;
    	    t *= x / (f + twon);
    	    term = v * t;
    	    ans += term;
    	    n++; twon = n*2;
	}
	else
	    {
		/* find the error bound and check for convergence */
		flag = true;
		
		for(;;) {
		    /*!* #ifdef DEBUG_pnch /*4!*/
		    //	    REprintf(" il: n=%d",n);
		    /*!* #endif /*4!*/
		    
		    bound = t * x / (f + twon - x);
		    /*!* #ifdef DEBUG_pnch /*4!*/
		    //    	    REprintf("\tL10: n=%d; term=%12g; bound=%12g\n",n,term,bound);
		    /*!* #endif /*4!*/
		    if (bound <= errmax || n > itrmax)
			break L_End;
		/* evaluate the next term of the */
		/* expansion and then the partial sum */
		u *= lam / n;
		v += u;
		t *= x / (f + twon);
		term = v * t;
		ans += term;
		n++; twon = n*2;
		}    
		
	    } 
    }// L_End:
        if (bound > errmax)
	    throw new java.lang.ArithmeticException("Math Error: PRECISION");
	/*!* #ifdef DEBUG_pnch /*4!*/
	//        REprintf("\tL_End: n=%d; term=%12g; bound=%12g\n",n,term,bound);
	/*!* #endif /*4!*/
	        return ans;
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double p, double n, double lambda)
    {
    	double ux, lx, nx;
    	double acu = 1.0e-12;
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(p) || Double.isNaN(n) || Double.isNaN(lambda))
    		return p + n + lambda;
    	if (Double.isInfinite(n)) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    /*!* #endif /*4!*/
/*!* 	n = floor(n + 0.5); *!*/
    	n = java.lang.Math.floor(n + 0.5);
    	if (p < 0 || p >= 1 || n < 1 || lambda < 0) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    	if (p == 0)
    		return 0;
    	for (ux = 1.0; cumulative(ux, n, lambda) < p; ux *= 2);
    	for (lx = ux; cumulative(lx, n, lambda) > p; lx *= 0.5);
    	do {
    		nx = 0.5 * (lx + ux);
    		if (cumulative(nx, n, lambda) > p)
    			ux = nx;
    		else
    			lx = nx;
    	}
    	while ((ux - lx) / nx > acu);
    	return 0.5 * (ux + lx);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/NoncentralBeta.java0000644000175000017500000001430711376411123032717 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class NoncentralBeta
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double a, double b, double lambda);
     *
     *  DESCRIPTION
     *
     *    Computes the density of the noncentral Beta distribution with
     *    noncentrality parameter lambda.  The noncentral Beta distribution
     *    has density:
     *
     *                     Inf
     *        f(x|a,b,d) = SUM p(i) * B(a+i,b) * x^(a+i-1) * (1-x)^(b-1)
     *                     i=0
     *
     *    where:
     *
     *              p(k) = exp(-lambda) lambda^k / k!
     *
     *            B(a,b) = Gamma(a+b) / (Gamma(a) * Gamma(b))
     *
     *
     *    This can be computed efficiently by using the recursions:
     *
     *            p(k+1) = (lambda/(k+1)) * p(k-1)
     *
     *        B(a+k+1,b) = ((a+b+k)/(a+k)) * B(a+k,b)
     *
     *    The summation of the series continues until
     *
     *              psum = p(0) + ... + p(k)
     *
     *    is close to 1.  Here we continue until 1 - psum < epsilon,
     *    with epsilon set close to the relative machine precision.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double a, double b, double lambda)
    {
    	double k, lambda2, psum, sum, term, weight;
    	final double eps = 1.e-14;
    	final int maxiter = 200;
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(a) || Double.isNaN(b) || Double.isNaN(lambda))
    		return x + a + b + lambda;
    /*!* #endif /*4!*/
    
    	if (lambda < 0 || a <= 0 || b <= 0) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    	}
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isInfinite(a) || Double.isInfinite(b) || Double.isInfinite(lambda)) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    /*!* #endif /*4!*/
    
    	if(x <= 0) return 0;
    
    	term = Beta.density(x, a, b);
    	if(lambda == 0)
    		return term;
    
    	lambda2 = 0.5 * lambda;
/*!* 	weight = exp(- lambda2); *!*/
    	weight = java.lang.Math.exp(- lambda2);
    	sum = weight * term;
    	psum = weight;
    	for(k=1 ; k<=maxiter ; k++) {
    		weight = weight * lambda2 / k;
    		term = term * x * (a + b) / a;
    		sum = sum + weight * term;
    		psum = psum + weight;
    		a = a + 1;
    		if(1 - psum < eps) break;
    	}
    	return sum;
    }
    /*
     *  Algorithm AS 226 Appl. Statist. (1987) Vol. 36, No. 2
     *  Incorporates modification AS R84 from AS Vol. 39, pp311-2, 1990
     *
     *  Returns the cumulative probability of x for the non-central
     *  Beta distribution with parameters a, b and non-centrality lambda.
     *
     *  Auxiliary routines required:
     *    lgamma - log-gamma function
     *    pbeta  - incomplete-Beta function
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double a, double b, double lambda)
    {
        double a0, ans, ax, lbeta, c, errbd, gx, q, sumq, temp, x0;
        int j;
    
        final double zero = 0;
        final double one = 1;
        final double half = 0.5;
    
            /* change errmax and itrmax if desired */
    
        final double ualpha = 5.0;
        final double errmax = 1.0e-6;
        final int itrmax = 100;
    
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(a) || Double.isNaN(b) || Double.isNaN(lambda))
    	return x + a + b + lambda;
    /*!* #endif /*4!*/
    
        if (lambda < zero || a <= zero || b <= zero) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    
        if (x <= zero) return 0;
        if(x >= one) return 1;
    
        c = lambda * half;
    
            /* initialize the series */
    
/*!*     x0 = floor(fmax2(c - ualpha * sqrt(c), zero)); *!*/
        x0 = java.lang.Math.floor(Math.max(c - ualpha * java.lang.Math.sqrt(c), zero));
        a0 = a + x0;
/*!*     lbeta = lgammafn(a0) + lgammafn(b) - lgammafn(a0 + b); *!*/
        lbeta = Misc.lgammafn(a0) + Misc.lgammafn(b) - Misc.lgammafn(a0 + b);
        temp = Beta.cumulative(x, a0, b);
/*!*     gx = exp(a0 * log(x) + b * log(one - x) - lbeta - log(a0)); *!*/
        gx = java.lang.Math.exp(a0 * java.lang.Math.log(x) + b * java.lang.Math.log(one - x) - lbeta - java.lang.Math.log(a0));
        if (a0 > a)
/*!* 	q = exp(-c + x0 * log(c) - lgammafn(x0 + one)); *!*/
    	q = java.lang.Math.exp(-c + x0 * java.lang.Math.log(c) - Misc.lgammafn(x0 + one));
        else
/*!* 	q = exp(-c); *!*/
    	q = java.lang.Math.exp(-c);
    
        ax = q * temp;
        sumq = one - q;
        ans = ax;
    
            /* recur over subsequent terms */
            /* until convergence is achieved */
        j = 0;
        do {
    	j++;
    	temp += - gx;
    	gx *= x * (a + b + j - one) / (a + j);
    	q *= c / j;
    	sumq += - q;
    	ax = temp * q;
    	ans += ax;
    	errbd = (temp - gx) * sumq;
        }
        while (errbd > errmax && j < itrmax);
    
        if (errbd > errmax) {
    	throw new java.lang.ArithmeticException("Math Error: PRECISION");
        }
        return ans;
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Uniform.java0000644000175000017500000000541711376411123031441 0ustar  giovannigiovanni/*  DistLib : A C Library of Special Functions
 *  Copyright (C) 1998 Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *  
 * data translated from C using perl script translate.pl
 * script version 0.00
 */
package org.mathpiper.builtin.library.statdistlib;

import org.mathpiper.builtin.library.statdistlib.rng.WichmannHill;

/**
 * Uniform distribution over an interval.
 */

public class Uniform {
  
  /**
   * density of the Uniform distribution.
   */
  public static double density(double x, double a, double b) {
    if (Double.isNaN(x) || Double.isNaN(a) || Double.isNaN(b))
      return x + a + b;
    if (b <= a) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (a <= x && x <= b)
      return 1.0 / (b - a);
    return 0.0;
  }
  
  /**
   * distribution function of the Uniform distribution.
   */
  public static double cumulative(double x, double a, double b) {
    if (Double.isNaN(x) || Double.isNaN(a) || Double.isNaN(b))
      return x + a + b;
    if (b <= a) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (x <= a)
      return 0.0;
    if (x >= b)
      return 1.0;
    return (x - a) / (b - a);
  }
  
  /**
   * quantile function of the Uniform distribution.
   */
  public static double quantile(double x, double a, double b) {
    if (Double.isNaN(x) || Double.isNaN(a) || Double.isNaN(b))
      return x + a + b;
    if (b <= a || x < 0 || x > 1) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    return a + x * (b - a);
  }
  
  /**
   *  Random variates from the Uniform distribution.
   */
  public static double random(double a, double b) {
    if (Double.isInfinite(a) || Double.isInfinite(b) || b < a) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (a == b) 
      return a;
    else 
      return a + (b - a) * random();
  }
  
  /**
   * Generator used during random() call. Can be set.
   */
  public static StdUniformRng uniRng = new WichmannHill();
  
  /**
   * generate standard Uniform random variate
   */
  public static double random() {
    return uniRng.random();
  }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Geometric.java0000644000175000017500000001652111376411123031736 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Geometric
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double p);
     *
     *  DESCRIPTION
     *
     *    The density of the Geometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(p)) return x + p;
    /*!* #endif /*4!*/
        if (p <= 0 || p >= 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
        if (x < 0)
    	return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isInfinite(x)) return 1;
    /*!* #endif /*4!*/
/*!*     return p * pow(1 - p, x); *!*/
        return p * java.lang.Math.pow(1 - p, x);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double p);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the Geometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(p))
    	return x + p;
    /*!* #endif /*4!*/
/*!*     x = floor(x); *!*/
        x = java.lang.Math.floor(x);
        if(p <= 0 || p >= 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x < 0.0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isInfinite(x)) return 1;
    /*!* #endif /*4!*/
/*!*     return 1 - pow(1 - p, x + 1); *!*/
        return 1 - java.lang.Math.pow(1 - p, x + 1);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double p);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Geometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(p))
    	return x + p;
        if (x < 0 || x > 1 || p <= 0 || p > 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x == 1) return Double.POSITIVE_INFINITY;
    /*!* #else /*4!*/
        if (x < 0 || x >= 1 || p <= 0 || p > 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
        if (x == 0) return 0;
/*!*     return ceil(log(1 - x) / log(1.0 - p) - 1); *!*/
        return java.lang.Math.ceil(java.lang.Math.log(1 - x) / java.lang.Math.log(1.0 - p) - 1);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka and the R Core Team.
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double p);
     *
     *  DESCRIPTION
     *
     *    Random variates from the Geometric distribution.
     *
     *  NOTES
     *
     *    We generate lambda as Exponential with scale parameter
     *    p / (1 - p).  Return a Poisson deviate with mean lambda.
     *
     *  REFERENCE
     *
     *    Devroye, L. (1980).
     *    Non-Uniform Random Variate Generation.
     *    New York: Springer-Verlag.
     *    Page 480.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double p, Uniform uniformDistribution)
    {
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isNaN(p) ||
    /*!* #endif /*4!*/
    	p <= 0 || p >= 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        return Poisson.random(Exponential.random( uniformDistribution ) * ((1 - p) / p), uniformDistribution);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Gamma.java0000644000175000017500000005156411376411123031050 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */

public class Gamma
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    Computes the density of the Gamma distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double shape, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(shape) || Double.isNaN(scale))
    	return x + shape + scale;
    /*!* #endif /*4!*/
        if (shape <= 0 || scale <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x < 0)
    	return 0;
        if (x == 0) {
    	if (shape < 1) {
    	    throw new java.lang.ArithmeticException("Math Error: RANGE");
	    //    	    return Double.POSITIVE_INFINITY;
    	}
    	if (shape > 1) {
    	    return 0;
    	}
    	return 1 / scale;
        }
        x = x / scale;
/*!*     return exp((shape - 1) * log(x) - lgammafn(shape) - x) / scale; *!*/
        return java.lang.Math.exp((shape - 1) * java.lang.Math.log(x) - Misc.lgammafn(shape) - x) / scale;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double a, double scale);
     *
     *  DESCRIPTION
     *
     *    This function computes the distribution function for the
     *    Gamma distribution with shape parameter a and scale parameter
     *    scale.  This is also known as the incomplete Gamma function.
     *    See Abramowitz and Stegun (6.5.1) for example.
     *
     *  NOTES
     *
     *    This function is an adaptation of Algorithm 239 from the
     *    Applied Statistics Series.  The algorithm is faster than
     *    those by W. Fullerton in the FNLIB library and also the
     *    TOMS 542 alorithm of W. Gautschi.  It provides comparable
     *    accuracy to those algorithms and is considerably simpler.
     *
     *  REFERENCES
     *
     *    Algorithm 239, Incomplete Gamma Function
     *    Applied Statistics 37, 1988.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static private double
        third = 1.0 / 3.0,
        zero = 0.0,
        one = 1.0,
        two = 2.0,
        oflo = 1.0e+37,
        three = 3.0,
        nine = 9.0,
        xbig = 1.0e+8,
        plimit = 1000.0e0,
        elimit = -88.0e0;
    
    public static double  cumulative(double x, double p, double scale)
    {
        double pn1, pn2, pn3, pn4, pn5, pn6, arg, c, rn, a, b, an;
        double sum;
    
        /* check that we have valid values for x and p */
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(p) || Double.isNaN(scale))
    	return x + p + scale;
    /*!* #endif /*4!*/
        if(p <= zero || scale <= zero) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        x = x / scale;
        if (x <= zero)
    	return 0.0;
    
        /* use a Normal approximation if p > plimit */
    
        if (p > plimit) {
/*!* 	pn1 = sqrt(p) * three * (pow(x/p, third) + one / (p * nine) - one); *!*/
    	pn1 = java.lang.Math.sqrt(p) * three * (java.lang.Math.pow(x/p, third) + one / (p * nine) - one);
    	return Normal.cumulative(pn1, 0.0, 1.0);
        }
    
        /* if x is extremely large compared to p then return 1 */
    
        if (x > xbig)
    	return one;
    
        if (x <= one || x < p) {
    
    	/* use pearson's series expansion. */
    
/*!* 	arg = p * log(x) - x - lgammafn(p + one); *!*/
    	arg = p * java.lang.Math.log(x) - x - Misc.lgammafn(p + one);
    	c = one;
    	sum = one;
    	a = p;
    	do {
    	    a = a + one;
    	    c = c * x / a;
    	    sum = sum + c;
    	} while (c > Constants.DBL_EPSILON);
/*!* 	arg = arg + log(sum); *!*/
    	arg = arg + java.lang.Math.log(sum);
    	sum = zero;
    	if (arg >= elimit)
/*!* 	    sum = exp(arg); *!*/
    	    sum = java.lang.Math.exp(arg);
        } else {
    
    	/* use a continued fraction expansion */
    
/*!* 	arg = p * log(x) - x - lgammafn(p); *!*/
    	arg = p * java.lang.Math.log(x) - x - Misc.lgammafn(p);
    	a = one - p;
    	b = a + x + one;
    	c = zero;
    	pn1 = one;
    	pn2 = x;
    	pn3 = x + one;
    	pn4 = x * b;
    	sum = pn3 / pn4;
    	for (;;) {
    	    a = a + one;
    	    b = b + two;
    	    c = c + one;
    	    an = a * c;
    	    pn5 = b * pn3 - an * pn1;
    	    pn6 = b * pn4 - an * pn2;
/*!* 	    if (fabs(pn6) > zero) { *!*/
    	    if (java.lang.Math.abs(pn6) > zero) {
    		rn = pn5 / pn6;
/*!* 		if (fabs(sum - rn) <= fmin2(Constants.DBL_EPSILON, Constants.DBL_EPSILON * rn)) *!*/
    		if (java.lang.Math.abs(sum - rn) <= Math.min(Constants.DBL_EPSILON, Constants.DBL_EPSILON * rn))
    		    break;
    		sum = rn;
    	    }
    	    pn1 = pn3;
    	    pn2 = pn4;
    	    pn3 = pn5;
    	    pn4 = pn6;
/*!* 	    if (fabs(pn5) >= oflo) { *!*/
    	    if (java.lang.Math.abs(pn5) >= oflo) {
    
                    /* re-scale the terms in continued fraction */
    		/* if they are large */
    
    		pn1 = pn1 / oflo;
    		pn2 = pn2 / oflo;
    		pn3 = pn3 / oflo;
    		pn4 = pn4 / oflo;
    	    }
    	}
/*!* 	arg = arg + log(sum); *!*/
    	arg = arg + java.lang.Math.log(sum);
    	sum = one;
    	if (arg >= elimit)
/*!* 	    sum = one - exp(arg); *!*/
    	    sum = one - java.lang.Math.exp(arg);
        }
        return sum;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double p, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    Compute the quantile function of the Gamma distribution.
     *
     *  NOTES
     *
     *    This function is based on the Applied Statistics
     *    Algorithm AS 91 and AS 239.
     *
     *  REFERENCES
     *
     *    Best, D. J. and D. E. Roberts (1975).
     *    Percentage Points of the Chi-Squared Disribution.
     *    Applied Statistics 24, page 385.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static private double  C7 = 4.67; 
    static private double  C8 = 6.66; 
    static private double  C9 = 6.73; 
    static private double  C10 = 13.32; 
    
    static private double  C11 = 60; 
    static private double  C12 = 70; 
    static private double  C13 = 84; 
    static private double  C14 = 105; 
    static private double  C15 = 120; 
    static private double  C16 = 127; 
    static private double  C17 = 140; 
    static private double  C18 = 1175; 
    static private double  C19 = 210; 
    
    static private double  C20 = 252; 
    static private double  C21 = 2264; 
    static private double  C22 = 294; 
    static private double  C23 = 346; 
    static private double  C24 = 420; 
    static private double  C25 = 462; 
    static private double  C26 = 606; 
    static private double  C27 = 672; 
    static private double  C28 = 707; 
    static private double  C29 = 735; 
    
    static private double  C30 = 889; 
    static private double  C31 = 932; 
    static private double  C32 = 966; 
    static private double  C33 = 1141; 
    static private double  C34 = 1182; 
    static private double  C35 = 1278; 
    static private double  C36 = 1740; 
    static private double  C37 = 2520; 
    static private double  C38 = 5040; 
    
    static private double  EPS0 = 5e-7/* originally: IDENTICAL to EPS2; not clear why */; 
    static private double  EPS1 = 1e-2; 
    static private double  EPS2 = 5e-7; 
    static private double  MAXIT = 20; 
    
    static private double  pMIN = 0.000002; 
    static private double  pMAX = 0.999998; 
    
    public static double  quantile(double p, double alpha, double scale)
    {
        double a, b, c, ch, g, p1, v;
        double p2, q, s1, s2, s3, s4, s5, s6, t=0.0, x;
        int i;
    
        /* test arguments and initialise */
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(p) || Double.isNaN(alpha) || Double.isNaN(scale))
    	return p + alpha + scale;
    /*!* #endif /*4!*/
    
        if (p < 0 || p > 1 || alpha <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (/* 0 <= */ p < pMIN) return 0;
        if (/* 1 >= */ p > pMAX) return Double.POSITIVE_INFINITY;
    
        v = 2*alpha;
    
        c = alpha-1;
/*!*     g = lgammafn(alpha);!!!COMMENT!!! *!*/
        g = Misc.lgammafn(alpha);/* log Gamma(v/2) */
    
/*!*     if(v < (-1.24)*log(p)) { *!*/
        if(v < (-1.24)*java.lang.Math.log(p)) {
          /* starting approximation for small chi-squared */
    
/*!* 	ch = pow(p*alpha*exp(g+alpha*Constants.M_LN_2), 1/alpha); *!*/
    	ch = java.lang.Math.pow(p*alpha*java.lang.Math.exp(g+alpha*Constants.M_LN_2), 1/alpha);
    	if(ch < EPS0) {
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    
        } else if(v > 0.32) {
    
    	/* starting approximation using Wilson and Hilferty estimate */
    
    	x = Normal.quantile(p, 0, 1);
    	p1 = 0.222222/v;
/*!* 	ch = v*pow(x*sqrt(p1)+1-p1, 3); *!*/
    	ch = v*java.lang.Math.pow(x*java.lang.Math.sqrt(p1)+1-p1, 3);
    
    	/* starting approximation for p tending to 1 */
    
    	if( ch > 2.2*v + 6 )
/*!* 	    ch = -2*(log(1-p) - c*log(0.5*ch) + g); *!*/
    	    ch = -2*(java.lang.Math.log(1-p) - c*java.lang.Math.log(0.5*ch) + g);
    
        } else { /* starting approximation for v <= 0.32 */
    
    	ch = 0.4;
/*!* 	a = log(1-p) + g + c*Constants.M_LN_2; *!*/
    	a = java.lang.Math.log(1-p) + g + c*Constants.M_LN_2;
    	do {
    	    q = ch;
    	    p1 = 1+ch*(C7+ch);
    	    p2 = ch*(C9+ch*(C8+ch));
    	    t = -0.5 +(C7+2*ch)/p1 - (C9+ch*(C10+3*ch))/p2;
/*!* 	    ch -= (1- exp(a+0.5*ch)*p2/p1)/t; *!*/
    	    ch -= (1- java.lang.Math.exp(a+0.5*ch)*p2/p1)/t;
/*!* 	} while(fabs(q/ch - 1) > EPS1); *!*/
    	} while(java.lang.Math.abs(q/ch - 1) > EPS1);
        }
    
        /* algorithm AS 239 and calculation of seven term taylor series */
    
        for( i=1 ; i <= MAXIT ; i++ ) {
    	q = ch;
    	p1 = 0.5*ch;
    	p2 = p - cumulative(p1, alpha, 1);
    /*!* #ifdef IEEE_754 /*4!*/
    	if(Double.isInfinite(p2))
    /*!* #else /*4!*/
	    //    	if((!!!!fixme!!!!) != 0)
    /*!* #endif /*4!*/
	    //    		return Double.NaN;
    
/*!* 	t = p2*exp(alpha*Constants.M_LN_2+g+p1-c*log(ch)); *!*/
    	t = p2*java.lang.Math.exp(alpha*Constants.M_LN_2+g+p1-c*java.lang.Math.log(ch));
    	b = t/ch;
    	a = 0.5*t-b*c;
    	s1 = (C19+a*(C17+a*(C14+a*(C13+a*(C12+C11*a)))))/C24;
    	s2 = (C24+a*(C29+a*(C32+a*(C33+C35*a))))/C37;
    	s3 = (C19+a*(C25+a*(C28+C31*a)))/C37;
    	s4 = (C20+a*(C27+C34*a)+c*(C22+a*(C30+C36*a)))/C38;
    	s5 = (C13+C21*a+c*(C18+C26*a))/C37;
    	s6 = (C15+c*(C23+C16*c))/C38;
    	ch = ch+t*(1+0.5*t*s1-b*c*(s1-b*(s2-b*(s3-b*(s4-b*(s5-b*s6))))));
/*!* 	if(fabs(q/ch-1) > EPS2) *!*/
    	if(java.lang.Math.abs(q/ch-1) > EPS2)
    	    return 0.5*scale*ch;
        }
        throw new java.lang.ArithmeticException("Math Error: PRECISION");
	//        return 0.5*scale*ch;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double a, double scale);
     *
     *  DESCRIPTION
     *
     *    Random variates from the Gamma distribution.
     *
     *  REFERENCES
     *
     *    [1] Shape parameter a >= 1.  Algorithm GD in:
     *
     *	  Ahrens, J.H. and Dieter, U. (1982).
     *	  Generating Gamma variates by a modified
     *	  rejection technique.
     *	  Comm. ACM, 25, 47-54.
     *
     *
     *    [2] Shape parameter 0 < a < 1. Algorithm GS in:
     *
     *        Ahrens, J.H. and Dieter, U. (1974).
     *	  Computer methods for sampling from Gamma, beta,
     *	  poisson and binomial distributions.
     *	  Computing, 12, 223-246.
     *
     *    Input: a = parameter (mean) of the standard Gamma distribution.
     *    Output: a variate from the Gamma(a)-distribution
     *
     *    Coefficients q(k) - for q0 = sum(q(k)*a**(-k))
     *    Coefficients a(k) - for q = q0+(t*t/2)*sum(a(k)*v**k)
     *    Coefficients e(k) - for exp(q)-1 = sum(e(k)*q**k)
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static private double a1 = 0.3333333;
    static private double a2 = -0.250003;
    static private double a3 = 0.2000062;
    static private double a4 = -0.1662921;
    static private double a5 = 0.1423657;
    static private double a6 = -0.1367177;
    static private double a7 = 0.1233795;
    static private double e1 = 1.0;
    static private double e2 = 0.4999897;
    static private double e3 = 0.166829;
    static private double e4 = 0.0407753;
    static private double e5 = 0.010293;
    static private double q1 = 0.04166669;
    static private double q2 = 0.02083148;
    static private double q3 = 0.00801191;
    static private double q4 = 0.00144121;
    static private double q5 = -7.388e-5;
    static private double q6 = 2.4511e-4;
    static private double q7 = 2.424e-4;
    static private double sqrt32 = 5.656854;
    
    static private double aa = 0.;
    static private double aaa = 0.;
    
    static private double b, c, d, e, p, q, r, s, t, u, v, w, x;
    static private double q0, s2, si;
      
    
    public static double  random(double a, double scale, Uniform uniformDistribution)
    {
    	double ret_val;
    
    	if (a < 1.0) {
    		/* alternate method for parameters a below 1 */
    		/* 0.36787944117144232159 = exp(-1) */
    		aa = 0.0;
    		b = 1.0 + 0.36787944117144232159 * a;
    		while(true) {
    			p = b * uniformDistribution.random();
    			if (p >= 1.0) {
/*!* 				ret_val = -log((b - p) / a); *!*/
    				ret_val = -java.lang.Math.log((b - p) / a);
/*!* 				if (Exponential.random!!!COMMENT!!!() >= (1.0 - a) * log(ret_val)) *!*/
    				if (Exponential.random(uniformDistribution) >= (1.0 - a) * java.lang.Math.log(ret_val))
    					break;
    			} else {
/*!* 				ret_val = exp(log(p) / a); *!*/
    				ret_val = java.lang.Math.exp(java.lang.Math.log(p) / a);
    				if (Exponential.random(uniformDistribution) >= ret_val)
    					break;
    			}
    		}
    		return scale * ret_val;
    	}
    	/* Step 1: Recalculations of s2, s, d if a has changed */
    	if (a != aa) {
    		aa = a;
    		s2 = a - 0.5;
/*!* 		s = sqrt(s2); *!*/
    		s = java.lang.Math.sqrt(s2);
    		d = sqrt32 - s * 12.0;
    	}
    	/* Step 2: t = standard Normal deviate, */
    	/* x = (s,1/2)-Normal deviate. */
    	/* immediate acceptance (i) */
    
    	t = Normal.random(uniformDistribution);
    	x = s + 0.5 * t;
    	ret_val = x * x;
    	if (t >= 0.0)
    		return scale * ret_val;
    
    	/* Step 3: u = 0,1 - Uniform sample. squeeze acceptance (s) */
    	u = uniformDistribution.random();
    	if (d * u <= t * t * t) {
    		return scale * ret_val;
    	}
    	/* Step 4: recalculations of q0, b, si, c if necessary */
    
    	if (a != aaa) {
    		aaa = a;
    		r = 1.0 / a;
    		q0 = ((((((q7 * r + q6) * r + q5) * r + q4)
    			* r + q3) * r + q2) * r + q1) * r;
    
    		/* Approximation depending on size of parameter a */
    		/* The constants in the expressions for b, si and */
    		/* c were established by numerical experiments */
    
    		if (a <= 3.686) {
    			b = 0.463 + s + 0.178 * s2;
    			si = 1.235;
    			c = 0.195 / s - 0.079 + 0.16 * s;
    		} else if (a <= 13.022) {
    			b = 1.654 + 0.0076 * s2;
    			si = 1.68 / s + 0.275;
    			c = 0.062 / s + 0.024;
    		} else {
    			b = 1.77;
    			si = 0.75;
    			c = 0.1515 / s;
    		}
    	}
    	/* Step 5: no quotient test if x not positive */
    
    	if (x > 0.0) {
    		/* Step 6: calculation of v and quotient q */
    		v = t / (s + s);
/*!* 		if (fabs(v) <= 0.25) *!*/
    		if (java.lang.Math.abs(v) <= 0.25)
    			q = q0 + 0.5 * t * t * ((((((a7 * v + a6)
    					    * v + a5) * v + a4) * v + a3)
    						 * v + a2) * v + a1) * v;
    		else
    			q = q0 - s * t + 0.25 * t * t + (s2 + s2)
/*!* 			    * log(1.0 + v); *!*/
    			    * java.lang.Math.log(1.0 + v);
    
    
    		/* Step 7: quotient acceptance (q) */
    
/*!* 		if (log(1.0 - u) <= q) *!*/
    		if (java.lang.Math.log(1.0 - u) <= q)
    			return scale * ret_val;
    	}
    	/* Step 8: e = standard Exponential deviate */
    	/* u= 0,1 -Uniform deviate */
    	/* t=(b,si)-double Exponential (laplace) sample */
    
    	while(true) {
    		e = Exponential.random(uniformDistribution);
    		u = uniformDistribution.random();
    		u = u + u - 1.0;
    		if (u < 0.0)
    			t = b - si * e;
    		else
    			t = b + si * e;
    		/* Step  9:  rejection if t < tau(1) = -0.71874483771719 */
    		if (t >= -0.71874483771719) {
    			/* Step 10:  calculation of v and quotient q */
    			v = t / (s + s);
/*!* 			if (fabs(v) <= 0.25) *!*/
    			if (java.lang.Math.abs(v) <= 0.25)
    				q = q0 + 0.5 * t * t * ((((((a7 * v + a6)
    					    * v + a5) * v + a4) * v + a3)
    						 * v + a2) * v + a1) * v;
    			else
    				q = q0 - s * t + 0.25 * t * t + (s2 + s2)
/*!* 				    * log(1.0 + v); *!*/
    				    * java.lang.Math.log(1.0 + v);
    			/* Step 11:  hat acceptance (h) */
    			/* (if q not positive go to step 8) */
    			if (q > 0.0) {
    				if (q <= 0.5)
    					w = ((((e5 * q + e4) * q + e3)
    					      * q + e2) * q + e1) * q;
    				else
/*!* 					w = exp(q) - 1.0; *!*/
    					w = java.lang.Math.exp(q) - 1.0;
    				/* if t is rejected */
    				/* sample again at step 8 */
/*!* 				if (c * fabs(u) <= w * exp(e - 0.5 * t * t)) *!*/
    				if (c * java.lang.Math.abs(u) <= w * java.lang.Math.exp(e - 0.5 * t * t))
    					break;
    			}
    		}
    	}
    	x = s + 0.5 * t;
    	return scale * x * x;
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/StdUniformRng.java0000644000175000017500000000037711330004150032547 0ustar  giovannigiovanni/**
 * Interface for standard uniform random number generator in this package.
 * 
 * Created on Apr 16, 2007
 */
package org.mathpiper.builtin.library.statdistlib;

public interface StdUniformRng {
  public void fixupSeeds();
  public double random();
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Normal.java0000644000175000017500000005060211376411123031246 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */


/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Normal
  { 
    
    /*  Mathematical Constants */
    static private double  SIXTEN = 1.6;   /* Magic Cutoff */


    /*
     * 	M_1_SQRT_2PI = 1 / sqrt(2 * pi)
     */
    
    /** The Normal Density Function */
    public static double  density(double x, double mu, double sigma)
    {
        if (Double.isNaN(x) || Double.isNaN(mu) || Double.isNaN(sigma))
    	return x + mu + sigma;
        if (sigma <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
        }
    
        x = (x - mu) / sigma;
        return Constants.M_1_SQRT_2PI * 
               java.lang.Math.exp(-0.5 * x * x) / sigma;
    }

    /**  DESCRIPTION 
     *    The main computation evaluates near-minimax approximations derived
     *    from those in "Rational Chebyshev approximations for the error
     *    function" by W. J. Cody, Math. Comp., 1969, 631-637.  This
     *    transportable program uses rational functions that theoretically
     *    approximate the Normal distribution function to at least 18
     *    significant decimal digits.  The accuracy achieved depends on the
     *    arithmetic system, the compiler, the intrinsic functions, and
     *    proper selection of the machine-dependent constants.
     *
     *  REFERENCE
     *
     *    Cody, W. D. (1993).
     *    ALGORITHM 715: SPECFUN - A Portable FORTRAN Package of
     *    Special Function Routines and Test Drivers".
     *    ACM Transactions on Mathematical Software. 19, 22-32.
     */

    public static double cumulative(double x, double mu, double sigma)
    {
        final double c[] = {
    	0.39894151208813466764,
    	8.8831497943883759412,
    	93.506656132177855979,
    	597.27027639480026226,
    	2494.5375852903726711,
    	6848.1904505362823326,
    	11602.651437647350124,
    	9842.7148383839780218,
    	1.0765576773720192317e-8
        };
    
        final double d[] = {
    	22.266688044328115691,
    	235.38790178262499861,
    	1519.377599407554805,
    	6485.558298266760755,
    	18615.571640885098091,
    	34900.952721145977266,
    	38912.003286093271411,
    	19685.429676859990727
        };
    
        final double p[] = {
    	0.21589853405795699,
    	0.1274011611602473639,
    	0.022235277870649807,
    	0.001421619193227893466,
    	2.9112874951168792e-5,
    	0.02307344176494017303
        };
    
        final double q[] = {
    	1.28426009614491121,
    	0.468238212480865118,
    	0.0659881378689285515,
    	0.00378239633202758244,
    	7.29751555083966205e-5
        };
    
        final double a[] = {
    	2.2352520354606839287,
    	161.02823106855587881,
    	1067.6894854603709582,
    	18154.981253343561249,
    	0.065682337918207449113
        };
    
        final double b[] = {
    	47.20258190468824187,
    	976.09855173777669322,
    	10260.932208618978205,
    	45507.789335026729956
        };
    
        double xden, temp, xnum, result, ccum;
        double del, min, eps, xsq;
        double y;
        int i;
    
        /* Note: The structure of these checks has been */
        /* carefully thought through.  For example, if x == mu */
        /* and sigma == 0, we still get the correct answer. */
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isNaN(x) || Double.isNaN(mu) || Double.isNaN(sigma))
    	return x + mu + sigma;
    /*!* #endif /*4!*/
        if (sigma < 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        x = (x - mu) / sigma;
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isInfinite(x)) {
    	if(x < 0) return 0;
    	else return 1;
        }
    /*!* #endif /*4!*/
    
        eps = Constants.DBL_EPSILON * 0.5;
        min = Double.MIN_VALUE;
/*!*     y = fabs(x); *!*/
        y = java.lang.Math.abs(x);
        if (y <= 0.66291) {
    	xsq = 0.0;
    	if (y > eps) {
    	    xsq = x * x;
    	}
    	xnum = a[4] * xsq;
    	xden = xsq;
    	for (i = 1; i <= 3; ++i) {
    	    xnum = (xnum + a[i - 1]) * xsq;
    	    xden = (xden + b[i - 1]) * xsq;
    	}
    	result = x * (xnum + a[3]) / (xden + b[3]);
    	temp = result;
    	result = 0.5 + temp;
    	ccum = 0.5 - temp;
        }
        else if (y <= Constants.M_SQRT_32) {
    
    	/* Evaluate pnorm for 0.66291 <= |z| <= sqrt(32) */
    
    	xnum = c[8] * y;
    	xden = y;
    	for (i = 1; i <= 7; ++i) {
    	    xnum = (xnum + c[i - 1]) * y;
    	    xden = (xden + d[i - 1]) * y;
    	}
    	result = (xnum + c[7]) / (xden + d[7]);
/*!* 	xsq = floor(y * SIXTEN) / SIXTEN; *!*/
    	xsq = java.lang.Math.floor(y * SIXTEN) / SIXTEN;
    	del = (y - xsq) * (y + xsq);
/*!* 	result = exp(-xsq * xsq * 0.5) * exp(-del * 0.5) * result; *!*/
    	result = java.lang.Math.exp(-xsq * xsq * 0.5) * java.lang.Math.exp(-del * 0.5) * result;
    	ccum = 1.0 - result;
    	if (x > 0.0) {
    	    temp = result;
    	    result = ccum;
    	    ccum = temp;
    	}
        }
        else if(y < 50) {
    
    	/* Evaluate pnorm for sqrt(32) < |z| < 50 */
    
    	result = 0.0;
    	xsq = 1.0 / (x * x);
    	xnum = p[5] * xsq;
    	xden = xsq;
    	for (i = 1; i <= 4; ++i) {
    	    xnum = (xnum + p[i - 1]) * xsq;
    	    xden = (xden + q[i - 1]) * xsq;
    	}
    	result = xsq * (xnum + p[4]) / (xden + q[4]);
    	result = (Constants.M_1_SQRT_2PI - result) / y;
/*!* 	xsq = floor(x * SIXTEN) / SIXTEN; *!*/
    	xsq = java.lang.Math.floor(x * SIXTEN) / SIXTEN;
    	del = (x - xsq) * (x + xsq);
/*!* 	result = exp(-xsq * xsq * 0.5) * exp(-del * 0.5) * result; *!*/
    	result = java.lang.Math.exp(-xsq * xsq * 0.5) * java.lang.Math.exp(-del * 0.5) * result;
    	ccum = 1.0 - result;
    	if (x > 0.0) {
    	    temp = result;
    	    result = ccum;
    	    ccum = temp;
    	}
        }
        else {
    	if(x > 0) {
    	    result = 1.0;
    	    ccum = 0.0;
    	}
    	else {
    	    result = 0.0;
    	    ccum = 1.0;
    	}
        }
        if (result < min) {
    	result = 0.0;
        }
        if (ccum < min) {
    	ccum = 0.0;
        }
        return result;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    double cumulative(double p, double mu, double sigma);
     *
     *  DESCRIPTION
     *
     *    Compute the quantile function for the Normal distribution.
     *
     *    For small to moderate probabilities, algorithm referenced
     *    below is used to obtain an initial approximation which is
     *    polished with a final Newton step.
     *
     *    For very large arguments, an algorithm of Wichura is used.
     *
     *  REFERENCE
     *
     *    Beasley, J. D. and S. G. Springer (1977).
     *    Algorithm AS 111: The percentage points of the Normal distribution,
     *    Applied Statistics, 26, 118-121.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    
    public static double  quantile(double p, double mu, double sigma)
    {
        double q, r, val;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(p) || Double.isNaN(mu) || Double.isNaN(sigma))
    	return p + mu + sigma;
    /*!* #endif /*4!*/
        if (p < 0.0 || p > 1.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    
        q = p - 0.5;
    
/*!*     if (fabs(q) <= 0.42) { *!*/
        if (java.lang.Math.abs(q) <= 0.42) {
    
    	/* 0.08 < p < 0.92 */
    
    	r = q * q;
    	val = q * (((-25.44106049637 * r + 41.39119773534) * r
    		    - 18.61500062529) * r + 2.50662823884)
    	    / ((((3.13082909833 * r - 21.06224101826) * r
    		 + 23.08336743743) * r + -8.47351093090) * r + 1.0);
        }
        else {
    
    	/* p < 0.08 or p > 0.92, set r = min(p, 1 - p) */
    
    	r = p;
    	if (q > 0.0)
    	    r = 1.0 - p;
    
    	if(r > Constants.DBL_EPSILON) {
/*!* 	    r = sqrt(-log(r)); *!*/
    	    r = java.lang.Math.sqrt(-java.lang.Math.log(r));
    	    val = (((2.32121276858 * r + 4.85014127135) * r
    		    - 2.29796479134) * r - 2.78718931138)
    		/ ((1.63706781897 * r + 3.54388924762) * r + 1.0);
    	    if (q < 0.0)
    		val = -val;
    	}
    	else if(r > 1e-300) {		/* Assuming IEEE here? */
/*!* 	    val = -2 * log(p); *!*/
    	    val = -2 * java.lang.Math.log(p);
/*!* 	    r = log(6.283185307179586476925286766552 * val); *!*/
    	    r = java.lang.Math.log(6.283185307179586476925286766552 * val);
    	    r = r/val + (2 - r)/(val * val)
    		+ (-14 + 6 * r - r * r)/(2 * val * val * val);
/*!* 	    val = sqrt(val * (1 - r)); *!*/
    	    val = java.lang.Math.sqrt(val * (1 - r));
    	    if(q < 0.0)
    		val = -val;
    	    return val;
    	}
    	else {
    	    throw new java.lang.ArithmeticException("Math Error: RANGE");
	    //    	    if(q < 0.0) {
	    //    		return Double.NEGATIVE_INFINITY;
	    //    	    }
	    //    	    else {
	    //    		return Double.POSITIVE_INFINITY;
	    //    	    }
    	}
        }
        val = val - (cumulative(val, 0.0, 1.0) - p) / Normal.density(val, 0.0, 1.0);
        return mu + sigma * val;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double mu, double sigma, Uniform uniformDistribution );
     *
     *  DESCRIPTION
     *
     *    Random variates from the Normal distribution.
     *
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double mu, double sigma, Uniform uniformDistribution)
    {
        if(
    /*!* #ifdef IEEE_754 /*4!*/
            Double.isInfinite(mu) || Double.isInfinite(sigma) ||
    /*!* #endif /*4!*/
    	sigma < 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN; 
        } else
        if (sigma == 0.0)
    	return mu;
        else
    	return mu + sigma * random(uniformDistribution);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(void);
     *
     *  DESCRIPTION
     *
     *    Random variates from the STANDARD Normal distribution  N(0,1).
     *
     * Is called from  random(..), but also rt(), rf(), rgamma(), ...
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    /*!* #define KINDERMAN_RAMAGE /*4!*/
    
    /*!* #ifdef AHRENS_DIETER /*4!*/
    
    /*
     *  REFERENCE
     *
     *    Ahrens, J.H. and Dieter, U.
     *    Extensions of Forsythe's method for random sampling from
     *    the Normal distribution.
     *    Math. Comput. 27, 927-937.
     *
     *    The definitions of the constants a[k], d[k], t[k] and
     *    h[k] are according to the abovementioned article
     */
    public static double  random_AhrensDieter( Uniform uniformDistribution )
    {      
      final double a[] =
    {
    	0.0000000, 0.03917609, 0.07841241, 0.1177699,
    	0.1573107, 0.19709910, 0.23720210, 0.2776904,
    	0.3186394, 0.36012990, 0.40225010, 0.4450965,
    	0.4887764, 0.53340970, 0.57913220, 0.6260990,
    	0.6744898, 0.72451440, 0.77642180, 0.8305109,
    	0.8871466, 0.94678180, 1.00999000, 1.0775160,
    	1.1503490, 1.22985900, 1.31801100, 1.4177970,
    	1.5341210, 1.67594000, 1.86273200, 2.1538750
    };
    
    final double d[] =
    {
    	0.0000000, 0.0000000, 0.0000000, 0.0000000,
    	0.0000000, 0.2636843, 0.2425085, 0.2255674,
    	0.2116342, 0.1999243, 0.1899108, 0.1812252,
    	0.1736014, 0.1668419, 0.1607967, 0.1553497,
    	0.1504094, 0.1459026, 0.1417700, 0.1379632,
    	0.1344418, 0.1311722, 0.1281260, 0.1252791,
    	0.1226109, 0.1201036, 0.1177417, 0.1155119,
    	0.1134023, 0.1114027, 0.1095039
    };
    
    final double t[] =
    {
    	7.673828e-4, 0.002306870, 0.003860618, 0.005438454,
    	0.007050699, 0.008708396, 0.010423570, 0.012209530,
    	0.014081250, 0.016055790, 0.018152900, 0.020395730,
    	0.022811770, 0.025434070, 0.028302960, 0.031468220,
    	0.034992330, 0.038954830, 0.043458780, 0.048640350,
    	0.054683340, 0.061842220, 0.070479830, 0.081131950,
    	0.094624440, 0.112300100, 0.136498000, 0.171688600,
    	0.227624100, 0.330498000, 0.584703100
    };
    
    final double h[] =
    {
    	0.03920617, 0.03932705, 0.03950999, 0.03975703,
    	0.04007093, 0.04045533, 0.04091481, 0.04145507,
    	0.04208311, 0.04280748, 0.04363863, 0.04458932,
    	0.04567523, 0.04691571, 0.04833487, 0.04996298,
    	0.05183859, 0.05401138, 0.05654656, 0.05953130,
    	0.06308489, 0.06737503, 0.07264544, 0.07926471,
    	0.08781922, 0.09930398, 0.11555990, 0.14043440,
    	0.18361420, 0.27900160, 0.70104740
    };
    
        double s, u, w, y, ustar, aa, tt;
        int i;
    
        u = uniformDistribution.random();
        s = 0.0;
        if (u > 0.5)
	    s = 1.0;
        u = u + u - s;
        u *= 32.0;
        i = (int) u;
        if (i == 32)
    	i = 31;
	deliver: {
	    if (i != 0) {
		ustar = u - i;
		aa = a[i - 1];
		while (ustar <= t[i - 1]) {
		    u = uniformDistribution.random();
		    w = u * (a[i] - aa);
		    tt = (w * 0.5 + aa) * w;
		    while(true) {
			if (ustar > tt)
			    break deliver;
			u = uniformDistribution.random();
			if (ustar < u)
			    break;
			tt = u;
			ustar = uniformDistribution.random();
		    }
		    ustar = uniformDistribution.random();
		}
		w = (ustar - t[i - 1]) * h[i - 1];
	    }
	    else {
		i = 6;
		aa = a[31];
		while(true) {
		    u = u + u;
		    if (u >= 1.0)
			break;
		    aa = aa + d[i - 1];
		    i = i + 1;
		}
		u = u - 1.0;
		jump: while(true) {
		    w = u * d[i - 1];
		    tt = (w * 0.5 + aa) * w;
		    while(true) {
			ustar = uniformDistribution.random();
			if (ustar > tt)
			    break jump;
			u = uniformDistribution.random();
			if (ustar < u)
			    break;
			tt = u;
		    }
		    u = uniformDistribution.random();
		} // jump:;
	    }
	    
	} // deliver:
        y = aa + w;
        return (s == 1.0) ? -y : y;
    
    }
    
    /*!* #endif /*4!*/
    
    /*!* #ifdef KINDERMAN_RAMAGE /*4!*/
    
    /*
     *  REFERENCE
     *
     *    Kinderman A. J. and Ramage J. G. (1976).
     *    Computer generation of Normal random variables.
     *    JASA 71, 893-896.
     */
    
    static final double  C1 = 0.398942280401433; 
    static final double  C2 = 0.180025191068563; 
/*!* /*!* #define g(x)		(C1*exp(-x*x/2.0)-C2*(a-fabs(x))) /*4!* *!*/
      static final double a =  2.216035867166471;

      static final double g(double x)
    {
	return (C1*java.lang.Math.exp(-x*x/2.0)-C2*(a-java.lang.Math.abs(x))) ;
    }
    
    public static double  random( Uniform uniformDistribution )
    {
        double t, u1, u2, u3;
    
        u1 = uniformDistribution.random();
        if(u1 < 0.884070402298758) {
    	u2 = uniformDistribution.random();
    	return a*(1.13113163544180*u1+u2-1);
        }
    
        if(u1 >= 0.973310954173898) {
        tail: while(true) {
    	u2 = uniformDistribution.random();
    	u3 = uniformDistribution.random();
/*!* 	t = (a*a-2*log(u3)); *!*/
    	t = (a*a-2*java.lang.Math.log(u3));
    	if( u2*u2<(a*a)/t )
/*!* 	    return (u1 < 0.986655477086949) ? sqrt(t) : -sqrt(t) ; *!*/
    	    return (u1 < 0.986655477086949) ? java.lang.Math.sqrt(t) : -java.lang.Math.sqrt(t) ;
    	// continue tail;
        }
	}
    
        if(u1 >= 0.958720824790463) {
        region3: while(true) {
    	u2 = uniformDistribution.random();
    	u3 = uniformDistribution.random();
/*!* 	t = a - 0.630834801921960* fmin2(u2,u3); *!*/
    	t = a - 0.630834801921960* Math.min(u2,u3);
/*!* 	if(fmax2(u2,u3) <= 0.755591531667601) *!*/
    	if(Math.max(u2,u3) <= 0.755591531667601)
    	    return (u2= 0.911312780288703) {
        region2: {
    	u2 = uniformDistribution.random();
    	u3 = uniformDistribution.random();
/*!* 	t = 0.479727404222441+1.105473661022070*fmin2(u2,u3); *!*/
    	t = 0.479727404222441+1.105473661022070*Math.min(u2,u3);
/*!* 	if( fmax2(u2,u3)<=0.872834976671790 ) *!*/
    	if( Math.max(u2,u3)<=0.872834976671790 )
    	    return (u2 testArr[i+1] )
// 			{
// 			    temp = testArr[i];
// 			    testArr[i] = testArr[i+1];
// 			    testArr[i+1] = temp;
// 			    ordered=false;
// 			}
// 	    }

// 	return true;

//     }

  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/NoncentralF.java0000644000175000017500000000374011376411123032230 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class NoncentralF
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double n1, double n2, double ncp);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the non-central F distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n1, double n2, double ncp)
    {
        double y;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n1) || Double.isNaN(n2) || Double.isNaN(ncp))
    	return x + n2 + n1 + ncp;
    /*!* #endif /*4!*/
        if (n1 <= 0.0 || n2 <= 0.0 || ncp < 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0.0)
    	return 0.0;
        y = (n1 / n2) * x;
        return NoncentralBeta.cumulative(y/(1 + y), n1 / 2.0, n2 / 2.0, ncp);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Polygamma.java0000644000175000017500000005462211376411123031752 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Polygamma
  { 
/***UNUSED***    /*
/***UNUSED***     *  DistLib : A C Library of Special Functions
/***UNUSED***     *  Copyright (C) 1998 Ross Ihaka
/***UNUSED***     *
/***UNUSED***     *  This program is free software; you can redistribute it and/or modify
/***UNUSED***     *  it under the terms of the GNU General Public License as published by
/***UNUSED***     *  the Free Software Foundation; either version 2 of the License, or
/***UNUSED***     *  (at your option) any later version.
/***UNUSED***     *
/***UNUSED***     *  This program is distributed in the hope that it will be useful,
/***UNUSED***     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
/***UNUSED***     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
/***UNUSED***     *  GNU General Public License for more details.
/***UNUSED***     *
/***UNUSED***     *  You should have received a copy of the GNU General Public License
/***UNUSED***     *  along with this program; if not, write to the Free Software
/***UNUSED***     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
/***UNUSED***     *
/***UNUSED***     *  SYNOPSIS
/***UNUSED***     *
/***UNUSED***     *    #include "DistLib.h"
/***UNUSED***     *    void dpsifn(double x, int n, int kode, int m,
/***UNUSED***     *		  double *ans, int *nz, int *ierr)
/***UNUSED***     *    double digamma(double x);
/***UNUSED***     *    double trigamma(double x)
/***UNUSED***     *    double tetragamma(double x)
/***UNUSED***     *    double pentagamma(double x)
/***UNUSED***     *
/***UNUSED***     *  DESCRIPTION
/***UNUSED***     *
/***UNUSED***     *    Compute the derivatives of the psi function
/***UNUSED***     *    and Polygamma functions.
/***UNUSED***     *
/***UNUSED***     *    The following definitions are used in dpsifn:
/***UNUSED***     *
/***UNUSED***     *    Definition 1
/***UNUSED***     *
/***UNUSED***     *	 psi(x) = d/dx (ln(gamma(x)),  the first derivative of
/***UNUSED***     *				       the log gamma function.
/***UNUSED***     *
/***UNUSED***     *    Definition 2
/***UNUSED***     *		     k	 k
/***UNUSED***     *	 psi(k,x) = d /dx (psi(x)),    the k-th derivative
/***UNUSED***     *				       of psi(x).
/***UNUSED***     *
/***UNUSED***     *
/***UNUSED***     *    "dpsifn" computes a sequence of scaled derivatives of
/***UNUSED***     *    the psi function; i.e. for fixed x and m it computes
/***UNUSED***     *    the m-member sequence
/***UNUSED***     *
/***UNUSED***     *		  ((-1)**(k+1)/gamma(k+1))*psi(k,x)
/***UNUSED***     *		     for k = n,...,n+m-1
/***UNUSED***     *
/***UNUSED***     *    where psi(k,x) is as defined above.   For kode=1, dpsifn
/***UNUSED***     *    returns the scaled derivatives as described.  kode=2 is
/***UNUSED***     *    operative only when k=0 and in that case dpsifn returns
/***UNUSED***     *    -psi(x) + ln(x).	That is, the logarithmic behavior for
/***UNUSED***     *    large x is removed when kode=2 and k=0.  When sums or
/***UNUSED***     *    differences of psi functions are computed the logarithmic
/***UNUSED***     *    terms can be combined analytically and computed separately
/***UNUSED***     *    to help retain significant digits.
/***UNUSED***     *
/***UNUSED***     *    Note that dpsifn(x, 0, 1, 1, ans) results in ans = -psi(x).
/***UNUSED***     *
/***UNUSED***     *  INPUT
/***UNUSED***     *
/***UNUSED***     *	x     - argument, x > 0.
/***UNUSED***     *
/***UNUSED***     *	n     - first member of the sequence, 0 <= n <= 100
/***UNUSED***     *		n == 0 gives ans(1) = -psi(x)	    for kode=1
/***UNUSED***     *					 -psi(x)+ln(x) for kode=2
/***UNUSED***     *
/***UNUSED***     *	kode  - selection parameter
/***UNUSED***     *		kode == 1 returns scaled derivatives of the
/***UNUSED***     *		psi function.
/***UNUSED***     *		kode == 2 returns scaled derivatives of the
/***UNUSED***     *		psi function except when n=0. In this case,
/***UNUSED***     *		ans(1) = -psi(x) + ln(x) is returned.
/***UNUSED***     *
/***UNUSED***     *	m     - number of members of the sequence, m >= 1
/***UNUSED***     *
/***UNUSED***     *  OUTPUT
/***UNUSED***     *
/***UNUSED***     *	ans   - a vector of length at least m whose first m
/***UNUSED***     *		components contain the sequence of derivatives
/***UNUSED***     *		scaled according to kode.
/***UNUSED***     *
/***UNUSED***     *	nz    - underflow flag
/***UNUSED***     *		nz == 0, a normal return
/***UNUSED***     *		nz != 0, underflow, last nz components of ans are
/***UNUSED***     *			 set to zero, ans(m-k+1)=0.0, k=1,...,nz
/***UNUSED***     *
/***UNUSED***     *	ierr  - error flag
/***UNUSED***     *		ierr=0, a normal return, computation completed
/***UNUSED***     *		ierr=1, input error,	 no computation
/***UNUSED***     *		ierr=2, overflow,	 x too small or n+m-1 too
/***UNUSED***     *			large or both
/***UNUSED***     *		ierr=3, error,		 n too large. dimensioned
/***UNUSED***     *			array trmr(nmax) is not large enough for n
/***UNUSED***     *
/***UNUSED***     *    The nominal computational accuracy is the maximum of unit
/***UNUSED***     *    roundoff (d1mach(4)) and 1e-18 since critical constants
/***UNUSED***     *    are given to only 18 digits.
/***UNUSED***     *
/***UNUSED***     *    The basic method of evaluation is the asymptotic expansion
/***UNUSED***     *    for large x >= xmin followed by backward recursion on a two
/***UNUSED***     *    term recursion relation
/***UNUSED***     *
/***UNUSED***     *	     w(x+1) + x**(-n-1) = w(x).
/***UNUSED***     *
/***UNUSED***     *    this is supplemented by a series
/***UNUSED***     *
/***UNUSED***     *	     sum( (x+k)**(-n-1) , k=0,1,2,... )
/***UNUSED***     *
/***UNUSED***     *    which converges rapidly for large n. both xmin and the
/***UNUSED***     *    number of terms of the series are calculated from the unit
/***UNUSED***     *    roundoff of the machine environment.
/***UNUSED***     *
/***UNUSED***     *  AUTHOR
/***UNUSED***     *
/***UNUSED***     *    Amos, D. E.  (Fortran)
/***UNUSED***     *    Ross Ihaka   (C Translation)
/***UNUSED***     *
/***UNUSED***     *  REFERENCES
/***UNUSED***     *
/***UNUSED***     *    Handbook of Mathematical Functions,
/***UNUSED***     *    National Bureau of Standards Applied Mathematics Series 55,
/***UNUSED***     *    Edited by M. Abramowitz and I. A. Stegun, equations 6.3.5,
/***UNUSED***     *    6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964.
/***UNUSED***     *
/***UNUSED***     *    D. E. Amos, (1983). "A Portable Fortran Subroutine for
/***UNUSED***     *    Derivatives of the Psi Function", Algorithm 610,
/***UNUSED***     *    TOMS 9(4), pp. 494-502.
/***UNUSED***     *
/***UNUSED***     *    Routines called: d1mach, i1mach.
/***UNUSED***     */
/***UNUSED***    
/***UNUSED***    /*!* #include "DistLib.h" /*4!*/
/***UNUSED***    
/***UNUSED***    	/* Bernoulli Numbers */
/***UNUSED***    
/***UNUSED***    static private double b[] = {
/***UNUSED***	00, /** DUMMY ENTRY SO INDEXING FROM 1 WORKS **/
/***UNUSED***         1.00000000000000000e+00,
/***UNUSED***        -5.00000000000000000e-01,
/***UNUSED***         1.66666666666666667e-01,
/***UNUSED***        -3.33333333333333333e-02,
/***UNUSED***         2.38095238095238095e-02,
/***UNUSED***        -3.33333333333333333e-02,
/***UNUSED***         7.57575757575757576e-02,
/***UNUSED***        -2.53113553113553114e-01,
/***UNUSED***         1.16666666666666667e+00,
/***UNUSED***        -7.09215686274509804e+00,
/***UNUSED***         5.49711779448621554e+01,
/***UNUSED***        -5.29124242424242424e+02,
/***UNUSED***         6.19212318840579710e+03,
/***UNUSED***        -8.65802531135531136e+04,
/***UNUSED***         1.42551716666666667e+06,
/***UNUSED***        -2.72982310678160920e+07,
/***UNUSED***         6.01580873900642368e+08,
/***UNUSED***        -1.51163157670921569e+10,
/***UNUSED***         4.29614643061166667e+11,
/***UNUSED***        -1.37116552050883328e+13,
/***UNUSED***         4.88332318973593167e+14,
/***UNUSED***        -1.92965793419400681e+16
/***UNUSED***    };
/***UNUSED***    
/***UNUSED***      //    static private double *b = (double *)&bvalues -1;
/***UNUSED***    static private int nmax = 100;
/***UNUSED***    
/***UNUSED***    public static int ierr = 0;
/***UNUSED***
/***UNUSED***    static double[] dpsifn(double x, int n, int kode, int m, int nz) 
/***UNUSED***    {
/***UNUSED***	double ans[] = new double[n+1];
/***UNUSED***	double retval[] = new double[n];
/***UNUSED***        int i, j, k, mm, mx, nn, np, nx, fn;
/***UNUSED***        double arg, den, elim, eps, fln, fx, rln, rxsq;
/***UNUSED***    	double r1m4, r1m5, s, slope, t, ta, tk, tol, tols, tss, tst;
/***UNUSED***    	double tt, t1, t2, wdtol, xdmln, xdmy, xinc, xln, xm, xmin;
/***UNUSED***    	double xq, yint;
/***UNUSED***        double trm[] = new double[23], trmr[] = new double[101];
/***UNUSED***    
/***UNUSED***        ierr = 0;
/***UNUSED***        if (x <= 0.0 || n < 0 || kode < 1 || kode > 2 || m < 1) {
/***UNUSED***    	ierr = 1;
/***UNUSED***    	return ans;
/***UNUSED***        }
/***UNUSED***    
/***UNUSED***        /* fortran adjustment */
/***UNUSED***        //ans--;
/***UNUSED***    
/***UNUSED***        nz = 0;
/***UNUSED***        mm = m;
/***UNUSED*** /*!*     nx = Math.min(-i1mach(15), i1mach(16)); *!*/
/***UNUSED***        nx = Math.min(-misc.i1mach(15), misc.i1mach(16));
/***UNUSED*** /*!*     r1m5 = d1mach(5); *!*/
/***UNUSED***        r1m5 = misc.d1mach(5);
/***UNUSED*** /*!*     r1m4 = d1mach(4) * 0.5; *!*/
/***UNUSED***        r1m4 = misc.d1mach(4) * 0.5;
/***UNUSED*** /*!*     wdtol = fmax2(r1m4, 0.5e-18); *!*/
/***UNUSED***        wdtol = Math.max(r1m4, 0.5e-18);
/***UNUSED***    
/***UNUSED***        /* elim = approximate exponential over and underflow limit */
/***UNUSED***    
/***UNUSED***        elim = 2.302 * (nx * r1m5 - 3.0);
/***UNUSED*** /*!*     xln = log(x); *!*/
/***UNUSED***        xln = java.lang.Math.log(x);
/***UNUSED***        for(;;) {
/***UNUSED***    	nn = n + mm - 1;
/***UNUSED***    	fn = nn;
/***UNUSED***    	t = (fn + 1) * xln;
/***UNUSED***    
/***UNUSED***    	/* overflow and underflow test for small and large x */
/***UNUSED***    
/***UNUSED*** /*!* 	if (fabs(t) > elim) { *!*/
/***UNUSED***    	if (java.lang.Math.abs(t) > elim) {
/***UNUSED***    	    if (t <= 0.0) {
/***UNUSED***    		nz = 0;
/***UNUSED***    		ierr = 2;
/***UNUSED***    		{
/***UNUSED***		    for(int count=0; count 7.0 && fln < 15.0)
/***UNUSED***    		    break;
/***UNUSED***    	    }
/***UNUSED***    	    xdmy = x;
/***UNUSED***    	    xdmln = xln;
/***UNUSED***    	    xinc = 0.0;
/***UNUSED***    	    if (x < xmin) {
/***UNUSED***    		nx = (int)x;
/***UNUSED***    		xinc = xmin - nx;
/***UNUSED***    		xdmy = x + xinc;
/***UNUSED*** /*!* 		xdmln = log(xdmy); *!*/
/***UNUSED***    		xdmln = java.lang.Math.log(xdmy);
/***UNUSED***    	    }
/***UNUSED***    
/***UNUSED***    	    /* generate w(n+mm-1, x) by the asymptotic expansion */
/***UNUSED***    
/***UNUSED***    	    t = fn * xdmln;
/***UNUSED***    	    t1 = xdmln + xdmln;
/***UNUSED***    	    t2 = t + xdmln;
/***UNUSED*** /*!* 	    tk = fmax2(fabs(t), fmax2(fabs(t1), fabs(t2))); *!*/
/***UNUSED***    	    tk = Math.max(java.lang.Math.abs(t), Math.max(java.lang.Math.abs(t1), java.lang.Math.abs(t2)));
/***UNUSED***    	    if (tk <= elim)
/***UNUSED***    		break L10;
/***UNUSED***    	}
/***UNUSED***
/***UNUSED***	nz = nz + 1;
/***UNUSED***    	ans[mm] = 0.0;
/***UNUSED***    	mm = mm - 1;
/***UNUSED***    	if (mm == 0)
/***UNUSED***    	   {
/***UNUSED***	       for(int count=0; count n */
/***UNUSED***    
/***UNUSED***    	tol = wdtol / 5.0;
/***UNUSED***    	for(j=2 ; j<=mm ; j++) {
/***UNUSED***    	    t = t / x;
/***UNUSED***    	    s = t;
/***UNUSED***    	    tols = t * tol;
/***UNUSED***    	    den = x;
/***UNUSED***    	    for(i=1 ; i<=nn ; i++) {
/***UNUSED***    		den = den + 1.0;
/***UNUSED***    		trm[i] = trm[i] / den;
/***UNUSED***    		s = s + trm[i];
/***UNUSED***    		if (trm[i] < tols)
/***UNUSED***    		    break;
/***UNUSED***    	    }
/***UNUSED***    	    ans[j] = s;
/***UNUSED***    	}
/***UNUSED***        }
/***UNUSED***        {
/***UNUSED***	    for(int count=0; count= tst) { *!*/
/***UNUSED***        if (java.lang.Math.abs(s) >= tst) {
/***UNUSED***    	tk = 2.0;
/***UNUSED***    	for(k=4 ; k<=22 ; k++) {
/***UNUSED***    	    t = t * ((tk + fn + 1)/(tk + 1.0))*((tk + fn)/(tk + 2.0)) * rxsq;
/***UNUSED***    	    trm[k] = t * b[k];
/***UNUSED*** /*!* 	    if (fabs(trm[k]) < tst) *!*/
/***UNUSED***    	    if (java.lang.Math.abs(trm[k]) < tst)
/***UNUSED***    		break;
/***UNUSED***    	    s = s + trm[k];
/***UNUSED***    	    tk = tk + 2.0;
/***UNUSED***    	}
/***UNUSED***        }
/***UNUSED***        s = (s + t1) * tss;
/***UNUSED***        if (xinc != 0.0) {
/***UNUSED***    
/***UNUSED***    	/* backward recur from xdmy to x */
/***UNUSED***    
/***UNUSED***    	nx = (int)xinc;
/***UNUSED***    	np = nn + 1;
/***UNUSED***    	if (nx > nmax) {
/***UNUSED***    	    nz = 0;
/***UNUSED***    	    ierr = 3;
/***UNUSED***	    {
/***UNUSED***		for(int count=0; count= tst) { *!*/
/***UNUSED***	    if (java.lang.Math.abs(s) >= tst) {
/***UNUSED***		tk = 4 + fn;
/***UNUSED***		for(k=4 ; k<=22 ; k++) {
/***UNUSED***		    trm[k] = trm[k] * (fn + 1) / tk;
/***UNUSED***		    /*!* 		if (fabs(trm[k]) < tst) *!*/
/***UNUSED***		    if (java.lang.Math.abs(trm[k]) < tst)
/***UNUSED***			break;
/***UNUSED***		    s = s + trm[k];
/***UNUSED***		    tk = tk + 2.0;
/***UNUSED***		}
/***UNUSED***	    }
/***UNUSED***	    s = (s + t1) * tss;
/***UNUSED***	    
/***UNUSED***	    if (xinc != 0.0) {
/***UNUSED***		if (fn == 0)
/***UNUSED***		    break L20;
/***UNUSED***		xm = xinc - 1.0;
/***UNUSED***		fx = x + xm;
/***UNUSED***		for(i=1 ; i<=nx ; i++) {
/***UNUSED***		    trmr[i] = trmr[i] * fx;
/***UNUSED***		    s = s + trmr[i];
/***UNUSED***		    xm = xm - 1.0;
/***UNUSED***		    fx = x + xm;
/***UNUSED***		}
/***UNUSED***	    }
/***UNUSED***	    mx = mm - j + 1;
/***UNUSED***	    ans[mx] = s;
/***UNUSED***	    if (fn == 0)
/***UNUSED***		break L30;
/***UNUSED***        }
/***UNUSED***        {
/***UNUSED***	    for(int count=0; count 1 || lambda <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x == 0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (x == 1) return Double.POSITIVE_INFINITY;
    /*!* #endif /*4!*/
        mu = lambda;
/*!*     sigma = sqrt(lambda); *!*/
        sigma = java.lang.Math.sqrt(lambda);
        gamma = sigma;
        z = Normal.quantile(x, 0.0, 1.0);
/*!*     y = floor(mu + sigma * (z + Gamma * (z * z - 1) / 6) + 0.5); *!*/
        y = java.lang.Math.floor(mu + sigma * (z + gamma * (z * z - 1) / 6) + 0.5);
        z = cumulative(y, lambda);
    
        if(z >= x) {
    
    	/* search to the left */
    
    	for(;;) {
    	    if((z = Poisson.cumulative(y - 1, lambda)) < x)
    		return y;
    	    y = y - 1;
    	}
        }
        else {
    
    	/* search to the right */
    
    	for(;;) {
    	    if((z = Poisson.cumulative(y + 1, lambda)) >= x)
    		return y + 1;
    	    y = y + 1;
    	}
        }
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double lambda)
     *
     *  DESCRIPTION
     *
     *    Random variates from the Poisson distribution.
     *
     *  REFERENCE
     *
     *    Ahrens, J.H. and Dieter, U. (1982).
     *    Computer generation of Poisson deviates
     *    from modified Normal distributions.
     *    ACM Trans. Math. Software 8, 163-179.
     */
    
    /* Factorial Table */
    static double fact[] =
    {
    	1.0,
    	1.0,
    	2.0,
    	6.0,
    	24.0,
    	120.0,
    	720.0,
    	5040.0,
    	40320.0,
    	362880.0
    };
    
    static private double  a0 = -0.5; 
    static private double  a1 = 0.3333333; 
    static private double  a2 = -0.2500068; 
    static private double  a3 = 0.2000118; 
    static private double  a4 = -0.1661269; 
    static private double  a5 = 0.1421878; 
    static private double  a6 = -0.1384794; 
    static private double  a7 = 0.1250060; 
    
      //    static private double  while(true) = for(;;); 
    
    /*!* #include "DistLib.h" /*4!*/
    

      static private double /* a0, a1, a2, a3, a4, a5, a6, a7, */ b1, b2;
      static private double c, c0, c1, c2, c3, d, del, difmuk, e;
      static private double fk, fx, fy, g, omega;
      static private double p, p0, px, py, q, s, t, u, v, x, xx;
      static private double pp[] = new double[36];
      static private int j, k, kflag, l, m;
      static private int ipois;
      static private double muprev = 0.0;
      static private double muold = 0.0;


    public static double  random(double mu, Uniform uniformDistribution )
    {
	throw new  java.lang.ArithmeticException("FUNCTION NOT IMPLEMENTED");
    }
}
/******        
/******        if (mu != muprev) {
/******    	if (mu >= 10.0) {
/******    	    /* case a. (recalculation of s,d,l */
/******    	    /* if mu has changed)  */
/******    	    /* the Poisson probabilities pk */
/******    	    /* exceed the discrete Normal */
/******    	    /* probabilities fk whenever k >= m(mu). */
/******    	    /* l=ifix(mu-1.1484) is an upper bound */
/******    	    /* to m(mu) for all mu >= 10. */
/******    	    muprev = mu;
/****** /*!* 	    s = sqrt(mu); *!*/
/******    	    s = java.lang.Math.sqrt(mu);
/******    	    d = 6.0 * mu * mu;
/******    	    l = mu - 1.1484;
/******    	} else {
/******    	    /* Case B. (start new table and */
/******    	    /* calculate p0 if necessary) */
/******    	    muprev = 0.0;
/******    	    if (mu != muold) {
/******    		muold = mu;
/****** /*!* 		m = imax2(1, (int) mu); *!*/
/******    		m = Math.max(1, (int) mu);
/******    		l = 0;
/****** /*!* 		p = exp(-mu); *!*/
/******    		p = java.lang.Math.exp(-mu);
/******    		q = p;
/******    		p0 = p;
/******    	    }
/******    	    while(true) {
/******    				/* Step U. Uniform sample */
/******    				/* for inversion method */
/******    		u = Uniform.random();
/******    		ipois = 0;
/******    		if (u <= p0)
/******    		    return (double)ipois;
/******    				/* Step T. table comparison until */
/******    				/* the end pp(l) of the pp-table of */
/******    				/* cumulative Poisson probabilities */
/******    				/* (0.458=pp(9) for mu=10) */
/******    		if (l != 0) {
/******    		    j = 1;
/******    		    if (u > 0.458)
/****** /*!* 			j = Math.min(l, m); *!*/
/******    			j = Math.min(l, m);
/******    		    for (k = j; k <= l; k++)
/******    			if (u <= pp[k])
/******    			    return (double)k;
/******    		    if (l == 35)
/******    			continue;
/******    		}
/******    				/* Step C. creation of new Poisson */
/******    				/* probabilities p and their cumulatives */
/******    				/* q=pp[k] */
/******    		l = l + 1;
/******    		for (k = l; k <= 35; k++) {
/******    		    p = p * mu / k;
/******    		    q = q + p;
/******    		    pp[k] = q;
/******    		    if (u <= q) {
/******    			l = k;
/******    			return (double)k;
/******    		    }
/******    		}
/******    		l = 35;
/******    	    }
/******    	}
/******        }
/******        /* Step N. Normal sample */
/******        /* Normal.random() for standard Normal deviate */
/******        g = mu + s * Normal.random();
/******        if (g >= 0.0) {
/******    	ipois = g;
/******    	/* Step I. immediate acceptance */
/******    	/* if ipois is large enough */
/******    	if (ipois >= l)
/******    	    return (double)ipois;
/******    	/* Step S. squeeze acceptance */
/******    	/* Uniform.random() for (0,1)-sample u */
/******    	fk = ipois;
/******    	difmuk = mu - fk;
/******    	u = Uniform.random();
/******    	if (d * u >= difmuk * difmuk * difmuk)
/******    	    return (double)ipois;
/******        }
/******        /* Step P. preparations for steps Q and H. */
/******        /* (recalculations of parameters if necessary) */
/******        /* 0.3989423=(2*pi)**(-0.5) */
/******        /* 0.416667e-1=1./24. */
/******        /* 0.1428571=1./7. */
/******        /* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite */
/******        /* approximations to the discrete Normal probabilities fk. */
/******        /* c=.1069/mu guarantees majorization by the 'hat'-function. */
/******        if (mu != muold) {
/******    	muold = mu;
/******    	omega = 0.3989423 / s;
/******    	b1 = 0.4166667e-1 / mu;
/******    	b2 = 0.3 * b1 * b1;
/******    	c3 = 0.1428571 * b1 * b2;
/******    	c2 = b2 - 15. * c3;
/******    	c1 = b1 - 6. * b2 + 45. * c3;
/******    	c0 = 1. - b1 + 3. * b2 - 15. * c3;
/******    	c = 0.1069 / mu;
/******        }
/******        if (g >= 0.0) {
/******    	/* 'Subroutine' F is called (kflag=0 for correct return) */
/******    	kflag = 0;
/******    	goto L20;
/******        }
/******	else while(true) {
/******    	/* Step E. Exponential Sample */
/******    	/* exponential.random() for standard exponential deviate */
/******    	/* e and sample t from the laplace 'hat' */
/******    	/* (if t <= -0.6744 then pk < fk for all mu >= 10.) */
/******    	e = exponential.random();
/******    	u = Uniform.random();
/******    	u = u + u - 1.0;
/****** /*!* 	t = 1.8 + fsign(e, u); *!*/
/******    	t = 1.8 + Misc.fsign(e, u);
/******    	if (t > -0.6744) {
/******    	    ipois = mu + s * t;
/******    	    fk = ipois;
/******    	    difmuk = mu - fk;
/******	    f(
/******    	    /* 'subroutine' f is called */
/******    	    /* (kflag=1 for correct return) */
/******    	    kflag = 1;
/******	    //**********	    subroutine_f(kflag)  ************** //
/******
/******   	}
/******        }
/******        return (double)ipois;
/******    }
/******  }
/******
/******double[] subroutine_f ( double px; double mu; double py; double del; double fk; double v; double a7; double a6; double a5; double a4; double a3; double a2; double a1; double a0; double x; double xx; double fx; double omega; double c3; double c2; double c1; double c0; double u; double e; int kflag )
/******    {
/******
/******    	    /* Step f. 'subroutine' f. */
/******    	    /* calculation of px,py,fx,fy. */
/******    	    /* case ignpoi < 10 uses */
/******    	    /* factorials from table fact */
/******    	  L20:if (ipois < 10) {
/******    	      px = -mu;
/****** /*!* 	      py = pow(mu, (double) ipois) / fact[ipois]; *!*/
/******    	      py = java.lang.Math.pow(mu, (double) ipois) / fact[ipois];
/******    	  } else {
/******    				/* Case ipois >= 10 uses polynomial */
/******    				/* approximation a0-a7 for accuracy */
/******    				/* when advisable */
/******    				/* 0.8333333e-1=1./12.0 */
/******    				/* 0.3989423=(2*pi)**(-0.5) */
/******    	      del = 0.8333333e-1 / fk;
/******    	      del = del - 4.8 * del * del * del;
/******    	      v = difmuk / fk;
/****** /*!* 	      if (fabs(v) <= 0.25) *!*/
/******    	      if (java.lang.Math.abs(v) <= 0.25)
/******    		  px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) * v + a3) * v + a2) * v + a1) * v + a0) - del;
/******    	      else
/****** /*!* 		  px = fk * log(1.0 + v) - difmuk - del; *!*/
/******    		  px = fk * java.lang.Math.log(1.0 + v) - difmuk - del;
/****** /*!* 	      py = 0.3989423 / sqrt(fk); *!*/
/******    	      py = 0.3989423 / java.lang.Math.sqrt(fk);
/******    	  }
/******    	    x = (0.5 - difmuk) / s;
/******    	    xx = x * x;
/******    	    fx = -0.5 * xx;
/******    	    fy = omega * (((c3 * xx + c2) * xx + c1) * xx + c0);
/******    	    if (kflag > 0) {
/******    				/* Step H. hat acceptance */
/******    				/* (e is while(true)ed on rejection) */
/****** /*!* 		if (c * fabs(u) <= py * exp(px + e) - fy * exp(fx + e)) *!*/
/******    		if (c * java.lang.Math.abs(u) <= py * java.lang.Math.exp(px + e) - fy * java.lang.Math.exp(fx + e))
/******    		    break;
/******    	    } else
/******    				/* step q. quotient acceptance (rare case) */
/****** /*!* 		if (fy - u * fy <= py * exp(px - fx)) *!*/
/******    		if (fy - u * fy <= py * java.lang.Math.exp(px - fx))
/******    		    break;
/******}
*******/
 
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/NegativeBinomial.java0000644000175000017500000002301111376411123033225 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class NegativeBinomial
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n, double p);
     *
     *  DESCRIPTION
     *
     *    The density function of the negative binomial distribution.
     *
     *  NOTES
     *
     *    x = the number of failures before the n-th success
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double n, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p))
    	return x + n + p;
    /*!* #endif /*4!*/
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (n < 1 || p <= 0 || p >= 1) {
	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	return Double.NaN;
        }
        if (x < 0)
    	return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isInfinite(x))
    	return 0;
    /*!* #endif /*4!*/
/*!*     return exp(lfastchoose(x + n - 1, x) *!*/
        return java.lang.Math.exp(Misc.lfastchoose(x + n - 1, x)
/*!* 	       + n * log(p) + x * log(1 - p)); *!*/
    	       + n * java.lang.Math.log(p) + x * java.lang.Math.log(1 - p));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double n, double p);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the negative binomial distribution.
     *
     *  NOTES
     *
     *    x = the number of failures before the n-th success
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p))
    	return x + n + p;
        if(Double.isInfinite(n) || Double.isInfinite(p)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (n < 1 || p <= 0 || p >= 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x < 0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isInfinite(x))
    	return 1;
    /*!* #endif /*4!*/
        return Beta.cumulative(p, n, x + 1);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double n, double p);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the negative binomial distribution.
     *
     *  NOTES
     *
     *    x = the number of failures before the n-th success
     *
     *  METHOD
     *
     *    Uses the Cornish-Fisher Expansion to include a skewness
     *    correction to a Normal approximation.  This gives an
     *    initial value which never seems to be off by more than
     *    1 or 2.  A search is then conducted of values close to
     *    this initial start point.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double n, double p)
    {
        double P, Q, mu, sigma, gamma, z, y;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p))
    	return x + n + p;
        if (Double.isInfinite(x)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (x < 0 || x > 1 || p <= 0 || p >= 1 || n <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x == 0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (x == 1) return Double.POSITIVE_INFINITY;
    /*!* #endif /*4!*/
        Q = 1.0 / p;
        P = (1.0 - p) * Q;
        mu = n * P;
/*!*     sigma = sqrt(n * P * Q); *!*/
        sigma = java.lang.Math.sqrt(n * P * Q);
        gamma = (Q + P)/sigma;
        z = Normal.quantile(x, 0.0, 1.0);
/*!*     y = floor(mu + sigma * (z + Gamma * (z*z - 1.0) / 6.0) + 0.5); *!*/
        y = java.lang.Math.floor(mu + sigma * (z + gamma * (z*z - 1.0) / 6.0) + 0.5);
    
        z = cumulative(y, n, p);
        if(z >= x) {
    
    	/* search to the left */
    
    	for(;;) {
    	    if((z = cumulative(y - 1, n, p)) < x)
    		return y;
    	    y = y - 1;
    	}
        }
        else {
    
    	/* search to the right */
    
    	for(;;) {
    	    if((z = cumulative(y + 1, n, p)) >= x)
    		return y + 1;
    	    y = y + 1;
    	}
        }
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n, double p);
     *
     *  DESCRIPTION
     *
     *    Random variates from the negative binomial distribution.
     *
     *  NOTES
     *
     *    x = the number of failures before the n-th success
     * 
     *  REFERENCE
     * 
     *    Devroye, L. (1980).
     *    Non-Uniform Random Variate Generation.
     *    New York:Springer-Verlag. Page 480.
     * 
     *  METHOD
     * 
     *    Generate lambda as Gamma with shape parameter n and scale
     *    parameter p/(1-p).  Return a Poisson deviate with mean lambda.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double n, double p, Uniform uniformDistribution)
    {
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if(
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(n) || Double.isInfinite(p) ||
    /*!* #endif /*4!*/
    	n <= 0 || p <= 0 || p >= 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        return Poisson.random(Gamma.random(n, (1 - p) / p, uniformDistribution), uniformDistribution);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Chisquare.java0000644000175000017500000001301611376411123031740 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Chisquare
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double df)
     *
     *  DESCRIPTION
     *
     *    The density of the chi-squared disribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double df)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        /* NaNs propagated correctly */
    /*!* #endif /*4!*/
        return Gamma.density(x, df / 2.0, 2.0);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double df);
     *
     *  DESCRIPTION
     *
     *    The disribution function of the chi-squared distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double df)
    {
        return Gamma.cumulative(x, df / 2.0, 2.0);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double p, double df);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the chi-squared distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double p, double df)
    {
        return Gamma.quantile(p, 0.5 * df, 2.0);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double df);
     *
     *  DESCRIPTION
     *
     *    Random variates from the chi-squared distribution.
     *
     *  NOTES
     *
     *    Calls rgamma to do the real work.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double df, Uniform uniformDistribution)
    {
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(df) ||
    /*!* #endif /*4!*/
    	df <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        return Gamma.random(df / 2.0, 2.0, uniformDistribution);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Binomial.java0000644000175000017500000003367011376411123031556 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Binomial
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n, double p)
     *
     *  DESCRIPTION
     *
     *    The density of the Binomial distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double n, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        /* NaNs propagated correctly */
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p)) return x + n + p;
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if(n <= 0 || p < 0 || p > 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
        if (x < 0 || x > n)
    	return 0;
        if (p == 0)
    	return (x == 0) ? 1 : 0;
        if (p == 1)
    	return (x == n) ? 1 : 0;
/*!*     return exp(lfastchoose(n, x) + log(p) * x + (n - x) * log(1 - p)); *!*/
        return java.lang.Math.exp(Misc.lfastchoose(n, x) + java.lang.Math.log(p) * x + (n - x) * java.lang.Math.log(1 - p));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double n, double p)
     *  
     *  DESCRIPTION
     *
     *    The distribution function of the Binomial distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n, double p)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p))
    	return x + n + p;
        if (Double.isInfinite(n) || Double.isInfinite(p)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if(n <= 0 || p < 0 || p > 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     x = floor(x); *!*/
        x = java.lang.Math.floor(x);
        if (x < 0.0) return 0;
        if (n <= x) return 1;
        return Beta.cumulative(1.0 - p, n - x, x + 1);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double n, double p);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Binomial distribution.
     *
     *  NOTES
     *
     *    The function uses the Cornish-Fisher Expansion to include
     *    a skewness correction to a Normal approximation.  This gives
     *    an initial value which never seems to be off by more than
     *    1 or 2.  A search is then conducted of values close to
     *    this initial start point.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double n, double p)
    {
        double q, mu, sigma, gamma, z, y;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n) || Double.isNaN(p))
    	return x + n + p;
        if(Double.isInfinite(x) || Double.isInfinite(n) || Double.isInfinite(p)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
    
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (x < 0 || x > 1 || p <= 0 || p >= 1 || n <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x == 0) return 0.0;
        if (x == 1) return n;
        q = 1 - p;
        mu = n * p;
/*!*     sigma = sqrt(n * p * q); *!*/
        sigma = java.lang.Math.sqrt(n * p * q);
        gamma = (q-p)/sigma;
        z = Normal.quantile(x, 0.0, 1.0);
/*!*     y = floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5); *!*/
        y = java.lang.Math.floor(mu + sigma * (z + gamma * (z*z - 1) / 6) + 0.5);
    
        z = cumulative(y, n, p);
        if(z >= x) {
    
    	/* search to the left */
    
    	for(;;) {
    	    if((z = cumulative(y - 1, n, p)) < x)
    		return y;
    	    y = y - 1;
    	}
        }
        else {
    
    	/* search to the right */
    
    	for(;;) {
    	    if((z = cumulative(y + 1, n, p)) >= x)
    		return y + 1;
    	    y = y + 1;
    	}
        }
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double nin, double pp)
     *    
     *  DESCRIPTION
     *
     *    Random variates from the Binomial distribution.
     *
     *  REFERENCE
     *
     *    Kachitvichyanukul, V. and Schmeiser, B. W. (1988).
     *    Binomial random variate generation.
     *    Communications of the ACM 31, p216.
     *    (Algorithm BTPEC).
     */
    
    /*!* #include "DistLib.h" /*4!*/
    /*!* #include  /*4!*/
    

    public static double  random(double nin, double pp, Uniform uniformDistribution)
    {
      double al=0.0, alv=0.0, amaxp=0.0, c=0.0, f=0.0, f1=0.0;
      double f2=0.0, ffm=0.0, fm=0.0, g=0.0;
      double p1=0.0, p2=0.0, p3=0.0, p4=0.0, qn=0.0, r=0.0;
      double u=0.0, v=0.0, w=0.0, w2=0.0;
      double x=0.0, x1=0.0, x2=0.0, xl=0.0, xll=0.0, xlr=0.0;
      double xm=0.0, xnp=0.0, xnpq=0.0, xr=0.0, ynorm=0.0, z=0.0, z2=0.0;
      int i=0, ix=0, ix1=0, k=0, m=0, mp=0, n=0;
      double p=0.0, q=0.0;
      double psave = -1.0;
      int nsave = -1;

    
/*!*     n = floor(nin + 0.5); *!*/
        n = (int) java.lang.Math.floor(nin + 0.5);
        /* n=0, p=0, p=1 are not errors */
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(n) || Double.isInfinite(pp) ||
    /*!* #endif /*4!*/
    	n < 0.0 || pp < 0.0 || pp > 1.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (n==0.0 || pp==0) return 0;
        if (pp==1.0) return n;
    
        /* setup, perform only when parameters change */
    
    L30: {
    L20: {
    L10: {
        if (pp != psave) {
    	psave = pp;
/*!* 	p = fmin2(psave, 1.0 - psave); *!*/
    	p = Math.min(psave, 1.0 - psave);
    	q = 1.0 - p;
        } else if (n == nsave) {
    	if (xnp < 30.0)
    	    break L20;
    	break L10;
        }
        xnp = n * p;
        nsave = n;
        if (xnp < 30.0) {
    	/* inverse cdf logic for mean less than 30 */
/*!* 	qn = pow(q, (double) n); *!*/
    	qn = java.lang.Math.pow(q, (double) n);
    	r = p / q;
    	g = r * (n + 1);
    	break L20;
        } else {
    	ffm = xnp + p;
    	m = (int) ffm;
    	fm = m;
    	xnpq = xnp * q;
/*!* 	p1 = (int)(2.195 * sqrt(xnpq) - 4.6 * q) + 0.5; *!*/
    	p1 = (int)(2.195 * java.lang.Math.sqrt(xnpq) - 4.6 * q) + 0.5;
    	xm = fm + 0.5;
    	xl = xm - p1;
    	xr = xm + p1;
    	c = 0.134 + 20.5 / (15.3 + fm);
    	al = (ffm - xl) / (ffm - xl * p);
    	xll = al * (1.0 + 0.5 * al);
    	al = (xr - ffm) / (xr * q);
    	xlr = al * (1.0 + 0.5 * al);
    	p2 = p1 * (1.0 + c + c);
    	p3 = p2 + c / xll;
    	p4 = p3 + c / xlr;
        }
    } 
    // L10:
    while(true) {
	  u = uniformDistribution.random() * p4;
          v = uniformDistribution.random();
          /* triangular region */
          if (u <= p1) {
    	  ix = (int) (xm - p1 * v + u);
    	  break L30;
          }
          /* parallelogram region */
          if (u <= p2) {
    	  x = xl + (u - p1) / c;
/*!* 	  v = v * c + 1.0 - fabs(xm - x) / p1; *!*/
    	  v = v * c + 1.0 - java.lang.Math.abs(xm - x) / p1;
    	  if (v > 1.0 || v <= 0.)
    	      continue;
    	  ix = (int) x;
          } else {
    	  if (u > p3) {	/* right tail */
/*!* 	      ix = xr - log(v) / xlr; *!*/
    	      ix = (int)( xr - java.lang.Math.log(v) / xlr);
    	      if (ix > n)
    		  continue;
    	      v = v * (u - p3) * xlr;
    	  } else {/* left tail */
/*!* 	      ix = xl + log(v) / xll; *!*/
    	      ix = (int) (xl + java.lang.Math.log(v) / xll);
    	      if (ix < 0)
    		  continue;
    	      v = v * (u - p2) * xll;
    	  }
          }
          /* determine appropriate way to perform accept/reject test */
/*!*       k = abs(ix - m); *!*/
          k = java.lang.Math.abs(ix - m);
          if (k <= 20 || k >= xnpq / 2 - 1) {
    	  /* explicit evaluation */
    	  f = 1.0;
    	  r = p / q;
    	  g = (n + 1) * r;
    	  if (m < ix) {
    	      mp = m + 1;
    	      for (i = mp; i <= ix; i++)
    		  f = f * (g / i - r);
    	  } else if (m != ix) {
    	      ix1 = ix + 1;
    	      for (i = ix1; i <= m; i++)
    		  f = f / (g / i - r);
    	  }
    	  if (v <= f)
    	      break L30;
          } else {
    	  /* squeezing using upper and lower bounds */
    	  /* on log(f(x)) */
    	  amaxp = (k / xnpq) * ((k * (k / 3.0 + 0.625) + 0.1666666666666) / xnpq + 0.5);
    	  ynorm = -k * k / (2.0 * xnpq);
/*!* 	  alv = log(v); *!*/
    	  alv = java.lang.Math.log(v);
    	  if (alv < ynorm - amaxp)
    	      break L30;
    	  if (alv <= ynorm + amaxp) {
    				/* stirling's formula to machine accuracy */
    				/* for the final acceptance/rejection test */
    	      x1 = ix + 1;
    	      f1 = fm + 1.0;
    	      z = n + 1 - fm;
    	      w = n - ix + 1.0;
    	      z2 = z * z;
    	      x2 = x1 * x1;
    	      f2 = f1 * f1;
    	      w2 = w * w;
/*!* 	      if (alv <= xm * log(f1 / x1) + (n - m + 0.5) * log(z / w) + (ix - m) * log(w * p / x1 * q) + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / f2) / f2) / f2) / f2) / f1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / z2) / z2) / z2) / z2) / z / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / x2) / x2) / x2) / x2) / x1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / w2) / w2) / w2) / w2) / w / 166320.) *!*/
    	      if (alv <= xm * java.lang.Math.log(f1 / x1) + (n - m + 0.5) * java.lang.Math.log(z / w) + (ix - m) * java.lang.Math.log(w * p / x1 * q) + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / f2) / f2) / f2) / f2) / f1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / z2) / z2) / z2) / z2) / z / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / x2) / x2) / x2) / x2) / x1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / w2) / w2) / w2) / w2) / w / 166320.)
    		  break L30;
    	  }
          }
      }
    } 
    // L20:
    while(true) {
	ix = 0;
	f = qn;
	u = uniformDistribution.random();
	while(true) {
	    if (u < f)
		break L30;
	    if (ix > 110)
		break;
	    u = u - f;
	    ix = ix + 1;
	    f = f * (g / ix - r);
	}
    }
	}
	// L30:
	if (psave > 0.5)
	    ix = n - ix;
	return (double)ix;
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/SignRank.java0000644000175000017500000002141311376411123031530 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class SignRank
  { 


	public static final double  SIGNRANK_NMAX = 50; 

    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 R Core Team
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n)
     *
     *  DESCRIPTION
     *
     *    The density of the Wilcoxon Signed Rank distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static private double w[][];
    
    static private double csignrank(int k, int n) {
      int c, u, i;
    
      u = n * (n + 1) / 2;
      c = (int) (u / 2);
    
      if ((k < 0) || (k > u))
          return(0);
      if (k > c)
          k = u - k;
      if (w[n] == null) {
          w[n] = new double[c + 1];
          for (i = 0; i <= c; i++)
    	  w[n][i] = -1;
      }
      if (w[n][k] < 0) {
          if (n == 0)
    	  w[n][k] = (k == 0)?1.0:0.0;
          else
    	  w[n][k] = csignrank(k - n, n - 1) + csignrank(k, n - 1);
      }
      return(w[n][k]);
    }
    
    public static double  density(double x, double n) {
    /*!* #ifdef IEEE_754 /*4!*/
        /* NaNs propagated correctly */
        if (Double.isNaN(x) || Double.isNaN(n)) return x + n;
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (n <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        } else if (n >= SIGNRANK_NMAX) {
    	System.out.println("n should be less than %d\n"+ SIGNRANK_NMAX);
    	return Double.NaN;
        }
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
        if ((x < 0) || (x > (n * (n + 1) / 2)))
    	return 0;
/*!*     return(exp(log(csignrank(x, n)) - n * log(2))); *!*/
        return(java.lang.Math.exp(
		  java.lang.Math.log(
		     csignrank((int) x, (int) n)) - n * java.lang.Math.log(2)));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 R Core Team
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double n)
     *
     *  DESCRIPTION
     *
     *    The distribution function of the Wilcoxon Signed Rank distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n) {
        int i;
        double p = 0.0;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n))
        return x + n;
        if (Double.isInfinite(n)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (n <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        } else if (n >= SIGNRANK_NMAX) {
    	System.out.println("n should be less than %d\n"+ SIGNRANK_NMAX);
    	return Double.NaN;
        }
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
        if (x < 0.0)
    	return 0;
        if (x >= n * (n + 1) / 2)
    	return 1;
        for (i = 0; i <= x; i++)
    	p += density(i, n);
        return(p);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 R Core Team
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double n);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Wilcoxon Signed Rank distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double n)
    {
        double p, q;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n))
    	return x + n;
        if(Double.isInfinite(x) || Double.isInfinite(n)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
    
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (x < 0 || x > 1 || n <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        } else if (n >= SIGNRANK_NMAX) {
    	System.out.println("n should be less than %d\n"+ SIGNRANK_NMAX);
    	return Double.NaN;
        }
    
        if (x == 0) return(0.0);
        if (x == 1) return(n * (n + 1) / 2);
        p = 0.0;
        q = 0.0;
        for (;;) {
    	/* Don't call cumulative() for efficiency */
    	p += density(q, n);
    	if (p >= x)
    	    return(q);
    	q++;
        }
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 R Core Team
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double n)
     *    
     *  DESCRIPTION
     *
     *    Random variates from the Wilcoxon Signed Rank distribution.
     *
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double n)
    {
        int i, k;
        double r;
      
    /*!* #ifdef IEEE_754 /*4!*/
        /* NaNs propagated correctly */
        if (Double.isNaN(n)) return(n);
    /*!* #endif /*4!*/
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (n < 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (n == 0)
    	return(0);
        r = 0.0;
        k = (int) n;
        for (i = 0; i < k; ) {
/*!* 	r += (++i) * floor(sunif() + 0.5); *!*/
    	r += (++i) * java.lang.Math.floor(Uniform.random() + 0.5);
        }
        return(r);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/0000755000175000017500000000000011722677317027754 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/MarsagliaMulticarry.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/MarsagliaMulticarry.0000644000175000017500000000156311324003163033712 0ustar  giovannigiovanni/*
 * Created on Apr 17, 2007
 */
package org.mathpiper.builtin.library.statdistlib.rng;

import org.mathpiper.builtin.library.statdistlib.StdUniformRng;


public class MarsagliaMulticarry implements StdUniformRng {
  
  int i1_seed;
  int[] i_seed;
  
  static private double i2_32m1 = 2.328306437080797e-10; /* = 1/(2^32 - 1) */
  static private int do32bits(int N) { return (N); }
  
  public MarsagliaMulticarry() {
    i1_seed = 123;
    i_seed = new int[1];
    fixupSeeds();
  }
  
  public void fixupSeeds() {
    if (i1_seed==0) i1_seed++;
    for(int j=0; j < i_seed.length; j++) {
      if (i_seed[j]==0) i_seed[j]++;
    }
  }
  
  public double random() {
    i1_seed= 36969*(i1_seed & 0177777) + (i1_seed>>16);
    i_seed[0]= 18000*(i_seed[0] & 0177777) + (i_seed[0]>>16);
    return (do32bits(i1_seed << 16) ^ (i_seed[0] & 0177777)) * i2_32m1; /* in [0,1) */
  }
  
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/WichmannHill.java0000644000175000017500000000242311324003163033151 0ustar  giovannigiovanni/**
 * Wichmann-Hill algorithm for random variates from the 
 * standard uniform distribution, U(0,1).
 * 
    
 *  Wichmann, B. A. and I. D. Hill (1982).
 *  Algorithm AS 183: An efficient and portable
 *  pseudo-random number generator,
 *  Applied Statistics, 31, 188.
 *  
 * Created on Apr 16, 2007
 */
package org.mathpiper.builtin.library.statdistlib.rng;

import org.mathpiper.builtin.library.statdistlib.StdUniformRng;

public class WichmannHill implements StdUniformRng {
  
  int i1_seed;
  int[] i_seed;
  static final int c0 = 30269;
  static final int c1 = 30307;
  static final int c2 = 30323;
  
  public WichmannHill() {
    i1_seed = 123;
    i_seed = new int[2];
    fixupSeeds();
  }
  
  public void fixupSeeds() {
    // exclude 0 as seed
    if (i1_seed==0) i1_seed++;
    for (int j=0; j < i_seed.length; j++) {
      if (i_seed[j]==0) i_seed[j]++;
    }
    if (i1_seed >= c0 ||
         i_seed[0] >= c1 ||
         i_seed[1] >= c2) {
      random();
    }
  }
  
  public double random() {
    i1_seed = i1_seed * 171 % c0;
    i_seed[0] = i_seed[0] * 172 % c1;
    i_seed[1] = i_seed[1] * 170 % c2;
    double value =
      (double)i1_seed / c0 +
      (double)i_seed[0] / c1 +
      (double)i_seed[1] / c2;
    return value - (int) value; // ensure in range [0,1)
  }
  
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/Rand.java0000644000175000017500000000067411324003163031466 0ustar  giovannigiovanni/*
 * Created on Apr 17, 2007
 */
package org.mathpiper.builtin.library.statdistlib.rng;

import java.util.Random;

import org.mathpiper.builtin.library.statdistlib.StdUniformRng;


public class Rand implements StdUniformRng {

  Random random;
  
  public Rand() {
    random = new Random();
  }
  
  public void fixupSeeds() {
    ; // do nothing since seeds are managed
  }

  public double random() {
    return random.nextDouble();
  }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/rng/SuperDuper.java0000644000175000017500000000210211324003163032664 0ustar  giovannigiovanni/**
 * Standard random deviates via 
 * Reeds et al (1984) implementation; 
 * modified using __unsigned__  seeds instead of signed ones.
 *
 * Created on Apr 17, 2007
 */
package org.mathpiper.builtin.library.statdistlib.rng;

import org.mathpiper.builtin.library.statdistlib.StdUniformRng;


public class SuperDuper implements StdUniformRng {

  private int i1_seed;
  private int[] i_seed;

  static private double i2_32m1 = 2.328306437080797e-10; /* = 1/(2^32 - 1) */
  static private int do32bits(int N) { return (N); }

  public SuperDuper() {
    i1_seed = 123;
    i_seed = new int[1];
    fixupSeeds();
  }
  public void fixupSeeds() {
    if (i1_seed==0) i1_seed++;
    for(int j=0; j < i_seed.length; j++) {
      if (i_seed[j]==0) i_seed[j]++;
    }
    i_seed[0] |= 1; // seed must be odd
  }

  public double random() {
    i1_seed ^= ((i1_seed >> 15) & 0377777); /* Tausworthe */
    i1_seed ^= do32bits(i1_seed << 17);
    i_seed[0] *= 69069;     /* Congruential */
    i_seed[0] = do32bits(69069 * i_seed[0]);
    return (i1_seed^i_seed[0]) * i2_32m1;/* in [0,1) */
  }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Hypergeometric.java0000644000175000017500000004604211376411123033007 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Hypergeometric
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double NR, double NB, double n);
     *
     *  DESCRIPTION
     *
     *    The density of the Hypergeometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double NR, double NB, double n)
    {
        double N;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(NR) || Double.isNaN(NB) || Double.isNaN(n))
    	return x + NR + NB + n;
    /*!* #endif /*4!*/
/*!*     x = floor(x + 0.5); *!*/
        x = java.lang.Math.floor(x + 0.5);
/*!*     NR = floor(NR + 0.5); *!*/
        NR = java.lang.Math.floor(NR + 0.5);
/*!*     NB = floor(NB + 0.5); *!*/
        NB = java.lang.Math.floor(NB + 0.5);
        N = NR + NB;
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (NR < 0 || NB < 0 || n < 0 || n > N) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     if (x < fmax2(0, n - NB) || x > fmin2(n, NR)) *!*/
        if (x < Math.max(0, n - NB) || x > Math.min(n, NR))
    	return 0;
/*!*     return exp(lfastchoose(NR, x) + lfastchoose(NB, n - x) *!*/
        return java.lang.Math.exp(Misc.lfastchoose(NR, x) + Misc.lfastchoose(NB, n - x)
/*!* 	       - lfastchoose(N, n)); *!*/
    	       - Misc.lfastchoose(N, n));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double NR, double NB, double n);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the Hypergeometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double NR, double NB, double n)
    {
        double N, xstart, xend, xr, xb, sum, term;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isNaN(x) || Double.isNaN(NR) || Double.isNaN(NB) || Double.isNaN(n))
    	return x + NR + NB + n;
        if(Double.isInfinite(x) || Double.isInfinite(NR) || Double.isInfinite(NB) || Double.isInfinite(n)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
    
/*!*     x = floor(x); *!*/
        x = java.lang.Math.floor(x);
/*!*     NR = floor(NR + 0.5); *!*/
        NR = java.lang.Math.floor(NR + 0.5);
/*!*     NB = floor(NB + 0.5); *!*/
        NB = java.lang.Math.floor(NB + 0.5);
        N = NR + NB;
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (NR < 0 || NB < 0 || n < 0 || n > N) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     xstart = fmax2(0, n - NB); *!*/
        xstart = Math.max(0, n - NB);
/*!*     xend = fmin2(n, NR); *!*/
        xend = Math.min(n, NR);
        if(x < xstart) return 0.0;
        if(x >= xend) return 1.0;
        xr = xstart;
        xb = n - xr;
/*!*     term = exp(lfastchoose(NR, xr) + lfastchoose(NB, xb) *!*/
        term = java.lang.Math.exp(Misc.lfastchoose(NR, xr) + Misc.lfastchoose(NB, xb)
/*!* 	       - lfastchoose(N, n)); *!*/
    	       - Misc.lfastchoose(N, n));
        NR = NR - xr;
        NB = NB - xb;
        sum = 0.0;
        while(xr <= x) {
    	sum += term;
    	xr++;
    	NB++;
    	term *= (NR / xr) * (xb / NB);
    	xb--;
    	NR--;
        }
        return sum;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double NR, double NB, double n);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Hypergeometric distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double NR, double NB, double n)
    {
        double N, xstart, xend, xr, xb, sum, term;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(NR) || Double.isNaN(NB) || Double.isNaN(n))
    	return x + NR + NB + n;
        if(Double.isInfinite(x) || Double.isInfinite(NR) || Double.isInfinite(NB) || Double.isInfinite(n)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
/*!*     NR = floor(NR + 0.5); *!*/
        NR = java.lang.Math.floor(NR + 0.5);
/*!*     NB = floor(NB + 0.5); *!*/
        NB = java.lang.Math.floor(NB + 0.5);
        N = NR + NB;
/*!*     n = floor(n + 0.5); *!*/
        n = java.lang.Math.floor(n + 0.5);
        if (x < 0 || x > 1 || NR < 0 || NR < 0 || n < 0 || n > N) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     xstart = fmax2(0, n - NB); *!*/
        xstart = Math.max(0, n - NB);
/*!*     xend = fmin2(n, NR); *!*/
        xend = Math.min(n, NR);
        if(x <= 0) return xstart;
        if(x >= 1) return xend;
        xr = xstart;
        xb = n - xr;
/*!*     term = exp(lfastchoose(NR, xr) + lfastchoose(NB, xb) *!*/
        term = java.lang.Math.exp(Misc.lfastchoose(NR, xr) + Misc.lfastchoose(NB, xb)
/*!* 	       - lfastchoose(N, n)); *!*/
    	       - Misc.lfastchoose(N, n));
        NR = NR - xr;
        NB = NB - xb;
        sum = term;
        while(sum < x && xr < xend) {
    	xr++;
    	NB++;
    	term *= (NR / xr) * (xb / NB);
    	sum += term;
    	xb--;
    	NR--;
        }
        return xr;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double NR, double NB, double n);
     *
     *  DESCRIPTION
     *
     *    Random variates from the Hypergeometric distribution.
     *    Returns the number of white balls drawn when kk balls
     *    are drawn at random from an urn containing nn1 white
     *    and nn2 black balls.
     *
     *  REFERENCE
     *
     *    V. Kachitvichyanukul and B. Schmeiser (1985).
     *    ``Computer generation of Hypergeometric random variates,''
     *    Journal of Statistical Computation and Simulation 22, 127-145.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    /* afc(i) :=  ln( i! )	[logarithm of the factorial i.
     *	   If (i > 7), use Stirling's approximation, otherwise use table lookup.
    */
    
    static private double al[] =
    {
        0.0,
        0.0,/*ln(0!)=ln(1)*/
        0.0,/*ln(1!)=ln(1)*/
        0.69314718055994530941723212145817,/*ln(2) */
        1.79175946922805500081247735838070,/*ln(6) */
        3.17805383034794561964694160129705,/*ln(24)*/
        4.78749174278204599424770093452324,
        6.57925121201010099506017829290394,
        8.52516136106541430016553103634712
        /*, 10.60460290274525022841722740072165*/
    };
    
    static private double afc(int i)
    {
        double di, value;
        if (i < 0) {
          System.out.println("rhyper.c: afc(i)+ i=%d < 0 -- SHOULD NOT HAPPEN!\n"+i);
          return -1;/* unreached (Wall) */
        } else if (i <= 7) {
    	value = al[i + 1];
        } else {
    	di = i;
/*!* 	value = (di + 0.5) * log(di) - di + 0.08333333333333 / di *!*/
    	value = (di + 0.5) * java.lang.Math.log(di) - di + 0.08333333333333 / di
    	    - 0.00277777777777 / di / di / di + 0.9189385332;
        }
        return value;
    }
    

      static private int ks = -1;
      static private int n1s = -1;
      static private int n2s = -1;
      static private double con = 57.56462733;
      static private double deltal = 0.0078;
      static private double deltau = 0.0034;
      static private double scale = 1e25;
      
      static private double a;
      static private double d, e, f, g;
      static private int i, k, m;
      static private double p;
      static private double r, s, t;
      static private double u, v, w;
      static private double lamdl, y, lamdr;
      static private int minjx, maxjx, n1, n2;
      static private double p1, p2, p3, y1, de, dg;
      static private boolean setup1, setup2;
      static private double gl, kl, ub, nk, dr, nm, gu, kr, ds, dt;
      static private int ix;
      static private double tn;
      static private double xl;
      static private double ym, yn, yk, xm;
      static private double xr;
      static private double xn;
      static private boolean reject;
      static private double xk;
      /* extern double afc(int); */
      static private double alv;
    

    public static double  random(double nn1in, double nn2in, double kkin,
				 Uniform uniformDistribution)
    {
        int nn1, nn2, kk;
    
        /* check parameter validity */
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isInfinite(nn1in) || Double.isInfinite(nn2in) || Double.isInfinite(kkin)) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #endif /*4!*/
    
/*!*     nn1 = floor(nn1in+0.5); *!*/
        nn1 = (int) java.lang.Math.floor(nn1in+0.5);
/*!*     nn2 = floor(nn2in+0.5); *!*/
        nn2 = (int) java.lang.Math.floor(nn2in+0.5);
/*!*     kk = floor(kkin+0.5); *!*/
        kk = (int) java.lang.Math.floor(kkin+0.5);
    
        if (nn1 < 0 || nn2 < 0 || kk < 0 || kk > nn1 + nn2) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//  	return Double.NaN;
        }
        /* if new parameter values, initialize */
    
        reject = true;
        setup1 = false;
        setup2 = false;
        if (nn1 != n1s || nn2 != n2s) {
    	setup1 = true;
    	setup2 = true;
        } else if (kk != ks) {
    	setup2 = true;
        }
        if (setup1) {
    	n1s = nn1;
    	n2s = nn2;
    	tn = nn1 + nn2;
    	if (nn1 <= nn2) {
    	    n1 = nn1;
    	    n2 = nn2;
    	} else {
    	    n1 = nn2;
    	    n2 = nn1;
    	}
        }
        if (setup2) {
    	ks = kk;
    	if (kk + kk >= tn) {
    	    k = (int) (tn) - kk;
    	} else {
    	    k = kk;
    	}
        }
        if (setup1 || setup2) {
    	m = (int) ((k + 1.0) * (n1 + 1.0) / (tn + 2.0));
/*!* 	minjx = imax2(0, k - n2); *!*/
    	minjx = Math.max(0, k - n2);
/*!* 	maxjx = Math.min(n1, k); *!*/
    	maxjx = Math.min(n1, k);
        }
        /* generate random variate */
    
        if (minjx == maxjx) {
    	/* degenerate distribution */
    	ix = maxjx;
    	/* return ix;
    	   No, need to unmangle */
    	/* return appropriate variate */
    
    	if (kk + kk >= tn) {
	    if (nn1 > nn2) {
		ix = kk - nn2 + ix;
	    } else {
		ix = nn1 - ix;
	    }
    	} else {
	    if (nn1 > nn2)
		ix = kk - ix;
    	}
    	return ix;
	
        } else if (m - minjx < 10) {
	    /* inverse transformation */
	    if (setup1 || setup2) {
		if (k < n2) {
		    /*!* 		w = exp(con + afc(n2) + afc(n1 + n2 - k) *!*/
		    w = java.lang.Math.exp(con + afc(n2) + afc(n1 + n2 - k)
					   - afc(n2 - k) - afc(n1 + n2));
		} else {
		    /*!* 		w = exp(con + afc(n1) + afc(k) *!*/
		    w = java.lang.Math.exp(con + afc(n1) + afc(k)
					   - afc(k - n2) - afc(n1 + n2));
		}
	    }
	L10: while(true) {
	    p = w;
	    ix = minjx;
	    u = uniformDistribution.random() * scale;
	L20: while(true) {
	    if (u > p) {
		u = u - p;
		p = p * (n1 - ix) * (k - ix);
		ix = ix + 1;
		p = p / ix / (n2 - k + ix);
		if (ix > maxjx)
		    continue L10;
		continue L20;
	    }
	    break L10;
	}}
        } else {
	    /* h2pe */
    
	    if (setup1 || setup2) {
		/*!* 	    s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn); *!*/
		s = java.lang.Math.sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
		
		/* remark: d is defined in reference without int. */
    	    /* the truncation centers the cell boundaries at 0.5 */
    
    	    d = (int) (1.5 * s) + .5;
    	    xl = m - d + .5;
    	    xr = m + d + .5;
    	    a = afc(m) + afc(n1 - m) + afc(k - m)
    		+ afc(n2 - k + m);
/*!* 	    kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl)) *!*/
    	    kl = java.lang.Math.exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
    		     - afc((int) (k - xl))
    		     - afc((int) (n2 - k + xl)));
/*!* 	    kr = exp(a - afc((int) (xr - 1)) *!*/
    	    kr = java.lang.Math.exp(a - afc((int) (xr - 1))
    		     - afc((int) (n1 - xr + 1))
    		     - afc((int) (k - xr + 1))
    		     - afc((int) (n2 - k + xr - 1)));
/*!* 	    lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) *!*/
    	    lamdl = -java.lang.Math.log(xl * (n2 - k + xl) / (n1 - xl + 1)
    			 / (k - xl + 1));
/*!* 	    lamdr = -log((n1 - xr + 1) * (k - xr + 1) *!*/
    	    lamdr = -java.lang.Math.log((n1 - xr + 1) * (k - xr + 1)
    			 / xr / (n2 - k + xr));
    	    p1 = d + d;
    	    p2 = p1 + kl / lamdl;
    	    p3 = p2 + kr / lamdr;
    	}
	L30: while(true) {
    	u = uniformDistribution.random() * p3;
    	v = uniformDistribution.random();
    	if (u < p1) {
    	    /* rectangular region */
    	    ix = (int) (xl + u);
    	} else if (u <= p2) {
    	    /* left tail */
/*!* 	    ix = xl + log(v) / lamdl; *!*/
    	    ix = (int) (xl + java.lang.Math.log(v) / lamdl);
    	    if (ix < minjx)
    		continue L30;
    	    v = v * (u - p1) * lamdl;
    	} else {
    	    /* right tail */
/*!* 	    ix = xr - log(v) / lamdr; *!*/
    	    ix = (int) (xr - java.lang.Math.log(v) / lamdr);
    	    if (ix > maxjx)
    		continue L30;
    	    v = v * (u - p2) * lamdr;
    	}
	
    	/* acceptance/rejection test */
    
    	if (m < 100 || ix <= 50) {
    	    /* explicit evaluation */
    	    f = 1.0;
    	    if (m < ix) {
    		for (i = m + 1; i <= ix; i++)
    		    f = f * (n1 - i + 1) * (k - i + 1)
    			/ (n2 - k + i) / i;
    	    } else if (m > ix) {
    		for (i = ix + 1; i <= m; i++)
    		    f = f * i * (n2 - k + i) / (n1 - i)
    			/ (k - i);
    	    }
    	    if (v <= f) {
    		reject = false;
    	    }
    	} else {
    	    /* squeeze using upper and lower bounds */
    	    y = ix;
    	    y1 = y + 1.0;
    	    ym = y - m;
    	    yn = n1 - y + 1.0;
    	    yk = k - y + 1.0;
    	    nk = n2 - k + y1;
    	    r = -ym / y1;
    	    s = ym / yn;
    	    t = ym / yk;
    	    e = -ym / nk;
    	    g = yn * yk / (y1 * nk) - 1.0;
    	    dg = 1.0;
    	    if (g < 0.0)
    		dg = 1.0 + g;
    	    gu = g * (1.0 + g * (-0.5 + g / 3.0));
    	    gl = gu - .25 * (g * g * g * g) / dg;
    	    xm = m + 0.5;
    	    xn = n1 - m + 0.5;
    	    xk = k - m + 0.5;
    	    nm = n2 - k + xm;
    	    ub = y * gu - m * gl + deltau
    		+ xm * r * (1. + r * (-0.5 + r / 3.0))
    		+ xn * s * (1. + s * (-0.5 + s / 3.0))
    		+ xk * t * (1. + t * (-0.5 + t / 3.0))
    		+ nm * e * (1. + e * (-0.5 + e / 3.0));
    	    /* test against upper bound */
/*!* 	    alv = log(v); *!*/
    	    alv = java.lang.Math.log(v);
    	    if (alv > ub) {
    		reject = true;
    	    } else {
    				/* test against lower bound */
    		dr = xm * (r * r * r * r);
    		if (r < 0.0)
    		    dr = dr / (1.0 + r);
    		ds = xn * (s * s * s * s);
    		if (s < 0.0)
    		    ds = ds / (1.0 + s);
    		dt = xk * (t * t * t * t);
    		if (t < 0.0)
    		    dt = dt / (1.0 + t);
    		de = nm * (e * e * e * e);
    		if (e < 0.0)
    		    de = de / (1.0 + e);
    		if (alv < ub - 0.25 * (dr + ds + dt + de)
    		    + (y + m) * (gl - gu) - deltal) {
    		    reject = false;
    		} else {
    		    /*
    		     * stirling's formula to machine
    		     * accuracy
    		     */
    		    if (alv <= (a - afc(ix) - afc(n1 - ix)
    				- afc(k - ix) - afc(n2 - k + ix))) {
    			reject = false;
    		    } else {
    			reject = true;
    		    }
    		}
    	    }
    	}
    	if (reject)
    	    continue L30;
	break L30;
        }
	}
        /* return appropriate variate */
    
        if (kk + kk >= tn) {
    	if (nn1 > nn2) {
    	    ix = kk - nn2 + ix;
    	} else {
    	    ix = nn1 - ix;
    	}
        } else {
    	if (nn1 > nn2)
    	    ix = kk - ix;
        }
        return ix;
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Misc.java0000644000175000017500000012647611376411123030726 0ustar  giovannigiovanni/*  DistLib - A Mathematical Function Library
 *  Copyright (C) 1998  Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *  
 * data translated from C using perl script translate.pl
 * script version 0.00
 */
package org.mathpiper.builtin.library.statdistlib;

/**
 * Miscellaneous functions and values.
 */

public class Misc {

  /**
   * Value of the beta function
   * evaluated with arguments a and b.
   *
   * This routine is a translation into C of a Fortran subroutine
   * by W. Fullerton of Los Alamos Scientific Laboratory.
   * Some modifications have been made so that the routines
   * conform to the IEEE 754 standard.
   */

  public static double  beta(double a, double b) {
    double xmax = 0;
    double alnsml = 0;
    double val=0.0, xmin=0.0;
    double temp[];

    if (xmax == 0) {
      temp = gammalims(xmin, xmax);
      xmin = temp[0]; xmax=temp[1];
      alnsml = java.lang.Math.log(d1mach(1));
    }

    if (Double.isNaN(a) || Double.isNaN(b)) return a + b;

    if (a < 0 || b < 0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    else if (a == 0 || b == 0) {
      return Double.POSITIVE_INFINITY;
    }
    else if (Double.isInfinite(a) || Double.isInfinite(b)) {
      return 0;
    }

    if (a + b < xmax)
      return gammafn(a) * gammafn(b) / gammafn(a+b);

    val = lbeta(a, b);
    // check for underflow of beta
    if (val < alnsml) {
      throw new java.lang.ArithmeticException("Math Error: UNDERFLOW");
    }
    return java.lang.Math.exp(val);
  }
    
  /**
   * Determine the number of terms for the
   * double precision orthogonal Chebyshev series "dos" needed to insure
   * the error is no larger than "eta".  Ordinarily eta will be
   * chosen to be one-tenth machine precision.
   *
   *    These routines are translations into C of Fortran routines
   *    by W. Fullerton of Los Alamos Scientific Laboratory.
   *
   *    Based on the Fortran routine dcsevl by W. Fullerton.
   *    Adapted from R. Broucke, Algorithm 446, CACM., 16, 254 (1973).
   */
  static int chebyshev_init(double dos[], int nos, double eta) {
    if (nos < 1) return 0;

    double err = 0.0;
    int i = 0;
    for (int ii=1; ii<=nos; ii++) {
      i = nos - ii;
      err += java.lang.Math.abs(dos[i]);
      if (err > eta) {
        return i;
      }
    }
    return i;
  }
    
  /**
   * evaluate the n-term Chebyshev series
   * @param x
   * @param a
   * @param n
   * @return
   */    
  public static double  chebyshev_eval(double x, double a[], int n) {
    if (n < 1 || n > 1000) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }

    if (x < -1.1 || x > 1.1) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }

    double twox = x * 2;
    double b2 = 0;
    double b1 = 0;
    double b0 = 0;
    for (int i = 1; i <= n; i++) {
      b2 = b1;
      b1 = b0;
      b0 = twox * b1 - b2 + a[(int) n - i];
    }
    return (b0 - b2) * 0.5;
  }
    
    /*
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double choose(double n, double k);
     *    double fastchoose(double n, double k);
     *    double lchoose(double n, double k);
     *    double lfastchoose(double n, double k);
     *
     *  DESCRIPTION
     *
     *    Binomial coefficients.
     */
    /*!* #include "DistLib.h" /*4!*/
    
  public static double lfastchoose(double n, double k) {
    return lgammafn(n + 1.0) - lgammafn(k + 1.0) - lgammafn(n - k + 1.0);
  }

  public static double fastchoose(double n, double k) {
    return java.lang.Math.exp(lfastchoose(n, k));
  }

  public static double lchoose(double n, double k) {
    n = java.lang.Math.floor(n + 0.5);
    k = java.lang.Math.floor(k + 0.5);
    if (Double.isNaN(n) || Double.isNaN(k)) return n + k;
    if (k < 0 || n < k) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    return lfastchoose(n, k);
  }

  /**
   * binomial coefficient
   * @param n
   * @param k
   * @return
   */
  public static double choose(double n, double k) {
    n = java.lang.Math.floor(n + 0.5);
    k = java.lang.Math.floor(k + 0.5);
    if (Double.isNaN(n) || Double.isNaN(k)) return n + k;
    if (k < 0 || n < k) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    return java.lang.Math.floor(java.lang.Math.exp(lfastchoose(n, k)) + 0.5);
  }

  /**
   * machine dependant constants
   * @param i
   * @return
   */
  
  public static double  d1mach(int i) {
    switch (i) {
    
    case 1: return Double.MIN_VALUE;
    case 2: return Double.MAX_VALUE;
    case 3: return java.lang.Math.pow((double)i1mach(10), -(double)i1mach(14));    
    case 4: return java.lang.Math.pow((double)i1mach(10), 1-(double)i1mach(14));
    case 5: return Math.log(2.0)/Math.log(10.0);

    default: return 0.0;
    }
  }
    
  /*
   * Returns the cube of its argument.
   */
   public static double fcube(double x) {
      return x * x * x;
  }
    
    
  public static double  fmax2(double x, double y) {
  	if (Double.isNaN(x) || Double.isNaN(y))
  	  return x + y;
  	return (x < y) ? y : x;
  }
  
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  fmin2(double x, double y)
    {
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(y))
    		return x + y;
    /*!* #endif /*4!*/
    	return (x < y) ? x : y;
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double fmod(double x, double y);
     *
     *  DESCRIPTION
     *
     *    Floating-point remainder of x / y;
     *
     *  NOTES
     *
     *    It may be better to use the system version of this function,
     *    but this version is portable.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  fmod(double x, double y)
    {
        double quot;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(y))
    	return x + y;
    /*!* #endif /*4!*/
        quot = x / y;
/*!*     return x - (quot < 0.0 ? ceil(quot) : floor(quot)) * y; *!*/
        return x - (quot < 0.0 ? java.lang.Math.ceil(quot) : java.lang.Math.floor(quot)) * y;
    }
    
  /**
   * Returns the value of x rounded to "digits" significant
   * decimal digits.
   *
   * This routine is a translation into C of a Fortran subroutine
   * by W. Fullerton of Los Alamos Scientific Laboratory.
   * Some modifications have been made so that the routines
   * conform to the IEEE 754 standard.
   * 
   * Improvements by Martin Maechler, May 1997
   * Note that the code could be further improved by using 
   * java.lang.Math.pow(x, i)  instead of  pow(x, (double)i) 
   */

  static final double MAXPLACES = Constants.DBL_DIG; 

  public static double fprec(double x, double digits) {

    if (Double.isNaN(x) || Double.isNaN(digits)) return x + digits;
    if (Double.isInfinite(x)) return x;
    if (Double.isInfinite(digits)) {
      if (digits > 0) return x;
      else return 0;
    }

    if (x == 0) return x;
    
    digits = java.lang.Math.floor(digits+0.5);
    if (digits > MAXPLACES) return x;
    else if (digits < 1) digits = 1;

    double sgn = 1.0;
    if (x < 0.0) {
      sgn = -sgn;
      x = -x;
    }
    double l10 = Math.log(x) / Math.log(10.0);
    // Max.expon. of 10 (=308.2547)
    int e10 = (int)(digits-1-java.lang.Math.floor(l10));
    final double max10e = Constants.DBL_MAX_EXP * Constants.M_LOG10_2;
    if (Math.abs(l10) < max10e - 2) {
      double pow10 = Math.pow(10.0, (double)e10);
      return (sgn*Math.floor(x*pow10+0.5)/pow10);
    } else { /* -- LARGE or small -- */
      /*!* 	do_round = max10e - l10	 >= pow(10.0, -digits); *!*/
      boolean do_round = max10e - l10 >= Math.pow(10.0, -digits);
      int e2 = (e10>0)? 16 : -16;
      double p10 = Math.pow(10.0, (double)e2);
      x *= p10;
      double P10 = Math.pow(10.0, (double)e10-e2);
      x *= P10;
      /*-- p10 * P10 = 10 ^ e10 */
      if (do_round) x += 0.5;
      x = Math.floor(x) / p10;
      return (sgn*x/P10);
    }
  }
  
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double fround(double x, double digits);
     *
     *  DESCRIPTION
     *
     *    Rounds "x" to "digits" decimal digits.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    /*!* #ifndef HAVE_RINT /*4!*/
    /*!* #define USE_BUILTIN_RINT /*4!*/
    /*!* #endif /*4!*/
    
    /*!* #ifdef USE_BUILTIN_RINT /*4!*/
      // final  double  R_rint = static private_rint; 
    
    	/* The largest integer which can be represented */
    	/* exactly in floating point form. */
    
    static final  double  BIGGEST = 4503599627370496.0E0; 
	/* 2^52 for IEEE */
    
    static private double Rint(double x)
    {
    	final  double biggest = BIGGEST;
    	double tmp;
    
    	if (x != x) return x;			/* NaN */
    
/*!* 	if (fabs(x) >= biggest)			!!!COMMENT!!! *!*/
    	if (java.lang.Math.abs(x) >= biggest)			/* Already integer */
    		return x;
    
    	if(x >= 0) {
    		tmp = x + biggest;
    		return tmp - biggest;
    	}
    	else {
    		tmp = x - biggest;
    		return tmp + biggest;
    	}
    }
    
    /*!* #else /*4!*/
      //final  double  R_rint = rint; 
    /*!* #endif /*4!*/
    
    public static double  fround(double x, double digits)
    {
    	double pow10, sgn, intx;
    	final  double maxdigits = Constants.DBL_DIG - 1;
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(digits))
    		return x + digits;
    	if(Double.isInfinite(x)) return x;
    /*!* #endif /*4!*/
    
/*!* 	digits = floor(digits + 0.5); *!*/
    	digits = java.lang.Math.floor(digits + 0.5);
    	if (digits > maxdigits)
    		digits = maxdigits;
/*!* 	pow10 = pow(10.0, digits); *!*/
    	pow10 = java.lang.Math.pow(10.0, digits);
    	sgn = 1.0;
    	if(x < 0.0) {
    		sgn = -sgn;
    		x = -x;
    	}
    	if (digits > 0.0) {
/*!* 		intx = floor(x); *!*/
    		intx = java.lang.Math.floor(x);
    		x = x - intx;
    	} else {
    		intx = 0.0;
    	}
    	return sgn * (intx + java.lang.Math.rint(x * pow10) / pow10);
    }
    /*
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double fsign(double x, double y);
     *
     *  DESCRIPTION
     *
     *    This function performs transfer of sign.  The result is:
     *
     *                        |x| * signum(y)
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  fsign(double x, double y)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(y))
    	return x + y;
    /*!* #endif /*4!*/
/*!*     return ((y >= 0) ? fabs(x) : -fabs(x)); *!*/
        return ((y >= 0) ? java.lang.Math.abs(x) : -java.lang.Math.abs(x));
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double fsquare(double x);
     *
     *  DESCRIPTION
     *
     *    This function returns the square of its argument.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  fsquare(double x)
    {
        return x * x;
    }
    
  /**
   * Truncation toward zero.
   */
  public static double ftrunc(double x) {
    if (x >= 0) return java.lang.Math.floor(x);
    else return java.lang.Math.ceil(x);
  }
    
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double gammafn(double x);
     *
     *  DESCRIPTION
     *
     *    This function computes the value of the gamma function.
     *
     *  NOTES
     *
     *    This function is a translation into C of a Fortran subroutine
     *    by W. Fullerton of Los Alamos Scientific Laboratory.
     *
     *    The accuracy of this routine compares (very) favourably
     *    with those of the Sun Microsystems portable mathematical
     *    library.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
        static final  double gamcs[] = {
    	+.8571195590989331421920062399942e-2,
    	+.4415381324841006757191315771652e-2,
    	+.5685043681599363378632664588789e-1,
    	-.4219835396418560501012500186624e-2,
    	+.1326808181212460220584006796352e-2,
    	-.1893024529798880432523947023886e-3,
    	+.3606925327441245256578082217225e-4,
    	-.6056761904460864218485548290365e-5,
    	+.1055829546302283344731823509093e-5,
    	-.1811967365542384048291855891166e-6,
    	+.3117724964715322277790254593169e-7,
    	-.5354219639019687140874081024347e-8,
    	+.9193275519859588946887786825940e-9,
    	-.1577941280288339761767423273953e-9,
    	+.2707980622934954543266540433089e-10,
    	-.4646818653825730144081661058933e-11,
    	+.7973350192007419656460767175359e-12,
    	-.1368078209830916025799499172309e-12,
    	+.2347319486563800657233471771688e-13,
    	-.4027432614949066932766570534699e-14,
    	+.6910051747372100912138336975257e-15,
    	-.1185584500221992907052387126192e-15,
    	+.2034148542496373955201026051932e-16,
    	-.3490054341717405849274012949108e-17,
    	+.5987993856485305567135051066026e-18,
    	-.1027378057872228074490069778431e-18,
    	+.1762702816060529824942759660748e-19,
    	-.3024320653735306260958772112042e-20,
    	+.5188914660218397839717833550506e-21,
    	-.8902770842456576692449251601066e-22,
    	+.1527474068493342602274596891306e-22,
    	-.2620731256187362900257328332799e-23,
    	+.4496464047830538670331046570666e-24,
    	-.7714712731336877911703901525333e-25,
    	+.1323635453126044036486572714666e-25,
    	-.2270999412942928816702313813333e-26,
    	+.3896418998003991449320816639999e-27,
    	-.6685198115125953327792127999999e-28,
    	+.1146998663140024384347613866666e-28,
    	-.1967938586345134677295103999999e-29,
    	+.3376448816585338090334890666666e-30,
    	-.5793070335782135784625493333333e-31
        };
    
    public static double  gammafn(double x)
    {
        int ngam = 0;
        double xmin = 0.;
        double xmax = 0.;
        double xsml = 0.;
        double dxrel = 0.;
	double temp[];
    
        int i, n;
        double y;
        double sinpiy, value;
    
        if (ngam == 0) {
    	ngam = chebyshev_init(gamcs, 42, 0.1 * d1mach(3));
    	temp = gammalims(xmin, xmax);
	xmin=temp[0]; xmax=temp[1];
/*!* 	xsml = exp(fmax2(log(d1mach(1)), -log(d1mach(2)))+0.01); *!*/
    	xsml = java.lang.Math.exp(fmax2(java.lang.Math.log(d1mach(1)), -java.lang.Math.log(d1mach(2)))+0.01);
/*!* 	dxrel = sqrt(d1mach(4)); *!*/
    	dxrel = java.lang.Math.sqrt(d1mach(4));
        }
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isNaN(x)) return x;
    /*!* #endif /*4!*/
    
/*!*     y = fabs(x); *!*/
        y = java.lang.Math.abs(x);
    
        if (y <= 10) {
    
    	/* Compute gamma(x) for -10 <= x <= 10. */
    	/* Reduce the interval and find gamma(1 + y) for */
    	/* 0 <= y < 1 first of all. */
    
    	n = (int) x;
    	if(x < 0) --n;
    	y = x - n;/* n = floor(x)  ==>	y in [ 0, 1 ) */
    	--n;
    	value = chebyshev_eval(y * 2 - 1, gamcs, ngam) + .9375;
    	if (n == 0)
    	    return value;/* x = 1.dddd = 1+y */
    
    	if (n < 0) {
    	    /* compute gamma(x) for -10 <= x < 1 */
    
    	    /* If the argument is exactly zero or a negative integer */
    	    /* then return NaN. */
    	    if (x == 0 || (x < 0 && x == n + 2)) {
    		throw new java.lang.ArithmeticException("Math Error: RANGE");
		//    		return Double.NaN;
    	    }
    
    	    /* The answer is less than half precision */
    	    /* because x too near a negative integer. */
/*!* 	    if (x < -0.5 && fabs(x - (int)(x - 0.5) / x) < dxrel) { *!*/
    	    if (x < -0.5 && java.lang.Math.abs(x - (int)(x - 0.5) / x) < dxrel) {
    		throw new java.lang.ArithmeticException("Math Error: PRECISION");
    	    }
    
    	    /* The argument is so close to 0 that the result would overflow. */
    	    if (y < xsml) {
    		throw new java.lang.ArithmeticException("Math Error: RANGE");
		//    		if(x > 0) return Double.POSITIVE_INFINITY;
		//    		else return Double.NEGATIVE_INFINITY;
    	    }
    
    	    n = -n;
    
    	    for (i = 0; i < n; i++) {
    		value /= (x + i);
    	    }
    	    return value;
    	}
    	else {
    	    /* gamma(x) for 2 <= x <= 10 */
    
    	    for (i = 1; i <= n; i++) {
    		value *= (y + i);
    	    }
    	    return value;
    	}
        }
        else {
    	/* gamma(x) for	 y = |x| > 10. */
    
    	if (x > xmax) {			/* Overflow */
    	    throw new java.lang.ArithmeticException("Math Error: RANGE");
	    //    	    return Double.POSITIVE_INFINITY;
    	}
    
    	if (x < xmin) {			/* Underflow */
    	    throw new java.lang.ArithmeticException("Math Error: UNDERFLOW");
	    //    	    return (Double.MIN_VALUE * Double.MIN_VALUE);
    	}
    
/*!* 	value = exp((y - 0.5) * log(y) - y + Constants.M_LN_SQRT_2PI + lgammacor(y)); *!*/
    	value = java.lang.Math.exp((y - 0.5) * java.lang.Math.log(y) - y + Constants.M_LN_SQRT_2PI + lgammacor(y));
    
    	if (x > 0)
    	    return value;
    
/*!* 	if (fabs((x - (int)(x - 0.5))/x) < dxrel){ *!*/
    	if (java.lang.Math.abs((x - (int)(x - 0.5))/x) < dxrel){
    
    	    /* The answer is less than half precision because */
    	    /* the argument is too near a negative integer. */
    
    	    throw new java.lang.ArithmeticException("Math Error: PRECISION");
    	}
    
/*!* 	sinpiy = sin(Constants.M_PI * y); *!*/
    	sinpiy = java.lang.Math.sin(Constants.M_PI * y);
    	if (sinpiy == 0) {		/* Negative integer arg - overflow */
    	    throw new java.lang.ArithmeticException("Math Error: RANGE");
	    //    	    return Double.POSITIVE_INFINITY;
    	}
    
    	return -Constants.M_PI / (y * sinpiy * value);
        }
    }
    /* From http://www.netlib.org/specfun/gamma	Fortran translated by f2c,...
     *	------------------------------#####	Martin Maechler, ETH Zurich
     *
     *=========== was part of	ribesl (Bessel I(.))
     *===========			~~~~~~
     */
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  gamma_cody(double x)
    {
    /* ----------------------------------------------------------------------
    
       This routine calculates the GAMMA function for a float argument X.
       Computation is based on an algorithm outlined in reference [1].
       The program uses rational functions that approximate the GAMMA
       function to at least 20 significant decimal digits.	Coefficients
       for the approximation over the interval (1,2) are unpublished.
       Those for the approximation for X >= 12 are from reference [2].
       The accuracy achieved depends on the arithmetic system, the
       compiler, the intrinsic functions, and proper selection of the
       machine-dependent constants.
    
       *******************************************************************
    
       Error returns
    
       The program returns the value XINF for singularities or
       when overflow would occur.	 The computation is believed
       to be free of underflow and overflow.
    
       Intrinsic functions required are:
    
       INT, DBLE, EXP, LOG, REAL, SIN
    
    
       References:
       [1]  "An Overview of Software Development for Special Functions",
    	W. J. Cody, Lecture Notes in Mathematics, 506,
    	Numerical Analysis Dundee, 1975, G. A. Watson (ed.),
    	Springer Verlag, Berlin, 1976.
    
       [2]  Computer Approximations, Hart, Et. Al., Wiley and sons, New York, 1968.
    
       Latest modification: October 12, 1989
    
       Authors: W. J. Cody and L. Stoltz
       Applied Mathematics Division
       Argonne National Laboratory
       Argonne, IL 60439
       ----------------------------------------------------------------------*/
    
    /* ----------------------------------------------------------------------
       Mathematical constants
       ----------------------------------------------------------------------*/
        final  double sqrtpi = .9189385332046727417803297; /* == ??? */
    
    /* *******************************************************************
    
       Explanation of machine-dependent constants
    
       beta	- radix for the floating-point representation
       maxexp - the smallest positive power of beta that overflows
       XBIG	- the largest argument for which GAMMA(X) is representable
    	in the machine, i.e., the solution to the equation
    	GAMMA(XBIG) = beta**maxexp
       XINF	- the largest machine representable floating-point number;
    	approximately beta**maxexp
       EPS	- the smallest positive floating-point number such that  1.0+EPS > 1.0
       XMININ - the smallest positive floating-point number such that
    	1/XMININ is machine representable
    
       Approximate values for some important machines are:
    
       beta	      maxexp	     XBIG
    
       CRAY-1		(S.P.)	      2		8191	    966.961
       Cyber 180/855
       under NOS	(S.P.)	      2		1070	    177.803
       IEEE (IBM/XT,
       SUN, etc.)	(S.P.)	      2		 128	    35.040
       IEEE (IBM/XT,
       SUN, etc.)	(D.P.)	      2		1024	    171.624
       IBM 3033	(D.P.)	     16		  63	    57.574
       VAX D-Format	(D.P.)	      2		 127	    34.844
       VAX G-Format	(D.P.)	      2		1023	    171.489
    
       XINF	 EPS	    XMININ
    
       CRAY-1		(S.P.)	 5.45E+2465   7.11E-15	  1.84E-2466
       Cyber 180/855
       under NOS	(S.P.)	 1.26E+322    3.55E-15	  3.14E-294
       IEEE (IBM/XT,
       SUN, etc.)	(S.P.)	 3.40E+38     1.19E-7	  1.18E-38
       IEEE (IBM/XT,
       SUN, etc.)	(D.P.)	 1.79D+308    2.22D-16	  2.23D-308
       IBM 3033	(D.P.)	 7.23D+75     2.22D-16	  1.39D-76
       VAX D-Format	(D.P.)	 1.70D+38     1.39D-17	  5.88D-39
       VAX G-Format	(D.P.)	 8.98D+307    1.11D-16	  1.12D-308
    
       *******************************************************************
    
       ----------------------------------------------------------------------
       Machine dependent parameters
       ----------------------------------------------------------------------
       */
    
    
        final  double xbig = 171.624;
        /* ML_POSINF ==   static private double xinf = 1.79e308;*/
        /* Constants.DBL_EPSILON = static private double eps = 2.22e-16;*/
        /* Double.MIN_VALUE ==   static private double xminin = 2.23e-308;*/
    
        /*----------------------------------------------------------------------
          Numerator and denominator coefficients for rational minimax
          approximation over (1,2).
          ----------------------------------------------------------------------*/
	//        final  double p[8] = {
        final  double p[] = {
    	-1.71618513886549492533811,
    	24.7656508055759199108314,-379.804256470945635097577,
    	629.331155312818442661052,866.966202790413211295064,
    	-31451.2729688483675254357,-36144.4134186911729807069,
    	66456.1438202405440627855 };
	//        final  double q[8] = { 
        final  double q[] = {
   	-30.8402300119738975254353,
    	315.350626979604161529144,-1015.15636749021914166146,
    	-3107.77167157231109440444,22538.1184209801510330112,
    	4755.84627752788110767815,-134659.959864969306392456,
    	-115132.259675553483497211 };
        /*----------------------------------------------------------------------
          Coefficients for minimax approximation over (12, INF).
          ----------------------------------------------------------------------*/
	//        final  double c[7] = {
        final  double c[] = {
    	-.001910444077728,8.4171387781295e-4,
    	-5.952379913043012e-4,7.93650793500350248e-4,
    	-.002777777777777681622553,.08333333333333333331554247,
    	.0057083835261 };
    
        /* Local variables */
        long i, n;
        boolean parity;/*logical*/
        double fact, xden, xnum, y, z, y1, res, sum, ysq;
    
        parity = false;
        fact = 1.;
        n = 0;
        y = x;
    L_end: {
	  if (y <= 0.) {
	    /* -------------------------------------------------------------
	       Argument is negative
	       ------------------------------------------------------------- */
	    y = -x;
	    y1 = ftrunc(y);
	    res = y - y1;
	    if (res != 0.) {
	      if (y1 != ftrunc(y1 * .5) * 2.)
    		parity = true;
	      /*!* 	    fact = -Constants.M_PI / sin(Constants.M_PI * res); *!*/
	      fact = -Constants.M_PI / java.lang.Math.sin(Constants.M_PI * res);
	      y += 1.;
	    } else {
	      res = Double.POSITIVE_INFINITY;
	      break L_end;
	    }
	  }
	  /* -----------------------------------------------------------------
	     Argument is positive
	     -----------------------------------------------------------------*/
	  if (y < Constants.DBL_EPSILON) {
	    /* --------------------------------------------------------------
	       Argument < EPS
	       -------------------------------------------------------------- */
	    if (y >= Double.MIN_VALUE) {
	      res = 1. / y;
	    } else {
	      res = Double.POSITIVE_INFINITY;
	      break L_end;
	    }
	  } else if (y < 12.) {
	    y1 = y;
	    if (y < 1.) {
	      /* ---------------------------------------------------------
		 EPS < argument < 1
		 --------------------------------------------------------- */
	      z = y;
	      y += 1.;
	    } else {
	      /* -----------------------------------------------------------
		 1 <= argument < 12, reduce argument if necessary
		 ----------------------------------------------------------- */
	      n = (long) y - 1;
	      y -= (double) n;
	      z = y - 1.;
	    }
	    /* ---------------------------------------------------------
	       Evaluate approximation for 1.0 < argument < 2.0
	       ---------------------------------------------------------*/
	    xnum = 0.;
	    xden = 1.;
	    for (i = 0; i < 8; ++i) {
	      xnum = (xnum + p[(int) i]) * z;
	      xden = xden * z + q[(int) i];
	    }
	    res = xnum / xden + 1.;
	    if (y1 < y) {
	      /* --------------------------------------------------------
		 Adjust result for case  0.0 < argument < 1.0
		 -------------------------------------------------------- */
	      res /= y1;
	    } else if (y1 > y) {
	      /* ----------------------------------------------------------
		 Adjust result for case  2.0 < argument < 12.0
		 ---------------------------------------------------------- */
	      for (i = 0; i < n; ++i) {
    		res *= y;
    		y += 1.;
	      }
	    }
	  } else {
	    /* -------------------------------------------------------------
	       Evaluate for argument >= 12.0,
	       ------------------------------------------------------------- */
	    if (y <= xbig) {
	      ysq = y * y;
	      sum = c[6];
	      for (i = 0; i < 6; ++i) {
    		sum = sum / ysq + c[(int) i];
	      }
	      sum = sum / y - y + sqrtpi;
	      /*!* 	    sum += (y - .5) * log(y); *!*/
	      sum += (y - .5) * java.lang.Math.log(y);
	      /*!* 	    res = exp(sum); *!*/
	      res = java.lang.Math.exp(sum);
	    } else {
	      res = Double.POSITIVE_INFINITY;
	      break L_end;
	    }
	  }
	  /* ----------------------------------------------------------------------
	     Final adjustments and return
	     ----------------------------------------------------------------------*/
	  if (parity)
	    res = -res;
	  if (fact != 1.)
	    res = fact / res;
    
	} // L_end:
        return res;
    }
    
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    void gammalims(double *xmin, double *xmax);
     *
     *  DESCRIPTION
     *
     *    This function alculates the minimum and maximum legal bounds
     *    for x in gammafn(x).  These are not the only bounds, but they
     *    are the only non-trivial ones to calculate.
     *
     *  NOTES
     *
     *    This routine is a translation into C of a Fortran subroutine
     *    by W. Fullerton of Los Alamos Scientific Laboratory.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    /* FIXME: We need an ifdef'ed version of this which gives  */
    /* the exact values when we are using IEEE 754 arithmetic. */
    
    static double[] gammalims(double xmin, double xmax)
    {
        double alnbig, alnsml, xln, xold;
        int i;
    
/*!*     alnsml = log(d1mach(1)); *!*/
        alnsml = java.lang.Math.log(d1mach(1));
        xmin = -alnsml;
    find_xmax: {
        for (i=1; i<=10; ++i) {
	    xold = xmin;
/*!* 	xln = log(*xmin); *!*/
	    xln = java.lang.Math.log(xmin);
	    xmin -= xmin * ((xmin + .5) * xln - xmin - .2258 + alnsml) /
    		(xmin * xln + .5);
/*!* 	if (fabs(xmin - xold) < .005) { *!*/
	    if (java.lang.Math.abs(xmin - xold) < .005) {
		xmin = -(xmin) + .01;
		break find_xmax;
	    }
        }
    
        /* unable to find xmin */
    
        throw new java.lang.ArithmeticException("Math Error: NOCONV");
        // xmin = xmax = Double.NaN;
    
	} //    find_xmax:
    
/*!*     alnbig = log(d1mach(2)); *!*/
        alnbig = java.lang.Math.log(d1mach(2));
        xmax = alnbig;
    done: {
        for (i=1; i<=10; ++i) {
	    xold = xmax;
/*!* 	xln = log(*xmax); *!*/
	    xln = java.lang.Math.log(xmax);
	    xmax -= xmax * ((xmax - .5) * xln - xmax + .9189 - alnbig) /
    		(xmax * xln - .5);
/*!* 	if (fabs(xmax - xold) < .005) { *!*/
	    if (java.lang.Math.abs(xmax - xold) < .005) {
		xmax += -.01;
		break done;
	    }
        }
    
        /* unable to find xmax */
    
        throw new java.lang.ArithmeticException("Math Error: NOCONV");
        // xmin = xmax = Double.NaN;
    
	} //    done:
        xmin = fmax2(xmin, -(xmax) + 1);

	double retval[] = new double[2];
	retval[0] = xmin;
	retval[1] = xmax;
	return(retval);
    }
     
    /*!* #include "DistLib.h" /*4!*/
    
    public static int i1mach(int i)
    {
        switch(i) {
    
        case  1: return 5;
        case  2: return 6;
        case  3: return 0;
        case  4: return 0;
    
        case  5: /*return CHAR_BIT * sizeof(int);*/ throw new java.lang.RuntimeException("Unimplemented Feature.");
        case  6: /*return sizeof(int)/sizeof(char);*/ throw new java.lang.RuntimeException("Unimplemented Feature.");
    
        case  7: return 2;
        case  8: /*return CHAR_BIT * sizeof(int) - 1;*/ throw new java.lang.RuntimeException("Unimplemented Feature.");
        case  9: return java.lang.Integer.MAX_VALUE; /*INT_MAX;*/
    
        case 10: return Constants.FLT_RADIX;
    
        case 11: return Constants.FLT_MANT_DIG;
        case 12: return Constants.FLT_MIN_EXP;
        case 13: return Constants.FLT_MAX_EXP;
    
        case 14: return Constants.DBL_MANT_DIG;
        case 15: return Constants.DBL_MAX_EXP;
        case 16: return Constants.DBL_MIN_EXP;
    
        default: return 0;
        }
    }
    
    int i1mach_(int i)
    {
    	return i1mach(i);
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    int imax2(int x, int y);
     *
     *  DESCRIPTION
     *
     *    Compute maximum of two integers.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    int imax2(int x, int y)
    {
        return (x < y) ? y : x;
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    int Math.min(int x, int y);
     *
     *  DESCRIPTION
     *
     *    Compute minimum of two integers.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    int imin2(int x, int y)
    {
        return (x < y) ? x : y;
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double lbeta(double a, double b);
     *
     *  DESCRIPTION
     *
     *    This function returns the value of the log beta function.
     *
     *  NOTES
     *
     *    This routine is a translation into C of a Fortran subroutine
     *    by W. Fullerton of Los Alamos Scientific Laboratory.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  lbeta(double a, double b)
    {
        double corr, p, q;
    
        p = q = a;
        if(b < p) p = b;/* := min(a,b) */
        if(b > q) q = b;/* := max(a,b) */
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isNaN(a) || Double.isNaN(b))
    	return a + b;
    /*!* #endif /*4!*/
    
        /* both arguments must be >= 0 */
    
        if (p < 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        else if (p == 0) {
    	return Double.POSITIVE_INFINITY;
        }
    /*!* #ifdef IEEE_754 /*4!*/
        else if (Double.isInfinite(q)) {
    	return Double.NEGATIVE_INFINITY;
        }
    /*!* #endif /*4!*/
    
        if (p >= 10) {
    	/* p and q are big. */
    	corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q);
/*!* 	return log(q) * -0.5 + Constants.M_LN_SQRT_2PI + corr *!*/
    	return java.lang.Math.log(q) * -0.5 + Constants.M_LN_SQRT_2PI + corr
/*!* 		+ (p - 0.5) * log(p / (p + q)) + q * logrelerr(-p / (p + q)); *!*/
    		+ (p - 0.5) * java.lang.Math.log(p / (p + q)) + q * logrelerr(-p / (p + q));
        }
        else if (q >= 10) {
    	/* p is small, but q is big. */
    	corr = lgammacor(q) - lgammacor(p + q);
/*!* 	return lgammafn(p) + corr + p - p * log(p + q) *!*/
    	return lgammafn(p) + corr + p - p * java.lang.Math.log(p + q)
    		+ (q - 0.5) * logrelerr(-p / (p + q));
        }
        else
    	/* p and q are small: p <= q > 10. */
/*!* 	return log(gammafn(p) * (gammafn(q) / gammafn(p + q))); *!*/
    	return java.lang.Math.log(gammafn(p) * (gammafn(q) / gammafn(p + q)));
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    extern int signgam;
     *    double lgammafn(double x);
     *
     *  DESCRIPTION
     *
     *    This function computes log|gamma(x)|.  At the same time
     *    the variable "signgam" is set to the sign of the gamma
     *    function.
     *
     *  NOTES
     *
     *    This routine is a translation into C of a Fortran subroutine
     *    by W. Fullerton of Los Alamos Scientific Laboratory.
     *
     *    The accuracy of this routine compares (very) favourably
     *    with those of the Sun Microsystems portable mathematical
     *    library.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static int signgam;
    
    public static double  lgammafn(double x)
    {
        double xmax = 0.;
        double dxrel = 0.;
        double ans, y, sinpiy;
    
        if (xmax == 0) {
/*!* 	xmax = d1mach(2)/log(d1mach(2)); *!*/
    	xmax = d1mach(2)/java.lang.Math.log(d1mach(2));
    	dxrel = java.lang.Math.sqrt (d1mach(4));
        }
    
        signgam = 1;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isNaN(x)) return x;
    /*!* #endif /*4!*/
    
        if (x <= 0 && x == (int)x) { /* Negative integer argument */
    	throw new java.lang.ArithmeticException("Math Error: RANGE");
	//    	return Double.POSITIVE_INFINITY;/* +Inf, since lgamma(x) = log|gamma(x)| */
        }
    
/*!*     y = fabs(x); *!*/
        y = java.lang.Math.abs(x);
    
        if (y <= 10) {
/*!* 	return log(fabs(gammafn(x))); *!*/
    	return java.lang.Math.log(java.lang.Math.abs(gammafn(x)));
        }
        else { /* y = |x| > 10  */
    
    	if (y > xmax) {
    	    throw new java.lang.ArithmeticException("Math Error: RANGE");
	    //    	    return Double.POSITIVE_INFINITY;
    	}
    
    	if (x > 0)
/*!* 	  return Constants.M_LN_SQRT_2PI + (x - 0.5) * log(x) - x + lgammacor(y); *!*/
    	  return Constants.M_LN_SQRT_2PI + (x - 0.5) * java.lang.Math.log(x) - x + lgammacor(y);
    
    	/* else: x < -10 */
/*!* 	sinpiy = fabs(sin(Constants.M_PI * y)); *!*/
    	sinpiy = java.lang.Math.abs(java.lang.Math.sin(Constants.M_PI * y));
    
    	if (sinpiy == 0) { /* Negative integer argument ===
    			      Now UNNECESSARY: caught above */
    	    System.out.println(" ** should NEVER happen! *** [lgamma.c: Neg.int+ y=%g]\n"+y);
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    
/*!* 	ans = Constants.M_LN_SQRT_PId2 + (x - 0.5) * log(y) - x *!*/
    	ans = Constants.M_LN_SQRT_PId2 + (x - 0.5) * java.lang.Math.log(y) - x
/*!* 	      - log(sinpiy) - lgammacor(y); *!*/
    	      - java.lang.Math.log(sinpiy) - lgammacor(y);
    
/*!* 	if(fabs((x - (int)(x - 0.5)) * ans / x) < dxrel) { *!*/
    	if(java.lang.Math.abs((x - (int)(x - 0.5)) * ans / x) < dxrel) {
    
    	    /* The answer is less than half precision because */
    	    /* the argument is too near a negative integer. */
    
    	    throw new java.lang.ArithmeticException("Math Error: PRECISION");
    	}
    
    	if (x > 0)
    	  return ans;
    	else if (((int)(-x))%2 == 0)
    	  signgam = -1;
    	return ans;
        }
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double lgammacor(double x);
     *
     *  DESCRIPTION
     *
     *    Compute the log gamma correction factor for x >= 10 so that
     *
     *    log(gamma(x)) = log(sqrt(2*pi))+(x-.5)*log(x)-x+lgammacor(x)
     *
     *  NOTES
     *
     *    This routine is a translation into C of a Fortran subroutine
     *    written by W. Fullerton of Los Alamos Scientific Laboratory.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  lgammacor(double x)
    {
        final  double algmcs[] /*[15]*/ = { 
    	+.1666389480451863247205729650822e+0,
    	-.1384948176067563840732986059135e-4,
    	+.9810825646924729426157171547487e-8,
    	-.1809129475572494194263306266719e-10,
    	+.6221098041892605227126015543416e-13,
    	-.3399615005417721944303330599666e-15,
    	+.2683181998482698748957538846666e-17,
    	-.2868042435334643284144622399999e-19,
    	+.3962837061046434803679306666666e-21,
    	-.6831888753985766870111999999999e-23,
    	+.1429227355942498147573333333333e-24,
    	-.3547598158101070547199999999999e-26,
    	+.1025680058010470912000000000000e-27,
    	-.3401102254316748799999999999999e-29,
    	+.1276642195630062933333333333333e-30
        };
        int nalgm = 0;
        double xbig = 0;
        double xmax = 0;
        double tmp;
    
        if (nalgm == 0) {
    	nalgm = chebyshev_init(algmcs, 15, d1mach(3));
/*!* 	xbig = 1 / sqrt(d1mach(3)); *!*/
    	xbig = 1 / java.lang.Math.sqrt(d1mach(3));
/*!* 	xmax = exp(fmin2(log(d1mach(2) / 12), -log(12 * d1mach(1)))); *!*/
    	xmax = java.lang.Math.exp(fmin2(java.lang.Math.log(d1mach(2) / 12), -java.lang.Math.log(12 * d1mach(1))));
        }
    
        if (x < 10) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
        else if (x >= xmax) {
            throw new java.lang.ArithmeticException("Math Error: UNDERFLOW");
	    //            return (Double.MIN_VALUE * Double.MIN_VALUE);
        }
        else if (x < xbig) {
            tmp = 10 / x;
            return chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x;
        }
        else return 1 / (x * 12);
    }
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double dlnrel(double x);
     *
     *  DESCRIPTION
     *
     *    Compute the relative error logarithm.
     *
     *                      log(1 + x)
     *
     *  NOTES
     *
     *    This code is a translation of a Fortran subroutine of the
     *    same name written by W. Fullerton of Los Alamos Scientific
     *    Laboratory.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  logrelerr(double x)
    {
        /* series for alnr on the interval -3.75000e-01 to  3.75000e-01 */
        /*                               with weighted error   6.35e-32 */
        /*                                log weighted error  31.20     */
        /*                      significant figures required  30.93     */
        /*                           decimal places required  32.01     */
        final  double alnrcs[] /*[43]*/ = {
    	+.10378693562743769800686267719098e+1,
    	-.13364301504908918098766041553133e+0,
    	+.19408249135520563357926199374750e-1,
    	-.30107551127535777690376537776592e-2,
    	+.48694614797154850090456366509137e-3,
    	-.81054881893175356066809943008622e-4,
    	+.13778847799559524782938251496059e-4,
    	-.23802210894358970251369992914935e-5,
    	+.41640416213865183476391859901989e-6,
    	-.73595828378075994984266837031998e-7,
    	+.13117611876241674949152294345011e-7,
    	-.23546709317742425136696092330175e-8,
    	+.42522773276034997775638052962567e-9,
    	-.77190894134840796826108107493300e-10,
    	+.14075746481359069909215356472191e-10,
    	-.25769072058024680627537078627584e-11,
    	+.47342406666294421849154395005938e-12,
    	-.87249012674742641745301263292675e-13,
    	+.16124614902740551465739833119115e-13,
    	-.29875652015665773006710792416815e-14,
    	+.55480701209082887983041321697279e-15,
    	-.10324619158271569595141333961932e-15,
    	+.19250239203049851177878503244868e-16,
    	-.35955073465265150011189707844266e-17,
    	+.67264542537876857892194574226773e-18,
    	-.12602624168735219252082425637546e-18,
    	+.23644884408606210044916158955519e-19,
    	-.44419377050807936898878389179733e-20,
    	+.83546594464034259016241293994666e-21,
    	-.15731559416479562574899253521066e-21,
    	+.29653128740247422686154369706666e-22,
    	-.55949583481815947292156013226666e-23,
    	+.10566354268835681048187284138666e-23,
    	-.19972483680670204548314999466666e-24,
    	+.37782977818839361421049855999999e-25,
    	-.71531586889081740345038165333333e-26,
    	+.13552488463674213646502024533333e-26,
    	-.25694673048487567430079829333333e-27,
    	+.48747756066216949076459519999999e-28,
    	-.92542112530849715321132373333333e-29,
    	+.17578597841760239233269760000000e-29,
    	-.33410026677731010351377066666666e-30,
    	+.63533936180236187354180266666666e-31,
        };
        int nlnrel = 0;
        double xmin = 0.;
    
        if (nlnrel == 0) {
            nlnrel = chebyshev_init(alnrcs, 43, 0.1 * d1mach(3));
/*!*         xmin = -1.0 + sqrt(d1mach(4)); *!*/
            xmin = -1.0 + java.lang.Math.sqrt(d1mach(4));
        }
    
        if (x <= -1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    
        if (x < xmin) {
    	/* answer less than half precision because x too near -1 */
    	throw new java.lang.ArithmeticException("Math Error: PRECISION");
        }
    
/*!*     if (fabs(x) <= .375) *!*/
        if (java.lang.Math.abs(x) <= .375)
    	return x * (1 - x * chebyshev_eval(x / .375, alnrcs, nlnrel));
        else
/*!* 	return log(x + 1); *!*/
    	return java.lang.Math.log(x + 1);
    }
    
    /*!* #include "DistLib.h" /*4!*/
    
    /*!* #ifdef IEEE_754 /*4!*/
    /* These are used in IEEE exception handling */
    static double m_zero = 0;
    static double m_one = 1;
    static double m_tiny = Double.MIN_VALUE;
    /*!* #endif /*4!*/
    
    /*!* #ifndef IEEE_754 /*4!*/
    
      /*
    void ml_error(int n)
    {
        switch(n) {
    
        case "Math Error: NONE":
    	(!!!!fixme!!!!) = 0;
    	break;
    
        case "Math Error: DOMAIN":
        case "Math Error: NOCONV":
    	(!!!!fixme!!!!) = EDOM;
    	break;
    
        case "Math Error: RANGE":
    	(!!!!fixme!!!!) = ERANGE;
    	break;
    
        default:
    	break;
        }
    }
    
      */
    /*!* #endif /*4!*/
    /*
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double sign(double x);
     *
     *  DESCRIPTION
     *
     *    This function computes the  'signum(.)' function:
     *
     *    	sign(x) =  1  if x > 0
     *    	sign(x) =  0  if x == 0
     *    	sign(x) = -1  if x < 0
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  sign(double x)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x))
    	return x;
    /*!* #endif /*4!*/
        return ((x > 0) ? 1 : ((x == 0)? 0 : -1));
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/t.java0000644000175000017500000002237011376411123030262 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class t 
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n);
     *
     *  DESCRIPTION
     *
     *    The density of the "Student" t distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double n)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n))
    	return x + n;
    /*!* #endif /*4!*/
        if (n <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isInfinite(x))
    	return 0;
        if(Double.isInfinite(n))
    	return Normal.density(x, 0.0, 1.0);
    /*!* #endif /*4!*/
/*!*     return pow(1.0 + x * x / n, -0.5 * (n + 1.0)) *!*/
        return java.lang.Math.pow(1.0 + x * x / n, -0.5 * (n + 1.0))
/*!* 	/ (sqrt(n) * Beta(0.5, 0.5 * n)); *!*/
    	/ (java.lang.Math.sqrt(n) * Misc.beta(0.5, 0.5 * n));
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n)
    {
        double val;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n))
    	return x + n;
    /*!* #endif /*4!*/
        if (n <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
    /*!* #ifdef IEEE_754 /*4!*/
        if(Double.isInfinite(x))
    	return (x < 0) ? 0 : 1;
        if(Double.isInfinite(n))
    	return Normal.cumulative(x, 0.0, 1.0);
    /*!* #endif /*4!*/
        val = 0.5 * Beta.cumulative(n / (n + x * x), n / 2.0, 0.5);
        return (x > 0.0) ? 1 - val : val;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double p, double ndf);
     *
     *  DESCRIPTION
     *
     *    The "Student" t distribution quantile function.
     *
     *  NOTES
     *
     *    This is a C translation of the Fortran routine given in:
     *    Algorithm 396: Student's t-quantiles by G.W. Hill
     *    CACM 13(10), 619-620, October 1970
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    static private double eps = 1.e-12;
    
    public static double  quantile(double p, double ndf)
    {
    	double a, b, c, d, prob, P, q, x, y;
    	boolean neg;
    
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(p) || Double.isNaN(ndf))
    		return p + ndf;
    	if(ndf < 1 || p > 1 || p < 0) {
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    	if (p == 0) return Double.NEGATIVE_INFINITY;
    	if (p == 1) return Double.POSITIVE_INFINITY;
    /*!* #else /*4!*/
    	if (ndf < 1 || p > 1 || p < 0) {
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    /*!* #endif /*4!*/
    	if (ndf > 1e20) return Normal.quantile(p, 0.0, 1.0);
    
    	if(p > 0.5) {
    		neg = false; P = 2 * (1 - p);
    	} else {
    		neg = true; P = 2 * p;
    	}
    
/*!* 	if (fabs(ndf - 2) < eps) { *!*/
    	if (java.lang.Math.abs(ndf - 2) < eps) {
                    /* df ~= 2 */
/*!* 		q = sqrt(2 / (P * (2 - P)) - 2); *!*/
    		q = java.lang.Math.sqrt(2 / (P * (2 - P)) - 2);
    	}
    	else if (ndf < 1 + eps) {
                    /* df ~= 1 */
    		prob = P * Constants.M_PI_half;
/*!* 		q = cos(prob) / sin(prob); *!*/
    		q = java.lang.Math.cos(prob) / java.lang.Math.sin(prob);
    	}
    	else {
                    /*-- usual case;  including, e.g.,  df = 1.1 */
    		a = 1 / (ndf - 0.5);
    		b = 48 / (a * a);
    		c = ((20700 * a / b - 98) * a - 16) * a + 96.36;
/*!* 		d = ((94.5 / (b + c) - 3) / b + 1) * sqrt(a * Constants.M_PI_half) * ndf; *!*/
    		d = ((94.5 / (b + c) - 3) / b + 1) * java.lang.Math.sqrt(a * Constants.M_PI_half) * ndf;
/*!* 		y = pow(d * P, 2 / ndf); *!*/
    		y = java.lang.Math.pow(d * P, 2 / ndf);
    
    		if (y > 0.05 + a) {
    			/* Asymptotic inverse expansion about Normal */
    			x = Normal.quantile(0.5 * P, 0.0, 1.0);
    			y = x * x;
    			if (ndf < 5)
    				c = c + 0.3 * (ndf - 4.5) * (x + 0.6);
    			c = (((0.05 * d * x - 5) * x - 7) * x - 2) * x + b + c;
    			y = (((((0.4 * y + 6.3) * y + 36) * y + 94.5) / c - y - 3) / b + 1) * x;
    			y = a * y * y;
    			if (y > 0.002)
/*!* 				y = exp(y) - 1; *!*/
    				y = java.lang.Math.exp(y) - 1;
    			else {
                                    /* Taylor of  e^y -1 : */
    				y = 0.5 * y * y + y;
    			}
    		} else {
    			y = ((1 / (((ndf + 6) / (ndf * y) - 0.089 * d - 0.822)
    				   * (ndf + 2) * 3) + 0.5 / (ndf + 4))
    			     * y - 1) * (ndf + 1) / (ndf + 2) + 1 / y;
    		}
/*!* 		q = sqrt(ndf * y); *!*/
    		q = java.lang.Math.sqrt(ndf * y);
    	}
    	if(neg) q = -q;
    	return q;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "mathlib.h"
     *    double random(double df);
     *
     *  DESCRIPTION
     *
     *    Pseudo-random variates from an F distribution.
     *
     *  NOTES
     *
     *    This function calls rchisq and rnorm to do the real work.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double df, Uniform uniformDistribution)
    {
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isNaN(df) ||
    /*!* #endif /*4!*/
    	df <= 0.0) {
	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
        }
        if(Double.isInfinite(df))
	    return Normal.random(uniformDistribution);
        else
/*!* 	return Normal.random!!!COMMENT!!!() / sqrt(rchisq(df) / df); *!*/
	    return Normal.random(uniformDistribution) / java.lang.Math.sqrt(Chisquare.random(df, uniformDistribution) / df);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Exponential.java0000644000175000017500000000744411376411123032312 0ustar  giovannigiovanni/*  DistLib : A C Library of Special Functions
 *  Copyright (C) 1998 Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *  
 * data translated from C using perl script translate.pl
 * script version 0.00
 */
package org.mathpiper.builtin.library.statdistlib;

/**
 * Wrapper of functions for the Exponential distribution.
 */

public class Exponential {
  
  /**
   * Density of the Exponential distribution.
   */
  public static double density(double x, double scale) {
    if (Double.isNaN(x) || Double.isNaN(scale)) return x + scale;
    if (scale <= 0.0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (x < 0.0) return 0.0;
    return java.lang.Math.exp(-x / scale) / scale;
  }

  /**
   * Distribution function of the Exponential distribution
   *
   */
  public static double cumulative(double x, double scale) {
    if (Double.isNaN(x) || Double.isNaN(scale))
      return x + scale;
    if (scale <= 0.0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (x <= 0.0) return 0.0;
    return 1.0 - java.lang.Math.exp(-x / scale);
  }

  /**
   * quantile function of the Exponential distribution
   */
  public static double quantile(double x, double scale) {
    if (Double.isNaN(x) || Double.isNaN(scale))
      return x + scale;
    if (scale <= 0 || x < 0 || x > 1) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (x <= 0.0) return 0.0;
    return - scale * java.lang.Math.log(1.0 - x);
  }
  
  /**
   * Random variates from the Exponential distribution
   */
  public static double random(double scale, Uniform uniformDistribution) {
    if (Double.isInfinite(scale) || scale <= 0.0) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    return scale * random(uniformDistribution);
  }
  
  /**
   * Random variates from the standard normal distribution.
   *
   *    Ahrens, J.H. and Dieter, U. (1972).
   *    Computer methods for sampling from the Exponential and
   *    normal distributions.
   *    Comm. ACM, 15, 873-882.
   */

  static private double q[] = {
    0.6931471805599453,
    0.9333736875190459,
    0.9888777961838675,
    0.9984959252914960,
    0.9998292811061389,
    0.9999833164100727,
    0.9999985691438767,
    0.9999998906925558,
    0.9999999924734159,
    0.9999999995283275,
    0.9999999999728814,
    0.9999999999985598,
    0.9999999999999289,
    0.9999999999999968,
    0.9999999999999999,
    1.0000000000000000
  };


  public static double random(Uniform uniformDistribution) {
    /* q[k-1] = sum(alog(2.0)**k/k!) k=1,..,n, */
    /* The highest n (here 8) is determined by q[n-1] = 1.0 */
    /* within standard precision */
    double a, u, ustar, umin;
    int i;

    a = 0.0;
    u = uniformDistribution.random();
    for (;;) {
      u = u + u;
      if (u > 1.0)
        break;
      a = a + q[0];
    }
    u = u - 1.0;

    if (u <= q[0])
      return a + u;

    i = 0;
    ustar = uniformDistribution.random();
    umin = ustar;
    do {
      ustar = uniformDistribution.random();
      if (ustar < umin)
        umin = ustar;
      i = i + 1;
    } while (u > q[i]);
    return a + umin * q[0];
  }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/F.java0000644000175000017500000001615311376411123030206 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class F
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double n1, double n2);
     *
     *  DESCRIPTION
     *
     *    The density function of the F distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double n1, double n2)
    {
    	double a;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n1) || Double.isNaN(n2))
    	return x + n1 + n2;
    /*!* #endif /*4!*/
    	if (n1 <= 0 || n2 <= 0) {
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    	if (x <= 0.0)
    		return 0.0;
    	a = (n1 / n2) * x;
/*!* 	return pow(a, 0.5 * n1) * pow(1.0 + a, -0.5 * (n1 + n2)) *!*/
    	return java.lang.Math.pow(a, 0.5 * n1) * java.lang.Math.pow(1.0 + a, -0.5 * (n1 + n2))
/*!* 			/ (x * Beta(0.5 * n1, 0.5 * n2)); *!*/
    			/ (x * Misc.beta(0.5 * n1, 0.5 * n2));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double n1, double n2);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the F distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double n1, double n2)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n1) || Double.isNaN(n2))
    	return x + n2 + n1;
    /*!* #endif /*4!*/
        if (n1 <= 0.0 || n2 <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0.0)
    	return 0.0;
        x = 1.0 - Beta.cumulative(n2 / (n2 + n1 * x), n2 / 2.0, n1 / 2.0);
        return !Double.isNaN(x) ? x : Double.NaN;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double n1, double n2);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the F distribution.
    */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double n1, double n2)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(n1) || Double.isNaN(n2))
    	return x + n1 + n2;
    /*!* #endif /*4!*/
        if (n1 <= 0.0 || n2 <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0.0)
    	return 0.0;
        x = (1.0 / Beta.quantile(1.0 - x, n2 / 2.0, n1 / 2.0) - 1.0) * (n2 / n1);
        return !Double.isNaN(x) ? x : Double.NaN;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "mathlib.h"
     *    double random(double dfn, double dfd);
     *
     *  DESCRIPTION
     *
     *    Pseudo-random variates from an F distribution.
     *
     *  NOTES
     *
     *    This function calls rchisq to do the real work
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double n1, double n2, Uniform uniformDistribution)
    {
        double v1, v2;
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isNaN(n1) || Double.isNaN(n2) ||
    /*!* #endif /*4!*/
    	n1 <= 0.0 || n2 <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        v1 = !Double.isInfinite(n1) ? (Chisquare.random(n1,uniformDistribution) / n1) : Normal.random(uniformDistribution);
        v2 = !Double.isInfinite(n2) ? (Chisquare.random(n2,uniformDistribution) / n2) : Normal.random(uniformDistribution);
        return v1 / v2;
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/LogNormal.java0000644000175000017500000001613211376411123031710 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class LogNormal
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    double density(double x, double logmean, double logsd);
     *
     *  DESCRIPTION
     *
     *    The density of the LogNormal distribution.
     *
     * 	M_1_SQRT_2PI = 1 / sqrt(2 * pi)
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double logmean, double logsd)
    {
        double y;
    
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(logmean) || Double.isNaN(logsd))
    	return x + logmean + logsd;
    /*!* #endif /*4!*/
        if(logsd <= 0) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
        if(x == 0) return 0;
/*!*     y = (log(x) - logmean) / logsd; *!*/
        y = (java.lang.Math.log(x) - logmean) / logsd;
/*!*     return Constants.M_1_SQRT_2PI * exp(-0.5 * y * y) / (x * logsd); *!*/
        return Constants.M_1_SQRT_2PI * java.lang.Math.exp(-0.5 * y * y) / (x * logsd);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double logmean, double logsd);
     *
     *  DESCRIPTION
     *
     *    The LogNormal distribution function.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double logmean, double logsd)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(logmean) || Double.isNaN(logsd))
    	return x + logmean + logsd;
    /*!* #endif /*4!*/
        if (logsd <= 0) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
        if (x > 0)
/*!* 	return Normal.cumulative!!!COMMENT!!!(log(x), logmean, logsd); *!*/
    	return Normal.cumulative(java.lang.Math.log(x), logmean, logsd);
        return 0;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double logmean, double logsd);
     *
     *  DESCRIPTION
     *
     *    This the LogNormal quantile function.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double logmean, double logsd)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(logmean) || Double.isNaN(logsd))
    	return x + logmean + logsd;
    /*!* #endif /*4!*/
        if(x < 0 || x > 1 || logsd <= 0) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
        if (x == 1) return Double.POSITIVE_INFINITY;
/*!*     if (x > 0) return exp(qnorm(x, logmean, logsd)); *!*/
        if (x > 0) return java.lang.Math.exp(Normal.quantile(x, logmean, logsd));
        return 0;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double logmean, double logsd);
     *
     *  DESCRIPTION
     *
     *    Random variates from the LogNormal distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double logmean, double logsd, Uniform uniformDistribution)
    {
        if(
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(logmean) || Double.isInfinite(logsd) ||
    /*!* #endif /*4!*/
    	logsd <= 0.0) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
/*!*     return exp(rnorm(logmean, logsd)); *!*/
        return java.lang.Math.exp(Normal.random(logmean, logsd, uniformDistribution));
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Cauchy.java0000644000175000017500000001626111376411123031235 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Cauchy
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double location, double scale);
     *
     *  DESCRIPTION
     *
     *    The density of the Cauchy distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double location, double scale)
    {
        double y;
    /*!* #ifdef IEEE_754 /*4!*/
        /* NaNs propagated correctly */
        if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
    	return x + location + scale;
    /*!* #endif /*4!*/
        if (scale <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        y = (x - location) / scale;
        return 1.0 / (Constants.M_PI * scale * (1.0 + y * y));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double location, double scale);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the Cauchy distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double location, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
    	return x + location + scale;
    /*!* #endif /*4!*/
        if (scale <= 0) {
    	    throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //    	    return Double.NaN;
    	}
    	x = (x - location) / scale;
    /*!* #ifdef IEEE_754 /*4!*/
    	if(Double.isInfinite(x)) {
    	    if(x < 0) return 0;
    	    else return 1;
    	}
    /*!* #endif /*4!*/
/*!* 	return 0.5 + atan(x) / Constants.M_PI; *!*/
    	return 0.5 + java.lang.Math.atan(x) / Constants.M_PI;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double location, double scale);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Cauchy distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double location, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
            return x + location + scale;
        if(Double.isInfinite(x) || Double.isInfinite(location) || Double.isInfinite(scale)) {
            throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	    //            return Double.NaN;
        }
    /*!* #endif /*4!*/
    
        if (scale <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     return location + scale * tan(Constants.M_PI * (x - 0.5)); *!*/
        return location + scale * java.lang.Math.tan(Constants.M_PI * (x - 0.5));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double random(double location, double scale);
     *
     *  DESCRIPTION
     *
     *    Random variates from the normal distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double location, double scale, Uniform uniformDistribution)
    {
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(location) || Double.isInfinite(scale) ||
    /*!* #endif /*4!*/
    	scale < 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     return location + scale * tan(Constants.M_PI * sunif()); *!*/
        return location + scale * java.lang.Math.tan(Constants.M_PI * uniformDistribution.random());
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Tukey.java0000644000175000017500000004243011376411123031117 0ustar  giovannigiovanni/* DistLib : A C Library of Special Functions
 * Copyright (C) 1998 Ross Ihaka
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *  
 * data translated from C using perl script translate.pl
 * script version 0.00
 */
package org.mathpiper.builtin.library.statdistlib;

//import org.apache.commons.math.MathException;
//import org.apache.commons.math.special.Erf;

import org.mathpiper.builtin.library.cern.Probability;

/**
 * Distribution of the maximum of rr studentized
 * ranges, each based on cc means and with df degrees of freedom
 * for the standard error, is less than q.
 * 
    
 * The algorithm is based on:
 *    Copenhaver, Margaret Diponzio & Holland, Burt S.
 *    Multiple comparisons of simple effects in
 *    the two-way analysis of variance with fixed effects.
 *    Journal of Statistical Computation and Simulation,
 *    Vol.30, pp.1-15, 1988.
 */

public class Tukey {

  /*
   *  This function calculates probability integral of Hartley's
   *  form of the range.
   *
   *  w     = value of range
   *  rr    = no. of rows or groups
   *  cc    = no. of columns or treatments
   *  ir    = error flag = 1 if wprob probability > 1
   *  wprob = returned probability integral from (0, w)
   *
   *  program will not terminate if ir is raised.
   *
   *  bb = upper limit of legendre integration
   *  eps = maximum acceptable value of integral
   *  nleg = order of legendre quadrature
   *  ihalf = int ((nleg + 1) / 2)
   *  wlar = value of range above which wincr1 intervals are used to
   *         calculate second part of integral,
   *         else wincr2 intervals are used.
   *  eps1, eps2, eps3 = values which are used as cutoffs for terminating
   *  or modifying a calculation.
   *
   *  M_1_SQRT_2PI = 1 / sqrt(2 * pi);  from abramowitz & stegun, p. 3.
   *  M_SQRT_2 = sqrt(2)
   *  xleg = legendre 12-point nodes
   *  aleg = legendre 12-point coefficients
   */

  static final double  nleg = 12; 
  static final double  ihalf = 6; 

  static double wprob(double w, double rr, double cc) throws ArithmeticException { //MathException {
    final double eps  =   1.0;
    final double eps1 = -30.0;
    final double eps2 = -50.0;
    final double eps3 =  60.0;
    final double bb = 8.0;
    final double wlar = 3.0;
    final double wincr1 = 2.0;
    final double wincr2 = 3.0;
    final double xleg[] = {
        0.981560634246719250690549090149e0,
        0.904117256370474856678465866119e0,
        0.769902674194304687036893833213e0,
        0.587317954286617447296702418941e0,
        0.367831498998180193752691536644e0,
        0.125233408511468915472441369464e0
    };
    final double aleg[] = {
        0.047175336386511827194615961485,
        0.106939325995318430960254718194,
        0.160078328543346226334652529543,
        0.203167426723065921749064455810,
        0.233492536538354808760849898925,
        0.249147045813402785000562436043
    };
    double a, ac, ans, b, binc, blb, bub, c, cc1, einsum, elsum,
    pminus, pplus, qexpo, qsqz, rinsum, wi, wincr, xx;
    int j, jj;

    qsqz = w * 0.5;

    /* if w >= 16 then the integral lower bound (occurs for c=20) */
    /* is 0.99999999999995 so return a value of 1. */

    ans = 1.0;
    if (qsqz >= bb) return 1.0;

    /* find (f(w/2) - 1) ** cc */
    /* (first term in integral of hartley's form). */

    /* if ans ** cc < 2e-22 then set ans = 0 */

    ans = Probability.errorFunction(qsqz / Constants.M_SQRT_2);
    if (ans >= Math.exp(eps2 / cc)) ans = Math.pow(ans, cc);
    else ans = 0.0;

    /* if w is large then the second component of the */
    /* integral is small, so fewer intervals are needed. */

    if (w > wlar) wincr = wincr1;
    else wincr = wincr2;

    /* find the integral of second term of hartley's form */
    /* for the integral of the range for equal-length */
    /* intervals using legendre quadrature.  limits of */
    /* integration are from (w/2, 8).  two or three */
    /* equal-length intervals are used. */

    /* blb and bub are lower and upper limits of integration. */

    blb = qsqz;
    binc = (bb - qsqz) / wincr;
    bub = blb + binc;
    einsum = 0.0;

    /* integrate over each interval */

    cc1 = cc - 1.0;
    for (wi = 1; wi <= wincr; wi++) {
      elsum = 0.0;
      a = 0.5 * (bub + blb);

      /* legendre quadrature with order = nleg */

      b = 0.5 * (bub - blb);

      for (jj = 1; jj <= nleg; jj++) {
        if (ihalf < jj) {
          j = (int) (nleg - jj) + 1;
          xx = xleg[j-1];
        } else {
          j = jj;
          xx = -xleg[j-1];
        }
        c = b * xx;
        ac = a + c;

        /* if exp(-qexpo/2) < 9e-14, */
        /* then doesn't contribute to integral */

        qexpo = ac * ac;

        if (qexpo > eps3) break;
        if (ac > 0.0)
          pplus = 1.0 + Probability.errorFunction(ac / Constants.M_SQRT_2);
        else
          pplus = 1.0 - Probability.errorFunction(-(ac / Constants.M_SQRT_2));

        if (ac > w)
          pminus = 1.0 + Probability.errorFunction((ac / Constants.M_SQRT_2) - (w / Constants.M_SQRT_2));
        else
          pminus = 1.0 - Probability.errorFunction((w / Constants.M_SQRT_2) - (ac / Constants.M_SQRT_2));

        /* if rinsum ** (cc-1) < 9e-14, */
        /* then doesn't contribute to integral */

        rinsum = (pplus * 0.5) - (pminus * 0.5);
        if (rinsum >= java.lang.Math.exp(eps1 / cc1)) {
          rinsum = (aleg[j-1] * Math.exp(-(0.5 * qexpo)))
                    * Math.pow(rinsum, cc1);
          elsum = elsum + rinsum;
        }
      }
      elsum = (((2.0 * b) * cc) * Constants.M_1_SQRT_2PI) * elsum;
      einsum = einsum + elsum;
      blb = bub;
      bub = bub + binc;
    }

    // if ans ** rr < 9e-14, then return 0.0
    ans = einsum + ans;
    if (ans <= Math.exp(eps1 / rr)) return 0.0;
    
    ans = Math.pow(ans, rr);
    if (ans >= eps) ans = 1.0;
    return ans;
  }

  /**
   *  function qprob
   *
   *  q = value of studentized range
   *  rr = no. of rows or groups
   *  cc = no. of columns or treatments
   *  df = degrees of freedom of error term
   *  ir[0] = error flag = 1 if wprob probability > 1
   *  ir[1] = error flag = 1 if qprob probability > 1
   *
   *  qprob = returned probability integral over [0, q]
   *
   *  The program will not terminate if ir[0] or ir[1] are raised.
   *
   *  All references in wprob to Abramowitz and Stegun
   *  are from the following reference:
   *
   *  Abramowitz, Milton and Stegun, Irene A.
   *  Handbook of Mathematical Functions.
   *  New York:  Dover publications, Inc. (1970).
   *
   *  All constants taken from this text are
   *  given to 25 significant digits.
   *
   *  nlegq = order of legendre quadrature
   *  ihalfq = int ((nlegq + 1) / 2)
   *  eps = max. allowable value of integral
   *  eps1 & eps2 = values below which there is
   *                no contribution to integral.
   *
   *  d.f. <= dhaf:   integral is divided into ulen1 length intervals.  else
   *  d.f. <= dquar:  integral is divided into ulen2 length intervals.  else
   *  d.f. <= deigh:  integral is divided into ulen3 length intervals.  else
   *  d.f. <= dlarg:  integral is divided into ulen4 length intervals.
   *
   *  d.f. > dlarg:   the range is used to calculate integral.
   *
   *  M_LN_2 = log(2)
   *
   *  xlegq = legendre 16-point nodes
   *
   *  alegq = legendre 16-point coefficients
   *
   *  The coefficients and nodes for the legendre quadrature used in
   *  qprob and wprob were calculated using the algorithms found in:
   *
   *  Stroud, A. H. and Secrest, D.
   *  Gaussian Quadrature Formulas.
   *  Englewood Cliffs,
   *  New Jersey:  Prentice-Hall, Inc, 1966.
   *
   *  All values matched the tables (provided in same reference)
   *  to 30 significant digits.
   *
   *  f(x) = .5 + erf(x / sqrt(2)) / 2      for x > 0
   *
   *  f(x) = erfc( -x / sqrt(2)) / 2        for x < 0
   *
   *  where f(x) is standard normal c. d. f.
   *
   *  if degrees of freedom large, approximate integral
   *  with range distribution.
   */

  static final double  nlegq = 16; 
  static final double  ihalfq = 8; 

  public static double cumulative(double q, double rr, double cc, double df) {
    final double eps = 1.0e0;
    final double eps1 = -30.0e0;
    final double eps2 = 1.0e-14;
    final double dhaf = 100.0e0;
    final double dquar = 800.0e0;
    final double deigh = 5000.0e0;
    final double dlarg = 25000.0e0;
    final double ulen1 = 1.0e0;
    final double ulen2 = 0.5e0;
    final double ulen3 = 0.25e0;
    final double ulen4 = 0.125e0;
    final double xlegq[] = {
        0.989400934991649932596154173450e+00,
        0.944575023073232576077988415535e+00,
        0.865631202387831743880467897712e+00,
        0.755404408355003033895101194847e+00,
        0.617876244402643748446671764049e+00,
        0.458016777657227386342419442984e+00,
        0.281603550779258913230460501460e+00,
        0.950125098376374401853193354250e-01
    };
    final double alegq[] = {
        0.271524594117540948517805724560e-01,
        0.622535239386478928628438369944e-01,
        0.951585116824927848099251076022e-01,
        0.124628971255533872052476282192e+00,
        0.149595988816576732081501730547e+00,
        0.169156519395002538189312079030e+00,
        0.182603415044923588866763667969e+00,
        0.189450610455068496285396723208e+00
    };
    double ans, f2, f21, f2lf, ff4, otsum, qsqz, rotsum,
    t1, twa1, ulen, wprb;
    int i, j, jj;

    if (Double.isNaN(q) || Double.isNaN(rr) || Double.isNaN(cc) || Double.isNaN(df)) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (q <= 0) return 0;

    /* df must be > 1 */
    /* there must be at least two values */

    if (df < 2 || rr < 1 || cc < 2) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }

    if (Double.isInfinite(q)) return 1;

    if (df > dlarg) {
      try {
        ans = wprob(q, rr, cc);
      } catch (ArithmeticException me) {  //Catch MathException.
        throw new ArithmeticException("Doesn't converge.");
      }
      return ans;
    }

    /* calculate leading constant */
    /* lgamma is the log gamma function. */

    f2 = df * 0.5;
    f2lf = ((f2 * Math.log(df)) - (df * Constants.M_LN_2)) - Misc.lgammafn(f2);
    f21 = f2 - 1.0;

    /* integral is divided into unit, half-unit, quarter-unit, or */
    /* eighth-unit length intervals depending on the value of the */
    /* degrees of freedom. */

    ff4 = df * 0.25;
    if (df <= dhaf) {
      ulen = ulen1;
    } else if (df <= dquar) {
      ulen = ulen2;
    } else if (df <= deigh) {
      ulen = ulen3;
    } else {
      ulen = ulen4;
    }

    f2lf = f2lf + Math.log(ulen);

    // integrate over each subinterval
    ans = 0.0;

    L400: {
      for (i = 1; i <= 50; i++) {
        otsum = 0.0;

        /* legendre quadrature with order = nlegq */
        /* nodes (stored in xlegq) are symmetric around zero. */

        twa1 = ((2.0 * i) - 1.0) * ulen;

        for (jj = 1; jj <= nlegq; jj++) {
          if (ihalfq < jj) {
            j = (int) (jj - ihalfq - 1);
            t1 = (f2lf + (f21 * java.lang.Math.log(twa1 + (xlegq[j] * ulen))))
                 - (((xlegq[j] * ulen) + twa1) * ff4);
          } else {
            j = jj - 1;
            t1 = (f2lf + (f21 * java.lang.Math.log(twa1 - (xlegq[j] * ulen))))
                 + (((xlegq[j] * ulen) - twa1) * ff4);

          }

          /* if exp(t1) < 9e-14, then doesn't */
          /* contribute to integral */

          if (t1 >= eps1) {
            if (ihalfq < jj) {
              qsqz = q * java.lang.Math.sqrt(((xlegq[j] * ulen) + twa1) * 0.5);
            } else {
              qsqz = q * java.lang.Math.sqrt(((-(xlegq[j] * ulen)) + twa1) * 0.5);
            }

            /* call wprob to find integral */
            /* of range portion */

            try {
              wprb = wprob(qsqz, rr, cc);
            } catch (ArithmeticException e) { //Catch ArithmeticException.
              throw new ArithmeticException("Doesn't converge");
            }
            rotsum = (wprb * alegq[j]) * Math.exp(t1);
            otsum = rotsum + otsum;
          }
          /* end legendre integral for interval i */
          /* L200: */
        }

        /* if integral for interval i < 1e-14, */
        /* then stop. however, in order to avoid */
        /* small area under left tail, at least */
        /* 1 / ulen intervals are calculated. */

        if (i * ulen >= 1.0 && otsum <= eps2)
          break L400;

        /* end of interval i */
        /* L330: */

        ans = ans + otsum;
      }
    } //L400:

    if (ans > eps) ans = 1.0;
    return ans;
  }
  
  /**
   *  this function finds percentage point of the studentized range
   *  which is used as initial estimate for the secant method.
   *  function is adapted from portion of algorithm as 70
   *  from applied statistics (1974) ,vol. 23, no. 1
   *  by odeh, r. e. and evans, j. o.
   *
   *  @param p percentage point
   *  @param c no. of columns or treatments
   *  @param v degrees of freedom
   *  @return initial estimate
   */

  static double qinv(double p, double c, double v) {
    final double p0 = 0.322232421088;
    final double q0 = 0.993484626060e-01;
    final double p1 = -1.0;
    final double q1 = 0.588581570495;
    final double p2 = -0.342242088547;
    final double q2 = 0.531103462366;
    final double p3 = -0.204231210125;
    final double q3 = 0.103537752850;
    final double p4 = -0.453642210148e-04;
    final double q4 = 0.38560700634e-02;
    final double c1 = 0.8832;
    final double c2 = 0.2368;
    final double c3 = 1.214;
    final double c4 = 1.208;
    final double c5 = 1.4142;
    final double vmax = 120.0; // cutoff above which degrees of freedom are treated as infinite
    double ps, q, t, yi;

    ps = 0.5 - 0.5 * p;
    yi = Math.sqrt (Math.log (1.0 / (ps * ps)));
    t = yi + (((( yi * p4 + p3) * yi + p2) * yi + p1) * yi + p0)
    / (((( yi * q4 + q3) * yi + q2) * yi + q1) * yi + q0);
    if (v < vmax) t += (t * t * t + t) / v / 4.0;
    q = c1 - c2 * t;
    if (v < vmax) q += -c3 / v + c4 * t / v;
    return t * (q * Math.log (c - 1.0) + c5);
  }

  /**
   * Computes the quantiles of the maximum of rr studentized
   * ranges, each based on cc means and with df degrees of freedom
   * for the standard error, is less than q.
   *
   * The algorithm is based on:
   * Copenhaver, Margaret Diponzio & Holland, Burt S.
   * Multiple comparisons of simple effects in
   * the two-way analysis of variance with fixed effects.
   * Journal of Statistical Computation and Simulation,
   * Vol.30, pp.1-15, 1988.
   *
   *  Uses the secant method to find critical values.
   *  If the difference between successive iterates is less than eps,
   *  the search is terminated and an exception thrown.
   *
   *  @param p confidence level (1 - alpha)
   *  @param rr no. of rows or groups
   *  @param cc no. of columns or treatments
   *  @param df degrees of freedom of error term
   *
   *  @return critical value
   */
  public static double quantile(double p, double rr, double cc, double df) {
    final double eps = 0.0001;
    final int maxiter = 50;
    double ans, valx0, valx1, x0, x1, xabs;
    int iter;

    if (Double.isNaN(p) || Double.isNaN(rr) || Double.isNaN(cc) || Double.isNaN(df)) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (p < 0 || p > 1) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }
    if (p < 0 || p >= 1) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }

    /* df must be > 1 */
    /* there must be at least two values */

    if (df < 2 || rr < 1 || cc < 2) {
      throw new java.lang.ArithmeticException("Math Error: DOMAIN");
    }

    if (p <= 0) return 0;

    /* Initial value */

    x0 = qinv(p, cc, df);

    /* Find prob(value < x0) */

    valx0 = cumulative(x0, rr, cc, df) - p;

    /* Find the second iterate and prob(value < x1). */
    /* If the first iterate has probability value */
    /* exceeding p then second iterate is 1 less than */
    /* first iterate; otherwise it is 1 greater. */

    if (valx0 > 0.0) x1 = Math.max(0.0, x0 - 1.0);
    else x1 = x0 + 1.0;
    valx1 = cumulative(x1, rr, cc, df) - p;

    /* Find new iterate */

    for (iter=1 ; iter < maxiter ; iter++) {
      ans = x1 - ((valx1 * (x1 - x0)) / (valx1 - valx0));
      valx0 = valx1;

      /* New iterate must be >= 0 */

      x0 = x1;
      if (ans < 0.0) {
        ans = 0.0;
        valx1 = -p;
      }
      /* Find prob(value < new iterate) */

      valx1 = cumulative(ans, rr, cc, df) - p;
      x1 = ans;

      /* If the difference between two successive */
      /* iterates is less than eps, stop */

      /*!* 	xabs = fabs(x1 - x0); *!*/
      xabs = java.lang.Math.abs(x1 - x0);
      if (xabs < eps)
        return ans;
    }

    /* The process did not converge in 'maxiter' iterations */
    throw new java.lang.ArithmeticException("No convergence.");
  }
  
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Weibull.java0000644000175000017500000001640611376411123031425 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Weibull
  { 
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    The density function of the Weibull distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  density(double x, double shape, double scale)
    {
        double tmp1, tmp2;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(shape) || Double.isNaN(scale))
    	return x + shape + scale;
    /*!* #endif /*4!*/
        if (shape <= 0 || scale <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isInfinite(x)) return 0;
    /*!* #endif /*4!*/
/*!*     tmp1 = pow(x / scale, shape - 1); *!*/
        tmp1 = java.lang.Math.pow(x / scale, shape - 1);
        tmp2 = tmp1 * (x / scale);
/*!*     return shape * tmp1 * exp(-tmp2) / scale; *!*/
        return shape * tmp1 * java.lang.Math.exp(-tmp2) / scale;
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double cumulative(double x, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    The distribution function of the Weibull distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  cumulative(double x, double shape, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(shape) || Double.isNaN(scale))
    	return x + shape + scale;
    /*!* #endif /*4!*/
        if(shape <= 0 || scale <= 0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x <= 0) return 0;
/*!*     return 1.0 - exp(-pow(x / scale, shape)); *!*/
        return 1.0 - java.lang.Math.exp(-java.lang.Math.pow(x / scale, shape));
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double quantile(double x, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    The quantile function of the Weibull distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  quantile(double x, double shape, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(shape) || Double.isNaN(scale))
    	return x + shape + scale;
    /*!* #endif /*4!*/
        if (shape <= 0 || scale <= 0 || x < 0 || x > 1) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
        if (x == 0) return 0;
    /*!* #ifdef IEEE_754 /*4!*/
        if (x == 1) return Double.POSITIVE_INFINITY;
    /*!* #endif /*4!*/
/*!*     return scale * pow(-log(1.0 - x), 1.0 / shape); *!*/
        return scale * java.lang.Math.pow(-java.lang.Math.log(1.0 - x), 1.0 / shape);
    }
    /*
     *  DistLib : A C Library of Special Functions
     *  Copyright (C) 1998 Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     *
     *  SYNOPSIS
     *
     *    #include "DistLib.h"
     *    double density(double x, double shape, double scale);
     *
     *  DESCRIPTION
     *
     *    Random variates from the Weibull distribution.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double  random(double shape, double scale, Uniform uniformDistribution)
    {
        if (
    /*!* #ifdef IEEE_754 /*4!*/
    	Double.isInfinite(shape) || Double.isInfinite(scale) ||
    /*!* #endif /*4!*/
    	shape <= 0.0 || scale <= 0.0) {
    	throw new java.lang.ArithmeticException("Math Error: DOMAIN");
	//    	return Double.NaN;
        }
/*!*     return scale * pow(-log(sunif()), 1.0 / shape); *!*/
        return scale * java.lang.Math.pow(-java.lang.Math.log(uniformDistribution.random()), 1.0 / shape);
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/statdistlib/Logistic.java0000644000175000017500000001434011376411123031572 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.statdistlib;

/* data translated from C using perl script translate.pl */
/* script version 0.00                               */


import java.lang.*;
import java.lang.Math;
import java.lang.Double;

public class Logistic
  { 
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double density(double x, double location, double scale)
    {
    	double e, f;
    /*!* #ifdef IEEE_754 /*4!*/
        if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
    	return x + location + scale;
    /*!* #endif /*4!*/
    	if (scale <= 0.0) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
/*!* 	e = exp(-(x - location) / scale); *!*/
    	e = java.lang.Math.exp(-(x - location) / scale);
    	f = 1.0 + e;
    	return e / (scale * f * f);
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double cumulative(double x, double location, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
    		return x + location + scale;
    /*!* #endif /*4!*/
    	if (scale <= 0.0) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    	if(Double.isInfinite(x)) {
    		if (x > 0) return 1;
    		else return 0;
    	}
/*!* 	return 1.0 / (1.0 + exp(-(x - location) / scale)); *!*/
    	return 1.0 / (1.0 + java.lang.Math.exp(-(x - location) / scale));
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double quantile(double x, double location, double scale)
    {
    /*!* #ifdef IEEE_754 /*4!*/
    	if (Double.isNaN(x) || Double.isNaN(location) || Double.isNaN(scale))
    		return x + location + scale;
    /*!* #endif /*4!*/
    	if (scale <= 0.0 || x < 0 || x > 1) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    	if(x <= 0) return Double.NEGATIVE_INFINITY;
    	if(x == 1) return Double.POSITIVE_INFINITY;
/*!* 	return location + scale * log(x / (1.0 - x)); *!*/
    	return location + scale * java.lang.Math.log(x / (1.0 - x));
    }
    /*
     *  R : A Computer Langage for Statistical Data Analysis
     *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
     *
     *  This program is free software; you can redistribute it and/or modify
     *  it under the terms of the GNU General Public License as published by
     *  the Free Software Foundation; either version 2 of the License, or
     *  (at your option) any later version.
     *
     *  This program is distributed in the hope that it will be useful,
     *  but WITHOUT ANY WARRANTY; without even the implied warranty of
     *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     *  GNU General Public License for more details.
     *
     *  You should have received a copy of the GNU General Public License
     *  along with this program; if not, write to the Free Software
     *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
     */
    
    /*!* #include "DistLib.h" /*4!*/
    
    public static double random(double location, double scale, Uniform uniformDistribution)
    {
    	double u;
    /* #ifndef IEEE_754 */
    	if (Double.isInfinite(location) || Double.isInfinite(scale)) {
    		throw new java.lang.ArithmeticException("Math Error: DOMAIN");
		//    		return Double.NaN;
    	}
    /* #endif */
    	u = uniformDistribution.random();
/*!* 	return location + scale * log(u / (1.0 - u)); *!*/
    	return location + scale * java.lang.Math.log(u / (1.0 - u));
    }
  }
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/0000755000175000017500000000000011722677320025407 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/JasAccess.java0000644000175000017500000001101111370216032030067 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jas;

//------------------------------------------------------------------------
//          Factoring polynomials over Ring of Integer
//          Version for interfacing with MathPiper
//------------------------------------------------------------------------
import java.util.Map;
import java.util.SortedMap;
import java.util.TreeMap;
import java.util.List;
import java.util.Set;
import java.util.Iterator;

import edu.jas.ufd.Factorization;
import edu.jas.ufd.FactorFactory;
import edu.jas.arith.BigInteger;
import edu.jas.arith.BigRational;
//import edu.jas.arith.BigComplex;
import edu.jas.kern.ComputerThreads;
import edu.jas.poly.GenPolynomial;
import edu.jas.poly.GenPolynomialRing;
import edu.jas.poly.TermOrder;
import edu.jas.util.StringUtil;

//-----------------------------------------------
public class JasAccess {

    private boolean debug = false;

    private BigInteger bi;

    private Factorization fEngineBI;

    public JasAccess() {
        // define the "nominal" BigInteger as type prototype
        bi = new BigInteger(1);

        // create a factorization engine suitable for BigInteger coefficient type
        fEngineBI = FactorFactory.getImplementation(bi);
        
    }//end constructor.

    

    public Set factorPolyInt(String poly, String vars) {
        if (debug) {
            System.out.println(" poly = " + poly);
            System.out.println(" vars = " + vars);
        }

        //  convert string of variable names to array of strings as required
        String[] jvars = StringUtil.variableList(vars);
        int nvars = jvars.length;
        if (debug) {
            System.out.print("\n number of variables: ");
            System.out.println(nvars);
            for (int i = 0; i < nvars; i++) {
                System.out.print(" " + jvars[i]);
            }
            System.out.println();
        }

        // make sure term-order is INVLEX, as required
        TermOrder to = new TermOrder(TermOrder.INVLEX);
        if (debug) {
            System.out.println(" term-order = " + to);
        }


        Factorization fEngine = fEngineBI;
        if (debug) {
            System.out.println("\nFactorization:  fEngineBI = " + fEngineBI);
        }

        // create appropriate Ring for BigIntegers with specified variable names
        GenPolynomialRing biRing = new GenPolynomialRing(bi, nvars, to, jvars);
        if (debug) {
            System.out.println("polynomial ring = " + biRing);
            int nvars2 = biRing.nvar;
            System.out.println("    number of variables for ring = " + nvars2);
            String varNames = biRing.varsToString();
            System.out.println("    names  of variables for ring = " + varNames);
        }

        // ---  Create polynomial in chosen Ring, from given string  --
        if (debug) {
            System.out.println("\nstrPoly = " + poly);
        }
        GenPolynomial polyp = biRing.parse(poly);
        //System.out.println("\npoly = " + polyp);
        if (debug) {
            int lenPoly = polyp.length();
            System.out.println("    length of poly = " + lenPoly);
            int numVars = polyp.numberOfVariables();
            System.out.println("    number of variables in poly = " + numVars);
            long degree = polyp.degree();
            System.out.println("    maximal degree of poly = " + degree);
        }

        // ---  JasAccess the polynomial  ---
        SortedMap, Long> Sm = fEngineBI.factors(polyp);

        //     print info about factorization
        /*int numFactors = Sm.size();
        System.out.println("    number of factors: " + numFactors);
         */

        // ---  Print out all factors and their multiplicities  ---
        /*for (Map.Entry, Long> f : Sm.entrySet()) {
            GenPolynomial factor = f.getKey();
            Long multiplicity = f.getValue();
            System.out.println("   ( " + factor + "  ,  " + multiplicity + " )");
        }*/


        return (Set) Sm.entrySet();


    }//end method.



    public void terminate()
    {
        ComputerThreads.terminate();
    }

    public boolean isDebug() {
        return debug;
    }

    public void setDebug(boolean debug) {
        this.debug = debug;
    }



    public static void main(String[] args) {
        JasAccess jas = new JasAccess();

        jas.setDebug(true);

        Set resultSet = jas.factorPolyInt("x**2-9", "x");

        jas.terminate();

    }//end main.
    

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/JasAccess2.java0000644000175000017500000001143411374142670030174 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jas;

//------------------------------------------------------------------------
//          Factoring polynomials over Ring of Integer
//          Version for interfacing with MathPiper
//             (sherm experiments in here)
//------------------------------------------------------------------------
import java.util.Map;
import java.util.SortedMap;
import java.util.TreeMap;
import java.util.List;
import java.util.Set;
import java.util.Iterator;

import edu.jas.ufd.Factorization;
import edu.jas.ufd.FactorFactory;
import edu.jas.arith.BigInteger;
import edu.jas.arith.BigRational;
//import edu.jas.arith.BigComplex;
import edu.jas.kern.ComputerThreads;
import edu.jas.poly.GenPolynomial;
import edu.jas.poly.GenPolynomialRing;
import edu.jas.poly.TermOrder;
import edu.jas.util.StringUtil;

//-----------------------------------------------
public class JasAccess2 {

    private boolean debug = false;

    private BigInteger bi;

    private Factorization fEngineBI;
    
    private GenPolynomial polyp;

    public JasAccess2() {
        // define the "nominal" BigInteger as type prototype
        bi = new BigInteger(1);

        // create a factorization engine suitable for BigInteger coefficient type
        fEngineBI = FactorFactory.getImplementation(bi);
        
    }//end constructor.

    

    public Set factorPolyInt(String poly, String vars) {
        if (debug) {
            System.out.println(" poly = " + poly);
            System.out.println(" vars = " + vars);
        }

        //  convert string of variable names to array of strings as required
        String[] jvars = StringUtil.variableList(vars);
        int nvars = jvars.length;
        if (debug) {
            System.out.print("\n number of variables: ");
            System.out.println(nvars);
            for (int i = 0; i < nvars; i++) {
                System.out.print(" " + jvars[i]);
            }
            System.out.println();
        }

        // make sure term-order is INVLEX, as required
        //TermOrder to = new TermOrder(TermOrder.INVLEX);
        //if (debug) {
        //    System.out.println(" term-order = " + to);
        //}


        Factorization fEngine = fEngineBI;
        if (debug) {
            System.out.println("\nFactorization:  fEngineBI = " + fEngineBI);
        }

        // create appropriate Ring for BigIntegers with specified variable names
        //GenPolynomialRing biRing = new GenPolynomialRing(bi, nvars, to, jvars);
        GenPolynomialRing biRing = new GenPolynomialRing(bi, nvars, jvars);
        if (debug) {
            System.out.println("polynomial ring = " + biRing);
            int nvars2 = biRing.nvar;
            System.out.println("    number of variables for ring = " + nvars2);
            String varNames = biRing.varsToString();
            System.out.println("    names  of variables for ring = " + varNames);
        }

        // ---  Create polynomial in chosen Ring, from given string  --
        if (debug) {
            System.out.println("\nstrPoly = " + poly);
        }
        polyp = biRing.parse(poly);
        //System.out.println("\npoly = " + polyp);
        if (debug) {
            int lenPoly = polyp.length();
            System.out.println("    length of poly = " + lenPoly);
            int numVars = polyp.numberOfVariables();
            System.out.println("    number of variables in poly = " + numVars);
            long degree = polyp.degree();
            System.out.println("    maximal degree of poly = " + degree);
        }

        // ---  JasAccess the polynomial  ---
        SortedMap, Long> Sm = fEngineBI.factors(polyp);

        //     print info about factorization
        /*int numFactors = Sm.size();
        System.out.println("    number of factors: " + numFactors);
         */

        // ---  Print out all factors and their multiplicities  ---
        /*for (Map.Entry, Long> f : Sm.entrySet()) {
            GenPolynomial factor = f.getKey();
            Long multiplicity = f.getValue();
            System.out.println("   ( " + factor + "  ,  " + multiplicity + " )");
        }*/


        return (Set) Sm.entrySet();


    } // end method.


    
    public long maxDegree() {
        return this.polyp.degree();
    } // end method


    public void terminate()
    {
        ComputerThreads.terminate();
    }

    public boolean isDebug() {
        return debug;
    }

    public void setDebug(boolean debug) {
        this.debug = debug;
    }



    public static void main(String[] args) {
        JasAccess2 jas = new JasAccess2();

        jas.setDebug(true);

        Set resultSet = jas.factorPolyInt("x**2-9", "x");

        jas.terminate();

    }//end main.
    

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/JasPolynomial.java0000644000175000017500000001463711403471736031045 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jas;

//------------------------------------------------------------------------
//          Operations on JAS Polynomials of various types
//          Version for interfacing with MathPiper
//             Initial version:  05/13/2010
//             Modifications:    through 05/20/2010
//------------------------------------------------------------------------
import java.util.Collections;
import java.util.Map;
import java.util.SortedMap;
import java.util.TreeMap;
import java.util.List;
import java.util.Set;
import java.util.Iterator;

import edu.jas.ufd.Factorization;
import edu.jas.ufd.FactorFactory;
import edu.jas.arith.BigInteger;
import edu.jas.arith.BigRational;
import edu.jas.arith.BigComplex;
import edu.jas.kern.ComputerThreads;
import edu.jas.poly.GenPolynomial;
import edu.jas.poly.GenPolynomialRing;
import edu.jas.poly.TermOrder;
import edu.jas.util.StringUtil;

//------------------------------------------------------------------------

public class JasPolynomial {

    private boolean debug = true;
    
    private String ringName;
    
    private BigInteger  bint;
    private BigRational brat;
    private BigComplex  bcmplx;

    private GenPolynomialRing polyRing;
    //private GenPolynomialRing polyRingExt;
    
    private GenPolynomial poly;
    
    private Factorization fEngine;
    
    private SortedMap factorsMap;
    
    // -----  CONSTRUCTORS  -----
    
    // no-argument constructor -- not to be used
    protected JasPolynomial() {
    }

    
    // one-argument constructor -- specify polynomial Ring only
    public JasPolynomial(String ringType) {
        this(ringType,"x");
    }

    
    // two-argument constructor -- specify polynomial Ring and varaible-names string
    //                             varNames string looks like this: "x,y"
    public JasPolynomial(String ringType, String varNames) {
        this(ringType,varNames,"x^2-1");
    }

    
    // three-argument constructor -- 
    //          specify polynomial Ring, varaible-names string, and polynomial string
    //                         varNames string looks like this: "x,y"
    //                         polyString looks like this:      "3*x^2-5*x+4"
    public JasPolynomial(String ringType, String varNames, String polyString) {
        ringName = ringType;
        String [] varList = varNames.split(",");
        if (ringName.equals("Integer")) {
            bint     = new BigInteger(1);
            GenPolynomialRing bintRing = new GenPolynomialRing(bint,varList);
            polyRing = (GenPolynomialRing)bintRing;
            poly     = polyRing.parse(polyString);
            fEngine  = FactorFactory.getImplementation(bint);
        }
        else if ( ringName.equals("Rational")) {
            brat = new BigRational(1);
            GenPolynomialRing bratRing = new GenPolynomialRing(brat,varList);
            polyRing = (GenPolynomialRing)bratRing;
            poly     = polyRing.parse(polyString);
            fEngine  = FactorFactory.getImplementation(brat);
        }
        else if ( ringName.equals("Complex")) {
            bcmplx = new BigComplex(1);
            GenPolynomialRing cmplxRing = new GenPolynomialRing(bcmplx,varList);
            polyRing = (GenPolynomialRing)cmplxRing;
            poly     = polyRing.parse(polyString);
            fEngine  = FactorFactory.getImplementation(bcmplx);
        }
    }


    //  ------   ACCESSORS   ------ ------ ------ ------ ------ ------
    
    // Get

    public boolean isDebug() {
        return debug;
    }
    
    public GenPolynomialRing getRing() {
        return polyRing;
    }
    
    public GenPolynomial getPolynomial() {
        return poly;
    }
    
    public Factorization getFactorizationEngine() {
        return fEngine;
    }
    
    public String getRingVariables() {
        return polyRing.varsToString();
    }
    
    public boolean isIrreducible() {
        return fEngine.isIrreducible(poly);
    }
    
    public boolean isIrreducible( GenPolynomial p ) {
        return fEngine.isIrreducible(p);
    }
    
    
    // Set
    
    public void setDebug(boolean debug) {
        this.debug = debug;
    }

    public void addVars(String newVarsString) {
        String[] newVars = newVarsString.split(",");
        polyRing = polyRing.extend(newVars);
    }

    public void setPolynomial(String polyString) {
        poly = polyRing.parse(polyString);
    }

    public void setPolynomial(String polyString, String newPolyVars) {
        this.addVars(newPolyVars);
        poly = polyRing.parse(polyString);
    }
 
    
    
    // Other ------ --------------- --------------- -----------------   
    
    // factorization of this.poly
    public SortedMap factors() {
        if ( debug ) {
            System.out.println(" DEBUG:  in method factors()");
            System.out.flush();
        }
        factorsMap = fEngine.factors(poly);
        if ( debug ) {
            System.out.println("       map of factors:   " + factorsMap);
            System.out.flush();
        }
        return factorsMap;       
    }

    
    // factorization of a new poly
    
    public SortedMap factorNewPolynomial(String polyString) {
        if ( debug ) {
            System.out.println(" DEBUG:  in method factorNewPolynomial1()");
            System.out.flush();
        }
        setPolynomial(polyString);
        if ( debug ) {
            System.out.println("\n  the poly was changed to: " + getPolynomial().toScript());
            System.out.flush();
        }
        factorsMap = factors();
        return factorsMap;       
    }
    
    
    public SortedMap factorNewPolynomial(String polyString, String newPolyVars) {
        if ( debug ) {
            System.out.println(" DEBUG:  in method factorNewPolynomial2()");
            System.out.flush();
        }
        setPolynomial(polyString, newPolyVars);
        if ( debug ) {
            System.out.println("\n  the poly was changed to: " + getPolynomial().toScript());
            System.out.println("       the ring variables are " + getRing().varsToString());
            System.out.flush();           
        }
        factorsMap = factors();
        return factorsMap;       
    }
   
    
    // termination of all working threads
    public void terminate(){
        ComputerThreads.terminate();
    }
        

}//end class JasPolynomial

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/Ring.java0000644000175000017500000000330411357555577027166 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jas;

//Represents a JAS polynomial ring: GenPolynomialRing.
import edu.jas.poly.GenPolynomialRing;
import edu.jas.poly.GenPolynomialTokenizer;
import edu.jas.poly.PolynomialList;
import edu.jas.ufd.FactorAbstract;
import edu.jas.ufd.FactorFactory;
import edu.jas.ufd.GCDFactory;
import edu.jas.ufd.GreatestCommonDivisorAbstract;
import edu.jas.ufd.SquarefreeAbstract;
import edu.jas.ufd.SquarefreeFactory;
import java.io.StringReader;
import java.util.List;
import org.mathpiper.lisp.Environment;

//Methods to create ideals and ideals with parametric coefficients.
public class Ring {

    private Environment iEnvironment;
    private PolynomialList pset;
    private GenPolynomialRing ring;
    private GreatestCommonDivisorAbstract engine;
    private SquarefreeAbstract sqf;
    private FactorAbstract factor;

    public Ring(Environment aEnvironment, String ringstr) throws Exception {

        this.iEnvironment = aEnvironment;
        StringReader sr = new StringReader(ringstr);
        GenPolynomialTokenizer tok = new GenPolynomialTokenizer(sr);
        pset = tok.nextPolynomialSet();
        ring = pset.ring;

        engine = GCDFactory.getProxy(ring.coFac);

        sqf = SquarefreeFactory.getImplementation(ring.coFac);

        factor = FactorFactory.getImplementation(ring.coFac);

    }//end method.

    public List gens() throws Exception {

        /*
        List genericPolynomials = ring.generators();
        List returnList = new ArrayList();
        for(GenPolynomial genericPolynomial: genericPolynomials)
        {
        returnList.add(new RingElem(genericPolynomial));
        }*/

        return ring.generators();

    }
}//end class.





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/library/jas/JFactorsPolyInt.java0000644000175000017500000000654111400514754031304 0ustar  giovannigiovannipackage org.mathpiper.builtin.library.jas;

//------------------------------------------------------------------------
//          Factor Polynomial over Integers, using JAS Library
//          Version for interfacing with MathPiper
//             Initial version:  05/24/2010
//------------------------------------------------------------------------
import java.util.Collections;
import java.util.Map;
import java.util.SortedMap;
import java.util.TreeMap;
import java.util.List;
import java.util.Set;
import java.util.Iterator;

import edu.jas.ufd.FactorInteger;
import edu.jas.arith.BigInteger;
import edu.jas.kern.ComputerThreads;
import edu.jas.poly.GenPolynomial;
import edu.jas.poly.GenPolynomialRing;
import edu.jas.poly.TermOrder;
import edu.jas.util.StringUtil;

//------------------------------------------------------------------------

public class JFactorsPolyInt {

    private boolean debug = false;   
    private String ringName;    
    private BigInteger  bint;
    private GenPolynomialRing polyRing;
    private GenPolynomial poly; 
    private FactorInteger fEngine;    
    private SortedMap factorsMap;
    
    // -----  CONSTRUCTORS  -----
    
    // no-argument constructor -- not to be used
    protected JFactorsPolyInt() {
    }
    
    // two-argument constructor -- 
    //      specify polynomial as string, and varaible-names as string
    //                     polyString looks like this:      "3*x^2-5*x+4"
    //                     varNames string looks like this: "x,y"
    public JFactorsPolyInt(String polyString, String varNames) {
        if ( debug ) {
            System.out.println("JFactorsPolyInt   " + polyString + "   " + varNames);
        }
        String [] varList = varNames.split(",");
        bint     = new BigInteger(1);
        GenPolynomialRing bintRing = new GenPolynomialRing(bint,varList);
        poly     = bintRing.parse(polyString);
        fEngine  = new FactorInteger();
    }

    
    // factorization of this.poly
    public SortedMap factors() {
        factorsMap = fEngine.factors(poly);
        return factorsMap;       
    }
    
    
    // reducibility of this.poly
    public boolean isReducible() {
        return fEngine.isReducible(poly);
    }
   
    
    // termination of all working threads
    public void terminate(){
        ComputerThreads.terminate();
    }
        
/*
    // M A I N
    public static void main(String[] args) {
        
        boolean iDebug = false;
        long        T1 = System.currentTimeMillis(); 
        
        String polyString = args[0];
        String varNames   = args[1];
        
        if ( iDebug ) {
            System.out.println("    poly " + polyString);
            System.out.println("    vars " + varNames);
            System.out.flush();
        }
        
        JFactorsPolyInt jPoly = new JFactorsPolyInt(polyString,varNames);
        SortedMap factorsMap = jPoly.factors();
        System.out.println("\nfactorsMap: " + factorsMap);
        
        System.out.println("\nisReducible: " + jPoly.isReducible());

        jPoly.terminate();
        
        long T2 = System.currentTimeMillis(); 
        float elapsedTimeSec = (T2-T1)/1000F;    
        System.out.println("  elapsed time :  " + elapsedTimeSec + " sec\n");

    }
*/

}//end class JFactorsPolyInt

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/ArgumentList.java0000644000175000017500000000255311205174264026447 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.builtin;

import java.util.List;

//todo:tk:this class can probably be replaced by a List.
public  class ArgumentList
{
    private List argumentList;

    public ArgumentList(List argumentList)
    {
        this.argumentList = argumentList;
    }//end constructor.

    
	public  int numberOfArguments()
    {
        return argumentList.size();
    }


	public  Object getArgument(int aIndex)
    {
        return argumentList.get(aIndex);
    }
	
    /*public  boolean compare(int aIndex, String aString);
    {
        return false;
    }*/
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/builtin/BuiltinContainer.java0000644000175000017500000000212311357555206027302 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.builtin;

/**
 * Abstract class which can be put inside a org.mathpiper.lisp.BuiltinObject.
 * 
 * 
 */
public abstract class BuiltinContainer {

    public BuiltinContainer() {
    }

    public abstract String typeName();

    public abstract Object getObject();


}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/0000755000175000017500000000000011722677337023303 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/0000755000175000017500000000000011722677336025711 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/CForm.mpw0000644000175000017500000002050111523200452027416 0ustar  giovannigiovanni%mathpiper,def="CForm"

/* CForm: convert MathPiper objects to C/C++ code. */

/* version 0.3 */

/* Changelog
	0.1	CForm() derived from TeXForm() v0.4. Have basic functionality. Do not allow list manipulation, unevaluated derivatives, set operations, limits, integrals, Infinity, explicit matrices. Complex numbers and expressions are handled just like real ones. Indexed symbols are assumed to be arrays and handled literally. No declarations or prototypes are supplied. Function definitions are not handled. Sum() is left as is (can be defined as a C function).
	0.2 Fix for extra parens in Sin() and other functions; fixes for Exp(), Abs() and inverse trig functions
	0.3 Fix for indexed expressions: support a[2][3][4]
	0.3.1 Fix for CForm(integer): add a decimal point
	0.4 Support While()[]. Added IsCFormable. Use Concat() instead of Union() on lists.
	0.4.1 Support False, True
  0.4.2 Changed it so that integers are not coerced to floats any more automatically (one can coerce integers to floats manually nowadays by adding a decimal point to the string representation, eg. 1. instead of 1).
*/

/* To do:
	0. Find and fix bugs.
	1. Chop strings that are longer than 80 chars?
	2. Optimization of C code?
*/

Rulebase("CForm",{expression});
Rulebase("CForm",{expression, precedence});

Function ("CFormBracketIf", {predicate, string})
[
	Check(IsBoolean(predicate) And IsString(string), "Argument", "CForm internal error: non-boolean and/or non-string argument of CFormBracketIf");
	If(predicate, ConcatStrings("( ", string, ") "), string);
];

CFormDoublePrecisionNumber(x_IsNumber) <--
[
    Local(i,n,s,f);
    s := ToString(x);
    n := Length(s);
    f := False;
    For(i := 1, i <= n, i++)
    [
        If(s[i] = "e" Or s[i] = ".", f := True);
    ];
    If(f, s, s : ".");
];

/* Proceed just like TeXForm()
*/

// CFormMaxPrec should perhaps only be used from within this file, it is thus not in the .def file.
CFormMaxPrec() := 60000;	 /* This precedence will never be bracketed. It is equal to KMaxPrec */

100 # CForm(_x) <-- CForm(x, CFormMaxPrec());

/* Replace numbers and variables -- never bracketed except explicitly */
110 # CForm(x_IsInteger, _p) <-- ToString(x);
111 # CForm(x_IsZero, _p) <-- "0.";
112 # CForm(x_IsNumber, _p) <-- CFormDoublePrecisionNumber(x);
/* Variables are left as is, except some special ones */
190 # CForm(False, _p) <-- "false";
190 # CForm(True, _p) <-- "true";
200 # CForm(x_IsAtom, _p) <-- ToString(x);

/* Strings must be quoted but not bracketed */
100 # CForm(x_IsString, _p) <-- ConcatStrings("\"", x, "\"");

/* Replace operations */

/* arithmetic */

/* addition, subtraction, multiplication, all comparison and logical operations are "regular" */


LocalSymbols(cformRegularOps) [
  cformRegularOps := { {"+"," + "}, {"-"," - "}, {"*"," * "},
                       {"/"," / "}, {":="," = "}, {"=="," == "},
                       {"="," == "}, {"!="," != "}, {"<="," <= "},
                       {">="," >= "}, {"<"," < "}, {">"," > "},
                       {"And"," && "}, {"Or"," || "}, {">>", " >> "},
                       { "<<", " << " }, { "&", " & " }, { "|", " | " },
                       { "%", " % " }, { "^", " ^ " },
                     };

  CFormRegularOps() := cformRegularOps;
]; // LocalSymbols(cformRegularOps)

	/* This is the template for "regular" binary infix operators:
100 # CForm(_x + _y, _p) <-- CFormBracketIf(p CForm(Sin(a1)+2*Cos(b1));
Result: "sin(a1) + 2 * cos(b1)";

*SEE PrettyForm, TeXForm, IsCFormable
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/texform.mpw0000644000175000017500000005027111563005657030121 0ustar  giovannigiovanni%mathpiper,def="TeXForm"

/* def file definitions
TeXForm
TeXFormMaxPrec
TexForm
*/

/* TeXForm: convert MathPiper objects to TeX math mode strings */

/* version 0.4 */

/* Changelog
	0.1	basic functionality
	0.2 fixed bracketing of Exp, added all infix ops and math functions
	0.3 fixed bracketing of lists, changed bracketing of math functions, modified TeX representation of user-defined functions (up to two-letter functions are in italics), added TeX Greek letters
	0.4 added nth roots, Sum, Limit, Integrate, hyperbolics, set operations, Abs, Max, Min, "==", ":=", Infinity; support indexed expressions A[i] and matrices.
	0.4.1 bugfixes for [] operator, support for multiple indices a[1][2][3]
	0.4.2 fix for variable names ending on digits "a2" represented as $a_2$
	0.4.3 bugfixes: complex I, indeterminate integration; relaxed bracketing of Sin()-like functions; implemented $TeX$ and $LaTeX$ correctly now (using \textrm{})
	0.4.4 use ordinary instead of partial derivative if expression has only one variable
	0.4.5 fixes for bracketing of Sum(); added <> to render as \sim and <=> to render as \approx; added BinomialCoefficient()
	0.4.6 moved the <> and <=> operators to initialization.rep/stdopers.mpi
	0.4.7 added Product() i.e. Product()
	0.4.8 added Differentiate(x,n), Deriv(x,n), =>, and fixed errors with ArcSinh, ArcCosh, ArcTanh
	0.4.9 fixed omission: (fraction)^n was not put in brackets
	0.4.10 cosmetic change: insert \cdot between numbers in cases like 2*10^n
	0.4.11 added DumpErrors() to TexForm for the benefit of TeXmacs notebooks
	0.4.12 implement the % operation as Mod
	0.4.13 added Bessel{I,J,K,Y}, Ortho{H,P,T,U}, with a general framework for usual two-argument functions of the form $A_n(x)$; fix for Max, Min
	0.4.14 added mathematical notation for Floor(), Ceil()
	0.4.15 added Prog() represented by ( )
	0.4.16 added Zeta()
*/

/* To do:
	0. Find and fix bugs.
	1. The current bracketing approach has limitations: can't omit extra brackets sometimes. " sin a b" is ambiguous, so need to do either "sin a sin b" or "(sin a) b" Hold((a*b)*Sqrt(x)). The current approach is *not* to bracket functions unless the enveloping operation is more binding than multiplication. This produces "sin a b" for both Sin(a*b) and Sin(a)*b but this is the current mathematical practice.
	2. Need to figure out how to deal with variable names such as "alpha3"
*/

//Retract("TeXForm", *);

/// TeXmacs prettyprinter
TexForm(_expr) <-- [DumpErrors();WriteString(TeXForm(expr));NewLine();];

Rulebase("TeXForm",{expression});
Rulebase("TeXForm",{expression, precedence});

/* Boolean predicate */


/* this function will put TeX brackets around the string if predicate holds */

Function ("TeXFormBracketIf", {predicate, string})
[
	Check(IsBoolean(predicate) And IsString(string), "Argument", "TeXForm internal error: non-boolean and/or non-string argument of TeXFormBracketIf");
	If(predicate, ConcatStrings("( ", string, ") "), string);
];




Function ("TeXFormMatrixBracketIf", {predicate, string})
[
	Check(IsBoolean(predicate) And IsString(string), "Argument", "TeXForm internal error: non-boolean and/or non-string argument of TeXFormMatrixBracketIf");
	If(predicate, ConcatStrings("\\left[ ", string, "\\right]"), string);
];



/* First, we convert TeXForm(x) to TeXForm(x, precedence). The enveloping precedence will determine whether we need to bracket the results. So TeXForm(x, TeXFormMaxPrec()) will always print "x", while TeXForm(x,-TeXFormMaxPrec()) will always print "(x)".
*/

TeXFormMaxPrec() := 60000;	 /* This precedence will never be bracketed. It is equal to KMaxPrec */

/// main front-end
100 # TeXForm(_x) <-- ConcatStrings("$", TeXForm(x, TeXFormMaxPrec()), "$");

/* Replace numbers and variables -- never bracketed except explicitly */

110 # TeXForm(x_IsNumber, _p) <-- ToString(x);
/* Variables */
200 # TeXForm(x_IsAtom, _p) <-- TeXFormTeXify(ToString(x));


/* Strings must be quoted but not bracketed */
100 # TeXForm(x_IsString, _p) <--
[
    Local(characterList);

    characterList := {};
    ForEach(character, x)
    [
        If(character != " ", DestructiveAppend(characterList, character), DestructiveAppend(characterList, "\\hspace{2 mm}"));
    ];
    ConcatStrings("\\mathrm{''", ListToString(characterList), "''}");
];



/* FunctionToList(...) can generate lists with atoms that would otherwise result in unparsable expressions. */
100 # TeXForm(x_IsAtom, _p)_(IsInfix(ToString(x))) <-- ConcatStrings("\\mathrm{", ToString(x), "}");


/* Lists: make sure to have matrices processed before them. Enveloping precedence is irrelevant because lists are always bracketed. List items are never bracketed. Note that TeXFormFinishList({a,b}) generates ",a,b" */

100 # TeXForm(x_IsList, _p)_(Length(x)=0) <-- TeXFormBracketIf(True, "");
110 # TeXForm(x_IsList, _p) <-- TeXFormBracketIf(True, ConcatStrings(TeXForm(First(x), TeXFormMaxPrec()), TeXFormFinishList(Rest(x)) ) );
100 # TeXFormFinishList(x_IsList)_(Length(x)=0) <-- "";
110 # TeXFormFinishList(x_IsList) <-- ConcatStrings(", ", TeXForm(First(x), TeXFormMaxPrec()), TeXFormFinishList(Rest(x)));

/* Replace operations */


	/* Template for "regular" binary infix operators:
100 # TeXForm(_x + _y, _p) <-- TeXFormBracketIf(p=","\\geq "},
    {"<"," < "},
    {">"," > "},
    {"And","\\wedge "},
    {"Or", "\\vee "},
    {"<>", "\\sim "},
    {"<=>", "\\approx "},
    {"=>", "\\Rightarrow "},
    {"%", "\\bmod "},
  };

  TeXFormRegularPrefixOps := { {"+"," + "}, {"-"," - "}, {"Not"," \\neg "} };



    /* Unknown function: precedence 200. Leave as is, never bracket the function itself and bracket the argumentPointer(s) automatically since it's a list. Other functions are precedence 100 */

  TeXFormGreekLetters := {"Gamma", "Delta", "Theta", "Lambda", "Xi", "Pi", "Sigma", "Upsilon", "Phi", "Psi", "Omega", "alpha", "beta", "gamma", "delta", "epsilon", "zeta", "eta", "theta", "iota", "kappa", "lambda", "mu", "nu", "xi", "pi", "rho", "sigma", "tau", "upsilon", "phi", "chi", "psi", "omega", "varpi", "varrho", "varsigma", "varphi", "varepsilon"};
  TeXFormSpecialNames := {
    {"I", "\\imath "},	// this prevents a real uppercase I, use BesselI instead
    {"Pi", "\\pi "},	// this makes it impossible to have an uppercase Pi... hopefully it's not needed
    {"Infinity", "\\infty "},
    {"TeX", "\\textrm{\\TeX\\/}"},
    {"LaTeX", "\\textrm{\\LaTeX\\/}"},
    {"Maximum", "\\max "},	// this replaces these function names
    {"Minimum", "\\min "},
    {"Prog", " "},
    {"Zeta", "\\zeta "},
  };


  /* this function will take a user-defined variable or function name and output either this name unmodified if it's only 2 characters long, or the name in normal text if it's longer, or a TeX Greek letter code */
  Function ("TeXFormTeXify", {string})
  [
    Check(IsString(string), "Argument", "TeXForm internal error: non-string argument of TeXFormTeXify");
    /* Check if it's a greek letter or a special name */
    If (Contains(AssocIndices(TeXFormSpecialNames), string), TeXFormSpecialNames[string],
    If (Contains(TeXFormGreekLetters, string), ConcatStrings("\\", string, " "),
    If (Contains(AssocIndices(TeXFormRegularOps), string), TeXFormRegularOps[string],
    If (Contains(AssocIndices(TeXFormRegularPrefixOps), string), TeXFormRegularPrefixOps[string],
    If (Length(string) >= 2 And IsNumber(ToAtom(StringMidGet(2, Length(string)-1, string))), ConcatStrings(StringMidGet(1,1,string), "_{", StringMidGet(2, Length(string)-1, string), "}"),
    If (Length(string) > 2, ConcatStrings("\\mathrm{ ", string, " }"),
    string
    ))))));
  ];

];

/* */

/* Unknown bodied function */

200 # TeXForm(x_IsFunction, _p) _ (IsBodied(Type(x))) <-- [
	Local(func, args, last'arg);
	func := Type(x);
	args := Rest(FunctionToList(x));
	last'arg := PopBack(args);
	TeXFormBracketIf(p1, "\\frac{\\partial}{\\partial ", "\\frac{d}{d "
	), TeXForm(x, PrecedenceGet("^")), "}", TeXForm(y, PrecedenceGet("/")) ) );

100 # TeXForm(Deriv(_x, _n)_y, _p) <-- TeXFormBracketIf(p1,
		"\\frac{\\partial^" : TeXForm(n, TeXFormMaxPrec()) : "}{\\partial ",
		"\\frac{d^" : TeXForm(n, TeXFormMaxPrec()) : "}{d "
	), TeXForm(x, PrecedenceGet("^")), " ^", TeXForm(n, TeXFormMaxPrec()), "}", TeXForm(y, PrecedenceGet("/")) ) );
100 # TeXForm(Differentiate(_x)_y, _p) <-- TeXForm(Deriv(x) y, p);
100 # TeXForm(Differentiate(_x, _n)_y, _p) <-- TeXForm(Deriv(x, n) y, p);

/* Indexed expressions */

/* This seems not to work because x[i] is replaced by Nth(x,i) */
/*
100 # TeXForm(_x [ _i ], _p) <-- ConcatStrings(TeXForm(x, TeXFormMaxPrec()), " _{", TeXForm(i, TeXFormMaxPrec()), "}");
*/
/* Need to introduce auxiliary function, or else have trouble with arguments of Nth being lists */
100 # TeXForm(Nth(Nth(_x, i_IsList), _j), _p) <-- TeXForm(TeXFormNth(x, Append(i,j)), p);
100 # TeXForm(TeXFormNth(Nth(_x, i_IsList), _j), _p) <-- TeXForm(TeXFormNth(x, Append(i,j)), p);
110 # TeXForm(Nth(Nth(_x, _i), _j), _p) <-- TeXForm(TeXFormNth(x, List(i,j)), p);
120 # TeXForm(Nth(_x, _i), _p) <-- ConcatStrings(TeXForm(x, TeXFormMaxPrec()), " _{", TeXForm(i, TeXFormMaxPrec()), "}");
120 # TeXForm(TeXFormNth(_x, _i), _p) <-- ConcatStrings(TeXForm(x, TeXFormMaxPrec()), " _{", TeXForm(i, TeXFormMaxPrec()), "}");

/* Matrices are always bracketed. Precedence 80 because lists are at 100. */

80 # TeXForm(M_IsMatrix, _p) <-- TeXFormMatrixBracketIf(True, TeXFormPrintMatrix(M));

Function ("TeXFormPrintMatrix", {M})
[
/*
	Want something like "\begin{array}{cc} a & b \\ c & d \\ e & f \end{array}"
	here, "cc" is alignment and must be given for each column
*/
	Local(row, col, result, ncol);
	result := "\\begin{array}{";
	ForEach(col, M[1]) result:=ConcatStrings(result, "c");
	result := ConcatStrings(result, "}");

	ForEach(row, 1 .. Length(M)) [
		ForEach(col, 1 .. Length(M[row])) [
			result := ConcatStrings( result, " ", TeXForm(M[row][col], TeXFormMaxPrec()), If(col = Length(M[row]), If(row = Length(M), "", " \\\\"), " &"));
		];
	];

	ConcatStrings(result, " \\end{array} ");
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="TeXForm",categories="User Functions;Input/Output"
*CMD TeXForm --- export expressions to $LaTeX$
*STD
*CALL
	TeXForm(expr)

*PARMS

{expr} -- an expression to be exported

*DESC

{TeXForm} returns a string containing a $LaTeX$ representation of the MathPiper expression {expr}. Currently the exporter handles most expression types but not all.

*E.G.

In> TeXForm(Sin(a1)+2*Cos(b1))
Result: "\$\sin a_{1} + 2 \cos b_{1}\$";

*SEE PrettyForm, CForm
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/IsCFormable.mpw0000644000175000017500000000542011523200452030541 0ustar  giovannigiovanni%mathpiper,def="IsCFormable"

//////////////////////////////////////////////////
/// IsCFormable
//////////////////////////////////////////////////

LocalSymbols(CFormAllFunctions) [

  /// predicate to test whether an expression can be successfully exported to C code

  /// interface with empty extra function list
  // need the backquote stuff b/c we have HoldArgument now
  IsCFormable(_expr) <-- `IsCFormable(@expr, {});

  // need to check that expr contains only allowed functions
  IsCFormable(_expr, funclist_IsList) <--
  [
    Local(bad'functions);
    bad'functions := Difference(`FuncList(@expr), Concat(CFormAllFunctions, funclist));
    If(Length(bad'functions)=0,
      True,
      [
        If(InVerboseMode(),
          Echo(Concat({"IsCFormable: Info: unexportable function(s): "}, bad'functions))
        );
        False;
      ]
    );
  ];
  HoldArgumentNumber("IsCFormable", 1, 1);
  HoldArgumentNumber("IsCFormable", 2, 1);

  /// This is a list of all function atoms which CForm can safely handle
  CFormAllFunctions := MapSingle(ToAtom, Concat(AssocIndices(CFormMathFunctions()), AssocIndices(CFormRegularOps()),
  // list of "other" (non-math) functions supported by CForm: needs to be updated when CForm is extended to handle new functions
  {
    "For",
    "While",
    "Prog",
    "Nth",
    "Modulo",
    "Complex",
    "if",
    "else",
    "++",
    "--",
  }
  ));


]; // LocalSymbols(CFormAllFunctions)

%/mathpiper



%mathpiper_docs,name="IsCFormable",categories="User Functions;Input/Output;Predicates"
*CMD IsCFormable --- check possibility to export expression to C++ code
*STD
*CALL
	IsCFormable(expr)
	IsCFormable(expr, funclist)
	
*PARMS

{expr} -- expression to be exported (this argument is not evaluated)

{funclist} -- list of "allowed" function atoms

*DESC

{IsCFormable} returns {True} if the MathPiper expression {expr} can be exported
into C++ code. This is a check whether the C++ exporter {CForm} can be safely
used on the expression.

A MathPiper expression is considered exportable if it contains only functions that can be translated into C++ (e.g. {ListToFunction} cannot be exported). All variables and constants are considered exportable.

The verbose option prints names of functions that are not exportable.

The second calling format of {IsCFormable} can be used to "allow" certain function names that will be available in the C++ code.

*E.G. notest

In> IsCFormable(Sin(a1)+2*Cos(b1))
Result: True;
In> V(IsCFormable(1+func123(b1)))
	IsCFormable: Info: unexportable function(s):
	  func123
Result: False;
This returned {False} because the function {func123} is not available in C++. We can
explicitly allow this function and then the expression will be considered
exportable:

In> IsCFormable(1+func123(b1), {func123})
Result: True;

*SEE CForm, V
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/PrettyForm.mpw0000644000175000017500000002427211523200452030534 0ustar  giovannigiovanni%mathpiper,def="PrettyForm;EvalFormula"

/* def file definitions
EvalFormula
*/


/*
TODO:
- Func(a=b) prematurely evaluates a=b
- clean up the code!
  - document the code!!!
- prefix/postfix currently not used!!!
- some rules for rendering the formula are slooooww....

- bin, derivative, sqrt, integral, summation, limits,
      ___
     / a |
 \  /  -
  \/   b

   /
   |
   |
   |
   /

  d
 --- f( x )
 d x

   2
  d
 ----  f( x )
    2
 d x

  Infinity
    ___
    \
     \    n
     /   x
    /__
    n = 0
                 Sin(x)
     lim         ------
 x -> Infinity    x



*/

/*
NLog(str):=
[
  WriteString(str);
  NewLine();
];
*/




CharList(length,item):=
[
  Local(line,i);
  line:="";
  For(Bind(i,0),IsLessThan(i,length),Bind(i,AddN(i,1)))
    Bind(line, line:item);
  line;
];




CharField(width,height) := ArrayCreate(height,CharList(width," "));




WriteCharField(charfield):=
[
  Local(i,len);
  len:=Length(charfield);
  For(Bind(i,1),i<=len,Bind(i,AddN(i,1)))
  [
    WriteString(charfield[i]);
    NewLine();
  ];
  True;
];




ColumnFilled(charfield,column):=
[
  Local(i,result,len);
  result:=False;
  len:=Length(charfield);
  For(Bind(i, 1),(result = False) And (i<=len),Bind(i,AddN(i,1)))
  [
    If(StringMidGet(column,1,charfield[i]) != " ",result:=True);
  ];
  result;
];




WriteCharField(charfield,width):=
[
  Local(pos,length,len);
  Bind(length, Length(charfield[1]));
  Bind(pos, 1);
  While(pos<=length)
  [
    Local(i,thiswidth);
    Bind(thiswidth, width);
    If(thiswidth>(length-pos)+1,
      [
        Bind(thiswidth, AddN(SubtractN(length,pos),1));
      ],
      [
        While (thiswidth>1 And ColumnFilled(charfield,pos+thiswidth-1))
        [
          Bind(thiswidth,SubtractN(thiswidth,1));
        ];
        If(thiswidth = 1, Bind(thiswidth, width));
      ]
    );
    len:=Length(charfield);
    For(Bind(i, 1),i<=len,Bind(i,AddN(i,1)))
    [
      WriteString(StringMidGet(pos,thiswidth,charfield[i]));
      NewLine();
    ];
    Bind(pos, AddN(pos, thiswidth));
    NewLine();
  ];
  True;
];




PutString(charfield,x,y,string):=
[
  cf[y] := StringMidSet(x,string,cf[y]);
  True;
];




MakeOper(x,y,width,height,oper,args,base):=
[
  Local(result);
  Bind(result,ArrayCreate(7,0));
  ArraySet(result,1,x);
  ArraySet(result,2,y);
  ArraySet(result,3,width);
  ArraySet(result,4,height);
  ArraySet(result,5,oper);
  ArraySet(result,6,args);
  ArraySet(result,7,base);
  result;
];




MoveOper(f,x,y):=
[
  f[1]:=AddN(f[1], x); /* move x */
  f[2]:=AddN(f[2], y); /* move y */
  f[7]:=AddN(f[7], y); /* move base */
];




AlignBase(i1,i2):=
[
  Local(base);
  Bind(base, Maximum(i1[7],i2[7]));
  MoveOper(i1,0,SubtractN(base,(i1[7])));
  MoveOper(i2,0,SubtractN(base,(i2[7])));
];




10 # BuildArgs({}) <-- Formula(ToAtom(" "));




20 # BuildArgs({_head}) <-- head;




30 # BuildArgs(_any)    <--
     [
        Local(item1,item2,comma,base,newitem);
        Bind(item1, any[1]);
        Bind(item2, any[2]);
        Bind(comma, Formula(ToAtom(",")));
        Bind(base, Maximum(item1[7],item2[7]));
        MoveOper(item1,0,SubtractN(base,(item1[7])));
        MoveOper(comma,AddN(item1[3],1),base);

        MoveOper(item2,comma[1]+comma[3]+1,SubtractN(base,(item2[7])));
        Bind(newitem, MakeOper(0,0,AddN(item2[1],item2[3]),Maximum(item1[4],item2[4]),"Func",{item1,comma,item2},base));
        BuildArgs(newitem:Rest(Rest(any)));
      ];




FormulaBracket(f):=
[
  Local(left,right);
  Bind(left, Formula(ToAtom("(")));
  Bind(right, Formula(ToAtom(")")));
  left[4]:=f[4];
  right[4]:=f[4];
  MoveOper(left,f[1],f[2]);
  MoveOper(f,2,0);
  MoveOper(right,f[1]+f[3]+1,f[2]);
  MakeOper(0,0,right[1]+right[3],f[4],"Func",{left,f,right},f[7]);
];




/* Rulebase("Formula",{f}); */

1 # Formula(f_IsAtom) <--
  MakeOper(0,0,Length(ToString(f)),1,"ToAtom",ToString(f),0);




2 # Formula(_xx ^ _yy) <--
[
  Local(l,r);
  Bind(l, BracketOn(Formula(xx),xx,LeftPrecedenceGet("^")));
  Bind(r, BracketOn(Formula(yy),yy,RightPrecedenceGet("^")));
  MoveOper(l,0,r[4]);
  MoveOper(r,l[3],0);
  MakeOper(0,0,AddN(l[3],r[3]),AddN(l[4],r[4]),"Func",{l,r},l[2]+l[4]-1);
];




10 # FormulaArrayItem(xx_IsList) <--
[
  Local(sub,height);
  sub := {};
  height := 0;
  ForEach(item,xx)
  [
    Local(made);
    made := FormulaBracket(Formula(item));
    If(made[4] > height,Bind(height,made[4]));
    DestructiveAppend(sub,made);
  ];
  MakeOper(0,0,0,height,"List",sub,height>>1);
];



20 # FormulaArrayItem(_item) <-- Formula(item);




2 # Formula(xx_IsList) <--
[
  Local(sub,width,height);
  sub:={};
  width := 0;
  height := 1;

  ForEach(item,xx)
  [
    Local(made);
    made := FormulaArrayItem(item);

    If(made[3] > width,Bind(width,made[3]));
    MoveOper(made,0,height);
    Bind(height,AddN(height,AddN(made[4],1)));
    DestructiveAppend(sub,made);
  ];

  Local(thislength,maxlength);
  maxlength:=0;
  ForEach(item,xx)
  [
    thislength:=0;
    if(IsList(item)) [thislength:=Length(item);];
    if (maxlength0,
  [
    Local(i,j);
    width:=0;
    For(j:=1,j<=maxlength,j++)
    [
      Local(w);
      w := 0;
      For(i:=1,i<=Length(sub),i++)
      [
        if (IsList(xx[i]) And j<=Length(xx[i]))
          If(sub[i][6][j][3] > w,w := sub[i][6][j][3]);
      ];

      For(i:=1,i<=Length(sub),i++)
      [
        if (IsList(xx[i]) And j<=Length(xx[i]))
          MoveOper(sub[i][6][j],width,0);
      ];
      width := width+w+1;
    ];
    For(i:=1,i<=Length(sub),i++)
    [
      sub[i][3] := width;
    ];
  ]
  );

  sub := MakeOper(0,0,width,height,"List",sub,height>>1);
  FormulaBracket(sub);
];





2 # Formula(_xx / _yy) <--
[
  Local(l,r,dash,width);
/*
  Bind(l, BracketOn(Formula(xx),xx,LeftPrecedenceGet("/")));
  Bind(r, BracketOn(Formula(yy),yy,RightPrecedenceGet("/")));
*/
  Bind(l, Formula(xx));
  Bind(r, Formula(yy));
  Bind(width, Maximum(l[3],r[3]));
  Bind(dash, Formula(ToAtom(CharList(width,"-"))));
  MoveOper(dash,0,l[4]);
  MoveOper(l,(SubtractN(width,l[3])>>1),0);
  MoveOper(r,(SubtractN(width,r[3])>>1),AddN(dash[2], dash[4]));
  MakeOper(0,0,width,AddN(r[2], r[4]),"Func",{l,r,dash},dash[2]);
];




Rulebase("BracketOn",{op,f,prec});

Rule("BracketOn",3,1,IsFunction(f) And ArgumentsCount(f) = 2
     And IsInfix(Type(f)) And PrecedenceGet(Type(f)) > prec)
[
 FormulaBracket(op);
];




Rule("BracketOn",3,2,True)
[
  op;
];





10 # Formula(f_IsFunction)_(ArgumentsCount(f) = 2 And IsInfix(Type(f))) <--
[
  Local(l,r,oper,width,height,base);
  Bind(l, Formula(f[1]));
  Bind(r, Formula(f[2]));

  Bind(l, BracketOn(l,f[1],LeftPrecedenceGet(Type(f))));
  Bind(r, BracketOn(r,f[2],RightPrecedenceGet(Type(f))));

  Bind(oper, Formula(f[0]));
  Bind(base, Maximum(l[7],r[7]));
  MoveOper(oper,AddN(l[3],1),SubtractN(base,(oper[7])));
  MoveOper(r,oper[1] + oper[3]+1,SubtractN(base,(r[7])));
  MoveOper(l,0,SubtractN(base,(l[7])));
  Bind(height, Maximum(AddN(l[2], l[4]),AddN(r[2], r[4])));

  MakeOper(0,0,AddN(r[1], r[3]),height,"Func",{l,r,oper},base);
];




11 # Formula(f_IsFunction) <--
[
  Local(head,args,all);
  Bind(head, Formula(f[0]));
  Bind(all, Rest(FunctionToList(f)));

  Bind(args, FormulaBracket(BuildArgs(MapSingle("Formula",Apply("Hold",{all})))));
  AlignBase(head,args);
  MoveOper(args,head[3],0);

  MakeOper(0,0,args[1]+args[3],Maximum(head[4],args[4]),"Func",{head,args},head[7]);
];



Rulebase("RenderFormula",{cf,f,x,y});

/*
/   /  /
\   |  |
    \  |
       \
*/

Rule("RenderFormula",4,1,f[5] = "ToAtom" And f[6] = "(" And f[4] > 1)
[
  Local(height,i);
  Bind(x, AddN(x,f[1]));
  Bind(y, AddN(y,f[2]));
  Bind(height, SubtractN(f[4],1));

  cf[y] := StringMidSet(x, "/", cf[y]);
  cf[AddN(y,height)] := StringMidSet(x, "\\", cf[AddN(y,height)]);
  For (Bind(i,1),IsLessThan(i,height),Bind(i,AddN(i,1)))
    cf[AddN(y,i)] := StringMidSet(x, "|", cf[AddN(y,i)]);
];




Rule("RenderFormula",4,1,f[5] = "ToAtom" And f[6] = ")" And f[4] > 1)
[
  Local(height,i);
  Bind(x, AddN(x,f[1]));
  Bind(y, AddN(y,f[2]));
  Bind(height, SubtractN(f[4],1));
  cf[y] := StringMidSet(x, "\\", cf[y]);
  cf[y+height] := StringMidSet(x, "/", cf[y+height]);
  For (Bind(i,1),IsLessThan(i,height),Bind(i,AddN(i,1)))
    cf[AddN(y,i)] := StringMidSet(x, "|", cf[AddN(y,i)]);
];




Rule("RenderFormula",4,5,f[5] = "ToAtom")
[
  cf[AddN(y, f[2]) ]:=
    StringMidSet(AddN(x,f[1]),f[6],cf[AddN(y, f[2]) ]);
];




Rule("RenderFormula",4,6,True)
[
  ForEach(item,f[6])
  [
    RenderFormula(cf,item,AddN(x, f[1]),AddN(y, f[2]));
  ];
];




LocalSymbols(formulaMaxWidth) [
  SetFormulaMaxWidth(width):=
  [
    formulaMaxWidth := width;
  ];
  FormulaMaxWidth() := formulaMaxWidth;
  SetFormulaMaxWidth(60);
]; // LocalSymbols(formulaMaxWidth)




Function("PrettyForm",{ff})
[
  Local(cf,f);

  f:=Formula(ff);

  cf:=CharField(f[3],f[4]);
  RenderFormula(cf,f,1,1);

  NewLine();
  WriteCharField(cf,FormulaMaxWidth());

  DumpErrors();
  True;
];
/*
HoldArgument("PrettyForm",ff);
*/




EvalFormula(f):=
[
  Local(result);
  result:= ListToFunction({ToAtom("="),f,Eval(f)});
  PrettyForm(result);
  True;
];
HoldArgument("EvalFormula",f);

/*
{x,y,width,height,oper,args,base}
*/

%/mathpiper



%mathpiper_docs,name="PrettyForm",categories="User Functions;Input/Output"
*CMD PrettyForm --- print an expression nicely with ASCII art
*STD
*CALL
	PrettyForm(expr)

*PARMS

{expr} -- an expression

*DESC

{PrettyForm} renders an expression in a nicer way, using ascii art.
This is generally useful when the result of a calculation is more
complex than a simple number.

*E.G.

In> Taylor(x,0,9)Sin(x)
Result: x-x^3/6+x^5/120-x^7/5040+x^9/362880;
In> PrettyForm(%)
	
	     3    5      7       9
	    x    x      x       x
	x - -- + --- - ---- + ------
	    6    120   5040   362880
	
Result: True;

*SEE EvalFormula, PrettyPrinterSet
%/mathpiper_docs



%mathpiper_docs,name="EvalFormula",categories="User Functions;Input/Output"
*CMD EvalFormula --- print an evaluation nicely with ASCII art
*STD
*CALL
	EvalFormula(expr)

*PARMS

{expr} -- an expression

*DESC

Show an evaluation in a nice way, using {PrettyPrinterSet}
to show 'input = output'.

*E.G.

In> EvalFormula(Taylor(x,0,7)Sin(x))
	
	                                      3    5
	                                     x    x  
	Taylor( x , 0 , 5 , Sin( x ) ) = x - -- + ---
	                                     6    120


*SEE PrettyForm
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/outputforms/openmath.mpw0000644000175000017500000006541311523200452030236 0ustar  giovannigiovanni%mathpiper,def="OMREP;OMDef;OMForm;OMRead;OMParse;OMEcho;OMEchoEscape"

/* def file definitions
OMREP
OMDef
OMForm
OMRead
OMParse
OMEcho
OMEchoEscape
*/

////////////////////////
// Written by Alberto González Palomo and Ayal Pinkus.
////////////////////////

/* The read-eval-print loop */
/* It can take one parameter, that is the evaluation count. If it is greater
   than zero, only that number of iterations will be performed before
   exiting. This is particularly useful when connecting to MathPiper via pipes.
*/
Rulebase("OMREP",{});
Rule("OMREP",0,1,True)
[
  OMREP(0);// 0 means keep repeating, as usual.
];
Rulebase("OMREP",{count});
LocalSymbols(input,stringOut,result)
Rule("OMREP",1,1,True)
[
  Local(input,stringOut,result);
  While(Not(IsExitRequested()))
  [
    Bind(errorObject, False);
    ExceptionCatch(Bind(input, PipeFromString(ConcatStrings(ReadCmdLineString("")," "))OMRead()), Bind(errorObject,OMGetCoreError()));

    If(Not(errorObject = False), errorObject); //todo:tk:check this code.

    If (Not(IsExitRequested()) And errorObject = False,
    [
      Bind(stringOut,"");
      Bind(result,False);
      ExceptionCatch(Bind(stringOut,PipeToString()[Secure(Bind(result,Eval(input)));]), Bind(errorObject,OMGetCoreError()));

      If(Not(errorObject = False), errorObject); //todo:tk:check this code.

      If(Not(stringOut = ""), WriteString(stringOut));
      SetGlobalLazyVariable(%,result);
      If(PrettyPrinterGet()="",
      [
        Apply("OMForm",{result});
      ],
      Apply(PrettyPrinterGet(),{result}));
      If(count > 0 And (count:=count-1) = 0, Exit());
    ]);
  ];
];


LocalSymbols(omindent) [
  // Function definitions
  OMIndent() := [omindent := omindent + 2;];
  OMUndent() := [omindent := omindent - 2;];
  OMClearIndent() := [omindent := 0;];
  OMIndentSpace() := Space(omindent);

  // Initialization of indentation
  OMClearIndent();
]; // LocalSymbols(omindent)

///////////////////////////////////////////////////////////////////////
// Output

10 # OMForm(_expression)
     <--
     [
     OMClearIndent();
     OMEcho("");
     OMIndent();
     If(IsAtom(expression),
        If(expression = ToAtom("%"),
           Secure(expression := Eval(expression))
           )
        );
     OMFormExpression(expression);
     OMUndent();
     OMEcho("");
     ];

10 # OMFormExpression(i_IsString)  <-- OMEcho("":i:"");
11 # OMFormExpression(i_IsInteger) <-- OMEcho("":ToString(i):"");
12 # OMFormExpression(i_IsNumber)  <-- OMEcho("");
13 # OMFormExpression(i_IsConstant)_(OMSymbol()[ ToString(i) ] != Empty)
     <-- OMEcho(""
                );
14 # OMFormExpression(i_IsConstant)// Should we rather evaluate it?
     <-- OMEcho("");
15 # OMFormExpression(i_IsVariable)_(OMSymbol()[ ToString(i) ] != Empty)
     <-- OMEcho(""
                );
16 # OMFormExpression(i_IsVariable)
     <-- OMEcho("");
16 # OMFormExpression(i_IsVariable)_(i = Empty)
     <-- False; // This is useful for void expressions.

10 # OMFormExpression(function_IsFunction)_(Type(function) = "OMError")
     <--
     [
     Local(cd, name);
     If(IsList(function[1]),
        [ cd := function[1][1]; name := function[1][2]; ],
        [ cd := "error";        name := function[1];    ]);
     OMEcho("");
     OMIndent();
     OMEcho("");
     ForEach(i, Rest(function)) OMFormExpression(i);
     OMUndent();
     OMEcho("");
     ];
10 # OMFormExpression(function_IsFunction)_(Type(function) = "OME")
     <--
     [
     OMEcho("");
     OMIndent();
     ForEach(i, function) OMFormExpression(i);
     OMUndent();
     OMEcho("");
     ];
10 # OMFormExpression(function_IsFunction)_(Type(function) = "OMS")
     <-- OMEcho("");
10 # OMFormExpression(function_IsFunction)_(Type(function) = "OMBIND")
     <--
     [
     OMEcho("");
     OMIndent();
     ForEach(i, function) OMFormExpression(i);
     OMUndent();
     OMEcho("");
     ];
10 # OMFormExpression(function_IsFunction)_(Type(function) = "OMBVAR")
     <--
     [
     OMEcho("");
     OMIndent();
     ForEach(i, function) OMFormExpression(i);
     OMUndent();
     OMEcho("");
     ];
10 # OMFormExpression(function_IsFunction)_(Type(function) = "OMA")
     <--
     [
     // This is not the same as the next rule: this is OMA(a,b,c,...),
     // which is used for building OMA constructs in the mapping to OM.
     OMEcho("");
     OMIndent();
     ForEach(i, function) OMFormExpression(i);
     OMUndent();
     OMEcho("");
     ];
11 # OMFormExpression(function_IsFunction)
     <--
     [
     OMEcho("");
     OMIndent();
     OMFormFunction(function);
     OMUndent();
     OMEcho("");
     ];

11 # OMFormFunction(function_IsFunction)
     <--
     [
     Local(arity);
     arity := Length(function);
     OMEcho("");
     If(arity > 0, ForEach(arg, function) OMFormExpression(arg));
     ];
10 # OMFormFunction(function_IsFunction)_(OMSymbol()[ Type(function) ] != Empty)
     <--
     [
     Local(symbolDef);
     // [20051016 AGP] The "signature" feature is an old attempt at pattern
     // matching, but now that we have real predicates in the mappings it's
     // probably obsolete. I'll think about removing it.
     symbolDef := OMSymbol()[ OMSignature(function) ];
     If(symbolDef = Empty, symbolDef := OMSymbol()[ Type(function) ] );
     If(symbolDef = Empty Or Length(symbolDef) < 3 Or symbolDef[3] = {},
        [
        OMEcho("");
        ForEach(arg, function) OMFormExpression(arg);
        ],
        [
        Local(result);
        result := OMApplyMapping(function, symbolDef[3]);
        //Check(IsList(result), "Return Type", PipeToString()Echo("Mapping result is not a list: ", result));
        If(IsList(result),
           [
           result := ListToFunction(Subst($, function[0]) result);
           OMFormExpression(result[0]);
           ForEach(i, result) OMFormExpression(i);
           ],
           If(result = Empty,
              Echo("No rule matched ", function, symbolDef[3]),
              Echo("Unexpected result value from OMApplyMapping(): ", result)
             )
          );
        ]
       );
     ];


OMWrite(_expression) <--
[
  Write(expression);
];

OMEcho(_expression) <--
[
  OMIndentSpace();
  Write(expression);
  NewLine();
];
OMEcho(expression_IsString) <--
[
  OMIndentSpace();
  WriteString(expression);
  NewLine();
];
OMEcho(expression_IsList) <--
[
  ForEach(arg, expression)
  [
    If (IsString(arg), WriteString(arg), Write(arg));
  ];
  NewLine();
];

OMEscape(_expression) <--
[
  "";
];
OMEscapeString(_expression_IsString) <--
[
  "";
];
OMWriteEscape(_expression) <--
[
  WriteString(OMEscape(expression));
];
OMWriteStringEscape(expression_IsString) <--
[
  WriteString(OMEscapeString(expression));
];
OMEchoEscape(_expression) <--
[
  OMWriteEscape(expression);
  NewLine();
];
OMEchoEscape(expression_IsString) <--
[
  OMWriteStringEscape(expression);
  NewLine();
];
OMEchoEscape(expression_IsList) <--
[
  WriteString("");
  NewLine();
];


HoldArgumentNumber("OMForm",1,1);
//HoldArgumentNumber("OMFormExpression",1,1);
//HoldArgumentNumber("OMFormFunction",1,1);


OMSignature(_function) <-- "";
OMSignature(function_IsFunction) <--
[
  Local(makeSig);
  makeSig := {ConcatStrings, Type(function), "_"};
  Local(type);
  type := "";// If "function" doesn't have parameters, the signature is "f_".
  ForEach(arg, function)
  [
    If(Type(arg) = "List",
       type := "L",
       If(IsFunction(arg),
          type := "F",
          If(IsInteger(arg),
             type := "I",
             type := "V"
             )
          )
       );
    DestructiveAppend(makeSig, type);
  ];
  Secure(Eval(ListToFunction(makeSig)));
];
HoldArgumentNumber("OMSignature", 1, 1);



///////////////////////////////////////////////////////////////////////
// Input

// Troubleshooting guide:
// "encodingError:unexpected closing brace": this happens in the ReadOMOBJ
//      rules. It means that you forgot to call OMNextToken() from your rule.

LocalSymbols(omtoken) [
  OMNextToken() :=
  [
    omtoken := XmlExplodeTag(ToString(ReadToken()));
  ];
  OMToken() := omtoken;
]; // LocalSymbols(omtoken)

OMRead():=
[
  Local(result);
  ExceptionCatch(
  [
    XmlTokenizer();
    OMNextToken();
    result := MatchOMOBJ(OMToken());
    DefaultTokenizer();
  ],
  [
    result := OMGetCoreError();
    DefaultTokenizer();
  ]);
  result;
];


OMDump(str):=
PipeFromString(str:" EndOfFile")
[
  Local(result);
  XmlTokenizer();
  OMNextToken();
  While(OMToken() != "EndOfFile")
  [
    Echo("Exploded ",OMToken());
    OMNextToken();
  ];
  DefaultTokenizer();
  True;
];



10 # MatchClose(_x)_(x = OMToken()) <-- [OMNextToken();True;];
20 # MatchClose(_x) <-- Check(False, "Syntax", PipeToString()Echo("encodingError:unexpected closing brace")); //@@@ TODO better error reporting

10 # MatchOMOBJ(XmlTag("OMOBJ",_attributes,"Open")) <--
[
  // Any attributes are ignored.
  Local(result);
  OMNextToken();
  result := ReadOMOBJ(OMToken());
  MatchClose(XmlTag("OMOBJ",{},"Close"));
  result;
];
10 # MatchOMOBJ(XmlTag("OMOBJ",_attributes,"OpenClose")) <--
[
  OMNextToken();
  // Any attributes are ignored.
  // This is a void expression, of the form "".
  Empty;
];
20 # MatchOMOBJ(_rest) <-- Check(False, "Type", PipeToString()Echo("encodingError:not an OMOBJ :",rest));

10 # ReadOMOBJ(XmlTag("OMOBJ",_attributes,"Close")) <--
[
  // This is a void expression, of the form "".
  Empty;
];

10 # ReadOMOBJ(XmlTag("OMI",{},"Open")) <--
[
  Local(result);
  OMNextToken();
  result := ToAtom(OMToken());
  OMNextToken();
  MatchClose(XmlTag("OMI",{},"Close"));
  result;
];

10 # ReadOMOBJ(XmlTag("OMV",{{"NAME",_name}},"OpenClose")) <--
[
  OMNextToken();
  ToAtom(name);
];

10 # ReadOMOBJ(XmlTag("OMF",{{"DEC",_dec}},"OpenClose")) <--
[
  OMNextToken();
  ToAtom(dec);
];

10 # ReadOMOBJ(XmlTag("OMSTR",{},"Open")) <--
[
  Local(result);
  OMNextToken();
  If(IsString(OMToken()), [result := OMToken(); OMNextToken();], result := "");
  MatchClose(XmlTag("OMSTR",{},"Close"));
  result;
];
10 # ReadOMOBJ(XmlTag("OMSTR",{},"OpenClose")) <--
[
  OMNextToken();
  "";
];

10 # ReadOMOBJ(XmlTag("OMA",{},"Open")) <--
[
  Local(result, new);
  result:={};
  OMNextToken();
  While (OMToken() != XmlTag("OMA",{},"Close"))
  [
    new:=ReadOMOBJ(OMToken());
    DestructiveAppend(result,new);
  ];
  MatchClose(XmlTag("OMA",{},"Close"));
  OMApplyReverseMapping(ListToFunction(result));
];

10 # ReadOMOBJ(XmlTag("OMBIND",{},"Open")) <--
[
  Local(result, new);
  result:={};
  OMNextToken();
  While (OMToken() != XmlTag("OMBIND",{},"Close"))
  [
    new:=ReadOMOBJ(OMToken());
    DestructiveAppend(result,new);
  ];
  MatchClose(XmlTag("OMBIND",{},"Close"));
  result;
];
10 # ReadOMOBJ(XmlTag("OMBVAR",{},"Open")) <--
[
  Local(result, new);
  result:={};
  OMNextToken();
  While (OMToken() != XmlTag("OMBVAR",{},"Close"))
  [
    new:=ReadOMOBJ(OMToken());
    DestructiveAppend(result,new);
  ];
  MatchClose(XmlTag("OMBVAR",{},"Close"));
  result;
];

10 # OMApplyReverseMapping(piperExp_IsFunction) <-- piperExp;
10 # OMApplyReverseMapping(piperExp_IsFunction)_(OMSymbol()[ Type(piperExp) ] != Empty)
     <--
     [
     Local(symbolDef, result);
     symbolDef := OMSymbol()[ Type(piperExp) ];
     If(symbolDef[4] = {},
        result := piperExp,
        [
          result := OMApplyMapping(piperExp, symbolDef[4]);
          result := Subst($, piperExp[0]) result;
          If(IsList(result), result := ListToFunction(result));
        ]
       );
     result;
     ];

10 # OMApplyMapping(_function, _mapping) <--
[
  Local(expandRules, result);
  expandRules := { _(_path) <- OMPathSelect(path, function) };
  expandRules[1][2][2] := function;// the "function" variable is not expanded above.

  mapping := (mapping /: expandRules);// "/:" has lower precedence than ":=".

  Local(ruleMatched);
  ruleMatched := False;
  If(Type(mapping) = "|",
     [
     mapping := Flatten(mapping, "|");
     ForEach(rule, mapping)
       If(Not ruleMatched,
          [
          If(Type(rule) = "_",
             If( Eval(rule[2]), [ result := rule[1]; ruleMatched := True; ] ),
             [ result := rule; ruleMatched := True; ]
            );
          ]
         );
     ],
     [
     If(Type(mapping) = "_",
        If(Eval(mapping[2]),
           result := mapping[1],
           result := FunctionToList(function)
          ),
	result := mapping
       );
     ruleMatched := True;
     ]
    );

  If(ruleMatched,
     If(Type(result) = ":",
        If(Length(result) = 2,
           result[1]:result[2],
           result),// Perhaps we should give a warning here.
        result),
     Empty);
];

11 # OMPathSelect(path_IsNumber, _expression) <--
[
  If(path >= 0 And path <= Length(expression),
     expression[path],
     Undefined);
];
11 # OMPathSelect(path_IsList, _expression) <--
[
  ForEach(i, path)
    If(IsFunction(expression) And i >= 0 And i <= Length(expression),
       expression := expression[i],
       Undefined);
  expression;
];
HoldArgumentNumber("OMPathSelect", 2, 2);

// Previously, any unknown symbols where reported as errors.
// Now, we just store them as OMS(cd, name) since MathPiper is perfectly happy
// with such unknown symbols, and will handle them right: When
// producing an OpenMath result from them, they will be output back
// unmodified, forming a valid OpenMath expression.
// This way we don't have to bother defining bogus symbols for concepts that
// MathPiper does not handle.
100 # ReadOMOBJ(XmlTag("OMS", _attributes, "OpenClose")) <--
[
  OMNextToken();
  Local(omcd, omname);
  omcd   := attributes["CD"];
  omname := attributes["NAME"];
  If(omcd = Empty Or omname = Empty,
     OMCheck(False, "Argument", OMError({"moreerrors", "encodingError"}, PipeToString()Echo("missing \"cd\" or \"name\" attribute: ",attributes))),
     [
     Local(cdTable, piperform);
     cdTable := OMSymbolReverse()[ omcd ];
     If(cdTable != Empty, piperform := cdTable[ omname ]);
     // We can not optimize here by checking first whether the CD is mathpiper
     // and avoiding the table lookup then, because for some symbols the
     // OM name have to be different from the MathPiper name (e.g. "/@").
     If(piperform = Empty,
        If(cd = mathpiper, ToAtom(omname), OMS(omcd, omname)),
        If(IsString(piperform), ToAtom(piperform), piperform));
     ]
    );
];

101 # ReadOMOBJ(_rest) <-- OMCheck(False, "Unimplemented", OMError({"moreerrors", "encodingError"}, PipeToString()Echo("unhandled tag: ",rest)));



///////////////////////////////////////////////////////////////////////
// Error reporting

Macro(OMCheck,{predicate,error})
[
  If(Not(@predicate),
  [
    Assert("omErrorObject", @error) False;
    Check(False, "Undefined", "omErrorObject");
  ]
  ,
  True);
];



OMGetCoreError():=
[
  Local(result);
  result := ExceptionGet(); //todo:tk:verify that ExceptionCheck works properly with the soft error handling functions.
  If(result != False,
     If( IsError("omErrorObject"),
        [result := GetError("omErrorObject");                     ],
        [result := OMError({"moreerrors", "unexpected"}, result); ])
    );
  result;
];



///////////////////////////////////////////////////////////////////////
// Symbol mapping tables

LocalSymbols(omsymbol, omsymbolreverse) [
  // Initialization of the openmath symbol dictionaries
  omsymbol := {};
  omsymbolreverse := {};

  // Access to the dictionaries
  OMSymbol() := omsymbol;
  OMSymbolReverse() := omsymbolreverse;

]; // LocalSymbols(omsymbol, omsymbolreverse)

OMDef(_piperform, omcd_IsString, omname_IsString, _directMapping, _reverseMapping) <--
[
  Local(cdTable);
  If(IsString(piperform),
     OMSymbol()[ piperform ] := {omcd, omname, directMapping, reverseMapping}
     );
  cdTable := OMSymbolReverse()[ omcd ];
  If(cdTable = Empty,
     OMSymbolReverse()[ omcd ] := {{omname, piperform}},
     [
       Local(oldMathPiperform);
       oldMathPiperform := cdTable[ omname ];
       If(oldMathPiperform = Empty,
          cdTable[ omname ] := piperform,
          [
          If(oldMathPiperform != piperform,
             [
             cdTable[ omname ] := piperform;
             Echo("Warning: the mapping for ", omcd, ":", omname,
                  " was already defined as ", oldMathPiperform,
                  ", but is redefined now as ", piperform
                  );
             ]
            );
          ]
         );
      ]
     );
  True;
];

OMDef(_piperform, omcd_IsString, omname_IsString)
<-- OMDef(piperform, omcd, omname, {}, {});

OMDef(piperalias_IsString, pipername_IsString) <--
[
  OMSymbol()[ piperalias ] := OMSymbol()[ pipername ];
];
HoldArgumentNumber("OMDef", 5, 4);
HoldArgumentNumber("OMDef", 5, 5);

// Many objects, such as matrices and sets, do not have a specific
// encoding in MathPiper, but are represented as lists.
OMDef( {},     "set1","emptyset" );
OMDef( "List", "set1","set"      );
OMDef( "List", "linalg2","matrix"    );
OMDef( "List", "linalg2","matrixrow" );
OMDef( "List", "linalg2","vector"    );
OMDef( "List", "list1","list" );

// [20010916 AGP] I couldn't find these symbols in the def files:
//     "E"        ,  "nums1", "e"
//     "Gamma"    ,  "nums1", "gamma"
OMDef( "Infinity" ,  "nums1", "infinity" );
OMDef( "Undefined",  "nums1", "NaN"      );
// [20010916 AGP] From initialization.rep/stdopers.mpi:
OMDef( "And"   ,  "logic1", "and"        );
OMDef( "=="    ,  "logic1", "equivalent" );
OMDef( "!=="   ,  "logic1", "not",
                { "",
                  1,
                  2,
                  ""
                }
      );
OMDef( "False",  "logic1", "false" );
OMDef( "Or"   ,  "logic1", "or"    );
OMDef( "True" ,  "logic1", "true"  );
//[20010916 AGP ] Xor is not available in MathPiper.
//     "Xor"  ,  "logic1", "xor"   );
OMDef( "&" ,  mathpiper, "bitwise_and" );
OMDef( "|" ,  mathpiper, "bitwise_or"  );
OMDef( "%" ,  mathpiper, "bitwise_xor" );
OMDef( "/" , "arith1", "divide");// This definition is for OM arith1:divide to MathPiper. In all other cases, the next one will be used.
OMDef( "/" , "nums1", "rational", {$, _1, _2}_(IsRational(_1/_2)) | {OMS("arith1", "divide"), _1, _2}, {/, _1, _2});
OMDef( "-" ,  "arith1", "unary_minus");
OMDef( "-" ,  "arith1", "minus"  );// We need a way of testing the arity.
OMDef( "+" ,  "arith1", "plus"   );
OMDef( "^" ,  "arith1", "power"  );
OMDef( "*" ,  "arith1", "times"  );


LoadScriptOnce("constants.rep/om.mpi");
LoadScriptOnce("stdfuncs.rep/om.mpi");
LoadScriptOnce("stubs.rep/om.mpi");
LoadScriptOnce("logic.rep/om.mpi");
LoadScriptOnce("complex.rep/om.mpi");
LoadScriptOnce("integrate.rep/om.mpi");
LoadScriptOnce("sums.rep/om.mpi");
LoadScriptOnce("limit.rep/om.mpi");
//LoadScriptOnce("numbers.rep/om.mpi");// Sqrt is loaded before (stubs.rep) than IntNthRoot.
LoadScriptOnce("functional.rep/om.mpi");


%/mathpiper



%mathpiper_docs,name="OMForm;OMRead",categories="User Functions;Input/Output"
*CMD OMForm --- convert MathPiper expression to OpenMath
*CMD OMRead --- convert expression from OpenMath to MathPiper expression
*STD
*CALL
	OMForm(expression)
	OMRead()

*PARMS

{expression} -- expression to convert

*DESC

{OMForm} prints an OpenMath representation of the input parameter {expression}
to standard output. {OMRead} reads an OpenMath expression from standard
input and returns a normal MathPiper expression that matches the input OpenMath
expression.

If a MathPiper symbol does not have a mapping defined by {OMDef}, it is translated
to and from OpenMath as the OpenMath symbol in the CD "mathpiper" with the same
name as it has in MathPiper.

*E.G. notest

In> str:=PipeToString()OMForm(2+Sin(a*3))
Result: "
	  
	    
	    2
	    
	      
	      
	        
	        
	        3
	      
	    
	  
	
	";
In> PipeFromString(str)OMRead()
Result: 2+Sin(a*3);

In> OMForm(NotDefinedInOpenMath(2+3))
	
	  
	    
	    
	      
	      2
	      3
	    
	  
	
Result: True

*SEE XmlTokenizer, XmlExplodeTag, OMDef
%/mathpiper_docs



%mathpiper_docs,name="OMDef",categories="User Functions;Input/Output"
*CMD OMDef --- define translations from MathPiper to OpenMath and vice-versa.
*STD
*CALL
	OMDef(mathpiperForm, cd, name)
	OMDef(mathpiperForm, cd, name, mathpiperToOM)
	OMDef(mathpiperForm, cd, name, mathpiperToOM, omToMathPiper)

*PARMS

{mathpiperForm} -- string with the name of a MathPiper symbol, or a MathPiper expression

{cd} -- OpenMath Content Dictionary for the symbol

{name} -- OpenMath name for the symbol

{mathpiperToOM} -- rule for translating an application of that symbol in MathPiper into an OpenMath expression

{omToMathPiper} -- rule for translating an OpenMath expression into an application of this symbol in MathPiper

*DESC

{OMDef} defines the translation rules for symbols between the MathPiper
representation and {OpenMath}.
The first parameter, {mathpiperForm}, can be a string or an expression. The
difference is that when giving an expression only the {omToMathPiper} translation
is defined, and it uses the exact expression given. This is used for {OpenMath}
symbols that must be translated into a whole subexpression in MathPiper, such
as {set1:emptyset} which gets translated to an empty list as follows:
In> OMDef( {}, "set1","emptyset" )
Result: True
In> PipeFromString(" ")OMRead()
Result: {}
In> IsList(%)
Result: True
Otherwise, a symbol that is not inside an application (OMA) gets translated to
the MathPiper atom with the given name:
In> OMDef( "EmptySet", "set1","emptyset" )
	Warning: the mapping for set1:emptyset was already defined as {} , but is redefined now as EmptySet
Result: True
In> PipeFromString(" ")OMRead()
Result: EmptySet

The definitions for the symbols in the MathPiper
library are in the {*.rep} script subdirectories. In those modules for which
the mappings are defined, there is a file called {om.ys} that contains the
{OMDef} calls. Those files are loaded in {openmath.rep/om.ys}, so any new
file must be added to the list there, at the end of the file.

A rule is represented as a list of expressions. Since both OM and
MathPiper expressions are actually lists, the syntax is the same in both
directions. There are two template forms that are expanded before the
translation:

*	{$}: this symbol stands for the translation of the symbol applied
in the original expression.

*	{_path}: a path into the original expression (list) to extract an
element, written as an underscore applied to an integer or a list of integers.
  Those integers are indexes into expressions, and integers in a list are
  applied recursively starting at the original expression.
  For example, {_2} means the second parameter of the expression, while
  {_{3,2,1}} means the first parameter of the second parameter of the third
  parameter of the original expression.

They can appear anywhere in the rule as expressions or subexpressions.

Finally, several alternative rules can be specified by joining them with
the {|} symbol, and each of them can be annotated with a post-predicate
applied with the underscore {_} symbol, in the style of MathPiper' simplification
rules. Only the first alternative rule that matches is applied, so the more
specific rules must be written first.

There are special symbols recognized by {OMForm} to output {OpenMath}
constructs that have no specific parallel in MathPiper, such as an OpenMath
symbol having a {CD} and {name}: MathPiper symbols have only a name.
Those special symbols are:

*	{OMS(cd, name)}: {}
*	{OMA(f x y ...)}: {f x y ...}
*	{OMBIND(binderSymbol, bvars, expression)}: {binderSymbol bvars expression}, where {bvars} must be produced by using {OMBVAR(...)}.
*	{OMBVAR(x y ...)}: {x y ...}
*	{OME(...)}: {...}

When translating from OpenMath to MathPiper, we just store unknown symbols as
{OMS("cd", "name")}. This way we don't have to bother defining bogus symbols
for concepts that MathPiper does not handle, and we can evaluate expressions that
contain them.

*E.G. notest

In> OMDef( "Sqrt" ,  "arith1", "root", { $, _1, 2 }, $(_1)_(_2=2) | (_1^(1/_2)) );
Result: True
In> OMForm(Sqrt(3))
	
	  
	    
	    3
	    2
	  
	
Result: True
In> PipeFromString("162 ")OMRead()
Result: Sqrt(16)
In> PipeFromString("163 ")OMRead()
Result: 16^(1/3)

In> OMDef("Limit", "limit1", "limit", \
	      {  $, _2, OMS("limit1", "under"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Left)  \
	      |{ $, _2, OMS("limit1", "above"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Right) \
	      |{ $, _2, OMS("limit1", "both_sides"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _3) },      \
	      { $, _{3,2,1}, _1, Left,  _{3,3}}_(_2=OMS("limit1", "below")) \
	      |{$, _{3,2,1}, _1, Right, _{3,3}}_(_2=OMS("limit1", "above")) \
	      |{$, _{3,2,1}, _1, _{3,3}}                                    \
	     );
In> OMForm(Limit(x,0) Sin(x)/x)
	
	  
	    
	    0
	    
	    
	      
	      
	        
	      
	      
	        
	        
	          
	          
	        
	        
	      
	    
	  
	
Result: True
In> OMForm(Limit(x,0,Right) 1/x)
	
	  
	    
	    0
	    
	    
	      
	      
	        
	      
	      
	        
	        1
	        
	      
	    
	  
	
Result: True
In> PipeFromString(PipeToString()OMForm(Limit(x,0,Right) 1/x))OMRead()
Result: Limit(x,0,Right)1/x
In> %
Result: Infinity

*SEE OMForm, OMRead
%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/0000755000175000017500000000000011722677334025134 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpExpand.mpw0000644000175000017500000000041511371733712027722 0ustar  giovannigiovanni%mathpiper,def="SimpExpand"

10 # SimpExpand(SimpAdd(_x,_y)) <-- SimpExpand(x) + SimpExpand(y);
10 # SimpExpand(SimpMul(_x,_y)) <-- SimpExpand(x) * SimpExpand(y);
10 # SimpExpand(SimpDiv(_x,_y)) <-- SimpExpand(x) / SimpExpand(y);
20 # SimpExpand(_x) <-- x;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/ExpandFrac.mpw0000644000175000017500000000106711320716335027665 0ustar  giovannigiovanni%mathpiper,def="ExpandFrac"

//////////////////////////////////////////////////
/// ExpandFrac --- normalize rational functions (no simplification)
//////////////////////////////////////////////////

5 # ExpandFrac(expr_IsList) <-- MapSingle("ExpandFrac", expr);

// expression does not contain fractions
10 # ExpandFrac(_expr)_Not(HasFuncSome(expr, "/", {ToAtom("+"), ToAtom("-"), *, /, ^})) <-- expr;
15 # ExpandFrac(a_IsRationalOrNumber) <-- a;
20 # ExpandFrac(_expr) <-- ExpandFrac'combine(GetNumerDenom(expr));

ExpandFrac'combine({_a, _b}) <-- a/b;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpDiv.mpw0000644000175000017500000000010111371733712027215 0ustar  giovannigiovanni%mathpiper,def="SimpDiv"

Rulebase("SimpDiv",{x,y});

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/Flatten.mpw0000644000175000017500000000173211523200452027237 0ustar  giovannigiovanni%mathpiper,def="Flatten"

Rulebase("DoFlatten",{doflattenx});
UnFence("DoFlatten",1);

10 # DoFlatten(_doflattenx)_(Type(doflattenx)=flattenoper) <--
     Apply("Concat",MapSingle("DoFlatten",Rest(FunctionToList(doflattenx))));
20 # DoFlatten(_doflattenx) <-- { doflattenx };


Function("Flatten",{body,flattenoper})
[
  DoFlatten(body);
];

%/mathpiper



%mathpiper_docs,name="Flatten",categories="User Functions;Lists (Operations)"
*CMD Flatten --- flatten expression w.r.t. some operator
*STD
*CALL
	Flatten(expression,operator)

*PARMS

{expression} -- an expression

{operator} -- string with the contents of an infix operator.

*DESC

Flatten flattens an expression with respect to a specific
operator, converting the result into a list.
This is useful for unnesting an expression. Flatten is typically
used in simple simplification schemes.

*E.G.

In> Flatten(a+b*c+d,"+");
Result: {a,b*c,d};
In> Flatten({a,{b,c},d},"List");
Result: {a,b,c,d};

*SEE UnFlatten
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/ExpandBrackets.mpw0000644000175000017500000000406111552343672030554 0ustar  giovannigiovanni%mathpiper,def="ExpandBrackets"

LocalSymbols(AssembleTerms, AssembleTermsRecursive)
[

    AssembleTerms(list) :=
    [
        Check(IsList(list), "Argument", "The argument must be a list.");

        If(Length(list) = 1, 
            First(list),
            AssembleTermsRecursive(Reverse(list)) 
        );
    ];


    AssembleTermsRecursive(list) :=
    [
        If(Type(list[1]) = "-" Or IsNegativeNumber(list[1]) Or Type(list[1]) = "/" And (Type(Numerator(list[1])) = "-" Or IsNegativeNumber(Numerator(list[1]))),
            If(Length(list) = 2,
                ListToFunction({ToAtom("-"), list[2], -list[1]} ),
                ListToFunction({ToAtom("-"), AssembleTermsRecursive(Rest(list)), -First(list)} )
            ),
            If(Length(list) = 2,
                ListToFunction({ToAtom("+"), list[2], list[1]} ),
                ListToFunction({ToAtom("+"), AssembleTermsRecursive(Rest(list)), First(list)} )
            )
        );
    ];


10 # ExpandBrackets(xx_IsZero) <-- 0;

20 # ExpandBrackets(_xx)_(Type(xx)="/" Or Type(-xx)="/") <-- 
[
    Local(N,D,t);
    N := ReassembleListTerms(DisassembleExpression(Numerator(xx)));
    D := ExpandBrackets(Denominator(xx));
    AssembleTerms(MapSingle({{t}, t / D}, N));
];


30 # ExpandBrackets(_xx) <-- AssembleTerms(ReassembleListTerms(DisassembleExpression(xx)));

];



//ExpandBrackets(_xx) <-- SimpExpand(SimpImplode(SimpFlatten(xx)));
//ExpandBrackets(x) := NormalForm(MM(x));

%/mathpiper


    



%mathpiper_docs,name="ExpandBrackets",categories="User Functions;Polynomials (Operations)"
*CMD ExpandBrackets --- expand all brackets
*STD
*CALL
	ExpandBrackets(expr)

*PARMS

{expr} -- an expression

*DESC

This command tries to expand all the brackets by repeatedly using the
distributive laws $a * (b+c) = a*b + a*c$ and $(a+b) * c = a*c + b*c$.
It goes further than {Expand}, in that it expands all brackets.

*E.G.

In> Expand((a-x)*(b-x),x)
Result: x^2-(b+a)*x+a*b;
In> Expand((a-x)*(b-x),{x,a,b})
Result: x^2-(b+a)*x+b*a;
In> ExpandBrackets((a-x)*(b-x))
Result: a*b-x*b+x^2-a*x;

*SEE Expand
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpMul.mpw0000644000175000017500000000010111371733712027230 0ustar  giovannigiovanni%mathpiper,def="SimpMul"

Rulebase("SimpMul",{x,y});

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/factorial/0000755000175000017500000000000011722677334027100 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/factorial/FactorialSimplify.mpw0000644000175000017500000002012311523200452033222 0ustar  giovannigiovanni%mathpiper,def="FactorialSimplify"


/* FactorialSimplify algorithm:
   1) expand binomials into factors
   2) expand brackets as much as possible
   3) for the remaining rational expressions x/y,
      take all the factors of x and y, and match them
      up one by one to determine if they can be
      factored out. The algorithm will look at expressions like x^n/x^m
      where (n-m) is an integer, or at expressions x!/y! where (x-y)
      is an integer. The routine CommonDivisors does these steps, and
      returns the new numerator and denominator factor.
  FactorialSimplifyWorker does the actual O(n^2) algorithm of
  matching all terms up.
*/

FactorialNormalForm(x):=
[
  // Substitute binomials
  x:=(x/:{BinomialCoefficient(_n,_m)<- (n!)/((m!)*(n-m)!)});
  // Expand expression as much as possible so that the terms become
  // simple rationals.

  x:=(
      x/::Hold({
          (_a/_b)/_c <- (a)/(b*c),
          (-(_a/_b))/_c <- (-a)/(b*c),
          (_a/_b)*_c <- (a*c)/b,
          (_a*_b)^_m <- a^m*b^m,
          (_a/_b)^_m*_c <- (a^m*c)/b^m,
          _a*(_b+_c) <- a*b+a*c,
          (_b+_c)*_a <- a*b+a*c,
          (_b+_c)/_a <- b/a+c/a,
          _a*(_b-_c) <- a*b-a*c,
          (_b-_c)*_a <- a*b-a*c,
          (_b-_c)/_a <- b/a-c/a
     }));
  x;
];

FactorialSimplify(x):=
[
  x := FactorialNormalForm(x);
  FactorialSimplifyWorker(x);
];


/* CommonDivisors takes two parameters x and y as input, determines a common divisor g
   and then returns {x/g,y/g,g}.
 */
10 # CommonDivisors(_x^(_n),_x^(_m)) <-- {x^Simplify(n-m),1,x^m};
10 # CommonDivisors(_x^(_n),_x)  <-- {x^Simplify(n-1),1,x};
10 # CommonDivisors(_x,_x^(_m)) <-- {x^Simplify(1-m),1,x^m};
10 # CommonDivisors((_x) !,_x) <-- {(x-1)!,1,x};
10 # CommonDivisors(_x,_x) <-- {1,1,x};
10 # CommonDivisors(- _x,_x) <-- {-1,1,x};
10 # CommonDivisors(_x,- _x) <-- {1,-1,x};
10 # CommonDivisors((_x),(_x)!) <-- {1,(x-1)!,x};
10 # CommonDivisors((_x)!, (_y)!)_IsInteger(Simplify(x-y))  <-- CommonFact(Simplify(x-y),y);


10 # CommonDivisors((_x)! ^ _m, (_y)! ^ _m)_IsInteger(Simplify(x-y))  <-- CommonFact(Simplify(x-y),y)^m;

10 # CommonFact(dist_IsNegativeInteger,_y)
   <-- {1,Product(i,1,-dist,Simplify(y+i+dist)),Simplify(y+dist)!};
11 # CommonFact(_dist,_y)
   <-- {Product(i,1,dist,Simplify(y+i)),1,Simplify(y)!};
60000 # CommonDivisors(_x,_y) <-- {x,y,1};

10 # CommonFactors((_x)!,_y)_(Simplify(y-x) = 1) <-- {y!,1};
10 # CommonFactors((_x)!,_y)_(Simplify((-y)-x) = 1) <-- {(-y)!,-1};

10 # CommonFactors(_x^_n,_x^_m) <-- {x^Simplify(n+m),1};
10 # CommonFactors(_x^_n,_x) <-- {x^Simplify(n+1),1};

60000 # CommonFactors(_x,_y) <-- {x,y};

10 # FactorialSimplifyWorker(_x+_y) <-- FactorialSimplifyWorker(x)+FactorialSimplifyWorker(y);
10 # FactorialSimplifyWorker(_x-_y) <-- FactorialSimplifyWorker(x)-FactorialSimplifyWorker(y);
10 # FactorialSimplifyWorker(  -_y) <--                     -FactorialSimplifyWorker(y);

LocalSymbols(x,y,i,j,n,d)[

20 # FactorialSimplifyWorker(_x/_y) <--
[
  // first separate out factors of the denominator
  Local(numerCommon,numerTerms);
  {numerCommon,numerTerms}:=FactorialGroupCommonDivisors(x);
  Local(denomCommon,denomTerms);
  {denomCommon,denomTerms}:=FactorialGroupCommonDivisors(y);
  Local(n,d,c);
  {n,d,c} := FactorialDivideTerms(numerCommon,denomCommon);
  (n/d)*Simplify((numerTerms)/(denomTerms));
];



20 # FactorialGcd(_x,_y) <--
[
  // first separate out factors of the denominator
  Local(numerCommon,numerTerms);
  {numerCommon,numerTerms}:=FactorialGroupCommonDivisors(x);
  Local(denomCommon,denomTerms);
  {denomCommon,denomTerms}:=FactorialGroupCommonDivisors(y);
  Local(n,d,c);
  {n,d,c} := FactorialDivideTerms(numerCommon,denomCommon);
  c;
];





10 # FactorialDivideTerms(- _x,- _y) <-- FactorialDivideTermsAux(x,y);
LocalSymbols(n,d,c)
[
  20 # FactorialDivideTerms(- _x,  _y)
    <--
    [
      Local(n,d,c);
      {n,d,c} := FactorialDivideTermsAux(x,y);
      {-n,d,c};
    ];
  30 # FactorialDivideTerms(  _x,- _y)
    <--
    [
      Local(n,d,c);
      {n,d,c} := FactorialDivideTermsAux(x,y);
      {n,-d,c};
    ];
];
40 # FactorialDivideTerms(  _x,  _y)
   <--
   [
//     Echo("GOTHERE 40");
     FactorialDivideTermsAux(x,y);
   ];

LocalSymbols(n,d,c)
[
  10 # FactorialDivideTermsAux(_x,_y) <--
  [
    x:=Flatten(x,"*");
    y:=Flatten(y,"*");

    Local(i,j,common);
    common:=1;
    For(i:=1,i<=Length(x),i++)
    For(j:=1,j<=Length(y),j++)
    [
      Local(n,d,c);
//Echo("inp is ",x[i]," ",y[j]);
      {n,d,c} := CommonDivisors(x[i],y[j]);

//Echo("aux is ",{n,d,c});
      x[i] := n;
      y[j] := d;
      common:=common*c;
    ];
//Echo("final ",{x,y,common});
//Echo("finalor ",{Product(x),Product(y),common});
    {Product(x),Product(y),common};
  ];
];

];

60000 # FactorialSimplifyWorker(_x)
      <--
      [
  // first separate out factors of the denominator
  Local(numerCommon,numerTerms);
  {numerCommon,numerTerms}:=FactorialGroupCommonDivisors(x);
  numerCommon*numerTerms;
      ];

/* FactorialFlattenAddition accepts an expression of form a+b+c-d+e-f+ ... +z with arbitrary additions
   and subtractions, and converts it to a list of terms. Terms that need to be subtracted start with a
   negation sign (useful for pattern matching).
 */
10 # FactorialFlattenAddition(_x+_y) <-- Concat(FactorialFlattenAddition(x), FactorialFlattenAddition(y));
10 # FactorialFlattenAddition(_x-_y) <-- Concat(FactorialFlattenAddition(x),-FactorialFlattenAddition(y));
10 # FactorialFlattenAddition(  -_y) <--                           -FactorialFlattenAddition(y);
20 # FactorialFlattenAddition(_x   ) <--                           {x};

LocalSymbols(n,d,c)
[
  10 # FactorialGroupCommonDivisors(_x) <--
  [
    Local(terms,common,tail);
    terms:=FactorialFlattenAddition(x);
//Echo("terms is ",terms);
    common := First(terms);
    tail:=Rest(terms);
    While (tail != {})
    [
      Local(n,d,c);
      {n,d,c} := FactorialDivideTerms(common,First(tail));

//Echo(common, " ",First(tail)," ",c);
      common := c;
      tail:=Rest(tail);
    ];
    Local(i,j);

//  Echo("common is ",common);

    For(j:=1,j<=Length(terms),j++)
    [
      Local(n,d,c);
//  Echo("IN = ",terms[j]," ",common);
//  Echo("n = ",n);
      {n,d,c} := FactorialDivideTerms(terms[j],common);
//  Echo("n = ",n);
//  Echo("{n,d,c} = ",{n,d,c});
      Check(d = 1, "Math",
        PipeToString()[
        Echo("FactorialGroupCommonDivisors failure 1 : ",d);
        ]);
/*
      Check(Simplify(c-common) = 0, "Math",
        PipeToString()
        [
          Echo("FactorialGroupCommonDivisors failure 2 : ");
          Echo(c," ",common);
          Echo(Simplify(c-common));
        ]);
*/
      terms[j] := n;
    ];
    terms:=Add(terms);

    common:=Flatten(common,"*");
    For(j:=1,j<=Length(common),j++)
    [
      Local(f1,f2);
      {f1,f2}:=CommonFactors(common[j],terms);
      common[j]:=f1;
      terms:=f2;

      For(i:=1,i<=Length(common),i++)
      If(i != j,
        [
          {f1,f2}:=CommonFactors(common[j],common[i]);
          common[j]:=f1;
          common[i]:=f2;
        ]);
    ];
    common := Product(common);
    {common,terms};
  ];
];



%/mathpiper



%mathpiper_docs,name="FactorialSimplify",categories="User Functions;Expression Simplification"
*CMD FactorialSimplify --- Simplify hypergeometric expressions containing factorials
*STD
*CALL
	FactorialSimplify(expression)

*PARMS

{expression} -- expression to simplify

*DESC

{FactorialSimplify} takes an expression that may contain factorials,
and tries to simplify it. An expression like $ (n+1)! / n! $ would
simplify to $(n+1)$. 

The following steps are taken to simplify:

*	1. binomials are expanded into factorials
*	2. the expression is flattened as much as possible, to reduce it to a sum of simple rational terms
*	3. expressions like $ p^n/p^m $ are reduced to $p^(n-m)$ if $n-m$ is an integer
*	4. expressions like $ n! / m! $ are simplified if $n-m$ is an integer

The function {Simplify} is used to determine if the relevant expressions $n-m$
are integers.

*E.G.

In> FactorialSimplify( (n-k+1)! / (n-k)! )
Result: n+1-k
In> FactorialSimplify(n! / BinomialCoefficient(n,k))
Result: k! *(n-k)!
In> FactorialSimplify(2^(n+1)/2^n)
Result: 2

*SEE Simplify, !, BinomialCoefficient
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/Simplify.mpw0000644000175000017500000000306511530137240027441 0ustar  giovannigiovanni%mathpiper,def="Simplify"

//Retract("Simplify",*);

10 # Simplify(expr_IsList) <-- MapSingle("Simplify",expr);

15 # Simplify(Complex(_r,_i)) <-- Complex(Simplify(r),Simplify(i));

20 # Simplify((_xex) == (_yex)) <-- (Simplify(xex-yex) == 0);

20 # Simplify((_xex) > (_yex)) <-- (Simplify(xex-yex) > 0);
20 # Simplify((_xex) < (_yex)) <-- (Simplify(xex-yex) < 0);
20 # Simplify((_xex) >= (_yex)) <-- (Simplify(xex-yex) >= 0);
20 # Simplify((_xex) <= (_yex)) <-- (Simplify(xex-yex) <= 0);
20 # Simplify((_xex) !== (_yex)) <-- (Simplify(xex-yex) !== 0);

// conditionals
25 # Simplify(if (_a) _b) <-- "if" @ {Simplify(a), Simplify(b)};
25 # Simplify(_a else _b) <-- "else" @ {Simplify(a), Simplify(b)};

// otherwise
40 # Simplify(_expr)_(Type(expr)="Ln") <--
[
    //If(InVerboseMode(),Tell("Simplify_Ln",expr));
    LnCombine(expr);
];

40 # Simplify(_expr)_(Type(expr)="Exp") <--
[
    //If(InVerboseMode(),Tell("Simplify_Exp",expr));
    expr;
];

50 # Simplify(_expr) <-- 
[
    //If(InVerboseMode(),Tell("Simplify_other",expr));
    MultiSimp(Eval(expr));
];

%/mathpiper



%mathpiper_docs,name="Simplify",categories="User Functions;Expression Simplification"
*CMD Simplify --- try to simplify an expression
*STD
*CALL
	Simplify(expr)

*PARMS

{expr} -- expression to simplify

*DESC

This function tries to simplify the expression {expr} as much
as possible. It does this by grouping powers within terms, and then
grouping similar terms.

*E.G.

In> a*b*a^2/b-a^3
Result: (b*a^3)/b-a^3;
In> Simplify(a*b*a^2/b-a^3)
Result: 0;

*SEE TrigSimpCombine, RadSimp, Combine
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpFlatten.mpw0000644000175000017500000000103411371733712030076 0ustar  giovannigiovanni%mathpiper,def="SimpFlatten"

10 # SimpFlatten((_x)+(_y)) <-- SimpAdd(SimpFlatten(x),SimpFlatten(y));
10 # SimpFlatten((_x)-(_y)) <-- SimpAdd(SimpFlatten(x),SimpMul(-1,SimpFlatten(y)));
10 # SimpFlatten(    -(_y)) <-- SimpMul(-1,SimpFlatten(y));

10 # SimpFlatten((_x)*(_y)) <-- SimpMul(SimpFlatten(x),SimpFlatten(y));
10 # SimpFlatten((_x)/(_y)) <-- SimpDiv(SimpFlatten(x),SimpFlatten(y));
10 # SimpFlatten((_x)^(n_IsPositiveInteger)) <--
     SimpMul(SimpFlatten(x),SimpFlatten(x^(n-1)));

100 # SimpFlatten(_x) <--
[
  x;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpImplode.mpw0000644000175000017500000000146311371733712030100 0ustar  giovannigiovanni%mathpiper,def="SimpImplode"

/* Distributed multiplication rule */
10 # SimpImplode(SimpMul(SimpAdd(_x,_y),_z)) <--
     SimpImplode(SimpAdd(SimpImplode(SimpMul(x,z)),
                 SimpImplode(SimpMul(y,z))));
10 # SimpImplode(SimpMul(_z,SimpAdd(_x,_y))) <--
     SimpImplode(SimpAdd(SimpImplode(SimpMul(z,x)),
                 SimpImplode(SimpMul(z,y))));
/* Distributed division rule  */
10 # SimpImplode(SimpDiv(SimpAdd(_x,_y),_z)) <--
     SimpImplode(SimpAdd(SimpImplode(SimpDiv(x,z)),
     SimpImplode(SimpDiv(y,z))));



20 # SimpImplode(SimpAdd(_x,_y)) <--
     SimpAdd(SimpImplode(x),SimpImplode(y));
20 # SimpImplode(SimpMul(_x,_y)) <--
     SimpMul(SimpImplode(x),SimpImplode(y));
20 # SimpImplode(SimpDiv(_x,_y)) <--
     SimpDiv(SimpImplode(x),SimpImplode(y));
30 # SimpImplode(_x) <-- x;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/SimpAdd.mpw0000644000175000017500000000010111371733712027163 0ustar  giovannigiovanni%mathpiper,def="SimpAdd"

Rulebase("SimpAdd",{x,y});

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/Eliminate.mpw0000644000175000017500000000151111523200452027544 0ustar  giovannigiovanni%mathpiper,def="Eliminate"

Eliminate(_var,_replace,_function) <-- Simplify(Subst(var,replace)function);

%/mathpiper



%mathpiper_docs,name="Eliminate",categories="User Functions;Solvers (Symbolic)"
*CMD Eliminate --- substitute and simplify
*STD
*CALL
	Eliminate(var, value, expr)

*PARMS

{var} -- variable (or subexpression) to substitute

{value} -- new value of "var"

{expr} -- expression in which the substitution should take place

*DESC

This function uses {Subst} to replace all instances
of the variable (or subexpression) "var" in the expression "expr"
with "value", calls {Simplify} to simplify the
resulting expression, and returns the result.

*E.G.

In> Subst(Cos(b), c) (Sin(a)+Cos(b)^2/c)
Result: Sin(a)+c^2/c;
In> Eliminate(Cos(b), c, Sin(a)+Cos(b)^2/c)
Result: Sin(a)+c;

*SEE SuchThat, Subst, Simplify
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/GetNumerDenom.mpw0000644000175000017500000000324211371733712030364 0ustar  giovannigiovanni%mathpiper,def="GetNumerDenom"

/// GetNumerDenom(x) returns a pair of expressions representing normalized numerator and denominator; GetNumerDenom(x, a) multiplies the numerator by the number a
GetNumerDenom(_expr, _a) <-- GetNumerDenom(expr)*{a,1};

// on expressions that are not fractions, we return unit denominator
10 # GetNumerDenom(_expr)_Not(HasFuncSome(expr, "/", {ToAtom("+"), ToAtom("-"), *, /, ^})) <-- {expr, 1};
// rational numbers are not simplified
15 # GetNumerDenom(a_IsRationalOrNumber) <-- {a, 1};
// arithmetic
20 # GetNumerDenom(_a + _b) <-- ExpandFrac'add(GetNumerDenom(a), GetNumerDenom(b));
20 # GetNumerDenom(_a - _b) <-- ExpandFrac'add(GetNumerDenom(a), GetNumerDenom(b, -1));
20 # GetNumerDenom(- _a) <-- GetNumerDenom(a, -1);
20 # GetNumerDenom(+ _a) <-- GetNumerDenom(a);
20 # GetNumerDenom(_a * _b) <-- ExpandFrac'multiply(GetNumerDenom(a), GetNumerDenom(b));
20 # GetNumerDenom(_a / _b) <-- ExpandFrac'divide(GetNumerDenom(a), GetNumerDenom(b));
// integer powers
20 # GetNumerDenom(_a ^ b_IsInteger)_(b > 1) <-- ExpandFrac'multiply(GetNumerDenom(a), GetNumerDenom(a^(b-1)));
20 # GetNumerDenom(_a ^ b_IsInteger)_(b < -1) <-- ExpandFrac'divide(GetNumerDenom(1), GetNumerDenom(a^(-b)));
20 # GetNumerDenom(_a ^ b_IsInteger)_(b = -1) <-- ExpandFrac'divide(GetNumerDenom(1), GetNumerDenom(a));
// non-integer powers are not considered to be rational functions
25 # GetNumerDenom(_a ^ _b) <-- {a^b, 1};

// arithmetic on fractions; not doing any simplification here, whereas we might want to
ExpandFrac'add({_a, _b}, {_c, _d}) <-- {a*d+b*c, b*d};
ExpandFrac'multiply({_a, _b}, {_c, _d}) <-- {a*c, b*d};
ExpandFrac'divide({_a, _b}, {_c, _d}) <-- {a*d, b*c};

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/UnFlatten.mpw0000644000175000017500000000172311523200452027542 0ustar  giovannigiovanni%mathpiper,def="UnFlatten"

10 # UnFlatten({},_op,_identity) <-- identity;
20 # UnFlatten(list_IsList,_op,_identity) <--
     Apply(op,{First(list),UnFlatten(Rest(list),op,identity)});

%/mathpiper



%mathpiper_docs,name="UnFlatten",categories="User Functions;Lists (Operations)"
*CMD UnFlatten --- inverse operation of Flatten
*STD
*CALL
	UnFlatten(list,operator,identity)

*PARMS

{list} -- list of objects the operator is to work on

{operator} -- infix operator

{identity} -- identity of the operator

*DESC

UnFlatten is the inverse operation of Flatten. Given
a list, it can be turned into an expression representing
for instance the addition of these elements by calling
UnFlatten with "+" as argument to operator, and 0 as
argument to identity (0 is the identity for addition, since
a+0=a). For multiplication the identity element would be 1.

*E.G.

In> UnFlatten({a,b,c},"+",0)
Result: a+b+c;
In> UnFlatten({a,b,c},"*",1)
Result: a*b*c;

*SEE Flatten
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/simplify/Combine.mpw0000644000175000017500000000363611523200452027223 0ustar  giovannigiovanni%mathpiper,def="Combine"

//Retract("Combine",*);

10 # Combine(expr_IsZero) <-- 0;

20 # Combine(_expr) <-- 
[
    Local(L);
    L := ReassembleListTerms(DisassembleExpression(expr));
    UnFlatten(L,"+",0);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="Combine",categories="User Functions;Expression Simplification"
*CMD Combine --- try to simplify an expression by combining terms or factors that cancel
*STD
*CALL
	Combine(expr)

*PARMS

{expr} -- expression to simplify

*DESC

This function tries to simplify the expression {expr} by combining like
terms or factors that will cancel. 
Unlike the related function {Simplify}, it does not manipulate the expression 
any further.

See Issue #14 for a description of why this function may be necessary.

At the present time, MathPiper's automatic evaluation scheme simplifies some
expressions but leaves other, similar ones, unsimplified (See examples 1 and 2
below).  
A call to Simplify()
may complete the simplification of the expression, but sometimes Simplify() does
too much (see example 3, below).

A call to Combine() is more likely to give what is wanted than a call to Simplify().
Until such time as we can make Combine() a part of MathPiper's automatic
expression evaluation, this is the best workaround.

*E.G.
In> e1:=3 + x/5 - 3
Result: x/5         (automatically simplified upon entry)

In> e2:=3-x/5-3
Result: 3-x/5-3     (NOT automatically simplified upon entry)

In> Simplify(e2)
Result: (-x)/5      (Simplify() does the job)

In> e3:=3 + x/5 + x/5
Result: (2*x)/5+3

In> Simplify(e3)
Result: (2*x+15)/5  (Simplify() does more than we want, here)

In> Combine(e3)
Result: (2*x)/5+3   (Combine() does just enough -- not too much)
    
*SEE Simplify, TrigSimpCombine, RadSimp
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/0000755000175000017500000000000011722677331024433 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/ContFrac.mpw0000644000175000017500000000365111523200452026645 0ustar  giovannigiovanni%mathpiper,def="ContFrac"

//////////////////////////////////////////////////
/// continued fractions for polynomials
//////////////////////////////////////////////////

/// main interface
10 # ContFrac(_n) <-- ContFrac(n, 6);
50 # ContFrac(_n,_depth) <-- ContFracEval(ContFracList(n, depth), rest);

40 # ContFrac(n_CanBeUni,_depth)_(Length(VarList(n)) = 1) <--
[
  ContFracDoPoly(n,depth,VarList(n)[1]);
];

5  # ContFracDoPoly(_exp,0,_var) <-- rest;
5  # ContFracDoPoly(0,0,_var) <-- rest;
10 # ContFracDoPoly(_exp,_depth,_var) <--
[
  Local(content,exp2,first,second);
  first:=Coef(exp,var,0);
  exp:=exp-first;
  content:=Content(exp);
  exp2:=DivPoly(1,PrimitivePart(exp),var,5+3*depth)-1;
  second:=Coef(exp2,0);
  exp2 := exp2 - second;
  first+content/((1+second)+ContFracDoPoly(exp2,depth-1,var));
];

%/mathpiper



%mathpiper_docs,name="ContFrac",categories="User Functions;Numbers (Operations)"
*CMD ContFrac --- continued fraction expansion
*STD
*CALL
	ContFrac(x)
	ContFrac(x, depth)

*PARMS

{x} -- number or polynomial to expand in continued fractions

{depth} -- integer, maximum required depth of result

*DESC

This command returns the continued fraction expansion of {x}, which
should be either a floating point number or a polynomial. If
{depth} is not specified, it defaults to 6. The remainder is
denoted by {rest}.

This is especially useful for polynomials, since series expansions
that converge slowly will typically converge a lot faster if
calculated using a continued fraction expansion.

*E.G.

In> PrettyForm(ContFrac(N(Pi)))
	
	             1
	--------------------------- + 3
	           1
	----------------------- + 7
	        1
	------------------ + 15
	      1
	-------------- + 1
	   1
	-------- + 292
	rest + 1

Result: True;
In> PrettyForm(ContFrac(x^2+x+1, 3))
	
	       x
	---------------- + 1
	         x
	1 - ------------
	       x
	    -------- + 1
	    rest + 1
	
Result: True;

*SEE PAdicExpand, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/ContFracList.mpw0000644000175000017500000000424411523200452027500 0ustar  giovannigiovanni%mathpiper,def="ContFracList"

/////////////////////////////////////////////////
/// Continued fractions stuff
/////////////////////////////////////////////////

/// compute the list of continued fraction coefficients for a given number
/// if order is not given, computes to the end
10 # ContFracList(_n) <-- ContFracList(n, Infinity);
/// compute list of given length
10 # ContFracList(_n, _depth)_(depth <= 0) <-- {};
20 # ContFracList(n_IsInteger, _depth) <-- {n};
// prevent infinite loop when in numeric mode
30 # ContFracList(n_IsNumber, _depth) _InNumericMode() <-- NonN(ContFracList(Rationalize(n), depth));

40 # ContFracList(n_IsNumber, _depth) <-- ContFracList(Rationalize(n), depth);

/* n/m = Quotient(n,m) + 1/( m/Modulo(n,m) ) */
35 # ContFracList((n_IsNegativeInteger) / (m_IsInteger), _depth) <-- Push( ContFracList(m/Modulo(n,m), depth-1) , Quotient(n,m)-1);

40 # ContFracList((n_IsInteger) / (m_IsInteger), _depth) <-- Push( ContFracList(m/Modulo(n,m), depth-1) , Quotient(n,m));

%/mathpiper



%mathpiper_docs,name="ContFracList",categories="User Functions;Numbers (Operations)"
*CMD ContFracList --- manipulate continued fractions
*CMD ContFracEval --- manipulate continued fractions
*STD
*CALL
	ContFracList(frac)
	ContFracList(frac, depth)
	ContFracEval(list)
	ContFracEval(list, rest)

*PARMS

{frac} -- a number to be expanded

{depth} -- desired number of terms

{list} -- a list of coefficients

{rest} -- expression to put at the end of the continued fraction

*DESC

The function {ContFracList} computes terms of the continued fraction
representation of a rational number {frac}.  It returns a list of terms of length {depth}. If {depth} is not specified, it returns all terms.

The function {ContFracEval} converts a list of coefficients into a continued fraction expression. The optional parameter {rest} specifies the symbol to put at the end of the expansion. If it is not given, the result is the same as if {rest=0}.

*E.G.

In> A:=ContFracList(33/7 + 0.000001)
Result: {4,1,2,1,1,20409,2,1,13,2,1,4,1,1,3,3,2};
In> ContFracEval(Take(A, 5))
Result: 33/7;
In> ContFracEval(Take(A,3), remainder)
Result: 1/(1/(remainder+2)+1)+4;
	
*SEE ContFrac, GuessRational
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/IsFreeOf.mpw0000644000175000017500000000303611523200452026605 0ustar  giovannigiovanni%mathpiper,def="IsFreeOf"

1 # IsFreeOf({},_expr) <-- True;
2 # IsFreeOf(var_IsList, _expr) <-- And(IsFreeOf(First(var),expr), IsFreeOf(Rest(var),expr));

4 # IsFreeOf(_var,{}) <-- True;
5 # IsFreeOf(_var,expr_IsList) <-- And(IsFreeOf(var,First(expr)), IsFreeOf(var,Rest(expr)));

/* Accept any variable. */
10 # IsFreeOf(_expr,_expr) <-- False;

/* Otherwise check all leafs of a function. */
11 # IsFreeOf(_var,expr_IsFunction) <-- IsFreeOf(var,Rest(FunctionToList(expr)));

/* Else it doesn't depend on any variable. */
12 # IsFreeOf(_var,_expr) <-- True;

%/mathpiper



%mathpiper_docs,name="IsFreeOf",categories="User Functions;Predicates"
*CMD IsFreeOf --- test whether expression depends on variable
*STD
*CALL
	IsFreeOf(var, expr)
	IsFreeOf({var, ...}, expr)

*PARMS

{expr} -- expression to test

{var} -- variable to look for in "expr"

*DESC

This function checks whether the expression "expr" (after being
evaluated) depends on the variable "var". It returns {False} if this is the case and {True}
otherwise.

The second form test whether the expression depends on any of
the variables named in the list. The result is {True} if none of the variables appear in the expression and {False} otherwise.

*E.G.

In> IsFreeOf(x, Sin(x));
Result: False;
In> IsFreeOf(y, Sin(x));
Result: True;
In> IsFreeOf(x, Differentiate(x) a*x+b);
Result: True;
In> IsFreeOf({x,y}, Sin(x));
Result: False;

The third command returns {True} because the
expression {Differentiate(x) a*x+b} evaluates to {a}, which does not depend on {x}.

*SEE Contains
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/TRun.mpw0000644000175000017500000000122011316274015026032 0ustar  giovannigiovanni%mathpiper,def=""

//todo:tk:this function is completely commented out.

/*
TRun(_f,_g,_degree)<--
[
  Local(l2,l3,l4);
  l2:=ReversePoly(f,g,t,z,degree);
  l3:=Subst(z,f)l2;
  l4:=BigOh(l3,t,degree);
  Echo({g," == ",l4});
  NewLine();
];

TRun(t+t^2,t,10);
TRun(t/2-t^2,t,10);
TRun(t/2-t^2,3+t+t^2/2,10);
TRun(2+t/2-t^2,t,10);
*/

/*
TRun(_f,_degree)<--
[
  Local(l2,l3,l4);
  l2:=InverseTaylor(t,0,degree)f;
  l3:=Subst(t,Taylor(t,0,degree)f)l2;
  l4:=BigOh(l3,t,degree);

  Echo({t," == ",Simplify(l4)});
  NewLine();
];
TRun(Sin(a*t),3);
TRun(a^t,3);
TRun(a^t,3);
TRun(t+t^2,10);
TRun(t/2-t^2,10);
TRun(t/2-t^2,10);
TRun(2+t/2-t^2,10);
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/NewLine.mpw0000644000175000017500000000142711523200452026506 0ustar  giovannigiovanni%mathpiper,def="NewLine"

//Retract("NewLine",*);

10 # NewLine()  <-- WriteN(Nl(),1);
20 # NewLine(n_IsPositiveInteger) <--  WriteN(Nl(),n);
30 # NewLine(_n) <-- Check(False, "Argument", "The argument must be a positive integer  ");


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="NewLine",categories="User Functions;Input/Output"
*CMD NewLine --- print one or more newline characters
*STD
*CALL
	NewLine()
	NewLine(nr)

*PARMS

{nr} -- the number of newline characters to print

*DESC

The command {NewLine()} prints one newline character
on the current output. The second form prints "nr" newlines on the
current output. The result is always True.

*E.G. notest

In> NewLine();
	
Result: True;

*SEE Echo, Write, Space
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/EigenValues.mpw0000644000175000017500000000167611523200452027362 0ustar  giovannigiovanni%mathpiper,def="EigenValues"

// diagonal matrices will be caught by IsUpperTriangular
10 # EigenValues(matrix_IsUpperTriangular) <-- Diagonal(matrix);
10 # EigenValues(matrix_IsLowerTriangular) <-- Diagonal(matrix);

20 # EigenValues(matrix_IsMatrix) <-- Roots(CharacteristicEquation(matrix,xx));

%/mathpiper



%mathpiper_docs,name="EigenValues",categories="User Functions;Linear Algebra"
*CMD EigenValues --- get eigenvalues of a matrix
*STD
*CALL
	EigenValues(matrix)

*PARMS

{matrix} -- a square matrix

*DESC

EigenValues returns the eigenvalues of a matrix.
The eigenvalues x of a matrix M are the numbers such that
$M*v=x*v$ for some vector.

It first determines the characteristic equation, and then factorizes this
equation, returning the roots of the characteristic equation
Det(matrix-x*identity).

*E.G.

In> M:={{1,2},{2,1}}
Result: {{1,2},{2,1}};
In> EigenValues(M)
Result: {3,-1};

*SEE EigenVectors, CharacteristicEquation
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/Decimal.mpw0000644000175000017500000000410711523200452026501 0ustar  giovannigiovanni%mathpiper,def="Decimal"

10 # Decimal( n_IsInteger ) <-- {n,{0}};
10 # Decimal( (n_IsPositiveInteger) / (d_IsPositiveInteger) ) <--
[
  Local(result,rev,first,period,repeat,static);
  result:={Quotient(n,d)};
  Decimal(result,Modulo(n,d),d,350);
  rev:=DecimalFindPeriod(result);
  first:=rev[1];
  period:=rev[2];
  repeat:=result[first .. (first+period-1)];
  static:=result[1 .. (first-1)];
  DestructiveAppend(static,repeat);
];
20 # Decimal(_n/_m)_((n/m)<0) <-- "-":Decimal(-n/m);

10 # Decimal(_result , _n , _d,_count ) <--
[
  While(count>0)
  [
    DestructiveAppend(result,Quotient(10*n,d));
    n:=Modulo(10*n,d);
    count--;
  ];
];

DecimalFindPeriod(_list) <--
[
  Local(period,nr,reversed,first,i);
  reversed:=Rest(DestructiveReverse(FlatCopy(Rest(list))));
  nr:=Length(reversed)>>1;
  period:=1;
  first:=reversed[1];

  For(i:=1,i1 And list[first] = list[first+period]) first--;
  first++;

  {first,period};
];

DecimalMatches(_reversed,_period) <--
[
  Local(nr,matches,first);
  nr:=0;
  matches:=True;
  first:=1;
  While((nr<100) And matches)
  [
    matches := (matches And
       (reversed[first .. (first+period-1)] = reversed[(first+period) .. (first+2*period-1)]));
    first:=first+period;
    nr:=nr+period;
  ];
  matches;
];

%/mathpiper



%mathpiper_docs,name="Decimal",categories="User Functions;Numbers (Operations)"
*CMD Decimal --- decimal representation of a rational
*STD
*CALL
	Decimal(frac)

*PARMS

{frac} -- a rational number

*DESC

This function returns the infinite decimal representation of a
rational number {frac}.  It returns a list, with the first element
being the number before the decimal point and the last element the
sequence of digits that will repeat forever. All the intermediate list
elements are the initial digits before the period sets in.

*E.G.

In> Decimal(1/22)
Result: {0,0,{4,5}};
In> N(1/22,30)
Result: 0.045454545454545454545454545454;

*SEE N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/Space.mpw0000644000175000017500000000101711523200452026173 0ustar  giovannigiovanni%mathpiper,def="Space"

Space() := WriteN(" ",1);
Space(n):= WriteN(" ",n);

%/mathpiper



%mathpiper_docs,name="Space",categories="User Functions;Input/Output"
*CMD Space --- print one or more spaces
*STD
*CALL
	Space()
	Space(nr)

*PARMS

{nr} -- the number of spaces to print

*DESC

The command {Space()} prints one space on the
current output. The second form prints {nr} spaces on the current
output. The result is always True.

*E.G. notest

In> Space(5);
	     Result: True;

*SEE Echo, Write, NewLine
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/Nl.mpw0000644000175000017500000000107211523200452025512 0ustar  giovannigiovanni%mathpiper,def="Nl"

Nl():=
"
";

%/mathpiper



%mathpiper_docs,name="Nl",categories="User Functions;Input/Output"
*CMD Nl --- the newline character
*STD
*CALL
	Nl()

*DESC

This function returns a string with one element in it, namely a newline
character. This may be useful for building strings to send to some
output in the end.

Note that the second letter in the name of this command is a lower
case {L} (from "line").

*E.G. notest

In> WriteString("First line" : Nl() : "Second line" : Nl());
	First line
	Second line
Result: True;

*SEE NewLine
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/UniqueConstant.mpw0000644000175000017500000000113111523200452030115 0ustar  giovannigiovanni%mathpiper,def="UniqueConstant"

UniqueConstant() <--
[
  Local(result);
  result := ToString(LocalSymbols(C)(C));
  ToAtom(StringMidGet(2,Length(result)-1,result));
];

%/mathpiper



%mathpiper_docs,name="UniqueConstant",categories="User Functions;Variables"
*CMD UniqueConstant --- create a unique identifier
*STD
*CALL
	UniqueConstant()

*DESC

This function returns a unique constant atom each time you call
it. The atom starts with a C character, and a unique number is
appended to it.

*E.G.

In> UniqueConstant()
Result: C9
In>  UniqueConstant()
Result: C10

*SEE LocalSymbols
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/NearRational.mpw0000644000175000017500000001101611523200452027517 0ustar  giovannigiovanni%mathpiper,def="NearRational"

//Retract("NearRational",*);

//////////////////////////////////////////////////
/// NearRational, GuessRational
//////////////////////////////////////////////////

/// find rational number with smallest num./denom. near a given number x
/// See: HAKMEM, MIT AI Memo 239, 02/29/1972, Item 101C

10 # NearRational(_x) <-- NearRational(x, Floor(1/2*BuiltinPrecisionGet()));

15 # NearRational(x_IsRationalOrNumber, prec_IsInteger) <-- 
[
	Local(x1, x2, i,  old'prec);
	old'prec := BuiltinPrecisionGet();
    BuiltinPrecisionSet(prec + 8);	// 8 guard digits (?)
	x1 := ContFracList(N(Eval(x+10^(-prec))));
	x2 := ContFracList(N(Eval(x-10^(-prec))));

    /*
    If(InVerboseMode(),
      [
         Echo("NearRational: x      = ", N(Eval(x           ))));
         Echo("NearRational: xplus  = ", N(Eval(x+10^(-prec)))));
         Echo("NearRational: xmin   = ", N(Eval(x-10^(-prec)))));
         Echo("NearRational: Length(x1) = ", Length(x1)," ",x1));
         Echo("NearRational: Length(x2) = ", Length(x2)," ",x1));
      ]
    );
    */
    
	// find where the continued fractions for "x1" and "x2" differ
	// prepare result in "x1" and length of result in "i"
	For (i:=1, i<=Length(x1) And i<=Length(x2) And x1[i]=x2[i], i++ ) True;
	If(
		i>Length(x1),
		// "x1" ended but matched, so use "x2" as "x1"
		x1:=x2,
		If(
			i>Length(x2),
		// "x2" ended but matched, so use "x1"
			True,
		// neither "x1" nor "x2" ended and there is a mismatch at "i"
		// apply recipe: select the smalest of the differing terms
			x1[i]:=Minimum(x1[i],x2[i])
		)
	);
	// recipe: x1dd 1 to the lx1st term unless it's the lx1st in the originx1l sequence
	//Ayal added this line, i could become bigger than Length(x1)!
	//If(InVerboseMode(), Echo({"NearRational: using ", i, "terms of the continued fraction"}));
	If(i>Length(x1),i:=Length(x1));
	x1[i] := x1[i] + If(i=Length(x1), 0, 1);
	BuiltinPrecisionSet(old'prec);
	ContFracEval(Take(x1, i));
];


20 # NearRational(_z, prec_IsInteger)_
      (And(Im(z)!=0,IsRationalOrNumber(Im(z)),IsRationalOrNumber(Re(z)))) <--
[
    Local(rr,ii);
    rr := Re(z);
    ii := Im(z);
    Complex( NearRational(rr,prec), NearRational(ii,prec) );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="NearRational",categories="User Functions;Numbers (Operations)"
*CMD NearRational --- find optimal rational approximations
*STD
*CALL
	NearRational(x)
	NearRational(x, digits)
    NearRational(z)
    NearRational(z, digits)

*PARMS

{x} -- a number to be approximated (must be already evaluated to floating-point)
{z} -- a complex number to be approximated (Re and Im as above)

{digits} -- desired number of decimal digits (integer)

*DESC

The functions {GuessRational(x)} and {NearRational(x)} attempt to find "optimal"
rational approximations to a given value {x}. The approximations are "optimal"
in the sense of having smallest numerators and denominators among all rational
numbers close to {x}. This is done by computing a continued fraction
representation of {x} and truncating it at a suitably chosen term.  Both
functions return a rational number which is an approximation of {x}.

Unlike the function {Rationalize()} which converts floating-point numbers to
rationals without loss of precision, the functions {GuessRational()} and
{NearRational()} are intended to find the best rational that is approximately
equal to a given value.

The function {NearRational(x)} is useful if one needs to
approximate a given value, i.e. to find an "optimal" rational number
that lies in a certain small interval around a certain value {x}. This
function takes an optional second parameter {digits} which has slightly
different meaning: it specifies the number of digits of precision of
the approximation; in other words, the difference between {x} and the
resulting rational number should be at most one digit of that
precision. The parameter {digits} also defaults to half of the current
precision.

*E.G.

Start with a rational number and obtain a floating-point approximation:
In> x:=N(956/1013)
Result: 0.9437314906
In> Rationalize(x)
Result: 4718657453/5000000000;
The first 10 terms of this continued fraction correspond to the correct continued fraction for the original rational number.
In> NearRational(x)
Result: 218/231;
This function found a different rational number closeby because the precision was not high enough.
In> NearRational(x, 10)
Result: 956/1013;

*SEE BracketRational, GuessRational, ContFrac, ContFracList, Rationalize
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/LagrangeInterpolant.mpw0000644000175000017500000000362311523200452031105 0ustar  giovannigiovanni%mathpiper,def="LagrangeInterpolant"

LagrangeInt(_var,_list) <--
[
  Local(nr);
  nr:=Length(list);
  Product(FillList(var,nr)-list);
];

LagrangeInterpolant(list_IsList,_values,_var) <--
[
  Local(i,nr,sublist);
  nr:=Length(list);
  result:=0;
  For(i:=1,i<=nr,i++)
  [
    sublist:=FlatCopy(list);
    DestructiveDelete(sublist,i);
    result:=result + values[i]*LagrangeInt(var,sublist)/LagrangeInt(list[i],sublist);
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="LagrangeInterpolant",categories="User Functions;Series"
*CMD LagrangeInterpolant --- polynomial interpolation
*STD
*CALL
	LagrangeInterpolant(xlist, ylist, var)

*PARMS

{xlist} -- list of argument values

{ylist} -- list of function values

{var} -- free variable for resulting polynomial

*DESC

This function returns a polynomial in the variable "var" which
interpolates the points "(xlist, ylist)". Specifically, the value of
the resulting polynomial at "xlist[1]" is "ylist[1]", the value at
"xlist[2]" is "ylist[2]", etc. The degree of the polynomial is not
greater than the length of "xlist".

The lists "xlist" and "ylist" should be of equal
length. Furthermore, the entries of "xlist" should be all distinct
to ensure that there is one and only one solution.

This routine uses the Lagrange interpolant formula to build up the
polynomial.

*E.G.

In> f := LagrangeInterpolant({0,1,2}, \
	  {0,1,1}, x);
Result: (x*(x-1))/2-x*(x-2);
In> Eval(Subst(x,0) f);
Result: 0;
In> Eval(Subst(x,1) f);
Result: 1;
In> Eval(Subst(x,2) f);
Result: 1;
	
In> PrettyPrinterSet("PrettyForm");
	
	True
	
In> LagrangeInterpolant({x1,x2,x3}, {y1,y2,y3}, x)
	
	y1 * ( x - x2 ) * ( x - x3 ) 
	---------------------------- 
	 ( x1 - x2 ) * ( x1 - x3 )   
	
	  y2 * ( x - x1 ) * ( x - x3 )
	+ ----------------------------
	   ( x2 - x1 ) * ( x2 - x3 )
	
	  y3 * ( x - x1 ) * ( x - x2 )
	+ ----------------------------
	   ( x3 - x1 ) * ( x3 - x2 )


*SEE Subst
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/ContFracEval.mpw0000644000175000017500000000434311523200452027454 0ustar  giovannigiovanni%mathpiper,def="ContFracEval"

//////////////////////////////////////////////////
/// ContFracEval: evaluate continued fraction from the list of coefficients
//////////////////////////////////////////////////
/// Each coefficient is either a single expression or a list of 2 expressions, giving the term and the numerator of the current level in the fraction.
/// ContFracEval({{a0, b0}, {a1, b1}, ...}) = a0+b0/(a1+b1/(...))
/// ContFracEval({a0, a1, ...}) = a0+1/(a1+1/(...))

10 # ContFracEval({}, _rest) <-- rest;
// finish recursion here
10 # ContFracEval({{_n, _m}}, _rest) <-- n+m+rest;
15 # ContFracEval({_n}, _rest) <-- n+rest;
/// Continued fractions with nontrivial numerators
20 # ContFracEval(list_IsList, _rest)_(IsList(First(list))) <-- First(First(list)) + Rest(First(list)) / ContFracEval(Rest(list), rest);
/// Continued fractions with unit numerators
30 # ContFracEval(list_IsList, _rest) <-- First(list) + 1 / ContFracEval(Rest(list), rest);

/// evaluate continued fraction: main interface
ContFracEval(list_IsList) <-- ContFracEval(list, 0);

%/mathpiper



%mathpiper_docs,name="ContFracEval",categories="User Functions;Numbers (Operations)"
*CMD ContFracList --- manipulate continued fractions
*CMD ContFracEval --- manipulate continued fractions
*STD
*CALL
	ContFracList(frac)
	ContFracList(frac, depth)
	ContFracEval(list)
	ContFracEval(list, rest)

*PARMS

{frac} -- a number to be expanded

{depth} -- desired number of terms

{list} -- a list of coefficients

{rest} -- expression to put at the end of the continued fraction

*DESC

The function {ContFracList} computes terms of the continued fraction
representation of a rational number {frac}.  It returns a list of terms of length {depth}. If {depth} is not specified, it returns all terms.

The function {ContFracEval} converts a list of coefficients into a continued fraction expression. The optional parameter {rest} specifies the symbol to put at the end of the expansion. If it is not given, the result is the same as if {rest=0}.

*E.G.

In> A:=ContFracList(33/7 + 0.000001)
Result: {4,1,2,1,1,20409,2,1,13,2,1,4,1,1,3,3,2};
In> ContFracEval(Take(A, 5))
Result: 33/7;
In> ContFracEval(Take(A,3), remainder)
Result: 1/(1/(remainder+2)+1)+4;
	
*SEE ContFrac, GuessRational
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/CharacteristicEquation.mpw0000644000175000017500000000160111523200452031575 0ustar  giovannigiovanni%mathpiper,def="CharacteristicEquation"

Function("CharacteristicEquation",{matrix,var})
   SymbolicDeterminant(matrix-var*Identity(Length(matrix)));
HoldArgument("CharacteristicEquation",var);

%/mathpiper



%mathpiper_docs,name="CharacteristicEquation",categories="User Functions;Linear Algebra"
*CMD CharacteristicEquation --- get characteristic polynomial of a matrix
*STD
*CALL
	CharacteristicEquation(matrix,var)

*PARMS

{matrix} -- a matrix

{var} -- a free variable

*DESC

CharacteristicEquation
returns the characteristic equation of "matrix", using
"var". The zeros of this equation are the eigenvalues
of the matrix, Det(matrix-I*var);

*E.G.

In> A:=DiagonalMatrix({a,b,c})
Result: {{a,0,0},{0,b,0},{0,0,c}};
In> B:=CharacteristicEquation(A,x)
Result: (a-x)*(b-x)*(c-x);
In> Expand(B,x)
Result: (b+a+c)*x^2-x^3-((b+a)*c+a*b)*x+a*b*c;

*SEE EigenValues, EigenVectors
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/BracketRational.mpw0000644000175000017500000000366311523200452030216 0ustar  giovannigiovanni%mathpiper,def="BracketRational"

//////////////////////////////////////////////////
/// BracketRational: find two rational approximations
//////////////////////////////////////////////////

/// Return a list of two rational numbers r1, r2 such that r1 Abs(N(Eval(eps*r)) ) ) )
	[
		r2 := r1;
		n++;
		r1 := ContFracEval(Take(cflist,n));
	];
	// now r1 and r2 are some rational numbers.
	// decide whether the search was successful.
	If(
		n=Length(cflist),
		{},	// return empty list if not enough precision
		If(N(Eval(r-r1))>0,
			{r1, r2},	// successive approximations are always bracketing, we only need to decide their order
			{r2, r1}
		)
	);
];

%/mathpiper



%mathpiper_docs,name="BracketRational",categories="User Functions;Numbers (Operations)"
*CMD BracketRational --- find optimal rational approximations
*STD
*CALL
	BracketRational(x, eps)

*PARMS

{x} -- a number to be approximated (must be already evaluated to floating-point)

{eps} -- desired precision

*DESC

The function {BracketRational(x,eps)} can be used to find approximations with a given relative precision from above and from below.
This function returns a list of two rational numbers {{r1,r2}} such that $r1 BracketRational(N(Ln(10)), 10^(-8))
Result: {12381/5377,41062/17833};


*SEE GuessRational, NearRational, ContFrac, ContFracList, Rationalize
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/ReversePoly.mpw0000644000175000017500000000443211523200452027423 0ustar  giovannigiovanni%mathpiper,def="ReversePoly"

/* Lagrangian power series reversion. Copied
   from Knuth seminumerical algorithms */

ReversePoly(_f,_g,_var,_newvar,_degree) <--
[
  Local(orig,origg,G,V,W,U,n,initval,firstder,j,k,newsum);
  orig:=MakeUni(f,var);
  origg:=MakeUni(g,var);
  initval:=Coef(orig,0);
  firstder:=Coef(orig,1);
  V:=Coef(orig,1 .. Degree(orig));
  V:=Concat(V,FillList(0,degree));
  G:=Coef(origg,1 .. Degree(origg));
  G:=Concat(G,FillList(0,degree));
  W:=FillList(0,Length(V)+2);
  W[1]:=G[1]/firstder;
  U:=FillList(0,Length(V)+2);
  U[1]:=1/firstder;
  n:=1;
  While(n f(x):=Eval(Expand((1+x)^4))
Result: True;
In> g(x) := x^2
Result: True;
In> h(y):=Eval(ReversePoly(f(x),g(x),x,y,8))
Result: True;
In> BigOh(h(f(x)),x,8)
Result: x^2;
In> h(x)
Result: (-2695*(x-1)^7)/131072+(791*(x-1)^6)
	/32768 +(-119*(x-1)^5)/4096+(37*(x-1)^4)
	/1024+(-3*(x-1)^3)/64+(x-1)^2/16;

*SEE InverseTaylor, Taylor, BigOh
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/InverseTaylor.mpw0000644000175000017500000000236611523200452027756 0ustar  giovannigiovanni%mathpiper,def="InverseTaylor"

/* InverseTaylor : given a function y=f(x), determine the Taylor series
 * expansion of the inverse f^-1(y)=x this function around y0=f(x0).
 *
 */
Function("InverseTaylor",{var,val,degree,func})
[
  Local(l1);
  l1:=UniTaylor(func,var,val,degree);
  val+ReversePoly(l1,var,var,var,degree+1);
];

%/mathpiper



%mathpiper_docs,name="InverseTaylor",categories="User Functions;Series"
*CMD InverseTaylor --- Taylor expansion of inverse
*STD
*CALL
	InverseTaylor(var, at, order) expr

*PARMS

{var} -- variable

{at} -- point to get inverse Taylor series around

{order} -- order of approximation

{expr} -- expression to get inverse Taylor series for

*DESC

This function builds the Taylor series expansion of the inverse of the
expression "expr" with respect to the variable "var" around "at"
up to order "order". It uses the function {ReversePoly} to perform the task.

*E.G.

In> PrettyPrinterSet("PrettyForm")
	
	True
	
In> exp1 := Taylor(x,0,7) Sin(x)
	
	     3    5      7
	    x    x      x
	x - -- + --- - ----
	    6    120   5040
	
In> exp2 := InverseTaylor(x,0,7) ArcSin(x)
	
	 5      7     3
	x      x     x
	--- - ---- - -- + x
	120   5040   6
	
In> Simplify(exp1-exp2)
	
	0


*SEE ReversePoly, Taylor, BigOh
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/Series.mpw0000644000175000017500000000007211316274015026400 0ustar  giovannigiovanni%mathpiper,def=""

//todo:tk:not implemented.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/GuessRational.mpw0000644000175000017500000000656411523200452027734 0ustar  giovannigiovanni%mathpiper,def="GuessRational"

/// guess the rational number behind an imprecise number
/// prec parameter is the max number of digits you can have in the denominator
GuessRational(_x) <-- GuessRational(x, Floor(1/2*BuiltinPrecisionGet()));
GuessRational(x_IsRationalOrNumber, prec_IsInteger) <-- [
	Local(denom'estimate, cf, i);
	denom'estimate := 1;
	cf := ContFracList(x);
	For(i:=2, i<=Length(cf) And denom'estimate < 10^prec, i++)
		[	// estimate the denominator
			denom'estimate := denom'estimate * If(
				cf[i] = 1,
				If(
					i+2<=Length(cf),	// have at least two more terms, do a full estimate
					RoundTo(N(Eval(cf[i]+1/(cf[i+1]+1/cf[i+2]))), 3),
					// have only one more term
					RoundTo(N(Eval(cf[i]+1/cf[i+1])), 3)
				),
				// term is not 1, use the simple estimate
				cf[i]
			);
		];
	If (denom'estimate < 10^prec,
		//If(InVerboseMode(), Echo({"GuessRational: all ", i, "terms are within limits"})),
		i--	// do not use the last term
	);
	i--;	// loop returns one more number
	//If(InVerboseMode(), Echo({"GuessRational: using ", i, "terms of the continued fraction"}));
	ContFracEval(Take(cf, i));
];

%/mathpiper



%mathpiper_docs,name="GuessRational",categories="User Functions;Numbers (Operations)"
*CMD GuessRational --- find optimal rational approximations
*STD
*CALL
	GuessRational(x)
	GuessRational(x, digits)

*PARMS

{x} -- a number to be approximated (must be already evaluated to floating-point)

{digits} -- desired number of decimal digits (integer)

*DESC

The functions {GuessRational(x)} and {NearRational(x)} attempt to find "optimal"
rational approximations to a given value {x}. The approximations are "optimal"
in the sense of having smallest numerators and denominators among all rational
numbers close to {x}. This is done by computing a continued fraction
representation of {x} and truncating it at a suitably chosen term.  Both
functions return a rational number which is an approximation of {x}.

Unlike the function {Rationalize()} which converts floating-point numbers to
rationals without loss of precision, the functions {GuessRational()} and
{NearRational()} are intended to find the best rational that is approximately
equal to a given value.

The function {GuessRational()} is useful if you have obtained a
floating-point representation of a rational number and you know
approximately how many digits its exact representation should contain.
This function takes an optional second parameter {digits} which limits
the number of decimal digits in the denominator of the resulting
rational number. If this parameter is not given, it defaults to half
the current precision. This function truncates the continuous fraction
expansion when it encounters an unusually large value (see example).
This procedure does not always give the "correct" rational number; a
rule of thumb is that the floating-point number should have at least as
many digits as the combined number of digits in the numerator and the
denominator of the correct rational number.

*E.G.

Start with a rational number and obtain a floating-point approximation:
In> x:=N(956/1013)
Result: 0.9437314906
In> Rationalize(x)
Result: 4718657453/5000000000;
In> V(GuessRational(x))
	
	GuessRational: using 10 terms of the  continued fraction
Result: 956/1013;
In> ContFracList(x)
Result: {0,1,16,1,3,2,1,1,1,1,508848,3,1,2,1,2,2};

*SEE BracketRational, NearRational, ContFrac, ContFracList, Rationalize
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/WithValue.mpw0000644000175000017500000000215311523200452027052 0ustar  giovannigiovanni%mathpiper,def="WithValue"

TemplateFunction("WithValue",{var,val,expr})
[
  If(IsList(var),
     ApplyFast("MacroLocal",var),
     MacroLocal(var)
    );
  ApplyFast(":=",{var,val});
  Eval(expr);
];

%/mathpiper



%mathpiper_docs,name="WithValue",categories="User Functions;Control Flow"
*CMD WithValue --- temporary assignment during an evaluation
*STD
*CALL
	WithValue(var, val, expr)
	WithValue({var,...}, {val,...}, expr)

*PARMS

{var} -- variable to assign to

{val} -- value to be assigned to "var"

{expr} -- expression to evaluate with "var" equal to "val"

*DESC

First, the expression "val" is assigned to the variable
"var". Then, the expression "expr" is evaluated and
returned. Finally, the assignment is reversed so that the variable
"var" has the same value as it had before {WithValue} was evaluated.

The second calling sequence assigns the first element in the list of
values to the first element in the list of variables, the second value
to the second variable, etc.

*E.G.

In> WithValue(x, 3, x^2+y^2+1);
Result: y^2+10;
In> WithValue({x,y}, {3,2}, x^2+y^2+1);
Result: 14;

*SEE Subst, /:
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/WriteN.mpw0000644000175000017500000000017411316274015026361 0ustar  giovannigiovanni%mathpiper,def="WriteN"

WriteN(string,n) :=
[
  Local(i);
  For(i:=1,i<=n,i++) WriteString(string);
  True;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/IsZeroVector.mpw0000644000175000017500000000120211523200452027532 0ustar  giovannigiovanni%mathpiper,def="IsZeroVector"

Function("IsZeroVector",{aList}) aList = ZeroVector(Length(aList));

%/mathpiper



%mathpiper_docs,name="IsZeroVector",categories="User Functions;Predicates"
*CMD IsZeroVector --- test whether list contains only zeroes
*STD
*CALL
	IsZeroVector(list)

*PARMS

{list} -- list to compare against the zero vector

*DESC

The only argument given to {IsZeroVector} should be
a list. The result is {True} if the list contains
only zeroes and {False} otherwise.

*E.G.

In> IsZeroVector({0, x, 0});
Result: False;
In> IsZeroVector({x-x, 1 - Differentiate(x) x});
Result: True;

*SEE IsList, ZeroVector
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/newly/EigenVectors.mpw0000644000175000017500000000232711523200452027542 0ustar  giovannigiovanni%mathpiper,def="EigenVectors"

EigenVectors(_matrix,_eigenvalues) <--
[
  Local(result,n);
/*  eigenvalues:=N(Eval(eigenvalues));  */
  n:=Length(eigenvalues);
  result:={};
  ForEach(e,eigenvalues)
  [
    Local(possible);
/* Echo({"1...",result}); */
    possible:=OldSolve(matrix*MakeVector(k,n)==e*MakeVector(k,n),MakeVector(k,n))[1];
/* Echo({"2..."}); */
/* Echo({"2..."}); */

    If(Not(IsZeroVector(possible)),
      DestructiveAppend(result,possible)
      );
/* Echo({"3..."}); */
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="EigenVectors",categories="User Functions;Linear Algebra"
*CMD EigenVectors --- get eigenvectors of a matrix
*STD
*CALL
	EigenVectors(A,eigenvalues)

*PARMS

{matrix} -- a square matrix

{eigenvalues} -- list of eigenvalues as returned by {EigenValues}

*DESC

{EigenVectors} returns a list of the eigenvectors of a matrix.
It uses the eigenvalues and the matrix to set up n equations with
n unknowns for each eigenvalue, and then calls {Solve} to determine
the values of each vector.

*E.G.

In> M:={{1,2},{2,1}}
Result: {{1,2},{2,1}};
In> e:=EigenValues(M)
Result: {3,-1};
In> EigenVectors(M,e)
Result: {{-ki2/ -1,ki2},{-ki2,ki2}};

*SEE EigenValues, CharacteristicEquation
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/pslq/0000755000175000017500000000000011722677326024260 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/pslq/Pslq.mpw0000644000175000017500000002045711523200452025711 0ustar  giovannigiovanni%mathpiper,def="Pslq"

/*********************************************************************************************#
#                       The PSLQ Integer Relation Algorithm                                   #
#                                                                                             #
# Aut.: Helaman R.P. Ferguson and David Bailey "A Polynomial Time, Numerically Stable         #
#       Integer Relation Algorithm" (RNR Technical Report RNR-92-032)    helaman@super.org    #
# Ref.: David Bailey and Simon Plouffe "Recognizing Numerical Constants" dbailey@nas.nasa.gov #
# Cod.: Raymond Manzoni  raymman@club-internet.fr                                             #
#*********************************************************************************************#
# Creation:97/11                    #
# New termination criteria:97/12/15 #
# this code is free...              #

Ported to MathPiper 2000 Ayal Pinkus.

Given a list of constants x find coefficients sol[i] such that
      sum(sol[i]*x[i], i=1..n) = 0    (where n=Length(x))

    x is the list of real expressions
          N(x[i]) must evaluate to floating point numbers!
    precision is the number of digits needed for completion;
          must be greater or equal to log10(max(sol[i]))*n
    returns the list of solutions with initial precision
          and the confidence (the lower the better)

    Example:

    In> Pslq({2*Pi-4*Exp(1),Pi,Exp(1)},20)
    Result: {1,-2,4};

*/

Pslq(x, precision) :=
[
  Local (ndigits, gam, A, B, H, n, i, j, k, s, y, tmp, t, m, maxi, gami,
	 t0, t1, t2, t3, t4, mini, Confidence, norme,result);
  n:=Length(x);
  ndigits:=BuiltinPrecisionGet();
  BuiltinPrecisionSet(precision+10); // 10 is chosen arbitrarily, but should always be enough. Perhaps we can optimize by lowering this number
  Confidence:=10^(-FloorN(N(Eval(precision/3))));
//Echo("Confidence is ",Confidence);

  gam:=N(Sqrt(4/3));
  For (i:=1, i<=n,i++) x[i]:=N(Eval(x[i]));

//Echo("1...");

  A:=Identity(n); /*A and B are of Integer type*/
  B:=Identity(n); /*but this doesn't speed up*/
  s:=ZeroVector(n);
  y:=ZeroVector(n);

//Echo("2...");

  For(k:=1,k<=n,k++)
  [
    tmp:=0;
    For (j:=k,j<=n,j++) tmp:=tmp + N(x[j]^2);
//tmp:=DivideN(tmp,1.0);
//Echo("tmp is ",tmp);
//MathDebugInfo(tmp);
/*If(Not IsPositiveNumber(tmp),
  Echo("******** not a positive number: ",tmp)
);
If(Not IsNumber(tmp),
  Echo("******** not a number: ",tmp)
);
If(IsLessThan(tmp,0),
[
  Echo("******** not positive: ",tmp);
]
);*/

    s[k]:=SqrtN(tmp);


/*If(Not IsNumber(tmp),
[
Echo("************** tmp = ",tmp);
]);
If(Not IsNumber(s[k]),
[
Echo("************** s[k] = ",s[k]);
]);*/

  ];

//Echo("3...");

  tmp:=N(Eval(s[1]));
/*If(Not IsNumber(tmp),
[
Echo("************** tmp = ",tmp);
]);*/

  For (k:= 1,k<= n,k++)
  [
    y[k]:=N(Eval(x[k]/tmp));
    s[k]:=N(Eval(s[k]/tmp));

//Echo("1..."," ",y[k]," ",s[k]);
/*If(Not IsNumber(y[k]),
[
Echo("************** y[k] = ",y[k]);
]);
If(Not IsNumber(s[k]),
[
Echo("************** s[k] = ",s[k]);
]);*/

  ];
  H:=ZeroMatrix(n, n-1);

//Echo("4...",n);
  For (i:=1,i<= n,i++)
  [

    if (i <= n-1)  [ H[i][i]:=N(s[i + 1]/s[i]); ];

//Echo("4.1...");
    For (j:= 1,j<=i-1,j++)
    [
//Echo("4.2...");
      H[i][j]:= N(-(y[i]*y[j])/(s[j]*s[j + 1]));
//Echo("4.3...");

/*If(Not IsNumber(H[i][j]),
[
Echo("************** H[i][j] = ",H[i][j]);
]
);*/

    ];
  ];

//Echo("5...");

  For (i:=2,i<=n,i++)
  [
    For (j:=i-1,j>= 1,j--)
    [
//Echo("5.1...");
      t:=Round(H[i][j]/H[j][j]);
//Echo("5.2...");
      y[j]:=y[j] + t*y[i];
//Echo("2..."," ",y[j]);
      For (k:=1,k<=j,k++) [ H[i][k]:=H[i][k]-t*H[j][k]; ];
      For (k:=1,k<=n,k++)
      [
        A[i][k]:=A[i][k]-t*A[j][k];
        B[k][j]:=B[k][j] + t*B[k][i];
      ];
    ];
  ];
  Local(found);
  found:=False;

//Echo("Enter loop");

  While (Not(found))
  [
    m:=1;
//Echo("maxi 1...",maxi);
    maxi:=N(gam*Abs(H[1][1]));
//Echo("maxi 2...",maxi);
    gami:=gam;
//Echo("3...");
    For (i:= 2,i<= n-1,i++)
    [
      gami:=gami*gam;
      tmp:=N(gami*Abs(H[i][i]));
      if (maxi < tmp)
      [
        maxi:=tmp;
//Echo("maxi 3...",maxi);
        m:=i;
      ];
    ];
//Echo("4...",maxi);
    tmp:=y[m + 1];
    y[m + 1]:=y[m];
    y[m]:=tmp;
//Echo("3..."," ",y[m]);
//Echo("5...");
    For (i:= 1,i<=n,i++)
    [
      tmp:=A[m + 1][ i];
      A[m + 1][ i]:=A[m][ i];
      A[m][ i]:=tmp;
      tmp:=B[i][ m + 1];
      B[i][ m + 1]:=B[i][ m];
      B[i][ m]:=tmp;
    ];
    For (i:=1,i<=n-1,i++)
    [
      tmp:=H[m + 1][ i];

      H[m + 1][ i]:=H[m][ i];
      H[m][ i]:=tmp;
    ];
//Echo("7...");
    if (m < n-1)
    [
      t0:=N(Eval(Sqrt(H[m][ m]^2 + H[m][ m + 1]^2)));

      t1:=H[m][ m]/t0;
      t2:=H[m][ m + 1]/t0;

//      If(IsZero(t0),t0:=N(Confidence));
//Echo("");
//Echo("H[m][ m] = ",N(H[m][ m]));
//Echo("H[m][ m+1] = ",N(H[m][ m+1]));

//If(IsZero(t0),[t1:=Infinity;t2:=Infinity;]);
//Echo("t0=",N(t0));
//Echo("t1=",N(t1));
//Echo("t2=",N(t2));

      For (i:=m,i<=n,i++)
      [
        t3:=H[i][ m];
        t4:=H[i][ m + 1];
//Echo("    t1 = ",t1);
//Echo("    t2 = ",t2);
//Echo("    t3 = ",t3);
//Echo("    t4 = ",t4);
        H[i][ m]:=t1*t3 + t2*t4;
//Echo("7.1... ",H[i][ m]);
        H[i][ m + 1]:= -t2*t3 + t1*t4;
//Echo("7.2... ",H[i][ m+1]);
      ];
    ];
//Echo("8...");
    For (i:= 1,i<= n,i++)
    [
      For (j := Minimum(i-1, m + 1),j>= 1,j--)
      [
        t:=Round(H[i][ j]/H[j][ j]);
//Echo("MATRIX",H[i][ j]," ",H[j][ j]);
//Echo("5... before"," ",y[j]," ",t," ",y[i]);
        y[j]:=y[j] + t*y[i];
//Echo("5... after"," ",y[j]);
        For (k:=1,k<=j,k++) H[i][ k]:=H[i][ k]-t*H[j][ k];
        For (k:= 1,k<=n,k++)
        [
          A[i][ k]:=A[i][ k]-t*A[j][ k];
          B[k][ j]:=B[k][ j] + t*B[k][ i];
        ];
      ];
    ];
//Echo("9...",N(H[1],10));

    /* BuiltinPrecisionSet(10);*/ /*low precision*/
//    maxi := N(Dot(H[1],  H[1]),10);
    maxi := N(Dot(H[1], H[1]));
//Echo("H[1] = ",H[1]);
//Echo("N(H[1]) = ",N(H[1]));
//Echo("N(Dot(H[1], H[1])) = ",N(Dot(H[1], H[1])));
//Echo("maxi 4...",maxi);

//Echo("9... maxi = ",maxi);

    For (j:=2,j<=n,j++)
    [
//Echo("9.1...");
      tmp:=N(Dot(H[j], H[j]),10);
//Echo("9.2...");
      if (maxi < tmp) [ maxi:=tmp; ];
//Echo("maxi 5...",maxi);
//Echo("9.3...");
    ];
//Echo("10...");
    norme:=N(Eval(1/Sqrt(maxi)));
    m:=1;
    mini:=N(Eval(Abs(y[1])));
//Echo("y[1] = ",y[1]," mini = ",mini);
    maxi:=mini;

//Echo("maxi 6...",maxi);
//Echo("11...");
    For (j:=2,j<=n,j++)
    [
      tmp:=N(Eval(Abs(y[j])));
      if (tmp < mini)
      [
        mini:=tmp;
        m:=j;
      ];
      if (tmp > maxi) [ maxi:=tmp; ];
//Echo("maxi 7...",maxi);
    ];
    /* following line may be commented */
//Echo({"Norm bound:",norme," Min=",mini," Conf=",mini/maxi," required ",Confidence});
    if ((mini/maxi) < Confidence) /*prefered to : if mini < 10^(- precision) then*/
    [
    /* following line may be commented */
/*      Echo({"Found with Confidence ",mini/maxi}); */
      BuiltinPrecisionSet(ndigits);
      result:=Transpose(B)[m];
      found:=True;
    ]
    else
    [
      maxi:=Abs(A[1][ 1]);
      For (i:=1,i<=n,i++)
      [
//Echo("i = ",i," n = ",n);
        For (j:=1,j<=n,j++)
        [
//Echo("j = ",j," n = ",n);
          tmp:=Abs(A[i][ j]);
          if (maxi < tmp) [ maxi:=tmp;];
        ];
      ];
//Echo("maxi = ",maxi);
      if (maxi > 10^(precision))
      [
        BuiltinPrecisionSet(ndigits);
        result:=Fail;
        found:=True;
      ];
      BuiltinPrecisionSet(precision+2);
//Echo("CLOSE");
    ];
  ];
  result;
];

/* end of file */

%/mathpiper



%mathpiper_docs,name="Pslq",categories="User Functions;Numbers (Operations)"
*CMD Pslq --- search for integer relations between reals
*STD
*CALL
	Pslq(xlist,precision)

*PARMS

{xlist} -- list of numbers

{precision} -- required number of digits precision of calculation

*DESC

This function is an integer relation detection algorithm. This means
that, given the numbers $x[i]$ in the list "xlist", it tries
to find integer coefficients $a[i]$ such that
$a[1]*x[1]$ + ... + $a[n]*x[n] = 0$.
The list of integer coefficients is returned.

The numbers in "xlist" must evaluate to floating point numbers if
the {N} operator is applied on them.

*E.G.

In> Pslq({ 2*Pi+3*Exp(1), Pi, Exp(1) },20)
Result: {1,-2,-3};

Note: in this example the system detects correctly that
$1 * (2*Pi+3*e) + (-2) * Pi + (-3) * e = 0$.

*SEE N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/0000755000175000017500000000000011722677327024432 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/OldSolve.mpw0000644000175000017500000001526011523200452026666 0ustar  giovannigiovanni%mathpiper,def="OldSolve"
/********** Solve'System **********/

// for now, just use a very simple backsubstitution scheme
Solve'System(_eqns, _vars) <-- Solve'SimpleBackSubstitution(eqns,vars);

// Check(False, "Unimplemented", "Solve'System: not implemented");

10 # Solve'SimpleBackSubstitution'FindAlternativeForms((_lx) == (_rx)) <--
[
  Local(newEq);
  newEq := (Simplify(lx) == Simplify(rx));
  If (newEq != (lx == rx) And newEq != (0==0),DestructiveAppend(eq,newEq));
  newEq := (Simplify(lx - rx) == 0);
  If (newEq != (lx == rx) And newEq != (0==0),DestructiveAppend(eq,newEq));
];
20 # Solve'SimpleBackSubstitution'FindAlternativeForms(_equation) <--
[
];
UnFence("Solve'SimpleBackSubstitution'FindAlternativeForms",1);

/* Solving sets of equations using simple backsubstitution.
 * Solve'SimpleBackSubstitution takes all combinations of equations and
 * variables to solve for, and it then uses SuchThat to find an expression
 * for this variable, and then if found backsubstitutes it in the other
 * equations in the hope that they become simpler, resulting in a final
 * set of solutions.
 */
10 # Solve'SimpleBackSubstitution(eq_IsList,var_IsList) <--
[
 If(InVerboseMode(), Echo({"Entering Solve'SimpleBackSubstitution"}));

  Local(result,i,j,nrvar,nreq,sub,nrSet,origEq);
  eq:=FlatCopy(eq);
  origEq:=FlatCopy(eq);
  nrvar:=Length(var);
  result:={FlatCopy(var)};
  nrSet := 0;

//Echo("Before: ",eq);
  ForEach(equation,origEq)
  [
//Echo("equation ",equation);
    Solve'SimpleBackSubstitution'FindAlternativeForms(equation);
  ];
//  eq:=Simplify(eq);
//Echo("After: ",eq);

  nreq:=Length(eq);

  /* Loop over each variable, solving for it */

/* Echo({eq});  */

  For(j:=1,j<=nreq And nrSet < nrvar,j++)
  [
    Local(vlist);
    vlist:=VarListAll(eq[j],`Lambda({pt},Contains(@var,pt)));
    For(i:=1,i<=nrvar And nrSet < nrvar,i++)
    [

//Echo("eq[",j,"] = ",eq[j]);
//Echo("var[",i,"] = ",var[i]);
//Echo("varlist = ",vlist);
//Echo();

      If(Count(vlist,var[i]) = 1,
         [
           sub := FunctionToList(eq[j]);
           sub := sub[2]-sub[3];
//Echo("using ",sub);
           sub:=SuchThat(sub,var[i]);
           If(InVerboseMode(), Echo({"From ",eq[j]," it follows that ",var[i]," = ",sub}));
           If(SolveFullSimplify=True,
             result:=Simplify(Subst(var[i],sub)result),
             result[1][i]:=sub
             );
//Echo("result = ",result," i = ",i);
           nrSet++;

//Echo("current result is ",result);
           Local(k,reset);
           reset:=False;
           For(k:=1,k<=nreq  And nrSet < nrvar,k++)
           If(Contains(VarListAll(eq[k],`Lambda({pt},Contains(@var,pt))),var[i]),
           [
             Local(original);
             original:=eq[k];
             eq[k]:=Subst(var[i],sub)eq[k];
             If(Simplify(Simplify(eq[k])) = (0 == 0),
               eq[k] := (0 == 0),
               Solve'SimpleBackSubstitution'FindAlternativeForms(eq[k])
               );
//             eq[k]:=Simplify(eq[k]);
//             eq[k]:=Simplify(eq[k]); //@@@??? TODO I found one example where simplifying twice gives a different result from simplifying once!
             If(original!=(0==0) And eq[k] = (0 == 0),reset:=True);
             If(InVerboseMode(), Echo({"   ",original," simplifies to ",eq[k]}));
           ]);
           nreq:=Length(eq);
           vlist:=VarListAll(eq[j],`Lambda({pt},Contains(@var,pt)));
           i:=nrvar+1;
           // restart at the beginning of the variables.
           If(reset,j:=1);
         ]);
    ];
  ];


//Echo("Finished finding results ",var," = ",result);
//  eq:=origEq;
//  nreq := Length(eq);
  Local(zeroeq,tested);
  tested:={};
//  zeroeq:=FillList(0==0,nreq);

  ForEach(item,result)
  [
/*
    Local(eqSimplified);
    eqSimplified := eq;
    ForEach(map,Transpose({var,item}))
    [
      eqSimplified := Subst(map[1],map[2])eqSimplified;
    ];
    eqSimplified := Simplify(Simplify(eqSimplified));

    Echo(eqSimplified);

    If(eqSimplified = zeroeq,
    [
      DestructiveAppend(tested,Map("==",{var,item}));
    ]);
*/
    DestructiveAppend(tested,Map("==",{var,item}));
  ];



/* Echo({"tested is ",tested});  */
 If(InVerboseMode(), Echo({"Leaving Solve'SimpleBackSubstitution"}));
  tested;
];




/********** OldSolve **********/
10 # OldSolve(eq_IsList,var_IsList) <-- Solve'SimpleBackSubstitution(eq,var);


90 # OldSolve((left_IsList) == right_IsList,_var) <--
      OldSolve(Map("==",{left,right}),var);


100 # OldSolve(_left == _right,_var) <--
     SuchThat(left - right , 0 , var);

/* HoldArgument("OldSolve",arg1); */
/* HoldArgument("OldSolve",arg2); */

%/mathpiper



%mathpiper_docs,name="OldSolve",categories="User Functions;Solvers (Symbolic)"
*CMD OldSolve --- old version of {Solve}
*STD
*CALL
	OldSolve(eq, var)
	OldSolve(eqlist, varlist)

*PARMS

{eq} -- single identity equation

{var} -- single variable

{eqlist} -- list of identity equations

{varlist} -- list of variables

*DESC

This is an older version of {Solve}. It is retained for two
reasons. The first one is philosophical: it is good to have multiple
algorithms available. The second reason is more practical: the newer
version cannot handle systems of equations, but {OldSolve} can.

This command tries to solve one or more equations. Use the first form
to solve a single equation and the second one for systems of
equations.

The first calling sequence solves the equation "eq" for the variable
"var". Use the {==} operator to form the equation.
The value of "var" which satisfies the equation, is returned. Note
that only one solution is found and returned.

To solve a system of equations, the second form should be used. It
solves the system of equations contained in the list "eqlist" for
the variables appearing in the list "varlist". A list of results is
returned, and each result is a list containing the values of the
variables in "varlist". Again, at most a single solution is
returned.

The task of solving a single equation is simply delegated to {SuchThat}. Multiple equations are solved recursively:
firstly, an equation is sought in which one of the variables occurs
exactly once; then this equation is solved with {SuchThat}; and finally the solution is substituted in the
other equations by {Eliminate} decreasing the number
of equations by one. This suffices for all linear equations and a
large group of simple nonlinear equations.

*E.G.

In> OldSolve(a+x*y==z,x)
Result: (z-a)/y;
In> OldSolve({a*x+y==0,x+z==0},{x,y})
Result: {{-z,z*a}};

This means that "x = (z-a)/y" is a solution of the first equation
and that "x = -z", "y = z*a" is a solution of the systems of
equations in the second command.

An example which {OldSolve} cannot solve:

In> OldSolve({x^2-x == y^2-y,x^2-x == y^3+y},{x,y});
Result: {};

*SEE Solve, SuchThat, Eliminate, PSolve, ==
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/SolveSystem.mpw0000644000175000017500000000720411554532234027445 0ustar  giovannigiovanni%mathpiper,def="SolveSystem"

/*-------------------------------------------------------------------
 *  NOTE:  this is a diversion of the SolveSystem modules to a
 *  new file all its own.  Previously, it was named "Solve'System",
 *  and was contained in the file OldSolve.mpw.
 *
 *  For the time being, we are just reconnecting the new file to
 *  point to the same old file  Solve'SimpleBackSubstitution .
 *  This will be changed soon.
 *    started   hso 100630.
 *    begin mods    100701
 *-------------------------------------------------------------------*/

//Retract("SolveSystem",*);
//Retract("VarsAndDegs",*);
//Retract("MakeCoefMatrix",*);
//Retract("SolveLinearSystem",*);
//Retract("SolveNonlinearSystem",*);

/*
10 # SolveSystem( eqns_IsList, vars_IsList ) <--
[
    // This is the old, now obsolete method
    If(InVerboseMode(),Tell("SolveSystem0",{eqns,vars}));
    Solve'SimpleBackSubstitution(eqns,vars);
];
*/

10 # SolveSystem( eqns_IsList, vars_IsList )_(Length(eqns)=1 And Length(vars)=1) <--
[
    {Solve(eqns[1],vars[1])};
];

12 # SolveSystem( eqns_IsList, vars_IsList ) <--
[
    // This is the first try at a better algorithm for doing this
    If(InVerboseMode(),Tell("SolveSystem",{eqns,vars}));
    
    Local(eq,expr,exprns,VaD,isLinearSet,ans);
    // express as set of polynomials, to be equated to zero
    exprns := {};
    ForEach(eq,eqns)
     [
         expr := If( IsEquation(eq), EquationLeft(eq)-EquationRight(eq), eq );
         DestructiveAppend(exprns,expr);
     ];
    If(InVerboseMode(),Tell(" ",exprns));
    
    // are all polynomials linear in given variables?
    VaD := VarsAndDegs(exprns,vars);
    If(InVerboseMode(),Tell(" ",VaD));
    isLinearSet := Maximum(Flatten(VaD,"List"))=1;
    If(InVerboseMode(),Tell(" ",isLinearSet));
    
    If( isLinearSet,
        ans:=SolveLinearSystem( exprns, vars ),
        ans:=SolveNonlinearSystem( exprns, vars )
    );

    If(ans != {}, ans := Map("==",{vars,ans}));

    If(InVerboseMode(),Tell("",ans));

    ans;
];


10 # VarsAndDegs(exs_IsList,vars_IsList) <--
[
    Local(ex,v,result);
    result := {};
    ForEach(ex,exs)
     [
         Local(res);
         res := {};
         ForEach(v,vars)
          [
              DestructiveAppend(res,Apply("Degree",{ex,v}));
          ];
          DestructiveAppend(result,res);
     ];
    result;
];



10 # SolveLinearSystem( polys_IsList, vars_IsList ) <--
[
    Local(A, E);

    If(InVerboseMode(),Tell("   SolveLinearSystem",{polys,vars}));
    // note  Coef(polys[1],vars[1],1) etc, to create matrix of coefficients
    Local(lhs,rhs,zeros);
    lhs := MakeCoefMatrix(polys,vars);
    If(InVerboseMode(),Tell("       ",lhs));
    zeros := ZeroVector(Length(vars));
    rhs := -WithValue(vars,zeros,polys);
    If(InVerboseMode(),Tell("       ",rhs));
    
    A := Transpose(Concat(Transpose(lhs),{rhs}));
    E := RREF(A);

    If(Contains(E,BaseVector(Dimensions(E)[2],Dimensions(E)[2])),
        {},
        MatrixColumn(E,Dimensions(E)[2]) - (ExtractSubMatrix(E, 1, 1, Length(E), Length(E)) - Identity(Length(E))) * vars);
];



10 # MakeCoefMatrix(polys_IsList,vars_IsList) <--
[
    If(InVerboseMode(),Tell("      MakeCoefMatrix",{polys,vars}));
    Local(p,v,result);
    result := {};
    ForEach(p,polys)
     [
         Local(res);
         res := {};
         ForEach(v,vars)
          [
              DestructiveAppend(res,Apply("Coef",{p,v,1}));
          ];
          DestructiveAppend(result,res);
     ];
    result;
];



%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/Assume.mpw0000644000175000017500000001040511523200452026370 0ustar  giovannigiovanni%mathpiper,def="Assume"

//Retract("Assume",*);
//Retract("AssumptionsAbout",*);
//Retract("UnAssume",*);
//Retract("IsAssumed",*);
//Retract("AssumptionsGet",*);

LocalSymbols(assumptions) [

assumptions := {};

10 # Assume( L_IsList ) <--
[
    If(InVerboseMode(),Tell("AssumeLst",L));
    Local(len,s);
    len := Length(L);
    If( len > 0, ForEach(s,L) [ Assume(s); ] );
    assumptions;
];


10 # Assume( _x -> _y ) <--
[ 
    If(InVerboseMode(),Tell("AssumeItem",{x,y}));
    Local(key,value);
    key   := Hold(x); 
    value := Hold(y);
    If(InVerboseMode(),Tell("       ",{key,value}));
    
    DestructiveAppend(assumptions,{Eval(key),Eval(value)});
    assumptions;
];


10 # AssumptionsGet() <-- assumptions;


10 # AssumptionsAbout(_key) <--
[
    Local(props);
    props := Select(assumptions,Lambda({X},X[1]=key));
    If( Length(props) > 0, Transpose(props)[2], {} );
];


10 # IsAssumed( _key, _valueExpected ) <-- Contains(AssumptionsAbout(key),valueExpected);


10 # UnAssume( _x )_(Contains(AssocIndices(assumptions),x)) <--
[
    Local(lst,len,jj);
    lst := Lambda({X},If(IsList(X),X[1])) /@ assumptions;
    jj := Find(lst,x);
    If( jj > 0, DestructiveDelete(assumptions,jj) );
    lst := Lambda({X},If(IsList(X),X[1])) /@ assumptions;
    jj := Find(lst,x);
    If( jj > 0, UnAssume(x), True );
];

];  //  LocalSymbols

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="Assume",categories="User Functions;Solvers (Symbolic)"
*CMD Assume --- a suite of functions for specifying and testing "assumptions" about unbound variables
*STD
*CALL
	Assume(v -> prop)
	Assume({v1 -> prop1, v2 -> prop2}}
	UnAssume(v)
	AssumptionsGet()
	AssumptionsAbout(v)
	IsAssumed(v,prop)

*PARMS

{v} -- an unbound variable or parameter
    
{v1,v2,...} -- different unbound variables or parameters

{prop} -- a 'property' to be attached to a variable or parameter

{prop1,prop2,...} -- different 'properties' to be attached to different variables

{assumptions} -- a normally-hidden associative list which stores the assumptions*

*DESC

This is a suite of functions which permit the user to specify (or 'attach')
{properties} to unbound variables or parameters to be used in the current
MathPiper session.

Once a property has been attached to a variable, the user, or some function 
called by the user, can query or test a given variable to see what properties
it has, or whether it has a specific property.  Actions may be taken based on
the results of such query or test.

Once Assume'd, properties remain associated with their variable until the
session ends, or until the user specifically calls {UnAssume} on that variable.
Once {UnAssume'd}, the variable thereafter has no properites, unless properties
are later added using {AddAssumption} or {AddAssumptions}.

Ordinarily, the user would specify all properties just once in a session.  However,
s/he may call Assume() multiple times in a session, and each such call simply augments
the 'hidden' list of assumptions by adding the new ones.  Note that new assumptions
for a given variable are {added}, and nothing is {replaced}.  Therefore, it is the
user's responsibility to avoid creating mutually-contradictory lists of properties.

NOTE:  All assumptions are lost once the session ends.

NOTE:  The user can employ these property lists as s/he sees fit.  Currently, none of
MathPiper's functions make any use of assumptions.  However, these can be very useful
especially in certain types of {Solve} or {Integrate} situations, so MathPiper's
functions are being modified to make use of assumptions where appropriate.
*E.G.


In> Assume(x->real)
Result: {{x,real}}
In> AssumptionsGet()
Result: {{x,real}}
In> IsAssumed(x,real)
Result: True
In> IsAssumed(z,complex)
Result: False
    
In> Assume({x->positive,y->positive})
Result: {{x,real},{x,positive},{y,positive}}
In> AssumptionsGet()
Result: {{x,real},{x,positive},{y,positive}}
In> AssumptionsAbout(x)
Result: {real,positive}
In> UnAssume(x)
Result: True
In> AssumptionsAbout(x)
Result: {}
In> AssumptionsGet()
Result: {{y,positive}}
*SEE Solve, Integrate
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/xPSolve.mpw0000644000175000017500000002677411523200452026553 0ustar  giovannigiovanni%mathpiper,def="xPSolve"

//Retract("xPSolve",*);
//Retract("xPSolveCubic",*);
//Retract("xPSC1",*);
//Retract("xPSC2",*);

/*-------------------------------------------------------
 * NOTES: TODO: RadSimp() may have a problem with 
 *        roots of complex numbers
 *-------------------------------------------------------*/

 
Rulebase("xPSolve",{uni});

Rule("xPSolve",1,1,IsUniVar(uni) And Degree(uni) = 1)
[
    If(iDebug,Tell("   xPSolve_1",uni));
    {-Coef(uni,0)/Coef(uni,1)};
];

Rule("xPSolve",1,1,IsUniVar(uni) And Degree(uni) = 2)
[
     If(iDebug,Tell("   xPSolve_2",uni));
     Local(a,b,c,d,q,r);
     c:=Coef(uni,0);
     b:=Coef(uni,1);
     a:=Coef(uni,2);
     If(iDebug,Tell("        ",{a,b,c}));
     d:=b*b-4*a*c;
     If(iDebug,Tell("              ",d));
     //q:=RadSimp(Sqrt(d)/(2*a));
     q:=Sqrt(d)/(2*a);
     If(iDebug,Tell("              ",q));
     r:=Simplify(-b/(2*a));
     If(iDebug,Tell("              ",r));
     {r+q,r-q};
];

/*
    How to solve the cubic equation?

   The equation is  a3 x^3 + a2 x^2 + a1 x + a0  = 0.  
   
   Get coefficients for a new polynomial, such that the coefficient of
   degree 2 is zero:
   Take f(x)=a0+a1*x+a2*x^2+a3*x^3 and substitute x = x' + adjust
   to get the expression  g(x) = b0+b1*x+b2*x^2+b3*x^3,
   where
      b3 = a3;
      b2 = 0 => adjust = (-a2)/(3*a3);
      b1 = 2*a2*adjust+3*a3*adjust^2+a1;
      b0 = a2*adjust^2+a3*adjust^3+adjust*a1+a0;

   After solving g(x') = 0, return x = x' + adjust.
   
   Since b2 = 0 by construction, we have the equation
      g(x) = x^3 + q x + r = 0,
   where
      r = b0/b3  and  q = b1/b3.
      
    Let x = a + b, so
	   a^3 + b^3 + 3 (a^2 b + b^2 a) + q (a + b) + r = 0
	   a^3 + b^3 + (3 a b + q) x + r = 0

	Let 3 a b + q = 0. This is permissible, for we can still find a+b == x

	a^3 + b^3 = -r
	(a b)^3 = -q^3/27

        So a^3 and b^3 are the roots of t^2 + r t - q^3/27 = 0

	Let
                a^3 = -r/2 + Sqrt(q^3/27+ r^2/4)
                b^3 = -r/2 - Sqrt(q^3/27+ r^2/4)
	Therefore there are three values for each of a and b.
	Clearly if ab = -q/3 is true then (wa)(w^2b) == (wb)(w^2a) == -q/3
*/

Rule("xPSolve",1,1,IsUniVar(uni) And Degree(uni) = 3 )
[
     If(iDebug,Tell("   xPSolve_3",uni));
     Local(p,q,r,s,t,w1,w2,a,b);
     Local(c0,c1,c3,adjust);

     //  w1 and w2 are constants: the "other" two cube-roots of unity
     w1 := (1/2)*Complex(-1, Sqrt(3));
     w2 := Conjugate(w1);
     If( iDebug, Tell("   ",{w1,w2}) );
     
     // Now we begin to find solutions
     adjust := (-uni[3][3])/(3*uni[3][4]);
     If( iDebug, Tell("   ",adjust));
     c3  := uni[3][4];
     c1  := (3*uni[3][4]*adjust+2*uni[3][3])*adjust+uni[3][2];
     c0  :=((uni[3][4]*adjust+uni[3][3])*adjust+uni[3][2])*adjust+uni[3][1];
     If( iDebug, Tell("   ",{c0,c1,c3})); 

     // Invariant: c0, c1, c2 are all REAL
     Assert("Invariant", "Coefficients Must be Real") And(Im(c0)=0,Im(c1)=0,Im(c2)=0);
     If( IsError("Invariant"), DumpErrors() );

     p :=c3;
     q :=c1/p;
     r :=c0/p;
     If( iDebug, Tell("   ",{p,q,r}));
     Local(a3,b3,qq,r1,r2,r3);
     qq := Sqrt(q^3/27 + r^2/4);
     a3 := -r/2 + qq;
     b3 := -r/2 - qq;
     // NOTE: If q < 0 and r = 0, then qq is pure imaginary, a3 = qq, b3 = -qq.
     If( iDebug, [Tell("   ",{qq,a3,b3}); Tell("   ",N(a3+b3+r)); Tell("   ",N(a3-b3-2*qq));]);
     a  := (a3)^(1/3);
     b  := (b3)^(1/3);
     If( iDebug, Tell("   ",{a,b}));
     r1 := a+b+adjust;
     r2 := w1*a+w2*b+adjust;
     r3 := w2*a+w1*b+adjust;
     // NOTE: If q < 0 and r = 0, then r3 = adjust  and  r2 = Sqrt(3)*qqi + adjust
     If( iDebug,
       [
          Tell("   ",r1);
          Tell("   ",r2);
          Tell("   ",r3);
       ]
     );
     {r1,r2,r3};
];


/*
How to solve the quartic equation?

The equation is x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = 0.
The idea is to write the left-hand side as the difference of two
squares: (x^2 + p x + q)^2 - (s x + t)^2.
Eliminating the parentheses and equation coefficients yields four
equations for the four unknowns p, q, s and t:
  a1 = 2p              (1)
  a2 = p^2 + 2q - s^2  (2)
  a3 = 2pq - 2st       (3)
  a4 = q^2 - t^2       (4)
From the first equation, we find that p = a1/2. Substituting this in
the other three equations and rearranging gives
  s^2 = a1^2/4 - a2 + 2q   (5)
  2st = a1 q - a3          (6)
  t^2 = q^2 - a4           (7)
We now take the square (6) and substitute (5) and (7):
  4 (a1^2/4 - a2 + 2q) (q^2 - a4) = (a1 q - a3)^2  <==>
  8 q^3 - 4 a2 q^2 + (2 a1 a3 - 8 a4) q + 4 a2 a4 - a1^2 a4 - a3^2 = 0.
Miraculously, we got a cubic equation for q. Suppose we can solve this
equation. We can then compute t from (7): t = sqrt(q^2 - a4). If t is
nonzero, we can compute s from (6). Note that we cannot compute s from
(5), since we introduced an extra solution when squaring (6). However,
if t is zero, then no extra solution was introduced and we can safely
use (5). Having found the values of p, q, s and t, we can factor the
difference of squares and solve the quartic:
  x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = (x^2 + p x + q)^2 - (s x + t)^2
                 = (x^2 + p x + q + s x + t) (x^2 + p x + q - sx - t).
The four roots of the quartic are the two roots of the first quadratic
factor plus the two roots of the second quadratic factor.
*/

Rule("xPSolve",1,1,IsUniVar(uni) And Degree(uni) = 4 )
[
    If(iDebug,Tell("   xPSolve_4",uni));
    Local(coef4,a1,a2,a3,a4,y,y1,z,t,s);

    coef4:=Coef(uni,4);
    a1:=Coef(uni,3)/coef4;
    a2:=Coef(uni,2)/coef4;
    a3:=Coef(uni,1)/coef4;
    a4:=Coef(uni,0)/coef4;
    If( iDebug, Tell("        ",{a1,a2,a3,a4}));

    /* y1 = 2q, with q as above. */
    Local(ys);
    ys := xPSolveCubic(y^3-a2*y^2+(a1*a3-4*a4)*y+(4*a2*a4-a3^2-a1^2*a4));
    If( iDebug, [NewLine(); Tell("        ",ys[1]);] );
    y1:=First(ys);
    If( iDebug, Tell("        ",y1));
    t := Sqrt(y1^2/4-a4);
    If( iDebug, Tell("        ",t));
    If(t=0, s:=Sqrt(y1+a1^2/4-a2), s:=(a1*y1-2*a3)/(4*t));
    If( iDebug, Tell("        ",s));
    
    Local(q11,q12,q21,q2,quad1,quad2);
    q11 := a1/2+s;    q12 := y1/2+t;
    q21 := a1/2-s;    q22 := y1/2-t;
    If( iDebug, Tell("        ",{q11,q12}));
    If( iDebug, Tell("        ",{q21,q22}));
    quad1 := z^2 + q11*z + q12;
    quad2 := z^2 + q21*z + q22;
    If( iDebug, Tell("        ",{quad1,quad2}));
    
    Local(r1,r2,r3,r4);
    {r1,r2} := xPSolve( quad1, z );
    {r3,r4} := xPSolve( quad2, z );
    r1 := NearRational(N(r1,10),8);
    r2 := NearRational(N(r2,10),8);
    r3 := NearRational(N(r3,10),8);
    r4 := NearRational(N(r4,10),8);
    
    {r1,r2,r3,r4};
];


Function("xPSolve",{expr,var})
[
    If( Not IsBound(iDebug), iDebug := False );
    If(iDebug,Tell("xPSolve_notUni",{expr,var}));  
    Local(lhs,rhs,cc,pp,uni,solnpp,solncc,soln);
    If( IsEquation(expr), 
      [
         If(iDebug,Tell("   is Equation"));
         lhs  := EquationLeft(expr);
         rhs  := EquationRight(expr);
         expr := lhs - rhs;
      ]
    );
    If(iDebug,Tell("   ",expr));
    cc := xContent(expr);
    pp := xPrimitivePart(expr,cc);
    If(iDebug,Tell("   ",{cc,pp}));
    solnpp := xPSolve(MakeUni(pp,var));
    If(iDebug,Tell("   ",solnpp));
    If( Length(VarList(cc)) > 0 And Contains(VarList(cc),var ),
      [
         solncc := xPSolve(MakeUni(cc,var));
         If(iDebug,Tell("   ",solncc));
         soln   := Concat(solncc,solnpp);
      ],
      [
         soln   := solnpp;
      ]
    );
    soln;
];


10 # xPSolveCubic( poly_IsPolynomial )_
                   (Length(VarList(poly))=1 And Degree(poly)=3) <--
[
    If( iDebug, Tell("  xPSolveCubic",poly) );
    Local(var,coeffs,ans);
    var    := VarList(poly)[1];
    coeffs := Coef(poly,var,3 .. 0);
    If( iDebug, Tell("     ",{var,coeffs}));
    ans    := xPSC1(coeffs);    
];
UnFence("xPSolveCubic",1);


10 # xPSC1( coeffs_IsList ) <--
[
    If( iDebug, Tell("    xPSC1",coeffs) );
    /*
     * This function solves a general cubic equation with REAL coefficients.
     * It is based on an algorithm described in the book
     * "Handbook of Applied Mathematics for Engineers and Scientists",
     * by Max Curtz.
     */
     Local(f,g,h,j,iType,ans);
     f := coeffs[2]/coeffs[1]/3;
     g := coeffs[3]/coeffs[1]/3 - f^2;
     h := coeffs[4]/coeffs[1]/2 + f^3 - f * coeffs[3]/coeffs[1]/2;
     j := g^3 + h^2;
     If( iDebug, Tell("     ",{f,g,h,j}) );
     ans := xPSC2( {f,g,h,j} );
];


10 # xPSC2( xs_IsList )_(xs[4]=0) <--
[
    If( iDebug, Tell("        Type 1",xs) );                 
    Local(f,g,h,j,m,r1,r2,r3,ans);
    {f,g,h,j} := FlatCopy(xs);
    m   := 2*(-h)^(1/3);
    r1  := NearRational(N(m - f,10),8);
    r2  := NearRational(N(-m/2 - f,10),8);
    r3  := NearRational(N(-m/2 - f,10),8);
    ans := {r1,r2,r3};
];

10 # xPSC2( xs_IsList )_(xs[4]>0) <--
[
    If( iDebug, Tell("        Type 2",xs) ); 
    Local(f,g,h,j,k,l1,l2,m,n,r1,r2,r3,ans); 
    {f,g,h,j} := FlatCopy(xs);
    k   := Sqrt(j);
    l1  := (-h + k)^(1/3);
    l2  := (-h - k)^(1/3);
    m   := l1 + l2;
    n   := (l1 - l2)*Sqrt(3)/2;
    r1  := NearRational(N(m - f,10),8);
    r2  := NearRational(N(-m/2 - f + I*n,10),8);
    r3  := NearRational(N(Conjugate(r2),10),8);
    ans := {r1,r2,r3};
    
];

10 # xPSC2( xs_IsList )_(xs[4]<0 And xs[3]=0) <--
[
    If( iDebug, Tell("        Type 3a",xs) );
    Local(f,g,h,j,p,r1,r2,r3,ans);
    {f,g,h,j} := FlatCopy(xs);
    p   := 2*Sqrt(-g);
    r1  := NearRational(N(-f,10),8);
    r2  := NearRational(N( p*Sqrt(3)/2 - f,10),8);
    r3  := NearRational(N(-p*Sqrt(3)/2 - f,10),8);
    ans := {r1,r2,r3};
];

10 # xPSC2( xs_IsList )_(xs[4]<0 And xs[3]>0) <--
[
    If( iDebug, Tell("        Type 3b",xs) );
    Local(p,x,alpha,beta,gama,r1,r2,r3,ans);
    {f,g,h,j} := FlatCopy(xs);
    p     := 2*Sqrt(-g);
    k     := Sqrt(-j);
    alpha := ArcTan(k/(-h));   //  alpha should be Acute
    beta  := Pi + alpha;
    gama  := beta / 3;
    If( iDebug,
      [
         Tell("          ",{p,k});
         Tell("          ",{alpha,beta,gama});
         Tell("          ",57.2957795*N({alpha,beta,gama}));
         Tell("          ",N(Cos(gama)));
      ]
    );
    r1    := NearRational(N(p * Cos(gama) - f,10),8);
    r2    := NearRational(N(p * Cos(gama+2*Pi/3) - f,10),8);
    r3    := NearRational(N(p * Cos(gama+4*Pi/3) - f,10),8);
    ans   := {r1,r2,r3};
];

10 # xPSC2( xs_IsList )_(xs[4]<0 And xs[3]<0) <--
[
    If( iDebug, Tell("        Type 3c",xs) );
    Local(f,g,h,j,p,k,alpha,beta,gama,r1,r2,r3,ans);
    {f,g,h,j} := FlatCopy(xs);
    p     := 2*Sqrt(-g);
    k     := Sqrt(-j);
    alpha := ArcTan(k/(-h));   //  alpha should be Acute
    beta  := alpha;
    gama  := beta / 3;
    If(iDebug,[Tell("          ",{p,k}); Tell("          ",{alpha,beta,gama});]);
    r1    := NearRational(N(p * Cos(gama) - f,10),8);
    r2    := NearRational(N(p * Cos(gama+2*Pi/3) - f,10),8);
    r3    := NearRational(N(p * Cos(gama+4*Pi/3) - f,10),8);
    ans   := {r1,r2,r3};
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="xPSolve",categories="User Functions;Solvers (Symbolic)"
*CMD xPSolve --- solve a polynomial equation
*STD
*CALL
	xPSolve(poly, var)

*PARMS

{poly} -- a polynomial in "var"

{var} -- a variable

*DESC

This commands returns a list containing the roots of "poly",
considered as a polynomial in the variable "var". If there is only
one root, it is not returned as a one-entry list but just by
itself. A double root occurs twice in the result, and similarly for
roots of higher multiplicity. All polynomials of degree up to 4 are
handled.

*E.G.

In> xPSolve(b*x+a,x)
Result: -a/b;
In> xPSolve(c*x^2+b*x+a,x)
Result: {(Sqrt(b^2-4*c*a)-b)/(2*c),(-(b+
	Sqrt(b^2-4*c*a)))/(2*c)};

*SEE Solve, Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/CheckSolution.mpw0000644000175000017500000000357311517224250027722 0ustar  giovannigiovanni%mathpiper,def="CheckSolution"

//Retract("CheckSolution",*);

10 # CheckSolution( _expr, _var, solution_IsList )_(Not IsFreeOf(var,expr)) <--
  [
      Local(expr0,result,s,r);
      If( IsEquation(expr),
          Bind(expr0,EquationLeft(expr)-EquationRight(expr)),
          Bind(expr0,expr)
      );
      result := {};
      ForEach(s,solution) 
        [
            r := ( expr0 Where s );
            If(r=0,Push(result,s));
        ];
        Reverse(result);
  ];
  
  
20 # CheckSolution( _expr, _var, _solution ) <-- False;

%/mathpiper





%mathpiper_docs,name="CheckSolution",categories="User Functions;Solvers (Symbolic)"

*CMD CheckSolution --- Check the validity of solutions returned by the {Solve} function.
*STD
*CALL
	CheckSolution(expr,var,solution)

*PARMS

{expr}     -- a mathematical expression
{var}      -- a varible identifier
{solution} -- a List containing solutions to the equation.


*DESC

The function {Solve} will attempt to find solutions to the equation
{expr}, if {expr} is an actual equatio), or to the equivalent equation
represented by {expr==0} if {expr} is NOT an equation.

Solutions returned by {Solve} will be in the form of a List, such as
{{var==something,var==something_else}}.

For certain types of expressions or equation, {Solve} might return
invalid solutions as well as valid ones in the output List.  To check
the list of solutions, call the function CheckSolutions().  This function
will return a list containing only the valid solutions from among those
in the list (if any).  If none of the "solutions" is valid, this 
function will return the empty list.

*E.G.

In> ss1 := Solve(x^2==4,x)

Result: {x==2,x==(-2)}

In> CheckSolution(x^2==4,x,ss1)

Result: {x==2,x==(-2)}

In> CheckSolution(x^2==4,x,{x==2,x==3})   // Deliberately incorrect

Result: {x==2}

%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/SolveMatrix.mpw0000644000175000017500000000237011523200452027412 0ustar  giovannigiovanni%mathpiper,def="SolveMatrix"

Function("SolveMatrix",{matrix,vector})
[
  If(InVerboseMode(),Tell("   SolveMatrix",{matrix,vector}));
  Local(perms,indices,inv,det,n);
  n:=Length(matrix);
  indices:=Table(i,i,1,n,1);
  perms:=PermutationsList(indices);
  inv:=ZeroVector(n);
  det:=0;
  ForEach(item,perms)
  [
    Local(i,lc);
    lc := LeviCivita(item);
    det:=det+Product(i,1,n,matrix[i][item[i] ])* lc;
    For(i:=1,i<=n,i++)
        [
         inv[i] := inv[i]+
           Product(j,1,n,
           If(item[j] =i,vector[j ],matrix[j][item[j] ]))*lc;
        ];
  ];
  Check(det != 0, "Math", "Zero determinant");
  (1/det)*inv;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="SolveMatrix",categories="User Functions;Linear Algebra;Solvers (Symbolic)"
*CMD SolveMatrix --- solve a linear system
*STD
*CALL
	SolveMatrix(M,v)

*PARMS

{M} -- a matrix

{v} -- a vector

*DESC

{SolveMatrix} returns the vector $x$ that satisfies
the equation $M*x = v$. The determinant of $M$ should be non-zero.

*E.G.

In> A := {{1,2}, {3,4}};
Result: {{1,2},{3,4}};
In> v := {5,6};
Result: {5,6};
In> x := SolveMatrix(A, v);
Result: {-4,9/2};
In> A * x;
Result: {5,6};

*SEE Inverse, Solve, PSolve, Determinant
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/PSolve.mpw0000644000175000017500000000017711436314455026364 0ustar  giovannigiovanni%mathpiper,def="PSolve"

PSolve( _uni ) <-- YacasPSolve( uni );

PSolve( _uni, _var ) <-- YacasPSolve( uni, var );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/jSolveUniPoly.mpw0000644000175000017500000000337611517224250027733 0ustar  giovannigiovanni%mathpiper,def="jSolveUniPoly"

//Retract("jSolveUniPoly",*);

10 # jSolveUniPoly( _lhs==_rhs, var_IsAtom ) <--
[
   jSolveUniPoly(lhs-rhs,var);
];

15 # jSolveUniPoly( poly_IsPolynomial, var_IsAtom )_(Length(VarList(poly))=1) <--
[
   If(InVerboseMode(),Tell(jSolveUniPoly,{poly,var}));
   Local(factorList,f,fac,mult,ii,answer);
   factorList := Factors(poly);
   If(InVerboseMode(),Tell("   ",factorList));
   answer := {};
   ForEach(f,factorList)
    [
        {fac,mult} := f;
        soln := Solve(fac,var);
        If(InVerboseMode(),[Tell("      ",{fac,mult});Tell("      ",soln);]);
        ForEach(ii,1 .. mult)
         [  DestructiveAppend(answer,soln); ];
    ];
    answer;
];

20 # jSolveUniPoly( poly_IsPolynomial, var_IsAtom ) <-- Failed;


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="jSolveUniPoly",categories="User Functions;Solvers (Symbolic)"
*CMD jSolveUniPoly --- solve (find the roots of) a strictly univariate polynomial using JAS
*STD
*CALL
	jSolveUniPoly(eq, var)

*PARMS

{eq} -- equation to solve

{var} -- variable to solve for

*DESC

This command tries to solve the polynomial equation by factoring. 
If {eq} does not contain the {==} operator, it is assumed that the 
user wants to solve $eq ==0$. 
The result is a list of equations of the form {var == value}, each
representing a solution of the given equation. The {Where} operator
can be used to substitute this solution in another expression. If the
given equation {eq} does not have any solutions, or if {jSolveUniPoly} is
unable to find any, then an empty list is returned.

*SEE Solve, PSolve, Where, ==
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/SuchThat.mpw0000644000175000017500000000726611523200452026671 0ustar  giovannigiovanni%mathpiper,def="SuchThat"

10 # ContainsExpression(_body,_body) <-- True;
15 # ContainsExpression(body_IsAtom,_expr) <-- False;
20 # ContainsExpression(body_IsFunction,_expr) <--
[
  Local(result,args);
  result:=False;
  args:=Rest(FunctionToList(body));
  While(args != {})
  [
    result:=ContainsExpression(First(args),expr);
    args:=Rest(args);
    if (result = True) (args:={});
  ];
  result;
];


SuchThat(_function,_var) <-- SuchThat(function,0,var);

10 # SuchThat(_left,_right,_var)_(left = var) <-- right;

/*This interferes a little with the multi-equation solver...
15 # SuchThat(_left,_right,_var)_CanBeUni(var,left-right) <--
     PSolve(MakeUni(left-right,var));
*/

20 # SuchThat(left_IsAtom,_right,_var) <-- var;

30 # SuchThat((_x) + (_y),_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right-y , var);
30 # SuchThat((_y) + (_x),_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right-y , var);

30 # SuchThat(Complex(_r,_i),_right,_var)_ContainsExpression(r,var) <--
    SuchThat(r , right-I*i , var);
30 # SuchThat(Complex(_r,_i),_right,_var)_ContainsExpression(i,var) <--
    SuchThat(i , right+I*r , var);

30 # SuchThat(_x * _y,_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right/y , var);
30 # SuchThat(_y * _x,_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right/y , var);

30 # SuchThat(_x ^ _y,_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right^(1/y) , var);
30 # SuchThat(_x ^ _y,_right,_var)_ContainsExpression(y,var) <--
    SuchThat(y , Ln(right)/Ln(x) , var);

30 # SuchThat(Sin(_x),_right,_var) <--
    SuchThat(x , ArcSin(right) , var);
30 # SuchThat(ArcSin(_x),_right,_var) <--
    SuchThat(x , Sin(right) , var);

30 # SuchThat(Cos(_x),_right,_var) <--
    SuchThat(x , ArcCos(right) , var);
30 # SuchThat(ArcCos(_x),_right,_var) <--
    SuchThat(x , Cos(right) , var);

30 # SuchThat(Tan(_x),_right,_var) <--
    SuchThat(x , ArcTan(right) , var);
30 # SuchThat(ArcTan(_x),_right,_var) <--
    SuchThat(x , Tan(right) , var);

30 # SuchThat(Exp(_x),_right,_var) <--
    SuchThat(x , Ln(right) , var);
30 # SuchThat(Ln(_x),_right,_var) <--
    SuchThat(x , Exp(right) , var);

30 # SuchThat(_x / _y,_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right*y , var);
30 # SuchThat(_y / _x,_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , y/right , var);

30 # SuchThat(- (_x),_right,_var) <--
    SuchThat(x , -right , var);

30 # SuchThat((_x) - (_y),_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , right+y , var);
30 # SuchThat((_y) - (_x),_right,_var)_ContainsExpression(x,var) <--
    SuchThat(x , y-right , var);

30 # SuchThat(Sqrt(_x),_right,_var) <--
    SuchThat(x , right^2 , var);

%/mathpiper



%mathpiper_docs,name="SuchThat",categories="User Functions;Solvers (Symbolic)"
*CMD SuchThat --- special purpose solver
*STD
*CALL
	SuchThat(expr, var)

*PARMS

{expr} -- expression to make zero

{var} -- variable (or subexpression) to solve for

*DESC

This functions tries to find a value of the variable "var" which
makes the expression "expr" zero. It is also possible to pass a
subexpression as "var", in which case {SuchThat}
will try to solve for that subexpression.

Basically, only expressions in which "var" occurs only once are
handled; in fact, {SuchThat} may even give wrong
results if the variables occurs more than once. This is a consequence
of the implementation, which repeatedly applies the inverse of the top
function until the variable "var" is reached.

*E.G.

In> SuchThat(a+b*x, x)
Result: (-a)/b;
In> SuchThat(Cos(a)+Cos(b)^2, Cos(b))
Result: Cos(a)^(1/2);
In> A:=Expand(a*x+b*x+c, x)
Result: (a+b)*x+c;
In> SuchThat(A, x)
Result: (-c)/(a+b);

*SEE Solve, OldSolve, Subst, Simplify
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/solve.mpw0000644000175000017500000003502411551567551026310 0ustar  giovannigiovanni%mathpiper,def="Solve"

//Retract("Solve",*);

/*
 * Strategy for Solve(expr, x):
 *
 * 10.  Call SolveSystem for systems of equations [now in its own file]
 * 20.  Check arguments.
 * 30.  Get rid of "==" in 'expr'.
 * 40.  Special cases.
 * 50.  If 'expr' is a polynomial in 'x', try to use PSolve.
 * 60.  If 'expr' is a product, solve for either factor.
 * 70.  If 'expr' is a quotient, solve for the denominator.
 * 80.  If 'expr' is a sum and one of the terms is free of 'x',
 *      try to use Solve'Simple.
 * 90.  If every occurance of 'x' is in the same context, use this to reduce
 *      the equation. For example, in 'Cos(x) + Cos(x)^2 == 1', the variable
 *      'x' always occurs in the context 'Cos(x)', and hence we can attack
 *      the equation by first solving 'y + y^2 == 1', and then 'Cos(x) == y'.
 *      This does not work for 'Exp(x) + Cos(x) == 2'.
 * 100. Apply Simplify to 'expr', and try again.
 * 110. Give up.
 */

LocalSymbols(res)
[
  10  # Solve(expr_IsList, var_IsList) <-- SolveSystem(expr, var);
  12  # Solve(_expr, var_IsList)_(Length(var)=1) <--
        [ {Solve(expr,var[1])}; ];
  
  20  # Solve(_expr, _var)_(IsNumber(var) Or IsString(var)) <--
        [ Assert("Solve'TypeError", "Second argument, ":(PipeToString() Write(var)):", is not the name of a variable") False; {}; ];
  22  # Solve(_expr, _var)_(Not IsAtom(var) And Not HasExpr(expr,var)) <--
        [ Assert("Solve'TypeError", "Second argument, ":(PipeToString() Write(var)):", is not the name of a variable") False; {}; ];
  24  # Solve(False,_var) <-- Check(False, "Argument", "Bad input: possibly '=' instead of '==' ");

  30  # Solve(_lhs == _rhs, _var) <-- Solve(lhs - rhs, var);
  40  # Solve(0, _var) <-- {var == var};
  41  # Solve(a_IsConstant, _var) <-- {};
  42  # Solve(_expr, _var)_(Not HasExpr(expr,var)) <--
        [ Assert("Solve", "expression ":(PipeToString() Write(expr)):" does not depend on ":PipeToString() Write(var)) False; {}; ];
  50  # Solve(_expr, _var)_((res := Solve'Poly(expr, var)) != Failed) <-- res;
  60  # Solve(_e1 * _e2, _var) <-- [
      Local(t,u,s);
      t := Union(Solve(e1,var), Solve(e2,var));
      u := {};
      ForEach(s, t) [
         Local(v1,v2);
         v1 := WithValue(var, s[2], e1);
         v2 := WithValue(var, s[2], e2);
         If(Not (IsInfinity(v1) Or (v1 = Undefined) Or
                 IsInfinity(v2) Or (v2 = Undefined)), 
             DestructiveAppend(u, s));
      ];
      u;
  ];
  70  # Solve(_e1 / _e2, _var) <-- [
      Local(tn, t, s);
      tn := Solve(e1, var);
      t := {};
      ForEach(s, tn)
          If(Not(IsZero(WithValue(var, s[2], e2))), 
              DestructiveAppend(t, s)
          );
      t;
  ];
  80  # Solve(_e1 + _e2, _var)_(Not HasExpr(e2,var) And (res := Solve'Simple(e1,-e2,var)) != Failed) <-- res;
  80  # Solve(_e1 + _e2, _var)_(Not HasExpr(e1,var) And (res := Solve'Simple(e2,-e1,var)) != Failed) <-- res;
  80  # Solve(_e1 - _e2, _var)_(Not HasExpr(e2,var) And (res := Solve'Simple(e1,e2,var)) != Failed) <-- res;
  80  # Solve(_e1 - _e2, _var)_(Not HasExpr(e1,var) And (res := Solve'Simple(e2,e1,var)) != Failed) <-- res;
  85  # Solve(_expr, _var)_((res := Solve'Simple(expr, 0, var)) != Failed) <-- res;
  90  # Solve(_expr, _var)_((res := Solve'Reduce(expr, var)) != Failed) <-- res;
  95  # Solve(_expr, _var)_((res := Solve'Divide(expr, var)) != Failed) <-- res;
  100 # Solve(_expr, _var)_((res := Simplify(expr)) != expr) <-- Solve(res, var);
  110 # Solve(_expr, _var) <--
        [ Assert("Solve'Fails", "cannot solve equation ":(PipeToString() Write(expr)):" for ":PipeToString() Write(var)) False; {}; ];
];

/********** Solve'Poly **********/

/* Tries to solve by calling PSolve */
/* Returns Failed if this doesn't work, and the solution otherwise */

/* CanBeUni is not documented, but defined in univar.rep/code.mpi */
/* It returns True iff 'expr' is a polynomial in 'var' */

10 # Solve'Poly(_expr, _var)_(Not CanBeUni(var, expr)) <-- Failed;

/* The call to PSolve can have three kind of results
 *   1) PSolve returns a single root
 *   2) PSolve returns a list of roots
 *   3) PSolve remains unevaluated
 */

20 # Solve'Poly(_expr, _var) <--
LocalSymbols(x)
[
  Local(roots);
  roots := PSolve(expr, var);
  If(Type(roots) = "YacasPSolve",
     If(roots = YacasPSolve(0), {var == var}, Failed),   /* Case 3 */
     If(Type(roots) = "List",
        MapSingle({{x},var==x}, roots),                  /* Case 2 */
        {var == roots}));                                /* Case 1 */
];

/********** Solve'Reduce **********/

/* Tries to solve by reduction strategy */
/* Returns Failed if this doesn't work, and the solution otherwise */

10 # Solve'Reduce(_expr, _var) <--
[
  ClearError("Solve'Fails"); // ..in case one was left over from prior failure
  Local(context, expr2, var2, res, sol, sol2, i);
  context := Solve'Context(expr, var);
  If(context = False,
     res := Failed,
     [
       expr2 := Eval(Subst(context, var2) expr);
       If(CanBeUni(var2, expr2) And (Degree(expr2, var2) = 0 Or (Degree(expr2, var2) = 1 And Coef(expr2, var2, 1) = 1)),
          res := Failed, /* to prevent infinite recursion */
          [
    	    sol2 := Solve(expr2, var2);
	    If(IsError("Solve'Fails"),
	       [
	         ClearError("Solve'Fails");
		 res := Failed;
               ],
    	       [
    		 res := {};
    		 i := 1;
    		 While(i <= Length(sol2) And res != Failed) [
    		   sol := Solve(context == (var2 Where sol2[i]), var);
	           If(IsError("Solve'Fails"),
		      [
		        ClearError("Solve'Fails");
		        res := Failed;
                      ],
    		      res := Union(res, sol));
    		   i++;
    		 ];
    	       ]);
      	   ]);
     ]);
  res;
];

/********** Solve'Context **********/

/* Returns the unique context of 'var' in 'expr', */
/* or {} if 'var' does not occur in 'expr',       */
/* or False if the context is not unique.         */

10 # Solve'Context(expr_IsAtom, _var) <-- If(expr=var, var, {});

20 # Solve'Context(_expr, _var) <--
[
  Local(lst, foundVarP, context, i, res);
  lst := FunctionToList(expr);
  foundVarP := False;
  i := 2;
  While(i <= Length(lst) And Not foundVarP) [
    foundVarP := (lst[i] = var);
    i++;
  ];
  If(foundVarP,
     context := expr,
     [
       context := {};
       i := 2;
       While(i <= Length(lst) And context != False) [
         res := Solve'Context(lst[i], var);
	 If(res != {} And context != {} And res != context, context := False);
	 If(res != {} And context = {}, context := res);
	 i++;
       ];
     ]);
  context;
];

/********** Solve'Simple **********/

/* Simple solver of equations
 *
 * Returns (possibly empty) list of solutions,
 * or Failed if it cannot handle the equation
 *
 * Calling format: Solve'Simple(lhs, rhs, var)
 *                 to solve 'lhs == rhs'.
 *
 * Note: 'rhs' should not contain 'var'.
 */

20 # Solve'Simple(_e1 + _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- { var == rhs-e2 };
20 # Solve'Simple(_e1 + _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- { var == rhs-e1 };

20 # Solve'Simple(_e1 - _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- { var == rhs+e2 };
20 # Solve'Simple(_e1 - _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- { var == e1-rhs };
20 # Solve'Simple(-(_e1), _rhs, _var)_(e1 = var) <-- { var == -rhs };

20 # Solve'Simple(_e1 * _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- { var == rhs/e2 };
20 # Solve'Simple(_e1 * _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- { var == rhs/e1 };

20 # Solve'Simple(_e1 / _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- { var == rhs*e2 };
10 # Solve'Simple(_e1 / _e2, 0,    _var)_(e2 = var And Not HasExpr(e1,var)) <-- { };
20 # Solve'Simple(_e1 / _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- { var == e1/rhs };

LocalSymbols(x)
[
  20 # Solve'Simple(_e1 ^ _n, _rhs, _var)_(e1 = var And IsPositiveInteger(n))
       <-- MapSingle({{x}, var == rhs^(1/n)*x}, Exp(2*Pi*I*(1 .. n)/n));
  20 # Solve'Simple(_e1 ^ _n, _rhs, _var)_(e1 = var And IsNegativeInteger(n))
       <-- MapSingle({{x}, var == rhs^(1/n)*x}, Exp(2*Pi*I*(1 .. (-n))/(-n)));
];

20 # Solve'Simple(_e1 ^ _e2, _rhs, _var)
     _ (IsPositiveReal(e1) And e1 != 0 And e2 = var And IsPositiveReal(rhs) And rhs != 0)
     <-- { var == Ln(rhs)/Ln(e1) };

/* Note: These rules do not take the periodicity of the trig. functions into account */
10 # Solve'Simple(Sin(_e1), 1,    _var)_(e1 = var) <-- { var == 1/2*Pi };
10 # Solve'Simple(Sin(_e1), _rhs, _var)_(e1 = var And rhs = -1) <-- { var == 3/2*Pi };
20 # Solve'Simple(Sin(_e1), _rhs, _var)_(e1 = var) <-- { var == ArcSin(rhs), var == Pi-ArcSin(rhs) };
10 # Solve'Simple(Cos(_e1), 1,    _var)_(e1 = var) <-- { var == 0 };
10 # Solve'Simple(Cos(_e1), _rhs, _var)_(e1 = var And rhs = -1) <-- { var == Pi };
20 # Solve'Simple(Cos(_e1), _rhs, _var)_(e1 = var) <-- { var == ArcCos(rhs), var == -ArcCos(rhs) };
20 # Solve'Simple(Tan(_e1), _rhs, _var)_(e1 = var) <-- { var == ArcTan(rhs) };

20 # Solve'Simple(ArcSin(_e1), _rhs, _var)_(e1 = var) <-- { var == Sin(rhs) };
20 # Solve'Simple(ArcCos(_e1), _rhs, _var)_(e1 = var) <-- { var == Cos(rhs) };
20 # Solve'Simple(ArcTan(_e1), _rhs, _var)_(e1 = var) <-- { var == Tan(rhs) };

/* Note: Second rule neglects (2*I*Pi)-periodicity of Exp() */
10 # Solve'Simple(Exp(_e1), 0,    _var)_(e1 = var) <-- { };
20 # Solve'Simple(Exp(_e1), _rhs, _var)_(e1 = var) <-- { var == Ln(rhs) };
20 # Solve'Simple(_b^_e1, _rhs, _var)_(e1 = var And IsFreeOf(var,b) And Not IsZero(b)) <-- { var == Ln(rhs) / Ln(b) };
20 # Solve'Simple(Ln(_e1),  _rhs, _var)_(e1 = var) <-- { var == Exp(rhs) };

/* The range of Sqrt is the set of (complex) numbers with either
 * positive real part, together with the pure imaginary numbers with
 * nonnegative real part. */
20 # Solve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And IsPositiveReal(Re(rhs)) And Re(rhs) != 0) <-- { var == rhs^2 };
20 # Solve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And Re(rhs)=0 And IsPositiveReal(Im(rhs))) <-- { var == rhs^2 };
20 # Solve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And Re(rhs)=0 And IsNegativeReal(Im(rhs)) And Im(rhs) != 0) <-- { };
20 # Solve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And IsNegativeReal(Re(rhs)) And Re(rhs) != 0) <-- { };

30 # Solve'Simple(_lhs, _rhs, _var) <-- Failed;


/********** Solve'Divide **********/
/* For some classes of equations, it may be easier to solve them if we
 * divide through by their first term.  A simple example of this is the
 * equation  Sin(x)+Cos(x)==0
 * One problem with this is that we may lose roots if the thing we
 * are dividing by shares roots with the whole equation.
 * The final HasExprs are an attempt to prevent infinite recursion caused by
 * the final Simplify step in Solve undoing what we do here.  It's conceivable
 * though that this won't always work if the recurring loop is more than two
 * steps long.  I can't think of any ways this can happen though :)
 */

10 # Solve'Divide(_e1 + _e2, _var)_(HasExpr(e1, var) And HasExpr(e2, var)
		And Not (HasExpr(Simplify(1 + (e2/e1)), e1)
		      Or HasExpr(Simplify(1 + (e2/e1)), e2)))
                                           <-- Solve(1 + (e2/e1), var);
10 # Solve'Divide(_e1 - _e2, _var)_(HasExpr(e1, var) And HasExpr(e2, var)
		And Not (HasExpr(Simplify(1 - (e2/e1)), e1)
		      Or HasExpr(Simplify(1 - (e2/e1)), e2)))
                                           <-- Solve(1 - (e2/e1), var);

20 # Solve'Divide(_e, _v) <-- Failed;


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Solve",categories="User Functions;Solvers (Symbolic)"
*CMD Solve --- solve an equation
*STD
*CALL
	Solve(eq, var)

*PARMS

{eq} -- equation to solve

{var} -- variable to solve for

*DESC

This command tries to solve an equation. If {eq} does not contain the
{==} operator, it is assumed that the user wants to solve
$eq == 0$. The result is a list of equations of the form {var == value}, each
representing a solution of the given equation. The {Where} operator
can be used to substitute this solution in another expression. If the
given equation {eq} does not have any solutions, or if {Solve} is
unable to find any, then an empty list is returned.

The current implementation is far from perfect. In particular, the
user should keep the following points in mind:
*	{Solve} cannot solve all equations. If it is given a equation
it can not solve, it raises an error via {Check}. Unfortunately, this
is not displayed by the inline pretty-printer; call {PrettyPrinterSet} to
change this. If an equation cannot be solved analytically, you may
want to call {Newton} to get a numerical solution.
*	Systems of equations are not handled yet. For linear systems,
{MatrixSolve} can be used. The old version of {Solve}, with the name
{OldSolve} might be able to solve nonlinear systems of equations.
*	The periodicity of the trigonometric functions {Sin}, {Cos},
and {Tan} is not taken into account. The same goes for the (imaginary)
periodicity of {Exp}. This causes {Solve} to miss solutions.
*	It is assumed that all denominators are nonzero. Hence, a
solution reported by {Solve} may in fact fail to be a solution because
a denominator vanishes.
*	In general, it is wise not to have blind trust in the results
returned by {Solve}. A good strategy is to substitute the solutions
back in the equation.

*E.G. notest

First a simple example, where everything works as it should. The
quadratic equation $x^2 + x == 0$ is solved. Then the result is
checked by substituting it back in the quadratic.

In> quadratic := x^2+x;
Result: x^2+x;
In> Solve(quadratic, x);
Result: {x==0,x==(-1)};
In> quadratic Where %;
Result: {0,0};

If one tries to solve the equation $Exp(x) == Sin(x)$, one finds that
{Solve} can not do this.

In> PrettyPrinterSet("DefaultPrint");
Result: True;
In> Solve(Exp(x) == Sin(x), x);
	Error: Solve'Fails: cannot solve equation Exp(x)-Sin(x) for x
Result: {};

The equation $Cos(x) == 1/2$ has an infinite number of solutions,
namely $x == (2*k + 1/3) * Pi$ and $x == (2*k - 1/3) * Pi$ for any
integer $k$. However, {Solve} only reports the solutions with $k == 0$.

In> Solve(Cos(x) == 1/2, x);
Result: {x==Pi/3,x== -Pi/3};

For the equation $x/Sin(x) == 0$, a spurious solution at $x == 0$ is
returned. However, the fraction is undefined at that point.

In> Solve(x / Sin(x) == 0, x);
Result: {x==0};

At first sight, the equation $Sqrt(x) == a$ seems to have the solution
$x == a^2$. However, this is not true for eg. $a == -1$.

In> PrettyPrinterSet("DefaultPrint");
Result: True;
In> Solve(Sqrt(x) == a, x);
	Error: Solve'Fails: cannot solve equation Sqrt(x)-a for  x
Result: {};
In> Solve(Sqrt(x) == 2, x);
Result: {x==4};
In> Solve(Sqrt(x) == -1, x);
Result: {};

*SEE Check, MatrixSolve, Newton, OldSolve, PrettyPrinterSet, PSolve, Where, AddTo, ==
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/YacasPSolve.mpw0000644000175000017500000001350711525527600027343 0ustar  giovannigiovanni%mathpiper,def="YacasYacasPSolve"

Rulebase("YacasPSolve",{uni});

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 0)
    {};

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 1)
    -Coef(uni,0)/Coef(uni,1);


Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 2)
    [
     Local(a,b,c,d,q,r);
     c:=Coef(uni,0);
     b:=Coef(uni,1);
     a:=Coef(uni,2);
     d:=b*b-4*a*c;
     q:=Sqrt(d)/(2*a);
     // Removed to avoid excessive time RadSimp takes for larger numbers
     // If(Im(q) != 0,
     //     q := Complex(RadSimp(Re(q)), RadSimp(Im(q))),
     //     q := RadSimp(q));
     r:=-b/(2*a);
     If(InVerboseMode(),[ Tell("   ",{c,b,a,d}); Tell("   ",{q,r}); ]);
     {r+q,r-q};
    ];


Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 3 )
    [
     Local(p,q,r,w,ww,a,b);
     Local(coef0,coef1,coef3,adjust);

/* Get coefficients for a new polynomial, such that the coefficient of
   degree 2 is zero:
   Take f(x)=a0+a1*x+a2*x^2+a3*x^3 and substitute x = x' + adjust
   This gives g(x) = b0+b1*x+b2*x^2+b3*x^3 where
   b3 = a3;
   b2 = 0 => adjust = (-a2)/(3*a3);
   b1 = 2*a2*adjust+3*a3*adjust^2+a1;
   b0 = a2*adjust^2+a3*adjust^3+adjust*a1+a0;

   After solving g(x') = 0, return x = x' + adjust.
*/

     adjust := (-Coef(uni,2))/(3*Coef(uni,3));
     coef3 := Coef(uni,3);
     coef1 := 2*Coef(uni,2)*adjust+3*Coef(uni,3)*adjust^2+Coef(uni,1);
     coef0 := Coef(uni,2)*adjust^2+Coef(uni,3)*adjust^3+
              adjust*Coef(uni,1)+Coef(uni,0);

     p:=coef3;
     q:=coef1/p;
     r:=coef0/p;
    w:=Complex(-1/2,Sqrt(3/4));
    ww:=Complex(-1/2,-Sqrt(3/4));

/* Equation is xxx + qx + r = 0 */
/* 	Let x = a + b
	a^3 + b^3 + 3(aab + bba) + q(a + b) + r = 0
	a^3 + b^3 + (3ab+q)x + r = 0

	Let 3ab+q = 0. This is permissible, for we can still find a+b == x

	a^3 + b^3 = -r
	(ab)^3 = -q^3/27

        So a^3 and b^3 are the roots of t^2 + rt - q^3/27 = 0

	Let
                a^3 = -r/2 + Sqrt(q^3/27+ rr/4)
                b^3 = -r/2 - Sqrt(q^3/27+ rr/4)
	Therefore there are three values for each of a and b.
	Clearly if ab = -q/3 is true then (wa)(wwb) == (wb)(wwa) == -q/3
*/

  a:=(-r/2 + Sqrt(q^3/27+ r*r/4))^(1/3);
  b:=(-r/2 - Sqrt(q^3/27+ r*r/4))^(1/3);

  {a+b+adjust,w*a+ww*b+adjust,ww*a+w*b+adjust};
];

/*
How to solve the quartic equation?

The equation is x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = 0.
The idea is to write the left-hand side as the difference of two
squares: (x^2 + p x + q)^2 - (s x + t)^2.
Eliminating the parentheses and equation coefficients yields four
equations for the four unknowns p, q, s and t:
  a1 = 2p              (1)
  a2 = p^2 + 2q - s^2  (2)
  a3 = 2pq - 2st       (3)
  a4 = q^2 - t^2       (4)
From the first equation, we find that p = a1/2. Substituting this in
the other three equations and rearranging gives
  s^2 = a1^2/4 - a2 + 2q   (5)
  2st = a1 q - a3          (6)
  t^2 = q^2 - a4           (7)
We now take the square (6) and substitute (5) and (7):
  4 (a1^2/4 - a2 + 2q) (q^2 - a4) = (a1 q - a3)^2  <==>
  8 q^3 - 4 a2 q^2 + (2 a1 a3 - 8 a4) q + 4 a2 a4 - a1^2 a4 - a3^2 = 0.
Miraculously, we got a cubic equation for q. Suppose we can solve this
equation. We can then compute t from (7): t = sqrt(q^2 - a4). If t is
nonzero, we can compute s from (6). Note that we cannot compute s from
(5), since we introduced an extra solution when squaring (6). However,
if t is zero, then no extra solution was introduced and we can safely
use (5). Having found the values of p, q, s and t, we can factor the
difference of squares and solve the quartic:
  x^4 + a1 x^3 + a2 x^2 + a3 x + a4 = (x^2 + p x + q)^2 - (s x + t)^2
                 = (x^2 + p x + q + s x + t) (x^2 + p x + q - sx - t).
The four roots of the quartic are the two roots of the first quadratic
factor plus the two roots of the second quadratic factor.
*/

Rule("YacasPSolve",1,1,IsUniVar(uni) And Degree(uni) = 4 )
[
    Local(coef4,a1,a2,a3,a4,y,y1,z,t,s);

    coef4:=Coef(uni,4);
    a1:=Coef(uni,3)/coef4;
    a2:=Coef(uni,2)/coef4;
    a3:=Coef(uni,1)/coef4;
    a4:=Coef(uni,0)/coef4;

    /* y1 = 2q, with q as above. */
    y1:=First(YacasPSolve(y^3-a2*y^2+(a1*a3-4*a4)*y+(4*a2*a4-a3^2-a1^2*a4),y));
    t := Sqrt(y1^2/4-a4);
    If(t=0, s:=Sqrt(y1+a1^2/4-a2), s:=(a1*y1-2*a3)/(4*t));
    Concat(YacasPSolve(z^2+(a1/2+s)*z+y1/2+t,z),
           YacasPSolve(z^2+(a1/2-s)*z+y1/2-t,z));
];

Function("YacasPSolve",{uni,var}) [
     Local(u, factors, f, r, s);

     u := MakeUni(uni, var);

     If(Type(u) = "UniVariate" And (And @ (Lambda({x}, IsNumber(x) Or IsRational(x)) /@ u[3])), [
         Local(coeffs);
         coeffs := Rationalize(u[3]);
         coeffs := If(Length(coeffs) > 1, 
                       Lcm(Denominator /@ coeffs) * coeffs, 
                       (Denominator /@ coeffs) * coeffs);
         DestructiveReplace(u, 3, coeffs);
         factors := If(Degree(u)>0, 
                        Factors(NormalForm(u)), 
                        {NormalForm(u), 1});
     ], [
         factors := {{uni, 1}};
     ]);

     r := {};
     ForEach(f, factors) [
         s := YacasPSolve(MakeUni(f[1],var));
         r := Union(r, If(IsList(s), s, {s}));
     ];

     If(Length(r) = 1, r[1], r);
];

%/mathpiper



%mathpiper_docs,name="YacasPSolve",categories="User Functions;Solvers (Symbolic)"
*CMD YacasPSolve --- solve a polynomial equation
*STD
*CALL
	YacasPSolve(poly, var)

*PARMS

{poly} -- a polynomial in "var"

{var} -- a variable

*DESC

This commands returns a list containing the roots of "poly",
considered as a polynomial in the variable "var". If there is only
one root, it is not returned as a one-entry list but just by
itself. A double root occurs twice in the result, and similarly for
roots of higher multiplicity. All polynomials of degree up to 4 are
handled.

*E.G.

In> YacasPSolve(b*x+a,x)
Result: -a/b;
In> YacasPSolve(c*x^2+b*x+a,x)
Result: {(Sqrt(b^2-4*c*a)-b)/(2*c),(-(b+
	Sqrt(b^2-4*c*a)))/(2*c)};

*SEE Solve, Factor
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/solve/Newton.mpw0000644000175000017500000000514711523200452026414 0ustar  giovannigiovanni%mathpiper,def="Newton"

Function("Newton",{function,variable,initial,accuracy})
[	// since we call a function with HoldArgument(), we need to evaluate some variables by hand
  `Newton(@function,@variable,initial,accuracy,-Infinity,Infinity);
];

Function("Newton",{function,variable,initial,accuracy,min,max})
[
  Local(result,adjust,delta,requiredPrec);
  MacroLocal(variable);
  requiredPrec := BuiltinPrecisionGet();
  accuracy:=N((accuracy/10)*10); // Making sure accuracy is rounded correctly
  BuiltinPrecisionSet(requiredPrec+2);
  function:=N(function);
  adjust:= -function/Apply("Differentiate",{variable,function});
  delta:=10000;
  result:=initial;
  While (result > min And result < max
      // avoid numerical underflow due to fixed point math, FIXME when have real floating math
      And N(Eval( Maximum(Re(delta), -Re(delta), Im(delta), -Im(delta)) ) ) > accuracy)
  [
    MacroBind(variable,result);
    delta:=N(Eval(adjust));
    result:=result+delta;
  ];

  BuiltinPrecisionSet(requiredPrec);
  result:=N(Eval((result/10)*10)); // making sure result is rounded to correct precision
  if (result <= min Or result >= max) [result := Fail;];
  result;
];

%/mathpiper



%mathpiper_docs,name="Newton",categories="User Functions;Solvers (Numeric)
*CMD Newton --- solve an equation numerically with Newton's method
*STD
*CALL
	Newton(expr, var, initial, accuracy)
	Newton(expr, var, initial, accuracy,min,max)

*PARMS

{expr} -- an expression to find a zero for

{var} -- free variable to adjust to find a zero

{initial} -- initial value for "var" to use in the search

{accuracy} -- minimum required accuracy of the result

{min} -- minimum value for "var" to use in the search

{max} -- maximum value for "var" to use in the search

*DESC

This function tries to numerically find a zero of the expression
{expr}, which should depend only on the variable {var}. It uses
the value {initial} as an initial guess.

The function will iterate using Newton's method until it estimates
that it has come within a distance {accuracy} of the correct
solution, and then it will return its best guess. In particular, it
may loop forever if the algorithm does not converge.

When {min} and {max} are supplied, the Newton iteration takes them
into account by returning {Fail} if it failed to find a root in
the given range. Note this doesn't mean there isn't a root, just
that this algorithm failed to find it due to the trial values
going outside of the bounds.

*E.G.

In> Newton(Sin(x),x,3,0.0001)
Result: 3.1415926535;
In> Newton(x^2-1,x,2,0.0001,-5,5)
Result: 1;
In> Newton(x^2+1,x,2,0.0001,-5,5)
Result: Fail;

*SEE Solve, NewtonNum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/0000755000175000017500000000000011722677332025136 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/DefinePattern.mpw0000644000175000017500000000346211417443641030413 0ustar  giovannigiovanni%mathpiper,def="DefinePattern",private="true"

Rulebase("DefinePattern",{leftOperand, rightOperand, rulePrecedence, postPredicate});



Rule("DefinePattern",4,9,IsEqual(Type(leftOperand),"_"))
[
    DefinePattern(leftOperand[1], rightOperand, rulePrecedence, leftOperand[2]);
];



Rule("DefinePattern",4,10,True)
[
      Local(patternFlat,patternVariables, pattern, patternOperator, arg, arity);
      
      Bind(patternFlat, FunctionToList(leftOperand)); //Turn the pattern into a list.
      
      Bind(patternVariables, Rest(patternFlat)); //Remove the function name from the list.
      
      Bind(patternOperator,ToString(First(patternFlat))); //Obtain the function name.
      
      Bind(arity,Length(patternVariables)); //Obtain the arity of the function.
      
      DefLoadFunction(patternOperator);  //Load the function if it exists.
    
      /*
            If the function does not exist, create it.
      */
      If(Not(RulebaseDefined(patternOperator,arity)),
         [
          MacroRulebase(patternOperator,MakeVector(arg,arity));
         ]
        );
    
      Bind(pattern,PatternCreate(patternVariables,postPredicate));
    
      MacroRulePattern(patternOperator,arity,rulePrecedence, pattern)rightOperand;
    
      True;
];

%/mathpiper



DefinePattern(leftOperand[2],rightOperand,leftOperand[1],True);


%mathpiper_docs,name="DefinePattern",categories="Programmer Functions;Programming;Built In"
*CMD DefinePattern --- defines a rule which uses a pattern as its predicate

*CALL
	DefinePattern("operator", arity, precedence, pattern) body
*PARMS

{"operator"} -- string, name of function

{arity}, {precedence} -- integers

{pattern} -- a pattern object

{body} -- expression, body of rule

*DESC
This function defines a rule which uses a pattern as its predicate.

*SEE MacroRulePattern
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/MakeVector.mpw0000644000175000017500000000172211523200452027705 0ustar  giovannigiovanni%mathpiper,def="MakeVector"

Rulebase("MakeVector",{vec,dimension});
Rule("MakeVector",2,1,True)
[
    Local(res,i);
    res:={};
    i:=1;
    Bind(dimension,AddN(dimension,1));
    While(IsLessThan(i,dimension))
    [
      DestructiveInsert(res,1,ToAtom(ConcatStrings(ToString(vec),ToString(i))));
      Bind(i,AddN(i,1));
    ];
    DestructiveReverse(res);
];

%/mathpiper



%mathpiper_docs,name="MakeVector",categories="User Functions;Lists (Operations)"
*CMD MakeVector --- vector of uniquely numbered variable names
*STD
*CALL
	MakeVector(var,n)

*PARMS

{var} -- free variable

{n} -- length of the vector

*DESC

A list of length "n" is generated. The first entry contains the
identifier "var" with the number 1 appended to it, the second entry
contains "var" with the suffix 2, and so on until the last entry
which contains "var" with the number "n" appended to it.

*E.G.

In> MakeVector(a,3)
Result: {a1,a2,a3};

*SEE RandomIntegerList, ZeroVector
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/pound_operator.mpw0000644000175000017500000000007511316304766030722 0ustar  giovannigiovanni%mathpiper,def=""

//Not defined in the scripts.

%/mathpiper././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/lessthan_negative_negative_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/patterns/lessthan_negative_negative_operato0000644000175000017500000001657511434420322034176 0ustar  giovannigiovanni%mathpiper,def="<--"

Rulebase("<--",{leftOperand,rightOperand});



Rule("<--",2,1,IsEqual(Type(leftOperand),"#"))
[
  DefinePattern(leftOperand[2],rightOperand,leftOperand[1],True);
];



Rule("<--",2,2,IsFunction(leftOperand))
[
 DefinePattern(leftOperand,rightOperand,0,True);
];

HoldArgument("<--",leftOperand);
HoldArgument("<--",rightOperand);

%/mathpiper




%mathpiper_docs,name="<--",categories="Operators"
*CMD <-- --- defines a rule which uses patterns and predicate functions to determine if it is true or not

*CALL
fn(_arg1, _arg2) <-- expression
fn(arg1_PredicateFunction, _arg2) <-- expression
fn(arg1_PredicateFunction, arg2_PredicateFunction) <-- expression
fn(arg1_PredicateFunction, arg2_PredicateFunction)_(PredicateExpression) <-- expression
_arg1 operator _arg2 <-- expression
arg1_PredicateFunction operator _arg2 <-- expression
arg1_PredicateFunction operator arg2_PredicateFunction <-- expression
arg1_PredicateFunction operator arg2_PredicateFunction_(PredicateExpression) <-- expression

*PARMS

{arg} -- an expression
{operator} -- an operator

*DESC
Mathematical calculations require versatile transformations on symbolic quantities.
Instead of trying to define all possible transformations, MathPiper provides a simple
and easy to use pattern matching scheme for manipulating expressions according to
user-defined rules. MathPiper itself is designed as a small core engine executing
a large library of rules to match and replace patterns.
One simple application of pattern-matching rules is to define new functions. (This
is actually the only way MathPiper can learn about new functions.) As an example,
let's define a function f that will evaluate factorials of non-negative integers.
We will define a predicate to check whether our argument is indeed a non-negative
integer, and we will use this predicate and the obvious recursion
f(n)=n*f(n-1) if n>0 and 1 if n=0 to evaluate the factorial.

We start with the simple termination condition, which is that f(n) should return
one if n is zero:

{10 # f(0) <-- 1;}

You can verify that this already works for input value zero, with f(0).

Now we come to the more complex line

20 # f(n_IsIntegerGreaterThanZero) <-- n*f(n-1);

We realize we need a function IsGreaterThanZero, so we define this function, with
IsIntegerGreaterThanZero(_n) <-- (IsInteger(n) And n>0);

You can verify that it works by trying f(5), which should return the same value as 5!.

In the above example we have first defined two "simplification rules" for a new
function f(). Then we realized that we need to define a predicate IsIntegerGreaterThanZero().
A predicate equivalent to IsIntegerGreaterThanZero() is actually already defined
in the standard library and it's called IsPositiveInteger, so it was not necessary,
strictly speaking, to define our own predicate to do the same thing. We did it here
just for illustration purposes.

The first two lines recursively define a factorial function f(n)=n*(n-1)*...*1.
The rules are given precedence values 10 and 20, so the first rule will be applied
first. Incidentally, the factorial is also defined in the standard library as a
postfix operator ! and it is bound to an internal routine much faster than the
recursion in our example. The example does show how to create your own routine with
a few lines of code. One of the design goals of MathPiper was to allow precisely
that, definition of a new function with very little effort.

The operator <-- defines a rule to be applied to a specific function. (The <-- operation
cannot be applied to an atom.) The _n in the rule for IsIntegerGreaterThanZero()
specifies that any object which happens to be the argument of that predicate is
matched and assigned to the local variable n. The expression to the right of <-- can
use n (without the underscore) as a variable.

Now we consider the rules for the function f. The first rule just specifies that f(0)
should be replaced by 1 in any expression. The second rule is a little more involved.
n_IsIntegerGreaterThanZero is a match for the argument of f, with the proviso that
the predicate IsIntegerGreaterThanZero(n) should return True, otherwise the pattern
is not matched. The underscore operator is to be used only on the left hand side of
the rule definition operator <--.

There is another, slightly longer but equivalent way of writing the second rule:
20 # f(_n)_(IsIntegerGreaterThanZero(n)) <-- n*f(n-1);

The underscore after the function object denotes a "postpredicate" that should return
True or else there is no match. This predicate may be a complicated expression involving
several logical operations, unlike the simple checking of just one predicate in the
n_IsIntegerGreaterThanZero construct. The postpredicate can also use the variable
n (without the underscore).

Precedence values for rules are given by a number followed by the # infix operator
(and the transformation rule after it). This number determines the ordering of precedence
for the pattern matching rules, with 0 the lowest allowed precedence value, i.e.
rules with precedence 0 will be tried first. Multiple rules can have the same number:
this just means that it doesn't matter what order these patterns are tried in. If no
number is supplied, 0 is assumed. In our example, the rule f(0) <-- 1 must be applied
earlier than the recursive rule, or else the recursion will never terminate. But as
long as there are no other rules concerning the function f, the assignment of numbers
10 and 20 is arbitrary, and they could have been 500 and 501 just as well. It is
usually a good idea however to keep some space between these numbers, so you have
room to insert new transformation rules later on.

Predicates can be combined: for example, {IsIntegerGreaterThanZero()} could also
have been defined as:
10 # IsIntegerGreaterThanZero(n_IsInteger)_(n>0) <-- True;
20 # IsIntegerGreaterThanZero(_n) <-- False;

The first rule specifies that if n is an integer, and is greater than zero, the
result is True, and the second rule states that otherwise (when the rule with
precedence 10 did not apply) the predicate returns False.

In the above example, the expression n > 0 is added after the pattern and allows
the pattern to match only if this predicate return True. This is a useful syntax
for defining rules with complicated predicates. There is no difference between the
rules F(n_IsPositiveInteger) <--... and F(_n)_(IsPositiveInteger(n)) <-- ... except
that the first syntax is a little more concise.

The left hand side of a rule expression has the following form:
precedence # pattern _ postpredicate <-- replacement ;

The optional precedence must be a positive integer.
Some more examples of rules (not made clickable because their equivalents are already
in the basic MathPiper library):
10 # _x + 0 <-- x;
20 # _x - _x <-- 0;
ArcSin(Sin(_x)) <-- x;

The last rule has no explicit precedence specified in it (the precedence zero will
be assigned automatically by the system). MathPiper will first try to match the pattern
as a template. Names preceded or followed by an underscore can match any one object:
a number, a function, a list, etc. MathPiper will assign the relevant variables as
local variables within the rule, and try the predicates as stated in the pattern.
The post-predicate (defined after the pattern) is tried after all these matched.
As an example, the simplification rule _x - _x <--0 specifies that the two objects
at left and at right of the minus sign should be the same for this transformation
rule to apply.

*SEE :=
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/0000755000175000017500000000000011722677335024442 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/WriteDataItem.mpw0000644000175000017500000000067211316304766027671 0ustar  giovannigiovanni%mathpiper,def="WriteDataItem"

/// service function. WriteDataItem({1,2,3}, {}) will output "1 2 3" on a separate line.
/// Writes data points to the current output stream, omits non-numeric values.
WriteDataItem(tuple_IsList, _options'hash) <--
[
  Local(item);
  If(	// do not write anything if one of the items is not a number
  	IsNumericList(tuple),
	ForEach(item,tuple)
	[
		Write(item);
		Space();
	]
  );
  NewLine();
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_2d/0000755000175000017500000000000011722677335025106 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_2d/plot2d.mpw0000644000175000017500000003173211517224250027027 0ustar  giovannigiovanni%mathpiper,def="Plot2D"

//Retract("Plot2D", *);

//////////////////////////////////////////////////
/// Plot2D --- adaptive two-dimensional plotting
//////////////////////////////////////////////////

/// definitions of backends
//LoadScriptOnce("plots.rep/backends_2d.mpi");

/*
	Plot2D is an interface for various backends (Plot2D'...). It calls
Plot2D'get'data to obtain the list of points and values, and then it calls
Plot2D' on that data.

	Algorithm for Plot2D'get'data:
	1) Split the given interval into Quotient(points+3, 4) subintervals, and split each subinterval into 4 parts.
	2) For each of the parts: evaluate function values and call Plot2D'adaptive
	3) concatenate resulting lists and return
*/

LocalSymbols(var, func, range, option, options'list, delta, options'hash, c, fc, all'values, dummy)
[

// declaration of Plot2D with variable number of arguments
Function() Plot2D(func);
Function() Plot2D(func, range);
Function() Plot2D(func, range, options, ...);

/// interface routines
1 # Plot2D(_func) <-- ("Plot2D" @ {func, -5:5});
2 # Plot2D(_func, _range) <-- ("Plot2D" @ {func, range, {}});
3 # Plot2D(_func, _range, option_IsFunction) _ (Type(option) = "->" )  <-- ("Plot2D" @ {func, range, {option}});

/// Plot a single function
5 # Plot2D(_func, _range, options'list_IsList)_(Not IsList(func)) <-- ("Plot2D" @ {{func}, range, options'list});

/// Top-level 2D plotting routine:
/// plot several functions sharing the same xrange and other options
4 # Plot2D(func'list_IsList, _range, options'list_IsList) <--
[
	Local(var, func, delta, options'hash, c, fc, all'values, dummy);
	all'values := {};
	options'hash := "OptionsListToHash" @ {options'list};
    
    
	// this will be a string - name of independent variable
	options'hash["xname"] := "";
	// this will be a list of strings - printed forms of functions being plotted
	options'hash["yname"] := {};
	// parse range
	If (
		Type(range) = "->",	// variable also specified -- ignore for now, store in options
		[
			// store alternative variable name
			options'hash["xname"] := ToString(range[1]);
			range := range[2];
		]
	);
	If(
		Type(range) = ":",	// simple range
		range := N(Eval({range[1], range[2]}))
	);
	// set default option values
	If(
		options'hash["points"] = Empty,
		options'hash["points"] := 23
	);
	If(
		options'hash["depth"] = Empty,
		options'hash["depth"] := 5
	);
	If(
		options'hash["precision"] = Empty,
		options'hash["precision"] := 0.0001
	);
	If(
		options'hash["output"] = Empty Or IsString(options'hash["output"]) And Plot2DOutputs()[options'hash["output"]] = Empty,
		options'hash["output"] := Plot2DOutputs()["default"]
	);
	// a "filename" parameter is required when using data file
	If(
		options'hash["output"] = "datafile" And options'hash["filename"] = Empty,
		options'hash["filename"] := "output.data"
	);
    
	// we will divide each subinterval in 4 parts, so divide number of points by 4 now
	options'hash["points"] := N(Eval(Quotient(options'hash["points"]+3, 4)));
    
	// in case it is not a simple number but an unevaluated expression
	options'hash["precision"] := N(Eval(options'hash["precision"]));
    
	// store range in options
	options'hash["xrange"] := {range[1], range[2]};
    
	// compute the separation between grid points
	delta := N(Eval( (range[2] - range[1]) / (options'hash["points"]) ));
    
	// check that the input parameters are valid (all numbers)
	Check(IsNumber(range[1]) And IsNumber(range[2]) And IsNumber(options'hash["points"]) And IsNumber(options'hash["precision"]),
                "Argument",
		"Plot2D: Error: plotting range '"
		:(PipeToString()Write(range))
		:"' and/or the number of points '"
		:(PipeToString()Write(options'hash["points"]))
		:"' and/or precision '"
		:(PipeToString()Write(options'hash["precision"]))
		:"' is not numeric"
	);
	// loop over functions in the list
	ForEach(func, func'list)
	[
		// obtain name of variable
		var := VarList(func);        // variable name in a one-element list
                Check(Length(var)<=1, "Argument", "Plot2D: Error: expression is not a function of one variable: "
			:(PipeToString()Write(func))
		);
		// Allow plotting of constant functions
		If(Length(var)=0, var:={dummy});
		// store variable name if not already done so
		If(
			options'hash["xname"] = "",
			options'hash["xname"] := ToString(VarList(var)[1])
		);
		// store function name in options
		DestructiveAppend(options'hash["yname"], PipeToString()Write(func));
		// compute the first point to see if it's okay
		c := range[1];
		fc := N(Eval(Apply({var, func}, {c})));
		Check(IsNumber(fc) Or fc=Infinity Or fc= -Infinity Or fc=Undefined,
                        "Argument", 
			"Plot2D: Error: cannot evaluate function '"
			:(PipeToString()Write(func))
			:"' at point '"
			:(PipeToString()Write(c))
			:"' to a number, instead got '"
			:(PipeToString()Write(fc))
			:"'"
		);
		// compute all other data points
		DestructiveAppend(all'values,  Plot2D'get'data(func, var, c, fc, delta, options'hash) );
        
		If(InVerboseMode(), Echo({"Plot2D: using ", Length(all'values[Length(all'values)]), " points for function ", func}), True);
	];
    
	// call the specified output backend
	Plot2DOutputs()[options'hash["output"]] @ {all'values, options'hash};
];

//HoldArgument("Plot2D", range);
//HoldArgument("Plot2D", options);
HoldArgumentNumber("Plot2D", 2, 2);
HoldArgumentNumber("Plot2D", 3, 2);
HoldArgumentNumber("Plot2D", 3, 3);



//Retract("Plot2D'get'data", *);
/// this is the middle-level plotting routine; it generates the initial
/// grid, calls the adaptive routine, and gathers data points.
/// func must be just one function (not a list)
Plot2D'get'data(_func, _var, _x'init, _y'init, _delta'x, _options'hash) <--
[
	Local(i, a, fa, b, fb, c, fc, result);
	// initialize list by first points (later will always use Rest() to exclude first points of subintervals)
	result := { {c,fc} := {x'init, y'init} };
	For(i:=0, i value)
	Plot2D(f(x), a:b, option -> value, ...)
	Plot2D(list, ...)

*PARMS

{f(x)} -- unevaluated expression containing one variables (function to be plotted)

{list} -- list of functions to plot

{a}, {b} -- numbers, plotting range in the $x$ coordinate

{option} -- atom, option name

{value} -- atom, number or string (value of option)

*DESC
The routine {Plot2D} performs adaptive plotting of one or several functions
of one variable in the specified range.
The result is presented as a line given by the equation $y=f(x)$.
Several functions can be plotted at once.
Various plotting options can be specified.
Output can be directed to a plotting program (the default is to use
{data}) to a list of values.

The function parameter {f(x)} must evaluate to a MathPiper expression containing
at most one variable. (The variable does not have to be called {x}.)
Also, {N(f(x))} must evaluate to a real (not complex) numerical value when given a numerical value of the argument {x}.
If the function {f(x)} does not satisfy these requirements, an error is raised.

Several functions may be specified as a list and they do not have to depend on the same variable, for example, {{f(x), g(y)}}.
The functions will be plotted on the same graph using the same coordinate ranges.

If you have defined a function which accepts a number but does not
accept an undefined variable, {Plot2D} will fail to plot it.
Use {NFunction} to overcome this difficulty.

Data files are created in a temporary directory {/tmp/plot.tmp/} unless otherwise requested.
File names
and other information is printed if {InVerboseMode()} returns {True} on using {V()}.

The current algorithm uses Newton-Cotes quadratures and some heuristics for error estimation (see <*mathpiperdoc://Algo/3/1/*>).
The initial grid of {points+1} points is refined between any grid points $a$, $b$ if the integral
$Integrate(x,a,b)f(x)$ is not approximated to the given precision by
the existing grid.

Default plotting range is {-5:5}. Range can also be specified as {x= -5:5} (note the mandatory space separating "{=}" and "{-}");
currently the variable name {x} is ignored in this case.

Options are of the form {option -> value}. Currently supported option names
are: "points", "precision", "depth", "output", "filename", "yrange". Option values
are either numbers or special unevaluated atoms such as {data}.
If you need to use the names of these atoms
in your script, strings can be used. Several option/value pairs may be specified (the function {Plot2D} has a variable number of arguments).

*	{yrange}: the range of ordinates to use for plotting, e.g.
{yrange=0:20}. If no range is specified, the default is usually to
leave the choice to the plotting backend. 
*	{points}: initial number of points (default 23) -- at least that
many points will be plotted. The initial grid of this many points will be
adaptively refined. 
*	{precision}: graphing precision (default $10^(-6)$). This is interpreted as the relative precision of computing the integral of $f(x)-Minimum(f(x))$ using the grid points. For a smooth, non-oscillating function this value should be roughly 1/(number of screen pixels in the plot).
*	{depth}: max. refinement depth, logarithmic (default 5) -- means there will be at most $2^depth$ extra points per initial grid point.
*	{output}: name of the plotting backend. Supported names: {data} (default).
The {data} backend will return the data as a list of pairs such as {{{x1,y1}, {x2,y2}, ...}}.
*	{filename}: specify name of the created data file. For example: {filename="data1.txt"}.
The default is the name {"output.data"}.
Note that if several functions are plotted, the data files will have a number appended to the given name, for example {data.txt1}, {data.txt2}.

Other options may be supported in the future.

The current implementation can deal with a singularity within the plotting range only if the function {f(x)} returns {Infinity}, {-Infinity} or
{Undefined} at the singularity.
If the function {f(x)} generates a numerical error and fails at a
singularity, {Plot2D} will fail if one of the grid points falls on the
singularity.
(All grid points are generated by bisection so in principle the
endpoints and the {points} parameter could be chosen to avoid numerical
singularities.)

*WIN32



*SEE V, NFunction, Plot3DS
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_2d/backends.mpw0000644000175000017500000001115711517224250027374 0ustar  giovannigiovanni%mathpiper,def="Plot2DOutputs"

//////////////////////////////////////////////////
/// Backends for 2D plotting
//////////////////////////////////////////////////


/// List of all defined backends and their symbolic labels.
/// Add any new backends here

LocalSymbols(options)
[
    options  := {
	{"default", "data"},
	{"data", "Plot2DData"},
	{"java", "Plot2DJava"},
    {"geogebra", "Plot2DGeoGebra"},
    {"jfreechart", "Plot2DJFreeChart"},
};
    

Plot2DOutputs() := options;

];

/*
	How backends work:
	Plot2D'(values, optionsHash)
	optionsHash is a hash that contains all plotting options:
	["xrange"] - a list of {x1, x2}, ["xname"] - name of the variable to plot, ["yname"] - array of string representations of the function(s), and perhaps other options relevant to the particular backend.
	{values} is a list of lists of pairs of the form {{{x1, y1}, {x2, y2}, ...}, {{x1, z1}, {x2, z2}, ...}, ...} corresponding to the functions y(x), z(x), ... to be plotted. The abscissa points x[i] are not the same for all functions.
	The backend should prepare the graph of the function(s). The "datafile" backend Plot2D'datafile(values, optionsHash) may be used to output all data to file(s), in which case the file name should be given by the value optionsHash["filename"]. Multiple files are created with names obtained by appending numbers to the filename.
	Note that the "data" backend does not do anything and simply returns the data.
	The backend Plot2D'datafile takes care not to write "Infinity" or "Undefined" data points (it just ignores them). Custom backends should either use Plot2D'datafile or take care of this themselves.
*/

/// trivial backend: return data list (do not confuse with Plot2D'get'data() defined in the main code which is the middle-level plotting routine)
Plot2DData(values_IsList, _optionsHash) <-- values;

/// The Java back-end generates a call-list that the Java graph plotter can handle
Plot2DJava(values_IsList, _optionsHash) <--
[
  Local(result,count);
  count := 0;
  result:="$plot2d:";

  result := result:" pensize 2.0 ";
  ForEach(function,values)
  [
    result := result:ColorForGraphNr(count);
    count++;
    result:=result:" lines2d ":ToString(Length(function));

    function:=Select(function, Lambda({item},item[2] != Undefined));

    ForEach(item,function)
    [
      result := result:" ":ToString(item[1]):" ":ToString(item[2]):" ";
    ];
  ];
  WriteString(result:"$");
  True;
];

10 # ColorForGraphNr(0) <-- " pencolor 64 64 128 ";
10 # ColorForGraphNr(1) <-- " pencolor 128 64 64 ";
10 # ColorForGraphNr(2) <-- " pencolor 64 128 64 ";
20 # ColorForGraphNr(_count) <-- ColorForGraphNr(Modulo(count,3));




//GeoGebra backend.
Plot2DGeogebra(values_IsList, _optionsHash) <--
[
  Local(result,count);
  count := 0;
  result:="";


  ForEach(function,values)
  [

    function:=Select(function, Lambda({item},item[2] != Undefined));

    ForEach(item,function)
    [
      result := result:"(":ToString(item[1]):",":ToString(item[2]):")":Nl();
    ];
  ];
  WriteString(result);
  True;
];




//JFreeChart backend.
//Retract("Plot2DJFreeChart", *);
Plot2DJFreeChart(values_IsList, _optionsHash) <--
[
    Local(rangeList, domainList, function, allProcessedFunctionData, lineChartCallListForm);
    
    
    
    //Remove Plot2D's options so that they don't get passed through to LineChart();
    ForEach(name, {"xrange", "xname", "yname", "output", "precision", "points", "depth"})
    [
        AssocDelete(optionsHash, name);
    ];
    
    
    
    //Convert {x,y} pairs into {x,x,x,...} {y,y,y,...} form.
    allProcessedFunctionData := {};
    
    ForEach(function,values)
    [
        rangeList := {};
        
        domainList := {};
        
        function := Select(function, Lambda({item},item[2] != Undefined));
        
        ForEach(item,function)
        [
            rangeList := Append(rangeList, item[1]);
          
            domainList := Append(domainList, item[2]);
        ];
        
        allProcessedFunctionData := Append(allProcessedFunctionData, rangeList);
        allProcessedFunctionData := Append(allProcessedFunctionData, domainList);
    
    ];


    
    //Put LineChart() function call into list form so it can be manipulated.
    lineChartCallListForm := {LineChart, allProcessedFunctionData };
    
    
    
    //Add any options to the list.
    ForEach(key, AssocIndices(optionsHash))
    [
        lineChartCallListForm := Append(lineChartCallListForm, Apply("->", {key, optionsHash[key]}));
    ];
    
    
    
    //Call the LineChart() function.
    Eval(ListToFunction(lineChartCallListForm));
    

];



%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/OptionsListToHash.mpw0000644000175000017500000000160011321741660030546 0ustar  giovannigiovanni%mathpiper,def="OptionsListToHash"

/// utility function: convert options lists of the form
/// "{key=value, key=value}" into a hash of the same form.
/// The argument list is kept unevaluated using "HoldArgumentNumber()".
/// Note that symbolic values of type atom are automatically converted to strings, e.g. ListToHash({a -> b}) returns {{"a", "b"}}
OptionsListToHash(list) :=
[
	Local(item, result);
	result := {};
	ForEach(item, list)
		If(
			IsFunction(item) And (Type(item) = "->" ) And IsAtom(item[1]),
			result[ToString(item[1])] := If(
				IsAtom(item[2]) And Not IsNumber(item[2]) And Not IsString(item[2]),
				ToString(item[2]),
				item[2]
			),
			Echo({"OptionsListToHash: Error: item ", item, " is not of the format a -> b."})
		);
        
	result;
];

HoldArgumentNumber("OptionsListToHash", 1, 1);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_3d/0000755000175000017500000000000011722677335025107 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_3d/plot3ds.mpw0000644000175000017500000004350611523200452027211 0ustar  giovannigiovanni%mathpiper,def="Plot3DS"

//////////////////////////////////////////////////
/// Plot3DS --- adaptive three-dimensional surface plotting
//////////////////////////////////////////////////

/// definitions of backends
//LoadScriptOnce("plots.rep/backends_3d.mpi");

/*
	Plot3DS is an interface for various backends (Plot3DS'...). It calls
Plot3DS'get'data to obtain the list of points and values, and then it calls
Plot3DS' on that data.

	Algorithm for Plot3DS'get'data:
	1) Split the given square into Quotient(Sqrt(points)+1, 2) subsquares, and split each subsquare into 4 parts.
	2) For each of the parts: evaluate function values and call Plot3DS'adaptive
	3) concatenate resulting lists and return
*/

	LocalSymbols(var, func, xrange, yrange, option, options'list, xdelta, ydelta, options'hash, cx, cy, fc, all'values, dummy)
[

// declaration of Plot3DS with variable number of arguments
Function() Plot3DS(func);
Function() Plot3DS(func, xrange, yrange);
Function() Plot3DS(func, xrange, yrange, options, ...);


/// interface routines
1 # Plot3DS(_func) <-- ("Plot3DS" @ {func, -5:5, -5:5});
2 # Plot3DS(_func, _xrange, _yrange) <-- ("Plot3DS" @ {func, xrange, yrange, {}});
3 # Plot3DS(_func, _xrange, _yrange, option_IsFunction) _ (Type(option) = "->" ) <-- ("Plot3DS" @ {func, xrange, yrange, {option}});

/// Plot a single function
5 # Plot3DS(_func, _xrange, _yrange, options'list_IsList)_(Not IsList(func)) <-- ("Plot3DS" @ {{func}, xrange, yrange, options'list});

/// Top-level 3D plotting routine:
/// plot several functions sharing the same ranges and other options
4 # Plot3DS(func'list_IsList, _xrange, _yrange, options'list_IsList) <--
[
	Local(var, func, xdelta, ydelta, options'hash, cx, cy, fc, all'values, dummy);
	// this will be a list of all computed values
	all'values := {};
	options'hash := "OptionsListToHash" @ {options'list};
	// this will be a string - name of independent variable
	options'hash["xname"] := "";
	options'hash["yname"] := "";
	// this will be a list of strings - printed forms of functions being plotted
	options'hash["zname"] := {};
	// parse range
	If (
		Type(xrange) = "->",	// variable also specified -- ignore for now, store in options
		[
			// store alternative variable name
			options'hash["xname"] := ToString(xrange[1]);
			xrange := xrange[2];
		]
	);
	If (
		Type(yrange) = "->" ,	// variable also specified -- ignore for now, store in options
		[
			// store alternative variable name
			options'hash["yname"] := ToString(yrange[1]);
			yrange := yrange[2];
		]
	);
	If(
		Type(xrange) = ":",	// simple range
		xrange := N(Eval({xrange[1], xrange[2]}))
	);
	If(
		Type(yrange) = ":",	// simple range
		yrange := N(Eval({yrange[1], yrange[2]}))
	);
	// set default option values
	If(
		options'hash["points"] = Empty,
		options'hash["points"] := 10	// default # of points along each axis
	);
	If(
		options'hash["xpoints"] = Empty,
		options'hash["xpoints"] := options'hash["points"]
	);
	If(
		options'hash["ypoints"] = Empty,
		options'hash["ypoints"] := options'hash["points"]
	);

	If(
		options'hash["depth"] = Empty,
		options'hash["depth"] := 2
	);
	If(
		options'hash["precision"] = Empty,
		options'hash["precision"] := 0.0001
	);
	If(
		options'hash["hidden"] = Empty Or Not IsBoolean(options'hash["hidden"]),
		options'hash["hidden"] := True
	);
	If(
		options'hash["output"] = Empty Or IsString(options'hash["output"]) And Plot3DS'outputs()[options'hash["output"]] = Empty,
		options'hash["output"] := Plot3DS'outputs()["default"]
	);
	// a "filename" parameter is required when using data file
	If(
		options'hash["output"] = "datafile" And options'hash["filename"] = Empty,
		options'hash["filename"] := "output.data"
	);
	options'hash["used depth"] := options'hash["depth"];
	// we will divide each subsquare in 4 parts, so divide number of points by 2 now
	options'hash["xpoints"] := N(Eval(Quotient(options'hash["xpoints"]+1, 2)));
	options'hash["ypoints"] := N(Eval(Quotient(options'hash["ypoints"]+1, 2)));
	// in case it is not a simple number but an unevaluated expression
	options'hash["precision"] := N(Eval(options'hash["precision"]));
	// store range in options
	options'hash["xrange"] := {xrange[1], xrange[2]};
	options'hash["yrange"] := {yrange[1], yrange[2]};
	// compute the separation between grid points
	xdelta := N(Eval( (xrange[2] - xrange[1]) / (options'hash["xpoints"]) ) );
	ydelta := N(Eval( (yrange[2] - yrange[1]) / (options'hash["ypoints"]) ) );
	// check that the input parameters are valid (all numbers)
	Check(IsNumericList({xrange[1], xrange[2], options'hash["xpoints"], options'hash["ypoints"], options'hash["precision"]}),
                "Argument", 
		"Plot3DS: Error: plotting ranges '"
		:(PipeToString()Write(xrange, yrange))
		:"' and/or the number of points '"
		:(PipeToString()Write(options'hash["xpoints"], options'hash["ypoints"]))
		:"' and/or precision '"
		:(PipeToString()Write(options'hash["precision"]))
		:"' is not numeric"
	);
	// loop over functions in the list
	ForEach(func, func'list)
	[
		// obtain name of variable
		var := VarList(func);        // variable names in a list
    	Check(Length(var)<=2, "Argument", "Plot3DS: Error: expression is not a function of at most two variables: "
			:(PipeToString()Write(func))
		);
		// Allow plotting of constant functions
		If(Length(var)=0, var:={dummy, dummy});
		If(Length(var)=1, var:={var[1], dummy});
		// store variable name if not already done so
		If(
			options'hash["xname"] = "",
			options'hash["xname"] := ToString(var[1])
		);
		If(
			options'hash["yname"] = "",
			options'hash["yname"] := ToString(var[2])
		);
		// store function name in options
		DestructiveAppend(options'hash["zname"], PipeToString()Write(func));
		// compute the first point to see if it's okay
		cx := xrange[1]; cy := yrange[1];
		fc := N(Eval(Apply({var, func}, {cx, cy})));
		Check(IsNumber(fc) Or fc=Infinity Or fc= -Infinity Or fc=Undefined,
                        "Argument", 
			"Plot3DS: Error: cannot evaluate function '"
			:(PipeToString()Write(func))
			:"' at point '"
			:(PipeToString()Write(cx, cy))
			:"' to a number, instead got '"
			:(PipeToString()Write(fc))
			:"'"
		);
		// compute all other data points
		DestructiveAppend(all'values, RemoveRepeated(HeapSort( Plot3DS'get'data(func, var, {cx, cy, fc}, {xdelta, ydelta}, options'hash), Hold({{x,y},x[1]value)
	Plot3DS(f(x,y), a:b, c:d, option->value, ...)
	Plot3DS(list, ...)

*PARMS

{f(x,y)} -- unevaluated expression containing two variables (function to be plotted)

{list} -- list of functions to plot

{a}, {b}, {c}, {d} -- numbers, plotting ranges in the $x$ and $y$ coordinates

{option} -- atom, option name

{value} -- atom, number or string (value of option)

*DESC
The routine {Plot3DS} performs adaptive plotting of a function
of two variables in the specified ranges.
The result is presented as a surface given by the equation $z=f(x,y)$.
Several functions can be plotted at once, by giving a list of functions.
Various plotting options can be specified.
Output can be directed to a plotting program (the default is to use
{data}), to a list of values.

The function parameter {f(x,y)} must evaluate to a MathPiper expression containing
at most two variables. (The variables do not have to be called {x} and {y}.)
Also, {N(f(x,y))} must evaluate to a real (not complex) numerical value when given numerical values of the arguments {x}, {y}.
If the function {f(x,y)} does not satisfy these requirements, an error is raised.

Several functions may be specified as a list but they have to depend on the same symbolic variables, for example, {{f(x,y), g(y,x)}}, but not {{f(x,y), g(a,b)}}.
The functions will be plotted on the same graph using the same coordinate ranges.

If you have defined a function which accepts a number but does not
accept an undefined variable, {Plot3DS} will fail to plot it.
Use {NFunction} to overcome this difficulty.

Data files are created in a temporary directory {/tmp/plot.tmp/} unless otherwise requested.
File names
and other information is printed if {InVerboseMode()} returns {True} on using {V()}.

The current algorithm uses Newton-Cotes cubatures and some heuristics for error estimation (see <*mathpiperdoc://Algo/3/1/*>).
The initial rectangular grid of {xpoints+1}*{ypoints+1} points is refined within any rectangle where the integral
of $f(x,y)$ is not approximated to the given precision by
the existing grid.

Default plotting range is {-5:5} in both coordinates.
A range can also be specified with a variable name, e.g. {x= -5:5} (note the mandatory space separating "{=}" and "{-}").
The variable name {x} should be the same as that used in the function {f(x,y)}.
If ranges are not given with variable names, the first variable encountered in the function {f(x,y)} is associated with the first of the two ranges.

Options are of the form {option->value}. Currently supported option names
are "points", "xpoints", "ypoints", "precision", "depth", "output", "filename", "xrange", "yrange", "zrange". Option values
are either numbers or special unevaluated atoms such as {data}.
If you need to use the names of these atoms
in your script, strings can be used (e.g. {output="data"}). Several option/value pairs may be specified (the function {Plot3DS} has a variable number of arguments).

*	{xrange}, {yrange}: optionally override coordinate ranges. Note that {xrange} is always the first variable and {yrange} the second variable, regardless of the actual variable names.
*	{zrange}: the range of the $z$ axis to use for plotting, e.g.
{zrange=0:20}. If no range is specified, the default is usually to
leave the choice to the plotting backend. Automatic choice based on actual values may
give visually inadequate plots if the function has a singularity.
*	{points}, {xpoints}, {ypoints}: initial number of points (default 10 each) -- at least that
many points will be plotted in each coordinate.
The initial grid of this many points will be
adaptively refined.
If {points} is specified, it serves as a default for both {xpoints} and {ypoints}; this value may be overridden by {xpoints} and {ypoints} values.
*	{precision}: graphing precision (default $0.01$). This is interpreted as the relative precision of computing the integral of $f(x,y)-Minimum(f(x,y))$ using the grid points. For a smooth, non-oscillating function this value should be roughly 1/(number of screen pixels in the plot).
*	{depth}: max. refinement depth, logarithmic (default 3) -- means there will be at most $2^depth$ extra points per initial grid point (in each coordinate).
*	{output}: name of the plotting backend. Supported names: {data} (default).
The {data} backend will return the data as a list of triples such as {{{x1, y1, z1}, {x2, y2, z2}, ...}}.

Other options may be supported in the future.

The current implementation can deal with a singularity within the plotting range only if the function {f(x,y)} returns {Infinity}, {-Infinity} or
{Undefined} at the singularity.
If the function {f(x,y)} generates a numerical error and fails at a
singularity, {Plot3DS} will fail only if one of the grid points falls on the
singularity.
(All grid points are generated by bisection so in principle the
endpoints and the {xpoints}, {ypoints} parameters could be chosen to avoid numerical
singularities.)

The {filename} option is optional if using graphical backends, but can be used to specify the location of the created data file.

*WIN32

Same limitations as {Plot2D}.

*E.G. notest
In> Plot3DS(a*b^2)
Result: True;
In> V(Plot3DS(Sin(x)*Cos(y),x->0:20, y->0:20,depth->3))
	CachedConstant: Info: constant Pi is being 
	  recalculated at precision 10
	CachedConstant: Info: constant Pi is being
	  recalculated at precision 11
	Plot3DS: using 1699  points for function Sin(x)*Cos(y)
	Plot3DS: max. used 8 subdivisions for Sin(x)*Cos(y)
	Plot3DS'datafile: created file '/tmp/plot.tmp/data1'
Result: True;


*SEE V, NFunction, Plot2D
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/_3d/backends.mpw0000644000175000017500000000336111316304766027403 0ustar  giovannigiovanni%mathpiper,def=""

//////////////////////////////////////////////////
/// Backends for 3D plotting
//////////////////////////////////////////////////

/// List of all defined backends and their symbolic labels.
/// Add any new backends here
Plot3DS'outputs() := {
	{"default", "data"},
	{"data", "Plot3DS'data"},
};

/*
	How backends work:
	Plot3DS'(values, options'hash)
	options'hash is a hash that contains all plotting options:
	["xrange"] - a list of {x1, x2}, ["xname"] - name of the variable to plot, same for "yrange";
	["zname"] - array of string representations of the function(s), and perhaps other options relevant to the particular backend.
	{values} is a list of lists of triples of the form {{{x1, y1, z1}, {x2, y2, z2}, ...}, {{x1, y1, t1}, {x2, y2, t2}, ...}, ...} corresponding to the functions z(x,y), t(x,y), ... to be plotted. The points x[i], y[i] are not necessarily the same for all functions.
	The backend should prepare the graph of the function(s). The "datafile" backend Plot3DS'datafile(values, options'hash) may be used to output all data to file(s), in which case the file name should be given by the value options'hash["filename"]. Multiple files are created with names obtained by appending numbers to the filename.
	Note that the "data" backend does not do anything and simply returns the data.
	The backend Plot3DS'datafile takes care not to write "Infinity" or "Undefined" data points (it just ignores them). Custom backends should either use Plot3DS'datafile to prepare a file, or take care of this themselves.
*/

/// trivial backend: return data list (do not confuse with Plot3DS'get'data() defined in the main code which is the middle-level plotting routine)
Plot3DS'data(values_IsList, _options'hash) <-- values;



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/plots/RemoveRepeated.mpw0000644000175000017500000000052411316304766030071 0ustar  giovannigiovanni%mathpiper,def="RemoveRepeated"

10 # RemoveRepeated({}) <-- {};
10 # RemoveRepeated({_x}) <-- {x};
20 # RemoveRepeated(list_IsList) <-- [
	Local(i, done);
	done := False;
	For(i:=0, Not done, i++)
	[
		While(iy And yz
	)
, 0, 1); 

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/0000755000175000017500000000000011722677333024557 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/RandomIntegerList.mpw0000644000175000017500000000140411523200452030654 0ustar  giovannigiovanni%mathpiper,def="RandomIntegerList"

RandomIntegerList(_count,_coefmin,_coefmax) <--
  Table(FloorN(coefmin+Random()*(coefmax+1-coefmin)),i,1,count,1);

%/mathpiper




%mathpiper_docs,name="RandomIntegerList",categories="User Functions;Numbers (Random)"
*CMD RandomIntegerList --- generate a vector of random integers

*STD

*CALL
	RandomIntegerList(nr, from, to)

*PARMS

{nr} -- number of integers to generate

{from} -- lower bound

{to} -- upper bound

*DESC

This function generates a list with "nr" random integers. All
entries lie between "from" and "to", including the boundaries, and
are uniformly distributed in this interval.

*E.G.

In> RandomIntegerList(4,-3,3)
Result: {0,3,2,-2};

*SEE Random, RandomPoly, RandomInteger, RandomIntegerMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/RandomInterestingPolynomial.mpw0000644000175000017500000001517311517224250032777 0ustar  giovannigiovanni%mathpiper,def="RandomInterestingPolynomial"

//Retract("RandomInterestingPolynomial",*);
//Retract("NewRandomPoly",*);
//Retract("RandomIrreducibleQuadratic",*);
//Retract("RandomIrreducibleQuadraticWithComplexRoots",*);
//Retract("RandomIrreducibleQuadraticWithRealRoots",*);


10 # RandomInterestingPolynomial( deg_IsPositiveInteger, _var ) <--
[
    RandomSeed( SystemTimer() );   //  randomize random number generator
    NewRandomPoly(deg,var);   
];


10 # NewRandomPoly( _deg, _var )_(IsEqual(deg,1)) <--
[
    Local(p,i1,i2);
    i1 := RandomInteger(1,10);
    i2 := RandomInteger(-10,10);
    p  := NormalForm(UniVariate(var,0,{i2,i1}));
];


10 # NewRandomPoly( _deg, _var )_(IsEqual(deg,2)) <--
[
    Local(ii,i1,i2,p,quadPoly);
    p := FillList(0,2);
    For(ii:=1,ii<=2,ii++)
    [
        i1 := RandomInteger(10);
        i2 := RandomInteger(-10,10);
        If( i1 > 1, i2 := i1*i2 );
        p[ii] := NormalForm(UniVariate(var,0,{i2,i1}));
    ];
    quadPoly := ExpandBrackets(p[1]*p[2]);
    quadPoly := Simplify(Quotient(quadPoly,LeadingCoef(quadPoly)));
];


10 # RandomIrreducibleQuadratic( _var ) <--
[
    Local(ii,coeffs,discrim,u,p,f);
    // Use random integers for coefficients a2 and a1.  Then select a0 
    // in one of two ways:
    //  (1) so that discriminant is negative integer,  or
    //  (2) so that discriminant is positive integer but not square.
    If(RandomInteger(2)=1,
        RandomIrreducibleQuadraticWithComplexRoots(var),
        RandomIrreducibleQuadraticWithRealRoots(var)
    );
];


10 # RandomIrreducibleQuadraticWithRealRoots(_var) <--
[
    Local(coeffs,ijk);
    coeffs    := FillList(1,3);
    coeffs[2] := RandomInteger(-10,10);
    coeffs[3] := RandomInteger(1,10);
    ijk := Floor(coeffs[2]^2 / (4*coeffs[3]));
    coeffs[1] := RandomInteger(-10,ijk);
    discrim := coeffs[2]^2-4*coeffs[1]*coeffs[3];
    NormalForm(UniVariate(var,0,coeffs));
];


10 # RandomIrreducibleQuadraticWithComplexRoots(_var) <--
[
    Local(coeffs,ijk);
    coeffs := {1,RandomInteger(-10,10),RandomInteger(1,10)};
    coeffs[1] := Ceil(N(coeffs[2]^2/(4*coeffs[3]))) + RandomInteger(1,5);
    NormalForm(UniVariate(var,0,coeffs));
];


10 # NewRandomPoly( _deg, _var )_(IsEqual(deg,3)) <--
[
    Local(ii,i1,i2,i3,p,CubicPoly);
    p := FillList(1,3);
    If( RandomInteger(3) = 1,
      [
        For(ii:=1,ii<=3,ii++)
        [
          i1 := RandomInteger(2);
          i2 := RandomInteger(-10,10);
          If( i1 > 1, i2 := i1*i2 );
          p[ii] := NormalForm(UniVariate(var,0,{i2,i1}));
        ];
      ],
      [
          i1 := RandomInteger(2);
          i2 := RandomInteger(-10,10);
          If( i1 > 1, i2 := i1*i2 );
          p[1] := NormalForm(UniVariate(var,0,{i2,i1}));
          p[2] := RandomIrreducibleQuadratic(var);
      ]
    );
    CubicPoly := ExpandBrackets(Product(p));
];


10 # NewRandomPoly( _deg, _var )_(IsEqual(deg,4)) <--
[
    Local(ii,i1,i2,i3,i4,p,QuarticPoly);
    p := FillList(1,4);
    If( RandomInteger(2) = 1,
      [
          p[1] := NewRandomPoly(3,x);
          i1 := RandomInteger(2);
          i2 := RandomInteger(-10,10);
          If( i1 > 1, i2 := i1*i2 );
          p[2] := NormalForm(UniVariate(var,0,{i2,i1}));
      ],
      [
          p[1] := NewRandomPoly(2,x);
          p[2] := NewRandomPoly(2,x);
      ]
    );
    QuarticPoly := ExpandBrackets(Product(p));
];


10 # NewRandomPoly( _deg, _var )_(IsEqual(deg,5)) <--
[
    Local(ii,i1,i2,i3,i4,p,QuinticPoly);
    p := FillList(1,4);
    p[1] := NewRandomPoly(1,x);
    p[2] := RandomIrreducibleQuadraticWithRealRoots(x);
    p[3] := RandomIrreducibleQuadraticWithComplexRoots(x);
    QuinticPoly := ExpandBrackets(Product(p));
];


11 # NewRandomPoly( deg_IsPositiveInteger, _var )_(deg > 5) <--
[
    Local(p,n,m);
    p := {};
    m := deg;
    Until( m < 3 )
    [
        n := RandomInteger(2,Floor(N(deg/2)));
        Tell("     ",{m,n});
        Push(p,NewRandomPoly(n,var));
        m := m - n;
    ];
    Tell("      ",m);
    If( m > 0, Push(p,NewRandomPoly(m,x)));
    Expand(Product(p));
];

%/mathpiper




%mathpiper_docs,name="RandomInterestingPolynomial",categories="User Functions;Numbers (Random)"
*CMD RandomInterestingPolynomial --- construct a random "interesting" polynomial
*CMD RandomIrreducibleQuadraticWithComplexRoots --- constructs a random quadratic polynomial with complex roots
*CMD RandomIrreducibleQuadraticWithRealRoots --- constructs a random quadratic polynomial with real roots

*STD
*CALL
    RandomInterestingPolynomial(deg,var)
    RandomIrreducibleQuadraticWithComplexRoots(var)
    RandomIrreducibleQuadraticWithRealRoots(var)

*PARMS

{deg} -- degree of the resulting univariate polynomial

{var} -- free variable for the resulting univariate polynomial

*DESC

RandomInterestingPolynomial generates a random "interesting" polynomial in 
variable {var}, of degree {deg}, with integer coefficients.

Unlike the similar function {RandomPoly}, which merely generates
polynomials with random integer coefficients, the current function 
generates polynomials which are constructed by multiplying simpler 
random polynomials (with integer coefficients).  In this way, the
generated polynomials are guaranteed to be "interesting" in the sense
that they will always be factorable.  It is a known fact that a polynomial
whose coefficients are integers chosen at random will almost always
turn out to be irreducible.  This is not usually very "interesting",
especially in a learning context.

If you would like to construct higher degree polynomials having certain
specific kinds of roots, you can write a custom function to do this, 
using {RandomIrreducibleQuadraticWithRealRoots} or 
{RandomIrreducibleQuadraticWithComplexRoots} to create quadratics
with which to compose the higher polynomial.

*E.G.

In> RandomInterestingPolynomial(3,x)
Result: x^3+2*x^2-12*x-48
    
In> Factor(%)
Result: (x-4)*(x^2+6*x+12)
    
In> Solve(x^2+6*x+12,x)
Result: {x==Complex(-3,Sqrt(3)),x==Complex(-3,(-Sqrt(12))/2)}
    
Notice that although the polynomial is indeed factorable, it is 
not guaranteed to have only linear factors (over the integers), 
and (some of) the roots of the polynomial may be complex.
    
In> RandomIrreducibleQuadraticWithRealRoots(x)
Result: 6*x^2+2*x-7
    
In> Solve(%,x)
Result: {x==(Sqrt(172)-2)/12,x==(-(Sqrt(172)+2))/12}
    
In>  RandomIrreducibleQuadraticWithComplexRoots(x)
Result: 8*x^2-5*x+3
    
In> Solve(%,x)
Result: {x==Complex(5/16,Sqrt(71/256)),x==Complex(5/16,(-Sqrt(71))/16)}

*SEE Random, RandomPoly
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/RandomInteger.mpw0000644000175000017500000000674611517224250030043 0ustar  giovannigiovanni%mathpiper,def="RandomInteger"

//Retract("RandomInteger", *);


10 # RandomInteger(_n) <--
[
    Check(IsPositiveInteger(n), "Argument", "The argument must be a positive integer.");

    CeilN(Random() * n);
];



10 # RandomInteger(_lowerBoundInclusive, _upperBoundInclusive) <--
[
    Check(IsInteger(lowerBoundInclusive) And IsInteger(upperBoundInclusive), "Argument", "Both arguments must be integers.");

    Check(lowerBoundInclusive < upperBoundInclusive, "Argument", "The first argument must be less than the second argument.");

    FloorN(lowerBoundInclusive + Random() * (upperBoundInclusive + 1 - lowerBoundInclusive) );
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




===================== Tests ==========================================


%mathpiper,scope="nobuild",subtype="manual_test",title="Test arguments."

Verify(ExceptionCatch(RandomInteger(-1), "Exception"), "Exception");

Verify(ExceptionCatch(RandomInteger(1.2, 4), "Exception"), "Exception");

Verify(ExceptionCatch(RandomInteger(1, 4.2), "Exception"), "Exception");

Verify(ExceptionCatch(RandomInteger(4, 1), "Exception"), "Exception");

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper,scope="nobuild",subtype="manual_test",title="Chi-square test for two argument version of RandomInteger."
[
    /*
        Test that the two argument version of RandomInteger produces a
        discrete uniform distribution.
    */


    Local(randomNumbers, chiSquareTest, criticalChiSquareScore);

    randomNumbers:= Table( RandomInteger(-2, 2),x,1,10000,1);

    chiSquareTest := ChiSquareTest({
                                Count(randomNumbers,-2),
                                Count(randomNumbers,-1),
                                Count(randomNumbers,0),
                                Count(randomNumbers,1),
                                Count(randomNumbers,2)},
                                {2000,2000,2000,2000,2000});

    criticalChiSquareScore := AlphaToChiSquareScore(.001, chiSquareTest["degreesOfFreedom"]);

    Echo(chiSquareTest);

    NewLine();

    Echo("Calculated chi-squ value: ", chiSquareTest["chiSquareScore"]);

    Echo("Critical chi-square value: ", criticalChiSquareScore);

    Histogram(randomNumbers);

];

%/mathpiper

    %output,preserve="false"
      Result: class org.jfree.chart.ChartPanel

      Side Effects:
      {{"chiSquareScore",3.357},{"pValue",0.6879909930},{"degreesOfFreedom",4}}

      Calculated chi-squ value: 3.357
      Critical chi-square value: 18.46682719

.   %/output





%mathpiper_docs,name="RandomInteger",categories="User Functions;Numbers (Random)"
*CMD RandomInteger --- generate a random integer

*STD

*CALL
	RandomInteger(upper_bound)
        RandomInteger(lower_bound, upper_bound)

*PARMS

{lower_bound} -- the smallest integer that can be generated

{upper_bound} -- the largest integer that can be generated


*DESC

The single argument version of this function generates a random integer between
1 and the given upper bound integer (inclusive).  The two argument version of
the function generates a random integer between a lower bound integer and an
upper bound integer (both inclusive).

*E.G.
In> RandomInteger(5)
Result> 4

In> Repeat(10) Write(RandomInteger(5),,)
Result> 10
Side Effects>4,3,5,1,2,2,3,5,3,3,

In> RandomInteger(5,10)
Result: 5

In> Repeat(10) Write(RandomInteger(5, 10),,)
Result: 10
Side Effects:
8,9,9,5,6,8,9,10,8,7,

*SEE Random, RandomPoly, RandomIntegerList, RandomIntegerMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/RandomIntegerMatrix.mpw0000644000175000017500000000260111523200452031205 0ustar  giovannigiovanni%mathpiper,def="RandomIntegerMatrix"

RandomIntegerMatrix(_rows,_cols,_coefmin,_coefmax) <--
	GenMatrix({{i,j}, FloorN(coefmin+Random()*(coefmax+1-coefmin))}, rows, cols );

%/mathpiper




%mathpiper_docs,name="RandomIntegerMatrix",categories="User Functions;Numbers (Random)"
*CMD RandomIntegerMatrix --- generate a matrix of random integers

*STD

*CALL
	RandomIntegerMatrix(rows,cols,from,to)

*PARMS

{rows} -- number of rows in matrix

{cols} -- number of cols in matrix

{from} -- lower bound

{to} -- upper bound

*DESC

This function generates a {rows x cols} matrix of random integers. All
entries lie between "from" and "to", including the boundaries, and
are uniformly distributed in this interval.

*E.G.
In> PrettyForm( RandomIntegerMatrix(5,5,-2^10,2^10) )

	/                                               \
	| ( -506 ) ( 749 )  ( -574 ) ( -674 ) ( -106 )  |
	|                                               |
	| ( 301 )  ( 151 )  ( -326 ) ( -56 )  ( -277 )  |
	|                                               |
	| ( 777 )  ( -761 ) ( -161 ) ( -918 ) ( -417 )  |
	|                                               |
	| ( -518 ) ( 127 )  ( 136 )  ( 797 )  ( -406 )  |
	|                                               |
	| ( 679 )  ( 854 )  ( -78 )  ( 503 )  ( 772 )   |
	\                                               /

*SEE RandomPoly, Random, RandomInteger, RandomIntegerList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/RandomPoly.mpw0000644000175000017500000000202711523200452027350 0ustar  giovannigiovanni%mathpiper,def="RandomPoly"

/* Generate a random polynomial */

RandomPoly(_var,_degree,_coefmin,_coefmax) <--
  NormalForm(UniVariate(var,0,RandomIntegerList(degree+1,coefmin,coefmax)));

%/mathpiper




%mathpiper_docs,name="RandomPoly",categories="User Functions;Numbers (Random)"
*CMD RandomPoly --- construct a random polynomial
*STD
*CALL
	RandomPoly(var,deg,coefmin,coefmax)

*PARMS

{var} -- free variable for resulting univariate polynomial

{deg} -- degree of resulting univariate polynomial

{coefmin} -- minimum value for coefficients

{coefmax} -- maximum value for coefficients

*DESC

RandomPoly generates a random polynomial in variable "var", of
degree "deg", with integer coefficients ranging from "coefmin" to
"coefmax" (inclusive). The coefficients are uniformly distributed in
this interval, and are independent of each other.

*E.G.

In> RandomPoly(x,3,-10,10)
Result: 3*x^3+10*x^2-4*x-6;
In> RandomPoly(x,3,-10,10)
Result: -2*x^3-8*x^2+8;

*SEE Random, RandomInteger, RandomIntegerList, RandomIntegerMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/random/random.mpw0000644000175000017500000003415311523200452026551 0ustar  giovannigiovanni%mathpiper,def="RandomSeed;Random;Rng;RngSeed;RngCreate"

/* def file definitions

RandomSeed
Random
Rng
RngSeed
RngCreate
*/

/*
Random number generators implemented in an object-oriented manner.

Old interface (still works):

	RandomSeed(123);
	Random(); Random();

It provides only one global RNG with a globally assigned seed.

New interface allows creating many RNG objects:

	r1:=RngCreate();	// create a default RNG object, assign structure to r1
	r2:=RngCreate(12345);	// create RNG object with given seed
	r3:=RngCreate(seed->0, engine->advanced, dist->gauss); 	// extended options: specify seed, type of RNG engine and the type of statistical distribution
	Rng(r1); Rng(r1); Rng(r2);	// generate some floating-point numbers
	RngSeed(r1, 12345);	// r1 is re-initialized with given seed, r2 is unaffected

More "RNG engines" and "RNG distribution adaptors" can be defined later (at run time).

RngCreate() will return an object of the following structure:
	{SomeDist, SomeEngine, state }

here SomeEngine is a function atom that describes the RNG engine,
SomeDist is a function atom that specifies the distribution adaptor,
and state is a "RNG state object", e.g. a list of all numbers that specify the current RNG state (seeds, temporaries, etc.).

RngSeed(r1, seed) expects an integer seed.
It will re-initialize the RNG object r1 with the given seed.

The "RNG engine API": calling RngCreate with engine->SomeEngine expects that:
	SomeEngine(seed_IsInteger) will create and initialize a state object with given seed and return the new state object (a list). SomeEngine can assume that "seed" is a positive integer.
	SomeEngine(state1_IsList) will update the RNG state object state1 and return the pair {new state object, new number}.

The "RNG distribution adaptor API": calling RngCreate with distribution->SomeDist expects that:
	SomeDist(r1) will update the RNG object r1 and return the pair {new state object, new number}. r1 is a full RNG object, not just a state object.


*/

//////////////////////////////////////////////////
/// lists of defined RNG entities
//////////////////////////////////////////////////

/// The idea is that options must be easy to type, but procedure names could be long.

LocalSymbols(knownRNGEngines, knownRNGDists) [
  knownRNGEngines :=
  {
    { "default", "RNGEngine'LCG'2"},
    { "advanced", "RNGEngine'L'Ecuyer"},
  };

  knownRNGDists :=
  {
    {"default", "FlatRNGDist"},
    {"flat", "FlatRNGDist"},
  //	{"uniform", "FlatRNGDist"},	// we probably don't need this alias...
    {"gauss", "GaussianRNGDist"},
  };

  KnownRNGDists() := knownRNGDists;
  KnownRNGEngines() := knownRNGEngines;
];


//////////////////////////////////////////////////
/// RNG object API
//////////////////////////////////////////////////

Function() RngCreate();
Function() RngCreate(seed, ...);
//HoldArgument("RngCreate", seed);	// this is needed to prevent evaluation of = and also to prevent substitution of variables, e.g. if "seed" is defined
//UnFence("RngCreate", 0);
//UnFence("RngCreate", 1);
Function() RngSeed(r, seed);
//UnFence("RngSeed", 2);
/// accessor for RNG objects
Function() Rng(r);
//UnFence("Rng", 1);


RngCreate() <-- RngCreate(0);

10 # RngCreate(a'seed_IsInteger) <-- (RngCreate @ {seed -> a'seed});

// a single option given: convert explicitly to a list
20 # RngCreate(_key -> _value) <-- `(RngCreate({@key -> value}));

// expect a list of options
30 # RngCreate(options_IsList) <--
[
	options := OptionsListToHash @ {options};

	// check options and assign defaults
	If(
		options["seed"] = Empty Or options["seed"] <= 0,
		options["seed"] := 76544321	// some default seed out of the blue sky
	);
	If(
		options["engine"] = Empty Or Not (Assert("warning", {"RngCreate: invalid engine", options["engine"]}) KnownRNGEngines()[options["engine"] ] != Empty),
		options["engine"] := "default"
	);
	If(
		options["dist"] = Empty Or Not (Assert("warning", {"RngCreate: invalid distribution", options["dist"]}) KnownRNGDists()[options["dist"] ] != Empty),
		options["dist"] := "default"
	);

	// construct a new RNG object
	// a RNG object has the form {"SomeDist", "SomeEngine", {state}}
	{
		KnownRNGDists()[options["dist"] ], KnownRNGEngines()[options["engine"] ],
		// initialize object with given seed using "SomeEngine"(seed)
		KnownRNGEngines()[options["engine"] ] @ { options["seed"] }
	};
];

/// accessor function: will call SomeDist(r) and update r
Rng(_r) <--
[
	Local(state, result);
	{state, result} := (r[1] @ {r});	// this calls SomeDist(r)
	DestructiveReplace(r, 3, state);	// update RNG object
	result;	// return floating-point number
];

/// set seed: will call SomeEngine(r, seed) and update r
RngSeed(_r, seed_IsInteger) <--
[
	Local(state);
	(Assert("warning", {"RngSeed: seed must be positive", seed}) seed > 0
	) Or (seed:=76544321);
	state := (r[2] @ {seed});	// this calls SomeEngine(r)
	DestructiveReplace(r, 3, state);	// update object
	True;
];

//////////////////////////////////////////////////
/// RNG distribution adaptors
//////////////////////////////////////////////////

/// trivial distribution adaptor: flat distribution, simply calls SomeEngine(r)
/* we have to return whole objects; we can't use references b/c the core
function ApplyFast will not work properly on references, i.e. if r = {"", "", {1}} so that
r[3] = {1}, then LCG'2(r[3]) modifies r[3], but LCG'2 @ r[3] or
ApplyFast("LCG'2", {r[3]}) do not actually modify r[3].
*/

// return pair {state, number}
FlatRNGDist(_r) <-- (r[2] @ {r[3]});	// this calls SomeEngine(state)

/// Gaussian distribution adaptor, returns a complex number with normal distribution with unit variance, i.e. Re and Im are independent and both have unit variance
/* Gaussian random number, Using the Box-Muller transform, from Knuth,
   "The Art of Computer Programming",
   Volume 2 (Seminumerical algorithms, third edition), section 3.4.1
 */
GaussianRNGDist(_rng) <--
[
	// a Gaussian distributed complex number p + I*q is made up of two uniformly distributed numbers x,y according to the formula:
	// a:=2*x-1, b:=2*y-1, m:=a^2+b^2; p = a*Sqrt(-2*Ln(m)/m); q:=b*Sqrt(-2*Ln(m)/m);
	// here we need to make sure that m is nonzero and strictly less than 1.
	Local(a,b,m, new'state, rnumber);
	new'state := rng[3];	// this will be updated at the end
	m:=0;
	While(m=0 Or m>=1)	// repeat generating new x,y  - should not take more than one iteration really
	[
		{new'state, rnumber} := (rng[2] @ {new'state});
		a:=2*rnumber-1;
		{new'state, rnumber} := (rng[2] @ {new'state});
		b:=2*rnumber-1;
		m:=a*a+b*b;
	];
	{new'state, (a+I*b)*SqrtN(-2*DivideN(Internal'LnNum(m),m))};
];


//////////////////////////////////////////////////
/// RNG engines
//////////////////////////////////////////////////

/// default RNG engine: the LCG generator

// first method: initialize a state object with given seed
RNGEngine'LCG'1(seed_IsInteger) <-- {seed};
// second method: update state object and return new number
RNGEngine'LCG'1(state_IsList) <-- LCG'1(state);

// first method: initialize a state object with given seed
RNGEngine'LCG'2(seed_IsInteger) <-- {seed};
// second method: update state object and return new number
RNGEngine'LCG'2(state_IsList) <-- LCG'2(state);

// first method: initialize a state object with given seed
RNGEngine'LCG'3(seed_IsInteger) <-- {seed};
// second method: update state object and return new number
RNGEngine'LCG'3(state_IsList) <-- LCG'3(state);

// first method: initialize a state object with given seed
RNGEngine'LCG'4(seed_IsInteger) <-- {seed};
// second method: update state object and return new number
RNGEngine'LCG'4(state_IsList) <-- LCG'4(state);

/// parameters from P. Hellekalek, 1994; see G. S. Fishman, Math. Comp. vol. 54, 331 (1990)
LCG'1(state) := RandomLCG(state, 2147483647,950706376,0);
LCG'2(state) := RandomLCG(state, 4294967296,1099087573,0);
LCG'3(state) := RandomLCG(state, 281474976710656,68909602460261,0);
LCG'4(state) := RandomLCG(state, 18014398509481984,2783377640906189,0);

/// Linear congruential generator engine: backend
// state is a list with one element
RandomLCG(_state, _im, _ia, _ic) <--
{
	DestructiveReplace(state,1, ModuloN(state[1]*ia+ic,im)),
	DivideN(state[1], im)	// division should never give 1
};

/// Advanced RNG engine due to L'Ecuyer et al.
/// RNG from P. L'ecuyer et al (2000). Period approximately 2^191
// state information: 6 32-bit integers, corresponding to {x3,x2,x1,y3,y2,y1}

// first method: initialize a state object with given seed
RNGEngine'L'Ecuyer(a'seed_IsInteger) <--
[
	// use LCG'2 as auxiliary RNG to fill the seeds
	Local(rng'aux, result);
	rng'aux := (RngCreate @ {a'seed});
	// this will be the state vector
	result:=ZeroVector(6);
	// fill the state object with random numbers
	Local(i);
	For(i:=1, i<=6, i++)
	[
		Rng(rng'aux);
		result[i] := rng'aux[3][1];	// hack to get the integer part
	];
	// return the state object
	result;
];

// second method: update state object and return a new random number (floating-point)
RNGEngine'L'Ecuyer(state_IsList) <--
[
	Local(new'state, result);
	new'state := {
		Modulo(1403580*state[2]-810728*state[3], 4294967087), state[1], state[2],
		Modulo(527612*state[4]-1370589*state[6], 4294944433), state[4], state[5]
	};
	result:=Modulo(state[1]-state[4], 4294967087);
	{
		new'state,
		DivideN(If(result=0, 4294967087, result), 4294967088)
	};
];

//////////////////////////////////////////////////
/// old interface: using one global RNG object
//////////////////////////////////////////////////
/* this is a little slower but entirely equivalent to the code below
GlobalRNG := RngCreate(76544321);
Random() := Rng(GlobalRNG);
RandomSeed(seed) := RngSeed(GlobalRNG, seed);
*/

LocalSymbols(RandSeed) [
  // initial seed should be nonzero
  RandSeed := SystemTimer(); //Was 76544321.

  /// assign random seed
  Function("RandomSeed", {seed}) Bind(RandSeed, seed);

  /// Linear congruential generator
  RandomLCG(_im, _ia, _ic) <--
  [
    RandSeed:=ModuloN(RandSeed*ia+ic,im);
    DivideN(RandSeed,im);	// should never give 1
  ];
]; // LocalSymbols(RandSeed)


Function("Random1",{}) RandomLCG(4294967296,1103515245,12345);
Function("Random6",{}) RandomLCG(1771875,2416,374441);
/// parameters from P. Hellekalek, 1994; see G. S. Fishman, Math. Comp. vol. 54, 331 (1990)
Function("Random2",{}) RandomLCG(2147483647,950706376,0);
Function("Random3",{}) RandomLCG(4294967296,1099087573,0);
Function("Random4",{}) RandomLCG(281474976710656,68909602460261,0);
Function("Random5",{}) RandomLCG(18014398509481984,2783377640906189,0);

// select one of them
Function("Random",{}) Random3();


%/mathpiper





%mathpiper_docs,name="Random;RandomSeed",categories="User Functions;Numbers (Random)"
*CMD Random, RandomSeed --- (pseudo-) random number generator
*STD
*CALL
	Random()
	RandomSeed(init)

*PARAMS
{init} -- positive integer, initial random seed

*DESC

The function {Random} returns a random number, uniformly distributed in the
interval between 0 and 1. The same sequence of random numbers is
generated in every MathPiper session.

The random number generator can be initialized by calling {RandomSeed} with an integer value.
Each seed value will result in the same sequence of pseudo-random numbers.

*SEE RandomInteger, RandomPoly, Rng, Random, RandomIntegerList, RandomIntegerMatrix
%/mathpiper_docs





%mathpiper_docs,name="RngCreate;RngSeed;Rng",categories="User Functions;Numbers (Random)"
*CMD RngCreate --- manipulate random number generators as objects
*CMD RngSeed --- manipulate random number generators as objects
*CMD Rng --- manipulate random number generators as objects
*STD
*CALL
	RngCreate()
	RngCreate(init)
	RngCreate(option->value,...)
	RngSeed(r, init)
	Rng(r)
	
*PARMS
{init} -- integer, initial seed value

{option} -- atom, option name

{value} -- atom, option value

{r} -- a list, RNG object

*DESC
These commands are an object-oriented interface to (pseudo-)random number generators (RNGs).

{RngCreate} returns a list which is a well-formed RNG object.
Its value should be saved in a variable and used to call {Rng} and {RngSeed}.

{Rng(r)} returns a floating-point random number between 0 and 1 and updates the RNG object {r}.
(Currently, the Gaussian option makes a RNG return a complex random number instead of a real random number.)

{RngSeed(r,init)} re-initializes the RNG object {r} with the seed value {init}.
The seed value should be a positive integer.

The {RngCreate} function accepts several options as arguments.
Currently the following options are available:

*	{seed} -- specify initial seed value, must be a positive integer
*	{dist} -- specify the distribution of the random number; currently {flat} and {gauss} are implemented, and the default is the flat (uniform) distribution
*	{engine} -- specify the RNG engine; currently {default} and {advanced} are available ("advanced" is slower but has much longer period)

If the initial seed is not specified, the value of 76544321 will be used.

The {gauss} option will create a RNG object that generates pairs of Gaussian distributed random numbers as a complex random number.
The real and the imaginary parts of this number are independent random numbers taken from a Gaussian (i.e. "normal") distribution with unit variance.

For the Gaussian distribution, the Box-Muller transform method is used.
A good description of this method, along with the proof that the method
generates normally distributed random numbers, can be found in Knuth, 
"The Art of Computer Programming", Volume 2 (Seminumerical algorithms, third 
edition), section 3.4.1 

Note that unlike the global {Random} function, the RNG objects created with {RngCreate} are independent RNGs and do not affect each other.
They generate independent streams of pseudo-random numbers.
However, the {Random} function is slightly faster.

*E.G.

In> r1:=RngCreate(seed->1,dist->gauss)
Result: {"GaussianRNGDist","RNGEngine'LCG'2",{1}}
In> Rng(r1)
Result: Complex(-1.6668466417,0.228904004);
In> Rng(r1);
Result: Complex(0.0279296109,-0.5382405341);
The second RNG gives a uniform distribution (default option) but uses a more complicated algorithm:
In> [r2:=RngCreate(engine->advanced);Rng(r2);]
Result: 0.3653615377;
The generator {r1} can be re-initialized with seed 1 again to obtain the same sequence:
In> RngSeed(r1, 1)
Result: True;
In> Rng(r1)
Result: Complex(-1.6668466417,0.228904004);
	

*SEE Random, RandomInteger, RandomIntegerList, RandomIntegerMatrix
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/geometry/0000755000175000017500000000000011722677331025130 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/0000755000175000017500000000000011722677331024372 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/LogicRemoveTautologies.mpw0000644000175000017500000000426711502266107031552 0ustar  giovannigiovanni%mathpiper,def="LogicRemoveTautologies"

 // not clear is this will stay, but it is eq. to LogicSimplify(expr, 2)

1 # SimpleNegate(Not (_x))  <-- x;
2 # SimpleNegate(_x)        <-- Not(x);

/* LogicRemoveTautologies scans a list representing e1 Or e2 Or ... to find
   if there are elements p and  Not p in the list. This signifies p Or Not p,
   which is always True. These pairs are removed. Another function that is used
   is RemoveDuplicates, which converts p Or p into p.
*/

/* this can be optimized to walk through the lists a bit more efficiently and also take
care of duplicates in one pass */
LocalCmp(_e1, _e2)                  <-- IsLessThan(PipeToString() Write(e1), PipeToString() Write(e2));

// we may want to add other expression simplifers for new expression types
100 # SimplifyExpression(_x)        <-- x;

// Return values:
//  {True} means True
//  {} means False
LogicRemoveTautologies(_e) <--
[
  Local(i, len, negationfound); Bind(len, Length(e));
  Bind(negationfound, False);

  //Echo(e);
  e := BubbleSort(e, "LocalCmp");

  For(Bind(i, 1), (i <= len) And (Not negationfound), i++)
  [
    Local(x, n, j);
    // we can register other simplification rules for expressions
    //e[i] := MathNth(e,i) /:: {gamma(_y) <- SimplifyExpression(gamma(y))};
    Bind(x, MathNth(e,i));
    Bind(n, SimpleNegate(x));                    /* this is all we have to do because of
                                                the kind of expressions we can have coming in */

    For(Bind(j, i+1), (j <= len) And (Not negationfound), j++) [
        Local(y);
        Bind(y, MathNth(e,j));

        If(IsEqual(y, n),
            [
                //Echo({"Deleting from ", e, " i=", i, ", j=", j, Nl()});

                Bind(negationfound, True);
                //Echo({"Removing clause ", i, Nl()});
            ],
        If(IsEqual(y, x),
            [
                //Echo({"Deleting from ", e, " j=", j, Nl()});
                DestructiveDelete(e, j);
                Bind(len,SubtractN(len,1));
            ])
        );
    ];
    Check(len = Length(e), "Math", "The length computation is incorrect");
  ];

  If(negationfound, {True}, e);            /* note that a list is returned */
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/om/0000755000175000017500000000000011722677331025005 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/om/om.mpw0000644000175000017500000000113411316274015026133 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( "=>" , "logic1","implies" );
OMDef( "CNF"          ,          mathpiper,"cnf"                      );
OMDef( "LogicSimplify",          mathpiper,"logic_simplify"           );
OMDef( "CanProve"     ,          mathpiper,"can_prove"                );
OMDef( "LogicRemoveTautologies", mathpiper,"logic_remove_tautologies" );
OMDef( "Subsumes"     ,          mathpiper,"subsumes"                 );
// The following appear in the def file, but commented out:
//     "~",  mathpiper, "Not"
//     "|",  mathpiper, "Or"
//     "&",  mathpiper, "And"


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/Contradict.mpw0000644000175000017500000000100211371733712027176 0ustar  giovannigiovanni%mathpiper,def="Contradict"

10 # Contradict((_x) - (_y) == 0, (_x) - (_z) == 0)_(y != z)     <-- True;
12 # Contradict((_x) == (_y), (_x) == (_z))_(y != z)             <-- True;
13 # Contradict((_x) - (_y) == 0, (_x) - (_z) >= 0)_(z > y)      <-- True;
14 # Contradict((_x) - (_y) == 0, (_x) - (_z) >  0)_(z > y)      <-- True;
14 # Contradict(Not (_x) - (_y) >= 0, (_x) - (_z) >  0)_(z > y)  <-- True;
15 # Contradict(_a, _b)                                          <-- IsEqual(SimpleNegate(a), b);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/LogicFindWith.mpw0000644000175000017500000000104311371733712027603 0ustar  giovannigiovanni%mathpiper,def="LogicFindWith"

/* find the number of the list that contains n in it, a pointer to a list of lists in passed */
LogicFindWith(_list, _i, _n) <--
[
  Local(result, index, j);
  Bind(result, -1); Bind(index, -1);

  For(j := i+1, (result<0) And (j <= Length(list)), j++)
  [
    Local(k, len); Bind(len, Length(list[j]));
    For(k := 1, (result<0) And (k<=len), k++)
    [
      Local(el); Bind(el, list[j][k]);

      If(Contradict(n, el),
        [Bind(result, j); Bind(index, k);]);
    ];
  ];
  {result, index};
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/CanProve.mpw0000644000175000017500000000630011523200452026614 0ustar  giovannigiovanni%mathpiper,def="CanProve"

/* Small theorem prover for propositional logic, based on the
 * resolution principle.
 * Written by Ayal Pinkus, based on the simple theorem prover from "Prolog, Ivan Bratko, chapter 20"
 * Version 0.1 initial implementation.
 *
 *
 * Examples:
CanProve(( (a=>b) And (b=>c)=>(a=>c) ))  <-- True
CanProve(a  Or   Not a)                  <-- True
CanProve(True  Or  a)                    <-- True
CanProve(False  Or  a)                   <-- a
CanProve(a  And   Not a)                 <-- False
CanProve(a  Or b Or (a And b))           <-- a Or b
 */

 // <==> LogicSimplify(expr, 3)

/* CanProve tries to prove that the negation of the negation of
   the proposition is true. Negating twice is just a trick to
   allow all the simplification rules a la De Morgan to operate
 */
/*CanProve(_proposition)    <-- CanProveAux( Not CanProveAux( Not proposition));*/

CanProveAux(_proposition)    <-- LogicSimplify(proposition, 3);

CanProve(_proposition)      <-- CanProveAux( proposition );

%/mathpiper



%mathpiper_docs,name="CanProve",categories="User Functions;Propositional Logic"
*CMD CanProve --- try to prove statement
*STD
*CALL
	CanProve(proposition)

*PARMS

{proposition} -- an expression with logical operations

*DESC

MathPiper has a small built-in propositional logic theorem prover.
It can be invoked with a call to {CanProve}.

An example of a proposition is: "if a implies b and b implies c then
a implies c". MathPiper supports the following logical operations:

{Not} :     negation, read as "not"

{And}  :   conjunction, read as "and"

{Or}  :   disjunction, read as "or"

{=>}  : implication, read as "implies"

The abovementioned proposition would be represented by the following expression,

	( (a=>b) And (b=>c) ) => (a=>c)

MathPiper can prove that is correct by applying {CanProve}
to it:

In> CanProve(( (a=>b) And (b=>c) ) => (a=>c))
Result: True;

It does this in the following way: in order to prove a proposition $p$, it
suffices to prove that  $Not p$ is false. It continues to simplify  $Not p$
using the rules:

	Not  ( Not x)      --> x
(eliminate double negation),
	x=>y  -->  Not x  Or  y
(eliminate implication),
	Not (x And y)  -->  Not x  Or  Not y
(De Morgan's law),
	Not (x Or y) -->  Not x  And  Not y
(De Morgan's law),
	(x And y) Or z --> (x Or z) And (y Or z)
(distribution),
	x Or (y And z) --> (x Or y) And (x Or z)
(distribution),
and the obvious other rules, such as,
	True Or x --> True
etc.
The above rules will translate a proposition into a form

	(p1  Or  p2  Or  ...)  And  (q1  Or  q2
	   Or  ...)  And ...
If any of the clauses is false, the entire expression will be false.
In the next step, clauses are scanned for situations of the form:

	(p Or Y)  And  ( Not p Or Z) --> (Y Or Z)
If this combination {(Y Or Z)} is empty, it is false, and
thus the entire proposition is false.

As a last step, the algorithm negates the result again. This has the
added advantage of simplifying the expression further.

*E.G.

In> CanProve(a  Or   Not a)
Result: True;
In> CanProve(True  Or  a)
Result: True;
In> CanProve(False  Or  a)
Result: a;
In> CanProve(a  And   Not a)
Result: False;
In> CanProve(a  Or b Or (a And b))
Result: a Or b;
	

*SEE True, False, And, Or, Not
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/CNF.mpw0000644000175000017500000001031011316274015025507 0ustar  giovannigiovanni%mathpiper,def="CNF"


 // former LogicSimplify

/*
   Simplify a boolean expression. CNF is responsible
   for converting an expression to the following form:
        (p1  Or  p2  Or  ...)  And  (q1  Or  q2  Or  ...)  And ...
   That is, a conjunction of disjunctions.
*/


// Trivial simplifications
10  # CNF( Not  True)                  <-- False;
11  # CNF( Not  False)                 <-- True;
12  # CNF(True   And  (_x))            <-- CNF(x);
13  # CNF(False  And  (_x))            <-- False;
14  # CNF(_x   And  True)              <-- CNF(x);
15  # CNF(_x  And  False)              <-- False;
16  # CNF(True   Or  (_x))             <-- True;
17  # CNF(False  Or  (_x))             <-- CNF(x);
18  # CNF((_x)  Or  True )             <-- True;
19  # CNF((_x)  Or  False)             <-- CNF(x);

// A bit more complext
21  # CNF(_x  Or  _x)                  <-- CNF(x);
22  # CNF(_x  And  _x)                 <-- CNF(x);
23  # CNF(_x  Or Not (_x))             <-- True;
14  # CNF(Not (_x)  Or _x)             <-- True;
25  # CNF(_x  And Not (_x))            <-- False;
26  # CNF(Not (_x)  And _x)            <-- False;

// Simplifications that deal with (in)equalities
25  # CNF(((_x) == (_y))   Or  ((_x) !== (_y)))   <-- True;
25  # CNF(((_x) !== (_y))  Or  ((_x) == (_y)))    <-- True;
26  # CNF(((_x) == (_y))   And ((_x) !== (_y)))   <-- False;
26  # CNF(((_x) !== (_y))  And ((_x) == (_y)))    <-- False;

27  # CNF(((_x) >= (_y))   And ((_x) < (_y)))     <-- False;
27  # CNF(((_x) < (_y))    And ((_x) >= (_y)))    <-- False;
28  # CNF(((_x) >= (_y))   Or  ((_x) < (_y)))     <-- True;
28  # CNF(((_x) < (_y))    Or  ((_x) >= (_y)))    <-- True;


// some things that are more complex
120  # CNF((_x)  Or  (_y))            <-- LogOr(x, y, CNF(x), CNF(y));
10 # LogOr(_x,_y,_x,_y)               <-- x Or y;
20 # LogOr(_x,_y,_u,_v)               <-- CNF(u Or v);

130  # CNF( Not  (_x))                <-- LogNot(x, CNF(x));
10 # LogNot(_x, _x)                   <-- Not (x);
20 # LogNot(_x, _y)                   <-- CNF(Not (y));

40 # CNF( Not ( Not  (_x)))           <-- CNF(x);                           // eliminate double negation
45 # CNF((_x)=>(_y))                  <-- CNF((Not (x))  Or  (y));              // eliminate implication

50 # CNF( Not ((_x)  And  (_y)))      <-- CNF((Not x) Or (Not y));          // De Morgan's law
60 # CNF( Not ((_x)  Or  (_y)))       <-- CNF(Not (x)) And CNF(Not (y));        // De Morgan's law

/*
70 # CNF((_x) And ((_y)  Or  (_z)))   <-- CNF(x And y) Or CNF(x And z);
70 # CNF(((_x) Or (_y)) And (_z))     <-- CNF(x And z) Or CNF(y And z);

80 # CNF((_x)  Or  ((_y)  And  (_z))) <-- CNF(x Or y) And CNF(x Or z);
80 # CNF(((_x)  And  (_y)) Or (_z))   <-- CNF(x Or z) And CNF(y Or z);
*/

70 # CNF(((_x)  And  (_y))  Or  (_z)) <-- CNF(x Or z) And CNF(y Or z);      // Distributing Or over And
80 # CNF((_x)  Or  ((_y)  And  (_z))) <-- CNF(x Or y) And CNF(x Or z);

90 # CNF((_x)  And  (_y))             <-- CNF(x) And CNF(y);                // Transform subexpression

101 # CNF( (_x) < (_y) )              <-- Not CNFInEq(x >=  y);
102 # CNF( (_x) > (_y) )              <-- CNFInEq(x >   y);
103 # CNF( (_x) >= (_y) )             <-- CNFInEq(x >=  y);
104 # CNF( (_x) <= (_y) )             <-- Not CNFInEq(x >  y);
105 # CNF( (_x) == (_y) )             <-- CNFInEq(x ==  y);
106 # CNF( (_x) !== (_y) )            <-- Not CNFInEq(x == y);

111 # CNF( Not((_x) <  (_y)) )        <-- CNFInEq( x >= y );
113 # CNF( Not((_x) <= (_y)) )        <-- CNFInEq( x > y );
116 # CNF( Not((_x) !== (_y)) )       <-- CNFInEq( x == y );

/* Accept as fully simplified, fallthrough case */
200 # CNF(_x)                         <-- x;

20 # CNFInEq((_xex) == (_yex))        <-- (CNFInEqSimplify(xex-yex) ==  0);
20 # CNFInEq((_xex) > (_yex))         <-- (CNFInEqSimplify(xex-yex) >   0);
20 # CNFInEq((_xex) >= (_yex))        <-- (CNFInEqSimplify(xex-yex) >=  0);
30 # CNFInEq(_exp)                    <-- (CNFInEqSimplify(exp));

10 # CNFInEqSimplify((_x) - (_x))     <-- 0;        // strictly speaking, this is not always valid, i.e. 1/0 - 1/0 != 0...
100# CNFInEqSimplify(_x)              <-- [/*Echo({"Hit the bottom of CNFInEqSimplify with ", x, Nl()});*/ x;];
                                                    // former "Simplify";



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/DoUnitSubsumptionAndResolution.mpw0000644000175000017500000000435611371733712033305 0ustar  giovannigiovanni%mathpiper,def="DoUnitSubsumptionAndResolution"

// perform unit subsumption and resolutiuon for a unit clause # i
// a boolean indicated whether there was a change is returned
DoUnitSubsumptionAndResolution(_list) <--
[
    Local(i, j, k, isFalse, isTrue, changed);
    Bind(isFalse, False);
    Bind(isTrue,  False);
    Bind(changed, True);

    //Echo({"In DoUnitSubsumptionAndResolution", Nl()});

    While(changed) [
      Bind(changed, False);

      For(i:=1, (Not isFalse And Not isTrue) And i <= Length(list), i++)
      [
        If(Length(list[i]) = 1, [
          Local(x); Bind(x, list[i][1]); //n := SimpleNegate(x);
          //Echo({"Unit clause ", x, Nl()});

          // found a unit clause, {x}, not use it to modify other clauses
          For(j:=1, (Not isFalse And Not isTrue) And j <= Length(list), j++)
          [
              If(i !=j, [
                Local(deletedClause); Bind(deletedClause, False);
                For(k:=1, (Not isFalse And Not isTrue And Not deletedClause) And k <= Length(list[j]),  k++)
                [
                    // In both of these, if a clause becomes empty, the whole thing is False

                    //Echo({"   ", x, " subsumes ", list[j][k], i,j, Subsumes(x, list[j][k]), Nl()});

                    // unit subsumption -- this kills clause j
                    If(Subsumes(x, list[j][k]), [
                        // delete this clause
                        DestructiveDelete(list, j);
                        j--;
                        If(i>j, i--);   // i also needs to be decremented
                        Bind(deletedClause, True);
                        Bind(changed, True);
                        If(Length(list) = 0, [Bind(isTrue, True);]);
                    ],
                      // else, try unit resolution
                    If(Contradict(x, list[j][k]), [
                        //Echo({x, " contradicts", list[j][k], Nl()});
                        DestructiveDelete(list[j], k);
                        k--;
                        Bind(changed, True);
                        If(Length(list[j]) = 0, [Bind(isFalse, True);]);
                    ])
                    );
                ];
              ]);
          ];
        ]);
      ];
    ];

    list;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/equals_greaterthan_operator.mpw0000644000175000017500000000006711321250634032677 0ustar  giovannigiovanni%mathpiper,def="=>"

Rulebase("=>",{a,b});

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/LogicSimplify.mpw0000644000175000017500000000277511502266107027673 0ustar  giovannigiovanni%mathpiper,def="LogicSimplify"

 // (expression, level=1..3

// Some shortcuts to match prev interface

10 # LogicSimplify(_proposition, _level)_(level<2)  <-- CNF(proposition);

20 # LogicSimplify(_proposition, _level) <--
[
  Local(cnf, list, clauses);
  Check(level > 1, "Argument", "Wrong level");
  // First get the CNF version of the proposition
  Bind(cnf, CNF(proposition));

  If(level <= 1, cnf, [
    Bind(list, Flatten(cnf, "And"));
    Bind(clauses, {});
    ForEach(clause, list)
    [
      Local(newclause);
      //newclause := BubbleSort(LogicRemoveTautologies(Flatten(clause, "Or")), LessThan);
      Bind(newclause, LogicRemoveTautologies(Flatten(clause, "Or")));
      If(newclause != {True}, DestructiveAppend(clauses, newclause));
    ];

    /*
        Note that we sort each of the clauses so that they look the same,
        i.e. if we have (A And B) And ( B And A), only the first one will
        persist.
    */
    Bind(clauses, RemoveDuplicates(clauses));

    If(IsEqual(level, 3) And (Length(clauses) != 0), [
        Bind(clauses, DoUnitSubsumptionAndResolution(clauses));
        Bind(clauses, LogicCombine(clauses));
    ]);

    Bind(clauses, RemoveDuplicates(clauses));

    If(IsEqual(Length(clauses), 0), True, [
        /* assemble the result back into a boolean expression */
        Local(result);
        Bind(result, True);
        ForEach(item,clauses)
        [
            Bind(result, result And UnFlatten(item, "Or", False));
        ];

        result;
    ]);
  ]);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/LogicCombine.mpw0000644000175000017500000000232211502266107027437 0ustar  giovannigiovanni%mathpiper,def="LogicCombine"

/* LogicCombine is responsible for scanning a list of lists, which represent
   a form (p1  Or  p2  Or  ...)  And  (q1  Or  q2  Or  ...)  And ... by scanning the lists
   for combinations x Or Y  And   Not x Or Z <-- Y Or Z . If Y Or Z is empty then this clause
   is false, and thus the entire proposition is false.
*/
LogicCombine(_list) <--
[
  Local(i, j);
  For(Bind(i,1), i<=Length(list), Bind(i,AddN(i,1)))
  [
    //Echo({"list[", i, "/", Length(list), "]: ", list[i], Nl()});

    For(j := 1, (j<=Length(list[i])), j++)
    [
      Local(tocombine, n, k);
      Bind(n, list[i][j]);

      {tocombine, k} := LogicFindWith(list, i, n);// search forward for n, tocombine is the list we
                                                  // will combine the current one with
      If(tocombine != -1,
      [
        Local(combination);
        Check(k != -1, "Math", "k is -1");

        Bind(combination, LogicRemoveTautologies(Concat(list[i], list[tocombine])));
        If(combination = {},                      // the combined clause is false, so the whole thing is false
          [Bind(list, {{}}); Bind(i, Length(list)+1);], [/*Bind(i, 0);*/]);
      ]);
    ];
  ];
  list;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/logic/Subsumes.mpw0000644000175000017500000000122611316274015026715 0ustar  giovannigiovanni%mathpiper,def="Subsumes"

10 # Subsumes((_x) - (_y) == 0, Not ((_x) - (_z)==0))_(y!=z)    <-- True;
// suif_tmp0_127_1-72==0 And 78-suif_tmp0_127_1>=0
20 # Subsumes((_x) - (_y) == 0, (_z) - (_x) >= 0)_(z>=y)        <-- True;
20 # Subsumes((_x) - (_y) == 0, (_z) - (_x) >  0)_(z>y)         <-- True;
// suif_tmp0_127_1-72==0 And suif_tmp0_127_1-63>=0
30 # Subsumes((_x) - (_y) == 0, (_x) - (_z) >= 0)_(y>=z)        <-- True;
30 # Subsumes((_x) - (_y) == 0, (_x) - (_z) > 0)_(y>z)          <-- True;

90 # Subsumes((_x), (_x))                                       <-- True;

100# Subsumes((_x), (_y))                                       <-- False;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/0000755000175000017500000000000011722677331025130 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/0000755000175000017500000000000011722677330026407 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolveSystem.mpw0000644000175000017500000000430011517224250031605 0ustar  giovannigiovanni%mathpiper,title="xSolveSystem"

//Retract("xSolve'System",*);
//Retract("xSolveLinearSystemViaMatrix",*);


10 # xSolve'System( eqns_IsList, vars_IsList ) <--
[
    If(iDebug=True,Tell("xSolve'System",{eqns,vars}));
    Local(zeros,expr,const,newEquations);
    zeros        := FillList(0,Length(vars));
    newEquations := {};
    ForEach(eqn,eqns)
    [
        expr  := EquationLeft(eqn) - EquationRight(eqn);
        //If(iDebug,Tell("  1",expr));
        const := WithValue(vars,zeros,expr);
        //Echo("      eqn: ",eqn," ,     const term: ",const);
        Push(newEquations,Simplify(expr - const)==-const);
        ForEach(var,vars)
        [
            deg := Degree(expr,var);
            //Echo("      var =   ",var," :  degree: ",deg););
        ];
    ];
    newEquations := Reverse(newEquations);    
    xSolveLinearSystemViaMatrix(newEquations,vars);
];
        
10 # xSolve'System( eqns_IsList ) <--
[
    Local(vars);
    If(iDebug=True,Tell("xSolve'System",eqns));
    vars := VarList(eqns);
    xSolve'System(eqns,vars);
];


10 # xSolveLinearSystemViaMatrix( eqns_IsList, vars_IsList ) <--
[
    Local(LE,LV,E,LHS,X,M,RHS,LL,eqn,row,ans,Det);
    If(iDebug=True,Tell(xSolveLinearSystemViaMatrix,{eqns,vars}));
    LE := Length(eqns);
    LV := Length(vars);
    E  := Assert() LE=LV;
    Check(E, "Argument", "Number of equations != Number of variables");
    
    LHS := {};
    RHS := {};
    X   := vars;
    M   := FillList(1,LE);
    ForEach(eqn,eqns) 
    [
        //If(iDebug,[Echo(EquationLeft(eqn)); Echo(EquationRight(eqn));]);
        E   := FunctionToList(eqn);
        LL  := E[2];
        RHS := E[3]:RHS;
        row := Map("Coef",{FillList(LL,LE),X,M});
        LHS := row:LHS;   
    ];
    LHS := DestructiveReverse(LHS);
    RHS := DestructiveReverse(RHS);
    Det := Determinant(LHS);
    /*
    If(iDebug=True,
        [      
            Tell(" LHS",LHS);
            Tell(" RHS",RHS);
            Tell(" det",Det);
        ]
    );   
    */
    ans := MatrixSolve(LHS,RHS);
    //If(iDebug=True,Tell("ans ",ans));
    ans := Map("==",{vars,ans});
];

12 # xSolveLinearSystemViaMatrix( _eqns, _vars ) <-- False;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolvePoly.mpw0000644000175000017500000000526411517224250031256 0ustar  giovannigiovanni%mathpiper,title="xSolvePoly"

//Retract("xSolve'Poly",*);

/******************** xSolve'Poly ********************/

/* Tries to solve by calling PSolve */
/* Returns Failed if this doesn't work, and the solution otherwise */

/* CanBeUni is not documented, but defined in univar.rep/code.mpi */
/* It returns True iff 'expr' is or can be considered to be a univariate polynomial in 'var' */

10 # xSolve'Poly(_expr, _var)_(Not CanBeUni(var, expr)) <-- 
  [
      If(iDebug=True,Tell("xSolvePoly_NoUni",{expr,var}));
      Failed;
  ];

  
20 # xSolve'Poly(_expr, _var) <--
  LocalSymbols(x)
  [
      If(iDebug=True,Tell("xSolvePoly_Uni_F",{expr,var}));
      Local(factors,nfactors,roots);
      factors  := Factors(expr);
      nfactors := Length(factors);
      If(iDebug=True,Tell("  sp1",{nfactors,factors}));
      roots := {};
      ForEach(factor,factors) 
          If(Contains(VarList(factor[1]),var),
              [
                  Local(rs,r);
                  rs := PSolve(factor[1],var);
                  If(iDebug=True,Tell("    sp2",rs));
                  If( Type(rs)="List",
                      ForEach(r,rs) Push(roots,r),
                      Push(roots,rs)
                  );
              ]
          );
      If(iDebug=True,Tell("  sp3",roots));
      Local(result);
      If(Type(roots) = "List",
          [
              If(iDebug=True,Tell("   sp4_is_list",Length(roots)));
              If(Length(roots) > 1, 
                  [Tell("      >1"); result := MapSingle({{t},var==t}, roots);],
                  If( Type(roots[1]) = "List",
                      [Tell("        List"); result := MapSingle({{t},var==t}, roots[1]);],
                      [Tell("        Not List"); result := {var == roots[1]};]
                  )
              );
          ],  
          [
              If(iDebug=True,Tell("   sp4_not_list"));
              result := {var == roots};
          ]
       );  
       result;
  ];
  
  
/* 
 * The call to PSolve (below) can have three kind of results
 *   1) PSolve returns a single root
 *   2) PSolve returns a list of roots
 *   3) PSolve remains unevaluated
 */

30 # xSolve'Poly(_expr, _var) <--
  LocalSymbols(x)
  [
      If(iDebug=True,Tell("xSolvePoly_Uni_P",{expr,var}));
      Local(roots);
      roots := PSolve(expr, var);
      If(Type(roots) = "PSolve",
         Failed,                               /* Case 3 */
         If(Type(roots) = "List",
             MapSingle({{x},var==x}, roots),   /* Case 2 */
             {var == roots})                   /* Case 1 */
      );
  ];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xTerms.mpw0000644000175000017500000000555011517224250030412 0ustar  giovannigiovanni%mathpiper,title="xTerms"

//Retract("xTerms",*);
//Retract("xTerms2",*);

xTerms(_expr) <--
[
    Local(L,n,h,s,t,f,stack,qs,topLevelPM,nTerms,firstH);
    If( InVerboseMode(),[ Echo("in xTerms()"); Echo("  input expression: ",expr); ]);    
    If( Not IsList( stack ), stack := {} );
    topLevelPM := 0;
    firstH     := 0;
    qs         := 1;
    f          := expr;      
    
    While( IsFunction(f) )
        [
            L  := FunctionToList(f);
            n  := Length(L);
            h  := Head( L );
            If(h=ToAtom("+") Or h=ToAtom("-"),[If(firstH=0,firstH=1);topLevelPM++;]);
            If(InVerboseMode(),Echo("  f=",f,"  n=",n,"  L=",L,"   h=",h,"   firstH=",firstH,"  tlpm=",topLevelPM));
            If (n=3, 
                [
                    If( h=ToAtom("-"), s:=-1, s:=1 );
                    t := s * L[3];
                    If(InVerboseMode(),Echo("                     t= ",t));
                    If( (h=ToAtom("*") Or h=ToAtom("/") Or h=ToAtom("^")), Push(stack,f), Push(stack,t) );
                    f := L[2];   
                    If(InVerboseMode(), [
                        Echo("         new f=",f);
                        Echo("                                     stack=",stack); ]
                    );
                ],
                [
                    If( h=ToAtom("-"),[f:=L[2];qs:=-1;],
                        [
                            Push(stack,ListToFunction(L));
                            If( InVerboseMode(), [
                                Echo("          n=",n,"      L=",L,"     h=",h);
                                Echo("DONE");
                                Echo("|---> ",stack," <---|"); ]
                            );
                            f:="STOP";
                        ]
                    );
                ]
            );    
        ];
    If( (Not IsFunction(f)) And (Length(stack)=0), stack := {f});
    stack := qs * stack;
    If(qs>0,nTerms:=topLevelPM+1,nTerms:=topLevelPM);
    If(InVerboseMode(),Echo("==========================  stack = ",stack));
    If( nTerms > Length(stack), Echo("  >>>> RESULT should be one term longer"));
    //If(firstH != ToAtom("+") And  firstH != ToAtom("-") And tlpm >0,Echo("  >>>> RESULT should be one term shorter"));
    stack;
];

UnFence( "xTerms", 1 );

xTerms2(_expr) <--
[
    Local(L,stack,result,lenL);
    If(InVerboseMode(),[ Tell("in xTerms2()"); Tell("   input expression: ",expr); ]);    
    If( Not IsList( stack ), stack := {} );
    If( IsAtom(expr), L:={expr}, L:=FunctionToList(expr) );
    lenL := Length(L);
    If(InVerboseMode(), Tell("   0",{L,lenL}) );  
    If( lenL = 1, [ stack := L:stack; Tell("   1",stack); ] );
    If( lenL = 2, [ stack := L[1]:L[2]:stack; Tell("   2",stack); ] );
    If( lenL = 3, [ stack := L[1]:L[2]:L[3]:stack; Tell("   3",stack); ] );
    
    result := stack;
];

UnFence( "xTerms2", 1 );

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolve.mpw0000644000175000017500000004153711523200452030410 0ustar  giovannigiovanni%mathpiper,title="xSolve"

//Retract("xSolve",*);
//Retract("xSolve'Simple",*);
//Retract("xSolve'Divide",*);


/*
 * Strategy for Solve(expr, x):
 *
 * 10.  Call xSolve'System for systems of equations.
 * 20.  Check arguments.
 * 30.  Get rid of "==" in 'expr'.
 * 40.  Special cases.
 * 50.  If 'expr' is a polynomial in 'x', try to use PSolve.
 * 60.  If 'expr' is a product, solve for either factor.
 * 70.  If 'expr' is a quotient, solve for the denominator.
 * 80.  If 'expr' is a sum and one of the terms is free of 'x',
 *      try to use xSolve'Simple.
 * 90.  If every occurance of 'x' is in the same context, use this to reduce
 *      the equation. For example, in 'Cos(x) + Cos(x)^2 == 1', the variable
 *      'x' always occurs in the context 'Cos(x)', and hence we can attack
 *      the equation by first solving 'y + y^2 == 1', and then 'Cos(x) == y'.
 *      This does not work for 'Exp(x) + Cos(x) == 2'.
 * 100. Apply Simplify to 'expr', and try again.
 * 110. Give up.
 */

LocalSymbols(res)
[
  10  # xSolve(expr_IsList, var_IsList) <-- 
    [
        If(iDebug=True,Tell("xSolve1",{expr,var}));
        xSolve'System(expr, var);
    ];
  
  20  # xSolve(_expr, _var)_(Not IsAtom(var) Or IsNumber(var) Or IsString(var)) <--
    [ 
        If(iDebug=True,Tell("xSolve2",{expr,var}));
        Assert("xSolve'TypeError", "Second argument, ":(PipeToString() Write(var)):", is not the name of a variable") False; {}; 
    ];
    
  30  # xSolve(_lhs == _rhs, _var) <-- 
    [
        If(iDebug=True,
           [
              Tell("xSolve3",{lhs,rhs,var});
              If(IsRationalFunction(lhs,var),
                 Tell("  3r IsRationalFunction",lhs),
                 Tell("  3r NotRationalFunction",lhs)
              );
              If(IsRationalFunction(rhs,var),
                 Tell("  3r IsRationalFunction",rhs),
                 Tell("  3r NotRationalFunction",rhs)
              );
           ]
        );
        Local(simpexpression);
        simpexpression  := Simplify(lhs-rhs);
        If(IsRationalFunction(simpexpression,var),
            [
                xSolve'Rational(simpexpression, var);
            ],
            [
                xSolve(simpexpression, var);  //  new hso 090923
            ]
        );
    ];
    
  40  # xSolve(0, _var) <--
    [
        If(iDebug=True,Tell("xSolve4",{0,var}));
        {var == var};
    ];
  
  41  # xSolve(a_IsConstant, _var) <-- 
    [
        If(iDebug=True,Tell("xSolve5",{a,var}));
        {};
    ];
  
  42  # xSolve(_expr, _var)_(Not HasExpr(expr,var)) <--
    [ 
        If(iDebug=True,Tell("xSolve6",{expr,var}));
        Assert("xSolve", "expression ":(PipeToString() Write(expr)):" does not depend on ":PipeToString() Write(var)) False; {}; 
    ];
    
  44 # xSolve(Sqrt(_expr1) - _expr2,_var) <-- 
           [If(iDebug=Trfue,Tell("xSolve441",{expr1,expr2,var}));xSolve'Sqrts(expr1,expr2,var);];

  44 # xSolve(Sqrt(_expr1) + _expr2,_var) <-- 
           [If(iDebug=True,Tell("xSolve442",{expr1,expr2,var}));xSolve'Sqrts(expr1,-expr2,var);];

  44 # xSolve(_expr2 - Sqrt(_expr1),_var) <-- 
           [If(iDebug=True,Tell("xSolve443",{expr2,expr1,var}));xSolve'Sqrts(expr1,expr2,var);];

  44 # xSolve(-_expr2 - Sqrt(_expr1),_var) <-- 
           [If(iDebug=True,Tell("xSolve444",{expr2,expr1,var}));xSolve'Sqrts(expr1,-expr2,var);];
  
    
  45 # xSolve(Sqrt(_expr1)-Sqrt(_expr2),_var) <--
    [
        If(iDebug=True,Tell("xSolve2Sqrts-",{expr1,expr2}));
        Local(solution);
        solution := xSolve(expr1-expr2,var);
        xCheckSolution(Sqrt(expr1)-Sqrt(expr2),var,solution);
    ];    
    
  45 # xSolve(Sqrt(_expr1)+Sqrt(_expr2),_var) <--
    [
        If(iDebug=True,Tell("xSolve2Sqrts+",{expr1,expr2}));
        Local(solution);
        solution := xSolve(expr1-expr2,var);
        xCheckSolution(Sqrt(expr1)+Sqrt(expr2),var,solution);
    ];    
        
  50  # xSolve(_expr, _var)_((res := xSolve'Poly(expr, var)) != Failed) <-- 
    [
        If(iDebug=True,Tell("xSolve7Poly",{expr,var,res}));
        res;
    ];
  
  60  # xSolve(_e1 * _e2, _var) <-- 
    [
        If(iDebug=True,Tell(8,{e1,e2,var}));
        Union(xSolve(e1,var), xSolve(e2,var));
    ];
  
  70  # xSolve(_e1 / _e2, _var) <-- 
    [
        If(iDebug=True,Tell(9,{e1,e2,var}));
        xSolve(e1, var);
    ];
  
  80  # xSolve(_e1 + _e2, _var)_(Not HasExpr(e2,var) And (res := xSolve'Simple(e1,-e2,var)) != Failed) <-- 
    [
        If(iDebug=True,Tell(10,{e1,e2,var,res}));
        res;
    ];
  
  80  # xSolve(_e1 + _e2, _var)_(Not HasExpr(e1,var) And (res := xSolve'Simple(e2,-e1,var)) != Failed) <-- 
    [
        If(iDebug=True,Tell(11,{e1,e2,var,res}));
        res;
    ];
  
  80  # xSolve(_e1 - _e2, _var)_(Not HasExpr(e2,var) And (res := xSolve'Simple(e1,e2,var)) != Failed) <-- 
    [
        If(iDebug=True,Tell(12,{e1,e2,var,res}));
        res;
    ];
  
  80  # xSolve(_e1 - _e2, _var)_(Not HasExpr(e1,var) And (res := xSolve'Simple(e2,e1,var)) != Failed) <-- 
    [
        If(iDebug=True,Tell(13,{e1,e2,var,res}));
        res;
    ];
  
  85  # xSolve(_expr, _var)_((res := xSolve'Simple(expr, 0, var)) != Failed) <-- 
    [
        If(iDebug=True,Tell("xSolve14Simple_succeeded",{expr,var,res}));
        res;
    ];
  
  90  # xSolve(_expr, _var)_((res := xSolve'Reduce(expr, var)) != Failed) <-- 
    [
        If(iDebug=True,Tell("xSolve15Reduce_succeeded",{expr,var,res}));
        res;
    ];
  
  95  # xSolve(_expr, _var)_((res := xSolve'Divide(expr, var)) != Failed) <-- 
    [
        If(iDebug=True,Tell("xSolve16Divide_succeeded",{expr,var,res}));
        res;
    ];
  
  100 # xSolve(_expr, _var)_((res := Simplify(expr)) != expr) <-- 
    [
        If(iDebug=True,Tell("xSolve17Simplified",{expr,var,res}));
        xSolve(res, var);
    ];
  
  110 # xSolve(_expr, _var) <--
    [ 
        If(iDebug,Tell("xSolve18Fails",{expr,var}));
        Assert("xSolve'Fails", "cannot solve equation ":(PipeToString() Write(expr)):" for ":PipeToString() Write(var)) False; {}; 
    ];
];    // LocalSymbols

/******************** xSolve'Simple ********************/

/* Simple solver of equations
 *
 * Returns (possibly empty) list of solutions,
 * or Failed if it cannot handle the equation
 *
 * Calling format: xSolve'Simple(lhs, rhs, var)
 *                 to solve 'lhs == rhs'.
 *
 * Note: 'rhs' should not contain 'var'.
 */

20 # xSolve'Simple(_e1 + _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve51aSimple",{e1,e2,rhs,var}));
      { var == rhs-e2 };
  ];
  
20 # xSolve'Simple(_e1 + _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve51bSimple",{e1,e2,rhs,var}));
      { var == rhs-e1 };
  ];

20 # xSolve'Simple(_e1 - _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve52aSimple",{e1,e2,rhs,var}));
      { var == rhs+e2 };
  ];

20 # xSolve'Simple(_e1 - _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve52bSimple",{e1,e2,rhs,var}));
      { var == e1-rhs };
  ];

20 # xSolve'Simple(-(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve53Simple",{e1,rhs,var}));
      { var == -rhs };
  ];

20 # xSolve'Simple(_e1 * _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve54aSimple",{e1,e2,rhs,var}));
      { var == rhs/e2 };
  ];

20 # xSolve'Simple(_e1 * _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- 
  [
      If(iDebug=True,Tell("xSolve54bSimple",{e1,e2,rhs,var}));
      { var == rhs/e1 };
  ];

20 # xSolve'Simple(_e1 / _e2, _rhs, _var)_(e1 = var And Not HasExpr(e2,var)) <-- 
  [
      If(iDebug,Tell("xSolve55aSimple",{e1,e2,rhs,var}));
      { var == rhs*e2 };
  ];

10 # xSolve'Simple(_e1 / _e2, 0,    _var)_(e2 = var And Not HasExpr(e1,var)) <-- 
  [
      If(iDebug,Tell("xSolve55bSimple",{e1,e2,var}));
      { };
  ];

20 # xSolve'Simple(_e1 / _e2, _rhs, _var)_(e2 = var And Not HasExpr(e1,var)) <-- 
  [
      If(iDebug,Tell("xSolve55cSimple",{e1,e2,rhs,var}));
      { var == e1/rhs };
  ];

LocalSymbols(x)
[
  20 # xSolve'Simple(_e1 ^ _n, _rhs, _var)_(e1 = var And IsPositiveInteger(n)) <--
     [
         If(iDebug,Tell("xSolve56aSimple",{e1,n,rhs,var}));
         MapSingle({{x}, var == rhs^(1/n)*x}, Exp(2*Pi*I*(1 .. n)/n));
     ];
       
  20 # xSolve'Simple(_e1 ^ _n, _rhs, _var)_(e1 = var And IsNegativeInteger(n)) <--
     [
         If(iDebug,Tell("xSolve56bSimple",{e1,n,rhs,var}));
         MapSingle({{x}, var == rhs^(1/n)*x}, Exp(2*Pi*I*(1 .. (-n))/(-n)));
     ];
       
];

20 # xSolve'Simple(_e1 ^ _e2, _rhs, _var)
     _ (IsPositiveReal(e1) And e1 != 0 And e2 = var And IsPositiveReal(rhs) And rhs != 0)
     <-- [
             If(iDebug,Tell("xSolve57Simple",{e1,e2,rhs,var}));
             { var == Ln(rhs)/Ln(e1) };
         ];

/* Note: These rules do not take the periodicity of the trig. functions into account */

10 # xSolve'Simple(Sin(_e1), 1,    _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve61aSimple",{e1,var}));
      { var == 1/2*Pi };
  ];
  
10 # xSolve'Simple(Sin(_e1), _rhs, _var)_(e1 = var And rhs = -1) <-- 
  [
      If(iDebug=True,Tell("xSolve61bSimple",{e1,rhs,var}));
      { var == 3/2*Pi };
  ];
  
20 # xSolve'Simple(Sin(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve61cSimple",{e1,rhs,var}));
      { var == ArcSin(rhs), var == Pi-ArcSin(rhs) };
  ];
  
10 # xSolve'Simple(Cos(_e1), 1,    _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve62aSimple",{e1,var}));
      { var == 0 };
  ];

10 # xSolve'Simple(Cos(_e1), _rhs, _var)_(e1 = var And rhs = -1) <-- 
  [
      If(iDebug,Tell("xSolve62bSimple",{e1,rhs,var}));
      { var == Pi };
  ];

20 # xSolve'Simple(Cos(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug,Tell("xSolve62cSimple",{e1,rhs,var}));
      { var == ArcCos(rhs), var ==  -ArcCos(rhs) };
  ];

20 # xSolve'Simple(Tan(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug,Tell("xSolve63aSimple",{e1,rhs,var}));
      { var == ArcTan(rhs) };
  ];

20 # xSolve'Simple(ArcSin(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug,Tell("xSolve63bSimple",{e1,rhs,var}));
      { var == Sin(rhs) };
  ];

20 # xSolve'Simple(ArcCos(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug,Tell("xSolve63cSimple",{e1,rhs,var}));
      { var == Cos(rhs) };
  ];

20 # xSolve'Simple(ArcTan(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug,Tell("xSolve63dSimple",{e1,rhs,var}));
      { var == Tan(rhs) };
  ];

/* Note: Second rule neglects (2*I*Pi)-periodicity of Exp() */

10 # xSolve'Simple(Exp(_e1), 0,    _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve64aSimple",{e1,var}));
      { };
  ];

20 # xSolve'Simple(Exp(_e1), _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve64bSimple",{e1,rhs,var}));
      { var == Ln(rhs) };
  ];

20 # xSolve'Simple(Ln(_e1),  _rhs, _var)_(e1 = var) <-- 
  [
      If(iDebug=True,Tell("xSolve64cSimple",{e1,rhs,var}));
      { var == Exp(rhs) };
  ];

/* The range of Sqrt is the set of (complex) numbers with either
 * positive real part, together with the pure imaginary numbers with
 * nonnegative real part. */
 
20 # xSolve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And IsPositiveReal(Re(rhs)) And Re(rhs) != 0) <-- 
  [
      If(iDebug,Tell("xSolve65aSimple",{e1,rhs,var}));
      { var == rhs^2 };
  ];

20 # xSolve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And Re(rhs)=0 And IsPositiveReal(Im(rhs))) <-- 
  [
      If(iDebug,Tell("xSolve65bSimple",{e1,rhs,var}));
      { var == rhs^2 };
  ];

20 # xSolve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And Re(rhs)=0 And IsNegativeReal(Im(rhs)) And Im(rhs) != 0) <-- 
  [
      If(iDebug,Tell("xSolve65cSimple",{e1,rhs,var}));
      { };
  ];

20 # xSolve'Simple(Sqrt(_e1), _rhs, _var)_(e1 = var And IsNegativeReal(Re(rhs)) And Re(rhs) != 0) <-- 
  [
      If(iDebug,Tell("xSolve65dSimple",{e1,rhs,var}));
      { };
  ];

30 # xSolve'Simple(_lhs, _rhs, _var) <-- 
  [
      If(iDebug,Tell("xSolve66Simple_failed",{lhs,rhs,var}));
      Failed;
  ];


/******************** xSolve'Divide ********************/

/* For some classes of equations, it may be easier to solve them if we
 * divide through by their first term.  A simple example of this is the
 * equation  Sin(x)+Cos(x)==0
 * One problem with this is that we may lose roots if the thing we
 * are dividing by shares roots with the whole equation.
 * The final HasExprs are an attempt to prevent infinite recursion caused by
 * the final Simplify step in xSolve undoing what we do here.  It's conceivable
 * though that this won't always work if the recurring loop is more than two
 * steps long.  I can't think of any ways this can happen though :)
 */

10 # xSolve'Divide(_e1 + _e2, _var)_(HasExpr(e1, var) And HasExpr(e2, var)
		And Not (HasExpr(Simplify(1 + (e2/e1)), e1)
		      Or HasExpr(Simplify(1 + (e2/e1)), e2))) <--
     [
         If(iDebug,Tell("xSolve71aDivide",{e1,e2,var}));
         xSolve(1 + (e2/e1), var);
     ];
                                           
10 # xSolve'Divide(_e1 - _e2, _var)_(HasExpr(e1, var) And HasExpr(e2, var)
		And Not (HasExpr(Simplify(1 - (e2/e1)), e1)
		      Or HasExpr(Simplify(1 - (e2/e1)), e2))) <--
     [
         If(iDebug,Tell("xSolve71bDivide",{e1,e2,var}));
         xSolve(1 - (e2/e1), var);
     ];

20 # xSolve'Divide(_e, _var) <-- 
  [
      If(iDebug,Tell("xSolve72Divide_failed",{e,var}));
      Failed;
  ];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="xSolve",categories="User Functions;Solvers (Symbolic)",access="experimental"
*CMD Solve --- solve an equation or set of linear equations
*STD
*CALL
	xSolve(eq, var)

*PARMS

{eq} -- equation to solve, or List of equations

{var} -- variable (or List of variables) to solve for

*DESC

This command tries to solve an equation or system of linear equations. 
If {eq} does not contain the {==} operator, it is assumed that the user 
wants to solve $eq == 0$. The result is a list of equations of the form 
{var == value}, each representing a solution of the given equation or
system. The {Where} operator can be used to substitute this solution 
in another expression. If the given equation or system {eq} does not 
have any solutions, or if {xSolve} is unable to find any, then an 
empty List is returned.

The current implementation is far from perfect. In particular, the
user should keep the following points in mind:
*	{xSolve} cannot solve all equations. If it is given a equation
it can not solve, it raises an error via {Check}. Unfortunately, this
is not displayed by the inline pretty-printer; call {PrettyPrinterSet} to
change this. If an equation cannot be solved analytically, you may
want to call {Newton} to get a numerical solution.
*	Systems of linear equations are handled, but the methods have not
yet been thoroughly checked-out.  Systems with one or more non-linear
equations are not handled yet. The old version of {Solve}, with the name
{OldSolve} might be able to solve some nonlinear systems of equations.
*	The periodicity of the trigonometric functions {Sin}, {Cos},
and {Tan} is not taken into account. The same goes for the (imaginary)
periodicity of {Exp}. This causes {xSolve} to miss solutions.
*	It is assumed that all denominators are nonzero. Hence, a
solution reported by {xSolve} may in fact fail to be a solution because
a denominator vanishes.  The function {xCheckSolution} should be
able to eliminate these false "solutions".
*	In general, it is wise not to have blind trust in the results
returned by {xSolve}. A good strategy is to substitute the solutions
back in the equation.

*E.G. notest

First a simple example, where everything works as it should. The
quadratic equation $x^2 + x == 0$ is solved. Then the result is
checked by substituting it back in the quadratic.

In> quadratic := x^2+x;
Result: x^2+x;
In> xSolve(quadratic, x);
Result: {x==0,x==(-1)};
In> quadratic Where %;
Result: {0,0};

If one tries to solve the equation $Exp(x) == Sin(x)$, one finds that
{xSolve} can not do this.

In> PrettyPrinterSet("DefaultPrint");
Result: True;
In> xSolve(Exp(x) == Sin(x), x);
	Error: Solve'Fails: cannot solve equation Exp(x)-Sin(x) for x
Result: {};

The equation $Cos(x) == 1/2$ has an infinite number of solutions,
namely $x == (2*k + 1/3) * Pi$ and $x == (2*k - 1/3) * Pi$ for any
integer $k$. However, {xSolve} only reports the solutions with 
$k == 0$.

In> xSolve(Cos(x) == 1/2, x);
Result: {x==Pi/3,x== -Pi/3};

For the equation $x/Sin(x) == 0$, a spurious solution at $x == 0$ is
returned. However, the fraction is undefined at that point.

In> xSolve(x / Sin(x) == 0, x);
Result: {x==0};

At first sight, the equation $Sqrt(x) == a$ seems to have the solution
$x == a^2$. However, this is not true for eg. $a == -1$.

In> PrettyPrinterSet("DefaultPrint");
Result: True;
In> xSolve(Sqrt(x) == a, x);
	Error: Solve'Fails: cannot solve equation Sqrt(x)-a for  x
Result: {};
In> xSolve(Sqrt(x) == 2, x);
Result: {x==4};
In> xSolve(Sqrt(x) == -1, x);
Result: {};

*SEE Check, MatrixSolve, Newton, OldSolve, PrettyPrinterSet, PSolve, xCheckSolution, Where, ==
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xCheckSolution.mpw0000644000175000017500000000646511517224250032100 0ustar  giovannigiovanni%mathpiper,title="xCheckSolution"

//Retract("xCheckSolution",*);
//Retract("CloseEnough",*);

10 # CloseEnough(_expr1,_expr2,_prec) <--
  [
      If(iDebug=True,Tell("CloseEnough",{expr1,expr2,prec}));
      Local(diff,ndiff,ncomp,result);
      diff := expr1 - expr2;
      If(diff != 0 And HasFunc(expr1,Sqrt), diff := RadSimp(expr1-expr2));
      If(diff != 0, diff := Simplify(expr1-expr2));      
      If(iDebug=True,Tell("  ce1",diff));
      If(diff=0,
          result:=True,
          [
              ndiff := Abs(N(diff,prec+1));
              ncomp := N(10^(-prec),prec);
              If(iDebug=True,Tell("  ce2",{ndiff,ncomp,ndiff/ncomp}));
              If(ndiff/ncomp<1,result:=True,result:=False);
          ]
      );
      result;
  ];
  

10 # xCheckSolution( exprs_IsList, _var, solutions_IsList ) <--
  [
      If(iDebug=True,Tell("xCheckSolutionL",{exprs,var,solutions}));
      Local(tests);
      
      tests := Subst(==,ToAtom("-")) (exprs Where solutions);
      If(iDebug,Tell("  1",tests));
      tests := AllSatisfy("IsZero",tests);
  ];

  
12 # xCheckSolution( _expr, _var, solution_IsList ) <--
  [
      If(iDebug=True,Tell("xCheckSolution1",{expr,var,solution}));
      Local(expr0,result,s,r);
      If( IsEquation(expr),
          Bind(expr0,EquationLeft(expr)-EquationRight(expr)),
          Bind(expr0,expr)
      );
      result := {};
      ForEach(s,solution) 
        [
            If(iDebug=True,Tell("  cs1",s));
            r := ( expr0 Where s );
            If(iDebug=True,Tell("    cs2",{expr0,r}));
            If(r=0,Push(result,s),If(CloseEnough(r,0,10),Push(result,s)));
        ];
        If(iDebug=True,Tell("  cs4",result)); 
        Reverse(result);
  ];
  
  
20 # xCheckSolution( _expr, _var, _solution ) <-- False;

%/mathpiper



%mathpiper_docs,name="xCheckSolution",categories="User Functions;Solvers (Symbolic)",access="experimental"

*CMD xCheckSolution --- Check the validity of solutions returned by the {xSolve} function.
*STD
*CALL
	xCheckSolution(expr,var,solution)

*PARMS

{expr}     -- a mathematical expression, or List of simultaneous equations
{var}      -- a varible identifier, or List of variables
{solution} -- a List containing solutions to the equation(s).


*DESC

The function {xSolve} will attempt to find solutions to the equation
{expr}, if {expr} is an actual equatio), or to the equivalent equation
represented by {expr==0} if {expr} is NOT an equation.  
If expr is a List of simultaneous linear equations, {xSolve} will
attempt to solve the system.

Solutions returned by {xSolve} will be in the form of a List, such as
{{var==something,var==something_else}}.

For certain types of expressions or equation, {xSolve} might return
invalid solutions as well as valid ones in the output List.  To check
the list of solutions, call the function xCheckSolutions().  This function
will return a list containing only the valid solutions from among those
in the list (if any).  If none of the "solutions" is valid, this 
function will return the empty list.

*E.G.

In> ss1 := xSolve(x^2==4,x)

Result: {x==2,x==(-2)}

In> xCheckSolution(x^2==4,x,ss1)

Result: {x==2,x==(-2)}

In> xCheckSolution(x^2==4,x,{x==2,x==3})   // Deliberately incorrect

Result: {x==2}

%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolveRational.mpw0000644000175000017500000000255411517224250032103 0ustar  giovannigiovanni%mathpiper,title="xSolve'Rational"

//Retract("xSolve'Rational",*);

/************************* xSolve'Rational *************************/
/*
 *    This expression is a rational function of its variable.
 * Try to solve it with the help of that information.
 */

 
10 # xSolve'Rational( _expr, _var )_(IsRationalFunction(expr,var)) <--
[
    If(iDebug=True,Tell(" Rational",expr==0));
    Local(n,d,fn,fd,factor,rootsn,rootsd,root,result);
    n := Numerator(expr);
    d := Denominator(expr);
    If(iDebug=True,Tell("  1",{n,d}));
    fn := Factors(n);
    fd := Factors(d);
    If(iDebug=True,Tell("  2",{fn,fd}));
    rootsn := {};
    rootsd := {};
    result := {};
    ForEach(factor,fn) 
        If(Contains(VarList(factor[1]),var), Push(rootsn,PSolve(factor[1],var)));  
    ForEach(factor,fd) 
        If(Contains(VarList(factor[1]),var), Push(rootsd,PSolve(factor[1],var)));    
    If(iDebug=True,Tell("  3",{rootsn,rootsd}));
    
    ForEach(root,rootsn) 
      [
            If(iDebug=True,Tell("     4",root));
            If(Not Contains(rootsd,root),Push(result,root));
            If(iDebug=True,Tell("     5",result));
      ];
    If(iDebug=True,Tell("  6",result));
    If( Length(result)=0,result:={},MapSingle({{t},var==t}, result)); 
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolveSqrts.mpw0000644000175000017500000000724511517224250031450 0ustar  giovannigiovanni%mathpiper,title="xSolveSqrts"

//Retract("xSolve'Sqrts",*);


/************************* xSolve'Sqrts *************************/

/* 
 *    To get here, the user had to have called with something
 * like  xSolve(Sqrt(_expr1) - _expr2,_var)  where  expr1  is a
 * function of var, and expr2 can be anything.  Depending on the
 * nature of expr2, appropriate sub-functions will be invoked. 
 */
  
 10 # xSolve'Sqrts(_expr1,_expr2,_var)_(Contains(VarList(expr1),var) 
                               And Not Contains(VarList(expr2),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts - no var",{expr1,expr2,var}));
    Local(vars2,result);
    vars2 := VarList(expr2);
    If(iDebug=True,Tell("   1",vars2));
    result := xSolve(expr1-expr2^2,var);
    If(iDebug=True,Tell("   2",result));
    Echo("HERE -- calling CheckSolution with   Sqrt(",expr1,")-",expr2,"   and  ",var,"   and   ",result);
    CheckSolution(Sqrt(expr1)-expr2,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,const_IsConstant*_var,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts - c*var",{expr1,const,var}));
    Local(rhs,result);
    rhs := const*var;
    If(iDebug=True,Tell("   3",rhs));
    result := xSolve(expr1-rhs^2,var);
    If(iDebug=True,Tell("   4",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,-const_IsConstant*_var,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts + c*var",{expr1,const,var}));
    Local(rhs,result);
    rhs := -const*var;
    If(iDebug=True,Tell("   5",rhs));
    result := xSolve(expr1-rhs^2,var);
    If(iDebug=True,Tell("   6",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,_var,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts - var",{expr1,const,var}));
    Local(rhs,result);
    rhs := var;
    If(iDebug=True,Tell("   7",rhs));
    result := xSolve(expr1-rhs^2,var);
    If(iDebug=True,Tell("   8",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,-_var,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts + var",{expr1,const,var}));
    Local(rhs,result);
    rhs := -var;
    If(iDebug=True,Tell("   9",rhs));
    result := xSolve(expr1-rhs^2,var);
    If(iDebug=True,Tell("   10",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,_expr1,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts -expr1",{expr1,var}));
    Local(rhs,result);
    rhs := expr1;
    If(iDebug=True,Tell("   11",rhs));
    result := xSolve(Simplify(expr1-rhs^2),var);
    If(iDebug=True,Tell("   12",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];
 
 10 # xSolve'Sqrts(_expr1,-_expr1,_var)_(Contains(VarList(expr1),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts +expr1",{expr1,var}));
    Local(rhs,result);
    rhs := expr1;
    If(iDebug=True,Tell("   13",rhs));
    result := xSolve(Simplify(expr1-rhs^2),var);
    If(iDebug=True,Tell("   14",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];

10 # xSolve'Sqrts(_expr1,_expr2,_var)_(Contains(VarList(expr2),var)) <--
 [
    If(iDebug=True,Tell("xSolve'Sqrts xx",{expr1,expr2,var}));
    Local(rhs,result);
    rhs := expr2;
    If(iDebug=True,Tell("   15",rhs));
    result := xSolve(Simplify(expr1-rhs^2),var);
    If(iDebug=True,Tell("   16",result));
    CheckSolution(Sqrt(expr1)-rhs,var,result);
 ];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

    %output,preserve="false"
      Processing...
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/xSolve/xSolveReduce.mpw0000644000175000017500000001053011517224250031532 0ustar  giovannigiovanni%mathpiper,title="xSolveReduce"

//Retract("xSolve'Reduce",*);
//Retract("xSolve'Context",*);

/***************************** xSolve'Reduce *****************************/

/*
 *      Tries to solve by reduction strategy, calling xSolve'Context(); 
 * Returns Failed if this doesn't work, and the solution otherwise 
*/

10 # xSolve'Reduce(_expr, _var) <--
  [
      If(iDebug,Tell("xSolveReduce",{expr,var}));
      ClearError("Solve'Fails");  // in case left-over from previous failure!
      Local(context, expr2, var2, res, sol, sol2, i);
      context := xSolve'Context(expr, var);
      If(iDebug,Tell(" xSolveReduce",context));
      If(context = False,
         [
             If(iDebug,Tell(" 31bReduce",expr));
             res := Failed;
         ],
         [
             expr2 := Eval(Subst(context, var2) expr);
             If(iDebug,Tell(" 31cReduce",expr2));
             If(CanBeUni(var2, expr2) And (Degree(expr2, var2) = 0 Or (Degree(expr2, var2) = 1 And Coef(expr2, var2, 1) = 1)),
                 [
                     If(iDebug=True,
                       [
                         Tell(" 31dReduce",expr2);
                         Tell(" 31eReduce -- Quitting to avoid infinite recursion",Degree(expr2,var2));
                       ]
                     );
                     res := Failed; // to prevent infinite recursion 
                 ],
                 [
                     //Tell(" 31XReduce",GetErrorTableau());
    	             sol2 := Solve(expr2, var2);
                     If(iDebug,Tell(" 31fReduce",sol2));
                     If(IsError("Solve'Fails"),
	                     [
                             If(iDebug,Tell(" 31gReduce_error"));
	                         ClearError("Solve'Fails");
		                     res := Failed;
                         ],
    	                 [
                             If(iDebug,Tell(" 31hReduce",sol2));
    		                 res := {};
    		                 i := 1;
    		                 While(i <= Length(sol2) And res != Failed) 
                             [
    		                     sol := Solve(context == (var2 Where sol2[i]), var);
                                 If(iDebug,Tell(" 31iReduce",{i,sol}));
	                             If(IsError("Solve'Fails"),
		                             [
		                                  ClearError("Solve'Fails");
		                                  res := Failed;
                                     ],
    		                         res := Union(res, sol)
                                 );
    		                     i++;
    		                 ];
                             If(iDebug,Tell(" 31jReduce",{sol1,sol2,res}));
    	                 ]
                     );
      	         ]
            ); 
        ]
      );
      res;
  ];



/******************** xSolve'Context ********************/

/*
 *      Returns the unique context of 'var' in 'expr', 
 * or {} if 'var' does not occur in 'expr',       
 * or False if the context is not unique.         
 */

10 # xSolve'Context(expr_IsAtom, _var) <-- 
  [
      If(iDebug,Tell("xSolveContext",{expr,var}));
      If(expr=var, var, {});
  ];

20 # xSolve'Context(_expr, _var) <--
  [
      If(iDebug,Tell("xSolveContext",{expr,var}));
      Local(lst, foundVarP, context, i, res);
      lst := FunctionToList(expr);
      If(iDebug,Tell(" 42aContext",lst));
      foundVarP := False;
      i := 2;
      While(i <= Length(lst) And Not foundVarP) [
          foundVarP := (lst[i] = var);
          i++;
      ];
      If(iDebug,Tell(" 42bContext",{foundVarP,expr}));
      If(foundVarP,
          [
              context := expr;
              If(iDebug,Tell("  42cContext_found",{foundVarP,context}));
          ],
          [
              context := {};
              i := 2;
              While(i <= Length(lst) And context != False) [
                  res := xSolve'Context(lst[i], var);
	              If(res != {} And context != {} And res != context, [context := False;If(iDebug,Tell("  42caContext",res));]);
	              If(res != {} And context = {}, [context := res;If(iDebug,Tell("  42cbContext",context));]);
	              i++;
              ];
              If(iDebug,Tell("  42dContext_solved",{i,context}));
          ]
      );
      context;
  ];  
  
%/mathpiper


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/0000755000175000017500000000000011722677330027772 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/NumberLinePrintZoom.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/NumberLinePrintZoom.0000644000175000017500000001345611517224250033715 0ustar  giovannigiovanni%mathpiper,def="NumberLinePrintZoom"

//Retract("NumberLineZoom", *);

//Retract("ZoomInOnce", *);

LocalSymbols(ZoomInOnce)
[

    10 # NumberLinePrintZoom(_lowValue, _highValue, divisions_IsPositiveInteger, depth_IsPositiveInteger)_(lowValue < highValue) <-- 
    [
    
        Local(numbers, stepAmount, zoomIndexes, nextZoomIndex, outputWidth, numbersString, output, randomStep, randomZoomNumber, iteration);
        
        iteration := 1;
        
        While(iteration <= depth)
        [
            {numbers, stepAmount} := ZoomInOnce(lowValue, highValue, divisions);
            
            zoomIndexes := {};
            
            outputWidth := 0;
            
            numbersString := "";
            
            ForEach(number, numbers)
            [
                output := PipeToString() Write(number);
                
                zoomIndexes := Append(zoomIndexes, Length(output));
                
                numbersString := numbersString : output : PipeToString() Space(3);
                
                outputWidth := outputWidth + Length(output) + 3;
            
            ];
            
            randomStep := RandomInteger(divisions);
            
            randomZoomNumber := Sum(Take(zoomIndexes, randomStep));
            
            If(randomStep = 1, nextZoomIndex := randomZoomNumber + 1, nextZoomIndex := 3*(randomStep-1) + randomZoomNumber + 1);
         
            If(iteration > 1, Echo(ListToString(FillList("-", outputWidth-3)))); 
            
            Echo(numbersString);
            
            If(iteration != depth,[Space(nextZoomIndex);Echo("|");]);
            
            lowValue := numbers[randomStep];
            
            highValue := numbers[randomStep+1];
            
            iteration++;
            
        ];
    
    ];
    
    
    
    
    ZoomInOnce(_lowValue, _highValue, divisions_IsPositiveInteger)_(lowValue < highValue) <--
    [
        Local(stepAmount, x, numbers);
        
        stepAmount := If(IsDecimal(lowValue) Or IsDecimal(highValue), N((highValue-lowValue)/divisions), (highValue-lowValue)/divisions);
        
        x := lowValue;
        
        numbers := {};
        
        While(x <= highValue)
        [
        
            numbers := Append(numbers, x);
            
            x := x + stepAmount;
        
        ];
        
        {numbers, stepAmount};
    
    ];


];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper,scope="nobuild",subtype="manual_test"

N(NumberLineZoom(0,1,8,5), 50);

%/mathpiper





%mathpiper_docs,name="NumberLinePrintZoom",categories="User Functions;Visualization",access="experimental"
*CMD NumberLinePrintZoom --- zooms into the number line
*STD
*CALL
	NumberLinePrintZoom(low_number, high_number, divisions, depth)

*PARMS

{low_value} -- lowest number in the zoom range

{high_value} -- highest number in the zoom range

{divisions} -- how many parts to divide the range into

{depth} -- continue the zooming process to depth levels

*DESC

This function allows sections of the number line to be displayed.  If rational numbers are
passed to low_number and high_number, rational numbers are displayed and if decimal
numbers are passed to low_number and high_number, decimal numbers are displayed.

*E.G. notest

In> NumberLinePrintZoom(0/1,1/1,8,1)
Result: True
Side Effects:
0   1/8   1/4   3/8   1/2   5/8   3/4   7/8   1

In> NumberLinePrintZoom(0/1,1/1,10,1)
Result: True
Side Effects:
0   1/10   1/5   3/10   2/5   1/2   3/5   7/10   4/5   9/10   1

In> NumberLinePrintZoom(0/1,1/1,20,1)
Result: True
Side Effects:
0   1/20   1/10   3/20   1/5   1/4   3/10   7/20   2/5   9/20   1/2   11/20   3/5   13/20   7/10   3/4   4/5   17/20   9/10   19/20   1

In> NumberLinePrintZoom(0/1,1/1,8,4)
Result: True
Side Effects:
0   1/8   1/4   3/8   1/2   5/8   3/4   7/8   1   
                          |
----------------------------------------------------------------
1/2   33/64   17/32   35/64   9/16   37/64   19/32   39/64   5/8   
    |
--------------------------------------------------------------------------------
1/2   257/512   129/256   259/512   65/128   261/512   131/256   263/512   33/64   
                                                                         |
--------------------------------------------------------------------------------------------------
263/512   2105/4096   1053/2048   2107/4096   527/1024   2109/4096   1055/2048   2111/4096   33/64  



In> NumberLinePrintZoom(0.0,1.0,8,1)
Result: True
Side Effects:
0.0   0.125   0.250   0.375   0.500   0.625   0.750   0.875   1.000

In> NumberLinePrintZoom(0.0,1.0,10,1)
Result: True
Side Effects:
0.0   0.1   0.2   0.3   0.4   0.5   0.6   0.7   0.8   0.9   1.0

In> NumberLinePrintZoom(0.0,1.0,20,1)
Result: True
Side Effects:
0.0   0.05   0.10   0.15   0.20   0.25   0.30   0.35   0.40   0.45   0.50   0.55   0.60   0.65   0.70   0.75   0.80   0.85   0.90   0.95   1.00

In> N(NumberLinePrintZoom(0.0,1.0,8,4),6)
Result: True
Side Effects:
0.0   0.125   0.250   0.375   0.500   0.625   0.750   0.875   1.000   
                                    |
---------------------------------------------------------------------------------------------
0.500   0.515625   0.531250   0.546875   0.562500   0.578125   0.593750   0.609375   0.625000   
                                       |
------------------------------------------------------------------------------------------------
0.546875   0.548828   0.550781   0.552734   0.554687   0.556640   0.558593   0.560546   0.562499   
                                                                           |
------------------------------------------------------------------------------------------------
0.558593   0.558837   0.559081   0.559325   0.559569   0.559813   0.560057   0.560301   0.560545

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/RForm.mpw0000644000175000017500000002442011523200452031530 0ustar  giovannigiovanni%mathpiper,def="RForm"

/* RForm: convert MathPiper objects to R code. */

//Retract("RForm",*);
//Retract("RIndent",*);
//Retract("RUndent",*);
//Retract("RNlIndented",*); 

Rulebase("RForm",{expression});
Rulebase("RForm",{expression, precedence});

Function ("RFormBracketIf", {predicate, string})
[
	Check(IsBoolean(predicate) And IsString(string), "Argument", "RForm internal error: non-boolean and/or non-string argument of RFormBracketIf");
	If(predicate, ConcatStrings("( ", string, ") "), string);
];

/* Proceed just like TeXForm()
*/

// RFormMaxPrec should perhaps only be used from within this file, it is thus not in the .def file.
RFormMaxPrec() := 60000;	 /* This precedence will never be bracketed. It is equal to KMaxPrec */

100 # RForm(_x) <-- RForm(x, RFormMaxPrec());

/* Replace numbers and variables -- never bracketed except explicitly */
110 # RForm(x_IsInteger, _p) <-- ToString(x);
111 # RForm(x_IsZero, _p) <-- "0.";
112 # RForm(x_IsNumber, _p) <-- ToString(x);
/* Variables are left as is, except some special ones */
190 # RForm(False, _p) <-- "false";
190 # RForm(True, _p) <-- "true";
190 # RForm(Pi, _p) <-- "pi";
200 # RForm(x_IsAtom, _p) <-- ToString(x);

/* Strings must be quoted but not bracketed */
100 # RForm(x_IsString, _p) <-- ConcatStrings("\"", x, "\"");

/* Replace operations */

/* arithmetic */

/* addition, subtraction, multiplication, all comparison and logical operations are "regular" */


LocalSymbols(rFormRegularOps) [
  rFormRegularOps := 
  { 
    {"+","+"},
    {"-","-"},
    {"*","*"},
    {"/","/"},
    {"/","/"},
    {"^","^"},
    {"=","=="},
    {">=",">="},
    {">",">"},
    {"<=","<="},
    {"<","<"},
    {"!=","!="},
    {"..",":"},
    {"Not","!"},
    {":=","<-"},
    {"sequence",":"},
    {"True","TRUE"},
    {"Modulo","%%"},
    {"Quotient","%/%"},
  };

  RFormRegularOps() := rFormRegularOps;
]; // LocalSymbols(rFormRegularOps)




LocalSymbols(rFormMathFunctions) [
  rFormMathFunctions :=
  {
    {"NthRoot","root"},
    {"Infinite","Inf"},
    {"Undefined","NaN"},
    {"Sin","sin"},
    {"Cos","cos"},
    {"Tan","tan"},
    {"ArcSin","asin"},
    {"ArcCos","acos"},
    {"ArcTan","atan"},
    {"ArcSinh","asinh"},
    {"ArcCosh","acosh"},
    {"ArcTanh","atanh"},
    {"ArcCsc","acsc"},
    {"ArcCsch","acsch"},
    {"ArcSec","asec"},
    {"ArcSech","asech"},
    {"ArcCot","acot"},
    {"ArcCoth","acoth"},
    {"Exp","exp"},
    {"Ln","log"},
    {"Sqrt","sqrt"},
    {"Bin","choose"},
    {"Gamma","gamma"},
    {"!","factorial"},
    {"Limit","limit"},
    {"Deriv","deriv"},
    {"Integrate","integrate"},
    {"Taylor","?"},
    {"List","list"},
  };

  RFormMathFunctions() := rFormMathFunctions;

]; // LocalSymbols(RFormMathFunctions)




/* This is the template for "regular" binary infix operators:
100 # RForm(_x + _y, _p) <-- RFormBracketIf(p RForm(Sin(a1)+2*Cos(b1));
Result: "sin(a1) + 2 * cos(b1)";

*SEE PrettyForm, TeXForm, CForm
%/mathpiper_docs








http://code.google.com/p/ryacas/source/browse/trunk/R/OpenMath2R.R
OpenMath2R <- function(x) {
 out <- c()
 recurse <- function( x ) {
	if ("name" %in% names(xmlAttrs(x))) {
		out <<- c(out, trans(xmlAttrs(x)[["name"]], from="OM", to="R"), " ")
	}
	if (xmlName(x) == "text") out <<- c(out, xmlValue(x), " ")
	if (xmlName(x) == "OMF") out <<- c(out, xmlAttrs(x)[["dec"]], " ")
	if (xmlName(x) == "OMS") {
	if (xmlAttrs(x)[["cd"]] == "logic1" && "name" %in% names(xmlAttrs(x))
		&& xmlAttrs(x)[["name"]] %in% c("true", "false")) {}
	   else if ((xmlAttrs(x)[["cd"]] != "nums1") ||
				(xmlAttrs(x)[["name"]] == "rational")) 
			out <<- c(out, xmlValue(x), "(")
	}
	# if (xmlName(x) == "OMS") out <<- c(out, "(")
	if (xmlName(x) == "OMSTR") {
	# out <<- c(out, sQuote(gsub("'", "\\\\'", xmlValue(x))))
	out <<- c(out, paste("'", gsub("'", "\\\\'", xmlValue(x)), "'", sep=""))
	} else if ( length( xmlChildren(x) ) > 0 )
		for( i in seq( along = xmlChildren(x) ) ) {
			Recall( x[[i]] )
			if (i > 1 && i < length(xmlChildren(x))) 
				out <<- c(out, ",")
		}
	if (xmlName(x) == "OMA" || xmlName(x) == "OMBIND") out <<- c(out, xmlValue(x), ")")
 }
 x <- paste(x, "\n", collapse = "")
 x <- xmlTreeParse(x, asText = TRUE)
 x <- xmlRoot(x)
 recurse(x)
 paste(out, collapse = "")
}

trans <- function(x, ttab=transtab, from, to) {
   idx <- match(x, ttab[,from], nomatch = 0)
   res <- if (idx > 0) ttab[idx,to] else x
   if (tolower(substr(res, 1, 1)) %in% letters) res
   else paste('"', res, '"', sep="")
}

transtab <- matrix( c(
	#R			OM			yacas
	"pi",		"pi",		"Pi",
	
	"+",		"plus",		"+",
	"-",		"minus",	"-",
	"*",		"times",	"*",
	"/",		"divide",	"/",
	"/",		"rational",	"/",
	"^",		"power",	"^",
	"%%",		"mod",		"Modulo",
	"%/%",		"div",		"Quotient",
	"root",		"root",		"NthRoot",
	"Inf",		"infinity",	"Infinite",
	"NaN",		"undefined","Undefined",
	
	"sin",		"Sin",		"Sin",
	"cos",		"Cos",		"Cos",
	"tan",		"Tan",		"Tan",
	
	"asin",		"arcsin",	"ArcSin",
	"acos",		"arccos",	"ArcCos",
	"atan", 	"arctan", 	"ArcTan",
	"asinh", 	"arcsinh", 	"ArcSinh", 
	"acosh", 	"arccosh", 	"ArcCosh", 
	"atanh", 	"arctanh", 	"ArcTanh",
	
	"acsc",		"arccsc",	"ArcCsc",
	"acsch",	"arccsch",	"ArcCsch",
	
	"asec",		"arcsec",	"ArcSec",
	"asech",	"arcsech",	"ArcSech",
	
	"acot",		"arccot",	"ArcCot",
	"acoth",	"arccoth",	"ArcCoth",
	
	"exp", 		"exp", 		"Exp",
	"log", 		"ln", 		"Ln",
	"sqrt", 	"sqrt", 	"Sqrt",
	"choose", 	"bin", 		"Bin",
	"gamma", 	"gamma", 	"Gamma",
	
	"!",		"not",		"Not",
	"==",		"eq",		"=",
	"==",		"equivalent","=",
	">=",		"geq",		">=",
	">", 		"gt",		">",
	"<=", 		"leq",		"<=",
	"<", 		"lt",		"<",
	"!=", 		"neq",		"!=",
	":", 		"seq",		"sequence",
	":", 		"seq",		"..",
	
	"factorial","factorial","factorial",
	"factorial","factorial","!",
	"limit", 	"lim", 		"Limit",
	"deriv", 	"deriv", 	"Deriv",
	"integrate","integrate","Integrate",
	"?",		"taylor",	"Taylor",

	"list",		"List", 	"List",
	"TRUE",		"true", 	"True",
	"<-",		"?",		":=",
	"Expr",		"?",		"",
	"Exprq", 	"?",		"",
	"expression", 	"?", 		""
	
), byrow = TRUE, ncol = 3)
colnames(transtab) <- c("R", "OM", "yacas")

# Used for expressions not handled by R

root <- function(x, y) {
	(x)^(1/(y))
}








mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/JavaAccess.mpw0000644000175000017500000000127711517224250032520 0ustar  giovannigiovanni%mathpiper,title=""

//Retract("JavaAccess",*);

RulebaseListed("JavaAccess",{object, method, parameters});

//Handle no option call.
5 # JavaAccess(_object, _method) <-- JavaAccess(object, method, {});


//Main routine.  It will automatically accept 2 or more option calls because the
//options come in a list.
10 # JavaAccess(_object, _method, parameters_IsList) <--
[   
    JavaCall(object, method, parameters);
    
    
];


//Handle a single option call because the option does not come in a list for some reason.
20 # JavaAccess(_object, _method, _singleParameter) <-- JavaAccess(object, method, {singleParameter});

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/StringToNumber.mpw0000644000175000017500000000171311517224250033432 0ustar  giovannigiovanni%mathpiper,def="StringToNumber"
//Retract("StringToNumber",*);

StringToNumber( str_IsString ) <-- FromBase(10,str);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="StringToNumber",categories="User Functions;String Manipulation",access="experimental"
*CMD StringToNumber --- Convert a base-10 number in string form to its numeric value
*STD
*CALL
	StringToNumber(numberString)

*PARMS

{numberString} -- a decimal (base-10) number represented as a string

*DESC

{StringToNumber} Converts the string representation of a number into the value of that number



*E.G.

In> IsNumber("1234")
Result: False
    
In> StringToNumber("1234")
Result: 1234
    
In> IsNumber(%)
Result: True
    
In> StringToNumber("0.12345678")
Result: 0.12345678
    
In> StringToNumber("0.12345678E4")
Result: 1234.5678

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/PadLeft.mpw0000644000175000017500000000245711517224250032035 0ustar  giovannigiovanni%mathpiper,def="PadLeft"

//Retract("PadLeft", *);

10 # PadLeft(number_IsNumber, totalDigits_IsInteger) <--
[
    Local(integerString, padAmount, resultString);
    
    integerString := ToString(number);
    
    padAmount := totalDigits - Length(integerString);
    
    If(padAmount > 0,
        resultString := ListToString(FillList(0, padAmount)) : integerString,
        resultString := integerString );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="PadLeft",categories="User Functions;Input/Output",access="experimental"
*CMD PadLeft --- converts a number into a string which has a specified width
*STD
*CALL
	PadLeft(number,string_width)

*PARMS

{number} -- an integer or a decimal number to convert to a string

{string_width} -- the width of the string

*DESC

This function converts a number into a string which has a specified width.  If the number
would normally be converted into a string with fewer characters than this width, zeros are
added to the left side of the string to make it the specified width.

*E.G.
/%mathpiper,title=""

Echo(PadLeft(.1,3));
Echo(PadLeft(20,3));
Echo(PadLeft(5,3));

/%/mathpiper

    /%output,preserve="false"
      Result: True
      
      Side Effects:
      0.1
      020
      005
.   /%/output
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/IsListOfLists.mpw0000644000175000017500000000155111371733712033231 0ustar  giovannigiovanni%mathpiper,def="IsListOfLists"

IsListOfLists(listOfLists) :=
[
    Local(result);
    
    result := True;
    
    if(Not IsList(listOfLists))
    [
        result := False;
    ]
    else 
    [
        ForEach(list, listOfLists)
        [
            If(Not IsList(list), result := False);
        ];
    ];
    
    result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="IsListOfLists",categories="User Functions;Predicates",access="experimental"
*CMD IsListOfLists --- determine if {list} is a list of lists
*STD
*CALL
	IsList(list)

*PARMS
{expr} -- a list

*DESC
This function returns {True} if {list} is a list of lists and {False} otherwise.

*E.G.
In> IsListOfLists(aa);
Result: False

In> IsListOfLists({1,2,3})
Result: False

In> IsListOfLists({{1,2},{3,4},{5,6}})
Result: True
    
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/VerifyNumeric.mpw0000644000175000017500000000702311502266107033300 0ustar  giovannigiovanni%mathpiper,def="VerifyNumeric"

VerifyNumeric(expression1, expression2, optionsList) :=
[
    Local(variablesList1, variablesList2, numericValue1, numericValue2, numericDifference, optionsVariableNamesList, optionsValuesList, associativeList);
 
    variablesList1 := VarList(expression1);
    
    variablesList2 := VarList(expression2);
    
    if(Length(variablesList1) = 0 And Length(variablesList2) = 0)
    [
        numericValue1 := N(expression1);
        
        numericValue2 := N(expression2);
    ]
    else
    [
        optionsList := HeapSort(optionsList, Lambda({x,y},IsLessThan(x[1],y[1])));
        
        associativeList := OptionsToAssociativeList(optionsList);
        
        optionsVariableNamesList := MapSingle("ToAtom", AssocIndices(associativeList));
        
        optionsValuesList := MapSingle("ToAtom", AssocValues(associativeList));
        
        variablesList1 := HeapSort(variablesList1,"IsLessThan");
        
        variablesList2 := HeapSort(variablesList2,"IsLessThan");
        
        Check(variablesList1 = variablesList2 And variablesList1 = optionsVariableNamesList, "Argument", "Both expressions and the options list must have the same variable names and the same number of variables.");
        
        numericValue1 := N(WithValue(variablesList1, optionsValuesList, expression1));
        
        numericValue2 := N(WithValue(variablesList2, optionsValuesList, expression2 ));
        
        Echo(Map("->",{variablesList1, optionsValuesList}));
        
        NewLine();
    ];
    
    Echo(expression1, "-> ", numericValue1);
    
    NewLine();
    
    Echo(expression2, "-> ", numericValue2);
    
    numericDifference := N(numericValue1 - numericValue2);
        
    NewLine();
    
    Echo("Difference between the numeric values: ", numericDifference);
    
    numericDifference;
];




VerifyNumeric(expression1, expression2) :=
[
    VerifyNumeric(expression1, expression2, {});
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="VerifyNumeric",categories="Programmer Functions;Testing",access="experimental"
*CMD VerifyNumeric --- numerically evaluates two expressions to indicate if they may be equivalent or not
*STD
*CALL
	Verify(symbolicExpression1,symbolicExpression2,variableAssignmentList)
    
    Verify(numericExpression1,numericExpression2)

*PARMS
{symbolicExpression1} -- a symbolic expression

{symbolicExpression2} -- a symbolic expression

{variableAssignmentList} -- a list which contains variable assignments in the form {b->7,a->4}

{numericExpression1} -- a numeric expression

{numericExpression2} -- a numeric expression

*DESC
The symbolic expression version of this function numerically evaluates two symbolic expressions to indicate if
they may be equivalent or not.  The values to set the variables to are contained in {variableAssignmentList}.

The numeric expression version of this function evaluates two numeric expressions to indicate if they are
equivalent or not.

*E.G.
In> VerifyNumeric((72*a^3*b^5)^(1/2), 6*a*b^2*(2*a*b)^(1/2), {b->7,a->4})
Result: 0.000000
Side Effects:
a->4 b->7 

Sqrt(72*a^3*b^5) -> 8800.378174 

6*a*b^2*Sqrt(2*a*b) -> 8800.378174 

Difference between the numeric values: 0.000000 



In> VerifyNumeric(.5,1/2)
Result: 0.0
Side Effects:
.5 -> 0.5 

1/2 -> 0.5 

Difference between the numeric values: 0.0 


%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/ElementCount.mpw0000644000175000017500000000146611517224250033117 0ustar  giovannigiovanni
%mathpiper,def="ElementCount"

//Retract("ElementCount",*);

ElementCount(list) :=
[   
    if(Length(list) = 0)
    [
        0;
    ]
    else if(IsAtom(list))
    [
        1;
    ]
    else
    [
        ElementCount(First(list)) + ElementCount(Rest(list));
    ];

];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ElementCount",categories="User Functions;Lists (Operations)",access="experimental"
*CMD ElementCount --- counts the number of elements in a list or nested list
*CALL
	ElementCount(list)

*PARMS
{list} -- a list or nested list

*DESC
Counts the number of elements in a list or nested list.

*E.G.
In> ElementCount({1,2,3,4})
Result: 4

In> ElementCount({1,2,{3,4},5,6})
Result: 6
%/mathpiper_docs
././@LongLink0000000000000000000000000000015500000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/OptionsToAssociativeList.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/OptionsToAssociative0000644000175000017500000000233511371733712034046 0ustar  giovannigiovanni%mathpiper,def="OptionsToAssociativeList"
OptionsToAssociativeList(optionList) :=
[
    Local(associativeList, key, value);
    
    associativeList := {};
    
    ForEach(option, optionList)
    [
        If(option[0] = ->,
        [
            If(IsString(option[1]), key := option[1], key := ToString(option[1]));
            If(IsString(option[2]), value := option[2], value := ToString(option[2]));
            
            associativeList := {key, value} : associativeList;
        
        ]);
    
    ];
    associativeList;
];

%/mathpiper



%mathpiper_docs,name="OptionsToAssociativeList",categories="User Functions;Lists (Operations)",access="experimental"
*CMD OptionsToAssociativeList --- converts an options list into an associative list
*CALL
	OptionsToAssociativeList(optionsList)

*PARMS
{optionsList} -- an options list to be converted into an associative list

*DESC
This function converts a list of options in the form of {name -> value, name -> value}
into an associative list.

*E.G.
In> OptionsToAssociativeList({a ->1, b -> 2})
Result> {{"b","2"},{"a","1"}}

%/mathpiper_docs




%mathpiper,title="",scope="nobuild",subtype="manual_test"

OptionsToAssociativeList({ lines -> True, labels -> False });

%/mathpiper



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/StringToList.mpw0000644000175000017500000000143411517224250033115 0ustar  giovannigiovanni%mathpiper,def="StringToList"

//Retract("StringToList", *);

10 # StringToList(string_IsString)_(Length(string) = 0) <-- {};


20 # StringToList(string_IsString) <--
[
    Local(resultList);
    
    resultList := {};
    
    ForEach(character, string)
    [
        resultList := Append(resultList, character);
    ];
    
    resultList;

];



%/mathpiper





%mathpiper_docs,name="StringToList",categories="User Functions;String Manipulation",access="experimental"
*CMD StringToList --- converts a string into a list
*STD
*CALL
	StringToList(string)

*PARMS

{string} -- a string to be converted into a list

*DESC

This function takes each character in a string and places it into a list.

*E.G.
In> StringToList("Hello")
Result: {"H","e","l","l","o"}

*SEE ListToString
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/CombinationsList.mpw0000644000175000017500000000516711502266107034001 0ustar  giovannigiovanni%mathpiper,def="CombinationsList"

/*
    The algorithm this function uses is on pp. 299-300 of
    "Discrete Mathematics and Its Applications" (fourth edition)
    by Kenneth H. Rosen.
*/
CombinationsList(inputList, r) :=
[
    Local(n,manipulatedIndexes,totalCombinations,combinationsList,combinationsLeft,combination,i,j,currentIndexes);
    
    Check(IsList(inputList) And Length(inputList) >= 1, "Argument", "The first argument must be a list with 1 or more elements.");
    
    n := Length(inputList);
    
    Check(r <= n , "Argument", "The second argument must be <= the length of the list.");
    
    manipulatedIndexes := 1 .. r; 
    
    totalCombinations := Combinations(n,r);
    
    combinationsLeft := totalCombinations;
    
    combinationsList := {};
    
    While(combinationsLeft > 0)
    [
        combination := {};
      
        if(combinationsLeft = totalCombinations) 
        [ 
          combinationsLeft := combinationsLeft - 1;
          
          currentIndexes := manipulatedIndexes;
        ]
        else
        [
            i := r;
        
            While(manipulatedIndexes[i] = n - r + i) 
            [
              i--;
            ];
            
            manipulatedIndexes[i] := manipulatedIndexes[i] + 1;
            
            For(j := i + 1, j <= r, j++) 
            [
              manipulatedIndexes[j] := manipulatedIndexes[i] + j - i;
            ];
        
            combinationsLeft := combinationsLeft - 1;
            
            currentIndexes := manipulatedIndexes;
        ];

        For(i := 1, i <= Length(currentIndexes), i++) 
        [
            combination := Append(combination,(inputList[currentIndexes[i]]));
        ];
      
        combinationsList := Append(combinationsList,combination);
    ];
    
    combinationsList;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="CombinationsList",categories="User Functions;Combinatorics",access="experimental"
*CMD CombinationsList --- return all of the combinations from a given list taken r at a time
*CALL
	CombinationsList(list,r)

*PARMS
{list} -- a list of elements

{r} -- the combinations from {list} are to be taken {r} at a time

*DESC
This function returns a list which contains all of the combinations of the elements in a 
given list taken r elements at a time.

*E.G.
In> CombinationsList({1,2,3},2)
Result: {{1,2},{1,3},{2,3}}

*SEE Combinations, PermutationsList, Permutations, LeviCivita
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/miscellaneous/ListToString.mpw0000644000175000017500000000164011517224250033114 0ustar  giovannigiovanni%mathpiper,def="ListToString"


//Retract("ListToString", *);


10 # ListToString(list_IsList)_(Length(list) = 0) <-- "";



20 # ListToString(list_IsList) <--
[
    Local(resultString, character);
    
    resultString := "";
    
    ForEach(element, list)
    [
        If(IsString(element), character := element, character := ToString(element));
        
        resultString := resultString : character;
    ];
    
    resultString;

];

%/mathpiper





%mathpiper_docs,name="ListToString",categories="User Functions;Lists (Operations)",access="experimental"
*CMD ListToString --- converts a list into a string
*STD
*CALL
	ListToString(list)

*PARMS

{list} -- a list to be converted into a string

*DESC
This function converts each of the elementes in a list into a string and then concatenates these
strings into a single string.

*E.G.
In> ListToString({a,b,c,d})
Result: "abcd"

*SEE StringToList
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/0000755000175000017500000000000011722677331026763 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/Segment.mpw0000644000175000017500000000145611523200452031101 0ustar  giovannigiovanni%mathpiper,def="Segment"

Segment(PointA_IsPoint,PointB_IsPoint) <--
[
    Local(x1,x2,y1,y2);
    
    x1 := PointA[1];
    x2 := PointB[1];
    y1 := PointA[2];
    y2 := PointB[2];

    {{x1,y1},{x2,y2}};
];

%/mathpiper



%mathpiper_docs,name="Segment",categories="User Functions;Analytic Geometry",access="experimental"
*CMD Segment --- returns a list which contains the endpoints of a segment
*STD
*CALL
	Segment(p1, p2)
*PARMS

{p1} -- the first endpoint

{p2} -- the second endpoint

*DESC

This function returns a list which represents a segment by its endpoints.

*E.G.

In> PointA := Point(2,3)
Result: {2,3}
	
In> PointB := Point(6,8)
Result: {6,8}
	
In> Segment(PointA,PointB)
Result: {{2,3},{6,8}}

*SEE IsPoint, Point, Distance, Slope
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/Slope.mpw0000644000175000017500000000250311523200452030553 0ustar  giovannigiovanni%mathpiper,def="Slope"

10 # Slope(PointA_IsPoint,PointB_IsPoint) <--
[
    Local(x1,x2,y1,y2,slope);

    x1 := PointA[1];
    x2 := PointB[1];
    y1 := PointA[2];
    y2 := PointB[2];
    
    slope := (y2 - y1)/(x2 - x1);
];



10 # Slope(segment_IsList)_(Length(segment) = 2 And Length(segment[1]) = 2 And Length(segment[2]) = 2) <--
[
    Local(x1,x2,y1,y2,slope);
    
    x1 := segment[1][1]; //PointA[1];
    x2 := segment[2][1]; //PointB[1];
    
    
    y1 := segment[1][2]; //PointA[2];
    y2 := segment[2][2]; //PointB[2];

    slope := (y2 - y1)/(x2 - x1);
];

%/mathpiper



%mathpiper_docs,name="Slope",categories="User Functions;Analytic Geometry",access="experimental",access="experimental"
*CMD Slope --- returns the slope of a line which is represented by two points
*STD
*CALL
	Slope(p1, p2)
	Slope(Segment(p1, p2))
*PARMS

{p1} -- the first point

{p2} -- the second point

*DESC

This function calculates the slope between two points or of a 
segment using the slope formula.

*E.G.

In> PointA := Point(2,3)
Result: {2,3}
	
In> PointB := Point(6,8)
Result: {6,8}
	
In> Slope(PointA,PointB)
Result: 5/4

In> s := Segment(PointA,PointB)
Result: {{2,3},{6,8}}
	
In> Slope(s)
Result: 5/4

*SEE IsPoint, Point, Distance, Midpoint, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/Point.mpw0000644000175000017500000000110611523200452030560 0ustar  giovannigiovanni%mathpiper,def="Point"

Point(x,y) := List(x,y);

Point(x,y,z) := List(x,y,z);

%/mathpiper



%mathpiper_docs,name="Point",categories="User Functions;Analytic Geometry",access="experimental"
*CMD Point --- return a list which contains a point
*STD
*CALL
	Point(x, y)
	Point(x, y, z)
*PARMS

{x} -- x coordinate of the point

{y} -- y coordinatte of the point

{z} -- z coordinate of the point

*DESC

Creates either a 2D point or a 3D point.

*E.G.

In> Point(5,2)
Result: {5,2}

*SEE IsPoint, Midpoint, Distance, Slope, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/IsSegment.mpw0000644000175000017500000000115311523200452031367 0ustar  giovannigiovanni%mathpiper,def="IsSegment"

IsSegment(list_IsList) <--
[
    If(IsList(list[1]) And Length(list[1])=2 And IsList(list[2]) And Length(list[2])=2,True,False);

];

%/mathpiper



%mathpiper_docs,name="IsSegment",categories="User Functions;Analytic Geometry",access="experimental"
*CMD IsSegment --- test for a segment
*STD
*CALL
	IsSegment(s)
*PARMS

{s} -- segment to test


*DESC

Tests if a value is a segment.

*E.G.

In> IsSegment(Segment(Point(0,0), Point(3,4)))
Result: True
	
In> IsSegment({3,4})
Result: False
	
*SEE Point, Midpoint, Distance, Slope, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/Midpoint.mpw0000644000175000017500000000247111523200452031260 0ustar  giovannigiovanni%mathpiper,def="Midpoint"

Midpoint(PointA_IsPoint,PointB_IsPoint) <-- 
[
    Local(x1,x2,y1,y2,midpointX,midpointY);
    
    x1 := PointA[1];
    x2 := PointB[1];
    y1 := PointA[2];
    y2 := PointB[2];

    midpointX := (x1 + x2)/2;
    midpointY := (y1 + y2)/2;
    
    {midpointX,midpointY};

];



Midpoint(segment_IsSegment) <-- 
[
    Local(x1,x2,y1,y2,midpointX,midpointY);
    
    x1 := segment[1][1];
    x2 := segment[2][1];
    y1 := segment[1][2];
    y2 := segment[2][2];

    midpointX := (x1 + x2)/2;
    midpointY := (y1 + y2)/2;
    
    {midpointX,midpointY};

];

%/mathpiper



%mathpiper_docs,name="Midpoint",categories="User Functions;Analytic Geometry",access="experimental"
*CMD Midpoint --- returns a Point which represents the midpoint between two points
*STD
*CALL
	Midpoint(p1, p2)
	Midpoint(s)
*PARMS

{p1} -- the first point

{p2} -- the second point

{s} -- a segment

*DESC

This function calculates the midpoint between two points using the 
midpoint formula.

*E.G.

In> PointA := Point(2,3)
Result: {2,3}
	
In> PointB := Point(6,8)
Result: {6,8}
	
In> Midpoint(PointA, PointB)
Result: {4,11/2}

In> Midpoint(Segment(Point(0,0), Point(3,4)))
Result: {3/2,2}

*SEE IsPoint, Point, Distance, Slope, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/IsPoint.mpw0000644000175000017500000000104211523200452031053 0ustar  giovannigiovanni%mathpiper,def="IsPoint"

IsPoint(p) := If(IsList(p) And (Length(p) = 2 Or Length(p) = 3),True,False);

%/mathpiper



%mathpiper_docs,name="IsPoint",categories="User Functions;Analytic Geometry",access="experimental"
*CMD IsPoint --- test for a point
*STD
*CALL
	IsPoint(p)
*PARMS

{p} -- point to test


*DESC

Tests if a value is a point.

*E.G.

In> p := Point(2,3)
Result: {2,3}
	
In> IsPoint(p)
Result: True
	
In> IsPoint(4)
Result: False
	
*SEE Point, Midpoint, Distance, Slope, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geometry/Distance.mpw0000644000175000017500000000152211523200452031223 0ustar  giovannigiovanni%mathpiper,def="Distance"

Distance(PointA_IsPoint,PointB_IsPoint) <--
[
    Local(x1,x2,y1,y2,distance);

    x1 := PointA[1];
    x2 := PointB[1];
    y1 := PointA[2];
    y2 := PointB[2];
    
    distance := Sqrt((x2 - x1)^2 + (y2 - y1)^2);
];

%/mathpiper



%mathpiper_docs,name="Distance",categories="User Functions;Analytic Geometry",access="experimental"
*CMD Distance --- returns the distance between two points
*STD
*CALL
	Distance(p1, p2)
*PARMS

{p1} -- the first point

{p2} -- the second point

*DESC

This function calculates the distance between two points using the 
distance formula.

*E.G.

In> PointA := Point(2,3)
Result: {2,3}
	
In> PointB := Point(6,8)
Result: {6,8}
	
In> Distance(PointA, PointB)
Result: Sqrt(41)

*SEE IsPoint, Point, Midpoint, Slope, Segment
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/0000755000175000017500000000000011722677331026703 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/GeoGebraHistogram.mpw0000644000175000017500000000466211517224250032757 0ustar  giovannigiovanni%mathpiper,def="GeoGebraHistogram"

//Retract("GeoGebraHistogram",*);

GeoGebraHistogram(classBoundaries, data) := 
[
    Local(command);
    //todo:tk: a check must be made to make sure that all data items fit into the class boundaries.
    // If they don't, GeoGebra will not accept them.
    
    command := PatchString("Histogram[,]");
    JavaCall(geogebra, "evalCommand", command);
];




GeoGebraHistogram(data) := 
[
    Local(command, classBoundaries, noDuplicatesSorted, largestValue, smallestValue, x, numberOfUniqueValues);
    
    noDuplicatesSorted := HeapSort(RemoveDuplicates(data), "<" );
    
    smallestValue := Floor(noDuplicatesSorted[1]);
    
    numberOfUniqueValues := Length(noDuplicatesSorted);
    
    largestValue := Ceil(noDuplicatesSorted[Length(noDuplicatesSorted)]);
    
    classBoundaries := N(Table(x,x,smallestValue-.5,largestValue+.5,1));
    
    command := PatchString("Histogram[,]");
    JavaCall(geogebra, "evalCommand", command);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper,scope="nobuild",subtype="manual_test"

GeoGebraHistogram({1, 2, 3, 4}, {1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0});

%/mathpiper

    %output,preserve="false"
      Result: class java.lang.Boolean
.   %/output




%mathpiper,scope="nobuild",subtype="manual_test"

GeoGebraHistogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0});

%/mathpiper

    %output,preserve="false"
      Result: java.lang.Boolean
.   %/output


%mathpiper,scope="nobuild",subtype="manual_test"

GeoGebraHistogram(N({16+3/8, 16+3/8, 17+1/8, 16, 14+3/8, 17+1/4, 16+5/8, 16, 17, 17+1/4, 17, 15+7/8, 16+5/8, 16+1/8, 17+1/8, 16+7/8, 16+3/8, 16+3/8, 16+7/8, 17+1/8, 17, 16+3/4, 17+1/4, 17+1/8, 15+3/8}));

%/mathpiper

    %output,preserve="false"
      Result: class java.lang.Boolean
.   %/output



%mathpiper,scope="nobuild",subtype="manual_test"
classBoundaries := N(Table(x,x,14,20,1/4));

E := N({16+3/8, 16+3/8, 17+1/8, 16, 14+3/8, 17+1/4, 16+5/8, 16, 17, 17+1/4, 17, 15+7/8, 16+5/8, 16+1/8, 17+1/8, 16+7/8, 16+3/8, 16+3/8, 16+7/8, 17+1/8, 17, 16+3/4, 17+1/4, 17+1/8, 15+3/8});

D := N({18+1/4, 19+1/4, 18+1/4, 15+5/8, 17+5/8, 17+1/2, 17+1/8, 17+1/8, 17+1/2, 14+1/2, 17+3/8, 16+7/8, 17+3/4, 18+7/8, 14+7/8, 19+1/4, 18+1/8, 16+1/4, 16+1/8, 16+3/4, 17+1/4, 17+3/8, 17+1/8, 17+1/2, 16+5/8});

GeoGebraHistogram(classBoundaries,Concat(D,E));

%/mathpiper



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/GeoGebra.mpw0000644000175000017500000000103411517224250031067 0ustar  giovannigiovanni%mathpiper,def="GeoGebra"

//Retract("GeoGebra",*);

LocalSymbols(options)
[
    options  := {};
    
    Local(updateObjects);
    
    updateObjects := "";
    
    options["updateObjects"] := updateObjects;
    
    

GeoGebra() := options;


GeoGebra(list) := (options := list);



];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper,scope="nobuild",subtype="manual_test"

LoadScriptOnce("proposed.rep/geogebra.mpi");

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/GeoGebraPlot.mpw0000644000175000017500000001025511517224250031733 0ustar  giovannigiovanni%mathpiper,def="GeoGebraPlot"
//Retract("GeoGebraPlot",*);

RulebaseListed("GeoGebraPlot",{arg1,arg2});



5 # GeoGebraPlot(_arg1) <-- GeoGebraPlot(arg1,{});  //Handle single argument call.


20 # GeoGebraPlot(function_IsFunction, options_IsList)_(Not IsList(function)) <--
[
    Local(command);
    
    function := (Subst(==,=) function);
    
    command := ConcatStrings(PipeToString()Write(function));
    
    JavaCall(geogebra,"evalCommand",command);
];




10 # GeoGebraPlot(list_IsList, _options)_(IsNumericList(list) )  <--
[
    If(IsList(options), options := OptionsToAssociativeList(options), options := OptionsToAssociativeList({options}));

    Local(length, index, labelIndex, pointTemplate, segmentCommandTemplate, segmentElementTemplate, command, code, x, y, pointSize);
    
    length := Length(list);
    
    If(IsOdd(length), list := Append(list,list[length])); //Make list even for line drawing.
    
    If(options["pointSize"] != Empty, pointSize := options["pointSize"], pointSize := "1");
    
    index := 1;
    
    labelIndex := 1;
    
    pointTemplate := "\"> 			\" y=\"\" z=\"1.0\"/>	\"/>";
    segmentCommandTemplate := "";
    segmentElementTemplate := "\">";
    
    
    //todo:tk: this does not seem to be working JavaCall(geogebra, "setRepaintingActive", "false");
    //JavaCall(geogebra, "setLayerVisible", "0", "False");
    
    While(index < length+1)
    [
        x := list[index];
        index++;
        y := list[index];
        index++;
        
        
        code := PatchString(pointTemplate);

        
        JavaCall(geogebra,"evalXML",code);
        
        If(options["lines"] = "True" And labelIndex > 1,
        [
            
            command := PatchString("a = Segment[A,A]");
            JavaCall(geogebra, "evalCommand", command);

            
            code := PatchString(segmentElementTemplate);
            JavaCall(geogebra,"evalXML",code);
        ]
        );
       
        labelIndex++;
    ]; //end while.
    
     //todo:tk: this does not seem to be working  JavaCall(geogebra, "setRepaintingActive", "true");
     //JavaCall(geogebra, "setLayerVisible", "0", "True");

];


5 # GeoGebraPlot(list_IsList, _options)_(IsMatrix(list)) <--
[
    Local(flatList);
    
    flatList := {};
    
    ForEach(subList,list)
    [
        DestructiveAppend(flatList,subList[1]);
        DestructiveAppend(flatList, subList[2]);
    ];
    
    GeoGebraPlot(flatList, options);

];

//HoldArgument("GeoGebraPlot",arg2);


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper,title="",scope="nobuild",subtype="manual_test"

GeoGebraPlot({1,1,2,2,3,3,4,4,5,5,6,6}, lines -> True);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper,title="",scope="nobuild",subtype="manual_test"

GeoGebraPlot({{0,0}, {0,-1},{0,-2},{1,-2},{1,-1},{2,-1},{3,-1},{4,-1},{4,-2},{5,-2},{6,-2},{6,-1},{6,-2},{7,-2},{7,-1},{8,-1},{8,0},{8,-1},{9,-1},{8,-1},{7,-1}},lines -> True, labels -> False);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper,title="",scope="nobuild",subtype="manual_test"
GeoGebraPlot(Hold(f(x) = x^2));

GeoGebraPlot(x^3);

%/mathpiper

    %output,preserve="false"
      Result: true
.   %/output






mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/ggbLine.mpw0000644000175000017500000000054111517224250030765 0ustar  giovannigiovanni%mathpiper,def="GgbLine"

//Retract("ggbLine", *);

ggbLine(point1Label, point2Label) :=
[
    Local(command);
    
    command := PatchString("Line[,]");
    
    
    JavaCall(geogebra,"evalCommand",command);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/ControlChart.mpw0000644000175000017500000001504411410317744032027 0ustar  giovannigiovanni%mathpiper,def="ControlChart"


ControlChart(data) :=
[
    A2 := .577;
    D3 := 0;
    D4 := 2.144;

    means := {};
    meansPoints := {};
    
    ranges := {};
    rangesPoints := {};
    
    index := 1;
    ForEach(group, data)
    [
        groupMean := Mean(group);
        means := N(Append(means, groupMean));
        meansPoints := N(Append(meansPoints,{index, groupMean} ));
        

        groupRange := Range(group);
        ranges := N(Append(ranges, groupRange));
        rangesPoints := N(Append(rangesPoints,{index, groupRange} ));
        
        index++;
    ];
    
    xBarBar := N(Mean(means));
    
    rBar := N(Mean(ranges));
    
    xBarUCL := N(xBarBar + A2*rBar);
    
    xBarLCL := N(xBarBar - A2*rBar);
    
    rUCL := N(D4*rBar);
    
    rLCL := N(D3*rBar);
];




%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper,scope="nobuild",subtype="manual_test"

data := GenMatrix(Lambda({m,n},Distribution(5,2)),25,5);




%/mathpiper

    %output,preserve="false"
      Result: {{5.535324696,3.147460888,4.910225401,6.076869410,8.616587548},{6.783193684,3.999124035,2.070132681,2.198471456,4.689837614},{5.115861586,2.556715922,1.791504284,1.570696873,3.186504705},{6.618546432,5.058075678,6.425406544,5.440151296,2.876156767},{6.870813463,5.536460503,3.742818612,3.273049807,5.440834797},{3.476261577,4.489497315,5.362976802,4.692969850,9.302494507},{7.193172085,1.406463231,3.552659846,5.868100596,5.048939936},{5.927707889,5.330929820,7.591065070,7.721676042,4.486786941},{10.31005985,5.395145532,7.605833444,3.065209181,5.762217907},{4.372961981,2.350334458,5.060549217,1.608207367,5.655733286},{10.64165146,4.807379261,4.127881722,3.879634014,7.783716362},{7.688489023,7.943422085,6.444746912,4.878194094,6.822302753},{5.986770920,1.645611318,3.476876756,4.688580264,4.838067994},{5.819847473,2.226979256,4.577186742,3.901802467,3.643508353},{5.330135257,8.514456587,7.449548011,7.243322996,5.061887727},{8.707067795,9.918086297,5.811769283,8.427376524,4.489150866},{6.084687883,9.006779258,8.491709337,3.211253709,3.300043312},{5.609307637,5.212278303,1.740591039,4.448388564,4.149500985},{3.188763079,8.104502601,7.255061454,3.195876581,2.452227551},{4.056398335,8.168559972,1.212381947,7.235714611,4.570414194},{7.429250440,8.693442366,5.930319720,5.669600753,5.712002630},{4.830909107,4.145336311,5.837332990,2.333043187,7.248572647},{3.301122251,5.373453189,6.696566666,7.643856909,0.6769830979},{5.931296300,3.747230241,6.487956900,4.663625370,6.587462343},{4.350973859,4.126664313,5.013334724,7.941338276,3.987860776}}
.   %/output







%mathpiper,scope="nobuild",subtype="manual_test"
ControlChart(data);
%/mathpiper

    %output,preserve="false"
      Result: 0.000000000
.   %/output






%mathpiper,scope="nobuild",subtype="manual_test"

GeoGebraPlot(meansPoints, lines -> True, pointSize -> 3);


GeoGebraPoint("M1",-10,xBarBar);
GeoGebraPoint("M2",-10.1,xBarBar);
ggbLine("M1","M2");



GeoGebraPoint("XBUCL1",-10,xBarUCL);
GeoGebraPoint("XBUCL2",-10.1,xBarUCL);
ggbLine("XBUCL1","XBUCL2");



GeoGebraPoint("XBLCL1",-10,xBarLCL);
GeoGebraPoint("XBLCL2",-10.1,xBarLCL);
ggbLine("XBLCL1","XBLCL2");




/*
GeoGebraPlot(rangesPoints, lines -> True, pointSize -> 3);

GeoGebraPoint("RM1",-10,rBar);
GeoGebraPoint("RM2",-10.1,rBar);
ggbLine("RM1","RM2");



GeoGebraPoint("RUCL1",-10,rUCL);
GeoGebraPoint("RUCL2",-10.1,rUCL);
ggbLine("RUCL1","RUCL2");
*/


//GeoGebraPoint("RLCL1",-10,rLCL);
//GeoGebraPoint("RLCL2",-10.1,rLCL);
//ggbLine("RLCL1","RLCL2");


%/mathpiper

    %output,preserve="false"
      Result: java.lang.Boolean
.   %/output






%mathpiper,scope="nobuild",subtype="manual_test"
valuesList := {};

Repeat(100)
[
    valuesList := Append( valuesList, Distribution(5,5));
];

valuesList;

%/mathpiper

    %output,preserve="false"
      Result: {3.904859738,1.291245119,11.33193219,2.125285126,2.897183574,6.404705964,2.809908112,0.8959498543,-2.246507238,2.384965110,5.531072931,1.801205670,6.167452541,-7.351081999,12.11859980,9.180652366,1.673470418,12.85119952,8.289753546,7.329728608,16.56995847,-5.806212238,-0.2918977644,-5.016981483,-1.932580558,10.22353528,4.033740000,9.522452367,9.488877976,8.212033039,11.24095104,3.149750964,-4.636901582,3.114616951,5.107259223,6.438374872,-0.6691735799,-0.8989714262,3.524368314,8.812615959,11.55612690,-3.058949624,2.848064062,0.5805488029,4.228697674,9.204665650,12.56855781,7.161728034,-7.201276121,3.702134288,12.20015166,3.319400475,1.562030448,4.665392950,-0.9897927647,2.701793362,14.99166973,3.838483238,3.285145809,0.2952079157,-5.906821377,7.049031704,-0.04361766674,6.289087138,8.640938903,15.48532166,-0.8308200551,5.264794370,6.954885186,2.721880917,10.38558697,8.861197033,5.219130424,-6.927169919,11.19627536,-3.360568640,0.6941200991,9.437604661,13.43687895,13.63578408,5.223931686,3.204927361,1.153818678,3.648579283,1.807616607,1.577352864,6.560595738,1.044125663,4.486200728,10.79969047,6.154173391,7.790004186,8.372930355,3.630221422,6.137493876,3.543304102,-1.314402929,-0.8982105160,4.992513937,2.062545116}
.   %/output



%mathpiper,scope="nobuild",subtype="manual_test"

zz1 := RandomIntegerList(1000,1,9);
Histogram(zz1);

%/mathpiper

    %output,preserve="false"
      Result: org.jfree.chart.ChartPanel
.   %/output




%mathpiper,scope="nobuild",subtype="manual_test"

/*
This is
more than one
line of
commenting!
*/

zz3 := GenMatrix(Lambda({m,n},m,n),4,5);

%/mathpiper

    %output,preserve="false"
      Result: {{1,1,1,1,1},{2,2,2,2,2},{3,3,3,3,3},{4,4,4,4,4}}
.   %/output







%mathpiper,scope="nobuild",subtype="manual_test"

parts := {10.225,10.290,10.193,10.187,10.097,10.116,10.149,10.128,10.032,10.071,10.089,10.090,10.105,10.091,10.137,10.140,10.071,10.077,10.020,10.057,10.107,10.075,10.139,10.170,10.150,9.937,9.908,9.927,9.911,9.862,9.823,9.400,10.145,10.007,9.026};

partsPoints := {};

index := 1;
ForEach(part, parts)
[
    partsPoints := N(Append(partsPoints,{index, part} ));
    
    
    index++;
];

partsPoints;
%/mathpiper

    %output,preserve="false"
      Result: {{1,10.225},{2,10.290},{3,10.193},{4,10.187},{5,10.097},{6,10.116},{7,10.149},{8,10.128},{9,10.032},{10,10.071},{11,10.089},{12,10.090},{13,10.105},{14,10.091},{15,10.137},{16,10.140},{17,10.071},{18,10.077},{19,10.020},{20,10.057},{21,10.107},{22,10.075},{23,10.139},{24,10.170},{25,10.150},{26,9.937},{27,9.908},{28,9.927},{29,9.911},{30,9.862},{31,9.823},{32,9.400},{33,10.145},{34,10.007},{35,9.026}}
.   %/output





%mathpiper,scope="nobuild",subtype="manual_test"

GeoGebraPlot(partsPoints, lines -> True, pointSize -> 3);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/geogebra/GeoGebraPoint.mpw0000644000175000017500000000056111517224250032105 0ustar  giovannigiovanni%mathpiper,def="GeoGebraPoint"
//Retract("GeoGebraPoint",*);

10 # GeoGebraPoint(name_IsString, x_IsNumber, y_IsNumber)  <--
[
    Local(command);
    
    command := PatchString("=(,)");
    
    JavaCall(geogebra,"evalCommand",command);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/0000755000175000017500000000000011722677331027322 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/CorrelationMatrix.mpw0000644000175000017500000000444211502266107033510 0ustar  giovannigiovanni%mathpiper,def="CorrelationMatrix"

CorrelationMatrix(dataLists) := 
[
    Local(namesList, correlationMatrix);
    
    ForEach(dataList, dataLists)
    [
        Check(IsMatrix(dataLists), "Argument", "All lists must have the same number of elements.");
    ];

    namesList := MatrixColumn(dataLists,1);
    
    namesList := "" : namesList;
    
    ForEach(dataList, dataLists)
    [
        PopFront(dataList);
    ];
    
    correlationMatrix := ZeroMatrix(Length(dataLists)+1);
    
    ForEach(rowIndex, 1 .. Length(dataLists) + 1)
    [
        ForEach(columnIndex, 1 .. Length(dataLists) + 1)
        [
            if(rowIndex >= 2 And columnIndex >= 2)
            [
                correlationMatrix[rowIndex][columnIndex] := N(CorrelationCoefficient(dataLists[rowIndex - 1],dataLists[columnIndex - 1]),2);
            ]
            else if(rowIndex = 1)
            [
                correlationMatrix[rowIndex][columnIndex] := namesList[columnIndex];
            ]
            else
            [
                correlationMatrix[rowIndex][columnIndex] := namesList[rowIndex];
            ];
        ];
    ];
    
    correlationMatrix;
];

%/mathpiper




%mathpiper_docs,name="CorrelationMatrix",categories="User Functions;Statistics & Probability",access="experimental"
*CMD CorrelationMatrix --- creates a correlation matrix
*STD
*CALL
	CorrelationMatrix(listOfLists)

*PARMS

{listOfLists} -- a list of lists which contains data to be correlated

*DESC
Creates a correlation coefficient matrix from a list of lists which contain data values.
The first element in each list is the title for the data in that list.  The
CorrelationCoefficient function is used to calculate the individual correlations.

*E.G.
/%mathpiper

dataLists :={
{"Age",25,16,8,23,31,19,15,31,21,26,24,25,36,45,16,23,31,53,11,33},
{"Level",1,2,2,3,4,4,4,5,1,1,5,5,4,4,4,1,2,2,3,2},
{"Score",78,66,78,89,87,90,98,76,56,72,84,87,69,87,88,92,97,69,79,69},
};

CorrelationMatrix(dataLists);

/%/mathpiper

    /%output,preserve="false"
      Result: {{"","Age","Level","Score"},{"Age",1,0.056,-0.15},{"Level",0.056,1,0.39},{"Score",-0.15,0.39,1}}
.   /%/output

*SEE CorrelationCoefficient
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Quartile.mpw0000644000175000017500000000400311517224250031620 0ustar  giovannigiovanni%mathpiper,def="Quartile"

//Retract("Quartile",*);

Quartile(list) :=
[
    sortedList := HeapSort(list,"<");
    
    secondQuartile := Median(sortedList);
    
    If(IsOdd(Length(sortedList)),
    [   
        secondQuartileIndex := Find(sortedList, secondQuartile);
        
        leftList := Take(sortedList, secondQuartileIndex-1);
        rightList := Take(sortedList, -(Length(sortedList) - (secondQuartileIndex) ) );
    ],
    [

        leftList := Take(sortedList, Length(sortedList)/2);
        rightList := Take(sortedList, -Length(sortedList)/2);
    ]
    );
    
    firstQuartile := Median(leftList);
    
    thirdQuartile := Median(rightList);
    
    interquartileRange := thirdQuartile - firstQuartile;
    
    {firstQuartile, secondQuartile, thirdQuartile, interquartileRange};

];

%/mathpiper






%mathpiper_docs,name="Quartile",categories="User Functions;Statistics & Probability",access="experimental"
*CMD Quartile --- returns all of the quartiles and the interquartile range of a list of values
*STD
*CALL
	Quartile(list)

*PARMS

{list} -- a list which contains values

*DESC
Returns all of the quartiles and the interquartile range of a list of values.  The first
value in the returned list is the first quartile, the second value is the second quartile,
the third value is the third quartile, and the fourth value is the interquartile range.

*E.G.
/%mathpiper,title=""

samples := {
438,413,444,468,445,472,474,454,455,449,
450,450,450,459,466,470,457,441,450,445,
487,430,446,450,456,433,455,459,423,455,
451,437,444,453,434,454,448,435,432,441,
452,465,466,473,471,464,478,446,459,464,
441,444,458,454,437,443,465,435,444,457,
444,471,471,458,459,449,462,460,445,437,
461,453,452,438,445,435,454,428,454,434,
432,431,455,447,454,435,425,449,449,452,
471,458,445,463,423,451,440,442,441,439
};

N(Quartile(samples));

/%/mathpiper

    /%output,preserve="false"
      Result: {441,450,458.5,17.5}
.   /%/output

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ScheffeTest.mpw0000644000175000017500000001577511502266107032260 0ustar  giovannigiovanni%mathpiper,def="ScheffeTest"

ScheffeTest(levelsList, alpha) :=
[
    Check(IsListOfLists(levelsList), "Argument", "The first argument must be a list of lists.");
    
    Check(alpha >= 0 And alpha <= 1, "Argument", "The second argument must be a number between 0 and 1.");
    
    Local(  result,
            topOfSummary,
            pairsList,
            xBarB,
            xBarA,
            summaryTableRow,
            ssw,
            nA,
            scheffeStatisticCalculated,
            nB,
            summaryList,
            topOfPage,
            htmlJavaString,
            summaryTableRows,
            meansList,
            index,b,
            pairList,
            a,
            bottomOfPage,
            k,
            countsList,
            oneComparisonList,
            scheffeStatistic,
            bottomOfSummary,
            resultList);
    
    anova := AnovaSingleFactor(levelsList, alpha);
    
    k := Length(levelsList);
    
    scheffeStatisticCalculated := (k-1)*anova["criticalFScore"];
    
    resultList := {};
    
    resultList["scheffeStatisticCalculated"] := scheffeStatisticCalculated;
    
    meansList := {};
    
    countsList := {};
    
    ForEach(levelList,levelsList)
    [
        meansList := meansList : N(Mean(levelList));
    
        countsList := countsList : Length(levelList);
    ];
    
    pairsList := CombinationsList(1 .. Length(levelsList),2);
    
    summaryList := {};
    
    index := 1;
    
    ForEach(pairList, pairsList)
    [   
        a := pairList[1];
        
        b := pairList[2];
        
        xBarA := meansList[a];
        
        nA := countsList[a];
        
        xBarB := meansList[b];
        
        nB := countsList[b];
        
        ssw := anova["sumOfSquaresWithin"];
        
        scheffeStatistic := ScheffeStatistic(xBarA,nA,xBarB,nB,ssw,k,countsList);
        
        oneComparisonList := {};
        
        oneComparisonList["conclusion"] := If(scheffeStatistic <= scheffeStatisticCalculated, "No Difference", "Difference");
        
        oneComparisonList["scheffeStatistic"] := scheffeStatistic;
        
        oneComparisonList["pair"] := pairList;
        
        summaryList["pair" : ToString(index)] := oneComparisonList;
        
        index++;
    ];
    
    resultList["summary"] := summaryList;
    
    
    
    
    topOfPage :=
"
    
        
            Scheffe Test Summary
        
        
        
";
    
    topOfSummary :=
"
            
    Scheffe Test Summary
    
            
            
";

    
    summaryTableRows := "";
    
    summaryTableRow := "":Nl();
    

    
    ForEach(summary, Reverse(resultList["summary"]))
    [
        summary := summary[2];

        pairList := summary["pair"];
        
        summaryTableRows := summaryTableRows : PatchString(summaryTableRow);
    
        index++;
    ];
    
    
    bottomOfSummary :=
"
            
    
                 
    Summary
          
                
                
      Sample Pair  Measured Scheffe Statistic   Calculated Scheffe Statistic   Conclusion  
                  
    
";
    
    
    bottomOfPage :=
"
                 
    
";
    
    htmlJavaString := JavaNew("java.lang.String",
                topOfPage : 
                topOfSummary : 
                summaryTableRows : 
                bottomOfSummary : 
                bottomOfPage);    
    
    
    
    
    resultList["html"] := htmlJavaString;
    
    
    DestructiveReverse(resultList);

];






ScheffeStatistic(xBarA,nA,xBarB,nB,ssw,k,countsList) :=
[
    N(((xBarA-xBarB)^2)/((ssw/Sum(i,1,k,(countsList[i] - 1))*(1/nA + 1/nB))));   
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="ScheffeTest",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ScheffeTest --- performs a Scheffe pairwise analysis

*CALL
	ScheffeTest(listOfLists,alpha)

*PARMS
{listOfLists} -- a list which contains lists which contain the data to be analyzed

{alpha} -- the alpha value to use in the analysis.

*DESC
This function performs a Scheffe pairwise analysis.  The various values that are
calculated during the analysis are returned in an association list and these
values are listed in the keys of the returned list (see the examples section).

If the {html} key is passed to the {ViewHtml} function, the results of the analysis
are displayed in a graphcs window as rendered HTML.

*E.G.
/%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

data1List := {10.2,8.5,8.4,10.5,9.0,8.1};

data2List := {11.6,12.0,9.2,10.3,9.9,12.5};

data3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(scheffeResult := ScheffeTest({data1List,data2List,data3List}, alpha));

Echo("Scheffe statistic of the first pair: ", scheffeResult["scheffeStatistic"]);

ViewHtml(scheffeResult["html"]);

/%/mathpiper

    /%output,preserve="false"
      Result: True
      
      Side Effects:
      {"scheffeStatisticCalculated",7.364640688} 
      {"summary",
      {{"pair3",{{"pair",{2,3}},{"scheffeStatistic",5.039520331},{"conclusion","No Difference"}}},
      {"pair2",{{"pair",{1,3}},{"scheffeStatistic",0.3297901324},{"conclusion","No Difference"}}},
      {"pair1",{{"pair",{1,2}},{"scheffeStatistic",7.947669691},{"conclusion","Difference"}}}}} 
      {"html",java.lang.String}
      
      Scheffe statistic of the first pair: 7.364640688 
      
.   /%/output

*SEE ViewHtml,AnovaSingleFactor
%/mathpiper_docs








%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

data1List := {10.2,8.5,8.4,10.5,9.0,8.1};

data2List := {11.6,12.0,9.2,10.3,9.9,12.5};

data3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(scheffeResult := ScheffeTest({data1List,data2List,data3List}, alpha));

NewLine();

Echo("Scheffe statistic of the first pair: ", scheffeResult["scheffeStatisticCalculated"]);

ViewHtml(scheffeResult["html"]);

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side Effects:
      {"scheffeStatisticCalculated",7.364640688} {"summary",{{"pair3",{{"pair",{2,3}},{"scheffeStatistic",5.039520331},{"conclusion","No Difference"}}},{"pair2",{{"pair",{1,3}},{"scheffeStatistic",0.3297901324},{"conclusion","No Difference"}}},{"pair1",{{"pair",{1,2}},{"scheffeStatistic",7.947669691},{"conclusion","Difference"}}}}} {"html",java.lang.String} 
      
      Scheffe statistic of the first pair: 7.364640688 
      
.   %/output


././@LongLink0000000000000000000000000000015600000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheProportion.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfThePropo0000644000175000017500000000215711517224250033760 0ustar  giovannigiovanni%mathpiper,def="StandardErrorOfTheProportion"

//Retract("StandardErrorOfTheProportion",*);

StandardErrorOfTheProportion(meanOfSampleProportions, sampleSize) :=
[
    Check(IsRationalOrNumber(meanOfSampleProportions), "Argument", "The first argument must be a number.");
    
    Check(IsInteger(sampleSize) And sampleSize > 0, "Argument", "The second argument must be an integer which is greater than 0.");
    
    Sqrt((meanOfSampleProportions*(1 - meanOfSampleProportions))/sampleSize);
];

%/mathpiper






%mathpiper_docs,name="StandardErrorOfTheProportion",categories="User Functions;Statistics & Probability",access="experimental"
*CMD StandardErrorOfTheProportion --- calculates the standard error of the proportion
*STD
*CALL
	StandardErrorOfTheProportion(meanOfSampleProportions,sampleSize)

*PARMS
{meanOfSampleProportions} -- the mean of the sample proportions
{sampleSize} -- the size of the proportion samples

*DESC
This function calculates the standard error of the proportion.

*E.G.
In> N(StandardErrorOfTheProportion(.164,150))
Result: 0.030232873941
%/mathpiper_docs




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/IsSubset.mpw0000644000175000017500000000054311517224250031600 0ustar  giovannigiovanni%mathpiper,def="IsSubset"

//Retract("IsSubset",*);

IsSubset(bigList, littleList) :=
[
    Local(result);
    result := True;
    
    ForEach(element, littleList)
    [
        If(Not Contains(bigList,element), result := False);
    ];

    result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/BinomialDistributionMean.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/BinomialDistributionMea0000644000175000017500000000175611517224250034021 0ustar  giovannigiovanni%mathpiper,def="BinomialDistributionMean"


//Retract("BinomialDistributionMean", *);

BinomialDistributionMean(probability,numberOfTrials) :=
[

    Check(IsRationalOrNumber(probability) And p >= 0 And p <= 1, "Argument", "The first argument must be a number between 0 and 1.");
    
    Check(IsInteger(numberOfTrials) And numberOfTrials >= 0, "Argument", "The second argument must be an integer which is greater than 0.");
    
    numberOfTrials * probability;
];
	

%/mathpiper





%mathpiper_docs,name="BinomialDistributionMean",categories="User Functions;Statistics & Probability",access="experimental"
*CMD BinomialDistributionMean --- the mean of a binomial distribution
*STD
*CALL
	BinomialDistributionMean(p,n)

*PARMS
{p} -- number, the probability of a success in a single trial

{n} -- number of trials

*DESC
This function calculates the mean of a binomial distribution. 

*E.G.
In> BinomialDistributionMean(.3,5)
Result: 1.5

*SEE BinomialDistributionStandardDeviation
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ShuffledDeckNoSuits.mpw0000644000175000017500000000036011517224250033710 0ustar  giovannigiovanni%mathpiper,def="ShuffledDeckNoSuits"

//Retract("ShuffledDeckNoSuits",*);


ShuffledDeckNoSuits() := 
[
   Shuffle(Concat(1 .. 13, 1 .. 13, 1 .. 13, 1 .. 13));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheSlope.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheSlope0000644000175000017500000000271111502266107033740 0ustar  giovannigiovanni%mathpiper,def="StandardErrorOfTheSlope"

StandardErrorOfTheSlope(xList,yList) :=
[   
    Check(IsList(xList), "Argument", "The first argument must be a list.");
    
    Check(IsList(yList), "Argument", "The second argument must be a list.");
    
    Check(Length(xList) = Length(yList), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    Local(standardErrorOfTheEstimate,n,xMean);
    
    standardErrorOfTheEstimate := StandardErrorOfTheEstimate(xList,yList);
    
    n := Length(xList);
    
    xMean := Mean(xList);
    
    N(standardErrorOfTheEstimate/Sqrt(Sum(xList^2) - n*xMean^2));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="StandardErrorOfTheSlope",categories="User Functions;Statistics & Probability",access="experimental"
*CMD StandardErrorOfTheSlope --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	StandardErrorOfTheSlope(xList,yList)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper

x := {4,3,5,2,3,4,3};
y := {83,86,92,78,82,95,80};

StandardErrorOfTheSlope(x,y);

/%/mathpiper

    /%output,preserve="false"
      Result: 1.813835715
.   /%/output
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Range.mpw0000644000175000017500000000145411502266107031076 0ustar  giovannigiovanni%mathpiper,def="Range"

Range(list) :=
[
    Check(Length(list) > 0 And IsNumericList(list), "Argument", "Argument must be a nonempty numeric list.");
    
    Maximum(list) - Minimum(list);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Range",categories="User Functions;Statistics & Probability",access="experimental"
*CMD Range --- calculates the Range of a list of values
*STD
*CALL
	Range(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the Range of a list of values.  The Range is the value
that occurs most frequently.

*E.G.
In> Range({2,3,4,3,4,5,5})
Result: 3

*SEE Mean, WeightedMean, Median, GeometricMean
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Permutations.mpw0000644000175000017500000000242211517224250032527 0ustar  giovannigiovanni%mathpiper,def="Permutations"

//Retract("Permutations", *);

Permutations(n) :=
[
    Check(IsInteger(n), "Argument", "Argument must be an integer");

    n!;
];


Permutations(n, r) :=
[
    Check(IsInteger(n), "Argument", "Argument 1 must be an integer");
    
    Check(IsInteger(r), "Argument", "Argument 2 must be an integer");
    
    n! /(n-r)!;
];

%/mathpiper





%mathpiper_docs,name="Permutations",categories="User Functions;Combinatorics",access="experimental"
*CMD Permutations --- number of permutations
*STD
*CALL
    Permutations(n)
    Permutations(n, r)

*PARMS

{n} -- integer - total number of objects
{r} -- integer - number of objects chosen

*DESC

In combinatorics, this function is thought of as being the number of ways
to choose "r" objects out of a total of "n" objects if order is taken into account.

The single parameter version of the function is a convenience function for
calculating the number of ways to choose "n" objects out of "n" objects.

*E.G.
In> Permutations(5)
Result> 120

In> Permutations(10,3)
Result> 720

*SEE PermutationsList, Combinations, CombinationsList, LeviCivita
%/mathpiper_docs






%mathpiper,scope="nobuild",subtype="manual_test"

Permutations(4);

%/mathpiper


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RandomPickVector.mpw0000644000175000017500000000240111517224250033244 0ustar  giovannigiovanni%mathpiper,def="RandomPickVector"

//Retract("RandomPickVector", *);

RandomPickVector(list, count) :=
[
    Check(IsList(list), "Argument", "Argument 1 must be a list.");
    
    Check(IsInteger(count), "Argument", "Argument 2 must be an integer.");
    
    Table(RandomPick(list),x,1,count,1);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="RandomPickVector",categories="User Functions;Statistics & Probability",access="experimental"
*CMD RandomPickVector --- returns a given number of randomly picked elements from a given list
*STD
*CALL
	RandomPickVector(list,count)

*PARMS

{list} -- a list which contains elements

{count} -- an integer which indicates how many elements to return

*DESC
Randomly picks {count} elements from the given list.

*E.G.
In> RandomPickVector({ONE,TWO,THREE},7);
Result: {THREE,ONE,THREE,THREE,ONE,TWO,TWO}

*SEE RandomPick, RandomPickWeighted
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output








%mathpiper,scope="nobuild",subtype="manual_test"

RandomPickVector({ONE,TWO,THREE},7);

%/mathpiper

    %output,preserve="false"
      Result: {TWO,THREE,ONE,THREE,THREE,TWO,THREE}
.   %/output


././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceLevelToZScore.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceLevelToZScore0000644000175000017500000000157411517224250033720 0ustar  giovannigiovanni%mathpiper,def="ConfidenceLevelToZScore"


//Retract("ConfidenceLevelToZScore",*);

ConfidenceLevelToZScore(probability) :=
[
    //Shift the probability higher to turn it into a confidence interval.
    probability := probability + (1 - probability)/2;
    
    ProbabilityToZScore(probability);
];


%/mathpiper







%mathpiper_docs,name="ConfidenceLevelToZScore",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ConfidenceLevelToZScore --- calculates the z-score for a given confidence level
*STD
*CALL
	ConfidenceLevelToZScore(probability)

*PARMS

{probability} -- a probability value

*DESC

This function calculates the z-score for a given confidence level.

*E.G.
In> ConfidenceLevelToZScore(.90)
Result: 1.644853952

*SEE NormalDistribution,ZScoreToProbability,ProbabilityToZScore
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ZScoreToValue.mpw0000644000175000017500000000157411517224250032551 0ustar  giovannigiovanni%mathpiper,def="ZScoreToValue"

//Retract("ZScoreToValue",*);

ZScoreToValue(zScore) :=
[
    -((-mean)/standardDeviation - zScore)*standardDeviation;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ZScoreToValue",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ZScoreToValue --- calculates the numerical value for a given z-score
*STD
*CALL
	ZScoreToValue(zScore,mean,standardDeviation)

*PARMS

{zScore} -- a z score
{mean} -- the mean
{standardDeviation} -- the standard deviation

*DESC
This function calculates the numerical value for a given z-score.

*E.G.
In> N(ZScoreToValue(1,5,1))
Result: 6

*SEE ValueToZScore,ZScoreToProbability,ProbabilityToZScore,ConfidenceLevelToZScore
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/CoefficientOfDetermination.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/CoefficientOfDeterminat0000644000175000017500000000234011502266107033753 0ustar  giovannigiovanni%mathpiper,def="CoefficientOfDetermination"

CoefficientOfDetermination(x,y) :=
[   
    Check(IsList(x), "Argument", "The first argument must be a list.");
    
    Check(IsList(y), "Argument", "The second argument must be a list.");
    
    Check(Length(x) = Length(y), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    N(CorrelationCoefficient(x,y)^2);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="CoefficientOfDetermination",categories="User Functions;Statistics & Probability",access="experimental"
*CMD CoefficientOfDetermination --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	CoefficientOfDetermination(xList,yList)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper

x := {4,3,5,2,3,4,3};
y := {83,86,92,78,82,95,80};

CoefficientOfDetermination(x,y);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.7766185090
.   /%/output
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RandomPickWeighted.mpw0000644000175000017500000000450211517224250033546 0ustar  giovannigiovanni%mathpiper,def="RandomPickWeighted"

//Retract("RandomPickWeighted",*);

RandomPickWeighted(list) :=
[

    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Local(element, probabilities, items, lastWeight, randomNumber, result);
    
    probabilities := 0;
    
    items := {};
    
    lastWeight := 0;
    
    
    
    //Make sure that the probabilities sum to 1.
    ForEach(element,list)
    [        
        probability := element[2];

        probabilities := probabilities + probability;
    ];
    
    Check(probabilities = 1, "Argument", "The probabilities must sum to 1.");
    
    
    
    //Place items in a list and associate it with a subrange in the range between 0 and 1.
    ForEach(element,list)
    [
        probability := element[2];
        
        item := element[1];
        
        items := Append(items, {item, {lastWeight, lastWeight := lastWeight + N(probability)}} );
    ];
    
    
    
    //Pick the item which is in the randomly determined range.
    randomNumber := Random();
    
    ForEach(itemData,items)
    [
        If(randomNumber >= itemData[2][1] And randomNumber <= itemData[2][2], result := itemData[1] );
    ];
    
    
    
    result;

];

%/mathpiper








%mathpiper_docs,name="RandomPickWeighted",categories="User Functions;Statistics & Probability",access="experimental"
*CMD RandomPickWeighted --- randomly pick an element from a list using a given weight
*STD
*CALL
	RandomPickWeighted(list)

*PARMS

{list} -- a list which contains elements and their respective weights

*DESC
Randomly picks an element from the given list with a probability which is determined by the element's weight. 

*E.G.
In> RandomPickWeighted({{HEADS,1/2},{TAILS,1/2}});
Result: HEADS

In> RandomPickWeighted({{HEADS,.5},{TAILS,.5}});
Result: TAILS

In> RandomPickWeighted({{DOOR1,2/8}, {DOOR2,1/8}, {DOOR3,5/8}})
Result: DOOR1

In> RandomPickWeighted({{DOG,.2}, {CAT,.3}, {BIRD,.1}, {MOUSE,.15}, {TURTLE,.25}})
Result: TURTLE

In> RandomPickWeighted({{23,5/32},{56,10/32},{87,8/32},{92,6/32},{15,3/32}})
Result: 15

*SEE RandomPick, RandomPickVector
%/mathpiper_docs








%mathpiper,scope="nobuild",subtype="manual_test"

RandomPickWeighted({{HEADS,1/2},{TAILS,1/2}});

%/mathpiper



././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/SampleSizeForTheProportion.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/SampleSizeForTheProport0000644000175000017500000000255711517224250034016 0ustar  giovannigiovanni%mathpiper,def="SampleSizeForTheProportion"

//Retract("SampleSizeForTheProportion",*);

SampleSizeForTheProportion(probabilityOfSuccess,confidenceLevel,marginOfError) :=
[
    Check(probabilityOfSuccess >=0 And probabilityOfSuccess <= 1, "Argument", "The first argument must be between 0 and 1.");

    Local(minimumSampleSize,zScore);
    
    zScore := ConfidenceLevelToZScore(confidenceLevel);
    
    minimumSampleSize := N(probabilityOfSuccess*(1 - probabilityOfSuccess)*(zScore/marginOfError)^2);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="SampleSizeForTheProportion",categories="User Functions;Statistics & Probability",access="experimental"
*CMD SampleSizeForTheProportion --- calculates the sample size for the proportion
*STD
*CALL
	SampleSizeForTheProportion(probabilityOfSuccess,confidenceLevel,marginOfError)
*PARMS
{probabilityOfSuccess} -- the probability of success for the sample
{confidenceLevel} -- the desired confidence level
{marginOfError} -- the desired margin of error

*DESC
This function calculates the minimum sample size for the proportion to provide
a specific margin of error for a given confidence level.

*E.G.
In> SampleSizeForTheProportion(.5,.99,.06)
Result: 460.7567390
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000016700000000000011571 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/BinomialDistributionStandardDeviation.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/BinomialDistributionSta0000644000175000017500000000225711517224250034043 0ustar  giovannigiovanni%mathpiper,def="BinomialDistributionStandardDeviation"


//Retract("BinomialDistributionStandardDeviation", *);

BinomialDistributionStandardDeviation(probability,numberOfTrials) :=
[

    Check(IsRationalOrNumber(probability) And p >= 0 And p <= 1, "Argument", "The first argument must be a number between 0 and 1.");
    
    Check(IsInteger(numberOfTrials) And numberOfTrials >= 0, "Argument", "The second argument must be an integer which is greater than 0.");
    
    SqrtN(numberOfTrials * probability * (1 - probability));
];
	

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="BinomialDistributionStandardDeviation",categories="User Functions;Statistics & Probability",access="experimental"
*CMD BinomialDistributionStandardDeviation --- the standard deviation of a binomial distribution
*STD
*CALL
	BinomialDistributionStandardDeviation(p,n)

*PARMS
{p} -- number, the probability of a success in a single trial

{n} -- number of trials

*DESC
This function calculates the standard deviation of a binomial distribution. 

*E.G.
In> BinomialDistributionStandardDeviation(.3,5)
Result: 1.05

*SEE BinomialDistributionMean
%/mathpiper_docs
././@LongLink0000000000000000000000000000015700000000000011570 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RegressionLineConfidenceLevel.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RegressionLineConfidenc0000644000175000017500000000451411502266107034001 0ustar  giovannigiovanni%mathpiper,def="RegressionLineConfidenceInterval"

RegressionLineConfidenceInterval(x,y,xValue,confidenceLevel) :=
[   
    Check(IsList(x), "Argument", "The first argument must be a list.");
    
    Check(IsList(y), "Argument", "The second argument must be a list.");
    
    Check(Length(x) = Length(y), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    Check(confidenceLevel >=0 And confidenceLevel <=1, "Argument", "The confidence level must be >= 0 and <= 1.");
    
    Local(n,a,b,xMean,part,result,criticalTScore,standardErrorOfTheEstimate/* regressionLine, todo:tk:causes an error if it is not global. */);
    
    regressionLine := RegressionLine(x,y);
    
    n := regressionLine["count"];
    
    f(x) := [Eval(regressionLine["line"]);];
    
    criticalTScore := OneTailAlphaToTScore(n-2, N((1 - confidenceLevel)/2));
    
    standardErrorOfTheEstimate := StandardErrorOfTheEstimate(x,y);

    xMean := regressionLine["xMean"];

    part := N(criticalTScore * standardErrorOfTheEstimate * Sqrt(1/n + ((xValue - xMean)^2)/(Sum(x^2) - Sum(x)^2/n)));
    
    result := {};
    
    result["upper"] := f(xValue) + part;
    
    result["lower"] := f(xValue) - part;
    
    result;
];

%/mathpiper

    %output,preserve="false"
      Result: {{"lower",f(8)-1.954274717},{"upper",f(8)+1.954274717}}
.   %/output




%mathpiper_docs,name="RegressionLineConfidenceInterval",categories="User Functions;Statistics & Probability",access="experimental"
*CMD RegressionLineConfidenceInterval --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	RegressionLineConfidenceInterval(xList,yList,xValue,confidenceLevel)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values
{xValue} -- a value of x to calculate the confidence interval around
{confidenceLevel} -- the desired level of confidence

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper,title="Confidence interval for the regression line."
xList := 1 .. 10;
yList := {5,6,10,6,11,13,9,12,15,17};
RegressionLineConfidenceInterval(xList,yList,8,.95);
/%/mathpiper

    /%output,preserve="false"
      Result: {{"lower",51.59027286},{"upper",55.49882230}}
.   /%/output

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Shuffle.mpw0000644000175000017500000000252411517224250031434 0ustar  giovannigiovanni%mathpiper,def="Shuffle"

//Retract("Shuffle",*);

/*
 This function is based on the Fisher-Yates/Knuth shuffle algorithm
 which is described here at 
 http://en.wikipedia.org/wiki/Fisher%E2%80%93Yates_shuffle .
*/
Shuffle(list) :=
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Local(index, randomIndex, temporary);
    
    list := FlatCopy(list);
    
    index := Length(list);
    
    While(index > 1)
    [
        randomIndex := RandomInteger(1,index);
        
        temporary := list[randomIndex];
        
        list[randomIndex] := list[index];
        
        list[index] := temporary;
        
        index--;
    ];      
    
    list;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="Shuffle",categories="User Functions;Statistics & Probability",access="experimental"
*CMD Shuffle --- randomly shuffles the elements in a list
*STD
*CALL
	Shuffle(list)

*PARMS

{list} -- a list of elements

*DESC
This function takes a list of elements and shuffles them.  A new
list with the shuffled elements is returned.

*E.G.
In> Shuffle({1,2,3,4,5})
Result: {5,1,2,4,3}

In> Shuffle({one,two,three})
Result: {two,three,one}

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Repeat.mpw0000644000175000017500000000454211517224250031262 0ustar  giovannigiovanni%mathpiper,def="Repeat"



//Retract("Repeat",*);


/*
    These variables need to be declared as local symbols because
    body is unfenced and expressions in the body could see them
    otherwise.
*/
LocalSymbols(count, iterations, body)[


Rulebase("Repeat",{iterations,body});

/*
  A Rule function needed to be used here because 10 # xxx <--
  notation did not work if Bodied was executed before the
  function was defined.  Bodied is evaluated in stdopers.mpw
  because it needs to be evaluated for the parser to parse
  Retract correctly.
*/

Rule("Repeat",2,10,IsInteger(iterations) And iterations > 0)
[
    Local(count);

    count := 0;

    While (iterations > 0)
    [
        Eval(body);
        iterations--;
        count++;
    ];

    count;

];





Rulebase("Repeat",{body});


Rule("Repeat",1,20,True)
[
    Local(count);

    count := 0;
    While (True)
    [
        Eval(body);
        count++;
    ];

    count;
];

];//end LocalSymbols

UnFence("Repeat",2);
HoldArgumentNumber("Repeat",2,2);
UnFence("Repeat",1);
HoldArgumentNumber("Repeat",1,1);



%/mathpiper





%mathpiper_docs,name="Repeat",categories="User Functions;Control Flow",access="experimental"
*CMD Repeat --- loop a specified number of times or loop indefinitely
*STD
*CALL
	Repeat(count) body
        Repeat() body

*PARMS

{count} -- a positive integer, the number of times to loop

{body} -- expression to loop over

*DESC

The first version of Repeat executes {body} the number of times
which are specified by {count}.  The second version
executes {body} indefinitely and the only way to exit the loop
is to execute the Break function inside of {body}.

Repeat returns the number of times it looped as a result.

*E.G.
/%mathpiper

Repeat(4)
[
    Echo("Hello");
];

/%/mathpiper

    /%output,preserve="false"
      Result: 4

      Side Effects:
      Hello
      Hello
      Hello
      Hello
.   /%/output



/%mathpiper

x := 1;

loopCount := Repeat()
[
    Echo(x);

    If(x = 3, Break());

    x := x + 1;
];

Echo("Loop count: ", loopCount);

/%/mathpiper

    /%output,preserve="false"
      Result: True

      Side Effects:
      1
      2
      3
      Loop count: 2
.   /%/output

*SEE While, For, ForEach, Break, Continue
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ZScoreToProbability.mpw0000644000175000017500000000547311371733712033765 0ustar  giovannigiovanni%mathpiper,def="ZScoreToProbability"

/* 
    This function was adapted from the Javascript version of function
    that is located here:
    
    http://www.fourmilab.ch/rpkp/experiments/analysis/zCalc.js
    http://www.fourmilab.ch/rpkp/experiments/analysis/zCalc.html?
    
    The following JavaScript functions for calculating normal and
    chi-square probabilities and critical values were adapted by
    John Walker from C implementations
    written by Gary Perlman of Wang Institute, Tyngsboro, MA
    01879. Both the original C code and this JavaScript edition
    are in the public domain. 
*/



/* 
    POZ -- probability of normal z value

    Adapted from a polynomial approximation in:
    Ibbetson D, Algorithm 209
    Collected Algorithms of the CACM 1963 p. 616
    Note:
    This routine has six digit accuracy, so it is only useful for absolute
    z values <:= 6. For z values > to 6.0, poz() returns 1.0.
*/

ZScoreToProbability(zScore) :=
[
    zScore := N(zScore);
    
    Local( y, x, w, ZMAX, result);
    
    ZMAX := 6; // Maximum �z value
    
    if(zScore = 0.0)
    [
        x := 0.0;
    ]
    else
    [
        y := 0.5 * AbsN(zScore);
        
        if(y > ZMAX * 0.5)
        [
            x := 1.0;
        ]
        else if(y < 1.0)
        [
            w := y * y;
            x := ((((((((0.000124818987 * w
            - 0.001075204047) * w + 0.005198775019) * w
            - 0.019198292004) * w + 0.059054035642) * w
            - 0.151968751364) * w + 0.319152932694) * w
            - 0.531923007300) * w + 0.797884560593) * y * 2.0;
        ]
        else
        [
            y := y - 2.0;
            
            x := (((((((((((((-0.000045255659 * y
            + 0.000152529290) * y - 0.000019538132) * y
            - 0.000676904986) * y + 0.001390604284) * y
            - 0.000794620820) * y - 0.002034254874) * y
            + 0.006549791214) * y - 0.010557625006) * y
            + 0.011630447319) * y - 0.009279453341) * y
            + 0.005353579108) * y - 0.002141268741) * y
            + 0.000535310849) * y + 0.999936657524;
        ];
    ];
    
        
    If(zScore > 0.0 , result := (x + 1.0) * 0.5 , result := (1.0 - x) * 0.5);
    
    result;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ZScoreToProbability",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ZScoreToProbability --- calculates the probability of a given z-score
*STD
*CALL
	ZScoreToProbability(z_score)

*PARMS

{z_score} -- a z-score value

*DESC

This function calculates the probability of a given z-score.

*E.G.
In> ZScoreToProbability(1.08)
Result: 0.8599289100

*SEE NormalDistribution,ProbabilityToZScore,ValueToZScore,ZScoreToValue,ConfidenceLevelToZScore
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ErrorFunction.mpw0000644000175000017500000000441311522452007032635 0ustar  giovannigiovanni%mathpiper,def="ErrorFunction"

/*
This function came from http://www.johndcook.com/blog/2009/01/19/stand-alone-error-function-erf/

"This problem is typical in two ways: Abramowitz & Stegun has a solution, and 
you've got to know a little background before you can use it.

The formula given in Abramowitz & Stegun is only good for x <= 0. That's no problem if you 
know that the error function is an odd function, i.e. erf(-x) = -erf(x). 
But if you're an engineer who has never heard of the error function but 
needs to use it, it may take a while to figure out how to handle negative inputs.

One other thing that someone just picking up A&S might not know is the 
best way to evaluate polynomials. The formula appears as 
1 - (a1t1 + a2t2 + a3t3 + a4t4 + a5t5)exp(-x2), which is absolutely correct. 
But directly evaluating an nth order polynomial takes O(n2) operations, 
while the factorization used in the code above uses O(n) operations. This 
technique is known as Horner's method. John D. Cook."

*/

//Retract("ErrorFunction",*);

ErrorFunction(x) :=
[
    Local(a1,a2,a3,a4,a5,p,sign,t,y);
    //constants
    a1 :=  0.254829592;
    a2 := -0.284496736;
    a3 :=  1.421413741;
    a4 := -1.453152027;
    a5 :=  1.061405429;
    p  :=  0.3275911;

    //Save the sign of x
    sign := 1;
    
    If(x < 0, sign := -1);
    
    x := AbsN(x);

    // Abramowitz & Stegun 7.1.26
    t := 1.0/(1.0 + p*x);
    y := N(1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1)*t*Exp(-x*x));

    sign*y;
];



%/mathpiper



%mathpiper_docs,name="ErrorFunction",categories="User Functions;Special Functions",access="experimental"
*CMD ErrorFunction --- a special function which occurs in probability statistics and partial differential equations
*STD
*CALL
	ErrorFunction(a)

*PARMS

{a} -- a measurement value

*DESC

When the results of a series of measurements are described by a normal distribution 
with standard deviation \scriptstyle\sigma and expected value 0, then 
${erf}\,\left(\,\frac{a}{\sigma \sqrt{2}}\,\right)$
is the probability that the error of a single measurement lies between -a and +a, 
for positive a. http://en.wikipedia.org/wiki/Error_function.

*E.G.
In> ErrorFunction(1)
Result: 0.8427006898

*SEE NormalDistribution
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RandomPick.mpw0000644000175000017500000000214311517224250032064 0ustar  giovannigiovanni%mathpiper,def="RandomPick"

//Retract("RandomPick",*);


RandomPick(list) :=
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Check(Length(list) > 0, "Argument", "The number of elements in the list must be greater than 0.");
    
    Local(pickPosition);
    
    pickPosition := RandomInteger(Length(list));

    list[pickPosition];
];

%/mathpiper







%mathpiper_docs,name="RandomPick",categories="User Functions;Statistics & Probability",access="experimental"
*CMD RandomPick --- randomly pick an element from a list
*STD
*CALL
	RandomPick(list)

*PARMS

{list} -- a list which contains elements

*DESC
Randomly picks an element from the given list.  

*E.G.
In> RandomPick({HEADS, TAILS})
Result: HEADS

In> RandomPick({DOOR1, DOOR2, DOOR3})
Result: DOOR2

In> RandomPick({DOG, CAT, BIRD, MOUSE, TURTLE})
Result: BIRD

In> RandomPick({23,56,87,92,15})
Result: 56

*SEE RandomPickWeighted, RandomPickVector
%/mathpiper_docs







%mathpiper,scope="nobuild",subtype="manual_test"

RandomPick({A,B,C});

%/mathpiper




././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheEstimate.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheEstim0000644000175000017500000000277711502266107033753 0ustar  giovannigiovanni%mathpiper,def="StandardErrorOfTheEstimate"

StandardErrorOfTheEstimate(xList,yList) :=
[   
    Check(IsList(xList), "Argument", "The first argument must be a list.");
    
    Check(IsList(yList), "Argument", "The second argument must be a list.");
    
    Check(Length(xList) = Length(yList), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    Local(n,a,b,regressionLine);
    
    regressionLine := RegressionLine(xList,yList);
    
    n := regressionLine["count"];
    
    a := regressionLine["yIntercept"];
    
    b := regressionLine["slope"];
        
    N(Sqrt((Sum(yList^2) - a*Sum(yList) - b*Sum(xList*yList))/(n-2)));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="StandardErrorOfTheEstimate",categories="User Functions;Statistics & Probability",access="experimental"
*CMD StandardErrorOfTheEstimate --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	StandardErrorOfTheEstimate(xList,yList)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper

x := {4,3,5,2,3,4,3};
y := {83,86,92,78,82,95,80};

StandardErrorOfTheEstimate(x,y);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.7766185090
.   /%/output
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000016000000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/AnovaCompletelyRandomizedBlock.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/AnovaCompletelyRandomiz0000644000175000017500000002342211502266107034045 0ustar  giovannigiovanni%mathpiper,def="AnovaCompletelyRandomizedBlock"


AnovaCompletelyRandomizedBlock(levelsList, alpha) :=
[
    Check(IsMatrix(levelsList), "Argument", "The first argument must be a list of equal-length lists.");
    
    Check(alpha >= 0 And alpha <= 1, "Argument", "The second argument must be a number between 0 and 1.");
    
    Local(
        topOfSummary,
        anovaBlockTableRow1,
        criticalFScore,
        anovaBlockTableRow3,
        anovaBlockTableRow2,
        lengthsList,
        summaryTableRow,
        sumsList,
        meanSquareWithin,
        topOfPage,
        htmlJavaString,
        index,
        variancesList,
        grandMean,
        row,
        topOfAnovaBlock,
        result,
        fScoreBlock,
        criticalFScoreBlock,
        blockMeansList,
        sumOfSquaresWithin',
        meanSquareBetween,
        sumOfSquaresBetween,
        fScore,
        summaryTableRows,
        meansList,
        sumOfSquaresBlock,
        b,
        blockSummaryTableRow,
        bottomOfAnovaBlock,
        sumOfSquaresWithin,
        bottomOfPage,
        k,
        sumOfSquaresTotal,
        meanSquareBlock,
        bottomOfSummary
    );
    
    meansList := {};
    
    variancesList := {};
    
    sumsList := {};
    
    lengthsList := {};
    
    
    //ANOVA calculations.
    ForEach(levelList, levelsList)
    [
        meansList := meansList : N(Mean(levelList));
        
        variancesList := variancesList : N(UnbiasedVariance(levelList));
        
        sumsList := sumsList : N(Sum(levelList));

        lengthsList := lengthsList : Length(levelList);
    ];
    
    sumOfSquaresWithin := Sum((lengthsList - 1) * variancesList);

    grandMean := N(Mean(meansList));
    
    sumOfSquaresBetween := Sum(lengthsList*(meansList - grandMean)^2);
    
    
    
    //Block calculations.
    blockMeansList := {};
    
    index := 1;
    
    While(index <= Length(First(levelsList)) )
    [
        row := MatrixColumn(levelsList, index);
        
        blockMeansList := Append(blockMeansList,N(Mean(row)));
    
        index++;
    ];
    
    b := Length(blockMeansList);
    
    k := Length(levelsList);
    
    sumOfSquaresBlock := Sum(j,1,b, k*(blockMeansList[j] - grandMean)^2);
    
    sumOfSquaresTotal := N(sumOfSquaresWithin + sumOfSquaresBetween);
    
    sumOfSquaresWithin' := N(sumOfSquaresTotal - sumOfSquaresBetween - sumOfSquaresBlock);
    
    meanSquareBetween := N(sumOfSquaresBetween/(k - 1));
    
    meanSquareWithin := N(sumOfSquaresWithin'/((k - 1)*(b - 1)));
    
    fScore := N(meanSquareBetween/meanSquareWithin);
    
    meanSquareBlock := N(sumOfSquaresBlock/(b - 1));
    
    fScoreBlock := N(meanSquareBlock/meanSquareWithin);
    
    criticalFScore := ProbabilityToFScore(k - 1, (k - 1)*(b - 1), 1-alpha);
    
    criticalFScoreBlock := ProbabilityToFScore(b - 1, (k - 1)*(b - 1), 1-alpha);
    
    
    
    topOfPage :=
"
    
        
            Anova: Completely Randomized Block
        
        
        
";
    
    topOfSummary :=
"
            
    Anova: Completely Randomized Block
    
            
            
";

    
    summaryTableRows := "";
    
    summaryTableRow := "":Nl();
    
    
    //Data summary.
    index := 1;
    
    While(index <= Length(levelsList))
    [
        summaryTableRows := summaryTableRows : PatchString(summaryTableRow);
    
        index++;
    ];
    

    //Block summary.
    
    blockSummaryTableRow := "":Nl();

    index := 1;
    
    While(index <= Length(First(levelsList)) )
    [
        row := MatrixColumn(levelsList, index);
        
        summaryTableRows := summaryTableRows : PatchString(blockSummaryTableRow);
    
        index++;
    ];
    
    
    
    
    
    bottomOfSummary :=
"
            
    
                 
    Summary
          
                
                
      Level   Count  Sum   Mean   Variance  
                     
                     
    
";
    


    topOfAnovaBlock :=
"
            
    
            
    
            
            
";

    
    
    anovaBlockTableRow1 := PatchString("":Nl());
    
    anovaBlockTableRow2 := PatchString("":Nl());

    anovaBlockTableRow3 := PatchString("":Nl());

    bottomOfAnovaBlock :=
"
            
    
                 
    ANOVA: Completely Randomized Block
          
                
                
      Source of Variation   Sum of Squares   Degrees of Freedom   Mean Square   F   F Critical  
                        
                         
                  
    
";


    
    bottomOfPage :=
"
                 
    
";
    
    htmlJavaString := JavaNew("java.lang.String",
                topOfPage : 
                topOfSummary : 
                summaryTableRows : 
                bottomOfSummary : 
                topOfAnovaBlock : 
                anovaBlockTableRow1 : 
                anovaBlockTableRow2 : 
                anovaBlockTableRow3 : 
                bottomOfAnovaBlock :
                bottomOfPage);
                
                
                
     result := {};
     
     result["html"] := htmlJavaString;
     
     result["sumOfSquaresWithin'"] := sumOfSquaresWithin';
     
     result["sumOfSquaresBetween"] := sumOfSquaresBetween;
     
     result["sumOfSquaresBlock"] := sumOfSquaresBlock;
     
     result["sumOfSquaresTotal"] := sumOfSquaresTotal;
     
     result["meanSquareBetween"] := meanSquareBetween;
     
     result["meanSquareWithin"] := meanSquareWithin;
     
     result["meanSquareBlock"] := meanSquareBlock;
     
     result["fScore"] := fScore;
     
     result["criticalFScore"] := criticalFScore;
     
     result["fScoreBlock"] := fScoreBlock;
     
     result["criticalFScoreBlock"] := criticalFScoreBlock;
     
     result;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output









%mathpiper_docs,name="AnovaCompletelyRandomizedBlock",categories="User Functions;Statistics & Probability",access="experimental"
*CMD AnovaCompleteRandomizedBlock --- performs an ANOVA completely randomized block analysis

*CALL
	AnovaCompletelyRandomizedBlock(2dMatrix,alpha)

*PARMS
{2dMatrix} -- a two dimensional matrix which contain the data to be analyzed

{alpha} -- the alpha value to use in the analysis.

*DESC
This function performs an ANOVA completely randomized block analysis.  The various values that are
calculated during the analysis are returned in an association list and these
values are listed in the keys of the returned list (see the examples section).

If the {html} key is passed to the {ViewHtml} function, the results of the analysis
are displayed in a graphcs window as rendered HTML.

*E.G.
/%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

factor1List := {10.2,8.5,8.4,10.5,9.0,8.1};

factor2List := {11.6,12.0,9.2,10.3,9.9,12.5};

factor3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(anovaBlock := AnovaCompletelyRandomizedBlock({factor1List,factor2List,factor3List}, alpha));

NewLine();

Echo("F-Score of the block: ", anovaBlock["fScoreBlock"]);

ViewHtml(anovaBlock["html"]);

/%/mathpiper

    /%output,preserve="false"
      Result: True
      
      Side Effects:
      {"criticalFScoreBlock",3.325834530} {"fScoreBlock",0.08045614890} {"criticalFScore",4.102821015} {"fScore",3.078377024} 
      {"meanSquareBlock",0.1418888884} {"meanSquareWithin",1.763555556} {"meanSquareBetween",5.428888905} {"sumOfSquaresTotal",29.20277781} 
      {"sumOfSquaresBlock",0.7094444419} {"sumOfSquaresBetween",10.85777781} {"sumOfSquaresWithin'",17.63555556} {"html",java.lang.String} 
      
      F-Score of the block: 0.08045614890 
      
.   /%/output

*SEE ViewHtml, ScheffeTest
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output









%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

factor1List := {10.2,8.5,8.4,10.5,9.0,8.1};

factor2List := {11.6,12.0,9.2,10.3,9.9,12.5};

factor3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(anovaBlock := AnovaCompletelyRandomizedBlock({factor1List,factor2List,factor3List}, alpha));

NewLine();

Echo("F-Score of the block: ", anovaBlock["fScoreBlock"]);

ViewHtml(anovaBlock["html"]);

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side Effects:
      {"criticalFScoreBlock",3.325834530} {"fScoreBlock",0.08045614890} {"criticalFScore",4.102821015} {"fScore",3.078377024} {"meanSquareBlock",0.1418888884} {"meanSquareWithin",1.763555556} {"meanSquareBetween",5.428888905} {"sumOfSquaresTotal",29.20277781} {"sumOfSquaresBlock",0.7094444419} {"sumOfSquaresBetween",10.85777781} {"sumOfSquaresWithin'",17.63555556} {"html",java.lang.String} 
      
      F-Score of the block: 0.08045614890 
      
.   %/output


././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/CorrelationCoefficient.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/CorrelationCoefficient.0000644000175000017500000000251211502266107033732 0ustar  giovannigiovanni%mathpiper,def="CorrelationCoefficient"

CorrelationCoefficient(x,y) :=
[   
    Check(IsList(x), "Argument", "The first argument must be a list.");
    
    Check(IsList(y), "Argument", "The second argument must be a list.");
    
    Check(Length(x) = Length(y), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    Local(n);
        
    n := Length(x);
    
    N((n*Sum(x*y)-Sum(x)*Sum(y))/Sqrt((n*Sum(x^2)-(Sum(x))^2)*(n*Sum(y^2)-(Sum(y)^2))) );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="CorrelationCoefficient",categories="User Functions;Statistics & Probability",access="experimental"
*CMD CorrelationCoefficient --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	CorrelationCoefficient(xList,yList)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper

x := {4,3,5,2,3,4,3};
y := {83,86,92,78,82,95,80};

CorrelationCoefficient(x,y);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.7766185090
.   /%/output

*SEE CorrelationMatrix
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ChiSquareScoreToAlpha.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ChiSquareScoreToAlpha.m0000644000175000017500000000632311371733712033631 0ustar  giovannigiovanni%mathpiper,def="ChiSquareScoreToAlpha"

/* 
    This function was adapted from the Javascript version of function
    that is located here:
    
    http://www.fourmilab.ch/rpkp/experiments/analysis/chiCalc.js
    http://www.fourmilab.ch/rpkp/experiments/analysis/chiCalc.html
    
    The following JavaScript functions for calculating normal and
    chi-square probabilities and critical values were adapted by
    John Walker from C implementations
    written by Gary Perlman of Wang Institute, Tyngsboro, MA
    01879. Both the original C code and this JavaScript edition
    are in the public domain. 
*/


/*  POCHISQ  --  probability of chi-square value

          Adapted from:
                  Hill, I. D. and Pike, M. C.  Algorithm 299
                  Collected Algorithms for the CACM 1967 p. 243
          Updated for rounding errors based on remark in
                  ACM TOMS June 1985, page 185
*/

ChiSquareScoreToAlpha(score, degreesOfFreedom) :=
[
    Local(a, y, s, e, c, z, LogSqrtPi, ISqrtPi,result);                     
    
    y := 0;
    
    LogSqrtPi := 0.5723649429247000870717135; /* log(sqrt(pi)) */
    
    ISqrtPi := 0.5641895835477562869480795;   /* 1 / sqrt(pi) */
    
    if(score <= 0.0 Or degreesOfFreedom < 1) 
    [
        result := 1.0;
    ]
    else
    [
        a := N(0.5 * score);
        
        if (degreesOfFreedom > 1) 
        [
            y := If(-a < -20, 0, ExpN(-a));
        ];
        
        s := If(IsEven(degreesOfFreedom), y , (2.0 * ZScoreToProbability(-SqrtN(score))));
        
        if (degreesOfFreedom > 2) 
        [
            score := 0.5 * (degreesOfFreedom - 1.0);
            
            z := If(IsEven(degreesOfFreedom), 1.0, 0.5);
            
            if (a > 20) 
            [
                e := If(IsEven(degreesOfFreedom), 0.0, LogSqrtPi);
                
                c := LogN(a);
                
                While(z <= score) 
                [
                    e := LogN(z) + e;
                    s := s + If(c * z - a - e < -20, 0, ExpN(c * z - a - e));
                    z := z + 1.0;
                ];
                result := s;
            ] 
            else 
            [
                e := If(IsEven(degreesOfFreedom) , 1.0, (ISqrtPi / SqrtN(a)));
                
                c := 0.0;
                
                While(z <= score) 
                [
                    e := e * (a / z);
                    c := c + e;
                    z := z + 1.0;
                ];
                
                result := c * y + s;
            ];
        ]
        else
        [
            result := s;
        ];
    
    ];
    
    N(result);
];




%/mathpiper






%mathpiper_docs,name="ChiSquareScoreToAlpha",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ChiSquareScoreToAlpha --- calculates the alpha probability of a chi square score
*STD
*CALL
	ChiSquareScoreToAlpha(chiSquareScore, degreesOfFreedom)

*PARMS
{chiSquareScore} -- a chi square score
{degreesOfFreedom} -- the degrees of freedom

*DESC
This function calculates the alpha probability of a chi square score.

*E.G.
In> ChiSquareScoreToAlpha(7.779,4)
Result: 0.1000175159

*SEE AlphaToChiSquareScore, ChiSquareTest
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/WeightedMean.mpw0000644000175000017500000000253411502266107032403 0ustar  giovannigiovanni%mathpiper,def="WeightedMean"


WeightedMean(list) :=
[

    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Local( values, lastWeight, weights );
    
    values := {};
    
    weights := {};
    
    
    ForEach(element,list)
    [        
        Check(IsList(element), "Argument", "Values and their associated weights must be in a list.");
        
        Check(Length(element) = 2, "Argument", "Each value and its associated weight must be in a two element list.");
        
        values := values : element[1];

        weights := weights : element[2];
    ];
    
    Sum(values * weights)/Sum(weights);

];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="WeightedMean",categories="User Functions;Statistics & Probability",access="experimental"
*CMD WeightedMean --- weighted mean
*STD
*CALL 
	WeightedMean({{value, weight},...})

*PARMS

{value} -- a value.

{weight} -- the weight to associate with the value.

*DESC 
This function allows more weight to be associated with certain values and
less weight to others when calculating their mean.

*E.G.
In>  WeightedMean({{92,50}, {87,40}, {76,10}})
Result: 442/5

In>  N(WeightedMean({{92,50}, {87,40}, {76,10}}))
Result: 88.4

*SEE Mean, Median, Mode, GeometricMean
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/RegressionLine.mpw0000644000175000017500000000320511502266107032766 0ustar  giovannigiovanni%mathpiper,def="RegressionLine"

RegressionLine(x,y) :=
[   
    Check(IsList(x), "Argument", "The first argument must be a list.");
    
    Check(IsList(y), "Argument", "The second argument must be a list.");
    
    Check(Length(x) = Length(y), "Argument", "The lists for argument 1 and argument 2 must have the same length.");
    
    Local(n,a,b,xMean,yMean,line,result);
    
    n := Length(x);
    
    b := N((n*Sum(x*y) - Sum(x)*Sum(y))/(n*Sum(x^2)-(Sum(x))^2));
    
    xMean := N(Mean(x));
    
    yMean := N(Mean(y));
    
    a := N(yMean - b*xMean);
    
    line := a + b*Hold(x);
    
    result := {};
    
    result["xMean"] := xMean;
    
    result["yMean"] := yMean;
    
    result["line"] := line;
    
    result["yIntercept"] := a;
    
    result["slope"] := b;
    
    result["count"] := n;
    
    result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="RegressionLine",categories="User Functions;Statistics & Probability",access="experimental"
*CMD RegressionLine --- calculates the correlation coefficient between two lists of values
*STD
*CALL
	RegressionLine(xList,yList)

*PARMS

{xList} -- the list of domain values
{yList} -- the list of range values

*DESC
This function calculates the correlation coefficient between two lists of values.

*E.G.
/%mathpiper

x := {4,3,5,2,3,4,3};
y := {83,86,92,78,82,95,80};

RegressionLine(x,y);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.7766185090
.   /%/output
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/AnovaSingleFactor.mpw0000644000175000017500000002032311517224250033402 0ustar  giovannigiovanni%mathpiper,def="AnovaSingleFactor"

//Retract("AnovaSingleFactor",*);

AnovaSingleFactor(levelsList, alpha) :=
[
    Check(IsListOfLists(levelsList), "Argument", "The first argument must be a list of lists.");
    
    Check(alpha >= 0 And alpha <= 1, "Argument", "The second argument must be a number between 0 and 1.");
    
    Local(
        anovaTableRow1,
        anovaTableRow2,
        anovaTableRow3,
        anovaTableTotal,
        bottomOfAnova,
        bottomOfPage,
        bottomOfSummary,
        criticalFScore,
        degreesOfFreedomBetween,
        degreesOfFreedomWithin,
        fScore,
        grandMean,
        htmlJavaString,
        index,
        lengthsList,
        meansList,
        meanSquareBetween,
        meanSquareWithin,
        result,
        summaryTableRow,
        summaryTableRows,
        sumOfSquaresBetween,
        sumOfSquaresTotal,
        sumOfSquaresWithin,
        sumsList,
        topOfAnova,
        topOfPage,
        topOfSummary,
        variancesList);

    meansList := {};
    
    variancesList := {};
    
    sumsList := {};
    
    lengthsList := {};
    
    ForEach(levelList, levelsList)
    [
        meansList := meansList : N(Mean(levelList));
        
        variancesList := variancesList : N(UnbiasedVariance(levelList));
        
        sumsList := sumsList : N(Sum(levelList));

        lengthsList := lengthsList : Length(levelList);
    ];
    
    sumOfSquaresWithin := Sum((lengthsList - 1) * variancesList);

    grandMean := N(Mean(Flatten(levelsList, "List")));
    
    sumOfSquaresBetween := Sum(lengthsList*(meansList - grandMean)^2);
    
    sumOfSquaresTotal := N(sumOfSquaresWithin + sumOfSquaresBetween);
    
    degreesOfFreedomBetween := (Length(levelsList)-1);
    
    degreesOfFreedomWithin := (ElementCount(levelsList) - Length(levelsList));
    
    meanSquareBetween := N(sumOfSquaresBetween/degreesOfFreedomBetween);
    
    meanSquareWithin := N(sumOfSquaresWithin/degreesOfFreedomWithin);
    
    fScore := N(meanSquareBetween/meanSquareWithin);
    
    criticalFScore := ProbabilityToFScore(degreesOfFreedomBetween, degreesOfFreedomWithin, 1-alpha);
    
    topOfPage :=
"
    
        
            Anova: Single Factor
        
        
        
";
    
    topOfSummary :=
"
            
    Anova: Single Factor
    
            
            
";

    
    summaryTableRows := "";
    
    summaryTableRow := "":Nl();
    
    index := 1;
    While(index <= Length(levelsList))
    [
        summaryTableRows := summaryTableRows : PatchString(summaryTableRow);
    
        index++;
    ];
    
    
    bottomOfSummary :=
"
            
    
                 
    Summary
          
                
                
      Level   Count  Sum   Mean   Variance  
                     
    
";
    


    topOfAnova :=
"
            
    
            
    
            
            
";

    
    
    anovaTableRow1 := PatchString("":Nl());
    
    anovaTableRow2 := PatchString("":Nl());
    
    anovaTableTotal := PatchString("");
    
    bottomOfAnova :=
"
            
    
                 
    ANOVA
          
                
                
      Source of Variation   Sum of Squares   Degrees of Freedom   Mean Square Between   F   F Critical  
                        
                  
      Total        
    
";


    
    bottomOfPage :=
"
                 
    
";
    
    htmlJavaString := JavaNew("java.lang.String",
                topOfPage : 
                topOfSummary : 
                summaryTableRows : 
                bottomOfSummary : 
                topOfAnova : 
                anovaTableRow1 : 
                anovaTableRow2 : 
                anovaTableTotal : 
                bottomOfAnova : 
                bottomOfPage);
                
                
                
     result := {};
     
     result["html"] := htmlJavaString;
     
     result["sumOfSquaresWithin"] := sumOfSquaresWithin;
     
     result["sumOfSquaresBetween"] := sumOfSquaresBetween;
     
     result["sumOfSquaresTotal"] := sumOfSquaresTotal;
     
     result["degreesOfFreedomBetween"] := degreesOfFreedomBetween;
     
     result["degreesOfFreedomWithin"] := degreesOfFreedomWithin;
     
     result["meanSquareBetween"] := meanSquareBetween;
     
     result["meanSquareWithin"] := meanSquareWithin;
     
     result["fScore"] := fScore;
     
     result["criticalFScore"] := criticalFScore;
     
     result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output









%mathpiper_docs,name="AnovaSingleFactor",categories="User Functions;Statistics & Probability",access="experimental"
*CMD AnovaSingleFactor --- performs an ANOVA single factor analysis

*CALL
	AnovaSingleFactor(listOfLists,alpha)

*PARMS
{listOfLists} -- a list which contains lists which contain the data to be analyzed

{alpha} -- the alpha value to use in the analysis.

*DESC
This function performs an ANOVA single factor analysis.  The various values that are
calculated during the analysis are returned in an association list and these
values are listed in the keys of the returned list (see the examples section).

If the {html} key is passed to the {ViewHtml} function, the results of the analysis
are displayed in a graphcs window as rendered HTML.

*E.G.
/%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

factor1List := {10.2,8.5,8.4,10.5,9.0,8.1};

factor2List := {11.6,12.0,9.2,10.3,9.9,12.5};

factor3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(anova := AnovaSingleFactor({factor1List,factor2List,factor3List}, alpha));

NewLine();

Echo("F-Score of the data: ", anova["fScore"]);

ViewHtml(anova["html"]);

/%/mathpiper

    /%output,preserve="false"
      Result: True
      
      Side Effects:
      {"criticalFScore",3.682320344} {"fScore",4.438993381} {"meanSquareWithin",1.22300000} 
      {"meanSquareBetween",5.428888905} {"degreesOfFreedomWithin",15} {"degreesOfFreedomBetween",2} 
      {"sumOfSquaresTotal",29.20277781} {"sumOfSquaresBetween",10.85777781} 
      {"sumOfSquaresWithin",18.34500000} {"html",java.lang.String} 
      
      F-Score of the data: 4.438993381 
      
.   /%/output

*SEE ViewHtml, ScheffeTest
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output









%mathpiper,scope="nobuild",subtype="manual_test"

alpha := .05;

factor1List := {10.2,8.5,8.4,10.5,9.0,8.1};

factor2List := {11.6,12.0,9.2,10.3,9.9,12.5};

factor3List := {8.1,9.0,10.7,9.1,10.5,9.5};

Echo(anova := AnovaSingleFactor({factor1List,factor2List,factor3List}, alpha));

Echo("F-Score of the data: ", anova["fScore"]);

ViewHtml(anova["html"]);

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side Effects:
      {"criticalFScore",3.682320344} {"fScore",4.438993381} {"meanSquareWithin",1.22300000} {"meanSquareBetween",5.428888905} {"degreesOfFreedomWithin",15} {"degreesOfFreedomBetween",2} {"sumOfSquaresTotal",29.20277781} {"sumOfSquaresBetween",10.85777781} {"sumOfSquaresWithin",18.34500000} {"html",java.lang.String} 
      F-Score of the data: 4.438993381 
      
.   %/output


././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/AlphaToChiSquareScore.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/AlphaToChiSquareScore.m0000644000175000017500000000515711371733712033635 0ustar  giovannigiovanni%mathpiper,def="AlphaToChiSquareScore",access="experimental"

/* 
    This function was adapted from the Javascript version of function
    that is located here:
    
    http://www.fourmilab.ch/rpkp/experiments/analysis/chiCalc.js
    http://www.fourmilab.ch/rpkp/experiments/analysis/chiCalc.html
    
    The following JavaScript functions for calculating normal and
    chi-square probabilities and critical values were adapted by
    John Walker from C implementations
    written by Gary Perlman of Wang Institute, Tyngsboro, MA
    01879. Both the original C code and this JavaScript edition
    are in the public domain. 
*/



/*  CRITCHI  --  Compute critical chi-square value to
                     produce given p.  We just do a bisection
                     search for a value within CHI_EPSILON,
                     relying on the monotonicity of pochisq().  
*/


AlphaToChiSquareScore(p, df) :=
[
    Local(ChiEpsilon, ChiMax, minchisq, maxchisq, chisqval, result);
    
    ChiEpsilon := 0.000001;   /* Accuracy of critchi approximation */
    
    ChiMax := 99999.0;        /* Maximum chi-square value */
    
    minchisq := 0.0;
    
    maxchisq := ChiMax;
    
    p := N(p);
    
    if( p <= 0.0 Or p >= 1.0)
    [
    
        if (p <= 0.0) 
        [
            result := maxchisq;
        ] 
        else 
        [
            if (p >= 1.0) 
            [
                result := 0.0;
            ];
        ];
    
    ]
    else
    [
        chisqval := N(df / SqrtN(p));
        
        /* fair first value */
        While ((maxchisq - minchisq) > ChiEpsilon) 
        [
            if (ChiSquareScoreToAlpha(chisqval, df) < p) 
            [
                maxchisq := chisqval;
            ] 
            else 
            [
                minchisq := chisqval;
            ];
            chisqval := (maxchisq + minchisq) * 0.5;
        ];
        
        result := chisqval;
    
    ];
    
    N(result);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="AlphaToChiSquareScore",categories="User Functions;Statistics & Probability",access="experimental"
*CMD AlphaToChiSquareScore --- calculates the chi square score of a given alpha probability
*STD
*CALL
	AlphaToChiSquareScore(alphaProbability, degreesOfFreedom)

*PARMS
{alphaProbability} -- an alpha probability
{degreesOfFreedom} -- the degrees of freedom

*DESC
This function calculates the chi square score of a given probability.

*E.G.
In> AlphaToChiSquareScore(.1,4)
Result: 7.779440287

*SEE ChiSquareScoreToProbability, ChiSquareTest
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ProbabilityToZScore.mpw0000644000175000017500000000426211517224250033752 0ustar  giovannigiovanni%mathpiper,def="ProbabilityToZScore"

/* 
    This function was adapted from the Javascript version of function
    that is located here:
    
    http://www.fourmilab.ch/rpkp/experiments/analysis/zCalc.js
    http://www.fourmilab.ch/rpkp/experiments/analysis/zCalc.html?
    
    The following JavaScript functions for calculating normal and
    chi-square probabilities and critical values were adapted by
    John Walker from C implementations
    written by Gary Perlman of Wang Institute, Tyngsboro, MA
    01879. Both the original C code and this JavaScript edition
    are in the public domain. 
*/


/* We just do a bisection
search for a value within CHI_EPSILON,
relying on the monotonicity of pochisq(). */

//Retract("ProbabilityToZScore",*);

ProbabilityToZScore(probability) :=
[
    Local(ZMAX,ZEPSILON,minimumZ,maximumZ,zValue,probabilityValue);
    
    probability := N(probability);
    
    Check(probability >= 0.0 And probability <= 1.0, "Argument", "The argument must be between 0 and 1.");
    
    ZMAX := 6; // Maximum �z value.
    
    ZEPSILON := 0.000001; /* Accuracy of z approximation */
    
    minimumZ := -ZMAX;
    
    maximumZ := ZMAX;
    
    zValue := 0.0;

    While ((maximumZ - minimumZ) > ZEPSILON) 
    [
        probabilityValue := ZScoreToProbability(zValue);
        
        if (probabilityValue > probability) 
        [
            maximumZ := zValue;
        ] 
        else 
        [
            minimumZ := zValue;
        ];
        
        zValue := (maximumZ + minimumZ) * 0.5;
    ];
    
    zValue;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ProbabilityToZScore",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ProbabilityToZScore --- calculates the z-score for a given probability
*STD
*CALL
	ProbabilityToZScore(probability)

*PARMS

{probability} -- a probability value

*DESC

This function calculates the z-score for a given probability.

*E.G.
In> ProbabilityToZScore(.90)
Result: 1.281551244

*SEE NormalDistribution,ZScoreToProbability,ValueToZScore,ZScoreToValue,ConfidenceLevelToZScore
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ControlChartConstants.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ControlChartConstants.m0000644000175000017500000000346711502266107034000 0ustar  giovannigiovanni%mathpiper,def="ControlChartConstants"

ControlChartConstants(n) :=
[   
    Check(n >= 2 And n <= 15, "Argument", "The argument n must be 2 <= n <= 20.");
    
    Local(result, table);
    
    result := {};
    
    n--;
    
    table := {
        {1.880, 1.128, 0.000, 3.267},
        {1.023, 1.693, 0.000, 2.574},
        {0.729, 2.059, 0.000, 2.282},
        {0.577, 2.326, 0.000, 2.114},
        {0.483, 2.534, 0.000, 2.004},
        {0.419, 2.704, 0.076, 1.924},
        {0.373, 2.847, 0.136, 1.864},
        {0.337, 2.970, 0.184, 1.816},
        {0.308, 3.078, 0.223, 1.777},
        {0.285, 3.173, 0.256, 1.744},
        {0.266, 3.258, 0.283, 1.717},
        {0.249, 3.336, 0.307, 1.693},
        {0.235, 3.407, 0.328, 1.672},
        {0.223, 3.472, 0.347, 1.653},
        {0.212, 3.532, 0.363, 1.637},
        {0.203, 3.588, 0.378, 1.622},
        {0.194, 3.640, 0.391, 1.608},
        {0.187, 3.689, 0.403, 1.597},
        {0.180, 3.735, 0.415, 1.585},
    };

    result["D4"] := table[n][4];
    
    result["D3"] := table[n][3];
    
    result["d2"] := table[n][2];
        
    result["A2"] := table[n][1];
    
    result;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="ControlChartConstants",categories="User Functions;Statistics & Probability"
*CMD ControlChartConstants --- returns the control chart constants A2 d2 D3 D4
*STD
*CALL
	ControlChartConstants(n)

*PARMS

{n} -- subgroup size (2 - 20)

*DESC
Returns the control chart constants $A_2, d_2, D_3, D_4$.

*E.G.
In> ControlChartConstants(2)
Result: {{"A2",1.880},{"d2",1.128},{"D3",0.000},{"D4",3.267}}

In> ControlChartConstants(2)["A2"]
Result: 1.880

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/SampleSizeForTheMean.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/SampleSizeForTheMean.mp0000644000175000017500000000221311517224250033631 0ustar  giovannigiovanni%mathpiper,def="SampleSizeForTheMean"

//Retract("SampleSizeForTheMean",*);

SampleSizeForTheMean(standardDeviation,confidenceLevel,marginOfError) :=
[
    Local(minimumSampleSize);
    
    zScore := ConfidenceLevelToZScore(confidenceLevel);
    
    minimumSampleSize := N(((zScore*standardDeviation)/marginOfError)^2);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="SampleSizeForTheMean",categories="User Functions;Statistics & Probability",access="experimental"
*CMD SampleSizeForTheMean --- calculates the sample size for the mean
*STD
*CALL
	SampleSizeForTheMean(standardDeviation,confidenceLevel,marginOfError)
*PARMS
{standardDeviation} -- the standard deviation of the sample
{confidenceLevel} -- the desired level of confidence
{marginOfError} -- the desired margin of error

*DESC
This function calculates the minimum sample size for the mean to provide
a specific margin of error for a given confidence level.

*E.G.
In> SampleSizeForTheMean(37.50,.95,8)
Result: 84.40706911
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StemAndLeaf.mpw0000644000175000017500000005206311371733712032174 0ustar  giovannigiovanni%mathpiper
//Obtained from http://math.uc.edu/~pelikan/probandstat/stem.htm


trunc(x):= [

  If(x < 0, s := -1, s := 1);
s* Floor(Abs(x));
];




intlabels(y1,y2,tnumint) := [
    diff :=y2-y1;
    x := intervals(diff,tnumint);
    bot := trunc(y1/x)*x;
  yy = bot;
  L = [];
  //i = 0;
  xx = 0;
  breakLoop := False;
  While (yy-x < y2 Or breakLoop = True) [
      L := Append(L, yy);
    yy := yy + x;
    //i++;
    xx++;
    If (xx > 100, breakLoop := True);
  ];
  L[i] = yy;
	L;
];




intervals(diff, NumCats) := [
    t4 := trunc(N(Ln(diff))) * 0.4342945;
  t4 = Power(10,t4);
  T := [];
  T := N(t4/10 : t4/5 : t4/2 : t4 : T);

  
  A := [];
  
  For (i := 0,i < 4, i++) [
      A := Append(A,trunc(diff/T[i]) +1);
  ];
  
  D := AbsN(10 - A[0]);
  
  index := 1;
  For (i := 1, i < 4, i++) 
  [
    if (A[i] <= 25) [
      if (A[i] > 2) [
      XX := AbsN(NumCats - A[i]);
	if (XX < D) [
        D := XX;
	  index = i+1;
	];
      ];
    ];
  ];
  T[index-1];
];





stemandleaf(x) :=
[
  Echo("Stem and Leaf Display");
  didzero := False;
   N := x.length;
  
  if (N<20)
    [
      tNumInt := 5;
    ] 
  else 
    [
      if (N < 100) 
	[
	  tNumInt := 10;
	] 
      else 
	[
	  if (N < 150) 
	    [
	      tNumInt := 15;
	    ] 
	  else
	    [
	      tNumInt := 20;
	    ];
	];
    ];
   theMax := x[N-1];
   theMin := x[0];
  alldone := False;
  if (theMax - theMin < 10) 
  [
     ratio := 1000/(theMax - theMin);
    ratio := Math.max(ratio,1000);
    ratio := trunc(Math.log(ratio) * 0.4342945);
    ratio := Math.pow(10,ratio);
    For ( i := 0, i < N , i++) 
      [
            x[i] := x[i] * ratio;
      ];
  ]
  else 
    [
      	ratio := 1;
    ];
   zcount := 0; 	
  theMin := x[0];
   abMin := Math.abs(theMin);
  theMax := x[N-1];
   Y := intervals(theMax-theMin,tNumInt);
   indexA := index +0;
  if (indexA= 2) 
    [
      Y := Y * 5;
       ncats :=5 ;
       newz := 1;
    ] 
  else 
    [
      if(indexA=3) 
	[
	  Y := Y * 2;
	   ncats := 2;
	] 
      else 
	[
	   ncats := 1;
	   newz := 0; 
	];
    ];

   cutoffs := intlabels(x[0], x[N-1], tNumInt);
  theMax := ratio * Round(theMax);
   nc := cutoffs.length;
   xx8:=0;
  While (cutoffs[nc-2] > theMax) 
    [
      nc--;
    ];
  theMax := cutoffs[nc-2];
  if (Y > AbsN(theMax)) 
    [
      nc++;
      While(Y > AbsN(theMax)) 
	[
	  xx8++;
	  if(xx8>100)[break;];
	  if (nc > Length(cutoffs)) 
	    [
	       temp := cutoffs[nc-2] - cutoffs[nc - 3];
	      temp := temp + cutoffs[nc-2];
	      cutoffs[nc-1] := temp;
	    ];
	  theMax := cutoffs[nc-1];
	  nc++;
	];
    ];
   base := trunc(theMax/Y);
   leftover := Round(theMax - base * Y);
  While (AbsN(leftover) > 10) 
    [
      leftover := AbsN(Round(leftover/10));
    ];
   theMax2 := Maximum(theMax,abMin);
   t4 := trunc(theMax2/base);
  t4 := trunc(N(Ln(t4) * .4342945));
  t4 := Power(10,t4);
   t3 := t4/10;
  if (indexA = 2) 
    [
      if (leftover >= 8)
	[
	   newz := 1;
	]
    else 
      [
	if (leftover >= 6)  
	  [
	     newz := 0;
	  ]
	else 
	  [
	    if (leftover >= 4) 
	      [
		 newz := 4;
	      ] 
	    else 
	      [
		if (leftover >= 2) 
		  [
		     newz := 3;
		  ] 
		else 
		  [
		     newz := 2; 
		  ];
	      ];
	  ];
      ];
    ]
  else 
    [
    if (indexA = 3) 
      [
	if (leftover >=5) 
	  [
	     newz := 1;
	  ] 
	else 
	  [
	     newz := 0;
	  ];
      ];
    ];
   start := False;
   LN := 1;
   LN2 := 0;
   nn := N;
   cur := cutoffs[nc-2];
   count := nc-2;
   base2 :=base;
   newline := True;
   stems := {base2};
   leaves := {""};

 
  For ( i := nn-1, i >= 0 , i--) 
    [
     it := x[i];
     dd := Round(it/t3) * t3;
     b := trunc(dd/t4);
     L := dd-t4*b;
    leftover := AbsN(Round(L/t3));
    While (leftover >= 10)
      [
	    leftover := Round(leftover/10);
      ];
    if (it >=0) 
      [
	     tt := t3;
      ]
    else 
      [
        tt := -t3;
      ];
      
     xz := b * t4 + leftover * tt;
     
    if (it<0)
      [
	    if (xz > 0 ) 
          [
            xz := xz * -1;
          ];
          xz := xz - .00001;
      ];
      
    if (xz=6)) Or ((indexA = 3) And (zcount >=3)) Or ((indexA = 1) And (zcount >1)) Or ((indexA = 4) And (zcount >1))) 
                 [
                    stems := Append(stems,"-" : ToString(base2));
                 ] 
                 else 
                 [
                        stems := Append(stems, ToString(base2));
                 ];
          ] 
          else 
          [
	            stems := Append(stems, ToString(base2));
          ];
	
	   ];//end While.
      
      
      ];//end if
      
    start := True;
    leftover := ToString(leftover);
    
    if (it>=0) 
      [
     
  leaves[LN2] := leftover : "" : leaves[LN2];
     
      ]
    else 
      [
            leaves[LN2] := leaves[LN2] : "" : leftover;
      ];
    ];
  
  For ( i := 0, i < N , i++) [
    x[i] := x[i] / ratio;
  ];
  

  Echo("Stems Leaves");
    For (i:=0, i

  
    Stem and Leaf Plot




  

  

      
    Stem and Leaf Plot
    


     This page contains JavaScript that will make a Stem-and-Leaf plot of the data you
paste or type into the text area below. Separate the different values by spaces, commas, or newlines
 as you enter them. Then hit the "Compute" button and your browser will open a new window and display the plot. When you are done looking at the new window minimize it or close it with controls from its pull-down menus.
    


    Note that Microsoft has implemented a different version of scripting language in their Internet Explorer browser. Very likely, the JavaScript program on this page will not work in Microsoft's browser. To the best of my knowledge, the script does work in Netscape's internet browser 3.0.
    



    




    
 The code in this page for the "hard" part of making the plot was borrowed from Lane's Hyperstat. All I've done is parsed the imput data differently.

    

    If you find errors in this program please send email:
      
    Stephan Pelikan
    



Last modified: Tue Sep 30 17:09:00 EDT 1997

  















%html

Minitab 




    

    
Section 2.6. http://www.math.binghamton.edu/arcones/327/2.6.html
    
  

    

First we use the yarn strength data. We find the boxplot of these data
MTB > Retrieve  'A:\YARNSTRG.MTW'.
Retrieving worksheet from file: A:\YARNSTRG.MTW
**************************************
A boxplot consists of a box, whiskers, and outliers. A line is drawn across 
the box at the median. By default, the bottom of the box is at the first
quartile (Q1), and the top is at the third quartile (Q3) value. The whiskers 
are the lines that extend from the top and bottom of the box to the adjacent 
values. The adjacent values are the lowest and highest observations that are 
still inside the region defined by the following limits:

      Lower Limit:   Q1 - 1.5 (Q3 - Q1)
      Upper Limit:   Q3 + 1.5 (Q3 - Q1)

Outliers are points outside of the lower and upper limits and are plotted 
with asterisks (*).
**************************************
MTB > boxplot c1


    
Using that
MTB > desc c1
                N     MEAN   MEDIAN   TRMEAN    STDEV   SEMEAN
Ln_YarnS      100   2.9238   2.8331   2.8982   0.9378   0.0938

              MIN      MAX       Q1       Q3
Ln_YarnS   1.1514   5.7978   2.2789   3.5732
We have that
Minimum=1.1514; Q1=2.2789; median=2.8331; Q3=3.5732; maximum=5.7978
In this case
Lower Limit:   Q1 - 1.5 (Q3 - Q1)= 2.2789-1.5(3.5732-2.2789)=0.8903
Upper Limit:   Q3 + 1.5 (Q3 - Q1)= 3.5732+1.5(3.5732-2.2789)=5.5146
The minimum is not an outlier, but the maximum is.
So, the lower whisker goes to the minimum. The upper whisker goes to
the biggest value in the data small than 5.5146. This value is  5.0904
Observe that
MTB > sort c1 c2
MTB > print c2


C2      
  1.1514   1.1535   1.3436   1.4328   1.4570   1.5059   1.5219   1.5305 
  1.6438   1.6787   1.7261   1.7837   1.7902   1.8926   1.8952   2.0813 
  2.0968   2.1232   2.1306   2.1381   2.1771   2.2163   2.2364   2.2671 
  2.2762   2.2872   2.3018   2.3459   2.3483   2.4016   2.4064   2.4190 
  2.4240   2.4822   2.5000   2.5238   2.5264   2.5326   2.5364   2.5453 
  2.5654   2.5724   2.5800   2.5813   2.6266   2.6537   2.6745   2.7243 
  2.7317   2.8243   2.8418   2.8732   2.9382   2.9394   2.9908   3.0027 
  3.0164   3.0693   3.0722   3.1166   3.1412   3.1860   3.1860   3.2108 
  3.2177   3.2217   3.3077   3.3770   3.4002   3.4217   3.4603   3.4743 
  3.4866   3.5017   3.5272   3.5886   3.6152   3.6162   3.6394   3.6398 
  3.6561   3.7043   3.7071   3.7782   3.8849   3.9821   4.0017   4.0022 
  4.0126   4.1251   4.3215   4.3389   4.4382   4.4563   4.5234   4.6315 
  4.6426   4.8444   5.0904   5.7978

Next, we draw the quantile graph in page 37:
MTB > set c2
DATA> 1:100
DATA> end
MTB > let c2=c2/101
MTB > sort c1 c3
MTB > Plot C3*C2;
SUBC>   Symbol;
SUBC>     Type 5.


    

Next, we get the stem-and leaf- for the strength yard data
******************************************************************
A stem-and-leaf display shows the distribution of a variable in much the
same way as a histogram.  However, the initial digits of each value are 
used to construct the display, so individual values can be read from the 
display. A stem-and-leaf display has three parts:

   The first column shows a cumulative count of the number of values on that
line or on lines toward the nearer edge.  (The line that contains the median 
shows a count of values on that line instead, enclosed in parentheses.)

   The second column of numbers holds the stems.

   The right-hand portion of the display holds the leaves.  Each leaf digit 
represents an individual value.  The initial digits of that value are the 
stem digits.  This is followed by the leaf digit.  Thus, a stem of 46 and a 
leaf of 2 could represent the number 462, or 46.2, or .00462.  The position 
of the decimal point is indicated by the UNIT of the leaf digit printed at 
the top of the display.
**************************************************

MTB > stemandleaf c1

Stem-and-leaf of Ln_YarnS  N  = 100
Leaf Unit = 0.10


    5    1 11344
   15    1 5556677788
   34    2 0011112222233344444
  (21)   2 555555555566677888999
   45    3 000011112223344444
   27    3 5556666677789
   14    4 00013344
    6    4 5668
    2    5 0
    1    5 7
Next, we find robust statistics for location and dispersion.
To find the 5 % trimmed mean we do:
MTB > descr c1

                N     MEAN   MEDIAN   TRMEAN    STDEV   SEMEAN
Ln_YarnS      100   2.9238   2.8331   2.8982   0.9378   0.0938

              MIN      MAX       Q1       Q3
Ln_YarnS   1.1514   5.7978   2.2789   3.5732
The trimmed mean is 2.8982
Alternatively, we could do:
MTB > sort c1 c2
MTB > delete 1,2,3,4,5,96,97,98,99,100 c2 
MTB > mean c2
   MEAN    =      2.8982
In this way, we can also find the 5 % trimmed standard deviation:
MTB > stdev c2
   ST.DEV. =     0.75951






%/html

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Sample.mpw0000644000175000017500000000160511517224250031260 0ustar  giovannigiovanni%mathpiper,def="Sample"

//Retract("Sample",*);

Sample(list, sampleSize) :=
[
    Check(IsList(list), "Argument", "The first argument must be a list.");
    
    Check(IsInteger(sampleSize) And sampleSize > 0, "Argument", "The second argument must be an integer which is greater than 0.");
    
    list := Shuffle(list);

    Take(list, sampleSize);
];

%/mathpiper





%mathpiper_docs,name="Sample",categories="User Functions;Statistics & Probability",access="experimental"
*CMD Sample --- takes a random sample of elements from a list
*STD
*CALL
	Sample(list,sampleSize)

*PARMS
{list} -- a list of elements
{sampleSize} -- the size of the sample to take from the list

*DESC
This function takes a random sample of items from a list and returns
a list which contains the sample.

*E.G.
In> Sample({a,b,c,d,e,f,g},3)
Result: {a,c,g}

%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/D2Value.mpw0000644000175000017500000000542011502266107031301 0ustar  giovannigiovanni%mathpiper,def="D2Value"

D2Value(k,n) :=
[
    Check(k >= 0 And k <= 15, "Argument", "The first argument k must be 0 <= k <= 15.");
    
    Check(n >= 2 And n <= 15, "Argument", "The second argument n must be 2 <= n <= 15.");
    
    n--;
    
    if(k = 0)
    [
        {1.128,1.693,2.059,2.326,2.534,2.704,2.847,2.970,3.078,3.173,3.259,3.336,3.407,3.472}[n];
    ]
    else
    [
        {
            {1.414, 1.912, 2.239, 2.481, 2.673, 2.830, 2.963, 3.078, 3.179, 3.269, 3.350, 3.424, 3.491, 3.553},
            {1.279, 1.805, 2.151, 2.405, 2.604, 2.768, 2.906, 3.025, 3.129, 3.221, 3.305, 3.380, 3.449, 3.513},
            {1.231, 1.769, 2.120, 2.379, 2.581, 2.747, 2.886, 3.006, 3.112, 3.205, 3.289, 3.366, 3.435, 3.499},
            {1.206, 1.750, 2.105, 2.366, 2.570, 2.736, 2.877, 2.997, 3.103, 3.197, 3.282, 3.358, 3.428, 3.492},
            {1.191, 1.739, 2.096, 2.358, 2.563, 2.730, 2.871, 2.992, 3.098, 3.192, 3.277, 3.354, 3.424, 3.488},
            {1.181, 1.731, 2.090, 2.353, 2.558, 2.726, 2.867, 2.988, 3.095, 3.189, 3.274, 3.351, 3.421, 3.486},
            {1.173, 1.726, 2.085, 2.349, 2.555, 2.723, 2.864, 2.986, 3.092, 3.187, 3.272, 3.349, 3.419, 3.484},
            {1.168, 1.721, 2.082, 2.346, 2.552, 2.720, 2.862, 2.984, 3.090, 3.185, 3.270, 3.347, 3.417, 3.482},
            {1.164, 1.718, 2.080, 2.344, 2.550, 2.719, 2.860, 2.982, 3.089, 3.184, 3.269, 3.346, 3.416, 3.481},
            {1.160, 1.716, 2.077, 2.342, 2.549, 2.717, 2.859, 2.981, 3.088, 3.183, 3.268, 3.345, 3.415, 3.480},
            {1.157, 1.714, 2.076, 2.340, 2.547, 2.716, 2.858, 2.980, 3.087, 3.182, 3.267, 3.344, 3.415, 3.479},
            {1.155, 1.712, 2.074, 2.344, 2.546, 2.715, 2.857, 2.979, 3.086, 3.181, 3.266, 3.343, 3.414, 3.479},
            {1.153, 1.710, 2.073, 2.338, 2.545, 2.714, 2.856, 2.978, 3.085, 3.180, 3.266, 3.343, 3.413, 3.478},
            {1.151, 1.709, 2.072, 2.337, 2.545, 2.714, 2.856, 2.978, 3.085, 3.180, 3.265, 3.342, 3.413, 3.478},
            {1.150, 1.708, 2.071, 2.337, 2.544, 2.713, 2.855, 2.977, 3.084, 3.179, 3.265, 3.342, 3.412, 3.477}
        }[k][n];
    ];
    
];



%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="D2Value",categories="User Functions;Statistics & Probability"
*CMD D2Value --- converts average range $\bar{R}$ into estimated standard deviation $\hat{\sigma}_x$
*STD
*CALL
	D2Value(k,n)

*PARMS

{k} -- the number of times each part was measured (sample size, 1 - 15) or 0 to obtain a d2 control limits constant
{n} -- the number of parts measured (number of samples, 2 - 15)

*DESC
Converts average range $\bar{R}$ into estimated standard deviation $\hat{\sigma}_x$.  If k is set to 0,
the d2 control limits constant is returned.

*E.G.
In> D2Value(4,7);
Result: 2.736

In> D2Value(0,2)
Result: 1.128
%/mathpiper_docs
././@LongLink0000000000000000000000000000016300000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceIntervalOfTheProportion.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceIntervalOfThe0000644000175000017500000000476711517224250033741 0ustar  giovannigiovanni%mathpiper,def="ConfidenceIntervalOfTheProportion"

//Retract("ConfidenceIntervalOfTheProportion",*);

ConfidenceIntervalOfTheProportion(numberOfSuccesses,sampleSize,confidenceLevel) :=
[
    Check(IsInteger(numberOfSuccesses) And numberOfSuccesses >= 0, "Argument", "The first argument must be an integer which is >=0");
    
    Check(IsInteger(sampleSize) And sampleSize >= 0, "Argument", "The second argument must be an integer which is >=0");
    
    Local(criticalZScore,approximateStandardErrorOfTheProportion,upperLimit,lowerLimit,resultList,proportion);
    
    resultList := {};
    
    criticalZScore := ConfidenceLevelToZScore(confidenceLevel);
    
    resultList["criticalZScore"] := criticalZScore;
    
    proportion := N(numberOfSuccesses/sampleSize);
    
    approximateStandardErrorOfTheProportion := Sqrt((proportion*(1 - proportion))/sampleSize);
    
    upperLimit := N(proportion + criticalZScore * approximateStandardErrorOfTheProportion);
    
    lowerLimit := N(proportion - criticalZScore * approximateStandardErrorOfTheProportion);
    
    If(InVerboseMode(),
        [
            Echo("Critical z-score: ", criticalZScore);
            
            Echo("Proportion: ", proportion);
            
            Echo("Standard error of the proportion: ", N(approximateStandardErrorOfTheProportion));
        ]);
    
    resultList["upperLimit"] := upperLimit;
    
    resultList["lowerLimit"] := lowerLimit;
    
    resultList;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ConfidenceIntervalOfTheProportion",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ConfidenceIntervalOfTheProportion --- calculates a confidence interval for a proportion
*STD
*CALL
	ConfidenceIntervalOfTheProportion(numberOfSuccesses,sampleSize,confidenceLevel)
*PARMS
{numberOfSuccesses} -- the number of successes in the sample
{sampleSize} -- the size of the sample
{confidenceLevel} -- the desired confidence level

*DESC

This function calculates a confidence interval for a proportion.  It returns an association list
which contains the lower limit, the upper limit, and the critical Z score.

*E.G.
In> ConfidenceIntervalOfTheProportion(110,175,.90)
Result: {{"lowerLimit",0.5684923463},{"upperLimit",0.6886505109},{"criticalZScore",1.644853952}}

*SEE ConfidenceIntervalOfTheMean, V, Assoc
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ValueToZScore.mpw0000644000175000017500000000163411517224250032546 0ustar  giovannigiovanni%mathpiper,def="ValueToZScore"

//Retract("ValueToZScore",*);

ValueToZScore(value,mean,standardDeviation) :=
[
    (value - mean)/standardDeviation;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ValueToZScore",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ValueToZScore --- calculates the z-score of a numerical value
*STD
*CALL
	ValueToZScore(numericalValue,mean,standardDeviation)

*PARMS

{numericalValue} -- a numerical value
{mean} -- the mean
{standardDeviation} -- the standard deviation

*DESC
This function calculates the z-score for a given numerical value.

*E.G.
In> N(ValueToZScore(4.74,5,.332))
Result: -0.7831325301

*SEE ZScoreToValue,ZScoreToProbability,ProbabilityToZScore,ConfidenceLevelToZScore
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000015500000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceIntervalOfTheMean.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/ConfidenceIntervalOfThe0000644000175000017500000001005311517224250033722 0ustar  giovannigiovanni%mathpiper,def="ConfidenceIntervalOfTheMean"

//Retract("ConfidenceIntervalOfTheMean",*);

ConfidenceIntervalOfTheMean(sampleMean,standardDeviation,standardDeviationIsKnown,sampleSize,confidenceLevel) :=
[
    Check(IsBoolean(standardDeviationIsKnown), "Argument", "The third argument must be True or False.");
    
    Local(criticalZScore,criticalTScore,standardErrorOfTheMean,upperLimitValue,lowerLimitValue,resultList);
    
    resultList := {};
    
    If(sampleSize >= 30 Or standardDeviationIsKnown = True,
    [
        criticalZScore := N(ConfidenceLevelToZScore(confidenceLevel));
        
        resultList["criticalZScore"] := criticalZScore;

        standardErrorOfTheMean := N(StandardErrorOfTheMean(standardDeviation,sampleSize));
        
        lowerLimitValue := N(sampleMean - criticalZScore * standardErrorOfTheMean);
        
        upperLimitValue := N(sampleMean + criticalZScore * standardErrorOfTheMean);

        
        If(InVerboseMode(),
            [
                Echo("Using the normal distribution.");
                
                Echo("Critical z-score: ", criticalZScore);
                
                Echo("Standard error of the mean: ", standardErrorOfTheMean);
            ]);
    ],
    [   
        criticalTScore := OneTailAlphaToTScore(sampleSize - 1, N((1 - confidenceLevel)/2));
        
        resultList["criticalTScore"] := criticalTScore;
        
        standardErrorOfTheMean := N(StandardErrorOfTheMean(standardDeviation,sampleSize));
        
        lowerLimitValue := N(sampleMean - criticalTScore * standardErrorOfTheMean);
        
        upperLimitValue := N(sampleMean + criticalTScore * standardErrorOfTheMean);
        
        
        If(InVerboseMode(),
            [
                Echo("Using the t-distribution.");
                
                Echo("Critical t-score: ", criticalTScore);
                
                Echo("Standard error of the mean: ", standardErrorOfTheMean);
            ]);
    
    ]);
    
    resultList["upperLimit"] := upperLimitValue;
    
    resultList["lowerLimit"] := lowerLimitValue;

    resultList;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ConfidenceIntervalOfTheMean",categories="User Functions;Statistics & Probability",access="experimental"
*CMD ConfidenceIntervalOfTheMean --- calculates a confidence interval
*STD
*CALL
	ConfidenceIntervalOfTheMean(sampleMean,standardDeviation,standardDeviationIsKnown,sampleSize,confidenceLevel)
*PARMS
{sampleMean} -- the mean of the sample
{standardDeviation} -- the standard deviation of the sample
{standardDeviationIsKnown} -- True or False
{sampleSize} -- the size of the sample
{confidenceLevel} -- the desired confidence level

*DESC
This function calculates a confidence interval for a mean.  It returns an association list
which contains the lower limit, the upper limit, and either the critical Z score or the t value.
If the sample size is <30 or {standardDeviationIsKnown} is False, then
Student's t-distribution is used during the calculation.

If the function is run in verbose mode, it returns additional information as a side effect.

*E.G.
In> result := ConfidenceIntervalOfTheMean(78.25,37.50,True,32,.90)
Result: {{"lowerLimit",67.34605578},{"upperLimit",89.15394422},{"criticalZScore",1.644853952}}

In> result["upperLimit"]
Result: 89.15394422

In> result := ConfidenceIntervalOfTheMean(78.25,37.50,False,25,.90)
Result: {{"lowerLimit",65.41838440},{"upperLimit",91.08161560},{"criticalTScore",1.710882080}}

In> result["criticalTScore"]
Result: 1.710882080

In> result := V(ConfidenceIntervalOfTheMean(78.25,37.50,True,32,.90))
Result: {{"lowerLimit",67.34605578},{"upperLimit",89.15394422},{"criticalZScore",1.644853952}}
Side Effects:
Using the normal distribution.
Critical Z-Score: 1.644853952 
Standard error of the mean: 6.629126073 

*SEE ConfidenceIntervalOfTheProportion, V, Assoc
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheMean.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/StandardErrorOfTheMean.0000644000175000017500000000176011517224250033616 0ustar  giovannigiovanni%mathpiper,def="StandardErrorOfTheMean"

//Retract("StandardErrorOfTheMean",*);

StandardErrorOfTheMean(sigma, sampleSize) :=
[
    Check(sigma > 0, "Argument", "The first argument must be a number which is greater than 0.");
    
    Check(IsInteger(sampleSize) And sampleSize > 0, "Argument", "The second argument must be an integer which is greater than 0.");
    
    sigma/Sqrt(sampleSize);
];

%/mathpiper





%mathpiper_docs,name="StandardErrorOfTheMean",categories="User Functions;Statistics & Probability",access="experimental"
*CMD StandardErrorOfTheMean --- calculates the standard error of the mean
*STD
*CALL
	StandardErrorOfTheMean(sigma,sampleSize)

*PARMS
{sigma} -- the standard deviation of the population
{sampleSize} -- the size of the sample

*DESC
This function calculates the standard error of the mean.

*E.G.
In> N(StandardErrorOfTheMean(1.44,2))
Result: 1.018233765

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/statistics/Mode.mpw0000644000175000017500000000246611502266107030732 0ustar  giovannigiovanni%mathpiper,def="Mode"

Mode(list) :=
[
    Check(Length(list) > 0 And IsNumericList(list), "Argument", "Argument must be a nonempty numeric list.");
    
    Local(noDuplicatesList, countsList, sortedList, highestCountsList, resultList);
    
    noDuplicatesList := RemoveDuplicates(list);
    
    countsList := {};
    
    ForEach(element, noDuplicatesList)
    [
        countsList := Append(countsList, {Count(list, element), element} );
    ];
    
    sortedList := HeapSort(countsList,Lambda({x,y},x[1] > y[1]));
    
    highestCountsList := Select(sortedList, Lambda({x},x[1] = sortedList[1][1]));
    
    resultList := MapSingle(Lambda({x},x[2]), highestCountsList);

];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Mode",categories="User Functions;Statistics & Probability",access="experimental"
*CMD Mode --- calculates the mode of a list of values
*STD
*CALL
	Mode(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the mode of a list of values.  The mode is the value
that occurs most frequently.

*E.G.
In> Mode({73,94,80,37,57,94,40,21,94,26})
Result: 94

*SEE Mean, WeightedMean, Median, Mode, GeometricMean
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/highschool/0000755000175000017500000000000011722677330027256 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/highschool/HighschoolForm.mpw0000644000175000017500000000067411517224250032714 0ustar  giovannigiovanni%mathpiper,def=""

//Retract("HighschoolForm",*);

HighschoolForm(expression) :=
[
    //Note: since := is at a higher precedence than :/, parentheses are needed.
    expression := (expression /: { (x_IsNegativeNumber) / _y <- [Echo(x,/,y);]});
    
    expression := (expression  /: {_z^((x_IsNegativeInteger)/y_IsNumber) <- {z,x,y}});
    
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/jas/0000755000175000017500000000000011722677331025705 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/jas/jas_test.mpw0000644000175000017500000000331711374701672030251 0ustar  giovannigiovanni%mathpiper,title=""
ring := Ring("Z(a,b,x,y) L"); 

gens := JavaCall(ring,"gens");

%/mathpiper

    %output,preserve="false"
      Result: {edu.jas.poly.GenPolynomial,edu.jas.poly.GenPolynomial,edu.jas.poly.GenPolynomial,edu.jas.poly.GenPolynomial,edu.jas.poly.GenPolynomial}
.   %/output



%mathpiper,title=""

ForEach(variable,gens)
[

    variableName := JavaToValue(JavaCall(variable,"toString"));
    
    Echo(variableName);
    
    If(Not IsNumber(variableName), MacroBind(variableName,MetaSet(variableName,"jas",variable)) );
    
];

f := 5*a*x + 5*b*x - 2*b*y - 2*a*y;

g := a-2;

%/mathpiper

    %output,preserve="false"
      Result: a-2
      
      Side Effects:
      1 
      a 
      b 
      x 
      y 
      
.   %/output






%mathpiper,title=""

IsJas(atom) :=
[
    If(MetaGet(atom,"jas") != Empty, True, False);

];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper,title=""

200 # a_IsInteger * b_IsJas <-- Echo("H");

201 # _a * b_IsJas <-- Echo("I");

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper,title=""

x := (xx/yy)/zz;

x:=(
  x/::Hold({
      (_a/_b)/_c <- (a)/(b*c),
      (-(_a/_b))/_c <- (-a)/(b*c),
      (_a/_b)*_c <- (a*c)/b,
      (_a*_b)^_m <- a^m*b^m,
      (_a/_b)^_m*_c <- (a^m*c)/b^m,
      _a*(_b+_c) <- a*b+a*c,
      (_b+_c)*_a <- a*b+a*c,
      (_b+_c)/_a <- b/a+c/a,
      _a*(_b-_c) <- a*b-a*c,
      (_b-_c)*_a <- a*b-a*c,
      (_b-_c)/_a <- b/a-c/a
 }));

%/mathpiper

    %output,preserve="false"
      Result: xx/(yy*zz)
.   %/output






%mathpiper,title=""

5*a*x;

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side Effects:
      H
      I
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/jfreechart/0000755000175000017500000000000011722677331027245 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/jfreechart/JFreeChartHistogram.mpw0000644000175000017500000000406511517224250033620 0ustar  giovannigiovanni  %mathpiper
  
  //Retract("JFreeChartHistogram",*);
  
  JFreeChartHistogram(data) :=
  [
      histogramDataset := JavaNew("org.jfree.data.statistics.HistogramDataset");
      doubleArray := JavaCall("java.lang.reflect.Array","newInstance","java.lang.Double",ToString(Length(data)) );
      x := 0;
      While(x < Length(data))
      [
          JavaCall("java.lang.reflect.Array","setDouble",doubleArray, x, data[x+1] );
      ];
  
  ];
  
  
  %/mathpiper

      %output,preserve="false"
        Result: True   JavaCall( JavaNew("java.lang.String","Hello"),"toUpperCase")    JavaCall("javax.swing.JOptionPane","showMessageDialog","null","hello")
.     %/output



%mathpiper,scope="nobuild",subtype="manual_test"

JFreeChartHistogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0});

%/mathpiper

    %output,preserve="false"
      Result: [Ljava.lang.Double;
.   %/output

Histogram({1.0, 1.1, 1.1, 1.2, 1.7, 2.2, 2.5, 4.0},line -> True, title -> "Test histogram");

JavaCall("java.lang.reflect.Array","setDouble",doubleArray, 0, 33.2);

JavaCall("java.lang.reflect.Array","newInstance","java.lang.Double","3");

 	private static IntervalXYDataset createDataset() {
		HistogramDataset dataset = new HistogramDataset();
		String samplesString = "16.375,16.375,17.125,16,14.375,17.25,16.625,16,17,17.25,17,15.875,16.625,16.125,17.125,16.875,16.375,16.375,16.875,17.125,17,16.75,17.25,17.125,15.375";
		String[] samples = samplesString.split(",");
		double[] values = new double[samples.length];
		int i = 0;
		for (String sample:samples) {
			values[i] = Float.parseFloat(sample);
			i++;
		}
		dataset.addSeries("Pile E", values, 20, 14.0, 20.0);
  
  
  
import org.jfree.chart.ChartFactory;
import org.jfree.chart.ChartPanel;
import org.jfree.chart.JFreeChart;
import org.jfree.chart.axis.NumberAxis;
import org.jfree.chart.plot.PlotOrientation;
import org.jfree.chart.plot.XYPlot;
import org.jfree.chart.renderer.xy.StandardXYBarPainter;
import org.jfree.chart.renderer.xy.XYBarRenderer;
import org.jfree.data.statistics.HistogramDataset;
import org.jfree.data.xy.IntervalXYDataset;
  
  
  
  


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/equations/0000755000175000017500000000000011722677330027137 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/equations/ManipEquations.mpw0000644000175000017500000000726611517224250032623 0ustar  giovannigiovanni%mathpiper

//Retract("IsEquation",*);

//Retract("*==",*);
//Retract("/==",*);
//Retract("+==",*);
//Retract("-==",*);
//Retract("==+",*);
//Retract("==-",*);

10 # IsEquation(expr_IsAtom) <-- False;
12 # IsEquation(_expr) <-- 
[
    Local(EL,res);
    EL  := FunctionToList(expr);
    res := (EL[1] = == ); 
];

10 # *==(_num,eqn_IsEquation) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( num * EL[2] ));
    RHS := Expand(Simplify( num * EL[3] ));
    LHS == RHS;
];

10 # *==(eqn_IsEquation,_num) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( num * EL[2] ));
    RHS := Expand(Simplify( num * EL[3] ));
    LHS == RHS;
];

10 # /==(eqn_IsEquation,_num) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( EL[2] / num ));
    RHS := Expand(Simplify( EL[3] / num ));
    LHS == RHS;
];

10 # +==(_num,eqn_IsEquation) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( EL[2] + num ));
    RHS := Expand(Simplify( EL[3] + num ));
    LHS == RHS;
];

10 # +==(eqn_IsEquation,_num) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( EL[2] + num ));
    RHS := Expand(Simplify( EL[3] + num ));
    LHS == RHS;
];

10 # -==(eqn_IsEquation,_num) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( EL[2] - num ));
    RHS := Expand(Simplify( EL[3] - num ));
    LHS == RHS;
];

10 # -==(_num,eqn_IsEquation) <-- 
[
    Local(EL,LHS,RHS);
    EL  := FunctionToList(eqn);
    LHS := Expand(Simplify( num - EL[2] ));
    RHS := Expand(Simplify( num - EL[3] ));
    LHS == RHS;
];

12 # ==+(eqn1_IsEquation,eqn2_IsEquation) <-- 
[
    Local(EL1,LHS,RHS,EL2);
    EL1 := FunctionToList(eqn1);
    EL2 := FunctionToList(eqn2);
    LHS := Expand(Simplify( EL1[2] + EL2[2] ));
    RHS := Expand(Simplify( EL1[3] + EL2[3] ));
    LHS == RHS;
];

12 # ==-(eqn1_IsEquation,eqn2_IsEquation) <-- 
[
    Local(EL1,LHS,RHS,EL2);
    EL1 := FunctionToList(eqn1);
    EL2 := FunctionToList(eqn2);
    LHS := Expand(Simplify( EL1[2] - EL2[2] ));
    RHS := Expand(Simplify( EL1[3] - EL2[3] ));
    LHS == RHS;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




///////////////////////////////////////////////////////////////////////////////

%mathpiper,scope="nobuild",subtype="manual_test"

Unbind(eqns,eq1,eq2,eq3,eq5,eq6,eq7,X,Y,solution);

/* Wade & Taylor, page 222, Example 2 */
//  Solve the pair of equations
//       2*x + 3*y == 7
//       3*x - 2*y == 4

eqns := { 2*x+3*y==7, 3*x-2*y==4 };
Tell(0,eqns);
NewLine();

// multiply each side of eqns[1] by 2:
eq1 := *==(2,eqns[1]);
// multiply each side of eqns[2] by 3:
eq2 := *==(3,eqns[2]);
Tell(1,eq1);
Tell(2,eq2);
NewLine();
// add the two equations together
eq3 := ==+(eq1,eq2);
Tell(Eq2+Eq3,eq3);
// solve eq3 for x
X := Solve(eq3,x);
Tell(4,X);
NewLine();

// now multiply each side of eqns[1] by 3:
eq5 := *==(3,eqns[1]);
// multiply each side of eqns[2] by 2:
eq6 := *==(2,eqns[2]);
Tell(5,eq5);
Tell(6,eq6);
NewLine();
// subtract eq6 from eq5
eq7 := ==-(eq5,eq6);
Tell(Eq5-Eq6,eq7);
// solve eq7 for y
Y := Solve(eq7,y);
Tell(8,Y);
NewLine();

solution := {X,Y};
Tell(9,solution);


%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side effects:
      << 0 >> eqns {2*x+3*y==7,3*x-2*y==4} 
      
      << 1 >> eq1 4*x+6*y==14 
      << 2 >> eq2 9*x-6*y==12 
      
      << Eq2+Eq3 >> eq3 13*x==26 
      << 4 >> X {x==2} 
      
      << 5 >> eq5 6*x+9*y==21 
      << 6 >> eq6 6*x-4*y==8 
      
      << Eq5-Eq6 >> eq7 13*y==13 
      << 8 >> Y {y==1} 
      
      << 9 >> solution {{x==2},{y==1}}
.   %/output





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/equations/Manipulate.mpw0000644000175000017500000000275411517224250031762 0ustar  giovannigiovanni%mathpiper,def="Manipulate"

//Retract("Manipulate",*);

Rulebase("Manipulate",{symbolicEquation});
HoldArgument("Manipulate",symbolicEquation);
10 # Manipulate(_symbolicEquation)_HasFunc(Eval(symbolicEquation), "==") <--
[
    Local(listForm, operator, operand, left, right, leftManipulated, rightManipulated, operandIndex, equationIndex, leftOrder, rightOrder);

    listForm := FunctionToList(symbolicEquation);
    
    operator := listForm[1];
    
    If(HasFunc(Eval(listForm[2]),"==" ), [operandIndex := 3; equationIndex := 2; ], [ operandIndex := 2; equationIndex := 3;]);
    
    operand := listForm[operandIndex];
    equation := Eval(listForm[equationIndex]);
    left := EquationLeft(equation);
    right := EquationRight(equation);
    
    If(operandIndex = 3, [ leftOrder := `({left,operand});rightOrder := `({right,operand});],  [leftOrder := `({operand,left}); rightOrder := `({operand,right});]);
    
    
    leftManipulated := ExpandBrackets(Simplify(Apply(ToString(operator), leftOrder)));
    rightManipulated := ExpandBrackets(Simplify(Apply(ToString(operator), rightOrder)));   
    
    leftManipulated == rightManipulated;

];

%/mathpiper



%mathpiper,scope="nobuild",subtype="manual_test"

Unbind(equ,a);

equ := y == m*x+b;
Tell(1, Manipulate(2*equ));
Tell(2, Manipulate(equ*2));
Tell(3, Manipulate(2/equ));
Tell(4, Manipulate(equ/2));
Tell(5, Manipulate(equ^2));

equ := Sqrt(a) == 3;
Tell(6, Manipulate(equ^2));

%/mathpiper



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/proposed/equations/SolveSetEqns.mpw0000644000175000017500000001131311517224250032245 0ustar  giovannigiovanni%mathpiper

LoadScriptOnce("proposed.rep/equations.mpi");

//Retract("SolveLinearSysViaMatrix",*);

//Retract("SolveLinearSystemViaGauss",*);

//Retract("CheckEquationSolution",*);



10 # SolveLinearSysViaMatrix( eqns_IsList, vars_IsList ) <--
[
    /*** NOTE: This function appears to be fully functional, and     */
    /***       gives correct answers, but                            */
    /***       needs some more work to get answers into desired form */ 

    Local(LE,LV,E,LHS,X,M,RHS,LL,eqn,row,ans,Det);
    If(InVerboseMode(),Tell(SolveLinearSysViaMatrix,{eqns,vars}));
    LE := Length(eqns);
    LV := Length(vars);
    E  := Assert() LE=LV;
    Check(E, "Argument", "Number of equations != Number of variables");
    
    LHS := {};
    RHS := {};
    X   := vars;
    M   := FillList(1,LE);
    ForEach(eqn,eqns) 
    [
        E   := FunctionToList(eqn);
        LL  := E[2];
        RHS := E[3]:RHS;
        row := Map("Coef",{FillList(LL,LE),X,M});
        LHS := row:LHS;   
    ];
    LHS := DestructiveReverse(LHS);
    RHS := DestructiveReverse(RHS);
    Det := Determinant(LHS);
    //Tell(det,Det);
    
    ans :=MatrixSolve(LHS,RHS);
];

12 # SolveLinearSysViaMatrix( _eqns, _vars ) <-- False;




10 # SolveLinearSystemViaGauss( eqns_IsList, vars_IsList ) <--
[
    /***** WARNING: This version is valid for TWO equations only *****/

    Local(LE,LV,E,E2,s,s1,s2,s3,ans);
    If(InVerboseMode(),Tell(SolveLinearSysViaGauss,{eqns,vars}));
    LE := Length(eqns);
    LV := Length(vars);
    E  := Assert() LE=LV;
    Check(E, "Argument", "Number of equations != Number of variables");
    
    If(InVerboseMode(),Tell(0,{LE,LV,E}));
    s  := Solve( eqns, vars )[1];
    If(InVerboseMode(),Tell(1,s));
    s1 := s[1];
    s2 := s[2];
    s3 := s[3];
    E2 := FunctionToList(s3);
    s2 := (s2 Where s3);
    s1 := (s1 Where s2 And s3);
    If( E2[2]=E2[3], ans:=Inconsistent-Set, ans:=List(s1,s2,s3));
    ans;
];

12 # SolveLinearSystemViaGauss( _eqns, _vars ) <-- False;




10 # CheckEquationSolution( eqn_IsEquation, soln_IsList ) <--
[
    Local(EL,LHS,RHS,L,svar,sval);
    If(InVerboseMode(),Tell(CheckOneEq,{eqn,soln}));
    EL   := FunctionToList(eqn);
    LHS  := Expand(Simplify( EL[2] ));
    RHS  := Expand(Simplify( EL[3] ));
    L    := FunctionToList(soln[1]);
    svar := L[2];
    sval := L[3];
    If( InVerboseMode(), [Tell(2,{LHS,RHS}); Tell(3,{svar,sval});]);
    V    := Eliminate(svar,sval,LHS);
    If(InVerboseMode(),Tell(4,V));
    V = RHS;
];

12 # CheckEquationSolution( eqns_IsList, solns_IsList ) <--
[
    Tell(CheckSetOfEqns,{eqns,solns});
    Check(False, "Unimplemented", "Not implemented yet");
];

14 # CheckEquationSolution( _eq, _soln ) <-- 
[
    Tell(CheckEqnLeftovers,{eq,soln});
    False;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




///////////////////////////////////////////////////////////////////////////////

%mathpiper,scope="nobuild",subtype="manual_test"

Unbind(eqns1,eqns2,eqns3,eqns4,eqns5,solution);

// --- Test the new solver for sets of linear equations ---

NewLine();

eqns1 := {2*x-2*y+z==(-7),3*x+y+2*z==(-2),5*x+3*y-3*z==(-7)};  //  3 eqns, 3 unknowns
Tell(Independent,eqns1);
solution := SolveLinearSysViaMatrix(eqns1,{x,y,z});
Tell(11,solution);
NewLine();

eqns2 := {3*x-2*y+z==1,x-y-z==2,6*x-4*y+2*z==3};  // 3 eqns, 3 unks, inconsistent
Tell(Inconsistent,eqns2);
solution := SolveLinearSysViaMatrix(eqns2,{x,y,z});
Tell(13,solution);
NewLine();

eqns3 := {2*x+3*y==12,3*x+2*y==12};  // 2 eqns, 2 unknown, independent
Tell(Independent,eqns3);
solution := SolveLinearSysViaMatrix(eqns3,{x,y});
Tell(15,solution);
NewLine();

eqns4 := {2*x+3*y==6,4*x+6*y==12};  // 2 eqns, 2 unknowns, dependent
Tell(Dependent,eqns4);
solution := SolveLinearSysViaMatrix(eqns4,{x,y});
Tell(17,solution);
NewLine();

eqns5 := {2*x+3*y==6,2*x+3*y==8};  // 2 eqns, 2 unknowns, parallel (inconsistent)
Tell(Inconsistent,eqns5);
solution := SolveLinearSysViaMatrix(eqns5,{x,y});
Tell(19,solution);
NewLine();

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side effects:
      << Independent >> eqns1 {2*x-2*y+z==(-7),3*x+y+2*z==(-2),5*x+3*y-3*z==(-7)} 
      << det >> Det -52 
      << 11 >> solution {-2,2,1} 
      
      << Inconsistent >> eqns2 {3*x-2*y+z==1,x-y-z==2,6*x-4*y+2*z==3} 
      << det >> Det 0 
      << 13 >> solution {Undefined,Infinity,Infinity} 
      
      << Independent >> eqns3 {2*x+3*y==12,3*x+2*y==12} 
      << det >> Det -5 
      << 15 >> solution {12/5,12/5} 
      
      << Dependent >> eqns4 {2*x+3*y==6,4*x+6*y==12} 
      << det >> Det 0 
      << 17 >> solution {Undefined,Undefined} 
      
      << Inconsistent >> eqns5 {2*x+3*y==6,2*x+3*y==8} 
      << det >> Det 0 
      << 19 >> solution {Infinity,Infinity}
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/0000755000175000017500000000000011722677336024751 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/IsComplex.mpw0000644000175000017500000000036611316266467027404 0ustar  giovannigiovanni%mathpiper,def="IsComplex"

/* All things you can request a real and imaginary part for are complex */
1 # IsComplex(x_IsRationalOrNumber)     <-- True;
2 # IsComplex(Complex(_r,_i)) <-- True;
3 # IsComplex(_x)             <-- False;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Im.mpw0000644000175000017500000000100411523200452026012 0ustar  giovannigiovanni%mathpiper,def="Im"

/* Imaginary parts */
110 # Im(Complex(_r,_i)) <-- i;
120 # Im(Undefined) <-- Undefined;
300 # Im(_x) <-- 0;

%/mathpiper



%mathpiper_docs,name="Im",categories="User Functions;Numbers (Complex)"
*CMD Im --- imaginary part of a complex number
*STD
*CALL
	Im(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the imaginary part of the complex number "x".

*E.G.

In> Im(5)
Result: 0;
In> Im(I)
Result: 1;
In> Im(Complex(3,4))
Result: 4;

*SEE Complex, Re
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Re.mpw0000644000175000017500000000076411523200452026027 0ustar  giovannigiovanni%mathpiper,def="Re"

/*Real parts */
110 # Re(Complex(_r,_i)) <-- r;
120 # Re(Undefined) <-- Undefined;
300 # Re(_x) <-- x;

%/mathpiper



%mathpiper_docs,name="Re",categories="User Functions;Numbers (Complex)"
*CMD Re --- real part of a complex number
*STD
*CALL
	Re(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the real part of the complex number "x".

*E.G.

In> Re(5)
Result: 5;
In> Re(I)
Result: 0;
In> Re(Complex(3,4))
Result: 3;

*SEE Complex, Im
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/om/0000755000175000017500000000000011722677336025364 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/om/om.mpw0000644000175000017500000000057311316266467026527 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( "Complex"  , "complex1","complex_cartesian" );
OMDef( "Re"       , "complex1","real"              );
OMDef( "Im"       , "complex1","imaginary"         );
OMDef( "Conjugate", "complex1","conjugate"         );
OMDef( "Arg"      , "complex1","argument"          );
OMDef( "IsComplex", mathpiper,"is_complex"           );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/ReII.mpw0000644000175000017500000000007211371733712026254 0ustar  giovannigiovanni%mathpiper,def="ReII"

ReII(_c) <-- NN(c)[1];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/IsNotComplex.mpw0000644000175000017500000000012111371733712030043 0ustar  giovannigiovanni%mathpiper,def="IsNotComplex"

IsNotComplex(x) := Not(IsComplex(x));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Arg.mpw0000644000175000017500000000204711523200452026166 0ustar  giovannigiovanni%mathpiper,def="Arg"

10 # Arg(Complex(Cos(_x),Sin(_x))) <-- x;
10 # Arg(x_IsZero) <-- Undefined;
15 # Arg(x_IsPositiveReal) <-- 0;
15 # Arg(x_IsNegativeReal) <-- Pi;
20 # Arg(Complex(r_IsZero,i_IsConstant)) <-- Sign(i)*Pi/2;
30 # Arg(Complex(r_IsPositiveReal,i_IsConstant)) <-- ArcTan(i/r);
40 # Arg(Complex(r_IsNegativeReal,i_IsPositiveReal)) <-- Pi+ArcTan(i/r);
50 # Arg(Complex(r_IsNegativeReal,i_IsNegativeReal)) <-- ArcTan(i/r)-Pi;

%/mathpiper



%mathpiper_docs,name="Arg",categories="User Functions;Numbers (Complex)"
*CMD Arg --- argument of a complex number
*STD
*CALL
	Arg(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the argument of "x". The argument is the angle
with the positive real axis in the Argand diagram, or the angle
"phi" in the polar representation $r * Exp(I*phi)$ of "x". The
result is in the range ($-Pi$, $Pi$], that is, excluding $-Pi$ but including $Pi$. The
argument of 0 is {Undefined}.

*E.G.

In> Arg(2)
Result: 0;
In> Arg(-1)
Result: Pi;
In> Arg(1+I)
Result: Pi/4;

*SEE Abs, Sign
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/ImII.mpw0000644000175000017500000000007211371733712026253 0ustar  giovannigiovanni%mathpiper,def="ImII"

ImII(_c) <-- NN(c)[2];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/II.mpw0000644000175000017500000000047211371733712025771 0ustar  giovannigiovanni%mathpiper,def="II"

//
// II is the imaginary number Sqrt(-1), and remains that way.
// The difference is it isn't converted to the form Complex(x,y).
//

10 # II^n_IsNegativeInteger <-- (-II)^(-n);
20 # (II^_n)_(IsEven(n) = True) <-- (-1)^(n>>1);
20 # (II^_n)_(IsOdd(n)  = True) <--  II*(-1)^(n>>1);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/IsComplexII.mpw0000644000175000017500000000011611371733712027610 0ustar  giovannigiovanni%mathpiper,def="IsComplexII"

IsComplexII(_c) <-- (ImII(c) != 0);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/NN.mpw0000644000175000017500000000053211371733712026000 0ustar  giovannigiovanni%mathpiper,def="NN"

LocalSymbols(complexReduce) [

  Bind(complexReduce,
    Hold(
    {
      Exp(x_IsComplexII) <- Exp(ReII(x))*(Cos(ImII(x))+II*Sin(ImII(x)))
    }));

  NN(_c) <--
  [
    Local(result);
    c := (c /:: complexReduce);
    result := Coef(Expand(c,II),II,{0,1});
    result;
  ];

]; //LocalSymbols(complexReduce)

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Magnitude.mpw0000644000175000017500000000014111316266467027405 0ustar  giovannigiovanni%mathpiper,def="Magnitude"

Function("Magnitude",{x}) [
	Sqrt(Re(x)^2 + Im(x)^2);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Conjugate.mpw0000644000175000017500000000122211523200452027366 0ustar  giovannigiovanni%mathpiper,def="Conjugate"

LocalSymbols(a,x)
[
Function("Conjugate",{a})
  Substitute(a,{{x},Type(x)="Complex"},{{x},Complex(x[1],-(x[2]))});
]; // LocalSymbols(a,x)

%/mathpiper



%mathpiper_docs,name="Conjugate",categories="User Functions;Numbers (Complex)"
*CMD Conjugate --- complex conjugate
*STD
*CALL
	Conjugate(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the complex conjugate of "x". The complex
conjugate of $a + I*b$ is $a - I*b$. This function assumes that all
unbound variables are real.

*E.G.

In> Conjugate(2)
Result: 2;
In> Conjugate(Complex(a,b))
Result: Complex(a,-b);

*SEE Complex, Re, Im
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/complex/Complex.mpw0000644000175000017500000000735011523200452027066 0ustar  giovannigiovanni%mathpiper,def="Complex"

0 # Complex(_r,i_IsZero) <-- r;
2 # Complex(Complex(_r1,_i1),_i2) <-- Complex(r1,i1+i2);
2 # Complex(_r1,Complex(_r2,_i2)) <-- Complex(r1-i2,r2);

6 # Complex(Undefined,_x) <-- Undefined;
6 # Complex(_x,Undefined) <-- Undefined;


/* Addition */

110 # Complex(_r1,_i1) + Complex(_r2,_i2) <-- Complex(r1+r2,i1+i2);
300 # Complex(_r,_i) + x_IsConstant <-- Complex(r+x,i);
300 # x_IsConstant + Complex(_r,_i) <-- Complex(r+x,i);

110 # - Complex(_r,_i) <-- Complex(-r,-i);

300 # Complex(_r,_i) - x_IsConstant <-- Complex(r-x,i);
300 # x_IsConstant - Complex(_r,_i) <-- Complex((-r)+x,-i);
111 # Complex(_r1,_i1) - Complex(_r2,_i2) <-- Complex(r1-r2,i1-i2);

/* Multiplication */
110 # Complex(_r1,_i1) * Complex(_r2,_i2) <-- Complex(r1*r2-i1*i2,r1*i2+r2*i1);
/* right now this is slower than above
110 # Complex(_r1,_i1) * Complex(_r2,_i2) <--
[	// the Karatsuba trick
	Local(A,B);
	A:=r1*r2;
	B:=i1*i2;
	Complex(A-B,(r1+i1)*(r2+i2)-A-B);
];
*/


// Multiplication in combination with complex numbers in the light of infinity
250 # Complex(r_IsZero,_i) * x_IsInfinity <-- Complex(0,i*x);
250 # Complex(_r,i_IsZero) * x_IsInfinity <-- Complex(r*x,0);
251 # Complex(_r,_i) * x_IsInfinity <-- Complex(r*x,i*x);

250 # x_IsInfinity * Complex(r_IsZero,_i) <-- Complex(0,i*x);
250 # x_IsInfinity * Complex(_r,i_IsZero) <-- Complex(r*x,0);
251 # x_IsInfinity * Complex(_r,_i) <-- Complex(r*x,i*x);


300 # Complex(_r,_i) * y_IsConstant <-- Complex(r*y,i*y);
300 # y_IsConstant * Complex(_r,_i) <-- Complex(r*y,i*y);

330 # Complex(_r,_i) * (y_IsConstant / _z) <-- (Complex(r*y,i*y))/z;
330 # (y_IsConstant / _z) * Complex(_r,_i) <-- (Complex(r*y,i*y))/z;


110 # x_IsConstant / Complex(_r,_i) <-- (x*Conjugate(Complex(r,i)))/(r^2+i^2);


300 # Complex(_r,_i) / y_IsConstant <-- Complex(r/y,i/y);

110 # (_x ^ Complex(_r,_i)) <-- Exp(Complex(r,i)*Ln(x));

110 # Sqrt(Complex(_r,_i)) <-- Exp(Ln(Complex(r,i))/2);
110 # (Complex(_r,_i) ^ x_IsRationalOrNumber)_(Not(IsInteger(x))) <-- Exp(x*Ln(Complex(r,i)));

// This is commented out because it used PowerN so (2*I)^(-10) became a floating-point number. Now everything is handled by binary algorithm below
//120 # Complex(r_IsZero,_i) ^ n_IsInteger <-- {1,I,-1,-I}[1+Modulo(n,4)] * i^n;

123 # Complex(_r, _i) ^ n_IsNegativeInteger <-- 1/Complex(r, i)^(-n);

124 # Complex(_r, _i) ^ (p_IsZero) <-- 1;	// cannot have Complex(0,0) here

125 # Complex(_r, _i) ^ n_IsPositiveInteger <--
[
	// use binary method
	Local(result, x);
	x:=Complex(r,i);
	result:=1;
	While(n > 0)
	[
		if ((n&1) = 1)
		[
		  result := result*x;
		];
		x := x*x;
		n := n>>1;
	];
	result;
];


/*[	// this method is disabled b/c it suffers from severe roundoff errors
  Local(rr,ii,count,sign);
  rr:=r^n;
  ii:=0;
  For(count:=1,count<=n,count:=count+2) [
    sign:=If(IsZero(Modulo(count-1,4)),1,-1);
    ii:=ii+sign*BinomialCoefficient(n,count)*i^count*r^(n-count);
    If(count I
Result: Complex(0,1);
In> 3+4*I
Result: Complex(3,4);
In> Complex(-2,0)
Result: -2;

*SEE Re, Im, I, Abs, Arg
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/0000755000175000017500000000000011722677327024271 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/SumFunc.mpw0000644000175000017500000000677211552552161026377 0ustar  giovannigiovanni%mathpiper,def="SumFunc"

LocalSymbols(c,d,expr,from,to,summand,sum,predicate,n,r,var,x) [

// Attempt to Sum series

Function() SumFunc(k,from,to,summand, sum, predicate );
Function() SumFunc(k,from,to,summand, sum);
HoldArgument(SumFunc,predicate);
HoldArgument(SumFunc,sum);
HoldArgument(SumFunc,summand);

// Difference code does not work
SumFunc(_sumvar,sumfrom_IsInteger,_sumto,_sumbody,_sum) <--
[
	// Take the given answer and create 2 rules, one for an exact match
	// for sumfrom, and one which will catch sums starting at a different
	// index and subtract off the difference

	`(40 # Sum(@sumvar,@sumfrom,@sumto,@sumbody )	<-- Eval(@sum) );
	`(41 # Sum(@sumvar,p_IsInteger,@sumto,@sumbody)_(p > @sumfrom)
	     <--
	     [
	          Local(sub);
		  (sub := Eval(ListToFunction({Sum,sumvar'arg,@sumfrom,p-1,sumbody'arg})));
		  Simplify(Eval(@sum) - sub );
             ]);
];

SumFunc(_sumvar,sumfrom_IsInteger,_sumto,_sumbody,_sum,_condition) <--
[

	`(40 # Sum(@sumvar,@sumfrom,@sumto,@sumbody)_(@condition)    <-- Eval(@sum) );
	`(41 # Sum(@sumvar,p_IsInteger,@sumto,@sumbody )_(@condition And p > @sumfrom)
	     <--
	     [
	          Local(sub);
		  `(sub := Eval(ListToFunction({Sum,sumvar'arg,@sumfrom,p-1,sumbody'arg})));
		  Simplify(Eval(@sum) - sub );
             ]);
];

// Some type of canonical form is needed so that these match when
// given in a different order, like x^k/k! vs. (1/k!)*x^k
// works !
SumFunc(_k,1,_n,_c + _d,
  Eval(ListToFunction({Sum,sumvar'arg,1,n,c})) +
  Eval(ListToFunction({Sum,sumvar'arg,1,n,d}))
);
SumFunc(_k,1,_n,_c*_expr,Eval(c*ListToFunction({Sum,sumvar'arg,1,n,expr})), IsFreeOf(k,c) );
SumFunc(_k,1,_n,_expr/_c,Eval(ListToFunction({Sum,sumvar'arg,1,n,expr})/c), IsFreeOf(k,c) );

// this only works when the index=1
// If the limit of the general term is not zero, then the series diverges
// We need something like IsUndefined(term), because this croaks when limit return Undefined
//SumFunc(_k,1,Infinity,_expr,Infinity,Eval(Abs(ListToFunction({Limit,sumvar'arg,Infinity,expr})) > 0));
SumFunc(_k,1,Infinity,1/_k,Infinity);

SumFunc(_k,1,_n,_c,c*n,IsFreeOf(k,c) );
SumFunc(_k,1,_n,_k, n*(n+1)/2 );
//SumFunc(_k,1,_n,_k^2, n*(n+1)*(2*n+1)/6 );
//SumFunc(_k,1,_n,_k^3, (n*(n+1))^2 / 4 );
SumFunc(_k,1,_n,_k^_p,(Bernoulli(p+1,n+1) - Bernoulli(p+1))/(p+1), IsInteger(p) );
SumFunc(_k,1,_n,2*_k-1, n^2 );
SumFunc(_k,1,_n,HarmonicNumber(_k),(n+1)*HarmonicNumber(n) - n );

// Geometric series! The simplest of them all ;-)
SumFunc(_k,0,_n,(r_IsFreeOf(k))^(_k), (1-r^(n+1))/(1-r) );

// Infinite Series
// this allows Zeta a complex argument, which is not supported yet
SumFunc(_k,1,Infinity,1/(_k^_d), Zeta(d), IsFreeOf(k,d) );
SumFunc(_k,1,Infinity,_k^(-_d), Zeta(d), IsFreeOf(k,d) );

SumFunc(_k,0,Infinity,_x^(2*_k+1)/(2*_k+1)!,Sinh(x) );
SumFunc(_k,0,Infinity,(-1)^k*_x^(2*_k+1)/(2*_k+1)!,Sin(x) );
SumFunc(_k,0,Infinity,_x^(2*_k)/(2*_k)!,Cosh(x) );
SumFunc(_k,0,Infinity,(-1)^k*_x^(2*_k)/(2*_k)!,Cos(x) );
SumFunc(_k,0,Infinity,_x^(2*_k+1)/(2*_k+1),ArcTanh(x) );
SumFunc(_k,0,Infinity,1/(_k)!,Exp(1) );
SumFunc(_k,0,Infinity,_x^_k/(_k)!,Exp(x) );
40 # Sum(_var,_from,Infinity,_expr)_( `(Limit(@var,Infinity)(@expr)) = Infinity) <-- Infinity;

SumFunc(_k,1,Infinity,1/BinomialCoefficient(2*_k,_k), (2*Pi*Sqrt(3)+9)/27 );
SumFunc(_k,1,Infinity,1/(_k*BinomialCoefficient(2*_k,_k)), (Pi*Sqrt(3))/9 );
SumFunc(_k,1,Infinity,1/(_k^2*BinomialCoefficient(2*_k,_k)), Zeta(2)/3 );
SumFunc(_k,1,Infinity,1/(_k^3*BinomialCoefficient(2*_k,_k)), 17*Zeta(4)/36 );
SumFunc(_k,1,Infinity,(-1)^(_k-1)/_k, Ln(2) );

];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Sum.mpw0000644000175000017500000000352111523200452025537 0ustar  giovannigiovanni%mathpiper,def="Sum"

/* Sums */


Rulebase("Sum",{sumvar'arg,sumfrom'arg,sumto'arg,sumbody'arg});




10  # Sum(_sumvar,sumfrom_IsNumber,sumto_IsNumber,_sumbody)_(sumfrom>sumto) <-- 0;

20 # Sum(_sumvar,sumfrom_IsNumber,sumto_IsNumber,_sumbody)_(sumto Sum({1,2,3})
Result> 6

In> Sum(1 .. 10);
Result: 55;

In> Sum(i, 1, 3, i^2);
Result: 14;

*SEE Product
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Subfactorial.mpw0000644000175000017500000000201711430141451027410 0ustar  giovannigiovanni%mathpiper,def="Subfactorial"

Function("Subfactorial",{n})
[
	n! * Sum(k,0,n,(-1)^(k)/k!);
];

30 # Subfactorial(n_IsList) <-- MapSingle("Subfactorial",n);

%/mathpiper



%mathpiper_docs,name="Subfactorial",categories="User Functions;Combinatorics"
*CMD Subfactorial  --- factorial and related functions
*CALL
	Subfactorial(m)

*PARMS
{m} -- integer

*DESC
The {Subfactorial} function can be interpreted as the  number of permutations of {m} objects in which no object 
appears in its natural place, also called "derangements." 

The factorial functions terminate and print an error message if the arguments are too large (currently the limit 
is $n < 65535$) because exact factorials of such large numbers are computationally expensive and most probably 
not useful. One can call {Internal'LnGammaNum()} to evaluate logarithms of such factorials to desired precision.

*E.G.
In> Subfactorial(10)
Result: 1334961;

*SEE BinomialCoefficient, Product, Gamma, ,! !!, ***,
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Minimum.mpw0000644000175000017500000000333211523200452026406 0ustar  giovannigiovanni%mathpiper,def="Minimum"

/*  this is disabled because some functions seem to implicitly define Min / Max with a different number of args, 
and then MathPiper is confused if it hasn't loaded all the Function() declarations beforehand.
FIXME
/// Min, Max with many arguments
*/

//Retract("Minimum", 1);
//Retract("Minimum", 2);
//Retract("Minimum", 3);

//Function() Minimum(list);

//Function() Minimum(l1, l2)

Function() Minimum(l1, l2, l3, ...);

10 # Minimum(_l1, _l2, l3_IsList) <-- Minimum(Concat({l1, l2}, l3));
20 # Minimum(_l1, _l2, _l3) <-- Minimum({l1, l2, l3});

10 # Minimum(l1_IsList,l2_IsList) <-- Map("Minimum",{l1,l2});

20 # Minimum(l1_IsRationalOrNumber,l2_IsRationalOrNumber) <-- If(l1 Minimum(2,3);
Result: 2;
In> Minimum({5,8,4});
Result: 4;

*SEE Maximum, Sum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Add.mpw0000644000175000017500000000133111523200452025460 0ustar  giovannigiovanni%mathpiper,def="Add"

Function() Add(val, ...);

10 # Add({}) <-- 0;
20 # Add(values_IsList) <--
[
   Local(i, sum);
   sum:=0;
   ForEach(i, values) [ sum := sum + i; ];
   sum;
];

// Add(1) should return 1
30 # Add(_value) <-- value;

%/mathpiper



%mathpiper_docs,name="Add",categories="User Functions;Series",access="private"
*CMD Add --- find sum of a list of values
*STD
*CALL
	Add(val1, val2, ...)
	Add({list})

*PARMS

{val1}, {val2} -- expressions

{{list}} -- list of expressions to add

*DESC

This function adds all its arguments and returns their sum. It accepts any
number of arguments. The arguments can be also passed as a list.

*E.G.

In> Add(1,4,9);
Result: 14;
In> Add(1 .. 10);
Result: 55;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/om/0000755000175000017500000000000011722677327024704 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/om/om.mpw0000644000175000017500000000207511320767174026042 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
// [2005-12-28 matmota]: I have to implement some better solution for the
// MathPiper -> OM mapping for these symbols.
OMDef( "Minimum", "minmax1","min",
       { "", "",
         1,2,3,4,5,6,7,8,9,10,11,12,13,14,
         "", "" },
       ($):_1 );
OMDef( "Maximum", "minmax1","max",
       { "", "",
         1,2,3,4,5,6,7,8,9,10,11,12,13,14,
         "", "" },
       ($):_1 );
OMDef( "!", "integer1","factorial" );
OMDef( "BinomialCoefficient", "combinat1","binomial" );
OMDef( "!!",  mathpiper,"double_factorial" );
OMDef( "***", mathpiper,"partial_factorial" );
OMDef( "Add", mathpiper,"Add" );
OMDef( "Sum", "arith1","sum", // Same argument reordering as Integrate.
       { $, _2 .. _3, OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) },
       { $, _{2,2,1}, _{1,1}, _{1,2}, _{2,3} }
      );
OMDef( "Product", mathpiper,"Product" );
OMDef( "Taylor",    mathpiper,"Taylor" );
OMDef( "Subfactorial", mathpiper,"Subfactorial" );


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Taylor.mpw0000644000175000017500000000541511523200452026251 0ustar  giovannigiovanni%mathpiper,def="Taylor"

/*COMMENT FROM AYAL: Jitse, I added some code to make Taylor2 work in the most general case too I believe.
  Could you check to see if you agree with my changes? If that is correct, perhaps we can start calling Taylor2
  by default in stead of Taylor1.
 */
Function("Taylor",{taylorvariable,taylorat,taylororder,taylorfunction})
  Taylor1(taylorvariable,taylorat,taylororder)(taylorfunction);

/*COMMENT FROM AYAL: this is the old slow but working version of Taylor series expansion. Jitse wrote a
 * faster version which resides in taylor.mpi, and uses lazy power series. This slow but correct version is still
 * useful for tests (the old and the new routine should yield identical results).
 */
Function("Taylor1",{taylorvariable,taylorat,taylororder,taylorfunction})
[
  Local(n,result,dif,polf);
  [
    MacroLocal(taylorvariable);
    [
      MacroLocal(taylorvariable);
      MacroBind(taylorvariable, taylorat);
      result:=Eval(taylorfunction);
    ];
    If(result=Undefined,
    [
      result:=Apply("Limit",{taylorvariable,taylorat,taylorfunction});
    ]);
/*
    MacroBind(taylorvariable,taylorat);
    result:=Eval(taylorfunction);
*/
  ];
  dif:=taylorfunction;
  polf:=(taylorvariable-taylorat);
  For(n:=1,result != Undefined And n<=taylororder,n++)
  [
    dif:= Deriv(taylorvariable) dif;
    Local(term);
    MacroLocal(taylorvariable);
    [
      MacroLocal(taylorvariable);
      MacroBind(taylorvariable, taylorat);
      term:=Eval(dif);
    ];
    If(term=Undefined,
    [
      term:=Apply("Limit",{taylorvariable,taylorat,dif});
    ]);

    result:=result+(term/(n!))*(polf^n);
/*    result:=result+Apply("Limit",{taylorvariable,taylorat,(dif/(n!))})*(polf^n); */
/*
    MacroBind(taylorvariable,taylorat);
    result:=result+(Eval(dif)/(n!))*(polf^n);
*/
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="Taylor",categories="User Functions;Series"
*CMD Taylor --- univariate Taylor series expansion
*STD
*CALL
	Taylor(var, at, order) expr

*PARMS

{var} -- variable

{at} -- point to get Taylor series around

{order} -- order of approximation

{expr} -- expression to get Taylor series for

*DESC

This function returns the Taylor series expansion of the expression
"expr" with respect to the variable "var" around "at" up to order
"order". This is a polynomial which agrees with "expr" at the
point "var = at", and furthermore the first "order" derivatives of
the polynomial at this point agree with "expr". Taylor expansions
around removable singularities are correctly handled by taking the
limit as "var" approaches "at".

*E.G.

In> PrettyForm(Taylor(x,0,9) Sin(x))
	
	     3    5      7       9
	    x    x      x       x
	x - -- + --- - ---- + ------
	    6    120   5040   362880
	
Result: True;

*SEE D, InverseTaylor, ReversePoly, BigOh
%/mathpiper_docs././@LongLink0000000000000000000000000000015500000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/exclamationpoint_exclamationpoint_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/exclamationpoint_exclamationpoint_oper0000644000175000017500000000372311502266107034244 0ustar  giovannigiovanni%mathpiper,def="!!"

/// even/odd double factorial: product of even or odd integers up to n
1# (n_IsPositiveInteger)!! _ (n<=3) <-- n;
2# (n_IsPositiveInteger)!! <--
[
	Check(n<=65535, "Argument", "Double factorial: Error: the argument " : ( PipeToString() Write(n) ) : " is too large, you may want to avoid exact calculation");
	Factorial'double(2+Modulo(n, 2), n);
];
// special cases
3# (_n)!! _ (n= -1 Or n=0)<-- 1;

// the purpose of this mess "Quotient(a+b,2)+1+Modulo(Quotient(a+b,2)+1-a, 2)" is to obtain the smallest integer which is >= Quotient(a+b,2)+1 and is also odd or even when a is odd or even; we need to add at most 1 to (Quotient(a+b,2)+1)
2# Factorial'double(_a, _b) _ (b-a>=6) <-- Factorial'double(a, Quotient(a+b,2)) * Factorial'double(Quotient(a+b,2)+1+Modulo(Quotient(a+b,2)+1-a, 2), b);
3# Factorial'double(_a, _b) _ (b-a>=4) <-- a*(a+2)*(a+4);
4# Factorial'double(_a, _b) _ (b-a>=2) <-- a*(a+2);
5# Factorial'double(_a, _b) <-- a;

/// double factorial for lists is threaded
30 # (n_IsList)!! <-- MapSingle("!!",n);

%/mathpiper



%mathpiper_docs,name="!!",categories="Operators"
*CMD !!  --- double factorial operator

*CALL
    n!!

*PARMS
{n} -- integer, half-integer, or list

*DESC
The "double factorial" function {n!!} calculates $n*(n-2)*(n-4)*...$. 
This product terminates either with $1$ or with $2$ depending on 
whether $n$ is odd or even. If $n=0$ the function returns $1$.

The factorial functions are threaded, meaning that if the argument {n} is a
list, the function will be applied to each element of the list.

The factorial functions terminate and print an error message if the arguments are too large (currently the limit 
is $n < 65535$) because exact factorials of such large numbers are computationally expensive and most probably 
not useful. One can call {Internal'LnGammaNum()} to evaluate logarithms of such factorials to desired precision.
*E.G.
In> 7!!;
Result: 105;

*SEE BinomialCoefficient, Product, Gamma, !, ***, Subfactorial
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Maximum.mpw0000644000175000017500000000334111523200452026410 0ustar  giovannigiovanni%mathpiper,def="Maximum"

/*  this is disabled because some functions seem to implicitly define Min / Max with a different number of args, and then MathPiper is confused if it hasn't loaded all the Function() declarations beforehand.
FIXME
/// Min, Max with many arguments
*/

//Retract("Maximum", 1);
//Retract("Maximum", 2);
//Retract("Maximum", 3);

//Function() Maximum(list);

//Function() Maximum(l1, l2);

Function() Maximum(l1, l2, l3, ...);



10 # Maximum(_l1, _l2, l3_IsList) <-- Maximum(Concat({l1, l2}, l3));
20 # Maximum(_l1, _l2, _l3) <-- Maximum({l1, l2, l3});
/**/

10 # Maximum(l1_IsList,l2_IsList) <-- Map("Maximum",{l1,l2});


20 # Maximum(l1_IsRationalOrNumber,l2_IsRationalOrNumber) <-- If(l1>l2,l1,l2);


30 # Maximum(l1_IsConstant,l2_IsConstant) <-- If(N(Eval(l1-l2))>0,l1,l2);

// Max on empty lists
10 # Maximum({}) <-- Undefined;


20 # Maximum(list_IsList) <--
[
  Local(result);
  result:= list[1];
  ForEach(item,Rest(list)) result:=Maximum(result,item);
  result;
];


30 # Maximum(_x) <-- x;

%/mathpiper



%mathpiper_docs,name="Maximum",categories="User Functions;Numbers (Operations)"
*CMD Maximum --- maximum of a number of values
*STD
*CALL
	Maximum(x,y)
	Maximum(list)

*PARMS

{x}, {y} -- pair of values to determine the maximum of

{list} -- list of values from which the maximum is sought

*DESC

This function returns the maximum value of its argument(s). If the
first calling sequence is used, the larger of "x" and "y" is
returned. If one uses the second form, the largest of the entries in
"list" is returned. In both cases, this function can only be used
with numerical values and not with symbolic arguments.

*E.G.

In> Maximum(2,3);
Result: 3;
In> Maximum({5,8,4});
Result: 8;

*SEE Minimum, Sum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Taylor3.mpw0000644000175000017500000001150311331203122026321 0ustar  giovannigiovanni%mathpiper,def="Taylor3"



/* Taylor3, implementation of Taylor series expansion by doing calculation on series directly.
 */

Defun("Taylor3'MultiplyCoefs",{coefs1,coefs2,degree})
[
  Local(result,i,j,jset,ilimit,jlimit);
  Bind(result, ArrayCreate(AddN(degree,1),0));
  Bind(i,1);
  Bind(ilimit,AddN(degree,2));
  While (Not IsEqual(i,ilimit))
  [
//Echo(coefs1,coefs2);
    Bind(j,1);
    Bind(jlimit,AddN(degree,SubtractN(3,i)));
    While (Not IsEqual(j,jlimit))
    [
      Bind(jset,AddN(i,SubtractN(j,1)));
//Echo("index = ",i+j-1);
      ArraySet(result,jset,ArrayGet(result,jset) + ArrayGet(coefs1,i)*ArrayGet(coefs2,j));
      Bind(j,AddN(j,1));
    ];
    Bind(i,AddN(i,1));
  ];
  result;
];


Bodied("Taylor3'TaylorCoefs",0);
10 # (Taylor3'TaylorCoefs(_var,_degree)(_var)) <--
[
  Local(result);
  Bind(result,ArrayCreate(degree+1,0));
  ArraySet(result,2, 1);
  result;
//Echo("degree = ",degree);
//  BaseVector(2,degree+1);
];
20 # (Taylor3'TaylorCoefs(_var,_degree)(_atom))_(IsFreeOf(var,atom))
   <--
   [
    Local(result);
    Bind(result,ArrayCreate(degree+1,0));
    ArraySet(result,1, atom);
    result;
//     atom*BaseVector(1,degree+1);
   ];
30 # (Taylor3'TaylorCoefs(_var,_degree)(_X + _Y))
   <--
   [
     Local(result,add,i);
     Bind(result,Taylor3'TaylorCoefs(var,degree)(X));
     Bind(add, Taylor3'TaylorCoefs(var,degree)(Y));
     For(i:=1,i<=degree+1,i++)
     [
       ArraySet(result,i,ArrayGet(result,i)+ArrayGet(add,i));
     ];
     result;
   ];

30 # (Taylor3'TaylorCoefs(_var,_degree)(_X - _Y))
   <--
   [
     Local(result,add,i);
     Bind(result,Taylor3'TaylorCoefs(var,degree)(X));
     Bind(add, Taylor3'TaylorCoefs(var,degree)(Y));
     For(i:=1,i<=degree+1,i++)
     [
       ArraySet(result,i,ArrayGet(result,i)-ArrayGet(add,i));
     ];
     result;
   ];

30 # (Taylor3'TaylorCoefs(_var,_degree)(   - _Y))
   <--
   [
     Local(result,add,i);
     Bind(result,Taylor3'TaylorCoefs(var,degree)(Y));
     For(i:=1,i<=degree+1,i++)
     [
       ArraySet(result,i,-ArrayGet(result,i));
     ];
     result;
   ];

30 # (Taylor3'TaylorCoefs(_var,_degree)(_X * _Y))
   <-- Taylor3'MultiplyCoefs(
         Taylor3'TaylorCoefs(var,degree)(X),
         Taylor3'TaylorCoefs(var,degree)(Y),
         degree);

30 # (Taylor3'TaylorCoefs(_var,_degree)((_X) ^ N_IsPositiveInteger))
  <--
[
  Local(result,factor);
  factor:=Taylor3'TaylorCoefs(var,degree)(X);
  result:=ArrayCreate(degree+1,0);
  result[1] := 1;
  //TODO@@@ optimize
  While(N>0)
  [
    result:=Taylor3'MultiplyCoefs(result,factor,degree);
    N--;
  ];
  result;
];

60 # Taylor3'UniFunction("Exp")     <-- True;
60 # Taylor3'CompCoeff("Exp", _n) <-- 1/n!;

80 # Taylor3'UniFunction("Ln")     <-- False; // False because this rule is only applicable for Ln(x+1)
80 # Taylor3'CompCoeff("Ln", 0) <-- 0;
81 # Taylor3'CompCoeff("Ln", _n) <-- (-1)^(n+1)/n;

90 # Taylor3'UniFunction("Sin")           <-- True;
90 # Taylor3'CompCoeff("Sin", n_IsOdd)  <-- (-1)^((n-1)/2) / n!;
90 # Taylor3'CompCoeff("Sin", n_IsEven) <-- 0;

100 # Taylor3'UniFunction("Cos")           <-- True;
100 # Taylor3'CompCoeff("Cos", n_IsOdd)  <-- 0;
100 # Taylor3'CompCoeff("Cos", n_IsEven) <-- (-1)^(n/2) / n!;


210 # Taylor3'UniFunction(_any)_
      (
        [
          Local(result);
          result:= Deriv(var)ListToFunction({ToAtom(any),var});
          Type(result) != "Deriv";
        ]
      )           <--
      [
        True;
      ];
210 # Taylor3'CompCoeff(_any, n_IsInteger)
    <--
    [
      Limit(var,0)(Deriv(var,n)(ListToFunction({ToAtom(any),var}))/n!);
    ];



60000 # Taylor3'UniFunction(_any) <-- False;


Taylor3'FuncCoefs(_fname,_degree) <--
[
  Local(sins,i);
  Bind(sins, ArrayCreate(degree+1,0));
  For (i:=0,i<=degree,Bind(i,i+1))
  [
    ArraySet(sins,i+1, Taylor3'CompCoeff(fname,i));
  ];
  sins;
];


100 # (Taylor3'TaylorCoefs(_var,_degree)(Ln(_f)))_(Simplify(f-1) = var) <-- Taylor3'FuncCoefs("Ln",degree);


110 # (Taylor3'TaylorCoefs(_var,_degree)(f_IsFunction))_(ArgumentsCount(f) = 1 And (Taylor3'UniFunction(Type(f)))) <--
[
  Local(sins,i,j,result,xx,expr,sinfact);
  expr := f[1];
  sins:=Taylor3'FuncCoefs(Type(f),degree);
//Echo("sins = ",sins);
  expr:=Taylor3'TaylorCoefs(var,degree)expr;
  result:=ArrayCreate(degree+1,0);
  ArraySet(result,1, ArrayGet(sins,1));
  xx:=expr;
//Echo("8...",sins,expr);
  For (i:=2,i<=degree+1,i++)
  [
    Bind(sinfact,sins[i]);
//Echo("8.1..",i," ",j);
    For (j:=1,j<=degree+1,j++)
    [
      ArraySet(result,j,ArrayGet(result,j) + (ArrayGet(xx,j) * sinfact));
    ];
//Echo("8.2..");
    Bind(xx,Taylor3'MultiplyCoefs(xx,expr,degree));
//Echo("8.3..");
  ];
  result;
];


(Taylor3(_var,_degree)(_expr)) <-- Add((Taylor3'TaylorCoefs(var,degree)(expr))[1 .. degree+1]*var^(0 .. degree));
10 # (Taylor3(_x,  0, _n) _y) <--              Taylor3(x,n)              y;
20 # (Taylor3(_x, _a, _n) _y) <-- Subst(x,x-a) Taylor3(x,n) Subst(x,x+a) y;




%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Taylor2.mpw0000644000175000017500000006000711502266107026337 0ustar  giovannigiovanni%mathpiper,def="Taylor2"

/*
 * Taylor(x,a,n) y  ---  ENTRY POINT
 * ~~~~~~~~~~~~~~~
 * The n-th degree Taylor polynomial of y around x=a
 *
 * This function is implemented by doing calculus on power series.  For
 * instance, the Taylor series of Sin(x)^2 around x=0 is computed as
 * follows. First, we look up the series for Sin(x)
 *    Sin(x) = x - 1/6 x^3 + 1/120 x^5 - 1/5040 x^7 + ...
 * and then we compute the square of this series
 *    Sin(x)^2 = x^2 - x^4/3 + 2/45 x^6 - 1/315 x^8 + ...
 *
 * An alternative method is to use the formula
 *    Taylor(x,a,n) y = \sum_{k=0}^n 1/k! a_k x^k,
 * where a_k is the k-th order derivative of y with respect to x,
 * evaluated at x=a. In fact, the old implementation of "Taylor", which
 * is retained in obsolete.mpi, uses this method. However, we found out
 * that the expressions for the derivatives often grow very large, which
 * makes the computation too slow.
 *
 * The power series are implemented as lazy power series, which means
 * that the coefficients are computed on demand. Lazy power series are
 * encapsulated in expressions of the form
 *    Taylor'LPS(order, coeffs, var, expr).
 * This represent the power series of "expr", seen as a function of
 * "var". "coeffs" is list of coefficients that have been computed thus
 * far. The integer "order" is the order of the first coefficient.
 *
 * For instance, the expression
 *    Taylor'LPS(1, {1,0,-1/6,0}, x, Sin(x))
 * contains the power series of Sin(x), viewed as a function of x, where
 * the four coefficients corresponding to x, x^2, x^3, and x^4 have been
 * computed. One can view this expression as x - 1/6 x^3 + O(x^5).
 *
 * "coeffs" is the empty list in the following special cases:
 * 1) order = Infinity represents the zero power series
 * 2) order = Undefined represents a power series of which no
 *    coefficients have yet been computed.
 * 3) order = n represents a power series of order at least n,
 *    of which no coefficients have yet been computed.
 *
 * "expr" may contain subexpressions of the form
 *    Taylor'LPS'Add(lps1, lps2)       = lps1)x) + lps2(x)
 *    Taylor'LPS'ScalarMult(a, lps)    = a*lps(x)  (a is scalar)
 *    Taylor'LPS'Multiply(lps1, lps2)  = lps1(x) * lps2(x)
 *    Taylor'LPS'Inverse(lps)          = 1/lps(x)
 *    Taylor'LPS'Power(lps, n)         = lps(x)^n  (n is natural number)
 *    Taylor'LPS'Compose(lps1, lps2)   = lps1(lps2(x))
 *
 * A well-formed LPS is an expression of the form
 *    Taylor'LPS(order, coeffs, var, expr)
 * satisfying the following conditions:
 * 1) order is an integer, Infinity, or Undefined;
 * 2) coeffs is a list;
 * 3) if order is Infinity or Undefined, then coeffs is {};
 * 4) if order is an integer, then coeffs is empty
 *    or its first entry is nonzero;
 * 5) var does not appear in coeffs;
 * 6) expr is normalized with Taylor'LPS'NormalizeExpr.
 *
 */

/* For the moment, the function is called Taylor2. */

/* HELP: Is this the correct mechanism to signal incorrect input? */
/*COMMENT FROM AYAL: Formally, I would do it the other way around, although this is more efficient. This
  scheme says: all following rules hold if n>=0. Ideally you'd have a rule "this transformation rule holds
  if n>=0". But then you would end up checking that n>=0 for each transformation rule, making things a little
  bit slower (but more correct, more elegant).
  */
10 # (Taylor2(_x, _a, _n) _y)
   _ (Not(IsPositiveInteger(n) Or IsZero(n)))
   <-- Check(False, "Argument", "Third argument to Taylor should be a nonnegative integer");

20 # (Taylor2(_x, 0, _n) _y) <--
[
   Local(res);
   res := Taylor'LPS'PowerSeries(Taylor'LPS'Construct(x, y), n, x);
   If (ClearError("singularity"),
       Echo(y, "has a singularity at", x, "= 0."));
   If (ClearError("dunno"),
       Echo("Cannot determine power series of", y));
   res;
];

30 # (Taylor2(_x, _a, _n) _y)
   <-- Subst(x,x-a) Taylor2(x,0,n) Subst(x,x+a) y;

/**********************************************************************
 *
 * Parameters
 * ~~~~~~~~~~
 * The number of coefficients to be computed before concluding that a
 * given power series is zero */



/*TODO COMMENT FROM AYAL: This parameter, 15, seems to be a bit arbitrary. This implies that there is an input
   with more than 15 zeroes, and then a non-zero coefficient, that this would fail on. Correct? Is there not
   a more accurate estimation of this parameter?
 */
Taylor'LPS'Param1() := 15;

/**********************************************************************
 *
 * Taylor'LPS'Construct(var, expr)
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * construct a LPS
 * PRE:  var is a name
 * POST: returns a well-formed LPS
 */

10 # Taylor'LPS'Construct(_var, _expr)
   <-- Taylor'LPS(Undefined, {}, var,
                  Taylor'LPS'NormalizeExpr(var, expr));

/**********************************************************************
 *
 * Taylor'LPS'Coeffs(lps, n1, n2)
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * List of coefficients of order n1 up to n2
 * PRE:  lps is a well-formed LPS, n1 in Z, n2 in Z, n2 >= n1
 * POST: returns list of length n2-n1+1,
 *       or raises "dunno", "div-by-zero", or "maybe-div-by-zero"
 *       lps may be changed, but it's still a well-formed LPS
 */

Taylor'LPS'Coeffs(_lps, _n1, _n2) <--
[
   Local(res, finished, order, j, k, n, tmp, c1, c2);
   finished := False;

   /* Case 1: Zero power series */

   If (lps[1] = Infinity,
   [
      res := FillList(0, n2-n1+1);
      finished := True;
   ]);

   /* Case 2: Coefficients are already computed */

   If (Not finished And lps[1] != Undefined And n2 < lps[1]+Length(lps[2]),
   [
      If (n1 >= lps[1],
          res := Take(lps[2], {n1-lps[1]+1, n2-lps[1]+1}),
	  If (n2 >= lps[1],
              res := Concat(FillList(0, lps[1]-n1),
                             Take(lps[2], n2-lps[1]+1)),
	      res := FillList(0, n2-n1+1)));
      finished := True;
   ]);

   /* Case 3: We need to compute the coefficients */

   If (Not finished,
   [
      /* Subcase 3a: Expression is recognized by Taylor'LPS'CompOrder */

      order := Taylor'LPS'CompOrder(lps[3], lps[4]);
      If (Not ClearError("dunno"),
      [
         If (lps[1] = Undefined,
         [
	    lps[1] := order;
            If (order <= n2,
            [
               lps[2] := Table(Taylor'LPS'CompCoeff(lps[3], lps[4], n),
                               n, order, n2, 1);
            ]);
         ],[
	    tmp := Table(Taylor'LPS'CompCoeff(lps[3], lps[4], n),
                         n, lps[1]+Length(lps[2]), n2, 1);
	    lps[2] := Concat(lps[2], tmp);
         ]);
         finished := True;
      ]);

      /* Subcase 3b: Addition */

      If (Not finished And lps[4][0] = Taylor'LPS'Add,
      [
         lps[1] := Minimum(Taylor'LPS'GetOrder(lps[4][1])[1],
                       Taylor'LPS'GetOrder(lps[4][2])[1], n2);
         If (IsError("dunno"),
         [
            ClearError("dunno");
            ClearError("dunno");
	 ],[
   	    If (lps[1] <= n2,
            [
               c1 := Taylor'LPS'Coeffs(lps[4][1], lps[1] + Length(lps[2]), n2);
               c2 := Taylor'LPS'Coeffs(lps[4][2], lps[1] + Length(lps[2]), n2);
   	       lps[2] := Concat(lps[2], c1 + c2);
            ]);
   	    finished := True;
         ]);
      ]);

      /* Subcase 3c: Scalar multiplication */

      If (Not finished And lps[4][0] = Taylor'LPS'ScalarMult,
      [
         lps[1] := Minimum(Taylor'LPS'GetOrder(lps[4][2])[1], n2);
         If (Not ClearError("dunno"),
         [
   	    If (lps[1] <= n2,
            [
	       tmp := Taylor'LPS'Coeffs(lps[4][2],
                                        lps[1] + Length(lps[2]), n2);
	       tmp := lps[4][1] * tmp;
               lps[2] := Concat(lps[2], tmp);
            ]);
   	    finished := True;
         ]);
      ]);

      /* Subcase 3d: Multiplication */

      If (Not finished And lps[4][0] = Taylor'LPS'Multiply,
      [
         lps[1] := Taylor'LPS'GetOrder(lps[4][1])[1]
                   + Taylor'LPS'GetOrder(lps[4][2])[1];
         If (IsError("dunno"),
         [
            ClearError("dunno");
            ClearError("dunno");
	 ],[
   	    If (lps[1] <= n2,
            [
               c1 := Taylor'LPS'Coeffs(lps[4][1], lps[4][1][1],
                                       n2 - lps[4][2][1]);
               c2 := Taylor'LPS'Coeffs(lps[4][2], lps[4][2][1],
                                       n2 - lps[4][1][1]);
               tmp := lps[2];
	       ForEach(k, (Length(lps[2])+1) .. Length(c1))
	          tmp := Append(tmp, Sum(j, 1, k, c1[j]*c2[k+1-j]));
	       lps[2] := tmp;
            ]);
   	    finished := True;
         ]);
      ]);

      /* Subcase 3e: Inversion */

      If (Not finished And lps[4][0] = Taylor'LPS'Inverse,
      [
         If (lps[4][1][1] = Infinity,
	 [
	    Assert("div-by-zero") False;
	    finished := True;
	 ]);
	 If (Not finished And lps[2] = {},
         [
	    order := Taylor'LPS'GetOrder(lps[4][1])[1];
	    n := order;
	    c1 := Taylor'LPS'Coeffs(lps[4][1], n, n)[1];
	    While (c1 = 0 And n < order + Taylor'LPS'Param1())
            [
	       n := n + 1;
 	       c1 := Taylor'LPS'Coeffs(lps[4][1], n, n)[1];
	    ];
	    If (c1 = 0,
	    [
	       Assert("maybe-div-by-zero") False;
	       finished := True;
	    ]);
         ]);
	 If (Not finished,
	 [
	    lps[1] := -lps[4][1][1];
	    c1 := Taylor'LPS'Coeffs(lps[4][1], lps[4][1][1],
                                    lps[4][1][1]+n2-lps[1]);
	    tmp := lps[2];
	    If (tmp = {}, tmp := {1/c1[1]});
	    If (Length(c1)>1,
	    [
               ForEach(k, (Length(tmp)+1) .. Length(c1))
               [
	          n := -Sum(j, 1, k-1, c1[k+1-j]*tmp[j]) / c1[1];
	          tmp := Append(tmp, n);
               ];
	    ]);
	    lps[2] := tmp;
            finished := True;
	 ]);
      ]);

      /* Subcase 3f: Composition */

      If (Not finished And lps[4][0] = Taylor'LPS'Compose,
      [
	 j := Taylor'LPS'GetOrder(lps[4][1])[1];
	 Check(j >= 0, "Math", "Expansion of f(g(x)) where f has a"
                       : "singularity is not implemented");
	 k := Taylor'LPS'GetOrder(lps[4][2])[1];
         c1 := {j, Taylor'LPS'Coeffs(lps[4][1], j, n2)};
         c2 := {k, Taylor'LPS'Coeffs(lps[4][2], k, n2)};
	 c1 := Taylor'TPS'Compose(c1, c2);
	 lps[1] := c1[1];
	 lps[2] := c1[2];
	 finished := True;
      ]);

      /* Case 3: The end */

      If (finished,
      [
         /* normalization: remove initial zeros from lps[2] */

	 While (lps[2] != {} And lps[2][1] = 0)
	 [
	    lps[1] := lps[1] + 1;
	    lps[2] := Rest(lps[2]);
	 ];

	 /* get result */

	 If (Not IsError("dunno") And Not IsError("div-by-zero")
	     And Not IsError("maybe-div-by-zero"),
	 [
            If (lps[1] <= n1,
                res := Take(lps[2], {n1-lps[1]+1, n2-lps[1]+1}),
                If (lps[1] <= n2,
                    res := Concat(FillList(0, lps[1]-n1), lps[2]),
                    res := FillList(0, n2-n1+1)));
         ]);
      ],[
         Assert("dunno") False;
         res := False;
      ]);
   ]);

   /* Return res */

   res;
];


/**********************************************************************
 *
 * Truncated power series
 * ~~~~~~~~~~~~~~~~~~~~~~
 * Here is the start of an implementation of truncated power series.
 * This should be cleaned up.
 *
 * {n, {a0,a1,a2,a3,...}} represents
 * a0 x^n + a1 x^(n+1) + a2 x^(n+2) + a3 x^(n+3) + ...
 *
 * The function Taylor'TPS'Add(tps1, tps2) adds two of such beasts,
 * and returns the sum in the same truncated power series form.
 * Similar for the other functions.
 */

10 # Taylor'TPS'GetCoeff({_n,_c}, _k) _ (k < n) <-- 0;
10 # Taylor'TPS'GetCoeff({_n,_c}, _k) _ (k >= n+Length(c)) <-- Undefined;
20 # Taylor'TPS'GetCoeff({_n,_c}, _k) <-- c[k-n+1];


10 # Taylor'TPS'Add({_n1,_c1}, {_n2,_c2}) <--
[
   Local(n, len, c1b, c2b);
   n := Minimum(n1,n2);
   len := Minimum(n1+Length(c1), n2+Length(c2)) - n;
   c1b := Take(Concat(FillList(0, n1-n), c1), len);
   c2b := Take(Concat(FillList(0, n2-n), c2), len);
   {n, c1b+c2b};
];

10 # Taylor'TPS'ScalarMult(_a, {_n2,_c2}) <-- {n2, a*c2};

10 # Taylor'TPS'Multiply({_n1,_c1}, {_n2,_c2}) <--
[
   Local(j,k,c);
   c := {};
   For (k:=1, k<=Minimum(Length(c1), Length(c2)), k++)
   [
      c := c : Sum(j, 1, k, c1[j]*c2[k+1-j]);
   ];
   {n1+n2, c};
];

10 # Taylor'TPS'Compose({_n1,_c1}, {_n2,_c2}) <--
[
   Local(res, tps, tps2, k, n);
   n := Minimum(n1+Length(c1)-1, n2+Length(c2)-1);
   tps := {0, 1 : FillList(0, n)}; // tps = {n2,c2} ^ k
   res := Taylor'TPS'ScalarMult(Taylor'TPS'GetCoeff({n1,c1}, 0), tps);
   For (k:=1, k<=n, k++)
   [
      tps := Taylor'TPS'Multiply(tps, {n2,c2});
      tps2 := Taylor'TPS'ScalarMult(Taylor'TPS'GetCoeff({n1,c1}, k), tps);
      res := Taylor'TPS'Add(res, tps2);
   ];
   res;
];



/**********************************************************************
 *
 * Taylor'LPS'NormalizeExpr(var, expr)
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Return expr, with "+" replaced by Taylor'LPS'Add, etc.
 * PRE:  var is a name
 */

5 # Taylor'LPS'NormalizeExpr(_var, _e1)
  _ [Taylor'LPS'CompOrder(var,e1); Not ClearError("dunno");]
  <-- e1;

10 # Taylor'LPS'NormalizeExpr(_var, _e1 + _e2)
   <-- Taylor'LPS'Add(Taylor'LPS'Construct(var, e1),
                      Taylor'LPS'Construct(var, e2));

10 # Taylor'LPS'NormalizeExpr(_var, - _e1)
   <-- Taylor'LPS'ScalarMult(-1, Taylor'LPS'Construct(var, e1));

10 # Taylor'LPS'NormalizeExpr(_var, _e1 - _e2)
   <-- (Taylor'LPS'Add(Taylor'LPS'Construct(var, e1),
                       Taylor'LPS'Construct(var, e3))
        Where e3 == Taylor'LPS'ScalarMult(-1, Taylor'LPS'Construct(var, e2)));

10 # Taylor'LPS'NormalizeExpr(_var, e1_IsFreeOf(var) * _e2)
   <-- Taylor'LPS'ScalarMult(e1, Taylor'LPS'Construct(var, e2));

10 # Taylor'LPS'NormalizeExpr(_var, _e1 * e2_IsFreeOf(var))
   <-- Taylor'LPS'ScalarMult(e2, Taylor'LPS'Construct(var, e1));

20 # Taylor'LPS'NormalizeExpr(_var, _e1 * _e2)
   <-- Taylor'LPS'Multiply(Taylor'LPS'Construct(var, e1),
                           Taylor'LPS'Construct(var, e2));

10 # Taylor'LPS'NormalizeExpr(_var, _e1 / e2_IsFreeOf(var))
   <-- Taylor'LPS'ScalarMult(1/e2, Taylor'LPS'Construct(var, e1));

20 # Taylor'LPS'NormalizeExpr(_var, 1 / _e1)
   <-- Taylor'LPS'Inverse(Taylor'LPS'Construct(var, e1));

30 # Taylor'LPS'NormalizeExpr(_var, _e1 / _e2)
   <-- (Taylor'LPS'Multiply(Taylor'LPS'Construct(var, e1),
                            Taylor'LPS'Construct(var, e3))
        Where e3 == Taylor'LPS'Inverse(Taylor'LPS'Construct(var, e2)));

/* Implement powers as repeated multiplication,
 * which is seriously inefficient.
 */
10 # Taylor'LPS'NormalizeExpr(_var, _e1 ^ (n_IsPositiveInteger))
   _ (e1 != var)
   <-- Taylor'LPS'Multiply(Taylor'LPS'Construct(var, e1),
                           Taylor'LPS'Construct(var, e1^(n-1)));

10 # Taylor'LPS'NormalizeExpr(_var, Tan(_x))
   <-- (Taylor'LPS'Multiply(Taylor'LPS'Construct(var, Sin(x)),
                            Taylor'LPS'Construct(var, e3))
        Where e3 == Taylor'LPS'Inverse(Taylor'LPS'Construct(var, Cos(x))));

LocalSymbols(res)
[
50 # Taylor'LPS'NormalizeExpr(_var, _e1)
_[
    Local(c, lps1, lps2, lps3, success);
    success := True;
    If (IsAtom(e1), success := False);
    If (success And Length(e1) != 1, success := False);
    If (success And IsAtom(e1[1]), success := False);
    If (success And CanBeUni(var, e1[1]) And Degree(e1[1], var) = 1,
    [
       success := False;
    ]);
    If (success,
    [
       lps2 := Taylor'LPS'Construct(var, e1[1]);
       c := Taylor'LPS'Coeffs(lps2, 0, 0)[1];
       If (IsError(),
       [
          ClearErrors();
	  success := False;
       ]);
       If (success And Taylor'LPS'GetOrder(lps2)[1] < 0,
       [
          success := False;
       ],[
          If (c = 0,
          [
             lps1 := Taylor'LPS'Construct(var, Apply(e1[0], {var}));
             res := Taylor'LPS'Compose(lps1, lps2);
          ],[
             lps1 := Taylor'LPS'Construct(var, Apply(e1[0], {var+c}));
             lps3 := Taylor'LPS'Construct(var, -c);
	     lps2 := Taylor'LPS'Construct(var, Taylor'LPS'Add(lps2, lps3));
             res := Taylor'LPS'Compose(lps1, lps2);
          ]);
       ]);
    ]);
    success;
 ] <-- res;
];

60000 # Taylor'LPS'NormalizeExpr(_var, _e1) <-- e1;


/**********************************************************************
 *
 * Taylor'LPS'CompOrder(var, expr)  ---  HOOK
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Compute order of expr as a power series in var
 * PRE:  var is a name
 * POST: returns an integer, or raises "dunno"
 *
 * Taylor'LPS'CompCoeff(var, expr, n)  ---  HOOK
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Compute n-th coefficient of expr as a power series in var
 * PRE:  var is a name, n is an integer,
 *       Taylor'LPS'CompOrder(var, expr) does not raise "dunno"
 * POST: returns an expression not containing var
 */

5  # Taylor'LPS'CompCoeff(_var, _expr, _n)
   _ (n < Taylor'LPS'CompOrder(var, expr))
   <-- 0;

/* Zero */

10 # Taylor'LPS'CompOrder(_x, 0) <-- Infinity;

/* Constant */

20 # Taylor'LPS'CompOrder(_x, e_IsFreeOf(x))     <-- 0;
20 # Taylor'LPS'CompCoeff(_x, e_IsFreeOf(x), 0)  <-- e;
21 # Taylor'LPS'CompCoeff(_x, e_IsFreeOf(x), _n) <-- 0;

/* Identity */

30 # Taylor'LPS'CompOrder(_x, _x)     <-- 1;
30 # Taylor'LPS'CompCoeff(_x, _x, 1)  <-- 1;
31 # Taylor'LPS'CompCoeff(_x, _x, _n) <-- 0;

/* Powers */

40 # Taylor'LPS'CompOrder(_x, _x^(k_IsPositiveInteger))     <-- k;
40 # Taylor'LPS'CompCoeff(_x, _x^(k_IsPositiveInteger), _k) <-- 1;
41 # Taylor'LPS'CompCoeff(_x, _x^(k_IsPositiveInteger), _n) <-- 0;

/* Sqrt */

50 # Taylor'LPS'CompOrder(_x, Sqrt(_y))
   _ (CanBeUni(x,y) And Degree(y,x) = 1 And Coef(y,x,0) != 0)
   <-- 0;

50 # Taylor'LPS'CompCoeff(_x, Sqrt(_y), 0)
   _ (CanBeUni(x,y) And Degree(y,x) = 1 And Coef(y,x,0) != 0)
   <-- Sqrt(Coef(y,x,0));

51 # Taylor'LPS'CompCoeff(_x, Sqrt(_y), _n)
   _ (CanBeUni(x,y) And Degree(y,x) = 1 And Coef(y,x,0) != 0) <--
[
   Local(j);
   Coef(y,x,0)^(1/2-n) * Product(j,0,n-1,1/2-j) * Coef(y,x,1)^n/n!;
];

/* Exp */

60 # Taylor'LPS'CompOrder(_x, Exp(_x))     <-- 0;
60 # Taylor'LPS'CompCoeff(_x, Exp(_x), _n) <-- 1/n!;

70 # Taylor'LPS'CompOrder(_x, Exp(_y))_(CanBeUni(x,y) And Degree(y,x) = 1)
   <-- 0;

70 # Taylor'LPS'CompCoeff(_x, Exp(_y), _n)_(CanBeUni(x,y) And Degree(y,x) = 1)
   <-- Exp(Coef(y,x,0)) * Coef(y,x,1)^n / n!;

/* Ln */

80 # Taylor'LPS'CompOrder(_x, Ln(_x+1))     <-- 1;
80 # Taylor'LPS'CompCoeff(_x, Ln(_x+1), _n) <-- (-1)^(n+1)/n;

/* Sin */

90 # Taylor'LPS'CompOrder(_x, Sin(_x))           <-- 1;
90 # Taylor'LPS'CompCoeff(_x, Sin(_x), n_IsOdd)  <-- (-1)^((n-1)/2) / n!;
90 # Taylor'LPS'CompCoeff(_x, Sin(_x), n_IsEven) <-- 0;

/* Cos */

100 # Taylor'LPS'CompOrder(_x, Cos(_x))           <-- 0;
100 # Taylor'LPS'CompCoeff(_x, Cos(_x), n_IsOdd)  <-- 0;
100 # Taylor'LPS'CompCoeff(_x, Cos(_x), n_IsEven) <-- (-1)^(n/2) / n!;

/* Inverse (not needed but speeds things up) */

110 # Taylor'LPS'CompOrder(_x, 1/_x)     <-- -1;
110 # Taylor'LPS'CompCoeff(_x, 1/_x, -1) <-- 1;
111 # Taylor'LPS'CompCoeff(_x, 1/_x, _n) <-- 0;


/*COMMENT FROM AYAL: Jitse, what do you think, fall-through defaulting to calculating the coefficient
  the hard way? Worst-case, if people define a taylor series in this module it is faster, otherwise it uses
  the old scheme that does explicit derivatives, which is slower, but still better than not returning a result
  at all? With this change the new taylor code is at least as good as the old code?

  The ugly part is obvious: instead of having a rule here that says "I work for the following input" I had to
  find out empirically what the "exclude list" is, eg. the input it will not work on. This because the system
  as it works currently yields "dunno", at which moment some other routine picks up.

  I think we can refactor this.
 */




Taylor'LPS'AcceptDeriv(_expr) <--
        (Contains({"ArcTan"},Type(expr)));
/*
        ( Type(Deriv(x)(expr)) != "Deriv"
         And Not Contains({
          "/","+","*","^","-","Sin","Cos","Sqrt","Ln","Exp","Tan"
          },Type(expr)));
*/

200 # Taylor'LPS'CompOrder(_x, (_expr))_(Taylor'LPS'AcceptDeriv(expr))
    <--
    [
//Echo("CompOrder for ",expr);
//      0; //generic case, assume zeroeth coefficient is non-zero.
      Local(n);
      n:=0;
      While ((Limit(x,0)expr) = 0 And n=0 ) <--
    [
    // This routine is written out for debugging purposes
      Local(result);
      result:=(Limit(x,0)(Deriv(x,n)expr))/(n!);
Echo(expr," ",n," ",result);
      result;
    ];

/* Default */

60000 # Taylor'LPS'CompOrder(_var, _expr)
      <-- Assert("dunno") False;

60000 # Taylor'LPS'CompCoeff(_var, _expr, _n)
      <-- Check(False, "Argument", "Taylor'LPS'CompCoeff'FallThrough"
                       : PipeToString() Write({var,expr,n}));

/**********************************************************************
 *
 * Taylor'LPS'GetOrder(lps)
 * ~~~~~~~~~~~~~~~~~~~~~~~~
 * Returns a pair {n,flag}. If flag is True, then n is the order of
 * the LPS. If flag is False, then n is a lower bound on the order.
 * PRE:  lps is a well-formed LPS
 * POST: returns a pair {n,flag}, where n is an integer or Infinity,
 *       and flag is True or False, or raises "dunno";
 *       may update lps.
 */

20 # Taylor'LPS'GetOrder(Taylor'LPS(_order, _coeffs, _var, _expr))
   _ (order != Undefined)
   <-- {order, coeffs != {}};

40 # Taylor'LPS'GetOrder(_lps) <--
[
   Local(res, computed, exact, res1, res2);
   computed := False;

   res := Taylor'LPS'CompOrder(lps[3], lps[4]);
   If (Not ClearError("dunno"),
   [
      res := {res, True};
      computed := True;
   ]);

   If (Not computed And lps[4][0] = Taylor'LPS'Add,
   [
      res1 := Taylor'LPS'GetOrder(lps[4][1]);
      If (Not ClearError("dunno"),
      [
         res2 := Taylor'LPS'GetOrder(lps[4][2]);
         If (Not ClearError("dunno"),
	 [
	    res := {Minimum(res1[1],res2[1]), False};
	    /* flag = False, since terms may cancel */
	    computed := True;
	 ]);
      ]);
   ]);

   If (Not computed And lps[4][0] = Taylor'LPS'ScalarMult,
   [
      res := Taylor'LPS'GetOrder(lps[4][2]);
      If (Not ClearError("dunno"), computed := True);
   ]);

   If (Not computed And lps[4][0] = Taylor'LPS'Multiply,
   [
      res1 := Taylor'LPS'GetOrder(lps[4][1]);
      If (Not ClearError("dunno"),
      [
         res2 := Taylor'LPS'GetOrder(lps[4][2]);
         If (Not ClearError("dunno"),
	 [
	    res := {res1[1]+res2[1], res1[1] And res2[1]};
	    computed := True;
	 ]);
      ]);
   ]);

   If (Not computed And lps[4][0] = Taylor'LPS'Inverse,
   [
      res := Taylor'LPS'GetOrder(lps[4][1]);
      If (Not ClearError("dunno"),
      [
         If (res[1] = Infinity,
	 [
	    res[1] = Undefined;
	    Assert("div-by-zero") False;
	    computed := True;
	 ]);
         If (Not computed And res[2] = False,
	 [
	    Local(c, n);
	    n := res[1];
	    c := Taylor'LPS'Coeffs(lps[4][1], res[1], res[1])[1];
	    While (c = 0 And res[1] < n + Taylor'LPS'Param1())
            [
	       res[1] := res[1] + 1;
 	       c := Taylor'LPS'Coeffs(lps[4][1], res[1], res[1])[1];
	    ];
	    If (c = 0,
	    [
	       res[1] := Undefined;
	       Assert("maybe-div-by-zero") False;
	       computed := True;
	    ]);
	 ]);
	 If (Not computed,
	 [
	    res := {-res[1], True};
	    computed := True;
	 ]);
      ]);
   ]);

   If (Not computed And lps[4][0] = Taylor'LPS'Compose,
   [
      res1 := Taylor'LPS'GetOrder(lps[4][1]);
      If (Not ClearError("dunno"),
      [
         res2 := Taylor'LPS'GetOrder(lps[4][2]);
         If (Not ClearError("dunno"),
	 [
	    res := {res1[1]*res2[1], res1[1] And res2[1]};
	    computed := True;
	 ]);
      ]);
   ]);

   If (computed, lps[1] := res[1]);
   Assert("dunno") computed;
   res;
];

/**********************************************************************
 *
 * Taylor'LPS'PowerSeries(lps, n, var)
 * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * Convert the LPS in a power series in var up to order n
 * PRE:  lps is a well-formed LPS, n is a natural number
 * POST: returns an expression, or raises "singularity" or "dunno"
 */

10 # Taylor'LPS'PowerSeries(_lps, _n, _var) <--
[
   Local(ord, k, coeffs);
   coeffs := Taylor'LPS'Coeffs(lps, 0, n);
   If (IsError("dunno"),
   [
      False;
   ],[
      If (lps[1] < 0,
      [
         Assert("singularity") False;
         Undefined;
      ],[
         Sum(k, 0, n, coeffs[k+1]*var^k);
      ]);
   ]);
];


%/mathpiper././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/asterisk_asterisk_asterisk_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/asterisk_asterisk_asterisk_operator.mp0000644000175000017500000000353211502266107034166 0ustar  giovannigiovanni%mathpiper,def="***"

/// partial factorial
n1_IsRationalOrNumber *** n2_IsRationalOrNumber <--
[
	Check(n2-n1 <= 65535, "Argument", "Partial factorial: Error: the range " : ( PipeToString() Write(n2-n1) ) : " is too large, you may want to avoid exact calculation");
	If(n2-n1<0,
		1,
		Factorial'partial(n1, n2)
	);
];

/// recursive routine to evaluate "partial factorial" a*(a+1)*...*b
// TODO lets document why the >>1 as used here is allowed (rounding down? What is the idea behind this algorithm?)
2# Factorial'partial(_a, _b) _ (b-a>=4) <-- Factorial'partial(a, a+((b-a)>>1)) * Factorial'partial(a+((b-a)>>1)+1, b);
3# Factorial'partial(_a, _b) _ (b-a>=3) <-- a*(a+1)*(a+2)*(a+3);
4# Factorial'partial(_a, _b) _ (b-a>=2) <-- a*(a+1)*(a+2);
5# Factorial'partial(_a, _b) _ (b-a>=1) <-- a*(a+1);
6# Factorial'partial(_a, _b) _ (b-a>=0) <-- a;
%/mathpiper




%mathpiper_docs,name="***",categories="Operators"
*CMD ***  --- partial factorial operator

*CALL
	a *** b

*PARMS
{a}, {b} -- numbers

*DESC
The "partial factorial" function {a *** b} calculates the product $a*(a+1)*...$ 
which is terminated at the least integer not greater than $b$. The arguments $a$ 
and $b$ do not have to be integers; for integer arguments, {a *** b} = $b! / (a-1)!$. 
This function is sometimes a lot faster than evaluating the two factorials, 
especially if $a$ and $b$ are close together. If $a>b$ the function returns $1$.

The factorial functions terminate and print an error message if the arguments are too large (currently the limit 
is $n < 65535$) because exact factorials of such large numbers are computationally expensive and most probably 
not useful. One can call {Internal'LnGammaNum()} to evaluate logarithms of such factorials to desired precision.

*E.G.
In> 1/3 *** 10;
Result: 17041024000/59049;

*SEE BinomialCoefficient, Product, Gamma, !, !!, Subfactorial
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Average.mpw0000644000175000017500000000010211316324171026342 0ustar  giovannigiovanni%mathpiper,def=""

//Not defined in scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/exclamationpoint_operator.mpw0000644000175000017500000000522211523200452032264 0ustar  giovannigiovanni%mathpiper,def="!"

/* Factorials */

10 # 0! <-- 1;
10 # (Infinity)! <-- Infinity;
20 # ((n_IsPositiveInteger)!) <-- [
	Check(n <= 65535, "Argument", "Factorial: Error: the argument " : ( PipeToString() Write(n) ) : " is too large, you may want to avoid exact calculation");
	MathFac(n);
];

25 # ((x_IsConstant)!)_(FloatIsInt(x) And x>0) <-- (Round(x)!);

30 # ((x_IsNumber)!)_InNumericMode() <-- Internal'GammaNum(x+1);

40 # (n_IsList)! <-- MapSingle("!",n);

/* formulae for half-integer factorials:

(+(2*z+1)/2)! = Sqrt(Pi)*(2*z+1)! / (2^(2*z+1)*z!) for z >= 0
(-(2*z+1)/2)! = Sqrt(Pi)*(-1)^z*z!*2^(2*z) / (2*z)! for z >= 0

Double factorials are more efficient:
	(2*n-1)!! := 1*3*...*(2*n-1) = (2*n)! / (2^n*n!)
	(2*n)!! := 2*4*...*(2*n) = 2^n*n!

*/
/* // old version - not using double factorials
HalfIntegerFactorial(n_IsOdd) _ (n>0) <--
	Sqrt(Pi) * ( n! / ( 2^n*((n-1)/2)! ) );
HalfIntegerFactorial(n_IsOdd) _ (n<0)  <--
	Sqrt(Pi) * ( (-1)^((-n-1)/2)*2^(-n-1)*((-n-1)/2)! / (-n-1)! );
*/
// new version using double factorials
HalfIntegerFactorial(n_IsOdd) _ (n>0) <--
	Sqrt(Pi) * ( n!! / 2^((n+1)/2) );
HalfIntegerFactorial(n_IsOdd) _ (n<0)  <--
	Sqrt(Pi) * ( (-1)^((-n-1)/2)*2^((-n-1)/2) / (-n-2)!! );
//HalfIntegerFactorial(n_IsOdd) _ (n= -1)  <-- Sqrt(Pi);

/* Want to also compute (2.5)! */
40 # (n_IsRationalOrNumber)! _(Denominator(Rationalize(n))=2) <-- HalfIntegerFactorial(Numerator(Rationalize(n)));


%/mathpiper



%mathpiper_docs,name="!",categories="Operators"
*CMD !  --- factorial

*CALL
	n!
	n!!
	
*PARMS
{n} -- integer, half-integer, or list

*DESC
The factorial function {n!} calculates the factorial of integer or half-integer numbers. For
nonnegative integers, $n! := n*(n-1)*(n-2)*...*1$. The factorial of
half-integers is defined via Euler's Gamma function, $z! := Gamma(z+1)$. If $n=0$ the function returns $1$.

The factorial functions are threaded, meaning that if the argument {n} is a
list, the function will be applied to each element of the list.

Note: For reasons of MathPiper syntax, the factorial sign {!} cannot precede other
non-letter symbols such as {+} or {*}. Therefore, you should enter a space
after {!} in expressions such as {x! +1}.

The factorial functions terminate and print an error message if the arguments are too large (currently the limit 
is $n < 65535$) because exact factorials of such large numbers are computationally expensive and most probably 
not useful. One can call {Internal'LnGammaNum()} to evaluate logarithms of such factorials to desired precision.

*E.G.

In> 5!
Result: 120;
In> 1 * 2 * 3 * 4 * 5
Result: 120;
In> (1/2)!
Result: Sqrt(Pi)/2;

*SEE BinomialCoefficient, Product, Gamma, !!, ***, Subfactorial
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/sums/Product.mpw0000644000175000017500000000261511523200452026416 0ustar  giovannigiovanni%mathpiper,def="Product"

Function("Product",{sumvar,sumfrom,sumto,sumbody})
[
   Local(sumi,sumsum);
   sumsum:=1;
   For(sumi:=sumfrom,sumi<=sumto And sumsum!=0,sumi++)
       [
        MacroLocal(sumvar);
        MacroBind(sumvar,sumi);
        sumsum:=sumsum*Eval(sumbody);
       ];
   sumsum;
];
UnFence("Product",4);
HoldArgument("Product",sumvar);
HoldArgument("Product",sumbody);

Product(sumlist_IsList) <--
[
   Local(sumi,sumsum);
   sumsum:=1;
   ForEach(sumi,sumlist)
   [
     sumsum:=sumsum*sumi;
   ];
   sumsum;
];

%/mathpiper



%mathpiper_docs,name="Product",categories="User Functions;Series"
*CMD Product --- product of a list of values
*STD
*CALL
	Product(list)
	Product(var, from, to, body)

*PARMS

{list} -- list of values to multiply

{var} -- variable to iterate over

{from} -- integer value to iterate from

{to} -- integer value to iterate up to

{body} -- expression to evaluate for each iteration

*DESC

The first form of the {Product} command simply
multiplies all the entries in "list" and returns their product.

If the second calling sequence is used, the expression "body" is
evaluated while the variable "var" ranges over all integers from
"from" up to "to", and the product of all the results is
returned. Obviously, "to" should be greater than or equal to
"from".

*E.G.

In> Product({1,2,3,4});
Result: 24;
In> Product(i, 1, 4, i);
Result: 24;

*SEE Sum, Apply
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/0000755000175000017500000000000011722677332024737 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xFactors.mpw0000644000175000017500000003502511577377604027271 0ustar  giovannigiovanni%mathpiper,def="xFactors"

/*------------------------------------------------------------------------
 *  PENULTIMATE VERSION 
 *    Started 091222
 *    revised 100108-22
 *    revised 100215
 *    revised 100301
 *------------------------------------------------------------------------*/

//Retract("xFactors",*);
//Retract("xFactorsPrimitivePart",*);
//Retract("xFactorsUnivariate",*);
//Retract("xFactorsMultivariate",*);
//Retract("xFactorsHomogeneousBivariate",*);
//Retract("CheckForSpecialForms",*);

//Retract("ApproximateRealCoefficients",*);
//Retract("FixUpMonicFactors",*);
//Retract("CombineNumericalFactors",*);
//Retract("IsPureRational",*);
//Retract("HasRealCoefficients",*);
//Retract("HasRationalCoefficients",*);
//Retract("matchPower",*);
//Retract("IsIrreducible",*);     //      NOT YET OPERATIONAL


/* --------------    LISTS    ---------------*/

10 # xFactors( L_IsList ) <-- xFactors /@ L;


/* -------------    NUMBERS    --------------*/


10 # xFactors(p_IsPositiveInteger) <--  
[
    If( p < 1600, FactorsSmallInteger(p), FactorizeInt(p) );
];


12 # xFactors(p_IsNegativeInteger) <-- xFactors(-p);


14 # xFactors(p_IsRational)_(Denominator(p) != 1) <-- 
             { {xFactor(Numerator(p)) / xFactor(Denominator(p) ) , 1} }; 
             

16 # xFactors(p_IsGaussianInteger)	<-- GaussianFactors(p);


18 # xFactors(_p)_(Length(VarList(p))=0) <-- {{p,1}};



/* -------------    POLYNOMIALS -- CAN BE UNI   --------------*/

21 # xFactors( poly_CanBeUni ) <--
[
    If(InVerboseMode(),Tell("xFactors_can_be_uni_100122",poly));
    Local(content,pp,ppFactors,monomialFactors,result);
    Local(vars,nvars,disassem,degrees,mpoly,nterms,allCoeffs,allPowers);
    Local(hasRealCoefficients,hasRationalCoefficients,isHomogeneous);

    //  First, check to see if the polynomial has any REAL coefficients.
    //  If so, convert to approximate integers (with divisor).
    hasRealCoefficients := HasRealCoefficients(poly);
    If( hasRealCoefficients, 
      [
         Local(realPoly);
         realPoly  := poly;   //  just in case -- save original form
         disassem  := DisassembleExpression(poly);
         allCoeffs := disassem[3];
         allPowers := Flatten(disassem[2],"List");
         poly      := ApproximateRealCoefficients(poly);
      ]
    );
    
    //  Also, check to see if the polynomial has Rational coeffs
    hasRationalCoefficients := HasRationalCoefficients(poly);
    
    // Now: get Content and Primitive Part
    content := xContent( poly );
    pp      := xPrimitivePart( poly, content );
    If(InVerboseMode(),Tell("  ",{content,pp}));
    vars     := VarList(pp);
    nvars    := Length(vars);
    disassem := DisassembleExpression(pp);
    nterms   := Length(disassem[3]);
    degrees  := {};
    allCoeffs         := disassem[3];
    allPowers         := Flatten(disassem[2],"List");
    If(nvars > 0,
      [
        ForEach(v,vars)
           [ DestructiveAppend(degrees,Degree(pp,v)); ];
        isHomogeneous     := [
            // A polynomial is homogeneous of degree n 
            // if all terms have degree n.   
            Local(sd,cmp); 
            sd  := Sum /@ disassem[2];
            cmp := FillList(sd[1],Length(sd));
            IsZeroVector(sd - cmp);
        ];
      ]
    );
    
    // Experimental: 
    //   Attach a set of Meta-Keys to pp, describing
    //   some of the above information
    pp := MetaSet(pp,"nvars",nvars);
    pp := MetaSet(pp,"nterms",nterms);
    pp := MetaSet(pp,"degrees",degrees);
    pp := MetaSet(pp,"isHomogeneous",isHomogeneous);
    
    If(InVerboseMode(),
      [
        Tell("               ",vars);
        Tell("              ",nvars);
        Tell("             ",nterms);
        Tell("            ",degrees);
        Tell("           ",disassem);
        Tell("          ",allCoeffs);
        Tell("          ",allPowers);
        Tell("      ",isHomogeneous);
        NewLine();
      ]
    );
    
    //  OK.  Now factor the PrimitivePart
    ppFactors := xFactorsPrimitivePart( pp );

    If(InVerboseMode(),[NewLine();Tell("  ",ppFactors);]);
    
    // Next, include the factors of the Content, if any
    If(InVerboseMode(),NewLine());
    monomialFactors := FactorsMonomial(content);
    If(InVerboseMode(),[Tell("  ",monomialFactors);]);
    If( monomialFactors[1][1] = 1,
        result := ppFactors,        
        result := Concat(monomialFactors,ppFactors)
    );
    
    If(InVerboseMode(),[NewLine();Tell("  final  ",result);]);
    result;
];



// -----------------  FACTOR PRIMITIVE PART  -----------------

     //  special case: binomials
10 # xFactorsPrimitivePart( _pp )_(nterms=2) <--
[
    If(InVerboseMode(),Tell("Binomial"));
    Local(ppFactors);
    ppFactors := xFactorsBinomial(pp);
];
UnFence("xFactorsPrimitivePart",1);


     //  special case: homogeneous bivariates
12 # xFactorsPrimitivePart( _pp )_(isHomogeneous And nvars=2) <--
[
    If(InVerboseMode(),Tell("Homogeneous and Bivariate"));
    Local(ppFactors);
    ppFactors := xFactorsHomogeneousBivariate(disassem);
];
UnFence("xFactorsPrimitivePart",1);


     //  special case:  no variables in pp!
14 # xFactorsPrimitivePart( _pp )_(nvars=0) <--
[
    Local(ppFactors);
    ppfactors := {};
];


     //  general case: univariate
16 # xFactorsPrimitivePart( _pp )_(nvars=1) <--  xFactorsUnivariate(pp); 
UnFence("xFactorsPrimitivePart",1);


     //  general case: multivariate
18 # xFactorsPrimitivePart( _pp )_(nvars>1) <-- xFactorsMultivariate(pp);
UnFence("xFactorsPrimitivePart",1);


     //  catch-all: represents an ERROR CONDITION
20 # xFactorsPrimitivePart( _pp ) <-- Tell("Should never get here!");
UnFence("xFactorsPrimitivePart",1);



// ----------------------  UNIVARIATE POLYNOMIALS  -----------------------

30 # xFactorsUnivariate( poly_CanBeUni )_(Length(VarList(poly))=1) <--
[
    Local(factrs,coeffs,deg,X,residuals,factrsnew);

    If(InVerboseMode(),
      [
         NewLine();
         Tell("xFactorsUnivariate",poly);
         Tell("       ",allCoeffs);
      ]
    );
    
    // OK, First, send it through MathPiper's basic factoring function
    // for univariate polynomials
    
    factrs := BinaryFactors(poly);
    If(InVerboseMode(),Tell("   output of BinaryFactors",factrs));

    //    Now fix-up the (monic) factors found above, to express them
    // as linear in x with integer coefficients.  
    //    Also, separate out any 'residual' factors -- defined here as
    // factors of degree > 2.
    
    {factrsnew,residuals} := FixUpMonicFactors(factrs);
    
    //  See if we can do something with the residuals
    Local(residOut);
    residOut := {};
    If(Length(residuals) > 0, residOut := xFactorsResiduals( residuals ) );
    
    If(InVerboseMode(),
      [
          NewLine();
          Tell(" just before end of univariate factoring");
          Tell("    ",factrs);
          Tell("    ",factrsnew);
          Tell("    ",residOut);
      ]
    );   
    //  Finally, the output --------
    Local(final);
    If(Length(Union(factrsnew,residOut)) > 0,
        final := Concat(factrsnew,residOut),
        final := factrs
    );
    CheckForSpecialForms( final );
];   //   xFactorsUnivariate
UnFence("xFactorsUnivariate",1);


// ----------------  MULTIVARIATE POLYNOMIALS  -----------------

40 # xFactorsMultivariate( poly_CanBeUni )_(Length(VarList(poly))>1) <--
[
    Local(factrs);
    
    If(InVerboseMode(),[NewLine();Tell("xFactorsMultivariate",poly);]);
    If( nterms = 2, 
      [
        If(InVerboseMode(),Tell("   Is Binomial"));
        factrs := xFactorsBinomial(poly); 
      ],
      [
        If(InVerboseMode(),Tell("   Has more than 2 terms"));
      ]
    );
    factrs;
];
UnFence("xFactorsMultivariate",1);


// ------------------  HOMOGENEOUS BIVARIATE  ------------------

10 # xFactorsHomogeneousBivariate( dis_IsList ) <-- 
[
    If(InVerboseMode(),[NewLine();Tell("xFactorsHomogeneousBivariate",dis);]);
    Local(dis1,f,lst,dis2,poly1,ppFactors,residuals,ii,preassem);
    dis1  := {{xi},{{X},{X[1]}} /@ dis[2],dis[3]};
    If(InVerboseMode(),Tell("   ",dis1));
    poly1 := Sum(ReassembleListTerms(dis1));
    If(InVerboseMode(),Tell("   ",poly1));
    ppFactors := BinaryFactors(poly1);
    {ppFactors,residuals} := FixUpMonicFactors(ppFactors);
    For(ii:=1,ii<=Length(ppFactors),ii++)
    [
        f := ppFactors[ii];
        If(InVerboseMode(),Tell("          ",f[1]));
        lst := DisassembleExpression(f[1]);
        If(InVerboseMode(),
          [
             Tell("               ",lst);
             Tell("                            ",dis[1]);
          ]
        );
        DestructiveReplace(lst,1,dis[1]);
        DestructiveAppend(lst[2][1],0);
        DestructiveAppend(lst[2][2],1);
        If(InVerboseMode(),Tell("               ",lst));
        preassem  := Sum(ReassembleListTerms(lst)) ;
        If(InVerboseMode(),Tell("               ",preassem));
        ppFactors[ii][1] := preassem;
    ];
    If(InVerboseMode(),[Tell("   ",ppFactors); Tell("   ",residuals);NewLine();] );  
    ppFactors;
];
UnFence("xFactorsHomogeneousBivariate",1);


// ------------------  SPECIAL FORMS  ------------------

10 # CheckForSpecialForms( final_IsList ) <-- 
[
    If(InVerboseMode(),[NewLine();Tell("CheckForSpecialForms",final);]);
    Local(LL,ii,fact,mult,dis,new);
    new := {};
    LL  := Length(final);
    For(ii:=1,ii<=LL,ii++)
    [
        fact := final[ii][1];
        mult := final[ii][2];
        If(InVerboseMode(),Tell("   ",{fact,mult}));
        dis := DisassembleExpression( fact );
        If(InVerboseMode(),Tell("   ",dis));
        Local(var);
        var := dis[1][1];
        if ( dis[2]={{4},{2},{0}} And dis[3]={1,1,1} )
            [
                Local(new1,new2);
                new1 := {var^2-var+1,mult};
                new2 := {var^2+var+1,mult};
                DestructiveAppend(new,new1);
                DestructiveAppend(new,new2);
                If(InVerboseMode(),Tell("   ",new));
            ]
        else
            [
                If(InVerboseMode(),Tell("   no special form"));
                DestructiveAppend(new,{fact,mult});
            ];
        );
    ];
    new;
];


// ---------------------   OTHER STUFF ------------------------


10 # ApproximateRealCoefficients( poly_IsPolynomial ) <--
[
    // If the polynomial has REAL coefficients, convert them to
    // approximate integers
    If(InVerboseMode(),[NewLine();Tell("  REAL",poly);]);
    Local(coeffs,gcd,lcm);
    coeffs := Rationalize /@ (allCoeffs);
    If(InVerboseMode(),[Tell("      to-Q",coeffs);Tell("      to-Z",coeffs);]);
    Local(gcd,lcm);
    gcd    := Gcd(Numerator /@ coeffs);
    lcm    := Lcm(Denominator /@ coeffs);
    If(InVerboseMode(),[Tell("       ",gcd);Tell("       ",lcm);]);
    disassem[3] := coeffs;
    allCoeffs   := coeffs;
    poly        := Sum(ReassembleListTerms(disassem));
    If(InVerboseMode(),Tell("   new",poly));
    poly;
];
UnFence("ApproximateRealCoefficients",1);


100 # CombineNumericalFactors( factrs_IsList ) <--
[
      If( InVerboseMode(), Tell("Combine",factrs) );
      Local(q,a,b,t,f,ff,err);
      err := False;
      t   := 1;
      f   := {};
      ForEach(q,factrs)
      [
          If( InVerboseMode(), Tell(1,q) );
          If( IsList(q) And Length(q)=2,
            [
                {a,b} := q;
                If( InVerboseMode(), Echo("     ",{a,b}) );
                If( IsNumericList( {a,b} ),
                    t := t * a^b,
                    f := {a,b}:f
                );
            ],
              err := True
          );
      ];
      If( InVerboseMode(),
        [
            Echo("      t = ",t);
            Echo("      f = ",f);
            Echo("    err = ",err);
        ]
      );
      ff := If(Not err And t != 1, {t,1}:Reverse(f), factrs);
      ff := Select(Lambda({x},x!={1,1}),ff);
      If(ff[1]<0,ff[1]:=-ff[1]);
];


// ----------------  RATIONAL POLYNOMIALS  -----------------

150 # xFactors( expr_IsRationalFunction )_
        (IsPolynomial(Numerator(expr)) And IsPolynomial(Denominator(expr))) <--
[
    If(InVerboseMode(),[NewLine();Tell("xFactors_Rational_Function",expr);]);
    Local(Numer,Denom,fNumer,fDenom);
    Numer  := Numerator(expr);
    Denom  := Denominator(expr);
    fNumer := xFactors(Numer);
    fDenom := xFactors(Denom);
    If(InVerboseMode(),[Tell("   ",fNumer); Tell("   ",fDenom);]);
    fNumer/fDenom;
];


152 # xFactors( expr_IsRationalFunction )_
        (IsConstant(Numerator(expr)) And IsPolynomial(Denominator(expr))) <--
[
    If(InVerboseMode(),[NewLine();Tell("xFactors_Rational_Denom",expr);]);
    Local(Numer,Denom,fNumer,fDenom);
    Numer  := Numerator(expr);
    Denom  := Denominator(expr);
    fNumer := xFactors(Numer);
    fDenom := xFactors(Denom);
    If(InVerboseMode(),[Tell("   ",fNumer); Tell("   ",fDenom);]);
    fNumer/fDenom;
];


// ----------   POSSIBLE NON-INTEGER EXPONENTS  ----------

200 # xFactors( _expr )_(Length(VarList(expr)) = 1) <--
[
    If(InVerboseMode(),[NewLine();Tell("Some other kind of expression",expr);]);
    Local(dis,X,pows);
    dis := DisassembleExpression(expr);
    X   := VarList(expr)[1];
    pows := matchPower /@ dis[1];
    rats := NearRational /@ pows;
    dis[1] := x^rats;
    p := Sum(ReassembleListTerms(dis));
    If(InVerboseMode(),Tell("    new ",p));
    xFactors(p);
];

10 # IsIrreducible( poly_IsPolynomial )_(Length(VarList(poly))=1) <--
[
    //  If these tests return True, the polynomial IS irreducible..
    //  If they return False, the reducibility of the polynomial is
    //  not established, one way or the other.
    //
    // ----   THIS FUNCTION IS NOT YET COMPLETE OR USEABLE   ---
    If(InVerboseMode(),Tell("IsIrreducible",poly));
    Local(var,deg,coeffs,num1);
    var    := VarList(poly)[1];
    deg    := Degree(poly);
    coeffs := Coef(poly,var,deg .. 0);
    If(InVerboseMode(),Tell("   ",deg));
    Local(ii,res,nprimes);
    nprimes := 0;
    For(ii:=-3*deg,ii<=3*deg,ii:=ii+3)
    [
        res := N(Subst(x,ii) poly);
        //Tell("      ",{ii,res,IsPrime(res)});
        If(Abs(res)=1 Or IsPrime(res), nprimes := nprimes + 1, );
    ];
    Tell("   ",nprimes);
    If(nprimes > 2*deg, True, False );
];


10 # matchPower(_Z^n_IsNumber) <-- n;

15 # matchPower(_Z) <-- 1;


//========================================================================

%/mathpiper








mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xFactorsResiduals.mpw0000644000175000017500000002150411517224250031120 0ustar  giovannigiovanni%mathpiper,def="xFactorsResiduals"

//Retract("xFactorsResiduals",*);
//Retract("trySQF",*);
//Retract("tryRealRoots",*);
//Retract("processRealRoots",*);

10 # xFactorsResiduals( residualList_IsList ) <--
[
    If(InVerboseMode(),[NewLine(); Tell("Residuals",residualList);]);
    If(InVerboseMode(),Tell("  --",content));
    If(InVerboseMode(),Tell("  --",factrs));
    If(InVerboseMode(),Tell("  --",factrsnew));
    If(InVerboseMode(),Tell("  --",residuals));
    If(InVerboseMode(),Tell("  -- original ",degrees));
    Local(resid,sqf,sqfGood,rrGood);
    
    //  ---  see if Square-Free factoring can find some factors

    residualList := trySQF(residualList);   //  hso
    
    If(InVerboseMode(),
      [
         Tell("   after trying SQF on all residuals");
         Tell("          ",sqfGood);
         Tell("          ",factrsnew);
         Tell("          ",residualList);
         NewLine();
      ]
    );
    
    //  ---  see if there are any REAL roots to help with factoring

    tryRealRoots(residualList);
    
    If(InVerboseMode(),
      [
         Tell("   after trying for REAL roots on all residuals");
         Tell("          ",rrGood);
         Tell("          ",factrsnew);
         Tell("          ",residuals);
         Tell("          ",residualList);
         NewLine();
      ]
    );

     residOut;
];
UnFence("xFactorsResiduals",1);



10 # trySQF( residualList_IsList ) <--
[
    //--- First, try SquareFree factorization on these residuals 
    Local(resid,sqf);
    If(InVerboseMode(),[NewLine(); Tell("trySQF",residualList);]);
    ForEach(resid,residualList)
    [
        If(InVerboseMode(),Tell("   ",resid));
        
        sqf := SquareFree(resid[1]);
        If(InVerboseMode(),
          [
             Tell("          trying SQF");
             Tell("            ",resid[1]);
             Tell("            ",sqf);
          ]
        );
        If(Degree(sqf) < Degree(resid[1]),
          [
            If(InVerboseMode(),Tell("               sqf helps factor resid"));
            sqfGood := True;
            Local(f1,f2);
            f1 := sqf;
            f2 := Simplify(resid[1]/sqf);
            If( f2 = f1,
                 factrsnew := Concat({{f1,2*resid[2]}},factrsnew),
                 factrsnew := Concat({{f1,resid[2]},{f2,resid[2]}},factrsnew)
            );
            //HSO experimental
            residuals := Difference(residuals,{resid});
            If(InVerboseMode(),Tell("                       new",residuals));
            residualList := residuals;
          ],
          [
            If(InVerboseMode(),
              [
                 Tell("               sqf DOES NOT HELP factor resid");
                 sqfGood := False;
              ]
            );
          ]
        );
        If(InVerboseMode(),Tell("            after sqf ",factrsnew));
        If(InVerboseMode(),Tell("                      ",residuals));
        If(InVerboseMode(),Tell("                      ",residualList));  // hso
    ];
    residualList;   //  hso
];
UnFence("trySQF",1);



10 # tryRealRoots(residualList_IsList)_(Length(residualList)>0) <--
[
    //--- See if there are any REAL roots to factor out
    If(InVerboseMode(),[NewLine(); Tell("tryRealRoots",residualList);]);
    ForEach(resid,residualList)
    [
        Local(nrr,rr,ptry,uptry);
        nrr := RealRootsCount(resid[1]);
        If(InVerboseMode(),
          [ Tell("            this ",resid[1]); Tell("            ",nrr); ]
        );
        If( nrr > 0, rr := FindRealRoots(resid[1]), rr := {} );
        processRealRoots(rr);
        
        If( nrr = 2,
          [
             If( nrr = 0,
               [
                  //  OhOh - no real solutions -- have to try something else
                  If(InVerboseMode(),
                    [
                       NewLine();
                       Tell("               NO real solutions");
                       Tell("               try something else");
                    ]
                  );
                  //  Here go some ad-hoc solutions that can be useful....
                  Local(u,X);
                  u := MakeUni(resid[1]);
                  X := u[1];
                  If( u[2]=0 And u[3]={1,0,1,0,1},
                    [ 
                       DestructiveAppend(residOut,{X^2-X+1,1});
                       DestructiveAppend(residOut,{X^2+X+1,1});
                       If(InVerboseMode(),
                         [
                            Tell("     found ",factrsnew);
                            Tell("           ",resid);
                            Tell("           ",factrs);
                            Tell("           ",residOut);
                         ]
                       );
                    ]
                  );
               ],
               [
                  //  more than 2 real solutions -- have to do a bit more work
                  rr := FindRealRoots(resid[1]);
                  If(InVerboseMode(),Tell("    ",rr));
                  // try them pairwise
                  goodptry := {};
                  For(ii:=1,ii 0,
                    [
                       ForEach(pt,goodptry)
                         [ DestructiveAppend(residOut,{pt,1}); ];
                    ]
                  );
               ]
             );  //   if nrr=0
          ]
        );  //  if nrr=2
     ];  
];
UnFence("tryRealRoots",1);


10 # processRealRoots( rr_IsNumericList )_(Length(rr) = 1) <--
[
    //  Only one real root, so it will probably be of no help
    //  in factoring, unless it is integer or small rational
    If(InVerboseMode(),Tell("  Only 1 real root",rr));
    Local(root);
    root := rr[1];
    rrGood := False;
    If(IsInteger(root), 
      [
          If(InVerboseMode(),Tell("    integer ",root));
          rrGood := True;
      ],
      [
          Local(rroot);
          rroot := NearRational(root);
          If(InVerboseMode(),Tell("    rational ",rroot));
          If(Denominator(rroot) < 100, [root := rroot; rrGood:=True;] );
      ]
    );
    
];
UnFence("processRealRoots",1);


10 # processRealRoots( rr_IsNumericList )_(Length(rr) = 2) <--
[
    // a pair of real solutions -- probably form a quadratic
    ptry  := Expand((x-rr[1])*(x-rr[2]));
    If(InVerboseMode(),[Tell("    ",rr);Tell("    ",ptry);]);
    uptry    := MakeUni(ptry);
    uptry[3] := "NearRational" /@ uptry[3];
    ptry     := NormalForm(uptry);
    If(InVerboseMode(),Tell("    ",ptry));
    If( Abs(Lcm(uptry[3])) < 100,
      [
         //  looks OK -- try to use it
         Local(f1,f2,new);
         f1    := ptry;
         f2    := Simplify(resid[1]/f1);
         new   := {{f1,resid[2]},{f2,resid[2]}};
         If(InVerboseMode(),Tell("    ",new));
         resid := new;
         residOut := new;
         If(InVerboseMode(),Tell("    ",residOut)); 
      ]
    );
];
UnFence("processRealRoots",1);



10 # processRealRoots( rr_IsNumericList )_(Length(rr) >= 4) <--
[
     //  more than 2 real solutions -- have to do a bit more work
     If(InVerboseMode(),Tell("    ",rr));
     // try them pairwise
     goodptry := {};
     For(ii:=1,ii 0,
           [
               ForEach(pt,goodptry)
               [ DestructiveAppend(residOut,{pt,1}); ];
           ]
         );
     ];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/YacasFactor.mpw0000644000175000017500000000166111523200452027647 0ustar  giovannigiovanni%mathpiper,def="YacasFactor"

// This is so YacasFactor(Sin(x)) doesn't return FWatom(Sin(x))
//YacasFactor(_p) <-- FW(YacasFactors(p));
10 # YacasFactor(p_CanBeUni) <-- FW(YacasFactors(p));

%/mathpiper



%mathpiper_docs,name="YacasFactor",categories="User Functions;Number Theory"
*CMD Factor --- factorization (in pretty form)
*STD
*CALL
	YacasFactor(x)

*PARMS

{x} -- integer or univariate polynomial

*DESC

This is the original Yacas version of the Factor() function.  It has
b een superceeded in MathPiper by the function xFactor().

This function factorizes "x", similarly to {YacasFactors}, but
it shows the result in a more human-readable format.

*E.G.

In> PrettyForm(YacasFactor(24));
	
	 3
	2  * 3
	
Result: True;
In> PrettyForm(YacasFactor(2*x^3 + 3*x^2 - 1));
	
	             2   /     1 \
	2 * ( x + 1 )  * | x - - |
	                 \     2 /
	
Result: True;

*SEE YacasFactors, xFactor, IsPrime, PrettyForm
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FindPrimeFactor.mpw0000644000175000017500000000203011320776303030463 0ustar  giovannigiovanni%mathpiper,def="FindPrimeFactor"

//  numbers

/// Auxiliary function. Return the power of a given prime contained in a given integer and remaining integer.
/// E.g. FindPrimeFactor(63, 3) returns {7, 2} and FindPrimeFactor(42,17) returns {42, 0}
// use variable step loops, like in IntLog()
FindPrimeFactor(n, prime) :=
[
	Local(power, factor, old'factor, step);
	power := 1;
	old'factor := 1;	// in case the power should be 0
	factor := prime;
	// first loop: increase step
	While(Modulo(n, factor)=0)	// avoid division, just compute Modulo()
	[
		old'factor := factor;	// save old value here, avoid sqrt
		factor := factor^2;
		power := power*2;
	];
	power := Quotient(power,2);
	factor := old'factor;
	n := Quotient(n, factor);
	// second loop: decrease step
	step := Quotient(power,2);
	While(step>0 And n > 1)
	[
		factor := prime^step;
		If(
			Modulo(n, factor)=0,
			[
				n := Quotient(n, factor);
				power := power + step;
			]
		);
		step := Quotient(step, 2);
	];
	{n, power};
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/Factors.mpw0000644000175000017500000001052011523200452027043 0ustar  giovannigiovanni%mathpiper,def="Factors"

/*------------------------------------------------------------------------
 *    Started 091222
 *    revised 100108-22
 *    revised 100215
 *    major refactoring 100425
 *    convert polynomial factoring to use JAS library  100511
 *    Another major refactoring -- 100529
 *    Ready for initial commit     100610
 *    Modifications                100727
 *------------------------------------------------------------------------*/

//Retract("Factors",*);


/* --------------    LISTS    ---------------*/

10 # Factors( L_IsList ) <-- nFactors /@ L;


/* -------------    NUMBERS    --------------*/


10 # Factors(n_IsPositiveInteger) <--  
[
    If( n < 1600, FactorsSmallInteger(n), FactorizeInt(n) );
];



15 # Factors(n_IsNegativeInteger) <--
[
    If(InVerboseMode(),Tell("Factors_negInt",n));
    Local(en,ans);
    en  := -n;
    ans := {-1,1}:If( en < 1600, FactorsSmallInteger(en), FactorizeInt(en) );
];


20 # Factors(p_IsRational)_(Denominator(p) != 1) <-- 
[
    If(InVerboseMode(),Tell("Factors_ratNum",p));
    Local(sgn,num,den,fn,fd,f,ans);
    sgn := 1;
    If(p < 0, [p := -p; sgn := -1;]);
    num := Numerator(p);
    den := Denominator(p);
    fn := FactorizeInt(num);
    If(sgn < 0, fn := {-1,1}:fn );
    fd := FactorizeInt(den);
    If(InVerboseMode(),Tell("  ",{fn,fd}));
    ForEach(f,fd)
     [
         DestructiveReplace(f,2,-f[2]);
         DestructiveAppend(fn,f);
     ];
    ans := fn;
]; 
             

25 # Factors(p_IsGaussianInteger)	<-- GaussianFactors(p);


30 # Factors(_p)_(Length(VarList(p))=0) <-- {{p,1}};


//40 # Factors(p_IsRationalFunction) <-- 
//[
//    If(InVerboseMode(),Tell("Factors_ratFunc",p));
//    jFactorsRationalFunc(p);
//];


50 # Factors( p_CanBeUni ) <-- 
[
    If(InVerboseMode(),Tell("Factors_uni",p));
    Local(res,len,newRes,ii,accum,n);
    res    := jFactorsPoly(p);
    //
    // Now, do a bit of fix-up for factors of (-1)^n
    //
    len    := Length(res);
    newRes := {};
    accum  := 1;    //  initialize number accumulator
    
    ForEach(r,res)
    [
        If(InVerboseMode(),Tell("      ",r));
        If( IsNumber(Eval(r[1])), 
          [ 
              n := r[1]^r[2];
              If(InVerboseMode(),Tell("            ",n));              
              accum := accum * n;
          ],
          DestructiveAppend(newRes,r)
        );
    ];
    If(InVerboseMode(),Tell("   ",{newRes,accum}));
    If(accum != 1, DestructiveInsert(newRes,1,{accum,1}));
    newRes;
];


60 # Factors( p_IsRationalFunction ) <--
[
    If(InVerboseMode(),Tell("Factors_ratFunc",p));
    Local(num,den,fn,fd,f);
    num := Numerator(p);
    den := Denominator(p);
    If(InVerboseMode(),Tell("   ",{num,den}));
    fn  := Factors(num);
    fd  := Factors(den);
    If(Not IsListOfLists(fd), fd := {fd});
    If(InVerboseMode(),Tell("       r ",{fn,fd}));
    ForEach(f,fd)
     [
         DestructiveReplace(f,2,-f[2]);
         DestructiveAppend(fn,f);
     ];
    fn;
];

100 # Factors( _p ) <--
[
    Tell("Factors__Fall-Through_cases",p);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

    %output,preserve="false"
      Processing...
.   %/output

    %output,preserve="false"
      Processing...
.   %/output





%mathpiper_docs,name="Factors",categories="User Functions;Number Theory"
*CMD Factors --- factorization
*STD
*CALL
	Factors(x)

*PARMS

{x} -- integer or univariate polynomial

*DESC

This function decomposes the integer number {x} into a product of
numbers. 
Alternatively, if {x} is a univariate polynomial, it is
decomposed into irreducible polynomials.  If {x} is a polynomial
"over the integers", the irreducible polynomial factors will also
be returned in the (unique) form with integer coefficients.

The factorization is returned as a list of pairs. The first member of
each pair is the factor, while the second member denotes the power to
which this factor should be raised. So the factorization
$x = p1^n1 * ... * p9^n9$
is returned as {{{p1,n1}, ..., {p9,n9}}}.

Programmer: Yacas Team + Sherm Ostrowsky

*E.G.
In> Factors(24)
Result: {{2,3},{3,1}}

In> Factors(32*x^3+32*x^2-70*x-75)
Result: {{4*x+5,2},{2*x-3,1}}

*SEE Factor, IsPrime, GaussianFactors
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/jasFactorsInt.mpw0000644000175000017500000000423711517224250030231 0ustar  giovannigiovanni%mathpiper,title="jasFactorsInt"

//Retract("jasFactorsInt",*);

jasFactorsInt(poly_IsPolynomial) <--
[
    If(InVerboseMode(),Tell(jasFactorsInt,poly));
    Local(polyStr,vars,strVars,ns,ringDescription,defaultPoly,jasI);
    
    // --- get Java class JFactorsPolyInt into MathPiper form
    polyStr := ExpressionToString(poly); //  polynomial as string
    vars    := VarList(poly);
    strVars := ExpressionToString( vars );  //  variables as string
    ns      := Length(strVars);
    strVars := strVars[2 .. ns-1];      //  remove enclosing braces

    jasI    := JavaNew("org.mathpiper.builtin.library.jas.JFactorsPolyInt",polyStr,strVars);
    If(InVerboseMode(),[Tell("  ",jasI);]);
    
    // --- at last, we're ready to do some factoring
    Local(resultSet,entrySet,iterator,result,mult,fact);
    //  the result returned by the factors() method is a Java SortedMap
    //  In order to iterate through this Map, we need its first set and
    //  an iterator.
    resultSet := JavaCall(jasI,"factors");
    entrySet  := JavaCall(resultSet,"entrySet");
    iterator  := JavaCall(entrySet,"iterator");
    // now we can iterate through the Map and make a MathPiper List whose
    // elements are {factor,multiplicity} pairs
    result    := {};
    While ( JavaAccess(iterator,"hasNext")=True)
    [
        entrySet := JavaCall(iterator,"next");
        mult     := JavaAccess(entrySet,"getValue");
        fact     := ToString(JavaAccess(JavaCall(entrySet,"getKey"),"toScript"));
        // convert factor string from "**" to "^" exponent notation
        Local(lst,ii,factor);
        lst   := StringToList(fact);
        For(ii:=1,ii=0));
    den := Select(fs,Lambda({X},X[2]<0));
    If(InVerboseMode(),Tell("   ",{num,den}));
    dent := Transpose(den);
    dent[2] := -1 * dent[2];
    den  := Transpose(dent);
    If(InVerboseMode(),Tell("   ",{num,den}));
    n  := FW(num);
    d  := FW(den);
    n/d;

];


12 # Factor( p_CanBeUni ) <-- 
[
    If(InVerboseMode(),Tell("Factor_uni",p));
    Local(facList);
    facList := Factors(p);
    If(InVerboseMode(),[Tell("   ",facList);]);
    FW(facList);
];


20 # Factor( p_IsRationalFunction ) <--
[
    If(InVerboseMode(),Tell("Factor_ratFunc",p));
    Local(fs,num,den,dent,n,d);
    fs := Factors( p );
    If(InVerboseMode(),Tell("  ",fs));
    num := Select(fs,Lambda({X},X[2]>=0));
    den := Select(fs,Lambda({X},X[2]<0));
    If(InVerboseMode(),Tell("   ",{num,den}));
    dent := Transpose(den);
    dent[2] := -1 * dent[2];
    den  := Transpose(dent);
    If(InVerboseMode(),Tell("   ",{num,den}));
    n  := FW(num);
    d  := FW(den);
    n/d;
];


30 # Factor( L_IsList ) <-- 
[
    Local (result,x,f);
    result := {};
    ForEach(x,L)
    [
        f := Factors(x);
        If( f = {}, f := 0, f := FW(f) );
        DestructiveAppend(result,f);
    ];
    result;
];



40 # Factor( _expr ) <-- expr;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="Factor",categories="User Functions;Polynomials (Operations);Number Theory"
*CMD Factor -- Factorization of almost anything factorable
*CALL
Factor( expr )
*PARMS
{expr} -- An Integer, Rational number, Gaussian Integer, Polynomial, or Rational Function
*DESC
This function decomposes an integer number {expr} into a product of its prime factors. 
    
If {expr} is a Rational number (quotient of integers), it is decomposed into a
quotient of prime factors divided by prime factors, in lowest terms.
    
If {expr} is a Gaussian integer (complex number whose Re and Im parts are integers),
it is decomposed into a product of Gaussian primes.
    
If {expr} is a univariate polynomial, it is decomposed into a product of
irreducible polynomials.  If the coefficients of {expr} are all Integers, the
factors will be irreducible over the Integers.  If the coefficients of {expr}
are Rational numbers, the factors will be irreducible over the Rationals.
If any of the coefficients are in {R} but not in {Z} or {Q}, they will be 
converted to approximate Rationals before factoring.
    
If {expr} is a multivariate polynomial, it may or may not be factorized by this
function.  In general, {bivariate binomials} and {homogeneous bivariate polynomials}
will be factored correctly.  Factoring of other types of multivariate polynomials
is not yet fully implemented.
    
If {expr} is a Rational {function} (quotient of polynomials), it is decomposed into a
quotient of irreducible factors divided by irreducible factors, but not in lowest terms.
    
*E.G.
In> n:=2*2*5*7*11^2
Result: 16940

In> Factor(n)
Result: 2^2*5*7*11^2

In> m:=3*7*11
Result: 231

In> Factor(n/m)
Result: (2^2*5*11)/3

In> g:=Expand((-2+3*I)*(5-6*I))
Result: Complex(8,27)

In> Factor(g)
Result: Complex(-2,3)*Complex(-5,6)

In> f:=Expand(5*x*(x-2)^2*(x^2+x+1)*(x^2-x+1))
Result: 5*x^7-20*x^6+25*x^5-20*x^4+25*x^3-20*x^2+20*x

In> Factor(f)
Result: 5*x*(x-2)^2*(x^2-x+1)*(x^2+x+1)

In> P:=Expand(x^2-1)
Result: x^2-1

In> Q:=Expand((x+1)^2)
Result: x^2+2*x+1

In> F:=P/Q
Result: (x^2-1)/(x^2+2*x+1)

In> Factor(F)
Result: ((x-1)*(x+1))/(x+1)^2

In> f:=Expand((2*x)^6-(3)^6)
Result: 64*x^6-729

In> Factor(f)
Result: (2*x+3)*(4*x^2-6*x+9)*(2*x-3)*(4*x^2+6*x+9)

In> f:=Expand((2*x)^6-(3*y)^6)
Result: 64*x^6-729*y^6

In> Factor(f)
Result: (3*y+2*x)*(9*y^2-6*y*x+4*x^2)*(2*x-3*y)*(9*y^2+6*y*x+4*x^2)

In> f:=Expand((2*x-5*y)^2*(7*x+3*y))
Result: 28*x^3-128*y*x^2+115*y^2*x+75*y^3

In> Factor(f)
Result: (2*x-5*y)^2*(7*x+3*y)

In> f:=(a*x-a*y)/a
Result: (a*x-a*y)/a

In> Factor(f)
Result: ((-1)*a*(y-x))/a

NOTE:  If you want the result of Factor on a rational function to express
the answer in lowest terms (i.e., with cancellation), then use the function
FactorCancel() instead.

In> FactorCancel(f)
Result: x-y

 
*SEE FactorCancel,Factors

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xContent.mpw0000644000175000017500000000423211517224250027254 0ustar  giovannigiovanni%mathpiper,def="xContent"

/*------------------------------------------------------------------------
 *  Finds the Content of a univariate or multivariate polynomial
 *      mod 100727 by hso:  conform to majority definition of "Content"
 *------------------------------------------------------------------------*/

//Retract("xContent",*);


//10 # xContent( poly_IsPolynomial ) <--
10 # xContent( poly_CanBeUni ) <--
[
    Local(disassem,gcdCoefs,lc,minExpts);
    disassem := DisassembleExpression(poly);
    gcdCoefs := Gcd(disassem[3]);
    lc       := LeadingCoef(poly);
    If(IsNegativeNumber(lc) And gcdCoefs > 0, gcdCoefs:=-gcdCoefs);
    //minExpts := Minimum /@ Transpose(disassem[2]);
    //gcdCoefs * Product(disassem[1]^minExpts);
    gcdCoefs;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="xContent",categories="User Functions;Number Theory"
*CMD Content --- content of a polynomial
*STD
*CALL
	Content(expr)

*PARMS

{expr} -- a univariate or multivariate polynomial

*DESC

This is an experimental version of the existing function Contact(), 
with extended features.  It is provided primarily for testing purposes,
until it is ready to replace the older version.

This command determines the {content} of a polynomial. 
The {content} is the greatest common divisor of all the terms in the
polynomial. 

For a {univariate} polynomial, the {content} will consist of a number
or the product of a number and the lowest power of the variable (if not 0). 

For a {multivariate} polynomial, the {content} will consist of a number
or the product of a number and the lowest power of each variable present
in all terms.

Every polynomial can be written as the product of its {content}
and its {primitive part} (q.v.). This representation is usually
the first step in any attempt to factor the polynomial.

*E.G.

In> poly2:=2*a*x^2+4*a*x
Result: 2*a*x^2+4*a*x

In> cx:=xContent(poly2)
Result: 2*a*x

In> ppx := xPrimitivePart(poly2)
Result: x+2

In> Expand(ppx*cx)
Result: 2*a*x^2+4*a*x

*SEE Content, PrimitivePart, Gcd, xPrimitivePart
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorsSmallInteger.mpw0000644000175000017500000000346111523200452031360 0ustar  giovannigiovanni%mathpiper,def="FactorsSmallInteger"

//Retract("FactorsSmallInteger",*);

10 # FactorsSmallInteger( N_IsInteger ) <--
[
	Local(n, power, prime, result, limit);
    n      := Abs(N);         // make sure its positive
    limit  := Ceil(SqrtN(n)); // upper bound for largest possible factor 
	prime  := 2;	          // first prime
    result := {};
	While( prime <= limit And n > 1 And prime*prime <= n )
	[	// find the max power of prime which divides n
		{n, power} := FindPrimeFactor(n, prime);
		If(	power > 0,	DestructiveAppend(result, {prime,power}) );
		prime := NextPseudoPrime(prime);	// faster than NextPrime and we don't need real primes here
	];
	// Add the last prime (with multiplicity 1) to end of list 
	If( n > 1, DestructiveAppend(result, {n,1}) );
    result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="FactorsSmallInteger",categories="User Functions;Number Theory"
*CMD FactorsSmallInteger --- factorization for small integers
*STD
*CALL
	FactorsSmallInteger(x)

*PARMS

{x} -- a small integer

*DESC

This function decomposes the integer number {x} into its prime factors.
The method used is not suitable for large integers, although it will work.
This function is best reserved for integers less than, say, 10,000 or so.

The factorization is returned as a list of pairs. The first member of
each pair is the factor, while the second member denotes the power to
which this factor should be raised. So the factorization
$x = p1^n1 * ... * p9^n9$
is returned as {{{p1,n1}, ..., {p9,n9}}}.

Programmer: Yacas Team + Sherm Ostrowsky

*E.G.
In> FactorsSmallInteger(24)
Result: {{2,3},{3,1}}

*SEE Factors, IsPrime, FactorizeInt
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xFactorsBinomial.mpw0000644000175000017500000002431511517224250030722 0ustar  giovannigiovanni%mathpiper,title="xFactorsBinomial"

/*-----------------------------------------------------------------
 *  Factoring Binomial expressions of the form  A X^n � B Y^n,
 *-----------------------------------------------------------------*/

//Retract("xFactorsBinomial",*);
//Retract("xFB1",*);
//Retract("xFB2",*);
//Retract("IsPowerOf2",*);


10 # xFactorsBinomial( poly_IsPolynomial )_(Length(VarList(poly))=1)  <-- 
[
    If(InVerboseMode(),Tell(xFactorsBinomial,poly));
    Local(dis,n,X,var,A,B,s,Ar,Br);
    dis := DisassembleExpression(poly);
    If(InVerboseMode(),Tell("   ",dis));
    n      := Maximum(dis[2])[1];
    X      := dis[1][1];
    var    := dis[1][1];
    A      := Abs(dis[3][1]);
    B      := Abs(dis[3][2]);
    s      := Sign(dis[3][1]*dis[3][2]);
    Ar     := NearRational(N(A^(1/n),20));
    Br     := NearRational(N(B^(1/n),20));
    If(InVerboseMode(),[Tell("       ",{n,X,var,A,B}); Tell("       ",{Ar,Br,s});]);
    If( IsInteger(Ar) And IsInteger(Br), xFB1(dis), {{poly,1}} );
];


10 # xFactorsBinomial( poly_IsPolynomial )_(Length(VarList(poly))=2)  <-- 
[
    If(InVerboseMode(),Tell(xFactorsBinomial,poly));
    Local(dis,n,X,Y,vars,A,B,s,Ar,Br);
    dis := DisassembleExpression(poly);
    If(InVerboseMode(),Tell("   ",dis));
    n     := Maximum(dis[2])[1];
    X     := dis[1][1];
    Y     := dis[1][2];
    vars  := dis[1];
    A     := Abs(dis[3][1]);
    B     := Abs(dis[3][2]);
    s     := Sign(dis[3][1]*dis[3][2]);
    Ar    := NearRational(N(A^(1/n)));
    Br    := NearRational(N(B^(1/n)));
    If(InVerboseMode(),
      [
          Tell("       ",{n,X,Y}); 
          Tell("       ",{vars,A,B});
          Tell("       ",{Ar,Br,s});
      ]
    );
    If( IsInteger(Ar) And IsInteger(Br), xFB2(dis), {{poly,1}} );
];


12 # xFB1( dis_IsList )_(Length(dis)=3 And Length(dis[3])=2) <--
[
    If(InVerboseMode(),[NewLine();Tell("xFB1",dis);]);
    Local(Y,y,ii,fac1);
    X  := Ar*X;     Y  := Br;
    Unbind(y);
    y  := 1;
    If(InVerboseMode(), Tell("     ",{X,Y}));
    fac1  := xFB1( X/Y,n,s);    //  factor using normalized variable
    
    If( InVerboseMode(),Tell("   ",fac1));
    
    // now convert factorization back to actual variable if required
    If( Y != 1,
      [
          Local(f,d);
          For(ii:=1,ii<=Length(fac1),ii++)
          [
              f := fac1[ii][1];
              d := Degree(f,var);
              If(InVerboseMode(),Tell("             ",{ii,f,d}));
              fac1[ii][1] := Simplify(Y^d*f);
          ];
      ]
    );
    fac1;
];
UnFence("xFB1",1);


15 # xFB1(_X,n_IsSmallPrime,s_IsNotZero)_(IsOdd(n)) <--
[
    Local(ans,k);
    If(InVerboseMode(),[NewLine();Tell("   xFB1prime",{X,n,s});]);
    ans := {{X+s,1}};
    If( n > 1, ans := Concat(ans,{{Sum(k,0,n-1,(-s)^k*X^(n-1-k)),1}}) );
    If(InVerboseMode(),Tell("          ",ans));
    ans;
];
UnFence("xFB1",3);


20 # xFB1(_X, n_IsOdd, s_IsPositiveInteger) <--
[
    Local(ans,ans1);
    If(InVerboseMode(),[NewLine(); Tell("   xFB1oddsum",{X,Y,n});]);
    if ( n = 9 )
        [ ans := {{X+1,1},{X^2-X+1,1},{X^6-X^3+1,1}}; ]
    else if ( n = 15 )
        [ ans := {{X+1,1},{X^2-X+1,1},{X^4-X^3+X^2-X+1,1},{X^8+X^7-X^5-X^4-X^3+X+1,1}}; ]
    else if ( n = 21 )
        [ ans := {{X+1,1},{X^2-X+1,1},{X^6-X^5+X^4-X^3+X^2-X+1,1},{X^12+X^11-X^9-X^8+X^6-X^4-X^3+X+1,1}}; ]
    else if ( n = 25 )
        [ ans := {{X+1,1},{X^4-X^3+X^2-X+1,1},{X^20-X^15+X^10-X^5+1,1}}; ]
    else if ( n = 35 )
        [ ans := {{X+1,1},{X^4-X^3+X^2-X+1,1},{X^6-X^5+X^4-X^3+X^2-X+1,1},{X^24+X^23-X^19-X^18-X^17-X^16+X^14+X^13+X^12+X^11+X^10-X^8-X^7-X^6-X^5+X+1,1}}; ]
    else if ( n = 45 )
        [ ans := {{X+1,1},{X^2-X+1,1},{X^4-X^3+X^2-X+1,1},{X^6-X^3+1,1},{X^8+X^7-X^5-X^4-X^3+X+1,1},{X^24+X^21-X^15-X^12-X^9+X^3+1,1}}; ]
    else
        [ ans := BinaryFactors(X^n+1); ];  //  may take a long time, and not be complete
    ans;
];


25 # xFB1(_X,n_IsOdd, s_IsNegativeInteger) <--
[
    Local(ans);
    If(InVerboseMode(),[NewLine(); Tell("   xFB1odddif",{X,n});]);
    if ( n = 9 )
        [ ans := {{X-1,1},{X^2+X+1,1},{X^6+X^3+1,1}}; ]
    else if ( n = 15 )
        [ ans := {{X-1,1},{X^2+X+1,1},{X^4+X^3+X^2+X+1,1},{X^8-X^7+X^5-X^4+X^3-X+1,1}}; ]
    else if ( n = 21 )
        [ ans := {{X-1,1},{X^2+X+1,1},{X^6+X^5+X^4+X^3+X^2+X+1,1},{X^12-X^11+X^9-X^8+X^6-X^4+X^3-X+1,1}}; ]
    else if ( n = 25 )
        [ ans := {{X-1,1},{X^4+X^3+X^2+X+1,1},{X^20+X^15+X^10+X^5+1,1}}; ]
    else if ( n = 35 )
        [ ans := {{X-1,1},{X^4+X^3+X^2+X+1,1},{X^6+X^5+X^4+X^3+X^2+X+1,1},{X^24-X^23+X^19-X^18+X^17-X^16+X^14-X^13+X^12-X^11+X^10-X^8+X^7-X^6+X^5-X+1,1}}; ]
    else if ( n = 45 )
        [ ans := {{X-1,1},{X^2+X+1,1},{X^4+X^3+X^2+X+1,1},{X^6+X^3+1,1},{X^8-X^7+X^5-X^4+X^3-X+1,1},{X^24-X^21+X^15-X^12+X^9-X^3+1,1}}; ]
    else
        [ ans := BinaryFactors(X^n-1); ];  //  may take a long time, and not be complete
    ans;
    If(InVerboseMode(),Tell("    ",ans));
    ans;
];


30 # xFB1(_X, n_IsEven, s_IsPositiveInteger) <--
[
    Local(ans,fn,mx,my);
    If(InVerboseMode(),[NewLine(); Tell("   xFB1evensum",{X,n});]);
    fn    := {{1,1}};
    If( n > 1, fn := FactorsSmallInteger(n) );
    If(Length(fn)=1 And IsOdd(fn[1][1]), mx:= fn[1][1]^(fn[1][2]-1));
    If(Length(fn)>1,
         ForEach(f,fn) [ If( IsOdd(f[1]), mx := f[1]^f[2] ); ]);
    my    := n/mx;
    If(InVerboseMode(),Tell("    ",{mx,my}));

    If( IsPowerOf2(n),
      [
         //  is power of 2,  so does not factor
         ans := {{X^n+1,1}};
      ],
      [
         //  is not power of 2  -- check further
         if ( n = 6 )
             [ ans := {{X^2+1,1},{X^4-X^2+1,1}}; ]
         else if ( n = 10 )
             [ ans := {{X^2+1,1},{X^8-X^6+X^4-X^2+1,1}}; ]
         else if ( n = 20 )
             [ ans := {{X^4+1,1},{X^16-X^12+X^8-X^4+1,1}}; ]
         else if ( n = 30 )
             [ ans := {{X^2+1,1},{X^4-x^2+1,1},{X^8-X^6+X^4-X^2+1,1},{X^16+X^14-X^10-X^8-X^6+X^2+1,1}}; ]
         else if ( n = 40 )
             [ ans := {{X^8+1,1},{X^32-X^24+X^16-X^8+1,1}}; ]
         else if ( n = 50 )
             [ ans := {{X^2+1,1},{X^8-X^6+X^4-X^2+1,1},{X^40-X^30+X^20-X^10+1,1}}; ]
         else if ( n = 100 )
             [ ans := {{X^4+1,1},{X^16-X^12+X^8-X^4+1,1},{X^80-X^60+X^40-X^20+1,1}}; ]
         else
             [ ans := {{X^my+1,1},{Sum(k,0,mx-1,X^(n-my-k*my)*(-1)^k),1}}; ];
      ]
    );
    If(InVerboseMode(),Tell("    ",ans));
    ans;
];


35 # xFB1(_X, n_IsEven, s_IsNegativeInteger) <--
[
    Local(ans);
    If(InVerboseMode(),[NewLine(); Tell("   xFB1evendif",{X,n});]);
    if ( n = 2 )
        [ ans := {{X-1,1},{X+1,1}}; ]
    else if ( n = 10 )
        [ ans := {{X-1,1},{X+1,1},{X^4+X^3+X^2+X+1,1},{X^4-X^3+X^2-X+1,1}}; ]
    else if ( n = 20 )
        [ ans := {{X-1,1},{X+1,1},{X^2+1,1},{X^4+X^3+X^2+X+1,1},{X^4-X^3+X^2-X+1,1},{X^8-X^6+X^4-X^2+1,1}}; ]
    else if ( n = 30 )
        [ ans := {{X-1,1},{X+1,1},{X^2+X+1,1},{X^2-X+1,1},{X^4+X^3+x^2+X+1,1},{X^4-X^3+x^2-X+1,1},{X^8-X^7+X^5-X^4+X^3-X+1,1},{X^8+X^7-X^5-X^4-X^3+X+1,1}}; ]
    else if ( n = 40 )
        [ ans := {{X-1,1},{X+1,1},{X^2+1,1},{X^4+1,1},{X^4+X^3+X^2+X+1,1},{X^4-X^3+X^2-X+1,1},{X^8-X^6+X^4-X^2+1,1},{X^16-X^12+X^8-X^4+1,1}}; ]
    else if ( n = 50 )
        [ ans := {{X-1,1},{X+1,1},{X^4+X^3+X^2+X+1,1},{X^4-X^3+X^2-X+1,1},{X^20+X^15+X^10+X^5+1,1},{X^20-X^15+X^10-X^5+1,1}}; ]
    else if ( n = 100 )
        [ ans := {{X-1,1},{X+1,1},{X^2+1,1},{X^4+X^3+X^2+X+1,1},{X^4-X^3+X^2-X+1,1},{X^8-X^6+X^4-X^2+1,1},{X^20+X^15+X^10+X^5+1,1},{X^20-X^15+X^10-X^5+1,1},{X^40-X^30+X^20-X^10+1,1}};]
    else
        [ ans := Concat( xFB1(X,n/2,1), xFB1(X,n/2,-1) ); ];   
        
    If(InVerboseMode(),Tell("    ",ans));
    ans;
];



50 # xFB2( dis_IsList )_(Length(dis)=3 And Length(dis[3])=2) <--
[
    If(InVerboseMode(),[NewLine();Tell("xFB2",dis);]);
    Local(ns,ii,fn,mx,my,fac2);
    If(InVerboseMode(),
      [
         Tell("     ",n);
         Tell("     ",{X,Y});
         Tell("     ",{A,B,s});
         Tell("     ",{Ar,Br});
      ]
    );
    X     := Ar*X;
    Y     := Br*Y;
    If(InVerboseMode(),Tell("     ",{X,Y}));
    
    fac2  := xFB1( X/Y,n,s);    //  factor using normalized variable
    If(InVerboseMode(),Tell("      ",fac2));
    
    // now convert factorization back to actual variables if required

    If( Y != 1,
      [
          Local(f,d);
          For(ii:=1,ii<=Length(fac2),ii++)
          [
              f := fac2[ii][1];
              d := Degree(f,vars[1]);
              If(InVerboseMode(),Tell("             ",{ii,f,d}));
              fac2[ii][1] := Simplify(Simplify(Y^d*f));
          ];
      ]
    );
    fac2;
];
UnFence("xFB2",1);


IsPowerOf2( n_IsPositiveInteger ) <-- [ Count(StringToList(ToBase(2,n)),"1") = 1; ];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper,title="testing"

//Retract("TestPlus1",*);
//Retract("TestMinus1",*);


1000 # TestMinus1() <--
[
    Local(n,poly,a,b,result,prod,ok);
    NewLine(1);
    Tell("Test Binomial Dif, 1 Variable");
    a := 2;
    b := 3;
    For(n:=2,n<=12,n++)
    [
        poly   := ExpandBrackets(a^n*x^n-b^n);
        result := xFactorsBinomial(poly);
        prod   := ExpandBrackets(FW(result));
        ok     := Verify(a^n*x^n-b^n,prod);
        NewLine(1);
        Tell("    ",poly);
        If(InVerboseMode(),
          [
             Tell("         ",result);
             Tell("         ",prod);
          ]
        );
        Tell("    ",ok);
    ];
];


1000 # TestPlus1() <--
[
    Local(n,poly,a,b,result,prod,ok);
    NewLine(1);
    Tell("Test Binomial Sum, 1 Variable");
    a := 2;
    b := 3;
    For(n:=2,n<=12,n++)
    [
        poly   := ExpandBrackets(a^n*x^n+b^n);
        result := xFactorsBinomial(poly);
        prod   := ExpandBrackets(FW(result));
        ok     := Verify(a^n*x^n+b^n,prod);
        NewLine(1);
        Tell("    ",poly);
        If(InVerboseMode(),
          [
             Tell("         ",result);
             Tell("         ",prod);
          ]
        );
        Tell("    ",ok);
    ];
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorsBinomials.mpw0000644000175000017500000000424211517224250030712 0ustar  giovannigiovanni%mathpiper,title="FactorsBinomials"

//Retract("FactorsBinomials",*);

10 # FactorsBinomials( _x + y_IsFreeOf(x) ) <-- {x+y,1};

10 # FactorsBinomials( _x - y_IsFreeOf(x) ) <-- {x-y,1};

10 # FactorsBinomials( c_IsConstant * _x + y_IsFreeOf(x) ) <-- {c*x+y,1};

10 # FactorsBinomials( c_IsConstant * _x - y_IsFreeOf(x) ) <-- {c*x-y,1};

10 # FactorsBinomials( _x^m_IsOdd + _y ) <--
[
    If(InVerboseMode(),Tell("FactorsBinomialssum",{x,m,y}));
    Local(nn,qq);
    nn := (m-1)/2;
    qq := (y^(1/m));
    If(InVerboseMode(),Tell("  FBinsum1",{nn,qq}));
    r := {{x+qq,1},{Sum(k,0,m-1,(-1)^k*qq^k*x^(m-1-k)),1}};
];


12 # FactorsBinomials( c_IsConstant * _x^m_IsOdd + _y ) <--
[
    If(InVerboseMode(),Tell("FactorsBinomialssum",{c,x,m,y}));
    Local(nn,qq);
    nn := (m-1)/2;
    qq := ((y/c)^(1/m));
    If(InVerboseMode(),Tell("  FBinsum.1b",{nn,qq}));
    If( c=1,
          r := {{x+qq,1},{Sum(k,0,m-1,(-1)^k*qq^k*x^(m-1-k)),1}},
          r := {{c,1},{x+qq,1},{Sum(k,0,m-1,(-1)^k*qq^k*x^(m-1-k)),1}}
    );  
];


10 # FactorsBinomials( _x^m_IsInteger - _y ) <--
[
    If(InVerboseMode(),Tell("FactorsBinomialsdif",{x,m,y}));
    Local(pp,qq,r,L);
    pp := m-1;
    qq := (y^(1/m));
    If(IsNumber(y),qq:=GuessRational(N(qq)));
    If(InVerboseMode(),Tell("  FBindif.1",{pp,qq}));
    
    if      (m = 2)
        [
            L := FunctionToList(y);
            If(And(L[1]=ToAtom("^"),L[3]=2),qq:=L[2]);
            r := {{x+qq,1},{x-qq,1}};
        ]
    else if (m = 4)
        [r := {{x+qq,1},{x-qq,1},{x^2+qq^2,1}};]
    else if (m = 6)
        [r := {{x+qq,1},{x-qq,1},{x^2+x*qq+qq^2,1},{x^2-x*qq+qq^2,1}};]
    else
        [r := {{x-qq,1},{Sum(k,0,pp,qq^k*x^(pp-k)),1}};];
    r;
];


12 # xFactorsBinomials( c_IsConstant * _x^m_IsInteger - _y ) <--
[
    If(InVerboseMode(),Tell("FactorsBinomialsdif",{c,x,m,y}));
    Local(aa,bb,c0,r);
    aa := c^(1/m);
    bb := ((y)^(1/m));
    If(IsNumber(y),bb:=GuessRational(N(bb)));
    If(InVerboseMode(),Tell("  FBindif.1b",{aa,bb}));
    r  := FactorsBinomials( (aa*x)^m - bb^m );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/YacasFactors.mpw0000644000175000017500000002047411523200452030035 0ustar  giovannigiovanni%mathpiper,def="YacasFactors"

//Retract("YacasFactors",*);
//Retract("FactorsMultivariateSpecialCases",*);
//Retract("FactorsSomethingElse",*);
//Retract("CombineNumericalFactors",*);

/*
 * This is the fundamental factorization algorithm as created for Yacas, with
 * a few improvements.
 * It works for integers, rational numbers, Gaussian integers, and polynomials
 * When the argument is an integer, FactorizeInt() does the heavy lifting.
 * When the argument is a polynomial, BinaryFactors() is the workhorse.
 */
 

10 # YacasFactors(p_IsPositiveInteger) <--  FactorizeInt(p);

11 # YacasFactors(p_IsInteger) <-- FactorizeInt(p);

12 # YacasFactors(p_IsRational)_(Denominator(p) != 1) <-- {{YacasFactor(Numerator(p)) /YacasFactor(Denominator(p)) , 1}}; 
     //Added to handle rational numbers with denominators that are not 1

14 # YacasFactors(p_IsGaussianInteger)	<-- GaussianFactors(p);

20 # YacasFactors(p_CanBeUni)_(Length(VarList(p)) = 1) <--  
[
    Local(x,d,coeffs,nterms,factorsList,result);
    x := VarList(p)[1];
    d := Degree(p,x);
    /*  p is the polynomial, x is its (only) variable.  It IS Univariate */
    /*  Let's find out how many terms this polynomial has.               */
    coeffs := Coef(p,x,0 .. Degree(p,x));
    nterms := Length(Select(coeffs, "IsNotZero"));
    /*  If nterms = 2, it is a binomial, and might be most easily
     *  factored by some special-purpose algorithms                      */
    If( nterms = 2 And d > 2, 
      [  result := FactorsBinomials(p);  ],    
      [  // nterms != 2, so try other techniques
        factorsList := BinaryFactors(p);
           // BinaryFactors is the internal MathPiper function that
           // creates a double list of factors and their multiplicities
        /*
         *  Now we check whether the input polynomial is "over the 
         *  integers", by examining all its coefficients
         */
        If( AllSatisfy("IsInteger",coeffs),
          [
              // Yes -- all integer coefficients
              result := FactorsPolynomialOverIntegers(p,x);
          ],
          [
              // No -- at least one non-integer coefficient
              // Check for FLOAT or RATIONAL coefficients
              Local(notInt,rat,dd,lcm,newCoeffs,NewPoly,facs);
              notInt := Select(coeffs, Lambda({i},Not IsInteger(i)));
              rat := Rationalize(coeffs);            
              dd  := MapSingle("Denominator",rat);
              lcm := Lcm(dd);
              newCoeffs := lcm * rat;
              newPoly := NormalForm(UniVariate(x,0,newCoeffs));
              facs := FactorsPolynomialOverIntegers(newPoly);
              If( InVerboseMode(), [
                  Echo("coeffs ",coeffs);
                  Echo("notInt ",notInt);
                  Echo("rat ",rat);
                  Echo("dd  ",dd);
                  Echo("lcm ",lcm);
                  Echo("newCoeffs ",newCoeffs);
                  Echo("newPoly ",newPoly);
                  Echo("facs ",facs);
                 ]
              );
              result := {(1/lcm),1}:facs;
              //NOT FINISHED YET
        ]
      );
    ]
   );
      CombineNumericalFactors( result );
];


30 # YacasFactors(p_CanBeUni) <--  
[
    /* 
     * This may be a multi-variate polynomial, or it may be something else.
     * Original YT function Factors() did not attempt to factor such.
     *    If it is a multivariate polynomial, we will try certain
     * Special cases which we can relatively easily factor.
     *    If it is "something else", we will have to check, on a
     * case-by-case basis.
     */
    Local(vl,nvars,coeffs,result);
    vl     := VarList(p);
    nvars  := Length(vl);
    coeffs := Coef(p,x,0 .. 8);
    If(InVerboseMode(),Tell("CBU",{vl,nvars,coeffs}));
    If (nvars > 1, 
         [
            If( InVerboseMode(), Echo(" special ",p));
            result := FactorsMultivariateSpecialCases(p);
         ], 
            result := FactorsSomethingElse(p) 
       );
       CombineNumericalFactors( result );
];


40 # YacasFactors(_p) <--
[
    /*
     * This may may be a polynomial with non-integer exponents.  Let's check.
     */
     If( InVerboseMode(), Echo("Possibly trying to factor polynomial with non-integral exponents") );
     Local( result);
     //Echo(40,p);
     //  NOT IMPLEMENTED YET
     result := {{p,1}};
     CombineNumericalFactors( result );
     
];

//------------------------------------------------------------------------
//                    S P E C I A L     C A S E S
//------------------------------------------------------------------------

10 # FactorsMultivariateSpecialCases(-_expr) <-- {-1,1}:FactorsMultivariateSpecialCases(expr);

10 # FactorsMultivariateSpecialCases(x_IsAtom + y_IsAtom) <-- [If(InVerboseMode(),Tell(1));{{x+y,1}};];

10 # FactorsMultivariateSpecialCases(x_IsAtom - y_IsAtom) <-- [If(InVerboseMode(),Tell(2));{{x-y,1}};];

10 # FactorsMultivariateSpecialCases(_n*_x^p_IsInteger + _n*_y) <-- [If(InVerboseMode(),Tell(3));{n,1}:FactorsMultivariateSpecialCases(x+y);];

10 # FactorsMultivariateSpecialCases(_n*_x^p_IsInteger - _n*_y) <-- [If(InVerboseMode(),Tell(4));{n,1}:FactorsMultivariateSpecialCases(x-y);];

10 # FactorsMultivariateSpecialCases(n_IsInteger*_x + m_IsInteger*_y)_(Gcd(n,m)>1) <-- {{Gcd(n,m),1},{(Simplify((n*x+m*y)/Gcd(n,m))),1}};

10 # FactorsMultivariateSpecialCases(n_IsInteger*_x - m_IsInteger*_y)_(Gcd(n,m)>1) <-- {{Gcd(n,m),1},{(Simplify((n*x-m*y)/Gcd(n,m))),1}};

10 # FactorsMultivariateSpecialCases(_n*_x + _n*_y) <-- {n,1}:FactorsMultivariateSpecialCases(x+y);

10 # FactorsMultivariateSpecialCases(_n*_x - _n*_y) <-- {n,1}:FactorsMultivariateSpecialCases(x-y);

10 # FactorsMultivariateSpecialCases(_x^n_IsInteger - _y) <-- FactorsBinomials(x^n - y); 

10 # FactorsMultivariateSpecialCases(_x^n_IsInteger + _y) <-- FactorsBinomials(x^n + y); 

20 # FactorsSomethingElse(_p) <-- 
  [
      If( InVerboseMode(),
          [
              ECHO("   *** FactorsSomethingElse: NOT IMPLEMENTED YET ***");
          ]
      );
      p;
  ];

//------------------------------------------------------------------------


10 # CombineNumericalFactors( factrs_IsList ) <--
  [
      If( InVerboseMode(), Tell("Combine",factrs) );
      Local(q,a,b,t,f,err);
      err := False;
      t   := 1;
      f   := {};
      ForEach(q,factrs)
      [
          If( InVerboseMode(), Tell(1,q) );
          If( IsList(q) And Length(q)=2,
              [
                  {a,b} := q;
                  If( InVerboseMode(), Echo("     ",{a,b}) );
                  If( IsNumericList( {a,b} ),
                      t := t * a^b,
                      f := {a,b}:f
                  );
              ],
              err := True
          );
      ];
      If( InVerboseMode(),
        [
            Echo("      t = ",t);
            Echo("      f = ",f);
            Echo("    err = ",err);
        ]
      );
      If(Not err And t != 1, {t,1}:Reverse(f), factrs);
  ];

%/mathpiper





%mathpiper_docs,name="YacasFactors",categories="User Functions;Number Theory"
*CMD YacasFactors --- factorization
*STD
*CALL
	YacasFactors(x)

*PARMS

{x} -- integer or univariate polynomial

*DESC

This is mostly the original Yacas version of the function Factors(),
slightly modified for Mathpiper to improve some of its capabilities.
It has now been superceeded in MathPiper by the function xFactors(),
which has a large number of improvements.

This function decomposes the integer number {x} into a product of
numbers. 
Alternatively, if {x} is a univariate polynomial, it is
decomposed into irreducible polynomials.  If {x} is a polynomial
"over the integers", the irreducible polynomial factors will also
be returned in the (unique) form with integer coefficients.

The factorization is returned as a list of pairs. The first member of
each pair is the factor, while the second member denotes the power to
which this factor should be raised. So the factorization
$x = p1^n1 * ... * p9^n9$
is returned as {{{p1,n1}, ..., {p9,n9}}}.

Programmer: Yacas Team + Sherm Ostrowsky

*E.G.
In> YacasFactors(24)
Result: {{2,3},{3,1}}

In> YacasFactors(32*x^3+32*x^2-70*x-75)
Result: {{4*x+5,2},{2*x-3,1}}

*SEE YacasFactor, xFactors, IsPrime, GaussianFactors
%/mathpiper_docs





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/BinaryFactors.mpw0000644000175000017500000001473511331203122030216 0ustar  giovannigiovanni%mathpiper,def="BinaryFactors",public="todo"

LocalSymbols(lastcoef,OrdBuild, AddFoundSolutionSingle , AddFoundSolution, Fct, MkfactD,p)
[

LastCoef(_vector,_p) <--
[
  Local(n);
  n:=Length(vector);
  Add(vector*p^(0 .. (n-1)));
];

/*
Ord(vector,q):=
[
  Local(n);
  n:=Length(vector);
  q*Coef(Simplify(LastCoef(vector,p+q)-LastCoef(vector,p)),q,1);
];
*/

OrdBuild(vector,q):=
[
  Local(i,result,n);
  Bind(i,2);
  Bind(result, 0);
  Bind(n, Length(vector));
  While (i<=n)
  [
    Bind(result,result+(i-1)*vector[i]*p^(i-2));
    Bind(i, i+2);
  ];
  q*result;
];


Function(AddFoundSolutionSingle,{p})
[
  Local(calc);
//  If ( Not Contains(result,p),
//  [
    Bind(calc, Eval(lastcoef));
    If (IsEqual(calc, 0),
    [
      Local(newlist,count,root);
      count:=0;
      root := p;
      Local(rem);

      rem:={-root,1};
      {testpoly,rem}:=MkfactD(testpoly,rem);

      rem:={-root,1};
      {newlist,rem}:=MkfactD(poly,rem);
      While (rem = {})
      [
        count++;
        Bind(poly,newlist);
        rem:={-root,1};
        {newlist,rem}:=MkfactD(poly,rem);
      ];

      Local(lgcd,lc);
      Bind(lgcd,Gcd({andiv,an,root}));
      Bind(lc,Quotient(an,lgcd));
      Bind(result,{var+ (-(Quotient(root,lgcd)/lc)),count}:result);
      Bind(andiv,Quotient(andiv,lgcd^count));
      Bind(anmul,anmul*lc^count);

//      factor:=(x-root);
//      Bind(result,{factor,count}:result);

      Local(p,q);
      Bind(lastcoef, LastCoef(testpoly,p));
      Bind(ord, OrdBuild(testpoly,q));
    ]);
//  ]);
];
UnFence(AddFoundSolutionSingle,1);

Function(AddFoundSolution,{p})
[
  AddFoundSolutionSingle(p);
  AddFoundSolutionSingle(-2*q+p);
];
UnFence(AddFoundSolution,1);

Function(Fct,{poly,var})
[
  Local(maxNrRoots,result,ord,p,q,accu,calc,twoq,mask);

  Local(gcd);
  [
    Bind(gcd,Gcd(poly));
    If(poly[Length(poly)] < 0,Bind(gcd, gcd * -1));
    Bind(poly,poly/gcd);
  ];

  Local(unrat);
  Bind(unrat,Lcm(MapSingle("Denominator",poly)));
  Bind(poly,unrat*poly);

  Local(origdegree);
  Bind(origdegree,Length(poly)-1);

  Local(an,andiv,anmul);
  Bind(an,poly[Length(poly)]);
  Bind(poly,poly* (an^((origdegree-1) .. -1)));
  Bind(andiv,an^(origdegree-1));
  Bind(anmul,1);

  Local(leadingcoef,lowestcoef);
  Bind(leadingcoef,poly[Length(poly)]);
  [
    Local(i);
    Bind(i,1);
    Bind(lowestcoef,Abs(poly[i]));
    While (lowestcoef = 0 And i<=Length(poly))
    [
      Bind(i,i+1);
      Bind(lowestcoef,Abs(poly[i]));
    ];
  ];
  // testpoly is the square-free version of the polynomial, used for finding
  // the factors. the original polynomials is kept around to find the
  // multiplicity of the factor.
  Local(testpoly);
//  Bind(testpoly,Mkc(Quotient(polynom,Monic(Gcd(polynom,Deriv(var)polynom))),var));
  Local(deriv);
  // First determine a derivative of the original polynomial
  deriv:=Rest(poly);
  [
    Local(i);
    For (i:=1,i<=Length(deriv),i++)
    [
      deriv[i] := deriv[i]*i;
    ];
//    Echo("POLY = ",poly);
//    Echo("DERIV = ",deriv);
  ];
  [
    Local(q,r,next);
    q:=poly;
    r:=deriv;
    While(r != {})
    [
//Echo(q,r);
      next := MkfactD(q,r)[2];
      q:=r;
      r:=next;
    ];
    // now q is the gcd of the polynomial and its first derivative.

    // Make it monic
    q:=q/q[Length(q)];
    testpoly:=MkfactD(poly,q)[1];
//Echo("TESTPOLY = ",testpoly);
  ];

//  Bind(testpoly,poly); //@@@

  Bind(maxNrRoots,Length(testpoly)-1);
  Bind(result, {});

  Bind(lastcoef, LastCoef(testpoly,p));
  Bind(ord, OrdBuild(testpoly,q));

  Bind(accu,{});
  Bind(q,1);
  Bind(twoq,MultiplyN(q,2));
  Bind(mask,AddN(twoq,MathNegate(1)));
  if (IsEven(testpoly[1]))
  [
    Bind(accu,0:accu);
    AddFoundSolutionSingle(0);
  ];
  Bind(p,1);
  Bind(calc, Eval(lastcoef));
  If (IsEven(calc),
  [
    Bind(accu,1:accu);
    AddFoundSolution(1);
  ]);
  Bind(q,twoq);
  Bind(twoq,MultiplyN(q,2));
  Bind(mask,AddN(twoq,MathNegate(1)));
  While(Length(result)0 And q<=Abs(testpoly[1]))
  [
    Local(newaccu);
    Bind(newaccu,{});
    ForEach(p,accu)
    [
      Bind(calc,Eval(lastcoef));
      If (IsLessThan(calc,0),
        Bind(calc, AddN(calc,MultiplyN(twoq,QuotientN(AddN(MathNegate(calc),twoq),twoq))))
         );
      Bind(calc, BitAnd(calc, mask));
      If ( IsEqual(calc, 0),
      [
        Bind(newaccu, p:newaccu);
        AddFoundSolutionSingle(-2*q+p);
      ]);
      Bind(calc, AddN(calc, Eval(ord)));
      If (IsLessThan(calc,0),
        Bind(calc, AddN(calc,MultiplyN(twoq,QuotientN(AddN(MathNegate(calc),twoq),twoq))))
         );
      Bind(calc, BitAnd(calc, mask));
      If ( IsEqual(calc, 0),
      [
        Bind(newaccu, AddN(p,q):newaccu);
        AddFoundSolution(AddN(p,q));
      ]);
    ];
    Bind(accu, newaccu);
    Bind(q,twoq);
    Bind(twoq,MultiplyN(q,2));
    Bind(mask,AddN(twoq,MathNegate(1)));

//Echo("q = ",q);
//Echo("Length is",Length(accu),"accu = ",accu);
//Echo("result = ",result);
  ];

  // If the polynom is not one, it is a polynomial which is not reducible any further
  // with this algorithm, return as is.
  Bind(poly,poly*an^(0 .. (Length(poly)-1)));
  Bind(poly,gcd*anmul*poly);
  //TODO had to add this if statement, what was andiv again, and why would it become zero? This happens with for example Factor(2*x^2)
  If(Not IsZero(unrat * andiv ),Bind(poly,poly/(unrat * andiv )));
  If(poly != {1},
  [
    result:={(Add(poly*var^(0 .. (Length(poly)-1)))),1}:result;
  ]);
  result;
];



BinaryFactors(expr):=
[
  Local(result,uni,coefs);
  uni:=MakeUni(expr,VarList(expr)[1]);
  uni:=FunctionToList(uni);
  coefs:=uni[4];
  coefs:=Concat(ZeroVector(uni[3]),coefs);
  result:=Fct(coefs,uni[2]);
//  Echo(result,list);
//  Echo((Add(list*x^(0 .. (Length(list)-1)))));
//  Product(x-result)*(Add(list*x^(0 .. (Length(list)-1))));
  result;
];



MkfactD(numer,denom):=
[
  Local(q,r,i,j,ln,ld,nq);
  DropEndZeroes(numer);
  DropEndZeroes(denom);
  Bind(numer,Reverse(numer));
  Bind(denom,Reverse(denom));
  Bind(ln,Length(numer));
  Bind(ld,Length(denom));
  Bind(q,FillList(0,ln));
  Bind(r,FillList(0,ln));

  Bind(i,1);
  If(ld>0,
  [
    While(Length(numer)>=Length(denom))
    [
      Bind(nq,numer[1]/denom[1]);
      q[ln-(Length(numer)-ld)] := nq;
      For(j:=1,j<=Length(denom),j++)
      [
        numer[j] := (numer[j] - nq*denom[j]);
      ];
      r[i] := r[1] + numer[1];

      Bind(numer, Rest(numer));
      i++;
    ];
  ]);
  For(j:=0,j FactorsMonomial(24)
Result: {{24,1}}

In> FactorsMonomial(24/15)
Result: {{8/5,1}}

In> FactorsMonomial(24*a*x^2*y^3)
Result: {{24,1},{a,1},{x,2},{y,3}}

In> FactorsMonomial(24*a*x^2*y^3/15)
Result: {{8/5,1},{a,1},{x,2},{y,3}}

In> FactorsMonomial(24*a*x^2*y^3/15+1)
Result: FactorsMonomial((24*a*x^2*y^3)/15+1)
    
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/jFactorsPoly.mpw0000644000175000017500000003752011577457731030121 0ustar  giovannigiovanni%mathpiper,title="jFactorsPoly"

/* -------------    POLYNOMIALS -- CAN BE UNI   --------------*/

50 # jFactorsPoly( poly_CanBeUni ) <--
[
    If(InVerboseMode(),Tell("jFactorsPoly_100612",poly));
    Local(content,pp,ppFactors,monomialFactors,result,moreDetails);
    Local(vars,nvars,nterms);
    Local(isHomogeneous);
    Local(extraFactor);
    
    moreDetails := False;

    If(HasRealCoefficients(poly), poly := RealToRationalConvert(poly));
    If(HasRationalCoefficients(poly), poly := RationalToIntegerConvert(poly));

    // Now: get Content and Primitive Part
    content := xContent( poly );
    pp      := Simplify( poly / content );
    If(IsBound(extraFactor),content := content / extraFactor);
    If(InVerboseMode(),Tell("   ",{content,pp}));
    //If(IsConstant(pp) And Length(VarList(content))>0,{content,pp}:={pp,content});
    If( Length(VarList(pp))=0, result := {{pp*content,1}},
      [
         Local(disassem);
         //If(InVerboseMode(),Tell("  ",{content,pp}));
         vars     := VarList(pp);
         nvars    := Length(vars);
         disassem := DisassembleExpression(pp);
         nterms   := Length(disassem[3]);

         If(nvars > 0,
           [
             isHomogeneous     := [
                 // A polynomial is homogeneous of degree n 
                 // if all terms have degree n.   
                 Local(sd,cmp); 
                 sd  := Sum /@ disassem[2];
                 cmp := FillList(sd[1],Length(sd));
                 IsZeroVector(sd - cmp);
             ];
           ]
         );
    
         If(InVerboseMode() And moreDetails,
           [
             Local(degrees, allCoeffs, allPowers);

             degrees := {};
             ForEach(v,vars) [ DestructiveAppend(degrees,Degree(pp,v)); ];
             allCoeffs := disassem[3];
             allPowers := Flatten(disassem[2],"List");

             Tell("               ",vars);
             Tell("              ",nvars);
             Tell("             ",nterms);
             Tell("            ",degrees);
             Tell("           ",disassem);
             Tell("          ",allCoeffs);
             Tell("          ",allPowers);
             Tell("      ",isHomogeneous);
             NewLine();
           ]
         );
    
         //  Does the Content have factors?  If so, get them.
         //If(InVerboseMode(),NewLine());
         monomialFactors := FactorsMonomial(content);
         If(InVerboseMode(),Tell("  ",monomialFactors));
    
         //  OK.  Now factor the PrimitivePart
         ppFactors := jFactorsPrimitivePart( pp );
         If(InVerboseMode(),Tell("                    ",ppFactors));
         If( Not IsListOfLists(ppFactors), 
           [
               Local(L,op,var,exp);
               L := If(IsAtom(ppFactors[1]), ppFactors, FunctionToList(ppFactors[1]) );
               If(InVerboseMode(),Tell("                    ",L));
               If( L[1] = ^, ppFactors := {L[2],L[3]} );
               ppFactors := {ppFactors};
           ]
         );
         If(InVerboseMode(),Tell("  ",ppFactors));
    
         // Next, include the factors of the Content, if any
         If( monomialFactors[1][1] = 1,
             result := ppFactors,        
             result := Concat(monomialFactors,ppFactors)      // hso 100803
         );
      ]
    );
    
    If(InVerboseMode(),
      [
          NewLine();
          Tell("  ",monomialFactors);
          Tell("        ",ppFactors);
          Tell("  final    ",result);
      ]
    );
    result;
];
UnFence("jFactorsPoly",1);



// -----------------  FACTOR PRIMITIVE PART  -----------------

     //  special case: binomials
60 # jFactorsPrimitivePart( _pp )_(isHomogeneous And nterms=2 And nvars=2) <--
[
    If(InVerboseMode(),Tell("Bivariate Binomial",pp));
    Local(ppFactors,isDiagonal);
    isDiagonal := IsDiagonal(disassem[2]);   //  mod hso 10-11-25
    ppFactors := If(isDiagonal,jFactorsBivariateBinomial(pp),jasFactorsInt(pp) );
];
UnFence("jFactorsPrimitivePart",1);


     //  special case: homogeneous bivariates
65 # jFactorsPrimitivePart( _pp )_(isHomogeneous And nterms>1 And nvars=2) <--
[
    If(InVerboseMode(),Tell("Homogeneous and Bivariate"));
    Local(ppFactors);
    ppFactors := jFactorsHomogeneousBivariate(disassem);
];
UnFence("jFactorsPrimitivePart",1);


     //  special case:  no variables in pp!
70 # jFactorsPrimitivePart( _pp )_(nvars=0) <--
[
    Local(ppFactors);
    ppfactors := {};
];


     //  general case
100 # jFactorsPrimitivePart( _pp ) <-- 
[
    If(InVerboseMode(),Tell("jFactorsPrimitivePart_usingJAS",pp));
    Local(answer);
    answer := If(IsMonomial(pp),{pp,1},jasFactorsInt(pp));
    If(InVerboseMode(),Tell("          ",answer));
    answer;
];
UnFence("jFactorsPrimitivePart",1);

// ------------------  HOMOGENEOUS BIVARIATE  ------------------

10 # jFactorsHomogeneousBivariate( dis_IsList ) <-- 
[
    If(InVerboseMode(),[NewLine();Tell("jFactorsHomogeneousBivariate",dis);]);
    Local(dis1,f,dis2,poly1,ppFactors,residuals);
    Local(ii,lst,f,preassem);
    dis1  := {{xi},{{X},{X[1]}} /@ dis[2],dis[3]};
    If(InVerboseMode(),Tell("   ",dis1));
    poly1 := Sum(ReassembleListTerms(dis1));
    If(InVerboseMode(),Tell("   ",poly1));
    ppFactors := BinaryFactors(poly1);
    {ppFactors,residuals} := FixUpMonicFactors(ppFactors);
    For(ii:=1,ii<=Length(ppFactors),ii++)
    [
        f := ppFactors[ii];
        If(InVerboseMode(),Tell("          ",f[1]));
        lst := DisassembleExpression(f[1]);
        If(InVerboseMode(),
          [
             Tell("               ",lst);
             Tell("                            ",dis[1]);
          ]
        );
        DestructiveReplace(lst,1,dis[1]);
        DestructiveAppend(lst[2][1],0);
        DestructiveAppend(lst[2][2],1);
        If(Length(lst[2])=3, DestructiveAppend(lst[2][3],2));
        If(InVerboseMode(),Tell("               ",lst));
        preassem  := Sum(ReassembleListTerms(lst)) ;
        If(InVerboseMode(),Tell("               ",preassem));
        ppFactors[ii][1] := preassem;
    ];
    If(InVerboseMode(),[Tell("   ",ppFactors); Tell("   ",residuals);NewLine();] );  
    ppFactors;
];
UnFence("jFactorsHomogeneousBivariate",1);

// ---------------------   OTHER STUFF ------------------------

10 # RealToRationalConvert( poly_IsPolynomial ) <--
[
    // If the polynomial has REAL coefficients, convert them to
    // approximate RATIONALS
    If(InVerboseMode(),[NewLine();Tell("  REAL",poly);]);
    Local(disassem,coeffs);
    disassem := DisassembleExpression(poly);
    coeffs := Rationalize /@ disassem[3];
    If(InVerboseMode(), [
        Local(gcd,lcm);
        gcd    := Gcd(Numerator /@ coeffs);
        lcm    := Lcm(Denominator /@ coeffs);
        Tell("      to-Q",coeffs);
        Tell("       ",gcd);
        Tell("       ",lcm);
    ]);
    disassem[3] := coeffs;
    poly        := Sum(ReassembleListTerms(disassem));
    If(InVerboseMode(),Tell("   new",poly));
    poly;
];
UnFence("RealToRationalConvert",1);


10 # RationalToIntegerConvert( poly_IsPolynomial ) <--
[
    // If the polynomial has RATIONAL coefficients, convert to
    // approximate INTEGER
    Local(coeffs,gcd,lcm);
    coeffs := DisassembleExpression(poly)[3];
    If(InVerboseMode(),Tell("  ",coeffs));
    lcm         := Lcm(Denominator /@ coeffs);
    extraFactor := lcm;
    If(InVerboseMode(),[Tell("     ",extraFactor);]);
    poly := Simplify(extraFactor*poly);
    If(InVerboseMode(),Tell("  new ",poly));
    poly;
];
UnFence("RationalToIntegerConvert",1);


100 # CombineNumericalFactors( factrs_IsList ) <--
[
      If( InVerboseMode(), Tell("Combine",factrs) );
      Local(q,a,b,t,f,ff,err);
      err := False;
      t   := 1;
      f   := {};
      ForEach(q,factrs)
      [
          If( InVerboseMode(), Tell(1,q) );
          If( IsList(q) And Length(q)=2,
            [
                {a,b} := q;
                If( InVerboseMode(), Echo("     ",{a,b}) );
                If( IsNumericList( {a,b} ),
                    t := t * a^b,
                    f := {a,b}:f
                );
            ],
              err := True
          );
      ];
      If( InVerboseMode(),
        [
            Echo("      t = ",t);
            Echo("      f = ",f);
            Echo("    err = ",err);
        ]
      );
      ff := If(Not err And t != 1, {t,1}:Reverse(f), factrs);
      ff := Select(Lambda({x},x!={1,1}),ff);
      If(ff[1]<0,ff[1]:=-ff[1]);
];


// ----------------  RATIONAL POLYNOMIALS  -----------------

150 # jFactors( expr_IsRationalFunction )_
        (IsPolynomial(Numerator(expr)) And IsPolynomial(Denominator(expr))) <--
[
    If(InVerboseMode(),[NewLine();Tell("jFactors_Rational_Function",expr);]);
    Local(Numer,Denom,fNumer,fDenom);
    Numer  := Numerator(expr);
    Denom  := Denominator(expr);
    fNumer := jFactors(Numer);
    fDenom := jFactors(Denom);
    If(InVerboseMode(),[Tell("   ",fNumer); Tell("   ",fDenom);]);
    fNumer/fDenom;
];


152 # jFactors( expr_IsRationalFunction )_
        (IsConstant(Numerator(expr)) And IsPolynomial(Denominator(expr))) <--
[
    If(InVerboseMode(),[NewLine();Tell("jFactors_Rational_Denom",expr);]);
    Local(Numer,Denom,fNumer,fDenom);
    Numer  := Numerator(expr);
    Denom  := Denominator(expr);
    fNumer := jFactors(Numer);
    fDenom := jFactors(Denom);
    If(InVerboseMode(),[Tell("   ",fNumer); Tell("   ",fDenom);]);
    fNumer/fDenom;
];


// ----------   POSSIBLE NON-INTEGER EXPONENTS  ----------

200 # jFactors( _expr )_(Length(VarList(expr)) = 1) <--
[
    If(InVerboseMode(),[NewLine();Tell("Some other kind of expression",expr);]);
    Local(dis,X,pows);
    dis := DisassembleExpression(expr);
    X   := VarList(expr)[1];
    pows := matchPower /@ dis[1];
    rats := NearRational /@ pows;
    dis[1] := x^rats;
    p := Sum(ReassembleListTerms(dis));
    If(InVerboseMode(),Tell("    new ",p));
    jFactors(p);
];



/*-------------------------------------------------------------------
 *  Factoring Binomial expressions of the form  A X^n � B Y^n,
 *     Uses JAS library, but converts to univariate equivalent
 *     before factoring. (JAS is inefficient for multivariate
 *     factoring when degree is large.)
 *-------------------------------------------------------------------*/

10 # jFactorsBivariateBinomial( poly_IsPolynomial )_(Length(VarList(poly))=2)  <-- 
[
    If(InVerboseMode(),Tell(jFactorsBivariateBinomial,poly));
    Local(dis,n,X,Y,vars,A,B,s,Ar,Br,Arr,Brr,DAr,DBr,result);
    dis := DisassembleExpression(poly);
    If(InVerboseMode(),Tell("   ",dis));
    n     := Maximum(dis[2])[1];
    X     := dis[1][1];
    Y     := dis[1][2];
    vars  := dis[1];
    A     := Abs(dis[3][1]);
    B     := Abs(dis[3][2]);
    s     := Sign(dis[3][1]*dis[3][2]);
    //Ar    := NearRational(N(A^(1/n)));
    //Br    := NearRational(N(B^(1/n)));
    Ar    := N(A^(1/n));    Arr := Round(Ar);   DAr := Abs(Ar-Arr);
    Br    := N(B^(1/n));    Brr := Round(Br);   DBr := Abs(Br-Brr);
    If(InVerboseMode(),
      [
          Tell("       ",{n,X,Y}); 
          Tell("       ",{vars,A,B});
          Tell("       ",{Ar,Br,s});
          Tell("       ",{Arr,Brr});
          Tell("       ",{DAr,DBr});
          Tell("       ",dis);
      ]
    );
    result := If( DAr < 10^(-9) And DBr < 10^(-9), jFB(dis), {{poly,1}} );
    result;
];
UnFence("jFactorsBivariateBinomial",1);


50 # jFB( dis_IsList )_(Length(dis)=3 And Length(dis[3])=2) <--
[
    If(InVerboseMode(),[NewLine();Tell("jFB",dis);]);
    Local(ns,ii,fn,mx,my,fac);
    If(InVerboseMode(),
      [
         Tell("     ",n);
         Tell("     ",{X,Y});
         Tell("     ",{A,B,s});
         Tell("     ",{Ar,Br});
      ]
    );
    X     := Arr*X;
    Y     := Brr*Y;
    If(InVerboseMode(),Tell("     ",{X,Y}));
    
    fac  := jFac( X/Y,n,s);    //  factor using JAS and normalized variable
    If(InVerboseMode(),
      [
          NewLine();
          Tell("      ",X/Y);
          Tell("      ",fac);
      ]
    );
    
    // now convert factorization back to actual variables if required
    If( Y != 1,
      [
          Local(f,d,fs);
          For(ii:=1,ii<=Length(fac),ii++)
          [
              f := fac[ii][1];
              d := Degree(f,x);
              If(InVerboseMode(),Tell("             ",{ii,f,d}));
              fs := Subst(x,X/Y) f;
              If(InVerboseMode(),Tell("               ",{fs,d}));
              fac[ii][1] := Simplify(Simplify(Y^d*fs));
          ];
      ]
    );
    fac;
];
UnFence("jFB",1);



60 # jFac( _var, n_IsPositiveInteger, s_IsInteger ) <--
[
    //  Uses JAS to factor polynomial of form x^n � 1.
    If(InVerboseMode(),[NewLine();Tell("jFac",{var,n,s});]);
    Local(x,poly,result);
    poly := x^n+s;
    If(InVerboseMode(),Tell("   ",poly));
    result := jasFactorsInt(poly);     
];
UnFence("jFac",3);


10 # IsPureRational( N_IsRational )_(Not IsInteger(N)) <-- True;

12 # IsPureRational( _N ) <-- False;

10 # HasRealCoefficients( poly_IsPolynomial ) <--
[
    Local(disassem);
    disassem := DisassembleExpression(poly);
    (Length(Select(disassem[3],"IsDecimal")) > 0);
];

10 # HasRealCoefficients( poly_IsMonomial ) <--
[
    Local(disassem);
    disassem := DisassembleExpression(poly);
    (Length(Select(disassem[3],"IsDecimal")) > 0);
];


10 # HasRationalCoefficients( poly_IsPolynomial ) <--
[
    Local(disassem,answer);
    If(InVerboseMode(),Tell("  HasRationalCoefficients",poly));
    disassem := DisassembleExpression(poly);
    //Tell("              ",disassem);
    answer := (Length(Select(disassem[3],"IsPureRational")) > 0);
    If(InVerboseMode(),Tell("   ",answer));
    answer;
];

10 # HasRationalCoefficients( poly_IsMonomial) <--
[
    Local(disassem);
    disassem := DisassembleExpression(poly);
    (Length(Select(disassem[3],"IsPureRational")) > 0);
];


10 # FixUpMonicFactors( factrs_IsList ) <--
[
    If(InVerboseMode(),[ NewLine(); Tell("   doing monic fixup"); ] );
    Local(factrsnew,residuals,f,uni,);
    factrsnew := {};
    residuals := {};
    ForEach(f,factrs)
    [
        If(InVerboseMode(),Tell("               ",f));
        uni := MakeUni(f[1]);
        If(InVerboseMode(),Tell("                    ",uni));
        If( Degree(f[1])=1,
          [
            Local(cc,lcm,fnew);
            If(InVerboseMode(),Tell("                          ",Degree(f[1])));
            cc      := Coef(f[1],uni[1],0 .. 1);
            //Tell("                       ",cc);
            lcm     := Lcm( Denominator /@ cc );
            uni[3]  := lcm * cc;
            fnew    := NormalForm(uni);
            DestructiveAppend(factrsnew,{fnew,f[2]});
          ]
        );
        If( Degree(f[1])=2,
          [
            If(InVerboseMode(),Tell("                          ",Degree(f[1])));
            Local(pq);
            pq      := PrimitivePart(f[1]);
            DestructiveAppend(factrsnew,{pq,f[2]});
          ]
        );
        //  If any factors have degree >=3, store them in a 'residuals' array
        //  for further analysis
        If( Degree(f[1]) > 2,
          [
            If(InVerboseMode(),Tell("                          ",Degree(f[1])));
            Local(pq);
            pq      := PrimitivePart(f[1]);
            DestructiveAppend(residuals,{pq,f[2]});
            If(InVerboseMode(),Tell("                   appending to residuals",pq));
          ]
        );       
    ];
    {factrsnew,residuals};
];
UnFence("FixUpMonicFactors",1);


//10 # matchPower(_Z^n_IsNumber) <-- n;

//15 # matchPower(_Z) <-- 1;


//========================================================================

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xFactor.mpw0000644000175000017500000000106711517224250027063 0ustar  giovannigiovanni%mathpiper,def="xFactor"

//Retract("xFactor",*);

10 # xFactor( p_CanBeUni ) <-- FW(xFactors(p));


10 # xFactor( p_IsRationalFunction ) <--
[
    Local(fs,n,d);
    fs := xFactors( p );
    n  := FW(Numerator(fs));
    d  := FW(Denominator(fs));
    n/d;
];


10 # xFactor( L_IsList ) <-- 
[
    Local (result,x,f);
    result := {};
    ForEach(x,L)
    [
        f := xFactors(x);
        If( f = {}, f := 0, f := FW(f) );
        DestructiveAppend(result,f);
    ];
    result;
];



20 # xFactor( _expr ) <-- expr;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorizeInt.mpw0000644000175000017500000000244011371733712030060 0ustar  giovannigiovanni%mathpiper,def="FactorizeInt"

//  numbers

/// Middle level function: returns a list of prime factors and their powers.
/// E.g. FactorizeInt(50) returns {{2, 1}, {5, 2}}.
1# FactorizeInt(0) <-- {};
1# FactorizeInt(1) <-- {};

3# FactorizeInt(n_IsInteger) <--
[
  Local(small'powers);
  n := Abs(n);	// just in case we are given a negative number
  // first, find powers of 2, 3, ..., p with p=257 currently -- this speeds up PollardRho and should avoids its worst-case performance
  // do a quick check first - this will save us time especially if we want to move 257 up a lot
  If(
  	Gcd(ProductPrimesTo257(), n) > 1,	// if this is > 1, we need to separate some factors. Gcd() is very fast
	small'powers := TrialFactorize(n, 257),	// value is {n1, {p1,q1}, {p2,q2}, ...} and n1=1 if completely factorized into these factors, and the remainder otherwise
	small'powers := {n}	// pretend we had run TrialFactorize without success
  );
  n := small'powers[1];	// remainder
  If(n=1, Rest(small'powers),
  // if n!=1, need to factorize the remainder with Pollard Rho algorithm
	  [
	  	//If(InVerboseMode(), Echo({"FactorizeInt: Info: remaining number ", n}));
		SortFactorList(
	  	  PollardCombineLists(Rest(small'powers), PollardRhoFactorize(n))
		);
	  ]
  );
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/RootsWithMultiples.mpw0000644000175000017500000000102511316266467031325 0ustar  giovannigiovanni%mathpiper,def="RootsWithMultiples"

//  polynomials

10 # RootsWithMultiples(poly_CanBeUni) <--
[
  Local(factors,result,uni,root,i,deg);
  factors:=Factors(poly);
  result:={};
  ForEach(item,factors)
  [
    uni:=MakeUni(item[1]);

    deg:=Degree(uni);
    If(deg > 0 And deg < 3,
      [
        root:= PSolve(uni);
        If(Not IsList(root),root:={root});
        For(i:=1,i<=Length(root),i++)
          result:= Concat({{root[i],item[2]}}, result);
      ]
      );
  ];
  result;
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorQS.mpw0000644000175000017500000000067611316266467027161 0ustar  giovannigiovanni%mathpiper,def="FactorQS"

//  numbers

// The bud of an Quadratic Seive algorithm
// congruence solving code must be written first
Function("FactorQS",{n})[
	Local(x,k,fb,j);
	// optimal number of primes in factor base
	// according to Fundamental Number Theory with Applications - Mollin, p130
	k:=Round(N(Sqrt(Exp(Sqrt(Ln(n)*Ln(Ln(n)))))));
	fb:=ZeroVector(k);
	For(j:=1,j<=k,j++)[
		fb[j]:=NextPrime(j);
	];
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FWatom.mpw0000644000175000017500000000017511371733712026657 0ustar  giovannigiovanni%mathpiper,def="FWatom"

10 # FWatom({_a,1}) <-- a;
20 # FWatom({_a,_n}) <-- ListToFunction({ToAtom("^"),a, n});

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FindPrimeFactorSimple.mpw0000644000175000017500000000052511320776303031644 0ustar  giovannigiovanni%mathpiper,def="FindPrimeFactorSimple"

// numbers

/* simpler method but slower on worstcase such as p^n or n! */
FindPrimeFactorSimple(n, prime) :=
[
	Local(power, factor);
	power := 0;
	factor := prime;
	While(Modulo(n, factor)=0)
	[
		factor := factor*prime;
		power++;
	];
	{n/(factor/prime), power};
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorsPolynomialOverIntegers.mpw0000644000175000017500000001657211517224250033466 0ustar  giovannigiovanni%mathpiper,def="FactorsPolynomialOverIntegers"

//Retract("FactorsPolynomialOverIntegers",*);
//Retract("TryToReduceSpecialPolynomial",*);

//---------------------------------------------------------------------------

10 # FactorsPolynomialOverIntegers(_expr)_IsPolynomialOverIntegers(expr) <--
[
    Local(x);
    x := VarList(expr)[1];
    FactorsPolynomialOverIntegers(expr,x);

];

15 # FactorsPolynomialOverIntegers(_expr) <-- expr;


10 # FactorsPolynomialOverIntegers(_expr,_var)_(IsPolynomialOverIntegers(expr,var)) <--
[
    Local(factorsList,factListTransp,factrs,multiplicities,factrsUnMonic);
    Local(polyFactors,normalizations,normDivisor,polyFactors,factList);
    Local(n,result,newResult,gtotal,r,rr,d,g);
    factorsList := BinaryFactors(expr);
    /*  
     *  BinaryFactors is the internal MathPiper function that
     *  creates a double list of factors and their multiplicities
     */
    
    // By transposing factorsList (which has the form of a list of 
    // lists, hence a matrix), we convert it into a form which has 
    // a list of all the factors first, followed by a list of all 
    // the corresponding multiplicities.
    
    factListTransp := Transpose(factorsList);
    factrs := factListTransp[1];
    multiplicities := factListTransp[2];
        
    // Now, these factors are probably all in "monic" form, with the 
    // coefficient of the highest power of x in each factor being 
    // equal to 1, and all the "normalizing" factors being combined 
    // into a new leading numeric factor.  We want to undo this
    // monic-ization.  The function Together() will accomplish this 
    // for each separate factor, while leaving untouched factors 
    // which do not need changing.
    
    factrsUnMonic := MapSingle("Together",factrs);
        
    // The result of this step is that each factor which had been 
    // "normalized" to a monic has now be un-normalized into a 
    // rational function consisting of a non-monic polynomial 
    // divided by a number.  Now we just collect all the non-monic 
    // polynomials into one list, and all the normalizing denominators
    // into another.
    
    {polyFactors,normalizations}:=Transpose(MapSingle("GetNumerDenom",factrsUnMonic));
        
    // The next step is to make sure that each of the normalizing 
    // numbers is raised to the power of its corresponding 
    // multiplicity. Then all these powers of numbers are 
    // multiplied together, to form the overall normilizing 
    // divisor which must be used to remove the extra factor (if 
    // any) introduced during the monic-ization process.  All this 
    // is condensed into one line of Functional code
            
    normDivisor := Product(Map("^",{normalizations,multiplicities}));
    
    //  Notice that normDivisors is exactly equal in value to the
    // 'extra' numeric factor introduced by the monic-ization, if
    // any was indeed so introduced (it doesn't happen under all
    // circumstances).  I believe this will always be true, but I 
    // have not taken the time to prove it.  So I proceed in a 
    // more general way.
    
    polyFactors[1] := Simplify(polyFactors[1]/normDivisor);
    
    // We can now replace the first sub-list in factListTransp by
    // the un-monic-ized version
    
    factListTransp[1] := polyFactors;
    factList := Transpose(factListTransp);
    
    
    // .... and that is (supposedly) the answer.
    result := factList;
    
    // However, let's find out if any of the factors needs more treatment.
    Local(newResult,gtotal,d,g,rr);
    newResult := {};
    gtotal    := 1;
    ForEach(r,result) [
        d := Degree(r[1],var);
        g := Gcd(Coef(r[1],var,0 .. d));
        If( g > 1,   //  need to remove common numerical factor
               [ gtotal:=g*gtotal; 
                 r[1]:=Simplify(r[1]/g);
               ]
          );
        If(d > 2,
            [
                //  polynomial is NOT irreducible, but can we reduce it?
                rr := TryToReduceSpecialPolynomial(r[1]);
                If( IsList(rr),newResult := Concat(newResult,rr) );
            ],
                If( r != {1,1}, newResult := r:newResult )
          );
    ];  
    If(gtotal>1,newResult:={gtotal,1}:newResult);    
    newResult;
];


//---------------------------------------------------------------------------
//                      S P E C I A L    C A S E S
//---------------------------------------------------------------------------
/*
 * Given an unreduced polynomial over the integers, of degree > 2, 
 * which was found as one of the "factors" of a polynomial over 
 * the integers, we know that it is factorable into irreducible 
 * quadratics.  This function tries to find such quadratic factors.
 *     Lacking a good general attack on this problem, we will turn
 * to special cases which we happen to be able to solve.
 */
 
10 # TryToReduceSpecialPolynomial(_x^4+_x^2+1) <-- {{x^2+x+1,1},{x^2-x+1,1}};

10 # TryToReduceSpecialPolynomial(_x^6-1) <-- {{x+1,1},{x-1,1},{x^2+x+1,1},{x^2-x+1,1}};



%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output







%mathpiper_docs,name="FactorsPolynomialOverIntegers",categories="User Functions;Number Theory",access="experimental"
*CMD Factors --- factorization of univariate polynomials over the integers 
*STD
*CALL
	FactorsPolynomialOverIntegers(poly,x)

*PARMS

{poly} -- a polynomial which is univariate w.r.t. variable x
{x}    -- variable of the polynomial

*DESC

This function decomposes the polynomial {poly}, considered as univariate
in the variable {x}, into a product of irreducible polynomials.

This function is specialized for polynomials in {x} whose coefficients 
are all integers.  In such a case, it is often customary to expect the 
irreducible polynomial factors to be given in a form which also has
only integer coefficients.  However, the standard MathPiper function 
Factors() follows a different convention, which returns the constituant
polynomial factors in a {monic} form.  This means that the results may 
have rational, rather than integer, coefficients.  

The present function offers an alternative which is guaranted to return
polynomial factors with integer coefficients.  But it works only for 
input {polynomials}, not {numbers}, and only for polynomials all of whose
coefficients are integers.  For any other input, this function will simply
return the input expression unevaluated.

The factorization is returned as a list of pairs. The first member of
each pair is the factor, while the second member denotes the power to
which this factor should be raised. So the factorization
$poly = p1^n1 * ... * p9^n9$
is returned as {{{p1,n1}, ..., {p9,n9}}}.

NOTE: If you want the factorization to be expressed in the nominal
form    $poly = p1^n1 * ... * p9^n9$,
just apply the function FW() to the result returned by the present
function.

Programmer:  Sherm Ostrowsky

*E.G.

In> u:=Expand((2*x-3)^2*(3*x+5)^3)
Result: 108*x^5+216*x^4-477*x^3-985*x^2+525*x+1125

In> FactorsPolynomialOverIntegers(u,x)
Result: {{2*x-3,2},{3*x+5,3}}

In> FW(%)
Result: (2*x-3)^2*(3*x+5)^3

In> FactorsPolynomialOverIntegers(y^2-4)
Result: {{y+2,1},{y-2,1}}

In> FactorsPolynomialOverIntegers(x^4+x^2+1)
Result: {{x^2+x+1,1},{x^2-x+1,1}}
        
*SEE Factor, Factors, FW
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/xPrimitivePart.mpw0000644000175000017500000000523511523200452030440 0ustar  giovannigiovanni%mathpiper,def="xPrimitivePart"

//Retract("xPrimitivePart",*);
    
10 # xPrimitivePart(poly_CanBeUni) <-- 
[
    Local(cont,pp);
    If(InVerboseMode(),Tell("  xPrimitivePart1",poly));
    cont := xContent(poly);
    pp   := poly / cont;
    //pp   := Simplify(Simplify(pp));
];


Macro("xPrimitivePart",{poly,xcont})
[
    Local(pp);
    If(InVerboseMode(),Tell("  xPrimitivePart2",{poly,xcont}));
    
    If( IsBound(@xcont), 
      [
          pp := Eval(@poly) / Eval(@xcont);
      ],
      [
          Local(xCont);
          xCont  := xContent(Eval(@poly));
          @xcont := xCont;
          pp     := Eval(@poly) / xCont;
      ]
    );
    pp;
    //pp   := Simplify(Simplify(pp));
];

%/mathpiper

 


%mathpiper_docs,name="xPrimitivePart",categories="User Functions;Number Theory"
*CMD xPrimitivePart --- primitive part of a polynomial
*STD
*CALL
	PrimitivePart(expr)
    PrimitivePart(expr,cont)

*PARMS

{expr} -- a univariate or multivariate polynomial
{cont} -- the Content of this polynomial

*DESC

This is an experimental version of the existing function PrimitivePart(), 
with extended features.  It is provided primarily for testing purposes,
until it is ready to replace the older version.

This command determines the {primitive part} of a polynomial. 
The {primitive part} is what remains after the content (the
greatest common divisor of all the terms) is divided out. 

Every polynomial can be written as the product of its {content} (q.v.)
and its {primitive part}. This representation is usually the
first step in any attempt to factor the polynomial.

NOTE: If the first calling sequence is used ('arity' = 1), the function
computes xContent(expr) internally, but returns only the primitive part.

      If the second calling sequence is used ('arity' = 2), then
(a) If the second argument contains a previously-computed value of 
    xContent(expr), that value will be used in computing the primitive
    part, thereby saving some work.
(b) If the second argument is not bound to any value, the function will
    compute xContent(expr) internally, AND return it in the second argument!

*E.G.
In> Unbind(a,b,xCont)
Result: True

In> poly:=2*a*x^2*y-8*a*y
Result: 2*a*x^2*y-8*a*y

In>Time() xCont := xContent(poly)
Result: 0.427442564
In> xCont
Result: 2*a*y

In> Time() xpp1:=xPrimitivePart(poly)
Result: 0.697451928
In> xpp1
Result: x^2-4

In> Time() xpp2:=xPrimitivePart(poly,xCont)
Result: 0.392679832
In> xpp2
Result: x^2-4

In> Unbind(cont)
Result: True

In> Time() xpp3:=xPrimitivePart(poly,cont)
Result: 0.735463317
In> xpp3
Result: x^2-4
In> cont
Result: 2*a*y

*SEE Content, PrimitivePart, Gcd, xContent
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/pollardrho/0000755000175000017500000000000011722677332027105 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/pollardrho/PollardRhoFactorize.mpw0000644000175000017500000000546311502266107033545 0ustar  giovannigiovanni%mathpiper,def="PollardRhoFactorize"

/* This is Pollard's Rho method of factorizing, as described in
 * "Modern Computer Algebra". It is a rather fast algorithm for
 * factoring, but doesn't scale to polynomials regrettably.
 *
 * It acts 'by chance'. This is the Floyd cycle detection trick, where
 * you move x(i+1) = f(x(i)) and y(i+1) = f(f(y(i))), so the y goes twice
 * as fast as x, and for a certain i x(i) will be equal to y(i).
 *
 * "Modern Computer Algebra" reasons that if f(x) = (x^2+1) mod n for
 * the value n to be factored, then chances are good that gcd(x-y,n)
 * is a factor of n. The function x^2+1 is arbitrary, a higher order
 * polynomial could have been chosen also.
 *
 */

/*
Warning: The Pollard Rho algorithm cannot factor some numbers, e.g. 703, and
can enter an infinite loop. This currently results in an error message: "failed to factorize".
Hopefully the TrialFactorize() step will avoid these situations by excluding
small prime factors.
This problem could also be circumvented by trying a different random initial value for x when a loop is encountered -- hopefully another initial value will not get into a loop. (currently this is not implemented)
*/




/// Polynomial for the Pollard Rho iteration
PollardRhoPolynomial(_x) <-- x^2+1;

2# PollardRhoFactorize(n_IsPrimePower) <-- {GetPrimePower(n)};
3# PollardRhoFactorize(_n) <--
[
  Local(x,y,restarts,gcd,repeat);
  gcd:=1;
  restarts := 100;	// allow at most this many restartings of the algorithm
  While(gcd = 1 And restarts>=0)	// outer loop: this will be typically executed only once but it is needed to restart the iteration if it "stalls"
  [
  	restarts--;
    /* Pick a random value between 1 and n-1 */
    x:= RandomInteger(n-1);

    /* Initialize loop */
    gcd:=1; y:=x;
	repeat := 4;	// allow at most this many repetitions
//		Echo({"debug PollardRho: entering gcd loop, n=", n});

    /* loop until failure or success found */
    While(gcd = 1 And repeat>=0)
    [
      x:= Modulo( PollardRhoPolynomial(x), n);
   	  y:= Modulo( PollardRhoPolynomial(
	  	Modulo( PollardRhoPolynomial(y), n)	// this is faster for large numbers
	  ), n);
   	  If(x-y = 0,
       	 [
		 	gcd := 1;
		 	repeat--;	// guard against "stalling" in an infinite loop but allow a few repetitions
		 ],
       	 gcd:=Gcd(x-y,n)
       	 );
//		Echo({"debug PollardRho: gcd=",gcd," x=", x," y=", y});
   	];
	If(InVerboseMode() And repeat<=0, Echo({"PollardRhoFactorize: Warning: stalled while factorizing ", n, "; counters ", x, y}));
  ];
  Check(restarts>0, "Math", "PollardRhoFactorize: Error: failed to factorize " : ToString(n));
  If(InVerboseMode() And gcd > 1, Echo({"PollardRhoFactorize: Info: while factorizing ", n, " found factor ", gcd}));
  /* Return result found */
  PollardCombineLists(PollardRhoFactorize(gcd), PollardRhoFactorize(Quotient(n,gcd)));
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/pollardrho/PollardCombineLists.mpw0000644000175000017500000000056111371733712033540 0ustar  giovannigiovanni%mathpiper,def="PollardCombineLists"
/* PollardCombineLists combines two assoc lists used for factoring.
   the first element in each item list is the factor, and the second
   the exponent. Thus, an assoc list of {{2,3},{3,5}} means 2^3*3^5.
*/
PollardCombineLists(_left,_right) <--
[
  ForEach(item,right)
  [
    PollardMerge(left,item);
  ];
  left;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/pollardrho/PollardMerge.mpw0000644000175000017500000000045611371733712032207 0ustar  giovannigiovanni%mathpiper,def="PollardMerge"

5 # PollardMerge(_list,{1,_n}) <-- True;
10 # PollardMerge(_list,_item)_(Assoc(item[1],list) = Empty) <--
  DestructiveInsert(list,1,item);

20 # PollardMerge(_list,_item) <--
[
  Local(assoc);
  assoc := Assoc(item[1],list);
  assoc[2]:=assoc[2]+item[2];
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/Monomials.mpw0000644000175000017500000000630011523200452027401 0ustar  giovannigiovanni%mathpiper,def="Monomials"

//Retract("CanBeMonomial",*);
//Retract("IsMonomial",*);
//Retract("FactorsMonomial",*);

10 # CanBeMonomial(_expr)<--Not (HasFunc(expr,ToAtom("+")) Or HasFunc(expr,ToAtom("-")));

10 # IsMonomial(expr_CanBeMonomial) <-- 
[
    Local(r);
    If( IsRationalFunction(expr),
        r := (VarList(Denominator(expr)) = {}),
        r := True
    );
];

15 # IsMonomial(_expr) <-- False;


10 # FactorsMonomial(expr_IsMonomial) <--
[
  If(InVerboseMode(),Tell("FactorsMonomial",expr));
  Local(den,num,Ns,flat,prod,quot,result,f,ff);
  If( IsRationalFunction(expr),
    [
      den := Denominator(expr);
      num := Flatten(Numerator(expr),"*");
    ],
    [
      den := 1;
      num := Flatten(expr,"*");
    ]
  );
  If(InVerboseMode(),Tell("     ",{num,den}));
  Ns  := Select(num, "IsComplex");
  If(InVerboseMode(),Tell("     ",Ns));
  If( Ns = {},
       If( den != 1, DestructiveInsert(num,1,1/den)),
       DestructiveReplace(num,Find(num,Ns[1]),Ns[1]/den)
  );
  If(InVerboseMode(),Tell("     ",num));
  result := {};
  ForEach(f,num)
  [
      If( IsComplex(f), 
          DestructiveAppend(result,{(f),1}),
          If( IsAtom(f),
              DestructiveAppend(result,{f,1}),
              DestructiveAppend(result,DestructiveDelete(FunctionToList(f),1))
          )
      );
  ];
  result;
];

%/mathpiper







%mathpiper_docs,name="IsMonomial",categories="User Functions;Predicates"
*CMD IsMonomial --- determine if {expr} is a Monomial
*STD
*CALL
	IsMonomial(expr)

*PARMS

{expr} -- an expression

*DESC

This function returns {True} if {expr} satisfies the definition of a {Monomial}.
Otherwise, {False}.
A {Monomial} is defined to be a single term, consisting of a product of numbers
and variables.

*E.G.
In> IsMonomial(24)
Result: True

In> IsMonomial(24*a*x^2*y^3)
Result: True

In> IsMonomial(24*a*x^2*y^3/15)
Result: True

In> IsMonomial(24*a*x^2*y^3/15+1)
Result: False
    
%/mathpiper_docs



%mathpiper_docs,name="FactorsMonomial",categories="User Functions;Polynomials (Operations)"
*CMD FactorsMonomial --- factorization of a monomial expression
*STD
*CALL
	FactorsMonomial(expr)

*PARMS

{expr} -- an expression representing a Monomial

*DESC

This function decomposes the {expr} into a product of numbers and variables 
raised to various powers.

The factorization is returned as a list of pairs.  The first member of
each pair is the factor (a number or a variable name), while the second
member is an integer denoting the power to which this factor should be
raised.

Thus, the factorization  
$expr = p1^n1 * ... * p9^n9$ 
is returned as {{(p1,n1), ..., (p9,n9)}}.

If {expr} is not a monomial, the function returns unevaluated.

NOTE: numerical factors are not decomposed into their prime factorization.

*E.G.

In> FactorsMonomial(24)
Result: {{24,1}}

In> FactorsMonomial(24/15)
Result: {{8/5,1}}

In> FactorsMonomial(24*a*x^2*y^3)
Result: {{24,1},{a,1},{x,2},{y,3}}

In> FactorsMonomial(24*a*x^2*y^3/15)
Result: {{8/5,1},{a,1},{x,2},{y,3}}

In> FactorsMonomial(24*a*x^2*y^3/15+1)
Result: FactorsMonomial((24*a*x^2*y^3)/15+1)
    
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FW.mpw0000644000175000017500000000063311320716335025771 0ustar  giovannigiovanni%mathpiper,def="FW"

/* FW: pass FW the result of Factors, and it will show it in the
 * form of p0^n0*p1^n1*...
 */


5  # FW(_list)_(Length(list) = 0) <-- 1;
10 # FW(_list)_(Length(list) = 1) <-- FWatom(list[1]);
20 # FW(_list) <--
[
  Local(result);
  result:=FWatom(First(list));
  ForEach(item,Rest(list))
  [
   result := ListToFunction({ ToAtom("*"),result,FWatom(item)});
  ];
  result;
];

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/TrialFactorize.mpw0000644000175000017500000000305511316266467030413 0ustar  giovannigiovanni%mathpiper,def="TrialFactorize"

//  numbers

//todo:tk:This functions was commented out for some reason.

/// Simple trial factorization: can be very slow for integers > 1,000,000.
/// Try all prime factors up to Sqrt(n).
/// Resulting factors are automatically sorted.
/// This function is not used any more.
/*
2# TrialFactorize(n_IsPrimePower) <-- {GetPrimePower(n)};
3# TrialFactorize(n_IsInteger) <--
[
	Local(factorization);
	factorization := TrialFactorize(n, n);	// TrialFactorize will limit to Sqrt(n) automatically
	If(
		First(factorization) = 1,	// all factors were smaller than Sqrt(n)
		Rest(factorization),
		// the first element needs to be replaced
		Concat(Rest(factorization), {{First(factorization),1}})
	);
];
*/


/// Auxiliary function. Factorizes by trials. Return prime factors up to given limit and the remaining number.
/// E.g. TrialFactorize(42, 2) returns {21, {{2, 1}}} and TrialFactorize(37, 4) returns {37}
TrialFactorize(n, limit) :=
[
	Local(power, prime, result);
	result := {n};	// first element of result will be replaced by the final value of n
	prime := 2;	// first prime
	While(prime <= limit And n>1 And prime*prime <= n)
	[	// find the max power of prime which divides n
		{n, power} := FindPrimeFactor(n, prime);
		If(
			power>0,
			DestructiveAppend(result, {prime,power})
		);
		prime := NextPseudoPrime(prime);	// faster than NextPrime and we don't need real primes here
	];
	// replace the first element which was n by the new n
	DestructiveReplace(result, 1, n);
];



%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/FactorCancel.mpw0000644000175000017500000000473511523200452030001 0ustar  giovannigiovanni%mathpiper,def="FactorCancel"

//Retract("FactorCancel",*);

10 # FactorCancel( p_IsRational ) <-- Factor(p);

15 # FactorCancel( p_IsRationalFunction ) <--
[
    If(InVerboseMode(),Tell(FactorCancel,p));
    Local(pp,ff,n,d,fn,fd,f,tnu,newn,newd,s,k);
    pp   := Simplify(p);
    If(InVerboseMode(),Tell("  ",pp));
    ff   := Factors(pp);
    If(InVerboseMode(),Tell("  ",ff));
    tnu  := {ff[1]};
    If(IsListOfLists(ff), tnu  := RemoveDuplicates(Transpose(ff)[1]));
    newn := {};
    newd := {};
    If(InVerboseMode(),Tell("      ",tnu));
    ForEach(f,tnu)
    [
       s := Select(ff,Lambda({X},X[1]=f));
       If(InVerboseMode(),Tell("      ",{f,s}));
       If( s != {},
         [
            k := Sum(Transpose(s)[2]);
            If(InVerboseMode(),Tell("      ",{s,k}));
            If( k > 0, DestructiveAppend(newn,{f,k}) );
            If( k < 0, DestructiveAppend(newd,{f,-k}) );
         ],
         [
            k := 1;
            DestructiveAppend(newn,{f,k});
         ]
       );
    ];
    If(InVerboseMode(),Tell("    ",{newn,newd}));
    FW(newn)/FW(newd);
];

20 # FactorCancel( _p ) <-- Factor(p);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

   
   
.  



%mathpiper_docs,name="FactorCancel",categories="User Functions;Polynomials (Operations)"

*CMD FactorCancel -- Factors a Rational Function and cancels where possible

*CALL
FactorCancel( expr )

*PARMS
{expr} -- A function which is a quotient of two polynomials

*DESC
A quotient of two polynomials P(z) and Q(z),
    R(z)=(P(z))/(Q(z)),
is called a rational function, or sometimes a rational polynomial function.

By convention, the {Domain} of the function {excludes} any points which are
zeros of the denominator, even though some of these may be cancelable by
equivalent zeros in the numerator.   Therefore, the function {Factor}, when
applied to such a function, retains all the factors of both numerator and
denominator, whether or not they might subsequently cancel.

But sometimes a user might want to see the factored function in the form which
results when such cancellation has been performed.  {FactorCancel} performs
this operation.

*E.G.

In> P:=Expand(x^2-1)
Result: x^2-1

In> Q:=Expand((x+1)^2)
Result: x^2+2*x+1

In> F:=P/Q
Result: (x^2-1)/(x^2+2*x+1)

In> Factor(F)
Result: ((x-1)*(x+1))/(x+1)^2

In> FactorCancel(F)
Result: (x-1)/(x+1)

    
*SEE Factor,Factors

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/factors/SortFactorList.mpw0000644000175000017500000000027411371733712030404 0ustar  giovannigiovanni%mathpiper,def="SortFactorList"

/// Sort the list of prime factors using HeapSort()
LocalSymbols(a,b, list) [

SortFactorList(list) := HeapSort(list, {{a,b}, a[1] 0 And deg < 3,
      [
        root:= PSolve(uni);
        If(Not IsList(root),root:={root});
        For(i:=0,i Macro("myfor",{init,pred,inc,body}) [@init;While(@pred)[@body;@inc;];True;];
Result: True;
In> a:=10
Result: 10;

Here this new macro {myfor} is used to loop, using a variable {a} from the
calling environment.

In> myfor(i:=1,i<10,i++,Echo(a*i))
	10 
	20 
	30 
	40 
	50 
	60 
	70 
	80 
	90 
Result: True;
In> i
Result: 10;

*SEE Function, DefMacroRulebase
%/mathpiper_docs



mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deffunc/colon_equals_operator.mpw0000644000175000017500000001704711502266107032033 0ustar  giovannigiovanni%mathpiper,def=":="

/* := assignment. */
Rulebase(":=",{aLeftAssign,aRightAssign});
UnFence(":=",2);
HoldArgument(":=",aLeftAssign);
HoldArgument(":=",aRightAssign);

/* := assignment. */
// assign a variable
Rule(":=",2,0,IsAtom(aLeftAssign))
[
  Check( Not IsNumber(aLeftAssign), "Argument", "Only a variable can be placed on the left side of an := operator." );

  MacroBind(aLeftAssign,Eval(aRightAssign));

  Eval(aLeftAssign);
];



// assign lists
Rule(":=",2,0,IsList(aLeftAssign))
[
  Map(":=",{aLeftAssign,Eval(aRightAssign)});
];

// auxiliary function to help assign arrays using :=
Rulebase("AssignArray",{setlistterm,setlistindex,setlistresult});
UnFence("AssignArray",3);
Rule("AssignArray",3,1,IsString(setlistindex))
[
  Local(item);
  item:=Assoc(setlistindex,setlistterm);
  If(item = Empty,
     DestructiveInsert(setlistterm,1,{setlistindex,setlistresult}),
     DestructiveReplace(item,2,setlistresult)
     );
  True;
];
// assign generic arrays
Rule("AssignArray",3,1,
   And(
           IsEqual(IsGeneric(setlistterm),True),
           IsEqual(GenericTypeName(setlistterm),"Array")
          )
    )
[
  ArraySet(setlistterm,setlistindex,setlistresult);
];


Rule("AssignArray",3,2,True)
[
  DestructiveReplace(setlistterm ,setlistindex, setlistresult);
  True;
];

// a[x] := ... assigns to an array element
Rule(":=",2,10,IsFunction(aLeftAssign) And (First(FunctionToList(aLeftAssign)) = Nth))
[
 Local(frst,scnd);

 Local(lst);
 Bind(lst,(FunctionToList(aLeftAssign)));
 Bind(lst,Rest(lst));
 Bind(frst, Eval(First(lst)));
 Bind(lst,Rest(lst));
 Bind(scnd, Eval(First(lst)));

 AssignArray(frst,scnd,Eval(aRightAssign));
];

// f(x):=... defines a new function
Rule(":=",2,30,IsFunction(aLeftAssign) And Not(IsEqual(aLeftAssign[0], ToAtom(":="))) )
[
  Check( Not IsEqual(aLeftAssign[0], ToAtom("/")), "Argument", "Only a variable can be placed on the left side of an := operator." );

  Local(oper,args,arity);
  Bind(oper,ToString(aLeftAssign[0]));
  Bind(args,Rest(FunctionToList(aLeftAssign)));
  If(
	And(IsGreaterThan(Length(args), 1), IsEqual( MathNth(args, Length(args)), ToAtom("...") )),
	// function with variable number of arguments
	[
	  DestructiveDelete(args,Length(args));	// remove trailing "..."
	  Bind(arity,Length(args));
	  Retract(oper,arity);
	  MacroRulebaseListed(oper, args);
	],
	// function with a fixed number of arguments
	[
	  Bind(arity,Length(args));
	  Retract(oper,arity);
	  MacroRulebase(oper, args);
	]
  );
  Unholdable(aRightAssign);
  MacroRule(oper,arity,1025,True) aRightAssign;
];

%/mathpiper



%mathpiper_docs,name=":=",categories="Operators"
*CMD := --- assign a variable or a list; define a function
*STD
*CALL
	var := expr
	{var1, var2, ...} := {expr1, expr2, ...}
	var[i] := expr
	fn(arg1, arg2, ...) := expr
Precedence:
*EVAL PrecedenceGet(":=")

*PARMS

{var} -- atom, variable which should be assigned

{expr} -- expression to assign to the variable or body of function

{i} -- index (can be integer or string)

{fn} -- atom, name of a new function to define

{arg1}, {arg2} -- atoms, names of arguments of the new function {fn}

*DESC

The {:=} operator can be used
in a number of ways. In all cases, some sort of assignment or definition takes
place.

The first form is the most basic one. It evaluates the expression on
the right-hand side and assigns it to the variable named on the
left-hand side. The left-hand side is not evaluated. The evaluated
expression is also returned.

The second form is a small extension, which allows one to do multiple
assignments. The first entry in the list on the right-hand side is
assigned to the first variable mentioned in the left-hand side, the
second entry on the right-hand side to the second variable on the
left-hand side, etc. The list on the right-hand side must have at
least as many entries as the list on the left-hand side. Any excess
entries are silently ignored. The result of the expression is the list
of values that have been assigned.

The third form allows one to change an entry in the list. If the index
"i" is an integer, the "i"-th entry in the list is changed to the
expression on the right-hand side. It is assumed that the length of
the list is at least "i". If the index "i" is a string, then
"var" is considered to be an associative list (sometimes called hash
table), and the key "i" is paired with the value "exp". In both
cases, the right-hand side is evaluated before the assignment and the
result of the assignment is {True}.

The last form defines a function. For example, the assignment {fn(x) := x^2}
removes any rules previously associated with {fn(x)} and defines the rule
{fn(_x) <-- x^2}. Note that the left-hand side may take a different form if
{fn} is defined to be a prefix, infix or bodied function. This case
is special since the right-hand side is not evaluated
immediately, but only when the function {fn} is used. If this takes
time, it may be better to force an immediate evaluation with {Eval}
(see the last example). If the expression on the right hand side begins
with {Eval()}, then it will be evaluated before defining the new function.

A variant of the function definition can be used to make a function
accepting a variable number of arguments.

*E.G.

A simple assignment:

In> a := Sin(x) + 3;
Result: Sin(x)+3;
In> a;
Result: Sin(x)+3;

Multiple assignments:

In> {a,b,c} := {1,2,3};
Result: {1,2,3};
In> a;
Result: 1;
In> b+c;
Result: 5;

Assignment to a list:

In> xs := { 1,2,3,4,5 };
Result: {1,2,3,4,5};
In> xs[3] := 15;
Result: True;
In> xs;
Result: {1,2,15,4,5};

Building an associative list:

In> alist := {};
Result: {};
In> alist["cherry"] := "red";
Result: True;
In> alist["banana"] := "yellow";
Result: True;
In> alist["cherry"];
Result: "red";
In> alist;
Result: {{"banana","yellow"},{"cherry","red"}};

Defining a function:

In> f(x) := x^2;
Result: True;
In> f(3);
Result: 9;
In> f(Sin(a));
Result: Sin(a)^2;

Defining a function with variable number of arguments:

In> f(x, ...) := If(IsList(x),Sum(x),x);
Result: True;
In> f(2);
Result: 2;
In> f(1,2,3);
Result: 6;

Defining a new infix operator:

In> Infix("*&*",10);
Result: True;
In> x1 *&* x2 := x1/x2 + x2/x1;
Result: True;
In> Sin(a) *&* Cos(a);
Result: Tan(1)+Cos(1)/Sin(1);
In> Unbind(a);
Result: True;
In> Sin(a) *&* Exp(a);
Result: Sin(a)/Exp(a)+Exp(a)/Sin(a);

In the following example, it may take some time to compute the Taylor
expansion. This has to be done every time the function {f} is called.

In> f(a) := Taylor(x,0,25) Sin(x);
Result: True;
In> f(1);
Result: x-x^3/6+x^5/120-x^7/5040+x^9/362880-
x^11/39916800+x^13/6227020800-x^15/
1307674368000+x^17/355687428096000-x^19/
121645100408832000+x^21/51090942171709440000
-x^23/25852016738884976640000+x^25
/15511210043330985984000000;
In> f(2);
Result: x-x^3/6+x^5/120-x^7/5040+x^9/362880-
x^11/39916800+x^13/6227020800-x^15
/1307674368000+x^17/355687428096000-x^19/
121645100408832000+x^21/51090942171709440000
-x^23/25852016738884976640000+x^25/
15511210043330985984000000;

The remedy is to evaluate the Taylor expansion immediately. Now the
expansion is computed only once.

In> f(a) := Eval(Taylor(x,0,25) Sin(x));
Result: True;
In> f(1);
Result: x-x^3/6+x^5/120-x^7/5040+x^9/362880-
x^11/39916800+x^13/6227020800-x^15/
1307674368000+x^17/355687428096000-x^19/
121645100408832000+x^21/51090942171709440000
-x^23/25852016738884976640000+x^25
/15511210043330985984000000;
In> f(2);
Result: x-x^3/6+x^5/120-x^7/5040+x^9/362880-
x^11/39916800+x^13/6227020800-x^15
/1307674368000+x^17/355687428096000-x^19/
121645100408832000+x^21/51090942171709440000
-x^23/25852016738884976640000+x^25/
15511210043330985984000000;

*SEE <--, Bind, Unbind, [], Rule, Infix, Eval, Function
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deffunc/TemplateFunction.mpw0000644000175000017500000000255611523146134030714 0ustar  giovannigiovanni%mathpiper,def="TemplateFunction"

Rulebase("TemplateFunction",{oper,args,body});

Bodied("TemplateFunction",60000);

HoldArgument("TemplateFunction",oper);

HoldArgument("TemplateFunction",args);

HoldArgument("TemplateFunction",body);

Rule("TemplateFunction",3,2047,True)
[
  Retract(oper,Length(args));
  Local(arglist);
  arglist:=FlatCopy(args);

  DestructiveAppend(arglist,{args,ListToFunction({Hold,body})});
  arglist:=ApplyFast("LocalSymbols",arglist);

  MacroRulebase(oper,arglist[1]);
  MacroRule(oper,Length(args),1025,True) arglist[2];

];

%/mathpiper




%mathpiper_docs,name="TemplateFunction",categories="Programmer Functions;Programming;Built In"
*CMD TemplateFunction --- defines a function
*CALL
	TemplateFunction("operator",parameter)

*PARMS
{"operator"} -- string, name of a function

{parameter} -- atom, symbolic name of parameter

*DESC
Defines a function.

*E.G.
/%mathpiper
TemplateFunction("MyUntil",{predicate,body})
[
  Eval(body);
  While (IsEqual(Eval(predicate),False))
  [
    Eval(body);
  ];
  True;
];
UnFence("MyUntil",2);
HoldArgumentNumber("MyUntil",2,1);
HoldArgumentNumber("MyUntil",2,2);
Bodied("MyUntil",60000);

/%/mathpiper



/%mathpiper

x := 1;

MyUntil(x = 5)
[
    Echo(x);
    x++;
];

/%/mathpiper

    /%output,preserve="false"
      Result: True

      Side Effects:
      1
      2
      3
      4

.   /%/output
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deffunc/HoldArgumentNumber.mpw0000644000175000017500000000162511523146134031171 0ustar  giovannigiovanni%mathpiper,def="HoldArgumentNumber"

Function("HoldArgumentNumber",{function,arity,index})
[
  Local(args);
  args:=RulebaseArgumentsList(function,arity);
/* Echo({"holdnr ",args}); */
  ApplyFast("HoldArgument",{function,args[index]});
];

%/mathpiper



%mathpiper_docs,name="HoldArgumentNumber",categories="Programmer Functions;Programming;Built In"
*CMD HoldArgumentNumber --- specify argument as not evaluated
*STD
*CALL
	HoldArgumentNumber("function", arity, argNum)

*PARMS
{"function"} -- string, function name

{arity}, {argNum} -- positive integers

*DESC

Declares the argument numbered {argNum} of the function named {"function"} with
specified {arity} to be unevaluated ("held"). Useful if you don't know symbolic
names of parameters, for instance, when the function was not declared using an
explicit {Rulebase} call. Otherwise you could use {HoldArgument}.

*SEE HoldArgument, Rulebase
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deffunc/Unholdable.mpw0000644000175000017500000000131411417443641027504 0ustar  giovannigiovanni%mathpiper,def="Unholdable"


Rulebase("Unholdable",{var});

HoldArgument("Unholdable",var);

UnFence("Unholdable",1);

Rule("Unholdable",1,10,IsEqual(Type(Eval(var)),"Eval"))
[
    MacroBind(var,Eval(Eval(var)));
    //Echo({"unheld",var,Eval(var)});
];


Rule("Unholdable",1,20,True)
[
    //Echo({"held"});
  True;
];

%/mathpiper





%mathpiper_docs,name="Unholdable",categories="Programmer Functions;Programming;Built In"
*CMD Unholdable --- make a variable unholdable

*CALL
    Unholdable(var)

*PARMS

{var} -- a variable

*DESC
This function makes a variable unholdable.  It is used to make sure that an :=
operator with an Eval() immediately to its right hand side evaluates its argument.
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deffunc/Function.mpw0000644000175000017500000001055511523200452027210 0ustar  giovannigiovanni%mathpiper,def="Function"

/* Defining a macro-like function that declares a function
 * with only one rule.
 */
Rulebase("Function",{oper,args,body});



// function with variable number of arguments: Function("func",{x,y, ...})body;
Rule("Function",3,2047,
	And(IsGreaterThan(Length(args), 1), IsEqual( MathNth(args, Length(args)), ToAtom("...") ))
)
[
  DestructiveDelete(args,Length(args));	// remove trailing "..."
  Retract(oper,Length(args));
  MacroRulebaseListed(oper,args);
  MacroRule(oper,Length(args),1025,True) body;	// at precedence 1025, for flexibility
];

// function with a fixed number of arguments
Rule("Function",3,2048,True)
[
  Retract(oper,Length(args));
  MacroRulebase(oper,args);
  MacroRule(oper,Length(args),1025,True) body;
];


/// shorthand function declarations
Rulebase("Function",{oper});
// function with variable number of arguments: Function() f(x,y, ...)
Rule("Function",1,2047,
	And(IsFunction(oper), IsGreaterThan(Length(oper), 1), IsEqual( MathNth(oper, Length(oper)), ToAtom("...") ))
)
[
	Local(args);
	Bind(args,Rest(FunctionToList(oper)));
	DestructiveDelete(args,Length(args));	// remove trailing "..."
	If(RulebaseDefined(Type(oper),Length(args)),
		False,	// do nothing
		MacroRulebaseListed(Type(oper),args)
	);
];


// function with a fixed number of arguments
Rule("Function",1,2048,
	And(IsFunction(oper))
)
[
	Local(args);
	Bind(args,Rest(FunctionToList(oper)));
	If(RulebaseDefined(Type(oper),Length(args)),
		False,	// do nothing
		MacroRulebase(Type(oper),args)
	);
];


HoldArgument("Function",oper);
HoldArgument("Function",args);
HoldArgument("Function",body);

%/mathpiper



%mathpiper_docs,name="Function",categories="Programmer Functions;Programming;Built In"
*CMD Function --- declare or define a function
*STD
*CALL
	Function() func(arglist)
	Function() func(arglist, ...)
	Function("op", {arglist}) body
	Function("op", {arglist, ...}) body

*PARMS

{func(args)} -- function declaration, e.g. {f(x,y)}

{"op"} -- string, name of the function

{{arglist}} -- list of atoms, formal arguments to the function

{...} -- literal ellipsis symbol "{...}" used to denote a variable number of arguments

{body} -- expression comprising the body of the function

*DESC

This command can be used to define a new function with named arguments.


The number of arguments of the new function and their names are determined by the list {arglist}. If the ellipsis "{...}" follows the last atom in {arglist}, a function with a variable number of arguments is declared (using {RulebaseListed}). Note that the ellipsis cannot be the only element of {arglist} and must be preceded by an atom.

A function with variable number of arguments can take more arguments than elements in {arglist}; in this case, it obtains its last argument as a list containing all extra arguments.

The short form of the {Function} call merely declares a {Rulebase} for the new function but does not define any function body. This is a convenient shorthand for {Rulebase} and {RulebaseListed}, when definitions of the function are to be supplied by rules. If the new function has been already declared with the same number of arguments (with or without variable arguments), {Function} returns false and does nothing.

The second, longer form of the {Function} call declares a function and also defines a function body. It is equivalent to a
single rule such as {op(_arg1, _arg2) <-- body}. The rule will be declared at
precedence 1025. Any previous rules associated with {"op"} (with the same
arity) will be discarded. More complicated functions (with more than one body)
can be defined by adding more rules.

*E.G. notest

This will declare a new function with two or more arguments, but define no rules for it. This is equivalent to {Rulebase ("f1", {x, y, ...})}.
In> Function() f1(x,y,...);
Result: True;
In> Function() f1(x,y);
Result: False;

This defines a function {FirstOf} which returns the
first element of a list. Equivalent definitions would be
{FirstOf(_list) <-- list[1]} or {FirstOf(list) := list[1]}.
In> Function("FirstOf", {list})  list[1];
Result: True;
In> FirstOf({a,b,c});
Result: a;

The following function will print all arguments to a string:
In> Function("PrintAll",{x, ...}) If(IsList(x),
	  PrintList(x), PipeToString()Write(x));
Result: True;
In> PrintAll(1):
Result: " 1";
In> PrintAll(1,2,3);
Result: " 1 2 3";

*SEE TemplateFunction, Rule, Rulebase,  RulebaseListed, :=, Retract
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/0000755000175000017500000000000011722677332025443 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/slash_colon_operator.mpw0000644000175000017500000000506111523200452032371 0ustar  giovannigiovanni%mathpiper,def="/:"

5 # (_expression /: LocPatterns(_patterns)) <--
[
  MacroSubstitute(expression,"LocPredicate","LocChange");
];


10 # (_expression /: _patterns) <--
[
  Bind(patterns, LocProcess(patterns));
  MacroSubstitute(expression,"LocPredicate","LocChange");
];

%/mathpiper



%mathpiper_docs,name="/:",categories="Operators"
*CMD /: --- local simplification rules
*CMD /:: --- local simplification rules
*STD
*CALL
	expression /: patterns
	expressions /:: patterns
Precedence:
*EVAL PrecedenceGet("/:")


*PARMS

{expression} -- an expression

{patterns} -- a list of patterns

*DESC

Sometimes you have an expression, and you want to use specific
simplification rules on it that are not done by default. This
can be done with the {/:} and the {/::} operators. Suppose we have the
expression containing things such as {Ln(a*b)}, and we want
to change these into {Ln(a)+Ln(b)}, the easiest way
to do this is using the {/:} operator, as follows:

In> Sin(x)*Ln(a*b)
Result: Sin(x)*Ln(a*b);
In> % /: { Ln(_x*_y) <- Ln(x)+Ln(y) }
Result: Sin(x)*(Ln(a)+Ln(b));

A whole list of simplification rules can be built up in the list,
and they will be applied to the expression on the left hand side
of {/:} .

The forms the patterns can have are one of:

	pattern <- replacement
	{pattern,replacement}
	{pattern,postpredicate,replacement}

Note that for these local rules, {<-} should be used instead of
{<--} which would be used in a global rule.

The {/:} operator traverses an expression much as {Subst} does, that is, top
down, trying to apply the rules from the beginning of the list of
rules to the end of the list of rules. If the rules cannot be applied
to an expression, it will try subexpressions of that
expression and so on.

It might be necessary sometimes to use the {/::} operator, which
repeatedly applies the {/:} operator until the result doesn't change
any more. Caution is required, since rules can contradict each other,
which could result in an infinite loop. To detect this situation,
just use /: repeatedly on the expression. The repetitive nature
should become apparent.

*E.G.

In> Sin(u)*Ln(a*b) /: {Ln(_x*_y) <- Ln(x)+Ln(y)}
Result: Sin(u)*(Ln(a)+Ln(b));
In> Sin(u)*Ln(a*b) /:: { a <- 2, b <- 3 }
Result: Sin(u)*Ln(6);

*SEE Subst
%/mathpiper_docs


/*
Examples to add to docs in the future.

Hold((a + b) * (1 + 2) * (2 + 1) * (1/2 + c) * (3/4 + d) ) /:
    {
      (x_IsOdd + y_IsEven) <- m1,
      (x_IsEven + y_IsOdd) <- m2,
      (x_IsRational + y_IsAtom)_(Denominator(x) = 2) <- m3,
    };

    %output,preserve="false"
      Result: (a+b)*m1*m2*m3*(3/4+d)
.   %/output

*/mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/lessthan_minus_operator.mpw0000644000175000017500000000016111321744335033126 0ustar  giovannigiovanni%mathpiper,def="<-"

Rulebase("<-",{left,right});
HoldArgument("<-",left);
HoldArgument("<-",right);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/CompilePatterns.mpw0000644000175000017500000000426011417150721031270 0ustar  giovannigiovanni%mathpiper,def="CompilePatterns"

LocalSymbols(LocResult) [

  Bind(LocResult,True);
  10 # LocPredicate(exp_IsAtom) <--
  [
    Local(tr,result);
    tr:=patterns;
    result:=False;
    While (tr != {})
    [
      If (First(First(tr)) = exp,
      [
        Bind(LocResult,Eval(First(Rest(First(tr)))));
        result := True;
        tr:={};
      ],
      [
        tr := Rest(tr);
      ]);
    ];
    result;
  ];

  10 # LocPredicate(exp_IsFunction) <--
  [
    Local(tr,result,head);
    tr:=patterns;
    result:=False;
    While (tr != {})
    [
      Bind(head, First(First(tr)));
      If (Not(IsAtom(head)) And exp[0]=head[1] And PatternMatches(head[2], exp),
      [
        Bind(LocResult,Eval(First(Rest(First(tr)))));
        Bind(result, True);
        Bind(tr,{});
      ],
      [
        Bind(tr, Rest(tr));
      ]);
    ];
    result;
  ];
  20 # LocPredicate(_exp) <-- False;

  LocChange(_exp) <-- LocResult;
]; // LocalSymbols(LocResult)

UnFence("LocPredicate",1);
UnFence("LocChange",1);

10 # LocProcessSingle({_pat,_post,_exp}) <-- { {pat[0],PatternCreate(pat,post)},exp };

20 # LocProcessSingle({pat_IsFunction,_exp}) <-- { {pat[0],PatternCreate(pat,True)},exp };

30 # LocProcessSingle({pat_IsAtom,_exp}) <-- { pat,exp };

/*
    40 # LocProcessSingle(pat_IsFunction <- _exp) <-- { {pat[0],PatternCreate(pat,True)},exp };
    todo:tk:this rule was not handling post predicates so I replaced it with a new version that does.
    I suspect that the other rules for this Rulebase have problems too. 
*/
40 # LocProcessSingle(pat_IsFunction <- _exp) <-- 
[
    Local(justPattern, postPredicate);
    
    If(Type(pat) = "_",
        [
            //A post predicate was submitted.
            justPattern := pat[1];
            postPredicate := pat[2];
        ],
        [
            //No post predicate was submitted.
            justPattern := pat;
            postPredicate := True;
        ]
    );
    
    { {justPattern[0],PatternCreate(justPattern,postPredicate)},exp };
];

50 # LocProcessSingle(pat_IsAtom <- _exp) <-- { pat,exp };

LocProcess(patterns) :=
[
  MapSingle("LocProcessSingle",patterns);
];

CompilePatterns(patterns) := LocPatterns(LocProcess(patterns));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/AddTo.mpw0000644000175000017500000000342711523200452027151 0ustar  giovannigiovanni%mathpiper,def="AddTo"

// (a or b) and (c or d) -> (a and c) or (a and d) or (b and c) or (b and d)
20 # (list_IsList AddTo _rest) <--
[
  Local(res);
  res:={};
  ForEach(item,list)
  [
    res := Concat(res,item AddTo rest);
  ];
  res;
];
30 # (_a'item AddTo list_IsList) <--
[
  MapSingle({{orig},a'item And orig},list);
];
40 # (_a'item AddTo _b) <-- a'item And b;

%/mathpiper



%mathpiper_docs,name="AddTo",categories="User Functions;Solvers (Symbolic)"
*CMD AddTo --- add an equation to a set of equations or set of set of equations
*STD
*CALL
	eq1 AddTo eq2

*PARMS

{eq} - (set of) set of equations

*DESC

Given two (sets of) sets of equations, the command AddTo combines
multiple sets of equations into one. 

A list {a,b} means that a is a solution, OR b is a solution.
AddTo then acts as a AND operation:

	(a or b) and (c or d) => 
	(a or b) Addto (c or d) => 
	(a and c) or (a and d) or (b and c)
	  or (b and d)

This function is useful for adding an identity to an already
existing set of equations. Suppose a solve command returned
{a>=0 And x==a,a<0 And x== -a} from an expression x==Abs(a),
then a new identity a==2 could be added as follows:

In> a==2 AddTo {a>=0 And x==a,a<0 And x== -a}
Result: {a==2 And a>=0 And x==a,a==2 And a<0 And x== -a};

Passing this set of set of identities back to solve, solve
should recognize that the second one is not a possibility
any more, since a==2 And a<0 can never be true at the same time.

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.

In> {A==2,c==d} AddTo {b==3 And d==2}
Result: {A==2 And b==3 And d==2,c==d And b==3 And d==2};
In> {A==2,c==d} AddTo {b==3, d==2}
Result: {A==2 And b==3,A==2 And d==2,c==d And b==3,c==d And d==2};

*SEE Where, Solve
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/Where.mpw0000644000175000017500000000364611522464622027245 0ustar  giovannigiovanni%mathpiper,def="Where"

Rulebase("Where",{left,right});
//HoldArgument("Where",left);
//HoldArgument("Where",right);
UnFence("Where",2);
10 # (_body Where var_IsAtom == _value)
     <-- `[Local(@var);@var := @value;@body;];
20 # (_body Where (_a And _b))
     <--
[
  Bind(body,`(@body Where @a));
  `(@body Where @b);
];

30 # (_body Where {}) <-- {};
40 # (_body Where list_IsList)_IsList(list[1])
     <--
     [
       Local(head,rest);
       head:=First(list);
       rest:=Rest(list);
       rest:= `(@body Where @rest);
       `(@body Where @head) : rest;
     ];

50 # (_body Where list_IsList)
     <--
     [
       Local(head,rest);
       While (list != {})
       [
          head:=First(list);
          body := `(@body Where @head);
          list:=Rest(list);
        ];
        body;
     ];


60 # (_body Where _var == _value) <-- Subst(var,value)body;

%/mathpiper



%mathpiper_docs,name="Where",categories="User Functions;Solvers (Symbolic)"
*CMD Where --- substitute result into expression
*STD
*CALL
	expr Where x==v
	expr Where x1==v1 And x2==v2 And ...
	expr Where {x1==v1 And x2==v2,x1==v3
	  And x2==v4,...}

*PARMS

{expr} - expression to evaluate

{x} - variable to set

{v} - value to substitute for variable

*DESC

The operator {Where} fills in values for variables, in its simplest form.
It accepts sets of variable/value pairs defined as 

	var1==val1 And var2==val2 And ...

and fills in the corresponding values. Lists of value pairs are
also possible, as:

	{var1==val1 And var2==val2, var1==val3 And var2==val4}

These values might be obtained through {Solve}.

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.
In> x^2+y^2 Where x==2
Result: y^2+4;
In> x^2+y^2 Where x==2 And y==3
Result: 13;
In> x^2+y^2 Where {x==2 And y==3}
Result: {13};
In> x^2+y^2 Where {x==2 And y==3,x==4 And y==5}
Result: {13,41};

*SEE Solve, AddTo
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/localrules/slash_colon_colon_operator.mpw0000644000175000017500000000467511523200452033575 0ustar  giovannigiovanni%mathpiper,def="/::"

5 # (_expression /:: LocPatterns(_patterns)) <--
[
  MacroSubstitute(expression,"LocPredicate","LocChange");
];
10 # (_expression /:: _patterns) <--
[
  Local(old);
  Bind(patterns, LocProcess(patterns));
  Bind(old, expression);
  Bind(expression, MacroSubstitute(expression,"LocPredicate","LocChange"));
  While (expression != old)
  [
    Bind(old, expression);
    Bind(expression, MacroSubstitute(expression,"LocPredicate","LocChange"));
  ];
  expression;
];


%/mathpiper



%mathpiper_docs,name="/::",categories="Operators"
*CMD /: --- local simplification rules
*CMD /:: --- local simplification rules
*STD
*CALL
	expression /: patterns
	expressions /:: patterns
Precedence:
*EVAL PrecedenceGet("/:")


*PARMS

{expression} -- an expression

{patterns} -- a list of patterns

*DESC

Sometimes you have an expression, and you want to use specific
simplification rules on it that are not done by default. This
can be done with the {/:} and the {/::} operators. Suppose we have the
expression containing things such as {Ln(a*b)}, and we want
to change these into {Ln(a)+Ln(b)}, the easiest way
to do this is using the {/:} operator, as follows:

In> Sin(x)*Ln(a*b)
Result: Sin(x)*Ln(a*b);
In> % /: { Ln(_x*_y) <- Ln(x)+Ln(y) }
Result: Sin(x)*(Ln(a)+Ln(b));

A whole list of simplification rules can be built up in the list,
and they will be applied to the expression on the left hand side
of {/:} .

The forms the patterns can have are one of:

	pattern <- replacement
	{pattern,replacement}
	{pattern,postpredicate,replacement}

Note that for these local rules, {<-} should be used instead of
{<--} which would be used in a global rule.

The {/:} operator traverses an expression much as {Subst} does, that is, top
down, trying to apply the rules from the beginning of the list of
rules to the end of the list of rules. If the rules cannot be applied
to an expression, it will try subexpressions of that
expression and so on.

It might be necessary sometimes to use the {/::} operator, which
repeatedly applies the {/:} operator until the result doesn't change
any more. Caution is required, since rules can contradict each other,
which could result in an infinite loop. To detect this situation,
just use /: repeatedly on the expression. The repetitive nature
should become apparent.

*E.G.

In> Sin(u)*Ln(a*b) /: {Ln(_x*_y) <- Ln(x)+Ln(y)}
Result: Sin(u)*(Ln(a)+Ln(b));
In> Sin(u)*Ln(a*b) /:: { a <- 2, b <- 3 }
Result: Sin(u)*Ln(6);

*SEE Subst
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/0000755000175000017500000000000011722677335025443 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/slash_atsign_operator.mpw0000644000175000017500000000153311523200452032541 0ustar  giovannigiovanni%mathpiper,def="/@"

Function("/@",{func,lst}) Apply("MapSingle",{func,lst});

%/mathpiper



%mathpiper_docs,name="/@",categories="Operators"
*CMD /@ --- apply a function to all entries in a list
*STD
*CALL
	fn /@ list
Precedence:
*EVAL PrecedenceGet("/@")

*PARMS

{fn} -- function to apply

{list} -- list of arguments

*DESC
This function is a shorthand for {MapSingle}. It
successively applies the function "fn" to all the entries in
"list" and returns a list contains the results. The parameter "fn"
can either be a string containing the name of a function or a pure
function.

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.

In> "Sin" /@ {a,b}
Result: {Sin(a),Sin(b)};
In> {{a},Sin(a)*a} /@ {a,b}
Result: {Sin(a)*a,Sin(b)*b};

*SEE MapSingle, Map, MapArgs
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/om/0000755000175000017500000000000011722677335026056 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/om/om.mpw0000644000175000017500000000045211316266467027216 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( ":"        , "mathpiper","prepend"    );
OMDef( "@"        , "mathpiper","apply"      );
OMDef( "/@"       , "mathpiper","list_apply" );
OMDef( ".."       , "interval1","integer_interval" );
OMDef( "NFunction", "mathpiper","NFunction" );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/Apply.mpw0000644000175000017500000000361711523150126027243 0ustar  giovannigiovanni%mathpiper,def="Apply"

10 # Apply(_applyoper,_applyargs) _ (Or(IsString(applyoper), IsList(applyoper))) <-- ApplyFast(applyoper,applyargs);
20 # Apply(applyoper_IsAtom,_applyargs) <-- ApplyFast(ToString(applyoper),applyargs);

30 # Apply(Lambda(_args,_body),_applyargs) <-- `ApplyFast(Hold({@args,@body}),applyargs);
UnFence("Apply",2);

%/mathpiper



%mathpiper_docs,name="Apply",categories="User Functions;Functional Operators"
*CMD Apply --- apply a function to arguments
*STD
*CALL
	Apply(fn, arglist)

*PARMS

{fn} -- function to apply

{arglist} -- list of arguments

*DESC

This function applies the function "fn" to the arguments in
"arglist" and returns the result. The first parameter "fn" can
either be a string containing the name of a function or a pure
function. Pure functions, modeled after lambda-expressions, have the
form "{varlist,body}", where "varlist" is the list of formal
parameters. Upon application, the formal parameters are assigned the
values in "arglist" (the second parameter of {Apply}) and the "body" is evaluated.

Another way to define a pure function is with the Lambda construct.
Here, instead of passing in "{varlist,body}", one can pass in
"Lambda(varlist,body)". Lambda has the advantage that its arguments
are not evaluated (using lists can have undesirable effects because
lists are evaluated). Lambda can be used everywhere a pure function
is expected, in principle, because the function Apply is the only function
dealing with pure functions. So all places where a pure function can
be passed in will also accept Lambda.

An shorthand for {Apply} is provided by the {@} operator.

*E.G.
In> Apply("+", {5,9});
Result: 14;

In> Apply({{x,y}, x-y^2}, {Cos(a), Sin(a)});
Result: Cos(a)-Sin(a)^2;

In>  Apply(Lambda({x,y}, x-y^2), {Cos(a), Sin(a)});
Result: Cos(a)-Sin(a)^2

In>  Lambda({x,y}, x-y^2) @ {Cos(a), Sin(a)}
Result: Cos(a)-Sin(a)^2

*SEE Map, MapSingle, @, Lambda
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/NFunction.mpw0000644000175000017500000000565311523200452030061 0ustar  giovannigiovanni%mathpiper,def="NFunction"

/* NFunction("new'func", "old'func" {arg'list}) will define a wrapper function
around  "old'func", called "new'func", which will return "old'func(arg'list)"
only when all arguments are numbers and will return unevaluated
"new'func(arg'list)" otherwise. */
LocalSymbols(NFunction'Numberize)
[
NFunction(new'name_IsString, old'name_IsString, arg'list_IsList) <-- [
	MacroRulebase(new'name, arg'list);
	MacroRule(new'name, Length(arg'list), 0,	// check whether all args are numeric
		ListToFunction({IsNumericList, arg'list})
	)

		/* this is the rule defined for the new function.
		// this expression should evaluate to the body of the rule.
		// the body looks like this:
		// NFunction'Numberize(old'name(arg'list))
		*/
			NFunction'Numberize(ListToFunction({ToAtom("@"), old'name, arg'list}));
			// cannot use bare '@' b/c get a syntax error

];

// this function is local to NFunction.
// special handling for numerical errors: return Undefined unless given a number.
10 # NFunction'Numberize(x_IsNumber) <-- x;
20 # NFunction'Numberize(x_IsAtom) <-- Undefined;
// do nothing unless given an atom

];	// LocalSymbols()

%/mathpiper



%mathpiper_docs,name="NFunction",categories="User Functions;Functional Operators"
*CMD NFunction --- make wrapper for numeric functions
*STD
*CALL
	NFunction("newname","funcname", {arglist})

*PARMS
{"newname"} -- name of new function

{"funcname"} -- name of an existing function

{arglist} -- symbolic list of arguments

*DESC
This function will define a function named "newname"
with the same arguments as an existing function named "funcname". The new function will evaluate and return the expression "funcname(arglist)" only when
all items in the argument list {arglist} are numbers, and return unevaluated otherwise.

This can be useful when plotting functions defined through other MathPiper routines that cannot return unevaluated.

If the numerical calculation does not return a number (for example,
it might return the atom {nan}, "not a number", for some arguments),
then the new function will return {Undefined}.

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.


*E.G. notest
In> f(x) := N(Sin(x));
Result: True;
In> NFunction("f1", "f", {x});
Result: True;
In> f1(a);
Result: f1(a);
In> f1(0);
Result: 0;
Suppose we need to define a complicated function {t(x)} which cannot be evaluated unless {x} is a number:

In> t(x) := If(x<=0.5, 2*x, 2*(1-x));
Result: True;
In> t(0.2);
Result: 0.4;
In> t(x);
	In function "If" :
	bad argument number 1 (counting from 1)
	CommandLine(1) : Invalid argument
Then, we can use {NFunction()} to define a wrapper {t1(x)} around {t(x)} which will not try to evaluate {t(x)} unless {x} is a number.

In> NFunction("t1", "t", {x})
Result: True;
In> t1(x);
Result: t1(x);
In> t1(0.2);
Result: 0.4;
Now we can plot the function.

In> Plot2D(t1(x), -0.1: 1.1)
Result: True;

*SEE MacroRule
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/atsign_operator.mpw0000644000175000017500000000154711523200452031354 0ustar  giovannigiovanni%mathpiper,def="@"

Rulebase("@",{func,arg});
Rule("@",2,1,IsList(arg)) Apply(func,arg);
Rule("@",2,2,True       ) Apply(func,{arg});

%/mathpiper



%mathpiper_docs,name="@",categories="Operators"
*CMD @ --- apply a function
*STD
*CALL
	fn @ arglist
Precedence:
*EVAL PrecedenceGet("@")

*PARMS

{fn} -- function to apply

{arglist} -- single argument, or a list of arguments

*DESC

This function is a shorthand for {Apply}. It applies the
function "fn" to the argument(s) in "arglist" and returns the
result. The first parameter "fn" can either be a string containing
the name of a function or a pure function.

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.

In> "Sin" @ a
Result: Sin(a);
In> {{a},Sin(a)} @ a
Result: Sin(a);
In> "f" @ {a,b}
Result: f(a,b);

*SEE Apply
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/dot_dot_operator.mpw0000644000175000017500000000173211523200452031517 0ustar  giovannigiovanni%mathpiper,def=".."

/*
.. operator is implemented with the Table function.
*/
10 # (count'from_IsInteger .. count'to_IsInteger)_(count'from <= count'to)
   <-- Table(i,i,count'from,count'to,1);
20 # (count'from_IsInteger .. count'to_IsInteger)
   <-- Table(i,i,count'from,count'to,-1);

%/mathpiper



%mathpiper_docs,name="..",categories="Operators"
*CMD .. --- construct a list of consecutive integers

*STD

*CALL
	n .. m

*PARMS

{n} -- integer. the first entry in the list

{m} -- integer, the last entry in the list

*DESC

This command returns the list {{n, n+1, n+2, ..., m}}. If {m} is
smaller than {n}, the empty list is returned. Note that the
{..} operator should be surrounded by spaces to keep the
parser happy, if "n" is a number. So one should write "{1 .. 4}" instead of "{1..4}".

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.

In> 1 .. 4
Result: {1,2,3,4};

*SEE Table
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/functional/colon_operator.mpw0000644000175000017500000000323111321250634031174 0ustar  giovannigiovanni%mathpiper,def=":"

/* Operators for functional programming. todo:tk:move some of this documentation into the proper function's .mpw files.
 * Examples:
 *  a:b:c:{}       ->  {a,b,c}
 *  "Sin" @ a      ->   Sin(a)
 *  "Sin" @ {a,b}  ->   Sin(a,b)
 *  "Sin" /@ {a,b} ->   {Sin(a),Sin(b)}
 *  1 .. 4         ->   {1,2,3,4}
 */


/* a : b will now return unevaluated (rather than cause error of invalid argument in Concat) if neither a nor b is a list and if one of them is not a string
*/
Rulebase(":",{head,tail});
Rule(":",2,20,IsList(head) And Not IsList(tail) ) Concat(head,{tail});
Rule(":",2,30,IsList(tail) ) Concat({head},tail);
Rule(":",2,10,IsString(tail) And IsString(head)) ConcatStrings(head,tail);
UnFence(":",2);

%/mathpiper



%mathpiper_docs,name=":",categories="Operators"
*CMD : --- append one item to a list or prepend one or more items to a list or concatenate strings
*STD
*CALL
    list : item
	item : list
    item : item : list
	string1 : string2
    
Precedence = 70

*PARMS
{item} -- an item to append or prepend to a list

{list} -- a list

{string1} -- a string

{string2} -- a string

*DESC

The first form appends a single "item" to "list".  The second form 
prepends one or more "items" to "list"
The third form concatenates the strings "string1" and
"string2".

This operator can help the user to program in the style of functional programming languages such as Miranda or Haskell.

*E.G.

In> {}:a
Result: {a}

In> {a,b}:c
Result: {a,b,c}

In> a:b:c:{}
Result: {a,b,c};

In> a:b:{c}:d
Result: {a,b,c,d}

In> "This":"Is":"A":"String"
Result: "ThisIsAString";

*SEE Concat, ConcatStrings
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/limit/0000755000175000017500000000000011722677333024415 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/limit/om/0000755000175000017500000000000011722677333025030 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/limit/om/om.mpw0000644000175000017500000000341111320713454026154 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef("Limit", "limit1","limit",
      {  _0, _2, OMS("limit1", "under"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Left)
      |{ _0, _2, OMS("limit1", "above"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Right)
      |{ _0, _2, OMS("limit1", "both_sides"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _3) },
      { _0, _{3,2,1}, _1, Left,  _{3,3}}_(_2=OMS("limit1", "below"))
      |{_0, _{3,2,1}, _1, Right, _{3,3}}_(_2=OMS("limit1", "above"))
      |{_0, _{3,2,1}, _1, _{3,3}}
     );
// Test [result Limit(x,0,Right)1/x]: PipeFromString(PipeToString()OMForm(Limit(x,0,Right) 1/x))OMRead()

// As explained in the manual, "limit1:both_sides" and "fns1:lambda" will
// be handled as OMS("limit1", "both_sides") and OMS("fns1", "lambda"), so
// we don't need to define bogus mappings for them:
// OMDef("OMSymbolLimit1BothSides", "limit1", "both_sides");
// OMDef("OMSymbolLambda", "fns1", "lambda");
// The same applies to "Left" and "Right", which are undefined symbols
// that are used only inside limit expressions, so they don't need a mapping
// of their own.
// We could define them as follows:
//OMDef("Left",  "limit1","below");
//OMDef("Right", "limit1","above");
// and then use the following rules instead:
//      {  _0, _2, Left,  OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Left)
//      |{ _0, _2, Right, OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) }_(_3=Right)
//      |{ _0, _2, OMS("limit1", "both_sides"), OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _3) },
//      { _0, _{3,2,1}, _1, _2, _{3,3}}_(_2=Left Or _2=Right)
//      |{_0, _{3,2,1}, _1, _{3,3}}
// The result is exactly the same. The only difference is when producing the
// OMForm of the symbols themselves, outside the limit expression.


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/limit/Limit.mpw0000644000175000017500000004323311641706064026217 0ustar  giovannigiovanni%mathpiper,def="Limit"

100 # IsIrrationalFunction(Sqrt(_expr), _var)_(IsPolynomial(expr, var) And Degree(expr, var) > 0 Or IsIrrationalFunction(expr,var)) <-- True;
100 # IsIrrationalFunction(_expr^_p, _var)_((IsPolynomial(expr, var) Or IsIrrationalFunction(expr,var)) And IsRationalOrNumber(p) And Not IsZero(p) And Not IsPositiveInteger(p)) <-- True;
100 # IsIrrationalFunction(_e1 + _e2, _var)_(IsIrrationalFunction(e1, var) And IsIrrationalFunction(e2, var) Or IsPolynomial(e1, var) And IsIrrationalFunction(e2, var) Or IsIrrationalFunction(e1, var) And IsPolynomial(e2, var)) <-- True;
100 # IsIrrationalFunction(_e1 - _e2, _var)_(IsIrrationalFunction(e1, var) And IsIrrationalFunction(e2, var) Or IsPolynomial(e1, var) And IsIrrationalFunction(e2, var) Or IsIrrationalFunction(e1, var) And IsPolynomial(e2, var)) <-- True;
100 # IsIrrationalFunction(_e1 * _e2, _var)_(IsIrrationalFunction(e1, var) And IsIrrationalFunction(e2, var) Or IsPolynomial(e1, var) And IsIrrationalFunction(e2, var) Or IsIrrationalFunction(e1, var) And IsPolynomial(e2, var)) <-- True;
100 # IsIrrationalFunction(_e1 / _e2, _var)_(IsIrrationalFunction(e1, var) And IsIrrationalFunction(e2, var) Or IsPolynomial(e1, var) And IsIrrationalFunction(e2, var) Or IsIrrationalFunction(e1, var) And IsPolynomial(e2, var)) <-- True;

500 # IsIrrationalFunction(_expr, _var) <-- False;

100 # IrrationalFunctionDegree(Sqrt(_expr), _var)_(IsPolynomial(expr, var)) <-- Degree(expr, var) / 2;
105 # IrrationalFunctionDegree(Sqrt(_expr), _var)_(IsIrrationalFunction(expr, var)) <-- IrrationalFunctionDegree(expr, var) / 2;
110 # IrrationalFunctionDegree(_expr^_p, _var)_(IsPolynomial(expr, var) And IsRationalOrNumber(p) And Not IsZero(p) And Not IsPositiveInteger(p)) <-- Degree(expr, var) * p;
110 # IrrationalFunctionDegree(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- Maximum(IrrationalFunctionDegree(e1,var), IrrationalFunctionDegree(e2,var));
110 # IrrationalFunctionDegree(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- Maximum(IrrationalFunctionDegree(e1,var), Degree(e2, var));
110 # IrrationalFunctionDegree(_e1 - _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- Maximum(Degree(e1, var), IrrationalFunctionDegree(e2,var));
110 # IrrationalFunctionDegree(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- Maximum(IrrationalFunctionDegree(e1,var), IrrationalFunctionDegree(e2,var));
110 # IrrationalFunctionDegree(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- Maximum(IrrationalFunctionDegree(e1,var), Degree(e2, var));
110 # IrrationalFunctionDegree(_e1 + _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- Maximum(Degree(e1, var), IrrationalFunctionDegree(e2,var));
110 # IrrationalFunctionDegree(_e1 * _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- IrrationalFunctionDegree(e1,var) + IrrationalFunctionDegree(e2,var);
110 # IrrationalFunctionDegree(_e1 * _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- IrrationalFunctionDegree(e1,var) + Degree(e2, var);
110 # IrrationalFunctionDegree(_e1 * _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- Degree(e1, var) + IrrationalFunctionDegree(e2,var);

110 # IrrationalFunctionDegree(_e1 / _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- IrrationalFunctionDegree(e1,var) - IrrationalFunctionDegree(e2,var);
110 # IrrationalFunctionDegree(_e1 / _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- IrrationalFunctionDegree(e1,var) - Degree(e2, var);
110 # IrrationalFunctionDegree(_e1 / _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- Degree(e1, var) - IrrationalFunctionDegree(e2,var);

100 # IrrationalFunctionLeadingCoef(Sqrt(_expr), _var)_(IsPolynomial(expr, var)) <-- Sqrt(LeadingCoef(expr, var));
105 # IrrationalFunctionLeadingCoef(Sqrt(_expr), _var)_(IsIrrationalFunction(expr, var)) <-- Sqrt(IrrationalFunctionLeadingCoef(expr, var));
110 # IrrationalFunctionLeadingCoef(_expr^_p, _var)_(IsPolynomial(expr, var) And IsRationalOrNumber(p) And Not IsZero(p) And Not IsPositiveInteger(p)) <-- LeadingCoef(expr, var)^p;

110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) > IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) < IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) = IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) + IrrationalFunctionLeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) > Degree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) < Degree(e2,var)) <-- LeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) = Degree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) + LeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) > IrrationalFunctionDegree(e2,var)) <-- LeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) < IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 + _e2, _var)_(IsPolynomiaml(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) = IrrationalFunctionDegree(e2,var)) <-- LeadingCoef(e1,var) + IrrationalFunctionLeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) > IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) < IrrationalFunctionDegree(e2,var)) <-- -IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var) And IrrationalFunctionDegree(e1,var) = IrrationalFunctionDegree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) - IrrationalFunctionLeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) > Degree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) < Degree(e2,var)) <-- -LeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var) And IrrationalFunctionDegree(e1,var) = Degree(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) - LeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) > IrrationalFunctionDegree(e2,var)) <-- LeadingCoef(e1,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) < IrrationalFunctionDegree(e2,var)) <-- -IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 - _e2, _var)_(IsPolynomiaml(e1,var) And IsIrrationalFunction(e2,var) And Degree(e1,var) = IrrationalFunctionDegree(e2,var)) <-- LeadingCoef(e1,var) - IrrationalFunctionLeadingCoef(e2,var);

110 # IrrationalFunctionLeadingCoef(_e1 * _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) * IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 * _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) * LeadingCoef(e2, var);
110 # IrrationalFunctionLeadingCoef(_e1 * _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- LeadingCoef(e1, var) * IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 / _e2, _var)_(IsIrrationalFunction(e1,var) And IsIrrationalFunction(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) / IrrationalFunctionLeadingCoef(e2,var);
110 # IrrationalFunctionLeadingCoef(_e1 / _e2, _var)_(IsIrrationalFunction(e1,var) And IsPolynomial(e2,var)) <-- IrrationalFunctionLeadingCoef(e1,var) / LeadingCoef(e2, var);
110 # IrrationalFunctionLeadingCoef(_e1 / _e2, _var)_(IsPolynomial(e1,var) And IsIrrationalFunction(e2,var)) <-- LeadingCoef(e1, var) / IrrationalFunctionLeadingCoef(e2,var);



/*                            */
/*  Limit operator rule base  */
/*                            */

/* Special case: limits of polynomials as x approaches infinity */
100 # Lim(_var, _tar, _dir, _p)_(IsPolynomial(p, var) And Degree(p, var) > 0 And IsInfinity(tar))
    <-- LeadingCoef(p,var) * Sign(tar)^Degree(p,var) * Infinity;

/* Special case: limits of rational function as x approaches infinity */
110 # Lim(_var, _tar, _dir, _r)_(IsRationalFunction(r, var) And IsInfinity(tar)) <-- 
[
    Local(p,q,pd,qd,pc,qc);

    p:=Numerator(r);
    q:=Denominator(r);

    pd:=Degree(p,var);
    qd:=Degree(q,var);

    pc:=LeadingCoef(p,var);
    qc:=LeadingCoef(q,var);

    If(pd>qd,
        pc/qc*tar,
        If(pd=qd,pc/qc,0)
    );
];

/* Special case: limits of irrational function as x approaches infinity */
110 # Lim(_var, _tar, _dir, _expr)_(IsIrrationalFunction(expr, var) And IsInfinity(tar)) <-- 
[
    Local(lc,dg);

    lc:=IrrationalFunctionLeadingCoef(expr, var);
    dg:=IrrationalFunctionDegree(expr, var);

    If(lc = 0,
        0,
        If(dg > 0,
            Sign(tar)^dg * Infinity,
            If(dg = 0, lc, 0)
        )
    );
];


/* Special case: make use of the logarithm properties */
120 # Lim(_var, _tar, _dir, Ln(_a) + Ln(_b)) <-- Lim(var, tar, dir, Ln(a*b));
120 # Lim(_var, _tar, _dir, Ln(_a) - Ln(_b)) <-- Lim(var, tar, dir, Ln(a/b));

/*  Exponentiation rules  */

/*  Special limit #1:  0 ^ 0;  #2:  1 ^ Infinity;  #3:  Infinity ^ 0  */
200 # Lim(_var, _tar, _dir, _x ^ _y)_
( [
    Local(lx,ly); lx := Lim(var, tar, dir, x); ly := Lim(var, tar, dir, y);
    ((IsZero(lx) And IsZero(ly)) Or ((lx = 1) And IsInfinity(ly)) Or (IsInfinity(lx) And IsZero(ly)));
] )
<-- Exp(Lim(var, tar, dir, y * Ln(x)));

/*  Default rule  */
210 # Lim(_var, _tar, _dir, _x ^ _y)
<-- Lim(var, tar, dir, x)^Lim(var, tar, dir, y);


/*  Division rules  */

/*  Special limit #4:  0 / 0;  #5:  Infinity / Infinity  */
300 # Lim(_var, _tar, _dir, _x / _y)_
( [
    Local(lx,ly,infx,infy);
     lx := Lim(var, tar, dir, x);
     ly := Lim(var, tar, dir, y);
     infx := (IsInfinity(lx) Or (IsZero(Re(lx)) And IsInfinity(Im(lx))));
     infy := (IsInfinity(ly) Or (IsZero(Re(ly)) And IsInfinity(Im(ly))));
    ((IsZero(lx) And IsZero(ly)) Or
     (infx And infy)
     );
] )
<-- Lim(var, tar, dir, ApplyFast("Differentiate", {var, x})/ApplyFast("Differentiate", {var, y}));

/*  Special limit #6: null denominator  */
/*  Probably there are still some problems.  */

Dir(Right) <-- 1;
Dir(Left) <-- -1;

/*  To get the sign of the denominator on one side:  */
Sign(_var, _tar, _dir, _exp, _n)
<-- [
  Local(der, coef); der := ApplyFast("Differentiate", {var, exp});
  coef := Eval(ApplyFast("Subst", {var, tar, der}));
  If ( coef = 0,
       Sign(var, tar, dir, der, n+1),
       (Sign(coef)*Dir(dir)) ^ n
     );
];

/*  To avoid infinite recursion (with 1/Exp(-x) for instance)  */
310 # Lim(_var, _tar, _dir, _x / _y)_
(IsInfinity(tar) And IsZero(Lim(var, tar, dir, y)))
<-- Sign(Lim(var, tar, dir, x))*Sign(Lim(var, tar, dir, ApplyFast("Differentiate", {var, y})))*tar;

320 # Lim(_var, _tar, _dir, _x / _y)_IsZero(Lim(var, tar, dir, y))
<-- Sign(Lim(var, tar, dir, x))*Sign(var, tar, dir, y, 1)*Infinity;


/*  Default rule  */
330 # Lim(_var, _tar, _dir, _x / _y) <-- [
    Local(u,v,r);

    u := Lim(var, tar, dir, x);
    v := Lim(var, tar, dir, y);

    r := u / v;

    If (u = Undefined And IsInfinity(v), [
        Local(li, ls);

        li := LimInf(var,tar,dir,x); 
        ls := LimSup(var,tar,dir,x);
        r := (li * ls) / v;
    ]);

    r;
];


/*  Multiplication rules  */

/*  To avoid some infinite recursions  */
400 # Lim(_var, _tar, _dir, _x * Exp(_y))_
(IsInfinity(Lim(var, tar, dir, x)) And (Lim(var, tar, dir, y) = -Infinity))
<-- Lim(var, tar, dir, x/Exp(-y));
400 # Lim(_var, _tar, _dir, Exp(_x) * _y)_
((Lim(var, tar, dir, x) = -Infinity) And IsInfinity(Lim(var, tar, dir, y)))
<-- Lim(var, tar, dir, y/Exp(-x));
400 # Lim(_var, _tar, _dir, Ln(_x) * _y)_
(IsZero(Lim(var, tar, dir, x)) And IsZero(Lim(var, tar, dir, y)))
<-- Lim(var, tar, dir, y*Ln(x));

/*  Special limit #7:  0 * Infinity  */
410 # Lim(_var, _tar, _dir, _x * _y)_
((IsZero(Lim(var, tar, dir, x)) And IsInfinity(Lim(var, tar, dir, y)))
  Or (IsInfinity(Lim(var, tar, dir, x)) And IsZero(Lim(var, tar, dir, y))))
<-- Lim(var, tar, dir, Simplify(ApplyFast("Differentiate", {var, y})/ApplyFast("Differentiate",
{var, 1/x})));

/*  Default rule  */
420 # Lim(_var, _tar, _dir, _x * _y) <-- [
    Local(u,v,r);

    u := Lim(var, tar, dir, x);
    v := Lim(var, tar, dir, y);

    r := u * v;

    If (u = 0 And v = Undefined, [
        li := LimInf(var,tar,dir,y); 
        ls := LimSup(var,tar,dir,y);
        r := u * li * ls;
    ], If (u = Undefined And v = 0, [
        li := LimInf(var,tar,dir,x); 
        ls := LimSup(var,tar,dir,x);
        r := v * li * ls;
    ]));

    r;
];

/*  Substraction rules  */

/*  Special limit #8:  Infinity - Infinity  */
500 # Lim(_var, _tar, _dir, _x - _y)_
( [
    Local(lx,ly); lx := Lim(var, tar, dir, x); ly := Lim(var, tar, dir, y);
    ((lx = Infinity) And (ly = Infinity)) Or ((lx = -Infinity) And (ly = -Infinity));
] )
<-- Lim(var, tar, dir, x*(1-y/x));

/*  Default rule  */
510 # Lim(_var, _tar, _dir, _x - _y)
<-- Lim(var, tar, dir, x)-Lim(var, tar, dir, y);

/*  Unary minus  */
520 # Lim(_var, _tar, _dir, - _x)
<-- - Lim(var, tar, dir, x);


/*  Addition rules  */

/*  Special limit #9:  Infinity + (-Infinity)  */
600 # Lim(_var, _tar, _dir, _x + _y)_
( [
    Local(lx,ly); lx := Lim(var, tar, dir, x); ly := Lim(var, tar, dir, y);
    ((lx = Infinity) And (ly = -Infinity)) Or ((lx = -Infinity) And (ly = Infinity));
] )
<-- Lim(var, tar, dir, x*(1+y/x));

603 # Lim(_var, _tar, _dir, _x + _y)_
(
    Lim(var, tar, dir, x) = Infinity And Lim(var, tar, dir, y) = Undefined And LimInf(var, tar, dir, y) != -Infinity
    Or
    Lim(var, tar, dir, x) = Undefined And LimInf(var, tar, dir, x) != -Infinity And Lim(var, tar, dir, y) = Infinity

) <-- Infinity;

/*  Default rule  */
610 # Lim(_var, _tar, _dir, _x + _y)
<-- Lim(var, tar, dir, x)+Lim(var, tar, dir, y);

/*  Global default rule : evaluate expression  */

700 # Lim(_var, _tar, _dir, exp_IsFunction)
<-- Eval(MapArgs(exp,"LimitArgs"));

LimitArgs(_arg) <-- Lim(var,tar,dir,arg);
UnFence("LimitArgs",1); /* Allow LimitArgs to have access to the local variables of the caller. */

701 # Lim(_var, _tar, _dir, _exp)
<-- Eval(ApplyFast("Subst", {var, tar, exp}));


/*  Limit without direction  */

10 # Lim(_var, tar_IsInfinity, _exp) <-- Lim(var, tar, None, exp);

20 # Lim(_var, _tar, _exp)
<-- [
  Local(l); l := Lim(var, tar, Left, exp);
  If ( l = Lim(var, tar, Right, exp),
       l,
       Undefined
     );
];


100 # LimInf(_var, _tar, _dir, Cos( _exp ))_IsInfinity(Lim(var,tar,dir,exp)) <-- -1;
100 # LimInf(_var, _tar, _dir, Sin( _exp ))_IsInfinity(Lim(var,tar,dir,exp)) <-- -1;

500 # LimInf(_var, _tar, _dir, _exp) <-- Lim(var,tar,dir,exp);

100 # LimSup(_var, _tar, _dir, Cos( _exp ))_IsInfinity(Lim(var,tar,dir,exp)) <-- 1;
100 # LimSup(_var, _tar, _dir, Sin( _exp ))_IsInfinity(Lim(var,tar,dir,exp)) <-- 1;

500 # LimSup(_var, _tar, _dir, _exp) <-- Lim(var,tar,dir,exp);


/* User-callable function */

(Limit(_var,_lim)(_fie)) <-- [
    Check(IsAtom(var) And Not(IsNumber(var)), "Argument", ExpressionToString(var) : " is not a valid variable");
    Lim(var,lim,fie); 
];

(Limit(_var,_lim,_direction)(_fie)) <-- [
    Check(IsAtom(var) And Not(IsNumber(var)), "Argument", ExpressionToString(var) : " is not a valid variable");
    Lim(var,lim,direction,fie);
];

UnFence("Limit",3);


%/mathpiper



%mathpiper_docs,name="Limit",categories="User Functions;Calculus Related (Symbolic)"
*CMD Limit --- limit of an expression
*STD
*CALL
	Limit(var, val) expr
	Limit(var, val, dir) expr

*PARMS

{var} -- a variable

{val} -- a number

{dir} -- a direction ({Left} or {Right})

{expr} -- an expression

*DESC

This command tries to determine the value that the expression "expr"
converges to when the variable "var" approaches "val". One may use
{Infinity} or {-Infinity} for
"val". The result of {Limit} may be one of the
symbols {Undefined} (meaning that the limit does not
exist), {Infinity}, or {-Infinity}.

The second calling sequence is used for unidirectional limits. If one
gives "dir" the value {Left}, the limit is taken as
"var" approaches "val" from the positive infinity; and {Right} will take the limit from the negative infinity.

*E.G.

In> Limit(x,0) Sin(x)/x
Result: 1;
In> Limit(x,0) (Sin(x)-Tan(x))/(x^3)
Result: -1/2;
In> Limit(x,0) 1/x
Result: Undefined;
In> Limit(x,0,Left) 1/x
Result: -Infinity;
In> Limit(x,0,Right) 1/x
Result: Infinity;
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/0000755000175000017500000000000011722677326024361 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/PAdicExpand.mpw0000644000175000017500000000166011601310352027204 0ustar  giovannigiovanni%mathpiper,def="PAdicExpand"

10 # PAdicExpand(_x,_y) <--
[
  Local(coefs);
  coefs:=PAdicExpandInternal(x,y);
  Subst(p,y)Add(coefs*(p^(0 .. Length(coefs)-1)));
];

%/mathpiper



%mathpiper_docs,name="PAdicExpand",categories="User Functions;Number Theory"
*CMD PAdicExpand --- p-adic expansion
*STD
*CALL
	PAdicExpand(n, p)

*PARMS

{n} -- number or polynomial to expand

{p} -- base to expand in

*DESC

This command computes the $p$-adic expansion of $n$. In other words,
$n$ is expanded in powers of $p$. The argument $n$ can be either
an integer or a univariate polynomial. The base $p$ should be of the
same type.

*E.G.

In> PrettyForm(PAdicExpand(1234, 10));
	
	               2     3
	3 * 10 + 2 * 10  + 10  + 4
	
Result: True;
In> PrettyForm(PAdicExpand(x^3, x-1));
	
	                             2            3
	3 * ( x - 1 ) + 3 * ( x - 1 )  + ( x - 1 )  + 1
	
Result: True;

*SEE Mod, ContFrac, FromBase, ToBase
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/ExtendedEuclidean.mpw0000644000175000017500000000215711320775271030455 0ustar  giovannigiovanni%mathpiper,def="ExtendedEuclidean"

/* Extended Euclidean algorithm. Algorithm taken from
 * "Modern Computer Algebra". It does a Gcd calculation, but
 * returns the intermediate results also.
 *
 * Returns {l,r,s,t}
 * where
 * - l the number of steps required
 * - r[i] the i-th remainder
 * - s[i] and t[i] the i-th bezout coefficients of f and g:
     s[i]*f + t[i]*g = r[i] .
 * The gcd is r[l].
 *
 * This is a slightly modified version from the one described in
 * "Modern Computer Algebra", where the elements in list r are not
 * monic. If needed this can be done afterwards. As a consequence
 * this version works on integers as well as on polynomials.
 */

ExtendedEuclidean(_f,_g) <--
[
   Local(r,s,t,i);

   /* Initialize the loop */
   r:={f,g};
   s:={1,0};
   t:={0,1};
   i:=1;

   Local(q,newr,news,newt);
   newr:=1;
   While(newr != 0)
   [
     newr:=Rem(r[i],r[i+1]);
     q   :=Quotient(r[i],r[i+1]);
     news  :=(s[i]-q*s[i+1]);
     newt  :=(t[i]-q*t[i+1]);
     DestructiveAppend(r  ,newr);
     DestructiveAppend(s,news);
     DestructiveAppend(t,newt);
     i++;
   ];
   {r[i],s[i],t[i]};
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/RationalForm.mpw0000644000175000017500000000036411316304766027500 0ustar  giovannigiovanni%mathpiper,def="RationalForm",private="true"

10 # RationalForm((g_CanBeUni(var))/(f_CanBeUni(var)),_var)
     <-- { MakeUni(g,var),MakeUni(f,var)};
20 # RationalForm(f_CanBeUni(var),_var)
     <-- { MakeUni(f,var),MakeUni(1,var)};

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/Together.mpw0000644000175000017500000000245311517224250026655 0ustar  giovannigiovanni%mathpiper,def="Together"

//Retract("Together",*);

10 # Together((_f/_g) + (_h/_i)) <--  Simplify(Expand(f*i+h*g)/Expand(g*i));

10 # Together((_f/_g) - (_h/_i)) <--  Simplify(Expand(f*i-h*g)/Expand(g*i));

20 # Together(_f + (_g / _h))    <--  Simplify(Expand(f*h+g)/h);

20 # Together((_f/_g) + _h)      <--  Simplify(Expand(f+h*g)/g);

20 # Together(_f - (_g / _h))    <--  Simplify(Expand(f*h-g)/h);

20 # Together((_f/_g) - _h)      <--  Simplify(Expand(f-h*g)/g);

20 # Together(- (_g / _h))       <--  Simplify((-g)/h);

20 # Together((_f/_g) * _h)      <--  Simplify(Expand(f*h)/g);

20 # Together(_h * (_f/_g))      <--  Simplify(Expand(f*h)/g);

20 # Together((_f/_g) / _h)      <--  Simplify((f)/Expand(g*h));

20 # Together(_h / (_f/_g))      <--  Simplify(Expand(g*h)/f);

20 # Together(- _f)              <-- - Together(f);

30 # Together(_f)                <--  f;

%/mathpiper




%mathpiper_docs,name="Together",categories="User Functions;Number Theory"
*CMD Together --- places terms in a sum over a common denominator and cancels factors in the result
*CALL
    Together(expression)

*PARMS

{expression} -- a sum

*DESC
This function places terms in a sum over a common denominator and cancels factors in the result.

*E.G.
In> Together(a/b + c/d)
Result: (d*a+b*c)/(d*b)

*SEE Apart

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/ChineseRemainderInteger.mpw0000644000175000017500000000106711320775271031625 0ustar  giovannigiovanni%mathpiper,def="ChineseRemainderInteger"

/* Chinese Remaindering algorithm, as described in "Modern Computer Algebra".
 */
ChineseRemainderInteger(mlist_IsList,vlist_IsList) <--
[
  Local(m,i,nr,result,msub,euclid,clist);
  clist:={};
  m:=Product(mlist);
  result:=0;

  nr:=Length(mlist);
  For(i:=1,i<=nr,i++)
  [
    msub:=Quotient(m,mlist[i]);
    euclid := ExtendedEuclidean(msub,mlist[i]);
    Local(c);
    c:=vlist[i] * euclid[2];
    c:=Rem(c, mlist[i]);
    DestructiveAppend(clist,c);
    result:=result + msub * c;
  ];
  {result,clist};
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/ExtendedEuclideanMonic.mpw0000644000175000017500000000156011320776303031435 0ustar  giovannigiovanni%mathpiper,def="ExtendedEuclideanMonic"

ExtendedEuclideanMonic(_f,_g) <--
[
   Local(rho,r,s,t,i);

/*
Echo({f,g});
Echo({});
*/

   /* Initialize the loop */
   rho:={LeadingCoef(f),LeadingCoef(g)};
   r:={Monic(f),Monic(g)};
   s:={1/(rho[1]),0};
   t:={0,1/(rho[2])};
   i:=1;

   Local(q,newr,news,newt,newrho);
   newr:=r[2];
   While(newr != 0)
   [
     q   :=Quotient(r[i],r[i+1]);
     newr:=Modulo(r[i],r[i+1]);
     newrho:=LeadingCoef(newr);


     If (newr != 0, newr:=Monic(newr));
     news  :=(s[i]-q*s[i+1]);
     newt  :=(t[i]-q*t[i+1]);
     If(newrho != 0,
       [
         news:=news/newrho;
         newt:=newt/newrho;
       ]);
     DestructiveAppend(rho,newrho);
     DestructiveAppend(r  ,newr);
     DestructiveAppend(s,news);
     DestructiveAppend(t,newt);
     i++;
   ];

/*
TableForm({i,r,s,t});
Echo({});
*/

   {r[i],s[i],t[i]};
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/GcdReduce.mpw0000644000175000017500000000066011320775271026725 0ustar  giovannigiovanni%mathpiper,def="GcdReduce"

/* Reduce rational function by dividing gcd away */
GcdReduce(_f,_var)<--
[
  Local(rat,gcd);
  rat:=RationalForm(f,var);
  gcd:=Gcd(rat[1],rat[2]);
/*  gcd:=gcd*Gcd(Content(rat[1]),Content(rat[2]));*/

  Local(numer,denom,lc);
  numer:=Quotient(rat[1],gcd);
  denom:=Quotient(rat[2],gcd);
  lc:=LeadingCoef(numer,var);
  numer:=numer/lc;
  denom:=denom/lc;
  Expand(numer)/Expand(denom);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/padic/PartFracExpand.mpw0000644000175000017500000000272511601305346027740 0ustar  giovannigiovanni%mathpiper,def="PartFracExpand"

/* Partial fraction expansion of g/f with Degree(g) Apart(1/(x^2-1),x);
Result: 1/(2*(x-1))+(-1)/(2*(x+1))

*SEE Together

%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/0000755000175000017500000000000011722677333025261 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/AntiDeriv.mpw0000644000175000017500000002134611561065465027677 0ustar  giovannigiovanni%mathpiper,def="AntiDeriv"

//todo:tk:this file need to be broken down further.

//tk:this code was moved here from Integrate.mpw because it was causing a 
// "rulebase with this arity already defined" error.
//hso:but the Rulebase line causes hang when processing in fold
//Rulebase("IntegrateMultiplicative",{var,from,a,b});

//Retract("AntiDeriv",*);
//Retract("IntFunc",*);


////////////////////////////////////////////////
//
// Anti-derivative of a univariate polynomial
//
////////////////////////////////////////////////
5  # AntiDeriv(_var, poly_CanBeUni(var) )
     <-- NormalForm(AntiDeriv(var,`MakeUni(@poly,@var)));
5 # AntiDeriv(_var,UniVariate(_var,_first,_coefs)) <--
[
  Local(result,i);
  result:=FlatCopy(coefs);
  For(i:=1,i<=Length(result),i++)
  [
    result[i]:= result[i]/(first+i);
  ];
  UniVariate(var,first+1,result);
];


////////////////////////////////////////////////
//
// Standard additive properties of integration.
//
////////////////////////////////////////////////
10 # AntiDeriv(_var,_x + _y) <-- AntiDeriv(var,x) + AntiDeriv(var,y);
10 # AntiDeriv(_var,_x - _y) <-- AntiDeriv(var,x) - AntiDeriv(var,y);
10 # AntiDeriv(_var,   - _y) <--            - AntiDeriv(var,y);

10 # AntiDeriv(_var,_x/c_IsFreeOf(var) )_(HasExpr(x,var)) <-- AntiDeriv(var,x)/c;
10 # AntiDeriv(_var,c_IsFreeOf(var)/_x )_(HasExpr(x,var) And c!= 1)
	<-- c*AntiDeriv(var,1/x);


////////////////////////////////////////////////
//
// Multiplying a polynomial with another (integrable)
// function, Integrate by parts.
//
////////////////////////////////////////////////
1570 # IntegrateMultiplicative(_var,(exy_CanBeUni(var)) * _exx,_dummy1,_dummy2)
     <-- IntByParts(var,exy*exx,AntiDeriv(var,exx));
1570 # IntegrateMultiplicative(_var,_exx * (exy_CanBeUni(var)),_dummy1,_dummy2)
     <-- IntByParts(var,exy*exx,AntiDeriv(var,exx));
10 # IntByParts(_var,_exy * _exx,Integrate(_var)(_something)) <--
     `Hold(AntiDeriv(@var,((@exy)*(@exx))));
20 # IntByParts(_var,_exy * _exx,_anti)_(Not IsFreeOf(anti,exx)) <--
     `Hold(AntiDeriv(@var,((@exy)*(@exx))));
30 # IntByParts(_var,_exy * _exx,_anti) <--
     [
       Local(cf);
       cf:=anti*Deriv(var)exy;
//  Echo({exy*anti,exy*exx,cf});
       exy*anti - `(AntiDeriv(@var,@cf));
     ];

////////////////////////////////////////////////
//
// Rational functions: f(x)/g(x) where f and g are
// polynomials.
//
////////////////////////////////////////////////
1570 # IntegrateMultiplicative(_var,(exy_CanBeUni(var)) / (exx_CanBeUni(var)),_dummy1,_dummy2) <--
     IntRat(var,exy/exx,MakeUni(exy,var),MakeUni(exx,var));

10 # IntRat(_var,_exy / _exx,_exyu,_exxu)_
     (Degree(exyu) > Degree(exxu) Or Degree(Gcd(exyu,exxu)) > 0) <--
     [
     Local(gcd);
     gcd:=Gcd(exxu,exyu);
     exyu:=Quotient(exyu,gcd);
     exxu:=Quotient(exxu,gcd);
     AntiDeriv(var,NormalForm(Quotient(exyu,exxu))) +
       AntiDeriv(var,NormalForm(Modulo(exyu,exxu))/NormalForm(exxu));
     ];

11 # IntRat(_var,_exy / _exx,_exyu,_exxu)_
        (Degree(exxu,var) > 1 And LeadingCoef(exxu)=1 And
	 IsNumericList(Coef(exxu,var,0 .. Degree(exxu)))) <--
[
  Local(ee);
  ee:=Apart(exy/exx,var);
  `AntiDeriv(@var,@ee);
];


20 # IntRat(_var,_exy / _exx,_exyu,_exxu) <--
     `Hold(AntiDeriv(@var,((@exy)/(@exx))));


30 # AntiDeriv(_var,Deriv(_var)(_expr)) <-- expr;

////////////////////////////////////////////////
//
// No simple form, try something else
//
////////////////////////////////////////////////
100 # AntiDeriv(_var,_exp) <--
[
  IntegrateMultiplicative(var,exp,a,b);
];


////////////////////////////////////////////////
//
// Special anti-derivatives can be added here.
//
////////////////////////////////////////////////

// integrating expressions containing if:
10 # IntegrateMultiplicative(_var,if(_cond)(_body),_a,_b)
     <--
     [
       body := AntiDeriv(var,body);
       `Hold(if(@cond)(@body));
     ];
// integrating expressions containing else
10 # IntegrateMultiplicative(_var,(_left) else (_right),_a,_b)
     <--
     [
       left  := AntiDeriv(var,left);
       right := AntiDeriv(var,right);
       `Hold( (@left) else (@right) );
     ];


////////////////////////////////////////////////
//
// Could not find anti-derivative, return unsimplified
//
////////////////////////////////////////////////
1600 # IntegrateMultiplicative(_var,_exp,_a,_b) <-- `Hold(Integrate(@var)(@exp));

////////////////////////////////////////////////
//
// IntFunc declares the anti-derivative of a function
// that has one argument.
// Calling sequence: IntFunc(variable,from,to);
// Example: IntFunc(x,Cos(_x),Sin(x));
//
////////////////////////////////////////////////
LocalSymbols(intpred)
[
  intpred := 50;
  IntFunc(_vr,_from,_to) <--
  [
    `((@intpred) # IntegrateMultiplicative(_var,@from,_dummy1,_dummy2)_MatchLinear(var,@vr) <-- (@to)/Matched'a());
    intpred++;
  ];
];


IntPureSquare(_vr,_from,_sign2,_sign0,_to) <--
[
  `(50 # IntegrateMultiplicative(_var,@from,_dummy1,_dummy2)_MatchPureSquared(var,@sign2,@sign0,@vr) <-- (@to));
];




////////////////////////////////////////////////
//
// Declaration of the anti-derivatives of a few analytic functions
//
////////////////////////////////////////////////


IntFunc(x,Sqrt(_x),(2*Sqrt(x)^(3))/3);
IntFunc(x,1/Sqrt(_x),2*Sqrt(x));
IntFunc(x,1/_x^(_n),x^(1-n)/(1-n) );
IntFunc(x,Sin(_x),-Cos(x));
IntFunc(x,1/Sin(_x), Ln( 1/Sin(x) - Cos(x)/Sin(x) ) );
IntFunc(x,Cos(_x),Sin(x));
IntFunc(x,1/Cos(_x),Ln(1/Cos(x)+Tan(x)));
IntFunc(x,Tan(_x),-Ln(Cos(x)));
IntFunc(x,1/Tan(_x),Ln(Sin(x)) );
IntFunc(x,Cos(_x)/Sin(_x),Ln(Sin(x)));
IntFunc(x,Exp(_x),Exp(x));
IntFunc(x,(C_IsFreeOf(var))^(_x),C^x/Ln(C));
// we don't need Ln(Abs(x))
IntFunc(x,num_IsFreeOf(var) / (_x),num*Ln(x));
IntFunc(x,Ln(_x),x*Ln(x)-x);
// where did these 1+1's come from?
IntFunc(x,(_x)*Ln(_x),(1/(1+1))*x^(1+1)*Ln(x) - (1/(1+1)^2)*x^(1+1) );
IntFunc(x,Ln(_x)*(_x),(1/(1+1))*x^(1+1)*Ln(x) - (1/(1+1)^2)*x^(1+1) );

IntFunc(x,1/Sin(_x)^2,-Cos(x)/Sin(x) );
IntFunc(x,1/Cos(_x)^2,Tan(x) );
IntFunc(x,1/(Sin(_x)*Tan(_x)),-1/Sin(x));
IntFunc(x,Tan(_x)/Cos(_x),1/Cos(x));
IntFunc(x,1/Sinh(_x)^2,-1/Tanh(x));
IntFunc(x,1/Cosh(_x)^2,Tanh(x));
IntFunc(x,1/(Sinh(_x)*Tan(_x)),-1/Sinh(x));
IntFunc(x,Tanh(_x)/Cosh(_x),-1/Cosh(x));

IntFunc(x,1/Sqrt(m_IsFreeOf(x)-_x^2),ArcSin(x/Sqrt(m)) );

IntFunc(x,Exp(n_IsNumber*_x)*Sin(m_IsNumber*_x),Exp(n*x)*(n*Sin(m*x)- m*Cos(m*x))/(m^2+n^2) );

// n>0
IntFunc(x,Ln(_x)*(_x)^n_IsNumber,(1/(n+1))*x^(n+1)*Ln(x) - (1/(n+1)^2)*x^(n+1) );

// n>0
IntFunc(x,Ln(A_IsNumber*_x)*(_x)^n_IsNumber,(1/(n+1))*x^(n+1)*Ln(A*x) - (1/(n+1)^2)*x^(n+1) );

IntFunc(x,Sin(Ln(_x)),x*Sin(Ln(x))/2 - x*Cos(Ln(x))/2 );


//This is a bug fix which was posted on the Yacas list by Alberto González Palomo on 10/5/2009.
//IntFunc(x,Cos(Ln(_x)),x*Sin(Ln(x))/2 - x*Cos(Ln(x))/2 );
IntFunc(x,Cos(Ln(_x)),x*Sin(Ln(x))/2 + x*Cos(Ln(x))/2 );

IntFunc(x,1/((_x)*Ln(_x)),Ln(Ln(x)));

IntFunc(x,(_x)^(-1),Ln(x));

IntFunc(x,(_x)^(n_IsFreeOf(x)),x^(n+1)/(n+1));
IntFunc(x,C_IsFreeOf(x)*(_x)^(n_IsFreeOf(x)),C*x^(n+1)/(n+1));
IntFunc(x,C_IsFreeOf(x)/(D_IsFreeOf(x)*(_x)^(n_IsFreeOf(x))),(C/D)*x^(1-n)/(1-n));
IntFunc(x,Sinh(_x),Cosh(x));
IntFunc(x,Sinh(_x)^2,Sinh(2*x)/4 - x/2);
IntFunc(x,1/Sinh(_x),Ln(Tanh(x/2)));
IntFunc(x,Cosh(_x),Sinh(x));
IntFunc(x,Cosh(_x)^2,Sinh(2*x)/4 + x/2);
IntFunc(x,1/Cosh(_x),ArcTan(Sinh(x)));
IntFunc(x,Tanh(_x),Ln(Cosh(x)));
IntFunc(x,Tanh(_x)/Cosh(_x),-1/Cosh(x));
IntFunc(x,1/Cosh(_x)^2,Tanh(x));
//IntFunc(x,1/Sech(_x)*Coth(_x),-1/Sinh(x));
IntFunc(x,1/Tanh(_x),Ln(Sinh(x)));

IntFunc(x,Abs(_x),Abs(x)*x/2);	// not 2*a

IntFunc(x,ArcTan(_x),x*ArcTan(x) - Ln(x^2 + 1)/2);
//IntFunc(x,ArcSin(_x),(x*ArcSin(x)) + Sqrt(1-x^2) );
IntFunc(x,ArcCos(_x),x*ArcCos(x) - Sqrt(1-x^2) );

IntFunc(x,ArcTanh(_x),x*ArcTanh(x) + Ln(1-x^2)/2 );
IntFunc(x,ArcSinh(_x),x*ArcSinh(x) - Sqrt(x^2 + 1) );
IntFunc(x,ArcCosh(_x),x*ArcCosh(x) - Sqrt(x-1)*Sqrt(x+1) );


// n^2 > x^2
//IntFunc(x,num_IsFreeOf(var)/(-(_x)^2 + n_IsNumber),num*ArcTanh(x/Sqrt(n))/n);

// x^2 > n^2
//IntFunc(x,num_IsFreeOf(var)/((_x)^2 - n_IsNumber),num * -ArcCoth(x/Sqrt(n))/Sqrt(n));

// n^2 > x^2
//IntFunc(x,num_IsFreeOf(var)/Sqrt(n_IsNumber - (_x)^2),num*ArcSin(x/Sqrt(n)));

// previous code is killing this....
IntFunc(x,num_IsFreeOf(var)/(A_IsNumber + B_IsNumber*(_x))^2,-num/(A*b + B^2*x));

// Code works now?
IntFunc(x,num_IsFreeOf(var)/(n_IsNumber + m_IsNumber*Exp(p_IsNumber*(_x))),num*x/n - num*Ln(n + m*Exp(p*x))/(n*p));
IntFunc(x,num_IsFreeOf(var)/(m_IsNumber*Exp(p_IsNumber*(_x)) + n_IsNumber),num*x/n - num*Ln(n + m*Exp(p*x))/(n*p));

// note:hso: removed erroneous "a" in denominator of function below
IntPureSquare(x,num_IsFreeOf(var)/(_x),1,1,(num/(Sqrt(Matched'b()*Matched'a())))*ArcTan(var/Sqrt(Matched'b()/Matched'a())));

///// Integrating Special Functions
IntFunc(x,Erf(_x), x*Erf(x)+ 1/(Exp(x^2)*Sqrt(Pi)) );

UnFence("IntegrateMultiplicative",4);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/om/0000755000175000017500000000000011722677333025674 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/om/om.mpw0000644000175000017500000000046011316274015027021 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( "Integrate", "calculus1","defint", // Same argument reordering as Sum.
       { $, _2 .. _3, OMBIND(OMS("fns1", "lambda"), OMBVAR(_1), _4) },
       { $, _{2,2,1}, _{1,1}, _{1,2}, _{2,3} }
      );
OMDef( "AntiDeriv", mathpiper,"AntiDeriv" );


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/MatchLinear.mpw0000644000175000017500000000665311523200452030166 0ustar  giovannigiovanni%mathpiper,def="MatchLinear;MatchPureSquared"

/*
todo:tk:MatchPureSquared() is in this file because it is grouped with MatchLinear in a
LocalSymbols() block.
*/

/* Def file definitions
MatchPureSquared
*/

/** MatchLinear(variable,expression)
 */
LocalSymbols(a,b)[

10 # MatchLinear(var_IsAtom,expr_CanBeUni(var)) <--
[
  Bind(expr,MakeUni(expr,var));
  MatchLinear(expr);
];
20 # MatchLinear(_var,_expr) <-- False;

10 # MatchLinear(_expr)_(Degree(expr,var)<2) <--
[
  Check(IsUniVar(expr), "Argument", PipeToString()Echo({"Incorrect argument ",expr," passed to MatchLinear"}));

//TODO if I enable these checks, then integration fails (only users of this function any way). Can this be removed? Where are these variables cleared any way?
//  Check(a = Hold(a), "Argument", PipeToString()(Echo({"Found bound variable a which should have been unbound, in MatchLinear: ", a, "=", Eval(a)})));
//  Check(b = Hold(b), "Argument", PipeToString()(Echo({"Found bound variable b which should have been unbound, in MatchLinear: ", b, "=", Eval(b)})));

  a := Coef(expr,1);
  b := Coef(expr,0);
  True;
];
20 # MatchLinear(_expr) <-- False;
UnFence("MatchLinear",1);
UnFence("MatchLinear",2);

/** MatchPureSquared(variable,expression) - matches expressions
 *  of the form a*x^2+b.
 */
10 # MatchPureSquared(var_IsAtom,_sign2,_sign0,expr_CanBeUni(var)) <--
[
  Bind(expr,MakeUni(expr,var));
  MatchPureSquared(expr,sign2,sign0);
];
20 # MatchPureSquared(_var,_sign2,_sign0,_expr) <-- False;

10 # MatchPureSquared(_expr,_sign2,_sign0)_(Degree(expr,var)=2 And
                                    Coef(expr,1) = 0 And
				    IsNumber(Coef(expr,0)) And
				    IsNumber(Coef(expr,2)) And
				    Coef(expr,0)*sign0 > 0 And
				    Coef(expr,2)*sign2 > 0
				    ) <--
[
  Check(IsUniVar(expr), "Argument", PipeToString()Echo({"Incorrect argument ",expr," passed to MatchLinear"}));
//TODO if I enable these checks, then integration fails (only users of this function any way). Can this be removed? Where are these variables cleared any way?
//  Check(a = Hold(a), "Invariant", "Found bound variable which should have been unbound, in MatchLinear");
//  Check(b = Hold(b), "Invariant", "Found bound variable which should have been unbound, in MatchLinear");
  a := Coef(expr,2);
  b := Coef(expr,0);
  True;
];
20 # MatchPureSquared(_expr,_sign2,_sign0) <-- False;
UnFence("MatchPureSquared",3);
UnFence("MatchPureSquared",4);

Matched'a() := a;
Matched'b() := b;



]; // LocalSymbols a,b


%/mathpiper



%mathpiper_docs,name="MatchLinear",categories="User Functions;Predicates"
*CMD MatchLinear --- match an expression to a polynomial of degree one in a variable
*STD
*CALL
	MatchLinear(x,expr)

*PARMS

{x} -- variable to express the univariate polynomial in

{expr} -- expression to match

*DESC

{MatchLinear} tries to match an expression to a linear (degree less than
two) polynomial. The function returns {True} if it could match, and
it stores the resulting coefficients in the variables "{a}" and "{b}"
as a side effect. The function calling this predicate should declare
local variables "{a}" and "{b}" for this purpose.
{MatchLinear} tries to match to constant coefficients which don't
depend on the variable passed in, trying to find a form "{a*x+b}"
with "{a}" and "{b}" not depending on {x} if {x} is given as the variable.

*E.G.

In> MatchLinear(x,(R+1)*x+(T-1))
Result: True;
In> {a,b};
Result: {R+1,T-1};
In> MatchLinear(x,Sin(x)*x+(T-1))
Result: False;
	
*SEE Integrate
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/integrate/Integrate.mpw0000644000175000017500000001305211554750350027723 0ustar  giovannigiovanni%mathpiper,def="Integrate"

//todo:tk:this file need to be broken down further.


10# (Integrate(_var)(expr_IsList))
    <-- Map("Integrate",{FillList(var,Length(expr)),expr});
20 # (Integrate(_var)(_expr)) <-- IntSub(var,expr,AntiDeriv(var,IntClean(var,expr)));

20 # (Integrate(_var, optionsList_IsList)(_expr)) <--
[
    Local(result);

    optionsList := OptionsToAssociativeList(optionsList);

    result := Integrate(var) expr;

    If( optionsList["logAbs"] = "True", result := ( result /: {Ln(_x) <- Ln(Abs(x))}) );

    result;
];


10 # IntSub(_var,_expr,Integrate(_var)(_expr2)) <--
     `Hold(Integrate(@var)(@expr));
20 # IntSub(_var,_expr,_result) <-- result;	// + UniqueConstant();

////////////////////////////////////////////////
//
// Integrate over a range
//
////////////////////////////////////////////////
10# (Integrate(_var,_from,_to)(expr_IsList))
    <-- Map("Integrate",{FillList(var,Length(expr)),
                         FillList(from,Length(expr)),
			 FillList(to,Length(expr)),
                         expr});

20 # (Integrate(_var,_from,_to)(_expr))
    <-- defIntegrate(var,from,to,expr,a,b);


20 # (Integrate(_var,_from,_to,optionsList_IsList)(_expr)) <--
[
    Local(result);

    optionsList := OptionsToAssociativeList(optionsList);

    result := Integrate(var,from,to) expr;

    If( optionsList["logAbs"] = "True", result := ( result /: {Ln(_x) <- Ln(Abs(x))}) );

    result;
];

////////////////////////////////////////////////
//
// separate rules can be added here for specific integrals
// to defIntegrate
//
////////////////////////////////////////////////

10 # defIntegrate(_var,_from,_to,_expr,_a,_b)_(from = -to And IsOddFunction(expr,var)) <-- 0;

// We need to define this case (integrating from 0 to 0 over an even function)
// explicitly, otherwise the integration ends up going in to infinite recursion.
// Extended it a little bit more, since if you are integrating from A to A,
// then the result is obviously zero. There are perhaps situations where
// this does not work, where we need to simplify (to-from) first. A naive
// implementation caused a test to fail.

10 # defIntegrate(_var,_from,_from,_expr,_a,_b) <-- 0;

12 # defIntegrate(_var,_from,_to,_expr,_a,_b)_(from = -to And IsEvenFunction(expr,var))
        <-- 2*defIntegrate(var,0,to,expr,a,b);

100 # defIntegrate(_var,_from,_to,_expr,_a,_b)_(Type(AntiDeriv(var,IntClean(var,expr))) != "AntiDeriv")
        <-- IntegrateRange(var,expr,from,to,AntiDeriv(var,IntClean(var,expr)));

101 # defIntegrate(_var,_from,_to,_expr,_a,_b)
    <-- `Hold(Integrate(@var,@from,@to)(@expr));
//    <-- IntegrateRange(var,expr,from,to,AntiDeriv(var,expr));


////////////////////////////////////////////////
//
// No anti-derivative found, return unavaluated.
//
////////////////////////////////////////////////
10 # IntegrateRange(_var,_expr,_from,_to,Integrate(_var)_expr2)
    <-- `Hold(Integrate(@var,@from,@to)@expr);

////////////////////////////////////////////////
//
// Anti-derivative found, return result.
//
////////////////////////////////////////////////
20 # IntegrateRange(_var,_expr,_from,_to,_antideriv)
    <-- `(@antideriv Where @var == @to) - `(@antideriv Where @var == @from);

////////////////////////////////////////////////
//
// IntClean cleans up an expression before passing
// it on to integration. This function normalizes
// an expression in a way desirable for integration.
// TrigSimpCombine, for instance, expands expressions
// containing trigonometric functions so that they are
// additive as opposed to multiplicative.
//
// If the expression doesn't contain the variable,
// just return it as-is. This fixes:
// In> Integrate(x) z^100
//
// If the expression can be considered to be a sum
// of terms in var, then avoid premature simplification.
////////////////////////////////////////////////
10 # IntClean(_var,_expr) <--
[
	if( IsFreeOf(var,expr) Or IsSumOfTerms(var,expr) )[
		expr;
	] else if ( HasFunc(expr,Sin) Or HasFunc(expr,Cos) )[
		Simplify(TrigSimpCombine(expr));
	] else [
		Simplify(expr);
	];
];

%/mathpiper



%mathpiper_docs,name="Integrate",categories="User Functions;Calculus Related (Symbolic)"
*CMD Integrate --- integration

*STD
*CALL
	Integrate(var, x1, x2) expr
	Integrate(var) expr
        Integrate(var, {optionsList}) expr
        Integrate(var, x1, x2, {optionsList}) expr

*PARMS

{var} -- atom, variable to integrate over

{optionsList} -- a list which contains options that affect integration

{x1} -- first point of definite integration

{x2} -- second point of definite integration

{expr} -- expression to integrate

*DESC

This function integrates the expression {expr} with respect to the
variable {var}. The first calling format is used to perform
definite integration: the integration is carried out from $var=x1$
to $var=x2$. The second form is for indefinite integration.

Some simple integration rules have currently been
implemented. Polynomials, some quotients of polynomials,
trigonometric functions and their inverses, hyperbolic functions
and their inverses, {Exp}, and {Ln}, and products of these
functions with polynomials can be integrated.



{Options}:

{logAbs} -- For results which contain logs, the result is given in terms of Ln(Abs(...))
if logAbs is True, but in terms of Ln(...) if logAbs is not set or is set to anything other than True.


*E.G.
In> Integrate(x,a,b) Cos(x)
Result: Sin(b)-Sin(a);

In> Integrate(x) Cos(x)
Result: Sin(x);

In> Integrate(x) 1/x;
Result> Ln(x)

In> Integrate(x, {logAbs -> True}) 1/x;
Result> Ln(Abs(x))

In> Integrate(x, a, b, {logAbs -> True})1/x;
Result> Ln(Abs(b))-Ln(Abs(a))

*SEE Differentiate, UniqueConstant
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/trigsimp/0000755000175000017500000000000011722677332025134 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/trigsimp/TrigSimpCombine.mpw0000644000175000017500000002761411523200452030706 0ustar  giovannigiovanni%mathpiper,def="TrigSimpCombine"


/* This file defines TrigSimpCombine. TrigSimpCombine is designed to
   simplify expressions like Cos(a)*Sin(b) to additions
   only (in effect, removing multiplications between
   trigonometric functions).

   The accepted expressions allow additions and multiplications
   between trig. functions, and raising trig. functions to an
   integer power.

   You can invoke it by calling TrigSimpCombine(f). Examples:
	TrigSimpCombine(Cos(a)*Sin(a^2+b)^2)
	TrigSimpCombine(Cos(a)*Sin(a)^2)
	TrigSimpCombine(Cos(a)^3*Sin(a)^2)
	TrigSimpCombine(d*Cos(a)^3*Sin(a)^2)
	TrigSimpCombine(Cos(a)^3*Sin(a)^2)
	TrigSimpCombine(Cos(a)*Sin(a))
	TrigSimpCombine(Cos(a)*Sin(b)*Cos(c))

 */


/* FSin, FCos and :*: are used for the internal representation
   of the expression to work on:
   - a*b -> a:*:b   this is used because we want to expand powers,
     without the standard engine collapsing them back again.
   - a*Sin(b) -> FSin(a,b) and a*Cos(b) -> FCos(a,b). This makes
     adding and multiplying expressions with trig. functions, non-trig.
     functions, constants, etc. a lot easier.
*/
Rulebase("FSin",{f,x});
Rulebase("FCos",{f,x});
Rulebase(":*:",{x,y});
Infix(":*:",3);


IsTrig(f) := (Type(f) = "Sin" Or Type(f) = "Cos");
IsFTrig(f) := (Type(f) = "FSin" Or Type(f) = "FCos");
IsMul(f) := (Type(f) = "*");
IsMulF(f) := (Type(f) = ":*:");

IsPow(f):=
  (Type(f) = "^" And
   IsInteger(f[2]) And
   f[2] > 1
  );


/* Convert Sin/Cos to FSin/FCos */
Rulebase("TrigChange",{f});
Rule("TrigChange",1,1,Type(f)="Cos") FCos(1,f[1]);
Rule("TrigChange",1,1,Type(f)="Sin") FSin(1,f[1]);

Rulebase("TrigUnChange",{f});
Rule("TrigUnChange",1,1,Type(f)="FCos") Cos(f[2]);
Rule("TrigUnChange",1,1,Type(f)="FSin") Sin(f[2]);


/* Do a full replacement to internal format on a term. */
Rulebase("FReplace",{f});
UnFence("FReplace",1);
Rule("FReplace",1,1,IsMul(f))  Substitute(f[1]) :*: Substitute(f[2]);
Rule("FReplace",1,2,IsPow(f))  (Substitute(f[1]) :*: Substitute(f[1])) :*: Substitute(f[1]^(f[2]-2));
/*
Rule("FReplace",1,2,IsPow(f))
[
  Local(trm,i,res,n);
  Bind(trm,Substitute(f[1]));
  Bind(n,f[2]);
  Bind(res,trm);
  For(i:=2,i<=n,i++)
  [
    Bind(res,res :*: trm);
  ];
  res;
];
*/

Rule("FReplace",1,3,IsTrig(f)) TrigChange(f);
FTest(f):=(IsMul(f) Or IsPow(f) Or IsTrig(f));

/* Central function that converts to internal format */
FToInternal(f):=Substitute(f,"FTest","FReplace");

FReplaceBack(f):=(Substitute(f[1])*Substitute(f[2]));
UnFence("FReplaceBack",1);
FFromInternal(f):=Substitute(f,"IsMulF","FReplaceBack");


/* FLog(s,f):=[WriteString(s:" ");Write(f);NewLine();]; */
 FLog(s,f):=[];


/* FSimpTerm simplifies the current term, wrt. trigonometric functions. */
Rulebase("FSimpTerm",{f,rlist});
UnFence("FSimpTerm",2);

/* Addition: add all the subterms */
Rule("FSimpTerm",2,1,Type(f) = "+")
[
  Local(result,lst);
  lst:=Flatten(f,"+");

  result:={{},{}};
FLog("simpadd",lst);

  ForEach(tt,lst)
  [
    Local(new);
    new:=FSimpTerm(tt,{{},{}});
    result:={Concat(result[1],new[1]),Concat(result[2],new[2])};
  ];
  result;
];


TrigNegate(f):=
[
  ListToFunction({f[0],-(f[1]),f[2]});
];


FUnTrig(result) := Substitute(result,"IsFTrig","TrigUnChange");

Rule("FSimpTerm",2,1,Type(f) = "-" And ArgumentsCount(f)=1)
[
  Local(result);
  result:=FSimpTerm(f[1],{{},{}});
  Substitute(result,"IsFTrig","TrigNegate");
];
Rule("FSimpTerm",2,1,Type(f) = "-" And ArgumentsCount(f)=2)
[
  Local(result1,result2);
  result1:=FSimpTerm(f[1],{{},{}});
  result2:=FSimpTerm(-(f[2]),{{},{}});
  {Concat(result1[1],result2[1]),Concat(result1[2],result2[2])};
];

Rule("FSimpTerm",2,2,Type(f) = ":*:")
[
  FSimpFactor({Flatten(f,":*:")});
];
Rule("FSimpTerm",2,3,Type(f) = "FSin")
[
  {rlist[1],f:(rlist[2])};
];
Rule("FSimpTerm",2,3,Type(f) = "FCos")
[
  {f:(rlist[1]),rlist[2]};
];

Rule("FSimpTerm",2,4,True)
[
  {(FCos(f,0)):(rlist[1]),rlist[2]};
];

/* FSimpFactor does the difficult part. it gets a list, representing
   factors, a*b*c -> {{a,b,c}}, and has to add terms from it.
   Special cases to deal with:
   - (a+b)*c -> a*c+b*c -> {{a,c},{b,c}}
   - {a,b,c} where one of them is not a trig function or an addition:
     replace with FCos(b,0), which is b*Cos(0) = b
   - otherwise, combine two factors and make them into an addition.
   - the lists should get shorter, but the number of lists should
     get longer, until there are only single terms to be added.
 */
FSimpFactor(flist):=
[
  Local(rlist);
  rlist:={{},{}};
  /* Loop over each term */
  While(flist != {})
  [
    Local(term);
FLog("simpfact",flist);
    term:=First(flist);
    flist:=Rest(flist);
    FProcessTerm(term);
  ];
FLog("simpfact",flist);

FLog("rlist",rlist);
  rlist;
];
UnFence("FSimpFactor",1);


Rulebase("FProcessTerm",{t});
UnFence("FProcessTerm",1);

/* Deal with (a+b)*c -> a*c+b*c */
Rule("FProcessTerm",1,1,Type(t[1]) = "+")
[
  Local(split,term1,term2);
  split:=t[1];
  term1:=FlatCopy(t);
  term2:=FlatCopy(t);
  term1[1]:=split[1];
  term2[1]:=split[2];
  DestructiveInsert(flist,1,term1);
  DestructiveInsert(flist,1,term2);
];
Rule("FProcessTerm",1,1,Type(t[1]) = "-" And ArgumentsCount(t[1]) = 2)
[
  Local(split,term1,term2);
  split:=t[1];
  term1:=FlatCopy(t);
  term2:=FlatCopy(t);
  term1[1]:=split[1];
  term2[1]:=split[2];
  DestructiveInsert(term2,1,FCos(-1,0));
  DestructiveInsert(flist,1,term1);
  DestructiveInsert(flist,1,term2);
];

Rule("FProcessTerm",1,1,Length(t)>1 And Type(t[2]) = "-" And ArgumentsCount(t[2]) = 2)
[
  Local(split,term1,term2);
  split:=t[2];
  term1:=FlatCopy(t);
  term2:=FlatCopy(t);
  term1[2]:=split[1];
  term2[2]:=split[2];
  DestructiveInsert(term2,1,FCos(-1,0));
  DestructiveInsert(flist,1,term1);
  DestructiveInsert(flist,1,term2);
];

Rule("FProcessTerm",1,1,Type(t[1]) = ":*:")
[
  Local(split,term);
  split:=t[1];
  term:=FlatCopy(t);
  term[1]:=split[1];
  DestructiveInsert(term,1,split[2]);
  DestructiveInsert(flist,1,term);
];

Rule("FProcessTerm",1,1,Length(t)>1 And Type(t[2]) = ":*:")
[
  Local(split,term);
  split:=t[2];
  term:=FlatCopy(t);
  term[2]:=split[1];
  DestructiveInsert(term,1,split[2]);
  DestructiveInsert(flist,1,term);
];

Rule("FProcessTerm",1,1,Type(t[1]) = "-" And ArgumentsCount(t[1]) = 1)
[
  Local(split,term);
  split:=t[1];
  term:=FlatCopy(t);
  term[1]:=split[1];
  DestructiveInsert(term,1,FCos(-1,0));
  DestructiveInsert(flist,1,term);
];
Rule("FProcessTerm",1,1,Length(t)>1 And Type(t[2]) = "-" And ArgumentsCount(t[2]) = 1)
[
  Local(split,term);
  split:=t[2];
  term:=FlatCopy(t);
  term[2]:=split[1];
  DestructiveInsert(term,1,FCos(-1,0));
  DestructiveInsert(flist,1,term);
];


/* Deal with (a*(b+c) -> a*b+a*c */
Rule("FProcessTerm",1,1,Length(t)>1 And Type(t[2]) = "+")
[
  Local(split,term1,term2);
  split:=t[2];
  term1:=FlatCopy(t);
  term2:=FlatCopy(t);
  term1[2]:=split[1];
  term2[2]:=split[2];
  DestructiveInsert(flist,1,term1);
  DestructiveInsert(flist,1,term2);
];



/* Deal with a*FCos(1,b) ->FCos(a,0)*FCos(1,b) */
Rule("FProcessTerm",1,2,Not(IsFTrig(t[1])) )
[
  t[1]:=FCos(t[1],0);
  DestructiveInsert(flist,1,t);
];
Rule("FProcessTerm",1,2,Length(t)>1 And Not(IsFTrig(t[2])) )
[
  t[2]:=FCos(t[2],0);
  DestructiveInsert(flist,1,t);
];


Rule("FProcessTerm",1,4,Length(t)=1 And Type(t[1]) = "FCos")
[
  DestructiveInsert(rlist[1],1,t[1]);
];
Rule("FProcessTerm",1,4,Length(t)=1 And Type(t[1]) = "FSin")
[
  DestructiveInsert(rlist[2],1,t[1]);
];

/* Now deal with the real meat: FSin*FCos etc. Reduce the multiplication
   of the first two terms to an addition, adding two new terms to
   the pipe line.
 */
Rule("FProcessTerm",1,5,Length(t)>1)
[
  Local(x,y,term1,term2,news);
  x:=t[1];
  y:=t[2];
  news:=TrigSimpCombineB(x,y);
  /* Drop one term */
  t:=Rest(t);
  term1:=FlatCopy(t);
  term2:=FlatCopy(t);
  term1[1]:=news[1];
  term2[1]:=news[2];
  DestructiveInsert(flist,1,term1);
  DestructiveInsert(flist,1,term2);
];

/* TrigSimpCombineB : take two FSin/FCos factors, and write them out into two terms */
Rulebase("TrigSimpCombineB",{x,y});
Rule("TrigSimpCombineB",2,1,Type(x) = "FCos" And Type(y) = "FCos")
     { FCos((x[1]*y[1])/2,x[2]+y[2]) , FCos((x[1]*y[1])/2,x[2]-y[2]) };
Rule("TrigSimpCombineB",2,1,Type(x) = "FSin" And Type(y) = "FSin")
     { FCos(-(x[1]*y[1])/2,x[2]+y[2]) , FCos((x[1]*y[1])/2,x[2]-y[2]) };
Rule("TrigSimpCombineB",2,1,Type(x) = "FSin" And Type(y) = "FCos")
     { FSin((x[1]*y[1])/2,x[2]+y[2]) , FSin( (x[1]*y[1])/2,x[2]-y[2]) };
Rule("TrigSimpCombineB",2,1,Type(x) = "FCos" And Type(y) = "FSin")
     { FSin((x[1]*y[1])/2,x[2]+y[2]) , FSin(-(x[1]*y[1])/2,x[2]-y[2]) };


Rulebase("TrigSimpCombine",{f});
Rule("TrigSimpCombine",1,1,IsList(f))
  Map("TrigSimpCombine",{f});

Rule("TrigSimpCombine",1,10,True)
[
  Local(new,varlist);
  new:=f;

  /* varlist is used for normalizing the trig. arguments */
  varlist:=VarList(f);

/* Convert to internal format. */
  new:=FToInternal(new);
FLog("Internal",new);

  /* terms will contain FSin/FCos entries, the final result */

  /* rlist gathers the true final result */
  Local(terms);
  terms:=FSimpTerm(new,{{},{}});
  /* terms now contains two lists: terms[1] is the list of cosines,
     and terms[2] the list of sines.
   */
FLog("terms",terms);

  /* cassoc and sassoc will contain the assoc lists with the cos/sin
     arguments as key.
   */
  Local(cassoc,sassoc);
  cassoc:={};
  sassoc:={};
  ForEach(item,terms[1])
  [
    CosAdd(item);
  ];
  ForEach(item,terms[2])
  [
    SinAdd(item);
  ];
FLog("cassoc",cassoc);
FLog("sassoc",sassoc);

  /* Now rebuild the normal form */
  Local(result);
  result:=0;

//Echo({cassoc});
//Echo({sassoc});
  ForEach(item,cassoc)
  [
Log("item",item);
    result:=result+Expand(FUnTrig(FFromInternal(item[2])))*Cos(item[1]);
  ];
  ForEach(item,sassoc)
  [
Log("item",item);
    result:=result+Expand(FUnTrig(FFromInternal(item[2])))*Sin(item[1]);
  ];

  result;
];



CosAdd(t):=
[
  Local(look,arg);
  arg:=Expand(t[2],varlist);
  look:=Assoc(arg,cassoc);
  If(look = Empty,
     [
       arg:=Expand(-arg,varlist);
       look:=Assoc(arg,cassoc);
       If(look = Empty,
         DestructiveInsert(cassoc,1,{arg,t[1]}),
         look[2]:=look[2]+t[1]
         );
     ]
     ,
     look[2]:=look[2]+t[1]
    );
];
UnFence("CosAdd",1);

SinAdd(t):=
[
  Local(look,arg);
  arg:=Expand(t[2],varlist);
  look:=Assoc(arg,sassoc);
  If(look = Empty,
     [
       arg:=Expand(-arg,varlist);
       look:=Assoc(arg,sassoc);
       If(look = Empty,
         DestructiveInsert(sassoc,1,{arg,-(t[1])}),
	 look[2]:=look[2]-(t[1])
         );
     ]
     ,
     look[2]:=look[2]+t[1]
    );
];
UnFence("SinAdd",1);


/*
In( 4 ) = Exp(I*a)*Exp(I*a)
Out( 4 ) = Complex(Cos(a)^2-Sin(a)^2,Cos(a)*Sin(a)+Sin(a)*Cos(a));
In( 5 ) = Exp(I*a)*Exp(-I*a)
Out( 5 ) = Complex(Cos(a)^2+Sin(a)^2,Sin(a)*Cos(a)-Cos(a)*Sin(a));

In( 5 ) = Exp(I*a)*Exp(I*b)
Out( 5 ) = Complex(Cos(a)*Cos(b)-Sin(a)*Sin(b),Cos(a)*Sin(b)+Sin(a)*Cos(b));
In( 6 ) = Exp(I*a)*Exp(-I*b)
Out( 6 ) = Complex(Cos(a)*Cos(b)+Sin(a)*Sin(b),Sin(a)*Cos(b)-Cos(a)*Sin(b));


*/



%/mathpiper



%mathpiper_docs,name="TrigSimpCombine",categories="User Functions;Expression Simplification"
*CMD TrigSimpCombine --- combine products of trigonometric functions
*STD
*CALL
	TrigSimpCombine(expr)

*PARMS

{expr} -- expression to simplify

*DESC

This function applies the product rules of trigonometry, e.g.
$Cos(u)*Sin(v) = (1/2)*(Sin(v-u) + Sin(v+u))$. As a
result, all products of the trigonometric functions {Cos} and {Sin} disappear. The function also tries to simplify the resulting expression as much as
possible by combining all similar terms.

This function is used in for instance {Integrate},
to bring down the expression into a simpler form that hopefully can be
integrated easily.

*E.G.

In> PrettyPrinterSet("PrettyForm");
	
	True
	
In> TrigSimpCombine(Cos(a)^2+Sin(a)^2)
	
	1
	
In> TrigSimpCombine(Cos(a)^2-Sin(a)^2)
	
	Cos( -2 * a )
	
Result:
In> TrigSimpCombine(Cos(a)^2*Sin(b))
	
	Sin( b )   Sin( -2 * a + b ) 
	-------- + ----------------- 
	   2               4         
	
	    Sin( -2 * a - b )
	  - -----------------
	            4

*SEE Simplify, Integrate, Expand, Sin, Cos, Tan
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/orthopoly/0000755000175000017500000000000011722677335025340 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/orthopoly/orthopoly.mpw0000644000175000017500000010061611523200452030105 0ustar  giovannigiovanni%mathpiper,def="OrthoP;OrthoG;OrthoH;OrthoL;OrthoT;OrthoU;OrthoPSum;OrthoGSum;OrthoHSum;OrthoLSum;OrthoTSum;OrthoUSum;EvaluateHornerScheme"

/* def file definitions
OrthoP
OrthoG
OrthoH
OrthoL
OrthoT
OrthoU
OrthoPSum
OrthoGSum
OrthoHSum
OrthoLSum
OrthoTSum
OrthoUSum
EvaluateHornerScheme
*/

/*
Orthogonal polynomials
version 1.2
(Serge Winitzki)

Polynomials are found from direct recurrence relations. Sums of series of polynomials are found using the Clenshaw-Smith recurrence scheme.

Reference: Yudell L. Luke. Mathematical functions and their approximations. Academic Press, N. Y., 1975.

Usage:
  The polynomials are evaluated by functions named Ortho*, where * is one of P, G, H, L, T, U. The first argument of these functions is an integer.  The series of polynomials are evaluated by functions named Ortho*Sum. The first argument of these functions is a list of coefficients. The last argument is the value x at which the polynomials are to be computed; if x is numerical, a faster routine is used.

  If n is an integer, n>=0, then:
	OrthoP(n, x) gives the n-th Legendre polynomial, evaluated on x
	OrthoP(n, a, b, x) gives the n-th Jacobi polynomial with parameters a, b, evaluated on x
	OrthoG(n, a, x) gives the n-th Gegenbauer polynomial
	OrthoH(n, x) gives the n-th Hermite polynomial
	OrthoL(n, a, x) gives the n-th Laguerre polynomial
	OrthoT(n, x) gives the n-th Tschebyscheff polynomial of the 1st kind
	OrthoU(n, x) gives the n-th Tschebyscheff polynomial of the 2nd kind

  If c is a list of coefficients c[1], c[2], ..., c[N], then Ortho*Sum(c, ...) where * is one of P, G, H, L, T, U, computes the sum of a series c[1]*P_0+c[2]*P_1+...+c[N]*P_N, where P_k is the relevant polynomial of k-th order. (For polynomials taking parameters: the parameters must remain constant throughout the summation.) Note that the intermediate polynomials are not evaluated and the recurrence relations are different for this computation, so there may be a numerical difference between Ortho*(c, ...) and computing the sum of the series directly.

  Internal functions that may be useful:
	OrthoPolyCoeffs(name_IsString, n_IsInteger, parameters_IsList) returns a list of coefficients of the polynomial. Here "name" must be one of the predefined names: "Jacobi", "Gegenbauer", "Hermite", "Laguerre", "Tscheb1",  "Tscheb2"; and "parameters" is a list of extra parameters for the given family of polynomials, e.g. {a,b} for the Jacobi, {a} for Laguerre and {} for Hermite polynomials.
	OrthoPolySumCoeffs(name_IsString, c_IsList, parameters_IsList) returns a list of coefficients of the polynomial which is a sum of series with coefficients c.
	EvaluateHornerScheme(coefficients, x) returns the Horner-evaluated polynomial on x. The "coefficients" is a list that starts at the lowest power. For example, EvaluateHornerScheme({a,b,c}, x) should return (a+x*(b+x*c))
*/

10 # EvaluateHornerScheme({}, _x) <-- 0;
/* Strictly speaking, the following rule is not needed, but it doesn't hurt */
10 # EvaluateHornerScheme({_coeffs}, _x) <-- coeffs;
20 # EvaluateHornerScheme(coeffs_IsList, _x) <-- First(coeffs)+x*EvaluateHornerScheme(Rest(coeffs), x);

/* Plain polynomials */
// some are computed by general routines, and some are replaced by more efficient routines below
OrthoP(n_IsInteger, _x)_(n>=0) <-- OrthoP(n, 0, 0, x);
OrthoP(n_IsInteger, a_IsRationalOrNumber, b_IsRationalOrNumber, _x)_(n>=0 And a> -1 And b> -1) <-- OrthoPoly("Jacobi", n, {a, b}, x);

OrthoG(n_IsInteger, a_IsRationalOrNumber, _x)_(n>=0 And a> -1/2) <-- OrthoPoly("Gegenbauer", n, {a}, x);

OrthoH(n_IsInteger, _x)_(n>=0) <-- OrthoPoly("Hermite", n, {}, x);

OrthoL(n_IsInteger, a_IsRationalOrNumber, _x)_(n>=0 And a> -1) <-- OrthoPoly("Laguerre", n, {a}, x);

OrthoT(n_IsInteger, _x)_(n>=0) <-- OrthoPoly("Tscheb1", n, {}, x);
OrthoU(n_IsInteger, _x)_(n>=0) <-- OrthoPoly("Tscheb2", n, {}, x);

/* Sums of series of orthogonal polynomials */

OrthoPSum(c_IsList, _x) <-- OrthoP(c, 0, 0, x);
OrthoPSum(c_IsList, a_IsRationalOrNumber, b_IsRationalOrNumber, _x)_(a> -1 And b> -1) <-- OrthoPolySum("Jacobi", c, {a, b}, x);

OrthoGSum(c_IsList, a_IsRationalOrNumber, _x)_(a> -1/2) <-- OrthoPolySum("Gegenbauer", c, {a}, x);

OrthoHSum(c_IsList, _x) <-- OrthoPolySum("Hermite", c, {}, x);

OrthoLSum(c_IsList, a_IsRationalOrNumber, _x)_(a> -1) <-- OrthoPolySum("Laguerre", c, {a}, x);

OrthoTSum(c_IsList, _x) <-- OrthoPolySum("Tscheb1", c, {}, x);
OrthoUSum(c_IsList, _x) <-- OrthoPolySum("Tscheb2", c, {}, x);

/*
Orthogonal polynomials are evaluated using a general routine OrthoPolyCoeffs that generates their coefficients recursively.

The recurrence relations start with n=0 and n=1 (the n=0 polynomial is always identically 1) and continue for n>=2. Note that the n=1 polynomial is not always given by the n=1 recurrence formula if we assume P_{-1}=0, so the recurrence should be considered undefined at n=1.

	For Legendre/Jacobi polynomials: (a>-1, b>-1)
P(0,a,b,x):=1
P(1,a,b,x):=(a-b)/2+x*(1+(a+b)/2)
P(n,a,b,x):=(2*n+a+b-1)*(a^2-b^2+x*(2*n+a+b-2)*(2*n+a+b))/(2*n*(n+a+b)*(2*n+a+b-2))*P(n-1,a,b,x)-(n+a-1)*(n+b-1)*(2*n+a+b)/(n*(n+a+b)*(2*n+a+b-2))*P(n-2,a,b,x)

	For Hermite polynomials:
H(0,x):=1
H(1,x):=2*x
H(n,x):=2*x*H(n-1,x)-2*(n-1)*H(n-2,x)

	For Gegenbauer polynomials: (a>-1/2)
G(0,a,x):=1
G(1,a,x):=2*a*x
G(n,a,x):=2*(1+(a-1)/n)*x*G(n-1,a,x)-(1+2*(a-2)/n)*G(n-2,a,x)

	For Laguerre polynomials: (a>-1)
L(0,a,x):=1
L(1,a,x):=a+1-x
L(n,a,x):=(2+(a-1-x)/n)*L(n-1,a,x)-(1+(a-1)/n)*L(n-2,a,x)

	For Tschebycheff polynomials of the first kind:
T(0,x):=1
T(1,x):=x
T(n,x):=2*x*T(n-1,x)-T(n-2,x)

	For Tschebycheff polynomials of the second kind:
U(0,x):=1
U(1,x):=2*x
U(n,x):=2*x*U(n-1,x)-U(n-2,x)

The database "KnownOrthoPoly" contains closures that return coefficients for the recurrence relations of each family of polynomials. KnownOrthoPoly["name"] is a closure that takes two arguments: the order (n) and the extra parameters (p), and returns a list of two lists: the first list contains the coefficients {A,B} of the n=1 polynomial, i.e. "A+B*x"; the second list contains the coefficients {A,B,C} in the recurrence relation, i.e. "P_n = (A+B*x)*P_{n-1}+C*P_{n-2}". (So far there are only 3 coefficients in the second list, i.e. no "C+D*x", but we don't want to be limited.)

*/

LocalSymbols(knownOrthoPoly) [
  knownOrthoPoly := Hold({
    {"Jacobi", {{n, p}, {{(p[1]-p[2])/2, 1+(p[1]+p[2])/2}, {(2*n+p[1]+p[2]-1)*((p[1])^2-(p[2])^2)/(2*n*(n+p[1]+p[2])*(2*n+p[1]+p[2]-2)), (2*n+p[1]+p[2]-1)*(2*n+p[1]+p[2])/(2*n*(n+p[1]+p[2])), -(n+p[1]-1)*(n+p[2]-1)*(2*n+p[1]+p[2])/(n*(n+p[1]+p[2])*(2*n+p[1]+p[2]-2))}}}},
    {"Gegenbauer", {{n, p}, {{0, 2*p[1]}, {0, 2+2*(p[1]-1)/n, -1-2*(p[1]-1)/n}}}},
    {"Laguerre", {{n, p}, {{p[1]+1, -1}, {2+(p[1]-1)/n, -1/n, -1-(p[1]-1)/n}}}},
    {"Hermite", {{n, p}, {{0,2}, {0, 2, -2*(n-1)}}}},
    {"Tscheb1", {{n, p}, {{0,1}, {0,2,-1}}}},
    {"Tscheb2", {{n, p}, {{0,2}, {0,2,-1}}}}
  });
  KnownOrthoPoly() := knownOrthoPoly;

]; // LocalSymbols(knownOrthoPoly)

/*
For efficiency, polynomials are represented by lists of coefficients rather than by MathPiper expressions. Polynomials are evaluated using the explicit Horner scheme. On numerical arguments, the polynomial coefficients are not computed, only the resulting value.
*/

/*
Sums of series of orthogonal polynomials are found using the Clenshaw-Smith recurrence scheme:
	If $P_n$ satisfy $P_n = A_n p_{n-1} + B_n p_{n-2}$, $n>=2$, and if $A_1$ is defined so that $P_1 = A_1 P_0$, then $\sum _{n=0}^N c_n P_n = X_0 P_0$, where $X_n$ are found from the following backward recurrence: $X_{N+1} = X_{N+2} = 0$, $X_n = c_n + A_{n+1} X_{n+1} + B_{n+2} X_{n+2}$, $n=N, N-1, ..., 0$.
*/

/* Numeric arguments are processed by a faster routine */

10 # OrthoPoly(name_IsString, _n, p_IsList, x_IsRationalOrNumber) _ (KnownOrthoPoly()[name] != Empty) <-- OrthoPolyNumeric(name, n, p, x);
20 # OrthoPoly(name_IsString, _n, p_IsList, _x) _ (KnownOrthoPoly()[name] != Empty) <-- EvaluateHornerScheme(OrthoPolyCoeffs(name, n, p), x);

10 # OrthoPolySum(name_IsString, c_IsList, p_IsList, x_IsRationalOrNumber) _ (KnownOrthoPoly()[name] != Empty) <-- OrthoPolySumNumeric(name, c, p, x);
20 # OrthoPolySum(name_IsString, c_IsList, p_IsList, _x) _ (KnownOrthoPoly()[name] != Empty) <-- EvaluateHornerScheme(OrthoPolySumCoeffs(name, c, p), x);

/*
OrthoPolyNumeric computes the value of the polynomial from recurrence relations directly. Do not use with non-numeric arguments, except for testing!
*/
OrthoPolyNumeric(name_IsString, n_IsInteger, p_IsList, _x) <-- [
	Local(value1, value2, value3, ruleCoeffs, index);
	value1 := 1;
	ruleCoeffs := Apply(KnownOrthoPoly()[name], {n, p})[1];
	value2 := ruleCoeffs[1] + x*ruleCoeffs[2];
	index := 1;
	/* value1, value2, value3 is the same as P_{n-2}, P_{n-1}, P_n where n = index */
	While(index=1) [
		ruleCoeffs := Apply(KnownOrthoPoly()[name], {index+1, p})[2];
		ruleCoeffs1 := Apply(KnownOrthoPoly()[name], {index+2, p})[2];
		value3 := (ruleCoeffs[1] + x*ruleCoeffs[2])*value2 + ruleCoeffs1[3]*value1 + c[index+1];
		value1 := value2;
		value2 := value3;
		index := index - 1;
	];
	/* Last iteration by hand: works correctly also if c has only 1 element */
	ruleCoeffs := Apply(KnownOrthoPoly()[name], {1, p})[1];
	ruleCoeffs1 := Apply(KnownOrthoPoly()[name], {2, p})[2];
	value2 := (ruleCoeffs[1] + x*ruleCoeffs[2])*value2 + ruleCoeffs1[3]*value1 + c[1];
	value2;
];

/*
OrthoPolyCoeffs(name, n, p) returns the list of coefficients for orthogonal polynomials, starting with the lowest powers.
*/

10 # OrthoPolyCoeffs(name_IsString, 0, p_IsList) <-- {1};
10 # OrthoPolyCoeffs(name_IsString, 1, p_IsList) <-- Apply(KnownOrthoPoly()[name], {1, p})[1];

/* Simple implementation, very slow, for testing only: recursive rule matches, no loops
20 # OrthoPolyCoeffs(name_IsString, n_IsInteger, p_IsList)_(n>1) <-- [
	Local(ruleCoeffs, newCoeffs);
	ruleCoeffs := Apply(KnownOrthoPoly()[name], {n, p})[2];
	newCoeffs := OrthoPolyCoeffs(name, n-1, p);
	Concat(newCoeffs,{0})*ruleCoeffs[1] + Concat(OrthoPolyCoeffs(name, n-2, p),{0,0})*ruleCoeffs[3] + Concat({0}, newCoeffs)*ruleCoeffs[2];
];
*/

/* A fast implementation that works directly with lists and saves memory. Same recurrence as in OrthoPolyNumeric() */
/* note: here we pass "name" instead of "KnownOrthoPoly()[name]" for efficiency, but strictly speaking we don't need to use this global constant */

20 # OrthoPolyCoeffs(name_IsString, n_IsInteger, p_IsList)_(n>1) <-- [
	Local(ruleCoeffs, tmpCoeffs, newCoeffs, prevCoeffs, index, jndex, tmptmpCoeffs, prevCoeffsA, newCoeffsA, tmpCoeffsA);
	/* For speed, allocate all lists now. Length is n+1 */
	prevCoeffsA := ZeroVector(n+1);
	newCoeffsA := ZeroVector(n+1);
	tmpCoeffsA := ZeroVector(n+1);
	/* pointers to arrays */
	prevCoeffs := prevCoeffsA;
	newCoeffs := newCoeffsA;
	tmpCoeffs := tmpCoeffsA;
	/* Initialize: n=0 and n=1 */
	prevCoeffs[1] := 1;
	ruleCoeffs := Apply(KnownOrthoPoly()[name], {n, p})[1];
	newCoeffs[1] := ruleCoeffs[1];
	newCoeffs[2] := ruleCoeffs[2];
	/* Invariant: answer ready in "newCoeffs" at value of index */
	index := 1;
	/* main loop */
	While(index < n) [
		index := index + 1;
		/* Echo({"index ", index}); */ /* in case this is slow */
		ruleCoeffs := Apply(KnownOrthoPoly()[name], {index, p})[2];
		tmpCoeffs[1] := ruleCoeffs[1]*newCoeffs[1] + ruleCoeffs[3]*prevCoeffs[1];
		/* The polynomial tmpCoeffs must have (index+1) coefficients now */
		For(jndex:=2, jndex <= index, jndex:=jndex+1) [
			tmpCoeffs[jndex] := ruleCoeffs[1]*newCoeffs[jndex] + ruleCoeffs[3]*prevCoeffs[jndex] + ruleCoeffs[2]*newCoeffs[jndex-1];
		];
		tmpCoeffs[index+1] := ruleCoeffs[2]*newCoeffs[index];
/*
		prevCoeffs := FlatCopy(newCoeffs);
		newCoeffs := FlatCopy(tmpCoeffs);
*/
/* juggle pointers instead of copying lists */
		tmptmpCoeffs := prevCoeffs;
		prevCoeffs := newCoeffs;
		newCoeffs := tmpCoeffs;
		tmpCoeffs := tmptmpCoeffs;
	];
	newCoeffs;
];

/*
OrthoPolySumCoeffs(name, c, p) returns the list of coefficients for the sum of a series of orthogonal polynomials. Same recurrence as in OrthoPolySumNumeric()
*/

OrthoPolySumCoeffs(name_IsString, c_IsList, p_IsList) <-- [
	Local(n, ruleCoeffs, ruleCoeffs1, tmpCoeffs, newCoeffs, prevCoeffs, index, jndex, tmptmpCoeffs, prevCoeffsA, newCoeffsA, tmpCoeffsA);
	/* n is the max polynomial order we need */
	n := Length(c) - 1;
	/* For speed, allocate all lists now. Length is n+1 */
	prevCoeffsA := ZeroVector(n+1);
	newCoeffsA := ZeroVector(n+1);
	tmpCoeffsA := ZeroVector(n+1);
	/* pointers to arrays */
	prevCoeffs := prevCoeffsA;
	newCoeffs := newCoeffsA;
	tmpCoeffs := tmpCoeffsA;
	/* Invariant: answer ready in "newCoeffs" at value of index */
	/* main loop */
	For(index:=n, index >= 1, index:=index-1) [
		/* Echo({"index ", index}); */ /* in case this is slow */
		ruleCoeffs := Apply(KnownOrthoPoly()[name], {index+1, p})[2];
		ruleCoeffs1 := Apply(KnownOrthoPoly()[name], {index+2, p})[2];
		tmpCoeffs[1] := c[index+1] + ruleCoeffs[1]*newCoeffs[1] + ruleCoeffs1[3]*prevCoeffs[1];
		/* The polynomial tmpCoeffs must have (n-index+1) coefficients now */
		For(jndex:=2, jndex <= n-index, jndex:=jndex+1) [
			tmpCoeffs[jndex] := ruleCoeffs[1]*newCoeffs[jndex] + ruleCoeffs1[3]*prevCoeffs[jndex] + ruleCoeffs[2]*newCoeffs[jndex-1];
		];
		If(n-index>0, tmpCoeffs[n-index+1] := ruleCoeffs[2]*newCoeffs[n-index]);
/*
		prevCoeffs := FlatCopy(newCoeffs);
		newCoeffs := FlatCopy(tmpCoeffs);
*/
/* juggle pointers instead of copying lists */
		tmptmpCoeffs := prevCoeffs;
		prevCoeffs := newCoeffs;
		newCoeffs := tmpCoeffs;
		tmpCoeffs := tmptmpCoeffs;
	];
	/* Last iteration by hand: works correctly also if c has only 1 element */
	index:=0;
	ruleCoeffs := Apply(KnownOrthoPoly()[name], {index+1, p})[1];
	ruleCoeffs1 := Apply(KnownOrthoPoly()[name], {index+2, p})[2];
	tmpCoeffs[1] := c[index+1] + ruleCoeffs[1]*newCoeffs[1] + ruleCoeffs1[3]*prevCoeffs[1];
	/* The polynomial tmpCoeffs must have (n-index+1) coefficients now */
	For(jndex:=2, jndex <= n-index, jndex:=jndex+1) [
		tmpCoeffs[jndex] := ruleCoeffs[1]*newCoeffs[jndex] + ruleCoeffs1[3]*prevCoeffs[jndex] + ruleCoeffs[2]*newCoeffs[jndex-1];
	];
	tmpCoeffs[n-index+1] := ruleCoeffs[2]*newCoeffs[n-index];
	tmpCoeffs;
];

//////////////////////////////////////////////////
/// Very fast computation of Chebyshev polynomials
//////////////////////////////////////////////////
/// (This is not used now because of numerical instability, until I figure out how much to increase the working precision to get P correct digits.)
/// See: W. Koepf. Efficient computation of Chebyshev polynomials in computer algebra (unpublished preprint). Contrary to Koepf's claim (unsupported by any calculation in his paper) that the method is numerically stable, I found unsatisfactory numerical behavior for very large orders.
/// Koepf suggests to use M. Bronstein's algorithm for finding rational solutions of linear ODEs for all other orthogonal polynomials (may be faster than recursion if we want to find the analytic form of the polynomial, but still slower if an explicit formula is available).
//////////////////////////////////////////////////
/// Main formulae: T(2*n,x) = 2*T(n,x)^2-1; T(2*n+1,x) = 2*T(n+1,x)*T(n,x)-x;
/// U(2*n,x) = 2*T(n,x)*U(n,x)-1; T(2*n+1,x) = 2*T(n+1,x)*U(n,x);
/// We avoid recursive calls and build the sequence of bits of n to determine the minimal sequence of n[i] for which T(n[i], x) and U(n[i], x) need to be computed
//////////////////////////////////////////////////
/*
/// This function will return the list of binary bits, e.g. BitList(10) returns {1,0,1,0}.
BitList(n) := BitList(n, {});
/// This will not be called on very large numbers so it's okay to use recursion
1# BitList(0, _bits) <-- bits;
2# BitList(_n, _bits) <-- BitList(Quotient(n,2), Push(bits, Modulo(n,2)));

// Tchebyshev polynomials of 1st kind
1 # FastOrthoT(0, _x) <-- 1;
1 # FastOrthoT(1, _x) <-- x;
// Tchebyshev polynomials of 2nd kind
1 # FastOrthoU(0, _x) <-- 1;
1 # FastOrthoU(1, _x) <-- 2*x;

// guard against user errors
2 # FastOrthoT(_n, _x) _ (IsInteger(n) And n<0) <-- Undefined;
2 # FastOrthoU(_n, _x) _ (IsInteger(n) And n<0) <-- Undefined;

// make T(), U() of even order more efficient: delegate gruntwork to odd order
2 # FastOrthoT(n_IsEven, _x) <-- 2*FastOrthoT(Quotient(n,2), x)^2-1;
2 # FastOrthoU(n_IsEven, _x) <-- 2*FastOrthoT(Quotient(n,2), x)*FastOrthoU(Quotient(n,2), x)-1;

// FastOrthoT() of odd order
3 # FastOrthoT(n_IsOdd, _x) <--
[
	Local(T1, T2, i);
	// first bit in the list is always 1, so initialize the pair
	T1 := FastOrthoT(1, x);
	T2 := FastOrthoT(2, x);
	ForEach(i, Rest(BitList(n)))	// skip first bit
	[
		// if the current bit is 1, we need to double the second index, else double the first index.
		// Invariant: n[i+1] = 2*n[i] + BitList[i] and we need to have FastOrthoT(n[i]), FastOrthoT(1+n[i]) as T1, T2. Initially n[1]=1 and after the cycle n[i]=n.
		{T1, T2} := If
		(
			i=1,
			{2*T1*T2-x, 2*T2^2-1},
			{2*T1^2-1, 2*T1*T2-x}
		);
	];
	T1;
];

// FastOrthoU() of any order
3 # FastOrthoU(_n, _x) <--
[
	Local(U1, T1, T2, i);
	// first bit in the list is always 1, so initialize the pair
	U1 := FastOrthoU(1, x);
	T1 := FastOrthoT(1, x);
	T2 := FastOrthoT(2, x);
	ForEach(i, Rest(BitList(n)))	// skip first bit
	[
		// if the current bit is 1, we need to double the second index, else double the first index
		// Invariant: n[i+1] = 2*n[i] + BitList[i] and we need to have U(n[i]), T(n[i]), T(1+n[i]) as U1, T1, T2. Initially n[1]=1 and after the cycle n[i]=n.
		{U1, T1, T2} := If
		(
			i=1,
			{2*U1*T2, 2*T1*T2-x, 2*T2^2-1},
			{2*U1*T1-1, 2*T1^2-1, 2*T1*T2-x}
		);
	];
	U1;
];
*/
//////////////////////////////////////////////////
/// Fast symbolic computation of some polynomials
//////////////////////////////////////////////////


//////////////////////////////////////////////////
/// Fast symbolic computation of Legendre polynomials
//////////////////////////////////////////////////

8# OrthoPolyCoeffs("Jacobi", n_IsInteger, {0,0}) <--
[
	Local(i, result);
	result := ZeroVector(n+1);
	result[n+1] := (2*n-1)!! /n!;	// coefficient at x^n
	i := 1;
	While(2*i<=n)
	[	// prepare coefficient at x^(n-2*i) now
		result[n+1-2*i] := -(result[n+3-2*i]*(n-2*i+1)*(n-2*i+2)) / ((2*n-2*i+1)*2*i);
		i++;
	];
	result;
];

//////////////////////////////////////////////////
/// Fast symbolic computation of Hermite polynomials
//////////////////////////////////////////////////

OrthoPolyCoeffs("Hermite", n_IsInteger, {}) <-- HermiteCoeffs(n);

/// Return the list of coefficiets of Hermite polynomials.
HermiteCoeffs(n_IsEven)_(n>0) <--
[
	Local(i, k, result);
	k := Quotient(n,2);
	result := ZeroVector(n+1);
	result[1] := (-2)^k*(n-1)!!;	// coefficient at x^0
	For(i:=1,i<=k,i++)	// prepare coefficient at x^(2*i) now
		result[2*i+1] := Quotient(-2*result[2*i-1] * (k-i+1), (2*i-1)*i);	// this division is always integer but faster with Quotient()
	result;
];
HermiteCoeffs(n_IsOdd)_(n>0) <--
[
	Local(i, k, result);
	k := Quotient(n,2);
	result := ZeroVector(n+1);
	result[2] := 2*(-2)^k*(n!!);	// coefficient at x^1
	For(i:=1,i<=k,i++)	// prepare coefficient at x^(2*i+1) now
		result[2*i+2] := Quotient(-2*result[2*i] * (k-i+1), i*(2*i+1));	// this division is always integer but faster with Quotient()
	result;
];

//////////////////////////////////////////////////
/// Fast symbolic computation of Laguerre polynomials
//////////////////////////////////////////////////

/// Return the list of coefficients of Laguerre polynomials.
OrthoPolyCoeffs("Laguerre", n_IsInteger, {_k}) <--
[
	Local(i, result);
	result := ZeroVector(n+1);
	result[n+1] := (-1)^n/n!;	// coefficient at x^n
	For(i:=n,i>=1,i--)	// prepare coefficient at x^(i-1) now
		result[i] := -(result[i+1]*i*(k+i))/(n-i+1);
	result;
];


//////////////////////////////////////////////////
/// Fast symbolic computation of Chebyshev polynomials
//////////////////////////////////////////////////

OrthoPolyCoeffs("Tscheb1", n_IsInteger, {}) <-- ChebTCoeffs(n);
OrthoPolyCoeffs("Tscheb2", n_IsInteger, {}) <-- ChebUCoeffs(n);

1 # ChebTCoeffs(0) <-- {1};
2 # ChebTCoeffs(n_IsInteger) <--
[
	Local(i, result);
	result := ZeroVector(n+1);
	result[n+1] := 2^(n-1);	// coefficient at x^n
	i := 1;
	While(2*i<=n)
	[	// prepare coefficient at x^(n-2*i) now
		result[n+1-2*i] := -(result[n+3-2*i]*(n-2*i+2)*(n-2*i+1)) / ((n-i)*4*i);
		i++;
	];
	result;
];

1 # ChebUCoeffs(0) <-- {1};
2 # ChebUCoeffs(n_IsInteger) <--
[
	Local(i, result);
	result := ZeroVector(n+1);
	result[n+1] := 2^n;	// coefficient at x^n
	i := 1;
	While(2*i<=n)
	[	// prepare coefficient at x^(n-2*i) now
		result[n+1-2*i] := -(result[n+3-2*i]*(n-2*i+2)*(n-2*i+1)) / ((n-i+1)*4*i);
		i++;
	];
	result;
];


%/mathpiper



%mathpiper_docs,name="EvaluateHornerScheme",categories="User Functions;Polynomials (Operations)"
*CMD EvaluateHornerScheme --- fast evaluation of polynomials
*STD
*CALL
	EvaluateHornerScheme(coeffs,x)

*PARMS

{coeffs} -- a list of coefficients

{x} -- expression

*DESC

This function evaluates a polynomial given as a list of its coefficients, using
the Horner scheme. The list of coefficients starts with the $0$-th power.

*E.G.

In> EvaluateHornerScheme({a,b,c,d},x)
Result: a+x*(b+x*(c+x*d));

*SEE Horner
%/mathpiper_docs



%mathpiper_docs,name="OrthoP",categories="User Functions;Polynomials (Special)"
*CMD OrthoP --- Legendre and Jacobi orthogonal polynomials
*STD
*CALL
	OrthoP(n, x);
	OrthoP(n, a, b, x);

*PARMS

{n} -- degree of polynomial

{x} -- point to evaluate polynomial at

{a}, {b} -- parameters for Jacobi polynomial

*DESC

The first calling format with two arguments evaluates the Legendre polynomial
of degree {n} at the point {x}. The second form does the same for the Jacobi
polynomial with parameters {a} and {b}, which should be both greater than -1.

The Jacobi polynomials are orthogonal with respect to the weight
function $(1-x)^a *(1+x)^b$ on the interval [-1,1]. They satisfy the
recurrence relation
$$P(n,a,b,x) = (2*n+a+b-1)/(2*n+a+b-2) $$*
$$ ((a^2-b^2+x*(2*n+a+b-2)*(n+a+b))/(2*n*(n+a+b))) * P(n-1,a,b,x)$$
$$ - ((n+a-1)*(n+b-1)*(2*n+a+b))/(n*(n+a+b)*(2*n+a+b-2))*P(n-2,a,b,x)$$
for $n > 1$, with
$P(0,a,b,x) = 1$,
$$P(1,a,b,x) = (a-b)/2+x*(1+(a+b)/2)$$.

*REM (old versions of the equations:)
//	P(0,a,b,x) = 1,
//	
//	             a - b     /     a + b \
//	P(1,a,b,x) = ----- + x | 1 + ----- | ,
//	               2       \       2   /
//	
//	
//	
//	P(n,a,b,x) = (2n + a + b - 1) *
//	
//	
//	    2   2
//	   a - b + x (2n+a+b-2) (n+a+b)
//	   ---------------------------- P(n-1,a,b,x)
//	      2n (2n+a+b-2) (n+a+b)
//	
//	    (n+a-1) (n+b-1) (2n+a+b)
//	 -  ------------------------ P(n-2,a,b,x)
//	      n (n+a+b) (2n+a+b-2)

Legendre polynomials are a special case of Jacobi polynomials with the
specific parameter values $a = b = 0$. So they form an orthogonal system
with respect to the weight function identically equal to 1 on the
interval [-1,1], and they satisfy the recurrence relation
$$ P(n,x)=((2*n-1)*x/(2*n))*P(n-1,x)-(n-1)/n*P(n-2,x) $$
for $n > 1$, with
$ P(0,x)=1 $,
$ P(1,x)=x $.

*REM
//	P(0,x) = 1
//	
//	P(1,x) = x
//	
//	         (2n - 1) x            n - 1
//	P(n,x) = ---------- P(n-1,x) - ----- P(n-2,x),
//	             2n                  n

Most of the work is performed by the internal function {OrthoPoly}.

*E.G.

In> PrettyPrinterSet("PrettyForm");
	
	True
	
In> OrthoP(3, x);
	
	    /      2     \
	    | 5 * x    3 |
	x * | ------ - - |
	    \   2      2 /
	
In> OrthoP(3, 1, 2, x);
	
	1       /     / 21 * x   7 \   7 \
	- + x * | x * | ------ - - | - - |
	2       \     \   2      2 /   2 /
	
In> Expand(%)
	
	      3        2
	21 * x  - 7 * x  - 7 * x + 1
	----------------------------
	             2
	
In> OrthoP(3, 1, 2, 0.5);
	
	-0.8124999999
	

*SEE OrthoPSum, OrthoG, OrthoPoly
%/mathpiper_docs



%mathpiper_docs,name="OrthoH",categories="User Functions;Polynomials (Special)"
*CMD OrthoH --- Hermite orthogonal polynomials
*STD
*CALL
	OrthoH(n, x);

*PARMS

{n} -- degree of polynomial

{x} -- point to evaluate polynomial at

*DESC

This function evaluates the Hermite polynomial of degree {n} at the
point {x}.

The Hermite polynomials are orthogonal with respect to the weight
function $Exp(-x^2/2)$ on the entire real axis. They satisfy the
recurrence relation
$$ H(n,x) = 2*x*H(n-1,x) - 2*(n-1)*H(n-2,x) $$
for $n > 1$, with
$H(0,x) = 1$,
$H(1,x) = 2*x$.

Most of the work is performed by the internal function {OrthoPoly}.

*E.G.

In> OrthoH(3, x);
Result: x*(8*x^2-12);
In> OrthoH(6, 0.5);
Result: 31;

*SEE OrthoHSum, OrthoPoly
%/mathpiper_docs



%mathpiper_docs,name="OrthoG",categories="User Functions;Polynomials (Special)"
*CMD OrthoG --- Gegenbauer orthogonal polynomials
*STD
*CALL
	OrthoG(n, a, x);

*PARMS

{n} -- degree of polynomial

{a} -- parameter

{x} -- point to evaluate polynomial at

*DESC

This function evaluates the Gegenbauer (or ultraspherical) polynomial
with parameter {a} and degree {n} at the point {x}. The
parameter {a} should be greater than -1/2.

The Gegenbauer polynomials are orthogonal with respect to the weight
function $(1-x^2)^(a-1/2)$ on the interval [-1,1]. Hence they are
connected to the Jacobi polynomials via 
$$ G(n, a, x) = P(n, a-1/2, a-1/2, x) $$.
They satisfy the recurrence relation
$$ G(n,a,x) = 2*(1+(a-1)/n)*x*G(n-1,a,x) $$
$$ -(1+2*(a-2)/n)*G(n-2,a,x) $$
for $n>1$, with
$G(0,a,x) = 1$,
$G(1,a,x) = 2*x$.

*REM	
//	             /     a - 1 \              
//	G(n,a,x) = 2 | 1 + ----- | x G(n-1,a,x) 
//	             \       n   /              
//	
//	  /     2 (a-2) \
//	- | 1 + ------- | G(n-2,a,x),
//	  \        n    /

Most of the work is performed by the internal function {OrthoPoly}.

*E.G.

In> OrthoG(5, 1, x);
Result: x*((32*x^2-32)*x^2+6);
In> OrthoG(5, 2, -0.5);
Result: 2;

*SEE OrthoP, OrthoT, OrthoU, OrthoGSum, OrthoPoly
%/mathpiper_docs



%mathpiper_docs,name="OrthoL",categories="User Functions;Polynomials (Special)"
*CMD OrthoL --- Laguerre orthogonal polynomials
*STD
*CALL
	OrthoL(n, a, x);

*PARMS

{n} -- degree of polynomial

{a} -- parameter

{x} -- point to evaluate polynomial at

*DESC

This function evaluates the Laguerre polynomial with parameter {a}
and degree {n} at the point {x}. The parameter {a} should be
greater than -1.

The Laguerre polynomials are orthogonal with respect to the weight
function $x^a * Exp(-x)$ on the positive real axis. They satisfy the
recurrence relation
$$ L(n,a,x) = (2+(a-1-x)/n)* L(n-1,a,x) $$
$$ -(1-(a-1)/n)*L(n-2,a,x) $$
for $n>1$, with 
$L(0,a,x) = 1$,
$L(1,a,x) = a + 1 - x$.

*REM	
//	           /     a - 1 - x \             
//	L(n,a,x) = | 2 + --------- | L(n-1,a,x) -
//	           \         n     /             
//	
//	  /     a - 1 \
//	  | 1 + ----- | L(n-2,a,x),
//	  \  	  n   /


Most of the work is performed by the internal function {OrthoPoly}.

*E.G.

In> OrthoL(3, 1, x);
Result: x*(x*(2-x/6)-6)+4;
In> OrthoL(3, 1/2, 0.25);
Result: 1.2005208334;

*SEE OrthoLSum, OrthoPoly
%/mathpiper_docs



%mathpiper_docs,name="OrthoT;OrthoU",categories="User Functions;Polynomials (Special)"
*CMD OrthoT --- Chebyshev polynomials
*CMD OrthoU --- Chebyshev polynomials
*STD
*CALL
	OrthoT(n, x);
	OrthoU(n, x);

*PARMS

{n} -- degree of polynomial

{x} -- point to evaluate polynomial at

*DESC

These functions evaluate the Chebyshev polynomials of the first kind
$T(n,x)$ and of the second kind $U(n,x)$, of degree "n" at the point "x". (The
name of this Russian mathematician is also sometimes spelled "Tschebyscheff".)

The Chebyshev polynomials are orthogonal with respect to the weight
function $(1-x^2)^(-1/2)$. Hence they are a special case of the Gegenbauer
polynomials $G(n,a,x)$, with $a=0$. They satisfy the recurrence relations
$$ T(n,x) = 2* x* T(n-1,x) - T(n-2,x) $$,
$$ U(n,x) = 2* x* U(n-1,x) - U(n-2,x) $$
for $n > 1$, with
$T(0,x) = 1$,
$T(1,x) = x$,
$U(0,x) = 1$,
$U(1,x) = 2*x$.


*E.G.

In> OrthoT(3, x);
Result: 2*x*(2*x^2-1)-x;
In> OrthoT(10, 0.9);
Result: -0.2007474688;
In> OrthoU(3, x);
Result: 4*x*(2*x^2-1);
In> OrthoU(10, 0.9);
Result: -2.2234571776;


*SEE OrthoG, OrthoTSum, OrthoUSum, OrthoPoly
%/mathpiper_docs



%mathpiper_docs,name="OrthoPSum;OrthoHSum;OrthoLSum;OrthoGSum;OrthoTSum;OrthoUSum",categories="User Functions;Polynomials (Special)"
*CMD OrthoPSum --- sums of series of orthogonal polynomials
*CMD OrthoHSum --- sums of series of orthogonal polynomials
*CMD OrthoLSum --- sums of series of orthogonal polynomials
*CMD OrthoGSum --- sums of series of orthogonal polynomials
*CMD OrthoTSum --- sums of series of orthogonal polynomials
*CMD OrthoUSum --- sums of series of orthogonal polynomials
*STD
*CALL
	OrthoPSum(c, x);
	OrthoPSum(c, a, b, x);
	OrthoHSum(c, x);
	OrthoLSum(c, a, x);
	OrthoGSum(c, a, x);
	OrthoTSum(c, x);
	OrthoUSum(c, x);

*PARMS

{c} -- list of coefficients

{a}, {b} -- parameters of specific polynomials

{x} -- point to evaluate polynomial at

*DESC

These functions evaluate the sum of series of orthogonal polynomials at the point {x}, with given list of coefficients {c} of the series and fixed polynomial parameters {a}, {b} (if applicable).

The list of coefficients starts with the lowest order, so that for example
OrthoLSum(c, a, x) = c[1] L[0](a,x) + c[2] L[1](a,x) + ... + c[N] L[N-1](a,x).

See pages for specific orthogonal polynomials for more details on the parameters of the polynomials.

Most of the work is performed by the internal function {OrthoPolySum}. The individual polynomials entering the series are not computed, only the sum of the series.

*E.G.

In> Expand(OrthoPSum({1,0,0,1/7,1/8}, 3/2, \
	  2/3, x));
Result: (7068985*x^4)/3981312+(1648577*x^3)/995328+
	(-3502049*x^2)/4644864+(-4372969*x)/6967296
	+28292143/27869184;

*SEE OrthoP, OrthoG, OrthoH, OrthoL, OrthoT, OrthoU, OrthoPolySum
%/mathpiper_docs



%mathpiper_docs,name="OrthoPoly",categories="User Functions;Polynomials (Special)"
*CMD OrthoPoly --- internal function for constructing orthogonal polynomials
*STD
*CALL
	OrthoPoly(name, n, par, x)

*PARMS

{name} -- string containing name of orthogonal family

{n} -- degree of the polynomial

{par} -- list of values for the parameters

{x} -- point to evaluate at

*DESC

This function is used internally to construct orthogonal
polynomials. It returns the {n}-th polynomial from the family
{name} with parameters {par} at the point {x}.

All known families are stored in the association list returned by the function {KnownOrthoPoly()}. The name serves as key. At the moment
the following names are known to MathPiper: {"Jacobi"}, {"Gegenbauer"}, {"Laguerre"}, {"Hermite"}, {"Tscheb1"},
and {"Tscheb2"}. The value associated to the key
is a pure function that takes two arguments: the order {n} and the
extra parameters {p}, and returns a list of two lists: the first list
contains the coefficients {A,B} of the n=1 polynomial, i.e. $A+B*x$;
the second list contains the coefficients {A,B,C} in the recurrence
relation, i.e. $P[n] = (A+B*x)*P[n-1]+C*P[n-2]$. (There are
only 3 coefficients in the second list, because none of the polynomials use $C+D*x$ instead of $C$ in the recurrence relation. This is assumed in the implementation!)

If the argument {x} is numerical, the function {OrthoPolyNumeric} is called. Otherwise, the function {OrthoPolyCoeffs} computes a list of coefficients, and
{EvaluateHornerScheme} converts this list into a
polynomial expression.

*SEE OrthoP, OrthoG, OrthoH, OrthoL, OrthoT, OrthoU, OrthoPolySum
%/mathpiper_docs



%mathpiper_docs,name="OrthoPolySum",categories="User Functions;Polynomials (Special)"
*CMD OrthoPolySum --- internal function for computing series of orthogonal polynomials
*STD
*CALL
	OrthoPolySum(name, c, par, x)

*PARMS

{name} -- string containing name of orthogonal family

{c} -- list of coefficients

{par} -- list of values for the parameters

{x} -- point to evaluate at

*DESC

This function is used internally to compute series of orthogonal polynomials.
It is similar to the function {OrthoPoly} and returns the result of the
summation of series of polynomials from the family {name} with parameters {par}
at the point {x}, where {c} is the list of coefficients of the series.

The algorithm used to compute the series without first computing the individual polynomials is the Clenshaw-Smith recurrence scheme.
(See the algorithms book for explanations.)

If the argument {x} is numerical, the function {OrthoPolySumNumeric} is called.
Otherwise, the function {OrthoPolySumCoeffs} computes the list of coefficients
of the resulting polynomial, and {EvaluateHornerScheme} converts this list into
a polynomial expression.

*SEE OrthoPSum, OrthoGSum, OrthoHSum, OrthoLSum, OrthoTSum, OrthoUSum, OrthoPoly
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/html/0000755000175000017500000000000011722677332024242 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/html/html.mpw0000644000175000017500000001037511320716335025730 0ustar  giovannigiovanni%mathpiper,def="HtmlNewParagraph;HtmlAnchor;HtmlLink;HtmlTable;HtmlCaption;HtmlTitle;HtmlFrameSetRows;HtmlFrameSetCols;HtmlFrame;HtmlTag;HtmlForm;Bullets;Bullet;HtmlTextArea;HtmlTextField;HtmlSubmitButton;SetHtmlDirectory;HtmlFile;ClearSite;LoadSite;SaveSite;MySQLQuery"

/* def file definitions
HtmlNewParagraph
HtmlAnchor
HtmlLink
HtmlTable
HtmlCaption
HtmlTitle
HtmlFrameSetRows
HtmlFrameSetCols
HtmlFrame
HtmlTag
HtmlForm
Bullets
Bullet
HtmlTextArea
HtmlTextField
HtmlSubmitButton
SetHtmlDirectory
HtmlFile
ClearSite
LoadSite
SaveSite
MySQLQuery
*/


/* code to generate html */


/* Global defines */
anchor:={};
anchor["0"]:="a";
anchor["name"]:="";

link:={};
link["0"]:="a";
link["href"]:="";

frameset:={};
frameset["0"]:="frameset";
frameset["border"]:="0";

frame:={};
frame["0"]:="frame";

caption:={};
caption["0"]:="caption";

table:={};
table["0"]:="table";

form:={};
form["0"]:="form";

textarea:={};
textarea["0"]:="textarea";

textfield:={};
textfield["0"]:="input";
textfield["TYPE"]:="text";

button:={};
button["0"]:="input";
button["TYPE"]:="submit";

bullets:={};
bullets["0"]:="ul";

bullet:={};
bullet["0"]:="li";

newline:="
";
Gt():=">";
Lt():="<";




HtmlNewParagraph():= (newline : "
    " : newline);

HtmlTitle(title):=
[
"
  " : title : "
  
";
];

HtmlAnchor(name):=
[
  anchor["name"]:=name;
  HtmlTag(anchor,"");
];
Bodied("HtmlAnchor",60000);

HtmlTable(cellpadding,width,body):=
[
  table["cellpadding"]:=ToString(cellpadding);
  table["width"]:=width;
  HtmlTag(table,body);
];

Bullets(list):=HtmlTag(bullets,list);
Bullet (list):=HtmlTag(bullet ,list);


HtmlCaption(title):=
[
 HtmlTag(caption,title);
];

HtmlForm(action,body):=
[
  form["method"]:="get";
  form["action"]:=action;
  HtmlTag(form,body);
];


HtmlTextArea(name,width,height,body) :=
[
  textarea["name"]:=name;
  textarea["cols"]:=ToString(width);
  textarea["rows"]:=ToString(height);
  HtmlTag(textarea,body);
];

HtmlTextField(name,size,value):=
[
  textfield["name"]:=name;
  textfield["size"]:=ToString(size);
  textfield["value"]:=value;
  HtmlTag(textfield,"");
];

HtmlSubmitButton(name,value):=
[
  button["name"]:=name;
  button["value"]:=value;
  HtmlTag(button,"");
];


HtmlLink(description,file,tag,target):=
[
  If(tag != "",
    link["href"]:= file : "#" : tag,
    link["href"]:= file);

  If(target != "",link["target"] :=target);
  HtmlTag(link,description);
];

HtmlFrameSetRows(columns,body):=
[
  frameset["cols"]:="";
  frameset["rows"]:=columns;
  HtmlTag(frameset,body);
];

HtmlFrameSetCols(columns,body):=
[
  frameset["cols"]:=columns;
  frameset["rows"]:="";
  HtmlTag(frameset,body);
];

HtmlFrame(source,name):=
[
  frame["src"]:=source;
  frame["name"]:=name;
  HtmlTag(frame,"");
];


/* export a html tag type, using the specifications in the
   tags assoc list.
   */
HtmlTag(tags,content):=
[
  Local(result,tag,analytics);
  result:="<" : tags["0"];
  ForEach(tag,AssocIndices(tags))
  [
    If (tag != "0" And tags[tag] != "",
       result:= result : " " : tag : "=" : "\"" : tags[tag] : "\""
       );
  ];

  analytics:="";
  If(tags["0"] = "body",
    analytics:="

");


  result:= result : ">" : newline :
           content : newline :
           analytics : "" : newline;

  result;
];

/* output directory management */
htmldir:="";
SetHtmlDirectory(dir):= [htmldir:=dir;];
HtmlFile(file) := [htmldir : file;];


/* loading and saving site info */
site:={};
ClearSite() := [site:={};];
LoadSite():=
[
  PipeFromFile("siteall")
  [
    site:=Read();
  ];
];

SaveSite():=
[
  PipeToFile("siteall")
  [
    Write(site);
    WriteString(";");
  ];
];

MySQLQuery(pidstr,string):=
[
  Local(result);
  PipeToFile("sqlin":pidstr) WriteString(string);
  SystemCall("mysql mysql < ":"sqlin":pidstr:" > sqlout":pidstr);
  SystemCall(FindFile("tools/mysqlstubs"):" sqlout":pidstr:" sqlout_":pidstr);
  result:= PipeFromFile("sqlout_":pidstr)Read();
  SystemCall("rm -rf sqlin":pidstr);
  SystemCall("rm -rf sqlout":pidstr);
  SystemCall("rm -rf sqlout_":pidstr);
  result;
];



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stats/0000755000175000017500000000000011722677334024436 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stats/ExpressionDepth.mpw0000644000175000017500000000056111320767174030305 0ustar  giovannigiovanni%mathpiper,def="ExpressionDepth"

10 # ExpressionDepth(expression_IsFunction) <--
[
  Local(result);
  result:=0;
  ForEach(item,Rest(FunctionToList(expression)))
  [
    Local(newresult);
    newresult:=ExpressionDepth(item);
    result:=Maximum(result,newresult);
  ];
  result+1;
];
20 # ExpressionDepth(_expression) <-- 1;
UnFence("ExpressionDepth",1);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/0000755000175000017500000000000011722677330025125 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Sin.mpw0000644000175000017500000000430611523200452026370 0ustar  giovannigiovanni%mathpiper,def="Sin"


1 # SinMap( _n )_(Not(IsRationalOrNumber(n))) <-- ListToFunction({ToAtom("Sin"),n*Pi});
2 # SinMap( _n )_(n<0) <-- -SinMap(-n);
2 # SinMap( _n )_(n>2) <-- SinMap(Modulo(n,2));
3 # SinMap( _n )_(n>1) <-- SinMap(n-2);
4 # SinMap( _n )_(n>1/2) <-- SinMap(1-n);

5 # SinMap( n_IsInteger ) <-- 0;
5 # SinMap( 1/6 ) <-- 1/2;
5 # SinMap( 1/4 ) <-- Sqrt(2)/2;
5 # SinMap( 1/3 ) <-- Sqrt(3)/2;
5 # SinMap( 1/2 ) <-- 1;
5 # SinMap( 1/10) <-- (Sqrt(5)-1)/4;

10 # SinMap(_n) <-- ListToFunction({ToAtom("Sin"),n*Pi});




2 # Sin(x_IsNumber)_InNumericMode() <-- SinNum(x);
4 # Sin(ArcSin(_x))           <-- x;
4 # Sin(ArcCos(_x)) <-- Sqrt(1-x^2);
4 # Sin(ArcTan(_x)) <-- x/Sqrt(1+x^2);
5 # Sin(- _x)_(Not IsConstant(x))                 <-- -Sin(x);
6 # (Sin(x_IsConstant))_(IsNegativeNumber(N(Eval(x))))   <-- -Sin(-x);

// must prevent it from looping
6 # Sin(x_IsInfinity) 		<-- Undefined;
6 # Sin(Undefined) <-- Undefined;

110 # Sin(Complex(_r,_i)) <--
    (Exp(I*Complex(r,i)) - Exp(- I*Complex(r,i))) / (I*2) ;

200 # Sin(v_CanBeUni(Pi))_(Not(InNumericMode()) And Degree(v,Pi) < 2 And Coef(v,Pi,0) = 0) <--
[
  SinMap(Coef(v,Pi,1));
];

100 # Sin(_x)/Tan(_x) <-- Cos(x);
100 # Sin(_x)/Cos(_x) <-- Tan(x);

Sin(xlist_IsList) <-- MapSingle("Sin",xlist);

%/mathpiper



%mathpiper_docs,name="Sin",categories="User Functions;Trigonometry (Symbolic)"
*CMD Sin --- trigonometric sine function
*STD
*CALL
	Sin(x)

*PARMS

{x} -- argument to the function, in radians

*DESC

This function represents the trigonometric function sine. MathPiper leaves 
expressions alone even if x is a number, trying to keep the result as 
exact as possible. The floating point approximations of these functions 
can be forced by using the {N} function.

MathPiper knows some trigonometric identities, so it can simplify to exact
results even if {N} is not used. This is the case, for instance,
when the argument is a multiple of $Pi$/6 or $Pi$/4.

These functions are threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Sin(1)
Result: Sin(1);
In> N(Sin(1),20)
Result: 0.84147098480789650665;
In> Sin(Pi/4)
Result: Sqrt(2)/2;

*SEE Cos, Tan, ArcSin, ArcCos, ArcTan, N, Pi
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Tanh.mpw0000644000175000017500000000103111316304766026536 0ustar  giovannigiovanni%mathpiper,def="Tanh"

2 # Tanh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( Sinh(x)/Cosh(x) ));

100 # Tanh(_x)*Cosh(_x) <-- Sinh(x);

200 # Tanh(0)           <-- 0;
200 # Tanh(Infinity)    <-- 1;
200 # Tanh(-Infinity)   <-- -1;
200 # Tanh(ArcTanh(_x)) <-- x;
200 # Tanh(ArcSinh(_x)) <-- x/Sqrt(1+x^2);
200 # Tanh(ArcCosh(_x)) <-- Sqrt((x-1)/(x+1))*(x+1)/x;

200 # Tanh(Undefined) <-- Undefined;

/* Threading of standard analytic functions */
Tanh(xlist_IsList) <-- MapSingle("Tanh",xlist);



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCosh.mpw0000644000175000017500000000051011316304766027167 0ustar  giovannigiovanni%mathpiper,def="ArcCosh"

10 # ArcCosh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( Ln(x+Sqrt(x^2-1)) ));

200 # ArcCosh(Infinity) <-- Infinity;
200 # ArcCosh(-Infinity) <-- Infinity+I*Pi/2;
200 # ArcCosh(Undefined) <-- Undefined;

ArcCosh(xlist_IsList) <-- MapSingle("ArcCosh",xlist);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Exp.mpw0000644000175000017500000000164311523200452026374 0ustar  giovannigiovanni%mathpiper,def="Exp"

2 # Exp(x_IsNumber)_InNumericMode() <-- ExpNum(x);
4 # Exp(Ln(_x))           <-- x;
110 # Exp(Complex(_r,_i)) <--  Exp(r)*(Cos(i) + I*Sin(i));
200 # Exp(0) <-- 1;
200 # Exp(-Infinity) <-- 0;
200 # Exp(Infinity) <-- Infinity;
200 # Exp(Undefined) <-- Undefined;

Exp(xlist_IsList) <-- MapSingle("Exp",xlist);

%/mathpiper



%mathpiper_docs,name="Exp",categories="User Functions;Calculus Related (Symbolic)"
*CMD Exp --- exponential function
*STD
*CALL
	Exp(x)

*PARMS

{x} -- argument to the function

*DESC

This function calculates $e$ raised to the power $x$, where $e$ is the
mathematic constant 2.71828... One can use {Exp(1)}
to represent $e$.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Exp(0)
Result: 1;
In> Exp(I*Pi)
Result: -1;
In> N(Exp(1))
Result: 2.7182818284;

*SEE Ln, Sin, Cos, Tan, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCoth.mpw0000644000175000017500000000010611316304766027171 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCsc.mpw0000644000175000017500000000011211316304766027001 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts yet. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcSinh.mpw0000644000175000017500000000050211316304766027175 0ustar  giovannigiovanni%mathpiper,def="ArcSinh"

10 # ArcSinh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( Ln(x+Sqrt(x^2+1)) ));

200 # ArcSinh(Infinity) <-- Infinity;
200 # ArcSinh(-Infinity) <-- -Infinity;
200 # ArcSinh(Undefined) <-- Undefined;

ArcSinh(xlist_IsList) <-- MapSingle("ArcSinh",xlist);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Csc.mpw0000644000175000017500000000013511316304766026360 0ustar  giovannigiovanni%mathpiper,def="Csc"

100 # 1/Csc(_x)		<-- Sin(x);

100 # Csc(_x)		<-- 1/Sin(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/om/0000755000175000017500000000000011722677330025540 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/om/om.mpw0000644000175000017500000000237611316304766026707 0ustar  giovannigiovanni%mathpiper,def=""

/// coded by Serge Winitzki. See essays documentation for algorithms.

// From code.mpi.def:
OMDef( "ArcSin" , "transc1","arcsin"  );
OMDef( "ArcCos" , "transc1","arccos"  );
OMDef( "ArcTan" , "transc1","arctan"  );
OMDef( "ArcSec" , "transc1","arcsec"  );
OMDef( "ArcCsc" , "transc1","arccsc"  );
OMDef( "ArcCot" , "transc1","arccot"  );
OMDef( "ArcSinh", "transc1","arcsinh" );
OMDef( "ArcCosh", "transc1","arccosh" );
OMDef( "ArcTanh", "transc1","arctanh" );
OMDef( "ArcSech", "transc1","arcsech" );
OMDef( "ArcCsch", "transc1","arccsch" );
OMDef( "ArcCoth", "transc1","arccoth" );
OMDef( "Sin"    , "transc1","sin"     );
OMDef( "Cos"    , "transc1","cos"     );
OMDef( "Tan"    , "transc1","tan"     );
OMDef( "Sec"    , "transc1","sec"     );
OMDef( "Csc"    , "transc1","csc"     );
OMDef( "Cot"    , "transc1","cot"     );
OMDef( "Sinh"   , "transc1","sinh"    );
OMDef( "Cosh"   , "transc1","cosh"    );
OMDef( "Tanh"   , "transc1","tanh"    );
OMDef( "Sech"   , "transc1","sech"    );
OMDef( "Csch"   , "transc1","csch"    );
OMDef( "Coth"   , "transc1","coth"    );
OMDef( "Exp"    , "transc1","exp"     );
OMDef( "Ln"     , "transc1","ln"      );

// Related OM symbols not yet defined in MathPiper:
//     "log"    , "transc1","log"


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcSin.mpw0000644000175000017500000000406711543450620027030 0ustar  giovannigiovanni%mathpiper,def="ArcSin"

2 # ArcSin(x_IsNumber)_(InNumericMode() And Abs(x)<=1) <-- ArcSinNum(x);
/// complex ArcSin
3 # ArcSin(x_IsNumber)_InNumericMode() <-- Sign(x)*(Pi/2+I*ArcCosh(x));

110 # ArcSin(Complex(_r,_i)) <--
    (- I) * Ln((I*Complex(r,i)) + ((1-(Complex(r,i)^2))^(1/2)));

150 # ArcSin(- _x)_(Not IsConstant(x))             <-- -ArcSin(x);
160 # (ArcSin(x_IsConstant))_(IsNegativeNumber(N(Eval(x)))) <-- -ArcSin(-x);

200 # ArcSin(0) <-- 0;
200 # ArcSin(1/2) <-- Pi/6;
200 # ArcSin(Sqrt(1/2)) <-- Pi/4;
200 # ArcSin(Sqrt(3/4)) <-- Pi/3;
200 # ArcSin(1) <-- Pi/2;
200 # ArcSin(_n)_(n = -1) <-- -Pi/2;
200 # ArcSin(_n)_(-n = Sqrt(3/4)) <-- -Pi/3;
200 # ArcSin(_n)_(-n = Sqrt(1/2)) <-- -Pi/4;
200 # ArcSin(_n)_(-n = 1/2) <-- -Pi/6;

ArcSin(xlist_IsList) <-- MapSingle("ArcSin",xlist);

200 # ArcSin(Undefined) <-- Undefined;

%/mathpiper



%mathpiper_docs,name="ArcSin",categories="User Functions;Trigonometry (Symbolic)"
*CMD ArcSin --- inverse trigonometric function arc-sine
*STD
*CALL
	ArcSin(x)

*PARMS

{x} -- argument to the function

*DESC

This function represents the inverse trigonometric function arcsine. For
instance, the value of $ArcSin(x)$ is a number $y$ such that
$Sin(y)$ equals $x$.

Note that the number $y$ is not unique. For instance, $Sin(0)$ and
$Sin(Pi)$ both equal 0, so what should $ArcSin(0)$ be? In MathPiper,
it is agreed that the value of $ArcSin(x)$ should be in the interval
[-$Pi$/2,$Pi$/2]. 

Usually, MathPiper leaves this function alone unless it is forced to do
a numerical evaluation by the {N} function. If the
argument is -1, 0, or 1 however, MathPiper will simplify the
expression. If the argument is complex,  the expression will be
rewritten using the {Ln} function.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> ArcSin(1)
Result: Pi/2;
	
In> ArcSin(1/3)
Result: ArcSin(1/3);
In> Sin(ArcSin(1/3))
Result: 1/3;
	
In> x:=N(ArcSin(0.75))
Result: 0.848062;
In> N(Sin(x))
Result: 0.7499999477;

*SEE Sin, Cos, Tan, N, Pi, Ln, ArcCos, ArcTan
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Coth.mpw0000644000175000017500000000020711316304766026545 0ustar  giovannigiovanni%mathpiper,def="Coth"

100 # 1/Coth(_x)	<-- Tanh(x);

100 # Coth(_x)		<-- 1/Tanh(x);

100 # Coth(_x)*Sinh(_x) <-- Cosh(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcTanh.mpw0000644000175000017500000000063111316304766027171 0ustar  giovannigiovanni%mathpiper,def="ArcTanh"

10 # ArcTanh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( Ln((1+x)/(1-x))/2 ));

200 # ArcTanh(Infinity) <-- Infinity+I*Pi/2;
200 # ArcTanh(-Infinity) <-- -Infinity-I*Pi/2;	// this is a little silly b/c we don't support correct branch cuts yet
200 # ArcTanh(Undefined) <-- Undefined;

ArcTanh(xlist_IsList) <-- MapSingle("ArcTanh",xlist);



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Cot.mpw0000644000175000017500000000013511316304766026375 0ustar  giovannigiovanni%mathpiper,def="Cot"

100 # 1/Cot(_x)		<-- Tan(x);

100 # Cot(_x)		<-- 1/Tan(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Csch.mpw0000644000175000017500000000014111316304766026525 0ustar  giovannigiovanni%mathpiper,def="Csch"

100 # 1/Csch(_x)	<-- Sinh(x);

100 # Csch(_x)		<-- 1/Sinh(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Ln.mpw0000644000175000017500000000263211523200452026210 0ustar  giovannigiovanni%mathpiper,def="Ln"

2 # Ln(0)                    <-- -Infinity;
2 # Ln(1)                    <-- 0;
2 # Ln(Infinity)                    <-- Infinity;
2 # Ln(Undefined)                   <-- Undefined;

/* 2 # Ln(-Infinity)                    <-- 0; */
2 # Ln(x_IsNegativeNumber)_InNumericMode() <-- Complex(Ln(-x), Pi);
3 # Ln(x_IsNumber)_(InNumericMode() And x>=1) <-- Internal'LnNum(x);
4 # Ln(Exp(_x))              <-- x;

3 # Ln(Complex(_r,_i)) <-- Complex(Ln(Abs(Complex(r,i))), Arg(Complex(r,i)));
4 # Ln(x_IsNegativeNumber) <-- Complex(Ln(-x), Pi);
5 # Ln(x_IsNumber)_(InNumericMode() And x<1) <-- - Internal'LnNum(DivideN(1, x));

Ln(xlist_IsList) <-- MapSingle("Ln",xlist);

%/mathpiper



%mathpiper_docs,name="Ln",categories="User Functions;Calculus Related (Symbolic)"
*CMD Ln --- natural logarithm
*STD
*CALL
	Ln(x)

*PARMS

{x} -- argument to the function

*DESC

This function calculates the natural logarithm of "x". This is the
inverse function of the exponential function, {Exp}, i.e. $Ln(x) = y$ implies that $Exp(y) = x$. For complex
arguments, the imaginary part of the logarithm is in the interval
(-$Pi$,$Pi$]. This is compatible with the branch cut of {Arg}.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Ln(1)
Result: 0;
In> Ln(Exp(x))
Result: x;
In> Differentiate(x) Ln(x)
Result: 1/x;

*SEE Exp, Arg
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/0000755000175000017500000000000011722677327027112 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/CosNum.mpw0000644000175000017500000000034611316304766031037 0ustar  giovannigiovanni%mathpiper,def="CosNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

CosNum(x) :=
[
  If(x<0 Or 113*x>710, x:=TruncRadian(x));
  CosN(x);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/SinNum.mpw0000644000175000017500000000040211316304766031035 0ustar  giovannigiovanni%mathpiper,def="SinNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

SinNum(x) :=
[
  If(x<0 Or 113*x>710, x:=TruncRadian(x));	// 710/113 is close to 2*Pi
  SinN(x);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/ExpNum.mpw0000644000175000017500000000113011316304766031037 0ustar  giovannigiovanni%mathpiper,def="ExpNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

// large positive x
10 # ExpNum(x_IsNumber) _ (x > MathExpThreshold()) <-- [
	Local(i, y);
	i:=0;
	For(i:=0, x > MathExpThreshold(), i++)
		x := DivideN(x, 2.);
	For(y:= ExpN(x), i>0, i--)
		y := MultiplyN(y, y);
	y;

];
// large negative x
20 # ExpNum(x_IsNumber) _ (2*x < -MathExpThreshold()) <-- DivideN(1, ExpNum(-x));
// other values of x
30 # ExpNum(x_IsNumber) <-- ExpN(x);


//CachedConstant(Exp1, ExpN(1));	// Exp1 is useless so far

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/expthreshold.mpw0000644000175000017500000000116311316304766032342 0ustar  giovannigiovanni%mathpiper,def="MathExpThreshold;SetMathExpThreshold"

/* def file definitions
MathExpThreshold
SetMathExpThreshold
*/

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

//////////////////////////////////////////////////
/// Exponent
//////////////////////////////////////////////////

LocalSymbols(mathExpThreshold) [
  // improve convergence of Exp(x) for large x
  mathExpThreshold := If(Not IsBound(mathExpThreshold), 500);

  MathExpThreshold() := mathExpThreshold;
  SetMathExpThreshold(threshold) := [mathExpThreshold:= threshold; ];
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/TanNum.mpw0000644000175000017500000000015411316304766031032 0ustar  giovannigiovanni%mathpiper,def="TanNum"
TanNum(x) :=
[
  If(x<0 Or 113*x>710, x:=TruncRadian(x));
  TanN(x);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/ArcTanNum.mpw0000644000175000017500000000444111316304766031463 0ustar  giovannigiovanni%mathpiper,def="ArcTanNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

ArcTanNum(x) :=
[
	// using trigonometric identities is faster for now
	If(
		Abs(x)>1,
		Sign(x)*(Internal'Pi()/2-ArcSin(1/Sqrt(x^2+1))),
		ArcSin(x/Sqrt(x^2+1))
	);
];





/* old methods -- slower for now
/// numerical evaluation of ArcTan using continued fractions: top level
2 # ArcTan(x_IsNumber)_InNumericMode() <--
Sign(x) *
// now we need to compute ArcTan of a nonnegative number Abs(x)
[
	Local(nterms, y);
	y := Abs(x);
	// use identities to improve convergence -- see essays book
	If(
		y>1,
		y:=1/y	// now y <= 1
	// we shall know that the first identity was used because Abs(x) > 1 still
	);
	// use the second identity
	y := y/(1+Sqrt(1+y^2));	// now y <= Sqrt(2)-1
	// find the required number of terms in the continued fraction
	nterms := 1/y;	// this needs to be calculated at full precision
	// see essays book on the choice of the number of terms (added 2 "guard terms").
	// we need Hold() because otherwise, if InNumericMode() returns True, N(..., 5) will not avoid the full precision calculation of Ln().
	// the value of x should not be greater than 1 here!
	nterms := 2 + Ceil( N(Hold(Ln(10)/(Ln(4)+2*Ln(nterms))), 5) * BuiltinPrecisionGet() );
	If(	// call the actual routine
		Abs(x)>1,
		Pi/2-2*MyArcTan(y, nterms),	// this is for |x|>1
		2*MyArcTan(y, nterms)
		// MyArcTan(x, nterms)
	);
];
*/



/// numerical evaluation of ArcTan using continued fractions: low level

// evaluation using recursion -- slightly faster but lose some digits to roundoff errors and needs large recursion depth
/*
10 # ContArcTan(_x,_n,_n) <-- (2*n-1);
20 # ContArcTan(_x,_n,_m) <--
[
  (2*n-1) + (n*x)^2/ContArcTan(x,n+1,m);
];

MyArcTan(x,n) :=
[
  x/ContArcTan(x,1,n);
];
*/
/*
/// evaluate n terms of the continued fraction for ArcTan(x) without recursion.
/// better control of roundoff errors
MyArcTan(x, n) :=
[
	Local(i, p, q, t);
	// initial numerator and denominator
	p:=1;
	q:=1;
	// start evaluating from the last term upwards
	For(i:=n, i>=1, i--)
	[
		//{p,q} := {p + q*(i*x)^2/(4*i^2-1), p};
	//	t := p*(2*i-1) + q*(i*x)^2; then have to start with p:=2*n+1
		t := p + q*(i*x)^2/(4*i^2-1);
		q := p;
		p := t;
	];
	// answer is x/(p/q)
	x*q/p;
];
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/ArcSinNum.mpw0000644000175000017500000000065511316304766031475 0ustar  giovannigiovanni%mathpiper,def="ArcSinNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

ArcSinNum(x) :=
[
	// need to be careful when |x| close to 1
	If(
		239*Abs(x) >= 169,	// 169/239 is a good enough approximation of 1/Sqrt(2)
		// use trigonometric identity to avoid |x| close to 1
		Sign(x)*(Internal'Pi()/2-ArcSinN(Sqrt(1-x^2))),
		ArcSinN(x)
	);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/TruncRadian.mpw0000644000175000017500000000277411523200452032037 0ustar  giovannigiovanni%mathpiper,def="TruncRadian"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

/* TruncRadian truncates the radian r so it is between 0 and 2*Pi.
 * It calculates r mod 2*Pi using the required precision.
 */
TruncRadian(_r) <--
[
  Local(twopi);
  // increase precision by the number of digits of r before decimal point; enough to evaluate Abs(r) with 1 digit of precision
  N([
    r:=Eval(r);
    twopi:=2*Internal'Pi();
    r:=r-FloorN(r/twopi)*twopi;
  ], BuiltinPrecisionGet() + IntLog(Ceil(Abs(N(Eval(r), 1))), 10));
  r;
];
HoldArgument("TruncRadian",r);

%/mathpiper



%mathpiper_docs,name="TruncRadian",categories="Programmer Functions;Numerical (Arbitrary Precision)"
*CMD TruncRadian --- remainder modulo $2*Pi$
*STD
*CALL
	TruncRadian(r)

*PARMS

{r} -- a number

*DESC

{TruncRadian} calculates $Modulo(r,2*Pi)$, returning a value between $0$
and $2*Pi$. This function is used in the trigonometry functions, just
before doing a numerical calculation using a Taylor series. It greatly
speeds up the calculation if the value passed is a large number.

The library uses the formula
$$TruncRadian(r) = r - Floor( r/(2*Pi) )*2*Pi$$,
where $r$ and $2*Pi$ are calculated with twice the precision used in the
environment to make sure there is no rounding error in the significant
digits.

*E.G.

In> 2*Internal'Pi()
Result: 6.283185307;
In> TruncRadian(6.28)
Result: 6.28;
In> TruncRadian(6.29)
Result: 0.0068146929;

*SEE Sin, Cos, Tan

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/BrentLn.mpw0000644000175000017500000000504411522447611031173 0ustar  giovannigiovanni%mathpiper,def="BrentLn"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

/* The BrentLn() algorithm is currently slower in internal math but should be asymptotically faster. */

CachedConstant(Ln2, Internal'LnNum(2));	// this is only useful for BrentLn

// compute Ln(x_IsInteger) using the AGM sequence. See: Brent paper rpb028 (1975).
// this is currently faster than LogN(n) for precision > 40 digits
10 # BrentLn(x_IsInteger)_(BuiltinPrecisionGet()>40) <--
[
	Local(y, n, k, eps);
	n := BuiltinPrecisionGet();	// decimal digits
	// initial power of x
	k := 1 + Quotient(IntLog(4*10^n, x), 2);	// now x^(2*k)>4*10^n
	BuiltinPrecisionSet(n+5);	// guard digits
	eps := DivideN(1, 10^n);	// precision
	y := PowerN(x, k);	// not yet divided by 4
	// this is Brent's AGM times y. This way we work around the MathPiper limitation of fixed precision, at cost of slightly slower initial iterations
	y := DivideN(Internal'Pi()*y, (2*k)*ArithmeticGeometricMean(4, y, eps));
	BuiltinPrecisionSet(n);
	RoundTo(y, n);	// do not return a more precise number than we really have
];

15 # BrentLn(x_IsInteger)  <-- LogN(x);

/// calculation of Ln(x) using Brent's AGM sequence - use precomputed Pi and Ln2.
20 # BrentLn(_x)_(x<1) <-- -BrentLn(1/x);

// this is currently faster than LogN() for precision > 85 digits and numbers >2
30 # BrentLn(_x)_(BuiltinPrecisionGet()>85) <--
[
	Local(y, n, n1, k, eps);
  N([
    n := BuiltinPrecisionGet();	// decimal digits
    // effective precision is n+Ln(n)/Ln(10)
    n1 := n + IntLog(n,10);	// Ln(2) < 7050/10171
    // initial power of 2
    k := 2 + Quotient(n1*28738, 2*8651)	// Ln(10)/Ln(2) < 28738/8651; now 2^(2*k)>4*10^n1
    // find how many binary digits we already have in x, and multiply by a sufficiently large power of 2 so that y=x*2^k is larger than 2*10^(n1/2)
    - IntLog(Floor(x), 2);
    // now we need k*Ln(2)/Ln(10) additional digits to compensate for cancellation at the final subtraction
    BuiltinPrecisionSet(n1+2+Quotient(k*3361, 11165));	// Ln(2)/Ln(10) < 3361/11165
    eps := DivideN(1, 10^(n1+1));	// precision
    y := x*2^(k-2);	// divided already by 4
    // initial values for AGM
    // this is Brent's AGM times y. This way we work around the MathPiper limitation of fixed precision, at cost of slightly slower initial iterations
    y:=Internal'Pi()*y/(2*ArithmeticGeometricMean(1,y,eps)) - k*Ln2();
    BuiltinPrecisionSet(n);
  ]);
	y;	// do not return a more precise number than we really have
];

40 # BrentLn(x_IsNumber) <-- LogN(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/numerical/Internal'LnNum.mpw0000644000175000017500000000125411371733712032425 0ustar  giovannigiovanni%mathpiper,def="Internal'LnNum"

/// low-level numerical calculations of elementary functions.
/// These are only called if InNumericMode() returns True

// natural logarithm: this should be called only for real x>1
//Internal'LnNum(x) := LogN(x);
// right now the fastest algorithm is Halley's method for Exp(x)=a
// when internal math is fixed, we may want to use Brent's method (below)
// this method is using a cubically convergent Newton iteration for Exp(x/2)-a*Exp(-x/2)=0:
// x' := x - 2 * (Exp(x)-a) / (Exp(x)+a) = x-2+4*a/(Exp(x)+a)
Internal'LnNum(x_IsNumber)_(x>=1) <-- NewtonLn(x);

Internal'LnNum(x_IsNumber)_(0 0 (arbitrary-precision math function)
*CALL
	LogN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcSech.mpw0000644000175000017500000000010611316304766027156 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcSec.mpw0000644000175000017500000000011211316304766027003 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts yet. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCot.mpw0000644000175000017500000000011211316304766027016 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts yet. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Tan.mpw0000644000175000017500000000413211523200452026356 0ustar  giovannigiovanni%mathpiper,def="Tan"

1 # TanMap( _n )_(Not(IsRationalOrNumber(n))) <-- ListToFunction({ToAtom("Tan"),n*Pi});
2 # TanMap( _n )_(n<0) <-- -TanMap(-n);
2 # TanMap( _n )_(n>1) <-- TanMap(Modulo(n,1));
4 # TanMap( _n )_(n>1/2) <-- -TanMap(1-n);

5 # TanMap( 0 ) <-- 0;
5 # TanMap( 1/6 ) <-- 1/3*Sqrt(3);
5 # TanMap( 1/4 ) <-- 1;
5 # TanMap( 1/3 ) <-- Sqrt(3);
5 # TanMap( 1/2 ) <-- Infinity;

10 # TanMap(_n) <-- ListToFunction({ToAtom("Tan"),n*Pi});




2 # Tan(x_IsNumber)_InNumericMode() <-- TanNum(x);
4 # Tan(ArcTan(_x))           <-- x;
4 # Tan(ArcSin(_x)) <-- x/Sqrt(1-x^2);
4 # Tan(ArcCos(_x)) <-- Sqrt(1-x^2)/x;
5 # Tan(- _x)_(Not IsConstant(x))                  <-- -Tan(x);
6 # (Tan(x_IsConstant))_(IsNegativeNumber(N(Eval(x))))   <-- -Tan(-x);

// must prevent it from looping
6 # Tan(Infinity) <-- Undefined;
6 # Tan(Undefined) <-- Undefined;

110 # Tan(Complex(_r,_i)) <-- Sin(Complex(r,i))/Cos(Complex(r,i));

200 # Tan(v_CanBeUni(Pi))_(Not(InNumericMode()) And Degree(v,Pi) < 2 And Coef(v,Pi,0) = 0) <--
      TanMap(Coef(v,Pi,1));

100 # Tan(_x)/Sin(_x) <-- (1/Cos(x));
100 # Tan(_x)*Cos(_x) <-- Sin(x);

Tan(xlist_IsList) <-- MapSingle("Tan",xlist);

%/mathpiper



%mathpiper_docs,name="Tan",categories="User Functions;Trigonometry (Symbolic)"
*CMD Tan --- trigonometric tangent function
*STD
*CALL
	Tan(x)

*PARMS

{x} -- argument to the function, in radians

*DESC

This function represents the trigonometric function tangent. MathPiper leaves 
expressions alone even if x is a number, trying to keep the result as 
exact as possible. The floating point approximations of these functions 
can be forced by using the {N} function.

MathPiper knows some trigonometric identities, so it can simplify to exact
results even if {N} is not used. This is the case, for instance,
when the argument is a multiple of $Pi$/6 or $Pi$/4.

These functions are threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Tan(1)
Result: Tan(1);
In> N(Tan(1),20)
Result: 1.5574077246549022305;
In> Tan(Pi/4)
Result: 1;

*SEE Sin, Cos, ArcSin, ArcCos, ArcTan, N, Pi
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcTan.mpw0000644000175000017500000000412511523200452027006 0ustar  giovannigiovanni%mathpiper,def="ArcTan"

5 # (ArcTan(x_IsConstant))_(IsNegativeNumber(N(Eval(x))))   <-- -ArcTan(-x);

//TODO fix! 4 # ArcTan(Tan(_x))           <-- x;
4 # ArcTan(-Tan(_x))           <-- -ArcTan(Tan(x));
110 # ArcTan(Complex(_r,_i)) <--
     (- I*0.5)*Ln(Complex(1,Complex(r,i))/ Complex(1, - Complex(r,i)));

150 # ArcTan(- _x)_(Not IsConstant(x))             <-- -ArcTan(x);
160 # (ArcTan(x_IsConstant))_(IsNegativeNumber(N(Eval(x)))) <-- -ArcTan(-x);

200 # ArcTan(Sqrt(3)) <-- Pi/3;
200 # ArcTan(-Sqrt(3)) <-- -Pi/3;
200 # ArcTan(1) <-- Pi/4;
200 # ArcTan(0) <-- 0;
200 # ArcTan(_n)_(n = -1) <-- -Pi/4;

200 # ArcTan(Infinity) <-- Pi/2;
200 # ArcTan(-Infinity) <-- -Pi/2;
200 # ArcTan(Undefined) <-- Undefined;

ArcTan(xlist_IsList) <-- MapSingle("ArcTan",xlist);

2 # ArcTan(x_IsNumber)_InNumericMode() <-- ArcTanNum(x);


%/mathpiper



%mathpiper_docs,name="ArcTan",categories="User Functions;Trigonometry (Symbolic)"
*CMD ArcTan --- inverse trigonometric function arc-tangent
*STD
*CALL
	ArcTan(x)

*PARMS

{x} -- argument to the function

*DESC

This function represents the inverse trigonometric function arctangent. For
instance, the value of $ArcTan(x)$ is a number $y$ such that
$Tan(y)$ equals $x$.

Note that the number $y$ is not unique. For instance, $Tan(0)$ and
$Tan(2*Pi)$ both equal 0, so what should $ArcTan(0)$ be? In MathPiper,
it is agreed that the value of $ArcTan(x)$ should be in the interval
[-$Pi$/2,$Pi$/2]. 

Usually, MathPiper leaves this function alone unless it is forced to do
a numerical evaluation by the {N} function. MathPiper will try to simplify
as much as possible while keeping the result exact. If the argument is 
complex,  the expression will be rewritten using the {Ln} function.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> ArcTan(1)
Result: Pi/4

In> ArcTan(1/3)
Result: ArcTan(1/3)
In> Tan(ArcTan(1/3))
Result: 1/3

In> x:=N(ArcTan(0.75))
Result: 0.643501108793285592213351264945231378078460693359375
In> N(Tan(x))
Result: 0.75

*SEE Sin, Cos, Tan, N, Pi, Ln, ArcSin, ArcCos
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Sinh.mpw0000644000175000017500000000142111316304766026550 0ustar  giovannigiovanni%mathpiper,def="Sinh"

2 # Sinh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( (Exp(x)-Exp(-x))/2 ));
5   # Sinh(- _x)	<-- -Sinh(x);

5   # Sinh(- _x)	<-- -Sinh(x);

100 # Sinh(_x)^2-Cosh(_x)^2 	<-- 1;
100 # Sinh(_x)+Cosh(_x)		<-- Exp(x);
100 # Sinh(_x)-Cosh(_x)		<-- Exp(-x);

//100 # Sinh(I*_x)        <-- I*Sin(x);

100 # Sinh(_x)/Cosh(_x) <-- Tanh(x);
100 # Sinh(_x)*Csch(_x) <-- 1;

200 # Sinh(0)		<-- 0;
200 # Sinh(Infinity)	<-- Infinity;
200 # Sinh(-Infinity)	<-- -Infinity;
200 # Sinh(ArcSinh(_x)) <-- x;
200 # Sinh(ArcCosh(_x)) <-- Sqrt((x-1)/(x+1))*(x+1);
200 # Sinh(ArcTanh(_x)) <-- x/Sqrt(1-x^2);

200 # Sinh(Undefined) <-- Undefined;

/* Threading of standard analytic functions */
Sinh(xlist_IsList) <-- MapSingle("Sinh",xlist);



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Sec.mpw0000644000175000017500000000013511316304766026362 0ustar  giovannigiovanni%mathpiper,def="Sec"

100 # 1/Sec(_x)		<-- Cos(x);
100 # Sec(_x)		<-- 1/Cos(x);


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCsch.mpw0000644000175000017500000000010611316304766027154 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Cosh.mpw0000644000175000017500000000107211316304766026545 0ustar  giovannigiovanni%mathpiper,def="Cosh"

5   # Cosh(- _x)	<-- Cosh(x);

// this is never activated

//100 # Cosh(I*_x)        <-- Cos(x);

100 # Cosh(_x)*Sech(_x) <-- 1;

200 # Cosh(0)		<-- 1;
200 # Cosh(Infinity)	<-- Infinity;
200 # Cosh(-Infinity)	<-- Infinity;
200 # Cosh(ArcCosh(_x)) <-- x;
200 # Cosh(ArcSinh(_x)) <-- Sqrt(1+x^2);
200 # Cosh(ArcTanh(_x)) <-- 1/Sqrt(1-x^2);

200 # Cosh(Undefined) <-- Undefined;

Cosh(xlist_IsList) <-- MapSingle("Cosh",xlist);

2 # Cosh(_x)_(InNumericMode() And (IsNumber(x) Or Type(x) = "Complex")) <-- N(Eval( (Exp(x)+Exp(-x))/2 ));



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Sech.mpw0000644000175000017500000000014311316304766026531 0ustar  giovannigiovanni%mathpiper,def="Sech"

100 # Sech(_x)		<-- 1/Cosh(x);

100 # 1/Sech(_x)	<-- Cosh(x);



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/ArcCos.mpw0000644000175000017500000000352011543450620027014 0ustar  giovannigiovanni%mathpiper,def="ArcCos"

2 # ArcCos(x_IsNumber)_InNumericMode() <-- Internal'Pi()/2-ArcSin(x);

 /* TODO check! */
200 # ArcCos(0) <-- Pi/2;
200 # ArcCos(1/2) <-- Pi/3;
200 # ArcCos(Sqrt(1/2)) <-- Pi/4;
200 # ArcCos(Sqrt(3/4)) <-- Pi/6;
200 # ArcCos(1) <-- 0;
200 # ArcCos(_n)_(n = -1) <-- Pi;
200 # ArcCos(_n)_(-n = Sqrt(3/4)) <-- 5/6*Pi;
200 # ArcCos(_n)_(-n = Sqrt(1/2)) <-- 3/4*Pi;
200 # ArcCos(_n)_(-n = 1/2) <-- 2/3*Pi;

200 # ArcCos(Undefined) <-- Undefined;

ArcCos(xlist_IsList) <-- MapSingle("ArcCos",xlist);

110 # ArcCos(Complex(_r,_i)) <--
    (- I)*Ln(Complex(r,i) + (Complex(r,i)^2 - 1)^(1/2));

%/mathpiper



%mathpiper_docs,name="ArcCos",categories="User Functions;Trigonometry (Symbolic)"

*CMD ArcCos --- inverse trigonometric function arc-cosine
*STD
*CALL
	ArcCos(x)

*PARMS

{x} -- argument to the function

*DESC

This function represents the inverse trigonometric function arc-cosine. For
instance, the value of $ArcCos(x)$ is a number $y$ such that
$Cos(y)$ equals $x$.

Note that the number $y$ is not unique. For instance, $Cos(Pi/2)$ and
$Cos(3*Pi/2)$ both equal 0, so what should $ArcCos(0)$ be? In MathPiper,
it is agreed that the value of $ArcCos(x)$ should be in the interval [0,$Pi$] .

Usually, MathPiper leaves this function alone unless it is forced to do
a numerical evaluation by the {N} function. If the
argument is -1, 0, or 1 however, MathPiper will simplify the
expression. If the argument is complex,  the expression will be
rewritten using the {Ln} function.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.


In> ArcCos(0)
Result: Pi/2

In> ArcCos(1/3)
Result: ArcCos(1/3)
In> Cos(ArcCos(1/3))
Result: 1/3

In> x:=N(ArcCos(0.75))
Result: 0.7227342478
In> N(Cos(x))
Result: 0.75


*SEE Sin, Cos, Tan, N, Pi, Ln, ArcSin, ArcTan

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/0000755000175000017500000000000011722677330027310 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/NewtonNum.mpw0000644000175000017500000001250511522212340031752 0ustar  giovannigiovanni%mathpiper,def="NewtonNum"

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: Newton-like superconvergent iteration
//////////////////////////////////////////////////

// Newton's method, generalized, with precision control and diagnostics

/// auxiliary utility: compute the number of common decimal digits of x and y (using relative precision)
Common'digits(x,y) :=
[
	Local(diff);
	diff := Abs(x-y);
	If(
		diff=0,
		Infinity,
		// use approximation Ln(2)/Ln(10) > 351/1166
		Quotient(IntLog(FloorN(DivideN(Maximum(Abs(x), Abs(y)), diff)), 2)*351, 1166)
	); 	// this many decimal digits in common
];

///interface
NewtonNum(_func, _x0) <-- NewtonNum(func, x0, 5);	// default prec0
NewtonNum(_func, _x0, _prec0) <-- NewtonNum(func, x0, prec0, 2);

// func is the function to iterate, i.e. x' = func(x).
// prec0 is the initial precision necessary to get convergence started.
// order is the order of convergence of the given sequence (e.g. 2 or 3).
// x0 must be close enough so that x1 has a few common digits with x0 after at most 5 iterations.
NewtonNum(_func, _x'init, _prec0, _order) <--
[
	Check(prec0>=4, "Argument", "NewtonNum: Error: initial precision must be at least 4");
	Check(IsInteger(order) And order>1, "Argument", "NewtonNum: Error: convergence order must be an integer and at least 2");
	Local(x0, x1, prec, exact'digits, int'part, initial'tries);
  N([
    x0 := x'init;
    prec := BuiltinPrecisionGet();
    int'part := IntLog(Ceil(Abs(x0)), 10);	// how many extra digits for numbers like 100.2223
    // int'part must be set to 0 if we have true floating-point semantics of BuiltinPrecisionSet()
    BuiltinPrecisionSet(2+prec0-int'part);	// 2 guard digits
    x1 := (func @ x0);	// let's run one more iteration by hand
    // first, we get prec0 exact digits
    exact'digits := 0;
    initial'tries := 5;	// stop the loop the the initial value is not good
    While(exact'digits*order < prec0 And initial'tries>0)
    [
      initial'tries--;
      x0 := x1;
      x1 := (func @ x0);
      exact'digits := Common'digits(x0, x1);
  //		If(InVerboseMode(), Echo("NewtonNum: Info: got", exact'digits, "exact digits at prec. ", BuiltinPrecisionGet()));
    ];
    // need to check that the initial precision is achieved
    If(
      Assert("value", {"NewtonNum: Error: need a more accurate initial value than", x'init})
        exact'digits >= 1,
    [
    exact'digits :=Minimum(exact'digits, prec0+2);
    // run until get prec/order exact digits
    int'part := IntLog(Ceil(Abs(x1)), 10);	// how many extra digits for numbers like 100.2223
    While(exact'digits*order <= prec)
    [
      exact'digits := exact'digits*order;
      BuiltinPrecisionSet(2+Minimum(exact'digits, Quotient(prec,order)+1)-int'part);
      x0 := x1;
      x1 := (func @ x0);
  //		If(InVerboseMode(), Echo("NewtonNum: Info: got", Common'digits(x0, x1), "exact digits at prec. ", BuiltinPrecisionGet()));
    ];
    // last iteration by hand
    BuiltinPrecisionSet(2+prec);
    x1 := RoundTo( (func @ x1), prec);
    ],
    // did not get a good initial value, so return what we were given
    x1 := x'init
    );
    BuiltinPrecisionSet(prec);
  ]);
	x1;
];


/*
example: logarithm function using cubically convergent Newton iteration for
Exp(x/2)-a*Exp(-x/2)=0:

x' := x - 2 * (Exp(x)-a) / (Exp(x)+a)

LN(x_IsNumber)_(x>1 ) <--
	LocalSymbols(y)
[
// initial guess is obtained as Ln(x^2)/Ln(2) * (Ln(2)/2)
	NewtonNum({{y},4*x/(Exp(y)+x)-2+y}, N(794/2291*IntLog(Floor(x*x),2),5), 10, 3);
];
*/

%/mathpiper



%mathpiper_docs,name="NewtonNum",categories="User Functions;Solvers (Numeric)
*CMD NewtonNum --- low-level optimized Newton's iterations
*STD
*CALL
	NewtonNum(func, x0, prec0, order)
	NewtonNum(func, x0, prec0)
	NewtonNum(func, x0)

*PARMS

{func} -- a function specifying the iteration sequence

{x0} -- initial value (must be close enough to the root)

{prec0} -- initial precision (at least 4, default 5)

{order} -- convergence order (typically 2 or 3, default 2)

*DESC

This function is an optimized interface for computing Newton's
iteration sequences for numerical solution of equations in arbitrary precision.

{NewtonNum} will iterate the given function starting from the initial
value, until the sequence converges within current precision.
Initially, up to 5 iterations at the initial precision {prec0} is
performed (the low precision is set for speed). The initial value {x0}
must be close enough to the root so that the initial iterations
converge. If the sequence does not produce even a single correct digit
of the root after these initial iterations, an error message is
printed. The default value of the initial precision is 5.

The {order} parameter should give the convergence order of the scheme.
Normally, Newton iteration converges quadratically (so the default
value is {order}=2) but some schemes converge faster and you can speed
up this function by specifying the correct order. (Caution: if you give
{order}=3 but the sequence is actually quadratic, the result will be
silently incorrect. It is safe to use {order}=2.)

*REM
The verbose option {V} can be used to monitor the convergence. The
achieved exact digits should roughly form a geometric progression.

*E.G.
In> BuiltinPrecisionSet(20)
Result: True;
In> NewtonNum({{x}, x+Sin(x)}, 3, 5, 3)
Result: 3.14159265358979323846;

*SEE Newton
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/SumTaylorNum.mpw0000644000175000017500000002175011522212340032441 0ustar  giovannigiovanni%mathpiper,def="SumTaylorNum"

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: Taylor series, rectangular summation
//////////////////////////////////////////////////

/// Fast summation of Taylor series using a rectangular scheme.
/// SumTaylorNum(x, nth'term'func, n'terms) = Sum(k, 0, n'terms, nth'term'func(k)*x^k)
/// Note that sufficient precision must be preset to avoid roundoff errors (these methods do not modify precision).
/// The only reason to try making these functions HoldArgument is to make sure that the closures nth'term'func and next'term'factor are passed intact. But it's probably not desired in most cases because a closure might contain parameters that should be evaluated.

/// The short form is used when only the nth term is known but no simple relation between a term and the next term.
/// The long form is used when there is a simple relation between consecutive terms. In that case, the n'th term function is not needed, only the 0th term value.

/// SumTaylorNum0 is summing the terms with direct methods (Horner's scheme or simple summation). SumTaylorNum1 is for the rectangular method.

/// nth'term'func and next'term'func must be functions applicable to one argument.

/// interface
SumTaylorNum0(_x, _nth'term'func, _n'terms) <-- SumTaylorNum0(x, nth'term'func, {}, n'terms);

SumTaylorNum1(_x, _nth'term'func, _n'terms) <-- SumTaylorNum1(x, nth'term'func, {}, n'terms);

/// interface
SumTaylorNum(_x, _nth'term'func, _n'terms) <--
If(
	n'terms >= 30,	// threshold for calculation with next'term'factor
	// use the rectangular algorithm for large enough number of terms
	SumTaylorNum1(x, nth'term'func, n'terms),
	SumTaylorNum0(x, nth'term'func, n'terms)
);

SumTaylorNum(_x, _nth'term'func, _next'term'factor, _n'terms) <--
If(
	n'terms >= 5,	// threshold for calculation with next'term'factor
	SumTaylorNum1(x, nth'term'func, next'term'factor, n'terms),
	SumTaylorNum0(x, nth'term'func, next'term'factor, n'terms)
);
//HoldArgumentNumber(SumTaylorNum, 3, 2);

/// straightforward algorithms for a small number of terms
1# SumTaylorNum0(_x, _nth'term'func, {}, _n'terms) <--
[
	Local(sum, k);
  N([
    // use Horner scheme starting from the last term
    x:=Eval(x);
    sum := 0;
    For(k:=n'terms, k>=0, k--)
      sum := AddN(sum*x, nth'term'func @ k);
  ]);
	sum;
];

//HoldArgumentNumber(SumTaylorNum0, 3, 2);

2# SumTaylorNum0(_x, _nth'term'func, _next'term'factor, _n'terms) <--
[
	Local(sum, k, term, delta);
  N([
    x:=Eval(x);	// x must be floating-point
    If (IsConstant(nth'term'func),
      term := nth'term'func,
      term := (nth'term'func @ {0}),
    );
    sum := term;	// sum must be floating-point
  ]);
  NonN([
    delta := 1;
    For(k:=1, k<=n'terms And delta != 0, k++)
    [
      term := MultiplyNum(term, next'term'factor @ {k}, x);	// want to keep exact fractions here, but the result is floating-point
      delta := sum;
      sum := sum + term;	// term must be floating-point
      delta := Abs(sum-delta);	// check for underflow
    ];
  ]);
	sum;
];

/// interface
SumTaylorNum0(_x, _nth'term'func, _n'terms) <-- SumTaylorNum0(x, nth'term'func, {}, n'terms);

//HoldArgumentNumber(SumTaylorNum0, 4, 2);
//HoldArgumentNumber(SumTaylorNum0, 4, 3);

/// this is to be used when a simple relation between a term and the next term is known.
/// next'term'factor must be a function applicable to one argument, so that if term = nth'term'func(k-1), then nth'term'func(k) = term / next'term'factor(k). (This is optimized for Taylor series of elementary functions.) In this case, nth'term'func is either a number, value of the 0th term, or a function.
/// A special case: when next'term'factor is an empty list; then we act as if there is no next'term'factor available.
/// In this case, nth'term'func must be a function applicable to one argument.
/// Need IntLog(n'terms, 10) + 1 guard digits due to accumulated roundoff error.
SumTaylorNum1(x, nth'term'func, next'term'factor, n'terms) :=
[
	// need Sqrt(n'terms/2) units of storage (rows) and Sqrt(n'terms*2) columns. Let's underestimate the storage.
	Local(sum, rows, cols, rows'tmp, last'power, i, j, x'power, term'tmp);
  N([ // want to keep exact fractions
    x:=Eval(x);	// x must be floating-point
    rows := IntNthRoot(n'terms+1, 2);
    cols := Quotient(n'terms+rows, rows);	// now: rows*cols >= n'terms+1
    Check(rows>1 And cols>1, "Argument", "SumTaylorNum1: Internal error: number of Taylor sum terms must be at least 4");
    rows'tmp := ArrayCreate(rows, 0);
    x'power := x ^ rows;	// do not use PowerN b/c x might be complex
    // initialize partial sums (array rows'tmp) - the 0th column (i:=0)
    // prepare term'tmp for the first element
    // if we are using next'term'factor, then term'tmp is x^(rows*i)*a[rows*i]
    // if we are not using it, then term'tmp is x^(rows*i)
    If(
      next'term'factor = {},
      term'tmp := 1,
  //		term'tmp := (nth'term'func @ 0)	// floating-point
      If (IsConstant(nth'term'func),
        term'tmp := nth'term'func,
        term'tmp := (nth'term'func @ {0}),
      )
    );
  ]);
  NonN([ // want to keep exact fractions below
    // do horizontal summation using term'tmp to get the first element
    For(i:=0, i0, j--)
      sum := sum*x + rows'tmp[j];
  ]);
	sum;
];

//HoldArgumentNumber(SumTaylorNum, 4, 2);
//HoldArgumentNumber(SumTaylorNum, 4, 3);

/*
Examples:
In> SumTaylorNum(1,{{k}, 1/k!},{{k}, 1/k}, 10 )
Result: 2.7182818006;
In> SumTaylorNum(1,{{k},1/k!}, 10 )
Result: 2.7182818007;
*/

%/mathpiper



%mathpiper_docs,name="SumTaylorNum",categories="User Functions;Series"
*CMD SumTaylorNum --- optimized numerical evaluation of Taylor series
*STD
*CALL
	SumTaylorNum(x, NthTerm, order)
	SumTaylorNum(x, NthTerm, TermFactor, order)
	SumTaylorNum(x, ZerothTerm, TermFactor, order)

*PARMS

{NthTerm} -- a function specifying $n$-th coefficient of the series

{ZerothTerm} -- value of the $0$-th coefficient of the series

{x} -- number, value of the expansion variable

{TermFactor} -- a function specifying the ratio of $n$-th term to the previous one

{order} -- power of $x$ in the last term

*DESC

{SumTaylorNum} computes a Taylor series $Sum(k,0,n,a[k]*x^k)$
numerically. This function allows very efficient computations of
functions given by Taylor series, although some tweaking of the
parameters is required for good results.

The coefficients $a[k]$ of the Taylor series are given as functions of one integer variable ($k$). It is convenient to pass them to {SumTaylorNum} as closures.
For example, if a function {a(k)} is defined, then
	SumTaylorNum(x, {{k}, a(k)}, n)
computes the series $Sum(k, 0, n, a(k)*x^k)$.

Often a simple relation between successive coefficients $a[k-1]$,
$a[k]$ of the series is available; usually they are related by a
rational factor. In this case, the second form of {SumTaylorNum} should
be used because it will compute the series faster. The function
{TermFactor} applied to an integer $k>=1$ must return the ratio
$a[k]$/$a[k-1]$. (If possible, the function {TermFactor} should return
a rational number and not a floating-point number.) The function
{NthTerm} may also be given, but the current implementation only calls
{NthTerm(0)} and obtains all other coefficients by using {TermFactor}.
Instead of the function {NthTerm}, a number giving the $0$-th term can be given.

The algorithm is described elsewhere in the documentation.
The number of terms {order}+1
must be specified and a sufficiently high precision must be preset in
advance to achieve the desired accuracy.
(The function {SumTaylorNum} does not change the current precision.)

*E.G.
To compute 20 digits of $Exp(1)$ using the Taylor series, one needs 21
digits of working precision and 21 terms of the series. 

In> BuiltinPrecisionSet(21)
Result: True;
In> SumTaylorNum(1, {{k},1/k!}, 21)
Result: 2.718281828459045235351;
In> SumTaylorNum(1, 1, {{k},1/k}, 21)
Result: 2.71828182845904523535;
In> SumTaylorNum(1, {{k},1/k!}, {{k},1/k}, 21)
Result: 2.71828182845904523535;
In> RoundTo(N(Ln(%)),20)
Result: 1;


*SEE Taylor
%/mathpiper_docs././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/ArithmeticGeometricMean.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/ArithmeticGeometricMean0000644000175000017500000000317011522455207033760 0ustar  giovannigiovanni%mathpiper,def="ArithmeticGeometricMean"

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: AGM sequence
//////////////////////////////////////////////////

/// compute the AGM sequence up to a given precision
ArithmeticGeometricMean(a, b, eps) :=
[
    Check(IsPositiveReal(a) And IsPositiveReal(b), "Argument", "The first two arguments must be positive real numbers.");
    
    Check(IsPositiveInteger(eps), "Argument", "The precision argument must be a positive integer.");
    
    a := N(a, eps);
    
    b := N(b, eps);
    
	Local(a1, b1);
	
	If(InVerboseMode(), Echo("ArithmeticGeometricMean: Info: at prec. ", BuiltinPrecisionGet()));
	
	// AGM main loop
	While(Abs(a-b)>=eps)
	[
		a1 := DivideN(a+b, 2);
		b1 := SqrtN(MultiplyN(a, b));	// avoid Sqrt() which uses N() inside it
		a := a1;
		b := b1;
	];
	
	DivideN(a+b, 2);
];
//UnFence(ArithmeticGeometricMean, 3);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ArithmeticGeometricMean",categories="User Functions;Special Functions"
*CMD ArithmeticGeometricMean --- calculate the arithmetic geometric mean of two positive real numbers
*CALL
	ArithmeticGeometricMean(a,b,precision)

*PARMS
{a} -- a positive real number
{b} -- a positive real number
{precision} -- a positive integer which specifies the precision to use during the calculation

*DESC
Computes the arithmetic geometric mean of two positive real numbers.

*E.G.
In> ArithmeticGeometricMean(6,24,10)
Result: 13.5

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/IntPowerNum.mpw0000644000175000017500000000422411522212340032246 0ustar  giovannigiovanni%mathpiper,def="IntPowerNum"

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: integer powers by binary reduction
//////////////////////////////////////////////////

/// generalized integer Power function using the classic binary method.
5 # IntPowerNum(_x, 0, _func, _unity) <-- unity;
10 # IntPowerNum(_x, n_IsInteger, _func, _unity) <--
[
	// use binary method
	Local(result);
	// unity might be of non-scalar type, avoid assignment
	While(n > 0)
	[
		If(
			(n&1) = 1,
			If(
				IsBound(result), // if result is already assigned
				result := Apply(func, {result,x}),
				result := x, // avoid multiplication
			)
		);
		x := Apply(func, {x,x});
		n := n>>1;
	];
	result;
];

%/mathpiper



%mathpiper_docs,name="IntPowerNum",categories="User Functions;Numbers (Operations)"
*CMD IntPowerNum --- optimized computation of integer powers
*STD
*CALL
	IntPowerNum(x, n, mult, unity)

*PARMS

{x} -- a number or an expression

{n} -- a non-negative integer (power to raise {x} to)

{mult} -- a function that performs one multiplication

{unity} -- value of the unity with respect to that multiplication

*DESC

{IntPowerNum} computes the power $x^n$ using the fast binary algorithm.
It can compute integer powers with $n>=0$ in any ring where multiplication with unity is defined.
The multiplication function and the unity element must be specified.
The number of multiplications is no more than $2*Ln(n)/Ln(2)$.

Mathematically, this function is a generalization of {MathPower} to rings other than that of real numbers.

In the current implementation, the {unity} argument is only used when the given power {n} is zero.

*E.G.

For efficient numerical calculations, the {MathMultiply} function can be passed:
In> IntPowerNum(3, 3, MathMultiply,1)
Result: 27;
	
Otherwise, the usual {*} operator suffices:
In> IntPowerNum(3+4*I, 3, *,1)
Result: Complex(-117,44);
In> IntPowerNum(HilbertMatrix(2), 4, *, Identity(2))
Result: {{289/144,29/27},{29/27,745/1296}};

Compute $Modulo(3^100,7)$:
In> IntPowerNum(3,100,{{x,y},Modulo(x*y,7)},1)
Result: 4;

*SEE MultiplyNum, PowerN, MatrixPower
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/MultiplyNum.mpw0000644000175000017500000000617211522212340032322 0ustar  giovannigiovanni%mathpiper,def="MultiplyNum"

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: multiply floats by rationals
//////////////////////////////////////////////////

/// aux function: optimized numerical multiplication. Use MultiplyN() and DivideN().
/// optimization consists of multiplying or dividing by integers if one of the arguments is a rational number. This is presumably always better than floating-point calculations, except if we use Rationalize() on everything.
/// note that currently this is not a big optimization b/c of slow arithmetic but it already helps for rational numbers under InNumericMode() returns True and it will help even more when faster math is done

Function() MultiplyNum(x, y, ...);
Function() MultiplyNum(x);

10 # MultiplyNum(x_IsList)_(Length(x)>1) <-- MultiplyNum(First(x), Rest(x));

10 # MultiplyNum(x_IsRational, y_IsRationalOrNumber) <--
[
	If(
        Type(y) = "/",  // IsRational(y), changed by Nobbi before redefinition of IsRational
		DivideN(Numerator(x)*Numerator(y), Denominator(x)*Denominator(y)),
		// y is floating-point
		// avoid multiplication or division by 1
		If(
			Numerator(x)=1,
			DivideN(y, Denominator(x)),
			If(
				Denominator(x)=1,
				MultiplyN(y, Numerator(x)),
				DivideN(MultiplyN(y, Numerator(x)), Denominator(x))
			)
		)
	);
];

20 # MultiplyNum(x_IsNumber, y_IsRational) <-- MultiplyNum(y, x);

25 # MultiplyNum(x_IsNumber, y_IsNumber) <-- MultiplyN(x,y);

30 # MultiplyNum(Complex(r_IsNumber, i_IsNumber), y_IsRationalOrNumber) <-- Complex(MultiplyNum(r, y), MultiplyNum(i, y));

35 # MultiplyNum(y_IsNumber, Complex(r_IsNumber, i_IsRationalOrNumber)) <-- MultiplyNum(Complex(r, i), y);

40 # MultiplyNum(Complex(r1_IsNumber, i1_IsNumber), Complex(r2_IsNumber, i2_IsNumber)) <-- Complex(MultiplyNum(r1,r2)-MultiplyNum(i1,i2), MultiplyNum(r1,i2)+MultiplyNum(i1,r2));

/// more than 2 operands
30 # MultiplyNum(x_IsRationalOrNumber, y_IsNumericList)_(Length(y)>1) <-- MultiplyNum(MultiplyNum(x, First(y)), Rest(y));
40 # MultiplyNum(x_IsRationalOrNumber, y_IsNumericList)_(Length(y)=1) <-- MultiplyNum(x, First(y));

%/mathpiper



%mathpiper_docs,name="MultiplyNum",categories="User Functions;Numbers (Operations)"
*CMD MultiplyNum --- optimized numerical multiplication
*STD
*CALL
	MultiplyNum(x,y)
	MultiplyNum(x,y,z,...)
	MultiplyNum({x,y,z,...})

*PARMS

{x}, {y}, {z} -- integer, rational or floating-point numbers to multiply

*DESC
The function {MultiplyNum} is used to speed up multiplication of floating-point numbers with rational numbers. 
Suppose we need to compute $(p/q)*x$ where $p$, $q$ are integers and $x$ is a floating-point number. 
At high precision, it is faster to multiply $x$ by an integer $p$ and divide by an integer $q$ than to 
compute $p/q$ to high precision and then multiply by $x$. The function  {MultiplyNum} performs this optimization.

The function accepts any number of arguments (not less than two) or a list of numbers. The result is always 
a floating-point number (even if {InNumericMode()} returns False).

*E.G.
In> MultiplyNum(1.2, 1/2)
Result: 0.6

*SEE MultiplyN
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/nummethods/binsplit.mpw0000644000175000017500000001057311523200452031651 0ustar  giovannigiovanni%mathpiper,def="BinSplitNum;BinSplitData;BinSplitFinal"

/*
def file definitions
BinSplitNum
BinSplitData
BinSplitFinal
*/

/// coded by Serge Winitzki. See essays documentation for algorithms.

//////////////////////////////////////////////////
/// Numerical method: binary splitting technique for simple series
//////////////////////////////////////////////////

/// Binary splitting for series of the form
/// S(m,n) = Sum(k,m,n, a(k)/b(k)*(p(0)*...*p(k))/(q(0)*...*q(k)))


/// High-level interface routine
BinSplitNum(m,n,a,b,p,q) := BinSplitFinal(BinSplitData(m,n,a,b,p,q));

/// Low-level routine: compute the floating-point answer from P, Q, B, T data
BinSplitFinal({_P,_Q,_B,_T}) <-- DivideN(T, MultiplyN(B, Q));

/// Low-level routine: combine two binary-split intermediate results
BinSplitCombine({_P1, _Q1, _B1, _T1}, {_P2, _Q2, _B2, _T2}) <-- {P1*P2, Q1*Q2, B1*B2, B1*P1*T2+B2*Q2*T1};

/// Low-level routine: compute the list of four integers P, Q, B, T. (T=BQS)
/// Input: m, n and four functions a,b,p,q of one integer argument.

// base of recursion
10 # BinSplitData(_m, _n, _a, _b, _p, _q)_(m>n) <-- {1,1,1,0};

10 # BinSplitData(_m, _n, _a, _b, _p, _q)_(m=n) <-- {p@m, q@m, b@m, (a@m)*(p@m)};

10 # BinSplitData(_m, _n, _a, _b, _p, _q)_(m+1=n) <-- {(p@m)*(p@n), (q@m)*(q@n), (b@m)*(b@n), (p@m)*((a@m)*(b@n)*(q@n)+(a@n)*(b@m)*(p@n))};

// could implement some more cases of recursion base, to improve speed

// main recursion step
20 # BinSplitData(_m, _n, _a, _b, _p, _q) <--
[
	BinSplitCombine(BinSplitData(m,(m+n)>>1, a,b,p,q), BinSplitData(1+((m+n)>>1),n, a,b,p,q));
];


%/mathpiper



%mathpiper_docs,name="BinSplitNum;BinSplitData;BinSplitFinal",categories="User Functions;Series"
*CMD BinSplitNum --- computations of series by the binary splitting method
*CMD BinSplitData --- computations of series by the binary splitting method
*CMD BinSplitFinal --- computations of series by the binary splitting method
*STD
*CALL
	BinSplitNum(n1, n2, a, b, c, d)
	BinSplitData(n1,n2, a, b, c, d)
	BinSplitFinal({P,Q,B,T})

*PARMS

{n1}, {n2} -- integers, initial and final indices for summation

{a}, {b}, {c}, {d} -- functions of one argument, coefficients of the series

{P}, {Q}, {B}, {T} -- numbers, intermediate data as returned by {BinSplitData}

*DESC

The binary splitting method is an efficient way to evaluate many series when fast multiplication is available and when the series contains only rational numbers.
The function {BinSplitNum} evaluates a series of the form
$$ S(n[1],n[2])=Sum(k,n[1],n[2], a(k)/b(k)*(p(0)/q(0)) * ... * p(k)/q(k)) $$.
Most series for elementary and special functions at rational points are of this form when the functions $a(k)$, $b(k)$, $p(k)$, $q(k)$ are chosen appropriately.

The last four arguments of {BinSplitNum} are functions of one argument that give the coefficients $a(k)$, $b(k)$, $p(k)$, $q(k)$.
In most cases these will be short integers that are simple to determine.
The binary splitting method will work also for non-integer coefficients, but the calculation will take much longer in that case.

Note: the binary splitting method outperforms the straightforward summation only if the multiplication of integers is faster than quadratic in the number of digits.
See <*the algorithm documentation|mathpiperdoc://Algo/3/14/*> for more information.

The two other functions are low-level functions that allow a finer control over the calculation.
The use of the low-level routines allows checkpointing or parallelization of a binary splitting calculation.

The binary splitting method recursively reduces the calculation of $S(n[1],n[2])$ to the same calculation for the two halves of the interval [$n[1]$, $n[2]$].
The intermediate results of a binary splitting calculation are returned by {BinSplitData} and consist of four integers $P$, $Q$, $B$, $T$.
These four integers are converted into the final answer $S$ by the routine {BinSplitFinal} using the relation
$$ S = T / (B*Q) $$.

*E.G.

Compute the series for $e=Exp(1)$ using binary splitting.
(We start from $n=1$ to simplify the coefficient functions.)
In> BuiltinPrecisionSet(21)
Result: True;
In>  BinSplitNum(1,21, {{k},1},
	  {{k},1},{{k},1},{{k},k})
Result: 1.718281828459045235359;
In> N(Exp(1)-1)
Result: 1.71828182845904523536;
In>  BinSplitData(1,21, {{k},1},
	  {{k},1},{{k},1},{{k},k})
Result: {1,51090942171709440000,1,
	  87788637532500240022};
In> BinSplitFinal(%)
Result: 1.718281828459045235359;

*SEE SumTaylorNum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/Cos.mpw0000644000175000017500000000507611523200452026370 0ustar  giovannigiovanni%mathpiper,def="Cos"

1 # CosMap( _n )_(Not(IsRationalOrNumber(n))) <-- ListToFunction({ToAtom("Cos"),n*Pi});
2 # CosMap( _n )_(n<0) <-- CosMap(-n);
2 # CosMap( _n )_(n>2) <-- CosMap(Modulo(n,2));
3 # CosMap( _n )_(n>1) <-- CosMap(2-n);
4 # CosMap( _n )_(n>1/2) <-- -CosMap(1-n);

5 # CosMap( 0 ) <-- 1;
5 # CosMap( 1/6 ) <-- Sqrt(3)/2;
5 # CosMap( 1/4 ) <-- Sqrt(2)/2;
5 # CosMap( 1/3 ) <-- 1/2;
5 # CosMap( 1/2 ) <-- 0;
5 # CosMap( 2/5 ) <-- (Sqrt(5)-1)/4;

10 # CosMap(_n) <-- ListToFunction({ToAtom("Cos"),n*Pi});



2 # Cos(x_IsNumber)_InNumericMode() <-- CosNum(x);
4 # Cos(ArcCos(_x))           <-- x;
4 # Cos(ArcSin(_x)) <-- Sqrt(1-x^2);
4 # Cos(ArcTan(_x)) <-- 1/Sqrt(1+x^2);
5 # Cos(- _x)_(Not IsConstant(x))                 <-- Cos(x);
6 # (Cos(x_IsConstant))_(IsNegativeNumber(N(Eval(x))))   <-- Cos(-x);
// must prevent it from looping

110 # Cos(Complex(_r,_i)) <--
    (Exp(I*Complex(r,i)) + Exp(- I*Complex(r,i))) / (2) ;

6 # Cos(x_IsInfinity) <-- Undefined;
6 # Cos(Undefined) <-- Undefined;

200 # Cos(v_CanBeUni(Pi))_(Not(InNumericMode()) And Degree(v,Pi) < 2 And Coef(v,Pi,0) = 0) <--
      CosMap(Coef(v,Pi,1));

400 # Cos(x_IsRationalOrNumber) <--
    [
     Local(ll);
     ll:= FloorN(N(Eval(x/Pi)));
     If(IsEven(ll),x:=(x - Pi*ll),x:=(-x + Pi*(ll+1)));
     ListToFunction({Cos,x});
     ];

400 # Cos(x_IsRationalOrNumber) <--
    [
     Local(ll);
     ll:= FloorN(N(Eval(Abs(x)/Pi)));
     If(IsEven(ll),x:=(Abs(x) - Pi*ll),x:=(-Abs(x) + Pi*(ll+1)));
     ListToFunction({Cos,x});
     ];

100 # Cos(_x)*Tan(_x) <-- Sin(x);
100 # Cos(_x)/Sin(_x) <-- (1/Tan(x));

Cos(xlist_IsList) <-- MapSingle("Cos",xlist);


%/mathpiper



%mathpiper_docs,name="Cos",categories="User Functions;Trigonometry (Symbolic)"
*CMD Cos --- trigonometric cosine function
*STD
*CALL
	Cos(x)

*PARMS

{x} -- argument to the function, in radians

*DESC

This function represents the trigonometric function cosine. MathPiper leaves 
expressions alone even if x is a number, trying to keep the result as 
exact as possible. The floating point approximations of these functions 
can be forced by using the {N} function.

MathPiper knows some trigonometric identities, so it can simplify to exact
results even if {N} is not used. This is the case, for instance,
when the argument is a multiple of $Pi$/6 or $Pi$/4.

These functions are threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Cos(1)
Result: Cos(1);
In> N(Cos(1),20)
Result: 0.5403023058681397174;
In> Cos(Pi/4)
Result: Sqrt(1/2);

*SEE Sin, Tan, ArcSin, ArcCos, ArcTan, N, Pi
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/0000755000175000017500000000000011722677327027114 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ArcCoshN.mpw0000644000175000017500000000221611523200452031256 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpiper






%mathpiper_docs,name="ArcCoshN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD ArcCoshN --- inverse hyperbolic cosine (arbitrary-precision math function)
*CALL
	ArcCoshN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/MathBitCount.mpw0000644000175000017500000000234111371733712032171 0ustar  giovannigiovanni%mathpiper,def="MathBitCount"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

///  MathBitCount: count number of bits in an integer or a float number.
/*  MathBitCount is now implemented through BigNumber::BitCount() */
/*  so this stays here as a reference implementation */
10 # MathBitCount(0) <-- 1;
20 # MathBitCount(_x) _ (x<0) <-- MathBitCount(-x);

30 # MathBitCount(_value) <--
[
	Local(nbits);
	nbits:=0;
  	If(value<1,
	[	// float value < 1, need to multiply by 2
		nbits := 1;
		While(value<1)
		[
			nbits--;
			value := MathMul2Exp(value,1);
		];
	],
	[	// need to divide by 2
		While(value>=1)
		[
			nbits++;
			value := MathMul2Exp(value, -1);
		];
	]);
	nbits;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/BisectSqrt.mpw0000644000175000017500000000357411316304766031726 0ustar  giovannigiovanni%mathpiper,def="BisectSqrt"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

//{BisectSqrt(N)} computes the integer part of $ Sqrt(N) $ for integer $N$.
// BisectSqrt() works only on integers
	//sqrt(1) = 1, sqrt(0) = 0
10 # BisectSqrt(0) <-- 0;
10 # BisectSqrt(1) <-- 1;

20 # BisectSqrt(N_IsPositiveInteger) <--
[
  Local(l2,u,v,u2,v2,uv2,n);

  // Find highest set bit, l2
  u  := N;
  l2 := MathBitCount(u)-1;

  // 1<<(l2/2) now would be a good under estimate
  // for the square root. 1<<(l2/2) is definitely
  // set in the result. Also it is the highest
  // set bit.
  l2 := l2>>1;

  // initialize u and u2 (u2==u^2).
  u  := 1 << l2;
  u2 := u << l2;

  // Now for each lower bit:
  While( l2 != 0 )
  [
 	 l2--;
     // Get that bit in v, and v2 == v^2.
      v  := 1<must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/MathPi.mpw0000644000175000017500000000540711371733712031020 0ustar  giovannigiovanni%mathpiper,def=""

//todo:tk:this MathPI cannot be in a def file because it conflicts with the MathPI in base.rep/elemfunctions.

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// The constant Pi. Using a simple method, solve Cos(x)=0.
// iterate x := x + Cos(x) + 1/6 *Cos(x)^3 + ... to converge to x=Pi/2
MathPi() :=
[
	Local(result, delta, deltasq, k, order, prec, curprec);
	order := 13;	// order of approximation
	prec := BuiltinPrecisionGet();
  N([
    /* initial approximation */
    curprec := 20;
    BuiltinPrecisionSet(curprec);
    result := 3.14159265358979323846*0.5;
    // find optimal initial precision
    For(k:=prec, k>=curprec, k:=Quotient(k,order)+2) True;
    If(k<5, curprec:=5, curprec:=k);
  //	Echo("initial precision", curprec);
    // now k is the iteration counter
    For(k:=0, curprec < prec, k := k+1) [
    // at this iteration we know the result to curprec digits
      curprec := Minimum(prec, curprec * order-2);	// 2 guard digits
      BuiltinPrecisionSet(curprec+2);
  //		Echo("Iteration ", k, " setting precision to ", BuiltinPrecisionGet());
  //		Echo("old result=", CosN(result));
      /*EchoTime()*/[
      delta := CosN(result);
      ];
      /*EchoTime()*/[
      deltasq := MultiplyN(delta,delta);
      ];
      result := /*EchoTime()*/result + delta*(1 + deltasq*(1/6 + deltasq*(3/40 + deltasq*(5/112 + deltasq*(35/1152 + (deltasq*63)/2816)))));
    ];
  //	Echo({"Method 3, using Pi/2 and order", order, ":", k, "iterations"});
  ]);
	result*2;
];

%/mathpiper







%mathpiper_docs,name="MathPi",categories="User Functions;Numeric",access="experimental"
*CMD MathPi --- The constant Pi.
*CALL
	MathPi()

*DESC

The constant Pi. Using a simple method, solve Cos(x)=0.
iterate x := x + Cos(x) + 1/6 *Cos(x)^3 + ... to converge to x=Pi/2

It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.

If a better optimized version of this function is available through the kernel,
then the kernel version will automatically shadow this function.
This implementation is not necessarily the best optimized version.


%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/MathLn'Doubling.mpw0000644000175000017500000000160111371733712032544 0ustar  giovannigiovanni%mathpiper,def="MathLn'Doubling"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Compute Ln(x) from Ln(x^(2^(1/n)))
MathLn'Doubling(value, n) :=
[
	Local(shift, result);
	shift := n;
	result := value;
	While (shift>0)	// lose 'shift' bits of precision here
	[
		result := MultiplyN(result, result);
		shift--;
	];
	result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ArcTanN'Taylor.mpw0000644000175000017500000000176011320777262032366 0ustar  giovannigiovanni%mathpiper,def="ArcTanN'Taylor"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// ArcTan(x), Taylor series for ArcTan(x)/x, use only with -1/2must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ArcTanN.mpw0000644000175000017500000000220611523200452031103 0ustar  giovannigiovanni%mathpiper,def="ArcTanN"

ArcTanN(x) :=
[
    FastArcTan(x);
];

%/mathpiper





%mathpiper_docs,name="ArcTanN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD ArcTanN --- inverse tangent (arbitrary-precision math function)
*CALL
	ArcTanN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/MathSqrtFloat.mpw0000644000175000017500000000637211371733712032371 0ustar  giovannigiovanni%mathpiper,def="MathSqrtFloat"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

// This function is *only* for float and positive A!
// The answer is only obtained at the current precision.
MathSqrtFloat(_A) <--
[
	Local(bitshift, a0, x0, x0sq, targetbits, subtargetbits, gotbits, targetprec);
	bitshift := ShiftRight(MathBitCount(A)-1,1);
	// this is how many bits of precision we need
	targetprec := BuiltinPrecisionGet();
	// argument reduction: a0 is between 1 and 4 and has the full target precision
	a0 := MathMul2Exp(A, -bitshift*2);	// this bit shift would be wrong for integer A
	BuiltinPrecisionSet(10);	// enough to compute at this point
	// cannot get more target bits than 1 + (the bits in A)
	// if this is less than the requested precision, the result will be silently less precise, but c'est la vie
	targetbits := Minimum(DigitsToBits(targetprec, 10), 1+GetExactBitsN(A));
	// initial approximation
	x0 := DivideN(14+22*a0, 31+5*a0);
	// this approximation gives at least 7 bits (relative error < 0.005) of Sqrt(a0) for 1 <= a0 <= 4
	gotbits := 7;
	// find the conditions for the last 2 iterations to be done in almost optimal precision
	subtargetbits := QuotientN(targetbits+8, 9);
	If(gotbits >= subtargetbits, subtargetbits := QuotientN(targetbits+2, 3));
	If(gotbits >= subtargetbits, subtargetbits := targetbits*4);
//	Echo("debug: subtargetbits=", subtargetbits, "a0=", a0, "targetbits=", targetbits, "bitshift=", bitshift, "targetprec=", targetprec);
	// now perform Halley iterations until we get at least subtargetbits, then start with subtargetbits and perform further Halley iterations
	While(gotbits < targetbits)
	[
		gotbits := 3*gotbits+1;	// Halley iteration; get 3n+2 bits, allow 1 bit for roundoff
		// check for suboptimal last iterations
		If(gotbits >= subtargetbits,
		[	// it could be very suboptimal to continue with our value of gotbits, so we curb precision for the last 2 iterations which dominate the calculation time at high precision
			gotbits := subtargetbits;
			subtargetbits := targetbits*4;	// make sure that the above condition never becomes true again
		]);
		BuiltinPrecisionSet(BitsToDigits(gotbits, 10)+2);	// guard digits
		x0 := SetExactBitsN(x0, gotbits+6);	// avoid roundoff
		x0sq := MultiplyN(x0, x0);
// this gives too much roundoff error		x0 := MultiplyN(x0, DivideN(3*a0+x0sq, a0+3*x0sq));
// rather use this equivalent formula:
		x0 := AddN(x0, MultiplyN(x0*2, DivideN(a0-x0sq, a0+3*x0sq)));
//		Echo("debug: ", gotbits, x0, GetExactBitsN(x0), BuiltinPrecisionGet());
	];
	// avoid truncating a precise result in x0 by calling BuiltinPrecisionSet() too soon
	x0 := SetExactBitsN(MathMul2Exp(x0, bitshift), gotbits);
	BuiltinPrecisionSet(targetprec);
//	Echo("debug: answer=", x0);
	x0;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ArcTanhN.mpw0000644000175000017500000000222111523200452031250 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpiper





%mathpiper_docs,name="ArcTanhN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD ArcTanhN --- inverse hyperbolic tangent (arbitrary-precision math function)
*CALL
	ArcTanhN(x)  ()

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/GcdN.mpw0000644000175000017500000000263211316304766030450 0ustar  giovannigiovanni%mathpiper,def=""

/*
todo:tk:this function was accidently shadowed by a built in function when the names of all MathXXX functions
were changed to XXXN.  However, I checked JYacas and GcdN was not used anyplace in the scripts anyway
so the shadowing did not seem to cause any harm.  I am commenting this function out until a reason
can be found to uncomment it.
*/
/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.


/// GcdN(x,y). Compute the GCD of two integers using the binary Euclidean algorithm.
5 # GcdN(x_IsNegativeInteger, y_IsInteger) <-- GcdN(-x, y);
5 # GcdN(y_IsNegativeInteger, x_IsNegativeInteger) <-- GcdN(x, -y);
6 # GcdN(0, _x) <-- 0;
6 # GcdN(_x, 0) <-- 0;

10 # GcdN(x_IsInteger, y_IsInteger) <--
[
	Local(z);
	While(x!=y)
	[
		While(x0)	// lose 'shift' bits of precision here
	[
		result := MultiplyN(MathMul2Exp(result, 1), 2 - result);
		shift--;
	];
	result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/DigitsToBits.mpw0000644000175000017500000000156011316304766032204 0ustar  giovannigiovanni%mathpiper,def="DigitsToBits"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// BitsToDigits(n,base) and DigitsToBits(n,base). Enough to compute at low precision.
// this is now a call to the kernel functions, so leave as a reference implementation
DigitsToBits(n, base) := FloorN(0.51+n*N(Ln(base)/Ln(2),10));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/MathLn'Taylor.mpw0000644000175000017500000000174411371733712032263 0ustar  giovannigiovanni%mathpiper,def="MathLn'Taylor"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Ln(x), Taylor series for Ln(1+y)/y, use only with 1/2must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/CoshN.mpw0000644000175000017500000000217511523200452030634 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpiper






%mathpiper_docs,name="CoshN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD CoshN --- hyperbolic cosine (arbitrary-precision math function)
*CALL
	CoshN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ArcSinN.mpw0000644000175000017500000000304111503731314031114 0ustar  giovannigiovanni%mathpiper,def="ArcSinN"


Defun("ArcSinN",{int1})
[
  Local(result,eps);
	Bind(result,FastArcSin(int1));
  Local(x,q,s,c);
  Bind(q,SubtractN(SinN(result),int1));
  Bind(eps,MathIntPower(10,MathNegate(BuiltinPrecisionGet())));
  While(IsGreaterThan(AbsN(q),eps))
  [
	Bind(s,SubtractN(int1,SinN(result)));
    Bind(c,CosN(result));
    Bind(q,DivideN(s,c));
    Bind(result,AddN(result,q));
  ];
  result;
];

/*
ArcSinN(x) :=
[
    FastArcSin(x);
];*/

%/mathpiper




%mathpiper_docs,name="ArcSinN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD ArcSinN --- inverse sine (arbitrary-precision math function)
*CALL
	ArcSinN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.

In> ArcSinN(.5)
Result> 0.5235987756

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/SinN'Tripling.mpw0000644000175000017500000000173111371733712032261 0ustar  giovannigiovanni%mathpiper,def="SinN'Tripling"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Identity transformation, compute Sin(x) from value=Sin(x/3^n)

SinN'Tripling(value, n) :=
[
	Local(shift, result);
	shift := n;
	result := value;
	While (shift>0)	// lose 'shift' bits of precision here
	[	// Sin(x)*(3-4*Sin(x)^2)
		result := MultiplyN(result, 3 - MathMul2Exp(MultiplyN(result,result), 2) );
		shift--;
	];
	result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/BitsToDigits.mpw0000644000175000017500000000042611316304766032204 0ustar  giovannigiovanni%mathpiper,def="BitsToDigits"

/// BitsToDigits(n,base) and DigitsToBits(n,base). Enough to compute at low precision.
// this is now a call to the kernel functions, so leave as a reference implementation
BitsToDigits(n, base) := FloorN(0.51+n*N(Ln(2)/Ln(base),10));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/SqrtN.mpw0000644000175000017500000000772411523200452030676 0ustar  giovannigiovanni%mathpiper,def="SqrtN"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// SqrtN(x).
SqrtN(x) := MathSqrt1(x);	// to have another function is easier for debugging

/// Compute square root(x) with nonnegative x. FIXME: No precision tracking yet.
10 # MathSqrt1(0) <-- 0;
/// negative or non-numeric arguments give error message
100 # MathSqrt1(_x) <-- [ Echo("SqrtN: invalid argument: ", x); False;];

// this is too slow at the moment
30 # MathSqrt1(x_IsPositiveNumber) <-- x*NewtonNum({{r}, r+r*(1-x*r^2)/2}, FastPower(x,-0.5), 4, 2);

30 # MathSqrt1(x_IsPositiveNumber) <-- MathSqrtFloat(x);

// for integers, we need to compute Sqrt(x) to (the number of bits in x) + 1 bits to figure out whether Sqrt(x) is itself an integer. If Sqrt(x) for integer x is exactly equal to an integer, we should return the integer answer rather than the float answer. For this answer, the current precision might be insufficient, therefore we compute with potentially more digits. This is slower but we assume this is what the user wants when calling SqrtN() on an integer.
20 # MathSqrt1(x_IsInteger) _ (IsGreaterThan(x,0)) <--
[
	Local(result);
	If(ModuloN(x,4)<2 And ModuloN(x,3)<2 And ModuloN(x+1,5)<3,
		// now the number x has a nonzero chance of being an exact square
		[
			// check whether increased precision would be at all necessary
//			Echo("checking integer case");
			GlobalPush(BuiltinPrecisionGet());
			If(MathBitCount(x)+3>DigitsToBits(BuiltinPrecisionGet(), 10),
			  BuiltinPrecisionSet(BitsToDigits(MathBitCount(x), 10)+1));
				// need one more digit to decide whether Sqrt(x) is integer
			// otherwise the current precision is sufficient

			// convert x to float and use the float routine
			result := MathSqrtFloat(x+0.);
			// decide whether result is integer: decrease precision and compare
			If(FloatIsInt(SetExactBitsN(result, GetExactBitsN(result)-3)), result:= Floor(result+0.5));
			BuiltinPrecisionSet(GlobalPop());
		],
		// now the number x cannot be an exact square; current precision is sufficient
		result := MathSqrtFloat(x+0.)
	);
	// need to set the correct precision on the result - will have no effect on integer answers
	SetExactBitsN(result, DigitsToBits(BuiltinPrecisionGet(),10));
];

%/mathpiper





%mathpiper_docs,name="SqrtN",categories="User Functions;Numeric"
*CMD SqrtN --- square root (x must be >= 0) (arbitrary-precision math function)
*CALL
	SqrtN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In> BuiltinPrecisionSet(10)
Result: True
In> Sqrt(10)
Result: Sqrt(10)
In> SqrtN(10)
Result: 3.16227766
In> SqrtN(490000*2^150)
Result: 26445252304070013196697600
In> SqrtN(490000*2^150+1)
Result: 0.264452523e26

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/TanhN.mpw0000644000175000017500000000217711523200452030634 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpiper






%mathpiper_docs,name="TanhN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD TanhN ---  hyperbolic tangent (arbitrary-precision math function)
*CALL
	TanhN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ExpN'Taylor.mpw0000644000175000017500000000216611371733712031751 0ustar  giovannigiovanni%mathpiper,def="ExpN'Taylor"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Compute Exp(x)-1 from the Taylor series for (Exp(x)-1)/x.
//Note:tk:changed name from ExpN'Taylor1 to ExpN'Taylor.
ExpN'Taylor(x) :=
[
	Local(num'terms, prec, Bx);
	prec := QuotientN(BuiltinPrecisionGet()*3919, 1702); // P*Ln(10)
	Bx := -QuotientN(MathBitCount(x)*1143, 1649)-2; // -Ln(x)-2
	num'terms := QuotientN( prec-1, QuotientN( MathBitCount( prec-1)*1588, 2291)+Bx)+1;
	// (P*Ln(10)-1)/(Ln(P*Ln(10)-1)-Ln(x)-2); use Ln(x)<=B(x)*Ln(2)
	x*SumTaylorNum(x, 1, {{k}, 1/(k+1)}, num'terms);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/ExpN'Doubling.mpw0000644000175000017500000000232011371733712032232 0ustar  giovannigiovanni%mathpiper,def="ExpN'Doubling"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Identity transformation, compute Exp(x)-1 from value=Exp(x/2^n)-1

ExpN'Doubling1(value, n) :=
[
	Local(shift, result);
	shift := n;
	result := value;
	While (shift>0)	// lose 'shift' bits of precision here
	[
		result := MathMul2Exp(result, 1) + MultiplyN(result, result);
		shift--;
	];
	result;
];

/// Identity transformation, compute Exp(x) from value=Exp(x/2^n)
/*
ExpN'Doubling(value, n) :=
[
	Local(shift, result);
	shift := n;
	result := value;
	While (shift>0)	// lose 'shift' bits of precision here
	[
		result := MultiplyN(result, result);
		shift--;
	];
	result;
];
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stdfuncs/elemfuncs/SinN'Taylor.mpw0000644000175000017500000000214311371733712031741 0ustar  giovannigiovanni%mathpiper,def="SinN'Taylor"

/** This file contains routines for numerical evaluation of elementary functions:
 *  PowerN, ExpN, SinN etc.
 *  It is assumed that the arguments are real (not complex) floating-point or integer numbers. (The {InNumericMode()} flag does not have to be set.)
 *  The result is an exact integer or a floating-point number correct to BuiltinPrecisionGet() digits.
 *
 *  If a better optimized version of these functions is available through the kernel,
 *  then the kernel version will automatically shadow these functions.
 *  These implementations are not necessarily the best optimized versions.
 */

/// Compute Sin(x), Taylor series for Sin(x)/x
SinN'Taylor(x) :=
[
	Local(num'terms, prec, Bx);
	prec := QuotientN(BuiltinPrecisionGet()*3919, 1702); // P*Ln(10)
	Bx := -QuotientN(MathBitCount(x)*1143, 1649)-2; // -Ln(x)-2
	num'terms := QuotientN( QuotientN( prec+Bx, QuotientN( MathBitCount( prec+Bx)*1588, 2291)+Bx)+1, 2)+1;
	// (P*Ln(10)-Ln(x)-2)/(Ln(P*Ln(10)-Ln(x)-2)-Ln(x)-2); use Ln(x)<=B(x)*Ln(2)
	x*SumTaylorNum(MultiplyN(x,x), 1, {{k}, -1/(2*k*(2*k+1))}, num'terms);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/calendar/0000755000175000017500000000000011722677336025053 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/calendar/Easter.mpw0000644000175000017500000000210011554100732026774 0ustar  giovannigiovanni%mathpiper,def="Easter"

// http://en.wikipedia.org/wiki/Computus#Anonymous_Gregorian_algorithm
Easter(year) := [

    Check(IsPositiveInteger(year), "Argument", "The argument must be a positive integer");

    Local(a,b,c,d,e,f,g,h,i,k,L,m,month,day);

    a := Modulo(year, 19);
    b := Quotient(year, 100);
    c := Modulo(year, 100);
    d := Quotient(b, 4);
    e := Modulo(b, 4);
    f := Quotient(b + 8, 25);
    g := Quotient(b - f + 1, 3);
    h := Modulo(19*a + b - d - g + 15, 30);
    i := Quotient(c, 4);
    k := Modulo(c, 4);
    L := Modulo(32 + 2*e + 2*i - h - k, 7);
    m := Quotient(a + 11*h + 22*L, 451);
    month := Quotient(h + L - 7*m + 114, 31);
    day := Modulo(h + L - 7*m + 114, 31) + 1;

    { month, day };
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Easter",categories="User Functions"
*CMD Easter --- solve an equation
*CALL
	Easter(year)

*PARMS

{year} -- year

*DESC

Calculates the date of Easter in the Gregorian calendar.

*E.G. notest

In> Easter(2011);
Result: {4,24}

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/transforms/0000755000175000017500000000000011722677332025474 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/transforms/laplace/0000755000175000017500000000000011722677332027075 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/transforms/laplace/LaplaceTransform.mpw0000644000175000017500000001010211523200452033031 0ustar  giovannigiovanni%mathpiper,def="LaplaceTransform"

10 # LaplaceTransform(_var1,_var2, _expr )	<-- LapTran(var1,var2,expr);

// Linearity properties
10 # LapTran(_var1,_var2,_x + _y)      		<-- LapTran(var1,var2,x) + LapTran(var1,var2,y);
10 # LapTran(_var1,_var2,_x - _y)		<-- LapTran(var1,var2,x) - LapTran(var1,var2,y);
10 # LapTran(_var1,_var2,    - _y)       	<-- LapTran(var1,var2,y);
10 # LapTran(_var1,_var2, c_IsConstant*_y)	<-- c*LapTran(var1,var2,y);
10 # LapTran(_var1,_var2, _y*c_IsConstant)	<-- c*LapTran(var1,var2,y);
10 # LapTran(_var1,_var2, _y/c_IsConstant) 	<-- LapTran(var1,var2,y)/c;

// Shift properties
10 # LapTran(_var1,_var2, Exp(c_IsConstant*_var1)*_expr  ) <-- LapTran(var1,var2-c,expr);
10 # LapTran(_var1,_var2, Exp(-c_IsConstant*_var1)*_expr ) <-- LapTran(var1,var2+c,expr);
10 # LapTran(_var1,_var2, _expr*Exp(c_IsConstant*_var1)  ) <-- LapTran(var1,var2-c,expr);
10 # LapTran(_var1,_var2, _expr*Exp(-c_IsConstant*_var1) ) <-- LapTran(var1,var2+c,expr);

// Other operational properties
10 # LapTran(_var1,_var2, _expr/_var1 )		<-- Integrate(var2,var2,Infinity) LapTran(var1,var2,expr) ;
10 # LapTran(_var1,_var2, _var1*_expr )		<-- - Deriv(var2) LapTran(var1,var2,expr);
10 # LapTran(_var1,_var2, _var1^(n_IsInteger)*_expr )  <-- (-1)^n * Deriv(var2,n) LapTran(var1,var2,expr);
10 # LapTran(_var1,_var2, _expr*_var1 )                <-- - Deriv(var2) LapTran(var1,var2,expr);
10 # LapTran(_var1,_var2, _expr*_var1^(n_IsInteger)  ) <-- (-1)^n * Deriv(var2,n) LapTran(var1,var2,expr);

// didn't match, return unevaled
100 # LapTran(_var1,_var2, _expr )	<-- `Hold(LaplaceTransform(@var1,@var2,@expr));

LapTranDef(_in,_out) <--
[
  Local(i,o);

  //Echo("50 # LapTran(_t,_s,",in,") <-- ",out,";");
  `(50 # LapTran(_t,_s,@in) <-- @out );

  i:=Subst(_t,c_IsPositiveInteger*_t) in;
  o:=Subst(s,s/c) out;

  //Echo("50 # LapTran(_t,_s,",i,") <-- ",o/c,";");
  `(50 # LapTran(_t,_s,@i ) <-- @o/c );

  i:=Subst(_t,_t/c_IsPositiveInteger) in;
  o:=Subst(s,s*c) out;

  //Echo("50 # LapTran(_t,_s,",i,") <-- ",o/c,";");
  `(50 # LapTran(_t,_s,@i ) <-- @o*c );

];

// transforms of specific functions
LapTranDef( (_t)^(n_IsConstant),	Gamma(n+1)/s^(n+1) );
LapTranDef( _t, 			1/s^2 );
LapTranDef( Sqrt(_t), 			Sqrt(Pi)/(2*s^(3/2)) );
LapTranDef( c_IsFreeOf({t,s}),		c/s );
LapTranDef( Sin(_t),	 		1/(s^2+1) );
LapTranDef( Cos(_t), 			s/(s^2+1) );
LapTranDef( Sinh(_t),			c/(s^2-1) );
LapTranDef( Cosh(_t),			s/(s^2-1) );
LapTranDef( Exp(_t),			1/(s-1) );
LapTranDef( BesselJ(n_IsConstant,_t),	(Sqrt(s^2+1)-s)^n /Sqrt(s^2+1) );
LapTranDef( BesselI(n_IsConstant,_t),	(s-Sqrt(s^2+1))^n /Sqrt(s^2-1) );
LapTranDef( Ln(_t),			-(gamma+Ln(s))/s);
LapTranDef( Ln(_t)^2,			Pi^2/(6*s)+(gamma+Ln(s))/s );
LapTranDef( Erf(_t),			Exp(s^2/4)*Erfc(s/2)/s );
LapTranDef( Erf(Sqrt(_t)),		1/(Sqrt(s+1)*s) );


%/mathpiper



%mathpiper_docs,name="LaplaceTransform",categories="User Functions;Transforms"
*CMD LaplaceTransform --- Laplace Transform
*STD
*CALL
	LaplaceTransform(t,s,func)	
*PARMS

{t} -- independent variable that is being transformed

{s} -- independent variable that is being transformed into

{f} -- function

*DESC

This function attempts to take the function {f(t)} and find the Laplace transform
of it,{F(s)}, which is defined as {Integrate(t,0,Infinity) Exp(-s*t)*f}. This is
also sometimes referred to the "unilateral" Laplace tranform. {LaplaceTransform}
can transform most elementary functions that do not require a convolution integral,
as well as any polynomial times an elementary function. If a transform cannot
be found then {LaplaceTransform} will return unevaluated. This can happen
for function which are not of "exponential order", which means that they grow
faster than exponential functions.


*E.G.

In> LaplaceTransform(t,s,2*t^5+ t^2/2 )
Result: 240/s^6+2/(2*s^3);
In> LaplaceTransform(t,s,t*Sin(2*t)*Exp(-3*t) )
Result: (2*(s+3))/(2*(2*(((s+3)/2)^2+1))^2);
In> LaplaceTransform(t,s, BesselJ(3,2*t) )
Result: (Sqrt((s/2)^2+1)-s/2)^3/(2*Sqrt((s/2)^2+1));
In> LaplaceTransform(t,s,Exp(t^2)); // not of exponential order
Result: LaplaceTransform(t,s,Exp(t^2));
In> LaplaceTransform(p,q,Ln(p))
Result: -(gamma+Ln(q))/q;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/combinatorics/0000755000175000017500000000000011722677334026134 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/combinatorics/PermutationsList.mpw0000644000175000017500000000205411523200452032166 0ustar  giovannigiovanni%mathpiper,def="PermutationsList"

Function("PermutationsList",{result,list})
[
  If(Length(list) = 0,
  [
    result;
  ],
  [
    Local(head);
    Local(newresult);
    Local(i);
    head:=list[1];
    newresult:={};
    ForEach(item,result)
    [
      For(i:=Length(item)+1,i>0,i--)
      [
        DestructiveInsert(newresult,1,Insert(item,i,head));
      ];
    ];
    newresult:=DestructiveReverse(newresult);
    PermutationsList(newresult,Rest(list));
  ]);
];


Function("PermutationsList",{list})
[
  PermutationsList({{}},list);
];

%/mathpiper



%mathpiper_docs,name="PermutationsList",categories="User Functions;Combinatorics"
*CMD PermutationsList --- return all permutations of a list
*STD
*CALL
	PermutationsList(list)

*PARMS

{list} -- a list of elements

*DESC

PermutationsList returns a list which contains all the permutations of
the elements in the original list.

*E.G.

In> PermutationsList({a,b,c})
Result: {{a,b,c},{a,c,b},{c,a,b},{b,a,c},
	{b,c,a},{c,b,a}};

*SEE Permutations, Combinations, CombinationsList, LeviCivita
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/combinatorics/Combinations.mpw0000644000175000017500000000310311523200452031261 0ustar  giovannigiovanni%mathpiper,def="Combinations;BinomialCoefficient"

/* Binomials -- now using partial factorial for speed */
// BinomialCoefficient(n,m) = BinomialCoefficient(n, n-m)
10 # BinomialCoefficient(0,0) 		<-- 1;
10 # BinomialCoefficient(n_IsPositiveInteger,m_IsNonNegativeInteger)_(2*m <= n) <-- ((n-m+1) *** n) / m!;
15 # BinomialCoefficient(n_IsPositiveInteger,m_IsNonNegativeInteger)_(2*m > n And m <= n) <-- BinomialCoefficient(n, n-m);
20 # BinomialCoefficient(n_IsInteger,m_IsInteger) <-- 0;

Combinations(n,m) := BinomialCoefficient(n,m);

%/mathpiper



%mathpiper_docs,name="Combinations;BinomialCoefficient",categories="User Functions;Combinatorics"
*CMD Combinations/BinomialCoefficient --- combinations/ binomial coefficient
*STD
*CALL
        Combinations(n, r)
	BinomialCoefficient(n, r)

*PARMS

{n} -- integer - total number of objects
{r} -- integer - number of objects chosen

*DESC

These functions are actually two names for a single function.

In combinatorics, the function is thought of as being the number of ways
to choose "r" objects out of a total of "n" objects if order is
not taken into account.

In mathematics the function is called the binomial coefficient function
and it is thought of as the coefficient of the x^r term in the polynomial expansion
of the binomial power (1 + x)^n.

The binomial coefficient is defined to be zero
if "r" is negative or greater than "n"; {BinomialCoefficient(0,0)}=1.


*E.G.

In> Combinations(10, 4)
Result: 210;

In> BinomialCoefficient(10, 4)
Result: 210;


*SEE CombinationsList, Permutations, PermutationsList, !, Eulerian
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/0000755000175000017500000000000011722677333024752 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IntLog.mpw0000644000175000017500000000321111522212340026645 0ustar  giovannigiovanni%mathpiper,def="IntLog"

/// Return integer part of the logarithm of x in given base. Use only integer arithmetic.
10 # IntLog(_x, _base) _ (base<=1) <-- Undefined;
/// Use variable steps to speed up operation for large numbers x
20 # IntLog(_x, _base) <--
[
	Local(result, step, old'step, factor, old'factor);
	result := 0;
	old'step := step := 1;
	old'factor := factor := base;
	// first loop: increase step
	While (x >= factor)
	[
		old'factor := factor;
		factor := factor*factor;
		old'step := step;
		step := step*2;
	];
	If(x >= base,
	  [
		step := old'step;
		result := step;
		x := Quotient(x, old'factor);
	  ],
	  step := 0
	);
	// second loop: decrease step
	While (step > 0 And x != 1)
	[
		step := Quotient(step,2);	// for each step size down to 1, divide by factor if x is up to it
		factor := base^step;
		If(
			x >= factor,
			[
				x:=Quotient(x, factor);
				result := result + step;
			]
		);
	];
	result;
];

%/mathpiper



%mathpiper_docs,name="IntLog",categories="User Functions;Numbers (Operations)"
*CMD IntLog --- integer part of logarithm
*STD
*CALL
	IntLog(n, base)

*PARMS

{n}, {base} -- positive integers

*DESC

{IntLog} calculates the integer part of the logarithm of {n} in base {base}. The algorithm uses only integer 
math and may be faster than computing $$Ln(n)/Ln(base)$$ with multiple precision floating-point math and rounding off to get the integer part.

This function can also be used to quickly count the digits in a given number.

*E.G.
Count the number of bits:
In> IntLog(257^8, 2)
Result: 64;

Count the number of decimal digits:
In> IntLog(321^321, 10)
Result: 804;

*SEE IntNthRoot, Quotient, Modulo, Ln
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/RoundToPlace.mpw0000644000175000017500000001114711517224250030026 0ustar  giovannigiovanni%mathpiper,def="RoundToPlace"

//Retract("RoundToPlace",*);

10 # RoundToPlace( N_IsDecimal, place_IsInteger ) <--
[
    //If(InVerboseMode(),Tell("RoundToPlace_D",{N,place}));
    Local(rep,sgn,oldInt,oldPrec,oldScale,oldPlaces,strOInt,LS);
    Local(newInt,newScale,newRep,ans);
    sgn      := Sign(N);
    rep      := NumberToRep( Abs(N) );
    oldInt   := rep[1];
    oldPrec  := rep[2];
    oldScale := rep[3];
    oldPlaces:= oldPrec - oldScale;
    strOInt  := ExpressionToString(oldInt);
    LS       := Length(strOInt);
    //If(InVerboseMode(),
    //   [
    //    Tell("   ",rep);
    //    Tell("         ",oldInt);
    //    Tell("         ",strOInt);
    //    Tell("         ",LS);
    //    Tell("         ",{place,oldPrec});
    //    Tell("         ",oldPlaces);
    //   ]
    //);
    If(oldPlaces+place>0,
        ans := RoundToPrecision(N,oldPlaces+place),
        ans := 0.
    );
    ans;
];


15 # RoundToPlace( N_IsInteger, place_IsInteger )_(place <= 0) <--
[
    //If(InVerboseMode(),Tell("RoundToPlace_I",{N,place}));
    Local(oldRep,oldPrec,decN,newDecN,ans);
    oldRep   := NumberToRep(N);
    oldPrec  := oldRep[2];
    decN     := N*1.0;
    newDecN  := RoundToPlace( decN, place );
    //If(InVerboseMode(),Tell("    ",oldRep));
    //If(InVerboseMode(),Tell("   ",oldPrec));
    //If(InVerboseMode(),Tell("   ",place));
    //If(InVerboseMode(),Tell("   ",newDecN));
    If( place <= oldPrec, 
        ans := Round(newDecN),
        ans := Round(newDecN*10^(place-oldPrec))
    );
    ans;
];



20 # RoundToPlace( N_IsComplex, place_IsInteger )_(Not IsInteger(N)) <--
[
    //If(InVerboseMode(),Tell("RoundToPlace_C",{N,place}));
    Local(rr,ii);
    rr := Re(N);
    ii := Im(N);
    Complex(RoundToPlace(rr,place),RoundToPlace(ii,place));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


    



%mathpiper_docs,name="RoundToPlace",categories="Programmer Functions;Numerical (Arbitrary Precision)"
*CMD RoundToPlace --- Rounds or Sets a number to the specified "decimal place"
*STD
*CALL
	RoundToPlace(number,place)
*PARMS
{number} -- a number (Decimal, Integer, or Complex) whose precision is to be changed
{place}  -- the decimal place to which to round


*DESC
This function rounds an {arbitrary-precision number} (A.P.N.) to the given
decimal place.  The variable {place} is an integer counting from the current
position of the decimal point in {number}.  If {place} is positive, the
number will be rounded to the position that many places to the right of
the current decimal point.  If {place} is negative, the number will be rounded
to the position that many places to the left of the current decimal point. 

The examples shown below will hopefully clarify the above description.

See the documentation for the related function {RoundToPrecision} for a
detailed description of the way MathPiper internally represents A.P.N.s.

NOTE:  It is important to recognize the distinction (often misused or misunderstood)
between rounding "to a specified decimal place" (which this function does) and 
rounding "to a specified precision", which in MathPiper is accomplished by
the function {RoundToPrecision} (q.v.).  

For Decimal numbers and Decimal Complex numbers, the concept of Rounding to a 
given decimal place to the left or right of the current decimal point is well 
understood. It makes no sense to try to round further to the left than the first 
digit of the number, and this function will return zero if you try.  To "round"
further to the right than the last decimal place of the number just adds 
trailing zeros.

For Integers and Complex Integers (Gaussian Integers), the concept of
Rounding to a decimal position {within} the integer (place < 0 ) makes sense,
and will be accomplished by this function.  Digits between the rounding digit
and the end of the integer will be replaced by zeros. 
However, it makes no sense to try to round an integer to a decimal place
{outside} the integer, and this function will return unevaluated if place > 0.
*E.G.
In> dec:=123.45678
Result: 123.45678
    
In> dec2:=RoundToPlace(dec,1)
Result: 123.5
    
In> dec3:=RoundToPlace(dec,-1)
Result: 120
    
In> dec3:=RoundToPlace(dec,-4)
Result: 0.
    
In> dec3:=RoundToPlace(dec,6)
Result: 123.456780
    
In> int:=12345678
Result: 12345678
    
In> int2:=RoundToPlace(int,-2)
Result: 12345700
    
In> int2:=RoundToPlace(int,2)
Result: RoundToPlace(12345678,2
*SEE RoundToPrecision, RoundToN, NumberToRep, DumpNumber
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsSquareFree.mpw0000644000175000017500000000133311523200452030014 0ustar  giovannigiovanni%mathpiper,def="IsSquareFree"

IsSquareFree(n_IsInteger)	<-- ( Moebius(n) != 0 );

%/mathpiper



%mathpiper_docs,name="IsSquareFree",categories="User Functions;Number Theory;Predicates"
*CMD IsSquareFree --- test for a square-free number
*STD
*CALL
	IsSquareFree(n)

*PARMS

{n} -- positive integer

*DESC

This function uses the {Moebius} function to tell if the given number is square-free, which
means it has distinct prime factors. If $Moebius(n)!=0$, then {n} is square free. All prime
numbers are trivially square-free.

*E.G.

In> IsSquareFree(37)
Result: True;
In> IsSquareFree(4)
Result: False;
In> IsSquareFree(16)
Result: False;
In> IsSquareFree(18)
Result: False;

*SEE Moebius, SquareFreeDivisorsList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/NextPseudoPrime.mpw0000644000175000017500000000131311320776303030557 0ustar  giovannigiovanni%mathpiper,def="NextPseudoPrime"

/// obtain next number that has good chances of being prime (not divisible by 2,3)
1# NextPseudoPrime(i_IsInteger)_(i<=1) <-- 2;
2# NextPseudoPrime(2) <-- 3;
//2# NextPseudoPrime(3) <-- 5;
3# NextPseudoPrime(i_IsOdd) <--
[
	// this sequence generates numbers not divisible by 2 or 3
	i := i+2;
	If(Modulo(i,3)=0, i:=i+2, i);
/* commented out because it slows things down without a real advantage
// this works only for odd i>=5
	i := If(
		Modulo(-i,3)=0,
		i + 2,
		i + 2*Modulo(-i, 3)
	);
	// now check if divisible by 5
	If(
		Modulo(i,5)=0,
		NextPseudoPrime(i),
		i
	);
*/
];
// this works only for even i>=4
4# NextPseudoPrime(i_IsEven) <-- NextPseudoPrime(i-1);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Euler.mpw0000644000175000017500000000161211523200452026532 0ustar  giovannigiovanni%mathpiper,def="Euler"

5  # Euler(0)		<-- 1;
10 # Euler(n_IsOdd)	<-- 0;
10 # Euler(n_IsEven)	<-- - Sum(r,0,n/2-1,BinomialCoefficient(n,2*r)*Euler(2*r));
10 # Euler(n_IsNonNegativeInteger,_x)	<-- Sum(i,0,Round(n/2),BinomialCoefficient(n,2*i)*Euler(2*i)*(x-1/2)^(n-2*i)/2^(2*i));

%/mathpiper



%mathpiper_docs,name="Euler",categories="User Functions;Special Functions"
*CMD Euler --- Euler numbers and polynomials
*STD
*CALL
	Euler(index)
	Euler(index,x)

*PARMS

{x} -- expression that will be the variable in the polynomial

{index} -- expression that can be evaluated to an integer

*DESC

{Euler(n)} evaluates the $n$-th Euler number. {Euler(n,x)} returns the $n$-th Euler polynomial in the variable $x$.

*E.G.

In> Euler(6)
Result: -61;
In> A:=Euler(5,x)
Result: (x-1/2)^5+(-10*(x-1/2)^3)/4+(25*(x-1/2))/16;
In> Simplify(A)
Result: (2*x^5-5*x^4+5*x^2-1)/2;

*SEE BinomialCoefficient
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/StirlingNumber1.mpw0000644000175000017500000000211211523200452030477 0ustar  giovannigiovanni%mathpiper,def="StirlingNumber1"

10 # StirlingNumber1(n_IsInteger,0) <-- If(n=0,1,0);
10 # StirlingNumber1(n_IsInteger,1) <-- (-1)^(n-1)*(n-1)!;
10 # StirlingNumber1(n_IsInteger,2) <-- (-1)^n*(n-1)! * HarmonicNumber(n-1);
10 # StirlingNumber1(n_IsInteger,n-1) <-- -BinomialCoefficient(n,2);
10 # StirlingNumber1(n_IsInteger,3) <-- (-1)^(n-1)*(n-1)! * (HarmonicNumber(n-1)^2 - HarmonicNumber(n-1,2))/2;
20 # StirlingNumber1(n_IsInteger,m_IsInteger) <--
	Sum(k,0,n-m,(-1)^k*BinomialCoefficient(k+n-1,k+n-m)*BinomialCoefficient(2*n-m,n-k-m)*StirlingNumber2(k-m+n,k));

%/mathpiper



%mathpiper_docs,name="StirlingNumber1",categories="User Functions;Number Theory"
*CMD StirlingNumber1 --- return the {n m}th Stirling Number of the first kind
*STD
*CALL
	StirlingNumber1(n,m)
*PARMS

{n}, {m}	-- positive integers

*DESC

This function returns the signed Stirling Number of the first kind.
All Stirling Numbers are integers. If $ m > n $, then {StirlingNumber1} returns
$0$.

*E.G.

In> StirlingNumber1(10,5)
Result: -269325;
In> StirlingNumber1(3,6)
Result: 0;

*SEE StirlingNumber2
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsPrime.mpw0000644000175000017500000000414711523200452027034 0ustar  giovannigiovanni%mathpiper,def="IsPrime",categories="User Functions;Number Theory"

2 # IsPrime(_n)_(Not IsInteger(n) Or n<=1) <-- False;
3 # IsPrime(n_IsInteger)_(n<=FastIsPrime(0)) <-- IsSmallPrime(n);

/* Fast pseudoprime testing: if n is a prime, then 24 divides (n^2-1) */
5 # IsPrime(n_IsPositiveInteger)_(n > 4 And Modulo(n^2-1,24)!=0) <-- False;

/* Determine if a number is prime, using Rabin-Miller primality
   testing. Code submitted by Christian Obrecht
 */
10 # IsPrime(n_IsPositiveInteger) <-- RabinMiller(n);

%/mathpiper



%mathpiper_docs,name="IsPrime",categories="User Functions;Number Theory;Predicates"
*CMD IsPrime --- test for a prime number
*CMD IsSmallPrime --- test for a (small) prime number
*STD
*CALL
	IsPrime(n)
	IsSmallPrime(n)

*PARMS

{n} -- integer to test

*DESC

The commands checks whether $n$, which should be a positive integer,
is a prime number. A number $n$ is a prime number if it is only divisible
by 1 and itself. As a special case, 1 is not considered a prime number.
The first prime numbers are 2, 3, 5, ...

The function {IsShortPrime} only works for numbers $n<=65537$ but it is very fast.

The function {IsPrime} operates on all numbers and uses different algorithms depending on the magnitude of the number $n$.
For small numbers $n<=65537$, a constant-time table lookup is performed.
(The function {IsShortPrime} is used for that.)
For numbers $n$ between $65537$ and $34155071728321$, the function uses the Rabin-Miller test together with table lookups to guarantee correct results.

For even larger numbers a version of the probabilistic Rabin-Miller test is executed.
The test can sometimes mistakenly mark a number as prime while it is in fact composite, but a prime number will never be mistakenly declared composite.
The parameters of the test are such that the probability for a false result is less than $10^(-24)$.

*E.G.

In> IsPrime(1)
Result: False;
In> IsPrime(2)
Result: True;
In> IsPrime(10)
Result: False;
In> IsPrime(23)
Result: True;
In> Select(1 .. 100, "IsPrime")
Result: {2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,
	  53,59,61,67,71,73,79,83,89,97};

*SEE IsPrimePower, Factors
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/0000755000175000017500000000000011722677333027475 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/DivisorsList.mpw0000644000175000017500000000162211523200452032640 0ustar  giovannigiovanni%mathpiper,def="DivisorsList"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/* DivisorsList(n) = the list of divisors of n */

DivisorsList(n_IsPositiveInteger) <--
[
 Local(nFactors,f,result,oldresult,x);
 nFactors:= Factors(n);
 result := {1};
 ForEach (f,nFactors)
    [
      oldresult := result;
      For (k:=1,k<=f[2],k++)
        ForEach (x,oldresult)
	  result:=Append(result,x*f[1]^k);
    ];
  result;
];

%/mathpiper



%mathpiper_docs,name="DivisorsList",categories="User Functions;Number Theory"
*CMD DivisorsList --- the list of divisors
*STD
*CALL
	DivisorsList(n)
*PARMS

{n} -- positive integer

*DESC

{DivisorsList} creates a list of the divisors of $n$.
This is useful for loops like

	ForEach(d,DivisorsList(n))

*E.G.

In> DivisorsList(18)
Result: {1,2,3,6,9,18};

*SEE DivisorsSum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/RamanujanSum.mpw0000644000175000017500000000212411316274015032607 0ustar  giovannigiovanni%mathpiper,def="RamanujanSum"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/* RamanujanSum(k,n) = the sum of the n-th powers of the
k-th primitive roots of the identity */

10 # RamanujanSum(k_IsPositiveInteger,0) <-- Totient(k);

20 # RamanujanSum(k_IsPositiveInteger,n_IsPositiveInteger) <--
[
 Local(s,gcd,d);
 s:= 0;
 gcd := Gcd(n,k);
 ForEach (d,DivisorsList(gcd))
  s:=s+d*Moebius(k/d);
 s;
];

%/mathpiper



%mathpiper_docs,name="RamanujanSum",categories="User Functions;Number Theory"
*CMD RamanujanSum --- compute the "Ramanujan sum"
*STD
*CALL
	RamanujanSum(k,n)

*PARMS

{k}, {n} -- positive integers

*DESC
This function computes the Ramanujan sum, i.e. the sum of the $n$-th powers of 
the $k$-th primitive roots of the unit:

$$ Sum(l,1,k, Exp(2*Pi*I*(l*n)/k)) $$

where $l$ runs thought the integers between $1$ and $k-1$ that are coprime to $l$.

The computation is done by using the formula in T. M. Apostol,
Introduction to Analytic Theory (Springer-Verlag), Theorem 8.6.
%/mathpiper_docs././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/SquareFreeDivisorsList.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/SquareFreeDivisorsList0000644000175000017500000000211011523200452034012 0ustar  giovannigiovanni%mathpiper,def="SquareFreeDivisorsList"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/* Returns a list of the square-free divisors of n */
SquareFreeDivisorsList(n_IsPositiveInteger) <--
[
 Local(nFactors,f,result,oldresult,x);
 nFactors:= Factors(n);
 result := {1};
 ForEach (f,nFactors)
    [
      oldresult := result;
        ForEach (x,oldresult)
	  result:=Append(result,x*f[1]);
    ];
  result;
];

%/mathpiper



%mathpiper_docs,name="SquareFreeDivisorsList",categories="User Functions;Number Theory"
*CMD SquareFreeDivisorsList --- the list of square-free divisors
*STD
*CALL
	SquareFreeDivisorsList(n)
*PARMS

{n} -- positive integer

*DESC

{SquareFreeDivisorsList} creates a list of the square-free divisors of $n$.
Square-free numbers are numbers that have only simple prime factors (no prime powers).
For example, $18=2*3*3$ is not square-free because it contains a square of $3$ as a factor.

*E.G.

In> SquareFreeDivisorsList(18)
Result: {1,2,3,6};

*SEE DivisorsList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/JacobiSymbol.mpw0000644000175000017500000000355711523200452032570 0ustar  giovannigiovanni%mathpiper,def="JacobiSymbol"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/** Compute the Jacobi symbol JS(m/n) - n must be odd, both positive.
See the Algo book for documentation.

*/

10 # JacobiSymbol(_a, 1) <-- 1;
15 # JacobiSymbol(0, _b) <-- 0;
18 # JacobiSymbol(_a, _b) _ (Gcd(a,b)>1) <-- 0;

20 # JacobiSymbol(_a, b_IsOdd)_(a>=Abs(b) Or a<0) <-- JacobiSymbol(Modulo(a,Abs(b)),Abs(b));

30 # JacobiSymbol(a_IsEven, b_IsOdd) <--
[
	Local(c, s);
	// compute c,s where a=c*2^s and c is odd
	{c,s}:=FindPrimeFactorSimple(a, 2);	// use the "Simple" function because we don't expect a worst case here
	If(Modulo(s,2)=1 And Abs(Modulo(b,8)-4)=1, -1, 1) * JacobiSymbol(c,b);
];

40 # JacobiSymbol(a_IsOdd, b_IsOdd) <-- If(Modulo(a,4)=3 And Modulo(b,4)=3, -1, 1) * JacobiSymbol(b,a);

%/mathpiper



%mathpiper_docs,name="JacobiSymbol",categories="User Functions;Number Theory"
*CMD JacobiSymbol --- functions related to finite groups
*STD
*CALL
	JacobiSymbol(m,n)

*PARMS
{m}, {n} -- integers, $n$ must be odd and positive

*DESC

The Jacobi symbol $[m/n;]$ is defined as the product of the Legendre symbols of the prime factors $f[i]$ of $n=f[1]^p[1]*...*f[s]^p[s]$,
$$ [m/n;] := [m/f[1];]^p[1]*...*[m/f[s];]^p[s] $$.
(Here we used the same notation $[a/b;]$ for the Legendre and the Jacobi symbols; this is confusing but seems to be the current practice.)
The Jacobi symbol is equal to $0$ if $m$, $n$ are not mutually prime (have a common factor).
The Jacobi symbol and the Legendre symbol have values $+1$, $-1$ or $0$.
If $n$ is prime, then the Jacobi symbol is the same as the Legendre symbol.

The Jacobi symbol can be efficiently computed without knowing the full factorization of the number $n$.

*E.G.

In> JacobiSymbol(7,15)
Result: -1;

*SEE Gcd, LegendreSymbol, IsQuadraticResidue
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/SumForDivisors.mpw0000644000175000017500000000261411331203122033134 0ustar  giovannigiovanni%mathpiper,def="SumForDivisors"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/* This function performs a sum where sumvar runs through
   the divisors of n
   For example SumForDivisors(d,10,d^2)
   sums d^2 with d walking through the divisors of 10
   LocalSymbols is needed since we use Eval() inside
   Look at Programming in MathPiper: Evaluating Variables in the Wrong
   Scope */

Function ("SumForDivisors",{sumvar,n,sumbody}) LocalSymbols(s,d)
[
   Local(s,d);
   s:=0;
   ForEach (d,DivisorsList(n))
   [
    MacroLocal(sumvar);
    MacroBind(sumvar,d);
    s:=s+Eval(sumbody);
   ];
   s;
];
UnFence("SumForDivisors",3);
HoldArgument("SumForDivisors",sumvar);
HoldArgument("SumForDivisors",sumbody); 

%/mathpiper



%mathpiper_docs,name="SumForDivisors",categories="User Functions;Number Theory"
*CMD SumForDivisors --- loop over divisors
*STD
*CALL
	SumForDivisors(var,n,expr)
*PARMS

{var} -- atom, variable name

{n} -- positive integer

{expr} -- expression depending on {var}

*DESC

This function performs the sum of the values of the expression {expr} while the variable {var} runs through 
the divisors of {n}.
For example, {SumForDivisors(d, 10, d^2)} sums $d^2$ where $d$ runs 
through the divisors of $10$.
This kind of computation is frequently used in number theory.

*SEE DivisorsList
%/mathpiper_docs././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/MoebiusDivisorsList.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/numbertheory/MoebiusDivisorsList.mp0000644000175000017500000000305211523200452033774 0ustar  giovannigiovanni%mathpiper,def="MoebiusDivisorsList"

/* Implementation of some number theoretical functions for MathPiper */
/* (C) 2002 Pablo De Napoli  under GNU GPL */

/* Returns a list of pairs {d,m}
   where d runs through the square free divisors of  n
   and m=Moebius(m)
   This is much more efficient than making a list of all
   square-free divisors of n, and then compute Moebius on each of them.
   It is useful for computing the Cyclotomic polinomials.
   It can be useful in other computations based on
   Moebius inversion formula. */

MoebiusDivisorsList(n_IsPositiveInteger) <--
[
 Local(nFactors,f,result,oldresult,x);
 nFactors:= Factors(n);
 result := {{1,1}};
 ForEach (f,nFactors)
    [
      oldresult := result;
        ForEach (x,oldresult)
	  result:=Append(result,{x[1]*f[1],-x[2]});
    ];
  result;
];

%/mathpiper



%mathpiper_docs,name="MoebiusDivisorsList",categories="User Functions;Number Theory"
*CMD MoebiusDivisorsList --- the list of divisors and Moebius values
*STD
*CALL
	MoebiusDivisorsList(n)
*PARMS

{n} -- positive integer

*DESC

Returns a list of pairs of the form {{d,m}}, where {d} runs through the squarefree divisors of $n$ and $m=Moebius(d)$. 
This is more efficient than making a list of all 
square-free divisors of $n$ and then computing {Moebius} on each of them.
It is useful for computing the cyclotomic polynomials. 
It can be useful in other computations based on the Moebius inversion formula. 

*E.G.

In> MoebiusDivisorsList(18)
Result: {{1,1},{2,-1},{3,-1},{6,1}};

*SEE DivisorsList, Moebius
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Moebius.mpw0000644000175000017500000000201311523200452027055 0ustar  giovannigiovanni%mathpiper,def="Moebius"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Definition 6.3 p120

5  # Moebius(1)	<-- 1;

10 # Moebius(_n)	<--
[
	Check(IsPositiveInteger(n), "Argument", "Moebius: argument must be positive integer");
        Local(factors,i,repeat);
	repeat:=0;
        factors:=Factors(n);
        len:=Length(factors);
        For(i:=1,i<=len,i++)[
		If(factors[i][2]>1,repeat:=1);
        ];
	If(repeat=0,(-1)^len,0);

];

%/mathpiper



%mathpiper_docs,name="Moebius",categories="User Functions;Number Theory"
*CMD Moebius --- the Moebius function
*STD 
*CALL
	Moebius(n)
*PARMS  

{n}     -- positive integer

*DESC

The Moebius function is 0 when a prime factor is repeated (which means it
is not square-free) and is $(-1)^r$ if $n$ has $r$ distinct factors. Also,
$Moebius(1)==1$.

*E.G.
In> Moebius(10)
Result: 1;
In> Moebius(11)
Result: -1;
In> Moebius(12)
Result: 0;
In> Moebius(13)
Result: -1;

*SEE DivisorsSum, ProperDivisors, ProperDivisorsSum, MoebiusDivisorsList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/om/0000755000175000017500000000000011722677333025365 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/om/om.mpw0000644000175000017500000000650411316274015026517 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( "BellNumber",      mathpiper,"BellNumber" );
OMDef( "CatalanNumber",   mathpiper,"CatalanNumber" );
OMDef( "DigitalRoot",     mathpiper,"DigitalRoot" );
OMDef( "Divisors",        mathpiper,"Divisors" );
OMDef( "DivisorsSum",     mathpiper,"DivisorsSum" );
OMDef( "Euler",           mathpiper,"Euler" );
OMDef( "EulerArray",      mathpiper,"EulerArray" );
OMDef( "Eulerian",        mathpiper,"Eulerian" );
OMDef( "FermatNumber",    mathpiper,"FermatNumber" );
OMDef( "GetPrimePower",   mathpiper,"GetPrimePower" );
OMDef( "HarmonicNumber",  mathpiper,"HarmonicNumber" );
OMDef( "IntLog",          mathpiper,"IntLog" );
OMDef( "IntNthRoot",      mathpiper,"IntNthRoot" );
OMDef( "IsAmicablePair",  mathpiper,"IsAmicablePair" );
OMDef( "IsCarmichaelNumber", mathpiper,"IsCarmichaelNumber" );
OMDef( "IsComposite",     mathpiper,"IsComposite" );
OMDef( "IsCoprime",       mathpiper,"IsCoprime" );
OMDef( "IsIrregularPrime", mathpiper,"IsIrregularPrime" );
OMDef( "IsPerfect",       mathpiper,"IsPerfect" );
OMDef( "IsPrime",         mathpiper,"IsPrime" );
OMDef( "IsPrimePower",    mathpiper,"IsPrimePower" );
OMDef( "IsQuadraticResidue", mathpiper,"IsQuadraticResidue" );
OMDef( "IsSmallPrime",    mathpiper,"IsSmallPrime" );
OMDef( "IsSquareFree",    mathpiper,"IsSquareFree" );
OMDef( "IsTwinPrime",     mathpiper,"IsTwinPrime" );
OMDef( "LegendreSymbol",  mathpiper,"LegendreSymbol" );
OMDef( "Moebius",         mathpiper,"Moebius" );
OMDef( "NextPrime",       mathpiper,"NextPrime" );
OMDef( "NextPseudoPrime", mathpiper,"NextPseudoPrime" );
OMDef( "PartitionsP",     mathpiper,"PartitionsP" );
OMDef( "ProductPrimesTo257", mathpiper,"ProductPrimesTo257" );
OMDef( "ProperDivisors",  mathpiper,"ProperDivisors" );
OMDef( "ProperDivisorsSum", mathpiper,"ProperDivisorsSum" );
OMDef( "Repunit",         mathpiper,"Repunit" );
OMDef( "StirlingNumber1", mathpiper,"StirlingNumber1" );
OMDef( "StirlingNumber2", mathpiper,"StirlingNumber2" );
OMDef( "Totient",         mathpiper,"Totient" );

// From GaussianIntegers.mpi.def
OMDef( "IsGaussianUnit",    mathpiper,"IsGaussianUnit" );
OMDef( "IsGaussianInteger", mathpiper,"IsGaussianInteger" );
OMDef( "IsGaussianPrime",   mathpiper,"IsGaussianPrime" );
OMDef( "GaussianFactorPrime", mathpiper,"GaussianFactorPrime" );
OMDef( "GaussianNorm",      mathpiper,"GaussianNorm" );
OMDef( "GaussianMod",       mathpiper,"GaussianMod" );
OMDef( "GaussianFactors",   mathpiper,"GaussianFactors" );
OMDef( "AddGaussianFactor", mathpiper,"AddGaussianFactor" );
OMDef( "FactorGaussianInteger", mathpiper,"FactorGaussianInteger" );
OMDef( "GaussianGcd",       mathpiper,"GaussianGcd" );

// From nthroot.mpi.def
OMDef( "NthRoot",      mathpiper,"NthRoot" );
OMDef( "NthRoot'Calc", mathpiper,"NthRoot'Calc" );
OMDef( "NthRoot'List", mathpiper,"NthRoot'List" );
OMDef( "NthRoot'Save", mathpiper,"NthRoot'Save" );
OMDef( "NthRoot'Restore", mathpiper,"NthRoot'Restore" );
OMDef( "NthRoot'Clear", mathpiper,"NthRoot'Clear" );

// From NumberTheory.mpi.def
OMDef( "DivisorsList", mathpiper,"DivisorsList" );
OMDef( "SquareFreeDivisorsList", mathpiper,"SquareFreeDivisorsList" );
OMDef( "MoebiusDivisorsList",    mathpiper,"MoebiusDivisorsList" );
OMDef( "SumForDivisors", mathpiper,"SumForDivisors" );
OMDef( "RamanujanSum",   mathpiper,"RamanujanSum" );
OMDef( "JacobiSymbol",   mathpiper,"JacobiSymbol" );


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsComposite.mpw0000644000175000017500000000124011523200452027711 0ustar  giovannigiovanni%mathpiper,def="IsComposite"

5  # IsComposite(1)			<-- False;
10 # IsComposite(n_IsPositiveInteger) 	<-- (Not IsPrime(n));

%/mathpiper



%mathpiper_docs,name="IsComposite",categories="User Functions;Number Theory;Predicates"
*CMD IsComposite --- test for a composite number
*STD
*CALL
	IsComposite(n)

*PARMS

{n} -- positive integer

*DESC

This function is the logical negation of {IsPrime}, except for the number 1, which is
neither prime nor composite.

*E.G.

In> IsComposite(1)
Result: False;
In> IsComposite(7)
Result: False;
In> IsComposite(8)
Result: True;
In> Select(1 .. 20, IsComposite)
Result: {4,6,8,9,10,12,14,15,16,18,20};

*SEE IsPrime
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Rationalize.mpw0000644000175000017500000000316411523200452027743 0ustar  giovannigiovanni%mathpiper,def="Rationalize"

//Retract("Rationalize",*);

10 # Rationalize(aNumber_IsList) <-- Rationalize /@ aNumber;

20 # Rationalize( _aNumber ) <--
[
    Local(result,n,d);
    result:=Substitute(aNumber,{{x},IsNumber(x) And Not(IsInteger(x))},"RationalizeNumber");
    If(InVerboseMode(),Tell("",result));
    If(Length(VarList(aNumber))=0,
      [
        n:=Numerator(result);
        If(Type(n)="Numerator",n:=result);
        d:=Denominator(result);
        If(Type(d)="Denominator",d:=1);
        result := n*(1/d);
      ]
    );
    result;
];
%/mathpiper

   




%mathpiper_docs,name="Rationalize",categories="User Functions;Numbers (Operations)"
*CMD Rationalize --- convert floating point numbers to fractions
*STD
*CALL
	Rationalize(expr)

*PARMS

{expr} -- an expression containing real numbers

*DESC

This command converts every real number in the expression "expr"
into a rational number. This is useful when a calculation needs to be
done on floating point numbers and the algorithm is unstable.
Converting the floating point numbers to rational numbers will force
calculations to be done with infinite precision (by using rational
numbers as representations).

It does this by finding the smallest integer $n$ such that multiplying
the number with $10^n$ is an integer. Then it divides by $10^n$ again,
depending on the internal gcd calculation to reduce the resulting
division of integers.

*E.G.
    
In> Rationalize(-1.2)
Result: (-6)/5
In> Rationalize(1.3+7.43*x)
Result: 743/100*x+13/10
In> {1.2,3.123,4.5}
Result: {1.2,3.123,4.5};
In> Rationalize(%)
Result: {6/5,3123/1000,9/2};

*SEE IsRational

%/mathpiper_docs

   


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/ProperDivisorsSum.mpw0000644000175000017500000000137411523200452031142 0ustar  giovannigiovanni%mathpiper,def="ProperDivisorsSum"

10 # ProperDivisorsSum(_n) <--
[
        Check(IsPositiveInteger(n), "Argument", "ProperDivisorsSum: argument must be positive integer");
        DivisorsSum(n)-n;
];

%/mathpiper



%mathpiper_docs,name="ProperDivisorsSum",categories="User Functions;Number Theory"
*CMD ProperDivisorsSum --- the sum of proper divisors
*STD 
*CALL
	ProperDivisorsSum(n)
*PARMS  

{n}     -- positive integer

*DESC

{ProperDivisorsSum} returns the sum of proper divisors, i.e. {ProperDivisors(n)-n},
since {n} is not counted.
{n} is prime if and only if {ProperDivisorsSum(n)==1}.

*E.G.
In> ProperDivisorsSum(180)
Result: 366;
In> ProperDivisorsSum(37)
Result: 1;


*SEE DivisorsSum, ProperDivisors, ProperDivisorsSum, Moebius
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IntNthRoot.mpw0000644000175000017500000000636011522212340027531 0ustar  giovannigiovanni%mathpiper,def="IntNthRoot"

/// Compute integer part of s-th root of (positive) integer n.
// algorithm using floating-point math
10 # IntNthRoot(_n, 2) <-- Floor(SqrtN(n));
20 # IntNthRoot(_n, s_IsInteger) <--
[
	Local(result, k);
	GlobalPush(BuiltinPrecisionGet());
	// find integer k such that 2^k <= n^(1/s) < 2^(k+1)
	k := Quotient(IntLog(n, 2), s);
	// therefore we need k*Ln(2)/Ln(10) digits for the floating-point calculation
	BuiltinPrecisionSet(2+Quotient(k*3361, 11165));	// 643/2136 < Ln(2)/Ln(10) < 3361/11165
	result := Round(ExpN(DivideN(Internal'LnNum(DivideN(n, 2^(k*s))), s))*2^k);
	BuiltinPrecisionSet(GlobalPop());
	// result is rounded and so it may overshoot (we do not use Floor above because numerical calculations may undershoot)
	If(result^s>n, result-1, result);
];

/* algorithm using only integer arithmetic.
(this is slower than the floating-point algorithm for large numbers because all calculations are with long integers)
IntNthRoot1(_n, s_IsInteger) <--
[
	Local(x1, x2, x'new, y1);
	// initial guess should always undershoot
	//	x1:= 2 ^ Quotient(IntLog(n, 2), s); 	// this is worse than we can make it
	x1 := IntLog(n,2);
	// select initial interval using (the number of bits in n) mod s
	// note that if the answer is 1, the initial guess must also be 1 (not 0)
	x2 := Quotient(x1, s);	// save these values for the next If()
	x1 := Modulo(x1, s)/s;	// this is kept as a fraction
	// now assign the initial interval, x1 <= root <= x2
	{x1, x2} := If(
		x1 >= 263/290,	// > Ln(15/8)/Ln(2)
		Quotient({15,16}*2^x2, 8),
		If(
		x1 >= 373/462,	// > Ln(7/4)/Ln(2)
		Quotient({7,8}*2^x2, 4),
		If(
		x1 >= 179/306,	// > Ln(3/2)/Ln(2)
		Quotient({6,7}*2^x2, 4),
		If(
		x1 >= 113/351,	// > Ln(5/4)/Ln(2)
		Quotient({5,6}*2^x2, 4),
		Quotient({4,5}*2^x2, 4)	// between x1 and (5/4)*x1
	))));
	// check whether x2 is the root
	y1 := x2^s;
	If(
		y1=n,
		x1 := x2,
		// x2 is not a root, so continue as before with x1
		y1 := x1^s	// henceforth, y1 is always x1^s
	);
	// Newton iteration combined with bisection
	While(y1 < n)
	[
//	Echo({x1, x2});
		x'new := Quotient(x1*((s-1)*y1+(s+1)*n), (s+1)*y1+(s-1)*n) + 1;	// add 1 because the floating-point value undershoots
		If(
			x'new < Quotient(x1+x2, 2),
			// x'new did not reach the midpoint, need to check progress
			If(
				Quotient(x1+x2, 2)^s <= n,
				// Newton's iteration is not making good progress, so leave x2 in place and update x1 by bisection
				x'new := Quotient(x1+x2, 2),
				// Newton's iteration knows what it is doing. Update x2 by bisection
				x2 := Quotient(x1+x2, 2)
			)
			// else, x'new reached the midpoint, good progress, continue
		);
		x1 := x'new;
		y1 := x1^s;
	];
	If(y1=n, x1, x1-1);	// subtract 1 if we overshot
];
*/

%/mathpiper



%mathpiper_docs,name="IntNthRoot",categories="User Functions;Numbers (Operations)"
*CMD IntNthRoot --- integer part of $n$-th root
*STD
*CALL
	IntNthRoot(x, n)

*PARMS

{x}, {n} -- positive integers

*DESC

{IntNthRoot} calculates the integer part of the $n$-th root of $x$. The algorithm uses only 
integer math and may be faster than computing $x^(1/n)$ with floating-point and rounding.

This function is used to test numbers for prime powers.

*E.G.
In> IntNthRoot(65537^111, 37)
Result: 281487861809153;

*SEE IntLog, PowerN, IsPrimePower
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/PartitionsP.mpw0000644000175000017500000001217211320776303027745 0ustar  giovannigiovanni%mathpiper,def="PartitionsP"

/// the restricted partition function
/// partitions of length k

5  # PartitionsP(n_IsInteger,0)		  	<-- 0;
5  # PartitionsP(n_IsInteger,n_IsInteger)	<-- 1;
5  # PartitionsP(n_IsInteger,1)			<-- 1;
5  # PartitionsP(n_IsInteger,2)			<-- Floor(n/2);
5  # PartitionsP(n_IsInteger,3)			<-- Round(n^2/12);
6  # PartitionsP(n_IsInteger,k_IsInteger)_(k>n) <-- 0;
10 # PartitionsP(n_IsInteger,k_IsInteger)	<-- PartitionsP(n-1,k-1)+PartitionsP(n-k,k);

/// the number of additive partitions of an integer
5  # PartitionsP(0)	<-- 1;
5  # PartitionsP(1)	<-- 1;
// decide which algorithm to use
10 # PartitionsP(n_IsInteger)_(n<250) <-- PartitionsP'recur(n);
20 # PartitionsP(n_IsInteger) <-- PartitionsP'HR(n);

/// Calculation using the Hardy-Ramanujan series.
10 # PartitionsP'HR(n_IsPositiveInteger) <--
[
	Local(P0, A, lambda, mu, mu'k, result, term, j, k, l, prec, epsilon);
	result:=0;
	term:=1;	// initial value must be nonzero
	GlobalPush(BuiltinPrecisionGet());
	// precision must be at least Pi/Ln(10)*Sqrt(2*n/3)-Ln(4*n*Sqrt(3))/Ln(10)
	// here Pi/Ln(10) < 161/118, and Ln(4*Sqrt(3))/Ln(10) <1 so it is disregarded. Add 2 guard digits and compensate for round-off errors by not subtracting Ln(n)/Ln(10) now
	prec := 2+Quotient(IntNthRoot(Quotient(2*n+2,3),2)*161+117,118);
	BuiltinPrecisionSet(prec);	// compensate for round-off errors
	epsilon := PowerN(10,-prec)*n*10;	// stop when term < epsilon

	// get the leading term approximation P0 - compute once at high precision
	lambda := N(Sqrt(n - 1/24));
	mu := N(Pi*lambda*Sqrt(2/3));
	// the hoops with DivideN are needed to avoid roundoff error at large n due to fixed precision:
	// Exp(mu)/(n) must be computed by dividing by n, not by multiplying by 1/n
	P0 := N(1-1/mu)*DivideN(ExpN(mu),(n-DivideN(1,24))*4*SqrtN(3));
	/*
	the series is now equal to
	P0*Sum(k,1,Infinity,
	  (
		Exp(mu*(1/k-1))*(1/k-1/mu) + Exp(-mu*(1/k+1))*(1/k+1/mu)
	  ) * A(k,n) * Sqrt(k)
	)
	*/

	A := 0;	// this is also used as a flag
	// this is a heuristic, because the next term error is expensive
	// to calculate and the theoretic bounds have arbitrary constants
	// use at most 5+Sqrt(n)/2 terms, stop when the term is nonzero and result stops to change at precision prec
	For(k:=1, k<=5+Quotient(IntNthRoot(n,2),2) And (A=0 Or Abs(term)>epsilon), k++)
	[
		// compute A(k,n)
		A:=0;
		For(l:=1,l<=k,l++)
		[
			If(
				Gcd(l,k)=1,
				A := A + Cos(Pi*
				  (	// replace Exp(I*Pi*...) by Cos(Pi*...) since the imaginary part always cancels
					Sum(j,1,k-1, j*(Modulo(l*j,k)/k-1/2)) - 2*l*n
					// replace (x/y - Floor(x/y)) by Modulo(x,y)/y for integer x,y
				  )/k)
			);
			A:=N(A);	// avoid accumulating symbolic Cos() expressions
		];

		term := If(
			A=0,	// avoid long calculations if the term is 0
			0,
			N( A*Sqrt(k)*(
			  [
			  	mu'k := mu/k;	// save time, compute mu/k once
			    Exp(mu'k-mu)*(mu'k-1) + Exp(-mu'k-mu)*(mu'k+1);
			  ]
			)/(mu-1) )
		);
//		Echo("k=", k, "term=", term);
		result := result + term;
//		Echo("result", new'result* P0);
	];
	result := result * P0;
	BuiltinPrecisionSet(GlobalPop());
	Round(result);
];

// old code for comparison

10 # PartitionsP1(n_IsPositiveInteger) <--
 [
		 Local(C,A,lambda,m,pa,k,h,term);
	   GlobalPush(BuiltinPrecisionGet());
	   // this is an overshoot, but seems to work up to at least n=4096
	   BuiltinPrecisionSet(10 + Floor(N(Sqrt(n))) );
	   pa:=0;
		 C:=Pi*Sqrt(2/3)/k;
		 lambda:=Sqrt(m - 1/24);
	   term:=1;
	   // this is a heuristic, because the next term error is expensive
	   // to calculate and the theoretic bounds have arbitrary constants
	   For(k:=1,k<=5+Floor(SqrtN(n)*0.5) And ( term=0 Or Abs(term)>0.1) ,k++)[
			   A:=0;
			   For(h:=1,h<=k,h++)[
					   if( Gcd(h,k)=1 )[
							   A:=A+Exp(I*Pi*Sum(j,1,k-1,(j/k)*((h*j)/k - Floor((h*j)/k) -1/2))
- 2*Pi*I*h*n/k );
					   ];
			   ];
			   If(A!=0, term:= N(A*Sqrt(k)*(Deriv(m) Sinh(C*lambda)/lambda) Where m==n ),term:=0 );
//			   Echo("Term ",k,"is ",N(term/(Pi*Sqrt(2))));
			   pa:=pa+term;
//			   Echo("result", N(pa/(Pi*Sqrt(2))));
	   ];
	   pa:=N(pa/(Pi*Sqrt(2)));
	   BuiltinPrecisionSet(GlobalPop());
	   Round(pa);
 ];

/// integer partitions by recurrence relation P(n) = Sum(k,1,n, (-1)^(k+1)*( P(n-k*(3*k-1)/2)+P(n-k*(3*k+1)/2) ) ) = P(n-1)+P(n-2)-P(n-5)-P(n-7)+...
/// where 1, 2, 5, 7, ... is the "generalized pentagonal sequence"
/// this method is faster with internal math for number<300 or so.
PartitionsP'recur(number_IsPositiveInteger) <--
[
	// need storage of n values PartitionsP(k) for k=1,...,n
	Local(sign, cache, n, k, pentagonal, P);
	cache:=ArrayCreate(number+1,1);	// cache[n] = PartitionsP(n-1)
	n := 1;
	While(n ProperDivisors(180)
Result: 17;
In> ProperDivisors(37)
Result: 1;

*SEE DivisorsSum, ProperDivisors, ProperDivisorsSum, Moebius
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/NthRoot.mpw0000644000175000017500000000746211522213116027064 0ustar  giovannigiovanni%mathpiper,def="NthRoot"

/* def file definitions
NthRoot
NthRoot'Calc
NthRoot'List
NthRoot'Save
NthRoot'Restore
NthRoot'Clear

*/

//////
// $Id: nthroot.mpi,v 1.5 2007/05/17 11:56:45 ayalpinkus Exp $
// calculation/simplifaction of nth roots of nonnegative integers
// NthRoot         - interface function
// NthRoot'Calc    - actually calculate/simplifies
// NthRoot'List    - list table entries for a given n
// NthRoot'Restore - get a root from lookup table
// NthRoot'Save    - save a root in lookup table
// NthRoot'Clear   - clear lookup table
//////

// LocalSymbols(m,n,r,
//		NthRoot'Table,
//		NthRoot'Calc,
//		NthRoot'List,
//		NthRoot'Restore,
//		NthRoot'Save,
//		NthRoot'Clear)
LocalSymbols(m,n,r,
             NthRoot'Table)
[

// interface function for nth root of m
// m>=0, n>1, integers
// m^(1/n) --> f*(r^(1/n))
NthRoot(m_IsNonNegativeInteger,n_IsInteger)_(n>1) <--
[
   Local(r);
   r:=NthRoot'Restore(m,n);
   If(Length(r)=0,
   [
      r:=NthRoot'Calc(m,n);
      NthRoot'Save(m,n,r);
   ]);
   r;
];

// internal functions
Function("NthRoot'Calc",{m,n})
[
   Local(i,j,f,r,in);
   Bind(i,2);
   Bind(j,Ceil(FastPower(m,N(1.0/n))+1));
   Bind(f,1);
   Bind(r,m);
   // for large j (approx >4000)
   // using Factors instead of the
   // following.  would this be
   // faster in general?
//Echo("i j ",i," ",j);
   While(IsLessThan(i,j))
   [
      Bind(in,PowerN(i,n));
//Echo("r in mod ",r, " ",in," ",ModuloN(r,in));
      While(IsEqual(ModuloN(r,in),0))
      [
	 Bind(f,MultiplyN(f,i));
	 Bind(r,QuotientN(r,in));
      ];
      While(IsEqual(ModuloN(r,i),0))   //
	 Bind(r,QuotientN(r,i));         //
      //Bind(i,NextPrime(i));
      Bind(i,NextPseudoPrime(i));
      Bind(j,Ceil(FastPower(r,N(1.0/n))+1));
   ];
   //List(f,r);
   List(f,QuotientN(m,PowerN(f,n))); //
];

// lookup table utilities
Function("NthRoot'List",{n})
[
   If(Length(NthRoot'Table)>0,
   [
      Local(p,xx);
      p:=Select(NthRoot'Table, {{xx},First(xx)=n});
      If(Length(p)=1,Rest(p[1]),List());
   ],
   List());
];

Function("NthRoot'Restore",{m,n})
[
   Local(p);
   p:=NthRoot'List(n);
   If(Length(p)>0,
   [
      Local(r,xx);
      r:=Select(p, {{xx},First(xx)=m});
      If(Length(r)=1,First(Rest(r[1])),List());
   ],
   List());
];

Function("NthRoot'Save",{m,n,r})
[
   Local(p);
   p:=NthRoot'List(n);
   If(Length(p)=0,
   // create power list and save root
   DestructiveInsert(NthRoot'Table,1,List(n,List(m,r))),
   [
      Local(rr,xx);
      rr:=Select(p, {{xx},First(xx)=m});
      If(Length(rr)=0,
      [
	 // save root only
	 DestructiveAppend(p,List(m,r));
      ],
      // already saved
      False);
   ]);
];

//TODO why is NthRoot'Table both lazy global and protected with LocalSymbols?
Function("NthRoot'Clear",{}) SetGlobalLazyVariable(NthRoot'Table,List());

// create empty table
NthRoot'Clear();

]; // LocalSymbols(m,n,r,NthRoot'Table);

//////
//////


%/mathpiper



%mathpiper_docs,name="NthRoot",categories="User Functions;Numbers (Operations)"
*CMD NthRoot --- calculate/simplify nth root of an integer
*STD
*CALL
	NthRoot(m,n)

*PARMS

{m} -- a non-negative integer ($m>0$)

{n} -- a positive integer greater than 1 ($n>1$)

*DESC

{NthRoot(m,n)} calculates the integer part of the $n$-th root $m^(1/n)$ and
returns a list {{f,r}}. {f} and {r} are both positive integers
that satisfy $f^n*r$=$m$.
In other words, $f$ is the largest integer such that $m$ divides $f^n$ and $r$ is the remaining factor.

For large {m} and small {n}
{NthRoot} may work quite slowly. Every result {{f,r}} for given
{m}, {n} is saved in a lookup table, thus subsequent calls to
{NthRoot} with the same values {m}, {n} will be executed quite
fast.

*E.G.
In> NthRoot(12,2)
Result: {2,3};
In> NthRoot(81,3)
Result: {3,3};
In> NthRoot(3255552,2)
Result: {144,157};
In> NthRoot(3255552,3)
Result: {12,1884};

*SEE IntNthRoot, Factors, PowerN
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Divisors.mpw0000644000175000017500000000176011523200452027264 0ustar  giovannigiovanni%mathpiper,def="Divisors"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Theorem 6.2 p112
5  # Divisors(0)	<-- 0;
5  # Divisors(1)	<-- 1;
// Unsure about if there should also be a function that returns
// n's divisors, may have to change name in future
10 # Divisors(_n)	<--
[
	Check(IsPositiveInteger(n), "Argument", "Divisors: argument must be positive integer");
	Local(len,sum,factors,i);
	sum:=1;
	factors:=Factors(n);
	len:=Length(factors);
	For(i:=1,i<=len,i++)[
		sum:=sum*(factors[i][2]+1);
	];
	sum;
];

%/mathpiper



%mathpiper_docs,name="Divisors",categories="User Functions;Number Theory"
*CMD Divisors --- number of divisors
*STD
*CALL
	Divisors(n)
*PARMS

{n} -- positive integer

*DESC

{Divisors} returns the number of positive divisors of a number.
A number is prime if and only if it has two divisors, 1 and itself.

*E.G.
In> Divisors(180)
Result: 18;
In> Divisors(37)
Result: 2;

*SEE DivisorsSum, ProperDivisors, ProperDivisorsSum, Moebius
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Totient.mpw0000644000175000017500000000064311502266107027115 0ustar  giovannigiovanni%mathpiper,def="Totient"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Theorem 7.3 p139

10 # Totient(_n)	<--
[
	Check(IsPositiveInteger(n), "Argument", "Totient: argument must be positive integer");
	Local(i,sum,factors,len);
	sum:=n;
        factors:=Factors(n);
        len:=Length(factors);
        For(i:=1,i<=len,i++)[
		sum:=sum*(1-1/factors[i][1]);
        ];
	sum;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/EulerArray.mpw0000644000175000017500000000052311316274015027537 0ustar  giovannigiovanni%mathpiper,def="EulerArray"

/** Compute an array of Euler numbers using recurrence relations.
*/
10 # EulerArray(n_IsInteger) <--
[
	Local(E,i,sum,r);
	E:=ZeroVector(n+1);
	E[1]:=1;
	For(i:=1,2*i<=n,i++)[
		sum:=0;
		For(r:=0,r<=i-1,r++)[
			sum:=sum+BinomialCoefficient(2*i,2*r)*E[2*r+1];
		];
		E[2*i+1] := -sum;
	];
	E;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/RationalizeNumber.mpw0000644000175000017500000000075011502266107031120 0ustar  giovannigiovanni%mathpiper,def="RationalizeNumber"

Function("RationalizeNumber",{x})
[
  Check(IsNumber(x), "Argument", "RationalizeNumber: Error: " : (PipeToString()Write(x)) :" is not a number");
  Local(n,i,bip,m);
  n   := 1;
  i   := 0;
  bip := BuiltinPrecisionGet();
  // We can not take for granted that the internal representation is rounded properly...
  While(i<=bip And Not(FloatIsInt(x)))
  [
    n := n*10; 
    x := x*10;
    i := i+1;
  ];
  m := Floor(x+0.5);
  (m/n);
];

%/mathpiper

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsTwinPrime.mpw0000644000175000017500000000116511523200452027673 0ustar  giovannigiovanni%mathpiper,def="IsTwinPrime"

IsTwinPrime(n_IsPositiveInteger)	<-- (IsPrime(n) And IsPrime(n+2));

%/mathpiper



%mathpiper_docs,name="IsTwinPrime",categories="User Functions;Number Theory;Predicates"
*CMD IsTwinPrime --- test for a twin prime
*STD
*CALL
	IsTwinPrime(n)
*PARMS

{n} -- positive integer

*DESC

This function returns {True} if {n} is a twin prime. By definition, a twin
prime is a prime number $n$ such that $n+2$ is also a prime number. 

*E.G.
In> IsTwinPrime(101)
Result: True;
In> IsTwinPrime(7)
Result: False;
In> Select(1 .. 100, IsTwinPrime)
Result: {3,5,11,17,29,41,59,71};

*SEE IsPrime
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/RepToNumber.mpw0000644000175000017500000001124311523200452027661 0ustar  giovannigiovanni%mathpiper,def="RepToNumber"

//Retract("RepToNumber",*);


10 # RepToNumber( rep_IsListOfLists ) <--
[
    //If(InVerboseMode(),[Tell(RepToNumberZ,rep); Tell("     complex");]);
    RepToNumber(rep[1])+I*RepToNumber(rep[2]);
];


12 # RepToNumber( rep_IsList ) <--
[
    //If(InVerboseMode(),Tell(RepToNumber,rep));
    Local(bigInt,precision,scale,strBI,sgn,index,ans);
    Local(first,secnd,third,LS,numStr);
    precision := rep[2];
    scale     := 0;
    bigInt    := rep[1];
    precision := rep[2];
    sgn       := Sign(bigInt);
    If( Length(rep) > 2, scale := rep[3] );
    strBI     := ExpressionToString(Abs(bigInt));
    LS        := Length(strBI);
    //If(InVerboseMode(),[Tell("   ",{bigInt,precision,scale,sgn});Tell("   ",strBI);]);
    If( Length(rep)=2, 
       [ numStr := strBI; ],
       [
           index := precision-scale;
           first := strBI[1];
           secnd := StringMidGet(2,LS-1,strBI);   
           third := ExpressionToString(index-1);
           //If(InVerboseMode(),Tell("     ",{index,first,secnd,third}));
           if ( index > 0 )
               [
                   if ( index < precision )
                       [
                           //If(InVerboseMode(),Tell("   index < precision "));
                           numStr := ConcatStrings(first,".",secnd,"E",third);
                       ]
                   else if ( index >= precision )
                       [
                           //If(InVerboseMode(),Tell("   index >= precision "));
                           numStr := ConcatStrings(first,".",secnd,"E+",third);
                       ];
               ]
           else if ( index < 0 )
               [
                   //If(InVerboseMode(),Tell("   index < 0 "));
                   numStr := ConcatStrings(first,".",secnd,"E",third);
               ]
           else
               [
                   //If(InVerboseMode(),Tell("   index = 0 "));
                   first  := "0." ; 
                   secnd  := strBI;
                   numStr := ConcatStrings(first,secnd);
               ];
        ]
     );
     ans := sgn * ToAtom(numStr);
     //If(InVerboseMode(),Tell("     ",ans));
     ans;
];

%/mathpiper






%mathpiper_docs,name="RepToNumber",categories="Programmer Functions;Numerical (Arbitrary Precision)"
*CMD RepToNumber --- Given a List representing a number as MathPiper stores it, returns the number
*STD
*CALL
	RepToNumber(rep)
	
*PARMS

{rep} -- A list representing MathPiper's internal structure for a number


*DESC

This function returns a Decimal, Integer, or Complex number, when given a data
structure containing MathPiper's internal representation of the number.

Internally, MathPiper represents {arbitrary precision} numbers as Java BigIntegers or
BigDecimals.  Java code handles calculations using such numbers.

All the information needed to correctly understand the precision attached to a number,
and the rounding and comparison thereof, is contained in the Java structure.

For a Decimal number (essentially anything with a decimal point), the representation
consists of an arbitrary-precision integer containing {all} the significant digits of
the number, and a {scale factor} telling where the implied decimal point is supposed to
be placed with respect to the end of the integer.  The {precision} of the number is
just the number of digits in the integer.

The three components of the List representing a decimal number are, respectively,
{{BigInteger (unscaled), Precision, ScaleFactor}}.
Note that the second of these is redundent: only the BigInteger and the ScaleFactor
are needed to completely define the number.

For an Integer number, the integer is its own representation, and again, the number of
its digits gives its precision, but the representation is still a list, with the number
as first component and its precision as second.

For a Complex number, the representation is a List of Lists,
containing the representations of the Real and Imaginary parts of the number.

The best way to {consistently} deal with precision and rounding issues is by making use
of the information given by the representation (or "rep" for short)..

*E.G.
In> RepToNumber({12345678,8,5})
Result: 123.45678

In> RepToNumber({34700,5})
Result: 34700

In> RepToNumber({{150,3,2},{675,3,2}})
Result: Complex(1.50,6.75)

In> RepToNumber({12345678,8,15})
Result: 0.000000012345678   :   BETTER WOULD BE 123.45678E-10

In> RepToNumber({12345678,8,-5})
Result: 1234567800000       :   BETTER WOULD BE 123.45678E+10
    
*SEE NumberToRep, DumpNumber
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsQuadraticResidue.mpw0000644000175000017500000000154111523200452031211 0ustar  giovannigiovanni%mathpiper,def="IsQuadraticResidue"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Theorem 9.1 p187
10 # IsQuadraticResidue(_a,_p) <--
[
        Check( IsInteger(a) And IsInteger(p) And p>2 And IsCoprime(a,p) And IsPrime(p),
                "Argument", "IsQuadraticResidue: Invalid arguments");
        If(a^((p-1)/2) % p = 1, True, False);
];

%/mathpiper



%mathpiper_docs,name="IsQuadraticResidue",categories="User Functions;Number Theory;Predicates"
*CMD IsQuadraticResidue --- functions related to finite groups
*STD
*CALL
	IsQuadraticResidue(m,n)

*PARMS
{m}, {n} -- integers, $n$ must be odd and positive

*DESC

A number $m$ is a "quadratic residue modulo $n$" if there exists a number $k$ such that $k^2:=Modulo(m,n)$.

*E.G.

In> IsQuadraticResidue(9,13)
Result: True;

*SEE Gcd, JacobiSymbol, LegendreSymbol
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsCarmichaelNumber.mpw0000644000175000017500000000355311523200452031161 0ustar  giovannigiovanni%mathpiper,def="IsCarmichaelNumber"

// Carmichael numbers are odd,squarefree and have at least 3 prime factors
5  # IsCarmichaelNumber(n_IsEven)		<-- False;
5  # IsCarmichaelNumber(_n)_(n<561)		<-- False;
10 # IsCarmichaelNumber(n_IsPositiveInteger)	<--
[
	Local(i,factors,length,carmichael);

	factors:=Factors(n);
	carmichael:=True;
	length:=Length(factors);
	if( length < 3)[
		 carmichael:=False;
	] else [
		For(i:=1,i<=length And carmichael,i++)[
			//Echo( n-1,"%",factors[i][1]-1,"=", Modulo(n-1,factors[i][1]-1) );
			If( Modulo(n-1,factors[i][1]-1) != 0, carmichael:=False );
			If(factors[i][2]>1,carmichael:=False);	// squarefree
		];
	];
	carmichael;
];

IsCarmichaelNumber(n_IsList) <-- MapSingle("IsCarmichaelNumber",n);

%/mathpiper



%mathpiper_docs,name="IsCarmichaelNumber",categories="User Functions;Number Theory;Predicates"
*CMD IsCarmichaelNumber --- test for a Carmichael number
*STD
*CALL
	IsCarmichaelNumber(n)

*PARMS

{n} -- positive integer

*DESC

This function returns {True} if {n} is a Carmichael number, also called an absolute pseudoprime.
They have the property that $ b^(n-1) % n == 1 $ for all $b$ satisfying $Gcd(b,n)==1$. These numbers
cannot be proved composite by Fermat's little theorem. Because the previous property is extremely
slow to test, the following equivalent property is tested by MathPiper: for all prime factors $p[i]$ of $n$,
$(n-1) % (p[i] - 1) == 0$ and $n$ must be square free. Also, Carmichael numbers must be odd and have
at least three prime factors. Although these numbers are rare (there are only 43 such numbers between $1$ and $10^6$),
it has recently been proven that there are infinitely many of them.

*E.G. notest

In> IsCarmichaelNumber(561)
Result: True;
In> EchoTime() Select(1 .. 10000, IsCarmichaelNumber)
	504.19 seconds taken
Result: {561,1105,1729,2465,2821,6601,8911};

*SEE IsSquareFree, IsComposite
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Eulerian.mpw0000644000175000017500000000113211523200452027217 0ustar  giovannigiovanni%mathpiper,def="Eulerian"

Eulerian(n_IsInteger,k_IsInteger) <-- Sum(j,0,k+1,(-1)^j*BinomialCoefficient(n+1,j)*(k-j+1)^n);

%/mathpiper



%mathpiper_docs,name="Eulerian",categories="User Functions;Combinatorics"
*CMD Eulerian --- Eulerian numbers
*STD
*CALL
	Eulerian(n,m)

*PARMS

{n}, {m} --- integers

*DESC

The Eulerian numbers can be viewed as a generalization of the binomial coefficients,
and are given explicitly by $$ Sum(j,0,k+1,(-1)^j*BinomialCoefficient(n+1,j)*(k-j+1)^n) $$ .

*E.G.

In> Eulerian(6,2)
Result: 302;
In> Eulerian(10,9)
Result: 1;

*SEE BinomialCoefficient
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/NumberToRep.mpw0000644000175000017500000001057411517224250027674 0ustar  giovannigiovanni%mathpiper,def="NumberToRep"

//Retract("NumberToRep",*);


10 # NumberToRep( N_IsNumber ) <--
[
    //If(InVerboseMode(),Tell(NumberToRep,N));
    Local(oldPrec,sgn,assoc,typ,val,prec,rep);
    oldPrec  := BuiltinPrecisionGet();
    BuiltinPrecisionSet(300);
    /*   NOTE: the above arbitrary 'magic number' is used because it is 
     *   currently necessary to set BuiltinPrecision to a value large 
     *   enough to handle any forseeable input.  Of course, even 300
     *   might not be enough!  I am looking for a way to base the 
     *   setting directly on the input number itself.                   */
     
    sgn      := Sign(N); 
    assoc    := DumpNumber(Abs(N));
    //If(InVerboseMode(),[ Tell("   ",assoc); Tell("   ",sgn); ]);
    typ := Assoc("type",assoc)[2];
    //If(InVerboseMode(),Tell("   ",typ));
    If( typ = "BigDecimal",
       [
          rep := { sgn*Assoc("unscaledValue",assoc)[2],
                   Assoc("precision",    assoc)[2],
                   Assoc("scale",        assoc)[2] 
                 };
       ],
       [
          Local(val,prec);
          val  := Assoc("value",assoc)[2];
          prec := Length(ExpressionToString(val));
          rep := { sgn*val, prec };
       ]
    );
    //If(InVerboseMode(),Tell("   ",rep));
    BuiltinPrecisionSet(oldPrec);
    rep;
];



12 # NumberToRep( N_IsComplex ) <-- 
[
    If(IsZero(Re(N)),
        {NumberToRep(0.0),NumberToRep(Im(N))},
        {NumberToRep(Re(N)),NumberToRep(Im(N))}
    );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

    





%mathpiper_docs,name="NumberToRep",categories="Programmer Functions;Numerical (Arbitrary Precision)"
*CMD NumberToRep --- returns a List showing MathPiper's internal representation of a number
*STD
*CALL
	NumberToRep(number)
	
*PARMS

{number} -- an Integer, Decimal, or Complex number


*DESC

Internally, MathPiper represents {arbitrary precision} numbers as Java BigIntegers or
BigDecimals.  Java code handles calculations using such numbers.

All the information needed to correctly understand the precision attached to a number,
and the rounding and comparison thereof, is contained in the Java structure.

For a Decimal number (essentially anything with a decimal point), the representation
consists of an arbitrary-precision integer containing {all} the significant digits of
the number, and a {scale factor} telling where the implied decimal point is supposed to
be placed with respect to the end of the integer.  The {precision} of the number is
just the number of digits in the integer.

The three components of the List returned for a decimal number are, respectively,
{{BigInteger (unscaled), Precision, ScaleFactor}}.
Note that the second of these is redundent: only the BigInteger and the ScaleFactor
are needed to completely define the number.

For an Integer number, the integer is its own representation, and again, the number of
its digits gives its precision.

For a Complex number, this function returns a List containing the representations of
the Real and Imaginary parts of the number.

The best way to {consistently} deal with precision and rounding issues is by making use
of the information given by this function.

*E.G.
    
In> NumberToRep(123.45678)
Result: {12345678,8,5}
    
In> NumberToRep(34700)
Result: {34700,5}
    
In> NumberToRep(1.5+6.75*I)
Result: {{150,3,2},{675,3,2}}
    
In> NumberToRep(123.45678E-10)
Result: {12345678,8,15}
   
In> NumberToRep(123.45678E+10)
Result: {12345678,8,-5}
    
NOTICE that the first, fourth, and fifth of these have the same 
BigInteger representation, and hence the same precision, namely 8.  
The ScaleFactor tells how many places the decimal point must be 
moved {leftward} from the {end} of the integer.  A negative 
ScaleFactor says to move the decimal point to the right -- 
i.e., effectively, add terminal zeros. However, if the number had 
originally been written as 1234567800000., it would actually have
a different representation, namely {1234567800000,13,0}.  That is
because, if we write those terminal zeros explicitly, they are assumed
to be "significant", and so the number is shown with precision 13.
Exponential notation must be used if the precision really is 8.

*SEE RepToNumber, DumpNumber
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/0000755000175000017500000000000011722677333030325 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianNorm.mpw0000644000175000017500000000072211523200452033440 0ustar  giovannigiovanni%mathpiper,def="GaussianNorm"

GaussianNorm(z_IsGaussianInteger) <-- Re(z)^2+Im(z)^2;

%/mathpiper



%mathpiper_docs,name="GaussianNorm",categories="User Functions;Number Theory"
*CMD GaussianNorm --- norm of a Gaussian integer
*STD
*CALL
	GaussianNorm(z)

*PARMS

{z} -- Gaussian integer

*DESC

This function returns the norm of a Gaussian integer $z=a+b*I$, defined as
$a^2+b^2$.

*E.G.

In> GaussianNorm(2+I)
Result: 5; 

*SEE IsGaussianInteger
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianGcd.mpw0000644000175000017500000000154411523200452033225 0ustar  giovannigiovanni%mathpiper,def="GaussianGcd"

10 # GaussianGcd(n_IsGaussianInteger,m_IsGaussianInteger) <--
[
	If(N(Abs(m))=0,n, GaussianGcd(m,n - m*Round(n/m) ) );
];

%/mathpiper



%mathpiper_docs,name="GaussianGcd",categories="User Functions;Number Theory"
*CMD GaussianGcd --- greatest common divisor in Gaussian integers
*STD
*CALL
	GaussianGcd(z,w)

*PARMS

{z}, {w} -- Gaussian integers 

*DESC

This function returns the greatest common divisor, in the ring of Gaussian
integers, computed using Euclid's algorithm. Note that in the Gaussian
integers, the greatest common divisor is only defined up to a Gaussian unit factor.

*E.G.

In> GaussianGcd(2+I,5)
Result: Complex(2,1);
The GCD of two mutually prime Gaussian integers might come out to be equal to some Gaussian unit instead of $1$:
In> GaussianGcd(2+I,3+I)
Result: -1;

*SEE Gcd, Lcm, IsGaussianUnit
%/mathpiper_docs././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianFactorPrime.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianFactorPrim0000644000175000017500000000110711320776303033777 0ustar  giovannigiovanni%mathpiper,def="GaussianFactorPrime"

/* GaussianFactorPrime(p): auxiliary function for Gaussian factors.
If p is a rational prime of the form 4n+1, we find a factor of p in the
Gaussian Integers. We compute
  a = (2n)!
By Wilson's theorem a^2 is -1 (mod p), it follows that

        p| (a+I)(a-I)

in the Gaussian integers. The desired factor is then the Gaussian GCD of a+i
and p. Note: If the result is Complex(a,b), then p=a^2+b^2 */

GaussianFactorPrime(p_IsInteger) <-- [
 Local(a,i);
 a := 1;
 For (i:=2,i<=(p-1)/2,i++) a := Modulo(a*i,p);
 GaussianGcd(a+I,p);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/IsGaussianUnit.mpw0000644000175000017500000000135111523200452033737 0ustar  giovannigiovanni%mathpiper,def="IsGaussianUnit"

IsGaussianUnit(z_IsGaussianInteger) <-- GaussianNorm(z)=1;

%/mathpiper



%mathpiper_docs,name="IsGaussianUnit",categories="User Functions;Number Theory;Predicates"
*CMD IsGaussianUnit ---  test for a Gaussian unit
*STD
*CALL
	IsGaussianUnit(z)
*PARMS

{z} -- a Gaussian integer	

*DESC

This function returns {True} if the argument is a unit in the Gaussian 
integers and {False} otherwise. A unit in a ring is an element that divides 
any other element.

There are four "units" in the ring of Gaussian integers, which are 
$1$, $-1$, $I$, and $-I$.
	
*E.G.
In> IsGaussianInteger(I)
Result: True;
In> IsGaussianUnit(5+6*I)
Result: False;

*SEE  IsGaussianInteger, IsGaussianPrime, GaussianNorm
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianMod.mpw0000644000175000017500000000016711316274015033255 0ustar  giovannigiovanni%mathpiper,def="GaussianMod"

GaussianMod(z_IsGaussianInteger,w_IsGaussianInteger) <-- z - w * Round(z/w);

%/mathpiper././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/IsGaussianInteger.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/IsGaussianInteger.0000644000175000017500000000200311523200452033664 0ustar  giovannigiovanni%mathpiper,def="IsGaussianInteger"

5  # IsGaussianInteger(x_IsList)	<-- False;

// ?????? why is the following rule needed?
// 5  # IsGaussianInteger(ProductPrimesTo257)	<-- False;

10 # IsGaussianInteger(x_IsComplex)  	<-- (IsInteger(Re(x)) And IsInteger(Im(x)));
// to catch IsGaussianInteger(x+2) from Apart
15 # IsGaussianInteger(_x)	<-- False;

%/mathpiper



%mathpiper_docs,name="IsGaussianInteger",categories="User Functions;Predicates"
*CMD IsGaussianInteger ---  test for a Gaussian integer
*STD
*CALL
	IsGaussianInteger(z)
*PARMS

{z} -- a complex or real number	

*DESC

This function returns {True} if the argument is a Gaussian integer and {False} otherwise.
A Gaussian integer is a generalization
of integers into the complex plane. A complex number $a+b*I$ is a Gaussian
integer if and only if $a$ and $b$ are integers.

*E.G.
In> IsGaussianInteger(5)
Result: True;
In> IsGaussianInteger(5+6*I)
Result: True;
In> IsGaussianInteger(1+2.5*I)
Result: False;

*SEE  IsGaussianUnit, IsGaussianPrime
%/mathpiper_docs././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/FactorGaussianInteger.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/FactorGaussianInte0000644000175000017500000000251611502266107033772 0ustar  giovannigiovanni%mathpiper,def="FactorGaussianInteger"

// Algorithm adapted from: Number Theory: A Programmer's Guide
//			Mark Herkommer
// Program 8.7.1c, p 264
// This function needs to be modified to return the factors in
// data structure instead of printing them out

// THIS FUNCTION IS DEPRECATED NOW!
// Use GaussianFactors instead (Pablo)
// I've leave this here so that you can compare the eficiency of one
// function against the other

Function("FactorGaussianInteger",{x}) [
	Check( IsGaussianInteger(x), "Argument", "FactorGaussianInteger: argument must be a Gaussian integer");
	Local(re,im,norm,a,b,d,i,j);

	re:=Re(x);im:=Im(x);

	If(re<0, re:=(-re) );
	If(im<0, im:=(-im) );
	norm:=re^2+im^2;

	if( IsComposite(norm) )[
		For(i:=0, i^2 <= norm, i++ )[	// real part
			For(j:=0, i^2 + j^2 <= norm, j++)[	// complex part
				if( Not( (i = re And j = im) Or
					 (i = im And j = re) ) )[ // no associates
					d:=i^2+j^2;
					if( d > 1 )[
						a := re * i + im * j;
						b := im * i - re * j;
						While( (Modulo(a,d) = 0) And  (Modulo(b,d) = 0) ) [
							FactorGaussianInteger(Complex(i,j));
							re:= a/d;
							im:= b/d;
							a := re * i + im * j;
							b := im * i - re * j;
							norm := re^2 + im^2;
						];
					];
				];
			];
		];
		If( re != 1 Or im != 0, Echo(Complex(re,im)) );
	] else [
		Echo(Complex(re,im));
	];
];

%/mathpiper././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/IsGaussianPrime.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/IsGaussianPrime.mp0000644000175000017500000000343211523200452033707 0ustar  giovannigiovanni%mathpiper,def="IsGaussianPrime"

Function("IsGaussianPrime",{x})
[
        if( IsGaussianInteger(x) )[
                if( IsZero(Re(x)) )[
                        ( Abs(Im(x)) % 4 = 3 And IsPrime(Abs(Im(x))) );
                ] else if ( IsZero(Im(x)) ) [
                        ( Abs(Re(x)) % 4 = 3 And IsPrime(Abs(Re(x))) );
                ] else [
                        IsPrime(Re(x)^2 + Im(x)^2);
                ];
        ] else [
                False;
        ];

];


/*
10 # IsGaussianPrime(p_IsInteger) <-- IsPrime(p) And Modulo(p,3)=1;
20 # IsGaussianPrime(p_IsGaussianInteger) <-- IsPrime(GaussianNorm(p));
*/

%/mathpiper



%mathpiper_docs,name="IsGaussianPrime",categories="User Functions;Number Theory;Predicates"
*CMD IsGaussianPrime ---  test for a Gaussian prime
*STD
*CALL
	IsGaussianPrime(z)
*PARMS

{z} -- a complex or real number

*DESC

This function returns {True} if the argument
is a Gaussian prime and {False} otherwise.

A prime element $x$ of a ring is divisible only by the units of
the ring and by associates of $x$.
("Associates" of $x$ are elements of the form $x*u$ where $u$ is
a unit of the ring).

Gaussian primes are Gaussian integers $z=a+b*I$ that satisfy one of the 
following properties:

*	If $Re(z)$ and $Im(z)$ are nonzero then $z$ is a Gaussian prime if and only 
if $Re(z)^2 + Im(z)^2$ is an ordinary prime.
*	If $Re(z)==0$ then $z$ is a Gaussian prime if and only if $Im(z)$ is an
ordinary prime and $Im(z):=Modulo(3,4)$.
*	If $Im(z)==0$ then $z$ is a Gaussian prime
if and only if $Re(z)$ is an ordinary prime and $Re(z):=Modulo(3,4)$.

*E.G.
In> IsGaussianPrime(13)
Result: False;
In> IsGaussianPrime(2+2*I)
Result: False;
In> IsGaussianPrime(2+3*I)
Result: True;
In> IsGaussianPrime(3)
Result: True;

*SEE  IsGaussianInteger, GaussianFactors
%/mathpiper_docs././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianFactors.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/gaussianintegers/GaussianFactors.mp0000644000175000017500000000653311522460262033753 0ustar  giovannigiovanni%mathpiper,def="GaussianFactors"

//Retract("GaussianFactors",*);


/* AddGaussianFactor: auxiliary function for Gaussian Factors.
L is a lists of factors of the Gaussian integer z and p is a Gaussian prime
that we want to add to the list. We first find the exponent e of p in the
decomposition of z (into Gaussian primes). If it is not zero, we add {p,e}
to the list */

AddGaussianFactor(L_IsList,z_IsGaussianInteger,p_IsGaussianInteger) <--
[
 Local(e);
 e :=0;
 While (IsGaussianInteger(z:= z/p)) e++;
 If (e != 0, DestructiveAppend(L,{p,e}));
];




/* 
GaussianFactors(n) : returns a list of factors of n, in a similar way to Factors(n).
If n is a rational integer, we factor n in the Gaussian integers, by first
factoring it in the rational integers, and after that factoring each of
its integer prime factors. 
*/

10 # GaussianFactors(n_IsInteger) <--
[
  // Chosing to factor this integer as a Gaussian Integer
  Local(ifactors,gfactors,p,alpha);
  ifactors := FactorizeInt(n);  // since we know it is an integer
  gfactors := {};
  ForEach(p,ifactors)
  [
     If (p[1]=2, [ DestructiveAppend(gfactors,{1+I,p[2]});
                   DestructiveAppend(gfactors,{1-I,p[2]}); ]);
     If (Modulo(p[1],4)=3, DestructiveAppend(gfactors,p));
     If (Modulo(p[1],4)=1, [ alpha := GaussianFactorPrime(p[1]);
                          DestructiveAppend(gfactors,{alpha,p[2]});
                          DestructiveAppend(gfactors,{Conjugate(alpha),p[2]});
                        ]);
  ];
gfactors;
];

/* 
If z is is a Gaussian integer, we find its possible Gassian prime factors,
by factoring its norm 
*/

20 # GaussianFactors(z_IsGaussianInteger) <--
[
 Local(n,nfactors,gfactors,p);
  gfactors :={};
  n := GaussianNorm(z);
  nfactors := Factors(n);
  ForEach(p,nfactors)
  [
   If (p[1]=2, [ AddGaussianFactor(gfactors,z,1+I);]);
   If (Modulo(p[1],4)=3, AddGaussianFactor(gfactors,z,p[1]));
   If (Modulo(p[1],4)=1, [ Local(alpha);
                        alpha := GaussianFactorPrime(p[1]);
                        AddGaussianFactor(gfactors,z,alpha);
                        AddGaussianFactor(gfactors,z,Conjugate(alpha));
                      ]);
 ];
 gfactors;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="GaussianFactors",categories="User Functions;Number Theory"
*CMD GaussianFactors --- factorization in Gaussian integers
*STD
*CALL
	GaussianFactors(z)

*PARMS

{z} -- Gaussian integer

*DESC

This function decomposes a Gaussian integer number {z} into a product of
Gaussian prime factors.
A Gaussian integer is a complex number with integer real and imaginary parts.
A Gaussian integer $z$ can be decomposed into Gaussian primes essentially in a
unique way (up to Gaussian units and associated prime factors), i.e. one
can write $z$ as
$$z = u*p[1]^n[1] * ... * p[s]^n[s]$$,
where $u$ is a Gaussian unit and $p[1]$, $p[2]$, ..., $p[s]$ are Gaussian primes. 

The factorization is returned as a list of pairs. The first member of
each pair is the factor (a Gaussian integer) and the second member denotes the power to
which this factor should be raised. So the factorization is returned as 
a list, e.g. {{{p1,n1}, {p2,n2}, ...}}.

*E.G.
In> GaussianFactors(5)
Result: {{Complex(2,1),1},{Complex(2,-1),1}};
In> GaussianFactors(3+I)
Result: {{Complex(1,1),1},{Complex(2,-1),1}};

*SEE Factors, IsGaussianPrime, IsGaussianUnit
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/DivisorsSum.mpw0000644000175000017500000000174511523200452027754 0ustar  giovannigiovanni%mathpiper,def="DivisorsSum"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Theorem 6.2 p112
5  # DivisorsSum(0)	<-- 0;
5  # DivisorsSum(1)	<-- 1;
10 # DivisorsSum(_n) 	<--
[
	Check(IsPositiveInteger(n), "Argument", "DivisorsSum: argument must be positive integer");
	Local(factors,i,sum,len,p,k);
	p:=0;k:=0;
	factors:={};
	factors:=Factors(n);
	len:=Length(factors);
	sum:=1;
	For(i:=1,i<=len,i++)[
		p:=factors[i][1];
		k:=factors[i][2];
		sum:=sum*(p^(k+1)-1)/(p-1);
	];
	sum;
];

%/mathpiper



%mathpiper_docs,name="DivisorsSum",categories="User Functions;Number Theory"
*CMD DivisorsSum --- the sum of  divisors
*STD
*CALL
	DivisorsSum(n)
*PARMS

{n}	-- positive integer

*DESC

{DivisorsSum} returns the sum all numbers that divide it. A number
{n} is prime if and only if the sum of its divisors are {n+1}.

*E.G.

In> DivisorsSum(180)
Result: 546;
In> DivisorsSum(37)
Result: 38;

*SEE DivisorsSum, ProperDivisors, ProperDivisorsSum, Moebius
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsSmallPrime.mpw0000644000175000017500000000355211523200452030024 0ustar  giovannigiovanni%mathpiper,def="IsSmallPrime"

/* Returns whether n is a small by a lookup table, very fast.
The largest prime number in the table is returned by FastIsPrime(0). */

2 # IsSmallPrime(0) <-- False;
3 # IsSmallPrime(n_IsInteger) <-- (FastIsPrime(n)>0);

%/mathpiper



%mathpiper_docs,name="IsSmallPrime",categories="User Functions;Number Theory;Predicates"
*CMD IsPrime --- test for a prime number
*CMD IsSmallPrime --- test for a (small) prime number
*STD
*CALL
	IsPrime(n)
	IsSmallPrime(n)

*PARMS

{n} -- integer to test

*DESC

The commands checks whether $n$, which should be a positive integer,
is a prime number. A number $n$ is a prime number if it is only divisible
by 1 and itself. As a special case, 1 is not considered a prime number.
The first prime numbers are 2, 3, 5, ...

The function {IsShortPrime} only works for numbers $n<=65537$ but it is very fast.

The function {IsPrime} operates on all numbers and uses different algorithms depending on the magnitude of the number $n$.
For small numbers $n<=65537$, a constant-time table lookup is performed.
(The function {IsShortPrime} is used for that.)
For numbers $n$ between $65537$ and $34155071728321$, the function uses the Rabin-Miller test together with table lookups to guarantee correct results.

For even larger numbers a version of the probabilistic Rabin-Miller test is executed.
The test can sometimes mistakenly mark a number as prime while it is in fact composite, but a prime number will never be mistakenly declared composite.
The parameters of the test are such that the probability for a false result is less than $10^(-24)$.

*E.G.

In> IsPrime(1)
Result: False;
In> IsPrime(2)
Result: True;
In> IsPrime(10)
Result: False;
In> IsPrime(23)
Result: True;
In> Select(1 .. 100, "IsPrime")
Result: {2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,
	  53,59,61,67,71,73,79,83,89,97};

*SEE IsPrimePower, Factors
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsCoprime.mpw0000644000175000017500000000134511523200452027353 0ustar  giovannigiovanni%mathpiper,def="IsCoprime"

5  # IsCoprime(list_IsList)                     <-- (Lcm(list) = Product(list));
10 # IsCoprime(n_IsInteger,m_IsInteger)		<-- (Gcd(n,m) = 1);

%/mathpiper



%mathpiper_docs,name="IsCoprime",categories="User Functions;Number Theory;Predicates"
*CMD IsCoprime --- test if integers are coprime 
*STD
*CALL
	IsCoprime(m,n)
	IsCoprime(list)
*PARMS

{m},{n} -- positive integers

{list}  -- list of positive integers

*DESC

This function returns {True} if the given pair or list of integers are coprime,
also called relatively prime. A pair or list of numbers are coprime if they 
share no common factors.

*E.G.

In> IsCoprime({3,4,5,8})
Result: False;
In> IsCoprime(15,17)
Result: True;

*SEE Prime
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/Repunit.mpw0000644000175000017500000000021711316274015027112 0ustar  giovannigiovanni%mathpiper,def="Repunit"

10 # 	Repunit(0)	<-- 0;
// Number consisting of n 1's
Repunit(n_IsPositiveInteger) <--
[
	(10^n-1)/9;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/GetPrimePower.mpw0000644000175000017500000000332411316274015030217 0ustar  giovannigiovanni%mathpiper,def="GetPrimePower"

/// Check whether n is a power of some prime integer and return that integer and the power.
/// This routine uses only integer arithmetic.
/// Returns {p, s} where p is a prime and n=p^s.
/// If no powers found, returns {n, 1}. Primality testing of n is not done.
20 # GetPrimePower(n_IsPositiveInteger) <--
[
	Local(s, factors, new'factors);
	// first, separate any small prime factors
	factors := TrialFactorize(n, 257);	// "factors" = {n1, {p1,s1},{p2,s2},...} or just {n} if no factors found
	If(
		Length(factors) > 1,	// factorized into something
		// now we return {n, 1} either if we haven't completely factorized, or if we factorized into more than one prime factor; otherwise we return the information about prime factors
		If(
			factors[1] = 1 And Length(factors) = 2,	// factors = {1, {p, s}}, so we have a prime power n=p^s
			factors[2],
			{n, 1}
		),
		// not factorizable into small prime factors -- use main algorithm
		[
			factors := CheckIntPower(n, 257);	// now factors = {p, s} with n=p^s
			If(
				factors[2] > 1,	// factorized into something
				// now need to check whether p is a prime or a prime power and recalculate "s"
				If(
					IsPrime(factors[1]),
					factors,	// ok, prime power, return information
					[	// not prime, need to check if it's a prime power
						new'factors := GetPrimePower(factors[1]);	// recursive call; now new'factors = {p1, s1} where n = (p1^s1)^s; we need to check that s1>1
						If(
							new'factors[2] > 1,
							{new'factors[1], new'factors[2]*factors[2]},	// recalculate and return prime power information
							{n, 1}	// not a prime power
						);
					]
				),
				// not factorizable -- return {n, 1}
				{n, 1}
			);
		]
	);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsIrregularPrime.mpw0000644000175000017500000000226611523200452030711 0ustar  giovannigiovanni%mathpiper,def="IsIrregularPrime"

5  # IsIrregularPrime(p_IsComposite)	<-- False;
// First irregular prime is 37
5  # IsIrregularPrime(_p)_(p<37)	<-- False;

// an odd prime p is irregular iff p divides the numerator of a Bernoulli number B(2*n) with
// 2*n+1
     IsIrregularPrime(5)
Result: False;
In> Select(1 .. 100, IsIrregularPrime)
Result: {37,59,67};

*SEE IsPrime
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/DigitalRoot.mpw0000644000175000017500000000025611316274015027710 0ustar  giovannigiovanni%mathpiper,def="DigitalRoot"

// Digital root of n (repeatedly add digits until reach a single digit).
10 # DigitalRoot(n_IsPositiveInteger) <-- If(n%9=0,9,n%9);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/NextPrime.mpw0000644000175000017500000000140111523200452027365 0ustar  giovannigiovanni%mathpiper,def="NextPrime"

/// obtain the real next prime number -- use primality testing
1# NextPrime(_i) <--
[
	Until(IsPrime(i)) i := NextPseudoPrime(i);
	i;
];

%/mathpiper



%mathpiper_docs,name="NextPrime",categories="User Functions;Number Theory"
*CMD NextPrime --- generate a prime following a number
*STD
*CALL
	NextPrime(i)

*PARMS

{i} -- integer value

*DESC

The function finds the smallest prime number that is greater than the given
integer value.

The routine generates "candidate numbers" using the formula $n+2*Modulo(-n,3)$
where $n$ is an odd number (this generates the sequence 5, 7, 11, 13, 17,
19, ...) and {IsPrime()} to test whether the next candidate number is in
fact prime.

*E.G.
In> NextPrime(5)
Result: 7;

*SEE IsPrime
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/HarmonicNumber.mpw0000644000175000017500000000156611523200452030377 0ustar  giovannigiovanni%mathpiper,def="HarmonicNumber"

10 # 	HarmonicNumber(n_IsInteger)	<-- HarmonicNumber(n,1);
HarmonicNumber(n_IsInteger,r_IsPositiveInteger) <--
[
	// small speed up
	if( r=1 )[
		Sum(k,1,n,1/k);
	] else [
		Sum(k,1,n,1/k^r);
	];
];

%/mathpiper



%mathpiper_docs,name="HarmonicNumber",categories="User Functions;Number Theory"
*CMD HarmonicNumber --- return the {n}th Harmonic Number
*STD
*CALL
	HarmonicNumber(n)
	HarmonicNumber(n,r)
*PARMS

{n}, {r}	-- positive integers

*DESC

This function returns the {n}-th Harmonic number, which is defined
as $Sum(k,1,n,1/k)$. If given a second argument, the Harmonic number
of order $r$ is returned, which is defined as $Sum(k,1,n,k^(-r))$.

*E.G.

In> HarmonicNumber(10)
Result: 7381/2520;
In> HarmonicNumber(15)
Result: 1195757/360360;
In> HarmonicNumber(1)
Result: 1;
In> HarmonicNumber(4,3)
Result: 2035/1728;



*SEE Sum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsPrimePower.mpw0000644000175000017500000000222111523200452030040 0ustar  giovannigiovanni%mathpiper,def="IsPrimePower"

/* Returns whether n is a prime^m. */
10 # IsPrimePower(n_IsPrime) <-- True;
10 # IsPrimePower(0) <-- False;
10 # IsPrimePower(1) <-- False;
20 # IsPrimePower(n_IsPositiveInteger) <-- (GetPrimePower(n)[2] > 1);

%/mathpiper



%mathpiper_docs,name="IsPrimePower",categories="User Functions;Number Theory;Predicates"
*CMD IsPrimePower --- test for a power of a prime number
*STD
*CALL
	IsPrimePower(n)

*PARMS

{n} -- integer to test

*DESC

This command tests whether "n", which should be a positive integer,
is a prime power, that is whether it is of the form $p^m$, with
"p" prime and "m" an integer.

This function does not try to decompose the number $n$ into factors.
Instead we check for all prime numbers $r=2$, $3$, ... that the $r$-th root of $n$ is an integer, and we find such $r$ and $m$ that $n=m^r$, we check that $m$ is a prime. If it is not a prime, we execute the same function call on $m$.

*E.G.

In> IsPrimePower(9)
Result: True;
In> IsPrimePower(10)
Result: False;
In> Select(1 .. 50, "IsPrimePower")
Result: {2,3,4,5,7,8,9,11,13,16,17,19,23,25,27,
	  29,31,32,37,41,43,47,49};

*SEE IsPrime, Factors
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/FermatNumber.mpw0000644000175000017500000000110611523200452030043 0ustar  giovannigiovanni%mathpiper,def="FermatNumber"

Function("FermatNumber",{n})[
	Check(IsPositiveInteger(n), "Argument", "FermatNumber: argument must be a positive integer");
	2^(2^n)+1;
];

%/mathpiper



%mathpiper_docs,name="FermatNumber",categories="User Functions;Number Theory"
*CMD FermatNumber --- return the {n}th Fermat Number
*STD
*CALL
	FermatNumber(n)
*PARMS  

{n}     -- positive integer

*DESC

This function returns the {n}-th Fermat number, which is defined as
$2^(2^n) + 1$. 

*E.G.

In> FermatNumber(7)
Result: 340282366920938463463374607431768211457;

*SEE	Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/CheckIntPower.mpw0000644000175000017500000000157611371733712030207 0ustar  giovannigiovanni%mathpiper,def="CheckIntPower"

/// Check whether n is a power of some integer, assuming that it has no prime factors <= limit.
/// This routine uses only integer arithmetic.
/// Returns {p, s} where s is the smallest prime integer such that n=p^s. (p is not necessarily a prime!)
/// If no powers found, returns {n, 1}. Primality testing of n is not done.
CheckIntPower(n, limit) :=
[
	Local(s0, s, root);
	If(limit<=1, limit:=2);	// guard against too low value of limit
	// compute the bound on power s
	s0 := IntLog(n, limit);
	// loop: check whether n^(1/s) is integer for all prime s up to s0
	root := 0;
	s := 0;
	While(root = 0 And NextPseudoPrime(s)<=s0)	// root=0 while no root is found
	[
		s := NextPseudoPrime(s);
		root := IntNthRoot(n, s);
		If(
			root^s = n,	// found root
			True,
			root := 0
		);
	];
	// return result
	If(
		root=0,
		{n, 1},
		{root, s}
	);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/BellNumber.mpw0000644000175000017500000000015411316274015027513 0ustar  giovannigiovanni%mathpiper,def="BellNumber"

10 # BellNumber(n_IsInteger)		<-- Sum(k,1,n,StirlingNumber2(n,k));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/RoundToPrecision.mpw0000644000175000017500000001720611517224250030737 0ustar  giovannigiovanni%mathpiper,def="RoundToPrecision"

//Retract("RoundToPrecision",*);

10 # RoundToPrecision( N_IsDecimal, newPrec_IsPositiveInteger ) <--
[
    //If(InVerboseMode(),Tell("RoundToPrecision_D",{N,newPrec}));
    Local(rep,sgn,oldInt,oldPrec,oldScale,strOInt,LS,BIP0);
    Local(newInt,newScale,newRep,ans);
    BIP0     := BuiltinPrecisionGet();
    sgn      := Sign(N);
    rep      := NumberToRep( If(sgn<0,-N,N) );
    oldInt   := rep[1];
    oldPrec  := rep[2];
    oldScale := rep[3];
    If( newPrec > oldPrec, BuiltinPrecisionSet(newPrec) );
    strOInt  := ExpressionToString(oldInt);
    LS       := Length(strOInt);
    //If(InVerboseMode(),
    //   [
    //      Tell("   ",rep);
    //      Tell("         ",oldInt);
    //      Tell("         ",strOInt);
    //      Tell("         ",LS);
    //      Tell("         ",{newPrec,oldPrec});
    //   ]
    //);
    
    Local(first,secnd,rem,ad);
    if ( newPrec = oldPrec )
        [ ans := N; ]
    else if ( newPrec < oldPrec )
        [
            first    := StringMidGet(1, newPrec, strOInt); 
            secnd    := StringMidGet(newPrec+1, LS-newPrec, strOInt);
            rem      := ToAtom(ConcatStrings(".",secnd));
            ad       := If(rem>=0.5, 1, 0 );
            newInt   := sgn * ( ToAtom(first) + ad );
            newScale := oldScale - ( oldPrec - newPrec ); 
            newRep   := {newInt,newPrec,newScale};
            ans      := RepToNumber(newRep);
            //If(InVerboseMode(),
            //   [
            //      Tell("         ",{first,secnd});
            //      Tell("         ",{rem,ad});
            //      Tell("         ",newRep);
            //      Tell("         ",ans);
            //   ]
            //);
        ]
    else
        [
            //If(InVerboseMode(),Tell("   newPrec > oldPrec "));
            Local(diffPrec);
            diffPrec := oldPrec - newPrec;
            newInt   := sgn * ToAtom(strOInt) * 10^(-diffPrec) ;
            newScale := oldScale - diffPrec;
            newRep   := {newInt,newPrec,newScale};
            //If(InVerboseMode(),[Tell("         ",diffPrec);Tell("         ",newRep);]);
            ans      := RepToNumber(newRep);
        ];
    BuiltinPrecisionSet(BIP0);
    ans;
];


15 # RoundToPrecision( N_IsInteger, newPrec_IsPositiveInteger ) <--
[
    //If(InVerboseMode(),Tell("RoundToPrecision_I",{N,newPrec}));
    Local(oldRep,oldPrec,decN,newDecN,ans);
    oldRep   := NumberToRep(N);
    oldPrec  := oldRep[2];
    decN     := N*1.0;
    newDecN  := RoundToPrecision( decN, newPrec );
    //If(InVerboseMode(),Tell("    ",oldRep));
    //If(InVerboseMode(),Tell("   ",oldPrec));
    //If(InVerboseMode(),Tell("   ",newPrec));
    //If(InVerboseMode(),Tell("   ",newDecN));
    If( newPrec <= oldPrec, 
        ans := Round(newDecN),
        ans := Round(newDecN*10^(newPrec-oldPrec))
    );
    ans;
];


20 # RoundToPrecision( N_IsComplex, newPrec_IsPositiveInteger ) <--
[
    //If(InVerboseMode(),Tell("RoundToPrecision_C",{N,newPrec}));
    Local(rr,ii);
    rr := Re(N);
    ii := Im(N);
    Complex(RoundToPrecision(rr,newPrec),RoundToPrecision(ii,newPrec));
];

%/mathpiper

  
   

    



%mathpiper_docs,name="RoundToPrecision",categories="Programmer Functions;Numerical (Arbitrary Precision)"
*CMD RoundToPrecision --- Rounds or Sets a number to the specified precision
*STD
*CALL
	RoundToPrecision(number,precision)
*PARMS
{number} -- a number (Decimal, Integer, or Complex) whose precision is to be changed
{precision} -- the new precision to be used


*DESC
This function changes the precision of an {arbitrary-precision number} (A.P.N.).
If the new precision is less than the original precision, the {significand}
will be appropriately rounded.  If the new precision is greater than the 
original precision, terminal zeros will be appended to the {significand}
and the indicated precision will be reset accordingly.

Internally, MathPiper represents an A.P.N. as Java a BigIntegers or
BigDecimal.  Java code handles calculations using such numbers.

All the information needed to correctly understand the precision attached to a number,
and the rounding and comparison thereof, is contained in the Java structure.

For a Decimal number (essentially anything with a decimal point), the representation
consists of an arbitrary-precision integer (called the {significand}) containing {all}
the significant digits of the number, and a {scale factor} telling where the implied 
decimal point is supposed to be placed with respect to the end of this integer.  
The {precision} of the number is usually just the number of digits in the 
{significand}.

The three components of the List representing a decimal number are, respectively,
{{BigInteger (unscaled), Precision, ScaleFactor}}.
Note that the second of these is redundent: only the BigInteger and the ScaleFactor
are needed to completely define the number.  The name 'BigInteger' is Java's
terminology for the {significand}.

For an Integer number, the integer is its own significand, and again, the number of
its digits gives its precision.  The representation is still a list, with the number
as first component and its precision as second.

For a Complex number, the representation is a List of Lists,
containing the representations of the Real and Imaginary parts of the number.

The best way to {consistently} deal with precision and rounding issues is by making use
of the information given by the representation (or "rep" for short)..

NOTE:  It is important to recognize the distinction (often misused or misunderstood)
between rounding "to a specified precision" (which this function does) and rounding
"to a specified number of decimal places", which in MathPiper is accomplished by
the function {RoundToPlace} (q.v.).  

For Decimal numbers and Decimal Complex numbers, the concept of Rounding DOWN to a 
given precision is well understood, and the concept of Rounding UP is pretty
clear also.  

However, for Integers and Complex Integers (Gaussian Integers), the
concept of Rounding down is somewhat obscure, and the concept of Rounding up 
makes very little sense at all.  An 8-digit integer, when rounded DOWN to 5
digits of precision, remains an 8-digit integer still, but the last 3 digits
have become zeros; the original number is still approximated by the new one.
But an 8-digit integer, when rounded UP to 10 digits of precision, has
two trailing zeros appended to it.  In the latter case, the new integer is
arguably not any kind of approximation of the old one.  

On the whole, it is probably best NOT to round integers UP.
*E.G.
In> dec:=123.45678
Result: 123.45678
In> NumberToRep(dec)
Result: {12345678,8,5}

In> dec2:=RoundToPrecision(dec,5)
Result: 123.46
In> NumberToRep(dec2)
Result: {12346,5,2}

In> dec3:=RoundToPrecision(dec,10)
Result: 123.4567800
In> NumberToRep(dec3)
Result: {1234567800,10,7}

In> cmplx:=12.345-I*567.891
Result: Complex(12.345,-567.891)
In> NumberToRep(cmplx)
Result: {{12345,5,3},{-567891,6,3}}

In> cmplx2:=RoundToPrecision(cmplx,4)
Result: Complex(12.34,-567.9)
In> NumberToRep(cmplx2)
Result: {{1234,4,2},{-5679,4,1}}

In> cmplx3:=RoundToPrecision(cmplx,8)
Result: Complex(12.345000,-567.89100)
In> NumberToRep(cmplx3)
Result: {{12345000,8,6},{-56789100,8,5}}

In> int:=12345678
Result: 12345678
In> NumberToRep(int)
Result: {12345678,8}

In> int2:=RoundToPrecision(int,5)
Result: 12346000
In> NumberToRep(int2)
Result: {12346000,8}

In> int3:=RoundToPrecision(int,10)
Result: 1234567800
In> NumberToRep(int3)
Result: {1234567800,10}
*SEE RoundToPlace, RoundToN, NumberToRep, DumpNumber
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/StirlingNumber2.mpw0000644000175000017500000000135011523200452030503 0ustar  giovannigiovanni%mathpiper,def="StirlingNumber2"

10 # StirlingNumber2(n_IsInteger,0) <-- If(n=0,1,0);
20 # StirlingNumber2(n_IsInteger,k_IsInteger) <-- Sum(i,0,k-1,(-1)^i*BinomialCoefficient(k,i)*(k-i)^n)/ k! ;

%/mathpiper



%mathpiper_docs,name="StirlingNumber2",categories="User Functions;Number Theory"
*CMD StirlingNumber2 --- return the {n m}th Stirling Number of the second kind
*STD
*CALL
        StirlingNumber1(n,m)
*PARMS

{n}, {m}        -- positive integers

*DESC

This function returns the Stirling Number of the second kind.
All Stirling Numbers are positive integers. If $ m > n $, then {StirlingNumber2} returns
$0$.

*E.G.

In> StirlingNumber2(3,6)
Result: 0;
In> StirlingNumber2(10,4)
Result: 34105;

*SEE StirlingNumber1
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/LegendreSymbol.mpw0000644000175000017500000000172211523200452030373 0ustar  giovannigiovanni%mathpiper,def="LegendreSymbol"

// Algorithm adapted from:
// Elementary Number Theory, David M. Burton
// Definition 9.2 p191

10 # LegendreSymbol(_a,_p)	<--
[
        Check( IsInteger(a) And IsInteger(p) And p>2 And IsCoprime(a,p) And IsPrime(p),
                "Argument", "LegendreSymbol: Invalid arguments");
	If(IsQuadraticResidue(a,p), 1, -1 );
];

%/mathpiper



%mathpiper_docs,name="LegendreSymbol",categories="User Functions;Number Theory"
*CMD LegendreSymbol --- functions related to finite groups
*STD
*CALL
	LegendreSymbol(m,n)

*PARMS
{m}, {n} -- integers, $n$ must be odd and positive

*DESC

The Legendre symbol ($m$/$n$) is defined as $+1$ if $m$ is a quadratic residue modulo $n$ and $-1$ if it is a non-residue.
The Legendre symbol is equal to $0$ if $m/n$ is an integer.

*E.G.

In> IsQuadraticResidue(9,13)
Result: True;
In> LegendreSymbol(15,23)
Result: -1;
In> JacobiSymbol(7,15)
Result: -1;

*SEE Gcd, JacobiSymbol, IsQuadraticResidue
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/ProductPrimesTo257.mpw0000644000175000017500000000045011371733712031031 0ustar  giovannigiovanni%mathpiper,def="ProductPrimesTo257"

/// Product of small primes <= 257. Computed only once.
LocalSymbols(p, q)
[
	// p:= 1;
	ProductPrimesTo257() := 2*3*[
		If(
			IsInteger(p),
			p,
			p := Product(Select( 5 .. 257, {{q}, Modulo(q^2,24)=1 And IsSmallPrime(q)}))
		);
//		p;
	];
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsAmicablePair.mpw0000644000175000017500000000135211523200452030264 0ustar  giovannigiovanni%mathpiper,def="IsAmicablePair"

IsAmicablePair(m_IsPositiveInteger,n_IsPositiveInteger) <-- ( ProperDivisorsSum(m)=n And ProperDivisorsSum(n)=m );

%/mathpiper



%mathpiper_docs,name="IsAmicablePair",categories="User Functions;Number Theory;Predicates"
*CMD IsAmicablePair --- test for a pair of amicable numbers
*STD
*CALL
	IsAmicablePair(m,n)

*PARMS

{m}, {n} -- positive integers

*DESC

This function tests if a pair of numbers are amicable. A pair of 
numbers $m$, $n$ has this property if the sum of the proper divisors of $m$ is
$n$ and the sum of the proper divisors of $n$ is $m$.

*E.G.

In> IsAmicablePair(200958394875, 209194708485 )
Result: True;
In> IsAmicablePair(220, 284)
Result: True;

*SEE ProperDivisorsSum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/IsPerfect.mpw0000644000175000017500000000014311316274015027346 0ustar  giovannigiovanni%mathpiper,def="IsPerfect"

IsPerfect(n_IsPositiveInteger) <-- ProperDivisorsSum(n)=n;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/nthroot/0000755000175000017500000000000011722677333026447 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/numbers/CatalanNumber.mpw0000644000175000017500000000116011523200452030170 0ustar  giovannigiovanni%mathpiper,def="CatalanNumber"

CatalanNumber(_n) <--
[
	Check( IsPositiveInteger(n), "Argument", "CatalanNumber: Error: argument must be positive" );
	BinomialCoefficient(2*n,n)/(n+1);
];

%/mathpiper



%mathpiper_docs,name="CatalanNumber",categories="User Functions;Number Theory"
*CMD CatalanNumber --- return the {n}th Catalan Number
*STD
*CALL
	CatalanNumber(n)
*PARMS

{n}	-- positive integer

*DESC

This function returns the {n}-th Catalan number, defined as $BinomialCoefficient(2*n,n)/(n+1)$.

*E.G.

In> CatalanNumber(10)
Result: 16796;
In> CatalanNumber(5)
Result: 42;

*SEE BinomialCoefficient
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/assoc/0000755000175000017500000000000011722677332024406 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/assoc/AssocValues.mpw0000644000175000017500000000150011523200452027337 0ustar  giovannigiovanni%mathpiper,def="AssocValues"

AssocValues(assocvalueslist_IsList) <--
  DestructiveReverse(MapSingle(Lambda({x},First(Rest(x))),assocvalueslist));

%/mathpiper



%mathpiper_docs,name="AssocValues",categories="User Functions;Lists (Operations)",access="experimental"
*CMD AssocValues --- return the values in an association list
*STD
*CALL
	AssocValues(alist)

*PARMS

{alist} -- association list to examine

*DESC

All the values in the association list "alist" are assembled in a list
and this list is returned.

*E.G.

In> writer := {};
Result: {};
In> writer["Iliad"] := "Homer";
Result: True;
In> writer["Henry IV"] := "Shakespeare";
Result: True;
In> writer["Ulysses"] := "James Joyce";
Result: True;
In> AssocIndices(writer);
Result: {"Homer","ShakespeareJames Joyce"};

*SEE Assoc, AssocDelete, AssocIndices
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/assoc/AssocDelete.mpw0000644000175000017500000000441511523200452027312 0ustar  giovannigiovanni%mathpiper,def="AssocDelete"

/// Delete an element of an associative list.
LocalSymbols(hash, key, element, hash'expr)
[

/// AssocDelete(hash,{"key", value})
10 # AssocDelete(hash_IsList, element_IsList) <--
[
	Local(index);
	index := Find(hash, element);
	If(
		index > 0,
		DestructiveDelete(hash, index)
	);
	index>0;	// return False if nothing found

];


/// AssocDelete(hash, "key")
20 # AssocDelete(hash_IsList, key_IsString) <--
[
	AssocDelete(hash, Builtin'Assoc(key, hash));
];

30 # AssocDelete(hash_IsList, Empty) <-- False;

//HoldArgument("AssocDelete", hash);
//UnFence("AssocDelete", 1);
//UnFence("AssocDelete", 2);

];	// LocalSymbols(hash, ...)

%/mathpiper



%mathpiper_docs,name="AssocDelete",categories="User Functions;Lists (Operations)"
*CMD AssocDelete --- delete an entry in an association list
*STD
*CALL
	AssocDelete(alist, "key")
	AssocDelete(alist, {key, value})

*PARMS

{alist} -- association list

{"key"} -- string, association key

{value} -- value of the key to be deleted

*DESC

The key {"key"} in the association list {alist} is deleted. (The list itself is modified.) If the key was found and successfully deleted, returns {True}, otherwise if the given key was not found, the function returns {False}.

The second, longer form of the function deletes the entry that has both the
specified key and the specified value. It can be used for two purposes:
*	1. to make sure that we are deleting the right value;
*	2. if several values are stored on the same key, to delete the specified entry (see the last example).

At most one entry is deleted.

*E.G.

In> writer := {};
Result: {};
In> writer["Iliad"] := "Homer";
Result: True;
In> writer["Henry IV"] := "Shakespeare";
Result: True;
In> writer["Ulysses"] := "James Joyce";
Result: True;
In> AssocDelete(writer, "Henry IV")
Result: True;
In> AssocDelete(writer, "Henry XII")
Result: False;
In> writer
Result: {{"Ulysses","James Joyce"},
	  {"Iliad","Homer"}};
In> DestructiveAppend(writer,
	  {"Ulysses", "Dublin"});
Result: {{"Iliad","Homer"},{"Ulysses","James Joyce"},
	  {"Ulysses","Dublin"}};
In> writer["Ulysses"];
Result: "James Joyce";
In> AssocDelete(writer,{"Ulysses","James Joyce"});
Result: True;
In> writer
Result: {{"Iliad","Homer"},{"Ulysses","Dublin"}};


*SEE Assoc, AssocIndices, AssocValues
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/assoc/AssocIndices.mpw0000644000175000017500000000142511523200452027464 0ustar  giovannigiovanni%mathpiper,def="AssocIndices"

AssocIndices(associndiceslist_IsList) <--
  DestructiveReverse(MapSingle("First",associndiceslist));

%/mathpiper



%mathpiper_docs,name="AssocIndices",categories="User Functions;Lists (Operations)"
*CMD AssocIndices --- return the keys in an association list
*STD
*CALL
	AssocIndices(alist)

*PARMS

{alist} -- association list to examine

*DESC

All the keys in the association list "alist" are assembled in a list
and this list is returned.

*E.G.

In> writer := {};
Result: {};
In> writer["Iliad"] := "Homer";
Result: True;
In> writer["Henry IV"] := "Shakespeare";
Result: True;
In> writer["Ulysses"] := "James Joyce";
Result: True;
In> AssocIndices(writer);
Result: {"Iliad","Henry IV","Ulysses"};

*SEE Assoc, AssocDelete, AssocValues
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/assoc/Assoc.mpw0000644000175000017500000000247311523200452026171 0ustar  giovannigiovanni%mathpiper,def="Assoc"

/* Assoc : given an assoc list like for example l:={{a,2},{b,3}},
   Assoc(b,l) will return {b,3}. if the key is not in the list,
   it will return the atom Empty.
*/

Function("Assoc",{key,list})  Builtin'Assoc(key,list);

%/mathpiper



%mathpiper_docs,name="Assoc",categories="User Functions;Lists (Operations)"
*CMD Assoc --- return element stored in association list
*STD
*CALL
	Assoc(key, alist)

*PARMS

{key} -- string, key under which element is stored

{alist} -- association list to examine

*DESC

The association list "alist" is searched for an entry stored with
index "key". If such an entry is found, it is returned. Otherwise
the atom {Empty} is returned.

Association lists are represented as a list of two-entry lists. The
first element in the two-entry list is the key, the second element is
the value stored under this key.

The call {Assoc(key, alist)} can (probably more
intuitively) be accessed as {alist[key]}.

*E.G.

In> writer := {};
Result: {};
In> writer["Iliad"] := "Homer";
Result: True;
In> writer["Henry IV"] := "Shakespeare";
Result: True;
In> writer["Ulysses"] := "James Joyce";
Result: True;
In> Assoc("Henry IV", writer);
Result: {"Henry IV","Shakespeare"};
In> Assoc("War and Peace", writer);
Result: Empty;

*SEE AssocIndices, [], :=, AssocDelete, AssocValues
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/debug/0000755000175000017500000000000011722677326024367 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/debug/verbose_mode.mpw0000644000175000017500000000237611523200452027552 0ustar  giovannigiovanni%mathpiper,def="V;InVerboseMode"

LocalSymbols(Verbose) [

  Bind(Verbose,False);


  Function("V",{aNumberBody})
  [
    Local(prevVerbose,result);
    Bind(prevVerbose,Verbose);
    Bind(Verbose,True);
    Bind(result,Eval(aNumberBody));
    Bind(Verbose,prevVerbose);
    result;
  ];


  Function("InVerboseMode",{}) Verbose;

]; // LocalSymbols(Verbose)

HoldArgument("V",aNumberBody);
UnFence("V",1);

%/mathpiper





%mathpiper_docs,name="V;InVerboseMode",categories="User Functions;Input/Output"
*CMD V, InVerboseMode --- set verbose output mode
*STD
*CALL
	V(expression)
	InVerboseMode()

*PARMS

{expression} -- expression to be evaluated in verbose mode

*DESC

The function {V(expression)} will evaluate the expression in
verbose mode. Various parts of MathPiper can show extra information
about the work done while doing a calculation when using {V}.

In verbose mode, {InVerboseMode()} will return {True}, otherwise
it will return {False}.

*E.G. notest

In> OldSolve({x+2==0},{x})
Result: {{-2}};
In> V(OldSolve({x+2==0},{x}))
	Entering OldSolve
	From  x+2==0  it follows that  x  = -2
	   x+2==0  simplifies to  True
	Leaving OldSolve
Result: {{-2}};
In> InVerboseMode()
Result: False
In> V(InVerboseMode())
Result: True

*SEE Echo, N, OldSolve
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/debug/debug.mpw0000644000175000017500000002072311523200452026163 0ustar  giovannigiovanni%mathpiper,def="TraceExp;Debug;Profile;DebugRun;DebugStep;DebugStepOver;DebugBreakAt;DebugRemoveBreakAt;DebugStop;DebugVerbose;DebugAddBreakpoint;BreakpointsClear;DebugCallstack;DebugBreakIf;DebugLocals;EchoTime;DebugShowCode"

/* def file definitions
TraceExp
Debug
Profile
DebugRun
DebugStep
DebugStepOver
DebugBreakAt
DebugRemoveBreakAt
DebugStop
DebugVerbose
DebugAddBreakpoint
BreakpointsClear
DebugCallstack
DebugBreakIf
DebugLocals
EchoTime
DebugShowCode
*/

LocalSymbols(TraceStart,TraceEnter,TraceLeave,DebugStart,DebugEnter,
             DebugLeave,ProfileStart,ProfileEnter,result,
             WriteLines,ClearScreenString,Debug'FileLoaded, Debug'FileLines, Debug'NrLines,
             debugstepoverfile, debugstepoverline) [

TraceStart() := [indent := 0;];
TraceEnter() :=
[
    indent++;
    Space(2*indent);
    Echo("Enter ",CustomEval'Expression());
];
TraceLeave() :=
[
    Space(2*indent);
    Echo("Leave ",CustomEval'Result());
    indent--;
];
Macro(TraceExp,{expression})
[
    TraceStart();
    CustomEval(TraceEnter(),TraceLeave(),CustomEval'Stop(),@expression);
];



DebugStart():=
[
   debugging:=True;
   debugstopdepth := -1;
   breakpoints:={};
   filebreakpoints := {};
   debugstopped:=False;
   debugverbose:=False;
   debugcallstack:={};
   breakpredicate:=False;
];
DebugRun():= [debugging:=False;True;];
DebugStep():=[debugging:=False;nextdebugging:=True;];

DebugStepOver():=
[
  debugging:=False;
  debugstepoverfile := DebugFile(CustomEval'Expression());
  debugstepoverline := DebugLine(CustomEval'Expression());
  debugstopdepth := Length(debugcallstack);
];
DebugBreakAt(file,line):=
[
  Check(InDebugMode(), "Mode", "DebugBreakAt only supported in the debug build of MathPiper");
  If(filebreakpoints[file] = Empty,filebreakpoints[file]:={});
  DestructiveAppend(filebreakpoints[file],line);
];
DebugRemoveBreakAt(file,line):=
[
  Check(InDebugMode(), "Mode", "DebugRemoveBreakAt only supported in the debug build of MathPiper");
  If(filebreakpoints[file] = Empty,filebreakpoints[file]:={});
  filebreakpoints[file] := Difference(filebreakpoints[file],{line});
];


DebugStop():=[debugging:=False;debugstopped:=True;CustomEval'Stop();];
DebugVerbose(verbose):=[debugverbose:=verbose;];
DebugAddBreakpoint(fname_IsString) <-- [ breakpoints := fname:breakpoints;];
Macro(DebugBreakIf,{predicate})
[
  breakpredicate:= Hold(@predicate);
];

BreakpointsClear() <--
[
  breakpredicate:=False;
  breakpoints := {};
];
Macro(DebugLocals,{})
[
  Echo("");
  Echo("*************** Current locals on the stack ****************");
  ForEach(item,CustomEval'Locals())
  [
    Echo("      ",item," : ",Eval(item));
  ];
  Echo("");
];
DebugCallstack() <--
[
  Echo("");
  Echo("*************** Function call stack ****************");
  ForEach(item,debugcallstack)
  [
    if(IsFunction(item))
      Echo("      Function ",Type(item)," : ",item)
    else
      Echo("      Variable ",item);
  ];
  Echo("");
];

Macro(DebugEnter,{})
[
  debugcallstack := CustomEval'Expression():debugcallstack;
  // custom breakpoint (custom predicate thought up by the programmer)
  If(debugging = False And
      Eval(breakpredicate) = True,
      [
        breakpredicate:=False;
        debugging:=True;
      ]);

  If(debugging = False And InDebugMode(),
  [
    Local(file,line);
    file := DebugFile(CustomEval'Expression());
    If(filebreakpoints[file] != Empty,
    [
      line := DebugLine(CustomEval'Expression());
      If(Not(file = debugstepoverfile And line = debugstepoverline) And
         Contains(filebreakpoints[file],line),
         [
           debugging:=True;
         ]
        );
    ]);
  ]);


  // the standard breakpoint
  If(debugging = False And
      IsFunction(CustomEval'Expression()) And
      Contains(breakpoints,Type(CustomEval'Expression())),   debugging:=True);
   nextdebugging:=False;
   If (debugging,
   [
     If(InDebugMode(),DebugShowCode());
     Echo(">>> ",CustomEval'Expression());
     While(debugging)
     [
        Echo("DebugResult: ",Eval(PipeFromString(ReadCmdLineString("Debug> "):";")Read()));
    //      If(debugging,Echo("DebugResult: ",debugRes));
       If(IsExitRequested(),debugging:=False);
     ];
    ]);
   debugging:=nextdebugging;

   If(IsExitRequested(),debugstopped:=True);

];
Macro(DebugLeave,{})
[
  If(debugging = False And debugstopdepth >= 0 And Length(debugcallstack) = debugstopdepth,
  [
    debugstepoverline := -1;
    debugging := True;
    debugstopdepth := -1;
  ]);

  debugcallstack := Rest(debugcallstack);
  If(debugverbose,Echo(CustomEval'Result()," <-- ",CustomEval'Expression()));
];
Macro(Debug,{expression})
PipeToStdout()
[
   DebugStart();
   CustomEval(DebugEnter(),DebugLeave(),If(debugstopped,Check(False, "Debug", ""),[debugging:=True;debugcallstack := Rest(debugcallstack);]),@expression);
];


ProfileStart():=
[
    profilefn:={};
];
10 # ProfileEnter()_(IsFunction(CustomEval'Expression())) <--
[
    Local(fname);
    fname:=Type(CustomEval'Expression());
    If(profilefn[fname]=Empty,profilefn[fname]:=0);
    profilefn[fname] := profilefn[fname]+1;
];
Macro(Profile,{expression})
[
    ProfileStart();
    CustomEval(ProfileEnter(),True,CustomEval'Stop(),@expression);
    ForEach(item,profilefn)
      Echo("Function ",item[1]," called ",item[2]," times");
];

/// Measure the time taken by evaluation and print results.
Macro(EchoTime,{expression})
[
	Local(result);
	Echo(Time()Bind(result, @expression), "seconds taken.");
	result;
];



// ClearScreenString : the ascii escape codes to clear the screen
ClearScreenString := UnicodeToString(27):"[2J":UnicodeToString(27):"[1;1H";

// WriteLines: do the actual outputting of lines of a file to screen
WriteLines(filename,lines,from,nrlines,breakpoints,current):=
[
  Local(i,nr);
  nr:=Length(lines);
  WriteString(ClearScreenString);
  Echo("File ",filename," at line ",current);
  For(i:=from,i")
    else
      WriteString(" ");
    if (Contains(breakpoints,i))
      WriteString("*")
    else
      WriteString(" ");
    WriteString("| ");
    Echo(lines[i][1]);
  ];
];
Debug'FileLoaded := "";
Debug'FileLines := {};
Debug'NrLines:=20;

//
// DebugShowCode: show the part of the file we are currently executing (based on the
// value returned by CustomEval'Expression() ).
//
// Currently unimplemented, should we remove?
//
DebugShowCode():=
[
  False;
];

]; //LocalSymbols


%/mathpiper




%mathpiper_docs,name="TraceExp",categories="User Functions;Control Flow",access="private"
*CMD TraceExp --- evaluate with tracing enabled
*CORE
*CALL
	TraceExp(expr)

*PARMS

{expr} -- expression to trace

*DESC

The expression "expr" is evaluated with the tracing facility turned
on. This means that every subexpression, which is evaluated, is shown
before and after evaluation. Before evaluation, it is shown in the
form {TrEnter(x)}, where {x}
denotes the subexpression being evaluated. After the evaluation the
line {TrLeave(x,y)} is printed, where {y} is the result of the evaluation. The indentation
shows the nesting level.

Note that this command usually generates huge amounts of output. A
more specific form of tracing (eg. {TraceRule}) is
probably more useful  for all but very simple expressions.

*E.G. notest

In> TraceExp(2+3);
	  TrEnter(2+3);
	    TrEnter(2);
	    TrLeave(2, 2);
	    TrEnter(3);
	    TrLeave(3, 3);
	    TrEnter(IsNumber(x));
	      TrEnter(x);
	      TrLeave(x, 2);
	    TrLeave(IsNumber(x),True);
	    TrEnter(IsNumber(y));
	      TrEnter(y);
	      TrLeave(y, 3);
	    TrLeave(IsNumber(y),True);
	    TrEnter(True);
	    TrLeave(True, True);
	    TrEnter(MathAdd(x,y));
	      TrEnter(x);
	      TrLeave(x, 2);
	      TrEnter(y);
	      TrLeave(y, 3);
	    TrLeave(MathAdd(x,y),5);
	  TrLeave(2+3, 5);
Result: 5;

*SEE TraceStack, TraceRule
%/mathpiper_docs




%mathpiper_docs,name="EchoTime",categories="User Functions;Input/Output"
*CMD EchoTime --- measure the time taken by a function and echos it
*STD
*CALL
	EchoTime()expr
*PARMS
{expr} -- any expression
*DESC

The function {EchoTime()expr} evaluates the expression {expr} and prints the time in seconds needed for the evaluation.
The time is printed to the current output stream.
The built-in function {Time} is used for timing.

The result is the "user time" as reported by the OS, not the real ("wall clock") time.
Therefore, any CPU-intensive processes running alongside MathPiper will not significantly affect the result of {EchoTime}.

*E.G. notest
In> EchoTime() N(MathLog(1000),40)
	0.34 seconds taken
Result: 6.9077552789821370520539743640530926228033;

*SEE Time, SystemTimer
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/0000755000175000017500000000000011722677334024771 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/VerifyArithmetic.mpw0000644000175000017500000000233211523200452030752 0ustar  giovannigiovanni%mathpiper,def="VerifyArithmetic"

LocalSymbols(f1,f2)
[
  // f1 and f2 are used inside VerifyArithmetic
  f1(x,n,m):=(x^n-1)*(x^m-1);
  f2(x,n,m):=x^(n+m)-(x^n)-(x^m)+1;

  VerifyArithmetic(x,n,m):=
  [
    Verify(f1(x,n,m),f2(x,n,m));
  ];
];

%/mathpiper




%mathpiper_docs,name="VerifyArithmetic",categories="Programmer Functions;Testing"
*CMD VerifyArithmetic --- Special purpose arithmetic verifiers
*STD
*CALL
	VerifyArithmetic(x,n,m)

*PARMS

{x}, {n}, {m} -- integer arguments

*DESC

The command {VerifyArithmetic} tests a
mathematic equality which should hold, testing that the
result returned by the system is mathematically correct
according to a mathematically provable theorem.

{VerifyArithmetic} verifies for an arbitrary set of numbers
$ x $, $ n $ and $ m $ that
$$ (x^n-1)*(x^m-1) = x^(n+m)-(x^n)-(x^m)+1 $$.

The left and right side represent two ways to arrive at the
same result, and so an arithmetic module actually doing the
calculation does the calculation in two different ways.
The results should be exactly equal.

*E.G.

In> VerifyArithmetic(100,50,60)
Result: True;

*SEE Verify, VerifyArithmetic, RandVerifyArithmetic, VerifyDiv, CanProve, KnownFailure, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/EqualAsSets.mpw0000644000175000017500000000077111517224250027700 0ustar  giovannigiovanni%mathpiper,def="EqualAsSets"

//Retract("EqualAsSets",*);

10 # EqualAsSets( A_IsList, B_IsList )_(Length(A)=Length(B)) <--
[
    Local(Acopy,b,nba,result);
    Acopy  := FlatCopy(A);
    result := True;
    ForEach(b,B)
     [
         nba := Find(Acopy,b);
         If( nba < 0, [ result := False; Break(); ] );
         DestructiveDelete(Acopy,nba);
     ];
     If( Not result, result := Length(Acopy)=0 );
     result;
];

20 # EqualAsSets( _A, _B ) <-- False;

%/mathpiper


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/VerifySolve.mpw0000644000175000017500000000634011523200452027754 0ustar  giovannigiovanni%mathpiper,def="VerifySolve"

//Retract("VerifySolve",*);
//Retract("VerifySolve'Equal",*);

VerifySolve(_e1, _e2) <--
If (VerifySolve'Equal(Eval(e1), Eval(e2)), 
    True,
    [ 
      WriteString("******************");    NewLine();
      ShowLine();                           NewLine();
      Write(e1);                            NewLine();
      WriteString(" evaluates to ");        NewLine();
      Write(Eval(e1));                      NewLine();
      WriteString(" which differs from ");  NewLine();
      Write(e2);                            NewLine();
      WriteString("******************");    NewLine();
      False; 
    ]); 
HoldArgumentNumber("VerifySolve", 2, 1);

10 # VerifySolve'Equal({}, {}) <-- True;

20 # VerifySolve'Equal({}, e2_IsList) <-- False;

30 # VerifySolve'Equal(e1_IsList, e2_IsList) <--
[
  Local(i, found);
  found := False;
  i := 0;
  While(i < Length(e2) And Not found) [
    i++;
    found := VerifySolve'Equal(First(e1), e2[i]);
  ];
  If (found, VerifySolve'Equal(Rest(e1), Delete(e2, i)), False);
];

40 # VerifySolve'Equal(_l1 == _r1, _l2 == _r2) 
<-- IsEqual(l1,l2) And Simplify(r1-r2)=0;

50 # VerifySolve'Equal(_e1, _e2) <-- Simplify(e1-e2) = 0;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="VerifySolve",categories="Programmer Functions;Testing"
*CMD VerifySolve --- verifies that one expression is mathematically equivalent to another
*STD
*CALL
	VerifySolve(expression,answer)

*PARMS

{expression} -- expression to be checked

{answer} -- expected result


*DESC

VerifySolve(expression, answer) tests whether 'expression' evaluates to 
something "equal" to 'answer', and complains explicitly if it doesn't. 

  Here, "equal" means:
   o  for lists: having the same entries, possibly in a different order;
   o  for equations: having the same right-hand sides, possibly after 'Simplify';
   o  in all other cases: equality, possible after 'Simplify'.
  Hence, { a == 1, a == x+1 } is "equal" to { a == 1+x, a == 1 }.

The command {VerifySolve} is usually employed to verify that an equation or
set of equations has been solved correctly.   

But it also has a wider applicability.

NOTE:
    This function used to be defined in the test file solve.mpt, where it was
used extensively.  However, by defining it in that file, it was unavailable for
use as a general tool.  Now it has been made available.

*E.G.

In> VerifySolve(Solve(a+x*y==z,x),{x==(z-a)/y});
Result: True

In> VerifySolve(Solve(a+x*y==z,x),{x==(a-z)/y});
Result: False
Side Effects:
******************
none: -1 
Solve(a+x*y==z,x)
 evaluates to
{x==-(a-z)/y}
 which differs from
{x==(a-z)/y}
******************

In> Verify(x*(1+x),x+x^2)
Result: False
Side Effects:
******************
none: -1 
x*(1+x)
 evaluates to
x*(x+1)
 which differs from
x+x^2
******************

In> VerifySolve(x*(1+x),x+x^2)
Result: True

NOTE: Verify cannot see past the syntactical dissimilarity;  
      VerifySolve can see the mathematical identity.

*SEE Verify, Simplify, CanProve, KnownFailure, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/LogicVerify.mpw0000644000175000017500000000146111523200452027720 0ustar  giovannigiovanni%mathpiper,def="LogicVerify"

Function("LogicVerify",{aLeft,aRight})
[
  If(aLeft != aRight,
    Verify(CanProve(aLeft => aRight),True)
  );
];

%/mathpiper



%mathpiper_docs,name="LogicVerify",categories="Programmer Functions;Testing"
*CMD LogicVerify --- verifying equivalence of two expressions
*STD
*CALL
	LogicVerify(question,answer)

*PARMS

{question} -- expression to check for

{answer} -- expected result after evaluation


*DESC

The command {LogicVerify} can be used to verify that an
expression is equivalent to  a correct answer after evaluation.
It returns {True} or {False}

*E.G.
In> LogicVerify(a And c Or b And Not c,a Or b)
Result: True;
In> LogicVerify(a And c Or b And Not c,b Or a)
Result: True;

*SEE Simplify, CanProve, KnownFailure, Verify, TestMathPiper, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/BenchShow.mpw0000644000175000017500000000033011351332763027362 0ustar  giovannigiovanni%mathpiper,def="BenchShow"

Function("BenchShow",{expr})
[
  Echo("In> ",expr);
  WriteString(" ");
  Echo("Out> ",Eval(expr),"");
  True;
];
HoldArgument("BenchShow",expr);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/NumericEqual.mpw0000644000175000017500000000504311517224250030075 0ustar  giovannigiovanni%mathpiper,def="NumericEqual"

//Retract("NumericEqual",*);

10 # NumericEqual(left_IsDecimal, right_IsDecimal, precision_IsPositiveInteger) <--
[
    If(InVerboseMode(),Tell("NumericEqual",{left,right}));
    Local(repL,repR,precL,precR,newL,newR,plo,phi,replo,rephi);
    Local(newhi,newrepL,newlo,newrepR,ans);
    repL     := NumberToRep(left);
    repR     := NumberToRep(right);
    precL    := repL[2];
    precR    := repR[2];
    If(InVerboseMode(),Tell("  ",{precL,precR,precision}));
    newL     := RoundToPrecision(left,  precision );
    newR     := RoundToPrecision(right, precision );
    If(InVerboseMode(),Tell("  ",{newL,newR}));
    newrepL  := NumberToRep( newL );
    newrepR  := NumberToRep( newR );
    If(InVerboseMode(),Tell("  ",{newrepL,newrepR}));
    ans      := Verify( newrepL[1] - newrepR[1], 0 );
    If(InVerboseMode(),Tell("        ",ans));
    ans;
];


15 # NumericEqual(left_IsInteger, right_IsInteger, precision_IsPositiveInteger) <--
[
    If(InVerboseMode(),Tell("NumericEqualInt",{left,right}));
    left = right;
];


20 # NumericEqual(left_IsNumber, right_IsNumber, precision_IsPositiveInteger) <--
[
    If(InVerboseMode(),Tell("NumericEqualNum",{left,right}));
    Local(nI,nD,repI,repD,precI,precD,intAsDec,newDec,newrepI,newrepD,ans);
    If( IsInteger(left), [nI:=left; nD:=right;], [nI:=right; nD:=left;]);
    // the integer can be converted to the equivalent decimal at any precision
    repI  := NumberToRep(nI);
    repD  := NumberToRep(nD);
    precI := repI[2];
    precD := repD[2];
    intAsDec := RoundToPrecision(1.0*nI,precision);
    newDec   := RoundToPrecision( nD,   precision );
    newrepI  := NumberToRep( intAsDec );
    newrepD  := NumberToRep( newDec   );
    If(InVerboseMode(),
      [
          Tell("        ",{nI,nD});
          Tell("    ",{repI,repD});
          Tell("  ",{precI,precD});
          Tell("       ",{intAsDec,newDec});
          Tell("       ",{newrepI,newrepD});
       ]
    );
    ans      := Verify( newrepI[1] - newrepD[1], 0 );
    If(InVerboseMode(),Tell("        ",ans));
    ans;
];


25 # NumericEqual(left_IsComplex, right_IsComplex, precision_IsPositiveInteger) <--
[
    If(InVerboseMode(),Tell("NumericEqualC",{left,right}));
    Local(rrL,iiL,rrR,iiR,ans);
    rrL := Re(left);
    iiL := Im(left);
    rrR := Re(right);
    iiR := Im(right);
    If(InVerboseMode(),
      [
         Tell("  ",{left,right});
         Tell("  ",{rrL,rrR});
         Tell("  ",{iiL,iiR});
      ]
    );
    ans := (NumericEqual(rrL,rrR,precision) And NumericEqual(iiL,iiR,precision));
];

%/mathpiper


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/VerifyDiv.mpw0000644000175000017500000000122411523200452027402 0ustar  giovannigiovanni%mathpiper,def="VerifyDiv"

VerifyDiv(_u,_v) <--
[
  Local(q,r);
  q:=Quotient(u,v);
  r:=Rem(u,v);

  Verify(Expand(u),Expand(q*v+r));
];

%/mathpiper




%mathpiper_docs,name="VerifyDiv",categories="Programmer Functions;Testing"
*CMD VerifyDiv --- Special purpose arithmetic verifiers
*STD
*CALL
	VerifyDiv(u,v)

*PARMS

{u}, {v} -- integer arguments

*DESC

{VerifyDiv(u,v)} checks that
$$ u = v*Quotient(u,v) + Modulo(u,v) $$.


*E.G.

In> VerifyDiv(x^2+2*x+3,x+1)
Result: True;
In> VerifyDiv(3,2)
Result: True;

*SEE Verify, VerifyArithmetic, RandVerifyArithmetic, VerifyDiv, CanProve, KnownFailure, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/RandVerifyArithmetic.mpw0000644000175000017500000000130211523200452031553 0ustar  giovannigiovanni%mathpiper,def="RandVerifyArithmetic"

RandVerifyArithmetic(_n)<--
[
 While(n>0)
 [
   n--;
   VerifyArithmetic(FloorN(300*Random()),FloorN(80*Random()),FloorN(90*Random()));
 ];
];

%/mathpiper




%mathpiper_docs,name="RandVerifyArithmetic",categories="Programmer Functions;Testing"
*CMD RandVerifyArithmetic --- Special purpose arithmetic verifiers
*STD
*CALL
	RandVerifyArithmetic(n)

*PARMS

{n} -- integer arguments

*DESC

{RandVerifyArithmetic(n)} calls {VerifyArithmetic} with
random values, {n} times.

*E.G.

In> RandVerifyArithmetic(4)
Result: True;

*SEE Verify, VerifyArithmetic, RandVerifyArithmetic, VerifyDiv, CanProve, KnownFailure, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/LogicTest.mpw0000644000175000017500000000271011523200452027371 0ustar  giovannigiovanni%mathpiper,def="LogicTest"

/* LogicTest compares the truth tables of two expressions. */
LocalSymbols(TrueFalse)
[
  MacroRulebase(TrueFalse,{var,expr});
  10 # TrueFalse(var_IsAtom,_expr) <-- `{(@expr) Where (@var)==False,(@expr) Where (@var)==True};
  20 # TrueFalse({},_expr) <-- `(@expr);
  30 # TrueFalse(var_IsList,_expr) <--
  `[
    Local(t,h);
    Bind(h,First(@var));
    Bind(t,Rest(@var));
    TrueFalse(h,TrueFalse(t,@expr));
  ];

  Macro(LogicTest,{vars,expr1,expr2}) Verify(TrueFalse((@vars),(@expr1)), TrueFalse((@vars),(@expr2)));
];

%/mathpiper





%mathpiper_docs,name="LogicTest",categories="Programmer Functions;Testing"
*CMD LogicTest --- verifying equivalence of two expressions
*STD
*CALL
	LogicTest(variables,expr1,expr2)

*PARMS

{variables} -- list of variables

{exprN} -- Some boolean expression

*DESC

The command {LogicTest} can be used to verify that an
expression is equivalent to  a correct answer after evaluation.
It returns {True} or {False}.


*E.G.

In> LogicTest({A,B,C},Not((Not A) And (Not B)),A Or B)
Result: True
In> LogicTest({A,B,C},Not((Not A) And (Not B)),A Or C)
	******************
	CommandLine: 1

	$TrueFalse4({A,B,C},Not(Not A And Not B))
	 evaluates to
	{{{False,False},{True,True}},{{True,True},{True,True}}}
	 which differs from
	{{{False,True},{False,True}},{{True,True},{True,True}}}
	******************
Result: False

*SEE Simplify, CanProve, KnownFailure, Verify, TestMathPiper, LogicVerify

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/TestMathPiper.mpw0000644000175000017500000000405611523200452030232 0ustar  giovannigiovanni%mathpiper,def="TestMathPiper"

/* Testing MathPiper functionality by checking expressions against correct
   answer.
   Use with algebraic expressions only, since we need Simplify() for that to work.
 */

/*
Macro ("TestMathPiper", {expr, ans})
[
	Local(diff,exprEval, ansEval);
  exprEval:= @expr;
  ansEval:= @ans;

	diff := Simplify(exprEval - ansEval);
		If (Simplify(diff)=0, True,
			[
			  WriteString("******************");
			  NewLine();
			  ShowLine();
			  Write(Hold(@expr));
			  WriteString(" evaluates to ");
			  NewLine();
			  Write(exprEval);
			  NewLine();
			  WriteString(" which differs from ");
			  NewLine();
			  Write(ansEval);
			  NewLine();
			  WriteString(" by ");
			  NewLine();
			  Write(diff);
			  NewLine();
			  WriteString("******************");
			  NewLine();
			  False;
			 ]
			);
];
*/



Function ("TestMathPiper", {expr, ans})
[
	Local(diff);
	diff := Simplify(Eval(expr)-Eval(ans));
		If (Simplify(diff)=0, True,
			[
			  WriteString("******************");
			  NewLine();
			  ShowLine();
			  Write(expr);
			  WriteString(" evaluates to ");
			  NewLine();
			  Write(Eval(expr));
			  NewLine();
			  WriteString(" which differs from ");
			  NewLine();
			  Write(Eval(ans));
			  NewLine();
			  WriteString(" by ");
			  NewLine();
			  Write(diff);
			  NewLine();
			  WriteString("******************");
			  NewLine();
			  False;
			 ]
			);
];

HoldArgument("TestMathPiper", expr);
HoldArgument("TestMathPiper", ans);


%/mathpiper




%mathpiper_docs,name="TestMathPiper",categories="Programmer Functions;Testing"
*CMD TestMathPiper --- verifying equivalence of two expressions
*STD
*CALL
	TestMathPiper(question,answer)

*PARMS

{question} -- expression to check for

{answer} -- expected result after evaluation

*DESC

The command {TestMathPiper} can be used to verify that an
expression is equivalent to  a correct answer after evaluation.
It returns {True} or {False}.

*E.G.
In> TestMathPiper(x*(1+x),x^2+x)
Result: True;


*SEE Simplify, CanProve, KnownFailure, Verify, LogicVerify, LogicTest

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/NextTest.mpw0000644000175000017500000000023511316324171027257 0ustar  giovannigiovanni%mathpiper,def="NextTest"

Function("NextTest",{aLeft})
[
// curline++;
WriteString("
Test suite for ":aLeft:" : "
           );
  NewLine();
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/RoundTo.mpw0000644000175000017500000000300011523200452027057 0ustar  giovannigiovanni%mathpiper,def="RoundTo"

/* Functions that aid in testing */

/* Round to specified number of digits */
10 # RoundTo(x_IsNumber, precision_IsPositiveInteger) <--
[
  Local(oldPrec,result);

  oldPrec:=BuiltinPrecisionGet();

  BuiltinPrecisionSet(precision);

  Bind(result,DivideN( Round( MultiplyN(x, 10^precision) ), 10^precision ));

  BuiltinPrecisionSet(oldPrec);

  result;
];



// complex numbers too
10 # RoundTo(Complex(r_IsNumber, i_IsNumber), precision_IsPositiveInteger) <-- Complex(RoundTo(r, precision), RoundTo(i, precision));




// Infinities, rounding does not apply.
20 # RoundTo( Infinity,precision_IsPositiveInteger) <--  Infinity;

20 # RoundTo(-Infinity,precision_IsPositiveInteger) <-- -Infinity;



/* ------   moved to separate file (already present but empty!) ---

Macro(NumericEqual,{left,right,precision})
[
  Verify(RoundTo((@left)-(@right),@precision),0);
];

*/

%/mathpiper





%mathpiper_docs,name="RoundTo",categories="Programmer Functions;Testing"
*CMD RoundTo --- Round a real-valued result to a set number of digits
*STD
*CALL
	RoundTo(number,precision)

*PARMS

{number} -- number to round off

{precision} -- precision to use for round-off

*DESC

The function {RoundTo} rounds a floating point number to a
specified precision, allowing for testing for correctness
using the {Verify} command.

*E.G.

In> N(RoundTo(Exp(1),30),30)
Result: 2.71828182110230114951959786552;
In> N(RoundTo(Exp(1),20),20)
Result: 2.71828182796964237096;

*SEE Verify, VerifyArithmetic, VerifyDiv

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/BenchCall.mpw0000644000175000017500000000032711371733712027324 0ustar  giovannigiovanni%mathpiper,def="BenchCall"

Function("BenchCall",{expr})
[
  Echo("In> ",expr);
  WriteString("");
  Eval(expr);
  WriteString("");
  True;
];
HoldArgument("BenchCall",expr);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/Testing.mpw0000644000175000017500000000017311316324171027117 0ustar  giovannigiovanni%mathpiper,def="Testing"

Function("Testing",{aLeft})
[
 WriteString("--");
 WriteString(aLeft); NewLine();
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/TestEquivalent.mpw0000644000175000017500000000664511517224250030471 0ustar  giovannigiovanni%mathpiper,def="TestEquivalent"

//Retract("TestEquivalent",*);
//Retract("TestTwoLists",*);

Macro("TestEquivalent",{left,right})
[
    Local(leftEval,rightEval,diff,vars,isEquiv);
    If(InVerboseMode(),[Tell(TestEquivalent,{left,right});]);
    leftEval  := @left;
    rightEval := @right;
    If(InVerboseMode(),
      [ NewLine(); Tell("    ",leftEval); Tell("   ",rightEval); ]);
    If( IsList(leftEval),
      [
          If( IsList(rightEval),
            [
                // both are lists
                If(InVerboseMode(),Tell("     both are lists "));
                isEquiv := TestTwoLists(leftEval,rightEval);
            ],
            isEquiv := False
          );
      ],
      [
          If( IsList(rightEval), 
            isEquiv := False,
            [
                // neither is a list, so check equality of diff
                If(InVerboseMode(),Tell("     neither is list "));
                If(IsEquation(leftEval),
                  [
                      If(IsEquation(rightEval),
                        [
                            If(InVerboseMode(),Tell("      both are equations"));
                            Local(dLHs,dRHS);
                            dLHS := Simplify(EquationLeft(leftEval) - EquationLeft(rightEval));
                            dRHS := Simplify(EquationRight(leftEval) - EquationRight(rightEval));
                            If(InVerboseMode(),Tell("      ",{dLHS,dRHS}));
                            isEquiv := dLHS=0 And dRHS=0;
                        ],
                        isEquiv := False
                      );
                  ],
                  [
                     If(IsEquation(rightEval),
                        isEquiv := False,
                        [
                            If(InVerboseMode(),Tell("      neither is equation"));
                            diff := Simplify(leftEval - rightEval);
                            vars := VarList(diff);
                            If(InVerboseMode(),
                              [
                                 Tell("    ",{leftEval,rightEval});
                                 Tell("    ",vars);
                                 Tell("    ",diff);
                              ]
                            );
                            isEquiv   := ( IsZero(diff) Or IsZeroVector(diff) );
                        ]
                      );
                   ]
                );
            ]
          );
      ]
    );
    If(InVerboseMode(),Tell("     Equivalence = ",isEquiv));
    If ( Not isEquiv,
      [
		  WriteString("******************");          NewLine();
		  WriteString("L.H.S. evaluates to: ");
		  Write(leftEval);                            NewLine();
		  WriteString("which differs from   ");
		  Write(rightEval);                           NewLine();
		  WriteString(" by                  "); 
		  Write(diff);                                NewLine();
		  WriteString("******************");          NewLine();
      ]
    );
    isEquiv;
];


10 # TestTwoLists( L1_IsList, L2_IsList ) <--
[
    If(InVerboseMode(),[Tell("   TestTwoLists");Tell("     ",L1);Tell("     ",L2);]);
    If(Length(L1)=1 And Length(L2)=1,
      [
          TestEquivalent(L1[1],L2[1]);
      ],
      [
          EqualAsSets(L1,L2);
      ]
    );
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/KnownFailure.mpw0000644000175000017500000000201011523200452030071 0ustar  giovannigiovanni%mathpiper,def="KnownFailure"

Function("KnownFailure",{expr})
[
  Local(rfail);
  Echo("Known failure: ", expr);
  Bind(rfail,Eval(expr));
  If(rfail,Echo({"Failure resolved!"}));
];
HoldArgument("KnownFailure",expr);

%/mathpiper




%mathpiper_docs,name="KnownFailure",categories="Programmer Functions;Testing"
*CMD KnownFailure --- Mark a test as a known failure
*STD
*CALL
	KnownFailure(test)

*PARMS

{test} -- expression that should return {False} on failure

*DESC

The command {KnownFailure} marks a test as known to fail
by displaying a message to that effect on screen.

This might be used by developers when they have no time
to fix the defect, but do not wish to alarm users who download
MathPiper and type {make test}.

*E.G.

In> KnownFailure(Verify(1,2))
	Known failure:
	******************
	 1 evaluates to  1 which differs from  2
	******************
Result: False;
In> KnownFailure(Verify(1,1))
	Known failure:
	Failure resolved!
Result: True;

*SEE Verify, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/Verify.mpw0000644000175000017500000001003011523200452026732 0ustar  giovannigiovanni%mathpiper,def="Verify"

/*
Macro("Verify",{aLeft,aRight})
[

	Local(result);
	result := @aLeft;	// to save time
  If (Not(IsEqual(result,@aRight)),
    [
      WriteString("******************");
      NewLine();
      ShowLine();
      NewLine();
      Write(Hold(@aLeft));
      NewLine();
      WriteString(" evaluates to ");
      NewLine();
	  Write(result);
	  WriteString(" which differs from ");
      NewLine();
      Write(Hold(@aRight));
      NewLine();
      WriteString("******************");
      NewLine();
      False;
    ],
    True
  );
];
*/


Function("Verify",{aLeft,aRight})
[

	Local(result);
	result := Eval(aLeft);	// to save time
  If (Not(IsEqual(result,aRight)),
    [
      WriteString("******************");
      NewLine();
      ShowLine();
      NewLine();
      Write(aLeft);
      NewLine();
      WriteString(" evaluates to ");
      NewLine();
	  Write(result);
      NewLine();
	  WriteString(" which differs from ");
      NewLine();
      Write(aRight);
      NewLine();
      WriteString("******************");
      NewLine();
      False;
    ],
    True
  );
];
HoldArgument("Verify",aLeft);
UnFence("Verify",2);
/*
HoldArgument("Verify",aRight);
*/

Macro("Verify", {a,b,message})
[
	Echo("test ", @message);
	Verify(@a, @b);
];


%/mathpiper






%mathpiper_docs,name="Verify",categories="Programmer Functions;Testing"
*CMD Verify --- verifying equivalence of two expressions
*STD
*CALL
	Verify(question,answer)

*PARMS

{question} -- expression to check for

{answer} -- expected result after evaluation


*DESC

The command {Verify} can be used to verify that an
expression is equivalent to  a correct answer after evaluation.
It returns {True} or {False}.

For some calculations, the demand that two expressions
are identical syntactically is too stringent. The
MathPiper system might change at various places in the future,
but $ 1+x $ would still be equivalent, from a mathematical
point of view, to $ x+1 $.

The general problem of deciding that two expressions $ a $ and $ b $
are equivalent, which is the same as saying that $ a-b=0 $ ,
is generally hard to decide on. The following commands solve
this problem by having domain-specific comparisons.

The comparison commands do the following comparison types:

*	{Verify} -- verify for literal equality.
This is the fastest and simplest comparison, and can be
used, for example, to test that an expression evaluates to $ 2 $.
*	{TestMathPiper} -- compare two expressions after simplification as
multivariate polynomials. If the two arguments are equivalent
multivariate polynomials, this test succeeds. {TestMathPiper} uses {Simplify}. Note: {TestMathPiper} currently should not be used to test equality of lists.
*	{LogicVerify} -- Perform a test by using {CanProve} to verify that from
{question} the expression {answer} follows. This test command is
used for testing the logic theorem prover in MathPiper.
*	{LogicTest} -- Generate a truth table for the two expressions and compare these two tables. They should be the same if the two expressions are logically the same.

*E.G.
In> Verify(1+2,3)
Result: True;

In> Verify(x*(1+x),x^2+x)
	******************
	x*(x+1) evaluates to x*(x+1) which differs
	  from x^2+x
	******************
Result: False;

In> TestMathPiper(x*(1+x),x^2+x)
Result: True;

In> Verify(a And c Or b And Not c,a Or b)
	******************
	 a And c Or b And Not c evaluates to  a And c
	  Or b And Not c which differs from  a Or b
	******************
Result: False;

In> LogicVerify(a And c Or b And Not c,a Or b)
Result: True;

In> LogicVerify(a And c Or b And Not c,b Or a)
Result: True;

In> LogicTest({A,B,C},Not((Not A) And (Not B)),A Or B)
Result: True

In> LogicTest({A,B,C},Not((Not A) And (Not B)),A Or C)
	******************
	CommandLine: 1

	TrueFalse4({A,B,C},Not(Not A And Not B))
	 evaluates to
	{{{False,False},{True,True}},{{True,True},{True,True}}}
	 which differs from
	{{{False,True},{False,True}},{{True,True},{True,True}}}
	******************
Result: False

*SEE Simplify, CanProve, KnownFailure, TestMathPiper, LogicVerify, LogicTest

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/testers/ShowLine.mpw0000644000175000017500000000017711371733712027244 0ustar  giovannigiovanni%mathpiper,def="ShowLine"

// print current file and line
ShowLine() := [Echo(CurrentFile(),": ",CurrentLine());];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/0000755000175000017500000000000011722677332025104 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/LnGamma.mpw0000644000175000017500000000045711316304766027150 0ustar  giovannigiovanni%mathpiper,def="LnGamma"

///// Serge Winitzki

10 # LnGamma(_n)_(IsInteger(n) And n<=0) <-- Infinity;

20 # LnGamma(n_IsRationalOrNumber)_(IsPositiveInteger(n) Or FloatIsInt(2*n)) <-- Ln((Round(2*n)/2-1)!);

30 # LnGamma(x_IsConstant)_(InNumericMode()) <-- Internal'LnGammaNum(N(Eval(x)));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/DirichletLambda.mpw0000644000175000017500000000015611316304766030640 0ustar  giovannigiovanni%mathpiper,def="DirichletLambda"

//Jonathan Leto

10 # DirichletLambda(_z)<-- (1-1/2^z)*Zeta(z);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/FresnelSin.mpw0000644000175000017500000000063611316304766027703 0ustar  giovannigiovanni%mathpiper,def="FresnelSin"

//Jonathan Leto

/////////////////////////////////////////////////
/// Fresnel integrals
/////////////////////////////////////////////////

10 # FresnelSin(0)		<-- 0;
10 # FresnelSin(Infinity)	<-- 1/2;
10 # FresnelSin(x_IsNumber)_(x<0)	<-- -FresnelSin(x);

40 # FresnelSin(x_IsNumber)_(Abs(x) <= 1) <-- N(Sqrt(2/Pi)*ApproxInfSum((-1)^(k+1)*x^(2*k+1)/(k! * (2*k+1)),1,x));


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/FresnelCos.mpw0000644000175000017500000000050111316304766027665 0ustar  giovannigiovanni%mathpiper,def="FresnelCos"

//Jonathan Leto

10 # FresnelCos(0)              <-- 0;
10 # FresnelCos(Infinity)       <-- 1/2;
10 # FresnelCos(x_IsNumber)_(x<0)       <-- -FresnelCos(x);

40 # FresnelCos(x_IsNumber)_(Abs(x) <= 1) <-- N(Sqrt(2/Pi)*ApproxInfSum((-1)^(k+1)*x^(4*k-3)/((4*k-3) * (2*k-2)! ),1,x));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/BesselJ.mpw0000644000175000017500000000262711316304766027164 0ustar  giovannigiovanni%mathpiper,def="BesselJ"

//Jonathan Leto

10 # BesselJ(0,0) 	<-- 1;
10 # BesselJ(_n,0)_(n>0) <-- 0;
10 # BesselJ(_n,0)_(n<0 And IsInteger(n)) <-- 0;
10 # BesselJ(_n,0)_(n<0 And Not IsInteger(n)) <-- Infinity;
10 # BesselJ(0,Infinity)<-- 0;
20 # BesselJ(1/2,_x)	<-- Sqrt(2/(x*Pi))*Sin(x);
20 # BesselJ(-1/2,_x)	<-- Sqrt(2/(x*Pi))*Cos(x);
20 # BesselJ(3/2,_x)	<-- Sqrt(2/(x*Pi))*(Sin(x)/x - Cos(x));
20 # BesselJ(-3/2,_x)	<-- Sqrt(2/(x*Pi))*(Cos(x)/x + Sin(x));
20 # BesselJ(5/2,_x)	<-- Sqrt(2/(x*Pi))*((3/x^2 - 1)*Sin(x) - 3*Cos(x)/x );
20 # BesselJ(-5/2,_x)      <-- Sqrt(2/(x*Pi))*( (3/x^2 -1)*Cos(x) + 3*Sin(x)/x );


// Forward recursion, works great, but really slow when n << x
30 # BesselJ(_n,_x)_(IsConstant(x) And IsInteger(n) And N(Abs(x) > 2*Gamma(n))) <-- N((2*(n+1)/x)*BesselJ(n+1,x) - BesselJ(n+2,x));

30 # BesselJ(_n,_z)_(n<0 And IsInteger(n) ) <-- (-1)^n*BesselJ(-n,z);

// When I put "And InNumericMode()" on the next rule, I lose precision. Why ?
// Also, if I move the the "_IsComplex" to the end with "IsComplex(x)"
// I lose precision.

//40 # BesselJ(_n,x_IsComplex)_(Abs(x)<= 2*Gamma(n) )  <-- N(BesselNsmall(n,x,0));

40 # BesselJ(_n,x_IsComplex)_(N(Abs(x)<= 2*Gamma(n)) )  <--
[
ApproxInfSum((-1)^k*(x/2)^(2*k+c[1])/(k! * Gamma(k+c[1]+1) ),0,x,{n} );
];

50 # BesselJ(0,x_IsComplex)_(InNumericMode()) <-- N(BesselJN0(x));

//50 # BesselJ(_n_IsPositiveNumber,_z_IsComplex) <-- BesselJN(n,z);



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/DawsonIntegral.mpw0000644000175000017500000000050211371733712030542 0ustar  giovannigiovanni%mathpiper,def="DawsonIntegral"

//Jonathan Leto

// needs Erf() that takes complex argument
/*
10 # DawsonIntegral(_x) <-- [
	Local(result,prec);
	prec:=BuiltinPrecisionGet();
	BuiltinPrecisionSet(prec+5);
	result:=N(I*Sqrt(Pi)*Exp(-x^2)*Erf(-I*x)/2);
	BuiltinPrecisionSet(prec);
	RoundTo(result,prec);
];
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/DirichletBeta.mpw0000644000175000017500000000125711316304766030336 0ustar  giovannigiovanni%mathpiper,def="DirichletBeta"

//Jonathan Leto

// This is really slow for x <= 3
5  # DirichletBeta(1)		<-- Pi/4;
5  # DirichletBeta(2)		<-- Catalan;
5  # DirichletBeta(3)		<-- Pi^3/32;
6  # DirichletBeta(n_IsOdd)	<-- [
		Local(k);
		k:=(n-1)/2;
		(-1)^k*Euler(2*k)*(Pi/2)^(2*k+1)/(2*(2*k)!);
];


10 # DirichletBeta(x_IsRationalOrNumber)_(InNumericMode() And x>=1 ) <-- [
	Local(prec,eps,term,result,k);
	prec:=BuiltinPrecisionGet();
  BuiltinPrecisionSet(prec+3);
	eps:=10^(-prec);
	result:=0;
	term:=1;
	For(k:=0, Abs(term) > eps, k++ )[
		term:=(-1)^k/(2*k+1)^x;
		Echo("term is ",term);
		result:=result+term;
	];
	BuiltinPrecisionSet(prec);
	RoundTo(result,prec);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Erf.mpw0000644000175000017500000000405011320767174026342 0ustar  giovannigiovanni%mathpiper,def="Erf"

//Jonathan Leto

/////////////////////////////////////////////////
/// Error and complementary error functions
/////////////////////////////////////////////////

10 # Erf(0)		<-- 0;
//10 # Erfc(0)		<-- 1;
10 # Erf(Infinity)	<-- 1;
10 # Erf(Undefined) <-- Undefined;
//10 # Erfc(Infinity)	<-- 0;
10 # Erf(x_IsNumber)_(x<0)	<-- -Erf(-x);
//40 # Erf(x_IsNumber)_(Abs(x) <= 1 )  <-- N(2/Sqrt(Pi)*ApproxInfSum((-1)^k*x^(2*k+1)/((2*k+1)*k!),0,x));

LocalSymbols(k)
[
	40 # Erf(_x)_(InNumericMode() And (IsNumber(x) Or IsComplex(x)) And Abs(x) <= 1) <--
[
  Local(prec);
  prec := BuiltinPrecisionGet(); // N(...) modifies the precision
  2 / SqrtN(Internal'Pi()) * x
	* SumTaylorNum(x^2, 1, {{k}, -(2*k-1)/(2*k+1)/k},
	// the number of terms n must satisfy n*Ln(n/Exp(1))>10^prec
//	Hold({{k}, [Echo(k); k;]}) @
		N(1+87/32*Exp(LambertW(prec*421/497)), 20)
	);

];

];	// LocalSymbols(k)

// asymptotic expansion, can be used only for low enough precision or large enough |x| (see predicates). Also works for complex x.
LocalSymbols(n'max, k)
[

	50 # Erf(_x)_(InNumericMode() And (IsNumber(x) Or IsComplex(x))
		And (
			[	// strongest condition: the exp(-x^2) asymptotic is already good
				n'max := 0;
				Re(x^2) > BuiltinPrecisionGet()*3295/1431+0.121;
			]
			Or
			[	// next condition: the exp(-x^2) helps but we need a few terms of the series too
				n'max := N(Minimum((BuiltinPrecisionGet()*3295/1431+0.121)/Internal'LnNum(Abs(x)), 2*Internal'LnNum(Abs(x))), 10);
				2*Abs(x)+Re(x^2) > BuiltinPrecisionGet()*3295/1431+0.121;
			]
			Or
			[	// worst case: exp(-x^2) does not help and we need the full series
	// hack: save a value computed in the predicate to use in the body of rule
				n'max := N(({{k}, k+Internal'LnNum(k)} @ BuiltinPrecisionGet()*3295/1431)/2 - 3/2, 10);
				Abs(x) > n'max+3/2;
			]
		)
	) <-- If(Re(x)!=0, Sign(Re(x)), 0) - Exp(-x^2)/x/SqrtN(Internal'Pi())
	// the series is 1 - 1/2/x^2 + 1*3/2^2/x^4 - 1*3*5/2^3/x^6 + ...
	* SumTaylorNum(1/x^2, 1, {{k}, -(2*k-1)/2 }, Maximum(0, Floor(n'max)));

];	// LocalSymbols(n'max, k)

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/om/0000755000175000017500000000000011722677332025517 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/om/om.mpw0000644000175000017500000000230211316304766026651 0ustar  giovannigiovanni%mathpiper,def=""

// From code.mpi.def:
OMDef( "Gamma", "nums1", "gamma" );
OMDef( "LnGamma"        , mathpiper, "LnGamma" );
OMDef( "Zeta"           , mathpiper, "Zeta" );
OMDef( "Bernoulli"      , mathpiper, "Bernoulli" );
OMDef( "ApproxInfSum"   , mathpiper, "ApproxInfSum" );
OMDef( "BesselJ"        , mathpiper, "BesselJ" );
OMDef( "BesselI"        , mathpiper, "BesselI" );
OMDef( "BesselY"        , mathpiper, "BesselY" );
OMDef( "Erf"            , mathpiper, "Erf" );
OMDef( "Erfc"           , mathpiper, "Erfc" );
OMDef( "Erfi"           , mathpiper, "Erfi" );
OMDef( "FresnelSin"     , mathpiper, "FresnelSin" );
OMDef( "FresnelCos"     , mathpiper, "FresnelCos" );
OMDef( "LambertW"       , mathpiper, "LambertW" );
OMDef( "Beta"           , mathpiper, "Beta" );
OMDef( "DirichletEta"   , mathpiper, "DirichletEta" );
OMDef( "DirichletLambda", mathpiper, "DirichletLambda" );
OMDef( "DirichletBeta"  , mathpiper, "DirichletBeta" );
OMDef( "Sinc"           , mathpiper, "Sinc" );
OMDef( "PolyLog"        , mathpiper, "PolyLog" );
OMDef( "CatalanConstNum", mathpiper, "CatalanConstNum" );
OMDef( "Digamma"        , mathpiper, "Digamma" );
OMDef( "DawsonIntegral" , mathpiper, "DawsonIntegral" );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/DirichletEta.mpw0000644000175000017500000000015111316304766030164 0ustar  giovannigiovanni%mathpiper,def="DirichletEta"

//Jonathan Leto

10 # DirichletEta(_z)	<-- (1-2/2^z)*Zeta(z);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/0000755000175000017500000000000011722677332026376 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/Bernoulli1.mpw0000644000175000017500000000241311320776303031127 0ustar  giovannigiovanni%mathpiper,def="Bernoulli1"

/// Find one Bernoulli number for large index
/// compute Riemann's zeta function and combine with the fractional part
Bernoulli1(n_IsEven)_(n>=2) <-- [
	Local(B, prec);
	prec := BuiltinPrecisionGet();
	// estimate the size of B[n] using Stirling formula
	// and compute Ln(B[n])/Ln(10) to find the number of digits
	BuiltinPrecisionSet(10);
	BuiltinPrecisionSet(
		Ceil(N((1/2*Ln(8*Pi*n)-n+n*Ln(n/2/Pi))/Ln(10)))+3	// 3 guard digits
	);
	If (InVerboseMode(), Echo({"Bernoulli: using zeta funcion, precision ", BuiltinPrecisionSet(), ", n = ", n}));
	B := Floor(N(	// compute integer part of B
		If(	// use different methods to compute Zeta function
			n>250,	// threshold is roughly right for internal math
			Internal'ZetaNum2(n, n/17+1),	// with this method, a single Bernoulli number n is computed in O(n*M(P)) operations where P = O(n*Ln(n)) is the required precision
			// Brent's method requires n^2*P+n*M(P)
			// simple array method requires
			Internal'ZetaNum1(n, n/17+1)	// this gives O(n*Ln(n)*M(P))
		)
		*N(2*n! /(2*Pi)^n)))
		// 2*Pi*e is approx. 17, add 1 to guard precision
		* (2*Modulo(n/2,2)-1)	// sign of B
		+ BernoulliFracPart(n);	// this already has the right sign
	BuiltinPrecisionSet(prec);	// restore old precision
	B;
];

%/mathpiper././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/Internal'BernoulliArray1.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/Internal'BernoulliArray1.mp0000644000175000017500000000257111371733712033513 0ustar  giovannigiovanni%mathpiper,def="Internal'BernoulliArray1"

/// Bernoulli numbers; algorithm from: R. P. Brent, "A FORTRAN multiple-precision arithmetic package", ACM TOMS vol. 4, no. 1, p. 57 (1978).
/// this may be good for floating-point (not exact) evaluation of B[n] at large n
/// but is not good at all for exact evaluation! (too slow)
/// Brent claims that the usual recurrence is numerically unstable
/// but we can't check this because MathPiper internal math is fixed-point and Brent's algorithm needs real floating point (C[k] are very small and then multiplied by (2*k)! )
Internal'BernoulliArray1(n_IsEven) _ (n>=2) <--
[
	Local(C, f, k, j, denom, sum);
	C := ArrayCreate(n+1, 0);
	f := ArrayCreate(n/2, 0);
	C[1] := 1;
	C[2] := -1/2;
	C[3] := 1/12;	// C[2*k+1] = B[2*k]/(2*k)!
	f[1] := 2;	// f[k] = (2k)!
	For(k:=2, k<=n/2, k++)	// we could start with k=1 but it would be awkward to compute f[] recursively
	[
		// compute f[k]
		f[k] := f[k-1] * (2*k)*(2*k-1);
		// compute C[k]
		C[2*k+1] := 1/(1-4^(-k))/2*(
			[
				denom := 4;	// = 4^1
				sum := 0;
				For(j:=1, j<=k-1, j++)
				[
					sum := sum + C[2*(k-j)+1]/denom/f[j];	// + C[k-j]/(2*j)! /4^j
					denom := denom * 4;
				];
				(2*k-1)/denom/f[k] - sum;
			]
		);
//	Echo({n, k, denom, C[k]});
	];
	// multiply C's with factorials to get B's
	For(k:=1, k<=n/2, k++)
		C[2*k+1] := C[2*k+1] * f[k];
	// return array object
	C;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/BernoulliFracPart.mpw0000644000175000017500000000167011320776303032475 0ustar  giovannigiovanni%mathpiper,def="BernoulliFracPart"

/// Find the fractional part of Bernoulli number with even index >=2
/// return negative if the sign of the Bernoulli number is negative
BernoulliFracPart(n_IsEven)_(n>=2) <-- [
	Local(p, sum);
	// always 2 and 3
	sum := 1/2+1/3;
	// check whether n+1 and n/2+1 are prime
	If(IsPrime(n+1), sum := sum+1/(n+1));
	If(IsPrime(n/2+1), sum := sum+1/(n/2+1));
	// sum over all primes p such that n / p-1 is integer
	// enough to check up to n/3 now
	For(p:=5, p<=n/3+1, p:=NextPrime(p))
		If(Modulo(n, p-1)=0, sum := sum + 1/p);
	// for negative Bernoulli numbers, let's change sign
	// Modulo(n/2, 2) is 0 for negative Bernoulli numbers and 1 for positive ones
	Quotient(Numerator(sum), Denominator(sum)) - sum
		 + Modulo(n/2,2);	// we'll return a negative number if the Bernoulli itself is negative -- slightly against our definitions in the manual
		//+ 1;	// this would be exactly like the manual says
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bernou/Internal'BernoulliArray.mpw0000644000175000017500000000236311371733712033620 0ustar  giovannigiovanni%mathpiper,def="Internal'BernoulliArray"

/// Simple implementation of the recurrence relation: create an array of Bernoulli numbers
// special cases: n=0 or n=1
10 # Internal'BernoulliArray(n_IsInteger)_(n=0 Or n=1) <-- [
	Local(B);
	B:=ArrayCreate(n+1,0);
	B[1] := 1;
	If(n=1, B[2] := -1/2);
	B;
];
/// Assume n>=2
20 # Internal'BernoulliArray(n_IsInteger) <-- [
	Local(B, i, k, k2, bin);
	If (InVerboseMode(), Echo({"Internal'BernoulliArray: using direct recursion, n = ", n}));
	B:=ArrayCreate(n+1, 0);	// array of B[k], k=1,2,... where B[1] is the 0th Bernoulli number
	// it would be better not to store the odd elements but let's optimize this later
	// we could also maintain a global cache of Bernoulli numbers computed so far, but it won't really speed up things at large n
	// all odd elements after B[2] are zero
	B[1] := 1;
	B[2] := -1/2;
	B[3] := 1/6;
	For(i:=4, i<=n, i := i+2)	// compute and store B[i]
	[	// maintain binomial coefficient
		bin := 1;	// BinomialCoefficient(i+1,0)
		// do not sum over odd elements that are zero anyway - cuts time in half
		B[i+1] := 1/2-1/(i+1)*(1 + Sum(k, 1, i/2-1,
			[
				bin := bin * (i+3-2*k) * (i+2-2*k)/ (2*k-1) / (2*k);
				B[2*k+1]*bin;	// *BinomialCoefficient(i+1, 2*k)
			]
		) );
	];
	B;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/gamma/0000755000175000017500000000000011722677332026166 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/gamma/Internal'LnGammaNum.mpw0000644000175000017500000000435311371733712032453 0ustar  giovannigiovanni%mathpiper,def="Internal'LnGammaNum"

/////////////////////////////////////////////////
/// Euler's Gamma function
/////////////////////////////////////////////////

//Serge Winitzki

/// This procedure computes the uniform approximation for the Gamma function
/// due to Lanczos and Spouge (the so-called "less precise coefficients")
/// evaluated at arbitrary precision by using a large number of terms
/// See J. L. Spouge, SIAM J. of Num. Anal. 31, 931 (1994)
/// See also Paul Godfrey 2001 (unpublished): http://winnie.fit.edu/~gabdo/gamma.txt for a discussion

/// Calculate the uniform approximation to the logarithm of the Gamma function
/// in the Re z > 0 half-plane; argument z may be symbolic or complex
/// but current value of precision is used
/// Note that we return LnGamma(z), not of z+1
/// This function should not be used directly by applications
10 # Internal'LnGammaNum(_z, _a)_(N(Re(z))<0) <-- [
	If (InVerboseMode(), Echo({"Internal'LnGammaNum: using 1-z identity"}));
	N(Ln(Pi/Sin(Pi*z)) - Internal'LnGammaNum(1-z, a));
];
20 # Internal'LnGammaNum(_z, _a) <-- [
	Local(e, k, tmpcoeff, coeff, result);
	a := Maximum(a, 4);	// guard against low values
	If (InVerboseMode(), Echo({"Internal'LnGammaNum: precision parameter = ", a}));
	e := N(Exp(1));
	k:=Ceil(a);	// prepare k=N+1; the k=N term is probably never significant but we don't win much by excluding it
	result := 0;	// prepare for last term
	// use Horner scheme to prevent loss of precision
	While(k>1) [	// 'result' will accumulate just the sum for now
		k:=k-1;
		result := N( PowerN(a-k,k)/((z+k)*Sqrt(a-k))-result/(e*k) );
	];
	N(Ln(1+Exp(a-1)/Sqrt(2*Pi)*result) + Ln(2*Pi)/2 -a-z+(z+1/2)*Ln(z+a) - Ln(z));
];

Internal'LnGammaNum(z) := [
	Local(a, prec, result);
	prec := BuiltinPrecisionGet();
	a:= Quotient((prec-IntLog(prec,10))*659, 526) + 0.4;	// see algorithm docs
	/// same as parameter "g" in Godfrey 2001.
	/// Chosen to satisfy Spouge's error bound:
	/// error < Sqrt(a)/Real(a+z)/(2*Pi)^(a+1/2)
//	Echo({"parameter a = ", a, " setting precision to ", Ceil(prec*1.4)});
	BuiltinPrecisionSet(Ceil(prec*1.4));	// need more precision b/c of roundoff errors but don't know exactly how many digits
	result := Internal'LnGammaNum(z,a);
	BuiltinPrecisionSet(prec);
	result;
];


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/gamma/Internal'GammaNum.mpw0000644000175000017500000000034311371733712032154 0ustar  giovannigiovanni%mathpiper,def="Internal'GammaNum"

//Serge Winitzki

Internal'GammaNum(z) := N(Exp(Internal'LnGammaNum(z)));

/// this should not be used by applications
Internal'GammaNum(z,a) := N(Exp(Internal'LnGammaNum(z,a)));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/PolyLog.mpw0000644000175000017500000000567711316304766027232 0ustar  giovannigiovanni%mathpiper,def="PolyLog"

//Jonathan Leto

////// Polylogarithm Function
/// coded by Jonathan Leto: PolyLog, Dirichlet*, Digamma, Bessel*, Erf*, Fresnel*, Beta,
///			    CatalanConstNum, Sinc, Beta, DawsonIntegral
// Note: currently, the numerics are only working for x \in [-1,1]

10 # PolyLog(_n,0)		<-- 0;
// this is nicer than -Ln(1/2)
10 # PolyLog(1,1/2)             <-- Ln(2);
10 # PolyLog(_n,1)		<-- Zeta(n);
10 # PolyLog(_n,_m)_(m= -1)	<-- DirichletEta(n);
10 # PolyLog(_n,_x)_(n< 0)	<-- (1/((1-x)^(-n+1)))*Sum(i,0,-n,Eulerian(-n,i)*x^(-n-i) );
//10 # PolyLog(_n,_x)_(n= -3)	<-- x*(x^2 + 4*x + 1)/(x-1)^4;
//10 # PolyLog(_n,_x)_(n= -2)	<-- x*(x+1)/(1-x)^3;
//10 # PolyLog(_n,_x)_(n= -1)	<-- x/(1-x)^2;
10 # PolyLog(0,_x)		<-- x/(1-x);
10 # PolyLog(1,_x)		<-- -Ln(1-x);
// special values
10 # PolyLog(2,1/2)		<-- (Pi^2 - 6*Ln(2)^2)/12;
10 # PolyLog(3,1/2)		<-- (4*Ln(2)^3 - 2*Pi^2*Ln(2)+21*Zeta(3))/24;
10 # PolyLog(2,2)		<-- Pi^2/4 - Pi*I*Ln(2);

20 # PolyLog(_n,_x)_(InNumericMode() And  x < -1 )  <-- [
	Local(prec,result);
	prec:=BuiltinPrecisionGet();
	BuiltinPrecisionSet(prec+5);
	Echo("Warning: PolyLog is only currently accurate for x in [-1,1]");
	result:= (-1)^(n-1)*PolyLog(n,1/x) - ((Ln(-x))^n)/n! -
	Sum(r,1,Round(n/2),
		2^(2*r-2)*Pi^(2*r)*Abs(Bernoulli(2*r))*Ln(-x)^(n-2*r)/( (2*r)! * (n - 2*r)! ) );
	BuiltinPrecisionSet(prec);
	RoundTo(N(result),prec);
];
20 # PolyLog(_n,_x)_(InNumericMode() And x>= -1 And x < 0 ) <-- [
	// this makes the domain [-1,0) into [0,1],
	// so if the summation representation is used, it is monotone
        Local(prec,result);
        prec:=BuiltinPrecisionGet();
        BuiltinPrecisionSet(prec+5);

	result:=PolyLog(n,x^2)/2^(n-1) - PolyLog(n,-x) ;
        BuiltinPrecisionSet(prec);
        RoundTo(N(result),prec);

];
/* this is very slow at high precision
20 # PolyLog(_n,_x)_(InNumericMode() And x > 0 And x <= 1) <-- [
	Local(result,prec,term,k,eps);
	prec:=BuiltinPrecisionGet();
  BuiltinPrecisionSet(prec+5);
	eps:=10^(-prec);
	result:=0;
	// Sorry Serge, I was only getting 2 digits of precision with this
		// so why didn't you ask me? :) -- Serge
	//terms:=Floor(10 + N(prec*Ln(10)/Ln(prec) - 1));
	//BuiltinPrecisionSet( prec + Floor(N(Ln(6*terms)/Ln(10))) );
	//result:=SumTaylorNum(x, {{k}, x^(k+1)/(k+1)^n }, terms );
	term:=1;
	For(k:=1,Abs(term)>eps,k++)[
		term:=N(x^k/k^n);
		result:=result+term;
	];
	BuiltinPrecisionSet(prec);
	RoundTo(result,prec);
];
*/

20 # PolyLog(_n,_x)_(InNumericMode() And x > 0 And x < 1) <--
[	// use Taylor series x^(k+1)/(k+1)^n, converges for -1= -Exp(-1)$. (This point is a logarithmic branching point.)
*/
10 # Internal'LambertWNum(x_IsNumber)_(x < -ExpN(-1)) <-- Undefined;
20 # Internal'LambertWNum(x_IsNumber) <--
[
	Local(W);
	NewtonNum(
	  `Hold(
	  {
	  {W},
	  [
	  	Local(a);
		a:=W- @x*ExpN(-W);
		W-a/(W+1-(W+2)/(W+1)*a/2.);
	  ]}),
	// initial approximation is the two-point global Pade:
	  If(
		x<0,
		x*ExpN(1) / (1+1 / (1 / SqrtN(2*(x*ExpN(1)+1)) - 1 / SqrtN(2) + 1/(ExpN(1)-1))),
		Internal'LnNum(1+x)*(1-Internal'LnNum(1+Internal'LnNum(1+x))/(2+Internal'LnNum(1+x)))
	  ),
	  10,	// initial approximation is good to about 3 digits
	  3	// 3rd order scheme
	);
];

%/mathpiper



%mathpiper_docs,name="LambertW",categories="User Functions;Special Functions"
*CMD LambertW --- Lambert's $W$ function

*STD
*CALL
	LambertW(x)
*PARMS

{x} -- expression, argument of the function

*DESC

Lambert's $W$ function is (a multiple-valued, complex function) defined for any (complex) $z$ by
$$ W(z) * Exp(W(z)) = z$$.
This function is sometimes useful to represent solutions of transcendental equations. For example, the equation $Ln(x)=3*x$ can be "solved" by writing $x= -3*W(-1/3)$. It is also possible to take a derivative or integrate this function "explicitly".

For real arguments $x$, $W(x)$ is real if $x>= -Exp(-1)$.

To compute the numeric value of the  principal branch of Lambert's $W$ function for real arguments $x>= -Exp(-1)$ to current precision, one can call {N(LambertW(x))} (where the function {N} tries to approximate its argument with a real value).

*E.G.
In> LambertW(0)
Result: 0;
In> N(LambertW(-0.24/Sqrt(3*Pi)))
Result: -0.0851224014;

*SEE Exp
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Zeta.mpw0000644000175000017500000000251211523200452026514 0ustar  giovannigiovanni%mathpiper,def="Zeta"

/////////////////////////////////////////////////
/// Riemann's Zeta function
/////////////////////////////////////////////////
/// Serge Winitzki

/// identities for exact values of Zeta

10 # Zeta(1) <-- Infinity;
10 # Zeta(0) <-- -1/2;	// let's save time
10 # Zeta(3)_InNumericMode() <-- Zeta3();	// special case
10 # Zeta(n_IsEven)_(n>0) <-- Pi^n*(2^(n-1)/n! *Abs(Bernoulli(n)));
10 # Zeta(n_IsInteger)_(n<0) <-- -Bernoulli(-n+1)/(-n+1);
11 # Zeta(n_IsInfinity) <-- 1;

/// compute numeric value
20 # Zeta(s_IsConstant)_(InNumericMode()) <-- Internal'ZetaNum(N(Eval(s)));

%/mathpiper



%mathpiper_docs,name="Zeta",categories="User Functions;Special Functions"
*CMD Zeta --- Riemann's Zeta function

*STD
*CALL
	Zeta(x)

*PARMS

{x} -- expression

{number} -- expression that can be evaluated to a number

*DESC

{Zeta(x)} is an interface to Riemann's Zeta function $zeta(s)$. It returns exact values on integer and half-integer arguments. {N(Zeta(x)} takes a numeric parameter and always returns a floating-point number in the current precision.

*E.G.

In> Precision(30)
Result: True;
In> Zeta(1)
Result: Infinity;
In> Zeta(1.3)
Result: Zeta(1.3);
In> N(Zeta(1.3))
Result: 3.93194921180954422697490751058798;
In> Zeta(2)
Result: Pi^2/6;
In> N(Zeta(2));
Result: 1.64493406684822643647241516664602;

*SEE !, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/BesselY.mpw0000644000175000017500000000026711316304766027201 0ustar  giovannigiovanni%mathpiper,def="BesselY"
//Jonathan Leto

// This is buggy
40 # BesselY(_n,x_IsComplex)_(Abs(x)<= 2*Gamma(n) )  <-- N((Cos(n*Pi)*BesselJ(n,x) - BesselJ(-n,x))/Sin(Pi*n));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Beta.mpw0000644000175000017500000000014711316304766026503 0ustar  giovannigiovanni%mathpiper,def="Beta"

//Jonathan Leto

10 # Beta(_n,_m)	<-- Gamma(m)*Gamma(n)/Gamma(m+n);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/ApproxInfSum.mpw0000644000175000017500000000241011316304766030216 0ustar  giovannigiovanni%mathpiper,def="ApproxInfSum"

//Jonathan Leto

// Ex:
// Bessel of order n:
// ApproxInfSum((-1)^k*(x/2)^(2*k+c[1])/(k! * Gamma(k+c[1]+1) ),1,x,{n} );

Function("ApproxInfSum",{expr,start,x})[
	ApproxInfSum(expr,start,x,{0});
];

/// FIXME this has a roundoff problem when InNumericMode()=True
// Summation must be on k
Function("ApproxInfSum",{expr,start,x,c})
[
        Local(term,result,k);
        Local(prec,eps,tmp);
        prec:=BuiltinPrecisionGet();
//        BuiltinPrecisionSet(Ceil(1.2*prec)); // this is a guess
        BuiltinPrecisionSet(prec+2); // this is a guess
//        eps:=5*10^(-prec);
        eps:=10^(-prec);
//Echo(expr);
//Echo("     eps = ",N(Eval(eps)));

        term:=1;
        k:=start;
        result:=0;
        While( N(Abs(term) >= eps) )[
                term:=N(Eval(expr));
		//Echo({"term is ",term});
                k:=k+1;
		result:=result+term;

        ];
		If(InVerboseMode(), Echo("ApproxInfSum: Info: using ", k, " terms of the series"));
        BuiltinPrecisionSet(prec);
        // This should not round, only truncate
        // some outputs will be off by one in the last digit

//Echo("lastterm = ",N(Eval(term)));

//Echo("r1",result);
//Echo("r2",RoundTo(result,prec));
//Echo("r3",N((result/10)*10));

  result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Bernoulli.mpw0000644000175000017500000000362211523200452027547 0ustar  giovannigiovanni%mathpiper,def="Bernoulli"

/////////////////////////////////////////////////
/// Bernoulli numbers and polynomials
/////////////////////////////////////////////////
/// Serge Winitzki

/// Bernoulli(n): interface to Bernoulli numbers
10 # Bernoulli(0) <-- 1;
10 # Bernoulli(1) <-- -1/2;
15 # Bernoulli(n_IsInteger)_(n<0) <-- Undefined;
30 # Bernoulli(n_IsOdd) <-- 0;

/// numerical computations of Bernulli numbers use two different methods, one good for small numbers and one good only for very large numbers (using Zeta function)
20 # Bernoulli(n_IsEven)_(n<=Bernoulli1Threshold()) <-- Internal'BernoulliArray(n)[n+1];
20 # Bernoulli(n_IsEven)_(n>Bernoulli1Threshold()) <-- Bernoulli1(n);

LocalSymbols(bernoulli1Threshold) [
  /// Bernoulli1Threshold could in principle be set by the user
  If(Not IsBound(bernoulli1Threshold), bernoulli1Threshold := 20);

  Bernoulli1Threshold() := bernoulli1Threshold;
  SetBernoulli1Threshold(threshold) := [ bernoulli1Threshold := threshold;];

] ; // LocalSymbols(bernoulli1Threshold)

/// Bernoulli polynomials of degree n in variable x
Bernoulli(n_IsInteger, _x) <-- [
	Local(B, i, result);
	B := Internal'BernoulliArray(n);
	result := B[1];
	For(i:=n-1, i>=0, i--) [
		result := result * x + B[n-i+1]*BinomialCoefficient(n,i);
	];
	result;
];

%/mathpiper



%mathpiper_docs,name="Bernoulli",categories="User Functions;Special Functions"
*CMD Bernoulli --- Bernoulli numbers and polynomials
*STD
*CALL
	Bernoulli(index)
	Bernoulli(index, x)

*PARMS

{x} -- expression that will be the variable in the polynomial

{index} -- expression that can be evaluated to an integer

*DESC

{Bernoulli(n)} evaluates the $n$-th Bernoulli number. {Bernoulli(n, x)} returns the $n$-th Bernoulli polynomial in the variable $x$. The polynomial is returned in the Horner form.

*E.G.

In> Bernoulli(20);
Result: -174611/330;
In> Bernoulli(4, x);
Result: ((x-2)*x+1)*x^2-1/30;

*SEE Gamma, Zeta
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Erfc.mpw0000644000175000017500000000012311316304766026501 0ustar  giovannigiovanni%mathpiper,def="Erfc"

//Jonathan Leto

10 # Erfc(_x)		<-- 1 - Erf(x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/BesselI.mpw0000644000175000017500000000171011316304766027153 0ustar  giovannigiovanni%mathpiper,def="BesselI"

//Jonathan Leto

10 # BesselI(0,0)	<-- 1;

10 # BesselI(_n,0)_(n>0) <-- 0;

10 # BesselI(_n,0)_(n<0 And IsInteger(n)) <-- 0;


// The following should be ComplexInfinity, if/when that is implemented
10 # BesselI(_n,0)_(n<0 And Not IsInteger(n)) <-- Infinity;


20 # BesselI(1/2,_x)	<-- Sqrt(2/(x*Pi))*Sinh(x);


20 # BesselI(3/2,_x)    <-- Sqrt(2/(x*Pi))*(Cosh(x) - Sinh(x)/x);


20 # BesselI(5/2,_x)    <-- Sqrt(2/(x*Pi))*((3/x^2 + 1)*Sinh(x) - 3*Cosh(x)/x );


30 # BesselI(_n,_z)_(n<0 And IsInteger(n) ) <-- BesselI(-n,z);


// When I put "And InNumericMode()" on the next rule, I lose precision. Why ?
// Also, if I move the the "_IsComplex" to the end with "IsComplex(x)"
// I lose precision.


//40 # BesselI(_n,x_IsComplex)_(Abs(x)<= 2*Gamma(n) )  <-- N(BesselNsmall(n,x,1));


40 # BesselI(_n,x_IsComplex)_(IsConstant(x) And Abs(x)<= 2*Gamma(n) )  <--
[
ApproxInfSum((x/2)^(2*k+c[1])/(k! * Gamma(k+c[1]+1) ),0,x,{n} );
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Erfi.mpw0000644000175000017500000000012411316304766026510 0ustar  giovannigiovanni%mathpiper,def="Erfi"

//Jonathan Leto

10 # Erfi(_x)		<-- -I*Erf(x*I);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/CatalanConstNum.mpw0000644000175000017500000000506511320775271030664 0ustar  giovannigiovanni%mathpiper,def="CatalanConstNum"

//Jonathan Leto

/////////////////////////////////////////////////
/// Catalan's constant, various algorithms for comparison. (SW)
/////////////////////////////////////////////////

/* Brent-Fee's method based on Ramanujan's identity and Brent's trick.
 * Geometric convergence as 2^(-n). */
CatalanConstNum1() :=
[
  Local(prec,Aterm,Bterm,nterms,result,n);
  prec:=BuiltinPrecisionGet();
	BuiltinPrecisionSet(10);
	// estimate the number of terms from above
	nterms := 1+Floor(N((prec*Ln(10)+Ln(prec*Ln(10)/Ln(2)))/Ln(2)));
  BuiltinPrecisionSet(prec+5);
	Aterm:=N(1/2);
  result:= Aterm;
  Bterm:=Aterm;
  For(n:=1, n<=nterms, n++ )
	[
/*
    Bterm := MultiplyNum(Bterm, n/(2*n+1));
    Aterm:= DivideN(MultiplyNum(Aterm,n)+Bterm, 2*n+1);
/* this is faster: */
    Bterm:=DivideN(MultiplyN(Bterm,n), 2*n+1); // Bterm = (k!)^2*2^(k-1)/(2*k+1)!
    Aterm:=DivideN(MultiplyN(Aterm,n)+Bterm, 2*n+1); // Aterm = Bterm * Sum(k,0,n,1/(2*k+1))
/**/
    result := result + Aterm;
  ];
  BuiltinPrecisionSet(prec);
  RoundTo(result,prec);
];

/* Bailey 1997's method.
 * Geometric convergence as 4^(-n). */

CatalanConstNum() :=
[
	Local(prec, n, result);
	prec:=BuiltinPrecisionGet();

	// number of terms
	n := 1+Quotient(prec*1068+642,643); // prec*Ln(10)/Ln(4)
	BuiltinPrecisionSet(prec+2);	// 2 guard digits

	result := N(1/(2*n+1));
	While(n>0)
	[
/*
		result := MultiplyNum(result, n/(4*n+2))+N(1/(2*n-1));
/* this is faster: */
		result := DivideN(MultiplyN(result, n), 4*n+2)+DivideN(1,2*n-1);
/**/
		n := n-1;
	];
	result := MultiplyNum(result, 3/8) + N(Pi/8*Ln(2+Sqrt(3)));
	BuiltinPrecisionSet(prec);
	RoundTo(result,prec);
];

/* Broadhurst's series.
 * Geometric convergence as 16^(-n). */

CatalanConstNum2() :=
[
	Local(prec, n, result1, result2);
	prec:=BuiltinPrecisionGet();

	// first series
	// number of terms
	n := 1+Quotient(prec*534+642,643); // prec*Ln(10)/Ln(16)
	BuiltinPrecisionSet(prec+2);	// 2 guard digits

	result1 := 0;
	While(n>=0)
	[
		result1 := DivideN(result1, 16)+N(
			+1/(8*n+1)^2 -1/(8*n+2)^2 +1/2/(8*n+3)^2 -1/4/(8*n+5)^2 +1/4/(8*n+6)^2 -1/8/(8*n+7)^2
		);
		n := n-1;
	];

	// second series
	// number of terms
	n := 1+Quotient(prec*178+642,643); // prec*Ln(10)/Ln(4096)
	BuiltinPrecisionSet(prec+2);	// 2 guard digits

	result2 := 0;
	While(n>=0)
	[
		result2 := DivideN(result2, 4096)+N(
			+1/(8*n+1)^2 +1/2/(8*n+2)^2 +1/8/(8*n+3)^2 -1/64/(8*n+5)^2 -1/128/(8*n+6)^2 -1/512/(8*n+7)^2
		);
		n := n-1;
	];
	result1 := MultiplyNum(result1, 3/2) - MultiplyNum(result2, 1/4);
	BuiltinPrecisionSet(prec);
	RoundTo(result1,prec);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Digamma.mpw0000644000175000017500000000017511316304766027170 0ustar  giovannigiovanni%mathpiper,def="Digamma"

//Jonathan Leto

10 # Digamma(_n)_(IsPositiveInteger(n)) <-- Sum(m,1,n-1,1/m) - gamma;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bessel/0000755000175000017500000000000011722677332026361 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bessel/BesselNsmall.mpw0000644000175000017500000000213511371733712031466 0ustar  giovannigiovanni%mathpiper,def="BesselNsmall"

/// coded by Jonathan Leto

// When x is <= 1, the series is monotonely decreasing from the
// start, so we don't have to worry about loss of precision from the
// series definition.
// When {n} is an integer, this is fast.
// When {n} is not, it is pretty slow due to Gamma()

Function("BesselNsmall",{n,x,modified})
[
        Local(term,result,k);
        Local(prec,eps,tmp);
        prec:=BuiltinPrecisionGet();
        BuiltinPrecisionSet(Ceil(1.2*prec)); // this is a guess
        eps:=5*10^(-prec);

        term:=1;
        k:=0;
        result:=0;
        While( Abs(term) >= eps )[
                term:=x^(2*k+n);
		// The only difference between BesselJ and BesselI
		// is an alternating term
		If( k%2=1 And modified=0 , term:=term*-1 );
		term:=N(term/(2^(2*k+n)* k! * Gamma(k+n+1) ));
                //Echo({"term is ",term});
                result:=result+term;
                k:=k+1;
        ];
        BuiltinPrecisionSet(prec);
	// This should not round, only truncate
	// some outputs will be off by one in the last digit
	RoundTo(result,prec);

];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bessel/BesselJN.mpw0000644000175000017500000000011611316304766030546 0ustar  giovannigiovanni%mathpiper,def=""

//Was not implemented in the scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/bessel/BesselJN0.mpw0000644000175000017500000000246611371733712030636 0ustar  giovannigiovanni%mathpiper,def="BesselJN0"

/// coded by Jonathan Leto

// Seems to get about 8 digits precision for most real numbers
// Only about 2 digits precision for complex
// This is just a temporary implementation, I would not want to
// expose users to it until it is much more robust
// I am still looking for a good arbitrary precision algorithm.
Function("BesselJN0",{x})
[
	Local(ax,z,xx,y,result,res1,res2);
	Local(c1,c2,c3,c4);

	// Coefficients of the rational polynomials to
	// approx J_0  for x < 8
	c1:={57568490574.0,-13362590354.0,651619640.7,
		-11214424.18,77392.33017,-184.9052456};
	c2:={57568490411.0,1029532985.0,9494680.718,
		59272.64853,267.8532712};
	// Coefficients of the rational polynomials to
	// approx J_0 for x >= 8
	c3:={-0.001098628627,0.00002734510407,-0.000002073370639,
		0.0000002093887211};
	c4:={-0.01562499995,0.0001430488765,-0.000006911147651,
		0.0000007621095161,0.0000000934935152};
	ax:=Abs(x);

	If( ax < 8.0,[
		y:=x^2;
		res1:=c1[1]+y*(c1[2]+y*c1[3]+y*(c1[4]+y*(c1[5]+y*(c1[6]))));
		res2:=c1[1]+y*(c2[2]+y*c2[3]+y*(c2[4]+y*(c2[5]+y*1.0)));
		result:=res1/res2;
	],[
		z:=8/ax;
		y:=z^2;
		xx:=ax-0.785398164;
		res1:=1.0+y*(c3[1]+y*(c3[2]+y*(c3[3]+y*c4[4])));
		res2:=c4[1]+y*(c4[2]+y*(c4[3]+y*(c4[4]-y*c4[5])));
		result:=Sqrt(2/(Pi*x))*(Cos(xx)*res1-z*Sin(xx)*res2);
	] );
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Gamma.mpw0000644000175000017500000000241711523200452026637 0ustar  giovannigiovanni%mathpiper,def="Gamma"

/////////////////////////////////////////////////
/// Euler's Gamma function
////////////////////////////////////////////////////
/// Serge Winitzki

/// User visible functions: Gamma(x), LnGamma(x)

5 # Gamma(Infinity)	<-- Infinity;

10 # Gamma(_n)_(IsInteger(n) And n<=0) <-- Infinity;


20 # Gamma(n_IsRationalOrNumber)_(IsPositiveInteger(n) Or FloatIsInt(2*n)) <-- (Round(2*n)/2-1)!;


30 # Gamma(x_IsConstant)_(InNumericMode()) <-- Internal'GammaNum(N(Eval(x)));


%/mathpiper



%mathpiper_docs,name="Gamma",categories="User Functions;Special Functions"
*CMD Gamma --- Euler's Gamma function
*STD
*CALL
	Gamma(x)

*PARMS

{x} -- expression

{number} -- expression that can be evaluated to a number

*DESC

{Gamma(x)} is an interface to Euler's Gamma function $Gamma(x)$. It returns exact values on integer and half-integer arguments. {N(Gamma(x)} takes a numeric parameter and always returns a floating-point number in the current precision.

Note that Euler's constant $gamma<=>0.57722$ is the lowercase {gamma} in MathPiper.

*E.G.

In> Gamma(1.3)
Result: Gamma(1.3);
In> N(Gamma(1.3),30)
Result: 0.897470696306277188493754954771;
In> Gamma(1.5)
Result: Sqrt(Pi)/2;
In> N(Gamma(1.5),30);
Result: 0.88622692545275801364908374167;

*SEE !, N, gamma
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/gammaconst/0000755000175000017500000000000011722677332027235 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/gammaconst/GammaConstNum.mpw0000644000175000017500000000201111316304766032462 0ustar  giovannigiovanni%mathpiper,def="GammaConstNum"

GammaConstNum() :=
[
  Local(k, n, A, B, U'old, U, V'old, V, prec, result);
  prec:=BuiltinPrecisionGet();
  NonN([
    BuiltinPrecisionSet(prec+IntLog(prec,10)+3);	// 2 guard digits and 1 to compensate IntLog
    n:= 1+Ceil(prec*0.5757+0.2862);	// n>(P*Ln(10)+Ln(Pi))/4
    A:= -Internal'LnNum(n);
    B:=1;
    U:=A;
    V:=1;
    k:=0;
    U'old := 0;	// these variables are for precision control
    V'old := 0;
    While(U'old-U != 0 Or V'old-V != 0)
    [
     k++;
     U'old:=U;
     V'old:=V;
     // B:=N( B*n^2/k^2 );
     B:=MultiplyNum(B,n^2/k^2);	// slightly faster
     // A:=N( (A*n^2/k+B)/k );
     A:=MultiplyNum(MultiplyNum(A,n^2/k)+B, 1/k);	// slightly faster
     U:=U+A;
     V:=V+B;
    ];
    If(InVerboseMode(), Echo("GammaConstNum: Info: used", k, "iterations at working precision", BuiltinPrecisionGet()));
    result:=DivideN(U,V);	// N(U/V)
  ]);
  BuiltinPrecisionSet(prec);	// restore precision
  RoundTo(result, prec);	// return correctly rounded result
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/Sinc.mpw0000644000175000017500000000013311316304766026517 0ustar  giovannigiovanni%mathpiper,def="Sinc"

//Jonathan Leto

10 # Sinc(_x)		<-- If(x=0,1,Sin(x)/x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/zeta/0000755000175000017500000000000011722677332026047 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/specfunc/zeta/zeta.mpw0000644000175000017500000000757011316304766027545 0ustar  giovannigiovanni%mathpiper,def="Internal'ZetaNum;Internal'ZetaNum1;Internal'ZetaNum2;Zeta3"

/* def file definitions
Internal'ZetaNum
Internal'ZetaNum1
Internal'ZetaNum2
Zeta3
*/

/////////////////////////////////////////////////
/// Riemann's Zeta function
/////////////////////////////////////////////////

//Serge Winitzki

/// See: Bateman, Erdelyi: Higher Transcendental Functions, vol. 1;
/// P. Borwein, An efficient algorithm for Riemann Zeta function (1995).

/// Numerical computation of Zeta function using Borwein's "third" algorithm
/// The value of $n$ must be large enough to ensure required precision
/// Also $s$ must satisfy $Re(s)+n+1 > 0$
Internal'ZetaNum(_s, n_IsInteger) <-- [
	Local(result, j, sign);
	If (InVerboseMode(), Echo({"Internal'ZetaNum: Borwein's method, precision ", BuiltinPrecisionGet(), ", n = ", n}));
	result := 0;
	sign := 1;	// flipping sign
	For(j:=0, j<=2*n-1, j++)
	[	// this is suboptimal b/c we can compute the coefficients a lot faster in this same loop, but ok for now
		result := N(result + sign*Internal'ZetaNumCoeffEj(j,n)/(1+j)^s );
		sign := -sign;
	];
	N(result/(2^n)/(1-2^(1-s)));
];

/// direct method -- only good for large s
Internal'ZetaNum1(s, limit) := [
	Local(i, sum);
	If (InVerboseMode(), Echo({"Internal'ZetaNum: direct method (sum), precision ", BuiltinPrecisionGet(), ", N = ", limit}));
	sum := 0;
	limit := Ceil(N(limit));
	For(i:=2, i<=limit, i++) sum := sum+N(1/PowerN(i, s));
//	sum := sum + ( N( 1/PowerN(limit, s-1)) + N(1/PowerN(limit+1, s-1)) )/2/(s-1); 	 // these extra terms don't seem to help much
	sum+1;	// add small terms together and then add 1
];
/// direct method -- using infinite product. For internal math, Internal'ZetaNum2 is faster for Bernoulli numbers > 250 or so.
Internal'ZetaNum2(s, limit) :=
[
	Local(i, prod);
	If (InVerboseMode(), Echo({"Internal'ZetaNum: direct method (product), precision ", BuiltinPrecisionGet(), ", N = ", limit}));
	prod := N( (1-1/PowerN(2, s))*(1-1/PowerN(3,s)) );
	limit := Ceil(N(limit));
	For(i:=5, i<=limit, i:= NextPrime(i))
		prod := prod*N(1-1/PowerN(i, s));
	1/prod;
];

/// Compute coefficients e[j] (see Borwein -- excluding (-1)^j )
Internal'ZetaNumCoeffEj(j,n) := [
	Local(k);
	2^n-If(j1-s identity, s=", s, ", precision ", prec}));
			result :=  2*Exp(Internal'LnGammaNum(1-s)-(1-s)*Ln(2*Internal'Pi()))*Sin(Internal'Pi()*s/2) * Internal'ZetaNum(1-s);
		],
		// choose between methods
		If (N(Re(s)) > N(1+(prec*Ln(10))/(Ln(prec)+0.1), 6),
			[	// use direct summation
				n:= N(10^(prec/(s-1)), 6)+2;	// 2 guard terms
				BuiltinPrecisionSet(prec+2);	// 2 guard digits
				result := Internal'ZetaNum1(s, n);
			],
			[	// use Internal'ZetaNum(s, n)
				n := Ceil( N( prec*Ln(10)/Ln(8) + 2, 6 ) );	// add 2 digits just in case
				BuiltinPrecisionSet(prec+2);	// 2 guard digits
				result := Internal'ZetaNum(s, n);
			]
		)
	);
	BuiltinPrecisionSet(prec);
	result;
];


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/0000755000175000017500000000000011722677337024615 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TExplicitSum.mpw0000644000175000017500000000042211316324171027712 0ustar  giovannigiovanni%mathpiper,def="TExplicitSum"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

/* TExplicitSum sets the dimension of the space under consideration,
   so summation can proceed */
(TExplicitSum(Ndim_IsInteger)(_body)) <-- Eval(body);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TList.mpw0000644000175000017500000000027011371733712026366 0ustar  giovannigiovanni%mathpiper,def="TList"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

Rulebase("TList",{head,tail});

//Not defined in the scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TSumRest.mpw0000644000175000017500000000036411371733712027061 0ustar  giovannigiovanni%mathpiper,def="TSumRest"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

10 # TSumRest({}) <-- 1;
20 # TSumRest(_list) <--
[
   TSumSimplify(TList(First(list),Rest(list)));
];

UnFence("TSumRest",1); 

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TD.mpw0000644000175000017500000000115111321250634025625 0ustar  giovannigiovanni%mathpiper,def="TD"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

Rulebase("TD",{ind});

/* And the simplificaiton rules for X, addition, subtraction
   and multiplication */
10 # (TD(_i)X(_j)) <-- Delta(i,j);
10 # (TD(_i) ( (_f) + (_g) ) ) <-- (TD(i)f) + (TD(i)g);
10 # (TD(_i) ( (_f) - (_g) ) ) <-- (TD(i)f) - (TD(i)g);
10 # (TD(_i) (      - (_g) ) ) <--          -  TD(i)g;
10 # (TD(_i) ( (_f) * (_g) ) ) <-- (TD(i)f)*g + f*(TD(i)g);
10 # (TD(_i) ( (_f) ^ (n_IsPositiveInteger) ) ) <-- n*(TD(i)f)*f^(n-1);
10 # (TD(_i)Delta(_j,_k)) <-- 0;
10 # (TD(_i)f_IsNumber) <-- 0;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/Delta.mpw0000644000175000017500000000033511321250634026352 0ustar  giovannigiovanni%mathpiper,def="Delta"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

/* functions internal to tensors */
Rulebase("Delta",{ind1,ind2});

//Not defined in the scripts. todo:tk.


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/X.mpw0000644000175000017500000000037611371733712025545 0ustar  giovannigiovanni%mathpiper,def=""
//todo:tk:this conflicts with "linalg.rep/code.mpi" when published as a def file.
/* Tensor package. This code intends to simplify tensorial expressions.
 */

Rulebase("X",{ind});

//Not implemented in the scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TSimplify.mpw0000644000175000017500000000257411316324171027252 0ustar  giovannigiovanni%mathpiper,def="TSimplify"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

/* TSimplify : expand brackets, and send the expression of addition
   of terms to TSimplifyAux */
TSimplify(TSum(_indices)(_f)) <--
[
  TSimplifyAux(TSum(indices)ExpandBrackets(f));
];


/* TSimplifyAux : simplify each term independently */
10 # TSimplifyAux(TSum(_indices)((_f) + (_g))) <--
     TSimplifyAux(TSum(FlatCopy(indices))(f)) +
     TSimplifyAux(TSum(FlatCopy(indices))(g));
10 # TSimplifyAux(TSum(_indices)((_f) - (_g))) <--
     TSimplifyAux(TSum(FlatCopy(indices))(f)) -
     TSimplifyAux(TSum(FlatCopy(indices))(g));
10 # TSimplifyAux(TSum(_indices)(   - (_g))) <--
                                    -  TSimplifyAux(TSum(indices)(g));

40 # TSimplifyAux(TSum(_indices)_body) <--
[
  Local(flat);

  /* Convert expressions of the form (a*b*c) to {a,b,c} */
  flat:=Flatten(body,"*");

  /* Move the deltas to the front. */
  flat:=MoveDeltas(flat);

  /* Simplify the deltas away (removing the required indices) */
  flat:=TSumRest(flat);

  /* Determine if there are indices the summand still depends on */
  Local(varlist,independ,nrdims);
  varlist:=VarList(flat);
  independ:=Intersection(indices,varlist);
  nrdims:=Length(indices)-Length(independ);

  /* Return result, still summing over the indices not removed by deltas */
  Ndim^nrdims*TSum(independ)flat;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/MoveDeltas.mpw0000644000175000017500000000100111371733712027363 0ustar  giovannigiovanni%mathpiper,def="MoveDeltas"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

/* Move the delta factors to the front, so they can be simplified
   away. It uses ApplyDelta to move a factor either to the front
   or to the back of the list. Input is a list of factors, as
   returned by Flatten(expressions,"*")
   */
MoveDeltas(_list) <--
[
  Local(result,i,nr);
  result:={};
  nr:=Length(list);
  For(i:=1,i<=nr,i++)
  [
    ApplyDelta(result,list[i]);
  ];
  result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TSumSimplify.mpw0000644000175000017500000000234311371733712027737 0ustar  giovannigiovanni%mathpiper,def="TSumSimplify"

/* Terminating condition for the tensorial simplification */

10 # TSumSimplify(TList(Delta(_ind,_ind),_list))_Contains(indices,ind) <--

[
  /* Remove the index from the list of indices to sum over, since
     it is now implicitly summed over by simplifying the delta */
  DestructiveDelete(indices,Find(indices,ind));

/* Return result simplified for this delta */
  Ndim*TSumRest(list);
];

11 # TSumSimplify(TList(Delta(_ind1,_ind2),_list))_
     Contains(indices,ind2) <--
[
  /* Remove the index from the list of indices to sum over, since
     it is now implicitly summed over by simplifying the delta */
  DestructiveDelete(indices,Find(indices,ind2));

  /* Return result simplified for this delta */
  TSumRest( Subst(ind2,ind1)list );
];
11 # TSumSimplify(TList(Delta(_ind1,_ind2),_list))_
     Contains(indices,ind1) <--
[
  /* Remove the index from the list of indices to sum over, since
     it is now implicitly summed over by simplifying the delta */
  DestructiveDelete(indices,Find(indices,ind1));

  /* Return result simplified for this delta */
  TSumRest( Subst(ind1,ind2)list );
];



1010 # TSumSimplify(TList(_term,_list)) <--
[
  term*TSumRest(list);
];

UnFence("TSumSimplify",1); 

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/ApplyDelta.mpw0000644000175000017500000000066211371733712027373 0ustar  giovannigiovanni%mathpiper,def="ApplyDelta"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

10  # ApplyDelta(_result,Delta(_i,_j)) <--
    DestructiveInsert(result,1,Delta(i,j));
20 # ApplyDelta(_result,(_x) ^ (n_IsInteger))_(n>0) <--
    [
      Local(i);
      For(i:=1,i<=n,i++)
      [
        ApplyDelta(result,x);
      ];
    ];
100 # ApplyDelta(_result,_term) <--
    DestructiveAppend(result,term);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/tensor/TSum.mpw0000644000175000017500000000131311331203122026175 0ustar  giovannigiovanni%mathpiper,def="TSum"

/* Tensor package. This code intends to simplify tensorial expressions.
 */

Rulebase("TSum",{indices,body});

/* The only TSum summation simplification: summing over no indices
   means no summation. */
10 # (TSum({})(_body)) <-- body;

/* Explicit summation when Ndim is defined. This summation will
   be invoked when using TExplicitSum. */
20 # (TSum(_indices)(_body))_(IsInteger(Ndim)) <--
    LocalSymbols(index,i,sum)
    [
      Local(index,i,sum);
      index:=indices[1];
      sum:=0;
      MacroLocal(index);
      For(i:=1,i<=Ndim,i++)
      [
        MacroBind(index,i);
        sum:=sum+Eval(TSum(Rest(indices))body);
      ];
      sum;
    ];

UnFence("TSum",2);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/0000755000175000017500000000000011722677336024550 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/period_operator.mpw0000644000175000017500000000117211523200452030447 0ustar  giovannigiovanni%mathpiper,def=""

//////
// dot product for vectors and matrices (dr)
//////

//_x . _y <-- Dot(x,y);

%/mathpiper




mathpiper_docs,name=".",categories="Operators"
*CMD . --- get dot product of tensors
*STD
*CALL
	t1 . t2
Precedence:
*EVAL PrecedenceGet(".")

*PARMS

{t1,t2} -- tensor lists (currently only vectors and matrices are supported)

*DESC

See the {Dot} function for more information.

*SEE Dot
/mathpiper_docs


	Or, using the "."-Operator:

In> {1,2} . {3,4}
Result: 11;
In> {{1,2},{3,4}} . {5,6}
Result: {17,39};
In> {5,6} . {{1,2},{3,4}}
Result: {23,34};
In> {{1,2},{3,4}} . {{5,6},{7,8}}
Result: {{19,22},{43,50}};mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/InfinityNorm.mpw0000644000175000017500000000167511523200452027707 0ustar  giovannigiovanni%mathpiper,def="xnfinityNorm"

//Retract("InfinityNorm",*);


10 # InfinityNorm( M_IsMatrix ) <--
[
	Local(sumlist,row);
	sumlist := {};
    ForEach(row,M)
        Push(sumlist,Sum(Abs(row)));
    Maximum(sumlist);
];

10 # InfinityNorm( M_IsVector ) <-- Maximum(Abs(M));

%/mathpiper

   





%mathpiper_docs,name="InfinityNorm",categories="User Functions;Linear Algebra"
*CMD InfinityNorm --- Compute the "Infinity Norm" of a Vector or Matrix
*STD
*CALL
	InfinityNorm(Matrix)
*PARMS

{Matrix} -- a Matrix or Vector


*DESC

The function {InfinityNorm} calculates one of the most valuable types
of Norm for Matrices.  It can also be applied to Vectors, but is less
often used that way.

For a Matrix, the so-called "Infinity Norm" is calculated by finding the 
sum of the absolute values of all the elements in each row, then returning
the largest of these row sums.   


*E.G.

In> InfinityNorm({{3,5,7},{2,-6,4},{0,2,8}})
Result: 15

%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/LU.mpw0000644000175000017500000000222411322513743025600 0ustar  giovannigiovanni%mathpiper,def="LU"

// In place LU decomposition
// Pivotting is not implemented
// Adapted from Numerical Methods with Matlab
//	Gerald Recktenwald, Sec 8.4
10 # LU(A_IsSquareMatrix) <--
[
	Local(n,matrix,L,U);
	n:=Length(A);
	L:=ZeroMatrix(n,n);
	U:=ZeroMatrix(n,n);
	matrix:=ZeroMatrix(n,n);

        ForEach(i,1 .. n)
                ForEach(j,1 .. n)
                        matrix[i][j] := A[i][j];

	// loop over pivot rows
	ForEach(i,1 ..(n-1))[
		// loop over column below the pivot
		ForEach(k,i+1 .. n)[
			// compute multiplier and store it in L
			matrix[k][i] := matrix[k][i] / matrix[i][i];
			// loop over elements in row k
			ForEach(j,i+1 .. n)[
				matrix[k][j] := matrix[k][j] - matrix[k][i]*matrix[i][j];
			];
		];
	];
	ForEach(i,1 .. n)[
		ForEach(j,1 .. n)[
			If(i<=j,U[i][j]:=matrix[i][j],L[i][j]:=matrix[i][j]);
		];
		// diagonal of L is always 1's
		L[i][i]:=1;
	];

	{L,U};
];


%/mathpiper




%mathpiper_docs,name="LU",categories="User Functions;Linear Algebra"
*CMD LU --- in-place LU decomposition
*CALL
	LU(matrix)

*PARMS
{matrix} -- a matrix

*DESC
todo

*E.G.
todo
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Deteminant.mpw0000644000175000017500000000231611523200452027343 0ustar  giovannigiovanni%mathpiper,def="Determinant"

10 # Determinant(_matrix)_(IsUpperTriangular(matrix) Or IsLowerTriangular(matrix)) <--
[
	Local(result);
	result:=1;
	ForEach(i, Diagonal(matrix) )
		result:=result*i;
	result;
];

//
// The fast determinant routine that does the determinant numerically, rule 20,
// divides things by the elements on the diagonal of the matrix. So if one of these
// elements happens to be zero, the result is something like Infinity or Undefined.
// Use the symbolic determinant in that case, as it is slower but much more robust.
//
15 # Determinant(_matrix)_(Length(Select(Diagonal(matrix), "IsZero")) > 0) <-- SymbolicDeterminant(matrix);

// Not numeric entries, so lets treat it symbolically.
16 # Determinant(_matrix)_(VarList(matrix) != {}) <-- SymbolicDeterminant(matrix);

20 # Determinant(_matrix) <-- GaussianDeterminant(matrix);

%/mathpiper



%mathpiper_docs,name="Determinant",categories="User Functions;Linear Algebra"
*CMD Determinant --- determinant of a matrix
*STD
*CALL
	Determinant(M)

*PARMS

{M} -- a matrix

*DESC

Returns the determinant of a matrix M.

*E.G.

In> A:=DiagonalMatrix(1 .. 4)
Result: {{1,0,0,0},{0,2,0,0},{0,0,3,0},{0,0,0,4}};
In> Determinant(A)
Result: 24;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/HankelMatrix.mpw0000644000175000017500000000076711322513743027661 0ustar  giovannigiovanni%mathpiper,def="HankelMatrix"

// The arguments of the following functions should be checked
HankelMatrix(n):=GenMatrix({{i,j}, If(i+j-1>n,0,i+j-1) }, n,n );
HankelMatrix(m,n):=GenMatrix({{i,j}, If(i+j-1>n,0,i+j-1)}, m,n );

%/mathpiper




%mathpiper_docs,name="HankelMatrix",categories="User Functions;Matrices (Special)"
*CMD HankelMatrix --- todo
*CALL
	HankelMatrix(matrix)

*PARMS
{n} -- todo
{m} -- todo

*DESC
todo

*E.G.
todo
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Dot.mpw0000644000175000017500000000430411523200452026000 0ustar  giovannigiovanni%mathpiper,def="Dot"

//////
// dot product for vectors and matrices (dr)
//////

LocalSymbols(Dot0,Dot1)
[
// vector . vector
Dot(t1_IsVector,t2_IsVector)_(Length(t1)=Length(t2)) <--
   Dot0(t1,t2,Length(t1));

// matrix . vector
Dot(t1_IsMatrix,t2_IsVector)_(Length(t1[1])=Length(t2)) <--
[
   Local(i,n,m,result);
   n:=Length(t1);
   m:=Length(t2);
   result:=List();
   For(i:=1,i<=n,i++)
	DestructiveInsert(result,1,Dot0(t1[i],t2,m));
   DestructiveReverse(result);
];

// vector . matrix
Dot(t1_IsVector,t2_IsMatrix)_(Length(t1)=Length(t2)
                               And Length(t2[1])>0) <--
   Dot1(t1,t2,Length(t1),Length(t2[1]));

// matrix . matrix
Dot(t1_IsMatrix,t2_IsMatrix)_(Length(t1[1])=Length(t2)
                                  And Length(t2[1])>0) <--
[
   Local(i,n,k,l,result);
   n:=Length(t1);
   k:=Length(t2);
   l:=Length(t2[1]);
   result:=List();
   For(i:=1,i<=n,i++)
      DestructiveInsert(result,1,Dot1(t1[i],t2,k,l));
   DestructiveReverse(result);
];

// vector . vector
Dot0(_t1,_t2,_n) <--
[
   Local(i,result);
   result:=0;
   For(i:=1,i<=n,i++)
      result:=result+t1[i]*t2[i];
   result;
];

// vector . matrix
// m vector length
// n number of matrix cols
Dot1(_t1,_t2,_m,_n) <--
[
   Local(i,j,result);
   result:=ZeroVector(n);
   For(i:=1,i<=n,i++)
      For(j:=1,j<=m,j++)
         result[i]:=result[i]+t1[j]*t2[j][i];
   result;
];

]; // LocalSymbols(Dot0,Dot1)

%/mathpiper



%mathpiper_docs,name="Dot",categories="User Functions;Linear Algebra"
*CMD Dot --- get dot product of tensors
*STD
*CALL
	Dot(t1,t2)

*PARMS

{t1,t2} -- tensor lists (currently only vectors and matrices are supported)

*DESC

{Dot} returns the dot (aka inner) product of two tensors t1 and t2. The last
index of t1 and the first index of t2 are contracted. Currently {Dot} works
only for vectors and matrices. {Dot}-multiplication of two vectors, a matrix
with a vector (and vice versa) or two matrices yields either a scalar, a
vector or a matrix.

*E.G.

In> Dot({1,2},{3,4})
Result: 11;
In> Dot({{1,2},{3,4}},{5,6})
Result: {17,39};
In> Dot({5,6},{{1,2},{3,4}})
Result: {23,34};
In> Dot({{1,2},{3,4}},{{5,6},{7,8}})
Result: {{19,22},{43,50}};

*SEE Outer, Cross, IsScalar, IsVector, IsMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/SymbolicDeterminant.mpw0000644000175000017500000000131711502266107031235 0ustar  giovannigiovanni%mathpiper,def="SymbolicDeterminant"

20 # SymbolicDeterminant(_matrix) <--
[
  Local(perms,indices,result);
  Check((IsMatrix(matrix)), "Argument", "Determinant: Argument must be a matrix");
  indices:=Table(i,i,1,Length(matrix),1);
  perms:=PermutationsList(indices);
  result:=0;
  ForEach(item,perms)
     result:=result+Product(i,1,Length(matrix),matrix[i][item[i] ])*
                    LeviCivita(item);
  result;
];

%/mathpiper





%mathpiper_docs,name="SymbolicDeterminant",categories="User Functions;Linear Algebra"
*CMD SymbolicDeterminant --- todo
*CALL
	SymbolicDeterminant(matrix)

*PARMS
{matrix} -- a matrix

*DESC
todo

*E.G.
todo
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/ZeroMatrix.mpw0000644000175000017500000000152111523200452027354 0ustar  giovannigiovanni%mathpiper,def="ZeroMatrix"

5  # ZeroMatrix(n_IsNonNegativeInteger) <--  ZeroMatrix(n,n);

10 # ZeroMatrix(n_IsNonNegativeInteger,m_IsNonNegativeInteger) <--
[
  Local(i,result);
  result:={};
  For(i:=1,i<=n,i++)
    DestructiveInsert(result,i,ZeroVector(m));
  result;
];

%/mathpiper



%mathpiper_docs,name="ZeroMatrix",categories="User Functions;Linear Algebra"
*CMD ZeroMatrix --- make a zero matrix
*STD
*CALL
	ZeroMatrix(n)
	ZeroMatrix(n, m)

*PARMS

{n} -- number of rows

{m} -- number of columns

*DESC

This command returns a matrix with {n} rows and {m} columns,
completely filled with zeroes. If only given one parameter,
it returns the square {n} by {n} zero matrix.

*E.G.

In> ZeroMatrix(3,4)
Result: {{0,0,0,0},{0,0,0,0},{0,0,0,0}};
In> ZeroMatrix(3)
Result: {{0,0,0},{0,0,0},{0,0,0}};


*SEE ZeroVector, Identity
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Diagonal.mpw0000644000175000017500000000125411523200452026771 0ustar  giovannigiovanni%mathpiper,def="Diagonal"

//
// Diagonal: return a vector with the diagonal elements of the matrix
//
Function("Diagonal",{A})
[
	Local(result,i,n);
	n:=Length(A);
	result:=ZeroVector(n);
	For(i:=1,i<=n,i++)
	[
		result[i] := A[i][i];
	];
	result;
];

%/mathpiper



%mathpiper_docs,name="Diagonal",categories="User Functions;Linear Algebra"
*CMD Diagonal --- extract the diagonal from a matrix
*STD
*CALL
	Diagonal(A)

*PARMS

{A} -- matrix

*DESC

This command returns a vector of the diagonal components
of the matrix {A}.


*E.G.

In> Diagonal(5*Identity(4))
Result: {5,5,5,5};
In> Diagonal(HilbertMatrix(3))
Result: {1,1/3,1/5};

*SEE DiagonalMatrix, IsDiagonal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/MatrixSolve.mpw0000644000175000017500000000771011523200452027533 0ustar  giovannigiovanni%mathpiper,def="MatrixSolve"

//Retract("MatrixSolve",*);

10 # MatrixSolve(matrix_IsDiagonal,b_IsVector) <--
[
    If(InVerboseMode(),Tell("   MatrixSolve_diag",{matrix,b}));
	Local(rowsm,rowsb,x);
    rowsm:=Length(matrix);
	rowsb:=Length(b);
	Check(rowsm=rowsb, "Argument", "MatrixSolve: Matrix and vector must have same number of rows");
	x:=ZeroVector(rowsb);
	ForEach(i,1 .. rowsb)
		x[i]:=b[i]/matrix[i][i];
	x;
];

// Backward Substitution
15 # MatrixSolve(matrix_IsUpperTriangular,b_IsVector) <--
[
    If(InVerboseMode(),Tell("   MatrixSolve_ut",{matrix,b}));
    Local(rowsm,rowsb,x,s);
    rowsm:=Length(matrix);
    rowsb:=Length(b);
    Check(rowsm=rowsb, "Argument", "MatrixSolve: Matrix and vector must have same number of rows");
    x:=ZeroVector(rowsb);

	x[rowsb]:=b[rowsb]/matrix[rowsb][rowsb];
	If(InVerboseMode(),Echo({"set x[",rowsb,"] = ",b[rowsb]/matrix[rowsb][rowsb]}));

	ForEach(i,(rowsb-1) .. 1 )[
		s:=b[i];
		ForEach(j,i+1 .. rowsb )[
			s:= s - matrix[i][j]*x[j];
		];
		x[i]:= s/matrix[i][i];
		If(InVerboseMode(),Echo({"set x[",i,"] = ",s/matrix[i][i]}));
	];
        x;
];

// Forward Substitution
15 # MatrixSolve(matrix_IsLowerTriangular,b_IsVector) <--
[
    If(InVerboseMode(),Tell("   MatrixSolve_lt",{matrix,b}));
	Local(rowsm,rowsb,x,s);
	rowsm:=Length(matrix);
	rowsb:=Length(b);
	Check(rowsm=rowsb, "Argument", "MatrixSolve: Matrix and vector must have same number of rows");
	x:=ZeroVector(rowsb);

	x[1]:=b[1]/matrix[1][1];
	If(InVerboseMode(),Echo({"set x[1] = ",b[1]/matrix[1][1]}));

	ForEach(i,2 .. rowsb )[
		s:=b[i];
		ForEach(j,1 .. (i-1) )[
			s:= s - matrix[i][j]*x[j];
		];
		x[i]:= s/matrix[i][i];
		If(InVerboseMode(),Echo({"set x[",i,"] = ",s/matrix[i][i]}));
	];
	x;
];
// Gaussian Elimination and Back Substitution
// pivoting not implemented yet
20 # MatrixSolve(matrix_IsMatrix,b_IsVector) <--
[
    If(InVerboseMode(),Tell("   MatrixSolve",{matrix,b}));
	Local(aug,rowsm,rowsb,x,s);
    rowsm:=Length(matrix);
    rowsb:=Length(b);
    Check(rowsm=rowsb, "Argument", "MatrixSolve: Matrix and vector must have same number of rows");
    aug:=ZeroMatrix(rowsb,rowsb+1);
	x:=ZeroVector(rowsb);

	// create augmented matrix
	ForEach(i, 1 .. rowsb )
		ForEach(j, 1 .. rowsb )
			aug[i][j] := matrix[i][j];
	ForEach(i, 1 .. rowsb )
		aug[i][rowsb+1] := b[i];

	// gaussian elimination
	ForEach(i, 1 .. (rowsb-1) )[
		// If our pivot element is 0 we need to switch
		// this row with a row that has a nonzero element
		If(aug[i][i] = 0, [
			Local(p,tmp);
			p:=i+1;
			While( aug[p][p] = 0 )[ p++; ];
			If(InVerboseMode(), Echo({"switching row ",i,"with ",p}) );
			tmp:=aug[i];
			aug[i]:=aug[p];
			aug[p]:=tmp;
		]);


		ForEach(k, (i+1) .. rowsb )[
			s:=aug[k][i];
			ForEach(j, i .. (rowsb+1) )[
				aug[k][j] := aug[k][j] - (s/aug[i][i])*aug[i][j];
				//Echo({"aug[",k,"][",j,"] =", aug[k][j]," - ",
				//	aug[k][i],"/",aug[i][i],"*",aug[i][j]," k i =", k,i  });
			];
		];
	];
	//PrettyForm(aug);
	x[rowsb]:=aug[rowsb][rowsb+1]/aug[rowsb][rowsb];
	If(InVerboseMode(),Echo({"set x[",rowsb,"] = ",x[rowsb] }));

	ForEach(i,(rowsb-1) .. 1 )[
		s:=aug[i][rowsb+1];
		ForEach(j,i+1 .. rowsb)[
			s := s - aug[i][j]*x[j];
		];
		x[i]:=Simplify(s/aug[i][i]);
		If(InVerboseMode(),Echo({"set x[",i,"] = ",x[i] }));
	];
	x;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="MatrixSolve",categories="User Functions;Solvers (Symbolic);Linear Algebra"
*CMD MatrixSolve --- solve a system of equations
*STD
*CALL
	MatrixSolve(A,b)

*PARMS

{A} -- coefficient matrix

{b} -- row vector

*DESC

{MatrixSolve} solves the matrix equations {A*x = b} using Gaussian Elimination
with Backward substitution. If your matrix is triangular or diagonal, it will
be recognized as such and a faster algorithm will be used.

*E.G.

In> A:={{2,4,-2,-2},{1,2,4,-3},{-3,-3,8,-2},{-1,1,6,-3}};
Result: {{2,4,-2,-2},{1,2,4,-3},{-3,-3,8,-2},{-1,1,6,-3}};
In> b:={-4,5,7,7};
Result: {-4,5,7,7};
In> MatrixSolve(A,b);
Result: {1,2,3,4};
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/LeviCivita.mpw0000644000175000017500000000244511523200452027315 0ustar  giovannigiovanni%mathpiper,def="LeviCivita"

/* Levi-civita symbol */
Function("LeviCivita",{indices})
[
  Local(i,j,length,left,right,factor);
  length:=Length(indices);
  factor:=1;

  For (j:=length,j>1,j--)
  [
    For(i:=1,i LeviCivita({1,2,3})
Result: 1;
In> LeviCivita({2,1,3})
Result: -1;
In> LeviCivita({2,2,3})
Result: 0;

*SEE PermutationsList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/BaseVector.mpw0000644000175000017500000000120211523200452027301 0ustar  giovannigiovanni%mathpiper,def="BaseVector"

Function("BaseVector",{row,n})
[
    Local(i,result);
    result:=ZeroVector(n);
    result[row] := 1;
    result;
];

%/mathpiper



%mathpiper_docs,name="BaseVector",categories="User Functions;Linear Algebra"
*CMD BaseVector --- base vector
*STD
*CALL
	BaseVector(k, n)

*PARMS

{k} -- index of the base vector to construct

{n} -- dimension of the vector

*DESC

This command returns the "k"-th base vector of dimension "n". This
is a vector of length "n" with all zeros except for the "k"-th
entry, which contains a 1.

*E.G.

In> BaseVector(2,4)
Result: {0,1,0,0};

*SEE ZeroVector, Identity
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Identity.mpw0000644000175000017500000000121511523200452027041 0ustar  giovannigiovanni%mathpiper,def="Identity"

Identity(n_IsNonNegativeInteger) <--
[
    Local(i,result);
    result:={};
    For(i:=1,i<=n,i++)
    [
      DestructiveAppend(result,BaseVector(i,n));
    ];
    result;
];

%/mathpiper



%mathpiper_docs,name="Identity",categories="User Functions;Linear Algebra"
*CMD Identity --- make identity matrix
*STD
*CALL
	Identity(n)

*PARMS

{n} -- size of the matrix

*DESC

This commands returns the identity matrix of size "n" by "n". This
matrix has ones on the diagonal while the other entries are zero.

*E.G.

In> Identity(3)
Result: {{1,0,0},{0,1,0},{0,0,1}};

*SEE BaseVector, ZeroMatrix, DiagonalMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/GenMatrix.mpw0000644000175000017500000000131711523146134027157 0ustar  giovannigiovanni%mathpiper,def="GenMatrix"

Function("GenMatrix",{func,m,n})
[
  Local(i,j,result);
  result:=ZeroMatrix(m,n);

  For(i:=1,i<=m,i++)
    For(j:=1,j<=n,j++)
          result[i][j]:=ApplyFast(func,{i,j});

  result;
];
HoldArgument("GenMatrix",func);
UnFence("GenMatrix",3);

%/mathpiper





%mathpiper_docs,name="GenMatrix",categories="User Functions;Linear Algebra"
*CMD GenMatrix --- generate a matrix with a function
*CALL
	GenMatrix(function,m,n)

*PARMS
{function} -- a pure function
{m} -- row index
{n} -- column index

*DESC
Generate a matrix with a pure function.

*E.G.
In> GenMatrix(Lambda({m,n},m*n),3,3)
Result: {{1,2,3},{2,4,6},{3,6,9}}
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/InProduct.mpw0000644000175000017500000000141411523200452027160 0ustar  giovannigiovanni%mathpiper,def="InProduct"

Function("InProduct",{aLeft,aRight})
[
  Local(length);
  length:=Length(aLeft);
  Check(length = Length(aRight), "Argument", "InProduct: error, vectors not of the same dimension");

  Local(result);
  result:=0;
  Local(i);
  For(i:=1,i<=length,i++)
  [
    result := result + aLeft[i] * aRight[i];
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="InProduct",categories="User Functions;Linear Algebra"
*CMD InProduct --- inner product of vectors (deprecated)
*STD
*CALL
	InProduct(a,b)

*PARMS

{a}, {b} -- vectors of equal length

*DESC

The inner product of the two vectors "a" and "b" is returned. The
vectors need to have the same size.

*E.G.

In> Dot({a,b,c}, {d,e,f});
Result: a*d+b*e+c*f;

*SEE Outer, Dot, CrossProduct
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/CrossProduct.mpw0000644000175000017500000000220011523200452027675 0ustar  giovannigiovanni%mathpiper,def="CrossProduct"

Function("CrossProduct",{aLeft,aRight})
[
  Local(length);
  length:=Length(aLeft);
  Check(length = 3, "Argument", "OutProduct: error, vectors not of dimension 3");
  Check(length = Length(aRight), "Argument", "OutProduct: error, vectors not of the same dimension");

  Local(perms);
  perms := PermutationsList({1,2,3});

  Local(result);
  result:=ZeroVector(3);

  Local(term);
  ForEach(term,perms)
  [
    result[ term[1] ] := result[ term[1] ] +
      LeviCivita(term) * aLeft[ term[2] ] * aRight[ term[3] ] ;
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="CrossProduct",categories="User Functions;Linear Algebra"
*CMD CrossProduct --- outer product of vectors
*STD
*CALL
	CrossProduct(a,b)
	a X b
Precedence:
*EVAL PrecedenceGet("X")

*PARMS

{a}, {b} -- three-dimensional vectors

*DESC

The cross product of the vectors "a"
and "b" is returned. The result is perpendicular to both "a" and
"b" and its length is the product of the lengths of the vectors.
Both "a" and "b" have to be three-dimensional.

*E.G.

In> {a,b,c} X {d,e,f};
Result: {b*f-c*e,c*d-a*f,a*e-b*d};

*SEE InProduct, X
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Sparsity.mpw0000644000175000017500000000220011523200452027061 0ustar  giovannigiovanni%mathpiper,def="Sparsity"

Function("Sparsity",{matrix})
[
	Local(rows,cols,nonzero);
	nonzero:=0;
	rows:=Length(matrix);
	cols:=Length(matrix[1]);
	ForEach(i, 1 .. rows )
		ForEach(j, 1 .. cols )
			If(matrix[i][j] != 0, nonzero:=nonzero+1 );

	N(1 - nonzero/(rows*cols));
];

%/mathpiper



%mathpiper_docs,name="Sparsity",categories="User Functions;Linear Algebra"
*CMD Sparsity --- get the sparsity of a matrix
*STD
*CALL
	Sparsity(matrix)
*PARMS

{matrix} -- a matrix

*DESC

The function {Sparsity} returns a number between {0} and {1} which 
represents the percentage of zero entries in the matrix. Although
there is no definite critical value, a sparsity of {0.75}  or more
is almost universally considered a "sparse" matrix. These type of
matrices can be handled in a different manner than "full" matrices
which speedup many calculations by orders of magnitude.

*E.G.

In> Sparsity(Identity(2))
Result: 0.5;
In> Sparsity(Identity(10))
Result: 0.9;
In> Sparsity(HankelMatrix(10))
Result: 0.45;
In> Sparsity(HankelMatrix(100))
Result: 0.495;
In> Sparsity(HilbertMatrix(10))
Result: 0;
In> Sparsity(ZeroMatrix(10,10))
Result: 1;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/MatrixPower.mpw0000644000175000017500000000223511523200452027534 0ustar  giovannigiovanni%mathpiper,def="MatrixPower"

//////
// power of a matrix (dr)
//////

MatrixPower(x_IsSquareMatrix, n_IsNonNegativeInteger) <--
[
   Local(result);
   result:=Identity(Length(x));
   While(n != 0)
   [
      If(IsOdd(n),
         result:=Dot(result,x));
      x:=Dot(x,x);
      n:=n>>1;
   ];
   result;
];

MatrixPower(x_IsSquareMatrix, n_IsNegativeInteger) <--
   MatrixPower(Inverse(x),-n);

%/mathpiper



%mathpiper_docs,name="MatrixPower",categories="User Functions;Linear Algebra"
*CMD MatrixPower --- get nth power of a square matrix
*STD
*CALL
	MatrixPower(mat,n)

*PARMS

{mat} -- a square matrix

{n} -- an integer

*DESC

{MatrixPower(mat,n)} returns the {n}th power of a square matrix {mat}. For
positive {n} it evaluates dot products of {mat} with itself. For negative
{n} the nth power of the inverse of {mat} is returned. For {n}=0 the identity
matrix is returned.

*E.G.
In> A:={{1,2},{3,4}}
Result: {{1,2},{3,4}};
In> MatrixPower(A,0)
Result: {{1,0},{0,1}};
In> MatrixPower(A,1)
Result: {{1,2},{3,4}};
In> MatrixPower(A,3)
Result: {{37,54},{81,118}};
In> MatrixPower(A,-3)
Result: {{-59/4,27/4},{81/8,-37/8}};

*SEE IsSquareMatrix, Inverse, Dot
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/WilkinsonMatrix.mpw0000644000175000017500000000070111371733712030424 0ustar  giovannigiovanni%mathpiper,def="WilkinsonMatrix"

// Used to test numerical eigenvalue algorithms, because it
// has eigenvalues extremely close to each other.
// WilkinsonMatrix(21) has 2 eigenvalues near 10.7 that agree
// to 14 decimal places
// Leto: I am not going to document this until we actually have
// numerical eigenvalue algorithms
WilkinsonMatrix(N):=GenMatrix({{i,j},
		If( Abs(i-j)=1,1,
		[ If(i=j,Abs( (N-1)/2 - i+1 ),0 ); ] )}, N,N );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Inverse.mpw0000644000175000017500000000234211523200452026665 0ustar  giovannigiovanni%mathpiper,def="Inverse"

Function("Inverse",{matrix})
[
  Local(perms,indices,inv,det,n);
  n:=Length(matrix);
  indices:=Table(i,i,1,n,1);
  perms:=PermutationsList(indices);
  inv:=ZeroMatrix(n,n);
  det:=0;
  ForEach(item,perms)
  [
    Local(i,lc);
    lc := LeviCivita(item);
    det:=det+Product(i,1,n,matrix[i][item[i] ])* lc;
    For(i:=1,i<=n,i++)
        [
         inv[item[i] ][i] := inv[item[i] ][i]+
           Product(j,1,n,
             If(j=i,1,matrix[j][item[j] ]))*lc;
        ];
  ];
  Check(det != 0, "Math", "Zero determinant");
  (1/det)*inv;
];

%/mathpiper



%mathpiper_docs,name="Inverse",categories="User Functions;Linear Algebra"
*CMD Inverse --- get inverse of a matrix
*STD
*CALL
	Inverse(M)

*PARMS

{M} -- a matrix

*DESC

Inverse returns the inverse of matrix $M$. The determinant of $M$ should
be non-zero. Because this function uses {Determinant} for calculating
the inverse of a matrix, you can supply matrices with non-numeric (symbolic)
matrix elements.

*E.G.

In> A:=DiagonalMatrix({a,b,c})
Result: {{a,0,0},{0,b,0},{0,0,c}};
In> B:=Inverse(A)
Result: {{(b*c)/(a*b*c),0,0},{0,(a*c)/(a*b*c),0},
	{0,0,(a*b)/(a*b*c)}};
In> Simplify(B)
Result: {{1/a,0,0},{0,1/b,0},{0,0,1/c}};

*SEE Determinant
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Minor.mpw0000644000175000017500000000157311523200452026343 0ustar  giovannigiovanni%mathpiper,def="Minor"

Minor(matrix,i,j) := CoFactor(matrix,i,j)*(-1)^(i+j);

%/mathpiper



%mathpiper_docs,name="Minor",categories="User Functions;Linear Algebra"
*CMD Minor --- get principal minor of a matrix
*STD
*CALL
	Minor(M,i,j)

*PARMS

{M} -- a matrix

{i}, {j} - positive integers

*DESC

Minor returns the minor of a matrix around
the element ($i$, $j$). The minor is the determinant of the matrix obtained from $M$ by
deleting the $i$-th row and the $j$-th column.

*E.G.

In> A := {{1,2,3}, {4,5,6}, {7,8,9}};
Result: {{1,2,3},{4,5,6},{7,8,9}};
In> PrettyForm(A);
	
	/                    \
	| ( 1 ) ( 2 ) ( 3 )  |
	|                    |
	| ( 4 ) ( 5 ) ( 6 )  |
	|                    |
	| ( 7 ) ( 8 ) ( 9 )  |
	\                    /
Result: True;
In> Minor(A,1,2);
Result: -6;
In> Determinant({{2,3}, {8,9}});
Result: -6;

*SEE CoFactor, Determinant, Inverse
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Norm.mpw0000644000175000017500000000063011523200452026163 0ustar  giovannigiovanni%mathpiper,def="Norm"

10 # Norm(_v) <-- PNorm(v,2);

%/mathpiper



%mathpiper_docs,name="Norm",categories="User Functions;Linear Algebra"
*CMD Norm --- the norm (magnitude or length) of a vector
*STD
*CALL
	Norm(v)

*PARMS

{v} -- a vector

*DESC

Return the norm (i.e., the magnitude, or length) of vector {v}

*E.G.

In> Norm({3,4})
    Result: 5

*SEE InProduct, CrossProduct, Normalize
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/OrthogonalBasis.mpw0000644000175000017500000000240411523200452030347 0ustar  giovannigiovanni%mathpiper,def="OrthogonalBasis"

// This is the standard textbook definition of the Gram-Schmidt
// Orthogonalization process, from:
// Friedberg,Insel,Spence "Linear Algebra"  (1997)
// TODO: This function does not check if the input vectors are LI, it
// only checks for zero vectors
Function("OrthogonalBasis",{W})[
	Local(V,j,k);

	V:=ZeroMatrix(Length(W),Length(W[1]) );

	V[1]:=W[1];
	For(k:=2,k<=Length(W),k++)[
		Check(Not IsZero(Norm(W[k])), "Argument", "OrthogonalBasis: Input vectors must be linearly independent");
		V[k]:=W[k]-Sum(j,1,k-1,InProduct(W[k],V[j])*V[j]/Norm(V[j])^2);
	];
	V;
];

%/mathpiper



%mathpiper_docs,name="OrthogonalBasis",categories="User Functions;Linear Algebra"
*CMD OrthogonalBasis --- create an orthogonal basis 
*STD
*CALL
	OrthogonalBasis(W)

*PARMS

{W} - A linearly independent set of row vectors (aka a matrix)

*DESC

Given a linearly independent set {W} (constructed of rows vectors),
this command returns an orthogonal basis {V} for {W}, which means 
that span(V) = span(W) and {InProduct(V[i],V[j]) = 0} when {i != j}.
This function uses the Gram-Schmidt orthogonalization process.

*E.G.

In> OrthogonalBasis({{1,1,0},{2,0,1},{2,2,1}}) 
Result: {{1,1,0},{1,-1,1},{-1/3,1/3,2/3}};


*SEE OrthonormalBasis, InProduct
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/MatrixRowAndColumnOps.mpw0000644000175000017500000000525211517224250031501 0ustar  giovannigiovanni%mathpiper,def="MatrixRowAndColumnOps"

//Retract("MatrixRowReplace",*);
//Retract("MatrixRowSwap",*);
//Retract("MatrixRowStack",*);
//Retract("MatrixColumnReplace",*);
//Retract("MatrixColumnSwap",*);
//Retract("MatrixColumnAugment",*);

MatrixRowReplace( M_IsMatrix, iRow_IsPositiveInteger, v_IsVector )_(Length(v)=Length(M[1])) <--
[
    If( Not IsBound(iDebug), iDebug := False );
    If( iDebug, Tell(MatrixRowReplace,{M,iRow,v}) );
    Local(mRows,nCols);
    {mRows,nCols} := Dimensions(M);
    If( iRow <= mRows, DestructiveReplace(M,iRow,v) );
    M;
];


MatrixRowSwap( M_IsMatrix, iRow1_IsPositiveInteger, iRow2_IsPositiveInteger )_
                          (And(iRow1<=Dimensions(M)[1],iRow2<=Dimensions(M)[1])) <--
[
    If( Not IsBound(iDebug), iDebug := False );
    If( iDebug, Tell(MatrixRowSwap,{M,iRow1,iRow2}) );
    Local(row1,row2);
    If( iRow1 != iRow2, 
       [ 
         row1 := MatrixRow(M,iRow1);         row2 := MatrixRow(M,iRow2);
         DestructiveReplace(M,iRow1,row2);   DestructiveReplace(M,iRow2,row1);
       ]
    );
    M;
];


MatrixRowStack( M_IsMatrix, v_IsVector )_(Length(v)=Dimensions(M)[1]) <--
[
    If( Not IsBound(iDebug), iDebug := False );
    If( iDebug, Tell(MatrixRowStack,{M,v}) );
    Local(mRows,nCols,newMat,ir);
    {mRows,nCols} := Dimensions(M);
    newMat        := ZeroMatrix(mRows+1,nCols);
    For(ir:=1,ir WronskianMatrix({Sin(x),Cos(x),x^4},x);
Result: {{Sin(x),Cos(x),x^4},{Cos(x),-Sin(x),4*x^3},
	  {-Sin(x),-Cos(x),12*x^2}};
In> PrettyForm(%)

	/                                                 \
	| ( Sin( x ) )      ( Cos( x ) )      /  4 \      |
	|                                     \ x  /      |
	|                                                 |
	| ( Cos( x ) )      ( -( Sin( x ) ) ) /      3 \  |
	|                                     \ 4 * x  /  |
	|                                                 |
	| ( -( Sin( x ) ) ) ( -( Cos( x ) ) ) /       2 \ |
	|                                     \ 12 * x  / |
	\                                                 /
The last element is a linear combination of the first two, so the determinant is zero:
In> A:=Determinant( WronskianMatrix( {x^4,x^3,2*x^4 
	  + 3*x^3},x ) )
Result: x^4*3*x^2*(24*x^2+18*x)-x^4*(8*x^3+9*x^2)*6*x
	  +(2*x^4+3*x^3)*4*x^3*6*x-4*x^6*(24*x^2+18*x)+x^3
	  *(8*x^3+9*x^2)*12*x^2-(2*x^4+3*x^3)*3*x^2*12*x^2;
In> Simplify(A)
Result: 0;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/ToeplitzMatrix.mpw0000644000175000017500000000204111523200452030245 0ustar  giovannigiovanni%mathpiper,def="ToeplitzMatrix"

// The arguments of the following functions should be checked
ToeplitzMatrix(N):=GenMatrix({{i,j},N[Abs(i-j)+1]}, Length(N), Length(N) );

%/mathpiper



%mathpiper_docs,name="ToeplitzMatrix",categories="User Functions;Matrices (Special)"
*CMD ToeplitzMatrix --- create a Toeplitz matrix
*STD
*CALL
	ToeplitzMatrix(N)
*PARMS

{N} -- an $n$-dimensional row vector

*DESC

The function {ToeplitzMatrix} calculates the Toeplitz matrix given
an $n$-dimensional row vector. This matrix has the same entries in
all diagonal columns, from upper left to lower right.

*E.G.

In> PrettyForm(ToeplitzMatrix({1,2,3,4,5}))

	/                                \
	| ( 1 ) ( 2 ) ( 3 ) ( 4 ) ( 5 )  |
	|                                |
	| ( 2 ) ( 1 ) ( 2 ) ( 3 ) ( 4 )  |
	|                                |
	| ( 3 ) ( 2 ) ( 1 ) ( 2 ) ( 3 )  |
	|                                |
	| ( 4 ) ( 3 ) ( 2 ) ( 1 ) ( 2 )  |
	|                                |
	| ( 5 ) ( 4 ) ( 3 ) ( 2 ) ( 1 )  |
	\                                /
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/MatrixRow.mpw0000644000175000017500000000135011502266107027212 0ustar  giovannigiovanni%mathpiper,def="MatrixRow"

Function("MatrixRow",{matrix,row})
[
  Check(row > 0, "Argument", "MatrixRow: row index out of range");
  Check(row <= Length(matrix), "Argument", "MatrixRow: row index out of range");

  Local(result);
  result:=matrix[row];

  result;
];

%/mathpiper




%mathpiper_docs,name="MatrixRow",categories="User Functions;Linear Algebra"
*CMD MatrixRow --- obtain the row of a matrix
*STD
*CALL
	MatrixRow(matrix,row)

*PARMS
{matrix} -- a matrix
{row} -- the index of a matrix row

*DESC
Returns the row of a matrix which is specified by {row}.

*E.G.
In> A := {{1,2}, {3,4}};
Result: {{1,2},{3,4}}

In> MatrixRow(A,1)
Result: {1,2}

*SEE MatrixColumn
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/OrthonormalBasis.mpw0000644000175000017500000000170011523200452030535 0ustar  giovannigiovanni%mathpiper,def="OrthonormalBasis"

// Like orthogonalization, only normalize all vectors
Function("OrthonormalBasis",{W})[
	Local(i);
	W:=OrthogonalBasis(W);
	For(i:=1,i<=Length(W),i++)[
		W[i]:=W[i]/Norm(W[i]);
	];
	W;
];

%/mathpiper



%mathpiper_docs,name="OrthonormalBasis",categories="User Functions;Linear Algebra"
*CMD OrthonormalBasis --- create an orthonormal basis 
*STD
*CALL
	OrthonormalBasis(W)

*PARMS

{W} - A linearly independent set of row vectors (aka a matrix)

*DESC

Given a linearly independent set {W} (constructed of rows vectors),
this command returns an orthonormal basis {V} for {W}. This is done
by first using {OrthogonalBasis(W)}, then dividing each vector by its
magnitude, so as the give them unit length. 

*E.G.

In> OrthonormalBasis({{1,1,0},{2,0,1},{2,2,1}})
Result: {{Sqrt(1/2),Sqrt(1/2),0},{Sqrt(1/3),-Sqrt(1/3),Sqrt(1/3)},
		{-Sqrt(1/6),Sqrt(1/6),Sqrt(2/3)}};

*SEE OrthogonalBasis, InProduct, Normalize
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/HessianMatrix.mpw0000644000175000017500000000233511523200452030033 0ustar  giovannigiovanni%mathpiper,def="HessianMatrix"

// The arguments of the following functions should be checked
// this takes 1 func in N vars
HessianMatrix(f,v):=GenMatrix({{i,j}, Deriv(v[i]) Deriv(v[j]) f},Length(v),Length(v));

%/mathpiper



%mathpiper_docs,name="HessianMatrix",categories="User Functions;Matrices (Special)"
*CMD HessianMatrix --- create the Hessian matrix
*STD
*CALL
	HessianMatrix(function,var)
*PARMS

{function} -- a function in $n$ variables

{var} -- an $n$-dimensional vector of variables

*DESC

The function {HessianMatrix} calculates the Hessian matrix
of a vector.

If $f(x)$ is a function of an $n$-dimensional vector $x$, then the ($i$,$j$)-th element of the Hessian matrix of the function $f(x)$ is defined as 
$ Deriv(x[i]) Deriv(x[j]) f(x) $. If the third
order mixed partials are continuous, then the Hessian
matrix is symmetric (a standard theorem of calculus).

The Hessian matrix is used in the second derivative test 
to discern if a critical point is a local maximum, a local
minimum or a saddle point.


*E.G.

In> HessianMatrix(3*x^2-2*x*y+y^2-8*y, {x,y} )
Result: {{6,-2},{-2,2}};
In> PrettyForm(%)

	/                \
	| ( 6 )  ( -2 )  |
	|                |
	| ( -2 ) ( 2 )   |
	\                /
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/JacobianMatrix.mpw0000644000175000017500000000211611523200452030144 0ustar  giovannigiovanni%mathpiper,def="JacobianMatrix"

// The arguments of the following functions should be checked
// this takes N funcs in N vars
JacobianMatrix(f,v):=GenMatrix({{i,j},Deriv(v[j])f[i]},Length(f),Length(f));

%/mathpiper



%mathpiper_docs,name="JacobianMatrix",categories="User Functions;Matrices (Special)"
*CMD JacobianMatrix --- calculate the Jacobian matrix of $n$ functions in $n$ variables
*STD
*CALL
	JacobianMatrix(functions,variables)

*PARMS

{functions} -- an $n$-dimensional vector of functions

{variables} -- an $n$-dimensional vector of variables

*DESC

The function {JacobianMatrix} calculates the Jacobian matrix
of n functions in n variables.

The ($i$,$j$)-th element of the Jacobian matrix is defined as the derivative
of $i$-th function with respect to the $j$-th variable.

*E.G.

In> JacobianMatrix( {Sin(x),Cos(y)}, {x,y} ); 
Result: {{Cos(x),0},{0,-Sin(y)}};
In> PrettyForm(%)

	/                                 \
	| ( Cos( x ) ) ( 0 )              |
	|                                 |
	| ( 0 )        ( -( Sin( y ) ) )  |
	\                                 /
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Outer.mpw0000644000175000017500000000177511523200452026361 0ustar  giovannigiovanni%mathpiper,def="Outer"

// outer product of vectors
Outer(t1_IsVector, t2_IsVector) <--
[
   Local(i,j,n,m,result);
   n:=Length(t1);
   m:=Length(t2);
   result:=ZeroMatrix(n,m);
   For(i:=1,i<=n,i++)
      For(j:=1,j<=m,j++)
	 result[i][j]:=t1[i]*t2[j];
   result;
];

%/mathpiper



%mathpiper_docs,name="Outer",categories="User Functions;Linear Algebra"
*CMD Outer, o --- get outer tensor product
*STD
*CALL
	Outer(t1,t2)
	t1 o t2
Precedence:
*EVAL PrecedenceGet("o")

*PARMS

{t1,t2} -- tensor lists (currently only vectors are supported)

*DESC

{Outer} returns the outer product of two tensors t1 and t2. Currently
{Outer} work works only for vectors, i.e. tensors of rank 1. The outer
product of two vectors yields a matrix.

*E.G.

In> Outer({1,2},{3,4,5})
Result: {{3,4,5},{6,8,10}};
In> Outer({a,b},{c,d})
Result: {{a*c,a*d},{b*c,b*d}};

	Or, using the "o"-Operator:

In> {1,2} o {3,4,5}
Result: {{3,4,5},{6,8,10}};
In> {a,b} o {c,d}
Result: {{a*c,a*d},{b*c,b*d}};


*SEE InProduct, Dot, Cross
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Cholesky.mpw0000644000175000017500000000440611523200452027036 0ustar  giovannigiovanni%mathpiper,def="Cholesky"

// Cholesky Decomposition, adapted from:
//	Fundamentals Of Matrix Computation (2nd), David S. Watkins, pp38
// This algorithm performs O(n^3) flops where A is nxn
// Given the positive definite matrix A, a matrix R is returned such that
// A = Transpose(R) * R

10 # Cholesky(A_IsMatrix) <--
[
	Local(matrix,n,k,j);
	n:=Length(A);
	matrix:=ZeroMatrix(n);

	// copy entries of A into matrix
        ForEach(i,1 .. n)
                ForEach(j,1 .. n)
			matrix[i][j] := A[i][j];

	// in place algorithm for cholesky decomp
	ForEach(i,1 .. n)[
		For(k:=1,k<=(i-1),k++)
			matrix[i][i] := matrix[i][i] - matrix[k][i]^2;
		Check( matrix[i][i] > 0, "Math", "Cholesky: Matrix is not positive definite");
		matrix[i][i] := Sqrt(matrix[i][i]);
		//Echo({"matrix[",i,"][",i,"] = ", matrix[i][i] });
		For(j:=i+1,j<=n,j++)[
			For(k:=1,k<=(i-1),k++)
				matrix[i][j]:= matrix[i][j] - matrix[k][i]*matrix[k][j];
			matrix[i][j] := matrix[i][j]/matrix[i][i];
			//Echo({"matrix[",i,"][",j,"] = ", matrix[i][j] });
		];
	];
	// cholesky factorization is upper triangular
	ForEach(i,1 .. n)
		ForEach(j,1 .. n)
			If(i>j,matrix[i][j] := 0);
	matrix;
];

%/mathpiper



%mathpiper_docs,name="Cholesky",categories="User Functions;Linear Algebra"
*CMD Cholesky --- find the Cholesky Decomposition
*STD
*CALL
	Cholesky(A)

*PARMS

{A} -- a square positive definite matrix

*DESC

{Cholesky} returns a upper triangular matrix {R} such that {Transpose(R)*R = A}.
The matrix {A} must be positive definite, {Cholesky} will notify the user if the matrix
is not. Some families of positive definite matrices are all symmetric matrices, diagonal
matrices with positive elements and Hilbert matrices.

*E.G.

In> A:={{4,-2,4,2},{-2,10,-2,-7},{4,-2,8,4},{2,-7,4,7}}
Result: {{4,-2,4,2},{-2,10,-2,-7},{4,-2,8,4},{2,-7,4,7}};
In> R:=Cholesky(A);
Result: {{2,-1,2,1},{0,3,0,-2},{0,0,2,1},{0,0,0,1}};
In> Transpose(R)*R = A
Result: True;
In> Cholesky(4*Identity(5))
Result: {{2,0,0,0,0},{0,2,0,0,0},{0,0,2,0,0},{0,0,0,2,0},{0,0,0,0,2}};
In> Cholesky(HilbertMatrix(3))
Result: {{1,1/2,1/3},{0,Sqrt(1/12),Sqrt(1/12)},{0,0,Sqrt(1/180)}};
In> Cholesky(ToeplitzMatrix({1,2,3}))
	In function "Check" :
	CommandLine(1) : "Cholesky: Matrix is not positive definite"

*SEE IsSymmetric, IsDiagonal, Diagonal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/FrobeniusNorm.mpw0000644000175000017500000000070611322513743030053 0ustar  giovannigiovanni%mathpiper,def="FrobeniusNorm"

FrobeniusNorm(matrix_IsMatrix) <--
[
	Local(i,j,result);
	result:=0;
	For(i:=1,i<=Length(matrix),i++)
		For(j:=1,j<=Length(matrix[1]),j++)
			result:=result+Abs(matrix[i][j])^2;

	Sqrt(result);

];

%/mathpiper





%mathpiper_docs,name="FrobeniusNorm",categories="User Functions;Linear Algebra"
*CMD FrobeniusNorm --- todo
*CALL
	FrobeniusNorm(matrix)

*PARMS
{matrix} -- a matrix

*DESC
todo

*E.G.
todo
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/VandermondeMatrix.mpw0000644000175000017500000000213711523200452030703 0ustar  giovannigiovanni%mathpiper,def="VandermondeMatrix"

Function("VandermondeMatrix",{vector})[
	Local(len,i,j,item,matrix);
	len:=Length(vector);
	matrix:=ZeroMatrix(len,len);

	For(i:=1,i<=Length(matrix),i++)[
		For(j:=1,j<=Length(matrix[1]),j++)[
      			matrix[j][i]:=vector[i]^(j-1);
		];
	];

	matrix;
];

%/mathpiper



%mathpiper_docs,name="VandermondeMatrix",categories="User Functions;Matrices (Special)"
*CMD VandermondeMatrix --- create the Vandermonde matrix
*STD
*CALL
	VandermondeMatrix(vector)
*PARMS

{vector} -- an $n$-dimensional vector 

*DESC

The function {VandermondeMatrix} calculates the Vandermonde matrix
of a vector.

The ($i$,$j$)-th element of the Vandermonde matrix is defined as $i^(j-1)$.

*E.G.
In> VandermondeMatrix({1,2,3,4})
Result: {{1,1,1,1},{1,2,3,4},{1,4,9,16},{1,8,27,64}};
In>PrettyForm(%)

	/                            \
	| ( 1 ) ( 1 ) ( 1 )  ( 1 )   |
	|                            |
	| ( 1 ) ( 2 ) ( 3 )  ( 4 )   |
	|                            |
	| ( 1 ) ( 4 ) ( 9 )  ( 16 )  |
	|                            |
	| ( 1 ) ( 8 ) ( 27 ) ( 64 )  |
	\                            /
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/o_operator.mpw0000644000175000017500000000047711322513743027441 0ustar  giovannigiovanni%mathpiper,def="o"

_x o _y <-- Outer(x,y);

%/mathpiper



%mathpiper_docs,name="o",categories="Operators"
*CMD o --- get outer tensor product
*STD
*CALL
	t1 o t2

*PARMS

{t1,t2} -- tensor lists (currently only vectors are supported)

*DESC

See the {Outer} function for more information.

*SEE Outer
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/HilbertInverseMatrix.mpw0000644000175000017500000000214411523200452031364 0ustar  giovannigiovanni%mathpiper,def="HilbertInverseMatrix"

HilbertInverseMatrix(n):=GenMatrix({{i,j},
	(-1)^(i+j)*(i+j-1)*BinomialCoefficient(n+i-1,n-j)*BinomialCoefficient(n+j-1,n-i)*BinomialCoefficient(i+j-2,i-1)^2},n,n);

%/mathpiper



%mathpiper_docs,name="HilbertInverseMatrix",categories="User Functions;Matrices (Special)"
*CMD HilbertInverseMatrix --- create a Hilbert inverse matrix
*STD
*CALL
	HilbertInverseMatrix(n)
*PARMS

{n} -- positive integer

*DESC

The function {HilbertInverseMatrix} returns the {n} by {n} inverse of the
corresponding Hilbert matrix. All Hilbert inverse matrices have integer
entries that grow in magnitude rapidly.

*E.G.
In> PrettyForm(HilbertInverseMatrix(4))

	/                                         \
	| ( 16 )   ( -120 )  ( 240 )   ( -140 )   |
	|                                         |
	| ( -120 ) ( 1200 )  ( -2700 ) ( 1680 )   |
	|                                         |
	| ( 240 )  ( -2700 ) ( 6480 )  ( -4200 )  |
	|                                         |
	| ( -140 ) ( 1680 )  ( -4200 ) ( 2800 )   |
	\                                         /

*SEE HilbertMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/CartesianProduct.mpw0000644000175000017500000000335611521470044030536 0ustar  giovannigiovanni%mathpiper,def="CartesianProduct"

//Retract("CartesianProduct",*);

CartesianProduct(xList_IsList, yList_IsList) <--
[
    Local(cartesianProduct);
    
    cartesianProduct := {};
    
    ForEach(x, xList)
    [
        ForEach(y, yList)
        [
            cartesianProduct := DestructiveAppend(cartesianProduct, {x,y});
        
        ];
    ];

    cartesianProduct;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="CartesianProduct",categories="User Functions;Linear Algebra;Lists (Operations)",access="experimental"
*CMD CartesianProduct --- returns the Cartesian product of two lists
*CALL
	CartesianProduct(list1, list2)

*PARMS

{list1} -- a list

{list2} -- a list

*DESC

This function returns the Cartesian product of two lists.

*E.G.
In> CartesianProduct({a,b}, {c,d})
Result: {{a,c},{a,d},{b,c},{b,d}}

In> CartesianProduct({2,3,4,5,6,7,8,9,10,Jack,Queen,King,Ace}, {Spades, Hearts, Diamonds, Clubs})
Result: {{2,Spades},{2,Hearts},{2,Diamonds},{2,Clubs},
{3,Spades},{3,Hearts},{3,Diamonds},{3,Clubs},
{4,Spades},{4,Hearts},{4,Diamonds},{4,Clubs},
{5,Spades},{5,Hearts},{5,Diamonds},{5,Clubs},
{6,Spades},{6,Hearts},{6,Diamonds},{6,Clubs},
{7,Spades},{7,Hearts},{7,Diamonds},{7,Clubs},
{8,Spades},{8,Hearts},{8,Diamonds},{8,Clubs},
{9,Spades},{9,Hearts},{9,Diamonds},{9,Clubs},
{10,Spades},{10,Hearts},{10,Diamonds},{10,Clubs},
{Jack,Spades},{Jack,Hearts},{Jack,Diamonds},{Jack,Clubs},
{Queen,Spades},{Queen,Hearts},{Queen,Diamonds},{Queen,Clubs},
{King,Spades},{King,Hearts},{King,Diamonds},{King,Clubs},
{Ace,Spades},{Ace,Hearts},{Ace,Diamonds},{Ace,Clubs}}
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/CoFactor.mpw0000644000175000017500000000221411523200452026750 0ustar  giovannigiovanni%mathpiper,def="CoFactor"

Function("CoFactor",{matrix,ii,jj})
[
  Local(perms,indices,result);
  indices:=Table(i,i,1,Length(matrix),1);
  perms:=PermutationsList(indices);
  result:=0;
  ForEach(item,perms)
     If(item[ii] = jj,
       result:=result+
         Product(i,1,Length(matrix),
         If(ii=i,1,matrix[i][item[i] ])
                  )*LeviCivita(item));
  result;
];

%/mathpiper



%mathpiper_docs,name="CoFactor",categories="User Functions;Linear Algebra"
*CMD CoFactor --- cofactor of a matrix
*STD
*CALL
	CoFactor(M,i,j)

*PARMS

{M} -- a matrix

{i}, {j} - positive integers

*DESC

{CoFactor} returns the cofactor of a matrix around
the element ($i$, $j$). The cofactor is the minor times
$(-1)^(i+j)$.

*E.G.

In> A := {{1,2,3}, {4,5,6}, {7,8,9}};
Result: {{1,2,3},{4,5,6},{7,8,9}};
In> PrettyForm(A);
	
	/                    \
	| ( 1 ) ( 2 ) ( 3 )  |
	|                    |
	| ( 4 ) ( 5 ) ( 6 )  |
	|                    |
	| ( 7 ) ( 8 ) ( 9 )  |
	\                    /
Result: True;
In> CoFactor(A,1,2);
Result: 6;
In> Minor(A,1,2);
Result: -6;
In> Minor(A,1,2) * (-1)^(1+2);
Result: 6;

*SEE Minor, Determinant, Inverse
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/GaussianDeterminant.mpw0000644000175000017500000000207111322513743031225 0ustar  giovannigiovanni%mathpiper,def="GaussianDeterminant"

GaussianDeterminant(matrix):=
[
  Local(n,s,result);
  n:=Length(matrix);
	result:=1;

  [
    matrix:=FlatCopy(matrix);
    Local(i);
    For(i:=1,i<=n,i++)
    [
      matrix[i]:=FlatCopy(matrix[i]);
    ];
  ];

  // gaussian elimination
  ForEach(i, 1 .. (n-1) )
  [
    ForEach(k, (i+1) .. n )
    [
      s:=matrix[k][i];
      ForEach(j, i .. n )
      [
        matrix[k][j] := matrix[k][j] - (s/matrix[i][i])*matrix[i][j];
        //Echo({"matrix[",k,"][",j,"] =", aug[k][j]," - ",
        //      matrix[k][i],"/",matrix[i][i],"*",matrix[i][j]," k i =", k,i  });
      ];
    ];
  ];

//Echo("mat: ",matrix);
//Echo("diagmat: ",Diagonal(matrix));
	// now upper triangular
  ForEach(i, Diagonal(matrix) )
    result:=result*i;
  result;
];

%/mathpiper





%mathpiper_docs,name="GaussianDeterminant",categories="User Functions;Linear Algebra"
*CMD GaussianDeterminant --- todo
*CALL
	GaussianDeterminant(matrix)

*PARMS
{matrix} -- a matrix

*DESC
todo

*E.G.
todo
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/DiagonalMatrix.mpw0000644000175000017500000000134211523200452030154 0ustar  giovannigiovanni%mathpiper,def="DiagonalMatrix"

Function("DiagonalMatrix",{list})
[
  Local(result,i,n);
  n:=Length(list);
  result:=Identity(n);
  For(i:=1,i<=n,i++)
  [
    result[i][i] := list[i];
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="DiagonalMatrix",categories="User Functions;Linear Algebra"
*CMD DiagonalMatrix --- construct a diagonal matrix
*STD
*CALL
	DiagonalMatrix(d)

*PARMS

{d} -- list of values to put on the diagonal

*DESC

This command constructs a diagonal matrix, that is a square matrix
whose off-diagonal entries are all zero. The elements of the vector
"d" are put on the diagonal.

*E.G.

In> DiagonalMatrix(1 .. 4)
Result: {{1,0,0,0},{0,2,0,0},{0,0,3,0},{0,0,0,4}};

*SEE Identity, ZeroMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Dimensions.mpw0000644000175000017500000000325011523200452027361 0ustar  giovannigiovanni%mathpiper,def="Dimensions"

//Retract("Dimensions",*);

/* Code that returns the list of the dimensions of a tensor or matrix
   Code submitted by Dirk Reusch.
 */

LocalSymbols(x,i,n,m,aux,dim,result)
[
 1 # Dimensions(x_IsList) <--
    [
      Local(i,n,m,aux,dim,result);
      result:=List(Length(x));
      If(Length(x)>0 And Length(Select(x, IsList))=Length(x),
        [
          n:=Length(x);
	      dim:=MapSingle(Dimensions,x);
	      m:=Minimum(MapSingle(Length,dim));
	      For(i:=1,i<=m,i++)
	      [
	        aux:=Table(dim[j][i],j,1,n,1);
	        If(Minimum(aux)=Maximum(aux),
	           result:=DestructiveAppend(result,dim[1][i]),
	           i:=m+1
            );
          ];
        ]
      );
      result;
    ];

 2 # Dimensions(_x) <-- List();
];  // LocalSymbols

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Dimensions",categories="User Functions;Linear Algebra"
*CMD Dimensions --- dimensions (number of rows and columns etc) of input Matrix
*STD
*CALL
	Dimensions(Matrix)

*PARMS

{Matrix} -- a matrix


*DESC

This command returns an array of dimensions {nrows,ncols,...} corresponding to the input array.
The input array can be 1-dimensional (i.e., vector), 2-dimensional (i.e., matrix),
or higher dimensioned (tensor).  

If multidimensional, the array must not be "ragged", else this function will give 
an incorrect result.

*E.G.
In> Dimensions({1,2,3,4})
Result: {4}

In> Dimensions({{1,2,3,4},{5,6,7,8}})
Result: {2,4}

In> Dimensions({{{4,8,1,2},{1,7,-3,-14}},{{2,-3,2,3},{11,12,13,14}},{{21,22,23,24},{31,32,33,34}}})
Result: {3,2,4}

In> Dimensions({{1,2,3,4},{5,6,7,8,9}})
Result: {2}

%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/SylvesterMatrix.mpw0000644000175000017500000000331411523200452030437 0ustar  giovannigiovanni%mathpiper,def="SylvesterMatrix"

/* SylvesterMatrix */

Function("SylvesterMatrix",{poly1, poly2, var})
[
  Local(i,m,p,q,y,z,result);
  y:=Degree(poly1,var);
  z:=Degree(poly2,var);
  m:=y+z;
  p:={};
  q:={};
  result:=ZeroMatrix(m,m);

  For(i:=y,i>=0,i--)
    DestructiveAppend(p,Coef(poly1,var,i));
  For(i:=z,i>=0,i--)
    DestructiveAppend(q,Coef(poly2,var,i));

  For(i:=1,i<=z,i++)
  [
    Local(j,k);
        k:=1;
    For(j:=i,k<=Length(p),j++)
        [
          result[i][j]:=p[k];
          k++;
        ];
  ];

  For(i:=1,i<=y,i++)
  [
    Local(j,k);
        k:=1;
    For(j:=i,k<=Length(q),j++)
        [
          result[i+z][j]:=q[k];
          k++;
        ];
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="SylvesterMatrix",categories="User Functions;Matrices (Special)"
*CMD SylvesterMatrix --- calculate the Sylvester matrix of two polynomials
*STD
*CALL
	SylvesterMatrix(poly1,poly2,variable)

*PARMS

{poly1} -- polynomial

{poly2} -- polynomial

{variable} -- variable to express the matrix for

*DESC

The function {SylvesterMatrix} calculates the Sylvester matrix
for a pair of polynomials.

The Sylvester matrix is closely related to the resultant, which
is defined as the determinant of the Sylvester matrix. Two polynomials
share common roots only if the resultant is zero.

*E.G.

In> ex1:= x^2+2*x-a
Result: x^2+2*x-a;
In> ex2:= x^2+a*x-4
Result: x^2+a*x-4;
In> A:=SylvesterMatrix(ex1,ex2,x)
Result: {{1,2,-a,0},{0,1,2,-a},
	  {1,a,-4,0},{0,1,a,-4}};
In> B:=Determinant(A)
Result: 16-a^2*a- -8*a-4*a+a^2- -2*a^2-16-4*a;
In> Simplify(B)
Result: 3*a^2-a^3;

The above example shows that the two polynomials have common
zeros if $ a = 3 $.

*SEE Determinant, Simplify, Solve, PSolve
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Normalize.mpw0000644000175000017500000000112011523200452027203 0ustar  giovannigiovanni%mathpiper,def="Normalize"

Function("Normalize",{vector})
[
  Local(norm);
  norm:=0;
  ForEach(item,vector)
  [
    norm:=norm+item*item;
  ];
  (1/(norm^(1/2)))*vector;
];

%/mathpiper



%mathpiper_docs,name="Normalize",categories="User Functions;Linear Algebra"
*CMD Normalize --- normalize a vector
*STD
*CALL
	Normalize(v)

*PARMS

{v} -- a vector

*DESC

Return the normalized (unit) vector parallel to {v}: a vector having the same
direction but with length 1.

*E.G.

In> v:=Normalize({3,4})
Result: {3/5,4/5};
In> Dot(v, v)
Result: 1;

*SEE InProduct, CrossProduct
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/HilbertMatrix.mpw0000644000175000017500000000253511523200452030034 0ustar  giovannigiovanni%mathpiper,def="HilbertMatrix"

// The arguments of the following functions should be checked
// notoriously hard to manipulate numerically
HilbertMatrix(n):=GenMatrix({{i,j}, 1/(i+j-1)}, n,n );
HilbertMatrix(m,n):=GenMatrix({{i,j}, 1/(i+j-1)}, m,n );


%/mathpiper



%mathpiper_docs,name="HilbertMatrix",categories="User Functions;Matrices (Special)"
*CMD HilbertMatrix --- create a Hilbert matrix
*STD
*CALL
	HilbertMatrix(n)
	HilbertMatrix(n,m)
*PARMS

{n,m} -- positive integers

*DESC

The function {HilbertMatrix} returns the {n} by {m} Hilbert matrix
if given two arguments, and the square {n} by {n} Hilbert matrix
if given only one. The Hilbert matrix is defined as {A(i,j) = 1/(i+j-1)}.
The Hilbert matrix is extremely sensitive to manipulate and invert numerically.

*E.G.

In> PrettyForm(HilbertMatrix(4))

	/                          \
	| ( 1 ) / 1 \ / 1 \ / 1 \  |
	|       | - | | - | | - |  |
	|       \ 2 / \ 3 / \ 4 /  |
	|                          |
	| / 1 \ / 1 \ / 1 \ / 1 \  |
	| | - | | - | | - | | - |  |
	| \ 2 / \ 3 / \ 4 / \ 5 /  |
	|                          |
	| / 1 \ / 1 \ / 1 \ / 1 \  |
	| | - | | - | | - | | - |  |
	| \ 3 / \ 4 / \ 5 / \ 6 /  |
	|                          |
	| / 1 \ / 1 \ / 1 \ / 1 \  |
	| | - | | - | | - | | - |  |
	| \ 4 / \ 5 / \ 6 / \ 7 /  |
	\                          /

*SEE HilbertInverseMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Transpose.mpw0000644000175000017500000000125311523200452027230 0ustar  giovannigiovanni%mathpiper,def="Transpose"

Transpose(matrix_IsList)_(Length(Dimensions(matrix))>1) <--
[
  Local(i,j,result);
  result:=ZeroMatrix(Length(matrix[1]),Length(matrix));
  For(i:=1,i<=Length(matrix),i++)
    For(j:=1,j<=Length(matrix[1]),j++)
      result[j][i]:=matrix[i][j];
  result;
];

%/mathpiper



%mathpiper_docs,name="Transpose",categories="User Functions;Linear Algebra"
*CMD Transpose --- get transpose of a matrix
*STD
*CALL
	Transpose(M)

*PARMS

{M} -- a matrix

*DESC

{Transpose} returns the transpose of a matrix $M$. Because matrices are
just lists of lists, this is a useful operation too for lists.

*E.G.

In> Transpose({{a,b}})
Result: {{a},{b}};
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/ExtractSubmatrix.mpw0000644000175000017500000000435711523200452030573 0ustar  giovannigiovanni%mathpiper,title="ExtractSubMatrix"

//Retract("ExtractSubMatrix",*);

10 # ExtractSubMatrix( mat_IsMatrix, _row1, _col1, _row2, _col2 )_
       (And(IsPositiveInteger(row1),IsPositiveInteger(col1),
            IsPositiveInteger(row2),IsPositiveInteger(col2))) <--
[
    Local(nrows,ncols,r,row,result);
    {nrows,ncols} := Dimensions( mat );
    Check(And(row1>0,col1>0,row1row1,col2>col1,row2<=nrows,col2<=ncols), "Math", "ERROR: LR out of range");
    result := {};
    For(r:=row1,r<=row2,r++)
    [
        row := Take( MatrixRow(mat,r), {col1,col2} );
        result := DestructiveAppend( result, row );
    ];
    result;
];


10 # ExtractSubMatrix( mat_IsMatrix, _row1, _col1 )_
              (And(IsPositiveInteger(row1),IsPositiveInteger(col1))) <--
[
    Local(nrows,ncols);
    {nrows,ncols} := Dimensions( mat );
    Check(And(row1>0,col1>0,row1 AM := {{11,12,13,14},{21,22,23,24},{31,32,33,34}}
Result: {{11,12,13,14},{21,22,23,24},{31,32,33,34}}

In> ExtractSubMatrix(AM,2,2,3,3)
Result: {{22,23},{32,33}}

In> ExtractSubMatrix(AM,2,2);
Result: {{22,23,24},{32,33,34}}

In> ExtractSubMatrix(AM,0,2,1,3);
Result: ExtractSubMatrix({{11,12,13,14},{21,22,23,24},{31,32,33,34}},0,2,1,3)

In> ExtractSubMatrix(AM,1,3,2,5)
Result: 
Exception: ERROR: LR out of range

%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/PNorm.mpw0000644000175000017500000000100011502266107026301 0ustar  giovannigiovanni%mathpiper,def="PNorm"

// p-norm, reduces to euclidean norm when p = 2
Function("PNorm",{v,p})
[
	Local(result,i);
	Check(p>=1, "Argument", "PNorm: p must be >= 1");

	result:=0;
	For(i:=1,i<=Length(v),i++)[
		result:=result+Abs(v[i])^p;
	];

	// make it look nicer when p = 2
	If(p=2,Sqrt(result),(result)^(1/p) );
];

%/mathpiper




%mathpiper_docs,name="PNorm",categories="User Functions;Linear Algebra"
*CMD PNorm --- todo:?
*CALL
	PNorm(v,p)

*PARMS
{v} -- ?
{p} -- ?

*DESC
?

*E.G.
todo
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/Trace.mpw0000644000175000017500000000152011523200452026305 0ustar  giovannigiovanni%mathpiper,def="Trace"

//Retract("Trace",*);

Trace(matrix_IsList) <--
[
   Local(i,j,n,d,r,aux,result);
   
   d:=Dimensions(matrix);
   
   r:=Length(d); // tensor rank.
   
   n:=Minimum(d);    // minimal dim.
   
   result:=0;
   
   For(i:=1,i<=n,i++)
   [
      aux:=matrix[i];
      For(j:=2,j<=r,j++)
	 aux:=aux[i];
      result:=result+aux;
   ];
   result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Trace",categories="User Functions;Linear Algebra"
*CMD Trace --- trace of a matrix
*STD
*CALL
	Trace(M)

*PARMS

{M} -- a matrix

*DESC

{Trace} returns the trace of a matrix $M$ (defined as the sum of the
elements on the diagonal of the matrix).

*E.G.

In> A:=DiagonalMatrix(1 .. 4)
Result: {{1,0,0,0},{0,2,0,0},{0,0,3,0},{0,0,0,4}};
In> Trace(A)
Result: 10;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/RREF.mpw0000644000175000017500000001471111555100362026017 0ustar  giovannigiovanni%mathpiper,title="RREF"

//Retract("RREF",*);

/*------------------------------------------------------------------------
 * RREF
 *    Takes an Augmented Matrix AM and convert it to Reduced Row Echelon
 * Form (Row Canonical Form).
 *
 *    Algorithm based on Anton & Rorres, Elementary Linear Algebra, p 10ff
 *
 *------------------------------------------------------------------------*/

10 # RREF( AM_IsMatrix ) <--
[
    If( Not IsBound(iDebug), iDebug := False );
    If(iDebug,Tell("RREF",AM));
    Local(mRows,nCols,nVars,varVec,ir,jc,col,am,e,ii,pivot);
    {mRows,nCols} := Dimensions(AM);
    am            := FlatCopy(AM); //  so as not to mess with original matrix!
    
    Local(cc,cr,col,cnz);  // cc = current column,  cr = current row
    cc := 1;               // initialize cc and cr to 1, to start with
    cr := 1;
    
    While( cr <= mRows )  // iterating over successively lower submatrices
    [
        Local(ic);

        // STEP 1:  Locate first (sub)column that is NOT all zeros
        If(iDebug, Tell("  STEP 1"));
        cnz := 0;   //  column number of first non-zero column in submatrix
        For(ic:=1,ic<=nCols,ic++)   
         [ 
            col := MatrixColumn(am,ic);
            If( cr > 1, col := Drop( col, {1,cr-1} ) );
            //Tell("         ",{ic,col});
            If(Not IsZeroVector(col), [cnz := ic; Break();]); 
         ];
        cc := cnz;
        If( iDebug, Tell("     first non-zero column is ",cc));
        
        // STEP 2::  Now, find the first row which does not have a zero in column cc,
        // and bring it to the top if necessary
        If(iDebug, Tell("  STEP 2"));
        For( ir:=cr, ir<=mRows,ir++ )
         [  
            If( am[ir][cc] != 0 And ir != 1, 
              [
                {am[ir],am[cr]} := {am[cr],am[ir]};
                If(iDebug, Tell("   swapping rows ",{cr,ir}));
                Break();
              ]
            );
         ];
        If(iDebug,[Tell("working matrix");TableForm(am);]);
        
        // STEP 3:  If the entry am[cr][cc] = a, then multiply row cr by 1/a
        // in order to introduce a leading 1.
        If(iDebug, Tell("  STEP 3"));
        am[cr] := am[cr]/am[cr][cc];
        If(iDebug,TableForm(am));
        
        // STEP 4:  Add suitable multiples of the top row to the rows below,
        // so that all entries below the leading 1 become zeros.
        If(iDebug, Tell("  STEP 4"));
        For(ir:=cr+1,ir<=mRows,ir++)
         [
           If( am[ir][cc] != 0, 
             [
                am[ir] := am[ir] - am[ir][cc]*am[cr];
             ]
           );
         ];
        If(iDebug,TableForm(am));
        
        // STEP 5:  Now cover the top row and begin again with STEP 1, 
        // applied to the submatrix that remains.  Continue until the
        // entire matrix is in row-echelon form
        If(iDebug, Tell("  STEP 5"));
        cr := cr + 1;
        If(iDebug And cr <= mRows, [NewLine();Tell(" ",cr);]);
        //Tell("   ",cr);
        //Tell("   ",am[cr]);
        If( cr=mRows And IsZeroVector(am[cr]), Break() );
    ];   // end while cr <= mRows
    
    // STEP 6:  convert to unique reduced row-echelon form
    //   Beginning with the last non-zero row, and working upward,
    //   add suitable multiples of each row to the rows above to 
    //   introduce zeros above the leading 1's.
    If(iDebug, Tell("  STEP 6"));
    Local(pc,jr);
    For(ir:=mRows,ir>1,ir--)
     [ 
         
         If(iDebug,Tell("",{ir,am[ir]}));
         If(IsZeroVector(am[ir]),
           [If(iDebug,Tell("    trailing row of zeros:  row ",ir)); ir:=ir-1;Continue();],
           [
              pc := Find(am[ir],1);  // find leading 1 in row
              If(pc > 0, 
                [
                   For(jr:=ir-1,jr>=1,jr--)
                    [
                       If(am[jr][pc]!=0, am[jr]:=am[jr]-am[jr][pc]*am[ir]);
                       If(iDebug,[NewLine();TableForm(am);]);
                    ];
                ]
              );
           ]
         );
     ];
    am;
];  
%/mathpiper




%mathpiper_docs,name="RREF",categories="User Functions;Linear Algebra"
*CMD RREF --- convert a system of equations to reduced row echelon form
*STD
*CALL
	RREF(AugmentedMatrix)

*PARMS

{AugmentedMatrix} -- Augmented matrix describing the system of equations


*DESC

{RREF} solves a system of linear equations by using the Gauss-Jordan
elimination method with partial pivoting, to convert the augmented matrix to the
(unique) reduced row echelon form.  
The original matrix is not modified.

If the system of equations has a unique solution, this function returns a matrix in
a form like
[   1  0  0  a]
[   0  1  0  b]
[   0  0  1  c]
where the diagonal form of the left submatrix indicates that the solution is unique
and has been found, and the right-hand column is the vector of solutions.

If the system of equations has {no} solution, this function returns a matrix in
a form like
[  1  0  0  a]
[  0  1  0  b]
[  0  0  0  c]
where the presence of a row like {0 0 0 c} at the bottom indicates that the system is
inconsistent and has no solution (0==c).

If the system of equations is {dependent} and has a family of valid solutions, this
function returns a matrix in a form like
[  1  0  q  a]
[  0  1  0  b]
[  0  0  0  0]
where the presence of a row (or several rows) of all zeros at the bottom indicates
that the corresponding variables appear as parameters describing a family of solutions
for the remaining variables.


*E.G.

In> AM := {{2,-3,2,3},{4,8,1,2},{1,7,-3,-14}};
Result: {{2,-3,2,3},{4,8,1,2},{1,7,-3,-14}}

In> RREF(AM)
Result: {{1,0,0,-3},{0,1,0,1},{0,0,1,6}}

NOTE:  This is fully solved.  The solution is
       {{x==-3},{y==1},{z==6}}

In> AM := {{2,-1,3},{6,-3,9}};
Result: {{2,-1,3},{6,-3,9}}

In> RREF(AM)
Result: {{1,(-1)/2,3/2},{0,0,0}}

NOTE:  This is a "dependent" set of equations.
       The presence of a row of zeros at the bottom of the result
       shows that the solution is
       {{x==x},{y==2*x-3}} for any real x.

In> AM := {{2,-4,6,5},{-1,3,-2,-1},{1,-2,3,1}};
Result: {{2,-4,6,5},{-1,3,-2,-1},{1,-2,3,1}}

In> RREF(AM)
Result: {{1,0,5,0},{0,1,1,0},{0,0,0,1}}
NOTE:  This is an "inconsistent" set of equations.
       The last row, which states that 0==1, shows
       that there is no solution.
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/MatrixColumn.mpw0000644000175000017500000000156711502266107027712 0ustar  giovannigiovanni%mathpiper,def="MatrixColumn"

Function("MatrixColumn",{matrix,col})
[
  Local(m);
  m:=matrix[1];

  Check(col > 0, "Argument", "MatrixColumn: column index out of range");
  Check(col <= Length(m), "Argument", "MatrixColumn: column index out of range");

  Local(i,result);
  result:={};
  For(i:=1,i<=Length(matrix),i++)
    DestructiveAppend(result,matrix[i][col]);

  result;
];

%/mathpiper




%mathpiper_docs,name="MatrixColumn",categories="User Functions;Linear Algebra"
*CMD MatrixColumn --- obtain the column of a matrix
*STD
*CALL
	MatrixColumn(matrix,column)

*PARMS
{matrix} -- a matrix
{column} -- the index of a matrix column

*DESC
Returns the column of a matrix which is specified by {column}.

*E.G.
In> A := {{1,2}, {3,4}};
Result: {{1,2},{3,4}}

In> MatrixColumn(A,1)
Result: {1,3}}

*SEE MatrixRow
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/RecursiveDeterminant.mpw0000644000175000017500000000210111322513743031414 0ustar  giovannigiovanni%mathpiper,def="RecursiveDeterminant"

/* Recursive calculation of determinant, provided by Sebastian Ferraro
 */
20 # RecursiveDeterminant(_matrix) <--
[
  /*
  
  */
  Local(result);
  If(IsEqual(Length(matrix),1),matrix[1][1],[
    result:=0;
    ForEach(i,1 .. Length(matrix))
      //Consider only non-zero entries
      If(Not(IsEqual(matrix[1][i],0)),
        //Transpose and Drop eliminate row 1, column i
        result:=result+matrix[1][i]*(-1)^(i+1)* RecursiveDeterminant(Transpose(Drop(Transpose(Drop(matrix,{1,1})),{i,i}))));
    result;
  ]);
];

%/mathpiper




%mathpiper_docs,name="RecursiveDeterminant",categories="User Functions;Linear Algebra"
*CMD RecursiveDeterminant --- computes a determinant recursively
*STD
*CALL
	RecursiveDeterminant(matrix)

*PARMS
{matrix} -- a matrix
*DESC
Computes a determinant recursively by summing the product of each (nonzero) element 
on the first row of the matrix by +/- the determinant of the submatrix with the 
corresponding row and column deleted.

*E.G.
todo
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/ZeroVector.mpw0000644000175000017500000000110211523200452027345 0ustar  giovannigiovanni%mathpiper,def="ZeroVector"

Function("ZeroVector",{n})
[
    Local(i,result);
    result:={};
    For(i:=1,i<=n,i++)
    [
      DestructiveInsert(result,1,0);
    ];
    result;
];

%/mathpiper



%mathpiper_docs,name="ZeroVector",categories="User Functions;Linear Algebra"
*CMD ZeroVector --- create a vector with all zeroes
*STD
*CALL
	ZeroVector(n)

*PARMS

{n} -- length of the vector to return

*DESC

This command returns a vector of length "n", filled with zeroes.

*E.G.

In> ZeroVector(4)
Result: {0,0,0,0};

*SEE BaseVector, ZeroMatrix, IsZeroVector
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/linalg/X_operator.mpw0000644000175000017500000000041311322513743027400 0ustar  giovannigiovanni%mathpiper,def="X"

x X y := CrossProduct(x,y);

%/mathpiper





%mathpiper_docs,name="X",categories="Operators"
*CMD X --- todo
*CALL
	x X y

*PARMS
todo

*DESC
todo

*E.G.
todo

*SEE CrossProduct
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/array/0000755000175000017500000000000011722677337024421 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/array/ArrayToList.mpw0000644000175000017500000000052611316266467027363 0ustar  giovannigiovanni%mathpiper,def="ArrayToList"

ArrayToList(array):= (array[1 .. ArraySize(array) ]);

%/mathpiper




%mathpiper_docs,name="ArrayToList",categories="Programmer Functions;Native Objects"
*CMD ArrayToList --- convert array to list
*CORE
*CALL
	ArrayToList(array)

*DESC
Creates a list from the contents of the array passed in.

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/array/ArrayCreateFromList.mpw0000644000175000017500000000100211316266467031016 0ustar  giovannigiovanni
%mathpiper,def="ArrayCreateFromList"

ArrayCreateFromList(list):=
[
  Local(result,i);
  result:=ArrayCreate(Length(list),0);
  i:=1;
  While (list != {})
  [
    result[i]:=First(list);
    i++;
    list:=Rest(list);
  ];
  result;
];

%/mathpiper





%mathpiper_docs,name="ArrayCreateFromList",categories="Programmer Functions;Native Objects"
*CMD ArrayCreateFromList --- convert list to array
*CALL
	ArrayCreateFromList(list)

*DESC
Creates an array from the contents of the list passed in.

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/0000755000175000017500000000000011722677335024441 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Expand.mpw0000644000175000017500000000327111523200452026365 0ustar  giovannigiovanni%mathpiper,def="Expand"

/* Expand expands polynomials.
 */
10 # Expand(expr_CanBeUni) <-- NormalForm(MakeUni(expr));
20 # Expand(_expr) <-- expr;

10 # Expand(expr_CanBeUni(var),_var) <-- NormalForm(MakeUni(expr,var));
20 # Expand(_expr,_var) <-- expr;

%/mathpiper



%mathpiper_docs,name="Expand",categories="User Functions;Polynomials (Operations)"
*CMD Expand --- transform a polynomial to an expanded form
*STD
*CALL
	Expand(expr)
	Expand(expr, var)
	Expand(expr, varlist)

*PARMS

{expr} -- a polynomial expression

{var} -- a variable

{varlist} -- a list of variables

*DESC

This command brings a polynomial in expanded form, in which
polynomials are represented in the form 
$c0 + c1*x + c2*x^2 + ... + c[n]*x^n$. In this form, it is easier to test whether a polynomial is
zero, namely by testing whether all coefficients are zero.

If the polynomial "expr" contains only one variable, the first
calling sequence can be used. Otherwise, the second form should be
used which explicitly mentions that "expr" should be considered as a
polynomial in the variable "var". The third calling form can be used
for multivariate polynomials. Firstly, the polynomial "expr" is
expanded with respect to the first variable in "varlist". Then the
coefficients are all expanded with respect to the second variable, and
so on.

*E.G.

In> PrettyPrinterSet("PrettyForm");
	
	True

In> Expand((1+x)^5);
	
	 5        4         3         2
	x  + 5 * x  + 10 * x  + 10 * x  + 5 * x + 1

In> Expand((1+x-y)^2, x);
	
	 2                                2
	x  + 2 * ( 1 - y ) * x + ( 1 - y )

In> Expand((1+x-y)^2, {x,y});
	
	 2                         2
	x  + ( -2 * y + 2 ) * x + y  - 2 * y + 1
	

*SEE ExpandBrackets
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Abs.mpw0000644000175000017500000000257111523200452025655 0ustar  giovannigiovanni%mathpiper,def="Abs"

10 # Abs(Infinity) 	<-- Infinity; //Note:tk:moved here from stdfuncts.

10 # Abs(n_IsNumber) <-- AbsN(n);
10 # Abs(n_IsPositiveNumber/m_IsPositiveNumber) <-- n/m;
10 # Abs(n_IsNegativeNumber/m_IsPositiveNumber) <-- (-n)/m;
10 # Abs(n_IsPositiveNumber/m_IsNegativeNumber) <-- n/(-m);
10 # Abs( Sqrt(_x)) <-- Sqrt(x);
10 # Abs(-Sqrt(_x)) <-- Sqrt(x);
10 # Abs(Complex(_r,_i)) <-- Sqrt(r^2 + i^2);
10 # Abs(n_IsInfinity) <-- Infinity;
10 # Abs(Undefined) <-- Undefined;
20 # Abs(n_IsList) <-- MapSingle("Abs",n);

100 # Abs(_a^_n) <-- Abs(a)^n;



%/mathpiper



%mathpiper_docs,name="Abs",categories="User Functions;Calculus Related (Symbolic)"
*CMD Abs --- absolute value or modulus of complex number
*STD
*CALL
	Abs(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the absolute value (also called the modulus) of
"x". If "x" is positive, the absolute value is "x" itself; if
"x" is negative, the absolute value is "-x". For complex "x",
the modulus is the "r" in the polar decomposition
$x = r *Exp(I*phi)$.

This function is connected to the {Sign} function by
the identity "Abs(x) * Sign(x) = x" for real "x".

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Abs(2);
Result: 2;
In> Abs(-1/2);
Result: 1/2;
In> Abs(3+4*I);
Result: 5;

*SEE Sign, Arg
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Ceil.mpw0000644000175000017500000000161311523200452026020 0ustar  giovannigiovanni%mathpiper,def="Ceil"

5 # Ceil(Infinity) <-- Infinity;
5 # Ceil(-Infinity) <-- -Infinity;
5 # Ceil(Undefined) <-- Undefined;

10 # Ceil(x_IsRationalOrNumber)
   <--
   [
     x:=N(x);
     Local(prec,result,n);
     Bind(prec,BuiltinPrecisionGet());
     If(IsZero(x),Bind(n,2),
     If(x>0,
       Bind(n,2+FloorN(N(FastLog(x)/FastLog(10)))),
       Bind(n,2+FloorN(N(FastLog(-x)/FastLog(10))))
       ));
     If(n>prec,BuiltinPrecisionSet(n));
     Bind(result,CeilN(x));
     BuiltinPrecisionSet(prec);
     result;
   ];
//   CeilN (N(x));

%/mathpiper



%mathpiper_docs,name="Ceil",categories="User Functions;Numbers (Operations)"
*CMD Ceil --- round a number upwards
*STD
*CALL
	Ceil(x)

*PARMS

{x} -- a number

*DESC

This function returns $Ceil(x)$, the smallest integer larger than or equal to $x$.

*E.G.

In> Ceil(1.1)
Result: 2;
In> Ceil(-1.1)
Result: -1;

*SEE Floor, Round
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/shifting_operators.mpw0000644000175000017500000000122111523200452031050 0ustar  giovannigiovanni%mathpiper,def="<<;>>"

/* def file definitions
<<
>>
*/

/* Shifting operators */

n_IsInteger << m_IsInteger <-- ShiftLeft(n,m);
n_IsInteger >> m_IsInteger <-- ShiftRight(n,m);

%/mathpiper


%mathpiper_docs,name="<<;>>",categories="Operators"
*CMD << --- binary shift left operator
*CMD >> --- binary shift right operator
*STD
*CALL
	n<>m

*PARMS

{n}, {m} -- integers

*DESC

These operators shift integers to the left or to the right.
They are similar to the C shift operators. These are sign-extended
shifts, so they act as multiplication or division by powers of 2.

*E.G.

In> 1 << 10
Result: 1024;
In> -1024 >> 10
Result: -1;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/comparison_operators.mpw0000644000175000017500000001755011523200452031423 0ustar  giovannigiovanni%mathpiper,def="<;>;<=;>=;!="

/* def file definitions
=
<
>
<=
>=
!=

*/

/* Comparison operators. They call the internal comparison routines when
 * both arguments are numbers. The value Infinity is also understood.
*/

// Undefined is a very special case as we return False for everything
1 # Undefined <  _x  <--  False;
1 # Undefined <= _x  <--  False;
1 # Undefined >  _x  <--  False;
1 # Undefined >= _x  <--  False;
1 # _x <  Undefined  <--  False;
1 # _x <= Undefined  <--  False;
1 # _x >  Undefined  <--  False;
1 # _x >= Undefined  <--  False;


// If n and m are numbers, use the standard LessThan function immediately
5 # (n_IsNumber < m_IsNumber) <-- IsLessThan(n-m,0);


// If n and m are symbolic after a single evaluation, see if they can be coerced in to a real-valued number.
LocalSymbols(nNum,mNum)
[
  10 # (_n < _m)_[nNum:=N(Eval(n)); mNum:=N(Eval(m));IsNumber(nNum) And IsNumber(mNum);] <-- IsLessThan(nNum-mNum,0);
];

// Deal with Infinity
20 #  (Infinity < _n)_(Not(IsInfinity(n)))  <-- False;
20 #  (-Infinity < _n)_(Not(IsInfinity(n))) <-- True;
20 #  (_n < Infinity)_(Not(IsInfinity(n)))  <-- True;
20 #  (_n < -Infinity)_(Not(IsInfinity(n))) <-- False;

// Lots of known identities go here
30 # (_n1/_n2) < 0  <--  (n1 < 0) != (n2 < 0);
30 # (_n1*_n2) < 0  <--  (n1 < 0) != (n2 < 0);

// This doesn't sadly cover the case where a and b have opposite signs
30 # ((_n1+_n2) < 0)_((n1 < 0) And (n2 < 0))  <--  True;
30 # ((_n1+_n2) < 0)_((n1 > 0) And (n2 > 0))  <--  False;
30 #  _x^a_IsOdd  < 0  <--  x < 0;
30 #  _x^a_IsEven < 0  <--  False; // This is wrong for complex x

// Add other functions here!  Everything we can compare to 0 should be here.
40 # (Sqrt(_x))_(x > 0) < 0          <--  False;

40 # (Sin(_x) < 0)_(Not(IsEven(N(x/Pi))) And IsEven(N(Floor(x/Pi)))) <-- False;
40 # (Sin(_x) < 0)_(Not(IsOdd (N(x/Pi))) And IsOdd (N(Floor(x/Pi)))) <-- True;

40 # Cos(_x) < 0 <-- Sin(Pi/2-x) < 0;

40 # (Tan(_x) < 0)_(Not(IsEven(N(2*x/Pi))) And IsEven(N(Floor(2*x/Pi)))) <-- False;
40 # (Tan(_x) < 0)_(Not(IsOdd (N(2*x/Pi))) And IsOdd (N(Floor(2*x/Pi)))) <-- True;

// Functions that need special treatment with more than one of the comparison
// operators as they always return true or false.  For these we must define
// both the `<' and `>=' operators.
40 # (Complex(_a,_b) <  0)_(b!=0) <--  False;
40 # (Complex(_a,_b) >= 0)_(b!=0) <--  False;
40 # (Sqrt(_x))_(x < 0) <  0      <--  False;
40 # (Sqrt(_x))_(x < 0) >= 0      <--  False;

// Deal with negated terms
50 # -(_x) < 0 <-- Not((x<0) Or (x=0));

// Define each of {>,<=,>=} in terms of <
50 # _n >  _m <-- m < n;
50 # _n <= _m <-- m >= n;
50 # _n >= _m <-- Not(n 2 < 5;
Result: True;
In> Cos(1) < 5;
Result: True;

*SEE IsNumber, IsInfinity, N
%/mathpiper_docs



%mathpiper_docs,name=">",categories="Operators"
*CMD > --- test for "greater than"
*STD
*CALL
	e1 > e2
Precedence:
*EVAL PrecedenceGet(">")


*PARMS

{e1}, {e2} -- expressions to be compared

*DESC

The two expression are evaluated. If both results are numeric, they
are compared. If the first expression is larger than the second one,
the result is {True} and it is {False} otherwise. If either of the expression is not numeric, after
evaluation, the expression is returned with evaluated arguments.

The word "numeric" in the previous paragraph has the following
meaning. An expression is numeric if it is either a number (i.e. {IsNumber} returns {True}), or the
quotient of two numbers, or an infinity (i.e. {IsInfinity} returns {True}). MathPiper will try to 
coerce the arguments passed to this comparison operator to a real value before making the comparison.

*E.G.

In> 2 > 5;
Result: False;
In> Cos(1) > 5;
Result: False

*SEE IsNumber, IsInfinity, N
%/mathpiper_docs



%mathpiper_docs,name="<=",categories="Operators"
*CMD <= --- test for "less or equal"
*STD
*CALL
	e1 <= e2
Precedence:
*EVAL PrecedenceGet("<=")


*PARMS

{e1}, {e2} -- expressions to be compared

*DESC

The two expression are evaluated. If both results are numeric, they
are compared. If the first expression is smaller than or equals the
second one, the result is {True} and it is {False} otherwise. If either of the expression is not
numeric, after evaluation, the expression is returned with evaluated
arguments.

The word "numeric" in the previous paragraph has the following
meaning. An expression is numeric if it is either a number (i.e. {IsNumber} returns {True}), or the
quotient of two numbers, or an infinity (i.e. {IsInfinity} returns {True}). MathPiper will try to 
coerce the arguments passed to this comparison operator to a real value before making the comparison.

*E.G.

In> 2 <= 5;
Result: True;
In> Cos(1) <= 5;
Result: True

*SEE IsNumber, IsInfinity, N
%/mathpiper_docs



%mathpiper_docs,name=">=",categories="Operators"
*CMD >= --- test for "greater or equal"
*STD
*CALL
	e1 >= e2
Precedence:
*EVAL PrecedenceGet(">=")


*PARMS

{e1}, {e2} -- expressions to be compared

*DESC

The two expression are evaluated. If both results are numeric, they
are compared. If the first expression is larger than or equals the
second one, the result is {True} and it is {False} otherwise. If either of the expression is not
numeric, after evaluation, the expression is returned with evaluated
arguments.

The word "numeric" in the previous paragraph has the following
meaning. An expression is numeric if it is either a number (i.e. {IsNumber} returns {True}), or the
quotient of two numbers, or an infinity (i.e. {IsInfinity} returns {True}). MathPiper will try to 
coerce the arguments passed to this comparison operator to a real value before making the comparison.

*E.G.

In> 2 >= 5;
Result: False;
In> Cos(1) >= 5;
Result: False

*SEE IsNumber, IsInfinity, N
%/mathpiper_docs



%mathpiper_docs,name="!=",categories="Operators"
*CMD != --- test for "not equal"
*STD
*CALL
	e1 != e2
Precedence:
*EVAL PrecedenceGet("!=")


*PARMS

{e1}, {e2} -- expressions to be compared

*DESC

Both expressions are evaluated and compared. If they turn out to be
equal, the result is {False}. Otherwise, the result
is {True}.

The expression {e1 != e2} is equivalent to {Not(e1 = e2)}.

*E.G.

In> 1 != 2;
Result: True;
In> 1 != 1;
Result: False;

*SEE =
%/mathpiper_docs



%mathpiper_docs,name="=",categories="Operators"
*CMD = --- test for equality of expressions
*STD
*CALL
	e1 = e2
Precedence:
*EVAL PrecedenceGet("=")


*PARMS

{e1}, {e2} -- expressions to be compared

*DESC

Both expressions are evaluated and compared. If they turn out to be equal, the
result is {True}. Otherwise, the result is {False}. The function {Equals} does
the same.

Note that the test is on syntactic equality, not mathematical equality. Hence
even if the result is {False}, the expressions can still be
mathematically equal; see the examples below. Put otherwise, this
function tests whether the two expressions would be displayed in the same way
if they were printed.

*E.G.

In> e1 := (x+1) * (x-1);
Result: (x+1)*(x-1);
In> e2 := x^2 - 1;
Result: x^2-1;
	
In> e1 = e2;
Result: False;
In> Expand(e1) = e2;
Result: True;

*SEE !=, Equals
%/mathpiper_docs




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Round.mpw0000644000175000017500000000154711523200452026241 0ustar  giovannigiovanni%mathpiper,def="Round"

5 # Round(Infinity) <-- Infinity;
5 # Round(-Infinity) <-- -Infinity;
5 # Round(Undefined) <-- Undefined;

10 # Round(x_IsRationalOrNumber) <-- FloorN(N(x+0.5));
10 # Round(x_IsList) <-- MapSingle("Round",x);

20 # Round(x_IsComplex)  _ (IsRationalOrNumber(Re(x)) And IsRationalOrNumber(Im(x)) )
		<-- FloorN(N(Re(x)+0.5)) + FloorN(N(Im(x)+0.5))*I;

%/mathpiper



%mathpiper_docs,name="Round",categories="User Functions;Numbers (Operations)"
*CMD Round --- round a number to the nearest integer
*STD
*CALL
	Round(x)

*PARMS

{x} -- a number

*DESC

This function returns the integer closest to $x$. Half-integers
(i.e. numbers of the form $n + 0.5$, with $n$ an integer) are
rounded upwards.

*E.G.

In> Round(1.49)
Result: 1;
In> Round(1.51)
Result: 2;
In> Round(-1.49)
Result: -1;
In> Round(-1.51)
Result: -2;

*SEE Floor, Ceil
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Sqrt.mpw0000644000175000017500000000371111523200452026076 0ustar  giovannigiovanni%mathpiper,def="Sqrt"

0 # Sqrt(0) <-- 0;
0 # Sqrt(Infinity) <--  Infinity;
0 # Sqrt(-Infinity) <-- Complex(0,Infinity);
0 # Sqrt(Undefined) <--  Undefined;
1 # Sqrt(x_IsPositiveInteger)_(IsInteger(SqrtN(x))) <-- SqrtN(x);
2 # Sqrt(x_IsPositiveNumber)_InNumericMode() <-- SqrtN(x);
2 # Sqrt(x_IsNegativeNumber) <-- Complex(0,Sqrt(-x));
/* 3 # Sqrt(x_IsNumber/y_IsNumber) <-- Sqrt(x)/Sqrt(y); */
3 # Sqrt(x_IsComplex)_InNumericMode() <-- x^(1/2);
/* Threading  */
Sqrt(xlist_IsList) <-- MapSingle("Sqrt",xlist);

90 # (Sqrt(x_IsConstant))_(IsNegativeNumber(N(x))) <-- Complex(0,Sqrt(-x));

400 # x_IsRationalOrNumber * Sqrt(y_IsRationalOrNumber)  <-- Sign(x)*Sqrt(x^2*y);
400 # Sqrt(y_IsRationalOrNumber) * x_IsRationalOrNumber  <-- Sign(x)*Sqrt(x^2*y);
400 # x_IsRationalOrNumber / Sqrt(y_IsRationalOrNumber)  <-- Sign(x)*Sqrt(x^2/y);
400 # Sqrt(y_IsRationalOrNumber) / x_IsRationalOrNumber  <-- Sign(x)*Sqrt(y/(x^2));
400 # Sqrt(y_IsRationalOrNumber) / Sqrt(x_IsRationalOrNumber)  <-- Sqrt(y/x);
400 # Sqrt(y_IsRationalOrNumber) * Sqrt(x_IsRationalOrNumber)  <-- Sqrt(y*x);
400 # Sqrt(x_IsInteger)_IsInteger(SqrtN(x)) <-- SqrtN(x);
400 # Sqrt(x_IsInteger/y_IsInteger)_(IsInteger(SqrtN(x)) And IsInteger(SqrtN(y))) <-- SqrtN(x)/SqrtN(y);

%/mathpiper



%mathpiper_docs,name="Sqrt",categories="User Functions;Calculus Related (Symbolic)"
*CMD Sqrt --- square root
*STD
*CALL
	Sqrt(x)

*PARMS

{x} -- argument to the function

*DESC

This function calculates the square root of "x". If the result is
not rational, the call is returned unevaluated unless a numerical
approximation is forced with the {N} function. This
function can also handle negative and complex arguments.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Sqrt(16)
Result: 4;
In> Sqrt(15)
Result: Sqrt(15);
In> N(Sqrt(15))
Result: 3.8729833462;
In> Sqrt(4/9)
Result: 2/3;
In> Sqrt(-1)
Result: Complex(0,1);

*SEE Exp, ^, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Modulo.mpw0000644000175000017500000000550611523200452026410 0ustar  giovannigiovanni%mathpiper,def="Modulo"

//Retract("Modulo",*);

0 # Modulo(_n,m_IsRationalOrNumber)_(m<0) <-- `Hold(Modulo(@n,@m));

1 # Modulo(n_IsNegativeInteger,m_IsPositiveInteger) <--
[
  Local(result);
  result := ModuloN(n,m);
  If (result < 0,result := result + m);
  result;
];
1 # Modulo(n_IsPositiveInteger,m_IsPositiveInteger) <-- ModuloN(n,m);
2 # Modulo(0,_m) <-- 0;
2 # Modulo(n_IsPositiveInteger,Infinity) <-- n;
3 # Modulo(n_IsInteger,m_IsInteger) <-- ModuloN(n,m);
4 # Modulo(n_IsNumber,m_IsNumber) <-- NonN(Modulo(Rationalize(n),Rationalize(m)));

5 # Modulo(n_IsRationalOrNumber,m_IsRationalOrNumber)/*_(n>0 And m>0)*/ <--
[
  Local(n1,n2,m1,m2);
  n1:=Numerator(n);
  n2:=Denominator(n);
  m1:=Numerator(m);
  m2:=Denominator(m);
  Modulo(n1*m2,m1*n2)/(n2*m2);
];

6 # Modulo(n_IsList,m_IsList) <-- Map("Modulo",{n,m});
7 # Modulo(n_IsList,_m) <-- Map("Modulo",{n,FillList(m,Length(n))});


30 # Modulo(n_CanBeUni,m_CanBeUni) <--
[
  Local(vars);
  vars:=VarList(n+m);
  NormalForm(Modulo(MakeUni(n,vars),MakeUni(m,vars)));
];


//Note:tk:moved here from univariate.rep.
0 # Modulo(n_IsUniVar,m_IsUniVar)_(Degree(n) < Degree(m)) <-- n;
1 # Modulo(n_IsUniVar,m_IsUniVar)_
    (n[1] = m[1] And Degree(n) >= Degree(m)) <--
[
    UniVariate(n[1],0,
               UniDivide(Concat(ZeroVector(n[2]),n[3]),
                         Concat(ZeroVector(m[2]),m[3]))[2]);
];

10 # Modulo(n_CanBeUni, m_CanBeUni, vars_IsList)_(Length(vars)=1) <--
[
    NormalForm(Modulo(MakeUni(n,vars),MakeUni(m,vars)));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


%mathpiper_docs,name="Modulo",categories="User Functions;Numbers (Operations)"
*CMD Modulo --- Determine remainder of two mathematical objects after dividing one by the other

*STD
*CALL
	Modulo(x,y)
	Modulo(x,y,vars)

*PARMS

{x}, {y} -- integers or univariate polynomials
{vars}   -- a list containing the name of the (single) variable appearing in both polynomials

*DESC

{Modulo} returns the remainder after division.  {Modulo} is also defined for univariate polynomials.

If {Quotient(x,y)} returns "a" and {Modulo(x,y)} equals "b", then these numbers satisfy $x =a*y + b$ and $0 <= b < y$.

The second form of the function contains a third parameter, and is used in the special case where the 
the "divisor" polynomial contains an unbound "variable" which is really just a parameter.  
In that situation, MathPiper cannot distinguish the variable from the parameter, until you
specifically name the variable.  See the example below.

*E.G.

In> Quotient(5,3)
Result: 1;
In> Modulo(5,3)
Result: 2;
	
In> Modulo(x^2-5*x+2,x-1)
Result: -2
	
In> Modulo(x^2-5*x+2,x-k)
Result: x^2-5*x+2          
	    NOTE: answer is INCORRECT
In> Modulo(x^2-5*x+2,x-k,{x})
Result: (k-5)*k+2
	    NOTE: answer is now CORRECT

*SEE Gcd, Lcm, Quotient
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/om/0000755000175000017500000000000011722677335025054 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/om/om.mpw0000644000175000017500000000210411320776303026176 0ustar  giovannigiovanni%mathpiper,def="false"

// From code.mpi.def:
OMDef( "Not", "logic1","not" );
OMDef( "=" , "relation1","eq"  );
OMDef( ">=", "relation1","geq" );
OMDef( ">" , "relation1","gt"  );
OMDef( "<=", "relation1","leq" );
OMDef( "<" , "relation1","lt"  );
OMDef( "!=", "relation1","neq" );
OMDef( "Gcd", "arith1","gcd" );
OMDef( "Sqrt", "arith1","root", { $, _1, 2 }, $(_1)_(_2=2) | (_1^(1/_2)) );
// Test [result: Sqrt(16)]:
// PipeFromString("162 ")OMRead()
// Test [result: IntNthRoot(16,3))]:
// PipeFromString("163 ")OMRead()
OMDef( "Abs", "arith1","abs" );
OMDef( "Lcm", "arith1","lcm" );

OMDef( "Floor", "rounding1","floor"   );
OMDef( "Ceil" , "rounding1","ceiling" );
OMDef( "Round", "rounding1","round"   );

OMDef( "Quotient"   , mathpiper,"div"    );
OMDef( "Modulo"   , mathpiper,"mod"    );
OMDef( "Expand", mathpiper,"expand" );
OMDef( "Object", mathpiper,"object" );
OMDef( "Sign"  , mathpiper,"sign"   );


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/minus_greaterthan_operator.mpw0000644000175000017500000000072111347104265032606 0ustar  giovannigiovanni%mathpiper,def="->"

Rulebase("->",{left,right});

HoldArgument("->",left);

//HoldArgument("->",right);

%/mathpiper




%mathpiper_docs,name="->",categories="Operators"
*CMD -> --- options operator
*CALL
	option -> value

*PARMS
{option} -- an option name

{value} -- the value to associate with the option

*DESC
The -> operator is used to create options.  {option} and {value}
need to be placed in quotes if they are not meant to be evaluated.

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Lcm.mpw0000644000175000017500000000226411523200452025662 0ustar  giovannigiovanni%mathpiper,def="Lcm"

/* Least common multiple */
5  # Lcm(a_IsInteger,b_IsInteger) <-- Quotient(a*b,Gcd(a,b));

10 # Lcm(list_IsList)_(Length(list)>2) <--
[
	Local(first);
	first:=Lcm(list[1],list[2]);
	Lcm(first:Rest(Rest(list)));
];

10 # Lcm(list_IsList)_(Length(list)=2) <-- Lcm(list[1],list[2]);

// We handle lists with just one element to avoid special-casing 
// all the calls. 
10 # Lcm(list_IsList)_(Length(list)=1) <-- Lcm(list[1],1);

%/mathpiper



%mathpiper_docs,name="Lcm",categories="User Functions;Numbers (Operations)"
*CMD Lcm --- least common multiple
*STD
*CALL
	Lcm(n,m)
	Lcm(list)

*PARMS

{n}, {m} -- integers or univariate polynomials
{list}	 -- list of integers

*DESC

This command returns the least common multiple of "n" and "m" or all of
the integers in the list {list}.
The least common multiple of two numbers "n" and "m" is the lowest
number which is an integer multiple of both "n" and "m".
It is calculated with the formula
$$Lcm(n,m) = Quotient(n*m,Gcd(n,m))$$.

This means it also works on polynomials, since {Div}, {Gcd} and multiplication are also defined for
them.

*E.G.

In> Lcm(60,24)
Result: 120;
In> Lcm({3,5,7,9})
Result: 315;


*SEE Gcd

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/LnCombine.mpw0000644000175000017500000000775511523200452027027 0ustar  giovannigiovanni%mathpiper,def="LnCombine"

////////////////////// Log rules stuff //////////////////////

// LnCombine is nice and simple now
LnCombine(_a) <-- DoLnCombine(CanonicalAdd(a));

// Combine single terms.  This can always be done without a recursive call.
1 # DoLnCombine(Ln(_a))              <-- Ln(a);
1 # DoLnCombine(Ln(_a)*_b)           <-- Ln(a^b);
1 # DoLnCombine(_b*Ln(_a))           <-- Ln(a^b);

// Deal with the first two terms so they are both simple logs if at all
// possible.  This involves converting a*Ln(b) to Ln(b^a) and moving log terms
// to the start of expressions.  One of either of these operations always takes
// us to a strictly simpler form than we started in, so we can get away with
// calling DoLnCombine again with the partly simplified argument.

// TODO: Make this deal with division everywhere it deals with multiplication

// first term is a log multiplied by something
2 # DoLnCombine(Ln(_a)*_b+_c)        <-- DoLnCombine(Ln(a^b)+c);
2 # DoLnCombine(Ln(_a)*_b-_c)        <-- DoLnCombine(Ln(a^b)-c);
2 # DoLnCombine(_b*Ln(_a)+_c)        <-- DoLnCombine(Ln(a^b)+c);
2 # DoLnCombine(_b*Ln(_a)-_c)        <-- DoLnCombine(Ln(a^b)-c);

// second term of a two-term expression is a log multiplied by something
2 # DoLnCombine(_a+(_c*Ln(_b)))      <-- DoLnCombine(a+Ln(b^c));
2 # DoLnCombine(_a-(_c*Ln(_b)))      <-- DoLnCombine(a-Ln(b^c));
2 # DoLnCombine(_a+(Ln(_b)*_c))      <-- DoLnCombine(a+Ln(b^c));
2 # DoLnCombine(_a-(Ln(_b)*_c))      <-- DoLnCombine(a-Ln(b^c));

// second term of a three-term expression is a log multiplied by something
2 # DoLnCombine(_a+((Ln(_b)*_c)+_d)) <-- DoLnCombine(a+(Ln(b^c)+d));
2 # DoLnCombine(_a+((Ln(_b)*_c)-_d)) <-- DoLnCombine(a+(Ln(b^c)-d));
2 # DoLnCombine(_a-((Ln(_b)*_c)+_d)) <-- DoLnCombine(a-(Ln(b^c)+d));
2 # DoLnCombine(_a-((Ln(_b)*_c)-_d)) <-- DoLnCombine(a-(Ln(b^c)-d));

2 # DoLnCombine(_a+((_c*Ln(_b))+_d)) <-- DoLnCombine(a+(Ln(b^c)+d));
2 # DoLnCombine(_a+((_c*Ln(_b))-_d)) <-- DoLnCombine(a+(Ln(b^c)-d));
2 # DoLnCombine(_a-((_c*Ln(_b))+_d)) <-- DoLnCombine(a-(Ln(b^c)+d));
2 # DoLnCombine(_a-((_c*Ln(_b))-_d)) <-- DoLnCombine(a-(Ln(b^c)-d));

// Combine the first two terms if they are logs, otherwise move one or both to
// the front, then recurse on the remaining possibly-log-containing portion.
// (the code makes more sense than this comment)
3 # DoLnCombine(Ln(_a)+Ln(_b))       <-- Ln(a*b);
3 # DoLnCombine(Ln(_a)-Ln(_b))       <-- Ln(a/b);
3 # DoLnCombine(Ln(_a)+(Ln(_b)+_c))  <-- DoLnCombine(Ln(a*b)+c);
3 # DoLnCombine(Ln(_a)+(Ln(_b)-_c))  <-- DoLnCombine(Ln(a*b)-c);
3 # DoLnCombine(Ln(_a)-(Ln(_b)+_c))  <-- DoLnCombine(Ln(a/b)-c);
3 # DoLnCombine(Ln(_a)-(Ln(_b)-_c))  <-- DoLnCombine(Ln(a/b)+c);

// We know that at least one of the first two terms isn't a log
4 # DoLnCombine(Ln(_a)+(_b+_c))      <-- b+DoLnCombine(Ln(a)+c);
4 # DoLnCombine(Ln(_a)+(_b-_c))      <-- b+DoLnCombine(Ln(a)-c);
4 # DoLnCombine(Ln(_a)-(_b+_c))      <-- DoLnCombine(Ln(a)-c)-b;
4 # DoLnCombine(Ln(_a)-(_b-_c))      <-- DoLnCombine(Ln(a)+c)-b;

4 # DoLnCombine(_a+(Ln(_b)+_c))      <-- a+DoLnCombine(Ln(b)+c);
4 # DoLnCombine(_a+(Ln(_b)-_c))      <-- a+DoLnCombine(Ln(b)-c);
4 # DoLnCombine(_a-(Ln(_b)+_c))      <-- a-DoLnCombine(Ln(b)+c);
4 # DoLnCombine(_a-(Ln(_b)-_c))      <-- a-DoLnCombine(Ln(b)-c);

// If we get here we know that neither of the first two terms is a log
5 # DoLnCombine(_a+(_b+_c))          <-- a+(b+DoLnCombine(c));

// Finished
6 # DoLnCombine(_a)                  <-- a;


%/mathpiper



%mathpiper_docs,name="LnCombine",categories="User Functions;Expression Simplification"
*CMD LnCombine --- combine logarithmic expressions using standard logarithm rules
*STD
*CALL
	LnCombine(expr)

*PARMS

{expr} -- an expression possibly containing multiple {Ln} terms to be combined

*DESC

{LnCombine} finds {Ln} terms in the expression it is given, and combines them
using logarithm rules.  It is intended to be the exact converse of {LnExpand}.

*E.G.
In> LnCombine(Ln(a)+Ln(b)*n)
Result: Ln(a*b^n)
In> LnCombine(2*Ln(2)+Ln(3)-Ln(5))
Result: Ln(12/5)

*SEE Ln, LnExpand
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Quotient.mpw0000644000175000017500000000274611523200452026764 0ustar  giovannigiovanni%mathpiper,def="Quotient"

/* Integer divisions */
0 # Quotient(n_IsInteger,m_IsInteger) <-- QuotientN(n,m);
1 # Quotient(0  ,_m) <-- 0;
2 # Quotient(n_IsRationalOrNumber,m_IsRationalOrNumber) <--
[
  Local(n1,n2,m1,m2,sgn1,sgn2);
  n1:=Numerator(n);
  n2:=Denominator(n);
  m1:=Numerator(m);
  m2:=Denominator(m);
  sgn1 := Sign(n1*m2);
  sgn2 := Sign(m1*n2);
  sgn1*sgn2*Floor(DivideN(sgn1*n1*m2,sgn2*m1*n2));
];
30 # Quotient(n_CanBeUni,m_CanBeUni)_(Length(VarList(n*m))=1) <--
[

  Local(vars,nl,ml);
  vars:=VarList(n*m);
  nl := MakeUni(n,vars);
  ml := MakeUni(m,vars);
  NormalForm(Quotient(nl,ml));
];


//Note:tk:moved here from univariate.rep.
0 # Quotient(n_IsUniVar,m_IsUniVar)_(Degree(n) < Degree(m)) <-- 0;
1 # Quotient(n_IsUniVar,m_IsUniVar)_
    (n[1] = m[1] And Degree(n) >= Degree(m)) <--
[
    UniVariate(n[1],0,
               UniDivide(Concat(ZeroVector(n[2]),n[3]),
                         Concat(ZeroVector(m[2]),m[3]))[1]);
];

%/mathpiper


%mathpiper_docs,name="Quotient",categories="User Functions;Numbers (Operations)"
*CMD Quotient --- Determine quotient of two mathematical objects

*STD
*CALL
	Quotient(x,y)

*PARMS

{x}, {y} -- integers or univariate polynomials

*DESC

{Quotient} performs integer division. {Quotient} is also defined for polynomials.

If {Quotient(x,y)} returns "a" and {Modulo(x,y)} equals "b", then these numbers satisfy $x =a*y + b$ and $0 <= b < y$.

*E.G.

In> Quotient(5,3)
Result: 1;
In> Modulo(5,3)
Result: 2;

*SEE Gcd, Lcm, Modulo
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/CanonicalAdd.mpw0000644000175000017500000000221211371733712027453 0ustar  giovannigiovanni%mathpiper,def="CanonicalAdd"

// Canonicalise an expression so its terms are grouped to the right
// ie a+(b+(c+d))
// This doesn't preserve order of terms, when doing this would cause more
// subtractions and nested parentheses than necessary.
1 # CanonicalAdd((_a+_b)+_c) <-- CanonicalAdd(CanonicalAdd(a)+
                                              CanonicalAdd(CanonicalAdd(b)+
                                                           CanonicalAdd(c)));
1 # CanonicalAdd((_a-_b)+_c) <-- CanonicalAdd(CanonicalAdd(a)+
                                              CanonicalAdd(CanonicalAdd(c)-
                                                           CanonicalAdd(b)));
1 # CanonicalAdd((_a+_b)-_c) <-- CanonicalAdd(CanonicalAdd(a)+
                                              CanonicalAdd(CanonicalAdd(b)-
                                                           CanonicalAdd(c)));
1 # CanonicalAdd((_a-_b)-_c) <-- CanonicalAdd(CanonicalAdd(a)-
                                              CanonicalAdd(CanonicalAdd(b)+
                                                           CanonicalAdd(c)));
2 # CanonicalAdd(_a)         <-- a;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Gcd.mpw0000644000175000017500000000565411523200452025652 0ustar  giovannigiovanni%mathpiper,def="Gcd"

0 # Gcd(0,0) <-- 1;
1 # Gcd(0,_m) <-- Abs(m);
1 # Gcd(_n,0) <-- Abs(n);
1 # Gcd(_m,_m) <-- Abs(m);
2 # Gcd(_n,1) <-- 1;
2 # Gcd(1,_m) <-- 1;
2 # Gcd(n_IsInteger,m_IsInteger) <-- GcdN(n,m);
3 # Gcd(_n,_m)_(IsGaussianInteger(m) And IsGaussianInteger(n) )<-- GaussianGcd(n,m);

4 # Gcd(-(_n), (_m)) <-- Gcd(n,m);
4 # Gcd( (_n),-(_m)) <-- Gcd(n,m);
4 # Gcd(Sqrt(n_IsInteger),Sqrt(m_IsInteger)) <-- Sqrt(Gcd(n,m));
4 # Gcd(Sqrt(n_IsInteger),m_IsInteger) <-- Sqrt(Gcd(n,m^2));
4 # Gcd(n_IsInteger,Sqrt(m_IsInteger)) <-- Sqrt(Gcd(n^2,m));

5 # Gcd(n_IsRational,m_IsRational) <--
[
  Gcd(Numerator(n),Numerator(m))/Lcm(Denominator(n),Denominator(m));
];


10 # Gcd(list_IsList)_(Length(list)>2) <--
    [
      Local(first);
      first:=Gcd(list[1],list[2]);
      Gcd(first:Rest(Rest(list)));
    ];
14 # Gcd({0}) <-- 1;
15 # Gcd({_head}) <-- head;

20 # Gcd(list_IsList)_(Length(list)=2) <-- Gcd(list[1],list[2]);

30 # Gcd(n_CanBeUni,m_CanBeUni)_(Length(VarList(n*m))=1) <--
[
  Local(vars);
  vars:=VarList(n+m);
  NormalForm(Gcd(MakeUni(n,vars),MakeUni(m,vars)));
];

100 # Gcd(n_IsConstant,m_IsConstant) <-- 1;
110 # Gcd(_m,_n) <--
[
  Echo("Not simplified");
];


//Note:tk:moved here from univar.rep.
0 # Gcd(n_IsUniVar,m_IsUniVar)_
    (n[1] = m[1] And Degree(n) < Degree(m)) <-- Gcd(m,n);

1 # Gcd(nn_IsUniVar,mm_IsUniVar)_
    (nn[1] = mm[1] And Degree(nn) >= Degree(mm)) <--
[
   UniVariate(nn[1],0,
                UniGcd(Concat(ZeroVector(nn[2]),nn[3]),
                       Concat(ZeroVector(mm[2]),mm[3])));
];

%/mathpiper



%mathpiper_docs,name="Gcd",categories="User Functions;Numbers (Operations)"
*CMD Gcd --- greatest common divisor
*STD
*CALL
	Gcd(n,m)
	Gcd(list)

*PARMS

{n}, {m} -- integers or Gaussian integers or univariate polynomials

{list} -- a list of all integers or all univariate polynomials

*DESC

This function returns the greatest common divisor of "n" and "m".
The gcd is the largest number that divides "n" and "m".  It is
also known as the highest common factor (hcf).  The library code calls
{MathGcd}, which is an internal function.  This
function implements the "binary Euclidean algorithm" for determining the
greatest common divisor:

*HEAD	Routine for calculating {Gcd(n,m)}
	
*	1. if $n = m$ then return $n$
*	2. if both $n$ and $m$ are even then return $2*Gcd(n/2,m/2)$
*	3. if exactly one of $n$ or $m$ (say $n$) is even then return $Gcd(n/2,m)$
*	4. if both $n$ and $m$ are odd and, say, $n>m$ then return $Gcd((n-m)/2,m)$

This is a rather fast algorithm on computers that can efficiently shift
integers. When factoring Gaussian integers, a slower recursive algorithm is used.

If the second calling form is used, {Gcd} will
return the greatest common divisor of all the integers or polynomials
in "list". It uses the identity
$$Gcd(a,b,c) = Gcd(Gcd(a,b),c)$$.

*E.G.

In> Gcd(55,10)
Result: 5;
In> Gcd({60,24,120})
Result: 12;
In> Gcd( 7300 + 12*I, 2700 + 100*I)
Result: Complex(-4,4);


*SEE Lcm
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Object.mpw0000644000175000017500000000127211523200452026353 0ustar  giovannigiovanni%mathpiper,def="Object"

Rulebase("Object",{pred,x});
Rule("Object",2,0,Apply(pred,{x})=True) x;

%/mathpiper



%mathpiper_docs,name="Object",categories="User Functions;Variables"
*CMD Object --- create an incomplete type
*STD
*CALL
	Object("pred", exp)

*PARMS

{pred} -- name of the predicate to apply

{exp} -- expression on which "pred" should be applied

*DESC

This function returns "obj" as soon as "pred" returns {True} when applied on "obj". This is used to declare
so-called incomplete types.

*E.G.

In> a := Object("IsNumber", x);
Result: Object("IsNumber",x);
In> Eval(a);
Result: Object("IsNumber",x);
In> x := 5;
Result: 5;
In> Eval(a);
Result: 5;

*SEE IsNonObject
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Rem.mpw0000644000175000017500000000027011371733712025700 0ustar  giovannigiovanni%mathpiper,def="Rem"

//Note:tk:this was not listed in the def file.
0 # Rem(n_IsNumber,m_IsNumber) <-- n-m*Quotient(n,m);
30 # Rem(n_CanBeUni,m_CanBeUni) <-- Modulo(n,m);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/LnExpand.mpw0000644000175000017500000000250611523200452026657 0ustar  giovannigiovanni%mathpiper,def="LnExpand"

////////////////////// Log rules stuff //////////////////////

// LnExpand
1 # LnExpand(Ln(x_IsInteger))
                            <-- Add(Map({{n,m},m*Ln(n)},Transpose(Factors(x))));
1 # LnExpand(Ln(_a*_b))     <-- LnExpand(Ln(a))+LnExpand(Ln(b));
1 # LnExpand(Ln(_a/_b))     <-- LnExpand(Ln(a))-LnExpand(Ln(b));
1 # LnExpand(Ln(_a^_n))     <-- LnExpand(Ln(a))*n;
2 # LnExpand(_a)            <-- a;

%/mathpiper



%mathpiper_docs,name="LnExpand",categories="User Functions;Expression Simplification"
*CMD LnExpand --- expand a logarithmic expression using standard logarithm rules
*STD
*CALL
	LnExpand(expr)

*PARMS

{expr} -- the logarithm of an expression

*DESC

{LnExpand} takes an expression of the form $Ln(expr)$, and applies logarithm
rules to expand this into multiple {Ln} expressions where possible.  An
expression like $Ln(a*b^n)$ would be expanded to $Ln(a)+n*Ln(b)$.

If the logarithm of an integer is discovered, it is factorised using {Factors}
and expanded as though {LnExpand} had been given the factorised form.  So 
$Ln(18)$ goes to $Ln(x)+2*Ln(3)$.

*E.G.
In> LnExpand(Ln(a*b^n))
Result: Ln(a)+Ln(b)*n
In> LnExpand(Ln(a^m/b^n))
Result: Ln(a)*m-Ln(b)*n
In> LnExpand(Ln(60))
Result: 2*Ln(2)+Ln(3)+Ln(5)
In> LnExpand(Ln(60/25))
Result: 2*Ln(2)+Ln(3)-Ln(5)

*SEE Ln, LnCombine, Factors
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Floor.mpw0000644000175000017500000000300311523200452026220 0ustar  giovannigiovanni%mathpiper,def="Floor"

5 # Floor(Infinity) <-- Infinity;
5 # Floor(-Infinity) <-- -Infinity;
5 # Floor(Undefined) <-- Undefined;


10 # Floor(x_IsRationalOrNumber)
   <--
   [
     x:=N(Eval(x));
//Echo("x = ",x);
     Local(prec,result,n);
     Bind(prec,BuiltinPrecisionGet());
     If(IsZero(x),
       Bind(n,2),
       If(x>0,
         Bind(n,2+FloorN(N(FastLog(x)/FastLog(10)))),
         Bind(n,2+FloorN(N(FastLog(-x)/FastLog(10))))
       ));
     If(n>prec,BuiltinPrecisionSet(n));
//Echo("Before");
     Bind(result,FloorN(x));
//Echo("After");
     BuiltinPrecisionSet(prec);
     result;
   ];

//     FloorN(N(x));


//todo:tk:should this be removed because it is no longer needed?
/* Changed by Nobbi before redefinition of Rational
10 # Floor(x_IsNumber) <-- FloorN(x);
10 # Ceil (x_IsNumber) <-- CeilN (x);
10 # Round(x_IsNumber) <-- FloorN(x+0.5);

20 # Floor(x_IsRational) _ (IsNumber(Numerator(x)) And IsNumber(Denominator(x))) <-- FloorN(N(x));
20 # Ceil (x_IsRational) _ (IsNumber(Numerator(x)) And IsNumber(Denominator(x))) <-- CeilN (N(x));
20 # Round(x_IsRational) _ (IsNumber(Numerator(x)) And IsNumber(Denominator(x))) <-- FloorN(N(x+0.5));
*/

%/mathpiper



%mathpiper_docs,name="Floor",categories="User Functions;Numbers (Operations)"
*CMD Floor --- round a number downwards
*STD
*CALL
	Floor(x)

*PARMS

{x} -- a number

*DESC

This function returns $Floor(x)$, the largest integer smaller than or equal to $x$.

*E.G.

In> Floor(1.1)
Result: 1;
In> Floor(-1.1)
Result: -2;

*SEE Ceil, Round
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/stubs/Sign.mpw0000644000175000017500000000212011523200452026036 0ustar  giovannigiovanni%mathpiper,def="Sign"

10 # Sign(n_IsPositiveNumber) <-- 1;
10 # Sign(n_IsZero) <-- 0;
20 # Sign(n_IsNumber) <-- -1;
15 # Sign(n_IsInfinity)_(n < 0) <-- -1;
15 # Sign(n_IsInfinity)_(n > 0) <-- 1;
15 # Sign(n_IsNumber/m_IsNumber) <-- Sign(n)*Sign(m);
20 # Sign(n_IsList) <-- MapSingle("Sign",n);

100 # Sign(_a)^n_IsEven <-- 1;
100 # Sign(_a)^n_IsOdd <-- Sign(a);

%/mathpiper



%mathpiper_docs,name="Sign",categories="User Functions;Calculus Related (Symbolic)"
*CMD Sign --- sign of a number
*STD
*CALL
	Sign(x)

*PARMS

{x} -- argument to the function

*DESC

This function returns the sign of the real number $x$. It is "1"
for positive numbers and "-1" for negative numbers. Somewhat
arbitrarily, {Sign(0)} is defined to be 1.

This function is connected to the {Abs} function by
the identity $Abs(x) * Sign(x) = x$ for real $x$.

This function is threaded, meaning that if the argument {x} is a
list, the function is applied to all entries in the list.

*E.G.

In> Sign(2)
Result: 1;
In> Sign(-3)
Result: -1;
In> Sign(0)
Result: 1;
In> Sign(-3) * Abs(-3)
Result: -3;

*SEE Arg, Abs
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/0000755000175000017500000000000011722677334025466 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/ForEach.mpw0000644000175000017500000000407211523200452027503 0ustar  giovannigiovanni%mathpiper,def="ForEach"

//Retract("ForEach" , *);

/*TODO remove? Not yet. If the code above (ForEachExperimental) can be made to work we can do away with this version. */
TemplateFunction("ForEach",{item,listOrString,body})
[
  If(And(IsEqual(IsGeneric(listOrString),True),
         IsEqual(GenericTypeName(listOrString),"Array")
         ),
    `ForEachInArray(@item,listOrString,@body),
    [

      MacroLocal(item);
      
      If(IsString(listOrString),
      [
          
          Local(index, stringLength);
          
          stringLength := Length(listOrString);
          
          index := 1;
          While(index <= stringLength )
          [
             MacroBind(item,listOrString[index] );
             
             Eval(body);
             
             index++;
          ];

      ],
      [
          Local(foreachtail);
          Bind(foreachtail,listOrString);
          While(Not(IsEqual(foreachtail,{})))
          [
            MacroBind(item,First(foreachtail));
            Eval(body);
            Bind(foreachtail,Rest(foreachtail));
          ];
      ]);
    ]);
];
UnFence("ForEach",3);
HoldArgumentNumber("ForEach",3,1);
HoldArgumentNumber("ForEach",3,3);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="ForEach",categories="User Functions;Control Flow"
*CMD ForEach --- loop over all entries in a list or a string
*STD
*CALL
	ForEach(var, list_or_string) body

*PARMS

{var} -- looping variable

{list} -- list of values or string of characters to assign to "var"

{body} -- expression to evaluate with different values of "var"

*DESC

The expression "body" is evaluated multiple times. The first time,
"var" has the value of the first element of "list" or the first
character in "string", then it gets
the value of the second element and so on. {ForEach}
returns {True}.

*E.G. notest

In> ForEach(i,{2,3,5,7,11}) Echo({i, i!});
2  2
3  6
5  120
7  5040
11  39916800
Result: True;


In> ForEach(i,"Hello") Echo(i)
Result: True
Side Effects:
H
e
l
l
o

*SEE For, While, Until, Break, Continue
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/ForEachExperimental.mpw0000644000175000017500000000256111331203122032054 0ustar  giovannigiovanni%mathpiper,def="",public="todo"

/*
 * TODO This was an experiment to try to get to using a new ForEach that works the
 * same on lists and arrays. For some odd reason all sorts of places in the scripts
 * break if we use this version of ForEach. We need to look into this still! I want
 * a ForEach that works on lists as well as arrays.

Macro()(ForEachRest(i,L,B));

LocalSymbols(foreachtail)
[
  10 # ForEachRest(_i,L_IsFunction,_B) <--
  [
    Local(foreachtail);
    Local(@i);
    Bind(foreachtail,@L);
    While(Not(IsEqual(foreachtail,{})))
    [
      Bind(@i,First(foreachtail));
      @B;
      Bind(foreachtail,Rest(foreachtail));
    ];
  ];
];

LocalSymbols(index,nr)
[
  20 # ForEachRest(_i,_A,_B)_(   And(
            IsEqual(IsGeneric(A),True),
            IsEqual(GenericTypeName(A),"Array")
            )) <--
  [
    Local(index,nr);
    Local(@i);
    Bind(index,1);
    Bind(nr,Length(@A));
    While(index<=nr)
    [
      Bind(@i,(@A)[index]);
      @B;
      Bind(index,AddN(index,1));
    ];
  ];
];

Macro()(ForEach(i,L)(B));

LocalSymbols(itm,lst,bd)
[
  (ForEach(_i,_L)(_B)) <--
  [
    Local(itm,lst,bd);
//CurrentFile(),CurrentLine(),,Hold(@B)
//Echo(CurrentFile(),CurrentLine());
// Echo("ForEach(",Hold(@i),", ",Hold(@L),", ) ");
    itm:=Hold(@i);
    lst:= (@L);
    bd:=Hold(@B);
//Echo("1...",itm);
    `ForEachRest(@itm,@lst,@bd);
  ];
];
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/Lambda.mpw0000644000175000017500000000242511422223770027362 0ustar  giovannigiovanni%mathpiper,def="Lambda"

/* Lambda was introduced as a form of pure function that can be passed on to the function Apply as a first argument.
 * The original method, passing it in as a list, had the disadvantage that the list was evaluated, which caused the
 * arguments to be evaluated too. This resulted in unwanted behaviour sometimes (expressions being prematurely evaluated
 * in the body of the pure function). The arguments to Lambda are not evaluated.
 */
DefMacroRulebase("Lambda",{args,body});

%/mathpiper




%mathpiper_docs,name="Lambda",categories="User Functions;Control Flow"
*CMD Lambda --- a form of pure function that can be passed to functions like Apply and Select
*STD
*CALL
	Lambda(arglist, function body)

*PARMS

{arglist} -- list of arguments

*DESC

Lambda functions are unnamed pure functions which can be used in places where a small function
is needed and creating a normal function is either inconvenient or impossible.

*E.G.
In>  Apply(Lambda({x,y}, x-y^2), {Cos(a), Sin(a)});
Result: Cos(a)-Sin(a)^2

In>  Lambda({x,y}, x-y^2) @ {Cos(a), Sin(a)}
Result: Cos(a)-Sin(a)^2


/%mathpiper

list := {1,-3,2,-6,-4,3};

Select(list, Lambda({i}, i > 0 ));

/%/mathpiper

    /%output,preserve="false"
      Result: {1,2,3}
.   /%/output

*SEE Apply, @, Select
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/else.mpw0000644000175000017500000000162211321744335027133 0ustar  giovannigiovanni%mathpiper,def="else"

Rulebase("else",{ifthen,otherwise});

0 # (if (_predicate) _body else _otherwise)_(Eval(predicate) = True) <-- Eval(body);

0 # (if (_predicate) _body else _otherwise)_(Eval(predicate) = False) <-- Eval(otherwise);

1 # (if (_predicate) _body else _otherwise) <--
    ListToFunction({ToAtom("else"),
            ListToFunction({ToAtom("if"), (Eval(predicate)), body}),
            otherwise});

HoldArgument("else",ifthen);

HoldArgument("else",otherwise);

UnFence("else",2);

%/mathpiper




%mathpiper_docs,name="else",categories="User Functions;Control Flow"
*CMD else --- branch point
*STD
*CALL
    if(predicate) body else otherwise)

*PARMS

{predicate} -- predicate to test

{body} -- expression to evaluate if the predicate is {True}.

{otherwise} -- expression to evaluate if the predicate if {False}.

*DESC

(This description under in development.)


*SEE If, if
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/Until.mpw0000644000175000017500000000322411523200452027265 0ustar  giovannigiovanni%mathpiper,def="Until"

TemplateFunction("Until",{predicate,body})
[
  Eval(body);
  While (IsEqual(Eval(predicate),False))
  [
    Eval(body);
  ];
  True;
];
UnFence("Until",2);
HoldArgumentNumber("Until",2,1);
HoldArgumentNumber("Until",2,2);

%/mathpiper



%mathpiper_docs,name="Until",categories="User Functions;Control Flow"
*CMD Until --- loop until a condition is met
*STD
*CALL
	Until(pred) body

*PARMS

{pred} -- predicate deciding whether to stop

{body} -- expression to loop over

*DESC

Keep on evaluating "body" until "pred" becomes {True}. More precisely, {Until} first
evaluates the expression "body". Then the predicate "pred" is
evaluated, which should yield either {True} or {False}. In the latter case, the expressions "body"
and "pred" are again evaluated and this continues as long as
"pred" is {False}. As soon as "pred" yields {True}, the loop terminates and {Until} returns {True}.

The main difference with {While} is that {Until} always evaluates the body at least once, but {While} may not evaluate the body at all. Besides, the
meaning of the predicate is reversed: {While} stops
if "pred" is {False} while {Until} stops if "pred" is {True}.
The command
{Until(pred) body;} is equivalent to {pred; While(Not pred) body;}. In fact, the
implementation of {Until} is based on the internal
command {While}. The {Until}
command can be compared to the {do ... while}
construct in the programming language C.

*E.G. notest

In> x := 0;
Result: 0;
In> Until (x! > 10^6) \
	  [ Echo({x, x!}); x++; ];
	 0  1
	 1  1
	 2  2
	 3  6
	 4  24
	 5  120
	 6  720
	 7  5040
	 8  40320
	 9  362880
Result: True;

*SEE While, For, ForEach, Break, Continue
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/ForEachInArray.mpw0000644000175000017500000000065711371733712031011 0ustar  giovannigiovanni%mathpiper,def="ForEachInArray"

LocalSymbols(i,nr)
[
  TemplateFunction("ForEachInArray",{item,list,body})
  [
    Local(i,nr);
    MacroLocal(item);
    Bind(i,1);
    Bind(nr,Length(list));
    While(i<=nr)
    [
      MacroBind(item,list[i]);
      Eval(body);
      Bind(i,AddN(i,1));
    ];
  ];
];

UnFence("ForEachInArray",3);
HoldArgumentNumber("ForEachInArray",3,1);
HoldArgumentNumber("ForEachInArray",3,3);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/For.mpw0000644000175000017500000000307011523200452026717 0ustar  giovannigiovanni%mathpiper,def="For"

/* Defining a For function */
TemplateFunction("For",{start,predicate,increment,body})
[
  Eval(start);
  While (IsEqual(Eval(predicate),True))
  [
    Eval(body);
    Eval(increment);
  ];
];
UnFence("For",4);
HoldArgumentNumber("For",4,1);
HoldArgumentNumber("For",4,2);
HoldArgumentNumber("For",4,3);
HoldArgumentNumber("For",4,4);

%/mathpiper



%mathpiper_docs,name="For",categories="User Functions;Control Flow"
*CMD For --- C-style {for} loop
*STD
*CALL
	For(init, pred, incr) body

*PARMS

{init} -- expression for performing the initialization

{pred} -- predicate deciding whether to continue the loop

{incr} -- expression to increment the counter

{body} -- expression to loop over

*DESC

This commands implements a C style {for} loop. First
of all, the expression "init" is evaluated. Then the predicate
"pred" is evaluated, which should return {True} or
{False}. Next the loop is executed as long as the
predicate yields {True}. One traversal of the loop
consists of the subsequent evaluations of "body", "incr", and
"pred". Finally, the value {True} is returned.

This command is most often used in a form such as {For(i=1, i<=10, i++) body}, which evaluates {body} with
{i} subsequently set to 1, 2, 3, 4, 5, 6, 7, 8, 9,
and 10.

The expression {For(init, pred, incr) body} is
equivalent to {init; While(pred) [body; incr;]}.

*E.G. notest

In> For (i:=1, i<=10, i++) Echo({i, i!});
	 1  1
	 2  2
	 3  6
	 4  24
	 5  120
	 6  720
	 7  5040
	 8  40320
	 9  362880
	 10  3628800
Result: True;

*SEE While, Until, ForEach, Break, Continue
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/contolflow/if.mpw0000644000175000017500000000070511321744335026602 0ustar  giovannigiovanni%mathpiper,def="if"

Rulebase("if",{predicate,body});

(if(True) _body) <-- Eval(body);

HoldArgument("if",body);

UnFence("if",2);

%/mathpiper




%mathpiper_docs,name="if",categories="User Functions;Control Flow"
*CMD if --- branch point
*STD
*CALL
    if(predicate)body

*PARMS

{predicate} -- predicate to test

{body} -- expression to evaluate if the predicate is true

*DESC

(This description is in development.)


*SEE If, else
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/0000755000175000017500000000000011722677334026327 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdopers/0000755000175000017500000000000011722677334030172 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdopers/stdopers.mpw0000644000175000017500000000472411321243474032556 0ustar  giovannigiovanni%mathpiper,def=""


/* stdopers is loaded immediately after MathPiper is started. It contains
 * the definitions of the infix operators, so the parser can already
 * parse expressions containing these operators, even though the
 * function hasn't been defined yet.
 */

Infix("=",90);
Infix("And",1000);
RightAssociativeSet("And");
Infix("Or", 1010);
Prefix("Not", 100);
Infix("<",90);
Infix(">",90);
Infix("<=",90);
Infix(">=",90);
Infix("!=",90);

Infix(":=",10000);
RightAssociativeSet(":=");

Infix("+",70);
Infix("-",70);
RightPrecedenceSet("-",40);
Infix("/",30);
Infix("*",40);
Infix("^",20);
LeftPrecedenceSet("^",19); //Added to make expressions like x^n^2 unambiguous.
RightAssociativeSet("^");
Prefix("+",50);
Prefix("-",50);
RightPrecedenceSet("-",40);
Bodied("For",60000);
Bodied("Until",60000);
Postfix("++",5);
Postfix("--",5);
Bodied("ForEach",60000);
Infix("<<",10);
Infix(">>",10);
Bodied("Differentiate",60000);
Bodied("Deriv",60000);
Infix("X",30);
Infix(".",30);
Infix("o",30);
Postfix("!", 30);
Postfix("!!", 30);
Infix("***", 50);
Bodied("Integrate",60000);

Bodied("Limit",60000);

Bodied("EchoTime", 60000);

Bodied("Repeat", 60000);

Infix("->",600);

/* functional operators */
Infix(":",70);
RightAssociativeSet(":");
Infix("@",600);
Infix("/@",600);
Infix("..",600);

Bodied("Taylor",60000);
Bodied("Taylor1",60000);
Bodied("Taylor2",60000);
Bodied("Taylor3",60000);
Bodied("InverseTaylor",60000);

Infix("<--",10000);
Infix("#",9900);

Bodied("TSum",60000);
Bodied("TExplicitSum",60000);
Bodied("TD",5);  /* Tell the MathPiper interpreter that TD is to be used as TD(i)f */

/* Operator to be used for non-evaluating comparisons */
Infix("==",90);
Infix("!==",90);

/* Operators needed for propositional logic theorem prover */
Infix("=>",10000); /* implication, read as 'implies' */


Bodied("if",5);
Infix("else",60000);
RightAssociativeSet("else");
/* Bitwise operations we REALLY need. Perhaps we should define them
   also as MathPiper operators?
 */
Infix("&",50);
Infix("|",50);
Infix("%",50);

/* local pattern replacement operators */
Infix("/:",20000);
Infix("/::",20000);
Infix("<-",10000);

/* Operators used for manual layout */
Infix("<>", PrecedenceGet("="));
Infix("<=>", PrecedenceGet("="));

/* Operators for Solve: Where and AddTo */
Infix("Where", 11000);
Infix("AddTo", 2000);

Bodied("Function",60000);
Bodied("Macro",60000);

Bodied(Assert, 60000);

// Defining very simple functions, in scripts that can be converted to plugin.
Bodied("Defun",0);




%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/0000755000175000017500000000000011722677334030127 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/equals_equals_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/equals_equals_opera0000644000175000017500000000075311321250634034072 0ustar  giovannigiovanni%mathpiper,def="=="

Rulebase("==",{left,right});

%/mathpiper




%mathpiper_docs,name="==",categories="Operators"
*CMD == --- symbolic equality operator
*STD
*CALL
    expression == expression

*PARMS

{expression} -- an expression

*DESC

This operator is used to symbolically represent the equality
of two expressions as opposed to the = operator which performs
a comparison operation on two expressions.

*E.G.

In> Solve(y == m*x + b, x)
Result: {x==(y-b)/m}

*SEE !==
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/NormalForm.mpw0000644000175000017500000000063411321250634032714 0ustar  giovannigiovanni%mathpiper,def="NormalForm"

Rulebase("NormalForm",{expression});
Rule("NormalForm",1,1000,True) expression;

%/mathpiper




%mathpiper_docs,name="NormalForm",categories="User Functions;Lists (Operations)"
*CMD NormalForm --- return expression in normal form
*STD
*CALL
	NormalForm(expression)

*PARMS

{expression} -- an expression

*DESC

This function returns an expression in normal form.


%/mathpiper_docs././@LongLink0000000000000000000000000000015300000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/vertical_bar_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/vertical_bar_operat0000644000175000017500000000057311316266467034066 0ustar  giovannigiovanni%mathpiper,def="|"

a_IsNonNegativeInteger | b_IsNonNegativeInteger <-- BitOr(a,b);

%/mathpiper




%mathpiper_docs,name="|",categories="Operators"
*CMD  --- bitwise OR operator
*STD
*CALL
    a | b

*PARMS

{a} -- non negative integer

{b} -- non negative integer

*DESC

This operator performs a bitwise OR on two integers.

*E.G.

In> 3 | 4
Result: 7

*SEE &
%/mathpiper_docs././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/minus_minus_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/minus_minus_operato0000644000175000017500000000106711440575336034151 0ustar  giovannigiovanni%mathpiper,def="--"

Function("--",{aVar})
[
   MacroBind(aVar,SubtractN(Eval(aVar),1));

   Eval(aVar);
];

UnFence("--",1);

HoldArgument("--",aVar);

%/mathpiper




%mathpiper_docs,name="--",categories="Operators"
*CMD -- --- decrement variable
*STD
*CALL
	var--

*PARMS

{var} -- variable to decrement

*DESC

The variable with name "var" is decremented, i.e. the number 1 is
subtracted from it. The expression {x--} is
equivalent to the assignment {x := x - 1}.

*E.G.
In> x := 5;
Result: 5;

In> x--;
Result: 4;

In> x;
Result: 4;

*SEE ++, :=
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/IsNonObject.mpw0000644000175000017500000000101311316266467033024 0ustar  giovannigiovanni%mathpiper,def="IsNonObject"

10 # IsNonObject(Object(_x)) <-- False;
20 # IsNonObject(_x)         <-- True;

%/mathpiper





%mathpiper_docs,name="IsNonObject",categories="User Functions;Predicates"
*CMD IsNonObject --- test whether argument is not an {Object()}
*STD
*CALL
	IsNonObject(expr)

*PARMS

{expr} -- the expression to examine

*DESC

This function returns {True} if "expr" is not of
the form {Object(...)} and {False}
otherwise.

*HEAD Bugs

In fact, the result is always {True}.

*SEE Object
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/ArgumentsCount.mpw0000644000175000017500000000123511523200452033611 0ustar  giovannigiovanni%mathpiper,def="ArgumentsCount"

Function("ArgumentsCount",{aLeft}) Length(FunctionToList(aLeft))-1;

%/mathpiper




%mathpiper_docs,name="ArgumentsCount",categories="Programmer Functions;Programming"
*CMD ArgumentsCount --- return number of top-level arguments
*STD
*CALL
	ArgumentsCount(expr)

*PARMS

{expr} -- expression to examine

*DESC

This function evaluates to the number of top-level arguments of the
expression "expr". The argument "expr" may not be an atom, since
that would lead to an error.

*E.G.

In> ArgumentsCount(f(a,b,c))
Result: 3;
In> ArgumentsCount(Sin(x));
Result: 1;
In> ArgumentsCount(a*(b+c));
Result: 2;

*SEE Type, Length
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/Numerator.mpw0000644000175000017500000000152311523200452032607 0ustar  giovannigiovanni%mathpiper,def="Numerator"

//Retract("Numerator",*);

1 # Numerator(_x / _y)      <-- x;
1 # Numerator(-_x/ _y)      <-- -x;
2 # Numerator(x_IsNumber)   <-- x;

%/mathpiper

 



%mathpiper_docs,name="Numerator",categories="User Functions;Numbers (Operations)"
*CMD Numerator --- numerator of an expression
*STD
*CALL
	Numerator(expr)

*PARMS

{expr} -- expression to determine numerator of

*DESC

This function determines the numerator of the rational expression
"expr" and returns it. As a special case, if its argument is numeric
but not rational, it returns this number. If "expr" is neither
rational nor numeric, the function returns unevaluated.

*E.G.

In> Numerator(2/7)
Result: 2;
In> Numerator(a / x^2)
Result: a;
In> Numerator(-a / x^2)
Result: -a;
In> Numerator(5)
Result: 5;

*SEE Denominator, IsRational, IsNumber
%/mathpiper_docs




././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/plus_plus_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/plus_plus_operator.0000644000175000017500000000105311440575336034064 0ustar  giovannigiovanni%mathpiper,def="++"

Function("++",{aVar})
[
   MacroBind(aVar,AddN(Eval(aVar),1));

   Eval(aVar);
];

UnFence("++",1);

HoldArgument("++",aVar);

%/mathpiper




%mathpiper_docs,name="++",categories="Operators"
*CMD ++ --- increment variable
*STD
*CALL
	var++

*PARMS

{var} -- variable to increment

*DESC

The variable with name "var" is incremented, i.e. the number 1 is
added to it. The expression {x++} is equivalent to
the assignment {x := x + 1}.

*E.G.
In> x := 5;
Result: 5;

In> x++;
Result: 6;

In> x;
Result: 6;

*SEE --, :=
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/numeric.mpw0000644000175000017500000001226011522212340032273 0ustar  giovannigiovanni%mathpiper,def="N;NonN;InNumericMode"

//"+-;/-;*-;^-;:=-;:=+" These were in the def list.

/* See the documentation on the assignment of the precedence of the rules.
 */

/* Some very basic functions that are used always any way... */

/* Implementation of numeric mode */

//Retract("N",*);

LocalSymbols(numericMode)
[

  numericMode := False;

  // N function: evaluate numerically with given precision.
  LocalSymbols(previousNumericMode, previousPrecision, numericResult) 
  Macro("N",{expression, precision})
  [
    //If(InVerboseMode(),
    //    [Tell("N",{expression,precision}); Tell("  ",{@expression,@precision});]
    //);
    
    // we were in non-numeric mode
    Local(previousNumericMode, previousPrecision, numericResult, exception);

    previousPrecision := BuiltinPrecisionGet();
    //If(InVerboseMode(),Tell("  ",previousPrecision));
    BuiltinPrecisionSet(@precision+5);

    AssignCachedConstantsN();

    previousNumericMode := numericMode;
    numericMode         := True;
    exception         := False;

    //ExceptionCatch(Bind(numericResult, Eval(@expression)),Bind(exception,ExceptionGet()));

    ExceptionCatch( numericResult:=Eval(@expression), exception := ExceptionGet() );
    //If(InVerboseMode(),Tell("  1",numericResult));

    If(IsDecimal(numericResult), numericResult := RoundToN(numericResult, @precision));
    //If(InVerboseMode(),Tell("  2",numericResult));

    numericMode := previousNumericMode;

    If(Not numericMode, [ ClearCachedConstantsN(); ] );

    BuiltinPrecisionSet(previousPrecision);

    Check(exception = False, exception["type"], exception["message"]);

    numericResult;

  ];




  // N function: evaluate numerically with default precision.
  LocalSymbols(precision,heldExpression) 
  Macro("N",{expression})
  [
     Local(precision, heldExpression);
     precision      :=  BuiltinPrecisionGet();
     heldExpression :=  Hold(@expression);

     `N(@heldExpression, @precision);
  ];

  
  // NoN function.
  LocalSymbols(result) 
  Macro("NonN",{expression})
  [
    Local(result);
    GlobalPush(numericMode);
    numericMode := False;
    result      := (@expression);
    numericMode := GlobalPop();
    result;
  ];


  // InNumericMode function.
  Function("InNumericMode",{}) numericMode;

]; //LocalSymbols(numericMode)

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

   





%mathpiper_docs,name="N",categories="User Functions;Numbers (Operations)"
*CMD N --- try to determine an numerical approximation of expression

*CALL
	N(expression)
	N(expression, precision)
*PARMS

{expression} -- expression to evaluate

{precision} -- integer, precision to use

*DESC

The function {N} instructs {MathPiper} to try to coerce an expression in to a numerical approximation to the
expression {expr}, using {prec} digits precision if the second calling
sequence is used, and the default precision otherwise. This overrides the normal
behaviour, in which expressions are kept in symbolic form (eg. {Sqrt(2)} instead of {1.41421}).

Application of the {N} operator will make MathPiper
calculate floating point representations of functions whenever
possible. In addition, the variable {Pi} is bound to
the value of $Pi$ calculated at the current precision.
(This value is a "cached constant", so it is not recalculated each time {N} is used, unless the precision is increased.)


{N} is a macro. Its argument {expr} will only
be evaluated after switching to numeric mode.

*E.G.
In> 1/2
Result: 1/2;
In> N(1/2)
Result: 0.5;
In> Sin(1)
Result: Sin(1);
In> N(Sin(1),10)
Result: 0.8414709848;
In> Pi
Result: Pi;
In> N(Pi,20)
Result: 3.1415926535897932385

*SEE Pi, InNumericMode, NonN
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output




%mathpiper_docs,name="InNumericMode",categories="User Functions;Predicates"
*CMD InNumericMode --- determine if currently in numeric mode

*CALL
	InNumericMode()

*DESC

When in numeric mode, {InNumericMode()} will return {True}, else it will
return {False}. {MathPiper} is in numeric mode when evaluating an expression
with the function {N}. Thus when calling {N(expr)}, {InNumericMode()} will
return {True} while {expr} is being evaluated.

{InNumericMode()} would typically be used to define a transformation rule
that defines how to get a numeric approximation of some expression. One
could define a transformation rule

	f(_x)_InNumericMode() <- [... some code to get a numeric approximation of f(x) ... ];

{InNumericMode()} usually returns {False}, so transformation rules that check for this
predicate are usually left alone.


*E.G.
In> InNumericMode()
Result: False
In> N(InNumericMode())
Result: True

*SEE N, BuiltinPrecisionSet, BuiltinPrecisionGet, Pi, CachedConstant
%/mathpiper_docs





%mathpiper_docs,name="NonN",categories="User Functions;Numbers (Operations)"
*CMD NonN --- calculate part in non-numeric mode

*CALL
	NonN(expr)

*PARMS
{expr} -- expression to evaluate

*DESC
When in numeric mode, {NonN} can be called to switch back to non-numeric
mode temporarily.

{NonN} is a macro. Its argument {expr} will only
be evaluated after the numeric mode has been set appropriately.

*E.G.
In> N(NonN(InNumericMode()))
Result: False

*SEE N, BuiltinPrecisionSet, BuiltinPrecisionGet, Pi, CachedConstant
%/mathpiper_docs
././@LongLink0000000000000000000000000000017500000000000011570 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/exclamationpoint_equals_equals_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/exclamationpoint_eq0000644000175000017500000000067511321250634034106 0ustar  giovannigiovanni%mathpiper,def="!=="

Rulebase("!==",{left,right});

%/mathpiper




%mathpiper_docs,name="!==",categories="Operators"
*CMD !== --- symbolic inequality operator
*STD
*CALL
    expression !== expression

*PARMS

{expression} -- an expression

*DESC

This operator is used to symbolically represent the inequality
of two expressions as opposed to the != operator which performs
a comparison operation on two expressions.


*SEE ==
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/Denominator.mpw0000644000175000017500000000154611523200452033117 0ustar  giovannigiovanni%mathpiper,def="Denominator"

//Retract("Denominator",*);

1 # Denominator(_x / _y)      <-- y;
1 # Denominator(-_x/ _y)      <-- y;
2 # Denominator(x_IsNumber)   <-- 1;

%/mathpiper

 


%mathpiper_docs,name="Denominator",categories="User Functions;Numbers (Operations)"
*CMD Denominator --- denominator of an expression
*STD
*CALL
	Denominator(expr)

*PARMS

{expr} -- expression to determine denominator of

*DESC

This function determines the denominator of the rational expression
"expr" and returns it. As a special case, if its argument is numeric
but not rational, it returns {1}. If "expr" is
neither rational nor numeric, the function returns unevaluated.

*E.G.

In> Denominator(2/7)
Result: 7;
In> Denominator(a / x^2)
Result: x^2;
In> Denominator(-a / x^2)
Result: x^2
In> Denominator(5)
Result: 1;

*SEE Numerator, IsRational, IsNumber
%/mathpiper_docs



././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/ampersand_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/ampersand_operator.0000644000175000017500000000057711316266467034026 0ustar  giovannigiovanni%mathpiper,def="&"

a_IsNonNegativeInteger & b_IsNonNegativeInteger <-- BitAnd(a,b);

%/mathpiper




%mathpiper_docs,name="&",categories="Operators"
*CMD  --- bitwise AND operator
*STD
*CALL
    a & b

*PARMS

{a} -- non negative integer

{b} -- non negative integer

*DESC

This operator performs a bitwise AND on two integers.

*E.G.

In> 15 & 4
Result: 4

*SEE |
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/A_Nth.mpw0000644000175000017500000000345411523200452031631 0ustar  giovannigiovanni%mathpiper,def="Nth"

/* Implementation of Nth that allows extending. */
Rulebase("Nth",{alist,aindex});
Rule("Nth",2,10,
    And(IsEqual(IsFunction(alist),True),
            IsEqual(IsInteger(aindex),True),
            Not(IsEqual(First(FunctionToList(alist)),Nth))
            ))
     MathNth(alist,aindex);




Rule("Nth",2,14,
     And(IsEqual(IsString(alist),True),IsList(aindex))
    )
[
  Local(result);
  result:="";
  ForEach(i,aindex) [ result := result : StringMidGet(i,1,alist); ];
  result;
];

Rule("Nth",2,15,IsEqual(IsString(alist),True))
[
  StringMidGet(aindex,1,alist);
];


Rule("Nth",2,20,IsEqual(IsList(aindex),True))
[
  Map({{ii},alist[ii]},{aindex});
];

Rule("Nth",2,30,
   And(
           IsEqual(IsGeneric(alist),True),
           IsEqual(GenericTypeName(alist),"Array"),
           IsEqual(IsInteger(aindex),True)
          )
    )
[
  ArrayGet(alist,aindex);
];



Rule("Nth",2,40,IsEqual(IsString(aindex),True))
[
  Local(as);
  as := Assoc(aindex,alist);
  If (Not(IsEqual(as,Empty)),Bind(as,Nth(as,2)));
  as;
];


%/mathpiper



%mathpiper_docs,name="Nth",categories="User Functions;Lists (Operations)"
*CMD Nth --- return the $n$-th element of a list
*CORE
*CALL
	Nth(list, n)

*PARMS

{list} -- list to choose from

{n} -- index of entry to pick

*DESC

The entry with index "n" from "list" is returned. The first entry
has index 1. It is possible to pick several entries of the list by
taking "n" to be a list of indices.

More generally, {Nth} returns the n-th operand of the
expression passed as first argument.

An alternative but equivalent form of {Nth(list, n)} is
{list[n]}.

*E.G.

In> lst := {a,b,c,13,19};
Result: {a,b,c,13,19};
In> Nth(lst, 3);
Result: c;
In> lst[3];
Result: c;
In> Nth(lst, {3,4,1});
Result: {c,13,a};
In> Nth(b*(a+c), 2);
Result: a+c;

*SEE Select, Nth
%/mathpiper_docs././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/percent_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/standard/percent_operator.mp0000644000175000017500000000057711320776303034037 0ustar  giovannigiovanni%mathpiper,def="%"

a_IsNonNegativeInteger % b_IsPositiveInteger <-- Modulo(a,b);

%/mathpiper




%mathpiper_docs,name="%_v1",categories="Operators"
*CMD  % --- modulus operator
*STD
*CALL
    a % b

*PARMS

{a} -- non negative integer

{b} -- non negative integer

*DESC

Divides a by b and returns the remainder of the division.

*E.G.
In> 8 % 5
Result: 3

*SEE /
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/0000755000175000017500000000000011722677334030151 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/asterisk_operator.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/asterisk_operator.m0000644000175000017500000000624111551612545034063 0ustar  giovannigiovanni%mathpiper,def="*"

/* Multiplication */

50  # x_IsNumber * y_IsNumber <-- MultiplyN(x,y);
100 #  1  * _x  <-- x;
100 # _x  *  1  <-- x;
100 # (_f  * _x)_(f= -1)  <-- -x;
100 # (_x  * _f)_(f= -1)  <-- -x;
105 # (f_IsNegativeNumber * _x)  <-- -(-f)*x;
105 # (_x * f_IsNegativeNumber)  <-- -(-f)*x;

95 # x_IsMatrix * y_IsMatrix <--
[
   Local(i,j,k,row,result);
   result:=ZeroMatrix(Length(x),Length(y[1]));
   For(i:=1,i<=Length(x),i++)
   For(j:=1,j<=Length(y),j++)
   For(k:=1,k<=Length(y[1]),k++)
   [
     row:=result[i];
     row[k]:= row[k]+x[i][j]*y[j][k];
   ];
   result;
];


96 # x_IsMatrix * y_IsList <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(x),i++)
   [ DestructiveInsert(result,i,Dot(x[i], y)); ];
   result;
];


97 # (x_IsList * y_IsNonObject)_Not(IsList(y)) <-- y*x;
98 # (x_IsNonObject * y_IsList)_Not(IsList(x)) <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(y),i++)
   [ DestructiveInsert(result,i,x * y[i]); ];
   result;
];


50  # _x * Undefined <-- Undefined;
50  # Undefined * _y <-- Undefined;


100  # 0 * y_IsInfinity <-- Undefined;
100  # x_IsInfinity * 0 <-- Undefined;

101 # 0    * (_x) <-- 0;
101 # (_x) *    0 <-- 0;

100 # x_IsNumber * (y_IsNumber * _z) <-- (x*y)*z;
100 # x_IsNumber * (_y * z_IsNumber) <-- (x*z)*y;

100 # (_x * _y) * _y <-- x * y^2;
100 # (_x * _y) * _x <-- y * x^2;
100 # _y * (_x * _y) <-- x * y^2;
100 # _x * (_x * _y) <-- y * x^2;
100 # _x * (_y / _z) <-- (x*y)/z;
// fractions
100 # (_y / _z) * _x <-- (x*y)/z;
100 # (_x * y_IsNumber)_Not(IsNumber(x)) <-- y*x;

100 # (_x) * (_x) ^ (n_IsConstant) <-- x^(n+1);
100 # (_x) ^ (n_IsConstant) * (_x) <-- x^(n+1);
100 # (_x * _y)* _x ^ n_IsConstant <-- y * x^(n+1);
100 # (_y * _x)* _x ^ n_IsConstant <-- y * x^(n+1);
100 # Sqrt(_x) * (_x) ^ (n_IsConstant) <-- x^(n+1/2);
100 # (_x) ^ (n_IsConstant) * Sqrt(_x) <-- x^(n+1/2);
100 # Sqrt(_x) * (_x) <-- x^(3/2);
100 # (_x) * Sqrt(_x) <-- x^(3/2);

105 # x_IsNumber * -(_y) <-- (-x)*y;
105 # (-(_x)) * (y_IsNumber) <-- (-y)*x;

106 # _x * -(_y) <-- -(x*y);
106 # (- _x) * _y <-- -(x*y);

107 # -( (-(_x))/(_y)) <-- x/y;
107 # -( (_x)/(-(_y))) <-- x/y;


250  # x_IsNumber * y_IsInfinity <-- Sign(x)*y;
250  # x_IsInfinity * y_IsNumber <-- Sign(y)*x;


/* Note: this rule MUST be past all the transformations on
 * matrices, since they are lists also.
 */
230 # (aLeft_IsList * aRight_IsList)_(Length(aLeft)=Length(aRight)) <--
	 Map("*",{aLeft,aRight});
// fractions
242 # (x_IsInteger / y_IsInteger) * (v_IsInteger / w_IsInteger) <-- (x*v)/(y*w);
243 #  x_IsInteger * (y_IsInteger / z_IsInteger) <--  (x*y)/z;
243 #  (y_IsInteger / z_IsInteger) * x_IsInteger <--  (x*y)/z;

400 # (_x) * (_x) <-- x^2;

%/mathpiper


%mathpiper_docs,name="*",categories="Operators"
*CMD * --- arithmetic multiplication
*STD
*CALL

	x*y
Precedence:
*EVAL PrecedenceGet("*")

*PARMS

{x} and {y} -- objects for which arithmetic multiplication is defined

*DESC

The multiplication operator can work on integers,
rational numbers, complex numbers, vectors, matrices and lists.

This operator is implemented in the standard math library (as opposed
to being built-in). This means that they can be extended by the user.

*E.G.

In> 2*3
Result: 6;
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/minus_operator.mpw0000644000175000017500000000461211523200452033725 0ustar  giovannigiovanni%mathpiper,def="-"

/* Subtraction arity 1 */

//50 # -0 <-- 0;
51 # -Undefined <-- Undefined;
54 # - (- _x)      <-- x;
55 # (- (x_IsNumber)) <-- SubtractN(0,x);
100 # _x - n_IsConstant*(_x)   <-- (1-n)*x;
100 # n_IsConstant*(_x) - _x   <-- (n-1)*x;

110 # - (_x - _y) <-- y-x;
111 # - (x_IsNumber / _y) <-- (-x)/y;	
LocalSymbols(x)
[
  200 # - (x_IsList) <-- MapSingle("-",x);
];

/* Subtraction arity 2 */
50  # x_IsNumber - y_IsNumber <-- SubtractN(x,y);
50  # x_IsNumber - y_IsNumber <-- SubtractN(x,y);
60  # Infinity - Infinity <-- Undefined;
100 # 0 - _x <-- -x;
100 # _x - 0 <-- x;
100 # _x - _x <-- 0;

110 # _x - (- _y) <-- x + y;
110 # _x - (y_IsNegativeNumber) <-- x + (-y);
111 # (_x + _y)- _x <-- y;
111 # (_x + _y)- _y <-- x;
112 # _x - (_x + _y) <-- - y;
112 # _y - (_x + _y) <-- - x;
113 # (- _x) - _y <-- -(x+y);
113 # (x_IsNegativeNumber) - _y <-- -((-x)+y);
113 # (x_IsNegativeNumber)/_y - _z <-- -((-x)/y+z);


/* TODO move to this precedence everywhere? */
LocalSymbols(x,y,xarg,yarg)
[
  10 # ((x_IsList) - (y_IsList))_(Length(x)=Length(y)) <--
  [
    Map({{xarg,yarg},xarg-yarg},{x,y});
  ];
];

240 # (x_IsList - y_IsNonObject)_Not(IsList(y)) <-- -(y-x);

241 # (x_IsNonObject - y_IsList)_Not(IsList(x)) <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(y),i++)
   [ DestructiveInsert(result,i,x - y[i]); ];
   result;
];

250 # z_IsInfinity - Complex(_x,_y) <-- Complex(-x+z,-y);
250 # Complex(_x,_y) - z_IsInfinity <-- Complex(x-z,y);

251 # z_IsInfinity - _x <-- z;
251 # _x - z_IsInfinity <-- -z;

250 # Undefined - _y <-- Undefined;
250 # _x - Undefined <-- Undefined;
// fractions
210 # x_IsNumber - (y_IsNumber / z_IsNumber) <--(x*z-y)/z;
210 # (y_IsNumber / z_IsNumber) - x_IsNumber <--(y-x*z)/z;
210 # (x_IsNumber / v_IsNumber) - (y_IsNumber / z_IsNumber) <--(x*z-y*v)/(v*z);

%/mathpiper


%mathpiper_docs,name="-",categories="Operators"
*CMD - --- arithmetic subtraction or negation
*STD
*CALL

	x-y
Precedence: left-side:
*EVAL PrecedenceGet("-")
, right-side:
*EVAL RightPrecedenceGet("-")

	-x

*PARMS

{x} and {y} -- objects for which subtraction is defined

*DESC

The subtraction operators can work on integers,
rational numbers, complex numbers, vectors, matrices and lists.

These operators are implemented in the standard math library (as opposed
to being built-in). This means that they can be extended by the user.

*E.G.

In> 2-3
Result: -1;
In> - 3
Result: -3;
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/slash_operator.mpw0000644000175000017500000000602011551615654033716 0ustar  giovannigiovanni%mathpiper,def="/"

/* Division */

50 # 0 / 0 <-- Undefined;

52 # x_IsPositiveNumber / 0 <-- Infinity;
52 # x_IsNegativeNumber / 0 <-- -Infinity;
55 # (_x / y_IsNumber)_(IsZero(y)) <-- Undefined;
55 # 0 / _x <-- 0;
// unnecessary rule (see #100 below). TODO: REMOVE
//55 # x_IsNumber / y_IsNegativeNumber <-- (-x)/(-y);

56 # (x_IsNonZeroInteger / y_IsNonZeroInteger)_(GcdN(x,y) > 1) <--
     [
       Local(gcd);
       Bind(x,x);
       Bind(y,y);
       Bind(gcd,GcdN(x,y));
       QuotientN(x,gcd)/QuotientN(y,gcd);
     ];

57 # ((x_IsNonZeroInteger * _expr) / y_IsNonZeroInteger)_(GcdN(x,y) > 1) <--
     [
       Local(gcd);
       Bind(x,x);
       Bind(y,y);
       Bind(gcd,GcdN(x,y));
       (QuotientN(x,gcd)*expr)/QuotientN(y,gcd);
     ];

57 # ((x_IsNonZeroInteger) / (y_IsNonZeroInteger * _expr))_(GcdN(x,y) > 1) <--
     [
       Local(gcd);
       Bind(x,x);
       Bind(y,y);
       Bind(gcd,GcdN(x,y));
       QuotientN(x,gcd)/(QuotientN(y,gcd)*expr);
     ];

57 # ((x_IsNonZeroInteger * _p) / (y_IsNonZeroInteger * _q))_(GcdN(x,y) > 1) <--
     [
       Local(gcd);
       Bind(x,x);
       Bind(y,y);
       Bind(gcd,GcdN(x,y));
       (QuotientN(x,gcd)*p)/(QuotientN(y,gcd)*q);
     ];

60 # (x_IsDecimal / y_IsNumber)  <-- DivideN(x,y);
60 # (x_IsNumber  / y_IsDecimal) <-- DivideN(x,y); 
60 # (x_IsNumber  / y_IsNumber)_(InNumericMode()) <-- DivideN(x,y);


90 # x_IsInfinity / y_IsInfinity <-- Undefined;
95  # x_IsInfinity / y_IsNumber <-- Sign(y)*x;
95  # x_IsInfinity / y_IsComplex <-- Infinity;

90 # Undefined / _y <-- Undefined;
90 # _y / Undefined <-- Undefined;


100 # _x / _x <-- 1;
100 # _x /  1 <-- x;
100 # (_x / y_IsNegativeNumber) <-- -x/(-y);
100 # (_x / - _y) <-- -x/y;

150 # (_x) / (_x) ^ (n_IsConstant) <-- x^(1-n);
150 # (_x) ^ (n_IsConstant) * (_x) <-- x^(n-1);
150 # Sqrt(_x) / (_x) ^ (n_IsConstant) <-- x^(1/2-n);
150 # (_x) ^ (n_IsConstant) / Sqrt(_x) <-- x^(n-1/2);
150 # (_x) / Sqrt(_x) <-- Sqrt(x);

// fractions
200 # (_x / _y)/ _z <-- x/(y*z);
230 # _x / (_y / _z) <-- (x*z)/y;

240 # (xlist_IsList / ylist_IsList)_(Length(xlist)=Length(ylist)) <--
	 Map("/",{xlist,ylist});


250 # (x_IsList / _y)_(Not(IsList(y))) <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(x),i++)
   [ DestructiveInsert(result,i,x[i] / y); ];
   result;
];

250 # (_x / y_IsList)_(Not(IsList(x))) <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(y),i++)
   [ DestructiveInsert(result,i,x/y[i]); ];
   result;
];

250 # _x / Infinity <-- 0;
250 # _x / (-Infinity) <-- 0;


400 # 0 / _x <-- 0;

%/mathpiper


%mathpiper_docs,name="/",categories="Operators"
*CMD / --- arithmetic division
*STD
*CALL

	x/y
Precedence:
*EVAL PrecedenceGet("/")

*PARMS

{x} and {y} -- objects for which arithmetic division is defined

*DESC

The division operator can work on integers,
rational numbers, complex numbers, vectors, matrices and lists.

This operator is implemented in the standard math library (as opposed
to being built-in). This means that they can be extended by the user.

*E.G.

In> 6/2
Result: 3;

*SEE %_v1
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/plus_operator.mpw0000644000175000017500000000473611523200452033564 0ustar  giovannigiovanni%mathpiper,def="+"

/* Addition */

100 # + _x  <-- x;

50 # x_IsNumber + y_IsNumber <-- AddN(x,y);

100 # 0 + _x    <-- x;
100 # _x + 0    <-- x;
100 # _x + _x   <-- 2*x;
100 # _x + n_IsConstant*(_x)   <-- (n+1)*x;
100 # n_IsConstant*(_x) + _x   <-- (n+1)*x;
101 # _x + - _y <-- x-y;
101 # _x + (- _y)/(_z) <-- x-(y/z);
101 # (- _y)/(_z) + _x  <-- x-(y/z);
101 # (- _x) + _y <-- y-x;
102 # _x + y_IsNegativeNumber <-- x-(-y);
102 # _x + y_IsNegativeNumber * _z <-- x-((-y)*z);
102 # _x + (y_IsNegativeNumber)/(_z) <-- x-((-y)/z);
102 # (y_IsNegativeNumber)/(_z) + _x  <-- x-((-y)/z);
102 # (x_IsNegativeNumber) + _y <-- y-(-x);
// fractions
150 # _n1 / _d + _n2 / _d <-- (n1+n2)/d;

200 # (x_IsNumber + _y)_Not(IsNumber(y)) <-- y+x;
200 # ((_y + x_IsNumber) + _z)_Not(IsNumber(y) Or IsNumber(z)) <-- (y+z)+x;
200 # ((x_IsNumber + _y) + z_IsNumber)_Not(IsNumber(y)) <-- y+(x+z);
200 # ((_x + y_IsNumber) + z_IsNumber)_Not(IsNumber(x)) <-- x+(y+z);
// fractions
210 # x_IsNumber + (y_IsNumber / z_IsNumber) <--(x*z+y)/z;
210 # (y_IsNumber / z_IsNumber) + x_IsNumber <--(x*z+y)/z;
210 # (x_IsNumber / v_IsNumber) + (y_IsNumber / z_IsNumber) <--(x*z+y*v)/(v*z);


//  220 # + x_IsList          <-- MapSingle("+",x);	// this rule is never active

220 # (xlist_IsList + ylist_IsList)_(Length(xlist)=Length(ylist)) <-- Map("+",{xlist,ylist});

SumListSide(_x, y_IsList) <--
[
   Local(i,result);
   result:={};
   For(i:=1,i<=Length(y),i++)
   [ DestructiveInsert(result,i,x + y[i]); ];
   result;
];

240 # (x_IsList + _y)_Not(IsList(y)) <-- SumListSide(y,x);
241 # (_x + y_IsList)_Not(IsList(x)) <-- SumListSide(x,y);

250 # z_IsInfinity + Complex(_x,_y) <-- Complex(x+z,y);
250 # Complex(_x,_y) + z_IsInfinity <-- Complex(x+z,y);

251 # z_IsInfinity + _x <-- z;
251 # _x + z_IsInfinity <-- z;


250 # Undefined + _y <-- Undefined;
250 # _x + Undefined <-- Undefined;

%/mathpiper




%mathpiper,scope="nobuild",subtype="test_suite"
//This fold is used to test the + operator.
    Verify(3 + 2 , 5);
%/mathpiper



%mathpiper_docs,name="+",categories="Operators"
*CMD + --- arithmetic addition
*STD
*CALL

	x+y
	+x
Precedence:
*EVAL PrecedenceGet("+")

*PARMS

{x} and {y} -- objects for which arithmetic addition is defined


*DESC

The addition operators can work on integers,
rational numbers, complex numbers, vectors, matrices and lists.

These operators are implemented in the standard math library (as opposed
to being built-in). This means that they can be extended by the user.

*E.G.

In> 2+3
Result: 5;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/stdarith/caret_operator.mpw0000644000175000017500000000716611523200452033677 0ustar  giovannigiovanni%mathpiper,def="^"

/* Faster version of raising power to 0.5 */
50 # _x ^ (1/2) <-- Sqrt(x);
50 # (x_IsPositiveNumber ^ (1/2))_IsInteger(SqrtN(x)) <-- SqrtN(x);
58 # 1 ^ n_IsInfinity <-- Undefined;
59 # _x ^ 1 <-- x;
59 # 1 ^ _n <-- 1;
59 # x_IsZero ^ y_IsZero <-- Undefined;
60 # (x_IsZero ^ n_IsRationalOrNumber)_(n>0) <-- 0;
60 # (x_IsZero ^ n_IsRationalOrNumber)_(n<0) <-- Infinity;
// This is to fix:
// In> 0.0000^2
// Result: 0.0000^2;
// In> 0.0^2/2
// Result: 0.0^2/2;
//60 # (x_IsNumber ^ n_IsRationalOrNumber)_(x+1=1) <-- 0;

59 # _x ^ Undefined <-- Undefined;
59 # Undefined ^ _x <-- Undefined;

/* Regular raising to the power. */
61 # Infinity ^ (y_IsNegativeNumber) <-- 0;
61 # (-Infinity) ^ (y_IsNegativeNumber) <-- 0;
//61 # x_IsPositiveNumber ^ y_IsPositiveNumber <-- PowerN(x,y);
//61 # x_IsPositiveNumber ^ y_IsNegativeNumber <-- (1/PowerN(x,-y));
// integer powers are very fast
61 # x_IsPositiveNumber ^ y_IsPositiveInteger <-- MathIntPower(x,y);
61 # x_IsPositiveNumber ^ y_IsNegativeInteger <-- 1/MathIntPower(x,-y);
65 # (x_IsPositiveNumber ^ y_IsNumber)_InNumericMode() <-- Exp(y*Ln(x));

90 # (-_x)^m_IsEven <-- x^m;
91 # (x_IsConstant ^ (m_IsOdd / p_IsOdd))_(IsNegativeNumber(Re(N(Eval(x))))) <--
     -((-x)^(m/p));
92 # (x_IsNegativeNumber ^ y_IsNumber)_InNumericMode() <-- Exp(y*Ln(x));


70  # (_x ^ m_IsRationalOrNumber) ^ n_IsRationalOrNumber <-- x^(n*m);

80 # (x_IsNumber/y_IsNumber) ^ n_IsPositiveInteger <-- x^n/y^n;
80 # (x_IsNumber/y_IsNumber) ^ n_IsNegativeInteger <-- y^(-n)/x^(-n);
80 # x_IsNegativeNumber ^ n_IsEven <-- (-x)^n;
80 # x_IsNegativeNumber ^ n_IsOdd <-- -((-x)^n);


100  # ((_x)*(_x ^ _m)) <-- x^(m+1);
100  # ((_x ^ _m)*(_x)) <-- x^(m+1);
100  # ((_x ^ _n)*(_x ^ _m)) <-- x^(m+n);

100  # ((x_IsNumber)^(n_IsInteger/(_m)))_(n>1) <-- MathIntPower(x,n)^(1/m);

100 # Sqrt(_n)^(m_IsEven) <-- n^(m/2);

100 # Abs(_a)^n_IsEven <-- a^n;
100 # Abs(_a)^n_IsOdd <-- Sign(a)*a^n;


200 # x_IsMatrix ^ n_IsPositiveInteger <-- x*(x^(n-1));
204 # (xlist_IsList ^ nlist_IsList)_(Length(xlist)=Length(nlist)) <--
	 Map("^",{xlist,nlist});
205 # (xlist_IsList ^ n_IsConstant)_(Not(IsList(n))) <--
	 Map({{xx},xx^n},{xlist});
206 # (_x ^ n_IsList)_(Not(IsList(x))) <-- Map({{xx},x^xx},{n});
249 # x_IsInfinity ^ 0 <-- Undefined;
250 # Infinity ^ (_n) <-- Infinity;
250 # Infinity ^ (_x_IsComplex) <-- Infinity;
250 # ((-Infinity) ^ (n_IsNumber))_(IsEven(n)) <-- Infinity;
250 # ((-Infinity) ^ (n_IsNumber))_(IsOdd(n)) <-- -Infinity;

250 # (x_IsNumber ^ Infinity)_(x> -1 And x < 1) <-- 0;
250 # (x_IsNumber ^ Infinity)_(x> 1) <-- Infinity;

// these Magnitude(x)s should probably be changed to Abs(x)s

250 # (x_IsComplex ^ Infinity)_(Magnitude(x) > 1) <-- Infinity;
250 # (x_IsComplex ^ Infinity)_(Magnitude(x) < -1) <-- -Infinity;
250 # (x_IsComplex ^ Infinity)_(Magnitude(x) > -1 And Magnitude(x) < 1) <-- 0;

250 # (x_IsNumber ^ -Infinity)_(x> -1 And x < 1) <-- Infinity;
250 # (x_IsNumber ^ -Infinity)_(x< -1) <-- 0;
250 # (x_IsNumber ^ -Infinity)_(x> 1) <-- 0;

255 # (x_IsComplex ^ Infinity)_(Abs(x) = 1) <-- Undefined;
255 # (x_IsComplex ^ -Infinity)_(Abs(x) = 1) <-- Undefined;



400 # _x ^ 0 <-- 1;

%/mathpiper


%mathpiper_docs,name="^",categories="Operators"
*CMD ^ --- arithmetic power
*STD
*CALL

	x^y
Precedence:
*EVAL PrecedenceGet("^")

*PARMS

{x} and {y} -- objects for which arithmetic operations are defined

*DESC

These are the basic arithmetic operations. They can work on integers,
rational numbers, complex numbers, vectors, matrices and lists.

These operators are implemented in the standard math library (as opposed
to being built-in). This means that they can be extended by the user.

*E.G.

In> 2^3
Result: 8;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/mathpiperinit/0000755000175000017500000000000011722677334031204 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/mathpiperinit/mathpiperinit.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/mathpiperinit/mathpiperinit.0000644000175000017500000000441511507273056034060 0ustar  giovannigiovanni%mathpiper,def=""



/* This is the basic initialization file for MathPiper. It gets loaded
 * each time MathPiper is started. All the basic files are loaded.
 */

/* Set up drivers, configurable in the .mpiperrc
 *   Bind(MultiNomialDriver,"multivar.rep/sparsenomial.mpi");
 *     or
 *   Bind(MultiNomialDriver,"multivar.rep/partialdensenomial.mpi");
 */

/* The truly required files (MathPiper NEEDS to load). */
// syntax must be loaded first
LoadScriptOnce("initialization.rep/stdopers.mpi");

/* Set of functions to define very simple functions. There are scripts that can
   be compiled to plugins. So MathPiper either loads the plugin, or loads the
   scripts at this point. The functions in these plugins need to be defined with
   these "Defun" functions.
 */
DefMacroRulebase("Defun",{func,args,body});
Rule("Defun",3,0,True)
[
  Local(nrargs);
  Bind(nrargs,Length(@args));
  Retract(@func, `(@nrargs));
  Rulebase(@func,@args);
  Local(fn,bd);
  Bind(fn,Hold(@func)); Bind(bd,Hold(@body));
  `Rule(@fn, @nrargs, 0,True)(@bd);
];

//TODO remove? LoadScriptOnce("base.rep/math.mpi");

LoadScriptOnce("patterns.rep/code.mpi");
// at this point <-- can be used

LoadScriptOnce("deffunc.rep/code.mpi");

// at this point := and Function() can be used

LoadScriptOnce("constants.rep/code.mpi");
LoadScriptOnce("initialization.rep/standard.mpi");
LoadScriptOnce("initialization.rep/stdarith.mpi");

// at this point arithmetic can be used

/* Load the def files for the other modules. The def files contain lists
 * of functions defined in that file. So, in solve.def you can find the
 * functions defined in the file solve. Each time a function is invoked
 * for which the interpreter can not find a definition, the file is loaded.
 */

Rulebase(LoadPackages,{packages});
Rule(LoadPackages, 1, 1, True)
[
	If(IsEqual(packages,{}), True,
	[
		DefLoad(First(packages));
		LoadPackages(Rest(packages));
	]);
];

LoadScriptOnce("initialization.rep/packages.mpi");
LoadPackages(DefFileList());

// The multivar routines are not all properly initialized until the first time
// one of them is called.  This may come too late for some operations that try
// to use them  before they have been initialized.  The following call should
// take care of this problem.
LoadScriptOnce("multivar.rep/code.mpi");


%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/miscdocs/0000755000175000017500000000000011722677334030133 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/miscdocs/miscellaneousdocs.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/initialization/miscdocs/miscellaneousdocs.m0000644000175000017500000001123611523200452034006 0ustar  giovannigiovanni

%mathpiper_docs,name="quit;restart",categories="User Functions;Built In"
*CMD quit --- stop MathPiper from running (from the command line)
*CMD restart --- restart MathPiper (to start with a clean slate)
*CORE
*CALL
	quit
	restart

*DESC

Type {quit} or {restart} at the MathPiper prompt to exit or to restart the interpreter.

The directives {quit} and {restart} are not reserved words or variable names.
They take effect only when typed as first characters at a prompt.

Pressing {Ctrl-C} will stop the currently running calculation.
If there is no currently running calculation, {Ctrl-C} will quit the interpreter.

When the interpreter quits, it saves the command history
(so quitting by {Ctrl-C} does not mean a "crash").

This command is not a function but a special directive that only applies while running MathPiper interactively.  It should not be used in scripts.

*E.G.

To be effective, the directive must be typed immediately after the prompt:
In> quit
	Quitting...
We can use variables named {quit}:
In> 1+quit
Result: quit+1;
There is no effect if we type some spaces first:
In>       restart
Result: restart;

*SEE Exit
%/mathpiper_docs




%mathpiper_docs,name="%_v2",categories="Operators"
*CMD % --- previous result
*CORE
*CALL
	%

*DESC

{%} evaluates to the previous result on the command line. {%} is a global
variable that is bound to the previous result from the command line.
Using {%} will evaluate the previous result. (This uses the functionality
offered by the {SetGlobalLazyVariable} command).

Typical examples are {Simplify(%)} and {PrettyForm(%)} to simplify and show the result in a nice
form respectively.

*E.G.

In> Taylor(x,0,5)Sin(x)
Result: x-x^3/6+x^5/120;
In> PrettyForm(%)

	     3    5
	    x    x
	x - -- + ---
	    6    120



*SEE SetGlobalLazyVariable
%/mathpiper_docs






%mathpiper_docs,name="True;False",categories="User Functions;Constants (System)"
*CMD True --- boolean constant representing true
*CMD False --- boolean constant representing false
*CORE
*CALL
	True
	False

*DESC

{True} and {False} are typically a result
of boolean expressions such as {2 < 3} or {True And False}.

*SEE And, Or, Not
%/mathpiper_docs






%mathpiper_docs,name="EndOfFile",categories="User Functions;Constants (System)"
*CMD EndOfFile --- end-of-file marker
*CORE
*CALL
	EndOfFile

*DESC

End of file marker when reading from file. If a file
contains the expression {EndOfFile;} the
operation will stop reading the file at that point.
%/mathpiper_docs





%mathpiper_docs,name="Infinity",categories="User Functions;Constants (Mathematical)"

*CMD Infinity --- constant representing mathematical infinity
*STD
*CALL
	Infinity

*DESC

Infinity represents infinitely large values. It can be the result of certain
calculations.

Note that for most analytic functions MathPiper understands {Infinity} as a positive number.
Thus {Infinity*2} will return {Infinity}, and {a < Infinity} will evaluate to {True}.

*E.G.

In> 2*Infinity
Result: Infinity;
In> 2 2*Infinity
Result: Infinity;
In> 0*Infinity
Result: Undefined;
In> Sin(Infinity);
Result: Undefined;
In> Undefined+2*Exp(Undefined);
Result: Undefined;

*SEE Infinity
%/mathpiper_docs




%mathpiper_docs,name="/*;*/;//",categories="Operators"
*CMD	/* --- Start of comment
*CMD	*/ --- end of comment
*CMD	// --- Beginning of one-line comment
*CORE
*CALL
	/* comment */
	// comment

*DESC

Introduce a comment block in a source file, similar to C++ comments.
{//} makes everything until the end of the line a comment, while {/*} and {*/} may delimit a multi-line comment.

*E.G.

	a+b; // get result
	a + /* add them */ b;
%/mathpiper_docs




%mathpiper_docs,name="[;]",categories="Operators"
*CMD [ --- beginning of block of statements
*CMD ] --- end of block of statements
*CORE
*CALL

	[ statement1; statement2; ... ]

*PARMS

{statement1}, {statement2} -- expressions

*DESC

The {Prog} and the {[ ... ]} construct have the same effect: they evaluate all
arguments in order and return the result of the last evaluated expression.

{Prog(a,b);} is the same as typing {[a;b;];} and is very useful for writing out
function bodies. The {[ ... ]} construct is a syntactically nicer version of the
{Prog} call; it is converted into {Prog(...)} during the parsing stage.

*SEE Prog
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/0000755000175000017500000000000011722677330025466 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/regression/0000755000175000017500000000000011722677330027646 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/regression/Regress.mpw0000644000175000017500000000067211316304766032011 0ustar  giovannigiovanni%mathpiper,def="Regress"


/* Finds the rengression of y onto x, that is
   y == alpha + beta * x

   Example usage:
   x := 1 .. 5;
   y := (2.34*x+2) +(2*Random()-1);
   ans :=Regress(x,y);

   To find the residuals, we do
   (y-alpha-beta*x) /: ans
 */


Regress(x,y) :=
[
 Local(xy,x2,i,mx,my);

 mx := Mean(x);
 my := Mean(y);
 xy := Add((x-mx)*(y-my));
 x2 := Add((x-mx)^2);
 {alpha <- (my-xy*mx/x2) , beta <-  xy/x2};
];



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/GeometricMean.mpw0000644000175000017500000000121311502266107030717 0ustar  giovannigiovanni%mathpiper,def="GeometricMean"

GeometricMean(list) := 
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Product(list)^(1/Length(list));
];

%/mathpiper




%mathpiper_docs,name="GeometricMean",categories="User Functions;Statistics & Probability"
*CMD GeometricMean --- calculates the mean of a list of values
*STD
*CALL
	GeometricMean(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the geometric mean of a list of values.

*E.G.
In> Mean({73,94,80,37,56,94,40,21,7,24})
Result: 263/5

In> N(Mean({73,94,80,37,56,94,40,21,7,24}))
Result: 52.6

*SEE Mean, WeightedMean, Median, Mode
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/UnbiasedVariance.mpw0000644000175000017500000000132611502266107031410 0ustar  giovannigiovanni%mathpiper,def="UnbiasedVariance"

UnbiasedVariance(list) := 
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Sum((list - Mean(list))^2)/(Length(list)-1);
];

%/mathpiper






%mathpiper_docs,name="UnbiasedVariance",categories="User Functions;Statistics & Probability"
*CMD UnbiasedVariance --- calculates the unbiased variance of a list of values
*STD
*CALL
	UnbiasedVariance(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the unbiased variance of a list of values.

*E.G.
In> UnbiasedVariance({73,94,80,37,57,94,40,21,7,26})
Result: 88009/90

In> N(UnbiasedVariance({73,94,80,37,57,94,40,21,7,26}))
Result: 977.8777778

*SEE Variance, StandardDeviation
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/Mean.mpw0000644000175000017500000000122511502266107027063 0ustar  giovannigiovanni%mathpiper,def="Mean"

Mean(list) := 
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Sum(list)/Length(list);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Mean",categories="User Functions;Statistics & Probability"
*CMD Mean --- calculates the mean of a list of values
*STD
*CALL
	Mean(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the mean of a list of values.

*E.G.
In> Mean({73,94,80,37,56,94,40,21,7,24})
Result: 263/5

In> N(Mean({73,94,80,37,56,94,40,21,7,24}))
Result: 52.6

*SEE WeightedMean, Median, Mode, GeometricMean
%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/Median.mpw0000644000175000017500000000147211502266107027404 0ustar  giovannigiovanni%mathpiper,def="Median"

Median(list) :=
[
    Check(IsList(list), "Argument", "Argument must be a list.");
    
    Local(sx,n,n2); // s[orted]x
    
    sx := HeapSort(list,"<");
    
    n := Length(list);
    
    n2 := (n>>1);
    
    If(Modulo(n,2) = 1, sx[n2+1], (sx[n2]+sx[n2+1])/2);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Median",categories="User Functions;Statistics & Probability"
*CMD Median --- calculates the median of a list of values
*STD
*CALL
	Median(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the median of a list of values.

*E.G.
In> Median({73,94,80,37,57,94,40,21,7,26})
Result: 97/2

In> N(Median({73,94,80,37,57,94,40,21,7,26}))
Result: 48.5

*SEE WeightedMean, Mean, Mode, GeometricMean
%/mathpiper_docs

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/incompletegamma/0000755000175000017500000000000011722677330030630 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/incompletegamma/IncompleteGamma.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/incompletegamma/IncompleteGamma.0000644000175000017500000000355411517224250033671 0ustar  giovannigiovanni%mathpiper,def=""



/* IncompleteGamma function \int\limits_{0}^xt^{a-1}e^{-t}dt

   Calculation is based on series
   IncompleteGamma(a,x)=x^a*Sum(k,0,infinity,(-1)^k*x^k/k!/(a+k)
   (see D.S.Kouznetsov. Special functions. Vysshaia Shkola, Moscow, 1965)
   for small x, and on asymptotic expansion
   IncompleteGamma(a,x)=Gamma(x)-x^(a-1)*Exp(-x)*(1+(a-1)/z+(a-1)(a-2)/z^2+...)
   (see O.E.Barndorf-Nielsen & D.R.Cox. Asymptotic techniques for Use
   in Statistics.. Russian translation is also available)
   for large x.
*/


/* This function is commented out because IncompleteGamma(2.5,3.6) causes infinite looping.

//Retract("IncompleteGamma",*);

100 # IncompleteGamma(_a, _x)_(x<=a+1) <--
[
   Local(prec,eps);
   prec:=BuiltinPrecisionGet();
   BuiltinPrecisionSet(Ceil(prec+1)); // this is a guess
   eps:=5*10^(-prec);

   Local(term,result,k);

   term:=1/a;
   k:=0;
   result:=0;
   While( Abs(term) >= eps )[
		  k:=k+1;
		  result:=result+term;
		  term:= -x*(a+k-1)*term/k/(a+k);
          //Echo({"term is ",term});
   ];
   result:= N(x^a*result);
   BuiltinPrecisionSet(prec);
   // This should not round, only truncate
   // some outputs will be off by one in the last digit
   RoundTo(result,prec);
];


100 # IncompleteGamma(_a, _x)_(x>a+1) <--
[ // Asymptotic expansion
   Local(prec,eps);
   prec:=BuiltinPrecisionGet();
   BuiltinPrecisionSet(Ceil(prec+1)); // this is a guess
   eps:=5*10^(-prec);

   Local(term,result,k,expr);

   term:=1;
   k:=0;
   result:=0;
   While( Abs(term) >= eps )[
		  k:=k+1;
		  result:=result+term;
		  term:=term*(a-k)/x;
		  //Echo({"term is ",term});
   ];
  result:=N(Gamma(a)-x^(a-1)*Exp(-x)*result);
  BuiltinPrecisionSet(prec);
  // This should not round, only truncate
  // some outputs will be off by one in the last digit
  RoundTo(result,prec);
];

*/

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/Variance.mpw0000644000175000017500000000130611502266107027733 0ustar  giovannigiovanni%mathpiper,def="Variance"

Variance(list) := 
[
    Check(IsList(list), "Argument", "Argument must be a list.");

    Sum((list - Mean(list))^2)/Length(list);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output






%mathpiper_docs,name="Variance",categories="User Functions;Statistics & Probability"
*CMD Variance --- calculates the variance of a list of values
*STD
*CALL
	Variance(list)

*PARMS

{list} -- list of values

*DESC

This function calculates the variance of a list of values.

*E.G.
In> Variance({73,94,80,37,57,94,40,21,7,26})
Result: 88009/100

In> N(Variance({73,94,80,37,57,94,40,21,7,26}))
Result: 880.09

*SEE UnbiasedVariance, StandardDeviation
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/0000755000175000017500000000000011722677330030370 5ustar  giovannigiovanni././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/PoissonDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/PoissonDistributio0000644000175000017500000000161411461400444034157 0ustar  giovannigiovanni%mathpiper,def="PoissonDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

PoissonDistribution(l_IsRationalOrNumber)_(l<=0) <-- Undefined;

%/mathpiper





%mathpiper_docs,name="PoissonDistribution",categories="User Functions;Statistics & Probability"
*CMD PoissonDistribution --- Poisson distribution
*STD
*CALL
	PoissonDistribution(lambda)

*PARMS
{lambda} -- number, the expected number of occurrences that occur during the given interval

*DESC
The poisson distribution.

*E.G.
In> N(PMF(PoissonDistribution(5), 7))
Result: 0.1044448631

In> N(CDF(PoissonDistribution(5), 2))
Result: 0.1246520197


*SEE BinomialDistribution, BernoulliDistribution, DiscreteUniformDistribution, ChiSquareDistribution, ContinuousUniformDistribution, ExponentionalDistribution, GeometricDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs././@LongLink0000000000000000000000000000016100000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/HypergeometricDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/HypergeometricDist0000644000175000017500000000305611316304766034130 0ustar  giovannigiovanni%mathpiper,def="HypergeometricDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

HypergeometricDistribution(N_IsRationalOrNumber, M_IsRationalOrNumber, n_IsRationalOrNumber)_(M > N Or n > N)
   <-- Undefined;

%/mathpiper




%mathpiper_docs,name="HypergeometricDistribution",categories="User Functions;Statistics & Probability"
*CMD HypergeometricDistribution --- Hypergeometric distribution
*STD
*CALL
	HypergeometricDistribution(N, M, n)

*PARMS

{N} -- number, a finite population
{M} -- number of items from N that fall into a class of interest
{n} -- number of items drawn from N

*DESC

A discrete probability distribution that describes the number of successes in a sequence of
draws from a finite population without replacement.  The hypergeometric distribution is the
probability model which is used for selecting a random sample of n items without replacement 
from a lot of N items, M of which are nonconforming or defective.

*E.G.

/%mathpiper,title=""

PDF(HypergeometricDistribution(100,5,10),0);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.5837523670
.   /%/output



/%mathpiper,title=""

CDF(HypergeometricDistribution(100,5,10),1);

/%/mathpiper

    /%output,preserve="false"
      Result: 0.9231432779
.   /%/output

*SEE BinomialDistribution, BernoulliDistribution, ChiSquareDistribution, DiscreteUniformDistribution, ExponentionalDistribution, GeometricDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/GeometricDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/GeometricDistribut0000644000175000017500000000130011316304766034114 0ustar  giovannigiovanni%mathpiper,def="GeometricDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

GeometricDistribution(p_IsRationalOrNumber)_(p<0 Or p>1) <-- Undefined;

%/mathpiper




%mathpiper_docs,name="GeometricDistribution",categories="User Functions;Statistics & Probability"
*CMD GeometricDistribution --- Geometric distribution
*STD
*CALL
	GeometricDistribution(p)

*PARMS

{p} -- number, probability of an event in a single trial


*SEE BinomialDistribution, BernoulliDistribution, DiscreteUniformDistribution, ChiSquareDistribution, ContinuousUniformDistribution, ExponentionalDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs././@LongLink0000000000000000000000000000016200000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/DiscreteUniformDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/DiscreteUniformDis0000644000175000017500000000137611316304766034063 0ustar  giovannigiovanni%mathpiper,def="DiscreteUniformDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

DiscreteUniformDistribution(a_IsRationalOrNumber, b_IsRationalOrNumber)_(a>=b)
   <-- Undefined;

%/mathpiper




%mathpiper_docs,name="DiscreteUniformDistribution",categories="User Functions;Statistics & Probability"
*CMD DiscreteUniformDistribution --- Discrete uniform distribution
*STD
*CALL
	DiscreteUniformDistribution(a, b)

*PARMS

{a} -- number, lower range value
{b} -- number, upper range value


*SEE BinomialDistribution, BernoulliDistribution, ChiSquareDistribution, ContinuousUniformDistribution, ExponentionalDistribution, GeometricDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs././@LongLink0000000000000000000000000000015100000000000011562 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/NormalDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/NormalDistribution0000644000175000017500000000155711316304766034152 0ustar  giovannigiovanni%mathpiper,def="NormalDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

NormalDistribution( _m , s2_IsRationalOrNumber)_(s2<=0) <-- Undefined;

%/mathpiper




%mathpiper_docs,name="NormalDistribution",categories="User Functions;Statistics & Probability"
*CMD NormalDistribution --- The normal distribution.
*STD
*CALL
	NormalDistribution(mean, sigma)

*PARMS

{mean} -- Number, the mean of the distribution
{sigma} -- Number, the standard deviation of the distribution

*DESC
The normal distribution.

*E.G.
In> N(CDF(NormalDistribution(60,5),64.3))
Result: 0.8051055222

*SEE BinomialDistribution, BernoulliDistribution, ChiSquareDistribution, DiscreteUniformDistribution, ContinuousUniformDistribution, ExponentionalDistribution, GeometricDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/ChiSquareDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/ChiSquareDistribut0000644000175000017500000000165511316304766034077 0ustar  giovannigiovanni%mathpiper,def="ChiSquareDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

ChiSquareDistribution(m_IsRationalOrNumber)_(m<=0) <-- Undefined;

%/mathpiper



%mathpiper_docs,name="ChiSquareDistribution",categories="User Functions;Statistics & Probability"
*CMD ChiSquareDistribution --- Chi square distribution
*STD
*CALL
	ChiSquareDistribution(p)

*PARMS

{p} -- number, probability of an event in a single trial

*DESC
A random variable has a ChiSquare distribution with probability {p} if
it can be interpreted as an indicator of an event, where {p} is the
probability to observe the event in a single trial.

Numerical value of {p} must satisfy $0=b)
   <-- Undefined;

%/mathpiper




%mathpiper_docs,name="ContinuousUniformDistribution",categories="User Functions;Statistics & Probability"
*CMD ContinuousUniformDistribution --- Discrete uniform distribution
*STD
*CALL
	ContinuousUniformDistribution(a, b)

*PARMS

{a} -- number, lower range value
{b} -- number, upper range value


*SEE BinomialDistribution, BernoulliDistribution, ChiSquareDistribution, DiscreteUniformDistribution, ExponentionalDistribution, GeometricDistribution, NormalDistribution, PoissonDistribution, tDistribution
%/mathpiper_docs././@LongLink0000000000000000000000000000015300000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/BinomialDistribution.mpwmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/distributions/BinomialDistributi0000644000175000017500000000315611316304766034114 0ustar  giovannigiovanni%mathpiper,def="BinomialDistribution"

/* Guard against distribution objects with senseless parameters
   Anti-nominalism */

BinomialDistribution(_p, _n)_
	(If(IsRationalOrNumber(p),p<0 Or p>1, False)
	 Or (IsConstant(n) And Not IsPositiveInteger(n)) )
	<-- Undefined;

%/mathpiper



%mathpiper_docs,name="BinomialDistribution",categories="User Functions;Statistics & Probability"
*CMD BinomialDistribution --- binomial distribution
*STD
*CALL
	BinomialDistribution(p,n)

*PARMS
{p} -- number, probability to observe an event in single trial

{n} -- number of trials

*DESC
Suppose we repeat a trial {n} times, the probability to observe an
event in a single trial is {p} and outcomes in all trials are mutually
independent. Then the number of trials when the event occurred
is distributed according to the binomial distribution. The probability
of that is {BinomialDistribution}{(p,n)}.

Describes the number of successes for draws with replacement.

Numerical value of {p} must satisfy $01) <-- Undefined;

%/mathpiper



%mathpiper_docs,name="BernoulliDistribution",categories="User Functions;Statistics & Probability"
*CMD BernoulliDistribution --- Bernoulli distribution
*STD
*CALL 
	BernoulliDistribution(p)

*PARMS

{p} -- number, probability of an event in a single trial

*DESC 
A random variable has a Bernoulli distribution with probability {p} if
it can be interpreted as an indicator of an event, where {p} is the
probability to observe the event in a single trial.

Numerical value of {p} must satisfy $0 StandardDeviation({73,94,80,37,57,94,40,21,7,26})
Result: Sqrt(88009/90)

In> N(StandardDeviation({73,94,80,37,57,94,40,21,7,26}))
Result: 31.271037366

*SEE Variance, UnbiasedVariance
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/hypothesystest/0000755000175000017500000000000011722677330030605 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/hypothesystest/ChiSquareTest.mpw0000644000175000017500000000714111502266107034051 0ustar  giovannigiovanni%mathpiper,def="ChiSquareTest"


/* ChiSquare's CDF is computed as IncompleteGamma(x,dof/2)/Gamma(dof/2); */

Retract(ChiSquareTest,*);


10 # ChiSquareTest( observedFrequenciesMatrix_IsMatrix, expectedFrequenciesMatrix_IsMatrix) <--
[

    Local(observedFrequenciesList, expectedFrequenciesList);
    
    observedFrequenciesList := Flatten(observedFrequenciesMatrix,"List");
    
    expectedFrequenciesList := Flatten(expectedFrequenciesMatrix,"List");
    
    Check(Length(observedFrequenciesList) > 0, "Argument", "The first argument must be a nonempty matrix.");
    
    Check(Length(expectedFrequenciesList) > 0, "Argument", "The second argument must be a nonempty matrix.");
    
    Check(Length(expectedFrequenciesList) = Length(expectedFrequenciesList), "Argument", "The matrices must be of equal length.");

    Local( numerator, chi2, pValue, categoriesCount, degreesOfFreedom, resultList);
   
    resultList := {};

    categoriesCount := Length(observedFrequenciesList);

    numerator := (observedFrequenciesList - expectedFrequenciesList)^2; //threading

    chi2 := Sum(i,1,categoriesCount,numerator[i]/(expectedFrequenciesList[i]));

    degreesOfFreedom := (Dimensions(observedFrequenciesMatrix)[1] - 1)*(Dimensions(observedFrequenciesMatrix)[2] - 1);

    pValue := 1-N(IncompleteGamma(degreesOfFreedom/2,chi2/2)/Gamma(degreesOfFreedom/2));

    resultList["degreesOfFreedom"] := degreesOfFreedom;
    
    resultList["pValue"] := pValue;
   
    resultList["chiSquareScore"] := chi2;
    
    N(resultList);
];




20 # ChiSquareTest( observedFrequenciesList_IsList, expectedFrequenciesList_IsList) <--
[
    Check(Length(observedFrequenciesList) > 0, "Argument", "The first argument must be a nonempty list.");
    
    Check(Length(expectedFrequenciesList) > 0, "Argument", "The second argument must be a nonempty list.");
    
    Check(Length(expectedFrequenciesList) = Length(expectedFrequenciesList), "Argument", "The lists must be of equal length.");

    Local( numerator, chi2, pValue, categoriesCount, degreesOfFreedom, resultList);
   
    resultList := {};

    categoriesCount := Length(observedFrequenciesList);

    numerator := (observedFrequenciesList - expectedFrequenciesList)^2; //threading

    chi2 := Sum(i,1,categoriesCount,numerator[i]/(expectedFrequenciesList[i]));

    degreesOfFreedom := categoriesCount - 1;

    pValue := 1-N(IncompleteGamma(degreesOfFreedom/2,chi2/2)/Gamma(degreesOfFreedom/2));

    resultList["degreesOfFreedom"] := degreesOfFreedom;
    
    resultList["pValue"] := pValue;
   
    resultList["chiSquareScore"] := chi2;
    
    N(resultList);
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="ChiSquareTest",categories="User Functions;Statistics & Probability"
*CMD ChiSquareTest --- Pearson's ChiSquare test
*STD

*CALL
	ChiSquareTest(observed,expected)

*PARMS
{observed} -- list of observed frequencies

{expected} -- list of expected frequencies

*DESC
{ChiSquareTest} is intended to determine if a sample was drawn from a
given distribution or not. To find this out, one has to calculate
observed frequencies into certain intervals and expected ones.

*E.G.
/%mathpiper,title=""

observedList := {145,128,73,32,22};

expectedList := {160,120,80,20,20};

a := ChiSquareTest(observedList, expectedList);

TableForm(a);

/%/mathpiper

    /%output,preserve="false"
      Result: True
      
      Side Effects:
      {"chiSquareScore",9.952083333}
      {"pValue",0.0412426135}
      {"degreesOfFreedom",4}
      
.   /%/output


*SEE AlphaToChiSquareScore, ChiSquareScoreToAlpha
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/statistics/randomtest.mpw0000644000175000017500000000125011321245544030362 0ustar  giovannigiovanni%mathpiper,def="",scope="nobuild",subtype="manual_test"

/*
  Tests MathPiper's Randomnumber generator
  Author Andrei Zorine, zoav1@uic.nnov.ru
*/

DefaultDerivtory("c:/src/ys/prob");
LoadScript("incompletegamma.mpi");
LoadScript("hypothesystest.mpi");


Function("DoTest",{size})
[
  Local(arr,o'f,e'f,i,j,m);
//  size:=200; // sample size
  arr := Table(Random(),i,1,size,1);
  arr := HeapSort(arr,"<");
  o'f := {};
  e'f :={};
  m:=1;
  For(i:=1, i<=10 And m<=size, i++)
   [
     j:=0;
     While(arr[m] 0 )[
    roots:=Transpose(e);
    consts:= MapSingle(Hold({{nn},Add(OdeConstantList(nn)*(x^(0 .. (nn-1))))}),roots[2]);
    roots:=roots[1];

    /* Return results */
    //Sum(consts * Exp(roots*x));
    Add( consts * Exp(roots*x) );
  ] else if ( Degree(auxeqn,x) = 2 ) [
    // we can solve second order equations without RootsWithMultiples
    Local(a,b,c,roots);
    roots:=ZeroVector(2);

    // this should probably be incorporated into RootsWithMultiples
    {c,b,a} := Coef(auxeqn,x,0 .. 2);


    roots := PSolve(a*x^2+b*x+c,x);
    If(InVerboseMode(),Echo("OdeSolve: Roots of quadratic:",roots) );

    // assuming real coefficients, the roots must come in a complex
    // conjugate pair, so we don't have to check both
    // also, we don't need to check to repeated root case, because
    // RootsWithMultiples (hopefully) catches those, except for
    // the case b,c=0

    if( b=0 And c=0 )[
	Add(OdeConstantList(2)*{1,x});
    ] else if( IsNumber(N(roots[1])) )[
	If(InVerboseMode(),Echo("OdeSolve: Real roots"));
	Add(OdeConstantList(2)*{Exp(roots[1]*x),Exp(roots[2]*x)});
    ] else [
      If(InVerboseMode(),Echo("OdeSolve: Complex conjugate pair roots"));
      Local(alpha,beta);
      alpha:=Re(roots[1]);
      beta:=Im(roots[1]);
      Exp(alpha*x)*Add( OdeConstantList(2)*{Sin(beta*x),Cos(beta*x)} );
    ];

  ] else [
    Echo("OdeSolve: Could not find roots of auxilliary equation");
  ];
];

// this croaks on Sin(x)*y'' because OdeMakeTerm does
10 # OdeOrder(_e) <-- [
	Local(h,i,coefs);

	coefs:=ZeroVector(10); //ugly
	e:=OdeNormalForm(e);

	If(InVerboseMode(),Echo("OdeSolve: Normal form is",e));
	h:=OdeFlatTerm(OdeCoefList(e));
	If(InVerboseMode(),Echo("OdeSolve: Flatterm is",h));

	// get the list of coefficients of the derivatives
	// in decreasing order
	coefs:=Reverse(FunctionToList(h)[3]);
	While( First(coefs) = 0 )[
		coefs:=Rest(coefs);
	];
	Length(coefs)-1;
];


10 # OdeSolve(_expr)_(OdeOrder(expr)=0)	    <-- Echo("OdeSolve: Not a differential equation");

// Solve the ever lovable seperable equation

10 # OdeSolve(y'+_a==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==expr-a);
10 # OdeSolve(y'-_a==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==expr+a);
10 # OdeSolve(y'/_a==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==expr*a);
10 # OdeSolve(_a*y'==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==expr/a);
10 # OdeSolve(y'*_a==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==expr/a);
10 # OdeSolve(_a/y'==_expr)_(IsFreeOf(y,a)) <-- OdeSolve(y'==a/expr);

// only works for low order equations
10 # OdeSolve(y'==_expr)_(IsFreeOf({y,y',y''},expr)) <--
[
	If(InVerboseMode(),Echo("OdeSolve: Integral in disguise!"));
	If(InVerboseMode(),Echo("OdeSolve: Attempting to integrate ",expr));

	(Integrate(x) expr)+UniqueConstant();
];

50 # OdeSolve(_e) <--
[
  Local(h);
  e:=OdeNormalForm(e);
  If(InVerboseMode(),Echo("OdeSolve: Normal form is",e));
  h:=OdeFlatTerm(OdeCoefList(e));
  If(InVerboseMode(),Echo("OdeSolve: Flatterm is",h));
  if (IsFreeOf(Error,h))
  [
    OdeSolveLinear(e,h);
  ]
  else
    OdeUnsolved(e);
];

10 # OdeSolveLinear(_e,OdeTerm(0,_list))_(Length(VarList(list)) = 0) <--
[
  OdeSolveLinearHomogeneousConstantCoefficients(OdeNormalForm(e));
];

100 # OdeSolveLinear(_e,_ode) <-- OdeUnsolved(e);

OdeUnsolved(_e) <-- Subst(yyy,y)e;



/*
FT3(_e) <--
[
  e:=OdeNormalForm(e);
Echo({e});
  e:=OdeCoefList(e);
Echo({e});
  e:=OdeFlatTerm(e);
Echo({e});
  e;
];
OdeBoundaries(_solution,bounds_IsList) <--
[
];
*/

OdeTest(_e,_solution) <--
[
  Local(s);
  s:= `Lambda({n},if (n>0)(Differentiate(x,n)(@solution)) else (@solution));
  e:=OdeNormalForm(e);
  e:=Apply("OdeSubstitute",{e,s});
  e:=Simplify(e);
  e;
];

%/mathpiper



%mathpiper_docs,name="OdeSolve",categories="User Functions;Differential Equations"
*CMD OdeSolve --- general ODE solver
*STD
*CALL
	OdeSolve(expr1==expr2)
*PARMS

{expr1,expr2} -- expressions containing a function to solve for

*DESC

This function currently can solve second order homogeneous linear real constant
coefficient equations. The solution is returned with unique constants
generated by {UniqueConstant}. The roots of the auxiliary equation are 
used as the arguments of exponentials. If the roots are complex conjugate
pairs, then the solution returned is in the form of exponentials, sines
and cosines.

First and second derivatives are entered as {y',y''}. Higher order derivatives
may be entered as {y(n)}, where {n} is any integer. 


*E.G.

In> OdeSolve( y'' + y == 0 )
Result: C42*Sin(x)+C43*Cos(x);
In> OdeSolve( 2*y'' + 3*y' + 5*y == 0 )
Result: Exp(((-3)*x)/4)*(C78*Sin(Sqrt(31/16)*x)+C79*Cos(Sqrt(31/16)*x));
In> OdeSolve( y'' - 4*y == 0 )
Result: C132*Exp((-2)*x)+C136*Exp(2*x);
In> OdeSolve( y'' +2*y' + y == 0 )
Result: (C183+C184*x)*Exp(-x);

*SEE Solve, RootsWithMultiples
%/mathpiper_docs



%mathpiper_docs,name="OdeTest",categories="User Functions;Differential Equations"
*CMD OdeTest --- test the solution of an ODE
*STD
*CALL
	OdeTest(eqn,testsol)
*PARMS

{eqn} -- equation to test

{testsol} -- test solution

*DESC

This function automates the verification of the solution of an ODE.
It can also be used to quickly see how a particular equation operates
on a function.

*E.G.

In> OdeTest(y''+y,Sin(x)+Cos(x))
Result: 0;
In> OdeTest(y''+2*y,Sin(x)+Cos(x))
Result: Sin(x)+Cos(x);

*SEE OdeSolve
%/mathpiper_docs



%mathpiper_docs,name="OdeOrder",categories="User Functions;Differential Equations"
*CMD OdeOrder --- return order of an ODE
*STD
*CALL
	OdeOrder(eqn)
*PARMS

{eqn} -- equation 

*DESC

This function returns the order of the differential equation, which is
order of the highest derivative. If no derivatives appear, zero is returned.

*E.G.

In> OdeOrder(y'' + 2*y' == 0)
Result: 2;
In> OdeOrder(Sin(x)*y(5) + 2*y' == 0)
Result: 5;
In> OdeOrder(2*y + Sin(y) == 0)
Result: 0;

*SEE OdeSolve
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/0000755000175000017500000000000011722677336023711 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/TableForm.mpw0000644000175000017500000000122111523200452026261 0ustar  giovannigiovanni%mathpiper,def="TableForm"

Function("TableForm",{list})
[
  Local(i);
  ForEach(i,list)
  [
    Write(i);
    NewLine();
  ];
  True;
];

%/mathpiper




%mathpiper_docs,name="TableForm",categories="User Functions;Lists (Operations)"
*CMD TableForm --- print each entry in a list on a line
*STD
*CALL
	TableForm(list)

*PARMS

{list} -- list to print

*DESC

This functions writes out the list {list} in a better readable form, by
printing every element in the list on a separate line.

*E.G.

In> TableForm(Table(i!, i, 1, 10, 1));

	1
	 2
	 6
	 24
	 120
	 720
	 5040
	 40320
	 362880
	 3628800
Result: True;

*SEE PrettyForm, Echo, Table
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/IsError.mpw0000644000175000017500000000151411502303630025777 0ustar  giovannigiovanni%mathpiper,def="IsError"

/// check for errors
IsError() <--
[
	CheckErrorTableau();
	Length(GetErrorTableau())>0;
];

/// check for errors of a given kind
IsError(error'class_IsString) <--
[
	CheckErrorTableau();
	GetErrorTableau()[error'class] != Empty;
];

%/mathpiper




%mathpiper_docs,name="IsError",categories="Programmer Functions;Error Reporting;Predicates",access="private"
*CMD IsError --- check for custom error
*STD
*CALL
	IsError()
	IsError("str")

*PARMS

{"str"} -- string to classify the error

*DESC

{IsError()} returns {True} if any custom errors have been reported using {Assert}.
The second form takes a parameter {"str"} that designates the class of the
error we are interested in. It returns {True} if any errors of the given class
{"str"} have been reported.

*SEE GetError, ClearError, Assert, Check

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/DumpErrors.mpw0000644000175000017500000000253611502303630026521 0ustar  giovannigiovanni%mathpiper,def="DumpErrors"

/// print all errors and clear the tableau
DumpErrors() <--
[
	Local(error'object, error'word);
	CheckErrorTableau();
	ForEach(error'object, GetErrorTableau())
	[	// error'object might be e.g. {"critical", {"bad bad", -1000}}
		If(
			IsList(error'object),
			[
				If( // special case: error class "warning"
					Length(error'object) > 0 And error'object[1] = "warning",
					[
						error'word := "Warning";
						error'object[1] := "";	// don't print the word "warning" again
					],
					error'word := "Error: "	// important hack: insert ": " here but not after "Warning"
				);

				If(	// special case: {"error'class", True}
					Length(error'object)=2 And error'object[2]=True,
					Echo(error'word, error'object[1]),
					[
						Echo(error'word, error'object[1], ": ",
							PrintList(Rest(error'object)));
					]
				);
			],
			// error'object is not a list: just print it
			Echo("Error: ", error'object)
		);
	];
	ClearErrors();
];

%/mathpiper




%mathpiper_docs,name="DumpErrors",categories="Programmer Functions;Error Reporting",access="private"
*CMD DumpErrors --- simple error handlers
*STD
*CALL
	DumpErrors()

*DESC

{DumpErrors} is a simple error handler for the global error reporting mechanism. It prints all errors posted using {Assert} and clears the error tableau.

*SEE Assert, IsError, ClearErrors

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/GetErrorTableau.mpw0000644000175000017500000000464611523200452027453 0ustar  giovannigiovanni%mathpiper,def="GetErrorTableau;ClearErrors;GetError"

/* def file definitions
ClearErrors
GetError
*/

//////////////////////////////////////////////////
/// ErrorTableau, Assert, IsError --- global error reporting
//////////////////////////////////////////////////

LocalSymbols(ErrorTableau) [

  /// global error tableau. Its entries do not have to be lists.
  Bind(ErrorTableau, {});

  GetErrorTableau() := ErrorTableau;

  ClearErrors() <-- Bind(ErrorTableau, {});

  /// aux function to check for corrupt tableau
  CheckErrorTableau() <--
  If(
    Not IsList(ErrorTableau),
    Bind(ErrorTableau, {{"general", "corrupted ErrorTableau"}})
  );

]; // LocalSymbols(ErrorTableau)


/// obtain error object
GetError(error'class_IsString) <--
[
	Local(error);
	error := GetErrorTableau()[error'class];
	If(
		error != Empty,
		error,
		False
	);
];


/// delete error
ClearError(error'class_IsString) <-- AssocDelete(GetErrorTableau(), error'class);

%/mathpiper




%mathpiper_docs,name="ClearErrors",categories="Programmer Functions;Error Reporting",access="private"
*CMD ClearErrors --- simple error handlers
*STD
*CALL
	ClearErrors()

*DESC

{ClearErrors} is a trivial error handler that does nothing except it clears the tableau.

*SEE Assert, IsError, DumpErrors

%/mathpiper_docs




%mathpiper_docs,name="GetError;ClearError;GetErrorTableau",categories="Programmer Functions;Error Reporting",access="private"
*CMD GetError --- custom errors handlers
*CMD ClearError --- custom errors handlers
*CMD GetErrorTableau --- custom errors handlers
*STD
*CALL
	GetError("str")
	ClearError("str")
	GetErrorTableau()

*PARMS

{"str"} -- string to classify the error

*DESC

These functions can be used to create a custom error handler.

{GetError} returns the error object if a custom error of class {"str"} has been
reported using {Assert}, or {False} if no errors of this class have been
reported.

{ClearError("str")} deletes the same error object that is returned by
{GetError("str")}. It deletes at most one error object. It returns {True} if an
object was found and deleted, and {False} otherwise.

{GetErrorTableau()} returns the entire association list of currently reported errors.

*E.G.

In> x:=1
Result: 1;
In> Assert("bad value", {x,"must be zero"}) x=0
Result: False;
In> GetError("bad value")
Result: {1, "must be zero"};
In> ClearError("bad value");
Result: True;
In> IsError()
Result: False;

*SEE IsError, Assert, Check, ClearErrors

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/Tell.mpw0000644000175000017500000000335211523200452025315 0ustar  giovannigiovanni%mathpiper,def="Tell"
Macro("Tell",{id})    [Echo(<<,@id,>>);];
Macro("Tell",{id,x})  [Echo(<<,@id,>>,Hold(@x),": ",Eval(@x));];
%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

%mathpiper_docs,name="Tell",categories="Programmer Functions;Testing"

*CMD Tell --- debug routine using Echo to print ID and (optional) variable(s)

*STD
*CALL
	Tell(ID)
	Tell(ID,list)

*PARMS

{ID} -- an arbitrary identifier for this printout

{list} -- a list of items to be printed (may be a single item)

*DESC

If passed a single item, {Tell} will display it using Echo().  
The dispayed value will be enclosed with << >> (see below).
If ID consists of more than one word, it should be quoted.

If there are two arguments, the first should be an ID as above, and the second 
should be a list of variables which are bound to values at the place where
{Tell} is called.  Using Echo(), the list of variable names will be printed
out, along with a list of their currently bound values.

{Tell} can be called with any number of variable names in the list.

{Tell} always returns {True}.

Because {Tell} uses Echo(), it prints to Standard Output.  If you are debuging
a program which may hang, you may get no printout.  In that case, use {Show}
instead of {Tell}

*E.G. notest
In> var1:=123
Result: 123
In> var2:= "a string"
Result: "a string"
In> var3:=Sin(x)+Exp(x)
Result: Sin(x)+Exp(x)
In> Tell(ID1)
Result: True
	Side Effects>
	<< ID1 >>
In> Tell(ID2,{var1})
Result: True
	Side Effects>
	<< ID2 >> {var1} :  {123} 
In> Tell(ID3,{var1,var2})
Result: True
	Side Effects>
	<< ID3 >> {var1,var2} {123,"a string"} 
In> Tell(ID4,{var1,var2,var3})
Result: True
	Side Effects>
	<< ID4 >> {var1,var2,var3} :  {123,"a string",Sin(x)+Exp(x)} 


*SEE Show
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/Show.mpw0000644000175000017500000000376111523200452025341 0ustar  giovannigiovanni%mathpiper,def="Show"
Macro("Show",{id})    [SysOut("<< ",@id," >>");];
Macro("Show",{id,x})  [SysOut("<< ",@id," >> ",Hold(@x),": ",Eval(@x));];
%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

%mathpiper_docs,name="Show",categories="Programmer Functions;Testing"

*CMD Show --- debug routine using SysOut to print ID and (optional) variable(s)

*STD
*CALL
	Show(ID)
	Show(ID,list)

*PARMS

{ID} -- an arbitrary identifier for this printout

{list} -- a list of items to be printed (may be a single item)

*DESC

If passed a single item, {Show} will display it using SysOut().  
The dispayed value will be enclosed with << >> (see below).
If ID consists of more than one word, it should be quoted.

If there are two arguments, the first should be an ID as above, and the second 
should be a list of variables which are bound to values at the place where
{Show} is called.  Using SysOut(), the list of variable names will be printed
out, along with a list of their currently bound values.

{Show} can be called with any number of variable names in the list.

{Show} always returns {True}.

Because {Show} uses SysOut() to print its output, the output will be visible
both on Standard Output and also on the Shell console (if MathPiper is started
this way), or on the MathPiperIDE Activity Log (if started in MathPiperIDE).  
The latter is very useful for debugging programs which hang in a loop or
otherwise, because standard output may not then be visible, but the alternative
output will usually be available.

*E.G. notest
In> var1:=123
Result: 123
In> var2:= "a string"
Result: "a string"
In> var3:=Sin(x)+Exp(x)
Result: Sin(x)+Exp(x)
In> Show(ID1)
Result: True
	Side Effects>
	<< ID1 >>
In> Show(ID2,{var1})
Result: True
	Side Effects>
	<< ID2 >> {var1}:  {123}
In> Show(ID3,{var1,var2})
Result: True
	Side Effects>
	<< ID3 >> {var1,var2}:  {123,a string}
In> Show(ID4,{var1,var2,var3})
Result: True
	Side Effects>
	<< ID4 >> {var1,var2,var3}:  {123,a string,Sin(x)+Exp(x)}

*SEE Tell
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/Print.mpw0000644000175000017500000000470011321740611025511 0ustar  giovannigiovanni%mathpiper,def="Print"


/* A reference print implementation. Expand at own leisure.
 *
 * This file implements Print, a scripted expression printer.
 */


/* 60000 is the maximum precedence allowed for operators */
10 # Print(_x) <--
[
  Print(x,60000);
  NewLine();
  DumpErrors();
];

/* Print an argument within an environment of precedence n */
10 # Print(x_IsAtom,_n) <-- Write(x);
10 # Print(_x,_n)_(IsInfix(Type(x))And ArgumentsCount(x) = 2) <--
[
  Local(bracket);
  bracket:= (PrecedenceGet(Type(x)) > n);
  If(bracket,WriteString("("));
  Print(x[1],LeftPrecedenceGet(Type(x)));
  Write(x[0]);
  Print(x[2],RightPrecedenceGet(Type(x)));
  If(bracket,WriteString(")"));
];

10 # Print(_x,_n)_(IsPrefix(Type(x)) And ArgumentsCount(x) = 1) <--
[
  Local(bracket);
  bracket:= (PrecedenceGet(Type(x)) > n);
  Write(x[0]);
  If(bracket,WriteString("("));
  Print(x[1],RightPrecedenceGet(Type(x)));
  If(bracket,WriteString(")"));
];

10 # Print(_x,_n)_(IsPostfix(Type(x))And ArgumentsCount(x) = 1) <--
[
  Local(bracket);
  bracket:= (PrecedenceGet(Type(x)) > n);
  If(bracket,WriteString("("));
  Print(x[1],LeftPrecedenceGet(Type(x)));
  Write(x[0]);
  If(bracket,WriteString(")"));
];

20 # Print(_x,_n)_(Type(x) = "List") <--
[
  WriteString("{");
  PrintArg(x);
  WriteString("}");
];

20 # Print(_x,_n)_(Type(x) = "Prog") <--
[
  WriteString("[");
  PrintArgProg(Rest(FunctionToList(x)));
  WriteString("]");
];
20 # Print(_x,_n)_(Type(x) = "Nth") <--
[
  Print(x[1],0);
  WriteString("[");
  Print(x[2],60000);
  WriteString("]");
];

100 # Print(x_IsFunction,_n) <--
 [
   Write(x[0]);
   WriteString("(");
   PrintArg(Rest(FunctionToList(x)));
   WriteString(")");
 ];


/* Print the arguments of an ordinary function */
10 # PrintArg({}) <-- True;

20 # PrintArg(_list) <--
[
  Print(First(list),60000);
  PrintArgComma(Rest(list));
];
10 # PrintArgComma({}) <-- True;
20 # PrintArgComma(_list) <--
[
  WriteString(",");
  Print(First(list),60000);
  PrintArgComma(Rest(list));
];


18 # Print(Complex(0,1),_n)   <-- [WriteString("I");];
19 # Print(Complex(0,_y),_n)  <-- [WriteString("I*");Print(y,4);];
19 # Print(Complex(_x,1),_n)  <-- [Print(x,7);WriteString("+I");];
20 # Print(Complex(_x,_y),_n) <-- [Print(x,7);WriteString("+I*");Print(y,4);];


/* Tail-recursive printing the body of a compound statement */
10 # PrintArgProg({}) <-- True;
20 # PrintArgProg(_list) <--
[
   Print(First(list),60000);
   WriteString(";");
   PrintArgProg(Rest(list));
];








%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/Echo.mpw0000644000175000017500000000354611517224250025305 0ustar  giovannigiovanni%mathpiper,def="Echo"

//Retract("EchoInternal",*);

10 # EchoInternal(string_IsString) <--
[
  WriteString(string);
];

20 # EchoInternal(_item) <--
[
  Write(item);Space();
];






//Retract("Echo",*);

RulebaseListed("Echo",{firstParameter, parametersList});

//Handle no option call.
5 # Echo(_firstParameter) <-- Echo(firstParameter, {});


//Main routine.  It will automatically accept 1 or more option calls because the
//options come in a list.
10 # Echo(_firstParameter, parametersList_IsList) <--
[
    EchoInternal(firstParameter);
    ForEach(item,parametersList) EchoInternal(item);
    NewLine();
    
];


//Handle a single option call because the option does not come in a list for some reason.
20 # Echo(_firstParameter, _secondParameter) <-- Echo(firstParameter, {secondParameter});


//No argument Echo simply prints a newline.
Echo() := NewLine();



%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="Echo",categories="User Functions;Input/Output"
*CMD Echo --- high-level printing routine
*STD
*CALL
	Echo(item,item,item,...)

*PARMS

{item} -- the items to be printed


*DESC

If passed a single item, {Echo} will evaluate it and print it to the
current output, followed by a newline. If {item} is a string, it is
printed without quotation marks.

If {Echo} is called with a variable number of arguments, they will all
be printed with spaces inbetween them and finally a newline will be printed.

If no arguments are passed to {Echo}, it will simply output a newline.

{Echo} always returns {True}.

*E.G.
In> Echo(5+3);
Result: True
Side Effects:
8 


In> Echo("The square of two is ", 2*2);
Result: True
Side Effects:
The square of two is 4 


In> Echo({a,b,c});
Result: True
Side Effects:
{a,b,c} 

*SEE PrettyForm, Write, WriteString, RulebaseListed
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/DefaultPrint.mpw0000644000175000017500000000035011422223770027017 0ustar  giovannigiovanni%mathpiper,def="DefaultPrint"

/// The new default pretty-printer: DefaultPrint
Function("DefaultPrint", {x})
[
	DumpErrors();
	WriteString("Result: ");
	Write(x);
	WriteString(";
");
];
HoldArgument("DefaultPrint", x);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/io/Assert.mpw0000644000175000017500000000577211523200452025666 0ustar  giovannigiovanni%mathpiper,def="Assert"

/// post an error if assertion fails
(Assert(_error'class, _error'object) _predicate) <--
[
	CheckErrorTableau();
	If(IsEqual(predicate, True),	// if it does not evaluate to True, it's an error
		True,
		[	// error occurred, need to post error'object
			DestructiveAppend(GetErrorTableau(), {error'class, error'object});
			False;
		]
	);
];

/// interface
(Assert(_error'class) _predicate) <-- Assert(error'class, True) predicate;

/// interface
(Assert() _predicate) <-- Assert("generic", True) predicate;

%/mathpiper



%mathpiper_docs,name="Assert",categories="Programmer Functions;Error Reporting",access="private"
*CMD Assert --- signal "soft" custom error
*STD
*CALL
	Assert("str", expr) pred
	Assert("str") pred
	Assert() pred
Precedence:
*EVAL PrecedenceGet("Assert")

*PARMS

{pred} -- predicate to check

{"str"} -- string to classify the error

{expr} -- expression, error object

*DESC

{Assert} is a global error reporting mechanism. It can be used to check for
errors and report them. An error is considered to occur when the predicate
{pred} evaluates to anything except {True}. In this case, the function returns
{False} and an error object is created and posted to the global error tableau.
Otherwise the function returns {True}.

Unlike the "hard" error function {Check}, the function {Assert} does not stop
the execution of the program.

The error object consists of the string {"str"} and an arbitrary
expression {expr}. The string should be used to classify the kind of error that
has occurred, for example "domain" or "format". The error object can be any expression that might be useful for handling the error later;
for example, a list of erroneous values and explanations.
The association list of error objects is currently obtainable through
the function {GetErrorTableau()}.

If the parameter {expr} is missing, {Assert} substitutes {True}. If both optional parameters {"str"} and {expr} are missing, {Assert} creates an error of class {"generic"}.

Errors can be handled by a
custom error handler in the portion of the code that is able to handle a certain class of
errors. The functions {IsError}, {GetError} and {ClearError} can be used.

Normally, all errors posted to the error tableau during evaluation of an expression should
be eventually printed to the screen. This is the behavior of prettyprinters
{DefaultPrint}, {Print}, {PrettyForm} and {TeXForm} (but not of the
inline prettyprinter, which is enabled by default); they call
{DumpErrors} after evaluating the expression.

*E.G.

In> Assert("bad value", "must be zero") 1=0
Result: False;
In> Assert("bad value", "must be one") 1=1
Result: True;
In> IsError()
Result: True;
In> IsError("bad value")
Result: True;
In> IsError("bad file")
Result: False;
In> GetError("bad value");
Result: "must be zero";
In> DumpErrors()
	Error: bad value: must be zero
Result: True;
No more errors left:
In> IsError()
Result: False;
In> DumpErrors()
Result: True;

*SEE IsError, DumpErrors, Check, GetError, ClearError, ClearErrors, GetErrorTableau

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deriv/0000755000175000017500000000000011722677333024410 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deriv/Differentiate.mpw0000644000175000017500000000511111523200452027663 0ustar  giovannigiovanni%mathpiper,def="Differentiate"

Rulebase("Differentiate",{aVar,aFunc});
Rulebase("Differentiate",{aVar,aCount,aFunc});

Rule("Differentiate",2,1,IsList(aVar) And Not(IsList(aFunc)))
	Map("Differentiate",{aVar,FillList(aFunc, Length(aVar))});
Rule("Differentiate",2,1,IsList(aVar) And IsList(aFunc))
	Map("Differentiate",{aVar,aFunc});

Rule("Differentiate",2,3,True)
[
  MacroLocal(aVar);
  Apply("Deriv",{aVar,1,aFunc});
];

Rule("Differentiate",3,1,IsList(aVar) And Not(IsList(aFunc)))
	Map("Differentiate",{aVar,
                 FillList(aCount, Length(aVar)),
                 FillList(aFunc, Length(aVar))});
Rule("Differentiate",3,1,IsList(aVar) And IsList(aFunc))
	Map("Differentiate",{aVar,
                 FillList(aCount, Length(aVar)),
                 aFunc});
Rule("Differentiate",3,3,True)
[
  MacroLocal(aVar);
  Apply("Deriv",{aVar,aCount,aFunc});
];


HoldArgument("Differentiate",aVar);
HoldArgument("Differentiate",aFunc);

%/mathpiper



%mathpiper_docs,name="Differentiate",categories="User Functions;Calculus Related (Symbolic)"
*CMD Differentiate --- take derivative of expression with respect to variable
*STD
*CALL
	Differentiate(variable) expression
	Differentiate(list) expression
	Differentiate(variable,n) expression

*PARMS

{variable} -- variable

{list} -- a list of variables

{expression} -- expression to take derivatives of

{n} -- order of derivative

*DESC

This function calculates the derivative of the expression {expr} with
respect to the variable {var} and returns it. If the third calling
format is used, the {n}-th derivative is determined. MathPiper knows
how to differentiate standard functions such as {Ln}
and {Sin}.

The {D} operator is threaded in both {var} and
{expr}. This means that if either of them is a list, the function is
applied to each entry in the list. The results are collected in
another list which is returned. If both {var} and {expr} are a
list, their lengths should be equal. In this case, the first entry in
the list {expr} is differentiated with respect to the first entry in
the list {var}, the second entry in {expr} is differentiated with
respect to the second entry in {var}, and so on.

The {D} operator returns the original function if $n=0$, a common
mathematical idiom that simplifies many formulae.

*E.G.

In> Differentiate(x)Sin(x*y)
Result: y*Cos(x*y);
In> Differentiate({x,y,z})Sin(x*y)
Result: {y*Cos(x*y),x*Cos(x*y),0};
In> Differentiate(x,2)Sin(x*y)
Result: -Sin(x*y)*y^2;
In> Differentiate(x){Sin(x),Cos(x)}
Result: {Cos(x),-Sin(x)};

*SEE Integrate, Taylor, Diverge, Curl
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deriv/Curl.mpw0000644000175000017500000000216511523200452026025 0ustar  giovannigiovanni%mathpiper,def="Curl"

Rulebase("Curl", {aFunc, aBasis});

Rule("Curl", 2, 1, Length(aBasis)=Length(aFunc))
	{
		Apply("Differentiate",{aBasis[2],aFunc[3]})-Apply("Differentiate",{aBasis[3],aFunc[2]}),
		Apply("Differentiate",{aBasis[3],aFunc[1]})-Apply("Differentiate",{aBasis[1],aFunc[3]}),
		Apply("Differentiate",{aBasis[1],aFunc[2]})-Apply("Differentiate",{aBasis[2],aFunc[1]})
	};

%/mathpiper



%mathpiper_docs,name="Curl",categories="User Functions;Calculus Related (Symbolic)"
*CMD Curl --- curl of a vector field
*STD
*CALL
	Curl(vector, basis)

*PARMS

{vector} -- vector field to take the curl of

{basis} -- list of variables forming the basis

*DESC

This function takes the curl of the vector field "vector" with
respect to the variables "basis". The curl is defined in the usual way,

	Curl(f,x) = {
	    Differentiate(x[2]) f[3] - Differentiate(x[3]) f[2],
	    Differentiate(x[3]) f[1] - Differentiate(x[1]) f[3],
	    Differentiate(x[1]) f[2] - Differentiate(x[2]) f[1]
	}
Both "vector" and "basis" should be lists of length 3.

*E.G.

In> Curl({x*y,x*y,x*y},{x,y,z})
Result: {x,-y,y-x};

*SEE D, Diverge
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deriv/Deriv.mpw0000644000175000017500000000652411502266107026202 0ustar  giovannigiovanni%mathpiper,def="Deriv"


5 # (Deriv(_var,1)_func) <-- Deriv(var)func;
5 # (Deriv(_var,0)_func) <-- func;
10 # (Deriv(_var,n_IsPositiveInteger)_func) <-- Deriv(var)Deriv(var,n-1)func;
10 # (Deriv(_var,n_IsNegativeInteger)_func) <-- Check(0, "Math", "Negative derivative");


// Need to clean out Sec(x) and friends
0 # (Deriv(_var) (_var)) <-- 1;
1 # (Deriv(_var)func_IsAtom) <-- 0;
2 # (Deriv(_var)_x + _y) <--  (Deriv(var)x) + (Deriv(var)y);
2 # (Deriv(_var)- (_x) ) <-- -Deriv(var)x;
2 # (Deriv(_var)_x - _y) <--  (Deriv(var)x) - (Deriv(var)y);
2 # (Deriv(_var)_x * _y) <-- (x*Deriv(var)y) + (Deriv(var)x)*y;
2 # (Deriv(_var)Sin(_x)) <--  (Deriv(var)x)*Cos(x);
2 # (Deriv(_var)Sinh(_x))<--  (Deriv(var)x)*Cosh(x);
2 # (Deriv(_var)Cosh(_x))<--  (Deriv(var)x)*Sinh(x);
2 # (Deriv(_var)Cos(_x)) <-- -(Deriv(var)x)*Sin(x);
2 # (Deriv(_var)Csc(_x)) <--  -(Deriv(var)x)*Csc(x)*Cot(x);
2 # (Deriv(_var)Csch(_x)) <-- -(Deriv(var)x)*Csch(x)*Coth(x);
2 # (Deriv(_var)Sec(_x)) <--  (Deriv(var)x)*Sec(x)*Tan(x);
2 # (Deriv(_var)Sech(_x)) <-- -(Deriv(var)x)*Sech(x)*Tanh(x);
2 # (Deriv(_var)Cot(_x)) <--  -(Deriv(var)x)*Csc(x)^2;
2 # (Deriv(_var)Coth(_x)) <--  (Deriv(var)x)*Csch(x)^2;

2 # (Deriv(_var)Tan(_x)) <-- ((Deriv(var) x) / (Cos(x)^2));
2 # (Deriv(_var)Tanh(_x)) <-- (Deriv(var)x)*Sech(x)^2;

2 # (Deriv(_var)Exp(_x)) <--  (Deriv(var)x)*Exp(x);

// When dividing by a constant, this is faster
2 # (Deriv(_var)(_x / _y))_(IsFreeOf(var,y)) <-- (Deriv(var) x) / y;
3 # (Deriv(_var)(_x / _y)) <--
    (y* (Deriv(var) x) - x* (Deriv(var) y))/ (y^2);

2 # (Deriv(_var)Ln(_x)) <-- ((Deriv(var) x) / x);
2 # (Deriv(_var)(_x ^ _n))_(IsRationalOrNumber(n) Or IsFreeOf(var, n)) <--
    n * (Deriv(var) x) * (x ^ (n - 1));

//2 # (Deriv(_var)(Abs(_x)))  <-- Sign(x)*(Deriv(var)x);
2 # (Deriv(_var)(Abs(_x)))  <-- (x/Abs(x))*(Deriv(var)x);
2 # (Deriv(_var)(Sign(_x))) <-- 0;

2 # (Deriv(_var)(if(_cond)(_body))) <--
	ListToFunction({ToAtom("if"),cond,Deriv(var)body});
2 # (Deriv(_var)((_left) else (_right))) <--
        ListToFunction({ToAtom("else"), (Deriv(var)left), (Deriv(var)right) } );

3 # (Deriv(_var)(_x ^ _n)) <-- (x^n)*Deriv(var)(n*Ln(x));

2 # (Deriv(_var)ArcSin(_x)) <-- (Deriv(var) x)/Sqrt(1 - (x^2));
2 # (Deriv(_var)ArcCos(_x)) <-- -(Deriv(var)x)/Sqrt(1 - (x^2));
2 # (Deriv(_var)ArcTan(_x)) <-- (Deriv(var) x)/(1 + x^2);

2 # (Deriv(_var)ArcSinh(_x)) <-- (Deriv(var) x)/Sqrt((x^2) + 1);
2 # (Deriv(_var)ArcCosh(_x)) <-- (Deriv(var) x)/Sqrt((x^2) - 1);
2 # (Deriv(_var)ArcTanh(_x)) <-- (Deriv(var) x)/(1 - x^2);

2 # (Deriv(_var)Sqrt(_x)) <-- ((Deriv(var)x)/(2*Sqrt(x)));
2 # (Deriv(_var)Complex(_r,_i)) <-- Complex(Deriv(var)r,Deriv(var)i);

LocalSymbols(var,var2,a,b,y)[
   2 # (Deriv(_var)Integrate(_var)(_y)) <-- y;
   2 # (Deriv(_var)Integrate(_var2,_a,_b)(y_IsFreeOf(var))) <--
         (Deriv(var)b)*(y Where var2 == b) -
         (Deriv(var)a)*(y Where var2 == a);
   3 # (Deriv(_var)Integrate(_var2,_a,_b)(_y)) <--
         (Deriv(var)b)*(y Where var2 == b) -
         (Deriv(var)a)*(y Where var2 == a) +
 	Integrate(var2,a,b) Deriv(var) y;
 ];



2 # (Deriv(_var)func_IsList)_(Not(IsList(var))) <--
    Map("Deriv",{FillList(var,Length(func)),func});


2 # (Deriv(_var)UniVariate(_var,_first,_coefs)) <--
[
  Local(result,m,i);
  result:=FlatCopy(coefs);
  m:=Length(result);
  For(i:=1,i<=m,i++)
  [
    result[i] := result[i] * (first+i-1);
  ];
  UniVariate(var,first-1,result);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/deriv/Diverge.mpw0000644000175000017500000000161111523200452026500 0ustar  giovannigiovanni%mathpiper,def="Diverge"

Rulebase("Diverge", {aFunc, aBasis});
Rule("Diverge", 2, 1, IsList(aBasis) And IsList(aFunc) And Length(aBasis) = Length(aFunc))
	Add(Map("Differentiate", {aBasis,aFunc}));

%/mathpiper



%mathpiper_docs,name="Diverge",categories="User Functions;Calculus Related (Symbolic)"
*CMD Diverge --- divergence of a vector field
*STD
*CALL
	Diverge(vector, basis)

*PARMS

{vector} -- vector field to calculate the divergence of

{basis} -- list of variables forming the basis

*DESC

This function calculates the divergence of the vector field "vector"
with respect to the variables "basis". The divergence is defined as

	Diverge(f,x) = Differentiate(x[1]) f[1] + ...
	    + Differentiate(x[n]) f[n],
where {n} is the length of the lists "vector" and
"basis". These lists should have equal length.

*E.G.

In> Diverge({x*y,x*y,x*y},{x,y,z})
Result: y+x;

*SEE D, Curl
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/substitute/0000755000175000017500000000000011722677337025516 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/substitute/Substitute.mpw0000644000175000017500000000072611371733712030411 0ustar  giovannigiovanni%mathpiper,def="Substitute"

Function("Substitute",{body,predicate,change})
[
  Substitute(body);
];
HoldArgument("Substitute",predicate);
HoldArgument("Substitute",change);
UnFence("Substitute",3);
Rulebase("Substitute",{body});
UnFence("Substitute",1);

Rule("Substitute",1,1,Apply(predicate,{body}) = True)
[
  Apply(change,{body});
];
Rule("Substitute",1,2,IsFunction(body))
[
  Apply("MapArgs",{body,"Substitute"});
];
Rule("Substitute",1,3,True) body;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/substitute/MacroSubstitute.mpw0000644000175000017500000000151611523146134031364 0ustar  giovannigiovanni%mathpiper,def="MacroSubstitute"

/*Extremely hacky workaround, MacroSubstitute is actually the same as Substitute,
  but without re-evaluating its arguments. I could not just change Substitute, as
  it changed behaviour such that tests started to break.
 */
Function("MacroSubstitute",{body,predicate,change})
[
  `MacroSubstitute((Hold(@body)));
];
HoldArgument("MacroSubstitute",predicate);
HoldArgument("MacroSubstitute",change);
UnFence("MacroSubstitute",3);
Rulebase("MacroSubstitute",{body});
UnFence("MacroSubstitute",1);

Rule("MacroSubstitute",1,1,`ApplyFast(predicate,{Hold(Hold(@body))}) = True)
[
  `ApplyFast(change,{Hold(Hold(@body))});
];
Rule("MacroSubstitute",1,2,`IsFunction(Hold(@body)))
[
  `ApplyFast("MacroMapArgs",{Hold(Hold(@body)),"MacroSubstitute"});
];
Rule("MacroSubstitute",1,3,True)
[
 `Hold(@body);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/rabinmiller/0000755000175000017500000000000011722677332025576 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/rabinmiller/RabinMiller.mpw0000644000175000017500000001244111427110063030506 0ustar  giovannigiovanni%mathpiper,def="RabinMiller"

/*
 * File `rabinmiller.mpi' is an implementation of the
 *           Rabin-Miller primality test.
 */


/*
 * FastModularPower(a, b, n) computes a^b (mod n) efficiently.
 * This function is called by IsStronglyProbablyPrime.
 */

FastModularPower(a_IsPositiveInteger, b_IsPositiveInteger, n_IsPositiveInteger) <--
[
  Local(p, j, r);
  p := a;
  j := b;
  r := 1;

  While (j > 0)
    [
      If (IsOdd(j), r := ModuloN(r*p, n));
      p := ModuloN(p*p, n);
      j := ShiftRight(j, 1);
    ];
  r;
];


/*
 * An integer n is `strongly-probably-prime' for base b if
 *
 *                   b^q = 1 (mod n) or
 * b^(q*2^i) = -1 (mod n) for some i such that 0 <= i < r
 *
 *    where q and r are such that n-1 = q*2^r and q is odd.
 *
 * If an integer is not strongly-probably-prime for a given
 * base b, then it is composed. The reciprocal is false.
 * Composed strongly-probably-prime numbers for base b
 * are called `strong pseudoprimes' for base b.
 */
// this will return a pair {root, True/False}
IsStronglyProbablyPrime(b_IsPositiveInteger, n_IsPositiveInteger) <--
[
  Local(m, q, r, a, flag, i, root);
  m := n-1;
  q := m;
  r := 0;
  root := 0;	// will be the default return value of the "root"
  While (IsEven(q))
  [
    q := ShiftRight(q, 1);
    r++;
  ];

  a := FastModularPower(b, q, n);
  flag := (a = 1 Or a = m);
  i := 1;

  While (Not(flag) And (i < r))
  [
	root := a;	// this is the value of the root if flag becomes true now
    a := ModuloN(a*a, n);
    flag := (a = m);
    i++;
  ];

  {root, flag};	// return a root of -1 (or 0 if not found)
];


/*
 * For numbers less than 3.4e14, exhaustive computations have
 * shown that there is no strong pseudoprime simultaneously for
 * bases 2, 3, 5, 7, 11, 13 and 17.
 * Function RabinMillerSmall is based on the results of these
 * computations.
 */

10 # RabinMillerSmall(1) <-- False;

10 # RabinMillerSmall(2) <-- True;

20 # RabinMillerSmall(n_IsEven) <-- False;

20 # RabinMillerSmall(3) <-- True;

30 # RabinMillerSmall(n_IsPositiveInteger) <--
[
  Local(continue, prime, i, primetable, pseudotable, root);
  continue := True;
  prime := True;
  i := 1;
  primetable := {2, 3, 5, 7, 11, 13, 17};
  pseudotable := {2047, 1373653, 25326001, 3215031751, 2152302898747,
                  3474749660383, 34155071728321};
  // if n is strongly probably prime for all bases up to and including primetable[i], then n is actually prime unless it is >= pseudotable[i].
  While (continue And prime And (i < 8))
  [	// we do not really need to collect the information about roots of -1 here, so we do not do anything with root
    {root, prime} := IsStronglyProbablyPrime(primetable[i], n);
    //If(InVerboseMode() And prime, Echo("RabinMiller: Info: ", n, "is spp base", primetable[i]));
    continue := (n >= pseudotable[i]);
    i++;
  ];
  // the function returns "Overflow" when we failed to check (i.e. the number n was too large)
  If (continue And (i = 8), Overflow, prime);
];


/*
 * RabinMillerProbabilistic(n, p) tells whether n is prime.
 * If n is actually prime, the result will always be `True'.
 * If n is composed the probability to obtain the wrong
 * result is less than 4^(-p).
 */
// these 4 rules are not really used now because RabinMillerProbabilistic is only called for large enough n
10 # RabinMillerProbabilistic(1, _p) <-- False;

10 # RabinMillerProbabilistic(2, _p) <-- True;

20 # RabinMillerProbabilistic(n_IsEven, _p) <-- False;

20 # RabinMillerProbabilistic(3, _p) <-- True;

30 # RabinMillerProbabilistic(n_IsPositiveInteger, p_IsPositiveInteger) <--
[
  Local(k, prime, b, roots'of'minus1, root);
  k := 1+IntLog(IntLog(n,2),4)+p;	// find k such that Ln(n)*4^(-k) < 4^(-p)
  b := 1;
  prime := True;
  roots'of'minus1 := {0};	// accumulate the set of roots of -1 modulo n
  While (prime And k>0)
    [
      b := NextPseudoPrime(b);	// use only prime bases, as suggested by Davenport; weak pseudo-primes are good enough
      {root, prime} := IsStronglyProbablyPrime(b, n);
	  If(prime, roots'of'minus1 := Union(roots'of'minus1, {root}));
	  If(Length(roots'of'minus1)>3, prime := False);
	  //If(InVerboseMode() And prime, Echo("RabinMiller: Info: ", n, "is spp base", b));
	  If( // this whole If() clause is only working when InVerboseMode() is in effect and the test is terminated in the unusual way
	  	InVerboseMode() And Length(roots'of'minus1)>3,
	  	[	// we can actually find a factor of n now
			Local(factor);
			roots'of'minus1 := Difference(roots'of'minus1,{0});
			//Echo("RabinMiller: Info: ", n, "is composite via roots of -1 ; ", roots'of'minus1);
			factor := Gcd(n, If(
				roots'of'minus1[1]+roots'of'minus1[2]=n,
				roots'of'minus1[1]+roots'of'minus1[3],
				roots'of'minus1[1]+roots'of'minus1[2]
			));
			Echo(n, " = ", factor, " * ", n/factor);
		]
	  );
      k--;
    ];
  prime;
];


/*
 * This is the frontend function, which uses RabinMillerSmall for
 * ``small'' numbers and RabinMillerProbabilistic for bigger ones.
 *
 * The probability to err is set to 1e-25, hopeing this is less
 * than the one to step on a rattlesnake in northern Groenland. :-)
 */

RabinMiller(n_IsPositiveInteger) <--
[
	//If(InVerboseMode(), Echo("RabinMiller: Info: Testing ", n));
	If(
		n < 34155071728321,
		RabinMillerSmall(n),
		RabinMillerProbabilistic(n, 40)	// 4^(-40)
	);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/example/0000755000175000017500000000000011722677330024727 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/example/Example.mpw0000644000175000017500000000314311317314530027036 0ustar  giovannigiovanni%mathpiper,def="Example"



examplelist:=
Hold(
{
  {40!,
"Simple factorial of a number.
"
  },
  {Differentiate(x)Sin(x),
"Taking the derivative of a function (the derivative of Sin(x) with
respect to x in this case).
"
  },
  {Taylor(x,0,5)Sin(x),
"Expanding a function into a taylor series.
"
  },
  {Integrate(x,a,b)Sin(x),
"Integrate a function.
"
  },
  {Solve(a+x*y==z,x),
"Solve a function for a variable.
"
  },
  {Limit(x,0) Sin(x)/x,
"Take a limit.
"
  },
  {Subst(x,Cos(a)) x+x,
"Substitute an expression with another in the main expression.
"
  },
  {Expand((1+x)^3),
"Expand into a polynomial.
"
  },
  {2^40,
"Big numbers.
"
  },
  {1<<40,
"Bitwise operations
"
  },
  {1 .. 4,
"Generating a list of numbers.
"
  },
  {a:b:c:{},
"Generating a list of items.
"
  },
  {[Local(x);x:={a,b,c};Sin(x)^2;],
"Threading: Sin(..)^2 will be performed on all elements of the list
passed in.
"
  },
  {[Local(list);list:={a,b,c,d,e,f}; list[2 .. 4];],
"Selecting a sublist from a list.
"
  },
  {PermutationsList({a,b,c}),
"Generate all permutations of a list.
"
  },
  {VarList(a+b*x),
"Show all variables that occur in an expression.
"
  },
  {TrigSimpCombine(Cos(a)*Cos(a)+Sin(a)*Sin(a)),
"Convert factors between trigonometric functions to addition of
trigonometric functions.
"
  }
}
);
exampleindex:=0;

Example():=
[
  exampleindex++;
  If (exampleindex>Length(examplelist),exampleindex:=1);

  Local(example);
  example:=examplelist[exampleindex];
  WriteString("Current example : ");
  Write(example[1]);WriteString(";");NewLine();
  NewLine();
  WriteString(example[2]);
  NewLine();
  Eval(example[1]);
];




%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/constants/0000755000175000017500000000000011722677337025317 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/constants/om/0000755000175000017500000000000011722677337025732 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/constants/om/om.mpw0000644000175000017500000000050011316266467027062 0ustar  giovannigiovanni%mathpiper,def=""

//From code.mpi.def:
OMDef( "I", "nums1", "i" );
OMDef( "CachedConstant",        mathpiper, "CachedConstant"        );
OMDef( "AssignCachedConstants", mathpiper, "AssignCachedConstants" );
OMDef( "ClearCachedConstants",  mathpiper, "ClearCachedConstants"  );
OMDef( "Pi", "nums1", "pi" );

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/constants/constants.mpw0000644000175000017500000002721211523200452030037 0ustar  giovannigiovanni%mathpiper,def="I;CachedConstant;AssignCachedConstants;ClearCachedConstants"

/* def file definitions.
I
CachedConstant
AssignCachedConstants
ClearCachedConstants
*/

/* Definition of constants. */

/* TODO:
 * There is a problem with defining I this way: if I is used, but the
 * file "complex" has not been loaded, the interpreter can not deal
 * with "Complex".
 *
 * Note:tk:10/9/09: Perhaps use SetGlobalLazyVariable(I,Hold(Complex(0,1)));
 */

SetGlobalLazyVariable(I,Complex(0,1));

//////////////////////////////////////////////////
/// Cached constants support and definition of Pi
//////////////////////////////////////////////////

//TODO: here we wrap the entire file in LocalSymbols, this is inefficient in that it slows loading of this file. Needs optimization.
LocalSymbols(CacheOfConstantsN) [

/// declare a new cached constant C'atom and its associated function C'atom().
/// C'atom() will call C'func() at current precision to evaluate C'atom if it has not yet been cached at that precision. (note: any arguments to C'func() must be included)
Rulebase("CachedConstant", {C'cache, C'atom, C'func});
UnFence("CachedConstant", 3);	// not sure if this is useful
HoldArgument("CachedConstant", C'func);
HoldArgument("CachedConstant", C'cache);	// name of the cache
// check syntax: must be called on an atom and a function
Rule("CachedConstant", 3, 10, And(IsAtom(C'atom), IsFunction(C'func)))
[
 	Local(C'name,C'functionName);
	Bind(C'name, ToString(C'atom));	// this is for later conveniences
  Bind(C'functionName,ConcatStrings("Internal'",C'name));

	If(	// create the cache it if it does not already exist
		IsAtom(Eval(C'cache)),
		MacroBind(Eval(C'cache), {})
	);
//	Write({"debug step 0: ", C'cache, Eval(C'cache), C'atom, C'func, C'name});
	// check that the constant is not already defined
	If(
	  IsEqual(Builtin'Assoc(C'name, Eval(C'cache)), Empty),	// the constant is not already defined, so need to define "C'atom" and the corresponding function "C'atom"()
	  [	// e.g. C'atom evaluates to Pi, C'cache to a name e.g. CacheOfConstantsN, which is bound to a hash
		MacroUnbind(C'atom);
//		Write({"debug step 1: ", Cache'name, C'cache, Eval(C'cache)});
		// add the new constant to the cache
//		MacroBind(Cache'name, Insert(Eval(C'cache), 1, {C'name, 0, 0}));
		DestructiveInsert(Eval(C'cache), 1, {C'name, 0, 0});
//		Write({"debug step 2: ", Cache'name, C'cache, Eval(C'cache)});
		// define the new function "C'atom"()
		// note: this should not use N() because it may be called from inside N() itself

		MacroRulebase(C'functionName, {});
		`( Rule(@C'functionName, 0, 1024, True)
		[
			Local(new'prec, new'C, cached'C);
			Bind(new'prec, BuiltinPrecisionGet());
			// fetch the cache entry for this constant
			// note that this procedure will store the name of the cache here in this statement as Eval(C'cache)
			Bind(cached'C, Builtin'Assoc(@C'name, @C'cache));
			If( MathNth(cached'C, 2) != new'prec,
			  [	// need to recalculate at current precision
				If(IsEqual(InVerboseMode(),True), Echo("CachedConstant: Info: constant ", @C'name, " is being recalculated at precision ", new'prec));
				Bind(new'C, RoundTo(Eval(@C'func),new'prec));
				DestructiveReplace(cached'C, 2, new'prec);
				DestructiveReplace(cached'C, 3, new'C);
				new'C;
			  ],
			  // return cached value of C'atom
			  MathNth(cached'C, 3)
			);
		]);

		// calculate C'atom at current precision for the first time
//		Eval(ListToFunction({C'atom}));	// "C'name"();
		// we do not need this until the constant is used; it will just slow us down
	  ],
	  // the constant is defined
	  Echo("CachedConstant: Warning: constant ", C'atom, " already defined")
	);
];

Rule("CachedConstant", 3, 20, True)
	Echo("CachedConstant: Error: ", C'atom, " must be an atom and ", C'func, " must be a function.");

/// assign numerical values to all cached constants: using fixed cache "CacheOfConstantsN"
// this is called from N()
Function("AssignCachedConstantsN", {})
[
	Local(var,fname);
	ForEach(var, AssocIndices(CacheOfConstantsN))
	[
		MacroUnbind(ToAtom(var));
    Bind(fname,ConcatStrings("Internal'",var));
    Bind(var,ToAtom(var));
		// this way the routine Internal'Pi() will be actually called only when the variable 'Pi' is used, etcetera.
    `SetGlobalLazyVariable((@var), ListToFunction({ToAtom(fname)}));
	];
];
UnFence("AssignCachedConstantsN", 0);

/// clear values from all cached constants: using fixed cache "CacheOfConstantsN"
// this is called from N()
Function("ClearCachedConstantsN", {})
[
	Local(c'entry);
	ForEach(c'entry, CacheOfConstantsN)
		MacroUnbind(ToAtom(c'entry[1]));
];
UnFence("ClearCachedConstantsN", 0);

/// declare some constants now
CachedConstant(CacheOfConstantsN, Pi,
[// it seems necessary to precompute Pi to a few more digits
// so that Cos(0.5*Pi)=0 at precision 10
// FIXME: find a better solution
	Local(result,old'prec);
  Bind(old'prec,BuiltinPrecisionGet());
If(IsEqual(InVerboseMode(),True), Echo("Recalculating Pi at precision ",old'prec+5));
	BuiltinPrecisionSet(BuiltinPrecisionGet()+5);
	result := MathPi();
If(IsEqual(InVerboseMode(),True),Echo("Switching back to precision ",old'prec));
	BuiltinPrecisionSet(old'prec);
	result;
]
);
CachedConstant(CacheOfConstantsN, gamma, GammaConstNum());
CachedConstant(CacheOfConstantsN, GoldenRatio, N( (1+Sqrt(5))/2 ) );
CachedConstant(CacheOfConstantsN, Catalan, CatalanConstNum() );

]; // LocalSymbols(CacheOfConstantsN)

%/mathpiper





%mathpiper_docs,name="I",categories="User Functions;Constants (Mathematical);Numbers (Complex)"
*CMD I --- imaginary unit
*STD
*CALL
	I

*DESC

This symbol represents the imaginary unit, which equals the square
root of -1. It evaluates to {Complex(0,1)}.

*E.G.

In> I
Result: Complex(0,1);
In> I = Sqrt(-1)
Result: True;

*SEE Complex
%/mathpiper_docs



%mathpiper_docs,name="Pi",categories="User Functions;Constants (Mathematical)"
*CMD Pi --- mathematical constant $pi$

*STD
*CALL
	Pi

*DESC

Pi symbolically represents the exact value of $pi$. When the {N()} function is
used, {Pi} evaluates to a numerical value according to the current precision.
It is better to use {Pi} than {N(Pi)} except in numerical calculations, because exact
simplification will be possible.

This is a "cached constant" which is recalculated only when precision is increased.

*E.G.

In> Sin(3*Pi/2)
Result: -1;
In> Pi+1
Result: Pi+1;
In> N(Pi)
Result: 3.14159265358979323846;

*SEE Sin, Cos, N, CachedConstant
%/mathpiper_docs



%mathpiper_docs,name="GoldenRatio",categories="User Functions;Constants (Mathematical)"
*CMD GoldenRatio --- the Golden Ratio
*STD
*CALL
	GoldenRatio

*DESC

These functions compute the "golden ratio"
$$phi <=> 1.6180339887 <=> (1+Sqrt(5))/2 $$.

The ancient Greeks defined the "golden ratio" as follows:
If one divides a length 1 into two pieces $x$ and $1-x$, such that the ratio of 1 to $x$ is the same as the ratio of $x$ to $1-x$, then $1/x <=> 1.618$... is the "golden ratio".


The constant is available symbolically as {GoldenRatio} or numerically through {N(GoldenRatio)}.
This is a "cached constant" which is recalculated only when precision is increased.
The numerical value of the constant can also be obtained as {N(GoldenRatio)}.


*E.G.

In> x:=GoldenRatio - 1
Result: GoldenRatio-1;
In> N(x)
Result: 0.6180339887;
In> N(1/GoldenRatio)
Result: 0.6180339887;
In> V(N(GoldenRatio,20));

	CachedConstant: Info: constant GoldenRatio is
	being recalculated at precision 20 
Result: 1.6180339887498948482;


*SEE N, CachedConstant
%/mathpiper_docs



%mathpiper_docs,name="Catalan",categories="User Functions;Constants (Mathematical)"
*CMD Catalan --- Catalan's Constant
*STD
*CALL
	Catalan

*DESC

These functions compute Catalan's Constant $Catalan<=>0.9159655941$.

The constant is available symbolically as {Catalan} or numerically through {N(Catalan)} with {N(...)} the usual operator used to try to coerce an expression in to a numeric approximation of that expression.
This is a "cached constant" which is recalculated only when precision is increased.
The numerical value of the constant can also be obtained as {N(Catalan)}.
The low-level numerical computations are performed by the routine {CatalanConstNum}.


*E.G.

In> N(Catalan)
Result: 0.9159655941;
In> DirichletBeta(2)
Result: Catalan;
In> V(N(Catalan,20))

	CachedConstant: Info: constant Catalan is
	being recalculated at precision 20
Result: 0.91596559417721901505;


*SEE N, CachedConstant
%/mathpiper_docs



%mathpiper_docs,name="gamma",categories="User Functions;Constants (Mathematical)"
*CMD gamma --- Euler's constant $gamma$
*STD
*CALL
	gamma

*DESC

These functions compute Euler's constant $gamma<=>0.57722$...

The constant is available symbolically as {gamma} or numerically through using the usual function {N(...)} to get a numeric result, {N(gamma)}.
This is a "cached constant" which is recalculated only when precision is increased.
The numerical value of the constant can also be obtained as {N(gamma)}.
The low-level numerical computations are performed by the routine {GammaConstNum}.

Note that Euler's Gamma function $Gamma(x)$ is the capitalized {Gamma} in MathPiper.

*E.G.

In> gamma+Pi
Result: gamma+Pi;
In> N(gamma+Pi)
Result: 3.7188083184;
In> V(N(gamma,20))
	
	CachedConstant: Info: constant gamma is being
	  recalculated at precision 20 
	GammaConstNum: Info: used 56 iterations at
	  working precision 24 
Result: 0.57721566490153286061;

*SEE Gamma, N, CachedConstant
%/mathpiper_docs



%mathpiper_docs,name="CachedConstant",categories="User Functions;Constants (Mathematical)"
*CMD CachedConstant --- precompute multiple-precision constants
*STD
*CALL
	CachedConstant(cache, Cname, Cfunc)

*PARMS
{cache} -- atom, name of the cache

{Cname} -- atom, name of the constant

{Cfunc} -- expression that evaluates the constant

*DESC

This function is used to create precomputed multiple-precision values of
constants. Caching these values will save time if they are frequently used.

The call to {CachedConstant} defines a new function named {Cname()} that
returns the value of the constant at given precision. If the precision is
changed, the value will be recalculated as necessary, otherwise calling {Cname()} will take very little time.

The parameter {Cfunc} must be an expression that can be evaluated and returns
the value of the desired constant at the current precision. (Most arbitrary-precision mathematical functions do this by default.)

The associative list {cache} contains elements of the form {{Cname, prec, value}}, as illustrated in the example. If this list does not exist, it will be created.

This mechanism is currently used by {N()} to precompute the values of $Pi$ and $gamma$ (and the golden ratio through {GoldenRatio}, and {Catalan}).
The name of the cache for {N()} is {CacheOfConstantsN}.
The code in the function {N()} assigns unevaluated calls to {Internal'Pi()} and {Internal'gamma()} to the atoms {Pi} and {gamma} and declares them to be lazy global variables through {SetGlobalLazyVariable} (with equivalent functions assigned to other constants that are added to the list of cached constants).

The result is that the constants will be recalculated only when they are used in the expression under {N()}.
In other words, the code in {N()} does the equivalent of

	SetGlobalLazyVariable(mypi,Hold(Internal'Pi()));
	SetGlobalLazyVariable(mygamma,Hold(Internal'gamma()));

After this, evaluating an expression such as {1/2+gamma} will call the function {Internal'gamma()} but not the function {Internal'Pi()}.

*E.G. notest

In> CachedConstant( my'cache, Ln2, Internal'LnNum(2) )
Result: True;
In> Internal'Ln2()
Result: 0.6931471806;
In> V(N(Internal'Ln2(),20))
	CachedConstant: Info: constant Ln2 is being
	  recalculated at precision 20 
Result: 0.69314718055994530942;
In> my'cache
Result: {{"Ln2",20,0.69314718055994530942}};


*SEE N, BuiltinPrecisionSet, Pi, GoldenRatio, Catalan, gamma
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/probability/0000755000175000017500000000000011722677333025617 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/probability/CDF.mpw0000644000175000017500000000577411517224250026741 0ustar  giovannigiovanni%mathpiper,def="CDF"

/* Evaluates distribution dst at point x
   known distributions are:
   1. Discrete distributions
   -- BernoulliDistribution(p)
   -- BinomialDistribution(p,n)
   -- DiscreteUniformDistribution(a,b)
   -- PoissonDistribution(l)
   -- HypergeometricDistribution(N, M)
   2. Continuous distributions
   -- ExponentialDistribution(l)
   -- NormalDistrobution(a,s)
   -- ContinuousUniformDistribution(a,b)
   -- tDistribution(m)
   -- GammaDistribution(m)
   -- ChiSquareDistribution(m)

  DiscreteDistribution(domain,probabilities) represent arbitrary
  distribution with finite number of possible values; domain list
  contains possible values such that
  Pr(X=domain[i])=probabilities[i].
  TODO: Should domain contain numbers only?
*/


/* Evaluates Cumulative probability function CDF(x)=Pr(X0 And x<=1, p,1));
11 # CDF(BernoulliDistribution(_p), _x) <-- Hold(If(x<=0,0,If(x>0 And x<=1, p,1)));

10 # CDF(BinomialDistribution(_p,_n),m_IsNumber)_(m<0) <-- 0;
10 # CDF(BinomialDistribution(_p,n_IsInteger),m_IsNumber)_(m>n) <-- 1;
10 # CDF(BinomialDistribution(_p,_n),_m) <-- Sum @ { i, 0, Floor(m), PMF(BinomialDistribution(p,n),i)};

10 # CDF(DiscreteUniformDistribution( a_IsNumber, b_IsNumber), x_IsNumber)_(x<=a) <-- 0;
10 # CDF(DiscreteUniformDistribution( a_IsNumber, b_IsNumber), x_IsNumber)_(x>b) <-- 1;
10 # CDF(DiscreteUniformDistribution( a_IsNumber, b_IsNumber), x_IsNumber)_(ab, 0 ,1/(b-a+1));
11 # PMF(DiscreteUniformDistribution(_a,_b), _x) <-- Hold(If(xb, 0 ,1/(b-a+1)));

10 # PMF(PoissonDistribution(_l), n_IsNumber) <-- If(n<0,0,Exp(-l)*l^n/n!);
11 # PMF(PoissonDistribution(_l),_n) <-- Exp(-l)*l^n/n!;

10 # PMF(GeometricDistribution(_p),_n) <--If(n<0,0,p*(1-p)^n);



10 # PMF(DiscreteDistribution( dom_IsList, prob_IsList), _x)_( Length(dom)=Length(prob) And Simplify(Add(prob))=1) <--
    [
      Local(i);
      i:=Find(dom,x);
      If(i = -1,0,prob[i]);
    ];
    


10 # PMF(HypergeometricDistribution( N_IsNumber, M_IsNumber, n_IsNumber), x_IsNumber)_(M <= N And n <= N) <-- (BinomialCoefficient(M,x) * BinomialCoefficient(N-M, n-x))/BinomialCoefficient(N,n);

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="PMF",categories="User Functions;Statistics & Probability"
*CMD PMF --- probability mass function
*STD
*CALL
	PMF(dist,x)

*PARMS
{dist} -- a distribution type

{x} -- a value of random variable

*DESC
{PMF} returns the
probability for a random variable with distribution {dist} to take a
value of {x}.


*SEE CDF, PDF, Expectation
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/probability/PDF.mpw0000644000175000017500000000375311517224250026751 0ustar  giovannigiovanni%mathpiper,def="PDF"

/* Evaluates distribution dst at point x
   known distributions are:
   1. Discrete distributions
   -- BernoulliDistribution(p)
   -- BinomialDistribution(p,n)
   -- DiscreteUniformDistribution(a,b)
   -- PoissonDistribution(l)
   2. Continuous distributions
   -- ExponentialDistribution(l)
   -- NormalDistrobution(a,s)
   -- ContinuousUniformDistribution(a,b)
   -- tDistribution(m)
   -- GammaDistribution(m)
   -- ChiSquareDistribution(m)

  DiscreteDistribution(domain,probabilities) represent arbitrary
  distribution with finite number of possible values; domain list
  contains possible values such that
  Pr(X=domain[i])=probabilities[i].
  TODO: Should domain contain numbers only?
*/

//Retract("PDF", *);


10 # PDF(ExponentialDistribution(_l), _x) <-- If(x<0,0,l*Exp(-l*x));

10 # PDF(NormalDistribution(_m,_s),_x) <-- Exp(-(x-m)^2/(2*s^2))/Sqrt(2*Pi*s^2); //See http://en.wikipedia.org/wiki/Normal_distribution.

10 # PDF(ContinuousUniformDistribution(_a,_b),x)_(ab,0,1/(b-a));

10 # PDF(DiscreteDistribution( dom_IsList, prob_IsList), _x)_( Length(dom)=Length(prob) And Simplify(Add(prob))=1) <--
    [
      Local(i);
      i:=Find(dom,x);
      If(i = -1,0,prob[i]);
    ];
10 # PDF( ChiSquareDistribution( _m),x_IsRationalOrNumber)_(x<=0) <-- 0;
20 # PDF( ChiSquareDistribution( _m),_x) <-- x^(m/2-1)*Exp(-x/2)/2^(m/2)/Gamma(m/2);

10 # PDF(tDistribution(_m),x) <-- Gamma((m+1)/2)*(1+x^2/m)^(-(m+1)/2)/Gamma(m/2)/Sqrt(Pi*m);


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="PDF",categories="User Functions;Statistics & Probability"
*CMD PDF --- probability density function
*STD
*CALL
	PDF(dist,x)

*PARMS
{dist} -- a distribution type

{x} -- a value of random variable

*DESC
{PDF}
returns the density function at point $x$.

The probability density function (PDF) of a continuous distribution is defined as the 
derivative of the (cumulative) distribution function.

*SEE CDF, PMF, Expectation
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/0000755000175000017500000000000011722677334025423 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsRational.mpw0000644000175000017500000000232211523200452030172 0ustar  giovannigiovanni%mathpiper,def="IsRational"

/* changed definition of IsRational, Nobbi 030529
Function("IsRational",{aLeft}) Type(aLeft) = "/";

Function("IsRationalNumeric",{aLeft})
    Type(aLeft) = "/" And
    IsNumber(aLeft[1]) And
    IsNumber(aLeft[2]);

IsRationalOrNumber(_x) <-- (IsNumber(x) Or IsRationalNumeric(x));

10 # IsRationalOrInteger(x_IsInteger) <-- True;
10 # IsRationalOrInteger(x_IsInteger / y_IsInteger) <-- True;
20 # IsRationalOrInteger(_x) <-- False;

*/

10 # IsRational(x_IsInteger) <-- True;
10 # IsRational(x_IsInteger / y_IsInteger) <-- True;
10 # IsRational(-(x_IsInteger / y_IsInteger)) <-- True;
60000 # IsRational(_x) <-- False;

%/mathpiper



%mathpiper_docs,name="IsRational",categories="User Functions;Numbers (Predicates);Predicates"
*CMD IsRational --- test whether argument is a rational
*STD
*CALL
	IsRational(expr)

*PARMS

{expr} -- expression to test

*DESC

This commands tests whether the expression "expr" is a rational
number, i.e. an integer or a fraction of integers.

*E.G.

In> IsRational(5)
Result: True;
In> IsRational(2/7)
Result: True;
In> IsRational(0.5)
Result: False;
In> IsRational(a/b)
Result: False;
In> IsRational(x + 1/x)
Result: False;

*SEE Numerator, Denominator
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsRationalFunction.mpw0000644000175000017500000001201111530542620031700 0ustar  giovannigiovanni%mathpiper,def="IsRationalFunction"

//Retract("IsRationalFunction",*);

10 # IsRationalFunction(_expr)_(Length(VarList(expr))=0) <-- False;

15 # IsRationalFunction(_expr) <-- IsRationalFunction(expr,VarList(expr));

10 # IsRationalFunction(expr_IsRationalOrNumber,_var) <-- False;

15 # IsRationalFunction(_expr,var_IsAtom)_(Type(expr)="/" Or Type(-expr)="/") <-- 
[
    If (IsPolynomial(Numerator(expr),var) And IsPolynomial(Denominator(expr),var),
        Contains(VarList(Denominator(expr)),var),
        False
    );
];

20 # IsRationalFunction(_expr,vars_IsList)_(Type(expr)="/" Or Type(-expr)="/") <-- 
[
    If (IsPolynomial(Numerator(expr),vars) And IsPolynomial(Denominator(expr),vars),
        Intersection(vars, VarList(expr)) != {},
        False
    );
];

60000 # IsRationalFunction(_expr,_var) <-- False;


%/mathpiper

    


%mathpiper_docs,name="IsRationalFunction",categories="Programmer Functions;Predicates",access="experimental"

*CMD IsRationalFunction --- test for a Rational Function
*STD
*CALL
	IsRationalFunction(expr)
	IsRationalFunction(expr,var)
	IsRationalFunction(expr,vars)

*PARMS

{expr} -- expression to test
{var}  -- (optional) variable
{vars} -- (optional) a list of variables

*DESC

This function tests whether the expression {expr} is a Rational
Function of the variable {var}.  If a list of variables {vars} is
provided, the test is made w.r.t.  all the variables in the list, and
returns True if any one of them succeeds.  If {var} is omitted, the
test is made w.r.t. the list VarList(expr).

*E.G.

In> IsRationalFunction(3,x)  
Result: False
In> IsRationalFunction(3)      
Result: False;
In> IsRationalFunction(3.5,x)
Result:  False
In> IsRationalFunction(3.5)
Result:  False 
In> IsRationalFunction(3/5,x)
Result:  False 
In> IsRationalFunction(3/5)
Result:  False 
In> IsRationalFunction(x,y)
Result:  False 
In> IsRationalFunction(x)
Result:  False 
In> IsRationalFunction(x/y,x)
Result:  False 
In> IsRationalFunction(x/y,y)
Result:  True
In> IsRationalFunction(x/y)
Result:  True 
In> IsRationalFunction(x/5,x)
Result:  False 
In> IsRationalFunction(x/5)
Result:  False 
In> IsRationalFunction(5/x,x)
Result:  True 
In> IsRationalFunction(-5/x,x)
Result:  True 
In> IsRationalFunction(5/x)
Result:  True 
In> IsRationalFunction(-5/x)
Result:  True 
In> IsRationalFunction(5/x,y)
Result:  False 
In> IsRationalFunction(5/x,{y})
Result:  False 
In> IsRationalFunction(5/x,{y,x})
Result:  False
In> IsRationalFunction(5/y)
Result:  True 
In> IsRationalFunction(1-1/x,x)
Result:  False 
In> IsRationalFunction(1-1/x)
Result:  False

%/mathpiper_docs




%mathpiper,scope="nobuild",subtype="manual_test"

Tell(1,IsRationalFunction(3,x));
Tell(2,IsRationalFunction(3.5,x));
Tell(3,IsRationalFunction(3/5,x));
Tell(4,IsRationalFunction(x,y));
Tell(5,IsRationalFunction(x/y,x));
Tell(6,IsRationalFunction(x/5,x));
Tell(7,IsRationalFunction(5/x,x));
Tell(8,IsRationalFunction(5/y,x));
Tell(9,IsRationalFunction(1-1/x,x));
Tell(11,IsRationalFunction(3));
Tell(12,IsRationalFunction(3.5));
Tell(13,IsRationalFunction(3/5));
Tell(14,IsRationalFunction(x));
Tell(15,IsRationalFunction(x/y));
Tell(16,IsRationalFunction(x/5));
Tell(17,IsRationalFunction(5/x));
Tell(18,IsRationalFunction(5/y));
Tell(19,IsRationalFunction(-5/y));
Tell(20,IsRationalFunction(1-1/x));

%/mathpiper

    %output,preserve="false"
      Result: True
      
      Side Effects:
      << 1 >> IsRationalFunction(3,x) : False 
      << 2 >> IsRationalFunction(3.5,x) : False 
      << 3 >> IsRationalFunction(3/5,x) : False 
      << 4 >> IsRationalFunction(x,y) : False 
      << 15 >> expr : x/y 
      <<     >> var : x 
      <<  >> Denominator(expr) : y 
      << 5 >> IsRationalFunction(x/y,x) : False 
      << 15 >> expr : x/5 
      <<     >> var : x 
      <<  >> Denominator(expr) : 5 
      << 6 >> IsRationalFunction(x/5,x) : False 
      << 15 >> expr : 5/x 
      <<     >> var : x 
      <<  >> Denominator(expr) : x 
      << 7 >> IsRationalFunction(5/x,x) : True 
      << 15 >> expr : 5/y 
      <<     >> var : x 
      <<  >> Denominator(expr) : y 
      << 8 >> IsRationalFunction(5/y,x) : False 
      << 9 >> IsRationalFunction(1-1/x,x) : False 
      << 11 >> IsRationalFunction(3) : False 
      << 12 >> IsRationalFunction(3.5) : False 
      << 13 >> IsRationalFunction(3/5) : False 
      << 14 >> IsRationalFunction(x) : False 
      << 15 >> expr : x/y 
      <<     >> var : x 
      <<  >> Denominator(expr) : y 
      << 15 >> IsRationalFunction(x/y) : False 
      << 15 >> expr : x/5 
      <<     >> var : x 
      <<  >> Denominator(expr) : 5 
      << 16 >> IsRationalFunction(x/5) : False 
      << 15 >> expr : 5/x 
      <<     >> var : x 
      <<  >> Denominator(expr) : x 
      << 17 >> IsRationalFunction(5/x) : True 
      << 15 >> expr : 5/y 
      <<     >> var : y 
      <<  >> Denominator(expr) : y 
      << 18 >> IsRationalFunction(5/y) : True 
      << 15 >> expr : (-5)/y 
      <<     >> var : y 
      <<  >> Denominator(expr) : y 
      << 19 >> IsRationalFunction(-5/y) : True 
      << 20 >> IsRationalFunction(1-1/x) : False 
      
.   %/output





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNonNegativeInteger.mpw0000644000175000017500000000014611316304766032173 0ustar  giovannigiovanni%mathpiper,def="IsNonNegativeInteger"

IsNonNegativeInteger(x):= IsInteger(x) And x >= 0;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsUpperTriangular.mpw0000644000175000017500000000220511523200452031545 0ustar  giovannigiovanni%mathpiper,def="IsUpperTriangular"

IsUpperTriangular(A_IsMatrix) <--
[
        Local(i,j,m,n,result);
        m:=Length(A);
        n:=Length(A[1]);
        i:=2;
        result:=(m=n);
        While(i<=m And result)
        [
                j:=1;
                While(j<=n And result)
                [
                        result:= (i<=j Or A[i][j] = 0);
                        j++;
                ];
                i++;
        ];
        result;
];

%/mathpiper



%mathpiper_docs,name="IsUpperTriangular",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsUpperTriangular --- test for an upper triangular matrix
*STD
*CALL
	IsUpperTriangular(A)

*PARMS

{A} -- a matrix

*DESC

An upper triangular matrix is a square matrix which has all zero entries above the diagonal.

{IsUpperTriangular(A)} returns {True} if {A} is an upper triangular matrix and {False} otherwise.

*E.G.
In> IsUpperTriangular(Identity(5))
Result: True;
In> IsUpperTriangular({{1,2},{0,1}})
Result: True;

A non-square matrix cannot be triangular:
In> IsUpperTriangular({{1,2,3},{0,1,2}})
Result: False;

*SEE IsLowerTriangle, IsDiagonal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasExprSome.mpw0000644000175000017500000000370011523200452030324 0ustar  giovannigiovanni%mathpiper,def="HasExprSome"

/// Same except only look at function arguments for functions in a given list
HasExprSome(_expr, _atom, _look'list) _ IsEqual(expr, atom) <-- True;
// an atom contains itself
15 # HasExprSome(expr_IsAtom, _atom, _look'list) <-- IsEqual(expr, atom);
// a list contains an atom if one element contains it
// we test for lists now because lists are also functions
// first take care of the empty list:
19 # HasExprSome({}, _atom, _look'list) <-- False;
20 # HasExprSome(expr_IsList, _atom, _look'list) <-- HasExprSome(First(expr), atom, look'list) Or HasExprSome(Rest(expr), atom, look'list);
// a function contains an atom if one of its arguments contains it
// first deal with functions that do not belong to the list: return False since we have already checked it at #15
25 # HasExprSome(expr_IsFunction, _atom, _look'list)_(Not Contains(look'list, ToAtom(Type(expr)))) <-- False;
// a function contains an atom if one of its arguments contains it
30 # HasExprSome(expr_IsFunction, _atom, _look'list) <-- HasExprSome(Rest(FunctionToList(expr)), atom, look'list);

%/mathpiper



%mathpiper_docs,name="HasExprSome",categories="User Functions;Predicates"
*CMD HasExprSome --- check for expression containing a subexpression
*STD
*CALL
	HasExprSome(expr, x, list)

*PARMS

{expr} -- an expression

{x} -- a subexpression to be found

{list} -- list of function atoms to be considered "transparent"

*DESC

The command {HasExprSome} does the same as {HasExpr}, except it only looks at arguments of a given {list} of functions. All other functions become "opaque" (as if they do not contain anything).

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasExprSome({a+b*2,c/d},c/d,{List})
Result: True;
In> HasExprSome({a+b*2,c/d},c,{List})
Result: False;

*SEE HasExpr, HasExprArith, FuncList, VarList, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasExpr.mpw0000644000175000017500000000326411523200452027505 0ustar  giovannigiovanni%mathpiper,def="HasExpr"

/// HasExpr --- test for an expression containing a subexpression
/// for checking dependence on variables, this may be faster than using VarList or IsFreeOf and this also can be used on non-variables, e.g. strings or numbers or other atoms or even on non-atoms
// an expression contains itself -- check early
10 # HasExpr(_expr, _atom) _ IsEqual(expr, atom) <-- True;
// an atom contains itself
15 # HasExpr(expr_IsAtom, _atom) <-- IsEqual(expr, atom);
// a list contains an atom if one element contains it
// we test for lists now because lists are also functions
// first take care of the empty list:
19 # HasExpr({}, _atom) <-- False;
20 # HasExpr(expr_IsList, _atom) <-- HasExpr(First(expr), atom) Or HasExpr(Rest(expr), atom);
// a function contains an atom if one of its arguments contains it
30 # HasExpr(expr_IsFunction, _atom) <-- HasExpr(Rest(FunctionToList(expr)), atom);

%/mathpiper



%mathpiper_docs,name="HasExpr",categories="User Functions;Predicates"
*CMD HasExpr --- check for expression containing a subexpression
*STD
*CALL
	HasExpr(expr, x)

*PARMS

{expr} -- an expression

{x} -- a subexpression to be found



*DESC

The command {HasExpr} returns {True} if the expression {expr} contains a literal subexpression {x}. The expression is recursively traversed.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasExpr(x+y*Cos(Ln(z)/z), z)
Result: True;
In> HasExpr(x+y*Cos(Ln(z)/z), Ln(z))
Result: True;
In> HasExpr(x+y*Cos(Ln(z)/z), z/Ln(z))
Result: False;

*SEE HasExprArith, HasExprSome, FuncList, VarList, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsBoolType.mpw0000644000175000017500000000022111316304766030167 0ustar  giovannigiovanni%mathpiper,def="IsBoolType"

0 # IsBoolType(True) <-- True;
0 # IsBoolType(False) <-- True;
1 # IsBoolType(_anythingelse) <-- False;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/ListHasFunc.mpw0000644000175000017500000000222611523200452030313 0ustar  giovannigiovanni%mathpiper,def="ListHasFunc"

/// ListHasFunc --- test for one of the elements of a list to contain a function
/// this is mainly useful to test whether a list has nested lists, 
/// i.e. ListHasFunc({1,2,3}, List)=False and ListHasFunc({1,2,{3}}, List)=True.
// need to exclude the List atom itself, so don't use FunctionToList
19 # ListHasFunc({}, _atom) <-- False;
20 # ListHasFunc(expr_IsList, atom_IsAtom) <-- HasFunc(First(expr), atom) Or ListHasFunc(Rest(expr), atom);

%/mathpiper




%mathpiper_docs,name="ListHasFunc",categories="User Functions;Predicates"
*CMD ListHasFunc --- test for one of the elements of a list to contain a function
*STD
*CALL
	ListHasFunc( list, func )

*PARMS

{list} - a list of expressions

{func} - a function atom to be found

*DESC

Given a list of expressions and and a function name, this command returns 
{True} if the list contains the function name.

*E.G.
In> lst := {Ln(x),Sinh(a*x),ArcTan(3/x)}
Result: {Ln(x),Sinh(a*x),ArcTan(3/x)}

In> ListHasFunc(lst,Sqrt)
Result: False

In> ListHasFunc(lst,Ln)
Result: True

In> ListHasFunc(lst,Sinh)
Result: True

In> ListHasFunc(lst,ArcTan)
Result: True
*SEE HasFunc
%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsHermitian.mpw0000644000175000017500000000120511523200452030340 0ustar  giovannigiovanni%mathpiper,def="IsHermitian"

IsHermitian(A_IsMatrix) <-- (Conjugate(Transpose(A))=A);

%/mathpiper



%mathpiper_docs,name="IsHermitian",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsHermitian --- test for a Hermitian matrix
*STD
*CALL
	IsHermitian(A)

*PARMS

{A} -- a square matrix

*DESC

IsHermitian(A) returns {True} if {A} is Hermitian and {False}
otherwise. $A$ is a Hermitian matrix iff Conjugate( Transpose $A$ )=$A$.
If $A$ is a real matrix, it must be symmetric to be Hermitian.

*E.G.

In> IsHermitian({{0,I},{-I,0}})
Result: True;
In> IsHermitian({{0,I},{2,0}})
Result: False;

*SEE IsUnitary
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasFunc.mpw0000644000175000017500000000245211523200452027460 0ustar  giovannigiovanni%mathpiper,def="HasFunc"

/// HasFunc --- test for an expression containing a function
/// function name given as string.
10 # HasFunc(_expr, string_IsString) <-- HasFunc(expr, ToAtom(string));
/// function given as atom.
// atom contains no functions
10 # HasFunc(expr_IsAtom, atom_IsAtom) <-- False;
// a list contains the function List so we test it together with functions
// a function contains itself, or maybe an argument contains it
20 # HasFunc(expr_IsFunction, atom_IsAtom) <-- IsEqual(First(FunctionToList(expr)), atom) Or ListHasFunc(Rest(FunctionToList(expr)), atom);

%/mathpiper



%mathpiper_docs,name="HasFunc",categories="User Functions;Predicates"
*CMD HasFunc --- check for expression containing a function
*STD
*CALL
	HasFunc(expr, func)

*PARMS

{expr} -- an expression

{func} -- a function atom to be found

*DESC

The command {HasFunc} returns {True} if the expression {expr} contains a function {func}. The expression is recursively traversed.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasFunc(x+y*Cos(Ln(z)/z), Ln)
Result: True;
In> HasFunc(x+y*Cos(Ln(z)/z), Sin)
Result: False;

*SEE HasFuncArith, HasFuncSome, FuncList, VarList, HasExpr
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsDiagonal.mpw0000644000175000017500000000157711523200452030152 0ustar  giovannigiovanni%mathpiper,def="IsDiagonal"

IsDiagonal(A_IsMatrix) <--
[
	Local(i,j,m,n,result);
	m      := Length(A);
	n      := Length(A[1]);
	result := (m=n);    //    must be a square matrix
	
	i:=2;
    While(i<=m And result)
     [
	     j:=1;
	     While(j<=n And result)
	     [
		     result:= (i=j Or A[i][j] = 0);
		     j++;
	     ];
	     i++;
	 ];
	If(m=2, [ result := result And (A=Transpose(A)); ]	);
	result;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="IsDiagonal",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsDiagonal --- test for a diagonal matrix
*STD
*CALL
	IsDiagonal(A)

*PARMS

{A} -- a matrix

*DESC

{IsDiagonal(A)} returns {True} if {A} is a diagonal square matrix and {False} otherwise.

*E.G.
In> IsDiagonal(Identity(5))
Result: True;
In> IsDiagonal(HilbertMatrix(5))
Result: False;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsPositiveNumber.mpw0000644000175000017500000000116111523200452031374 0ustar  giovannigiovanni%mathpiper,def="IsPositiveNumber"

IsPositiveNumber(x):= IsNumber(x) And x > 0;

%/mathpiper



%mathpiper_docs,name="IsPositiveNumber",categories="User Functions;Predicates"
*CMD IsPositiveNumber --- test for a positive number
*STD
*CALL
	IsPositiveNumber(n)

*PARMS

{n} -- number to test

*DESC

{IsPositiveNumber(n)} evaluates to {True} if $n$ is (strictly) positive, i.e.
if $n>0$. If {n} is not a number the function returns {False}.

*E.G.

In> IsPositiveNumber(6);
Result: True;
In> IsPositiveNumber(-2.5);
Result: False;

*SEE IsNumber, IsNegativeNumber, IsNotZero, IsPositiveInteger, IsPositiveReal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsPositiveInteger.mpw0000644000175000017500000000120311523200452031536 0ustar  giovannigiovanni%mathpiper,def="IsPositiveInteger"

IsPositiveInteger(x):= IsInteger(x) And x > 0;

%/mathpiper



%mathpiper_docs,name="IsPositiveInteger",categories="User Functions;Predicates"
*CMD IsPositiveInteger --- test for a positive integer
*STD
*CALL
	IsPositiveInteger(n)

*PARMS

{n} -- integer to test

*DESC

This function tests whether the integer {n} is (strictly) positive. The
positive integers are 1, 2, 3, 4, 5, etc. If {n} is not a integer, the
function returns {False}.

*E.G.

In> IsPositiveInteger(31);
Result: True;
In> IsPositiveInteger(-2);
Result: False;

*SEE IsNegativeInteger, IsNonZeroInteger, IsPositiveNumber
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsOne.mpw0000644000175000017500000000026511316304766027163 0ustar  giovannigiovanni%mathpiper,def="IsOne",private="true"

// why do we need this? Why doesn't x=1 not work?
10 # IsOne(x_IsNumber) <-- IsZero(SubtractN(x,1));
60000 # IsOne(_x) <-- False;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsSymmetric.mpw0000644000175000017500000000176711523200452030411 0ustar  giovannigiovanni%mathpiper,def="IsSymmetric"

IsSymmetric(A_IsMatrix) <-- (Transpose(A)=A);

%/mathpiper



%mathpiper_docs,name="IsSymmetric",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsSymmetric --- test for a symmetric matrix
*STD
*CALL
	IsSymmetric(A)

*PARMS

{A} -- a matrix

*DESC

{IsSymmetric(A)} returns {True} if {A} is symmetric and {False} otherwise.
$A$ is symmetric iff Transpose ($A$) =$A$.

*E.G.

In> A := {{1,0,0,0,1},{0,2,0,0,0},{0,0,3,0,0},
	  {0,0,0,4,0},{1,0,0,0,5}};
In> PrettyForm(A)

	/                                \
	| ( 1 ) ( 0 ) ( 0 ) ( 0 ) ( 1 )  |
	|                                |
	| ( 0 ) ( 2 ) ( 0 ) ( 0 ) ( 0 )  |
	|                                |
	| ( 0 ) ( 0 ) ( 3 ) ( 0 ) ( 0 )  |
	|                                |
	| ( 0 ) ( 0 ) ( 0 ) ( 4 ) ( 0 )  |
	|                                |
	| ( 1 ) ( 0 ) ( 0 ) ( 0 ) ( 5 )  |
	\                                /
Result: True;
In> IsSymmetric(A)
Result: True;
		

*SEE IsHermitian, IsSkewSymmetric
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsPolynomial.mpw0000644000175000017500000000302611517224250030553 0ustar  giovannigiovanni%mathpiper,def="IsPolynomial"

//Retract("IsPolynomial",*);

10 # IsPolynomial(expr_IsFunction) <-- 
[
    Local(x,vars);
    vars := VarList(expr);
    If(Length(vars)>1,vars:=HeapSort(vars,"IsGreaterThan"));    
    x := vars[1];
    IsPolynomial(expr,x);
];

15 # IsPolynomial(_expr) <-- False;


10 # IsPolynomial(_expr,_var)_(CanBeUni(var,expr)) <-- True;

15 # IsPolynomial(_expr,_var) <-- False;

%/mathpiper




%mathpiper_docs,name="IsPolynomial",categories="Programmer Functions;Predicates"

*CMD IsPolynomial --- Check if {expr} is a polynomial in variable {var} if {var} is specified.

*STD
*CALL
    IsPolynomial(expr,var)
or
    IsPolynomial(expr)

*PARMS

{expr} -- an algebraic expression which may be a polynomial

{var}  -- a variable name which might be used in {expr}

*DESC

The command {IsPolynomial} returns {True} if {expr} is (or could be) a polynomial in {var}.
If {var} is not specified, a heuristic algorithm (which may be wrong!) is used to select a
likely variable name from among the list of "variables" returned by VarList(expr).
If you would rather not have an algorithm selecting the variable name, specify it as an
argument to the function.
It returns {False} if {expr} is not likely to be a polynomial in {var}.

*E.G.

In> IsPolynomial(2*x^3-3*x^2+5*x-14,x)
Result: True 

In> IsPolynomial(2*x^3-3*x^2+5*x-14)
Result: False

In> IsPolynomial(y^2-4)
Result: True
        NOTE: if variable name is omitted, a reasonable default is taken.

%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNegativeInteger.mpw0000644000175000017500000000121011523200452031474 0ustar  giovannigiovanni%mathpiper,def="IsNegativeInteger"

IsNegativeInteger(x):= IsInteger(x) And x < 0;

%/mathpiper



%mathpiper_docs,name="IsNegativeInteger",categories="User Functions;Predicates"
*CMD IsNegativeInteger --- test for a negative integer
*STD
*CALL
	IsNegativeInteger(n)

*PARMS

{n} -- integer to test

*DESC

This function tests whether the integer {n} is (strictly)
negative. The negative integers are -1, -2, -3, -4, -5, etc. If
{n} is not a integer, the function returns {False}.

*E.G.

In> IsNegativeInteger(31);
Result: False;
In> IsNegativeInteger(-2);
Result: True;

*SEE IsPositiveInteger, IsNonZeroInteger, IsNegativeNumber
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/matrix.mpw0000644000175000017500000001122011523200452027426 0ustar  giovannigiovanni%mathpiper,def="IsScalar;IsMatrix;IsVector;IsSquareMatrix"

/* def file definitions
IsScalar
IsMatrix
IsVector
IsSquareMatrix
*/

LocalSymbols(p,x)
[
// test for a scalar
Function("IsScalar",{x}) Not(IsList(x));



// test for a vector
Function("IsVector",{x})
   If(IsList(x),
   Length(Select(x, IsList))=0,
   False);

// test for a vector w/ element test p
Function("IsVector",{p,x})
[
   If(IsList(x),
   [
      Local(i,n,result);
      n:=Length(x);
      i:=1;
      result:=True;
      While(i<=n And result)
      [
	 result:=Apply(p,{x[i]});
	 i++;
      ];
      result;
   ],
   False);
];

// test for a matrix (dr)
Function("IsMatrix",{x})
If(IsList(x) And Length(x)>0,
[
   Local(n);
   n:=Length(x);
   If(Length(Select(x, IsVector))=n,
   MapSingle(Length,x)=Length(x[1])+ZeroVector(n),
   False);
],
False);

// test for a matrix w/ element test p (dr)
Function("IsMatrix",{p,x})
If(IsMatrix(x),
[
   Local(i,j,m,n,result);
   m:=Length(x);
   n:=Length(x[1]);
   i:=1;
   result:=True;
   While(i<=m And result)
   [
      j:=1;
      While(j<=n And result)
      [
         result:=Apply(p,{x[i][j]});
         j++;
      ];
      i++;
   ];
   result;
],
False);

/* remove? (dr)
IsSquareMatrix(_x) <--
[
   Local(d);
   d:=Dimensions(x);
   Length(d)=2 And d[1]=d[2];
];
*/

// test for a square matrix (dr)
Function("IsSquareMatrix",{x}) IsMatrix(x) And Length(x)=Length(x[1]);
// test for a square matrix w/ element test p (dr)
Function("IsSquareMatrix",{p,x}) IsMatrix(p,x) And Length(x)=Length(x[1]);

]; // LocalSymbols(p,x)

%/mathpiper



%mathpiper_docs,name="IsScalar",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsScalar --- test for a scalar
*STD
*CALL

	IsScalar(expr)

*PARMS

{expr} -- a mathematical object

*DESC

{IsScalar} returns {True} if {expr} is a scalar, {False} otherwise.
Something is considered to be a scalar if it's not a list.

*E.G.
In> IsScalar(7)
Result: True;
In> IsScalar(Sin(x)+x)
Result: True;
In> IsScalar({x,y})
Result: False;

*SEE IsList, IsVector, IsMatrix
%/mathpiper_docs



%mathpiper_docs,name="IsVector",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsVector --- test for a vector
*STD
*CALL

	IsVector(expr)

	IsVector(pred,expr)

*PARMS

{expr} -- expression to test

{pred} -- predicate test (e.g. IsNumber, IsInteger, ...)

*DESC

{IsVector(expr)} returns {True} if {expr} is a vector, {False} otherwise.
Something is considered to be a vector if it's a list of scalars.
{IsVector(pred,expr)} returns {True} if {expr} is a vector and if the
predicate test {pred} returns {True} when applied to every element of
the vector {expr}, {False} otherwise.

*E.G.
In> IsVector({a,b,c})
Result: True;
In> IsVector({a,{b},c})
Result: False;
In> IsVector(IsInteger,{1,2,3})
Result: True;
In> IsVector(IsInteger,{1,2.5,3})
Result: False;

*SEE IsList, IsScalar, IsMatrix
%/mathpiper_docs



%mathpiper_docs,name="IsMatrix",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsMatrix --- test for a matrix
*STD
*CALL
	IsMatrix(expr)

	IsMatrix(pred,expr)

*PARMS

{expr} -- expression to test

{pred} -- predicate test (e.g. IsNumber, IsInteger, ...)

*DESC

{IsMatrix(expr)} returns {True} if {expr} is a matrix, {False} otherwise.
Something is considered to be a matrix if it's a list of vectors of equal
length.
{IsMatrix(pred,expr)} returns {True} if {expr} is a matrix and if the
predicate test {pred} returns {True} when applied to every element of
the matrix {expr}, {False} otherwise.

*E.G.

In> IsMatrix(1)
Result: False;
In> IsMatrix({1,2})
Result: False;
In> IsMatrix({{1,2},{3,4}})
Result: True;
In> IsMatrix(IsRational,{{1,2},{3,4}})
Result: False;
In> IsMatrix(IsRational,{{1/2,2/3},{3/4,4/5}})
Result: True;

*SEE IsList, IsVector
%/mathpiper_docs



%mathpiper_docs,name="IsSquareMatrix",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsSquareMatrix --- test for a square matrix
*STD
*CALL
	IsSquareMatrix(expr)

	IsSquareMatrix(pred,expr)

*PARMS

{expr} -- expression to test

{pred} -- predicate test (e.g. IsNumber, IsInteger, ...)

*DESC

{IsSquareMatrix(expr)} returns {True} if {expr} is a square matrix,
{False} otherwise. Something is considered to be a square matrix if
it's a matrix having the same number of rows and columns.
{IsMatrix(pred,expr)} returns {True} if {expr} is a square matrix and
if the predicate test {pred} returns {True} when applied to every
element of the matrix {expr}, {False} otherwise.

*E.G.

In> IsSquareMatrix({{1,2},{3,4}});
Result: True;
In> IsSquareMatrix({{1,2,3},{4,5,6}});
Result: False;
In> IsSquareMatrix(IsBoolean,{{1,2},{3,4}});
Result: False;
In> IsSquareMatrix(IsBoolean,{{True,False},{False,True}});
Result: True;

*SEE IsMatrix
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/ListHasFuncSome.mpw0000644000175000017500000000037711371733712031157 0ustar  giovannigiovanni%mathpiper,def="ListHasFuncSome"

19 # ListHasFuncSome({}, _atom, _look'list) <-- False;
20 # ListHasFuncSome(expr_IsList, atom_IsAtom, _look'list) <-- HasFuncSome(First(expr), atom, look'list) Or ListHasFuncSome(Rest(expr), atom, look'list);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsEvenFunction.mpw0000644000175000017500000000177111523200452031033 0ustar  giovannigiovanni%mathpiper,def="IsEvenFunction"

IsEvenFunction(f,x):= (f = Eval(Subst(x,-x)f));

%/mathpiper



%mathpiper_docs,name="IsEvenFunction",categories="User Functions;Predicates"
*CMD IsEvenFunction --- Return true if function is an even function (False otherwise)

*STD
*CALL
	IsEvenFunction(expression,variable)

*PARMS

{expression} -- mathematical expression
{variable} -- variable

*DESC

This function returns True if MathPiper can determine that the
function is even. Even functions are
defined to be functions that have the property:

$$ f(x) = f(-x) $$

{Cos(x)} is an example of an even function.

As a side note, one can decompose a function into an
even and an odd part:

$$ f(x) = f_even(x) + f_odd(x) $$

Where 

$$ f_even(x) = (f(x)+f(-x))/2 $$

and

$$ f_odd(x) = (f(x)-f(-x))/2 $$

*E.G.

In> IsEvenFunction(Cos(b*x),x)
Result: True
In> IsEvenFunction(Sin(b*x),x)
Result: False
In> IsEvenFunction(1/x^2,x)
Result: True
In> IsEvenFunction(1/x,x)
Result: False

*SEE IsOddFunction, Sin, Cos
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/NoneSatisfy.mpw0000644000175000017500000000173111523200452030372 0ustar  giovannigiovanni%mathpiper,def="NoneSatisfy"

10 # NoneSatisfy(pred_IsString,lst_IsList) <-- Not Apply("Or",(MapSingle(pred,lst)));

20 # NoneSatisfy(_pred,_lst) <-- True;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

%mathpiper_docs,name="NoneSatisfy",categories="User Functions;Predicates"

*CMD NoneSatisfy --- Check if NO element of list {lst} satisfies predicate {pred}

*STD
*CALL
	NoneSatisfy(pred,lst)

*PARMS

{pred} -- the name of the predicate (as string, with quotes) to be tested

{lst} -- a list

*DESC

The command {NoneSatisfy} returns {True} if NO element of the list {lst} satisfies the predicate {pred}.
It returns {False} if at least one element of the list satisfies the predicate.
It also returns {True} if {lst} is not a list, or if {pred} is not a predicate.

*E.G.

In> NoneSatisfy("IsNegativeInteger",{1,0,5})
Result: True
In> NoneSatisfy("IsPositiveInteger",{-1,0,5})
Result: False
    
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/AllSatisfy.mpw0000644000175000017500000000164111523200452030203 0ustar  giovannigiovanni%mathpiper,def="AllSatisfy"

10 # AllSatisfy(pred_IsString,lst_IsList) <-- Apply("And",(MapSingle(pred,lst)));

20 # AllSatisfy(_pred,_lst) <-- False;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


%mathpiper_docs,name="AllSatisfy",categories="User Functions;Predicates"


*CMD AllSatisfy --- Check if all elements of list {lst} satisfy predicate {pred}

*STD
*CALL
	AllSatisfy(pred,lst)

*PARMS

{pred} -- the name of the predicate (as string, with quotes) to be tested

{lst} -- a list


*DESC

The command {AllSatisfy} returns {True} if every element of the list {lst} satisfies the predicate {pred}. 
It returns {False} otherwise.
It also returns {False} if {lst} is not a list, or if {pred} is not a predicate.

*E.G.

In> AllSatisfy("IsInteger",{1,0,-5})
Result> True 
In> AllSatisfy("IsPositiveInteger",{1,0,-5})
Result> False
    
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsConstant.mpw0000644000175000017500000000121411523200452030211 0ustar  giovannigiovanni%mathpiper,def="IsConstant"

IsConstant(_n) <-- (VarList(n) = {});

%/mathpiper



%mathpiper_docs,name="IsConstant",categories="User Functions;Predicates"
*CMD IsConstant --- test for a constant
*STD
*CALL
	IsConstant(expr)

*PARMS

{expr} -- some expression

*DESC

{IsConstant} returns {True} if the
expression is some constant or a function with constant arguments. It
does this by checking that no variables are referenced in the
expression. {Pi} is considered a constant.

*E.G.

In> IsConstant(Cos(x))
Result: False;
In> IsConstant(Cos(2))
Result: True;
In> IsConstant(Cos(2+x))
Result: False;

*SEE IsNumber, IsInteger, VarList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsSkewSymmetric.mpw0000644000175000017500000000134011523200452031226 0ustar  giovannigiovanni%mathpiper,def="IsSkewSymmetric"

IsSkewSymmetric(A_IsMatrix) <-- (Transpose(A)=(-1*A));

%/mathpiper



%mathpiper_docs,name="IsSkewSymmetric",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsSkewSymmetric --- test for a skew-symmetric matrix
*STD
*CALL
	IsSkewSymmetric(A)

*PARMS

{A} -- a square matrix

*DESC

{IsSkewSymmetric(A)} returns {True} if {A} is skew symmetric and {False} otherwise.
$A$ is skew symmetric iff $Transpose(A)$ =$-A$. 

*E.G.

In> A := {{0,-1},{1,0}}
Result: {{0,-1},{1,0}};
In> PrettyForm(%)

	/               \
	| ( 0 ) ( -1 )  |
	|               |
	| ( 1 ) ( 0 )   |
	\               /
Result: True;
In> IsSkewSymmetric(A);
Result: True;

*SEE IsSymmetric, IsHermitian
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsVariable.mpw0000644000175000017500000000027011316304766030163 0ustar  giovannigiovanni%mathpiper,def="IsVariable"

IsVariable(_expr) <-- (IsAtom(expr) And Not(expr=Infinity) And Not(expr= -Infinity) And Not(expr=Undefined) And Not(IsNumber(N(Eval(expr)))));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsBoolean.mpw0000644000175000017500000000137211523200452030004 0ustar  giovannigiovanni%mathpiper,def="IsBoolean"

Function ("IsBoolean", {x})
	(x=True) Or (x=False) Or IsFunction(x) And Contains({"=", ">", "<", ">=", "<=", "!=", "And", "Not", "Or"}, Type(x));

%/mathpiper



%mathpiper_docs,name="IsBoolean",categories="User Functions;Predicates"
*CMD IsBoolean --- test for a Boolean value
*STD
*CALL
	IsBoolean(expression)

*PARMS

{expression} -- an expression

*DESC

IsBoolean returns True if the argument is of a boolean type.
This means it has to be either True, False, or an expression involving
functions that return a boolean result, e.g.
{=}, {>}, {<}, {>=}, {<=}, {!=}, {And}, {Not}, {Or}.

*E.G.

In> IsBoolean(a)
Result: False;
In> IsBoolean(True)
Result: True;
In> IsBoolean(a And b)
Result: True;

*SEE True, False
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsInfinity.mpw0000644000175000017500000000142111523200452030211 0ustar  giovannigiovanni%mathpiper,def="IsInfinity"

10 # IsInfinity(Infinity) <-- True;
10 # IsInfinity(-(_x)) <-- IsInfinity(x);

// This is just one example, we probably need to extend this further to include all
// cases for f*Infinity where f can be guaranteed to not be zero
11 # IsInfinity(Sign(_x)*y_IsInfinity) <-- True;

60000 # IsInfinity(_x) <-- False;

%/mathpiper



%mathpiper_docs,name="IsInfinity",categories="User Functions;Predicates"
*CMD IsInfinity --- test for an infinity
*STD
*CALL
	IsInfinity(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tests whether {expr} is an infinity. This is only the
case if {expr} is either {Infinity} or {-Infinity}.

*E.G.

In> IsInfinity(10^1000);
Result: False;
In> IsInfinity(-Infinity);
Result: True;

*SEE Integer
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNonNegativeNumber.mpw0000644000175000017500000000014311316304766032023 0ustar  giovannigiovanni%mathpiper,def="IsNonNegativeNumber"

IsNonNegativeNumber(x):= IsNumber(x) And x >= 0;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsRationalOrNumber.mpw0000644000175000017500000000040211316304766031656 0ustar  giovannigiovanni%mathpiper,def="IsRationalOrNumber"

10 # IsRationalOrNumber(x_IsNumber) <-- True;
10 # IsRationalOrNumber(x_IsNumber / y_IsNumber) <-- True;
10 # IsRationalOrNumber(-(x_IsNumber / y_IsNumber)) <-- True;
60000 # IsRationalOrNumber(_x) <-- False;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsZero.mpw0000644000175000017500000000203211523200452027336 0ustar  giovannigiovanni%mathpiper,def="IsZero"

//10 # IsZero(x_IsNumber) <-- (DivideN( Round( MultiplyN(x, 10^BuiltinPrecisionGet()) ), 10^BuiltinPrecisionGet() ) = 0);

// these should be calls to MathSign() and the math library should do this. Or it should be just MathEquals(x,0).
// for now, avoid underflow and avoid IsZero(10^(-BuiltinPrecisionGet())) returning True.
10 # IsZero(x_IsNumber) <-- ( MathSign(x) = 0 Or AbsN(x)  < PowerN(10, -BuiltinPrecisionGet()));
60000 # IsZero(_x) <-- False;

//Note:tk:moved here from univariate.rep.
20 # IsZero(UniVariate(_var,_first,_coefs)) <-- IsZeroVector(coefs);

%/mathpiper



%mathpiper_docs,name="IsZero",categories="User Functions;Numbers (Predicates);Predicates"
*CMD IsZero --- test whether argument is zero
*STD
*CALL
	IsZero(n)

*PARMS

{n} -- number to test

*DESC

{IsZero(n)} evaluates to {True} if
"n" is zero. In case "n" is not a number, the function returns
{False}.

*E.G.

In> IsZero(3.25)
Result: False;
In> IsZero(0)
Result: True;
In> IsZero(x)
Result: False;

*SEE IsNumber, IsNotZero
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNegativeReal.mpw0000644000175000017500000000175211523200452030775 0ustar  giovannigiovanni%mathpiper,def="IsNegativeReal"

/* See if a number, when evaluated, would be a positive real value */

IsNegativeReal(_r) <--
[
  r:=N(Eval(r));
  (IsNumber(r) And r <= 0);
];

%/mathpiper



%mathpiper_docs,name="IsNegativeReal",categories="User Functions;Predicates"
*CMD IsNegativeReal --- test for a numerically negative value
*STD
*CALL
	IsNegativeReal(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tries to approximate {expr} numerically. It returns {True} if this approximation is negative. In case no
approximation can be found, the function returns {False}. Note that round-off errors may cause incorrect
results.

*E.G.

In> IsNegativeReal(Sin(1)-3/4);
Result: False;
In> IsNegativeReal(Sin(1)-6/7);
Result: True;
In> IsNegativeReal(Exp(x));
Result: False;

The last result is because {Exp(x)} cannot be
numerically approximated if {x} is not known. Hence
MathPiper can not determine the sign of this expression.

*SEE IsPositiveReal, IsNegativeNumber, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsOrthogonal.mpw0000644000175000017500000000177111523200452030544 0ustar  giovannigiovanni%mathpiper,def="IsOrthogonal"

IsOrthogonal(A_IsMatrix) <-- (Transpose(A)*A=Identity(Length(A)));

%/mathpiper



%mathpiper_docs,name="IsOrthogonal",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsOrthogonal --- test for an orthogonal matrix
*STD
*CALL
	IsOrthogonal(A)

*PARMS

{A} -- square matrix

*DESC

{IsOrthogonal(A)} returns {True} if {A} is orthogonal and {False} 
otherwise. $A$ is orthogonal iff $A$*Transpose($A$) = Identity, or
equivalently Inverse($A$) = Transpose($A$).

*E.G.

In> A := {{1,2,2},{2,1,-2},{-2,2,-1}};
Result: {{1,2,2},{2,1,-2},{-2,2,-1}};
In> PrettyForm(A/3)

	/                      \
	| / 1 \  / 2 \ / 2 \   |
	| | - |  | - | | - |   |
	| \ 3 /  \ 3 / \ 3 /   |
	|                      |
	| / 2 \  / 1 \ / -2 \  |
	| | - |  | - | | -- |  |
	| \ 3 /  \ 3 / \ 3  /  |
	|                      |
	| / -2 \ / 2 \ / -1 \  |
	| | -- | | - | | -- |  |
	| \ 3  / \ 3 / \ 3  /  |
	\                      /
Result: True;
In> IsOrthogonal(A/3)
Result: True;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsOddFunction.mpw0000644000175000017500000000171711523200452030644 0ustar  giovannigiovanni%mathpiper,def="IsOddFunction"

IsOddFunction(f,x):= (f = Eval(-Subst(x,-x)f));

%/mathpiper



%mathpiper_docs,name="IsOddFunction",categories="User Functions;Predicates"
*CMD IsOddFunction --- Return true if function is an odd function (False otherwise)

*STD
*CALL
	IsOddFunction(expression,variable)

*PARMS

{expression} -- mathematical expression
{variable} -- variable

*DESC

This function returns True if MathPiper can determine that the
function is odd.  Odd functions have the property:

$$ f(x) = -f(-x) $$

{Sin(x)} is an example of an odd function.

As a side note, one can decompose a function into an
even and an odd part:

$$ f(x) = f_even(x) + f_odd(x) $$

Where 

$$ f_even(x) = (f(x)+f(-x))/2 $$

and

$$ f_odd(x) = (f(x)-f(-x))/2 $$

*E.G.

In> IsOddFunction(Cos(b*x),x)
Result: False
In> IsOddFunction(Sin(b*x),x)
Result: True
In> IsOddFunction(1/x,x)
Result: True
In> IsOddFunction(1/x^2,x)
Result: False

*SEE IsEvenFunction, Sin, Cos
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasFuncArith.mpw0000644000175000017500000000157211523200452030452 0ustar  giovannigiovanni%mathpiper,def="HasFuncArith"

/// Analyse arithmetic expressions

HasFuncArith(expr, atom) := HasFuncSome(expr, atom, {ToAtom("+"), ToAtom("-"), *, /});

%/mathpiper



%mathpiper_docs,name="HasFuncArith",categories="User Functions;Predicates"
*CMD HasFuncArith --- check for expression containing a function
*STD
*CALL
	HasFuncArith(expr, func)

*PARMS

{expr} -- an expression

{func} -- a function atom to be found

*DESC

{HasFuncArith} is defined through {HasFuncSome} to look only at arithmetic operations {+}, {-}, {*}, {/}.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasFuncArith(x+y*Cos(Ln(x)/x), Cos)
Result: True;
In> HasFuncArith(x+y*Cos(Ln(x)/x), Ln)
Result: False;

*SEE HasFunc, HasFuncSome, FuncList, VarList, HasExpr
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsMonomial.mpw0000644000175000017500000000213111523200452030172 0ustar  giovannigiovanni%mathpiper,def="IsMonomial"

//Retract("CanBeMonomial",*);
//Retract("IsMonomial",*);

10 # CanBeMonomial(_expr)_(Type(expr)="UniVariate") <-- False;

10 # CanBeMonomial(_expr)<--Not (HasFunc(expr,ToAtom("+")) Or HasFunc(expr,ToAtom("-")));

10 # IsMonomial(expr_CanBeMonomial) <-- 
[
    Local(r);
    If( IsRationalFunction(expr),
        r := (VarList(Denominator(expr)) = {}),
        r := True
    );
];

15 # IsMonomial(_expr) <-- False;

%/mathpiper








%mathpiper_docs,name="IsMonomial",categories="User Functions;Predicates"
*CMD IsMonomial --- determine if {expr} is a Monomial
*STD
*CALL
	IsMonomial(expr)

*PARMS
{expr} -- an expression

*DESC
This function returns {True} if {expr} satisfies the definition of a {Monomial}.
Otherwise, {False}.
A {Monomial} is defined to be a single term, consisting of a product of numbers
and variables.

*E.G.
In> IsMonomial(24)
Result: True

In> IsMonomial(24*a*x^2*y^3)
Result: True

In> IsMonomial(24*a*x^2*y^3/15)
Result: True

In> IsMonomial(24*a*x^2*y^3/15+1)
Result: False
    
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasExprArith.mpw0000644000175000017500000000150311523200452030467 0ustar  giovannigiovanni%mathpiper,def="HasExprArith"

/// Analyse arithmetic expressions

HasExprArith(expr, atom) := HasExprSome(expr, atom, {ToAtom("+"), ToAtom("-"), *, /});


%/mathpiper



%mathpiper_docs,name="HasExprArith",categories="User Functions;Predicates"
*CMD HasExprArith --- check for expression containing a subexpression
*STD
*CALL
	HasExprArith(expr, x)

*PARMS

{expr} -- an expression

{x} -- a subexpression to be found

*DESC

{HasExprArith} is defined through {HasExprSome} to look only at arithmetic operations {+}, {-}, {*}, {/}.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasExprArith(x+y*Cos(Ln(x)/x), z)
Result: False;

*SEE HasExpr, HasExprSome, FuncList, VarList, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsOdd.mpw0000644000175000017500000000103711523200452027131 0ustar  giovannigiovanni%mathpiper,def="IsOdd"

IsOdd(n)  := IsInteger(n) And ( BitAnd(n,1)  = 1 );

%/mathpiper



%mathpiper_docs,name="IsOdd",categories="User Functions;Predicates"
*CMD IsOdd --- test for an odd integer
*STD
*CALL
	IsOdd(n)

*PARMS

{n} -- integer to test

*DESC

This function tests whether the integer "n" is odd. An integer is
odd if it is not divisible by two. Hence the odd numbers are 1, 3, 5,
7, 9, etc., and -1, -3, -5, -7, -9, etc.

*E.G.

In> IsOdd(4);
Result: False;
In> IsOdd(-1);
Result: True;

*SEE IsEven, IsInteger
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/FloatIsInt.mpw0000644000175000017500000000127311331203122030137 0ustar  giovannigiovanni%mathpiper,def="FloatIsInt"

/// TODO FIXME document this: FloatIsInt returns True if the argument is integer after removing potential trailing
/// zeroes after the decimal point
// but in fact this should be a call to BigNumber::IsIntValue()
FloatIsInt(_x) <--
   [
     x:=N(Eval(x));
     Local(prec,result,n);
     Bind(prec,BuiltinPrecisionGet());
     If(IsZero(x),Bind(n,2),
     If(x>0,
       Bind(n,2+FloorN(N(FastLog(x)/FastLog(10)))),
       Bind(n,2+FloorN(N(FastLog(-x)/FastLog(10))))
       ));
     BuiltinPrecisionSet(n+prec);
     Bind(result,IsZero(RoundTo(x-Floor(x),prec)) Or IsZero(RoundTo(x-Ceil(x),prec)));
     BuiltinPrecisionSet(prec);
     result;
   ];
//  

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsSumOfTerms.mpw0000644000175000017500000000544511522212340030474 0ustar  giovannigiovanni%mathpiper,def="IsSumOfTerms"

// an expression free of the variable -- obviously not a sum of terms in it
10 # IsSumOfTerms(_var,expr_IsFreeOf(var)) <-- False;

// an Atom cannot be a sum of terms
12 # IsSumOfTerms(_var,expr_IsAtom()) <-- False;

// after being "Listified", expr is a sum of terms if headed by "+" or "-"
14 # IsSumOfTerms(_var,expr_IsList())_(expr[1]=ToAtom("+") Or expr[1]=ToAtom("-")) <-- True;

// after being "Listified", an expr headed by "*" is not considered a sum 
// of terms unless one or the other operand is free of the variable
16 # IsSumOfTerms(_var,expr_IsList())_(expr[1]=ToAtom("*")) <-- Or(IsFreeOf(var,expr[2]),IsFreeOf(var,expr[3]));

// after being "Listified", an expr headed by "/" is not considered a sum 
// of terms unless the denominator (only) is free of the variable
18 # IsSumOfTerms(_var,expr_IsList())_(expr[1]=ToAtom("/")) <-- IsFreeOf(var,expr[3]);

// after being "Listified", any other expression is not a sum of terms
20 # IsSumOfTerms(_var,expr_IsList()) <-- False;

// if we get to this point, FunctionToList the expression and try again
22 # IsSumOfTerms(_var,_expr) <-- IsSumOfTerms(var,FunctionToList(expr));

%/mathpiper

%mathpiper_docs,name="IsSumOfTerms",categories="User Functions;Predicates"
*CMD IsSumOfTerms --- check for expression being a sum of terms in variable

*STD
*CALL
	IsSumOfTerms(var,expr)

*PARMS

{var} -- a variable name

{expr} -- an expression to be tested

*DESC

The command {IsSumOfTerms} returns {True} if the expression {expr} can be 
considered to be a "sum of terms" in the given variable {var}.  The criteria
are reasonable but somewhat arbitrary.  The criteria were selected after
a lot of experimentation, specifically to aid the logic used in Integration.

The criteria for {expr} to be a sum of terms in {var} are:
     o  {expr} is a function of variable {var}
     o  {expr} can best be described as a sum (or difference) of two or more
        functions of {var}  OR
        {expr} is a monomial in {var} (this latter is to simplify the logic)
     o  {expr} is not better described as a product of functions of {var}
     o  {expr} is not better described as a quotient of functions of {var}
        (i.e., is a rational function)

Note that the last three criteria are somewhat subjective!  

*E.G.
In> IsSumOfTerms(x,23)
Result> False
In> IsSumOfTerms(x,23*x)
Result> True
In> IsSumOfTerms(x,5*y)
Result> False
In> IsSumOfTerms(x,a*x^2-b*x-c/x)
Result> True
In> IsSumOfTerms(x,Sin(x))
Result> False
In> IsSumOfTerms(x,Sin(x)+Exp(x))
Result> True
In> IsSumOfTerms(x,d*(x^2-1))
Result> True
In> IsSumOfTerms(x,(x^2-1)*d)
Result> True
In> IsSumOfTerms(x,(x^2-1)/d)
Result> True
In> IsSumOfTerms(x,d/(x^2-1))
Result> False
In> IsSumOfTerms(x,(x^2-1)*(x^2+1))
Result> False
In> IsSumOfTerms(x,(x^2-1)/(x^2+1))
    Result> False    
    
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNonZeroInteger.mpw0000644000175000017500000000106711523200452031336 0ustar  giovannigiovanni%mathpiper,def="IsNonZeroInteger"

IsNonZeroInteger(x) := (IsInteger(x) And x != 0);

%/mathpiper



%mathpiper_docs,name="IsNonZeroInteger",categories="User Functions;Predicates"
*CMD IsNonZeroInteger --- test for a nonzero integer
*STD
*CALL
	IsNonZeroInteger(n)

*PARMS

{n} -- integer to test

*DESC

This function tests whether the integer {n} is not zero. If {n} is
not an integer, the result is {False}.

*E.G.

In> IsNonZeroInteger(0)
Result: False;
In> IsNonZeroInteger(-2)
Result: True;

*SEE IsPositiveInteger, IsNegativeInteger, IsNotZero
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsEven.mpw0000644000175000017500000000105111523200452027314 0ustar  giovannigiovanni%mathpiper,def="IsEven"

IsEven(n) := IsInteger(n) And ( BitAnd(n,1)  = 0 );

%/mathpiper



%mathpiper_docs,name="IsEven",categories="User Functions;Predicates"
*CMD IsEven --- test for an even integer
*STD
*CALL
	IsEven(n)

*PARMS

{n} -- integer to test

*DESC

This function tests whether the integer "n" is even. An integer is
even if it is divisible by two. Hence the even numbers are 0, 2, 4, 6,
8, 10, etc., and -2, -4, -6, -8, -10, etc.

*E.G.

In> IsEven(4);
Result: True;
In> IsEven(-1);
Result: False;

*SEE IsOdd, IsInteger
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsPolynomialOverIntegers.mpw0000644000175000017500000000353711517224250033117 0ustar  giovannigiovanni%mathpiper,def="IsPolynomialOverIntegers"

//Retract("IsPolynomialOverIntegers",*);

10 # IsPolynomialOverIntegers(expr_IsFunction) <-- 
[
    Local(x,vars);
    vars := VarList(expr);
    If(Length(vars)>1,vars:=HeapSort(vars,"IsGreaterThan"));    
    x := vars[1];
    IsPolynomialOverIntegers(expr,x);
];

15 # IsPolynomialOverIntegers(_expr) <-- False;


10 # IsPolynomialOverIntegers(_expr,_var)_(CanBeUni(var,expr)) <--
[
    If( AllSatisfy("IsInteger",Coef(expr,var,0 .. Degree(expr,var))),
        True,
        False
      );
];

15 # IsPolynomialOverIntegers(_expr,_var) <-- False;

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output


%mathpiper_docs,name="IsPolynomialOverIntegers",categories="Programmer Functions;Predicates"

*CMD IsPolynomialOverIntegers --- Check if {expr} is a polynomial in variable {var} all of whose coefficients are integers

*STD
*CALL
    IsPolynomialOverIntegers(expr,var)

*PARMS

{expr} -- an algebraic expression which may be a polynomial

{var} -- a variable name which might be used in {expr}

*DESC

The command {IsPolynomialOverIntegers} returns {True} if {expr} is a polynomial in {var} and all of its coefficients are integers.
It returns {False} if {expr} is not a polynomial in {var} or if any of its coefficients are not integers.

This can be important, since many factoring theorems are applicable to such polynomials but not others.

*E.G.

In> IsPolynomialOverIntegers(2*x^3-3*x^2+5*x-14,x)
Result: True 

In> IsPolynomialOverIntegers(2.0*x^3-3*x^2+5*x-14,x)
Result: False

In> IsPolynomialOverIntegers(y^2-4)
Result: True
        NOTE: if variable name is omitted, a reasonable default is taken.

In> IsPolynomialOverIntegers(x^2-a^2)
Result: False
        NOTE: the unbound variable 'a' need not be an integer.

%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsLowerTriangular.mpw0000644000175000017500000000143611523200452031547 0ustar  giovannigiovanni%mathpiper,def="IsLowerTriangular"

IsLowerTriangular(A_IsMatrix) <-- (IsUpperTriangular(Transpose(A)));

%/mathpiper



%mathpiper_docs,name="IsLowerTriangular",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsLowerTriangular --- test for a lower triangular matrix
*STD
*CALL
	IsLowerTriangular(A)

*PARMS

{A} -- a matrix

*DESC

A lower triangular matrix is a square matrix which has all zero entries below the diagonal.

{IsLowerTriangular(A)} returns {True} if {A} is a lower triangular matrix and {False} otherwise.

*E.G.
In> IsLowerTriangular(Identity(5))
Result: True;
In> IsLowerTriangular({{1,2},{0,1}})
Result: False;

A non-square matrix cannot be triangular:
In> IsLowerTriangular({{1,2,3},{0,1,2}})
Result: False;

*SEE IsUpperTriangle, IsDiagonal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsEquation.mpw0000644000175000017500000000133311517224250030214 0ustar  giovannigiovanni%mathpiper,def="IsEquation"

//Retract("IsEquation",*);

10 # IsEquation(expr_IsAtom) <-- False;

12 # IsEquation(_expr) <-- FunctionToList(expr)[1] = == ; 

%/mathpiper




%mathpiper_docs,name="IsEquation",categories="User Functions;Predicates"

*CMD IsEquation --- Return true if {expr} is an Equation False otherwise

*STD
*CALL
	IsEquation(expr)

*PARMS

{expr} -- mathematical expression

*DESC

This function returns {True} if MathPiper can determine that the expression is an equation.  
Otherwise, {False}.
Equations are defined by the property that they are of the form {a==b}.

*E.G.

In> IsEquation(x^2==4)

Result: True

In> IsEquation(x^2-4)

Result: False

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNumericList.mpw0000644000175000017500000000107311316304766030676 0ustar  giovannigiovanni%mathpiper,def="IsNumericList"

// check that all items in the list are numbers
IsNumericList(_arg'list) <-- IsList(arg'list) And
	("And" @ (MapSingle(Hold({{x},IsNumber(N(Eval(x)))}), arg'list)));

%/mathpiper



%mathpiper_docs,name="IsNumericList",categories="User Functions;Predicates"
*CMD IsNumericList --- test for a list of numbers
*STD
*CALL
	IsNumericList({list})

*PARMS

{{list}} -- a list

*DESC
Returns {True} when called on a list of numbers or expressions that evaluate to numbers using {N()}. Returns {False} otherwise.

*SEE N, IsNumber
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNotZero.mpw0000644000175000017500000000134511523200452030025 0ustar  giovannigiovanni%mathpiper,def="IsNotZero"

/*
10 # IsNotZero(x_IsNumber)       <-- ( RoundTo(x,BuiltinPrecisionGet()) != 0);
*/


10 # IsNotZero(x_IsNumber) <-- ( AbsN(x)  >= PowerN(10, -BuiltinPrecisionGet()));
10 # IsNotZero(x_IsInfinity) <-- True;
60000 # IsNotZero(_x) <-- False;

%/mathpiper



%mathpiper_docs,name="IsNotZero",categories="User Functions;Predicates"
*CMD IsNotZero --- test for a nonzero number
*STD
*CALL
	IsNotZero(n)

*PARMS

{n} -- number to test

*DESC

{IsNotZero(n)} evaluates to {True} if {n} is not zero. In case {n} is not a
number, the function returns {False}.

*E.G.

In> IsNotZero(3.25);
Result: True;
In> IsNotZero(0);
Result: False;

*SEE IsNumber, IsPositiveNumber, IsNegativeNumber, IsNonZeroInteger
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsIdempotent.mpw0000644000175000017500000000114311523200452030531 0ustar  giovannigiovanni%mathpiper,def="IsIdempotent"

IsIdempotent(A_IsMatrix) <-- (A^2 = A);

%/mathpiper



%mathpiper_docs,name="IsIdempotent",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsIdempotent --- test for an idempotent matrix
*STD
*CALL
	IsIdempotent(A)

*PARMS

{A} -- a square matrix

*DESC

{IsIdempotent(A)} returns {True} if {A} is idempotent and {False} otherwise.
$A$ is idempotent iff $A^2=A$. Note that this also implies that $A$ raised
to any power is also equal to $A$.

*E.G.

In> IsIdempotent(ZeroMatrix(10,10));
Result: True;
In> IsIdempotent(Identity(20))
Result: True;
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsPositiveReal.mpw0000644000175000017500000000175111523200452031034 0ustar  giovannigiovanni%mathpiper,def="IsPositiveReal"

/* See if a number, when evaluated, would be a positive real value */
IsPositiveReal(_r) <--
[
  r:=N(Eval(r));
  (IsNumber(r) And r >= 0);
];

%/mathpiper



%mathpiper_docs,name="IsPositiveReal",categories="User Functions;Predicates"
*CMD IsPositiveReal --- test for a numerically positive value
*STD
*CALL
	IsPositiveReal(expr)

*PARMS

{expr} -- expression to test

*DESC

This function tries to approximate "expr" numerically. It returns {True} if this approximation is positive. In case no
approximation can be found, the function returns {False}. Note that round-off errors may cause incorrect
results.

*E.G.

In> IsPositiveReal(Sin(1)-3/4);
Result: True;
In> IsPositiveReal(Sin(1)-6/7);
Result: False;
In> IsPositiveReal(Exp(x));
Result: False;

The last result is because {Exp(x)} cannot be
numerically approximated if {x} is not known. Hence
MathPiper can not determine the sign of this expression.

*SEE IsNegativeReal, IsPositiveNumber, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/HasFuncSome.mpw0000644000175000017500000000341611523200452030305 0ustar  giovannigiovanni%mathpiper,def="HasFuncSome"

/// function name given as string.
10 # HasFuncSome(_expr, string_IsString, _look'list) <-- HasFuncSome(expr, ToAtom(string), look'list);
/// function given as atom.
// atom contains no functions
10 # HasFuncSome(expr_IsAtom, atom_IsAtom, _look'list) <-- False;
// a list contains the function List so we test it together with functions
// a function contains itself, or maybe an argument contains it

// first deal with functions that do not belong to the list: return top level function
15 # HasFuncSome(expr_IsFunction, atom_IsAtom, _look'list)_(Not Contains(look'list, ToAtom(Type(expr)))) <-- IsEqual(First(FunctionToList(expr)), atom);
// function belongs to the list - check its arguments
20 # HasFuncSome(expr_IsFunction, atom_IsAtom, _look'list) <-- IsEqual(First(FunctionToList(expr)), atom) Or ListHasFuncSome(Rest(FunctionToList(expr)), atom, look'list);

%/mathpiper



%mathpiper_docs,name="HasFuncSome",categories="User Functions;Predicates"
*CMD HasFuncSome --- check for expression containing a function
*STD
*CALL
	HasFuncSome(expr, func, list)

*PARMS

{expr} -- an expression

{func} -- a function atom to be found

{list} -- list of function atoms to be considered "transparent"

*DESC

The command {HasFuncSome} does the same thing as {HasFunc}, except it only looks at arguments of a given {list} of functions. Arguments of all other functions become "opaque" (as if they do not contain anything).

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> HasFuncSome({a+b*2,c/d},/,{List})
Result: True;
In> HasFuncSome({a+b*2,c/d},*,{List})
Result: False;

*SEE HasFunc, HasFuncArith, FuncList, VarList, HasExpr
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsNegativeNumber.mpw0000644000175000017500000000116311523200452031336 0ustar  giovannigiovanni%mathpiper,def="IsNegativeNumber"

IsNegativeNumber(x):= IsNumber(x) And x < 0;

%/mathpiper



%mathpiper_docs,name="IsNegativeNumber",categories="User Functions;Predicates"
*CMD IsNegativeNumber --- test for a negative number
*STD
*CALL
	IsNegativeNumber(n)

*PARMS

{n} -- number to test

*DESC

{IsNegativeNumber(n)} evaluates to {True} if $n$ is (strictly) negative, i.e.
if $n<0$. If {n} is not a number, the functions return {False}. 

*E.G.

In> IsNegativeNumber(6);
Result: False;
In> IsNegativeNumber(-2.5);
Result: True;

*SEE IsNumber, IsPositiveNumber, IsNotZero, IsNegativeInteger, IsNegativeReal
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/predicates/IsUnitary.mpw0000644000175000017500000000133511523200452030057 0ustar  giovannigiovanni%mathpiper,def="IsUnitary"

IsUnitary(A_IsMatrix) <-- (Transpose(Conjugate(A))*A = Identity(Length(A)));

%/mathpiper



%mathpiper_docs,name="IsUnitary",categories="User Functions;Matrices (Predicates);Predicates"
*CMD IsUnitary --- test for a unitary matrix
*STD
*CALL
	IsUnitary(A)

*PARMS

{A} -- a square matrix

*DESC

This function tries to find out if A is unitary.

A matrix $A$ is orthogonal iff $A^(-1)$ = Transpose( Conjugate($A$) ). This is
equivalent to the fact that the columns of $A$ build an orthonormal system
(with respect to the scalar product defined by {InProduct}).

*E.G.

In> IsUnitary({{0,I},{-I,0}})
Result: True;
In> IsUnitary({{0,I},{2,0}})
Result: False;

*SEE IsHermitian, IsSymmetric
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/radsimp/0000755000175000017500000000000011722677332024735 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/radsimp/RadSimp.mpw0000644000175000017500000000553011523200452027004 0ustar  giovannigiovanni%mathpiper,def="RadSimp"

//Retract("RadSimp",*);

/* Simplification of nested radicals.
*/

10 # RadSimp(_n)_(Length(VarList(n))<1) <--
[
  Local(max, result);
  Bind(max, CeilN(N(Eval(n^2))));
  Bind(result,0);
  Bind(result,RadSimpTry(n,0,1,max));

//Echo("result is ",result);
  if (CheckRadicals(n,result))
    result
  else
    n;
];


20 # RadSimp(_n) <-- n;


/*Echo({"Try ",test}); */

CheckRadicals(_n,_test) <-- Abs(N(Eval(n-test),20)) < 0.000001;

10 # ClampRadicals(_r)_(N(Eval(Abs(r)), 20)<0.000001) <-- 0;
20 # ClampRadicals(_r) <-- r;



RadSimpTry(_n,_result,_current,_max)<--
[
//Echo(result," ",n," ",current);
  if (IsLessThan(N(Eval(result-n)), 0))
  [
    Local(i);

    // First, look for perfect match
    i:=BSearch(max,Hold({{try},ClampRadicals(N(Eval((result+Sqrt(try))-n),20))}));
    If(i>0,
    [
      Bind(result,result+Sqrt(i));
      Bind(i,AddN(max,1));
      Bind(current,AddN(max,1));
    ]);

    // Otherwise, search for another solution
    if (IsLessThan(N(Eval(result-n)), 0))
    [
      For (Bind(i,current),i<=max,Bind(i,AddN(i,1)))
      [
        Local(new, test);
        Bind(test,result+Sqrt(i));

/* Echo({"Full-try ",test}); */

        Bind(new,RadSimpTry(n,test,i,max));
	if (CheckRadicals(n,new))
        [
          Bind(result,new);
          Bind(i,AddN(max,1));
        ];
      ];
    ];
  ];
  result;
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="RadSimp",categories="User Functions;Expression Simplification"
*CMD RadSimp --- simplify expression with nested radicals
*STD
*CALL
	RadSimp(expr)

*PARMS

{expr} -- an expression containing nested radicals

*DESC

This function tries to write the expression "expr" as a sum of roots
of integers: $Sqrt(e1) + Sqrt(e2) + ...$, where $e1$, $e2$ and
so on are natural numbers. The expression "expr" may not contain
free variables.

It does this by trying all possible combinations for $e1$, $e2$, ...
Every possibility is numerically evaluated using {N} and compared with the numerical evaluation of
"expr". If the approximations are equal (up to a certain margin),
this possibility is returned. Otherwise, the expression is returned
unevaluated.

Note that due to the use of numerical approximations, there is a small
chance that the expression returned by {RadSimp} is
close but not equal to {expr}. The last example underneath
illustrates this problem. Furthermore, if the numerical value of
{expr} is large, the number of possibilities becomes exorbitantly
big so the evaluation may take very long.

*E.G.

In> RadSimp(Sqrt(9+4*Sqrt(2)))
Result: Sqrt(8)+1;
In> RadSimp(Sqrt(5+2*Sqrt(6)) \
	  +Sqrt(5-2*Sqrt(6)))
Result: Sqrt(12);
In> RadSimp(Sqrt(14+3*Sqrt(3+2
	*Sqrt(5-12*Sqrt(3-2*Sqrt(2))))))
Result: Sqrt(2)+3;

But this command may yield incorrect results:

In> RadSimp(Sqrt(1+10^(-6)))
Result: 1;

*SEE Simplify, N
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/equations/0000755000175000017500000000000011722677336025312 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/equations/EquationRight.mpw0000644000175000017500000000140511523200452030576 0ustar  giovannigiovanni%mathpiper,def="EquationRight"

EquationRight(_symbolicEquation)_(Type(symbolicEquation) = "==")  <--
[
    Local(listForm);
    
    listForm := FunctionToList(symbolicEquation);
    
    listForm[3];
];

%/mathpiper



%mathpiper_docs,name="EquationRight",categories="User Functions;Expression Manipulation"
*CMD EquationRight --- return the right side of a symbolic equation
*STD
*CALL
	EquationRight(equation)
	
*PARMS

{equation} -- symbolic equation.


*DESC

A symbolic equation is an equation which is defined using the == operator.  This
function returns the right side of a symbolic equation.

*E.G.

In> equ := y^2 == 4*p*x
Result: y^2==4*p*x

In> EquationRight(equ)
Result: 4*p*x

*SEE ==, EquationLeft
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/equations/EquationLeft.mpw0000644000175000017500000000137411523200452030420 0ustar  giovannigiovanni%mathpiper,def="EquationLeft"

EquationLeft(_symbolicEquation)_(Type(symbolicEquation) = "==")  <--
[
    Local(listForm);
    
    listForm := FunctionToList(symbolicEquation);
    
    listForm[2];
];
%/mathpiper




%mathpiper_docs,name="EquationLeft",categories="User Functions;Expression Manipulation"
*CMD EquationLeft --- return the left side of a symbolic equation
*STD
*CALL
	EquationLeft(equation)
	
*PARMS

{equation} -- symbolic equation.


*DESC

A symbolic equation is an equation which is defined using the == operator.  This
function returns the left side of a symbolic equation.

*E.G.

In> equ := y^2 == 4*p*x
Result: y^2==4*p*x

In> EquationLeft(equ)
Result: y^2

*SEE ==, EquationRight
%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/0000755000175000017500000000000011722677335024605 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/UniDivide.mpw0000644000175000017500000000112111316324171027167 0ustar  giovannigiovanni%mathpiper,def="UniDivide"

/* division algo: (for zero-base univariates:) */
Function("UniDivide",{u,v})
[
  Local(m,n,q,r,k,j);
  m := Length(u)-1;
  n := Length(v)-1;
  While (m>0 And IsZero(u[m+1])) m--;
  While (n>0 And IsZero(v[n+1])) n--;
  q := ZeroVector(m-n+1);
  r := FlatCopy(u);  /*  (m should be >= n) */
  For(k:=m-n,k>=0,k--)
  [
    q[k+1] := r[n+k+1]/v[n+1];
    For (j:=n+k-1,j>=k,j--)
    [
      r[j+1] := r[j+1] - q[k+1]*v[j-k+1];
    ];
  ];
  Local(end);
  end:=Length(r);
  While (end>n)
  [
    DestructiveDelete(r,end);
    end:=end-1;
  ];

  {q,r};
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/DivPoly.mpw0000644000175000017500000000101411316324171026676 0ustar  giovannigiovanni%mathpiper,def="DivPoly"

DivPoly(_A,_B,_var,_deg) <--
[
  Local(a,b,c,i,j,denom);
  b:=MakeUni(B,var);
  denom:=Coef(b,0);

  if (denom = 0)
  [
    Local(f);
    f:=Content(b);
    b:=PrimitivePart(b);
    A:=Simplify(A/f);
    denom:=Coef(b,0);
  ];
  a:=MakeUni(A,var);

  c:=FillList(0,deg+1);
  For(i:=0,i<=deg,i++)
  [
    Local(sum,j);
    sum:=0;
    For(j:=0,j poly := 2*x^2 + 4*x;
Result: 2*x^2+4*x;
In> c := Content(poly);
Result: 2*x;
In> pp := PrimitivePart(poly);
Result: x+2;
In> Expand(pp*c);
Result: 2*x^2+4*x;

*SEE PrimitivePart, Gcd
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/NormalForm.mpw0000644000175000017500000000051211316324171027366 0ustar  giovannigiovanni%mathpiper,def=""

/*
Note:tk:since this version of NormalForm is only used in univariate functions, and since
 the standard version of NormalForm is published as a def in standard.mpw,
I am not publishing it as a def here.
*/

0 # NormalForm(UniVariate(_var,_first,_coefs)) <--
    ExpandUniVariate(var,first,coefs);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/ExpandUniVariate.mpw0000644000175000017500000000042011316324171030517 0ustar  giovannigiovanni%mathpiper,def="ExpandUniVariate"

Function("ExpandUniVariate",{var,first,coefs})
[
  Local(result,i);
  result:=0;
  For(i:=Length(coefs),i>0,i--)
  [
    Local(term);
    term:=NormalForm(coefs[i])*var^(first+i-1);
    result:=result+term;
  ];
  result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/0000755000175000017500000000000011722677335025757 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/BoundRealRoots.mpw0000644000175000017500000000372011316324171031372 0ustar  giovannigiovanni%mathpiper,def="BoundRealRoots"

BoundRealRoots(_p) <--
[
  BoundRealRoots(p,MinimumBound(p),MaximumBound(p));
];

BoundRealRoots(_p,_Mmin,_Mmax) <--
[
  Local(S,N,work,result,Vmin,Vmax,a,b,Va,Vb,c,Vc,x);

  result:={};
  if (IsZero(p Where x==0))
  [
    p:=Simplify(p/x);
    result:={{0,0}};
  ];
  S:=SturmSequence(p);
  Vmin := SturmVariations(S,-Infinity);
  Vmax := SturmVariations(S,Infinity);

//Echo("Vmin,Vmax = ",Vmin,Vmax);

  N:=Vmin - Vmax;

//Echo("N = ",N);

//Echo("Mmin,Mmax = ",Mmin,Mmax);
  work:={};
  if (N=1)
  [
    result:={{-Mmax,Mmax}};
  ];
  if (N>1)
  [
    work :=
    {
      {-Mmax,-Mmin,Vmin,SturmVariations(S,-Mmin)},
      { Mmin, Mmax,SturmVariations(S, Mmin),Vmax}
    };
  ];

//Echo("Work start = ",work);
    While(work != {})
    [
      {a,b,Va,Vb} := First(work);
      work := Rest(work);
      c:=(a+b)/2;
//Echo(a,b,c);
      Vc := SturmVariations(S,c);
      if (IsZero(p Where x == c))
      [
        Local(M,Vcmin,Vcplus,pnew);
        pnew := Simplify((p Where x == x+c)/x);
        M:=MinimumBound(pnew);
//Echo("Mi = ",M);
        Vcmin  := SturmVariations(S, c-M);
        Vcplus := SturmVariations(S, c+M);
        result:=Concat(result,{{c,c}});

        if (Va = Vcmin+1)
        [
          result:=Concat(result,{{a,c-M}});
        ];
        if (Va > Vcmin+1)
        [
          work:=Concat(work,{{a,c-M,Va,Vcmin}});
        ];
        if (Vb = Vcplus-1)
        [
          result:=Concat(result,{{c+M,b}});
        ];
        if (Vb < Vcplus-1)
        [
          work:=Concat(work,{{c+M,b,Vcplus,Vb}});
        ];
      ]
      else
      [
        if (Va = Vc+1)
        [
          result:=Concat(result,{{a,c}});
        ];
        if (Va > Vc+1)
        [
          work:=Concat(work,{{a,c,Va,Vc}});
        ];
        if (Vb = Vc-1)
        [
          result:=Concat(result,{{c,b}});
        ];
        if (Vb < Vc-1)
        [
          work:=Concat(work,{{c,b,Vc,Vb}});
        ];
      ];
    ];
    result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/FindRealRoots.mpw0000644000175000017500000000565011523200452031202 0ustar  giovannigiovanni%mathpiper,def="FindRealRoots"

iDebug:=False;

//Retract("FindRealRoots",*);

FindRealRoots(_p) <--
[
    If(iDebug,Tell("FindRealRoots",p));
    Local(vars,var,cc,pp,vlcc,zeroRoot,minb,maxb,rr);
    vars := VarList(p);
    var  := vars[1];
    cc   := Content(p);
    pp   := PrimitivePart(p);
    If(iDebug,Tell("   ",{cc,pp}));
    vlcc := VarList(cc);
    If(Length(vlcc)>0 And Contains(vlcc,var), zeroRoot:=True,zeroRoot:=False);
    p:=SquareFree(Rationalize(pp));
    If(iDebug,Tell("   after sqf",p));
    minb := MinimumBound(p);
    maxb := MaximumBound(p);
    If(iDebug,Tell("   ",{minb,maxb}));
    rr := FindRealRoots(p,minb,maxb);
    If(zeroRoot,DestructiveAppend(rr,0));
    rr;
];


FindRealRoots(_p,_Mmin,_Mmax) <--
[
    If(iDebug,Tell("  FindRealRoots3",{p,Mmin,Mmax}));
    Local(bounds,result,i,prec,requiredPrec);
    bounds := BoundRealRoots(p,Mmin,Mmax);
    If(iDebug,Tell("      ",{bounds,Length(bounds)}));
    result:=FillList(0,Length(bounds));
    requiredPrec := BuiltinPrecisionGet();
    BuiltinPrecisionSet(BuiltinPrecisionGet()+4);
    prec:=10^-(requiredPrec+1);

    For(i:=1,i<=Length(bounds),i++)
    [
        If(iDebug,Tell(i));
        Local(a,b,c,r);
        {a,b} := bounds[i];
        c:=N(Eval((a+b)/2));
        If(iDebug,Tell("         ",{a,b,c}));
        r := Fail;
        If(iDebug,Tell("         newt1",`Hold(Newton(@p,x,@c,@prec,@a,@b))));
        if (a != b) [r := `Newton(@p,x,@c,prec,a,b);];
        If(iDebug,Tell("         newt2",r));
        if (r = Fail)
          [
             Local(c,cold,pa,pb,pc);
             pa:=(p Where x==a);
             pb:=(p Where x==b);
             c:=((a+b)/2);
             cold := a;
             While (Abs(cold-c)>prec)
             [
                 pc:=(p Where x==c);
                 If(iDebug,Tell("              ",{a,b,c}));
                 if (Abs(pc) < prec)
                   [ a:=c; b:=c; ]
                 else if (pa*pc < 0)
                   [ b:=c; pb:=pc; ]
                 else
                   [ a:=c; pa:=pc; ];
                   cold:=c;
                   c:=((a+b)/2);
             ];
             r:=c;
          ];
        result[i] := N(Eval((r/10)*(10)),requiredPrec);
    ];
    BuiltinPrecisionSet(requiredPrec);
    result;
];

%/mathpiper



%mathpiper_docs,name="FindRealRoots",categories="User Functions;Solvers (Numeric)"
*CMD FindRealRoots --- find the real roots of a polynomial
*STD
*CALL
	FindRealRoots(p)

*PARMS

{p} - a polynomial in {x}

*DESC

Return a list with the real roots of $ p $. It tries to find the real-valued
roots, and thus requires numeric floating point calculations. The precision
of the result can be improved by increasing the calculation precision.

*E.G. notest

In> p:=Expand((x+3.1)^5*(x-6.23))
Result: x^6+9.27*x^5-0.465*x^4-300.793*x^3-
	1394.2188*x^2-2590.476405*x-1783.5961073;
In> FindRealRoots(p)
Result: {-3.1,6.23};

*SEE SquareFree, RealRootsCount, MinimumBound, MaximumBound, Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/SturmSequence.mpw0000644000175000017500000000135111517224250031271 0ustar  giovannigiovanni%mathpiper,def="SturmSequence"

//Retract("SturmSequence",*);

/** SturmSequence(p) : generate a Sturm sequence for a univariate polynomial
 */

10 # SturmSequence(_p,_var) <--
[
  Local(result,i,deg,nt);
  If(InVerboseMode(),Tell(10));
  result := {p,`Differentiate(@var)(@p)};
  deg    := Degree(p,var);
  For(i:=3,i<=deg+1,i++)
  [
    nt := -NormalForm(MultiDivide(MM(result[i-2],{var}),{MM(result[i-1],{var})})[2]);//??
    DestructiveAppend(result,nt);
  ];
  result;
];

20 # SturmSequence(_p)_(Length(VarList(p))=1) <-- SturmSequence(p,VarList(p)[1]);

30 # SturmSequence(_p) <-- Check(Length(VarList(p))=1,"Argument","Input must be Univariate Polynomial. ");


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/MinimumBound.mpw0000644000175000017500000000217011523200452031064 0ustar  giovannigiovanni%mathpiper,def="MinimumBound"

10 # MinimumBound(_p)_(IsZero(p Where x==0)) <-- 0;

20 # MinimumBound(_p)_(Degree(p)>0) <--
[
  Local(an,result);
  an:=Coef(p,1 .. (Degree(p)))/Coef(p,0);
  an := N(Eval(Abs(an)^(1/(1 .. Degree(p)))));

  result:=0;
  an:=2*Maximum(an);
  if(Not IsZero(an)) [result := 1/an;];
  Simplify(Rationalize(result));
];
30 # MinimumBound(_p) <-- -Infinity;

%/mathpiper



%mathpiper_docs,name="MinimumBound",categories="User Functions;Solvers (Numeric)
*CMD MinimumBound --- return lower bounds on the absolute values of real roots of a polynomial
*STD
*CALL
	MinimumBound(p)

*PARMS

{p} - a polynomial in $x$

*DESC

Return minimum bounds for the absolute values of the real
roots of a polynomial {p}. The polynomial has to be converted to one with
rational coefficients first, and be made square-free.
The polynomial must use the variable {x}.

*E.G.

In> p:=SquareFree(Rationalize((x-3.1)*(x+6.23)))
Result: (-40000*x^2-125200*x+772520)/870489;
In> MinimumBound(p)
Result: 5000000000/2275491039;
In> N(%)
Result: 2.1973279236;

*SEE MaximumBound, SquareFree, RealRootsCount, FindRealRoots, Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/SturmVariations.mpw0000644000175000017500000000147211316324171031644 0ustar  giovannigiovanni%mathpiper,def="SturmVariations"

10 # SturmVariations(_S,Infinity) <--
[
  Local(i,s);
  s:=FillList(0,Length(S));
  For(i:=1,i<=Length(S),i++)
  [
    s[i] := LeadingCoef(S[i]);
  ];
  SturmVariations(s);
];

10 # SturmVariations(_S,-Infinity) <--
[
  Local(i,s);
  s:=FillList(0,Length(S));
  For(i:=1,i<=Length(S),i++)
  [
    s[i] := ((-1)^Degree(S[i]))*LeadingCoef(S[i]);
  ];
  SturmVariations(s);
];

20 # SturmVariations(_S,_x) <-- SturmVariations(Eval(S));
SturmVariations(_S) <--
[
  Local(result,prev);
//Echo("S = ",S);
  result:=0;
  While(Length(S)>0 And IsZero(S[1])) S:=Rest(S);
//Echo("S = ",S);
  if (Length(S)>0)
  [
    prev:=S[1];
    ForEach(item,Rest(S))
    [
      if(Not IsZero(item))
      [
        if (prev*item < 0) [result++;];
        prev:=item;
      ];
    ];
  ];
  result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/MaximumBound.mpw0000644000175000017500000000245111523200452031070 0ustar  giovannigiovanni%mathpiper,def="MaximumBound"

/** Maximum bound on the absolute value of the roots of a
  polynomial p in variable x, according to Knuth:

  Maximum( Abs(a[n-1]/a[n]) , Abs(a[n-2]/a[n])^(1/2), ... , Abs(a[0]/a[n])^(1/n) )

 As described in Davenport.
 */
 5 # MaximumBound(_p)_(IsZero(p Where x==0)) <-- MaximumBound(Simplify(p/x));
10 # MaximumBound(_p)_(Degree(p)>0) <--
[
  Local(an);
  an:=Coef(p,(Degree(p)-1) .. 0)/Coef(p,Degree(p));
  an := N(Eval(Abs(an)^(1/(1 .. Degree(p)))));
  Rationalize(2*Maximum(an));
];

20 # MaximumBound(_p) <-- Infinity;

%/mathpiper



%mathpiper_docs,name="MaximumBound",categories="User Functions;Solvers (Numeric)"
*CMD MaximumBound --- return upper bounds on the absolute values of real roots of a polynomial
*STD
*CALL
	MaximumBound(p)

*PARMS

{p} - a polynomial in $x$

*DESC

Return maximum bounds for the absolute values of the real
roots of a polynomial {p}. The polynomial has to be converted to one with
rational coefficients first, and be made square-free.
The polynomial must use the variable {x}.

*E.G.

In> p:=SquareFree(Rationalize((x-3.1)*(x+6.23)))
Result: (-40000*x^2-125200*x+772520)/870489;
In> MaximumBound(p)
Result: 10986639613/1250000000;
In> N(%)
Result: 8.7893116904;

*SEE MinimumBound, SquareFree, RealRootsCount, FindRealRoots, Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/RealRootsCount.mpw0000644000175000017500000000132111523200452031401 0ustar  giovannigiovanni%mathpiper,def="RealRootsCount"

RealRootsCount(_p) <--
[
  Local(S);
  p:=SquareFree(Rationalize(p));
  S:=SturmSequence(p);
  SturmVariations(S,-Infinity)-SturmVariations(S,Infinity);
];

%/mathpiper



%mathpiper_docs,name="RealRootsCount",categories="User Functions;Solvers (Numeric)"
*CMD RealRootsCount --- return the number of real roots of a polynomial
*STD
*CALL
	RealRootsCount(p)

*PARMS

{p} - a polynomial in {x}

*DESC

Returns the number of real roots of a polynomial $ p $.
The polynomial must use the variable {x} and no other variables.

*E.G.

In> RealRootsCount(x^2-1)
Result: 2;
In> RealRootsCount(x^2+1)
Result: 0;

*SEE FindRealRoots, SquareFree, MinimumBound, MaximumBound, Factor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sturm/SquareFree.mpw0000644000175000017500000000267111523200452030531 0ustar  giovannigiovanni%mathpiper,def="SquareFree"

//Retract("SquareFree",*);


10 # SquareFree(_p)_(Length(VarList(p))!=1) <-- Check(False,"Argument","Input must be Univariate");

12 # SquareFree(_p) <-- SquareFree(p,VarList(p)[1]);

14 # SquareFree(_p,_var)_(Not IsPolynomial(p,var)) <-- Check(False,"Argument","Input must be Univariate Polynomial");

16 # SquareFree(_p,_var) <--
[
  /*
  Local(dp,gcd);
  dp:=MakeMultiNomial(`(Differentiate(var)(@p)),{var});

  p:=MakeMultiNomial(p,{var});
  gcd:=MultiGcd(p,dp);
  NormalForm(MultiDivide(p,{gcd})[1][1]);
  */
  Quotient(p,Gcd(p,(`(Differentiate(@var)(@p)))));
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output

    

  
    



%mathpiper_docs,name="SquareFree",categories="User Functions;Polynomials (Operations)"
*CMD SquareFree --- return the square-free part of a univariate polynomial
*STD
*CALL
	SquareFree(p)

*PARMS

{p} - a univariate polynomial

*DESC

Given a polynomial 
$$ p = p[1]^n[1]* ... * p[m]^n[m] $$
with irreducible polynomials $ p[i] $,
return the square-free version part (with all the factors having
multiplicity 1):
$$ p[1]* ... * p[m] $$

Throws "argument" exception if input is not a univariate polynomial.

*E.G.

In> Expand((x+1)^5)
Result: x^5+5*x^4+10*x^3+10*x^2+5*x+1;
In> SquareFree(%)
Result: (x+1)/5;
In> Monic(%)
Result: x+1;

*SEE FindRealRoots, RealRootsCount, MinimumBound, MaximumBound, Factor
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/SetOrder.mpw0000644000175000017500000000010611316324171027040 0ustar  giovannigiovanni%mathpiper,def=""

//Not implemented in scripts. todo:tk.

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/UniTaylor.mpw0000644000175000017500000000111311331203122027223 0ustar  giovannigiovanni%mathpiper,def="UniTaylor"

Function("UniTaylor",{taylorfunction,taylorvariable,taylorat,taylororder})
[
  Local(n,result,dif,polf);
  result:={};
  [
    MacroLocal(taylorvariable);
    MacroBind(taylorvariable,taylorat);
    DestructiveAppend(result,Eval(taylorfunction));
  ];
  dif:=taylorfunction;
  polf:=(taylorvariable-taylorat);
  For(n:=1,n<=taylororder,n++)
  [
    dif:= Deriv(taylorvariable) dif;
    MacroLocal(taylorvariable);
    MacroBind(taylorvariable,taylorat);
    DestructiveAppend(result,(Eval(dif)/n!));
  ];
  UniVariate(taylorvariable,0,result);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/UniVariate.mpw0000644000175000017500000000506711331203122027360 0ustar  giovannigiovanni%mathpiper,def="UniVariate"

//Auxiliary function.
ShiftUniVar(UniVariate(_var,_first,_coefs),_fact,_shift)
   <--
   [
//Echo("fact, coefs = ",fact,coefs);
     UniVariate(var,first+shift,fact*coefs);
   ];



Rulebase("UniVariate",{var,first,coefs});

Rule("UniVariate",3,10,Length(coefs)>0 And coefs[1]=0)
  UniVariate(var,first+1,Rest(coefs));
Rule("UniVariate",3,1000,IsComplex(var) Or IsList(var))
    ExpandUniVariate(var,first,coefs);

500 # UniVariate(_var,_f1,_c1) + UniVariate(_var,_f2,_c2) <--
[
  Local(from,result);
  Local(curl,curr,left,right);

  Bind(curl, f1);
  Bind(curr, f2);
  Bind(left, c1);
  Bind(right, c2);
  Bind(result, {});
  Bind(from, Minimum(curl,curr));

  While(And(IsLessThan(curl,curr),left != {}))
  [
    DestructiveAppend(result,First(left));
    Bind(left,Rest(left));
    Bind(curl,AddN(curl,1));
  ];
  While(IsLessThan(curl,curr))
  [
    DestructiveAppend(result,0);
    Bind(curl,AddN(curl,1));
  ];
  While(And(IsLessThan(curr,curl), right != {}))
  [
    DestructiveAppend(result,First(right));
    Bind(right,Rest(right));
    Bind(curr,AddN(curr,1));
  ];
  While(IsLessThan(curr,curl))
  [
    DestructiveAppend(result,0);
    Bind(curr,AddN(curr,1));
  ];
  While(And(left != {}, right != {}))
  [
    DestructiveAppend(result,First(left)+First(right));
    Bind(left, Rest(left));
    Bind(right, Rest(right));
  ];
  While(left != {})
  [
    DestructiveAppend(result,First(left));
    Bind(left, Rest(left));
  ];
  While(right != {})
  [
    DestructiveAppend(result,First(right));
    Bind(right, Rest(right));
  ];

  UniVariate(var,from,result);
];


200 # UniVariate(_var,_first,_coefs) + a_IsNumber <--
      UniVariate(var,first,coefs) + UniVariate(var,0,{a});
200 # a_IsNumber + UniVariate(_var,_first,_coefs) <--
      UniVariate(var,first,coefs) + UniVariate(var,0,{a});


200 # - UniVariate(_var,_first,_coefs) <-- UniVariate(var,first,-coefs);


200 # (_factor * UniVariate(_var,_first,_coefs))_((IsFreeOf(var,factor))) <--
  UniVariate(var,first,coefs*factor);

200 # (UniVariate(_var,_first,_coefs)/_factor)_((IsFreeOf(var,factor))) <--
  UniVariate(var,first,coefs/factor);



200 # UniVariate(_var,_f1,_c1) * UniVariate(_var,_f2,_c2) <--
[
  Local(i,j,n,shifted,result);
  Bind(result,MakeUni(0,var));
//Echo("c1 = ",var,f1,c1);
//Echo("c2 = ",var,f2,c2);
  Bind(n,Length(c1));
  For(i:=1,i<=n,i++)
  [
//Echo("before = ",result);
//Echo("parms = ",var,c1,c2,f1,f2,f1+i-1);
    Bind(result,result+ShiftUniVar(UniVariate(var,f2,c2),MathNth(c1,i),f1+i-1));
//Echo("after = ",result);
  ];
//Echo("result = ",result);
  result;
];




%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/Degree.mpw0000644000175000017500000000406411523200452026506 0ustar  giovannigiovanni%mathpiper,def="Degree"

//Retract("Degree",*);

Rulebase("Degree",{expr});
Rule("Degree",1,0, IsUniVar(expr))
[

  Local(i,min,max);
  min:=expr[2];
  max:=min+Length(expr[3]);
  i:=max;
  While(i >= min And IsZero(Coef(expr,i))) i--;
  i;
];

10 # Degree(poly_CanBeUni)                           <-- Degree(MakeUni(poly));

10 # Degree(_poly,_var)_(CanBeUni(var,poly))         <-- Degree(MakeUni(poly,var));

20 # Degree(_poly,_var)_(Type(poly)="Sqrt")          <-- Degree(poly^2,var)/2;

20 # Degree(_poly,_var)_(FunctionToList(poly)[1]= ^) <-- 
[
    Local(ex,pwr,deg);
    ex  := FunctionToList(poly)[3];
    pwr := 1/ex;
    //Tell("     ",{ex,pwr});
    deg := Degree(poly^pwr,var);
    //Tell("     ",deg);
    deg*ex;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="Degree",categories="User Functions;Polynomials (Operations)"
*CMD Degree --- degree of a polynomial
*STD
*CALL
	Degree(expr)
	Degree(expr, var)

*PARMS

{expr} -- a polynomial

{var} -- a variable occurring in "expr"

*DESC

This command returns the degree of the polynomial "expr" with
respect to the variable "var". The degree is the highest power of
"var" occurring in the polynomial. If only one variable occurs in
"expr", the first calling sequence can be used. Otherwise the user
should use the second form in which the variable is explicitly
mentioned.

If {expr} is not a polynomial in the accepted sense of the word,
this command will return unevaluated.  In particular, if {expr} 
contains negative powers of the variable, it is not a polynomial.

However, if {expr} is a simple root of a polynomial -- i.e., of 
the form poly^(1/n), and {poly} is of degree n in {var}, then the
call {Degree(expr,var)} will correctly identify the "degree" of 
this non-polynomial.

*E.G.
In> Degree(x^5+x-1)
Result: 5

In> Degree(a+b*x^3, a)
Result: 1

In> Degree(a+b*x^3, x)
Result: 3

In> Degree(x^-2+x-1)
Result: Degree(x^(-2)+x-1)

In> Degree( (Sqrt(2)*x^2*(x+3))^(1/3),x)
Result: 1

*SEE Expand, Coef
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/CollectOn.mpw0000644000175000017500000000345011523200452027173 0ustar  giovannigiovanni%mathpiper,def="CollectOn"

//:::  Collect terms of a polynomial-like expression on powers of var,
//     starting with power 0.

//Retract("CollectOn",*);

10 # CollectOn(_var,_expr)_(CanBeUni(var,expr)) <--
[
    If(InVerboseMode(),Echo("<< Collect on:  ",var," in expression ",expr));
    
    Local(u,a);
    u := MakeUni(expr,var);
    If( u[2] > 0, 
      [ a := FillList(0,u[2]); u[3] := Concat(a,u[3]); u[2] := 0; ]
    );
    u[3];
];

%/mathpiper

    



%mathpiper_docs,name="CollectOn",categories="User Functions;Polynomials (Operations)"
*CMD CollectOn -- Collect terms of a polynomial-like expression on powers of {var}, starting with power 0.

*CALL
CollectOn( var, expr )
*PARMS
{var}  -- The variable on which to collect
{expr} -- a polynomial-like expression containing one or more terms in variable {var}
*DESC
This function collects the terms of {expr} into a list according to the power of 
variable {var}. The list always begins with the zeroth power in {var} and 
contains {n+1} elements, where {n} is the highest power of {var} present in {expr}.
    

*E.G.
In> CollectOn(x,2*x-2*y-a*x+x*y)
Result: {-2*y,2-a+y}
   NOTE 1: This result indicates that the given expression could be rewritten in
   the form  -2*y+(2-a+y)*x.
   NOTE 2: If P is the list output by a call to CollectOn, this rewriting could
   be done by evaluating Dot(P,FillList(var,Length(P))^(0 .. Length(P)-1)).
    
In> CollectOn(y,2*x-2*y-a*x+x*y)
Result: {2*x-a*x,x-2}
   NOTE 1: This result indicates that the given expression could be rewritten in
   the form  (2*x-a*x)+(x-2)*y.
   NOTE 2: The collection is ONLY made on the given variable; any other variable
   is not collected further.
       
*SEE 
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/BigOh.mpw0000644000175000017500000000147311523200452026304 0ustar  giovannigiovanni%mathpiper,def="BigOh"

10 # BigOh(UniVariate(_var,_first,_coefs),_var,_degree) <--
    [
     While(first+Length(coefs)>=(degree+1) And Length(coefs)>0) DestructiveDelete(coefs,Length(coefs));
     UniVariate(var,first,coefs);
    ];
20 # BigOh(_uv,_var,_degree)_CanBeUni(uv,var) <-- NormalForm(BigOh(MakeUni(uv,var),var,degree));

%/mathpiper



%mathpiper_docs,name="BigOh",categories="User Functions;Series"
*CMD BigOh --- drop all terms of a certain order in a polynomial
*STD
*CALL
	BigOh(poly, var, degree)

*PARMS

{poly} -- a univariate polynomial

{var} -- a free variable

{degree} -- positive integer

*DESC

This function drops all terms of order "degree" or higher in
"poly", which is a polynomial in the variable "var".

*E.G.

In> BigOh(1+x+x^2+x^3,x,2)
Result: x+1;

*SEE Taylor, InverseTaylor
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/DropEndZeroes.mpw0000644000175000017500000000027311316324171030041 0ustar  giovannigiovanni%mathpiper,def="DropEndZeroes"

DropEndZeroes(list):=
[
  Local(end);
  end:=Length(list);
  While(list[end] = 0)
  [
    DestructiveDelete(list,end);
    end:=end-1;
  ];
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/Coef.mpw0000644000175000017500000000244511523200452026170 0ustar  giovannigiovanni%mathpiper,def="Coef"

5 # Coef(uv_IsUniVar,order_IsList) <--
[
  Local(result);
  result:={};
  ForEach(item,order)
  [
    DestructiveAppend(result,Coef(uv,item));
  ];
  result;
];

10 # Coef(uv_IsUniVar,order_IsInteger)_(order=uv[2]+Length(uv[3])) <-- 0;
20 # Coef(uv_IsUniVar,order_IsInteger) <-- uv[3][(order-uv[2])+1];
30 # Coef(uv_CanBeUni,_order)_(IsInteger(order) Or IsList(order)) <-- Coef(MakeUni(uv),order);

Function("Coef",{expression,var,order})
    NormalForm(Coef(MakeUni(expression,var),order));



%/mathpiper



%mathpiper_docs,name="Coef",categories="User Functions;Polynomials (Operations)"
*CMD Coef --- coefficient of a polynomial
*STD
*CALL
	Coef(expr, var, order)

*PARMS

{expr} -- a polynomial

{var} -- a variable occurring in "expr"

{order} -- integer or list of integers

*DESC

This command returns the coefficient of "var" to the power "order"
in the polynomial "expr". The parameter "order" can also be a list
of integers, in which case this function returns a list of
coefficients.

*E.G.

In> e := Expand((a+x)^4,x)
Result: x^4+4*a*x^3+(a^2+(2*a)^2+a^2)*x^2+
	(a^2*2*a+2*a^3)*x+a^4;
In> Coef(e,a,2)
Result: 6*x^2;
In> Coef(e,a,0 .. 4)
Result: {x^4,4*x^3,6*x^2,4*x,1};

*SEE Expand, Degree, LeadingCoef
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/RepeatedSquaresMultiply.mpw0000644000175000017500000000114711371733712032162 0ustar  giovannigiovanni%mathpiper,def="RepeatedSquaresMultiply"

/* Repeated squares multiplication
 TODO put somewhere else!!!
 */
10 # RepeatedSquaresMultiply(_a,- (n_IsInteger)) <-- 1/RepeatedSquaresMultiply(a,n);

15 #  RepeatedSquaresMultiply(UniVariate(_var,_first,{_coef}),(n_IsInteger)) <--
      UniVariate(var,first*n,{coef^n});
20 # RepeatedSquaresMultiply(_a,n_IsInteger) <--
[
  Local(m,b);
  Bind(m,1);
  Bind(b,1);
  While(m<=n) Bind(m,(ShiftLeft(m,1)));
  Bind(m, ShiftRight(m,1));
  While(m>0)
  [
    Bind(b,b*b);
    If (Not(IsEqual(BitAnd(m,n), 0)),Bind(b,b*a));
    Bind(m, ShiftRight(m,1));
  ];
  b;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/LeadingCoef.mpw0000644000175000017500000000237411523200452027455 0ustar  giovannigiovanni%mathpiper,def="LeadingCoef"

//todo:tk:moved here form Coef.mpw.
10 # LeadingCoef(uv_IsUniVar) <-- Coef(uv,Degree(uv));

20 # LeadingCoef(uv_CanBeUni) <--
[
  Local(uvi);
  uvi:=MakeUni(uv);
  Coef(uvi,Degree(uvi));
];
10 # LeadingCoef(uv_CanBeUni(var),_var) <--
[
  Local(uvi);
  uvi:=MakeUni(uv,var);
  Coef(uvi,var,Degree(uvi));
];

%/mathpiper



%mathpiper_docs,name="LeadingCoef",categories="User Functions;Polynomials (Operations)"
*CMD LeadingCoef --- leading coefficient of a polynomial
*STD
*CALL
	LeadingCoef(poly)
	LeadingCoef(poly, var)

*PARMS

{poly} -- a polynomial

{var} -- a variable

*DESC

This function returns the leading coefficient of "poly", regarded as
a polynomial in the variable "var". The leading coefficient is the
coefficient of the term of highest degree. If only one variable
appears in the expression "poly", it is obvious that it should be
regarded as a polynomial in this variable and the first calling
sequence may be used.

*E.G.

In> poly := 2*x^2 + 4*x;
Result: 2*x^2+4*x;
In> lc := LeadingCoef(poly);
Result: 2;
In> m := Monic(poly);
Result: x^2+2*x;
In> Expand(lc*m);
Result: 2*x^2+4*x;
	
In> LeadingCoef(2*a^2 + 3*a*b^2 + 5, a);
Result: 2;
In> LeadingCoef(2*a^2 + 3*a*b^2 + 5, b);
Result: 3*a;
	
*SEE Coef, Monic

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/IsUniVar.mpw0000644000175000017500000000252611320767174027032 0ustar  giovannigiovanni%mathpiper,def="IsUniVar"

10 # IsUniVar(UniVariate(_var,_first,_coefs)) <-- True;
20 # IsUniVar(_anything) <-- False;

200 # aLeft_IsUniVar ^ aRight_IsPositiveInteger <--
      RepeatedSquaresMultiply(aLeft,aRight);


200 # aLeft_IsUniVar - aRight_IsUniVar <--
[
  Local(from,result);
  Local(curl,curr,left,right);

  curl:=aLeft[2];
  curr:=aRight[2];
  left:=aLeft[3];
  right:=aRight[3];
  result:={};
  from:=Minimum(curl,curr);

  While(curl=1, While ((i<=l) And (term[1]l, [DestructiveAppend(termlist,term);i++;],
          If (term[1]=termlist[i][1],
             [ Local(nc);
               nc:=termlist[i][2]+term[2];
                 If(nc!=0,DestructiveReplace(termlist,i,{term[1],nc}),
                          [DestructiveDelete(termlist,i);i--;]);
             ],  DestructiveInsert(termlist,i,term))
     );
 ]
  );
 i+1;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sparse/DivTermList.mpw0000644000175000017500000000112111316324171031012 0ustar  giovannigiovanni%mathpiper,def="DivTermList"

// Implements the division of polynomials!

Function("DivTermList",{a,b})
[
 Local(q,nq,t,c,begining);
 q := {};
 // a[1][1] is the degree of a, b[1][1] is the degree of b
 While ((a!={}) And a[1][1]>=b[1][1])
  [
     begining := 1;
     If(InVerboseMode(),Echo("degree=",a[1][1]));
     nq := {a[1][1]-b[1][1],a[1][2]/b[1][2]}; // a new term of the quotient
     DestructiveAppend(q,nq);
     // We compute a:= a - nq* b
     ForEach (t,b)
       begining := AddTerm(a,{t[1]+nq[1],-t[2]*nq[2]},begining);
   ];
   // a is the rest at the end
 q;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sparse/ExpandSparseUniVar.mpw0000644000175000017500000000043611316324171032336 0ustar  giovannigiovanni%mathpiper,def="ExpandSparseUniVar"

Function("ExpandSparseUniVar",{s})
[
 Local(result,t,var,termlist);
 result :=0;
 var := s[1];
 termlist := s[2];
 ForEach (t,termlist)
 [
   Local(term);
   term := NormalForm(t[2]*var^t[1]);
   result := result + term;
 ];
 result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sparse/MultiplySingleTerm.mpw0000644000175000017500000000064311316324171032425 0ustar  giovannigiovanni%mathpiper,def="MultiplySingleTerm"

/*
Note:tk:I am publishing this function as a def because
but it seems like it was meant to be a published function.
*/

// Multiply a list of terms by a Single term.

Function("MultiplySingleTerm",{termlist,term})
[
 Local(result,t);
 result:={};
 If(term[2]!=0,
       ForEach (t,termlist)
         DestructiveAppend(result,{t[1]+term[1],t[2]*term[2]}) );
 result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/sparse/MakeSparseUniVar.mpw0000644000175000017500000000141511517224250031772 0ustar  giovannigiovanni%mathpiper,def="MakeSparseUniVar"

//Retract("MakeSparseUniVar",*);

10 # MakeSparseUniVar(poly_CanBeUni,var_IsAtom) <--
[
    If(InVerboseMode(),Tell("MakeSparseUniVar",{var,poly}));
    Local(uni,first,coeffs,n,c,lc,termlist,term);
    uni    := MakeUni(poly,var);
    If(InVerboseMode(),Tell("      ",uni));
    first  := uni[2];
    coeffs := (uni[3]);
    If(InVerboseMode(),[Tell("    ",first); Tell("   ",coeffs);]);
    termlist := {};
    lc       := Length(coeffs);
    For(n:=0,n poly := 2*x^2 + 4*x;
Result: 2*x^2+4*x;
In> lc := LeadingCoef(poly);
Result: 2;
In> m := Monic(poly);
Result: x^2+2*x;
In> Expand(lc*m);
Result: 2*x^2+4*x;
	
In> Monic(2*a^2 + 3*a*b^2 + 5, a);
Result: a^2+(a*3*b^2)/2+5/2;
In> Monic(2*a^2 + 3*a*b^2 + 5, b);
Result: b^2+(2*a^2+5)/(3*a);

*SEE LeadingCoef
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/PrimitivePart.mpw0000644000175000017500000000164011523200452030107 0ustar  giovannigiovanni%mathpiper,def="PrimitivePart"

10 # PrimitivePart(UniVariate(_var,_first,_coefs)) <--
	UniVariate(var,0,coefs/Gcd(coefs));
20 # PrimitivePart(poly_CanBeUni) <-- NormalForm(PrimitivePart(MakeUni(poly)));

%/mathpiper



%mathpiper_docs,name="PrimitivePart",categories="User Functions;Polynomials (Operations)"
*CMD PrimitivePart --- primitive part of a univariate polynomial
*STD
*CALL
	PrimitivePart(expr)

*PARMS

{expr} -- univariate polynomial

*DESC

This command determines the primitive part of a univariate
polynomial. The primitive part is what remains after the content (the
greatest common divisor of all the terms) is divided out. So the
product of the content and the primitive part equals the original
polynomial.

*E.G.

In> poly := 2*x^2 + 4*x;
Result: 2*x^2+4*x;
In> c := Content(poly);
Result: 2*x;
In> pp := PrimitivePart(poly);
Result: x+2;
In> Expand(pp*c);
Result: 2*x^2+4*x;

*SEE Content
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/CanBeUni.mpw0000644000175000017500000000271211316324171026742 0ustar  giovannigiovanni%mathpiper,def="CanBeUni"

/* CanBeUni returns whether the function can be converted to a
 * univariate, with respect to a variable.
 */
Function("CanBeUni",{expression}) CanBeUni(UniVarList(expression),expression);


/* Accepting an expression as being convertable to univariate */

/* Dealing wiht a list of variables. The poly should be expandable
 * to each of these variables (smells like tail recursion)
 */
10 # CanBeUni({},_expression) <-- True;
20 # CanBeUni(var_IsList,_expression) <--
    CanBeUni(First(var),expression) And CanBeUni(Rest(var),expression);

/* Atom can always be a polynom to any variable */
30 # CanBeUni(_var,expression_IsAtom) <-- True;
35 # CanBeUni(_var,expression_IsFreeOf(var)) <-- True;

/* Other patterns supported. */
40 # CanBeUni(_var,_x + _y) <-- CanBeUni(var,x) And CanBeUni(var,y);
40 # CanBeUni(_var,_x - _y) <-- CanBeUni(var,x) And CanBeUni(var,y);
40 # CanBeUni(_var,   + _y) <-- CanBeUni(var,y);
40 # CanBeUni(_var,   - _y) <-- CanBeUni(var,y);
40 # CanBeUni(_var,_x * _y) <-- CanBeUni(var,x) And CanBeUni(var,y);
40 # CanBeUni(_var,_x / _y) <-- CanBeUni(var,x) And IsFreeOf(var,y);
/* Special case again: raising powers */
40 # CanBeUni(_var,_x ^ y_IsInteger)_(y >= 0 And CanBeUni(var,x)) <-- True;
41 # CanBeUni(_var,(x_IsFreeOf(var)) ^ (y_IsFreeOf(var))) <-- True;
50 # CanBeUni(_var,UniVariate(_var,_first,_coefs)) <-- True;
1000 # CanBeUni(_var,_f)_(Not(IsFreeOf(var,f))) <-- False;
1001 # CanBeUni(_var,_f) <-- True;

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/MakeUni.mpw0000644000175000017500000000257411321250634026653 0ustar  giovannigiovanni%mathpiper,def="MakeUni"

Function("MakeUni",{expression}) MakeUni(expression,UniVarList(expression));

/* Convert normal form to univariate expression */
Rulebase("MakeUni",{expression,var});

5 # MakeUni(_expr,{}) <-- UniVariate(dummyvar,0,{expression});
6 # MakeUni(_expr,var_IsList) <--
[
  Local(result,item);
  result:=expression;
  ForEach(item,var)
  [
    result:=MakeUni(result,item);
  ];
  result;
];

10 # MakeUni(UniVariate(_var,_first,_coefs),_var) <--
    UniVariate(var,first,coefs);

20 # MakeUni(UniVariate(_v,_first,_coefs),_var) <--
[
  Local(reslist,item);
  reslist:={};
  ForEach(item,expression[3])
  [
    If(IsFreeOf(var,item),
      DestructiveAppend(reslist,item),
      DestructiveAppend(reslist,MakeUni(item,var))
      );
  ];
  UniVariate(expression[1],expression[2],reslist);
];


LocalSymbols(a,b,var,expression)
[
  20 # MakeUni(expression_IsFreeOf(var),_var)
       <-- UniVariate(var,0,{expression});
  30 # MakeUni(_var,_var) <-- UniVariate(var,1,{1});
  30 # MakeUni(_a + _b,_var) <-- MakeUni(a,var) + MakeUni(b,var);
  30 # MakeUni(_a - _b,_var) <-- MakeUni(a,var) - MakeUni(b,var);
  30 # MakeUni(   - _b,_var) <--                - MakeUni(b,var);
  30 # MakeUni(_a * _b,_var) <-- MakeUni(a,var) * MakeUni(b,var);
  1 # MakeUni(_a ^ n_IsInteger,_var) <-- MakeUni(a,var) ^ n;
  30 # MakeUni(_a / (b_IsFreeOf(var)),_var) <-- MakeUni(a,var) * (1/b);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/Horner.mpw0000644000175000017500000000230711523200452026546 0ustar  giovannigiovanni%mathpiper,def="Horner"

Horner(_e,_v) <--
[
  Local(uni,coefs,result);
  uni := MakeUni(e,v);
  coefs:=DestructiveReverse(uni[3]);
  result:=0;

  While(coefs != {})
  [
    result := result*v;
    result := result+First(coefs);
    coefs  := Rest(coefs);
  ];
  result:=result*v^uni[2];
  result;
];

%/mathpiper



%mathpiper_docs,name="Horner",categories="User Functions;Polynomials (Operations)"
*CMD Horner --- convert a polynomial into the Horner form
*STD
*CALL
	Horner(expr, var)

*PARMS

{expr} -- a polynomial in "var"

{var} -- a variable

*DESC

This command turns the polynomial "expr", considered as a univariate
polynomial in "var", into Horner form. A polynomial in normal form
is an expression such as
$$c[0] + c[1]*x + ... + c[n]*x^n$$.

If one converts this polynomial into Horner form, one gets the
equivalent expression
$$(...( c[n] * x + c[n-1] ) * x + ...  + c[1] ) * x + c[0]$$.

Both expression are equal, but the latter form gives a more
efficient way to evaluate the polynomial as  the powers have
disappeared.

*E.G.

In> expr1:=Expand((1+x)^4)
Result: x^4+4*x^3+6*x^2+4*x+1;
In> Horner(expr1,x)
Result: (((x+4)*x+6)*x+4)*x+1;

*SEE Expand, ExpandBrackets, EvaluateHornerScheme
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/UniGCD.mpw0000644000175000017500000000111111316324171026357 0ustar  giovannigiovanni%mathpiper,def="UniGcd"

Function("UniGcd",{u,v})
[
  Local(l,div,mod,m);

  DropEndZeroes(u);
  DropEndZeroes(v);
/*
  If(Length(v)>Length(u),
    [
      Locap(swap);
      swap:=u;
      u:=v;
      v:=swap;
    ] );
  If(Length(u)=Length(v) And v[Length(v)] > u[Length(u)],
    [
      Locap(swap);
      swap:=u;
      u:=v;
      v:=swap;
    ] );
  */


  l:=UniDivide(u,v);

  div:=l[1];
  mod:=l[2];

  DropEndZeroes(mod);
  m := Length(mod);

/* Echo({"v,mod = ",v,mod}); */
/*  If(m <= 1, */
  If(m = 0,
     v,
/*     v/v[Length(v)], */
     UniGcd(v,mod));
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/cyclotomic/0000755000175000017500000000000011722677335026752 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/cyclotomic/Cyclotomic.mpw0000644000175000017500000001342211321245544031572 0ustar  giovannigiovanni%mathpiper,def="Cyclotomic"

//  Cyclotomic(n,x):
//  Returns the cyclotomic polinomial in the variable x
//  (which is the minimal polynomial of the n-th primitive
//  roots of the unit).
//  Autor: Pablo De Napoli

LoadScriptOnce("univar.rep/code.mpi");

// Auxiliar function for Cyclotomic: returns the internal representation of
// x^q+a as an univarate polinomial (like MakeUni(x^q+a) but more efficient)

Function ("UniVariateBinomial",{x,q,a})
[
Local(L,i);
L := {a};
For (i:=1,i0,i--)
  [
    Local(term);
    exponent := first+i-1;
    c:= coefs[i];
    nc := If(IsEven(exponent),c,-c);
    term:=NormalForm(nc*var^(exponent*k));
    result:=result+term;
  ];
  result;
];

// Returns a list of elements of the form {d1,d2,m}
// where
// 1) d1,d2 runs through the square free divisors of n
// 2) d1 divides d2 and d2/d1 is a prime factor of n
// 3) m=Moebius(d1)
// Addapted form: MoebiusDivisorsList

CyclotomicDivisorsList(n_IsPositiveInteger) <--
[
 Local(nFactors,f,result,oldresult,x);
 nFactors:= Factors(n);
 result := {{1,nFactors[1][1],1}};
 nFactors := Rest(nFactors);
 ForEach (f,nFactors)
    [
      oldresult := result;
        ForEach (x,oldresult)
	  result:=Append(result,{x[1]*f[1],x[2]*f[1],-x[3]});
    ];
  result;
];

// CyclotomicFactor(x,a,b): Auxiliary function that constructs the term list of
// the polynomial
// Quotient(x^a-1,x^b-1) =
// x^(b*(p-1)) + x^(b^*(p-2)) + ... + x^(b) + 1
// p= a/b, b should divide a


CyclotomicFactor(_a,_b) <--
[
 Local(coef,p,i,j,result); p := a/b; result:= {{b*(p-1),1}}; For (i:=
 p-2,i>=0,i--)
   DestructiveAppend(result,{b*i,1});
 result;
];



// This new implementation makes use of the internal representations of univariate
// polynomials as SparseUniVar(var,termlist).


//  For n even, we write n= m*k, where k is a Power of 2
//  and m is odd, and redce it to the case m even since:
//
//   Cyclotomic(n,x) = Cyclotomic(m,-x^{k/2})
//
// If m=1, n is a power of 2, and Cyclotomic(n,x)= x^k+1 */


10 # InternalCyclotomic(n_IsEven,_x) <--
     [
      Local(k,m,result,p,t);
       k := 1;
       m := n;
	While(IsEven(m))
       [
	k := k*2;
        m := m/2;
       ];
       k := k/2 ;
       If(m>1, [
	         p:= InternalCyclotomic(m,x)[2];
                 // Substitute x by -x^k
                 result:={};
                 ForEach(t,p)
                    DestructiveAppend(result, {t[1]*k,If(IsEven(t[1]),t[2],-t[2])});
               ],
	         result := {{k,1},{0,1}} // x^k+1
        );
	SparseUniVar(x,result);
     ];


//  For n odd, the algoritm is based on the formula
//
//     Cyclotomic(n,x) := Prod (x^(n/d)-1)^Moebius(d)
//
// where d runs through the divisors of n.

// We compute in poly1 the product
// of (x^(n/d)-1) with Moebius(d)=1 , and in poly2 the product of these polynomials
// with  Moebius(d)=-1. Finally we compute the quotient poly1/poly2

// In order to compute this in a efficient way, we use the functions
// CyclotomicDivisorsList and  CyclotomicFactors (in order to avoid
// unnecesary polynomial divisions)


20 # InternalCyclotomic(n_IsOdd,_x)_(n>1) <--
[
 Local(divisors,poly1,poly2,q,d,f,coef,i,j,result);
 divisors := CyclotomicDivisorsList(n);
 poly1 := {{0,1}};
 poly2 := {{0,1}};
 ForEach (d,divisors)
 [
   If(InVerboseMode(),Echo("d=",d));
   f:= CyclotomicFactor(n/d[1],n/d[2]);
   If (d[3]=1,poly1:=MultiplyTerms(poly1,f),poly2:=MultiplyTerms(poly2,f));
   If(InVerboseMode(),
     [
       Echo("poly1=",poly1);
       Echo("poly2=",poly2);
     ]);
 ];
 If(InVerboseMode(),Echo("End ForEach"));
 result := If(poly2={{0,1}},poly1,DivTermList(poly1,poly2));
 SparseUniVar(x,result);
];


10  # Cyclotomic(1,_x) <-- x-1;
20  # Cyclotomic(n_IsInteger,_x) <-- ExpandSparseUniVar(InternalCyclotomic(n,x));



%/mathpiper



%mathpiper_docs,name="Cyclotomic",categories="User Functions;Number Theory"
*CMD Cyclotomic --- construct the cyclotomic polynomial
*STD
*CALL
	Cyclotomic(n,x)

*PARMS

{n} -- positive integer

{x} -- variable

*DESC

Returns the cyclotomic polynomial in the variable {x}
(which is the minimal polynomial of the $n$-th primitive
roots of the unit, over the field of rational numbers).
 
For $n$ even, we write $n= m*k$, where $k$ is a power of $2$ 
and $m$ is odd, and reduce it to the case of even $m$ since
$$ Cyclotomic(n,x) = Cyclotomic(m,-x^(k/2)) $$.

If $m=1$, $n$ is a power of $2$, and $Cyclotomic(n,x)= x^k+1$.

For $n$ odd, the algorithm is based on the formula
$$ Cyclotomic(n,x) := Prod((x^(n/d)-1)^mu(d)) $$,
where $d$ runs through the divisors of $n$.
In order to compute this in a efficient way, we use the function
{MoebiusDivisorsList}. Then we compute in {poly1} the product
of $x^(n/d)-1$ with $mu(d)=1$ , and in {poly2} the product of these polynomials
with  $mu(d)= -1$. Finally we compute the quotient {poly1}/{poly2}.

*SEE RamanujanSum
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/cyclotomic/OldCyclotomic.mpw0000644000175000017500000000274211320775271032240 0ustar  giovannigiovanni%mathpiper,def="OldCyclotomic"

// OldInternalCyclotomic(n,x,WantNormalForm) is the internal implementation
// WantNormalForm is a boolean parameter. If it is true, returns the normal
// form, if it is false returns the UniVariate representation.

// This (old) implementation makes use of the internal representations of univariate
// polynomials as UniVariate(var,begining,coefficients).
// There is also a version UniVariateCyclotomic(n,x) that returns the
// cyclotomic polynomial in the UniVariate representation.


10 # OldInternalCyclotomic(n_IsEven,_x,WantNormalForm_IsBoolean) <--
     [
      Local(k,m,p);
       k := 1;
       m := n;
	While(IsEven(m))
       [
	k := k*2;
        m := m/2;
       ];
       k := k/2 ;
       If(m>1, [
	         p := OldInternalCyclotomic(m,x,False);
                 If (WantNormalForm, SubstituteAndExpandInUniVar(p,k),SubstituteInUniVar(p,k));
               ],
	         If (WantNormalForm, x^k+1, UniVariateBinomial(x,k,1))
        );
     ];

20 # OldInternalCyclotomic(n_IsOdd,_x,WantNormalForm_IsBoolean)_(n>1) <--
[
 Local(divisors,poly1,poly2,q,d,f,result);
 divisors := MoebiusDivisorsList(n);
 poly1 :=1 ;
 poly2 := 1;
 ForEach (d,divisors)
 [
   q:=n/d[1];
   f:=UniVariateBinomial(x,q,-1);
   If (d[2]=1,poly1:=poly1*f,poly2:=poly2*f);
 ];
 result := Quotient(poly1,poly2);
 If(WantNormalForm,NormalForm(result),result);
];

10  # OldCyclotomic(1,_x) <-- _x-1;
20  # OldCyclotomic(n_IsInteger,_x) <-- OldInternalCyclotomic(n,x,True);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/univar/cyclotomic/UniVariateCyclotomic.mpw0000644000175000017500000000043611316324171033561 0ustar  giovannigiovanni%mathpiper,def="UniVariateCyclotomic"

// This function returns the Cyclotomic polynomial, but in the univariate
// representation

10  # UniVariateCyclotomic(1,_x) <-- UniVariate(x,0,{-1,1});
20  # UniVariateCyclotomic(n_IsInteger,_x) <-- OldInternalCyclotomic(n,x,False);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/0000755000175000017500000000000011722677336024214 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/CosN.mpw0000644000175000017500000000217111523200452025560 0ustar  giovannigiovanni%mathpiper,def="CosN"

Defun("CosN",{x})Trigonometry(x,0.0,1.0,1.0);

%/mathpiper





%mathpiper_docs,name="CosN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD CosN --- cosine (arbitrary-precision math function)
*CALL
	CosN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathMul2Exp.mpw0000644000175000017500000000100211320757541027027 0ustar  giovannigiovanni%mathpiper,def="MathMul2Exp"

// MathMul2Exp: multiply x by 2^n quickly (for integer n)
// this should really be implemented in the core as a call to BigNumber::ShiftRight or ShiftLeft
Defun("MathMul2Exp", {x,n})	// avoid roundoff by not calculating 1/2^n separately
	If(IsGreaterThan(n,0), MultiplyN(x, MathIntPower(2,n)), DivideN(x, MathIntPower(2,MathNegate(n))));
// this doesn't work because ShiftLeft/Right don't yet work on floats
//	If(IsGreaterThan(n,0), ShiftLeft(x,n), ShiftRight(x,n)
//	);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/PositiveIntPower.mpw0000644000175000017500000000147611371733712030232 0ustar  giovannigiovanni%mathpiper,def="PositiveIntPower"

// first define the binary exponentiation algorithm, MathIntPower.
// Later, the PowerN function will be defined through IntPower and MathLn/ExpN. Note that ExpN uses IntPower.

// power x^n only for non-negative integer n
Defun("PositiveIntPower", {x,n})
[
  Local(result,unit);
  If(IsLessThan(n,0), False,
  [
	Bind(unit,1);	 // this is a constant, initial value of the power
	Bind(result, unit);
	If(IsEqual(n,0),unit,
	 If(IsEqual(n,1),x,
	  [
		While(IsGreaterThan(n,0))
		[
			If(
				IsEqual(BitAnd(n,1), 1),
//				If(
//					IsEqual(result,unit), // if result is already assigned
//					Bind(result, x), // avoid multiplication
					Bind(result, MultiplyN(result,x))
//				)
			);
			Bind(x, MultiplyN(x,x));
			Bind(n,ShiftRight(n,1));
		];
		result;
	  ]
	 )
	);
  ]);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/SinN.mpw0000644000175000017500000000216311523200452025566 0ustar  giovannigiovanni%mathpiper,def="SinN"

Defun("SinN",{x})Trigonometry(x,1.0,x,x);

%/mathpiper





%mathpiper_docs,name="SinN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD SinN --- sine (arbitrary-precision math function)
*CALL
	SinN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathExpTaylor.mpw0000644000175000017500000000123311371733712027470 0ustar  giovannigiovanni%mathpiper,def="MathExpTaylor"

// simple Taylor expansion, use only for 0<=x<1
Defun("MathExpTaylor0",{x})
[
  Local(i,aResult,term,eps);
  // Exp(x)=Sum(i=0 to Inf)  x^(i) /(i)!
  // Which incrementally becomes the algorithm:
  //
  // i <- 0
  Bind(i,0);
  // sum <- 1
  Bind(aResult,1.0);
  // term <- 1
  Bind(term,1.0);
  Bind(eps,MathIntPower(10,MathNegate(BuiltinPrecisionGet())));
  // While (term>epsilon)
  While(IsGreaterThan(AbsN(term),eps))
  [
    //   i <- i+1
    Bind(i,AddN(i,1));
    //   term <- term*x/(i)
    Bind(term,DivideN(MultiplyN(term,x),i));
    //   sum <- sum+term
    Bind(aResult,AddN(aResult,term));
  ];
  aResult;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathPi.mpw0000644000175000017500000000270511331203122026075 0ustar  giovannigiovanni%mathpiper,def="MathPi"

Defun("MathPi",{})
[
  // Newton's method for finding pi:
  // x[0] := 3.1415926
  // x[n+1] := x[n] + Sin(x[n])
  Local(initialPrec,curPrec,result,aPrecision);
  Bind(aPrecision,BuiltinPrecisionGet());
	Bind(initialPrec, aPrecision);	// target precision of first iteration, will be computed below
  Bind(curPrec, 40);  // precision of the initial guess
  Bind(result, 3.141592653589793238462643383279502884197169399);    // initial guess

	// optimize precision sequence
	While (IsGreaterThan(initialPrec, MultiplyN(curPrec,3)))
  [
		Bind(initialPrec, FloorN(DivideN(AddN(initialPrec,2),3)));
  ];
	Bind(curPrec, initialPrec);
  While (Not(IsGreaterThan(curPrec, aPrecision)))
  [
 		// start of iteration code
    // Get Sin(result)
    BuiltinPrecisionSet(curPrec);
    Bind(result,AddN(result,SinN(result)));
    // Calculate new result: result := result + Sin(result);
		// end of iteration code
		// decide whether we are at end of loop now
		If (IsEqual(curPrec, aPrecision),	// if we are exactly at full precision, it's the last iteration
    [
			Bind(curPrec, AddN(aPrecision,1));	// terminate loop
    ],
    [
			Bind(curPrec, MultiplyN(curPrec,3));	// precision triples at each iteration
			// need to guard against overshooting precision
 			If (IsGreaterThan(curPrec, aPrecision),
      [
				Bind(curPrec, aPrecision);	// next will be the last iteration
      ]);
		]);
  ];
  BuiltinPrecisionSet(aPrecision);
  result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/PowerN.mpw0000644000175000017500000000276511523200452026141 0ustar  giovannigiovanni%mathpiper,def="PowerN"

// power function that works for all real x, y
/// FIXME: No precision tracking yet.

/* Serge, as MathFloatPower cannot be defined yet, I made the "avoid PowerN(num,float) explicit :-)
*/
Defun("PowerN", {x,y})
// avoid PowerN(0,float)
	If(IsEqual(x,0),0, If(IsEqual(x,1),1,
	  If(IsInteger(y), MathIntPower(x,y), False/*MathFloatPower(x,y)*/)
	));

%/mathpiper





%mathpiper_docs,name="PowerN",categories="User Functions;Numeric"
*CMD PowerN --- power x^y (arbitrary-precision math function)
*CALL
	PowerN(x,y)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In> BuiltinPrecisionSet(10)
Result: True
In> PowerN(2,3)
Result: 8
In> PowerN(2,-3)
Result: 0.125

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/Trigonometry.mpw0000644000175000017500000000126311371733712027434 0ustar  giovannigiovanni%mathpiper,def="Trigonometry"

Defun("Trigonometry",{x,i,sum,term})
[
  Local(x2,orig,eps,previousPrec,newPrec);
  Bind(previousPrec,BuiltinPrecisionGet());
  Bind(newPrec,AddN(BuiltinPrecisionGet(),2));
  Bind(x2,MultiplyN(x,x));
  BuiltinPrecisionSet(newPrec);
  Bind(eps,MathIntPower(10,MathNegate(previousPrec)));
  While(IsGreaterThan(AbsN(term),eps))
  [
    Bind(term,MultiplyN(term,x2));
    Bind(i,AddN(i,1.0));
    Bind(term,DivideN(term,i));
    Bind(i,AddN(i,1.0));
    Bind(term,DivideN(MathNegate(term),i));
    BuiltinPrecisionSet(previousPrec);
    Bind(sum, AddN(sum, term));
    BuiltinPrecisionSet(newPrec);
  ];
  BuiltinPrecisionSet(previousPrec);
  sum;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathFloatPower.mpw0000644000175000017500000000104511371733712027624 0ustar  giovannigiovanni%mathpiper,def="MathFloatPower"

// power function for non-integer argument y -- use ExpN and LogN
/* Serge, I disabled this one for now, until we get a compiled version of LogN that does not hang in
   an infinite loop. The C++ version of LogN never terminates, so I mapped LogN to your Internal'LnNum
   which of course does a much better job of it. Corollary is that this function can be defined when we also
   have Internal'LnNum in this file.
Defun("MathFloatPower", {x,y})
	If(IsInteger(y), False, ExpN(MultiplyN(y,LogN(x))));
*/

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathIntPower.mpw0000644000175000017500000000104411371733712027310 0ustar  giovannigiovanni%mathpiper,def="MathIntPower"

// power x^y only for integer y (perhaps negative)
Defun("MathIntPower", {x,y})
	If(IsEqual(x,0),0,If(IsEqual(x,1),1,
	 If(IsInteger(y),If(IsLessThan(y,0), // negative power, need to convert x to float to save time, since x^(-n) is never going to be integer anyway
	  DivideN(1, PositiveIntPower(AddN(x,0.),MathNegate(y))),
	   // now the positive integer y calculation - note that x might still be integer
	  PositiveIntPower(x,y)
	 ),	// floating-point calculation is absent, return False
	 False)
	));

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/ExpN.mpw0000644000175000017500000000335111523200452025571 0ustar  giovannigiovanni%mathpiper,def="ExpN"

/// ExpN(x). Algorithm: for x<0, divide 1 by ExpN(-x); for x>1, compute ExpN(x/2)^2 recursively; for 0must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/MathExpDoubling.mpw0000644000175000017500000000064711371733712027771 0ustar  giovannigiovanni%mathpiper,def="MathExpDoubling"

/// Identity transformation, compute Exp(x) from value=Exp(x/2^n) by squaring the value n times
Defun("MathExpDoubling", {value, n})
[
	Local(shift, result);
	Bind(shift, n);
	Bind(result, value);
	While (IsGreaterThan(shift,0))	// will lose 'shift' bits of precision here
	[
		Bind(result, MultiplyN(result, result));
		Bind(shift, AddN(shift,MathNegate(1)));
	];
	result;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/base/TanN.mpw0000644000175000017500000000216711523200452025563 0ustar  giovannigiovanni%mathpiper,def="TanN"

Defun("TanN",{x})DivideN(SinN(x),CosN(x));

%/mathpiper





%mathpiper_docs,name="TanN",categories="User Functions;Numeric;Trigonometry (Numeric)"
*CMD TanN --- tangent (arbitrary-precision math function)
*CALL
	TanN(x)

*DESC

This command performs the calculation of an elementary mathematical
function.  The arguments must be numbers.  The reason for the
postfix {N} is that the library needs to define equivalent non-numerical
functions for symbolic computations, such as {Exp}, {Sin}, etc.

Note that all xxxN functions accept integers as well as floating-point numbers.
The resulting values may be integers or floats.  If the mathematical result is an
exact integer, then the integer is returned.  For example, {Sqrt(25)} returns
the integer {5}, and {Power(2,3)} returns the integer {8}.  In such cases, the
integer result is returned even if the calculation requires more digits than set by
{BuiltinPrecisionSet}.  However, when the result is mathematically not an integer,
the functions return a floating-point result which is correct only to the current precision.

*E.G.
In>
Result:

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/0000755000175000017500000000000011722677332025141 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/makemulti/0000755000175000017500000000000011722677332027131 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/makemulti/MakeMultiNomial.mpw0000644000175000017500000001422211565743515032711 0ustar  giovannigiovanni%mathpiper,def="MakeMultiNomial"


/* code pertaining to creating the internal format for multivariate
   polynomials (the inverse of NormalForm

- MultiExpressionList(x)
  extract all variable-like sub-expressions from the main expression,
  including functions, which can then get treated as if they were
  a variable.
- IsMultiExpression(x)
  determing whether 'x' can be a 'variable' for a multiNomial
- IsMulti(x)
  returns True if 'x' is a multivariate expression in internal format.
  Useful for transformation rules.
 */

MultiExpressionList(_expr) <-- VarList(expr,"IsMultiExpression");
10 # IsMultiExpression(_x + _y) <-- False;
10 # IsMultiExpression(_x - _y) <-- False;
10 # IsMultiExpression(   - _y) <-- False;
10 # IsMultiExpression(_x * _y) <-- False;
10 # IsMultiExpression(_x / _y) <-- False;
10 # IsMultiExpression(_x ^ y_IsPositiveInteger) <-- False;
11 # IsMultiExpression(_x ^ _y)_(IsPositiveInteger(Simplify(y))) <-- False;
//10 # IsMultiExpression(x_IsConstant) <-- False;
10 # IsMultiExpression(x_IsMultiConstant) <-- False;

//TODO: shouldn't this be more global? The problem right now is
// that IsConstant/IsVariable take Pi to be a constant...
IsMultiConstant(_n) <-- (VarList(n,"IsVr")={});
10 # IsVr(n_IsNumber) <-- False;
10 # IsVr(n_IsFunction) <-- False;
10 # IsVr(n_IsString) <-- False;
20 # IsVr(_n) <-- True;
100 # IsMultiExpression(_x) <-- True;

10 # IsMulti(MultiNomial(vars_IsList,_terms)) <-- True;
20 # IsMulti(_anything) <-- False;



LocalSymbols(a,vars,pow)  [
  20 #  MultiSingleFactor(_vars,_a,_pow) <--
    [
      Local(term);
      term:={FillList(0,Length(vars)),1};
      term[1][Find(vars,a)] := pow;
      CreateTerm(vars,term);
    ];
];
LocalSymbols(x,y,vars)  [
10 #  MakeMultiNomial(x_IsMultiConstant,vars_IsList) <--
      CreateTerm(vars,{FillList(0,Length(vars)),x});
20 #  MakeMultiNomial(_x,vars_IsList)_(Contains(vars,x)) <-- MultiSingleFactor(vars,x,1);
30 #  MakeMultiNomial(_x + _y,vars_IsList) <--
      MakeMultiNomial(x,vars) + MakeMultiNomial(y,vars);
30 #  MakeMultiNomial(_x * _y,vars_IsList) <--
      MakeMultiNomial(x,vars) * MakeMultiNomial(y,vars);
30 #  MakeMultiNomial(- _x,vars_IsList) <-- -MakeMultiNomial(x,vars);
30 #  MakeMultiNomial(_x - _y,vars_IsList) <--
      MakeMultiNomial(x,vars) - MakeMultiNomial(y,vars);
30 #  MakeMultiNomial(MultiNomial(_vars,_terms),vars_IsList)
      <-- MultiNomial(vars,terms);

// This rule would accept almost all terms, assuming them to be const.
100 #  MakeMultiNomial(_x,vars_IsList) <--
      [
      CreateTerm(vars,{FillList(0,Length(vars)),x});
      ];

];

LocalSymbols(x,y,z,vars,gcd,a,a)  [
  20 #  MakeMultiNomial(_x / (_y / _z),vars_IsList)
     <-- MakeMultiNomial((x*z) / y,vars_IsList);
  20 #  MakeMultiNomial((_x / _y) / _z,vars_IsList)
     <-- MakeMultiNomial((x*z) / y,vars_IsList);
  25 #  MakeMultiNomial(_x / y_IsConstant,vars_IsList)
     <-- MakeMultiNomial(1/y,vars)*MakeMultiNomial(x,vars);
  30 #  MakeMultiNomial(_x / _y,vars_IsList) <--
        [
          Local(result);
//Echo("1...",x);
//Echo("2...",y);
          Bind(result,MultiRemoveGcd(MakeMultiNomial(x,vars)/MakeMultiNomial(y,vars)));
//Echo("3...",result);
          result;
        ];
  ];


MultiNomial(_vars,_x) + MultiNomial(_vars,_y) <--
	   MultiNomialAdd(MultiNomial(vars,x), MultiNomial(vars,y));
MultiNomial(_vars,_x) * MultiNomial(_vars,_y) <--
           MultiNomialMultiply(MultiNomial(vars,x), MultiNomial(vars,y));
MultiNomial(_vars,_x) - MultiNomial(_vars,_y) <--
        MultiNomialAdd(MultiNomial(vars,x), MultiNomialNegate(MultiNomial(vars,y)));
                      - MultiNomial(_vars,_y) <--
        MultiNomialNegate(MultiNomial(vars,y));
MultiNomial(_vars,_x) / MultiNomial(_vars,_x) <-- MakeMultiNomial(1, vars);


LocalSymbols(x,n,vars)  [
30 #  MakeMultiNomial(_x ^ n_IsInteger,vars_IsList)_(Contains(vars,x)) <--
      MultiSingleFactor(vars,x,n);
40 #  MakeMultiNomial(_x ^ n_IsPositiveInteger,vars_IsList) <--
      [
        Local(mult,result);
        Bind(mult,MakeMultiNomial(x,vars));
        Bind(result,MakeMultiNomial(1,vars));
	While(n>0)
        [
          If(n&1 != 0, Bind(result, MultiNomialMultiply(result,mult)));
          Bind(n,n>>1);
          If(n!=0,Bind(mult,MultiNomialMultiply(mult,mult)));
        ];
        result;
      ];

  15 #  MakeMultiNomial(_x ^ _n,vars_IsList)_(Not(IsInteger(n)) And IsInteger(Simplify(n))) <--
        MakeMultiNomial( x ^  Simplify(n),vars);

  50 #  MakeMultiNomial(_x ^ (_n),vars_IsList)_(Contains(vars,x)) <--
        [
          Bind(n,Simplify(n));
          If(IsInteger(n),
            MultiSingleFactor(vars,x,n),
            MultiSingleFactor(vars,x^n,1)
  	    );
        ];
];


x_IsMulti + (y_IsMulti/z_IsMulti) <-- ((x*z+y)/z);
(y_IsMulti/z_IsMulti) + x_IsMulti <-- ((x*z+y)/z);
(y_IsMulti/z_IsMulti) + (x_IsMulti/w_IsMulti) <-- ((y*w+x*z)/(z*w));
(y_IsMulti/z_IsMulti) - (x_IsMulti/w_IsMulti) <-- ((y*w-x*z)/(z*w));
(y_IsMulti/z_IsMulti) * (x_IsMulti/w_IsMulti) <-- ((y*x)/(z*w));
(y_IsMulti/z_IsMulti) / (x_IsMulti/w_IsMulti) <-- ((y*w)/(z*x));
x_IsMulti - (y_IsMulti/z_IsMulti) <-- ((x*z-y)/z);
(y_IsMulti/z_IsMulti) - x_IsMulti <-- ((y-x*z)/z);
(a_IsMulti/(c_IsMulti/b_IsMulti))    <-- ((a*b)/c);
((a_IsMulti/c_IsMulti)/b_IsMulti)    <-- (a/(b*c));
((a_IsMulti/b_IsMulti) * c_IsMulti)  <-- ((a*c)/b);
(a_IsMulti * (c_IsMulti/b_IsMulti))  <-- ((a*c)/b);
- ((a_IsMulti)/(b_IsMulti))         <-- (-a)/b;


MultiNomialMultiply(
     MultiNomial(_vars,_terms1)/MultiNomial(_vars,_terms2),
     MultiNomial(_vars,_terms3)/MultiNomial(_vars,_terms4)) <--
[
  MultiNomialMultiply(MultiNomial(vars,terms1),MultiNomial(vars,terms3))/
  MultiNomialMultiply(MultiNomial(vars,terms2),MultiNomial(vars,terms4));
];
MultiNomialMultiply(
     MultiNomial(_vars,_terms1)/MultiNomial(_vars,_terms2),
     MultiNomial(_vars,_terms3)) <--
[
  MultiNomialMultiply(MultiNomial(vars,terms1),MultiNomial(vars,terms3))/
  MultiNomial(vars,terms2);
];
MultiNomialMultiply(
     MultiNomial(_vars,_terms3),
     MultiNomial(_vars,_terms1)/MultiNomial(_vars,_terms2)) <--
[
  MultiNomialMultiply(MultiNomial(vars,terms1),MultiNomial(vars,terms3))/
  MultiNomial(vars,terms2);
];

10 # MultiNomialMultiply(_a,_b) <--
[
  Echo({"ERROR!",a,b});
  Echo({"ERROR!",Type(a),Type(b)});
];







%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/MultiGcd.mpw0000644000175000017500000000273011331203122027352 0ustar  giovannigiovanni%mathpiper,def="MultiGcd"

//TODO optimize this! keeps on converting to and from internal format!

10 # MultiGcd( 0,_g) <-- g;
10 # MultiGcd(_f, 0) <-- f;

20 # MultiGcd(_f,_g) <--
[
  Local(v);
  v:=MultiExpressionList(f+g);  //hier
  NormalForm(MultiGcd(MakeMultiNomial(f,v),MakeMultiNomial(g,v)));
];


5 # MultiGcd(f_IsMulti,g_IsMulti)_(MultiTermLess({MultiLM(f),1},{MultiLM(g),1})) <--
[
//Echo("lesser");
  MultiGcd(g,f);
];

5  # MultiGcd(MultiNomial(_vars,_terms),g_IsMulti)_(MultiLM(MultiNomial(vars,terms)) = MultiLM(g))
     <-- CreateTerm(vars,{FillList(0,Length(vars)),1});

5  # MultiGcd(MultiNomial(_vars,_terms),g_IsMulti)_( Select(MultiLM(MultiNomial(vars,terms))-MultiLM(g), {{n},n<0} ) != {})
     <-- CreateTerm(vars,{FillList(0,Length(vars)),1});

5  # MultiGcd(MultiNomial(_vars,_terms),g_IsMulti)_(NormalForm(g) = 0)
     <-- CreateTerm(vars,{FillList(0,Length(vars)),1});
10 # MultiGcd(f_IsMulti,g_IsMulti) <--
[
  LocalSymbols(a)
  [
    Bind(f,Subst(a,a)f);
    Bind(g,Subst(a,a)g);
  ];
  Local(new);
  While(g != 0)
  [
//Echo("before f",f,NormalForm(f));
//Echo("before g",g,NormalForm(g));
    Bind(new, MultiDivide(f,{g}));
//Echo("new g",NormalForm(new[1][1]),NormalForm(new[2]));
If(new[1][1]=0,
[
  g:=MakeMultiNomial(1,MultiVars(f));
//Echo("PRIM ",MultiPrimitivePart(g));
  new[2]:=0;
]);
    Bind(new, new[2]);
    Bind(f,g);
    Bind(g,new);

//Echo("after f",f,NormalForm(f));
//Echo("after g",g,NormalForm(g));
  ];
  MultiPrimitivePart(f);
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/ReassembleListTerms.mpw0000644000175000017500000000506311523200452031603 0ustar  giovannigiovanni%mathpiper,def="ReassembleListTerms"

//Retract("ReassembleListTerms",*);

10 # ReassembleListTerms( disassembly_IsList ) <--
[
    Local(vars,lst,powers,coeffs,ii,pows,coef,term);
    vars   := disassembly[1];
    powers := disassembly[2];
    coeffs := disassembly[3];
    lst    := {};
    For(ii:=1,ii<=Length(powers),ii++)
    [
        pows := powers[ii];
        coef := coeffs[ii];
        //Tell("     ",{pows,coef});
        term  := coef*Product(vars^pows);
        //Tell("          ",term);
        DestructiveAppend(lst,term);
    ];
    lst;
];

%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output



%mathpiper_docs,name="ReassembleListTerms",categories="User Functions;Polynomials (Operations)"

*CMD ResassembleListTerms --- returns a list of the terms in an expression

*STD
*CALL
	ResassembleListTerms(disassembly)

*PARMS

{disassembly} -- a disassembly list generated by {DisassembleExpression}

*DESC

After an expression (usually, but not always, a polynomial) has been disassembled
by the function {DisassembleExpression}, the function 
{ReassembleListTerms} converts this into a list of the individual terms
in the expression.  

This is useful in itself, because a list of terms can be processed term-by-term
in any desired manner.

But also, the items in the disassembly may be transformed in various ways before
being reassembled.  This can facilitate automatic transformations of
polynomials or expressions into forms more convenient for further processing.

See the examples below.

The pair of functions, {DisassembleExpression} and {ReassembleListTerms}, 
together constitute a foundation for the analysis of polynomials and -- more
generally -- any expressions which can be regarded as sum or difference of terms.

*E.G.
    
In> ww:=x+2*Sqrt(x)+1
Result: x+2*Sqrt(x)+1
    This expression is really a disguised quadratic

In> ex:=DisassembleExpression(ww)
Result: {{x,Sqrt(x)},{{1,0},{0,1},{0,0}},{1,2,1}}
    The disassembly has recognized Sqrt(x) as a quasi-variable

In> exx:=Subst({x,Sqrt(x)},{t^2,t})ex
Result: {{t^2,t},{{1,0},{0,1},{0,0}},{1,2,1}}
    An algorithm could observe the list {x,Sqrt(x)} and automatically
    perform the substitution to make a change-of-variables

In> Sum(ReassembleListTerms(exx))
Result: t^2+2*t+1
    The expression has now been transformed into an obvious quadratic,
    which can now be solved.


*SEE MultiExpressionList, DisassembleExpression,MM
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output




mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/sparsetree/0000755000175000017500000000000011722677332027316 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/sparsetree/sparsetree.mpw0000644000175000017500000001164511523146134032215 0ustar  giovannigiovanni%mathpiper,def="CreateSparseTree;SparseTreeMap;SparseTreeScan;AddSparseTrees;MultiplyAddSparseTrees;SparseTreeGet"

/* def file definitions
CreateSparseTree
SparseTreeMap
SparseTreeScan
AddSparseTrees
MultiplyAddSparseTrees
SparseTreeGet
*/

/* Implementation of a sparse tree of Multidimensional matrix elements.
*/

10 # SparseTreeGet({},_tree) <-- tree;
20 # SparseTreeGet(_key,_tree) <--
[
  SparseTreeGet2(Rest(key),Assoc(First(key),tree));
];
10 # SparseTreeGet2(_key,Empty) <-- 0;
20 # SparseTreeGet2(_key,_item) <-- SparseTreeGet(key,First(Rest(item)));

10 # SparseTreeSet({_i},_tree,_newvalue)
   <--
[
  Local(Current,assoc,result);
  Bind(assoc,Assoc(i,tree));
  if(assoc=Empty)
  [
    Bind(Current,0);
    Bind(result,Eval(newvalue));
    AddSparseTrees(1,tree,CreateSparseTree({i},result));
  ]
  else
  [
    Bind(Current,assoc[2]);
    Bind(result,Eval(newvalue));
    assoc[2] := result;
  ];
  result;
];
20 # SparseTreeSet(_key,_tree,_newvalue) <--
[
  SparseTreeSet2(Rest(key),Assoc(First(key),tree));
];
10 # SparseTreeSet2(_key,Empty) <-- 0;
20 # SparseTreeSet2(_key,_item)
   <-- SparseTreeSet(key,First(Rest(item)),newvalue);
UnFence("SparseTreeSet",3);
UnFence("SparseTreeSet2",2);


LocalSymbols(SparseTreeMap2,SparseTreeScan2,Muaddterm,MuMuaddterm,
              meradd,meraddmap) [

10 # CreateSparseTree({},_fact) <-- fact;

20 # CreateSparseTree(_coefs,_fact)
    <-- CreateSparseTree(First(coefs),Rest(coefs),fact);
10 # CreateSparseTree(_first,{},_fact) <-- {{first,fact}};
20 # CreateSparseTree(_first,_coefs,_fact)
    <-- {{first,CreateSparseTree(First(coefs),Rest(coefs),fact)}};

10 # SparseTreeMap(_op,_depth,_list) <-- SparseTreeMap2(list,depth,{});
10 # SparseTreeMap2(_list,1,_coefs)
   <--
   ForEach(item,list)
   [
     item[2] := ApplyFast(op,{Concat(coefs,{item[1]}),item[2]});
   ];
20 # SparseTreeMap2(_list,_depth,_coefs)
   <--
   ForEach(item,list)
   [
     SparseTreeMap2(item[2],AddN(depth,-1),Concat(coefs,{item[1]}));
   ];
UnFence("SparseTreeMap", 3);
[Local(fn);fn:=ToString(SparseTreeMap2);`UnFence(@fn,3);];

10 # SparseTreeScan(_op,_depth,_list) <-- SparseTreeScan2(list,depth,{});
10 # SparseTreeScan2(_list,0,_coefs)  <-- ApplyFast(op,{coefs,list});
20 # SparseTreeScan2(_list,_depth,_coefs)
   <--
   ForEach(item,list)
   [
     SparseTreeScan2(item[2],AddN(depth,-1),Concat(coefs,{item[1]}));
   ];
UnFence("SparseTreeScan", 3);
[Local(fn);fn:=ToString(SparseTreeScan2);`UnFence(@fn,3);];



5  # AddSparseTrees(0,_x,_y) <-- x+y;
10 # AddSparseTrees(_depth,_x,_y) <--
[
  Local(i,t1,t2,inspt);
  Bind(t1,x);
  Bind(i,1);
  Bind(t2,y);
  Bind(inspt,{});
  While(t1 != {} And t2 != {})
  [
    Muaddterm(First(t1),First(t2));
  ];
  While(t2 != {})
  [
    Bind(x,DestructiveAppend(x,First(t2)));
    Bind(t2,Rest(t2));
  ];
  While(inspt != {})
  [
    Bind(i,First(inspt));
    Bind(x,DestructiveInsert(x,i[2],i[1]));
    Bind(inspt,Rest(inspt));
  ];
  x;
];

10 # Muaddterm({_pow,_list1},{_pow,_list2}) <--
[
  if(depth=1)
    [ t1[1][2] := list1+list2; ]
  else
    [ t1[1][2] := AddSparseTrees(AddN(depth,-1),list1,list2);];
  Bind(t2,Rest(t2));
];
20 # Muaddterm(_h1,_h2)_(h1[1] uu:=ExpandBrackets((x+1)^4)
Result: x^4+4*x^3+6*x^2+4*x+1

In> DisassembleExpression(uu)
Result: {{x},{{4},{3},{2},{1},{0}},{1,4,6,4,1}}
    clear signature of binomial expansion in coefficients list

In> vv:=ExpandBrackets((x+y)^4)
Result: x^4+4*x^3*y+6*x^2*y^2+4*x*y^3+y^4

In> DisassembleExpression(vv)
Result: {{x,y},{{4,0},{3,1},{2,2},{1,3},{0,4}},{1,4,6,4,1}}
    same signature

In> vv:=ExpandBrackets((a*x+b*y)^4)
Result: a^4*x^4+4*a^3*x^3*b*y+6*a^2*x^2*b^2*y^2+4*a*x*b^3*y^3+b^4*y^4

In> DisassembleExpression(vv)
Result: {{a,x,b,y},{{4,4,0,0},{3,3,1,1},{2,2,2,2},{1,1,3,3},{0,0,4,4}},{1,4,6,4,1}}
    parameters {a,b} mistaken for variables, but binomial signature still visible

In> DisassembleExpression(vv,{x,y})
Result: {{x,y},{{4,0},{3,1},{2,2},{1,3},{0,4}},{a^4,4*b*a^3,6*b^2*a^2,4*b^3*a,b^4}}
    user guidance helps distinguish parameters from variables,
    but binomial signature still visible

In> ww:=x+2*Sqrt(x)+1
Result: x+2*Sqrt(x)+1

In> DisassembleExpression(ww)
Result: {{x,Sqrt(x)},{{1,0},{0,1},{0,0}},{1,2,1}}
    {MultiExpressionList} identified as "variables" both {x} and
    {Sqrt(x)} -- we call the latter a {quasi-variable}.  See documentation for
    {ReassembleListTerms} for an example of how this can be used to perform
    automatic substitution of variables.

*SEE MultiExpressionList, ReassembleListTerms,MM
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output





mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/ListTerms.mpw0000644000175000017500000000510011523200452027570 0ustar  giovannigiovanni%mathpiper,def="ListTerms"

//From 0Solve5/ListTerms5.mpw, 7 Nov 2010

//Retract("ListTerms",*);
//Retract("terms",*);

10 # ListTerms(_expr) <--
[
    If(InVerboseMode(),Tell("ListTerms",expr));
    Local(termList);
    Local(op,x2,x3);
    termList := {};
    If(IsFunction(expr),
      [
         {op,x2,x3} := FunctionToList(expr);
         If(InVerboseMode(),Tell("          ",{op,x2,x3})); 
         terms(op,x2,x3);
      ],
      [
         Push(termList,expr);
      ]
    );
    termList;
];


10 # terms(_op,_x2,_x3)_(op=ToAtom("+") Or op=ToAtom("-")) <--
[
    If(InVerboseMode(),[Tell("   terms10",op);Tell("         ",{x2,x3});]);
    Local(sgn);
    If(op=ToAtom("+"),sgn:=1,sgn:=-1);
    Push(termList,sgn*x3);
    If(InVerboseMode(),Tell("         ",termList));
    If(IsFunction(x2),
      [
         Local(L);
         L := FunctionToList(x2);
         If(InVerboseMode(),Tell("               ",L));
         If(Length(L)=3,terms(L[1],L[2],L[3]),Push(termList,x2));
      ],
      [
         Push(termList,x2);
      ]
    );
];
UnFence("terms",3);


20 # terms(_op,_x2,_x3) <--
[
    If(InVerboseMode(),[Tell("   terms20",op);Tell("         ",{x2,x3});]);
    Local(F);
    F := ListToFunction({op,x2,x3});
    Push(termList,F);
    If(InVerboseMode(),Tell("         ",termList));
    termList;
];
UnFence("terms",3);


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output





%mathpiper_docs,name="ListTerms",categories="User Functions;Polynomials (Operations)"

*CMD ListTerms --- returns a list of the terms in an expression

*STD
*CALL
	ListTerms(expr)

*PARMS
{expr} -- a mathematical expression composed of sums and differences of terms=

*DESC
Given an expression {expr} containing (at top level) terms connected by
"+" and/or "-" signs, this function generates a list of all such terms 
in the expression.

If the expression has only products, powers, or rational expressions (but not
sums or differences) at the top level, this function will {not} expand them, 
and thus will not list any "terms".  If the user wants the expression to be
expanded, s/he must do so explicitly.

*E.G.   
In> ListTerms(Sin(Sqrt(x))-Sqrt(x+1)-Exp(-2*x))
Result: {Sin(Sqrt(x)),-Sqrt(x+1),-Exp(-2*x)}

In> ListTerms((a+b*x)/(x-d*x)-(e-f*x^2)/(g+h*x))
Result: {(a+b*x)/(x-d*x),(f*x^2-e)/(g+h*x)}

In> ListTerms((3*x+5*y)^5)
Result: {(3*x+5*y)^5}

In> ListTerms(ExpandBrackets((3*x+5*y)^5))
Result: {243*x^5,2025*x^4*y,6750*x^3*y^2,11250*x^2*y^3,9375*x*y^4,3125*y^5}


%/mathpiper_docs


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/MultiSimp.mpw0000644000175000017500000000537211565720721027614 0ustar  giovannigiovanni%mathpiper,def="MultiSimp"

MultiSimp(_expr) <--
[
  Local(vars);
  vars:=MultiExpressionList(expr);
//Echo({"step1 ",MM(expr,vars)});
  MultiSimp2(MM(expr,vars));
];

10 # MultiSimp2(_a / _b) <--
[
  Local(c1,c2,gcd,cmn,vars);


  c1 := MultiContentTerm(a);
  c2 := MultiContentTerm(b);
  gcd:=Gcd(c1[2],c2[2]);
  c1[2] := c1[2]/gcd;
  c2[2] := c2[2]/gcd;

  cmn:=Minimum(c1[1],c2[1]);
  c1[1] := c1[1] - cmn;
  c2[1] := c2[1] - cmn;

  vars:=MultiVars(a);
  Check(vars = MultiVars(b), "Argument", "incompatible Multivars to simplify");

  (NormalForm(CreateTerm(vars,c1))/NormalForm(CreateTerm(vars,c2)))
    *(NormalForm(MultiPrimitivePart(a))/NormalForm(MultiPrimitivePart(b)));
];

20 # MultiSimp2(expr_IsMulti) <--
[
  NormalForm(MultiContent(expr))*NormalForm(MultiPrimitivePart(expr));
];
30 # MultiSimp2(_expr) <-- expr;

MultiContent(multi_IsMulti)
<--
[
  Local(least,gcd);
  Bind(least, MultiDegree(multi));
  Bind(gcd,MultiLeadingCoef(multi));
  ScanMultiNomial("MultiContentScan",multi);
  CreateTerm(MultiVars(multi),MultiContentTerm(multi));
];

MultiContentTerm(multi_IsMulti)
<--
[
  Local(least,gcd);
  Bind(least, MultiDegree(multi));
  Bind(gcd,MultiLeadingCoef(multi));
  ScanMultiNomial("MultiContentScan",multi);
  {least,gcd};
];

MultiContentScan(_coefs,_fact) <--
[
  Bind(least,Minimum({least,coefs}));
  Bind(gcd,Gcd(gcd,fact));
];
UnFence("MultiContentScan",2);

MultiPrimitivePart(MultiNomial(vars_IsList,_terms))
<--
[
  Local(cont);
  Bind(cont,MultiContentTerm(MultiNomial(vars,terms)));
  Bind(cont,CreateTerm(vars,{-cont[1],1/Rationalize(cont[2])}));
  MultiNomialMultiply(MultiNomial(vars,terms), cont);
];

10 # MultiRemoveGcd(x_IsMulti/y_IsMulti) <--
[
  Local(gcd);
  Bind(gcd,MultiGcd(x,y));
  Bind(x,MultiDivide(x,{gcd})[1][1]);
  Bind(y,MultiDivide(y,{gcd})[1][1]);
  x/y;
];
20 # MultiRemoveGcd(_x) <-- x;



5 # MultiDegree(MultiNomial(_vars,_term))_(Not(IsList(term))) <-- {};
10 # MultiDegree(MultiNomial(_vars,{})) <-- FillList(-Infinity,Length(vars));
20 # MultiDegree(MultiNomial(_vars,_terms))
   <-- (MultiLeadingTerm(MultiNomial(vars,terms))[1]);


10 # MultiLeadingCoef(MultiNomial(_vars,_terms))
   <-- (MultiLeadingTerm(MultiNomial(vars,terms))[2]);

10 # MultiLeadingMono(MultiNomial(_vars,{})) <-- 0;
20 # MultiLeadingMono(MultiNomial(_vars,_terms))
   <-- Product(vars^(MultiDegree(MultiNomial(vars,terms))));

20 # MultiLeadingTerm(_m) <-- MultiLeadingCoef(m) * MultiLeadingMono(m);

MultiVars(MultiNomial(_vars,_terms)) <-- vars;

20 # MultiLT(multi_IsMulti)
   <-- CreateTerm(MultiVars(multi),MultiLeadingTerm(multi));

10 # MultiLM(multi_IsMulti) <-- MultiDegree(multi);

10 # MultiLC(MultiNomial(_vars,{})) <-- 0;
20 # MultiLC(multi_IsMulti) <-- MultiLeadingCoef(multi);

DropZeroLC(multi_IsMulti) <-- MultiDropLeadingZeroes(multi);

%/mathpiper
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/MultiNomial.mpw0000644000175000017500000000103511321250634030102 0ustar  giovannigiovanni%mathpiper,def="MultiNomial"

// The basic container for multivariates
Rulebase("MultiNomial",{vars,terms});

// using the sparse tree driver for multivariate polynomials
//LoadScriptOnce("multivar.rep/sparsenomial.mpi");
//LoadScriptOnce("multivar.rep/partialdensenomial.mpi");

If(IsBound(MultiNomialDriver),
  `LoadScriptOnce(@MultiNomialDriver),
  LoadScriptOnce("multivar.rep/sparsenomial.mpi"));

// Code that can build the internal representation of a multivariate polynomial
LoadScriptOnce("multivar.rep/makemulti.mpi");

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/multivar/Groebner.mpw0000644000175000017500000000131411422223770027416 0ustar  giovannigiovanni%mathpiper,def="Groebner"

/*
  Groebner : Calculate the Groebner basis of a set of polynomials.
  Nice example of its power is

In> TableForm(Groebner({x*(y-1),y*(x-1)}))
 x*y-x
 x*y-y
 y-x
 y^2-y
In> Factor(y^2-y)
Result: y*(y-1);

From which you can see that x = y, and x^2 = x so x is 0 or 1.

*/

Groebner(f_IsList) <--
[
  Local(vars,i,j,S,nr,r);
  nr:=Length(f);
  vars:=VarList(f);
  For(i:=1,i<=nr,i++)
  [
    f[i] := MakeMultiNomial(f[i],vars);
  ];
  S:={};
  For(i:=1,i VarList(Sin(x))
Result: {x};
In> VarList(x+a*y)
Result: {x,a,y};
In> VarListSome(x+a*y, {ToAtom("+")})
Result: {x,a*y};
In> VarListArith(x+y*Cos(Ln(x)/x))
Result: {x,y,Cos(Ln(x)/x)}
In> VarListArith(x+a*y^2-1)
Result: {x,a,y^2};

*SEE IsFreeOf, IsVariable, FuncList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/PopBack.mpw0000644000175000017500000000143711523200452026465 0ustar  giovannigiovanni%mathpiper,def="PopBack"

Function("PopBack",{stack})  Pop(stack,Length(stack));

%/mathpiper



%mathpiper_docs,name="PopBack",categories="User Functions;Lists (Operations)"
*CMD PopBack --- remove an element from the bottom of a stack
*STD
*CALL
	PopBack(stack)

*PARMS

{stack} -- a list (which serves as the stack container)

*DESC

This is part of a simple implementation of a stack, internally
represented as a list. This command removes the element at the bottom
of the stack and returns this element. Of course, the stack should not
be empty.

*E.G.

In> stack := {};
Result: {};
In> Push(stack, x);
Result: {x};
In> Push(stack, x2);
Result: {x2,x};
In> Push(stack, x3);
Result: {x3,x2,x};
In> PopBack(stack);
Result: x;
In> stack;
Result: {x3,x2};

*SEE Push, Pop, PopFront
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/MacroMapSingle.mpw0000644000175000017500000000072311523146134030012 0ustar  giovannigiovanni%mathpiper,def="MacroMapSingle"

/* Another Macro... hack for /: to work. */
TemplateFunction("MacroMapSingle",{func,list})
[
  Local(mapsingleresult);
  mapsingleresult:={};

  ForEach(mapsingleitem,list)
  [
    DestructiveInsert(mapsingleresult,1,
      `ApplyFast(func,{Hold(Hold(@mapsingleitem))}));
  ];
  DestructiveReverse(mapsingleresult);
];
UnFence("MacroMapSingle",2);
HoldArgument("MacroMapSingle",func);
HoldArgument("MacroMapSingle",list);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Intersection.mpw0000644000175000017500000000425311523200452027613 0ustar  giovannigiovanni%mathpiper,def="Intersection"

//Retract("Intersection",*);

10 # Intersection( LoL_IsList )_(AllSatisfy("IsList",LoL)) <--
[
  //If(InVerboseMode(),Tell("Intersection_listOfLists",LoL));
  Local(nLists,L0,L1,ii,result,LI);
  nLists := Length(LoL);
  //Tell("  ",nLists);
  If( nLists = 1,
    [
        result := LoL[1];
    ],
    [
      L0 := FlatCopy(LoL[1]);
      For( ii:=2,ii<=nLists,ii++)
      [
          L1 := FlatCopy(LoL[ii]);
          //If(InVerboseMode(),Tell("    ",{ii,L0,L1}));
          LI := Intersection(L0,L1);
          //If(InVerboseMode(),Tell("  -->",LI));
          L0 := FlatCopy(LI);
      ];
      //If(InVerboseMode(),Tell("  result ",L0));
      result := L0;
    ]
  );
  result;
];
  

11 # Intersection(list1_IsList,list2_IsList) <--
[
    //If(InVerboseMode(),Tell("Intersection_pairOfLists",{list1,list2}));
    Local(l2,index,result);
    l2:=FlatCopy(list2);
    result:={};
    ForEach(item,list1)
    [
        Bind(index, Find(l2,item));
        If(index>0,
          [
             DestructiveDelete(l2,index);
             DestructiveInsert(result,1,item);
          ]
        );
    ];
    DestructiveReverse(result);
];


%/mathpiper

    %output,preserve="false"
      Result: True
.   %/output




%mathpiper_docs,name="Intersection",categories="User Functions;Lists (Operations)"
*CMD Intersection --- return the Intersection of two or more lists
*STD
*CALL
	Intersection(L1, L2)
or
    Intersection( ListOfLists )

*PARMS

{L1}, {L2} -- two lists
or
{ListOfLists}  --  a List of two or more lists

*DESC

The Intersection of all the lists is determined and
returned. The Intersection contains all elements that occur in all
lists. The entries in the result are listed in the same order as in
the first list. If an expression occurs multiple times in all the
lists, then it will occur the same number of times in the result.

*E.G.

In> Intersection({a,b,c}, {b,c,d})
Result: {b,c}

In> Intersection({a,e,i,o,u}, {f,o,u,r,t,e,e,n})
Result: {e,o,u}

In> Intersection({1,2,2,3,3,3}, {1,1,2,2,3,3})
Result: {1,2,2,3,3}

In> Intersection({{1,2,2,3,3,3,a,c,e},{1,1,2,2,3,3,a,c,e},{3,a,b,c,d,e,f,1,3,5}})
Result: {1,3,3,a,c,e}
    
*SEE Union, Difference

%/mathpiper_docs
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/HeapSort.mpw0000644000175000017500000000522211342344550026676 0ustar  giovannigiovanni%mathpiper,def="HeapSort"

HeapSort(list, compare) := HeapSort(list, ArrayCreate(Length(list), 0), 1, Length(list), compare);

// this will sort "list" and mangle "tmplist"
1 # HeapSort(_list, _tmplist, _first, _last, _compare) _ (last - first <= 2) <-- SmallSort(list, first, last, compare);
2 # HeapSort(_list, _tmplist, _first, _last, _compare) <--
[	// See: J. W. J. Williams, Algorithm 232 (Heapsort), Com. of ACM, vol. 7, no. 6, p. 347 (1964)
	// sort two halves recursively, then merge two halves
	// cannot merge in-place efficiently, so need a second list
	Local(mid, ileft, iright, pleft);
	mid := first+((last-first)>>1);
	HeapSort(list, tmplist, first, mid, compare);
	HeapSort(list, tmplist, mid+1, last, compare);
	// copy the lower part to temporary array
	For(ileft := first,  ileft <= mid, ileft++)
		tmplist[ileft] := list[ileft];
	For(
		[ileft := first; pleft := first; iright := mid+1;],
		ileft <= mid,	// if the left half is finished, we don't have to do any more work
		pleft++	// one element is stored at each iteration
	)	// merge two halves
		// elements before pleft have been stored
		// the smallest element of the right half is at iright
		// the smallest element of the left half is at ileft, access through tmplist
	If(	// we copy an element from ileft either if it is smaller or if the right half is finished; it is unnecessary to copy the remainder of the right half since the right half stays in the "list"
		iright>last Or Apply(compare,{tmplist[ileft],list[iright]}),
		[	// take element from ileft
			list[pleft] := tmplist[ileft];
			ileft++;
		],
		[	// take element from iright
			list[pleft] := list[iright];
			iright++;
		]
	);

	list;
];

%/mathpiper



%mathpiper_docs,name="HeapSort",categories="User Functions;Lists (Operations)"
*CMD HeapSort --- sort a list
*STD
*CALL
	HeapSort(list, compare)

*PARMS

{list} -- list to sort

{compare} -- function used to compare elements of {list}

*DESC

This command returns {list} after it is sorted using {compare} to
compare elements. The function {compare} should accept two arguments,
which will be elements of {list}, and compare them. It should return
{True} if in the sorted list the second argument
should come after the first one, and {False}
otherwise.  The function {compare} can either be a string which
contains the name of a function or a pure function.

The function {HeapSort} uses a recursive algorithm "heapsort" and is much
faster for large lists. The sorting time is proportional to $n*Ln(n)$ where $n$
is the length of the list.

*E.G.
In> HeapSort({4,7,23,53,-2,1}, ">")
Result: {53,23,7,4,1,-2}

In> HeapSort({3,5,2},Lambda({x,y},x lst := {a,b,c,b,a};
Result: {a,b,c,b,a};
In> Count(lst, a);
Result: 2;
In> Count(lst, c);
Result: 1;
In> Count(lst, x);
Result: 0;

*SEE Length, Select, Contains
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/global_stack.mpw0000644000175000017500000000315311523200452027570 0ustar  giovannigiovanni%mathpiper,def="GlobalPush;GlobalPop"

//////////////////////////////////////////////////
/// Global stack operations on variables
//////////////////////////////////////////////////


LocalSymbols(GlobalStack, x)
[
  GlobalStack := {};

	GlobalPop(x_IsAtom) <--
	[
		Check(Length(GlobalStack)>0, "Invariant", "GlobalPop: Error: empty GlobalStack");
		MacroBind(x, PopFront(GlobalStack));
		Eval(x);
	];

	HoldArgumentNumber("GlobalPop", 1, 1);

	GlobalPop() <--
	[
		Check(Length(GlobalStack)>0, "Invariant", "GlobalPop: Error: empty GlobalStack");
		PopFront(GlobalStack);
	];

	GlobalPush(_x) <--
	[
		Push(GlobalStack, x);
		x;
	];
];

%/mathpiper



%mathpiper_docs,name="GlobalPop;GlobalPush",categories="User Functions;Lists (Operations)"
*CMD GlobalPop --- restore variables using a global stack
*CMD GlobalPush --- save variables using a global stack
*STD
*CALL
	GlobalPop(var)
	GlobalPop()
	GlobalPush(expr)

*PARMS

{var} -- atom, name of variable to restore from the stack

{expr} -- expression, value to save on the stack

*DESC

These functions operate with a global stack, currently implemented as a list that is not accessible externally (it is protected 
through {LocalSymbols}).

{GlobalPush} stores a value on the stack. {GlobalPop} removes the last pushed value from the stack. If a variable name is given, the variable is assigned, otherwise the popped value is returned.

If the global stack is empty, an error message is printed.

*E.G.

In> GlobalPush(3)
Result: 3;
In> GlobalPush(Sin(x))
Result: Sin(x);
In> GlobalPop(x)
Result: Sin(x);
In> GlobalPop(x)
Result: 3;
In> x
Result: 3;

*SEE Push, PopFront
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/VarListArith.mpw0000644000175000017500000000404211523200452027515 0ustar  giovannigiovanni%mathpiper,def="VarListArith"

/// VarListArith --- obtain arithmetic variables
// currently the VarList(x,y) semantic is convoluted so let's introduce a new name; but in principle this needs to be cleaned up
VarListArith(expr) := VarListSome(expr, {ToAtom("+"), ToAtom("-"), *, /});

%/mathpiper



%mathpiper_docs,name="VarListArith",categories="User Functions;Lists (Operations)"
*CMD VarList --- list of variables appearing in an expression
*CMD VarListArith --- list of variables appearing in an expression
*CMD VarListSome --- list of variables appearing in an expression
*STD
*CALL
	VarList(expr)
	VarListArith(expr)
	VarListSome(expr, list)

*PARMS

{expr} -- an expression

{list} -- a list of function atoms

*DESC

The command {VarList(expr)} returns a list of all variables that appear in the
expression {expr}. The expression is traversed recursively.

The command {VarListSome} looks only at arguments of functions in the {list}. All other functions are considered "opaque" (as if they do not contain any variables) and their arguments are not checked.
For example, {VarListSome(a + Sin(b-c))} will return {{a, b, c}}, but {VarListSome(a*Sin(b-c), {*})} will not look at arguments of {Sin()} and will return {{a,Sin(b-c)}}. Here {Sin(b-c)} is considered a "variable" because the function {Sin} does not belong to {list}.


The command {VarListArith} returns a list of all variables that appear
arithmetically in the expression {expr}. This is implemented through
{VarListSome} by restricting to the arithmetic functions {+}, {-}, {*}, {/}.
Arguments of other functions are not checked.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> VarList(Sin(x))
Result: {x};
In> VarList(x+a*y)
Result: {x,a,y};
In> VarListSome(x+a*y, {ToAtom("+")})
Result: {x,a*y};
In> VarListArith(x+y*Cos(Ln(x)/x))
Result: {x,y,Cos(Ln(x)/x)}
In> VarListArith(x+a*y^2-1)
Result: {x,a,y^2};

*SEE IsFreeOf, IsVariable, FuncList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Contains.mpw0000644000175000017500000000205711523200452026723 0ustar  giovannigiovanni%mathpiper,def="Contains"

Function("Contains",{list,element})
[
  Local(result);
  Bind(result,False);
  While(And(Not(result), Not(IsEqual(list, {}))))
  [
    If(IsEqual(First(list),element),
      Bind(result, True),
      Bind(list, Rest(list))
      );
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="Contains",categories="User Functions;Lists (Operations)"
*CMD Contains --- test whether a list contains a certain element
*STD
*CALL
	Contains(list, expr)

*PARMS

{list} -- list to examine

{expr} -- expression to look for in "list"

*DESC

This command tests whether "list" contains the expression "expr"
as an entry. It returns {True} if it does and
{False} otherwise. Only the top level of "list" is
examined. The parameter "list" may also be a general expression, in
that case the top-level operands are tested for the occurrence of
"expr".

*E.G.

In> Contains({a,b,c,d}, b);
Result: True;
In> Contains({a,b,c,d}, x);
Result: False;
In> Contains({a,{1,2,3},z}, 1);
Result: False;
In> Contains(a*b, b);
Result: True;

*SEE Find, Count
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FuncListSome.mpw0000644000175000017500000000307711523200452027523 0ustar  giovannigiovanni%mathpiper,def=""

//todo:tk:not defined in the scripts.

%/mathpiper



%mathpiper_docs,name="FuncListSome",categories="User Functions;Lists (Operations)"
*CMD FuncList --- list of functions used in an expression
*CMD FuncListArith --- list of functions used in an expression
*CMD FuncListSome --- list of functions used in an expression
*STD
*CALL
	FuncList(expr)
	FuncListArith(expr)
	FuncListSome(expr, list)

*PARMS

{expr} -- an expression

{list} -- list of function atoms to be considered "transparent"

*DESC

The command {FuncList(expr)} returns a list of all function atoms that appear
in the expression {expr}. The expression is recursively traversed.

The command {FuncListSome(expr, list)} does the same, except it only looks at arguments of a given {list} of functions. All other functions become "opaque" (as if they do not contain any other functions).
For example, {FuncListSome(a + Sin(b-c))} will see that the expression has a "{-}" operation and return {{+,Sin,-}}, but {FuncListSome(a + Sin(b-c), {+})} will not look at arguments of {Sin()} and will return {{+,Sin}}.

{FuncListArith} is defined through {FuncListSome} to look only at arithmetic operations {+}, {-}, {*}, {/}.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G. notest

In> FuncList(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos,/,Ln};
In> FuncListArith(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos};
In> FuncListSome({a+b*2,c/d},{List})
Result: {List,+,/};

*SEE VarList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/DestructiveAppend.mpw0000644000175000017500000000206511523200452030575 0ustar  giovannigiovanni%mathpiper,def="DestructiveAppend"

Function("DestructiveAppend",{list,element})
[
  DestructiveInsert(list,Length(list)+1,element);
];

%/mathpiper



%mathpiper_docs,name="DestructiveAppend",categories="User Functions;Lists (Operations)"
*CMD DestructiveAppend --- destructively append an entry to a list
*STD
*CALL
	DestructiveAppend(list, expr)

*PARMS

{list} -- list to append "expr" to

{expr} -- expression to append to the list

*DESC

This is the destructive counterpart of {Append}. This
command yields the same result as the corresponding call to
{Append}, but the original list is modified. So if a
variable is bound to "list", it will now be bound to the list with
the expression "expr" inserted.

Destructive commands run faster than their nondestructive counterparts
because the latter copy the list before they alter it.

*E.G.

In> lst := {a,b,c,d};
Result: {a,b,c,d};
In> Append(lst, 1);
Result: {a,b,c,d,1};
In> lst
Result: {a,b,c,d};
In> DestructiveAppend(lst, 1);
Result: {a,b,c,d,1};
In> lst;
Result: {a,b,c,d,1};

*SEE Concat, :, Append
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/DestructiveAppendList.mpw0000644000175000017500000000033111316274015031431 0ustar  giovannigiovanni%mathpiper,def="DestructiveAppendList"

Function("DestructiveAppendList",{list,toadd})
[
  Local(i,nr);
  nr:=Length(toadd);
  For(i:=1,i<=nr,i++)
  [
    DestructiveAppend(list,toadd[i]);
  ];
  True;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FillList.mpw0000644000175000017500000000127211523200452026665 0ustar  giovannigiovanni%mathpiper,def="FillList"

Function("FillList", {aItem, aLength})
[
  Local(i, aResult);
  aResult:={};
  For(i:=0, i FillList(x, 5);
Result: {x,x,x,x,x};

*SEE MakeVector, ZeroVector, RandomIntegerList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Reverse.mpw0000644000175000017500000000124011523200452026551 0ustar  giovannigiovanni%mathpiper,def="Reverse"

// Non-destructive Reverse operation
Reverse(list):=DestructiveReverse(FlatCopy(list));

%/mathpiper



%mathpiper_docs,name="Reverse",categories="User Functions;Lists (Operations)"
*CMD Reverse --- return the reversed list (without touching the original)
*STD
*CALL
	Reverse(list)

*PARMS

{list} -- list to reverse

*DESC

This function returns a list reversed, without changing the
original list. It is similar to {DestructiveReverse}, but safer
and slower.


*E.G.

In> lst:={a,b,c,13,19}
Result: {a,b,c,13,19};
In> revlst:=Reverse(lst)
Result: {19,13,c,b,a};
In> lst
Result: {a,b,c,13,19};

*SEE FlatCopy, DestructiveReverse
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FindPredicate.mpw0000644000175000017500000000062211331203122027634 0ustar  giovannigiovanni%mathpiper,def="FindPredicate"

// Find the first thingy that matches a predicate
Function("FindPredicate",{list,predicate})
[
  Local(result,count);
  Bind(result, -1);
  Bind(count, 1);
  While(And(result<0, Not(IsEqual(list, {}))))
  [
    If(Apply(predicate,{First(list)}),
      Bind(result, count)
      );
    Bind(list,Rest(list));
    Bind(count,AddN(count,1));
  ];
  result;
]; 

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/PrintList.mpw0000644000175000017500000000234411523200452027074 0ustar  giovannigiovanni%mathpiper,def="PrintList"

//////////////////////////////////////////////////
/// Print a list using a padding string
//////////////////////////////////////////////////

10 # PrintList(list_IsList) <-- PrintList(list, ", ");
10 # PrintList({}, padding_IsString) <-- "";
20 # PrintList(list_IsList, padding_IsString) <-- PipeToString() [
	Local(i);
	ForEach(i, list) [
		If(Not(IsEqual(i, First(list))), WriteString(padding));
		If (IsString(i), WriteString(i), If(IsList(i), WriteString("{" : PrintList(i, padding) : "}"), Write(i)));
	];
];

%/mathpiper



%mathpiper_docs,name="PrintList",categories="User Functions;Lists (Operations)"
*CMD PrintList --- print list with padding
*STD
*CALL
	PrintList(list)
	PrintList(list, padding);

*PARMS

{list} -- a list to be printed

{padding} -- (optional) a string

*DESC

Prints {list} and inserts the {padding} string between each pair of items of the list. Items of the list which are strings are printed without quotes, unlike {Write()}. Items of the list which are themselves lists are printed inside braces {{}}. If padding is not specified, a standard one is used (comma, space).

*E.G.

In> PrintList({a,b,{c, d}}, " .. ")
Result: " a ..  b .. { c ..  d}";

*SEE Write, WriteString
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/MapSingle.mpw0000644000175000017500000000206511523200452027023 0ustar  giovannigiovanni%mathpiper,def="MapSingle"

TemplateFunction("MapSingle",{func,list})
[
  Local(mapsingleresult);
  mapsingleresult:={};

  ForEach(mapsingleitem,list)
  [
    DestructiveInsert(mapsingleresult,1,
      Apply(func,{mapsingleitem}));
  ];
  DestructiveReverse(mapsingleresult);
];
UnFence("MapSingle",2);
HoldArgument("MapSingle",func);

%/mathpiper



%mathpiper_docs,name="MapSingle",categories="User Functions;Lists (Operations)"
*CMD MapSingle --- apply a unary function to all entries in a list
*STD
*CALL
	MapSingle(fn, list)

*PARMS

{fn} -- function to apply

{list} -- list of arguments

*DESC

The function "fn" is successively applied to all entries in
"list", and a list containing the respective results is
returned. The function can be given either as a string or as a pure
function (see Apply for more information on pure functions).

The {/@} operator provides a shorthand for
{MapSingle}.

*E.G.

In> MapSingle("Sin",{a,b,c});
Result: {Sin(a),Sin(b),Sin(c)};
In> MapSingle({{x},x^2}, {a,2,c});
Result: {a^2,4,c^2};

*SEE Map, MapArgs, /@, Apply
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/scopestack/0000755000175000017500000000000011722677331026572 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/scopestack/scopestack.mpw0000644000175000017500000000375511502266107031457 0ustar  giovannigiovanni%mathpiper,def="NewStack;PushStackFrame;PopStackFrame;StackDepth;AddToStack;IsOnStack;FindOnStack"

/* def file list
NewStack
PushStackFrame
PopStackFrame
StackDepth
AddToStack
IsOnStack
FindOnStack

*/


/*
   Stack simulator. Api:

   NewStack() - creates a stack simulation
   PushStackFrame(stack,unfenced) - push frame on stack, (un)fenced
   PushStackFrame(stack,fenced)
   PopStackFrame(stack)   - pop stack frame
   StackDepth(_stack) - return stack depth
   AddToStack(stack,element) - add element to top stack frame

   IsOnStack(stack,element) - returns True if element is accessible
       on current stack, False otherwise
   FindOnStack(stack,element) - return assoc list for element.
       Check first with IsOnStack that it is available!

*/

NewStack() := {{},{}};

10 # PushStackFrame(_stack,unfenced)
   <--
   [
     DestructiveInsert(stack[1],1,{});
     DestructiveInsert(stack[2],1,True);
   ];
10 # PushStackFrame(_stack,fenced)
   <--
   [
     DestructiveInsert(stack[1],1,{});
     DestructiveInsert(stack[2],1,False);
   ];
PopStackFrame(stack):=
[
  DestructiveDelete(stack[1],1);
  DestructiveDelete(stack[2],1);
];
StackDepth(_stack) <-- Length(stack[1]);

AddToStack(stack,element)  :=
[
  DestructiveInsert(stack[1][1],1,{element,{}});
];

DropOneFrame(_stack) <-- {Rest(stack[1]),Rest(stack[2])};

10 # IsOnStack({{},{}},_element) <-- False;
11 # IsOnStack(_stack,_element)_(stack[1][1][element] != Empty) <-- True;
20 # IsOnStack(_stack,_element)_(StackDepth(stack)>0 And stack[2][1] = True)
   <-- IsOnStack(DropOneFrame(stack),element);
30 # IsOnStack(_stack,_element) <--
[
//Echo("stack depth = ",StackDepth(stack));
//Echo(stack[2][1]);
False;
];
10 # FindOnStack(_stack,_element)_(stack[1][1][element] != Empty)
   <-- stack[1][1][element];
20 # FindOnStack(_stack,_element)_(StackDepth(stack)>0 And stack[2][1] = True)
   <-- FindOnStack(DropOneFrame(stack),element);
30 # FindOnStack(_stack,_element) <-- Check(False, "Argument", "Illegal stack access! Use IsOnStack.");



%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Drop.mpw0000644000175000017500000000257011523200452026051 0ustar  giovannigiovanni%mathpiper,def="Drop"

/* ���� Drop ���� */

/* Needs to check the parameters */

/*
 * Drop( list, n ) gives 'list' with its first n elements dropped
 * Drop( list, -n ) gives 'list' with its last n elements dropped
 * Drop( list, {m,n} ) gives 'list' with elements m through n dropped
 */

Rulebase("Drop", {lst, range});

Rule("Drop", 2, 1, IsList(range))
    Concat(Take(lst,range[1]-1), Drop(lst, range[2]));

Rule("Drop", 2, 2, range >= 0)
    If( range = 0 Or lst = {}, lst, Drop( Rest(lst), range-1 ));

Rule("Drop", 2, 2, range < 0)
    Take( lst, Length(lst) + range );

%/mathpiper



%mathpiper_docs,name="Drop",categories="User Functions;Lists (Operations)"
*CMD Drop --- drop a range of elements from a list

*STD

*CALL
	Drop(list, n)
	Drop(list, -n)
	Drop(list, {m,n})

*PARMS

{list} -- list to act on

{n}, {m} -- positive integers describing the entries to drop

*DESC

This command removes a sublist of "list" and returns a list
containing the remaining entries. The first calling sequence drops the
first "n" entries in "list". The second form drops the last "n"
entries. The last invocation drops the elements with indices "m"
through "n".

*E.G.

In> lst := {a,b,c,d,e,f,g};
Result: {a,b,c,d,e,f,g};
In> Drop(lst, 2);
Result: {c,d,e,f,g};
In> Drop(lst, -3);
Result: {a,b,c,d};
In> Drop(lst, {2,4});
Result: {a,e,f,g};

*SEE Take, Select, Remove
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/RemoveDuplicates.mpw0000644000175000017500000000141211523200452030412 0ustar  giovannigiovanni%mathpiper,def="RemoveDuplicates"

Function("RemoveDuplicates",{list})
[
   Local(result);
   Bind(result,{});
   ForEach(item,list)
     If(Not(Contains(result,item)),DestructiveAppend(result,item));
   result;
];

%/mathpiper



%mathpiper_docs,name="RemoveDuplicates",categories="User Functions;Lists (Operations)"
*CMD RemoveDuplicates --- remove any duplicates from a list
*STD
*CALL
	RemoveDuplicates(list)

*PARMS

{list} -- list to act on

*DESC

This command removes all duplicate elements from a given list and returns the resulting list.
To be
precise, the second occurrence of any entry is deleted, as are the
third, the fourth, etc.

*E.G.

In> RemoveDuplicates({1,2,3,2,1});
Result: {1,2,3};
In> RemoveDuplicates({a,1,b,1,c,1});
Result: {a,1,b,c};
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Table.mpw0000644000175000017500000000402511352320006026167 0ustar  giovannigiovanni%mathpiper,def="Table"

/* Juan: TemplateFunction (as defined in the file "deffunc")
 * also makes the arguments to the function local symbols.
 * Use HoldArgumentNumber to specify the index of a variable to hold
 * (since they are defined as local symbols).
 */

TemplateFunction("Table",{body,var,count'from,count'to,step})
  [
    MacroLocal(var);
    Local(result,nr,ii);
    result:={};
    nr := (count'to - count'from) / step;
    ii := 0;
    While( ii <= nr )
      [
       MacroBind( var, count'from + ii * step );
       DestructiveInsert( result,1,Eval(body) );
       Bind(ii,AddN(ii,1));
      ];
    DestructiveReverse(result);
  ];
HoldArgumentNumber("Table",5,1); /* body */
HoldArgumentNumber("Table",5,2); /* var */
UnFence("Table",5);

%/mathpiper



%mathpiper_docs,name="Table",categories="User Functions;Lists (Operations)"
*CMD Table --- evaluate while some variable ranges over interval
*STD
*CALL
	Table(body, var, from, to, step)

*PARMS

{body} -- expression to evaluate multiple times

{var} -- variable to use as loop variable

{from} -- initial value for "var"

{to} -- final value for "var"

{step} -- step size with which "var" is incremented

*DESC

This command generates a list of values from "body", by assigning
variable "var" values from "from" up to "to", incrementing
"step" each time. So, the variable "var" first gets the value
"from", and the expression "body" is evaluated. Then the value
"from"+"step" is assigned to "var" and the expression "body"
is again evaluated. This continues, incrementing "var" with "step"
on every iteration, until "var" exceeds "to". At that moment, all
the results are assembled in a list and this list is returned.

*E.G.
In> Table(i!, i, 1, 9, 1);
Result: {1,2,6,24,120,720,5040,40320,362880}

In> Table(i, i, 3, 16, 4);
Result: {3,7,11,15}

In> Table(i^2, i, 10, 1, -1);
Result: {100,81,64,49,36,25,16,9,4,1}

In> Table(a+b, b, 0, 2, 1)
Result: {a,a+1,a+2}

In> Table(Table(a+b, b, 0, 2, 1), a, 0, 2, 1)
Result: {{0,1,2},{1,2,3},{2,3,4}}

*SEE For, MapSingle, .., TableForm
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Swap.mpw0000644000175000017500000000167511523200452026064 0ustar  giovannigiovanni%mathpiper,def="Swap"

Function("Swap",{list,index1,index2})
[
  Local(item1,item2);
  item1:=list[index1];
  item2:=list[index2];
  list[index1] := item2;
  list[index2] := item1;
];

%/mathpiper



%mathpiper_docs,name="Swap",categories="User Functions;Lists (Operations)"
*CMD Swap --- swap two elements in a list
*STD
*CALL
	Swap(list, i1, i2)

*PARMS

{list} -- the list in which a pair of entries should be swapped

{i1, i2} -- indices of the entries in "list" to swap

*DESC

This command swaps the pair of entries with entries "i1" and "i2"
in "list". So the element at index "i1" ends up at index "i2"
and the entry at "i2" is put at index "i1". Both indices should be
valid to address elements in the list. Then the updated list is
returned.

{Swap()} works also on generic arrays.

*E.G.

In> lst := {a,b,c,d,e,f};
Result: {a,b,c,d,e,f};
In> Swap(lst, 2, 4);
Result: {a,d,c,b,e,f};

*SEE Replace, DestructiveReplace, Array'Create
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FuncList.mpw0000644000175000017500000000550511523200452026675 0ustar  giovannigiovanni%mathpiper,def="FuncList"

//////////////////////////////////////////////////
/// FuncList --- list all function atoms used in an expression
//////////////////////////////////////////////////
/// like VarList except collects functions

10 # FuncList(expr_IsAtom) <-- {};
20 # FuncList(expr_IsFunction) <--
RemoveDuplicates(
	Concat(
		{First(FunctionToList(expr))},
		Apply("Concat",
			MapSingle("FuncList", Rest(FunctionToList(expr)))
		)
	)
);

/*
This is like FuncList except only looks at arguments of a given list of functions. All other functions become "opaque".

*/
10 # FuncList(expr_IsAtom, look'list_IsList) <-- {};
// a function not in the looking list - return its type
20 # FuncList(expr_IsFunction, look'list_IsList)_(Not Contains(look'list, ToAtom(Type(expr)))) <-- {ToAtom(Type(expr))};
// a function in the looking list - traverse its arguments
30 # FuncList(expr_IsFunction, look'list_IsList) <--
RemoveDuplicates(
	Concat(
		{First(FunctionToList(expr))},
		[	// gave up trying to do it using Map and MapSingle... so writing a loop now.
			// obtain a list of functions, considering only functions in look'list
			Local(item, result);
			result := {};
			ForEach(item, expr) result := Concat(result, FuncList(item, look'list));
			result;
		]
	)
);

HoldArgumentNumber("FuncList", 1, 1);
HoldArgumentNumber("FuncList", 2, 1);

%/mathpiper



%mathpiper_docs,name="FuncList",categories="User Functions;Lists (Operations)"
*CMD FuncList --- list of functions used in an expression
*CMD FuncListArith --- list of functions used in an expression
*CMD FuncListSome --- list of functions used in an expression
*STD
*CALL
	FuncList(expr)
	FuncListArith(expr)
	FuncListSome(expr, list)

*PARMS

{expr} -- an expression

{list} -- list of function atoms to be considered "transparent"

*DESC

The command {FuncList(expr)} returns a list of all function atoms that appear
in the expression {expr}. The expression is recursively traversed.

The command {FuncListSome(expr, list)} does the same, except it only looks at arguments of a given {list} of functions. All other functions become "opaque" (as if they do not contain any other functions).
For example, {FuncListSome(a + Sin(b-c))} will see that the expression has a "{-}" operation and return {{+,Sin,-}}, but {FuncListSome(a + Sin(b-c), {+})} will not look at arguments of {Sin()} and will return {{+,Sin}}.

{FuncListArith} is defined through {FuncListSome} to look only at arithmetic operations {+}, {-}, {*}, {/}.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G. notest

In> FuncList(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos,/,Ln};
In> FuncListArith(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos};
In> FuncListSome({a+b*2,c/d},{List})
Result: {List,+,/};

*SEE VarList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/VarListAll.mpw0000644000175000017500000000127211331203122027152 0ustar  giovannigiovanni%mathpiper,def="VarListAll"

/*
 * Rulebase for VarListAll: recursively traverse an expression looking
 * up all variables the expression depends on.
 */
/* Accept any variable. */

VarListAll(_expr) <-- VarListAll(expr,"IsVariable");

10 # VarListAll(_expr,_filter)_(Apply(filter,{expr}) = True) <--
     {expr};

/* Otherwise check all leafs of a function. */
20 # VarListAll(expr_IsFunction,_filter) <--
[
  Local(item,result, flatlist);
  Bind(flatlist,Rest(FunctionToList(expr)));
  Bind(result,{});
  ForEach(item,flatlist)
    Bind(result,Concat(result,VarListAll(item,filter)));
  result;
];

/* Else it doesn't depend on any variable. */
30 # VarListAll(_expr,_filter) <-- {};

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Difference.mpw0000644000175000017500000000222611523200452027175 0ustar  giovannigiovanni%mathpiper,def="Difference"

Function("Difference",{list1,list2})
[
  Local(l2,index,result);
  l2:=FlatCopy(list2);
  result:=FlatCopy(list1);
  ForEach(item,list1)
  [
    Bind(index,Find(l2,item));
    If(index>0,
      [
        DestructiveDelete(l2,index);
        DestructiveDelete(result,Find(result,item));
      ]
      );
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="Difference",categories="User Functions;Lists (Operations)"
*CMD Difference --- return the difference of two lists
*STD
*CALL
	Difference(l1, l2)

*PARMS

{l1}, {l2} -- two lists

*DESC

The difference of the lists "l1" and "l2" is determined and
returned. The difference contains all elements that occur in "l1"
but not in "l2". The order of elements in "l1" is preserved. If a
certain expression occurs "n1" times in the first list and "n2"
times in the second list, it will occur "n1-n2" times in the result
if "n1" is greater than "n2" and not at all otherwise.

*E.G.

In> Difference({a,b,c}, {b,c,d});
Result: {a};
In> Difference({a,e,i,o,u}, {f,o,u,r,t,e,e,n});
Result: {a,i};
In> Difference({1,2,2,3,3,3}, {2,2,3,4,4});
Result: {1,3,3};

*SEE Intersection, Union
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Find.mpw0000644000175000017500000000165311523200452026026 0ustar  giovannigiovanni%mathpiper,def="Find"

Function("Find",{list,element})
[
  Local(result,count);
  Bind(result, -1);
  Bind(count, 1);
  While(And(result<0, Not(IsEqual(list, {}))))
  [
    If(IsEqual(First(list), element),
      Bind(result, count)
      );
    Bind(list,Rest(list));
    Bind(count,AddN(count,1));
  ];
  result;
];

%/mathpiper



%mathpiper_docs,name="Find",categories="User Functions;Lists (Operations)"
*CMD Find --- get the index at which a certain element occurs
*STD
*CALL
	Find(list, expr)

*PARMS

{list} -- the list to examine

{expr} -- expression to look for in "list"

*DESC

This commands returns the index at which the expression "expr"
occurs in "list". If "expr" occurs more than once, the lowest
index is returned. If "expr" does not occur at all,
{-1} is returned.

*E.G.

In> Find({a,b,c,d,e,f}, d);
Result: 4;
In> Find({1,2,3,2,1}, 2);
Result: 2;
In> Find({1,2,3,2,1}, 4);
Result: -1;

*SEE Contains
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/MapArgs.mpw0000644000175000017500000000162211523200452026474 0ustar  giovannigiovanni%mathpiper,def="MapArgs"

TemplateFunction("MapArgs",{expr,oper})
[
  Bind(expr,FunctionToList(expr));
   ListToFunction(Concat({expr[1]},
     Apply("MapSingle",{oper,Rest(expr)})
   ) );
];
UnFence("MapArgs",2);
HoldArgument("MapArgs",oper);

%/mathpiper



%mathpiper_docs,name="MapArgs",categories="User Functions;Control Flow"
*CMD MapArgs --- apply a function to all top-level arguments
*STD
*CALL
	MapArgs(expr, fn)

*PARMS

{expr} -- an expression to work on

{fn} -- an operation to perform on each argument

*DESC

Every top-level argument in "expr" is substituted by the result of
applying "fn" to this argument. Here "fn" can be either the name
of a function or a pure function (see Apply for more information on 
pure functions).

*E.G.

In> MapArgs(f(x,y,z),"Sin");
Result: f(Sin(x),Sin(y),Sin(z));
In> MapArgs({3,4,5,6}, {{x},x^2});
Result: {9,16,25,36};

*SEE MapSingle, Map, Apply
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Push.mpw0000644000175000017500000000135511523200452026064 0ustar  giovannigiovanni%mathpiper,def="Push"

Function("Push",{stack,element})
[
  DestructiveInsert(stack,1,element);
];

%/mathpiper



%mathpiper_docs,name="Push",categories="User Functions;Lists (Operations)"
*CMD Push --- add an element on top of a stack
*STD
*CALL
	Push(stack, expr)

*PARMS

{stack} -- a list (which serves as the stack container)

{expr} -- expression to push on "stack"

*DESC

This is part of a simple implementation of a stack, internally
represented as a list. This command pushes the expression "expr" on
top of the stack, and returns the stack afterwards.

*E.G.

In> stack := {};
Result: {};
In> Push(stack, x);
Result: {x};
In> Push(stack, x2);
Result: {x2,x};
In> PopFront(stack);
Result: x2;

*SEE Pop, PopFront, PopBack
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Select.mpw0000644000175000017500000000210311422223770026362 0ustar  giovannigiovanni%mathpiper,def="Select"

LocalSymbols(predicate,list,result,item)
[
  Function("Select",{list,predicate})
  [
    Local(result);
    result:={};
    ForEach(item,list)
    [
      If(Apply(predicate,{item}),DestructiveAppend(result,item));
    ];
    result;
  ];
  HoldArgument("Select",predicate);
  UnFence("Select",2);
];

%/mathpiper



%mathpiper_docs,name="Select",categories="User Functions;Lists (Operations)"
*CMD Select --- select entries satisfying some predicate
*STD
*CALL
	Select(list, pred)

*PARMS

{pred} -- a predicate

{list} -- a list of elements to select from

*DESC

{Select} returns a sublist of "list" which contains all
the entries for which the predicate "pred" returns
{True} when applied to this entry.

The {Lambda} function can be used in place of a predicate function
if desired.

*E.G.

In> Select({a,b,2,c,3,d,4,e,f}, "IsInteger")
Result: {2,3,4};


/%mathpiper

list := {1,-3,2,-6,-4,3};

Select(list, Lambda({i}, i > 0 ));

/%/mathpiper

    /%output,preserve="false"
      Result: {1,2,3}
.   /%/output

*SEE Length, Find, Count, Lambda
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Append.mpw0000644000175000017500000000163011523200452026350 0ustar  giovannigiovanni%mathpiper,def="Append"

Function("Append",{list,element})
[
  Check(IsList(list), "Argument", "The first argument must be a list.");

  Insert(list,Length(list)+1,element);
];


%/mathpiper



%mathpiper_docs,name="Append",categories="User Functions;Lists (Operations)"
*CMD Append --- append an entry at the end of a list
*STD
*CALL
	Append(list, expr)

*PARMS

{list} -- list to append "expr" to

{expr} -- expression to append to the list

*DESC

The expression "expr" is appended at the end of "list" and the
resulting list is returned.

Note that due to the underlying data structure, the time it takes to
append an entry at the end of a list grows linearly with the length of
the list, while the time for prepending an entry at the beginning is
constant.

*E.G.

In> Append({a,b,c,d}, 1);
Result: {a,b,c,d,1};

*SEE Concat, :, DestructiveAppend
%/mathpiper_docs

    %output,preserve="false"
      
.   %/output

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Map.mpw0000644000175000017500000000237211423471644025676 0ustar  giovannigiovanni%mathpiper,def="Map"

LocalSymbols(func,lists,mapsingleresult,mapsingleitem)
[
  TemplateFunction("Map",{func,lists})
  [
    Local(mapsingleresult,mapsingleitem);
    mapsingleresult:={};
    lists:=Transpose(lists);
    ForEach(mapsingleitem,lists)
    [
      DestructiveInsert(mapsingleresult,1,Apply(func,mapsingleitem));
    ];
    DestructiveReverse(mapsingleresult);
  ];
  UnFence("Map",2);
  HoldArgument("Map",func);
];

%/mathpiper



%mathpiper_docs,name="Map",categories="User Functions;Lists (Operations)"
*CMD Map --- apply an $n$-ary function to all entries in a list
*STD
*CALL
	Map(fn, list)

*PARMS

{fn} -- function to apply

{list} -- list of lists of arguments

*DESC

This function applies "fn" to every list of arguments to be found in
"list". So the first entry of "list" should be a list containing
the first, second, third, ... argument to "fn", and the same goes
for the other entries of "list". The function can either be given as
a string or as a pure function (see Apply for more information on 
pure functions).

*E.G.
In> MapSingle("Sin",{a,b,c});
Result> {Sin(a),Sin(b),Sin(c)};

In> Map("+",{{a,b},{c,d}});
Result> {a+c,b+d};

In> Map("List",{{1,2,3},{4,5,6}});
Result: {{1,4},{2,5},{3,6}}

*SEE MapSingle, MapArgs, Apply
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/MacroMapArgs.mpw0000644000175000017500000000054711331203122027455 0ustar  giovannigiovanni%mathpiper,def="MacroMapArgs"

/* Another Macro... hack for /: to work. */
Macro("MacroMapArgs",{expr,oper})
[
  Local(ex,tl,op);
  Bind(op,@oper);
  Bind(ex,FunctionToList(@expr));
  Bind(tl,Rest(ex));

   ListToFunction(Concat({ex[1]},
     `MacroMapSingle(@op,Hold(@tl)))
   );
];

UnFence("MacroMapArgs",2);
HoldArgument("MacroMapArgs",oper);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Take.mpw0000644000175000017500000000263011523200452026026 0ustar  giovannigiovanni%mathpiper,def="Take"

/* ���� Take ���� */

/* Needs to check the parameters */

/*
 * Take( list, n ) gives the first n elements of 'list'
 * Take( list, -n ) gives the last n elements of 'list'
 * Take( list, {m,n} ) elements m through n of 'list'
 */

Rulebase("Take", {lst, range});

Rule("Take", 2, 1, IsList(range))
    Take( Drop(lst, range[1] -1), range[2] - range[1] + 1);

Rule("Take", 2, 2, range >= 0)
    If( Length(lst)=0 Or range=0, {},
        Concat({First(lst)}, Take(Rest(lst), range-1)));

Rule("Take", 2, 2, range < 0)
    Drop( lst, Length(lst) + range );

%/mathpiper



%mathpiper_docs,name="Take",categories="User Functions;Lists (Operations)"
*CMD Take --- take a sublist from a list (dropping the rest)
*STD
*CALL
	Take(list, n)
	Take(list, -n)
	Take(list, {m,n})

*PARMS

{list} -- list to act on

{n}, {m} -- positive integers describing the entries to take

*DESC

This command takes a sublist of "list", drops the rest, and returns
the selected sublist. The first calling sequence selects the first
"n" entries in "list". The second form takes the last "n"
entries. The last invocation selects the sublist beginning with entry
number "m" and ending with the "n"-th entry.

*E.G.

In> lst := {a,b,c,d,e,f,g};
Result: {a,b,c,d,e,f,g};
In> Take(lst, 2);
Result: {a,b};
In> Take(lst, -3);
Result: {e,f,g};
In> Take(lst, {2,4});
Result: {b,c,d};

*SEE Drop, Select, Remove
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FuncListArith.mpw0000644000175000017500000000336111523200452027663 0ustar  giovannigiovanni%mathpiper,def="FuncListArith"

/* FuncListArith() is defined to only look at arithmetic operations +, -, *, /.  */

FuncListArith(expr) := FuncList(expr, {ToAtom("+"), ToAtom("-"), *, /});

HoldArgumentNumber("FuncListArith", 1, 1);

%/mathpiper



%mathpiper_docs,name="FuncListArith",categories="User Functions;Lists (Operations)"
*CMD FuncList --- list of functions used in an expression
*CMD FuncListArith --- list of functions used in an expression
*CMD FuncListSome --- list of functions used in an expression
*STD
*CALL
	FuncList(expr)
	FuncListArith(expr)
	FuncListSome(expr, list)

*PARMS

{expr} -- an expression

{list} -- list of function atoms to be considered "transparent"

*DESC

The command {FuncList(expr)} returns a list of all function atoms that appear
in the expression {expr}. The expression is recursively traversed.

The command {FuncListSome(expr, list)} does the same, except it only looks at arguments of a given {list} of functions. All other functions become "opaque" (as if they do not contain any other functions).
For example, {FuncListSome(a + Sin(b-c))} will see that the expression has a "{-}" operation and return {{+,Sin,-}}, but {FuncListSome(a + Sin(b-c), {+})} will not look at arguments of {Sin()} and will return {{+,Sin}}.

{FuncListArith} is defined through {FuncListSome} to look only at arithmetic operations {+}, {-}, {*}, {/}.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G. notest

In> FuncList(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos,/,Ln};
In> FuncListArith(x+y*Cos(Ln(x)/x))
Result: {+,*,Cos};
In> FuncListSome({a+b*2,c/d},{List})
Result: {List,+,/};

*SEE VarList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/SmallSort.mpw0000644000175000017500000000213711316274015027072 0ustar  giovannigiovanni%mathpiper,def="SmallSort"

/// fast in-place sorting of a list (or array!)
/// SmallSort sorts up to 3 elements, HeapSort sorts 4 and more elements
SmallSort(_list, _first, _last, _compare) _ (last=first) <-- list;
SmallSort(_list, _first, _last, _compare) _ (last=first+1) <--
[
	Local(temp);
	temp := list[first];
	If(
		Apply(compare,{temp,list[last]}),
		list,
		[
			list[first] := list[last];
			list[last] := temp;
		]	//Swap(list, first, last)
	);
	list;
];
SmallSort(_list, _first, _last, _compare) _ (last=first+2) <--
[
	Local(temp);
	temp := list[first];
	If(
		Apply(compare,{list[first+1],temp}),
		[
			list[first] := list[first+1];
			list[first+1] := temp;
		]	//Swap(list, first, first+1)	// x>y, z
	);
	// xx 1, 2, 3
			list[last] := list[first+1];
			list[first+1] := list[first];
			list[first] := temp;
		]
	);
	list;
];

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/BSearch.mpw0000644000175000017500000000035111331203122026441 0ustar  giovannigiovanni%mathpiper,def="BSearch"

LocalSymbols(max,f,result)
[
  BSearch(max,f)  :=
  [
    Local(result);
    Bind(result, FindIsq(max,f));
    If(Apply(f,{result})!=0,Bind(result,-1));
    result;
  ];
];
UnFence("BSearch",2);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Remove.mpw0000644000175000017500000000124311522212340026374 0ustar  giovannigiovanni%mathpiper,def="Remove"

Remove(list, expression) :=
[
   Local(result);
   Bind(result,{});
   ForEach(item,list)
   If(item != expression, DestructiveAppend(result,item));
   result;
];

%/mathpiper



%mathpiper_docs,name="Remove",categories="User Functions;Lists (Operations)"
*CMD Remove --- remove all occurrences of an expression from a list
*STD
*CALL
	Remove(list, expr)

*PARMS

{list} -- list to act on

{expr} -- expression to look for in "list"

*DESC

This command removes all elements that match a given expression from a given list and returns the resulting list.

*E.G.
In> Remove({a,b,a,b,c,a,c},a)
Result> {b,b,c,c}

*SEE RemoveDuplicates

%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Partition.mpw0000644000175000017500000000213611523200452027114 0ustar  giovannigiovanni%mathpiper,def="Partition"

/* ���� Partition ���� */

/* Partition( list, n ) partitions 'list' into non-overlapping sublists of length n */

Partition(lst, len):=
	If( Length(lst) < len Or len = 0, {},
        	Concat( {Take(lst,len)}, Partition(Drop(lst,len), len) ));

%/mathpiper



%mathpiper_docs,name="Partition",categories="User Functions;Lists (Operations)"
*CMD Partition --- partition a list in sublists of equal length
*STD
*CALL
	Partition(list, n)

*PARMS

{list} -- list to partition

{n} -- length of partitions

*DESC

This command partitions "list" into non-overlapping sublists of
length "n" and returns a list of these sublists. The first "n"
entries in "list" form the first partition, the entries from
position "n+1" up to "2n" form the second partition, and so on. If
"n" does not divide the length of "list", the remaining entries
will be thrown away. If "n" equals zero, an empty list is
returned.

*E.G.

In> Partition({a,b,c,d,e,f,}, 2);
Result: {{a,b},{c,d},{e,f}};
In> Partition(1 .. 11, 3);
Result: {{1,2,3},{4,5,6},{7,8,9}};

*SEE Take, PermutationsList
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Union.mpw0000644000175000017500000000133711523200452026235 0ustar  giovannigiovanni%mathpiper,def="Union"

Function("Union",{list1,list2})
[
  RemoveDuplicates(Concat(list1,list2));
];

%/mathpiper



%mathpiper_docs,name="Union",categories="User Functions;Lists (Operations)"
*CMD Union --- return the union of two lists
*STD
*CALL
	Union(l1, l2)

*PARMS

{l1}, {l2} -- two lists

*DESC

The union of the lists "l1" and "l2" is determined and
returned. The union contains all elements that occur in one or both of
the lists. In the resulting list, any element will occur only once.

*E.G.

In> Union({a,b,c}, {b,c,d});
Result: {a,b,c,d};
In> Union({a,e,i,o,u}, {f,o,u,r,t,e,e,n});
Result: {a,e,i,o,u,f,r,t,n};
In> Union({1,2,2,3,3,3}, {2,2,3,3,4,4});
Result: {1,2,3,4};

*SEE Intersection, Difference
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/Pop.mpw0000644000175000017500000000174411523200452025705 0ustar  giovannigiovanni%mathpiper,def="Pop"

Function("Pop",{stack,index})
[
  Local(result);
  result:=stack[index];
  DestructiveDelete(stack,index);
  result;
];

%/mathpiper



%mathpiper_docs,name="Pop",categories="User Functions;Lists (Operations)"
*CMD Pop --- remove an element from a stack
*STD
*CALL
	Pop(stack, n)

*PARMS

{stack} -- a list (which serves as the stack container)

{n} -- index of the element to remove

*DESC

This is part of a simple implementation of a stack, internally
represented as a list. This command removes the element with index
"n" from the stack and returns this element. The top of the stack is
represented by the index 1. Invalid indices, for example indices
greater than the number of element on the stack, lead to an error.

*E.G.

In> stack := {};
Result: {};
In> Push(stack, x);
Result: {x};
In> Push(stack, x2);
Result: {x2,x};
In> Push(stack, x3);
Result: {x3,x2,x};
In> Pop(stack, 2);
Result: x2;
In> stack;
Result: {x3,x};

*SEE Push, PopFront, PopBack
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/FindIsq.mpw0000644000175000017500000000075111331203122026473 0ustar  giovannigiovanni%mathpiper,def="FindIsq"

LocalSymbols(max,f,low,high,mid,current)
[
FindIsq(max,f)  :=
[
  Local(low,high,mid,current);
  low:=1;
  high:=max+1;
  Bind(mid,((high+low)>>1));
  While(high>low And mid>1)
  [
    Bind(mid,((high+low)>>1));
    Bind(current,Apply(f,{mid}));
//Echo({low,high,current});
    If(current = 0,
       high:=low-1,
       If(current > 0,
          Bind(high,mid),
          Bind(low,mid+1)
          )
       );
  ];
  mid;
];
];
UnFence("FindIsq",2);

%/mathpipermathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/BubbleSort.mpw0000644000175000017500000000301211342344550027207 0ustar  giovannigiovanni%mathpiper,def="BubbleSort"

Function("BubbleSort",{list,compare})
[
  Local(i,j,length,left,right);

  list:=FlatCopy(list);
  length:=Length(list);

  For (j:=length,j>1,j--)
  [
    For(i:=1,i BubbleSort({4,7,23,53,-2,1}, ">")
Result: {53,23,7,4,1,-2}

In> BubbleSort({3,5,2},Lambda({x,y},x stack := {};
Result: {};
In> Push(stack, x);
Result: {x};
In> Push(stack, x2);
Result: {x2,x};
In> Push(stack, x3);
Result: {x3,x2,x};
In> PopFront(stack);
Result: x3;
In> stack;
Result: {x2,x};

*SEE Push, Pop, PopBack
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/scripts4/lists/VarListSome.mpw0000644000175000017500000000501711523200452027354 0ustar  giovannigiovanni%mathpiper,def="VarListSome"

/// VarListSome is just like FuncList(x,y)

10 # VarListSome({}, _look'list) <-- {};
// an atom should be a variable to qualify
10 # VarListSome(expr_IsVariable, _look'list) <-- {expr};
15 # VarListSome(expr_IsAtom, _look'list) <-- {};
// a function not in the looking list - return it whole
20 # VarListSome(expr_IsFunction, look'list_IsList)_(Not Contains(look'list, ToAtom(Type(expr)))) <-- {expr};
// a function in the looking list - traverse its arguments
30 # VarListSome(expr_IsFunction, look'list_IsList) <--
RemoveDuplicates(
		[	// obtain a list of functions, considering only functions in look'list
			Local(item, result);
			result := {};
			ForEach(item, expr) result := Concat(result, VarListSome(item, look'list));
			result;
		]
);

%/mathpiper



%mathpiper_docs,name="VarListSome",categories="User Functions;Lists (Operations)"
*CMD VarList --- list of variables appearing in an expression
*CMD VarListArith --- list of variables appearing in an expression
*CMD VarListSome --- list of variables appearing in an expression
*STD
*CALL
	VarList(expr)
	VarListArith(expr)
	VarListSome(expr, list)

*PARMS

{expr} -- an expression

{list} -- a list of function atoms

*DESC

The command {VarList(expr)} returns a list of all variables that appear in the
expression {expr}. The expression is traversed recursively.

The command {VarListSome} looks only at arguments of functions in the {list}. All other functions are considered "opaque" (as if they do not contain any variables) and their arguments are not checked.
For example, {VarListSome(a + Sin(b-c))} will return {{a, b, c}}, but {VarListSome(a*Sin(b-c), {*})} will not look at arguments of {Sin()} and will return {{a,Sin(b-c)}}. Here {Sin(b-c)} is considered a "variable" because the function {Sin} does not belong to {list}.


The command {VarListArith} returns a list of all variables that appear
arithmetically in the expression {expr}. This is implemented through
{VarListSome} by restricting to the arithmetic functions {+}, {-}, {*}, {/}.
Arguments of other functions are not checked.

Note that since the operators "{+}" and "{-}" are prefix as well as infix operators, it is currently required to use {ToAtom("+")} to obtain the unevaluated atom "{+}".

*E.G.

In> VarList(Sin(x))
Result: {x};
In> VarList(x+a*y)
Result: {x,a,y};
In> VarListSome(x+a*y, {ToAtom("+")})
Result: {x,a*y};
In> VarListArith(x+y*Cos(Ln(x)/x))
Result: {x,y,Cos(Ln(x)/x)}
In> VarListArith(x+a*y^2-1)
Result: {x,a,y^2};

*SEE IsFreeOf, IsVariable, FuncList, HasExpr, HasFunc
%/mathpiper_docsmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/0000755000175000017500000000000011722677352023331 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/ui/0000755000175000017500000000000011722677352023746 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/ui/gui/0000755000175000017500000000000011722677352024532 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/ui/gui/InputPane.java0000644000175000017500000007075711546225657027321 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.ui.gui;

//
// InputPane.java                           Copyright A C Norman, 2000
//
//
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

import java.awt.Color;
import java.awt.Dimension;
import java.awt.Event;
import java.awt.Font;
import java.awt.FontMetrics;
import java.awt.datatransfer.Clipboard;
import java.awt.datatransfer.DataFlavor;
import java.awt.datatransfer.StringSelection;
import java.awt.datatransfer.Transferable;
import java.awt.event.ActionEvent;
import java.awt.event.KeyEvent;
import java.util.HashMap;
import java.util.Vector;
import javax.swing.text.AttributeSet;
import javax.swing.AbstractAction;
import javax.swing.Action;
import javax.swing.JTextPane;
import javax.swing.KeyStroke;
import javax.swing.SwingUtilities;
import javax.swing.text.BadLocationException;
import javax.swing.text.DefaultCaret;
import javax.swing.text.Element;
import javax.swing.text.Keymap;
import javax.swing.text.SimpleAttributeSet;
import javax.swing.text.StyleConstants;
import javax.swing.text.StyledDocument;
import javax.swing.text.StyledEditorKit;
import org.mathpiper.mpreduce.functions.builtin.Fns;





class InputPane extends JTextPane
{
// This extends a JTextPane since that lets me hook onto all the
// actions and general facilities that that provides me with. But what
// I first do here is to get myself hooks onto all those existing actions
// and then install a new keymap that directs most things to my own set of
// actions. During development these will just invoke the one that I had
// inherited, often printing a message so I can verify what is going on.
// But eventually they implement the behaviour that I really want, much of
// which is described in the file CWin.java

StyledDocument doc;

// A InputPane can be in one of four states.

int state = OUTPUTMODE;

static final int INPUTMODE   = 0;
static final int OUTPUTMODE  = 1;
static final int PAGEWAIT    = 2;
static final int INTERRUPTED = 3;

static final int redColor    = 0x00ff0040;   // slight purple tinge
static final int yellowColor = 0x00ffffc0;   // rather pale yellow
static final int blueColor   = 0x000000c0;   // darkish blue
static final int greenColor  = 0x00008040;   // darkish green
static final int blackColor  = 0x00000040;   // very dark blue

SimpleAttributeSet redText;
SimpleAttributeSet yellowText;
SimpleAttributeSet blueText;
SimpleAttributeSet greenText;
SimpleAttributeSet blackText;

String monospacedFontName = "MonoSpaced";
String fontName = "Serif";
int fontSize = 16;
int fontWeight = Font.PLAIN;
Font fixedFont, font, smallFont, tinyFont;
Font italicFont, smallItalicFont, tinyItalicFont;
FontMetrics metrics;

DefaultCaret caret;

public boolean getScrollableTracksViewportWidth()
{
//  System.out.println("check width option");
    return true; // (doc.getLength() == 0);
}

class ToScreen implements Runnable
{
    String b;

    ToScreen(String s)
    {   b = s;
    }
    
    public void run()
    {
        try
	{   doc.insertString(doc.getLength(), b, null);
	    caret.setDot(doc.getLength());
	}
	catch (BadLocationException e)
	{}
    }
}

// toScreen is called from other threads - I must protect Swing against 
// that!

void toScreen(String b)
{
    SwingUtilities.invokeLater(new ToScreen(b));
}

int afterPrompt = 0;


void showPrompt()
{
    try
    {   doc.insertString(doc.getLength(), 
            (Fns.prompt==null ? "> " : Fns.prompt),
            redText);
        afterPrompt = doc.getLength();
        caret.setDot(afterPrompt);
	scrollRectToVisible(caret);
    }
    catch (BadLocationException e)
    {}
}

Action [] pendingActions = new Action[10];
ActionEvent [] pendingEvents = new ActionEvent[10];
int pendingIn = 0, pendingOut = 0;

void deferAction(Action a, ActionEvent e)
{
    int l = pendingActions.length;
    pendingActions[pendingIn] = a;
    pendingEvents[pendingIn++] = e;
    if (pendingIn == l) pendingIn = 0;
    if (pendingIn == pendingOut) // buffer now full
    {   Action [] w = new Action[2*l];
        ActionEvent [] w1 = new ActionEvent[2*l];
        pendingIn = 0;
        for (int i=pendingOut; i CUT
        KeyStroke.getKeyStroke(KeyEvent.VK_X, Event.CTRL_MASK),
        cut);
    map.addActionForKeyStroke(        // ^V => PASTE
        KeyStroke.getKeyStroke(KeyEvent.VK_V, Event.CTRL_MASK),
        paste);
    map.addActionForKeyStroke(        // ^C => COPY
        KeyStroke.getKeyStroke(KeyEvent.VK_C, Event.CTRL_MASK),
        copy);
    map.addActionForKeyStroke(        // backspace => deletePrev
        KeyStroke.getKeyStroke(KeyEvent.VK_BACK_SPACE, 0),
        deletePrevChar);
    map.addActionForKeyStroke(        // delete => deleteNext
        KeyStroke.getKeyStroke(KeyEvent.VK_DELETE, 0),
        deleteNextChar);
    map.addActionForKeyStroke(        // enter => accept the line
        KeyStroke.getKeyStroke(KeyEvent.VK_ENTER, 0),
        insertBreak);
    map.addActionForKeyStroke(        // tab => tab
        KeyStroke.getKeyStroke(KeyEvent.VK_TAB, 0),
        insertTab);
// The default actions for the up and down keys are
//     up/down          move up and down one line
//     shift+up/down    ditto but extending a selection
//     ctrl+up/down     up & down one paragraph
//     ctrl+shift       select up and sown by the paragraph
// I modify this so that ctrl+up/down gives a behaviour rather like
// that of "doskey" or the command history scheme present in some
// Unix shells. It replaces the whole of the current input line
// with one of the previous input lines (which I therefore need to
// store away)
    map.addActionForKeyStroke(        // ctrl-UP
        KeyStroke.getKeyStroke(KeyEvent.VK_UP, Event.CTRL_MASK),
        historyUp);
    map.addActionForKeyStroke(        // ctrl-DOWN
        KeyStroke.getKeyStroke(KeyEvent.VK_DOWN, Event.CTRL_MASK),
        historyDown);
    setKeymap(map);

    requestFocus();
    replaceSelection("\n" +
//                   getPreferredScrollableViewportSize() + "\n" +
                     getBounds() + "\n" +
                     getWidth() + "\n"
                     );


}

void guessFont()
{
    fontSize = 16;
    fontWeight = Font.PLAIN;
}

void setupFonts(int size, int weight)
{
    fontSize = size;
    fontWeight = weight;
// I will prepare seven fonts. The first is a fixed pitch one used for
// simple text output. The remaining seven (and I may decide later on that
// I need yet more) are Roman & Italic styles in three sizes: the intent is
// that they are for body, subscript and sub-subscripts.
    fixedFont = new Font(monospacedFontName, fontWeight, fontSize);
    setFont(fixedFont);
    metrics = getFontMetrics(fixedFont);
// Now the others... I am somewhat uncertain about the scaling
// rules that I should apply here, but I am confident that if the
// main font is really tiny already I should be cautious about
// reducing too abruptly. Tune this for the best visual effect!
    font      = new Font(fontName, fontWeight, fontSize);
    italicFont = new Font(fontName, fontWeight+Font.ITALIC, fontSize);
    int smallSize = (fontSize <= 10) ? fontSize-1 :
                    (fontSize <= 14) ? fontSize-2 :
                    ((7*fontSize+9)/10);
    smallFont = new Font(fontName, fontWeight, smallSize);
    smallItalicFont = new Font(fontName, fontWeight+Font.ITALIC, smallSize);
    int tinySize = (smallSize <= 10) ? smallSize-1 :
                    (smallSize <= 14) ? smallSize-2 :
                    ((7*smallSize+9)/10);
    tinyFont  = new Font(fontName, fontWeight, tinySize);
    tinyItalicFont  = new Font(fontName, fontWeight+Font.ITALIC, tinySize);
}



// I want to arrange that input up to and including the most
// recent prompt string is read-only. To achieve this I arrange
// to reset dot and mark to be beyond there whenever an interesting
// event is triggered. I allow them to roam so I can COPY from earlier
// material.

int adjustSelection()
{
    int dot = caret.getDot();
    int mark = caret.getMark();
    int x = afterPrompt;
    if (dot < afterPrompt)
    {   if (mark < afterPrompt)
        {   caret.setDot(afterPrompt);
            dot = mark = afterPrompt;
        }
        else
        {   caret.setDot(mark);
            caret.moveDot(afterPrompt);
            dot = afterPrompt;
        }
    }
    else if (mark < afterPrompt)
    {   caret.setDot(afterPrompt);
        caret.moveDot(dot);
        mark = afterPrompt;
    }
    if (mark < dot) return mark;
    else return dot;
}

String clipboardSubstitute = null;

class CopyAction extends AbstractAction
{
    CopyAction()
    {   super(StyledEditorKit.copyAction);
    }

    public void actionPerformed(ActionEvent e)
    {
// I possibly want to customise this to transfer some style information
// to the clipboard as well as plain text. Eg I probably want to do special
// things with prompt strings.  But also note that I want COPY (and so also
// CUT) to be executed instantly and not deferred waiting for input. Actually
// that means that CUT will not do much cutting in such circumstances.
//
        int mark = caret.getMark();
        int dot = caret.getDot();
        if (mark == dot) return;
        else if (mark > dot)
        {   int w = mark;
            mark = dot;
            dot = w;
        }
// now (mark < dot) defines the region of my selection
            StringBuffer s = new StringBuffer();
// This really feels pretty gross. I look at each character and discard it
// if it is the colour that I use for prompts! Doing it one character at a
// time makes COPY a slow process, but I expect it only gets used on smallish
// selections!  The reasoning behind this is that I may want to re-input
// previous segments of stuff, and if the prompts get picked up by "COPY"
// and put back by "PASTE" that will mess me up.
//
// Maybe a yet better variation will be to map things so that the
// text on the clipboard reads
//       on screen         on clipboard
//          \                 \\ 
//          {                 \{
//          }                 \}
//          prompt            {\p prompt}
// where this leaves capability for other bits of clipboard syntax
// involving {} to denote other effects I may later introduce.
//
// Anyway that is not yet done and needs more thought!
        for (int i=mark; i= 0x100 ||
             (e.getModifiers() & 
              (Event.CTRL_MASK|Event.ALT_MASK|Event.META_MASK)) != 0) return;
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
// NB the "dot" returned here is the lower of dot/mark and so it is the
// position to insert after I have done a replaceSelection("");
        int dot = adjustSelection();
// I replace the selection with an empty string and THEN insert my
// new character because that lets me control the attributes (in my case
// colour) of inserted text.
        replaceSelection("");
        try
        {   doc.insertString(dot, e.getActionCommand(), blueText);
            caret.setDot(dot+1);
        }
        catch (BadLocationException e1)
        {}
    }
}

int adjustForDelete(boolean left)
{
// When I hit either delete-forwards or delete-backwards I will behave
// as follows:
//     If either dot or mark line within the current input line
//     I shrink the selection to be the intersection of the current one
//     and the input line. If both dot and mark are outside the
//     current line then delete-forwards moves them to its start and
//     delete backwards moves them both to its end.
//     If there is a non-empty selection left I delete that material and
//     that is all I do (whichever direction the delete was in)
//     Finally I have a caret location within the input line and if
//     there is a character to the relevant size of it I delete that.
    int dot = caret.getDot();
    int mark = caret.getMark();
    int x = afterPrompt;
    if (dot < afterPrompt)
    {   if (mark < afterPrompt)
        {   if (left)
            {   dot = mark = doc.getLength();
                caret.setDot(dot);
            }
            else
            {   dot = mark = afterPrompt;
                caret.setDot(afterPrompt);
            }
        }
        else
        {   caret.setDot(mark);
            caret.moveDot(afterPrompt);
            dot = afterPrompt;
        }
    }
    else if (mark < afterPrompt)
    {   caret.setDot(afterPrompt);
        caret.moveDot(dot);
        mark = afterPrompt;
    }
// now the selection is fully after the prompt location
    if (mark == dot) return dot;
    replaceSelection("");
    return -1;
}


class DeleteNextCharAction extends AbstractAction
{
    DeleteNextCharAction()
    {   super(StyledEditorKit.deleteNextCharAction);
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        int dot = adjustForDelete(false);
        if (dot < 0) return; // done
        if (dot == doc.getLength()) return;
        caret.setDot(dot);
        caret.moveDot(dot+1);
        replaceSelection("");
    }
}

class DeletePrevCharAction extends AbstractAction
{
    DeletePrevCharAction()
    {   super(StyledEditorKit.deletePrevCharAction);
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        int dot = adjustForDelete(true);
        if (dot <= afterPrompt) return;
        caret.setDot(dot);
        caret.moveDot(dot-1);
        replaceSelection("");
    }
}

class InsertBreakAction extends AbstractAction
{
    InsertBreakAction()
    {   super(StyledEditorKit.insertBreakAction);
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        int l = doc.getLength();
        try
        {   String s = getText(afterPrompt, l - afterPrompt);
            history.add(s);  // remember it!
            historyIndex = history.size();
// now I will put a newline on the screen.
            caret.setDot(l); // so it tends to remain at the end...
            doc.insertString(l, "\n", blueText);
// I should do the setInputData LAST here since it flips my global
// state from INPUTMODE to OUTPUTMODE and also lets the client thread
// have my data and potentially start generating new output based on it.
// Actually I might worry a bit about what happens if another mouse or
// keyboard event is triggered while I am busy around here...
            setInputData(s);
	}
        catch (BadLocationException e1)
        {}
    }
}

// The next action is ONLY used as a pending action, so it can only
// ever be triggered when I am in input mode.

class InsertPastedAction extends AbstractAction
{
    InsertPastedAction()
    {
        super("insert-pasted-text");
    }

    public void actionPerformed(ActionEvent e)
    {
        int dot = adjustSelection();
        replaceSelection("");
        try
        {   String s = e.getActionCommand();
            doc.insertString(dot, s, blueText);
            caret.setDot(dot+s.length());
        }
        catch (BadLocationException e1)
        {}
        if (e.getModifiers() != 0) return;
        insertBreak.actionPerformed(e);
    }
}

class InsertContentAction extends AbstractAction
{
    InsertContentAction()
    {   super(StyledEditorKit.insertContentAction);
    }

    public void actionPerformed(ActionEvent e)
    {
        System.out.println("insertContent " +
                           safe(e.getActionCommand()) + " " + 
                           safe(e.paramString()));
//      oldinsertContent.actionPerformed(e);
    }
}

class InsertTabAction extends AbstractAction
{
    InsertTabAction()
    {   super(StyledEditorKit.insertTabAction);
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        int dot = adjustSelection();
        replaceSelection("");
        try
        {   do
            {   doc.insertString(dot++, " ", blueText);
            }
            while ((dot-afterPrompt)%8 != 0);
        }
        catch (BadLocationException e1)
        {}
    }
}

class PasteAction extends AbstractAction
{
    PasteAction()
    {   super(StyledEditorKit.pasteAction);
    }

    public void actionPerformed(ActionEvent e)
    {
// Actually if I go PASTE when not in input mode I think I still need to
// grab the stuff off the clipboard instantly. It is inserting it into
// the buffer that gets delayed.
        Clipboard cb;
        Transferable tr;
        String s = null;
        try
        {
            cb = getToolkit().getSystemClipboard();
            tr = cb.getContents(this);
            s = (String)tr.getTransferData(DataFlavor.stringFlavor);
        }
        catch (Exception e1)
        {   s = clipboardSubstitute;
        }
        if (s == null || s.length() == 0) return; // No more to do!
        int p = 0, q;
        ActionEvent e2;
        String s1;
        while ((q = s.indexOf('\n', p)) >= 0)
        {   s1 = s.substring(p, q); // up to but not including newline
            e2 = new ActionEvent(this, 0, s1);
            deferAction(insertPasted, e2);
            p = q+1;
        }
        s1 = s.substring(p, s.length()); 
        if (s1.length() != 0)
        {   e2 = new ActionEvent(this, 0, s1, 1); // 1 marks "no newline"!
            deferAction(insertPasted, e2);
        }
        if (state != INPUTMODE) return;
        performPendedActions();
    }
}

class HistoryUpAction extends AbstractAction
{
    HistoryUpAction()
    {   super("history-up");
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        if (historyIndex > 0)
        {   historyIndex--;
            String s = "";
            try
            {   s = (String)history.get(historyIndex);
            }
            catch (ArrayIndexOutOfBoundsException e1)
            {};
            caret.setDot(afterPrompt);
            caret.moveDot(doc.getLength());
            replaceSelection("");
            try
            {   doc.insertString(afterPrompt, s, blueText);
                caret.setDot(doc.getLength());
            }
            catch (BadLocationException e1)
            {}
        }
    }
}

class HistoryDownAction extends AbstractAction
{
    HistoryDownAction()
    {   super("history-down");
    }

    public void actionPerformed(ActionEvent e)
    {
        if (state != INPUTMODE)
        {   deferAction(this, e);
            return;
        }
        int n = history.size();
        if (historyIndex < n)
        {   historyIndex++;
            String s = "";
            try
            {   if (historyIndex < n)
                    s = (String)history.get(historyIndex);
            }
            catch (ArrayIndexOutOfBoundsException e1)
            {};
            caret.setDot(afterPrompt);
            caret.moveDot(doc.getLength());
            replaceSelection("");
            try
            {   doc.insertString(afterPrompt, s, blueText);
                caret.setDot(doc.getLength());
            }
            catch (BadLocationException e1)
            {}
        }
    }
}


String safe(String a)
{
    if (a == null) return "";
    String r = "";
    for (int i=0; i
// deleteNextChar
//       If there is no active region queue this until there is one.
//       If dot is outside the active line move it to save before attempting
//       the delection. If dot is at the end of the document beep and do
//       nothing.
// deletePrevChar
//       If there is no active region queue this until there is one.
//       If dot is outside the active line move it to save before attempting
//       the delection. If dot is at the start of the active line beep
//       and do nothing.
// down (and also up)
//       Normal: move dot down/up one line (keepin in some column if possible)
//       Shift:  move so to create or extend a selection
//       Ctrl:   move dot down/up one paragraph
//       Shift/Ctrl: combine two effects
//       ALT:    MAYBE...
//           If no active region then queue up.
//           activate a doskey-like record of previous input lines
// [keyboard combinations to do with the arrow keys already seem pretty
//  heavy. Fitting doskey-like stuff in too seems slightly messy. I do not
//  know what is best here]
// left (and also right)
//       Normal: move dot one character
//       Shift:  move horizontally so as to create/extend a selection
//       Ctrl:   move to start of previous/next word
//       home/end keys move to start and end of current line
// 
//       if new mark will be outside the active region but old was within
//       then set save.
//
// To allow discussion of other key sequences, eg based on ALT or
// the controll key (and possibly with additional menus in support
// that I have not listed before, I will include a psuedo action
// that is intended to cover both keyboard shortcuts implemented
// within Java's framework and special keys that I will define for
// myself:
//
// specialKeySequencePressed
//       Maybe ALT-up belongs here, since it is not even related to
//       the things that Java's default editorKit does.
//
// In addition I will want to take an action when the EDIT menu is
// about to be displayed:
//
// showEditMenu
//       This is to remind me that I want CUT disabled when the selection
//       is empty or totally outside the active region
//
// and I should consider some other menu items
//
// fileRead
//       for CSL I make this insert the text  as new
//       input. This is a jolly odd thing to do!
// fileSaveAs
// fileSaveSelection
// fileSaveExtras
//       PSL has special menu items for copying (etc) parts of the
//       text that are not just simple text.
// fileToFile
//       by which I mean spool/dripple or whatever you want to call it
// filePrint
// fileOPrintSelection
// fileExit
// editCut
//       disabled if no part of the selection is in the active region
// editCutCut
//       Maybe I should let people discard some of the historical output
//       if they REALLY want to.
// editCopy
// editPaste
// editSelectAll
// editClear
// editTop
// editBottom
//
// breakInterrupt
//       discards all queued up input events. If there is an active
//       area clears it and sends an INTERRUPT response to the client
//       application. If page mode is on resets so that another full page
//       can be displayed before a further pause. 
//       If no active input region then sets flag so that subsequent
//       printText requests will be ignored and sends an asynchronous
//       break request to the application. Restones sanity on getting
//       a response.
//
// the other menus are fairly decoupled from the display of text so
// I will not discuss them here.
//
// Yet further events reflect interaction with the program that this
// window is serving:
//
// requestLine(promptString)
//       Insert print test as start of a new paragraph. Establish new
//       active region, putting save in it. If there are queued input
//       events they are dispatched until one of them is an insertBreak.
// acceptLine
//       as mentioned under insertBreak. and breakInterrupt
// printText
//       This should not happen while there is an active region. It
//       just appends text to the end of the buffer. If page_mode has
//       been set then count lines and set a page break pause when
//       a screenful is there. This is released by any key-stroke.
//       Think a bit about users who re-size the screen while output is
//       being generated! Adjust window title while this delay is in
//       force, and also allow invisible buffer of at least a few more
//       lines of output to build up even while the screen is kept
//       stable.
// asynchronousBreak
//       sent to the client in nasty cases!
// breakACK
//       resonse from client to say that the break is acknowledged.
//
// printPicture
//       It MIGHT be that the program can "print" things other than text,
//       for instance graphical objects. Support for that sort of thing
//       is not considered here (yet). For REDUCE the idea of displays with
//       lots of fonts and general 2D layout may well be important!
//       Current THOUGHT
//          start2DOutput();
//          printText(...);   material sent in a format derived from
//                            TeX markup (since I want to display maths, and
//                            because REDUCE already contains an option to
//                            do this).
//          end2DOutput();
//
// Yet another issue is that the client program should be able to make
// calls that display (small amounts of) information on the title or
// menu bar (eg garbage collection or timing information). And the
// windowed front-end should buffer all output from the user (with great
// vigour to try to keep performance under control) but should flush the
// buffers before requesting input or 2 (say) second after the last
// screen update happened.
//
// For computer algebra the issue of 2D output is a very real one and the
// yet nastier issue of managing to COPY or CUT from it and get something
// that can be pasted in as input is hard enough for whole expressions (but
// one could have a protocol where the application always provided a
// re-inputable version as well as the display-friendly one) but gets
// worse if you want natural ways to allow mouse-drags to select
// semantically valid parts of a huge expression.
//
// With one earlier user-interface I had (CML) some user keystrokes could
// lead to displays that involved special symbols (in that case if you typed
// in "fn" you got a display of a Greek lambda, while 'a, 'b etc gave
// alpha, beta and so on. Then using the delete key has to repair things
// in a witty manner.



import java.awt.BorderLayout;
import java.awt.Container;
import java.awt.Font;
import java.awt.Insets;
import java.awt.event.ActionEvent;
import java.awt.event.ActionListener;
import java.awt.event.KeyEvent;
import java.awt.event.WindowAdapter;
import java.awt.event.WindowEvent;
import java.io.CharArrayWriter;
import java.io.InputStreamReader;
import java.io.PrintWriter;
import java.io.Reader;
import javax.swing.ButtonGroup;
import javax.swing.JApplet;
import javax.swing.JFileChooser;
import javax.swing.JFrame;
import javax.swing.JMenu;
import javax.swing.JMenuBar;
import javax.swing.JMenuItem;
import javax.swing.JRadioButtonMenuItem;
import javax.swing.JScrollPane;
import javax.swing.KeyStroke;
import javax.swing.Timer;
import org.mathpiper.mpreduce.Jlisp;

public class CWin extends JApplet
{

// This code should be launchable as either an applet or as
// an application. Note however that as of spring 2000 the use
// of Java 2 facilities means that web browsers will need a
// Java 1.2 plugin to be able to run this code, and that the HTML
// that launches the applet will have to dircet execution to that
// plugin. Furthermore in order that the file-system and clipboard
// can be accesses the applet will have to come from a signed
// source and suitable steps will have to be taken to grant it
// authority to perform these security-impinging actions.

public static boolean isApplet;
String [] args = new String [0];

public static void main(String [] args)
{
// If the command line includes an argument "-w" then I will remove
// that so it doe not get looked at again and start the system up as a simple
// application to run from the command line rather than in a window.
//
// The effect is that I can rin things in THREE ways:
//    (1) As an applet, ie using a browser of some form. In such cases
//        it is hard to pass (variable) parameters;
//    (2) As an application but one that pops up a window and then behaves
//        much like an applet EXCEPT that it does not suffer from security
//        limits as much and you can re-size the window;
//    (3) As a command line application via "java -jar  -w"
//        where the thing behaves as a traditional application.
//
    for (int i=0; i 

Display me instead if Java is not available.

 

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/showprofile.bat0000644000175000017500000000005211527641631026351 0ustar  giovannigiovannijava -jar PerfAnal.jar java.hprof.txt 

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/special/0000755000175000017500000000000011722677351024750 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/special/SpecialFunction.java0000644000175000017500000001072311555446662030707 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.special;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public abstract class SpecialFunction extends LispObject
{
    public String name;

    public abstract LispObject op(LispObject args) throws Exception;

    LispObject error(String s) throws Exception
    {
        return Jlisp.error(s);
    }

    public void iprint() throws ResourceException
    {
        String s = "#Special<" + name + ">";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }
    
    public void blankprint() throws ResourceException
    {
        String s = "#Special<" + name + ">";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    byte [] rep = name.getBytes("UTF8");
	    int length = rep.length;
	    if (length <= 0xff)
	    {   Jlisp.odump.write(X_SPECFN);
	        Jlisp.odump.write(length);
	    }
	    else throw new Exception("overlong name for a function");
	    for (int i=0; i 1) Jlisp.error("may only have one &rest arg", bvl);
        if (nopts < 0) nopts = 0;
        if (nrest < 0) nrest = 0;
        int total = nvars + nopts;
        if (nrest==0 && passed > total)
            Jlisp.error("too many args provided", bvl);
// Pad so optional args get nil as their values.
        for (int i=passed; i=total; i--)
                 r = new Cons(args[i], r);
            args[total++] = r;
        }
        LispObject [] save = new LispObject [total];
        nvars = 0;
        for (LispObject b1 = bvl; !b1.atom; b1 = b1.cdr)
        {   Symbol s = (Symbol)b1.car;
            if (s == Jlisp.lit[Lit.optional] ||
                s == Jlisp.lit[Lit.rest]) continue;
            save[nvars] = s.car/*value*/;
            s.car/*value*/ = args[nvars++];
        }
        LispObject r = Environment.nil;
        try
        {   while (!body.atom && Specfn.progEvent == Specfn.NONE)
            {   r = body.car.eval();
                body = body.cdr;
            }
        }
        finally
        {   nvars = 0;
            for (LispObject b1 = bvl; !b1.atom; b1 = b1.cdr)
            {   LispObject s = b1.car;
                if (s == Jlisp.lit[Lit.optional] ||
                    s == Jlisp.lit[Lit.rest]) continue;
                s.car/*value*/ = save[nvars++];
            }
        }
        return r;
    }

    public static String explodeToString(LispObject arg1) throws Exception
    {
        LispStream f = new LispOutputString();
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.printEscape);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return f.sb.toString();
    }
}

// end of Fns.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/builtin/MPReduceFunctions.java0000644000175000017500000000550611555446662033217 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.builtin;

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.LispObject;

/**************************************************************************
 * Copyright (C) 2011, Ted Kosan                                          *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/
public class MPReduceFunctions {

    public static boolean inEvaluationMode = true;
    
    public Object[][] builtins = {
        {"evaluatingset", new EvaluatingSetFn()},
        {"evaluatingclear", new EvaluatingClearFn()},};

    class EvaluatingSetFn extends BuiltinFunction {

        public LispObject op0() {
            inEvaluationMode = true;
            return Environment.nil;
        }

    }

    class EvaluatingClearFn extends BuiltinFunction {

        public LispObject op1(LispObject o) throws Exception{
            inEvaluationMode = false;
            return Environment.nil;
        }

    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/builtin/Fns3.java0000644000175000017500000025150511555446662030475 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.builtin;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//


// Fns3.java

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/
// Each built-in function is created wrapped in a class
// that is derived from BuiltinFunction.





import java.io.BufferedInputStream;
import java.io.BufferedOutputStream;
import java.io.BufferedReader;
import java.io.File;
import java.io.FileInputStream;
import java.io.FileNotFoundException;
import java.io.FileOutputStream;
import java.io.FileReader;
import java.io.IOException;
import java.math.BigInteger;
import java.util.HashMap;
import java.util.zip.GZIPInputStream;
import java.util.zip.GZIPOutputStream;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.functions.lisp.AutoLoad;
import org.mathpiper.mpreduce.functions.functionwithenvironment.ByteOpt;
import org.mathpiper.mpreduce.functions.functionwithenvironment.Bytecode;
import org.mathpiper.mpreduce.functions.lisp.CallAs;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.exceptions.EOFException;
import org.mathpiper.mpreduce.io.Fasl;
import org.mathpiper.mpreduce.functions.functionwithenvironment.FnWithEnv;
import org.mathpiper.mpreduce.functions.lisp.Interpreted;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.io.streams.LispDigester;
import org.mathpiper.mpreduce.datatypes.LispEqualHash;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;
import org.mathpiper.mpreduce.datatypes.LispHash;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.numbers.LispNumber;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.io.streams.LispOutputStream;
import org.mathpiper.mpreduce.numbers.LispSmallInteger;
import org.mathpiper.mpreduce.io.streams.LispStream;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.datatypes.LispVector;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.functions.lisp.Macro;
import org.mathpiper.mpreduce.exceptions.ProgEvent;
import org.mathpiper.mpreduce.exceptions.ResourceException;
import org.mathpiper.mpreduce.special.Specfn;
import org.mathpiper.mpreduce.symbols.Symbol;
import org.mathpiper.mpreduce.functions.lisp.TracedFunction;
import org.mathpiper.mpreduce.functions.lisp.Undefined;

public class Fns3
{
    public Object [][] builtins =
    {
        {"liter",                       new LiterFn()},
        {"load-module",                 new Load_moduleFn()},
        {"lposn",                       new LposnFn()},
        {"macro-function",              new Macro_functionFn()},
        {"macroexpand",                 new MacroexpandFn()},
        {"macroexpand-1",               new Macroexpand_1Fn()},
        {"make-bps",                    new Make_bpsFn()},
        {"make-function-stream",        new Make_function_streamFn()},
        {"make-global",                 new Make_globalFn()},
        {"make-native",                 new Make_nativeFn()},
        {"make-random-state",           new Make_random_stateFn()},
        {"make-simple-string",          new Make_simple_stringFn()},
        {"make-special",                new Make_specialFn()},
        {"map",                         new MapFn()},
        {"mapc",                        new MapcFn()},
        {"mapcan",                      new MapcanFn()},
        {"mapcar",                      new MapcarFn()},
        {"mapcon",                      new MapconFn()},
        {"maphash",                     new MaphashFn()},
        {"maplist",                     new MaplistFn()},
        {"mapstore",                    new MapstoreFn()},
        {"md5",                         new Md5Fn()},
        {"md60",                        new Md60Fn()},
        {"member",                      new MemberFn()},
        {"member**",                    new MemberStarStarFn()},
        {"memq",                        new MemqFn()},
        {"mkevect",                     new MkevectFn()},
        {"mkfvect32",                   new Mkfvect32Fn()},
        {"mkfvect64",                   new Mkfvect64Fn()},
        {"mkhash",                      new MkhashFn()},
        {"mkquote",                     new MkquoteFn()},
        {"mkvect",                      new MkvectFn()},
        {"mkvect16",                    new Mkvect16Fn()},
        {"mkvect32",                    new Mkvect32Fn()},
        {"mkvect8",                     new Mkvect8Fn()},
        {"mkxvect",                     new MkxvectFn()},
        {"modulep",                     new ModulepFn()},
        {"native-address",              new Native_addressFn()},
        {"native-getv",                 new Native_getvFn()},
        {"native-putv",                 new Native_putvFn()},
        {"native-type",                 new Native_typeFn()},
        {"nconc",                       new NconcFn()},
        {"ncons",                       new NconsFn()},
        {"neq",                         new NeqFn()},
        {"noisy-setq",                  new Noisy_setqFn()},
        {"not",                         new NotFn()},
        {"null",                        new NullFn()},
        {"oblist",                      new OblistFn()},
        {"oem-supervisor",              new Oem_supervisorFn()},
        {"open",                        new OpenFn()},
        {"internal-open",               new InternalOpenFn()},
        {"open-library",                new Open_libraryFn()},
        {"open-url",                    new Open_urlFn()},
        {"orderp",                      new OrderpFn()},
        {"ordp",                        new OrderpFn()}, // synonym
        {"output-library",              new Output_libraryFn()},
        {"pagelength",                  new PagelengthFn()},
        {"pair",                        new PairFn()},
        {"pairp",                       new PairpFn()},
        {"peekch",                      new PeekchFn()},
        {"pipe-open",                   new Pipe_openFn()},
        {"plist",                       new PlistFn()},
        {"posn",                        new PosnFn()},
        {"preserve",                    new PreserveFn()},
        {"restart-csl",                 new RestartFn()},
        {"saveobject",                  new SaveObjectFn()},
        {"restoreobject",               new RestoreObjectFn()},
        {"prin",                        new PrinFn()},
        {"prin1",                       new Prin1Fn()},
        {"prin2",                       new Prin2Fn()},
        {"prin2a",                      new Prin2aFn()},
        {"prinbinary",                  new PrinbinaryFn()},
        {"princ",                       new PrincFn()},
        {"princ-downcase",              new Princ_downcaseFn()},
        {"princ-upcase",                new Princ_upcaseFn()},
        {"prinhex",                     new PrinhexFn()},
        {"prinoctal",                   new PrinoctalFn()},
        {"print",                       new PrintFn()},
        {"printc",                      new PrintcFn()},
        {"printprompt",                 new PrintpromptFn()},
        {"prog1",                       new Prog1Fn()},
        {"prog2",                       new Prog2Fn()},
        {"progn",                       new PrognFn()},
        {"put",                         new PutFn()},
        {"puthash",                     new PuthashFn()},
        {"putv",                        new PutvFn()},
        {"putv-char",                   new Putv_charFn()},
        {"putv16",                      new Putv16Fn()},
        {"putv32",                      new Putv32Fn()},
        {"putv8",                       new Putv8Fn()},
        {"qcaar",                       new QcaarFn()},
        {"qcadr",                       new QcadrFn()},
        {"qcar",                        new QcarFn()},
        {"qcdar",                       new QcdarFn()},
        {"qcddr",                       new QcddrFn()},
        {"qcdr",                        new QcdrFn()},
        {"qgetv",                       new QgetvFn()},
        {"qputv",                       new QputvFn()},
        {"rassoc",                      new RassocFn()},
        {"rdf",                         new RdfFn()},
        {"rds",                         new RdsFn()},
        {"read",                        new ReadFn()},
        {"readch",                      new ReadchFn()},
        {"readline",                    new ReadlineFn()},
        {"reclaim",                     new ReclaimFn()},
        {"remd",                        new RemdFn()},
        {"remflag",                     new RemflagFn()},
        {"remhash",                     new RemhashFn()},
        {"remob",                       new RemobFn()},
        {"remprop",                     new RempropFn()},
        {"rename-file",                 new Rename_fileFn()},
        {"representation",              new RepresentationFn()},
        {"return",                      new ReturnFn()},
        {"reverse",                     new ReverseFn()},
        {"reversip",                    new ReversipFn()},
        {"nreverse",                    new ReversipFn()},
        {"rplaca",                      new RplacaFn()},
        {"rplacd",                      new RplacdFn()},
        {"rplacw",                      new RplacwFn()},
        {"rseek",                       new RseekFn()},
        {"rtell",                       new RtellFn()},
        {"sample",                      new SampleFn()},
        {"sassoc",                      new SassocFn()},
        {"schar",                       new ScharFn()},
        {"seprp",                       new SeprpFn()},
        {"set",                         new SetFn()},
        {"set-autoload",                new Set_autoloadFn()},
        {"set-help-file",               new Set_help_fileFn()},
        {"set-print-precision",         new Set_print_precisionFn()},
        {"setpchar",                    new SetpcharFn()},
        {"simple-string-p",             new Simple_string_pFn()},
        {"simple-vector-p",             new Simple_vector_pFn()},
        {"smemq",                       new SmemqFn()},
        {"spaces",                      new SpacesFn()},
        {"special-char",                new Special_charFn()},
        {"special-form-p",              new Special_form_pFn()},
        {"spool",                       new SpoolFn()},
        {"start-module",                new Start_moduleFn()},
        {"stop",                        new StopFn()},
        {"streamp",                     new StreampFn()},
        {"stringp",                     new StringpFn()},
        {"stub1",                       new Stub1Fn()},
        {"stub2",                       new Stub2Fn()},
        {"subla",                       new SublaFn()},
        {"sublis",                      new SublisFn()},
        {"subst",                       new SubstFn()},
        {"sxhash",                      new SxhashFn()},
        {"symbol-argcount",             new Symbol_argcountFn()},
        {"symbol-env",                  new Symbol_envFn()},
        {"symbol-fastgets",             new Symbol_fastgetsFn()},
        {"symbol-fn-cell",              new Symbol_fn_cellFn()},
        {"symbol-function",             new Symbol_functionFn()},
        {"symbol-make-fastget",         new Symbol_make_fastgetFn()},
        {"symbol-name",                 new Symbol_nameFn()},
        {"symbol-protect",              new Symbol_protectFn()},
        {"symbol-set-definition",       new Symbol_set_definitionFn()},
        {"symbol-set-env",              new Symbol_set_envFn()},
        {"symbol-set-native",           new Symbol_set_nativeFn()},
        {"symbol-value",                new Symbol_valueFn()},
        {"symbolp",                     new SymbolpFn()},
        {"symerr",                      new SymerrFn()},
        {"system",                      new SystemFn()},
        {"tagbody",                     new TagbodyFn()},
        {"terpri",                      new TerpriFn()},
        {"threevectorp",                new ThreevectorpFn()},
        {"throw",                       new ThrowFn()},
        {"time",                        new TimeFn()},
        {"tmpnam",                      new TmpnamFn()},
        {"trace",                       new TraceFn()},
        {"traceset",                    new TracesetFn()},
        {"traceset1",                   new Traceset1Fn()},
        {"ttab",                        new TtabFn()},
        {"tyo",                         new TyoFn()},
        {"undouble-execute",            new Undouble_executeFn()},
        {"unfluid",                     new UnfluidFn()},
        {"unglobal",                    new UnglobalFn()},
        {"union",                       new UnionFn()},
        {"unmake-global",               new Unmake_globalFn()},
        {"unmake-special",              new Unmake_specialFn()},
        {"unreadch",                    new UnreadchFn()},
        {"untrace",                     new UntraceFn()},
        {"untraceset",                  new UntracesetFn()},
        {"untraceset1",                 new Untraceset1Fn()},
        {"unwind-protect",              new Unwind_protectFn()},
        {"upbv",                        new UpbvFn()},
        {"user-homedir-pathname",       new User_homedir_pathnameFn()},
        {"vectorp",                     new VectorpFn()},
        {"verbos",                      new VerbosFn()},
        {"where-was-that",              new Where_was_thatFn()},
        {"window-heading",              new Window_headingFn()},
        {"startup-banner",              new Startup_bannerFn()},
        {"writable-libraryp",           new Writable_librarypFn()},
        {"write-help-module",           new Write_help_moduleFn()},
        {"write-module",                new Write_moduleFn()},
        {"wrs",                         new WrsFn()},
        {"xassoc",                      new XassocFn()},
        {"xcons",                       new XconsFn()},
        {"xdifference",                 new XdifferenceFn()},
        {"xtab",                        new XtabFn()},
        {"~tyi",                        new TyiFn()}
    };



class LiterFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (!(arg1 instanceof Symbol)) return Environment.nil;
        Symbol s = (Symbol)arg1;
        s.completeName();
        char ch = s.pname.charAt(0);
        if (Character.isLetter(ch)) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}


class Load_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return Fasl.loadModule(arg1);
    }
}

class LposnFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Macro_functionFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (!(arg1 instanceof Symbol)) return Environment.nil;
        LispFunction fn = ((Symbol)arg1).fn;
        if (fn instanceof Macro)
        {   return ((Macro)fn).body;
        }
        else return Environment.nil;
    }
}

class MacroexpandFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return op2(arg1, null);
    }
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        for (;;)
        {   if (arg1.atom) return arg1;
            if (!(arg1.car instanceof Symbol)) return arg1;
            Symbol f = (Symbol)arg1.car;
            LispFunction fn = f.fn;
            if (!(fn instanceof Macro)) return arg1;
// At last - here I have a macro that I can expand
            arg1 = fn.op1(arg1);
        }
    }
}

class Macroexpand_1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return op2(arg1, null);
    }
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1.atom) return arg1;
        if (!(arg1.car instanceof Symbol)) return arg1;
        Symbol f = (Symbol)arg1.car;
        LispFunction fn = f.fn;
        if (!(fn instanceof Macro)) return arg1;
// At last - here I have a macro that I can expand
        return fn.op1(arg1);
    }
}

class Make_bpsFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int n = ((LispSmallInteger)arg1).value;
        return new Bytecode(n);
    }
}

class Make_function_streamFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Make_globalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        Symbol s = (Symbol)arg1;
        Fns.put(s, Jlisp.lit[Lit.global], Jlisp.lispTrue);
        if (s.car/*value*/ == Jlisp.lit[Lit.undefined]) s.car/*value*/ = Environment.nil;
        return Environment.nil; 
    }
}

class Make_nativeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Make_random_stateFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Make_simple_stringFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int n = ((LispSmallInteger)arg1).value;
        char [] c = new char[n];
        for (int i=0; i");
        else return r;
    }
}

class PrinFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printEscape);
        return arg1;
    }
}

class Prin1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printEscape);
        return arg1;
    }
}

class Prin2Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(0);
        return arg1;
    }
}

class Prin2aFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.noLineBreak);
        return arg1;
    }
}

class PrinbinaryFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printBinary);
        return arg1;
    }
}

class PrincFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print();
        return arg1;
    }
}

class Princ_downcaseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printLower);
        return arg1;
    }
}

class Princ_upcaseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printUpper);
        return arg1;
    }
}

class PrinhexFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printHex);
        return arg1;
    }
}

class PrinoctalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printOctal);
        return arg1;
    }
}

class PrintFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print(LispObject.printEscape);
        Jlisp.println();
        return arg1;
    }
}

class PrintcFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        arg1.print();
        Jlisp.println();
        return arg1;
    }
}

class PrintpromptFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Prog1Fn extends BuiltinFunction
{
    public LispObject op0()
    {
        return Environment.nil;
    }
    public LispObject op1(LispObject arg1)
    {
        return arg1;
    }
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        return arg1;
    }
    public LispObject opn(LispObject [] args)
    {
        return args[0];
    }
}

class Prog2Fn extends BuiltinFunction
{
    public LispObject op0()
    {
         return Environment.nil;
    }
    public LispObject op1(LispObject arg1)
    {
         return Environment.nil;
    }
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        return arg2;
    }
    public LispObject opn(LispObject [] args)
    {
        return args[1];
    }
}

class PrognFn extends BuiltinFunction
{
    public LispObject op0()
    {
         return Environment.nil;
    }

    public LispObject op1(LispObject arg1)
    {
        return arg1;
    }
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        return arg2;
    }
    public LispObject opn(LispObject [] args)
    {
        return args[args.length-1];
    }

}

class PutFn extends BuiltinFunction
{
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3)
            return error("put called with " + args.length +
                "args when 3 expected");
        return Fns.put((Symbol)args[0], args[1], args[2]);
    }
}

class PuthashFn extends BuiltinFunction
{
    public LispObject op2(LispObject key, LispObject value)
    {
        ((LispHash)Jlisp.lit[Lit.hashtab]).hash.put(key, value);
        return value;
    }
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3)
            return error("puthash called with " + args.length +
                "args when 2 or 3 expected");
        LispObject key = args[0];
        LispHash h = (LispHash)args[1];
        LispObject value = args[2];
        h.hash.put(key, value);
        return value;
    }
}

class PutvFn extends BuiltinFunction
{
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3)
            return error("putv called with " + args.length +
                "args when 3 expected");
        LispVector v = (LispVector)args[0];
        LispSmallInteger n = (LispSmallInteger)args[1];
        int i = n.value;
        v.vec[i] = args[2];
        return args[2];
    }

}

class Putv_charFn extends BuiltinFunction
{
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3)
            return error("putv-char called with " + args.length +
                "args when 3 expected");
        String v = ((LispString)args[0]).string;
        LispSmallInteger n = (LispSmallInteger)args[1];
        int i = n.value;
        char [] v1 = v.toCharArray();
        v1[i] = (char)(((LispSmallInteger)args[2]).value);
        ((LispString)args[0]).string = new String(v1);
        return args[2];
    }
}

class Putv16Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Putv32Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Putv8Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class QcaarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        return arg1.car.car;
    }
}

class QcadrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.cdr.car;
    }
}

class QcarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.car;
    }
}

class QcdarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.car.cdr;
    }
}

class QcddrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.cdr.cdr;
    }
}

class QcdrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.cdr;
    }
}

class QgetvFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        LispVector v = (LispVector)arg1;
        return v.vec[((LispSmallInteger)arg2).value];
    }
}

class QputvFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class RassocFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class RdfFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (!(arg1 instanceof LispString))
            return error("argument for rdf should be a string");
        String name = ((LispString)arg1).string;
        LispObject save = Jlisp.lit[Lit.std_input].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_input].car/*value*/ =
                new LispStream(
                    name,
                    new BufferedReader(
                        new FileReader(LispStream.nameConvert(name))),
                    false, true);
            try
            {   Jlisp.println();
                // here I really want the simple READ-EVAL-PRINT
                // without any messing with any restart function.
                Jlisp.restarting = false; // just to be ultra-careful!
                Jlisp.readEvalPrintLoop(true);
            }
            finally
            {   ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/).close();
            }
        }
        catch (FileNotFoundException e)
        {   return error("Unable to read from \"" +
                         name + "\"");
        }
        finally
        {   Jlisp.lit[Lit.std_input].car/*value*/ = save;
            Jlisp.println("+++ end of reading " + name);
        }
        return Environment.nil;
    }
}

class RdsFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
// The issue of what to select if the user says (rds nil) is a bit horrid
// here in terms of how it should react with the user also re-setting
// or re-binding !*std-input!* and the other related variables. Here I
// do something that probably works well enough for REDUCE...
        if (arg1 == Environment.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/;
        LispObject prev = Jlisp.lit[Lit.std_input].car/*value*/;
        Jlisp.lit[Lit.std_input].car/*value*/ = (LispStream)arg1;
        return prev;
    }
}

class ReadFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        LispObject w = Jlisp.lit[Lit.eof];
        try
        {   w = LispReader.read();
        }
        catch (EOFException e)
        {   return Jlisp.lit[Lit.eof];
        }
        catch (IOException e)
        {   Jlisp.errprintln("Reader error: " + e.getMessage());
        }
        return w;
    }
}

class ReadchFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        try
        {   int ch;
            do
            {   ch = ((LispStream)Jlisp.lit[Lit.std_input].car/*value*/
                     ).readChar();
            } while (ch == '\r');          // wary of Windows (& DOS)
            if (ch < 0) return Jlisp.lit[Lit.eof];
            else if (ch < 128) return LispReader.chars[ch];
            else return Symbol.intern(String.valueOf((char)ch));
        }
        catch (IOException e)
        {   return error("IO error detected in readch");
        }
    }
}

class ReadlineFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        StringBuffer s = new StringBuffer();
        LispObject sr = Jlisp.lit[Lit.raise].car/*value*/;
        LispObject sl = Jlisp.lit[Lit.lower].car/*value*/;
        Jlisp.lit[Lit.raise].car/*value*/ = Environment.nil;
        Jlisp.lit[Lit.lower].car/*value*/ = Environment.nil;
        try
        {   int c;
            boolean any = false;
            LispStream r = (LispStream)Jlisp.lit[Lit.std_input].car/*value*/;
            while ((c = r.readChar()) != '\n' &&
                   c != -1)
            {   if (c != '\r') 
                {   s.append((char)c);
                    any = true;
                }
            }
            if (c == -1 && !any) return Jlisp.lit[Lit.eof];
            else return new LispString(new String(s));
        }
        catch (IOException e)
        {   return error("IO error detected in readline");
        }
        finally
        {   Jlisp.lit[Lit.raise].car/*value*/ = sr;
            Jlisp.lit[Lit.lower].car/*value*/ = sl;
        }
    }
    public LispObject op1(LispObject a1) throws Exception
    {
        StringBuffer s = new StringBuffer();
        LispObject sr = Jlisp.lit[Lit.raise].car/*value*/;
        LispObject sl = Jlisp.lit[Lit.lower].car/*value*/;
        Jlisp.lit[Lit.raise].car/*value*/ = Environment.nil;
        Jlisp.lit[Lit.lower].car/*value*/ = Environment.nil;
        try
        {   int c;
            boolean any = false;
            LispStream r = (LispStream)a1;
            while ((c = r.readChar()) != '\n' &&
                   c != -1)
            {   if (c != '\r')
                {   s.append((char)c);
                    any = true;
                }
            }
            if (c == -1 && !any) return Jlisp.lit[Lit.eof];
            else return new LispString(new String(s));
        }
        catch (IOException e)
        {   return error("IO error detected in readline");
        }
        finally
        {   Jlisp.lit[Lit.raise].car/*value*/ = sr;
            Jlisp.lit[Lit.lower].car/*value*/ = sl;
        }
    }
}

class ReclaimFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class RemdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        Symbol a = (Symbol)arg1;
        a.completeName();
        a.fn = new Undefined(a.pname);
        return a;
    }
}

class RemflagFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        while (!arg1.atom)
        {   LispObject p = arg1;
            Symbol s = (Symbol)p.car;
            arg1 = p.cdr;
            Fns.remprop(s, arg2);
        }
        return Environment.nil;
    }
}

class RemhashFn extends BuiltinFunction
{
    public LispObject op1(LispObject key)
    {
        LispObject r = (LispObject)
            ((LispHash)Jlisp.lit[Lit.hashtab]).hash.remove(key);
        if (r == null) r = Environment.nil;
        return r;
    }
    public LispObject op2(LispObject key, LispObject table)
    {
        LispHash h = (LispHash)table;
        LispObject r = (LispObject)h.hash.remove(key);
        if (r == null) r = Environment.nil;
        return r;
    }
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3)
            return error("remhash called with " + args.length +
                "args when 1 to 3 expected");
        LispObject key = args[0];
        LispHash h = (LispHash)args[1];
        LispObject defaultValue = args[2];
        LispObject r = (LispObject)h.hash.remove(key);
        if (r == null) r = defaultValue;
        return r;
    }
}

class RemobFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class RempropFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (!(arg1 instanceof Symbol)) return Environment.nil;
        else return Fns.remprop((Symbol)arg1, arg2);
    }
}

class Rename_fileFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        String s;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            s = ((Symbol)arg1).pname;
        }
        else if (arg1 instanceof LispString) s = ((LispString)arg1).string;
        else return Environment.nil;
        String s1;
        if (arg2 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            s1 = ((Symbol)arg2).pname;
        }
        else if (arg2 instanceof LispString) s1 = ((LispString)arg2).string;
        else return Environment.nil;
        return LispStream.fileRename(s, s1);
    }
}

class RepresentationFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class ReturnFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ProgEvent
    {
        Specfn.progEvent = Specfn.RETURN;
        Specfn.progData = arg1;
        return arg1;
    }
}

class ReverseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        LispObject r = Environment.nil;
        while (!arg1.atom)
        {   LispObject a = arg1;
            r = new Cons(a.car, r);
            arg1 = a.cdr;
        }
        return r;
    }
}

class ReversipFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        LispObject r = Environment.nil;
        while (!arg1.atom)
        {   LispObject a = arg1;
            arg1 = a.cdr;
            a.cdr = r;
            r = a;
        }
        return r;
    }
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        LispObject r = arg2;
        while (!arg1.atom)
        {   LispObject a = arg1;
            arg1 = a.cdr;
            a.cdr = r;
            r = a;
        }
        return r;
    }
}

class RplacaFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1.atom) return error("bad arg to rplaca");
        arg1.car = arg2;
        return arg1;
    }
}

class RplacdFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1.atom) return error("bad arg to rplacd");
        arg1.cdr = arg2;
        return arg1;
    }
}

class RplacwFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1.atom || arg2.atom) return error("bad arg to rplacw");
        arg1.car = arg2.car;
        arg1.cdr = arg2.cdr;
        return arg1;
    }
}

class RseekFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class RtellFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class SampleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class SassocFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class ScharFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        int n = ((LispSmallInteger)arg2).value;
        String s = ((LispString)arg1).string;
        char ch = s.charAt(n);
        if (ch < 128) return LispReader.chars[ch];
        else return Symbol.intern(String.valueOf((char)ch));
    }
}

class SeprpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        // blank end-of-line tab form-fee carriage-return
        if (arg1 == Jlisp.lit[Lit.space] ||
            arg1 == Jlisp.lit[Lit.newline] ||
            arg1 == Jlisp.lit[Lit.tab] ||
            arg1 == Jlisp.lit[Lit.formFeed] ||
            arg1 == Jlisp.lit[Lit.cr])
            return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class SetFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        ((Symbol)arg1).car/*value*/ = arg2;
        return arg2;
    }
}

class Set_autoloadFn extends BuiltinFunction
{
    public LispObject op2(LispObject name, LispObject data) throws Exception
    {
        Symbol f = (Symbol)name;
        if (data.atom)
            data = new Cons(data, Environment.nil);
        f.fn = new AutoLoad(f, data);
        return name;
    }
}

class Set_help_fileFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Set_print_precisionFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int n = Jlisp.printprec;
        Jlisp.printprec = ((LispSmallInteger)arg1).value;
        return LispInteger.valueOf(n);
    }
}

class SetpcharFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        String old = Fns.prompt;
        if (old == null) old = "";     // just in case!
        if (arg1 instanceof LispString)
            Fns.prompt = ((LispString)arg1).string;
        else if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            Fns.prompt = ((Symbol)arg1).pname;
        }
        else Fns.prompt = null;  // use system default
        return new LispString(old);
    }
}

class Simple_string_pFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        if (arg1 instanceof LispString) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class Simple_vector_pFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        if (arg1 instanceof LispVector) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class SmemqFn extends BuiltinFunction
{

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        while (!arg2.atom)
        {   LispObject a = arg2;
            if (a.car == Jlisp.lit[Lit.quote]) return Environment.nil;
            else if (op2(arg1, a.car) != Environment.nil)
                return Jlisp.lispTrue;
            else arg2 = a.cdr;
        }
        if (arg1 == arg2) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class SpacesFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        int n = ((LispSmallInteger)arg1).value;
        for (int i=0; i> 8;
                int flagbits = nopts >> 8;
                int ntail = flagbits >> 2;
                nargs &= 0xff;
                nopts &= 0xff;
                flagbits &= 0x03;
// The next few cases are where a function is defined as a direct call
// to another, possibly discarding a few final args. Eg
//                          (de f (a b) (g a))
                if (ntail != 0)
                {   a1.fn = new CallAs(nargs, a2.cdr.cdr, ntail-1);
                    return arg1;
                }
                a2 = a2.cdr;
                if (a2.atom) return Environment.nil;
                Bytecode b = (Bytecode)a2.car;
                LispVector v = (LispVector)a2.cdr;
                if (flagbits != 0 || nopts != 0)
                {
// What is happening here is a MESS inherited from CSL.
//   nopts = number of optional args wanted
//   flagbits & 1   "hard case": pass Spid.noarg not nil for missing opts
//   flagbits & 2    &rest arg present
                    b = new ByteOpt(b.bytecodes, v.vec, 
                                    nargs, nopts, flagbits);
                }
                else 
                {   b.env = v.vec;
                    b.nargs = nargs;
                }
                a1.fn = b;
                return arg1;
            }
            // Otherwise drop through and moan
        }
        else if (arg2 instanceof Symbol)
        {   Symbol a2 = (Symbol)arg2;
            a1.fn = a2.fn;
            return arg1;
        }
        else if (arg2 instanceof LispFunction)
        {   a1.fn = (LispFunction)arg2;
            return arg1;
        }
        // Unrecognised cases follow - just print a message
        Jlisp.println();
        arg1.print(LispObject.printEscape);
        Jlisp.print(" => ");
        arg2.print();
        Jlisp.println();
        return Environment.nil;
    }
}

class Symbol_set_envFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (!(arg1 instanceof Symbol)) return Environment.nil;
        LispFunction f = ((Symbol)arg1).fn;
        if (f instanceof FnWithEnv) 
            ((FnWithEnv)f).env = ((LispVector)arg2).vec;
        else return Environment.nil; // quiet in case it fails?
        return arg2;
    }
}

class Symbol_set_nativeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Symbol_valueFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        return ((Symbol)arg1).car/*value*/;
    }
}

class SymbolpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {   return arg1 instanceof Symbol ? Jlisp.lispTrue :
               Environment.nil;
    }
}

class SymerrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class SystemFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        try
        {   Runtime r = Runtime.getRuntime();
            r.exec(((LispString)arg1).string);
        }
        catch (IOException e)
        {   return Environment.nil;
        }
        catch (SecurityException e)
        {   return Environment.nil;
        }
        return Jlisp.lispTrue;
    }
}

class TagbodyFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class TerpriFn extends BuiltinFunction
{
    public LispObject op0() throws ResourceException
    {
        Jlisp.println();
        return Environment.nil;
    }
}

class ThreevectorpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof LispVector &&
            ((LispVector)arg1).vec.length == 3) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class ThrowFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class TimeFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        return LispInteger.valueOf(System.currentTimeMillis());
    }
}

class TmpnamFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class TraceFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        while (!arg1.atom)
        {   Symbol n = (Symbol)arg1.car;
            if (!(n.fn instanceof TracedFunction))
                n.fn = new TracedFunction(n, n.fn);
            arg1 = arg1.cdr;
        }
        return Environment.nil;
    }
}

class TracesetFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Traceset1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class TtabFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        int n = ((LispSmallInteger)arg1).value;
        LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
        while (f.column < n) f.print(" ");
        return Environment.nil;
    }
}

class TyoFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Undouble_executeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class UnfluidFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class UnglobalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class UnionFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        while (!arg1.atom)
        {   LispObject a2 = arg2;
            while (!a2.atom)
            {   if (a2.car.lispequals(arg1.car)) break;
                a2 = a2.cdr;
            }
            if (a2.atom)
                arg2 = new Cons(arg1.car, arg2);
            arg1 = arg1.cdr;
        }
        return arg2; 
    }
}

class Unmake_globalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.global]);
        return Environment.nil;
    }
}

class Unmake_specialFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        Fns.remprop((Symbol)arg1, Jlisp.lit[Lit.special]);
        return Environment.nil;
    }
}

class UnreadchFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class UntraceFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        while (!arg1.atom)
        {   Symbol n = (Symbol)arg1.car;
            if (n.fn instanceof TracedFunction)
                n.fn = ((TracedFunction)n.fn).fn;
            arg1 = arg1.cdr;
        }
        return Environment.nil;
    }
}

class UntracesetFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Untraceset1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Unwind_protectFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class UpbvFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int n;
        if (arg1 instanceof LispString)
            n = ((LispString)arg1).string.length();
        else if (arg1 instanceof LispVector)
            n = ((LispVector)arg1).vec.length;
        else return Environment.nil;
        return LispInteger.valueOf(n-1);
    }
}

class User_homedir_pathnameFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class VectorpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof LispVector) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class VerbosFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int old = Jlisp.verbosFlag;
        if (arg1 instanceof LispInteger)
            Jlisp.verbosFlag = arg1.intValue();
        else if (arg1 == Environment.nil) Jlisp.verbosFlag = 0;
        else Jlisp.verbosFlag = 3;
        return LispInteger.valueOf(old);
    }
}

class Where_was_thatFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        return new Cons(
            new LispString("Unknown file"),
            new Cons(LispInteger.valueOf(-1), Environment.nil));
    }
}

class Window_headingFn extends BuiltinFunction
{
    public LispObject op1(LispObject a) throws Exception
    {
        String s;
        if (a instanceof Symbol)
        {   ((Symbol)a).completeName();
            s = ((Symbol)a).pname;
        }
        else if (a instanceof LispString) s = ((LispString)a).string;
        else return Environment.nil;
// Note that I just dump this to output with no regard for Lisp output
// streams, buffering etc!
        if (Jlisp.standAlone) System.out.println(s);
        else
        {
            // in CWin case put string arg on window title-bar @@@@
        }
        return Environment.nil;
    }
}

class Startup_bannerFn extends BuiltinFunction
{
    public LispObject op1(LispObject a) throws Exception
    {
        // reset message displayed when Jlisp starts up @@@@
        // compressed heap images make this harder. I need to worry!
        return Environment.nil;
    }
}

class Writable_librarypFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Write_help_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Write_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (Fasl.writer == null)
            return error("no FASL file active in write-module");
        Fasl.faslWrite(arg1);
        return Environment.nil;
    }
}

class WrsFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
// see comments for Rds.
        if (arg1 == Environment.nil) arg1 = Jlisp.lit[Lit.terminal_io].car/*value*/;
        LispObject prev = Jlisp.lit[Lit.std_output].car/*value*/;
        Jlisp.lit[Lit.std_output].car/*value*/ = (LispStream)arg1;
        return prev;
    }
}

class XassocFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class XconsFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException
    {
        return new Cons(arg2, arg1);
    }
}

class XdifferenceFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class XtabFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws ResourceException
    {
        int n = ((LispSmallInteger)arg1).value;
        LispStream f = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
        for (int i=0; i 1.0 || a < -1.0) return error("bad arg for acos");
        a = Math.acos(a);
        return new LispFloat(a);
    }
}

class AcosdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > 1.0 || a < -1.0) return error("bad arg for acosd");
        a = 180.0*Math.acos(a)/Math.PI;
        return new LispFloat(a);
    }
}

class AcoshFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a < 1.0) return error("bad arg for acosh");
        a = MyMath.acosh(a);
        return new LispFloat(a);
    }
}

class AcotFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.PI/2.0 - Math.atan(a);
        return new LispFloat(a);
    }
}

class AcotdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 90.0 - 180.0*Math.atan(a)/Math.PI;
        return new LispFloat(a);
    }
}

class AcothFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > -1.0 && a < 1.0) return error("bad arg for acoth");
        a = MyMath.acoth(a);
        return new LispFloat(a);
    }
}

class AcscFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > -1.0 && a < 1.0) return error("bad arg for acsc");
        a = Math.asin(1.0/a);
        return new LispFloat(a);
    }
}

class AcscdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > -1.0 && a < 1.0) return error("bad arg for acscd");
        a = 180.0*Math.asin(1.0/a)/Math.PI;
        return new LispFloat(a);
    }
}

class AcschFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.acsch(a);
        return new LispFloat(a);
    }
}

class Add1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.add1();
    }
}

class AsecFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > -1.0 && a < 1.0) return error("bad arg for asec");
        a = Math.acos(1.0/a);
        return new LispFloat(a);
    }
}

class AsecdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > -1.0 && a < 1.0) return error("bad arg for asecd");
        a = 180.0*Math.acos(1.0/a)/Math.PI;
        return new LispFloat(a);
    }
}

class AsechFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a < 0.0 || a > 1.0) return error("bad arg for asech");
        a = MyMath.asech(a);
        return new LispFloat(a);
    }
}

class AshFn extends BuiltinFunction
{
// Shift - thinking of things as twos-complement binary numbers 
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.ash(((LispSmallInteger)arg2).value);
    }
}

class Ash1Fn extends BuiltinFunction
{
// Shift - thinking of things as sign-and-magnitude numbers 
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.ash1(((LispSmallInteger)arg2).value);
    }
}

class AsinFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a < -1.0 || a > 1.0) return error("bad arg for asin");
        a = Math.asin(a);
        return new LispFloat(a);
    }
}

class AsindFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a < -1.0 || a > 1.0) return error("bad arg for asind");
        a = 180.0*Math.asin(a)/Math.PI;
        return new LispFloat(a);
    }
}

class AsinhFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.asinh(a);
        return new LispFloat(a);
    }
}


class CeilingFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.ceiling();
    }
}

class AtanFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.atan(a);
        return new LispFloat(a);
    }
}

class Atan2Fn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        double a = arg1.doubleValue();
        double b = arg2.doubleValue();
        a = Math.atan2(a, b);
        return new LispFloat(a);
    }
}

class Atan2dFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        double a = arg1.doubleValue();
        double b = arg2.doubleValue();
        a = 180.0*Math.atan2(a, b)/Math.PI;
        return new LispFloat(a);
    }
}

class AtandFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 180.0*Math.atan(a)/Math.PI;
        return new LispFloat(a);
    }
}

class AtanhFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a > 1.0 || a < -1.0) return error("bad arg for atanh");
        a = MyMath.atanh(a);
        return new LispFloat(a);
    }
}

class CosFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.cos(a);
        return new LispFloat(a);
    }
}

class CosdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.cos(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class CoshFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.cosh(a);
        return new LispFloat(a);
    }
}

class CotFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.tan(a);
        return new LispFloat(a);
    }

}

class CotdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.tan(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class CothFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.coth(a);
        return new LispFloat(a);
    }
}

class CscFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.sin(a);
        return new LispFloat(a);
    }
}

class CscdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.sin(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class CschFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.csch(a);
        return new LispFloat(a);
    }
}

class DifferenceFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.subtract(arg2);
    }
}

class DivideFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.quotientAndRemainder(arg2);
    }
}

class EvenpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.evenp();
    }
}

class ExpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.exp(a);
        return new LispFloat(a);
    }
}

class ExptFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.expt(arg2);
    }
}

class FixFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.fix();
    }
}


class EqSafeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return Environment.nil;
    }
}

class FixpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.fixp();
    }
}

class FloatFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.jfloat();
    }
}

class FloatpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.floatp();
    }
}

class FloorFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.floor();
    }
}

class FrexpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double d = ((LispFloat)arg1).value;
        if (d == 0.0) return new Cons(LispInteger.valueOf(0), arg1);
	long l = Double.doubleToLongBits(d);
	long x = (l >> 52) & 0x7ff;
// NaN and infinity do not normalise a lot
        if (x == 0x7ff) return new Cons(LispInteger.valueOf(0), arg1);
        if (x == 0) // a denormalised number
        {   long s = l & 0x8000000000000000L;
            while ((l & 0x0010000000000000L) == 0)
            {   x--;
                l = l << 1;
            }
            l = s | (l & 0x000fffffffffffffL);
        }
        x = x - 0x3fe;
	l = (l & 0x800fffffffffffffL) | 0x3fe0000000000000L;
	return new Cons(LispInteger.valueOf((int)x),
	                new LispFloat(Double.longBitsToDouble(l)));
    }
}

class GcdnFn extends BuiltinFunction
{
    public LispObject op0()
    { return LispInteger.valueOf(0); }
    public LispObject op1(LispInteger a1)
    { return a1; }
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return arg1.gcd(arg2);
    }
    public LispObject opn(LispObject [] args) throws Exception
    {
        BigInteger r = args[0].bigIntValue();
        for (int i=2; i> 52) & 0x7ff;
        double r = a1+a2;
        long r1 = Double.doubleToLongBits(r);
        int x = (int)(r1 >> 52) & 0x7ff;
// I return nil if either the result overflows, or if it becomes a denorm,
// or if it is smaller than one of the inputs by 40 places. This last
// case seems a bit curious but it is what the REDUCE code appears to
// expect and I should not adjust it without making a major review of all
// that REDUCE does...
        if (x == 0x7ff || x == 0 || x < (x1-40)) return Environment.nil;
        else return new LispFloat(r);
    }
}

class Safe_fp_timesFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
	double a1 = ((LispFloat)arg1).value,
               a2 = ((LispFloat)arg2).value;
// I accept that multiplying by 0.0 should return 0.0
// The possibility that the calculation was 0.0*infinity or 0.0*NaN is
// one I will ignore, since in the cases I use safe-fp-times values should
// never degenerate into those special cases.
        if (a1 == 0.0 || a2 == 0.0) return new LispFloat(0.0);
        double r = a1*a2;
// form tha product in the ordinary way and then see if the result is
// denormalised or infinite.
        long r1 = Double.doubleToLongBits(r);
        int x = (int)(r1 >> 52) & 0x7ff;
        if (x == 0x7ff || x == 0) return Environment.nil;
        return new LispFloat(r);
    }
}

class Safe_fp_quotFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
	double a1 = ((LispFloat)arg1).value,
               a2 = ((LispFloat)arg2).value;
        if (a2 == 0.0) return Environment.nil;
        else if (a1 == 0.0) return new LispFloat(0.0);
        double r = a1/a2;
        long r1 = Double.doubleToLongBits(r);
        int x = (int)(r1 >> 52) & 0x7ff;
        if (x == 0x7ff || x == 0) return Environment.nil;
        return new LispFloat(r);
    }
}

class SecFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.cos(a);
        return new LispFloat(a);
    }
}

class SecdFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = 1.0/Math.cos(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class SechFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.sech(a);
        return new LispFloat(a);
    }
}

class Set_small_modulusFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int old = Jlisp.modulus;
        int n = ((LispSmallInteger)arg1).value;
        if (n <= 0) 
             return error("set-small-modulus needs a positive argument");
        Jlisp.modulus = n;
        Jlisp.bigModulus = BigInteger.valueOf(n);
        return LispInteger.valueOf(old);
    }
}

class SinFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.sin(a);
        return new LispFloat(a);
    }
}

class SindFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.sin(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class SinhFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.sinh(a);
        return new LispFloat(a);
    }
}

class SqrtFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
	if (a < 0.0) return error("bad arg for sqrt");
        a = Math.sqrt(a);
        return new LispFloat(a);
    }
}

class Sub1Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.sub1();
    }
}

class TanFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.tan(a);
        return new LispFloat(a);
    }
}

class TandFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = Math.tan(Math.PI*a/180.0);
        return new LispFloat(a);
    }
}

class TanhFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        double a = arg1.doubleValue();
        a = MyMath.tanh(a);
        return new LispFloat(a);
    }
}

class TruncateFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.truncate();
    }

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        double a1, a2;
        if (arg1 instanceof LispInteger)
	{   if (arg2 instanceof LispInteger)
                return arg1.divide(arg2);
	    else a1 = arg1.doubleValue(); // overflow?
        }
        else a1 = ((LispFloat)arg1).value;
        a2 = arg2.doubleValue();
// There is worry here with overflow etc. But maybe nobody ever calls this!
        return LispInteger.valueOf((long)(a1 / a2));
    }
}

class ZeropFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.zerop();
    }
}

}

// End of Fns2.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/builtin/BuiltinFunction.java0000644000175000017500000000704511555446662032776 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.builtin;


//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;

public abstract class BuiltinFunction extends LispFunction
{
    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    byte [] rep = name.getBytes("UTF8");
	    int length = rep.length;
	    if (length <= 0xff)
	    {   Jlisp.odump.write(X_FNAME);
	        Jlisp.odump.write(length);
	    }
	    else throw new Exception("overlong name for a function");
	    for (int i=0; i= 0.0) return Math.log(a + Math.sqrt(1.0 + a*a));
    else return -Math.log(-a + Math.sqrt(1.0 + a*a));
}

public static double atanh(double a)
{
    return 0.5*Math.log((1.0+a)/(1.0-a)); 
}

public static double cosh(double a)
{
    if (a < 0.0) a = -a;
// no cancellation worries for small argument
    if (a < 20.0)
    {   double ea = Math.exp(a);
        return (ea + 1.0/ea)/2.0;
    }
// if exp(-a) is tiny compared with exp(a) I can ignore it
    else if (a < 700) return Math.exp(a)/2.0;
// avoid premature overflow in extreme cases
    else return Math.exp(a - Math.log(2.0));
}

public static double coth(double a)
{
    return 1.0/tanh(a);
}

public static double csch(double a)
{
    return 1.0/sinh(a);
}

public static double sech(double a)
{
    return 1.0/cosh(a);
}

public static double sinh(double a)
{
// for small arguments I use the series expansion to avoid cancellation
    double aa = Math.abs(a);
    if (aa < 0.35)
    {   double a2 = a*a;
        double r = (((((a2/110.0 + 1.0)*a2/72.0 + 1.0)*a2/42.0 +
	           1.0)*a2/20.0 + 1.0)*a2/6.0 + 1.0)*a;
	return r;  
    }
// for medium arguments the full formula can be used
    else if (aa < 20.0) return (Math.exp(a) - Math.exp(-a))/2.0;
// for |a| > 20 I can use a simplified version
    else if (aa < 700.0) aa = Math.exp(aa)/2.0;
// fially for very large args I must avoid premature overflow
    else aa = Math.exp(aa - Math.log(2.0));
    if (a < 0.0) return -aa;
    else return aa;
}

public static double tanh(double a)
{
    double aa = Math.abs(a);
// for small argument I will first range reduce and then use a simple
// powert series.
    if (aa < 0.40)
    {   int n = 0;
        while (aa >= 0.05)
	{   aa = aa/2.0;
	    n++;
	}
	double a2 = aa*aa;
	double r = ((((62.0/2835.0*a2 - 17.0/315)*a2 + 2.0/15.0)*a2 -
	               1.0/3.0)*a2 + 1.0)*aa;
	while (n != 0)
	{   r = 2.0*r/(1 + r*r);
	    n--;
	}
	if (a < 0) return -r;
        else return r;
    }
// for large enough argument the value will be +1 or -1 to within accuracy
// limits
    else if (aa >= 20.0)
    {   if (a < 0.0) return -1.0;
        else return 1.0;
    }
// for intermediate ranges I can use the normal formula, secure that there
// will be no overflow, underflow or serious cancellation
    double ea = Math.exp(a);
    double ema = 1.0/ea;
    return (ea-ema)/(ea+ema);
}

}

// end of MyMath.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/builtin/Fns1.java0000644000175000017500000031221211611456002030442 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.builtin;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

// Fns1.java

// Each built-in function is created wrapped in a class
// that is derived from BuiltinFunction.

import java.io.InputStream;
import java.io.PrintWriter;



import java.math.BigInteger;
import java.text.DateFormat;
import java.text.ParsePosition;
import java.util.Date;
import java.util.Iterator;
import org.mathpiper.mpreduce.Environment;

import org.mathpiper.mpreduce.functions.functionwithenvironment.Bytecode;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.io.Fasl;
import org.mathpiper.mpreduce.symbols.Gensym;
import org.mathpiper.mpreduce.functions.lisp.Interpreted;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.io.streams.LispCounter;
import org.mathpiper.mpreduce.LispEqualObject;
import org.mathpiper.mpreduce.exceptions.LispException;
import org.mathpiper.mpreduce.io.streams.LispExploder;
import org.mathpiper.mpreduce.numbers.LispFloat;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;
import org.mathpiper.mpreduce.datatypes.LispHash;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.numbers.LispNumber;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.numbers.LispSmallInteger;
import org.mathpiper.mpreduce.io.streams.LispStream;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.datatypes.LispVector;
import org.mathpiper.mpreduce.io.streams.ListReader;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.functions.lisp.Macro;
import org.mathpiper.mpreduce.packagedatastore.PDS;
import org.mathpiper.mpreduce.exceptions.ProgEvent;
import org.mathpiper.mpreduce.exceptions.ResourceException;
import org.mathpiper.mpreduce.special.Specfn;
import org.mathpiper.mpreduce.symbols.Symbol;
import org.mathpiper.mpreduce.functions.lisp.Undefined;
import org.mathpiper.mpreduce.io.streams.WriterToLisp;

public class Fns1
{
    public Object [][] builtins =
    {
        //{"userjava",                    new UserJavaFn()},
        {"acons",                       new AconsFn()},
        {"append",                      new AppendFn()},
        {"apply",                       new ApplyFn()},
        {"apply0",                      new Apply0Fn()},
        {"apply1",                      new Apply1Fn()},
        {"apply2",                      new Apply2Fn()},
        {"apply3",                      new Apply3Fn()},
        {"assoc",                       new AssocFn()},
        {"assoc**",                     new AssocStarStarFn()},
        {"atom",                        new AtomFn()},
        {"atsoc",                       new AtsocFn()},
        {"batchp",                      new BatchpFn()},
        {"binary_close_input",          new Binary_close_inputFn()},
        {"binary_close_output",         new Binary_close_outputFn()},
        {"binary_open_input",           new Binary_open_inputFn()},
        {"binary_open_output",          new Binary_open_outputFn()},
        {"binary_prin1",                new Binary_prin1Fn()},
        {"binary_prin2",                new Binary_prin2Fn()},
        {"binary_prin3",                new Binary_prin3Fn()},
        {"binary_prinbyte",             new Binary_prinbyteFn()},
        {"binary_princ",                new Binary_princFn()},
        {"binary_prinfloat",            new Binary_prinfloatFn()},
        {"binary_read2",                new Binary_read2Fn()},
        {"binary_read3",                new Binary_read3Fn()},
        {"binary_read4",                new Binary_read4Fn()},
        {"binary_readbyte",             new Binary_readbyteFn()},
        {"binary_readfloat",            new Binary_readfloatFn()},
        {"binary_select_input",         new Binary_select_inputFn()},
        {"binary_terpri",               new Binary_terpriFn()},
        {"binopen",                     new BinopenFn()},
        {"boundp",                      new BoundpFn()},
        {"bps-getv",                    new Bps_getvFn()},
        {"bps-putv",                    new Bps_putvFn()},
        {"bps-upbv",                    new Bps_upbvFn()},
        {"bpsp",                        new BpspFn()},
        {"break-loop",                  new Break_loopFn()},
        {"byte-getv",                   new Byte_getvFn()},
        {"bytecounts",                  new BytecountsFn()},
        {"c_out",                       new C_outFn()},
        {"caaaar",                      new CaaaarFn()},
        {"caaadr",                      new CaaadrFn()},
        {"caaar",                       new CaaarFn()},
        {"caadar",                      new CaadarFn()},
        {"caaddr",                      new CaaddrFn()},
        {"caadr",                       new CaadrFn()},
        {"caar",                        new CaarFn()},
        {"cadaar",                      new CadaarFn()},
        {"cadadr",                      new CadadrFn()},
        {"cadar",                       new CadarFn()},
        {"caddar",                      new CaddarFn()},
        {"cadddr",                      new CadddrFn()},
        {"caddr",                       new CaddrFn()},
        {"cadr",                        new CadrFn()},
        {"car",                         new CarFn()},
        {"car*",                        new CarStarFn()},
        {"carcheck",                    new CarcheckFn()},
        {"catch",                       new CatchFn()},
        {"cbrt",                        new CbrtFn()},
        {"cdaaar",                      new CdaaarFn()},
        {"cdaadr",                      new CdaadrFn()},
        {"cdaar",                       new CdaarFn()},
        {"cdadar",                      new CdadarFn()},
        {"cdaddr",                      new CdaddrFn()},
        {"cdadr",                       new CdadrFn()},
        {"cdar",                        new CdarFn()},
        {"cddaar",                      new CddaarFn()},
        {"cddadr",                      new CddadrFn()},
        {"cddar",                       new CddarFn()},
        {"cdddar",                      new CdddarFn()},
        {"cddddr",                      new CddddrFn()},
        {"cdddr",                       new CdddrFn()},
        {"cddr",                        new CddrFn()},
        {"cdr",                         new CdrFn()},
        {"char-code",                   new Char_codeFn()},
        {"char-downcase",               new Char_downcaseFn()},
        {"char-upcase",                 new Char_upcaseFn()},
        {"chdir",                       new ChdirFn()},
        {"checkpoint",                  new CheckpointFn()},
        {"cl-equal",                    new Cl_equalFn()},
        {"close",                       new CloseFn()},
        {"close-library",               new Close_libraryFn()},
        {"clrhash",                     new ClrhashFn()},
        {"code-char",                   new Code_charFn()},
        {"codep",                       new CodepFn()},
        {"compress",                    new CompressFn()},
        {"cons",                        new ConsFn()},
        {"consp",                       new ConspFn()},
        {"constantp",                   new ConstantpFn()},
        {"contained",                   new ContainedFn()},
        {"convert-to-evector",          new Convert_to_evectorFn()},
        {"copy",                        new CopyFn()},
        {"copy-module",                 new Copy_moduleFn()},
        {"create-directory",            new Create_directoryFn()},
        {"date",                        new DateFn()},
        {"dated-name",                  new Dated_nameFn()},
        {"datelessp",                   new DatelesspFn()},
        {"datestamp",                   new DatestampFn()},
        {"define-in-module",            new Define_in_moduleFn()},
        {"deflist",                     new DeflistFn()},
        {"deleq",                       new DeleqFn()},
        {"delete",                      new DeleteFn()},
        {"delete-file",                 new Delete_fileFn()},
        {"library-members",             new Library_membersFn()},
        {"delete-module",               new Delete_moduleFn()},
        {"demo-mode",                   new Demo_modeFn()},
        {"digit",                       new DigitFn()},
        {"directoryp",                  new DirectorypFn()},
        {"dm",                          new DmFn()},
        {"do",                          new DoFn()},
        {"do*",                         new DoStarFn()},
        {"dolist",                      new DolistFn()},
        {"dotimes",                     new DotimesFn()},
        {"double-execute",              new Double_executeFn()},
        {"egetv",                       new EgetvFn()},
        {"eject",                       new EjectFn()},
        {"enable-backtrace",            new Enable_backtraceFn()},
        {"endp",                        new EndpFn()},
        {"eputv",                       new EputvFn()},
        {"eq",                          new EqFn()},
        {"eqcar",                       new EqcarFn()},
        {"equalcar",                    new EqualcarFn()},
        {"eql",                         new EqlFn()},
        {"eqlhash",                     new EqlhashFn()},
        {"equal",                       new EqualFn()},
        {"iequal",                      new EqualFn()},
        {"equalp",                      new EqualpFn()},
        {"error",                       new ErrorFn()},
        {"error1",                      new Error1Fn()},
        {"errorset",                    new ErrorsetFn()},
        {"eupbv",                       new EupbvFn()},
        {"eval",                        new EvalFn()},
        {"eval-when",                   new Eval_whenFn()},
        {"evectorp",                    new EvectorpFn()},
        {"evlis",                       new EvlisFn()},
        {"expand",                      new ExpandFn()},
        {"explode",                     new ExplodeFn()},
        {"explodetostring",             new ExplodetostringFn()},
        {"explode2",                    new Explode2Fn()},
        {"explode2lc",                  new Explode2lcFn()},
        {"explode2lcn",                 new Explode2lcnFn()},
        {"explode2n",                   new Explode2nFn()},
        {"explode2uc",                  new Explode2ucFn()},
        {"explode2ucn",                 new Explode2ucnFn()},
        {"explodebinary",               new ExplodebinaryFn()},
        {"explodec",                    new ExplodecFn()},
        {"explodecn",                   new ExplodecnFn()},
        {"explodehex",                  new ExplodehexFn()},
        {"exploden",                    new ExplodenFn()},
        {"explodeoctal",                new ExplodeoctalFn()},
        {"fetch-url",                   new Fetch_urlFn()},
        {"fgetv32",                     new Fgetv32Fn()},
        {"fgetv64",                     new Fgetv64Fn()},
        {"file-readablep",              new File_readablepFn()},
        {"file-writeablep",             new File_writeablepFn()},
        {"filedate",                    new FiledateFn()},
        {"filep",                       new FilepFn()},
        {"flag",                        new FlagFn()},
        {"flagp",                       new FlagpFn()},
        {"flagp**",                     new FlagpStarStarFn()},
        {"flagpcar",                    new FlagpcarFn()},
        {"fluid",                       new FluidFn()},
        {"fluidp",                      new FluidpFn()},
        {"flush",                       new FlushFn()},
        {"format",                      new FormatFn()},
        {"fp-evaluate",                 new Fp_evaluateFn()},
        {"fputv32",                     new Fputv32Fn()},
        {"fputv64",                     new Fputv64Fn()},
        {"funcall",                     new FuncallFn()},
        {"funcall*",                    new FuncallFn()},
        {"gctime",                      new GctimeFn()},
        {"gensym",                      new GensymFn()},
        {"gensym1",                     new Gensym1Fn()},
        {"gensym2",                     new Gensym2Fn()},
        {"gensymp",                     new GensympFn()},
        {"get",                         new GetFn()},
        {"get*",                        new GetStarFn()},
        {"get-current-directory",       new Get_current_directoryFn()},
        {"get-lisp-directory",          new Get_lisp_directoryFn()},
        {"getd",                        new GetdFn()},
        {"getenv",                      new GetenvFn()},
        {"gethash",                     new GethashFn()},
        {"getv",                        new GetvFn()},
        {"getv16",                      new Getv16Fn()},
        {"getv32",                      new Getv32Fn()},
        {"getv8",                       new Getv8Fn()},
        {"global",                      new GlobalFn()},
        {"globalp",                     new GlobalpFn()},
        {"hash-table-p",                new Hash_table_pFn()},
        {"hashcontents",                new HashcontentsFn()},
        {"hashtagged-name",             new Hashtagged_nameFn()},
        {"help",                        new HelpFn()},
        {"idp",                         new IdpFn()},
        {"indirect",                    new IndirectFn()},
        {"inorm",                       new InormFn()},
        {"input-libraries",             new Input_librariesFn()},
        {"intern",                      new InternFn()},
        {"intersection",                new IntersectionFn()},
        {"is-console",                  new Is_consoleFn()},
        {"last",                        new LastFn()},
        {"lastcar",                     new LastcarFn()},
        {"lastpair",                    new LastpairFn()},
        {"length",                      new LengthFn()},
        {"lengthc",                     new LengthcFn()},
        {"library-name",                new Library_nameFn()},
        {"linelength",                  new LinelengthFn()},
        {"list",                        new ListFn()},
        {"list*",                       new ListStarFn()},
        {"list-directory",              new List_directoryFn()},
        {"list-modules",                new List_modulesFn()},
        {"list-to-string",              new List_to_stringFn()},
        {"list-to-symbol",              new List_to_symbolFn()},
        {"list-to-vector",              new List_to_vectorFn()},
        {"list2",                       new List2Fn()},
        {"list2*",                      new List2StarFn()},
        {"list3",                       new List3Fn()},
        {"resource-exceeded",           new ResourceExceededFn()},
        {"resource-limit",              new ResourceLimitFn()}

    };

/*
static Class c = null;
static Method m0 = null, m1 = null, m2 = null, mn = null;


class UserJavaFn extends BuiltinFunction
{
// To use this, prepare a new class
//
//   public class UserJava
//   {   public static LispObject op1(LispObject a)
//       {   return ... }
//   }
// with PUBLIC STATIC methods op0, op1, op2 and opn (not all need be
// provided). Compile it and put it where the system class loader can
// find it. Maybe merge it into the mai .jar file? Then
//    (userjava )
// will call those methods for you, or if the class was not provided it
// will just return a complaint!
//
    void ensureClassLoaded() throws Exception
    {
        if (c == null)
        {   ClassLoader l = ClassLoader.getSystemClassLoader();
            c = l.loadClass("UserJava");
            Class lo = Class.forName("LispObject");
            Class lov = (new LispObject [0]).getClass();
            m0 = m1 = m2 = mn = null;
            try
            {   m0 = c.getMethod("op0", 
                                new Class [] {});
            }
            catch (NoSuchMethodException nsm) {}
            try
            {   m1 = c.getMethod("op1", 
                                new Class [] {lo});
            }
            catch (NoSuchMethodException nsm) {}
            try
            {   m2 = c.getMethod("op2", 
                                new Class [] {lo, lo});
            }
            catch (NoSuchMethodException nsm) {}
            try
            {   mn = c.getMethod("opn", 
                                new Class [] {lov});
            }
            catch (NoSuchMethodException nsm) {}
        }
    }

    public LispObject op0() throws Exception
    {
        ensureClassLoaded();
        if (m0 == null) return Jlisp.error("no 0-arg method in UserJava");
        return (LispObject)m0.invoke(null);
    }

    public LispObject op1(LispObject a) throws Exception
    {
        ensureClassLoaded();
        if (m1 == null) return Jlisp.error("no 1-arg method in UserJava");
        return (LispObject)m1.invoke(this, a);
    }

    public LispObject op2(LispObject a, LispObject b) throws Exception
    {
        ensureClassLoaded();
        if (m2 == null) return Jlisp.error("no 2-arg method in UserJava");
        return (LispObject)m2.invoke(this, a, b);
    }

    public LispObject opn(LispObject [] a) throws Exception
    {
        ensureClassLoaded();
        if (mn == null) return Jlisp.error("no n-arg method in UserJava");
        return (LispObject)mn.invoke(this, (Object)a);
    }
}
*/

class AconsFn extends BuiltinFunction
{
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3) 
            return error("acons called with " + args.length +
                         " args when 3 were expected");
        return new Cons(new Cons(args[0], args[1]), args[2]);
    }
}

class AppendFn extends BuiltinFunction
{
    public LispObject op0()
    { return Environment.nil; }
    public LispObject op1(LispObject arg1)
    { return arg1; }
    public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException
    {
        LispObject r = Environment.nil;
        while (!arg1.atom)
        {   LispObject a = arg1;
            r = new Cons(a.car, r);
            arg1 = a.cdr;
        }
        while (!r.atom)
        {   LispObject a = r;
            r = a.cdr;
            a.cdr = arg2;
            arg2 = a;
        }
        return arg2;
    }
    public LispObject opn(LispObject [] args) throws ResourceException
    {
        int n = args.length;
        LispObject r = args[--n];
        for (int i=n-1; i>=0; i--)
        {   r = op2(args[i], r);
        }
        return r;
    }
}

class ApplyFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return applySub(arg1, 0, Environment.nil);
    }
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        return applySub(arg1, 0, arg2);
    }
    public LispObject opn(LispObject [] aa) throws Exception
    {
        int n = aa.length;
        for (int i=1; i 0.0) return new LispFloat(Math.pow(a, 1.0/3.0));
        else return new LispFloat(-Math.pow(-a, 1.0/3.0));
    }
}

class CdaaarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdaadrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdaarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdadarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdaddrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdadrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CddaarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CddadrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CddarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdddarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.car;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CddddrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CdddrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class CddrFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        if (arg1.atom) return error("Attempt to take car/cdr of an atom");
        arg1 = arg1.cdr;
        return arg1;
    }
}

class Char_codeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Char_downcaseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        char ch;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            ch = ((Symbol)arg1).pname.charAt(0);
        }
        else if (arg1 instanceof LispInteger)
            ch = (char)arg1.intValue();
        else if (arg1 instanceof LispString)
            ch = ((LispString)arg1).string.charAt(0);
        else return error("bad arg for char-downcase");
        byte [] bch = new byte [] { (byte)Character.toLowerCase(ch) };
        return Symbol.intern(new String(bch));
    }
}

class Char_upcaseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        char ch;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            ch = ((Symbol)arg1).pname.charAt(0);
        }
        else if (arg1 instanceof LispInteger)
            ch = (char)arg1.intValue();
        else if (arg1 instanceof LispString)
            ch = ((LispString)arg1).string.charAt(0);
        else return error("bad arg for char-upcase");
        byte [] bch = new byte [] { (byte)Character.toUpperCase(ch) };
        return Symbol.intern(new String(bch));
    }
}

class ChdirFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class CheckpointFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        return op1(Environment.nil);
    }
    
    public LispObject op1(LispObject arg1) throws Exception
    {
        return op2(arg1, Environment.nil);
    }
    
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        Jlisp.preserve(arg1, arg2);
        return Environment.nil;
    }
}

class Cl_equalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class CloseFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof LispStream)
        {   ((LispStream)arg1).close();
        }
        return Environment.nil;
    }
}

class Close_libraryFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class ClrhashFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        ((LispHash)Jlisp.lit[Lit.hashtab]).hash.clear();
        return Environment.nil;
    }
    
    public LispObject op1(LispObject ht) throws Exception
    {
        ((LispHash)ht).hash.clear();
        return Environment.nil;
    }
}

class Code_charFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class CodepFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof BuiltinFunction) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class CompressFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispObject save = Jlisp.lit[Lit.std_input].car/*value*/;
        LispStream from = new ListReader(arg1);
        LispObject r = Environment.nil;
        try
        {   Jlisp.lit[Lit.std_input].car/*value*/ = from;
            r = LispReader.read();
//-             int c = from.readChar();
            from.close();
//- // The next section is a pretty shameless hack to make REDUCE a bit
//- // more robust. If when I parse the input to COMPRESS I find something
//- // left over, I will take that as an indication that what the user
//- // intended was to have a symbol made up of all the characters in the
//- // input data (except that "!" gets treated as an escape (which is no
//- // longer needed, but which must be ignored)
//-             if (c != -1)
//-             {   StringBuffer s = new StringBuffer();
//-                 boolean escaped = false;
//-                 while (!arg1.atom)
//-                 {   LispObject k = arg1.car;
//-                     arg1 = arg1.cdr;
//-                     char ch;
//-                     if (k instanceof LispString)
//-                         ch = ((LispString)k).string.charAt(0);
//-                     else if (k instanceof LispInteger)
//-                         ch = (char)k.intValue();
//-                     else if (k instanceof Symbol)
//-                         ch = ((Symbol)k).pname.charAt(0);
//-                     else break;
//-                     if (!escaped && ch == '!')
//-                     {   escaped = true;
//-                         continue;
//-                     }
//-                     escaped = false;
//-                     s.append(ch);
//-                 }
//-                 return Symbol.intern(s.toString());
//-             }
        }
        catch (Exception e)
        {   Jlisp.errprintln(
                "Error in compress: " + e.getMessage());

            LispStream ee = // @@@
                        (LispStream)Jlisp.lit[Lit.err_output].car/*value*/;
            e.printStackTrace(new PrintWriter(new WriterToLisp(ee)));
            r = Environment.nil;
        }
        finally
        {   Jlisp.lit[Lit.std_input].car/*value*/ = save;
        }
        return r;
    }
}

// like ML   "fun cons a b = a :: b;"

class ConsFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException
    {   return new Cons(arg1, arg2);
    }
}

class ConspFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {   return arg1.atom ? Environment.nil :
               Jlisp.lispTrue;
    }
}

class ConstantpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof Symbol || !arg1.atom)
            return Environment.nil;
        else return Jlisp.lispTrue;
    }
}

class ContainedFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Convert_to_evectorFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class CopyFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return arg1.copy();
    }
}

class Copy_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1==Environment.nil) return arg1;
        Fasl.startModule(arg1);  // set up for output...
        InputStream readerSave = Fasl.reader;
        if (Fasl.openModule(arg1))
        {   try
            {   Fasl.writer.close();
            }
            finally
            {   Fasl.writer = null;
                Fasl.reader = readerSave;
            }
            return Environment.nil;
        }
        int c;
        while ((c = Fasl.reader.read()) != -1) Fasl.writer.write(c);
        try
        {   Fasl.reader.close();
        }
        catch (Exception e)
        {}
        try
        {   Fasl.writer.close();
        }
        finally
        {   Fasl.writer = null;
            Fasl.reader = readerSave;
        }
        return Jlisp.lispTrue;
    }
}

class Create_directoryFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DateFn extends BuiltinFunction
{
    public LispObject op0()
    {
        Date now = new Date();
        String s = DateFormat.getDateTimeInstance().format(now);
        return new LispString(s);
    }
}

class Dated_nameFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DatelesspFn extends BuiltinFunction
{
    public LispObject op2(LispObject a1, LispObject a2) throws Exception
    {
        String s1, s2;
        s1 = ((LispString)a1).string;
        s2 = ((LispString)a2).string;
        Date d1, d2;
        d1 = LispStream.dFormat.parse(s1, new ParsePosition(0));
        d2 = LispStream.dFormat.parse(s2, new ParsePosition(0));
        if (d1 == null || d2 == null) error("badly formatted date");
        boolean res = d1.getTime() < d2.getTime();
        return res ? Jlisp.lispTrue : Environment.nil;
    }
}

class DatestampFn extends BuiltinFunction
{
    public LispObject op0()
    {
        Date now = new Date();
        return LispInteger.valueOf(now.getTime());
    }
}

class Define_in_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        int n = arg1.intValue();
        if (n < -1 || n > 0x3ffff) error("bad arg to define-in-module");
        Fasl.defineInModule(n);
        return Environment.nil;
    }
}

class DeflistFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DeleqFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        LispObject w = Environment.nil;
        while (!arg2.atom)
        {   LispObject a2 = arg2;
            arg2 = a2.cdr;
            if (arg1 instanceof LispNumber &&    // @@@
                arg1.lispequals(a2.car)) break;  // @@@
            else if (a2.car == arg1) break;
            w = new Cons(a2.car, w);
        }
        while (!w.atom)
        {   LispObject cw = w;
            w = cw.cdr;
            cw.cdr = arg2;
            arg2 = cw;
        }
        return arg2;
    }
}

class DeleteFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws ResourceException
    {
        LispObject w = Environment.nil;
        while (!arg2.atom)
        {   LispObject a2 = arg2;
            arg2 = a2.cdr;
            if (arg1.lispequals(a2.car)) break;
            w = new Cons(a2.car, w);
        }
        while (!w.atom)
        {   LispObject cw = w;
            w = cw.cdr;
            cw.cdr = arg2;
            arg2 = cw;
        }
        return arg2;
    }
}

class Delete_fileFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        String s;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            s = ((Symbol)arg1).pname;
        }
        else if (arg1 instanceof LispString) s = ((LispString)arg1).string;
        else return Environment.nil;
        return LispStream.fileDelete(s);
    }
}

class Library_membersFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        if (Jlisp.outputImagePos < 0) return Environment.nil;
        PDS z = Jlisp.images[Jlisp.outputImagePos];
        if (z != null) return z.members();
        return Environment.nil;
    }
}

class Delete_moduleFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        Jlisp.println("++++ delete-module not coded yet"); // @@@
        return Environment.nil;
    }
}

class Demo_modeFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        return Environment.nil;
    }
}

class DigitFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (!(arg1 instanceof Symbol)) return Environment.nil;
        Symbol s = (Symbol)arg1;
        s.completeName();
        char ch = s.pname.charAt(0);
        if (Character.isDigit(ch)) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class DirectorypFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DmFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DoFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DoStarFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DolistFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class DotimesFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Double_executeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EgetvFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EjectFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Enable_backtraceFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EndpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {   if (arg1 == Environment.nil) return Jlisp.lispTrue;
        else if (!arg1.atom) return Environment.nil;
        else return error("ill-formed list detected by ENDP");
    }
}

class EputvFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

// (eq a b) is true if a and b are the same thing

class EqFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        if (arg1 instanceof LispNumber)                                // @@@
            return arg1.lispequals(arg2) ? Jlisp.lispTrue : Environment.nil; // @@@
        else return arg1==arg2 ? Jlisp.lispTrue : Environment.nil;
    }
}

class EqcarFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        if (arg1.atom) return Environment.nil;
        arg1 = arg1.car;
        if (arg1 instanceof LispNumber)                                // @@@
            return arg1.lispequals(arg2) ? Jlisp.lispTrue : Environment.nil; // @@@
        else return arg1==arg2 ? Jlisp.lispTrue : Environment.nil;
    }
}

class EqualcarFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        if (!arg1.atom &&
            (arg1.car == arg2 ||
             arg1.car.lispequals(arg2))) return Jlisp.lispTrue;
        else return Environment.nil;
    }
}

class EqlFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EqlhashFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EqualFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2)
    {
        if (arg1 == arg2) return Jlisp.lispTrue;
        return (arg1.lispequals(arg2) ? 
                Jlisp.lispTrue :
                Environment.nil);
    }
}

class EqualpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class ErrorFn extends BuiltinFunction
{
    public LispObject op1(LispObject a) throws Exception
    {
        return op2(LispInteger.valueOf(0), a);
    }

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (Jlisp.headline)
        {   Jlisp.errprintln();
            Jlisp.errprint("+++++ Error ");
            arg1.errPrint();
            Jlisp.errprint(" ");
            arg2.errPrint();
            Jlisp.errprintln();
        }
        if (!arg1.atom) arg1 = LispInteger.valueOf(0);
        Jlisp.errorCode = arg1;
        return error("Error function called");
    }
}

class Error1Fn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        if (!Jlisp.debugFlag) Jlisp.headline = Jlisp.backtrace = false;
        return error("Error1 function called");
    }
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (!Jlisp.debugFlag) Jlisp.headline = Jlisp.backtrace = false;
        return error("Error1 function called");
    }
}

class ErrorsetFn extends BuiltinFunction
{
    public LispObject opn(LispObject [] args) throws Exception
    {
        if (args.length != 3) 
            return error("errorset called with " + args.length + 
                         " arguments when 3 expected");
        LispObject form = args[0];
        boolean savehead = Jlisp.headline;
        boolean saveback = Jlisp.backtrace;
        try
        {   Jlisp.headline = (args[1] != Environment.nil);
            Jlisp.backtrace = (args[2] != Environment.nil);
// "-g" forces all errors to be noisy!
            if (Jlisp.debugFlag)
            {   Jlisp.headline = true;
                Jlisp.backtrace = true;
            }
            Jlisp.errorCode = Jlisp.lispTrue; // gets reset by user error function
            try
            {   form = form.eval();
                if (Specfn.progEvent != Specfn.NONE)
                {   Specfn.progEvent = Specfn.NONE;
                    error("GO or RETURN out of context");
                }
            }
            catch (Exception e) 
            {
            	if(Jlisp.trapExceptions == false)
            	{
            		//System.out.println(e.getMessage());
            		e.printStackTrace();
            	}
            	
                if (e instanceof ProgEvent)
                {   ProgEvent ep = (ProgEvent)e;
                    switch (ep.type)
                    {
                case ProgEvent.STOP:
                case ProgEvent.PRESERVE:
                case ProgEvent.RESTART:
                case ProgEvent.THROW:
                        throw e;
                default:
                        break;
                    }
                }
                boolean head = Jlisp.headline;
                boolean back = Jlisp.backtrace;
                if (head || back)
                    Jlisp.errprintln();
                if (e instanceof LispException)
                {   LispException e1 = (LispException)e;
                    if (head)
                    {   Jlisp.errprint("+++++ Error: " + e1.message);
                        if (e1.details != null)
                        {   Jlisp.errprint(": ");
                            e1.details.errPrint();
                        }
                        Jlisp.errprintln();
                    }
                }
                else
                {   if (head || back)
                        Jlisp.errprintln();
                    if (head)
                    {   String m = e.getMessage();
                        if (m == null) m = e.toString();
                        Jlisp.errprintln("+++++ Error: " + m);
                    }
                }
                if (back)
                {   LispStream ee = 
                        (LispStream)Jlisp.lit[Lit.err_output].car/*value*/;
                    e.printStackTrace(new PrintWriter(new WriterToLisp(ee)));
                }
                if (e instanceof ResourceException) throw e;
// I will return the atom that was the first argument in a user call to
//    (error a b)
// if such is available. Otherwise I return T.
                form = Jlisp.errorCode;
                Jlisp.errorCode = Jlisp.lispTrue;
                if (form == null | !form.atom) form = Jlisp.lispTrue;
                return form;
            }
        }
        finally
        {   Jlisp.headline = savehead;
            Jlisp.backtrace = saveback;
        }
        return new Cons(form, Environment.nil);
    }
}




class ResourceExceededFn extends BuiltinFunction
{
 public LispObject op0() throws LispException
 {   throw new ResourceException("User indicated resource limit");
 }
}


/*
 * (resource!-limit form time space io errors)
 *   Evaluate the given form and if it succeeds return a
 *   list whose first item is its value. If it fails in the ordinary manner
 *   then its failure (error/throw/restart etc) gets passed back through
 *   here in a transparent manner. But if it runs out of resources this
 *   function catches that fact and returns an atomic value.
 *   Resource limits are not precise, and are specified by the
 *   subsequent arguments here:
 *      time:  an integer giving a time allowance in seconds
 *      space: an integer giving a measure of memory that may be used,
 *             expressed in units of "megaconses". This is space
 *             allocated - the fact that memory gets recycled does not
 *             get it discounted.
 *      io:    an integer limiting the number of kilobytes of IO that may
 *             be performed.(not enforced yet in Jlisp)
 *      errors:an integer limiting the number of times traditional
 *             Lisp errors can occur. Note that if errorset is used
 *             you could have very many errors raised.
 *   In each case specifying a negative limit means that that limit does
 *   not apply. But at least one limit must be specified.
 *   If calls to resource!-limit are nested the inner ones can only
 *   reduce the resources available to their form.
 *
 *   On success set *resource* limit to a list showing the resources used.
 *
 * For now this ignores the limits!
 */

class ResourceLimitFn extends BuiltinFunction
{
    public LispObject op1(LispObject a1) throws Exception
    {
        return opn(new LispObject [] {a1});
    }
    public LispObject op2(LispObject a1, LispObject a2) throws Exception
    {
        return opn(new LispObject [] {a1, a2});
    }
    public LispObject opn(LispObject[] args) throws Exception {
        boolean ok = true;
        if (args.length > 5 || args.length < 1) {
            return error("resource-limit called with " + args.length
                    + " arguments when 1 to 5 expected");
        }
        int save_time_base = ResourceException.time_base,
                save_space_base = ResourceException.space_base,
                save_io_base = ResourceException.io_base,
                save_errors_base = ResourceException.errors_base;
        int save_time_limit = ResourceException.time_limit,
                save_space_limit = ResourceException.space_limit,
                save_io_limit = ResourceException.io_limit,
                save_errors_limit = ResourceException.errors_limit;
        LispObject form = args[0];
        LispObject time   = args[1];
        LispObject space  = args[2];
        LispObject io     = args.length > 3 ? args[3] : Environment.nil;
        LispObject errors = args.length > 4 ? args[4] : Environment.nil;
        int itime   = time instanceof LispInteger ? time.intValue() : -1;
        int ispace  = space instanceof LispInteger ? space.intValue() : -1;
        int iio     = io instanceof LispInteger ? io.intValue() : -1;
        int ierrors = errors instanceof LispInteger ? errors.intValue() : -1;
        LispObject r = Environment.nil;
        ResourceException.time_base = ResourceException.time_now;
        ResourceException.space_base = ResourceException.space_now;
        ResourceException.io_base = ResourceException.io_now;
        ResourceException.errors_base = ResourceException.errors_now;
        // If there is a limit already being imposed then this one can not extend
        // it, only shrink it.
        if (itime > 0) {
            int w = ResourceException.time_base + itime;
            if (ResourceException.time_limit > 0
                    && ResourceException.time_limit < w) {
                w = ResourceException.time_limit;
            }
            ResourceException.time_limit = w;
        }
        if (ispace > 0) {
            int w = ResourceException.space_base + (ispace < 4 ? 4 : ispace);
            if (ResourceException.space_limit > 0
                    && ResourceException.space_limit < w) {
                w = ResourceException.space_limit;
            }
            ResourceException.space_limit = w;
        }
        if (iio > 0) {
            int w = ResourceException.io_base + (iio < 2 ? 2 : iio);
            if (ResourceException.io_limit > 0
                    && ResourceException.io_limit < w) {
                w = ResourceException.io_limit;
            }
            ResourceException.io_limit = w;
        }
        if (ierrors > 0) {
            int w = ResourceException.errors_base + ierrors;
            if (ResourceException.errors_limit > 0
                    && ResourceException.errors_limit < w) {
                w = ResourceException.errors_limit;
            }
            ResourceException.errors_limit = w;
        }
        try {
            try
            {
            r = form.eval();
        } catch (ResourceException e) {
            ok = false;
        }
         itime =   ResourceException.time_now   - ResourceException.time_base;
         ispace =  ResourceException.space_now  - ResourceException.space_base;
         iio =     ResourceException.io_now     - ResourceException.io_base;
         ierrors = ResourceException.errors_now - ResourceException.errors_base;
        ((Symbol)(Jlisp.lit[Lit.resources])).car/*value*/ =
            new Cons(new LispSmallInteger(itime),
                new Cons(new LispSmallInteger(ispace),
                    new Cons(new LispSmallInteger(iio),
                        new Cons(new LispSmallInteger(ierrors), Environment.nil))));
        }finally{
 	  	         ResourceException.time_base    = save_time_base;
 	  	         ResourceException.space_base   = save_space_base;
 	  	         ResourceException.io_base      = save_io_base;
 	  	         ResourceException.errors_base  = save_errors_base;
 	  	         ResourceException.time_limit   = save_time_limit;
 	  	         ResourceException.space_limit  = save_space_limit;
 	  	         ResourceException.io_limit     = save_io_limit;
                         ResourceException.errors_limit = save_errors_limit;
        }
        if (ok) return new Cons(r, Environment.nil);
        else return Environment.nil;
    }
}

class EupbvFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EvalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        arg1 = arg1.eval();
        if (Specfn.progEvent != Specfn.NONE)
        {   Specfn.progEvent = Specfn.NONE;
            return error("GO or RETURN out of context");
        }
        return arg1;
    }
}

class Eval_whenFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EvectorpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class EvlisFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispObject r = Environment.nil;
        while (!arg1.atom)
        {   LispObject a1 = arg1;
            r = new Cons(a1.car.eval(), r);
            if (Specfn.progEvent != Specfn.NONE) return Environment.nil;
            arg1 = a1.cdr;
        }
        arg1 = Environment.nil;
        while (!r.atom)
        {   LispObject a1 = r;
            r = a1.cdr;
            a1.cdr = arg1;
            arg1 = a1;
        }
        return arg1;
    }
}

class ExpandFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class ExplodeFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printEscape);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodetostringFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return new LispString(Fns.explodeToString(arg1));
    }
}

class Explode2Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class Explode2lcFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printLower);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class Explode2lcnFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(false);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printLower);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class Explode2nFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(false);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class Explode2ucFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printUpper);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class Explode2ucnFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(false);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printUpper);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodebinaryFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+
                       LispObject.printEscape+
                       LispObject.printBinary);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodecFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodecnFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(false);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodehexFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+
                       LispObject.printEscape+
                       LispObject.printHex);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodenFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(false);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+LispObject.printEscape);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}

class ExplodeoctalFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream f = new LispExploder(true);
        LispObject save = Jlisp.lit[Lit.std_output].car/*value*/;
        try
        {   Jlisp.lit[Lit.std_output].car/*value*/ = f;
            arg1.print(LispObject.noLineBreak+
                       LispObject.printEscape+
                       LispObject.printOctal);
        }
        finally
        {   Jlisp.lit[Lit.std_output].car/*value*/ = save;
        }
        return Fns.reversip(f.exploded);
    }
}


class Fetch_urlFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Fgetv32Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Fgetv64Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class File_readablepFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class File_writeablepFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class FiledateFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        String s;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            s = ((Symbol)arg1).pname;
        }
        else if (arg1 instanceof LispString) s = ((LispString)arg1).string;
        else return Environment.nil;
        return LispStream.fileDate(s);
    }
}

class FilepFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
// use filedate(arg1) here.
        String s;
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            s = ((Symbol)arg1).pname;
        }
        else if (arg1 instanceof LispString) s = ((LispString)arg1).string;
        else return Environment.nil;
        return LispStream.fileDate(s);
    }
}


class FlagFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        while (!arg1.atom)
        {   LispObject p = arg1;
            Symbol name = (Symbol)p.car;
            arg1 = p.cdr;
            Fns.put(name, arg2, Jlisp.lispTrue);
        }
        return arg1;
    }
}

class FlagpFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        LispObject res = Fns.get(arg1, arg2);
        if (res != Environment.nil) res = Jlisp.lispTrue;
        return res;
    }
}

class FlagpStarStarFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        LispObject res = Fns.get(arg1, arg2);
        if (res != Environment.nil) res = Jlisp.lispTrue;
        return res;
    }
}

class FlagpcarFn extends BuiltinFunction
{
    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1.atom) return Environment.nil;
        arg1 = arg1.car;
        LispObject res = Fns.get(arg1, arg2);
        if (res != Environment.nil) res = Jlisp.lispTrue;
        return res;
    }
}

class FluidFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class FluidpFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1)
    {
        return Fns.get(arg1, Jlisp.lit[Lit.special]);
    }
}

class FlushFn extends BuiltinFunction
{
    public LispObject op0() throws Exception
    {
        LispStream ee = 
            (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
        ee.flush();
        return Environment.nil;
    }
    public LispObject op1(LispObject arg1) throws Exception
    {
        LispStream ee = (LispStream)arg1;
        ee.flush();
        return Environment.nil;
    }
}

class FormatFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Fp_evaluateFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Fputv32Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class Fputv64Fn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        return error(name + " not yet implemented");
    }
}

class FuncallFn extends BuiltinFunction
{
    public LispObject op1(LispObject arg1) throws Exception
    {
        if (arg1 instanceof Symbol)
        {   return ((Symbol)arg1).fn.op0();
        }
        else if (arg1 instanceof LispFunction)
        {   return ((LispFunction)arg1).op0();
        }
        else return Fns.apply0(arg1);
    }

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        if (arg1 instanceof Symbol)
        {   return ((Symbol)arg1).fn.op1(arg2);
        }
        else if (arg1 instanceof LispFunction)
        {   return ((LispFunction)arg1).op1(arg2);
        }
        else return Fns.apply1(arg1, arg2);
    }

    public LispObject opn(LispObject [] aa) throws Exception
    {
        int n = aa.length;
        LispObject arg1 = aa[0];
        if (n == 3)
        {   if (arg1 instanceof Symbol)
            {   return ((Symbol)arg1).fn.op2(aa[1], aa[2]);
            }
            else if (arg1 instanceof LispFunction)
            {   return ((LispFunction)arg1).op2(aa[1], aa[2]);
            }
            else return error("function in funcall is invalid");
        }
        LispObject [] args = new LispObject [n-1];
        for (int i = 0;i");
    }

    public void print(int n) throws ResourceException
    {
        name.completeName();
        Jlisp.print("#Autoload<" + name.pname + ">");
    }
    
    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else
	{   LispReader.objects.add(this);
	    LispReader.stack.push(name);
	    LispReader.stack.push(data);
	}
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w);
	else
	{   if (w != null)
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
	    }
	    Jlisp.odump.write(X_AUTOLOAD);
	    LispReader.stack.push(data);
	    LispReader.stack.push(name);
	}
    }
    
}

// End of LispFunction.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/lisp/Undefined.java0000644000175000017500000000616011555446662031061 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.lisp;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;

public class Undefined extends LispFunction
{

    public Undefined(String name)
    {
        this.name = name;
    }

    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    byte [] rep = name.getBytes("UTF8");
	    int length = rep.length;
	    putPrefix(length, X_UNDEF1);
	    for (int i=0; i>4) & 0xf) + "<");
    body.print(fg);
    Jlisp.print(">");
}

public LispObject op0() throws Exception
{
    if (((nargs>>4) & 0xf) != 0)
        error("Call with wrong number of arguments", body);
    return ((Symbol)body).fn.op0();
}

public LispObject op1(LispObject a1) throws Exception
{
    if (((nargs>>4) & 0xf) != 1)
        error("Call with wrong number of arguments", body);
    if ((nargs & 0xf) == 0) return ((Symbol)body).fn.op0();
    else return ((Symbol)body).fn.op1(a1);
}

public LispObject op2(LispObject a1, LispObject a2) throws Exception
{
    if (((nargs>>4) & 0xf) != 2)
        error("Call with wrong number of arguments", body);
    switch ((nargs & 0xf))
    {
case 0: return ((Symbol)body).fn.op0();
case 1: return ((Symbol)body).fn.op1(a1);
default:return ((Symbol)body).fn.op2(a1, a2);
    }
}

public LispObject opn(LispObject [] args) throws Exception
{
    if (((nargs>>4) & 0xf) != args.length) 
        error("Call with wrong number of arguments", body);
    switch ((nargs & 0xf))
    {
case 0: return ((Symbol)body).fn.op0();
case 1: return ((Symbol)body).fn.op1(args[0]);
case 2: return ((Symbol)body).fn.op2(args[0], args[1]);
default:return ((Symbol)body).fn.opn(
            new LispObject [] { args[0], args[1], args[2] });
    }
}

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
        LispReader.stack.push(body);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
            Jlisp.odump.write(X_CALLAS);
            Jlisp.odump.write(nargs);
            LispReader.stack.push(body);
	}
    }
    
}

// End of CallAs.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/lisp/Macro.java0000644000175000017500000001260111555446662030216 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.lisp;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


// A Lisp macro is really very much like an ordinary
// function with exactly one argument. It is the way that the
// interpreted processes it that makes it different. Well actually because
// of views on Common Lisp compatibility the function that is a macro
// has one essential argument and one optional one (which I never use!)

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.functions.builtin.Fns;

import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class Macro extends LispFunction
{
    public LispObject body;

    public void iprint() throws ResourceException
    {
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 7 > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("[Macro:");
        body.blankprint();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 1 > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("]");
    }
											    
    public void blankprint() throws ResourceException
    {
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 7 >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print("[Macro:");
        body.blankprint();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 1 > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("]");
    }
											    
    public Macro()
    {
    }
    
    public Macro(LispObject def) throws Exception
    {
        body = new Cons(Jlisp.lit[Lit.lambda], def);
    }
    
    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
        LispReader.stack.push(body);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
            Jlisp.odump.write(X_MACRO);
            LispReader.stack.push(body);
	}
    }
    
    public LispObject op1(LispObject arg1) throws Exception
    {
        Fns.args[0] = arg1;
        return Fns.applyInner(body, 1);
    }

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        Fns.args[0] = arg1;
        Fns.args[1] = arg2;
        return Fns.applyInner(body, 2);
    }

}

// End of Macro.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/lisp/LispJavaFunction.java0000644000175000017500000000501711546225657032376 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.lisp;

//NOT USED ...SEE JavaFn.java instead

import org.mathpiper.mpreduce.LispObject;

// LispJavaFuncion.java 
// created 27/02/02
// classes I create will be subclasses of LispJavaFunction
// just to provide a level to put more mess later on

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


abstract class LispJavaFunction extends LispFunction
{
	LispObject[] constants;
}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/lisp/LispFunction.java0000644000175000017500000001055511555446662031600 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.lisp;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public abstract class LispFunction extends LispObject
{
    public String name = "unknown-function";

    public LispObject op0() throws Exception
    {
        return error("undefined " + name + " with 0 args");
    }

    public LispObject op1(LispObject a1) throws Exception
    {
        return error("undefined " + name + " with 1 arg");
    }

    public LispObject op2(LispObject a1, LispObject a2) throws Exception
    {
        return error("undefined " + name + " with 2 args");
    }

    public LispObject opn(LispObject [] args) throws Exception
    {
        return error("undefined " + name + " with " + args.length + " args");
    }

    public LispObject error(String s) throws Exception
    {
        return Jlisp.error(s);
    }

    public LispObject error(String s, LispObject a) throws Exception
    {
        return Jlisp.error(s, a);
    }

    public void iprint() throws ResourceException
    {
        String s = "#Fn<" + name + ">";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = "#Fn<" + name + ">";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
    }
    

}

// End of LispFunction.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/lisp/Interpreted.java0000644000175000017500000001164411555446662031450 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.lisp;


//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


// If a symbol has an interpreted definition its
// associated function is this job, which knows how to
// extract the saved definition and activate it.

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.functions.builtin.Fns;

import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class Interpreted extends LispFunction
{
    public LispObject body;

    public void iprint() throws ResourceException
    {
        body.iprint();	
    }
    
    public void blankprint() throws ResourceException
    {
        body.blankprint();	
    }
    
    public Interpreted()
    {
    }
    
    public Interpreted(LispObject def) throws ResourceException
    {
        body = new Cons(Jlisp.lit[Lit.lambda], def);
    }
    
    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else 
	{   LispReader.objects.add(this);
            LispReader.stack.push(body);
        }
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    Jlisp.odump.write(X_INTERP);
            LispReader.stack.push(body);
	}
    }
    

// All interpreted function calls check that the number of arguments
// actually passed agrees with the number expected. Shallow binding is
// used for all variables.

    public LispObject op0() throws Exception
    {
        return Fns.applyInner(body, 0);
    }

    public LispObject op1(LispObject arg1) throws Exception
    {
        Fns.args[0] = arg1;
        return Fns.applyInner(body, 1);
    }

    public LispObject op2(LispObject arg1, LispObject arg2) throws Exception
    {
        Fns.args[0] = arg1;
        Fns.args[1] = arg2;
        return Fns.applyInner(body, 2);
    }

    public LispObject opn(LispObject [] actual) throws Exception
    {
        int n = actual.length;
        for (int i=0; i 0xff)
    {   sb.append(Integer.toHexString(nargs >> 8));
        sb.append(":");
    }
    sb.append(Integer.toString(nargs & 0xff));
    sb.append("<");
    if (bytecodes == null) sb.append("null");
    else for (int i=0; i");
    return sb.toString();
}

public void iprint() throws ResourceException
{
    String s = printAs();
    if ((currentFlags & noLineBreak) == 0 &&
        currentOutput.column + s.length() > currentOutput.lineLength)
        currentOutput.println();
    currentOutput.print(s);
}

public void blankprint() throws ResourceException
{
    String s = printAs();
    if ((currentFlags & noLineBreak) == 0 &&
        currentOutput.column + s.length() >= currentOutput.lineLength)
        currentOutput.println();
    else currentOutput.print(" ");
    currentOutput.print(s);
}

public LispObject op0() throws Exception
{
    if (nargs != 0) Jlisp.error("Wrong number of arguments for " + name);
    return interpret(0);
}

public LispObject op1(LispObject a1) throws Exception
{
    if (nargs != 1) Jlisp.error("Wrong number of arguments for " + name);
    int spsave = sp;
    LispObject r = Environment.nil;
    stack[++sp] = a1;
    try
    {   r = interpret(0);
        sp--;
    }
    catch (Exception e)
    {   sp = spsave;
        throw e;
    }
    return r;
}

public LispObject op2(LispObject a1, LispObject a2) throws Exception
{
    if (nargs != 2) Jlisp.error("Wrong number of arguments for " + name);
    int spsave = sp;
    LispObject r = Environment.nil;
    stack[++sp] = a1;
    stack[++sp] = a2;
    try
    {   r = interpret(0);
        sp -= 2;
    }
    catch (Exception e)
    {   sp = spsave;
        throw e;
    }
    return r;
}

public LispObject opn(LispObject [] args) throws Exception
{
    int n = args.length;
    if (nargs != n) Jlisp.error("Wrong number of arguments for " + name);
    int spsave = sp;
    for (int i=0; i 3)
    {   if (n != (bytecodes[0] & 0xff)) 
        {   sp = spsave;
            error("Wrong number of args");
        }
        n = 1;
    }
    else n = 0;
    LispObject r = Environment.nil;
    try
    {   r = interpret(n);
        sp = spsave;
    }
    catch (Exception e)
    {   sp = spsave;
        throw e;
    }
    return r;
}


static LispFunction builtin0[], builtin1[], builtin2[], builtin3[];

static LispFunction lookupBuiltin(String s) throws ResourceException
{
    LispFunction r = (LispFunction)Jlisp.builtinFunctions.get(s);
    if (r == null) Jlisp.println("Function " + s + " not found");
    return r;
}

static int BIbatchp, BIdate, BIeject, BIerror1, BIgctime,
    BIgensym, BIlposn, BInext_random, BIposn, BIread,
    BIreadch, BIterpri, BItime, BItyi, BIload_spid,
    BIabs, BIadd1, BIatan, BIapply0, BIatom,
    BIboundp, BIchar_code, BIclose, BIcodep, BIcompress,
    BIconstantp, BIdigit, BIendp, BIeval, BIevenp,
    BIevlis, BIexplode, BIexplode2lc, BIexplode2, BIexplodec,
    BIfixp, BIfloat, BIfloatp, BIsymbol_specialp, BIgc,
    BIgensym1, BIgetenv, BIsymbol_globalp, BIiadd1, BIsymbolp,
    BIiminus, BIiminusp, BIindirect, BIintegerp, BIintern,
    BIisub1, BIlength, BIlengthc, BIlinelength, BIliter,
    BIload_module, BIlognot, BImacroexpand, BImacroexpand_1, BImacro_function,
    BImake_bps, BImake_global, BImake_simple_string, BImake_special, BIminus,
    BIminusp, BImkvect, BImodular_minus, BImodular_number, BImodular_reciprocal,
    BInull, BIoddp, BIonep, BIpagelength, BIpairp,
    BIplist, BIplusp, BIprin, BIprinc, BIprint,
    BIprintc, BIrandom, BIrational, BIload, BIrds,
    BIremd, BIreverse, BIreversip, BIreversip2, BIseprp, BIset_small_modulus,
    BIspaces, BIxtab, BIspecial_char, BIspecial_form_p, BIspool,
    BIstop, BIstringp, BIsub1, BIsymbol_env, BIsymbol_function,
    BIsymbol_name, BIsymbol_value, BIsystem, BIfix, BIttab,
    BItyo, BIremob, BIunmake_global, BIunmake_special, BIupbv,
    BIvectorp, BIsimple_vectorp, BIverbos, BIwrs, BIzerop,
    BIcar, BIcdr, BIcaar, BIcadr, BIcdar,
    BIcddr, BIqcar, BIqcdr, BIqcaar, BIqcadr,
    BIqcdar, BIqcddr, BIncons, BInumberp, BIis_spid,
    BIspid_to_nil, BImv_listSTAR, BIappend, BIash, BIassoc,
    BIatsoc, BIdeleq, BIdelete, BIdivide, BIeqcar,
    BIeql, BIeqn, BIexpt, BIflag, BIflagpcar,
    BIgcdn, BIgeq, BIgetv, BIgreaterp, BIidifference,
    BIigreaterp, BIilessp, BIimax, BIimin, BIiplus2,
    BIiquotient, BIiremainder, BIirightshift, BIitimes2, BIlcm,
    BIleq, BIlessp, BImake_random_state, BImax2, BImember,
    BImemq, BImin2, BImod, BImodular_difference, BImodular_expt,
    BImodular_plus, BImodular_quotient, BImodular_times, BInconc, BIneq,
    BIorderp, BIordp, BIquotient, BIremainder, BIremflag,
    BIremprop, BIrplaca, BIrplacd, BIschar, BIset,
    BIsmemq, BIsubla, BIsublis, BIsymbol_set_definition, BIsymbol_set_env,
    BIxcons, BIequal, BIeq, BIcons,
    BIlist2, BIget, BIqgetv, BIflagp, BIapply1,
    BIdifference, BIplus2, BItimes2, BIequalcar, BIiequal, BIbps_putv,
    BIerrorset, BIlist2STAR, BIlist3, BIputprop, BIputv,
    BIputv_char, BIsubst, BIapply2, BIacons;

public static void setupBuiltins() throws ResourceException
{
    builtin0 = new LispFunction[15];
    builtin1 = new LispFunction[114];
    builtin2 = new LispFunction[73];
    builtin3 = new LispFunction[10];

    builtin0[0]   = lookupBuiltin("batchp");               BIbatchp =                0;
    builtin0[1]   = lookupBuiltin("date");                 BIdate =                  1;
    builtin0[2]   = lookupBuiltin("eject");                BIeject =                 2;
    builtin0[3]   = lookupBuiltin("error1");               BIerror1 =                3;
    builtin0[4]   = lookupBuiltin("gctime");               BIgctime =                4;
    builtin0[5]   = lookupBuiltin("gensym");               BIgensym =                5;
    builtin0[6]   = lookupBuiltin("lposn");                BIlposn =                 6;
//  builtin0[7]   = lookupBuiltin("next-random");          BInext_random =           7;
    builtin0[8]   = lookupBuiltin("posn");                 BIposn =                  8;
    builtin0[9]   = lookupBuiltin("read");                 BIread =                  9;
    builtin0[10]  = lookupBuiltin("readch");               BIreadch =                10;
    builtin0[11]  = lookupBuiltin("terpri");               BIterpri =                11;
    builtin0[12]  = lookupBuiltin("time");                 BItime =                  12;
//  builtin0[13]  = lookupBuiltin("tyi");                  BItyi =                   13;
//  builtin0[14]  = lookupBuiltin("load-spid");            BIload_spid =             14;

    builtin1[0]   = lookupBuiltin("abs");                  BIabs =                   0;
    builtin1[1]   = lookupBuiltin("add1");                 BIadd1 =                  1;
    builtin1[2]   = lookupBuiltin("atan");                 BIatan =                  2;
    builtin1[3]   = lookupBuiltin("apply0");               BIapply0 =                3;
    builtin1[4]   = lookupBuiltin("atom");                 BIatom =                  4;
    builtin1[5]   = lookupBuiltin("boundp");               BIboundp =                5;
    builtin1[6]   = lookupBuiltin("char-code");            BIchar_code =             6;
    builtin1[7]   = lookupBuiltin("close");                BIclose =                 7;
    builtin1[8]   = lookupBuiltin("codep");                BIcodep =                 8;
    builtin1[9]   = lookupBuiltin("compress");             BIcompress =              9;
    builtin1[10]  = lookupBuiltin("constantp");            BIconstantp =             10;
    builtin1[11]  = lookupBuiltin("digit");                BIdigit =                 11;
    builtin1[12]  = lookupBuiltin("endp");                 BIendp =                  12;
    builtin1[13]  = lookupBuiltin("eval");                 BIeval =                  13;
    builtin1[14]  = lookupBuiltin("evenp");                BIevenp =                 14;
    builtin1[15]  = lookupBuiltin("evlis");                BIevlis =                 15;
    builtin1[16]  = lookupBuiltin("explode");              BIexplode =               16;
    builtin1[17]  = lookupBuiltin("explode2lc");           BIexplode2lc =            17;
    builtin1[18]  = lookupBuiltin("explode2");             BIexplode2 =              18;
    builtin1[18]  = lookupBuiltin("explodec");             BIexplodec =              18;
    builtin1[19]  = lookupBuiltin("fixp");                 BIfixp =                  19;
    builtin1[20]  = lookupBuiltin("float");                BIfloat =                 20;
    builtin1[21]  = lookupBuiltin("floatp");               BIfloatp =                21;
//  builtin1[22]  = lookupBuiltin("symbol-specialp");      BIsymbol_specialp =       22;
//  builtin1[23]  = lookupBuiltin("gc");                   BIgc =                    23;
    builtin1[24]  = lookupBuiltin("gensym1");              BIgensym1 =               24;
    builtin1[25]  = lookupBuiltin("getenv");               BIgetenv =                25;
//  builtin1[26]  = lookupBuiltin("symbol-globalp");       BIsymbol_globalp =        26;
    builtin1[27]  = lookupBuiltin("iadd1");                BIiadd1 =                 27;
    builtin1[28]  = lookupBuiltin("symbolp");              BIsymbolp =               28;
    builtin1[29]  = lookupBuiltin("iminus");               BIiminus =                29;
    builtin1[30]  = lookupBuiltin("iminusp");              BIiminusp =               30;
    builtin1[31]  = lookupBuiltin("indirect");             BIindirect =              31;
    builtin1[32]  = lookupBuiltin("integerp");             BIintegerp =              32;
    builtin1[33]  = lookupBuiltin("intern");               BIintern =                33;
    builtin1[34]  = lookupBuiltin("isub1");                BIisub1 =                 34;
    builtin1[35]  = lookupBuiltin("length");               BIlength =                35;
    builtin1[36]  = lookupBuiltin("lengthc");              BIlengthc =               36;
    builtin1[37]  = lookupBuiltin("linelength");           BIlinelength =            37;
    builtin1[38]  = lookupBuiltin("liter");                BIliter =                 38;
    builtin1[39]  = lookupBuiltin("load-module");          BIload_module =           39;
    builtin1[40]  = lookupBuiltin("lognot");               BIlognot =                40;
    builtin1[41]  = lookupBuiltin("macroexpand");          BImacroexpand =           41;
    builtin1[42]  = lookupBuiltin("macroexpand-1");        BImacroexpand_1 =         42;
    builtin1[43]  = lookupBuiltin("macro-function");       BImacro_function =        43;
    builtin1[44]  = lookupBuiltin("make-bps");             BImake_bps =              44;
    builtin1[45]  = lookupBuiltin("make-global");          BImake_global =           45;
    builtin1[46]  = lookupBuiltin("make-simple-string");   BImake_simple_string =    46;
    builtin1[47]  = lookupBuiltin("make-special");         BImake_special =          47;
    builtin1[48]  = lookupBuiltin("minus");                BIminus =                 48;
    builtin1[49]  = lookupBuiltin("minusp");               BIminusp =                49;
    builtin1[50]  = lookupBuiltin("mkvect");               BImkvect =                50;
    builtin1[51]  = lookupBuiltin("modular-minus");        BImodular_minus =         51;
    builtin1[52]  = lookupBuiltin("modular-number");       BImodular_number =        52;
    builtin1[53]  = lookupBuiltin("modular-reciprocal");   BImodular_reciprocal =    53;
    builtin1[54]  = lookupBuiltin("null");                 BInull =                  54;
    builtin1[55]  = lookupBuiltin("oddp");                 BIoddp =                  55;
    builtin1[56]  = lookupBuiltin("onep");                 BIonep =                  56;
    builtin1[57]  = lookupBuiltin("pagelength");           BIpagelength =            57;
    builtin1[58]  = lookupBuiltin("pairp");                BIpairp =                 58;
    builtin1[59]  = lookupBuiltin("plist");                BIplist =                 59;
    builtin1[60]  = lookupBuiltin("plusp");                BIplusp =                 60;
    builtin1[61]  = lookupBuiltin("prin");                 BIprin =                  61;
    builtin1[62]  = lookupBuiltin("princ");                BIprinc =                 62;
    builtin1[63]  = lookupBuiltin("print");                BIprint =                 63;
    builtin1[64]  = lookupBuiltin("printc");               BIprintc =                64;
//  builtin1[65]  = lookupBuiltin("random");               BIrandom =                65;
    builtin1[66]  = lookupBuiltin("rational");             BIrational =              66;
//  builtin1[67]  = lookupBuiltin("load");                 BIload =                  67;
    builtin1[68]  = lookupBuiltin("rds");                  BIrds =                   68;
    builtin1[69]  = lookupBuiltin("remd");                 BIremd =                  69;
    builtin1[70]  = lookupBuiltin("reverse");              BIreverse =               70;
    builtin1[71]  = lookupBuiltin("reversip");             BIreversip =              71;
    builtin1[72]  = lookupBuiltin("seprp");                BIseprp =                 72;
    builtin1[73]  = lookupBuiltin("set-small-modulus");    BIset_small_modulus =     73;
    builtin1[74]  = lookupBuiltin("spaces");               BIspaces =                74;
    builtin1[74]  = lookupBuiltin("xtab");                 BIxtab =                  74;
    builtin1[75]  = lookupBuiltin("special-char");         BIspecial_char =          75;
    builtin1[76]  = lookupBuiltin("special-form-p");       BIspecial_form_p =        76;
    builtin1[77]  = lookupBuiltin("spool");                BIspool =                 77;
    builtin1[78]  = lookupBuiltin("stop");                 BIstop =                  78;
    builtin1[79]  = lookupBuiltin("stringp");              BIstringp =               79;
    builtin1[80]  = lookupBuiltin("sub1");                 BIsub1 =                  80;
    builtin1[81]  = lookupBuiltin("symbol-env");           BIsymbol_env =            81;
    builtin1[82]  = lookupBuiltin("symbol-function");      BIsymbol_function =       82;
    builtin1[83]  = lookupBuiltin("symbol-name");          BIsymbol_name =           83;
    builtin1[84]  = lookupBuiltin("symbol-value");         BIsymbol_value =          84;
    builtin1[85]  = lookupBuiltin("system");               BIsystem =                85;
    builtin1[86]  = lookupBuiltin("fix");                  BIfix =                   86;
    builtin1[87]  = lookupBuiltin("ttab");                 BIttab =                  87;
    builtin1[88]  = lookupBuiltin("tyo");                  BItyo =                   88;
    builtin1[89]  = lookupBuiltin("remob");                BIremob =                 89;
    builtin1[90]  = lookupBuiltin("unmake-global");        BIunmake_global =         90;
    builtin1[91]  = lookupBuiltin("unmake-special");       BIunmake_special =        91;
    builtin1[92]  = lookupBuiltin("upbv");                 BIupbv =                  92;
    builtin1[93]  = lookupBuiltin("vectorp");              BIvectorp =               93;
//  builtin1[93]  = lookupBuiltin("simple-vectorp");       BIsimple_vectorp =        93;
    builtin1[94]  = lookupBuiltin("verbos");               BIverbos =                94;
    builtin1[95]  = lookupBuiltin("wrs");                  BIwrs =                   95;
    builtin1[96]  = lookupBuiltin("zerop");                BIzerop =                 96;
    builtin1[97]  = lookupBuiltin("car");                  BIcar =                   97;
    builtin1[98]  = lookupBuiltin("cdr");                  BIcdr =                   98;
    builtin1[99]  = lookupBuiltin("caar");                 BIcaar =                  99;
    builtin1[100] = lookupBuiltin("cadr");                 BIcadr =                  100;
    builtin1[101] = lookupBuiltin("cdar");                 BIcdar =                  101;
    builtin1[102] = lookupBuiltin("cddr");                 BIcddr =                  102;
    builtin1[103] = lookupBuiltin("qcar");                 BIqcar =                  103;
    builtin1[104] = lookupBuiltin("qcdr");                 BIqcdr =                  104;
    builtin1[105] = lookupBuiltin("qcaar");                BIqcaar =                 105;
    builtin1[106] = lookupBuiltin("qcadr");                BIqcadr =                 106;
    builtin1[107] = lookupBuiltin("qcdar");                BIqcdar =                 107;
    builtin1[108] = lookupBuiltin("qcddr");                BIqcddr =                 108;
    builtin1[109] = lookupBuiltin("ncons");                BIncons =                 109;
    builtin1[110] = lookupBuiltin("numberp");              BInumberp =               110;
//  builtin1[111] = lookupBuiltin("is-spid");              BIis_spid =               111;
//  builtin1[112] = lookupBuiltin("spid-to-nil");          BIspid_to_nil =           112;
//  builtin1[113] = lookupBuiltin("mv-list*");             BImv_listSTAR =           113;

    builtin2[0]   = lookupBuiltin("append");               BIappend =                0;
    builtin2[1]   = lookupBuiltin("ash");                  BIash =                   1;
    builtin2[2]   = lookupBuiltin("assoc");                BIassoc =                 2;
    builtin2[3]   = lookupBuiltin("atsoc");                BIatsoc =                 3;
    builtin2[4]   = lookupBuiltin("deleq");                BIdeleq =                 4;
    builtin2[5]   = lookupBuiltin("delete");               BIdelete =                5;
    builtin2[6]   = lookupBuiltin("divide");               BIdivide =                6;
    builtin2[7]   = lookupBuiltin("eqcar");                BIeqcar =                 7;
    builtin2[8]   = lookupBuiltin("eql");                  BIeql =                   8;
    builtin2[9]   = lookupBuiltin("eqn");                  BIeqn =                   9;
    builtin2[10]  = lookupBuiltin("expt");                 BIexpt =                  10;
    builtin2[11]  = lookupBuiltin("flag");                 BIflag =                  11;
    builtin2[12]  = lookupBuiltin("flagpcar");             BIflagpcar =              12;
    builtin2[13]  = lookupBuiltin("gcdn");                 BIgcdn =                  13;
    builtin2[14]  = lookupBuiltin("geq");                  BIgeq =                   14;
    builtin2[15]  = lookupBuiltin("getv");                 BIgetv =                  15;
    builtin2[16]  = lookupBuiltin("greaterp");             BIgreaterp =              16;
    builtin2[17]  = lookupBuiltin("idifference");          BIidifference =           17;
    builtin2[18]  = lookupBuiltin("igreaterp");            BIigreaterp =             18;
    builtin2[19]  = lookupBuiltin("ilessp");               BIilessp =                19;
    builtin2[20]  = lookupBuiltin("imax");                 BIimax =                  20;
    builtin2[21]  = lookupBuiltin("imin");                 BIimin =                  21;
    builtin2[22]  = lookupBuiltin("iplus2");               BIiplus2 =                22;
    builtin2[23]  = lookupBuiltin("iquotient");            BIiquotient =             23;
    builtin2[24]  = lookupBuiltin("iremainder");           BIiremainder =            24;
    builtin2[25]  = lookupBuiltin("irightshift");          BIirightshift =           25;
    builtin2[26]  = lookupBuiltin("itimes2");              BIitimes2 =               26;
//  builtin2[27]  = lookupBuiltin("lcm");                  BIlcm =                   27;
    builtin2[28]  = lookupBuiltin("leq");                  BIleq =                   28;
    builtin2[29]  = lookupBuiltin("lessp");                BIlessp =                 29;
    builtin2[30]  = lookupBuiltin("make-random-state");    BImake_random_state =     30;
    builtin2[31]  = lookupBuiltin("max2");                 BImax2 =                  31;
    builtin2[32]  = lookupBuiltin("member");               BImember =                32;
    builtin2[33]  = lookupBuiltin("memq");                 BImemq =                  33;
    builtin2[34]  = lookupBuiltin("min2");                 BImin2 =                  34;
    builtin2[35]  = lookupBuiltin("mod");                  BImod =                   35;
    builtin2[36]  = lookupBuiltin("modular-difference");   BImodular_difference =    36;
    builtin2[37]  = lookupBuiltin("modular-expt");         BImodular_expt =          37;
    builtin2[38]  = lookupBuiltin("modular-plus");         BImodular_plus =          38;
    builtin2[39]  = lookupBuiltin("modular-quotient");     BImodular_quotient =      39;
    builtin2[40]  = lookupBuiltin("modular-times");        BImodular_times =         40;
    builtin2[41]  = lookupBuiltin("nconc");                BInconc =                 41;
    builtin2[42]  = lookupBuiltin("neq");                  BIneq =                   42;
    builtin2[43]  = lookupBuiltin("orderp");               BIorderp =                43;
    builtin2[43]  = lookupBuiltin("ordp");                 BIordp =                  43;
    builtin2[44]  = lookupBuiltin("quotient");             BIquotient =              44;
    builtin2[45]  = lookupBuiltin("remainder");            BIremainder =             45;
    builtin2[46]  = lookupBuiltin("remflag");              BIremflag =               46;
    builtin2[47]  = lookupBuiltin("remprop");              BIremprop =               47;
    builtin2[48]  = lookupBuiltin("rplaca");               BIrplaca =                48;
    builtin2[49]  = lookupBuiltin("rplacd");               BIrplacd =                49;
    builtin2[50]  = lookupBuiltin("schar");                BIschar =                 50;
    builtin2[51]  = lookupBuiltin("set");                  BIset =                   51;
    builtin2[52]  = lookupBuiltin("smemq");                BIsmemq =                 52;
    builtin2[53]  = lookupBuiltin("subla");                BIsubla =                 53;
    builtin2[54]  = lookupBuiltin("sublis");               BIsublis =                54;
    builtin2[55]  = lookupBuiltin("symbol-set-definition");BIsymbol_set_definition = 55;
    builtin2[56]  = lookupBuiltin("symbol-set-env");       BIsymbol_set_env =        56;
////builtin2[57]  = lookupBuiltin("times2");               BItimes2 =                57;
    builtin2[58]  = lookupBuiltin("xcons");                BIxcons =                 58;
    builtin2[59]  = lookupBuiltin("equal");                BIequal =                 59;
    builtin2[60]  = lookupBuiltin("eq");                   BIeq =                    60;
    builtin2[61]  = lookupBuiltin("cons");                 BIcons =                  61;
    builtin2[62]  = lookupBuiltin("list2");                BIlist2 =                 62;
    builtin2[63]  = lookupBuiltin("get");                  BIget =                   63;
    builtin2[64]  = lookupBuiltin("qgetv");                BIqgetv =                 64;
    builtin2[65]  = lookupBuiltin("flagp");                BIflagp =                 65;
    builtin2[66]  = lookupBuiltin("apply1");               BIapply1 =                66;
    builtin2[67]  = lookupBuiltin("difference");           BIdifference =            67;
    builtin2[68]  = lookupBuiltin("plus2");                BIplus2 =                 68;
    builtin2[69]  = lookupBuiltin("times2");               BItimes2 =                69;
    builtin2[70]  = lookupBuiltin("equalcar");             BIequalcar =              70;
    builtin2[71]  = lookupBuiltin("iequal");               BIiequal =                71;
    builtin2[72]  = lookupBuiltin("reversip");             BIreversip2 =             72;

    builtin3[0]   = lookupBuiltin("bps-putv");             BIbps_putv =              0;
    builtin3[1]   = lookupBuiltin("errorset");             BIerrorset =              1;
    builtin3[2]   = lookupBuiltin("list2*");               BIlist2STAR =             2;
    builtin3[3]   = lookupBuiltin("list3");                BIlist3 =                 3;
//  builtin3[4]   = lookupBuiltin("putprop");              BIputprop =               4;
    builtin3[5]   = lookupBuiltin("putv");                 BIputv =                  5;
    builtin3[6]   = lookupBuiltin("putv-char");            BIputv_char =             6;
    builtin3[7]   = lookupBuiltin("subst");                BIsubst =                 7;
    builtin3[8]   = lookupBuiltin("apply2");               BIapply2 =                8;
    builtin3[9]   = lookupBuiltin("acons");                BIacons =                 9;
}



static final int LOADLOC       =     0x00;
static final int LOADLOC0      =     0x01;
static final int LOADLOC1      =     0x02;
static final int LOADLOC2      =     0x03;
static final int LOADLOC3      =     0x04;
static final int LOADLOC4      =     0x05;
static final int LOADLOC5      =     0x06;
static final int LOADLOC6      =     0x07;
static final int LOADLOC7      =     0x08;
static final int LOADLOC8      =     0x09;
static final int LOADLOC9      =     0x0a;
static final int LOADLOC10     =     0x0b;
static final int LOADLOC11     =     0x0c;
static final int LOC0LOC1      =     0x0d;
static final int LOC1LOC2      =     0x0e;
static final int LOC2LOC3      =     0x0f;
static final int LOC1LOC0      =     0x10;
static final int LOC2LOC1      =     0x11;
static final int LOC3LOC2      =     0x12;
static final int VNIL          =     0x13;
static final int LOADLIT       =     0x14;
static final int LOADLIT1      =     0x15;
static final int LOADLIT2      =     0x16;
static final int LOADLIT3      =     0x17;
static final int LOADLIT4      =     0x18;
static final int LOADLIT5      =     0x19;
static final int LOADLIT6      =     0x1a;
static final int LOADLIT7      =     0x1b;
static final int LOADFREE      =     0x1c;
static final int LOADFREE1     =     0x1d;
static final int LOADFREE2     =     0x1e;
static final int LOADFREE3     =     0x1f;
static final int LOADFREE4     =     0x20;
static final int STORELOC      =     0x21;
static final int STORELOC0     =     0x22;
static final int STORELOC1     =     0x23;
static final int STORELOC2     =     0x24;
static final int STORELOC3     =     0x25;
static final int STORELOC4     =     0x26;
static final int STORELOC5     =     0x27;
static final int STORELOC6     =     0x28;
static final int STORELOC7     =     0x29;
static final int STOREFREE     =     0x2a;
static final int STOREFREE1    =     0x2b;
static final int STOREFREE2    =     0x2c;
static final int STOREFREE3    =     0x2d;
static final int LOADLEX       =     0x2e;
static final int STORELEX      =     0x2f;
static final int CLOSURE       =     0x30;
static final int CARLOC0       =     0x31;
static final int CARLOC1       =     0x32;
static final int CARLOC2       =     0x33;
static final int CARLOC3       =     0x34;
static final int CARLOC4       =     0x35;
static final int CARLOC5       =     0x36;
static final int CARLOC6       =     0x37;
static final int CARLOC7       =     0x38;
static final int CARLOC8       =     0x39;
static final int CARLOC9       =     0x3a;
static final int CARLOC10      =     0x3b;
static final int CARLOC11      =     0x3c;
static final int CDRLOC0       =     0x3d;
static final int CDRLOC1       =     0x3e;
static final int CDRLOC2       =     0x3f;
static final int CDRLOC3       =     0x40;
static final int CDRLOC4       =     0x41;
static final int CDRLOC5       =     0x42;
static final int CAARLOC0      =     0x43;
static final int CAARLOC1      =     0x44;
static final int CAARLOC2      =     0x45;
static final int CAARLOC3      =     0x46;
static final int CALL0         =     0x47;
static final int CALL1         =     0x48;
static final int CALL2         =     0x49;
static final int CALL2R        =     0x4a;
static final int CALL3         =     0x4b;
static final int CALLN         =     0x4c;
static final int CALL0_0       =     0x4d;
static final int CALL0_1       =     0x4e;
static final int CALL0_2       =     0x4f;
static final int CALL0_3       =     0x50;
static final int CALL1_0       =     0x51;
static final int CALL1_1       =     0x52;
static final int CALL1_2       =     0x53;
static final int CALL1_3       =     0x54;
static final int CALL1_4       =     0x55;
static final int CALL1_5       =     0x56;
static final int CALL2_0       =     0x57;
static final int CALL2_1       =     0x58;
static final int CALL2_2       =     0x59;
static final int CALL2_3       =     0x5a;
static final int CALL2_4       =     0x5b;
static final int BUILTIN0      =     0x5c;
static final int BUILTIN1      =     0x5d;
static final int BUILTIN2      =     0x5e;
static final int BUILTIN2R     =     0x5f;
static final int BUILTIN3      =     0x60;
static final int APPLY1        =     0x61;
static final int APPLY2        =     0x62;
static final int APPLY3        =     0x63;
static final int APPLY4        =     0x64;
static final int JCALL         =     0x65;
static final int JCALLN        =     0x66;
static final int JUMP          =     0x67;
static final int JUMP_B        =     0x68;
static final int JUMP_L        =     0x69;
static final int JUMP_BL       =     0x6a;
static final int JUMPNIL       =     0x6b;
static final int JUMPNIL_B     =     0x6c;
static final int JUMPNIL_L     =     0x6d;
static final int JUMPNIL_BL    =     0x6e;
static final int JUMPT         =     0x6f;
static final int JUMPT_B       =     0x70;
static final int JUMPT_L       =     0x71;
static final int JUMPT_BL      =     0x72;
static final int JUMPATOM      =     0x73;
static final int JUMPATOM_B    =     0x74;
static final int JUMPATOM_L    =     0x75;
static final int JUMPATOM_BL   =     0x76;
static final int JUMPNATOM     =     0x77;
static final int JUMPNATOM_B   =     0x78;
static final int JUMPNATOM_L   =     0x79;
static final int JUMPNATOM_BL  =     0x7a;
static final int JUMPEQ        =     0x7b;
static final int JUMPEQ_B      =     0x7c;
static final int JUMPEQ_L      =     0x7d;
static final int JUMPEQ_BL     =     0x7e;
static final int JUMPNE        =     0x7f;
// I will put these things into byte arrays so I want to have values
// in the range -128 to +127.
static final int JUMPNE_B      =     0x80 - 0x100;
static final int JUMPNE_L      =     0x81 - 0x100;
static final int JUMPNE_BL     =     0x82 - 0x100;
static final int JUMPEQUAL     =     0x83 - 0x100;
static final int JUMPEQUAL_B   =     0x84 - 0x100;
static final int JUMPEQUAL_L   =     0x85 - 0x100;
static final int JUMPEQUAL_BL  =     0x86 - 0x100;
static final int JUMPNEQUAL    =     0x87 - 0x100;
static final int JUMPNEQUAL_B  =     0x88 - 0x100;
static final int JUMPNEQUAL_L  =     0x89 - 0x100;
static final int JUMPNEQUAL_BL =     0x8a - 0x100;
static final int JUMPL0NIL     =     0x8b - 0x100;
static final int JUMPL0T       =     0x8c - 0x100;
static final int JUMPL1NIL     =     0x8d - 0x100;
static final int JUMPL1T       =     0x8e - 0x100;
static final int JUMPL2NIL     =     0x8f - 0x100;
static final int JUMPL2T       =     0x90 - 0x100;
static final int JUMPL3NIL     =     0x91 - 0x100;
static final int JUMPL3T       =     0x92 - 0x100;
static final int JUMPL4NIL     =     0x93 - 0x100;
static final int JUMPL4T       =     0x94 - 0x100;
static final int JUMPST0NIL    =     0x95 - 0x100;
static final int JUMPST0T      =     0x96 - 0x100;
static final int JUMPST1NIL    =     0x97 - 0x100;
static final int JUMPST1T      =     0x98 - 0x100;
static final int JUMPST2NIL    =     0x99 - 0x100;
static final int JUMPST2T      =     0x9a - 0x100;
static final int JUMPL0ATOM    =     0x9b - 0x100;
static final int JUMPL0NATOM   =     0x9c - 0x100;
static final int JUMPL1ATOM    =     0x9d - 0x100;
static final int JUMPL1NATOM   =     0x9e - 0x100;
static final int JUMPL2ATOM    =     0x9f - 0x100;
static final int JUMPL2NATOM   =     0xa0 - 0x100;
static final int JUMPL3ATOM    =     0xa1 - 0x100;
static final int JUMPL3NATOM   =     0xa2 - 0x100;
static final int JUMPFREE1NIL  =     0xa3 - 0x100;
static final int JUMPFREE1T    =     0xa4 - 0x100;
static final int JUMPFREE2NIL  =     0xa5 - 0x100;
static final int JUMPFREE2T    =     0xa6 - 0x100;
static final int JUMPFREE3NIL  =     0xa7 - 0x100;
static final int JUMPFREE3T    =     0xa8 - 0x100;
static final int JUMPFREE4NIL  =     0xa9 - 0x100;
static final int JUMPFREE4T    =     0xaa - 0x100;
static final int JUMPFREENIL   =     0xab - 0x100;
static final int JUMPFREET     =     0xac - 0x100;
static final int JUMPLIT1EQ    =     0xad - 0x100;
static final int JUMPLIT1NE    =     0xae - 0x100;
static final int JUMPLIT2EQ    =     0xaf - 0x100;
static final int JUMPLIT2NE    =     0xb0 - 0x100;
static final int JUMPLIT3EQ    =     0xb1 - 0x100;
static final int JUMPLIT3NE    =     0xb2 - 0x100;
static final int JUMPLIT4EQ    =     0xb3 - 0x100;
static final int JUMPLIT4NE    =     0xb4 - 0x100;
static final int JUMPLITEQ     =     0xb5 - 0x100;
static final int JUMPLITNE     =     0xb6 - 0x100;
static final int JUMPB1NIL     =     0xb7 - 0x100;
static final int JUMPB1T       =     0xb8 - 0x100;
static final int JUMPB2NIL     =     0xb9 - 0x100;
static final int JUMPB2T       =     0xba - 0x100;
static final int JUMPFLAGP     =     0xbb - 0x100;
static final int JUMPNFLAGP    =     0xbc - 0x100;
static final int JUMPEQCAR     =     0xbd - 0x100;
static final int JUMPNEQCAR    =     0xbe - 0x100;
static final int CATCH         =     0xbf - 0x100;
static final int CATCH_B       =     0xc0 - 0x100;
static final int CATCH_L       =     0xc1 - 0x100;
static final int CATCH_BL      =     0xc2 - 0x100;
static final int UNCATCH       =     0xc3 - 0x100;
static final int THROW         =     0xc4 - 0x100;
static final int PROTECT       =     0xc5 - 0x100;
static final int UNPROTECT     =     0xc6 - 0x100;
static final int PVBIND        =     0xc7 - 0x100;
static final int PVRESTORE     =     0xc8 - 0x100;
static final int FREEBIND      =     0xc9 - 0x100;
static final int FREERSTR      =     0xca - 0x100;
static final int EXIT          =     0xcb - 0x100;
static final int NILEXIT       =     0xcc - 0x100;
static final int LOC0EXIT      =     0xcd - 0x100;
static final int LOC1EXIT      =     0xce - 0x100;
static final int LOC2EXIT      =     0xcf - 0x100;
static final int PUSH          =     0xd0 - 0x100;
static final int PUSHNIL       =     0xd1 - 0x100;
static final int PUSHNIL2      =     0xd2 - 0x100;
static final int PUSHNIL3      =     0xd3 - 0x100;
static final int PUSHNILS      =     0xd4 - 0x100;
static final int POP           =     0xd5 - 0x100;
static final int LOSE          =     0xd6 - 0x100;
static final int LOSE2         =     0xd7 - 0x100;
static final int LOSE3         =     0xd8 - 0x100;
static final int LOSES         =     0xd9 - 0x100;
static final int SWOP          =     0xda - 0x100;
static final int EQ            =     0xdb - 0x100;
static final int EQCAR         =     0xdc - 0x100;
static final int EQUAL         =     0xdd - 0x100;
static final int NUMBERP       =     0xde - 0x100;
static final int CAR           =     0xdf - 0x100;
static final int CDR           =     0xe0 - 0x100;
static final int CAAR          =     0xe1 - 0x100;
static final int CADR          =     0xe2 - 0x100;
static final int CDAR          =     0xe3 - 0x100;
static final int CDDR          =     0xe4 - 0x100;
static final int CONS          =     0xe5 - 0x100;
static final int NCONS         =     0xe6 - 0x100;
static final int XCONS         =     0xe7 - 0x100;
static final int ACONS         =     0xe8 - 0x100;
static final int LENGTH        =     0xe9 - 0x100;
static final int LIST2         =     0xea - 0x100;
static final int LIST2STAR     =     0xeb - 0x100;
static final int LIST3         =     0xec - 0x100;
static final int PLUS2         =     0xed - 0x100;
static final int ADD1          =     0xee - 0x100;
static final int DIFFERENCE    =     0xef - 0x100;
static final int SUB1          =     0xf0 - 0x100;
static final int TIMES2        =     0xf1 - 0x100;
static final int GREATERP      =     0xf2 - 0x100;
static final int LESSP         =     0xf3 - 0x100;
static final int FLAGP         =     0xf4 - 0x100;
static final int GET           =     0xf5 - 0x100;
static final int LITGET        =     0xf6 - 0x100;
static final int GETV          =     0xf7 - 0x100;
static final int QGETV         =     0xf8 - 0x100;
static final int QGETVN        =     0xf9 - 0x100;
static final int BIGSTACK      =     0xfa - 0x100;
static final int BIGCALL       =     0xfb - 0x100;
static final int ICASE         =     0xfc - 0x100;
static final int FASTGET       =     0xfd - 0x100;
static final int SPARE1        =     0xfe - 0x100;
static final int SPARE2        =     0xff - 0x100;

// The table of names is just for debugging - but that is of course
// very important!
//- 
//- static final String [] opnames =
//- {
//-     "LOADLOC      ", "LOADLOC0     ", "LOADLOC1     ", "LOADLOC2     ",
//-     "LOADLOC3     ", "LOADLOC4     ", "LOADLOC5     ", "LOADLOC6     ",
//-     "LOADLOC7     ", "LOADLOC8     ", "LOADLOC9     ", "LOADLOC10    ",
//-     "LOADLOC11    ", "LOC0LOC1     ", "LOC1LOC2     ", "LOC2LOC3     ",
//-     "LOC1LOC0     ", "LOC2LOC1     ", "LOC3LOC2     ", "VNIL         ",
//-     "LOADLIT      ", "LOADLIT1     ", "LOADLIT2     ", "LOADLIT3     ",
//-     "LOADLIT4     ", "LOADLIT5     ", "LOADLIT6     ", "LOADLIT7     ",
//-     "LOADFREE     ", "LOADFREE1    ", "LOADFREE2    ", "LOADFREE3    ",
//-     "LOADFREE4    ", "STORELOC     ", "STORELOC0    ", "STORELOC1    ",
//-     "STORELOC2    ", "STORELOC3    ", "STORELOC4    ", "STORELOC5    ",
//-     "STORELOC6    ", "STORELOC7    ", "STOREFREE    ", "STOREFREE1   ",
//-     "STOREFREE2   ", "STOREFREE3   ", "LOADLEX      ", "STORELEX     ",
//-     "CLOSURE      ", "CARLOC0      ", "CARLOC1      ", "CARLOC2      ",
//-     "CARLOC3      ", "CARLOC4      ", "CARLOC5      ", "CARLOC6      ",
//-     "CARLOC7      ", "CARLOC8      ", "CARLOC9      ", "CARLOC10     ",
//-     "CARLOC11     ", "CDRLOC0      ", "CDRLOC1      ", "CDRLOC2      ",
//-     "CDRLOC3      ", "CDRLOC4      ", "CDRLOC5      ", "CAARLOC0     ",
//-     "CAARLOC1     ", "CAARLOC2     ", "CAARLOC3     ", "CALL0        ",
//-     "CALL1        ", "CALL2        ", "CALL2R       ", "CALL3        ",
//-     "CALLN        ", "CALL0_0      ", "CALL0_1      ", "CALL0_2      ",
//-     "CALL0_3      ", "CALL1_0      ", "CALL1_1      ", "CALL1_2      ",
//-     "CALL1_3      ", "CALL1_4      ", "CALL1_5      ", "CALL2_0      ",
//-     "CALL2_1      ", "CALL2_2      ", "CALL2_3      ", "CALL2_4      ",
//-     "BUILTIN0     ", "BUILTIN1     ", "BUILTIN2     ", "BUILTIN2R    ",
//-     "BUILTIN3     ", "APPLY1       ", "APPLY2       ", "APPLY3       ",
//-     "APPLY4       ", "JCALL        ", "JCALLN       ", "JUMP         ",
//-     "JUMP_B       ", "JUMP_L       ", "JUMP_BL      ", "JUMPNIL      ",
//-     "JUMPNIL_B    ", "JUMPNIL_L    ", "JUMPNIL_BL   ", "JUMPT        ",
//-     "JUMPT_B      ", "JUMPT_L      ", "JUMPT_BL     ", "JUMPATOM     ",
//-     "JUMPATOM_B   ", "JUMPATOM_L   ", "JUMPATOM_BL  ", "JUMPNATOM    ",
//-     "JUMPNATOM_B  ", "JUMPNATOM_L  ", "JUMPNATOM_BL ", "JUMPEQ       ",
//-     "JUMPEQ_B     ", "JUMPEQ_L     ", "JUMPEQ_BL    ", "JUMPNE       ",
//-     "JUMPNE_B     ", "JUMPNE_L     ", "JUMPNE_BL    ", "JUMPEQUAL    ",
//-     "JUMPEQUAL_B  ", "JUMPEQUAL_L  ", "JUMPEQUAL_BL ", "JUMPNEQUAL   ",
//-     "JUMPNEQUAL_B ", "JUMPNEQUAL_L ", "JUMPNEQUAL_BL", "JUMPL0NIL    ",
//-     "JUMPL0T      ", "JUMPL1NIL    ", "JUMPL1T      ", "JUMPL2NIL    ",
//-     "JUMPL2T      ", "JUMPL3NIL    ", "JUMPL3T      ", "JUMPL4NIL    ",
//-     "JUMPL4T      ", "JUMPST0NIL   ", "JUMPST0T     ", "JUMPST1NIL   ",
//-     "JUMPST1T     ", "JUMPST2NIL   ", "JUMPST2T     ", "JUMPL0ATOM   ",
//-     "JUMPL0NATOM  ", "JUMPL1ATOM   ", "JUMPL1NATOM  ", "JUMPL2ATOM   ",
//-     "JUMPL2NATOM  ", "JUMPL3ATOM   ", "JUMPL3NATOM  ", "JUMPFREE1NIL ",
//-     "JUMPFREE1T   ", "JUMPFREE2NIL ", "JUMPFREE2T   ", "JUMPFREE3NIL ",
//-     "JUMPFREE3T   ", "JUMPFREE4NIL ", "JUMPFREE4T   ", "JUMPFREENIL  ",
//-     "JUMPFREET    ", "JUMPLIT1EQ   ", "JUMPLIT1NE   ", "JUMPLIT2EQ   ",
//-     "JUMPLIT2NE   ", "JUMPLIT3EQ   ", "JUMPLIT3NE   ", "JUMPLIT4EQ   ",
//-     "JUMPLIT4NE   ", "JUMPLITEQ    ", "JUMPLITNE    ", "JUMPB1NIL    ",
//-     "JUMPB1T      ", "JUMPB2NIL    ", "JUMPB2T      ", "JUMPFLAGP    ",
//-     "JUMPNFLAGP   ", "JUMPEQCAR    ", "JUMPNEQCAR   ", "CATCH        ",
//-     "CATCH_B      ", "CATCH_L      ", "CATCH_BL     ", "UNCATCH      ",
//-     "THROW        ", "PROTECT      ", "UNPROTECT    ", "PVBIND       ",
//-     "PVRESTORE    ", "FREEBIND     ", "FREERSTR     ", "EXIT         ",
//-     "NILEXIT      ", "LOC0EXIT     ", "LOC1EXIT     ", "LOC2EXIT     ",
//-     "PUSH         ", "PUSHNIL      ", "PUSHNIL2     ", "PUSHNIL3     ",
//-     "PUSHNILS     ", "POP          ", "LOSE         ", "LOSE2        ",
//-     "LOSE3        ", "LOSES        ", "SWOP         ", "EQ           ",
//-     "EQCAR        ", "EQUAL        ", "NUMBERP      ", "CAR          ",
//-     "CDR          ", "CAAR         ", "CADR         ", "CDAR         ",
//-     "CDDR         ", "CONS         ", "NCONS        ", "XCONS        ",
//-     "ACONS        ", "LENGTH       ", "LIST2        ", "LIST2STAR    ",
//-     "LIST3        ", "PLUS2        ", "ADD1         ", "DIFFERENCE   ",
//-     "SUB1         ", "TIMES2       ", "GREATERP     ", "LESSP        ",
//-     "FLAGP        ", "GET          ", "LITGET       ", "GETV         ",
//-     "QGETV        ", "QGETVN       ", "BIGSTACK     ", "BIGCALL      ",
//-     "ICASE        ", "FASTGET      ", "SPARE1       ", "SPARE2       "
//- };

static int stack_size = 5000;
static LispObject [] stack = new LispObject[stack_size];
static int sp = 0;
static int poll_time_countdown = 0;

static long last_clock = -1;

LispObject interpret(int pc) throws Exception
{
    if (--poll_time_countdown < 0) {
        poll_time_countdown = 10000;
        long t = System.currentTimeMillis();
        if (last_clock < 0) {
            last_clock = t;
        } else {
            while (t - last_clock > 1000) {
                last_clock += 1000;
                ResourceException.time_now++;
                if (ResourceException.time_limit > 0
                        && ResourceException.time_now > ResourceException.time_limit) {
                    if (Jlisp.headline) {
                        Jlisp.errprint("\n+++ Time limit exceeded\n");
                    }
                    throw new ResourceException("time limit exceeded");
                }
            }
        }
    }
    int spsave = sp;
    int arg;
    LispObject a = Environment.nil, b = Environment.nil, w;
    int iw, fname;

    if (sp > stack_size - 500) // the 500 is a pretty arbitrary margin!
                               // bad enough code could breach it.
    {   int new_size = (3*stack_size)/2;
        LispObject [] new_stack = new LispObject[new_size];
        for (int i=0; i<=sp; i++) new_stack[i] = stack[i];
        stack = new_stack;
        stack_size = new_size;
        if (Jlisp.verbosFlag != 0)
            Jlisp.errprint("+++ Stack enlarged to " + stack_size);
    }

    try { for (;;) 
    {
    switch (bytecodes[pc++])
    {
case LOADLOC:
        b = a; a = stack[sp-(bytecodes[pc++] & 0xff)];
        continue;
case LOADLOC0:
        b = a; a = stack[sp-0];
        continue;
case LOADLOC1:
        b = a; a = stack[sp-1];
        continue;
case LOADLOC2:
        b = a; a = stack[sp-2];
        continue;
case LOADLOC3:
        b = a; a = stack[sp-3];
        continue;
case LOADLOC4:
        b = a; a = stack[sp-4];
        continue;
case LOADLOC5:
        b = a; a = stack[sp-5];
        continue;
case LOADLOC6:
        b = a; a = stack[sp-6];
        continue;
case LOADLOC7:
        b = a; a = stack[sp-7];
        continue;
case LOADLOC8:
        b = a; a = stack[sp-8];
        continue;
case LOADLOC9:
        b = a; a = stack[sp-9];
        continue;
case LOADLOC10:
        b = a; a = stack[sp-10];
        continue;
case LOADLOC11:
        b = a; a = stack[sp-11];
        continue;
case LOC0LOC1:
        b = stack[sp-0];
        a = stack[sp-1];
        continue;
case LOC1LOC2:
        b = stack[sp-1];
        a = stack[sp-2];
        continue;
case LOC2LOC3:
        b = stack[sp-2];
        a = stack[sp-3];
        continue;
case LOC1LOC0:
        b = stack[sp-1];
        a = stack[sp-0];
        continue;
case LOC2LOC1:
        b = stack[sp-2];
        a = stack[sp-1];
        continue;
case LOC3LOC2:
        b = stack[sp-3];
        a = stack[sp-2];
        continue;
case VNIL:
        b = a; a = Environment.nil;
        continue;
case LOADLIT:
        b = a; a = env[bytecodes[pc++] & 0xff];
        continue;
case LOADLIT1:
        b = a; a = env[1];
        continue;
case LOADLIT2:
        b = a; a = env[2];
        continue;
case LOADLIT3:
        b = a; a = env[3];
        continue;
case LOADLIT4:
        b = a; a = env[4];
        continue;
case LOADLIT5:
        b = a; a = env[5];
        continue;
case LOADLIT6:
        b = a; a = env[6];
        continue;
case LOADLIT7:
        b = a; a = env[7];
        continue;
case LOADFREE:
        b = a; a = env[bytecodes[pc++] & 0xff].car/*value*/;
        continue;
case LOADFREE1:
        b = a; a = env[1].car/*value*/;
        continue;
case LOADFREE2:
        b = a; a = env[2].car/*value*/;
        continue;
case LOADFREE3:
        b = a; a = env[3].car/*value*/;
        continue;
case LOADFREE4:
        b = a; a = env[4].car/*value*/;
        continue;
case STORELOC:
        stack[sp-(bytecodes[pc++] & 0xff)] = a;
        continue;
case STORELOC0:
        stack[sp-0] = a;
        continue;
case STORELOC1:
        stack[sp-1] = a;
        continue;
case STORELOC2:
        stack[sp-2] = a;
        continue;
case STORELOC3:
        stack[sp-3] = a;
        continue;
case STORELOC4:
        stack[sp-4] = a;
        continue;
case STORELOC5:
        stack[sp-5] = a;
        continue;
case STORELOC6:
        stack[sp-6] = a;
        continue;
case STORELOC7:
        stack[sp-7] = a;
        continue;
case STOREFREE:
        env[bytecodes[pc++] & 0xff].car/*value*/ = a;
        continue;
case STOREFREE1:
        env[1].car/*value*/ = a;
        continue;
case STOREFREE2:
        env[2].car/*value*/ = a;
        continue;
case STOREFREE3:
        env[3].car/*value*/ = a;
        continue;
case LOADLEX:
        Jlisp.error("bytecode LOADLEX not implemented");
case STORELEX:
        Jlisp.error("bytecode STORELEX not implemented");
case CLOSURE:
        Jlisp.error("bytecode CLOSURE not implemented");
case CARLOC0:
        b = a;
        a = stack[sp-0];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC1:
        b = a;
        a = stack[sp-1];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC2:
        b = a;
        a = stack[sp-2];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC3:
        b = a;
        a = stack[sp-3];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC4:
        b = a;
        a = stack[sp-4];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC5:
        b = a;
        a = stack[sp-5];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC6:
        b = a;
        a = stack[sp-6];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC7:
        b = a;
        a = stack[sp-7];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC8:
        b = a;
        a = stack[sp-8];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC9:
        b = a;
        a = stack[sp-9];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC10:
        b = a;
        a = stack[sp-10];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CARLOC11:
        b = a;
        a = stack[sp-11];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CDRLOC0:
        b = a;
        a = stack[sp-0];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CDRLOC1:
        b = a;
        a = stack[sp-1];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CDRLOC2:
        b = a;
        a = stack[sp-2];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CDRLOC3:
        b = a;
        a = stack[sp-3];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CDRLOC4:
        b = a;
        a = stack[sp-4];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CDRLOC5:
        b = a;
        a = stack[sp-5];
        if (a.atom) Jlisp.error("attempt to take cdr of an atom", a);
        a = a.cdr;
        continue;
case CAARLOC0:
        b = a;
        a = stack[sp-0];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CAARLOC1:
        b = a;
        a = stack[sp-1];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CAARLOC2:
        b = a;
        a = stack[sp-2];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CAARLOC3:
        b = a;
        a = stack[sp-3];
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        if (a.atom) Jlisp.error("attempt to take car of an atom", a);
        a = a.car;
        continue;
case CALL0:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
	a = ((Symbol)env[arg]).fn.op0();
	continue;
case CALL1:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
	a = ((Symbol)env[arg]).fn.op1(a);
	continue;
case CALL2:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
	a = ((Symbol)env[arg]).fn.op2(b, a);
	continue;
case CALL2R:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
	a = ((Symbol)env[arg]).fn.op2(a, b);
	continue;
case CALL3:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        a = ((Symbol)env[arg]).fn.opn(new LispObject [] {stack[sp--], b, a});
	continue;
case CALLN:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        switch (bytecodes[pc++] & 0xff)
        {
    case 4: sp -= 2;
            a = ((Symbol)env[arg]).fn.opn(new LispObject [] 
                {stack[sp+1], stack[sp+2], b, a});
	    continue;
    case 5: sp -= 3;
            a = ((Symbol)env[arg]).fn.opn(new LispObject [] 
                {stack[sp+1], stack[sp+2], stack[sp+3], b, a});
	    continue;
    case 6: sp -= 4;
            a = ((Symbol)env[arg]).fn.opn(new LispObject [] 
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], b, a});
	    continue;
    case 7: sp -= 5;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
	        {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], b, a});
            continue;
    case 8: sp -= 6;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], b, a});
            continue;
    case 9: sp -= 7;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], b, a});
            continue;
    case 10:sp -= 8;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8], b, a});
            continue;
    case 11:sp -= 9;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], b, a});
            continue;
    case 12:sp -= 10;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], b, a});
            continue;
    case 13:sp -= 11;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], b, a});
            continue;
    case 14:sp -= 12;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12], b, a});
            continue;
    case 15:sp -= 13;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], b, a});
            continue;
// The Standard Lisp Report mandates at least 15 arguments must be supported.
// Common Lisp maybe does not have any real limit? Anyway I will go to 20
// here.
    case 16:sp -= 14;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], stack[sp+14], b, a});
            continue;
    case 17:sp -= 15;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], stack[sp+14], stack[sp+15], b, a});
            continue;
    case 18:sp -= 16;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], stack[sp+14], stack[sp+15], stack[sp+16], b, a});
            continue;
    case 19:sp -= 17;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], stack[sp+14], stack[sp+15], stack[sp+16],
                 stack[sp+17], b, a});
            continue;
    case 20:sp -= 18;
            a = ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[sp+1], stack[sp+2], stack[sp+3], stack[sp+4], 
                 stack[sp+5], stack[sp+6], stack[sp+7], stack[sp+8],
                 stack[sp+9], stack[sp+10], stack[sp+11], stack[sp+12],
                 stack[sp+13], stack[sp+14], stack[sp+15], stack[sp+16],
                 stack[sp+17], stack[sp+18], b, a});
            continue;
    default:
            Jlisp.error("calls with over 20 args not supported in this Lisp");
        }
case CALL0_0:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = op0();   // optimisation on call to self!
	continue;
case CALL0_1:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[1]).fn.op0();
	continue;
case CALL0_2:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[2]).fn.op0();
	continue;
case CALL0_3:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[3]).fn.op0();
	continue;
case CALL1_0:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = op1(a);   // call to self
	continue;
case CALL1_1:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[1]).fn.op1(a);
	continue;
case CALL1_2:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[2]).fn.op1(a);
	continue;
case CALL1_3:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[3]).fn.op1(a);
	continue;
case CALL1_4:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[4]).fn.op1(a);
	continue;
case CALL1_5:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[5]).fn.op1(a);
	continue;
case CALL2_0:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = op2(b, a);   // call to self
	continue;
case CALL2_1:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[1]).fn.op2(b, a);
	continue;
case CALL2_2:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[2]).fn.op2(b, a);
	continue;
case CALL2_3:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[3]).fn.op2(b, a);
	continue;
case CALL2_4:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
	a = ((Symbol)env[4]).fn.op2(b, a);
	continue;
case BUILTIN0:
        arg = bytecodes[pc++] & 0xff;
	a = builtin0[arg].op0();
	continue;
case BUILTIN1:
        arg = bytecodes[pc++] & 0xff;
	a = builtin1[arg].op1(a);
	continue;
case BUILTIN2:
        arg = bytecodes[pc++] & 0xff;
	a = builtin2[arg].op2(b, a);
	continue;
case BUILTIN2R:
        arg = bytecodes[pc++] & 0xff;
	a = builtin2[arg].op2(a, b);
 	continue;
case BUILTIN3:
        arg = bytecodes[pc++] & 0xff;
	a = builtin3[arg].opn(new LispObject [] {stack[sp--], b, a});
	continue;
case APPLY1:
        if (b instanceof Symbol)
        {   a = ((Symbol)b).fn.op1(a);
        }
        else if (b instanceof LispFunction)
        {   a = ((LispFunction)b).op1(a);
        }
        else a = Fns.apply1(b, a);
        continue;
case APPLY2:
        if (stack[sp] instanceof Symbol)
        {   a = ((Symbol)stack[sp--]).fn.op2(b, a);
        }
        else if (stack[sp] instanceof LispFunction)
        {   a = ((LispFunction)stack[sp--]).op2(b, a);
        }
        else a = Fns.apply2(stack[sp--], b, a);
        continue;
case APPLY3:
        sp -= 2;
        if (stack[sp+1] instanceof Symbol)
        {   a = ((Symbol)stack[sp+1]).fn.opn(new LispObject [] {stack[sp+2], b, a});
        }
        else if (stack[sp+1] instanceof LispFunction)
        {   a = ((LispFunction)stack[sp+1]).opn(new LispObject [] {stack[sp+2], b, a});
        }
        else a = Fns.apply3(stack[sp+1], stack[sp+2], b, a);
        continue;
case APPLY4:
        sp -= 3;
        if (stack[sp+1] instanceof Symbol)
        {   a = ((Symbol)stack[sp+1]).fn.opn(new LispObject [] {stack[sp+2], stack[sp+3], b, a});
        }
        else if (stack[sp+1] instanceof LispFunction)
        {   a = ((LispFunction)stack[sp+1]).opn(new LispObject [] {stack[sp+2], stack[sp+3], b, a});
        }
        else a = Fns.applyn(stack[sp+1], 
            new LispObject [] {stack[sp+2], stack[sp+3], b, a});
        continue;
case JCALL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++];
        switch (arg & 0xe0)  // number of args
        {
    case 0x00: arg &= 0x1f;
               if (arg == 0)
               {   sp = spsave;
                   pc = 0;
                   continue;
               }
               sp = spsave;
               return ((Symbol)env[arg & 0x1f]).fn.op0();
    case 0x20: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   sp = spsave;
                   pc = 0;
                   continue;
               }
               sp = spsave;
               return ((Symbol)env[arg & 0x1f]).fn.op1(a);
    case 0x40: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   sp = spsave;
                   pc = 0;
                   continue;
               }
               sp = spsave;
               return ((Symbol)env[arg & 0x1f]).fn.op2(b, a);
    case 0x60: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   stack[spsave-2] = stack[sp];
                   sp = spsave;
                   pc = 0;
                   continue;
               }
               pc = sp;
               sp = spsave;
               return ((Symbol)env[arg & 0x1f]).fn.opn(
                          new LispObject [] {stack[pc--], b, a});
    case 0x80: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   stack[spsave-2] = stack[sp];
                   stack[spsave-3] = stack[sp-1];
                   sp = spsave;
                   pc = 1;  // NB to allow for arg-count byte
                   continue;
               }
               pc = sp;
               sp = spsave;
               pc -= 2; 
               return ((Symbol)env[arg & 0x1f]).fn.opn(
                   new LispObject [] {stack[pc+1], stack[pc+2], b, a});
    case 0xa0: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   stack[spsave-2] = stack[sp];
                   stack[spsave-3] = stack[sp-1];
                   stack[spsave-4] = stack[sp-2];
                   sp = spsave;
                   pc = 1;
                   continue;
               }
               pc = sp;
               sp = spsave;
               pc -= 3; 
               return ((Symbol)env[arg & 0x1f]).fn.opn(
                   new LispObject [] {stack[pc+1], stack[pc+2], stack[pc+3], b, a});
    case 0xc0: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   stack[spsave-2] = stack[sp];
                   stack[spsave-3] = stack[sp-1];
                   stack[spsave-4] = stack[sp-2];
                   stack[spsave-5] = stack[sp-3];
                   sp = spsave;
                   pc = 1;
                   continue;
               }
               pc = sp;
               sp = spsave;
               pc -= 4; 
               return ((Symbol)env[arg & 0x1f]).fn.opn(
                   new LispObject [] {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], b, a});
    case 0xe0: arg &= 0x1f;
               if (arg == 0)
               {   stack[spsave] = a;
                   stack[spsave-1] = b;
                   stack[spsave-2] = stack[sp];
                   stack[spsave-3] = stack[sp-1];
                   stack[spsave-4] = stack[sp-2];
                   stack[spsave-5] = stack[sp-3];
                   stack[spsave-6] = stack[sp-4];
                   sp = spsave;
                   pc = 1;
                   continue;
               }
               pc = sp;
               sp = spsave;
               pc -= 5; 
               return ((Symbol)env[arg & 0x1f]).fn.opn(
                   new LispObject [] {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], stack[pc+5], b, a});
    default:
               return Jlisp.error("oddity with JCALL " +
                                  Integer.toHexString(arg));
        }
case JCALLN:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++];
        switch (bytecodes[pc++] & 0xff)  // number of args
        {
// Just at present I do not treat calls to self specially here (in the
// way that I do for JCALL rather than JCALLN). This is something that I
// should fix sometime...
    case 0: sp = spsave;
            return ((Symbol)env[arg]).fn.op0();
    case 1: sp = spsave;
            return ((Symbol)env[arg]).fn.op1(a);
    case 2: sp = spsave;
            return ((Symbol)env[arg]).fn.op2(b, a);
    case 3: pc = sp;
            sp = spsave;
            return ((Symbol)env[arg]).fn.opn(new LispObject [] 
                {stack[pc--], b, a});
    case 4: pc = sp;
            sp = spsave;
            pc -= 2; 
            return ((Symbol)env[arg]).fn.opn(new LispObject [] 
                {stack[pc+1], stack[pc+2], b, a});
    case 5: pc = sp;
            sp = spsave;
            pc -= 3; 
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], b, a});
    case 6: pc = sp;
            sp = spsave;
            pc -= 4; 
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], b, a});
    case 7: pc = sp;
            sp = spsave;
            pc -= 5;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
	        {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], b, a});
    case 8: pc = sp;
            sp = spsave;
            pc -= 6;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], b, a});
    case 9: pc = sp;
            sp = spsave;
            pc -= 7;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], b, a});
    case 10:pc = sp;
            sp = spsave;
            pc -= 8;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8], b, a});
    case 11:pc = sp;
            sp = spsave;
            pc -= 9;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], b, a});
    case 12:pc = sp;
            sp = spsave;
            pc -= 10;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], b, a});
    case 13:pc = sp;
            sp = spsave;
            pc -= 11;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], b, a});
    case 14:pc = sp;
            sp = spsave;
            pc -= 12;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12], b, a});
    case 15:pc = sp;
            sp = spsave;
            pc -= 13;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], b, a});
// The Standard Lisp Report mandates at least 15 arguments must be supported.
// Common Lisp maybe does not have any real limit? Anyway I will go to 20
// here.
    case 16:pc = sp;
            sp = spsave;
            pc -= 14;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], stack[pc+14], b, a});
    case 17:pc = sp;
            sp = spsave;
            pc -= 15;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], stack[pc+14], stack[pc+15], b, a});
    case 18:pc = sp;
            sp = spsave;
            pc -= 16;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], stack[pc+14], stack[pc+15], stack[pc+16], b, a});
    case 19:pc = sp;
            sp = spsave;
            pc -= 17;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], stack[pc+14], stack[pc+15], stack[pc+16],
                 stack[pc+17], b, a});
    case 20:pc = sp;
            sp = spsave;
            pc -= 18;
            return ((Symbol)env[arg]).fn.opn(new LispObject []
                {stack[pc+1], stack[pc+2], stack[pc+3], stack[pc+4], 
                 stack[pc+5], stack[pc+6], stack[pc+7], stack[pc+8],
                 stack[pc+9], stack[pc+10], stack[pc+11], stack[pc+12],
                 stack[pc+13], stack[pc+14], stack[pc+15], stack[pc+16],
                 stack[pc+17], stack[pc+18], b, a});
    default:
            Jlisp.error("calls with over 20 args not supported in this Lisp");
        }
case JUMP:
        pc = pc + (bytecodes[pc] & 0xff) + 1;
        continue;
case JUMP_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        pc = pc - (bytecodes[pc] & 0xff) + 1;
        continue;
case JUMP_L:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        continue;
case JUMP_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        continue;
case JUMPNIL:
        if (a == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNIL_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a == Environment.nil) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNIL_L:
        arg = bytecodes[pc++] & 0xff;
        if (a == Environment.nil) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNIL_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a == Environment.nil) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPT:
        if (a != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPT_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a != Environment.nil) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPT_L:
        arg = bytecodes[pc++] & 0xff;
        if (a != Environment.nil) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPT_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a != Environment.nil) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPATOM:
        if (a.atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPATOM_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a.atom) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPATOM_L:
        arg = bytecodes[pc++] & 0xff;
        if (a.atom) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPATOM_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a.atom) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPNATOM:
        if (!a.atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNATOM_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (!a.atom) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNATOM_L:
        arg = bytecodes[pc++] & 0xff;
        if (!a.atom) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNATOM_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (!a.atom) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPEQ:
// @@@ here and many related places would need treatment of numbers if
// I had to support EQ being a reliable comparison on integers.
        if (a == b) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQ_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a == b) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQ_L:
        arg = bytecodes[pc++] & 0xff;
        if (a == b) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQ_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a == b) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPNE:
        if (a != b) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNE_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a != b) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNE_L:
        arg = bytecodes[pc++] & 0xff;
        if (a != b) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNE_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a != b) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPEQUAL:
        if (a.lispequals(b)) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQUAL_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (a.lispequals(b)) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQUAL_L:
        arg = bytecodes[pc++] & 0xff;
        if (a.lispequals(b)) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQUAL_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (a.lispequals(b)) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPNEQUAL:
        if (!a.lispequals(b)) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNEQUAL_B:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        if (!a.lispequals(b)) pc = pc - (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNEQUAL_L:
        arg = bytecodes[pc++] & 0xff;
        if (!a.lispequals(b)) pc = pc + (arg << 8) + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNEQUAL_BL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        arg = bytecodes[pc++] & 0xff;
        if (!a.lispequals(b)) pc = pc - ((arg << 8) + (bytecodes[pc] & 0xff)) + 1;
        else pc++;
        continue;
case JUMPL0NIL:
        if (stack[sp-0] == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL0T:
        if (stack[sp-0] != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL1NIL:
        if (stack[sp-1] == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL1T:
        if (stack[sp-1] != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL2NIL:
        if (stack[sp-2] == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL2T:
        if (stack[sp-2] != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL3NIL:
        if (stack[sp-3] == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL3T:
        if (stack[sp-3] != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL4NIL:
        if (stack[sp-4] == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL4T:
        if (stack[sp-4] != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST0NIL:
        if ((stack[sp-0] = a) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST0T:
        if ((stack[sp-0] = a) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST1NIL:
        if ((stack[sp-1] = a) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST1T:
        if ((stack[sp-1] = a) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST2NIL:
        if ((stack[sp-2] = a) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPST2T:
        if ((stack[sp-2] = a) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL0ATOM:
        if (stack[sp-0].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL0NATOM:
        if (!stack[sp-0].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL1ATOM:
        if (stack[sp-1].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL1NATOM:
        if (!stack[sp-1].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL2ATOM:
        if (stack[sp-2].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL2NATOM:
        if (!stack[sp-2].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL3ATOM:
        if (stack[sp-3].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPL3NATOM:
        if (!stack[sp-3].atom) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE1NIL:
        if (env[1].car/*value*/ == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE1T:
        if (env[1].car/*value*/ != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE2NIL:
        if (env[2].car/*value*/ == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE2T:
        if (env[2].car/*value*/ != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE3NIL:
        if (env[3].car/*value*/ == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE3T:
        if (env[3].car/*value*/ != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE4NIL:
        if (env[4].car/*value*/ == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREE4T:
        if (env[4].car/*value*/ != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREENIL:
        arg = bytecodes[pc++] & 0xff;
        if (env[arg].car/*value*/ == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFREET:
        arg = bytecodes[pc++] & 0xff;
        if (env[arg].car/*value*/ != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT1EQ:
        if (env[1] == a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT1NE:
        if (env[1] != a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT2EQ:
        if (env[2] == a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT2NE:
        if (env[2] != a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT3EQ:
        if (env[3] == a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT3NE:
        if (env[3] != a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT4EQ:
        if (env[4] == a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLIT4NE:
        if (env[4] != a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLITEQ:
        arg = bytecodes[pc++] & 0xff;
        if (env[arg] == a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPLITNE:
        arg = bytecodes[pc++] & 0xff;
        if (env[arg] != a) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPB1NIL:
        arg = bytecodes[pc++] & 0xff;
        if (builtin1[arg].op1(a) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPB1T:
        arg = bytecodes[pc++] & 0xff;
        if (builtin1[arg].op1(a) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPB2NIL:
        arg = bytecodes[pc++] & 0xff;
        if (builtin2[arg].op2(b, a) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPB2T:
        arg = bytecodes[pc++] & 0xff;
        if (builtin2[arg].op2(b, a) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPFLAGP:
        arg = bytecodes[pc++] & 0xff;
        if (builtin2[BIflagp].op2(a, env[arg]) != Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNFLAGP:
        arg = bytecodes[pc++] & 0xff;
        if (builtin2[BIflagp].op2(a, env[arg]) == Environment.nil) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPEQCAR:
        arg = bytecodes[pc++] & 0xff;
        if (!a.atom && env[arg] == a.car) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case JUMPNEQCAR:
        arg = bytecodes[pc++] & 0xff;
        if (a.atom || env[arg] != a.car) pc = pc + (bytecodes[pc] & 0xff) + 1;
        else pc++;
        continue;
case CATCH:
        Jlisp.error("bytecode CATCH not implemented");
case CATCH_B:
        Jlisp.error("bytecode CATCH_B not implemented");
case CATCH_L:
        Jlisp.error("bytecode CATCH_L not implemented");
case CATCH_BL:
        Jlisp.error("bytecode CATCHH_BL not implemented");
case UNCATCH:
        Jlisp.error("bytecode UNCATCH not implemented");
case THROW:
        Jlisp.error("bytecode THROW not implemented");
case PROTECT:
        Jlisp.error("bytecode PROTECT not implemented");
case UNPROTECT:
        Jlisp.error("bytecode UNPROTECT not implemented");
case PVBIND:
        Jlisp.error("bytecode PVBIND not implemented");
case PVRESTORE:
        Jlisp.error("bytecode PVRESTORE not implemented");
case FREEBIND:
        arg = bytecodes[pc++] & 0xff;
        {   LispObject [] v = ((LispVector)env[arg]).vec;
            for (int i=0; i=0; i--)
            {   v[i].car/*value*/ = stack[sp--];
            }
        }
        continue;
case EXIT:
        sp = spsave;
        return a;
case NILEXIT:
        sp = spsave;
        return Environment.nil;
case LOC0EXIT:
        pc = sp;
        sp = spsave;
        return stack[pc-0];
case LOC1EXIT:
        pc = sp;
        sp = spsave;
        return stack[pc-1];
case LOC2EXIT:
        pc = sp;
        sp = spsave;
        return stack[pc-2];
case PUSH:
        stack[++sp] = a;
        continue;
case PUSHNIL:
        stack[++sp] = Environment.nil;
        continue;
case PUSHNIL2:
        stack[++sp] = Environment.nil;
        stack[++sp] = Environment.nil;
        continue;
case PUSHNIL3:
        stack[++sp] = Environment.nil;
        stack[++sp] = Environment.nil;
        stack[++sp] = Environment.nil;
        continue;
case PUSHNILS:
        arg = bytecodes[pc++] & 0xff;
        for (int i=0; i> 4);
//          r1 = stack[sp+1-n];
//          b = a;
//          n = w & 0x1f;
//          while (n != 0) n--;
//          if ((w & 0x20) == 0)
//              a = 0;
//          else ?? = a;
//          continue;
        }
case BIGCALL:
        if(Jlisp.interruptEvaluation == true)
        {
            handleInterrupt();
        }
        iw = bytecodes[pc++] & 0xff;
        System.out.printf("BIGCALL %x%n", iw);
        fname = (bytecodes[pc++] & 0xff) + ((iw & 0xf) << 8);
        switch (iw >> 4)
        {
    default:
    //case 0: // call0
	    a = ((Symbol)env[fname]).fn.op0();
            continue;
    case 1:   // call1
	    a = ((Symbol)env[fname]).fn.op1(a);
            continue;
    case 2:   // call2
	    a = ((Symbol)env[fname]).fn.op2(b, a);
            continue;
    case 3:   // call3
            a = ((Symbol)env[fname]).fn.opn(
                new LispObject [] {stack[sp--], b, a});
            continue;
    case 4:   // calln
            Jlisp.error("BIG CALLN not implemented");
    case 5:   // call2r
	    a = ((Symbol)env[fname]).fn.op2(a, b);
            continue;
    case 6:   // loadfree
            b = a;
            a = env[fname].car/*value*/;
            continue;
    case 7:   // storefree
            env[fname].car/*value*/ = a;
            continue;
    case 8:   // jcall0
            sp = spsave;
            return ((Symbol)env[fname]).fn.op0();
    case 9:   // jcall1
            sp = spsave;
            return ((Symbol)env[fname]).fn.op1(a);
    case 10:  // jcall2
            sp = spsave;
            return ((Symbol)env[fname]).fn.op2(b, a);
    case 11:  // jcall3
            pc = sp;
            sp = spsave;
            return ((Symbol)env[fname]).fn.opn(
                new LispObject [] {stack[pc--], b, a});
    case 12:  // jcalln
            Jlisp.error("BIG JCALLN not implemented");
    case 13:  // freebind
            Jlisp.error("BIG FREEBIND not implemented");
    case 14:  // litget
            Jlisp.error("BIG LITGET not implemented");
    case 15:  // loadlit
            b = a;
            a = env[fname];
            continue;
        }
case ICASE:
        Jlisp.error("bytecode ICASE not implemented");
case FASTGET:
        Jlisp.error("bytecode FASTGET not implemented");
case SPARE1:
        Jlisp.error("bytecode SPARE1 not implemented");
case SPARE2:
        Jlisp.error("bytecode SPARE2 not implemented");
    }
    }}
    catch (Exception e)
    {
// What I NEED to do here is to restore any free bindings that have been made.
// I can find them because there is a Spid.fbind on the stack to mark them.
//
// What I also WANT to do is to print a fragment of backtrace in relevant
// cases.

        while (sp != spsave)
        {   a = stack[sp--];
            if (a != Spid.fbind) continue;
            LispObject [] v = ((LispVector)stack[sp--]).vec;
            for (int i=v.length-1; i>=0; i--)
            {   v[i].car/*value*/ = stack[sp--];
            }
        }
        if (Jlisp.backtrace)
        {   Jlisp.errprint("Within: ");
            env[0].errPrint();
            Jlisp.errprintln();
        }
        throw e;
    }
}

}


// End of Bytecode.java

././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/JavaFn.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/JavaFn.ja0000644000175000017500000000474211546225657034040 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.functionwithenvironment;

// JavaFn.java 
// created 27/02/02
// classes I create will be subclasses of LispJavaFunction
// just to provide a level to put more mess later on
// class FnWithEnv extends LispFunction

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



public class JavaFn extends FnWithEnv
{

}

// end of JavaFn.java

././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/ByteOpt.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/ByteOpt.j0000644000175000017500000001300011555446662034104 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.functionwithenvironment;

//

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Spid;
import org.mathpiper.mpreduce.LispObject;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/
public class ByteOpt extends Bytecode
{

// nargs is inherited from Bytecode.
//  treated here as (flags/nopts/nargs) in 2:8:8 bits

// flags & 1     use Spid.noarg not nil as default
// flags & 2     use a &rest argument
//(flags & 4)    (marks a CallAs...)

// The code here seems pretty messy and sordid. Perhaps I can think
// harder some-time and write a cleaned up version!

public ByteOpt(byte [] b, LispObject [] e, int w, int o, int fg)
{
    bytecodes = b;
    env = e;
    nargs = w + (o<<8) + (fg<<16);
}

public ByteOpt(int packed)
{
    bytecodes = null;
    env = new LispObject [0];
    nargs = packed;
}

public LispObject op0() throws Exception
{
    if ((nargs & 0xff) > 0) error("not enough arguments");
    int spsave = sp;
    LispObject r;
    for (int i = 0; i<((nargs>>8)&0xff); i++)
        stack[++sp] = (nargs & 0x10000) != 0 ? (LispObject)Spid.noarg : (LispObject)Environment.nil;
    if ((nargs & 0x20000) != 0) stack[++sp] = Environment.nil;
    try
    {   r = interpret(2);
    }
    finally
    {   sp = spsave;
    }
    return r;
}

public LispObject op1(LispObject a1) throws Exception
{
    if ((nargs & 0xff) > 1) error("not enough arguments");
    int spsave = sp;
    if ((nargs & 0xff) == 0 && ((nargs>>8)&0xff) == 0)
    {   if ((nargs & 0x20000)==0) error("too many args");
        stack[++sp] = new Cons(a1, Environment.nil); // all in the &rest arg
    }
    else
    {   stack[++sp] = a1;
        for (int i = 0; i<(nargs & 0xff)+((nargs>>8)&0xff)-1; i++)
            stack[++sp] = (nargs & 0x10000) != 0 ? (LispObject)Spid.noarg : (LispObject)Environment.nil;
        if ((nargs & 0x20000) != 0) stack[++sp] = Environment.nil;
    }
    LispObject r;
    try
    {   r = interpret(2);
    }
    finally
    {   sp = spsave;
    }
    return r;
}

public LispObject op2(LispObject a1, LispObject a2) throws Exception
{
    if ((nargs & 0xff) > 2) error("not enough arguments");
    int spsave = sp;
    switch ((nargs & 0xff)+((nargs>>8)&0xff))
    {
case 0: if ((nargs & 0x20000)==0) error("too many args");
        stack[++sp] = new Cons(a1, new Cons(a2, Environment.nil));
        break;
case 1: if ((nargs & 0x20000)==0) error("too many args");
        stack[++sp] = a1; // will be either needed or optional
        stack[++sp] = new Cons(a2, Environment.nil);
        break;
case 2: stack[++sp] = a1;
        stack[++sp] = a2;
        if ((nargs & 0x20000)!=0) stack[++sp] = Environment.nil;
        break;
default:stack[++sp] = a1;
        stack[++sp] = a2;
        for (int i = 0; i<(nargs & 0xff)+((nargs>>8)&0xff)-2; i++)
            stack[++sp] = (nargs & 0x10000) != 0 ? (LispObject)Spid.noarg : (LispObject)Environment.nil;
        if ((nargs & 0x20000) != 0) stack[++sp] = Environment.nil;
    }
    LispObject r;
    try
    {   r = interpret(2);
    }
    finally
    {   sp = spsave;
    }
    return r;
}

public LispObject opn(LispObject [] args) throws Exception
{
// @@@
    error("byteopt call with 3 or more args not yet implemented, sorry");
    return Environment.nil;
}

}

// End of ByteOpt.java

././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/FnWithEnv.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/functions/functionwithenvironment/FnWithEnv0000644000175000017500000001112011555446662034137 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.functions.functionwithenvironment;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;
import org.mathpiper.mpreduce.LispObject;

import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/
public class FnWithEnv extends LispFunction
{

public int nargs;           // integer field saved in image file
public byte [] bytecodes;   // can be null if not needed (never shared?)
public LispObject [] env;   // vector of lisp objects, eg literals

FnWithEnv()
{
    env = new LispObject[0];
    bytecodes = null;
    nargs = 0;
}

FnWithEnv(LispObject [] env)
{
    this.env = env;
    bytecodes = null;
    nargs = 0;
}

public void scan()
{
    if (LispReader.objects.contains(this)) // seen before?
    {   if (!LispReader.repeatedObjects.containsKey(this))
        {   LispReader.repeatedObjects.put(
                this,
                Environment.nil); // value is junk at this stage
        }
    }
    else LispReader.objects.add(this);
    for (int i=0; i> 7;
            if (n <= 0x7f) Jlisp.odump.write(n);
            else
            {   Jlisp.odump.write(n | 0x80);
                Jlisp.odump.write(n >> 7);
            }
        }
        for (int i=0; i currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = "#SPID" + tag;
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public void scan()
    {
        Object w = new Integer(tag);
        if (LispReader.objects.contains(w)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(w))
	    {   LispReader.repeatedObjects.put(
	            w,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(w);
    }
    
    public void dump() throws Exception
    {
        Object d = new Integer(tag);
        Object w = LispReader.repeatedObjects.get(d);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            d,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    Jlisp.odump.write(X_SPID);
	    Jlisp.odump.write(tag);
// NOTE that I do NOT dump and restore the data field here. That is because
// I only use it in cases to do with reading FASL files and the relevant
// objects should NEVER need saving in a heap.
	}
    }


}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/jlisp_manifest0000644000175000017500000000002411527641631026251 0ustar  giovannigiovanniMain-Class: CWin

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/exceptions/0000755000175000017500000000000011722677351025511 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/exceptions/EOFException.java0000644000175000017500000000471711546225657030657 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.exceptions;

//

import java.io.IOException;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



public class EOFException extends IOException
{

public EOFException()
{
}

}

// end of EOFException.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/exceptions/ProgEvent.java0000644000175000017500000000613611540051553030257 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.exceptions;

//

import org.mathpiper.mpreduce.LispObject;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

public class ProgEvent extends LispException
{
    public static final int STOP     = 2;
    public static final int RESTART  = 3;
    public static final int THROW    = 4;
    public static final int PRESERVE = 5;
    
    public LispObject details;
    public LispObject extras;
    public String message;
    public int type;

    public ProgEvent(int type, LispObject details, String message)
    {
        this.type = type;
        this.details = details;
        this.extras = null;
        this.message = message; 
    }

    public ProgEvent(int type, LispObject details, LispObject extras, String message)
    {
        this.type = type;
        this.details = details;
        this.extras = extras;
        this.message = message; 
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/exceptions/LispException.java0000644000175000017500000000555311555446662031155 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.exceptions;

//

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.LispObject;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


public class LispException extends Exception
{
    public LispObject details;
    public String message;
    
    public LispException()
    {
        this.message = "unknown"; 
	this.details = Environment.nil;
    }
    
    public LispException(String message)
    {
        this.message=message;
	this.details=null; 
    }
    
    public LispException(String message, LispObject details)
    {
        this.message = message;
	this.details = details; 
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/exceptions/ResourceException.java0000644000175000017500000000613511555446662032032 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.exceptions;

//

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.LispObject;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


public class ResourceException extends LispException
{
    	 public static int time_base = 0,   space_base = 0,   io_base = 0,   errors_base = 0;
         public static int time_now = 0,    space_now = 0,    io_now = 0,    errors_now = 0;
         public static int time_limit = -1, space_limit = -1, io_limit = -1, errors_limit = -1;
    
    public ResourceException()
    {
        this.message = "unknown"; 
	this.details = Environment.nil;
    }
    
    public ResourceException(String message)
    {
        this.message=message;
	this.details=null; 
    }
    
    public ResourceException(String message, LispObject details)
    {
        this.message = message;
	this.details = details; 
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/rawdrprint.red0000644000175000017500000006563211555446662026237 0ustar  giovannigiovannimodule rprint;  % The Standard LISP to REDUCE pretty-printer.

% Author: Anthony C. Hearn.

create!-package('(rprint),'(util));

fluid '(!*lower !*n buffp combuff!* curmark curpos orig pretop rmar
        pretoprinf rmar rprifn!* rterfn!* labs lits blocks curblock
        numblocks);

Comment RPRIFN!* allows output from RPRINT to be handled differently,
        RTERFN!* allows end of lines to be handled differently;

pretop := 'op; pretoprinf := 'oprinf;

symbolic procedure rprint u;
   begin integer !*n; scalar buff,buffp,curmark,rmar,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      rmar := linelength nil;
      x := get('!*semicol!*,pretop);
      !*n := 0;
      mprino1(u,list(caar x,cadar x));
%      prin2ox ";";
      omarko curmark;
%      prinos buff
      return buff
   end;

symbolic procedure rprin1 u;
   begin scalar buff,buffp,curmark,x;
      curmark := 0;
      buff := buffp := list list(0,0);
      x := get('!*semicol!*,pretop);
      mprino1(u,list(caar x,cadar x));
      omarko curmark;
      prinos buff
   end;

symbolic procedure mprino u; mprino1(u,list(0,0));

symbolic procedure mprino1(u,v);
   begin scalar x;
      if x := atsoc(u,combuff!*) then 
        <>;
      if numberp u and u<0 and (x := get('difference,pretop)) then 
        return begin scalar p;
                  x := car x;
                  p := not(car x>cadr v) or not(cadr x>car v);
                  if p then prin2ox "(";
                  prinox u;
                  if p then prinox ")"
               end
      else if atom u then return prinox u
      else if not atom car u and (x:=strangeop u) then 
        return mprino1(x,v)
      else if not atom car u then 
        <>
      else if x := get(car u,pretoprinf) then 
        return begin scalar p;
                  p := car v>0 and not(car u memq 
                           '(rblock procedure prog quote string));
                  if p then prin2ox "(";
                  apply1(x,cdr u);
                  if p then prin2ox ")"
               end
      else if x := get(car u,pretop) then 
        return if car x then inprinox(u,car x,v)
% Next line commented out since not all user infix operators are binary.
%              else if cddr u then rederr "Syntax error"
               else if null cadr x then inprinox(u,list(100,1),v)
               else inprinox(u,list(100,cadr x),v)
      else if flagp(car u,'modefn) and eqcar(cadr u,'procedure) then 
        return proceox(cadadr u . car u . cdr cddadr u)
      else prinlit u
%      if rlistatp car u then return rlpri cdr u;
%      u := cdr u;
%      if null u then prin2ox "()"
%      else mprargs(u,v)
   end;

symbolic procedure strangeop u;
  % U is a non-atomic operator; try to find a better print form for it.
  if caar u='lambda and length cadar u=1 then
    subst(cadr u,car cadar u,car cddar u);

symbolic procedure mprargs(u,v);
   if null cdr u then <>
   else inprinox('!*comma!* . u,list(0,0),v);

symbolic procedure inprinox(u,x,v);
   begin scalar p;
      p := not(car x>cadr v) or not(cadr x>car v);
      if p then prin2ox "("; omark '(m u);
      inprino(car u,x,cdr u);
      if p then prin2ox ")"; omark '(m d)
   end;

symbolic procedure inprino(opr,v,l);
   begin scalar flg,x;
      curmark := curmark+2;
      x := get(opr,pretop);
      if x and car x
        then <>;
      while l do
        <>
           else if opr eq 'setq
            then <>
               else <>
                     where y = flagp(opr,'spaced))
   get(opr,'prtch);

flag('(cons),'spaced);

flag('(add mult over to),'spaced);  % So that we don't have 1./1 etc.

symbolic procedure prin2ox u;
   <>;

symbolic procedure explodex u;
   % "Explodes" atom U without including escape characters.
   if numberp u then explode u
    else if stringp u then reversip cdr reversip cdr explode u
    else explodex1 explode u;

symbolic procedure explodex1 u;
   if null u then nil
    else if car u eq '!! then cadr u . explodex1 cddr u
    else check!-downcase car u . explodex1 cdr u;

symbolic procedure explodey u;
   begin scalar v;
      v := explode u;
      if idp u then v := for each x in v collect check!-downcase x;
      return v
   end;

symbolic procedure check!-downcase u;
   begin scalar z;
      return if liter u
                and (z := atsoc(u,
                     '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e)
                       (!F . !f) (!G . !g) (!H . !h) (!I . !i) (!J . !j)
                       (!K . !k) (!L . !l) (!M . !m) (!N . !n) (!O . !o)
                       (!P . !p) (!Q . !q) (!R . !r) (!S . !s) (!T . !t)
                       (!U . !u) (!V . !v) (!W . !w) (!X . !x) (!Y . !y)
                       (!Z . !z))))
               then cdr z
              else u
   end;

symbolic procedure prinox u;
   <>
    where x = get(u,'oldnam);

symbolic procedure omark u;
   <>;

symbolic procedure omarko u; omark list(u,0);

symbolic procedure comprox u;
   begin scalar x;
        if car buffp = '(0 0)
          then return <>;
        x := car buffp;
        rplaca(buffp,list(curmark+1,3));
        for each j in u do prin2ox j;
        omark x
   end;

symbolic procedure rlistatp u;
   get(u,'stat) member '(endstat rlis);

symbolic procedure rlpri u;
   if null u then nil
    else begin
      prin2ox " ";
      omark '(m u);
      inprino('!*comma!*,list(0,0),u);
      omark '(m d)
   end;

symbolic procedure prinlit u;
   begin
      prin2ox "((Symbol)env[";
      prinox find_literal car u;
      prin2ox "]).fn.op";
      if not cdr u then prin2ox "0"
      else if not cddr u then prin2ox "1"
      else if not cdddr u then prin2ox "2"
      else prin2ox "n";
      prin2ox "(";
      u:=cdr u;
      while u do
        <>;
      prin2ox ")"
   end;

symbolic procedure find_literal u;
   begin scalar w,n;
      w:=lits;
      n:=0;
      while not null w and not (car w eq u) do
         <>;
      if not null w then return n;
      lits:=append(lits,list u);
      return n
   end;



Comment THIS IS THE START OF THE STRUCTURE BLOCKS;


symbolic procedure proceox u;
   begin scalar lits,blocks,curblock,numblocks;
      omark '(m u);
      curmark := curmark+1;
      curblock:=0;
      numblocks:=0;
%      prinox u;
%      omark list(curmark,0);
%      if cadr u then <>;
%      if not(caddr u eq 'expr) then <>;
      prin2ox "class ";
      mprino car u;
      prin2ox " extends LispFunction";
      omark list(curmark,2);
      prin2ox "{ LispObject ";
      if not car cadddr u then prin2ox "op0()"
      else if not cdr cadddr u then
        <>
      else if not cddr cadddr u then
        <>
      else prin2ox "opn(LispObject []args)";
      omark list(curmark,5);
      mprino car cddddr u;
      omark list(curmark,2); 
      prin2ox "}";
      omark list(curmark,0);
      prin2ox "lits are ";
      prinox lits;
      omarko curmark;
      prinox blocks;
      curmark := curmark - 1;
      omark '(m d)     
   end;

put('procedure,pretoprinf,'proceox);


symbolic procedure progox u;
   blockox((for each j in reverse car u collect j . 'scalar) . cdr u);

put('prog,pretoprinf,'progox);


symbolic procedure blockox u;
   begin
      scalar body,labs,nextlab,w;
      curmark := curmark+2;
      omark '(m u);
      numblocks := numblocks+1;
      blocks := list(numblocks,curblock,nil).blocks;
      curblock := numblocks;      
      body := labchk(gensym().cdr u);
      nextlab := 0;
      for each s in body do
         if eqcar(s,'!*label) then
           <>;
      prin2ox "{ int nextlab";
      prinox curblock;
      prin2ox " := 0; ";
      omark list(curmark,2);
      prin2ox "LispObject retVal := Environment.nil;";
      omark list(curmark,2);
      if car u then varprx car u;
      prin2ox "for (;;)";
      omark list(curmark,2);
      prin2ox "{ switch (nextlab";
      prinox curblock;
      prin2ox ") {";
      for each s in body do
         <>
           else
            <>
         >>;
      omark list(curmark,4);
      prin2ox "} ";
      omark list(curmark,4);
      prin2ox "break; ";
      omark list(curmark,2);
      prin2ox "}";
      if caddr assoc(curblock,blocks) and (curblock = 1) then 
        <>;
      omarko curmark;
      prin2ox "}";
      curblock := cadr assoc(curblock,blocks);
      omark '(m d);
      curmark := curmark-2 
   end;

symbolic procedure labchk u;
   begin scalar x;
      for each z in u do 
        if atom z then x := list('!*label,z) . x else x := z . x;
      return reversip x
   end;

symbolic procedure varprx u;
   begin
      prin2ox "LispObject ";
      while u do
        <>;
      omark list(curmark,2)
   end; 

put('rblock,pretoprinf,'blockox);


symbolic procedure condox u;
   begin scalar w,x,y,z;
      y:=0;
      omark '(m u);
      curmark := curmark+2;
      while u do
        <>;
          if not atom cadar u and caadar u memq '(go return) then 
            <>;
          mprino cadar u;
          if atom cadar u or not 
            (caadar u memq '(progn cond go return)) then 
            prin2ox "; ";
          if x then prin2ox ";} ";
          u := cdr u;
          if u then 
            <>;
                  mprino cadar u;
                  if atom cadar u or not 
                    (caadar u memq '(progn cond go return)) then 
                    prin2ox "; ";
                  if w then prin2ox ";} ";
                  u := nil>>
               else <>>>>>;
      for z:=1:y do prin2ox "}";    
      curmark := curmark - 2;
      omark '(m d)
   end;

put('cond,pretoprinf,'condox);


symbolic procedure gox u;
   begin scalar w;
      w:=assoc(car u,labs);
      prin2ox "nextlab";
      prinox curblock;
      prin2ox " := "; 
      mprino cdr w; 
      prin2ox "; ";
      omark list(curmark,6);
      prin2ox "continue"
   end;

put('go,pretoprinf,'gox);


symbolic procedure retox u;
   begin
      omark '(m u);
      curmark := curmark+2;
      prin2ox "retVal := ";
      omark '(m u);
      mprino car u;
      prin2ox "; ";
      omark list(curmark,0);
      prin2ox "break";
      caddr assoc(curblock,blocks) := 't;
      curmark := curmark - 2;
      omark '(m d);
      omark '(m d)
   end;

put('return,pretoprinf,'retox);
 

symbolic procedure labox u;
   <>;

put('!*label,pretoprinf,'labox);


symbolic procedure quotox u;
   if stringp u then prinox u 
   else <>;

put('quote,pretoprinf,'quotox);


symbolic procedure prognox u;
   begin
      curmark := curmark+1;
      prin2ox "{";
      omark '(m u);
      while u do 
        <>;
          u:=cdr u>>;
      omark '(m d);
      prin2ox "} ";
      curmark := curmark - 1
   end;

put('prog2,pretoprinf,'prognox);
put('progn,pretoprinf,'prognox);


symbolic procedure setqox u;
   begin
      mprino car u;
      prin2ox " := ";
      if null cddr u then mprino cadr u
      else mprino cdr u
   end;

put('setq,pretoprinf,'setqox);


symbolic procedure listox u;
   begin
      curmark := curmark+1;
      prin2ox "{";
      omark '(m u);
      while u do <>>>;
      omark '(m d);
      prin2ox "}";
      curmark := curmark - 1
   end;

put('list,pretoprinf,'listox);


symbolic procedure repeatox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "do ";
      mprino car u;
      prin2ox " while (NOT ";
      omark list(curmark,3);
      mprino cadr u;
      prin2ox ") ";
      omark '(m d);
      curmark := curmark - 1
   end;

put('repeat,pretoprinf,'repeatox);


symbolic procedure whileox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "while (";
      mprino car u;
      prin2ox ") ";
      omark list(curmark,3);
      mprino cadr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('while,pretoprinf,'whileox);


symbolic procedure procox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      if cadddr cdr u then <>;
      prin2ox "procedure ";
      procox1(car u,cadr u,caddr u)
   end;

symbolic procedure procox1(u,v,w);
   begin
      prinox u;
      if v then mprargs(v,list(0,0));
      prin2ox "; ";
      omark list(curmark,3);
      mprino w;
      curmark := curmark - 1;
      omark '(m d)
   end;

put('proc,pretoprinf,'procox);



symbolic procedure proceox0(u,v,w,x);
   proceox list(u,'symbolic,v,for each j in w collect j . 'symbolic,x);

symbolic procedure deox u;
   proceox0(car u,'expr,cadr u,caddr u);

put('de,pretoprinf,'deox);

% symbolic procedure dfox u;
%   proceox0(car u,'fexpr,cadr u,caddr u);

%put('df,pretoprinf,'dfox);  % Commented out because of confusion with
                             % differentiation.  We also want to
                             % discourage use of fexpr in REDUCE.

symbolic procedure dsox u;
   proceox0(car u,'smacro,cadr u,caddr u);

put('ds,pretoprinf,'dsox);

symbolic procedure stringox u;
   <>;

put('string,pretoprinf,'stringox);

symbolic procedure lambdox u;
   begin
      omark '(m u);
      curmark := curmark+1;
      procox1('lambda,car u,cadr u)
   end;

put('lambda,pretoprinf,'lambdox);

symbolic procedure eachox u;
   <>;
     mprino car u>>;

put('foreach,pretoprinf,'eachox);

symbolic procedure forox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "for (";
      mprino car u;
      prin2ox ":=";
      mprino caadr u;
      prin2ox "; (";
      mprino car u;
      prin2ox "==";
      mprino caddr cadr u;
      prin2ox "); ";
      mprino car u;
      prin2ox ":=";
      mprino car u;
      prin2ox "+";
      mprino cadr cadr u;
      prin2ox ") ";

      mprino caddr u;
      prin2ox " ";
      omark list(curmark,3);
      mprino cadddr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('for,pretoprinf,'forox);

symbolic procedure forallox u;
   begin
      curmark := curmark+1;
      omark '(m u);
      prin2ox "for all ";
      inprino('!*comma!*,list(0,0),car u);
      if cadr u
        then <>;
      prin2ox " ";
      omark list(curmark,3);
      mprino caddr u;
      omark '(m d);
      curmark := curmark - 1
   end;

put('forall,pretoprinf,'forallox);

Comment Support for printing algebraic mode code;

put('aeval!*,pretoprinf,'aevalox);

put('aeval,pretoprinf,'aevalox);

symbolic procedure aevalox(u);
      mprino aevalox1 car u;

symbolic procedure aevalox1 u;
  % unquote and listify.
  if eqcar(u,'quote) then cadr u else
  if eqcar(u,'list) then
    for each q in u collect aevalox1 q else u;

symbolic procedure minuspox u;
  if eqcar(car u,'difference) then
     mprino('lessp.cdar u) else mprino('lessp.car u.'(0));

put('minusp,pretoprinf,'minuspox);
put('aminusp!:,pretoprinf,'minuspox);
put('evalequal,pretoprinf,function (lambda u;mprino('equal.u)));
put('evalgreaterp,pretoprinf,function (lambda u;mprino('greaterp.u)));
put('evalgeq,pretoprinf,function (lambda u;mprino('geq.u)));
put('evallessp,pretoprinf,function (lambda u;mprino('lessp.u)));
put('evalleq,pretoprinf,function (lambda u;mprino('leq.u)));
put('evalneq,pretoprinf,function (lambda u;mprino('neq.u)));
put('!:dn!:,pretoprinf,function (lambda u;
                mprino(float car u*expt(float 10,cdr u))));
put('!:rd!:,pretoprinf,function (lambda u;
                mprino(if atom u then u else
                        float car u*expt(float 2,cdr u))));
put('plus2,pretoprinf,function(lambda u;mprino('plus.u)));


Comment Declarations needed by old parser;

if null get('!*semicol!*,'op)
  then <>;

% Code for printing active comments.

symbolic procedure princom u;
   % Print an active comment.
   begin scalar w,x,y,z; integer n;
      x := explode2 u;
      % Process first line.
      while car x eq '!  do x := cdr x;
      while x and car x neq !$eol!$ do <>;
      while y and car y eq '!  do y := cdr y;
      w := reversip!* y;    % Header line.
      % Process remaining lines.
      while x and (x := cdr x) do
       <>;
         while x and car x neq !$eol!$ do <>;
         while y and car y eq '!  do y := cdr y;
         z := (n . reversip!* y) . z>>;
      % Find line with least blanks.
      y := z;
      if y
        then <>;
      while z do <>;
      % Now merge lines where possible.
      while y do
       <>)
               else bool := nil;
           x := car u . x; u := cdr u>>;
      rplacd(buffp,reversip!* x);
      while cdr buffp do buffp := cdr buffp
   end;


Comment RPRINT MODULE, Part 2;

fluid '(orig curpos);

symbolic procedure prinos u;
   begin integer curpos;
        scalar !*lower,orig;
      orig := list posn();
      curpos := car orig;
      prinoy(u,0);
      terpri0x()
   end;

symbolic procedure prinoy(u,n);
   begin scalar x;
      if car(x := spaceleft(u,n)) then return prinom(u,n)
       else if null cdr x then return if car orig<10 then prinom(u,n)
       else <>
      else begin
        a: u := prinoy(u,n+1);
           if null cdr u or caar u<=n then return;
           terpri0x();
           spaces20x(curpos := car orig+cadar u);
           go to a end;
      return u
   end;

symbolic procedure spaceleft(u,mark);
   %U is an expanded buffer of characters delimited by non-atom marks
   %of the form: '(M ...) or '(INT INT))
   %MARK is an integer;
   begin integer n; scalar flg,mflg;
      n := rmar - curpos;
      u := cdr u;   %move over the first mark;
      while u and not flg and n>=0 do
        <=caar u then <>
           else mflg := t;
          u := cdr u>>;
      return ((n>=0) . mflg)
   end;

symbolic procedure prinom(u,mark);
   begin integer n; scalar flg,x;
      n := curpos;
      u := cdr u;
      while u and not flg do
        <>
          else if caar u eq 'm
           then if cadar u eq 'u then orig := n . orig
                 else if cadar u eq 'l
                  then (if chars2 cdr u > (rmar - posn())
                          then <>)
                 else orig := cdr orig
           else if mark>=caar u
             and not(x='!, and rmar - n - 6>charspace(u,x,mark))
            then <>;
          u := cdr u>>;
      curpos := n;
        if mark=0 and cdr u
          then <>;
          %must be a top level constant;
      return u
   end;

symbolic procedure chars2 u; chars21(u,0);

symbolic procedure chars21(u,n);
   if eqcar(car u,'m) then n else chars21(cdr u,n+1);

symbolic procedure charspace(u,char,mark);
   %determines if there is space until the next character CHAR;
   begin integer n;
      n := 0;
      while u do
        <0 do <>;

symbolic procedure prin2rox u;
   begin integer m,n; scalar x,y;
      m := rmar - 12;
      n := rmar - 1;
      while u do
        if car u eq '!"
          then <>
                  else nil;
                 prin20x '!";
                 u := cdr u;
                 while not(car u eq '!") do
                   <>;
                 prin20x '!";
                 u := cdr u;
                 !*n := !*n+2;
                 x := y := nil>>
         else if atom car u and not(car u eq '!  and (!*n=0 or null x
              or cdr u and breakp cadr u or breakp x and not(y eq '!!)))
          then <m and not breakp car u and nospace(u,n - !*n)
          then <> else nil>>
         else u := cdr u
   end;

symbolic procedure nospace(u,n);
   if n<1 then t
    else if null u then nil
    else if not atom car u then nospace(cdr u,n)
    else if not(car u eq '!!) and (cadr u eq '!  or breakp cadr u)
     then nil
    else nospace(cdr u,n - 1);

symbolic procedure breakp u;
   u member '(!< !> !; !: != !) !+ !- !, !' !");

symbolic procedure stringspace(u,n);
   if n<1 then nil else car u eq '!" or stringspace(cdr u,n - 1);


Comment Some interfaces needed;

symbolic procedure prin20x u;
   if rprifn!* then apply1(rprifn!*,u) else prin2 u;

symbolic procedure terpri0x;
   if rterfn!* then lispeval {rterfn!*} else terpri();


Comment OLD STUFF WHICH I HAVEN'T GOT RID OF YET;

%  symbolic procedure varprx u;
%        mapc(cdr u,function (lambda j;
%                          <>));
%
%Comment a version for the old parser;

%symbolic procedure varprx1 u;
%   begin scalar typ;
%     u := reverse u;
%       while u do
%        <>
%           else <>;
%                prinox (typ := cdar u);
%                  prin2ox " "; omark '(m u); prinox caar u>>;
%           u := cdr u>>;
%      prin2ox "; ";
%      omark '(m d)
%   end; 

%symbolic procedure prinsox u;
%   if atom u then prinox u
%    else <>
%                         else prin2ox " ">>>>;
%           curmark := curmark - 1;
%           omark '(m d);
%        prin2ox ")">>;

%symbolic procedure proceox1(u,v,w);
%    Prettyprint the procedure's argument list, any active annotation,
%    and its body.
%   begin scalar annot;
%      prinox u;
%      if v
%        then <>;
%      prin2ox "; ";
%      if annot := get(u,'active!-annotation) then
%            <>;
%      omark list(curmark,3);
%      mprino w;
%      curmark := curmark - 3;
%      omark '(m d)
%   end;

%symbolic procedure blockox2 u;
%   begin
%      omark '(m u);
%      curmark := curmark+2;
%      prin2ox "begin ";
%      if car u then varprx car u;
%      u := labchk cdr u;
%      omark list(curmark,if eqcar(car u,'!*label) then 1 else 3);
%      while u do
%        <>;
%      omark list(curmark - 1,-1);
%      prin2ox " end";
%      curmark := curmark - 2;
%      omark '(m d)
%   end;


endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/package.map0000644000175000017500000002445711527641631025431 0ustar  giovannigiovanni% This is a copy of ".../trunk/packages/package.map" but has a number of
% lines commented out with the result that the Java build (if it uses this
% file) will build a mini-Reduce with only a selection of the main set of
% packages. This capability will be useful because of the reduction in the
% size of the image file and hence the jar package.

% The selection of what to include and what to omit here is rather a matter
% of taste and the eventual selection must be made on the basis of the needs
% of the eventual user. The sample choices here are not intended to be any
% reflection on the global value of any particular packages. Also after
% making a selection here it will be necessary to do a careful evaluation and
% run proper tests to assure oneself that any omitted packages are not in
% fact prerequisites for things then included.

(
 (support       "support"     core                               psl)
 (rlisp         "rlisp"       core                           csl psl)
 (alg           "alg"         core      test                 csl psl)
 (poly          "poly"        core      test                 csl psl)
 (polydiv       "poly"        core      test                 csl psl)
 (arith         "arith"       core      test                 csl psl)
 (mathpr        "mathpr"      core                           csl psl)
 (ezgcd         "factor"      core                           csl psl)
 (factor        "factor"      core      test                 csl psl)
%(hephys        "hephys"      core                           csl psl)
 (int           "int"         core      test                 csl psl)
 (matrix        "matrix"      core      test                 csl psl)
%(rlisp88       "rlisp88"     core                           csl psl)
%(rprint        "rprint"      core                           csl psl)
%(fmprint       "rprint"      core                           csl psl)
%(pretty        "rprint"      core                           csl psl)
 (solve         "solve"       core      test                 csl psl)
%(desir         "solve"       core      test                 csl psl)
 (ineq          "solve"       core      test                 csl psl)
 (modsr         "solve"       core      test                 csl psl)
 (rsolve        "solve"       core      test                 csl psl)
 (algint        "algint"      core      test                 csl psl)
 (arnum         "arnum"       core      test                 csl psl)
 (assist        "assist"      core      test                 csl psl)
 (dummy         "assist"      core      test                 csl psl)
%(cantens       "assist"      core      test                 csl psl)
%(atensor       "atensor"     core      test                 csl psl)
%(avector       "avector"     core      test                 csl psl)
%(invbase       "invbase"     core      test                 csl psl)
 (misc          "misc"        core                           csl psl)
 (boolean       "misc"        core      test                 csl psl)
%(cedit         "misc"        core                           csl psl)
%(rcref         "misc"        core                           csl psl)
%(ftr           "misc"        core                           csl psl)
 (reset         "misc"        core                           csl psl)
%(cali          "cali"        core      test                 csl psl)
%(camal         "camal"       core      test                 csl psl)
 (changevr      "misc"        core      test                 csl psl)
 (compact       "misc"        core      test                 csl psl)
 (dfpart        "misc"        core      test                 csl psl)
%(lie           "misc"        core      test                 csl psl)
 (assert        "assert"                test                 csl psl)
 (odesolve      "odesolve"    noncore   test                 csl psl)
 (pf            "misc"                  test                 csl psl)
%(cvit          "hephys"                test                 csl psl)
%(noncom2       "hephys"                                     csl psl)
%(physop        "hephys"                test                 csl psl)
%(crack         "crack"                 test                 csl psl)
%(liepde        "crack"                 test                 csl psl)
%(applysym      "crack"                 test                 csl psl)
%(conlaw        "crack"                 test                 csl psl)
%(excalc        "excalc"                test                 csl psl)
%(gentran       "gentran"               test                 csl psl)
%(fide1         "fide"                                       csl psl)
%(fide          "fide"                  test                 csl psl)
 (numeric       "numeric"               test                 csl psl)
 (randpoly      "misc"                  test                 csl psl)
%(reacteqn      "misc"                  test                 csl psl)
 (roots         "roots"                 test                 csl psl)
%(rlfi          "misc"                  test                 csl psl)
 (roots2        "roots"                                      csl psl)
 (sets          "misc"                  test                 csl psl)
%(xideal        "xideal"                test                 csl psl)
%(eds           "eds"                   test                 csl psl)
%(dipoly        "dipoly"                                     csl psl)
%(groebner      "groebner"              test                 csl psl)
%(groebnr2      "groebner"                                   csl psl)
%(ideals        "groebner"              test                 csl psl)
 (linalg        "linalg"                test                 csl psl)
%(ncpoly        "ncpoly"                test                 csl psl)
 (normform      "normform"              test                 csl psl)
%(orthovec      "orthovec"              test                 csl psl)
%(plot          "plot"                                       csl psl)
%(gnuplot       "plot"                                       csl psl)
%(laplace       "laplace"               test                 csl psl)
%(pm            "pm"                    test                 csl psl)
%(qsum          "qsum"                  test                 csl psl)
%(scope         "scope"                 test                 csl psl)
%(sparse        "sparse"                test                 csl psl)
%(spde          "spde"                  test                 csl psl)
 (specfn        "specfn"                test                 csl psl)
 (specfn2       "specfn"                                     csl psl)
 (specfaux      "specfn"                                     csl psl)
 (specbess      "specfn"                                     csl psl)
 (sfgamma       "specfn"                                     csl psl)
 (tps           "tps"                   test                 csl psl)
 (limits        "misc"                  test                 csl psl)
 (defint        "defint"                test                 csl psl)
 (fps           "specfn"                test                 csl psl)
 (trigint       "trigint"               test                 csl psl)
 (ratint        "ratint"                test                 csl psl)
 (mathml        "mathml"                test                 csl psl)
%(mathmlom      "mathml"                test                 csl psl)
%(rltools       "redlog/rltools"                             csl psl)
%(redlog        "redlog/rl"             test                 csl psl)
%(cgb           "cgb"                   test                 csl psl)
%(cl            "redlog/cl"                                  csl psl)
%(ofsf          "redlog/ofsf"           test                 csl psl)
%(dvfsf         "redlog/dvfsf"                               csl psl)
%(acfsf         "redlog/acfsf"                               csl psl)
%(dcfsf         "redlog/dcfsf"                               csl psl)
 (geometry      "geometry"                                   csl psl)
%(ibalp         "redlog/ibalp"          test                 csl psl)
%(pasf          "redlog/pasf"           test                 csl psl)
%(qqe           "redlog/qqe"                                 csl psl)
%(qqe_ofsf      "redlog/qqe_ofsf"       test                 csl psl)
%(mri           "redlog/mri"                                 csl psl)
%(mri_ofsf      "redlog/mri"                                 csl psl)
%(mri_pasf      "redlog/mri"                                 csl psl)
%(redfront      "redfront"                                   csl psl)
%(reduce4       "reduce4"                                    csl psl)
%(tables        "reduce4"                                    csl psl)
%(talp          "redlog/talp"                                csl psl)
%(v3tools       "crack"                                      csl psl)
 (sum           "sum"                   test                 csl psl)
 (zeilberg      "sum"                   test                 csl psl)
%(symaux        "symmetry"                                   csl psl)
%(symmetry      "symmetry"              test                 csl psl)
 (taylor        "taylor"                test                 csl psl)
 (mrvlimit      "mrvlimit"              test                 csl psl)
 (residue       "residue"               test                 csl psl)
%(susy2         "susy2"                 test                 csl psl)
%(tri           "tri"                   test                 csl psl)
 (trigsimp      "trigsimp"              test                 csl psl)
%(xcolor        "xcolor"                test                 csl psl)
 (wu            "wu"                    test                 csl psl)
%(ztrans        "ztrans"                test                 csl psl)
 (geoprover     "geometry"              test                 csl psl)
 (rataprx       "rataprx"               test                 csl psl)
%(rtrace        "rtrace"                                     csl psl)
 (tmprint       "tmprint"                                    csl psl)
%(libreduce     "libreduce"                                  csl psl)
%(qepcad        "redlog/qepcad"                              csl psl)
 (utf8          "utf8"                                       csl psl)
%(lpdo          "lpdo"                  test                 csl psl)
%(mma           "redlog/mma"                                 csl psl)
%(guardian      "guardian"              test                 csl psl)
%(cdiff         "cdiff"                 test                 csl psl)
)

% End of configuration data
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/datatypes/0000755000175000017500000000000011722677351025326 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/datatypes/Cons.java0000644000175000017500000003173111555446662027103 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.datatypes;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


// A "cons" is an ordered pair. In ML terms it would be
// a bit like ('a * 'b)

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.functions.lisp.Macro;
import org.mathpiper.mpreduce.exceptions.ProgEvent;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.functions.builtin.Fns;

import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;
import org.mathpiper.mpreduce.special.Specfn;
import org.mathpiper.mpreduce.symbols.Symbol;

public class Cons extends LispObject
{

    public static int consCount = 0;
    static int consCountDown = 1000000;

// The left and right parts of a pair are called
//                CAR and CDR

    public Cons()
    {
        super(null, null);
    }

    public Cons(LispObject car, LispObject cdr) throws ResourceException {
        super(car, cdr);
        consCount++;
        if (--consCountDown < 0) {
            consCountDown = 1000000;
            ResourceException.space_now++;
            if (ResourceException.space_limit > 0
                    && ResourceException.space_limit < ResourceException.space_now)
                         {   if (Jlisp.headline)
 	  	                 {   Jlisp.errprintln();
 	  	                     Jlisp.errprintln("+++ space usage limit exceeded");
 	  	                 }
                throw new ResourceException("space");
            }
        }
    }

// Function calls are written as lists (fn a1 a2 ...)
    public LispObject eval() throws Exception
    {
        if(Jlisp.interruptEvaluation == true)
        {
                Jlisp.interruptEvaluation = false;
                Jlisp.error("Evaluation Interrupted.");
        }
                int n = 0;
        try         // So I can display a backtrace of my own
        {   Symbol fname = null;
            if (car instanceof Symbol)
            {   fname = (Symbol)car;
                if (fname.fn instanceof Macro)
                {   LispObject r = fname.fn.op1(this); // use 1-arg version
                    return r.eval();
                }
                else if (fname.special != null)
                {   return fname.special.op(cdr);
                }
            }
            LispObject a;
            for (a=cdr; !a.atom; a = a.cdr) n++;
            if (fname != null)
            {   switch (n)
                {
            case 0: return fname.fn.op0();
            case 1: a = cdr.car.eval();
                    if (Specfn.progEvent != Specfn.NONE) return Environment.nil;
                    return fname.fn.op1(a);
            case 2: a = cdr.car.eval();
                    if (Specfn.progEvent != Specfn.NONE) return Environment.nil;
                    LispObject b = cdr.cdr.car.eval();
                    if (Specfn.progEvent != Specfn.NONE) return Environment.nil;
                    return fname.fn.op2(a, b);
            default:
                    LispObject [] args = new LispObject [n];
                    n = 0;
                    for (a=cdr;
                         !a.atom;
                         a = a.cdr)
                    {   args[n++] = a.car.eval();
                        if (Specfn.progEvent != Specfn.NONE) return Environment.nil;
                    }
                    return fname.fn.opn(args);
                }
            }
            LispObject [] args = new LispObject [n];
            n = 0;
            for (a=cdr;
                 !a.atom;
                 a = a.cdr) args[n++] = a.car;
// Now the head of the list is not a symbol. The only
// other legal possibility is that it is a lambda-expression,
// so I should look for (lambda vars body ...)
            if (!car.atom)
            {   for (int i=0; i currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("(");
        if (x.car == null) 
        {   if ((currentFlags & noLineBreak) == 0 &&
                currentOutput.column + 6 > currentOutput.lineLength)
                currentOutput.println();
            currentOutput.print("");
        }
        else x.car.iprint();
        x = x.cdr;
        while (x != null && !x.atom)
        {   if (car == null)
            {   if ((currentFlags & noLineBreak) == 0 &&
                    currentOutput.column + 6 >= currentOutput.lineLength)
                    currentOutput.println();
                else currentOutput.print(" ");
                currentOutput.print("");
            }
            else x.car.blankprint();
            x = x.cdr;
        }
        if (x != Environment.nil)
        {   if ((currentFlags & noLineBreak) == 0 &&
                currentOutput.column + 1 >= currentOutput.lineLength)
                currentOutput.println();
            else currentOutput.print(" ");
            currentOutput.print(".");
            if (x == null)
            {   if ((currentFlags & noLineBreak) == 0 &&
                    currentOutput.column + 6 >= currentOutput.lineLength)
                    currentOutput.println();
                else currentOutput.print(" ");
                currentOutput.print("");
            }
            else x.blankprint();
        }
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 1 > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(")");
    }

    public void blankprint() throws ResourceException
    {
        if (currentOutput.column + 1 >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        iprint();
    }

    public LispObject copy()
    {
        LispObject a = this;
        LispObject r = Environment.nil;
        while (!a.atom) {
            int re = ResourceException.space_limit;
            ResourceException.space_limit = -1;
            try {
                r = new Cons(a.car.copy(), r);
            } catch (ResourceException e) {   // Because I reset space_limit this can never happen!
            }
            ResourceException.space_limit = re;
            a = a.cdr;
        }
        while (!r.atom)
        {   LispObject w = r;
            r = r.cdr;
            w.cdr = a;
            a = w;
        }
        return a;
    }

    public boolean lispequals(Object b)
    {
        if (b == this) return true;
        else if (!(b instanceof Cons)) return false;
        LispObject a1 = this, b1 = (LispObject)b;
        for (;;)
        {   LispObject p1 = a1.car, q1 = b1.car;
            if (!p1.lispequals(q1)) return false;
            p1 = a1.cdr;
            q1 = b1.cdr;
            if (p1 == q1) return true;
            if (p1.atom) return p1.lispequals(q1);
            if (q1.atom) return false;
            a1 = p1;
            b1 = q1;
        }
    }

  // The idea used to hash Cons cells here is to accept that I have to
  // drop through and do a recursive tree walk. But very deep trees
  // and especially looped up structures would be a MENACE. So I truncate
  // the search at a depth of "100" where each CAR direction link costs
  // 10 and each CDR direction link costs only 1. The expectation is that
  // this limits the total cost to O(1000) - bad but tolerable. When I
  // exceed the limit I must hand back a fixed value. I use crude and
  // not-thought-out arithmetic to combine hash-values of components.
  // Note that if a tree contains vectors I will need to limit recursion
  // through them too.
    public int lisphashCode()
    {
        return lisphashCode(this, 100);
    }

    public int lisphashCode(LispObject a, int n)
    {   int r = 9990;
        while (n >= 0 && !a.atom)
        {   n--;
            LispObject ca = a;
            if (!ca.car.atom)
                r = 169*r - lisphashCode(ca.car, n-10);
            else r = 11213*r + ca.car.lisphashCode();
            a = ca.cdr;
        }
        if (n < 0) return r + 212215;
        else if (a instanceof LispVector)
            return ((LispVector)a).lisphashCode(n-3)*0xfade0ff - r;
        else return a.lisphashCode()*0xDe5ade + r;
    }

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
        {   if (!LispReader.repeatedObjects.containsKey(this))
            {   LispReader.repeatedObjects.put(
                    this,
                    Environment.nil); // value is junk at this stage
            }
        }
        else
        {   LispReader.objects.add(this);
            LispReader.stack.push(cdr);
            LispReader.stack.push(car);
        }
    }

    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
        if (w != null &&
            w instanceof Integer) putSharedRef(w); // processed before
        else
        {   if (w != null) // will be used again sometime
            {   LispReader.repeatedObjects.put(
                    this,
                    new Integer(LispReader.sharedIndex++));
                Jlisp.odump.write(X_STORE);
            }
            int n = 1;
            boolean starred = false;
            LispObject l = cdr;
            LispReader.spine[0] = car;
            while (n < 16 &&
                   !l.atom &&
                   LispReader.repeatedObjects.get(l) == null)
            {   LispReader.spine[n++] = l.car;
                l = l.cdr;
            }
            if (n < 16 &&
                Jlisp.specialNil && // ha ha be careful here
                l == Environment.nil)     // especially common case!
            {   Jlisp.odump.write(X_LIST+n);
            }
            else
            {   Jlisp.odump.write(X_LISTX+n-1);
                starred = true;
            }
            for (int i=0; i currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("[");
        if (vec.length == 0)
	{   if ((currentFlags & noLineBreak) == 0 &&
                currentOutput.column + 1 > currentOutput.lineLength)
                currentOutput.println();
            currentOutput.print("]");
            return;
        }
        if (vec[0] == null)
        {   if ((currentFlags & noLineBreak) == 0 &&
                currentOutput.column + 1 > currentOutput.lineLength)
                currentOutput.println();
            currentOutput.print(".");
        }
        else vec[0].iprint();
        for (int i=1; i= currentOutput.lineLength)
                    currentOutput.println();
                else currentOutput.print(" ");
                currentOutput.print(".");
            }
            else vec[i].blankprint();
        }
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 1 > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print("]");
    }

    public void blankprint() throws ResourceException
    {
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + 1 >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        iprint();
    }

    public boolean lispequals(Object b)
    {
        if (!(b instanceof LispVector)) return false;
        if (b == this) return true;
        else if (this == LispReader.obvector || b == LispReader.obvector) return false;
        LispVector vb = (LispVector)b;
        if (vec.length != vb.vec.length) return false;
        for (int i=0; i currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = "#";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else 
	{   LispReader.objects.add(this);
            for (Iterator e = hash.keySet().iterator();
                 e.hasNext();
	        )
            {   Object k = e.next();
                Object v = hash.get(k);
		LispReader.stack.push(v);
		LispReader.stack.push(k);
	    }
	}
    }
  
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    Jlisp.odump.write(X_HASH + flavour);
	    for (Iterator e = hash.keySet().iterator();
	         e.hasNext();
		)
            {   Object k = e.next();
	        Object v = hash.get(k);
		LispReader.stack.push(v);
		LispReader.stack.push(k);
            }
	    Jlisp.odump.write(X_ENDHASH);
	}
    }


}


// end of LispHash.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/datatypes/LispString.java0000644000175000017500000001356611555446662030305 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.datatypes;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import java.io.IOException;
import java.io.ObjectInputStream;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispString extends LispObject
{

    public static int stringCount = 0;

    public String string;

    public LispString(String s)
    {
        this.string = s;
    }

    static StringBuffer sb = new StringBuffer();

    public void iprint() throws ResourceException
    {
        String s;
        if ((currentFlags & printEscape) != 0) s = escapedPrint(); 
        else s = string;
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println(); 
        currentOutput.print(s);
    }

    String escapedPrint()
    {
        sb.setLength(0);
        sb.append("\"");
        int n = string.indexOf('"');
        if (n == -1) sb.append(string);
        else
        {   int s = 0;
            while (n != -1)
            {   sb.append(string.substring(s, n+1));
                sb.append("\"");
                s = n+1;
                n = string.indexOf('"', s);
            }
            sb.append(string.substring(s, string.length()));
        }
        sb.append("\"");
        return sb.toString();
    }

    public void blankprint() throws ResourceException
    {
        String s;
        if ((currentFlags & printEscape) != 0) s = escapedPrint(); 
        else s = string;
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public boolean lispequals(Object b)
    {   if (!(b instanceof LispString)) return false;
        return string.equals(((LispString)b).string);
    }

    public boolean equals(Object b)
    {   if (!(b instanceof LispString)) return false;
        return string.equals(((LispString)b).string);
    }

    public int lisphashCode()
    {
        return string.hashCode();
    }
    
    public int hashCode()
    {
        return string.hashCode();
    }

    public void scan()
    {
        if (LispReader.objects.contains(string)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(string))
	    {   LispReader.repeatedObjects.put(
	            string,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(string);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(string);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            string,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
// The next line turns the string into bytes using the platform's default
// encoding. I would LIKE to use a representation guaranteed to be available
// and to behave consistently everywhere... 
	    byte [] rep = string.getBytes("UTF8");
	    int length = rep.length;
	    putPrefix2(length, X_STRn, X_STR);
	    for (int i=0; i",           // various special characters
	" ",
	"\n",
	"\b",
	"\t",
	"\f",
	"\r",
	"\u007f",          // rubout/delete
	"\u001b",          // ESCAPE
	"lispsystem*",
	"*raise",
	"*lower",
	"*comp",
        "compile",
	"common-lisp-mode",
        "*echo",
        "&optional",
        "&rest",
        "*savedef",
        "*package*",
        "*terminal-io*",
        "*standard-output*",
        "*standard-input*",
        "*error-output*",
        "*trace-output*",
        "*debug-io*",
        "*query-io*",
        "*redefmsg",
        "*resources*",

        "++spare2++",
        "++spare1++"
    };
    
// The names listed here MUST be in the same order as entries in the
// above table.

    public static final int restart    = 0;
    public static final int banner     = 1;
    public static final int hashtab    = 2;
    public static final int birthday   = 3;
    public static final int spareV     = 4;
 
    public static final int undefined  = 5;
    public static final int lambda     = 6;
    public static final int quote      = 7;
    public static final int comma      = 8;
    public static final int commaAt    = 9;
    public static final int cons       = 10;
    public static final int append     = 11;
    public static final int special    = 12;
    public static final int global     = 13;
    public static final int expr       = 14;
    public static final int subr       = 15;
    public static final int macro      = 16;
    public static final int fexpr      = 17;
    public static final int input      = 18;
    public static final int output     = 19;
    public static final int noncom     = 20;
    public static final int eof        = 21;
    public static final int space      = 22;
    public static final int newline    = 23;
    public static final int backspace  = 24;
    public static final int tab        = 25;
    public static final int formFeed   = 26;
    public static final int cr         = 27;
    public static final int rubout     = 28;
    public static final int escape     = 29;
    public static final int lispsystem = 30;
    public static final int raise      = 31;
    public static final int lower      = 32;
    public static final int starcomp   = 33;
    public static final int compile    = 34;
    public static final int commonLisp = 35;
    public static final int starecho   = 36;
    public static final int optional   = 37;
    public static final int rest       = 38;
    public static final int savedef    = 39;
    public static final int starpackage= 40;
    public static final int terminal_io= 41;
    public static final int std_output = 42;
    public static final int std_input  = 43;
    public static final int err_output = 44;
    public static final int tr_output  = 45;
    public static final int debug_io   = 46;
    public static final int query_io   = 47;
    public static final int redefmsg   = 48;
    public static final int resources  = 49;
    public static final int spare2     = 50;
    public static final int spare1     = 51;
}

// end of Lit.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/runprofile.bat0000644000175000017500000000030011527641631026171 0ustar  giovannigiovanniif "L%1" == "L" then goto L
set m=%1
goto M
:L
set m=alg
:M
echo testing module %m%
java -classic -Djava.compiler=none -Xrunhprof:cpu=samples Jlisp -w profile.red -Dwhich_module=%m%

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/Makefile0000644000175000017500000000545211527641631024771 0ustar  giovannigiovanni# Makefile for "Jlisp"
# Now using a reasonably standard "make" syntax.


all:	reduce.jar minireduce.jar jlisp.jar

.PHONY:	clean
clean:
	-rm -f *.jar *.class *.img *.log *.bak *~

# The idea here is that the jar file contains EVERYTHING needed for
# Reduce, and so "java -jar reduce.jar" will launch the system with its
# default image file.

reduce.jar:	*.java jlisp_manifest reduce.img
	javac *.java
	cp reduce.img default.img
	-rm -f reduce.jar
	jar cmf jlisp_manifest reduce.jar *.class default.img
	rm default.img

# minireduce.jar is a cut-down system not containing all the Reduce modules.
# It will thus be smaller (albeit less capable of performing advanced
# operations).

minireduce.jar:	*.java jlisp_manifest minireduce.img
	javac *.java
	cp minireduce.img default.img
	-rm -f minireduce.jar
	jar cmf jlisp_manifest minireduce.jar *.class default.img
	rm default.img

# jlisp.jar is merely the Lisp system without any algebra. If may sometimes
# be easier to work with this smaller system while developing or interfacing?

jlisp.jar:	*.java jlisp_manifest jlisp.img
	javac *.java
	cp jlisp.img default.img
	-rm -f jlisp.jar
	jar cmf jlisp_manifest jlisp.jar *.class default.img
	rm default.img


JLISP   = java -jar jlisp.jar
MEM=300M
STK=8M
REDUCE	= java -Xmx$(MEM) -Xms$(MEM) -Xss$(STK) -jar reduce.jar


###########################################################################

C = ../cslbase

# I make the targets here .PHONY so that (eg) "make reduce.img" always
# rebuilds the image even though I have not got careful dependencies set up
# to make it clear why this is necessary.

.PHONY:	jlisp.img
jlisp.img:
	javac *.java
	-rm -f jlisp.img
	java Jlisp -w -v -z -o jlisp.img $(C)/buildcsl.lsp \
		-D@cslbase="$(C)" -- jlispimg.log



.PHONY:	reduce.img
reduce.img:
	javac *.java
	-rm -f reduce.img
	java Jlisp -w -v -z -o reduce.img $(C)/buildreduce.lsp \
		-D@srcdir="$(C)" -- reduce.log


.PHONY:	minireduce.img
minireduce.img:
	javac *.java
	-rm -f minireduce.img
	java Jlisp -w -v -z -o minireduce.img $(C)/buildreduce.lsp \
		-Dminireduce -D@srcdir="$(C)" -- reduce.log


.PHONY:	testall
testall:
	mkdir -p testlogs
	$(REDUCE) -w $(C)/testall.red -D@srcdir=$(C) -- testlogs/testreduce.log
	$(REDUCE) -w $(C)/checkall.red -D@srcdir=$(C) -- testlogs/checkall.log

.PHONY:	test1
# Use:    make test1 which=modulename
test1:
	mkdir -p testlogs
	$(REDUCE) -w -v $(C)/testall.red -D@srcdir=$(C) -Dwhich=$(which) -- testlogs/test$(which).log

.PHONY:	debug1
# Use:    make debug1 which=modulename
#         as test1 but passes the "-g" flag that makes all backtraces noisy.
debug1:
	mkdir -p testlogs
	$(REDUCE) -w -v -g $(C)/testall.red -D@srcdir=$(C) -Dwhich=$(which) -- testlogs/test$(which).log

.PHONY:	checkall
checkall:
	mkdir -p testlogs
	$(REDUCE) -w $(C)/checkall.red -D@srcdir=$(C) -- testlogs/checkall.log

# end of Makefile
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/symbols/0000755000175000017500000000000011722677351025020 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/symbols/Symbol.java0000644000175000017500000003224611555446662027142 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.symbols;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


// Class to represent Lisp symbols

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.special.SpecialFunction;
import org.mathpiper.mpreduce.io.Fasl;
import org.mathpiper.mpreduce.functions.lisp.Undefined;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;

import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class Symbol extends LispObject
{

    public static int symbolCount = 0;

// ALL LispObjects have car and cdr fields, which can contain other
// LispObjects. So I might as well use those for the fields I would otherwise
// need here that are of that type, ie value and plist. Ugh!

//  LispObject value;        // shallow-binding         use .car instead!
//  LispObject plist;        // property list           use .cdr instead!

    public String pname;            // print name
    int cacheFlags;          // used with cacheString to speed up..
    String cacheString;      // .. printing when escape chare may be needed
    public LispFunction fn;         // function (if any)
    public SpecialFunction special; // special fn (if any)


    public void completeName()      // needed to that gensyms can have delayed names
    {
    }

// intern() looks up a Java String and find the Lisp
// symbol with that name. It creates it if needbe. This version
// always sets the (pre-defined) function call of this symbol. It is
// only used from cold-start code.

    public static Symbol intern(String name,
                         LispFunction fn, 
                         SpecialFunction special)
    {
        Symbol p;
        int inc = name.hashCode();
        int hash = ((169*inc) & 0x7fffffff) % LispReader.oblistSize;
        inc = 1 + (inc & 0x7fffffff) % (LispReader.oblistSize-1);
        for (;;)
        {   p = LispReader.oblist[hash];
            if (p == null) break;    // symbol is not in oblist
            if (p.pname.equals(name)) 
            {   if (fn != null) p.fn = fn;
                if (special != null) p.special = special;
                return p;
            }
            hash += inc;
            if (hash >= LispReader.oblistSize) hash -= LispReader.oblistSize;
        }
// not found on object-list, so create it.
        p = new Symbol();
        p.pname = name;
        p.cacheFlags = -1;
        p.car/*value*/ = Jlisp.lit[Lit.undefined];
        p.cdr/*plist*/ = Environment.nil;
        LispReader.oblist[hash] = p;
        if (fn != null) p.fn = fn;
        else p.fn = new Undefined(name);
        p.special = special;
        LispReader.oblistCount++;
        if (4*LispReader.oblistCount > 3*LispReader.oblistSize) LispReader.reHashOblist();
        return p;
    }

// now the version of intern() for normal use
    public static Symbol intern(String name)
    {
        Symbol p;
        int inc = name.hashCode();
        int hash = ((169*inc) & 0x7fffffff) % LispReader.oblistSize;
        inc = 1 + (inc & 0x7fffffff) % (LispReader.oblistSize-1);
        for (;;)
        {   p = LispReader.oblist[hash];
            if (p == null) break;    // symbol is not in oblist
            if (p.pname.equals(name)) return p;
            hash += inc;
            if (hash >= LispReader.oblistSize) hash -= LispReader.oblistSize;
        }
// not found on object-list, so create it.
        p = new Symbol();
        p.pname = name;
        p.cacheFlags = -1;
        p.car/*value*/ = Jlisp.lit[Lit.undefined];
        p.cdr/*plist*/ = Environment.nil;
        LispReader.oblist[hash] = p;
        p.fn = new Undefined(name);
        p.special = null;
        LispReader.oblistCount++;
        if (4*LispReader.oblistCount > 3*LispReader.oblistSize) LispReader.reHashOblist();
        return p;
    }

    public LispObject eval()
    {   return car/*value*/;
    }

    static StringBuffer cache = new StringBuffer();

    String toPrint()
    {
        completeName();
        if ((currentFlags & (printEscape | printLower | printUpper)) == 0)
            return pname;
        else if (currentFlags == cacheFlags) return cacheString;
        cache.setLength(0);
        String p = pname;
        if (p.length() == 0) return p;
        cacheFlags = currentFlags;
        if ((currentFlags & printLower) != 0) p = p.toLowerCase();
        else if ((currentFlags & printUpper) != 0) p = p.toUpperCase();
        char c = p.charAt(0);
        if ((currentFlags & printEscape) != 0)
        {   if (Character.isLetter(c))
            {   if (((Symbol)Jlisp.lit[Lit.lower]).car/*value*/ !=
                    Environment.nil)
                {   if (Character.isUpperCase(c))
                        cache.append((char)'!');
                }
                else if (((Symbol)Jlisp.lit[Lit.raise]).car/*value*/ !=
                    Environment.nil)
                {   if (Character.isLowerCase(c))
                        cache.append((char)'!');
                }
                cache.append((char)c);
            }
//          else if ((int)c < 32)
//          {   cache.append("\\x" + Integer.toHexString((int)c));
//          }
            else
            {   cache.append((char)'!');
                cache.append((char)c);
            }
        }
        else cache.append((char)c);
        for (int i=1; i currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = toPrint();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public int lisphashCode()
    {
        completeName();
        return 139*pname.hashCode() ^ 0x12345678; 
    }

    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
        {   if (!LispReader.repeatedObjects.containsKey(this))
            {   LispReader.repeatedObjects.put(
                    this,
                    Environment.nil); // value is junk at this stage
            }
        }
        else 
        {   LispReader.objects.add(this);
            if (Jlisp.descendSymbols)
            {   if (car/*value*/ != null) LispReader.stack.push(car/*value*/);
                if (cdr/*plist*/ != null) LispReader.stack.push(cdr/*plist*/);
                if (fn != null) LispReader.stack.push(fn);
                if (special != null) LispReader.stack.push(special);
            }
        }
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
        if (w != null &&
            w instanceof Integer)
        {   if (Jlisp.specialNil &&
                this == Environment.nil) 
                // important enough for a special-case, but must not use
                // that while dumping itself!
                Jlisp.odump.write(X_LIST+0);
            else putSharedRef(w); // processed before
        }
        else
        {   if (w != null) // will be used again sometime
            {   LispReader.repeatedObjects.put(
                    this,
                    new Integer(LispReader.sharedIndex++));
                Jlisp.odump.write(X_STORE);
            }
// Now this is the first time I see this symbol while writing a dump
// file. For a symbol I emit
//    SYM n c0 c1 ... cn  // the name
//    special fn plist value
            if (!Jlisp.descendSymbols) // ie for FASL not PRESERVE
            {
// The search here is a crude linear search through the most recent
// 512 symbols mentioned. I could use a hash table but the code overhead
// makes this really simple look attractive as a start.
                 for (int i=0; i<512; i++)
                 {   if (Fasl.recent[i] == this)
                     {    int op = X_RECENT;
                          if (i >= 256)
                          {   op = X_RECENT1;
                              i -= 256;
                          }
                          Jlisp.odump.write(op);
                          Jlisp.odump.write(i);
                          Fasl.recentn++;
                          return;
                     }
                 }
            }
            byte [] rep = pname.getBytes("UTF8");
            int length = rep.length;
// Because I expect it to be a common case I have a special opcode
// for a function that does not have a function associated with it.
// I also have to take special care with uninterned symbols, and since
// I do not have unlimited space in the opcode map I do not manage to
// optimise these two cases at the same time.
            boolean undefined = false;
// NB gensyms are handled as a derived class so do not need attention here
            if (fn instanceof Undefined &&
                LispReader.repeatedObjects.get(fn) == null)
            {   putPrefix2(length, X_UNDEFn, X_UNDEF);
                undefined = true;
            }
            else putPrefix2(length, X_SYMn, X_SYM);
            for (int i=0; i> 8) & 0xff);
            Jlisp.odump.write((myNumber >> 16) & 0xff);
            Jlisp.odump.write((myNumber >> 24) & 0xff);
	    if (Jlisp.descendSymbols)	
	    {   LispReader.stack.push(car/*value*/);
	        LispReader.stack.push(cdr/*plist*/);
	        LispReader.stack.push(special);
	        LispReader.stack.push(fn);
	    }
	}
    }

}

// end of Gensym.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/0000755000175000017500000000000011722677352025004 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/LispFloat.java0000644000175000017500000004405111555446662027552 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.numbers;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



import java.math.BigDecimal;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispFloat extends LispNumber
{
    public double value;

    public LispFloat(int value)
    {
        this.value = (double)value;
    }

    public LispFloat(String value)
    {
        Double d = Double.valueOf(value);
        this.value = d.doubleValue();
    }

    public LispFloat(double value)
    {
        this.value = value;
    }

    public LispObject eval()
    {
        return this;
    }

    public void iprint() throws ResourceException
    {
        String s = trimTo(Jlisp.printprec);
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }
    
    public void blankprint() throws ResourceException
    {
        String s = trimTo(Jlisp.printprec);
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }


// The next method is something that I am reasonably upset about since
// I believe that Java ought to provide this sort of formatting but at
// present I can not see how and where it does it.
    String trimTo(int n) // trim to n significant figures
    {
        if (n < 1) n = 1;
        else if (n > 16) n = 16; // limit precision to sensible range
        String s = Double.toString(value);
//Jlisp.println("original = " + s);
        int len = s.length();
        char [] s1 = s.toCharArray();
// identify and remove any "-" sign
        boolean neg = false;
        if (s1[0] == '-')
        {   neg = true;
            for (int i=0; i= 0.5.
//Jlisp.println("truncated = " + new String(s1, 0, len) + " x= " + x);
            if (next >= '5')         // need to round up?
            {   char w = 'x';
                for (int k=len-1; k >= 0; k--)
                {   w = s1[k];
                    w = (char)(w == '9' ? '0' : w + 1);
                    s1[k] = w;
                    if (w != '0') break;
                }
// If the number being rounded (say to 5 places) had been 999997 then
// rounding converts it to (1)00000. The "1" would in natural cases go
// into s1[-1], but in this case I KNOW that all remaining digits in s1
// are "0" so I can safely put it in s1[0]! I then have to adjust the
// exponent to reflect the shift.
                if (w == '0')
                {   s1[0] = '1';
                    x++;
                }
            }
        }
//Jlisp.println("rounded = " + new String(s1, 0, len) + " x= " + x);
// Now I guess I can trim any trailing zeros
        while (len>0 && s1[len-1] == '0')
        {   len--;
            x++;
        }
//Jlisp.println("no trailing 0 = " + new String(s1, 0, len) + " x= " + x);
// Finally I can try to decide on a format to use (F or E style)
// and reconstruct the result as a string
        if (len == 0) return "0.0";  // easy special case!
        StringBuffer r = new StringBuffer();
        if (neg) r.append("-");
        if (x>n || x<(-len-2)) // use "E" style
        {   r.append(s1[0]);
            r.append(".");
            if (len == 1) r.append("0");
            else r.append(s1, 1, len-1);
            r.append("e");
            r.append(x+len-1);
        }
        else // use "F" style
        {   int left = len;
            if (len+x <= 0) r.append("0");
            else 
            {   if (x > 0)
                {   r.append(s1, 0, len);
                    while (x > 0)
                    {   r.append("0");
                        x--;
                    }
                    left = 0;
                }
                else
                {   r.append(s1, 0, len+x);
                    left -= (len+x);
                }
            }
            r.append(".");
            if (left == 0) r.append("0");
            else 
            {   while (len+x < 0)
                {   r.append("0");
                    len++;
                }
                r.append(s1, len+x, left);
            }
        }
//Jlisp.println("result = " + r.toString());
        return r.toString();
    }

    public double doubleValue()
    {
        return value;
    }

    public boolean lispequals(Object b)
    {
        if (!(b instanceof LispFloat)) return false;
        return value == ((LispFloat)b).value;
    }
    
    public boolean equals(Object b)
    {   if (!(b instanceof LispFloat)) return false;
        return value == ((LispFloat)b).value;
    }

    public int lisphashCode()
    {
        return (new Double(value)).hashCode();
    }
    
    public int hashCode()
    {
        return (new Double(value)).hashCode();
    }
    
    public void scan()
    {
        Object w = new Double(value);
        if (LispReader.objects.contains(w)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(w))
	    {   LispReader.repeatedObjects.put(
	            w,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(w);
    }
    
    public void dump() throws Exception
    {
        Object d = new Double(value);
        Object w = LispReader.repeatedObjects.get(d);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            d,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    long rep = Double.doubleToLongBits(value);
	    Jlisp.odump.write(X_DOUBLE);
	    for (int i=0; i<8; i++)
	    {   Jlisp.odump.write((int)(rep >> (56-8*i)));
	    }
	}
    }

    public LispObject negate() throws Exception
    {
        return new LispFloat(-value);
    }

    public LispObject abs() throws Exception
    {
        if (value >= 0) return this;
        else return new LispFloat(-value);
    }

    public LispObject add(LispObject a) throws Exception
    {
        return new LispFloat(value + a.doubleValue());
    }

    public LispObject subtract(LispObject a) throws Exception
    {
        return new LispFloat(value - a.doubleValue());
    }

    public LispObject multiply(LispObject a) throws Exception
    {
        return new LispFloat(value * a.doubleValue());
    }

    public LispObject divide(LispObject a) throws Exception
    {
        return new LispFloat(value / a.doubleValue());
    }

    public LispObject remainder(LispObject a) throws Exception
    {
        return new LispFloat(value % a.doubleValue());
    }

    public LispObject expt(LispObject a) throws Exception
    {
// it is possible that I should delect cases where a is an integer
// and raise to a power using some alternative scheme, like repeated
// multiplication.
        return new LispFloat(Math.pow(value, a.doubleValue()));
    }

    public LispObject max(LispObject a) throws Exception
    {
        return (value >= a.doubleValue() ? this : a);
    }

    public LispObject min(LispObject a) throws Exception
    {
        return (value <= a.doubleValue() ? this : a);
    }

    public boolean eqn(LispObject a) throws Exception
    {
        return (value == a.doubleValue());
    }

    public boolean neqn(LispObject a) throws Exception
    {
        return (value != a.doubleValue());
    }

    public boolean ge(LispObject a) throws Exception
    {
        return (value > a.doubleValue());
    }

    public boolean geq(LispObject a) throws Exception
    {
        return (value >= a.doubleValue());
    }

    public boolean le(LispObject a) throws Exception
    {
        return (value < a.doubleValue());
    }

    public boolean leq(LispObject a) throws Exception
    {
        return (value <= a.doubleValue());
    }

    public LispObject add1() throws Exception
    {
        return new LispFloat(value + 1.0);
    }

    public LispObject sub1() throws Exception
    {
        return new LispFloat(value - 1.0);
    }

    public LispObject floor() throws Exception
    {
        BigDecimal w =
            new BigDecimal(value).setScale(0, BigDecimal.ROUND_FLOOR);
        return LispInteger.valueOf(w.toBigInteger());
    }

    public LispObject ceiling() throws Exception
    {
        BigDecimal w =
            new BigDecimal(value).setScale(0, BigDecimal.ROUND_CEILING);
        return LispInteger.valueOf(w.toBigInteger());
    }

    public LispObject round() throws Exception
    {
        BigDecimal w =
            new BigDecimal(value).setScale(0, BigDecimal.ROUND_HALF_EVEN);
        return LispInteger.valueOf(w.toBigInteger());
    }

    public LispObject truncate() throws Exception
    {
        BigDecimal w =
            new BigDecimal(value).setScale(0, BigDecimal.ROUND_DOWN);
        return LispInteger.valueOf(w.toBigInteger());
    }

    public LispObject fix() throws Exception
    {
        BigDecimal w =
            new BigDecimal(value).setScale(0, BigDecimal.ROUND_DOWN);
        return LispInteger.valueOf(w.toBigInteger());
    }

    public LispObject fixp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject integerp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject jfloat() throws Exception
    {
        return this;
    }

    public LispObject floatp() throws Exception
    {
        return Jlisp.lispTrue;
    }

    public LispObject minusp() throws Exception
    {
        return (value < 0.0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject plusp() throws Exception
    {
        return (value >= 0.0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject zerop() throws Exception
    {
        return (value == 0.0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject onep() throws Exception
    {
        return (value == 1.0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject addInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(a.value.doubleValue() + value);
    }

    public LispObject subtractInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(a.value.doubleValue() - value);
    }

    public LispObject multiplyInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(a.value.doubleValue() * value);
    }

    public LispObject divideInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(a.value.doubleValue() / value);
    }

    public LispObject remainderInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(a.value.doubleValue() % value);
    }

    public LispObject maxInteger(LispBigInteger a) throws Exception
    {
        if (a.value.doubleValue() >= value) return a;
        else return this;
    }

    public LispObject exptInteger(LispBigInteger a) throws Exception
    {
        return new LispFloat(Math.pow(a.doubleValue(), value));
    }

    public LispObject minInteger(LispBigInteger a) throws Exception
    {
        if (a.value.doubleValue() <= value) return a;
        else return this;
    }

    public boolean eqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() == value);
    }

    public boolean neqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() != value);
    }

    public boolean geInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() > value);
    }

    public boolean geqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() >= value);
    }

    public boolean leInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() < value);
    }

    public boolean leqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.doubleValue() <= value);
    }

    public LispObject addSmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat((double)a.value + value);
    }

    public LispObject subtractSmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat((double)a.value - value);
    }

    public LispObject multiplySmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat((double)a.value * value);
    }

    public LispObject divideSmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat((double)a.value / value);
    }

    public LispObject remainderSmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat((double)a.value % value);
    }

    public LispObject maxSmallInteger(LispSmallInteger a) throws Exception
    {
        if ((double)a.value >= value) return a;
        else return this;
    }

    public LispObject exptSmallInteger(LispSmallInteger a) throws Exception
    {
        return new LispFloat(Math.pow(a.doubleValue(), value));
    }

    public LispObject minSmallInteger(LispSmallInteger a) throws Exception
    {
        if ((double)a.value <= value) return a;
        else return this;
    }

    public boolean eqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value == value);
    }

    public boolean neqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value != value);
    }

    public boolean geSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value > value);
    }

    public boolean geqSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value >= value);
    }

    public boolean leSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value < value);
    }

    public boolean leqSmallInteger(LispSmallInteger a) throws Exception
    {
        return ((double)a.value <= value);
    }

}

// end of LispFloat.java
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/LispSmallInteger.java0000644000175000017500000005645511555446662031106 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.numbers;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



import java.math.BigInteger;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispSmallInteger extends LispInteger
{
    public int value;

// I will keep integers of up to 31 bits as "Small" integers. This means that
// the criterion I will use to notice them will be that as ints they will
// have their top two bits equal. For values in some (much) smaller range
// I will have a pre-allocated table of values and will return one of
// those when needed - thereby avoiding some heap allocation at the expense
// of extra calculation and testing.

    static final int MIN = -100;
    static final int MAX = 1000;
    static LispSmallInteger [] preAllocated = new LispSmallInteger[MAX-MIN+1];

    public static void preAllocate()
    {
        for (int i=MIN; i<=MAX; i++)
            preAllocated[i-MIN] = new LispSmallInteger(i);
    }

    public LispSmallInteger(int n)
    {
        value = n;
    }

    public int intValue()
    {
        return value;
    }

    public BigInteger bigIntValue()
    {
        return BigInteger.valueOf((long)value);
    }

    public LispObject eval()
    {
        return this;
    }

    String printAs()
    {
        if ((currentFlags & (printBinary | printOctal | printHex)) == 0)   
            return Integer.toString(value);
        else if ((currentFlags & printBinary) != 0)
            return Integer.toBinaryString(value);
        else if ((currentFlags & printOctal) != 0)
            return Integer.toOctalString(value);
        else // if ((currentFlags & printHex) != 0)
            return Integer.toHexString(value);
    }

    public void iprint() throws ResourceException
    {
        String s = printAs();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = printAs();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public double doubleValue()
    {
        return (double)value;
    }

    public boolean lispequals(Object b)
    {
        if (!(b instanceof LispSmallInteger)) return false;
        return value == ((LispSmallInteger)b).value;
    }
    
    public boolean equals(Object b)
    {
        if (!(b instanceof LispSmallInteger)) return false;
        return value == ((LispSmallInteger)b).value;
    }

    public int lisphashCode()
    {
        return value*696969;
    }
    
    public int hashCode()
    {
        return value*696969;
    }
    
    public void scan()
    {
        Object w = new Integer(value);
        if (LispReader.objects.contains(w)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(w))
	    {   LispReader.repeatedObjects.put(
	            w,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(w);
    }
    
    public void dump() throws Exception
    {
        Object d = new Integer(value);
        Object w = LispReader.repeatedObjects.get(d);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            d,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
// Note whacky coding with sign bit in bottom bit position. The intent
// of this is that numbers that ar esmall in absolute value will be
// packed into rather few bytes.
	    putPrefix(value == 0x80000000 ? 1 :
                      value < 0 ? 1 + ((-value)<<1) :
                      value<<1,
                      X_FIXNUM);
	}
    }

    public LispObject negate() throws Exception
    {
        if (value == 0xc0000000) return new LispBigInteger(-value);
        return valueOf(-value);
    }

    public LispObject abs() throws Exception
    {
        if (value >= 0) return this;
        else if (value == 0xc0000000) return new LispBigInteger(-value);
        else return valueOf(-value);
    }

    public LispObject add1() throws Exception
    {
        if (value == 0x3fffffff) return new LispBigInteger(0x40000000);
        else return valueOf(value+1);
    }

    public LispObject sub1() throws Exception
    {
        if (value == 0xc0000000) return new LispBigInteger(0xbfffffff);
        return valueOf(value-1);
    }

    public LispObject msd() throws Exception
    {
        int r = 0, w = value;
        if (w < 0) w = -(w + 1);
        while ((w & ~0x3f) != 0)
        {   w = w >>> 6;
            r += 6;
        }
        while (w != 0)
        {   w = w >>> 1;
            r += 1;
        }
        return valueOf(r);
    }

    public LispObject lsd() throws Exception
    {
        int r = 0, w = value;
        if (w == 0) return valueOf(-1);
        while ((w & 0x3f) == 0)
        {   w = w >> 6;
            r += 6;
        }
        while ((w & 0x1) == 0)
        {   w = w >> 1;
            r += 1;
        }
        return valueOf(r);
    }

    public LispObject not() throws Exception
    {
        return valueOf(~value);
    }

    public LispObject modMinus() throws Exception
    {
        if (value == 0) return this;
        else return valueOf(Jlisp.modulus - value);
    }

    public LispObject modRecip() throws Exception
    {
        if (value == 0) 
            return Jlisp.error("attempt to take modular recip of zero");
        int a = Jlisp.modulus, b = value, s = 0, t = 1;
        while (b != 0)
        {   int q = a/b;
            int w = a - q*b; a = b; b = w;
            w = s - q*t; s = t; t = w;
        }
        if (s < 0) s += Jlisp.modulus;
        return valueOf(s);
    }

    public LispObject safeModRecip() throws Exception
    {
        if (value == 0) return Environment.nil;
        int a = Jlisp.modulus, b = value, s = 0, t = 1;
        while (b != 0)
        {   int q = a/b;
            int w = a - q*b; a = b; b = w;
            w = s - q*t; s = t; t = w;
        }
        if (s < 0) s += Jlisp.modulus;
        return valueOf(s);
    }

    public LispObject reduceMod() throws Exception
    {
        int r = value % Jlisp.modulus;
        if (r < 0) r += Jlisp.modulus;
        return valueOf(r);
    }

    public LispObject floor() throws Exception
    {
        return this;
    }

    public LispObject ceiling() throws Exception
    {
        return this;
    }

    public LispObject round() throws Exception
    {
        return this;
    }

    public LispObject truncate() throws Exception
    {
        return this;
    }

    public LispObject ash(int n) throws Exception
    {
        if (n > 0) return valueOf(BigInteger.valueOf((long)value).shiftLeft(n));
        else if (n < -31)
        {   if (value < 0) return valueOf(-1);
            else return valueOf(0);
        }
        else if (n < 0) return valueOf(value >> (-n));
        else return this;
    }

    public LispObject ash1(int n) throws Exception
    {
        if (n > 0) return valueOf(BigInteger.valueOf((long)value).shiftLeft(n));
        else if (n < -31) return valueOf(0);
        else if (n < 0)
        {   if (value >= 0)
                return valueOf(value >> (-n));
            else return valueOf(-((-value) >> (-n)));
        }
        else return this;
    }

    public LispObject rightshift(int n) throws Exception
    {
        return valueOf(value >> n);
    }

    public LispObject evenp() throws Exception
    {
        return ((value & 1) != 0) ? Environment.nil : Jlisp.lispTrue;
    }

    public LispObject oddp() throws Exception
    {
        return ((value & 1) != 0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject fix() throws Exception
    {
        return this;
    }

    public LispObject fixp() throws Exception
    {
        return Jlisp.lispTrue;
    }

    public LispObject integerp() throws Exception
    {
        return Jlisp.lispTrue;
    }

    public LispObject jfloat() throws Exception
    {
        return new LispFloat((double)value);
    }

    public LispObject floatp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject minusp() throws Exception
    {
        return value < 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject plusp() throws Exception
    {
        return value >= 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject zerop() throws Exception
    {
        return value == 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject onep() throws Exception
    {
        return value == 1 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject add(LispObject a) throws Exception
    {
        return a.addSmallInteger(this);
    }

    public LispObject subtract(LispObject a) throws Exception
    {
        return a.subtractSmallInteger(this);
    }

    public LispObject multiply(LispObject a) throws Exception
    {
        return a.multiplySmallInteger(this);
    }

    public LispObject expt(LispObject a) throws Exception
    {
        return a.exptSmallInteger(this);
    }

    public LispObject divide(LispObject a) throws Exception
    {
        return a.divideSmallInteger(this);
    }

    public LispObject remainder(LispObject a) throws Exception
    {
        return a.remainderSmallInteger(this);
    }

    public LispObject quotientAndRemainder(LispObject a) throws Exception
    {
        return a.quotientAndRemainderSmallInteger(this);
    }

    public LispObject mod(LispObject a) throws Exception
    {
        return a.modSmallInteger(this);
    }

    public LispObject max(LispObject a) throws Exception
    {
        return a.maxSmallInteger(this);
    }

    public LispObject min(LispObject a) throws Exception
    {
        return a.minSmallInteger(this);
    }

    public LispObject and(LispObject a) throws Exception
    {
        return a.andSmallInteger(this);
    }

    public LispObject or(LispObject a) throws Exception
    {
        return a.orSmallInteger(this);
    }

    public LispObject xor(LispObject a) throws Exception
    {
        return a.xorSmallInteger(this);
    }

    public LispObject gcd(LispObject a) throws Exception
    {
        return a.gcdSmallInteger(this);
    }

    public LispObject lcm(LispObject a) throws Exception
    {
        return a.lcmSmallInteger(this);
    }

    public LispObject modAdd(LispObject a) throws Exception
    {
        return a.modAddSmallInteger(this);
    }

    public LispObject modSubtract(LispObject a) throws Exception
    {
        return a.modSubtractSmallInteger(this);
    }

    public LispObject modMultiply(LispObject a) throws Exception
    {
        return a.modMultiplySmallInteger(this);
    }

    public LispObject modDivide(LispObject a) throws Exception
    {
        return a.modDivideSmallInteger(this);
    }

    public LispObject modExpt(int a) throws Exception
    {
        long r = 1;
        long w = value;
        while (a != 0)
        {   if ((a & 1) != 0) r = (r*w) % Jlisp.modulus;
            w = (w*w) % Jlisp.modulus;
            a = a >>> 1;
        }
        if (r < 0) r += Jlisp.modulus;
        return valueOf(r);
    }

    public boolean eqn(LispObject a) throws Exception
    {
        return a.eqnSmallInteger(this);
    }

    public boolean neqn(LispObject a) throws Exception
    {
        return a.neqnSmallInteger(this);
    }

    public boolean ge(LispObject a) throws Exception
    {
        return a.geSmallInteger(this);
    }

    public boolean geq(LispObject a) throws Exception
    {
        return a.geqSmallInteger(this);
    }

    public boolean le(LispObject a) throws Exception
    {
        return a.leSmallInteger(this);
    }

    public boolean leq(LispObject a) throws Exception
    {
        return a.leqSmallInteger(this);
    }

// Now versions that know they have one integer and one small integer.
// I am going to accept that these will be seriously slower than the
// LispSmallInteger cases and to cope with that I will suppose that
// they always return small integers if they can.

    public LispObject addInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.add(BigInteger.valueOf((long)value)));
    }

    public LispObject subtractInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.subtract(BigInteger.valueOf((long)value)));
    }

    public LispObject multiplyInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.multiply(BigInteger.valueOf((long)value)));
    }

    public LispObject divideInteger(LispBigInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return valueOf(a.value.divide(BigInteger.valueOf((long)value)));
    }

    public LispObject remainderInteger(LispBigInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return valueOf(a.value.remainder(BigInteger.valueOf((long)value)));
    }

    public LispObject quotientAndRemainderInteger(LispBigInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        BigInteger [] r = a.value.divideAndRemainder(BigInteger.valueOf((long)value));
        return new Cons(valueOf(r[0]), valueOf(r[1]));
    }

    public LispObject modInteger(LispBigInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return valueOf(a.value.mod(BigInteger.valueOf((long)value)));
    }

    public LispObject exptInteger(LispBigInteger a) throws Exception
    {
        if (value < 0) return valueOf(0);
        else if (value == 0) return valueOf(1);
        else if (value >= 0x10000)
            return Jlisp.error("integer result would be too large");
        else return valueOf(a.value.pow(value));
    }

    public LispObject maxInteger(LispBigInteger a) throws Exception
    {
        if (a.value.compareTo(BigInteger.valueOf((long)value)) >= 0) return a;
        else return this;
    }

    public LispObject minInteger(LispBigInteger a) throws Exception
    {
        if (a.value.compareTo(BigInteger.valueOf((long)value)) <= 0) return a;
        else return this;
    }

    public LispObject andInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.and(BigInteger.valueOf((long)value)));
    }

    public LispObject orInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.or(BigInteger.valueOf((long)value)));
    }

    public LispObject xorInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.xor(BigInteger.valueOf((long)value)));
    }

    public LispObject gcdInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.gcd(BigInteger.valueOf((long)value)));
    }

    public LispObject lcmInteger(LispBigInteger a) throws Exception
    {
        return valueOf(LispBigInteger.biglcm(
           a.value, BigInteger.valueOf((long)value)));
    }

    public boolean eqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) == 0);
    }

    public boolean neqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) != 0);
    }

    public boolean geInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) > 0);
    }

    public boolean geqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) >= 0);
    }

    public boolean leInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) < 0);
    }

    public boolean leqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(BigInteger.valueOf((long)value)) <= 0);
    }

// Finally versions that know they have 2 small integer args. Here I need
// to worry about overflow and promote to a LispBigInteger in suitable cases.

    public LispObject addSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(a.value + value);
    }

    public LispObject subtractSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(a.value - value);
    }

    public LispObject multiplySmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf((long)a.value * (long)value);
    }

    public LispObject divideSmallInteger(LispSmallInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return valueOf(a.value / value);
    }

    public LispObject remainderSmallInteger(LispSmallInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return valueOf(a.value % value);
    }

    public LispObject quotientAndRemainderSmallInteger(LispSmallInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        return new Cons(valueOf(a.value / value),
                        valueOf(a.value % value));
    }

    public LispObject modSmallInteger(LispSmallInteger a) throws Exception
    {
        if (value == 0) return Jlisp.error("attempt to divide by zero");
        int r = a.value % value;
        if (value > 0)
        {   if (r < 0) r += value;
        }
        else if (r > 0) r += value;
        return valueOf(r);
    }

    public LispObject exptSmallInteger(LispSmallInteger a) throws Exception
    {
        if (value < 0) return valueOf(0);
        else if (value == 0) return valueOf(1);
        else if (value >= 0x10000)
                 return Jlisp.error("integer result would be too large");
        else return valueOf(
                        BigInteger.valueOf((long)a.value).pow(value));
    }

    public LispObject maxSmallInteger(LispSmallInteger a) throws Exception
    {
        if (a.value >= value) return a;
        else return this;
    }

    public LispObject minSmallInteger(LispSmallInteger a) throws Exception
    {
        if (a.value <= value) return a;
        else return this;
    }

    public LispObject andSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(a.value & value);
    }

    public LispObject orSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(a.value | value);
    }

    public LispObject xorSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(a.value ^ value);
    }

    public LispObject gcdSmallInteger(LispSmallInteger a) throws Exception
    {
        int p = a.value;
        int q = value;
        if (p < 0) p = -p;
        if (q < 0) q = -q;
        if (p == 0) return valueOf(q);
        if (p < q)
        {   q = q % p;
        }
        while (q != 0)
        {   int r = p % q;
            p = q;
            q = r;
        }
        return valueOf(p);
    }

    public LispObject lcmSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(
            LispBigInteger.biglcm(
                BigInteger.valueOf((long)a.value),
                BigInteger.valueOf((long)value)));
    }

    public LispObject modAddSmallInteger(LispSmallInteger a) throws Exception
    {
        int n = a.value + value;
        if (n >= Jlisp.modulus) n -= Jlisp.modulus;
        return valueOf(n);
    }

    public LispObject modSubtractSmallInteger(LispSmallInteger a) throws Exception
    {
        int n = a.value - value;
        if (n < 0) n += Jlisp.modulus;
        return valueOf(n);
    }

    public LispObject modMultiplySmallInteger(LispSmallInteger a) throws Exception
    {
        long n = (long)a.value * (long)value;
        return valueOf(n % Jlisp.modulus);
    }

    public LispObject modDivideSmallInteger(LispSmallInteger arg) throws Exception
    {
        if (value == 0) 
            return Jlisp.error("attempt to divide by (modular) zero");
        int a = Jlisp.modulus, b = value, s = 0, t = 1;
        while (b != 0)
        {   int q = a/b;
            int w = a - q*b; a = b; b = w;
            w = s - q*t; s = t; t = w;
        }
        if (s < 0) s += Jlisp.modulus;
        return valueOf(((long)s * (long)arg.value) % Jlisp.modulus);
    }

    public boolean eqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value == value);
    }

    public boolean neqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value != value);
    }

    public boolean geSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value > value);
    }

    public boolean geqSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value >= value);
    }

    public boolean leSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value < value);
    }

    public boolean leqSmallInteger(LispSmallInteger a) throws Exception
    {
        return (a.value <= value);
    }

}

// End of LispSmallInteger.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/LispBigInteger.java0000644000175000017500000004532211555446662030526 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.numbers;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import java.math.BigInteger;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispBigInteger extends LispInteger
{
    BigInteger value;

    public LispBigInteger(int value)
    {
        this.value = BigInteger.valueOf((long)value);
    }

    public LispBigInteger(long value)
    {
        this.value = BigInteger.valueOf(value);
    }

    public LispBigInteger(BigInteger value)
    {
        this.value = value;
    }

    public int intValue() throws Exception
    {
        int n;
        if (value.bitLength() <= 31 &&
            (n = value.intValue()) <= 0x3fffffff &&
            n >= -0x40000000) return n;
        Jlisp.error("Integer is too large", this);
        return 0; // never reached
    }

    public BigInteger bigIntValue()
    {
        return value;
    }

    public LispObject eval()
    {
        return this;
    }

    String printAs()
    {
        if ((currentFlags & (printBinary | printOctal | printHex)) == 0)   
            return value.toString();
        else if ((currentFlags & printBinary) != 0)
            return value.toString(2);
        else if ((currentFlags & printOctal) != 0)
            return value.toString(8);
        else // if ((currentFlags & printHex) != 0)
            return value.toString(16);
    }

    public void iprint() throws ResourceException
    {
        String s = printAs();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = printAs();
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public double doubleValue()
    {
        return value.doubleValue();
    }

    public boolean lispequals(Object b)
    {
        if (!(b instanceof LispBigInteger)) return false;
        return value.compareTo(((LispBigInteger)b).value) == 0;
    }
    
    public boolean equals(Object b)
    {
        if (!(b instanceof LispBigInteger)) return false;
	return value.compareTo(((LispBigInteger)b).value) == 0;
    }

    public int lisphashCode()
    {
        return value.hashCode();
    }
    
    public int hashCode()
    {
        return value.hashCode();
    }
    
    public void scan()
    {
        if (LispReader.objects.contains(value)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(value))
	    {   LispReader.repeatedObjects.put(
	            value,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(value);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(value);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            value,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
// Now this is the first time I see this integer while writing a dump
// file. I will put out a byte that says "here comes an integer", then
// the number of bytes used to represent it, and finally the set of bytes
// concerned. To save a little space I have variants to cope with the
// various possible sizes of length-code needed.
	    byte [] rep = value.toByteArray();
	    int length = rep.length;
	    putPrefix2(length, X_INTn, X_INT);
	    for (int i=0; i= 0) return this;
        else return valueOf(value.negate());
    }

    public LispObject msd() throws Exception
    {
        return valueOf(value.bitLength());
    }

    public LispObject lsd() throws Exception
    {
        return valueOf(value.getLowestSetBit());
    }

    public LispObject not() throws Exception
    {
        return valueOf(value.not());
    }

    public LispObject reduceMod() throws Exception
    {
        return valueOf(value.mod(Jlisp.bigModulus));
    }

    public LispObject add1() throws Exception
    {
        return valueOf(value.add(BigInteger.ONE));
    }

    public LispObject sub1() throws Exception
    {
        return valueOf(value.subtract(BigInteger.ONE));
    }

    public LispObject floor() throws Exception
    {
        return this;
    }

    public LispObject ceiling() throws Exception
    {
        return this;
    }

    public LispObject round() throws Exception
    {
        return this;
    }

    public LispObject truncate() throws Exception
    {
        return this;
    }

    public LispObject ash(int n) throws Exception
    {
        if (n > 0) return valueOf(value.shiftLeft(n));
        else if (n < 0) return valueOf(value.shiftRight(-n));
        else return this;
    }

    public LispObject ash1(int n) throws Exception
    {
        if (n > 0) return valueOf(value.shiftLeft(n));
        else if (n < 0)
        {   if (value.signum() >= 0)
                return valueOf(value.shiftRight(-n));
            else return valueOf(value.negate().shiftRight(-n).negate());
        }
        else return this;
    }

    public LispObject rightshift(int n) throws Exception
    {
        return valueOf(value.shiftRight(n));
    }

    public LispObject evenp() throws Exception
    {
        return value.testBit(0) ? Environment.nil : Jlisp.lispTrue;
    }

    public LispObject oddp() throws Exception
    {
        return value.testBit(0) ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject fix() throws Exception
    {
        return this;
    }

    public LispObject fixp() throws Exception
    {
        return Jlisp.lispTrue;
    }

    public LispObject integerp() throws Exception
    {
        return Jlisp.lispTrue;
    }

    public LispObject jfloat() throws Exception
    {
        return new LispFloat(value.doubleValue());
    }

    public LispObject floatp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject minusp() throws Exception
    {
        return value.signum() < 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject plusp() throws Exception
    {
        return value.signum() >= 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject zerop() throws Exception
    {
        return value.signum() == 0 ? Jlisp.lispTrue : Environment.nil;
    }

    public LispObject onep() throws Exception
    {
        return (value.compareTo(BigInteger.ONE) == 0) ? 
               Jlisp.lispTrue :
               Environment.nil;
    }

    public LispObject add(LispObject a) throws Exception
    {
        return a.addInteger(this);
    }

    public LispObject subtract(LispObject a) throws Exception
    {
        return a.subtractInteger(this);
    }

    public LispObject multiply(LispObject a) throws Exception
    {
        return a.multiplyInteger(this);
    }

    public LispObject expt(LispObject a) throws Exception
    {
        return a.exptInteger(this);
    }

    public LispObject divide(LispObject a) throws Exception
    {
        return a.divideInteger(this);
    }

    public LispObject remainder(LispObject a) throws Exception
    {
        return a.remainderInteger(this);
    }

    public LispObject quotientAndRemainder(LispObject a) throws Exception
    {
        return a.quotientAndRemainderInteger(this);
    }

    public LispObject mod(LispObject a) throws Exception
    {
        return a.modInteger(this);
    }

    public LispObject max(LispObject a) throws Exception
    {
        return a.maxInteger(this);
    }

    public LispObject min(LispObject a) throws Exception
    {
        return a.minInteger(this);
    }

    public LispObject and(LispObject a) throws Exception
    {
        return a.andInteger(this);
    }

    public LispObject or(LispObject a) throws Exception
    {
        return a.orInteger(this);
    }

    public LispObject xor(LispObject a) throws Exception
    {
        return a.xorInteger(this);
    }

    public LispObject gcd(LispObject a) throws Exception
    {
        return a.gcdInteger(this);
    }

    public LispObject lcm(LispObject a) throws Exception
    {
        return a.lcmInteger(this);
    }

    public boolean eqn(LispObject a) throws Exception
    {
        return a.eqnInteger(this);
    }

    public boolean neqn(LispObject a) throws Exception
    {
        return a.neqnInteger(this);
    }

    public boolean ge(LispObject a) throws Exception
    {
        return a.geInteger(this);
    }

    public boolean geq(LispObject a) throws Exception
    {
        return a.geqInteger(this);
    }

    public boolean le(LispObject a) throws Exception
    {
        return a.leInteger(this);
    }

    public boolean leq(LispObject a) throws Exception
    {
        return a.leqInteger(this);
    }

// now versions that know they have 2 integer args

    public LispObject addInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.add(value));
    }

    public LispObject subtractInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.subtract(value));
    }

    public LispObject multiplyInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.multiply(value));
    }

    public LispObject divideInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.divide(value));
    }

    public LispObject remainderInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.remainder(value));
    }

    public LispObject quotientAndRemainderInteger(LispBigInteger a) throws Exception
    {
        BigInteger [] r = a.value.divideAndRemainder(value);
        return new Cons(valueOf(r[0]), valueOf(r[1]));
    }

    public LispObject modInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.mod(value));
    }

    public LispObject exptInteger(LispBigInteger a) throws Exception
    {
        switch (value.signum())
        {
    case -1: return valueOf(0);
    case 0:  return valueOf(1);
    default:
             if (value.bitLength() > 15)
                 return Jlisp.error("integer result would be too large");
             else return valueOf(a.value.pow(value.intValue()));
        }
    }

    public LispObject maxInteger(LispBigInteger a) throws Exception
    {
        if (a.value.compareTo(value) >= 0) return a;
        else return this;
    }

    public LispObject minInteger(LispBigInteger a) throws Exception
    {
        if (a.value.compareTo(value) <= 0) return a;
        else return this;
    }

    public LispObject andInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.and(value));
    }

    public LispObject orInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.or(value));
    }

    public LispObject xorInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.xor(value));
    }

    public LispObject gcdInteger(LispBigInteger a) throws Exception
    {
        return valueOf(a.value.gcd(value));
    }

    public LispObject lcmInteger(LispBigInteger a) throws Exception
    {
        return valueOf(biglcm(a.value, value));
    }

    public boolean eqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) == 0);
    }

    public boolean neqnInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) != 0);
    }

    public boolean geInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) > 0);
    }

    public boolean geqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) >= 0);
    }

    public boolean leInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) < 0);
    }

    public boolean leqInteger(LispBigInteger a) throws Exception
    {
        return (a.value.compareTo(value) <= 0);
    }

// Finally versions that mix big and small integers. I will generally cope by
// converting the small integer to a big one.

    public LispObject addSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).add(value));
    }

    public LispObject subtractSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).subtract(value));
    }

    public LispObject multiplySmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).multiply(value));
    }

    public LispObject divideSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).divide(value));
    }

    public LispObject remainderSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).remainder(value));
    }

    public LispObject quotientAndRemainderSmallInteger(LispSmallInteger a) throws Exception
    {
        BigInteger [] r = BigInteger.valueOf((long)a.value).divideAndRemainder(value);
        return new Cons(valueOf(r[0]), valueOf(r[1]));
    }

    public LispObject modSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).mod(value));
    }

    public LispObject exptSmallInteger(LispSmallInteger a) throws Exception
    {
        switch (value.signum())
        {
    case -1: return valueOf(0);
    case 0:  return valueOf(1);
    default:
             if (value.bitLength() > 15)
                 return Jlisp.error("integer result would be too large");
             else return valueOf(BigInteger.valueOf((long)a.value).pow(value.intValue()));
        }
    }

    public LispObject maxSmallInteger(LispSmallInteger a) throws Exception
    {
        if (BigInteger.valueOf((long)a.value).compareTo(value) >= 0) return a;
        else return this;
    }

    public LispObject minSmallInteger(LispSmallInteger a) throws Exception
    {
        if (BigInteger.valueOf((long)a.value).compareTo(value) <= 0) return a;
        else return this;
    }

    public LispObject andSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).and(value));
    }

    public LispObject orSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).or(value));
    }

    public LispObject xorSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).xor(value));
    }

    public LispObject gcdSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(BigInteger.valueOf((long)a.value).gcd(value));
    }

    public LispObject lcmSmallInteger(LispSmallInteger a) throws Exception
    {
        return valueOf(biglcm(BigInteger.valueOf((long)a.value), value));
    }

    public boolean eqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) == 0);
    }

    public boolean neqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) != 0);
    }

    public boolean geSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) > 0);
    }

    public boolean geqSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) >= 0);
    }

    public boolean leSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) < 0);
    }

    public boolean leqSmallInteger(LispSmallInteger a) throws Exception
    {
        return (BigInteger.valueOf((long)a.value).compareTo(value) <= 0);
    }


    static public BigInteger biglcm(BigInteger a, BigInteger b)
    {
        a = a.abs();
        b = b.abs();
        if (a.equals(BigInteger.ZERO) &&
            b.equals(BigInteger.ZERO)) return BigInteger.ONE;
        BigInteger g = a.gcd(b);
        b = b.divide(g);
        return a.multiply(b);
    }
}

// End of LispBigInteger.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/LispInteger.java0000644000175000017500000000736111546225657030104 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.numbers;

//

import java.math.BigInteger;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/




public abstract class LispInteger extends LispNumber
{

    public static LispInteger valueOf(int value)
    {
        if (value <= LispSmallInteger.MAX &&
            value >= LispSmallInteger.MIN)
            return LispSmallInteger.preAllocated[value - LispSmallInteger.MIN];
        else if (value <= 0x3fffffff &&
            value >= -0x40000000) return new LispSmallInteger(value);
        else return new LispBigInteger(BigInteger.valueOf((long)value));
    }

    public static LispInteger valueOf(long value)
    {
        if (value <= LispSmallInteger.MAX &&
            value >= LispSmallInteger.MIN)
            return LispSmallInteger.preAllocated[
                       (int)(value - LispSmallInteger.MIN)];
        else if (value <= 0x3fffffffL &&
            value >= -0x40000000L) return new LispSmallInteger((int)value);
        else return new LispBigInteger(BigInteger.valueOf(value));
    }

    public static LispInteger valueOf(BigInteger value)
    {
        if (value.bitLength() <= 31)
        {   int n = value.intValue();
            if (n <= LispSmallInteger.MAX &&
                n >= LispSmallInteger.MIN)
                return LispSmallInteger.preAllocated[n - LispSmallInteger.MIN];
            else if (n <= 0x3fffffff &&
                     n >= -0x40000000) return new LispSmallInteger(n);
        }
        return new LispBigInteger(value);
    }


}

// End of LispInteger.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/numbers/LispNumber.java0000644000175000017500000000467711546225657027746 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.numbers;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

import org.mathpiper.mpreduce.LispObject;

public abstract class LispNumber extends LispObject
{
}

// end of LispNumber.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/Interpreter.java0000644000175000017500000002207111546225657026502 0ustar  giovannigiovanni/**************************************************************************
 * Copyright (C) 2011 Ted Kosan                                           *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

package org.mathpiper.mpreduce;

import java.io.BufferedInputStream;
import java.io.BufferedOutputStream;
import java.io.InputStreamReader;
import java.io.PipedInputStream;
import java.io.PipedOutputStream;
import java.io.PrintWriter;
import java.util.regex.Matcher;
import java.util.regex.Pattern;


/**
 *
 *
 */
public class Interpreter {

    Jlisp jlisp;
    private static Interpreter JlispCASInstance = null;
    private StringBuffer responseBuffer;
    private Pattern inputPromptPattern;
    private PipedInputStream myInputStream;
    private PipedOutputStream myOutputStream;
    private String response;
    private String startMessage;
    private String prompt;
    private Thread reduceThread;
    private boolean evaluationHalted = false;


    public Interpreter() {



        jlisp = new Jlisp();

        try {

            myOutputStream = new PipedOutputStream();
            myInputStream = new PipedInputStream();

            final PipedOutputStream jLispOutputStream = new PipedOutputStream(myInputStream);
            final PipedInputStream jLispInputStream = new PipedInputStream(myOutputStream);

            //myOutputStream.connect(jLispInputStream);
            //myInputStream.connect(jLispOutputStream);



            final String[] args = new String[0];

            reduceThread = new Thread(new Runnable() {

                public void run() {
                    try {
                        jlisp.startup(args,
                                new InputStreamReader(new BufferedInputStream(jLispInputStream)),
                                new PrintWriter(new BufferedOutputStream(jLispOutputStream)),
                                true);
                    } catch (Exception ex) {
                        ex.printStackTrace();
                    }
                }

            });

            reduceThread.setName("MPReduce");

            reduceThread.start();


            responseBuffer = new StringBuffer();
            inputPromptPattern = Pattern.compile("\n*[0-9]+\\:");


            startMessage = getResponse();


            //Initialize MPReduce.
            evaluate("symbolic procedure update!_prompt; begin setpchar \"f179eb\" end;;");
            inputPromptPattern = Pattern.compile("\n*(f179eb)+");
            getResponse();


            evaluate("off int; on errcont; off nat;");
            String switchSetResponce = getResponse();


        } catch (Throwable t) {
            t.printStackTrace();

        }



    }//end constructor.


    public String getStartMessage() {
        return startMessage;
    }//end method.


    public String getPrompt() {
        return prompt;
    }//end method.


    public static Interpreter getInstance() throws Throwable {
        if (JlispCASInstance == null) {
            JlispCASInstance = new Interpreter();
        }
        return JlispCASInstance;
    }//end method.


    public synchronized void evaluate(String send) throws Throwable {

        send = send.trim();

        if(((send.endsWith(";")) || (send.endsWith("$"))) != true)
        {
            send = send + ";\n"; 
        }

        while(send.endsWith(";;"))
        {
            send = send.substring(0,send.length()-1);
        }

        while(send.endsWith("$"))
        {
            send = send.substring(0,send.length()-1);
        }

        send = send + "\n";

        myOutputStream.write(send.getBytes());
        myOutputStream.flush();
        

    }//end evaluate.


    public void interruptEvaluation() {
        try {
            evaluate(""); //Needed to make sure the next evaluation after the interruption works okay.

            jlisp.interruptEvaluation = true;

            evaluationHalted = true;
        } catch (Throwable e) {
            //Each excpetion.
        }
    }


    public String getResponse() throws Throwable {
        boolean keepChecking = true;

        mainLoop:
        while (keepChecking) {
            int serialAvailable = myInputStream.available();
            if (serialAvailable == 0) {
                try {
                    Thread.sleep(100);
                } catch (InterruptedException ie) {
                    System.out.println("Jlisp session interrupted.");
                }
                continue mainLoop;
            }//end while

            byte[] bytes = new byte[serialAvailable];

            myInputStream.read(bytes, 0, serialAvailable);
            responseBuffer.append(new String(bytes));
            response = responseBuffer.toString();

            //Check for an error response.
            if(response.indexOf("*****") != -1)
            {
                responseBuffer.delete(0, responseBuffer.length());
                //response = response.trim();
                keepChecking = false;
            }

            //System.out.println("SSSSS " + response);
            Matcher matcher = inputPromptPattern.matcher(response);
            if (matcher.find()) {
                //System.out.println("PPPPPP found end");

                responseBuffer.delete(0, responseBuffer.length());

                int promptIndex = matcher.start();

                prompt = response.substring(promptIndex, response.length()).trim();
                response = response.substring(0, promptIndex);

                //response = response.trim();



                keepChecking = false;

            }//end if.

        }//end while.


        //Obtain the exceptin message from the input stream.
        if (this.evaluationHalted == true) { 
            int serialAvailable;
            while ((serialAvailable = myInputStream.available()) != 0) {
                byte[] bytes = new byte[serialAvailable];
                myInputStream.read(bytes, 0, serialAvailable);
                response = response + new String(bytes);
            }
            evaluationHalted = false;
        }

        if(! response.endsWith("$"))
        {
            response = response + "$";
        }

        return response;

    }//end method


    public static void main(String[] args) {
        Interpreter mpreduce = new Interpreter();

        String result = "";

        try {

            mpreduce.evaluate("off nat;");
            result = mpreduce.getResponse();
            System.out.println(result + "\n");

            mpreduce.evaluate("x^2;");
            result = mpreduce.getResponse();
            System.out.println(result + "\n");

            //An example which shows how to interrupt an evaluation.
            mpreduce.evaluate("(X-Y)^100;");
            Thread.sleep(100);
            System.out.println("Interrupting mpreduce evaluation.");
            mpreduce.interruptEvaluation();
            result = mpreduce.getResponse();
            System.out.println(result+ "\n");


            mpreduce.evaluate("2 + 2;");
            result = mpreduce.getResponse();
            System.out.println(result+ "\n");


            mpreduce.evaluate("Factorize(100);");
            result = mpreduce.getResponse();
            System.out.println(result+ "\n");

        } catch (Throwable t) {
            t.printStackTrace();
        }



    }

}//end class.


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/UserJava.java0000644000175000017500000000711111555446662025716 0ustar  giovannigiovannipackage org.mathpiper.mpreduce;

import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.exceptions.ResourceException;


// This is to demonstrate how user Java code can be called from Jlisp.
// You may edit this file to put in arbitrary Java definitions in the
// various methods (which had better be public static and named as shown 
// here). 
//
// From within Jlisp (and hence REDUCE) the function USERJAVA will then
// call the method from here that corresponds to the relevant number of
// arguments. This class MUST be called "UserJava" but it is loaded
// dynamically when Jlisp is running and when the first use of it is
// attempted. So the class file must be somewhere that the default Java
// classloader will look. But this file does NOT need to be present when
// Jlisp is built.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


public class UserJava
{
    public static LispObject op0()
    {
        return new LispString("Sample");
    }

    public static LispObject op1(LispObject a) throws ResourceException
    {
        return new Cons(a, a);
    }

    public static LispObject op2(LispObject a, LispObject b) throws ResourceException
    {
        return new Cons(b, a);
    }

    public static LispObject opn(LispObject [] a) throws ResourceException
    {
        LispObject r = Environment.nil;
        for (int i=0; i= because otherwise we might wake up EXACTLY after
					// timeout ms and currentTimeMillis - startTime = timeout. We would then
					// wait for another timeout ms, altough our timeout has already been reached.
					if (System.currentTimeMillis() - startTime >= timeoutMillis && sendString != null) {
						interruptEvaluation();
						
						// wait for JLisp to handle the interruption, then discard the output.
						while (sendString != null)
							outputLock.wait();
						out.flush();
						inputBuffer.delete(0, inputBuffer.length());
						throw new TimeoutException("MPReduce timout for expression: " + send.trim());
					}
				}
			} catch (InterruptedException ioe) {
			}
		}
		String responseString = this.inputBuffer.toString();
		inputBuffer.delete(0, inputBuffer.length());
		// System.err.println(responseString);
		return responseString;
	}


	public void interruptEvaluation() {
		try {
			Jlisp.interruptEvaluation = true;
		} catch (Throwable e) {
			// Each excpetion.
		}
	}

	// Lisp in, my out.
	class InterpreterReader extends Reader {
		Interpreter2 interpreter;
		int pos;
		String tmp = null;

		InterpreterReader(Interpreter2 interpreter) {
			this.interpreter = interpreter;
			sendString = null;
			tmp = null;
		}

		public int available() {
			if (sendString != null)
				return 1;
			else
				return 0;
		}

		public void close() {
		}

		public boolean markSupported() {
			return false;
		}

		public int read() {

			// if the buffer is empty, we'll wait until we get new input from the interpreter
			if (tmp == null) {
				synchronized(inputLock){				
					try {
						while (sendString == null) {
							inputLock.wait();
						}
					} catch (InterruptedException ioe)
					{}
					pos = 0;
					tmp = sendString;
				}
			}

			if (pos == tmp.length()) {
				tmp = null;
				interpreter.out.flush();
				synchronized(outputLock)
				{
					sendString = null;
					outputLock.notifyAll();
				}
				return (int) ' ';
			} else
			{
				return (int) tmp.charAt(pos++);
			}
		}

		public int read(char[] b) {
			if (b.length == 0)
				return 0;
			b[0] = (char) read();
			return 1;
		}

		public int read(char[] b, int off, int len) {
			if (b.length == 0 || len == 0)
				return 0;
			b[off] = (char) read();
			return 1;
		}
		
	}

	// Lisp out, my in.
	class InterpreterWriter extends CharArrayWriter {

		InterpreterWriter() {
			super(8000); // nice big buffer by default;
		}

		public void close() {
			flush();
		}
		
		public void flush() {
			super.flush();
			if (size() != 0) // mild optimisation, I suppose!
			{
				// The JavaDocs of the Writer class recommends to lock this way in sub-classes.
				// Here we MUST ensure that if we do the toString() that we do the reset()
				// before anybody adds any more characters to this stream.
				synchronized (lock) {
					Interpreter2.this.inputBuffer.append(toString());
					reset();
				}
			}
		}
	}

	public static void main(String[] args) {
		Interpreter2 mpreduce = new Interpreter2();

		String result = "";

		try {

			result = mpreduce.evaluate("off nat;");
			System.out.println(result + "\n");

			result = mpreduce.evaluate("x^2;");
			System.out.println(result + "\n");

			result = mpreduce.evaluate("(X-Y)^100;");
			System.out.println(result + "\n");

			result = mpreduce.evaluate("2 + 2;");
			System.out.println(result + "\n");

			result = mpreduce.evaluate("Factorize(100);");
			System.out.println(result + "\n");
			

			result = mpreduce.evaluate("Hold((x + x) / x);");
			System.out.println(result + "\n");

		} catch (Throwable t) {
			t.printStackTrace();
		} finally {
			System.exit(0);
		}

	}

}// end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/packagedatastore/0000755000175000017500000000000011722677351026632 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/packagedatastore/PDSInputStream.java0000644000175000017500000000706211546225657032326 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.packagedatastore;

//

import java.io.IOException;
import java.io.InputStream;

// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



public class PDSInputStream extends InputStream
{

PDS pds;

long savedPosition;
int left;

public PDSInputStream(PDS pds, String member) throws IOException
{
    this.pds = pds;
    if (pds == null || (pds.f == null && pds.data == null))
        throw new IOException("PDS member " + member + " not found"); 
    Object on = pds.directory.get(member);
    if (on == null)
        throw new IOException("PDS member " + member + " not found");
    left = ((PDSEntry)on).len;
    savedPosition = pds.getFilePointer();
    pds.seek((long)((PDSEntry)on).loc);
}

public int available()
{
    return left;
}

public void close() throws IOException
{
    pds.seek(savedPosition);
}

public boolean markSupported()
{
    return false;
}

public int read() throws IOException
{
    if (left <= 0) return -1;
    else
    {   int c = pds.read();
        left--;
        return c;
    }    
}

public int read(byte [] b) throws IOException
{
    return read(b, 0, b.length);
}

public int read(byte [] b, int off, int len) throws IOException
{
    if (left <= 0) return -1;
    if (left < len) len = left;
    int n = pds.read(b, off, len);
    left -= n;
    return n;
}

}

// end of PDSInputStream.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/packagedatastore/PDSOutputStream.java0000644000175000017500000000766111546225657032534 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.packagedatastore;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



import java.io.IOException;
import java.io.OutputStream;
import java.util.Date;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class PDSOutputStream extends OutputStream
{

PDS pds;
String member;
int length;

long savedPosition;

public PDSOutputStream(PDS pds, String member) throws IOException, ResourceException
{
    this.pds = pds;
    this.member = member;
    if (pds.f != null) savedPosition = pds.f.getFilePointer();
    else savedPosition = -1;
    if (pds.memberData != 0)
        throw new IOException("Attempt to have two output files open in one PDS");
    pds.addToDirectory(member);
    length = 0;
}

public void close() throws IOException
{
    if (pds == null) return;

    pds.f.seek(pds.memberData);
    pds.f.write(pds.memberStart >> 24);
    pds.f.write(pds.memberStart >> 16);
    pds.f.write(pds.memberStart >> 8);
    pds.f.write(pds.memberStart);
    pds.f.write(length >> 24);
    pds.f.write(length >> 16);
    pds.f.write(length >> 8);
    pds.f.write(length);
    long date = new Date().getTime();
    pds.f.write((int)(date >> 56));
    pds.f.write((int)(date >> 48));
    pds.f.write((int)(date >> 40));
    pds.f.write((int)(date >> 32));
    pds.f.write((int)(date >> 24));
    pds.f.write((int)(date >> 16));
    pds.f.write((int)(date >> 8));
    pds.f.write((int)date);
    pds.memberData = 0;
    pds.directory.put(member,
        new PDSEntry(member, pds.memberStart, length, date));
    if (savedPosition >= 0) pds.f.seek(savedPosition);
    pds = null;
}

public void write(int c) throws IOException
{
    pds.f.write(c);
    length++;
}

}

// end of PDSInputStream.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/packagedatastore/PDS.java0000644000175000017500000004630711555446662030140 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.packagedatastore;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



import java.io.File;
import java.io.IOException;
import java.io.InputStream;
import java.io.RandomAccessFile;
import java.util.Arrays;
import java.util.Date;
import java.util.HashMap;
import java.util.Iterator;
import java.util.Vector;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.io.streams.LispStream;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.exceptions.ResourceException;

// This class (and PDSInputStream & PDSOutputStream) support a crude
// version of a file-system-within-a-file.  No sub-directoried are
// allowed. Allocation is strictly sequential. There are potentially
// SEVERE constraints on having access to multiple members of the
// one file. These rules are
//  (a) All access must be strictly nested. If a member x is open
//      for either reading or writing and one opens a different member
//      y then you may not read from or write to x again until y has
//      been closed.
//  (b) Only one member may be open for writing at any one time.
// Adherence to these constraints my not be fully checked, and violating
// them might cause arbitrary confusion.
//
// Failure to close a member after opening it for writing will leave
// that member visible but with zero length.
// Exiting from the entire system without closing a PDS may leave it
// containing old and unwanted material.
// Replacing members of a PDS may cause the file to grow by a large
// amount until it is closed.

// Three bits of serious re-work are needed here and in related places:
// (a) When I delete or replace a PDS member at present the space
//     that had been used is left vacant and wasted. The PDS should be
//     compacted sometime.
// (b) Right now my code probably only supports a single image file,
//     and functions to get module dates, copy and rename modules etc are
//     not in place. They need to be provided.
//
// It might also be better to have two sub-classes of PDS for the versions
// that read from a file and from in-store data?

public class PDS
{

String name;
boolean writeable;
boolean untidy;

RandomAccessFile f;
Vector data;
HashMap directory;

private static final int bufferShift = 12;
private static final int bufferSize  = 1<> bufferShift));
            bufferValid = true;
        }
        int n = (int)(pos++ & bufferMask);
        c = buffer[n] & 0xff;
        if (n == bufferMask)
        {   bufferPos += bufferSize;
            bufferValid = false;
        }
        return c;
    }
    else return -1;
}

int read(byte [] b, int off, int len) throws IOException
{
    int c;
    if (f != null) return f.read(b, off, len);
    else if (data != null)
    {   if (!bufferValid)
        {   // unpack a new chunk of data...
            buffer = (byte [])data.get((int)(bufferPos >> bufferShift));
            bufferValid = true;
        }
        int p = (int)(pos & bufferMask);
        int n = bufferSize - p;  // bytes left in buffer
        if (n < len) len = n;    // trim request
        for (int i=0; i length()-buffer.length)
            throw new IOException("Not a Jlisp image file (chaining)");
        int n = 6, l;
        for (;;)
        {   l = buffer[n++] & 0xff; // length code
            if (l == 0) break;      // end of what is packed into this chunk
            if ((n + l + 16) > buffer.length)
                throw new IOException("Not a Jlisp image file (name length)");
            byte [] name = new byte[l];
            for (i=0; i f.length()-buffer.length)
                throw new IOException("Not a Jlisp image file (chaining)");
            n = 6;
            int l;
            for (;;)
            {   l = buffer[n++] & 0xff; // length code
                if (l == 0) break;      // end of what is packed into this chunk
                if ((n + l + 16) > buffer.length)
                    throw new IOException(
                        "Not a Jlisp image file (name length)");
                byte [] name = new byte[l];
                for (i=0; i 100)
            {   Jlisp.println("Looping...");
                throw new IOException("Sorry - mangled image file");
            }
            for (i=0; i= 0x100)
            throw new IOException("Name " + member +
                                  " for PSD member is too long");
        if (n + nbl + 16 >= buffer.length) 
// Would overflow this chunk, so chain on another one.
        {   long end = loc;
            loc = loc + DirectoryBlockSize;   // allow for the index block
            Jlisp.println("end = " + end);
            f.seek(p+2);
            f.write((int)(end >> 24));
            f.write((int)(end >> 16));
            f.write((int)(end >> 8));
            f.write((int)end);
            p = end;
            for (i=0; i> 7;
        if (n1 == 0) writer.write(n);
        else
        {   writer.write(n | 0x80);
            n = n1;
            n1 = n >> 7;
            if (n1 == 0) writer.write(n);
            else
            {   writer.write(n | 0x80);
                writer.write(n >> 7);
            }
        }
    }

    public static void faslWrite(LispObject arg1) throws Exception
    {
        LispReader.dumpTree(arg1, writer);
    }
    
    static String name;

    public static boolean openModule(LispObject arg1) throws LispException
    {
        name = "unknown";
        if (arg1 instanceof Symbol)
        {   ((Symbol)arg1).completeName();
            name = ((Symbol)arg1).pname;
        }
        else if (arg1 instanceof LispString) name = ((LispString)arg1).string;
        else Jlisp.error("symbol or string needed as module name");
        name = name + ".fasl";
        try 
        {   PDSInputStream ff = null;
            for (int i=0; i= 0x100)
        {   Bytecode bps2 = new ByteOpt(nargs);
            bps2.bytecodes = bps.bytecodes;
            bps = bps2;
        }
        bps.env = env.vec;
        bps.nargs = nargs;
        name.fn = bps;
        if (savedef != Environment.nil)
            Fns.put(name, Jlisp.lit[Lit.savedef], savedef);
    }


    static LispObject faslRead() throws Exception
    {
        Jlisp.idump = reader;
        LispReader.preRestore();
        Jlisp.descendSymbols = false;
        LispObject r = LispReader.readObject();
        LispReader.postRestore();
        return r;
    }

}

// end of Fasl.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/0000755000175000017500000000000011722677351025415 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/LispStream.java0000644000175000017500000007430711555446662030361 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

import java.io.File;
import java.io.IOException;
import java.io.Reader;
import java.io.Writer;
import java.math.BigInteger;
import java.security.MessageDigest;
import java.text.SimpleDateFormat;
import java.util.Date;
import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.numbers.LispFloat;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.functions.builtin.Fns;

import org.mathpiper.mpreduce.Jlisp;
import org.mathpiper.mpreduce.Lit;
import org.mathpiper.mpreduce.symbols.Symbol;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispStream extends LispObject
{
    String name;

    public LispStream(String name)
    {
        this.name = name;
    }

// A jollity here is that a LispStream can be both for input and
// ouput. So I defined the fields & methods used for each here even though
// they only get activated in sub-classes.

    public int lineLength = 80;  // for linelength() and wrapping
    public int column;           // for posn(), lengthc()

// Making end-of-line behave in a properly platform-specific manner is
// something I had just expected to happen for me as part of the Unicode
// conversion fun, but it seems not to. So I do it by steam here. Ugh!

    public static String eol = System.getProperty("line.separator");

// Various classes derived from this generic LispStream will direct
// output to one or the other of the following destinations. I include
// all the options here to start with but will consider moving some down
// the class hierarchy later on when I have things more complete!

    public LispObject exploded;  // for explode() and friends
    public StringBuffer sb;      // for explodeToString()
    public MessageDigest md;     // for md5 checksumming
    public Writer wr;            // for ordinary printing!

    public void print(String s) throws ResourceException
    { // attempting to print to (eg) an input stream has no effect at all
    }

    public void println(String s) throws ResourceException
    {
    }

    public void println() throws ResourceException
    {
        print("\n");
    }

    public void flush()
    {
    }

    public void close()
    {
        if (reader != null)
        {   try
            {   reader.close();
            }
            catch (IOException e)
            {}
        }
    }

// Next I include data fields and methods associated with reading from
// this stream. The code here will be to read from a file, or at least
// something packaged up via a Reader. But a sub-class will be able to
// cause input to be taken from a list (for compress()).

    public boolean inputValid;
    public LispObject inputData;
    String stringData;
    public Reader reader = null;


// This will behave somewhat like the regular Java StreamTokenizer class
// except that the rules for processing will be as expected for
// my Lisp purposes. This will include making integers readable
// as big values not just longs, distinction between integer and floating
// point input, and acceptance of markers that flag the following character
// as "letter-like". So when I have read a token the variable ttype will get
// set to show what sort of thing is there and value will hold extended
// data.

    public static final int TT_EOF    = -1;
    public static final int TT_NUMBER = -2;
    public static final int TT_WORD   = -3;
    public static final int TT_STRING = -4;
    int ttype;

    public LispObject value; // symbol, number, whatever

    public int nextChar, prevChar = '\n';
    StringBuffer s = new StringBuffer();
    public boolean needsPrompt;
    public boolean escaped;

    public boolean allowOctal;

    static BigInteger [] digits = // to avoid repeated re-construction
    {   BigInteger.valueOf(0),
        BigInteger.valueOf(1),
        BigInteger.valueOf(2),
        BigInteger.valueOf(3),
        BigInteger.valueOf(4),
        BigInteger.valueOf(5),
        BigInteger.valueOf(6),
        BigInteger.valueOf(7),
        BigInteger.valueOf(8),
        BigInteger.valueOf(9),
        BigInteger.valueOf(10),
        BigInteger.valueOf(11),
        BigInteger.valueOf(12),
        BigInteger.valueOf(13),
        BigInteger.valueOf(14),
        BigInteger.valueOf(15),
        BigInteger.valueOf(16)
    };

// To get an input-capable stream I can either create it directly using
// this constructor, or I can add input capability to an existing
// (output) stream using setReader().

    public LispStream(String name, Reader reader, boolean np, boolean allowOctal)
    {
        this.name = name;
        setReader(name, reader, np, allowOctal);
    }

    public void setReader(String name, Reader reader, boolean np, boolean allowOctal)
    {
        this.name = name;
        this.reader = reader;
        this.needsPrompt = np;
        escaped = false;
        this.allowOctal = allowOctal;
        nextChar = -2;
    }

// Parsing of Lisp tokens uses a finite state machine. The next
// collection of values represent its states.

    static final int init   =  0;
    static final int zero   =  1;
    static final int binary =  2;
    static final int octal  =  3;
    static final int dec    =  4;
    static final int hex    =  5;
    static final int dot    =  6;
    static final int e      =  7;
    static final int e1     =  8;
    static final int e2     =  9;
    static final int e3     = 10;
    static final int esc    = 11;
    static final int sym    = 12;
    static final int signed = 13;

    void prompt() throws ResourceException
    {
        if (!needsPrompt) return;
// here I want to print to the standard output regardless of any stream
// selections anybody has tried to make!
        if (Fns.prompt != null) Jlisp.lispIO.print(Fns.prompt);
        Jlisp.lispIO.flush();
    }
    
    public int read() throws Exception
    {
        if (reader == null) return -1;
        int c;
        try
        {   c = reader.read();
            if (c == -1) return c;
        }
        catch (IOException e)
        {   return -1;
        }
        if (Jlisp.lit[Lit.starecho].car/*value*/ != Environment.nil)
        {   LispStream o = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
            o.print(String.valueOf((char)c));
        }
        return c;
    }

    public void getNext() throws Exception
    {
        if (prevChar == '\n') prompt();
        int c = read();
        if (c >= 0 && !escaped)
        {   if (((Symbol)Jlisp.lit[Lit.lower]).car/*value*/ !=
                Environment.nil) c = (int)Character.toLowerCase((char)c);
            else if (((Symbol)Jlisp.lit[Lit.raise]).car/*value*/ !=
                Environment.nil) c = (int)Character.toUpperCase((char)c);
        }
        prevChar = nextChar = c;
    }
    
    public int readChar() throws Exception // gets one character
    {
        if (nextChar == -2) getNext();
        int c = nextChar;
        if (c == 26) c = -1;  // map ^Z onto EOF
        if (nextChar != -1) nextChar = -2;
        return c;
    }
    
    public int nextToken() throws Exception
    {
        int i;
        for (;;)
        {   if (nextChar == -2) getNext();
            if (nextChar == -1 || nextChar == 26) 
            {   nextChar = -1;
                return TT_EOF;
            }
            if (Character.isWhitespace((char)nextChar))
            {   nextChar = -2;
                continue;
            }
            if (nextChar == '%')
            {   while (nextChar != '\n' &&
                       nextChar != '\r' &&
                       //nextChar != '\p' &&
                       nextChar != -1)
                {   getNext();
                }
                if (nextChar == -1 || nextChar == 26)
                {   nextChar = -1;
                    return TT_EOF;
                }
                continue;
            }
            else if (nextChar == '\"')
            {   s.setLength(0);
                for (;;)
                {   if (prevChar == '\n') prompt(); // no case fold
                    prevChar = nextChar = read();
                    if (nextChar == -1 || nextChar == 26) break;
                    if (nextChar == '\"')
                    {   prevChar = nextChar = read(); // no possibly prompt here
                        if (nextChar != '\"') break;
                    }
                    s.append((char)nextChar);
                }
                value = new LispString(s.toString());
                return TT_WORD;
            }
            else if (Character.isLetterOrDigit((char)nextChar) ||
                     nextChar == '_' ||
                     nextChar == '+' || nextChar == '-' || // for numbers
// It seems that maybe at this level Reduce wants almost any character to
// be allowed to start a symbol. And specifically the mathmlom package depends
// on some of these via its use of compress.
                     nextChar == '&' || nextChar == '$' || nextChar == '*' ||
                     nextChar == '/' || nextChar == '^' || nextChar == '?' ||
                     nextChar == '<' || nextChar == '>' || nextChar == ':' ||
                     nextChar == ';' || nextChar == '#' || nextChar == '\\' ||
                     nextChar == '!')
            {
// Numbers are in one of the following forms:
//       0dddddddddd                octal (digits 0 to 7)
//       0Bddddddddd                binary (digits 0 or 1)
//       0Xddddddddd                hex   (digits 0 to f)
//       [+/-]ddddddddddd           decimal
//       [+/-]dddd.[ddd][E[+|-]ddd] floating point with "."
//       [+/-]ddddE[+|-]ddd         floating point with "E"
// and if a sequence of characters starts off as a number if it
// breaks with one of the above forms before a "." then I just
// keep reading ahead and accept a symbol. If I have seen a "."
// or E followed by + or - (but not just E on its own) and the format
// deviates from that of a floating point number then I stop reading
// at the character that was odd. This 0xen is a symbol despite 0xe
// making it start looking like a hex value. Similarly 100e99L will
// be a symbol because the L can not form part of a float. But the
// very similar-seeming 1.00E99L will be treated as two tokens, ie
// 1.00E99 followed by L. And equally 1e-7x is two tokens, one for
// the floating point value 1.0e-7 and a second for the "x". Escaped
// characters (following "!") can never be parts of numbers and so
// fit somewhere in the above discussion. Eg 0x12!34 is a symbol and 
// 1.23!e4 is a float (1.23) followed by a symbol (!e4).
// 
// I parse using a finite state machine so that at the end of a
// token I can tell it I have a number or a symbol (and what sort
// of number too). The code here may indicate that I would quite
// like to have GOTO statements in my language for implementing
// some styles of code! Equally one feels that this mess might better
// be implemented using transition tables. But if I did that I would
// need more refined classification of every character read.
                s.setLength(0);
                int state = init;
                for (;;getNext())
                {   switch (state)
                    {
                case init:
                        if (nextChar == '!')
                        {   state = esc;  // NB do not buffer the "!"
                            escaped = true;
                            continue;
                        }
                        else if (nextChar == '0' && allowOctal)
                        {   state = zero;
                            s.append('0');
                            continue;
                        }
                        else if (Character.digit((char)nextChar, 10) >= 0)
                        {   state = dec;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '+' || nextChar == '-')
                        {   state = signed;
                            s.append((char)nextChar);
                            continue;
                        }
                        else
// In the init state I know that the character is alphanumeric.
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                case signed:
                        if (Character.digit((char)nextChar, 10) >= 0)
                        {   state = dec;
                            s.append((char)nextChar);
                            continue;
                        }
                        else
                        {   value = Symbol.intern(s.toString());
                            return TT_WORD;
                        }
                case zero:
                        if (nextChar == 'B' || nextChar == 'b')
                        {   state = binary;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == 'X' || nextChar == 'x')
                        {   state = hex;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.digit((char)nextChar, 8) >= 0)
                        {   state = octal;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '.')
                        {   state = dot;
                            s.append('.');
                            continue;
                        }
                        else if (nextChar == 'e' || nextChar == 'E')
                        {   state = e2;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case binary:
                        if (Character.digit((char)nextChar, 2) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case octal:
                        if (Character.digit((char)nextChar, 8) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case hex:
                        if (Character.digit((char)nextChar, 16) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case dec:
                        if (Character.digit((char)nextChar, 10) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '.')
                        {   state = dot;
                            s.append('.');
                            continue;
                        }
                        else if (nextChar == 'e' || nextChar == 'E')
                        {   state = e2;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case dot:
                        if (nextChar == 'e' || nextChar == 'E')
                        {   state = e;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.digit((char)nextChar, 10) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else break;
                case e:
                        if (Character.digit((char)nextChar, 10) >= 0 ||
                            nextChar == '+' || nextChar == '-')
                        {   state = e1;
                            s.append((char)nextChar);
                            continue;
                        }
                        else break;
                case e1:
                        if (Character.digit((char)nextChar, 10) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else break;
                case e2:
                        if (Character.digit((char)nextChar, 10) >= 0)
                        {   state = e3;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '+' || nextChar == '-')
                        {   state = e1;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case e3:
                        if (Character.digit((char)nextChar, 10) >= 0)
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (Character.isLetterOrDigit((char)nextChar) ||
                                 nextChar == '_')
                        {   state = sym;
                            s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                case esc:
                        state = sym;
                        escaped = false;
                        s.append((char)nextChar);
                        continue;
                case sym:
                        if (Character.isLetterOrDigit((char)nextChar) ||
                            nextChar == '_')
                        {   s.append((char)nextChar);
                            continue;
                        }
                        else if (nextChar == '!')
                        {   state = esc;
                            escaped = true;
                            continue;
                        }
                        else break;
                default:
                        break; // should never happen!
                    }
                    break;
                }
                BigInteger r;
                switch (state)
                {
            case dec:
                    r = new BigInteger(s.toString());
                    value = LispInteger.valueOf(r);
                    break;
            case binary:
// If I really expected LOTS of people to read in large binary, octal
// or hex numbers I ought to read around 32-bits at a time using int or
// long arithmetic and only fall back to bignumber work after that. However
// I do NOT expect these to be read in very often so I will not bother!
                    BigInteger two = digits[2];
                    r = BigInteger.valueOf(0);
                    for (i=2; i";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() > currentOutput.lineLength)
            currentOutput.println();
        currentOutput.print(s);
    }

    public void blankprint() throws ResourceException
    {
        String s = "#Stream<" + name + ">";
        if ((currentFlags & noLineBreak) == 0 &&
            currentOutput.column + s.length() >= currentOutput.lineLength)
            currentOutput.println();
        else currentOutput.print(" ");
        currentOutput.print(s);
    }

    public LispObject eval()
    {
        return this;
    }

// I put various things related to file manipulation here as a convenient
// sort of place for them to go.


// nameConvert is here to perform any adjustments on file-names that may
// be called for. The first thing that I do is to take any initial
// prefix of the form $xxx/... and expand out the $xxx as the value
// of a lisp variable called $xxx. If the variable concerned does not have
// as string as its value I put in "." as the expansion, and hope that that
// refers to the current directory.
    public static String nameConvert(String a)
    {
        if (a.charAt(0) != '$') return a;
        int n = a.indexOf('/');
        if (n < 0) n = a.indexOf('\\');
        String prefix, tail;
        if (n < 0) 
        {   prefix = a.substring(1);
            tail = "";
        }
        else 
        {   prefix = a.substring(1, n);
            tail = a.substring(n);
        }
        LispObject x = Symbol.intern("$" + prefix).car/*value*/;
        if (x instanceof LispString) prefix = ((LispString)x).string;
        else if ((x = Symbol.intern("@" + prefix).car/*value*/) 
                instanceof LispString) prefix = ((LispString)x).string;
        else prefix = ".";
        return prefix + tail;
    }

    public static SimpleDateFormat dFormat =
        new SimpleDateFormat("yyyy.MM.dd:HH.mm.ss:SSS");

    public static LispObject fileDate(String s)
    {
        try
        {   File f = new File(nameConvert(s));
            long n = f.lastModified();
            if (n == 0) return Environment.nil;
            s = dFormat.format(new Date(n));
            return new LispString(s);
        }
        catch (Exception e)
        {   return Environment.nil;
        }
    }
    
    public static LispObject fileDelete(String s)
    {
        try
        {   File f = new File(nameConvert(s));
            f.delete();
            return Jlisp.lispTrue;
        }
        catch (Exception e)
        {   return Environment.nil;
        }
    }
    
    public static LispObject fileRename(String s, String s1)
    {
        try
        {   File f = new File(nameConvert(s));
            File f1 = new File(nameConvert(s1));
            f.renameTo(f1);
            return Jlisp.lispTrue;
        }
        catch (Exception e)
        {   return Environment.nil;
        }
    }
    
    public void scan()
    {
        if (LispReader.objects.contains(this)) // seen before?
	{   if (!LispReader.repeatedObjects.containsKey(this))
	    {   LispReader.repeatedObjects.put(
	            this,
	            Environment.nil); // value is junk at this stage
	    }
	}
	else LispReader.objects.add(this);
    }
    
    public void dump() throws Exception
    {
        Object w = LispReader.repeatedObjects.get(this);
	if (w != null &&
	    w instanceof Integer) putSharedRef(w); // processed before
	else
	{   if (w != null) // will be used again sometime
	    {   LispReader.repeatedObjects.put(
	            this,
		    new Integer(LispReader.sharedIndex++));
		Jlisp.odump.write(X_STORE);
            }
	    Jlisp.odump.write(X_STREAM); // not re-loadable!
	}
    }

}

// end of LispStream.java
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/LispOutputStream.java0000644000175000017500000001335411546225657031574 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import java.io.BufferedWriter;
import java.io.File;
import java.io.FileWriter;
import java.io.IOException;
import org.mathpiper.mpreduce.Jlisp;

public class LispOutputStream extends LispStream
{

    boolean closeMe;

    public LispOutputStream(String n) throws IOException // to a named file
    {
        super(n);
        wr = new BufferedWriter(new FileWriter(nameConvert(n)));
        closeMe = true;
        Jlisp.openOutputFiles.add(this);
    }

    public LispOutputStream(File n) throws IOException // to a named file
    {
        super(n.getName());
        wr = new BufferedWriter(new FileWriter(n));
        closeMe = true;
        Jlisp.openOutputFiles.add(this);
    }

    public LispOutputStream(String n, boolean appendp) throws IOException
    // to a file, but with an "append" option
    {
        super(n);
        wr = new BufferedWriter(new FileWriter(nameConvert(n), appendp));
        closeMe = true;
        Jlisp.openOutputFiles.add(this);
    }

    public LispOutputStream() // uses standard input, no extra buffering.
                       // but note that I have made it a Writer already...
    {
        super("");
        wr = Jlisp.out;
        closeMe = false;
        Jlisp.openOutputFiles.add(this);
    }

    public void flush()
    {
        try
        {   wr.flush();
        }
        catch (IOException e)
        {}
    }

    public void close()
    {
        Jlisp.openOutputFiles.removeElement(this);
        try
        {   wr.flush();
            if (closeMe) wr.close();
        }
        catch (IOException e)
        {}
    }

    public void print(String s)
    {
        if (s == null) s = "null";
        char [] v = s.toCharArray();
// It *MAY* be better to use getChars here and move data into a pre-allocated
// array of characters.
        try
        {   int p = 0;
            for (int i=0; i");
        wr = Jlisp.out;
        this.log = log;
        closeMe = false;
        Jlisp.openOutputFiles.add(this);
    }

    public void flush()
    {
        try
        {   wr.flush();
            log.flush();
        }
        catch (IOException e)
        {}
    }

    public void close()
    {
        Jlisp.openOutputFiles.removeElement(this);
        try
        {   wr.flush();
            log.flush();
            if (closeMe) wr.close();
            log.close();
        }
        catch (IOException e)
        {}
    }

    public void print(String s)
    {
        if (s == null) s = "null";
        char [] v = s.toCharArray();
// It *MAY* be better to use getChars here and move data into a pre-allocated
// array of characters.
        try
        {   int p = 0;
            for (int i=0; i");
        try
        {   md = MessageDigest.getInstance("MD5", "SUN");
        }
        catch (NoSuchAlgorithmException e)
        {
            Jlisp.errprintln("No MD5 available: " + e.getMessage());
            md = null;
        }
        catch (NoSuchProviderException e)
        {
            Jlisp.errprintln("No provider: " + e.getMessage());
            md = null;
        }
    }

    public void flush()
    {
    }

    public void close()
    {
        md = null;
    }

    public void print(String s)
    {
        if (md == null) return;
        char [] v = s.toCharArray();
// It *MAY* be better to use getChars here and move data into a pre-allocated
// array of characters.
        for (int i=0; i> 8));
            md.update((byte)c);
        }
    }

    public void println(String s)
    {
        print(s);
        if (md != null)
        {   md.update((byte)0);
            md.update((byte)'\n');
        }
    }

}

// end of LispDigester.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/LispExploder.java0000644000175000017500000000744011555446662030702 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.symbols.Symbol;
import org.mathpiper.mpreduce.LispObject;
import org.mathpiper.mpreduce.LispReader;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class LispExploder extends LispStream
{

    boolean asSymbols;

    public LispExploder(boolean n) // builds a list of all characters
                            // n true for symbols, false for numeric codes
    {
        super("");
        asSymbols = n;
        exploded = Environment.nil;
    }

    public void flush()
    {
    }

    public void close()
    {
        exploded = Environment.nil;
    }

    public void print(String s) throws ResourceException
    {
        char [] v = s.toCharArray();
        for (int i=0; i");
        stringData = data;
        pos = 0;
        needsPrompt = false;
        escaped = false;
        this.allowOctal = allowOctal;
        nextChar = -2;
    }

    public int read()
    {
        if (pos >= stringData.length()) return -1;
        else return (int)stringData.charAt(pos++);
    }

    public void close()
    {
        stringData = null;
    }

}

// end of LispStringReader.java
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/ListReader.java0000644000175000017500000000655211555446662030331 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

import org.mathpiper.mpreduce.Environment;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.LispObject;

import org.mathpiper.mpreduce.symbols.Symbol;

public class ListReader extends LispStream
{

    public ListReader(LispObject data)
    {
        super("");
        inputData = data;
        needsPrompt = false;
        escaped = false;
        this.allowOctal = allowOctal;
        nextChar = -2;
    }

    public int read() throws Exception
    {
        if (inputData.atom) return -1;
        LispObject w = inputData.car;
        inputData = inputData.cdr;
        if (w instanceof LispString)
            return (int)((LispString)w).string.charAt(0);
        else if (w instanceof Symbol)
            return (int)((Symbol)w).pname.charAt(0);
        else if (w instanceof LispInteger)
            return w.intValue();
        else return -1;
    }

    public void close()
    {
        inputData = Environment.nil;
    }

}

// end of ListReader.java
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/LispCounter.java0000644000175000017500000000533211546225657030534 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



public class LispCounter extends LispStream
{

    public LispCounter()
    {
        super("");
        column = 0;
    }

    public void flush()
    {
    }

    public void close()
    {
    }

    public void print(String s)
    {
        column += s.length();
    }

    public void println(String s)
    {
        column += s.length() + 1;
    }

}

// end of LispCounter.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/LispOutputString.java0000644000175000017500000000552311546225657031606 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/



public class LispOutputString extends LispStream
{

    public LispOutputString()
    {
        super("");
        sb = new StringBuffer();
    }

    public void flush()
    {
    }

    public void close()
    {
        sb = null;
    }

    public void print(String s)
    {
        sb.append(s);
    }

    public void println(String s)
    {
        sb.append(s);
        sb.append("\n");
    }


    public String toString()
    {
        return sb.toString();
    }

}

// end of LispOutputString.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/io/streams/WriterToLisp.java0000644000175000017500000000564411546225657030702 0ustar  giovannigiovannipackage org.mathpiper.mpreduce.io.streams;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2000.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import java.io.Writer;
import org.mathpiper.mpreduce.exceptions.ResourceException;

public class WriterToLisp extends Writer
{
    LispStream stream;

    public WriterToLisp(LispStream s)
    {
        stream = s;
    }

    public void close()
    {
        stream.close();
    }

    public void flush()
    {
        stream.flush();
    }

    public void write(char [] buffer, int off, int len)
    {
         try
         {   stream.print(new String(buffer, off, len));
         }
         catch (ResourceException e)
         {} // This LOSES the exception....
    }

}

// end of WriterToLisp.java


mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/LispObject.java0000644000175000017500000006122111555446662026236 0ustar  giovannigiovannipackage org.mathpiper.mpreduce;

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


// Lisp has a single inclusive data-type, which I call
// LispObject here. It has sub-types that are symbols,
// numbers, strings and lists. Here I give just a few
// methods (eg print and eval) that may be used on anything.


import java.math.BigInteger;
import org.mathpiper.mpreduce.exceptions.ResourceException;
import org.mathpiper.mpreduce.io.streams.LispOutputString;
import org.mathpiper.mpreduce.numbers.LispBigInteger;
import org.mathpiper.mpreduce.numbers.LispSmallInteger;
import org.mathpiper.mpreduce.io.streams.LispStream;

public abstract class LispObject extends Object
{
    public boolean atom;   // true if it is atomic
    public LispObject car; // car and cdr fields to reduce number of expensive casts!
    public LispObject cdr;

    public LispObject()
    {
        car = cdr = null;
        atom = true;
    }

// The following constructor is ONLY intended for use via a call
//       super(car, cdr);
// in the constructor for the "Cons" sub-class.

    public LispObject(LispObject car, LispObject cdr)
    {
        atom = false;
        this.car = car; 
        this.cdr = cdr;
    }

    public static final int printEscape      = 1; // flags to pass to print(n)
    public static final int printBinary      = 2;
    // (decimal is the default)       = 4
    public static final int printOctal       = 8;
    public static final int printHex         = 16;
    public static final int printLower       = 32;
    public static final int printUpper       = 64;
    public static final int noLineBreak      = 128;

    public void print() throws ResourceException
    {
        currentOutput = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
        currentFlags = 0;
        iprint();
    }

    public void print(int flags) throws ResourceException
    {
        currentOutput = (LispStream)Jlisp.lit[Lit.std_output].car/*value*/;
        currentFlags = flags;
        iprint();
    }

// real printing will usually be done by iprint where the current output
// stream and format flags can be accessed via static variables.

    public static LispStream currentOutput;
    public static int currentFlags;

    abstract public void iprint() throws ResourceException;
    abstract public void blankprint() throws ResourceException; // print but with whitespace before it

    public void errPrint() throws ResourceException // print to error output stream
    {
        currentOutput = (LispStream)Jlisp.lit[Lit.err_output].car/*value*/;
        currentFlags = printEscape;
        iprint();
    }

    public void tracePrint() throws ResourceException // print to trace output stream
    {
        currentOutput = (LispStream)Jlisp.lit[Lit.tr_output].car/*value*/;
        currentFlags = printEscape;
        iprint();
    }

// Codes for use in my (custom) serialisation format.

// I make special provision for references to 64 things. I will use
// this for the first 48 things used at all and the 16 most recent ones.

    public static final int X_REFn     = 0x00;

    public static final int X_BREAK1   = 0x40;

// The next bunch are optimisations for common cases when the
// length code is short. The length code is folded into the main byte. Thus
// (eg) symbols whose name is from 0 to 15 characters long are dealt with
// especially neatly.

    public static final int X_SYMn     = 0x40; // symbol with 0 to 15 chars
    public static final int X_UNDEFn   = 0x50; // symbol (0-15), not a function
    public static final int X_GENSYMn  = 0x60; // gensym with 0 to 15 bytes
    public static final int X_LIST     = 0x70; // list with 0 to 15 items: (LIST) = NIL
    public static final int X_LISTX    = 0x80; // like (LIST* ..) with 1-16 items then tail
    public static final int X_INTn     = 0x90; // integer with 0 to 15 bytes
    public static final int X_STRn     = 0xa0; // string, 0 to 15 chars

    public static final int X_BREAK2   = 0xb0;

    public static final int X_REF      = 0xb0; // refer to a previously mentioned item
    public static final int X_REFBACK  = 0xb4; // (only 1 and 2 byte versions used)
    public static final int X_INT      = 0xb8; // LispBigInteger represented by an array
    public static final int X_STR      = 0xbc; // Strings
    public static final int X_SYM      = 0xc0; // Symbol with given name
    public static final int X_UNDEF    = 0xc4; // Symbol (not a function)
    public static final int X_UNDEF1   = 0xc8; // disembodied undefined function
    public static final int X_GENSYM   = 0xcc; // a gensym or other uninterned name
    public static final int X_BPS      = 0xd0; // "binary code" ha ha ha.
    public static final int X_VEC      = 0xd4; // a Lisp vector
// perhaps X_INT with a short-enough operand could be used for X_FIXNUM
// as a rationalisation here.
    public static final int X_FIXNUM   = 0xd8; // 1, 2, 3 or 4-byte small integer

//  0xdc spare at present

    public static final int X_BREAK3   = 0xe0;

// The final collection of codes are all one-byte incidental ones and
// the amount of any associated data is implicit in them. Eg X_DOUBLE will
// be followed by 8 bytes that represent a double-precision floating point
// value. X_FNAME is followed by a single length byte (n) then n characters.

    public static final int X_NULL     = 0xe0; // empty cell (ie Java null)
    public static final int X_DOUBLE   = 0xe1; // double-precision number
    public static final int X_STREAM   = 0xe2; // an open file (not dumpable)
    public static final int X_FNAME    = 0xe3; // built-in function
    public static final int X_SPECFN   = 0xe4; // built-in special form
    public static final int X_STORE    = 0xe5; // the next item will be re-used
    public static final int X_HASH     = 0xe6; // EQ hash
    public static final int X_HASH1    = 0xe7; // EQL hash (not used)
    public static final int X_HASH2    = 0xe8; // EQUAL hash
    public static final int X_HASH3    = 0xe9; // EQUALS hash (not used)
    public static final int X_HASH4    = 0xea; // EQUALP hash (not used)
    public static final int X_ENDHASH  = 0xeb; // end of data for hash table
    public static final int X_AUTOLOAD = 0xec; // autoloading fn def
    public static final int X_SPID     = 0xed; // internal marker
    public static final int X_DEFINMOD = 0xee; // "define-in-module" in fasl files
    public static final int X_INTERP   = 0xef; // interpreted code
    public static final int X_MACRO    = 0xf0; // interpreted macro
    public static final int X_CALLAS   = 0xf1; // simple tail-call object
    public static final int X_RECENT   = 0xf2; // used in FASL but not checkpoints
    public static final int X_RECENT1  = 0xf3; // used in FASL but not checkpoints
    public static final int X_OBLIST   = 0xf4; // oblist vector

// 0xf2 to 0xff spare at present...

    abstract public void scan();
    public abstract void dump() throws Exception;

// dealing with references to shared structure has the most complicated
// treatment here because it appears to be an especially heavily used
// case and one where special cases may make some real difference.

    public void putSharedRef(Object w) throws Exception
    {
        int n = ((Integer)w).intValue();
        if (n < 48)
        {   Jlisp.odump.write(X_REFn + n);
            return;
        }
	int n1 = LispReader.sharedIndex - n;
        if (n1 < 17)  // range 1 to 16 is possible here (0 can not arise)
        {   Jlisp.odump.write(X_REFn + n1 - 1 + 48);
            return;
        }
	if (n >= 0x100 && n1 < 0x100 ||
	    n >= 0x10000 && n1 < 0x10000) putPrefix(n1, X_REFBACK);
        else putPrefix(n, X_REF);
    }

    public void putPrefix2(int n, int code1, int code2) throws Exception
    {
        if (n < 16)
	{   Jlisp.odump.write(code1+n);
	}
	else putPrefix(n, code2);
    }

    public void putPrefix(int n, int code) throws Exception
    {
	if ((n & 0xffffff00) == 0)
	{   Jlisp.odump.write(code);
            Jlisp.odump.write(n);
        }
        else if ((n & 0xffff0000) == 0)
        {   Jlisp.odump.write(code+1);
            Jlisp.odump.write(n >> 8);
            Jlisp.odump.write(n);
        }
	else if ((n & 0xff000000) == 0)
	{   Jlisp.odump.write(code+2);
	    Jlisp.odump.write(n >> 16);
	    Jlisp.odump.write(n >> 8);
	    Jlisp.odump.write(n);
	}
        else
        {   Jlisp.odump.write(code+3);
            Jlisp.odump.write(n >> 24);
            Jlisp.odump.write(n >> 16);
            Jlisp.odump.write(n >> 8);
            Jlisp.odump.write(n);
        }
    }

    public boolean lispequals(Object a)
    {
        return this.equals(a);
    }

    public LispObject eval() throws Exception
    {
        return this;
    }

    public LispObject copy()
    {
        return this;
    }

    public int lisphashCode()
    {
        return this.hashCode();
    }

    public double doubleValue() throws Exception
    {
        Jlisp.error("Number needed", this);
        return 0.0;  // never reached!
    }

    public int intValue() throws Exception
    {
        Jlisp.error("Number needed", this);
        return 0;    // never reached!
    }

    public BigInteger bigIntValue() throws Exception
    {
        Jlisp.error("Number needed", this);
        return null;    // never reached!
    }

    public LispObject negate() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject ash(int n) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject ash1(int n) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject rightshift(int n) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject add1() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject sub1() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject floor() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject ceiling() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject round() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject truncate() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject evenp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject oddp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject fix() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject fixp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject integerp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject jfloat() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject floatp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject minusp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject plusp() throws Exception
    {
        return Environment.nil;
    }

    public LispObject zerop() throws Exception
    {
        return Environment.nil;
    }

    public LispObject onep() throws Exception
    {
        return Environment.nil;
    }

    public LispObject abs() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject msd() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject lsd() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject not() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modMinus() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modRecip() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject safeModRecip() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject reduceMod() throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject add(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject subtract(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject multiply(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject divide(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject remainder(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject quotientAndRemainder(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject mod(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject expt(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject max(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject min(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject and(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject or(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject xor(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject gcd(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject lcm(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modAdd(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modSubtract(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modMultiply(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modDivide(LispObject a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modExpt(int n) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public boolean eqn(LispObject a) throws Exception
    {
        return (this == a);
    }

    public boolean neqn(LispObject a) throws Exception
    {
        return (this != a);
    }

    public boolean ge(LispObject a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean geq(LispObject a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean le(LispObject a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean leq(LispObject a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }


    public LispObject addInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject subtractInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject multiplyInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject divideInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject remainderInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject quotientAndRemainderInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject exptInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject maxInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject minInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject andInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject orInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject xorInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject gcdInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject lcmInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modAddInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modSubtractInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modMultiplyInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modDivideInteger(LispBigInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public boolean eqnInteger(LispBigInteger a) throws Exception
    {
        return false;
    }

    public boolean neqnInteger(LispBigInteger a) throws Exception
    {
        return true;
    }

    public boolean geInteger(LispBigInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean geqInteger(LispBigInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean leInteger(LispBigInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean leqInteger(LispBigInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public LispObject addSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject subtractSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject multiplySmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject divideSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject remainderSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject quotientAndRemainderSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject exptSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject maxSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject minSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject andSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject orSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject xorSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject gcdSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject lcmSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modAddSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modSubtractSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modMultiplySmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public LispObject modDivideSmallInteger(LispSmallInteger a) throws Exception
    {
        return Jlisp.error("Number needed", this);
    }

    public boolean eqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return false;
    }

    public boolean neqnSmallInteger(LispSmallInteger a) throws Exception
    {
        return true;
    }

    public boolean geSmallInteger(LispSmallInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean geqSmallInteger(LispSmallInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean leSmallInteger(LispSmallInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }

    public boolean leqSmallInteger(LispSmallInteger a) throws Exception
    {
        Jlisp.error("Number needed", this);
        return false;
    }


    public String toString()
    {
         LispStream originalOutput = this.currentOutput;

         LispStream stringStream = new LispOutputString();

         this.currentOutput = stringStream;

         try
         {
         //Print object information into a string.
         iprint();
        }
         catch(ResourceException e)
         {
             
         }

         this.currentOutput = originalOutput;

         return stringStream.toString();

    }//end method.

}

// End of LispObject.java

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/LispReader.java0000644000175000017500000007665711555446662026255 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */

package org.mathpiper.mpreduce;

import java.io.IOException;
import java.io.InputStream;
import java.io.OutputStream;
import java.math.BigInteger;
import java.util.EmptyStackException;
import java.util.HashMap;
import java.util.HashSet;
import java.util.Stack;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.datatypes.LispEqualHash;
import org.mathpiper.mpreduce.datatypes.LispHash;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.datatypes.LispVector;
import org.mathpiper.mpreduce.exceptions.EOFException;
import org.mathpiper.mpreduce.exceptions.ResourceException;
import org.mathpiper.mpreduce.functions.builtin.Fns;
import org.mathpiper.mpreduce.functions.functionwithenvironment.ByteOpt;
import org.mathpiper.mpreduce.functions.functionwithenvironment.Bytecode;
import org.mathpiper.mpreduce.functions.functionwithenvironment.FnWithEnv;
import org.mathpiper.mpreduce.functions.lisp.AutoLoad;
import org.mathpiper.mpreduce.functions.lisp.CallAs;
import org.mathpiper.mpreduce.functions.lisp.Interpreted;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;
import org.mathpiper.mpreduce.functions.lisp.Macro;
import org.mathpiper.mpreduce.functions.lisp.Undefined;
import org.mathpiper.mpreduce.io.Fasl;
import org.mathpiper.mpreduce.io.streams.LispStream;
import org.mathpiper.mpreduce.numbers.LispFloat;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.numbers.LispNumber;
import org.mathpiper.mpreduce.special.SpecialFunction;
import org.mathpiper.mpreduce.symbols.Gensym;
import org.mathpiper.mpreduce.symbols.Symbol;


public class LispReader {
    
    	static int istacklimit;
	static int [] istack;
	public static int sharedIndex;
	public static Stack stack;
	static int sharedSize;
	static LispObject [] shared;

        // I choose my initial oblist size so that REDUCE can run without need
	// for re-hashing at all often. The size must also be a prime, and 15013
	// seems to fit the bill.
	public static int oblistSize = 15013;
	public static int oblistCount = 0;
	public static Symbol [] oblist = new Symbol[oblistSize];
        public static LispVector obvector = new LispVector((LispObject [])oblist);

	public static Symbol [] chars  = new Symbol[128];  // to speed up READCH
	public static LispObject [] spine = new LispObject[17]; // for PRESERVE


	static int inputType;



	public static HashSet objects;
	public static HashMap repeatedObjects;
        
    	static final int S_VECTOR     =  0;      // + number of items to come

	static final int S_START      = -1;
	static final int S_CDR        = -2;
	static final int S_HASHKEY    = -3;
	static final int S_HASHVAL    = -4;
	static final int S_SYMVAL     = -5;
	static final int S_SYMPLIST   = -6;
	static final int S_SYMFN      = -7;
	static final int S_SYMSPECIAL = -8;
	static final int S_AUTONAME   = -9;
	static final int S_AUTODATA   = -10;
	static final int S_INTERP_BODY= -11;
	static final int S_MACRO_BODY = -12;
	static final int S_CALLAS_BODY= -13;

	static final int S_CADR       = -100;  // +0 to +15 offsets from this used

	public static LispObject readObject() throws IOException, ResourceException
	{
		// Reloading an image uses an explicit stack to manage the recusion that
		// it needs. It controls this stack using a finite-state control. The states
		// are identified here as constants S_xxx.

		int state = S_START;
		int sp = 0;

		LispObject w = null;
		boolean setLabel = false;
		int i;

		for (;;)
			{   if (sp >= istacklimit-2)  // grow integer stack if needbe.
			{   int [] newistack = new int[2*istacklimit];
				for (i=0; i= 48) operand = sharedIndex - (operand + 1 - 48);
			case LispObject.X_REF:       // refer to an item that has already been read
				w = shared[operand];
				break;
			case LispObject.X_REFBACK:
				w = shared[sharedIndex - operand];
				break;
			case LispObject.X_RECENT:
				Fasl.recentn++;
				w = Fasl.recent[Jlisp.idump.read()];
				if (setLabel)
				{   shared[sharedIndex++] = w;
					setLabel = false;
				}
				break;
			case LispObject.X_RECENT1:
				Fasl.recentn++;
				w = Fasl.recent[Jlisp.idump.read()+256];
				if (setLabel)
				{   shared[sharedIndex++] = w;
					setLabel = false;
				}
				break;
			case LispObject.X_OBLIST:
				w = obvector;
				break;
			case LispObject.X_INT:       // a LispInteger
			case LispObject.X_INTn:
				{   byte [] data = new byte[operand];
					for (i=0; i>> 1);
					else if (operand == 1) operand = 0x80000000;
					else operand = -(operand >>> 1);
				w = LispInteger.valueOf(operand);
				break;
			case LispObject.X_STR:
				case LispObject.X_STRn:
						{   byte [] data = new byte[operand];
						    for (i=0; i 0xff) ws = new ByteOpt(nargs);
					else
					{   ws = new Bytecode();
						ws.nargs = nargs;
					}
					ws.bytecodes = data;
					// the X_BPS format is curious in that it should ALWAYS be followed
					// by an X_VEC. So I look for that here. I think I should also note that
					// I have a fragment of design here that is not fully worked through.
					// My Bytecoded is a sub-class of FnWithEnv - a general class for functions
					// that want a vector of LispObjects kept with them. But at present
					// Bytecode is the only sub-class that exists and the only one that this
					// rea-loading code can ever re-create.  So I expect to have to do more
					// work when or if I add more, for instance for code that has been reduced
					// to real Jaba bytecodes rather than my Jlisp-specific ones.
					opcode = Jlisp.idump.read();
					if (opcode < LispObject.X_VEC || opcode > LispObject.X_VEC+3)
						throw new IOException("Corrupted image file");
					switch (opcode & 3)
					{
					case 0: operand = Jlisp.idump.read();
						break;
					case 1: operand = Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						break;
					case 2: operand = Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						break;
					case 3: operand = Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						operand = (operand << 8) | Jlisp.idump.read();
						break;
					}
					ws.env = new LispObject [operand];
					if (operand == 0)
					{   w = ws;
						break;
					}
					stack.push(ws);
					istack[sp++] = state;
					state = S_VECTOR + operand;
					continue;
				}
			case LispObject.X_LIST:
				w = Environment.nil;
				if (operand == 0) break;
				for (i=0; i S_VECTOR)
					{   if (y instanceof LispVector)
						((LispVector)y).vec[--state - S_VECTOR] = w;
					else if (y instanceof FnWithEnv)
						((FnWithEnv)y).env[--state - S_VECTOR] = w;
					else throw new IOException("Corrupt image file");
					if (state == S_VECTOR) // now completed?
						{   if (y instanceof LispVector)
						{   stack.pop();
							w = y;
							state = istack[--sp];
							continue;
						}
						else if (y instanceof FnWithEnv)
						{   stack.pop();
							w = y;
							state = istack[--sp];
							continue;
						}
					}
					else break;
				}
				else switch (state)
					{
					case S_START:
						return w;
					case S_CADR+16:
						y = y.cdr;
					case S_CADR+15:
						y = y.cdr;
					case S_CADR+14:
						y = y.cdr;
					case S_CADR+13:
						y = y.cdr;
					case S_CADR+12:
						y = y.cdr;
					case S_CADR+11:
						y = y.cdr;
					case S_CADR+10:
						y = y.cdr;
					case S_CADR+9:
						y = y.cdr;
					case S_CADR+8:
						y = y.cdr;
					case S_CADR+7:
						y = y.cdr;
					case S_CADR+6:
						y = y.cdr;
					case S_CADR+5:
						y = y.cdr;
					case S_CADR+4:
						y = y.cdr;
					case S_CADR+3:
						y = y.cdr;
					case S_CADR+2:
						y = y.cdr;
						y.car = w;
						state--;
						break;
					case S_CADR+1:
						y.car = w;
						w = (LispObject)stack.pop();
						state = istack[--sp];
						continue;
					case S_CDR:
						{   Cons wc = (Cons)stack.pop();
							wc.cdr = w;
							state = istack[--sp];  // will be S_CADR+nn
						}
						break;
					case S_HASHKEY:
						if (w == null)  // hash table now complete
						{   w = (LispObject)stack.pop();
							state = istack[--sp];
							continue;
						}
						stack.push(w);
						state = S_HASHVAL;
						break;
					case S_HASHVAL:
						{   LispObject k = (LispObject)stack.pop();
							LispHash h = (LispHash)stack.peek();
							h.hash.put(k, w);
						}
						state = S_HASHKEY;
						break;
					case S_SYMFN:
						{   Symbol ws = (Symbol)stack.peek();
							ws.fn = (LispFunction)w;
							state = S_SYMSPECIAL;
							break;
						}
					case S_SYMSPECIAL:
						{   Symbol ws = (Symbol)stack.peek();
							ws.special = (SpecialFunction)w;
							state = S_SYMPLIST;
							break;
						}
					case S_SYMPLIST:
						{   Symbol ws = (Symbol)stack.peek();
							ws.cdr/*plist*/ = (LispObject)w;
							state = S_SYMVAL;
							break;
						}
					case S_SYMVAL:
						{   Symbol ws = (Symbol)stack.pop();
							ws.car/*value*/ = (LispObject)w;
							w = ws;
							state = istack[--sp];
							continue;
						}
					case S_AUTONAME:
						{   AutoLoad wa = (AutoLoad)stack.peek();
							wa.name = (Symbol)w;
							state = S_AUTODATA;
							break;
						}
					case S_AUTODATA:
						{   AutoLoad wa = (AutoLoad)stack.pop();
							wa.data = w;
							w = wa;
							state = istack[--sp];
							continue;
						}
					case S_INTERP_BODY:
						{   Interpreted wa = (Interpreted)stack.pop();
							wa.body = w;
							w = wa;
							state = istack[--sp];
							continue;
						}
					case S_MACRO_BODY:
						{   Macro wa = (Macro)stack.pop();
							wa.body = w;
							w = wa;
							state = istack[--sp];
							continue;
						}
					case S_CALLAS_BODY:
						{   CallAs wa = (CallAs)stack.pop();
							wa.body = w;
							w = wa;
							state = istack[--sp];
							continue;
						}
					default:
						Jlisp.lispIO.println("Unknown state");
						throw new IOException("Malformed image file (bad state)");
					}
				break;    // so "break" in the switch corresponds to
				// requesting a SHIFT, while "continue" is a REDUCE.
			}
		}
	}


	// read a single parenthesised expression.
	// Supports  'xx as a short-hand for (quote xx)
	// which is what most Lisps do.

	// Formal syntax:
	//    read => SYMBOL | NUMBER | STRING
	//         => ' read
	//         => ` read
	//         => , read
	//         => ,@ read
	//         => ( tail
	//    tail => )
	//         => . read )
	//         => read readtail

	static LispStream readIn;

	public static LispObject read() throws Exception
	{
		LispObject r;
		r = Jlisp.lit[Lit.std_input].car/*value*/;
		if (r instanceof LispStream) readIn = (LispStream)r;
		else throw new EOFException();
		if (!readIn.inputValid)
		{   inputType = readIn.nextToken();
			readIn.inputValid = true;
		}
		switch (inputType)
		{
		case LispStream.TT_EOF:
			throw new EOFException();
		case LispStream.TT_WORD:
			readIn.inputValid = false;
			return readIn.value;
			//case LispStream.TT_NUMBER:
			//readIn.inputValid = false;
			//return readIn.value;
			//case '\"':  // String
			//r = new LispString(readIn.sval);
			//readIn.inputValid = false;
			//return r;
		case '\'':
			readIn.inputValid = false;
			r = read();
			return new Cons(Jlisp.lit[Lit.quote], new Cons(r, Environment.nil));
		case '`':
			readIn.inputValid = false;
			r = read();
			return expandBackquote(r);
		case ',':
			readIn.inputValid = false;
			r = read();
			return new Cons(Jlisp.lit[Lit.comma], new Cons(r, Environment.nil));
		case 0x10000:  // ",@"
			readIn.inputValid = false;
			r = read();
			return new Cons(Jlisp.lit[Lit.commaAt], new Cons(r, Environment.nil));
		case '(':
			readIn.inputValid = false;
			return readTail();
		case ')':
		case '.':
			readIn.inputValid = false;
			return Environment.nil;
		default:
			if (inputType < 128) r = chars[inputType];
			else r = Symbol.intern(String.valueOf((char)inputType));
			readIn.inputValid = false;
			return r;
		}
	}

	static LispObject readTail() throws Exception
	{
		LispObject r;
		if (!readIn.inputValid)
		{   inputType = readIn.nextToken();
			readIn.inputValid = true;
		}
		switch (inputType)
		{
		case '.':
			readIn.inputValid = false;
			r = read();
			if (!readIn.inputValid)
			{   inputType = readIn.nextToken();
				readIn.inputValid = true;
			}
			if (inputType == ')') readIn.inputValid = false;
			return r;
		case LispStream.TT_EOF:
			throw new EOFException();
		case ')':
			readIn.inputValid = false;
			return Environment.nil;
		default:r = read();
			return new Cons(r, readTail());
		}
	}

	static LispObject expandBackquote(LispObject a)throws ResourceException
	{
		if (a == Environment.nil) return a;
		else if (a.atom)
			return new Cons(Jlisp.lit[Lit.quote], new Cons(a, Environment.nil));
		LispObject aa = a;
		if (aa.car == Jlisp.lit[Lit.comma]) return aa.cdr.car;
		if (!aa.car.atom)
		{   LispObject aaa = aa.car;
			if (aaa.car == Jlisp.lit[Lit.commaAt])
			{   LispObject v = aaa.cdr.car;
				LispObject t = expandBackquote(aa.cdr);
				return new Cons(Jlisp.lit[Lit.append],
				                new Cons(v, new Cons(t, Environment.nil)));
			}
		}
		return new Cons(Jlisp.lit[Lit.cons],
		                new Cons(expandBackquote(aa.car),
		                         new Cons(expandBackquote(aa.cdr), Environment.nil)));
	}





        	public static void preRestore() throws IOException
	{
		sharedIndex = 0;
		sharedSize = Jlisp.idump.read();
		sharedSize = (sharedSize<<8) + Jlisp.idump.read();
		sharedSize = (sharedSize<<8) + Jlisp.idump.read();
		shared = new LispObject[sharedSize];
		istacklimit = 500;
		istack = new int[istacklimit];
		stack = new Stack();
		stack.push(new Cons()); // to make "peek()" valid even when empty
	}

	public static void postRestore()
	{
		istack = null;
		stack = null;
		shared = null;
	}


	static void restore(InputStream dump) throws IOException, ResourceException
	{
		Jlisp.idump = dump;
		preRestore();
		Jlisp.descendSymbols = true;
		// First I will read and display the banner...
		// I would like to be able to update JUST this banner in a heap image. To
		// support that I will (sometime!) change my heap format to put the
		// banner as an initial chunk of bytes in the PDS outside the compressed
		// data that represents the main heap image. One natural place to put it
		// will be as part of the directory entry for the initial image, and another
		// would be at the very start of the whole image file.
		int n, i;
		n = Jlisp.idump.read();
		n = (n<<8) + Jlisp.idump.read();
		n = (n<<8) + Jlisp.idump.read();
		if (n != 0)
		{   byte [] b = new byte[n];
			for (i=0; i length " + name.length());
			int inc = name.hashCode();
			//System.out.println("raw hash = " + Integer.toHexString(inc));
			// I want my hash addresses and the increment to be positive...
			// and Java tells me what the hash algorithm for strings is. What I do here
			// ensures that strings that differ only in their final character get placed
			// some multiple of 169 apart (is not quite adjacant).
			int hash = ((169*inc) & 0x7fffffff) % oblistSize;
			inc = 1 + ((inc & 0x7fffffff) % (oblistSize-1)); // never zero
			//System.out.println("first probe = " + hash + " " + inc);
			while (oblist[hash] != null)
				{   if (oblist[hash].pname.equals(name))
					System.out.println("Two symbols called <" + name + "> " +
					                   Integer.toHexString((int)name.charAt(0)));
				hash += inc;
				if (hash >= oblistSize) hash -= oblistSize;
				//System.out.println("next probe = " + hash);
			}
			//System.out.println("Put <" + name + "> at " + hash + " " + inc);
			oblist[hash] = s;
			oblistCount++;
			// I will permit the hash table loading to reach 0.75, but then I take action
			if (4*oblistCount > 3*oblistSize) reHashOblist();
		}
		//System.out.println("termination of oblist found : " + oblistCount);

		LispObject w;

		if (Jlisp.idump.read() == 0) Fns.prompt = null;
		else
		{   w = readObject();
			Fns.prompt = ((LispString)w).string;
		}

		w = readObject();
		try { Gensym.gensymCounter = w.intValue(); }
		catch (Exception ee) { Gensym.gensymCounter = 0; }

		w = readObject();
		try { Environment.modulus = w.intValue(); }
		catch (Exception ee) { Environment.modulus = 1; }
		Environment.bigModulus = BigInteger.valueOf(Environment.modulus);

		w = readObject();
		try { Environment.printprec = w.intValue(); }
		catch (Exception ee) { Environment.printprec = 14; }


		postRestore();
	}

	static boolean isPrime(int n)
	{
		// the input must be odd and fairly large here... so the case of even
		// numbers is not important, as is the status of the number 1.
		for (int f=3; f*f<=n; f+=2)
		{   if (n%f == 0) return false;
		}
		return true;
	}


	public static void reHashOblist()
	{
		int n = ((3*oblistSize)/2) | 1;
		while (!isPrime(n)) n += 2;
		Symbol [] v = new Symbol[n];
		for (int i=0; i " +
					                   Integer.toHexString((int)s.pname.charAt(0)));
				hash += inc;
				if (hash >= n) hash -= n;
			}
			//System.out.println("Relocate <" + s.pname + "> at " + hash + " " + inc);
			v[hash] = s;
		}
		oblist = v;
		oblistSize = n;
		obvector.vec = v;
	}

	static public void scanObject(LispObject a)
	{
		if (a == null) return;
		stack.push(a);
		try              // keep going until the stack empties.
			{   for (;;)
			{   LispObject w = (LispObject)stack.pop();
				w.scan();
			}
		}
		catch (EmptyStackException e)
		{
		}
	}

	static void writeObject(LispObject a) throws Exception
	{
		if (a == null)
		{   Jlisp.odump.write(LispObject.X_NULL);
			return;
		}
		stack.push(a);
		try              // keep going until the stack empties.
			{   for (;;)
			{   LispObject w = (LispObject)stack.pop();
				if (w == null) Jlisp.odump.write(LispObject.X_NULL);
				else w.dump();
			}
		}
		catch (EmptyStackException e)
		{
		}
	}

	static void preserve(OutputStream dump) throws Exception
	{
		int i;
		Jlisp.odump = dump;
		Jlisp.descendSymbols = true;
		LispNumber g1 = LispInteger.valueOf(Gensym.gensymCounter);
		LispNumber g2 = LispInteger.valueOf(Environment.modulus);
		LispNumber g3 = LispInteger.valueOf(Environment.printprec);
		LispString gp = null;
		if (Fns.prompt != null) gp = new LispString(Fns.prompt);
		try
		{   objects = new HashSet();
			repeatedObjects = new HashMap();
			stack = new Stack();
			sharedIndex = 0;
			// First scan to detect shared sub-structures
			scanObject(Environment.nil);
			scanObject(Environment.lispTrue);
			for (i=0; i>16);
			Jlisp.odump.write(n>>8);
			Jlisp.odump.write(n);
			// See comments where the banner is loaded and displayed to the effect that
			// I might want to store this information elsewhere...
			byte [] rep = null;
			if (Environment.lit[Lit.banner] instanceof LispString)
			{   rep = ((LispString)Environment.lit[Lit.banner]).string.getBytes("UTF8");
				n = rep.length;
			}
			else n = 0;
			Jlisp.odump.write(n>>16);
			Jlisp.odump.write(n>>8);
			Jlisp.odump.write(n);
			for (i=0; i>16);
			Jlisp.odump.write(i>>8);
			Jlisp.odump.write(i);
			writeObject(a);
		}
		finally
		{   objects = null;
			repeatedObjects = null;
			stack = null;
		}

	}

}//End class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/Environment.java0000644000175000017500000000605111555450172026473 0ustar  giovannigiovanni/**************************************************************************
 * Copyright (C) 2011 Ted Kosan                                           *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/

package org.mathpiper.mpreduce;

import java.math.BigInteger;
import org.mathpiper.mpreduce.functions.builtin.Fns1;
import org.mathpiper.mpreduce.functions.builtin.Fns2;
import org.mathpiper.mpreduce.functions.builtin.Fns3;
import org.mathpiper.mpreduce.functions.builtin.MPReduceFunctions;
import org.mathpiper.mpreduce.special.Specfn;
import org.mathpiper.mpreduce.symbols.Symbol;


public class Environment {
    public static Symbol nil;
    public static Symbol lispTrue;
    public static LispObject[] lit = new LispObject[Lit.names.length];
    public static BigInteger bigModulus = BigInteger.ONE;
    public static int modulus = 1;
    public static int printprec = 15;
    public static boolean descendSymbols;
    public static boolean specialNil;

    static Fns1 fns1 = new Fns1();
    static Fns2 fns2 = new Fns2();
    static Fns3 fns3 = new Fns3();
    static MPReduceFunctions mpreduceFunctions = new MPReduceFunctions();
    static Specfn specfn = new Specfn();



}mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/mpreduce/Jlisp.java0000644000175000017500000012273711611456002025251 0ustar  giovannigiovannipackage org.mathpiper.mpreduce;

// Jlisp
//
// Standard Lisp system coded in Java. Actually this goes
// way beyond the Standard Lisp Report and includes a large fraction
// of that which is present in the CSL Lisp system.
//
// The purpose of this implementation is to support
// REDUCE. Early versions of jlisp were amazingly slow but
// performance is gradually improving!

//
// This file is part of the Jlisp implementation of Standard Lisp
// Copyright \u00a9 (C) Codemist Ltd, 1998-2011.
//

/**************************************************************************
 * Copyright (C) 1998-2011, Codemist Ltd.                A C Norman       *
 *                            also contributions from Vijay Chauhan, 2002 *
 *                                                                        *
 * Redistribution and use in source and binary forms, with or without     *
 * modification, are permitted provided that the following conditions are *
 * met:                                                                   *
 *                                                                        *
 *     * Redistributions of source code must retain the relevant          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer.                                                      *
 *     * Redistributions in binary form must reproduce the above          *
 *       copyright notice, this list of conditions and the following      *
 *       disclaimer in the documentation and/or other materials provided  *
 *       with the distribution.                                           *
 *                                                                        *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    *
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      *
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS      *
 * FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE         *
 * COPYRIGHT OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *
 * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,   *
 * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS  *
 * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *
 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR  *
 * TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF     *
 * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH   *
 * DAMAGE.                                                                *
 *************************************************************************/


import java.io.BufferedInputStream;
import java.io.BufferedOutputStream;
import java.io.BufferedReader;
import java.io.BufferedWriter;
import java.io.FileReader;
import java.io.FileWriter;
import java.io.IOException;
import java.io.InputStream;
import java.io.InputStreamReader;
import java.io.OutputStream;
import java.io.PrintWriter;
import java.io.Reader;
import java.io.Writer;
import java.math.BigInteger;
import java.text.DateFormat;
import java.util.Date;
import java.util.HashMap;
import java.util.TimeZone;
import java.util.Vector;
import java.util.zip.GZIPInputStream;
import java.util.zip.GZIPOutputStream;
import org.mathpiper.mpreduce.symbols.Gensym;
import org.mathpiper.mpreduce.symbols.Symbol;
import org.mathpiper.mpreduce.special.SpecialFunction;
import org.mathpiper.mpreduce.special.Specfn;
import org.mathpiper.mpreduce.io.Fasl;
import org.mathpiper.mpreduce.io.streams.WriterToLisp;
import org.mathpiper.mpreduce.datatypes.Cons;
import org.mathpiper.mpreduce.io.streams.DoubleWriter;
import org.mathpiper.mpreduce.functions.functionwithenvironment.Bytecode;
import org.mathpiper.mpreduce.functions.lisp.Undefined;
import org.mathpiper.mpreduce.exceptions.ProgEvent;
import org.mathpiper.mpreduce.exceptions.EOFException;
import org.mathpiper.mpreduce.io.streams.LispStringReader;
import org.mathpiper.mpreduce.datatypes.LispString;
import org.mathpiper.mpreduce.functions.lisp.LispFunction;
import org.mathpiper.mpreduce.numbers.LispSmallInteger;
import org.mathpiper.mpreduce.datatypes.LispHash;
import org.mathpiper.mpreduce.datatypes.LispEqualHash;
import org.mathpiper.mpreduce.exceptions.LispException;
import org.mathpiper.mpreduce.datatypes.LispVector;
import org.mathpiper.mpreduce.io.streams.LispStream;
import org.mathpiper.mpreduce.numbers.LispInteger;
import org.mathpiper.mpreduce.io.streams.LispOutputStream;
import org.mathpiper.mpreduce.packagedatastore.PDS;
import org.mathpiper.mpreduce.packagedatastore.PDSInputStream;
import org.mathpiper.mpreduce.packagedatastore.PDSOutputStream;
import org.mathpiper.mpreduce.functions.builtin.Fns;
//import org.mathpiper.mpreduce.javacompiler.Fns4;


import org.mathpiper.mpreduce.exceptions.ResourceException;

public class Jlisp extends Environment
{
        private static String version = ".016";

	// Within this file I will often reference lispIO and lispErr
	// directly. Elsewhere they should ONLY be accessed via the Lisp
	// variables that point towards them. The direct access here is in
	// cases where the Lisp world may not have been fully set up.
	public static LispStream lispIO, lispErr;
	public static boolean interactivep = false;
	public static boolean debugFlag = false;
	public static boolean headline = true;
	public static boolean backtrace = true;
	public static LispObject errorCode;
	public static int verbosFlag = 1;
	public static boolean trapExceptions = true;
	private static Writer transcript = null;

	public static boolean interruptEvaluation = false;

	public static void print(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.std_output].car/*value*/)).print(s);
	}

	public static void println(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.std_output].car/*value*/)).println(s);
	}

	public static void print(LispObject s) throws ResourceException
	{
		if (s==null) print(""); else s.print();
	}

	public static void println(LispObject s) throws ResourceException
	{
		if (s==null) print(""); else s.print();
		((LispStream)(lit[Lit.std_output].car/*value*/)).println();
	}

	public static void println() throws ResourceException
	{
		((LispStream)(lit[Lit.std_output].car/*value*/)).println();
	}

	public static void errprint(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.err_output].car/*value*/)).print(s);
	}

	public static void errprintln(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.err_output].car/*value*/)).println(s);
	}

	public static void errprintln() throws ResourceException
	{
		((LispStream)(lit[Lit.err_output].car/*value*/)).println();
	}

	public static void traceprint(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.tr_output].car/*value*/)).print(s);
	}

	public static void traceprintln(String s) throws ResourceException
	{
		((LispStream)(lit[Lit.tr_output].car/*value*/)).println(s);
	}

	public static void traceprintln() throws ResourceException
	{
		((LispStream)(lit[Lit.tr_output].car/*value*/)).println();
	}

	public static LispObject error(String s) throws LispException
	{
		if (headline)
		{   errprintln();
			errprintln("++++ " + s);
		}
                	     ResourceException.errors_now++;
 	  	     if (ResourceException.errors_limit > 0 &&
 	  	         ResourceException.errors_now > ResourceException.errors_limit)
                         {   if (headline) errprintln("++++ Error count resource exceeded");
                            throw new ResourceException("error count");
                         }

		     checkExit(s);



		throw new LispException(s);
	}

	public static LispObject error(String s, LispObject a) throws LispException
	{
		if (headline)
		{   errprintln();
			errprint("++++ " + s + ": ");
			a.errPrint();
			errprintln();
		}

                     ResourceException.errors_now++;
 	  	     if (ResourceException.errors_limit > 0 &&
 	  	         ResourceException.errors_now > ResourceException.errors_limit)
                         {   if (headline) errprintln("++++ Error count resource exceeded");
                            throw new ResourceException("error count");
                        }

		

		checkExit(s);



		throw new LispException(s);
	}


	// The main parts of this file relate to system startup options

	public static PDS [] images = new PDS[10];
	public static int outputImagePos;
	public static int imageCount;

	static String [] imageFile = new String[10];

	public static void main(String [] args)
	{
		startup(args,
		        new InputStreamReader(System.in),
		        new PrintWriter(System.out),
		        true);
	}

	static Reader in;
	public static PrintWriter out;

	public static boolean standAlone;

	public static Vector openOutputFiles = null;

	public static boolean restarting = false;
	static String  restartModule = null;
	static String  restartFn = null;
	static String  restartArg = null;

	static boolean finishingUp = false;

	public static void startup(String [] args,
	                           Reader Xin, PrintWriter Xout,
	                           boolean standAloneFlag)
	{
		in = Xin;
		out = Xout;
		lispIO = null;
		standAlone = standAloneFlag;
		Thread t = null;
		if (standAlone)
		{   final int screenRefreshInterval = 2500;
			t = new FlushOutputThread();
			t.start();
		}
		// I am pretty keen that all output files should be closed (and in the
		// process they should be flushed) so that data is never lost. So I keep
		// a record (in this Vector) of ones that are liable to need closing, and
		// then in a "finally" clause I zoom through cleaning up.
		openOutputFiles = new Vector(10, 5);
		try
		{   startup1(args);
		}
                catch (Exception e)
 	  	{e.printStackTrace();}
		finally
		{
			lispIO = null;
			finishingUp = true;
			t.interrupt();     // so it can exit
			int i;
			// In general I close in the opposite order from that in which I opened files.
			// The code here is such that if closing one file happened to have a side
			// effect of closing another along the way that would not be a calamity.
			while ((i=openOutputFiles.size()) != 0)
			{   ((LispStream)openOutputFiles.get(i-1)).close();
			}
		}
		// If I was run as an application not an applet (via any route!) I am
		// permitted to exit.
		// if (!CWin.isApplet) System.exit(0);
	}

	static void startup1(String [] args) throws Exception
	{
		long startTime = System.currentTimeMillis();
		String [] inputFile = new String [10];
		int inputCount = 0;
		imageCount = 0;
		outputImagePos = -1;
		boolean coldStart = false;
		String mainOutput = null;
		String logFile = null;
		boolean verbose = false;
		boolean copyrightRequest = false;
		String [] errs = new String [10];
		int errCount = 0;
		String [] defineSymbol = new String [10];
		int defineCount = 0;
		String [] undefineSymbol = new String [10];
		int undefineCount = 0;
		boolean noRestart = false;
		boolean batchSwitch = false;
		// I may need to display diagnostics before I have finshed setting up
		// streams etc in their proper final form, so I arrange a provisional
		// setting that directs early messages to the terminal.
		lispIO = lispErr = new LispOutputStream();
		lit[Lit.std_output] = lit[Lit.tr_output] =
		                              lit[Lit.err_output] = lit[Lit.std_input] =
		                                                            lit[Lit.terminal_io] = lit[Lit.debug_io] =
		                                                                                           lit[Lit.query_io] = Symbol.intern("temp-stream");
		standardStreams();

		// The options that I accept here are intended to match (as far as I can
		// reasonably make them) the ones used with the "CSL" Lisp implementation.
		// I scan the command line to decode them. Note that until this has
		// been completed I can not do proper Lisp output because I will not have
		// seen redirection requests.
		int i;
		for (i=0; i= 2 && arg.charAt(0) == '-')
			{   char key = Character.toLowerCase(arg.charAt(1));
				switch (key)
				{
				case '-': // redirect all output
					break;
				case 'b': // flips batchp() result
					batchSwitch = true;
					continue;
				case 'c': // display copyright notice
					copyrightRequest = true;
					continue;
				case 'd': // define symbol
					break;
				case 'e': // "experiment" control
					continue;
				case 'f': // serve on a socket
					break;
				case 'g': // enhance debugging
					debugFlag = true;
					continue;
				case 'i': // specify (input) image or library
					break;
				case 'k': // indicate amount of memory to use
					break;
				case 'l': // transcript of output to a log file
					break;
				case 'm': // (memory trace control)
					continue;
				case 'n': // ignore restart function in image
					noRestart = true;
					continue;
				case 'o': // output image
					break;
				case 'p': // profile option
					continue;
				case 'q': // quiet mode
					verbose = false;
					continue;
				case 'r': // initial random seed
					break;
				case 's': // view machine code from any compilation
					continue;
				case 't': // inspect time-stamp on a module
					continue;
				case 'u': // undefined symbol
					break;
				case 'v': // verbose mode
					verbose = true;
					continue;
				case 'w': // run in windowed mode
					continue;
				case 'x': // less trapping of possibly internal errors
					System.out.println("JVM exit on error set.");
					trapExceptions = false;
					continue;
				case 'y': // ignore restart-function in saved image
					continue;
				case 'z': // cold start mode
					coldStart = true;
					continue;
				default:
					if (errCount < errs.length)
						errs[errCount++] =
						        "Invalid option \"" + arg + "\"";
					continue;
				}
				// In many cases an option takes an argument. I permit either -Ixx or -I xx
				// and separate off xxx here.
				if (arg.length() > 2) arg1 = arg.substring(2);
				else if (i+1\"");
					// The next two lines are for debugging at least
					lispErr.println(e.getMessage());
					e.printStackTrace(new PrintWriter(new WriterToLisp(lispErr)));
					loaded = false;
				}
				finally
					{   if (image != null)
						{   try
						{   image.close();
						}
						catch (IOException e)
						{   lispErr.println("Failed to load image");
							loaded = false;
						}
					}
				}
				if (restarting && !loaded)
				{   lispIO.println("+++ No image file when restarting");
					return;
				}
			}

			// If no image file was available I will fall back to a cold start. This is
			// probably not what is wanted in the long run but will be useful while
			// testing.
			if (!loaded)
			{   initSymbols();
				DateFormat df = DateFormat.getInstance();
				df.setTimeZone(TimeZone.getDefault());
				lit[Lit.birthday] = new LispString(df.format(new Date()));
			}
			else
			{   // System.out.println("Bodge here...");
				//initfns(fns4.builtins);
			}
			lispIO.tidyup(nil);
			lispErr.tidyup(nil);

			// Having set up an image I optionally display a banner.
			if (verbose)
			{   lispIO.println("Jlisp 0.93a ... " +
				                   ((LispString)lit[Lit.birthday]).string);
				if (loaded)
				{   lispIO.println("Sym    = " + Symbol.symbolCount);
					lispIO.println("Cons   = " + Cons.consCount);
					lispIO.println("String = " + LispString.stringCount);
				}
				if (copyrightRequest)
				{
					lispIO.println("Copyright \u00a9 (C) Codemist Ltd, 1998-2000");
				}
			}

			// If the user specifed -Dxxx, -Dxxx=yyy or -Uxxx on the command
			// line I process that here. I will perform all the "undefine"
			// operations before any of the "define" ones, but otherwise
			// proceed left to right
			for (i=0; i", in, standAlone, true);
				standardStreams();
				//System.out.printf("set up standard streams%n");
				try
				{   readEvalPrintLoop(noRestart);
					throw new ProgEvent(ProgEvent.STOP, nil, "EOF");
				}
				catch (ProgEvent e)
				{
					checkExit(e.getMessage());


					switch (e.type)
					{
					case ProgEvent.STOP:
						restarting = false;
						break;
					case ProgEvent.PRESERVE:
						Cons w = (Cons)e.details;
						preserve(w.car, w.cdr);
						restarting = false;
						break;
					case ProgEvent.RESTART:
						println();
						println("Restart Lisp...");
						// the RESTART event has (details/extra) as Lisp items carried
						// with it.
						//    If details=nil it asks for a cold start
						//    If details=t   it asks for a normal start using the default
						//                   restart-action from the image
						//    if details=f   it does a warm restart but then calls function f
						//                   (this is any atomic f not nil or t)
						//    if details=(m f) it does a warm start, then loads module m and
						//                   finally calls function f
						// In the two latter cases (ie details other than nil/t) if extra is provided
						// it is passed on as an argument to the user-specified restart function f.
						//
						// This elaborate behaviour is as grew up piecemeal in CSL and it is expected
						// that this function is only used when setting up scripts to rebuild major
						// bits of software so MAYBE the fact that it is a bit obscure is not too
						// much of a problem.
						restartFn = null;
						restartModule = null;
						restartArg = null;
						if (e.details == nil) coldStart = true;
						else try
							{   coldStart = false;
								if (e.details != lispTrue)
									{   if (e.details.atom)
									{   restartFn = Fns.explodeToString(e.details);
									}
									else
									{   restartModule =
										        Fns.explodeToString(e.details.car);
										LispObject w1 = e.details.cdr;
										if (!w1.atom) w1 = w1.car;
										restartFn = Fns.explodeToString(w1);
									}
									if (e.extras != null)
										restartArg = Fns.explodeToString(e.extras);
								}
							}
							catch (Exception e1)
							{   System.out.println("Unexpected exception " + e1);
							}
						restarting = true;
						continue;
					default:
						errprintln();
						errprintln("Stopping because of " + e.message);
						restarting = false;
						break;
					}
				}
				if (restarting) continue;
				else break;
			}
			else
			{   interactivep = batchSwitch;
				if (restarting) inputCount = 1;
				for (i=0; i functionCategoriesList = new ArrayList();
    private int documentedFunctionsCount = 0;
    private int undocumentedMPWFileCount = 0;


    public Build() {
    }//end constructor.


    public Build(String sourceScriptsDirectory, String outputScriptsDirectory) {
        this.sourceScriptsDirectory = sourceScriptsDirectory;
        this.outputScriptsDirectory = outputScriptsDirectory;
    }//end constructor.


    public Build(String sourceScriptsDirectory, String outputScriptsDirectory, String outputDirectory) throws Exception {
        this(sourceScriptsDirectory, outputScriptsDirectory);

        this.outputDirectory = outputDirectory;


        documentationFile = new DataOutputStream(new java.io.FileOutputStream(outputDirectory + "org/mathpiper/ui/gui/help/data/documentation.txt"));
        documentationIndexFile = new java.io.FileWriter(outputDirectory + "org/mathpiper/ui/gui/help/data/documentation_index.txt");
        functionCategoriesFile = new java.io.FileWriter(outputDirectory + "org/mathpiper/ui/gui/help/data/function_categories.txt");



    }


    public void setSourceScriptsDirectory(String scriptsDirectory) {
        this.sourceScriptsDirectory = scriptsDirectory;
    }//end method.


    public void setOutputScriptsDirectory(String outputDirectory) {
        this.outputScriptsDirectory = outputDirectory;
    }//end method.



    public void setOutputDirectory(String outputDirectory) throws Exception {
        this.outputDirectory = outputDirectory;

        documentationFile = new DataOutputStream(new java.io.FileOutputStream(outputDirectory + "org/mathpiper/ui/gui/help/data/documentation.txt"));
        documentationIndexFile = new java.io.FileWriter(outputDirectory + "org/mathpiper/ui/gui/help/data/documentation_index.txt");
        functionCategoriesFile = new java.io.FileWriter(outputDirectory + "org/mathpiper/ui/gui/help/data/function_categories.txt");


    }//end method.

    public void setBaseDirectory(String baseDirectory) {
        this.sourceDirectory = baseDirectory + "src/";
    }//end method.


    public void compileScripts() throws Exception {


        //System.out.println("XXXXX " + outputDirectory);
        packagesFile = new java.io.FileWriter(outputScriptsDirectory + "initialization.rep/packages.mpi");
        packagesFile.write("//// This file is generated by a script.\n/// It lists all {.def} files in the library.\nDefun(DefFileList,{}) {\n");


        scriptsDir = new java.io.File(sourceScriptsDirectory);

        if (scriptsDir.exists()) {
            java.io.File[] packagesDirectory = scriptsDir.listFiles(new java.io.FilenameFilter() {

                public boolean accept(java.io.File file, String name) {
                    if (name.endsWith(".rep") || name.startsWith(".")) {
                        return (false);
                    } else {
                        return (true);
                    }
                }


            });

            Arrays.sort(packagesDirectory);



            String output;
            for (int x = 0; x < packagesDirectory.length; x++) {
                //Process each package directory.************************************************************************
                File packageDirectoryFile = packagesDirectory[x];
                String packageDirectoryFileName = packageDirectoryFile.getName();

                System.out.println(packageDirectoryFile.getPath() + "/");

                //Create package directory
                String dirNameRep = packageDirectoryFileName;
                String newPackageName = dirNameRep + ".rep";
                String newPackagePath = outputScriptsDirectory + newPackageName;
                File newPackageFile = new File(newPackagePath);
                Boolean directoryCreated = newPackageFile.mkdirs();

                //mpi file.
                BufferedWriter mpiFileOut = null;
                File newMPIFile = new File(newPackagePath + "/" + "code.mpi");
                newMPIFile.createNewFile();
                mpiFileOut = new BufferedWriter(new FileWriter(newMPIFile));

                packagesFile.write("\"" + newPackageName + "/code.mpi\",\n");

                //mpi.def file
                BufferedWriter mpiDefFileOut = null;
                File newMPIDefFile = new File(newPackagePath + "/" + "code.mpi.def");
                newMPIDefFile.createNewFile();
                mpiDefFileOut = new BufferedWriter(new FileWriter(newMPIDefFile));


                //Place files in package dir
                if (packageDirectoryFile.exists()) {
                    java.io.File[] packageDirectoryContentsArray = packageDirectoryFile.listFiles(new java.io.FilenameFilter() {

                        public boolean accept(java.io.File file, String name) {
                            if (name.startsWith(".")) {
                                return (false);
                            } else {
                                return (true);
                            }
                        }


                    });

                    Arrays.sort(packageDirectoryContentsArray);


                    for (int x2 = 0; x2 < packageDirectoryContentsArray.length; x2++) {
                        //Process each script or subdirectory in a .rep directory.***********************************************************************************
                        File scriptFileOrSubdirectoy = packageDirectoryContentsArray[x2];

                        if (scriptFileOrSubdirectoy.getName().toLowerCase().endsWith(".mrw")) {
                            throw new Exception("The .mrw file extension has been deprecated ( " + scriptFileOrSubdirectoy.getName() +" ).");
                        }

                        if (scriptFileOrSubdirectoy.getName().toLowerCase().endsWith(".mpw")) {
                            //Process a .mpw files that is in a top-level package. ************************************************************************
                            
                            System.out.print("    " + scriptFileOrSubdirectoy.getName() +" -> ");

                            documentedFunctionsCount++;

                            processMPWFile(scriptFileOrSubdirectoy, mpiDefFileOut, mpiFileOut);

                        } else {
                            //Process a subdirectory.***********************************************************************************************

                            System.out.println("    " + scriptFileOrSubdirectoy + "/");

                            java.io.File[] packageSubDirectoryContentsArray = scriptFileOrSubdirectoy.listFiles(new java.io.FilenameFilter() {

                                public boolean accept(java.io.File file, String name) {
                                    if (name.startsWith(".")) {
                                        return (false);
                                    } else {
                                        return (true);
                                    }
                                }


                            });

                            Arrays.sort(packageSubDirectoryContentsArray);

                            BufferedWriter mpiSubDirectoyFileOut = null;
                            File newMPISubDirectoyFile = new File(newPackagePath + "/" + scriptFileOrSubdirectoy.getName() + ".mpi");
                            newMPISubDirectoyFile.createNewFile();
                            mpiSubDirectoyFileOut = new BufferedWriter(new FileWriter(newMPISubDirectoyFile));

                            packagesFile.write("\"" + newPackageName + "/" + scriptFileOrSubdirectoy.getName() + ".mpi" + "\",\n");

                            //mpi.def file
                            BufferedWriter mpiSubDirectoyDefFileOut = null;
                            File newMPISubDirectoyDefFile = new File(newPackagePath + "/" + scriptFileOrSubdirectoy.getName() + ".mpi.def");
                            newMPISubDirectoyDefFile.createNewFile();
                            mpiSubDirectoyDefFileOut = new BufferedWriter(new FileWriter(newMPISubDirectoyDefFile));

                            for (int x3 = 0; x3 < packageSubDirectoryContentsArray.length; x3++) {
                                //Process each script in a package subdirectlry directory.
                                File scriptFile2 = packageSubDirectoryContentsArray[x3];
                                System.out.print("        " + scriptFile2.getName() + " -> ");

                                processMPWFile(scriptFile2, mpiSubDirectoyDefFileOut, mpiSubDirectoyFileOut);

                                //mpi file.


                            }//end subpackage for.

                            if (mpiSubDirectoyFileOut != null) {
                                mpiSubDirectoyFileOut.close();
                                mpiSubDirectoyDefFileOut.write("}\n\n");
                                mpiSubDirectoyDefFileOut.close();
                            }

                        }//end else.

                    }//end package for.


                }//end if.

                if (mpiFileOut != null) {
                    mpiFileOut.close();
                    mpiDefFileOut.write("}\n");
                    mpiDefFileOut.close();
                }

            }//end for.

            if (documentationFile != null) {
            	    
                processBuiltinDocs(sourceDirectory, outputDirectory, "org/mathpiper/builtin/functions/core");
                
                processBuiltinDocs(sourceDirectory, outputDirectory, "org/mathpiper/builtin/functions/optional");
                
                processBuiltinDocs(sourceDirectory, outputDirectory, "org/mathpiper/builtin/functions/plugins/jfreechart");
            }

            Collections.sort(functionCategoriesList);
            for (CategoryEntry entry : functionCategoriesList) {
                functionCategoriesFile.write(entry.toString() + "\n");
            }


        } else {
            System.out.println("\nDirectory " + sourceScriptsDirectory + "does not exist.\n");
        }

        packagesFile.write("\n};\n");
        packagesFile.close();

        if (documentationFile != null) {

            documentationFile.close();
            documentationIndexFile.close();
            functionCategoriesFile.close();
        }


        System.out.println("\nDocumented functions: " + this.documentedFunctionsCount + "\n");

        System.out.println("Undocumented .mpw files: " + this.undocumentedMPWFileCount + "\n");


    }//end method.


    List scanSourceFile(File sourceFile) throws Exception {


        String fileName = sourceFile.getName();

        //Uncomment for debugging.
        /*
        if (fileName.equals("Factors.mpw")) {
            int xxx = 1;
        }//end if.*/

        List folds = new ArrayList();
        StringBuilder foldContents = new StringBuilder();
        String foldHeader = "";
        boolean inFold = false;


        FileInputStream fstream = new FileInputStream(sourceFile);
        // Get the object of DataInputStream
        DataInputStream in = new DataInputStream(fstream);
        BufferedReader br = new BufferedReader(new InputStreamReader(in));
        String line;
        //Read File Line By Line
        while ((line = br.readLine()) != null) {
            //line = line.trim();
            //System.out.println(line);

            if (line.startsWith("%/")) {

                if (inFold == false) {
                    throw new Exception("Opening fold tag missing in " + fileName + ".");
                }

                Fold fold = new Fold(foldHeader, foldContents.toString());
                foldContents.delete(0, foldContents.length());
                folds.add(fold);
                inFold = false;

            } else if (line.startsWith("%")) {

                if (inFold == true) {
                    throw new Exception("Closing fold tag missing in " + fileName + ".");
                }

                foldHeader = line;
                inFold = true;
            } else if (inFold == true) {
                foldContents.append(line);
                foldContents.append("\n");

            }
        }//end while.

        if (inFold == true) {
            throw new Exception("Opening or closing fold tag missing in " + fileName + ".");
        }

        //Close the input stream
        in.close();


        return folds;

    }//end.


    class Fold {

        private String type;
        private String contents;
        private Map attributes = new HashMap();


        public Fold(String header, String contents) {
            scanHeader(header);

            this.contents = contents;
        }//end inner class.


        private void scanHeader(String header) {
            String[] headerParts = header.trim().split(",");

            type = headerParts[0];

            for (int x = 1; x < headerParts.length; x++) {
                headerParts[x] = headerParts[x].replaceFirst("=", ",");
                String[] headerPart = headerParts[x].split(",");
                String attributeName = headerPart[0];
                String attributeValue = headerPart[1].replace("\"", "");
                attributes.put(attributeName, attributeValue);
            }

        }//end method.


        public Map getAttributes() {
            return attributes;
        }


        public String getContents() {
            return contents;
        }


        public String getType() {
            return type;
        }


    }//end inner class.


    private void processMPWFile(File mpwFile, Writer mpiDefFileOut, Writer mpiFileOut) throws Exception {

        List folds = scanSourceFile(mpwFile);

        boolean hasDocs = false;

        String scopeAttribute = "public";
        //String scope = "public";

        for (Fold fold : folds) {

            String foldType = fold.getType();

            if (foldType.equalsIgnoreCase("%mathpiper")) {


                if (fold.getAttributes().containsKey("scope")) {
                    scopeAttribute = (String) fold.getAttributes().get("scope");
                }

                if (!scopeAttribute.equalsIgnoreCase("nobuild")) {

                    mpiFileOut.write(fold.getContents());

                    if (fold.getAttributes().containsKey("def")) {
                        String defAttribute = (String) fold.getAttributes().get("def");
                        if (!defAttribute.equalsIgnoreCase("")) {

                            String[] defFunctionNames = defAttribute.split(";");

                            for (int x = 0; x < defFunctionNames.length; x++) {
                                mpiDefFileOut.write(defFunctionNames[x]);
                                mpiDefFileOut.write("\n");
                            }//end if.
                        }//end if.
                    }//end if.

                    //scope = scopeAttribute;
                }//end if.


            } else if (foldType.equalsIgnoreCase("%mathpiper_docs")) {
                //System.out.println("        **** Contains docs *****");
                hasDocs = true;

                String mpwFilePath = mpwFile.getPath();

                processMathPiperDocsFold(fold, mpwFilePath);

            }//end if.


        }//end subpackage for.

        if (!hasDocs) {
            System.out.println("**** Does not contain docs ****");
            this.undocumentedMPWFileCount++;
        }
        else
        {
            System.out.println();
        }
    }//end method.


    private void processMathPiperDocsFold(Fold fold, String mpwFilePath) throws Exception {
        if (documentationFile != null) {
        	
            mpwFilePath = mpwFilePath.substring(mpwFilePath.indexOf(File.separator + "org" + File.separator + "mathpiper" + File.separator)); //"/org/mathpiper/";

            String functionNamesString = "";
            if (fold.getAttributes().containsKey("name")) {
                functionNamesString = (String) fold.getAttributes().get("name");

                //Uncomment to debug the documentation for a given function..
                /*if(functionNamesString.equals("RepToNumber"))
                {
                int xxx = 1;
                }*/


                String[] functionNames = functionNamesString.split(";");

                for (String functionName : functionNames) {
                    //DataOutputStream individualDocumentationFile = null;
                    /*
                    try{
                    individualDocumentationFile =  new DataOutputStream(new java.io.FileOutputStream(outputDirectory + functionName));
                    }catch(Exception ex)
                    {
                    ex.printStackTrace();
                    }*/

                    documentationIndexFile.write(functionName + ",");
                    documentationIndexFile.write(documentationOffset + ",");

                    String contents = fold.getContents();

                    contents = contents + "\n*SOURCE " + mpwFilePath;

                    byte[] contentsBytes = contents.getBytes();
                    documentationFile.write(contentsBytes, 0, contentsBytes.length);
                    //individualDocumentationFile.write(contentsBytes, 0, contentsBytes.length);
                    //individualDocumentationFile.close();

                    documentationOffset = documentationOffset + contents.length();
                    documentationIndexFile.write(documentationOffset + "\n");

                    byte[] separator = "\n==========\n".getBytes();
                    documentationFile.write(separator, 0, separator.length);

                    documentationOffset = documentationOffset + separator.length;

                    String access = "public";

                    if (fold.getAttributes().containsKey("categories")) {


                        int commandIndex = contents.indexOf("*CMD");
                        if(commandIndex == -1)
                        {
                            throw new Exception("Missing *CMD tag.");
                        }
                        String descriptionLine = contents.substring(commandIndex, contents.indexOf("\n", commandIndex));
                        String description = descriptionLine.substring(descriptionLine.lastIndexOf("--") + 2);
                        description = description.trim();

                        if(description.contains(","))
                        {
                            description = "\"" + description + "\"";
                        }

                        System.out.print(functionName + ": " + description + ", ");

                        String functionCategories = (String) fold.getAttributes().get("categories");
                        String[] categoryNames = functionCategories.split(";");
                        String categories = "";

                        int categoryIndex = 0;
                        String functionCategoryName = "";

                        for (String categoryName : categoryNames) {
                            if (categoryIndex == 0) {
                                //functionCategoriesFile.write(categoryName + ",");
                                functionCategoryName = categoryName;

                            } else {
                                categories = categories + categoryName + ",";
                            }
                            categoryIndex++;
                        }//end for.

                        //functionCategoriesFile.write(functionName + ",");


                        //functionCategoriesFile.write(description);


                        if (!categories.equalsIgnoreCase("")) {
                            categories = categories.substring(0, categories.length() - 1);
                            //functionCategoriesFile.write("," + categories);

                        }
                        //functionCategoriesFile.write("\n");
                        if (functionCategoryName.equalsIgnoreCase("")) {
                            functionCategoryName = "Uncategorized";  //todo:tk:perhaps we should throw an exception here.
                        }

                        if (fold.getAttributes().containsKey("access")) {
                            access = (String) fold.getAttributes().get("access");
                        }

                        CategoryEntry categoryEntry = new CategoryEntry(functionCategoryName, functionName, access, description, categories);

                        functionCategoriesList.add(categoryEntry);

                    }
                    else
                    {
                        System.out.print(functionName + ": **** Uncategorized ****, ");
                    }
                }//end for.
            }//end if.




        }//end if.
    }//end method


    public void execute() throws Exception {
        //execute() method is needed by ant to run this class.
        System.out.println("****************** Compiling scripts *******");
        System.out.println("Source directory: " + this.sourceScriptsDirectory);
        System.out.println("Destination directory: " + this.outputScriptsDirectory);
        compileScripts();
    }//end method.


    private class CategoryEntry implements Comparable {

        private String categoryName;
        private String functionName;
        private String access;
        private String description;
        private String categories;


        public CategoryEntry(String categoryName, String functionName, String access, String description, String categories) {
            this.categoryName = categoryName;
            this.functionName = functionName;
            this.access = access;
            this.description = description;
            this.categories = categories;
        }


        public int compareTo(Object o) {
            CategoryEntry categoryEntry = (CategoryEntry) o;
            return this.functionName.compareToIgnoreCase(categoryEntry.getFunctionName());
        }//end method.


        public String getFunctionName() {
            return this.functionName;
        }//end method.


        public String toString() {
            return categoryName + "," + functionName + "," + access + "," + description + "," + categories;
        }//end method.


    }//end class.


    private void processBuiltinDocs(String sourceDirectoryPath, String outputDirectoryPath, String pluginFilePath) throws Exception {
        // try {
        System.out.println("\n***** Processing built in docs *****");

        File builtinFunctionsSourceDir = new java.io.File(sourceDirectoryPath + pluginFilePath );
        
        String directoryPath = builtinFunctionsSourceDir.getPath();
        
        System.out.println(directoryPath + "/");


        java.io.FileWriter pluginsListFile = null;
        if(!directoryPath.endsWith("core"))
        {
            pluginsListFile = new java.io.FileWriter(outputDirectoryPath + "/" + pluginFilePath + "/plugins_list.txt");
        }


        if (builtinFunctionsSourceDir.exists()) {
            java.io.File[] javaFilesDirectory = builtinFunctionsSourceDir.listFiles(new java.io.FilenameFilter() {

                public boolean accept(java.io.File file, String name) {
                    if (name.endsWith(".java")) {
                        return true;
                    } else {
                        return false;
                    }
                }


            });

            Arrays.sort(javaFilesDirectory);

            for (int x = 0; x < javaFilesDirectory.length; x++) {

                File javaFile = javaFilesDirectory[x];
                String javaFileName = javaFile.getName();

                if(pluginsListFile != null)
                {
                    pluginsListFile.append( javaFileName.substring(0,javaFileName.length() - 4) + "class" + "\n");
                }


                System.out.print("    " + javaFileName + " -> ");

                this.documentedFunctionsCount++;

                List folds = scanSourceFile(javaFile);

                boolean hasDocs = false;

                for (Fold fold : folds) {

                    String foldType = fold.getType();
                    if (foldType.equalsIgnoreCase("%mathpiper_docs")) {
                        // System.out.println("        **** Contains docs *****  " + javaFileName);
                        hasDocs = true;


                        processMathPiperDocsFold(fold, javaFile.getPath());

                    }//end if.

                }//end for

                if (!hasDocs) {
                    System.out.println("**** Does not contain docs ****");// + javaFileName);
                    this.undocumentedMPWFileCount++;
                }
                else
                {
                    System.out.println();
                }




            }//end for

            if(pluginsListFile != null)
            {
                pluginsListFile.close();
            }

        }//end if.

        /*               } catch (java.io.IOException e) {
        e.printStackTrace();
        }*/


    }//end method.


    public static void main(String[] args) {

        String sourceScriptsDirectory;

        if (args.length > 0) {
            sourceScriptsDirectory = args[0];
        } else {
            sourceScriptsDirectory = "/home/tkosan/NetBeansProjects/mathpiper/src/org/mathpiper/scripts4/";
        }

        String outputScriptsDirectory = "/home/tkosan/NetBeansProjects/mathpiper/build/classes/org/mathpiper/assembledscripts/"; //"/home/tkosan/NetBeansProjects/scripts/";
        File newScriptsDirectory = new File(outputScriptsDirectory);
        Boolean directoryCreated = newScriptsDirectory.mkdirs();




        File newInitializationDirectory = new File(outputScriptsDirectory + "initialization.rep/");
        newInitializationDirectory.mkdirs();

        File outputDocsDirectory = new File(outputScriptsDirectory + "documentation/org/mathpiper/ui/gui/help/data/");
        outputDocsDirectory.mkdirs();
        
        File pluginsDirectory = new File(outputScriptsDirectory + "documentation/org/mathpiper/builtin/functions/optional/");
        pluginsDirectory.mkdirs();

        pluginsDirectory = new File(outputScriptsDirectory + "documentation/org/mathpiper/builtin/functions/plugins/jfreechart/");
        pluginsDirectory.mkdirs();


        //String outputDirectory = "/home/tkosan/temp/mathpiper/org/mathpiper/assembledscripts/";

        String outputDirectory = "/home/tkosan/NetBeansProjects/mathpiper/build/classes/";

        try {

            Build scripts = new Build(sourceScriptsDirectory, outputScriptsDirectory,  outputDirectory);

            scripts.setBaseDirectory("/home/tkosan/NetBeansProjects/mathpiper/");


            scripts.compileScripts();

            Map functionDocs = new HashMap();

            BufferedReader documentationIndex = new BufferedReader(new FileReader(outputDocsDirectory.getPath() + "/documentation_index.txt"));

            String line;
            while ((line = documentationIndex.readLine()) != null) {

                String[] values = line.split(",");

                if (values[0].indexOf(";") != -1) {
                    String[] functionNames = values[0].split(";");
                    for (String name : functionNames) {
                        functionDocs.put(name, values[1] + "," + values[2]);
                    }//end for.
                } else {
                    functionDocs.put(values[0], values[1] + "," + values[2]);
                }//end else.
            }//end while.

            documentationIndex.close();

        } catch (Exception e) {
            e.printStackTrace();
        }


    }//end main
}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/InterpreterTest.java0000644000175000017500000001001611423200443026465 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 *///}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.test;

import org.mathpiper.interpreters.Interpreters;
import org.mathpiper.interpreters.EvaluationResponse;
import org.mathpiper.interpreters.Interpreter;
import org.mathpiper.interpreters.ResponseListener;

/**
 *
 */
public class InterpreterTest implements ResponseListener
{

    public InterpreterTest()
    {
        
        EvaluationResponse response;
       
        final Interpreter interpreter = Interpreters.getSynchronousInterpreter();

        /*
         final Timer timer = new Timer();

        timer.schedule(new TimerTask() {
            public void run() {
                interpreter.haltEvaluation();
                timer.cancel();
            }

        }, 1000); //Time out after one second.
        */

        
        // response = interpreter.evaluate("Tell(a);");
       // System.out.println("Straight: " + "Result: " + response.getResult() + "  Side Effects: " + response.getSideEffects() + "  Errors: " + response.getExceptionMessage());
         
        //Load("/home/tkosan/NetBeansProjects/mathpiper/src/org/mathpiper/test/test.mpi");
        response = interpreter.evaluate("LoadScript(\"/home/tkosan/NetBeansProjects/mathpiper/src/org/mathpiper/test/test.mpi\");");

        //timer.cancel();
        
        System.out.println("Load test: " + "Result: " + response.getResult() + "  Side Effects: " + response.getSideEffects() + "  Errors: " + response.getExceptionMessage() + "   File: " + response.getSourceFileName() + "  Line number: " + response.getLineNumber());
        
       /* response = interpreter.evaluate("3+3;");
         System.out.println("Straight: " + "Result: " + response.getResult() + "  Side Effects: " + response.getSideEffects() + "  Errors: " + response.getExceptionMessage());
        * */
        
       /* interpreter = Interpreters.newAsynchronousInterpreter();
        interpreter.addResponseListener(this);
        response = interpreter.evaluate("2+2;");
        System.out.println("AsynchronousInterpreter evaluation request sent.");*/
        
        
    }
    
    public void response(EvaluationResponse response)
    {
         System.out.println("AsynchronousInterpreter: " + response.getResult());
    }
    
    public boolean remove()
    {
        return true;
    }
    
    public static void main(String[] args)
    {
        new InterpreterTest();

        /*
        JFrame frame = new JFrame();
        Container contentPane = frame.getContentPane();

    	geogebra.GeoGebraPanel ggbPanel = new geogebra.GeoGebraPanel();
    	ggbPanel.setShowAlgebraInput(true);
        ggbPanel.setShowAlgebraView(false);
    	ggbPanel.setMaxIconSize(24);
    	ggbPanel.setShowMenubar(true);
    	ggbPanel.setShowToolbar(true);
    	ggbPanel.buildGUI();
    	contentPane.add(ggbPanel);
        frame.setBounds ( 10 , 10 , 700 , 700 );
        frame.setVisible(true);

        geogebra.plugin.GgbAPI ggbAPI = ggbPanel.getGeoGebraAPI();


        //Wait until the frame is shown.
        try
        {
        Thread.sleep(3000);
        }
        catch(InterruptedException ie)
        {

        }


        ggbAPI.setRepaintingActive(false);



        //Plot 1000 points to the drawing pad.
        for(double x = -5; x < 5; x = x + .01)
        {
            ggbAPI.evalCommand("(" + x + "," + x + ")");
        }//end for.
        */

    }//end main.
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/0000755000175000017500000000000011722677373025005 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/AlgebraicFunctionIntegrationRules.m0000644000175000017500000016551711446257035033770 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Algebraic Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*(c (a + b x)^n)^m		Powers of powers of linear binomials*)


(* ::Item::Closed:: *)
(*Derivation: Reciprocal rule for integration*)


(* ::Item:: *)
(*Basis: D[(a*f[x]^n)^m/f[x]^(m*n),x] == 0*)


Int[(c_.*(a_.+b_.*x_)^n_.)^m_,x_Symbol] :=
  (a+b*x)*(c*(a+b*x)^n)^m*Log[a+b*x]/b /;
FreeQ[{a,b,c,m,n},x] && ZeroQ[m*n+1]


(* ::Item::Closed:: *)
(*Derivation: Power rule for integration*)


(* ::Item:: *)
(*Basis: D[(a*f[x]^n)^m/f[x]^(m*n),x] == 0*)


Int[(c_.*(a_.+b_.*x_)^n_)^m_,x_Symbol] :=
  (a+b*x)*(c*(a+b*x)^n)^m/(b*(m*n+1)) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[m*n+1]


(* ::Subsection::Closed:: *)
(*u (a v^m w^n ...)^p		Distribute powers over powers and products*)


(* Note: The generalization of these rules when m*p is rational is in GeneralIntegrationRules.m *)


(* ::Item:: *)
(*Basis: D[(a*f[x]^n)^m/f[x]^(m*n),x] == 0*)


Int[u_.*(a_.*v_^m_)^p_, x_Symbol] :=
  Module[{q=FractionalPart[p]},
  a^(p-q)*(a*v^m)^q/v^(m*q)*Int[u*v^(m*p),x]] /;
FreeQ[{a,m,p},x] && IntegerQ[m*p]


(* ::Item:: *)
(*Basis: D[(a*f[x]^m*g[x]^n)^p/(f[x]^(m*p)*g[x]^(n*p)),x] == 0*)


Int[u_.*(a_.*v_^m_.*w_^n_.)^p_, x_Symbol] :=
  Module[{q=FractionalPart[p]},
  a^(p-q)*(a*v^m*w^n)^q/(v^(m*q)*w^(n*q))*Int[u*v^(m*p)*w^(n*p),x]] /;
FreeQ[{a,m,n,p},x] && IntegerQ[m*p] && IntegerQ[n*p]


(* ::Subsection::Closed:: *)
(*a x^m + b x^n + \[CenterEllipsis]		Integrands involving sums of monomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*z^m+b*z^n == z^m*(a+b*z^(n-m))*)


(* ::Item:: *)
(*Note : Way kool rule!  If m*(p+1)-n+1=0, then rule for x^(n-1)*(a+b*x^n)^p will fire.*)


Int[(a_.*x_^m_.+b_.*x_^n_.)^p_,x_Symbol] :=
  Int[x^(m*p)*(a+b*x^(n-m))^p,x] /;
FreeQ[{a,b,m,n},x] && IntegerQ[p] && ZeroQ[m*(p+1)-n+1] && Not[IntegerQ[{m,n}]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*z^m+b*z^n == z^m*(a+b*z^(n-m))*)


(* ::Item:: *)
(*Note : Way kool rule!  If m*(p+1)-n+1=0, then rule for x^(n-1)*(a+b*x^n)^p will fire.*)


Int[(a_.*x_^m_.+b_.*x_^n_.)^p_,x_Symbol] :=
  Int[(x^m*(a+b*x^(n-m)))^p,x] /;
FreeQ[{a,b,m,n},x] && FractionQ[p] && ZeroQ[m*(p+1)-n+1]


(* Int[(a_.*x_^m_.+b_.*x_^n_.)^p_,x_Symbol] :=
  Int[(x^m*(a+b*x^(n-m)))^p,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<=n && HalfIntegerQ[p] && ZeroQ[m*(p+1)-n+1] *)


(* Int[(a_.*x_^m_.+b_.*x_^n_.)^p_,x_Symbol] :=
  Int[(x^m*(a+b*x^(n-m)))^p,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<=n && HalfIntegerQ[p] && Not[2*m==n==2] *)


Int[(a_.*x_^m_.+b_.*x_^n_.+c_.*x_^q_.)^p_,x_Symbol] :=
  Int[(x^m*(a+b*x^(n-m)+c*x^(q-m)))^p,x] /;
FreeQ[{a,b,c},x] && IntegerQ[{m,n,q}] && FractionQ[p] && m<=n<=q


Int[u_.*x_^m_./(a_.*x_^n_.+b_.*x_^p_),x_Symbol] :=
  Int[u*x^(m-n)/(a+b*x^(p-n)),x] /;
FreeQ[{a,b},x] && FractionQ[{m,n,p}] && 0 Int[x^m*u+x^m*v+\[CenterEllipsis],x] *)


If[ShowSteps,
Int[x_^m_.*u_,x_Symbol] :=
  ShowStep["","Int[x^m*(u+v+\[CenterEllipsis]),x]","Int[x^m*u+x^m*v+\[CenterEllipsis],x]",Hold[
  Int[Map[Function[x^m*#],u],x]]] /;
SimplifyFlag && FreeQ[m,x] && SumQ[u],

Int[x_^m_.*u_,x_Symbol] :=
  Int[Map[Function[x^m*#],u],x] /;
FreeQ[m,x] && SumQ[u]]


(* ::Subsection::Closed:: *)
(*(a+b x^n)^p / x		Quotients of powers of binomials by integation variable*)


(* ::Item:: *)
(*Reference: CRC 276b*)


Int[1/(x_*Sqrt[a_+b_.*x_^n_.]),x_Symbol] :=
  -2*ArcTanh[Sqrt[a+b*x^n]/Rt[a,2]]/(n*Rt[a,2]) /;
FreeQ[{a,b,n},x] && PosQ[a]


(* ::Item:: *)
(*Reference: CRC 277*)


Int[1/(x_*Sqrt[a_+b_.*x_^n_.]),x_Symbol] :=
  2*ArcTan[Sqrt[a+b*x^n]/Rt[-a,2]]/(n*Rt[-a,2]) /;
FreeQ[{a,b,n},x] && NegQ[a]


(* ::Item:: *)
(*Reference: G&R 2.110.1, CRC 88b*)


Int[(a_+b_.*x_^n_.)^p_/x_,x_Symbol] :=
  (a+b*x^n)^p/(n*p) +
  Dist[a,Int[(a+b*x^n)^(p-1)/x,x]] /;
FreeQ[{a,b,n},x] && FractionQ[p] && p>0


(* ::Item:: *)
(*Reference: G&R 2.110.2, CRC 88d*)


Int[(a_+b_.*x_^n_.)^p_/x_,x_Symbol] :=
  -(a+b*x^n)^(p+1)/(a*n*(p+1)) +
  Dist[1/a,Int[(a+b*x^n)^(p+1)/x,x]] /;
FreeQ[{a,b,n},x] && FractionQ[p] && p<-1


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[x^n]/x == (f[x^n]/x^n)*D[x^n,x]/n*)


(* Int[(a_+b_.*x_^n_)^p_/x_,x_Symbol] :=
  Subst[Int[(a+b*x)^p/x,x],x,x^n]/n /;
FreeQ[{a,b,n},x] && FractionQ[p] && -1=0, (a+z)^m*(c-z)^m == (a*c-(a-c)*z-z^2)^m*)


Int[u_.*(a_+b_.*x_)^m_*(c_+d_.*x_)^m_,x_Symbol] :=
  Int[u*(a*c+(a*d+b*c)*x+b*d*x^2)^m,x] /;
FreeQ[{a,b,c,d},x] && FractionQ[m] && ZeroQ[b+d] && PositiveQ[a+c]


(* ::Subsubsection::Closed:: *)
(*1 / ((a+b x) Sqrt[c+d x])	Reciprocals of products of linears and square-roots of linears*)


(* ::Item:: *)
(*Reference: G&R 2.246.1', CRC 147a', A&S 3.3.30'*)


Int[1/((a_.+b_.*x_)*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  -2*ArcTanh[Sqrt[c+d*x]/Rt[(b*c-a*d)/b,2]]/(b*Rt[(b*c-a*d)/b,2]) /;
FreeQ[{a,b,c,d},x] && PosQ[(b*c-a*d)/b]


(* ::Item:: *)
(*Reference: G&R 2.246.2, CRC 148, A&S 3.3.29*)


Int[1/((a_.+b_.*x_)*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  2*ArcTan[Sqrt[c+d*x]/Rt[(a*d-b*c)/b,2]]/(b*Rt[(a*d-b*c)/b,2]) /;
FreeQ[{a,b,c,d},x] && NegQ[(b*c-a*d)/b]


(* ::Subsubsection::Closed:: *)
(*1 / (Sqrt[a+b x] Sqrt[c+d x])	Reciprocal of products of square-roots of linears*)


Int[1/(Sqrt[a_+b_.*x_]*Sqrt[c_+b_.*x_]),x_Symbol] :=
  ArcCosh[b*x/a]/b /;
FreeQ[{a,b,c},x] && ZeroQ[a+c] && PositiveQ[a]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  2*Rt[b/d,2]*ArcSinh[Sqrt[a+b*x]/Rt[b/d,2]]/b /;
FreeQ[{a,b,c,d},x] && PosQ[b/d] && ZeroQ[a*d-b*c+b]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  2*Rt[-b/d,2]*ArcSin[Sqrt[a+b*x]/Rt[-b/d,2]]/b /;
FreeQ[{a,b,c,d},x] && NegQ[b/d] && ZeroQ[a*d-b*c+b]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  2*Rt[b/d,2]*ArcSinh[Rt[b/(a*d-b*c),2]*Sqrt[c+d*x]]/b /;
FreeQ[{a,b,c,d},x] && PosQ[b/d] && PositiveQ[(a*d-b*c)/d]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  -2*Rt[-b/d,2]*ArcSin[Rt[b/(b*c-a*d),2]*Sqrt[c+d*x]]/b /;
FreeQ[{a,b,c,d},x] && NegQ[b/d] && PositiveQ[(a*d-b*c)/d]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  2*Rt[d/b,2]*ArcTanh[Rt[d/b,2]*Sqrt[a+b*x]/Sqrt[c+d*x]]/d /;
FreeQ[{a,b,c,d},x] && PosQ[d/b] && NonzeroQ[a*d-b*c]


Int[1/(Sqrt[a_.+b_.*x_]*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  -2*Rt[-d/b,2]*ArcTan[Rt[-d/b,2]*Sqrt[a+b*x]/Sqrt[c+d*x]]/d /;
FreeQ[{a,b,c,d},x] && NegQ[d/b] && NonzeroQ[a*d-b*c]


(* ::Subsubsection::Closed:: *)
(*(a+b x)^m (c+d x)^n		Products of powers of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If b*c-a*d=0 and n is an integer, (a+b*x)^m*(c+d*x)^n == (d/b)^n*(a+b*x)^(m+n)*)


Int[(a_.+b_.*x_)^m_.*(c_.+d_.*x_)^n_.,x_Symbol] :=
  Dist[(d/b)^n,Int[(a+b*x)^(m+n),x]] /;
FreeQ[{a,b,c,d,m},x] && IntegerQ[n] && ZeroQ[b*c-a*d] && Not[IntegerQ[m]]


Int[(a_.+b_.*x_)^m_*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)^(m+1)*(c+d*x)^n*Log[a+b*x]/b /;
FreeQ[{a,b,c,d,m,n},x] && Not[IntegerQ[m]] && Not[IntegerQ[n]] && ZeroQ[b*c-a*d] && ZeroQ[m+n+1] && 
(LeafCount[a+b*x]0


(* ::Item:: *)
(*Reference: G&R 2.151, CRC 59b*)


(* Note: Experimental!!! *)
Int[(a_.+b_.*x_)^m_*(c_.+d_.*x_),x_Symbol] :=
  (a+b*x)^(m+1)*(c+d*x)/(b*(m+2)) +
  Dist[(b*c-a*d)/(b*(m+2)),Int[(a+b*x)^m,x]] /;
FreeQ[{a,b,c,d,m},x] && Not[IntegerQ[m]] && NonzeroQ[b*c-a*d]


(* ::Item:: *)
(* Reference: G&R 2.151, CRC 59b*)


Int[(a_.+b_.*x_)^m_*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)^(m+1)*(c+d*x)^n/(b*(m+n+1)) +
  Dist[n/(m+n+1)*(b*c-a*d)/b,Int[(a+b*x)^m*(c+d*x)^(n-1),x]] /;
FreeQ[{a,b,c,d,m},x] && NonzeroQ[b*c-a*d] && NonzeroQ[m+n+1] && RationalQ[n] && n>0 &&
Not[IntegerQ[m]] && (IntegerQ[n] || FractionQ[m] && (n<=m || -1<=m<0))


(* ::Item:: *)
(*Reference: G&R 2.155, CRC 59a*)


Int[(a_.+b_.*x_)^m_.*(c_.+d_.*x_)^n_,x_Symbol] :=
  -(a+b*x)^(m+1)*(c+d*x)^(n+1)/((n+1)*(b*c-a*d)) +
  Dist[(m+n+2)/(n+1)*b/(b*c-a*d),Int[(a+b*x)^m*(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d,m},x] && NonzeroQ[b*c-a*d] && RationalQ[n] && n<-1 && Not[IntegerQ[{m,n}]] &&
(Not[RationalQ[m]] || n>=m || -1<=m<0 (* || n+2<=2*(m+n+2)<0 *))


(* ::Item:: *)
(*Reference: G&R 2.155, CRC 59a*)


Int[(a_.+b_.*x_)^m_.*(c_.+d_.*x_)^n_,x_Symbol] :=
  -(a+b*x)^(m+1)*(c+d*x)^(n+1)/((n+1)*(b*c-a*d)) +
  Dist[(m+n+2)/(n+1)*b/(b*c-a*d),Int[(a+b*x)^m*(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d,m,n},x] && NonzeroQ[b*c-a*d] && NonzeroQ[n+1] && Not[RationalQ[n]] && 
RationalQ[m+n] && Simplify[m+n]<-1


(* ::Item:: *)
(*Reference: G&R 2.153.3, CRC 59c*)


Int[(a_.+b_.*x_)*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)*(c+d*x)^(n+1)/(d*(n+1)) -
  Dist[b/(d*(n+1)),Int[(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d,n},x] && Not[IntegerQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.153.3, CRC 59c*)


Int[(a_.+b_.*x_)^m_*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)^m*(c+d*x)^(n+1)/(d*(n+1)) -
  Dist[m/(n+1)*b/d,Int[(a+b*x)^(m-1)*(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[{m,n}] && Not[IntegerQ[{m,n}]] && m>0 && n<-1


Int[(a_.+b_.*x_)^m_/(c_+d_.*x_),x_Symbol] :=
  Module[{p=Denominator[m]},
  Dist[p,Subst[Int[x^(m*p+p-1)/(b*c-a*d+d*x^p),x],x,(a+b*x)^(1/p)]]] /;
FreeQ[{a,b,c,d},x] && FractionQ[m] && -10 && ZeroQ[a*d+b*c]


Int[(a_+b_.*x_)^n_*(c_+d_.*x_)^n_/x_,x_Symbol] :=
  (a+b*x)^n*(c+d*x)^n/(2*n) +
  Dist[(a*d+b*c)/2,Int[(a+b*x)^(n-1)*(c+d*x)^(n-1),x]] +
  Dist[a*c,Int[(a+b*x)^(n-1)*(c+d*x)^(n-1)/x,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>0 && NonzeroQ[a*d+b*c]


(* ::Item:: *)
(*Reference: G&R 2.268b, CRC 122*)


Int[(a_+b_.*x_)^n_*(c_+d_.*x_)^n_/x_,x_Symbol] :=
  -(a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*a*c*(n+1)) +
  Dist[1/(a*c),Int[(a+b*x)^(n+1)*(c+d*x)^(n+1)/x,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n<-1 && ZeroQ[a*d+b*c]


Int[(a_+b_.*x_)^n_*(c_+d_.*x_)^n_/x_,x_Symbol] :=
  -(a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*a*c*(n+1)) -
  Dist[(a*d+b*c)/(2*a*c),Int[(a+b*x)^n*(c+d*x)^n,x]] +
  Dist[1/(a*c),Int[(a+b*x)^(n+1)*(c+d*x)^(n+1)/x,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n<-1 && NonzeroQ[a*d+b*c]


(* ::Item:: *)
(*Reference: G&R 2.174.2*)


Int[x_^m_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  x^(m-1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*b*d*(n+1)) +
  Dist[1/(b*d),Int[x^(m-2)*(a+b*x)^(n+1)*(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && m+2*n+1==0 && m>1 && ZeroQ[a*d+b*c]


Int[x_^m_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  x^(m-1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*b*d*(n+1)) -
  Dist[(a*d+b*c)/(2*b*d),Int[x^(m-1)*(a+b*x)^n*(c+d*x)^n,x]] +
  Dist[1/(b*d),Int[x^(m-2)*(a+b*x)^(n+1)*(c+d*x)^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && m+2*n+1==0 && m>1 && NonzeroQ[a*d+b*c]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[x_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*b*d*(n+1)) /;
FreeQ[{a,b,c,d,n},x] && NonzeroQ[n+1] && ZeroQ[a*d+b*c]


Int[x_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  (a+b*x)^(n+1)*(c+d*x)^(n+1)/(2*b*d*(n+1)) -
  Dist[(a*d+b*c)/(2*b*d),Int[(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n]


Int[x_^m_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  x^(m-1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(b*d*(m+2*n+1)) -
  Dist[a*c*(m-1)/(b*d*(m+2*n+1)),Int[x^(m-2)*(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && NonzeroQ[m+2*n+1] && m>1 && (ZeroQ[m+n] || ZeroQ[a*d+b*c])


Int[x_^m_*(a_.+b_.*x_)^n_*(c_.+d_.*x_)^n_,x_Symbol] :=
  x^(m-1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(b*d*(m+2*n+1)) -
  Dist[(m+n)*(a*d+b*c)/(b*d*(m+2*n+1)),Int[x^(m-1)*(a+b*x)^n*(c+d*x)^n,x]] -
  Dist[a*c*(m-1)/(b*d*(m+2*n+1)),Int[x^(m-2)*(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && NonzeroQ[m+2*n+1] && m>1


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


Int[x_^m_*(a_+b_.*x_)^n_*(c_+d_.*x_)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(a*c*(m+1)) /;
FreeQ[{a,b,c,d,n},x] && NonzeroQ[m+1] && ZeroQ[m+2*n+3] && ZeroQ[a*d+b*c]


Int[x_^m_*(a_+b_.*x_)^n_*(c_+d_.*x_)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(a*c*(m+1)) -
  Dist[(m+n+2)/(m+1)*((a*d+b*c)/(a*c)),Int[x^(m+1)*(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && m<-1 && ZeroQ[m+2*n+3]


Int[x_^m_*(a_+b_.*x_)^n_*(c_+d_.*x_)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(a*c*(m+1)) -
  Dist[(m+2*n+3)/(m+1)*(b*d/(a*c)),Int[x^(m+2)*(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && m<-1 && (ZeroQ[m+n+2] || ZeroQ[a*d+b*c])


Int[x_^m_*(a_+b_.*x_)^n_*(c_+d_.*x_)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x)^(n+1)*(c+d*x)^(n+1)/(a*c*(m+1)) -
  Dist[(m+n+2)/(m+1)*((a*d+b*c)/(a*c)),Int[x^(m+1)*(a+b*x)^n*(c+d*x)^n,x]] -
  Dist[(m+2*n+3)/(m+1)*(b*d/(a*c)),Int[x^(m+2)*(a+b*x)^n*(c+d*x)^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && RationalQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x)^n (c+d x)^p	Products of monomials and different powers of two linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (a+b*x)^n/x == b*(a+b*x)^(n-1) + a*(a+b*x)^(n-1)/x*)


Int[(a_+b_.*x_)^n_*(c_+d_.*x_)^p_/x_,x_Symbol] :=
  Dist[b,Int[(a+b*x)^(n-1)*(c+d*x)^p,x]] +
  Dist[a,Int[(a+b*x)^(n-1)*(c+d*x)^p/x,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[{n,p}] && n>0 && IntegerQ[n-p]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (a+b*x)^n/x == (a+b*x)^(n+1)/(a*x) - b/a*(a+b*x)^n*)


Int[(a_+b_.*x_)^n_*(c_+d_.*x_)^p_/x_,x_Symbol] :=
  Dist[1/a,Int[(a+b*x)^(n+1)*(c+d*x)^p/x,x]] -
  Dist[b/a,Int[(a+b*x)^n*(c+d*x)^p,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[{n,p}] && n<-1 && IntegerQ[n-p]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: x^m*(a+b*x)^n == x^(m-1)*(a+b*x)^(n+1)/b - a*x^(m-1)*(a+b*x)^n/b*)


(* ::Item:: *)
(*Basis: If m>=0 is an integer, x^m == 1/b^m*Sum[(-a)^(m-k)*Binomial[m,m-k]*(a+b*x)^k, {k,0,m}]*)


Int[x_^m_.*(a_+b_.*x_)^n_*(c_.+d_.*x_)^p_.,x_Symbol] :=
  Sum[Dist[(-a)^(m-k)/b^m*Binomial[m,m-k],Int[(a+b*x)^(n+k)*(c+d*x)^p,x]],{k,0,m}] /;
FreeQ[{a,b,c,d,n,p},x] && IntegerQ[{m,p-n}] && m>0 && Not[IntegerQ[n]] && p-n<0 &&
(m>3 || n=!=-1/2)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: x^m*(a+b*x)^n == x^(m-1)*(a+b*x)^(n+1)/b - a*x^(m-1)*(a+b*x)^n/b*)


(* ::Item:: *)
(*Basis: If m and p-n are integers and 00 and p-n>0 are integers, (a+b*x)^n*(c+d*x)^p/x^m == *)
(*	(-b)^m*Sum[1/a^(m+k)*Binomial[k+m-1,m-1]*(a+b*x)^(n+k)*(c+d*x)^p, {k,0,p-n-1}] + *)
(*	1/a^(p-n)*Sum[(-b/a)^k*Binomial[p-n+k-1,p-n-1]*(a+b*x)^p*(c+d*x)^p/x^(m-k), {k,0,m-1}]*)


Int[x_^m_.*(a_+b_.*x_)^n_*(c_.+d_.*x_)^p_,x_Symbol] :=
  Sum[Dist[a^(m-k)/(-b)^m*Binomial[k-m-1,-m-1],Int[(a+b*x)^(n+k)*(c+d*x)^p,x]], {k,0,p-n-1}] + 
  Sum[Dist[(-b/a)^k/a^(p-n)*Binomial[p-n+k-1,p-n-1],Int[x^(m+k)*(a+b*x)^p*(c+d*x)^p,x]], {k,0,-m-1}] /;
FreeQ[{a,b,c,d,n,p},x] && IntegerQ[{m,p-n}] && m<0 && p-n>0 && Not[IntegerQ[n]]


(* ::Subsubsection::Closed:: *)
(*x^m (e (a+b x)^p+f (c+d x)^q)^n	Products of expn and powers of sums of square-roots of linears*)


(* ::Item:: *)
(*Basis: r^p*(v*r^q + w) == v*r^(p+q) + w*r^p*)


(* Int[u_.*r_^p_*(v_.*r_^q_+w_),x_Symbol] :=
  Int[u*v*r^(p+q),x] + Int[u*w*r^p,x] /;
HalfIntegerQ[{p,q}] *)


(* Int[u_.*(a_*r_^p_+s_.)*(b_*r_^q_+t_.),x_Symbol] :=
  Dist[a*b,Int[u*r^(p+q),x]] + Int[u*(a*t*r^p+b*s*r^q+s*t),x] /;
FreeQ[{a,b},x] && HalfIntegerQ[{p,q}] *)


(* Int[(e_.*(a_.+b_.*x_)^p_+f_.*(c_.+d_.*x_)^q_)^n_,x_Symbol] :=
  Int[Expand[(e*(a+b*x)^p+f*(c+d*x)^q)^n],x] /;
FreeQ[{a,b,c,d,e,f},x] && IntegerQ[n] && n>0 && HalfIntegerQ[{p,q}] *)


(* Int[x_^m_.*(e_.*(a_.+b_.*x_)^p_+f_.*(c_.+d_.*x_)^q_)^n_,x_Symbol] :=
  Int[Expand[x^m*(e*(a+b*x)^p+f*(c+d*x)^q)^n],x] /;
FreeQ[{a,b,c,d,e,f,m},x] && IntegerQ[n] && n>0 && HalfIntegerQ[{p,q}] *)


(* ::Subsection::Closed:: *)
(*(a + b x^n)^p			Powers of binomials*)


(* ::Subsubsection::Closed:: *)
(*1 / (a+b x^n)				Reciprocals of binomials*)


Int[1/(a_+b_.*(x_^m_)^n_),x_Symbol] :=
  Rt[b/a,2]*x*ArcTan[Rt[b/a,2]*(x^m)^(1/m)]/(b*(x^m)^(1/m)) /;
FreeQ[{a,b,m,n},x] && m*n===2 && PosQ[a/b]


Int[1/(a_+b_.*(x_^m_)^n_),x_Symbol] :=
  -Rt[-b/a,2]*x*ArcTanh[Rt[-b/a,2]*(x^m)^(1/m)]/(b*(x^m)^(1/m)) /;
FreeQ[{a,b,m,n},x] && m*n===2 && NegQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*z^n) == 1/a - b/(a*(b+a/z^n))*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  x/a - Dist[b/a,Int[1/(b+a*x^(-n)),x]] /;
FreeQ[{a,b},x] && FractionQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*1 / Sqrt[a+b x^n]			Reciprocals of square-root of binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 278*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ArcSinh'[z] == 1/Sqrt[1+z^2]*)


Int[1/Sqrt[a_+b_.*x_^2],x_Symbol] :=
  ArcSinh[Rt[b,2]*x/Sqrt[a]]/Rt[b,2] /;
FreeQ[{a,b},x] && PositiveQ[a] && PosQ[b]


(* ::Item::Closed:: *)
(*Reference: CRC 279, A&S 3.3.44*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ArcSin'[z] == 1/Sqrt[1-z^2]*)


Int[1/Sqrt[a_+b_.*x_^2],x_Symbol] :=
  ArcSin[Rt[-b,2]*x/Sqrt[a]]/Rt[-b,2] /;
FreeQ[{a,b},x] && PositiveQ[a] && NegQ[b]


(* ::Item:: *)
(*Reference: CRC 278'*)


Int[1/Sqrt[a_+b_.*x_^2],x_Symbol] :=
  ArcTanh[Sqrt[a+b*x^2]/(Rt[b,2]*x)]/Rt[b,2] /;
FreeQ[{a,b},x] && Not[PositiveQ[a]] && PosQ[b]


(* ::Item:: *)
(*Reference: CRC 279'*)


Int[1/Sqrt[a_+b_.*x_^2],x_Symbol] :=
  -ArcTan[Sqrt[a+b*x^2]/(Rt[-b,2]*x)]/Rt[-b,2] /;
FreeQ[{a,b},x] && Not[PositiveQ[a]] && NegQ[b]


Int[1/Sqrt[a_+b_.*x_^4],x_Symbol] :=
  EllipticF[ArcSin[Rt[-b/a,4]*x],-1]/(Rt[-b/a,4]*Sqrt[a]) /;
FreeQ[{a,b},x] && PositiveQ[a]


Int[1/Sqrt[a_+b_.*x_^4],x_Symbol] :=
  Sqrt[(a+b*x^4)/a]*EllipticF[ArcSin[Rt[-b/a,4]*x],-1]/(Rt[-b/a,4]*Sqrt[a+b*x^4]) /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*(a+b x^n)^p				Powers of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Sqrt[a+b/z^2] == -Sqrt[a+b*(1/z)^2]/(1/z)^2*D[1/z,z]*)


Int[Sqrt[a_.+b_./x_^2],x_Symbol] :=
  -Subst[Int[Sqrt[a+b*x^2]/x^2,x],x,1/x] /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Reference: G&R 2.110.2', CRC 88d'*)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x*(a+b*x^n)^(p+1)/a /;
FreeQ[{a,b,n,p},x] && ZeroQ[n*(p+1)+1]


(* ::Item:: *)
(*Reference: G&R 2.110.1, CRC 88b*)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x*(a+b*x^n)^p/(n*p+1) +
  Dist[n*p*a/(n*p+1),Int[(a+b*x^n)^(p-1),x]] /;
FreeQ[{a,b,n},x] && FractionQ[p] && p>0 && NonzeroQ[n*p+1]


(* ::Item:: *)
(*Reference: G&R 2.110.2, CRC 88d*)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  -x*(a+b*x^n)^(p+1)/(n*(p+1)*a) +
  Dist[(n*(p+1)+1)/(n*(p+1)*a),Int[(a+b*x^n)^(p+1),x]] /;
FreeQ[{a,b,n},x] && FractionQ[p] && p<-1


(* ::Item:: *)
(*Reference: G&R 2.110.6, CRC 88c*)


Int[(a_+b_./x_)^p_,x_Symbol] :=
  x*(a+b/x)^(p+1)/a +
  Dist[b*p/a,Int[(a+b/x)^p/x,x]] /;
FreeQ[{a,b,p},x] && Not[IntegerQ[p]]
(* Transforms fractional power p of binomial into an integer *)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  Module[{q=Denominator[p]},
  Dist[q*a^(p+1/n)/n,
	Subst[Int[x^(q/n-1)/(1-b*x^q)^(p+1/n+1),x],x,x^(n/q)/(a+b*x^n)^(1/q)]]] /;
FreeQ[{a,b},x] && RationalQ[{p,n}] && -11 is integer*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n/(m+1) is an integer, x^n == (x^(m+1))^(n/(m+1))*)


Int[x_^m_.*(a_.+b_.*x_^n_)^p_.,x_Symbol] :=
  Dist[1/(m+1),Subst[Int[(a+b*x^(n/(m+1)))^p,x],x,x^(m+1)]] /;
FreeQ[{a,b,m,n,p},x] && NonzeroQ[m+1] && IntegerQ[n/(m+1)] && n/(m+1)>1 && Not[IntegerQ[{m,n,p}]]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^n)^p			Products of monomials and powers of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If p is an integer, (a+b*x^n)^p == x^(n*p)*(b+a/x^n)^p*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  Int[x^(m+n*p)*(b+a/x^n)^p,x] /;
FreeQ[{a,b,m},x] && FractionQ[n] && n<0 && IntegerQ[p] && p<0


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.3*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x^(m+1)*(a+b*x^n)^p/(m+1) -
  Dist[b*n*p/(m+1),Int[x^(m+n)*(a+b*x^n)^(p-1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && FractionQ[p] && p>0 && (n>0 && m<-1 || 0<-n<=m+1)


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.4*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*(a+b*x^n)^p == x^(m-n+1)*((a+b*x^n)^p*x^(n-1))*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x^(m-n+1)*(a+b*x^n)^(p+1)/(b*n*(p+1)) -
  Dist[(m-n+1)/(b*n*(p+1)),Int[x^(m-n)*(a+b*x^n)^(p+1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && FractionQ[p] && (00 &&
Not[IntegerQ[(m+1)/n] && (m+1)/n>0]


(* ::Item:: *)
(*Reference: G&R 2.110.2, CRC 88d*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  -x^(m+1)*(a+b*x^n)^(p+1)/(a*n*(p+1)) +
  Dist[(m+n*(p+1)+1)/(a*n*(p+1)),Int[x^m*(a+b*x^n)^(p+1),x]] /;
FreeQ[{a,b,m,n},x] && FractionQ[p] && p<-1 && NonzeroQ[m+n*(p+1)+1] && NonzeroQ[m-n+1]


(* ::Item:: *)
(*Reference: G&R 2.110.5, CRC 88a*)


Int[x_^m_.*(a_+b_.*x_^n_.)^p_,x_Symbol] :=
  x^(m-n+1)*(a+b*x^n)^(p+1)/(b*(m+n*p+1)) -
  Dist[a*(m-n+1)/(b*(m+n*p+1)),Int[x^(m-n)*(a+b*x^n)^p,x]] /;
FreeQ[{a,b,m,n,p},x] && NonzeroQ[m+n*p+1] && NonzeroQ[m-n+1] && NonzeroQ[m+1] &&
Not[IntegerQ[{m,n,p}]] && 
	(IntegerQ[{m,n}] && (0=1])


(* ::Item:: *)
(*Reference: G&R 2.110.6, CRC 88c*)


Int[x_^m_.*(a_+b_.*x_^n_.)^p_,x_Symbol] :=
  x^(m+1)*(a+b*x^n)^(p+1)/(a*(m+1)) -
  Dist[b*(m+n*(p+1)+1)/(a*(m+1)),Int[x^(m+n)*(a+b*x^n)^p,x]] /;
FreeQ[{a,b,m,n,p},x] && NonzeroQ[m+1] && (* NonzeroQ[m+n*(p+1)+1] && *) Not[IntegerQ[{m,n,p}]] && 
	(IntegerQ[{m,n}] && (n>0 && m<-1 || 0<-n<=m+1) ||
     Not[RationalQ[m]] && RationalQ[m+n] ||
     RationalQ[n] && MatchQ[m,u_+q_ /; RationalQ[q] && (n>0 && q<0 || 0<-n<=q)] || 
     MatchQ[m,u_+q_*n /; RationalQ[q] && q<0]) 
(* Transforms fractional power p of binomial into an integer *)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  Module[{q=Denominator[p]},
  q*a^(p+(m+1)/n)/n*
	Subst[Int[x^(q*(m+1)/n-1)/(1-b*x^q)^(p+(m+1)/n+1),x],x,x^(n/q)/(a+b*x^n)^(1/q)]] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && -10 && q<=-1 && ZeroQ[a*d-b*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (a+b*z^n)/(c+d*z^n) == b/d + (a*d-b*c)/(d*(c+d*z^n))*)


Int[(a_.+b_.*x_^n_)^p_*(c_.+d_.*x_^n_)^q_.,x_Symbol] :=
  Dist[(a*d-b*c)/d,Int[(a+b*x^n)^(p-1)*(c+d*x^n)^q,x]] +
  Dist[b/d,Int[(a+b*x^n)^(p-1)*(c+d*x^n)^(q+1),x]] /;
FreeQ[{a,b,c,d,n},x] && RationalQ[{p,q}] && p>0 && q<=-1 && NonzeroQ[a*d-b*c] && 
IntegerQ[n] && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/((a+b*z^n)*(c+d*z^n)) == b/((b*c-a*d)*(a+b*z^n)) - d/((b*c-a*d)*(c+d*z^n))*)


Int[(a_.+b_.*x_^n_)^p_.*(c_.+d_.*x_^n_)^q_.,x_Symbol] :=
  Dist[b/(b*c-a*d),Int[(a+b*x^n)^p*(c+d*x^n)^(q+1),x]] -
  Dist[d/(b*c-a*d),Int[(a+b*x^n)^(p+1)*(c+d*x^n)^q,x]] /;
FreeQ[{a,b,c,d,n},x] && RationalQ[{p,q}] && p<-1 && q<=-1 && NonzeroQ[b*c-a*d] && 
IntegerQ[n] && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If b*c-a*d==0, (a+b*z^n)*(c+d*z^n) == d/b*(a+b*z^n)^2*)


(* Int[u_.*(a_+b_.*x_^n_.)^p_*(c_+d_.*x_^n_.)^q_,x_Symbol] :=
  Dist[(d/b)^q,Int[u*(a+b*x^n)^(p+q),x]] /;
FreeQ[{a,b,c,d,n,p},x] && IntegerQ[q] && ZeroQ[b*c-a*d] *)


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^2)^n (c+d x^2)^p		Products of monomials and powers of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: z/Sqrt[a+b*z] == Sqrt[a+b*z]/b - a/(b*Sqrt[a+b*z])*)


Int[x_^2/(Sqrt[a_+b_.*x_^2]*Sqrt[c_+d_.*x_^2]),x_Symbol] :=
  Dist[1/b,Int[Sqrt[a+b*x^2]/Sqrt[c+d*x^2],x]] -
  Dist[a/b,Int[1/(Sqrt[a+b*x^2]*Sqrt[c+d*x^2]),x]] /;
FreeQ[{a,b,c,d},x]


Int[x_^2*Sqrt[a_+b_.*x_^2]/Sqrt[c_+d_.*x_^2],x_Symbol] :=
  x*Sqrt[a+b*x^2]*Sqrt[c+d*x^2]/(3*d) -
  Dist[1/(3*d),Int[(a*c+(2*b*c-a*d)*x^2)/(Sqrt[a+b*x^2]*Sqrt[c+d*x^2]),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^n) / (c+d x^p)		Products of monomials and quotients of binomials*)


Int[(a_.+b_.*x_^n_.)/(x_*(c_+d_.*x_^p_.)),x_Symbol] :=
  a*Log[x]/c+
  Dist[1/c,Int[x^(n-1)*(b*c-a*d*x^(p-n))/(c+d*x^p),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[{n,p}] && 00. *)


Int[1/Sqrt[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  ArcSinh[(b+2*c*x)/(Sqrt[4*a-b^2/c]*Rt[c,2])]/Rt[c,2] /;
FreeQ[{a,b,c},x] && PositiveQ[4*a-b^2/c] && PosQ[c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.261.3', CRC 238', A&S 3.3.36'*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[ArcSin[x],x] == 1/Sqrt[1-x^2] *)


(* Note: Unlike in the references,this formulation of the rule is valid even if not c>0. *)
Int[1/Sqrt[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  -ArcSin[(b+2*c*x)/(Sqrt[4*a-b^2/c]*Rt[-c,2])]/Rt[-c,2] /;
FreeQ[{a,b,c},x] && PositiveQ[4*a-b^2/c] && NegQ[c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.261.1, CRC 237a, A&S 3.3.33*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


Int[1/Sqrt[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
(* ArcTanh[(b+2*c*x)/(2*Rt[c,2]*Sqrt[a+b*x+c*x^2])]/Rt[c,2] /; *)
  ArcTanh[(2*Rt[c,2]*Sqrt[a+b*x+c*x^2])/(b+2*c*x)]/Rt[c,2] /;
FreeQ[{a,b,c},x] && PosQ[c] && NonzeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: CRC 238'*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


Int[1/Sqrt[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
(* -ArcTan[(b+2*c*x)/(2*Rt[-c,2]*Sqrt[a+b*x+c*x^2])]/Rt[-c,2] /; *)
  ArcTan[(2*Rt[-c,2]*Sqrt[a+b*x+c*x^2])/(b+2*c*x)]/Rt[-c,2] /;
FreeQ[{a,b,c},x] && NegQ[c] && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*1 / ((d+e x) Sqrt[a+b x+c x^2])		Reciprocals of products of linears and square-roots of quadratic trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.266.7, CRC 260*)
(* Note: Unnecessary because this is a special case of the rule for when m+2*(n+1) is zero! *)


(* Int[1/((d_.+e_.*x_)*Sqrt[a_.+c_.*x_^2]),x_Symbol] :=
  Module[{q=c*d^2+a*e^2},
(*  e*Sqrt[a+c*x^2]/(c*d*(d+e*x)) /; *)
  (-d+e*x)/(d*e*Sqrt[a+c*x^2]) /;
 ZeroQ[q]] /;
FreeQ[{a,c,d,e},x] *)


(* ::Item:: *)
(*Reference: G&R 2.266.1', CRC 258'*)


Int[1/((d_.+e_.*x_)*Sqrt[a_.+c_.*x_^2]),x_Symbol] :=
  Module[{q=c*d^2+a*e^2},
(* -ArcTanh[(a*e-c*d*x)/(Rt[q,2]*Sqrt[a+c*x^2])]/Rt[q,2] /; *)
  -ArcTanh[(Rt[q,2]*Sqrt[a+c*x^2])/(a*e-c*d*x)]/Rt[q,2] /;
 PosQ[q]] /;
FreeQ[{a,c,d,e},x]


(* ::Item:: *)
(*Reference: G&R 2.266.3, CRC 259*)


Int[1/((d_.+e_.*x_)*Sqrt[a_.+c_.*x_^2]),x_Symbol] :=
  Module[{q=c*d^2+a*e^2},
(* ArcTan[(a*e-c*d*x)/(Rt[-q,2]*Sqrt[a+c*x^2])]/Rt[-q,2] /; *)
  -ArcTan[(Rt[-q,2]*Sqrt[a+c*x^2])/(a*e-c*d*x)]/Rt[-q,2] /;
 NegQ[q]] /;
FreeQ[{a,c,d,e},x]


(* ::Item:: *)
(*Reference: G&R 2.266.7, CRC 260*)


Int[1/((d_.+e_.*x_)*Sqrt[a_.+b_.*x_+c_.*x_^2]),x_Symbol] :=
  -2*e*Sqrt[a+b*x+c*x^2]/((b*e-2*c*d)*(d+e*x)) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[c*d^2-b*d*e+a*e^2]


(* ::Item:: *)
(*Reference: G&R 2.266.1', CRC 258'*)


Int[1/((d_.+e_.*x_)*Sqrt[a_.+b_.*x_+c_.*x_^2]),x_Symbol] :=
  Module[{q=c*d^2-b*d*e+a*e^2},
  -ArcTanh[(2*Rt[q,2]*Sqrt[a+b*x+c*x^2])/(2*a*e-b*d+(b*e-2*c*d)*x)]/Rt[q,2] /;
 PosQ[q]] /;
FreeQ[{a,b,c,d,e},x]


(* ::Item:: *)
(*Reference: G&R 2.266.3, CRC 259*)


Int[1/((d_.+e_.*x_)*Sqrt[a_.+b_.*x_+c_.*x_^2]),x_Symbol] :=
  Module[{q=c*d^2-b*d*e+a*e^2},
  -ArcTan[(2*Rt[-q,2]*Sqrt[a+b*x+c*x^2])/(2*a*e-b*d+(b*e-2*c*d)*x)]/Rt[-q,2] /;
 NegQ[q]] /;
FreeQ[{a,b,c,d,e},x]


(* ::Subsubsection::Closed:: *)
(*(a+b x+c x^2)^n			Powers of quadratic trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.260.2, CRC 245, A&S 3.3.37*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  (b+2*c*x)*(a+b*x+c*x^2)^n/(2*c*(2*n+1)) -
  Dist[n*(b^2-4*a*c)/(2*c*(2*n+1)),Int[(a+b*x+c*x^2)^(n-1),x]] /;
FreeQ[{a,b,c},x] && FractionQ[n] && n>0


(* ::Subsubsection::Closed:: *)
(*x^m / (a+b x+c x^2)			Quotients of monomials by quadratic trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[x_^m_/(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  x^(m-1)/(c*(m-1))-
  Dist[1/c,Int[x^(m-2)*(a+b*x)/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c},x] && FractionQ[m] && m>1


(* ::Item:: *)
(*Reference: G&R 2.265c*)


Int[x_^m_/(b_.*x_+c_.*x_^2),x_Symbol] :=
  x^m/(b*m)-
  Dist[c/b,Int[x^(m+1)/(b*x+c*x^2),x]] /;
FreeQ[{b,c},x] && FractionQ[m] && m<-1


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


Int[x_^m_/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  x^(m+1)/(a*(m+1))-
  Dist[1/a,Int[x^(m+1)*(b+c*x)/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c},x] && FractionQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*x^m (d+e x) / (a+b x+c x^2)		Products of monomials and quotients of linears by quadratic trinomials*)


Int[x_^m_.*(d_+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*x^m/(c*m)-
  Dist[1/c,Int[x^(m-1)*(a*e+(b*e-c*d)*x)/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[m] && m>0


Int[x_^m_.*(d_+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  d*x^(m+1)/(a*(m+1))-
  Dist[1/a,Int[x^(m+1)*(b*d-a*e+c*d*x)/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*(a+b x+c x^2)^n / (d+e x)		Quotients of powers of quadratic trinomials by linears*)


(* ::Item:: *)
(*Reference: G&R 2.265b*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_/(d_.+e_.*x_),x_Symbol] :=
  (a+b*x+c*x^2)^n/(2*e*n) + 
  Dist[(b*e-2*c*d)/(2*e^2), Int[(a+b*x+c*x^2)^(n-1),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && n>0 && ZeroQ[c*d^2-b*d*e+a*e^2]


(* ::Item:: *)
(*Reference: G&R 2.265b*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_/(d_.+e_.*x_),x_Symbol] :=
  (a+b*x+c*x^2)^n/(2*e*n) + 
  Dist[(c*d^2-b*d*e+a*e^2)/e^2, Int[(a+b*x+c*x^2)^(n-1)/(d+e*x),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && n>0 && ZeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Reference: G&R 2.265b*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_/(d_.+e_.*x_),x_Symbol] :=
  (a+b*x+c*x^2)^n/(2*e*n) + 
  Dist[(b*e-2*c*d)/(2*e^2), Int[(a+b*x+c*x^2)^(n-1),x]] + 
  Dist[(c*d^2-b*d*e+a*e^2)/e^2, Int[(a+b*x+c*x^2)^(n-1)/(d+e*x),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && n>0


(* ::Item:: *)
(*Reference: G&R 2.268b, CRC 122*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_/(d_.+e_.*x_),x_Symbol] :=
  -e*(a+b*x+c*x^2)^(n+1)/(2*(n+1)*(c*d^2-b*d*e+a*e^2)) + 
  Dist[e^2/(c*d^2-b*d*e+a*e^2), Int[(a+b*x+c*x^2)^(n+1)/(d+e*x),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && n<-1 && NonzeroQ[c*d^2-b*d*e+a*e^2] && ZeroQ[2*c*d-b*e]


(* ::Item:: *)
(*Reference: G&R 2.268b, CRC 122*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_/(d_.+e_.*x_),x_Symbol] :=
  -e*(a+b*x+c*x^2)^(n+1)/(2*(n+1)*(c*d^2-b*d*e+a*e^2)) + 
  Dist[(2*c*d-b*e)/(2*(c*d^2-b*d*e+a*e^2)), Int[(a+b*x+c*x^2)^n,x]] + 
  Dist[e^2/(c*d^2-b*d*e+a*e^2), Int[(a+b*x+c*x^2)^(n+1)/(d+e*x),x]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && n<-1 && NonzeroQ[c*d^2-b*d*e+a*e^2]


(* ::Subsection::Closed:: *)
(*a + b x^2 + c x^4		Integrands involving symmetric quartic trinomials*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], then a+b*x^2+c*x^4 == a*(1+2*c*x^2/(b-q))*(1+2*c*x^2/(b+q))*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], then D[Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]/Sqrt[a+b*x^2+c*x^4], x] == 0*)


Int[1/Sqrt[a_+b_.*x_^2+c_.*x_^4],x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]/Sqrt[a+b*x^2+c*x^4]*Int[1/(Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]),x]] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], then a+b*x^2+c*x^4 == a*(1+2*c*x^2/(b-q))*(1+2*c*x^2/(b+q))*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], then D[Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]/Sqrt[a+b*x^2+c*x^4], x] == 0*)


Int[x_^2/Sqrt[a_+b_.*x_^2+c_.*x_^4],x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]/Sqrt[a+b*x^2+c*x^4]*Int[x^2/(Sqrt[1+2*c*x^2/(b-q)]*Sqrt[1+2*c*x^2/(b+q)]),x]] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Subsection::Closed:: *)
(*a + b x^k + c x^(2k)		Integrands involving symmetric trinomials*)


(* ::Subsubsection::Closed:: *)
(*(a + b x^2)/(c + d x^2 + e x^4)		Quotients of binomials by quartic trinomials*)


(* ::ItemParagraph:: *)
(*Previously undiscovered rules ??? *)


Int[(a_+b_.*x_^k_)/(c_+d_.*x_^2+e_.*x_^k_+f_.*x_^j_), x_Symbol] :=
  a/Rt[c*d,2]*ArcTan[(k-1)*a*Rt[c*d,2]*x/(c*((k-1)*a-b*x^k))] /;
FreeQ[{a,b,c,d,e,f,j,k},x] && Not[IntegerQ[k]] && j===2*k && ZeroQ[(k-1)^2*a^2*f-b^2*c] && ZeroQ[b*e+2*(k-1)*a*f] &&
PosQ[c*d]


Int[(a_+b_.*x_^k_)/(c_+d_.*x_^2+e_.*x_^k_+f_.*x_^j_), x_Symbol] :=
  a/Rt[-c*d,2]*ArcTanh[(k-1)*a*Rt[-c*d,2]*x/(c*((k-1)*a-b*x^k))] /;
FreeQ[{a,b,c,d,e,f,j,k},x] && Not[IntegerQ[k]] && j===2*k && ZeroQ[(k-1)^2*a^2*f-b^2*c] && ZeroQ[b*e+2*(k-1)*a*f] &&
NegQ[c*d]


Int[x_^m_.*(a_+b_.*x_^n_.)/(c_+d_.*x_^k_.+e_.*x_^n_.+f_.*x_^j_), x_Symbol] :=
  a*ArcTan[(m-n+1)*a*Rt[c*d,2]*x^(m+1)/(c*((m-n+1)*a+(m+1)*b*x^n))]/((m+1)*Rt[c*d,2]) /;
FreeQ[{a,b,c,d,e,f,j,k,m,n},x] && ZeroQ[k-2*(m+1)] && ZeroQ[j-2*n] &&
ZeroQ[(m-n+1)^2*a^2*f-(m+1)^2*b^2*c] && ZeroQ[(m+1)*b*e-2*(m-n+1)*a*f] && PosQ[c*d]


Int[x_^m_.*(a_+b_.*x_^n_.)/(c_+d_.*x_^k_.+e_.*x_^n_.+f_.*x_^j_), x_Symbol] :=
  a*ArcTanh[(m-n+1)*a*Rt[-c*d,2]*x^(m+1)/(c*((m-n+1)*a+(m+1)*b*x^n))]/((m+1)*Rt[-c*d,2]) /;
FreeQ[{a,b,c,d,e,f,j,k,m,n},x] && ZeroQ[k-2*(m+1)] && ZeroQ[j-2*n] &&
ZeroQ[(m-n+1)^2*a^2*f-(m+1)^2*b^2*c] && ZeroQ[(m+1)*b*e-2*(m-n+1)*a*f] && NegQ[c*d]


(* ::Subsubsection::Closed:: *)
(*(a+b x^k+c x^(2k))^n			Powers of symmetric trinomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.161.1a'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*z+c*z^2) == 2*c/(q*(b-q+2*c*z)) - 2*c/(q*(b+q+2*c*z)) where q=Sqrt[b^2-4*a*c]*)


Int[1/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[2*c/q,Int[1/(b-q+2*c*x^k),x]] -
  Dist[2*c/q,Int[1/(b+q+2*c*x^k),x]]] /;
FreeQ[{a,b,c,j,k},x] && Not[IntegerQ[k]] && j===2*k && NonzeroQ[b^2-4*a*c] && Not[NegativeQ[b^2-4*a*c]]


(* ::Item:: *)
(*Reference: G&R 2.161.1b?*)


Int[1/(a_+b_.*x_^k_+c_.*x_^j_),x_Symbol] :=
  Module[{q=2*Rt[a/c,2]-b/c},
  Dist[1/(2*c*Rt[a/c,2]*Rt[q,2]),Int[(Rt[q,2]+x^(k/2))/(Rt[a/c,2]+Rt[q,2]*x^(k/2)+x^k),x]] +
  Dist[1/(2*c*Rt[a/c,2]*Rt[q,2]),Int[(Rt[q,2]-x^(k/2))/(Rt[a/c,2]-Rt[q,2]*x^(k/2)+x^k),x]] /;
 PosQ[q]] /;  
FreeQ[{a,b,c},x] && EvenQ[k] && k>0 && j===2*k && PosQ[a/c] && NegativeQ[b^2-4*a*c]


(* ::Item:: *)
(*Reference: G&R 2.161.5' (GR5 2.161.4 is a special case.)*)
(* Previously undiscovered rule ??? *)


Int[(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  -x*(b^2-2*a*c+b*c*x^k)*(a+b*x^k+c*x^j)^(n+1)/(k*a*(n+1)*(b^2-4*a*c)) +
  Dist[(k*(n+1)*(b^2-4*a*c)+b^2-2*a*c)/(k*a*(n+1)*(b^2-4*a*c)),Int[(a+b*x^k+c*x^j)^(n+1),x]] +
  Dist[(k*(2*n+3)+1)*b*c/(k*a*(n+1)*(b^2-4*a*c)),Int[x^k*(a+b*x^k+c*x^j)^(n+1),x]] /;
FreeQ[{a,b,c,j,k},x] && RationalQ[n] && Not[IntegerQ[k]] && j===2*k && n<-1 && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*1 / (x Sqrt[a+b x^k+c x^(2k)])		Reciprocals of products of x and square-roots of symmetric trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.266.7, CRC 260*)


Int[1/(x_*Sqrt[b_.*x_^k_.+c_.*x_^j_.]),x_Symbol] :=
  -2*Sqrt[b*x^k+c*x^j]/(b*k*x^k) /;
FreeQ[{b,c,j,k},x] && j===2*k


(* ::Item:: *)
(*Reference: G&R 2.266.1', CRC 258'*)


Int[1/(x_*Sqrt[a_+b_.*x_^k_.+c_.*x_^j_.]),x_Symbol] :=
  -ArcTanh[(2*a+b*x^k)/(2*Rt[a,2]*Sqrt[a+b*x^k+c*x^j])]/(k*Rt[a,2]) /;
FreeQ[{a,b,c,j,k},x] && j===2*k && PosQ[a]


(* ::Item:: *)
(*Reference: G&R 2.266.3, CRC 259*)


Int[1/(x_*Sqrt[a_+b_.*x_^k_.+c_.*x_^j_.]),x_Symbol] :=
  ArcTan[(2*a+b*x^k)/(2*Rt[-a,2]*Sqrt[a+b*x^k+c*x^j])]/(k*Rt[-a,2]) /;
FreeQ[{a,b,c,j,k},x] && j===2*k && NegQ[a]


(* ::Subsubsection::Closed:: *)
(*x^m / (a+b x^k+c x^(2k))		Quotients of monomials by symmetric trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.177.1', CRC 120'*)


(* Note: This rule does not use the obvious substitution u=x^k on the whole integrand reducing 
	it to 1/(x*(a+b*x+c*x^2)) so that Log[x] instead of Log[x^k] appears in the result *)
Int[1/(x_*(a_+b_.*x_^k_+c_.*x_^j_.)),x_Symbol] :=
(* Dist[1/a,Int[x^(k-1)*(b+c*x^k)/(a+b*x^k+c*x^j),x]] /; *)
  Log[x]/a -
  Dist[1/(a*k),Subst[Int[(b+c*x)/(a+b*x+c*x^2),x],x,x^k]] /;
FreeQ[{a,b,c,j,k},x] && Not[IntegerQ[k]] && j===2*k


(* ::Item::Closed:: *)
(*Reference: G&R 2.161.3'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: z/(a+b*z+c*z^2) == (1-b/q)/(b-q+2*c*z) + (1+b/q)/(b+q+2*c*z) where q=Sqrt[b^2-4*a*c]*)


Int[x_^k_/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[(1-b/q),Int[1/(b-q+2*c*x^k),x]] +
  Dist[(1+b/q),Int[1/(b+q+2*c*x^k),x]]] /;
FreeQ[{a,b,c,j,k},x] && Not[IntegerQ[k]] && j===2*k && NonzeroQ[b^2-4*a*c] && Not[NegativeQ[b^2-4*a*c]]


(* ::Item:: *)
(*Reference: G&R 2.174.1', CRC 119'*)


Int[x_^m_./(a_+b_.*x_^k_+c_.*x_^j_),x_Symbol] :=
  x^(m-j+1)/(c*(m-j+1)) - 
  Dist[1/c,Int[x^(m-j)*(a+b*x^k)/(a+b*x^k+c*x^j),x]] /;
FreeQ[{a,b,c,j,k},x] && Not[IntegerQ[k]] && j===2*k && RationalQ[{m,k}] && 00


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^k+c x^(2k))^n		Products of monomials and powers of symmetric trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.174.2'*)


(* Note: This should be generalized from quadratic to all symmetric trinomials! *)
Int[x_^m_*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  -x^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m-1)) - 
  Dist[b/(2*c),Int[x^(m-1)*(a+b*x+c*x^2)^n,x]] + 
  Dist[1/c,Int[x^(m-2)*(a+b*x+c*x^2)^(n+1),x]] /;
FreeQ[{a,b,c},x] && RationalQ[{m,n}] && n<-1 && ZeroQ[m+2*n+1] && Not[IntegerQ[{m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.4*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^n/(m+j*n+1) +
  Dist[a*j*n/(m+j*n+1),Int[x^m*(a+b*x^k+c*x^j)^(n-1),x]] +
  Dist[b*k*n/(m+j*n+1),Int[x^(m+k)*(a+b*x^k+c*x^j)^(n-1),x]] /;
FreeQ[{a,b,c},x] && RationalQ[{j,k,m,n}] && j==2*k && j>0 && m<-1 && n>1 && NonzeroQ[m+j*n+1] && 
Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.3'*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m-j+1)*(a+b*x^k+c*x^j)^(n+1)/(c*k*(n+1)) +
  Dist[a/c,Int[x^(m-j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c,n},x] && FractionQ[{j,k,m}] && j===2*k && 0=-1] && Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.3 (GR5 2.174.1 is a special case.)*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m-j+1)*(a+b*x^k+c*x^j)^(n+1)/(c*(m+j*n+1)) -
  Dist[b*(m+k*(n-1)+1)/(c*(m+j*n+1)),Int[x^(m-k)*(a+b*x^k+c*x^j)^n,x]] -
  Dist[a*(m-j+1)/(c*(m+j*n+1)),Int[x^(m-j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{j,k,m}] && j==2*k && 0=-1] && Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.1 special case*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^(n+1)/(a*(m+1)) +
  Dist[c/a,Int[x^(m+j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{j,k,m}] && j==2*k && j>0 && m<-1 && ZeroQ[m+1+k*(n+1)] &&
Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.1 special case*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^(n+1)/(a*(m+1)) -
  Dist[b/(2*a),Int[x^(m+k)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{j,k,m}] && j==2*k && j>0 && m<-1 && ZeroQ[m+1+j*(n+1)] &&
Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.2*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^n/(m+1) -
  Dist[b*k*n/(m+1),Int[x^(m+k)*(a+b*x^k+c*x^j)^(n-1),x]] -
  Dist[c*j*n/(m+1),Int[x^(m+j)*(a+b*x^k+c*x^j)^(n-1),x]] /;
FreeQ[{a,b,c},x] && RationalQ[{j,k,m,n}] && j==2*k && j>0 && m<-1 && n>1 &&
Not[IntegerQ[{j,k,m,n}]]


(* ::Item:: *)
(*Reference: G&R 2.160.1*)


(* ::Item:: *)
(*Note: G&R 2.161.6 is a special case*)


Int[x_^m_*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^(n+1)/(a*(m+1)) -
  Dist[b*(m+1+k*(n+1))/(a*(m+1)),Int[x^(m+k)*(a+b*x^k+c*x^j)^n,x]] -
  Dist[c*(m+1+j*(n+1))/(a*(m+1)),Int[x^(m+j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{j,k,m}] && j==2*k && j>0 && m<-1 && NonzeroQ[m+1+k*(n+1)] &&
NonzeroQ[m+1+j*(n+1)] && Not[RationalQ[n] && n>1] && Not[IntegerQ[{j,k,m,n}]]


(* Previously undiscovered rules ??? *)
Int[x_^k_.*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x*(b+2*c*x^k)*(a+b*x^k+c*x^j)^n/(2*c*(k*(2*n+1)+1)) - 
  Dist[b/(2*c*(k*(2*n+1)+1)),Int[(a+b*x^k+c*x^j)^n, x]] - 
  Dist[k*n*(b^2-4*a*c)/(2*c*(k*(2*n+1)+1)),Int[x^k*(a+b*x^k+c*x^j)^(n-1), x]] /;
FreeQ[{a,b,c,j,k},x] && RationalQ[n] && Not[IntegerQ[k]] && j===2*k && n>0 && NonzeroQ[b^2-4*a*c] &&
NonzeroQ[k*(2*n+1)+1]


Int[x_^k_.*(a_+b_.*x_^k_.+c_.*x_^j_.)^n_,x_Symbol] :=
  x*(b+2*c*x^k)*(a+b*x^k+c*x^j)^(n+1)/(k*(n+1)*(b^2-4*a*c)) - 
  Dist[b/(k*(n+1)*(b^2-4*a*c)),Int[(a+b*x^k+c*x^j)^(n+1),x]] -
  Dist[2*c*(k*(2*n+3)+1)/(k*(n+1)*(b^2-4*a*c)),Int[x^k*(a+b*x^k+c*x^j)^(n+1),x]] /;
FreeQ[{a,b,c,j,k},x] && RationalQ[n] && Not[IntegerQ[k]] && j===2*k && n<-1 && NonzeroQ[b^2-4*a*c]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* Note: Transforms quadratic trinomial into a quadratic binomial. *)
(* Int[x_^m_.*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  Subst[Int[Expand[(-b/(2*c)+x)^m*(a-b^2/(4*c)+c*x^2)^n],x],x,b/(2*c)+x] /;
FreeQ[{a,b,c},x] && IntegerQ[m] && m>0 && FractionQ[n] *)


(* ::Subsubsection::Closed:: *)
(*x^m (d+e x^k) / (a+b x^k+c x^(2k))	Products of monomials and quotients of binomials by symmetric trinomials*)


(* These way kool, and to my knowledge original, rules reduce the degree of monomial without
	increasing the complexity of the integrands. *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (d+e*z)/(a+b*z+c*z^2) == (e+(2*c*d-b*e)/q)/(b-q+2*c*z) + (e-(2*c*d-b*e)/q)/(b+q+2*c*z) where q=Sqrt[b^2-4*a*c]*)


(* Basis: (d+e*z)/(a+b*z+c*z^2) == (e+(2*c*d-b*e)/q)/(b-q+2*c*z) + (e-(2*c*d-b*e)/q)/(b+q+2*c*z)
	where q=Sqrt[b^2-4*a*c] *)


Int[(d_+e_.*x_^k_)/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[(e+(2*c*d-b*e)/q),Int[1/(b-q+2*c*x^k),x]] +
  Dist[(e-(2*c*d-b*e)/q),Int[1/(b+q+2*c*x^k),x]]] /;
FreeQ[{a,b,c,d,e,j,k},x] && Not[IntegerQ[k]] && j===2*k && NonzeroQ[b^2-4*a*c] && Not[NegativeQ[b^2-4*a*c]]


(* Note: This rule does not use the obvious substitution u=x^k on the whole integrand reducing 
	it to (d+e*x)/(x*(a+b*x+c*x^2)) so that Log[x] instead of Log[x^k] appears in the result *)
Int[(d_.+e_.*x_^k_)/(x_*(a_+b_.*x_^k_+c_.*x_^j_.)),x_Symbol] :=
(* Dist[1/a,Int[x^(k-1)*(b*d-a*e+c*d*x^k)/(a+b*x^k+c*x^j),x]] /; *)
  d*Log[x]/a -
    1/(a*k)*Subst[Int[(b*d-a*e+c*d*x)/(a+b*x+c*x^2),x],x,x^k] /;
FreeQ[{a,b,c,d,e,j,k},x] && Not[IntegerQ[k]] && j===2*k


Int[x_^m_.*(d_.+e_.*x_^k_)/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  e*x^(m-k+1)/(c*(m-k+1)) -
  Dist[1/c,Int[x^(m-k)*(a*e+(b*e-c*d)*x^k)/(a+b*x^k+c*x^j),x]] /;
FreeQ[{a,b,c,d,e,j,k},x] && Not[IntegerQ[k]] && j===2*k && RationalQ[{m,k}] && 00


(* ::Subsection::Closed:: *)
(*x^m ((a+b x)/(c+d x))^n	Products of monomials and powers of quotients of linears*)


(* Int[(e_.*(a_.+b_.*x_)/(c_.+d_.*x_))^n_,x_Symbol] :=
  Dist[e*(b*c-a*d),Subst[Int[x^n/(b*e-d*x)^2,x],x,e*(a+b*x)/(c+d*x)]] /;
FreeQ[{a,b,c,d,e},x] && FractionQ[n] && NonzeroQ[b*c-a*d] *)


(* Int[x_^m_.*(e_.*(a_.+b_.*x_)/(c_.+d_.*x_))^n_,x_Symbol] :=
  Dist[e*(b*c-a*d),Subst[Int[x^n*(-a*e+c*x)^m/(b*e-d*x)^(m+2),x],x,e*(a+b*x)/(c+d*x)]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[m] && FractionQ[n] && NonzeroQ[b*c-a*d] *)


(* Int[(f_+g_.*x_)^m_*(e_.*(a_.+b_.*x_)/(c_.+d_.*x_))^n_,x_Symbol] :=
  Dist[1/g,Subst[Int[x^m*(e*(a-b*f/g+b/g*x)/(c-d*f/g+d/g*x))^n,x],x,f+g*x]] /;
FreeQ[{a,b,c,d,e,f,g},x] && IntegerQ[m] && m<0 && FractionQ[n] && NonzeroQ[b*c-a*d] *)


(* ::Subsection::Closed:: *)
(*Sqrt[a x+Sqrt[b+a^2 x^2]]	Nested square roots*)


Int[Sqrt[a_.*x_+Sqrt[b_+c_.*x_^2]], x_Symbol] :=
  2*(2*a*x-Sqrt[b+c*x^2])*Sqrt[a*x+Sqrt[b+c*x^2]]/(3*a) /;
FreeQ[{a,b,c},x] && c===a^2


Int[Sqrt[a_.*x_-Sqrt[b_+c_.*x_^2]], x_Symbol] :=
  2*(2*a*x+Sqrt[b+c*x^2])*Sqrt[a*x-Sqrt[b+c*x^2]]/(3*a) /;
FreeQ[{a,b,c},x] && c===a^2


(* ::Subsection::Closed:: *)
(*Sqrt[a+Sqrt[a^2+b x^2]]	Nested square roots*)


Int[Sqrt[a_+Sqrt[c_+b_.*x_^2]], x_Symbol] :=
  2*Sqrt[a+Sqrt[a^2+b*x^2]]*(-a^2+b*x^2+a*Sqrt[a^2+b*x^2])/(3*b*x) /;
FreeQ[{a,b,c},x] && c===a^2


Int[Sqrt[a_-Sqrt[c_+b_.*x_^2]], x_Symbol] :=
  2*Sqrt[a-Sqrt[a^2+b*x^2]]*(-a^2+b*x^2-a*Sqrt[a^2+b*x^2])/(3*b*x) /;
FreeQ[{a,b,c},x] && c===a^2


(* ::Subsection::Closed:: *)
(*u / (v+Sqrt[w])		Rationalization of denominators*)


Int[u_./(a_.*x_^m_.+b_.*Sqrt[c_.*x_^n_]),x_Symbol] :=
  Int[u*(a*x^m-b*Sqrt[c*x^n])/(a^2*x^(2*m)-b^2*c*x^n),x] /;
FreeQ[{a,b,c,m,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If b*e^2=d*f^2, 1/(e*Sqrt[a+b*x^n]+f*Sqrt[c+d*x^n]) == (e*Sqrt[a+b*x^n]-f*Sqrt[c+d*x^n])/(a*e^2-c*f^2)*)


Int[u_.*(e_.*Sqrt[a_.+b_.*x_^n_.]+f_.*Sqrt[c_.+d_.*x_^n_.])^m_,x_Symbol] :=
  Dist[(a*e^2-c*f^2)^m,Int[u*(e*Sqrt[a+b*x^n]-f*Sqrt[c+d*x^n])^(-m),x]] /;
FreeQ[{a,b,c,d,e,f,n},x] && IntegerQ[m] && m<0 && ZeroQ[b*e^2-d*f^2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a*e^2=c*f^2, 1/(e*Sqrt[a+b*x^n]+f*Sqrt[c+d*x^n]) == (e*Sqrt[a+b*x^n]-f*Sqrt[c+d*x^n])/((b*e^2-d*f^2)*x^n)*)


Int[u_.*(e_.*Sqrt[a_.+b_.*x_^n_.]+f_.*Sqrt[c_.+d_.*x_^n_.])^m_,x_Symbol] :=
  Dist[(b*e^2-d*f^2)^m,Int[u*(e*Sqrt[a+b*x^n]-f*Sqrt[c+d*x^n])^(-m)*x^(m*n),x]] /;
FreeQ[{a,b,c,d,e,f,n},x] && IntegerQ[m] && m<0 && ZeroQ[a*e^2-c*f^2]


Int[u_./(a_+b_.*Sqrt[c_+d_.*x_^n_]),x_Symbol] :=
  Dist[-a/(b^2*d),Int[u/x^n,x]] +
  Dist[1/(b*d),Int[u*Sqrt[c+d*x^n]/x^n,x]] /;
FreeQ[{a,b,c,d,n},x] && a^2===b^2*c


Int[u_./(a_.*x_^m_.+b_.*Sqrt[c_+d_.*x_^n_]),x_Symbol] :=
  Dist[-a/(b^2*c),Int[u*x^m,x]] +
  Dist[1/(b*c),Int[u*Sqrt[c+d*x^n],x]] /;
FreeQ[{a,b,c,d,m,n},x] && n===2*m && a^2===b^2*d


Int[u_./(a_+b_.*x_^m_.+c_.*Sqrt[d_+e_.*x_^n_]),x_Symbol] :=
  Dist[1/(2*b),Int[u/x^m,x]] +
  Dist[1/(2*a),Int[u,x]] -
  Dist[c/(2*a*b),Int[u*Sqrt[d+e*x^n]/x^m,x]] /;
FreeQ[{a,b,c,d,m,n},x] && n===2*m && a^2===c^2*d && b^2===c^2*e


Int[u_./(a_+b_.*x_^m_.+c_.*Sqrt[d_+e_.*x_^n_]),x_Symbol] :=
  Dist[a/b^2,Int[u/x^(2*m),x]] +
  Dist[1/b,Int[u/x^m,x]] -
  Dist[c/b^2,Int[u*Sqrt[d+e*x^n]/x^(2*m),x]] /;
FreeQ[{a,b,c,d,m,n},x] && n===m && a^2===c^2*d && 2*a*b===c^2*e


(* Int[u_./(e_.*Sqrt[a_.+b_.*x_]+f_.*Sqrt[c_.+d_.*x_]),x_Symbol] :=
  Int[u*(e*Sqrt[a+b*x]-f*Sqrt[c+d*x])/(a*e^2-c*f^2+(b*e^2-d*f^2)*x),x] /;
FreeQ[{a,b,c,d,e,f},x] *)


Int[u_./(a_.*x_+b_.*Sqrt[c_.+d_.*x_^2]),x_Symbol] :=
  Dist[a,Int[x*u/(-b^2*c+(a^2-b^2*d)*x^2),x]] -
  Dist[b,Int[u*Sqrt[c+d*x^2]/(-b^2*c+(a^2-b^2*d)*x^2),x]] /;
FreeQ[{a,b,c,d},x]


Int[u_./(e_.*Sqrt[(a_.+b_.*x_^n_.)^p_.]+f_.*Sqrt[(a_.+b_.*x_^n_.)^q_.]),x_Symbol] :=
  Int[u*(e*Sqrt[(a+b*x^n)^p]-f*Sqrt[(a+b*x^n)^q])/(e^2*(a+b*x^n)^p-f^2*(a+b*x^n)^q),x] /;
FreeQ[{a,b,e,f},x] && IntegerQ[{n,p,q}]


(* Int[u_./(v_+a_.*Sqrt[w_]),x_Symbol] :=
  Int[u*v/(v^2-a^2*w),x] -
  Dist[a,Int[u*Sqrt[w]/(v^2-a^2*w),x]] /;
FreeQ[a,x] && PolynomialQ[v,x] *)


(* Int[u_./(a_.*x_+b_.*Sqrt[c_+d_.*x_]),x_Symbol] :=
  Int[(a*x*u-b*u*Sqrt[c+d*x])/(-b^2*c-b^2*d*x+a^2*x^2),x] /;
FreeQ[{a,b,c,d},x] *)


(* ::Subsection::Closed:: *)
(*u Sqrt[c+d x]/(a+b x)		Rationalization of numerator*)


Int[u_.*Sqrt[c_+d_.*x_^2]/(a_+b_.*x_),x_Symbol] :=
  a*Int[u/Sqrt[c+d*x^2],x] - 
  b*Int[x*u/Sqrt[c+d*x^2],x] /;
FreeQ[{a,b,c,d},x] && c===a^2 && d===-b^2


(* ::Subsection::Closed:: *)
(*Sqrt[a+b x^4]			Integrands involving square roots of quartic binomials*)


Int[Sqrt[b_.*x_^2+Sqrt[a_+c_.*x_^4]]/Sqrt[a_+c_.*x_^4],x_Symbol] :=
  ArcTanh[Rt[2*b,2]*x/Sqrt[b*x^2+Sqrt[a+c*x^4]]]/Rt[2*b,2] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-c] && PosQ[b]


Int[Sqrt[b_.*x_^2+Sqrt[a_+c_.*x_^4]]/Sqrt[a_+c_.*x_^4],x_Symbol] :=
  ArcTan[Rt[-2*b,2]*x/Sqrt[b*x^2+Sqrt[a+c*x^4]]]/Rt[-2*b,2] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-c] && NegQ[b]


(* ::Item::Closed:: *)
(*Author: Martin*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If a>0, Sqrt[a+z^2] == Sqrt[Sqrt[a]+I*z]*Sqrt[Sqrt[a]-I*z]*)


(* ::Item:: *)
(*Basis: If a>0, Sqrt[z+Sqrt[a+z^2]]/Sqrt[a+z^2] == (1-I)/(2*Sqrt[Sqrt[a]-I*z]) + (1+I)/(2*Sqrt[Sqrt[a]+I*z])*)


Int[u_.*Sqrt[v_+Sqrt[a_+w_]]/Sqrt[a_+w_],x_Symbol] :=
  Dist[(1-I)/2, Int[u/Sqrt[Sqrt[a]-I*v],x]] +
  Dist[(1+I)/2, Int[u/Sqrt[Sqrt[a]+I*v],x]] /;
FreeQ[a,x] && ZeroQ[w-v^2] && PositiveQ[a] && Not[LinearQ[v,x]]


(* ::Subsection::Closed:: *)
(*1 / (a+b f[c+d x])		Aggressively factor out constants to prevent them occurring in logarithms*)


(* Note: Constant factors in denominator are aggressively factored out to prevent them occurring
	unnecessarily in logarithm of antiderivative! *)
If[ShowSteps,

Int[1/(a_+b_.*u_),x_Symbol] :=
  Module[{lst=ConstantFactor[a+b*u,x]},
  ShowStep["","Int[1/(a*c+b*c*u),x]","c*Int[1/(a+b*u),x]",Hold[
  Dist[1/lst[[1]],Int[1/lst[[2]],x]]]] /;
 lst[[1]]=!=1] /;
SimplifyFlag && FreeQ[{a,b},x] && (
	MatchQ[u,f_^(c_.+d_.*x) /; FreeQ[{c,d,f},x]] ||
	MatchQ[u,f_[c_.+d_.*x] /; FreeQ[{c,d},x] && MemberQ[{Tan,Cot,Tanh,Coth},f]]),

Int[1/(a_+b_.*u_),x_Symbol] :=
  Module[{lst=ConstantFactor[a+b*u,x]},
  Dist[1/lst[[1]],Int[1/lst[[2]],x]] /;
 lst[[1]]=!=1] /;
FreeQ[{a,b},x] && (
	MatchQ[u,f_^(c_.+d_.*x) /; FreeQ[{c,d,f},x]] ||
	MatchQ[u,f_[c_.+d_.*x] /; FreeQ[{c,d},x] && MemberQ[{Tan,Cot,Tanh,Coth},f]])]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/TrigFunctionIntegrationRules.m0000644000175000017500000035420511446257035033016 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Trig Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Sine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x]^n				Powers of sines of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.5, CRC 290, A&S 4.3.113*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Cos'[z] == -Sin[z]*)


Int[Sin[a_.+b_.*x_],x_Symbol] :=
  -Cos[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.513.5, CRC 296*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[Sin[a_.+b_.*x_]^2,x_Symbol] :=
  x/2 - Cos[a+b*x]*Sin[a+b*x]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Sin[z]^n == -(1-Cos[z]^2)^((n-1)/2)*Cos'[z]*)


Int[Sin[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[(1-x^2)^((n-1)/2),x],x],x,Cos[a+b*x]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1


(* ::ItemParagraph::Closed:: *)
(**)


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 299*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sin[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*Cos[a+b*x]*(c*Sin[a+b*x])^(n-1)/(b*n) + 
  Dist[(n-1)*c^2/n,Int[(c*Sin[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[OddQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.3, CRC 309*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sin[a_.+b_.*x_])^n_,x_Symbol] :=
  Cos[a+b*x]*(c*Sin[a+b*x])^(n+1)/(c*b*(n+1)) + 
  Dist[(n+2)/((n+1)*c^2),Int[(c*Sin[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Sin[x])^n/Sin[x]^n,x] == 0*)


Int[(c_*Sin[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Sin[a+b*x])^n/Sin[a+b*x]^n*Int[Sin[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.555.1'*)


Int[(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Cos[c+d*x]*(a+b*Sin[c+d*x])^n/(a*d*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Sin[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.552.3 inverted*)


(* Note: This would result in an infinite loop!!! *)
(* Int[(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Cos[c+d*x]*(a+b*Sin[c+d*x])^n/(a*d*n) +
  Dist[(a^2-b^2)/a,Int[(a+b*Sin[c+d*x])^(n-1),x]] +
  Dist[b*(n+1)/(a*n),Int[Sin[c+d*x]*(a+b*Sin[c+d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>0 && NonzeroQ[a^2-b^2] *)


(* ::Item:: *)
(*Reference: G&R 2.552.3*)


Int[1/(a_+b_.*Sin[c_.+d_.*x_])^2,x_Symbol] :=
  b*Cos[c+d*x]/(d*(a^2-b^2)*(a+b*Sin[c+d*x])) + 
  Dist[a/(a^2-b^2),Int[1/(a+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.552.3*)


Int[(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Cos[c+d*x]*(a+b*Sin[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[1/((n+1)*(a^2-b^2)),Int[(a*(n+1)-b*(n+2)*Sin[c+d*x])*(a+b*Sin[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Sin[c+d x])^n		Products of monomials and powers of linear binomials of sines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1+Sin[z]==2*Sin[z/2+Pi/4]^2==2*Cos[z/2-Pi/4]^2*)


Int[x_^m_.*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
(*Dist[(2*a)^n,Int[x^m*Sin[Pi/4+c/2+d*x/2]^(2*n),x]] /; *)
  Dist[(2*a)^n,Int[x^m*Cos[-Pi/4+c/2+d*x/2]^(2*n),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && n<0 && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1+Sin[z]==2*Sin[z/2+Pi/4]^2==2*Cos[z/2-Pi/4]^2*)


Int[x_^m_.*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
(*Dist[2^n,Int[x^m*(a*Sin[Pi/4+c/2+d*x/2]^2)^n,x]] /;*)
  Dist[2^n,Int[x^m*(a*Cos[-Pi/4+c/2+d*x/2]^2)^n,x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[{m,n}] && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1-Sin[z]==2*Sin[z/2-Pi/4]^2==2*Cos[z/2+Pi/4]^2*)


Int[x_^m_.*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
(*Dist[(2*a)^n,Int[x^m*Sin[-Pi/4+c/2+d*x/2]^(2*n),x]] /; *)
  Dist[(2*a)^n,Int[x^m*Cos[Pi/4+c/2+d*x/2]^(2*n),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && n<0 && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1-Sin[z]==2*Sin[z/2-Pi/4]^2==2*Cos[z/2+Pi/4]^2*)


Int[x_^m_.*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
(*Dist[2^n,Int[x^m*(a*Sin[-Pi/4+c/2+d*x/2]^2)^n,x]] /; *)
  Dist[2^n,Int[x^m*(a*Cos[Pi/4+c/2+d*x/2]^2)^n,x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[{m,n}] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b z)^2 == a/((a^2-b^2) (a+b z)) - b (b+a z)/((a^2-b^2) (a+b z)^2)*)


Int[x_/(a_+b_.*Sin[c_.+d_.*x_])^2,x_Symbol] :=
  Dist[a/(a^2-b^2),Int[x/(a+b*Sin[c+d*x]),x]] -
  Dist[b/(a^2-b^2),Int[x*(b+a*Sin[c+d*x])/(a+b*Sin[c+d*x])^2,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*Sin[z] == (I*b+2*a*E^(I*z)-I*b*E^(2*I*z))/(2*E^(I*z))*)


Int[x_^m_.*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[1/2^n,Int[x^m*(I*b+2*a*E^(I*c+I*d*x)-I*b*E^(2*(I*c+I*d*x)))^n/E^(n*(I*c+I*d*x)),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && IntegerQ[n] && n<0 && RationalQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*(A+B Sin[c+d x]) (a+b Sin[c+d x])^n	Products of powers of linear binomials of sines*)


(* ::Item:: *)
(*Basis: (A+B*z)/Sqrt[a+b*z] == (b*A-a*B)/(b*Sqrt[a+b*z]) + B/b*Sqrt[a+b*z]*)


Int[(A_.+B_.*Sin[c_.+d_.*x_])/Sqrt[a_+b_.*Sin[c_.+d_.*x_]],x_Symbol] :=
  Dist[(b*A-a*B)/b,Int[1/Sqrt[a+b*Sin[c+d*x]],x]] +
  Dist[B/b,Int[Sqrt[a+b*Sin[c+d*x]],x]] /;
FreeQ[{a,b,c,d,A,B},x] && NonzeroQ[b*A-a*B]


(* ::Item:: *)
(*Reference: G&R 2.551.1 inverted*)


Int[(A_.+B_.*Sin[c_.+d_.*x_])*(a_+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  -B*Cos[c+d*x]*(a+b*Sin[c+d*x])^n/(d*(n+1)) + 
  Dist[1/(n+1),Int[(b*B*n+a*A*(n+1) + (a*B*n+b*A*(n+1))*Sin[c+d*x])*(a+b*Sin[c+d*x])^(n-1), x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n>1 && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.551.1 special case*)


Int[(A_+B_.*Sin[c_.+d_.*x_])/(a_+b_.*Sin[c_.+d_.*x_])^2,x_Symbol] :=
  -B*Cos[c+d*x]/(a*d*(a+b*Sin[c+d*x])) /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*(A_+B_.*Sin[c_.+d_.*x_])/(a_+b_.*Sin[c_.+d_.*x_])^2,x_Symbol] :=
  -B*x*Cos[c+d*x]/(a*d*(a+b*Sin[c+d*x])) +
  Dist[B/(a*d),Int[Cos[c+d*x]/(a+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Reference: G&R 2.551.1*)


Int[(A_.+B_.*Sin[c_.+d_.*x_])*(a_.+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  (a*B-b*A)*Cos[c+d*x]*(a+b*Sin[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[1/((n+1)*(a^2-b^2)),Int[((n+1)*(a*A-b*B)+(n+2)*(a*B-b*A)*Sin[c+d*x])*(a+b*Sin[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Sin[c+d x]^2)^n		Products of monomials and powers of quadratic binomials of sines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sin[z]^2 == (1 - Cos[2*z])/2*)


Int[x_^m_./(a_+b_.*Sin[c_.+d_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a+b-b*Cos[2*c+2*d*x]),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0 && NonzeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a+b*Cos[z]^2+c*Sin[z]^2 == (2*a+b+c + (b-c)*Cos[2*z])/2*)


Int[x_^m_./(a_.+b_.*Cos[d_.+e_.*x_]^2+c_.*Sin[d_.+e_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a+b+c+(b-c)*Cos[2*d+2*e*x]),x]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[m] && m>0 && NonzeroQ[a+b] && NonzeroQ[a+c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sin[z]^2 == (1 - Cos[2*z])/2*)


Int[(a_+b_.*Sin[c_.+d_.*x_]^2)^n_,x_Symbol] :=
  Dist[1/2^n,Int[(2*a+b-b*Cos[2*c+2*d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Sin[c+d x] Cos[c+d x])^n	Products of monomials and powers involving products of sines and cosines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sin[z]*Cos[z] == Sin[2*z]/2*)


Int[x_^m_./(a_+b_.*Sin[c_.+d_.*x_]*Cos[c_.+d_.*x_]),x_Symbol] :=
  Int[x^m/(a+b*Sin[2*c+2*d*x]/2),x] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sin[z]*Cos[z] == Sin[2*z]/2*)


Int[(a_+b_.*Sin[c_.+d_.*x_]*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(a+b*Sin[2*c+2*d*x]/2)^n,x] /;
FreeQ[{a,b,c,d},x] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x]^m Cos[a+b x]^n		Products of powers of sines and cosines*)


Int[Sin[a_.+b_.*x_]^m_.*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^(m+1)*Cos[a+b*x]^(n+1)/(b*(m+1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+2] && NonzeroQ[m+1] && PosQ[m]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Cos[z]^n == (1-Sin[z]^2)^((n-1)/2)*Sin'[z]*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[x^m*(1-x^2)^((n-1)/2),x],x],x,Sin[a+b*x]]] /;
FreeQ[{a,b,m},x] && OddQ[n] && Not[OddQ[m] && 01 && n<-1


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b, A&S 4.3.127b*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sin[a+b*x]^(m-1)*Cos[a+b*x]^(n+1)/(b*(m+n)) +
  Dist[(m-1)/(m+n),Int[Sin[a+b*x]^(m-2)*Cos[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m]] && NonzeroQ[m+n] &&
Not[OddQ[n] && n>1]


(* ::Item:: *)
(*Reference: G&R 2.510.3, CRC 334a, A&S 4.3.128b*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^(m+1)*Cos[a+b*x]^(n+1)/(b*(m+1)) +
  Dist[(m+n+2)/(m+1),Int[Sin[a+b*x]^(m+2)*Cos[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+2]


(* Note: Kool rule, but replace with a more general collect fractional power rule?! *)
Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/(b*m),Subst[Int[x^(1/m)/(1+x^(2/m)),x],x,Sin[a+b*x]^m*Cos[a+b*x]^n]] /;
FreeQ[{a,b},x] && FractionQ[{m,n}] && ZeroQ[m+n] && IntegerQ[1/m] && m>0


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x]^m Tan[a+b x]^n		Products of powers of sines and tangents*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.18', CRC 327'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z]*Tan[z] == -Cos[z]+Sec[z]*)


Int[Sin[a_.+b_.*x_]*Tan[a_.+b_.*x_],x_Symbol] :=
  -Sin[a+b*x]/b + 
  Int[Sec[a+b*x],x] /;
FreeQ[{a,b},x]


Int[Sin[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sin[a+b*x]^m*Tan[a+b*x]^(n-1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-1]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[Sin[a_.+b_.*x_]^m_.*Tan[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[(1-x^2)^((m+n-1)/2)/x^n,x],x],x,Cos[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && OddQ[m+n]


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a*)


Int[Sin[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^m*Tan[a+b*x]^(n+1)/(b*m) -
  Dist[(n+1)/m,Int[Sin[a+b*x]^(m-2)*Tan[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m>1 && n<-1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.6, CRC 334b*)


Int[Sin[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^(m+2)*Tan[a+b*x]^(n-1)/(b*(n-1)) -
  Dist[(m+2)/(n-1),Int[Sin[a+b*x]^(m+2)*Tan[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b*)


Int[Sin[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_.,x_Symbol]:=
  -Sin[a+b*x]^m*Tan[a+b*x]^(n-1)/(b*m) +
  Dist[(m+n-1)/m,Int[Sin[a+b*x]^(m-2)*Tan[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.1*)


Int[Sin[a_.+b_.*x_]^m_.*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^m*Tan[a+b*x]^(n-1)/(b*(n-1)) -
  Dist[(m+n-1)/(n-1),Int[Sin[a+b*x]^m*Tan[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.3, CRC 334a*)


Int[Sin[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_.,x_Symbol]:=
  Sin[a+b*x]^(m+2)*Tan[a+b*x]^(n-1)/(b*(m+n+1)) +
  Dist[(m+2)/(m+n+1),Int[Sin[a+b*x]^(m+2)*Tan[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.4*)


Int[Sin[a_.+b_.*x_]^m_.*Tan[a_.+b_.*x_]^n_,x_Symbol]:=
  Sin[a+b*x]^m*Tan[a+b*x]^(n+1)/(b*(m+n+1)) -
  Dist[(n+1)/(m+n+1),Int[Sin[a+b*x]^m*Tan[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x^n]				Sines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: FresnelS'[z] == Sin[Pi*z^2/2]*)


Int[Sin[b_.*x_^2],x_Symbol] :=
  Sqrt[Pi/2]*FresnelS[Rt[b,2]*x/Sqrt[Pi/2]]/Rt[b,2] /;
FreeQ[b,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[w+z] == Sin[w]*Cos[z] + Cos[w]*Sin[z]*)


Int[Sin[a_+b_.*x_^2],x_Symbol] :=
  Dist[Sin[a],Int[Cos[b*x^2],x]] + 
  Dist[Cos[a],Int[Sin[b*x^2],x]] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z] == I/2*E^(-I*z) - I/2*E^(I*z)*)


Int[Sin[a_.+b_.*x_^n_],x_Symbol] :=
  Dist[I/2,Int[E^(-a*I-b*I*x^n),x]] - 
  Dist[I/2,Int[E^(a*I+b*I*x^n),x]] /;
FreeQ[{a,b,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one, rules for 
	improper binomials rectify it. *)
Int[Sin[a_.+b_.*x_^n_],x_Symbol] :=
  x*Sin[a+b*x^n] -
  Dist[b*n,Int[x^n*Cos[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a+b x^n]			Products of monomials and sines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: SinIntegral'[z] == Sin[z]/z*)


Int[Sin[a_.*x_^n_.]/x_,x_Symbol] :=
  SinIntegral[a*x^n]/n /;
FreeQ[{a,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[w+z] == Sin[w]*Cos[z] + Cos[w]*Sin[z]*)


Int[Sin[a_+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[Sin[a],Int[Cos[b*x^n]/x,x]] + 
  Dist[Cos[a],Int[Sin[b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 392, A&S 4.3.119*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*Sin[a+b*x^n] == x^(m-n+1)*(Sin[a+b*x^n]*x^(n-1))*)


Int[x_^m_.*Sin[a_.+b_.*x_^n_.],x_Symbol] :=
  -x^(m-n+1)*Cos[a+b*x^n]/(b*n) +
  Dist[(m-n+1)/(b*n),Int[x^(m-n)*Cos[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[m] && 00 && m<-1 || 0<-n1 && ZeroQ[m-2*n+1]


(* ::Item:: *)
(*Reference: G&R 2.631.2'*)


Int[x_^m_.*Sin[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  (m-n+1)*x^(m-2*n+1)*Sin[a+b*x^n]^p/(b^2*n^2*p^2) -
  x^(m-n+1)*Cos[a+b*x^n]*Sin[a+b*x^n]^(p-1)/(b*n*p) +
  Dist[(p-1)/p,Int[x^m*Sin[a+b*x^n]^(p-2),x]] -
  Dist[(m-n+1)*(m-2*n+1)/(b^2*n^2*p^2),Int[x^(m-2*n)*Sin[a+b*x^n]^p,x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[{m,p}] && p>1 && 0<2*n1 && m<-1 && n>0 && NonzeroQ[m+n+1]


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a+b (c+d x)^n]^p		Products of monomials and powers of sines of binomials of linears*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b x,x],x] == Subst[Int[f[x,-a/b+x/b],x],x,a+b x]/b*)


Int[x_^m_.*Sin[a_.+b_.*(c_+d_.*x_)^n_]^p_.,x_Symbol] :=
  Dist[1/d,Subst[Int[(-c/d+x/d)^m*Sin[a+b*x^n]^p,x],x,c+d*x]] /;
FreeQ[{a,b,c,d,n},x] && IntegerQ[m] && m>0 && RationalQ[p]


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x+c x^2]			Sines of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*x+c*x^2 == (b+2*c*x)^2/(4*c)*)


Int[Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Int[Sin[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*x+c*x^2 == (b+2*c*x)^2/(4*c) - (b^2-4*a*c)/(4*c)*)


(* ::Item:: *)
(*Basis: Sin[z-w] == Cos[w]*Sin[z] - Sin[w]*Cos[z]*)


Int[Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Cos[(b^2-4*a*c)/(4*c)]*Int[Sin[(b+2*c*x)^2/(4*c)],x] - 
  Sin[(b^2-4*a*c)/(4*c)]*Int[Cos[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m Sin[a+b x+c x^2]		Products of linears and sines of quadratic trinomials*)
(**)


Int[(d_.+e_.*x_)*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  -e*Cos[a+b*x+c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  -e*Cos[a+b*x+c*x^2]/(2*c) -
  Dist[(b*e-2*c*d)/(2*c),Int[Sin[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  -e*(d+e*x)^(m-1)*Cos[a+b*x+c*x^2]/(2*c) + 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Cos[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  -e*(d+e*x)^(m-1)*Cos[a+b*x+c*x^2]/(2*c) - 
  Dist[(b*e-2*c*d)/(2*c),Int[(d+e*x)^(m-1)*Sin[a+b*x+c*x^2],x]] + 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Cos[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Sin[a+b*x+c*x^2]/(e*(m+1)) -
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Cos[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sin[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Sin[a+b*x+c*x^2]/(e*(m+1)) -
  Dist[(b*e-2*c*d)/(e^2*(m+1)),Int[(d+e*x)^(m+1)*Cos[a+b*x+c*x^2],x]] -
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Cos[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && NonzeroQ[b*e-2*c*d]


(* ::Subsubsection::Closed:: *)
(*Sin[a+b Log[c x^n]]^p			Powers of sines of logarithms*)


Int[Sin[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  x*Sin[a+b*Log[c*x^n]]/(1+b^2*n^2) -
  b*n*x*Cos[a+b*Log[c*x^n]]/(1+b^2*n^2) /;
FreeQ[{a,b,c,n},x] && NonzeroQ[1+b^2*n^2]


Int[Sin[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Sin[a+b*Log[c*x^n]]^p/(1+b^2*n^2*p^2) -
  b*n*p*x*Cos[a+b*Log[c*x^n]]*Sin[a+b*Log[c*x^n]]^(p-1)/(1+b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p-1)/(1+b^2*n^2*p^2),Int[Sin[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && NonzeroQ[1+b^2*n^2*p^2]


Int[Sin[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Cot[a+b*Log[c*x^n]]*Sin[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  x*Sin[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[(1+b^2*n^2*(p+2)^2)/(b^2*n^2*(p+1)*(p+2)),Int[Sin[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && p!=-2


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a+b Log[c x^n]]^p		Products of monomials and powers of sines of logarithms*)


Int[x_^m_.*Sin[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  (m+1)*x^(m+1)*Sin[a+b*Log[c*x^n]]/(b^2*n^2+(m+1)^2) -
  b*n*x^(m+1)*Cos[a+b*Log[c*x^n]]/(b^2*n^2+(m+1)^2) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[b^2*n^2+(m+1)^2] && NonzeroQ[m+1]


Int[x_^m_.*Sin[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Sin[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2+(m+1)^2) -
  b*n*p*x^(m+1)*Cos[a+b*Log[c*x^n]]*Sin[a+b*Log[c*x^n]]^(p-1)/(b^2*n^2*p^2+(m+1)^2) +
  Dist[b^2*n^2*p*(p-1)/(b^2*n^2*p^2+(m+1)^2),Int[x^m*Sin[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && NonzeroQ[b^2*n^2*p^2+(m+1)^2] && NonzeroQ[m+1]


Int[x_^m_.*Sin[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x^(m+1)*Cot[a+b*Log[c*x^n]]*Sin[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  (m+1)*x^(m+1)*Sin[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[(b^2*n^2*(p+2)^2+(m+1)^2)/(b^2*n^2*(p+1)*(p+2)),Int[x^m*Sin[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a x^n Log[b x]^p Log[b x]^p  Products of sines and powers of logarithms*)
(**)


Int[Sin[a_.*x_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  -Cos[a*x*Log[b*x]^p]/a -
  Dist[p,Int[Sin[a*x*Log[b*x]^p]*Log[b*x]^(p-1),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>0


Int[Sin[a_.*x_^n_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  -Cos[a*x^n*Log[b*x]^p]/(a*n*x^(n-1)) -
  Dist[p/n,Int[Sin[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] -
  Dist[(n-1)/(a*n),Int[Cos[a*x^n*Log[b*x]^p]/x^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{n,p}] && p>0


Int[x_^m_*Sin[a_.*x_^n_.*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  -x^(m-n+1)*Cos[a*x^n*Log[b*x]^p]/(a*n) -
  Dist[p/n,Int[x^m*Sin[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] +
  Dist[(m-n+1)/(a*n),Int[x^(m-n)*Cos[a*x^n*Log[b*x]^p],x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>0


(* ::Subsubsection::Closed:: *)
(*u Sin[v]^2				Products involving squares of sines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z]^2 == 1/2 - 1/2*Cos[2*z]*)


Int[u_*Sin[v_]^2,x_Symbol] :=
  Dist[1/2,Int[u,x]] - 
  Dist[1/2,Int[u*Cos[2*v],x]] /;
FunctionOfTrigQ[u,2*v,x]


(* ::Subsubsection::Closed:: *)
(*u Sin[v] Trig[w]			Products of circular trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Cos[w] == Sin[v+w]/2 + Sin[v-w]/2*)


Int[u_.*Sin[v_]*Cos[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Sin[v+w],x],x]] + 
  Dist[1/2,Int[u*Regularize[Sin[v-w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && PosQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Sin[w] == Cos[v-w]/2 - Cos[v+w]/2*)


Int[u_.*Sin[v_]*Sin[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Cos[v-w],x],x]] - 
  Dist[1/2,Int[u*Regularize[Cos[v+w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Tan[w] == -Cos[v] + Cos[v-w]*Sec[w]*)


Int[u_.*Sin[v_]*Tan[w_]^n_.,x_Symbol] :=
  -Int[u*Cos[v]*Tan[w]^(n-1),x] + Cos[v-w]*Int[u*Sec[w]*Tan[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Cot[w] == Cos[v] + Sin[v-w]*Csc[w]*)


Int[u_.*Sin[v_]*Cot[w_]^n_.,x_Symbol] :=
  Int[u*Cos[v]*Cot[w]^(n-1),x] + Sin[v-w]*Int[u*Csc[w]*Cot[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Sec[w] == Cos[v-w]*Tan[w] + Sin[v-w]*)


Int[u_.*Sin[v_]*Sec[w_]^n_.,x_Symbol] :=
  Cos[v-w]*Int[u*Tan[w]*Sec[w]^(n-1),x] + Sin[v-w]*Int[u*Sec[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Csc[w] == Sin[v-w]*Cot[w] + Cos[v-w]*)


Int[u_.*Sin[v_]*Csc[w_]^n_.,x_Symbol] :=
  Sin[v-w]*Int[u*Cot[w]*Csc[w]^(n-1),x] + Cos[v-w]*Int[u*Csc[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Subsection::Closed:: *)
(*Cosine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x]^n				Positive integer powers of cosines of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.6, CRC 291, A&S 4.3.114*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Sin'[z] == Cos[z]*)


Int[Cos[a_.+b_.*x_],x_Symbol] :=
  Sin[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.513.11, CRC 302*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[Cos[a_.+b_.*x_]^2,x_Symbol] :=
  x/2 + Cos[a+b*x]*Sin[a+b*x]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Cos[z]^n == (1-Sin[z]^2)^((n-1)/2)*Sin'[z]*)


Int[Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1-x^2)^((n-1)/2),x],x],x,Sin[a+b*x]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1


(* ::ItemParagraph::Closed:: *)
(**)


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 305*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Cos[a_.+b_.*x_])^n_,x_Symbol] :=
  c*Sin[a+b*x]*(c*Cos[a+b*x])^(n-1)/(b*n) + 
  Dist[(n-1)*c^2/n,Int[(c*Cos[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[OddQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.6, CRC 313*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Cos[a_.+b_.*x_])^n_,x_Symbol] :=
  -Sin[a+b*x]*(c*Cos[a+b*x])^(n+1)/(c*b*(n+1)) + 
  Dist[(n+2)/((n+1)*c^2),Int[(c*Cos[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Cos[x])^n/Cos[x]^n,x] == 0*)


Int[(c_*Cos[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Cos[a+b*x])^n/Cos[a+b*x]^n*Int[Cos[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.555.2'*)


Int[(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Sin[c+d*x]*(a+b*Cos[c+d*x])^n/(a*d*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Cos[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.554.3 inverted*)


(* Note: This would result in an infinite loop!!! *)
(* Int[(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Sin[c+d*x]*(a+b*Cos[c+d*x])^n/(a*d*n) +
  Dist[(a^2-b^2)/a,Int[(a+b*Cos[c+d*x])^(n-1),x]] +
  Dist[b*(n+1)/(a*n),Int[Cos[c+d*x]*(a+b*Cos[c+d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>0 && NonzeroQ[a^2-b^2] *)


(* ::Item:: *)
(*Reference: G&R 2.554.3*)


Int[1/(a_+b_.*Cos[c_.+d_.*x_])^2,x_Symbol] :=
  -b*Sin[c+d*x]/(d*(a^2-b^2)*(a+b*Cos[c+d*x])) + 
  Dist[a/(a^2-b^2),Int[1/(a+b*Cos[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.554.3*)


Int[(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Sin[c+d*x]*(a+b*Cos[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[1/((n+1)*(a^2-b^2)),Int[(a*(n+1)-b*(n+2)*Cos[c+d*x])*(a+b*Cos[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Cos[c+d x])^n		Products of monomials and powers of linear binomials of cosines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1+Cos[z] == 2*Cos[z/2]^2*)


Int[x_^m_.*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[(2*a)^n,Int[x^m*Cos[c/2+d*x/2]^(2*n),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && n<0 && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1+Cos[z] == 2*Cos[z/2]^2*)


Int[x_^m_.*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[2^n,Int[x^m*(a*Cos[c/2+d*x/2]^2)^n,x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[{m,n}] && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1-Cos[z] == 2*Sin[z/2]^2*)


Int[x_^m_.*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[(2*a)^n,Int[x^m*Sin[c/2+d*x/2]^(2*n),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && n<0 && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1-Cos[z] == 2*Sin[z/2]^2*)


Int[x_^m_.*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[2^n,Int[x^m*(a*Sin[c/2+d*x/2]^2)^n,x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[{m,n}] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b z)^2 == a/((a^2-b^2) (a+b z)) - b (b+a z)/((a^2-b^2) (a+b z)^2)*)


Int[x_/(a_+b_.*Cos[c_.+d_.*x_])^2,x_Symbol] :=
  Dist[a/(a^2-b^2),Int[x/(a+b*Cos[c+d*x]),x]] -
  Dist[b/(a^2-b^2),Int[x*(b+a*Cos[c+d*x])/(a+b*Cos[c+d*x])^2,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*Cos[z] == (b+2*a*E^(I*z)+b*E^(2*I*z))/(2*E^(I*z))*)


Int[x_^m_.*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[1/2^n,Int[x^m*(b+2*a*E^(I*c+I*d*x)+b*E^(2*(I*c+I*d*x)))^n/E^(n*(I*c+I*d*x)),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && IntegerQ[n] && n<0 && RationalQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*(A+B Cos[c+d x]) (a+b Cos[c+d x])^n	Products of powers of linear binomials of cosines*)


(* ::Item:: *)
(*Basis: (A+B*z)/Sqrt[a+b*z] == (b*A-a*B)/(b*Sqrt[a+b*z]) + B/b*Sqrt[a+b*z]*)


Int[(A_.+B_.*Cos[c_.+d_.*x_])/Sqrt[a_+b_.*Cos[c_.+d_.*x_]],x_Symbol] :=
  Dist[(b*A-a*B)/b,Int[1/Sqrt[a+b*Cos[c+d*x]],x]] +
  Dist[B/b,Int[Sqrt[a+b*Cos[c+d*x]],x]] /;
FreeQ[{a,b,c,d,A,B},x] && NonzeroQ[b*A-a*B]


(* ::Item:: *)
(*Reference: G&R 2.554.1 inverted*)


Int[(A_.+B_.*Cos[c_.+d_.*x_])*(a_+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  B*Sin[c+d*x]*(a+b*Cos[c+d*x])^n/(d*(n+1)) + 
  Dist[1/(n+1),Int[(b*B*n+a*A*(n+1) + (a*B*n+b*A*(n+1))*Cos[c+d*x])*(a+b*Cos[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n>1 && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.554.1 special case*)


Int[(A_+B_.*Cos[c_.+d_.*x_])/(a_+b_.*Cos[c_.+d_.*x_])^2,x_Symbol] :=
  B*Sin[c+d*x]/(a*d*(a+b*Cos[c+d*x])) /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*(A_+B_.*Cos[c_.+d_.*x_])/(a_+b_.*Cos[c_.+d_.*x_])^2,x_Symbol] :=
  B*x*Sin[c+d*x]/(a*d*(a+b*Cos[c+d*x])) -
  Dist[B/(a*d),Int[Sin[c+d*x]/(a+b*Cos[c+d*x]),x]] /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Reference: G&R 2.554.1*)


Int[(A_.+B_.*Cos[c_.+d_.*x_])*(a_.+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  -(a*B-b*A)*Sin[c+d*x]*(a+b*Cos[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[1/((n+1)*(a^2-b^2)),Int[((n+1)*(a*A-b*B)+(n+2)*(a*B-b*A)*Cos[c+d*x])*(a+b*Cos[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Cos[c+d x]^2)^n		Products of monomials and powers of quadratic binomials of sines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cos[z]^2 == (1 + Cos[2*z])/2*)


Int[x_^m_./(a_+b_.*Cos[c_.+d_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a+b+b*Cos[2*c+2*d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cos[z]^2 == (1 + Cos[2*z])/2*)


Int[(a_+b_.*Cos[c_.+d_.*x_]^2)^n_,x_Symbol] :=
  Dist[1/2^n,Int[(2*a+b+b*Cos[2*c+2*d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x]^n Sin[a+b x]^m 		Products of powers of cosines and sines*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Sin[a+b*x]^(m+1)*Cos[a+b*x]^(n+1)/(b*(n+1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+2] && NonzeroQ[n+1] && PosQ[n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is odd, Sin[z]^m == -(1-Cos[z]^2)^((m-1)/2)*Cos'[z]*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[x^n*(1-x^2)^((m-1)/2),x],x],x,Cos[a+b*x]]] /;
FreeQ[{a,b,n},x] && OddQ[m] && Not[OddQ[n] && 01


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a, A&S 4.3.127a*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Sin[a+b*x]^(m+1)*Cos[a+b*x]^(n-1)/(b*(m+n)) +
  Dist[(n-1)/(m+n),Int[Sin[a+b*x]^m*Cos[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[n]] && NonzeroQ[m+n] &&
Not[OddQ[m] && m>1]


(* ::Item:: *)
(*Reference: G&R 2.510.6, CRC 334b, A&S 4.3.128a*)


Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sin[a+b*x]^(m+1)*Cos[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[(m+n+2)/(n+1),Int[Sin[a+b*x]^m*Cos[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+2]


(* Kool rule, but replace with a more general collect fractional power rule?! *)
Int[Sin[a_.+b_.*x_]^m_*Cos[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[-1/(b*n),Subst[Int[x^(1/n)/(1+x^(2/n)),x],x,Sin[a+b*x]^m*Cos[a+b*x]^n]] /;
FreeQ[{a,b},x] && FractionQ[{m,n}] && ZeroQ[m+n] && IntegerQ[1/n] && n>0


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x]^m Cot[a+b x]^n		Products of powers of cosines and cotangents*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.34'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z]*Cot[z] == -Sin[z]+Csc[z]*)


Int[Cos[a_.+b_.*x_]*Cot[a_.+b_.*x_],x_Symbol] :=
  Cos[a+b*x]/b + 
  Int[Csc[a+b*x],x] /;
FreeQ[{a,b},x]


Int[Cos[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  Cos[a+b*x]^m*Cot[a+b*x]^(n-1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-1]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[Cos[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1-x^2)^((m+n-1)/2)/x^n,x],x],x,Sin[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && OddQ[m+n]


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b*)


Int[Cos[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Cos[a+b*x]^m*Cot[a+b*x]^(n+1)/(b*m) -
  Dist[(n+1)/m,Int[Cos[a+b*x]^(m-2)*Cot[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m>1 && n<-1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.3, CRC 334a*)


Int[Cos[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Cos[a+b*x]^(m+2)*Cot[a+b*x]^(n-1)/(b*(n-1)) -
  Dist[(m+2)/(n-1),Int[Cos[a+b*x]^(m+2)*Cot[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a*)


Int[Cos[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_.,x_Symbol] :=
  Cos[a+b*x]^m*Cot[a+b*x]^(n-1)/(b*m) +
  Dist[(m+n-1)/m,Int[Cos[a+b*x]^(m-2)*Cot[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.4*)


Int[Cos[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Cos[a+b*x]^m*Cot[a+b*x]^(n-1)/(b*(n-1)) -
  Dist[(m+n-1)/(n-1),Int[Cos[a+b*x]^m*Cot[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.6, CRC 334b*)


Int[Cos[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Cos[a+b*x]^(m+2)*Cot[a+b*x]^(n-1)/(b*(m+n+1)) +
  Dist[(m+2)/(m+n+1),Int[Cos[a+b*x]^(m+2)*Cot[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.1*)


Int[Cos[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Cos[a+b*x]^m*Cot[a+b*x]^(n+1)/(b*(m+n+1)) -
  Dist[(n+1)/(m+n+1),Int[Cos[a+b*x]^m*Cot[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x^n]				Cosines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: FresnelC'[z] == Cos[Pi*z^2/2]*)


Int[Cos[b_.*x_^2],x_Symbol] :=
  Sqrt[Pi/2]*FresnelC[Rt[b,2]*x/Sqrt[Pi/2]]/Rt[b,2] /;
FreeQ[b,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[w+z] == Cos[w]*Cos[z] - Sin[w]*Sin[z]*)


Int[Cos[a_+b_.*x_^2],x_Symbol] :=
  Dist[Cos[a],Int[Cos[b*x^2],x]] - 
  Dist[Sin[a],Int[Sin[b*x^2],x]] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z] == E^(-I*z)/2 + E^(I*z)/2*)


Int[Cos[a_.+b_.*x_^n_],x_Symbol] :=
  Dist[1/2,Int[E^(-a*I-b*I*x^n),x]] + 
  Dist[1/2,Int[E^(a*I+b*I*x^n),x]] /;
FreeQ[{a,b,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one, rules for 
	improper binomials rectify it. *)
Int[Cos[a_.+b_.*x_^n_],x_Symbol] :=
  x*Cos[a+b*x^n] + 
  Dist[b*n,Int[x^n*Sin[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a+b x^n]			Products of monomials and cosines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: CosIntegral'[z] == Cos[z]/z*)


Int[Cos[a_.*x_^n_.]/x_,x_Symbol] :=
  CosIntegral[a*x^n]/n /;
FreeQ[{a,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[w+z] == Cos[w]*Cos[z] - Sin[w]*Sin[z]*)


Int[Cos[a_+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[Cos[a],Int[Cos[b*x^n]/x,x]] - 
  Dist[Sin[a],Int[Sin[b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 396, A&S 4.3.123*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*Cos[a+b*x^n] == x^(m-n+1)*(Cos[a+b*x^n]*x^(n-1))*)


Int[x_^m_.*Cos[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m-n+1)*Sin[a+b*x^n]/(b*n) -
  Dist[(m-n+1)/(b*n),Int[x^(m-n)*Sin[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[m] && 00 && m<-1 || 0<-n1 && ZeroQ[m-2*n+1]


(* ::Item:: *)
(*Reference: G&R 2.631.3'*)


Int[x_^m_.*Cos[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  (m-n+1)*x^(m-2*n+1)*Cos[a+b*x^n]^p/(b^2*n^2*p^2) +
  x^(m-n+1)*Sin[a+b*x^n]*Cos[a+b*x^n]^(p-1)/(b*n*p) +
  Dist[(p-1)/p,Int[x^m*Cos[a+b*x^n]^(p-2),x]] -
  Dist[(m-n+1)*(m-2*n+1)/(b^2*n^2*p^2),Int[x^(m-2*n)*Cos[a+b*x^n]^p,x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[{m,p}] && p>1 && 0<2*n1 && m<-1 && n>0 && NonzeroQ[m+n+1]


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a+b (c+d x)^n]^p		Products of monomials and powers of cosines of binomials of linears*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b x,x],x] == Subst[Int[f[x,-a/b+x/b],x],x,a+b x]/b*)


Int[x_^m_.*Cos[a_.+b_.*(c_+d_.*x_)^n_]^p_.,x_Symbol] :=
  Dist[1/d,Subst[Int[(-c/d+x/d)^m*Cos[a+b*x^n]^p,x],x,c+d*x]] /;
FreeQ[{a,b,c,d,n},x] && IntegerQ[m] && m>0 && RationalQ[p]


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x+c x^2]			Cosines of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*x+c*x^2 == (b+2*c*x)^2/(4*c)*)


Int[Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Int[Cos[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*x+c*x^2 == (b+2*c*x)^2/(4*c) - (b^2-4*a*c)/(4*c)*)


(* ::Item:: *)
(*Basis: Cos[z-w] == Cos[w]*Cos[z] + Sin[w]*Sin[z]*)


Int[Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Cos[(b^2-4*a*c)/(4*c)]*Int[Cos[(b+2*c*x)^2/(4*c)],x] + 
  Sin[(b^2-4*a*c)/(4*c)]*Int[Sin[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m Cos[a+b x+c x^2]		Products of linears and cosines of quadratic trinomials*)
(**)


Int[(d_.+e_.*x_)*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Sin[a+b*x+c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Sin[a+b*x+c*x^2]/(2*c) -
  Dist[(b*e-2*c*d)/(2*c),Int[Cos[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Sin[a+b*x+c*x^2]/(2*c) - 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Sin[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Sin[a+b*x+c*x^2]/(2*c) - 
  Dist[(b*e-2*c*d)/(2*c),Int[(d+e*x)^(m-1)*Cos[a+b*x+c*x^2],x]] - 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Sin[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Cos[a+b*x+c*x^2]/(e*(m+1)) + 
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Sin[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cos[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Cos[a+b*x+c*x^2]/(e*(m+1)) + 
  Dist[(b*e-2*c*d)/(e^2*(m+1)),Int[(d+e*x)^(m+1)*Sin[a+b*x+c*x^2],x]] +
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Sin[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && NonzeroQ[b*e-2*c*d]


(* ::Subsubsection::Closed:: *)
(*Cos[a+b Log[c x^n]]^p			Powers of cosines of logarithms*)


Int[Cos[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  x*Cos[a+b*Log[c*x^n]]/(1+b^2*n^2) +
  b*n*x*Sin[a+b*Log[c*x^n]]/(1+b^2*n^2) /;
FreeQ[{a,b,c,n},x] && NonzeroQ[1+b^2*n^2]


Int[Cos[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Cos[a+b*Log[c*x^n]]^p/(1+b^2*n^2*p^2) +
  b*n*p*x*Cos[a+b*Log[c*x^n]]^(p-1)*Sin[a+b*Log[c*x^n]]/(1+b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p-1)/(1+b^2*n^2*p^2),Int[Cos[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && NonzeroQ[1+b^2*n^2*p^2]


Int[Cos[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x*Tan[a+b*Log[c*x^n]]*Cos[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  x*Cos[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[(1+b^2*n^2*(p+2)^2)/(b^2*n^2*(p+1)*(p+2)),Int[Cos[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && p!=-2


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a+b Log[c x^n]]^p		Products of monomials and powers of cosines of logarithms*)


Int[x_^m_.*Cos[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  (m+1)*x^(m+1)*Cos[a+b*Log[c*x^n]]/(b^2*n^2+(m+1)^2) +
  b*n*x^(m+1)*Sin[a+b*Log[c*x^n]]/(b^2*n^2+(m+1)^2) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[b^2*n^2+(m+1)^2] && NonzeroQ[m+1]


Int[x_^m_.*Cos[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Cos[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2+(m+1)^2) +
  b*n*p*x^(m+1)*Cos[a+b*Log[c*x^n]]^(p-1)*Sin[a+b*Log[c*x^n]]/(b^2*n^2*p^2+(m+1)^2) +
  Dist[b^2*n^2*p*(p-1)/(b^2*n^2*p^2+(m+1)^2),Int[x^m*Cos[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && NonzeroQ[b^2*n^2*p^2+(m+1)^2] && NonzeroQ[m+1]


Int[x_^m_.*Cos[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x^(m+1)*Tan[a+b*Log[c*x^n]]*Cos[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  (m+1)*x^(m+1)*Cos[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[(b^2*n^2*(p+2)^2+(m+1)^2)/(b^2*n^2*(p+1)*(p+2)),Int[x^m*Cos[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a x^n Log[b x]^p Log[b x]^p	Products of cosines and powers of logarithms*)
(**)


Int[Cos[a_.*x_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Sin[a*x*Log[b*x]^p]/a -
  Dist[p,Int[Cos[a*x*Log[b*x]^p]*Log[b*x]^(p-1),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>0


Int[Cos[a_.*x_^n_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Sin[a*x^n*Log[b*x]^p]/(a*n*x^(n-1)) -
  Dist[p/n,Int[Cos[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] +
  Dist[(n-1)/(a*n),Int[Sin[a*x^n*Log[b*x]^p]/x^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{n,p}] && p>0


Int[x_^m_*Cos[a_.*x_^n_.*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  x^(m-n+1)*Sin[a*x^n*Log[b*x]^p]/(a*n) -
  Dist[p/n,Int[x^m*Cos[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] -
  Dist[(m-n+1)/(a*n),Int[x^(m-n)*Sin[a*x^n*Log[b*x]^p],x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>0


(* ::Subsubsection::Closed:: *)
(*u Cos[v]^2				Products involving squares of cosines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z]^2 == 1/2 + 1/2*Cos[2*z]*)


Int[u_*Cos[v_]^2,x_Symbol] :=
  Dist[1/2,Int[u,x]] + 
  Dist[1/2,Int[u*Cos[2*v],x]] /;
FunctionOfTrigQ[u,2*v,x]


(* ::Subsubsection::Closed:: *)
(*u Cos[v] Trig[w]			Products of circular trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[v]*Cos[w] == Sin[w+v]/2 - Sin[w-v]/2*)


Int[u_.*Sin[v_]*Cos[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Sin[w+v],x],x]] - 
  Dist[1/2,Int[u*Regularize[Sin[w-v],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && PosQ[w-v]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[v]*Cos[w] == Cos[v-w]/2 + Cos[v+w]/2*)


Int[u_.*Cos[v_]*Cos[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Cos[v-w],x],x]] + 
  Dist[1/2,Int[u*Regularize[Cos[v+w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[v]*Tan[w] == Sin[v] - Sin[v-w]*Sec[w]*)


Int[u_.*Cos[v_]*Tan[w_]^n_.,x_Symbol] :=
  Int[u*Sin[v]*Tan[w]^(n-1),x] - Sin[v-w]*Int[u*Sec[w]*Tan[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[v]*Cot[w] == -Sin[v] + Cos[v-w]*Csc[w]*)


Int[u_.*Cos[v_]*Cot[w_]^n_.,x_Symbol] :=
  -Int[u*Sin[v]*Cot[w]^(n-1),x] + Cos[v-w]*Int[u*Csc[w]*Cot[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[v]*Sec[w] == -Sin[v-w]*Tan[w] + Cos[v-w]*)


Int[u_.*Cos[v_]*Sec[w_]^n_.,x_Symbol] :=
  -Sin[v-w]*Int[u*Tan[w]*Sec[w]^(n-1),x] + Cos[v-w]*Int[u*Sec[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[v]*Csc[w] == Cos[v-w]*Cot[w] - Sin[v-w]*)


Int[u_.*Cos[v_]*Csc[w_]^n_.,x_Symbol] :=
  Cos[v-w]*Int[u*Cot[w]*Csc[w]^(n-1),x] - Sin[v-w]*Int[u*Csc[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Subsection::Closed:: *)
(*Tangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(c Tan[a+b x])^n			Powers of tangents of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.17, CRC 292, A&S 4.3.115*)


(* ::Item:: *)
(*Derivation: Reciprocal rule*)


(* ::Item:: *)
(*Basis: Tan[z] == Sin[z]/Cos[z]*)


Int[Tan[a_.+b_.*x_],x_Symbol] :=
  -Log[Cos[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.22, CRC 420*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Tan[z]^2 == -1+Sec[z]^2*)


Int[Tan[a_.+b_.*x_]^2,x_Symbol] :=
  -x + Tan[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.1, CRC 423, A&S 4.3.129*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


(* ::Item:: *)
(*Basis: Tan[z]^n == Tan[z]^(n-1)/Cos[z]*Sin[z]*)


Int[(c_.*Tan[a_.+b_.*x_])^n_,x_Symbol] :=
  c*(c*Tan[a+b*x])^(n-1)/(b*(n-1)) - 
  Dist[c^2,Int[(c*Tan[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.4, CRC 427'*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Tan[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Tan[a+b*x])^(n+1)/(b*c*(n+1)) - 
  Dist[1/c^2,Int[(c*Tan[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*(a+b Tan[c+d x])^n			Powers of binomials of tangents where a^2+b^2 is zero*)


Int[Sqrt[a_+b_.*Tan[c_.+d_.*x_]],x_Symbol] :=
  -(Sqrt[2]*b*ArcTanh[Sqrt[a+b*Tan[c+d*x]]/(Sqrt[2]*Rt[a,2])])/(d*Rt[a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2] && PosQ[a]


Int[Sqrt[a_+b_.*Tan[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcTan[Sqrt[a+b*Tan[c+d*x]]/(Sqrt[2]*Rt[-a,2])])/(d*Rt[-a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2] && NegQ[a]


Int[(a_+b_.*Tan[c_.+d_.*x_])^n_,x_Symbol] :=
  -a^2*(a+b*Tan[c+d*x])^(n-1)/(b*d*(n-1)) + 
  Dist[2*a,Int[(a+b*Tan[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2+b^2]


Int[1/(a_+b_.*Tan[c_.+d_.*x_]),x_Symbol] :=
  x/(2*a) - a/(2*b*d*(a+b*Tan[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


Int[(a_+b_.*Tan[c_.+d_.*x_])^n_,x_Symbol] :=
  a*(a+b*Tan[c+d*x])^n/(2*b*d*n) + 
  Dist[1/(2*a),Int[(a+b*Tan[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<0 && ZeroQ[a^2+b^2]


(* ::Subsubsection::Closed:: *)
(*1 / (a+b Tan[c+d x]^n)			Reciprocals of binomials of tangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*Tan[z]) == Cos[z]/(a*Cos[z]+b*Sin[z])*)


Int[1/(a_+b_.*Tan[c_.+d_.*x_]),x_Symbol] :=
  a*x/(a^2+b^2) + b*Log[a*Cos[c+d*x]+b*Sin[c+d*x]]/(d*(a^2+b^2)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


Int[1/(a_+b_.*Tan[c_.+d_.*x_]^2),x_Symbol] :=
  x/(a-b) - Sqrt[b]*ArcTan[(Sqrt[b]*Tan[c+d*x])/Sqrt[a]]/(Sqrt[a]*d*(a-b)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a-b]


(* ::Subsubsection::Closed:: *)
(*x^m Tan[a+b x^n]^p			Products of monomials and powers of tangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Tan[z] == -I + 2*I/(1+E^(2*I*z))*)


Int[x_^m_.*Tan[a_.+b_.*x_^n_.],x_Symbol] :=
  -I*x^(m+1)/(m+1) + 
  Dist[2*I,Int[x^m/(1+E^(2*I*a+2*I*b*x^n)),x]] /;
FreeQ[{a,b,m,n},x] && NonzeroQ[m-n+1] && IntegerQ[m] && m>0


(* Note: Rule not in literature ??? *)
Int[x_^m_.*Tan[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  x^(m-n+1)*Tan[a+b*x^n]^(p-1)/(b*n*(p-1)) - 
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Tan[a+b*x^n]^(p-1),x]] - 
  Int[x^m*Tan[a+b*x^n]^(p-2),x] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>1 && NonzeroQ[m-n+1] && 01 *)


(* ::Subsection::Closed:: *)
(*Cotangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(c Cot[a+b x])^n			Powers of cotangents of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.33, CRC 293, A&S 4.3.118*)


(* ::Item:: *)
(*Derivation: Reciprocal rule*)


(* ::Item:: *)
(*Basis: Cot[z] == Cos[z]/Sin[z]*)


Int[Cot[a_.+b_.*x_],x_Symbol] :=
  Log[Sin[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.38, CRC 424*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cot[z]^2 == -1+Csc[z]^2*)


Int[Cot[a_.+b_.*x_]^2,x_Symbol] :=
  -x - Cot[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.4, CRC 427, A&S 4.3.130*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


(* ::Item:: *)
(*Basis: Cot[z]^n == Cot[z]^(n-1)/Sin[z]*Cos[z]*)


Int[(c_.*Cot[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*(c*Cot[a+b*x])^(n-1)/(b*(n-1)) - 
  Dist[c^2,Int[(c*Cot[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.1, CRC 423'*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Cot[a_.+b_.*x_])^n_,x_Symbol] :=
  -(c*Cot[a+b*x])^(n+1)/(b*c*(n+1)) - 
  Dist[1/c^2,Int[(c*Cot[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*(a+b Cot[c+d x])^n			Powers of binomials of cotangents where a^2+b^2 is zero*)


Int[Sqrt[a_+b_.*Cot[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcCoth[Sqrt[a+b*Cot[c+d*x]]/(Sqrt[2]*Rt[a,2])])/(d*Rt[a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2] && PosQ[a]


Int[Sqrt[a_+b_.*Cot[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcCot[Sqrt[a+b*Cot[c+d*x]]/(Sqrt[2]*Rt[-a,2])])/(d*Rt[-a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2] && NegQ[a]


Int[(a_+b_.*Cot[c_.+d_.*x_])^n_,x_Symbol] :=
  a^2*(a+b*Cot[c+d*x])^(n-1)/(b*d*(n-1)) + 
  Dist[2*a,Int[(a+b*Cot[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2+b^2]


Int[1/(a_+b_.*Cot[c_.+d_.*x_]),x_Symbol] :=
  x/(2*a) + a/(2*b*d*(a+b*Cot[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


Int[(a_+b_.*Cot[c_.+d_.*x_])^n_,x_Symbol] :=
  -a*(a+b*Cot[c+d*x])^n/(2*b*d*n) + 
  Dist[1/(2*a),Int[(a+b*Cot[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<0 && ZeroQ[a^2+b^2]


(* ::Subsubsection::Closed:: *)
(*1 / (a+b Cot[c+d x]^n)			Reciprocals of binomials of cotangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*Cot[z]) == Sin[z]/(a*Sin[z]+b*Cos[z])*)


Int[1/(a_+b_.*Cot[c_.+d_.*x_]),x_Symbol] :=
  a*x/(a^2+b^2) - b*Log[b*Cos[c+d*x]+a*Sin[c+d*x]]/(d*(a^2+b^2)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


Int[1/(a_+b_.*Cot[c_.+d_.*x_]^2),x_Symbol] :=
  x/(a-b) + Sqrt[b]*ArcTan[(Sqrt[b]*Cot[c+d*x])/Sqrt[a]]/(Sqrt[a]*d*(a-b)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a-b]


(* ::Subsubsection::Closed:: *)
(*x^m Cot[a+b x^n]^p			Products of monomials and powers of cotangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cot[z] == I - 2*I/(1-E^(2*I*z))*)


Int[x_^m_.*Cot[a_.+b_.*x_^n_.],x_Symbol] :=
  I*x^(m+1)/(m+1) - 
  Dist[2*I,Int[x^m/(1-E^(2*I*a+2*I*b*x^n)),x]] /;
FreeQ[{a,b,m,n},x] && NonzeroQ[m-n+1] && IntegerQ[m] && m>0


(* Note: Rule not in literature ??? *)
Int[x_^m_.*Cot[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  -x^(m-n+1)*Cot[a+b*x^n]^(p-1)/(b*n*(p-1)) + 
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Cot[a+b*x^n]^(p-1),x]] - 
  Int[x^m*Cot[a+b*x^n]^(p-2),x] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>1 && NonzeroQ[m-n+1] && 01*)


(* ::Subsection::Closed:: *)
(*Secant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Sec[a+b x]^n				Powers of secants of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.9', CRC 294', A&S 4.3.117'*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Sec[z] == 1/(1-Sin[z]^2)*Sin'[z]*)


Int[Sec[a_.+b_.*x_],x_Symbol] :=
  ArcTanh[Sin[a+b*x]]/b /;
FreeQ[{a,b},x]


(* Note: This entirely redundant is required due to idem potent problem in Mathematica 6 & 7. *)
Int[1/Sqrt[Sec[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Cos[a+b*x]]*Sqrt[Sec[a+b*x]]*Int[Sqrt[Cos[a+b*x]],x] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Sec[x])^n*Cos[x]^n,x] == 0*)


Int[(c_.*Sec[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Sec[a+b*x])^n*Cos[a+b*x]^n*Int[1/Cos[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.6, CRC 313*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Sec[a_.+b_.*x_])^n_,x_Symbol] :=
  c*Sin[a+b*x]*(c*Sec[a+b*x])^(n-1)/(b*(n-1)) + 
  Dist[(n-2)*c^2/(n-1),Int[(c*Sec[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[EvenQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.5, CRC 305*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sec[a_.+b_.*x_])^n_,x_Symbol] :=
  -Sin[a+b*x]*(c*Sec[a+b*x])^(n+1)/(b*c*n) + 
  Dist[(n+1)/(c^2*n),Int[(c*Sec[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m Sec[a+b x]^n			Products of monomials and powers of secants of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sec[a_.+b_.*x_],x_Symbol] :=
  -2*I*x^m*ArcTan[E^(I*a+I*b*x)]/b +
  Dist[2*I*m/b,Int[x^(m-1)*ArcTan[E^(I*a+I*b*x)],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Reference: CRC 430, A&S 4.3.125*)


Int[x_^m_.*Sec[a_.+b_.*x_]^2,x_Symbol] :=
  x^m*Tan[a+b*x]/b -
  Dist[m/b,Int[x^(m-1)*Tan[a+b*x],x]] /;
FreeQ[{a,b},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Reference: G&R 2.643.2, CRC 431, A&S 4.3.126*)


Int[x_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  x*Tan[a+b*x]*Sec[a+b*x]^(n-2)/(b*(n-1)) -
  Sec[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x*Sec[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1 && n!=2


(* ::Item:: *)
(*Reference: G&R 2.643.2*)


Int[x_^m_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  x^m*Tan[a+b*x]*Sec[a+b*x]^(n-2)/(b*(n-1)) -
  m*x^(m-1)*Sec[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x^m*Sec[a+b*x]^(n-2),x]] +
  Dist[m*(m-1)/(b^2*(n-1)*(n-2)),Int[x^(m-2)*Sec[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n>1 && n!=2 && m>1


(* ::Item:: *)
(*Reference: G&R 2.631.3*)


Int[x_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  Sec[a+b*x]^n/(b^2*n^2) -
  x*Sin[a+b*x]*Sec[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x*Sec[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1


(* ::Item:: *)
(*Reference: G&R 2.631.3*)


Int[x_^m_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  m*x^(m-1)*Sec[a+b*x]^n/(b^2*n^2) -
  x^m*Sin[a+b*x]*Sec[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x^m*Sec[a+b*x]^(n+2),x]] -
  Dist[m*(m-1)/(b^2*n^2),Int[x^(m-2)*Sec[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n<-1 && m>1


(* ::Subsubsection::Closed:: *)
(*(a+b Sec[c+d x])^n			Powers of constant plus secants of linears where a^2-b^2 is zero*)


Int[Sqrt[a_+b_.*Sec[c_.+d_.*x_]],x_Symbol] :=
  2*a*ArcTan[Sqrt[-1+a/b*Sec[c+d*x]]]*Tan[c+d*x]/
		(d*Sqrt[-1+a/b*Sec[c+d*x]]*Sqrt[a+b*Sec[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* Note: There should be a simpler antiderivative! *)
Int[1/Sqrt[a_+b_.*Sec[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*ArcTan[(Sqrt[2]*Sqrt[a])/Sqrt[-a+b*Sec[x]]]+2*ArcTan[Sqrt[-a+b*Sec[x]]/Sqrt[a]])*
  Sqrt[-a+b*Sec[x]]*Sqrt[a+b*Sec[x]]*Cot[x]/a^(3/2) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Sec[c+d x]^n)^m			Powers of constant plus powers of secants of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Sec[z]^n == (b+a*Cos[z]^n)/Cos[z]^n*)


Int[(a_+b_.*Sec[v_]^n_.)^m_,x_Symbol] :=
  Int[(b+a*Cos[v]^n)^m/Cos[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<0 && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Sec[z]^n == (b+a*Cos[z]^n)/Cos[z]^n*)


Int[Cos[v_]^p_.*(a_+b_.*Sec[v_]^n_.)^m_,x_Symbol] :=
  Int[Cos[v]^(p-m*n)*(b+a*Cos[v]^n)^m,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n,p}] && m<0 && n>0


(* ::Subsubsection::Closed:: *)
(*Sec[a+b x]^n Csc[a+b x]^m		Products of powers of secants and cosecants*)


(* ::Item:: *)
(*Reference: G&R 2.526.49, CRC 329*)


Int[Csc[a_.+b_.*x_]*Sec[a_.+b_.*x_],x_Symbol] :=
  Log[Tan[a+b*x]]/b /;
FreeQ[{a,b},x] && PosQ[b]


Int[Csc[a_.+b_.*x_]^m_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  Csc[a+b*x]^(m-1)*Sec[a+b*x]^(n-1)/(b*(n-1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-2] && NonzeroQ[n-1] && PosQ[n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m and n are integers and m+n is even, Csc[z]^m*Sec[z]^n == (1+Tan[z]^2)^((m+n)/2-1)/Tan[z]^m*Tan'[z]*)


Int[Csc[a_.+b_.*x_]^m_.*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1+x^2)^((m+n)/2-1)/x^m,x],x],x,Tan[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && EvenQ[m+n] && 01


(* ::Item:: *)
(*Reference: G&R 2.510.6, CRC 334b, A&S 4.3.128a*)


Int[Csc[a_.+b_.*x_]^m_.*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  Csc[a+b*x]^(m-1)*Sec[a+b*x]^(n-1)/(b*(n-1)) +
  Dist[(m+n-2)/(n-1),Int[Csc[a+b*x]^m*Sec[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[EvenQ[m+n]] && Not[EvenQ[n] && OddQ[m] && m>1]


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a, A&S 4.3.127a*)


Int[Csc[a_.+b_.*x_]^m_.*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^(m-1)*Sec[a+b*x]^(n+1)/(b*(m+n)) +
  Dist[(n+1)/(m+n),Int[Csc[a+b*x]^m*Sec[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n]


(* ::Subsubsection::Closed:: *)
(*Sec[a+b x]^m Tan[a+b x]^n		Products of powers of secants and tangents*)
(**)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[Sec[a_.+b_.*x_]^m_.*Tan[a_.+b_.*x_]^n_.,x_Symbol] :=
  Sec[a+b*x]^m/(b*m) /;
FreeQ[{a,b,m},x] && n===1


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is even, Sec[z]^m == (1+Tan[z]^2)^((m-2)/2)*Tan'[z]*)


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[x^n*(1+x^2)^((m-2)/2),x],x],x,Tan[a+b*x]]] /;
FreeQ[{a,b,n},x] && EvenQ[m] && m>2 && Not[OddQ[n] && 01 && n<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b*)


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sec[a+b*x]^m*Tan[a+b*x]^(n-1)/(b*m) -
  Dist[(n-1)/m,Int[Sec[a+b*x]^(m+2)*Tan[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a*)


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sec[a+b*x]^m*Tan[a+b*x]^(n+1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+1]


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sec[a+b*x]^m*Tan[a+b*x]^(n+1)/(b*m) +
  Dist[(m+n+1)/m,Int[Sec[a+b*x]^(m+2)*Tan[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.6, CRC 334b*)


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sec[a+b*x]^(m-2)*Tan[a+b*x]^(n+1)/(b*(m+n-1)) +
  Dist[(m-2)/(m+n-1),Int[Sec[a+b*x]^(m-2)*Tan[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.1*)


Int[Sec[a_.+b_.*x_]^m_.*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sec[a+b*x]^m*Tan[a+b*x]^(n-1)/(b*(m+n-1)) -
  Dist[(n-1)/(m+n-1),Int[Sec[a+b*x]^m*Tan[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.4*)


Int[Sec[a_.+b_.*x_]^m_*Tan[a_.+b_.*x_]^n_,x_Symbol] :=
  Sec[a+b*x]^m*Tan[a+b*x]^(n+1)/(b*(n+1)) -
  Dist[(m+n+1)/(n+1),Int[Sec[a+b*x]^m*Tan[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && Not[EvenQ[m]]


(* ::Subsubsection::Closed:: *)
(*x^m Sec[a+b x^n]^p Sin[a+b x^n]	Products of monomials, sines and powers of secants of binomials*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sec[a_.+b_.*x_^n_.]^p_*Sin[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m-n+1)*Sec[a+b*x^n]^(p-1)/(b*n*(p-1)) -
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Sec[a+b*x^n]^(p-1),x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && NonzeroQ[p-1]


(* ::Subsubsection::Closed:: *)
(*x^m Sec[a+b x^n]^p Tan[a+b x^n]	Products of monomials, tangents and powers of secants of binomials*)
(**)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sec[a_.+b_.*x_^n_.]^p_.*Tan[a_.+b_.*x_^n_.]^q_.,x_Symbol] :=
  x^(m-n+1)*Sec[a+b*x^n]^p/(b*n*p) -
  Dist[(m-n+1)/(b*n*p),Int[x^(m-n)*Sec[a+b*x^n]^p,x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && q===1 (* Required so InputForm is matchable *)


(* ::Subsubsection::Closed:: *)
(*Sec[a+b Log[c x^n]]^p			Powers of secants of logarithms*)


Int[Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Tan[a+b*Log[c*x^n]]*Sec[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  x*Sec[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) +
  Dist[(1+b^2*n^2*(p-2)^2)/(b^2*n^2*(p-1)*(p-2)),Int[Sec[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && p!=2


Int[Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Sec[a+b*Log[c*x^n]]^p/(1+b^2*n^2*p^2) -
  b*n*p*x*Sec[a+b*Log[c*x^n]]^(p+1)*Sin[a+b*Log[c*x^n]]/(1+b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p+1)/(1+b^2*n^2*p^2),Int[Sec[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && NonzeroQ[1+b^2*n^2*p^2]


(* ::Subsubsection::Closed:: *)
(*x^m Sec[a+b Log[c x^n]]^p		Products of monomials and powers of secants of logarithms*)


Int[Sec[a_.+b_.*Log[c_.*x_^n_.]]^2/x_,x_Symbol] :=
  Tan[a+b*Log[c*x^n]]/(b*n) /;
FreeQ[{a,b,c,n},x]


Int[Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  Tan[a+b*Log[c*x^n]]*Sec[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) +
  Dist[(p-2)/(p-1),Int[Sec[a+b*Log[c*x^n]]^(p-2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1


Int[Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  -Sec[a+b*Log[c*x^n]]^(p+1)*Sin[a+b*Log[c*x^n]]/(b*n*p) +
  Dist[(p+1)/p,Int[Sec[a+b*Log[c*x^n]]^(p+2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1


Int[x_^m_.*Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x^(m+1)*Tan[a+b*Log[c*x^n]]*Sec[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  (m+1)*x^(m+1)*Sec[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) +
  Dist[(b^2*n^2*(p-2)^2+(m+1)^2)/(b^2*n^2*(p-1)*(p-2)),Int[x^m*Sec[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && p!=2


Int[x_^m_.*Sec[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Sec[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2+(m+1)^2) -
  b*n*p*x^(m+1)*Sec[a+b*Log[c*x^n]]^(p+1)*Sin[a+b*Log[c*x^n]]/(b^2*n^2*p^2+(m+1)^2) +
  Dist[b^2*n^2*p*(p+1)/(b^2*n^2*p^2+(m+1)^2),Int[x^m*Sec[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && NonzeroQ[b^2*n^2*p^2+(m+1)^2]


(* ::Subsection::Closed:: *)
(*Cosecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Csc[a+b x]^n				Powers of cosecants of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.526.1, CRC 295, A&S 4.3.116'*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Csc[z] == -1/(1-Cos[z]^2)*Cos'[z]*)


Int[Csc[a_.+b_.*x_],x_Symbol] :=
  -ArcTanh[Cos[a+b*x]]/b /;
FreeQ[{a,b},x]


(* Note: This entirely redundant is required due to idem potent problem in Mathematica 6 & 7. *)
Int[1/Sqrt[Csc[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Csc[a+b*x]]*Sqrt[Sin[a+b*x]]*Int[Sqrt[Sin[a+b*x]],x] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Csc[x])^n*Sin[x]^n,x] == 0*)


Int[(c_.*Csc[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Csc[a+b*x])^n*Sin[a+b*x]^n*Int[1/Sin[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.3, CRC 309*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Csc[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*Cos[a+b*x]*(c*Csc[a+b*x])^(n-1)/(b*(n-1)) + 
  Dist[(n-2)*c^2/(n-1),Int[(c*Csc[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[EvenQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.510.2, CRC 299*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Csc[a_.+b_.*x_])^n_,x_Symbol] :=
  Cos[a+b*x]*(c*Csc[a+b*x])^(n+1)/(b*c*n) + 
  Dist[(n+1)/(c^2*n),Int[(c*Csc[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m Csc[a+b x]^n			Products of monomials and powers of cosecants of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csc[a_.+b_.*x_],x_Symbol] :=
  -2*x^m*ArcTanh[E^(I*a+I*b*x)]/b +
  Dist[2*m/b,Int[x^(m-1)*ArcTanh[E^(I*a+I*b*x)],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Reference: CRC 428, A&S 4.3.121*)


Int[x_^m_.*Csc[a_.+b_.*x_]^2,x_Symbol] :=
  -x^m*Cot[a+b*x]/b +
  Dist[m/b,Int[x^(m-1)*Cot[a+b*x],x]] /;
FreeQ[{a,b},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Reference: G&R 2.643.1, CRC 429', A&S 4.3.122*)


Int[x_*Csc[a_.+b_.*x_]^n_,x_Symbol] :=
  -x*Cot[a+b*x]*Csc[a+b*x]^(n-2)/(b*(n-1)) -
  Csc[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x*Csc[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1 && n!=2


(* ::Item:: *)
(*Reference: G&R 2.643.1*)


Int[x_^m_*Csc[a_.+b_.*x_]^n_,x_Symbol] :=
  -x^m*Cot[a+b*x]*Csc[a+b*x]^(n-2)/(b*(n-1)) -
  m*x^(m-1)*Csc[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x^m*Csc[a+b*x]^(n-2),x]] +
  Dist[m*(m-1)/(b^2*(n-1)*(n-2)),Int[x^(m-2)*Csc[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n>1 && n!=2 && m>1


(* ::Item:: *)
(*Reference: G&R 2.631.2'*)


Int[x_*Csc[a_.+b_.*x_]^n_,x_Symbol] :=
  Csc[a+b*x]^n/(b^2*n^2) +
  x*Cos[a+b*x]*Csc[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x*Csc[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1


(* ::Item:: *)
(*Reference: G&R 2.631.2*)


Int[x_^m_*Csc[a_.+b_.*x_]^n_,x_Symbol] :=
  m*x^(m-1)*Csc[a+b*x]^n/(b^2*n^2) +
  x^m*Cos[a+b*x]*Csc[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x^m*Csc[a+b*x]^(n+2),x]] -
  Dist[m*(m-1)/(b^2*n^2),Int[x^(m-2)*Csc[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n<-1 && m>1


(* ::Subsubsection::Closed:: *)
(*(a+b Csc[c+d x])^n			Powers of constant plus cosecants of linears where a^2-b^2 is zero*)


Int[Sqrt[a_+b_.*Csc[c_.+d_.*x_]],x_Symbol] :=
  -2*a*ArcTan[Sqrt[-1+a/b*Csc[c+d*x]]]*Cot[c+d*x]/
		(d*Sqrt[-1+a/b*Csc[c+d*x]]*Sqrt[a+b*Csc[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* Note: There should be a simpler antiderivative! *)
Int[1/Sqrt[a_+b_.*Csc[c_.+d_.*x_]],x_Symbol] :=
  -(Sqrt[2]*ArcTan[(Sqrt[2]*Sqrt[a])/Sqrt[-a+b*Csc[x]]]+2*ArcTan[Sqrt[-a+b*Csc[x]]/Sqrt[a]])*
  Sqrt[-a+b*Csc[x]]*Sqrt[a+b*Csc[x]]*Tan[x]/a^(3/2) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Csc[c+d x]^n)^m			Powers of constant plus powers of cosecants of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Csc[z]^n == (b+a*Sin[z]^n)/Sin[z]^n*)


Int[(a_+b_.*Csc[v_]^n_.)^m_,x_Symbol] :=
  Int[(b+a*Sin[v]^n)^m/Sin[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<0 && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Csc[z]^n == (b+a*Sin[z]^n)/Sin[z]^n*)


Int[Sin[v_]^p_.*(a_+b_.*Csc[v_]^n_.)^m_,x_Symbol] :=
  Int[Sin[v]^(p-m*n)*(b+a*Sin[v]^n)^m,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n,p}] && m<0 && n>0


(* ::Subsubsection::Closed:: *)
(*Csc[a+b x]^m Sec[a+b x]^n		Products of powers of cosecants and secants*)


(* ::Item:: *)
(*Reference: G&R 2.526.49', CRC 329'*)


Int[Csc[a_.+b_.*x_]*Sec[a_.+b_.*x_],x_Symbol] :=
  -Log[Cot[a+b*x]]/b /;
FreeQ[{a,b},x] && NegQ[b]


Int[Csc[a_.+b_.*x_]^m_*Sec[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^(m-1)*Sec[a+b*x]^(n-1)/(b*(m-1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-2] && NonzeroQ[m-1] && PosQ[m]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m and n are integers and m+n is even, Csc[z]^m*Sec[z]^n == -(1+Cot[z]^2)^((m+n)/2-1)/Cot[z]^n*Cot'[z]*)


Int[Csc[a_.+b_.*x_]^m_*Sec[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[(1+x^2)^((m+n)/2-1)/x^n,x],x],x,Cot[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && EvenQ[m+n] && 01 && n<-1


(* ::Item:: *)
(*Reference: G&R 2.510.3, CRC 334a, A&S 4.3.128b*)


Int[Csc[a_.+b_.*x_]^m_*Sec[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Csc[a+b*x]^(m-1)*Sec[a+b*x]^(n-1)/(b*(m-1)) +
  Dist[(m+n-2)/(m-1),Int[Csc[a+b*x]^(m-2)*Sec[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[EvenQ[m+n]] && Not[EvenQ[m] && OddQ[n] && n>1]


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b, A&S 4.3.127b*)


Int[Csc[a_.+b_.*x_]^m_*Sec[a_.+b_.*x_]^n_.,x_Symbol] :=
  Csc[a+b*x]^(m+1)*Sec[a+b*x]^(n-1)/(b*(m+n)) +
  Dist[(m+1)/(m+n),Int[Csc[a+b*x]^(m+2)*Sec[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n]


(* ::Subsubsection::Closed:: *)
(*Csc[a+b x]^m Cot[a+b x]^n		Products of powers of cosecants and cotangents*)
(**)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[Csc[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Csc[a+b*x]^m/(b*m) /;
FreeQ[{a,b,m},x] && n===1


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is even, Csc[z]^m == -(1+Cot[z]^2)^((m-2)/2)*Cot'[z]*)


Int[Csc[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[x^n*(1+x^2)^((m-2)/2),x],x],x,Cot[a+b*x]]] /;
FreeQ[{a,b,n},x] && EvenQ[m] && m>2 && Not[OddQ[n] && 01 && n<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.5, CRC 323a*)


Int[Csc[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^m*Cot[a+b*x]^(n-1)/(b*m) -
  Dist[(n-1)/m,Int[Csc[a+b*x]^(m+2)*Cot[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.2, CRC 323b*)


Int[Csc[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  Csc[a+b*x]^m*Cot[a+b*x]^(n+1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+1]


Int[Csc[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  Csc[a+b*x]^m*Cot[a+b*x]^(n+1)/(b*m) +
  Dist[(m+n+1)/m,Int[Csc[a+b*x]^(m+2)*Cot[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.510.3, CRC 334a*)


Int[Csc[a_.+b_.*x_]^m_*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^(m-2)*Cot[a+b*x]^(n+1)/(b*(m+n-1)) +
  Dist[(m-2)/(m+n-1),Int[Csc[a+b*x]^(m-2)*Cot[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.4*)


Int[Csc[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^m*Cot[a+b*x]^(n-1)/(b*(m+n-1)) -
  Dist[(n-1)/(m+n-1),Int[Csc[a+b*x]^m*Cot[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.510.1*)


Int[Csc[a_.+b_.*x_]^m_.*Cot[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csc[a+b*x]^m*Cot[a+b*x]^(n+1)/(b*(n+1)) -
  Dist[(m+n+1)/(n+1),Int[Csc[a+b*x]^m*Cot[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && Not[EvenQ[m]]


(* ::Subsubsection::Closed:: *)
(*x^m Csc[a+b x^n]^p Cos[a+b x^n]	Products of monomials, cosines and powers of cosecants of binomials*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csc[a_.+b_.*x_^n_.]^p_*Cos[a_.+b_.*x_^n_.],x_Symbol] :=
  -x^(m-n+1)*Csc[a+b*x^n]^(p-1)/(b*n*(p-1)) +
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Csc[a+b*x^n]^(p-1),x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && NonzeroQ[p-1]


(* ::Subsubsection::Closed:: *)
(*x^m Csc[a+b x^n]^p Cot[a+b x^n]	Products of monomials, cotangents and powers of cosecants of binomials*)
(**)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csc[a_.+b_.*x_^n_.]^p_.*Cot[a_.+b_.*x_^n_.]^q_.,x_Symbol] :=
  -x^(m-n+1)*Csc[a+b*x^n]^p/(b*n*p) +
  Dist[(m-n+1)/(b*n*p),Int[x^(m-n)*Csc[a+b*x^n]^p,x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && q===1 (* Required so InputForm is matchable *)


(* ::Subsubsection::Closed:: *)
(*Csc[a+b Log[c x^n]]^p			Powers of cosecants of logarithms*)


Int[Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x*Cot[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  x*Csc[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) +
  Dist[(1+b^2*n^2*(p-2)^2)/(b^2*n^2*(p-1)*(p-2)),Int[Csc[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && p!=2


Int[Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Csc[a+b*Log[c*x^n]]^p/(1+b^2*n^2*p^2) +
  b*n*p*x*Cos[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p+1)/(1+b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p+1)/(1+b^2*n^2*p^2),Int[Csc[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && NonzeroQ[1+b^2*n^2*p^2]


(* ::Subsubsection::Closed:: *)
(*x^m Csc[a+b Log[c x^n]]^p		Products of monomials and powers of cosecants of logarithms*)


Int[Csc[a_.+b_.*Log[c_.*x_^n_.]]^2/x_,x_Symbol] :=
  -Cot[a+b*Log[c*x^n]]/(b*n) /;
FreeQ[{a,b,c,n},x]


Int[Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  -Cot[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) +
  Dist[(p-2)/(p-1),Int[Csc[a+b*Log[c*x^n]]^(p-2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1


Int[Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  Cos[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p+1)/(b*n*p) +
  Dist[(p+1)/p,Int[Csc[a+b*Log[c*x^n]]^(p+2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1


Int[x_^m_.*Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x^(m+1)*Cot[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  (m+1)*x^(m+1)*Csc[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) +
  Dist[(b^2*n^2*(p-2)^2+(m+1)^2)/(b^2*n^2*(p-1)*(p-2)),Int[x^m*Csc[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && p!=2


Int[x_^m_.*Csc[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Csc[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2+(m+1)^2) +
  b*n*p*x^(m+1)*Cos[a+b*Log[c*x^n]]*Csc[a+b*Log[c*x^n]]^(p+1)/(b^2*n^2*p^2+(m+1)^2) +
  Dist[b^2*n^2*p*(p+1)/(b^2*n^2*p^2+(m+1)^2),Int[x^m*Csc[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && NonzeroQ[b^2*n^2*p^2+(m+1)^2]


(* ::Subsection::Closed:: *)
(*Powers of sums of Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(a Cos[c+d x] + b Sin[c+d x])^n	Powers of sums of sines and cosines*)


Int[(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  a*(a*Cos[c+d*x]+b*Sin[c+d*x])^n/(b*d*n) /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a^2+b^2]


(* ::Item:: *)
(*Reference: G&R 2.557.5b'*)


Int[1/(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^2,x_Symbol] :=
  Sin[c+d*x]/(a*d*(a*Cos[c+d*x]+b*Sin[c+d*x])) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


(* ::Item:: *)
(*Basis: a*Cos[z]+b*Sin[z] == Sqrt[a^2+b^2]*Cos[z-ArcTan[a,b]]*)


Int[Sqrt[a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]],x_Symbol] :=
  2*EllipticE[(c+d*x-ArcTan[a,b])/2,2]*Sqrt[a*Cos[c+d*x]+b*Sin[c+d*x]]/
  (d*Sqrt[(a*Cos[c+d*x]+b*Sin[c+d*x])/Sqrt[a^2+b^2]]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


(* ::Item:: *)
(*Basis: a*Cos[z]+b*Sin[z] == Sqrt[a^2+b^2]*Cos[z-ArcTan[a,b]]*)


Int[1/Sqrt[a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]],x_Symbol] :=
  2*EllipticF[(c+d*x-ArcTan[a,b])/2,2]*Sqrt[(a*Cos[c+d*x]+b*Sin[c+d*x])/Sqrt[a^2+b^2]]/
  (d*Sqrt[a*Cos[c+d*x]+b*Sin[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


(* ::Item::Closed:: *)
(*Reference: G&R 2.557'*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, (a*Cos[z]+b*Sin[z])^n == (a^2+b^2-u^2)^((n-1)/2)*D[u,z] where u = -b*Cos[z]+a*Sin[z]*)


(* Note: For odd n<-1, better to stay in the trig world using 2nd rule below ??? *)
Int[(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[1/d,Subst[Int[Regularize[(a^2+b^2-x^2)^((n-1)/2),x],x],x,-b*Cos[c+d*x]+a*Sin[c+d*x]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>=-1 && NonzeroQ[a^2+b^2]


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  -(b*Cos[c+d*x]-a*Sin[c+d*x])*(a*Cos[c+d*x]+b*Sin[c+d*x])^(n-1)/(d*n) +
  Dist[(n-1)*(a^2+b^2)/n,Int[(a*Cos[c+d*x]+b*Sin[c+d*x])^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1 && NonzeroQ[a^2+b^2] && Not[OddQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  (b*Cos[c+d*x]-a*Sin[c+d*x])*(a*Cos[c+d*x]+b*Sin[c+d*x])^(n+1)/(d*(n+1)*(a^2+b^2)) + 
  Dist[(n+2)/((n+1)*(a^2+b^2)),Int[(a*Cos[c+d*x]+b*Sin[c+d*x])^(n+2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2+b^2]


(* ::Subsubsection::Closed:: *)
(*(a Csc[c+d x] - a Sin[c+d x])^n		where a+b is zero*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Csc[z]-Sin[z] == Cos[z]*Cot[z]*)


Int[(a_.*Csc[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(a*Cos[c+d*x]*Cot[c+d*x])^n,x] /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a+b]


(* ::Subsubsection::Closed:: *)
(*(a Sec[c+d x] - a Cos[c+d x])^n		where a+b is zero*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sec[z]-Cos[z] == Sin[z]*Tan[z]*)


Int[(a_.*Sec[c_.+d_.*x_]+b_.*Cos[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(a*Sin[c+d*x]*Tan[c+d*x])^n,x] /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a+b]


(* ::Subsection::Closed:: *)
(*Rational functions of Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*u Trig[c+d x]^m / (a Cos[c+d x]+b Sin[c+d x])	where a^2+b^2 is nonzero*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z]^2/(a*Cos[z]+b*Sin[z]) == b/(a^2+b^2)*Sin[z] - a/(a^2+b^2)*Cos[z] + a^2/((a^2+b^2)*(a*Cos[z]+b*Sin[z]))*)


Int[u_.*Sin[c_.+d_.*x_]^n_./(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]),x_Symbol] :=
  Dist[b/(a^2+b^2),Int[u*Sin[c+d*x]^(n-1),x]] -
  Dist[a/(a^2+b^2),Int[u*Sin[c+d*x]^(n-2)*Cos[c+d*x],x]] +
  Dist[a^2/(a^2+b^2),Int[u*Sin[c+d*x]^(n-2)/(a*Cos[c+d*x]+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && IntegerQ[n] && n>0 &&
(n>1 || MatchQ[u,v_.*Tan[c+d*x]^m_. /; IntegerQ[m] && m>0])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z]^2/(a*Cos[z]+b*Sin[z]) == a/(a^2+b^2)*Cos[z] - b/(a^2+b^2)*Sin[z] + b^2/(a^2+b^2)/(a*Cos[z]+b*Sin[z])*)


Int[u_.*Cos[c_.+d_.*x_]^n_./(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]),x_Symbol] :=
  Dist[a/(a^2+b^2),Int[u*Cos[c+d*x]^(n-1),x]] -
  Dist[b/(a^2+b^2),Int[u*Cos[c+d*x]^(n-2)*Sin[c+d*x],x]] +
  Dist[b^2/(a^2+b^2),Int[u*Cos[c+d*x]^(n-2)/(a*Cos[c+d*x]+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && IntegerQ[n] && n>0 &&
(n>1 || MatchQ[u,v_.*Cot[c+d*x]^m_. /; IntegerQ[m] && m>0])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z]*Sin[z]/(a*Cos[z]+b*Sin[z]) == b/(a^2+b^2)*Cos[z] + a/(a^2+b^2)*Sin[z] - a*b/((a^2+b^2)*(a*Cos[z]+b*Sin[z]))*)


(* Int[u_.*Cos[c_.+d_.*x_]^m_.*Sin[c_.+d_.*x_]^n_./(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]),x_Symbol] :=
  Dist[b/(a^2+b^2),Int[u*Cos[c+d*x]^m*Sin[c+d*x]^(n-1),x]] +
  Dist[a/(a^2+b^2),Int[u*Cos[c+d*x]^(m-1)*Sin[c+d*x]^n,x]] -
  Dist[a*b/(a^2+b^2),Int[u*Cos[c+d*x]^(m-1)*Sin[c+d*x]^(n-1)/(a*Cos[c+d*x]+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && IntegerQ[{m,n}] && m>0 && n>0 *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sec[z]/(a*Cos[z]+b*Sin[z]) == Tan[z]/b + (b*Cos[z]-a*Sin[z])/(b*(a*Cos[z]+b*Sin[z]))*)


(* Int[u_.*Sec[c_.+d_.*x_]/(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]),x_Symbol] :=
  Dist[1/b,Int[u*Tan[c+d*x],x]] + 
  Dist[1/b,Int[u*(b*Cos[c+d*x]-a*Sin[c+d*x])/(a*Cos[c+d*x]+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Csc[z]/(a*Cos[z]+b*Sin[z]) == Cot[z]/a - (b*Cos[z]-a*Sin[z])/(a*(a*Cos[z]+b*Sin[z]))*)


(* Int[u_.*Csc[c_.+d_.*x_]/(a_.*Cos[c_.+d_.*x_]+b_.*Sin[c_.+d_.*x_]),x_Symbol] :=
  Dist[1/a,Int[u*Cot[c+d*x],x]] - 
  Dist[1/a,Int[u*(b*Cos[c+d*x]-a*Sin[c+d*x])/(a*Cos[c+d*x]+b*Sin[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] *)


(* ::Subsubsection::Closed:: *)
(*(a+b Cos[d+e x]+c Sin[d+e x])^n			where a^2-b^2-c^2 is zero*)


(* ::Item:: *)
(*Reference: G&R 2.558.4d*)


Int[1/(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
(* (-c*Cos[d+e*x]+b*Sin[d+e*x])/(a*e*(a+b*Cos[d+e*x]+c*Sin[d+e*x])) *)
  -2/(e*(c+(a-b)*Tan[(d+e*x)/2])) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2-c^2]


Int[Sqrt[a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]],x_Symbol] :=
  -2*(c*Cos[d+e*x]-b*Sin[d+e*x])/(e*Sqrt[a+b*Cos[d+e*x]+c*Sin[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2-c^2]


(* Int[1/Sqrt[a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]],x_Symbol] :=
  -2*ArcTanh[Sin[z/2]]*Cos[z/2]/(e*Sqrt[a+b*Cos[d+e*x]+c*Sin[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2-c^2] *)


(* Int[1/Sqrt[a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]],x_Symbol] :=
  2*ArcTanh[Sin[z/2]]*Cos[z/2]/(e*Sqrt[a+b*Cos[d+e*x]+c*Sin[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2-c^2] *)


Int[(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  (-c*Cos[d+e*x]+b*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n-1)/(e*n) +
  Dist[a*(2*n-1)/n,Int[(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n-1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n>1 && ZeroQ[a^2-b^2-c^2]


Int[(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  (c*Cos[d+e*x]-b*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^n/(a*e*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n<-1 && ZeroQ[a^2-b^2-c^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Cos[d+e x]+c Sin[d+e x])^n			where a^2-b^2-c^2 is nonzero*)


(* ::Item:: *)
(*Reference: G&R 2.558.4c*)


(* The following two rules should be unified?! *)
Int[1/(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  Log[a+c*Tan[(d+e*x)/2]]/(c*e) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a-b]


Int[1/(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  -Log[a+c*Cot[(d+e*x)/2]]/(c*e) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a+b]


(* ::Item:: *)
(*Reference: G&R 2.558.4a, CRC 342b*)


Int[1/(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  2*ArcTan[(c+(a-b)*Tan[(d+e*x)/2])/Rt[a^2-b^2-c^2,2]]/(e*Rt[a^2-b^2-c^2,2]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2] && PosQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Reference: G&R 2.558.4b', CRC 342b'*)


Int[1/(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  -2*ArcTanh[(c+(a-b)*Tan[(d+e*x)/2])/Rt[-a^2+b^2+c^2,2]]/(e*Rt[-a^2+b^2+c^2,2]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2] && NegQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Basis: a+b*Cos[z]+c*Sin[z] == a+Sqrt[b^2+c^2]*Cos[z-ArcTan[b,c]]*)


Int[Sqrt[a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]],x_Symbol] :=
  2*EllipticE[(d+e*x-ArcTan[b,c])/2,2/(1+a/Sqrt[b^2+c^2])]*Sqrt[a+b*Cos[d+e*x]+c*Sin[d+e*x]]/
  (e*Sqrt[(a+b*Cos[d+e*x]+c*Sin[d+e*x])/(a+Sqrt[b^2+c^2])]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Basis: a+b*Cos[z]+c*Sin[z] == a+Sqrt[b^2+c^2]*Cos[z-ArcTan[b,c]]*)


Int[1/Sqrt[a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]],x_Symbol] :=
  2*EllipticF[(d+e*x-ArcTan[b,c])/2,2/(1+a/Sqrt[b^2+c^2])]*
    Sqrt[(a+b*Cos[d+e*x]+c*Sin[d+e*x])/(a+Sqrt[b^2+c^2])]/
  (e*Sqrt[a+b*Cos[d+e*x]+c*Sin[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Reference: G&R 2.558.1*)


Int[(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  (-c*Cos[d+e*x]+b*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1)/(e*(n+1)*(a^2-b^2-c^2)) +
  Dist[1/((n+1)*(a^2-b^2-c^2)),
    Int[((n+1)*a-(n+2)*b*Cos[d+e*x]-(n+2)*c*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2-c^2]


(* ::Subsubsection::Closed:: *)
(*(A+B Cos[d+e x]+C Sin[d+e x]) (a+b Cos[d+e x]+c Sin[d+e x])^n		where a^2-b^2-c^2 is nonzero*)
(**)


(* ::Item:: *)
(*Reference: G&R 2.558.2*)


Int[(A_.+C_.*Sin[d_.+e_.*x_])/(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  -b*C*Log[a+b*Cos[d+e*x]+c*Sin[d+e*x]]/(e*(b^2+c^2)) +
  c*C*(d+e*x)/(e*(b^2+c^2)) +
  Dist[(A-a*c*C/(b^2+c^2)),Int[1/(a+b*Cos[d+e*x]+c*Sin[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,C},x] && NonzeroQ[b^2+c^2] && NonzeroQ[A-a*c*C/(b^2+c^2)]


(* ::Item:: *)
(*Reference: G&R 2.558.2*)


Int[(A_.+B_.*Cos[d_.+e_.*x_])/(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  c*B*Log[a+b*Cos[d+e*x]+c*Sin[d+e*x]]/(e*(b^2+c^2)) +
  b*B*(d+e*x)/(e*(b^2+c^2)) +
  Dist[(A-a*b*B/(b^2+c^2)),Int[1/(a+b*Cos[d+e*x]+c*Sin[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,B},x] && NonzeroQ[b^2+c^2] && NonzeroQ[A-a*b*B/(b^2+c^2)]


(* ::Item:: *)
(*Reference: G&R 2.558.2*)


Int[(A_.+B_.*Cos[d_.+e_.*x_]+C_.*Sin[d_.+e_.*x_])/(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_]),x_Symbol] :=
  (c*B-b*C)*Log[a+b*Cos[d+e*x]+c*Sin[d+e*x]]/(e*(b^2+c^2)) +
  (b*B+c*C)*(d+e*x)/(e*(b^2+c^2)) +
  Dist[(A-a*(b*B+c*C)/(b^2+c^2)),Int[1/(a+b*Cos[d+e*x]+c*Sin[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,B,C},x] && NonzeroQ[b^2+c^2] && NonzeroQ[A-a*(b*B+c*C)/(b^2+c^2)]


(* ::Item:: *)
(*Reference: G&R 2.558.1 inverted*)


(* Int[(A_.+B_.*Cos[d_.+e_.*x_]+C_.*Sin[d_.+e_.*x_])*(a_+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  (B*c-b*C-a*C*Cos[d+e*x]+a*B*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^n/(a*e*(n+1)) + 
  Dist[1/(a*(n+1)),Int[(a*(b*B+c*C)*n + a^2*A*(n+1) + 
    (a^2*B*n + c*(b*C-c*B)*n + a*b*A*(n+1))*Cos[d+e*x] + 
    (a^2*C*n - b*(b*C-c*B)*n + a*c*A*(n+1))*Sin[d+e*x])*
    (a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n-1), x]] /;
FreeQ[{a,b,c,d,e,A,B,C},x] && RationalQ[n] && n>1 && NonzeroQ[a^2-b^2-c^2] *)


(* ::Item:: *)
(*Reference: G&R 2.558.1*)


Int[(A_.+C_.*Sin[d_.+e_.*x_])*(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  (b*C+(a*C-c*A)*Cos[d+e*x]+b*A*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2-c^2)) +
  Dist[1/((n+1)*(a^2-b^2-c^2)),
    Int[((n+1)*(a*A-c*C)-(n+2)*b*A*Cos[d+e*x]+(n+2)*(a*C-c*A)*Sin[d+e*x])*
      (a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,C},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Reference: G&R 2.558.1*)


Int[(A_.+B_.*Cos[d_.+e_.*x_])*(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  -(c*B+c*A*Cos[d+e*x]+(a*B-b*A)*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2-c^2)) +
  Dist[1/((n+1)*(a^2-b^2-c^2)),
    Int[((n+1)*(a*A-b*B)+(n+2)*(a*B-b*A)*Cos[d+e*x]-(n+2)*c*A*Sin[d+e*x])*
      (a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2-c^2]


(* ::Item:: *)
(*Reference: G&R 2.558.1*)


Int[(A_.+B_.*Cos[d_.+e_.*x_]+C_.*Sin[d_.+e_.*x_])*(a_.+b_.*Cos[d_.+e_.*x_]+c_.*Sin[d_.+e_.*x_])^n_,x_Symbol] :=
  -(c*B-b*C-(a*C-c*A)*Cos[d+e*x]+(a*B-b*A)*Sin[d+e*x])*(a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2-c^2)) +
  Dist[1/((n+1)*(a^2-b^2-c^2)),
    Int[((n+1)*(a*A-b*B-c*C)+(n+2)*(a*B-b*A)*Cos[d+e*x]+(n+2)*(a*C-c*A)*Sin[d+e*x])*
      (a+b*Cos[d+e*x]+c*Sin[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,B,C},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2-c^2]


(* ::Subsubsection::Closed:: *)
(*Trig[v] (a+b Tan[v])^n*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: (a+b*Tan[z])/Sec[z] == a*Cos[z] + b*Sin[z]*)


Int[Sec[v_]^m_.*(a_+b_.*Tan[v_])^n_., x_Symbol] :=
  Int[(a*Cos[v]+b*Sin[v])^n,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m+n==0 


(* ::Subsubsection::Closed:: *)
(*Trig[v] (a+b Cot[v])^n*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: (a+b*Cot[z])/Csc[z] == b*Cos[z] + a*Sin[z]*)


Int[Csc[v_]^m_.*(a_+b_.*Cot[v_])^n_., x_Symbol] :=
  Int[(b*Cos[v]+a*Sin[v])^n,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m+n==0 


(* ::Subsection::Closed:: *)
(*Exponential and Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Sin[c + d x]^n		Products of exponentials and powers of sines of linears*)


(* ::Item:: *)
(*Reference: CRC 533, A&S 4.3.136*)


Int[E^(a_.+b_.*x_)*Sin[c_.+d_.*x_],x_Symbol] :=
  -d*E^(a+b*x)*Cos[c+d*x]/(b^2+d^2) + b*E^(a+b*x)*Sin[c+d*x]/(b^2+d^2) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[b^2+d^2]


(* ::Item:: *)
(*Reference: CRC 542, A&S 4.3.138*)


Int[E^(a_.+b_.*x_)*Sin[c_.+d_.*x_]^n_,x_Symbol] :=
  b*E^(a+b*x)*Sin[c+d*x]^n/(b^2+d^2*n^2) - 
  d*n*E^(a+b*x)*Cos[c+d*x]*Sin[c+d*x]^(n-1)/(b^2+d^2*n^2) + 
  Dist[n*(n-1)*d^2/(b^2+d^2*n^2),Int[E^(a+b*x)*Sin[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Cos[c + d x]^n		Products of exponentials and powers of cosines of linears*)


(* ::Item:: *)
(*Reference: CRC 538, A&S 4.3.137*)


Int[E^(a_.+b_.*x_)*Cos[c_.+d_.*x_],x_Symbol] :=
  b*E^(a+b*x)*Cos[c+d*x]/(b^2+d^2) + d*E^(a+b*x)*Sin[c+d*x]/(b^2+d^2) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[b^2+d^2]


(* ::Item:: *)
(*Reference: CRC 543, A&S 4.3.139*)


Int[E^(a_.+b_.*x_)*Cos[c_.+d_.*x_]^n_,x_Symbol] :=
  b*E^(a+b*x)*Cos[c+d*x]^n/(b^2+d^2*n^2) + 
  d*n*E^(a+b*x)*Cos[c+d*x]^(n-1)*Sin[c+d*x]/(b^2+d^2*n^2) +
  Dist[n*(n-1)*d^2/(b^2+d^2*n^2),Int[E^(a+b*x)*Cos[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Sec[c + d x]^n		Products of exponentials and powers of secants of linears*)


(* ::Item:: *)
(*Reference: CRC 552*)


Int[E^(a_.+b_.*x_)*Sec[c_.+d_.*x_]^n_,x_Symbol] :=
  -b*E^(a+b*x)*Sec[c+d*x]^(n-2)/(d^2*(n-1)*(n-2)) + 
  E^(a+b*x)*Sec[c+d*x]^(n-1)*Sin[c+d*x]/(d*(n-1)) +
  Dist[(b^2+d^2*(n-2)^2)/(d^2*(n-1)*(n-2)),Int[E^(a+b*x)*Sec[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1 && n!=2


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Csc[c + d x]^n		Products of exponentials and powers of cosecants of linears*)
(**)


(* ::Item:: *)
(*Reference: CRC 551*)


Int[E^(a_.+b_.*x_)*Csc[c_.+d_.*x_]^n_,x_Symbol] :=
  -b*E^(a+b*x)*Csc[c+d*x]^(n-2)/(d^2*(n-1)*(n-2)) - 
  E^(a+b*x)*Cos[c+d*x]*Csc[c+d*x]^(n-1)/(d*(n-1)) +
  Dist[(b^2+d^2*(n-2)^2)/(d^2*(n-1)*(n-2)),Int[E^(a+b*x)*Csc[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1 && n!=2


(* ::Subsubsection::Closed:: *)
(*x^m Exp[a + b x] Sin[c + d x]^n	Products of monomials, exponentials and powers of sines of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(a_.+b_.*x_)*Sin[c_.+d_.*x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[E^(a+b*x)*Sin[c+d*x]^n,x]]},
  x^m*u - Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && m>0 && n>0


(* ::Subsubsection::Closed:: *)
(*x^m Exp[a + b x] Cos[c + d x]^n	Products of exponentials and powers of cosines of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(a_.+b_.*x_)*Cos[c_.+d_.*x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[E^(a+b*x)*Cos[c+d*x]^n,x]]},
  x^m*u - Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && m>0 && n>0


(* ::Subsubsection::Closed:: *)
(*u f^v Trig[w]				Products of exponentials and trig functions of polynomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z] == I/2*(1/E^(I*z) - E^(I*z)) *)


Int[f_^v_*Sin[w_],x_Symbol] :=
  Dist[I/2,Int[f^v/E^(I*w),x]] - 
  Dist[I/2,Int[f^v*E^(I*w),x]] /;
FreeQ[f,x] && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sin[z] == I/2*(1/E^(I*z) - E^(I*z)) *)


Int[f_^v_*Sin[w_]^n_,x_Symbol] :=
  Dist[(I/2)^n,Int[f^v*(1/E^(I*w)-E^(I*w))^n,x]] /;
FreeQ[f,x] && IntegerQ[n] && n>0 && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z] == 1/2*(E^(I*z) + 1/E^(I*z))*)


Int[f_^v_*Cos[w_],x_Symbol] :=
  Dist[1/2,Int[f^v*E^(I*w),x]] + 
  Dist[1/2,Int[f^v/E^(I*w),x]] /;
FreeQ[f,x] && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cos[z] == 1/2*(E^(I*z) + 1/E^(I*z))*)


Int[f_^v_*Cos[w_]^n_,x_Symbol] :=
  Dist[1/2^n,Int[f^v*(E^(I*w)+1/E^(I*w))^n,x]] /;
FreeQ[f,x] && IntegerQ[n] && n>0 && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Subsection::Closed:: *)
(*Trig Function Simplification Rules*)


(* ::Subsubsection::Closed:: *)
(*u (a-a Trig[v]^2)^n*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1-Sin[z]^2 == Cos[z]^2*)


Int[u_.*(a_+b_.*Sin[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Cos[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 - Cos[z]^2 == Sin[z]^2*)


Int[u_.*(a_+b_.*Cos[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Sin[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 + Tan[z]^2 == Sec[z]^2*)


Int[u_.*(a_+b_.*Tan[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Sec[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 + Cot[z]^2 == Csc[z]^2*)


Int[u_.*(a_+b_.*Cot[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Csc[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: -1 + Sec[z]^2 == Tan[z]^2*)


Int[u_.*(a_+b_.*Sec[v_]^2)^n_.,x_Symbol] :=
  Dist[b^n,Int[u*Tan[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: -1 + Csc[z]^2 == Cot[z]^2*)


Int[u_.*(a_+b_.*Csc[v_]^2)^n_.,x_Symbol] :=
  Dist[b^n,Int[u*Cot[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Subsubsection::Closed:: *)
(*u (a Tan[v]^m+b Sec[v]^m)^n		Simplify sum of powers of trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a^2-b^2=0, then a*Tan[z]+b*Sec[z] == a*Tan[z/2+a/b*Pi/4]*)


Int[(a_.*Tan[v_]+b_.*Sec[v_])^n_,x_Symbol] :=
  Dist[a^n,Int[Tan[v/2+a/b*Pi/4]^n,x]] /;
FreeQ[{a,b},x] && ZeroQ[a^2-b^2] && EvenQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*Sec[z]+b*Tan[z] == (a+b*Sin[z])/Cos[z]*)


Int[u_.*(a_.*Sec[v_]^m_.+b_.*Tan[v_]^m_.)^n_.,x_Symbol] :=
  Int[u*(a+b*Sin[v]^m)^n/Cos[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && (OddQ[m*n] || m*n<0) && Not[m==2 && ZeroQ[a+b]]


(* ::Subsubsection::Closed:: *)
(*u (a Cot[v]^m+b Csc[v]^m)^n		Simplify sum of powers of trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a^2-b^2=0, then a*Cot[z]+b*Csc[z] == a*Cot[z/2+(a/b-1)*Pi/4]*)


Int[(a_.*Cot[v_]+b_.*Csc[v_])^n_,x_Symbol] :=
  Dist[a^n,Int[Cot[v/2+(a/b-1)*Pi/4]^n,x]] /;
FreeQ[{a,b},x] && ZeroQ[a^2-b^2] && EvenQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*Csc[z]+b*Cot[z] == (a+b*Cos[z])/Sin[z]*)


Int[u_.*(a_.*Csc[v_]^m_.+b_.*Cot[v_]^m_.)^n_.,x_Symbol] :=
  Int[u*(a+b*Cos[v]^m)^n/Sin[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && (OddQ[m*n] || m*n<0) && Not[m==2 && ZeroQ[a+b]]


(* ::Subsubsection::Closed:: *)
(*x^m Trig[u]^n Trig[v]^p*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sin[z]*Cos[z] == Sin[2*z]/2*)


(* Int[x_^m_.*Sin[v_]^n_.*Cos[v_]^n_.,x_Symbol] :=
  Dist[1/2^n,Int[x^m*Sin[Dist[2,v]]^n,x]] /;
IntegerQ[n] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sec[z]*Csc[z] == 2*Csc[2*z]*)


Int[x_^m_.*Sec[v_]^n_.*Csc[v_]^n_.,x_Symbol] :=
  Dist[2^n,Int[x^m*Csc[Dist[2,v]]^n,x]] /;
IntegerQ[{m,n}] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Convert trig function to complex exponentials*)


(* Got to improve x^m*f[e^x] integration before doing this! *)
(* Int[x_^m_.*f_[u_]^n_.*g_[v_]^p_.,x_Symbol] :=
  Int[x^m*TrigToExp[f[u]]^n*TrigToExp[g[v]]^p,x] /;
IntegerQ[{m,n,p}] && TrigQ[f] && TrigQ[g] *)


(* ::Subsection::Closed:: *)
(*Trig Function Substitution Rules*)


(* ::Subsubsection::Closed:: *)
(*Pure sine function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sin[z]]*Cos[z] == f[Sin[z]] * Sin'[z]*)


Int[u_*Cos[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sin[c*(a+b*x)],u,x],x],x],x,Sin[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sin[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sin[z]]*Cot[z] == f[Sin[z]]/Sin[z] * Sin'[z]*)


Int[u_*Cot[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sin[c*(a+b*x)],u,x]/x,x],x],x,Sin[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sin[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sin[z]]*Sin[2*z] == 2*f[Sin[z]]*Sin[z] * Sin'[z]*)


Int[u_*Sin[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[4/(b*c),Subst[Int[Regularize[x*SubstFor[Sin[c*(a+b*x)/2],u,x],x],x],x,Sin[c*(a+b*x)/2]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sin[c*(a+b*x)/2],u,x,True]


(* ::Subsubsection::Closed:: *)
(*Pure cosine function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z]]*Sin[z] == -f[Cos[z]] * Cos'[z]*)


Int[u_*Sin[c_.*(a_.+b_.*x_)],x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cos[c*(a+b*x)],u,x],x],x],x,Cos[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cos[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z]]*Tan[z] == -f[Cos[z]]/Cos[z] * Cos'[z]*)


Int[u_*Tan[c_.*(a_.+b_.*x_)],x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cos[c*(a+b*x)],u,x]/x,x],x],x,Cos[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cos[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z]]*Sin[2*z] == -2*f[Cos[z]]*Cos[z] * Cos'[z]*)


Int[u_*Sin[c_.*(a_.+b_.*x_)],x_Symbol] :=
  -Dist[4/(b*c),Subst[Int[Regularize[x*SubstFor[Cos[c*(a+b*x)/2],u,x],x],x],x,Cos[c*(a+b*x)/2]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cos[c*(a+b*x)/2],u,x,True]


(* ::Subsubsection::Closed:: *)
(*Pure cotangent function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is an integer, f[Cot[z]]*Tan[z]^n == -f[Cot[z]]/(Cot[z]^n*(1+Cot[z]^2)) * Cot'[z]*)


Int[u_*Tan[c_.*(a_.+b_.*x_)]^n_.,x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cot[c*(a+b*x)],u,x]/(x^n*(1+x^2)),x],x],x,Cot[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && IntegerQ[n] && FunctionOfQ[Cot[c*(a+b*x)],u,x,True] && TryPureTanSubst[u*Tan[c*(a+b*x)]^n,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cot[z]] == -f[Cot[z]]/(1+Cot[z]^2) * Cot'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Cot[a+b*x]],x]","Subst[Int[f[x]/(1+x^2),x],x,Cot[a+b*x]]/b",Hold[
  Dist[-1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cot[v],u,x]/(1+x^2),x],x],x,Cot[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Cot[v],u,x,True] && TryPureTanSubst[u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  Dist[-1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cot[v],u,x]/(1+x^2),x],x],x,Cot[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Cot[v],u,x,True] && TryPureTanSubst[u,x]]]


(* ::Subsubsection::Closed:: *)
(*Pure tangent function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is an integer, f[Tan[z]]*Cot[z]^n == f[Tan[z]]/(Tan[z]^n*(1+Tan[z]^2)) * Tan'[z]*)


Int[u_*Cot[c_.*(a_.+b_.*x_)]^n_.,x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Tan[c*(a+b*x)],u,x]/(x^n*(1+x^2)),x],x],x,Tan[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && IntegerQ[n] && FunctionOfQ[Tan[c*(a+b*x)],u,x,True] && TryPureTanSubst[u*Cot[c*(a+b*x)]^n,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Tan[z]] == f[Tan[z]]/(1+Tan[z]^2) * Tan'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Tan[a+b*x]],x]","Subst[Int[f[x]/(1+x^2),x],x,Tan[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tan[v],u,x]/(1+x^2),x],x],x,Tan[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Tan[v],u,x,True] && TryPureTanSubst[u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tan[v],u,x]/(1+x^2),x],x],x,Tan[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Tan[v],u,x,True] && TryPureTanSubst[u,x]]]


TryPureTanSubst[u_,x_Symbol] :=
  Not[MatchQ[u,ArcTan[a_.*Tan[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcTan[a_.*Cot[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcCot[a_.*Tan[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcCot[a_.*Cot[v_]] /; FreeQ[a,x]]] &&
  u===ExpnExpand[u,x]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/GeneralIntegrationRules.m0000644000175000017500000014776711446257035031775 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*General Integration Rules*)


(* ::Section::Closed:: *)
(*Simplification Rules*)


(* ::Item:: *)
(*Derivation: Algebraic simplification*)


(* Note: This needs to be done before trying trig substitution! *)
Int[u_,x_Symbol] :=
  Module[{v=TrigSimplify[u]},
  Int[v,x] /;
 v=!=u] /;
Not[MatchQ[u,w_.*(a_.+b_.*v_)^m_.*(c_.+d_.*v_)^n_. /; 
		FreeQ[{a,b,c,d},x] && IntegerQ[{m,n}] && m<0 && n<0]]


(* ::Section:: *)
(*Integration by Substitution Rules*)


(* ::Subsection::Closed:: *)
(*Derivative divides substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[g[x]]*g'[x], x] == Subst[Int[f[x], x], x, g[x]]*)


Int[u_*x_^m_.,x_Symbol] :=
  Dist[1/(m+1),Subst[Int[Regularize[SubstFor[x^(m+1),u,x],x],x],x,x^(m+1)]] /;
FreeQ[m,x] && NonzeroQ[m+1] && FunctionOfQ[x^(m+1),u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[g[x]]*g'[x], x] == Subst[Int[f[x], x], x, g[x]]*)


If[ShowSteps,

Int[u_*f_[a1___,g_[b1___,h_[c1___,v_,c2___],b2___],a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  ShowStep["","Int[f[g[x]]*g'[x],x]","Subst[Int[f[x],x],x,g[x]]",Hold[
  Dist[z,Subst[Int[f[a1,g[b1,h[c1,x,c2],b2],a2],x],x,v]]]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,b1,b2,c1,c2,f,g},x],

Int[u_*f_[a1___,g_[b1___,h_[c1___,v_,c2___],b2___],a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  Dist[z,Subst[Int[f[a1,g[b1,h[c1,x,c2],b2],a2],x],x,v]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,b1,b2,c1,c2,f,g},x]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[g[x]]*g'[x], x] == Subst[Int[f[x], x], x, g[x]]*)


If[ShowSteps,

Int[u_*f_[a1___,g_[b1___,v_,b2___],a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  ShowStep["","Int[f[g[x]]*g'[x],x]","Subst[Int[f[x],x],x,g[x]]",Hold[
  Dist[z,Subst[Int[f[a1,g[b1,x,b2],a2],x],x,v]]]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,b1,b2,f,g},x],

Int[u_*f_[a1___,g_[b1___,v_,b2___],a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  Dist[z,Subst[Int[f[a1,g[b1,x,b2],a2],x],x,v]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,b1,b2,f,g},x]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[g[x]]*g'[x], x] == Subst[Int[f[x], x], x, g[x]]*)


If[ShowSteps,

Int[u_*f_[a1___,v_,a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  ShowStep["","Int[f[g[x]]*g'[x],x]","Subst[Int[f[x],x],x,g[x]]",Hold[
  Dist[z,Subst[Int[f[a1,x,a2],x],x,v]]]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,f},x],

Int[u_*f_[a1___,v_,a2___],x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  Dist[z,Subst[Int[f[a1,x,a2],x],x,v]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag && FreeQ[{a1,a2,f},x]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[g[x]*g'[x], x] == Subst[Int[x, x], x, g[x]]*)


If[ShowSteps,

Int[u_*v_,x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  ShowStep["","Int[g[x]*g'[x],x]","Subst[Int[x,x],x,g[x]]",Hold[
  Dist[z,Subst[Int[x,x],x,v]]]] /;
 Not[FalseQ[z]]] /;
SimplifyFlag,

Int[u_*v_,x_Symbol] :=
  Module[{z=DerivativeDivides[v,u,x]},
  Dist[z,Subst[Int[x,x],x,v]] /;
 Not[FalseQ[z]]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n!=-1, Int[f[x]^n*g[x]^n*D[f[x]*g[x], x], x] == f[x]^(n+1)*g[x]^(n+1)/(n+1)*)


(* ::Item:: *)
(*Note: Need to generalize for any number of u' s raised to multiples of n!*)


If[ShowSteps,

Int[u1_^n_*u2_^n_*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u1*u2,v,x]},
  ShowStep["If nonzero[n+1],","Int[f[x]^n*g[x]^n*D[f[x]*g[x],x],x]",
							  "f[x]^(n+1)*g[x]^(n+1)/(n+1)",Hold[
  w*u1^(n+1)*u2^(n+1)/(n+1)]] /;
 Not[FalseQ[w]]] /;
SimplifyFlag && FreeQ[n,x] && NonzeroQ[n+1] && (SumQ[v] || NonsumQ[u1*u2] || NonzeroQ[n-1]),

Int[u1_^n_*u2_^n_*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u1*u2,v,x]},
  w*u1^(n+1)*u2^(n+1)/(n+1) /;
 Not[FalseQ[w]]] /;
FreeQ[n,x] && NonzeroQ[n+1] && (SumQ[v] || NonsumQ[u1*u2] || NonzeroQ[n-1])]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n!=-1, Int[f[x]^n*g[x]^n*D[f[x]*g[x], x], x] == f[x]^(n+1)*g[x]^(n+1)/(n+1)*)


If[ShowSteps,

Int[x_^m_.*u_^n_.*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[x*u,x^(m-n)*v,x]},
  ShowStep["If nonzero[n+1],","Int[f[x]^n*g[x]^n*D[f[x]*g[x],x],x]",
							  "f[x]^(n+1)*g[x]^(n+1)/(n+1)",Hold[
  w*x^(n+1)*u^(n+1)/(n+1)]] /;
 Not[FalseQ[w]]] /;
SimplifyFlag && FreeQ[n,x] && NonzeroQ[n+1] && (SumQ[v] || NonsumQ[u] || NonzeroQ[n-1]),

Int[x_^m_.*u_^n_.*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[x*u,x^(m-n)*v,x]},
  w*x^(n+1)*u^(n+1)/(n+1) /;
 Not[FalseQ[w]]] /;
FreeQ[n,x] && NonzeroQ[n+1] && (SumQ[v] || NonsumQ[u] || NonzeroQ[n-1])]


(* ::Item::Closed:: *)
(*Derivation: Integration by parts & power rule for integration*)


(* ::Item:: *)
(*Basis: If n!=-1, Int[x^m*f[x]^n*f'[x], x] == x^m*f[x]^(n+1)/(n+1) - m/(n+1)*Int[x^(m-1)*f[x]^(n+1)*)


If[ShowSteps,

Int[x_^m_.*u_^n_.*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u,v,x]},
  ShowStep["If nonzero[n+1],","Int[x^m*f[x]^n*f'[x],x]",
				"x^m*f[x]^(n+1)/(n+1) - m/(n+1)*Int[x^(m-1)*f[x]^(n+1),x]",Hold[
  w*x^m*u^(n+1)/(n+1) -
    Dist[m/(n+1)*w,Int[x^(m-1)*u^(n+1),x]]]] /;
 Not[FalseQ[w]]] /;
SimplifyFlag && FreeQ[n,x] && NonzeroQ[n+1] && RationalQ[m] && m>0 &&
	(SumQ[v] || NonsumQ[u] || NonzeroQ[n-1]),

Int[x_^m_.*u_^n_.*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u,v,x]},
  w*x^m*u^(n+1)/(n+1) -
    Dist[m/(n+1)*w,Int[x^(m-1)*u^(n+1),x]] /;
 Not[FalseQ[w]]] /;
FreeQ[n,x] && NonzeroQ[n+1] && RationalQ[m] && m>0 && (SumQ[v] || NonsumQ[u] || NonzeroQ[n-1])]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[Int[g[x], x]]*g[x], x] == Subst[Int[f[x], x], x, Int[g[x]]]*)


Int[u_*v_,x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},
  Subst[Int[Regularize[SubstFor[w,u,x],x],x],x,w] /;
 FunctionOfQ[w,u,x]] /;
SumQ[v] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[g[x]]*g'[x], x] == Subst[Int[f[x], x], x, g[x]]*)


Int[u_*(a_.+b_.*x_)^m_.,x_Symbol] :=
  Dist[1/(b*(m+1)),Subst[Int[Regularize[SubstFor[(a+b*x)^(m+1),u,x],x],x],x,(a+b*x)^(m+1)]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1] && FunctionOfQ[(a+b*x)^(m+1),u,x] (* && NonsumQ[u] *)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[(c*x)^n]/x == f[(c*x)^n]/(n*(c*x)^n)*D[(c*x)^n,x]*)


(* ::Item:: *)
(*Basis: Int[f[(c*x)^n]/x, x] == Subst[Int[f[x]/x, x], x, (c*x)^n]/n*)


If[ShowSteps,

Int[u_/x_,x_Symbol] :=
  Module[{lst=PowerVariableExpn[u,0,x]},
  ShowStep["","Int[f[(c*x)^n]/x,x]","Subst[Int[f[x]/x,x],x,(c*x)^n]/n",Hold[
  Dist[1/lst[[2]],Subst[Int[Regularize[lst[[1]]/x,x],x],x,(lst[[3]]*x)^lst[[2]]]]]] /;
 Not[FalseQ[lst]] && NonzeroQ[lst[[2]]]] /;
SimplifyFlag && NonsumQ[u] && Not[RationalFunctionQ[u,x]],

Int[u_/x_,x_Symbol] :=
  Module[{lst=PowerVariableExpn[u,0,x]},
  Dist[1/lst[[2]],Subst[Int[Regularize[lst[[1]]/x,x],x],x,(lst[[3]]*x)^lst[[2]]]] /;
 Not[FalseQ[lst]] && NonzeroQ[lst[[2]]]] /;
NonsumQ[u] && Not[RationalFunctionQ[u,x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: x^(n-1)*f[(c*x)^n] == f[(c*x)^n]/(c*n)*D[(c*x)^n,x]*)


(* ::Item:: *)
(*Basis: If g = GCD[m+1, n] > 1, Int[x^m*f[x^n], x] == Subst[Int[x^((m+1)/g-1)*f[x^(n/g)], x], x, x^g]/g*)


If[ShowSteps,

Int[u_*x_^m_.,x_Symbol] :=
  Module[{lst=PowerVariableExpn[u,m+1,x]},
  ShowStep["If g=GCD[m+1,n]>1,","Int[x^m*f[x^n],x]",
		"Subst[Int[x^((m+1)/g-1)*f[x^(n/g)],x],x,x^g]/g",Hold[
  Dist[1/lst[[2]],Subst[Int[Regularize[lst[[1]]/x,x],x],x,(lst[[3]]*x)^lst[[2]]]]]] /;
 NotFalseQ[lst] && NonzeroQ[lst[[2]]-m-1]] /;
SimplifyFlag && IntegerQ[m] && m!=-1 && NonsumQ[u] && (m>0 || Not[AlgebraicFunctionQ[u,x]]),

Int[u_*x_^m_.,x_Symbol] :=
  Module[{lst=PowerVariableExpn[u,m+1,x]},
  Dist[1/lst[[2]],Subst[Int[Regularize[lst[[1]]/x,x],x],x,(lst[[3]]*x)^lst[[2]]]] /;
 NotFalseQ[lst] && NonzeroQ[lst[[2]]-m-1]] /;
IntegerQ[m] && m!=-1 && NonsumQ[u] && (m>0 || Not[AlgebraicFunctionQ[u,x]])]


(* ::Subsection::Closed:: *)
(*Trig function product expansion rules*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


Int[u_,x_Symbol] :=
  Int[NormalForm[Expand[TrigReduce[u],x],x],x] /;
ProductQ[u] && Catch[Scan[Function[If[Not[LinearSinCosQ[#,x]],Throw[False]]],u];True]


LinearSinCosQ[u_^n_.,x_Symbol] :=
  IntegerQ[n] && n>0 && (SinQ[u] || CosQ[u]) && LinearQ[u[[1]],x]


(* ::Subsection::Closed:: *)
(*Hyperbolic function product expansion rules*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


Int[u_,x_Symbol] :=
  Int[NormalForm[Expand[TrigReduce[u],x],x],x] /;
ProductQ[u] && Catch[Scan[Function[If[Not[LinearSinhCoshQ[#,x]],Throw[False]]],u];True]


LinearSinhCoshQ[u_^n_.,x_Symbol] :=
  IntegerQ[n] && n>0 && (SinhQ[u] || CoshQ[u]) && LinearQ[u[[1]],x]


(* ::Subsection::Closed:: *)
(*Impure trig function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z]]*Sin[z] == -f[Cos[z]] * Cos'[z]*)


Int[u_*Sin[c_.*(a_.+b_.*x_)],x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cos[c*(a+b*x)],u,x],x],x],x,Cos[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cos[c*(a+b*x)],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sin[z]]*Cos[z] == f[Sin[z]] * Sin'[z]*)


Int[u_*Cos[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sin[c*(a+b*x)],u,x],x],x],x,Sin[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sin[c*(a+b*x)],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is even, f[Tan[z]]*Sec[z]^n == f[Tan[z]]*(1+Tan[z]^2)^((n-2)/2) * Tan'[z]*)


Int[u_*Sec[c_.*(a_.+b_.*x_)]^n_,x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[(1+x^2)^((n-2)/2)*SubstFor[Tan[c*(a+b*x)],u,x],x],x],x,Tan[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && EvenQ[n] && FunctionOfQ[Tan[c*(a+b*x)],u,x] && NonsumQ[u]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is even, f[Cot[z]]*Csc[z]^n == -f[Cot[z]]*(1+Cot[z]^2)^((n-2)/2) * Cot'[z]*)


Int[u_*Csc[c_.*(a_.+b_.*x_)]^n_,x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[(1+x^2)^((n-2)/2)*SubstFor[Cot[c*(a+b*x)],u,x],x],x],x,Cot[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && EvenQ[n] && FunctionOfQ[Cot[c*(a+b*x)],u,x] && NonsumQ[u]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sin[z]]*Cos[z] == f[Sin[z]] * Sin'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Sin[a+b*x]]*Cos[a+b*x],x]","Subst[Int[f[x],x],x,Sin[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Sin[v],u/Cos[v],x],x],x],x,Sin[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Sin[v],u/Cos[v],x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Sin[v],u/Cos[v],x],x],x],x,Sin[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Sin[v],u/Cos[v],x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z]]*Sin[z] == -f[Cos[z]] * Cos'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Cos[a+b*x]]*Sin[a+b*x],x]","-Subst[Int[f[x],x],x,Cos[a+b*x]]/b",Hold[
  -Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cos[v],u/Sin[v],x],x],x],x,Cos[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Cos[v],u/Sin[v],x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  -Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cos[v],u/Sin[v],x],x],x],x,Cos[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Cos[v],u/Sin[v],x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Log[Tan[z]]]*Sec[z]*Csc[z] == f[Log[Tan[z]]] * D[Log[Tan[z]], z]*)


Int[u_*Sec[a_.+b_.*x_]*Csc[a_.+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[SubstFor[Log[Tan[a+b*x]],u,x],x],x],x,Log[Tan[a+b*x]]]] /;
FreeQ[{a,b},x] && FunctionOfQ[Log[Tan[a+b*x]],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Log[Cot[z]]]*Sec[z]*Csc[z] == -f[Log[Cot[z]]] * D[Log[Cot[z]], z]*)


Int[u_*Sec[a_.+b_.*x_]*Csc[a_.+b_.*x_],x_Symbol] :=
  -Dist[1/b,Subst[Int[Regularize[SubstFor[Log[Cot[a+b*x]],u,x],x],x],x,Log[Cot[a+b*x]]]] /;
FreeQ[{a,b},x] && FunctionOfQ[Log[Cot[a+b*x]],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cos[z/2]*Sin[z/2]]*Cos[z] == 2*f[Cos[z/2]*Sin[z/2]] * D[Cos[z/2]*Sin[z/2], z]*)


Int[u_*Cos[a_.+b_.*x_],x_Symbol] :=
  Dist[2/b,Subst[Int[Regularize[SubstFor[Cos[a/2+b/2*x]*Sin[a/2+b/2*x],u,x],x],x],x,
				Cos[a/2+b/2*x]*Sin[a/2+b/2*x]]] /;
NonsumQ[u] && FreeQ[{a,b},x] && FunctionOfQ[Cos[a/2+b/2*x]*Sin[a/2+b/2*x],u,x]


(* ::Subsection::Closed:: *)
(*Impure hyperbolic function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cosh[z]]*Sinh[z] == f[Cosh[z]] * Cosh'[z]*)


Int[u_*Sinh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cosh[c*(a+b*x)],u,x],x],x],x,Cosh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cosh[c*(a+b*x)],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sinh[z]]*Cosh[z] == f[Sinh[z]] * Sinh'[z]*)


Int[u_*Cosh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sinh[c*(a+b*x)],u,x],x],x],x,Sinh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sinh[c*(a+b*x)],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is even, f[Tanh[z]]*Sech[z]^n == f[Tanh[z]]*(1-Tanh[z]^2)^((n-2)/2) * Tanh'[z]*)


Int[u_*Sech[c_.*(a_.+b_.*x_)]^n_,x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[(1-x^2)^((n-2)/2)*SubstFor[Tanh[c*(a+b*x)],u,x],x],x],x,Tanh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && EvenQ[n] && FunctionOfQ[Tanh[c*(a+b*x)],u,x] && NonsumQ[u]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is even, f[Coth[z]]*Csch[z]^n == -f[Coth[z]]*(-1+Coth[z]^2)^((n-2)/2) * Coth'[z]*)


Int[u_*Csch[c_.*(a_.+b_.*x_)]^n_,x_Symbol] :=
  -Dist[1/(b*c),Subst[Int[Regularize[(-1+x^2)^((n-2)/2)*SubstFor[Coth[c*(a+b*x)],u,x],x],x],x,Coth[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && EvenQ[n] && FunctionOfQ[Coth[c*(a+b*x)],u,x] && NonsumQ[u]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[Sinh[a+b*x]]*Cosh[a+b*x], x] == Subst[Int[f[x], x], x, Sinh[a+b*x]]/b*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  ShowStep["","Int[f[Sinh[a+b*x]]*Cosh[a+b*x],x]","Subst[Int[f[x],x],x,Sinh[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Sinh[v],u/Cosh[v],x],x],x],x,Sinh[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Sinh[v],u/Cosh[v],x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Sinh[v],u/Cosh[v],x],x],x],x,Sinh[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Sinh[v],u/Cosh[v],x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[Cosh[a+b*x]]*Sinh[a+b*x], x] == Subst[Int[f[x], x], x, Cosh[a+b*x]]/b*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  ShowStep["","Int[f[Cosh[a+b*x]]*Sinh[a+b*x],x]","Subst[Int[f[x],x],x,Cosh[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cosh[v],u/Sinh[v],x],x],x],x,Cosh[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Cosh[v],u/Sinh[v],x] (* && Not[FunctionOfQ[Tanh[v],u,x]] *)] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cosh[v],u/Sinh[v],x],x],x],x,Cosh[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Cosh[v],u/Sinh[v],x] (* && Not[FunctionOfQ[Tanh[v],u,x]] *)]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Log[Tanh[z]]]*Sech[z]*Csch[z] == f[Log[Tanh[z]]] * D[Log[Tanh[z]], z]*)


Int[u_*Sech[a_.+b_.*x_]*Csch[a_.+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[SubstFor[Log[Tanh[a+b*x]],u,x],x],x],x,Log[Tanh[a+b*x]]]] /;
FreeQ[{a,b},x] && FunctionOfQ[Log[Tanh[a+b*x]],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Log[Coth[z]]]*Sech[z]*Csch[z] == -f[Log[Coth[z]]] * D[Log[Coth[z]], z]*)


Int[u_*Sech[a_.+b_.*x_]*Csch[a_.+b_.*x_],x_Symbol] :=
  -Dist[1/b,Subst[Int[Regularize[SubstFor[Log[Coth[a+b*x]],u,x],x],x],x,Log[Coth[a+b*x]]]] /;
FreeQ[{a,b},x] && FunctionOfQ[Log[Coth[a+b*x]],u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cosh[z/2]*Sinh[z/2]]*Cosh[z] == 2*f[Cosh[z/2]*Sinh[z/2]] * D[Cosh[z/2]*Sinh[z/2], z]*)


Int[u_*Cosh[a_.+b_.*x_],x_Symbol] :=
  Dist[2/b,Subst[Int[Regularize[SubstFor[Cosh[a/2+b/2*x]*Sinh[a/2+b/2*x],u,x],x],x],x,
				Cosh[a/2+b/2*x]*Sinh[a/2+b/2*x]]] /;
NonsumQ[u] && FreeQ[{a,b},x] && FunctionOfQ[Cosh[a/2+b/2*x]*Sinh[a/2+b/2*x],u,x]


(* ::Subsection::Closed:: *)
(*Derivative divides substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[x^m*f[x]^(-1+a*x^m)*f'[x], x] == f[x]^(a*x^m)/a - m*Int[x^(m-1)*f[x]^(a*x^m)*Log[f[x]], x]*)


If[ShowSteps,

Int[x_^m_.*u_^(-1+a_.*x_^m_.)*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u,v,x]},
  ShowStep["If m>0,","Int[x^m*f[x]^(-1+a*x^m)*f'[x],x]",
				"f[x]^(a*x^m)/a - m*Int[x^(m-1)*f[x]^(a*x^m)*Log[f[x]],x]",Hold[
  w*u^(a*x^m)/a -
    Dist[m*w,Int[x^(m-1)*u^(a*x^m)*Log[u],x]]]] /;
 Not[FalseQ[w]]] /;
SimplifyFlag && FreeQ[a,x] && RationalQ[m] && m>0,

Int[x_^m_.*u_^(-1+a_.*x_^m_.)*v_,x_Symbol] :=
  Module[{w=DerivativeDivides[u,v,x]},
  w*u^(a*x^m)/a -
    Dist[m*w,Int[x^(m-1)*u^(a*x^m)*Log[u],x]] /;
 Not[FalseQ[w]]] /;
FreeQ[a,x] && RationalQ[m] && m>0]


(* ::Subsection:: *)
(*Trig function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cot[z]] == -f[Cot[z]]/(1+Cot[z]^2) * Cot'[z]*)


(* If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Cot[a+b*x]],x]","-Subst[Int[f[x]/(1+x^2),x],x,Cot[a+b*x]]/b",Hold[
  -Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cot[v],u,x]/(1+x^2),x],x],x,Cot[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Cot[v],u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  -Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Cot[v],u,x]/(1+x^2),x],x],x,Cot[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Cot[v],u,x]]] *)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Tan[z]] == f[Tan[z]]/(1+Tan[z]^2) * Tan'[z]*)


(* If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  ShowStep["","Int[f[Tan[a+b*x]],x]","Subst[Int[f[x]/(1+x^2),x],x,Tan[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tan[v],u,x]/(1+x^2),x],x],x,Tan[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Tan[v],u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfTrig[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tan[v],u,x]/(1+x^2),x],x],x,Tan[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Tan[v],u,x]]] *)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Tan[z]] == f[Tan[z]]/(1+Tan[z]^2) * Tan'[z]*)


Int[u_,x_Symbol] :=
  Subst[Int[Regularize[SubstFor[Tan[x],u,x]/(1+x^2),x],x],x,Tan[x]] /;
FunctionOfQ[Tan[x],u,x] && FunctionOfTanWeight[u,x,x]>=0 && TryTanSubst[u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cot[z]] == -f[Cot[z]]/(1+Cot[z]^2) * Cot'[z]*)


Int[u_,x_Symbol] :=
  -Subst[Int[Regularize[SubstFor[Cot[x],u,x]/(1+x^2),x],x],x,Cot[x]] /;
FunctionOfQ[Cot[x],u,x] && FunctionOfTanWeight[u,x,x]<0 && TryTanSubst[u,x]


TryTanSubst[u_,x_Symbol] :=
  FalseQ[FunctionOfLinear[u,x]] &&
  Not[MatchQ[u,r_.*(s_+t_)^n_. /; IntegerQ[n] && n>0]] &&
  Not[MatchQ[u,Log[f_[x]^2] /; SinCosQ[f]]]  &&
  Not[MatchQ[u,1/(a_+b_.*f_[x]^n_) /; SinCosQ[f] && IntegerQ[n] && n>2]] &&
  Not[MatchQ[u,f_[m_.*x]*g_[n_.*x] /; IntegerQ[{m,n}] && SinCosQ[f] && SinCosQ[g]]] &&
  Not[MatchQ[u,r_.*(a_.*s_^m_)^p_ /; FreeQ[{a,m,p},x] && Not[m===2 && (s===Sec[x] || s===Csc[x])]]] &&
(*u===TrigSimplify[u] && *)
  u===ExpnExpand[u,x]


(* ::Subsection:: *)
(*Hyperbolic function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Tanh[z]] == f[Tanh[z]] / (1-Tanh[z]^2) * Tanh'[z]*)


Int[u_,x_Symbol] :=
  Subst[Int[Regularize[SubstFor[Tanh[x],u,x]/(1-x^2),x],x],x,Tanh[x]] /;
FunctionOfQ[Tanh[x],u,x] && FunctionOfTanhWeight[u,x,x]>=0 && TryTanhSubst[u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Coth[z]] == f[Coth[z]] / (1-Coth[z]^2) * Coth'[z]*)


Int[u_,x_Symbol] :=
  Subst[Int[Regularize[SubstFor[Coth[x],u,x]/(1-x^2),x],x],x,Coth[x]] /;
FunctionOfQ[Coth[x],u,x] && FunctionOfTanhWeight[u,x,x]<0 && TryTanhSubst[u,x]


TryTanhSubst[u_,x_Symbol] :=
  FalseQ[FunctionOfLinear[u,x]] &&
  Not[MatchQ[u,r_.*(s_+t_)^n_. /; IntegerQ[n] && n>0]] &&
  Not[MatchQ[u,Log[f_[x]^2] /; SinhCoshQ[f]]]  &&
  Not[MatchQ[u,1/(a_+b_.*f_[x]^n_) /; SinhCoshQ[f] && IntegerQ[n] && n>2]] &&
  Not[MatchQ[u,f_[m_.*x]*g_[n_.*x] /; IntegerQ[{m,n}] && SinhCoshQ[f] && SinhCoshQ[g]]] &&
  Not[MatchQ[u,r_.*(a_.*s_^m_)^p_ /; FreeQ[{a,m,p},x] && Not[m===2 && (s===Sech[x] || s===Csch[x])]]] &&
(*u===TrigSimplify[u] && *)
  u===ExpnExpand[u,x]


(* ::Subsection::Closed:: *)
(*Exponential function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[E^(a+b*x)], x] == Subst[Int[f[x]/x, x], x, E^(a+b*x)]/b*)


(* ::Item:: *)
(*Basis: Int[g[f^(a+b*x)], x] == Subst[Int[g[x]/x, x], x, f^(a+b*x)]/(b*Log[f])*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfExponentialOfLinear[u,x]},
  If[lst[[4]]===E,
    ShowStep["","Int[f[E^(a+b*x)],x]","Subst[Int[f[x]/x,x],x,E^(a+b*x)]/b",Hold[
    Dist[1/lst[[3]],Subst[Int[Regularize[lst[[1]]/x,x],x],x,E^(lst[[2]]+lst[[3]]*x)]]]],
  ShowStep["","Int[g[f^(a+b*x)],x]","Subst[Int[g[x]/x,x],x,f^(a+b*x)]/(b*Log[f])",Hold[
  Dist[1/(lst[[3]]*Log[lst[[4]]]),
       Subst[Int[Regularize[lst[[1]]/x,x],x],x,lst[[4]]^(lst[[2]]+lst[[3]]*x)]]]]] /;
 Not[FalseQ[lst]]] /;
SimplifyFlag && 
Not[MatchQ[u,v_^n_. /; SumQ[v] && IntegerQ[n] && n>0]] &&
Not[MatchQ[u,v_^n_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,f},x] && SumQ[v] && IntegerQ[n] && n>0]] &&
Not[MatchQ[u,1/(a_.+b_.*f_^(d_.+e_.*x)+c_.*f_^(g_.+h_.*x)) /; 
	FreeQ[{a,b,c,d,e,f,g,h},x] && ZeroQ[g-2*d] && ZeroQ[h-2*e]]] &&
FalseQ[FunctionOfHyperbolic[u,x]] (* && u===ExpnExpand[u,x] *),

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfExponentialOfLinear[u,x]},
  Dist[1/(lst[[3]]*Log[lst[[4]]]),
	   Subst[Int[Regularize[lst[[1]]/x,x],x],x,lst[[4]]^(lst[[2]]+lst[[3]]*x)]] /;
 Not[FalseQ[lst]]] /;
Not[MatchQ[u,v_^n_. /; SumQ[v] && IntegerQ[n] && n>0]] &&
Not[MatchQ[u,v_^n_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,f},x] && SumQ[v] && IntegerQ[n] && n>0]] &&
Not[MatchQ[u,1/(a_.+b_.*f_^(d_.+e_.*x)+c_.*f_^(g_.+h_.*x)) /; 
	FreeQ[{a,b,c,d,e,f,g,h},x] && ZeroQ[g-2*d] && ZeroQ[h-2*e]]] &&
FalseQ[FunctionOfHyperbolic[u,x]] (* && u===ExpnExpand[u,x] *) ]


(* ::Subsection::Closed:: *)
(*Improper binomial subexpressions substitution rules*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*f_^(a_.+b_.*x_^n_.),x_Symbol] :=
  -Subst[Int[f^(a+b*x^(-n))/x^(m+2),x],x,1/x] /;
FreeQ[{a,b,f},x] && IntegerQ[{m,n}] && n<0 && m<-1 && GCD[m+1,n]==1


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*f_[a_.+b_.*x_^n_]^p_.,x_Symbol] :=
  -Subst[Int[f[a+b*x^(-n)]^p/x^(m+2),x],x,1/x] /;
FreeQ[{a,b,f,p},x] && IntegerQ[{m,n}] && n<0 && m<-1 && GCD[m+1,n]==1


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification and distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(a+b*x^n)^m/(x^(m*n)*(b+a/x^n)^m), x] == 0*)


Int[u_*(a_+b_.*x_^n_)^m_,x_Symbol] :=
  (a+b*x^n)^m/(x^(m*n)*(b+a/x^n)^m)*Int[u*x^(m*n)*(b+a/x^n)^m,x] /;
FreeQ[{a,b},x] && FractionQ[m] && IntegerQ[n] && n<-1 && u===ExpnExpand[u,x]


(* ::Subsection::Closed:: *)
(*Fractional power subexpressions substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[(a+b*x)^(1/n), x], x] == n/b*Subst[Int[x^(n-1)*f[x, -a/b+x^n/b], x], x, (a+b*x)^(1/n)]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfLinear[u,x]},
  ShowStep["","Int[f[(a+b*x)^(1/n),x],x]",
			"n/b*Subst[Int[x^(n-1)*f[x,-a/b+x^n/b],x],x,(a+b*x)^(1/n)]",Hold[
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]]]] /;
 NotFalseQ[lst] && SubstForFractionalPowerQ[u,lst[[3]],x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfLinear[u,x]},
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]] /;
 NotFalseQ[lst] && SubstForFractionalPowerQ[u,lst[[3]],x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[((a+b*x)/(c+d*x))^(1/n), x], x] == *)
(*			n*(b*c-a*d)*Subst[Int[x^(n-1)*f[x, (-a+c*x^n)/(b-d*x^n)]/(b-d*x^n)^2, x], x, ((a+b*x)/(c+d*x))^(1/n)]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfQuotientOfLinears[u,x]},
  ShowStep["","Int[f[((a+b*x)/(c+d*x))^(1/n),x],x]",
	"n*(b*c-a*d)*Subst[Int[x^(n-1)*f[x,(-a+c*x^n)/(b-d*x^n)]/(b-d*x^n)^2,x],x,((a+b*x)/(c+d*x))^(1/n)]",Hold[
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]]]] /;
 NotFalseQ[lst]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfQuotientOfLinears[u,x]},
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]] /;
 NotFalseQ[lst]]]


(* ::Subsection::Closed:: *)
(*Linear subexpressions substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x], x] == Subst[Int[f[x], x], x, a+b*x]/b*)


Int[u_*(a_+b_.*x_)^m_.,x_Symbol] :=
  Dist[1/b,Subst[Int[x^m*Regularize[SubstFor[a+b*x,u,x],x],x],x,a+b*x]] /;
FreeQ[{a,b,m},x] && FunctionOfQ[a+b*x,u,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x, x], x] == Subst[Int[f[x, -a/b+x/b], x], x, a+b*x]/b*)


Int[x_^m_./(a_+b_.*(c_+d_.*x_)^n_), x_Symbol] :=
  Dist[1/d,Subst[Int[(-c/d+x/d)^m/(a+b*x^n),x],x,c+d*x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[{m,n}] && n>2


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[(e_+f_.*x_)^m_.*(a_+b_.*(c_+d_.*x_)^n_)^p_, x_Symbol] :=
  Dist[(f/d)^m/d,Subst[Int[x^m*(a+b*x^n)^p,x],x,c+d*x]] /;
FreeQ[{a,b,c,d,e,f},x] && IntegerQ[{m,n,p}] && ZeroQ[d*e-c*f]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x, x], x] == Subst[Int[f[x, -a/b+x/b], x], x, a+b*x]/b*)


Int[(a_.+b_.*x_)^m_.*f_[c_.+d_.*x_]^p_.,x_Symbol] :=
  Dist[1/b,Subst[Int[x^m*f[c-a*d/b+d*x/b]^p,x],x,a+b*x]] /;
FreeQ[{a,b,c,d,m},x] && RationalQ[p] && Not[a===0 && b===1] &&
	MemberQ[{Sin,Cos,Sec,Csc,Sinh,Cosh,Sech,Csch},f]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x, x], x] == Subst[Int[f[x, -a/b+x/b], x], x, a+b*x]/b*)


Int[(a_.+b_.*x_)^m_*(c_.+d_.*x_+e_.*x_^2)^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[x^m*(c-a*d/b+a^2*e/b^2+(d/b-2*a*e/b^2)*x+e*x^2/b^2)^n,x],x,a+b*x]] /;
FreeQ[{a,b,c,d,e,m,n},x] && FractionQ[n] && Not[a===0 && b===1]


(* ::Section::Closed:: *)
(*Integration by Parts Rules*)


(* ::Subsection::Closed:: *)
(*Extended integration by parts rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: Int[(g[x]+h[x])^n*g'[x],x] == (g[x]+h[x])^(n+1)/(n+1) - Int[(g[x]+h[x])^n*h'[x], x]*)


Int[(u_+x_^p_.)^n_*v_,x_Symbol] :=
  Module[{z=DerivativeDivides[u,v,x]},
  z*(u+x^p)^(n+1)/(n+1) -
  Dist[z*p,Int[x^(p-1)*(u+x^p)^n,x]] /;
 Not[FalseQ[z]]] /;
IntegerQ[p] && RationalQ[n] && NonzeroQ[n+1] && Not[AlgebraicFunctionQ[v,x]]


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: Int[f[x]*(g[x]+h[x])^n*g'[x],x] == f[x]*(g[x]+h[x])^(n+1)/(n+1) - Int[f[x]*(g[x]+h[x])^n*h'[x], x] - Int[f'[x]*(g[x]+h[x])^(n+1), x]/(n+1)*)


Int[x_^m_.*(u_+x_^p_.)^n_*v_,x_Symbol] :=
  Module[{z=DerivativeDivides[u,v,x]},
  z*x^m*(u+x^p)^(n+1)/(n+1) -
  Dist[z*p,Int[x^(m+p-1)*(u+x^p)^n,x]] -
  Dist[z*m/(n+1),Int[x^(m-1)*(u+x^p)^(n+1),x]] /;
 Not[FalseQ[z]]] /;
IntegerQ[{m,p}] && RationalQ[n] && NonzeroQ[n+1]


(* ::Subsection::Closed:: *)
(*Logarithm rules (move to log rules!)*)


(* ::Item::Closed:: *)
(*Reference: A&S 4.1.53*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[u_],x_Symbol] :=
  x*Log[u] -
  Int[Regularize[x*D[u,x]/u,x],x] /;
InverseFunctionFreeQ[u,x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.727.2*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[u_]/x_,x_Symbol] :=
  Module[{v=D[u,x]/u},
  Log[u]*Log[x] -
  Int[Regularize[Log[x]*v,x],x] /;
 RationalFunctionQ[v,x]] /;
Not[BinomialTest[u,x] && BinomialTest[u,x][[3]]^2===1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.727.2*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[u_]/(a_+b_.*x_),x_Symbol] :=
  Module[{v=D[u,x]/u},
  Log[u]*Log[a+b*x]/b -
  Dist[1/b,Int[Regularize[Log[a+b*x]*v,x],x]] /;
 RationalFunctionQ[v,x]] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.725.1, A&S 4.1.54*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(a_.+b_.*x_)^m_.*Log[u_],x_Symbol] :=
  Module[{v=D[u,x]/u},
  (a+b*x)^(m+1)*Log[u]/(b*(m+1)) -
  Dist[1/(b*(m+1)),Int[Regularize[(a+b*x)^(m+1)*v,x],x]]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1] && InverseFunctionFreeQ[u,x] && 
	Not[FunctionOfQ[x^(m+1),u,x]] && 
	FalseQ[PowerVariableExpn[u,m+1,x]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[v_*Log[u_],x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},  
  w*Log[u] -
    Int[Regularize[w*D[u,x]/u,x],x] /;
 InverseFunctionFreeQ[w,x]] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[v, x^m_. /; FreeQ[m,x]]] &&
	FalseQ[FunctionOfLinear[v*Log[u],x]]


(* ::Section::Closed:: *)
(*Algebraic Expansion Rules*)


(* ::Subsection::Closed:: *)
(*Reciprocals of quadratic trinomial expansion rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[-a/b], z/(a+b*z^2) == q/(2*(a+b*q*z)) - q/(2*(a-b*q*z))*)


Int[u_.*x_/(a_+b_.*x_^2),x_Symbol] :=
  Module[{q=Rt[-a/b,2]},
  Dist[q/2,Int[u/(a+b*q*x),x]] -
  Dist[q/2,Int[u/(a-b*q*x),x]]] /;
FreeQ[{a,b},x] && Not[MatchQ[u,r_*s_. /; SumQ[r]]] && Not[RationalFunctionQ[u,x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], z/(a+b*z+c*z^2) == (1+b/q)/(b+q+2*c*z) + (1-b/q)/(b-q+2*c*z))*)


Int[u_.*v_^m_./(a_+b_.*v_+c_.*w_),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[(1+b/q),Int[u*v^(m-1)/(b+q+2*c*v),x]] + Dist[(1-b/q),Int[u*v^(m-1)/(b-q+2*c*v),x]] /;
 NonzeroQ[q]] /;
FreeQ[{a,b,c},x] && RationalQ[m] && m==1 && ZeroQ[w-v^2] && 
		Not[MatchQ[u,r_*s_. /; SumQ[r]]] && (Not[RationalFunctionQ[u,x]] || Not[RationalFunctionQ[v,x]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], (d+e*z)/(a+b*z+c*z^2) == (e-2*c*d/q+b*e/q)/(b+q+2*c*z)) + (e+2*c*d/q-b*e/q)/(b-q+2*c*z)*)


Int[(d_.+e_.*v_)/(a_+b_.*v_+c_.*w_),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
    Dist[e+(b*e-2*c*d)/q,Int[1/(b+q+2*c*v),x]] + Dist[e-(b*e-2*c*d)/q,Int[1/(b-q+2*c*v),x]] /;
 NonzeroQ[q]] /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[w-v^2] && NonzeroQ[2*c*d-b*e] && Not[RationalFunctionQ[v,x]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.161.1 a'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4*a*c], 1/(a+b*z+c*z^2) == 2*c/(q*(b-q+2*c*z)) - 2*c/(q*(b+q+2*c*z))*)


Int[u_./(a_+b_.*v_+c_.*w_),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[2*c/q,Int[u/(b-q+2*c*v),x]] - Dist[2*c/q,Int[u/(b+q+2*c*v),x]] /;
 NonzeroQ[q]] /;
FreeQ[{a,b,c},x] && ZeroQ[w-v^2] && Not[MatchQ[u,v^m_ /; RationalQ[m]]] &&
		Not[MatchQ[u,r_*s_. /; SumQ[r]]] && (Not[RationalFunctionQ[u,x]] || Not[RationalFunctionQ[v,x]])


(* ::Subsection::Closed:: *)
(*General algebraic simplification rules*)


(* ::Item:: *)
(*Derivation: Algebraic simplification*)


Int[u_,x_Symbol] :=
  Module[{v=SimplifyExpression[u,x]},
  Int[v,x] /;
 v=!=u ]


(* ::Subsection::Closed:: *)
(*Fractional powers of powers and products distribution rules*)


(* ::Item:: *)
(*Derivation: Distribution of fractional powers*)


Int[u_.*(v_^m_.*w_^n_.*t_^q_.)^p_,x_Symbol] :=
  Int[u*v^(m*p)*w^(n*p)*t^(p*q),x] /;
FreeQ[p,x] && Not[PowerQ[v]] && Not[PowerQ[w]] && Not[PowerQ[t]] &&
	ZeroQ[Simplify[(v^m*w^n*t^q)^p-v^(m*p)*w^(n*p)*t^(p*q)]]


(* ::Item:: *)
(*Derivation: Distribution of fractional powers*)


Int[u_.*(v_^m_.*w_^n_.*t_^q_.)^p_,x_Symbol] :=
  Module[{r=Simplify[(v^m*w^n*t^q)^p/(v^(m*p)*w^(n*p)*t^(p*q))],lst},
  ( lst=SplitFreeFactors[v^(m*p)*w^(n*p)*t^(p*q),x];
  r*lst[[1]]*Int[Regularize[u*lst[[2]],x],x] ) /;
 NonzeroQ[r-1]] /;
FreeQ[p,x] && Not[PowerQ[v]] && Not[PowerQ[w]] && Not[PowerQ[t]]


(* ::Subsection::Closed:: *)
(*General algebraic expansion rules*)


(* ::Item::Closed:: *)
(*Author: Martin 13 July 2010*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == b*Product[z - (-a/b)^(1/n)*(-1)^(2*k/n), {k, 1, n}]*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == a*Product[1 - z/((-a/b)^(1/n)*(-1)^(2*k/n)), {k, 1, 4}]*)


(* ::Item:: *)
(*Basis: If m and n are integers and 0<=m0 is an integer let q=(-a/b)^(1/n), then 1/(a+b*z^n) == q*Sum[(-1)^(2*k/n)/(q*(-1)^(2*k/n) - z), {k, 1, n}]/(a*n)*)


Int[u_/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,n]], s=Denominator[Rt[-a/b,n]]},
  Dist[r/(a*n), Sum[Int[u*(-1)^(2*k/n)/(r*(-1)^(2*k/n)-s*x),x],{k,1,n}]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1 && Not[AlgebraicFunctionQ[u,x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == b*Product[z - (-a/b)^(1/n)*(-1)^(2*k/n), {k, 1, n}]*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, z^(n-1)/(a+b*z^n) == Sum[1/(z - (-a/b)^(1/n)*(-1)^(2*k/n)), {k, 1, n}]/(b*n)*)


Int[u_.*v_^m_/(a_+b_.*v_^n_),x_Symbol] :=
  Dist[1/(b*n),Sum[Int[Together[u/(v-Rt[-a/b,n]*(-1)^(2*k/n))],x],{k,1,n}]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1 && ZeroQ[m-n+1] && Not[AlgebraicFunctionQ[u,x] && AlgebraicFunctionQ[v,x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == a*Product[1 - z/((-a/b)^(1/n)*(-1)^(2*k/n)), {k, 1, 4}]*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, 1/(a+b*z^n) == Sum[1/(1 - z/((-a/b)^(1/n)*(-1)^(2*k/n))), {k, 1, n}]/(a*n)*)


Int[u_./(a_+b_.*v_^n_),x_Symbol] :=
  Dist[1/(a*n),Sum[Int[Together[u/(1-v/(Rt[-a/b,n]*(-1)^(2*k/n)))],x],{k,1,n}]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1 && Not[AlgebraicFunctionQ[u,x] && AlgebraicFunctionQ[v,x]]


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


Int[u_,x_Symbol] :=
  Module[{v=ExpnExpand[u,x]},
  Int[v,x] /;
 v=!=u ]


(* ::Subsection::Closed:: *)
(*Function of linear binomial substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[1/(a+b*x)], x] == -Subst[Int[f[x]/x^2, x], x, 1/(a+b*x)]/b*)


(* ::Item:: *)
(*Basis: Int[f[(a+b*x)/(c+d*x)], x] == -Subst[Int[f[b/d+(a*d-b*c)/d*x]/x^2, x], x, 1/(c+d*x)]/d*)


If[ShowSteps, 

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseLinear[u,x]},
  ShowStep["","Int[f[1/(a+b*x)],x]","-Subst[Int[f[x]/x^2,x],x,1/(a+b*x)]/b",Hold[
  -Dist[1/lst[[3]],Subst[Int[lst[[1]]/x^2,x],x,1/lst[[2]]]]]] /;
 NotFalseQ[lst]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseLinear[u,x]},
  -Dist[1/lst[[3]],Subst[Int[lst[[1]]/x^2,x],x,1/lst[[2]]]] /;
 NotFalseQ[lst]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x], x] == Subst[Int[f[x], x], x, a+b*x]/b*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfLinear[u,x]},
  ShowStep["","Int[f[a+b*x],x]","Subst[Int[f[x],x],x,a+b*x]/b",Hold[
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]+lst[[3]]*x]]]] /;
 Not[FalseQ[lst]]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfLinear[u,x]},
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]+lst[[3]]*x]] /;
 Not[FalseQ[lst]]]]


(* ::Subsection::Closed:: *)
(*Negative powers of binomials expansion rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is even, 1/(a+b*z^n) == 2/(a*n)*Sum[1/(1-z^2/((-a/b)^(2/n)*(-1)^(4*k/n))), {k, 1, n/2}]*)


Int[u_./(a_+b_.*v_^n_),x_Symbol] :=
  Dist[2/(a*n),Sum[Int[Together[u/(1-v^2/(Rt[-a/b,n/2]*(-1)^(4*k/n)))],x],{k,1,n/2}]] /;
FreeQ[{a,b},x] && EvenQ[n] && n>2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is even, a+b*z^n == a*Product[1-(-1)^(4*k/n)*(-b/a)^(2/n)*z^2, {k, 1, n/2}]*)


Int[u_.*(a_+b_.*v_^n_)^m_,x_Symbol] :=
  Dist[a^m,Int[u*Product[(1-(-1)^(4*k/n)*Rt[-b/a,n/2]*v^2)^m,{k,1,n/2}],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-1 && EvenQ[n] && n>2 (* && NegQ[b/a] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == b*Product[-(-a/b)^(1/n)*(-1)^(2*k/n) + z, {k, 1, n}]*)


(* ::Item:: *)
(*Basis: If n>0 is an integer, a+b*z^n == a*Product[1-(-1)^(2*k/n)*(-b/a)^(1/n)*z, {k, 1, n}]*)


(* ::Item:: *)
(*Basis: If n>0 is odd, a+b*z^n == a*Product[1+(-1)^(2*k/n)*(b/a)^(1/n)*z, {k, 1, n}]*)


Int[u_.*(a_+b_.*v_^n_)^m_,x_Symbol] :=
  Dist[a^m,Int[u*Product[(1+(-1)^(2*k/n)*Rt[b/a,n]*v)^m,{k,1,n}],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-1 && OddQ[n] && n>1


(* ::Subsection::Closed:: *)
(*Negative powers of trinomials expansion rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*z+c*z^2 == (b-Sqrt[b^2-4*a*c]+2*c*z)*(b+Sqrt[b^2-4*a*c]+2*c*z)/(4*c)*)


Int[u_.*(a_+b_.*v_+c_.*w_)^m_,x_Symbol] :=
  Dist[1/(4*c)^m,Int[u*(b-Sqrt[b^2-4*a*c]+2*c*v)^m*(b+Sqrt[b^2-4*a*c]+2*c*v)^m,x]] /;
FreeQ[{a,b,c},x] && IntegerQ[m] && m<0 && ZeroQ[w-v^2]


(* ::Subsection::Closed:: *)
(*Normalization rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Note: Replace this rule with specific rules for each normalization.*)


Int[u_,x_Symbol] :=
  Module[{v=NormalForm[u,x]},
  Int[v,x] /;
 Not[v===u]]


(* ::Subsection::Closed:: *)
(*Fractional powers of powers and products distribution rules*)


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(f[x]^m)^p/f[x]^(m*p), x] == 0*)


Int[u_.*(v_^m_)^p_, x_Symbol] :=
  Module[{q=FractionalPart[p]},
  (v^m)^q/v^(m*q)*Int[u*v^(m*p),x]] /;
FreeQ[m,x] && FractionQ[p]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(a*f[x]^m)^p/f[x]^(m*p), x] == 0*)


Int[u_.*(a_*v_^m_.)^p_, x_Symbol] :=
  Module[{q=FractionalPart[p]},
  a^(p-q)*(a*v^m)^q/v^(m*q)*Int[u*v^(m*p),x]] /;
FreeQ[{a,m},x] && FractionQ[p]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(a*f[x]^m*g[x]^n)^p/(f[x]^(m*p)*g[x]^(n*p)), x] == 0*)


Int[u_.*(a_.*v_^m_.*w_^n_.)^p_, x_Symbol] :=
  Module[{q=FractionalPart[p]},
  a^(p-q)*(a*v^m*w^n)^q/(v^(m*q)*w^(n*q))*Int[u*v^(m*p)*w^(n*p),x]] /;
FreeQ[a,x] && RationalQ[{m,n,p}]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(f[x]^m)^p/f[x]^(m*p), x] == 0*)


Int[u_.*(v_^m_)^p_,x_Symbol] :=
  Int[u*v^(m*p),x] /;
FreeQ[p,x] && Not[PowerQ[v]] && ZeroQ[Simplify[(v^m)^p-v^(m*p)]]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(f[x]^m)^p/f[x]^(m*p), x] == 0*)


Int[u_.*(v_^m_)^p_,x_Symbol] :=
  Module[{r=Simplify[(v^m)^p/v^(m*p)]},
  r*Int[Regularize[u*v^(m*p),x],x] /;
 NonzeroQ[r-1]] /;
FreeQ[p,x] && Not[PowerQ[v]]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(f[x]^m*g[x]^n)^p/(f[x]^(m*p)*g[x]^(n*p)), x] == 0*)


Int[u_.*(v_^m_.*w_^n_.)^p_,x_Symbol] :=
  Int[u*v^(m*p)*w^(n*p),x] /;
FreeQ[p,x] && Not[PowerQ[v]] && Not[PowerQ[w]] && ZeroQ[Simplify[(v^m*w^n)^p-v^(m*p)*w^(n*p)]]


(* ::Item::Closed:: *)
(*Derivation: Distribution of fractional powers*)


(* ::Item:: *)
(*Basis: D[(f[x]^m*g[x]^n)^p/(f[x]^(m*p)*g[x]^(n*p)), x] == 0*)


(* Valid because the derivative of (f[x]^m*g[x]^n)^p/(f[x]^(m*p)*g[x]^(n*p)) wrt x is 0. *)
Int[u_.*(v_^m_.*w_^n_.)^p_,x_Symbol] :=
  Module[{r=Simplify[(v^m*w^n)^p/(v^(m*p)*w^(n*p))],lst},
  ( lst=SplitFreeFactors[v^(m*p)*w^(n*p),x];
    r*lst[[1]]*Int[Regularize[u*lst[[2]],x],x] ) /;
 NonzeroQ[r-1]] /;
FreeQ[p,x] && Not[PowerQ[v]] && Not[PowerQ[w]]


(* ::Subsection::Closed:: *)
(*Products of fractional powers collection rules*)


(* ::Item::Closed:: *)
(*Derivation: Collection of fractional powers*)


(* ::Item:: *)
(*Basis: D[f[x]^m/g[x]^m/(f[x]/g[x])^m, x] == 0*)


(* ::Item:: *)
(*Basis: Int[v^m/w^m, x] == v^m/w^m/(v/w)^m*Int[(v/w)^m, x]*)


Int[u_.*v_^m_*w_^n_,x_Symbol] :=
  Module[{q=Cancel[v/w]},
  (v^m*w^n)/q^m*Int[u*q^m,x] /;
 PolynomialQ[q,x]] /;
FractionQ[{m,n}] && m+n==0 && PolynomialQ[{v,w},x]


(* ::Subsection::Closed:: *)
(*Fractional power of linear subexpression substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[(a+b*x)^(1/n), x], x] == n/b*Subst[Int[x^(n-1)*f[x, -a/b+x^n/b], x], x, (a+b*x)^(1/n)]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfLinear[u,x]},
  ShowStep["","Int[f[(a+b*x)^(1/n),x],x]",
			"n/b*Subst[Int[x^(n-1)*f[x,-a/b+x^n/b],x],x,(a+b*x)^(1/n)]",Hold[
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]]]] /;
 NotFalseQ[lst] (* && AlgebraicFunctionQ[lst[[1]],x] *) ] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForFractionalPowerOfLinear[u,x]},
  Dist[lst[[2]]*lst[[4]],Subst[Int[lst[[1]],x],x,lst[[3]]^(1/lst[[2]])]] /;
 NotFalseQ[lst] (* && AlgebraicFunctionQ[lst[[1]],x] *) ]]


(* ::Subsection::Closed:: *)
(*Quadratic binomial expansion rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*z^2) == 1/(2*(a+b*Sqrt[-a/b]*z)) + 1/(2*(a-b*Sqrt[-a/b]*z))*)


(* ::Item:: *)
(*Note: This rule necessary because ExpnExpand cannot expand Sqrt[x + 1]/((1 - I*x)*(1 + I*x)).*)


Int[u_./(a_+b_.*v_^2),x_Symbol] :=
  Dist[1/2,Int[u/(a+b*Rt[-a/b,2]*v),x]] + Dist[1/2,Int[u/(a-b*Rt[-a/b,2]*v),x]] /;
FreeQ[{a,b},x] (* && Not[PositiveQ[-a/b]] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*z^2 == a*(1+Sqrt[-b/a]*z)*(1-Sqrt[-b/a]*z)*)


Int[u_.*(a_+b_.*v_^2)^m_,x_Symbol] :=
  Dist[a^m,Int[u*(1+Rt[-b/a,2]*v)^m*(1-Rt[-b/a,2]*v)^m,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && (m<-1 || m==-1 && PositiveQ[-b/a])


(* ::Subsection::Closed:: *)
(*Exponential function expansion rules*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: f^(z+w) == f^z*f^w*)


Int[u_.*f_^(a_+v_)*g_^(b_+w_),x_Symbol] :=
  Dist[f^a*g^b,Int[u*f^v*g^w,x]] /;
FreeQ[{a,b,f,g},x] && Not[MatchQ[v,c_+t_ /; FreeQ[c,x]]] && Not[MatchQ[w,c_+t_ /; FreeQ[c,x]]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: f^(z+w) == f^z*f^w*)


Int[u_.*f_^(a_+v_),x_Symbol] :=
  Dist[f^a,Int[u*f^v,x]] /;
FreeQ[{a,f},x] && Not[MatchQ[v,b_+w_ /; FreeQ[b,x]]]


(* ::Section::Closed:: *)
(*Nuclear Option Rules*)


(* ::Subsection::Closed:: *)
(*Tangent \[Theta]/2 substitution rules for linear trigonometric expressions*)


(* ::Item::Closed:: *)
(*Reference: CRC 484*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Sin[x] == 2*Tan[x/2]/(1+Tan[x/2]^2)*)


(* ::Item:: *)
(*Basis: Cos[x] == (1-Tan[x/2]^2)/(1+Tan[x/2]^2)*)


(* ::Item:: *)
(*Basis: 1+Tan[x/2]^2 == Tan'[x/2]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  ShowStep["","Int[f[Sin[x],Cos[x]],x]",
			"2*Subst[Int[f[2*x/(1+x^2),(1-x^2)/(1+x^2)]/(1+x^2),x],x,Tan[x/2]]",Hold[
  Dist[2,Subst[Int[Regularize[SubstForTrig[u,2*x/(1+x^2),(1-x^2)/(1+x^2),x,x]/(1+x^2),x],x],x,Tan[x/2]]]]] /;
SimplifyFlag && FunctionOfTrigQ[u,x,x],

Int[u_,x_Symbol] :=
  Dist[2,Subst[Int[Regularize[SubstForTrig[u,2*x/(1+x^2),(1-x^2)/(1+x^2),x,x]/(1+x^2),x],x],x,Tan[x/2]]] /;
FunctionOfTrigQ[u,x,x]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Sinh[x] == 2*Tanh[x/2]/(1-Tanh[x/2]^2)*)


(* ::Item:: *)
(*Basis: Cosh[x] == (1+Tanh[x/2]^2)/(1-Tanh[x/2]^2)*)


(* ::Item:: *)
(*Basis: 1-Tanh[x/2]^2 == Tanh'[x/2]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  ShowStep["","Int[f[Sinh[x],Cosh[x]],x]",
			"2*Subst[Int[f[2*x/(1-x^2),(1+x^2)/(1-x^2)]/(1-x^2),x],x,Tanh[x/2]]",Hold[
  Dist[2,Subst[Int[Regularize[SubstForHyperbolic[u,2*x/(1-x^2),(1+x^2)/(1-x^2),x,x]/(1-x^2),x],x],x,Tanh[x/2]]]]] /;
SimplifyFlag && FunctionOfHyperbolicQ[u,x,x],

Int[u_,x_Symbol] :=
  Dist[2,Subst[Int[Regularize[SubstForHyperbolic[u,2*x/(1-x^2),(1+x^2)/(1-x^2),x,x]/(1-x^2),x],x],x,Tanh[x/2]]] /;
FunctionOfHyperbolicQ[u,x,x]]


(* ::Subsection::Closed:: *)
(*Euler's substitution rules for subexpressions of the form Sqrt[a+b x+c x^2]*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.251.1*)


(* ::Item:: *)
(*Derivation: Integration by Euler substitution for a>0*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  ShowStep["","Int[f[Sqrt[a+b*x+c*x^2],x],x]",
			"2*Subst[Int[f[(c*Sqrt[a]-b*x+Sqrt[a]*x^2)/(c-x^2),(-b+2*Sqrt[a]*x)/(c-x^2)]*
				(c*Sqrt[a]-b*x+Sqrt[a]*x^2)/(c-x^2)^2,x],x,(-Sqrt[a]+Sqrt[a+b*x+c*x^2])/x]",
			Hold[Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]]]] /;
 Not[FalseQ[lst]] && lst[[3]]===1] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]] /;
 Not[FalseQ[lst]]]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.251.2*)


(* ::Item:: *)
(*Derivation: Integration by Euler substitution for c>0*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  ShowStep["","Int[f[Sqrt[a+b*x+c*x^2],x],x]",
			"2*Subst[Int[f[(a*Sqrt[c]+b*x+Sqrt[c]*x^2)/(b+2*Sqrt[c]*x),(-a+x^2)/(b+2*Sqrt[c]*x)]*
				(a*Sqrt[c]+b*x+Sqrt[c]*x^2)/(b+2*Sqrt[c]*x)^2,x],x,Sqrt[c]*x+Sqrt[a+b*x+c*x^2]]",
			Hold[Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]]]] /;
 Not[FalseQ[lst]] && lst[[3]]===2] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]] /;
 Not[FalseQ[lst]]]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.251.3*)


(* ::Item:: *)
(*Derivation: Integration by Euler substitution*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  ShowStep["","Int[f[Sqrt[a+b*x+c*x^2],x],x]",
		   "-2*Sqrt[b^2-4*a*c]*Subst[Int[f[-Sqrt[b^2-4*a*c]*x/(c-x^2),
			  (b*c+c*Sqrt[b^2-4*a*c]+(-b+Sqrt[b^2-4*a*c])*x^2)/(-2*c*(c-x^2))]*x/(c-x^2)^2,x],
			   x,2*c*Sqrt[a+b*x+c*x^2]/(b-Sqrt[b^2-4*a*c]+2*c*x)]",
		   Hold[Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]]]] /;
 Not[FalseQ[lst]] && lst[[3]]===3] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{lst=FunctionOfSquareRootOfQuadratic[u,x]},
  Dist[2,Subst[Int[lst[[1]],x],x,lst[[2]]]] /;
 Not[FalseQ[lst]]]]


(* ::Subsection::Closed:: *)
(*Inverse function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[z]/Sqrt[1-z^2] == f[Sin[ArcSin[z]]]*ArcSin'[z]*)


Int[u_*(1-(a_.+b_.*x_)^2)^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  Dist[1/b,Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*Cos[x]^(2*n+1),x],x],x,tmp]] /;
 NotFalseQ[tmp] && tmp===ArcSin[a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[2*n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[z]/Sqrt[1-z^2] == -f[Cos[ArcCos[z]]]*ArcCos'[z]*)


Int[u_*(1-(a_.+b_.*x_)^2)^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  -Dist[1/b,Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*Sin[x]^(2*n+1),x],x],x,tmp]] /;
 NotFalseQ[tmp] && tmp===ArcCos[a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[2*n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[z]/Sqrt[1+z^2] == f[Sinh[ArcSinh[z]]]*ArcSinh'[z]*)


Int[u_*(1+(a_.+b_.*x_)^2)^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  Dist[1/b,Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*Cosh[x]^(2*n+1),x],x],x,tmp]] /;
 NotFalseQ[tmp] && tmp===ArcSinh[a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[2*n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If h[g[x]] == x, Int[f[x, g[a+b*x]], x] == Subst[Int[f[-a/b+h[x]/b, x]*h'[x], x], x, g[a+b*x]]/b*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseFunctionOfLinear[u,x]},
  ShowStep["If h[g[x]]==x","Int[f[x,g[a+b*x]],x]",
	"Subst[Int[f[-a/b+h[x]/b,x]*h'[x],x],x,g[a+b*x]]/b",Hold[
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]]]]] /;
 NotFalseQ[lst]] /;
SimplifyFlag && Not[NotIntegrableQ[u,x]],

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseFunctionOfLinear[u,x]},
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]]] /;
 NotFalseQ[lst]] /;
Not[NotIntegrableQ[u,x]]]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If h[g[x]] == x, *)
(*        Int[f[x, g[(a+b*x)/(c+d*x)]], x] == (b*c-a*d)*Subst[Int[f[(-a+c*h[x])/(b-d*h[x]), x]*h'[x]/(b-d*h[x])^2, x], x, g[(a+b*x)/(c+d*x)]]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseFunctionOfQuotientOfLinears[u,x]},
  ShowStep["If h[g[x]]==x","Int[f[x,g[(a+b*x)/(c+d*x)]],x]",
	"(b*c-a*d)*Subst[Int[f[(-a+c*h[x])/(b-d*h[x]),x]*h'[x]/(b-d*h[x])^2,x],x,g[(a+b*x)/(c+d*x)]]",Hold[
  Dist[lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]]]]] /;
 NotFalseQ[lst]] /;
SimplifyFlag && Not[NotIntegrableQ[u,x]],

Int[u_,x_Symbol] :=
  Module[{lst=SubstForInverseFunctionOfQuotientOfLinears[u,x]},
  Dist[lst[[3]],Subst[Int[lst[[1]],x],x,lst[[2]]]] /;
 NotFalseQ[lst]] /;
Not[NotIntegrableQ[u,x]]]
././@LongLink0000000000000000000000000000015500000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/InverseHyperbolicFunctionIntegrationRules.mmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/InverseHyperbolicFunctionIntegratio0000644000175000017500000012560111446257035034115 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Inverse Hyperbolic Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Hyperbolic Arcsine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcSinh[a+b x]^n			Powers of arcsines of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 579, A&S 4.6.43*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSinh[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcSinh[a+b*x]/b - Sqrt[1+(a+b*x)^2]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/ArcSinh[z] == Cosh[ArcSinh[z]]/ArcSinh[z]*ArcSinh'[z]*)


Int[1/ArcSinh[a_.+b_.*x_],x_Symbol] :=
  CoshIntegral[ArcSinh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[1/ArcSinh[a_.+b_.*x_]^2,x_Symbol] :=
  -Sqrt[1+(a+b*x)^2]/(b*ArcSinh[a+b*x]) + SinhIntegral[ArcSinh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* Replace the above with following when able to integrate result! *)
(* Int[1/ArcSinh[x_]^2,x_Symbol] :=
  -Sqrt[1+x^2]/(ArcSinh[x]) +
   Int[x/(Sqrt[1+x^2]*ArcSinh[x]),x] *)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[ArcSinh[z]] == Cosh[ArcSinh[z]]/Sqrt[ArcSinh[z]]*ArcSinh'[z]*)


Int[1/Sqrt[ArcSinh[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Pi]/2*(Erf[Sqrt[ArcSinh[a+b*x]]]+Erfi[Sqrt[ArcSinh[a+b*x]]])/b /;
FreeQ[{a,b},x]


(* Replace the above with following when able to integrate result! *)
(* Int[1/Sqrt[ArcSinh[x_]],x_Symbol] :=
  Subst[Int[Cosh[x]/Sqrt[x],x],x,ArcSinh[x]] *)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sqrt[ArcSinh[a_.+b_.*x_]],x_Symbol] :=
  (a+b*x)*Sqrt[ArcSinh[a+b*x]]/b -
  Sqrt[Pi]/4*(-Erf[Sqrt[ArcSinh[a+b*x]]]+Erfi[Sqrt[ArcSinh[a+b*x]]])/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[ArcSinh[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcSinh[a+b*x]^n/b -
  n*Sqrt[1+(a+b*x)^2]*ArcSinh[a+b*x]^(n-1)/b +
  Dist[n*(n-1),Int[ArcSinh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts twice*)


Int[ArcSinh[a_.+b_.*x_]^n_,x_Symbol] :=
  -(a+b*x)*ArcSinh[a+b*x]^(n+2)/(b*(n+1)*(n+2)) +
  Sqrt[1+(a+b*x)^2]*ArcSinh[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[1/((n+1)*(n+2)),Int[ArcSinh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1 && n!=-2


Int[ArcSinh[a_.+b_.*x_]^n_,x_Symbol] :=
  ArcSinh[a+b*x]^n*Gamma[n+1,-ArcSinh[a+b*x]]/(2*b*(-ArcSinh[a+b*x])^n) -
  Gamma[n+1,ArcSinh[a+b*x]]/(2*b) /;
FreeQ[{a,b,n},x] && (Not[RationalQ[n]] || -10


(* ::Subsubsection::Closed:: *)
(*x ArcSinh[a+b x]^n/Sqrt[1+(a+b x)^2]  Products of x and powers of arcsines of linears divided by sqrt of linear*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*ArcSinh[a_.+b_.*x_]^n_/Sqrt[u_],x_Symbol] :=
  Sqrt[u]*ArcSinh[a+b*x]^n/b^2 -
  Dist[n/b,Int[ArcSinh[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcSinh[a+b*x]^n/Sqrt[u],x]] /;
FreeQ[{a,b},x] && ZeroQ[u-1-(a+b*x)^2] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcSinh[c / (a+b x^n)]^m		Powers of arcsines of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcSinh[z] == ArcCsch[1/z]*)


Int[u_.*ArcSinh[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCsch[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcSinh[x]] / Sqrt[1+x^2]		Products of functions of arcsines and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[1+z^2] == ArcSinh'[z]*)


(* Int[u_/Sqrt[1+x_^2],x_Symbol] :=
  Subst[Int[Regularize[SubstFor[ArcSinh[x],u,x],x],x],x,ArcSinh[x]] /;
FunctionOfQ[ArcSinh[x],u,x] *)


(* ::Subsubsection::Closed:: *)
(*u ArcSinh[v]				Products of expressions and arcsines of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSinh[u_],x_Symbol] :=
  x*ArcSinh[u] -
  Int[Regularize[x*D[u,x]/Sqrt[1+u^2],x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsubsection::Closed:: *)
(*f^(c ArcSinh[a+b x])			Exponentials of arcsines of linears*)


Int[f_^(c_.*ArcSinh[a_.+b_.*x_]),x_Symbol] :=
  f^(c*ArcSinh[a+b*x])*(a+b*x-c*Sqrt[1+(a+b*x)^2]*Log[f])/(b*(1-c^2*Log[f]^2)) /;
FreeQ[{a,b,c,f},x] && NonzeroQ[1-c^2*Log[f]^2]


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcSinh[v])			Products of expressions and exponentials of arcsines  *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcSinh[z]) == (z+Sqrt[1+z^2])^n*)


Int[E^(n_.*ArcSinh[v_]), x_Symbol] :=
  Int[(v+Sqrt[1+v^2])^n,x] /;
IntegerQ[n] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcSinh[z]) == (z+Sqrt[1+z^2])^n*)


Int[x_^m_.*E^(n_.*ArcSinh[v_]), x_Symbol] :=
  Int[x^m*(v+Sqrt[1+v^2])^n,x] /;
RationalQ[m] && IntegerQ[n] && PolynomialQ[v,x]


(* ::Subsection::Closed:: *)
(*Hyperbolic Arccosine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcCosh[a+b x]^n			Powers of arccosines of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 582', A&S 4.6.44*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Should be simpler, analagous to that for ArcSinh. *)
Int[ArcCosh[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCosh[a+b*x]/b - Sqrt[-1+a+b*x]*Sqrt[1+a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/ArcCosh[z] == Sinh[ArcCosh[z]]/ArcCosh[z]*ArcCosh'[z]*)


Int[1/ArcCosh[a_.+b_.*x_],x_Symbol] :=
  SinhIntegral[ArcCosh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[1/ArcCosh[a_.+b_.*x_]^2,x_Symbol] :=
  -Sqrt[-1+a+b*x]*Sqrt[1+a+b*x]/(b*ArcCosh[a+b*x]) + CoshIntegral[ArcCosh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[ArcCosh[x]] == Sinh[ArcCosh[x]]/Sqrt[ArcCosh[x]]*ArcCosh'[x]*)


Int[1/Sqrt[ArcCosh[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Pi]/2*(-Erf[Sqrt[ArcCosh[a+b*x]]] + Erfi[Sqrt[ArcCosh[a+b*x]]])/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sqrt[ArcCosh[a_.+b_.*x_]],x_Symbol] :=
  (a+b*x)*Sqrt[ArcCosh[a+b*x]]/b -
  Sqrt[Pi]/4*(Erf[Sqrt[ArcCosh[a+b*x]]]+Erfi[Sqrt[ArcCosh[a+b*x]]])/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[ArcCosh[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcCosh[a+b*x]^n/b -
  n*Sqrt[-1+a+b*x]*Sqrt[1+a+b*x]*ArcCosh[a+b*x]^(n-1)/b +
  Dist[n*(n-1),Int[ArcCosh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts twice*)


Int[ArcCosh[a_.+b_.*x_]^n_,x_Symbol] :=
  -(a+b*x)*ArcCosh[a+b*x]^(n+2)/(b*(n+1)*(n+2)) +
  Sqrt[-1+a+b*x]*Sqrt[1+a+b*x]*ArcCosh[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[1/((n+1)*(n+2)),Int[ArcCosh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1 && n!=-2


Int[ArcCosh[a_.+b_.*x_]^n_,x_Symbol] :=
  ArcCosh[a+b*x]^n*Gamma[n+1,-ArcCosh[a+b*x]]/(2*b*(-ArcCosh[a+b*x])^n) +
  Gamma[n+1,ArcCosh[a+b*x]]/(2*b) /;
FreeQ[{a,b,n},x] && (Not[RationalQ[n]] || -10


(* ::Subsubsection::Closed:: *)
(*x ArcCosh[a+b x]^n/Sqrt[1+(a+b x)^2]    Products of x and powers of arccosines of linears divided by sqrt of linear*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Int[x_*ArcCosh[a_.+b_.*x_]^n_/Sqrt[u_],x_Symbol] :=
  ??? /;
FreeQ[{a,b},x] && ZeroQ[u-1+(a+b*x)^2] && RationalQ[n] && n>1 *)


(* ::Subsubsection::Closed:: *)
(*u ArcCosh[c / (a+b x^n)]^m		Powers of arccosines of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCosh[z] == ArcSech[1/z]*)


Int[u_.*ArcCosh[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcSech[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcCosh[x]] / Sqrt[1+x^2]		Products of functions of arccosines and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/(Sqrt[1+z]*Sqrt[-1+z]) == ArcCosh'[z]*)


(* Int[u_/(Sqrt[1+x_]*Sqrt[-1+x_]),x_Symbol] :=
  Subst[Int[Regularize[SubstFor[ArcCosh[x],u,x],x],x],x,ArcCosh[x]] /;
FunctionOfQ[ArcCosh[x],u,x] *)


(* ::Subsubsection::Closed:: *)
(*u ArcCosh[v]				Products of expressions and arccosines of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCosh[u_],x_Symbol] :=
  x*ArcCosh[u] - 
  Int[Regularize[x*D[u,x]/(Sqrt[-1+u]*Sqrt[1+u]),x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsubsection::Closed:: *)
(*f^(c ArcCosh[a+b x])			Exponentials of arccosines of linears*)


Int[f_^(c_.*ArcCosh[a_.+b_.*x_]),x_Symbol] :=
  f^(c*ArcCosh[a+b*x])*(a+b*x-c*Sqrt[(-1+a+b*x)/(1+a+b*x)]*(1+a+b*x)*Log[f])/
    (b*(1-c^2*Log[f]^2)) /;
FreeQ[{a,b,c,f},x] && NonzeroQ[1-c^2*Log[f]^2]


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcCosh[v])			Products of expressions and exponentials of arccosines  *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCosh[z]) == (z+Sqrt[-1+z]*Sqrt[1+z])^n*)


(* ::Item:: *)
(*Basis: If n is an integer, E^(n*ArcCosh[z]) == (z + Sqrt[(-1+z)/(1+z)] + z*Sqrt[(-1+z)/(1+z)])^n*)


Int[E^(n_.*ArcCosh[v_]), x_Symbol] :=
  Int[(v+Sqrt[-1+v]*Sqrt[1+v])^n,x] /;
IntegerQ[n] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCosh[z]) == (z+Sqrt[-1+z]*Sqrt[1+z])^n*)


(* ::Item:: *)
(*Basis: If n is an integer, E^(n*ArcCosh[z]) == (z + Sqrt[(-1+z)/(1+z)] + z*Sqrt[(-1+z)/(1+z)])^n*)


Int[x_^m_.*E^(n_.*ArcCosh[v_]), x_Symbol] :=
  Int[x^m*(v+Sqrt[-1+v]*Sqrt[1+v])^n,x] /;
RationalQ[m] && IntegerQ[n] && PolynomialQ[v,x]


(* ::Subsection::Closed:: *)
(*Hyperbolic Arctangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcTanh[a+b x^n]			Arctangents of binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 585, A&S 4.6.45*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTanh[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcTanh[a+b*x]/b + Log[1-(a+b*x)^2]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTanh[a_.+b_.*x_^n_],x_Symbol] :=
  x*ArcTanh[a+b*x^n] -
  Dist[b*n,Int[x^n/(1-a^2-2*a*b*x^n-b^2*x^(2*n)),x]] /;
FreeQ[{a,b},x] && IntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m ArcTanh[a+b x^n]		Products of monomials and arctangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: ArcTanh[z] == 1/2*Log[1+z] - 1/2*Log[1-z]*)


Int[ArcTanh[a_.+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[1/2,Int[Log[1+a+b*x^n]/x,x]] -
  Dist[1/2,Int[Log[1-a-b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 588, A&S 4.6.54*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcTanh[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)*ArcTanh[a+b*x^n]/(m+1) -
  Dist[b*n/(m+1),Int[x^(m+n)/(1-a^2-2*a*b*x^n-b^2*x^(2*n)),x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && NonzeroQ[m+1] && NonzeroQ[m-n+1]


(* ::Subsubsection::Closed:: *)
(*(1-x^2)^m ArcTanh[x]^n		Products of integer powers of binomials and powers of arctangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(1-x_^2)^m_*ArcTanh[x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[(1-x^2)^m,x]]},
  u*ArcTanh[x]^n -
  Dist[n,Int[Expand[u*ArcTanh[x]^(n-1)/(1-x^2)],x]]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* Ug.  (-1+x^2)^m should automatically evaluate to (-1)^m*(1-x^2)^m for integer m! *)
Int[(-1+x_^2)^m_*ArcTanh[x_]^n_.,x_Symbol] :=
  Dist[(-1)^m,Int[(1-x^2)^m*ArcTanh[x]^n,x]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* ::Subsubsection::Closed:: *)
(*(1-x^2)^m ArcCoth[x]^n ArcTanh[x]^p	Products of powers of binomials, arccotangents and arctangents*)


Int[1/((1-x_^2)*ArcCoth[x_]*ArcTanh[x_]),x_Symbol] :=
  (-Log[ArcCoth[x]]+Log[ArcTanh[x]])/(ArcCoth[x]-ArcTanh[x])


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCoth[x_]^n_.*ArcTanh[x_]^p_./(1-x_^2),x_Symbol] :=
  ArcCoth[x]^(n+1)*ArcTanh[x]^p/(n+1) -
  Dist[p/(n+1),Int[ArcCoth[x]^(n+1)*ArcTanh[x]^(p-1)/(1-x^2),x]] /;
IntegerQ[{n,p}] && 01


Int[x_*ArcTanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -(1-(a+b*x)^2)*ArcTanh[a+b*x]^n/(2*b^2) +
  Dist[n/(2*b),Int[ArcTanh[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcTanh[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcTanh[c / (a+b x^n)]		Arctangent of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTanh[z] == ArcCoth[1/z]*)


Int[u_.*ArcTanh[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCoth[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[x, ArcTanh[a+b x]] / (1-(a+b x)^2)	Products of functions involving arctangents of linears and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[z]/(1-z^2) == f[Tanh[ArcTanh[z]]]*ArcTanh'[z]*)


(* ::Item:: *)
(*Basis: r + s*x + t*x^2 == -(s^2-4*r*t)/(4*t)*(1 - (s+2*t*x)^2/(s^2-4*r*t))*)


(* ::Item:: *)
(*Basis: 1-Tanh[z]^2 == Sech[z]^2*)


If[ShowSteps,

Int[u_*v_^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  ShowStep["","Int[f[x,ArcTanh[a+b*x]]/(1-(a+b*x)^2),x]",
		   "Subst[Int[f[-a/b+Tanh[x]/b,x],x],x,ArcTanh[a+b*x]]/b",Hold[
  Dist[(-Discriminant[v,x]/(4*Coefficient[v,x,2]))^n/Coefficient[tmp[[1]],x,1],
	Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*Sech[x]^(2*(n+1)),x],x], x, tmp]]]] /;
 NotFalseQ[tmp] && Head[tmp]===ArcTanh && ZeroQ[Discriminant[v,x]*tmp[[1]]^2-D[v,x]^2]] /;
SimplifyFlag && QuadraticQ[v,x] && IntegerQ[n] && n<0 && PosQ[Discriminant[v,x]],

Int[u_*v_^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  Dist[(-Discriminant[v,x]/(4*Coefficient[v,x,2]))^n/Coefficient[tmp[[1]],x,1],
	Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*Sech[x]^(2*(n+1)),x],x], x, tmp]] /;
 NotFalseQ[tmp] && Head[tmp]===ArcTanh && ZeroQ[Discriminant[v,x]*tmp[[1]]^2-D[v,x]^2]] /;
QuadraticQ[v,x] && IntegerQ[n] && n<0 && PosQ[Discriminant[v,x]]]


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcTanh[v])			Products of expressions and exponentials of arctangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^(n/2)/(1-z)^(n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_]),x_Symbol] :=
  Int[u*(1+v)^(n/2)/(1-v)^(n/2),x] /;
EvenQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^(n/2)/(1-z)^(n/2)*)


Int[E^(n_.*ArcTanh[v_]),x_Symbol] :=
  Int[(1+v)^(n/2)/(1-v)^(n/2),x] /;
RationalQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == ((1+z)/Sqrt[1-z^2])^n*)


Int[x_^m_.*E^(n_.*ArcTanh[v_]), x_Symbol] :=
  Int[x^m*(1+v)^n/(1-v^2)^(n/2),x] /;
RationalQ[m] && OddQ[n] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z])*(1-z^2)^m == (1-z)^(m-n/2)*(1+z)^(m+n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(1-v_^2)^m_.,x_Symbol] :=
  Int[u*(1-v)^(m-n/2)*(1+v)^(m+n/2),x] /;
RationalQ[{m,n}] && IntegerQ[m-n/2] && IntegerQ[m+n/2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z])*(1-z^2)^m == (1-z)^(m-n/2)*(1+z)^(m+n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(a_+b_.*v_^2)^m_.,x_Symbol] :=
  (a+b*v^2)^m/(1-v^2)^m*Int[u*(1-v)^(m-n/2)*(1+v)^(m+n/2),x] /;
FreeQ[{a,b},x] && ZeroQ[a+b] && RationalQ[{m,n}] && IntegerQ[m-n/2] && IntegerQ[m+n/2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^n/(1-z^2)^(n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(1-v_^2)^m_.,x_Symbol] :=
  Int[u*(1+v)^n*(1-v^2)^(m-n/2),x] /;
RationalQ[n] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^n/(1-z^2)^(n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(1+v_)^m_.,x_Symbol] :=
  Int[u*(1+v)^(m+n)/(1-v^2)^(n/2),x] /;
RationalQ[{m,n}] && IntegerQ[m+n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^(n/2)/(1-z)^(n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(1+v_)^m_.,x_Symbol] :=
  Int[u*(1+v)^(m+n/2)/(1-v)^(n/2),x] /;
RationalQ[{m,n}]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcTanh[z]) == (1+z)^(n/2)/(1-z)^(n/2)*)


Int[u_.*E^(n_.*ArcTanh[v_])*(1-v_)^m_.,x_Symbol] :=
  Int[u*(1+v)^(n/2)*(1-v)^(m-n/2),x] /;
RationalQ[{m,n}]


(* ::Item:: *)
(*Derivation: Algebraic simplification*)


Int[u_.*E^(n_.*ArcTanh[v_])*(a_+b_.*v_)^m_.,x_Symbol] :=
  Dist[a^m,Int[u*E^(n*ArcTanh[v])*(1+b/a*v)^m,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && RationalQ[n] && NonzeroQ[a-1] && ZeroQ[a^2-b^2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If m is an integer, E^ArcTanh[z]*(a-a/z^2)^m == (-a)^m*(1+z)*(1-z^2)^(m-1/2)/z^(2*m)*)


Int[u_.*E^ArcTanh[v_]*(a_+b_./v_^2)^m_.,x_Symbol] :=
  b^m*Int[u*(1-v^2)^(m-1/2)/v^(2*m),x] + 
  b^m*Int[u*(1-v^2)^(m-1/2)/v^(2*m-1),x] /;
FreeQ[{a,b},x] && ZeroQ[a+b] && IntegerQ[m]


(* ::Subsubsection::Closed:: *)
(*f[ArcTanh[x]] (1-x^2)^n		Products of functions of arctangents and its derivative*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Cosh[x]^(-2*(n+1))*SubstFor[ArcTanh[x],u,x],x],x],x,ArcTanh[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTanh[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[1/a,Subst[Int[Regularize[(a*Sech[x]^2)^(n+1)*SubstFor[ArcTanh[x],u,x],x],x],x,ArcTanh[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTanh[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] && n<-1


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* Int[u_*(a_+b_./x_^2)^n_,x_Symbol] :=
  Subst[Int[Regularize[(b*Csch[x]^2)^n*Sech[x]^2*SubstFor[ArcTanh[x],u,x],x],x],x,ArcTanh[x]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTanh[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] *)


(* ::Subsubsection::Closed:: *)
(*x^m f[ArcTanh[x]] (1-x^2)^n		Products of monomials, functions of arctangents and its derivative*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Tanh[x]^m*Cosh[x]^(-2*(n+1))*SubstFor[ArcTanh[x],u,x],x],x],x,ArcTanh[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTanh[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a] && IntegerQ[m]


(* ::Subsubsection::Closed:: *)
(*u ArcTanh[v]				Products of expressions and arctangents of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTanh[u_],x_Symbol] :=
  x*ArcTanh[u] -
  Int[Regularize[x*D[u,x]/(1-u^2),x],x] /;
InverseFunctionFreeQ[u,x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcTanh[u_],x_Symbol] :=
  x^(m+1)*ArcTanh[u]/(m+1) -
  Dist[1/(m+1),Int[Regularize[x^(m+1)*D[u,x]/(1-u^2),x],x]] /;
FreeQ[m,x] && NonzeroQ[m+1] && InverseFunctionFreeQ[u,x] && 
	Not[FunctionOfQ[x^(m+1),u,x]] && 
	FalseQ[PowerVariableExpn[u,m+1,x]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[v_*ArcTanh[u_],x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},  
  w*ArcTanh[u] -
  Int[Regularize[w*D[u,x]/(1-u^2),x],x] /;
 InverseFunctionFreeQ[w,x]] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[v, x^m_. /; FreeQ[m,x]]] &&
	FalseQ[FunctionOfLinear[v*ArcTanh[u],x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTanh[z] ==  Log[1+z]/2 - Log[1-z]/2*)


Int[ArcTanh[b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[1/2,Int[Log[1+b*x]/(c+d*x^n),x]] -
  Dist[1/2,Int[Log[1-b*x]/(c+d*x^n),x]] /;
FreeQ[{b,c,d},x] && IntegerQ[n] && Not[n==2 && ZeroQ[b^2*c+d]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTanh[z] ==  Log[1+z]/2 - Log[1-z]/2*)


Int[ArcTanh[a_+b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[1/2,Int[Log[1+a+b*x]/(c+d*x^n),x]] -
  Dist[1/2,Int[Log[1-a-b*x]/(c+d*x^n),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[n] && Not[n==1 && ZeroQ[a*d-b*c]]


(* ::Subsection::Closed:: *)
(*Hyperbolic Arccotangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*x^m ArcCoth[a+b x^n]		Arccotangents of binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 586, A&S 4.6.48*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCoth[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCoth[a+b*x]/b + Log[1-(a+b*x)^2]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCoth[a_.+b_.*x_^n_],x_Symbol] :=
  x*ArcCoth[a+b*x^n] -
  Dist[b*n,Int[x^n/(1-a^2-2*a*b*x^n-b^2*x^(2*n)),x]] /;
FreeQ[{a,b},x] && IntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m ArcCoth[a+b x^n]		Products of monomials and arccotangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: ArcCoth[z] == 1/2*Log[1+1/z] - 1/2*Log[1-1/z]*)


Int[ArcCoth[a_.+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[1/2,Int[Log[1+1/(a+b*x^n)]/x,x]] -
  Dist[1/2,Int[Log[1-1/(a+b*x^n)]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 590*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCoth[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)*ArcCoth[a+b*x^n]/(m+1) -
  Dist[b*n/(m+1),Int[x^(m+n)/(1-a^2-2*a*b*x^n-b^2*x^(2*n)),x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && NonzeroQ[m+1] && NonzeroQ[m-n+1]


(* ::Subsubsection::Closed:: *)
(*(1-x^2)^m ArcCoth[x]^n		Products of powers of binomials and powers of arccotangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(1-x_^2)^m_*ArcCoth[x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[(1-x^2)^m,x]]},
  u*ArcCoth[x]^n-
  Dist[n,Int[Expand[u*ArcCoth[x]^(n-1)/(1-x^2)],x]]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* Ug.  (-1+x^2)^m should automatically evaluate to (-1)^m*(1-x^2)^m for integer m! *)
Int[(-1+x_^2)^m_*ArcCoth[x_]^n_.,x_Symbol] :=
  Dist[(-1)^m,Int[(1-x^2)^m*ArcCoth[x]^n,x]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* ::Subsubsection::Closed:: *)
(*(1-x^2)^m ArcCoth[x]^n ArcTanh[x]^p  Products of powers of binomials, arccotangents and arctangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCoth[x_]^n_.*ArcTanh[x_]^p_/(1-x_^2),x_Symbol] :=
  ArcCoth[x]^n*ArcTanh[x]^(p+1)/(p+1) -
  Dist[n/(p+1),Int[ArcCoth[x]^(n-1)*ArcTanh[x]^(p+1)/(1-x^2),x]] /;
IntegerQ[{n,p}] && 01 && n>1


(* Ug.  (-1+x^2)^m should automatically evaluate to (-1)^m*(1-x^2)^m for integer m! *)
Int[(-1+x_^2)^m_.*ArcCoth[x_]^n_.*ArcTanh[x_]^p_.,x_Symbol] :=
  Dist[(-1)^m,Int[(1-x^2)^m*ArcCoth[x]^n*ArcTanh[x]^p,x]] /;
IntegerQ[{m,n,p}] && m<-1 && n>0


(* ::Subsubsection::Closed:: *)
(*x ArcCoth[a+b x]^n			Products of x and powers of arccotangents of linears*)


Int[x_*ArcCoth[a_.*x_]^n_,x_Symbol] :=
  (-1+a^2*x^2)*ArcCoth[a*x]^n/(2*a^2)+
  Dist[n/(2*a),Int[ArcCoth[a*x]^(n-1),x]] /;
FreeQ[a,x] && RationalQ[n] && n>1


Int[x_*ArcCoth[a_.+b_.*x_]^n_,x_Symbol] :=
  (-1+(a+b*x)^2)*ArcCoth[a+b*x]^n/(2*b^2) +
  Dist[n/(2*b),Int[ArcCoth[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcCoth[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcCoth[c / (a+b x^n)]		Arccotangent of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCoth[z] == ArcTanh[1/z]*)


Int[u_.*ArcCoth[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcTanh[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[x, ArcCoth[a+b x]] / (1-(a+b x)^2)	Products of functions involving arccotangents of linears and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[z]/(1-z^2) == f[Coth[ArcCoth[z]]]*ArcCoth'[z]*)


(* ::Item:: *)
(*Basis: r + s*x + t*x^2 == -(s^2-4*r*t)/(4*t)*(1 - (s+2*t*x)^2/(s^2-4*r*t))*)


(* ::Item:: *)
(*Basis: 1-Coth[z]^2 == -Csch[z]^2*)


If[ShowSteps,

Int[u_*v_^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  ShowStep["","Int[f[x,ArcCoth[a+b*x]]/(1-(a+b*x)^2),x]",
		   "Subst[Int[f[-a/b+Coth[x]/b,x],x],x,ArcCoth[a+b*x]]/b",Hold[
  Dist[(-Discriminant[v,x]/(4*Coefficient[v,x,2]))^n/Coefficient[tmp[[1]],x,1],
	Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*(-Csch[x]^2)^(n+1),x],x], x, tmp]]]] /;
 NotFalseQ[tmp] && Head[tmp]===ArcCoth && ZeroQ[Discriminant[v,x]*tmp[[1]]^2-D[v,x]^2]] /;
SimplifyFlag && QuadraticQ[v,x] && IntegerQ[n] && n<0 && PosQ[Discriminant[v,x]],

Int[u_*v_^n_.,x_Symbol] :=
  Module[{tmp=InverseFunctionOfLinear[u,x]},
  Dist[(-Discriminant[v,x]/(4*Coefficient[v,x,2]))^n/Coefficient[tmp[[1]],x,1],
	Subst[Int[Regularize[SubstForInverseFunction[u,tmp,x]*(-Csch[x]^2)^(n+1),x],x], x, tmp]] /;
 NotFalseQ[tmp] && Head[tmp]===ArcCoth && ZeroQ[Discriminant[v,x]*tmp[[1]]^2-D[v,x]^2]] /;
QuadraticQ[v,x] && IntegerQ[n] && n<0 && PosQ[Discriminant[v,x]]]


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcCoth[v])			Products of expressions and exponentials of arccotangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is even, E^(n*ArcCoth[z]) == (1+z)^(n/2)/(-1+z)^(n/2)*)


Int[u_.*E^(n_.*ArcCoth[v_]),x_Symbol] :=
  Int[u*(1+v)^(n/2)/(-1+v)^(n/2),x] /;
EvenQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (z*(1+z)/(Sqrt[z^2]*Sqrt[-1+z^2]))^n*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (1/Sqrt[1-1/z^2] + 1/(z*Sqrt[1-1/z^2]))^n*)


Int[E^(n_.*ArcCoth[v_]),x_Symbol] :=
  Int[Expand[(1/Sqrt[1-1/v^2] + 1/(x*Sqrt[1-1/v^2]))^n],x] /;
OddQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (1+1/z)^(n/2)/(1-1/z)^(n/2)*)


(* Int[E^(n_.*ArcCoth[v_]),x_Symbol] :=
  Int[(1+1/v)^(n/2)/(1-1/v)^(n/2),x] /;
RationalQ[n] *)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[E^(ArcCoth[a_.+b_.*x_]/2), x_Symbol] :=
  x*E^(ArcCoth[a+b*x]/2) -
  Dist[b/2,Int[x*E^(ArcCoth[a+b*x]/2)/(1-(a+b*x)^2),x]] /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(ArcCoth[a_.+b_.*x_]/2), x_Symbol] :=
  x^(m+1)*E^(ArcCoth[a+b*x]/2)/(m+1) -
  Dist[b/(2*(m+1)),Int[x^(m+1)*E^(ArcCoth[a+b*x]/2)/(1-(a+b*x)^2),x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (z*(1+z)/(Sqrt[z^2]*Sqrt[-1+z^2]))^n*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (1/Sqrt[1-1/z^2] + 1/(z*Sqrt[1-1/z^2]))^n*)


Int[x_^m_.*E^(n_.*ArcCoth[v_]),x_Symbol] :=
  Int[Expand[x^m*(1/Sqrt[1-1/v^2] + 1/(x*Sqrt[1-1/v^2]))^n],x] /;
RationalQ[m] && OddQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == ((1+1/z)/Sqrt[1-1/z^2])^n*)


(* ::Item:: *)
(*Basis: If n is an integer, E^(n*ArcCoth[z]) == (1+z)^n/(z^n*(1-1/z^2)^(n/2))*)


(* Int[x_^m_.*E^(n_.*ArcCoth[v_]), x_Symbol] :=
  Int[x^m*(1+v)^n/(v^n*(1-1/v^2)^(n/2)),x] /;
RationalQ[m] && OddQ[n] && PolynomialQ[v,x] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is odd, E^(n*ArcCoth[z])*(1-z^2)^m == -(-1)^((n-1)/2)*z*Sqrt[1-1/z^2]/Sqrt[1-z^2]*(1-z)^(m-n/2)*(1+z)^(m+n/2)*)


(* ::Item:: *)
(*Basis: D[f[x]*Sqrt[a-a/f[x]^2]/Sqrt[1-f[x]^2],x] == 0*)


Int[u_.*E^(n_.*ArcCoth[v_])*(1-v_^2)^m_.,x_Symbol] :=
  -(-1)^((n-1)/2)*v*Sqrt[1-1/v^2]/Sqrt[1-v^2]*Int[u*(1-v)^(m-n/2)*(1+v)^(m+n/2),x] /;
OddQ[n] && HalfIntegerQ[m]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^ArcCoth[z]*(1-z^2) == -z*(1+z)*Sqrt[1-1/z^2]*)


Int[u_.*E^ArcCoth[v_]*(1-v_^2)^m_.,x_Symbol] :=
  -Int[Expand[u*v*(1+v)*Sqrt[1-1/v^2]*(1-v^2)^(m-1),x],x] /;
IntegerQ[m] && m>0


(* ::Item:: *)
(*Basis: D[(a-a*f[x]^2)^m/(1-f[x]^2)^m,x] == 0*)


Int[u_.*E^ArcCoth[v_]*(a_+b_.*v_^2)^m_.,x_Symbol] :=
  (a+b*v^2)^m/(1-v^2)^m*Int[u*E^ArcCoth[v]*(1-v^2)^m,x] /;
FreeQ[{a,b},x] && ZeroQ[a+b] && NonzeroQ[a-1]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (1+1/z)^n/(1-1/z^2)^(n/2)*)


Int[u_.*E^(n_.*ArcCoth[v_])*(1-1/v_^2)^m_.,x_Symbol] :=
  Int[u*(1+v)^(m+n/2)*(-1+v)^(m-n/2)/v^(2*m),x] /;
IntegerQ[n] && IntegerQ[m-n/2]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCoth[z]) == (1+1/z)^n/(1-1/z^2)^(n/2)*)


Int[u_.*E^(n_.*ArcCoth[v_])*(1-1/v_^2)^m_.,x_Symbol] :=
  Int[Expand[u*(1+1/v)^n*(1-1/v^2)^(m-n/2),x],x] /;
RationalQ[n] && IntegerQ[2*m]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^ArcCoth[z] == (1+1/z)/Sqrt[1-1/z^2]*)


(* ::Item:: *)
(*Basis: D[(a-a/f[x]^2)^m/(1-1/f[x]^2)^m,x] == 0*)


Int[u_.*E^ArcCoth[v_]*(a_+b_./v_^2)^m_.,x_Symbol] :=
  Int[u*(1+1/v)*(1-v^(-2))^(m-1/2),x]*(a+b*v^(-2))^m/(1-v^(-2))^m /;
FreeQ[{a,b},x] && ZeroQ[a+b] && IntegerQ[2*m]


(* ::Subsubsection::Closed:: *)
(*f[ArcCoth[x]] (1-x^2)^n		Products of functions of arccotangents and its derivative*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[1/a,Subst[Int[Regularize[(b*Csch[x]^2)^(n+1)*SubstFor[ArcCoth[x],u,x],x],x],x,ArcCoth[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCoth[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] *)


(* ::Subsubsection::Closed:: *)
(*x^m f[ArcCoth[x]] (1-x^2)^n		Products of monomials, functions of arctangents and its derivative*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[-b^n,Subst[Int[Regularize[Coth[x]^m*Sinh[x]^(-2*(n+1))*SubstFor[ArcCoth[x],u,x],x],x],x,ArcCoth[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCoth[x],u,x] && ZeroQ[a+b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a] && IntegerQ[m]


(* ::Subsubsection::Closed:: *)
(*u ArcCoth[v]				Products of expressions and arccotangents of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCoth[u_],x_Symbol] :=
  x*ArcCoth[u] - 
  Int[Regularize[x*D[u,x]/(1-u^2),x],x] /;
InverseFunctionFreeQ[u,x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCoth[u_],x_Symbol] :=
  x^(m+1)*ArcCoth[u]/(m+1) - 
  Dist[1/(m+1),Int[Regularize[x^(m+1)*D[u,x]/(1-u^2),x],x]] /;
FreeQ[m,x] && NonzeroQ[m+1] && InverseFunctionFreeQ[u,x] && 
	Not[FunctionOfQ[x^(m+1),u,x]] && 
	FalseQ[PowerVariableExpn[u,m+1,x]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[v_*ArcCoth[u_],x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},  
  w*ArcCoth[u] - 
  Int[Regularize[w*D[u,x]/(1-u^2),x],x] /;
 InverseFunctionFreeQ[w,x]] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[v, x^m_. /; FreeQ[m,x]]] &&
	FalseQ[FunctionOfLinear[v*ArcCoth[u],x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCoth[z] ==  Log[1+1/z]/2 - Log[1-1/z]/2*)


Int[ArcCoth[b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[1/2,Int[Log[1+1/(b*x)]/(c+d*x^n),x]] -
  Dist[1/2,Int[Log[1-1/(b*x)]/(c+d*x^n),x]] /;
FreeQ[{b,c,d},x] && IntegerQ[n] && Not[n==2 && ZeroQ[b^2*c+d]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCoth[z] ==  Log[1+1/z]/2 - Log[1-1/z]/2*)


Int[ArcCoth[a_+b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[1/2,Int[Log[1+1/(a+b*x)]/(c+d*x^n),x]] -
  Dist[1/2,Int[Log[1-1/(a+b*x)]/(c+d*x^n),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[n] && Not[n==1 && ZeroQ[a*d-b*c]]


(* ::Subsection::Closed:: *)
(*Hyperbolic Arcsecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcSech[a+b x]^n			Powers of arcsecants of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 591', A&S 4.6.47'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSech[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcSech[a+b*x]/b - 2*ArcTan[Sqrt[(1-a-b*x)/(1+a+b*x)]]/b /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m ArcSech[a+b x]			Products of monomials and arcsecants of monomials*)


Int[ArcSech[a_.*x_^n_.]/x_,x_Symbol] :=
(*   Int[ArcCosh[1/a*x^(-n)]/x,x] /; *)
  -ArcSech[a*x^n]^2/(2*n) - 
  ArcSech[a*x^n]*Log[1+E^(-2*ArcSech[a*x^n])]/n + 
  PolyLog[2,-E^(-2*ArcSech[a*x^n])]/(2*n) /;
(* -ArcSech[a*x^n]^2/(2*n) - 
  ArcSech[a*x^n]*Log[1+1/(1/(a*x^n)+Sqrt[-1+1/(a*x^n)]*Sqrt[1+1/(a*x^n)])^2]/n + 
  PolyLog[2,-1/(1/(a*x^n)+Sqrt[-1+1/(a*x^n)]*Sqrt[1+1/(a*x^n)])^2]/(2*n) /; *)
FreeQ[{a,n},x]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*ArcSech[a_+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*ArcSech[x],x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Reference: CRC 593', A&S 4.6.58'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: D[ArcSech[x],x] == -Sqrt[1/(1+x)]*Sqrt[1+x]/(x*Sqrt[1+x]*Sqrt[1-x])*)


(* ::Item:: *)
(*Basis: D[Sqrt[1/(1+a+b*x^n)]*Sqrt[1+a+b*x^n],x] == 0*)


Int[x_^m_.*ArcSech[a_.*x_],x_Symbol] :=
  x^(m+1)*ArcSech[a*x]/(m+1) + 
(*  Dist[1/(m+1),Int[x^m*Sqrt[(1-a*x)/(1+a*x)]/(1-a*x),x]] /; *)
  Dist[1/(m+1),Int[x^m/(Sqrt[(1-a*x)/(1+a*x)]*(1+a*x)),x]] /;
FreeQ[{a,m},x] && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*u ArcSech[c / (a+b x^n)]		Inverse secant of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcSech[z] == ArcCosh[1/z]*)


Int[u_.*ArcSech[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCosh[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*u ArcSech[v]				Products of expressions and arcsecants of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Int[ArcSech[u_],x_Symbol] :=
  x*ArcSech[u] +
  Int[Regularize[x*D[u,x]/(u^2*Sqrt[-1+1/u]*Sqrt[1+1/u]),x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]] *)


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcSech[v])			Products of expressions and exponentials of arccosines  *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcSech[z]) == (Sqrt[-1+1/z]*Sqrt[1+1/z] + 1/z)^n*)


(* ::Item:: *)
(*Basis: If n is an integer, E^(n*ArcSech[z]) == (1/z + Sqrt[(1-z)/(1+z)] + Sqrt[(1-z)/(1+z)]/z)^n*)


(* ::Item:: *)
(*Basis: If n is an integer, E^(n*ArcSech[z]) == ((1+Sqrt[1-z]/Sqrt[1/(1+z)])/z)^n*)


Int[E^(n_.*ArcSech[v_]), x_Symbol] :=
  Int[(1/v + Sqrt[(1-v)/(1+v)] + Sqrt[(1-v)/(1+v)]/v)^n,x] /;
IntegerQ[n] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcSech[z]) == (Sqrt[-1+1/z]*Sqrt[1+1/z] + 1/z)^n*)


Int[x_^m_.*E^(n_.*ArcSech[v_]), x_Symbol] :=
  Int[x^m*(1/v + Sqrt[(1-v)/(1+v)] + Sqrt[(1-v)/(1+v)]/v)^n,x] /;
RationalQ[m] && IntegerQ[n] && PolynomialQ[v,x]


(* ::Subsection::Closed:: *)
(*Hyperbolic Arccosecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcCsch[a+b x]^n			Powers of arcsecants of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: CRC 594', A&S 4.6.46'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCsch[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCsch[a+b*x]/b + ArcTanh[Sqrt[1+1/(a+b*x)^2]]/b /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m ArcCsch[a x^n]			Products of monomials and arccosecants of monomials*)


Int[ArcCsch[a_.*x_^n_.]/x_,x_Symbol] :=
(* Int[ArcSinh[1/a*x^(-n)]/x,x] /; *)
  -ArcCsch[a*x^n]^2/(2*n) - 
  ArcCsch[a*x^n]*Log[1-E^(-2*ArcCsch[a*x^n])]/n + 
  PolyLog[2,E^(-2*ArcCsch[a*x^n])]/(2*n) /;
(* -ArcCsch[a*x^n]^2/(2*n) - 
  ArcCsch[a*x^n]*Log[1-1/(1/(a*x^n)+Sqrt[1+1/(a^2*x^(2*n))])^2]/n + 
  PolyLog[2,1/(1/(a*x^n)+Sqrt[1+1/(a^2*x^(2*n))])^2]/(2*n) /; *)
FreeQ[{a,n},x]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*ArcCsch[a_+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*ArcCsch[x],x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Reference: CRC 596, A&S 4.6.56*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCsch[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*ArcCsch[a+b*x]/(m+1) + 
  Dist[b/(m+1),Int[x^(m+1)/((a+b*x)^2*Sqrt[1+1/(a+b*x)^2]),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*u ArcCsch[c / (a+b x^n)]		Inverse cosecant of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCsch[z] == ArcSinh[1/z]*)


Int[u_.*ArcCsch[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcSinh[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*u ArcCsch[v]				Products of expressions and arccosecants of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCsch[u_],x_Symbol] :=
  x*ArcCsch[u] +
  Int[Regularize[x*D[u,x]/(u^2*Sqrt[1+1/u^2]),x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsubsection::Closed:: *)
(*u E^(n ArcCsch[v])			Products of expressions and exponentials of arccosines  *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCsch[z]) == (1/z+Sqrt[1+1/z^2])^n*)


Int[E^(n_.*ArcCsch[v_]), x_Symbol] :=
  Int[(1/v+Sqrt[1+1/v^2])^n,x] /;
IntegerQ[n] && PolynomialQ[v,x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: E^(n*ArcCsch[z]) == (1/z+Sqrt[1+1/z^2])^n*)


Int[x_^m_.*E^(n_.*ArcCsch[v_]), x_Symbol] :=
  Int[x^m*(1/v+Sqrt[1+1/v^2])^n,x] /;
RationalQ[m] && IntegerQ[n] && PolynomialQ[v,x]
././@LongLink0000000000000000000000000000014600000000000011566 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/HyperbolicFunctionIntegrationRules.mmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/HyperbolicFunctionIntegrationRules.0000644000175000017500000036065411446257035034041 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Hyperbolic Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Hyperbolic Sine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x]^n				Powers of sines of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.20, CRC 554, A&S 4.5.77*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Cosh'[z] == -Sinh[z]*)


Int[Sinh[a_.+b_.*x_],x_Symbol] :=
  Cosh[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.414.2, CRC 566*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[Sinh[a_.+b_.*x_]^2,x_Symbol] :=
  -x/2 + Cosh[a+b*x]*Sinh[a+b*x]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Sinh[z]^n == (-1+Cosh[z]^2)^((n-1)/2)*Cosh'[z]*)


Int[Sinh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(-1+x^2)^((n-1)/2),x],x],x,Cosh[a+b*x]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*(a+b Sinh[c+d x])^n			Powers of linear binomials of sines of linears*)


Int[1/(a_+b_.*Sinh[c_.+d_.*x_]),x_Symbol] :=
  -Cosh[c+d*x]/(d*(b-a*Sinh[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


(* ::Item:: *)
(*Reference: G&R 2.441.3b*)


Int[1/(a_+b_.*Sinh[c_.+d_.*x_]),x_Symbol] :=
  -2*ArcTanh[(b-a*Tanh[(c+d*x)/2])/Rt[a^2+b^2,2]]/(d*Rt[a^2+b^2,2]) /;
FreeQ[{a,b,c,d},x] && PosQ[a^2+b^2]


Int[1/(a_+b_.*Sinh[c_.+d_.*x_]),x_Symbol] :=
  2*ArcTan[(b-a*Tanh[(c+d*x)/2])/Rt[-a^2-b^2,2]]/(d*Rt[-a^2-b^2,2]) /;
FreeQ[{a,b,c,d},x] && NegQ[a^2+b^2]


(* ::ItemParagraph:: *)
(**)


Int[Sqrt[a_+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*b*Cosh[c+d*x]/(d*Sqrt[a+b*Sinh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


(* ::Item:: *)
(*Basis: D[EllipticE[x,n],x] == Sqrt[1-n*Sin[x]^2]*)


Int[Sqrt[a_.+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*I*Sqrt[a-I*b]*EllipticE[(Pi/2-I*(c+d*x))/2,2*b/(a*I+b)]/d /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && PositiveQ[a-I*b]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[Sqrt[a+b*f[c+d*x]]/Sqrt[(a+b*f[c+d*x])/(a+b)],x] == 0*)


Int[Sqrt[a_.+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  Sqrt[a+b*Sinh[c+d*x]]/Sqrt[(a+b*Sinh[c+d*x])/(a-I*b)]*Int[Sqrt[a/(a-I*b)+b/(a-I*b)*Sinh[c+d*x]],x] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && Not[PositiveQ[a-I*b]]


(* ::ItemParagraph:: *)
(**)


Int[1/Sqrt[a_+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  -2*ArcTanh[Cosh[(c+Pi*I/2+d*x)/2]]*Sinh[(c+Pi*I/2+d*x)/2]/(d*Sqrt[a+b*Sinh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a-b*I]


Int[1/Sqrt[a_+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*ArcTan[Sinh[(c+Pi*I/2+d*x)/2]]*Cosh[(c+Pi*I/2+d*x)/2]/(d*Sqrt[a+b*Sinh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a+b*I]


(* ::Item:: *)
(*Basis: D[EllipticF[x,n],x] == 1/Sqrt[1-n*Sin[x]^2]*)


Int[1/Sqrt[a_.+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*I*EllipticF[(Pi/2-I*(c+d*x))/2,2*b/(a*I+b)]/(d*Sqrt[a-I*b]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && PositiveQ[a-I*b]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[Sqrt[(a+b*f[c+d*x])/(a+b)]/Sqrt[a+b*f[c+d*x]],x] == 0*)


Int[1/Sqrt[a_.+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  Sqrt[(a+b*Sinh[c+d*x])/(a-I*b)]/Sqrt[a+b*Sinh[c+d*x]]*Int[1/Sqrt[a/(a-I*b)+b/(a-I*b)*Sinh[c+d*x]],x] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2] && Not[PositiveQ[a-I*b]]


(* ::ItemParagraph:: *)
(**)


Int[(a_+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^(n-1)/(d*n) +
  Dist[a*(2*n-1)/n,Int[(a+b*Sinh[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2+b^2]


Int[(a_+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^n/(a*d*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Sinh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && ZeroQ[a^2+b^2]


(* ::Item:: *)
(*Reference: G&R 2.441.1 inverted*)


(* This results in an infinite loop!!! *)
(* Int[(a_+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^n/(a*d*n) +
  Dist[(a^2+b^2)/a,Int[(a+b*Sinh[c+d*x])^(n-1),x]] +
  Dist[b*(n+1)/(a*n),Int[Sinh[c+d*x]*(a+b*Sinh[c+d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>0 && NonzeroQ[a^2+b^2] *)


Int[1/(a_+b_.*Sinh[c_.+d_.*x_])^2,x_Symbol] :=
  -b*Cosh[c+d*x]/(d*(a^2+b^2)*(a+b*Sinh[c+d*x])) + 
  Dist[a/(a^2+b^2),Int[1/(a+b*Sinh[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2+b^2]


Int[(a_+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^(n+1)/(d*(n+1)*(a^2+b^2)) +
  Dist[1/((n+1)*(a^2+b^2)),Int[(a*(n+1)-b*(n+2)*Sinh[c+d*x])*(a+b*Sinh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2+b^2]


(* ::ItemParagraph::Closed:: *)
(**)


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sinh[a_.+b_.*x_])^n_,x_Symbol] :=
  c*Cosh[a+b*x]*(c*Sinh[a+b*x])^(n-1)/(b*n) -
  Dist[(n-1)*c^2/n,Int[(c*Sinh[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[OddQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.5, CRC 568a*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sinh[a_.+b_.*x_])^n_,x_Symbol] :=
  Cosh[a+b*x]*(c*Sinh[a+b*x])^(n+1)/(c*b*(n+1)) - 
  Dist[(n+2)/((n+1)*c^2),Int[(c*Sinh[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Sinh[x])^n/Sinh[x]^n,x] == 0*)


Int[(c_*Sinh[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Sinh[a+b*x])^n/Sinh[a+b*x]^n*Int[Sinh[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -10


(* ::Subsubsection::Closed:: *)
(*(A+B Sinh[c+d x]) (a+b Sinh[c+d x])^n  Products of powers of linear binomials of sines*)


(* ::Item:: *)
(*Basis: (A+B*z)/Sqrt[a+b*z] == (b*A-a*B)/(b*Sqrt[a+b*z]) + B/b*Sqrt[a+b*z]*)


Int[(A_.+B_.*Sinh[c_.+d_.*x_])/Sqrt[a_+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  Dist[(b*A-a*B)/b,Int[1/Sqrt[a+b*Sinh[c+d*x]],x]] +
  Dist[B/b,Int[Sqrt[a+b*Sinh[c+d*x]],x]] /;
FreeQ[{a,b,c,d,A,B},x] && NonzeroQ[b*A-a*B]


(* ::Item:: *)
(*Reference: G&R 2.441.1 inverted*)


Int[(A_.+B_.*Sinh[c_.+d_.*x_])*(a_+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  B*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^n/(d*(n+1)) + 
  Dist[1/(n+1),Int[(-b*B*n+a*A*(n+1) + (a*B*n+b*A*(n+1))*Sinh[c+d*x])*(a+b*Sinh[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n>1 && NonzeroQ[a^2+b^2]


(* ::Item:: *)
(*Reference: G&R 2.441.1 special case*)


Int[(A_+B_.*Sinh[c_.+d_.*x_])/(a_+b_.*Sinh[c_.+d_.*x_])^2,x_Symbol] :=
  B*Cosh[c+d*x]/(a*d*(a+b*Sinh[c+d*x])) /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A+b*B]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*(A_+B_.*Sinh[c_.+d_.*x_])/(a_+b_.*Sinh[c_.+d_.*x_])^2,x_Symbol] :=
  B*x*Cosh[c+d*x]/(a*d*(a+b*Sinh[c+d*x])) -
  Dist[B/(a*d),Int[Cosh[c+d*x]/(a+b*Sinh[c+d*x]),x]] /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A+b*B]


(* ::Item:: *)
(*Reference: G&R 2.441.1*)


Int[(A_.+B_.*Sinh[c_.+d_.*x_])*(a_.+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  -(a*B-b*A)*Cosh[c+d*x]*(a+b*Sinh[c+d*x])^(n+1)/(d*(n+1)*(a^2+b^2)) +
  Dist[1/((n+1)*(a^2+b^2)),Int[((n+1)*(a*A+b*B)+(n+2)*(a*B-b*A)*Sinh[c+d*x])*(a+b*Sinh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2+b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Sinh[c+d x]^2)^n		Products of monomials and powers of quadratic binomials of sines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[z]^2 == (-1 + Cosh[2*z])/2*)


Int[x_^m_./(a_+b_.*Sinh[c_.+d_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a-b+b*Cosh[2*c+2*d*x]),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0 && NonzeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a+b*Cosh[z]^2+c*Sinh[z]^2 == (2*a+b-c + (b+c)*Cosh[2*z])/2*)


Int[x_^m_./(a_.+b_.*Cosh[d_.+e_.*x_]^2+c_.*Sinh[d_.+e_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a+b-c+(b+c)*Cosh[2*d+2*e*x]),x]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[m] && m>0 && NonzeroQ[a+b] && NonzeroQ[a-c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[z]^2 == (-1 + Cosh[2*z])/2*)


Int[(a_+b_.*Sinh[c_.+d_.*x_]^2)^n_,x_Symbol] :=
  Dist[1/2^n,Int[(2*a-b+b*Cosh[2*c+2*d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a-b] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Sinh[c+d x] Cosh[c+d x])^n	Products of monomials and powers involving products of sines and cosines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[z]*Cosh[z] == Sinh[2*z]/2*)


Int[x_^m_./(a_+b_.*Sinh[c_.+d_.*x_]*Cosh[c_.+d_.*x_]),x_Symbol] :=
  Int[x^m/(a+b*Sinh[2*c+2*d*x]/2),x] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[z]*Cosh[z] == Sinh[2*z]/2*)


Int[(a_+b_.*Sinh[c_.+d_.*x_]*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(a+b*Sinh[2*c+2*d*x]/2)^n,x] /;
FreeQ[{a,b,c,d},x] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x]^m Cosh[a+b x]^n		Products of powers of sines and cosines*)


Int[Sinh[a_.+b_.*x_]^m_.*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^(m+1)*Cosh[a+b*x]^(n+1)/(b*(m+1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+2] && NonzeroQ[m+1] && PosQ[m]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Cosh[z]^n == (1+Sinh[z]^2)^((n-1)/2)*Sinh'[z]*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[x^m*(1+x^2)^((n-1)/2),x],x],x,Sinh[a+b*x]]] /;
FreeQ[{a,b,m},x] && OddQ[n] && Not[OddQ[m] && 01 && n<-1


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b, A&S 4.5.85b*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^(m-1)*Cosh[a+b*x]^(n+1)/(b*(m+n)) -
  Dist[(m-1)/(m+n),Int[Sinh[a+b*x]^(m-2)*Cosh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m]] && NonzeroQ[m+n] &&
Not[OddQ[n] && n>1]


(* ::Item:: *)
(*Reference: G&R 2.411.5, CRC 568a, A&S 4.5.86a*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^(m+1)*Cosh[a+b*x]^(n+1)/(b*(m+1)) -
  Dist[(m+n+2)/(m+1),Int[Sinh[a+b*x]^(m+2)*Cosh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+2]


(* Kool rule *)
Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/(b*m),Subst[Int[x^(1/m)/(1-x^(2/m)),x],x,Sinh[a+b*x]^m*Cosh[a+b*x]^n]] /;
FreeQ[{a,b},x] && FractionQ[{m,n}] && ZeroQ[m+n] && IntegerQ[1/m] && m>0


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x]^m Tanh[a+b x]^n	Products of powers of sines and tangents*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.18'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z]*Tanh[z] == Cosh[z]-Sech[z]*)


Int[Sinh[a_.+b_.*x_]*Tanh[a_.+b_.*x_],x_Symbol] :=
  Sinh[a+b*x]/b - Int[Sech[a+b*x],x] /;
FreeQ[{a,b},x]


Int[Sinh[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol]:=
  Sinh[a+b*x]^m*Tanh[a+b*x]^(n-1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-1]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[Sinh[a_.+b_.*x_]^m_.*Tanh[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(-1+x^2)^((m+n-1)/2)/x^n,x],x],x,Cosh[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && OddQ[m+n]


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a*)


Int[Sinh[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^m*Tanh[a+b*x]^(n+1)/(b*m) -
  Dist[(n+1)/m,Int[Sinh[a+b*x]^(m-2)*Tanh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m>1 && n<-1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.6, CRC 568b*)


Int[Sinh[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^(m+2)*Tanh[a+b*x]^(n-1)/(b*(n-1)) -
  Dist[(m+2)/(n-1),Int[Sinh[a+b*x]^(m+2)*Tanh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


Int[Sinh[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_.,x_Symbol]:=
  Sinh[a+b*x]^m*Tanh[a+b*x]^(n-1)/(b*m) -
  Dist[(m+n-1)/m,Int[Sinh[a+b*x]^(m-2)*Tanh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.3*)


Int[Sinh[a_.+b_.*x_]^m_.*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sinh[a+b*x]^m*Tanh[a+b*x]^(n-1)/(b*(n-1)) +
  Dist[(m+n-1)/(n-1),Int[Sinh[a+b*x]^m*Tanh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.5, CRC 568a*)


Int[Sinh[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_.,x_Symbol]:=
  Sinh[a+b*x]^(m+2)*Tanh[a+b*x]^(n-1)/(b*(m+n+1)) -
  Dist[(m+2)/(m+n+1),Int[Sinh[a+b*x]^(m+2)*Tanh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.4*)


Int[Sinh[a_.+b_.*x_]^m_.*Tanh[a_.+b_.*x_]^n_,x_Symbol]:=
  Sinh[a+b*x]^m*Tanh[a+b*x]^(n+1)/(b*(m+n+1)) +
  Dist[(n+1)/(m+n+1),Int[Sinh[a+b*x]^m*Tanh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x^n]				Sines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: FresnelS'[z] == Sin[Pi*z^2/2]*)


(* Note: This rule introduces I;whereas,converting to exponentials does not. *)
(* Int[Sinh[b_.*x_^2],x_Symbol] :=
  -I*Sqrt[Pi/2]*FresnelS[Rt[I*b,2]*x/Sqrt[Pi/2]]/Rt[I*b,2] /;
FreeQ[b,x] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z] == E^z/2 - E^(-z)/2*)


Int[Sinh[a_.+b_.*x_^n_],x_Symbol] :=
  Dist[1/2,Int[E^(a+b*x^n),x]] - 
  Dist[1/2,Int[E^(-a-b*x^n),x]] /;
FreeQ[{a,b,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one, rules for 
	improper binomials rectify it. *)
Int[Sinh[a_.+b_.*x_^n_],x_Symbol] :=
  x*Sinh[a+b*x^n] - 
  Dist[b*n,Int[x^n*Cosh[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a+b x^n]			Products of monomials and sines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: SinhIntegral'[z] == Sinh[z]/z*)


Int[Sinh[a_.*x_^n_.]/x_,x_Symbol] :=
  SinhIntegral[a*x^n]/n /;
FreeQ[{a,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[w+z] == Sinh[w]*Cosh[z] + Cosh[w]*Sinh[z]*)


Int[Sinh[a_+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[Sinh[a],Int[Cosh[b*x^n]/x,x]] + 
  Dist[Cosh[a],Int[Sinh[b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 392h, A&S 4.5.83*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*Sinh[a+b*x^n] == x^(m-n+1)*(Sinh[a+b*x^n]*x^(n-1))*)


Int[x_^m_.*Sinh[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m-n+1)*Cosh[a+b*x^n]/(b*n) -
  Dist[(m-n+1)/(b*n),Int[x^(m-n)*Cosh[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[m] && 00 && m<-1 || 0<-n1 && ZeroQ[m-2*n+1]


(* ::Item:: *)
(*Reference: G&R 2.471.1b' w/ q=0*)


Int[x_^m_.*Sinh[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  -(m-n+1)*x^(m-2*n+1)*Sinh[a+b*x^n]^p/(b^2*n^2*p^2) +
  x^(m-n+1)*Cosh[a+b*x^n]*Sinh[a+b*x^n]^(p-1)/(b*n*p) -
  Dist[(p-1)/p,Int[x^m*Sinh[a+b*x^n]^(p-2),x]] +
  Dist[(m-n+1)*(m-2*n+1)/(b^2*n^2*p^2),Int[x^(m-2*n)*Sinh[a+b*x^n]^p,x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[{m,p}] && p>1 && 0<2*n1 && m<-1 && n>0 && NonzeroQ[m+n+1]


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a+b (c+d x)^n]^p		Products of monomials and powers of sines of binomials of linears*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b x,x],x] == Subst[Int[f[x,-a/b+x/b],x],x,a+b x]/b*)


Int[x_^m_.*Sinh[a_.+b_.*(c_+d_.*x_)^n_]^p_.,x_Symbol] :=
  Dist[1/d,Subst[Int[(-c/d+x/d)^m*Sinh[a+b*x^n]^p,x],x,c+d*x]] /;
FreeQ[{a,b,c,d,n},x] && IntegerQ[m] && m>0 && RationalQ[p]


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x+c x^2]			Sines of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*x+c*x^2 == (b+2*c*x)^2/(4*c)*)


Int[Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Int[Sinh[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z] == E^z/2 - E^(-z)/2*)


Int[Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Dist[1/2,Int[E^(a+b*x+c*x^2),x]] - 
  Dist[1/2,Int[E^(-a-b*x-c*x^2),x]] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m Sinh[a+b x+c x^2]		Products of monomials and sines of quadratic trinomials*)
(**)


Int[(d_.+e_.*x_)*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Cosh[a+b*x+c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Cosh[a+b*x+c*x^2]/(2*c) -
  Dist[(b*e-2*c*d)/(2*c),Int[Sinh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Cosh[a+b*x+c*x^2]/(2*c) -
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Cosh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Cosh[a+b*x+c*x^2]/(2*c) -
  Dist[(b*e-2*c*d)/(2*c),Int[(d+e*x)^(m-1)*Sinh[a+b*x+c*x^2],x]] -
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Cosh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Sinh[a+b*x+c*x^2]/(e*(m+1)) -
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Cosh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Sinh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Sinh[a+b*x+c*x^2]/(e*(m+1)) -
  Dist[(b*e-2*c*d)/(e^2*(m+1)),Int[(d+e*x)^(m+1)*Cosh[a+b*x+c*x^2],x]] -
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Cosh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && NonzeroQ[b*e-2*c*d]


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b Log[c x^n]]^p		Powers of sines of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[b*Log[c*x^n]] == (c*x^n)^b/2 - 1/(2*(c*x^n)^b)*)


Int[Sinh[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[((c*x^n)^b/2 - 1/(2*(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,n,p}]


Int[Sinh[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  x*Sinh[a+b*Log[c*x^n]]/(1-b^2*n^2) -
  b*n*x*Cosh[a+b*Log[c*x^n]]/(1-b^2*n^2) /;
FreeQ[{a,b,c,n},x] && NonzeroQ[1-b^2*n^2]


Int[Sqrt[Sinh[a_.+b_.*Log[c_.*x_^n_.]]],x_Symbol] :=
  x*Sqrt[Sinh[a+b*Log[c*x^n]]]/Sqrt[-1+E^(2*a)*(c*x^n)^(4/n)]*
    Int[Sqrt[-1+E^(2*a)*(c*x^n)^(4/n)]/x,x] /;
FreeQ[{a,b,c,n},x] && ZeroQ[b*n-2]


(* Int[1/Sqrt[Sinh[a_.+b_.*Log[c_.*x_^n_.]]],x_Symbol] :=
  ??? /;
FreeQ[{a,b,c,n},x] && ZeroQ[b*n-2] *)


Int[Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Coth[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  x*Sinh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) /;
FreeQ[{a,b,c,n,p},x] && NonzeroQ[p+1] && NonzeroQ[p+2] && ZeroQ[b^2*n^2*(p+2)^2-1]


Int[Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Sinh[a+b*Log[c*x^n]]^p/(1-b^2*n^2*p^2) -
  b*n*p*x*Cosh[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p-1)/(1-b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p-1)/(1-b^2*n^2*p^2),Int[Sinh[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && NonzeroQ[1-b^2*n^2*p^2]


Int[Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Coth[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  x*Sinh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) -
  Dist[(b^2*n^2*(p+2)^2-1)/(b^2*n^2*(p+1)*(p+2)),Int[Sinh[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[b^2*n^2*(p+2)^2-1]


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a+b Log[c x^n]]^p		Products of monomials and powers of sines of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[b*Log[c*x^n]] == (c*x^n)^b/2 - 1/(2*(c*x^n)^b)*)


Int[x_^m_.*Sinh[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[x^m*((c*x^n)^b/2 - 1/(2*(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,m,n,p}]


Int[x_^m_.*Sinh[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  (m+1)*x^(m+1)*Sinh[a+b*Log[c*x^n]]/((m+1)^2-b^2*n^2) -
  b*n*x^(m+1)*Cosh[a+b*Log[c*x^n]]/((m+1)^2-b^2*n^2) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[(m+1)^2-b^2*n^2] && NonzeroQ[m+1]


Int[x_^m_.*Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x^(m+1)*Coth[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  (m+1)*x^(m+1)*Sinh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) /;
FreeQ[{a,b,c,m,n,p},x] && NonzeroQ[p+1] && NonzeroQ[p+2] && ZeroQ[(m+1)^2-b^2*n^2*(p+2)^2]


Int[x_^m_.*Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Sinh[a+b*Log[c*x^n]]^p/((m+1)^2-b^2*n^2*p^2) -
  b*n*p*x^(m+1)*Cosh[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p-1)/((m+1)^2-b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p-1)/((m+1)^2-b^2*n^2*p^2),Int[x^m*Sinh[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && NonzeroQ[(m+1)^2-b^2*n^2*p^2] && NonzeroQ[m+1]


Int[x_^m_.*Sinh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x^(m+1)*Coth[a+b*Log[c*x^n]]*Sinh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) -
  (m+1)*x^(m+1)*Sinh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[((m+1)^2-b^2*n^2*(p+2)^2)/(b^2*n^2*(p+1)*(p+2)),Int[x^m*Sinh[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[m+1] && NonzeroQ[(m+1)^2-b^2*n^2*(p+2)^2]


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a x^n Log[b x]^p Log[b x]^p  Products of sines and powers of logarithms*)
(**)


Int[Sinh[a_.*x_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Cosh[a*x*Log[b*x]^p]/a -
  Dist[p,Int[Sinh[a*x*Log[b*x]^p]*Log[b*x]^(p-1),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>0


Int[Sinh[a_.*x_^n_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Cosh[a*x^n*Log[b*x]^p]/(a*n*x^(n-1)) -
  Dist[p/n,Int[Sinh[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] +
  Dist[(n-1)/(a*n),Int[Cosh[a*x^n*Log[b*x]^p]/x^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{n,p}] && p>0


Int[x_^m_*Sinh[a_.*x_^n_.*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  x^(m-n+1)*Cosh[a*x^n*Log[b*x]^p]/(a*n) -
  Dist[p/n,Int[x^m*Sinh[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] -
  Dist[(m-n+1)/(a*n),Int[x^(m-n)*Cosh[a*x^n*Log[b*x]^p],x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>0


(* ::Subsubsection::Closed:: *)
(*u Sinh[v]^2				Products involving squares of sines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z]^2 == -1/2 + 1/2*Cosh[2*z]*)


Int[u_*Sinh[v_]^2,x_Symbol] :=
  Dist[-1/2,Int[u,x]] + 
  Dist[1/2,Int[u*Cosh[2*v],x]] /;
FunctionOfHyperbolicQ[u,2*v,x]


(* ::Subsubsection::Closed:: *)
(*u Sinh[v] Hyper[w]			Products of hyperbolic trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Cosh[w] == Sinh[v+w]/2 + Sinh[v-w]/2*)


Int[u_.*Sinh[v_]*Cosh[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Sinh[v+w],x],x]] + 
  Dist[1/2,Int[u*Regularize[Sinh[v-w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && PosQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Sinh[w] == Cosh[v+w]/2 - Cosh[v-w]/2*)


Int[u_.*Sinh[v_]*Sinh[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Cosh[v+w],x],x]] - 
  Dist[1/2,Int[u*Regularize[Cosh[v-w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Tanh[w] == Cosh[v] - Cosh[v-w]*Sech[w]*)


Int[u_.*Sinh[v_]*Tanh[w_]^n_.,x_Symbol] :=
  Int[u*Cosh[v]*Tanh[w]^(n-1),x] - Cosh[v-w]*Int[u*Sech[w]*Tanh[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Coth[w] == Cosh[v] + Sinh[v-w]*Csch[w]*)


Int[u_.*Sinh[v_]*Coth[w_]^n_.,x_Symbol] :=
  Int[u*Cosh[v]*Coth[w]^(n-1),x] + Sinh[v-w]*Int[u*Csch[w]*Coth[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Sech[w] == Cosh[v-w]*Tanh[w] + Sinh[v-w]*)


Int[u_.*Sinh[v_]*Sech[w_]^n_.,x_Symbol] :=
  Cosh[v-w]*Int[u*Tanh[w]*Sech[w]^(n-1),x] + Sinh[v-w]*Int[u*Sech[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Csch[w] == Sinh[v-w]*Coth[w] + Cosh[v-w]*)


Int[u_.*Sinh[v_]*Csch[w_]^n_.,x_Symbol] :=
  Sinh[v-w]*Int[u*Coth[w]*Csch[w]^(n-1),x] + Cosh[v-w]*Int[u*Csch[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Subsection::Closed:: *)
(*Hyperbolic Cosine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x]^n				Powers of cosines of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.21, CRC 555, A&S 4.5.78*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Sinh'[z] == Cosh[z]*)


Int[Cosh[a_.+b_.*x_],x_Symbol] :=
  Sinh[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.414.9, CRC 572*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[Cosh[a_.+b_.*x_]^2,x_Symbol] :=
  x/2 + Cosh[a+b*x]*Sinh[a+b*x]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, Cosh[z]^n == (1+Sinh[z]^2)^((n-1)/2)*Sinh'[z]*)


Int[Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1+x^2)^((n-1)/2),x],x],x,Sinh[a+b*x]]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*(a+b Cosh[c+d x])^n			Powers of linear binomials of cosines of linears*)


(* ::Item:: *)
(*Reference: G&R 2.446.2'*)


Int[1/(a_+b_.*Cosh[c_.+d_.*x_]),x_Symbol] :=
  Sinh[c+d*x]/(d*(b+a*Cosh[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.443.3c'*)


Int[1/(a_+b_.*Cosh[c_.+d_.*x_]),x_Symbol] :=
  2*ArcTanh[((a-b)*Tanh[(c+d*x)/2])/Rt[a^2-b^2,2]]/(d*Rt[a^2-b^2,2]) /;
FreeQ[{a,b,c,d},x] && PosQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.443.3a'*)


Int[1/(a_+b_.*Cosh[c_.+d_.*x_]),x_Symbol] :=
  -2*ArcTan[((a-b)*Tanh[(c+d*x)/2])/Rt[b^2-a^2,2]]/(d*Rt[b^2-a^2,2]) /;
FreeQ[{a,b,c,d},x] && NegQ[a^2-b^2]


(* ::ItemParagraph:: *)
(**)


Int[Sqrt[a_+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  2*b*Sinh[c+d*x]/(d*Sqrt[a+b*Cosh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Basis: D[EllipticE[x,n],x] == Sqrt[1-n*Sin[x]^2]*)


Int[Sqrt[a_.+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  -2*I*Sqrt[a+b]*EllipticE[I*(c+d*x)/2,2*b/(a+b)]/d /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && PositiveQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[Sqrt[a+b*f[c+d*x]]/Sqrt[(a+b*f[c+d*x])/(a+b)],x] == 0*)


Int[Sqrt[a_.+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  Sqrt[a+b*Cosh[c+d*x]]/Sqrt[(a+b*Cosh[c+d*x])/(a+b)]*Int[Sqrt[a/(a+b)+b/(a+b)*Cosh[c+d*x]],x] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && Not[PositiveQ[a+b]]


(* ::ItemParagraph:: *)
(**)


Int[1/Sqrt[a_+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  2*ArcTan[Sinh[(c+d*x)/2]]*Cosh[(c+d*x)/2]/(d*Sqrt[a+b*Cosh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a-b]


Int[1/Sqrt[a_+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  -2*ArcTanh[Cosh[(c+d*x)/2]]*Sinh[(c+d*x)/2]/(d*Sqrt[a+b*Cosh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a+b]


(* ::Item:: *)
(*Basis: D[EllipticF[x,n],x] == 1/Sqrt[1-n*Sin[x]^2]*)


Int[1/Sqrt[a_.+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  -2*I*EllipticF[I*(c+d*x)/2,2*b/(a+b)]/(d*Sqrt[a+b]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && PositiveQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[Sqrt[(a+b*f[c+d*x])/(a+b)]/Sqrt[a+b*f[c+d*x]],x] == 0*)


Int[1/Sqrt[a_+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  Sqrt[(a+b*Cosh[c+d*x])/(a+b)]/Sqrt[a+b*Cosh[c+d*x]]*Int[1/Sqrt[a/(a+b)+b/(a+b)*Cosh[c+d*x]],x] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && Not[PositiveQ[a+b]]


(* ::ItemParagraph:: *)
(**)


Int[(a_+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^(n-1)/(d*n) +
  Dist[a*(2*n-1)/n,Int[(a+b*Cosh[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.446.1'*)


Int[(a_+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^n/(a*d*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Cosh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && ZeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.443.1 inverted*)


(* Note: This results in an infinite loop!!! *)
(* Int[(a_+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  -b*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^n/(a*d*n) +
  Dist[(a^2-b^2)/a,Int[(a+b*Cosh[c+d*x])^(n-1),x]] +
  Dist[b*(n+1)/(a*n),Int[Cosh[c+d*x]*(a+b*Cosh[c+d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>0 && NonzeroQ[a^2-b^2] *)


(* ::Item:: *)
(*Reference: G&R 2.443.1*)


Int[1/(a_+b_.*Cosh[c_.+d_.*x_])^2,x_Symbol] :=
  -b*Sinh[c+d*x]/(d*(a^2-b^2)*(a+b*Cosh[c+d*x])) + 
  Dist[a/(a^2-b^2),Int[1/(a+b*Cosh[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.443.1*)


Int[(a_+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  b*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) + 
  Dist[1/((n+1)*(a^2-b^2)),Int[(a*(n+1)-b*(n+2)*Cosh[c+d*x])*(a+b*Cosh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::ItemParagraph::Closed:: *)
(**)


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 305h*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Cosh[a_.+b_.*x_])^n_,x_Symbol] :=
  c*Sinh[a+b*x]*(c*Cosh[a+b*x])^(n-1)/(b*n) + 
  Dist[(n-1)*c^2/n,Int[(c*Cosh[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[OddQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.6, CRC 568b*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Cosh[a_.+b_.*x_])^n_,x_Symbol] :=
  -Sinh[a+b*x]*(c*Cosh[a+b*x])^(n+1)/(b*c*(n+1)) + 
  Dist[(n+2)/((n+1)*c^2),Int[(c*Cosh[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Cosh[x])^n/Cosh[x]^n,x] == 0*)


Int[(c_*Cosh[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Cosh[a+b*x])^n/Cosh[a+b*x]^n*Int[Cosh[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -10


(* ::Subsubsection::Closed:: *)
(*(A+B Cosh[c+d x]) (a+b Cosh[c+d x])^n  Products of powers of linear binomials of cosines*)


(* ::Item:: *)
(*Basis: (A+B*z)/Sqrt[a+b*z] == (b*A-a*B)/(b*Sqrt[a+b*z]) + B/b*Sqrt[a+b*z]*)


Int[(A_.+B_.*Cosh[c_.+d_.*x_])/Sqrt[a_+b_.*Cosh[c_.+d_.*x_]],x_Symbol] :=
  Dist[(b*A-a*B)/b,Int[1/Sqrt[a+b*Cosh[c+d*x]],x]] +
  Dist[B/b,Int[Sqrt[a+b*Cosh[c+d*x]],x]] /;
FreeQ[{a,b,c,d,A,B},x] && NonzeroQ[b*A-a*B]


(* ::Item:: *)
(*Reference: G&R 2.443.1 inverted*)


Int[(A_.+B_.*Cosh[c_.+d_.*x_])*(a_+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  B*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^n/(d*(n+1)) + 
  Dist[1/(n+1),Int[(b*B*n+a*A*(n+1) + (a*B*n+b*A*(n+1))*Cosh[c+d*x])*(a+b*Cosh[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n>1 && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Reference: G&R 2.443.1 special case*)


Int[(A_+B_.*Cosh[c_.+d_.*x_])/(a_+b_.*Cosh[c_.+d_.*x_])^2,x_Symbol] :=
  B*Sinh[c+d*x]/(a*d*(a+b*Cosh[c+d*x])) /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*(A_+B_.*Cosh[c_.+d_.*x_])/(a_+b_.*Cosh[c_.+d_.*x_])^2,x_Symbol] :=
  B*x*Sinh[c+d*x]/(a*d*(a+b*Cosh[c+d*x])) -
  Dist[B/(a*d),Int[Sinh[c+d*x]/(a+b*Cosh[c+d*x]),x]] /;
FreeQ[{a,b,c,d,A,B},x] && ZeroQ[a*A-b*B]


(* ::Item:: *)
(*Reference: G&R 2.443.1*)


Int[(A_.+B_.*Cosh[c_.+d_.*x_])*(a_.+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  -(a*B-b*A)*Sinh[c+d*x]*(a+b*Cosh[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[1/((n+1)*(a^2-b^2)),Int[((n+1)*(a*A-b*B)+(n+2)*(a*B-b*A)*Cosh[c+d*x])*(a+b*Cosh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*x^m (a+b Cosh[c+d x]^2)^n		Products of monomials and powers of quadratic binomials of sines of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cosh[z]^2 == (1 + Cosh[2*z])/2*)


Int[x_^m_./(a_+b_.*Cosh[c_.+d_.*x_]^2),x_Symbol] :=
  Dist[2,Int[x^m/(2*a+b+b*Cosh[2*c+2*d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cosh[z]^2 == (1 + Cosh[2*z])/2*)


Int[(a_+b_.*Cosh[c_.+d_.*x_]^2)^n_,x_Symbol] :=
  Dist[1/2^n,Int[(2*a+b+b*Cosh[2*c+2*d*x])^n,x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b] && HalfIntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x]^n Sinh[a+b x]^m 	Products of powers of cosines and sines*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Sinh[a+b*x]^(m+1)*Cosh[a+b*x]^(n+1)/(b*(n+1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+2] && NonzeroQ[n+1] && PosQ[n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is odd, Sinh[z]^m == (-1+Cosh[z]^2)^((m-1)/2)*Cosh'[z]*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[x^n*(-1+x^2)^((m-1)/2),x],x],x,Cosh[a+b*x]]] /;
FreeQ[{a,b,n},x] && OddQ[m] && Not[OddQ[n] && 01


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a, A&S 4.5.85a*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sinh[a+b*x]^(m+1)*Cosh[a+b*x]^(n-1)/(b*(m+n)) +
  Dist[(n-1)/(m+n),Int[Sinh[a+b*x]^m*Cosh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[n]] && NonzeroQ[m+n] &&
Not[OddQ[m] && m>1]


(* ::Item:: *)
(*Reference: G&R 2.411.6, CRC 568b, A&S 4.5.86b*)


Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sinh[a+b*x]^(m+1)*Cosh[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[(m+n+2)/(n+1),Int[Sinh[a+b*x]^m*Cosh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+2]


(* Kool rule *)
Int[Sinh[a_.+b_.*x_]^m_*Cosh[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/(b*n),Subst[Int[x^(1/n)/(1-x^(2/n)),x],x,Sinh[a+b*x]^m*Cosh[a+b*x]^n]] /;
FreeQ[{a,b},x] && FractionQ[{m,n}] && ZeroQ[m+n] && IntegerQ[1/n] && n>0


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x]^m Coth[a+b x]^n		Products of powers of cosines and cotangents*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.34'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z]*Coth[z] == Sinh[z]+Csch[z]*)


Int[Cosh[a_.+b_.*x_]*Coth[a_.+b_.*x_],x_Symbol] :=
  Cosh[a+b*x]/b + Int[Csch[a+b*x],x] /;
FreeQ[{a,b},x]


Int[Cosh[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  Cosh[a+b*x]^m*Coth[a+b*x]^(n-1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-1]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1+x^2)^((m+n-1)/2)/x^n,x],x],x,Sinh[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && OddQ[m+n]


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  Cosh[a+b*x]^m*Coth[a+b*x]^(n+1)/(b*m) +
  Dist[(n+1)/m,Int[Cosh[a+b*x]^(m-2)*Coth[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m>1 && n<-1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.5, CRC 568a*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Cosh[a+b*x]^(m+2)*Coth[a+b*x]^(n-1)/(b*(n-1)) +
  Dist[(m+2)/(n-1),Int[Cosh[a+b*x]^(m+2)*Coth[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a*)


Int[Cosh[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  Cosh[a+b*x]^m*Coth[a+b*x]^(n-1)/(b*m) +
  Dist[(m+n-1)/m,Int[Cosh[a+b*x]^(m-2)*Coth[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.4*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Cosh[a+b*x]^m*Coth[a+b*x]^(n-1)/(b*(n-1)) +
  Dist[(m+n-1)/(n-1),Int[Cosh[a+b*x]^m*Coth[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.6, CRC 568b*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Cosh[a+b*x]^(m+2)*Coth[a+b*x]^(n-1)/(b*(m+n+1)) +
  Dist[(m+2)/(m+n+1),Int[Cosh[a+b*x]^(m+2)*Coth[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.3*)


Int[Cosh[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  Cosh[a+b*x]^m*Coth[a+b*x]^(n+1)/(b*(m+n+1)) +
  Dist[(n+1)/(m+n+1),Int[Cosh[a+b*x]^m*Coth[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n+1] && Not[OddQ[m] && EvenQ[n]]


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x^n]				Cosines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: FresnelC'[z] == Cos[Pi*z^2/2]*)


(* Note: This rule introduces I;whereas,converting to exponentials does not. *)
(* Int[Cosh[b_.*x_^2],x_Symbol] :=
  Sqrt[Pi/2]*FresnelC[Rt[I*b,2]*x/Sqrt[Pi/2]]/Rt[I*b,2] /;
FreeQ[b,x] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z] == E^(-z)/2 + E^z/2*)


Int[Cosh[a_.+b_.*x_^n_],x_Symbol] :=
  Dist[1/2,Int[E^(-a-b*x^n),x]] + 
  Dist[1/2,Int[E^(a+b*x^n),x]] /;
FreeQ[{a,b,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one, rules for 
	improper binomials rectify it. *)
Int[Cosh[a_.+b_.*x_^n_],x_Symbol] :=
  x*Cosh[a+b*x^n] - 
  Dist[b*n,Int[x^n*Sinh[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a+b x^n]			Products of monomials and cosines of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: CoshIntegral'[z] == Cosh[z]/z*)


Int[Cosh[a_.*x_^n_.]/x_,x_Symbol] :=
  CoshIntegral[a*x^n]/n /;
FreeQ[{a,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[w+z] == Cosh[w]*Cosh[z] + Sinh[w]*Sinh[z]*)


Int[Cosh[a_+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[Cosh[a],Int[Cosh[b*x^n]/x,x]] + 
  Dist[Sinh[a],Int[Sinh[b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Reference: CRC 396h, A&S 4.5.84*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*Cosh[a+b*x^n] == x^(m-n+1)*(Cosh[a+b*x^n]*x^(n-1))*)


Int[x_^m_.*Cosh[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m-n+1)*Sinh[a+b*x^n]/(b*n) -
  Dist[(m-n+1)/(b*n),Int[x^(m-n)*Sinh[a+b*x^n],x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[m] && 00 && m<-1 || 0<-n1 && ZeroQ[m-2*n+1]


(* ::Item:: *)
(*Reference: G&R 2.471.1a' w/ p=0*)


Int[x_^m_.*Cosh[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  -(m-n+1)*x^(m-2*n+1)*Cosh[a+b*x^n]^p/(b^2*n^2*p^2) +
  x^(m-n+1)*Sinh[a+b*x^n]*Cosh[a+b*x^n]^(p-1)/(b*n*p) +
  Dist[(p-1)/p,Int[x^m*Cosh[a+b*x^n]^(p-2),x]] +
  Dist[(m-n+1)*(m-2*n+1)/(b^2*n^2*p^2),Int[x^(m-2*n)*Cosh[a+b*x^n]^p,x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && RationalQ[{m,p}] && p>1 && 0<2*n1 && m<-1 && n>0 && NonzeroQ[m+n+1]


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a+b (c+d x)^n]^p		Products of monomials and powers of cosines of binomials of linears*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b x,x],x] == Subst[Int[f[x,-a/b+x/b],x],x,a+b x]/b*)


Int[x_^m_.*Cosh[a_.+b_.*(c_+d_.*x_)^n_]^p_.,x_Symbol] :=
  Dist[1/d,Subst[Int[(-c/d+x/d)^m*Cosh[a+b*x^n]^p,x],x,c+d*x]] /;
FreeQ[{a,b,c,d,n},x] && IntegerQ[m] && m>0 && RationalQ[p]


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x+c x^2]			Cosines of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*x+c*x^2 == (b+2*c*x)^2/(4*c)*)


Int[Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Int[Cosh[(b+2*c*x)^2/(4*c)],x] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z] == E^(-z)/2 + E^z/2*)


Int[Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  Dist[1/2,Int[E^(-a-b*x-c*x^2),x]] + 
  Dist[1/2,Int[E^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m Cosh[a+b x+c x^2]		Products of monomials and cosines of quadratic trinomials*)
(**)


Int[(d_.+e_.*x_)*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Sinh[a+b*x+c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*Sinh[a+b*x+c*x^2]/(2*c) - 
  Dist[(b*e-2*c*d)/(2*c),Int[Cosh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Sinh[a+b*x+c*x^2]/(2*c) - 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Sinh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  e*(d+e*x)^(m-1)*Sinh[a+b*x+c*x^2]/(2*c) - 
  Dist[(b*e-2*c*d)/(2*c),Int[(d+e*x)^(m-1)*Cosh[a+b*x+c*x^2],x]] - 
  Dist[e^2*(m-1)/(2*c),Int[(d+e*x)^(m-2)*Sinh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m>1 && NonzeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Cosh[a+b*x+c*x^2]/(e*(m+1)) - 
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Sinh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && ZeroQ[b*e-2*c*d]


Int[(d_.+e_.*x_)^m_*Cosh[a_.+b_.*x_+c_.*x_^2],x_Symbol] :=
  (d+e*x)^(m+1)*Cosh[a+b*x+c*x^2]/(e*(m+1)) - 
  Dist[(b*e-2*c*d)/(e^2*(m+1)),Int[(d+e*x)^(m+1)*Sinh[a+b*x+c*x^2],x]] -
  Dist[2*c/(e^2*(m+1)),Int[(d+e*x)^(m+2)*Sinh[a+b*x+c*x^2],x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[m] && m<-1 && NonzeroQ[b*e-2*c*d]


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b Log[c x^n]]^p		Powers of cosines of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cosh[b*Log[c*x^n]] == (c*x^n)^b/2 + 1/(2*(c*x^n)^b)*)


Int[Cosh[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[((c*x^n)^b/2 + 1/(2*(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,n,p}]


Int[Cosh[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  x*Cosh[a+b*Log[c*x^n]]/(1-b^2*n^2) -
  b*n*x*Sinh[a+b*Log[c*x^n]]/(1-b^2*n^2) /;
FreeQ[{a,b,c,n},x] && NonzeroQ[1-b^2*n^2]


Int[Sqrt[Cosh[a_.+b_.*Log[c_.*x_^n_.]]],x_Symbol] :=
  x*Sqrt[Cosh[a+b*Log[c*x^n]]]/Sqrt[1+E^(2*a)*(c*x^n)^(4/n)]*
    Int[Sqrt[1+E^(2*a)*(c*x^n)^(4/n)]/x,x] /;
FreeQ[{a,b,c,n},x] && ZeroQ[b*n-2]


Int[Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x*Tanh[a+b*Log[c*x^n]]*Cosh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) +
  x*Cosh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) /;
FreeQ[{a,b,c,n,p},x] && NonzeroQ[p+1] && NonzeroQ[p+2] && ZeroQ[b^2*n^2*(p+2)^2-1]


Int[Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Cosh[a+b*Log[c*x^n]]^p/(1-b^2*n^2*p^2) -
  b*n*p*x*Cosh[a+b*Log[c*x^n]]^(p-1)*Sinh[a+b*Log[c*x^n]]/(1-b^2*n^2*p^2) -
  Dist[b^2*n^2*p*(p-1)/(1-b^2*n^2*p^2),Int[Cosh[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && NonzeroQ[1-b^2*n^2*p^2]


Int[Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x*Tanh[a+b*Log[c*x^n]]*Cosh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) +
  x*Cosh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) +
  Dist[(b^2*n^2*(p+2)^2-1)/(b^2*n^2*(p+1)*(p+2)),Int[Cosh[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[b^2*n^2*(p+2)^2-1]


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a+b Log[c x^n]]^p		Products of monomials and powers of cosines of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Cosh[b*Log[c*x^n]] == (c*x^n)^b/2 + 1/(2*(c*x^n)^b)*)


Int[x_^m_.*Cosh[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[x^m*((c*x^n)^b/2 + 1/(2*(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,m,n,p}]


Int[x_^m_.*Cosh[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  (m+1)*x^(m+1)*Cosh[a+b*Log[c*x^n]]/((m+1)^2-b^2*n^2) -
  b*n*x^(m+1)*Sinh[a+b*Log[c*x^n]]/((m+1)^2-b^2*n^2) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[(m+1)^2-b^2*n^2] && NonzeroQ[m+1]


Int[x_^m_.*Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x^(m+1)*Tanh[a+b*Log[c*x^n]]*Cosh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) +
  (m+1)*x^(m+1)*Cosh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) /;
FreeQ[{a,b,c,m,n,p},x] && NonzeroQ[p+1] && NonzeroQ[p+2] && ZeroQ[(m+1)^2-b^2*n^2*(p+2)^2]


Int[x_^m_.*Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  (m+1)*x^(m+1)*Cosh[a+b*Log[c*x^n]]^p/((m+1)^2-b^2*n^2*p^2) -
  b*n*p*x^(m+1)*Cosh[a+b*Log[c*x^n]]^(p-1)*Sinh[a+b*Log[c*x^n]]/((m+1)^2-b^2*n^2*p^2) -
  Dist[b^2*n^2*p*(p-1)/((m+1)^2-b^2*n^2*p^2),Int[x^m*Cosh[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && NonzeroQ[(m+1)^2-b^2*n^2*p^2] && NonzeroQ[m+1]


Int[x_^m_.*Cosh[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x^(m+1)*Tanh[a+b*Log[c*x^n]]*Cosh[a+b*Log[c*x^n]]^(p+2)/(b*n*(p+1)) +
  (m+1)*x^(m+1)*Cosh[a+b*Log[c*x^n]]^(p+2)/(b^2*n^2*(p+1)*(p+2)) -
  Dist[((m+1)^2-b^2*n^2*(p+2)^2)/(b^2*n^2*(p+1)*(p+2)),Int[x^m*Cosh[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && p!=-2 && NonzeroQ[m+1] && NonzeroQ[(m+1)^2-b^2*n^2*(p+2)^2]


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a x^n Log[b x]^p Log[b x]^p  Products of cosines and powers of logarithms*)
(**)


Int[Cosh[a_.*x_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Sinh[a*x*Log[b*x]^p]/a -
  Dist[p,Int[Cosh[a*x*Log[b*x]^p]*Log[b*x]^(p-1),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>0


Int[Cosh[a_.*x_^n_*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  Sinh[a*x^n*Log[b*x]^p]/(a*n*x^(n-1)) -
  Dist[p/n,Int[Cosh[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] +
  Dist[(n-1)/(a*n),Int[Sinh[a*x^n*Log[b*x]^p]/x^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{n,p}] && p>0


Int[x_^m_*Cosh[a_.*x_^n_.*Log[b_.*x_]^p_.]*Log[b_.*x_]^p_.,x_Symbol] :=
  x^(m-n+1)*Sinh[a*x^n*Log[b*x]^p]/(a*n) -
  Dist[p/n,Int[x^m*Cosh[a*x^n*Log[b*x]^p]*Log[b*x]^(p-1),x]] -
  Dist[(m-n+1)/(a*n),Int[x^(m-n)*Sinh[a*x^n*Log[b*x]^p],x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>0


(* ::Subsubsection::Closed:: *)
(*u Cosh[v]^2				Products involving squares of cosines*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z]^2 == 1/2 + 1/2*Cosh[2*z]*)


Int[u_*Cosh[v_]^2,x_Symbol] :=
  Dist[1/2,Int[u,x]] + 
  Dist[1/2,Int[u*Cosh[2*v],x]] /;
FunctionOfHyperbolicQ[u,2*v,x]


(* ::Subsubsection::Closed:: *)
(*u Cosh[v] Hyper[w]			Products of hyperbolic trig functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[v]*Cosh[w] == Sinh[w+v]/2 - Sinh[w-v]/2*)


Int[u_.*Sinh[v_]*Cosh[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Sinh[w+v],x],x]] - 
  Dist[1/2,Int[u*Regularize[Sinh[w-v],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && PosQ[w-v]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[v]*Cosh[w] == Cosh[v+w]/2 + Cosh[v-w]/2*)


Int[u_.*Cosh[v_]*Cosh[w_],x_Symbol] :=
  Dist[1/2,Int[u*Regularize[Cosh[v+w],x],x]] + 
  Dist[1/2,Int[u*Regularize[Cosh[v-w],x],x]] /;
(PolynomialQ[v,x] && PolynomialQ[w,x] || IndependentQ[Cancel[v/w],x]) && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[v]*Tanh[w] == Sinh[v] - Sinh[v-w]*Sech[w]*)


Int[u_.*Cosh[v_]*Tanh[w_]^n_.,x_Symbol] :=
  Int[u*Sinh[v]*Tanh[w]^(n-1),x] - Sinh[v-w]*Int[u*Sech[w]*Tanh[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[v]*Coth[w] == Sinh[v] + Cosh[v-w]*Csch[w]*)


Int[u_.*Cosh[v_]*Coth[w_]^n_.,x_Symbol] :=
  Int[u*Sinh[v]*Coth[w]^(n-1),x] + Cosh[v-w]*Int[u*Csch[w]*Coth[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[v]*Sech[w] == Sinh[v-w]*Tanh[w] + Cosh[v-w]*)


Int[u_.*Cosh[v_]*Sech[w_]^n_.,x_Symbol] :=
  Sinh[v-w]*Int[u*Tanh[w]*Sech[w]^(n-1),x] + Cosh[v-w]*Int[u*Sech[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[v]*Csch[w] == Cosh[v-w]*Coth[w] + Sinh[v-w]*)


Int[u_.*Cosh[v_]*Csch[w_]^n_.,x_Symbol] :=
  Cosh[v-w]*Int[u*Coth[w]*Csch[w]^(n-1),x] + Sinh[v-w]*Int[u*Csch[w]^(n-1),x] /;
RationalQ[n] && n>0 && FreeQ[v-w,x] && NonzeroQ[v-w]


(* ::Subsection::Closed:: *)
(*Hyperbolic Tangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(c Tanh[a+b x])^n			Powers of tangents of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.243.17, CRC 556, A&S 4.5.79*)


(* ::Item:: *)
(*Derivation: Reciprocal rule*)


(* ::Item:: *)
(*Basis: Tanh[z] == Sinh[z]/Cosh[z]*)


Int[Tanh[a_.+b_.*x_],x_Symbol] :=
  Log[Cosh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.22, CRC 569*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Tanh[z]^2 == 1-Sech[z]^2*)


Int[Tanh[a_.+b_.*x_]^2,x_Symbol] :=
  x - Tanh[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.3, CRC 570, A&S 4.5.87*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


(* ::Item:: *)
(*Basis: Tanh[z]^n == Tanh[z]^(n-1)/Cosh[z]*Sinh[z]*)


Int[(c_.*Tanh[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*(c*Tanh[a+b*x])^(n-1)/(b*(n-1)) + 
  Dist[c^2,Int[(c*Tanh[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.4, CRC 574'*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Tanh[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Tanh[a+b*x])^(n+1)/(b*c*(n+1)) + 
  Dist[1/c^2,Int[(c*Tanh[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*(a+b Tanh[c+d x])^n			Powers of binomials of tangents where a^2-b^2 is zero*)


Int[Sqrt[a_+b_.*Tanh[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcTanh[Sqrt[a+b*Tanh[c+d*x]]/(Sqrt[2]*Rt[a,2])])/(d*Rt[a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2] && PosQ[a]


Int[Sqrt[a_+b_.*Tanh[c_.+d_.*x_]],x_Symbol] :=
  -(Sqrt[2]*b*ArcTan[Sqrt[a+b*Tanh[c+d*x]]/(Sqrt[2]*Rt[-a,2])])/(d*Rt[-a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2] && NegQ[a]


Int[(a_+b_.*Tanh[c_.+d_.*x_])^n_,x_Symbol] :=
  -a^2*(a+b*Tanh[c+d*x])^(n-1)/(b*d*(n-1)) + 
  Dist[2*a,Int[(a+b*Tanh[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2-b^2]


Int[1/(a_+b_.*Tanh[c_.+d_.*x_]),x_Symbol] :=
  x/(2*a) - a/(2*b*d*(a+b*Tanh[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


Int[(a_+b_.*Tanh[c_.+d_.*x_])^n_,x_Symbol] :=
  a*(a+b*Tanh[c+d*x])^n/(2*b*d*n) + 
  Dist[1/(2*a),Int[(a+b*Tanh[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<0 && ZeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*1 / (a+b Tanh[c+d x]^2)		Reciprocals of binomials of tangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*Tanh[z]) == Cosh[z]/(a*Cosh[z]+b*Sinh[z])*)


Int[1/(a_+b_.*Tanh[c_.+d_.*x_]),x_Symbol] :=
  a*x/(a^2-b^2) - b*Log[a*Cosh[c+d*x]+b*Sinh[c+d*x]]/(d*(a^2-b^2)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


Int[1/(a_+b_.*Tanh[c_.+d_.*x_]^2),x_Symbol] :=
  x/(a+b) + Sqrt[b]*ArcTan[(Sqrt[b]*Tanh[c+d*x])/Sqrt[a]]/(Sqrt[a]*d*(a+b)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b]


(* ::Subsubsection::Closed:: *)
(*x^m Tanh[a+b x^n]^p			Products of monomials and powers of tangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Tanh[z] == 1 - 2/(1+E^(2*z))*)


Int[x_^m_.*Tanh[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)/(m+1) - 
  Dist[2,Int[x^m/(1+E^(2*a+2*b*x^n)),x]] /;
FreeQ[{a,b,m,n},x] && NonzeroQ[m-n+1] && IntegerQ[m] && m>0


(* Note: Rule not in literature ??? *)
Int[x_^m_.*Tanh[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  -x^(m-n+1)*Tanh[a+b*x^n]^(p-1)/(b*n*(p-1)) + 
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Tanh[a+b*x^n]^(p-1),x]] + 
  Int[x^m*Tanh[a+b*x^n]^(p-2),x] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>1 && NonzeroQ[m-n+1] && 01 *)


(* ::Subsection::Closed:: *)
(*Hyperbolic Cotangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(c Coth[a+b x])^n			Powers of cotangents of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.33, CRC 557, A&S 4.5.82*)


(* ::Item:: *)
(*Derivation: Reciprocal rule*)


(* ::Item:: *)
(*Basis: Coth[z] == Cosh[z]/Sinh[z]*)


Int[Coth[a_.+b_.*x_],x_Symbol] :=
  Log[Sinh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.38, CRC 573*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Coth[z]^2 == 1+Csch[z]^2*)


Int[Coth[a_.+b_.*x_]^2,x_Symbol] :=
  x - Coth[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.4, CRC 574, A&S 4.5.88*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


(* ::Item:: *)
(*Basis: Coth[z]^n == Coth[z]^(n-1)/Sinh[z]*Cosh[z]*)


Int[(c_.*Coth[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*(c*Coth[a+b*x])^(n-1)/(b*(n-1)) + 
  Dist[c^2,Int[(c*Coth[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.3, CRC 570'*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Coth[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Coth[a+b*x])^(n+1)/(b*c*(n+1)) + 
  Dist[1/c^2,Int[(c*Coth[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*(a+b Coth[c+d x])^n			Powers of binomials of cotangents where a^2-b^2 is zero*)


Int[Sqrt[a_+b_.*Coth[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcCoth[Sqrt[a+b*Coth[c+d*x]]/(Sqrt[2]*Rt[a,2])])/(d*Rt[a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2] && PosQ[a]


Int[Sqrt[a_+b_.*Coth[c_.+d_.*x_]],x_Symbol] :=
  (Sqrt[2]*b*ArcCot[Sqrt[a+b*Coth[c+d*x]]/(Sqrt[2]*Rt[-a,2])])/(d*Rt[-a,2]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2] && NegQ[a]


Int[(a_+b_.*Coth[c_.+d_.*x_])^n_,x_Symbol] :=
  -a^2*(a+b*Coth[c+d*x])^(n-1)/(b*d*(n-1)) + 
  Dist[2*a,Int[(a+b*Coth[c+d*x])^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && ZeroQ[a^2-b^2]


Int[1/(a_+b_.*Coth[c_.+d_.*x_]),x_Symbol] :=
  x/(2*a) - a/(2*b*d*(a+b*Coth[c+d*x])) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


Int[(a_+b_.*Coth[c_.+d_.*x_])^n_,x_Symbol] :=
  a*(a+b*Coth[c+d*x])^n/(2*b*d*n) + 
  Dist[1/(2*a),Int[(a+b*Coth[c+d*x])^(n+1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<0 && ZeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*1 / (a+b Coth[c+d x]^n)		Reciprocals of binomials of cotangents*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*Coth[z]) == Sinh[z]/(a*Sinh[z]+b*Cosh[z])*)


Int[1/(a_+b_.*Coth[c_.+d_.*x_]),x_Symbol] :=
  a*x/(a^2-b^2) - b*Log[b*Cosh[c+d*x]+a*Sinh[c+d*x]]/(d*(a^2-b^2)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


Int[1/(a_+b_.*Coth[c_.+d_.*x_]^2),x_Symbol] :=
  x/(a+b) + Sqrt[b]*ArcTan[(Sqrt[b]*Coth[c+d*x])/Sqrt[a]]/(Sqrt[a]*d*(a+b)) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a+b]


(* ::Subsubsection::Closed:: *)
(*x^m Coth[a+b x^n]^p			Products of monomials and powers of cotangents of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Coth[z] == 1 - 2/(1-E^(2*z))*)


Int[x_^m_.*Coth[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)/(m+1) - 
  Dist[2,Int[x^m/(1-E^(2*a+2*b*x^n)),x]] /;
FreeQ[{a,b,m,n},x] && NonzeroQ[m-n+1] && IntegerQ[m] && m>0


(* Note: Rule not in literature ??? *)
Int[x_^m_.*Coth[a_.+b_.*x_^n_.]^p_,x_Symbol] :=
  -x^(m-n+1)*Coth[a+b*x^n]^(p-1)/(b*n*(p-1)) + 
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Coth[a+b*x^n]^(p-1),x]] + 
  Int[x^m*Coth[a+b*x^n]^(p-2),x] /;
FreeQ[{a,b},x] && RationalQ[{m,n,p}] && p>1 && NonzeroQ[m-n+1] && 01 *)


(* ::Subsection::Closed:: *)
(*Hyperbolic Secant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Sech[a+b x]^n				Powers of secants of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.9, CRC 558, A&S 4.5.81*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Sech[z] == 1/(1+Sinh[z]^2)*Sinh'[z]*)


Int[Sech[a_.+b_.*x_],x_Symbol] :=
(* -ArcCot[Sinh[a+b*x]]/b *)
  ArcTan[Sinh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* Note: This entirely redundant is required due to idem potent problem in Mathematica 6 & 7. *)
Int[1/Sqrt[Sech[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Cosh[a+b*x]]*Sqrt[Sech[a+b*x]]*Int[Sqrt[Cosh[a+b*x]],x] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Sech[x])^n*Cosh[x]^n,x] == 0*)


Int[(c_.*Sech[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Sech[a+b*x])^n*Cosh[a+b*x]^n*Int[1/Cosh[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.6, CRC 568b*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Sech[a_.+b_.*x_])^n_,x_Symbol] :=
  c*Sinh[a+b*x]*(c*Sech[a+b*x])^(n-1)/(b*(n-1)) + 
  Dist[(n-2)*c^2/(n-1),Int[(c*Sech[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[EvenQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.1, CRC 567a*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Sech[a_.+b_.*x_])^n_,x_Symbol] :=
  -Sinh[a+b*x]*(c*Sech[a+b*x])^(n+1)/(b*c*n) + 
  Dist[(n+1)/(c^2*n),Int[(c*Sech[a+b*x])^(n+2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m Sech[a+b x]^n			Products of monomials and powers of secants of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sech[a_.+b_.*x_],x_Symbol] :=
  2*x^m*ArcTan[E^(a+b*x)]/b -
  Dist[2*m/b,Int[x^(m-1)*ArcTan[E^(a+b*x)],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Reference: CRC 430h*)


Int[x_^m_.*Sech[a_.+b_.*x_]^2,x_Symbol] :=
  x^m*Tanh[a+b*x]/b -
  Dist[m/b,Int[x^(m-1)*Tanh[a+b*x],x]] /;
FreeQ[{a,b},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Reference: G&R 2.643.2h, CRC 431h*)


Int[x_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  x*Tanh[a+b*x]*Sech[a+b*x]^(n-2)/(b*(n-1)) +
  Sech[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x*Sech[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1 && n!=2


(* ::Item:: *)
(*Reference: G&R 2.643.2h*)


Int[x_^m_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  x^m*Tanh[a+b*x]*Sech[a+b*x]^(n-2)/(b*(n-1)) +
  m*x^(m-1)*Sech[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) +
  Dist[(n-2)/(n-1),Int[x^m*Sech[a+b*x]^(n-2),x]] -
  Dist[m*(m-1)/(b^2*(n-1)*(n-2)),Int[x^(m-2)*Sech[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n>1 && n!=2 && m>1


(* ::Item:: *)
(*Reference: G&R 2.631.3h*)


Int[x_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sech[a+b*x]^n/(b^2*n^2) -
  x*Sinh[a+b*x]*Sech[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x*Sech[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1


(* ::Item:: *)
(*Reference: G&R 2.631.3h*)


Int[x_^m_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  -m*x^(m-1)*Sech[a+b*x]^n/(b^2*n^2) -
  x^m*Sinh[a+b*x]*Sech[a+b*x]^(n+1)/(b*n) +
  Dist[(n+1)/n,Int[x^m*Sech[a+b*x]^(n+2),x]] +
  Dist[m*(m-1)/(b^2*n^2),Int[x^(m-2)*Sech[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n<-1 && m>1


(* ::Subsubsection::Closed:: *)
(*(a+b Sech[c+d x])^n			Powers of constant plus secants of linears where a^2-b^2 is zero*)


Int[Sqrt[a_+b_.*Sech[c_.+d_.*x_]],x_Symbol] :=
  2*a*ArcTan[Sqrt[-1+a/b*Sech[c+d*x]]]*Tanh[c+d*x]/
		(d*Sqrt[-1+a/b*Sech[c+d*x]]*Sqrt[a+b*Sech[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* Note: There should be a simpler antiderivative! *)
Int[1/Sqrt[a_+b_.*Sech[c_.+d_.*x_]],x_Symbol] :=
  -(Sqrt[2]*ArcTan[(Sqrt[2]*Sqrt[a])/Sqrt[-a+b*Sech[x]]]+2*ArcTan[Sqrt[-a+b*Sech[x]]/Sqrt[a]])*
  Sqrt[-a+b*Sech[x]]*Sqrt[a+b*Sech[x]]*Coth[x]/a^(3/2) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Sech[c+d x]^n)^m		Powers of constant plus powers of secants of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Sech[z]^n == (b+a*Cosh[z]^n)/Cosh[z]^n*)


Int[(a_+b_.*Sech[v_]^n_.)^m_,x_Symbol] :=
  Int[(b+a*Cosh[v]^n)^m/Cosh[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<0 && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Sech[z]^n == (b+a*Cosh[z]^n)/Cosh[z]^n*)


Int[Cosh[v_]^p_.*(a_+b_.*Sech[v_]^n_.)^m_,x_Symbol] :=
  Int[Cosh[v]^(p-m*n)*(b+a*Cosh[v]^n)^m,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n,p}] && m<0 && n>0


(* ::Subsubsection::Closed:: *)
(*Sech[a+b x]^n Csch[a+b x]^m		Products of powers of secants and cosecants*)


(* ::Item:: *)
(*Reference: G&R 2.423.49*)


Int[Csch[a_.+b_.*x_]*Sech[a_.+b_.*x_],x_Symbol] :=
  Log[Tanh[a+b*x]]/b /;
FreeQ[{a,b},x] && PosQ[b]


Int[Csch[a_.+b_.*x_]^m_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  Csch[a+b*x]^(m-1)*Sech[a+b*x]^(n-1)/(b*(n-1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-2] && NonzeroQ[n-1] && PosQ[n]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m and n are integers and m + n is even, Csch[z]^m*Sech[z]^n == (1-Tanh[z]^2)^((m+n)/2-1)/Tanh[z]^m*Tanh'[z]*)


Int[Csch[a_.+b_.*x_]^m_.*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[(1-x^2)^((m+n)/2-1)/x^m,x],x],x,Tanh[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && EvenQ[m+n] && 01


(* ::Item:: *)
(*Reference: G&R 2.411.6, CRC 568b, A&S 4.5.86b*)


Int[Csch[a_.+b_.*x_]^m_.*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  Csch[a+b*x]^(m-1)*Sech[a+b*x]^(n-1)/(b*(n-1)) +
  Dist[(m+n-2)/(n-1),Int[Csch[a+b*x]^m*Sech[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && Not[EvenQ[m+n]] && Not[EvenQ[n] && OddQ[m] && m>1]


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a, A&S 4.5.85a*)


Int[Csch[a_.+b_.*x_]^m_.*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^(m-1)*Sech[a+b*x]^(n+1)/(b*(m+n)) +
  Dist[(n+1)/(m+n),Int[Csch[a+b*x]^m*Sech[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && NonzeroQ[m+n]


(* ::Subsubsection::Closed:: *)
(*Sech[a+b x]^m Tanh[a+b x]^n	Products of powers of secants and tangents*)
(**)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[Sech[a_.+b_.*x_]^m_.*Tanh[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Sech[a+b*x]^m/(b*m) /;
FreeQ[{a,b,m},x] && n===1


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is even, Sech[z]^m == (1-Tanh[z]^2)^((m-2)/2)*Tanh'[z]*)


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[x^n*(1-x^2)^((m-2)/2),x],x],x,Tanh[a+b*x]]] /;
FreeQ[{a,b,n},x] && EvenQ[m] && m>2 && Not[OddQ[n] && 01 && n<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sech[a+b*x]^m*Tanh[a+b*x]^(n-1)/(b*m) +
  Dist[(n-1)/m,Int[Sech[a+b*x]^(m+2)*Tanh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a*)


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sech[a+b*x]^m*Tanh[a+b*x]^(n+1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+1]


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sech[a+b*x]^m*Tanh[a+b*x]^(n+1)/(b*m) +
  Dist[(m+n+1)/m,Int[Sech[a+b*x]^(m+2)*Tanh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.6, CRC 568b*)


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sech[a+b*x]^(m-2)*Tanh[a+b*x]^(n+1)/(b*(m+n-1)) +
  Dist[(m-2)/(m+n-1),Int[Sech[a+b*x]^(m-2)*Tanh[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.3*)


Int[Sech[a_.+b_.*x_]^m_.*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  -Sech[a+b*x]^m*Tanh[a+b*x]^(n-1)/(b*(m+n-1)) +
  Dist[(n-1)/(m+n-1),Int[Sech[a+b*x]^m*Tanh[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.4*)


Int[Sech[a_.+b_.*x_]^m_*Tanh[a_.+b_.*x_]^n_,x_Symbol] :=
  Sech[a+b*x]^m*Tanh[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[(m+n+1)/(n+1),Int[Sech[a+b*x]^m*Tanh[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && Not[EvenQ[m]]


(* ::Subsubsection::Closed:: *)
(*x^m Sech[a+b x^n]^p Sinh[a+b x^n]  Products of monomials, sines and powers of secants of binomials*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sech[a_.+b_.*x_^n_.]^p_*Sinh[a_.+b_.*x_^n_.],x_Symbol] :=
  -x^(m-n+1)*Sech[a+b*x^n]^(p-1)/(b*n*(p-1)) +
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Sech[a+b*x^n]^(p-1),x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && NonzeroQ[p-1]


(* ::Subsubsection::Closed:: *)
(*x^m Sech[a+b x^n]^p Tanh[a+b x^n]  Products of monomials, tangents and powers of secants of binomials*)
(**)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sech[a_.+b_.*x_^n_.]^p_.*Tanh[a_.+b_.*x_^n_.]^q_.,x_Symbol] :=
  -x^(m-n+1)*Sech[a+b*x^n]^p/(b*n*p) +
  Dist[(m-n+1)/(b*n*p),Int[x^(m-n)*Sech[a+b*x^n]^p,x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && q===1 (* Required so InputForm is matchable *)


(* ::Subsubsection::Closed:: *)
(*Sech[a+b Log[c x^n]]^p		Powers of secants of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sech[b*Log[c*x^n]] == 2 / ((c*x^n)^b + 1/(c*x^n)^b)*)


Int[Sech[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[(2/((c*x^n)^b+1/(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,n,p}]


Int[Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Tanh[a+b*Log[c*x^n]]*Sech[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) +
  x*Sech[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) -
  Dist[(1-b^2*n^2*(p-2)^2)/(b^2*n^2*(p-1)*(p-2)),Int[Sech[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && p!=2


Int[Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Sech[a+b*Log[c*x^n]]^p/(1-b^2*n^2*p^2) +
  b*n*p*x*Sech[a+b*Log[c*x^n]]^(p+1)*Sinh[a+b*Log[c*x^n]]/(1-b^2*n^2*p^2) -
  Dist[b^2*n^2*p*(p+1)/(1-b^2*n^2*p^2),Int[Sech[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && NonzeroQ[1-b^2*n^2*p^2]


(* ::Subsubsection::Closed:: *)
(*x^m Sech[a+b Log[c x^n]]^p		Products of monomials and powers of secants of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sech[b*Log[c*x^n]] == 2 / ((c*x^n)^b + 1/(c*x^n)^b)*)


Int[x_^m_.Sech[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[x^m*(2/((c*x^n)^b+1/(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,m,n,p}]


Int[Sech[a_.+b_.*Log[c_.*x_^n_.]]^2/x_,x_Symbol] :=
  Tanh[a+b*Log[c*x^n]]/(b*n) /;
FreeQ[{a,b,c,n},x]


Int[Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  Tanh[a+b*Log[c*x^n]]*Sech[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) +
  Dist[(p-2)/(p-1),Int[Sech[a+b*Log[c*x^n]]^(p-2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1


Int[Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  -Sech[a+b*Log[c*x^n]]^(p+1)*Sinh[a+b*Log[c*x^n]]/(b*n*p) +
  Dist[(p+1)/p,Int[Sech[a+b*Log[c*x^n]]^(p+2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1


Int[x_^m_.*Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x^(m+1)*Tanh[a+b*Log[c*x^n]]*Sech[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) +
  (m+1)*x^(m+1)*Sech[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) -
  Dist[(b^2*n^2*(p-2)^2-(m+1)^2)/(b^2*n^2*(p-1)*(p-2)),Int[x^m*Sech[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && p!=2


Int[x_^m_.*Sech[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -(m+1)*x^(m+1)*Sech[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2-(m+1)^2) -
  b*n*p*x^(m+1)*Sech[a+b*Log[c*x^n]]^(p+1)*Sinh[a+b*Log[c*x^n]]/(b^2*n^2*p^2-(m+1)^2) +
  Dist[b^2*n^2*p*(p+1)/(b^2*n^2*p^2-(m+1)^2),Int[x^m*Sech[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && NonzeroQ[b^2*n^2*p^2-(m+1)^2]


(* ::Subsection::Closed:: *)
(*Hyperbolic Cosecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Csch[a+b x]^n				Powers of cosecants of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.423.1', CRC 559', A&S 4.5.80'*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Csch[z] == -1/(1-Cosh[z]^2)*Cosh'[z]*)


Int[Csch[a_.+b_.*x_],x_Symbol] :=
(* -ArcTanh[Cosh[a+b*x]]/b *)
  -ArcCoth[Cosh[a+b*x]]/b /;
FreeQ[{a,b},x]


(* Note: This entirely redundant is required due to idem potent problem in Mathematica 6 & 7. *)
Int[1/Sqrt[Csch[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[Csch[a+b*x]]*Sqrt[Sinh[a+b*x]]*Int[Sqrt[Sinh[a+b*x]],x] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Extract constant factor*)


(* ::Item:: *)
(*Basis: D[(c*Csch[x])^n*Sinh[x]^n,x] == 0*)


Int[(c_.*Csch[a_.+b_.*x_])^n_,x_Symbol] :=
  (c*Csch[a+b*x])^n*Sinh[a+b*x]^n*Int[1/Sinh[a+b*x]^n,x] /;
FreeQ[{a,b,c},x] && RationalQ[n] && -11


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.5, CRC 568a*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts with a double-back flip*)


Int[(c_.*Csch[a_.+b_.*x_])^n_,x_Symbol] :=
  -c*Cosh[a+b*x]*(c*Csch[a+b*x])^(n-1)/(b*(n-1)) - 
  Dist[(n-2)*c^2/(n-1),Int[(c*Csch[a+b*x])^(n-2),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n>1 && Not[EvenQ[n]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(c_.*Csch[a_.+b_.*x_])^n_,x_Symbol] :=
  -Cosh[a+b*x]*(c*Csch[a+b*x])^(n+1)/(b*c*n) - 
  Dist[(n+1)/(c^2*n),Int[(c*Csch[a+b*x])^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m Csch[a+b x]^n			Products of monomials and powers of cosecants of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csch[a_.+b_.*x_],x_Symbol] :=
  -2*x^m*ArcTanh[E^(a+b x)]/b +
  Dist[2*m/b,Int[x^(m-1)*ArcTanh[E^(a+b x)],x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Reference: CRC 428h*)


Int[x_^m_.*Csch[a_.+b_.*x_]^2,x_Symbol] :=
  -x^m*Coth[a+b*x]/b +
  Dist[m/b,Int[x^(m-1)*Coth[a+b*x],x]] /;
FreeQ[{a,b},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Reference: G&R 2.643.1h, CRC 429h*)


Int[x_*Csch[a_.+b_.*x_]^n_,x_Symbol] :=
  -x*Coth[a+b*x]*Csch[a+b*x]^(n-2)/(b*(n-1)) -
  Csch[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) -
  Dist[(n-2)/(n-1),Int[x*Csch[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1 && n!=2


(* ::Item:: *)
(*Reference: G&R 2.643.1h*)


Int[x_^m_*Csch[a_.+b_.*x_]^n_,x_Symbol] :=
  -x^m*Coth[a+b*x]*Csch[a+b*x]^(n-2)/(b*(n-1)) -
  m*x^(m-1)*Csch[a+b*x]^(n-2)/(b^2*(n-1)*(n-2)) -
  Dist[(n-2)/(n-1),Int[x^m*Csch[a+b*x]^(n-2),x]] +
  Dist[m*(m-1)/(b^2*(n-1)*(n-2)),Int[x^(m-2)*Csch[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n>1 && n!=2 && m>1


(* ::Item:: *)
(*Reference: G&R 2.631.2h*)


Int[x_*Csch[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^n/(b^2*n^2) -
  x*Cosh[a+b*x]*Csch[a+b*x]^(n+1)/(b*n) -
  Dist[(n+1)/n,Int[x*Csch[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1


(* ::Item:: *)
(*Reference: G&R 2.631.2h*)


Int[x_^m_*Csch[a_.+b_.*x_]^n_,x_Symbol] :=
  -m*x^(m-1)*Csch[a+b*x]^n/(b^2*n^2) -
  x^m*Cosh[a+b*x]*Csch[a+b*x]^(n+1)/(b*n) -
  Dist[(n+1)/n,Int[x^m*Csch[a+b*x]^(n+2),x]] +
  Dist[m*(m-1)/(b^2*n^2),Int[x^(m-2)*Csch[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && n<-1 && m>1


(* ::Subsubsection::Closed:: *)
(*(a+b Csch[c+d x])^n			Powers of constant plus cosecants of linears where a^2+b^2 is zero*)


Int[Sqrt[a_+b_.*Csch[c_.+d_.*x_]],x_Symbol] :=
  2*a*ArcTan[Sqrt[-1-a/b*Csch[c+d*x]]]*Coth[c+d*x]/
		(d*Sqrt[-1-a/b*Csch[c+d*x]]*Sqrt[a+b*Csch[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


(* Note: There should be a simpler antiderivative! *)
Int[1/Sqrt[a_+b_.*Csch[c_.+d_.*x_]],x_Symbol] :=
  -(Sqrt[2]*ArcTan[(Sqrt[2]*Sqrt[a])/Sqrt[-a+b*Csch[x]]]+2*ArcTan[Sqrt[-a+b*Csch[x]]/Sqrt[a]])*
		Sqrt[-a+b*Csch[x]]*Sqrt[a+b*Csch[x]]*Tanh[x]/a^(3/2) /;
FreeQ[{a,b,c,d},x] && ZeroQ[a^2+b^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Csch[c+d x]^n)^m		Powers of constant plus powers of cosecants of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Csch[z]^n == (b+a*Sinh[z]^n)/Sinh[z]^n*)


Int[(a_+b_.*Csch[v_]^n_.)^m_,x_Symbol] :=
  Int[(b+a*Sinh[v]^n)^m/Sinh[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m<0 && n>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If n is an integer, a+b*Csch[z]^n == (b+a*Sinh[z]^n)/Sinh[z]^n*)


Int[Sinh[v_]^p_.*(a_+b_.*Csch[v_]^n_.)^m_,x_Symbol] :=
  Int[Sinh[v]^(p-m*n)*(b+a*Sinh[v]^n)^m,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n,p}] && m<0 && n>0


(* ::Subsubsection::Closed:: *)
(*Csch[a+b x]^m Sech[a+b x]^n		Products of powers of cosecants and secants*)


(* ::Item:: *)
(*Reference: G&R 2.423.49'*)


Int[Csch[a_.+b_.*x_]*Sech[a_.+b_.*x_],x_Symbol] :=
  -Log[Coth[a+b*x]]/b /;
FreeQ[{a,b},x] && NegQ[b]


Int[Csch[a_.+b_.*x_]^m_*Sech[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^(m-1)*Sech[a+b*x]^(n-1)/(b*(m-1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n-2] && NonzeroQ[m-1] && PosQ[m]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m and n are integers and m+n is even, Csch[z]^m*Sech[z]^n == -(-1+Coth[z]^2)^((m+n)/2-1)/Coth[z]^n*Coth'[z]*)


Int[Csch[a_.+b_.*x_]^m_*Sech[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[(-1+x^2)^((m+n)/2-1)/x^n,x],x],x,Coth[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && EvenQ[m+n] && 01 && n<-1


(* ::Item:: *)
(*Reference: G&R 2.411.5, CRC 568a, A&S 4.5.86a*)


Int[Csch[a_.+b_.*x_]^m_*Sech[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Csch[a+b*x]^(m-1)*Sech[a+b*x]^(n-1)/(b*(m-1)) -
  Dist[(m+n-2)/(m-1),Int[Csch[a+b*x]^(m-2)*Sech[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && Not[EvenQ[m+n]] && Not[EvenQ[m] && OddQ[n] && n>1]


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b, A&S 4.5.85b*)


Int[Csch[a_.+b_.*x_]^m_*Sech[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Csch[a+b*x]^(m+1)*Sech[a+b*x]^(n-1)/(b*(m+n)) -
  Dist[(m+1)/(m+n),Int[Csch[a+b*x]^(m+2)*Sech[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n]


(* ::Subsubsection::Closed:: *)
(*Csch[a+b x]^m Coth[a+b x]^n		Products of powers of cosecants and cotangents*)
(**)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[Csch[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  -Csch[a+b*x]^m/(b*m) /;
FreeQ[{a,b,m},x] && n===1


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If m is even, Csch[z]^m == -(-1+Coth[z]^2)^((m-2)/2)*Coth'[z]*)


Int[Csch[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_.,x_Symbol] :=
  Dist[-1/b,Subst[Int[Regularize[x^n*(-1+x^2)^((m-2)/2),x],x],x,Coth[a+b*x]]] /;
FreeQ[{a,b,n},x] && EvenQ[m] && m>2 && Not[OddQ[n] && 01 && n<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.1, CRC 567a*)


Int[Csch[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^m*Coth[a+b*x]^(n-1)/(b*m) -
  Dist[(n-1)/m,Int[Csch[a+b*x]^(m+2)*Coth[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[{m,n}] && m<-1 && n>1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.2, CRC 567b*)


Int[Csch[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^m*Coth[a+b*x]^(n+1)/(b*m) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+1]


Int[Csch[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^m*Coth[a+b*x]^(n+1)/(b*m) -
  Dist[(m+n+1)/m,Int[Csch[a+b*x]^(m+2)*Coth[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1 && Not[EvenQ[m]]


(* ::Item:: *)
(*Reference: G&R 2.411.5, CRC 568a*)


Int[Csch[a_.+b_.*x_]^m_*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^(m-2)*Coth[a+b*x]^(n+1)/(b*(m+n-1)) -
  Dist[(m-2)/(m+n-1),Int[Csch[a+b*x]^(m-2)*Coth[a+b*x]^n,x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.4*)


Int[Csch[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  -Csch[a+b*x]^m*Coth[a+b*x]^(n-1)/(b*(m+n-1)) +
  Dist[(n-1)/(m+n-1),Int[Csch[a+b*x]^m*Coth[a+b*x]^(n-2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n>1 && NonzeroQ[m+n-1] && Not[EvenQ[m]] && Not[OddQ[n]]


(* ::Item:: *)
(*Reference: G&R 2.411.3*)


Int[Csch[a_.+b_.*x_]^m_.*Coth[a_.+b_.*x_]^n_,x_Symbol] :=
  Csch[a+b*x]^m*Coth[a+b*x]^(n+1)/(b*(n+1)) +
  Dist[(m+n+1)/(n+1),Int[Csch[a+b*x]^m*Coth[a+b*x]^(n+2),x]] /;
FreeQ[{a,b,m},x] && RationalQ[n] && n<-1 && Not[EvenQ[m]]


(* ::Subsubsection::Closed:: *)
(*x^m Csch[a+b x^n]^p Cosh[a+b x^n]	Products of monomials, cosines and powers of cosecants of binomials*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csch[a_.+b_.*x_^n_.]^p_*Cosh[a_.+b_.*x_^n_.],x_Symbol] :=
  -x^(m-n+1)*Csch[a+b*x^n]^(p-1)/(b*n*(p-1)) +
  Dist[(m-n+1)/(b*n*(p-1)),Int[x^(m-n)*Csch[a+b*x^n]^(p-1),x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && NonzeroQ[p-1]


(* ::Subsubsection::Closed:: *)
(*x^m Csch[a+b x^n]^p Coth[a+b x^n]	Products of monomials, cotangents and powers of cosecants of binomials*)
(**)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Csch[a_.+b_.*x_^n_.]^p_.*Coth[a_.+b_.*x_^n_.]^q_.,x_Symbol] :=
  -x^(m-n+1)*Csch[a+b*x^n]^p/(b*n*p) +
  Dist[(m-n+1)/(b*n*p),Int[x^(m-n)*Csch[a+b*x^n]^p,x]] /;
FreeQ[{a,b,p},x] && RationalQ[m] && IntegerQ[n] && m-n>=0 && q===1 (* Required so InputForm is matchable *)


(* ::Subsubsection::Closed:: *)
(*Csch[a+b Log[c x^n]]^p		Powers of cosecants of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Csch[b*Log[c*x^n]] == 2 / ((c*x^n)^b - 1/(c*x^n)^b)*)


Int[Csch[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[(2/((c*x^n)^b - 1/(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,n,p}]


Int[Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x*Coth[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  x*Csch[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) +
  Dist[(1-b^2*n^2*(p-2)^2)/(b^2*n^2*(p-1)*(p-2)),Int[Csch[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1 && p!=2


Int[Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  x*Csch[a+b*Log[c*x^n]]^p/(1-b^2*n^2*p^2) +
  b*n*p*x*Cosh[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p+1)/(1-b^2*n^2*p^2) +
  Dist[b^2*n^2*p*(p+1)/(1-b^2*n^2*p^2),Int[Csch[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1 && NonzeroQ[1-b^2*n^2*p^2]


(* ::Subsubsection::Closed:: *)
(*x^m Csch[a+b Log[c x^n]]^p		Products of monomials and powers of cosecants of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Csch[b*Log[c*x^n]] == 2 / ((c*x^n)^b - 1/(c*x^n)^b)*)


Int[x_^m_.*Csch[b_.*Log[c_.*x_^n_.]]^p_.,x_Symbol] :=
  Int[x^m*(2/((c*x^n)^b - 1/(c*x^n)^b))^p,x] /;
FreeQ[c,x] && RationalQ[{b,m,n,p}]


Int[Csch[a_.+b_.*Log[c_.*x_^n_.]]^2/x_,x_Symbol] :=
  -Coth[a+b*Log[c*x^n]]/(b*n) /;
FreeQ[{a,b,c,n},x]


Int[Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  -Coth[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  Dist[(p-2)/(p-1),Int[Csch[a+b*Log[c*x^n]]^(p-2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>1


Int[Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_/x_,x_Symbol] :=
  -Cosh[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p+1)/(b*n*p) -
  Dist[(p+1)/p,Int[Csch[a+b*Log[c*x^n]]^(p+2)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1


Int[x_^m_.*Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -x^(m+1)*Coth[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p-2)/(b*n*(p-1)) -
  (m+1)*x^(m+1)*Csch[a+b*Log[c*x^n]]^(p-2)/(b^2*n^2*(p-1)*(p-2)) -
  Dist[(b^2*n^2*(p-2)^2-(m+1)^2)/(b^2*n^2*(p-1)*(p-2)),Int[x^m*Csch[a+b*Log[c*x^n]]^(p-2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>1 && p!=2


Int[x_^m_.*Csch[a_.+b_.*Log[c_.*x_^n_.]]^p_,x_Symbol] :=
  -(m+1)*x^(m+1)*Csch[a+b*Log[c*x^n]]^p/(b^2*n^2*p^2-(m+1)^2) -
  b*n*p*x^(m+1)*Cosh[a+b*Log[c*x^n]]*Csch[a+b*Log[c*x^n]]^(p+1)/(b^2*n^2*p^2-(m+1)^2) -
  Dist[b^2*n^2*p*(p+1)/(b^2*n^2*p^2-(m+1)^2),Int[x^m*Csch[a+b*Log[c*x^n]]^(p+2),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && NonzeroQ[b^2*n^2*p^2-(m+1)^2]


(* ::Subsection::Closed:: *)
(*Powers of sums of Hyperbolic Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*(a Cosh[c+d x] + b Sinh[c+d x])^n	Powers of sums of sines and cosines*)


Int[(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  a*(a*Cosh[c+d*x]+b*Sinh[c+d*x])^n/(b*d*n) /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a^2-b^2]


Int[1/(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^2,x_Symbol] :=
  Sinh[c+d*x]/(a*d*(a*Cosh[c+d*x]+b*Sinh[c+d*x])) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Basis: a*Cosh[z]+b*Sinh[z] == -I*Sqrt[a^2-b^2]*Sinh[z+I*ArcTan[I*b,a]]*)


Int[Sqrt[a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*I*EllipticE[(Pi/2-I*(c+d*x+I*ArcTan[I*b,a]))/2,2]*
  Sqrt[a*Cosh[c+d*x]+b*Sinh[c+d*x]]/
  (d*Sqrt[-(a*Cosh[c+d*x]+b*Sinh[c+d*x])/Sqrt[a^2-b^2]]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Basis: a*Cosh[z]+b*Sinh[z] == -I*Sqrt[a^2-b^2]*Sinh[z+I*ArcTan[I*b,a]]*)


Int[1/Sqrt[a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_]],x_Symbol] :=
  2*I*EllipticF[(Pi/2-I*(c+d*x+I*ArcTan[I*b,a]))/2,2]*
  Sqrt[-(a*Cosh[c+d*x]+b*Sinh[c+d*x])/Sqrt[a^2-b^2]]/
  (d*Sqrt[a*Cosh[c+d*x]+b*Sinh[c+d*x]]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2]


(* ::Item::Closed:: *)
(*Reference: G&R 2.449'*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is odd, (a*Cosh[z]+b*Sinh[z])^n == (a^2-b^2+u^2)^((n-1)/2)*D[u,z] where u = b*Cosh[z]+a*Sinh[z]*)


(* Note: For odd n<-1, might as well stay in the trig world using 2nd rule below ??? *)
Int[(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  Dist[1/d,Subst[Int[Regularize[(a^2-b^2+x^2)^((n-1)/2),x],x],x,b*Cosh[c+d*x]+a*Sinh[c+d*x]]] /;
FreeQ[{a,b,c,d},x] && OddQ[n] && n>=-1 && NonzeroQ[a^2-b^2]


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  (b*Cosh[c+d*x]+a*Sinh[c+d*x])*(a*Cosh[c+d*x]+b*Sinh[c+d*x])^(n-1)/(d*n) +
  Dist[(n-1)*(a^2-b^2)/n,Int[(a*Cosh[c+d*x]+b*Sinh[c+d*x])^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n>1 && NonzeroQ[a^2-b^2] && Not[OddQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts with a double-back flip*)


Int[(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  -(b*Cosh[c+d*x]+a*Sinh[c+d*x])*(a*Cosh[c+d*x]+b*Sinh[c+d*x])^(n+1)/(d*(n+1)*(a^2-b^2)) +
  Dist[(n+2)/((n+1)*(a^2-b^2)),Int[(a*Cosh[c+d*x]+b*Sinh[c+d*x])^(n+2),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2]


(* ::Subsubsection::Closed:: *)
(*(a Csch[c+d x] + a Sinh[c+d x])^n	where a-b is zero*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Csch[z]+Sinh[z] == Cosh[z]*Coth[z]*)


Int[(a_.*Csch[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(a*Cosh[c+d*x]*Coth[c+d*x])^n,x] /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a-b]


(* ::Subsubsection::Closed:: *)
(*(a Sech[c+d x] + a Cosh[c+d x])^n	where a+b is zero*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sech[z]-Cosh[z] == -Sinh[z]*Tanh[z]*)


Int[(a_.*Sech[c_.+d_.*x_]+b_.*Cosh[c_.+d_.*x_])^n_,x_Symbol] :=
  Int[(-a*Sinh[c+d*x]*Tanh[c+d*x])^n,x] /;
FreeQ[{a,b,c,d,n},x] && ZeroQ[a+b]


(* ::Subsection::Closed:: *)
(*Rational functions of Hyperbolic Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*u Hyper[c+d x]^n / (a Cosh[c+d x]+b Sinh[c+d x])	where a^2-b^2 is nonzero*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z]^2/(a*Cosh[z]+b*Sinh[z]) == -b/(a^2-b^2)*Sinh[z] + a/(a^2-b^2)*Cosh[z] - a^2/(a^2-b^2)/(a*Cosh[z]+b*Sinh[z])*)


Int[u_.*Sinh[c_.+d_.*x_]^n_/(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_]),x_Symbol] :=
  Dist[-b/(a^2-b^2),Int[u*Sinh[c+d*x]^(n-1),x]] +
  Dist[a/(a^2-b^2),Int[u*Sinh[c+d*x]^(n-2)*Cosh[c+d*x],x]] -
  Dist[a^2/(a^2-b^2),Int[u*Sinh[c+d*x]^(n-2)/(a*Cosh[c+d*x]+b*Sinh[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && IntegerQ[n] && n>1


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z]^2/(a*Cosh[z]+b*Sinh[z]) == a/(a^2-b^2)*Cosh[z] - b/(a^2-b^2)*Sinh[z] - b^2/(a^2-b^2)/(a*Cosh[z]+b*Sinh[z])*)


Int[u_.*Cosh[c_.+d_.*x_]^n_/(a_.*Cosh[c_.+d_.*x_]+b_.*Sinh[c_.+d_.*x_]),x_Symbol] :=
  Dist[a/(a^2-b^2),Int[u*Cosh[c+d*x]^(n-1),x]] -
  Dist[b/(a^2-b^2),Int[u*Cosh[c+d*x]^(n-2)*Sinh[c+d*x],x]] -
  Dist[b^2/(a^2-b^2),Int[u*Cosh[c+d*x]^(n-2)/(a*Cosh[c+d*x]+b*Sinh[c+d*x]),x]] /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2] && IntegerQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*(a+b Cosh[d+e x]+c Sinh[d+e x])^n			where a^2-b^2+c^2 is zero*)


(* ::Item:: *)
(*Reference: G&R 2.451.4d*)


Int[1/(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  -2/(e*(c-(a-b)*Tanh[(d+e*x)/2])) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2+c^2]


Int[Sqrt[a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]],x_Symbol] :=
  2*(c*Cosh[d+e*x]+b*Sinh[d+e*x])/(e*Sqrt[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a^2-b^2+c^2]


Int[(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  (c*Cosh[d+e*x]+b*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n-1)/(e*n) +
  Dist[a*(2*n-1)/n,Int[(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n-1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n>1 && ZeroQ[a^2-b^2+c^2]


Int[(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  -(c*Cosh[d+e*x]+b*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^n/(a*e*(2*n+1)) +
  Dist[(n+1)/(a*(2*n+1)),Int[(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n<-1 && ZeroQ[a^2-b^2+c^2]


(* ::Subsubsection::Closed:: *)
(*(a+b Cosh[d+e x]+c Sinh[d+e x])^n			where a^2-b^2+c^2 is nonzero*)


(* ::Item:: *)
(*Reference: G&R 2.451.4c*)


(* Note: The following two rules should be unified! *)
Int[1/(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  Log[a+c*Tanh[(d+e*x)/2]]/(c*e) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a-b]


Int[1/(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  -Log[a-c*Coth[(d+e*x)/2]]/(c*e) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a+b]


(* ::Item:: *)
(*Reference: G&R 2.451.4a*)


Int[1/(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  2*ArcTan[(c-(a-b)*Tanh[(d+e*x)/2])/Rt[-a^2+b^2-c^2,2]]/(e*Rt[-a^2+b^2-c^2,2]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2] && NegQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Reference: G&R 2.451.4b'*)


Int[1/(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  -2*ArcTanh[(c-(a-b)*Tanh[(d+e*x)/2])/Rt[a^2-b^2+c^2,2]]/(e*Rt[a^2-b^2+c^2,2]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2] && PosQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Basis: a+b*Cosh[z]+c*Sinh[z] == a-I*Sqrt[b^2-c^2]*Sinh[z+I*ArcTan[I*c,b]]*)


Int[Sqrt[a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]],x_Symbol] :=
  2*I*EllipticE[(Pi/2-I*(d+e*x+I*ArcTan[I*c,b]))/2,2/(1-a/Sqrt[b^2-c^2])]*
  Sqrt[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]/
  (e*Sqrt[(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])/(a-Sqrt[b^2-c^2])]) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Basis: a+b*Cosh[z]+c*Sinh[z] == a-I*Sqrt[b^2-c^2]*Sinh[z+I*ArcTan[I*c,b]]*)


Int[1/Sqrt[a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]],x_Symbol] :=
  2*I*EllipticF[(Pi/2-I*(d+e*x+I*ArcTan[I*c,b]))/2,2/(1-a/Sqrt[b^2-c^2])]*
  Sqrt[(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])/(a-Sqrt[b^2-c^2])]/
  (e*Sqrt[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]) /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Reference: G&R 2.451.1*)


Int[(a_+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  (c*Cosh[d+e*x]+b*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1)/(e*(n+1)*(a^2-b^2+c^2)) +
  1/((n+1)*(a^2-b^2+c^2))*
    Int[((n+1)*a-(n+2)*b*Cosh[d+e*x]-(n+2)*c*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1),x] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2+c^2]


(* ::Subsubsection::Closed:: *)
(*(A+B Cosh[d+e x]+C Sinh[d+e x]) (a+b Cosh[d+e x]+c Sinh[d+e x])^n	where a^2-b^2+c^2 is nonzero*)
(**)


(* ::Item:: *)
(*Reference: G&R 2.451.2*)


Int[(A_.+C_.*Sinh[d_.+e_.*x_])/(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  b*C*Log[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]/(e*(b^2-c^2)) -
  c*C*(d+e*x)/(e*(b^2-c^2)) +
  Dist[(A+a*c*C/(b^2-c^2)),Int[1/(a+b*Cosh[d+e*x]+c*Sinh[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,C},x] && NonzeroQ[b^2-c^2] && NonzeroQ[A+a*c*C/(b^2-c^2)]


(* ::Item:: *)
(*Reference: G&R 2.451.2*)


Int[(A_.+B_.*Cosh[d_.+e_.*x_])/(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  -c*B*Log[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]/(e*(b^2-c^2)) +
  b*B*(d+e*x)/(e*(b^2-c^2)) +
  Dist[(A-a*b*B/(b^2-c^2)),Int[1/(a+b*Cosh[d+e*x]+c*Sinh[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,B},x] && NonzeroQ[b^2-c^2] && NonzeroQ[A-a*b*B/(b^2-c^2)]


(* ::Item:: *)
(*Reference: G&R 2.451.2*)


Int[(A_.+B_.*Cosh[d_.+e_.*x_]+C_.*Sinh[d_.+e_.*x_])/(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_]),x_Symbol] :=
  -(c*B-b*C)*Log[a+b*Cosh[d+e*x]+c*Sinh[d+e*x]]/(e*(b^2-c^2)) +
  (b*B-c*C)*(d+e*x)/(e*(b^2-c^2)) +
  Dist[(A-a*(b*B-c*C)/(b^2-c^2)),Int[1/(a+b*Cosh[d+e*x]+c*Sinh[d+e*x]),x]] /;
FreeQ[{a,b,c,d,e,A,B,C},x] && NonzeroQ[b^2-c^2] && NonzeroQ[A-a*(b*B-c*C)/(b^2-c^2)]


(* ::Item:: *)
(*Reference: G&R 2.451.1*)


Int[(A_.+C_.*Sinh[d_.+e_.*x_])*(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  (-b*C+(c*A-a*C)*Cosh[d+e*x]+b*A*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2+c^2)) +
  Dist[1/((n+1)*(a^2-b^2+c^2)),
    Int[((n+1)*(a*A+c*C)-(n+2)*b*A*Cosh[d+e*x]-(n+2)*(c*A-a*C)*Sinh[d+e*x])*
      (a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,C},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Reference: G&R 2.451.1*)


Int[(A_.+B_.*Cosh[d_.+e_.*x_])*(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  (c*B+c*A*Cosh[d+e*x]+(b*A-a*B)*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2+c^2)) +
  Dist[1/((n+1)*(a^2-b^2+c^2)),
    Int[((n+1)*(a*A-b*B)-(n+2)*(b*A-a*B)*Cosh[d+e*x]-(n+2)*c*A*Sinh[d+e*x])*
      (a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,B},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2+c^2]


(* ::Item:: *)
(*Reference: G&R 2.451.1*)


Int[(A_.+B_.*Cosh[d_.+e_.*x_]+C_.*Sinh[d_.+e_.*x_])*(a_.+b_.*Cosh[d_.+e_.*x_]+c_.*Sinh[d_.+e_.*x_])^n_,x_Symbol] :=
  (c*B-b*C+(c*A-a*C)*Cosh[d+e*x]+(b*A-a*B)*Sinh[d+e*x])*(a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1)/
    (e*(n+1)*(a^2-b^2+c^2)) +
  Dist[1/((n+1)*(a^2-b^2+c^2)),
    Int[((n+1)*(a*A-b*B+c*C)-(n+2)*(b*A-a*B)*Cosh[d+e*x]-(n+2)*(c*A-a*C)*Sinh[d+e*x])*
      (a+b*Cosh[d+e*x]+c*Sinh[d+e*x])^(n+1),x]] /;
FreeQ[{a,b,c,d,e,A,B,C},x] && RationalQ[n] && n<-1 && NonzeroQ[a^2-b^2+c^2]


(* ::Subsubsection::Closed:: *)
(*u (a+b Tanh[c+d x])^n*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: (a+b*Tanh[z])/Sech[z] == a*Cosh[z] + b*Sinh[z]*)


Int[Sech[v_]^m_.*(a_+b_.*Tanh[v_])^n_., x_Symbol] :=
  Int[(a*Cosh[v]+b*Sinh[v])^n,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m+n==0 


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: (a+b*Coth[z])/Csch[z] == b*Cosh[z] + a*Sinh[z]*)


Int[Csch[v_]^m_.*(a_+b_.*Coth[v_])^n_., x_Symbol] :=
  Int[(b*Cosh[v]+a*Sinh[v])^n,x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && m+n==0 


(* ::Subsection::Closed:: *)
(*Exponential and Hyperbolic Trig Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Sinh[c + d x]^n		Products of exponentials and powers of sines of linears*)


(* ::Item:: *)
(*Reference: CRC 533, A&S 4.3.136*)


Int[E^(a_.+b_.*x_)*Sinh[c_.+d_.*x_],x_Symbol] :=
  -d*E^(a+b*x)*Cosh[c+d*x]/(b^2-d^2) + b*E^(a+b*x)*Sinh[c+d*x]/(b^2-d^2) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[b^2-d^2]


(* ::Item:: *)
(*Reference: CRC 542, A&S 4.3.138*)


Int[E^(a_.+b_.*x_)*Sinh[c_.+d_.*x_]^n_,x_Symbol] :=
  -d*n*E^(a+b*x)*Cosh[c+d*x]*Sinh[c+d*x]^(n-1)/(b^2-d^2*n^2) + 
  b*E^(a+b*x)*Sinh[c+d*x]^n/(b^2-d^2*n^2) + 
  Dist[n*(n-1)*d^2/(b^2-d^2*n^2),Int[E^(a+b*x)*Sinh[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Cosh[c + d x]^n		Products of exponentials and powers of cosines of linears*)


(* ::Item:: *)
(*Reference: CRC 538, A&S 4.3.137*)


Int[E^(a_.+b_.*x_)*Cosh[c_.+d_.*x_],x_Symbol] :=
  b*E^(a+b*x)*Cosh[c+d*x]/(b^2-d^2) - d*E^(a+b*x)*Sinh[c+d*x]/(b^2-d^2) /;
FreeQ[{a,b,c,d},x] && NonzeroQ[b^2-d^2]


(* ::Item:: *)
(*Reference: CRC 543, A&S 4.3.139*)


Int[E^(a_.+b_.*x_)*Cosh[c_.+d_.*x_]^n_,x_Symbol] :=
  b*E^(a+b*x)*Cosh[c+d*x]^n/(b^2-d^2*n^2) - 
  d*n*E^(a+b*x)*Cosh[c+d*x]^(n-1)*Sinh[c+d*x]/(b^2-d^2*n^2) - 
  Dist[n*(n-1)*d^2/(b^2-d^2*n^2),Int[E^(a+b*x)*Cosh[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Sech[c + d x]^n		Products of exponentials and powers of secants of linears*)


(* ::Item:: *)
(*Reference: CRC 552*)


Int[E^(a_.+b_.*x_)*Sech[c_.+d_.*x_]^n_,x_Symbol] :=
  b*E^(a+b*x)*Sech[c+d*x]^(n-2)/(d^2*(n-2)*(n-1)) + 
  E^(a+b*x)*Sech[c+d*x]^(n-1)*Sinh[c+d*x]/(d*(n-1)) -
  Dist[(b^2-d^2*(n-2)^2)/(d^2*(n-1)*(n-2)),Int[E^(a+b*x)*Sech[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && n!=2


(* ::Subsubsection::Closed:: *)
(*Exp[a + b x] Csch[c + d x]^n		Products of exponentials and powers of cosecants of linears*)
(**)


(* ::Item:: *)
(*Reference: CRC 551*)


Int[E^(a_.+b_.*x_)*Csch[c_.+d_.*x_]^n_,x_Symbol] :=
  -b*E^(a+b*x)*Csch[c+d*x]^(n-2)/(d^2*(n-1)*(n-2)) - 
  E^(a+b*x)*Cosh[c+d*x]*Csch[c+d*x]^(n-1)/(d*(n-1)) +
  Dist[(b^2-d^2*(n-2)^2)/(d^2*(n-1)*(n-2)),Int[E^(a+b*x)*Csch[c+d*x]^(n-2),x]] /;
FreeQ[{a,b,c,d},x] && FractionQ[n] && n>1 && n!=2


(* ::Subsubsection::Closed:: *)
(*x^m Exp[a + b x] Sinh[c + d x]^n	Products of monomials, exponentials and powers of sines of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(a_.+b_.*x_)*Sinh[c_.+d_.*x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[E^(a+b*x)*Sinh[c+d*x]^n,x]]},
  x^m*u - 
  Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && m>0 && n>0


(* ::Subsubsection::Closed:: *)
(*x^m Exp[a + b x] Cosh[c + d x]^n	Products of exponentials and powers of cosines of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(a_.+b_.*x_)*Cosh[c_.+d_.*x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[E^(a+b*x)*Cosh[c+d*x]^n,x]]},
  x^m*u - 
  Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && IntegerQ[n] && m>0 && n>0


(* ::Subsubsection::Closed:: *)
(*u f^v Hyper[w]				Products of exponentials and hyperbolic functions of polynomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z] == 1/2*(E^z - 1/E^z) *)


Int[f_^v_*Sinh[w_],x_Symbol] :=
  Dist[1/2,Int[f^v*E^w,x]] - 
  Dist[1/2,Int[f^v/E^w,x]] /;
FreeQ[f,x] && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Sinh[z] == 1/2*(E^z - 1/E^z) *)


Int[f_^v_*Sinh[w_]^n_,x_Symbol] :=
  Dist[1/2^n,Int[f^v*(E^w-1/E^w)^n,x]] /;
FreeQ[f,x] && IntegerQ[n] && n>0 && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z] == 1/2*(E^z + 1/E^z)*)


Int[f_^v_*Cosh[w_],x_Symbol] :=
  Dist[1/2,Int[f^v*E^w,x]] + 
  Dist[1/2,Int[f^v/E^w,x]] /;
FreeQ[f,x] && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Cosh[z] == 1/2*(E^z + 1/E^z)*)


Int[f_^v_*Cosh[w_]^n_,x_Symbol] :=
  Dist[1/2^n,Int[f^v*(E^w+1/E^w)^n,x]] /;
FreeQ[f,x] && IntegerQ[n] && n>0 && PolynomialQ[v,x] && Exponent[v,x]<=2 && PolynomialQ[w,x] && Exponent[w,x]<=2


(* ::Subsection::Closed:: *)
(*Hyperbolic Function Simplification Rules*)


(* ::Subsubsection::Closed:: *)
(*u (a-a Hyper[v]^2)^n*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1+Sinh[z]^2 == Cosh[z]^2*)


Int[u_.*(a_+b_.*Sinh[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Cosh[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a-b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: -1 + Cosh[z]^2 == Sinh[z]^2*)


Int[u_.*(a_+b_.*Cosh[v_]^2)^n_.,x_Symbol] :=
  Dist[b^n,Int[u*Sinh[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 - Tanh[z]^2 == Sech[z]^2*)


Int[u_.*(a_+b_.*Tanh[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Sech[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: -1 + Coth[z]^2 == Csch[z]^2*)


Int[u_.*(a_+b_.*Coth[v_]^2)^n_.,x_Symbol] :=
  Dist[b^n,Int[u*Csch[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 - Sech[z]^2 == Tanh[z]^2*)


Int[u_.*(a_+b_.*Sech[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Tanh[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a+b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 + Csch[z]^2 == Coth[z]^2*)


Int[u_.*(a_+b_.*Csch[v_]^2)^n_.,x_Symbol] :=
  Dist[a^n,Int[u*Coth[v]^(2*n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && ZeroQ[a-b]


(* ::Subsubsection::Closed:: *)
(*u (a Tanh[v]^m+b Sech[v]^m)^n  	Simplify sum of powers of hyperbolic functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a^2+b^2=0, then a*Tanh[z]+b*Sech[z] == a*Tanh[z/2-a/b*Pi/4]*)


(* Int[(a_.*Tanh[v_]+b_.*Sech[v_])^n_,x_Symbol] :=
  Dist[a^n,Int[Tanh[v/2-a/b*Pi/4]^n,x]] /;
FreeQ[{a,b},x] && ZeroQ[a^2+b^2] && EvenQ[n] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*Sech[z]+b*Tanh[z] == (a+b*Sinh[z])/Cosh[z]*)


Int[u_.*(a_.*Sech[v_]^m_.+b_.*Tanh[v_]^m_.)^n_.,x_Symbol] :=
  Int[u*(a+b*Sinh[v]^m)^n/Cosh[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && (OddQ[m*n] || m*n<0) && Not[m==2 && ZeroQ[a-b]]


(* ::Subsubsection::Closed:: *)
(*u (a Coth[v]^m+b Csch[v]^m)^n 	Simplify sum of powers of hyperbolic functions*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a^2-b^2=0, then a*Coth[z]+b*Csch[z] == a*Coth[z/2+(a/b-1)*Pi*I/4]*)


Int[(a_.*Coth[v_]+b_.*Csch[v_])^n_,x_Symbol] :=
  Dist[a^n,Int[Coth[v/2+(a/b-1)*Pi*I/4]^n,x]] /;
FreeQ[{a,b},x] && ZeroQ[a^2-b^2] && EvenQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*Csch[z]+b*Coth[z] == (a+b*Cosh[z])/Sinh[z]*)


Int[u_.*(a_.*Csch[v_]^m_.+b_.*Coth[v_]^m_.)^n_.,x_Symbol] :=
  Int[u*(a+b*Cosh[v]^m)^n/Sinh[v]^(m*n),x] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && (OddQ[m*n] || m*n<0) && Not[m==2 && ZeroQ[a+b]]


(* ::Subsubsection::Closed:: *)
(*x^m Hyper[u]^n Hyper[v]^p*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sinh[z]*Cosh[z] == Sinh[2*z]/2*)


(* Int[x_^m_.*Sinh[v_]^n_.*Cosh[v_]^n_.,x_Symbol] :=
  Dist[1/2^n,Int[x^m*Sinh[Dist[2,v]]^n,x]] /;
IntegerQ[n] *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Sech[z]*Csch[z] == 2*Csch[2*z]*)


Int[x_^m_.*Sech[v_]^n_.*Csch[v_]^n_.,x_Symbol] :=
  Dist[2^n,Int[x^m*Csch[Dist[2,v]]^n,x]] /;
IntegerQ[{m,n}] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Convert hyperbolic function to complex exponentials*)


(* Got to improve x^m*f[e^x] integration before doing this! *)
(* Int[x_^m_.*f_[u_]^n_.*g_[v_]^p_.,x_Symbol] :=
  Int[x^m*TrigToExp[f[u]]^n*TrigToExp[g[v]]^p,x] /;
IntegerQ[{m,n,p}] && HyperbolicQ[f] && HyperbolicQ[g] *)


(* ::Subsection::Closed:: *)
(*Hyperbolic Function Substitution Rules*)


(* ::Subsubsection::Closed:: *)
(*Pure hyperbolic sine function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sinh[z]]*Cosh[z] == f[Sinh[z]] * Sinh'[z]*)


Int[u_*Cosh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sinh[c*(a+b*x)],u,x],x],x],x,Sinh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sinh[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sinh[z]]*Coth[z] == f[Sinh[z]]/Sinh[z] * Sinh'[z]*)


Int[u_*Coth[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Sinh[c*(a+b*x)],u,x]/x,x],x],x,Sinh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sinh[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Sinh[z]]*Sinh[2*z] == 2*f[Sinh[z]]*Sinh[z] * Sinh'[z]*)


Int[u_*Sinh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[4/(b*c),Subst[Int[Regularize[x*SubstFor[Sinh[c*(a+b*x)/2],u,x],x],x],x,Sinh[c*(a+b*x)/2]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Sinh[c*(a+b*x)/2],u,x,True]


(* ::Subsubsection::Closed:: *)
(*Pure hyperbolic cosine function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cosh[z]]*Sinh[z] == f[Cosh[z]] * Cosh'[z]*)


Int[u_*Sinh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cosh[c*(a+b*x)],u,x],x],x],x,Cosh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cosh[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cosh[z]]*Tanh[z] == f[Cosh[z]]/Cosh[z] * Cosh'[z]*)


Int[u_*Tanh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Cosh[c*(a+b*x)],u,x]/x,x],x],x,Cosh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cosh[c*(a+b*x)],u,x,True]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Cosh[z]]*Sinh[2*z] == 2*f[Cosh[z]]*Cosh[z] * Cosh'[z]*)


Int[u_*Sinh[c_.*(a_.+b_.*x_)],x_Symbol] :=
  Dist[4/(b*c),Subst[Int[Regularize[x*SubstFor[Cosh[c*(a+b*x)/2],u,x],x],x],x,Cosh[c*(a+b*x)/2]]] /;
FreeQ[{a,b,c},x] && FunctionOfQ[Cosh[c*(a+b*x)/2],u,x,True]


(* ::Subsubsection::Closed:: *)
(*Pure hyperbolic cotangent function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is an integer, f[Coth[z]]*Tanh[z]^n == f[Coth[z]]/(Coth[z]^n*(1-Coth[z]^2)) * Coth'[z]*)


Int[u_*Tanh[c_.*(a_.+b_.*x_)]^n_.,x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Coth[c*(a+b*x)],u,x]/(x^n*(1-x^2)),x],x],x,Coth[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && IntegerQ[n] && FunctionOfQ[Coth[c*(a+b*x)],u,x,True] && TryPureTanhSubst[u*Tanh[c*(a+b*x)]^n,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Coth[z]] == f[Coth[z]]/(1-Coth[z]^2) * Coth'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  ShowStep["","Int[f[Coth[a+b*x]],x]","Subst[Int[f[x]/(1-x^2),x],x,Coth[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Coth[v],u,x]/(1-x^2),x],x],x,Coth[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Coth[v],u,x,True] && TryPureTanhSubst[u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Coth[v],u,x]/(1-x^2),x],x],x,Coth[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Coth[v],u,x,True] && TryPureTanhSubst[u,x]]]


(* ::Subsubsection::Closed:: *)
(*Pure hyperbolic tangent function substitution rules*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: If n is an integer, f[Tanh[z]]*Coth[z]^n == f[Tanh[z]]/(Tanh[z]^n*(1-Tanh[z]^2)) * Tanh'[z]*)


Int[u_*Coth[c_.*(a_.+b_.*x_)]^n_.,x_Symbol] :=
  Dist[1/(b*c),Subst[Int[Regularize[SubstFor[Tanh[c*(a+b*x)],u,x]/(x^n*(1-x^2)),x],x],x,Tanh[c*(a+b*x)]]] /;
FreeQ[{a,b,c},x] && IntegerQ[n] && FunctionOfQ[Tanh[c*(a+b*x)],u,x,True] && TryPureTanhSubst[u*Coth[c*(a+b*x)]^n,x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[Tanh[z]] == f[Tanh[z]]/(1-Tanh[z]^2) * Tanh'[z]*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  ShowStep["","Int[f[Tanh[a+b*x]],x]","Subst[Int[f[x]/(1-x^2),x],x,Tanh[a+b*x]]/b",Hold[
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tanh[v],u,x]/(1-x^2),x],x],x,Tanh[v]]]]] /;
 NotFalseQ[v] && FunctionOfQ[Tanh[v],u,x,True] && TryPureTanhSubst[u,x]] /;
SimplifyFlag,

Int[u_,x_Symbol] :=
  Module[{v=FunctionOfHyperbolic[u,x]},
  Dist[1/Coefficient[v,x,1],Subst[Int[Regularize[SubstFor[Tanh[v],u,x]/(1-x^2),x],x],x,Tanh[v]]] /;
 NotFalseQ[v] && FunctionOfQ[Tanh[v],u,x,True] && TryPureTanhSubst[u,x]]]


TryPureTanhSubst[u_,x_Symbol] :=
  Not[MatchQ[u,ArcTanh[a_.*Tanh[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcTanh[a_.*Coth[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcCoth[a_.*Tanh[v_]] /; FreeQ[a,x]]] &&
  Not[MatchQ[u,ArcCoth[a_.*Coth[v_]] /; FreeQ[a,x]]] &&
  u===ExpnExpand[u,x]
././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/InverseTrigFunctionIntegrationRules.mmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/InverseTrigFunctionIntegrationRules0000644000175000017500000007617611446257035034127 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Inverse Trig Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Arcsine Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcSin[a+b x]^n			Powers of arcsines of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.813.1, CRC 441, A&S 4.4.58*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSin[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcSin[a+b*x]/b + Sqrt[1-(a+b*x)^2]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/ArcSin[z] == Cos[ArcSin[z]]/ArcSin[z]*ArcSin'[z]*)


Int[1/ArcSin[a_.+b_.*x_],x_Symbol] :=
  CosIntegral[ArcSin[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[1/ArcSin[a_.+b_.*x_]^2,x_Symbol] :=
  -Sqrt[1-(a+b*x)^2]/(b*ArcSin[a+b*x]) - SinIntegral[ArcSin[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[ArcSin[z]] == Cos[ArcSin[z]]/Sqrt[ArcSin[z]]*ArcSin'[z]*)


Int[1/Sqrt[ArcSin[a_.+b_.*x_]],x_Symbol] :=
  Sqrt[2*Pi]*FresnelC[Sqrt[2/Pi]*Sqrt[ArcSin[a+b*x]]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sqrt[ArcSin[a_.+b_.*x_]],x_Symbol] :=
  (a+b*x)*Sqrt[ArcSin[a+b*x]]/b -
  Sqrt[Pi/2]*FresnelS[Sqrt[2/Pi]*Sqrt[ArcSin[a+b*x]]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: CRC 465*)


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[ArcSin[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcSin[a+b*x]^n/b +
  n*Sqrt[1-(a+b*x)^2]*ArcSin[a+b*x]^(n-1)/b -
  Dist[n*(n-1),Int[ArcSin[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts twice*)


Int[ArcSin[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcSin[a+b*x]^(n+2)/(b*(n+1)*(n+2)) +
  Sqrt[1-(a+b*x)^2]*ArcSin[a+b*x]^(n+1)/(b*(n+1)) -
  Dist[1/((n+1)*(n+2)),Int[ArcSin[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1 && n!=-2


Int[ArcSin[a_.+b_.*x_]^n_,x_Symbol] :=
  I*ArcSin[a+b*x]^n*(-(I*ArcSin[a+b*x])^n*Gamma[n+1,-I*ArcSin[a+b*x]] + 
  (-I*ArcSin[a+b*x])^n*Gamma[n+1,I*ArcSin[a+b*x]])/(2*b*(ArcSin[a+b*x]^2)^n) /;
FreeQ[{a,b,n},x] && (Not[RationalQ[n]] || -10


(* ::Subsubsection::Closed:: *)
(*x ArcSin[a+b x]^n/Sqrt[1-(a+b x)^2]	Products of x and powers of arcsines of linears divided by sqrt of linear*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*ArcSin[a_.+b_.*x_]^n_/Sqrt[u_],x_Symbol] :=
  -Sqrt[u]*ArcSin[a+b*x]^n/b^2 +
  Dist[n/b,Int[ArcSin[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcSin[a+b*x]^n/Sqrt[u],x]] /;
FreeQ[{a,b},x] && ZeroQ[u-1+(a+b*x)^2] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcSin[c / (a+b x^n)]^m		Powers of arcsines of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcSin[z] == ArcCsc[1/z]*)


Int[u_.*ArcSin[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCsc[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcSin[x]] / Sqrt[1-x^2]		Products of functions of inverse sines and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: f[ArcSin[x]]/Sqrt[1-x^2] == f[ArcSin[x]]*ArcSin'[x]*)


(* Int[u_/Sqrt[1-x_^2],x_Symbol] :=
  Subst[Int[Regularize[SubstFor[ArcSin[x],u,x],x],x],x,ArcSin[x]] /;
FunctionOfQ[ArcSin[x],u,x] *)


(* ::Subsubsection::Closed:: *)
(*u ArcSin[v]				Products of expressions and arcsines of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSin[u_],x_Symbol] :=
  x*ArcSin[u] -
  Int[Regularize[x*D[u,x]/Sqrt[1-u^2],x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsubsection::Closed:: *)
(*f^(c ArcSin[a+b x])			Exponentials of arcsines of linears*)


Int[f_^(c_.*ArcSin[a_.+b_.*x_]),x_Symbol] :=
  f^(c*ArcSin[a+b*x])*(a+b*x+c*Sqrt[1-(a+b*x)^2]*Log[f])/(b*(1+c^2*Log[f]^2)) /;
FreeQ[{a,b,c,f},x] && NonzeroQ[1+c^2*Log[f]^2]


(* ::Subsection::Closed:: *)
(*Arccosine Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcCos[a+b x]^n			Powers of arccosines of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.814.1, CRC 442, A&S 4.4.59*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCos[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCos[a+b*x]/b - Sqrt[1-(a+b*x)^2]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/ArcCos[z] == -Sin[ArcCos[z]]/ArcCos[z]*ArcCos'[z]*)


Int[1/ArcCos[a_.+b_.*x_],x_Symbol] :=
  -SinIntegral[ArcCos[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[1/ArcCos[a_.+b_.*x_]^2,x_Symbol] :=
  Sqrt[1-(a+b*x)^2]/(b*ArcCos[a+b*x]) - CosIntegral[ArcCos[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[ArcCos[z]] == -Sin[ArcCos[z]]/Sqrt[ArcCos[z]]*ArcCos'[z]*)


Int[1/Sqrt[ArcCos[a_.+b_.*x_]],x_Symbol] :=
  -Sqrt[2*Pi]*FresnelS[Sqrt[2/Pi]*Sqrt[ArcCos[a+b*x]]]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sqrt[ArcCos[a_.+b_.*x_]],x_Symbol] :=
  (a+b*x)*Sqrt[ArcCos[a+b*x]]/b - Sqrt[Pi/2]*FresnelC[Sqrt[2/Pi]*Sqrt[ArcCos[a+b*x]]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: CRC 466*)


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[ArcCos[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcCos[a+b*x]^n/b -
  n*Sqrt[1-(a+b*x)^2]*ArcCos[a+b*x]^(n-1)/b -
  Dist[n*(n-1),Int[ArcCos[a+b*x]^(n-2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts twice*)


Int[ArcCos[a_.+b_.*x_]^n_,x_Symbol] :=
  (a+b*x)*ArcCos[a+b*x]^(n+2)/(b*(n+1)*(n+2)) -
  Sqrt[1-(a+b*x)^2]*ArcCos[a+b*x]^(n+1)/(b*(n+1)) -
  Dist[1/((n+1)*(n+2)),Int[ArcCos[a+b*x]^(n+2),x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n<-1 && n!=-2


Int[ArcCos[a_.+b_.*x_]^n_,x_Symbol] :=
  ArcCos[a+b*x]^n*((I*ArcCos[a+b*x])^n*Gamma[n+1,-I*ArcCos[a+b*x]] + 
  (-I*ArcCos[a+b*x])^n*Gamma[n+1,I*ArcCos[a+b*x]])/(2*b*(ArcCos[a+b*x]^2)^n) /;
FreeQ[{a,b,n},x] && (Not[RationalQ[n]] || -10


(* ::Subsubsection::Closed:: *)
(*x ArcCos[a+b x]^n/Sqrt[1-(a+b x)^2]  	Products of x and powers of arccosines of linears divided by sqrt of linear*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*ArcCos[a_.+b_.*x_]^n_/Sqrt[u_],x_Symbol] :=
  -Sqrt[u]*ArcCos[a+b*x]^n/b^2 -
  Dist[n/b,Int[ArcCos[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcCos[a+b*x]^n/Sqrt[u],x]] /;
FreeQ[{a,b},x] && ZeroQ[u-1+(a+b*x)^2] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcCos[c / (a+b x^n)]^m		Powers of arccosines of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCos[z] == ArcSec[1/z]*)


Int[u_.*ArcCos[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcSec[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcCos[x]] / Sqrt[1-x^2]		Products of functions of inverse cosines and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/Sqrt[1-z^2] == -ArcCos'[z]*)


(* Int[u_/Sqrt[1-x_^2],x_Symbol] :=
  -Subst[Int[Regularize[SubstFor[ArcCos[x],u,x],x],x],x,ArcCos[x]] /;
FunctionOfQ[ArcCos[x],u,x] *)


(* ::Subsubsection::Closed:: *)
(*u ArcCos[v]				Products of expressions and arccosines of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCos[u_],x_Symbol] :=
  x*ArcCos[u] +
  Int[Regularize[x*D[u,x]/Sqrt[1-u^2],x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsubsection::Closed:: *)
(*f^(c ArcCos[a+b x])			Exponentials of arccosines of linears*)


Int[f_^(c_.*ArcCos[a_.+b_.*x_]),x_Symbol] :=
  f^(c*ArcCos[a+b*x])*(a+b*x-c*Sqrt[1-(a+b*x)^2]*Log[f])/(b*(1+c^2*Log[f]^2)) /;
FreeQ[{a,b,c,f},x] && NonzeroQ[1+c^2*Log[f]^2]


(* ::Subsection::Closed:: *)
(*Arctangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcTan[a+b x^n]			Arctangents of binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.822.1, CRC 443, A&S 4.4.60*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTan[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcTan[a+b*x]/b - Log[1+(a+b*x)^2]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTan[a_.+b_.*x_^n_],x_Symbol] :=
  x*ArcTan[a+b*x^n] -
  Dist[b*n,Int[x^n/(1+a^2+2*a*b*x^n+b^2*x^(2*n)),x]] /;
FreeQ[{a,b},x] && IntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m ArcTan[a+b x^n]			Products of monomials and arctangents of binomials*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: ArcTan[z] == I/2*Log[1-I*z] - I/2*Log[1+I*z]*)


Int[ArcTan[a_.+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[I/2,Int[Log[1-I*a-I*b*x^n]/x,x]] -
  Dist[I/2,Int[Log[1+I*a+I*b*x^n]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Int[ArcTan[a_.+b_.*x_]/x_,x_Symbol] :=
  Log[x]*ArcTan[a+b*x] -
  Dist[b,Int[Log[x]/(1+(a+b*x)^2),x]] /;
FreeQ[{a,b},x] *)


(* ::Item::Closed:: *)
(*Reference: G&R 2.851, CRC 456, A&S 4.4.69*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcTan[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)*ArcTan[a+b*x^n]/(m+1) -
  Dist[b*n/(m+1),Int[x^(m+n)/(1+a^2+2*a*b*x^n+b^2*x^(2*n)),x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && NonzeroQ[m+1] && NonzeroQ[m-n+1]


(* ::Subsubsection::Closed:: *)
(*(1+x^2)^m ArcTan[x]^n		Products of powers of binomials and powers of arctangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(1+x_^2)^m_*ArcTan[x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[(1+x^2)^m,x]]},
  u*ArcTan[x]^n -
  Dist[n,Int[u*ArcTan[x]^(n-1)/(1+x^2),x]]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* ::Subsubsection::Closed:: *)
(*(1+x^2)^m ArcCot[x]^n ArcTan[x]^p	Products of powers of binomials, arccotangents and arctangents*)


Int[1/((1+x_^2)*ArcCot[x_]*ArcTan[x_]),x_Symbol] :=
  (-Log[ArcCot[x]]+Log[ArcTan[x]])/(ArcCot[x]+ArcTan[x])


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCot[x_]^n_.*ArcTan[x_]^p_./(1+x_^2),x_Symbol] :=
  -ArcCot[x]^(n+1)*ArcTan[x]^p/(n+1) +
  Dist[p/(n+1),Int[ArcCot[x]^(n+1)*ArcTan[x]^(p-1)/(1+x^2),x]] /;
IntegerQ[{n,p}] && 01


Int[x_*ArcTan[a_+b_.*x_]^n_,x_Symbol] :=
  ((a+b*x)^2+1)*ArcTan[a+b*x]^n/(2*b^2) -
  Dist[n/(2*b),Int[ArcTan[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcTan[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcTan[c / (a+b x^n)]		Arctangents of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTan[z] == ArcCot[1/z]*)


Int[u_.*ArcTan[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCot[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcTan[x]] (1+x^2)^n		Products of functions of arctangents and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/(1+z^2) == ArcTan'[z]*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Cos[x]^(-2*(n+1))*SubstFor[ArcTan[x],u,x],x],x],x,ArcTan[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTan[x],u,x] && ZeroQ[a-b] && IntegerQ[n] && n<-1


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Cos[x]^(-2*(n+1))*SubstFor[ArcTan[x],u,x],x],x],x,ArcTan[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTan[x],u,x] && ZeroQ[a-b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[1/a,Subst[Int[Regularize[(a*Sec[x]^2)^(n+1)*SubstFor[ArcTan[x],u,x],x],x],x,ArcTan[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTan[x],u,x] && ZeroQ[a-b] && HalfIntegerQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m f[ArcTan[x]] (1+x^2)^n		Products of monomials, functions of arctangents and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/(1+z^2) == ArcTan'[z]*)


Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Tan[x]^m*Cos[x]^(-2*(n+1))*SubstFor[ArcTan[x],u,x],x],x],x,ArcTan[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTan[x],u,x] && ZeroQ[a-b] && IntegerQ[{m,n}] && n<0


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[a^n,Subst[Int[Regularize[Tan[x]^m*Cos[x]^(-2*(n+1))*SubstFor[ArcTan[x],u,x],x],x],x,ArcTan[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcTan[x],u,x] && ZeroQ[a-b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a] && IntegerQ[m]
(* Need to generalize for arbitrary functions of ArcTan[Sqrt[b/a]*x] *)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* Int[f_[ArcTan[c_.*x_]]/(a_+b_.*x_^2),x_Symbol] :=
  Dist[1/(a*Sqrt[b/a]),Subst[Int[f[x],x],x,ArcTan[c*x]]] /;
FreeQ[{a,b,c,f},x] && c===Sqrt[b/a] *)


(* ::Subsubsection::Closed:: *)
(*v ArcTan[u]				Products of expressions and arctangents of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcTan[u_],x_Symbol] :=
  x*ArcTan[u] -
  Int[Regularize[x*D[u,x]/(1+u^2),x],x] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcTan[u_],x_Symbol] :=
  x^(m+1)*ArcTan[u]/(m+1) -
  Dist[1/(m+1),Int[Regularize[x^(m+1)*D[u,x]/(1+u^2),x],x]] /;
FreeQ[m,x] && NonzeroQ[m+1] && InverseFunctionFreeQ[u,x] && 
	Not[FunctionOfQ[x^(m+1),u,x]] && 
	FalseQ[PowerVariableExpn[u,m+1,x]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[v_*ArcTan[u_],x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},  
  w*ArcTan[u] -
  Int[Regularize[w*D[u,x]/(1+u^2),x],x] /;
 InverseFunctionFreeQ[w,x]] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[v, x^m_. /; FreeQ[m,x]]] &&
	FalseQ[FunctionOfLinear[v*ArcTan[u],x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTan[z] ==  I/2*Log[1-I*z] - I/2*Log[1+I*z]*)


Int[ArcTan[b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[I/2,Int[Log[1-I*b*x]/(c+d*x^n),x]] -
  Dist[I/2,Int[Log[1+I*b*x]/(c+d*x^n),x]] /;
FreeQ[{b,c,d},x] && IntegerQ[n] && Not[n==2 && ZeroQ[b^2*c-d]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTan[z] ==  I/2*Log[1-I*z] - I/2*Log[1+I*z]*)


Int[ArcTan[a_+b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[I/2,Int[Log[1-I*a-I*b*x]/(c+d*x^n),x]] -
  Dist[I/2,Int[Log[1+I*a+I*b*x]/(c+d*x^n),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[n] && Not[n==1 && ZeroQ[a*d-b*c]]


(* ::Subsection::Closed:: *)
(*Arccotangent Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcCot[a+b x^n]			Arccotangents of binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.822.2, CRC 444, A&S 4.4.63*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCot[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCot[a+b*x]/b + Log[1+(a+b*x)^2]/(2*b) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCot[a_.+b_.*x_^n_],x_Symbol] :=
  x*ArcCot[a+b*x^n] +
  Dist[b*n,Int[x^n/(1+a^2+2*a*b*x^n+b^2*x^(2*n)),x]] /;
FreeQ[{a,b},x] && IntegerQ[n]


(* ::Subsubsection::Closed:: *)
(*x^m ArcCot[a+b x^n]			Products of monomials and arccotangents of binomials*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: ArcCot[z] == I/2*Log[1-I/z] - I/2*Log[1+I/z]*)


Int[ArcCot[a_.+b_.*x_^n_.]/x_,x_Symbol] :=
  Dist[I/2,Int[Log[1-I/(a+b*x^n)]/x,x]] -
  Dist[I/2,Int[Log[1+I/(a+b*x^n)]/x,x]] /;
FreeQ[{a,b,n},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Int[ArcCot[a_.+b_.*x_]/x_,x_Symbol] :=
  Log[x]*ArcCot[a+b*x] +
  Dist[b,Int[Log[x]/(1+(a+b*x)^2),x]] /;
FreeQ[{a,b},x] *)


(* ::Item::Closed:: *)
(*Reference: G&R 2.852, CRC 458, A&S 4.4.71*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCot[a_.+b_.*x_^n_.],x_Symbol] :=
  x^(m+1)*ArcCot[a+b*x^n]/(m+1) +
  Dist[b*n/(m+1),Int[x^(m+n)/(1+a^2+2*a*b*x^n+b^2*x^(2*n)),x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && NonzeroQ[m+1] && NonzeroQ[m-n+1]


(* ::Subsubsection::Closed:: *)
(*(1+x^2)^m ArcCot[x]^n		Products of powers of binomials and powers of arccotangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(1+x_^2)^m_*ArcCot[x_]^n_.,x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[(1+x^2)^m,x]]},
  u*ArcCot[x]^n +
  Dist[n,Int[u*ArcCot[x]^(n-1)/(1+x^2),x]]] /;
IntegerQ[{m,n}] && m<-1 && n>0


(* ::Subsubsection::Closed:: *)
(*(1+x^2)^m ArcCot[x]^n ArcTan[x]^p	Products of powers of binomials, arccotangents and arctangents*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCot[x_]^n_.*ArcTan[x_]^p_/(1+x_^2),x_Symbol] :=
  ArcCot[x]^n*ArcTan[x]^(p+1)/(p+1) +
  Dist[n/(p+1),Int[ArcCot[x]^(n-1)*ArcTan[x]^(p+1)/(1+x^2),x]] /;
IntegerQ[{n,p}] && 00 && n>0


(* ::Subsubsection::Closed:: *)
(*x ArcCot[a+b x]^n			Products of x and powers of arccotangents of linears*)


Int[x_*ArcCot[b_.*x_]^n_,x_Symbol] :=
  ((b*x)^2+1)*ArcCot[b*x]^n/(2*b^2) +
  Dist[n/(2*b),Int[ArcCot[b*x]^(n-1),x]] /;
FreeQ[b,x] && RationalQ[n] && n>1


Int[x_*ArcCot[a_.+b_.*x_]^n_,x_Symbol] :=
  ((a+b*x)^2+1)*ArcCot[a+b*x]^n/(2*b^2) +
  Dist[n/(2*b),Int[ArcCot[a+b*x]^(n-1),x]] -
  Dist[a/b,Int[ArcCot[a+b*x]^n,x]] /;
FreeQ[{a,b},x] && RationalQ[n] && n>1


(* ::Subsubsection::Closed:: *)
(*u ArcCot[c / (a+b x^n)]			Inverse cotangent of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCot[z] == ArcTan[1/z]*)


Int[u_.*ArcCot[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcTan[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*f[ArcCot[x]] (1+x^2)^n		Products of functions of arccotangents and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/(1+z^2) == -ArcCot'[z]*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[-a^n,Subst[Int[Regularize[Sin[x]^(-2*(n+1))*SubstFor[ArcCot[x],u,x],x],x],x,ArcCot[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCot[x],u,x] && ZeroQ[a-b] && IntegerQ[n] && n<-1


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[-1/a,Subst[Int[Regularize[(a*Csc[x]^2)^(n+1)*SubstFor[ArcCot[x],u,x],x],x],x,ArcCot[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCot[x],u,x] && ZeroQ[a-b] && HalfIntegerQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m f[ArcCot[x]] (1+x^2)^n		Products of monomials, functions of arccotangents and its derivative*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/(1+z^2) == -ArcCot'[z]*)


Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[-a^n,Subst[Int[Regularize[Cot[x]^m*Sin[x]^(-2*(n+1))*SubstFor[ArcCot[x],u,x],x],x],x,ArcCot[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCot[x],u,x] && ZeroQ[a-b] && IntegerQ[{m,n}] && n<0


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* ??? *)
Int[x_^m_.*u_*(a_+b_.*x_^2)^n_,x_Symbol] :=
  Dist[-a^n,Subst[Int[Regularize[Cot[x]^m*Sin[x]^(-2*(n+1))*SubstFor[ArcCot[x],u,x],x],x],x,ArcCot[x]]] /;
FreeQ[{a,b},x] && FunctionOfQ[ArcCot[x],u,x] && ZeroQ[a-b] && HalfIntegerQ[n] && n<-1 && 
	PositiveQ[a] && IntegerQ[m]


(* ::Subsubsection::Closed:: *)
(*v ArcCot[u]				Products of expressions and arccotangents of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCot[u_],x_Symbol] :=
  x*ArcCot[u] +
  Int[Regularize[x*D[u,x]/(1+u^2),x],x] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCot[u_],x_Symbol] :=
  x^(m+1)*ArcCot[u]/(m+1) +
  Dist[1/(m+1),Int[Regularize[x^(m+1)*D[u,x]/(1+u^2),x],x]] /;
FreeQ[m,x] && NonzeroQ[m+1] && InverseFunctionFreeQ[u,x] && 
	Not[FunctionOfQ[x^(m+1),u,x]] && 
	FalseQ[PowerVariableExpn[u,m+1,x]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[v_*ArcCot[u_],x_Symbol] :=
  Module[{w=Block[{ShowSteps=False,StepCounter=Null}, Int[v,x]]},  
  w*ArcCot[u] +
  Int[Regularize[w*D[u,x]/(1+u^2),x],x] /;
 InverseFunctionFreeQ[w,x]] /;
InverseFunctionFreeQ[u,x] && 
	Not[MatchQ[v, x^m_. /; FreeQ[m,x]]] &&
	FalseQ[FunctionOfLinear[v*ArcCot[u],x]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCot[z] ==  I/2*Log[1-I/z] - I/2*Log[1+I/z]*)


Int[ArcCot[b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[I/2,Int[Log[1-I/(b*x)]/(c+d*x^n),x]] -
  Dist[I/2,Int[Log[1+I/(b*x)]/(c+d*x^n),x]] /;
FreeQ[{b,c,d},x] && IntegerQ[n] && Not[n==2 && ZeroQ[b^2*c-d]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCot[z] ==  I/2*Log[1-I/z] - I/2*Log[1+I/z]*)


Int[ArcCot[a_+b_.*x_]/(c_+d_.*x_^n_.),x_Symbol] :=
  Dist[I/2,Int[Log[1-I/(a+b*x)]/(c+d*x^n),x]] -
  Dist[I/2,Int[Log[1+I/(a+b*x)]/(c+d*x^n),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[n] && Not[n==1 && ZeroQ[a*d-b*c]]


(* ::Subsection::Closed:: *)
(*Arcsecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcSec[a+b x]^n			Powers of arcsecants of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.821.2, CRC 445', A&S 4.4.62'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSec[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcSec[a+b*x]/b - 
  Int[1/((a+b*x)*Sqrt[1-1/(a+b*x)^2]),x] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m ArcSec[a+b x]			Products of monomials and arcsecants of binomials*)


Int[ArcSec[a_.*x_^n_.]/x_,x_Symbol] :=
  I*ArcSec[a*x^n]^2/(2*n) - 
  ArcSec[a*x^n]*Log[1-1/(I/(x^n*a)+Sqrt[1-1/(x^(2*n)*a^2)])^2]/n + 
  I*PolyLog[2,1/(I/(x^n*a)+Sqrt[1-1/(x^(2*n)*a^2)])^2]/(2*n) /;
(* Sqrt[-1/a^2]*a*ArcCsc[a*x^n]^2/(2*n) + 
  Pi*Log[x]/2 - 
  Sqrt[-1/a^2]*a*ArcSinh[Sqrt[-1/a^2]/x^n]*Log[1-1/(Sqrt[-(1/a^2)]/x^n+Sqrt[1-1/(x^(2*n)*a^2)])^2]/n + 
  Sqrt[-1/a^2]*a*PolyLog[2, 1/(Sqrt[-1/a^2]/x^n+Sqrt[1-1/(x^(2*n)*a^2)])^2]/(2*n) *)
FreeQ[{a,n},x]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*ArcSec[a_+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*ArcSec[x],x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Reference: CRC 474*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcSec[a_.*x_],x_Symbol] :=
  x^(m+1)*ArcSec[a*x]/(m+1) - 
  Dist[1/(a*(m+1)),Int[x^(m-1)/Sqrt[1-1/(a*x)^2],x]] /;
FreeQ[{a,m},x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Reference: CRC 474*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcSec[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*ArcSec[a+b*x]/(m+1) - 
  Dist[b/(m+1),Int[x^(m+1)/(Sqrt[1-1/(a+b*x)^2]*(a+b*x)^2),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*u ArcSec[c / (a+b x^n)]^m		Powers of arcsecants of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcSec[z] == ArcCos[1/z]*)


Int[u_.*ArcSec[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcCos[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*v ArcSec[u]				Products of expressions and arcsecants of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcSec[u_],x_Symbol] :=
  x*ArcSec[u] -
  Int[Regularize[x*D[u,x]/(u^2*Sqrt[1-1/u^2]),x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]


(* ::Subsection::Closed:: *)
(*Arccosecant Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ArcCsc[a+b x]^n			Powers of arcsecants of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.821.1, CRC 446', A&S 4.4.61'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCsc[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ArcCsc[a+b*x]/b +
  Int[1/((a+b*x)*Sqrt[1-1/(a+b*x)^2]),x] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m ArcCsc[a+b x]			Products of monomials and arccosecants of binomials*)


Int[ArcCsc[a_.*x_^n_.]/x_,x_Symbol] :=
(* Int[ArcSin[1/a*x^(-n)]/x,x] /; *)
  I*ArcCsc[a*x^n]^2/(2*n) - 
  ArcCsc[a*x^n]*Log[1-(I/(x^n*a)+Sqrt[1-1/(x^(2*n)*a^2)])^2]/n + 
  I*PolyLog[2,(I/(x^n*a)+Sqrt[1-1/(x^(2*n)*a^2)])^2]/(2*n) /;
(* -Sqrt[-1/a^2]*a*ArcCsc[a*x^n]^2/(2*n) - 
  ArcCsc[a*x^n]*Log[2*(1/(x^n*a^2) + Sqrt[-1/a^2]*Sqrt[1-1/(x^(2*n)*a^2)])/x^n]/n - 
  Sqrt[-1/a^2]*a*PolyLog[2, 1-2*(1/(x^n*a^2)+Sqrt[-1/a^2]*Sqrt[1-1/(x^(2*n)*a^2)])/x^n]/(2*n) /; *)
FreeQ[{a,n},x]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_.*ArcCsc[a_+b_.*x_],x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*ArcCsc[x],x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Reference: CRC 477*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCsc[a_.*x_],x_Symbol] :=
  x^(m+1)*ArcCsc[a*x]/(m+1) + 
  Dist[1/(a*(m+1)),Int[x^(m-1)/Sqrt[1-1/(a*x)^2],x]] /;
FreeQ[{a,m},x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Reference: CRC 477*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ArcCsc[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*ArcCsc[a+b*x]/(m+1) + 
  Dist[b/(m+1),Int[x^(m+1)/(Sqrt[1-1/(a+b*x)^2]*(a+b*x)^2),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*u ArcCsc[c / (a+b x^n)]			Inverse cosecant of reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCsc[z] == ArcSin[1/z]*)


Int[u_.*ArcCsc[c_./(a_.+b_.*x_^n_.)]^m_.,x_Symbol] :=
  Int[u*ArcSin[a/c+b*x^n/c]^m,x] /;
FreeQ[{a,b,c,n,m},x]


(* ::Subsubsection::Closed:: *)
(*v ArcCsc[u]				Products of expressions and arccosecants of inverse free functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ArcCsc[u_],x_Symbol] :=
  x*ArcCsc[u] +
  Int[Regularize[x*D[u,x]/(u^2*Sqrt[1-1/u^2]),x],x] /;
InverseFunctionFreeQ[u,x] && Not[MatchQ[u,c_.+d_.*f_^(a_.+b_.*x) /; FreeQ[{a,b,c,d,f},x]]]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/IntegralFunctionIntegrationRules.m0000644000175000017500000005415311446257035033655 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Integral Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Exponential Integral En Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ExpIntegralE[n,a+b x]			Exponential integral E function of linears*)


(* ::Item:: *)
(*Basis: D[ExpIntegralE[n,z],z] == -ExpIntegralE[n-1,z]*)


Int[ExpIntegralE[n_,a_.+b_.*x_],x_Symbol] :=
  -ExpIntegralE[n+1,a+b*x]/b /;
FreeQ[{a,b,n},x]


(* ::Subsubsection::Closed:: *)
(*x^m ExpIntegralE[n,a+b x]		Products of monomials and exponential integral E function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ExpIntegralE[n_,a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*ExpIntegralE[n,a+b*x]/(m+1) +
  Dist[b/(m+1),Int[x^(m+1)*ExpIntegralE[n-1,a+b*x],x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && n>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*ExpIntegralE[n_,a_.+b_.*x_],x_Symbol] :=
  -x^m*ExpIntegralE[n+1,a+b*x]/b +
  Dist[m/b,Int[x^(m-1)*ExpIntegralE[n+1,a+b*x],x]] /;
FreeQ[{a,b,m},x] && IntegerQ[n] && n<0


(* ::Subsection::Closed:: *)
(*Exponential Integral Ei Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ExpIntegralEi[a+b x]^n		Powers of exponential integral function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ExpIntegralEi[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*ExpIntegralEi[a+b*x]/b - E^(a+b*x)/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ExpIntegralEi[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*ExpIntegralEi[a+b*x]^2/b -
  Dist[2,Int[E^(a+b*x)*ExpIntegralEi[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m ExpIntegralEi[a+b x]^n		Products of monomials and powers of exponential integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ExpIntegralEi[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*ExpIntegralEi[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*E^(a+b*x)/(a+b*x),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ExpIntegralEi[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*ExpIntegralEi[b*x]^2/(m+1) -
  Dist[2/(m+1),Int[x^m*E^(b*x)*ExpIntegralEi[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[x_^m_.*ExpIntegralEi[a_+b_.*x_]^2,x_Symbol] :=
  x^(m+1)*ExpIntegralEi[a+b*x]^2/(m+1) +
  a*x^m*ExpIntegralEi[a+b*x]^2/(b*(m+1)) -
  Dist[2/(m+1),Int[x^m*E^(a+b*x)*ExpIntegralEi[a+b*x],x]] -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*ExpIntegralEi[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Int[x_^m_.*ExpIntegralEi[a_+b_.*x_]^2,x_Symbol] :=
  b*x^(m+2)*ExpIntegralEi[a+b*x]^2/(a*(m+1)) +
  x^(m+1)*ExpIntegralEi[a+b*x]^2/(m+1) -
  Dist[2*b/(a*(m+1)),Int[x^(m+1)*E^(a+b*x)*ExpIntegralEi[a+b*x],x]] -
  Dist[b*(m+2)/(a*(m+1)),Int[x^(m+1)*ExpIntegralEi[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-2 *)


(* ::Subsubsection::Closed:: *)
(*E^(a+b x) ExpIntegralEi[c+d x]	Products of exponential and exponential integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[E^(a_.+b_.*x_)*ExpIntegralEi[c_.+d_.*x_],x_Symbol] :=
  E^(a+b*x)*ExpIntegralEi[c+d*x]/b -
  Dist[d/b,Int[E^(a+b*x)*E^(c+d*x)/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m E^(a+b x) ExpIntegralEi[c+d x]	Products of monomials, exponential and exponential integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*E^(a_.+b_.*x_)*ExpIntegralEi[c_.+d_.*x_],x_Symbol] :=
  x^m*E^(a+b*x)*ExpIntegralEi[c+d*x]/b -
  Dist[d/b,Int[x^m*E^(a+b*x)*E^(c+d*x)/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*E^(a+b*x)*ExpIntegralEi[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*E^(a_.+b_.*x_)*ExpIntegralEi[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*E^(a+b*x)*ExpIntegralEi[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*E^(a+b*x)*E^(c+d*x)/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*E^(a+b*x)*ExpIntegralEi[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Sine Integral Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*SinIntegral[a+b x]^n			Powers of sine integral function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[SinIntegral[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*SinIntegral[a+b*x]/b + Cos[a+b*x]/b/;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[SinIntegral[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*SinIntegral[a+b*x]^2/b -
  Dist[2,Int[Sin[a+b*x]*SinIntegral[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m SinIntegral[a+b x]^n		Products of monomials and powers of sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*SinIntegral[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*SinIntegral[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Sin[a+b*x]/(a+b*x),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*SinIntegral[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*SinIntegral[b*x]^2/(m+1) -
  Dist[2/(m+1),Int[x^m*Sin[b*x]*SinIntegral[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[x_^m_.*SinIntegral[a_+b_.*x_]^2,x_Symbol] :=
  x^(m+1)*SinIntegral[a+b*x]^2/(m+1) +
  a*x^m*SinIntegral[a+b*x]^2/(b*(m+1)) -
  Dist[2/(m+1),Int[x^m*Sin[a+b*x]*SinIntegral[a+b*x],x]] -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*SinIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Int[x_^m_.*SinIntegral[a_+b_.*x_]^2,x_Symbol] :=
  b*x^(m+2)*SinIntegral[a+b*x]^2/(a*(m+1)) +
  x^(m+1)*SinIntegral[a+b*x]^2/(m+1) -
  Dist[2*b/(a*(m+1)),Int[x^(m+1)*Sin[a+b*x]*SinIntegral[a+b*x],x]] -
  Dist[b*(m+2)/(a*(m+1)),Int[x^(m+1)*SinIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-2 *)


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x] SinIntegral[c+d x]		Products of sine and sine integral functions*)


(* ::Item::Closed:: *)
(*Reference: G&R 5.32.2*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sin[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  -Cos[a+b*x]*SinIntegral[c+d*x]/b +
  Dist[d/b,Int[Cos[a+b*x]*Sin[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a+b x] SinIntegral[c+d x]	Products of monomials, sine and sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sin[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  -x^m*Cos[a+b*x]*SinIntegral[c+d*x]/b +
  Dist[d/b,Int[x^m*Cos[a+b*x]*Sin[c+d*x]/(c+d*x),x]] +
  Dist[m/b,Int[x^(m-1)*Cos[a+b*x]*SinIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sin[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Sin[a+b*x]*SinIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Sin[a+b*x]*Sin[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Cos[a+b*x]*SinIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x] SinIntegral[c+d x]		Products of cosine and sine integral functions*)


(* ::Item::Closed:: *)
(*Reference: G&R 5.32.1*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Cos[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  Sin[a+b*x]*SinIntegral[c+d*x]/b -
  Dist[d/b,Int[Sin[a+b*x]*Sin[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a+b x] SinIntegral[c+d x]	Products of monomials, cosine and sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Cos[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Sin[a+b*x]*SinIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Sin[a+b*x]*Sin[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Sin[a+b*x]*SinIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*Cos[a_.+b_.*x_]*SinIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Cos[a+b*x]*SinIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Cos[a+b*x]*Sin[c+d*x]/(c+d*x),x]] +
  Dist[b/(m+1),Int[x^(m+1)*Sin[a+b*x]*SinIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Cosine Integral Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*CosIntegral[a+b x]^n			Powers of cosine integral function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[CosIntegral[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*CosIntegral[a+b*x]/b - Sin[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[CosIntegral[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*CosIntegral[a+b*x]^2/b -
  Dist[2,Int[Cos[a+b*x]*CosIntegral[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m CosIntegral[a+b x]^n		Products of monomials and powers of cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*CosIntegral[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*CosIntegral[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Cos[a+b*x]/(a+b*x),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*CosIntegral[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*CosIntegral[b*x]^2/(m+1) -
  Dist[2/(m+1),Int[x^m*Cos[b*x]*CosIntegral[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[x_^m_.*CosIntegral[a_+b_.*x_]^2,x_Symbol] :=
  x^(m+1)*CosIntegral[a+b*x]^2/(m+1) +
  a*x^m*CosIntegral[a+b*x]^2/(b*(m+1)) -
  Dist[2/(m+1),Int[x^m*Cos[a+b*x]*CosIntegral[a+b*x],x]] -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*CosIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Int[x_^m_.*CosIntegral[a_+b_.*x_]^2,x_Symbol] :=
  b*x^(m+2)*CosIntegral[a+b*x]^2/(a*(m+1)) +
  x^(m+1)*CosIntegral[a+b*x]^2/(m+1) -
  Dist[2*b/(a*(m+1)),Int[x^(m+1)*Cos[a+b*x]*CosIntegral[a+b*x],x]] -
  Dist[b*(m+2)/(a*(m+1)),Int[x^(m+1)*CosIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-2 *)


(* ::Subsubsection::Closed:: *)
(*Sin[a+b x] CosIntegral[c+d x]		Products of sine and cosine integral functions*)


(* ::Item::Closed:: *)
(*Reference: G&R 5.31.2*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sin[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  -Cos[a+b*x]*CosIntegral[c+d*x]/b +
  Dist[d/b,Int[Cos[a+b*x]*Cos[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Sin[a+b x] CosIntegral[c+d x]	Products of monomials, sine and cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sin[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  -x^m*Cos[a+b*x]*CosIntegral[c+d*x]/b +
  Dist[d/b,Int[x^m*Cos[a+b*x]*Cos[c+d*x]/(c+d*x),x]] +
  Dist[m/b,Int[x^(m-1)*Cos[a+b*x]*CosIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sin[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Sin[a+b*x]*CosIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Sin[a+b*x]*Cos[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Cos[a+b*x]*CosIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*Cos[a+b x] CosIntegral[c+d x]	Products of cosine and cosine integral functions*)


(* ::Item::Closed:: *)
(*Reference: G&R 5.31.1*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Cos[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  Sin[a+b*x]*CosIntegral[c+d*x]/b -
  Dist[d/b,Int[Sin[a+b*x]*Cos[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Cos[a+b x] CosIntegral[c+d x]	Products of monomials, cosine and cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Cos[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Sin[a+b*x]*CosIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Sin[a+b*x]*Cos[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Sin[a+b*x]*CosIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*Cos[a_.+b_.*x_]*CosIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Cos[a+b*x]*CosIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Cos[a+b*x]*Cos[c+d*x]/(c+d*x),x]] +
  Dist[b/(m+1),Int[x^(m+1)*Sin[a+b*x]*CosIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Hyperbolic Sine Integral Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*SinhIntegral[a+b x]^n			Powers of hyperbolic sine integral function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[SinhIntegral[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*SinhIntegral[a+b*x]/b - Cosh[a+b*x]/b/;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[SinhIntegral[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*SinhIntegral[a+b*x]^2/b -
  Dist[2,Int[Sinh[a+b*x]*SinhIntegral[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m SinhIntegral[a+b x]^n		Products of monomials and powers of hyperbolic sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*SinhIntegral[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*SinhIntegral[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Sinh[a+b*x]/(a+b*x),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*SinhIntegral[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*SinhIntegral[b*x]^2/(m+1) -
  Dist[2/(m+1),Int[x^m*Sinh[b*x]*SinhIntegral[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[x_^m_.*SinhIntegral[a_+b_.*x_]^2,x_Symbol] :=
  x^(m+1)*SinhIntegral[a+b*x]^2/(m+1) +
  a*x^m*SinhIntegral[a+b*x]^2/(b*(m+1)) -
  Dist[2/(m+1),Int[x^m*Sinh[a+b*x]*SinhIntegral[a+b*x],x]] -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*SinhIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Int[x_^m_.*SinhIntegral[a_+b_.*x_]^2,x_Symbol] :=
  b*x^(m+2)*SinhIntegral[a+b*x]^2/(a*(m+1)) +
  x^(m+1)*SinhIntegral[a+b*x]^2/(m+1) -
  Dist[2*b/(a*(m+1)),Int[x^(m+1)*Sinh[a+b*x]*SinhIntegral[a+b*x],x]] -
  Dist[b*(m+2)/(a*(m+1)),Int[x^(m+1)*SinhIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-2 *)


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x] SinhIntegral[c+d x]	Products of hyperbolic sine and hyperbolic sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sinh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  Cosh[a+b*x]*SinhIntegral[c+d*x]/b -
  Dist[d/b,Int[Cosh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a+b x] SinhIntegral[c+d x]	Products of monomials, hyperbolic sine and hyperbolic sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sinh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Cosh[a+b*x]*SinhIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Cosh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Cosh[a+b*x]*SinhIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sinh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Sinh[a+b*x]*SinhIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Sinh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Cosh[a+b*x]*SinhIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x] SinhIntegral[c+d x]	Products of hyperbolic cosine and hyperbolic sine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Cosh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  Sinh[a+b*x]*SinhIntegral[c+d*x]/b -
  Dist[d/b,Int[Sinh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a+b x] SinhIntegral[c+d x]	Products of monomials, hyperbolic cosine and hyperbolic sine integrals*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Cosh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Sinh[a+b*x]*SinhIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Sinh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Sinh[a+b*x]*SinhIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*Cosh[a_.+b_.*x_]*SinhIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Cosh[a+b*x]*SinhIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Cosh[a+b*x]*Sinh[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Sinh[a+b*x]*SinhIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Hyperbolic Cosine Integral Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*CoshIntegral[a+b x]^n		Powers of hyperbolic cosine integral function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[CoshIntegral[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*CoshIntegral[a+b*x]/b - Sinh[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[CoshIntegral[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*CoshIntegral[a+b*x]^2/b -
  Dist[2,Int[Cosh[a+b*x]*CoshIntegral[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m CoshIntegral[a+b x]^n		Products of monomials and powers of hyperbolic cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*CoshIntegral[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*CoshIntegral[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Cosh[a+b*x]/(a+b*x),x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*CoshIntegral[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*CoshIntegral[b*x]^2/(m+1) -
  Dist[2/(m+1),Int[x^m*Cosh[b*x]*CoshIntegral[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Iterated integration by parts*)


Int[x_^m_.*CoshIntegral[a_+b_.*x_]^2,x_Symbol] :=
  x^(m+1)*CoshIntegral[a+b*x]^2/(m+1) +
  a*x^m*CoshIntegral[a+b*x]^2/(b*(m+1)) -
  Dist[2/(m+1),Int[x^m*Cosh[a+b*x]*CoshIntegral[a+b*x],x]] -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*CoshIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Int[x_^m_.*CoshIntegral[a_+b_.*x_]^2,x_Symbol] :=
  b*x^(m+2)*CoshIntegral[a+b*x]^2/(a*(m+1)) +
  x^(m+1)*CoshIntegral[a+b*x]^2/(m+1) -
  Dist[2*b/(a*(m+1)),Int[x^(m+1)*Cosh[a+b*x]*CoshIntegral[a+b*x],x]] -
  Dist[b*(m+2)/(a*(m+1)),Int[x^(m+1)*CoshIntegral[a+b*x]^2,x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m<-2 *)


(* ::Subsubsection::Closed:: *)
(*Sinh[a+b x] CoshIntegral[c+d x]	Products of hyperbolic sine and hyperbolic cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Sinh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  Cosh[a+b*x]*CoshIntegral[c+d*x]/b -
  Dist[d/b,Int[Cosh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Sinh[a+b x] CoshIntegral[c+d x]	Products of monomials, hyperbolic sine and hyperbolic cosine integrals*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Sinh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Cosh[a+b*x]*CoshIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Cosh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Cosh[a+b*x]*CoshIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sinh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Sinh[a+b*x]*CoshIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Sinh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Cosh[a+b*x]*CoshIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*Cosh[a+b x] CoshIntegral[c+d x]	Products of hyperbolic sine and hyperbolic cosine integral functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Cosh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  Sinh[a+b*x]*CoshIntegral[c+d*x]/b -
  Dist[d/b,Int[Sinh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] /;
FreeQ[{a,b,c,d},x]


(* ::Subsubsection::Closed:: *)
(*x^m Cosh[a+b x] CoshIntegral[c+d x]Products of monomials, hyperbolic cosine and hyperbolic cosine integrals*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Cosh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  x^m*Sinh[a+b*x]*CoshIntegral[c+d*x]/b -
  Dist[d/b,Int[x^m*Sinh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] -
  Dist[m/b,Int[x^(m-1)*Sinh[a+b*x]*CoshIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*Cosh[a_.+b_.*x_]*CoshIntegral[c_.+d_.*x_],x_Symbol] :=
  x^(m+1)*Cosh[a+b*x]*CoshIntegral[c+d*x]/(m+1) -
  Dist[d/(m+1),Int[x^(m+1)*Cosh[a+b*x]*Cosh[c+d*x]/(c+d*x),x]] -
  Dist[b/(m+1),Int[x^(m+1)*Sinh[a+b*x]*CoshIntegral[c+d*x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Logarithmic Integral Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*LogIntegral[a+b x]^n			Powers of log integral of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[LogIntegral[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*LogIntegral[a+b*x]/b - ExpIntegralEi[2*Log[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m LogIntegral[a+b x]		Products of monomials and log integral of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*LogIntegral[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*LogIntegral[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)/Log[a+b*x],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]
././@LongLink0000000000000000000000000000014700000000000011567 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/ExponentialFunctionIntegrationRules.mmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/ExponentialFunctionIntegrationRules0000644000175000017500000004416711446257035034147 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Exponential Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*f^(a+b x^n)				Products of monomials and exponentials of binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.311, CRC 519, A&S 4.2.54*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[E^x,x] == E^x*)


Int[E^(a_.+b_.*x_),x_Symbol] :=
  E^(a+b*x)/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.311, CRC 519, A&S 4.2.54*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[E^x,x] == E^x*)


Int[f_^(a_.+b_.*x_),x_Symbol] :=
  f^(a+b*x)/(b*Log[f]) /;
FreeQ[{a,b,f},x]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Erfi'[z] == 2*E^(z^2)/Sqrt[Pi]*)


Int[E^(a_.+b_.*x_^2),x_Symbol] :=
  E^a*Sqrt[Pi]*Erfi[x*Rt[b,2]]/(2*Rt[b,2]) /;
FreeQ[{a,b},x] && PosQ[b]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Erfi'[z] == 2*E^(z^2)/Sqrt[Pi]*)


Int[f_^(a_.+b_.*x_^2),x_Symbol] :=
  f^a*Sqrt[Pi]*Erfi[x*Rt[b*Log[f],2]]/(2*Rt[b*Log[f],2]) /;
FreeQ[{a,b,f},x] && PosQ[b*Log[f]]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Erf'[z] == 2*E^(-z^2)/Sqrt[Pi]*)


Int[E^(a_.+b_.*x_^2),x_Symbol] :=
  E^a*Sqrt[Pi]*Erf[x*Rt[-b,2]]/(2*Rt[-b,2]) /;
FreeQ[{a,b},x] && NegQ[b]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: Erf'[z] == 2*E^(-z^2)/Sqrt[Pi]*)


Int[f_^(a_.+b_.*x_^2),x_Symbol] :=
  f^a*Sqrt[Pi]*Erf[x*Rt[-b*Log[f],2]]/(2*Rt[-b*Log[f],2]) /;
FreeQ[{a,b,f},x] && NegQ[b*Log[f]]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[Gamma[n,x],x] == -E^(-x)*x^(n-1)*)


Int[E^(a_.+b_.*x_^n_),x_Symbol] :=
  -E^a*x*Gamma[1/n,-b*x^n]/(n*(-b*x^n)^(1/n)) /;
FreeQ[{a,b,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[Gamma[n,x],x] == -E^(-x)*x^(n-1)*)


Int[f_^(a_.+b_.*x_^n_),x_Symbol] :=
  -f^a*x*Gamma[1/n,-b*x^n*Log[f]]/(n*(-b*x^n*Log[f])^(1/n)) /;
FreeQ[{a,b,f,n},x] && Not[FractionOrNegativeQ[n]]


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one,rules for 
	improper binomials rectify it. *)
Int[E^(a_.+b_.*x_^n_.),x_Symbol] :=
  x*E^(a+b*x^n) - 
  Dist[b*n,Int[x^n*E^(a+b*x^n),x]] /;
FreeQ[{a,b},x] && IntegerQ[n] && n<0


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Note: Although resulting integrand looks more complicated than original one,rules for 
	improper binomials rectify it. *)
Int[f_^(a_.+b_.*x_^n_.),x_Symbol] :=
  x*f^(a+b*x^n) - 
  Dist[b*n*Log[f],Int[x^n*f^(a+b*x^n),x]] /;
FreeQ[{a,b,f},x] && IntegerQ[n] && n<0


(* ::Subsection::Closed:: *)
(*x^m f^(a+b x^n)			Products of monomials and exponentials of binomials*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ExpIntegralEi'[z] == E^z/z*)


Int[E^(a_.+b_.*x_^n_.)/x_,x_Symbol] :=
  E^a*ExpIntegralEi[b*x^n]/n /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ExpIntegralEi'[z] == E^z/z*)


Int[f_^(a_.+b_.*x_^n_.)/x_,x_Symbol] :=
  f^a*ExpIntegralEi[b*x^n*Log[f]]/n /;
FreeQ[{a,b,f,n},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.321.1, CRC 521, A&S 4.2.55*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m*f^(a+b*x^n) == x^(m-n+1)*(f^(a+b*x^n)*x^(n-1))*)


Int[x_^m_.*f_^(a_.+b_.*x_^n_.),x_Symbol] :=
  x^(m-n+1)*f^(a+b*x^n)/(b*n*Log[f]) -
  Dist[(m-n+1)/(b*n*Log[f]),Int[x^(m-n)*f^(a+b*x^n),x]] /;
FreeQ[{a,b,f},x] && IntegerQ[n] && RationalQ[m] && 00 && m<-1 || 0<-n<=m+1)


Int[x_^m_.*f_^(a_.+b_.*x_^n_.),x_Symbol] :=
  -f^a*x^(m+1)*Gamma[(m+1)/n,-b*x^n*Log[f]]/(n*(-b*x^n*Log[f])^((m+1)/n)) /;
FreeQ[{a,b,f,m,n},x] &&
  NonzeroQ[m+1] &&
  NonzeroQ[m-n+1] &&
  Not[m===-1/2 && ZeroQ[n-1]] &&
  Not[IntegerQ[{m,n}] && n>0 && (m<-1 || m>=n)] &&
  Not[RationalQ[{m,n}] && (FractionQ[m] || FractionOrNegativeQ[n])]


(* ::Subsection::Closed:: *)
(*f^(a+b x+c x^2)			Exponentials of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*x+c*x^2 == (b+2*c*x)^2/(4*c)*)


Int[f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  Int[f^((b+2*c*x)^2/(4*c)),x] /;
FreeQ[{a,b,c,f},x] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: a+b*x+c*x^2 == (b+2*c*x)^2/(4*c) - (b^2-4*a*c)/(4*c)*)


(* ::Item:: *)
(*Basis: f^(z-w) == f^z/f^w*)


Int[f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  f^(a-b^2/(4*c))*Int[f^((b+2*c*x)^2/(4*c)),x] /;
FreeQ[{a,b,c,f},x]


(* ::Subsection::Closed:: *)
(*(d+e x)^m f^(a+b x+c x^2)		Products of linears and exponentials of quadratic trinomials*)
(**)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


(* Note: This rule unnecessary because derivative of quadratic divides linear factor. *)
(* Int[(d_.+e_.*x_)*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*f^(a+b*x+c*x^2)/(2*c*Log[f]) /;
FreeQ[{a,b,c,d,e,f},x] && ZeroQ[b*e-2*c*d] *)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[(d_.+e_.*x_)*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*f^(a+b*x+c*x^2)/(2*c*Log[f]) -
  Dist[(b*e-2*c*d)/(2*c),Int[f^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e,f},x] && NonzeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[(d_.+e_.*x_)^m_*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*(d+e*x)^(m-1)*f^(a+b*x+c*x^2)/(2*c*Log[f]) -
  Dist[(m-1)*e^2/(2*c*Log[f]),Int[(d+e*x)^(m-2)*f^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e,f},x] && RationalQ[m] && m>1 && ZeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[(d_.+e_.*x_)^m_*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*(d+e*x)^(m-1)*f^(a+b*x+c*x^2)/(2*c*Log[f]) -
  Dist[(b*e-2*c*d)/(2*c),Int[(d+e*x)^(m-1)*f^(a+b*x+c*x^2),x]] -
  Dist[(m-1)*e^2/(2*c*Log[f]),Int[(d+e*x)^(m-2)*f^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e,f},x] && RationalQ[m] && m>1 && NonzeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(d_.+e_.*x_)^m_*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  (d+e*x)^(m+1)*f^(a+b*x+c*x^2)/(e*(m+1)) -
  Dist[2*c*Log[f]/(e^2*(m+1)),Int[(d+e*x)^(m+2)*f^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e,f},x] && RationalQ[m] && m<-1 && ZeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(d_.+e_.*x_)^m_*f_^(a_.+b_.*x_+c_.*x_^2),x_Symbol] :=
  (d+e*x)^(m+1)*f^(a+b*x+c*x^2)/(e*(m+1)) -
  Dist[(b*e-2*c*d)*Log[f]/(e^2*(m+1)),Int[(d+e*x)^(m+1)*f^(a+b*x+c*x^2),x]] -
  Dist[2*c*Log[f]/(e^2*(m+1)),Int[(d+e*x)^(m+2)*f^(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e,f},x] && RationalQ[m] && m<-1 && NonzeroQ[b*e-2*c*d]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(a_.+b_.*x_)^m_*f_^((c_.+d_.*x_)^n_.),x_Symbol] :=
  (a+b*x)^(m+1)*f^((c+d*x)^n)/(b*(m+1)) -
  Dist[d*n*Log[f]/(b*(m+1)),Int[(a+b*x)^(m+1)*f^((c+d*x)^n)*(c+d*x)^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && RationalQ[m] && m<-1 && IntegerQ[n] && n>1


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* Int[(a_.+b_.*x_)^m_*f_^u_,x_Symbol] :=
  (a+b*x)^(m+1)*f^u/(b*(m+1)) -
  Dist[Log[f]/(b*(m+1)),Int[(a+b*x)^(m+1)*f^u*D[u,x],x]] /;
FreeQ[{a,b},x] && PolynomialQ[u,x] && Exponent[u,x]>1 && RationalQ[m] && m<-1 *)


(* ::Subsection::Closed:: *)
(*(a+b f^(c+d x))^n			Powers of linear exponentials of linear binomials*)


(* ::Item:: *)
(*Reference: CRC 256*)


Int[1/(a_+b_.*f_^(c_.+d_.*x_)),x_Symbol] :=
  -Log[b+a*f^(-c-d*x)]/(a*d*Log[f]) /;
FreeQ[{a,b,c,d,f},x] && NegativeCoefficientQ[d]


(* ::Item:: *)
(*Reference: CRC 256*)


Int[1/(a_+b_.*f_^(c_.+d_.*x_)),x_Symbol] :=
  x/a-Log[a+b*f^(c+d*x)]/(a*d*Log[f]) /;
FreeQ[{a,b,c,d,f},x]


Int[1/Sqrt[a_+b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  -2*ArcTanh[Sqrt[a+b*f^(c+d*x)]/Sqrt[a]]/(Sqrt[a]*d*Log[f]) /;
FreeQ[{a,b,c,d,f},x] && PosQ[a]


Int[1/Sqrt[a_+b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  2*ArcTan[Sqrt[a+b*f^(c+d*x)]/Sqrt[-a]]/(Sqrt[-a]*d*Log[f]) /;
FreeQ[{a,b,c,d,f},x] && NegQ[a]


Int[(a_+b_.*f_^(c_.+d_.*x_))^n_,x_Symbol] :=
  (a+b*f^(c+d*x))^n/(n*d*Log[f]) + 
  Dist[a,Int[(a+b*f^(c+d*x))^(n-1),x]] /;
FreeQ[{a,b,c,d,f},x] && FractionQ[n] && n>0


Int[(a_+b_.*f_^(c_.+d_.*x_))^n_,x_Symbol] :=
  -(a+b*f^(c+d*x))^(n+1)/((n+1)*a*d*Log[f]) + 
  Dist[1/a,Int[(a+b*f^(c+d*x))^(n+1),x]] /;
FreeQ[{a,b,c,d,f},x] && RationalQ[n] && n<-1


(* ::Subsection::Closed:: *)
(*x^m (a+b f^(c+d x))^n		Products of monomials and powers of linear exponentials of linear binomials*)
(**)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*z) == 1/a - b/a*z/(a+b*z)*)


Int[x_^m_./(a_+b_.*f_^(c_.+d_.*x_)), x_Symbol] :=
  x^(m+1)/(a*(m+1)) -
  Dist[b/a,Int[x^m*f^(c+d*x)/(a+b*f^(c+d*x)),x]] /;
FreeQ[{a,b,c,d,f},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*(a_+b_.*f_^(c_.+d_.*x_))^n_, x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[(a+b*f^(c+d*x))^n,x]]},
  x^m*u - Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d,f},x] && RationalQ[{m,n}] && m>0 && n<-1


(* ::Subsection::Closed:: *)
(*x^m f^(c (a+b x)^n)			Products of linears and exponentials of powers of linears*)


(* Yikes!!! Need to do something likes this for trig and hyperbolic too.Ug! *)


Int[x_^m_*f_^(c_.*(a_+b_.*x_)^2),x_Symbol] :=
  Int[x^m*f^(a^2*c+2*a*b*c*x+b^2*c*x^2),x] /;
FreeQ[{a,b,c,f},x] && FractionQ[m] && m>1


Int[x_^m_.*f_^(c_.*(a_+b_.*x_)^n_),x_Symbol] :=
  Dist[1/b^m,Int[Expand[b^m*x^m-(a+b*x)^m,x]*f^(c*(a+b*x)^n),x]] +
  Dist[1/b^(m+1),Subst[Int[x^m*f^(c*x^n),x],x,a+b*x]] /;
FreeQ[{a,b,c,f,n},x] && IntegerQ[m] && m>0


(* ::Subsection::Closed:: *)
(*x^m f^(c+d x)/(a+b f^(c+d x))	Products of monomials and linear exponentials of linear binomials*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*f_^(c_.+d_.*x_)/(a_+b_.*f_^(c_.+d_.*x_)), x_Symbol] :=
  x^m*Log[1+b*f^(c+d*x)/a]/(b*d*Log[f]) -
  Dist[m/(b*d*Log[f]),Int[x^(m-1)*Log[1+b/a*f^(c+d*x)],x]] /;
FreeQ[{a,b,c,d,f},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*f_^(c_.+d_.*x_)/(a_.+b_.*f_^v_),x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[f^(c+d*x)/(a+b*f^v),x]]},
  x^m*u - Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d,f},x] && ZeroQ[2*(c+d*x)-v] && RationalQ[m] && m>0


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_./(a_.*f_^(c_.+d_.*x_)+b_.*f_^v_),x_Symbol] :=
  Module[{u=Block[{ShowSteps=False,StepCounter=Null}, Int[1/(a*f^(c+d*x)+b*f^v),x]]},
  x^m*u - Dist[m,Int[x^(m-1)*u,x]]] /;
FreeQ[{a,b,c,d,f},x] && ZeroQ[(c+d*x)+v] && RationalQ[m] && m>0


(* ::Item::Closed:: *)
(*Note: The remaining inverse function integration rules in this section are required to integrate the expressions generated by the above rules.*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[1+c_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  -PolyLog[2,-c*f^(a+b*x)]/(b*Log[f]) /;
FreeQ[{a,b,c,f},x]


(* ::Item:: *)
(*Basis: D[Log[c+d*g[x]],x] == D[Log[1+d/c*g[x]],x]*)


Int[Log[c_+d_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  x*Log[c+d*f^(a+b*x)] - x*Log[1+d/c*f^(a+b*x)] +
  Int[Log[1+d/c*f^(a+b*x)],x] /;
FreeQ[{a,b,c,d,f},x] && NonzeroQ[c-1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Log[1+c_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  -x^m*PolyLog[2,-c*f^(a+b*x)]/(b*Log[f]) +
  Dist[m/(b*Log[f]),Int[x^(m-1)*PolyLog[2,-c*f^(a+b*x)],x]] /;
FreeQ[{a,b,c,f},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Basis: D[Log[c+d*g[x]],x] == D[Log[1+d/c*g[x]],x]*)


Int[x_^m_.*Log[c_+d_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  x^(m+1)*Log[c+d*f^(a+b*x)]/(m+1) - x^(m+1)*Log[1+d/c*f^(a+b*x)]/(m+1) +
  Int[x^m*Log[1+d/c*f^(a+b*x)],x] /;
FreeQ[{a,b,c,d,f},x] && NonzeroQ[c-1] && RationalQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[PolyLog[n,z],z] == PolyLog[n-1,z]/z*)


Int[PolyLog[n_,c_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  PolyLog[n+1,c*f^(a+b*x)]/(b*Log[f]) /;
FreeQ[{a,b,c,n},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*PolyLog[n_,c_.*f_^(a_.+b_.*x_)],x_Symbol] :=
  x^m*PolyLog[n+1,c*f^(a+b*x)]/(b*Log[f]) -
  Dist[m/(b*Log[f]),Int[x^(m-1)*PolyLog[n+1,c*f^(a+b*x)],x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTanh[z] == 1/2*Log[1+z] - 1/2*Log[1-z]*)


Int[ArcTanh[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[1/2,Int[Log[1+b*f^(c+d*x)],x]] -
  Dist[1/2,Int[Log[1-b*f^(c+d*x)],x]] /;
FreeQ[{b,c,d,f},x] 


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTanh[z] == 1/2*Log[1+z] - 1/2*Log[1-z]*)


Int[x_^m_.*ArcTanh[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[1/2,Int[x^m*Log[1+b*f^(c+d*x)],x]] -
  Dist[1/2,Int[x^m*Log[1-b*f^(c+d*x)],x]] /;
FreeQ[{b,c,d,f},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCoth[z] == 1/2*Log[1+1/z] - 1/2*Log[1-1/z]*)


Int[ArcCoth[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[1/2,Int[Log[1+1/(b*f^(c+d*x))],x]] -
  Dist[1/2,Int[Log[1-1/(b*f^(c+d*x))],x]] /;
FreeQ[{b,c,d,f},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCoth[z] == 1/2*Log[1+1/z] - 1/2*Log[1-1/z]*)


Int[x_^m_.*ArcCoth[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[1/2,Int[x^m*Log[1+1/(b*f^(c+d*x))],x]] -
  Dist[1/2,Int[x^m*Log[1-1/(b*f^(c+d*x))],x]] /;
FreeQ[{b,c,d,f},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTan[z] == I/2*Log[1-I*z] - I/2*Log[1+I*z]*)


Int[ArcTan[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[I/2,Int[Log[1-b*I*f^(c+d*x)],x]] -
  Dist[I/2,Int[Log[1+b*I*f^(c+d*x)],x]] /;
FreeQ[{b,c,d,f},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcTan[z] == I/2*Log[1-I*z] - I/2*Log[1+I*z]*)


Int[x_^m_.*ArcTan[a_.+b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[I/2,Int[x^m*Log[1-a*I-b*I*f^(c+d*x)],x]] -
  Dist[I/2,Int[x^m*Log[1+a*I+b*I*f^(c+d*x)],x]] /;
FreeQ[{a,b,c,d,f},x] && IntegerQ[m] && m>0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCot[z] == I/2*Log[1-I/z] - I/2*Log[1+I/z]*)


Int[ArcCot[b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[I/2,Int[Log[1-I/(b*f^(c+d*x))],x]] -
  Dist[I/2,Int[Log[1+I/(b*f^(c+d*x))],x]] /;
FreeQ[{b,c,d,f},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: ArcCot[z] == I/2*Log[1-I/z] - I/2*Log[1+I/z]*)


Int[x_^m_.*ArcCot[a_.+b_.*f_^(c_.+d_.*x_)],x_Symbol] :=
  Dist[I/2,Int[x^m*Log[1-I/(a+b*f^(c+d*x))],x]] -
  Dist[I/2,Int[x^m*Log[1+I/(a+b*f^(c+d*x))],x]] /;
FreeQ[{a,b,c,d,f},x] && IntegerQ[m] && m>0


(* ::Subsection::Closed:: *)
(*(a+b x)^m f^(e (c+d x)^n)		Products of linears and exponentials of powers of linears*)


If[ShowSteps,

Int[(a_.+b_.*x_)^m_.*(f_^(e_.*(c_.+d_.*x_)^n_.))^p_.,x_Symbol] :=
  ShowStep["","Int[(a+b*x)^m*f[x],x]","Subst[Int[x^m*f[-a/b+x/b],x],x,a+b*x]/b",Hold[
  Dist[1/b,Subst[Int[x^m*(f^(e*(c-a*d/b+d*x/b)^n))^p,x],x,a+b*x]]]] /;
SimplifyFlag && FreeQ[{a,b,c,d,e,f,m,n},x] && RationalQ[p] && Not[a===0 && b===1],

Int[(a_.+b_.*x_)^m_.*(f_^(e_.*(c_.+d_.*x_)^n_.))^p_.,x_Symbol] :=
  Dist[1/b,Subst[Int[x^m*(f^(e*(c-a*d/b+d*x/b)^n))^p,x],x,a+b*x]] /;
FreeQ[{a,b,c,d,e,f,m,n},x] && RationalQ[p] && Not[a===0 && b===1]]


(* ::Subsection::Closed:: *)
(*f^((a+b x^4)/x^2)			Exponentials of quotients of binomials and monomials*)


Int[f_^((a_.+b_.*x_^4)/x_^2),x_Symbol] :=
  Sqrt[Pi]*Exp[2*Sqrt[-a*Log[f]]*Sqrt[-b*Log[f]]]*Erf[(Sqrt[-a*Log[f]]+Sqrt[-b*Log[f]]*x^2)/x]/
    (4*Sqrt[-b*Log[f]]) -
  Sqrt[Pi]*Exp[-2*Sqrt[-a*Log[f]]*Sqrt[-b*Log[f]]]*Erf[(Sqrt[-a*Log[f]]-Sqrt[-b*Log[f]]*x^2)/x]/
    (4*Sqrt[-b*Log[f]]) /;
FreeQ[{a,b,f},x]


(* ::Subsection::Closed:: *)
(*u / (a+b f^(d+e x)+c f^(g+h x))	Quotients by quadratic trinomial exponentials of linears*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*f^z+c*f^(2*z)) == 1/a - f^z*(b+c*f^z)/(a*(a+b*f^z+c*f^(2*z)))*)


Int[1/(a_+b_.*f_^u_+c_.*f_^v_), x_Symbol] :=
  x/a -
  Dist[1/a,Int[f^u*(b+c*f^u)/(a+b*f^u+c*f^v),x]] /;
FreeQ[{a,b,c,f},x] && LinearQ[u,x] && LinearQ[v,x] && ZeroQ[2*u-v] &&
Not[RationalQ[Rt[b^2-4*a*c,2]]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (d+e*f^z)/(a+b*f^z+c*f^(2*z)) == d/a - f^z*(b*d-a*e+c*d*f^z)/(a*(a+b*f^z+c*f^(2*z)))*)


Int[(d_+e_.*f_^u_)/(a_+b_.*f_^u_+c_.*f_^v_), x_Symbol] :=
  d*x/a -
  Dist[1/a,Int[f^u*(b*d-a*e+c*d*f^u)/(a+b*f^u+c*f^v),x]] /;
FreeQ[{a,b,c,d,e,f},x] && LinearQ[u,x] && LinearQ[v,x] && ZeroQ[2*u-v] &&
Not[RationalQ[Rt[b^2-4*a*c,2]]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1/(a+b*z+c/z) == z/(c+a*z+b*z^2)*)


Int[u_/(a_+b_.*f_^v_+c_.*f_^w_), x_Symbol] :=
  Int[u*f^v/(c+a*f^v+b*f^(2*v)),x] /;
FreeQ[{a,b,c,f},x] && LinearQ[v,x] && LinearQ[w,x] && ZeroQ[v+w] &&
If[RationalQ[Coefficient[v,x,1]], Coefficient[v,x,1]>0, LeafCount[v]0 && NonzeroQ[n+1]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/ErrorFunctionIntegrationRules.m0000644000175000017500000003753611446257035033207 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Error and Fresnel Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Error Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Erf[a+b x]^n				Powers of error function of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 5.41*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erf[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*Erf[a+b*x]/b + 1/(b*Sqrt[Pi]*Exp[(a+b*x)^2]) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erf[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*Erf[a+b*x]^2/b -
  Dist[4/Sqrt[Pi],Int[(a+b*x)*Erf[a+b*x]/E^(a+b*x)^2,x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m Erf[a+b x]^n			Products of monomials and powers of error functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erf[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*Erf[a+b*x]/(m+1) -
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)/Exp[(a+b*x)^2],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erf[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*Erf[b*x]^2/(m+1) -
  Dist[4*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(-b^2*x^2)*Erf[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m+1!=0 && (m>0 || OddQ[m])


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x, a+b*x], x] == Subst[Int[f[-a/b+x/b, x], x], x, a+b*x]/b*)


Int[x_^m_.*Erf[a_+b_.*x_]^2,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*Erf[x]^2,x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*x^m E^(-b^2 x^2) Erf[b x]		Products of monomials, exponentials and error functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*E^(c_.*x_^2)*Erf[b_.*x_],x_Symbol] :=
  -E^(-b^2*x^2)*Erf[b*x]/(2*b^2) +
  Dist[1/(b*Sqrt[Pi]),Int[E^(-2*b^2*x^2),x]] /;
FreeQ[{b,c},x] && c===-b^2


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erf[b_.*x_],x_Symbol] :=
  -x^(m-1)*E^(-b^2*x^2)*Erf[b*x]/(2*b^2) +
  Dist[1/(b*Sqrt[Pi]),Int[x^(m-1)*E^(-2*b^2*x^2),x]] +
  Dist[(m-1)/(2*b^2),Int[x^(m-2)*E^(-b^2*x^2)*Erf[b*x],x]] /;
FreeQ[{b,c},x] && c===-b^2 && IntegerQ[m] && m>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erf[b_.*x_],x_Symbol] :=
  x^(m+1)*E^(-b^2*x^2)*Erf[b*x]/(m+1) -
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(-2*b^2*x^2),x]] +
  Dist[2*b^2/(m+1),Int[x^(m+2)*E^(-b^2*x^2)*Erf[b*x],x]] /;
FreeQ[{b,c},x] && c===-b^2 && EvenQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Complementary Error Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Erfc[a+b x]^n				Powers of complementary error function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erfc[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*Erfc[a+b*x]/b - 1/(b*Sqrt[Pi]*Exp[(a+b*x)^2]) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erfc[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*Erfc[a+b*x]^2/b +
  Dist[4/Sqrt[Pi],Int[(a+b*x)*Erfc[a+b*x]/E^(a+b*x)^2,x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m Erfc[ a+b x]^n			Products of monomials and powers of complementary error function*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erfc[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*Erfc[a+b*x]/(m+1) +
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)/Exp[(a+b*x)^2],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erfc[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*Erfc[b*x]^2/(m+1) +
  Dist[4*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(-b^2*x^2)*Erfc[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m+1!=0 && (m>0 || OddQ[m])


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x, a+b*x], x] == Subst[Int[f[-a/b+x/b, x], x], x, a+b*x]/b*)


Int[x_^m_.*Erfc[a_+b_.*x_]^2,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*Erfc[x]^2,x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*x^m E^(-b^2 x^2) Erfc[b x]		Products of monomials, exponentials and complementary error functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*E^(c_.*x_^2)*Erfc[b_.*x_],x_Symbol] :=
  -E^(-b^2*x^2)*Erfc[b*x]/(2*b^2) -
  Dist[1/(b*Sqrt[Pi]),Int[E^(-2*b^2*x^2),x]] /;
FreeQ[{b,c},x] && c===-b^2


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erfc[b_.*x_],x_Symbol] :=
  -x^(m-1)*E^(-b^2*x^2)*Erfc[b*x]/(2*b^2) -
  Dist[1/(b*Sqrt[Pi]),Int[x^(m-1)*E^(-2*b^2*x^2),x]] +
  Dist[(m-1)/(2*b^2),Int[x^(m-2)*E^(-b^2*x^2)*Erfc[b*x],x]] /;
FreeQ[{b,c},x] && c===-b^2 && IntegerQ[m] && m>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erfc[b_.*x_],x_Symbol] :=
  x^(m+1)*E^(-b^2*x^2)*Erfc[b*x]/(m+1) +
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(-2*b^2*x^2),x]] +
  Dist[2*b^2/(m+1),Int[x^(m+2)*E^(-b^2*x^2)*Erfc[b*x],x]] /;
FreeQ[{b,c},x] && c===-b^2 && EvenQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Imaginary Error Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Erfi[a+b x]^n				Powers of imaginary error function of linears*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erfi[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*Erfi[a+b*x]/b - Exp[(a+b*x)^2]/(b*Sqrt[Pi]) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Erfi[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*Erfi[a+b*x]^2/b -
  Dist[4/Sqrt[Pi],Int[(a+b*x)*E^(a+b*x)^2*Erfi[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m Erfi[a+b x]^n			Products of monomials and powers of imaginary error functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erfi[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*Erfi[a+b*x]/(m+1) -
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*Exp[(a+b*x)^2],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Erfi[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*Erfi[b*x]^2/(m+1) -
  Dist[4*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(b^2*x^2)*Erfi[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m+1!=0 && (m>0 || OddQ[m])


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x, a+b*x], x] == Subst[Int[f[-a/b+x/b, x], x], x, a+b*x]/b*)


Int[x_^m_.*Erfi[a_+b_.*x_]^2,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*Erfi[x]^2,x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*x^m E^(b^2 x^2) Erfi[b x]		Products of monomials, exponentials and imaginary error functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*E^(c_.*x_^2)*Erfi[b_.*x_],x_Symbol] :=
  E^(b^2*x^2)*Erfi[b*x]/(2*b^2) -
  Dist[1/(b*Sqrt[Pi]),Int[E^(2*b^2*x^2),x]] /;
FreeQ[{b,c},x] && c===b^2


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erfi[b_.*x_],x_Symbol] :=
  x^(m-1)*E^(b^2*x^2)*Erfi[b*x]/(2*b^2) -
  Dist[1/(b*Sqrt[Pi]),Int[x^(m-1)*E^(2*b^2*x^2),x]] -
  Dist[(m-1)/(2*b^2),Int[x^(m-2)*E^(b^2*x^2)*Erfi[b*x],x]] /;
FreeQ[{b,c},x] && c===b^2 && IntegerQ[m] && m>1


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*E^(c_.*x_^2)*Erfi[b_.*x_],x_Symbol] :=
  x^(m+1)*E^(b^2*x^2)*Erfi[b*x]/(m+1) -
  Dist[2*b/(Sqrt[Pi]*(m+1)),Int[x^(m+1)*E^(2*b^2*x^2),x]] -
  Dist[2*b^2/(m+1),Int[x^(m+2)*E^(b^2*x^2)*Erfi[b*x],x]] /;
FreeQ[{b,c},x] && c===b^2 && EvenQ[m] && m<-1


(* ::Subsection::Closed:: *)
(*Fresnel Integral S Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*FresnelS[a+b x]^n				Powers of Fresnel integral S functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[FresnelS[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*FresnelS[a+b*x]/b + Cos[Pi/2*(a+b*x)^2]/(b*Pi) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[FresnelS[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*FresnelS[a+b*x]^2/b -
  Dist[2,Int[(a+b*x)*Sin[Pi/2*(a+b*x)^2]*FresnelS[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m FresnelS[a+b x]^n			Products of monomials and powers of Fresnel integral S functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*FresnelS[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*FresnelS[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Sin[Pi/2*(a+b*x)^2],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Note: Also apply rule when m mod 4 = 1 when a closed-form antiderivative is defined for Cos[Pi/2*x^2]*FresnelS[x].*)


Int[x_^m_*FresnelS[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*FresnelS[b*x]^2/(m+1) -
  Dist[2*b/(m+1),Int[x^(m+1)*Sin[Pi/2*b^2*x^2]*FresnelS[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m+1!=0 && (m>0 && EvenQ[m] || Mod[m,4]==3)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x, a+b*x], x] == Subst[Int[f[-a/b+x/b, x], x], x, a+b*x]/b*)


(* ::Item:: *)
(*Note: Rule not necessary until a closed-form antiderivative is defined for Cos[Pi/2*x^2]*FresnelS[x].*)


(* Int[x_^m_.*FresnelS[a_+b_.*x_]^2,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*FresnelS[x]^2,x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0 *)


(* ::Subsubsection::Closed:: *)
(*x^m Sin[Pi/2 b^2 x^2] FresnelS[b x]		Products of monomials, sines and Fresnel integral S functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*Sin[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  -Cos[Pi/2*b^2*x^2]*FresnelS[b*x]/(Pi*b^2) +
  Dist[1/(2*b*Pi),Int[Sin[Pi*b^2*x^2],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Note: Also apply rule when m mod 4 = 2 when a closed-form antiderivative is defined for Cos[Pi/2*x^2]*FresnelS[x].*)


Int[x_^m_*Sin[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  -x^(m-1)*Cos[Pi/2*b^2*x^2]*FresnelS[b*x]/(Pi*b^2) +
  Dist[1/(2*b*Pi),Int[x^(m-1)*Sin[Pi*b^2*x^2],x]] +
  Dist[(m-1)/(Pi*b^2),Int[x^(m-2)*Cos[Pi/2*b^2*x^2]*FresnelS[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m>1 && Not[Mod[m,4]==2]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sin[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  x^(m+1)*Sin[Pi/2*b^2*x^2]*FresnelS[b*x]/(m+1) - b*x^(m+2)/(2*(m+1)*(m+2)) +
  Dist[b/(2*(m+1)),Int[x^(m+1)*Cos[Pi*b^2*x^2],x]] -
  Dist[Pi*b^2/(m+1),Int[x^(m+2)*Cos[Pi/2*b^2*x^2]*FresnelS[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m<-2 && Mod[m,4]==0


(* ::Subsubsection::Closed:: *)
(*x^m Cos[Pi/2 b^2 x^2] FresnelS[b x]		Products of monomials, cosines and Fresnel integral S functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*Cos[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  Sin[Pi/2*b^2*x^2]*FresnelS[b*x]/(Pi*b^2) - x/(2*b*Pi) +
  Dist[1/(2*b*Pi),Int[Cos[Pi*b^2*x^2],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_*Cos[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  x^(m-1)*Sin[Pi/2*b^2*x^2]*FresnelS[b*x]/(Pi*b^2) - x^m/(2*b*m*Pi) +
  Dist[1/(2*b*Pi),Int[x^(m-1)*Cos[Pi*b^2*x^2],x]] -
  Dist[(m-1)/(Pi*b^2),Int[x^(m-2)*Sin[Pi/2*b^2*x^2]*FresnelS[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m>1 && Not[Mod[m,4]==0]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Cos[c_.*x_^2]*FresnelS[b_.*x_],x_Symbol] :=
  x^(m+1)*Cos[Pi/2*b^2*x^2]*FresnelS[b*x]/(m+1) -
  Dist[b/(2*(m+1)),Int[x^(m+1)*Sin[Pi*b^2*x^2],x]] +
  Dist[Pi*b^2/(m+1),Int[x^(m+2)*Sin[Pi/2*b^2*x^2]*FresnelS[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m<-1 && Mod[m,4]==2


(* ::Subsection::Closed:: *)
(*Fresnel Integral C Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*FresnelC[a+b x]^n				Powers of Fresnel integral C functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[FresnelC[a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*FresnelC[a+b*x]/b - Sin[Pi/2*(a+b*x)^2]/(b*Pi) /;
FreeQ[{a,b},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[FresnelC[a_.+b_.*x_]^2,x_Symbol] :=
  (a+b*x)*FresnelC[a+b*x]^2/b -
  Dist[2,Int[(a+b*x)*Cos[Pi/2*(a+b*x)^2]*FresnelC[a+b*x],x]] /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m FresnelC[a+b x]^n			Products of monomials and powers of Fresnel integral C functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*FresnelC[a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*FresnelC[a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*Cos[Pi/2*(a+b*x)^2],x]] /;
FreeQ[{a,b,m},x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Note: Also apply rule when m mod 4 = 1 when a closed-form antiderivative is defined for Sin[Pi/2*x^2]*FresnelC[x].*)


Int[x_^m_*FresnelC[b_.*x_]^2,x_Symbol] :=
  x^(m+1)*FresnelC[b*x]^2/(m+1) -
  Dist[2*b/(m+1),Int[x^(m+1)*Cos[Pi/2*b^2*x^2]*FresnelC[b*x],x]] /;
FreeQ[b,x] && IntegerQ[m] && m+1!=0 && (m>0 && EvenQ[m] || Mod[m,4]==3)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x, a+b*x], x] == Subst[Int[f[-a/b+x/b, x], x], x, a+b*x]/b*)


(* ::Item:: *)
(*Note: Rule not necessary until a closed-form antiderivative is defined for Sin[Pi/2*x^2]*FresnelC[x].*)


(* Int[x_^m_.*FresnelC[a_+b_.*x_]^2,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*FresnelC[x]^2,x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0 *)


(* ::Subsubsection::Closed:: *)
(*x^m Sin[Pi/2 b^2 x^2] FresnelC[b x]		Products of monomials, sines and Fresnel integral C functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*Sin[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  -Cos[Pi/2*b^2*x^2]*FresnelC[b*x]/(Pi*b^2) + x/(2*b*Pi) +
  Dist[1/(2*b*Pi),Int[Cos[Pi*b^2*x^2],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_*Sin[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  -x^(m-1)*Cos[Pi/2*b^2*x^2]*FresnelC[b*x]/(Pi*b^2) + x^m/(2*b*m*Pi) +
  Dist[1/(2*b*Pi),Int[x^(m-1)*Cos[Pi*b^2*x^2],x]] +
  Dist[(m-1)/(Pi*b^2),Int[x^(m-2)*Cos[Pi/2*b^2*x^2]*FresnelC[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m>1 && Not[Mod[m,4]==0]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Sin[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  x^(m+1)*Sin[Pi/2*b^2*x^2]*FresnelC[b*x]/(m+1) -
  Dist[b/(2*(m+1)),Int[x^(m+1)*Sin[Pi*b^2*x^2],x]] -
  Dist[Pi*b^2/(m+1),Int[x^(m+2)*Cos[Pi/2*b^2*x^2]*FresnelC[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m<-1 && Mod[m,4]==2


(* ::Subsubsection::Closed:: *)
(*x^m Cos[Pi/2 b^2 x^2] FresnelC[b x]		Products of monomials, cosines and Fresnel integral C functions*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_*Cos[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  Sin[Pi/2*b^2*x^2]*FresnelC[b*x]/(Pi*b^2) -
  Dist[1/(2*b*Pi),Int[Sin[Pi*b^2*x^2],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2


(* ::Item::Closed:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Note: Also apply rule when m mod 4 = 2 when a closed-form antiderivative is defined for Sin[Pi/2*x^2]*FresnelC[x].*)


Int[x_^m_*Cos[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  x^(m-1)*Sin[Pi/2*b^2*x^2]*FresnelC[b*x]/(Pi*b^2) -
  Dist[1/(2*b*Pi),Int[x^(m-1)*Sin[Pi*b^2*x^2],x]] -
  Dist[(m-1)/(Pi*b^2),Int[x^(m-2)*Sin[Pi/2*b^2*x^2]*FresnelC[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m>1 && Not[Mod[m,4]==2]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*Cos[c_.*x_^2]*FresnelC[b_.*x_],x_Symbol] :=
  x^(m+1)*Cos[Pi/2*b^2*x^2]*FresnelC[b*x]/(m+1) - b*x^(m+2)/(2*(m+1)*(m+2)) -
  Dist[b/(2*(m+1)),Int[x^(m+1)*Cos[Pi*b^2*x^2],x]] +
  Dist[Pi*b^2/(m+1),Int[x^(m+2)*Sin[Pi/2*b^2*x^2]*FresnelC[b*x],x]] /;
FreeQ[{b,c},x] && c===Pi/2*b^2 && IntegerQ[m] && m<-2 && Mod[m,4]==0
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/LogarithmFunctionIntegrationRules.m0000644000175000017500000004145711446257035034041 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Logarithm Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Log[c (a+b x)^n]			Logarithms of powers of linears*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.711.1, CRC 499, A&S 4.1.49*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_.+b_.*x_)^n_.],x_Symbol] :=
  (a+b*x)*Log[c*(a+b*x)^n]/b - n*x /;
FreeQ[{a,b,c,n},x]


(* ::Subsection::Closed:: *)
(*(d+e x)^m Log[c (a+b x)^n]		Products of powers of linears and logarithms of powers of linears*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.2*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[-PolyLog[2, d+e*x]/e, x] == Log[1-d-e*x]/(d+e*x)*)


Int[Log[c_.*(a_.+b_.*x_)]/(d_+e_.*x_),x_Symbol] :=
  -PolyLog[2,1-a*c-b*c*x]/e /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[a*c*e-b*c*d-e]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_.+b_.*x_)^n_.]/(d_+e_.*x_),x_Symbol] :=
  Log[c*(a+b*x)^n]*Log[b*(d+e*x)/(b*d-a*e)]/e + 
  n*PolyLog[2,-e*(a+b*x)/(b*d-a*e)]/e /;
FreeQ[{a,b,c,d,e,n},x] && NonzeroQ[b*d-a*e]


(* ::Subsection::Closed:: *)
(*Log[c (a+b x^n)^p]			Logarithms of powers of binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.1*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(b_.*x_^n_)^p_.],x_Symbol] :=
  x*Log[c*(b*x^n)^p] - n*p*x /;
FreeQ[{b,c,n,p},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.1*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_+b_.*x_^n_)^p_.],x_Symbol] :=
  x*Log[c*(a+b*x^n)^p] - 
  Dist[b*n*p,Int[1/(b+a*x^(-n)),x]] /;
FreeQ[{a,b,c,p},x] && RationalQ[n] && n<0


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.1*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_+b_.*x_^n_)^p_.],x_Symbol] :=
  x*Log[c*(a+b*x^n)^p] - n*p*x + 
  Dist[a*n*p,Int[1/(a+b*x^n),x]] /;
FreeQ[{a,b,c,n,p},x]


(* ::Subsection::Closed:: *)
(*x^m Log[c (a+b x^n)^p]		Products of monomials and logarithms of powers of binomials*)
(**)


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.2*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[PolyLog[2,-x],x] == -Log[1+x]/x*)


Int[Log[1+b_.*x_^n_.]/x_,x_Symbol] :=
  -PolyLog[2,-b*x^n]/n /;
FreeQ[{b,n},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If a>0, Log[a*z] == Log[a] + Log[z]*)


Int[Log[c_.*(a_+b_.*x_^n_.)]/x_,x_Symbol] :=
  Log[a*c]*Log[x] +
  Int[Log[1+b*x^n/a]/x,x] /;
FreeQ[{a,b,c,n},x] && PositiveQ[a*c]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_+b_.*x_^n_.)^p_.]/x_,x_Symbol] :=
  Log[c*(a+b*x^n)^p]*Log[-b*x^n/a]/n -
  Dist[b*p,Int[x^(n-1)*Log[-b*x^n/a]/(a+b*x^n),x]] /;
(* p*PolyLog[2,1+b*x^n/a]/n /; *)
FreeQ[{a,b,c,n,p},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.1, CRC 501, A&S 4.1.50'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Log[c_.*(b_.*x_^n_.)^p_.],x_Symbol] :=
  x^(m+1)*Log[c*(b*x^n)^p]/(m+1) - n*p*x^(m+1)/(m+1)^2 /;
FreeQ[{b,c,m,n,p},x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.728.1, CRC 501, A&S 4.1.50'*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Log[c_.*(a_+b_.*x_^n_.)^p_.],x_Symbol] :=
  x^(m+1)*Log[c*(a+b*x^n)^p]/(m+1) - 
  Dist[b*n*p/(m+1),Int[x^(m+n)/(a+b*x^n),x]] /;
FreeQ[{a,b,c,m,n,p},x] && NonzeroQ[m+1] && NonzeroQ[m-n+1]


(* ::Subsection::Closed:: *)
(*(a+b Log[c (d+e x)^n])^p		Powers of linear binomials of logarithms*)


(* ::Item::Closed:: *)
(*Reference: CRC 492*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[LogIntegral[x],x] == 1/Log[x]*)


Int[1/Log[c_.*(d_.+e_.*x_)],x_Symbol] :=
  LogIntegral[c*(d+e*x)]/(c*e) /;
FreeQ[{c,d,e},x]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[ExpIntegralEi[x],x] == E^x/x*)


Int[1/(a_.+b_.*Log[c_.*(d_.+e_.*x_)^n_.]),x_Symbol] :=
  (d+e*x)*ExpIntegralEi[(a+b*Log[c*(d+e*x)^n])/(b*n)]/(b*e*n*E^(a/(b*n))*(c*(d+e*x)^n)^(1/n)) /;
FreeQ[{a,b,c,d,e,n},x]


Int[1/Sqrt[a_.+b_.*Log[c_.*(d_.+e_.*x_)^n_.]],x_Symbol] :=
  Sqrt[Pi]*(d+e*x)*Erfi[Rt[1/(b*n),2]*Sqrt[a+b*Log[c*(d+e*x)^n]]]/
    (b*e*n*Rt[1/(b*n),2]*E^(a/(b*n))*(c*(d+e*x)^n)^(1/n)) /;
FreeQ[{a,b,c,d,e,n},x] && PosQ[1/(b*n)]


Int[1/Sqrt[a_.+b_.*Log[c_.*(d_.+e_.*x_)^n_.]],x_Symbol] :=
  Sqrt[Pi]*(d+e*x)*Erf[Rt[-1/(b*n),2]*Sqrt[a+b*Log[c*(d+e*x)^n]]]/
    (b*e*n*Rt[-1/(b*n),2]*E^(a/(b*n))*(c*(d+e*x)^n)^(1/n)) /;
FreeQ[{a,b,c,d,e,n},x] && NegQ[1/(b*n)]


(* ::Item::Closed:: *)
(*Reference: G&R 2.711.1, CRC 490*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(a_.+b_.*Log[c_.*x_^n_.])^p_,x_Symbol] :=
  x*(a+b*Log[c*x^n])^p -
  Dist[b*n*p,Int[(a+b*Log[c*x^n])^(p-1),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>0


(* ::Item::Closed:: *)
(*Reference: G&R 2.711.1, CRC 490*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(d_.+e_.*x_)^n_.]^p_,x_Symbol] :=
  (d+e*x)*Log[c*(d+e*x)^n]^p/e -
  Dist[n*p,Int[Log[c*(d+e*x)^n]^(p-1),x]] /;
FreeQ[{c,d,e,n},x] && RationalQ[p] && p>0


(* ::Item::Closed:: *)
(*Reference: G&R 2.711.1, CRC 490*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(a_.+b_.*Log[c_.*(d_.+e_.*x_)^n_.])^p_,x_Symbol] :=
  x*(a+b*Log[c*(d+e*x)^n])^p -
  Dist[b*e*n*p,Int[x*(a+b*Log[c*(d+e*x)^n])^(p-1)/(d+e*x),x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[p] && p>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[(a_.+b_.*Log[c_.*x_^n_.])^p_,x_Symbol] :=
  x*(a+b*Log[c*x^n])^(p+1)/(b*n*(p+1)) -
  Dist[1/(b*n*(p+1)),Int[(a+b*Log[c*x^n])^(p+1),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p<-1


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[Log[c_.*(d_.+e_.*x_)^n_.]^p_,x_Symbol] :=
  (d+e*x)*Log[c*(d+e*x)^n]^(p+1)/(e*n*(p+1)) -
  Dist[1/(n*(p+1)),Int[Log[c*(d+e*x)^n]^(p+1),x]] /;
FreeQ[{c,d,e,n},x] && RationalQ[p] && p<-1


Int[(a_.+b_.*Log[c_.*(d_.+e_.*x_)^n_.])^p_,x_Symbol] :=
  (d+e*x)*Gamma[p+1,-(a+b*Log[c*(d+e*x)^n])/(b*n)]*(a+b*Log[c*(d+e*x)^n])^p/
    (e*(-(a+b*Log[c*(d+e*x)^n])/(b*n))^p*E^(a/(b*n))*(c*(d+e*x)^n)^(1/n)) /;
FreeQ[{a,b,c,d,e,n,p},x] && NonzeroQ[p+1]


(* ::Subsection::Closed:: *)
(*x^m (a+b Log[c x^n])^p		Products of monomials and powers of linear binomials of logarithms*)
(**)


Int[x_^m_./(a_.+b_.*Log[c_.*x_^n_.]),x_Symbol] :=
  x^(m+1)*ExpIntegralEi[(m+1)*(a+b*Log[c*x^n])/(b*n)]/(b*n*E^(a*(m+1)/(b*n))*(c*x^n)^((m+1)/n)) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[m+1]


Int[x_^m_./Sqrt[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  Sqrt[Pi]*x^(m+1)*Erfi[Rt[(m+1)/(b*n),2]*Sqrt[a+b*Log[c*x^n]]]/
    (b*n*Rt[(m+1)/(b*n),2]*E^(a*(m+1)/(b*n))*(c*x^n)^((m+1)/n)) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[m+1] && PosQ[(m+1)/(b*n)]


Int[x_^m_./Sqrt[a_.+b_.*Log[c_.*x_^n_.]],x_Symbol] :=
  Sqrt[Pi]*x^(m+1)*Erf[Rt[-(m+1)/(b*n),2]*Sqrt[a+b*Log[c*x^n]]]/
    (b*n*Rt[-(m+1)/(b*n),2]*E^(a*(m+1)/(b*n))*(c*x^n)^((m+1)/n)) /;
FreeQ[{a,b,c,m,n},x] && NonzeroQ[m+1] && NegQ[(m+1)/(b*n)]


(* ::Item::Closed:: *)
(*Reference: G&R 2.721.1, CRC 496, A&S 4.1.51*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*(a_.+b_.*Log[c_.*x_^n_.])^p_,x_Symbol] :=
  x^(m+1)*(a+b*Log[c*x^n])^p/(m+1) -
  Dist[b*n*p/(m+1),Int[x^m*(a+b*Log[c*x^n])^(p-1),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p>0 && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.724.1, CRC 495*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*(a_.+b_.*Log[c_.*x_^n_.])^p_,x_Symbol] :=
  x^(m+1)*(a+b*Log[c*x^n])^(p+1)/(b*n*(p+1)) -
  Dist[(m+1)/(b*n*(p+1)),Int[x^m*(a+b*Log[c*x^n])^(p+1),x]] /;
FreeQ[{a,b,c,m,n},x] && RationalQ[p] && p<-1 && NonzeroQ[m+1]


Int[x_^m_.*(a_.+b_.*Log[c_.*x_^n_.])^p_,x_Symbol] :=
  x^(m+1)*Gamma[p+1,-(m+1)*(a+b*Log[c*x^n])/(b*n)]*(a+b*Log[c*x^n])^p/
    ((m+1)*E^(a*(m+1)/(b*n))*(c*x^n)^((m+1)/n)*(-(m+1)*(a+b*Log[c*x^n])/(b*n))^p) /;
FreeQ[{a,b,c,m,n,p},x] && NonzeroQ[m+1]


(* Need a rule for arbitrarily deep nesting of powers! *) 
Int[Log[a_.*(b_.*x_^n_.)^p_]^q_.,x_Symbol] :=
  Subst[Int[Log[x^(n*p)]^q,x],x^(n*p),a*(b*x^n)^p] /;
FreeQ[{a,b,n,p,q},x]


Int[Log[a_.*(b_.*(c_.*x_^n_.)^p_)^q_]^r_.,x_Symbol] :=
  Subst[Int[Log[x^(n*p*q)]^r,x],x^(n*p*q),a*(b*(c*x^n)^p)^q] /;
FreeQ[{a,b,c,n,p,q,r},x]


Int[x_^m_.*Log[a_.*(b_.*x_^n_.)^p_]^q_.,x_Symbol] :=
  Subst[Int[x^m*Log[x^(n*p)]^q,x],x^(n*p),a*(b*x^n)^p] /;
FreeQ[{a,b,m,n,p,q},x] && NonzeroQ[m+1] && Not[x^(n*p)===a*(b*x^n)^p]


Int[x_^m_.*Log[a_.*(b_.*(c_.*x_^n_.)^p_)^q_]^r_.,x_Symbol] :=
  Subst[Int[x^m*Log[x^(n*p*q)]^r,x],x^(n*p*q),a*(b*(c*x^n)^p)^q] /;
FreeQ[{a,b,c,m,n,p,q,r},x] && NonzeroQ[m+1] && Not[x^(n*p*q)===a*(b*(c*x^n)^p)^q]


(* ::Subsection::Closed:: *)
(*Log[c (a+b x)^n]^p / (d+e x)		Quotients of powers of logarithms of powers of binomials by x*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[c_.*(a_+b_.*x_)^n_.]^p_./(d_.+e_.*x_),x_Symbol] :=
  Log[c*(a+b*x)^n]^p*Log[b*(d+e*x)/(b*d-a*e)]/e -
  Dist[b*n*p/e,Int[Log[c*(a+b*x)^n]^(p-1)*Log[b*(d+e*x)/(b*d-a*e)]/(a+b*x),x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[p] && p>0 && NonzeroQ[b*d-a*e]


(* ::Item:: *)
(*Note: Log[z] == -PolyLog[1, 1-z]*)


Int[Log[c_.*(a_+b_.*x_)^n_.]^p_.*Log[h_.*(f_.+g_.*x_)]/(d_+e_.*x_),x_Symbol] :=
  Module[{q=Simplify[1-h*(f+g*x)]},
  -Log[c*(a+b*x)^n]^p*PolyLog[2,q]/e +
  Dist[b*n*p/e,Int[Log[c*(a+b*x)^n]^(p-1)*PolyLog[2,q]/(a+b*x),x]]] /;
FreeQ[{a,b,c,d,e,f,g,h,n},x] && RationalQ[p] && p>0 && ZeroQ[a*e-b*d] && ZeroQ[a*g*h-b*(f*h-1)]


Int[Log[c_.*(a_+b_.*x_)^n_.]^p_.*PolyLog[m_,h_.*(f_.+g_.*x_)]/(d_+e_.*x_),x_Symbol] :=
  Log[c*(a+b*x)^n]^p*PolyLog[m+1,h*(f+g*x)]/e -
  Dist[b*n*p/e,Int[Log[c*(a+b*x)^n]^(p-1)*PolyLog[m+1,h*(f+g*x)]/(a+b*x),x]] /;
FreeQ[{a,b,c,d,e,f,g,h,m,n},x] && RationalQ[p] && p>0 && ZeroQ[a*e-b*d] && ZeroQ[a*g-b*f]


(* ::Item:: *)
(*Note: Reduces binomial to a linear, even for fractional and symbolic m, n and p.*)


(* Int[Log[c_.*(a_+b_.*x_^m_)^n_.]^p_./x_,x_Symbol] :=
  Dist[1/m,Subst[Int[Log[c*(a+b*x)^n]^p/x,x],x,x^m]] /;
FreeQ[{a,b,c,m,n,p},x] *)


(* ::Subsection::Closed:: *)
(*x^m Log[c (a+b x)^n]^p		Products of monomials and powers of logarithms of monomials*)
(**)


Int[x_^m_.*Log[c_.*(a_+b_.*x_)^n_.]^p_,x_Symbol] :=
  x^m*(a+b*x)*Log[c*(a+b*x)^n]^p/(b*(m+1)) -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*Log[c*(a+b*x)^n]^p,x]] -
  Dist[n*p/(m+1),Int[x^m*Log[c*(a+b*x)^n]^(p-1),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{m,p}] && m>0 && p>0


Int[Log[c_.*(a_+b_.*x_)^n_.]^p_/x_^2,x_Symbol] :=
  -(a+b*x)*Log[c*(a+b*x)^n]^p/(a*x) +
  Dist[b*n*p/a,Int[Log[c*(a+b*x)^n]^(p-1)/x,x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[p] && p>0


Int[x_^m_.*Log[c_.*(a_+b_.*x_)^n_.]^p_,x_Symbol] :=
  x^(m+1)*(a+b*x)*Log[c*(a+b*x)^n]^p/(a*(m+1)) -
  Dist[(b*(m+2))/(a*(m+1)),Int[x^(m+1)*Log[c*(a+b*x)^n]^p,x]] -
  Dist[b*n*p/(a*(m+1)),Int[x^(m+1)*Log[c*(a+b*x)^n]^(p-1),x]] /;
FreeQ[{a,b,c,n},x] && RationalQ[{m,p}] && m<-1 && m!=-2 && p>0


Int[x_^m_.*Log[c_.*(a_+b_.*x_)^n_.]^p_,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*Log[c*x^n]^p,x],x,a+b*x]] /;
FreeQ[{a,b,c,n,p},x] && IntegerQ[m] && m>0 && Not[RationalQ[p] && p>0]


(* ::Subsection::Closed:: *)
(*Log[c (a+b x^m)^n]^p		Powers of logarithms of binomials*)
(**)


(* Way kool rule!  Note that the b/x in the resulting integrand will be transformed to b*x
	by the rule Int[f[x^n]/x,x] -> Subst[Int[f[x]/x,x],x,x^n]/n *)
Int[Log[c_.*(a_+b_./x_)^n_.]^p_, x_Symbol] :=
  (b+a*x)*Log[c*(a+b/x)^n]^p/a + 
  Dist[b/a*n*p,Int[Log[c*(a+b/x)^n]^(p-1)/x,x]] /;
FreeQ[{a,b,c,n},x] && IntegerQ[p] && p>0


Int[Log[c_.*(a_+b_.*x_^2)^n_.]^2, x_Symbol] :=
  x*Log[c*(a+b*x^2)^n]^2 + 
    8*n^2*x -
    4*n*x*Log[c*(a+b*x^2)^n] + 
    (n*Sqrt[a]/Sqrt[-b])*( 
      4*n*Log[(-Sqrt[a]+Sqrt[-b]*x)/(Sqrt[a]+Sqrt[-b]*x)] - 
      4*n*ArcTanh[Sqrt[-b]*x/Sqrt[a]]*(Log[-Sqrt[a]/Sqrt[-b]+x] + Log[Sqrt[a]/Sqrt[-b]+x]) -
      n*Log[-Sqrt[a]/Sqrt[-b]+x]^2 + 
      n*Log[Sqrt[a]/Sqrt[-b]+x]^2 - 
      2*n*Log[Sqrt[a]/Sqrt[-b]+x]*Log[1/2-Sqrt[-b]*x/(2*Sqrt[a])] + 
      2*n*Log[-Sqrt[a]/Sqrt[-b]+x]*Log[(1+Sqrt[-b]*x/Sqrt[a])/2] + 
      4*ArcTanh[Sqrt[-b]*x/Sqrt[a]]*Log[c*(a+b*x^2)^n] + 
      2*n*PolyLog[2,1/2-Sqrt[-b]*x/(2*Sqrt[a])] - 
      2*n*PolyLog[2,(1+Sqrt[-b]*x/Sqrt[a])/2]) /;
FreeQ[{a,b,c,n},x]


(* ::Subsection::Closed:: *)
(*Log[d (a+b x+c x^2)^n]^p		Powers of logarithms of powers of quadratics*)
(**)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[d_.*(a_.+b_.*x_+c_.*x_^2)^n_.]^2,x_Symbol] :=
  x*Log[d*(a+b*x+c*x^2)^n]^2 -
  Dist[2*b*n,Int[x*Log[d*(a+b*x+c*x^2)^n]/(a+b*x+c*x^2),x]] - 
  Dist[4*c*n,Int[x^2*Log[d*(a+b*x+c*x^2)^n]/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,n},x]


(* ::Subsection::Closed:: *)
(*x^m Log[a Log[b x^n]^m]		Logarithms of logarithms*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[a_.*Log[b_.*x_^n_.]^p_.],x_Symbol] :=
  x*Log[a*Log[b*x^n]^p] - 
  Dist[n*p,Int[1/Log[b*x^n],x]] /;
FreeQ[{a,b,n,p},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[a_.*Log[b_.*x_^n_.]^p_.]/x_,x_Symbol] :=
  Log[b*x^n]*(-p+Log[a*Log[b*x^n]^p])/n /;
FreeQ[{a,b,n,p},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Log[a_.*Log[b_.*x_^n_.]^p_.],x_Symbol] :=
  x^(m+1)*Log[a*Log[b*x^n]^p]/(m+1) - 
  Dist[n*p/(m+1),Int[x^m/Log[b*x^n],x]] /;
FreeQ[{a,b,m,n,p},x] && NonzeroQ[m+1]


(* ::Subsection::Closed:: *)
(*Log[u] / x				Quotients of logarithms by x*)


(* Int[Log[b_.*x_^n_.+c_.*x_^p_.]/x_,x_Symbol] :=
  -Log[x^n]*(Log[x^n]/2-Log[b*x^n+c*x^p]+Log[1+c*x^n/b])/n - 
  PolyLog[2,-c*x^n/b]/n /;
FreeQ[{b,c,n,p},x] && p===2*n *)


(* Int[Log[a_+b_.*x_^n_.+c_.*x_^p_.]/x_,x_Symbol] :=
  Module[{q=Sqrt[b^2-4*a*c]},
  -Log[x]*(Log[1+2*c*x^n/(b-q)]+Log[1+2*c*x^n/(b+q)]-Log[a+b*x^n+c*x^p]) - 
  PolyLog[2,-2*c*x^n/(b-q)]/n - 
  PolyLog[2,-2*c*x^n/(b+q)]/n] /;
FreeQ[{a,b,c,n,p},x] && p===2*n *)


(* Way kool rule!  More generally valid for any integrand of the form f ((a+b*x)/(c+d*x))/x. *)
Int[Log[(a_.+b_.*x_)/(c_+d_.*x_)]^m_./x_,x_Symbol] :=
  Subst[Int[Log[a/c+x/c]^m/x,x],x,(b*c-a*d)*x/(c+d*x)] - 
  Subst[Int[Log[b/d+x/d]^m/x,x],x,-(b*c-a*d)/(c+d*x)] /;
FreeQ[{a,b,c,d},x] && IntegerQ[m] && m>0 && NonzeroQ[b*c-a*d]


(* ::Subsection::Closed:: *)
(*Log[u]^n / (a+b x+...)			Quotients of powers of logarithms by polynomials*)


(* Int[Log[u_]^n_./(a_+b_.*x_),x_Symbol] :=
  Dist[1/b,Subst[Int[Regularize[Log[Subst[u,x,-a/b+x/b]]^n/x,x],x],x,a+b*x]] /;
FreeQ[{a,b,n},x] && NonzeroQ[u-a-b*x] && InverseFunctionFreeQ[u,x] *)


(* ::Subsection::Closed:: *)
(*(A+B Log[d+e x]) / Sqrt[a+b Log[d+e x]]  Quotients of linear binomials of logarithms*)


(* ::Item:: *)
(*Basis: (A+B*z)/Sqrt[a+b*z] == (b*A-a*B)/(b*Sqrt[a+b*z]) + B/b*Sqrt[a+b*z]*)


Int[(A_.+B_.*Log[c_.+d_.*x_])/Sqrt[a_+b_.*Log[c_.+d_.*x_]],x_Symbol] :=
  Dist[(b*A-a*B)/b,Int[1/Sqrt[a+b*Log[c+d*x]],x]] +
  Dist[B/b,Int[Sqrt[a+b*Log[c+d*x]],x]] /;
FreeQ[{a,b,c,d,A,B},x] && NonzeroQ[b*A-a*B]


(* ::Subsection::Closed:: *)
(*(a+b x)^m Log[c+d x]^n*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[(a_.+b_.*x_)^m_.*Log[c_.+d_.*x_]^n_,x_Symbol] :=
  (a+b*x)^(m+1)*Log[c+d*x]^n/(b*(m+1)) -
  Dist[d*n/(b*(m+1)),Int[Regularize[(a+b*x)^(m+1)*Log[c+d*x]^(n-1)/(c+d*x),x],x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[{m,n}] && m<-1 && n>0


(* ::Subsection::Closed:: *)
(*f^(a Log[u])				Exponentials of logarithms*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: f^(a*Log[g]) == g^(a*Log[f])*)


Int[f_^(a_.*Log[u_]),x_Symbol] :=
  Int[u^(a*Log[f]),x] /;
FreeQ[{a,f},x]


(* ::Subsection::Closed:: *)
(*Integration by substitution*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/z == Log'[z]*)


Int[1/(a_.*x_+b_.*x_*Log[c_.*x_^n_.]^m_.),x_Symbol] :=
  Dist[1/n,Subst[Int[1/(a+b*x^m),x],x,Log[c*x^n]]] /;
FreeQ[{a,b,c,m,n},x]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/z == Log'[z]*)


If[ShowSteps,

Int[u_/x_,x_Symbol] :=
  Module[{lst=FunctionOfLog[u,x]},
  ShowStep["","Int[f[Log[a*x^n]]/x,x]","Subst[Int[f[x],x],x,Log[a*x^n]]/n",Hold[
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,Log[lst[[2]]]]]]] /;
 Not[FalseQ[lst]]] /;
SimplifyFlag && NonsumQ[u],

Int[u_/x_,x_Symbol] :=
  Module[{lst=FunctionOfLog[u,x]},
  Dist[1/lst[[3]],Subst[Int[lst[[1]],x],x,Log[lst[[2]]]]] /;
 Not[FalseQ[lst]]] /;
NonsumQ[u]]


(* ::Subsection::Closed:: *)
(*Integration by parts*)


(* ::Item::Closed:: *)
(*Reference: A&S 4.1.53*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: D[Log[f[x]], x] == D[f[x],x] / f[x]*)


Int[Log[u_],x_Symbol] :=
  x*Log[u] -
  Int[Regularize[x*D[u,x]/u,x],x] /;
AlgebraicFunctionQ[u,x]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/SpecialFunctionIntegrationRules.m0000644000175000017500000005147711446257035033476 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Special Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*Gamma Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Gamma[n,a+b x]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Gamma[n_,a_.+b_.*x_],x_Symbol] :=
  (a+b*x)*Gamma[n,a+b*x]/b -
  Gamma[n+1,a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m Gamma[n,a+b x]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Gamma[n_,a_.*x_],x_Symbol] :=
  x^(m+1)*Gamma[n,a*x]/(m+1) -
  Gamma[m+n+1,a*x]/((m+1)*a^(m+1)) /;
FreeQ[{a,n},x] && (IntegerQ[m] || PositiveQ[a])


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Gamma[n_,a_*x_],x_Symbol] :=
  x^(m+1)*Gamma[n,a*x]/(m+1) -
  x^(m+1)*Gamma[m+n+1,a*x]/((m+1)*(a*x)^(m+1)) /;
FreeQ[{a,m,n},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Gamma[n_,a_+b_.*x_],x_Symbol] :=
  x^m*(a+b*x)*Gamma[n,a+b*x]/(b*(m+1)) -
  x^m*Gamma[n+1,a+b*x]/(b*(m+1)) -
  Dist[a*m/(b*(m+1)),Int[x^(m-1)*Gamma[n,a+b*x],x]] +
  Dist[m/(b*(m+1)),Int[x^(m-1)*Gamma[n+1,a+b*x],x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>0


(* ::Subsection::Closed:: *)
(*LogGamma Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*LogGamma[a+b x]*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[PolyGamma[-2,z],z] == LogGamma[z]*)


Int[LogGamma[a_.+b_.*x_],x_Symbol] :=
  PolyGamma[-2,a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Subsubsection::Closed:: *)
(*x^m LogGamma[a+b x]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*LogGamma[a_.+b_.*x_],x_Symbol] :=
  x^m*PolyGamma[-2,a+b*x]/b -
  Dist[m/b,Int[x^(m-1)*PolyGamma[-2,a+b*x],x]] /;
FreeQ[{a,b},x] && RationalQ[m] && m>0


(* ::Subsection::Closed:: *)
(*PolyGamma Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*PolyGamma[n, a+b x]*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[PolyGamma[n,z],z] == PolyGamma[n+1,z]*)


Int[PolyGamma[n_,a_.+b_.*x_],x_Symbol] :=
  PolyGamma[n-1,a+b*x]/b /;
FreeQ[{a,b,n},x]


(* ::Subsubsection::Closed:: *)
(*x^m PolyGamma[n, a+b x]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*PolyGamma[n_,a_.+b_.*x_],x_Symbol] :=
  x^m*PolyGamma[n-1,a+b*x]/b -
  Dist[m/b,Int[x^(m-1)*PolyGamma[n-1,a+b*x],x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*PolyGamma[n_,a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*PolyGamma[n,a+b*x]/(m+1) -
  Dist[b/(m+1),Int[x^(m+1)*PolyGamma[n+1,a+b*x],x]] /;
FreeQ[{a,b,n},x] && RationalQ[m] && m<-1


(* ::Subsubsection::Closed:: *)
(*Gamma[a+b x]^n PolyGamma[0, a+b x]*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[Gamma[z]^n, z] == n Gamma[z]^n PolyGamma[0, z]*)


Int[Gamma[a_.+b_.*x_]^n_.*PolyGamma[0,a_.+b_.*x_],x_Symbol] :=
  Gamma[a+b*x]^n/(b*n) /;
FreeQ[{a,b,n},x]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[(z!)^n, z] == n (z!)^n PolyGamma[0, 1+z]*)


Int[((a_.+b_.*x_)!)^n_.*PolyGamma[0,c_.+b_.*x_],x_Symbol] :=
  ((a+b*x)!)^n/(b*n) /;
FreeQ[{a,b,c,n},x] && ZeroQ[a-c+1]


(* ::Subsection::Closed:: *)
(*Zeta Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*Zeta[s, a+b x]*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Zeta[2,z] == PolyGamma[1,z]*)


Int[Zeta[2,a_.+b_.*x_],x_Symbol] :=
  Int[PolyGamma[1,a+b*x],x] /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[Zeta[s,z],z] == -s*Zeta[s+1,z]*)


Int[Zeta[s_,a_.+b_.*x_],x_Symbol] :=
  -Zeta[s-1,a+b*x]/(b*(s-1)) /;
FreeQ[{a,b,s},x] && NonzeroQ[s-1] && NonzeroQ[s-2]


(* ::Subsubsection::Closed:: *)
(*x^m Zeta[s, a+b x]*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: Zeta[2,z] == PolyGamma[1,z]*)


Int[x_^m_.*Zeta[2,a_.+b_.*x_],x_Symbol] :=
  Int[x^m*PolyGamma[1,a+b*x],x] /;
FreeQ[{a,b},x] && RationalQ[m]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*Zeta[s_,a_.+b_.*x_],x_Symbol] :=
  -x^m*Zeta[s-1,a+b*x]/(b*(s-1)) +
  Dist[m/(b*(s-1)),Int[x^(m-1)*Zeta[s-1,a+b*x],x]] /;
FreeQ[{a,b,s},x] && RationalQ[m] && m>0 && NonzeroQ[s-1] && NonzeroQ[s-2]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*Zeta[s_,a_.+b_.*x_],x_Symbol] :=
  x^(m+1)*Zeta[s,a+b*x]/(m+1) +
  Dist[b*s/(m+1),Int[x^(m+1)*Zeta[s+1,a+b*x],x]] /;
FreeQ[{a,b,s},x] && RationalQ[m] && m<-1 && NonzeroQ[s-1] && NonzeroQ[s-2]


(* ::Subsection::Closed:: *)
(*Polylogarithm Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*PolyLog[n, a (b x^p)^q]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[PolyLog[n_,a_.*(b_.*x_^p_.)^q_.],x_Symbol] :=
  x*PolyLog[n,a*(b*x^p)^q] -
  Dist[p*q,Int[PolyLog[n-1,a*(b*x^p)^q],x]] /;
FreeQ[{a,b,p,q},x] && RationalQ[n] && n>0


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[PolyLog[n_,a_.*(b_.*x_^p_.)^q_.],x_Symbol] :=
  x*PolyLog[n+1,a*(b*x^p)^q]/(p*q) -
  Dist[1/(p*q),Int[PolyLog[n+1,a*(b*x^p)^q],x]] /;
FreeQ[{a,b,p,q},x] && RationalQ[n] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m PolyLog[n, a (b x^p)^q]*)


(* ::Item::Closed:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: D[PolyLog[n,z],z] == PolyLog[n-1,z]/z*)


Int[PolyLog[n_,a_.*(b_.*x_^p_.)^q_.]/x_,x_Symbol] :=
  PolyLog[n+1,a*(b*x^p)^q]/(p*q) /;
FreeQ[{a,b,n,p,q},x]


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*PolyLog[n_,a_.*(b_.*x_^p_.)^q_.],x_Symbol] :=
  x^(m+1)*PolyLog[n,a*(b*x^p)^q]/(m+1) -
  Dist[p*q/(m+1),Int[x^m*PolyLog[n-1,a*(b*x^p)^q],x]] /;
FreeQ[{a,b,m,p,q},x] && RationalQ[n] && n>0 && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*PolyLog[n_,a_.*(b_.*x_^p_.)^q_.],x_Symbol] :=
  x^(m+1)*PolyLog[n+1,a*(b*x^p)^q]/(p*q) -
  Dist[(m+1)/(p*q),Int[x^m*PolyLog[n+1,a*(b*x^p)^q],x]] /;
FreeQ[{a,b,m,p,q},x] && RationalQ[n] && n<-1 && NonzeroQ[m+1]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[PolyLog[n_,u_]/(a_+b_.*x_),x_Symbol] :=
  Dist[1/b,Subst[Int[PolyLog[n,Regularize[Subst[u,x,-a/b+x/b],x]]/x,x],x,a+b*x]] /;
FreeQ[{a,b,n},x]


(* ::Subsubsection::Closed:: *)
(*PolyLog[n, c (a+b x)^p]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[PolyLog[n_,c_.*(a_.+b_.*x_)^p_.],x_Symbol] :=
  x*PolyLog[n,c*(a+b*x)^p] -
  Dist[p,Int[PolyLog[n-1,c*(a+b*x)^p],x]] +
  Dist[a*p,Int[PolyLog[n-1,c*(a+b*x)^p]/(a+b*x),x]] /;
FreeQ[{a,b,c,p},x] && RationalQ[n] && n>0


(* ::Subsubsection::Closed:: *)
(*x^m PolyLog[n, c (a+b x)^p]*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*PolyLog[n_,c_.*(a_.+b_.*x_)^p_.],x_Symbol] :=
  x^(m+1)*PolyLog[n,c*(a+b*x)^p]/(m+1) -
  Dist[b*p/(m+1),Int[x^(m+1)*PolyLog[n-1,c*(a+b*x)^p]/(a+b*x),x]] /;
FreeQ[{a,b,c,m,p},x] && RationalQ[n] && n>0 && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*Log[a x^n]^p PolyLog[q, b x^m]/x*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[Log[a_.*x_^n_.]^p_.*PolyLog[q_,b_.*x_^m_.]/x_,x_Symbol] :=
  Log[a*x^n]^p*PolyLog[q+1,b*x^m]/m -
  Dist[n*p/m,Int[Log[a*x^n]^(p-1)*PolyLog[q+1,b*x^m]/x,x]] /;
FreeQ[{a,b,m,n,q},x] && RationalQ[p] && p>0


(* ::Subsection::Closed:: *)
(*LambertW (ProductLog) Function Integration Rules*)


(* ::Subsubsection::Closed:: *)
(*ProductLog[a+b x]^p*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ProductLog[a_.+b_.*x_]^p_.,x_Symbol] :=
  (a+b*x)*ProductLog[a+b*x]^p/b -
  Dist[p,Int[ProductLog[a+b*x]^p/(1+ProductLog[a+b*x]),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>=-1


Int[ProductLog[a_.+b_.*x_]^p_,x_Symbol] :=
  (a+b*x)*ProductLog[a+b*x]^p/(b*(p+1)) +
  Dist[p/(p+1),Int[ProductLog[a+b*x]^(p+1)/(1+ProductLog[a+b*x]),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p<-1


Int[ProductLog[a_.+b_.*x_]^p_,x_Symbol] :=
  ProductLog[a+b*x]^p/(-ProductLog[a+b*x])^p*Int[(-ProductLog[a+b*x])^p,x] /;
FreeQ[{a,b,p},x] && Not[RationalQ[p]]


(* ::Subsubsection::Closed:: *)
(*ProductLog[a+b x]^p / (1+ProductLog[a+b x])*)


Int[1/(1+ProductLog[a_.+b_.*x_]),x_Symbol] :=
  (a+b*x)/(b*ProductLog[a+b*x]) /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: z/(1+z) == 1-1/(1+z)*)


Int[ProductLog[a_.+b_.*x_]/(1+ProductLog[a_.+b_.*x_]),x_Symbol] :=
  x - 
  Int[1/(1+ProductLog[a+b*x]),x] /;
FreeQ[{a,b},x]


Int[1/(ProductLog[a_.+b_.*x_]*(1+ProductLog[a_.+b_.*x_])),x_Symbol] :=
  ExpIntegralEi[ProductLog[a+b*x]]/b /;
FreeQ[{a,b},x]


Int[1/(Sqrt[ProductLog[a_.+b_.*x_]]*(1+ProductLog[a_.+b_.*x_])),x_Symbol] :=
  Sqrt[Pi]*Erfi[Sqrt[ProductLog[a+b*x]]]/b /;
FreeQ[{a,b},x]


Int[ProductLog[a_.+b_.*x_]^p_/(1+ProductLog[a_.+b_.*x_]),x_Symbol] :=
  (a+b*x)*ProductLog[a+b*x]^(p-1)/b -
  Dist[p,Int[ProductLog[a+b*x]^(p-1)/(1+ProductLog[a+b*x]),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p>0


Int[ProductLog[a_.+b_.*x_]^p_./(1+ProductLog[a_.+b_.*x_]),x_Symbol] :=
  (a+b*x)*ProductLog[a+b*x]^p/(b*(p+1)) -
  Dist[1/(p+1),Int[ProductLog[a+b*x]^(p+1)/(1+ProductLog[a+b*x]),x]] /;
FreeQ[{a,b},x] && RationalQ[p] && p<-1


(* ::Subsubsection::Closed:: *)
(*x^m ProductLog[a+b x]^p*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ProductLog[a_.*x_]^p_.,x_Symbol] :=
  x^(m+1)*ProductLog[a*x]^p/(m+1) -
  Dist[p/(m+1),Int[x^m*ProductLog[a*x]^p/(1+ProductLog[a*x]),x]] /;
FreeQ[a,x] && RationalQ[{m,p}] && NonzeroQ[m+1] && m+p+1>=0


Int[x_^m_.*ProductLog[a_.*x_]^p_.,x_Symbol] :=
  x^(m+1)*ProductLog[a*x]^p/(m+p+1) +
  Dist[p/(m+p+1),Int[x^m*ProductLog[a*x]^(p+1)/(1+ProductLog[a*x]),x]] /;
FreeQ[a,x] && RationalQ[{m,p}] && NonzeroQ[m+1] && m+p+1<0


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 == 1/(1+z) + z/(1+z)*)


Int[x_^m_.*ProductLog[a_.*x_]^p_.,x_Symbol] :=
  Int[x^m*ProductLog[a*x]^p/(1+ProductLog[a*x]),x] +
  Int[x^m*ProductLog[a*x]^(p+1)/(1+ProductLog[a*x]),x] /;
FreeQ[a,x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x,x], x] == Subst[Int[f[x,-a/b+x/b], x], x, a+b*x]/b*)


Int[x_^m_.*ProductLog[a_+b_.*x_]^p_.,x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m*ProductLog[x]^p,x],x,a+b*x]] /;
FreeQ[{a,b,p},x] && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*x^m / (1+ProductLog[a+b x])*)


Int[x_^m_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^(m+1)/((m+1)*ProductLog[a*x]) -
  Dist[m/(m+1),Int[x^m/(ProductLog[a*x]*(1+ProductLog[a*x])),x]] /;
FreeQ[a,x] && RationalQ[m] && m>0


Int[x_^m_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^(m+1)/(m+1) -
  Int[x^m*ProductLog[a*x]/(1+ProductLog[a*x]),x] /;
FreeQ[a,x] && RationalQ[m] && m<-1


Int[x_^m_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^m*Gamma[m+1,-(m+1)*ProductLog[a*x]]/
	(a*(m+1)*E^(m*ProductLog[a*x])*(-(m+1)*ProductLog[a*x])^m) /;
FreeQ[a,x] && NonzeroQ[m+1]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[a+b*x,x], x] == Subst[Int[f[x,-a/b+x/b], x], x, a+b*x]/b*)


Int[x_^m_./(1+ProductLog[a_+b_.*x_]),x_Symbol] :=
  Dist[1/b,Subst[Int[(-a/b+x/b)^m/(1+ProductLog[x]),x],x,a+b*x]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0


(* ::Subsubsection::Closed:: *)
(*x^m ProductLog[a x]^p / (1+ProductLog[a x])*)
(**)


Int[x_^m_.*ProductLog[a_.*x_]^p_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x]^(p-1)/(m+1) /;
FreeQ[{a,m,p},x] && ZeroQ[m+(p-1)+1] && NonzeroQ[m+1]


Int[x_^m_.*ProductLog[a_.*x_]^p_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  a^p*ExpIntegralEi[-p*ProductLog[a*x]] /;
FreeQ[{a,m},x] && IntegerQ[p] && ZeroQ[m+p+1]


Int[x_^m_.*ProductLog[a_.*x_]^p_/(1+ProductLog[a_.*x_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[Pi/(p-1/2)]*Erf[Sqrt[(p-1/2)*ProductLog[a*x]]] /;
FreeQ[{a,m},x] && IntegerQ[p-1/2] && p>1 && ZeroQ[m+(p-1/2)+1]


Int[x_^m_.*ProductLog[a_.*x_]^p_/(1+ProductLog[a_.*x_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[-Pi/(p-1/2)]*Erfi[Sqrt[-(p-1/2)*ProductLog[a*x]]] /;
FreeQ[{a,m},x] && IntegerQ[p-1/2] && p<0 && ZeroQ[m+(p-1/2)+1]


Int[x_^m_.*ProductLog[a_.*x_]^p_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x]^(p-1)/(m+1) -
  Dist[(m+(p-1)+1)/(m+1),Int[x^m*ProductLog[a*x]^(p-1)/(1+ProductLog[a*x]),x]] /;
FreeQ[a,x] && RationalQ[{m,p}] && NonzeroQ[m+1] && m+p>0


Int[x_^m_.*ProductLog[a_.*x_]^p_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x]^p/(m+p+1) -
  Dist[(m+1)/(m+p+1),Int[x^m*ProductLog[a*x]^(p+1)/(1+ProductLog[a*x]),x]] /;
FreeQ[a,x] && RationalQ[{m,p}] && NonzeroQ[m+1] && m+p<-1


Int[x_^m_.*ProductLog[a_.*x_]^p_./(1+ProductLog[a_.*x_]),x_Symbol] :=
  x^m*Gamma[m+p+1,-(m+1)*ProductLog[a*x]]*ProductLog[a*x]^p/
	(a*(m+1)*E^(m*ProductLog[a*x])*(-(m+1)*ProductLog[a*x])^(m+p)) /;
FreeQ[a,x] && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*ProductLog[a x^n]^p*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  x*ProductLog[a*x^n]^p -
  Dist[n*p,Int[ProductLog[a*x^n]^p/(1+ProductLog[a*x^n]),x]] /;
FreeQ[{a,n,p},x] && (ZeroQ[n*(p-1)+1] || IntegerQ[p-1/2] && ZeroQ[n*(p-1/2)+1])


Int[ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  x*ProductLog[a*x^n]^p/(n*p+1) +
  Dist[n*p/(n*p+1),Int[ProductLog[a*x^n]^(p+1)/(1+ProductLog[a*x^n]),x]] /;
FreeQ[{a,n},x] && (IntegerQ[p] && ZeroQ[n*(p+1)+1] || IntegerQ[p-1/2] && ZeroQ[n*(p+1/2)+1])


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  -Subst[Int[ProductLog[a*x^(-n)]^p/x^2,x],x,1/x] /;
FreeQ[{a,p},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*ProductLog[a x^n]^p / (1+ProductLog[a x^n])*)


Int[ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x*ProductLog[a*x^n]^(p-1) /;
FreeQ[{a,n,p},x] && ZeroQ[n*(p-1)+1]


Int[ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^p*ExpIntegralEi[-p*ProductLog[a*x^n]]/n /;
FreeQ[{a,n},x] && IntegerQ[p] && ZeroQ[n*p+1]


Int[ProductLog[a_.*x_^n_]^p_/(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[Pi/(p-1/2)]*Erf[Sqrt[(p-1/2)*ProductLog[a*x^n]]]/n /;
FreeQ[{a,n},x] && IntegerQ[p-1/2] && p>1 && ZeroQ[n*(p-1/2)+1]


Int[ProductLog[a_.*x_^n_]^p_/(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[-Pi/(p-1/2)]*Erfi[Sqrt[-(p-1/2)*ProductLog[a*x^n]]]/n /;
FreeQ[{a,n},x] && IntegerQ[p-1/2] && p<0 && ZeroQ[n*(p-1/2)+1]


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  -Subst[Int[ProductLog[a*x^(-n)]^p/(x^2*(1+ProductLog[a*x^(-n)])),x],x,1/x] /;
FreeQ[{a,p},x] && IntegerQ[n] && n<0


(* ::Subsubsection::Closed:: *)
(*x^m ProductLog[a x^n]^p*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  x^(m+1)*ProductLog[a*x^n]^p/(m+1) -
  Dist[n*p/(m+1),Int[x^m*ProductLog[a*x^n]^p/(1+ProductLog[a*x^n]),x]] /;
FreeQ[{a,m,n,p},x] && NonzeroQ[m+1] &&
	(ZeroQ[m+n*(p-1)+1] || 
	 IntegerQ[p] && ZeroQ[m+n*p+1] ||
	 IntegerQ[p-1/2] && ZeroQ[m+n*(p-1/2)+1])


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  x^(m+1)*ProductLog[a*x^n]^p/(m+n*p+1) +
  Dist[n*p/(m+n*p+1),Int[x^m*ProductLog[a*x^n]^(p+1)/(1+ProductLog[a*x^n]),x]] /;
FreeQ[{a,m,n,p},x] && NonzeroQ[m+1] &&
	(IntegerQ[p] && ZeroQ[m+n*(p+1)+1] || IntegerQ[p-1/2] && ZeroQ[m+n*(p+1/2)+1])


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_.,x_Symbol] :=
  -Subst[Int[ProductLog[a*x^(-n)]^p/x^(m+2),x],x,1/x] /;
FreeQ[{a,p},x] && IntegerQ[{m,n}] && n<0 && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*x^m / (1+ProductLog[a x^n])*)


(* Int[x_^m_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x^(m+1)/((m+1)*ProductLog[a*x^n]) -
  Dist[(m-n+1)/(m+1),Int[x^m/(ProductLog[a*x^n]*(1+ProductLog[a*x^n])),x]] /;
FreeQ[a,x] && RationalQ[{m,n}] && m>0 && NonzeroQ[m-n+1] *)


(* Int[x_^m_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x^(m+1)/(m+1) -
  Int[x^m*ProductLog[a*x^n]/(1+ProductLog[a*x^n]),x] /;
FreeQ[a,x] && RationalQ[{m,n}] && m<-1 *)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[1/(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  -Subst[Int[1/(x^2*(1+ProductLog[a*x^(-n)])),x],x,1/x] /;
FreeQ[a,x] && IntegerQ[n] && n<0


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[x_^m_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  -Subst[Int[1/(x^(m+2)*(1+ProductLog[a*x^(-n)])),x],x,1/x] /;
FreeQ[a,x] && IntegerQ[{m,n}] && n<0 && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*x^m ProductLog[a x^n]^p / (1+ProductLog[a x^n])*)
(**)


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x^n]^(p-1)/(m+1) /;
FreeQ[{a,m,n,p},x] && ZeroQ[m+n*(p-1)+1] && NonzeroQ[m+1]


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^p*ExpIntegralEi[-p*ProductLog[a*x^n]]/n /;
FreeQ[{a,m,n},x] && IntegerQ[p] && ZeroQ[m+n*p+1]


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_/(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[Pi/(p-1/2)]*Erf[Sqrt[(p-1/2)*ProductLog[a*x^n]]]/n /;
FreeQ[{a,m,n},x] && IntegerQ[p-1/2] && p>1 && ZeroQ[m+n*(p-1/2)+1]


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_/(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  a^(p-1/2)*Sqrt[-Pi/(p-1/2)]*Erfi[Sqrt[-(p-1/2)*ProductLog[a*x^n]]]/n /;
FreeQ[{a,m,n},x] && IntegerQ[p-1/2] && p<0 && ZeroQ[m+n*(p-1/2)+1]


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x^n]^(p-1)/(m+1) -
  Dist[(m+n*(p-1)+1)/(m+1),Int[x^m*ProductLog[a*x^n]^(p-1)/(1+ProductLog[a*x^n]),x]] /;
FreeQ[a,x] && RationalQ[{m,n,p}] && n>0 && NonzeroQ[m+1] && m+n*(p-1)+1>0


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  x^(m+1)*ProductLog[a*x^n]^p/(m+n*p+1) -
  Dist[(m+1)/(m+n*p+1),Int[x^m*ProductLog[a*x^n]^(p+1)/(1+ProductLog[a*x^n]),x]] /;
FreeQ[a,x] && RationalQ[{m,n,p}] && n>0 && NonzeroQ[m+1] && m+n*p+1<0


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: Int[f[x], x] == -Subst[Int[f[1/x]/x^2, x], x, 1/x]*)


Int[x_^m_.*ProductLog[a_.*x_^n_]^p_./(1+ProductLog[a_.*x_^n_]),x_Symbol] :=
  -Subst[Int[ProductLog[a*x^(-n)]^p/(x^(m+2)*(1+ProductLog[a*x^(-n)])),x],x,1/x] /;
FreeQ[{a,p},x] && IntegerQ[{m,n}] && n<0 && NonzeroQ[m+1]


(* ::Subsubsection::Closed:: *)
(*(-ProductLog[a+b x])^p / (1+ProductLog[a+b x])*)


Int[(-ProductLog[a_.+b_.*x_])^p_./(1+ProductLog[a_.+b_.*x_]),x_Symbol] :=
  Gamma[p+1,-ProductLog[a+b*x]]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: 1 == 1/(1+z) - -z/(1+z)*)


Int[(-ProductLog[a_.+b_.*x_])^p_,x_Symbol] :=
  Int[(-ProductLog[a+b*x])^p/(1+ProductLog[a+b*x]),x] -
  Int[(-ProductLog[a+b*x])^(p+1)/(1+ProductLog[a+b*x]),x] /;
FreeQ[{a,b,p},x]


(* ::Subsubsection::Closed:: *)
(*f[ProductLog[a+b x]]*)


(* ::Item::Closed:: *)
(*Derivation: Integration by substitution*)


(* ::Item:: *)
(*Basis: 1/z == (1 + ProductLog[z])/ProductLog[z]*ProductLog'[z]*)


If[ShowSteps,

Int[u_/x_,x_Symbol] :=
  Module[{lst=FunctionOfProductLog[u,x]},
  ShowStep["","Int[f[ProductLog[a*x^n]]/x,x]","Subst[Int[f[x]*(1+x)/x,x],x,ProductLog[a*x^n]]/n",Hold[
  Dist[1/lst[[3]],Subst[Int[Regularize[lst[[1]]*(1+x)/x,x],x],x,ProductLog[lst[[2]]]]]]] /;
 Not[FalseQ[lst]]] /;
SimplifyFlag && NonsumQ[u],

Int[u_/x_,x_Symbol] :=
  Module[{lst=FunctionOfProductLog[u,x]},
  Dist[1/lst[[3]],Subst[Int[Regularize[lst[[1]]*(1+x)/x,x],x],x,ProductLog[lst[[2]]]]] /;
 Not[FalseQ[lst]]] /;
NonsumQ[u]]


(* ::Item:: *)
(*Derivation: Integration by *)


(* Int[x_^m_.*ProductLog[a_.+b_.*x_],x_Symbol] :=
  Dist[1/b^(m+1),Subst[Int[Regularize[(x*E^x-a)^m*x*(x+1)*E^x,x],x],x,ProductLog[a+b*x]]] /;
FreeQ[{a,b},x] && IntegerQ[m] && m>0 *)


(* ::Item::Closed:: *)
(*Author: Rob Corless 2009-07-10*)


(* ::Item:: *)
(*Derivation: Legendre substitution for inverse functions*)


(* ::Item:: *)
(*Basis: ProductLog[z]*E^ProductLog[z] == z*)


Int[u_,x_Symbol] :=
  Subst[Int[Regularize[(x+1)*E^x*SubstFor[ProductLog[x],u,x],x],x],x,ProductLog[x]] /;
FunctionOfQ[ProductLog[x],u,x]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/test/matheclipse/RationalFunctionIntegrationRules.m0000644000175000017500000017467311446257035033673 0ustar  giovannigiovanni(* ::Package:: *)

(* ::Title:: *)
(*Rational Function Integration Rules*)


(* ::Subsection::Closed:: *)
(*a u				Products having constant factors*)


(* ::Item:: *)
(*Reference: CRC 1*)


Int[a_,x_Symbol] :=
   a*x /;
IndependentQ[a,x]


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[c_*(a_+b_.*x_),x_Symbol] :=
  c*(a+b*x)^2/(2*b) /;
FreeQ[{a,b,c},x]


(* ::Item:: *)
(*Reference: G&R 2.02.1, CRC 2*)


If[ShowSteps,

Int[c_*(a_+b_.*x_)^n_,x_Symbol] :=
  ShowStep["","Int[a*u,x]","a*Int[u,x]",Hold[
  Dist[c,Int[(a+b*x)^n,x]]]] /;
SimplifyFlag && FreeQ[{a,b,c,n},x] && NonzeroQ[n+1],

Int[c_*(a_+b_.*x_)^n_,x_Symbol] :=
  Dist[c,Int[(a+b*x)^n,x]] /;
FreeQ[{a,b,c,n},x] && NonzeroQ[n+1]]


(* ::Item:: *)
(*Reference: G&R 2.02.1, CRC 2*)


If[ShowSteps,

Int[a_*u_,x_Symbol] :=
  Module[{lst=ConstantFactor[u,x]},
  ShowStep["","Int[a*u,x]","a*Int[u,x]",Hold[
  Dist[a*lst[[1]],Int[lst[[2]],x]]]]] /;
SimplifyFlag && FreeQ[a,x] && Not[MatchQ[u,b_*v_ /; FreeQ[b,x]]],

Int[a_*u_,x_Symbol] :=
  Module[{lst=ConstantFactor[u,x]},
  Dist[a*lst[[1]],Int[lst[[2]],x]]] /;
FreeQ[a,x] && Not[MatchQ[u,b_*v_ /; FreeQ[b,x]]]]


(* Note: Constant factors in denominators are aggressively factored out to prevent them occurring
	unnecessarily in logarithm terms of antiderivatives! *) 
If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=ConstantFactor[Simplify[Denominator[u]],x]},
  ShowStep["","Int[a*u,x]","a*Int[u,x]",Hold[
  Dist[1/lst[[1]],Int[Numerator[u]/lst[[2]],x]]]] /;
 lst[[1]]=!=1] /;
SimplifyFlag && (
	MatchQ[u,1/(a_+b_.*x) /; FreeQ[{a,b},x]] ||
	MatchQ[u,x^m_./(a_+b_.*x^n_) /; FreeQ[{a,b,m,n},x] && ZeroQ[m-n+1]] ||
	MatchQ[u,1/((a_.+b_.*x)*(c_+d_.*x)) /; FreeQ[{a,b,c,d},x]] ||
	MatchQ[u,(d_.+e_.*x)/(a_+b_.*x+c_.*x^2) /; FreeQ[{a,b,c,d,e},x]] ||
	MatchQ[u,(c_.*(a_.+b_.*x)^n_)^m_ /; FreeQ[{a,b,c,m,n},x] && ZeroQ[m*n+1]]),

Int[u_,x_Symbol] :=
  Module[{lst=ConstantFactor[Simplify[Denominator[u]],x]},
  Dist[1/lst[[1]],Int[Numerator[u]/lst[[2]],x]] /;
 lst[[1]]=!=1] /;
	MatchQ[u,1/(a_+b_.*x) /; FreeQ[{a,b},x]] ||
	MatchQ[u,x^m_./(a_+b_.*x^n_) /; FreeQ[{a,b,m,n},x] && ZeroQ[m-n+1]] ||
	MatchQ[u,1/((a_.+b_.*x)*(c_+d_.*x)) /; FreeQ[{a,b,c,d},x]] ||
	MatchQ[u,(d_.+e_.*x)/(a_+b_.*x+c_.*x^2) /; FreeQ[{a,b,c,d,e},x]] ||
	MatchQ[u,(c_.*(a_.+b_.*x)^n_)^m_ /; FreeQ[{a,b,c,m,n},x] && ZeroQ[m*n+1]]]


(* Note: Constant factors in denominators are aggressively factored out to prevent them occurring
	unnecessarily in logarithm terms of antiderivatives! *) 
If[ShowSteps,

Int[u_/v_,x_Symbol] :=
  Module[{lst=ConstantFactor[v,x]},
  ShowStep["","Int[a*u,x]","a*Int[u,x]",Hold[
  Dist[1/lst[[1]],Int[u/lst[[2]],x]]]] /;
 lst[[1]]=!=1] /;
SimplifyFlag && Not[FalseQ[DerivativeDivides[v,u,x]]],

Int[u_/v_,x_Symbol] :=
  Module[{lst=ConstantFactor[v,x]},
  Dist[1/lst[[1]],Int[u/lst[[2]],x]] /;
 lst[[1]]=!=1] /;
Not[FalseQ[DerivativeDivides[v,u,x]]]]


(* ::Item:: *)
(*Basis: D[f[x]^p*(a*x^n/f[x])^p/x^(n*p),x] == 0*)


(* ??? *)


(* ::Item:: *)
(*Basis: D[x^(n*p)*f[x]^p/(a*x^n*f[x])^p,x] == 0*)


(* ??? *)


(* ::Item:: *)
(*Basis: D[f[x]^m/(-f[x])^m,x] == 0*)


Int[u_.*v_^m_*w_^n_,x_Symbol] :=
  (v^m*w^n)*Int[u,x] /;
FreeQ[{m,n},x] && ZeroQ[m+n] && ZeroQ[v+w]


(* ::Item:: *)
(*Basis: D[(a+b*x^m)^p/(x^(m*p)*(-b-a/x^m)^p),x] == 0*)


Int[u_.*(a_.+b_.*x_^m_.)^p_.*(c_.+d_.*x_^n_.)^q_., x_Symbol] :=
  (a+b*x^m)^p*(c+d*x^n)^q/x^(m*p)*Int[u*x^(m*p),x] /;
FreeQ[{a,b,c,d,m,n,p,q},x] && ZeroQ[a+d] && ZeroQ[b+c] && ZeroQ[m+n] && ZeroQ[p+q]


(* ::Subsection::Closed:: *)
(*(a + b x)^n			Powers of linear binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.2, CRC 27, A&S 3.3.15*)


(* ::Item:: *)
(*Derivation: Reciprocal rule for integration*)


Int[1/(a_+b_.*x_),x_Symbol] :=
  Log[-a-b*x]/b /;
FreeQ[{a,b},x] && NegativeCoefficientQ[a]


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.2, CRC 27, A&S 3.3.15*)


(* ::Item:: *)
(*Derivation: Reciprocal rule for integration*)


Int[1/(a_.+b_.*x_),x_Symbol] :=
  Log[a+b*x]/b /;
FreeQ[{a,b},x]


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.1, CRC 7*)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[x_^n_.,x_Symbol] :=
  x^(n+1)/(n+1) /;
IndependentQ[n,x] && NonzeroQ[n+1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.01.1, CRC 23, A&S 3.3.14*)


(* ::Item:: *)
(*Derivation: Power rule for integration*)


Int[(a_.+b_.*x_)^n_,x_Symbol] :=
  (a+b*x)^(n+1)/(b*(n+1)) /;
FreeQ[{a,b,n},x] && NonzeroQ[n+1]


(* ::Subsection::Closed:: *)
(*a x^m + b x^n + \[CenterEllipsis]		Integrands involving sums of monomials*)


(* ::Item:: *)
(*Reference: CRC 1,2,4,7,9*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  If[PolynomialQ[u,x],
    ShowStep["","Int[a+b*x+c*x^2+\[CenterEllipsis],x]","a*x+b*x^2/2+c*x^3/3+\[CenterEllipsis]",Hold[
    IntegrateMonomialSum[u,x]]],
  ShowStep["","Int[a+b/x+c*x^m+\[CenterEllipsis],x]","a*x+b*Log[x]+c*x^(m+1)/(m+1)+\[CenterEllipsis]",Hold[
  IntegrateMonomialSum[u,x]]]] /;
SimplifyFlag && MonomialSumQ[u,x],

Int[u_,x_Symbol] :=
  IntegrateMonomialSum[u,x] /;
MonomialSumQ[u,x]]


(* u is a monomial sum in x.  IntegrateMonomialSum[u,x] returns the antiderivative of u wrt x
	with the antiderivative of the constants terms of u collected into a single term times x. *)
IntegrateMonomialSum[u_,x_Symbol] :=
  Module[{lst=Map[Function[If[FreeQ[#,x],{#,0},{0,#*x*If[Exponent[#,x]===-1,Log[x],1/(Exponent[#,x]+1)]}]],u]},
  lst[[1]]*x + lst[[2]]]


(* ::Item:: *)
(*Reference: G&R 2.02.2, CRC 2,4*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  Module[{lst=SplitMonomialTerms[u,x]},
  ShowStep["","Int[a*u+b*v+\[CenterEllipsis],x]","a*Int[u,x]+b*Int[v,x]+\[CenterEllipsis]",Hold[
  Int[lst[[1]],x] + SplitFreeIntegrate[lst[[2]],x]]] /;
 SumQ[lst[[1]]] && Not[FreeQ[lst[[1]],x]] && lst[[2]]=!=0] /;
SimplifyFlag && SumQ[u],

Int[u_,x_Symbol] :=
  Module[{lst=SplitMonomialTerms[u,x]},
  Int[lst[[1]],x] + SplitFreeIntegrate[lst[[2]],x] /;
 SumQ[lst[[1]]] && Not[FreeQ[lst[[1]],x]] && lst[[2]]=!=0] /;
SumQ[u]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: z*(u+v) == z*u+z*v*)


If[ShowSteps,

Int[x_^m_.*u_,x_Symbol] :=
  ShowStep["","Int[z*(u+v+\[CenterEllipsis]),x]","Int[z*u+z*v+\[CenterEllipsis],x]",Hold[
  Int[Map[Function[x^m*#],u],x]]] /;
SimplifyFlag && IntegerQ[m] && SumQ[u],

Int[x_^m_.*u_,x_Symbol] :=
  Int[Map[Function[x^m*#],u],x] /;
IntegerQ[m] && SumQ[u]]


(* ::Subsection::Closed:: *)
(*a + b x				Integrands involving linear binomials*)


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x)^n			Products of monomials and powers of linear binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification and integration by substitution*)


(* ::Item:: *)
(*Basis: x*(a+b*x) == -a^2/(4*b)*(1-(1+2*b*x/a)^2)*)


(* ::Item:: *)
(*Substitution: u = 1+2*b*x^n/a*)


Int[1/(x_*(a_+b_.*x_^n_.)),x_Symbol] :=
  -2*ArcTanh[1+2*b*x^n/a]/(a*n) /;
FreeQ[{a,b,n},x] && PosQ[n] && RationalQ[b/a]


(* ::Item::Closed:: *)
(*Reference: G&R 2.118.1, CRC 84*)


(* ::Item:: *)
(*Derivation: Reciprocal rule for integration*)


(* ::Item:: *)
(*Basis: 1/(x*(a+b*x^n)) == 1/(x^(n+1)*(b+a/x^n))*)


Int[1/(x_*(a_+b_.*x_^n_.)),x_Symbol] :=
(* -Log[(a+b*x^n)/x^n]/(a*n) /; *)
  Log[x]/a - Log[a+b*x^n]/(a*n) /;
FreeQ[{a,b,n},x] && PosQ[n] && Not[RationalQ[b/a]]


(* ::Item::Closed:: *)
(*Reference: G&R 2.118.1, CRC 84*)


(* ::Item:: *)
(*Derivation: Reciprocal rule for integration*)


(* ::Item:: *)
(*Basis: 1/(x*(a+b*x^n)) == 1/(x^(n+1)*(b+a/x^n))*)


Int[1/(x_*(a_+b_.*x_^n_.)),x_Symbol] :=
  -Log[b+a*x^(-n)]/(a*n) /;
FreeQ[{a,b,n},x] && NegQ[n]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a*x+b*x^n == x*(a+b*x^(n-1))*)


Int[1/(a_.*x_+b_.*x_^n_),x_Symbol] :=
  Int[1/(x*(a+b*x^(n-1))),x] /;
FreeQ[{a,b,n},x]


(* ::Item:: *)
(*Reference: G&R 2.110.2, CRC 26b special case*)


Int[x_^m_.*(a_+b_.*x_)^n_,x_Symbol] :=
  -x^(m+1)*(a+b*x)^(n+1)/(a*(n+1)) /;
FreeQ[{a,b,m,n},x] && ZeroQ[m+n+2] && NonzeroQ[n+1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.2, CRC 26b*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m (a+b*x)^n == x^(m+n+2) ((a+b*x)^n / x^(n+2))*)


Int[x_^m_.*(a_+b_.*x_)^n_,x_Symbol] :=
  -x^(m+1)*(a+b*x)^(n+1)/(a*(n+1)) +
  Dist[(m+n+2)/(a*(n+1)),Int[x^m*(a+b*x)^(n+1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && 00


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.1, CRC 26a*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_*(a_.+b_.*x_)^n_.,x_Symbol] :=
  x^(m+1)*(a+b*x)^n/(m+n+1) +
  Dist[a*n/(m+n+1),Int[x^m*(a+b*x)^(n-1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && 00


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.5, CRC 26c*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[x_^m_.*(a_.+b_.*x_)^n_,x_Symbol] :=
  x^m*(a+b*x)^(n+1)/(b*(m+n+1)) -
  Dist[a*m/(b*(m+n+1)),Int[x^(m-1)*(a+b*x)^n,x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && 00


(* ::Item::Closed:: *)
(*Reference: G&R 2.151, CRC 59b*)


(* ::Item:: *)
(*Derivation: Inverted integration by parts*)


Int[(a_+b_.*x_)^m_*(c_+d_.*x_)^n_.,x_Symbol] :=
  (a+b*x)^(m+1)*(c+d*x)^n/(b*(m+n+1)) +
  Dist[n*(b*c-a*d)/(b*(m+n+1)),Int[(a+b*x)^m*(c+d*x)^(n-1),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[{m,n}] && NonzeroQ[b*c-a*d] && 05


Int[x_^m_*(a_+b_.*x_)^n_.*(c_+d_.*x_)^p_.,x_Symbol] :=
  x^(m-1)*(a+b*x)^(n+1)*(c+d*x)^(p+1)/(b*d*(1+m+n+p)) - 
  Dist[a*c*(m-1)/(b*d*(1+m+n+p)), Int[x^(m-2)*(a+b*x)^n*(c+d*x)^p, x]] - 
  Dist[(b*c*(m+n)+a*d*(m+p))/(b*d*(1+m+n+p)), Int[x^(m-1)*(a+b*x)^n*(c+d*x)^p, x]] /;
FreeQ[{a,b,c,d,n,p},x] && IntegerQ[{m,n,p}] && 05


(* ::Subsection::Closed:: *)
(*a + b x^n			Integrands involving nonlinear binomials*)


(* ::Subsubsection::Closed:: *)
(*1 / (a+b x^n)				Reciprocals of binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.124.1a, CRC 60, A&S 3.3.21*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ArcTan'[z] == 1/(1+z^2)*)


Int[1/(a_+b_.*x_^2),x_Symbol] :=
  Rt[b/a,2]*ArcTan[Rt[b/a,2]*x]/b /;
FreeQ[{a,b},x] && PosQ[a/b]


(* ::Item::Closed:: *)
(*Reference: G&R 2.124.1b', CRC 61b, A&S 3.3.23*)


(* ::Item:: *)
(*Derivation: Primitive rule*)


(* ::Item:: *)
(*Basis: ArcTanh'[z] == 1/(1-z^2)*)


Int[1/(a_+b_.*x_^2),x_Symbol] :=
  -Rt[-b/a,2]*ArcTanh[Rt[-b/a,2]*x]/b /;
FreeQ[{a,b},x] && NegQ[a/b]


(* ::Item::Closed:: *)
(*Reference: G&R 2.126.1.2, CRC 74*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis:  If q=(a/b)^(1/3), 1/(a+b*z^3) == q/(3*a*(q+z)) + q/(3*a)*(2*q-z)/(q^2-q*z+z^2)*)


Int[1/(a_+b_.*x_^3),x_Symbol] :=
  Module[{r=Numerator[Rt[a/b,3]], s=Denominator[Rt[a/b,3]]},
  Dist[r/(3*a),Int[1/(r+s*x),x]] +
  Dist[r/(3*a),Int[(2*r-s*x)/(r^2-r*s*x+s^2*x^2),x]]] /;
FreeQ[{a,b},x] && PosQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis:  If q=(-a/b)^(1/3), 1/(a+b*z^3) == q/(3*a*(q-z)) + q/(3*a)*(2*q+z)/(q^2+q*z+z^2)*)


Int[1/(a_+b_.*x_^3),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,3]], s=Denominator[Rt[-a/b,3]]},
  Dist[r/(3*a),Int[1/(r-s*x),x]] +
  Dist[r/(3*a),Int[(2*r+s*x)/(r^2+r*s*x+s^2*x^2),x]]] /;
FreeQ[{a,b},x] && NegQ[a/b]


(* ::Item::Closed:: *)
(*Reference: G&R 2.132.1.1', CRC 77'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis:  If q=(a/b)^(1/4), 1/(a+b*z^4) == *)
(*	q/(2*Sqrt[2]*a)*(Sqrt[2]*q-z)/(q^2-Sqrt[2]*q*z+z^2) + q/(2*Sqrt[2]*a)*(Sqrt[2]*q+z)/(q^2+Sqrt[2]*q*z+z^2)*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[a/b,4]], s=Denominator[Rt[a/b,4]]},
  Dist[r/(2*Sqrt[2]*a),Int[(Sqrt[2]*r-s*x^(n/4))/(r^2-Sqrt[2]*r*s*x^(n/4)+s^2*x^(n/2)),x]] +
  Dist[r/(2*Sqrt[2]*a),Int[(Sqrt[2]*r+s*x^(n/4))/(r^2+Sqrt[2]*r*s*x^(n/4)+s^2*x^(n/2)),x]]] /;
FreeQ[{a,b},x] && EvenQ[n/2] && n>2 && PosQ[a/b]


(* ::Item::Closed:: *)
(*Reference: G&R 2.132.1.2', CRC 78'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis:  If q=Sqrt[-a/b], 1/(a+b*z^2) == q/(2*a*(q-z)) + q/(2*a*(q+z))*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,2]], s=Denominator[Rt[-a/b,2]]},
  Dist[r/(2*a),Int[1/(r-s*x^(n/2)),x]] +
  Dist[r/(2*a),Int[1/(r+s*x^(n/2)),x]]] /;
FreeQ[{a,b},x] && EvenQ[n/2] && n>2 && NegQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is even and q=(a/b)^(1/n), 1/(a+b*x^n) == Sum[2 q (q-Cos[(2 k-1) Pi/n] x)/(a n (q^2-2 q Cos[(2 k-1) Pi/n] x+x^2)), {k,1,n/2}]*)


(* ::Item:: *)
(*Basis: If n/2>0 is odd and q=(a/b)^(2/n), 1/(a+b*x^n) == 2*q/(a*n*(q+x^2)) +*)
(*	4*q/(a*n)*Sum[(q-Cos[2*(2*k-1)*Pi/n]*x^2)/(q^2-2*q*Cos[2*(2*k-1)*Pi/n]*x^2+x^4), {k, 1, (n/2-1)/2}]*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[a/b,n/2]], s=Denominator[Rt[a/b,n/2]]},
  Dist[2*r/(a*n),Int[1/(r+s*x^2),x]] +
  Dist[4*r/(a*n),Int[Sum[(r-s*Cos[2*(2*k-1)*Pi/n]*x^2)/(r^2-2*r*s*Cos[2*(2*k-1)*Pi/n]*x^2+s^2*x^4),{k,1,(n/2-1)/2}],x]]] /;
FreeQ[{a,b},x] && OddQ[n/2] && n>2 && PosQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is even and q=(-a/b)^(1/n), 1/(a+b*x^n) == 2 q^2/(n a (q^2-x^2)) + Sum[2 q (q-Cos[2 k Pi/n] x)/(a n (q^2-2 q Cos[2 k Pi/n] x+x^2)), {k,1,n/2-1}]*)


(* ::Item:: *)
(*Basis: If n/2>0 is odd and q=(-a/b)^(2/n), 1/(a+b*x^n) == 2*q/(a*n*(q-x^2)) +*)
(*	4*q/(a*n)*Sum[(q-Cos[4*k*Pi/n]*x^2)/(q^2-2*q*Cos[4*k*Pi/n]*x^2+x^4), {k, 1, (n/2-1)/2}]*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,n/2]], s=Denominator[Rt[-a/b,n/2]]},
  Dist[2*r/(a*n),Int[1/(r-s*x^2),x]] +
  Dist[4*r/(a*n),Int[Sum[(r-s*Cos[4*k*Pi/n]*x^2)/(r^2-2*r*s*Cos[4*k*Pi/n]*x^2+s^2*x^4),{k,1,(n/2-1)/2}],x]]] /;
FreeQ[{a,b},x] && OddQ[n/2] && n>2 && NegQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is odd and q=(a/b)^(1/n), 1/(a+b*x^n) == q/(a n (q+x)) + Sum[2 q (q-Cos[(2 k-1) Pi/n] x)/(a n (q^2-2 q Cos[(2 k-1) Pi/n] x+x^2)), {k,1,(n-1)/2}]*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[a/b,n]], s=Denominator[Rt[a/b,n]]},
  Int[r/(a*n*(r+s*x)) + 
	Sum[2*r*(r-s*Cos[(2*k-1)*Pi/n]*x)/(a*n*(r^2-2*r*s*Cos[(2*k-1)*Pi/n]*x+s^2*x^2)), {k,1,(n-1)/2}],x]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1 && PosQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is odd and q=(-a/b)^(1/n), 1/(a+b*x^n) == q/(a n (q-x)) + Sum[2 q (q+Cos[(2 k-1) Pi/n] x)/(a n (q^2+2 q Cos[(2 k-1) Pi/n] x+x^2)), {k,1,(n-1)/2}]*)


Int[1/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,n]], s=Denominator[Rt[-a/b,n]]},
  Int[r/(a*n*(r-s*x)) + 
	Sum[2*r*(r+s*Cos[(2*k-1)*Pi/n]*x)/(a*n*(r^2+2*r*s*Cos[(2*k-1)*Pi/n]*x+s^2*x^2)), {k,1,(n-1)/2}],x]] /;
FreeQ[{a,b},x] && OddQ[n] && n>1 && NegQ[a/b]


(* ::Subsubsection::Closed:: *)
(*x^m / (a+b x^n)			Quotients of monomials by binomials*)


(* ::Item::Closed:: *)
(*Reference: G&R 2.126.2, CRC 75*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Let q=(a/b)^(1/3), then x/(a+b*x^3) == -q^2/(3*a*(q+x)) + q^2/(3*a)*(q+x)/(q^2-q*x+x^2)*)


Int[x_/(a_+b_.*x_^3),x_Symbol] :=
  Module[{r=Numerator[Rt[a/b,3]], s=Denominator[Rt[a/b,3]]},
  Dist[-r^2/(3*a*s),Int[1/(r+s*x),x]] +
  Dist[r^2/(3*a*s),Int[(r+s*x)/(r^2-r*s*x+s^2*x^2),x]]] /;
FreeQ[{a,b},x] && PosQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Let q=(-a/b)^(1/3), then x/(a+b*x^3) == q^2/(3*a*(q-x)) - q^2/(3*a)*(q-x)/(q^2+q*x+x^2)*)


Int[x_/(a_+b_.*x_^3),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,3]], s=Denominator[Rt[-a/b,3]]},
  Dist[r^2/(3*a*s),Int[1/(r-s*x),x]] -
  Dist[r^2/(3*a*s),Int[(r-s*x)/(r^2+r*s*x+s^2*x^2),x]]] /;
FreeQ[{a,b},x] && NegQ[a/b]


(* ::Item:: *)
(*Derivation: Integration by substitution*)


Int[x_^m_./(a_+b_.*x_^n_),x_Symbol] :=
  Module[{g=GCD[m+1,n]},
  Dist[1/g,Subst[Int[x^((m+1)/g-1)/(a+b*x^(n/g)),x],x,x^g]] /;
 g>1] /;
FreeQ[{a,b},x] && IntegerQ[{m,n}] && 00 && n===2*m && PosQ[a/b]


(* ::Item::Closed:: *)
(*Reference: G&R 2.132.3.2', CRC 82'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Let q=Sqrt[-a/b], then z/(a+b*z^2) == 1/(2*b*(q+z)) - 1/(2*b*(q-z))*)


(* ::Item:: *)
(*Basis: Let q=Sqrt[-a/b], then x^m/(a+b*x^(2*m)) == 1/(2*b*(q+x^m)) - 1/(2*b*(q-x^m))*)


Int[x_^m_/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{r=Numerator[Rt[-a/b,2]], s=Denominator[Rt[-a/b,2]]},
  Dist[s/(2*b),Int[1/(r+s*x^m),x]] -
  Dist[s/(2*b),Int[1/(r-s*x^m),x]]] /;
FreeQ[{a,b},x] && EvenQ[m] && m>0 && n===2*m && NegQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If n>0 is even and 0<=m0 is odd, m is even and 0<=m0 is odd, m is even and 0<=m0 is odd and 0<=m0 is odd and 0<=m1 when m is odd and n even:*)


(* ::Item:: *)
(*Basis: If m is odd and n is even and 0<=m0 && n===2*m && PosQ[a/b]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: Let q=Sqrt[-a/b], then (c+d*x^m)/(a+b*x^(2*m)) == (c+d*q)/(2*(a+b*q*x^m)) + (c-d*q)/(2*(a-b*q*x^m))*)


Int[(c_.+d_.*x_^m_)/(a_+b_.*x_^n_),x_Symbol] :=
  Module[{q=Rt[-a/b,2]},
  Dist[(c+d*q)/2, Int[1/(a+b*q*x^m),x]] +
  Dist[(c-d*q)/2, Int[1/(a-b*q*x^m),x]]] /;
FreeQ[{a,b,c,d},x] && EvenQ[m] && m>0 && n===2*m && NegQ[a/b] && NonzeroQ[b*c^2+a*d^2]


(* ::Subsubsection::Closed:: *)
(*(a+b x^n)^p				Powers of binomials*)


(* ::Item:: *)
(*Reference: G&R 2.110.2, CRC 88d special case*)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x*(a+b*x^n)^(p+1)/a /;
FreeQ[{a,b,n,p},x] && ZeroQ[n*(p+1)+1]


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.2, CRC 88d*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: (a+b*x^n)^p == x^(n*(p+1)+1) * ((a+b*x^n)^p/x^(n*(p+1)+1))*)


(* ::Item:: *)
(*Basis: Int[(a+b*x^n)^p/x^(n*(p+1)+1),x] == -((a+b*x^n)^(p+1)/(x^(n*(p+1))*(a*n*(p+1))))*)


(* ::Item:: *)
(*Note: Requirement that n>1 ensures new term is a proper fraction.*)


Int[(a_+b_.*x_^n_)^p_,x_Symbol] :=
  -x*(a+b*x^n)^(p+1)/(a*n*(p+1)) + 
  Dist[(n*(p+1)+1)/(a*n*(p+1)),Int[(a+b*x^n)^(p+1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{n,p}] && n>1 && p<-1


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^n)^p			Products of monomials and powers of binomials*)


(* ::Item:: *)
(*Reference: G&R 2.110.6, CRC 88c special case*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x^(m+1)*(a+b*x^n)^(p+1)/(a*(m+1)) /;
FreeQ[{a,b,m,n,p},x] && ZeroQ[m+n*(p+1)+1] && NonzeroQ[m+1] && NonzeroQ[p+2]


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.4*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m (a+b*x^n)^p == x^(m-n+1) * ((a+b*x^n)^p*x^(n-1))*)


(* ::Item:: *)
(*Basis: Int[(a+b*x^n)^p*x^(n-1),x] == (a+b*x^n)^(p+1)/(b*n*(p+1))*)


(* ::Item:: *)
(*Note: Requirement that m<2 n-1 ensures new term is a proper fraction.*)


Int[x_^m_.*(a_+b_.*x_^n_)^p_,x_Symbol] :=
  x^(m-n+1)*(a+b*x^n)^(p+1)/(b*n*(p+1)) - 
  Dist[(m-n+1)/(b*n*(p+1)),Int[x^(m-n)*(a+b*x^n)^(p+1),x]] /;
FreeQ[{a,b},x] && IntegerQ[{m,n,p}] && n>1 && p<-1 && n<=m<2*n-1


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.2, CRC 88d*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m (a+b*x^n)^p == x^(m+n*(p+1)+1) ((a+b*x^n)^p/x^(n*(p+1)+1))*)


(* ::Item:: *)
(*Basis: Int[(a+b*x^n)^p/x^(n*(p+1)+1),x] == -((a+b*x^n)^(p+1)/(x^(n*(p+1))*(a*n*(p+1))))*)


(* ::Item:: *)
(*Note: Requirement that m+11 && 00 && 
IntegerQ[(m+n*(p+1)+1)/n] && 00 && ExpandIntegrandQ[m,n,p]


(* ::Item::Closed:: *)
(*Reference: G&R 2.110.4*)


(* ::Item:: *)
(*Derivation: Integration by parts*)


(* ::Item:: *)
(*Basis: x^m (a+b*x^n)^p == x^(m-n+1) ((a+b*x^n)^p x^(n-1))*)


(* ::Item:: *)
(*Note: Requirement that m<2 n-1 ensures new term is a proper fraction.*)


(* ::Item:: *)
(*Note: Unfortunately this rule is necessary to prevent the Ostrogradskiy-Hermite method from being applied instead of substituting for c+d x.*)


Int[(c_+d_.*x_)^m_.*(a_+b_.*(c_+d_.*x_)^n_)^p_,x_Symbol] :=
  (c+d*x)^(m-n+1)*(a+b*(c+d*x)^n)^(p+1)/(b*d*n*(p+1)) - 
  Dist[(m-n+1)/(b*n*(p+1)),Int[(c+d*x)^(m-n)*(a+b*(c+d*x)^n)^(p+1),x]] /;
FreeQ[{a,b,c,d},x] && IntegerQ[{m,n,p}] && n>1 && p<-1 && n<=m<2*n-1


(* ::Subsubsection::Closed:: *)
(*(a+b x^n)^m / (b+a/x^n)		Quotients of powers of monomials and monomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: (a+b*x^n)/(b+a/x^n) == x^n*)


Int[(a_+b_.*x_^n_.)^m_/(b_+a_.*x_^p_.),x_Symbol] :=
  Int[x^n*(a+b*x^n)^(m-1), x] /;
FreeQ[{a,b,m,n,p},x] && ZeroQ[n+p]


(* ::Subsection::Closed:: *)
(*a + b x + c x^2		Integrands involving quadratic trinomials*)


(* ::Subsubsection::Closed:: *)
(*(a+b x+c x^2)^n			Powers of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Reference: A&S 3.3.18*)


(* ::Item:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*z+c*z^2 == (b/2+c*z)^2/c*)


Int[(a_+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  Int[(b/2+c*x)^(2*n),x]/c^n /;
FreeQ[{a,b,c},x] && IntegerQ[n] && ZeroQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.172.2, CRC 110a, A&S 3.3.17*)


(* ::Item:: *)
(*Derivation: Algebraic simplification and integration by substitution*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4 a c], a+b x+c x^2 == -q^2/(4 c) (1-((b+2 c x)/q)^2)*)


(* ::Item:: *)
(*Substitution: u = (b+2 c x)/q where q = Sqrt[b^2-4 a c]*)


Int[1/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  -2*ArcTanh[b/q+2*c*x/q]/q /;
 SqrtNumberQ[q] && RationalQ[b/q]] /;
FreeQ[{a,b,c},x] && PosQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.172.2, CRC 110a, A&S 3.3.17*)


(* ::Item:: *)
(*Derivation: Algebraic simplification and integration by substitution*)


(* ::Item:: *)
(*Basis: If q=Sqrt[b^2-4 a c], a+b x+c x^2 == -q^2/(4 c) (1-((b+2 c x)/q)^2)*)


(* ::Item:: *)
(*Substitution: u = (b+2 c x)/q where q = Sqrt[b^2-4 a c]*)


Int[1/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  -2*ArcTanh[(b+2*c*x)/Rt[b^2-4*a*c,2]]/Rt[b^2-4*a*c,2] /;
FreeQ[{a,b,c},x] && PosQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.172.4, CRC 109, A&S 3.3.16*)


(* ::Item:: *)
(*Derivation: Algebraic simplification and integration by substitution*)


(* ::Item:: *)
(*Basis: If q = Sqrt[4 a c-b^2], a+b x+c x^2 == q^2/(4 c) (1+((b+2 c x)/q)^2)*)


(* ::Item:: *)
(*Substitution: u = (b+2 c x)/q where q = Sqrt[4 a c-b^2]*)


Int[1/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  Module[{q=Rt[4*a*c-b^2,2]},
  2*ArcTan[b/q+2*c*x/q]/q /;
 SqrtNumberQ[q] && RationalQ[b/q]] /;
FreeQ[{a,b,c},x] && NegQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.172.4, CRC 109, A&S 3.3.16*)


(* ::Item:: *)
(*Derivation: Algebraic simplification and integration by substitution*)


(* ::Item:: *)
(*Basis: If q = Sqrt[4 a c-b^2], a+b x+c x^2 == q^2/(4 c) (1+((b+2 c x)/q)^2)*)


(* ::Item:: *)
(*Substitution: u = (b+2 c x)/q where q = Sqrt[4 a c-b^2]*)


Int[1/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  2*ArcTan[(b+2*c*x)/Rt[4*a*c-b^2,2]]/Rt[4*a*c-b^2,2] /;
FreeQ[{a,b,c},x] && NegQ[b^2-4*a*c]


(* ::Item:: *)
(*Reference: G&R 2.264.5, CRC 239*)


Int[1/(a_.+b_.*x_+c_.*x_^2)^(3/2),x_Symbol] :=
  -2*(b+2*c*x)/((b^2-4*a*c)*Sqrt[a+b*x+c*x^2]) /;
FreeQ[{a,b,c},x] && NonzeroQ[b^2-4*a*c]


(* ::Item:: *)
(*Reference: G&R 2.171.3, GR5 2.263.3, CRC 113,241*)


Int[(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  (b+2*c*x)*(a+b*x+c*x^2)^(n+1)/((n+1)*(b^2-4*a*c)) -
  Dist[2*c*(2*n+3)/((n+1)*(b^2-4*a*c)),Int[(a+b*x+c*x^2)^(n+1),x]] /;
FreeQ[{a,b,c},x] && RationalQ[n] && n<-1 && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*(d+e x) / (a+b x+c x^2)			Quotients of linears by quadratic trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.175.1, CRC 114*)


Int[(d_.+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*Log[-a-b*x-c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[2*c*d-b*e] && NegativeCoefficientQ[a]


(* ::Item:: *)
(*Reference: G&R 2.175.1, CRC 114*)


Int[(d_.+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*Log[a+b*x+c*x^2]/(2*c) /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[2*c*d-b*e]


(* ::Item:: *)
(*Reference: A&S 3.3.19*)


Int[(d_.+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*Log[-a-b*x-c*x^2]/(2*c) +
  Dist[Simplify[(2*c*d-b*e)/(2*c)],Int[1/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e},x] && Not[RationalQ[Rt[b^2-4*a*c,2]]] && NonzeroQ[a*e^2+c*d^2-b*d*e] && 
NegativeCoefficientQ[a]


(* ::Item:: *)
(*Reference: A&S 3.3.19*)


Int[(d_.+e_.*x_)/(a_+b_.*x_+c_.*x_^2),x_Symbol] :=
  e*Log[a+b*x+c*x^2]/(2*c) +
  Dist[Simplify[(2*c*d-b*e)/(2*c)],Int[1/(a+b*x+c*x^2),x]] /;
FreeQ[{a,b,c,d,e},x] && Not[RationalQ[Rt[b^2-4*a*c,2]]] && NonzeroQ[a*e^2+c*d^2-b*d*e]


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m (a+c x^2)^n			Products of powers of linears and powers of quadratic binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a*e^2+c*d^2==0, a+c*x^2 == (d+e*x)*(a/d+c/e*x)*)


Int[(d_+e_.*x_)^m_.*(a_+c_.*x_^2)^n_.,x_Symbol] :=
  Int[(d+e*x)^(m+n)*(a/d+c/e*x)^n,x] /;
FreeQ[{a,c,d,e,m},x] && IntegerQ[n] && ZeroQ[a*e^2+c*d^2]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_+e_.*x_)*(a_.+c_.*x_^2)^n_,x_Symbol] :=
  e*(a+c*x^2)^(n+1)/(2*c*(n+1)) +
  Dist[d,Int[(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && NonzeroQ[n+1] && Not[IntegerQ[n] && n>0]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_+e_.*x_)^m_*(a_.+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+c*x^2)^(n+1)/(c*(m+2*n+1)) -
  Dist[(a*e^2+c*d^2)*(m-1)/(c*(m+2*n+1)),Int[(d+e*x)^(m-2)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e},x] && RationalQ[{m,n}] && m>1 && ZeroQ[m+n]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_+e_.*x_)^m_.*(a_.+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+c*x^2)^(n+1)/(c*(m+2*n+1)) +
  Dist[2*c*d*(m+n)/(c*(m+2*n+1)),Int[(d+e*x)^(m-1)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+2*n+1] && Not[IntegerQ[n] && n>=-1] &&
ZeroQ[a*e^2+c*d^2]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


(* Int[(d_+e_.*x_)^m_*(a_.+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+c*x^2)^(n+1)/(c*(m+2*n+1)) +
  Dist[2*c*d*(m+n)/(c*(m+2*n+1)),Int[(d+e*x)^(m-1)*(a+c*x^2)^n,x]] -
  Dist[(a*e^2+c*d^2)*(m-1)/(c*(m+2*n+1)),Int[(d+e*x)^(m-2)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+2*n+1] && Not[IntegerQ[n] && n>=-1] *)


Int[(d_+e_.*x_)^m_*(a_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^m*(a+c*x^2)^(n+1)/(2*c*d*(n+1)) /;
FreeQ[{a,c,d,e,n},x] && ZeroQ[c*d^2+a*e^2] && ZeroQ[m+2*(n+1)] && NonzeroQ[n+1]


Int[(d_+e_.*x_)^m_*(a_+c_.*x_^2)^n_,x_Symbol] :=
  -e*(d+e*x)^m*(a+c*x^2)^(n+1)/(2*c*d*(m+n+1)) +
  Dist[(m+2*(n+1))/(2*d*(m+n+1)),Int[(d+e*x)^(m+1)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && RationalQ[m] && m<-1 && ZeroQ[c*d^2+a*e^2] && NonzeroQ[m+n+1]


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


Int[(d_+e_.*x_)^m_*(a_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m+1)*(a+c*x^2)^(n+1)/((m+1)*(c*d^2+a*e^2)) +
  Dist[2*c*d*(m+n+2)/((m+1)*(c*d^2+a*e^2)),Int[(d+e*x)^(m+1)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && RationalQ[m] && m<-1 && NonzeroQ[c*d^2+a*e^2] && 
Not[IntegerQ[n] && n>=-1] && ZeroQ[m+2*n+3]


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


(* Int[(d_+e_.*x_)^m_*(a_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m+1)*(a+c*x^2)^(n+1)/((m+1)*(c*d^2+a*e^2)) +
  Dist[2*c*d*(m+n+2)/((m+1)*(c*d^2+a*e^2)),Int[(d+e*x)^(m+1)*(a+c*x^2)^n,x]] -
  Dist[c*(m+2*n+3)/((m+1)*(c*d^2+a*e^2)),Int[(d+e*x)^(m+2)*(a+c*x^2)^n,x]] /;
FreeQ[{a,c,d,e,n},x] && RationalQ[m] && m<-1 && NonzeroQ[c*d^2+a*e^2] && 
Not[IntegerQ[n] && n>=-1] && NonzeroQ[m+2*n+3] *)


(* ::Subsubsection::Closed:: *)
(*(d+e x)^m (a+b x+c x^2)^n		Products of powers of linears and powers of quadratic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If a*e^2+c*d^2==b*d*e, a+b*x+c*x^2 == (d+e*x)*(a/d+c/e*x)*)


Int[(d_+e_.*x_)^m_.*(a_.+b_.*x_+c_.*x_^2)^n_.,x_Symbol] :=
  Int[(d+e*x)^(m+n)*(a/d+c/e*x)^n,x] /;
FreeQ[{a,b,c,d,e,m},x] && IntegerQ[n] && ZeroQ[a*e^2+c*d^2-b*d*e]


(* ::Item:: *)
(*Reference: G&R 2.174.2*)


Int[(d_.+e_.*x_)^m_*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  -e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m-1)) +
  Dist[e^2/c,Int[(d+e*x)^(m-2)*(a+b*x+c*x^2)^(n+1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[{m,n}] && n<-1 && ZeroQ[m+2*n+1] && ZeroQ[2*c*d-b*e]


(* ::Item:: *)
(*Reference: G&R 2.174.2*)


(* Int[(d_.+e_.*x_)^m_*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  -e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m-1)) +
  Dist[(2*c*d-b*e)/(2*c),Int[(d+e*x)^(m-1)*(a+b*x+c*x^2)^n,x]] +
  Dist[e^2/c,Int[(d+e*x)^(m-2)*(a+b*x+c*x^2)^(n+1),x]] /;
FreeQ[{a,b,c,d,e},x] && RationalQ[{m,n}] && n<-1 && ZeroQ[m+2*n+1] *)


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_.+e_.*x_)*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(a+b*x+c*x^2)^(n+1)/(2*c*(n+1)) /;
FreeQ[{a,b,c,d,e,n},x] && ZeroQ[2*c*d-b*e] && NonzeroQ[n+1]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_.+e_.*x_)*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(a+b*x+c*x^2)^(n+1)/(2*c*(n+1)) +
  Dist[(2*c*d-b*e)/(2*c),Int[(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && NonzeroQ[n+1] && Not[IntegerQ[n] && n>0]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


(* Int[(d_.+e_.*x_)^m_.*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(2*n+m+1)) /;
FreeQ[{a,b,c,d,e,m,n},x] && ZeroQ[2*c*d-b*e] && NonzeroQ[2*n+m+1] && ZeroQ[b^2-4*a*c] *)


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_.+e_.*x_)^m_*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m+2*n+1)) -
  Dist[(e*(a*e-b*d)+c*d^2)*(m-1)/(c*(m+2*n+1)),Int[(d+e*x)^(m-2)*(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+2*n+1] && Not[IntegerQ[n] && n>=-1] && 
(ZeroQ[m+n] || ZeroQ[2*c*d-b*e])


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


Int[(d_.+e_.*x_)^m_.*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m+2*n+1)) +
  Dist[(2*c*d-b*e)*(m+n)/(c*(m+2*n+1)),Int[(d+e*x)^(m-1)*(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+2*n+1] && Not[IntegerQ[n] && n>=-1] &&
ZeroQ[e*(a*e-b*d)/c+d^2]


(* ::Item:: *)
(*Reference: G&R 2.174.1, CRC 119*)


(* Int[(d_.+e_.*x_)^m_*(a_.+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m-1)*(a+b*x+c*x^2)^(n+1)/(c*(m+2*n+1)) +
  Dist[(2*c*d-b*e)*(m+n)/(c*(m+2*n+1)),Int[(d+e*x)^(m-1)*(a+b*x+c*x^2)^n,x]] -
  Dist[(e*(a*e-b*d)/c+d^2)*(m-1)/(m+2*n+1),Int[(d+e*x)^(m-2)*(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[m] && m>1 && NonzeroQ[m+2*n+1] && Not[IntegerQ[n] && n>=-1] *)


(* ::Item:: *)
(*Reference: G&R 2.265c*)


Int[x_^m_*(b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  x^m*(b*x+c*x^2)^(n+1)/(b*(m+n+1)) /;
FreeQ[{b,c,m,n},x] && NonzeroQ[m+n+1] && ZeroQ[m+2*(n+1)]


(* ::Item:: *)
(*Reference: G&R 2.265c*)


Int[x_^m_*(b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  x^m*(b*x+c*x^2)^(n+1)/(b*(m+n+1)) - 
  Dist[c*(m+2*(n+1))/(b*(m+n+1)),Int[x^(m+1)*(b*x+c*x^2)^n,x]] /;
FreeQ[{b,c,n},x] && RationalQ[m] && m<-1 && NonzeroQ[m+n+1] && Not[IntegerQ[n] && n>=-1]


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


Int[(d_.+e_.*x_)^m_*(a_+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m+1)*(a+b*x+c*x^2)^(n+1)/((m+1)*(c*d^2+a*e^2-b*d*e)) +
  Dist[(2*c*d-b*e)*(m+n+2)/((m+1)*(c*d^2+a*e^2-b*d*e)),Int[(d+e*x)^(m+1)*(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[m] && m<-1 && NonzeroQ[c*d^2+a*e^2-b*d*e] && 
Not[IntegerQ[n] && n>=-1] && ZeroQ[m+2*n+3]


(* ::Item:: *)
(*Reference: G&R 2.176, CRC 123*)


(* Int[(d_.+e_.*x_)^m_*(a_+b_.*x_+c_.*x_^2)^n_,x_Symbol] :=
  e*(d+e*x)^(m+1)*(a+b*x+c*x^2)^(n+1)/((m+1)*(c*d^2+a*e^2-b*d*e)) +
  Dist[(2*c*d-b*e)*(m+n+2)/((m+1)*(c*d^2+a*e^2-b*d*e)),Int[(d+e*x)^(m+1)*(a+b*x+c*x^2)^n,x]] -
  Dist[c*(m+2*n+3)/((m+1)*(c*d^2+a*e^2-b*d*e)),Int[(d+e*x)^(m+2)*(a+b*x+c*x^2)^n,x]] /;
FreeQ[{a,b,c,d,e,n},x] && RationalQ[m] && m<-1 && NonzeroQ[c*d^2+a*e^2-b*d*e] && 
Not[IntegerQ[n] && n>=-1] && NonzeroQ[m+2*n+3] *)


(* ::Subsection::Closed:: *)
(*a + b x^k + c x^(2k)		Integrands involving symmetric trinomials*)


(* ::Subsubsection::Closed:: *)
(*(d+e x^2)/(a+b x^2+c x^4)			Quotients of binomials by quartic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: If b^2-4*a*c=0, a+b*z^2+c*z^4 == (b/2+c*z^2)^2/c*)


Int[u_./(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Dist[c,Int[u/(b/2+c*x^2)^2,x]] /;
FreeQ[{a,b,c},x] && ZeroQ[b^2-4*a*c] && PolynomialQ[u,x]


(* Previously undiscovered rules ??? *)


Int[(d_+e_.*x_^2)/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  d/(a*Rt[(d*b+2*e*a)/(d*a),2])*ArcTan[d*Rt[(d*b+2*e*a)/(d*a),2]*x/(d-e*x^2)] /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[d^2*c-e^2*a] && PosQ[(d*b+2*e*a)/(d*a)]


Int[(d_+e_.*x_^2)/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  d/(a*Rt[-(d*b+2*e*a)/(d*a),2])*ArcTanh[d*Rt[-(d*b+2*e*a)/(d*a),2]*x/(d-e*x^2)] /;
FreeQ[{a,b,c,d,e},x] && ZeroQ[d^2*c-e^2*a] && NegQ[(d*b+2*e*a)/(d*a)]


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[a/c], then 1/(a+b*x^2+c*x^4) == c*q*(q+x^2)/(2*a*(a+b*x^2+c*x^4)) + c*q*(q-x^2)/(2*a*(a+b*x^2+c*x^4))*)


Int[1/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[a/c,2]},
  Dist[c*q/(2*a),Int[(q+x^2)/(a+b*x^2+c*x^4),x]] +
  Dist[c*q/(2*a),Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c},x] && PosQ[a/c] &&
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[-a/c], then 1/(a+b*x^2+c*x^4) == -c*q/(2*a)*(q+x^2)/(a+b*x^2+c*x^4) - c*q/(2*a)*(q-x^2)/(a+b*x^2+c*x^4)*)


Int[1/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[-a/c,2]},
  -Dist[c*q/(2*a),Int[(q+x^2)/(a+b*x^2+c*x^4),x]] -
  Dist[c*q/(2*a),Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c},x] && NegQ[a/c] &&
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[a/c], then x^2/(a+b*x^2+c*x^4) == (q+x^2)/(2*(a+b*x^2+c*x^4)) - (q-x^2)/(2*(a+b*x^2+c*x^4))*)


Int[x_^2/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[a/c,2]},
  Dist[1/2,Int[(q+x^2)/(a+b*x^2+c*x^4),x]] -
  Dist[1/2,Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c},x] && PosQ[a/c] && 
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[-a/c], then x^2/(a+b*x^2+c*x^4) == (q+x^2)/(2*(a+b*x^2+c*x^4)) - (q-x^2)/(2*(a+b*x^2+c*x^4))*)


Int[x_^2/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[-a/c,2]},
  Dist[1/2,Int[(q+x^2)/(a+b*x^2+c*x^4),x]] -
  Dist[1/2,Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c},x] && NegQ[a/c] &&
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[a/c], then (d+e*x^2)/(a+b*x^2+c*x^4) == *)
(*	(q*c*d+a*e)/(2*a)*(q+x^2)/(a+b*x^2+c*x^4) + (q*c*d-a*e)/(2*a)*(q-x^2)/(a+b*x^2+c*x^4)*)


Int[(d_+e_.*x_^2)/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[a/c,2]},
  Dist[(q*c*d+a*e)/(2*a),Int[(q+x^2)/(a+b*x^2+c*x^4),x]] +
  Dist[(q*c*d-a*e)/(2*a),Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[d^2*c-e^2*a] && PosQ[a/c] &&
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[-a/c], then (d+e*x^2)/(a+b*x^2+c*x^4) == *)
(*	-(q*c*d-a*e)/(2*a)*(q+x^2)/(a+b*x^2+c*x^4) - (q*c*d+a*e)/(2*a)*(q-x^2)/(a+b*x^2+c*x^4)*)


Int[(d_+e_.*x_^2)/(a_+b_.*x_^2+c_.*x_^4), x_Symbol] :=
  Module[{q=Rt[-a/c,2]},
  Dist[-(q*c*d-a*e)/(2*a),Int[(q+x^2)/(a+b*x^2+c*x^4),x]] -
  Dist[(q*c*d+a*e)/(2*a),Int[(q-x^2)/(a+b*x^2+c*x^4),x]]] /;
FreeQ[{a,b,c,d,e},x] && NonzeroQ[d^2*c-e^2*a] && NegQ[a/c] &&
(NegativeQ[b^2-4*a*c] || RationalQ[a/c] && Not[PositiveQ[b^2-4*a*c]])


(* ::Subsubsection::Closed:: *)
(*x^m (a + b x^2)/(c + d x^n + e x^k + f x^j)		Quotients of binomials by quartic trinomials*)


Int[(a_+b_.*x_^k_)/(c_+d_.*x_^2+e_.*x_^k_+f_.*x_^j_), x_Symbol] :=
  a/Rt[c*d,2]*ArcTan[a*(k-1)*Rt[c*d,2]*x/(c*(a*(k-1)-b*x^k))] /;
FreeQ[{a,b,c,d,e,f},x] && IntegerQ[{j,k}] && k>0 && j==2*k && ZeroQ[(k-1)^2*a^2*f-b^2*c] && 
ZeroQ[b*e+2*a*(k-1)*f] && PosQ[c*d]


Int[(a_+b_.*x_^k_)/(c_+d_.*x_^2+e_.*x_^k_+f_.*x_^j_), x_Symbol] :=
  a/Rt[-c*d,2]*ArcTanh[a*(k-1)*Rt[-c*d,2]*x/(c*(a*(k-1)-b*x^k))] /;
FreeQ[{a,b,c,d,e,f},x] && IntegerQ[{j,k}] && k>0 && j==2*k && ZeroQ[(k-1)^2*a^2*f-b^2*c] && 
ZeroQ[b*e+2*a*(k-1)*f] && NegQ[c*d]


Int[x_^m_.*(a_+b_.*x_^k_.)/(c_+d_.*x_^n_.+e_.*x_^k_.+f_.*x_^j_), x_Symbol] :=
  a*ArcTan[a*(m-k+1)*Rt[c*d,2]*x^(m+1)/(c*(a*(m-k+1)+b*(m+1)*x^k))]/((m+1)*Rt[c*d,2]) /;
FreeQ[{a,b,c,d,e,f,j,k,m,n},x] && ZeroQ[n-2*(m+1)] && ZeroQ[j-2*k] &&
ZeroQ[a^2*f*(m-k+1)^2-b^2*c*(m+1)^2] && ZeroQ[b*e*(m+1)-2*a*f*(m-k+1)] && PosQ[c*d]


Int[x_^m_.*(a_+b_.*x_^k_.)/(c_+d_.*x_^n_.+e_.*x_^k_.+f_.*x_^j_), x_Symbol] :=
  a*ArcTanh[a*(m-k+1)*Rt[-c*d,2]*x^(m+1)/(c*(a*(m-k+1)+b*(m+1)*x^k))]/((m+1)*Rt[-c*d,2]) /;
FreeQ[{a,b,c,d,e,f,j,k,m,n},x] && ZeroQ[n-2*(m+1)] && ZeroQ[j-2*k] &&
ZeroQ[a^2*f*(m-k+1)^2-b^2*c*(m+1)^2] && ZeroQ[b*e*(m+1)-2*a*f*(m-k+1)] && NegQ[c*d]


(* ::Subsubsection::Closed:: *)
(*(a+b x^k+c x^(2k))^n			Powers of symmetric trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.161.1b?*)


Int[1/(a_+b_.*x_^k_+c_.*x_^j_),x_Symbol] :=
  Module[{q=2*Rt[a/c,2]-b/c},
  Dist[1/(2*c*Rt[a/c,2]*Rt[q,2]),Int[(Rt[q,2]+x^(k/2))/(Rt[a/c,2]+Rt[q,2]*x^(k/2)+x^k),x]] + 
  Dist[1/(2*c*Rt[a/c,2]*Rt[q,2]),Int[(Rt[q,2]-x^(k/2))/(Rt[a/c,2]-Rt[q,2]*x^(k/2)+x^k),x]] /;
 Not[NegativeQ[q]]] /;  
FreeQ[{a,b,c},x] && IntegerQ[{j,k}] && k>0 && j==2*k && EvenQ[k] && PosQ[a/c] && 
NegativeQ[b^2-4*a*c]


(* ::Item::Closed:: *)
(*Reference: G&R 2.161.1a'*)


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: 1/(a+b*z+c*z^2) == 2*c/(q*(b-q+2*c*z)) - 2*c/(q*(b+q+2*c*z)) where q=Sqrt[b^2-4*a*c]*)


Int[1/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[2*c/q,Int[1/(b-q+2*c*x^k),x]] - 
  Dist[2*c/q,Int[1/(b+q+2*c*x^k),x]]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k}] && k>0 && j==2*k && NonzeroQ[b^2-4*a*c] && 
(OddQ[k] || Not[NegativeQ[b^2-4*a*c]])


(* ::Item:: *)
(*Reference: G&R 2.161.5' (GR5 2.161.4 is a special case.)*)


(* Previously undiscovered rule ??? *)
Int[(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  -x*(b^2-2*a*c+b*c*x^k)*(a+b*x^k+c*x^j)^(n+1)/(k*a*(n+1)*(b^2-4*a*c)) +
  Dist[(k*(n+1)*(b^2-4*a*c)+b^2-2*a*c)/(k*a*(n+1)*(b^2-4*a*c)),Int[(a+b*x^k+c*x^j)^(n+1),x]] +
  Dist[(k*(2*n+3)+1)*b*c/(k*a*(n+1)*(b^2-4*a*c)),Int[x^k*(a+b*x^k+c*x^j)^(n+1),x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,n}] && k>0 && j==2*k && NonzeroQ[b^2-4*a*c] && n<-1


(* ::Subsubsection::Closed:: *)
(*x^m / (a+b x^k+c x^(2k))		Quotients of monomials by symmetric trinomials*)


(* ::Item:: *)
(*Reference: G&R 2.177.1', CRC 120'*)


(* Note: This rule does not use the obvious substitution u=x^k on the whole integrand reducing 
	it to 1/(x*(a+b*x+c*x^2)) so that Log[x] instead of Log[x^k] appears in the result *)
Int[1/(x_*(a_+b_.*x_^k_+c_.*x_^j_.)),x_Symbol] :=
(* Dist[1/a,Int[x^(k-1)*(b+c*x^k)/(a+b*x^k+c*x^j),x]] /; *)
  Log[x]/a -
  Dist[1/(a*k),Subst[Int[(b+c*x)/(a+b*x+c*x^2),x],x,x^k]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k}] && k>0 && j==2*k && NonzeroQ[b^2-4*a*c]


(* ::Item:: *)
(*Derivation: Algebraic expansion*)


Int[x_^m_./(a_+b_.*x_^k_+c_.*x_^j_),x_Symbol] :=
  Module[{q=2*Rt[a/c,2]-b/c},
  Dist[1/(2*c*Rt[q,2]),Int[x^(m-k/2)/(Rt[a/c,2]-Rt[q,2]*x^(k/2)+x^k),x]] -
  Dist[1/(2*c*Rt[q,2]),Int[x^(m-k/2)/(Rt[a/c,2]+Rt[q,2]*x^(k/2)+x^k),x]] /;
 PosQ[q]] /;  
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m}] && k>0 && j==2*k && EvenQ[m] && EvenQ[k] && 
00 && j==2*k && NonzeroQ[b^2-4*a*c] && 
(OddQ[k] || Not[NegativeQ[b^2-4*a*c]])


(* ::Item:: *)
(*Reference: G&R 2.174.1', CRC 119'*)


Int[x_^m_./(a_+b_.*x_^k_+c_.*x_^j_),x_Symbol] :=
  x^(m-j+1)/(c*(m-j+1))-
  Dist[1/c,Int[x^(m-j)*(a+b*x^k)/(a+b*x^k+c*x^(2k)),x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m}] && k>0 && j==2*k && NonzeroQ[b^2-4*a*c] && 00 && j==2*k && NonzeroQ[b^2-4*a*c] && m<-1 && k>0


(* ::Subsubsection::Closed:: *)
(*x^m (a+b x^k+c x^(2k))^n		Products of monomials and powers of symmetric trinomials*)


(* ::Item:: *)
(*Derivation: Integration by substitution*)


(* Int[x_^m_./(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{g=GCD[m+1,k]},
  Dist[1/g,Subst[Int[x^((m+1)/g-1)/(a+b*x^(k/g)+c*x^(j/g)),x],x,x^g]] /;
 g>1] /;
FreeQ[{a,b,c},x] && IntegerQ[{m,k,j}] && j==2*k && 00 && j==2*k && m>0 && n<0 && IntegerQ[(m+1)/k] && 
NonzeroQ[b^2-4*a*c]


(* Int[(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  Int[(b/2+c*x^k)^(2*n),x]/c^n /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,n}] && k>0 && j==2*k && ZeroQ[b^2-4*a*c] *)


(* ::Item:: *)
(*Reference: G&R 2.160.4*)


Int[x_^m_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^n/(m+j*n+1) +
  Dist[a*j*n/(m+j*n+1),Int[x^m*(a+b*x^k+c*x^j)^(n-1),x]] +
  Dist[b*k*n/(m+j*n+1),Int[x^(m+k)*(a+b*x^k+c*x^j)^(n-1),x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m,n}] && k>0 && j==2*k && m<-1 && n>1 && NonzeroQ[m+j*n+1]


(* ::Item:: *)
(*Reference: G&R 2.160.3'*)


Int[x_^m_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m-j+1)*(a+b*x^k+c*x^j)^(n+1)/(c*k*(n+1)) +
  Dist[a/c,Int[x^(m-j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m,n}] && k>0 && j==2*k && m-j>=0 && n<-1 && ZeroQ[m+k*(n-1)+1]


(* ::Item:: *)
(*Reference: G&R 2.160.3 (GR5 2.174.1 is a special case.)*)


Int[x_^m_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m-j+1)*(a+b*x^k+c*x^j)^(n+1)/(c*(m+j*n+1)) -
  Dist[b*(m+k*(n-1)+1)/(c*(m+j*n+1)),Int[x^(m-k)*(a+b*x^k+c*x^j)^n,x]] -
  Dist[a*(m-j+1)/(c*(m+j*n+1)),Int[x^(m-j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m,n}] && k>0 && j==2*k && m-j>=0 && n<-1 && NonzeroQ[m+j*n+1] &&
NonzeroQ[m+k*(n-1)+1]


(* ::Item:: *)
(*Reference: G&R 2.160.2*)


Int[x_^m_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^n/(m+1) -
  Dist[b*k*n/(m+1),Int[x^(m+k)*(a+b*x^k+c*x^j)^(n-1),x]] -
  Dist[c*j*n/(m+1),Int[x^(m+j)*(a+b*x^k+c*x^j)^(n-1),x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m,n}] && k>0 && j==2*k && m<-1 && n>1


(* ::Item:: *)
(*Reference: G&R 2.160.1 (GR5 2.161.6 is a special case.)*)


Int[x_^m_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x^(m+1)*(a+b*x^k+c*x^j)^(n+1)/(a*(m+1)) -
  Dist[b*(m+1+k*(n+1))/(a*(m+1)),Int[x^(m+k)*(a+b*x^k+c*x^j)^n,x]] -
  Dist[c*(m+1+j*(n+1))/(a*(m+1)),Int[x^(m+j)*(a+b*x^k+c*x^j)^n,x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,m,n}] && k>0 && j==2*k && m<-1 && n<=1


(* Previously undiscovered rules ??? *)
Int[x_^k_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x*(b+2*c*x^k)*(a+b*x^k+c*x^j)^n/(2*c*(k*(2*n+1)+1)) - 
  Dist[b/(2*c*(k*(2*n+1)+1)),Int[(a+b*x^k+c*x^j)^n, x]] - 
  Dist[k*n*(b^2-4*a*c)/(2*c*(k*(2*n+1)+1)),Int[x^k*(a+b*x^k+c*x^j)^(n-1), x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,n}] && k>0 && j==2*k && n>0 && NonzeroQ[b^2-4*a*c] &&
NonzeroQ[k*(2*n+1)+1]


Int[x_^k_*(a_+b_.*x_^k_+c_.*x_^j_.)^n_,x_Symbol] :=
  x*(b+2*c*x^k)*(a+b*x^k+c*x^j)^(n+1)/(k*(n+1)*(b^2-4*a*c)) - 
  Dist[b/(k*(n+1)*(b^2-4*a*c)),Int[(a+b*x^k+c*x^j)^(n+1),x]] -
  Dist[2*c*(k*(2*n+3)+1)/(k*(n+1)*(b^2-4*a*c)),Int[x^k*(a+b*x^k+c*x^j)^(n+1),x]] /;
FreeQ[{a,b,c},x] && IntegerQ[{j,k,n}] && k>0 && j==2*k && n<-1 && NonzeroQ[b^2-4*a*c]


(* ::Subsubsection::Closed:: *)
(*x^m (d+e x^k) / (a+b x^k+c x^(2k))	Products of monomials and quotients of binomials by symmetric trinomials*)


(* These way kool, and to my knowledge original, rules reduce the degree of monomial without
	increasing the complexity of the integrands. *)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: (d+e*z)/(a+b*z+c*z^2) == (e+(2*c*d-b*e)/q)/(b-q+2*c*z) + (e-(2*c*d-b*e)/q)/(b+q+2*c*z) where q=Sqrt[b^2-4*a*c]*)


Int[(d_+e_.*x_^k_)/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  Module[{q=Rt[b^2-4*a*c,2]},
  Dist[(e+(2*c*d-b*e)/q),Int[1/(b-q+2*c*x^k),x]] +
  Dist[(e-(2*c*d-b*e)/q),Int[1/(b+q+2*c*x^k),x]]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[{j,k}] && k>0 && j==2*k && NonzeroQ[b^2-4*a*c] && 
Not[NegativeQ[b^2-4*a*c]]


(* Note: This rule does not use the obvious substitution u=x^k on the whole integrand reducing 
	it to (d+e*x)/(x*(a+b*x+c*x^2)) so that Log[x] instead of Log[x^k] appears in the result *)
Int[(d_.+e_.*x_^k_)/(x_*(a_+b_.*x_^k_+c_.*x_^j_.)),x_Symbol] :=
(* Dist[1/a,Int[x^(k-1)*(b*d-a*e+c*d*x^k)/(a+b*x^k+c*x^j),x]] /; *)
  d*Log[x]/a -
  Dist[1/(a*k),Subst[Int[(b*d-a*e+c*d*x)/(a+b*x+c*x^2),x],x,x^k]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[{j,k}] && k>0 && j==2*k


Int[x_^m_.*(d_.+e_.*x_^k_)/(a_+b_.*x_^k_+c_.*x_^j_.),x_Symbol] :=
  e*x^(m-k+1)/(c*(m-k+1)) -
  Dist[1/c,Int[x^(m-k)*(a*e+(b*e-c*d)*x^k)/(a+b*x^k+c*x^j),x]] /;
FreeQ[{a,b,c,d,e},x] && IntegerQ[{j,k,m}] && k>0 && j==2*k && k0 && j==2*k && m<-1


(* ::Subsection::Closed:: *)
(*a + b x + c x^2 + b x^3 + a x^4  Integrands involving symmetric quartic polynomials*)


(* ::Subsubsection::Closed:: *)
(*(d+e x+f x^2+g x^3)/(a+b x+c x^2+b x^3+a x^4)	Quotients of binomials by quartic trinomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic expansion*)


(* ::Item:: *)
(*Basis: If q=Sqrt[8*a^2+b^2-4*a*c], then a+b*x+c*x^2+b*x^3+a*x^4 == a*(1+((b-q)*x)/(2*a)+x^2)*(1+((b+q)*x)/(2*a)+x^2)*)


(* ::Item:: *)
(*Basis: If q=Sqrt[8*a^2+b^2-4*a*c], then (d+e*x+f*x^2+g*x^3)/(a+b*x+c*x^2+b*x^3+a*x^4) == *)
(*	(b*d-2*a*e+2*a*g+d*q+(2*a*d-2*a*f+b*g+g*q)*x)/(q*(2*a+(b+q)*x+2*a*x^2)) - *)
(*	(b*d-2*a*e+2*a*g-d*q+(2*a*d-2*a*f+b*g-g*q)*x)/(q*(2*a+(b-q)*x+2*a*x^2))*)


Int[(d_.+e_.*x_+f_.*x_^2+g_.*x_^3)/(a_+b_.*x_+c_.*x_^2+b_.*x_^3+a_.*x_^4),x_Symbol] :=
  Module[{q=Sqrt[8*a^2+b^2-4*a*c]},
  Dist[1/q,Int[(b*d-2*a*e+2*a*g+d*q+(2*a*d-2*a*f+b*g+g*q)*x)/(2*a+(b+q)*x+2*a*x^2),x]] -
  Dist[1/q,Int[(b*d-2*a*e+2*a*g-d*q+(2*a*d-2*a*f+b*g-g*q)*x)/(2*a+(b-q)*x+2*a*x^2),x]]] /;
FreeQ[{a,b,c,d,e,f,g},x] && PosQ[8*a^2+b^2-4*a*c]


Int[(d_.+e_.*x_+g_.*x_^3)/(a_+b_.*x_+c_.*x_^2+b_.*x_^3+a_.*x_^4),x_Symbol] :=
  Module[{q=Sqrt[8*a^2+b^2-4*a*c]},
  Dist[1/q,Int[(b*d-2*a*e+2*a*g+d*q+(2*a*d+b*g+g*q)*x)/(2*a+(b+q)*x+2*a*x^2),x]] -
  Dist[1/q,Int[(b*d-2*a*e+2*a*g-d*q+(2*a*d+b*g-g*q)*x)/(2*a+(b-q)*x+2*a*x^2),x]]] /;
FreeQ[{a,b,c,d,e,g},x] && PosQ[8*a^2+b^2-4*a*c]


(* ::Subsection::Closed:: *)
(*a x^p + b x^q			Integrands involving nonnormal binomials*)


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a z^p+b z^q == z^p (a+b z^(q-p))*)


Int[(a_.*x_^p_.+b_.*x_^q_.)^n_,x_Symbol] :=
  Int[x^(n*p)*(a+b*x^(q-p))^n,x] /;
FreeQ[{a,b,p,q},x] && IntegerQ[n] && Not[FractionQ[p]] && Not[FractionQ[q]] && Not[NegativeQ[q-p]]


(* ::Item::Closed:: *)
(*Derivation: Algebraic simplification*)


(* ::Item:: *)
(*Basis: a z^p+b z^q == z^p (a+b z^(q-p))*)


Int[x_^m_.*(a_.*x_^p_.+b_.*x_^q_.)^n_,x_Symbol] :=
  Int[x^(m+n*p)*(a+b*x^(q-p))^n,x] /;
FreeQ[{a,b,m,p,q},x] && IntegerQ[n] && Not[FractionQ[p]] && Not[FractionQ[q]] && Not[FractionQ[m]] && Not[NegativeQ[q-p]]


(* ::Subsection::Closed:: *)
(*P(x)/Q(x)^n			Quotients of polynomials and powers of polynomials*)


(* Note: Finds one term of the rational part of the antiderivative, thereby reducing the degree 
	of the polynomial in the numerator of the integrand.  Equivalent to the Ostrogradskiy-Hermite
	method (GR5 2.104) but without the need to solve a system of linear equations. *)
(* If m+1>=n and m+1-n*p!=0, let c=pm/(qn*(m+1-n*p)), then Int[Pm[x]/Qn[x]^p,x] -->
	c*x^(m-n+1)/Qn[x]^(p-1)+
		Int[(Pm[x]-c*x^(m-n)*((m-n+1)*Qn[x]+(1-p)*x*D[Qn[x],x]))/Qn[x]^p,x] *)
(* Integrate[Sum[ai*(m+i-i*p)*x^(m+i-1),{i,0,n}]/Sum[ai*x^i,{i,0,n}]^p,x] == 
		x^m/Sum[ai*x^i,{i,0,n}]^(p-1) *)
(* Note: Requirement that m<2*n-1 ensures new term is a proper fraction. *)
If[ShowSteps,

Int[u_*v_^p_,x_Symbol] :=
  Module[{m=Exponent[u,x],n=Exponent[v,x]},
  Module[{c=Coefficient[u,x,m]/(Coefficient[v,x,n]*(m+1+n*p)),w},
  w=Apart[u-c*x^(m-n)*((m-n+1)*v+(p+1)*x*D[v,x]),x];
  If[ZeroQ[w],
    ShowStep["If p>1, m+1>=n>1, and m-n*p<-1, let c=pm/(qn*(m+1-n*p)), then if (Pm[x]-c*x^(m-n)*((m-n+1)*Qn[x]+(1-p)*x*D[Qn[x],x]))==0,",
	  "Int[Pm[x]/Qn[x]^p,x]", "c*x^(m-n+1)/Qn[x]^(p-1)",
      Hold[c*x^(m-n+1)*v^(p+1)]],
  ShowStep["If p>1, m+1>=n>1, and m-n*p<-1, let c=pm/(qn*(m+1-n*p)), then",
	"Int[Pm[x]/Qn[x]^p,x]",
	"c*x^(m-n+1)/Qn[x]^(p-1)+Int[(Pm[x]-c*x^(m-n)*((m-n+1)*Qn[x]+(1-p)*x*D[Qn[x],x]))/Qn[x]^p,x]",
	Hold[c*x^(m-n+1)*v^(p+1) + Int[w*v^p,x]]]]] /;
 m+1>=n>1 && m+n*p<-1 && FalseQ[DerivativeDivides[v,u,x]]] /;
SimplifyFlag && RationalQ[p] && p<-1 && PolynomialQ[{u,v},x] && SumQ[v] && 
Not[MonomialQ[u,x] && BinomialQ[v,x]] && 
Not[ZeroQ[Coefficient[u,x,0]] && ZeroQ[Coefficient[v,x,0]]],

Int[u_*v_^p_,x_Symbol] :=
  Module[{m=Exponent[u,x],n=Exponent[v,x]},
  Module[{c=Coefficient[u,x,m]/(Coefficient[v,x,n]*(m+1+n*p)),w},
  c=Coefficient[u,x,m]/(Coefficient[v,x,n]*(m+1+n*p));
  w=Apart[u-c*x^(m-n)*((m-n+1)*v+(p+1)*x*D[v,x]),x];
  If[ZeroQ[w],
    c*x^(m-n+1)*v^(p+1),
  c*x^(m-n+1)*v^(p+1) + Int[w*v^p,x]]] /;
 m+1>=n>1 && m+n*p<-1 && FalseQ[DerivativeDivides[v,u,x]]] /;
RationalQ[p] && p<-1 && PolynomialQ[{u,v},x] && SumQ[v] && 
Not[MonomialQ[u,x] && BinomialQ[v,x]] && 
Not[ZeroQ[Coefficient[u,x,0]] && ZeroQ[Coefficient[v,x,0]]]]


(* ::Subsection::Closed:: *)
(*u + v				Sums*)


(* ::Item:: *)
(*Reference: G&R 2.02.5*)


Int[f_'[u_]*g_[v_]*w_. + f_[u_]*g_'[v_]*t_.,x_Symbol] :=
  f[u]*g[v] /;
FreeQ[{f,g},x] && ZeroQ[D[u,x]-w] && ZeroQ[D[v,x]-t]


(* ::Item::Closed:: *)
(*Reference: G&R 2.02.2, CRC 2,4*)


(* ::Item:: *)
(*Basis: Int[a*u+b*v+...,x] == a*Int[u,x]+b*Int[v,x]+...*)


If[ShowSteps,

Int[u_,x_Symbol] :=
  If[SplitFreeTerms[u,x][[1]]===0,
    ShowStep["","Int[a*u+b*v+\[CenterEllipsis],x]","a*Int[u,x]+b*Int[v,x]+\[CenterEllipsis]",Hold[
    SplitFreeIntegrate[u,x]]],
  ShowStep["","Int[a+b*u+c*v+\[CenterEllipsis],x]","a*x+b*Int[u,x]+c*Int[v,x]+\[CenterEllipsis]",Hold[
  SplitFreeIntegrate[u,x]]]] /;
SimplifyFlag && SumQ[u],

Int[u_,x_Symbol] :=
  SplitFreeIntegrate[u,x] /;
SumQ[u]]


(* ::Item:: *)
(*Basis: Int[a*u,x] == a*Int[u,x]*)


SplitFreeIntegrate[u_,x_Symbol] :=
  If[SumQ[u],
    Map[Function[SplitFreeIntegrate[#,x]],u],
  If[FreeQ[u,x],
    u*x,
  If[MatchQ[u,c_*(a_+b_.*x) /; FreeQ[{a,b,c},x]],
    Int[u,x],
  Module[{lst=SplitFreeFactors[u,x]},
  Dist[lst[[1]], Int[lst[[2]],x]]]]]]
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/Version.java0000644000175000017500000000176211554752464024024 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper;

//$Revision: 4053 $
//$Id: Version.java 4053 2011-04-24 07:45:56Z ted.kosan $
public class Version
{

   public  static final String version = ".81f";
    
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/license.txt0000644000175000017500000000036211542711404023674 0ustar  giovannigiovanniMathPiper is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version. 
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/0000755000175000017500000000000011722677325024253 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/AsynchronousInterpreter.java0000644000175000017500000001236111353014107032017 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.interpreters;

import java.util.concurrent.Callable;
import java.util.concurrent.ExecutionException;
import java.util.concurrent.ExecutorService;
import java.util.concurrent.Executors;
import java.util.concurrent.FutureTask;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 *
 */
class AsynchronousInterpreter implements Interpreter
{
    private static AsynchronousInterpreter singletonInstance;
    private SynchronousInterpreter interpreter;
    private String expression;

    private AsynchronousInterpreter(SynchronousInterpreter interpreter)
    {
        this.interpreter = interpreter;
    }//end constructor.

    static AsynchronousInterpreter newInstance()
    {
        SynchronousInterpreter interpreter = SynchronousInterpreter.newInstance();
        return new AsynchronousInterpreter(interpreter);
    }

    static AsynchronousInterpreter getInstance()
    {
        if (singletonInstance == null)
        {
            SynchronousInterpreter interpreter = SynchronousInterpreter.getInstance();
            singletonInstance = new AsynchronousInterpreter(interpreter);
        }
        return singletonInstance;
    }

     static AsynchronousInterpreter newInstance(String docBase)
    {
        SynchronousInterpreter interpreter = SynchronousInterpreter.newInstance(docBase);
        return new AsynchronousInterpreter(interpreter);
    }

    static AsynchronousInterpreter getInstance(String docBase)
    {
        if (singletonInstance == null)
        {
            SynchronousInterpreter interpreter = SynchronousInterpreter.getInstance(docBase);
            singletonInstance = new AsynchronousInterpreter(interpreter);
        }
        return singletonInstance;
    }
    
    public synchronized EvaluationResponse evaluate(String inputExpression) {
	    return this.evaluate(inputExpression, false);
    }//end method.

    public EvaluationResponse evaluate(String expression, boolean notifyEvaluationListeners)
    {

        FutureTask task = new EvaluationTask(new Evaluator(expression, notifyEvaluationListeners));
        ExecutorService es = Executors.newSingleThreadExecutor();
        es.submit(task);


        return EvaluationResponse.newInstance();

    }//end method.


    public synchronized EvaluationResponse evaluate(ConsPointer inputExpressionPointer) {
        return interpreter.evaluate(inputExpressionPointer);
    }


    public void addResponseListener(ResponseListener listener)
    {
	    interpreter.addResponseListener(listener);
    }//end method.

    public void removeResponseListener(ResponseListener listener)
    {
	    interpreter.removeResponseListener(listener);
    }//end method.



    public void addScriptsDirectory(String dir)
    {
        interpreter.addScriptsDirectory(dir);
    }

    public void haltEvaluation()
    {
        interpreter.haltEvaluation();
    }

    public Environment getEnvironment()
    {
        return interpreter.getEnvironment();
    }

    private class Evaluator implements Callable
    {

        private String expression;
	private boolean notifyEvaluationListeners;

        public Evaluator(String expression, boolean notifyEvaluationListeners)
        {
            this.expression = expression;
	    this.notifyEvaluationListeners = notifyEvaluationListeners;
        }

        public EvaluationResponse call() throws Exception
        {
            EvaluationResponse evaluationResponse = interpreter.evaluate(expression, notifyEvaluationListeners);
            return evaluationResponse;
        }
    } // MyCallable

    private class EvaluationTask extends FutureTask
    {

        public EvaluationTask(Callable arg0)
        {
            super(arg0);
        }

        @Override public void done()
        {
            EvaluationResponse evaluationResponse = null;
            try
            {
                evaluationResponse = (EvaluationResponse) get();
            } catch (ExecutionException e)
            {
                evaluationResponse = EvaluationResponse.newInstance();
                evaluationResponse.setExceptionMessage(e.getMessage());
            } catch (InterruptedException e)
            {
                evaluationResponse = EvaluationResponse.newInstance();
                evaluationResponse.setExceptionMessage(e.getMessage());
            }

        }//done.
    }//EvaluationTask.

    /*public java.util.zip.ZipFile getScriptsZip()
    {
        return interpreter.getScriptsZip();
    }//end method.*/
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/ResponseListener.java0000644000175000017500000000315711126545224030416 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.interpreters;

/**
 * This interface must be implemented by all client code that uses the
 * asynchronous {@link Interpreter}.
 */
public interface ResponseListener
{
    /**
     * Called by the asynchronous interperter to provide ResponseListeners with
     * an {@link EvaluationResponse} object which contains the results of the latest
     * evaluation.
     *
     * @param response
     */
    public void response(EvaluationResponse response);

    
    /**
     * Tells the asynchronous interpreter whether this ResponseListener would like to
     * be automatically removed from its listener list after the current evaluation
     * is complete.
     *
     * @return {@code true} if automatic removal is desired and {@code false} otherwise
     */
    public boolean remove();

}// end interface.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/SynchronousInterpreter.java0000644000175000017500000004775211554752464031714 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.interpreters;

import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.io.InputStatus;
import org.mathpiper.lisp.printers.MathPiperPrinter;
import org.mathpiper.lisp.parsers.MathPiperParser;
import org.mathpiper.io.StringOutputStream;
import org.mathpiper.io.StringInputStream;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import org.mathpiper.lisp.parsers.Parser;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.printers.LispPrinter;

import org.mathpiper.io.CachedStandardFileInputStream;
import java.io.*;
import java.util.ArrayList;
import java.util.List;
import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.io.StringOutput;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.SublistCons;

/**
 *
 *
 */
class SynchronousInterpreter implements Interpreter {

    private ArrayList removeListeners;
    private ArrayList responseListeners;
    private Environment iEnvironment = null;
    MathPiperTokenizer tokenizer = null;
    LispPrinter printer = null;
    //private String iException = null;
    String defaultDirectory = null;
    String archive = "";
    String detect = "";
    String pathParent = "";
    boolean inZipFile = false;
    MathPiperOutputStream sideEffectsStream;
    private static SynchronousInterpreter singletonInstance;
    private Thread evaluationThread;


    private SynchronousInterpreter(String docBase) {
        responseListeners = new ArrayList();
        removeListeners = new ArrayList();

        sideEffectsStream = new StringOutput();

        Utility.scriptsPath = "/org/mathpiper/assembledscripts/";

        try {
            iEnvironment = new Environment(sideEffectsStream);

            BuiltinFunction.addCoreFunctions(iEnvironment);

            if (!Utility.scriptsPath.contains("geogebra")) {
                List failList = BuiltinFunction.addOptionalFunctions(iEnvironment, "org/mathpiper/builtin/functions/optional/");
            }

            iEnvironment.pushLocalFrame(true, "");



            tokenizer = new MathPiperTokenizer();
            printer = new MathPiperPrinter(iEnvironment.iPrefixOperators, iEnvironment.iInfixOperators, iEnvironment.iPostfixOperators, iEnvironment.iBodiedOperators);


            iEnvironment.iCurrentInput = new CachedStandardFileInputStream(iEnvironment.iInputStatus);


            if (docBase != null) {


                if (docBase.substring(0, 4).equals("file")) {
                    int pos = docBase.lastIndexOf("/");
                    String zipFileName = docBase.substring(0, pos + 1) + "mathpiper.jar";
                    //zipFileName = zipFileName.substring(6,zipFileName.length());
                    //zipFileName = "file://" + zipFileName.substring(5,zipFileName.length());
                    zipFileName = zipFileName.substring(5, zipFileName.length());

                    try {
                        java.util.zip.ZipFile z = new java.util.zip.ZipFile(new File(zipFileName));
                        //System.out.println("XXXX " + z);
                        Utility.zipFile = z; //todo:tk:a better way needs to be found to do this.
                    } catch (Exception e) {
                        System.out.println("Failed to find mathpiper.jar");
                        System.out.println("" + zipFileName + " : \n");
                        System.out.println(e.toString());
                    }
                }
                if (docBase.startsWith("http")) {
                    //jar:http://www.xs4all.nl/~apinkus/interpreter.jar!/
                    int pos = docBase.lastIndexOf("/");
                    String scriptBase = "jar:" + docBase.substring(0, pos + 1) + "mathpiper.jar!/";


                    evaluate("DefaultDirectory(\"" + scriptBase + "\");");


                } else if (docBase.startsWith("jar:")) {
                    // used by GeoGebra
                    //eg docBase = "jar:http://www.geogebra.org/webstart/alpha/geogebra_cas.jar!/";
                    evaluate("DefaultDirectory(\"" + docBase + "\");");

                }//end if.

            }//end if.



            /*  java.net.URL detectURL = java.lang.ClassLoader.getSystemResource("initialization.rep/mathpiperinit.mpi");

            //StdFileInput.setPath(pathParent + File.separator);


            if (detectURL != null)
            {
            detect = detectURL.getPath(); // file:/home/av/src/lib/piper.jar!/piperinit.mpi

            if (detect.indexOf('!') != -1)
            {
            archive = detect.substring(0, detect.lastIndexOf('!')); // file:/home/av/src/lib/piper.jar

            try
            {
            String zipFileName = archive;//"file:/Users/ayalpinkus/projects/JavaMathPiper/piper.jar";

            java.util.zip.ZipFile z = new java.util.zip.ZipFile(new File(new java.net.URI(zipFileName)));
            Utility.zipFile = z;
            inZipFile = true;
            } catch (Exception e)
            {
            System.out.println("Failed to find mathpiper.jar" + e.toString());
            }
            } else
            {
            pathParent = new File(detectURL.getPath()).getParent();
            addScriptsDirectory(pathParent);
            }
            } else
            {
            System.out.println("Cannot find org/mathpiper/assembledscripts/initialization.rep/mathpiperinit.mpi.");
            }*/


            EvaluationResponse initializationEvaluationResponse = evaluate("LoadScript(\"initialization.rep/mathpiperinit.mpi\");");

            if (initializationEvaluationResponse.isExceptionThrown()) {
                throw new Exception("Error during system script initialization.");
            }

            initializationEvaluationResponse = evaluate("LoadScript(\"/mathpiper_user_initialization.mpi\");");

            if (!initializationEvaluationResponse.isExceptionThrown()) {
                System.out.println("The initialization file mathpiper_user_initialization.mpi was evaluated.");
            }



        } catch (Exception e) //Note:tk:need to handle exceptions better here.  should return exception to user in an EvaluationResponse.
        {
            e.printStackTrace();
            System.out.println(e.toString());
        }
    }//end constructor.


    private SynchronousInterpreter() {
        this(null);
    }


    static SynchronousInterpreter newInstance() {
        return new SynchronousInterpreter();
    }


    static SynchronousInterpreter newInstance(String docBase) {
        return new SynchronousInterpreter(docBase);
    }


    static SynchronousInterpreter getInstance() {
        if (singletonInstance == null) {
            singletonInstance = new SynchronousInterpreter();
        }
        return singletonInstance;
    }


    static SynchronousInterpreter getInstance(String docBase) {
        if (singletonInstance == null) {
            singletonInstance = new SynchronousInterpreter(docBase);
        }
        return singletonInstance;
    }


    public synchronized EvaluationResponse evaluate(String inputExpression) {
        return this.evaluate(inputExpression, false);
    }//end method.


    /**
    Evaluate an input expression which is a string.

    @param inputExpression
    @param notifyEvaluationListeners
    @return
     */
    public synchronized EvaluationResponse evaluate(String inputExpression, boolean notifyEvaluationListeners) {

        evaluationThread = Thread.currentThread();

        EvaluationResponse evaluationResponse = EvaluationResponse.newInstance();
        if (inputExpression.length() == 0) {
            //return (String) "";
            evaluationResponse.setResult("Empty Input");
            return evaluationResponse;
        }
        String resultString = "";
        try {
            iEnvironment.iEvalDepth = 0;

            //todo:tk:this was causing problems with GeoGebraPoint() on Windows.
            //environment.resetArgumentStack();


            //iException = null;

            ConsPointer inputExpressionPointer = new ConsPointer();
            if (iEnvironment.iPrettyReaderName != null) {
                InputStatus someStatus = new InputStatus();
                StringBuilder inp = new StringBuilder();
                inp.append(inputExpression);
                InputStatus oldstatus = iEnvironment.iInputStatus;
                iEnvironment.iInputStatus.setTo("String");
                StringInputStream newInput = new StringInputStream(new StringBuffer(inputExpression), iEnvironment.iInputStatus);

                MathPiperInputStream previous = iEnvironment.iCurrentInput;
                iEnvironment.iCurrentInput = newInput;
                try {
                    ConsPointer args = new ConsPointer();
                    Utility.applyString(iEnvironment, -1, inputExpressionPointer,
                            iEnvironment.iPrettyReaderName,
                            args);
                } catch (Exception exception) {
                    if (exception instanceof EvaluationException) {
                        EvaluationException mpe = (EvaluationException) exception;
                        int errorLineNumber = mpe.getLineNumber();
                        evaluationResponse.setLineNumber(errorLineNumber);
                    }
                    evaluationResponse.setException(exception);
                    evaluationResponse.setExceptionMessage(exception.getMessage());

                } finally {
                    iEnvironment.iCurrentInput = previous;
                    iEnvironment.iInputStatus.restoreFrom(oldstatus);
                }
            } else //Else not PrettyPrinter.
            {

                InputStatus someStatus = new InputStatus();

                StringBuffer inp = new StringBuffer();
                inp.append(inputExpression);
                inp.append(";");
                StringInputStream inputExpressionBuffer = new StringInputStream(inp, someStatus);

                Parser infixParser = new MathPiperParser(tokenizer, inputExpressionBuffer, iEnvironment, iEnvironment.iPrefixOperators, iEnvironment.iInfixOperators, iEnvironment.iPostfixOperators, iEnvironment.iBodiedOperators);
                infixParser.parse(-1, inputExpressionPointer);
            }

            return evaluate(inputExpressionPointer, notifyEvaluationListeners);

        } catch (Exception exception) {
            this.handleException(exception, evaluationResponse);
        }

        if (notifyEvaluationListeners) {
            notifyListeners(evaluationResponse);
        }//end if.

        return evaluationResponse;

    }//end method.


    public synchronized EvaluationResponse evaluate(ConsPointer inputExpressionPointer) {
        return evaluate(inputExpressionPointer, false);
    }


    /**
    Evaluate an input expression which is a Lisp list.

    @param inputExpressionPointer
    @param notifyEvaluationListeners
    @return
     */
    public synchronized EvaluationResponse evaluate(ConsPointer inputExpressionPointer, boolean notifyEvaluationListeners) {

        evaluationThread = Thread.currentThread();

        //return this.evaluate(inputExpression, false);
        EvaluationResponse evaluationResponse = EvaluationResponse.newInstance();

        String resultString = "Exception";

        try {
            ConsPointer resultPointer = new ConsPointer();
            iEnvironment.iLispExpressionEvaluator.evaluate(iEnvironment, -1, resultPointer, inputExpressionPointer); //*** The main evaluation happens here.

            evaluationResponse.setResultList(resultPointer);

            if (resultPointer.type() == Utility.OBJECT) {

                Object object = resultPointer.car();

                if (object instanceof BuiltinContainer) {
                    BuiltinContainer builtinContainer = (BuiltinContainer) object;
                    evaluationResponse.setObject(builtinContainer.getObject());
                } else {
                    evaluationResponse.setObject(object);
                }
            }//end if.

            //Set the % symbol to the result of the current evaluation.
            String percent = (String) iEnvironment.getTokenHash().lookUp("%");
            iEnvironment.setGlobalVariable(-1, percent, resultPointer, true);

            StringBuffer outputBuffer = new StringBuffer();
            MathPiperOutputStream outputStream = new StringOutputStream(outputBuffer);

            if (iEnvironment.iPrettyPrinterName != null) {
                //Pretty printer.

                ConsPointer applyResultPointer = new ConsPointer();

                if (iEnvironment.iPrettyPrinterName.equals("\"RForm\"")) {
                    Cons holdAtom = AtomCons.getInstance(iEnvironment, -1, "Hold");

                    holdAtom.cdr().setCons(resultPointer.getCons());

                    Cons subListCons = SublistCons.getInstance(iEnvironment, holdAtom);

                    ConsPointer resultPointerWithHold = new ConsPointer(subListCons);

                    Utility.applyString(iEnvironment, -1, applyResultPointer, iEnvironment.iPrettyPrinterName, resultPointerWithHold);
                } else {
                    Utility.applyString(iEnvironment, -1, applyResultPointer, iEnvironment.iPrettyPrinterName, resultPointer);
                }

                printer.rememberLastChar(' ');
                printer.print(-1, applyResultPointer, outputStream, iEnvironment);
                resultString = outputBuffer.toString();

            } else {
                //Default printer.
                printer.rememberLastChar(' ');
                printer.print(-1, resultPointer, outputStream, iEnvironment);
                resultString = outputBuffer.toString();
            }



        } catch (Exception exception) {
            this.handleException(exception, evaluationResponse);
        }//end catch.


        evaluationResponse.setResult(resultString);

        String sideEffects = sideEffectsStream.toString();

        if (sideEffects != null && sideEffects.length() != 0) {
            evaluationResponse.setSideEffects(sideEffects);
        }

        /*try{
        org.mathpiper.builtin.functions.optional.ViewList.evaluate(iEnvironment, -1, inputExpressionPointer);
        }catch(Exception e)
        {
        e.printStackTrace();
        }*/

        try {
            if (inputExpressionPointer.getCons() instanceof SublistCons) {

                Object object = ((ConsPointer) inputExpressionPointer.getCons().car()).car();

                if (object instanceof String && ((String) object).startsWith("Load")) {
                    ConsPointer loadResult = new ConsPointer();
                    iEnvironment.getGlobalVariable(-1, "$LoadResult", loadResult);
                    StringBuffer string_out = new StringBuffer();
                    MathPiperOutputStream output = new StringOutputStream(string_out);
                    printer.rememberLastChar(' ');
                    printer.print(-1, loadResult, output, iEnvironment);
                    String loadResultString = string_out.toString();
                    evaluationResponse.setResult(loadResultString);
                    if (loadResult.type() == Utility.OBJECT) {
                        JavaObject javaObject = (JavaObject) loadResult.car();
                        evaluationResponse.setObject(javaObject.getObject());
                    }//end if.
                }//if.
            }//end if
        } catch (Exception e) {
            evaluationResponse.setExceptionMessage(e.getMessage());
            evaluationResponse.setException(e);
        }

        if (notifyEvaluationListeners) {
            notifyListeners(evaluationResponse);
        }//end if.

        return evaluationResponse;
    }


    private void handleException(Exception exception, EvaluationResponse evaluationResponse) {
        //exception.printStackTrace();  //todo:tk:uncomment for debugging.

        Evaluator.DEBUG = false;
        Evaluator.VERBOSE_DEBUG = false;
        Evaluator.TRACE_TO_STANDARD_OUT = false;
        Evaluator.iTraced = false;

        try {
            iEnvironment.iArgumentStack.reset(-1, iEnvironment);
        } catch (Exception e) {
            e.printStackTrace();
        }

        if (exception instanceof EvaluationException) {
            EvaluationException mpe = (EvaluationException) exception;
            int errorLineNumber = mpe.getLineNumber();
            if (errorLineNumber == -1) {
                errorLineNumber = iEnvironment.iInputStatus.lineNumber();
                if (errorLineNumber == -1) {
                    errorLineNumber = 1; //Code was probably a single line submitted from the command line or from a single line evaluation request.
                }
                evaluationResponse.setLineNumber(errorLineNumber);
                evaluationResponse.setSourceFileName(iEnvironment.iInputStatus.fileName());
            } else {
                evaluationResponse.setLineNumber(mpe.getLineNumber());
                evaluationResponse.setSourceFileName(mpe.getFileName());
            }


        } else {
            int errorLineNumber = iEnvironment.iInputStatus.lineNumber();
            if (errorLineNumber == -1) {
                errorLineNumber = 1; //Code was probably a single line submitted from the command line or from a single line evaluation request.
            }
            evaluationResponse.setLineNumber(errorLineNumber);
            evaluationResponse.setSourceFileName(iEnvironment.iInputStatus.fileName());
        }

        evaluationResponse.setException(exception);
        evaluationResponse.setExceptionMessage(exception.getMessage());
    }


    public void haltEvaluation() {
        synchronized (iEnvironment) {
            //iEnvironment.iEvalDepth = iEnvironment.iMaxEvalDepth + 100; //Deprecated.

            evaluationThread.interrupt();
        }
    }


    public Environment getEnvironment() {
        return iEnvironment;
    }

    /*public java.util.zip.ZipFile getScriptsZip()
    {
    return Utility.zipFile;
    }//end method.*/

    public void addScriptsDirectory(String directory) {
        String toEvaluate = "DefaultDirectory(\"" + directory + File.separator + "\");";

        evaluate(toEvaluate);  //Note:tk:some exception handling needs to happen here..

    }//addScriptsDirectory.


    public void addResponseListener(ResponseListener listener) {
        responseListeners.add(listener);
    }


    public void removeResponseListener(ResponseListener listener) {
        responseListeners.remove(listener);
    }


    protected void notifyListeners(EvaluationResponse response) {
        //notify listeners.
        for (ResponseListener listener : responseListeners) {
            listener.response(response);

            if (listener.remove()) {
                removeListeners.add(listener);
            }//end if.
        }//end for.


        //Remove certain listeners.
        for (ResponseListener listener : removeListeners) {

            if (listener.remove()) {
                responseListeners.remove(listener);
            }//end if.
        }//end for.

        removeListeners.clear();

    }//end method.
}// end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/Interpreter.java0000644000175000017500000000714711353014107027411 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 *///}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.interpreters;

import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;

/**
 * Interpreter is implemented by all MathPiper interpreters and it allows client code to evaluate
 * MathPiper scripts and to also control the evaluation process.
 */
public interface Interpreter
{

    /**
     * Evaluates a MathPiper expression.  The results of the evaluation are returned
     * in a {@link EvaluationResponse} object.
     *
     * @param expression the MathPiper expression to be evaluated
     * @return an EvaluationResponse object
     */
    public EvaluationResponse evaluate(String expression);
    
    /**
     * Evaluates a MathPiper expression and optinally notifies evaluation listeners.  The results of the evaluation are returned
     * in a {@link EvaluationResponse} object.
     *
     * @param expression the MathPiper expression to be evaluated
     * @param notifyListeners if true, evaluation listeners will be notified
     * @return an EvaluationResponse object
     */
    public EvaluationResponse evaluate(String expression, boolean notifyListeners);

    /**
     * Evaluates a MathPiper expression.  The results of the evaluation are returned
     * in a {@link EvaluationResponse} object.
     *
     * @param expressionPointer the list form of a MathPiper expression to be evaluated
     * @return an EvaluationResponse object
     */
    public EvaluationResponse evaluate(ConsPointer expressionPointer);

    /**
     * Halts the current evaluation.
     */
    public void haltEvaluation();

    //java.util.zip.ZipFile getScriptsZip();

    /**
     * Adds a path to the paths which are searched when locating MathPiper scripts.
     *
     * @param directoryPath the path to a directory which contains MathPiper scripts
     */
    public void addScriptsDirectory(String directoryPath);
   
    /**
     * Allows asynchrnous interpreter clients to add themselves to the list of listeners which
     * get notified when the response from an asynchronous evaluation is ready.  These
     * clients must all implement the {@link ResponseListener} interface.
     *
     * @param responseListener a response listener
     */
    public void addResponseListener(ResponseListener responseListener);

     /**
     * Allows asynchrnous interpreter clients to remove themselves from the list of listeners which
     * get notified when the response from an asynchronous evaluation is ready.
     * 
     * @param responseListener a response listener
     */
    public void removeResponseListener(ResponseListener listener);
     
    /**
     * Returns the interpreter's execution {@link Environment}.  Warning: the Environment class
     * is currently not well protected and it will change in the future.
     * 
     * @return the Environment.
     */
    public Environment getEnvironment();

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/Interpreters.java0000644000175000017500000001533411126545224027600 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.interpreters;

/**
 * This class consists exclusively of static factory methods which return MathPiper interpreter instances.
 * These static methods are the only way to obtain instances of MathPiper interpeters.
 */
public class Interpreters {

    private Interpreters() {
    }

    /**
     * Instantiates a new synchronous {@link Interpreter} and returns it.  The interpreter contains
     * its own namespace and it runs in the client's thread.
     * 
     * @return a new synchronous interpreter
     */
    public static Interpreter newSynchronousInterpreter() {
        return SynchronousInterpreter.newInstance();
    }

    /**
     * Instantiates a new synchronous {@link Interpreter} and returns it.  The interpreter contains
     * its own namespace and it runs in the client's thread.  The docBase argument is used
     * to specify a path which contains the core MathPiper scripts.  A typical case where a
     * docBase path needs to be  used is with Applets.  The following code shows the document
     * base being obtained inside of an applet and then being used to obtain a new interpreter
     * instance which uses the docBase path to locate the core MathPiper scripts:
     * 
    
     * {@code String docBase = getDocumentBase().toString();}
    
     *  {@code mathPiperInterpreter = org.mathpiper.interpreters.Interpreters.newSynchronousInterpreter(docBase);}
     *
     * @param  docBase path which contains core MathPiper scripts
     * @return a new synchronous interpreter
     */
    public static Interpreter newSynchronousInterpreter(String docBase) {
        return SynchronousInterpreter.newInstance(docBase);
    }

     /**
     * Returns a synchronous {@link Interpreter} singleton.  All users of the interpreter singleton share
      * the same namespace and it runs in the client's thread.
     *
     * @return a synchronous interpreter singleton
     */
    public static Interpreter getSynchronousInterpreter() {
        return SynchronousInterpreter.getInstance();
    }

     /**
     * Returns a synchronous {@link Interpreter} singleton.  All users of the interpreter singleton share
      * the same namespace and it runs in the client's thread.  The docBase argument is used
     * to specify a path which contains the core MathPiper scripts.  A typical case where a
     * docBase path needs to be  used is with Applets.  The following code shows the document
     * base being obtained inside of an applet and then being used to obtain a new interpreter
     * instance which uses the docBase path to locate the core MathPiper scripts:
     * 
    
     * {@code String docBase = getDocumentBase().toString();}
    
     * {@code mathPiperInterpreter = org.mathpiper.interpreters.Interpreters.newSynchronousInterpreter(docBase);}
     *
     * @param docBase path which contains core MathPiper scripts
     * @return a synchronous interpreter singleton
     */
    public static Interpreter getSynchronousInterpreter(String docBase) {
        return SynchronousInterpreter.getInstance(docBase);
    }



    /**
     * Instantiates a new asynchronous {@link Interpreter} and returns it.  The interpreter contains
     * its own namespace and it runs in its own thread.
     *
     * @return a new asynchronous interpreter
     */
    public static Interpreter newAsynchronousInterpreter() {
        return AsynchronousInterpreter.newInstance();
    }

     /**
     * Instantiates a new asynchronous {@link Interpreter} and returns it.  The interpreter contains
     * its own namespace and it runs in its own thread.  The docBase argument is used
     * to specify a path which contains the core MathPiper scripts.  A typical case where a
     * docBase path needs to be  used is with Applets.  The following code shows the document
     * base being obtained inside of an applet and then being used to obtain a new interpreter
     * instance which uses the docBase path to locate the core MathPiper scripts:
     * 
    
     * {@code String docBase = getDocumentBase().toString();}
    
     *  {@code mathPiperInterpreter = org.mathpiper.interpreters.Interpreters.newAynchronousInterpreter(docBase);}
     *
     * @param  docBase path which contains core MathPiper scripts
     * @return a new aynchronous interpreter
     */
    public static Interpreter newAsynchronousInterpreter(String docBase) {
        return AsynchronousInterpreter.newInstance(docBase);
    }

     /**
     * Returns an asynchronous {@link Interpreter} singleton.  All users of the interpreter singleton share
      * the same namespace and it runs in its own thread.  The interpreter singleton is the same one which
      * is used by the synchronous interpreter.
     *
     * @return an asynchronous interpreter singleton
     */
    public static Interpreter getAsynchronousInterpreter() {
        return AsynchronousInterpreter.getInstance();
    }

     /**
     * Returns an asynchronous {@link Interpreter} singleton.  All users of the interpreter singleton share
      * the same namespace and it runs in its own thread.    The interpreter singleton is the same one which
      * is used by the synchronous interpreter.  The docBase argument is used
     * to specify a path which contains the core MathPiper scripts.  A typical case where a
     * docBase path needs to be  used is with Applets.  The following code shows the document
     * base being obtained inside of an applet and then being used to obtain a new interpreter
     * instance which uses the docBase path to locate the core MathPiper scripts:
     * 
    
     * {@code String docBase = getDocumentBase().toString();}
    
     * {@code mathPiperInterpreter = org.mathpiper.interpreters.Interpreters.newSynchronousInterpreter(docBase);}
     *
     * @param docBase path which contains core MathPiper scripts
     * @return an asynchronous interpreter singleton
     */
    public static Interpreter getAsynchronousInterpreter(String docBase) {
        return AsynchronousInterpreter.getInstance(docBase);
    }
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/interpreters/EvaluationResponse.java0000644000175000017500000001160411506531763030741 0ustar  giovannigiovanni/*
 * To change this template, choose Tools | Templates
 * and open the template in the editor.
 */

package org.mathpiper.interpreters;

import org.mathpiper.lisp.cons.ConsPointer;

/**
 * This class is used by an {@link Interpreter} to send the results of an evaluation to
 * client code.
 */
public class EvaluationResponse {
    private String result = "";
    private String sideEffects = "";
    private String exceptionMessage = "";
    private boolean exceptionThrown = false;
    private Exception exception = null;
    private int lineNumber;
    private String sourceFileName = "";
    private Object object = null;
    private ConsPointer resultList = null;
            
    private EvaluationResponse()
    {
    }

    /**
     * A static factory method which is used to crerate new EvaluationResponse objects.
     *
     * @return a new EvaluationResponse
     */
    public static EvaluationResponse newInstance()
    {
        return new EvaluationResponse();
    }

    /**
     * Returns the name of the source file in which an error occurred.
     *
     * @return the name of the source file
     */
    public String getSourceFileName()
    {
        return sourceFileName;
    }

    /**
     * Sets the name of the source file in which an error occurred.
     *
     * @param  name of the source file
     */
    public void setSourceFileName(String sourceFileName)
    {
        this.sourceFileName = sourceFileName;
    }

    /**
     * Returns the line number near where an error occurred.
     *
     * @return the line number near where an error occurred
     */
    public int getLineNumber()
    {
        return lineNumber;
    }

    /**
     * Sets the line number near where an error occurred.
     *
     * @param  lineNumber the line number near where an error occurred
     */
    public void setLineNumber(int lineNumber)
    {
        this.lineNumber = lineNumber;
    }

    /**
     * Returns the result of the evaluation.
     *
     * @return the result of the evaluation
     */
    public String getResult()
    {
        return result;
    }

    /**
     * Sets the result of the evaluation.
     *
     * @param result the result of the evaluation
     */
    public void setResult(String result)
    {
        this.result = result.trim();
    }

    /**
     * Returns any side effects generated by the evaluation.
     * 
     * @return any side effects generated by the evaluation
     */
    public String getSideEffects()
    {
        return sideEffects;
    }

    /**
     * Sets any side effects generated by the evaluation.
     * 
     * @param sideEffects any side effects generated by the evaluation
     */
    public void setSideEffects(String sideEffects)
    {
        this.sideEffects = sideEffects;
    }

    /**
     * Returns the exception message generated by the evaluation (if present).
     *
     * @return the exception message
     */
    public String getExceptionMessage()
    {
        return exceptionMessage;
    }

    /**
     * Sets the exception message generated by the evaluation (if present).
     *
     * @param exceptionMessage the exception message
     */
    public void setExceptionMessage(String exceptionMessage)
    {
        if(exceptionMessage != null)
        {
            this.exceptionMessage = exceptionMessage.trim();
        }
    }

     /**
     * Returns the exception object thrown by the evaluation (if present).
     *
     * @return the exception object
     */
    public Exception getException()
    {
        return exception;
    }

    /**
     * Sets the exception object thrown by the evaluation (if present).
     *
     * @param exception the exception object
     */
    public void setException(Exception exception)
    {
        this.exceptionThrown = true;
        this.exception = exception;
    }

    /**
     * Allows the client to determine if the evaluation threw an exception.
     *
     * @return {@code true} if an exception was thrown and {@code false} otherwise
     */
    public boolean isExceptionThrown()
    {
        return exceptionThrown;
    }


    /**
     * Allows the user to obtain a Java object from a function.
     *
     * @return a Java object if one is available to return to the user.
     */
    public Object getObject()
    {
        return object;
    }


    /**
     * Sets a Java object to be returned to the user..
     *
     * @param exception the exception object
     */
    public void setObject(Object object)
    {
        this.object = object;
    }



    /**
     * Allows the user to obtain the result list.
     *
     * @return a Java object if one is available to return to the user.
     */
    public ConsPointer getResultList() {
        return resultList;
    }


    /**
     * Sets the result list to be returned to the user..
     *
     * @param exception the exception object
     */
    public void setResultList(ConsPointer resultList) {
        this.resultList = resultList;
    }



}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/0000755000175000017500000000000011722677326022135 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/StandardFileInputStream.java0000644000175000017500000000362211506531763027531 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;

import java.io.InputStreamReader;

public class StandardFileInputStream
        extends StringInputStream {
    // private static String path;
    //static void setPath(String aPath)
    //{
    //    path = aPath;
    //}

    public StandardFileInputStream(String aFileName, InputStatus aStatus)
            throws Exception {
        super(new StringBuffer(), aStatus);

        //System.out.println("YYYYYY " + aFileName);//Note:tk: remove.
        InputStreamReader stream = new InputStreamReader(new java.io.FileInputStream(aFileName));
        int c;

        while (true) {
            c = stream.read();

            if (c == -1) {
                break;
            }

            iString.append((char) c);
        }
    }


    public StandardFileInputStream(java.io.InputStreamReader aStream, InputStatus aStatus)
            throws Exception {
        super(new StringBuffer(), aStatus);

        int c;

        while (true) {
            c = aStream.read();

            if (c == -1) {
                break;
            }

            iString.append((char) c);
        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/StandardFileOutputStream.java0000644000175000017500000000246011230525143027716 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */

//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;


public class StandardFileOutputStream implements MathPiperOutputStream //Note:tk: made this class public.
{

	java.io.OutputStream iFile;

	public StandardFileOutputStream(java.io.OutputStream aFile)
	{
		iFile = aFile;
	}

	public void putChar(char aChar)
	throws Exception
	{
		iFile.write(aChar);
	}

    public void write(String aString) throws Exception {
        int i;
        for (i = 0; i < aString.length(); i++) {
            putChar(aString.charAt(i));
        }
    }
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/InputDirectories.java0000644000175000017500000000166111072511461026261 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.io;

public class InputDirectories extends java.util.ArrayList // CDeletingArrayGrower
{
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/StringInputStream.java0000644000175000017500000000355711506531763026446 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;

public class StringInputStream
        extends MathPiperInputStream {

    int iCurrent;
    StringBuffer iString;


    public StringInputStream(StringBuffer aString, InputStatus aStatus) {
        super(aStatus);
        iString = aString;
        iCurrent = 0;
    }


    public char next()
            throws Exception {

        if (iCurrent == iString.length()) {
            return '\0';
        }

        iCurrent++;

        char c = iString.charAt(iCurrent - 1);

        if (c == '\n') {
            iStatus.nextLine();
        }

        return c;
    }


    public char peek()
            throws Exception {

        if (iCurrent == iString.length()) {
            return '\0';
        }

        return iString.charAt(iCurrent);
    }


    public boolean endOfStream() {

        return (iCurrent == iString.length());
    }


    public StringBuffer startPtr() {

        return iString;
    }


    public int position() {

        return iCurrent;
    }


    public void setPosition(int aPosition) {
        iCurrent = aPosition;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/StringOutputStream.java0000644000175000017500000000240411506531763026635 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;

public class StringOutputStream implements MathPiperOutputStream {

    StringBuffer iString;


    public StringOutputStream(StringBuffer aString) {
        iString = aString;
    }


    public void putChar(char aChar) {
        iString.append(aChar);
    }


    public void write(String aString) throws Exception {
        int i;
        for (i = 0; i < aString.length(); i++) {
            putChar(aString.charAt(i));
        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/MathPiperOutputStream.java0000644000175000017500000000220011230525143027237 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.io;

/** \class MathPiperOutputStream : interface an output object should adhere to.
 */
public interface MathPiperOutputStream //Note:tk: Made this interface public.
{
	/// write out one character.
	public void putChar(char aChar) throws Exception;
        public void write(String aString) throws Exception;
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/MathPiperInputStream.java0000644000175000017500000000444011132023700027037 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.io;


/** \class MathPiperInputStream : pure abstract class declaring the interface
 *  that needs to be implemented by a file (something that expressions
 *  can be read from).
 */
public abstract class MathPiperInputStream
{
	public InputStatus iStatus;

	/** Constructor with InputStatus. InputStatus retains the information
	 * needed when an error occurred, and the file has already been
	 * closed.
	 */
	public MathPiperInputStream(InputStatus aStatus)
	{
		iStatus = aStatus;
	}

	/// Return the next character in the file
	public abstract char next() throws Exception;

	/** peek at the next character in the file, without advancing the file
	 *  pointer.
	 */
	public abstract char peek() throws Exception;

	public InputStatus status()
	{
		return iStatus;
	}

	/// Check if the file position is past the end of the file.
	public abstract boolean endOfStream();
	/** startPtr returns the start of a buffer, if there is one.
	 * Implementations of this class can keep the file in memory
	 * as a whole, and return the start pointer and current position.
	 * Especially the parsing code requires this, because it can then
	 * efficiently look up a symbol in the hash table without having to
	 * first create a buffer to hold the symbol in. If startPtr is supported,
	 * the whole file should be in memory for the whole period the file
	 * is being read.
	 */
	public abstract StringBuffer startPtr();
	public abstract int position();
	public abstract void setPosition(int aPosition);

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/JarFileInputStream.java0000644000175000017500000000267611506531763026515 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;

import java.io.InputStreamReader;

import java.net.*;

public class JarFileInputStream extends StringInputStream {

    public JarFileInputStream(String aFileName, InputStatus aStatus) throws Exception {
        super(new StringBuffer(), aStatus);
        URL url = new URL(aFileName);
        JarURLConnection con = (JarURLConnection) url.openConnection();
        InputStreamReader stream = new InputStreamReader(con.getInputStream());
        int c;
        while (true) {
            c = stream.read();
            if (c == -1) {
                break;
            }
            iString.append((char) c);
        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/StringOutput.java0000644000175000017500000000344011506531763025462 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.io;

public class StringOutput implements MathPiperOutputStream {

    StringBuffer stringBuffer;


    public StringOutput() {
        this.stringBuffer = new java.lang.StringBuffer();
    }


    public void putChar(char aChar) {
        this.stringBuffer.append(aChar);
    }


    /*public void setStringBuffer(StringBuffer stringBuffer)
    {
    this.stringBuffer = stringBuffer;
    }//end method.*/
    public String toString() {
        if (this.stringBuffer.length() != 0) {
            String outputMessage = this.stringBuffer.toString();
            this.clear();
            return outputMessage;
        } else {
            return null;
        }//end else.


    }//end method.


    public void clear() {
        this.stringBuffer.delete(0, this.stringBuffer.length());
    }


    public void write(String aString) throws Exception {
        int i;
        for (i = 0; i < aString.length(); i++) {
            putChar(aString.charAt(i));
        }
    }

}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/CachedStandardFileInputStream.java0000644000175000017500000000360011506531763030615 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.io;

/** CachedStandardFileInputStream : input from stdin */
public class CachedStandardFileInputStream extends MathPiperInputStream
{
	StringBuffer iBuffer;
	int iCurrentPos;

	public CachedStandardFileInputStream(InputStatus aStatus)
	{
		super(aStatus);
		rewind();
	}
        
	public char next() throws Exception
	{
		int c = peek();
		iCurrentPos++;
		if (c == '\n')
			iStatus.nextLine();
		return (char)c;
	}
        
	public char peek() throws Exception
	{
		if (iCurrentPos == iBuffer.length())
		{
			int newc;
			newc = System.in.read();
			iBuffer.append((char)newc);
			while (newc != '\n')
			{
				newc = System.in.read();
				iBuffer.append((char)newc);
			}
		}
		return iBuffer.charAt(iCurrentPos);
	}
        
	public boolean endOfStream()
	{
		return false;
	}
        
	public void rewind()
	{
		iBuffer = new StringBuffer();
		iCurrentPos = 0;
	}
        
	public StringBuffer startPtr()
	{
		return iBuffer;
	}
        
	public int position()
	{
		return iCurrentPos;
	}
        
	public void setPosition(int aPosition)
	{
		iCurrentPos = aPosition;
	}


}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/io/InputStatus.java0000644000175000017500000000325611226764562025307 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.io;


public class InputStatus
{
	String iFileName;
	private int  iLineNumber;

	public InputStatus()
	{
		iFileName = "none";
		iLineNumber = -1;
	}

	public InputStatus(InputStatus aPreviousStatus)
	{
		iFileName = aPreviousStatus.iFileName;
		iLineNumber = aPreviousStatus.iLineNumber;
		//System.out.println("InputStatus construct to "+iFileName);
	}

	public void setTo(String aFileName)
	{
		//System.out.println("InputStatus set to "+aFileName);
		iFileName = aFileName;
		iLineNumber = 0;
	}

	public void restoreFrom(InputStatus aPreviousStatus)
	{
		iFileName = aPreviousStatus.iFileName;
		iLineNumber = aPreviousStatus.iLineNumber;

		//System.out.println("InputStatus restore to "+iFileName);

	}

	public int lineNumber()
	{
		return iLineNumber;
	}

	public String fileName()
	{
		return iFileName;
	}

	public  void nextLine()
	{
		iLineNumber++;
	}

};

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/0000755000175000017500000000000011722677326022475 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parsers/0000755000175000017500000000000011722677325024153 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parsers/Parser.java0000644000175000017500000000773211506531763026256 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parsers;

import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.*;

public class Parser {

    public MathPiperTokenizer iTokenizer;
    public MathPiperInputStream iInput;
    public Environment iEnvironment;
    public boolean iListed;


    public Parser(MathPiperTokenizer aTokenizer, MathPiperInputStream aInput,
            Environment aEnvironment) {
        iTokenizer = aTokenizer;
        iInput = aInput;
        iEnvironment = aEnvironment;
        iListed = false;
    }


    public void parse(int aStackTop, ConsPointer aResult) throws Exception {
        aResult.setCons(null);

        String token;
        // Get token.
        token = iTokenizer.nextToken(iEnvironment, aStackTop, iInput, iEnvironment.getTokenHash());
        if (token.length() == 0) //TODO FIXME either token == null or token.length() == 0?
        {
            aResult.setCons(AtomCons.getInstance(iEnvironment, aStackTop, "EndOfFile"));
            return;
        }
        parseAtom(iEnvironment, aStackTop, aResult, token);
    }


    void parseList(Environment aEnvironment, int aStackTop, ConsPointer aResult) throws Exception {
        String token;

        ConsPointer iter = aResult;
        if (iListed) {
            aResult.setCons(AtomCons.getInstance(iEnvironment, aStackTop, "List"));
            iter = (aResult.cdr()); //TODO FIXME
        }
        for (;;) {
            //Get token.
            token = iTokenizer.nextToken(iEnvironment, aStackTop, iInput, iEnvironment.getTokenHash());
            // if token is empty string, error!
            LispError.check(iEnvironment, aStackTop, token.length() > 0, LispError.INVALID_TOKEN, "INTERNAL"); //TODO FIXME
            // if token is ")" return result.
            if (token == iEnvironment.getTokenHash().lookUp(")")) {
                return;
            }
            // else parse simple atom with parse, and append it to the
            // results list.

            parseAtom(aEnvironment, aStackTop, iter, token);
            iter = (iter.cdr()); //TODO FIXME
        }
    }


    void parseAtom(Environment aEnvironment, int aStackTop, ConsPointer aResult, String aToken) throws Exception {
        // if token is empty string, return null pointer (no expression)
        if (aToken.length() == 0) //TODO FIXME either token == null or token.length() == 0?
        {
            return;
        }
        // else if token is "(" read in a whole array of objects until ")",
        //   and make a sublist
        if (aToken == iEnvironment.getTokenHash().lookUp("(")) {
            ConsPointer subList = new ConsPointer();
            parseList(aEnvironment, aStackTop, subList);
            aResult.setCons(SublistCons.getInstance(aEnvironment, subList.getCons()));
            return;
        }
        // else make a simple atom, and return it.
        aResult.setCons(AtomCons.getInstance(iEnvironment, aStackTop, aToken));
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parsers/MathPiperParser.java0000644000175000017500000003552011506531763030064 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parsers;

import org.mathpiper.lisp.printers.MathPiperPrinter;

import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.collections.OperatorMap;

public class MathPiperParser extends Parser
{

    public OperatorMap iPrefixOperators;
    public OperatorMap iInfixOperators;
    public OperatorMap iPostfixOperators;
    public OperatorMap iBodiedOperators;
    //private Environment iEnvironment;
    
    boolean iError;
    boolean iEndOfFile;
    String iLookAhead;
    public ConsPointer iSExpressionResult = new ConsPointer();

    public MathPiperParser(MathPiperTokenizer aTokenizer,
            MathPiperInputStream aInput,
            Environment aEnvironment,
            OperatorMap aPrefixOperators,
            OperatorMap aInfixOperators,
            OperatorMap aPostfixOperators,
            OperatorMap aBodiedOperators)
    {
        super(aTokenizer, aInput, aEnvironment);
        iPrefixOperators = aPrefixOperators;
        iInfixOperators = aInfixOperators;
        iPostfixOperators = aPostfixOperators;
        iBodiedOperators = aBodiedOperators;
        iEnvironment = aEnvironment;

        iError = false;
        iEndOfFile = false;
        iLookAhead = null;
    }

    @Override
    public void parse(int aStackTop, ConsPointer aResult) throws Exception
    {
        parse(aStackTop);
        aResult.setCons(iSExpressionResult.getCons());
    }

    public void parse(int aStackTop) throws Exception
    {
        readToken(aStackTop);
        if (iEndOfFile)
        {
            iSExpressionResult.setCons(iEnvironment.iEndOfFileAtom.copy( iEnvironment, true));
            return;
        }

        readExpression(iEnvironment,aStackTop, MathPiperPrinter.KMaxPrecedence);  // least precedence

        if (iLookAhead != iEnvironment.iEndStatementAtom.car())
        {
            fail(aStackTop);
        }
        if (iError)
        {
            while (iLookAhead.length() > 0 && iLookAhead != iEnvironment.iEndStatementAtom.car())
            {
                readToken(aStackTop);
            }
        }

        if (iError)
        {
            iSExpressionResult.setCons(null);
        }
        LispError.check(iEnvironment, aStackTop, !iError, LispError.INVALID_EXPRESSION, "INTERNAL");
    }

    void readToken(int aStackTop) throws Exception
    {
        // Get token.
        iLookAhead = iTokenizer.nextToken(iEnvironment, aStackTop, iInput,
                iEnvironment.getTokenHash());
        if (iLookAhead.length() == 0)
        {
            iEndOfFile = true;
        }
    }

    void matchToken(int aStackTop, String aToken) throws Exception
    {
        if (!aToken.equals(iLookAhead))
        {
            fail(aStackTop);
        }
        readToken(aStackTop);
    }

    void readExpression(Environment aEnvironment,int aStackTop, int depth) throws Exception
    {
        readAtom(aEnvironment, aStackTop);

        for (;;)
        {
            //Handle special case: a[b]. a is matched with lowest precedence!!
            if (iLookAhead == iEnvironment.iProgOpenAtom.car())
            {
                // Match opening bracket
                matchToken(aStackTop, iLookAhead);
                // Read "index" argument
                readExpression(aEnvironment, aStackTop, MathPiperPrinter.KMaxPrecedence);
                // Match closing bracket
                if (iLookAhead != iEnvironment.iProgCloseAtom.car())
                {
                    LispError.raiseError("Expecting a ] close bracket for program block, but got " + iLookAhead + " instead.", "[INTERNAL]", aStackTop, aEnvironment);
                    return;
                }
                matchToken(aStackTop, iLookAhead);
                // Build into Ntn(...)
                String theOperator = (String) iEnvironment.iNthAtom.car();
                insertAtom(aStackTop, theOperator);
                combine(aEnvironment,aStackTop, 2);
            } else
            {
                Operator op = (Operator) iInfixOperators.lookUp(iLookAhead);
                if (op == null)
                {
                    //printf("op [%s]\n",iLookAhead.String());
                    if(iLookAhead.equals(""))
                    {

                       LispError.raiseError("Expression must end with a semi-colon (;)", "[INTERNAL]", aStackTop, aEnvironment);
                        return;
                    }
                    if (MathPiperTokenizer.isSymbolic(iLookAhead.charAt(0)))
                    {
                        int origlen = iLookAhead.length();
                        int len = origlen;
                        //printf("IsSymbolic, len=%d\n",len);

                        while (len > 1)
                        {
                            len--;
                            String lookUp =
                                    (String) iEnvironment.getTokenHash().lookUp(iLookAhead.substring(0, len));

                            //printf("trunc %s\n",lookUp.String());
                            op = (Operator) iInfixOperators.lookUp(lookUp);
                            //if (op) printf("FOUND\n");
                            if (op != null)
                            {
                                String toLookUp = iLookAhead.substring(len, origlen);
                                String lookUpRight =
                                       (String) iEnvironment.getTokenHash().lookUp(toLookUp);

                                //printf("right: %s (%d)\n",lookUpRight.String(),origlen-len);

                                if (iPrefixOperators.lookUp(lookUpRight) != null)
                                {
                                    //printf("ACCEPT %s\n",lookUp.String());
                                    iLookAhead = lookUp;
                                    MathPiperInputStream input = iInput;
                                    int newPos = input.position() - (origlen - len);
                                    input.setPosition(newPos);
                                    //printf("Pushhback %s\n",&input.startPtr()[input.position()]);
                                    break;
                                } else
                                {
                                    op = null;
                                }
                            }
                        }
                        if (op == null)
                        {
                            return;
                        }
                    } else
                    {
                        return;
                    }




                //              return;
                }
                if (depth < op.iPrecedence)
                {
                    return;
                }
                int upper = op.iPrecedence;
                if (op.iRightAssociative == 0)
                {
                    upper--;
                }
                getOtherSide(aEnvironment,aStackTop, 2, upper);
            }
        }
    }

    void readAtom(Environment aEnvironment, int aStackTop) throws Exception
    {
        Operator op;
        // parse prefix operators
        op = (Operator) iPrefixOperators.lookUp(iLookAhead);
        if (op != null)
        {
            String theOperator = iLookAhead;
            matchToken(aStackTop, iLookAhead);
            {
                readExpression(aEnvironment,aStackTop, op.iPrecedence);
                insertAtom(aStackTop, theOperator);
                combine(aEnvironment,aStackTop, 1);
            }
        } // Else parse brackets
        else if (iLookAhead == iEnvironment.iBracketOpenAtom.car())
        {
            matchToken(aStackTop, iLookAhead);
            readExpression(aEnvironment,aStackTop, MathPiperPrinter.KMaxPrecedence);  // least precedence
            matchToken( aStackTop, (String) iEnvironment.iBracketCloseAtom.car());
        } //parse lists
        else if (iLookAhead == iEnvironment.iListOpenAtom.car())
        {
            int nrargs = 0;
            matchToken(aStackTop, iLookAhead);
            while (iLookAhead != iEnvironment.iListCloseAtom.car())
            {
                readExpression(aEnvironment,aStackTop, MathPiperPrinter.KMaxPrecedence);  // least precedence
                nrargs++;

                if (iLookAhead == iEnvironment.iCommaAtom.car())
                {
                    matchToken(aStackTop, iLookAhead);
                } else if (iLookAhead != iEnvironment.iListCloseAtom.car())
                {
                    LispError.raiseError("Expecting a } close bracket for a list, but got " + iLookAhead + " instead.", "[INTERNAL]", aStackTop, aEnvironment);
                    return;
                }
            }
            matchToken(aStackTop, iLookAhead);
            String theOperator = (String) iEnvironment.iListAtom.car();
            insertAtom(aStackTop, theOperator);
            combine(aEnvironment, aStackTop, nrargs);

        } // parse prog bodies
        else if (iLookAhead == iEnvironment.iProgOpenAtom.car())
        {
            int nrargs = 0;

            matchToken(aStackTop, iLookAhead);
            while (iLookAhead != iEnvironment.iProgCloseAtom.car())
            {
                readExpression(aEnvironment,aStackTop, MathPiperPrinter.KMaxPrecedence);  // least precedence
                nrargs++;

                if (iLookAhead == iEnvironment.iEndStatementAtom.car())
                {
                    matchToken(aStackTop, iLookAhead);
                } else
                {
                    LispError.raiseError("Expecting ; end of statement in program block, but got " + iLookAhead + " instead.", "[INTERNAL]", aStackTop, aEnvironment);
                    return;
                }
            }
            matchToken(aStackTop, iLookAhead);
            String theOperator = (String) iEnvironment.iProgAtom.car();
            insertAtom(aStackTop, theOperator);

            combine(aEnvironment, aStackTop, nrargs);
        } // Else we have an atom.
        else
        {
            String theOperator = iLookAhead;
            matchToken(aStackTop, iLookAhead);

            int nrargs = -1;
            if (iLookAhead == iEnvironment.iBracketOpenAtom.car())
            {
                nrargs = 0;
                matchToken(aStackTop, iLookAhead);
                while (iLookAhead != iEnvironment.iBracketCloseAtom.car())
                {
                    readExpression(aEnvironment,aStackTop, MathPiperPrinter.KMaxPrecedence);  // least precedence
                    nrargs++;

                    if (iLookAhead == iEnvironment.iCommaAtom.car())
                    {
                        matchToken(aStackTop, iLookAhead);
                    } else if (iLookAhead != iEnvironment.iBracketCloseAtom.car())
                    {
                        LispError.raiseError("Expecting ) closing bracket for sub-expression, but got " + iLookAhead + " instead.", "[INTERNAL]", aStackTop, aEnvironment);
                        return;
                    }
                }
                matchToken(aStackTop, iLookAhead);

                op = (Operator) iBodiedOperators.lookUp(theOperator);
                if (op != null)
                {
                    readExpression(aEnvironment,aStackTop, op.iPrecedence); // MathPiperPrinter.KMaxPrecedence
                    nrargs++;
                }
            }
            insertAtom(aStackTop, theOperator);
            if (nrargs >= 0)
            {
                combine(aEnvironment, aStackTop, nrargs);
            }
        }

        // parse postfix operators

        while ((op = (Operator) iPostfixOperators.lookUp(iLookAhead)) != null)
        {
            insertAtom(aStackTop, iLookAhead);
            matchToken(aStackTop, iLookAhead);
            combine(aEnvironment,aStackTop, 1);
        }
    }

    void getOtherSide(Environment aEnvironment, int aStackTop, int aNrArgsToCombine, int depth) throws Exception
    {
        String theOperator = iLookAhead;
        matchToken(aStackTop, iLookAhead);
        readExpression(aEnvironment, aStackTop,  depth);
        insertAtom(aStackTop, theOperator);
        combine(aEnvironment, aStackTop, aNrArgsToCombine);
    }

    void combine(Environment aEnvironment, int aStackTop, int aNrArgsToCombine) throws Exception
    {
        ConsPointer subList = new ConsPointer();
        subList.setCons(SublistCons.getInstance(aEnvironment,iSExpressionResult.getCons()));
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, iSExpressionResult);
        int i;
        for (i = 0; i < aNrArgsToCombine; i++)
        {
            if (consTraverser.getCons() == null)
            {
                fail(aStackTop);
                return;
            }
            consTraverser.goNext(aStackTop);
        }
        if (consTraverser.getCons() == null)
        {
            fail(aStackTop);
            return;
        }
        subList.cdr().setCons(consTraverser.cdr().getCons());
        consTraverser.cdr().setCons(null);

        Utility.reverseList(aEnvironment, ((ConsPointer) subList.car()).cdr(),
                ((ConsPointer) subList.car()).cdr());
        iSExpressionResult.setCons(subList.getCons());
    }

    void insertAtom(int aStackTop, String aString) throws Exception
    {
        ConsPointer ptr = new ConsPointer();
        ptr.setCons(AtomCons.getInstance(iEnvironment, aStackTop, aString));
        ptr.cdr().setCons(iSExpressionResult.getCons());
        iSExpressionResult.setCons(ptr.getCons());
    }

    void fail(int aStackTop) throws Exception // called when parsing fails, raising an exception
    {
        iError = true;
        if (iLookAhead != null)
        {
            LispError.raiseError("Error parsing expression, near token " + iLookAhead + ".", "[INTERNAL]", aStackTop, iEnvironment);
        }
        LispError.raiseError("Error parsing expression.", "[INTERNAL]", aStackTop, iEnvironment);
    }
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/Evaluator.java0000644000175000017500000002162311506531763025300 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

// class EvalFuncBase defines the interface to 'something that can
import java.util.ArrayList;
import java.util.Collections;
import java.util.List;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.io.StringOutputStream;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.localvariables.LocalVariableFrame;
import org.mathpiper.lisp.printers.MathPiperPrinter;
import org.mathpiper.lisp.stacks.UserStackInformation;

// evaluate'
public abstract class Evaluator {

	public static boolean DEBUG = false;
	public static boolean TRACE_TO_STANDARD_OUT = false;
	public static boolean VERBOSE_DEBUG = false;
	private static int evalDepth = 0;
	public static boolean iTraced = false;
	private static List traceFunctionList = null;
	private static List traceExceptFunctionList = null;
        public static boolean iStackTraced = false;
	UserStackInformation iBasicInfo = new UserStackInformation();

	public static void showExpression(StringBuffer outString, Environment aEnvironment, ConsPointer aExpression) throws Exception {
		MathPiperPrinter infixprinter = new MathPiperPrinter(aEnvironment.iPrefixOperators, aEnvironment.iInfixOperators, aEnvironment.iPostfixOperators, aEnvironment.iBodiedOperators);
		// Print out the current expression
		//StringOutput stream(outString);
		MathPiperOutputStream stream = new StringOutputStream(outString);
		infixprinter.print(-1, aExpression, stream, aEnvironment);
		// Escape quotes.
		for (int i = outString.length() - 1; i >= 0; --i) {
			char c = outString.charAt(i);
			if (c == '\"') {
				//outString.insert(i, '\\');
				outString.deleteCharAt(i);
			}
		}// end for.

	}//end method.

	public static void traceShowEnter(Environment aEnvironment, ConsPointer aExpression, String extraInfo) throws Exception {
		for (int i = 0; i < evalDepth; i++) {
			// aEnvironment.iEvalDepth; i++) {
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print("    ");
			} else {
				aEnvironment.write("    ");
			}
		}//end for.

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print("Enter<" + extraInfo + ">{(");
		} else {
			aEnvironment.write("Enter<" + extraInfo + ">{(");
		}

		String function = "";
		if (aExpression.car() instanceof ConsPointer) {
			ConsPointer sub = (ConsPointer) aExpression.car();
			if (sub.car() instanceof String) {
				function = (String) sub.car();
			}
		}
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(function);
		} else {
			aEnvironment.write(function);
		}//end else.

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(", ");
		} else {
			aEnvironment.write(", ");
		}
		traceShowExpression(aEnvironment, aExpression);

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(");\n");
		} else {
			aEnvironment.write(");\n");
		}

		if (traceFunctionList != null) {
			for (int i = 0; i < (evalDepth + 1); i++) {
				if (TRACE_TO_STANDARD_OUT) {
					System.out.print("    ");
				} else {
					aEnvironment.write("    ");
				}
			}//end for.

			//Trace stack frames.
			List functionsOnStack = new ArrayList();
			LocalVariableFrame localVariableFrame = aEnvironment.iLocalVariablesFrame;
			while (localVariableFrame != null) {
				functionsOnStack.add(localVariableFrame.getFunctionName());
				localVariableFrame = localVariableFrame.iNext;
			}//end while
			Collections.reverse(functionsOnStack);
			StringBuilder functionsDump = new StringBuilder();
			functionsDump.append("(User Function Call Stack: ");
			for(String functionName: functionsOnStack)
			{
				functionsDump.append(functionName + ", ");
			}//end for.
			functionsDump.append(")\n");
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print(functionsDump.toString());
			} else {
				aEnvironment.write(functionsDump.toString());
			}//end else.
		}//end if.


		evalDepth++;
	}//end method.

	public static void traceShowArg(Environment aEnvironment, ConsPointer aParam, ConsPointer aValue) throws Exception {
		for (int i = 0; i < evalDepth; i++) {
			//aEnvironment.iEvalDepth; i++) {
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print("    ");
			} else {
				aEnvironment.write("    ");
			}
		}
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print("Arg(");
		} else {
			aEnvironment.write("Arg(");
		}
		traceShowExpression(aEnvironment, aParam);
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(" -> ");
		} else {
			aEnvironment.write(" -> ");
		}
		traceShowExpression(aEnvironment, aValue);
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(");\n");
		} else {
			aEnvironment.write(");\n");
		}
	}//end method.

	public static void traceShowExpression(Environment aEnvironment, ConsPointer aExpression) throws Exception {
		StringBuffer outString = new StringBuffer();

		showExpression(outString, aEnvironment, aExpression);

		String expression = outString.toString();
		expression = expression.replace("\n", "");

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(expression);
		} else {
			aEnvironment.write(expression);
		}
	}//end method.

	public static void traceShowRule(Environment aEnvironment, ConsPointer aExpression, String ruleDump) throws Exception {

		for (int i = 0; i < evalDepth; i++) {
			// aEnvironment.iEvalDepth; i++) {
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print("    ");
			} else {
				aEnvironment.write("    ");
			}
		}

		String function = "";
		if (aExpression.car() instanceof ConsPointer) {
			ConsPointer sub = (ConsPointer) aExpression.car();
			if (sub.car() instanceof String) {
				function = (String) sub.car();
			}
		}//end function.

		ruleDump = ruleDump.replace("\n", "");

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print("**** Rule in function (" + function + ") matched: ");
			System.out.print(ruleDump);
			System.out.print("\n");
		} else {
			aEnvironment.write("**** Rule in function (" + function + ") matched: ");
			aEnvironment.write(ruleDump);
			aEnvironment.write("\n");
		}
	}//end method.

	public static void traceShowLeave(Environment aEnvironment, ConsPointer aResult, ConsPointer aExpression, String extraInfo, String localVariables) throws Exception {
		if (evalDepth != 0) {
			evalDepth--;
		}
		for (int i = 0; i < evalDepth; i++) {
			// aEnvironment.iEvalDepth; i++) {
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print("    ");
			} else {
				aEnvironment.write("    ");
			}
		}
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print("Leave<" + extraInfo + ">}(");
		} else {
			aEnvironment.write("Leave<" + extraInfo + ">}(");
		}
		traceShowExpression(aEnvironment, aExpression);
		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(" -> ");
		} else {
			aEnvironment.write(" -> ");
		}

		traceShowExpression(aEnvironment, aResult);

		if (localVariables != null) {
			if (TRACE_TO_STANDARD_OUT) {
				System.out.print(",    " + localVariables);
			} else {
				aEnvironment.write(",    " + localVariables);
			}//end else.

		}//end if.

		if (TRACE_TO_STANDARD_OUT) {
			System.out.print(");\n");
		} else {
			aEnvironment.write(");\n");
		}//end else.
	}//end method.

	public static boolean isTraced() {
		return iTraced;
	}

	public static void traceOff() {
		iTraced = false;
	}

	public static void traceOn() {
		iTraced = true;
	}

	public static boolean isStackTraced() {
		return iStackTraced;
	}

	public static void stackTraceOff() {
		iStackTraced = false;
	}

	public static void stackTraceOn() {
		iStackTraced = true;
	}

	public abstract void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArgumentsOrExpression) throws Exception;


	public UserStackInformation stackInformation() {
		return iBasicInfo;
	}

	public void showStack(Environment aEnvironment, MathPiperOutputStream aOutput) {
	}//end method.

	public static void setTraceFunctionList(List traceFunctionList) {
		Evaluator.traceFunctionList = traceFunctionList;
	}

	public static void setTraceExceptFunctionList(List traceExceptFunctionList) {
		Evaluator.traceExceptFunctionList = traceExceptFunctionList;
	}

	public static boolean isTraceFunction(String functionName) {
		if (!(traceFunctionList == null)) {
			return traceFunctionList.contains(functionName);
		} else if (!(traceExceptFunctionList == null)) {
			return !traceExceptFunctionList.contains(functionName);
		} else {
			return true;
		}//end else.

	}//end method.
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/LispExpressionEvaluator.java0000644000175000017500000003732111523146134030203 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.builtin.BuiltinFunctionEvaluator;
import org.mathpiper.lisp.rulebases.MultipleArityRulebase;

import org.mathpiper.lisp.rulebases.SingleArityRulebase;

/**
 *  The basic evaluator for Lisp expressions.
 *
 */
public class LispExpressionEvaluator extends Evaluator {

    /**
     * 
    
     * First, the evaluation depth is checked. An error is raised if the maximum evaluation
     * depth is exceeded.  The next step is the actual evaluation.  aExpression is a
     * Cons, so we can distinguish three cases:
    
     * 
      
     * 
    1. 
     * If  aExpression is a string starting with " , it is
     * simply copied in aResult. If it starts with another
     * character (this includes the case where it represents a
     * number), the environment is checked to see whether a
     * variable with this name exists. If it does, its value is
     * copied in aResult, otherwise aExpression is copied.
      
     *
     * 
    2. 
     * If aExpression is a list, the head of the list is
     * examined. If the head is not a string. ApplyFast()
     * is called. If the head is a string, it is checked against
     * the core commands (if there is a check, the corresponding
     * evaluator is called). Then it is checked agaist the list of
     * user function with getRulebase().   Again, the
     * corresponding evaluator is called if there is a check. If
     * all fails, ReturnUnEvaluated() is called.
      
     * 
    3. 
     * Otherwise (ie. if aExpression is a getJavaObject object), it is
     * copied in aResult.
      
     * 
    
     *
     * 
    
     * Note: The result of this operation must be a unique (copied)
     * element! Eg. its Next might be set...
    
     *
     * @param aEnvironment  the Lisp environment, in which the evaluation should take place
     * @param aResult             the result of the evaluation
     * @param aExpression     the expression to evaluate
     * @throws java.lang.Exception
     */
    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aExpression) throws Exception {

        LispError.lispAssert(aExpression.getCons() != null, aEnvironment, aStackTop);
        synchronized (aEnvironment) {
            aEnvironment.iEvalDepth++;
            if (aEnvironment.iEvalDepth >= aEnvironment.iMaxEvalDepth) {
                /* if (aEnvironment.iEvalDepth > aEnvironment.iMaxEvalDepth + 20) {
                LispError.check(aEnvironment, aStackTop, aEnvironment.iEvalDepth < aEnvironment.iMaxEvalDepth, LispError.USER_INTERRUPT, "INTERNAL");
                } else {*/
                LispError.check(aEnvironment, aStackTop, aEnvironment.iEvalDepth < aEnvironment.iMaxEvalDepth, LispError.MAXIMUM_RECURSE_DEPTH_REACHED, "INTERNAL");
                // }
            }

            if (Thread.interrupted()) {
                LispError.raiseError("User halted calculation.", "", aStackTop, aEnvironment);
            }
        }



        // evaluate an atom: find the bound value (treat it as a variable)
        if (aExpression.car() instanceof String) {
            String str = (String) aExpression.car();
            if (str.charAt(0) == '\"') {
                aResult.setCons(aExpression.getCons().copy(aEnvironment, false));
                aEnvironment.iEvalDepth--;
                return;
            }

            ConsPointer val = new ConsPointer();
            aEnvironment.getGlobalVariable(aStackTop, str, val);
            if (val.getCons() != null) {
                aResult.setCons(val.getCons().copy(aEnvironment, false));
                aEnvironment.iEvalDepth--;
                return;
            }
            aResult.setCons(aExpression.getCons().copy(aEnvironment, false));
            aEnvironment.iEvalDepth--;
            return;
        }
        {


            if (aExpression.car() instanceof ConsPointer) {
                ConsPointer subList = (ConsPointer) aExpression.car();
                Cons head = subList.getCons();
                if (head != null) {

                    String functionName;

                    if (head.car() instanceof String) {

                        functionName = (String) head.car();

                        //Built-in function handler.
                        BuiltinFunctionEvaluator builtinInFunctionEvaluator = (BuiltinFunctionEvaluator) aEnvironment.getBuiltinFunctions().lookUp(functionName);
                        if (builtinInFunctionEvaluator != null) {
                            builtinInFunctionEvaluator.evaluate(aEnvironment, aStackTop, aResult, subList);
                            aEnvironment.iEvalDepth--;
                            return;
                        }

                        //User function handler.
                        SingleArityRulebase userFunction;
                        userFunction = getUserFunction(aEnvironment, aStackTop, subList);
                        if (userFunction != null) {
                            userFunction.evaluate(aEnvironment, aStackTop, aResult, subList);
                            aEnvironment.iEvalDepth--;
                            return;
                        }


                    } else {
                        //Pure function handler.
                        ConsPointer operator = new ConsPointer();
                        ConsPointer args2 = new ConsPointer();
                        operator.setCons(subList.getCons());
                        args2.setCons(subList.cdr().getCons());
                        Utility.applyPure(aStackTop, operator, args2, aResult, aEnvironment);
                        aEnvironment.iEvalDepth--;
                        return;
                    }
                    //printf("**** Undef: %s\n",head.String().String());


                    /*  todo:tk: This code is for experimenting with having non-existent functions throw an exception when they are called.
                    if (functionName.equals("_")) {
                        Utility.returnUnEvaluated(aStackTop, aResult, subList, aEnvironment);
                        aEnvironment.iEvalDepth--;
                        return;
                    } else {
                        LispError.raiseError("The function " + functionName + " is not defined.\n", null, aStackTop, aEnvironment );
                    }*/


                    Utility.returnUnEvaluated(aStackTop, aResult, subList, aEnvironment);

                    aEnvironment.iEvalDepth--;

                    return;




                }
            }
            aResult.setCons(aExpression.getCons().copy(aEnvironment, false));
        }
        aEnvironment.iEvalDepth--;
    }


    SingleArityRulebase getUserFunction(Environment aEnvironment, int aStackTop, ConsPointer subList) throws Exception {
        Cons head = subList.getCons();
        SingleArityRulebase userFunc = null;

        userFunc = (SingleArityRulebase) aEnvironment.getRulebase(aStackTop, subList);
        if (userFunc != null) {
            return userFunc;
        } else if (head.car() instanceof String) {
            MultipleArityRulebase multiUserFunc = aEnvironment.getMultipleArityRulebase(aStackTop, (String) head.car(), true);
            if (multiUserFunc.iFileToOpen != null) {
                DefFile def = multiUserFunc.iFileToOpen;

                if (DEBUG) {
                    /*Show loading... */

                    if (VERBOSE_DEBUG) {
                        /*char buf[1024];
                        #ifdef HAVE_VSNPRINTF
                        snprintf(buf,1024,"Debug> Loading file %s for function %s\n",def.iFileName.c_str(),head.String().c_str());
                        #else
                        sprintf(buf,      "Debug> Loading file %s for function %s\n",def.iFileName.c_str(),head.String().c_str());
                        #endif
                        aEnvironment.write(buf);*/
                        if (TRACE_TO_STANDARD_OUT) {
                            System.out.print("Debug> Loading file" + def.iFileName + " for function " + head.car() + "\n");
                        } else {
                            aEnvironment.write("Debug> Loading file" + def.iFileName + " for function " + head.car() + "\n");
                        }

                        int debugBreakpoint = 0;
                    }
                }



                multiUserFunc.iFileToOpen = null;
                Utility.loadScriptOnce(aEnvironment, aStackTop, def.iFileName);

                if (DEBUG) {
                    //extern int VERBOSE_DEBUG;
                    if (VERBOSE_DEBUG) {
                        /*
                        char buf[1024];
                        #ifdef HAVE_VSNPRINTF
                        snprintf(buf,1024,"Debug> Finished loading file %s\n",def.iFileName.c_str());
                        #else
                        sprintf(buf,      "Debug> Finished loading file %s\n",def.iFileName.c_str());
                        #endif*/

                        if (TRACE_TO_STANDARD_OUT) {
                            System.out.print("Debug> Finished loading file " + def.iFileName + "\n");
                        } else {
                            aEnvironment.write("Debug> Finished loading file " + def.iFileName + "\n");
                        }

                    }
                }
            }
            userFunc = aEnvironment.getRulebase(aStackTop, subList);
        }
        return userFunc;
    }//end method.
    /*
    void TracedStackEvaluator::PushFrame()
    {
    UserStackInformation *op = NEW UserStackInformation;
    objs.Append(op);
    }

    void TracedStackEvaluator::PopFrame()
    {
    LISPASSERT (objs.Size() > 0);
    if (objs[objs.Size()-1])
    {
    delete objs[objs.Size()-1];
    objs[objs.Size()-1] = null;
    }
    objs.Delete(objs.Size()-1);
    }

    void TracedStackEvaluator::ResetStack()
    {
    while (objs.Size()>0)
    {
    PopFrame();
    }
    }

    UserStackInformation& TracedStackEvaluator::StackInformation()
    {
    return *(objs[objs.Size()-1]);
    }

    TracedStackEvaluator::~TracedStackEvaluator()
    {
    ResetStack();
    }

    void TracedStackEvaluator::ShowStack(Environment aEnvironment, LispOutput& aOutput)
    {
    LispLocalEvaluator local(aEnvironment,NEW BasicEvaluator);

    LispInt i;
    LispInt from=0;
    LispInt upto = objs.Size();

    for (i=from;i ");
    #endif
    InternalIntToAscii(str,i);
    aEnvironment.write(str);
    aEnvironment.write(": ");
    aEnvironment.CurrentPrinter().Print(objs[i].iOperator, *aEnvironment.CurrentOutput(),aEnvironment);

    LispInt internal;
    internal = (null != aEnvironment.CoreCommands().LookUp(objs[i].iOperator.String()));
    if (internal)
    {
    aEnvironment.write(" (Internal function) ");
    }
    else
    {
    if (objs[i].iRulePrecedence>=0)
    {
    aEnvironment.write(" (Rule # ");
    InternalIntToAscii(str,objs[i].iRulePrecedence);
    aEnvironment.write(str);
    if (objs[i].iSide)
    aEnvironment.write(" in body) ");
    else
    aEnvironment.write(" in pattern) ");
    }
    else
    aEnvironment.write(" (User function) ");
    }
    if (!!objs[i].iExpression)
    {
    aEnvironment.write("\n      ");
    if (aEnvironment.iEvalDepth>(aEnvironment.iMaxEvalDepth-10))
    {
    LispString expr;
    PrintExpression(expr, objs[i].iExpression,aEnvironment,60);
    aEnvironment.write(expr.c_str());
    }
    else
    {
    LispPtr getSubList = objs[i].iExpression.SubList();
    if (!!getSubList && !!getSubList)
    {
    LispString expr;
    LispPtr out(objs[i].iExpression);
    PrintExpression(expr, out,aEnvironment,60);
    aEnvironment.write(expr.c_str());
    }
    }
    }
    aEnvironment.write("\n");
    }
    }

    void TracedStackEvaluator::Eval(Environment aEnvironment, ConsPointer aResult,
    ConsPointer aExpression)
    {
    if (aEnvironment.iEvalDepth>=aEnvironment.iMaxEvalDepth)
    {
    ShowStack(aEnvironment, *aEnvironment.CurrentOutput());
    CHK2(aEnvironment.iEvalDepth= 0 && aError < MAXIMUM_NUMBER_OF_ERRORS, aEnvironment, aStackTop);

        if (aError < 0 || aError >= MAXIMUM_NUMBER_OF_ERRORS) {
            throw new EvaluationException("Maximum number of errors exceeded.", "", -1);
        }


        //    switch (aError)
        {
            if (aError == NONE) {
                return "No error.";
            }
            if (aError == INVALID_ARGUMENT) {
                return "Invalid argument.";
            }
            if (aError == WRONG_NUMBER_OF_ARGUMENTS) {
                return "Wrong number of arguments.";
            }
            if (aError == NOT_A_LIST) {
                return "Argument is not a list.";
            }
            if (aError == NOT_LONG_ENOUGH) {
                return "List not long enough.";
            }
            if (aError == INVALID_STACK) {
                return "Invalid stack.";
            }
            if (aError == QUITTING) {
                return "Quitting...";
            }
            if (aError == NOT_ENOUGH_MEMORY) {
                return "Not enough memory.";
            }
            if (aError == INVALID_TOKEN) {
                return "Empty token during parsing.";
            }
            if (aError == INVALID_EXPRESSION) {
                return "Error parsing expression.";
            }
            if (aError == UNPRINTABLE_TOKEN) {
                return "Unprintable atom.";
            }
            if (aError == FILE_NOT_FOUND) {
                return "File not found.";
            }
            if (aError == READING_FILE) {
                return "Error reading file.";
            }
            if (aError == CREATING_USER_FUNCTION) {
                return "Could not create user function.";
            }
            if (aError == CREATING_RULE) {
                return "Could not create rule.";
            }
            if (aError == ARITY_ALREADY_DEFINED) {
                return "Rule base with this arity already defined.";
            }
            if (aError == COMMENT_TO_END_OF_FILE) {
                return "Reaching end of file within a comment block.";
            }
            if (aError == NOT_A_STRING) {
                return "Argument is not a string.";
            }
            if (aError == NOT_AN_INTEGER) {
                return "Argument is not an integer.";
            }
            if (aError == PARSING_INPUT) {
                return "Error while parsing input.";
            }
            if (aError == MAXIMUM_RECURSE_DEPTH_REACHED) {
                return "Max evaluation stack depth reached.\nPlease use MaxEvalDepth to increase the stack size as needed.";
            }
            if (aError == DEF_FILE_ALREADY_CHOSEN) {
                return "DefFile already chosen for function.";
            }
            if (aError == DIVIDE_BY_ZERO) {
                return "Divide by zero.";
            }
            if (aError == NOT_AN_INFIX_OPERATOR) {
                return "Trying to make a non-infix operator right-associative.";
            }
            if (aError == IS_NOT_INFIX) {
                return "Trying to get precedence of non-infix operator.";
            }
            if (aError == SECURITY_BREACH) {
                return "Trying to perform an insecure action.";
            }
            if (aError == LIBRARY_NOT_FOUND) {
                return "Could not find library.";
            }
            if (aError == USER_INTERRUPT) {
                return "User halted calculation.";
            }
            if (aError == NON_BOOLEAN_PREDICATE_IN_PATTERN) {
                return "Predicate doesn't evaluate to a boolean in pattern.";
            }
            if (aError == GENERIC_FORMAT) {
                return "Generic format.";
            }
            if (aError == LIST_LENGTHS_MUST_BE_EQUAL) {
                return "List lengths must be equal.";
            }
        }
        return "Unspecified Error.";
    }


    public static void check(Environment aEnvironment, int aStackTop, boolean hastobetrue, int aError, String functionName) throws Exception {
        if (!hastobetrue) {
            String errorMessage = errorString(aError);// + " In function " + functionName + ". ";

            check(hastobetrue, errorMessage, functionName, aStackTop, aEnvironment);

        }
    }//end method.


    public static void check(boolean predicate, String aErrorMessage, String functionName, int aStackTop, Environment aEnvironment) throws Exception {
        if (!predicate) {
            String stackTrace = "";

            if (Evaluator.isStackTraced() && aStackTop >= 0) {
                stackTrace = aEnvironment.iArgumentStack.dump(aStackTop, aEnvironment);

                stackTrace = stackTrace + aEnvironment.dumpLocalVariablesFrame(aStackTop);
            }


            if (aStackTop == -1) {
                throw new EvaluationException("Error encountered during initialization or parsing: " + aErrorMessage + stackTrace, "none", -1);
            } else if (aStackTop == -2) {
                throw new EvaluationException("Error: " + aErrorMessage + stackTrace, "none", -1);
            } else {
                ConsPointer arguments = BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 0);
                if (arguments.getCons() == null) {
                    throw new EvaluationException("Error in compiled code." + stackTrace, "none", -1);
                } else {
                    //TODO FIXME          ShowStack(aEnvironment);
                    aErrorMessage = aErrorMessage + " " + showFunctionError(arguments, aEnvironment) + "internal.";
                }


                throw new EvaluationException(aErrorMessage /*+ " In function " + functionName + ". " */ + stackTrace, "none", -1);

            }
        }
    }//end method.


    public static void raiseError(String errorMessage, String functionName, int aStackTop, Environment aEnvironment) throws Exception {
        check(false, errorMessage, functionName, aStackTop, aEnvironment);
        //throw new EvaluationException(errorMessage + " In function " + functionName + ". ","none",-1);
    }


    public static void checkNumberOfArguments(int aStackTop, int n, ConsPointer aArguments, Environment aEnvironment, String functionName) throws Exception {
        int nrArguments = Utility.listLength(aEnvironment, aStackTop, aArguments);
        if (nrArguments != n) {
            errorNumberOfArguments(n - 1, nrArguments - 1, aArguments, aEnvironment, functionName, aStackTop);
        }
    }


    public static void errorNumberOfArguments(int needed, int passed, ConsPointer aArguments, Environment aEnvironment, String functionName, int aStackTop) throws Exception {
        String stackTrace = "";

        if (Evaluator.isStackTraced() && aStackTop >= 0) {
            stackTrace = aEnvironment.iArgumentStack.dump(aStackTop, aEnvironment);

            stackTrace = stackTrace + aEnvironment.dumpLocalVariablesFrame(aStackTop);
        }

        if (aArguments.getCons() == null) {
            throw new EvaluationException("Error in compiled code." + stackTrace, "none", -1);
        } else {
            //TODO FIXME      ShowStack(aEnvironment);
            String error = showFunctionError(aArguments, aEnvironment) + "expected " + needed + " arguments, got " + passed + /*" in function " + functionName +*/ ". ";
            throw new EvaluationException(error + stackTrace, "none", -1);

            /*TODO FIXME
            LispChar str[20];
            aEnvironment.iErrorOutput.Write("expected ");
            InternalIntToAscii(str,needed);
            aEnvironment.iErrorOutput.Write(str);
            aEnvironment.iErrorOutput.Write(" arguments, got ");
            InternalIntToAscii(str,passed);
            aEnvironment.iErrorOutput.Write(str);
            aEnvironment.iErrorOutput.Write("\n");
            LispError.check(passed == needed,LispError.WRONG_NUMBER_OF_ARGUMENTS);
             */
        }
    }


    public static String showFunctionError(ConsPointer aArguments, Environment aEnvironment) throws Exception {
        if (aArguments.getCons() == null) {
            return "Error in compiled code. ";
        } else {
            String string = (String) aArguments.car();
            if (string != null) {
                return "In function \"" + string + "\" : ";
            }
        }
        return "[Atom]";
    }


    public static void check(Environment aEnvironment, int aStackTop, boolean aPredicate, int errNo) throws Exception {
        if (!aPredicate) {

            String stackTrace = "";

            if (Evaluator.isStackTraced() && aStackTop >= 0) {
                stackTrace = aEnvironment.iArgumentStack.dump(aStackTop, aEnvironment);

                stackTrace = stackTrace + aEnvironment.dumpLocalVariablesFrame(aStackTop);
            }

            if (aStackTop == -1) {
                throw new EvaluationException("Error encountered during initialization: " + errorString(errNo) + stackTrace, "none", -1);
            } else if (aStackTop == -2) {
                throw new EvaluationException("Error: " + errorString(errNo) + stackTrace, "none", -1);
            } else {
                ConsPointer arguments = BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 0);
                if (arguments.getCons() == null) {
                    throw new EvaluationException("Error in compiled code." + stackTrace, "none", -1);
                } else {
                    String error = "";
                    error = error + showFunctionError(arguments, aEnvironment) + "internal.";
                    throw new EvaluationException(error + stackTrace, "none", -1);
                }
            }
        }
    }


    public static void lispAssert(boolean aPredicate, Environment aEnvironment, int aStackTop) throws Exception {
        if (!aPredicate) {
            //throw new EvaluationException("Assertion failed.","none",-1);
            check(aPredicate, "Assertion error.", "", aStackTop, aEnvironment);
        }
    }


    public static void checkArgument(Environment aEnvironment, int aStackTop, boolean aPredicate, int aArgNr, String functionName) throws Exception {
        checkArgumentTypeWithError(aEnvironment, aStackTop, aPredicate, aArgNr, "", functionName);
    }


    public static void checkIsList(Environment aEnvironment, int aStackTop, ConsPointer evaluated, int aArgNr, String functionName) throws Exception {
        checkArgumentTypeWithError(aEnvironment, aStackTop, Utility.isSublist(evaluated), aArgNr, "argument is not a list.", functionName);
    }


    public static void checkIsString(Environment aEnvironment, int aStackTop, ConsPointer evaluated, int aArgNr, String functionName) throws Exception {
        checkArgumentTypeWithError(aEnvironment, aStackTop, Utility.isString(evaluated.car()), aArgNr, "argument is not a string.", functionName);
    }


    public static void checkArgumentTypeWithError(Environment aEnvironment, int aStackTop, boolean aPredicate, int aArgNr, String aErrorDescription, String functionName) throws Exception {
        if (!aPredicate) {
            String stackTrace = "";

            if (Evaluator.isStackTraced() && aStackTop >= 0) {
                stackTrace = aEnvironment.iArgumentStack.dump(aStackTop, aEnvironment);

                stackTrace = stackTrace + aEnvironment.dumpLocalVariablesFrame(aStackTop);
            }

            ConsPointer arguments = BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 0);
            if (arguments.getCons() == null) {
                throw new EvaluationException("Error in compiled code." + stackTrace, "none", -1);
            } else {
                String error = "";
                error = error + showFunctionError(arguments, aEnvironment) + "\nbad argument number " + aArgNr + "(counting from 1) : \n" + aErrorDescription + "\n";
                ConsPointer arg = BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, arguments, aArgNr);
                String strout;

                error = error + "The offending argument ";
                strout = Utility.printMathPiperExpression(aStackTop, arg, aEnvironment, 60);
                error = error + strout;

                ConsPointer eval = new ConsPointer();
                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, eval, arg);
                error = error + " evaluated to ";
                strout = Utility.printMathPiperExpression(aStackTop, eval, aEnvironment, 60);
                error = error + strout;
                error = error + "\n";

                throw new EvaluationException(error + stackTrace, "none", -1);
            }//end else.
        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/Operator.java0000644000175000017500000000270011506531763025124 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

public class Operator {

    public int iPrecedence;
    public int iLeftPrecedence;
    public int iRightPrecedence;
    public int iRightAssociative;


    public Operator(int aPrecedence) {
        iPrecedence = aPrecedence;
        iLeftPrecedence = aPrecedence;
        iRightPrecedence = aPrecedence;
        iRightAssociative = 0;
    }


    public void setRightAssociative() {
        iRightAssociative = 1;
    }


    public void setLeftPrecedence(int aPrecedence) {
        iLeftPrecedence = aPrecedence;
    }


    public void setRightPrecedence(int aPrecedence) {
        iRightPrecedence = aPrecedence;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/Utility.java0000644000175000017500000020415211554752464025007 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

import org.mathpiper.lisp.collections.OperatorMap;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.cons.SublistCons;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.Cons;
import java.io.InputStreamReader;
import java.util.HashMap;
import java.util.Iterator;
import java.util.Map;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.io.InputStatus;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.builtin.JavaObject;
import org.mathpiper.io.InputDirectories;
import org.mathpiper.lisp.behaviours.Substitute;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import org.mathpiper.lisp.rulebases.MultipleArityRulebase;
import org.mathpiper.lisp.printers.MathPiperPrinter;
import org.mathpiper.lisp.parsers.MathPiperParser;
import org.mathpiper.io.JarFileInputStream;
import org.mathpiper.io.StandardFileInputStream;
import org.mathpiper.io.StringInputStream;
import org.mathpiper.io.StringOutput;
import org.mathpiper.io.StringOutputStream;
import org.mathpiper.lisp.behaviours.BackQuoteSubstitute;
import org.mathpiper.lisp.cons.BuiltinObjectCons;
import org.mathpiper.lisp.cons.NumberCons;
import org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher;
import org.mathpiper.lisp.parametermatchers.PatternParameterMatcher;
import org.mathpiper.lisp.parsers.Parser;
import org.mathpiper.lisp.printers.LispPrinter;
import org.mathpiper.lisp.rulebases.Rule;
import org.mathpiper.lisp.rulebases.ParameterName;
import org.mathpiper.lisp.rulebases.MacroRulebase;
import org.mathpiper.lisp.rulebases.PatternRule;
import org.mathpiper.lisp.rulebases.SingleArityRulebase;

public class Utility {

    public static final int ATOM = 1;
    public static final int NUMBER = 2;
    public static final int SUBLIST = 3;
    public static final int OBJECT = 4;
    static int log2_table_size = 32;    // A lookup table of Ln(n)/Ln(2) for n = 1 .. 32.
    // With this we don't have to use math.h if all we need is to convert the number of digits from one base to another. This is also faster.
    // Generated by: PrintList(N(Ln(1 .. 32)/Ln(2)), ",") at getPrecision 40.
    static double log2_table[] = {
        0.,
        1.,
        1.5849625007211561814537389439478165087598,
        2.,
        2.3219280948873623478703194294893901758648,
        2.5849625007211561814537389439478165087598,
        2.807354922057604107441969317231830808641,
        3.,
        3.1699250014423123629074778878956330175196,
        3.3219280948873623478703194294893901758648,
        3.4594316186372972561993630467257929587032,
        3.5849625007211561814537389439478165087598,
        3.7004397181410921603968126542566947336284,
        3.807354922057604107441969317231830808641,
        3.9068905956085185293240583734372066846246,
        4.,
        4.0874628412503394082540660108104043540112,
        4.1699250014423123629074778878956330175196,
        4.2479275134435854937935194229068344226935,
        4.3219280948873623478703194294893901758648,
        4.3923174227787602888957082611796473174008,
        4.4594316186372972561993630467257929587032,
        4.5235619560570128722941482441626688444988,
        4.5849625007211561814537389439478165087598,
        4.6438561897747246957406388589787803517296,
        4.7004397181410921603968126542566947336284,
        4.7548875021634685443612168318434495262794,
        4.807354922057604107441969317231830808641,
        4.8579809951275721207197733246279847624768,
        4.9068905956085185293240583734372066846246,
        4.9541963103868752088061235991755544235489,
        5.
    };
    public static java.util.zip.ZipFile zipFile = null;
    public static String scriptsPath = null;

    public static boolean isNumber(String ptr, boolean aAllowFloat) {

        if (ptr.length() == 0) {
            return false;
        }//end if.

        int pos = 0;
        if (ptr.charAt(pos) == '-' || ptr.charAt(pos) == '+') {
            pos++;
        }
        int nrDigits = 0;
        int index = 0;
        if (pos + index == ptr.length()) {
            return false;
        }
        while (ptr.charAt(pos + index) >= '0' && ptr.charAt(pos + index) <= '9') {
            nrDigits++;
            index++;
            if (pos + index == ptr.length()) {
                return true;
            }
        }
        if (ptr.charAt(pos + index) == '.') {
            if (!aAllowFloat) {
                return false;
            }
            index++;
            if (pos + index == ptr.length()) {
                return true;
            }
            while (ptr.charAt(pos + index) >= '0' && ptr.charAt(pos + index) <= '9') {
                nrDigits++;
                index++;
                if (pos + index == ptr.length()) {
                    return true;
                }
            }
        }
        if (nrDigits == 0) {
            return false;
        }
        if (ptr.charAt(pos + index) == 'e' || ptr.charAt(pos + index) == 'E') {
            if (!aAllowFloat) {
                return false;
            }
            if (!BigNumber.numericSupportForMantissa()) {
                return false;
            }
            index++;
            if (pos + index == ptr.length()) {
                return true;
            }
            if (ptr.charAt(pos + index) == '-' || ptr.charAt(pos + index) == '+') {
                index++;
            }
            while (ptr.charAt(pos + index) >= '0' && ptr.charAt(pos + index) <= '9') {
                index++;
                if (pos + index == ptr.length()) {
                    return true;
                }
            }
        }
        if (ptr.length() != (pos + index)) {
            return false;
        }
        return true;
    }

    public static int listLength(Environment aEnvironment, int aStackTop, ConsPointer aOriginal) throws Exception {
        ConsPointer consTraverser = new ConsPointer( aOriginal.getCons());
        int length = 0;
        while (consTraverser.getCons() != null) {
            consTraverser.goNext(aStackTop, aEnvironment);
            length++;
        }
        return length;
    }

    public static void reverseList(Environment aEnvironment, ConsPointer aResult, ConsPointer aOriginal) {
        //ConsPointer iter = new ConsPointer(aOriginal);
        ConsPointer iter = new ConsPointer();
        iter.setCons(aOriginal.getCons());
        ConsPointer previous = new ConsPointer();
        ConsPointer tail = new ConsPointer();
        tail.setCons(aOriginal.getCons());

        while (iter.getCons() != null) {
            tail.setCons(iter.cdr().getCons());
            iter.cdr().setCons(previous.getCons());
            previous.setCons(iter.getCons());
            iter.setCons(tail.getCons());
        }
        aResult.setCons(previous.getCons());
    }

    public static void returnUnEvaluated(int aStackTop, ConsPointer aResult, ConsPointer aArguments, Environment aEnvironment) throws Exception {
        ConsPointer full = new ConsPointer();
        full.setCons(aArguments.getCons().copy(aEnvironment, false));
        aResult.setCons(SublistCons.getInstance(aEnvironment, full.getCons()));

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, aArguments);
        consTraverser.goNext(aStackTop);

        while (consTraverser.getCons() != null) {
            ConsPointer next = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, next, consTraverser.getPointer());
            full.cdr().setCons(next.getCons());
            full.setCons(next.getCons());
            consTraverser.goNext(aStackTop);
        }
        full.cdr().setCons(null);
    }

    //Evaluate a function which is in string form.
    public static void applyString(Environment aEnvironment, int aStackTop, ConsPointer aResult, String aOperator, ConsPointer aArgs) throws Exception {
        LispError.check(aEnvironment, aStackTop, isString(aOperator), LispError.NOT_A_STRING, "INTERNAL");

        Cons head = AtomCons.getInstance(aEnvironment, aStackTop, getSymbolName(aEnvironment, aOperator));
        head.cdr().setCons(aArgs.getCons());
        ConsPointer body = new ConsPointer();
        body.setCons(SublistCons.getInstance(aEnvironment, head));
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, aResult, body);
    }

    public static void applyPure(int aStackTop, ConsPointer oper, ConsPointer args2, ConsPointer aResult, Environment aEnvironment) throws Exception {
        LispError.check(aEnvironment, aStackTop, oper.car() instanceof ConsPointer, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, ((ConsPointer) oper.car()).getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        ConsPointer oper2 = new ConsPointer();
        oper2.setCons(((ConsPointer) oper.car()).cdr().getCons());
        LispError.check(aEnvironment, aStackTop, oper2.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");

        ConsPointer body = new ConsPointer();
        body.setCons(oper2.cdr().getCons());
        LispError.check(aEnvironment, aStackTop, body.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");

        LispError.check(aEnvironment, aStackTop, oper2.car() instanceof ConsPointer, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, ((ConsPointer) oper2.car()).getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        oper2.setCons(((ConsPointer) oper2.car()).cdr().getCons());

        aEnvironment.pushLocalFrame(false, "Pure");
        try {
            while (oper2.getCons() != null) {
                LispError.check(aEnvironment, aStackTop, args2.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");

                String var = (String) oper2.car();
                LispError.check(aEnvironment, aStackTop, var != null, LispError.INVALID_ARGUMENT, "INTERNAL");
                ConsPointer newly = new ConsPointer();
                newly.setCons(args2.getCons().copy(aEnvironment, false));
                aEnvironment.newLocalVariable(var, newly.getCons(), aStackTop);
                oper2.setCons(oper2.cdr().getCons());
                args2.setCons(args2.cdr().getCons());
            }
            LispError.check(aEnvironment, aStackTop, args2.getCons() == null, LispError.INVALID_ARGUMENT, "INTERNAL");
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, aResult, body);
        } catch (EvaluationException e) {
            throw e;
        } finally {
            aEnvironment.popLocalFrame(aStackTop);
        }

    }

    public static void putTrueInPointer(Environment aEnvironment, ConsPointer aResult) throws Exception {
        aResult.setCons(aEnvironment.iTrueAtom.copy(aEnvironment, false));
    }

    public static void putFalseInPointer(Environment aEnvironment, ConsPointer aResult) throws Exception {
        aResult.setCons(aEnvironment.iFalseAtom.copy(aEnvironment, false));
    }

    public static void putBooleanInPointer(Environment aEnvironment, ConsPointer aResult, boolean aValue) throws Exception {
        if (aValue) {
            putTrueInPointer(aEnvironment, aResult);
        } else {
            putFalseInPointer(aEnvironment, aResult);
        }
    }

    public static void nth(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArg, int n) throws Exception {
        LispError.check(aEnvironment, aStackTop, aArg.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, aArg.car() instanceof ConsPointer, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, n >= 0, LispError.INVALID_ARGUMENT, "INTERNAL");
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, (ConsPointer) aArg.car());

        while (n > 0) {
            LispError.check(aEnvironment, aStackTop, consTraverser.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
            consTraverser.goNext(aStackTop);
            n--;
        }
        LispError.check(aEnvironment, aStackTop, consTraverser.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        aResult.setCons(consTraverser.getCons().copy(aEnvironment, false));
    }

    public static void tail(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArg) throws Exception {
        LispError.check(aEnvironment, aStackTop, aArg.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, aArg.car() instanceof ConsPointer, LispError.INVALID_ARGUMENT, "INTERNAL");

        ConsPointer iter = (ConsPointer) aArg.car();

        LispError.check(aEnvironment, aStackTop, iter.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        aResult.setCons(SublistCons.getInstance(aEnvironment, iter.cdr().getCons()));
    }


    public static boolean isTrue(Environment aEnvironment, ConsPointer aExpression, int aStackTop) throws Exception {
        LispError.lispAssert(aExpression.getCons() != null, aEnvironment, aStackTop);

        //return aExpression.car() == aEnvironment.iTrueAtom.car();
        return aExpression.car() instanceof String && ((String) aExpression.car()).equals(aEnvironment.iTrueString);

        /* Code which returns True for everything except False and {};
        String expressionString = aExpression.car();

        //return expressionString == aEnvironment.iTrueString;

        if (expressionString == aEnvironment.iTrueString) {
        return true;
        } else if (isSublist(aExpression)) {
        if (listLength(aExpression.car()) == 1) {
        //Empty list.
        return false;
        } else {
        //Non-empty list.
        return true;
        }
        } else {
        //Anything other than False returns true.
        return expressionString != null && expressionString != aEnvironment.iFalseString;
        }*/

    }//end method.
    public static boolean isFalse(Environment aEnvironment, ConsPointer aExpression, int aStackTop) throws Exception {
        LispError.lispAssert(aExpression.getCons() != null, aEnvironment, aStackTop);
        return aExpression.car() instanceof String && ((String) aExpression.car()).equals(aEnvironment.iFalseString);

        /* Code which returns True for everything except False and {};
        return aExpression.car() == aEnvironment.iFalseString || (isSublist(aExpression) && (listLength(aExpression.car()) == 1));
         */
    }

    public static String getSymbolName(Environment aEnvironment, String aSymbol) {
        if (aSymbol.charAt(0) == '\"') {
            return aEnvironment.getTokenHash().lookUpUnStringify(aSymbol);
        } else {
            return (String) aEnvironment.getTokenHash().lookUp(aSymbol);
        }
    }

    public static boolean isSublist(ConsPointer aPtr) throws Exception {
        /**
         * todo:tk: I am currently not sure why non nested lists are not supported in Yacas.
         */
        if (aPtr.getCons() == null) {
            return false;
        }
        if (!(aPtr.car() instanceof ConsPointer)) {
            return false;
        }
        if (((ConsPointer) aPtr.car()).getCons() == null) {
            return false;
            //TODO this StrEqual is far from perfect. We could pass in a Environment object...
        }
        if (!((ConsPointer) aPtr.car()).car().equals("List")) {
            return false;
        }
        return true;

    }//end method.

    public static boolean isList(ConsPointer aPtr) throws Exception {
        /**
         * todo:tk: I am currently not sure why non nested lists are not supported in Yacas.
         */
        if (aPtr.getCons() == null) {
            return false;
        }

        if (aPtr.type() == Utility.ATOM) {
            if (((String) aPtr.car()).equalsIgnoreCase("List")) {
                return true;
            }//end if.
        }//end if.

        if (isSublist(aPtr)) {
            return true;
        }//end if.
        return false;

    }//end method.

    public static boolean isNestedList(Environment aEnvironment, int aStackTop, ConsPointer clientListPointer) throws Exception {

        ConsPointer listPointer = new ConsPointer( clientListPointer.getCons());

        listPointer.goNext(aStackTop, aEnvironment); //Strip List tag.

        while (listPointer.getCons() != null) {
            if (listPointer.car() instanceof ConsPointer && isList((ConsPointer) listPointer.car())) {
                listPointer.goNext(aStackTop, aEnvironment);
            } else {
                return false;
            }
        }//end while.
        return true;
    }//end method.

    public static Map optionsListToJavaMap(Environment aEnvironment, int aStackTop, ConsPointer argumentsPointer, Map defaultOptions) throws Exception {

        Map userOptions = (Map) ((HashMap) defaultOptions).clone();

        while (argumentsPointer.getCons() != null) {
            //Obtain -> operator.
            ConsPointer optionPointer = (ConsPointer) argumentsPointer.car();
            LispError.check(aEnvironment, aStackTop, optionPointer.type() == Utility.ATOM, LispError.INVALID_ARGUMENT, "INTERNAL");
            String operator = (String) optionPointer.car();
            LispError.check(aEnvironment, aStackTop, operator.equals("->"), LispError.INVALID_ARGUMENT, "INTERNAL");

            //Obtain key.
            optionPointer.goNext(aStackTop, aEnvironment);
            LispError.check(aEnvironment, aStackTop, optionPointer.type() == Utility.ATOM, LispError.INVALID_ARGUMENT, "INTERNAL");
            String key = (String) optionPointer.car();
            key = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, key);

            //Obtain value.
            optionPointer.goNext(aStackTop, aEnvironment);
            LispError.check(aEnvironment, aStackTop, optionPointer.type() == Utility.ATOM || optionPointer.type() == Utility.NUMBER, LispError.INVALID_ARGUMENT, "INTERNAL");
            if (optionPointer.type() == Utility.ATOM) {
                String value = (String) optionPointer.car();
                value = Utility.stripEndQuotesIfPresent(aEnvironment, aStackTop, value);
                if (value.equalsIgnoreCase("true") || value.equalsIgnoreCase("false")) {
                    userOptions.put(key, Boolean.parseBoolean(value));
                } else {
                    userOptions.put(key, value);
                }//ende else.
            } else //Number
            {
                NumberCons numberCons = (NumberCons) optionPointer.getCons();
                BigNumber bigNumber = (BigNumber) numberCons.getNumber(10, aEnvironment);
                Double value = bigNumber.toDouble();
                userOptions.put(key, value);
            }//end if/else.



            argumentsPointer.goNext(aStackTop, aEnvironment);

        }//end while

        return userOptions;
    }//end method.

    public static boolean isString(Object aOriginal) {

        if (!(aOriginal instanceof String)) {
            return false;
        }//end if.

        String stringVersion = (String) aOriginal;

        if (stringVersion != null) {
            if (stringVersion.charAt(0) == '\"') {
                if (stringVersion.charAt(stringVersion.length() - 1) == '\"') {
                    return true;
                }
            }
        }
        return false;
    }//end method


    public static String stripEndDollarSigns(String aOriginal) throws Exception {
        //If there are not dollar signs on both ends of the string then return without any changes.
        aOriginal = aOriginal.trim();
        if (aOriginal.startsWith("$") && aOriginal.endsWith("$")) {
            aOriginal = aOriginal.substring(1, aOriginal.length());
            aOriginal = aOriginal.substring(0, aOriginal.length() - 1);
        }//end if.

        return aOriginal;
    }//end method.

    public static void not(int aStackTop, ConsPointer aResult, Environment aEnvironment, ConsPointer aExpression) throws Exception {
        if (isTrue(aEnvironment, aExpression, aStackTop)) {
            putFalseInPointer(aEnvironment, aResult);
        } else {
            LispError.check(aEnvironment, aStackTop, isFalse(aEnvironment, aExpression, aStackTop), LispError.INVALID_ARGUMENT, "INTERNAL");
            putTrueInPointer(aEnvironment, aResult);
        }
    }

    public static void flatCopy(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aOriginal) throws Exception {
        ConsTraverser orig = new ConsTraverser(aEnvironment, aOriginal);
        ConsTraverser res = new ConsTraverser(aEnvironment, aResult);

        while (orig.getCons() != null) {
            res.getPointer().setCons(orig.getCons().copy(aEnvironment, false));
            orig.goNext(aStackTop);
            res.goNext(aStackTop);
        }
    }

    public static boolean equals(Environment aEnvironment, int aStackTop, ConsPointer aExpression1, ConsPointer aExpression2) throws Exception {
        // Handle pointers to same, or null
        if (aExpression1.getCons() == aExpression2.getCons()) {
            return true;
        }
        //LispError.check(aExpression1.type().equals("Number"), LispError.INVALID_ARGUMENT);
        //LispError.check(aExpression2.type().equals("Number"), LispError.INVALID_ARGUMENT);
        BigNumber n1 = (BigNumber) aExpression1.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        BigNumber n2 = (BigNumber) aExpression2.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        if (!(n1 == null && n2 == null)) {
            if (n1 == n2) {
                return true;
            }
            if (n1 == null) {
                return false;
            }
            if (n2 == null) {
                return false;
            }
            if (n1.equals(n2)) {
                return true;
            }
            return false;
        }

        //Pointers to strings should be the same
        if ((aExpression1.car() instanceof String) && (aExpression2.car() instanceof String)) {
            if (aExpression1.car() != aExpression2.car()) {
                return false;
            }
        }


        // Handle same sublists, or null
        if (aExpression1.car() == aExpression2.car()) {
            return true;
        }

        // Now check the sublists
        if (aExpression1.car() instanceof ConsPointer) {
            if (!(aExpression2.car() instanceof ConsPointer)) {
                return false;
            }
            ConsTraverser consTraverser1 = new ConsTraverser(aEnvironment, (ConsPointer) aExpression1.car());
            ConsTraverser consTraverser2 = new ConsTraverser(aEnvironment, (ConsPointer) aExpression2.car());

            while (consTraverser1.getCons() != null && consTraverser2.getCons() != null) {
                // compare two list elements
                if (!equals(aEnvironment, aStackTop, consTraverser1.getPointer(), consTraverser2.getPointer())) {
                    return false;
                }

                // Step to rest
                consTraverser1.goNext(aStackTop);
                consTraverser2.goNext(aStackTop);
            }
            // Lists don't have the same length
            if (consTraverser1.getCons() != consTraverser2.getCons()) {
                return false;            // Same!
            }
            return true;
        }

        // expressions sublists are not the same!
        return false;
    }

    public static void substitute(Environment aEnvironment, int aStackTop, ConsPointer aTarget, ConsPointer aSource, Substitute aBehaviour) throws Exception {
        Cons object = aSource.getCons();
        LispError.lispAssert(object != null, aEnvironment, aStackTop);
        if (!aBehaviour.matches(aEnvironment, aStackTop, aTarget, aSource)) {
            Object oldList = object.car();

            ConsPointer oldListPointer = null;
            if (oldList instanceof ConsPointer) {
                oldListPointer = (ConsPointer) oldList;
                oldList = null;
            }
            if (oldListPointer != null) {

                ConsPointer newList = new ConsPointer();
                ConsPointer next = newList;
                while (oldListPointer.getCons() != null) {
                    substitute(aEnvironment, aStackTop, next, oldListPointer, aBehaviour);
                    oldListPointer = oldListPointer.cdr();
                    next = next.cdr();
                }
                aTarget.setCons(SublistCons.getInstance(aEnvironment, newList.getCons()));
            } else {
                aTarget.setCons(object.copy(aEnvironment, false));
            }
        }//end matches if.
    }


    public static String stripEndQuotesIfPresent(Environment aEnvironment, int aStackTop, String aOriginal) throws Exception {
        //If there are not quotes on both ends of the string then return without any changes.
        if (aOriginal.startsWith("\"") && aOriginal.endsWith("\"")) {
            aOriginal = aOriginal.substring(1, aOriginal.length());
            aOriginal = aOriginal.substring(0, aOriginal.length() - 1);
        }//end if.

        return aOriginal;
    }//end method.

    

    public static String toNormalString(Environment aEnvironment, int aStackTop, String aOriginal) throws Exception {
        LispError.check(aEnvironment, aStackTop, aOriginal != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, aOriginal.charAt(0) == '\"', LispError.INVALID_ARGUMENT, "INTERNAL");
        int nrc = aOriginal.length() - 1;
        LispError.check(aEnvironment, aStackTop, aOriginal.charAt(nrc) == '\"', LispError.INVALID_ARGUMENT, "INTERNAL");
        return aOriginal.substring(1, nrc);
    }

    public static String toMathPiperString(Environment aEnvironment, int aStackTop, String aOriginal) throws Exception {
        LispError.check(aEnvironment, aStackTop, aOriginal != null, LispError.INVALID_ARGUMENT, "INTERNAL");

        return "\"" + aOriginal + "\"";
    }

    private static void doInternalLoad(Environment aEnvironment, int aStackTop, MathPiperInputStream aInput) throws Exception {
        MathPiperInputStream previous = aEnvironment.iCurrentInput;
        try {
            aEnvironment.iCurrentInput = aInput;
            // TODO make "EndOfFile" a global thing
            // read-parse-evaluate to the end of file
            String eof = (String) aEnvironment.getTokenHash().lookUp("EndOfFile");
            boolean endoffile = false;
            MathPiperParser parser = new MathPiperParser(new MathPiperTokenizer(),
                    aEnvironment.iCurrentInput, aEnvironment,
                    aEnvironment.iPrefixOperators, aEnvironment.iInfixOperators,
                    aEnvironment.iPostfixOperators, aEnvironment.iBodiedOperators);
            ConsPointer readIn = new ConsPointer();
            while (!endoffile) {
                // Read expression
                parser.parse(aStackTop, readIn);

                LispError.check(aEnvironment, aStackTop, readIn.getCons() != null, LispError.READING_FILE, "INTERNAL");
                // check for end of file
                if (readIn.car() instanceof String && ((String) readIn.car()).equals(eof)) {
                    endoffile = true;
                } // Else evaluate
                else {
                    ConsPointer result = new ConsPointer();
                    aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result, readIn);
                    aEnvironment.setGlobalVariable(aStackTop, "$LoadResult", result, false);//Note:tk:added to make the result of executing Loaded code available.
                }
            }//end while.



        } catch (Exception e) {
            //e.printStackTrace(); //todo:tk:uncomment for debugging.

            EvaluationException ee = new EvaluationException(e.getMessage(), aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
            throw ee;
        } finally {
            aEnvironment.iCurrentInput = previous;
        }
    }

    /**
     * Searches for a file on the classpath then in the default directories.  If the file is found, it is loaded.
     * @param aEnvironment
     * @param aFileName
     * @throws java.lang.Exception
     */
    public static void loadScript(Environment aEnvironment, int aStackTop, String aFileName) throws Exception {
        String oper = toNormalString(aEnvironment, aStackTop, aFileName);

        String hashedname = (String) aEnvironment.getTokenHash().lookUp(oper);

        InputStatus oldstatus = new InputStatus(aEnvironment.iInputStatus);
        aEnvironment.iInputStatus.setTo(hashedname);

        MathPiperInputStream newInput = null;

        String path = Utility.scriptsPath + oper;

        //Try to find script on classpath + scriptspath.
        java.io.InputStream inputStream = Utility.class.getResourceAsStream(path);

        //Try to find script on classpath.
        if(inputStream == null)
        {
            inputStream = Utility.class.getResourceAsStream(oper);
        }


        if (inputStream != null) //File is on the classpath.
        {
            newInput = new StandardFileInputStream(new InputStreamReader(inputStream), aEnvironment.iInputStatus);
            LispError.check(aEnvironment, aStackTop, newInput != null, LispError.FILE_NOT_FOUND, "INTERNAL");
            doInternalLoad(aEnvironment, aStackTop, newInput);

        } else { //File may be in the filesystem.
            try {
                // Open file
                newInput = // new StandardFileInputStream(hashedname, aEnvironment.iInputStatus);
                        openInputFile(aEnvironment, aEnvironment.iInputDirectories, hashedname, aEnvironment.iInputStatus);

                LispError.check(aEnvironment, aStackTop, newInput != null, LispError.FILE_NOT_FOUND, "INTERNAL");
                doInternalLoad(aEnvironment, aStackTop, newInput);
            } catch (Exception e) {
                throw e;
            } finally {
                aEnvironment.iInputStatus.restoreFrom(oldstatus);
            }
        }//end else.*/


        aEnvironment.iInputStatus.restoreFrom(oldstatus);


    }

    public static void loadScriptOnce(Environment aEnvironment, int aStackTop, String aFileName) throws Exception {
        DefFile def = aEnvironment.iDefFiles.getFile(aFileName);
        if (!def.isLoaded()) {
            def.setLoaded();
            loadScript(aEnvironment, aStackTop, aFileName);
        }
    }

    public static void doPatchString(String unpatchedString, MathPiperOutputStream aOutput, Environment aEnvironment, int aStackTop) throws Exception
    {
        String[] tags = unpatchedString.split("\\?\\>");
        if (tags.length > 1) {
            for (int x = 0; x < tags.length; x++) {
                String[] tag = tags[x].split("\\<\\?");
                if (tag.length > 1) {
                    aOutput.write(tag[0]);
                    String scriptCode = tag[1].trim();
                    StringBuffer scriptCodeBuffer = 
                        new StringBuffer(scriptCode);
                    StringInputStream scriptStream = 
                        new StringInputStream(scriptCodeBuffer, aEnvironment.iInputStatus);
                    MathPiperOutputStream previous = 
                        aEnvironment.iCurrentOutput;
                    try {
                        aEnvironment.iCurrentOutput = aOutput;
                        Utility.doInternalLoad(aEnvironment, aStackTop, scriptStream);
                    } catch(Exception e) {
                        throw e;
                    } finally {
                        aEnvironment.iCurrentOutput = previous;
                    }
                }
            } // end for
            aOutput.write(tags[tags.length - 1]);
        } else {
            aOutput.write(unpatchedString);
        }
    }

    public static String printMathPiperExpression(int aStackTop, ConsPointer aExpression, Environment aEnvironment, int aMaxChars) throws Exception {
        if(aExpression.getCons() == null)
        {
            return "NULL";
        }

        StringBuffer result = new StringBuffer();
        StringOutputStream newOutput = new StringOutputStream(result);
        MathPiperPrinter infixprinter = new MathPiperPrinter(aEnvironment.iPrefixOperators,
                aEnvironment.iInfixOperators,
                aEnvironment.iPostfixOperators,
                aEnvironment.iBodiedOperators);
        infixprinter.print(aStackTop, aExpression, newOutput, aEnvironment);
        if (aMaxChars > 0 && result.length() > aMaxChars) {
            result.delete(aMaxChars, result.length());
            result.append((char) '.');
            result.append((char) '.');
            result.append((char) '.');
        }
        return result.toString();
    }//end method.


    public static String printLispExpression( int aStackTop, ConsPointer aExpression, Environment aEnvironment, int aMaxChars) throws Exception {
        if(aExpression.getCons() == null)
        {
            return "NULL";
        }

        StringOutput out = new StringOutput();

        LispPrinter printer = new LispPrinter();

        printer.print(aStackTop, aExpression, out, aEnvironment);

        //todo:tk:add the ability to truncate the result.

        return out.toString();
    }

    public static MathPiperInputStream openInputFile(String aFileName, InputStatus aInputStatus) throws Exception {//Note:tk:primary method for file opening.

        try {
            if (zipFile != null) {
                java.util.zip.ZipEntry e = zipFile.getEntry(aFileName);
                if (e != null) {
                    java.io.InputStream s = zipFile.getInputStream(e);
                    return new StandardFileInputStream(new InputStreamReader(s), aInputStatus);
                }
            }

            if (aFileName.substring(0, 4).equals("jar:")) {
                return new JarFileInputStream(aFileName, aInputStatus);
            } else {
                return new StandardFileInputStream(aFileName, aInputStatus);
            }
        } catch (Exception e) {
            //MathPiper eats this exception because returning null indicates to higher level code that the file was not found.
        }
        return null;

        //return new StandardFileInputStream(aFileName, aInputStatus);
    }

    public static MathPiperInputStream openInputFile(Environment aEnvironment,
            InputDirectories aInputDirectories, String aFileName,
            InputStatus aInputStatus) throws Exception {
        String othername = aFileName;
        int i = 0;
        MathPiperInputStream f = openInputFile(othername, aInputStatus);
        while (f == null && i < aInputDirectories.size()) {
            othername = ((String) aInputDirectories.get(i)) + aFileName;
            f = openInputFile(othername, aInputStatus);
            i++;
        }
        return f;
    }

    public static String findFile(String aFileName, InputDirectories aInputDirectories) throws Exception {
        InputStatus inputStatus = new InputStatus();
        String othername = aFileName;
        int i = 0;
        MathPiperInputStream f = openInputFile(othername, inputStatus);
        if (f != null) {
            return othername;
        }
        while (i < aInputDirectories.size()) {
            othername = ((String) aInputDirectories.get(i)) + aFileName;
            f = openInputFile(othername, inputStatus);
            if (f != null) {
                return othername;
            }
            i++;
        }
        return "";
    }

    private static void doLoadDefFile(Environment aEnvironment, int aStackTop, MathPiperInputStream aInput, DefFile def) throws Exception {
        MathPiperInputStream previous = aEnvironment.iCurrentInput;
        try {
            aEnvironment.iCurrentInput = aInput;
            String eof = (String) aEnvironment.getTokenHash().lookUp("EndOfFile");
            String end = (String) aEnvironment.getTokenHash().lookUp("}");
            boolean endoffile = false;

            MathPiperTokenizer tok = new MathPiperTokenizer();

            while (!endoffile) {
                // Read expression
                String token = tok.nextToken(aEnvironment, aStackTop, aEnvironment.iCurrentInput, aEnvironment.getTokenHash());

                // check for end of file
                if (token.equals(eof) || token.equals(end)) {
                    endoffile = true;
                } // Else evaluate
                else {
                    String str = token;
                    MultipleArityRulebase multiUser = aEnvironment.getMultipleArityRulebase(aStackTop, str, true);
                    if (multiUser.iFileToOpen != null) {
                        throw new EvaluationException("[" + str + "]" + "] : def file already chosen: " + multiUser.iFileToOpen.iFileName, aEnvironment.iInputStatus.fileName(), aEnvironment.iCurrentInput.iStatus.lineNumber());
                    }
                    multiUser.iFileToOpen = def;
                    multiUser.iFileLocation = def.fileName();
                }
            }
        } catch (Exception e) {
            throw e;
        } finally {
            aEnvironment.iCurrentInput = previous;
        }
    }

    public static void loadDefFile(Environment aEnvironment, int aStackTop, String aFileName) throws Exception {
        LispError.lispAssert(aFileName != null, aEnvironment, aStackTop);

        String flatfile = toNormalString(aEnvironment, aStackTop, aFileName) + ".def";
        DefFile def = aEnvironment.iDefFiles.getFile(aFileName);

        String hashedname = (String) aEnvironment.getTokenHash().lookUp(flatfile);

        InputStatus oldstatus = aEnvironment.iInputStatus;
        aEnvironment.iInputStatus.setTo(hashedname);


        MathPiperInputStream newInput = null;

        String path = Utility.scriptsPath + flatfile;

        java.io.InputStream inputStream = Utility.class.getResourceAsStream(path);


        if (inputStream != null) //File is on the classpath.
        {
            newInput = new StandardFileInputStream(new InputStreamReader(inputStream), aEnvironment.iInputStatus);
            LispError.check(aEnvironment, aStackTop, newInput != null, LispError.FILE_NOT_FOUND, "INTERNAL");
            doLoadDefFile(aEnvironment, aStackTop, newInput, def);

        } else //File may be in the filesystem.
        {
            newInput = // new StandardFileInputStream(hashedname, aEnvironment.iInputStatus);
                    openInputFile(aEnvironment, aEnvironment.iInputDirectories, hashedname, aEnvironment.iInputStatus);
            LispError.check(aEnvironment, aStackTop, newInput != null, LispError.FILE_NOT_FOUND, "INTERNAL");
            doLoadDefFile(aEnvironment, aStackTop, newInput, def);
        }

        aEnvironment.iInputStatus.restoreFrom(oldstatus);
    }
    //////////////////////////////////////////////////
    ///// bits_to_digits and digits_to_bits implementation
    //////////////////////////////////////////////////

    // lookup table for transforming the number of digits
    // report the table size
    int log2TableRange() {
        return log2_table_size;
    }
    // table look-up of small integer logarithms, for converting the number of digits to binary and back

    static double log2TableLookup(int n) throws Exception {
        if (n <= log2_table_size && n >= 2) {
            return log2_table[n - 1];
        } else {
            throw new EvaluationException("log2_table_lookup: error: invalid argument " + n, "none", -1);
        }
    }

    /**
     * Convert the number of digits in given base to the number of bits.  To make sure there is no hysteresis, the returned
     * value is rounded up.
     *
     * @param digits
     * @param base
     * @return the number of bits
     * @throws java.lang.Exception
     */
    public static long digitsToBits(long digits, int base) throws Exception {
        return (long) Math.ceil(((double) digits) * log2TableLookup(base));
    }

    /**
     * Convert the  number of bits in a given base to the number of digits.  To make sure there is no hysteresis, the returned
     * value is rounded down.
     *
     * @param bits
     * @param base
     * @return the number of digits
     * @throws java.lang.Exception
     */
    public static long bitsToDigits(long bits, int base) throws Exception {
        return (long) Math.floor(((double) bits) / log2TableLookup(base));
    }

    //************************* The following methods were taken from the Functions class.
    /**
     * Construct a {@link BigNumber}.
     * @param aEnvironment the current {@link Environment}.
     * @param aStackTop points to the the top of the argument stack.
     * @param aArgNr the index of the argument to be converted.
     * @return a BigNumber.
     * @throws java.lang.Exception
     */
    public static BigNumber getNumber(Environment aEnvironment, int aStackTop, int aArgNr) throws Exception {
        //LispError.check(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, aArgNr).type().equals("Number"), LispError.INVALID_ARGUMENT);
        BigNumber x = (BigNumber) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, aArgNr).getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        LispError.checkArgument(aEnvironment, aStackTop, x != null, aArgNr, "INTERNAL");
        return x;
    }

    public static void multiFix(Environment aEnvironment, int aStackTop, OperatorMap aOps) throws Exception {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");
        String orig = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "INTERNAL");

        ConsPointer precedence = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, precedence, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2));
        LispError.checkArgument(aEnvironment, aStackTop, precedence.car() instanceof String, 2, "INTERNAL");
        int prec = Integer.parseInt((String) precedence.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, prec <= MathPiperPrinter.KMaxPrecedence, 2, "INTERNAL");
        aOps.setOperator(prec, Utility.getSymbolName(aEnvironment, orig));
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }

    public static void singleFix(int aPrecedence, Environment aEnvironment, int aStackTop, OperatorMap aOps) throws Exception {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");
        String orig = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "INTERNAL");
        aOps.setOperator(aPrecedence, Utility.getSymbolName(aEnvironment, orig));
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }

    public static Operator operatorInfo(Environment aEnvironment, int aStackTop, OperatorMap aOperators) throws Exception {
        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");

        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons());

        String orig = (String) evaluated.car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "INTERNAL");
        //
        Operator op = (Operator) aOperators.lookUp(Utility.getSymbolName(aEnvironment, orig));
        return op;
    }

    /**
     * Sets a variable in the current {@link Environment}.
     * @param aEnvironment holds the execution environment of the program.
     * @param aStackTop
     * @param aMacroMode boolean which determines whether the getFirstPointer argument should be evaluated.
     * @param aGlobalLazyVariable
     * @throws java.lang.Exception
     */
    public static void setVar(Environment aEnvironment, int aStackTop, boolean aMacroMode, boolean aGlobalLazyVariable) throws Exception {
        String variableString = null;
        if (aMacroMode) {
            ConsPointer result = new ConsPointer();
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1));
            variableString = (String) result.car();
        } else {
            variableString = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        }
        LispError.checkArgument(aEnvironment, aStackTop, variableString != null, 1, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, !Utility.isNumber(variableString, true), 1, "INTERNAL");

        ConsPointer result = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2));
        aEnvironment.setGlobalVariable(aStackTop, variableString, result, aGlobalLazyVariable); //Variable setting is deligated to Environment.
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }

    public static void delete(Environment aEnvironment, int aStackTop, boolean aDestructive) throws Exception {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkIsList(aEnvironment, aStackTop, evaluated, 1, "INTERNAL");

        ConsPointer copied = new ConsPointer();
        if (aDestructive) {
            copied.setCons(((ConsPointer) evaluated.car()).getCons());
        } else {
            Utility.flatCopy(aEnvironment, aStackTop, copied, (ConsPointer) evaluated.car());
        }

        ConsPointer index = new ConsPointer();
        index.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "INTERNAL");
        int ind = Integer.parseInt((String) index.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, ind > 0, 2, "INTERNAL");

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, copied);
        while (ind > 0) {
            consTraverser.goNext(aStackTop);
            ind--;
        }
        LispError.check(aEnvironment, aStackTop, consTraverser.getCons() != null, LispError.NOT_LONG_ENOUGH);
        ConsPointer next = new ConsPointer();
        next.setCons(consTraverser.cdr().getCons());
        consTraverser.getPointer().setCons(next.getCons());
        BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, copied.getCons()));
    }

    public static void insert(Environment aEnvironment, int aStackTop, boolean aDestructive) throws Exception {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        LispError.checkIsList(aEnvironment, aStackTop, evaluated, 1, "INTERNAL");

        ConsPointer copied = new ConsPointer();
        if (aDestructive) {
            copied.setCons(((ConsPointer) evaluated.car()).getCons());
        } else {
            Utility.flatCopy(aEnvironment, aStackTop, copied, (ConsPointer) evaluated.car());
        }

        ConsPointer index = new ConsPointer();
        index.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "INTERNAL");
        int ind = Integer.parseInt((String) index.car(), 10);
        LispError.checkArgument(aEnvironment, aStackTop, ind > 0, 2, "INTERNAL");

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, copied);
        while (ind > 0) {
            consTraverser.goNext(aStackTop);
            ind--;
        }

        ConsPointer toInsert = new ConsPointer();
        toInsert.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        toInsert.cdr().setCons(consTraverser.getCons());
        consTraverser.getPointer().setCons(toInsert.getCons());
        BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, copied.getCons()));
    }

    public static void replace(Environment aEnvironment, int aStackTop, boolean aDestructive) throws Exception {
        ConsPointer evaluated = new ConsPointer();
        evaluated.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons());
        // Ok, so lets not check if it is a list, but it needs to be at least a 'function'
        LispError.checkArgument(aEnvironment, aStackTop, evaluated.car() instanceof ConsPointer, 1, "INTERNAL");

        ConsPointer index = new ConsPointer();
        index.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, index.getCons() != null, 2, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, index.car() instanceof String, 2, "INTERNAL");
        int ind = Integer.parseInt((String) index.car(), 10);

        ConsPointer copied = new ConsPointer();
        if (aDestructive) {
            copied.setCons(((ConsPointer) evaluated.car()).getCons());
        } else {
            Utility.flatCopy(aEnvironment, aStackTop, copied, (ConsPointer) evaluated.car());
        }
        LispError.checkArgument(aEnvironment, aStackTop, ind > 0, 2, "INTERNAL");

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, copied);
        while (ind > 0) {
            consTraverser.goNext(aStackTop);
            ind--;
        }

        ConsPointer toInsert = new ConsPointer();
        toInsert.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        LispError.checkArgument(aEnvironment, aStackTop, consTraverser.getPointer() != null, 2, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, consTraverser.getPointer().getCons() != null, 2, "INTERNAL");
        toInsert.cdr().setCons(consTraverser.getPointer().cdr().getCons());
        consTraverser.getPointer().setCons(toInsert.getCons());
        BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop).setCons(SublistCons.getInstance(aEnvironment, copied.getCons()));
    }

    /**
     *Implements the MathPiper functions Rulebase and MacroRulebase .
     * The real work is done by Environment.defineRulebase().
     */
    public static void rulebase(Environment aEnvironment, int aStackTop, boolean aListed) throws Exception {

        // Get operator
        ConsPointer argsPointer = new ConsPointer();
        String functionName = null;

        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");
        functionName = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, functionName != null, 1, "INTERNAL");
        argsPointer.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());

        // Check the arguments.
        LispError.checkIsList(aEnvironment, aStackTop, argsPointer, 2, "INTERNAL");

        // Finally define the rule database.
        aEnvironment.defineRulebase(aStackTop, Utility.getSymbolName(aEnvironment, functionName), ((ConsPointer) argsPointer.car()).cdr(), aListed);

        // Return true
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }

    public static void newRule(Environment aEnvironment, int aStackTop, boolean aPattern) throws Exception {

        int arity;
        int precedence;

        ConsPointer arityPointer = new ConsPointer();
        ConsPointer precidencePointer = new ConsPointer();
        ConsPointer predicate = new ConsPointer();
        ConsPointer bodyPointer = new ConsPointer();
        String orig = null;

        // Get operator
        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");
        orig = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "INTERNAL");
        arityPointer.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        precidencePointer.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 3).getCons());
        predicate.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 4).getCons());
        bodyPointer.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 5).getCons());

        // The arity
        LispError.checkArgument(aEnvironment, aStackTop, arityPointer.getCons() != null, 2, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, arityPointer.car() instanceof String, 2, "INTERNAL");
        arity = Integer.parseInt((String) arityPointer.car(), 10);

        // The precedence
        LispError.checkArgument(aEnvironment, aStackTop, precidencePointer.getCons() != null, 3, "INTERNAL");
        LispError.checkArgument(aEnvironment, aStackTop, precidencePointer.car() instanceof String, 3, "INTERNAL");
        precedence = Integer.parseInt((String) precidencePointer.car(), 10);

        // Finally define the rule base
        if(aPattern == true)
        {
            aEnvironment.defineRulePattern(aStackTop, Utility.getSymbolName(aEnvironment, orig),
                arity,
                precedence,
                predicate,
                bodyPointer);
        }
        else
        {
            aEnvironment.defineRule(aStackTop, Utility.getSymbolName(aEnvironment, orig),
                arity,
                precedence,
                predicate,
                bodyPointer);
        }

        // Return true
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }

    public static void defMacroRulebase(Environment aEnvironment, int aStackTop, boolean aListed) throws Exception {
        // Get operator
        ConsPointer args = new ConsPointer();
        ConsPointer body = new ConsPointer();
        String orig = null;

        LispError.checkArgument(aEnvironment, aStackTop, BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).getCons() != null, 1, "INTERNAL");
        orig = (String) BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 1).car();
        LispError.checkArgument(aEnvironment, aStackTop, orig != null, 1, "INTERNAL");

        // The arguments
        args.setCons(BuiltinFunction.getArgumentPointer(aEnvironment, aStackTop, 2).getCons());
        LispError.checkIsList(aEnvironment, aStackTop, args, 2, "INTERNAL");

        // Finally define the rule base
        aEnvironment.defineMacroRulebase(aStackTop, Utility.getSymbolName(aEnvironment, orig),
                ((ConsPointer) args.car()).cdr(), aListed);

        // Return true
        Utility.putTrueInPointer(aEnvironment, BuiltinFunction.getTopOfStackPointer(aEnvironment, aStackTop));
    }



    public static String dumpRule(int aStackTop, Rule rule, Environment aEnvironment, SingleArityRulebase userFunction) {
        StringBuilder dumpResult = new StringBuilder();
        try {
            int precedence = rule.getPrecedence();

            ConsPointer predicatePointer1 = rule.getPredicatePointer();
            String predicate = "";
            String predicatePointerString = predicatePointer1.toString();

            if (predicatePointerString == null || predicatePointerString.equalsIgnoreCase("Empty.")) {
                predicate = "None.";
            } else {
                predicate = Utility.printMathPiperExpression(aStackTop, predicatePointer1, aEnvironment, 0);
            }

            if (rule instanceof PatternRule) {
                predicate = "(Pattern) ";
                PatternRule branchPattern = (PatternRule) rule;
                ParametersPatternMatcher pattern = branchPattern.getPattern();

                Iterator variablesIterator = pattern.getVariables().iterator();
                String patternVariables = "";
                while (variablesIterator.hasNext()) {
                    String patternVariable = (String) variablesIterator.next();
                    patternVariables += patternVariable + ", ";
                }
                if (patternVariables.contains(",")) {
                    patternVariables = patternVariables.substring(0, patternVariables.lastIndexOf(","));
                }


                Iterator parameterMatchersIterator = pattern.getParameterMatchers().iterator();
                String parameterTypes = "";
                while (parameterMatchersIterator.hasNext()) {
                    PatternParameterMatcher parameter = (PatternParameterMatcher) parameterMatchersIterator.next();
                    String parameterType = (String) parameter.getType();
                    parameterTypes += parameterType + ": " + parameter.toString();
                    parameterTypes += "; ";
                }
                if (parameterTypes.contains(",")) {
                    parameterTypes = parameterTypes.substring(0, parameterTypes.lastIndexOf(","));
                }



                Iterator patternPredicatesIterator = pattern.getPredicates().iterator();
                while (patternPredicatesIterator.hasNext()) {
                    ConsPointer predicatePointer = (ConsPointer) patternPredicatesIterator.next();
                    String patternPredicate = Utility.printMathPiperExpression(aStackTop, predicatePointer, aEnvironment, 0);
                    predicate += patternPredicate + ", ";
                }
                /*if (predicate.contains(",")) {
                predicate = predicate.substring(0, predicate.lastIndexOf(","));
                }*/
                predicate += "\n    Variables: " + patternVariables + ", ";
                predicate += "\n    Types: " + parameterTypes;

            }//end if.

            Iterator paremetersIterator = userFunction.getParameters();
            String parameters = "";
            boolean isHold = false;
            while (paremetersIterator.hasNext()) {
                ParameterName branchParameter = (ParameterName) paremetersIterator.next();
                String parameter = branchParameter.getName();
                isHold = branchParameter.isHold();
                parameters += parameter + ", ";
            }
            if (parameters.contains(",")) {
                parameters = parameters.substring(0, parameters.lastIndexOf(","));
            }

            String body = Utility.printMathPiperExpression(aStackTop, rule.getBodyPointer(), aEnvironment, 0);
            body = body.replace(",", ", ");
            //System.out.println(data);

            String substitutedMacroBody = "";

            if (userFunction instanceof MacroRulebase) {
                BackQuoteSubstitute backQuoteSubstitute = new BackQuoteSubstitute(aEnvironment);
                ConsPointer substitutedBodyPointer = new ConsPointer();
                Utility.substitute(aEnvironment, aStackTop, substitutedBodyPointer, rule.getBodyPointer(), backQuoteSubstitute);
                substitutedMacroBody = Utility.printMathPiperExpression(aStackTop, substitutedBodyPointer, aEnvironment, 0);
            }

            dumpResult.append("Precedence: " + precedence + ", ");
            dumpResult.append("\n" + "Rule Type: " + rule.getClass().getSimpleName() + ", ");
            dumpResult.append("\n" + "Arity: " + userFunction.arity() + ", ");
            dumpResult.append("\n" + "Parameters: " + parameters + ", ");
            dumpResult.append("\n" + "Predicates: " + predicate + ",    ");

            if (userFunction instanceof MacroRulebase) {
                dumpResult.append("\n" + "Body: \n" + body + ", ");
                dumpResult.append("\n" + "Substituted Macro Body: \n" + substitutedMacroBody + "\n");
            } else {
                dumpResult.append("\n" + "Body: \n" + body + "\n");
            }



        } catch (Exception ex) {
            ex.printStackTrace();
        }
        return dumpResult.toString();

    }//end method.

    public static Cons associativeListGet(Environment aEnvironment, int aStackTop, ConsPointer key, Cons listCons) throws Exception {


        while (listCons != null) {
            if (listCons.car() instanceof ConsPointer) {
                Cons sub = ((ConsPointer) listCons.car()).getCons();
                if (sub != null) {
                    sub = sub.cdr().getCons();
                    ConsPointer temp = new ConsPointer();
                    temp.setCons(sub);
                    if (Utility.equals(aEnvironment, aStackTop, key, temp)) {
                        return listCons;
                    }//end if.

                }//end if.

            }//end if.

            listCons = listCons.cdr().getCons();

        }//end if.

        return null;
    }//end method.

    /**
     * Returns the type of a.
     * @param aEnvironment
     * @param expressionPointer
     * @throws java.lang.Exception
     */
    public static String functionType(ConsPointer expressionPointer) throws Exception {
        if (!(expressionPointer.car() instanceof ConsPointer)) {
            return "";
        }

        ConsPointer subList = (ConsPointer) expressionPointer.car();
        Cons head = null;
        head = subList.getCons();
        if (!(head.car() instanceof String)) {
            return "";
        }//end if.

        return (String) head.car();

    }//end method.

    /**
     * Converts a =Java Iterable into a MathPiper List.
     *
     * @param aEnvironment
     * @param iterable
     * @return cons
     * @throws java.lang.Exception
     */
    public static Cons iterableToList(Environment aEnvironment, int aStackTop, java.lang.Iterable iterable) throws Exception {
        
        Cons head = aEnvironment.iListAtom.copy(aEnvironment, false);

        ConsPointer consPointer = new ConsPointer();

        consPointer.setCons(head);

        Iterator iterator = iterable.iterator();

        while (iterator.hasNext()) {
            Object object = iterator.next();

            if(object instanceof String)
            {
                String key = (String) object;

                Cons stringCons = AtomCons.getInstance(aEnvironment, aStackTop, key);

                consPointer.getCons().cdr().setCons(stringCons);
            }
            else
            {
                consPointer.getCons().cdr().setCons(BuiltinObjectCons.getInstance(aEnvironment, aStackTop, new JavaObject(object)));
            }

            consPointer.goNext(aStackTop, aEnvironment);

        }//end while.

        return head;

    }//end method.


    public static ConsPointer mathPiperParse(Environment aEnvironment, int aStackTop, String inputExpression) throws Exception {
        MathPiperTokenizer tokenizer = new MathPiperTokenizer();
        InputStatus someStatus = new InputStatus();
        ConsPointer inputExpressionPointer = new ConsPointer();

        StringBuffer inp = new StringBuffer();
        inp.append(inputExpression);
        inp.append(";");
        StringInputStream inputExpressionBuffer = new StringInputStream(inp, someStatus);

        Parser infixParser = new MathPiperParser(tokenizer, inputExpressionBuffer, aEnvironment, aEnvironment.iPrefixOperators, aEnvironment.iInfixOperators, aEnvironment.iPostfixOperators, aEnvironment.iBodiedOperators);
        infixParser.parse(aStackTop, inputExpressionPointer);

        return inputExpressionPointer;
    }//end method.




    public static ConsPointer lispEvaluate(Environment aEnvironment, int aStackTop, String inputExpression) throws Exception {
        ConsPointer result = new ConsPointer();

        ConsPointer inputExpressionPointer = mathPiperParse(aEnvironment, aStackTop, inputExpression);

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result, inputExpressionPointer);

        return result;
    }//end method.




    public static ConsPointer lispEvaluate(Environment aEnvironment, int aStackTop, ConsPointer inputExpressionPointer) throws Exception {
        ConsPointer result = new ConsPointer();
        MathPiperTokenizer tokenizer = new MathPiperTokenizer();
        InputStatus someStatus = new InputStatus();

        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, result, inputExpressionPointer);

        return result;
    }//end method.



    public static void declareFunction(String functionName, String[] parameters, String body, Environment aEnvironment, int aStackTop) throws Exception
    {

        ConsTraverser parameterTraverser = new ConsTraverser(aEnvironment, new ConsPointer());

        for(String parameterName:parameters)
        {
           Cons atomCons = AtomCons.getInstance(aEnvironment, aStackTop, parameterName);

           parameterTraverser.setCons(atomCons);
           
           parameterTraverser.goNext(aStackTop);
        }//end for.

        aEnvironment.defineRulebase(aStackTop, functionName, parameterTraverser.getHeadPointer(), false);

        ConsPointer truePointer = new ConsPointer();

        Utility.putTrueInPointer(aEnvironment, truePointer);

        ConsPointer expressionPointer = Utility.mathPiperParse(aEnvironment, aStackTop, body);

        aEnvironment.defineRule(aStackTop, functionName, parameters.length, 100, truePointer, expressionPointer);
    }

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/0000755000175000017500000000000011722677325023436 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/Cons.java0000644000175000017500000000606611333354275025205 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import java.util.Map;
import org.mathpiper.lisp.Environment;


/**
 * Class Cons is the base object class that can be put in
 *  linked lists. It either has a pointer to a string
 * or it is a holder for a sublist, ,
 *  or it is a Java object.  All of these values are obtainable
 * using car();
 *  It is a reference-counted object. ConsPointer handles the reference counting. ap.
 */
public abstract class Cons //Note:tk:was MathPiperObject.
{

    protected Map metadataMap;


    public Cons() throws Exception
    {
        metadataMap = null; //aEnvironment.iEmptyAtom;
    }//end constructor.


    public abstract ConsPointer cdr();

    public abstract Object car() throws Exception;

    public abstract int type();



    /**
     * If this is a number, return a BigNumber representation of it.
     */
    public Object getNumber(int aPrecision, Environment aEnvironment) throws Exception {
        return null;
    }

    public abstract Cons copy( Environment aEnvironment, boolean aRecursed) throws Exception;





    /**
     *  Return a pointer to extra info. This allows for annotating
     *  an object. Returns NULL by default.
     */
    public Map getMetadataMap()
    {
        return metadataMap;
    }//end method.



    public void setMetadataMap(Map metaDataMap)
    {
        this.metadataMap = metaDataMap;
    }//end method.



    public boolean isEqual(Cons aOther) throws Exception {
        // iCdr line handles the fact that either one is a string
        if (car() != aOther.car()) {
            return false;
        }

        //So, no strings.
        ConsPointer iter1 = (ConsPointer) car();
        ConsPointer iter2 = (ConsPointer) aOther.car();
        if (!(iter1 != null && iter2 != null)) {
            return false;
        }

        // check all elements in sublist
        while (iter1.getCons() != null && iter2.getCons() != null) {
            if (!iter1.getCons().isEqual(iter2.getCons())) {
                return false;
            }

            iter1 = iter1.cdr();
            iter2 = iter2.cdr();
        }
        //One list longer than the other?
        if (iter1.getCons() == null && iter2.getCons() == null) {
            return true;
        }
        return false;
    }//end method.



    
}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/AtomCons.java0000644000175000017500000000477211506545417026032 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import org.mathpiper.lisp.*;

public class AtomCons extends Cons
{

    private String iCar;

    ConsPointer iCdr;

    public AtomCons(String aString) throws Exception
    {
        //Make sure to use aEnvironment.getTokenHash().lookUp(aString) with aString before calling this constructor.
        
        super();
        iCar = aString;
        iCdr = new ConsPointer();
    }

    public static Cons getInstance(Environment aEnvironment, int aStackTop, String aString) throws Exception
    {
        Cons self = null;
        if (Utility.isNumber(aString, true))  // check if aString is a number (int or float)
        {
            /// construct a number from a decimal string representation (also create a number object)
            self = new NumberCons(aString, aEnvironment.getPrecision());
        } else
        {
            self = new AtomCons((String)aEnvironment.getTokenHash().lookUp(aString));
        }
        
        LispError.check(aEnvironment, aStackTop, self != null, LispError.NOT_ENOUGH_MEMORY, "INTERNAL");
        
        return self;
    }
    
    public Object car()
    {
        return iCar;
    }

    
        /*public String toString()
        {
            return car();
        }*/

    public Cons copy( Environment aEnvironment, boolean aRecursed) throws Exception
    {
        Cons atomCons = new AtomCons(iCar);

        atomCons.setMetadataMap(this.getMetadataMap());
        
        return atomCons;
    }



    public ConsPointer cdr() {
        return iCdr;
    }

    @Override
    public String toString()
    {
        return iCar;
    }//end method.

    public int type()
    {
        return Utility.ATOM;
    }//end method.
   

}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/ConsPointerArray.java0000644000175000017500000000412311506531763027536 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import org.mathpiper.lisp.Environment;

/** 
 * Similar to ConsPointer, but implements an array of pointers to CONS.
 *  
 */
public class ConsPointerArray {

    int iSize;
    ConsPointer iArray[];


    public ConsPointerArray(Environment aEnvironment, int aSize, Cons aInitialItem) {
        iArray = new ConsPointer[aSize];
        iSize = aSize;
        int i;
        for (i = 0; i < aSize; i++) {
            iArray[i] = new ConsPointer();
            iArray[i].setCons(aInitialItem);
        }
    }


    public int size() {
        return iSize;
    }


    public ConsPointer getElement(int aItem) {
        return iArray[aItem];
    }


    public ConsPointer[] getElements(int first, int last) throws IndexOutOfBoundsException {
        if (first < last && first > 0 && last > 0 && first < iSize - 1 && last < iSize - 1) {
            ConsPointer[] arguments = new ConsPointer[last - first];
            int i = 0;
            for (int x = first; x < last; x++) {
                arguments[i++] = iArray[x];
            }
            return arguments;
        } else {
            throw new IndexOutOfBoundsException("Stack index is out of bounds.");
        }
    }


    public void setElement(int aItem, Cons aCons) {
        iArray[aItem].setCons(aCons);
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/NumberCons.java0000644000175000017500000001324111506531763026350 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import org.mathpiper.lisp.*;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.exceptions.EvaluationException;


/**
 * Holds a single number.
 *  
 */
public class NumberCons extends Cons {
    /* Note: Since NumberCons is a LispAtom, shouldn't it extend LispAtom instead of Cons? tk
     */

    /// number object; NULL if not yet converted from string
    private BigNumber iCarBigNumber;
    /// string representation in decimal; NULL if not yet converted from BigNumber
    private String iCarStringNumber;
    private ConsPointer iCdr;

    /**
     * Construct a number from either a BigNumber or a String.
     *
     * @param aNumber
     * @param aString
     */
    public NumberCons(BigNumber aNumber, String aString) throws Exception {
        super();
        iCarStringNumber = aString;
        iCarBigNumber = aNumber;
        iCdr = new ConsPointer();
    }

    /**
     * Construct a number from a BigNumber.
     * @param aNumber
     */
    public NumberCons(BigNumber aNumber) throws Exception {
        super();
        iCarStringNumber = null;
        iCarBigNumber = aNumber;
        iCdr = new ConsPointer();
    }

    /**
     * Construct a number from a decimal string representation and the specified number of decimal digits.
     *
     * @param aString a number in decimal format
     * @param aBasePrecision the number of decimal digits for the number
     */
    public NumberCons(String aString, int aBasePrecision) throws Exception {
        super();
        //(also create a number object).
        iCarStringNumber = aString;
        iCarBigNumber = null;  // purge whatever it was.
        iCdr = new ConsPointer();

    // create a new BigNumber object out of iString, set its precision in digits
    //TODO FIXME enable this in the end    NumberCons(aBasePrecision);
    }

    public Cons copy( Environment aEnvironment, boolean aRecursed) throws Exception  {

        NumberCons numberCons = new NumberCons(iCarBigNumber, iCarStringNumber);

        numberCons.setMetadataMap(this.getMetadataMap());
        
        return numberCons;
    }

    /*public Object car() {
        return iCarBigNumber;
    }*/





    /**
     * Return a string representation of the number in decimal format with the maximum decimal precision allowed by the inherent accuracy of the number.
     *
     * @return string representation of the number
     * @throws java.lang.Exception
     */
    public Object car() throws Exception {
        if (iCarStringNumber == null) {
            //LispError.lispAssert(iCarBigNumber != null, aEnvironment, aStackTop);  // either the string is null or the number but not both.

            if(iCarBigNumber == null) throw new EvaluationException("Internal error in NumberCons.","",-1);

            iCarStringNumber = iCarBigNumber.numToString(0/*TODO FIXME*/, 10);
        // export the current number to string and store it as NumberCons::iString
        }
        return iCarStringNumber;
    }

    @Override
    public String toString() {
        String stringRepresentation = null;
        try {
            stringRepresentation = (String) car();

        } catch (Exception e) {
            e.printStackTrace();  //Todo:fixme.
        }
        return stringRepresentation;

    }

    
    /**
     * Returns a BigNumber which has at least the specified precision.
     *
     * @param aPrecision
     * @return
     * @throws java.lang.Exception
     */
    @Override
    public Object getNumber(int aPrecision, Environment aEnvironment) throws Exception {
        /// If necessary, will create a BigNumber object out of the stored string, at given precision (in decimal?)
        if (iCarBigNumber == null) {  // create and store a BigNumber out of the string representation.
            
            //LispError.lispAssert(iCarStringNumber != null, aEnvironment, aStackTop);

            if(iCarStringNumber == null) throw new EvaluationException("Internal error in NumberCons.","",-1);

            String str;
            str = iCarStringNumber;
            // aBasePrecision is in digits, not in bits, ok
            iCarBigNumber = new BigNumber(str, aPrecision, 10/*TODO FIXME BASE10*/);
        } // check if the BigNumber object has enough precision, if not, extend it
        // (applies only to floats). Note that iNumber->GetPrecision() might be < 0
        else if (!iCarBigNumber.isInteger() && iCarBigNumber.getPrecision() < aPrecision) {
            if (iCarStringNumber != null) {// have string representation, can extend precision
                iCarBigNumber.setTo(iCarStringNumber, aPrecision, 10);
            } else {
                // do not have string representation, cannot extend precision!
            }
        }

        return iCarBigNumber;
    }


    

    public ConsPointer cdr() {
        return iCdr;
    }//end method.


    public int type()
    {
        return Utility.NUMBER;
    }//end method.

}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/BuiltinObjectCons.java0000644000175000017500000000430111506531763027652 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;


import org.mathpiper.lisp.*;
import org.mathpiper.builtin.BuiltinContainer;


public class BuiltinObjectCons extends Cons {

    BuiltinContainer iCarBuiltin;
    ConsPointer iCdr;


    private BuiltinObjectCons(Environment aEnvironment, BuiltinContainer aClass) throws Exception  {
        super();
        iCarBuiltin = aClass;
        iCdr = new ConsPointer();
    }

    public static BuiltinObjectCons getInstance(Environment aEnvironment, int aStackTop, BuiltinContainer aClass) throws Exception {
        LispError.lispAssert(aClass != null, aEnvironment, aStackTop);
        BuiltinObjectCons self = new BuiltinObjectCons(aEnvironment, aClass);
        LispError.check(aEnvironment, aStackTop, self != null, LispError.NOT_ENOUGH_MEMORY, "INTERNAL");
        return self;
    }


    public Object car() {
        return iCarBuiltin;
    }


    public Cons copy(Environment aEnvironment, boolean aRecursed) throws Exception  {

        Cons copied = new BuiltinObjectCons(aEnvironment, iCarBuiltin);

        copied.setMetadataMap(this.getMetadataMap());

        return copied;
        
    }



    public ConsPointer cdr() {
        return iCdr;
    }


    public int type() {
        return Utility.OBJECT;
    }//end method.


    @Override
    public String toString()
    {
        return "JavaObject: " + this.iCarBuiltin.getObject().toString();
    }//end method.
    
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/ConsTraverser.java0000644000175000017500000000461211506531763027077 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import org.mathpiper.lisp.*;

/**
 * Works almost like ConsPointer, but doesn't enforce
 * reference counting, so it should be slightly faster. This one
 * should be used instead of ConsPointer if you are going to traverse
 * a lisp expression in a non-destructive way.
 */
public class ConsTraverser {

    ConsPointer iPointer;
    ConsPointer iHeadPointer;

    private Environment iEnvironment;

    public ConsTraverser(Environment aEnvironment, ConsPointer aPtr) {
        iEnvironment = aEnvironment;
        iPointer = aPtr;
        iHeadPointer = aPtr;
    }

    public Object car() throws Exception {
        return iPointer.car();
    }

    public ConsPointer cdr() {
        return iPointer.cdr();
    }

    public Cons getCons() {
        return iPointer.getCons();
    }

    public void setCons(Cons aCons) {
        iPointer.setCons(aCons);
    }

    public ConsPointer getPointer() {
        return iPointer;
    }

    public ConsPointer getHeadPointer()
    {
        return iHeadPointer;
    }

    public void goNext(int aStackTop) throws Exception {
        LispError.check(iEnvironment, aStackTop, iPointer.getCons() != null, LispError.NOT_LONG_ENOUGH, "INTERNAL");
        iPointer = (iPointer.cdr());
    }

    public void goSub(int aStackTop) throws Exception {
        LispError.check(iEnvironment, aStackTop, iPointer.getCons() != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(iEnvironment, aStackTop, iPointer.car() instanceof ConsPointer, LispError.NOT_A_LIST, "INTERNAL");
        iPointer = (ConsPointer) iPointer.car();
    }
};

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/ConsPointer.java0000644000175000017500000000612711506531763026545 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;

import org.mathpiper.io.StringOutput;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.printers.LispPrinter;

/** 
 * Provides a smart pointer type to CONS
 *  that can be inserted into linked lists. They do the actual
 *  reference counting, and consequent destruction of the object if
 *  nothing points to it. ConsPointer is used in Cons as a pointer
 *  to the next object, and in diverse parts of the built-in internal
 *  functions to hold temporary values.
 */
public class ConsPointer {

    Cons iCons;


    public Object car() throws Exception {
        return iCons.car();
    }

    public ConsPointer cdr() {
        return iCons.cdr();
    }

    public ConsPointer()
    {
        super();
    }


    public ConsPointer( Cons aCons) {
        super();
        iCons = aCons;
    }

    //public ConsPointer(ConsPointer aConsPointer) {
    //    iCons = aConsPointer.getCons();
    //    }//todo:tk:I am removing this until a mechanism is developed to traverse
    //    conses which does not destroy the original ConsPointer's pointer. See Utility.flatCopy.

    public void setCons(Cons aNext) {
        iCons = aNext;
    }

    public Cons getCons() {
        return iCons;
    }


    //iPointer = (iPointer.cdr());
    public void goNext(int aStackTop , Environment aEnvironment) throws Exception {
        LispError.check(aEnvironment, aStackTop, iCons != null, LispError.NOT_LONG_ENOUGH, "INTERNAL");
        iCons = iCons.cdr().iCons;
    }

    public void goSub(int aStackTop , Environment aEnvironment) throws Exception {
        LispError.check(aEnvironment, aStackTop, iCons != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, iCons.car() instanceof ConsPointer, LispError.NOT_A_LIST, "INTERNAL");
        iCons = ((ConsPointer)iCons.car()).getCons();
    }

    @Override
    public String toString() {
        StringOutput out = new StringOutput();
        LispPrinter printer = new LispPrinter();
        try {
            printer.print(-1, this, out, null);
        } catch (Exception e) {
            e.printStackTrace();
        }
        return out.toString();
    }//end method.

    public int type()
    {
        return iCons.type();
    }//end method.

}//end class.
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/cons/SublistCons.java0000644000175000017500000000507011506531763026546 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.cons;


import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.io.StringOutput;
import org.mathpiper.lisp.*;
import org.mathpiper.lisp.printers.LispPrinter;


public class SublistCons extends Cons {

    ConsPointer iCar;
    ConsPointer iCdr;


    private SublistCons(Environment aEnvironment, Cons aSubList) throws Exception {
        super();
        iCar = new ConsPointer();
        iCar.setCons(aSubList);
        iCdr = new ConsPointer();
    }

    public static SublistCons getInstance(Environment aEnvironment, Cons aSubList) throws Exception {
        return new SublistCons(aEnvironment, aSubList);
    }


    public Object car() {
        return iCar;
    }


    /*
    public String toString()
    {
    return iCar.toString();
    }*/
    public Cons copy(Environment aEnvironment, boolean aRecursed) throws Exception {
        //TODO recursed copy needs to be implemented still
        //LispError.lispAssert(aRecursed == false, aEnvironment, aStackTop);

        if(aRecursed != false) throw new EvaluationException("Internal error in SublistCons.","",-1);

        Cons copied = new SublistCons(aEnvironment, iCar.getCons());

        copied.setMetadataMap(this.getMetadataMap());
        
        return copied;
    }



    public ConsPointer cdr() {
        return iCdr;
    }//end method.


    @Override
    public String toString() {
        StringOutput out = new StringOutput();
        LispPrinter printer = new LispPrinter();
        try {
            printer.print(-1, new ConsPointer(this), out, null);
        } catch (Exception e) {
            e.printStackTrace();
        }
        return out.toString();
    }//end method.


    public int type() {
        return Utility.SUBLIST;
    }//end method.


}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/behaviours/0000755000175000017500000000000011722677326024644 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/behaviours/Substitute.java0000644000175000017500000000220111332771351027643 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.lisp.behaviours;

import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.ConsPointer;


/** Behaviour for substituting sub-expressions.
 */
public interface Substitute
{
	public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aElement) throws Exception;
};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/behaviours/BackQuoteSubstitute.java0000644000175000017500000000636411506531763031464 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.behaviours;

import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.SublistCons;

/** Substitute behaviour for backquote mechanism as in LISP.
 * When typing `(...) all occurrences of @a will be
 * replaced with:
 * 1) a evaluated if a is an atom
 * 2) function call with function name replaced by evaluated
 *    head of function if a is a function. For instance, if
 *    a is f(x) and f is g, then f(x) gets replaced by g(x)
 */
public class BackQuoteSubstitute implements Substitute {

    Environment iEnvironment;


    public BackQuoteSubstitute(Environment aEnvironment) {
        iEnvironment = aEnvironment;
    }


    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aElement) throws Exception {
        if (!(aElement.car() instanceof ConsPointer)) {
            return false;
        }

        Cons ptr = ((ConsPointer) aElement.car()).getCons();
        if (ptr == null) {
            return false;
        }

        if (!(ptr.car() instanceof String)) {
            return false;
        }

        if (ptr.car().equals("`")) {
            aResult.setCons(aElement.getCons());
            return true;
        }

        if (!ptr.car().equals("@")) {
            return false;
        }

        ptr = ptr.cdr().getCons();

        if (ptr == null) {
            return false;
        }

        if (ptr.car() instanceof String) {
            ConsPointer cur = new ConsPointer();
            cur.setCons(ptr);
            iEnvironment.iLispExpressionEvaluator.evaluate(iEnvironment, aStackTop, aResult, cur);
            return true;
        } else {
            ptr = ((ConsPointer) ptr.car()).getCons();
            ConsPointer cur = new ConsPointer();
            cur.setCons(ptr);
            ConsPointer args = new ConsPointer();
            args.setCons(ptr.cdr().getCons());
            ConsPointer result = new ConsPointer();
            iEnvironment.iLispExpressionEvaluator.evaluate(iEnvironment, aStackTop, result, cur);
            result.cdr().setCons(args.getCons());
            ConsPointer result2 = new ConsPointer();
            result2.setCons(SublistCons.getInstance(aEnvironment, result.getCons()));
            Utility.substitute(aEnvironment, aStackTop, aResult, result2, this);
            return true;
        }
        //      return false;
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/behaviours/LocalSymbolSubstitute.java0000644000175000017500000000406311506531763032020 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.behaviours;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.Environment;

/** Substitute behaviour for changing the local variables to have unique
 * names.
 */
public class LocalSymbolSubstitute implements Substitute {

    Environment iEnvironment;
    String[] iOriginalNames;
    String[] iNewNames;
    int iNumberOfNames;


    public LocalSymbolSubstitute(Environment aEnvironment,
            String[] aOriginalNames,
            String[] aNewNames, int aNrNames) {
        iEnvironment = aEnvironment;
        iOriginalNames = aOriginalNames;
        iNewNames = aNewNames;
        iNumberOfNames = aNrNames;
    }


    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aElement) throws Exception {

        if (!(aElement.car() instanceof String)) {
            return false;
        }//end if.

        String name = (String) aElement.car();

        int i;
        for (i = 0; i < iNumberOfNames; i++) {
            if (name.equals(iOriginalNames[i])) {
                aResult.setCons(AtomCons.getInstance(iEnvironment, aStackTop, iNewNames[i]));
                return true;
            }
        }
        return false;
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/behaviours/ExpressionSubstitute.java0000644000175000017500000000173711506531763031744 0ustar  giovannigiovannipackage org.mathpiper.lisp.behaviours;

import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

/** Substing one expression for another. The simplest form
 * of substitution
 */
public class ExpressionSubstitute
        implements Substitute {

    Environment iEnvironment;
    ConsPointer iToMatch;
    ConsPointer iToReplaceWith;


    public ExpressionSubstitute(Environment aEnvironment, ConsPointer aToMatch, ConsPointer aToReplaceWith) {
        iEnvironment = aEnvironment;
        iToMatch = aToMatch;
        iToReplaceWith = aToReplaceWith;
    }


    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aElement)
            throws Exception {

        if (Utility.equals(iEnvironment, aStackTop, aElement, iToMatch)) {
            aResult.setCons(iToReplaceWith.getCons().copy(aEnvironment, false));

            return true;
        }

        return false;
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/GlobalVariable.java0000644000175000017500000000422011506531763026176 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

import org.mathpiper.lisp.cons.ConsPointer;

/**
 * Value of a Lisp global variable.
 * The only special feature of this class is the attribute
 * iEvalBeforeReturn, which defaults to LispFalse. If this
 * attribute is set to LispTrue, the value in iValue needs to be
 * evaluated to get the value of the Lisp variable.
 * See: LispEnvironment::GetVariable()
 */
public class GlobalVariable {

    ConsPointer iValue;
    boolean iEvalBeforeReturn;
    private Environment iEnvironment;


    public GlobalVariable(Environment aEnvironment, GlobalVariable aOther) {
        iEnvironment = aEnvironment;
        iValue = new ConsPointer();
        iValue = aOther.iValue;
        iEvalBeforeReturn = aOther.iEvalBeforeReturn;
    }


    public GlobalVariable(Environment aEnvironment, ConsPointer aValue) {
        iEnvironment = aEnvironment;
        iValue = new ConsPointer();
        iValue.setCons(aValue.getCons());
        iEvalBeforeReturn = false;
    }


    public void setEvalBeforeReturn(boolean aEval) {
        iEvalBeforeReturn = aEval;
    }


    @Override
    public String toString() {
        return (String) iValue.getCons().toString();
    }


    public boolean isIEvalBeforeReturn() {
        return iEvalBeforeReturn;
    }


    public ConsPointer getValue() {
        return iValue;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/stacks/0000755000175000017500000000000011722677325023764 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/stacks/UserStackInformation.java0000644000175000017500000000222611506531763030736 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.stacks;

import org.mathpiper.lisp.cons.ConsPointer;

public class UserStackInformation {

    public ConsPointer iExpression;
    public ConsPointer iOperator;
    public int iRulePrecedence;
    public int iSide; // 0=pattern, 1=body


    public UserStackInformation() {
        iRulePrecedence = -1;
        iSide = 0;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/stacks/ArgumentStack.java0000644000175000017500000001235711506531763027402 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.stacks;

import org.mathpiper.lisp.*;
import org.mathpiper.lisp.cons.ConsPointerArray;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.Cons;

/** 
 * Implements a stack of pointers to CONS that can be used to pass
 * arguments to functions, and receive results back.
 */
public class ArgumentStack {

    ConsPointerArray iArgumentStack;
    int iStackTopIndex;

    //TODO appropriate constructor?
    public ArgumentStack(Environment aEnvironment, int aStackSize) {
        iArgumentStack = new ConsPointerArray(aEnvironment, aStackSize, null);
        iStackTopIndex = 0;
        //printf("STACKSIZE %d\n",aStackSize);
    }

    public int getStackTopIndex() {
        return iStackTopIndex;
    }

    public void raiseStackOverflowError(int aStackTop, Environment aEnvironment) throws Exception {
        LispError.raiseError("Argument stack reached maximum. Please extend argument stack with --stack argument on the command line.", "[INTERNAL]", aStackTop, aEnvironment);
    }

    public void pushArgumentOnStack(Cons aCons, int aStackTop, Environment aEnvironment) throws Exception {
        if (iStackTopIndex >= iArgumentStack.size()) {
            raiseStackOverflowError(aStackTop, aEnvironment);
        }
        iArgumentStack.setElement(iStackTopIndex, aCons);
        iStackTopIndex++;
    }

    public void pushNulls(int aNr, int aStackTop, Environment aEnvironment) throws Exception {
        if (iStackTopIndex + aNr > iArgumentStack.size()) {
            raiseStackOverflowError(aStackTop, aEnvironment);
        }
        iStackTopIndex += aNr;
    }

    public ConsPointer getElement(int aPos, int aStackTop, Environment aEnvironment) throws Exception {
        LispError.lispAssert(aPos >= 0 && aPos < iStackTopIndex, aEnvironment, aStackTop);
        return iArgumentStack.getElement(aPos);
    }

    public void popTo(int aTop, int aStackTop, Environment aEnvironment) throws Exception {
        LispError.lispAssert(aTop <= iStackTopIndex, aEnvironment, aStackTop);
        while (iStackTopIndex > aTop) {
            iStackTopIndex--;
            iArgumentStack.setElement(iStackTopIndex, null);
        }
    }

    public void reset(int aStackTop, Environment aEnvironment) throws Exception {
        this.popTo(0, aStackTop, aEnvironment);
    }//end method.

    public String dump(int aStackTop, Environment aEnvironment) throws Exception {

        StringBuilder stringBuilder = new StringBuilder();

        int functionBaseIndex = 0;

        int functionPositionIndex = 0;


        while (functionBaseIndex <= aStackTop) {

            if(functionBaseIndex == 0)
            {
                stringBuilder.append("\n\n========================================= Start Of Built In Function Stack Trace\n");
            }
            else
            {
                stringBuilder.append("-----------------------------------------\n");
            }

            ConsPointer consPointer = getElement(functionBaseIndex, aStackTop, aEnvironment);

            int argumentCount = Utility.listLength(aEnvironment, aStackTop, consPointer);

            ConsPointer argumentPointer = new ConsPointer();

            Object car = consPointer.getCons().car();

            ConsPointer consTraverser = new ConsPointer( consPointer.getCons());

            stringBuilder.append(functionPositionIndex++ + ": ");
            stringBuilder.append(Utility.printMathPiperExpression(aStackTop, consTraverser, aEnvironment, -1));
            stringBuilder.append("\n");

            consTraverser.goNext(aStackTop, aEnvironment);

            while(consTraverser.getCons() != null)
            {
                stringBuilder.append("   " + functionPositionIndex++ + ": ");
                stringBuilder.append("-> " + Utility.printMathPiperExpression(aStackTop, consTraverser, aEnvironment, -1));
                stringBuilder.append("\n");
                
                consTraverser.goNext(aStackTop, aEnvironment);
            }


            functionBaseIndex = functionBaseIndex + argumentCount;

        }//end while.

        stringBuilder.append("========================================= End Of Built In Function Stack Trace\n\n");

        return stringBuilder.toString();
        
    }//end method.

    public ConsPointer[] getElements(int quantity) throws IndexOutOfBoundsException {
        int last = iStackTopIndex;
        int first = last - quantity;
        return iArgumentStack.getElements(first, last);
    }//end method.
}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/DefFile.java0000644000175000017500000000260511506531763024633 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

/** DefFile represents one file that can be loaded just-in-time.
 */
public class DefFile {

    public String iFileName;
    public boolean iIsLoaded;


    public DefFile(String aFile) {
        iFileName = aFile;
        iIsLoaded = false;
    }


    public DefFile(DefFile aOther) {
        iFileName = aOther.iFileName;
        iIsLoaded = aOther.iIsLoaded;
    }


    public void setLoaded() {
        iIsLoaded = true;
    }


    public boolean isLoaded() {
        return iIsLoaded;
    }


    public String fileName() {
        return iFileName;
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/0000755000175000017500000000000011722677325024461 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/ListedRulebase.java0000644000175000017500000000522711520672140030223 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.SublistCons;

public class ListedRulebase extends SingleArityRulebase {

    public ListedRulebase(Environment aEnvironment, int aStackTop, ConsPointer aParameters, String functionName) throws Exception {
        super(aEnvironment, aStackTop, aParameters, functionName);
    }


    @Override
    public boolean isArity(int aArity) {
        return (arity() <= aArity);
    }


    @Override
    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArguments) throws Exception {
        ConsPointer newArgs = new ConsPointer();
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, aArguments);
        ConsPointer ptr = newArgs;
        int arity = arity();
        int i = 0;
        while (i < arity && consTraverser.getCons() != null) {
            ptr.setCons(consTraverser.getCons().copy(aEnvironment, false));
            ptr = (ptr.cdr());
            i++;
            consTraverser.goNext(aStackTop);
        }
        if (consTraverser.cdr().getCons() == null) {
            ptr.setCons(consTraverser.getCons().copy(aEnvironment, false));
            ptr = (ptr.cdr());
            i++;
            consTraverser.goNext(aStackTop);
            LispError.lispAssert(consTraverser.getCons() == null, aEnvironment, aStackTop);
        } else {
            ConsPointer head = new ConsPointer();
            head.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
            head.cdr().setCons(consTraverser.getCons());
            ptr.setCons(SublistCons.getInstance(aEnvironment, head.getCons()));
        }
        super.evaluate(aEnvironment, aStackTop, aResult, newArgs);
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/TrueRule.java0000644000175000017500000000257511506531763027077 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

/**
 * A rule that always matches.
 */
class TrueRule extends PredicateRule
{

    public TrueRule(Environment aEnvironment, int aPrecedence, ConsPointer aBody)
    {
        super(aEnvironment);
        iPrecedence = aPrecedence;
        iBody.setCons(aBody.getCons());
    }
    /// Return true, always.
    @Override
    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception
    {
        return true;
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/SingleArityRulebase.java0000644000175000017500000004653611522214131031233 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.stacks.UserStackInformation;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.SublistCons;
import java.util.*;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.exceptions.ReturnException;
import org.mathpiper.lisp.Evaluator;

/**
 * A function (usually mathematical) which is defined by one or more rules.
 * This is the basic class which implements functions.  Evaluation is done
 * by consulting a set of rewritng rules.  The body of the first rule that
 * matches is evaluated and its result is returned as the function's result.
 */
public class SingleArityRulebase extends Evaluator {
    // List of arguments, with corresponding iHold property.
    protected List iParameters = new ArrayList(); //CArrayGrower

    // List of rules, sorted on precedence.
    protected List iBranchRules = new ArrayList();//CDeletingArrayGrower
    
    // List of arguments
    ConsPointer iParameterList;
/// Abstract class providing the basic user function API.
/// Instances of this class are associated to the name of the function
/// via an associated hash table. When obtained, they can be used to
/// evaluate the function with some arguments.
    boolean iFenced = true;
    boolean showFlag = false;
    protected String functionType = "**** user rulebase";
    protected String functionName;
    protected Environment iEnvironment;


    /**
     * Constructor.
     *
     * @param aParameters linked list constaining the names of the arguments
     * @throws java.lang.Exception
     */
    public SingleArityRulebase(Environment aEnvironment, int aStackTop, ConsPointer aParametersPointer, String functionName) throws Exception {
        iEnvironment = aEnvironment;
        this.functionName = functionName;
        iParameterList = new ConsPointer();
        // iParameterList and #iParameters are set from \a aParameters.
        iParameterList.setCons(aParametersPointer.getCons());

        ConsPointer parameterPointer = new ConsPointer(aParametersPointer.getCons());

        while (parameterPointer.getCons() != null) {

            try {
                LispError.check(aEnvironment, aStackTop, parameterPointer.car() instanceof String, LispError.CREATING_USER_FUNCTION, "INTERNAL");
            } catch (EvaluationException ex) {
                if (ex.getFunctionName() == null) {
                    throw new EvaluationException(ex.getMessage() + " In function: " + this.functionName + ",  ", "none", -1, this.functionName);
                } else {
                    throw ex;
                }
            }//end catch.

            ParameterName parameter = new ParameterName((String) parameterPointer.car(), false);
            iParameters.add(parameter);
            parameterPointer.goNext(aStackTop, aEnvironment);
        }
    }


    /**
     * Evaluate the function with the given arguments.
     * First, all arguments are evaluated by the evaluator associated
     * with aEnvironment, unless the iHold flag of the
     * corresponding parameter is true. Then a new LocalFrame is
     * constructed, in which the actual arguments are assigned to the
     * names of the formal arguments, as stored in iName. Then
     * all rules in iRules are tried one by one. The body of the
     * first rule that matches is evaluated, and the result is put in
     * aResult. If no rule matches, aResult will recieve a new
     * expression with evaluated arguments.
     * 
     * @param aResult (on output) the result of the evaluation
     * @param aEnvironment the underlying Lisp environment
     * @param aArguments the arguments to the function
     * @throws java.lang.Exception
     */
    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArgumentsPointer) throws Exception {
        int arity = arity();
        ConsPointer[] argumentsResultPointerArray = evaluateArguments(aEnvironment, aStackTop, aArgumentsPointer);

        // Create a new local variables frame that has the same fenced state as this function.
        aEnvironment.pushLocalFrame(fenced(), this.functionName);

        int beforeStackTop = -1;
        int beforeEvaluationDepth = -1;
        int originalStackTop = -1;

        try {

            // define the local variables.
            for (int parameterIndex = 0; parameterIndex < arity; parameterIndex++) {
                String variableName = ((ParameterName) iParameters.get(parameterIndex)).iName;
                // set the variable to the new value
                aEnvironment.newLocalVariable(variableName, argumentsResultPointerArray[parameterIndex].getCons(), aStackTop);
            }

            // walk the rules database, returning the evaluated result if the
            // predicate is true.
            int numberOfRules = iBranchRules.size();

            UserStackInformation userStackInformation = aEnvironment.iLispExpressionEvaluator.stackInformation();

            for (int ruleIndex = 0; ruleIndex < numberOfRules; ruleIndex++) {
                Rule thisRule = ((Rule) iBranchRules.get(ruleIndex));
                LispError.lispAssert(thisRule != null, aEnvironment, aStackTop);

                userStackInformation.iRulePrecedence = thisRule.getPrecedence();

                boolean matches = thisRule.matches(aEnvironment, aStackTop, argumentsResultPointerArray);

                if (matches) {

                    /* Rule dump trace code. */
                    if (isTraced() && showFlag) {
                        ConsPointer argumentsPointer = new ConsPointer();
                        argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
                        String ruleDump = org.mathpiper.lisp.Utility.dumpRule(aStackTop, thisRule, aEnvironment, this);
                        Evaluator.traceShowRule(aEnvironment, argumentsPointer, ruleDump);
                    }

                    userStackInformation.iSide = 1;

                    try {
                        beforeStackTop = aEnvironment.iArgumentStack.getStackTopIndex();
                        beforeEvaluationDepth = aEnvironment.iEvalDepth;

                        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, aResult, thisRule.getBodyPointer()); //*** User function is called here.

                    } catch (ReturnException re) {
                        //todo:tk:note that user functions currently return their results in aResult, not on the stack.
                        int stackTopIndex = aEnvironment.iArgumentStack.getStackTopIndex();
                        ConsPointer resultPointer = BuiltinFunction.getTopOfStackPointer(aEnvironment, stackTopIndex - 1);

                        aResult.setCons(resultPointer.getCons());

                        aEnvironment.iArgumentStack.popTo(beforeStackTop, aStackTop, aEnvironment);
                        aEnvironment.iEvalDepth = beforeEvaluationDepth;

                    }

                    /*Leave trace code */
                    if (isTraced() && showFlag) {
                        ConsPointer argumentsPointer2 = new ConsPointer();
                        argumentsPointer2.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
                        String localVariables = aEnvironment.getLocalVariables(aStackTop);
                        Evaluator.traceShowLeave(aEnvironment, aResult, argumentsPointer2, functionType, localVariables);
                        argumentsPointer2.setCons(null);
                    }//end if.

                    return;
                }//end if matches.

                // If rules got inserted, walk back.
                while (thisRule != ((Rule) iBranchRules.get(ruleIndex)) && ruleIndex > 0) {
                    ruleIndex--;
                }
            }//end for.


            // No predicate was true: return a new expression with the evaluated
            // arguments.
            ConsPointer full = new ConsPointer();
            full.setCons(aArgumentsPointer.getCons().copy(aEnvironment, false));
            if (arity == 0) {
                full.cdr().setCons(null);
            } else {
                full.cdr().setCons(argumentsResultPointerArray[0].getCons());
                for (int parameterIndex = 0; parameterIndex < arity - 1; parameterIndex++) {
                    argumentsResultPointerArray[parameterIndex].cdr().setCons(argumentsResultPointerArray[parameterIndex + 1].getCons());
                }
            }
            aResult.setCons(SublistCons.getInstance(aEnvironment, full.getCons()));


            /* Trace code */
            if (isTraced() && showFlag) {
                ConsPointer argumentsPointer3 = new ConsPointer();
                argumentsPointer3.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
                String localVariables = aEnvironment.getLocalVariables(aStackTop);
                Evaluator.traceShowLeave(aEnvironment, aResult, argumentsPointer3, functionType, localVariables);
                argumentsPointer3.setCons(null);
            }

        } catch (EvaluationException ex) {

            //ex.printStackTrace();//todo:tk:uncomment for debugging.

            if (ex.getFunctionName() == null) {
                throw new EvaluationException(ex.getMessage() + " In function: " + this.functionName + ",  ", "none", -1, this.functionName);
            } else {
                throw ex;
            }
        } finally {
            aEnvironment.popLocalFrame(aStackTop);
        }
    }


    protected ConsPointer[] evaluateArguments(Environment aEnvironment, int aStackTop, ConsPointer aArgumentsPointer) throws Exception {
        int arity = arity();
        int parameterIndex;

        /*Enter trace code*/
        if (isTraced()) {
            ConsPointer argumentsPointer = new ConsPointer();
            argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
            String traceFunctionName = "";
            if (argumentsPointer.car() instanceof ConsPointer) {
                ConsPointer sub = (ConsPointer) argumentsPointer.car();
                if (sub.car() instanceof String) {
                    traceFunctionName = (String) sub.car();
                }
            }//end function.
            if (Evaluator.isTraceFunction(traceFunctionName)) {
                showFlag = true;
                Evaluator.traceShowEnter(aEnvironment, argumentsPointer, functionType);
            } else {
                showFlag = false;
            }//
            argumentsPointer.setCons(null);
        }

        ConsPointer argumentsTraverser = new ConsPointer(aArgumentsPointer.getCons());

        //Strip the function name from the head of the list.
        argumentsTraverser.goNext(aStackTop, aEnvironment);

        //Creat an array which holds pointers to each argument.
        ConsPointer[] argumentsResultPointerArray;
        if (arity == 0) {
            argumentsResultPointerArray = null;
        } else {
            LispError.lispAssert(arity > 0, aEnvironment, aStackTop);
            argumentsResultPointerArray = new ConsPointer[arity];
        }

        // Walk over all arguments, evaluating them as necessary ********************************************************
        for (parameterIndex = 0; parameterIndex < arity; parameterIndex++) {

            argumentsResultPointerArray[parameterIndex] = new ConsPointer();

            LispError.check(aEnvironment, aStackTop, argumentsTraverser.getCons() != null, LispError.WRONG_NUMBER_OF_ARGUMENTS, "INTERNAL");

            if (((ParameterName) iParameters.get(parameterIndex)).iHold) {
                //If the parameter is on hold, don't evaluate it and place a copy of it in argumentsPointerArray.
                argumentsResultPointerArray[parameterIndex].setCons(argumentsTraverser.getCons().copy(aEnvironment, false));
            } else {
                //If the parameter is not on hold:

                //Verify that the pointer to the arguments is not null.
                LispError.check(aEnvironment, aStackTop, argumentsTraverser != null, LispError.WRONG_NUMBER_OF_ARGUMENTS, "INTERNAL");

                //Evaluate each argument and place the result into argumentsResultPointerArray[i];
                aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, argumentsResultPointerArray[parameterIndex], argumentsTraverser);
            }
            argumentsTraverser.goNext(aStackTop, aEnvironment);
        }//end for.

        /*Argument trace code */
        if (isTraced() && argumentsResultPointerArray != null && showFlag) {
            //ConsTraverser consTraverser2 = new ConsTraverser(aArguments);
            //ConsPointer traceArgumentPointer = new ConsPointer(aArgumentsPointer.getCons());

            //ConsTransverser traceArgumentPointer new ConsTraverser(this.iParameterList);
            ConsPointer traceParameterPointer = new ConsPointer(this.iParameterList.getCons());

            //traceArgumentPointer.goNext();
            for (parameterIndex = 0; parameterIndex < argumentsResultPointerArray.length; parameterIndex++) {
                Evaluator.traceShowArg(aEnvironment, traceParameterPointer, argumentsResultPointerArray[parameterIndex]);

                traceParameterPointer.goNext(aStackTop, aEnvironment);
            }//end for.
        }//end if.

        return argumentsResultPointerArray;

    }//end method.


    /**
     * Put an argument on hold.
     * The \c iHold flag of the corresponding argument is setCons. This
     * implies that this argument is not evaluated by evaluate().
     * 
     * @param aVariable name of argument to put un hold
     */
    public void holdArgument(String aVariable) {
        int i;
        int nrc = iParameters.size();
        for (i = 0; i < nrc; i++) {
            if (((ParameterName) iParameters.get(i)).iName.equals(aVariable)) {
                ((ParameterName) iParameters.get(i)).iHold = true;
            }
        }
    }


    /**
     * Return true if the arity of the function equals \a aArity.
     * 
     * @param aArity
     * @return true of the arities match.
     */
    public boolean isArity(int aArity) {
        return (arity() == aArity);
    }


    /**
     * Return the arity (number of arguments) of the function.
     *
     * @return the arity of the function
     */
    public int arity() {
        return iParameters.size();
    }


    /**
     *  Add a PredicateRule to the list of rules.
     * See: insertRule()
     * 
     * @param aPrecedence
     * @param aPredicate
     * @param aBody
     * @throws java.lang.Exception
     */
    public void defineSometimesTrueRule(int aStackTop, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) throws Exception {
        // New branching rule.
        PredicateRule newRule = new PredicateRule(iEnvironment, aPrecedence, aPredicate, aBody);
        LispError.check(iEnvironment, aStackTop, newRule != null, LispError.CREATING_RULE, "INTERNAL");

        insertRule(aPrecedence, newRule);
    }


    /**
     * Add a TrueRule to the list of rules.
     * See: insertRule()
     * 
     * @param aPrecedence
     * @param aBody
     * @throws java.lang.Exception
     */
    public void defineAlwaysTrueRule(int aStackTop, int aPrecedence, ConsPointer aBody) throws Exception {
        // New branching rule.
        PredicateRule newRule = new TrueRule(iEnvironment, aPrecedence, aBody);
        LispError.check(iEnvironment, aStackTop, newRule != null, LispError.CREATING_RULE, "INTERNAL");

        insertRule(aPrecedence, newRule);
    }


    /**
     *  Add a PatternRule to the list of rules.
     *  See: insertRule()
     * 
     * @param aPrecedence
     * @param aPredicate
     * @param aBody
     * @throws java.lang.Exception
     */
    public void definePattern(int aStackTop, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) throws Exception {
        // New branching rule.
        PatternRule newRule = new PatternRule(iEnvironment, aStackTop, aPrecedence, aPredicate, aBody);
        LispError.check(iEnvironment, aStackTop, newRule != null, LispError.CREATING_RULE, "INTERNAL");

        insertRule(aPrecedence, newRule);
    }


    /**
     * Insert any Rule object in the list of rules.
     * This function does the real work for defineAlwaysTrueRule() and
     * definePattern(): it inserts the rule in iRules, while
     * keeping it sorted. The algorithm is O(log n), where
     * n denotes the number of rules.
     * 
     * @param aPrecedence
     * @param newRule
     */
    void insertRule(int aNewRulePrecedence, Rule aNewRule) {
        // Find place to insert
        int low, high, mid;
        low = 0;
        high = iBranchRules.size();

        // Constant time: find out if the precedence is before any of the
        // currently defined rules or past them.
        if (high > 0) {
            if (((Rule) iBranchRules.get(0)).getPrecedence() > aNewRulePrecedence) {
                mid = 0;
                // Insert it
                iBranchRules.add(mid, aNewRule);
                return;
            }
            if (((Rule) iBranchRules.get(high - 1)).getPrecedence() < aNewRulePrecedence) {
                mid = high;
                // Insert it
                iBranchRules.add(mid, aNewRule);
                return;
            }
        }

        // Otherwise, O(log n) search algorithm for place to insert
        while(true) {
            if (low >= high) {
                //Insert it.
                mid = low;
                iBranchRules.add(mid, aNewRule);
                return;
            }


            mid = (low + high) >> 1;

            Rule existingRule = (Rule) iBranchRules.get(mid);

            int existingRulePrecedence = existingRule.getPrecedence();

            if (existingRulePrecedence > aNewRulePrecedence) {
                high = mid;
            } else if (existingRulePrecedence < aNewRulePrecedence) {
                low = (++mid);
            } else {

                //existingRule.
                //Insert it.
                iBranchRules.add(mid, aNewRule);
                return;
            }
        }
    }


    /**
     * Return the argument list, stored in #iParameterList.
     * 
     * @return a ConsPointer
     */
    public ConsPointer argList() {
        return iParameterList;
    }


    public Iterator getRules() {
        return iBranchRules.iterator();
    }


    public Iterator getParameters() {
        return iParameters.iterator();
    }


    public void unFence() {
        iFenced = false;
    }


    public boolean fenced() {
        return iFenced;
    }

}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/MacroRulebase.java0000644000175000017500000001651011522214131030027 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.exceptions.EvaluationException;
import org.mathpiper.lisp.stacks.UserStackInformation;
import org.mathpiper.lisp.behaviours.BackQuoteSubstitute;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Evaluator;
import org.mathpiper.lisp.LispExpressionEvaluator;
import org.mathpiper.lisp.cons.SublistCons;

public class MacroRulebase extends SingleArityRulebase {

    public MacroRulebase(Environment aEnvironment, int aStackTop, ConsPointer aParameters, String functionName) throws Exception {
        super(aEnvironment, aStackTop, aParameters, functionName);
        ConsTraverser parameterTraverser = new ConsTraverser(aEnvironment, aParameters);
        int i = 0;
        while (parameterTraverser.getCons() != null) {

            //LispError.check(parameterTraverser.car() != null, LispError.CREATING_USER_FUNCTION);
            try {
                LispError.check(aEnvironment, aStackTop, parameterTraverser.car() instanceof String, LispError.CREATING_USER_FUNCTION, "INTERNAL");
            } catch (EvaluationException ex) {
                if (ex.getFunctionName() == null) {
                    throw new EvaluationException(ex.getMessage() + " In function: " + this.functionName + ",  ", "none", -1, this.functionName);
                } else {
                    throw ex;
                }
            }//end catch.


            ((ParameterName) iParameters.get(i)).iHold = true;
            parameterTraverser.goNext(aStackTop);
            i++;
        }
        //Macros are all unfenced.
        unFence();

        this.functionType = "macro";
    }


    @Override
    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArgumentsPointer) throws Exception {
        int arity = arity();
        ConsPointer[] argumentsResultPointerArray = evaluateArguments(aEnvironment, aStackTop, aArgumentsPointer);



        ConsPointer substitutedBodyPointer = new ConsPointer();

        //Create a new local variable frame that is unfenced (false = unfenced).
        aEnvironment.pushLocalFrame(false, this.functionName);

        try {
            // define the local variables.
            for (int parameterIndex = 0; parameterIndex < arity; parameterIndex++) {
                String variable = ((ParameterName) iParameters.get(parameterIndex)).iName;

                // set the variable to the new value
                aEnvironment.newLocalVariable(variable, argumentsResultPointerArray[parameterIndex].getCons(), aStackTop);
            }

            // walk the rules database, returning the evaluated result if the
            // predicate is true.
            int numberOfRules = iBranchRules.size();
            UserStackInformation userStackInformation = aEnvironment.iLispExpressionEvaluator.stackInformation();
            for (int ruleIndex = 0; ruleIndex < numberOfRules; ruleIndex++) {
                Rule thisRule = ((Rule) iBranchRules.get(ruleIndex));
                //TODO remove            CHECKPTR(thisRule);
                LispError.lispAssert(thisRule != null, aEnvironment, aStackTop);

                userStackInformation.iRulePrecedence = thisRule.getPrecedence();

                boolean matches = thisRule.matches(aEnvironment, aStackTop, argumentsResultPointerArray);

                if (matches) {
                    /* Rule dump trace code. */
                    if (isTraced() && showFlag) {
                        ConsPointer argumentsPointer = new ConsPointer();
                        argumentsPointer.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
                        String ruleDump = org.mathpiper.lisp.Utility.dumpRule(aStackTop, thisRule, aEnvironment, this);
                        Evaluator.traceShowRule(aEnvironment, argumentsPointer, ruleDump);
                    }
                    userStackInformation.iSide = 1;

                    BackQuoteSubstitute backQuoteSubstitute = new BackQuoteSubstitute(aEnvironment);

                    ConsPointer originalBodyPointer = thisRule.getBodyPointer();
                    Utility.substitute(aEnvironment, aStackTop, substitutedBodyPointer, originalBodyPointer, backQuoteSubstitute);
                    //              aEnvironment.iLispExpressionEvaluator.Eval(aEnvironment, aResult, thisRule.body());
                    break;
                }

                // If rules got inserted, walk back
                while (thisRule != ((Rule) iBranchRules.get(ruleIndex)) && ruleIndex > 0) {
                    ruleIndex--;
                }
            }
        } catch (EvaluationException ex) {
            if (ex.getFunctionName() == null) {
                throw new EvaluationException(ex.getMessage() + " In function: " + this.functionName + ",  ", "none", -1, this.functionName);
            } else {
                throw ex;
            }
        } finally {
            aEnvironment.popLocalFrame(aStackTop);
        }



        if (substitutedBodyPointer.getCons() != null) {
            //Note:tk:substituted body must be evaluated after the local frame has been popped.
            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, aResult, substitutedBodyPointer);
        } else // No predicate was true: return a new expression with the evaluated
        // arguments.
        {
            ConsPointer full = new ConsPointer();
            full.setCons(aArgumentsPointer.getCons().copy(aEnvironment, false));
            if (arity == 0) {
                full.cdr().setCons(null);
            } else {
                full.cdr().setCons(argumentsResultPointerArray[0].getCons());
                for (int parameterIndex = 0; parameterIndex < arity - 1; parameterIndex++) {
                    argumentsResultPointerArray[parameterIndex].cdr().setCons(argumentsResultPointerArray[parameterIndex + 1].getCons());
                }
            }
            aResult.setCons(SublistCons.getInstance(aEnvironment, full.getCons()));
        }
        //FINISH:

        /*Leave trace code */
        if (isTraced() && showFlag) {
            ConsPointer tr = new ConsPointer();
            tr.setCons(SublistCons.getInstance(aEnvironment, aArgumentsPointer.getCons()));
            String localVariables = aEnvironment.getLocalVariables(aStackTop);
            LispExpressionEvaluator.traceShowLeave(aEnvironment, aResult, tr, "macro", localVariables);
            tr.setCons(null);
        }

    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/Rule.java0000644000175000017500000000237211420626602026222 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

/**
 * Base class for rules.
 */
public abstract class Rule
{

    public abstract boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception;

    public abstract int getPrecedence();

    public abstract ConsPointer getPredicatePointer();

    public abstract ConsPointer getBodyPointer();
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/ParameterName.java0000644000175000017500000000235611420626602030036 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

/**
 * Contains the name of a parameter and if it is put on hold.
 */
public class ParameterName
{
        String iName;
        boolean iHold;

    public ParameterName(String aParameter, boolean aHold /*=false*/)
    {
        iName = aParameter;
        iHold = aHold;
    }

    public String getName()
    {
        return iName;
    }

    public boolean isHold()
    {
        return iHold;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/PatternRule.java0000644000175000017500000000565211506531763027574 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.builtin.PatternContainer;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.parametermatchers.ParametersPatternMatcher;

/**
 * A rule which matches if the corresponding {@link PatternContainer} matches.
 */
public class PatternRule extends Rule {

    protected int iPrecedence;
    protected ConsPointer iBody;
    protected ConsPointer iPredicate;    
    protected PatternContainer iPattern; //The pattern that decides whether this rule matches or not.

    /**
     * 
     * @param aPrecedence precedence of the rule
     * @param aPredicate getObject object of type PatternContainer
     * @param aBody body of the rule
     */
    public PatternRule(Environment aEnvironment, int aStackTop, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) throws Exception {
        iBody = new ConsPointer();
        iPredicate = new ConsPointer();
        iPattern = null;
        iPrecedence = aPrecedence;
        iPredicate.setCons(aPredicate.getCons());

        BuiltinContainer gen = (BuiltinContainer) aPredicate.car();
        LispError.check(aEnvironment, aStackTop, gen != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        LispError.check(aEnvironment, aStackTop, gen.typeName().equals("\"Pattern\""), LispError.INVALID_ARGUMENT, "INTERNAL");

        iPattern = (PatternContainer) gen;
        iBody.setCons(aBody.getCons());
    }

    //Return true if the corresponding pattern matches.
    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception {
        return iPattern.matches(aEnvironment, aStackTop, aArguments);
    }

    //Access iPrecedence.
    public int getPrecedence() {
        return iPrecedence;
    }

    public ConsPointer getPredicatePointer() {
        return this.iPredicate;
    }

    public ParametersPatternMatcher getPattern() {
        return iPattern.getPattern();
    }

    //Access iBody
    public ConsPointer getBodyPointer() {
        return iBody;
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/ListedMacroRulebase.java0000644000175000017500000000523311520672140031202 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.SublistCons;

public class ListedMacroRulebase extends MacroRulebase {

    public ListedMacroRulebase(Environment aEnvironment, int aStackTop, ConsPointer aParameters, String functionName) throws Exception {
        super(aEnvironment, aStackTop, aParameters, functionName);
    }


    @Override
    public boolean isArity(int aArity) {
        return (arity() <= aArity);
    }


    @Override
    public void evaluate(Environment aEnvironment, int aStackTop, ConsPointer aResult, ConsPointer aArguments) throws Exception {
        ConsPointer newArgs = new ConsPointer();
        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, aArguments);
        ConsPointer ptr = newArgs;
        int arity = arity();
        int i = 0;
        while (i < arity && consTraverser.getCons() != null) {
            ptr.setCons(consTraverser.getCons().copy(aEnvironment, false));
            ptr = (ptr.cdr());
            i++;
            consTraverser.goNext(aStackTop);
        }
        if (consTraverser.cdr().getCons() == null) {
            ptr.setCons(consTraverser.getCons().copy(aEnvironment, false));
            ptr = (ptr.cdr());
            i++;
            consTraverser.goNext(aStackTop);
            LispError.lispAssert(consTraverser.getCons() == null, aEnvironment, aStackTop);
        } else {
            ConsPointer head = new ConsPointer();
            head.setCons(aEnvironment.iListAtom.copy(aEnvironment, false));
            head.cdr().setCons(consTraverser.getCons());
            ptr.setCons(SublistCons.getInstance(aEnvironment, head.getCons()));
        }
        super.evaluate(aEnvironment, aStackTop, aResult, newArgs);
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/MultipleArityRulebase.java0000644000175000017500000001131411520672140031575 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.*;
import java.util.*;

/**
 * Holds a set of {@link SingleArityRulebase} which are associated with one function name.
 * A specific SingleArityRulebase can be selected by providing its name.  The
 * name of the file in which the function is defined can also be specified.
 */
public class MultipleArityRulebase {

    /// Set of SingleArityRulebase's provided by this MultipleArityRulebase.
    List iFunctions = new ArrayList();//
    /// File to read for the definition of this function.
    public DefFile iFileToOpen;
    public String iFileLocation;


    public MultipleArityRulebase() {
        iFileToOpen = null;
    }


    /**
     *Return user function with given arity.
     */
    public SingleArityRulebase getUserFunction(int aArity, int aStackTop, Environment aEnvironment) throws Exception {
        int ruleIndex;
        //Find function body with the right arity
        int numberOfRules = iFunctions.size();
        for (ruleIndex = 0; ruleIndex < numberOfRules; ruleIndex++) {
            LispError.lispAssert(iFunctions.get(ruleIndex) != null, aEnvironment, aStackTop);

            if (((SingleArityRulebase) iFunctions.get(ruleIndex)).isArity(aArity)) {
                return (SingleArityRulebase) iFunctions.get(ruleIndex);
            }
        }

        // If function not found, just unaccept!
        // User-defined function not found! Returning null
        return null;

    }//end method.


    /**
     * Specify that some argument should be held.
     */
    public void holdArgument(String aVariable, int aStackTop, Environment aEnvironment) throws Exception {
        int ruleIndex;
        for (ruleIndex = 0; ruleIndex < iFunctions.size(); ruleIndex++) {
            LispError.lispAssert(iFunctions.get(ruleIndex) != null, aEnvironment, aStackTop);
            ((SingleArityRulebase) iFunctions.get(ruleIndex)).holdArgument(aVariable);
        }
    }//end method.


    /**
     *Add another SingleArityRulebase to #iFunctions.
     */
    public void addRulebaseEntry(Environment aEnvironment, int aStackTop, SingleArityRulebase aNewFunction) throws Exception {
        int ruleIndex;
        //Find function body with the right arity
        int numberOfRules = iFunctions.size();
        for (ruleIndex = 0; ruleIndex < numberOfRules; ruleIndex++) {
            LispError.lispAssert(((SingleArityRulebase) iFunctions.get(ruleIndex)) != null, aEnvironment, aStackTop);
            LispError.lispAssert(aNewFunction != null, aEnvironment, aStackTop);
            LispError.check(aEnvironment, aStackTop, !((SingleArityRulebase) iFunctions.get(ruleIndex)).isArity(aNewFunction.arity()), LispError.ARITY_ALREADY_DEFINED, "INTERNAL");
            LispError.check(aEnvironment, aStackTop, !aNewFunction.isArity(((SingleArityRulebase) iFunctions.get(ruleIndex)).arity()), LispError.ARITY_ALREADY_DEFINED, "INTERNAL");
        }
        iFunctions.add(aNewFunction);
    }//end method.


    /**
     *Delete user function with given arity.  If arity is -1 then delete all functions regardless of arity.
     */
    public void deleteRulebaseEntry(int aArity, int aStackTop, Environment aEnvironment) throws Exception {
        if (aArity == -1) //Retract all functions regardless of arity.
        {
            iFunctions.clear();
            return;
        }//end if.

        int ruleIndex;
        //Find function body with the right arity
        int numberOfRules = iFunctions.size();
        for (ruleIndex = 0; ruleIndex < numberOfRules; ruleIndex++) {
            LispError.lispAssert(((SingleArityRulebase) iFunctions.get(ruleIndex)) != null, aEnvironment, aStackTop);

            if (((SingleArityRulebase) iFunctions.get(ruleIndex)).isArity(aArity)) {
                iFunctions.remove(ruleIndex);
                return;
            }
        }
    }//end method.


    public Iterator getFunctions() {
        return this.iFunctions.iterator();
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/rulebases/PredicateRule.java0000644000175000017500000000503311506531763030050 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.rulebases;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.Utility;

/**
 * A rule with a predicate (the rule matches if the predicate evaluates to True.)
 */
class PredicateRule extends Rule {

    protected int iPrecedence;
    protected ConsPointer iBody;
    protected ConsPointer iPredicate;


    public PredicateRule(Environment aEnvironment, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) {
        iBody = new ConsPointer();
        iBody.setCons(aBody.getCons());
        iPredicate = new ConsPointer();
        iPrecedence = aPrecedence;
        iPredicate.setCons(aPredicate.getCons());

    }


    protected PredicateRule(Environment aEnvironment) {
        iBody = new ConsPointer();
        iPredicate = new ConsPointer();
    }


    private PredicateRule() {
    }


    /**
     *  Return true if the rule matches.
     * 
     * @param aEnvironment
     * @param aArguments
     * @return
     * @throws java.lang.Exception
     */
    // iPredicate is evaluated in \a Environment. If the result
    /// IsTrue(), this function returns true
    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception {
        ConsPointer pred = new ConsPointer();
        aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, pred, iPredicate);
        return Utility.isTrue(aEnvironment, pred, aStackTop);
    }

    /// Access #iPrecedence.

    public int getPrecedence() {
        return iPrecedence;
    }

    /// Access #iBody.

    public ConsPointer getBodyPointer() {
        return iBody;
    }


    public ConsPointer getPredicatePointer() {
        return this.iPredicate;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/localvariables/0000755000175000017500000000000011722677325025457 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/localvariables/LocalVariableFrame.java0000644000175000017500000000314411506531763031772 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.localvariables;

public class LocalVariableFrame {

    public LocalVariableFrame iNext;
    public LocalVariable iFirst;
    LocalVariable iLast;
    private String functionName;


    public LocalVariableFrame(LocalVariableFrame aNext, LocalVariable aFirst, String functionName) {
        iNext = aNext;
        iFirst = aFirst;
        iLast = aFirst;
        this.functionName = functionName;
    }


    public void add(LocalVariable aNew) {
        aNew.iNext = iFirst;
        iFirst = aNew;
    }


    public void delete() {
        LocalVariable t = iFirst;
        LocalVariable next;
        while (t != iLast) {
            next = t.iNext;
            t = next;
        }
    }//end method.


    public String getFunctionName() {
        return functionName;
    }

}//end class

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/localvariables/LocalVariable.java0000644000175000017500000000245011506531763031016 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.localvariables;

import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.cons.ConsPointer;

public class LocalVariable {

    public LocalVariable iNext;
    public String iVariable;
    public ConsPointer iValue;


    public LocalVariable(Environment aEnvironment, String aVariable, Cons aValue) {
        iNext = null;
        iVariable = aVariable;
        iValue = new ConsPointer();
        iValue.setCons(aValue);


    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/Environment.java0000644000175000017500000005607611554752464025662 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp;

import java.util.HashSet;
import java.util.List;
import java.util.Set;
import org.mathpiper.lisp.stacks.ArgumentStack;
import org.mathpiper.lisp.collections.DefFileMap;
import org.mathpiper.lisp.collections.MathPiperMap;
import org.mathpiper.lisp.collections.TokenMap;
import org.mathpiper.lisp.collections.OperatorMap;
import org.mathpiper.lisp.cons.AtomCons;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.printers.LispPrinter;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.builtin.BuiltinFunction;
import org.mathpiper.lisp.tokenizers.XmlTokenizer;
import org.mathpiper.io.InputStatus;

import org.mathpiper.io.InputDirectories;

import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;

import org.mathpiper.lisp.rulebases.MultipleArityRulebase;

import org.mathpiper.lisp.rulebases.MacroRulebase;


import org.mathpiper.lisp.rulebases.ListedRulebase;

import org.mathpiper.lisp.rulebases.SingleArityRulebase;

import org.mathpiper.lisp.rulebases.ListedMacroRulebase;

import org.mathpiper.lisp.printers.MathPiperPrinter;

import org.mathpiper.lisp.localvariables.LocalVariable;
import org.mathpiper.lisp.localvariables.LocalVariableFrame;

public final class Environment {

    public Evaluator iLispExpressionEvaluator = new LispExpressionEvaluator();
    private int iPrecision = 10;
    private TokenMap iTokenHash = new TokenMap();
    public Cons iTrueAtom;
    public final String iTrueString;
    public Cons iFalseAtom;
    public final String iFalseString;
    public Cons iEndOfFileAtom;
    public Cons iEndStatementAtom;
    public Cons iProgOpenAtom;
    public Cons iProgCloseAtom;
    public Cons iNthAtom;
    public Cons iComplexAtom;
    public Cons iBracketOpenAtom;
    public Cons iBracketCloseAtom;
    public Cons iListOpenAtom;
    public Cons iListCloseAtom;
    public Cons iCommaAtom;
    public Cons iListAtom;
    public Cons iSetAtom;
    public Cons iProgAtom;
    public OperatorMap iPrefixOperators = new OperatorMap(this);
    public OperatorMap iInfixOperators = new OperatorMap(this);
    public OperatorMap iPostfixOperators = new OperatorMap(this);
    public OperatorMap iBodiedOperators = new OperatorMap(this);
    public volatile int iEvalDepth = 0;
    public int iMaxEvalDepth = 10000;
    //TODO FIXME
    public ArgumentStack iArgumentStack;
    public LocalVariableFrame iLocalVariablesFrame;
    public boolean iSecure = false;
    public int iLastUniqueId = 1;
    public MathPiperOutputStream iCurrentOutput = null;
    public MathPiperOutputStream iInitialOutput = null;
    public LispPrinter iCurrentPrinter = null;
    public MathPiperInputStream iCurrentInput = null;
    public InputStatus iInputStatus = new InputStatus();
    public MathPiperTokenizer iCurrentTokenizer;
    public MathPiperTokenizer iDefaultTokenizer = new MathPiperTokenizer();
    public MathPiperTokenizer iXmlTokenizer = new XmlTokenizer();
    public MathPiperMap iGlobalState = new MathPiperMap();
    public MathPiperMap iUserRules = new MathPiperMap();
    MathPiperMap iBuiltinFunctions = new MathPiperMap();
    public Throwable iException = null;
    public DefFileMap iDefFiles = new DefFileMap();
    public InputDirectories iInputDirectories = new InputDirectories();
    public String iPrettyReaderName = null;
    public String iPrettyPrinterName = null;

    public Environment(MathPiperOutputStream aCurrentOutput/*TODO FIXME*/) throws Exception {
        iCurrentTokenizer = iDefaultTokenizer;
        iInitialOutput = aCurrentOutput;
        iCurrentOutput = aCurrentOutput;
        iCurrentPrinter = new MathPiperPrinter(iPrefixOperators, iInfixOperators, iPostfixOperators, iBodiedOperators);

        iTrueAtom = new AtomCons((String)getTokenHash().lookUp("True"));
        iTrueString = (String) iTrueAtom.car();
        iFalseAtom = new AtomCons((String)getTokenHash().lookUp("False"));
        iFalseString = (String) iFalseAtom.car();
        iEndOfFileAtom = new AtomCons((String)getTokenHash().lookUp("EndOfFile"));
        iEndStatementAtom = new AtomCons((String)getTokenHash().lookUp(";"));
        iProgOpenAtom = new AtomCons((String)getTokenHash().lookUp("["));
        iProgCloseAtom = new AtomCons((String)getTokenHash().lookUp("]"));
        iNthAtom = new AtomCons((String)getTokenHash().lookUp("Nth"));
        iComplexAtom = new AtomCons((String)getTokenHash().lookUp("Complex"));
        iBracketOpenAtom = new AtomCons((String)getTokenHash().lookUp("("));
        iBracketCloseAtom = new AtomCons((String)getTokenHash().lookUp(")"));
        iListOpenAtom = new AtomCons((String)getTokenHash().lookUp("{"));
        iListCloseAtom = new AtomCons((String)getTokenHash().lookUp("}"));
        iCommaAtom = new AtomCons((String)getTokenHash().lookUp(","));
        iListAtom = new AtomCons((String)getTokenHash().lookUp("List"));
        iSetAtom = new AtomCons((String)getTokenHash().lookUp("Set"));
        iProgAtom = new AtomCons((String)getTokenHash().lookUp("Prog"));

        iArgumentStack = new ArgumentStack(this, 50000 /*TODO FIXME*/);
        //org.mathpiper.builtin.Functions mc = new org.mathpiper.builtin.Functions();
        //mc.addCoreFunctions(this);

        //System.out.println("Classpath: " + System.getProperty("java.class.path"));
        
    }

    public TokenMap getTokenHash() {
        return iTokenHash;
    }

    public MathPiperMap getGlobalState() {
        return iGlobalState;
    }

    public MathPiperMap getUserFunctions() {
        return iUserRules;
    }

    public MathPiperMap getBuiltinFunctions() {
        return iBuiltinFunctions;
    }

    public int getPrecision() {
        return iPrecision;
    }

    public void setPrecision(int aPrecision) throws Exception {
        iPrecision = aPrecision;    // getPrecision in decimal digits
    }

    public void setGlobalVariable(int aStackTop, String aVariable, ConsPointer aValue, boolean aGlobalLazyVariable) throws Exception {
        ConsPointer localVariable = getLocalVariable(aStackTop, aVariable);
        if (localVariable != null) {
            localVariable.setCons(aValue.getCons());
            return;
        }
        GlobalVariable globalVariable = new GlobalVariable(this,aValue);
        iGlobalState.setAssociation(globalVariable, aVariable);
        if (aGlobalLazyVariable) {
            globalVariable.setEvalBeforeReturn(true);
        }
    }

    public void getGlobalVariable(int aStackTop, String aVariable, ConsPointer aResult) throws Exception {
        aResult.setCons(null);
        ConsPointer localVariable = getLocalVariable(aStackTop, aVariable);
        if (localVariable != null) {
            aResult.setCons(localVariable.getCons());
            return;
        }
        GlobalVariable globalVariable = (GlobalVariable) iGlobalState.lookUp(aVariable);
        if (globalVariable != null) {
            if (globalVariable.iEvalBeforeReturn) {
                iLispExpressionEvaluator.evaluate(this, aStackTop, aResult, globalVariable.iValue);
                globalVariable.iValue.setCons(aResult.getCons());
                globalVariable.iEvalBeforeReturn = false;
                return;
            } else {
                aResult.setCons(globalVariable.iValue.getCons());
                return;
            }
        }
    }


    public ConsPointer getLocalVariable(int aStackTop, String aVariable) throws Exception {
        LispError.check(this, aStackTop, iLocalVariablesFrame != null, LispError.INVALID_STACK, "INTERNAL");
        //    check(iLocalsList.iFirst != null,INVALID_STACK);
        LocalVariable localVariable = iLocalVariablesFrame.iFirst;

        while (localVariable != null) {
            if (localVariable.iVariable.equals(aVariable)) {
                return localVariable.iValue;
            }
            localVariable = localVariable.iNext;
        }
        return null;
    }//end method.



    public void unbindAllLocalVariables(int aStackTop) throws Exception{
        LispError.check(this, aStackTop, iLocalVariablesFrame != null, LispError.INVALID_STACK, "INTERNAL");

        LocalVariable localVariable = iLocalVariablesFrame.iFirst;

        while (localVariable != null) {
            localVariable.iValue.setCons(null);
            localVariable = localVariable.iNext;
        }
        
    }//end method.


    public String getLocalVariables(int aStackTop) throws Exception {
        LispError.check(this, aStackTop, iLocalVariablesFrame != null, LispError.INVALID_STACK, "INTERNAL");
        //    check(iLocalsList.iFirst != null,INVALID_STACK);

        LocalVariable localVariable = iLocalVariablesFrame.iFirst;

        StringBuilder localVariablesStringBuilder = new StringBuilder();

        localVariablesStringBuilder.append("Local variables: ");

        while (localVariable != null) {
            localVariablesStringBuilder.append(localVariable.iVariable);

            localVariablesStringBuilder.append(" -> ");

            String value = localVariable.iValue.toString();
            if(value != null)
            {
                localVariablesStringBuilder.append(value.trim().replace("  ","").replace("\n", "") );
            }
            else
            {
                localVariablesStringBuilder.append("unbound");
            }//end else.

            localVariablesStringBuilder.append(", ");

            localVariable = localVariable.iNext;
        }//end while.

        return localVariablesStringBuilder.toString();

    }//end method.


    public String dumpLocalVariablesFrame(int aStackTop) throws Exception {

        LispError.check(this, aStackTop, iLocalVariablesFrame != null, LispError.INVALID_STACK, "INTERNAL");

        LocalVariableFrame localVariableFramePointer = iLocalVariablesFrame;

        StringBuilder stringBuilder = new StringBuilder();



        int functionPositionIndex = 0;

        //int functionBaseIndex = 0;

        while (localVariableFramePointer != null) {

            String functionName = localVariableFramePointer.getFunctionName();


            if(functionPositionIndex == 0)
            {
                stringBuilder.append("\n\n========================================= Start Of User Function Stack Trace\n");
            }
            else
            {
                stringBuilder.append("-----------------------------------------\n");
            }


            stringBuilder.append(functionPositionIndex++ + ": ");
            stringBuilder.append(functionName);
            stringBuilder.append("\n");

            LocalVariable localVariable = localVariableFramePointer.iFirst;


            //stringBuilder.append("Local variables: ");


            while (localVariable != null) {


                stringBuilder.append("   " + functionPositionIndex++ + ": -> ");

                stringBuilder.append(localVariable.iVariable);

                stringBuilder.append(" = ");

                ConsPointer valuePointer = localVariable.iValue;

                String valueString = Utility.printMathPiperExpression(aStackTop, valuePointer, this, -1);

                stringBuilder.append(valueString);

                stringBuilder.append("\n");




                /*if(value != null)
                {
                    localVariablesStringBuilder.append(value.trim().replace("  ","").replace("\n", "") );
                }
                else
                {
                    localVariablesStringBuilder.append("unbound");
                }//end else.


                localVariablesStringBuilder.append(", ");*/

                localVariable = localVariable.iNext;
            }//end while.

            localVariableFramePointer = localVariableFramePointer.iNext;

        }//end while

        stringBuilder.append("========================================= End Of User Function Stack Trace\n\n");

        return stringBuilder.toString();




        /*StringBuilder stringBuilder = new StringBuilder();

        int functionBaseIndex = 0;

        int functionPositionIndex = 0;


        while (functionBaseIndex <= aStackTop) {

            if(functionBaseIndex == 0)
            {
                stringBuilder.append("\n\n========================================= Start Of Stack Trace\n");
            }
            else
            {
                stringBuilder.append("-----------------------------------------\n");
            }

            ConsPointer consPointer = getElement(functionBaseIndex, aStackTop, aEnvironment);

            int argumentCount = Utility.listLength(aEnvironment, aStackTop, consPointer);

            ConsPointer argumentPointer = new ConsPointer();

            Object car = consPointer.getCons().car();

            ConsPointer consTraverser = new ConsPointer( consPointer.getCons());

            stringBuilder.append(functionPositionIndex++ + ": ");
            stringBuilder.append(Utility.printMathPiperExpression(aStackTop, consTraverser, aEnvironment, -1));
            stringBuilder.append("\n");

            consTraverser.goNext(aStackTop, aEnvironment);

            while(consTraverser.getCons() != null)
            {
                stringBuilder.append("   " + functionPositionIndex++ + ": ");
                stringBuilder.append("-> " + Utility.printMathPiperExpression(aStackTop, consTraverser, aEnvironment, -1));
                stringBuilder.append("\n");

                consTraverser.goNext(aStackTop, aEnvironment);
            }


            functionBaseIndex = functionBaseIndex + argumentCount;

        }//end while.

        stringBuilder.append("========================================= End Of User Function Stack Trace\n\n");

        return stringBuilder.toString();*/

    }//end method.

    public void unbindVariable(int aStackTop, String aVariableName) throws Exception {

        if(aVariableName.equals("*"))
        {
            this.unbindAllLocalVariables(aStackTop);


            //Unbind global variables
            Set keySet = new HashSet(iGlobalState.getMap().keySet());

            for(String key : keySet)
            {
                if(!key.startsWith("$") 
			&& !key.equals("I") 
			&& !key.equals("%") 
			&& !key.equals("geogebra"))
                {
                    //Do not unbind private variables (which are those which start with a $) or the other listed variables.
                    iGlobalState.release(key);
                }
            }
        }
        else
        {
            //Unbind local variable.
            ConsPointer localVariable = getLocalVariable(aStackTop, aVariableName);
            if (localVariable != null) {
                localVariable.setCons(null);
                return;
            }

            iGlobalState.release(aVariableName);
        }//end else.

    }

    public void newLocalVariable(String aVariable, Cons aValue, int aStackTop) throws Exception {
        LispError.lispAssert(iLocalVariablesFrame != null, this, aStackTop);
        iLocalVariablesFrame.add(new LocalVariable(this, aVariable, aValue));
    }

    public void pushLocalFrame(boolean aFenced, String functionName) {
        if (aFenced) {
            LocalVariableFrame newLocalVariableFrame = new LocalVariableFrame(iLocalVariablesFrame, null, functionName);
            iLocalVariablesFrame = newLocalVariableFrame;
        } else {
            LocalVariableFrame newLocalVariableFrame = new LocalVariableFrame(iLocalVariablesFrame, iLocalVariablesFrame.iFirst, functionName);
            iLocalVariablesFrame = newLocalVariableFrame;
        }
    }

    public void popLocalFrame(int aStackTop) throws Exception {
        LispError.lispAssert(iLocalVariablesFrame != null, this, aStackTop);
        LocalVariableFrame nextLocalVariableFrame = iLocalVariablesFrame.iNext;
        iLocalVariablesFrame.delete();
        iLocalVariablesFrame = nextLocalVariableFrame;
    }

    public int getUniqueId() {
        return iLastUniqueId++;
    }

    public void holdArgument(int aStackTop, String aOperator, String aVariable, Environment aEnvironment) throws Exception {
        MultipleArityRulebase multipleArityUserFunc = (MultipleArityRulebase) iUserRules.lookUp(aOperator);
        LispError.check(this, aStackTop, multipleArityUserFunc != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        multipleArityUserFunc.holdArgument(aVariable, aStackTop, aEnvironment);
    }

    public void retractRule(String aOperator, int aArity, int aStackTop, Environment aEnvironment) throws Exception {
        MultipleArityRulebase multipleArityUserFunc = (MultipleArityRulebase) iUserRules.lookUp(aOperator);
        if (multipleArityUserFunc != null) {
            multipleArityUserFunc.deleteRulebaseEntry(aArity, aStackTop, aEnvironment);
        }
    }

    public SingleArityRulebase getRulebase(int aStackTop, ConsPointer aArguments) throws Exception {
        MultipleArityRulebase multipleArityUserFunc = (MultipleArityRulebase) iUserRules.lookUp( (String) aArguments.car());
        if (multipleArityUserFunc != null) {
            int arity = Utility.listLength(this, aStackTop, aArguments) - 1;
            return multipleArityUserFunc.getUserFunction(arity, aStackTop, this);
        }
        return null;
    }

    public SingleArityRulebase getRulebase(String aName, int aArity, int aStackTop) throws Exception {
        MultipleArityRulebase multipleArityUserFunc = (MultipleArityRulebase) iUserRules.lookUp(aName);
        if (multipleArityUserFunc != null) {
            return multipleArityUserFunc.getUserFunction(aArity, aStackTop, this);
        }
        return null;
    }

    public void unfenceRule(int aStackTop, String aOperator, int aArity) throws Exception {
        MultipleArityRulebase multiUserFunc = (MultipleArityRulebase) iUserRules.lookUp(aOperator);

        LispError.check(this, aStackTop, multiUserFunc != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        SingleArityRulebase userFunc = multiUserFunc.getUserFunction(aArity, aStackTop, this);
        LispError.check(this, aStackTop, userFunc != null, LispError.INVALID_ARGUMENT, "INTERNAL");
        userFunc.unFence();
    }

    public MultipleArityRulebase getMultipleArityRulebase(int aStackTop, String aOperator, boolean create) throws Exception {
        // Find existing multiuser func.  Todo:tk:a user function name is added to the list even if a non-existing function
        // is being executed or looked for by FindFunction();
        MultipleArityRulebase multipleArityUserFunction = (MultipleArityRulebase) iUserRules.lookUp(aOperator);

        // If none exists, add one to the user functions list
        if (multipleArityUserFunction == null && create == true) {
            MultipleArityRulebase newMultipleArityUserFunction = new MultipleArityRulebase();
            iUserRules.setAssociation(newMultipleArityUserFunction, aOperator);
            multipleArityUserFunction = (MultipleArityRulebase) iUserRules.lookUp(aOperator);
            LispError.check(this, aStackTop, multipleArityUserFunction != null, LispError.CREATING_USER_FUNCTION, "INTERNAL");
        }
        return multipleArityUserFunction;
    }

    public void defineRulebase(int aStackTop, String aOperator, ConsPointer aParametersPointer, boolean aListed) throws Exception {
        MultipleArityRulebase multipleArityUserFunction = getMultipleArityRulebase(aStackTop, aOperator, true);

        // add an operator with this arity to the multiuserfunc.
        SingleArityRulebase newBranchingRulebase;
        if (aListed) {
            newBranchingRulebase = new ListedRulebase(this, aStackTop, aParametersPointer, aOperator);
        } else {
            newBranchingRulebase = new SingleArityRulebase(this, aStackTop, aParametersPointer, aOperator);
        }
        multipleArityUserFunction.addRulebaseEntry(this, aStackTop, newBranchingRulebase);
    }

    public void defineRule(int aStackTop, String aOperator, int aArity, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) throws Exception {
        // Find existing multiuser rule.
        MultipleArityRulebase multipleArityRulebase = (MultipleArityRulebase) iUserRules.lookUp(aOperator);
        LispError.check(this, aStackTop, multipleArityRulebase != null, LispError.CREATING_RULE, "INTERNAL");

        // Get the specific user function with the right arity
        SingleArityRulebase rulebase = (SingleArityRulebase) multipleArityRulebase.getUserFunction(aArity, aStackTop, this);
        LispError.check(this, aStackTop, rulebase != null, LispError.CREATING_RULE, "INTERNAL");

        // Declare a new evaluation rule
        if (Utility.isTrue(this, aPredicate, aStackTop)) {
            //        printf("FastPredicate on %s\n",aOperator->String());
            rulebase.defineAlwaysTrueRule(aStackTop, aPrecedence, aBody);
        } else {
            rulebase.defineSometimesTrueRule(aStackTop, aPrecedence, aPredicate, aBody);
        }
    }

    public void defineMacroRulebase(int aStackTop, String aFunctionName, ConsPointer aParameters, boolean aListed) throws Exception {
        MultipleArityRulebase multipleArityRulebase = getMultipleArityRulebase(aStackTop, aFunctionName, true);

        MacroRulebase newMacroRulebase;

        if (aListed) {
            newMacroRulebase = new ListedMacroRulebase(this, aStackTop, aParameters, aFunctionName);
        } else {
            newMacroRulebase = new MacroRulebase(this, aStackTop, aParameters, aFunctionName);
        }
        multipleArityRulebase.addRulebaseEntry(this, aStackTop, newMacroRulebase);
    }

    public void defineRulePattern(int aStackTop, String aOperator, int aArity, int aPrecedence, ConsPointer aPredicate, ConsPointer aBody) throws Exception {
        // Find existing multiuser rulebase.
        MultipleArityRulebase multipleArityRulebase = (MultipleArityRulebase) iUserRules.lookUp(aOperator);
        LispError.check(this, aStackTop, multipleArityRulebase != null, LispError.CREATING_RULE, "INTERNAL");

        // Get the specific user function with the right arity
        SingleArityRulebase rulebase = multipleArityRulebase.getUserFunction(aArity, aStackTop, this);
        LispError.check(this, aStackTop, rulebase != null, LispError.CREATING_RULE, "INTERNAL");

        // Declare a new evaluation rule
        rulebase.definePattern(aStackTop, aPrecedence, aPredicate, aBody);
    }

    /**
     * Write data to the current output.
     * @param aString
     * @throws java.lang.Exception
     */
    public void write(String aString) throws Exception {
        iCurrentOutput.write(aString);
    }



    public void resetArgumentStack(int aStackTop) throws Exception
    {
        this.iArgumentStack.reset(aStackTop, this);
    }//end method.




}//end class.

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/0000755000175000017500000000000011722677326026204 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/PatternParameterMatcher.java0000644000175000017500000000274411420662456033631 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

//Abstract class for matching one argument to a pattern.
public abstract class PatternParameterMatcher {

    /**
     *Check whether some expression matches to the pattern.
     *@aEnvironment the underlying Lisp environment.
     *@aExpression the expression to test.
     *@arguments (input/output) actual values of the pattern variables for aExpression.
     */
    public abstract boolean argumentMatches(Environment aEnvironment, int aStackTop, ConsPointer aExpression, ConsPointer[] arguments) throws Exception;


    public abstract String getType();

}
././@LongLink0000000000000000000000000000015400000000000011565 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/VariablePatternParameterMatcher.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/VariablePatternParameterMatch0000644000175000017500000000477711506531763034041 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

//Class for matching against a pattern variable.
public class VariablePatternParameterMatcher extends PatternParameterMatcher {
    //Index of variable in MathPiperPatternPredicateBase.iVariables.
    protected int iVarIndex;

    //Not used.
    protected String iString;


    public VariablePatternParameterMatcher(int aVarIndex) {
        iVarIndex = aVarIndex;
    }


    /**
     *Matches an expression against the pattern variable.
     *@param aEnvironment the underlying Lisp environment.
     *@param aExpression the expression to test.
     *@param arguments (input/output) actual values of the pattern variables for aExpression.
     *
     *If entry iVarIndex in arguments is still empty, the
     *pattern matches and aExpression is stored in this
     *entry. Otherwise, the pattern only matches if the entry equals
     *aExpression.
     */
    public boolean argumentMatches(Environment aEnvironment, int aStackTop, ConsPointer aExpression, ConsPointer[] arguments) throws Exception {

        if (arguments[iVarIndex].getCons() == null) {
            arguments[iVarIndex].setCons(aExpression.getCons());
            //Set var iVarIndex.
            return true;
        } else {
            if (Utility.equals(aEnvironment, aStackTop, aExpression, arguments[iVarIndex])) {
                //Matched var iVarIndex.
                return true;
            }
            return false;
        }

    }//end method.


    public String getType() {
        return "Variable";
    }


    @Override
    public String toString()
    {
        return "";
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/ParametersPatternMatcher.java0000644000175000017500000003622011420717703034004 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.lisp.cons.Cons;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
//import org.mathpiper.lisp.AtomCons;
import org.mathpiper.lisp.Environment;
//import org.mathpiper.lisp.SublistCons;
import java.util.*;
import org.mathpiper.builtin.BigNumber;

/**
 *ParametersPatternMatcher matching code.
 *
 *General idea: have a class that can match function parameters
 *to a pattern, check for predicates on the arguments, and return
 *whether there was a match.
 *
 *First the pattern is mapped onto the arguments. Then local variables
 *are set. Then the predicates are called. If they all return true,
 *Then the pattern matches, and the locals can stay (the body is expected
 *to use these variables).
 *
 *Class that matches function arguments to a pattern.
 *This class (specifically, the matches() member function) can match
 *function parameters to a pattern, check for predicates on the
 *arguments, and return whether there was a match.
 */
public class ParametersPatternMatcher {
    //List of parameter matchers, one for every parameter.
    protected List iParamMatchers = new ArrayList();

    // List of variables appearing in the pattern.
    protected List iVariables = new ArrayList();

    // List of predicates which need to be true for a match.
    protected List iPredicates = new ArrayList();


    /**
     *Constructor.
     *@param aEnvironment the underlying Lisp environment
     *@param aPattern Lisp expression containing the pattern
     *@param aPostPredicate Lisp expression containing the postpredicate
     *
     *The function makeParameterMatcher() is called for every argument
     *in aPattern, and the resulting pattern matchers are
     *collected in iParamMatchers. Additionally, aPostPredicate
     *is copied, and the copy is added to iPredicates.
     */
    public ParametersPatternMatcher(Environment aEnvironment, int aStackTop, ConsPointer aPattern, ConsPointer aPostPredicate) throws Exception {

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, aPattern);

        while (consTraverser.getCons() != null) {

            PatternParameterMatcher matcher = makeParameterMatcher(aEnvironment, aStackTop, consTraverser.getCons());

            LispError.lispAssert(matcher != null, aEnvironment, aStackTop);

            iParamMatchers.add(matcher);

            consTraverser.goNext(aStackTop);
        }//end while.

        ConsPointer postPredicatesPointer = new ConsPointer();

        postPredicatesPointer.setCons(aPostPredicate.getCons());

        iPredicates.add(postPredicatesPointer);

        
    }//end method.


    /*
    Try to match the pattern against aArguments.
    First, every argument in aArguments is matched against the
    corresponding PatternParameterMatcher in iParamMatches. If any
    match fails, matches() returns false. Otherwise, a temporary
    LispLocalFrame is constructed, then setPatternVariables() and
    checkPredicates() are called, and then the LispLocalFrame is
    immediately deleted. If checkPredicates() returns false, this
    function also returns false. Otherwise, setPatternVariables()
    is called again, but now in the current LispLocalFrame, and
    this function returns true.
     */
    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer aArguments) throws Exception {
        int i;

        ConsPointer[] argumentsPointer = null;
        if (iVariables.size() > 0) {
            argumentsPointer = new ConsPointer[iVariables.size()];
            for (i = 0; i < iVariables.size(); i++) {
                argumentsPointer[i] = new ConsPointer();
            }

        }
        ConsTraverser argumentsTraverser = new ConsTraverser(aEnvironment, aArguments);

        for (i = 0; i < iParamMatchers.size(); i++) {
            if (argumentsTraverser.getCons() == null) {
                return false;
            }
            ConsPointer argumentsPointer2 = argumentsTraverser.getPointer();
            if (argumentsPointer2 == null) {
                return false;
            }
            if (!((PatternParameterMatcher) iParamMatchers.get(i)).argumentMatches(aEnvironment, aStackTop, argumentsPointer2, argumentsPointer)) {
                return false;
            }
            argumentsTraverser.goNext(aStackTop);
        }
        if (argumentsTraverser.getCons() != null) {
            return false;
        }

        {
            //Set the local variables.
            aEnvironment.pushLocalFrame(false, "Pattern");
            try {
                setPatternVariables(aEnvironment, argumentsPointer, aStackTop);

                //Do the predicates
                if (!checkPredicates(aEnvironment, aStackTop)) {
                    return false;
                }
            } catch (Exception e) {
                throw e;
            } finally {
                aEnvironment.popLocalFrame(aStackTop);
            }
        }

        // setCons the local variables for sure now
        setPatternVariables(aEnvironment, argumentsPointer, aStackTop);

        return true;
    }


    /**
     *Try to match the pattern against aArguments.
     *This function does the same as matches(Environment, ConsPointer),
     *but differs in the type of the arguments.
     */
    public boolean matches(Environment aEnvironment, int aStackTop, ConsPointer[] aArguments) throws Exception {
        int i;

        ConsPointer[] arguments = null;
        if (iVariables.size() > 0) {
            arguments = new ConsPointer[iVariables.size()];
        }
        for (i = 0; i < iVariables.size(); i++) {
            arguments[i] = new ConsPointer();
        }



        for (i = 0; i < iParamMatchers.size(); i++) {
            LispError.check(i < aArguments.length, "Listed function definitions need at least two parameters.", "INTERNAL", aStackTop, aEnvironment);
            PatternParameterMatcher patternParameter = (PatternParameterMatcher) iParamMatchers.get(i);
            ConsPointer argument = aArguments[i];
            if (!patternParameter.argumentMatches(aEnvironment, aStackTop, argument, arguments)) {
                return false;
            }
        }

        {
            //Set the local variables.
            aEnvironment.pushLocalFrame(false, "Pattern");
            try {
                setPatternVariables(aEnvironment, arguments, aStackTop);

                //Check the predicates.
                if (!checkPredicates(aEnvironment, aStackTop)) {
                    return false;
                }
            } catch (Exception e) {
                throw e;
            } finally {
                aEnvironment.popLocalFrame(aStackTop);
            }
        }

        // Set the local variables for sure now.
        setPatternVariables(aEnvironment, arguments, aStackTop);

        return true;
    }


    /*
    Construct a pattern matcher out of a Lisp expression.
    The result of this function depends on the value of aPattern:
    - If aPattern is a number, the corresponding NumberPatternParameterMatcher is
    constructed and returned.
    - If aPattern is an atom, the corresponding AtomCons is
    constructed and returned.
    - If aPattern is a list of the form ( _var ),
    where var is an atom, lookUp() is called on var. Then
    the correspoding VariablePatternParameterMatcher is constructed and returned.
    - If aPattern is a list of the form ( var_expr ),
    where var is an atom, lookUp() is called on var. Then,
    expr is appended to #iPredicates. Finally, the
    correspoding VariablePatternParameterMatcher is constructed and returned.
    - If aPattern is a list of another form, this function
    calls itself on any of the entries in this list. The
    resulting PatternParameterMatcher objects are collected in a
    SublistCons, which is returned.
    - Otherwise, this function returns #null.
     */
    protected PatternParameterMatcher makeParameterMatcher(Environment aEnvironment, int aStackTop, Cons aPattern) throws Exception {

        if (aPattern == null) {
            return null;
        }


        //Check for a number pattern.
        if (aPattern.getNumber(aEnvironment.getPrecision(), aEnvironment) != null) {
            return new NumberPatternParameterMatcher((BigNumber) aPattern.getNumber(aEnvironment.getPrecision(), aEnvironment));
        }


        //Check for an atom pattern.
        if (aPattern.car() instanceof String) {
            return new AtomPatternParameterMatcher((String) aPattern.car());
        }


        // Else, it must be a sublist pattern.
        if (aPattern.car() instanceof ConsPointer) {

            // See if it is a variable template:
            ConsPointer sublist = (ConsPointer) aPattern.car();
            //LispError.lispAssert(sublist != null);

            int num = Utility.listLength(aEnvironment, aStackTop, sublist);

            // variable matcher here...
            if (num > 1) {
                Cons head = sublist.getCons();

                //Handle _ prefix or suffix on a pattern variables.
                if (((String) head.car()) == aEnvironment.getTokenHash().lookUp("_")) {
                    Cons second = head.cdr().getCons();
                    if (second.car() instanceof String) {
                        int index = lookUp((String) second.car());


                        if (num > 2) {
                            //Handle a pattern variable which has a predicate (like var_PredicateFunction).
                            ConsPointer third = new ConsPointer();

                            Cons predicate = second.cdr().getCons();
                            if ((predicate.car() instanceof ConsPointer)) {
                                Utility.flatCopy(aEnvironment, aStackTop, third, (ConsPointer) predicate.car());
                            } else {
                                third.setCons(second.cdr().getCons().copy(aEnvironment, false));
                            }

                            String str = (String) second.car();
                            Cons last = third.getCons();
                            while (last.cdr().getCons() != null) {
                                last = last.cdr().getCons();
                            }

                            last.cdr().setCons(org.mathpiper.lisp.cons.AtomCons.getInstance(aEnvironment, aStackTop, str));

                            ConsPointer newPredicate = new ConsPointer();
                            newPredicate.setCons(org.mathpiper.lisp.cons.SublistCons.getInstance(aEnvironment, third.getCons()));

                            iPredicates.add(newPredicate);
                        }//end if.

                        return new VariablePatternParameterMatcher(index);
                    }
                }
            }

            PatternParameterMatcher[] matchers = new PatternParameterMatcher[num];

            int i;
            ConsTraverser consTraverser = new ConsTraverser(aEnvironment, sublist);
            for (i = 0; i < num; i++) {
                matchers[i] = makeParameterMatcher(aEnvironment, aStackTop, consTraverser.getCons());
                LispError.lispAssert(matchers[i] != null, aEnvironment, aStackTop);
                consTraverser.goNext(aStackTop);
            }
            return new SublistPatternParameterMatcher(matchers, num);
        }

        return null;

    }//end method.


    /*
     *Look up a variable name in iVariables.
     *Returns index in iVariables array where aVariable
     *appears.  If aVariable is not in iVariables, it is added.
     */
    protected int lookUp(String aVariable) {
        int i;
        for (i = 0; i < iVariables.size(); i++) {
            if (iVariables.get(i) == aVariable) {
                return i;
            }
        }
        iVariables.add(aVariable);
        return iVariables.size() - 1;
    }


    /**
     *Set local variables corresponding to the pattern variables.
     *This function goes through the #iVariables array. A local
     *variable is made for every entry in the array, and the
     *corresponding argument is assigned to it.
     */
    protected void setPatternVariables(Environment aEnvironment, ConsPointer[] arguments, int aStackTop) throws Exception {
        int i;
        for (i = 0; i < iVariables.size(); i++) {
            //Set the variable to the new value
            aEnvironment.newLocalVariable((String) iVariables.get(i), arguments[i].getCons(), aStackTop);
        }
    }


    /**
     *Check whether all predicates are true.
     *This function goes through all predicates in iPredicates and
     *evaluates them. It returns false if at least one
     *of these results IsFalse(). An error is raised if any result
     *that is neither IsTrue() nor IsFalse().
     */
    protected boolean checkPredicates(Environment aEnvironment, int aStackTop) throws Exception {
        int i;
        for (i = 0; i < iPredicates.size(); i++) {

            ConsPointer resultPredicate = new ConsPointer();

            aEnvironment.iLispExpressionEvaluator.evaluate(aEnvironment, aStackTop, resultPredicate, ((ConsPointer) iPredicates.get(i)));

            if (Utility.isFalse(aEnvironment, resultPredicate, aStackTop)) {
                return false;
            }


            // If the result is not False, it should be True, else probably something is wrong (the expression returned unevaluated)
            boolean isTrue = Utility.isTrue(aEnvironment, resultPredicate, aStackTop);
            if (!isTrue) {
                //TODO this is probably not the right way to generate an error, should we perhaps do a full throw new MathPiperException here?
                String strout;
                aEnvironment.write("The predicate\n\t");
                strout = Utility.printMathPiperExpression(aStackTop, ((ConsPointer) iPredicates.get(i)), aEnvironment, 60);
                aEnvironment.write(strout);
                aEnvironment.write("\nevaluated to\n\t");
                strout = Utility.printMathPiperExpression(aStackTop, resultPredicate, aEnvironment, 60);
                aEnvironment.write(strout);
                aEnvironment.write("\n");

                LispError.check(aEnvironment, aStackTop, isTrue, LispError.NON_BOOLEAN_PREDICATE_IN_PATTERN, "INTERNAL");
            }
        }
        return true;
    }


    public List getParameterMatchers() {
        return iParamMatchers;
    }


    public List getPredicates() {
        return iPredicates;
    }


    public List getVariables() {
        return iVariables;
    }

}

././@LongLink0000000000000000000000000000015300000000000011564 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/SublistPatternParameterMatcher.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/SublistPatternParameterMatche0000644000175000017500000000565211506531763034077 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Environment;

/// Class for matching against a list of PatternParameterMatcher objects.
public class SublistPatternParameterMatcher extends PatternParameterMatcher {

    protected PatternParameterMatcher[] iMatchers;

    protected int iNumberOfMatchers;


    public SublistPatternParameterMatcher(PatternParameterMatcher[] aMatchers, int aNrMatchers) {
        iMatchers = aMatchers;
        iNumberOfMatchers = aNrMatchers;
    }


    public boolean argumentMatches(Environment aEnvironment, int aStackTop, ConsPointer aExpression, ConsPointer[] arguments) throws Exception {

        if (!(aExpression.car() instanceof ConsPointer)) {
            return false;
        }

        ConsTraverser consTraverser = new ConsTraverser(aEnvironment, aExpression);

        consTraverser.goSub(aStackTop);

        for (int i = 0; i < iNumberOfMatchers; i++) {

            ConsPointer consPointer = consTraverser.getPointer();

            if (consPointer == null) {
                return false;
            }

            if (consTraverser.getCons() == null) {
                return false;
            }

            if (!iMatchers[i].argumentMatches(aEnvironment, aStackTop, consPointer, arguments)) {
                return false;
            }

            consTraverser.goNext(aStackTop);
        }

        if (consTraverser.getCons() != null) {
            return false;
        }
        
        return true;
    }


    public String getType()
    {
        return "Sublist";
    }


    @Override
    public String toString() {
        StringBuilder stringBuilder = new StringBuilder();

        for(int x = 0; x < iMatchers.length; x++)
        {
            PatternParameterMatcher matcher = iMatchers[x];

            stringBuilder.append(matcher.getType());
            
            stringBuilder.append(": ");
            
            stringBuilder.append(matcher.toString());

            stringBuilder.append(", ");
            
        }

        return stringBuilder.toString();
    }

}
././@LongLink0000000000000000000000000000015200000000000011563 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/NumberPatternParameterMatcher.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/NumberPatternParameterMatcher0000644000175000017500000000342711506531763034062 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.builtin.BigNumber;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;

/// Class for matching an expression to a given number.
public class NumberPatternParameterMatcher extends PatternParameterMatcher {

    protected BigNumber iNumber;


    public NumberPatternParameterMatcher(BigNumber aNumber) {
        iNumber = aNumber;
    }


    public boolean argumentMatches(Environment aEnvironment, int aStackTop, ConsPointer aExpression, ConsPointer[] arguments) throws Exception {

        BigNumber bigNumber = (BigNumber) aExpression.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment);
        
        if (bigNumber != null) {
            return iNumber.equals(bigNumber);
        }
        
        return false;
    }


    public String getType() {
        return "Number";
    }


    @Override
    public String toString()
    {
        return this.iNumber.toString();
    }

}
././@LongLink0000000000000000000000000000015000000000000011561 Lustar  rootrootmathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/AtomPatternParameterMatcher.javamathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/parametermatchers/AtomPatternParameterMatcher.j0000644000175000017500000000421011506531763033751 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.parametermatchers;

import org.mathpiper.builtin.BigNumber;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.cons.NumberCons;

//Class for matching an expression to a given atom.
public class AtomPatternParameterMatcher extends PatternParameterMatcher {

    protected String iString;


    public AtomPatternParameterMatcher(String aString) {
        iString = aString;
    }


    public boolean argumentMatches(Environment aEnvironment, int aStackTop, ConsPointer aExpression, ConsPointer[] arguments) throws Exception {

        // If it is a floating point, don't even bother comparing
        if (aExpression.getCons() != null) {
            try {
                if (aExpression.getCons().getNumber(aEnvironment.getPrecision(), aEnvironment) != null) {
                    if (!((BigNumber) ((NumberCons) aExpression.getCons()).getNumber(aEnvironment.getPrecision(), aEnvironment)).isInteger()) {
                        return false;
                    }
                }
            } catch (NumberFormatException e) {
                return false;
            }
        }

        return (iString == aExpression.car());
    }


    public String getType() {
        return "Atom";
    }

    @Override
    public String toString()
    {
        return iString;
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/printers/0000755000175000017500000000000011722677325024342 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/printers/MathPiperPrinter.java0000644000175000017500000003236511563005657030447 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.printers;

import org.mathpiper.builtin.BuiltinContainer;
import org.mathpiper.io.MathPiperOutputStream;
import org.mathpiper.lisp.Utility;
import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.LispError;
import org.mathpiper.lisp.cons.ConsTraverser;
import org.mathpiper.lisp.Environment;
import org.mathpiper.lisp.tokenizers.MathPiperTokenizer;
import org.mathpiper.lisp.Operator;
import org.mathpiper.lisp.collections.OperatorMap;

public class MathPiperPrinter extends LispPrinter {

    StringBuilder spaces = new StringBuilder();
    public static int KMaxPrecedence = 60000;
    OperatorMap iPrefixOperators;
    OperatorMap iInfixOperators;
    OperatorMap iPostfixOperators;
    OperatorMap iBodiedOperators;
    char iPrevLastChar;
    Environment iCurrentEnvironment;

    //private List visitedLists = new ArrayList();
    public MathPiperPrinter(OperatorMap aPrefixOperators,
            OperatorMap aInfixOperators,
            OperatorMap aPostfixOperators,
            OperatorMap aBodiedOperators) {
        iPrefixOperators = aPrefixOperators;
        iInfixOperators = aInfixOperators;
        iPostfixOperators = aPostfixOperators;
        iBodiedOperators = aBodiedOperators;
        iPrevLastChar = 0;
    }

    @Override
    public void print(int aStackTop, ConsPointer aExpression,  MathPiperOutputStream aOutput, Environment aEnvironment) throws Exception {
        iCurrentEnvironment = aEnvironment;


        Print(aEnvironment, aStackTop, aExpression, aOutput, KMaxPrecedence);

        //visitedLists.clear();
    }

    @Override
    public void rememberLastChar(char aChar) {
        iPrevLastChar = aChar;
    }

    void Print(Environment aEnvironment, int aStackTop, ConsPointer aExpression, MathPiperOutputStream aOutput, int iPrecedence) throws Exception {

        LispError.lispAssert(aExpression.getCons() != null, aEnvironment, aStackTop);

        String functionOrOperatorName;
        if (aExpression.car() instanceof String) {
            functionOrOperatorName = (String) aExpression.car();
            boolean bracket = false;
            if (iPrecedence < KMaxPrecedence &&
                    functionOrOperatorName.charAt(0) == '-' &&
                    (MathPiperTokenizer.isDigit(functionOrOperatorName.charAt(1)) || functionOrOperatorName.charAt(1) == '.')) {
                //Code for (-1)/2 .
                bracket = true;
            }
            if (bracket) {
                WriteToken(aOutput, "(");
            }
            WriteToken(aOutput, functionOrOperatorName);
            if (bracket) {
                WriteToken(aOutput, ")");
            }
            return;
        }

        if (aExpression.car() instanceof BuiltinContainer) {
            //TODO display genericclass
            WriteToken(aOutput, ((BuiltinContainer) aExpression.car()).getObject().getClass().toString());
            return;
        }

        ConsPointer subList = (ConsPointer) aExpression.car();

        LispError.check(aEnvironment, aStackTop, subList != null, LispError.UNPRINTABLE_TOKEN, "INTERNAL");

        if (subList.getCons() == null) {
            WriteToken(aOutput, "( )");
        } else {
            int length = Utility.listLength(aEnvironment, aStackTop, subList);
            functionOrOperatorName = (String) subList.car();
            Operator prefix = (Operator) iPrefixOperators.lookUp(functionOrOperatorName);
            Operator infix = (Operator) iInfixOperators.lookUp(functionOrOperatorName);
            Operator postfix = (Operator) iPostfixOperators.lookUp(functionOrOperatorName);
            Operator bodied = (Operator) iBodiedOperators.lookUp(functionOrOperatorName);
            Operator operator = null;

            if (length != 2) {
                prefix = null;
                postfix = null;
            }
            if (length != 3) {
                infix = null;
            }
            if (prefix != null) {
                operator = prefix;
            }
            if (postfix != null) {
                operator = postfix;
            }
            if (infix != null) {
                operator = infix;
            }

            if (operator != null) {
                ConsPointer left = null;
                ConsPointer right = null;

                if (prefix != null) {
                    right = subList.cdr();
                } else if (infix != null) {
                    left = subList.cdr();
                    right = subList.cdr().cdr();
                } else if (postfix != null) {
                    left = subList.cdr();
                }

                if (iPrecedence < operator.iPrecedence) {
                    WriteToken(aOutput, "(");
                } else {
                    //Vladimir?    aOutput.write(" ");
                }

                if (left != null) {

                    if (functionOrOperatorName.equals("/") && Utility.functionType(left).equals("/")) {
                        //Code for In> Hold((3/2)/(1/2)) Result> (3/2)/(1/2) .
                        WriteToken(aOutput, "(");
                    }//end if.

                    Print(aEnvironment, aStackTop, left, aOutput, operator.iLeftPrecedence);

                    if (functionOrOperatorName.equals("/") && Utility.functionType(left).equals("/")) {
                        //Code for In> Hold((3/2)/(1/2)) Result> (3/2)/(1/2) .
                        WriteToken(aOutput, ")");
                    }//end if.
                }

                boolean addSpaceAroundInfixOperator = 
                    left != null && right != null && // is this really an infix operator?
                    functionOrOperatorName.length() > 1;// no spaces around +,-,*,/ etc

                if (addSpaceAroundInfixOperator)
                    WriteToken(aOutput, "  ");

                WriteToken(aOutput, functionOrOperatorName);

                if (addSpaceAroundInfixOperator)
                    WriteToken(aOutput, "  ");

                if (right != null) {

                    if (functionOrOperatorName.equals("/") && Utility.functionType(right).equals("/")) {
                        //Code for In> Hold((3/2)/(1/2)) Result> (3/2)/(1/2) .
                        WriteToken(aOutput, "(");
                    }//end if.

                    if (functionOrOperatorName.equals("Not")) {//Todo:tk:perhaps a more general way should be found to place a space after a prefix operator.
                        WriteToken(aOutput, " ");
                    }//end if.

                    Print(aEnvironment, aStackTop, right, aOutput, operator.iRightPrecedence);

                    if (functionOrOperatorName.equals("/") && Utility.functionType(right).equals("/")) {
                        //Code for In> Hold((3/2)/(1/2)) Result> (3/2)/(1/2) .
                        WriteToken(aOutput, ")");
                    }//end if.
                }

                if (iPrecedence < operator.iPrecedence) {
                    WriteToken(aOutput, ")");
                }

            } else {

                ConsTraverser consTraverser = new ConsTraverser(aEnvironment, subList.cdr());

               /*
                   Removing complex number output notation formatting until the problem with Solve(x^3 - 2*x - 7 == 0,x) is resolved.
                
                   if (functionOrOperatorName == iCurrentEnvironment.iComplexAtom.car()) {

                    Print(consTraverser.getPointer(), aOutput, KMaxPrecedence);

                    consTraverser.goNext(); //Point to second argument.

                    if (!consTraverser.car().toString().startsWith("-")) {
                        WriteToken(aOutput, "+");
                    }

                    Print(consTraverser.getPointer(), aOutput, KMaxPrecedence);

                    WriteToken(aOutput, "*I");

                } else */
                if (functionOrOperatorName == iCurrentEnvironment.iListAtom.car()) {

                    /*
                    Cons atomCons = (Cons) subList.getCons();
                    if (visitedLists.contains(atomCons)) {
                    WriteToken(aOutput, "{CYCLE_LIST}");
                    return;

                    } else {

                    visitedLists.add(atomCons);*/

                    WriteToken(aOutput, "{");

                    while (consTraverser.getCons() != null) {
                        Print(aEnvironment, aStackTop, consTraverser.getPointer(), aOutput, KMaxPrecedence);
                        consTraverser.goNext(aStackTop);
                        if (consTraverser.getCons() != null) {
                            WriteToken(aOutput, ",");
                        }
                    }//end while.

                    WriteToken(aOutput, "}");

                    // }//end else.
                } else if (functionOrOperatorName == iCurrentEnvironment.iProgAtom.car()) // Program block brackets.
                {
                    WriteToken(aOutput, "[");
                    aOutput.write("\n");
                    spaces.append("    ");

                    while (consTraverser.getCons() != null) {
                        aOutput.write(spaces.toString());
                        Print(aEnvironment, aStackTop, consTraverser.getPointer(), aOutput, KMaxPrecedence);
                        consTraverser.goNext(aStackTop);
                        WriteToken(aOutput, ";");
                        aOutput.write("\n");
                    }

                    WriteToken(aOutput, "]");
                    aOutput.write("\n");
                    spaces.delete(0, 4);
                } else if (functionOrOperatorName == iCurrentEnvironment.iNthAtom.car()) {
                    Print(aEnvironment, aStackTop, consTraverser.getPointer(), aOutput, 0);
                    consTraverser.goNext(aStackTop);
                    WriteToken(aOutput, "[");
                    Print(aEnvironment, aStackTop,  consTraverser.getPointer(), aOutput, KMaxPrecedence);
                    WriteToken(aOutput, "]");
                } else {
                    boolean bracket = false;
                    if (bodied != null) {
                        //printf("%d > %d\n",iPrecedence, bodied.iPrecedence);
                        if (iPrecedence < bodied.iPrecedence) {
                            bracket = true;
                        }
                    }
                    if (bracket) {
                        WriteToken(aOutput, "(");
                    }
                    if (functionOrOperatorName != null) {
                        WriteToken(aOutput, functionOrOperatorName); //Print function name.
                    } else {
                        Print(aEnvironment, aStackTop, subList, aOutput, 0);
                    }
                    WriteToken(aOutput, "("); //Print the opening parenthese of the function argument list.

                    ConsTraverser counter = new ConsTraverser(aEnvironment, consTraverser.getPointer());
                    int nr = 0;

                    while (counter.getCons() != null) { //Count arguments.
                        counter.goNext(aStackTop);
                        nr++;
                    }

                    if (bodied != null) {
                        nr--;
                    }
                    while (nr-- != 0) {
                        Print(aEnvironment, aStackTop, consTraverser.getPointer(), aOutput, KMaxPrecedence); //Print argument.

                        consTraverser.goNext(aStackTop);

                        if (nr != 0) {
                            WriteToken(aOutput, ","); //Print the comma which is between arguments.
                        }
                    }//end while.

                    WriteToken(aOutput, ")");

                    if (consTraverser.getCons() != null) {
                        Print(aEnvironment, aStackTop, consTraverser.getPointer(), aOutput, bodied.iPrecedence);
                    }

                    if (bracket) {
                        WriteToken(aOutput, ")"); //Print the closing parenthese of the function argument list.
                    }
                }
            }
        }//end sublist if.
    }

    void WriteToken(MathPiperOutputStream aOutput, String aString) throws Exception {
        /*if (MathPiperTokenizer.isAlNum(iPrevLastChar) && (MathPiperTokenizer.isAlNum(aString.charAt(0)) || aString.charAt(0)=='_'))
        {
        aOutput.write(" ");
        }
        else if (MathPiperTokenizer.isSymbolic(iPrevLastChar) && MathPiperTokenizer.isSymbolic(aString.charAt(0)))
        {
        aOutput.write(" ");
        }*/
        aOutput.write(aString);
        rememberLastChar(aString.charAt(aString.length() - 1));
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/printers/LispPrinter.java0000644000175000017500000000617611506531763027465 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.printers;

import org.mathpiper.lisp.cons.ConsPointer;
import org.mathpiper.lisp.*;
import org.mathpiper.io.MathPiperOutputStream;

public class LispPrinter {

    //private List visitedLists = new ArrayList();
    public void print(int aStackTop, ConsPointer aExpression, MathPiperOutputStream aOutput, Environment aEnvironment) throws Exception {
        printExpression(aExpression, aOutput, aEnvironment, 0);

        //visitedLists.clear();
    }


    public void rememberLastChar(char aChar) {
    }


    void printExpression(ConsPointer aExpression, MathPiperOutputStream aOutput, Environment aEnvironment, int aDepth /* =0 */) throws Exception {
        ConsPointer consWalker = new ConsPointer();
        consWalker.setCons(aExpression.getCons());
        int item = 0;

        while (consWalker.getCons() != null) {

            if (consWalker.car() instanceof String) {
                String string = (String) consWalker.car();
                aOutput.write(string);
                aOutput.putChar(' ');
            } // else print "(", print sublist, and print ")"
            else if (consWalker.car() instanceof ConsPointer) {
                if (item != 0) {
                    indent(aOutput, aDepth + 1);
                }

                /*
                Cons atomCons = (Cons) consWalker.getCons();
                if (visitedLists.contains(atomCons)) {
                aOutput.write("(CYCLE_LIST)");

                } else {
                visitedLists.add(atomCons);*/

                if (item != 0) {
                    indent(aOutput, aDepth + 1);
                }
                aOutput.write("(");
                printExpression(((ConsPointer) consWalker.car()), aOutput, aEnvironment, aDepth + 1);
                aOutput.write(")");
                item = 0;
                //}


            } else {
                aOutput.write("[BuiltinObject]");
            }
            consWalker = (consWalker.cdr()); // print rest element
            item++;
        }//end while.

    }//end method.


    void indent(MathPiperOutputStream aOutput, int aDepth) throws Exception {
        aOutput.write("\n");
        int i;
        for (i = aDepth; i > 0; i--) {
            aOutput.write("  ");
        }
    }

};
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/collections/0000755000175000017500000000000011722677326025013 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/collections/TokenMap.java0000644000175000017500000000431311331405625027360 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.collections;

public class TokenMap extends MathPiperMap
{

   // java.util.Hashtable iMap = new java.util.Hashtable();


    /**
     * If the string is not in the table yet then insert it.
     * @param aString
     * @return the string.
     */
    public Object lookUp(String aString)
    {
        if (!iMap.containsKey(aString))
        {
            iMap.put(aString, aString);
        }

        return iMap.get(aString);
    }

   /**
     * If the string is not in the table yet then place double quotes
    * arount it and insert it.
     * @param aString
     * @return the string.
     */
    public String lookUpStringify(String aString)
    {
        aString = "\"" + aString + "\"";
        if (!iMap.containsKey(aString))
        {
            iMap.put(aString, aString);
        }
        
        return (String) iMap.get(aString);
        
    }

   /**
     * If the string is not in the table yet then remove its 
    * enclosing double quotes and insert it.
     * @param aString
     * @return the string.
     */
    public String lookUpUnStringify(String aString)
    {
        aString = aString.substring(1, aString.length() - 1);
        if (!iMap.containsKey(aString))
        {
            iMap.put(aString, aString);
        }

        return (String) iMap.get(aString);
        
    }

    // GarbageCollect
    public void garbageCollect()
    {
        //TODO FIXME
    }
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/collections/OperatorMap.java0000644000175000017500000000401711332771351030077 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.lisp.collections;

import org.mathpiper.lisp.*;


public class OperatorMap extends MathPiperMap // 
{
	Environment iEnvironment;

        public OperatorMap(Environment aEnvironment)
        {
            iEnvironment = aEnvironment;
        }

	public void setOperator(int aPrecedence,String aString)
	{
		Operator op = new Operator(aPrecedence);
		setAssociation(op, aString);
	}
	
	public void setRightAssociative(int aStackTop, String aString) throws Exception
	{
		Operator op = (Operator)lookUp(aString);
		LispError.check(iEnvironment, aStackTop, op != null,LispError.NOT_AN_INFIX_OPERATOR, "INTERNAL");
		op.setRightAssociative();
	}
	
	public void setLeftPrecedence(int aStackTop, String aString,int aPrecedence) throws Exception
	{
		Operator op = (Operator)lookUp(aString);
		LispError.check(iEnvironment, aStackTop, op != null,LispError.NOT_AN_INFIX_OPERATOR, "INTERNAL");
		op.setLeftPrecedence(aPrecedence);
	}
	
	public void setRightPrecedence(int aStackTop, String aString,int aPrecedence) throws Exception
	{
		Operator op = (Operator)lookUp(aString);
		LispError.check(iEnvironment, aStackTop, op != null,LispError.NOT_AN_INFIX_OPERATOR, "INTERNAL");
		op.setRightPrecedence(aPrecedence);
	}
	
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/collections/MathPiperMap.java0000644000175000017500000000537511331405625030202 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.collections;

import java.util.Collections;

/** MathPiperMap allows you to associate arbitrary
 * information with a string in the above hash table. You can
 * specify what type of information to link to the string, and
 * this class then stores that information for a string. It is
 * in a sense a way to extend the string object without modifying
 * the string class itself. This class does not own the strings it
 * points to, but instead relies on the fact that the strings
 * are maintained in a hash table (like LispHashTable above).
 */
public class MathPiperMap
{
    //java.util.Hashtable iMap = new java.util.Hashtable();
    java.util.Map iMap = Collections.synchronizedMap(new java.util.HashMap());

    /**
     * Find the data associated to \a aString.
     * If \a aString is not stored in the hash table, this function
     * returns #NULL.
     * 
     * @param aString
     * @return the object which is associated with the key or null if there is
     * no object associated with the key.
     */
    public Object lookUp(String aString)
    {
        //if (iMap.containsKey(aString))
        //	return iMap.get(aString);
        //return null;
        return iMap.get(aString);
    }

    /**
     * Add an association to the hash table.
     *  If aString is already stored in the hash table, its
     * association is changed to aData. Otherwise, a new
     * association is added.
     * 
     * @param aData
     * @param aString
     */
    public void setAssociation(Object aData, String aString)
    {
        //if (iMap.containsKey(aString))
        //	iMap.remove(aString);

        iMap.put(aString, aData);
    }


    /**
     * Delete an association from the hash table.
     * 
     * @param aString
     */
    public void release(String aString)
    {
        //if (iMap.containsKey(aString))
        //iMap.remove(aString);
        iMap.remove(aString);
    }


    public java.util.Map getMap()
    {
        return iMap;
    }
}

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/collections/DefFileMap.java0000644000175000017500000000240111331405625027572 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:

package org.mathpiper.lisp.collections;

import org.mathpiper.lisp.DefFile;


public class DefFileMap extends MathPiperMap // 
{
	public DefFile getFile(String aFileName)
	{
		// Create a new entry
		DefFile file = (DefFile)lookUp(aFileName);
		if (file == null)
		{
			DefFile newfile = new DefFile(aFileName);
			// Add the new entry to the hash table
			setAssociation(newfile, aFileName);
			file = (DefFile)lookUp(aFileName);
		}
		return file;
	}
}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/tokenizers/0000755000175000017500000000000011722677325024671 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/tokenizers/XmlTokenizer.java0000644000175000017500000000463111506531763030166 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */
//}}}
// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.tokenizers;

import org.mathpiper.lisp.collections.TokenMap;
import org.mathpiper.lisp.LispError;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.lisp.Environment;

public class XmlTokenizer
        extends MathPiperTokenizer {

    /// NextToken returns a string representing the next token,
    /// or an empty list.
    @Override
    public String nextToken(Environment aEnvironment, int aStackTop, MathPiperInputStream aInput, TokenMap aHashTable)
            throws Exception {

        char c;
        int firstpos = 0;

        if (aInput.endOfStream()) {
            return (String) aHashTable.lookUp(aInput.startPtr().substring(firstpos, aInput.position()));
        }

        //skipping spaces
        while (IsSpace(aInput.peek())) {
            aInput.next();
        }

        firstpos = aInput.position();
        c = aInput.next();

        if (c == '<') {

            while (c != '>') {
                c = aInput.next();
                LispError.check(aEnvironment, aStackTop, !aInput.endOfStream(), LispError.COMMENT_TO_END_OF_FILE, "INTERNAL");
            }
        } else {

            while (aInput.peek() != '<' && !aInput.endOfStream()) {
                c = aInput.next();
            }
        }

        return (String) aHashTable.lookUp(aInput.startPtr().substring(firstpos, aInput.position()));
    }


    private static boolean IsSpace(int c) {

        switch (c) {

            case 0x20:
            case 0x0D:
            case 0x0A:
            case 0x09:
                return true;

            default:
                return false;
        }
    }

}
mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/tokenizers/MathPiperTokenizer.java0000644000175000017500000002125011506531763031313 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.tokenizers;

import org.mathpiper.lisp.collections.TokenMap;
import org.mathpiper.io.MathPiperInputStream;
import org.mathpiper.builtin.BigNumber;
import org.mathpiper.lisp.*;


public class MathPiperTokenizer {

    static String symbolics = "~`!@#$^&*-=+:<>?/\\|";
    //static String unicodeVariableChars = "αβγ";
    String iToken; //Can be used as a token container.

    /// NextToken returns a string representing the next token,
    /// or an empty list.
    public String nextToken(Environment aEnvironment, int aStackTop, MathPiperInputStream aInput, TokenMap aTokenHashTable) throws Exception {
        char streamCharacter;
        int firstpos = aInput.position();

        boolean redo = true;
        while (redo) {
            redo = false;
            //REDO: //TODO FIXME
            firstpos = aInput.position();

            // End of stream: return empty string
            if (aInput.endOfStream()) {
                break;
            }

            streamCharacter = aInput.next();
            //printf("%c",c);

            //Parse brackets
            if (streamCharacter == '(') {
            } else if (streamCharacter == ')') {
            } else if (streamCharacter == '{') {
            } else if (streamCharacter == '}') {
            } else if (streamCharacter == '[') {
            } else if (streamCharacter == ']') {
            } else if (streamCharacter == ',') {
            } else if (streamCharacter == ';') {
            } else if (streamCharacter == '%') {
            } //    else if (c == '\'') {}
            else if (streamCharacter == '.' && !isDigit(aInput.peek())) {
                while (aInput.peek() == '.') {
                    aInput.next();
                }
            } // parse comments
            else if (streamCharacter == '/' && aInput.peek() == '*') {
                aInput.next(); //consume *
                while (true) {
                    while (aInput.next() != '*' && !aInput.endOfStream());
                    LispError.check(aEnvironment, aStackTop, !aInput.endOfStream(), LispError.COMMENT_TO_END_OF_FILE, "INTERNAL");
                    if (aInput.peek() == '/') {
                        aInput.next();  // consume /
                        redo = true;
                        break;
                    }
                }
                if (redo) {
                    continue;
                }
            } else if (streamCharacter == '/' && aInput.peek() == '/') {
                aInput.next(); //consume /
                while (aInput.next() != '\n' && !aInput.endOfStream());
                redo = true;
                continue;
            } // parse literal strings
            else if (streamCharacter == '\"') {
                String aResult;
                aResult = "";
                //TODO FIXME is following append char correct?
                aResult = aResult + ((char) streamCharacter);
                while (aInput.peek() != '\"') {
                    if (aInput.peek() == '\\') {
                        aInput.next();
                        LispError.check(aEnvironment, aStackTop, !aInput.endOfStream(), LispError.PARSING_INPUT, "INTERNAL");

                        /*if(! (aInput.peek() == '\"'))
                        {
                            //Leave in backslash in front of all characters except a " character.
                            aResult = aResult + "\\";
                        }*/
                    }
                    //TODO FIXME is following append char correct?
                    aResult = aResult + ((char) aInput.next());
                    LispError.check(aEnvironment, aStackTop, !aInput.endOfStream(), LispError.PARSING_INPUT, "INTERNAL");
                }
                //TODO FIXME is following append char correct?
                aResult = aResult + ((char) aInput.next()); // consume the close quote
                return (String) aTokenHashTable.lookUp(aResult);
            } //parse atoms
            else if (isAlpha(streamCharacter)) {
                while (isAlNum(aInput.peek())) {
                    aInput.next();
                }
            } else if (isSymbolic(streamCharacter)) {
                while (isSymbolic(aInput.peek())) {
                    aInput.next();
                }
            } else if (streamCharacter == '_') {
                while (aInput.peek() == '_') {
                    aInput.next();
                }
            } else if (isDigit(streamCharacter) || streamCharacter == '.') {
                while (isDigit(aInput.peek())) {
                    aInput.next();
                }
                if (aInput.peek() == '.') {
                    aInput.next();
                    while (isDigit(aInput.peek())) {
                        aInput.next();
                    }
                }
                if (BigNumber.numericSupportForMantissa()) {
                    if (aInput.peek() == 'e' || aInput.peek() == 'E') {
                        aInput.next();
                        if (aInput.peek() == '-' || aInput.peek() == '+') {
                            aInput.next();
                        }
                        while (isDigit(aInput.peek())) {
                            aInput.next();
                        }
                    }
                }
            } // Treat the char as a space.
            else {
                redo = true;
                continue;
            }
        }
        return (String) aTokenHashTable.lookUp(aInput.startPtr().substring(firstpos, aInput.position()));
    }

    public static boolean isDigit(char c) {
        return ((c >= '0' && c <= '9'));
    }

    public static boolean isAlpha(char c) {
     
       // "$", // for absolute references in the spreadsheet

        if (c >= 'a' && c <= 'z') {
            return true;
        } else if (c >= 'A' && c <= 'Z') {
            return true;
        } else if (c == '\'') {
            return true;
        } else if (c == '?') {
            return true;
        }else if (c == 0x00b7) { // middle dot (for Catalan).
            return true;
        } else if (c == 0x00b0) { // degree symbol).
            return true;
        } else if (c >= 0x00c0 && c <= 0x00d6) { //accentuated letters.
            return true;
        } else if (c >= 0x00d8 && c <= 0x01bf) {//accentuated letters.
            return true;
        } else if (c >= 0x01c4 && c <= 0x02a8) { //accentuated letters.
            return true;
        } else if (c >= 0x0391 && c <= 0x03f3) {// Greek.
            return true;
        } else if (c >= 0x0401 && c <= 0x0481) { // Cyrillic.
            return true;
        } else if (c >= 0x0490 && c <= 0x04f9) {// Cyrillic.
            return true;
        } else if (c >= 0x0531 && c <= 0x1ffc) {// a lot of signs (Arabic, accentuated, ...).
            return true;
        } else if (c >= 0x3041 && c <= 0x3357) {// Asian letters.
            return true;
        } else if (c >= 0x4e00 && c <= 0xd7a3) {// Asian letters.
            return true;
        } else if (c >= 0xf71d && c <= 0xfa2d) {// Asian letters.
            return true;
        } else if (c >= 0xfb13 && c <= 0xfdfb) {// Armenian, Hebrew, Arabic.
            return true;
        } else if (c >= 0xfe80 && c <= 0xfefc) { // Arabic.
            return true;
        } else if (c >= 0xff66 && c <= 0xff9d) {// Katakana.
            return true;
        } else if (c >= 0xffa1 && c <= 0xffdc) {// Hangul.
            return true;
        }


        return false;

    //return ( (c>='a' && c<='z') || (c>='A' && c<='Z') || (c == '\'') || unicodeVariableChars.indexOf(c) != -1);
    }

    public static boolean isAlNum(char c) {
        return (isAlpha(c) || isDigit(c));
    }

    public static boolean isSymbolic(char c) {
        return (symbolics.indexOf(c) != -1);
    }
};

mathpiper-0.81f+svn4469+dfsg3/src/org/mathpiper/lisp/tokenizers/CommonLispTokenizer.java0000644000175000017500000000751611506531763031513 0ustar  giovannigiovanni/* {{{ License.
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
 */ //}}}

// :indentSize=4:lineSeparator=\n:noTabs=false:tabSize=4:folding=explicit:collapseFolds=0:
package org.mathpiper.lisp.tokenizers;

class CommonLispTokenizer extends MathPiperTokenizer
{
/*
class CommonLispTokenizer extends LispTokenizer
{
    String NextToken(LispInput aInput, LispHashTable aHashTable)
  {
    char c;
    int firstpos;

REDO://TODO FIXME
    
    while(true)
    {
    firstpos = aInput.Position();

    // End of stream: return empty string
    if (aInput.EndOfStream())
    {
        return aHashTable.LookUpCounted(&aInput.StartPtr()[firstpos],aInput.Position()-firstpos);
    }
      //goto FINISH;

    c = aInput.Next();
    //printf("%c",c);

    //Parse brackets
    if (c == '(')      {}
    else if (c == ')') {}
    else if (c == '{') {}
    else if (c == '}') {}
    else if (c == '[') {}
    else if (c == ']') {}
    else if (c == ',') {}
    else if (c == '\'') {}
    else if (c == '%') {}
  //    else if (c == '\'') {}
    else if (c == '.' && !IsDigit(aInput.Peek()) )
    {
      while (aInput.Peek() == '.')
      {
        aInput.Next();
      }
    }
    // parse comments
    else if (c == '/' && aInput.Peek() == '*')
    {
      aInput.Next(); //consume *
FALSEALARM://TODO FIXME
      while (aInput.Next() != '*' && !aInput.EndOfStream());
      Check(!aInput.EndOfStream(),KLispErrCommentToEndOfFile);
      if (aInput.Peek() == '/')
      {
        aInput.Next();  // consume /
        goto REDO;
      }
      goto FALSEALARM;
    }
    else if (c == ';')
    {
      while (aInput.Next() != '\n' && !aInput.EndOfStream());
      goto REDO;
    }
    // parse literal strings
    else if (c == '\"')
    {
      LispString aResult;
      aResult.Resize(0);
      aResult.Append(c);
      while (aInput.Peek() != '\"')
      {
        if (aInput.Peek() == '\\')
        {
          aInput.Next();
          Check(!aInput.EndOfStream(),KLispErrParsingInput);
        }
        aResult.Append(aInput.Next());
        Check(!aInput.EndOfStream(),KLispErrParsingInput);
      }
      aResult.Append(aInput.Next()); // consume the close quote
      aResult.Append('\0');
      return aHashTable.LookUp(aResult.String());
    }
    //parse atoms
    else if (IsAlpha(c) || IsSymbolic(c))
    {
      while (IsAlNum( aInput.Peek()) || IsSymbolic( aInput.Peek()))
      {
        aInput.Next();
      }
    }
    else if (c == '_')
    {
      while (aInput.Peek() == '_')
      {
        aInput.Next();
      }
    }
    else if (IsDigit(c) || c == '.')
    {
      while (IsDigit( aInput.Peek())) aInput.Next();
      if (aInput.Peek() == '.')
      {
        aInput.Next();
        while (IsDigit( aInput.Peek())) aInput.Next();
      }
      if (NumericSupportForMantissa())
      {
        if (aInput.Peek() == 'e' || aInput.Peek() == 'E')
        {
          aInput.Next();
          if (aInput.Peek() == '-' || aInput.Peek() == '+')
            aInput.Next();
          while (IsDigit( aInput.Peek())) aInput.Next();
        }
      }
    }
    // Treat the char as a space.
    else
    {
      goto REDO;
    }

//FINISH://TODO FIXME
    return aHashTable.LookUpCounted(&aInput.StartPtr()[firstpos],aInput.Position()-firstpos);
  }
  
   */
}

mathpiper-0.81f+svn4469+dfsg3/resources/0000755000175000017500000000000011722677346020173 5ustar  giovannigiovannimathpiper-0.81f+svn4469+dfsg3/resources/MANIFEST.MF0000644000175000017500000000011411233213077021601 0ustar  giovannigiovanniMain-Class: org/mathpiper/ui/gui/consoles/Console
Class-Path: mathpiper.jar

    L/NkHw0'_[QV .}ǯ
C(wDsisKƄ/
:3@پ	Q3ʷjUP!ѯ*>p_6!ŎRW}ZOSQ
=vYBTuY#q#ݡ|׮Hv/BʡZ;?zkՍ7%y.es6t[m	ͲNWXf:ڂ3H!a=a)R"[_8~!
mkϧp&̤Hp^zbD5RFkG5a|h^ㄭڌT~VGU868d04-3cIz8Me!qg}ɗ5N3H~*ahU˧it$y(k!&}4ʕlfQYjTb8x	XWp\x*Kfrj3c
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
59 0 obj
6611
endobj
60 0 obj
1151
endobj
61 0 obj
4928
endobj
62 0 obj
532
endobj
63 0 obj
/UKDRSR+CMR12
endobj
64 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -194
/FontName 63 0 R
/ItalicAngle 0
/StemV 65
/XHeight 431
/FontBBox [ -34 -251 988 750 ]
/Flags 4
/CharSet (/comma/hyphen/zero/one/two/A/B/L/M/S/U/a/b/e/f/h/i/l/n/o/r/s/t/u/v/y/z)
/FontFile 58 0 R
>> endobj
5 0 obj <<
/Type /Font
/Subtype /Type1
/FirstChar 0
/LastChar 127
/Widths 65 0 R
/BaseFont 71 0 R
/FontDescriptor 72 0 R
>> endobj
65 0 obj
[ 576 772 720 641 615 693 668 720 668 720 668 525 499 499 749 749 250 276 459 459 459 459 459 693 406 459 668 720 459 837 942 720 250 250 459 772 459 772 720 250 354 354 459 720 250 302 250 459 459 459 459 459 459 459 459 459 459 459 250 250 250 720 433 433 720 693 654 668 707 628 602 726 693 328 471 719 576 850 693 720 628 720 680 511 668 693 693 955 693 693 563 250 459 250 459 250 250 459 511 406 511 406 276 459 511 250 276 485 250 772 511 459 511 485 354 359 354 511 485 668 485 485 406 459 917 459 459 459 ]
endobj
66 0 obj <<
/Length 67 0 R
/Length1 68 0 R
/Length2 69 0 R
/Length3 70 0 R
>>
stream
%!PS-AdobeFont-1.1: CMR17 1.0
%%CreationDate: 1991 Aug 20 16:38:24
% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
11 dict begin
/FontInfo 7 dict dup begin
/version (1.0) readonly def
/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
/FullName (CMR17) readonly def
/FamilyName (Computer Modern) readonly def
/Weight (Medium) readonly def
/ItalicAngle 0 def
/isFixedPitch false def
end readonly def
/FontName /OAFFQB+CMR17 def
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/Encoding 256 array
0 1 255 {1 index exch /.notdef put} for
dup 47 /slash put
dup 73 /I put
dup 76 /L put
dup 77 /M put
dup 79 /O put
dup 85 /U put
dup 97 /a put
dup 99 /c put
dup 101 /e put
dup 102 /f put
dup 104 /h put
dup 108 /l put
dup 110 /n put
dup 112 /p put
dup 114 /r put
dup 115 /s put
dup 116 /t put
dup 117 /u put
readonly def
/FontBBox{-33 -250 945 749}readonly def
/UniqueID 5000795 def
currentdict end
currentfile eexec
oc;j~EЪ*BgNӽؑlKq*޲Xws|QFqv`zXMyp"5O˩YŝP(DT![v67XFlU&3!Rq4wσ~j+ou_^
2nΗ%)[yi2:(o Gu^~kτ>(O/߄ۤXNߵ(ӸaXœIli-i{.%Õ`
vEa!n]8rCzi.;a.|&Lу׊@a,
|/"UZ%F	7?@^7>at%Tcq{K9a%-dSKKV$m3+8&t}2oM#
*w6`*s:82hbwC$o&I$}&3Ͻ3i	
b3?
K{\7j}8fnd
Zt4~d. (w;ZdLBarεR['`a_Btl27[rLPYm
力HI~xܧsbVܣCݜ:Zl$etب群,:S΃Å=a?tQ31%|wsD{QtGXbypuⱆ֗צ[
dbG~DBۏ
!c
l;=_\
*<n"|篆BN9&E@X(&vØ9Uw9"Y8
G0͝{FnUI$dP
킊
6yaX|@<6aəB3;;K5\ztJ/4
'{q1fDI`Vִi.k4ѓ[E_V=[/m"܏;!Z7ypT#td(oĄDpr05agF_}VuNfn4cB̢F~Wb>BQF뜮E2rc<ʚGI+iߨ8q!"DjBEy1גD
;sR8'ADUEovF!,z&? L[/.V++JAeʱ.P-qP.[a`%
syjz.*wF{+?Sy߃MmQX()	8uör:E~#;bTWGSre!yGX"w9j-[y݈V 2Aȍ̩Fb/Vl~>E19c4YeΉ2J%B
;
Rwubl.%BV~Zjbh)aFq]ѓrETb&50Hh5-"Ks@P
(>iV?JXs=]qU^YM/_#rnIpfjzzUr.V⏽DйԆLYPX̠.;ώF H 3:Fҫȏ3cԫ8@#}S-P-_&P|QkE52Ury;CΧo5%dƾP`!붙nܓֲͶ2~[Yl0[vMf5lz轓7&pv?f+]{^ԏ'_Y&`٭(.Y%-q6D5,LNNpg~\ZZW"ٯ)2^Q9붾QIN8O-qtk]=\cnb!M1P"u,ٍ?W+Pa2:G~#δ`]zR2nRxVIC@md-oO^7{&ޝ&WG%ul826$L,,uuW!:R~h =M
觢	ZE00qow6M|"H
s
)vAUBN&t%ďԬ\tp-Zb}zGXɪm3
b]m&u615N.!aZh+73/N3Ik2qMv~a<,"Su/v,>]{|i"%:{@ݺO_i^@7PbĂlh2v$̌$EJz}J?pɫ'6v-w`vYdqibgW7#A|V3ʖR@4y	+1QS~B{;	IsK(6,{ߺr¢ZЗr1x#+V¡ć\P7vBx
l
[-n`Fפ:ӷ9C+tZ)%FGhaJpc}Uufv(髺,mf	b#b,N?ai[q(*<|%\}ruoxB(xsu
3՟H0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
cleartomark
endstream
endobj
67 0 obj
5076
endobj
68 0 obj
1009
endobj
69 0 obj
3535
endobj
70 0 obj
532
endobj
71 0 obj
/OAFFQB+CMR17
endobj
72 0 obj <<
/Ascent 694
/CapHeight 683
/Descent -195
/FontName 71 0 R
/ItalicAngle 0
/StemV 53
/XHeight 431
/FontBBox [ -33 -250 945 749 ]
/Flags 4
/CharSet (/slash/I/L/M/O/U/a/c/e/f/h/l/n/p/r/s/t/u)
/FontFile 66 0 R
>> endobj
11 0 obj <<
/Type /Pages
/Count 2
/Kids [2 0 R 13 0 R]
>> endobj
73 0 obj <<
/Type /Catalog
/Pages 11 0 R
>> endobj
74 0 obj <<
/Creator (TeX)
/Producer (pdfTeX-0.13d)
/CreationDate (D:20000501175400)
>> endobj
xref
0 75
0000000000 65535 f 
0000001603 00000 n 
0000001490 00000 n 
0000000009 00000 n 
0000001470 00000 n 
0000047388 00000 n 
0000039641 00000 n 
0000032310 00000 n 
0000019461 00000 n 
0000016481 00000 n 
0000008145 00000 n 
0000053569 00000 n 
0000003120 00000 n 
0000003004 00000 n 
0000001726 00000 n 
0000002983 00000 n 
0000003234 00000 n 
0000003366 00000 n 
0000003903 00000 n 
0000007836 00000 n 
0000007857 00000 n 
0000007877 00000 n 
0000007898 00000 n 
0000007918 00000 n 
0000007949 00000 n 
0000008277 00000 n 
0000008809 00000 n 
0000016060 00000 n 
0000016081 00000 n 
0000016102 00000 n 
0000016123 00000 n 
0000016143 00000 n 
0000016174 00000 n 
0000016612 00000 n 
0000017155 00000 n 
0000019155 00000 n 
0000019176 00000 n 
0000019196 00000 n 
0000019216 00000 n 
0000019236 00000 n 
0000019267 00000 n 
0000019592 00000 n 
0000020127 00000 n 
0000031883 00000 n 
0000031905 00000 n 
0000031926 00000 n 
0000031947 00000 n 
0000031967 00000 n 
0000031997 00000 n 
0000032441 00000 n 
0000032978 00000 n 
0000039277 00000 n 
0000039298 00000 n 
0000039319 00000 n 
0000039340 00000 n 
0000039360 00000 n 
0000039391 00000 n 
0000039772 00000 n 
0000040305 00000 n 
0000047018 00000 n 
0000047039 00000 n 
0000047060 00000 n 
0000047081 00000 n 
0000047101 00000 n 
0000047131 00000 n 
0000047519 00000 n 
0000048051 00000 n 
0000053229 00000 n 
0000053250 00000 n 
0000053271 00000 n 
0000053292 00000 n 
0000053312 00000 n 
0000053342 00000 n 
0000053634 00000 n 
0000053685 00000 n 
trailer
<<
/Size 75
/Root 73 0 R
/Info 74 0 R
>>
startxref
53780
%%EOF
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/ir2om.red0000644000175000017500000002727711526203062023531 0ustar  giovannigiovanni%  Description: This module defines all functions necessary to pass from the
%               intermediate representation to OpenMath. They print out the
%               OpenMath expression on the screen.
%
%  Date: 2 May 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following tables are used by the functions in this file       %
% in order to map properly intermediate representation tokens   %
% to OpenMath elements and symbols.                          %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

mmltypes!*:=
'((complex_cartesian . (complex_cartesian_type))
(complex_polar . (complex_polar_type))
(constant . (constant_type))
(integer . (integer_type))
(list . (list_type))
(matrix . (matrix_type))
(rational . (rational_type))
(real . (real_type))
(set . (set_type)));

% Maps MathML  attribute values
% to OpenMath symbols

interval!*:=
'((open . (interval_oo))
(closed . (interval_cc))
(open!-closed . (interval_oc))
(closed!-open . (interval_co)));

% Maps MathML constants to OpenMath constant symbols
% and their CDs.

constantsOM!*:=
'((!&ImaginaryI!; . (nums1 i))
(!&ExponentialE!; . (nums1 e))
(!&pi!; . (nums1 pi))
(!&NotANumber!; . (nums1 nan))
(!&gamma!; . (nums1 gamma))
(!&infin!; . (nums1 infinity))
(!&false!; . (logic1 false))
(!&true!; . (logic1 true)));


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The function ir2om starts the process of translating intermediate  %
% representation into OpenMath         IR->OpenMath              %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


symbolic procedure ir2om( elem );
begin;
   ind:=2;
   indent:=0;
   printout("");
   indent!* t;
   objectOM( elem );
   indent!* nil;
   printout("");
end;

symbolic procedure objectOM(elem);
begin scalar aa;;
   if PAIRP elem then <<
    if (aa:=assoc(car elem, ir2mml!*)) then <<
      apply(cadddr aa, list elem)
     >>
    else fnOM(elem);
   >>
   else basicOM(elem);
end;

symbolic procedure strOM(elem);
begin;
  printout " ";princ cadr elem; princ " ";
end;

% Recieves an element which is not a list
% and prints out OpenMath accordingly.

symbolic procedure basicOM(elem);
begin;
  if NUMBERP elem then <<
    if FIXP elem then integerOM(elem);
    if FLOATP elem then floatOM(elem)
  >>
  else
    if IDP elem then variableOM(elem);
end;

% Prints out integers

symbolic procedure integerOM(elem);
begin;
   printout(" ");
   princ elem;
   princ " "
end;

% Prints out decimal floats

symbolic procedure floatOM(elem);
begin;
   printout("";
end;

% Prints out OpenMath variables

symbolic procedure variableOM(elem);
begin scalar aa;
 aa:=assoc(intern elem, constantsOM!*);
 if aa neq nil then <<
    printout("";
   >>
   else <<
     if elem neq nil then <<
       printout("";
    >>
  >>;
end;



% Prints out all OpenMath symbols of 1, 2, or more arguments
% constructed by application.

symbolic procedure naryOM(elem);
begin scalar cd, name;
  name:=car elem;
  if name='var then name:='variance;
  cd := assoc(name, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  if cadr elem neq nil then <<
    if cadr elem = 'multiset then cd:=cadr elem;
  >>;
  printout "";
  indent:=indent+2;
  printout "";
  multiOM(cddr elem);
  indent:=indent-2;
  printout "";
end;

symbolic procedure multiOM(elem);
begin;
   if ((length elem)=1) then objectOM( car elem )
       else <>
end;

% Prints out the OpenMath matrix_selector or
% vector_selector symbols

symbolic procedure selectOM(elem);
begin scalar name;
  if caaddr elem ='matrix then name:='matrix_selector
  else name:='vector_selector;
  printout "";
  indent:=indent+2;
  printout "";
  multiOM(cdddr elem);
  objectOM caddr elem;
  indent:=indent-2;
  printout "";
end;

% Prints out elements which are
% containers in MathML.

symbolic procedure containerOM(elem);
begin scalar cd, att, name;
  att:=cadr elem;
  name:=car elem;
  printout "";
  indent!* t;
  if name = 'vectorml then name:= 'vector;
  cd := cadr assoc(name, valid_om!*);
  if car elem = 'set and PAIRP att then <<
    if intern cadr car att='multiset then cd:='multiset1;
  >>;

  if car elem = 'vectorml then name:= "vector";
  if car elem = 'vectorml then elem:= 'vector . cdr elem;
  printout "";
  multiOM(cddr elem);
  indent!* nil;
  printout "";
end;

% Prints out OpenMath intervals

symbolic procedure intervalOM(elem);
begin scalar aa, att, name, cd;
  att:=cadr elem;
  name:=car elem;

  if name = 'lowupperlimit then <>;

  cd := cadr assoc(name, valid_om!*);

  if att neq nil then <<
     aa:=assoc(intern cadr car att, interval!*);
     name:=cadr aa;
  >>;

  printout "";
  indent!* t;
  printout "";
  multiOM(cddr elem);
  indent!* nil;
  printout "";

end;

% Prints matrices according to the definition
% in CD linalg1

symbolic procedure matrixOM(elem);
begin;
  printout "";
  indent!* t;
  printout "";
  matrixrowOM(cadddr elem);
  indent!* nil;
  printout "";
end;

symbolic procedure matrixrowOM(elem);
begin;
  if elem neq nil then <<
    printout "";
    indent!* t;
    printout "";
    multiOM(car elem);
    indent!* nil;
    printout "";
    matrixrowOM cdr elem;
  >>;
end;

% Prints out variables which posses
% an attribute

symbolic procedure ciOM(elem);
begin;
  printout "";
  indent!* t;
  printout "";
  indent!* t;
  printout "";
  printout "";
  indent!* nil;
  printout "";
  objectOM(caddr elem);
  indent!* nil;
  printout "";
end;

% Prints out constants such as pi, gamma etc...

symbolic procedure numOM(elem);
begin;
  printout "";
  indent!* t;
  printout "";
  objectOM cadr elem;
  if car elem='based_integer then strOM cadr caddr elem
  else objectOM caddr elem;
  indent!* nil;
  printout "";
end;

symbolic procedure fnOM(elem);
begin;
  printout "";
  indent!* t;
  printout "";
  indent!* t;
  printout "";
  indent!* t;
  printout "";

  printout "";
  indent!* nil;
  printout "";
  objectOM car elem;
  indent!* nil;
  printout "";
  multiOM(cddr elem);
  indent!* nil;
  printout "";
end;

% Prints out partial differentiation expressions

symbolic procedure partialdiffOM(elem);
begin scalar cd, var, fun, name;
  cd := assoc(car elem, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  name:=car elem;
  var:=cdr reverse cddr elem;
  fun:=car reverse elem;

  if length var = 1 then symbolsOM('diff . cdr elem);
end;

% Prints out elements such as sum, prod, diff and int.

symbolic procedure symbolsOM(elem);
begin scalar cd, var, fun, int, name;
  cd := assoc(car elem, valid_om!*);
  if cd neq nil then cd:=cadr cd;
  name:=car elem;
  var:=caddr elem;
  fun:=car reverse elem;
  if name neq 'diff then int:=cadddr elem;

  % This error states that a  will not be translated to MathML
  if int neq nil then if car int = 'condition then errorML(" tag not supported in MathML", 1);

  printout "";
  indent!* t;
  if int neq nil AND name='int then name:='defint;
  printout "";
  if int neq nil then objectOM int;
  lambdaOM ('lambda . nil . var . list fun);
  indent!* nil;
  printout "";
end;

% Prints out lambda expressions

symbolic procedure lambdaOM(elem);
begin scalar var, fun;
  var:= cadr caddr elem;
  fun:=car reverse elem;
  printout "";
  indent!* t;
  printout "";
  printout "";
  indent!* t;
  objectOM var;
  indent!* nil;
  printout "";
  objectOM fun;
  indent!* nil;
  printout "";
end;

% Does not work...

symbolic procedure semanticOM(elem);
begin scalar sem;
  printout "";
  indent!* t;
  sem:=cadr cadr elem;
  list2string sem;
  multiOM cddr elem;
  indent!* nil;
  printout "";
end;

% Prints out limit expressions

symbolic procedure limitOM(elem);
begin scalar limit, fun, var, tendsto;
  var:=caddr elem;
  limit:=cadddr elem;
  fun:=car reverse elem;

  printout "";
  indent!* t;
  printout "";
  if car limit = 'lowlimit then <<
    objectOM cadr limit;
    printout ""
  >>;
  if car limit = 'condition then <<
    objectOM car reverse cadr limit;
    tendsto:=  cadr car cadr cadr limit;
    printout ""
  >>;
  lambdaOM ('limit . nil . var . list fun);
  indent!* nil;
  printout "";
end;

% Prints out OpenMath quantifiers

symbolic procedure quantOM(elem);
begin;
  if cadr reverse elem neq nil then errorML("condition tag not supported in MathML ", 2);
  printout "";
  indent!* t;
  printout "";
  printout "";
  indent!* t;
  bvarOM cddr elem;
  indent!* nil;
  printout "";
  objectOM car reverse elem;
  indent!* nil;
  printout "";
end;

symbolic procedure bvarOM(elem);
begin;
  if PAIRP car elem then
  if car car elem = 'bvar then <>;
end;

symbolic procedure printout( str );
begin;
   terpri!* t;
   for i := 1:indent do << princ " " >>;
   princ str;
end;

% This is the function the user types to
% translate MathML to OpenMath

symbolic procedure mml2om();
begin scalar a;;
  a:=mml2ir();
  terpri!* t;
  princ "Intermediate representation: "; terpri!* t; print a;
  ir2om a;
end;

lisp operator mml2om;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathml.tst0000644000175000017500000000051211526203062024002 0ustar  giovannigiovannion mathml; % output

sin (x);

(x + y)^5;

off mathml;


parseml(); 
 
3 
5 
 
 

operator gt;

 % MathML 1.x form
parseml();

x
y



 % MathML 2.x form
parseml();

x
y



end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mtables.red0000644000175000017500000003675211526203062024126 0ustar  giovannigiovanni%  Description: This file contains the tables guiding the program
%
%  Version 26 March 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Declaration of a series of table lists which contain the function to be executed  %
% when a certain token is encountered.                                                    %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

constants!*:=
'(!&true!; !&false!; !&imaginaryi!; !&ii!; !&exponentiale!; !&ee!; !&pi!; !&infin!; !&gamma!; !&differentiald!;
!&dd!;);

% The relations!* list contains the correspondance between
% tokens to be found between  tags and the
% reduce function to be executed as well as the argument
% the reduce function should take.
% The  tag is deprecated in MathML2.0 but we have
% kept it for backwards compatibilty.

relations!*:=
'((tendsto . (binaryRD tendsto))
(tendsto!/ . (binaryRD tendsto))
(eq!/ . (naryRD eq))
(neq!/ . (binaryRD neq))
(lt!/ . (naryRD lt))
(gt!/ . (naryRD gt))
(geq!/ . (naryRD geq))
(leq!/ . (naryRD leq))
(in!/ . (binaryRD in))
(notin!/ . (binaryRD notin))
(subset!/ . (subsetrd subset))
(prsubset!/ . (prsubsetrd prsubset))
(notprsubset!/ . (binaryRD notprsubset))
(notsubset!/ . (binaryRD notsubset)));


% The functions!* list contains the correspondance between
% tokens to be found between  tags and the
% reduce function to be executed as well as the argument
% the reduce function should take.

functions!*:=
'((divide!/ . (binaryRD divide))
(scalarproduct!/ . (binaryRD scalarproduct))
(vectorproduct!/ . (binaryRD vectorproduct))
(outerproduct!/ . (binaryRD outerproduct))
(divergence!/ . (unaryRD divergence))
(curl!/ . (unaryRD curl))
(laplacian!/ . (unaryRD laplacian))
(grad!/ . (unaryRD grad))
(size!/ . (unaryRD size))
(setdiff!/ . (setFuncsBinRD setdiff))
(select!/ . (selectRD selector))
(selector!/ . (selectRD selector))
(transpose!/ . (transposeRD transpose))
(determinant!/ . (determinantRD determinant))
(fn . (applyfnRD fn))
(union!/ . (setFuncsnaryRD union))
(intersect!/ . (setFuncsnaryRD intersect))
(implies!/ . (binaryRD implies))
(not!/ . (unaryRD not))
(xor!/ . (naryRD xor))
(or!/ . (naryRD or))
(and!/ . (naryRD and))
(mean!/ . (naryRD mean))
(mode!/ . (naryRD mode))
(var!/ . (naryRD variance))
(variance!/ . (naryRD var))
(sdev!/ . (naryRD sdev))
(moment!/ . (momentRD moment))
(median!/ . (naryRD median))
(sin!/ . (unaryRD sin))
(sec!/ . (unaryRD sec))
(sinh!/ . (unaryRD sinh))
(sech!/ . (unaryRD sech))
(arcsin!/ . (unaryRD arcsin))
(cos!/ . (unaryRD cos))
(csc!/ . (unaryRD csc))
(cosh!/ . (unaryRD cosh))
(csch!/ . (unaryRD csch))
(arccos!/ . (unaryRD arccos))
(tan!/ . (unaryRD tan))
(cot!/ . (unaryRD cot))
(tanh!/ . (unaryRD tanh))
(coth!/ . (unaryRD coth))
(arctan!/ . (unaryRD arctan))
(abs!/ . (unaryRD abs))
(ln!/ . (unaryRD ln))
(plus!/ . (naryRD plus))
(times!/ . (naryRD times))
(power!/ . (binaryRD power))
(exp!/ . (unaryRD exp))
(factorial!/ . (unaryRD factorial))
(quotient!/ . (binaryRD quotient))
(max!/ . (minmaxRD max))
(min!/ . (minmaxRD min))
(minus!/ . (minusRD minus))
(rem!/ . (binaryRD rem))
(conjugate!/ . (unaryRD conjugate))
(root!/ . (rootRD root))
(gcd!/ . (naryRD gcd))
(log!/ . (logRD log))
(int!/ . (symbolsRD int))
(sum!/ . (symbolsRD sum))
(limit!/ . (limitRD limit))
(condition . (conditionRD condition))
(product!/ . (symbolsRD product))
(diff!/ . (diffRD diff))
(partialdiff!/ . (partialdiffRD partialdiff))
(inverse!/ . (unaryRD inverse))
(tendsto . (binaryRD tendsto))
(tendsto!/ . (binaryRD tendsto))
(eq!/ . (naryRD eq))
(neq!/ . (binaryRD neq))
(lt!/ . (naryRD lt))
(gt!/ . (naryRD gt))
(geq!/ . (naryRD geq))
(leq!/ . (naryRD leq))
(in!/ . (setFuncsBinRD in))
(notin!/ . (setFuncsBinRD notin))
(subset!/ . (subsetrd subset))
(prsubset!/ . (prsubsetrd prsubset))
(notprsubset!/ . (setFuncaBinRD notprsubset))
(notsubset!/ . (setFuncsBinRD notsubset))
(forall!/ . (quantifierRD forall))
(exists!/ . (quantifierRD exists))
(equivalent!/ . (binaryRD equivalent))
(approx!/ . (binaryRD approx))
(imaginary!/ . (unaryRD imaginary))
(real!/ . (unaryRD real))
(arg!/ . (unaryRD arg))
(compose!/ . (naryRD compose))
(csymbol . (csymbolrd csymbol)));

% The constructors!* list sets a correspondance between MathML
% constructor tags, the reduce function to be executed and the
% closing tag which must be looked for in order to make sure
% syntax is correct

constructors!* :=
'((reln . (relnRD !/reln ""))
(set . ( setRD !/set ""))
(fn . ( fnRD !/fn ""))
(declare . ( declareRD !/declare ""))
(interval . ( intervalRD !/interval ""))
(list . ( listRD !/list ""))
(matrix . ( matrixRD !/matrix ""))
(apply . ( applyRD !/apply ""))
(cn . ( cnRD !/cn ""))
(ci . ( ciRD !/ci ""))
(lambda . ( lambdaRD !/lambda "")));

% The mml!* list determines the correspondance between elements
% in the intermediate representation and the reduce functions to be
% executed.

% The ir2mml!* table determines what function to execute for each
% element of the intermediate representation.
% Its syntax is the following:
%
% (ir_element . (reduce_function function_argument))
%
% The function argument is the equvalent MathML tag usually

ir2mml!* :=
'((determinant . (nary determinant naryOM))
(semantic . (semanticML nil semanticOM))
(string . (nil nil strOM))
(based_integer . (numML based_integer naryOM))
(complex_cartesian . (numML complex_cartesian naryOM))
(complex_polar . (numML complex_polar naryOM))
(ci . (ciML nil ciOM))
(cn . (cnML nil cnOM))
(vectorml . (vectorML nil containerOM))
(scalarproduct . (nary scalarproduct naryOM))
(vectorproduct . (nary vectorproduct naryOM))
(outerproduct . (nary outerproduct naryOM))
(lambda . (containerML lambda lambdaOM))
(declare . (declareML nil))
(divergence . (nary divergence naryOM))
(laplacian . (nary laplacian naryOM))
(curl . (nary curl naryOM))
(grad . (nary grad naryOM))
(size . (nary size naryOM))
(moment . (degreetoksML moment naryOM))
(transpose . (nary transpose naryOM))
(sum . (nary sum symbolsOM))
(product . (nary product symbolsOM))
(limit . (nary limit limitOM))
(tendsto . (tendstoML nil))
(df . (dfML nil))
(diff . (nary diff symbolsOM))
(partialdiff . (nary partialdiff partialdiffOM))
(conjugate . (nary conjugate naryOM))
(inverse . (nary inverse naryOM))
(abs . (nary abs naryOM))
(gcd . (nary gcd naryOM))
(set . (containerML set containerOM))
(factorial . (nary factorial naryOM))
(max . (nary max naryOM))
(min . (nary min naryOM))
(and . (nary and naryOM))
(or . (nary or naryOM))
(xor . (nary xor naryOM))
(selector . (nary selector selectOM))
(cos . (nary cos naryOM))
(sin . (nary sin naryOM))
(sec . (nary sec naryOM))
(cosh . (nary cosh naryOM))
(cot . (nary cot naryOM))
(coth . (nary coth naryOM))
(csch . (nary csch naryOM))
(arccos . (nary arccos naryOM))
(arcsin . (nary arcsin naryOM))
(arctan . (nary arctan naryOM))
(sech . (nary sech naryOM))
(sinh . (nary sinh naryOM))
(tan . (nary tan naryOM))
(tanh . (nary tanh naryOM))
(csc . (nary csc naryOM))
(arg . (nary arg naryOM))
(real . (nary real naryOM))
(exp . (nary exp naryOM))
(not . (nary not naryOM))
(rem . (nary rem naryOM))
(imaginary . (nary imaginary naryOM))
(quotient . (quotientML quotient naryOM))
(divide . (quotientML divide naryOM))
(equivalent . (nary equivalent naryOM))
(approx . (nary approx naryOM))
(implies . (nary implies naryOM))
(plus . (nary plus naryOM))
(times . (nary times naryOM))
(power . (nary power naryOM))
(median . (nary median naryOM))
(mean . (nary mean naryOM))
(sdev . (nary sdev naryOM))
(variance . (nary variance naryOM))
(mode . (nary mode naryOM))
(compose . (nary compose naryOM))
(root . (degreetoksML root naryOM))
(log . (log_baseML log naryOM))
(logb . (log_baseML logb))
(log10 . (log_baseML log10))
(ln . (nary ln naryOM))
(eq . (reln eq naryOM))
(neq . (reln neq naryOM))
(gt . (reln gt naryOM))
(lt . (reln lt naryOM))
(geq . (reln geq naryOM))
(leq . (reln leq naryOM))
(union . (sets union naryOM))
(intersect . (sets intersect naryOM))
(in . (reln in naryOM))
(notin . (reln notin naryOM))
(subset . (reln subset naryOM))
(prsubset . (reln prsubset naryOM))
(notsubset . (reln notsubset naryOM))
(notprsubset . (reln notprsubset naryOM))
(setdiff . (sets setdiff naryOM))
(rational . (rationalML nil naryOM))
(matrix . (matrixML nil matrixOM))
(minus . (minusML nil naryOM))
(int . (nary int symbolsOM))
(equal . (equalML nil naryOM))
(bvar . (bvarML nil))
(degree . (degreeML nil))
(interval . (containerML interval intervalOM))
(integer_interval . (containerML interval intervalOM))
(condition . (conditionML nil))
(lowupperlimit . (lowupperlimitML nil intervalOM))
(lowlimit . (lowlimitML nil))
(fn . (csymbol_fn nil))
%Ident has no OpenMath equivalent
(ident . (identML nil))
(forall . (nary forall quantOM))
(exists . (nary exists quantOM))
(list . (containerML list containerOM)));


% This table contains all the OpenMath elements which are understood by the
% translator and which have a MathML equivalent. The symbol and originating CDs
% are contained in this table.

valid_om!*:=
'((divide . (arith1))
(integer (omtypes))
(float (omtypes))
(selector .(linalg3))
(complex_cartesian . (nums1))
(complex_polar . (nums1))
(based_integer . (nums1))
(equivalent . (logic2))
(approx . (relation2))
(determinant . (linalg3))
(transpose . (linalg3))
(inverse . (fns1 arith2))
(in . (set1 multiset1))
(subset . (set1 multiset1))
(prsubset . (set1 multiset1))
(notsubset . (set1 multiset1))
(notprsubset . (set1 multiset1))
(set . (set1 multiset1))
(setdiff . (set1 multiset1))
(union . (set1 multiset1))
(notin . (set1 multiset1))
(intersect . (set1 multiset1))
(implies . (logic1))
(not . (logic1))
(xor . (logic1))
(vectorproduct . (linalg1))
(vector . (linalg1 linalg2))
(or . (logic1))
(forall . (quant1))
(and . (logic1))
(mean . (stats1))
(mode . (stats1))
(variance . (stats1))
(sdev . (stats1))
(moment . (stats1))
(median . (stats1))
(sin . (transc1))
(sinh . (transc1))
(arcsin . (transc1))
(arcsinh . (transc1 transc2))
(sec . (transc1))
(sech . (transc1))
(arcsec . (transc1 transc2))
(arcsech . (transc1 transc2))
(cos . (transc1))
(arccos . (transc1))
(cosh . (transc1))
(arccosh . (transc1 arctrans2))
(csc . (transc1))
(csch . (transc1))
(arccsc . (transc1 transc2))
(arccsch . (transc1 transc2))
(tan . (transc1))
(tanh . (transc1))
(arctan . (transc1))
(arctanh . (transc1 transc2))
(cot . (transc1))
(coth . (transc1))
(arccot . (transc1 transc2))
(arccoth . (transc1 transc2))
(ln . (transc1))
(exp . (transc1))
(abs . (arith1))
(plus . (arith1))
(times . (arith1 arith2))
(power . (arith1))
(factorial . (integer1))
(minus . (arith1))
(rem . (integer1))
(conjugate . (arith1))
(root . (arith1))
(log . (transc1))
(int . (calculus1))
(gcd . (integer1))
(quotient . (integer1))
(sum . (arith1))
(product . (arith1))
(scalarproduct . (linalg1))
(outerproduct . (linalg1))
(diff . (calculus1))
(partialdiff . (calculus1))
(eq . (relation1))
(neq . (relation1))
(leq . (relation1))
(geq . (relation1))
(lt . (relation1))
(gt . (relation1))
(quotient . (integer1))
(interval . (interval1))
(integer_interval . (interval1))
(min . (minmax1))
(max . (minmax1))
(imaginary . (nums1))
(real . (nums1))
(forall . (quant1))
(exists . (quant1))
(lambda . (fns1))
(list . (list1))
(arg . (arith2))
(type . (typmml))
(rational . (nums1))
(curl . (veccalc1))
(divergence . (veccalc1))
(grad . (veccalc1))
(size . (linalg3))
(laplacian . (veccalc1)));


% The following table keeps information about OpenMath elements which have
% a MathML equivalent, but with another name. It also makes sure that
% the MathML translation has the correct attributes when attributes
% are needed to have a correct semantic translation.
%
% The format of the table is:
% (OpenMath_symbol_name . (one_or_more_CDs  MathML_equivalent  MathML_attribute))

special_cases!*:=
'((unary_minus . (arith1 minus nil))
(both_sides . (limit1 nil nil))
(above . (limit1 tendsto above))
(below . (limit1 tendsto below))
(null . (limit1 nil nil))
(multiset . (multiset1 set (type multiset)))
(complex_cartesian_type . (typmml complex_cartesian nil))
(complex_polar_type . (typmml complex_polar nil))
(constant_type . (typmml constant nil))
(fn_type . (typmml csymbol nil))
(integer_type . (typmml integer nil))
(list_type . (typmml list nil))
(matrix_type . (typmml matrix nil))
(rational_type . (typmml rational nil))
(real_type . (typmml real nil))
(set_type . (typmml set nil))
(vector_type . (typmml vectorml nil))
(integer_interval . (interval1 interval nil))
(interval_oo . (interval1 interval (closure open)))
(interval_cc . (interval1 interval (closure close)))
(interval_oc . (interval1 interval (closure open!-closed)))
(interval_co . (interval1 interval (closure closed!-open))));

% The following table specifies when it is
% necessary to call a function to deal in a
% precise way with the translation of the
% symbol.

special_cases2!*:=
'((matrix . (matrixIR))
(limit . (limitIR))
(vector_selector . (selectIR))
(matrix_selector . (selectIR))
(complex_cartesian . (numIR))
(complex_polar . (numIR))
(rational . (numIR))
(defint . (integralIR))
(int . (integralIR))
(diff . (integralIR))
(partialdiff . (partialdiffIR))
(sum . (sum_prodIR))
(product . (sum_prodIR))
(one . (unaryIR alg1 1))
(zero . (unaryIR alg1 0))
(i . (unaryIR nums1 !&ImaginaryI!;))
(e . (unaryIR nums1 !&ExponentialE!;))
(pi . (unaryIR nums1 !&pi!;))
(nan . (unaryIR nums1 !&NotANumber!;))
(gamma . (unaryIR nums1 !&gamma!;))
(infinity . (unaryIR nums1 !&infin!;))
(false . (unaryIR logic1 !&false!;))
(true . (unaryIR logic1 !&true!;)));


% This table contains the OpenMath elements which map simply to MathML.
% These symbols have direct mapping into MathML.

mmleq!*:= '(divide based_integer
equivalent approx determinant transpose inverse in subset prsubset
notsubset notprsubset set setdiff union notin intersect implies not xor
vectorproduct vector or forall and mean mode variance sdev moment median
sin sinh arcsin arcsinh sec sech arcsec arcsech cos arccos cosh arccosh
csc csch arccsc arccsch tan tanh arctan arctanh cot coth arccot arccoth
ln exp abs plus times power factorial minus rem conjugate root log gcd
quotient scalarproduct outerproduct eq neq leq geq lt gt quotient
interval min max imaginary real forall exists lambda list arg type
laplacian divergence curl grad size integer);

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/ptitle.tex0000644000175000017500000000330611526203062024013 0ustar  giovannigiovanni\begin{center}
\large\sc
MATH0082 Double Unit Project			\\ [4ex]
\large\bf
An OpenMath to MathML translator.
\end{center}

\begin{center}\begin{tabular}{ll}
  Candidate: 		 &Alvarez,L.		\\	% SURNAME, INITALS
  Supervisor:		 &JHD			\\	% TITLE INITALS SURNAME
  Checker:		 & 			\\	% LEAVE BLANK
  Review date:		 &	3 March 2000	\\
  Final submission date: &	2 May 2000	\\
  Equipment required:	 &own Linux Computer; BUCS	\\	% SPECIFY
\end{tabular}\end{center}


\subsubsection{ Description}					% DESCRIPTION (in the range of 100--200 words)

OpenMath and MathML are two ways of representing mathematical objects. Semantically, OpenMath is a superset of (content) MathML. The aim is to
build a translator from OpenMath to content MathML, using presentation MathML where necessary as in the example of rank in Section 5.3 on MathML
{\tt http://www.w3c.org/TR/REC-MathML/chapter5.html}. Since OpenMath is extensible, the translator will need to be.  There is no a priori choice of
implementation language. A {\em viva voce} examination will be held.  % DELETE IF INAPPLICABLE

The project report should be no more than 40 pages.


\vspace{2ex}
 \subsubsection{Marking Scheme}					

%
%	THIS DOUBLE UNIT CARRIES 12 CREDITS AND 6 ALPHAS
%
%	THERE ARE 100 AVAILABLE MARKS
%
%
\begin{center}\begin{tabular}{lrr}
  Background research           	  &	 15 &	 $\alpha$	\\
  Analysis of MathML/OpenMath translation &      10 &    $\alpha$        \\ 
  Design				  &	 20 &	2$\alpha$	\\
  Implementation	        	  &	 25 &	 $\alpha$	\\
  Testing       			  &	 10 &			\\
  Report and Documentation		  &	 15 &	 $\alpha$	\\
  Viva and Demonstration		  &	  5 &			\\ \cline{2-3}
								\\
  Total					  &	100 &	6$\alpha$	\\
\end{tabular}\end{center}




mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathmlom.rlg0000644000175000017500000046023311527635055024336 0ustar  giovannigiovanniFri Feb 18 21:28:10 2011 run on win32
load mathmlom;



in "$reduce/packages/mathml/examples.mml";

%  Description: This file contains a long list of examples demonstrating the abilities of
%               the translator. Most of these examples come straight from the MathML spec. They
%               were used during the development of the interface and should all be correctly
%               translated into OpenMath.
%
%  Version 17 April 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%       


mml2om();



  
     
       
          x 
       
       
          x 
          3 
       
     
   


Intermediate representation: 
(sin nil (plus nil (cos nil x) (power nil x 3)))


  
    
    
      
      
        
        
      
      
        
        
         3 
      
    
  
            


mml2om();



  
     
       
          x 
       
       
          x 
          3 
       
     
   


Intermediate representation: 
(sin nil (plus nil (cos nil x) (power nil (ci ((type real)) x) 3)))


  
    
    
      
      
        
        
      
      
        
        
          
            
            
          
          
        
         3 
      
    
  
      


mml2om();



  
      b 
      2 
      c 
   


Intermediate representation: 
(set ((type normal)) b 2 c)


  
    
    
     2 
    
  



mml2om();



  
      b 
      2 
      c 
   


Intermediate representation: 
(set ((type multiset)) b 2 c)


  
    
    
     2 
    
  



mml2om();



  
      b 
      2 
      c 
   


Intermediate representation: 
(vectorml nil b 2 c)


  
    
    
     2 
    
  


mml2om();



  
      b 
      2 
   


Intermediate representation: 
(interval ((closure closed)) b 2)


  
    
    
     2 
  


mml2om();



  
      b 
      2 
   


Intermediate representation: 
(interval ((closure open)) b 2)


  
    
    
     2 
  


mml2om();



  
      b 
      2 
   


Intermediate representation: 
(interval ((closure open!-closed)) b 2)


  
    
    
     2 
  



mml2om();



  
      b 
      2 
   


Intermediate representation: 
(interval ((closure closed!-open)) b 2)


  
    
    
     2 
  



mml2om();



    6  3 


Intermediate representation: 
(complex_cartesian nil 6 3)


  
    
     6 
     3 
  


mml2om();



    6  3 


Intermediate representation: 
(complex_polar nil 6 3)


  
    
     6 
     3 
  


mml2om();



    6 


Intermediate representation: 
(based_integer nil 10 (string 6))


  
    
     10 
     6 
  


mml2om();



  
     
        x 
     
     
        a 
     
     
        b 
     
      
          x 
         
             y 
         
      
   


Intermediate representation: 
(sum nil (bvar x 1) (lowupperlimit a b) (plus nil x (sin nil y)))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
        
        
          
          
        
      
    
  



              
mml2om();



  
     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   


Intermediate representation: 
(int nil (bvar x 1) (lowupperlimit a b) (f nil x))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
          
            
            
          
          
        
        
      
    
  
  



mml2om();



   
      
          x 
      
      
          x 
      
   


Intermediate representation: 
(lambda nil (bvar x 1) (sin nil x))


  
    
    
      
    
    
      
      
    
  
          
    

mml2om();



 
     
        x 
     
     
        0 
     
     
        x 
     
   


Intermediate representation: 
(limit nil (bvar x 1) (lowlimit 0) (sin nil x))


  
    
     0 
    
    
      
      
        
      
      
        
        
      
    
  

 
mml2om();

            

  
    
       x 
    
    
      
        
         x 
         a 
      
    
    
        x 
    
  


Intermediate representation: 
(limit nil (bvar x 1) (condition (tendsto ((type above)) x a)) (sin nil x))


  
    
    
    
    
      
      
        
      
      
        
        
      
    
  



mml2om();



   
      
         
             x 
         
         
             y 
         
         
             z 
         
         
             n 
         
         
            
                n 
                2 
            
            
               
                  
                      x 
                      n 
                  
                  
                      y 
                      n 
                  
               
               
                   z 
                   n 
               
            
         
      
   


Intermediate representation: 
(not nil (exists nil (bvar x 1) (bvar y 1) (bvar z 1) (bvar n 1) nil (and nil (
gt nil n 2) (eq nil (plus nil (power nil x n) (power nil y n)) (power nil z n)))
))


  
    
    
      
      
        
        
        
        
      
      
        
        
          
          
           2 
        
        
          
          
            
            
              
              
              
            
            
              
              
              
            
          
          
            
            
            
          
        
      
    
  
      



mml2om();



  
     
        0   1   0 
     
     
        0   0   1 
     
     
        1   0   0 
     
   


Intermediate representation: 
(matrix nil matrixrow ((0 1 0) (0 0 1) (1 0 0)))


  
    
    
      
       0 
       1 
       0 
    
    
      
       0 
       0 
       1 
    
    
      
       1 
       0 
       0 
    
  


mml2om();



   
      
         x
      
      
         x
         2
      
   


Intermediate representation: 
(int nil (bvar x 1) nil (power nil x 2))


  
    
    
      
      
        
      
      
        
        
         2 
      
    
  

     
mml2om();



   
      
          x 
      
      
          x 
      
   


Intermediate representation: 
(int nil (bvar x 1) nil (sin nil x))


  
    
    
      
      
        
      
      
        
        
      
    
  
                    


mml2om();




     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   


Intermediate representation: 
(sum nil (bvar x 1) (lowupperlimit a b) (f nil x))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
          
            
            
          
          
        
        
      
    
  

                 


mml2om();



  
    
       x 
   
    f
        x 
    
  


Intermediate representation: 
(diff nil (bvar x 1) (f nil x))


  
    
    
      
      
        
      
      
        
          
            
            
          
          
        
        
      
    
  

 

mml2om();



  
    
       x 
       
         2 
       
   
    f
        x 
    
  


Intermediate representation: 
(diff nil (bvar x 1) (diff nil (bvar x 1) (f nil x)))


  
    
    
      
      
        
      
      
        
        
          
          
            
          
          
            
              
                
                
              
              
            
            
          
        
      
    
  

 

mml2om();



  
    
       x 
       
         3 
       
   
    f
        x 
    
  


Intermediate representation: 
(diff nil (bvar x 1) (diff nil (bvar x 1) (diff nil (bvar x 1) (f nil x))))


  
    
    
      
      
        
      
      
        
        
          
          
            
          
          
            
            
              
              
                
              
              
                
                  
                    
                    
                  
                  
                
                
              
            
          
        
      
    
  

 



mml2om();



  
      b 
      a 
      c 
  


Intermediate representation: 
(set ((type normal)) b a c)


  
    
    
    
    
  


mml2om();



   
      b 
      a 
      c 
   


Intermediate representation: 
(list nil b a c)


  
    
    
    
    
  


mml2om();




      b 
      a 
      c 
   


Intermediate representation: 
(list ((order lexicographic)) b a c)


  
    
    
    
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(union ((definitionurl (w w w !. n a g !. c o !. u k))) (ci ((type set)) a) (ci
((type set)) b))


  
    
    
      
        
        
      
      
    
    
      
        
        
      
      
    
  


mml2om();




  
      b 
      2 
      c 
   
   
      b 
      r 
      2 
      4 
      c 
   
   


Intermediate representation: 
(union nil (set ((type normal)) b 2 c) (set nil b r 2 4 c))


  
    
    
      
      
       2 
      
    
    
      
      
      
       2 
       4 
      
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(intersect ((definitionurl (w w w !. m i t !. e d u))) (ci ((type set)) a) (ci (
(type set)) b))


  
    
    
      
        
        
      
      
    
    
      
        
        
      
      
    
  


mml2om();




  
      b 
      2 
      c 
   
   
      b 
      r 
      2 
      4 
      c 
   
 


Intermediate representation: 
(intersect nil (set nil b 2 c) (set nil b r 2 4 c))


  
    
    
      
      
       2 
      
    
    
      
      
      
       2 
       4 
      
    
  



mml2om();




      a 
      A 
   


Intermediate representation: 
(in ((definitionurl (w w w !. w w w !. w w w))) a (ci ((type set)) a))


  
    
    
    
      
        
        
      
      
    
  


mml2om();



 
    a 
    A 
 


Intermediate representation: 
(notin ((definitionurl (w w w !. w w w !. w w w))) a a)


  
    
    
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(prsubset ((definitionurl (w w w !. w w w !. w w w))) a b)


  
    
    
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(notsubset ((definitionurl (w w w !. w w w !. w w w))) a b)


  
    
    
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(notprsubset ((definitionurl (w w w !. w w w !. w w w))) a b)


  
    
    
    
  


mml2om();




      A 
      B 
   


Intermediate representation: 
(setdiff ((definitionurl (w w w !. w w w !. w w w))) a b)


  
    
    
    
  


mml2om();




     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   


Intermediate representation: 
(sum nil (bvar x 1) (lowupperlimit a b) (f nil x))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
          
            
            
          
          
        
        
      
    
  




mml2om();




     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   


Intermediate representation: 
(product nil (bvar x 1) (lowupperlimit a b) (f nil x))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
          
            
            
          
          
        
        
      
    
  


mml2om();



 
   
      V 
   
   
     
       
        V 
        0 
     
   
   
     
       
          S
       
        a 
     
      V 
   
 


Intermediate representation: 
(limit nil (bvar v 1) (condition (tendsto ((type above)) v 0)) (divide nil (int
nil (bvar s 1) nil a) v))


  
    
     0 
    
    
      
      
        
      
      
        
        
          
          
            
            
              
            
            
          
        
        
      
    
  
               

mml2om();




     
        x 
     
     
        0 
     
     
        x 
     
   


Intermediate representation: 
(limit nil (bvar x 1) (lowlimit 0) (sin nil x))


  
    
     0 
    
    
      
      
        
      
      
        
        
      
    
  


mml2om();




     
        x 
     
     
       
         
          x 
          a 
       
     
     
         x 
     
   


Intermediate representation: 
(limit nil (bvar x 1) (condition (tendsto ((type above)) x a)) (sin nil x))


  
    
    
    
    
      
      
        
      
      
        
        
      
    
  



mml2om();




     
       
          x 
       
       
          x 
          3 
       
     
   


Intermediate representation: 
(sin nil (plus nil (cos nil x) (power nil x 3)))


  
    
    
      
      
        
        
      
      
        
        
         3 
      
    
  


mml2om();




      b 
      r 
      2 
      4 
      c 
   


Intermediate representation: 
(mean nil b r 2 4 c)


  
    
    
    
     2 
     4 
    
  


mml2om();




      b 
      r 
      2 
      4 
      c 
   


Intermediate representation: 
(sdev nil b r 2 4 c)


  
    
    
    
     2 
     4 
    
  


mml2om();



 
      b 
      r 
      2 
      4 
      c 
 


Intermediate representation: 
(variance nil b r 2 4 c)


  
    
    
    
     2 
     4 
    
  



mml2om();




      1 
      2 
      3 
      x 
   


Intermediate representation: 
(vectorml nil 1 2 3 x)


  
    
     1 
     2 
     3 
    
  


mml2om();




     
        0   1   0 
     
     
        0   0   1 
     
     
        1   0   0 
     
   


Intermediate representation: 
(matrix nil matrixrow ((0 1 0) (0 0 1) (1 0 0)))


  
    
    
      
       0 
       1 
       0 
    
    
      
       0 
       0 
       1 
    
    
      
       1 
       0 
       0 
    
  


mml2om();





     
        3   1   5 
     
     
        7   0   2 
     
     
        1   7   8 
     
   



Intermediate representation: 
(determinant nil (matrix nil matrixrow ((3 1 5) (7 0 2) (1 7 8))))


  
    
    
      
      
        
         3 
         1 
         5 
      
      
        
         7 
         0 
         2 
      
      
        
         1 
         7 
         8 
      
    
  


mml2om();





     
        3   1   5 
     
     
        7   0   2 
     
     
        1   7   8 
     
   



Intermediate representation: 
(transpose nil (matrix nil matrixrow ((3 1 5) (7 0 2) (1 7 8))))


  
    
    
      
      
        
         3 
         1 
         5 
      
      
        
         7 
         0 
         2 
      
      
        
         1 
         7 
         8 
      
    
  


mml2om();




     
       
          1   2 
       
       
          3   4 
       
     
      1 
   


Intermediate representation: 
(selector nil (matrix nil matrixrow ((1 2) (3 4))) 1 nil)


  
    
     1 
    
      
      
        
         1 
         2 
      
      
        
         3 
         4 
      
    
  


mml2om();




     
       
          1   2 
       
       
          3   4 
       
     
      2 
      2 
   


Intermediate representation: 
(selector nil (matrix nil matrixrow ((1 2) (3 4))) 2 2)


  
    
     2 
     2 
    
      
      
        
         1 
         2 
      
      
        
         3 
         4 
      
    
  


mml2om();




 
      
         a
         1
      
      
         2
         s
      
   



Intermediate representation: 
(determinant nil (matrix nil matrixrow ((a 1) (2 s))))


  
    
    
      
      
        
        
         1 
      
      
        
         2 
        
      
    
  



mml2om();



 
  
   
      
         1
         2
         3
         4
      
      
         1
         2
         1
         2
      
      
         2
         3
         2
         1
      
      
         2
         1
         1
         1
      
   
  
 


Intermediate representation: 
(determinant nil (transpose nil (matrix nil matrixrow ((1 2 3 4) (1 2 1 2) (2 3
2 1) (2 1 1 1)))))


  
    
    
      
      
        
        
          
           1 
           2 
           3 
           4 
        
        
          
           1 
           2 
           1 
           2 
        
        
          
           2 
           3 
           2 
           1 
        
        
          
           2 
           1 
           1 
           1 
        
      
    
  



mml2om();



   
      
         2
         
            x
         
         x
      
      
         
            
               x
            
            
               x
               2
            
         
      
   


Intermediate representation: 
(plus nil (times nil 2 (cos nil x) x) (minus nil (times nil (sin nil x) (power
nil x 2))))


  
    
    
      
       2 
      
        
        
      
      
    
    
      
      
        
        
          
          
        
        
          
          
           2 
        
      
    
  



mml2om();



   
      
         x
         
            ⅈ
            
               1
            
         
      
      
         x
         
            
               ⅈ
            
            
               1
            
         
      
   


Intermediate representation: 
(list nil (eq nil x (plus nil !&imaginaryi!; (minus nil 1))) (eq nil x (plus nil
(minus nil !&imaginaryi!;) (minus nil 1))))


  
    
    
      
      
      
        
        
        
          
           1 
        
      
    
    
      
      
      
        
        
          
          
        
        
          
           1 
        
      
    
  




mml2om();



   
      
         
            
               
                  x
                  y
               
            
            x
            y
         
      
      
         
            2
            
               x
               y
            
         
         
            
               2
            
            2
         
         x
         y
      
      
         
            2
            
               x
               y
            
         
         
            2
         
      
      
         
            
               x
               y
            
         
      
      1
   


Intermediate representation: 
(plus nil (minus nil (times nil (cos nil (times nil x y)) x y)) (times nil (
power nil 2 (times nil x y)) (power nil (log nil nil 2) 2) x y) (times nil (
power nil 2 (times nil x y)) (log nil nil 2)) (minus nil (sin nil (times nil x y
))) 1)


  
    
    
      
      
        
        
          
          
            
            
            
          
        
        
        
      
    
    
      
      
        
         2 
        
          
          
          
        
      
      
        
        
          
           2 
        
         2 
      
      
      
    
    
      
      
        
         2 
        
          
          
          
        
      
      
        
         2 
      
    
    
      
      
        
        
          
          
          
        
      
    
     1 
  



mml2om();



 
  2
  2
  2
 


Intermediate representation: 
(eq nil 2 2 2)


  
    
     2 
     2 
     2 
  


mml2om();



 
  2
  A
  u
 


Intermediate representation: 
(eq nil 2 a u)


  
    
     2 
    
    
  


mml2om();



 
  2
  2
 


Intermediate representation: 
(neq nil 2 2)


  
    
     2 
     2 
  


mml2om();



 
  2
  A
 


Intermediate representation: 
(neq nil 2 a)


  
    
     2 
    
  


mml2om();



 
  2
  2
  2
 


Intermediate representation: 
(lt nil 2 2 2)


  
    
     2 
     2 
     2 
  


mml2om();



 
  2
  A
  u
 


Intermediate representation: 
(lt nil 2 a u)


  
    
     2 
    
    
  


mml2om();



 
  2
  2
  2
 


Intermediate representation: 
(gt nil 2 2 2)


  
    
     2 
     2 
     2 
  


mml2om();



 
  2
  A
  u
 


Intermediate representation: 
(gt nil 2 a u)


  
    
     2 
    
    
  


mml2om();



 
  2
  2
  2
 


Intermediate representation: 
(geq nil 2 2 2)


  
    
     2 
     2 
     2 
  


mml2om();



 
  2
  A
  u
 


Intermediate representation: 
(geq nil 2 a u)


  
    
     2 
    
    
  


mml2om();



 
  2
  2
  2
 


Intermediate representation: 
(leq nil 2 2 2)


  
    
     2 
     2 
     2 
  


mml2om();



 
  2
  A
  u
 


Intermediate representation: 
(leq nil 2 a u)


  
    
     2 
    
    
  


%The following examples work perfectly when read
%in by mml2om() and prove that the tags employed
%work correctly. The ir output can then be used
%to see if the mathml produced works:

mml2om();



   
      
         x
      
      
         0
      
      
         1
      
      
         x
         2
      
   


Intermediate representation: 
(int nil (bvar x 1) (lowupperlimit 0 1) (power nil x 2))


  
    
    
      
       0 
       1 
    
    
      
      
        
      
      
        
        
         2 
      
    
  
           


mml2om();



   
      
         x
      
      
         1
      
      
         ∞
      
      x
   


Intermediate representation: 
(int nil (bvar x 1) (lowupperlimit 1 !&infin!;) x)


  
    
    
      
       1 
      
    
    
      
      
        
      
      
    
  
       

mml2om();


       
 
   
      x 
   
   
       a 
       b 
    
   
      x 
   
 


Intermediate representation: 
(int nil (bvar x 1) (interval nil a b) (cos nil x))


  
    
    
      
      
      
    
    
      
      
        
      
      
        
        
      
    
  
       

%this example is MathML1.0 and when passed
%through function mml2om() it translates it to
%MathML2.0

mml2om();



  
    
       x 
      
         2 
      
    
    f
        x 
    
  


Intermediate representation: 
(diff nil (bvar x 1) (diff nil (bvar x 1) (f nil x)))


  
    
    
      
      
        
      
      
        
        
          
          
            
          
          
            
              
                
                
              
              
            
            
          
        
      
    
  
             



mml2om();



  
    
        x 
        y 
    
     3 
     7 
  


Intermediate representation: 
(list nil (plus nil x y) 3 7)


  
    
    
      
      
      
    
     3 
     7 
  
       

mml2om();


       
  
     a 
     b 
  


Intermediate representation: 
(interval ((closure open!-closed)) a b)


  
    
    
    
  
       

mml2om();



   
      a 
      b 
   


Intermediate representation: 
(interval nil a b)


  
    
    
    
  


mml2om();



   
      
         
            x
            
               
                  root_of
               
               
                  
                     
                        y
                        x_
                     
                  
                  
                     
                        
                           
                              x_
                           
                           
                              x_
                              x_
                           
                        
                        y
                     
                  
                  x_
                  y
               
               x_
               tag_1
            
         
         
            a
            
               x
               y
            
         
      
   


Intermediate representation: 
(list nil (list nil (eq nil x (root_of nil (plus nil (minus nil (power nil y x_)
) (minus nil (times nil (int nil (bvar x_ 1) nil (power nil x_ x_)) y)) x_ y) x_
tag_1)) (eq nil a (plus nil x y))))


  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                
              
            
            
              
              
                
                
                  
                  
                    
                    
                      
                    
                    
                      
                      
                      
                    
                  
                
                
              
            
            
            
          
          
          
        
      
      
        
        
        
          
          
          
        
      
    
  
          
mml2om();



   
      
         
            x
            
               
                  root_of
               
               
                  
                     
                        
                           ⅈ
                           x_
                        
                     
                     y
                  
                  
                     
                        ⅈ
                        x_
                     
                  
                  
                     x_
                     
                        y
                        1
                     
                  
                  
                     
                        
                           x_
                        
                        
                           x_
                           x_
                        
                     
                     
                        y
                        2
                     
                  
                  
                     
                        
                           x_                  
                        
                        
                           x_
                           x_
                        
                     
                     y
                  
               
               x_
               tag_2
            
         
         
            z
            y
         
      
   


Intermediate representation: 
(list nil (list nil (eq nil x (root_of nil (plus nil (times nil (exp nil (plus
nil !&imaginaryi!; x_)) y) (exp nil (plus nil !&imaginaryi!; x_)) (power nil x_
(plus nil y 1)) (times nil (int nil (bvar x_ 1) nil (power nil x_ x_)) (power
nil y 2)) (times nil (int nil (bvar x_ 1) nil (power nil x_ x_)) y)) x_ tag_2))
(eq nil z y)))


  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                  
                  
                  
                
              
              
            
            
              
              
                
                
                
              
            
            
              
              
              
                
                
                 1 
              
            
            
              
              
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
                
                
                 2 
              
            
            
              
              
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
            
          
          
          
        
      
      
        
        
        
      
    
  
                   


mml2om();



  
  
      b 
      2 
      c 
   
  


Intermediate representation: 
(curl nil (vectorml nil b 2 c))


  
    
    
      
      
       2 
      
    
  
       

mml2om();



  
  
      b 
      2 
      c 
   
  


Intermediate representation: 
(divergence nil (vectorml nil b 2 c))


  
    
    
      
      
       2 
      
    
  
       

mml2om();



  
  
      b 
      2 
      c 
   
  


Intermediate representation: 
(laplacian nil (vectorml nil b 2 c))


  
    
    
      
      
       2 
      
    
  
       

mml2om();



   
      
          a 
      
      
         
            
                a 
            
         
          a 
      
   


Intermediate representation: 
(forall nil (bvar a 1) nil (eq nil (inverse nil (inverse nil a)) a))


  
    
    
      
    
    
      
      
        
        
          
          
        
      
      
    
  
            

end;


in "$reduce/packages/mathml/examples.om";

%  Description: This file contains a long list of examples demonstrating the abilities of
%               the translator. Most of these examples come straight from the CDs. They
%		were used during the development of the interface and should all be correctly
%		translated into MathML.
%
%  Version 17 April 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

om2mml();



  
    
      
      
      
         
          1
          
      
  


Intermediate representation:
(plus nil f d (plus nil 1 10000000000.0))


   
       f 
       d 
      
          1 
          10000000000.0 
      
   
       

om2mml();



  
  
  
    
  
  
    
    
  
  


Intermediate representation:
(lambda nil (bvar x 1) (sin nil x))


   
      
          x 
      
      
          x 
      
   
       

om2mml();



  
  
  
    
    
  
  
    
    
    
      
      
    
  
  


Intermediate representation:
(lambda nil (bvar x 1) (bvar y 1) (plus nil x (sin nil y)))


   
      
          x 
      
      
          y 
      
      
          x 
         
             y 
         
      
   
       

om2mml();


       
  
    
    
    
      
      
    
  


Intermediate representation:
(plus nil x (sin nil x))


   
       x 
      
          x 
      
   
       

om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
        
      
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (leq nil (abs nil (sin nil x)) 1.0))


   
      
          x 
      
      
         
            
                x 
            
         
          1.0 
      
   
      

om2mml();



 
   
   
     
     
       
       
       
       
     
     
       
       
         
         
          2 
       
       
         
         
           
           
              
              
              
           
           
              
              
              
           
         
         
            
            
            
         
       
     
   
 


Intermediate representation:
(not nil (exists nil (bvar x 1) (bvar y 1) (bvar z 1) (bvar n 1) (and nil (gt
nil n 2) (eq nil (plus nil (power nil x n) (power nil y n)) (power nil z n)))))


   
      
         
             x 
         
         
             y 
         
         
             z 
         
         
             n 
         
         
            
                n 
                2 
            
            
               
                  
                      x 
                      n 
                  
                  
                      y 
                      n 
                  
               
               
                   z 
                   n 
               
            
         
      
   



% The following two examples show how the translator
% can deal with matrices represented either in columns
% or rows. The translator then converts matrices
% represented in columns into ones represented in
% rows. Mapping to MathML is then possible.

om2mml();



  
    
      
        
         1 
         2 
      
      
        
         3 
         4 
      
      
        
         5 
         6 
      
  


Intermediate representation:
(matrix nil matrixcolumn ((1 2) (3 4) (5 6)))


   
      
          1 
          3 
          5 
      
      
          2 
          4 
          6 
      
   



om2mml();



  
    
      
        
         1 
         0 
      
      
        
         0 
         1 
      
  


Intermediate representation:
(matrix nil matrixrow ((1 0) (0 1)))


   
      
          1 
          0 
      
      
          0 
          1 
      
   
     


om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
            
            
              
              
            
          
          
        
        
      
      
        
        
          
          
          
            
            
              
              
            
          
        
        
      
    
  


Intermediate representation:
(forall nil (bvar m 1) (and nil (eq nil (times nil (semantic (identity (o m s  
c d = " l i n a l g 3 "   n a m e = " i d e n t i t y " /)) (semantic (rowcount
(o m s   c d = " l i n a l g 3 "   n a m e = " r o w c o u n t " /)) m)) m) m) (
eq nil (times nil m (semantic (identity (o m s   c d = " l i n a l g 3 "   n a m
e = " i d e n t i t y " /)) (semantic (columncount (o m s   c d = " l i n a l g
3 "   n a m e = " c o l u m n c o u n t " /)) m))) m)))


   
      
          m 
      
      
         
            
               
                  
                     
                        identity
                        
                           
                        
                     
                  
                  
                     
                        
                           rowcount
                           
                              
                           
                        
                     
                      m 
                  
               
                m 
            
             m 
         
         
            
                m 
               
                  
                     
                        identity
                        
                           
                        
                     
                  
                  
                     
                        
                           columncount
                           
                              
                           
                        
                     
                      m 
                  
               
            
             m 
         
      
   



om2mml();



  
    
    
    
    
      
      
        
      
      
        
        
      
    
  


Intermediate representation:
(limit nil (bvar x 1) (condition (tendsto ((type above)) x 0.0)) (sin nil x))


   
      
          x 
      
      
         
             x 
             0.0 
         
      
      
          x 
      
   

                 
% This following example will show that the translator only
% identifies the limit symbol of the limit1 CD

om2mml();



  
    
    
    
    
      
      
        
      
      
        
        
      
    
  


Intermediate representation:
(semantic (limit (o m s   c d = " f a k e c d "   n a m e = " l i m i t " /))
nil (bvar x 1) (condition (tendsto ((type above)) x 0.0)) (sin nil x))


   
      
         
            limit
            
               
            
         
      
      
          x 
      
      
         
             x 
             0.0 
         
      
      
          x 
      
   

                 
% The following two examples show how the translator
% recognizes whether a symbol has a mathml equivalent
% depending on the CD it comes from. 

% They both use symbol 'notsubset' but from different
% CDs. Only one of them can be mapped to MathML
% and the program distinguishes it by checking if 
% the CD given is the correct one on its table
% om_mml!*.

om2mml();



 
   
   
     
      2 
      3 
      3 
   
   
     
        1 
        2 
        3 
   
  


Intermediate representation:
(notsubset nil (set nil 2 3 3) (set nil 1 2 3))


   
      
          2 
          3 
          3 
      
      
          1 
          2 
          3 
      
   
    


om2mml();



 
   
   
     
      2 
      3 
      3 
   
   
     
        1 
        2 
        3 
   
  


Intermediate representation:
(notsubset nil (set nil 2 3 3) (set nil 1 2 3))


   
      
          2 
          3 
          3 
      
      
          1 
          2 
          3 
      
   
    



om2mml();



  
    
    
      
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  


Intermediate representation:
(forall nil (bvar a 1) (bvar b 1) (eq nil (plus nil a b) (plus nil b a)))


   
      
          a 
      
      
          b 
      
      
         
             a 
             b 
         
         
             b 
             a 
         
      
   


% Example of a symbol which has a MathML equivalent
% but under another name.

om2mml();



  
    
         1 
  


Intermediate representation:
(minus nil 1)


   
       1 
   
  


om2mml();



  
    
    
      
      
    
    
  


Intermediate representation:
(eq nil (not nil &false;) &true;)


   
      
          &false; 
      
       &true; 
   
    



om2mml();



  
    
    
      
      
        
        
          
          
        
      
      
    
    
  


Intermediate representation:
(eq nil (times nil (semantic (identity (o m s   c d = " f n s 1 "   n a m e = "
i d e n t i t y " /)) (semantic (rowcount (o m s   c d = " l i n a l g 3 "   n a
m e = " r o w c o u n t " /)) m)) m) m)


   
      
         
            
               
                  identity
                  
                     
                  
               
            
            
               
                  
                     rowcount
                     
                        
                     
                  
               
                m 
            
         
          m 
      
       m 
   

                 


om2mml();



  
    
    
      
         3 
         6 
         9 
    
    
      
         3 
         6 
         9 
    
  


Intermediate representation:
(scalarproduct nil (vectorml nil 3 6 9) (vectorml nil 3 6 9))


   
      
          3 
          6 
          9 
      
      
          3 
          6 
          9 
      
   
     

om2mml();



  
    
    
      
         3 
         6 
         9 
    
    
      
         3 
         6 
         9 
    
  


Intermediate representation:
(outerproduct nil (vectorml nil 3 6 9) (vectorml nil 3 6 9))


   
      
          3 
          6 
          9 
      
      
          3 
          6 
          9 
      
   
     



om2mml();



   
       
       
         
       
       
         
         
           
           
           
         
         
      
   


Intermediate representation:
(forall nil (bvar a 1) (eq nil (plus nil a 0) a))


   
      
          a 
      
      
         
             a 
             0 
         
          a 
      
   
  



om2mml();



  
     
     
       
     
     
       
       
         
         
         
       
       
     
   


Intermediate representation:
(forall nil (bvar a 1) (eq nil (times nil 1 a) a))


   
      
          a 
      
      
         
             1 
             a 
         
          a 
      
   
   


om2mml();



  
    
    
      
      
      
      
    
    
      
      
      
        
        
        
      
    
  


Intermediate representation:
(eq nil (semantic (bigfloat (o m s   c d = " b i g f l o a t 1 "   n a m e = " b
i g f l o a t " /)) m r e) (times nil m (power nil r e)))


   
      
         
            
               bigfloat
               
                  
               
            
         
          m 
          r 
          e 
      
      
          m 
         
             r 
             e 
         
      
   
   


% The integral symbols defint and int are ambigious as defined
% in the CDs. They do not specify their variable of integration
% explicitly. The following shows that when the function
% to integrate is defined as a lambda expression, then the
% bound variable is easily determined. However, in other
% cases, it is not possible to determine the bound variable.

om2mml();



 
    
    
      
      
        
      
      
        
        
      
    
  


Intermediate representation:
(int nil (bvar x 1) (sin nil x))


   
      
          x 
      
      
          x 
      
   
        

om2mml();



  
    
    
     
      
      
    
  


Intermediate representation:
(int nil (bvar x 1) (plus nil x y))


   
      
          x 
      
      
          x 
          y 
      
   


% Some calculus

om2mml();



  
    
    
      
      
        
        
          
        
        
          
          
          
        
      
    
    
  


Intermediate representation:
(eq nil (diff nil (bvar x 1) (plus nil x 1.0)) 1.0)


   
      
         
             x 
         
         
             x 
             1.0 
         
      
       1.0 
   



om2mml();



       
         
           
             
             
               
                1 
                3 
             
             
               
               
                 
                 
                 
               
               
                 
                 
                 
                 
               
             
           
         
       


Intermediate representation:
(eq nil (partialdiff nil (bvar z 1) (bvar x 1) (times nil x y z)) y)


   
      
         
             z 
         
         
             x 
         
         
             x 
             y 
             z 
         
      
       y 
   



om2mml();



  
     
     
       
       
     
     
       
       
         
          1 
         
       
       
         
         
           
         
         
      
    
  


Intermediate representation:
(eq nil (factorial nil n) (product nil (bvar i 1) (lowupperlimit nil 1 n) i))


   
      
          n 
      
      
         
             i 
         
         
             1 
         
         
             n 
         
          i 
      
   


                        
om2mml();



  
    
    
      
      
        
      
      
        
        
          
          
            
            
            
          
          
        
        
          
          
            
            
            
          
          
        
        
          
          
          
            
            
            
          
        
      
    
  


Intermediate representation:
(not nil (exists nil (bvar c 1) (and nil (in nil (divide nil a c) (semantic (z (
o m s   c d = " s e t n a m e 1 "   n a m e = " z " /)))) (in nil (divide nil b
c) (semantic (z (o m s   c d = " s e t n a m e 1 "   n a m e = " z " /)))) (gt
nil c (gcd nil a b)))))


   
      
         
             c 
         
         
            
               
                   a 
                   c 
               
               
                  z
                  
                     
                  
               
            
            
               
                   b 
                   c 
               
               
                  z
                  
                     
                  
               
            
            
                c 
               
                   a 
                   b 
               
            
         
      
   






om2mml();



  
    
    
      
    
    
      
      
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (implies nil &false; x))


   
      
          x 
      
      
          &false; 
          x 
      
   

                  


om2mml();



  
    
    
      
       1 
       9 
       5 
    
     9 
  


Intermediate representation:
(eq nil (max nil 1 9 5) 9)


   
      
          1 
          9 
          5 
      
       9 
   


% The following examples belong to the multiset CD

om2mml();



  
    
    
      
      
        
        
        
      
      
        
        
        
      
    
    
      
      
      
        
        
        
      
    
  


Intermediate representation:
(implies nil (and nil (in nil a a) (in nil a b)) (in nil a (intersect nil a b)))


   
      
         
             a 
             a 
         
         
             a 
             b 
         
      
      
          a 
         
             a 
             b 
         
      
   



om2mml();



  
    
     4 
     1 
     0 
     1 
     4 
  


Intermediate representation:
(set ((type multiset)) 4 1 0 1 4)


   
       4 
       1 
       0 
       1 
       4 
   


om2mml();



  
    
    
      
      
        
        
        
      
      
    
    
      
      
        
        
        
      
      
    
  


Intermediate representation:
(and nil (subset nil (intersect nil a b) a) (subset nil (intersect nil a b) b))


   
      
         
             a 
             b 
         
          a 
      
      
         
             a 
             b 
         
          b 
      
   


     
om2mml();



  
    
    
      
      
      
        
        
        
      
    
    
      
      
      
        
        
        
      
    
  


Intermediate representation:
(and nil (subset nil a (union nil a b)) (subset nil b (union nil a b)))


   
      
          a 
         
             a 
             b 
         
      
      
          b 
         
             a 
             b 
         
      
   



om2mml();



  
    
    
      
      
      
    
    
      
      
        
        
        
          
          
          
        
      
      
        
        
          
          
          
        
        
          
          
          
        
      
        
  


Intermediate representation:
(forall nil (bvar a 1) (bvar b 1) (bvar c 1) (eq nil (union nil a (intersect nil
b c)) (intersect nil (union nil a b) (union nil a c))))


   
      
          a 
      
      
          b 
      
      
          c 
      
      
         
             a 
            
                b 
                c 
            
         
         
            
                a 
                b 
            
            
                a 
                c 
            
         
      
   


om2mml();



  
    
    
      
      
      
    
    
  


Intermediate representation:
(subset nil (setdiff nil a b) a)


   
      
          a 
          b 
      
       a 
   


om2mml();



  
    
    
      
      
        
        
        
      
      
        
        
        
      
    
    
      
      
      
    
  


Intermediate representation:
(implies nil (and nil (subset nil b a) (subset nil c b)) (subset nil c a))


   
      
         
             b 
             a 
         
         
             c 
             b 
         
      
      
          c 
          a 
      
   


om2mml();



  
    
     4 
    
      
       1 
       1 
       2 
       3 
    
  


Intermediate representation:
(notin nil 4 (set ((type multiset)) 1 1 2 3))


   
       4 
      
          1 
          1 
          2 
          3 
      
   


om2mml();



  
    
    
      
       2 
       3 
    
    
      
       2 
       2 
       3 
    
  


Intermediate representation:
(prsubset nil (set ((type multiset)) 2 3) (set ((type multiset)) 2 2 3))


   
      
          2 
          3 
      
      
          2 
          2 
          3 
      
   



om2mml();



  
    
    
      
       2 
       3 
       3 
    
    
      
       1 
       2 
       3 
    
  


Intermediate representation:
(notsubset nil (set ((type multiset)) 2 3 3) (set ((type multiset)) 1 2 3))


   
      
          2 
          3 
          3 
      
      
          1 
          2 
          3 
      
   



om2mml();



  
    
    
      
       1 
       2 
       1 
    
    
      
       1 
       2 
       1 
    
  


Intermediate representation:
(notprsubset nil (set ((type multiset)) 1 2 1) (set ((type multiset)) 1 2 1))


   
      
          1 
          2 
          1 
      
      
          1 
          2 
          1 
      
   


% Examples from CD nums1

om2mml();



  
    
     8 
    
      
       8 
       10 
    
  


Intermediate representation:
(eq nil 8 (based_integer nil 8 (string 10)))


   
       8 
       10 
   



om2mml();



  
    
     1 
     2 
  


Intermediate representation:
(rational nil 1 2)


   12



om2mml();



 
   
   
             
     
   
   
     
     
       
       
       
     
     
       
       
       
         
         
         
       
     
   
 


Intermediate representation:
(forall nil (bvar x 1) (bvar y 1) (eq nil (plus nil x (times nil y &imaginaryi;)
) (plus nil x (times nil &imaginaryi; y))))


   
      
          x 
      
      
          y 
      
      
         
             x 
            
                y 
                &imaginaryi; 
            
         
         
             x 
            
                &imaginaryi; 
                y 
            
         
      
   



om2mml();




  
  
    
    
    
    
  
  
    
    
      
      
        
        
          
          
          
            
            
          
        
        
      
      
        
        
          
          
          
            
            
          
        
        
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  



Intermediate representation:
(forall nil (bvar x 1) (bvar y 1) (bvar r 1) (bvar a 1) (implies nil (and nil (
eq nil (times nil r (sin nil a)) y) (eq nil (times nil r (cos nil a)) x)) (eq
nil (times nil r (exp nil (times nil a &imaginaryi;))) (plus nil x (times nil y
&imaginaryi;)))))


   
      
          x 
      
      
          y 
      
      
          r 
      
      
          a 
      
      
         
            
               
                   r 
                  
                      a 
                  
               
                y 
            
            
               
                   r 
                  
                      a 
                  
               
                x 
            
         
         
            
                r 
               
                  
                      a 
                      &imaginaryi; 
                  
               
            
            
                x 
               
                   y 
                   &imaginaryi; 
               
            
         
      
   



om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
          
        
        
          
          
          
        
      
      
        
        
          
          
          
        
        
          
          
          
            
            
            
              
               2 
              
              
            
          
        
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (implies nil (and nil (in nil a (semantic (r (o m s   c d
= " s e t n a m e 1 "   n a m e = " r " /)))) (in nil k (semantic (z (o m s   c
d = " s e t n a m e 1 "   n a m e = " z " /))))) (eq nil (times nil x (exp nil (
times nil a &imaginaryi;))) (times nil x (exp nil (times nil (plus nil a (times
nil 2 π k)) &imaginaryi;))))))


   
      
          x 
      
      
         
            
                a 
               
                  r
                  
                     
                  
               
            
            
                k 
               
                  z
                  
                     
                  
               
            
         
         
            
                x 
               
                  
                      a 
                      &imaginaryi; 
                  
               
            
            
                x 
               
                  
                     
                         a 
                        
                            2 
                            π 
                            k 
                        
                     
                      &imaginaryi; 
                  
               
            
         
      
   


om2mml();



  
    
    
    
      
      
        
        
        
      
      
        
        
          
        
        
          
          
          
            
            
          
        
      
    
  


Intermediate representation:
(eq nil ⅇ (sum nil (bvar j 1) (lowupperlimit nil 0 ∞) (divide
nil 1 (factorial nil j))))


   
       ⅇ 
      
         
             j 
         
         
             0 
         
         
             ∞ 
         
         
             1 
            
                j 
            
         
      
   



om2mml();



  
    
    
      
      
       2 
    
    
      
      
    
  


Intermediate representation:
(eq nil (power nil &imaginaryi; 2) (minus nil 1))


   
      
          &imaginaryi; 
          2 
      
      
          1 
      
   



om2mml();



  
    
    
      
      
    
    
      
      
      
        
        
          
          
          
        
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (bvar y 1) (eq nil y (imaginary nil (plus nil x (times
nil y &imaginaryi;)))))


   
      
          x 
      
      
          y 
      
      
          y 
         
            
                x 
               
                   y 
                   &imaginaryi; 
               
            
         
      
   



om2mml();



  
    
    
      
      
    
    
      
      
      
        
        
          
          
          
        
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (bvar y 1) (eq nil x (real nil (plus nil x (times nil y
&imaginaryi;)))))


   
      
          x 
      
      
          y 
      
      
          x 
         
            
                x 
               
                   y 
                   &imaginaryi; 
               
            
         
      
   


om2mml();



  
    
    
      
      
      
    
    
      
      
      
    
  


Intermediate representation:
(implies nil (in nil a (semantic (r (o m s   c d = " s e t n a m e 1 "   n a m e
= " r " /)))) (lt nil x ∞))


   
      
          a 
         
            r
            
               
            
         
      
      
          x 
          ∞ 
      
   


om2mml();



  
    
    
    
  


Intermediate representation:
(neq nil ¬anumber; ¬anumber;)


   
       ¬anumber; 
       ¬anumber; 
   


om2mml();



  
    
    
    
      
      
        
        
        
      
      
        
        
          
        
        
          
          
            
            
            
              
              
                
                 4 
                
              
              
            
          
          
            
            
            
              
              
                
                 4 
                
              
              
            
          
        
      
    
  


Intermediate representation:
(eq nil π (sum nil (bvar j 1) (lowupperlimit nil 0 ∞) (minus nil (
divide nil 1 (plus nil (times nil 4 j) 1)) (divide nil 1 (plus nil (times nil 4
j) 1)))))


   
       π 
      
         
             j 
         
         
             0 
         
         
             ∞ 
         
         
            
                1 
               
                  
                      4 
                      j 
                  
                   1 
               
            
            
                1 
               
                  
                      4 
                      j 
                  
                   1 
               
            
         
      
   


om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
            
            
          
          
        
        
       
       
         
         
         
           
           
         
       
     
  


Intermediate representation:
(forall nil (bvar x 1) (and nil (lt nil (minus nil (semantic (ceiling (o m s   c
d = " r o u n d i n g 1 "   n a m e = " c e i l i n g " /)) x) 1) x) (leq nil x
(semantic (ceiling (o m s   c d = " r o u n d i n g 1 "   n a m e = " c e i l i
n g " /)) x))))


   
      
          x 
      
      
         
            
               
                  
                     
                        ceiling
                        
                           
                        
                     
                  
                   x 
               
                1 
            
             x 
         
         
             x 
            
               
                  
                     ceiling
                     
                        
                     
                  
               
                x 
            
         
      
   




om2mml();



  
    
    
      
       1   2   3 
    
     3 
  


Intermediate representation:
(eq nil (mean nil 1 2 3) 3)


   
      
          1 
          2 
          3 
      
       3 
   




om2mml();



  
     
      
      
      
     
      
      
     
     
      
      
     
     
     
   


Intermediate representation:
(sdev nil 3.1 2.2 1.8 1.1 3.3 2.4 5.5 2.3 1.7 1.8 3.4 4.0 3.3)


   
       3.1 
       2.2 
       1.8 
       1.1 
       3.3 
       2.4 
       5.5 
       2.3 
       1.7 
       1.8 
       3.4 
       4.0 
       3.3 
   




om2mml();



  
    
    
      
      
        
        
        
      
      
    
    
      
      
        
        
        
      
      
    
  


Intermediate representation:
(implies nil (eq nil (power nil a b) c) (eq nil (log nil a c) b))


   
      
         
             a 
             b 
         
          c 
      
      
         
            
                a 
            
             c 
         
          b 
      
   


om2mml();



  
    
    
      
      
        
        
      
      
        
        
          
          
        
      
    
    
      
      
        
        
          
          
        
      
      
    
  


Intermediate representation:
(and nil (lt nil (minus nil π) (imaginary nil (ln nil x))) (leq nil (
imaginary nil (ln nil x)) π))


   
      
         
             π 
         
         
            
                x 
            
         
      
      
         
            
                x 
            
         
          π 
      
   





om2mml();



  
    
    
      
      
    
    
      
      
        
        
          
           1 
           0 
           0 
        
        
          
          
            
             1 
          
          
        
      
      
        
        
          
           0 
           1 
           0 
        
        
          
          
            
             2 
          
          
        
      
      
        
        
          
           0 
           0 
           1 
        
        
          
          
            
             3 
          
          
        
      
    
  


Intermediate representation:
(eq nil (curl nil f) (plus nil (vectorproduct nil (vectorml nil 1 0 0) (
partialdiff nil f)) (vectorproduct nil (vectorml nil 0 1 0) (partialdiff nil f))
(vectorproduct nil (vectorml nil 0 0 1) (partialdiff nil f))))


   
      
          f 
      
      
         
            
                1 
                0 
                0 
            
            
                f 
            
         
         
            
                0 
                1 
                0 
            
            
                f 
            
         
         
            
                0 
                0 
                1 
            
            
                f 
            
         
      
   



om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
        
        
          
          
        
      
      
        
        
          
          
        
        
      
    
  


Intermediate representation:
(forall nil (bvar x 1) (and nil (lt nil (minus nil π) (arg nil x)) (leq nil (
arg nil x) π)))


   
      
          x 
      
      
         
            
                π 
            
            
                x 
            
         
         
            
                x 
            
             π 
         
      
   



om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
        
      
      
    
 


Intermediate representation:
(forall nil (bvar a 1) (eq nil (inverse nil (inverse nil a)) a))


   
      
          a 
      
      
         
            
                a 
            
         
          a 
      
   


% An example of elements which do not have a MathML 
% equivalent. This example comes from the fns1 CD

om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
            
             1 
            
            
          
        
      
      
        
        
        
          
          
            
            
             1 
          
        
         2 
      
    
  


Intermediate representation:
(forall nil (bvar n 1) (eq nil (semantic (apply_to_list (o m s   c d = " f n s 2
"   n a m e = " a p p l y _ t o _ l i s t " /)) (plus nil (semantic (make_list (
o m s   c d = " l i s t 1 "   n a m e = " m a k e _ l i s t " /)) 1 n (semantic
(identity (o m s   c d = " f n s 1 "   n a m e = " i d e n t i t y " /)))))) (
divide nil (times nil n (plus nil n 1)) 2)))


   
      
          n 
      
      
         
            
               
                  apply_to_list
                  
                     
                  
               
            
            
               
                  
                     
                        make_list
                        
                           
                        
                     
                  
                   1 
                   n 
                  
                     identity
                     
                        
                     
                  
               
            
         
         
            
                n 
               
                   n 
                   1 
               
            
             2 
         
      
   



om2mml();



  
    
    
      
      
        
        
      
    
    
  


Intermediate representation:
(eq nil (determinant nil (semantic (identity (o m s   c d = " l i n a l g 3 "  
n a m e = " i d e n t i t y " /)) n)) 1)


   
      
         
            
               
                  identity
                  
                     
                  
               
            
             n 
         
      
       1 
   



om2mml();



  
    
    
      
      
        
        
          
           0 
           1 
        
        
          
           2 
           3 
        
      
    
    
      
      
        
         0 
         2 
      
      
        
         1 
         3 
      
    
  


Intermediate representation:
(eq nil (transpose nil (matrix nil matrixrow ((0 1) (2 3)))) (matrix nil
matrixrow ((0 2) (1 3))))


   
      
         
            
                0 
                1 
            
            
                2 
                3 
            
         
      
      
         
             0 
             2 
         
         
             1 
             3 
         
      
   




om2mml();



  
    
    
      
      
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  


Intermediate representation:
(equivalent nil (equivalent nil a b) (and nil (implies nil a b) (implies nil b a
)))


   
      
          a 
          b 
      
      
         
             a 
             b 
         
         
             b 
             a 
         
      
   

om2mml();



  
    
      
      
    
    
  


Intermediate representation:
(ci ((type complex_polar)) z)


   z


% Examples of assigning types to variables.

om2mml();


      
         
           
              
              
           
           
         
       

Intermediate representation:
(ci ((type integer)) z)


   z


om2mml();


       
         
           
              
              
           
           
         
       

Intermediate representation:
(ci ((type real)) z)


   z


om2mml();


       
         
           
              
              
           
           
         
       

Intermediate representation:
(ci ((type rational)) z)


   z



% These examples show the use of attributions within OpenMath
% expressions.


om2mml();



   
     
       
          
          
       
       
     
     1
     2
     3
   


Intermediate representation:
(f nil 1 2 3)


   
      
         f
      
       1 
       2 
       3 
   


om2mml();



  
    
    
      
        
        
      
    
    
    
      
      
    
  


Intermediate representation:
(times nil (ci ((type matrix)) a) (sin nil x))


   
      a
      
          x 
      
   
   


om2mml();



  
    
    2
    
      
       3 
       6 
       9 
         
  


Intermediate representation:
(selector nil (vectorml nil 3 6 9) 2)


   
      
          3 
          6 
          9 
      
       2 
   


om2mml();



  
    
    2
    
      
       0 
       1 
       0 
         
  


Intermediate representation:
(selector nil (semantic (matrixrow (o m s   c d = " l i n a l g 1 "   n a m e =
" m a t r i x r o w " /)) 0 1 0) 2)


   
      
         
            
               matrixrow
               
                  
               
            
         
          0 
          1 
          0 
      
       2 
   



om2mml();



  
    
    
      
    
    
      
      
        
        
          
          
            
            
              
              
            
            
              
              
            
          
          
        
        
          
          
            
            
          
          
            
            
          
        
      
      
        
        
          
          
          
            
            
              
              
            
            
              
              
            
          
        
        
          
          
            
            
          
          
            
            
          
        
      
    
  


Intermediate representation:
(forall nil (bvar m 1) (and nil (eq nil (times nil (semantic (zero (o m s   c d
= " l i n a l g 3 "   n a m e = " z e r o " /)) (semantic (rowcount (o m s   c d
= " l i n a l g 3 "   n a m e = " r o w c o u n t " /)) m) (semantic (rowcount (
o m s   c d = " l i n a l g 3 "   n a m e = " r o w c o u n t " /)) m)) m) (
semantic (zero (o m s   c d = " l i n a l g 3 "   n a m e = " z e r o " /)) (
semantic (rowcount (o m s   c d = " l i n a l g 3 "   n a m e = " r o w c o u n
t " /)) m) (semantic (columncount (o m s   c d = " l i n a l g 3 "   n a m e = "
c o l u m n c o u n t " /)) m))) (eq nil (times nil m (semantic (zero (o m s   c
d = " l i n a l g 3 "   n a m e = " z e r o " /)) (semantic (columncount (o m s
  c d = " l i n a l g 3 "   n a m e = " c o l u m n c o u n t " /)) m) (semantic
(columncount (o m s   c d = " l i n a l g 3 "   n a m e = " c o l u m n c o u n
t " /)) m))) (semantic (zero (o m s   c d = " l i n a l g 3 "   n a m e = " z e
r o " /)) (semantic (rowcount (o m s   c d = " l i n a l g 3 "   n a m e = " r o
w c o u n t " /)) m) (semantic (columncount (o m s   c d = " l i n a l g 3 "   n
a m e = " c o l u m n c o u n t " /)) m)))))


   
      
          m 
      
      
         
            
               
                  
                     
                        zero
                        
                           
                        
                     
                  
                  
                     
                        
                           rowcount
                           
                              
                           
                        
                     
                      m 
                  
                  
                     
                        
                           rowcount
                           
                              
                           
                        
                     
                      m 
                  
               
                m 
            
            
               
                  
                     zero
                     
                        
                     
                  
               
               
                  
                     
                        rowcount
                        
                           
                        
                     
                  
                   m 
               
               
                  
                     
                        columncount
                        
                           
                        
                     
                  
                   m 
               
            
         
         
            
                m 
               
                  
                     
                        zero
                        
                           
                        
                     
                  
                  
                     
                        
                           columncount
                           
                              
                           
                        
                     
                      m 
                  
                  
                     
                        
                           columncount
                           
                              
                           
                        
                     
                      m 
                  
               
            
            
               
                  
                     zero
                     
                        
                     
                  
               
               
                  
                     
                        rowcount
                        
                           
                        
                     
                  
                   m 
               
               
                  
                     
                        columncount
                        
                           
                        
                     
                  
                   m 
               
            
         
      
   



om2mml();



   
      
       1 
      
        
          
          
        
        
              
        


Intermediate representation:
(selector nil (ci ((type vectorml)) a) 1)


   
      a
       1 
   


om2mml();



   
      
       1 
       1 
      
        
          
          
        
        
              
        


Intermediate representation:
(selector nil (ci ((type matrix)) a) 1 1)


   
      a
       1 
       1 
   



% The following two examples were produced by REDUCE in MathML with the
% MathML interface, then translated to OpenMath. It is now possible to
% translate them back to MathML.

om2mml();



  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                
              
            
            
              
              
                
                
                  
                  
                    
                    
                      
                    
                    
                      
                      
                      
                    
                  
                
                
                                            
            
            
            
          
          
          
        
      
      
        
        
        
          
          
          
        
      
    
  


Intermediate representation:
(list nil (list nil (eq nil x (root_of nil (plus nil (minus nil (power nil y x_)
) (minus nil (times nil (int nil (bvar x_ 1) (power nil x_ x_)) y)) x_ y) x_
tag_1)) (eq nil a (plus nil x y))))


   
      
         
             x 
            
               
                  root_of
               
               
                  
                     
                         y 
                         x_ 
                     
                  
                  
                     
                        
                           
                               x_ 
                           
                           
                               x_ 
                               x_ 
                           
                        
                         y 
                     
                  
                   x_ 
                   y 
               
                x_ 
                tag_1 
            
         
         
             a 
            
                x 
                y 
            
         
      
   
      




om2mml();



  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                  
                  
                  
                
              
              
            
            
              
              
                
                
                
              
            
            
              
              
              
                
                
                 1 
              
            
            
              
                                               
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
                
                
                 2 
              
            
            
              
              
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
            
          
          
          
        
      
      
        
        
        
      
    
  


Intermediate representation:
(list nil (list nil (eq nil x (root_of nil (plus nil (times nil (exp nil (plus
nil &imaginaryi; x_)) y) (exp nil (plus nil &imaginaryi; x_)) (power nil x_ (
plus nil y 1)) (times nil (int nil (bvar x_ 1) (power nil x_ x_)) (power nil y 2
)) (times nil (int nil (bvar x_ 1) (power nil x_ x_)) y)) x_ tag_2)) (eq nil z y
)))


   
      
         
             x 
            
               
                  root_of
               
               
                  
                     
                        
                            &imaginaryi; 
                            x_ 
                        
                     
                      y 
                  
                  
                     
                         &imaginaryi; 
                         x_ 
                     
                  
                  
                      x_ 
                     
                         y 
                         1 
                     
                  
                  
                     
                        
                            x_ 
                        
                        
                            x_ 
                            x_ 
                        
                     
                     
                         y 
                         2 
                     
                  
                  
                     
                        
                            x_ 
                        
                        
                            x_ 
                            x_ 
                        
                     
                      y 
                  
               
                x_ 
                tag_2 
            
         
         
             z 
             y 
         
      
   
                     
om2mml();



 
    
       
       
    
     0   
  


Intermediate representation:
(cn ((type integer)) 0)


   0


om2mml();



  
    
      
      
    
      
  


Intermediate representation:
(cn ((type semantic)) 1.0)


   1.0


om2mml();


 
  
    
    
    
   


Intermediate representation:
(plus nil x (times nil y &imaginaryi;))


   
       x 
      
          y 
          &imaginaryi; 
      
   
 

om2mml();


 
  
    
    
    
   


Intermediate representation:
(times nil x (exp nil (times nil y &imaginaryi;)))


   
       x 
      
         
             y 
             &imaginaryi; 
         
      
   
 

om2mml();


 
  
    
    
    
   


Intermediate representation:
(divide nil x y)


   
       x 
       y 
   
 

om2mml();


 
  
    
    4
    2
   


Intermediate representation:
(complex_cartesian nil 4 2)


    4  2 
 

om2mml();


 
  
    
    4
    2
   


Intermediate representation:
(complex_polar nil 4 2)


    4  2 
 

om2mml();


 
  
    
    4
    2
   


Intermediate representation:
(rational nil 4 2)


   42
 

end;


end;


Time for test: 47 ms
@@@@@ Resources used: (0 0 344 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/om2ir.red0000644000175000017500000002753411526203062023525 0ustar  giovannigiovanni
% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

omfuncs!*:=
'((oma . (omaIR))
(oms . (omsIR))
(omi . (omiIR))
(omv . (omvIR))
(omf . (omfIR))
(omstr . (omstrIR))
(ombind . (ombindIR))
(omattr . (omattrIR)));

symbolic procedure om2ir();
begin scalar res;
 % Initialisation of important variables used by the lexer.

 res:=nil;
 FLUID '(safe_atts char ch atts count temp space temp2);
 space:=int2id(32);
 count:=0;
 ch:=readch();
 temp2:=nil;

 % Begining of lexing and parsing

 lex();
 if char='(o m o b j) then <<
     lex();
     res:=omobj();
 >>
   else errorML("",2);

 lex();

 if char='(!/ o m o b j) then
   terpri()
   else errorML("",19);

 return res;
end;

symbolic procedure omobj();
begin scalar aa, res;
  % We check what the OpenMath tag is and call the appropriate function. The relationship
  % between OpenMath tag and function to be called is in table omfuncs!*.
  if (aa:=assoc(compress!* char, omfuncs!*)) then return apply(cadr aa, nil);
end;

% The following function recursively reads in objects as defined in
% the OpenMath grammar in the OpenMath standard.

symbolic procedure omobjs();
begin scalar obj, objs;
  if char neq '(!/ o m a) then <<
    obj:=omobj();
    lex();
    objs:=omobjs();
    if obj eq nil then
     return append(obj, objs)
    else
     return cons(obj, objs);
  >>;
end;

% Checks if the current token is equivalent to the given tag.

symbolic procedure checkTag(tag);
begin;
  if char neq tag then errorML("Problem", "problem");
end;

% This function returns the symbol read within an  tag.
% It will also check in the mmleq!* table what the equivalent
% MathML symbol is. If there isnt any it encodes the symbol
% for use in a  tag.

symbolic procedure omsIR();
begin scalar cd, name, sem, aa, bb, cd, attr, symb, validcd;
  attr:=nil;

  % We read in from the input the name and CD contained
  % in the OMS tag.

  name:= intern find(atts, 'name);
  cd:= intern find(atts, 'cd);

  % We check if the symbol has a MathML equivalent
  % in the mmleq!* table.
  % But when dealing with a vector, REDUCE works differently
  % hence we have to deal with vectors independently.

  if explode name = '(v e c t o r) then aa:='(vectorml linalg1)
  else aa:=member (intern name, mmleq!*);


  % If nothing was found, we check to see if we are
  % dealing with a special case.
  % If so, we retrieve from the table special_cases!*
  % the equivalent MathML symbol and the correct
  % attribute to add.

  if aa=nil then <<
    if (aa:=assoc(name, special_cases!*)) then <<
      attr:=car reverse aa;
      if attr neq nil then attr:=list attr;
      aa:=cadr reverse aa . reverse cddr reverse cdr aa
    >>
    else
      % Here we call special case functions
      % because the tranlation needs some care.
      if (bb:=assoc(name, special_cases2!*)) neq nil then <<
        return apply(cadr bb, cddr bb)
      >>;
  >>;




  % We now check if aa is still nothing, or if the CD
  % given in the input does not match one of the CDs
  % contained in aa which map to MathML. If so, we
  % envelope the input into a semantic tag.


  if aa neq nil then validcd:= assoc(car aa, valid_om!*);
  if validcd neq nil then validcd:=cadr validcd;
  %debug("validcd: ",validcd);

  if aa eq nil OR cd=validcd eq nil then <<
    sem:=encodeIR(name);
    return sem;
  >>;

  % If we are dealing with a vector, we change it to IR rep which
  % is vectorml

  return list(car aa, attr);
end;

% The following function encodes an unknown symbol into a
% valid representation for use within  tags.

symbolic procedure encodeIR(name);
begin scalar sem;
  sem:=append(char, cons('!  , atts));
  sem:=delall('!$, sem);
  return cons('semantic, list cons(name, list sem));
end;

lisp operator om2mml;

symbolic procedure omiIR();
begin scalar int;
  lex();
  int := compress char;
  lex();
  return int;
end;

symbolic procedure omvIR();
begin scalar name;
  name:=find(atts, 'name);
  if find(atts, 'hex) neq nil then errorML("wrong att", 2);
  if find(atts, 'dec) neq nil then errorML("wrong att", 2);
  return name;
end;

symbolic procedure variablesIR();
begin scalar var, vars;
  if char neq '(!/ o m b v a r) then <<
    var:=omvIR();
  lex();
    vars:=variablesIR();
    if var eq nil then
     return append(var, vars)
    else
     return cons(var, vars);
  >>;
end;

symbolic procedure omfIR();
begin scalar float;
  float:=find(atts, 'dec);
  if find(atts, 'name) neq nil then errorML("wrong att", 2);
  return float;
end;

symbolic procedure omstrIR();
begin scalar str;
  lex();
  str := compress char;
  lex();
  return cons('string, list str);
end;

symbolic procedure omaIR();
begin scalar obj, elems;
  lex();
  obj:=omobj();

  % If we are dealing with a matrix the following code
  % is not executed because the MatrixIR function
  % does the input reading and checks when it has
  % reached the closing  tag.

  if car obj neq 'matrix then <<
    lex();
    elems:=omobjs();
    checkTag('(!/ o m a));
  >>;

  return append(obj, elems);
end;

symbolic procedure ombindIR();
begin scalar symb, vars, obj;
  lex();
  symb:=omobj();
  lex();
  vars:=toBvarIR variablesIR();
  lex();
  obj:=omobj();
  lex();
  checkTag('(!/ o m b i n d));
  return append(symb , append(vars, list obj));
end;

symbolic procedure omattrIR();
begin scalar omatp, var;
  lex();
  omatp:=omatpIR();
  lex();
  var:=omobj();
  lex();
  checkTag('(!/ o m a t t r));
  if PAIRP omatp then if cadar omatp = 'csymbol then return (var . list nil);
  if NUMBERP var then return list('cn, omatp, var);
  return list('ci, omatp, var);
end;

symbolic procedure omatpIR();
begin scalar symb ,obj;
  lex();
  symb:=car omsIR();

  lex();
  obj:=car omobj();

  lex();
  checkTag('(!/ o m a t p));

  return list (symb . list obj);
end;

% The following function transforms a list of variables
% into a list of bvar constructs. ie: (x y)->((bvar x 1)(bvar y 1))

symbolic procedure toBvarIR(bv);
begin;
  if bv neq nil then return cons(cons('bvar, list(car bv, 1)), toBvarIR(cdr bv));
end;


% From here onwards, functions necessary to deal with
% OpenMath special operators are defined. This is where
% matrix, int, sum, prod, diff etc... are treated.

symbolic procedure matrixIR();
begin scalar res;
  lex();
  res:=omobjs();
  if caadr cadr res = 'matrixcolumn then res := 'matrixcolumn . list matrixelems(res)
  else res := 'matrixrow . list matrixelems(res);
  return 'matrix . nil . res;
end;

symbolic procedure matrixelems(elem);
  if elem neq nil then cons(cddr car elem, matrixelems cdr elem);

symbolic procedure sum_prodIR();
begin scalar var, fun, int, name;
  name:=intern find(atts, 'name);
  lex();
  int:=omobj();
  int:='lowupperlimit . (cdr int);
  lex();
  fun:=omobj();
  var:=lambdaVar fun;
  fun:=lambdaFun fun;
  return append(list(name , nil) , append(var  , int . list fun));
  return name . nil . var . int . list fun;
end;

symbolic procedure integralIR();
begin scalar int, fun, var, tag;
  tag:=intern find(atts, 'name);

  var:=list '(bvar x 1);
  int:=nil;

  % if dealing with defint, determine the interval
  % and store inside variable int

  if tag = 'defint then <<
    lex();
    int:=omobj();
  >>;

  lex();
  fun:=omobj();

  if PAIRP fun then if car fun = 'lambda then <<
      var:=lambdaVar fun;
      fun:=lambdaFun fun;
  >>;
  return append(list(tag , nil) , append(var  , list fun));
end;

symbolic procedure partialdiffIR();
begin scalar lis, fun, var, tag, vars;
  tag:=intern find(atts, 'name);

  lex();
  lis:=omobj();

  if car lis='list then lis:=cddr lis
  else errorML("",3);

  lex();
  fun:=omobj();

  if PAIRP fun then
    if car fun = 'lambda then <<
       var:=lambdaVar fun;
       fun:=lambdaFun fun;
       vars:= pdiffvars(lis, var);
    >>;

  return append(list('partialdiff , nil) , append(vars  , list fun));
end;

symbolic procedure pdiffvars(ind, v);
begin;
  return if ind neq nil then nth(v, car ind) . pdiffvars(cdr ind, v);
end;

symbolic procedure selectIR();
begin scalar name, cd, a,b, c, tag;
  name:=intern find(atts, 'name);
  cd:=intern find(atts, 'cd);
  tag:=list 'selector;
  if member(cd, '(linalg3)) eq nil then tag:=encodeIR(name);
  lex();
  a:=omobj();
  if name='matrix_selector then <<
  lex();
  b:=omobj();
  >>;
  lex();
  c:=omobj();
  if name='matrix_selector then <<
    return append(tag,  nil . c . a . list b);
  >>;
  return append(tag,  nil . c . list a);
end;


symbolic procedure limitIR();
begin scalar val, type, cd, fun, var, res, tag;
  cd:=intern find(atts, 'cd);
  tag:=list 'limit;
  if member(cd, '(limit1)) eq nil then tag:=encodeIR('limit);
  lex();
  val:=omobj();
  lex();
  type:=omobj();
  lex();
  fun:=omobj();




  % Extract the necessary information from the OpenMath read in just above.
  type:=caadr type;

  if member(type, '(below above both_sides null)) eq nil then errorML("wrong method of approach", 2);
  if type='null then type:='both_sides;

  var:= lambdaVar fun;
  fun:= lambdaFun fun;

  % Transform that information into intermediate representation.
  res:= append(tag, (nil . var ));
  if type neq 'both_sides then
    res:= append(res , list ('condition . list ('tendsto . list ('type . list type) . cadr car var . list val)))
  else
    res:= append(res , list ('condition . list ('tendsto . nil . cadr car var . list val)));
  res:= append(res, list fun);

  return res;
end;

symbolic procedure numIR();
begin scalar base, a1, a2, tag;
  tag:=intern find(atts, 'name);
  lex();
  a1:=omobj();
  lex();
  a2:=omobj();

  if tag = 'complex_cartesian then <<
    if IDP a1 OR IDP a2 then return 'plus . nil . a1 . list ('times . nil . a2 . list '!&imaginaryi!;)
  >>;

  if tag = 'complex_polar then <<
    if IDP a1 OR IDP a2 then return 'times . nil . a1 . list ('exp . nil . list ('times . nil . a2 . list '!&imaginaryi!;))
  >>;

  if tag = 'rational then <<
    if IDP a1 OR IDP a2 then return 'divide . nil . a1 . list a2;
  >>;

  return tag . nil . a1. list a2;

end;

% The following function deals with OpenMath symbols
% not taking any arguments such as false, true, zero, etc...

symbolic procedure unaryIR(validcd, tag);
begin scalar name, cd;
  name:=intern find(atts, 'name);
  cd:=intern find(atts, 'cd);
  if cd neq validcd then return encodeIR name;
  return tag;
end;

% Returns the first main variable of a lambda expression

symbolic procedure lambdaVar(l);
begin;
  return cdr reverse cddr l;
end;

symbolic procedure lambdaVar2(l);
begin;
  return cadr caddr l;
end;

% Returns the function of a lambda expression

symbolic procedure lambdaFun(l);
begin;
  return car reverse l;
end;


% This function is the one the user types to
% translate OpenMath to MathML.


symbolic procedure om2mml();
begin scalar ir;
  ir:=om2ir();
  terpri!* t;
  princ "Intermediate representation:";
  terpri!* t;
  princ ir;
  terpri!* t;
  ir2mml ir;
end;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/tools.red0000644000175000017500000003473011526203062023631 0ustar  giovannigiovanni%  Description: This file contains various important functions which are used by all modules
%                of the program. Of importance is the lexer, and the functions dealing with
%                XML attributes for both OpenMath and MathML as well as the error message
%                generator.
%
%  Date: 25 March 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%

% Declaration of two switches.
% _mathml_ allows all output to be printed in mathml.
% _both_ allows all output to be printed in mathml and in normal reduce
% output.

load assist;
load matrix;


global '(f dfunctions!* file!*);

%Initialisation of REDUCE switches.

global '(!*mathml);
switch mathml;
global '(!*both);
switch both;
global '(!*web);
switch web;

LISP (FILE!*:=nil);
!*mathml:=nil;
!*both:=nil;
!*web:=nil;

off both;
off mathml;
off web;



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following functions are the lexer. When called they return the next       %
% mathml token in the input stream.                                           %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure lex();
begin scalar token,safe_atts;
% princ "Char: ";print char;
 token:=nil;
 char:=nil;
 if atts neq nil then safe_atts:=atts;
 atts:=nil;
 if ch eq int2id(10) then ch:=readch();
 if ch neq !$EOF!$ then <<
   if ch=space then while (ch:=readch())=space do
   else
    if ch='!< then char:=get_token()
    else char:=get_content();

    if char neq nil then
     <<  count:=count+1;
         token:=reverse char;
         if notstring char then <<
            char:=butes(token);          % a token is striped from its attributes.
            isvalid(char);               % Make sure token is not a string
            attributes(char,token)>>     % and they are stored by the function attributes
     >>
    else lex(); >>
end;

% Returns anything until the XML element '>' closing character

symbolic procedure get_token();
begin scalar d;
 d:='();
 while (ch:=readch()) neq '!> do d:=cons(ch,d);
 return cons('!$,d);
end;


% This function reads the elements within XML tags. It will skip and ignore
% unnecessary spaces. However if the element is a string then it will keep
% the spaces.

symbolic procedure get_content();
begin scalar d, d2;
 d:='();
 while (ch:=readch()) neq '!< AND ch neq !$EOF!$  do <<
   if ch neq int2id(10) then
   d:=cons(ch,d)
 >>;
 d2:=delall('!  , d);
 if d2 eq nil then d:=nil
 else
   <>;
 if d neq nil then d:=cons('!$,d);
 return d;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following fuctions deal with XML attributes.                                 %
%                                                                                  %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


% The following function will search a list of attributes _att_ for the attribute
% named _key_. It is useful for getting the value of a particular attribute from
% a MathML token which contains various attributes

symbolic procedure search_att( att, key);
begin scalar l, stop,d;
 l:=nil;
 d:=();
 stop:=0;
 att:= find2(att, key);
 if att neq '(stop) then
 <<
 while (car att='! ) do att:=cdr att;
 if (car att = '!=) then
   <<
     att:=cdr att;
     while (car att='! ) do att:=cdr att;
     if (car att='!") then
      << att:=cdr att;
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
      >>
      else
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
   >>
 else
 errorML(compress key,1);
 if car d='!" then d:=cdr d;
 return reverse d
 >>
end;

% _attributes(a,b)_ reads the attributes of a MathML token and
% stores them in global variable atts

symbolic procedure attributes(a,b);
begin scalar l;
 l:=length a;
 for a:=1:l do b:=cdr b;
 while (car b='! ) do b:=cdr b;
 if b neq '(!$) then  atts:=b;
end;

% butes removes all attributes to a token. Necessary when parsing. The attributes of the
% current character are always stored in atts in case they are necessary.

symbolic procedure butes( str );
begin scalar cha;
cha:=car str;
return if (cha='!  OR cha='!$) then <<'(); >>
        else  cons(car str, butes cdr str);
end;



% This function takes a list of attributes
% and their corresponding values _fatt_ and
% the name of the attribute wanted _fkey_.
% It then returns the value of that attribute.
% eg: find('...., 'type);

symbolic procedure find(fatt, fkey);
begin scalar a;
  fkey := explode fkey;
  a:=find2(fatt, fkey);
%  debug("find a: ",a);
  if car a neq '!= then a:=find2(a, fkey);
%  debug("find a: ",a);
%  debug("",);
  a:=delall('!", a);
  a:=delall('!=, a);
  a:=delall('!$, a);
  if a neq '(stop) then
    if car reverse a = '!/ then
        a:=reverse cdr reverse a;              %will remove the !/ character at the end.
  if a neq '(stop) then
    if fkey = '(d e f i n i t i o n u r l)  then return delall('!  ,a)
    else return compress!* a
  else return nil;
end;

symbolic procedure compress!* u;
   begin scalar x;
      if digit car u then return compress u;
      for each j in u do
         if j eq '!/ or j eq '!- or j eq '!; or j eq '!.
            then x := j . '!! . x
          else x := j . x;
      return intern compress reversip x
   end;

symbolic procedure find2(fatt, fkey);
begin;
return if fkey= '() then if fatt neq nil then cdr fatt else '(stop)
          else
          find2(member(car fkey, fatt), cdr fkey);
end;

% Given a list of attributes _ats_ and a list of attributes
% of interest _list_ it will return a list containing
% the attribute names and their corresponding attribute values.

symbolic procedure retattributes( ats, list );
begin scalar a;
  if list eq nil then nil
         else <<
            a:=find(ats, car list);
            if a neq nil then
                return cons(list(car list, a ), retattributes(ats,cdr list))
            else return retattributes(ats,cdr list);
         >>;
end;



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  The following functions are handy tools. Some of them are very useful      %
%  Others are modifications of REDUCE functions which were not perfectly   %
%  suitable for the tasks required by this program                               %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



% When a token has its attributes stripped off, it looses the !/ character
% at the end. This function restores this character only if the token is valid.
% It is valid if it is part of the functions!* list. If not it doesn't restore
% the !/ character and calls an error

symbolic procedure isvalid(a);
begin;
   if IDP compress a neq t then return compress a;
   if assoc(compress!* a, functions!*) then return t;
   a:=reverse cons('!/,  reverse a);
   if assoc(compress!* a, functions!*) then <>;
   return nil;
end;

% This function checks that a given token or element
% produced by the lexer is not a string.

symbolic procedure notstring(a);
begin scalar a, a2;
 a2:=delall('!  , a);
 if car a2 neq '!"  AND car reverse a2 neq '!"
 then return t else return nil;
end;

% This function will take a list as argument and return a list where
% only one copy is kept of elements appearing more than once.

symbolic procedure norepeat(args);
begin;
return if args=nil then nil else
 if length args=1 then list car args
 else append(list car args, norepeat(delall(car args, cdr args)));
end;

% This function will delete all occurences of element x in list l

symbolic procedure delall(x,l);
if l=nil then nil
else if x=car l then delall(x, cdr l)
     else append(list car l ,delall(x, cdr l));


% This function takes a list of characters and prints them out together.
% It is like compress but works better when it comes to uniting and
% printing the elements of a list.

symbolic procedure list2string(a);
begin;
  if a neq nil then <>;
end;

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% The following function is in charge of providing the correct error message        %
% as well as closing the input/output stream, and exiting the program              %
% correctly.                                                                     %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure errorML( str, msg );
begin;
 terpri();
 princ "***** Error in token number ";
 princ count;
 princ " (<";
 princ compress char;
 princ ">)";
 terpri();
 if msg=1 then
  << princ "Needed attribute";
     princ str;
     princ " and none was found.">> else
 if msg=2 then
  << princ "Missing tag: ";
     princ str >> else
 if msg=3 then
  << princ "Undefined error!" >> else
 if msg=4 then
  << princ "Numerical constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=5 then
  << princ "All arguments must be sets";
     terpri();
     princ str;
     princ " does not represent a set.">> else
 if msg=6 then
  << princ "Non-numeric argument in arithmetic.">> else
 if msg=7 then
  << princ "The degree quantifier is of no use in the sumation";
     princ "operator.">> else
 if msg=8 then
  << princ "The degree quantifier is of no use in the limit";
     princ " operator.">> else
 if msg=9 then
  << princ "The index of sumation has not been specified.";
     terpri();
     princ "Please use  tags to specify an index.">>
 else
 if msg=10 then
  << princ "Upperlimit not specified.">> else
 if msg=11 then
  << princ "Upper and lower limits have not been specified.">> else
 if msg=12 then
  << princ "The degree quantifier is of no use in the product";
     princ " operator.">> else
 if msg=13 then
  << princ "The degree quantifier is not allowed in the integral";
     princ " operator.">> else
 if msg=14 then
  << princ "Variable of integration not specified.";
     princ "Please use  tags to specify variable.">>
 else
 if msg=15 then
  << princ "Incorrect use of  tags.";
     princ " Correct use:";
     terpri();
     princ
" bound_var  [ degree ] ">> else
 if msg=16 then
  << princ "Symbolic constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax:  ";
     princ str;
     princ " ";
     terpri();
     princ "or  ";
     princ "if using constants ⅈ, ⅈ, ⅇ, γ, ⅇ or π."
  >> else
 if msg=17 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Token not allowed within  tags.";
     terpri();
     princ "Might be: <"; princ str; princ "/>.">> else
 if msg=18 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Not allowed within  tags.">> else
 if msg=19 then
  << princ "Undefined error!";
     princ " Token "; princ sub1 count;
     princ " is probably mispelled";
     terpri();
     princ "or unknown, ";
     princ "or the  tag is missing">> else
 if msg=20 then
  << princ "Function ";
     princ str;
     princ "()";
     princ " was not enclosed in  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=21 then
  << princ "Error, division by 0">> else
 if msg=22 then
  << princ " should contain a type attribute";
     terpri();
     princ "example: ";>>;


 terpri();
 if FILE!*=t then close rds !*f!*;
 FILE!*:=nil;
 rederr("");
 rederr("");
 terpri();
end;


% This function transforms a list representing a list of matrix columns
% to a list representing a list of matrix rows
% Very important in order to deal with OpenMath's way of
% representing Matrices which can be both with columns
% or rows.

symbolic procedure cols2rows(l);
begin scalar len;
%  return l;
  len := length car l;
  return reverse cols2rows2(l, len);
end;

symbolic procedure cols2rows2(l, s);
begin;
  if s neq 0 then return cons(ithListElem(l, s), cols2rows2(l, s-1));
end;

% This function is given a list of lists (ie a matrix) and an index i.
% It then returns a list containing the ith element of the lists in the list lst
% for example: listelem('((1 2)(3 4)(5 6)), 2) --> (2 4 6)

symbolic procedure ithListElem(lst, i);
begin;
  if lst neq nil then return cons(nth(car lst, i), ithlistelem (cdr lst, i));
end;


% The function subst(a1,a2,a3) substitutes a1 for all occurences
% of a2 in list a3

% Allows printing out two variables. Usually a
% string and a variable.

symbolic procedure debug(s1, s2);
begin;
  terpri!* t;
  princ s1; princ s2;
  terpri!* t;
end;

% If v=t then there is a 2 space indentation,
% if v=nil then the next print will be
% 2 spaces less.

fluid '(indent ind);

symbolic procedure indent!* (v);
begin;
 if v=t then indent:=indent+ind;
 if v=nil then indent:=indent-ind;
end;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/cds.tex0000644000175000017500000000445211526203062023266 0ustar  giovannigiovanni\appendix

\chapter{CDs and Symbols handled by the Interface}

\begin{tabular}{p{2in} p{2in}}

{\bf alg1} & {\tt one, zero}\\ \\

{\bf arith1 } & {\tt abs, conjugate, divide, minus, plus, power, product, root, sum, times, unary\_minus}\\ \\

{\bf arith2 } & {\tt arg, inverse, times}\\ \\


{\bf calculus1} & {\tt defint, diff, int, partialdiff}\\ \\


{\bf fns1 }& {\tt inverse, lambda}\\ \\


{\bf integer1 }& {\tt factorial, gcd , quotient, rem}\\ \\


{\bf interval1 }& {\tt integer\_interval, interval, interval\_cc, interval\_co, interval\_oc, interval\_oo}\\ \\

{\bf limit1 }& {\tt both\_sides, above, below, limit, null}\\ \\

{\bf linalg1 }& {\tt matrix, outerproduct, scalarproduct, vector, vectorproduct}\\ \\

\end{tabular}


\begin{tabular}{p{2in} p{2in}}


{\bf linalg2 }& {\tt vector}\\ \\


{\bf linalg3 }& {\tt determinant, matrix\_selector, selector, size, transpose, vector\_selector}\\ \\

{\bf list1 }& {\tt list}\\ \\


{\bf logic1 }& {\tt and, false, implies, not, or, true, xor}\\ \\


{\bf logic2 }& {\tt equivalent}\\ \\


{\bf minmax1 }& {\tt max, min}\\ \\


{\bf multiset1 }& {\tt in, intersect, multiset, notin, notprsubset, notsubset, prsubset, set, setdiff, subset, union}\\ \\

{\bf nums1 }& {\tt based\_integer, complex\_cartesian, complex\_polar, e, gamma, i, imaginary, infinity, nan, pi, rational,
real}\\ \\


{\bf omtypes }& {\tt float, integer}\\ \\


{\bf quant1 }& {\tt exists, forall}\\ \\


{\bf relation1 }& {\tt eq, geq, gt, leq, lt, neq}\\ \\


{\bf relation2 }& {\tt approx}\\ \\


{\bf set1 }& {\tt in, intersect, notin, notprsubset, notsubset, prsubset, set, setdiff, subset, union}\\ \\


{\bf stats1 }& {\tt mean, median, mode, moment, sdev, variance}\\ \\

\end{tabular}


\begin{tabular}{p{2in} p{2in}}

{\bf transc1 }& {\tt arccos, arccosh, arccot, arccoth, arccsc, arccsch, arcsec, arcsech, arcsin, arcsinh, arctan, arctanh, cos,
cosh, cot, coth, csc, csch, exp, ln, log, sec, sech, sin, sinh, tan, tanh}\\ \\


{\bf transc2 }& {\tt arccot, arccoth, arccsc, arccsch, arcsec, arcsech, arcsinh, arctanh}\\ \\


{\bf typmml }& {\tt complex\_cartesian\_type, complex\_polar\_type, constant\_type, fn\_type, integer\_type, list\_type,
matrix\_type, rational\_type, real\_type, set\_type, type, vector\_type}\\ \\


{\bf veccalc1 }& {\tt curl, divergence, grad, laplacian}\\ \\


\end{tabular}

mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/examples.mml0000755000175000017500000005241011526203062024320 0ustar  giovannigiovanni%  Description: This file contains a long list of examples demonstrating the abilities of
%               the translator. Most of these examples come straight from the MathML spec. They
%               were used during the development of the interface and should all be correctly
%               translated into OpenMath.
%
%  Version 17 April 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%       


mml2om();

  
     
       
          x 
       
       
          x 
          3 
       
     
   
            


mml2om();

  
     
       
          x 
       
       
          x 
          3 
       
     
   
      


mml2om();

  
      b 
      2 
      c 
   



mml2om();

  
      b 
      2 
      c 
   



mml2om();

  
      b 
      2 
      c 
   


mml2om();

  
      b 
      2 
   


mml2om();

  
      b 
      2 
   


mml2om();

  
      b 
      2 
   



mml2om();

  
      b 
      2 
   



mml2om();

    6  3 


mml2om();

    6  3 


mml2om();

    6 


mml2om();

  
     
        x 
     
     
        a 
     
     
        b 
     
      
          x 
         
             y 
         
      
   



              
mml2om();

  
     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   
  



mml2om();

   
      
          x 
      
      
          x 
      
   
          
    

mml2om();

 
     
        x 
     
     
        0 
     
     
        x 
     
   

 
mml2om();            

  
    
       x 
    
    
      
        
         x 
         a 
      
    
    
        x 
    
  



mml2om();

   
      
         
             x 
         
         
             y 
         
         
             z 
         
         
             n 
         
         
            
                n 
                2 
            
            
               
                  
                      x 
                      n 
                  
                  
                      y 
                      n 
                  
               
               
                   z 
                   n 
               
            
         
      
   
      



mml2om();

  
     
        0   1   0 
     
     
        0   0   1 
     
     
        1   0   0 
     
   


mml2om();

   
      
         x
      
      
         x
         2
      
   

     
mml2om();

   
      
          x 
      
      
          x 
      
   
                    


mml2om();


     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   

                 


mml2om();

  
    
       x 
   
    f
        x 
    
  

 

mml2om();

  
    
       x 
       
         2 
       
   
    f
        x 
    
  

 

mml2om();

  
    
       x 
       
         3 
       
   
    f
        x 
    
  

 



mml2om();

  
      b 
      a 
      c 
  


mml2om();

   
      b 
      a 
      c 
   


mml2om();


      b 
      a 
      c 
   


mml2om();


      A 
      B 
   


mml2om();


  
      b 
      2 
      c 
   
   
      b 
      r 
      2 
      4 
      c 
   
   


mml2om();


      A 
      B 
   


mml2om();


  
      b 
      2 
      c 
   
   
      b 
      r 
      2 
      4 
      c 
   
 



mml2om();


      a 
      A 
   


mml2om();

 
    a 
    A 
 


mml2om();


      A 
      B 
   


mml2om();


      A 
      B 
   


mml2om();


      A 
      B 
   


mml2om();


      A 
      B 
   


mml2om();


     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   




mml2om();


     
        x 
     
     
        a 
     
     
        b 
     
      f 
        x 
     
   


mml2om();

 
   
      V 
   
   
     
       
        V 
        0 
     
   
   
     
       
          S
       
        a 
     
      V 
   
 
               

mml2om();


     
        x 
     
     
        0 
     
     
        x 
     
   


mml2om();


     
        x 
     
     
       
         
          x 
          a 
       
     
     
         x 
     
   



mml2om();


     
       
          x 
       
       
          x 
          3 
       
     
   


mml2om();


      b 
      r 
      2 
      4 
      c 
   


mml2om();


      b 
      r 
      2 
      4 
      c 
   


mml2om();

 
      b 
      r 
      2 
      4 
      c 
 



mml2om();


      1 
      2 
      3 
      x 
   


mml2om();


     
        0   1   0 
     
     
        0   0   1 
     
     
        1   0   0 
     
   


mml2om();



     
        3   1   5 
     
     
        7   0   2 
     
     
        1   7   8 
     
   



mml2om();



     
        3   1   5 
     
     
        7   0   2 
     
     
        1   7   8 
     
   



mml2om();


     
       
          1   2 
       
       
          3   4 
       
     
      1 
   


mml2om();


     
       
          1   2 
       
       
          3   4 
       
     
      2 
      2 
   


mml2om();


 
      
         a
         1
      
      
         2
         s
      
   




mml2om();

 
  
   
      
         1
         2
         3
         4
      
      
         1
         2
         1
         2
      
      
         2
         3
         2
         1
      
      
         2
         1
         1
         1
      
   
  
 



mml2om();

   
      
         2
         
            x
         
         x
      
      
         
            
               x
            
            
               x
               2
            
         
      
   



mml2om();

   
      
         x
         
            ⅈ
            
               1
            
         
      
      
         x
         
            
               ⅈ
            
            
               1
            
         
      
   




mml2om();

   
      
         
            
               
                  x
                  y
               
            
            x
            y
         
      
      
         
            2
            
               x
               y
            
         
         
            
               2
            
            2
         
         x
         y
      
      
         
            2
            
               x
               y
            
         
         
            2
         
      
      
         
            
               x
               y
            
         
      
      1
   



mml2om();

 
  2
  2
  2
 


mml2om();

 
  2
  A
  u
 


mml2om();

 
  2
  2
 


mml2om();

 
  2
  A
 


mml2om();

 
  2
  2
  2
 


mml2om();

 
  2
  A
  u
 


mml2om();

 
  2
  2
  2
 


mml2om();

 
  2
  A
  u
 


mml2om();

 
  2
  2
  2
 


mml2om();

 
  2
  A
  u
 


mml2om();

 
  2
  2
  2
 


mml2om();

 
  2
  A
  u
 


%The following examples work perfectly when read
%in by mml2om() and prove that the tags employed
%work correctly. The ir output can then be used
%to see if the mathml produced works:

mml2om();

   
      
         x
      
      
         0
      
      
         1
      
      
         x
         2
      
   
           


mml2om();

   
      
         x
      
      
         1
      
      
         ∞
      
      x
   
       

mml2om();
       
 
   
      x 
   
   
       a 
       b 
    
   
      x 
   
 
       

%this example is MathML1.0 and when passed
%through function mml2om() it translates it to
%MathML2.0

mml2om();

  
    
       x 
      
         2 
      
    
    f
        x 
    
  
             



mml2om();

  
    
        x 
        y 
    
     3 
     7 
  
       

mml2om();
       
  
     a 
     b 
  
       

mml2om();

   
      a 
      b 
   


mml2om();

   
      
         
            x
            
               
                  root_of
               
               
                  
                     
                        y
                        x_
                     
                  
                  
                     
                        
                           
                              x_
                           
                           
                              x_
                              x_
                           
                        
                        y
                     
                  
                  x_
                  y
               
               x_
               tag_1
            
         
         
            a
            
               x
               y
            
         
      
   
          
mml2om();

   
      
         
            x
            
               
                  root_of
               
               
                  
                     
                        
                           ⅈ
                           x_
                        
                     
                     y
                  
                  
                     
                        ⅈ
                        x_
                     
                  
                  
                     x_
                     
                        y
                        1
                     
                  
                  
                     
                        
                           x_
                        
                        
                           x_
                           x_
                        
                     
                     
                        y
                        2
                     
                  
                  
                     
                        
                           x_                  
                        
                        
                           x_
                           x_
                        
                     
                     y
                  
               
               x_
               tag_2
            
         
         
            z
            y
         
      
   
                   


mml2om();

  
  
      b 
      2 
      c 
   
  
       

mml2om();

  
  
      b 
      2 
      c 
   
  
       

mml2om();

  
  
      b 
      2 
      c 
   
  
       

mml2om();

   
      
          a 
      
      
         
            
                a 
            
         
          a 
      
   
            

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/testing.tex0000644000175000017500000002613111526203062024170 0ustar  giovannigiovanni\chapter{Testing}

In order to confirm that the task of interfacing MathML and OpenMath has
been achieved, we must test the program in a variety of situations. We
will be ensuring that all guidelines described in Chapter \ref{analysis}
are properly adhered to. The testing will also prove the efficiency of
the overall design.

The most important feature to look for is that the translation process does not alter or modify the expressions being translated. Additionally, it
is essential that all results produced by the translator are compliant to the OpenMath and MathML standards. We will focus on ensuring semantic
value is preserved as well as making sure that CDs appear correctly next to symbols, MathML attributes are accurate, and that OpenMath symbols not
handled are properly dealt with. Finally we will test MathML outputs with the widespread MathML renderer: IBM TechExplorer.

We will aim to test varios specific aspects in more detail. We will describe the testing method and the results obtained.

The testing should verify whether the program accomplishes its task of translating OpenMath to MathML.

\section{Translation}

In order to verify whether the translation process is attained, we have
created a test suite comprising over 170 MathML and OpenMath examples,
more than 80 of each. Most of these examples come from the standard
specifications and others have been designed to test specific aspects
of the translator. Many of these examples were extensively used
throughout the implementation phase.

By running these examples through the translator, it was possible to
carefully check if the output produced for each example corresponded to
the expected result. This careful analysis, example by example,
has proven that in most cases, semantic value was preserved and a
proper translation was carried out.  However, it is important to
concentrate on the difficulties arising from translating OpenMath and
MathML.

\subsection{Content Dictionaries}

\paragraph{Aim:} Given that symbols from different CDs may have the
same name albeit different meanings, we must test the ability of the
translator to relate symbols to their CDs and recognize the difference
in meaning different CDs convey.

\paragraph{Testing method:} In the test suite of 170 examples, there
are a set of expressions testing the ability of the translator to
relate symbols to their CDs. These examples contain expressions with
symbols from different CDs but with the same name, to test the
translator's faculty to properly handle them. There are examples
where correct symbols appear next to wrong CDs and vice versa. The
translator should recognize only the valid CDs.

\paragraph{Results:} All examples were correctly treated. The
translator was capable of recognizing valid symbols by consulting the tables, translating them
accordingly. The results produced by these examples were very satisfactory.

\paragraph{Aim:} To test whether OpenMath expressions generated have
symbols appearing next to the correct CDs.

\paragraph{Testing Method:} Running all the examples contained in {\tt 
examples.mml} will generate a large number of OpenMath expressions.
By looking at them carefully we will see if symbols are correctly
related to their CDs.

\paragraph{Results:} All examples analysed were correct. The generated
symbols appeared next to the appropriate CDs. However, whenever a
MathML element mapped to a symbol which belonged to more than one CD
(like {\it inverse} for instance), there was no rule determining which
CD to place. Nevertheless, all translation were correct.

\subsection{MathML Attributes}

\paragraph{Aim 1:} In many cases attribute values modify the semantic
value of MathML expressions and must be taken into account when
translating. We would like to determine if the translator detects
attribute values and takes them into account when translating.

\paragraph{Aim 2:} Various OpenMath symbols map to MathML elements with
specific attribute values. Does the translator detect these symbols in order to 
generate MathML elements with their correct attribute values?

\paragraph{Testing Method:} We must gather all examples containing
elements whose attribute values convey semantic meaning. We translate
these elements from MathML to OpenMath and see if the semantic meaning
has been preserved. We then translate back to MathML and the translator
will have recognized these OpenMath elements and reproduced the
original MathML element with the correct attribute value.

\paragraph{Results:} All results were satisfactory. Attribute values were
recognized, correctly interpreted and semantic meaning was preserved in
all cases.

\subsection{Extensibility}

\paragraph{Aim:} To test how well the translator copes with OpenMath
symbols having no equivalent MathML element. We want to determine if they
are properly translated and preserve their structure and meaning.
\paragraph{Testing Method:} There are various types of situations where
extensibility mechanisms must be employed. These are:

\begin{itemize}

\item Both the CD and symbol are not recognized

\item The symbol is not recognized

\item The CD is not recognized

\end{itemize}

In these three cases, the translator must employ MathML \verb||
tags to preserve semantic meaning. We will tes expressions
based on these three cases.

\paragraph{Results:} The translator automatically detected the unknown
symbols and enveloped them inside \verb|| tags. The translator
worked well in cases where the OpenMath symbol translated was constructed
by {\it application}.  An example of this is the {\tt rank} operator seen
in figure \ref{rank}. In other cases (such as {\it binding}) the results
were poor and in many cases incorrect.

\section{Standard Compliance}

For this translator to produce usable results it must imperatively conform to MathML and OpenMath standards. This implies that all expressions
produced must be lexically and syntactically correct according to the specifications.  We must examine that the translator can parse and generate
valid expressions.

\subsection{Parsing of Expressions}

\paragraph{Aim:} Valid MathML and OpenMath expressions must be parsed
without difficulty by the translator. Lexical and syntax errors must be
detected and attribute values must be extracted for use in translating.

\paragraph{Testing Method:} The translator should correctly parse a large
amount of valid MathML and OpenMath examples taken from the standards.
These examples are contained in the 170 examples mentioned earlier and are considered to be correct. The
World Wide Web Consortium also offers a test suite for testing
applications for MathML compliance. This test suite is a series of valid
MathML expressions, which if parsed prove that an application is MathML
compliant. Unfortunately the URL link to this test suite was broken
throughout the duration of this project and has not been able to be used.

We will also introduce incorrect expressions to see if the translator
declares them as erroneous.

\paragraph{Results:} The translator performs well. All supported
operators are correctly parsed. Syntax is validated in both standards, thus distinguishing amongst correct and incorrect expressions.
Unsupported elements as described in section ref{nosupport} cause the
translator to abort. The translator is MathML and OpenMath compliant.

\subsection{Generation of Expressions}

\paragraph{Aim:} To determine if expressions produced by the translator
are MathML and OpenMath compliant.

\paragraph{Testing Method 1:} In order to determine whether the OpenMath
expressions are compliant, we shall introduce them back into the
translator. If the translator correctly parses them then they are
compliant.  Additionally, we will check the expressions individually to
ensure they are correct.

\paragraph{Testing Method 2:} To determine if MathML expressions produced
are MathML compliant, we shall translate them back to OpenMath. If the
translator reads through them correctly then we can conclude the
expressions are compliant.  Furthermore, we will try and render the
generated MathML expressions using IBM's TechExplorer. If TechExplorer
renders all MathML expressions generated then we have more reason's to
confirm that the MathML output is MathML compliant. 

\paragraph{Results:} The testing procedures all produced satisfying results. The translator's output can be parsed by itself validating the
expressions. Furthermore, IBM's TechExplorer successfully parsed and rendered a large number
of generated MathML1.0 expressions. \\

The results produced throughout these tests were mostly accurate, and when not, the translator was corrected. We recomend the user to run all the
examples in {\tt examples.om} and {\tt examples.mml} to get a better idea of the translation efficiency. It is possible that mistakes have pased
unnoticed. Reassuringly, the design is robust enough and most bugs should be quick to eliminate.

\section{Interface Limitations}

Testing of the interface has also revealed its limitations. Various
aspects of the translation process have not been properly solved. It is
important that we enumerate the areas where the translator performs
poorly.

In section \ref{boundvars} we mentioned that some OpenMath operators
encoded their bound variables within lambda expressions. We also said
that this was not compulsory. The translator however only deals with
expressions where the bound variable is within a lambda expression. Other
cases cause the translator to abort promptly.

The analysis in section \ref{scope} discussed the importance of defining
each operator's scope. The OpenMath/MathML translator gets confused when
scopes are ambiguous and aborts.

MathML element {\tt partialdiff} is not translated properly in most
cases. Only when the variables of differentiation have an order of
derivation equal to one. In all other cases the translator produces
incorrect results or aborts.

The translator will reject MathML expressions containing operators
defined within \verb|| tags. This is clearly something which
will have to be implemented in the future, since the \verb||
tags may contain OpenMath code. 

The translator is capable of distinguishing incorrect expressions from valid ones. Unfortunately there was not enough time to implement a
constructive set of error messages. These error messages should have been able to quickly inform the user why a translation might have been
aborted, or what problems there are with the input impeding tranlation.


Finally, there is an aspect of REDUCE which limits the interface.
Contrary to XML, which is case sensitive as is stated in the XML
standard~\cite{xml}, REDUCE is case insensitive. Consequently when
translating an expression with variables or function names using
capital letters, REDUCE will produce only small letters.  This may in
some occasions create confusion for the user or even distort the
semantics.

\section{Conclusion}

Although 170 examples might not be enough to test the translator in all situations, they did demonstrate that the translator coped well with the
difficulties of OpenMath/MathML translation. Because these examples are a representative selection of most OpenMath and MathML operators and
situations, the satisfying results confirm that the task of accurate translating has been achieved.


mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathml.red0000644000175000017500000021722611526203062023756 0ustar  giovannigiovannimodule mathml;

% Redistribution and use in source and binary forms, with or without
% modification, are permitted provided that the following conditions are met:
%
%    * Redistributions of source code must retain the relevant copyright
%      notice, this list of conditions and the following disclaimer.
%    * Redistributions in binary form must reproduce the above copyright
%      notice, this list of conditions and the following disclaimer in the
%      documentation and/or other materials provided with the distribution.
%
% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
% CONTRIBUTORS
% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
% POSSIBILITY OF SUCH DAMAGE.
%


% Version 5 August 1999

% Modified by FJW, 22 May 2000
% Modified by Winfried Neun , 1 August 2000
% Modified by Winfried Neun , 18 December 2000

fluid '(atts ch cha char count file!* pvar rdci!* rdelems!* rdlist!*
        rdreln!* space safe_atts temp2 unary!* !*mathprint
        consts_compl consts_int flagg found_compl found_int consts_mat_int
        consts_mat_compl found_mat_compl found_mat_int indent);

%Declaration of some switches.

%_mathml_ allows all output to be printed in mathml.
%_both_ allows all output to be printed in mathml and in normal reduce
%output.

load!-package 'assist;
load!-package 'ineq;
load!-package 'matrix;
roundconstants();

global '(f);

global '(!*mathml);
switch mathml;
global '(!*both);
switch both;
global '(!*web);
switch web;

LISP (FILE!*:=nil);
!*mathml:=nil;
!*both:=nil;
!*web:=nil;

off both;
off mathml;
off web;

%Declaration of a series of lists which contain the function to be executed
%when the token (cadr) is found.

%Tokens to be found between  tags.

RDci!*:='
((!&imaginaryi!; . (consts 'i))
(!&ii!; . (consts 'i))
(!&exponential!; . (consts 'e))
(!&ee!; . (consts 'e))
(!&pi!; . (consts 'p))
(!&differentiald!; . (const 'd))
(!&dd!; . (consts 'd)));

%Tokens to be found between  tags.

RDreln!*:=
'((tendsto . (tendstoRD ))
(eq!/ . (relationRD 'eq))
(neq!/ . (relationRD 'neq))
(lt!/ . (relationRD 'lt))
(gt!/ . (relationRD 'gt))
(geq!/ . (relationRD 'geq))
(leq!/ . (relationRD 'leq))
(in!/ . (inRD ))
(notin!/ . (notinRD ))
(subset!/ . (relationRD 'subset))
(prsubset!/ . (relationRD 'prsubset))
(notprsubset!/ . (notprsubsetRD ))
(notsubset!/ . (notsubsetRD )));

%Tokens to be found between  tags.

RDlist!*:= append(RDreln!*,
'((divide!/ . (divideRD))
(setdiff!/ . ( setdiffRD))
(select!/ . (selectRD))
(transpose!/ . ( transposeRD))
(determinant!/ . ( determinantRD))
(fn . ( applyfnRD))
(union!/ . (unionRD))
(intersect!/ . (intersectionRD))
(implies!/ . ( impliesRD))
(not!/ . ( notRD))
(xor!/ . (xorRD))
(or!/ . (orRD))
(and!/ . (andRD))
(mean!/ . ( meanRD))
(var!/ . ( varRD))
(sdev!/ . ( sdevRD))
(moment!/ . ( momentRD))
(median!/ . ( medianRD))
(sin!/ . ( sinRD))
(sec!/ . ( secRD))
(sinh!/ . ( sinhRD))
(sech!/ . ( sechRD))
(arcsin!/ . ( arcsinRD))
(cos!/ . ( cosRD))
(csc!/ . ( cscRD))
(cosh!/ . ( coshRD))
(csch!/ . ( cschRD))
(arccos!/ . ( arccosRD))
(tan!/ . ( tanRD))
(cot!/ . ( cotRD))
(tanh!/ . ( tanhRD))
(coth!/ . ( cothRD))
(arctan!/ . ( arctanRD))
(abs!/ . ( absRD))
(ln!/ . ( lnRD))
(plus!/ . ( plusRD))
(times!/ . ( timesRD))
(power!/ . ( powerRD))
(exp!/ . ( expRD))
(factorial!/ . ( factorialRD))
(quotient!/ . ( quotientRD))
(max!/ . ( maxRD))
(min!/ . ( minRD))
(minus!/ . ( minusRD))
(rem!/ . (remRD))
(conjugate!/ . ( conjugateRD))
(root!/ . ( rootRD))
(gcd!/ . ( gcdRD))
(log!/ . (logRD))
(int!/ . (intRD))
(sum!/ . ( sumRD))
(limit!/ . (limitRD))
(condition . (conditionRD))
(product!/ . (productRD))
(diff!/ . (diffRD))
(partialdiff!/ . (partialdiffRD))));

RDelems!* :=
'((reln . (relnRD !/reln ""))
(set . ( setRD !/set ""))
(fn . ( fnRD !/fn ""))
(declare . ( declareRD !/declare ""))
(list . ( listRD !/list ""))
(matrix . ( matrixRD !/matrix ""))
(cn . ( cnML !/cn ""))
(ci . ( ciML !/ci ""))
(lambda . ( lambdaRD !/lambda "")));

unary!* :=
'((determinant . (unary determinant))
(transpose . (unary transpose))
(sum . (sum_prodML sum))
(prod . (sum_prodML product))
(df . (dfML nil))      % FJW: (df.(dfML df))
(impart . (complpart impart))
(repart . (complpart repart))
(abs . (unary abs))
(gcd . (n_nary gcd))
(set . (setML set))
(factorial . (unary factorial))
(max . (n_nary max))
(min . (n_nary min))
(cos . (unary cos))
(sin . (unary sin))
(sec . (unary sec))
(cosh . (unary cosh))
(cot . (unary cot))
(coth . (unary coth))
(csch . (unary csch))
(acos . (trigML acos))
(asin . (trigML asin))
(atan . (trigML atan))
(sech . (unary sech))
(sinh . (unary sinh))
(tan . (unary tan))
(tanh . (unary tanh))
(csc . (unary csc))
(quotient . (quotientML nil))
(plus . (n_nary plus))
(times . (n_nary times))
(expt . (n_nary power))
(sqrt . (sqrtML sqrt))
(log . (unary log))
(logb . (log_baseML logb))
(log10 . (log_baseML log10))
(ln . (unary ln))
(eq . (reln eq))
(neq . (reln neq))
(gt . (reln gt))
(lt . (reln lt))
(greaterp . (reln gt))
(lessp . (reln lt))
(geq . (reln geq))
(leq . (reln leq))
(union . (sets union))
(intersection . (sets intersection))
(in . (reln in))
(notin . (reln notin))
(subset . (reln subset))
(prsubset . (reln prsubset))
(notsubset . (reln notsubset))
(notprsubset . (reln notprsubset))
(setdf . (sets setdf))
(arbcomplex . (printsub2 cadr arbcomplex))
(arbint . (printsub2 cadr arbint))
(mat . (matrixML nil))
(minus . (minusML nil))
(int . (integralML nil))
(equal . (equalML nil))
(list . (listML nil)));


%The next three functions are the lexer. When called they returns the next
%mathml token in the input stream.

symbolic procedure lex();
begin scalar token;
 token:=nil;
 if atts neq nil then safe_atts:=atts;
 atts:=nil;
 if ch neq !$EOF!$ then <<
  if ch=space then while (ch:=readch())=space do
  else
   if ch='!< then char:=get_token()
   else char:=get_content();
   if char neq nil then
   <<  count:=count+1;
       token:=reverse char;
       char:=butes(token);
%By decomenting the following line, the tokens read in are one by one
%printed onto the output stream.
%       print char;
       attributes(char,token)>>
    else lex(); >>
end;


symbolic procedure get_token();
begin scalar d;
 d:=();
 while (ch:=readch()) neq '!> do d:=cons(ch,d);
 return cons('!$,d);
end;


symbolic procedure get_content();
begin scalar d;
 d:=();
 while (ch:=readch()) neq '!< AND ch neq !$EOF!$
do
    if ch neq space AND id2int(ch)>10 then
d:=cons(ch,d);
 if d neq nil then d:=cons('!$,d);
 return d;
end;


%This function will search the list of attributes _att_ for the attribute
%named _key_

symbolic procedure search_att( att, key);
begin scalar l, stop,d;
 l:=nil;
 d:=();
 stop:=0;
 att:= find(att, key);
 if att neq '(stop) then
 <<
 while (car att='! ) do att:=cdr att;
 if (car att = '!=) then
   <<
     att:=cdr att;
     while (car att='! ) do att:=cdr att;
     if (car att='!") then
      << att:=cdr att;
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
      >>
      else
         while (stop=0) do
          << d:=cons(car att, d);
             att:=cdr att;
             if (car att='!  ) OR (car att='!$) then stop:=1
          >>
   >>
 else
 errorML(compress key,1);
 if car d='!" then d:=cdr d;
 return reverse d
 >>
end;

symbolic procedure find(fatt, fkey);
begin;
return if fkey= '() then if fatt neq nil then cdr fatt else '(stop)
          else
          find(member(car fkey, fatt), cdr fkey);
end;

symbolic procedure attributes(a,b);
begin scalar l;
 l:=length a;
 for a:=1:l do b:=cdr b;
 while (car b='! ) do b:=cdr b;
 if b neq '(!$) then  atts:=b;
end;


symbolic procedure butes( str );
%Removes all attributes to a token.
begin cha;
cha:=car str;
return if (cha='!  OR cha='!$) then <<'(); >>
        else  cons(car str, butes cdr str);
end;


%This is the MAIN function. It is given the name of a file which contains
%the mathml input. It launches the program by calling parseML().

symbolic procedure mml(ff);
begin;
 FILE!*:=t;
 ff:= open(ff, 'input);
 ff:= rds(ff);
 parseML();
 close rds ff;
 FILE!*:=nil;
end;

%This function starts the parsing mechanism, which is a recursive descent
%parsing.


symbolic procedure parseML();
begin scalar res, vswitch;
 res:=nil;
 vswitch:=nil;
%  FLUID '(safe_atts char ch atts count temp space temp2);
 space:=int2id(32);
 count:=0;
 ch:=readch();
 temp2:=nil;
 lex();
 if char='(m a t h) then
     res:=mathML()
   else errorML("",2);
 lex();
 if char='(!/ m a t h) then
   terpri()
   else errorML("",19);

 return algebraic res;
end;

%The two next functions differ in that one of them parses from the next
%token onwards, and the other one from the actual token onwards.


symbolic procedure mathML();
begin scalar a;
 a:=nil;
 lex();
 return sub_math();
end;

symbolic procedure mathML2();
begin scalar a;
 a:=nil;
 return sub_math();
end;

%Parses all tokens which legally follow a mathml token.

symbolic procedure sub_math();
   begin scalar a,aa;
      if char='(a p p l y)
        then <",3)>>
       else if char='(v e c t o r)
        then <",2)>>
       else if (aa := assoc(compress!* char, RDelems!*))
        then <>;
      return a
   end;

symbolic procedure compress!* u;
   begin scalar x;
      if digit car u then return compress u;
      for each j in u do
         if j eq '!/ or j eq '!- or j eq '!; or j eq '!.
            then x := j . '!! . x
          else x := j . x;
      return intern compress reversip x
   end;


%The next two functions parse the  and  tokens and extracts its
%content to be used by the function calling it. It will have different
%behaviours according to the type of the  data.

symbolic procedure cnML();
begin scalar type, sep, tt,aa;
%Must check that what is being returned is an int.
 type:=nil; sep:=nil;
 type:=search_att(atts, '(t y p e));
 lex();
 tt := char;
 lex();


 if type='(c o n s t a n t) then
 <<
   if (aa:=assoc(intern compress tt, RDci!*)) then
     return apply(first cdr aa, rest cdr aa) >>;

 if IDP compress tt then errorML(compress tt, 16);

 if type=nil then return compress tt;
 if member(type, '((r e a l) (i n t e g e r))) neq nil then
    return compress tt;
 if member(type, '((r a t i o n a l) (c o m p l e x !- c a r t e s i a n)
                   (c o m p l e x !- p o l a r))) neq nil then
   << sep:=sepRD();
      if type='(r a t i o n a l) then <>
      else
      if type='(c o m p l e x !- c a r t e s i a n) then
        << lex();return comp2(compress tt, sep) >>else
      if type='(c o m p l e x !- p o l a r) then
        <> >>
   >>;
end;


symbolic procedure ciML();
begin scalar test, type,aa, tt;
 aa:=nil; type:=nil; test:=nil;
 type:=search_att(atts, '(t y p e));
 lex();
 tt := char;
 lex();
  << test:=compress tt;
     if NUMBERP test then errorML(test, 4);
     test:=intern test;
     return test>>
end;

%returns the algebraic value of the constant values.

algebraic procedure consts(c);
begin;
 if c=i then return i;
 if c=d then return d;
 if c=e then return e;
 if c=p then return pi;
end;

%Constructs a complex number.

algebraic procedure comp2(a,b);
begin;
 return a+b*i;
end;

%Returns the two values separated by a  tag.

symbolic procedure sepRD();
begin scalar p1, p2;
 p1:=nil; p2:=nil;
 if char neq '(s e p !/) then errorML("",2);
 lex();
 p2:=compress char;
 return p2;
end;

%Creates a vector by using function matrix_row.

symbolic procedure vectorRD();
begin scalar a;
 a:=nil;
 a:=matrixrowRD();
 a:=lisp aeval list('mat, a);
 return a;
end;

%The following functions construct the matrix from the mathml information.

symbolic procedure matrixRD();
begin scalar b1, b2, stop;
 stop:=0;
 b1:='();
 b2:=nil;
 while stop=0 do
 <<
   lex();
   if char='(m a t r i x r o w) then
    <",2)>>
   else stop:=1
  >>;
 return aeval cons ('mat ,b1);
end;

symbolic procedure matrixrowRD();
begin scalar a;
 a:=nil;
 a:=mathML();
 return if a=nil then nil
        else cons(a, matrixrowRD());
end;

%returns a lambda function constructed from the information supplied.

symbolic procedure lambdaRD();
begin scalar b1, b2;
 lex();
 b1:=bvarRD();
 b1:=car b1;
 b2:=mathML();
 lex();
 return algebraic( (lambda  b1; b2) b1 );
end;

%returns a set constructed from the information supplied.

symbolic procedure setRD();
begin scalar setvars;
 atts:='(t y p e != s e t !$);
 setvars:= cons('list,stats_getargs());
 setvars:=cons(car setvars, norepeat(cdr setvars));
 return setvars;
end;

%This function will keep one copy only of any repeating elements

symbolic procedure norepeat(args);
begin;
return if args=nil then nil else
 if length args=1 then list car args
 else append(list car args, norepeat(delall(car args, cdr args)));
end;

%This function will delete all occurences of element x in list l

symbolic procedure delall(x,l);
if l=nil then nil
else if x=car l then delall(x, cdr l)
     else append(list car l ,delall(x, cdr l));

%returns a list constructed from the information supplied.

symbolic procedure listRD();
begin scalar setvars, lorder, tmp;
 lorder:=search_att(atts, '(o r d e r));
 atts:='(t y p e != l i s t !$);
 setvars:= cons('list,stats_getargs());
 tmp := setvars;
 if lorder='(l e x i c o g r a p h i c) then
   setvars:=algebraic sortlist (setvars, lexog);
 if lorder='(n u m e r i c) then
  setvars:=algebraic sortlist (setvars, numer)
 else
   setvars:=algebraic sortlist (setvars, pred);
 if setvars = nil then setvars:= tmp;
 return setvars;
end;

%Defines the predicate function used by function _sortlist_. Sortlist comes
%from package assist, and its documentation can be found in assist's
%documentation

%This one will sort all elements in numerical and alphanumerical order

symbolic procedure pred(u,v);
begin;
return if NUMBERP u and NUMBERP v then <> else
 if IDP u and IDP v then <>
 else if NUMBERP u and IDP v then <> else
if IDP u and NUMBERP v then <>;
end;

%This one sorts in alphanumerical order

symbolic procedure lexog(u,v);
begin;
 return if IDP u and IDP v then <>
 else t;
end;

%This one sorts in numerical order

symbolic procedure numer(u,v);
begin;
 return if NUMBERP u and NUMBERP v then <>
 else t;
end;

%Makes the next token in the inputstream an operator.

symbolic procedure fnRD();
begin scalar b1;
 lex();
 if char neq '(c i) then errorML(compress char,20)
 else b1:= mathML2();
 if ATOM b1 then algebraic operator b1;
 lex();
 return b1;
end;

%Reads the declare construct and sets the value of the given variable to
%the given value.

symbolic procedure declareRD();
begin scalar b1, b2, flagg, at;
 at:=atts;
 flagg := nil;
 b1:=mathML();
 clear b1;
 clear reval b1;
 lex();
 if at neq nil then
   put(b1, 'type, search_att(at,'(t y p e)));

 if search_att(at, '(t y p e)) = '(v e c t o r) then
   flagg:=t;

 if char='(!/ d e c l a r e) then return nil;
 b2 :=mathML2();
 if get(b1, 'type)='(f n) then
  << algebraic operator b1>>;
 if flagg = t then setk(b1, b2)
 else algebraic set(b1, b2);
 lex();
 return nil;
end;

%This function will determine if the next token is a valid token following
%an apply token. It then calls the appropriate function if succesful.

symbolic procedure applyML();
   begin scalar aa;
      lex();
      if (aa := assoc(compress!* char, RDlist!*))
        then return apply(first cdr aa, rest cdr aa)
       else if char='(i d e n t !/) or char='(c o m p o s e !/)
        then return nil
       else if char='(i n v e r s e !/) then return t
       else errorML(compress!* char, 17)
   end;

%Reads the next two elements and returns their setdifference.

symbolic procedure setdiffRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 and b2=reval b2 then return list('setdiff,b1, b2)
else
 if b1=reval b1 then return list('setdiff, b1, reval b2) else
 if b2=reval b2 then return list('setdiff, reval b1, b2) else
 return append(list('set), setdiff(reval b1, reval b2));
end;

%Reads through a select construct and acts accordingly.

symbolic procedure selectRD();
begin scalar a1, res;
 a1:=stats_getargs();
 if caar a1='mat then res:=mat_select(a1);
 if caar a1='list then res:=list_select(a1);
 if ATOM res then return res;
 return cons('list, res);
end;

symbolic procedure mat_select(a1);
begin
 if length car a1=2 then return nth(cadar a1, cadr a1)
 else
 if length a1=2 then return nth(cdar a1, cadr a1);
 if length a1=3 then return nth(nth(cdar a1, caddr a1), cadr a1);
end;

symbolic procedure list_select(a1);
begin scalar b1;
 b1:=cdar a1;
 return nth(b1, cadr a1);
end;


%Returns the transpose of the element contained in the transpose tags.

symbolic procedure transposeRD();
begin scalar a, res;
 a:=mathML();
 res:=algebraic(tp a);
 lex();
 return res;
end;

%Returns the determinant of the given element.

symbolic procedure determinantRD();
begin scalar a, res;
 a:=mathML();
   res:=alg_det a;
 lex();
 return res;
end;

algebraic procedure alg_det(a);
begin;
return det a;
end;

%Takes the given function name, makes it an operator, and then
%applies it to the arguments specified in the mathml input.

symbolic procedure applyfnRD();
begin scalar b1, b2, c1;
 b1:=nil; b2:=nil; c1:=nil;
 b1:=fnRD();
 b2:=stats_getargs();
 b2:=cons(b1, b2);
 c1:=algebraic b2;
 return  c1;
end;

%Returns the union of the elements specified.

symbolic procedure unionRD();
begin scalar b1, a1, a2,type,res;
 b1:=stats_getargs();
 a1:=car b1;
 a2:=cadr b1;
 if PAIRP a1 AND PAIRP a2 then <<
   type := car a1;
   a1:=cons('list, eval_list cdr a1);
   a2:=cons('list, eval_list cdr a2);
   res:=algebraic union(a1,a2);
 >>
 else <<
  type := 'list;
  res := cons('list,cons(a1,list a2));
 >>;
 return cons(type, cdr res);
end;

%Returns the intersection of the elements specified.

symbolic procedure intersectionRD();
begin scalar b1, a1, a2,type,res;
 b1:=stats_getargs();
 a1:=car b1;
 a2:=cadr b1;
 if PAIRP a1 AND PAIRP a2 then <<
   type := car a1;
   a1:=cons('list, eval_list cdr a1);
   a2:=cons('list, eval_list cdr a2);
   res:=algebraic intersect(a1,a2);
 >>
 else <<
  type := 'list;
  res := cons('list,cons(a1,list a2));
 >>;
 return cons(type, cdr res);
end;


%Takes all the arguments in a list, and forces an evaluation on them if they can be
%evaluated.

symbolic procedure eval_list(args);
begin;
 return if args=nil then nil
 else cons(reval car args, eval_list(cdr args));
end;

%Takes all the arguments in a list of sets, and evaluates them if they can
%be evaluated.

symbolic procedure eval_list_sets(args);
begin scalar ab;
 return if args=nil then nil
 else <>
        else ab:=reval car args;
        cons(ab, eval_list_sets(cdr args))>>;
end;

%Sets global variable temp2 to 'stop if an evaluatable element is found in
%list args.

symbolic procedure constants(args);
begin scalar b1;
if args neq nil then b1:=car args;
 return if args=nil then nil
   else <> else
 %if type='(quote eq) then <> else
 %if type='(quote neq) then <> else
 %if type='(quote lt) then <> else
 %if type='(quote gt) then <> else
 if type='(quote lt) then <> else
 if type='(quote gt) then <> else

 if type='(quote subset) then <> else
 if type='(quote prsubset) then <> else
 %if type='(quote geq) then <> else
 %if type='(quote leq) then <>;
 if type='(quote geq) then a:= 'geq . args else
 if type='(quote leq) then a:= 'leq . args;

 return if a=t then t
        else if a=nil then 'false else a;
end;

%The following functions do all the necessay actions in order to evaluate
%what should be by the tags.

symbolic procedure notsubsetRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 AND b2=reval b2 then
    return list('notsubset, b1, b2);
 if b1= reval b1 then
    return list('notsubset, b1,cons ('set, cdr reval b2));
 if b2= reval b2 then
    return list('notsubset, cons('set,cdr reval b1), b2);
 if intersection(cdr reval b1,cdr reval b2)=nil then
    return t
 else
    return nil;
end;

symbolic procedure notprsubsetRD();
begin scalar b1, b2;
 b1:=mathML();
 b2:=mathML();
 lex();
 if b1=reval b1 AND b2=reval b2 then
    return list('notprsubset, b1, b2);
 if b1= reval b1 then
    return list('notprsubset, b1,cons('set, cdr reval b2));
 if b2= reval b2 then
    return list('notprsubset, cons('set,cdr reval b1), b2);
 if reval b1 = reval b2 then return t;
 if intersection(cdr reval b1,cdr reval b2)=nil then return t else
return nil;
end;


symbolic procedure subsetRD(sets);
begin scalar args,val;
 args:=sets;
 val:=t;
 while (length args > 1) do
  << if NUMBERP reval car args then
       errorML(reval car args,5);
     if car args = reval car args OR cadr args = reval cadr args then
     << args:='();
        val:=cons('subset, eval_list_sets(sets))>>
     else
     << val:=AND(val, alg_subset(reval car args, reval cadr args));
        args:=cdr args >>
  >>;
 return val;
end;



symbolic procedure alg_subset(a,b);
begin;
  if a=b then return t
  else
  if setdiff(a,b)=nil then return t else return nil;
end;


symbolic procedure prsubsetRD(sets);
begin scalar args, val;
 val:=t;
 while (length args > 1) do
  << if car args = reval car args OR cadr args = reval cadr args then
     << args:='();
        val:=cons('prsubset, eval_list_sets(sets))>>
     else
     << val:=AND(val, alg_prsubset(reval car args, reval cadr args));
        args:=cdr args >> >>;
 return val;
end;

symbolic procedure alg_prsubset(a,b);
begin;
  if setdiff(a,b)=nil then return t else return nil;
end;

symbolic procedure inRD();
begin scalar b1,b2;
 b1:= mathML();
 b2:= mathML();
 lex();
 if b2 = reval b2 AND ATOM b2 then
 <<
    if b2='n then <>;
    if b2='r then <>;
    return list('in, reval b1, b2)
 >>;
 if MEMBER(reval b1,reval  b2) neq nil then return t
   else return nil;
end;

symbolic procedure notinRD();
begin scalar b1,b2;
 b1:= mathML();
 b2:= mathML();
 lex();
 if b2 = reval b2 AND ATOM b2 then
 <<
    if b2='N then if FIXP b1 then return nil else return nil;
    if b2='R then if NUMBERP b1 then return nil else return nil;
    return list('notin, reval b1, b2)>>;
 if MEMBER(reval b1,reval  b2) neq nil then return nil
   else return t;
end;

symbolic procedure alg_eq(args);
begin;
 constants(args);
 return alg_eq2 eval_list args;

end;

symbolic procedure alg_eq2(args);
begin;
 return if length args=1 then t
        else if (reval car args eq reval cadr args) then
                alg_eq2(cdr args);
end;

symbolic procedure alg_neq(args);
begin;
 constants(args);
 return alg_neq2(eval_list(args));
end;

symbolic procedure alg_neq2(args);
begin;
 return if length args=1 then t
        else if (reval car args neq reval cadr args) then
                alg_neq2(cdr args);
end;

symbolic procedure alg_lt(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_lt2(eval_list(args));
end;

symbolic procedure alg_lt2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <>
 else errorML("",6);
end;



symbolic procedure alg_gt(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_gt2(eval_list(args));
end;

symbolic procedure alg_gt2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   < reval cadr args) then
       alg_gt2(cdr args)
     else nil>>
 else errorML("",6);
end;

symbolic procedure alg_geq(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_geq2(eval_list(args));
end;

symbolic procedure alg_geq2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <= reval cadr args) then
       alg_geq2(cdr args)
     else nil>>
 else errorML("",6);
end;

symbolic procedure alg_leq(args);
begin;
 constants(args);
 if temp2='stop then
 <>
 else return alg_leq2(eval_list(args));
end;

symbolic procedure alg_leq2(args);
begin;
 return if length args=1 then t
        else
 if (NUMBERP reval car args AND NUMBERP reval cadr args )then
   <>
 else errorML("",6);
end;

%Interprets the  tag when used in the  tag.

symbolic procedure tendstoRD();
begin scalar attr, arg1 ,arg2;
 if intersection(atts, '(t y p e)) neq nil then
    attr:=search_att(atts, '(t y p e))
 else attr:=nil;
 arg1:=mathML();
 arg2:=mathML();
 lex();
 return list (attr,arg2);
end;

%Returns the limit of the information given. Uses the Reduce package
%LIMITS.

symbolic procedure limitRD();
begin scalar var, condi, low, exp;
 lex();
 if char='(b v a r) then
  << var:=bvarRD();
     if eqn(cadr var,1) then var:=car var
      else
         errorML("",8);
     lex()>>
 else var:=nil;

 if char='(l o w l i m i t) then
  << low:=lowlimitRD();
     lex()>>
 else if char='(c o n d i t i o n) then
     <<      condi:=conditionRD();
        if char neq '(!/ c o n d i t i o n) then
        errorML("",2);
        lex()>>
      else condi:=nil;

 exp:=mathML2();
 lex();

 if condi=nil then
   return alg_limit(exp, var, low, 'norm);

 if low=nil then
   if car condi='(a b o v e) then
        return alg_limit(exp, var, cadr condi, 'plus)
   else return alg_limit(exp, var, cadr condi, 'min);

end;

algebraic procedure alg_limit(exp, var, tendto, type);
begin;
 if type='norm then return limit(exp, var, tendto);
 if type='plus then return limit!+(exp,var,tendto);
 if type='min then return limit!-(exp,var,tendto);
end;

%Returns the sum.

symbolic procedure sumRD();
begin scalar svar, low, upper, express, res;
 svar:=nil; low:=nil; upper:=nil; express:=nil; res:=nil;
 lex();
 if char='(b v a r) then
      <",7);
        lex()>>
 else errorML("",9);

 if char='(l o w l i m i t) then
     << low:=lowlimitRD();
        lex();
          if char='(u p l i m i t) then
             <<      upper:=upperlimitRD();
                lex()>>
        else errorML("",10) >>
 else if char='(i n t e r v a l) then
     <<      res:=intervalRD();
        lex();
        low:=car res;
        upper:=cadr res >>
      else errorML(" or ",11);

 express:=mathML2();
 lex();

 return algebraic sum(express, svar, low, upper);

end;

algebraic procedure alg_sum( low, upper, formu);
begin scalar temp,var2;
 algebraic;
 temp:=0;
 var2:=symbolic svar;
 for tt:=low:upper do
  << set(var2,tt);
     temp:=temp+formu;
     clear symbolic svar;
     var2:=symbolic svar>>;
 symbolic;
 return temp;
end;


%Returns the product.

symbolic procedure productRD();
begin scalar pvar, low, upper, pexpress, res;
 lex();
 if char='(b v a r) then
      <",12);
        lex()>>
 else errorML("",9);
 if char='(l o w l i m i t) then
     << low:=lowlimitRD();
        lex();
          if char='(u p l i m i t) then
             <<      upper:=upperlimitRD();
                lex()>>
        else errorML("",10)>>
 else if char='(i n t e r v a l) then
     <<      res:=intervalRD();
        lex();
        low:=car res;
        upper:=cadr res >>
      else errorML(" or ",11);

 pexpress:=mathML2();
 lex();

 return algebraic prod(pexpress, pvar, low, upper);


end;



algebraic procedure alg_prod( low, upper, formu);
begin scalar temp,var2;
 algebraic;
 temp:=1;
 var2:=symbolic pvar;
 for tt:=low:upper do
  << set(var2,tt);
     temp:=temp*formu;
     clear symbolic pvar;
     var2:=symbolic pvar>>;
 symbolic;
 return temp;
end;

%Returns the partial derivative.

symbolic procedure partialdiffRD();
begin scalar res, bvar, express;
 lex();
 bvar:=getargsRD();
 express:=mathML2();
 lex();
 res:=differentiate(express, bvar);
 return res;
end;

symbolic procedure differentiate(express, bvar);
begin scalar temp,diffed;
return
  if eqn(length bvar,0) then express
   else
    <>;
end;


%This function reads through the a series of  tags and extracts the
%variables.

symbolic procedure getargsRD();
begin scalar a;

%Dont forget. This function leaves the file pointer on
%the next token after the last bvar. So you need to use mathML2 after.

if char='(b v a r) then
<>;
end;

%Returns the derivative.

symbolic procedure diffRD();
begin scalar bvar, degree, express, res;
 lex();
 if char='(b v a r) then
  <>
 else <>;
 express:=mathML2();
 lex();
 res:=alg_df(express, bvar, degree);
 return res;
end;

algebraic procedure alg_df(a,b,c);
begin;
 return df(a,b,c);
end;

%This function will calculate the integral. Takes in the expression, then
%the bound variable, and finally the limits if they exist.

symbolic procedure intRD();
begin scalar bvar, low, upper, int, exp;
 lex();
 if char='(b v a r) then
      <>
   else errorML("",14);


 if char='(l o w l i m i t) then <>
   else low:=nil;

 if char='(u p l i m i t) then <>
   else upper:=nil;

 if char='(i n t e r v a l) then
   <>
   else int:=nil;


 exp:=mathML2();
 lex();
 return alg_int(exp, bvar, low, upper);
end;

algebraic procedure alg_int(exp, bvar, low, upper);
begin scalar res;
 if (low='nil) AND (upper=nil) then res:= int(exp, bvar)
  else res:= int(exp,bvar,low,upper);
return res;
end;

%Here we parse bound variables. The function reads the variable as well as
%the degree if there is one.

symbolic procedure bvarRD();
begin scalar var, deg;
 lex();
 if char='(d e g r e e) then
     errorML("",15);
 var:=mathML2();
 lex();
 if char='(d e g r e e) then
   << deg:=mathML();
      lex();
      if char neq '(!/ d e g r e e) then
        error("",2);
      lex()>>
 else deg:=1;
 if char='(!/ b v a r) then return list(var, deg)
   else errorML("", 2);
end;

%Functions used to parse the limits of an integral, sum, or product.

symbolic procedure lowlimitRD();
begin scalar lowlimit;
 lowlimit:=mathML();
 lex();
 if char='(!/ l o w l i m i t) then return lowlimit
   else errorML("", 2);
end;

symbolic procedure upperlimitRD();
begin scalar upperlimit;
 upperlimit:=mathML();
 lex();
 if char='(!/ u p l i m i t) then return upperlimit
   else errorML("", 2);
end;


symbolic procedure intervalRD();
begin scalar l,u;
 l:=mathML();
 u:=mathML();
 lex();
 if char='(!/ i n t e r v a l) then return list(l,u)
   else errorML("", 2);
end;

%Following functions just evaluate calculus functions.

symbolic procedure lnRD();
begin scalar a;
 a:=alg_ln(mathML());
 lex();
 return a;
end;

algebraic procedure alg_ln(a);
begin;
  return ln(a);
end;

symbolic procedure logRD();
begin scalar a, a1, base;
 base:=nil;
 lex();
 if char='(l o g b a s e) then
    <>;
  a1:=mathML2();
  lex();
  a:=alg_log(a1, base);
  return a;
end;

algebraic procedure alg_log(a, base);
begin;
 if base=nil then return log(a)
 else
  return logb(a, base);
end;

symbolic procedure logbaseRD();
begin scalar a;
 a:=mathML();
 lex();
 if char='(!/ l o g b a s e) then return a
   else errorML("",2);
end;


symbolic procedure conjugateRD();
begin scalar a;
  a:= alg_conj(mathML());
  lex();
  return a;
end;

algebraic procedure alg_conj(a);
begin;
 return conj(a);
end;


symbolic procedure minusRD();
begin scalar c,b;
  c:=mathML();
  b:=mathML();
  if b=nil then c:=alg_minus(c)
   else <<
        c:=alg_difference(c,b);
        lex()>>;
  return c;
end;

algebraic procedure alg_minus(a);
begin;
 return -a;
end;

algebraic procedure alg_difference(a,b);
begin;
 return difference(a,b);
end;


symbolic procedure absRD();
begin scalar a;
  a:=alg_abs(mathML());
  lex();
  return a;
end;

algebraic procedure alg_abs(a);
begin;
 return abs(a);
end;

symbolic procedure rootRD();
begin scalar b,deg;
  lex();
  if char='(d e g r e e) then
  << deg:=mathML();
     lex();
     if char neq '(!/ d e g r e e) then
       error("","Syntax ERROR: Missing end tag");
     lex()>>
  else deg:=2;

  b:=mathML2();
  lex();
  return alg_root(b,deg);
end;

algebraic procedure alg_root(b,a);
begin;
return b**(1/a);
end;


symbolic procedure remRD();
begin scalar a, a1, a2;
  a1:=mathml();
  a2:=mathml();
  a:=alg_remainder(a1, a2);
  lex();
  return a;
end;

algebraic procedure alg_remainder(a,b);
begin;
  return remainder(a,b);
end;

symbolic procedure factorialRD();
begin scalar a;
  a:=alg_factorial(mathML());
  lex();
  return a;
end;

algebraic procedure alg_factorial(a);
begin;
  return factorial(a);
end;

symbolic procedure expRD();
begin scalar a;
  a:= alg_exp(mathML());
  lex();
  return a;
end;

algebraic procedure alg_exp(a);
begin;
  return exp(a);
end;

symbolic procedure quotientRD();
begin scalar a, a1, a2;
  a1:=mathML();
  a2:=mathML();
  if IDP reval a1 OR IDP reval a2 then a:=alg_quotient(a1,a2)
  else
  a:= (reval a1)/(reval a2);
  lex();
  return a;
end;

algebraic procedure alg_quotient(a,b);
begin;
  return a/b;
end;

symbolic procedure divideRD();
begin scalar a, a1, a2;
  a1:=mathML();
  a2:=mathML();
  if a2 = 0 then errorML("", 21);
  a:=alg_divide(a1,a2);
  lex();
  return a;
end;

algebraic procedure alg_divide(a,b);
begin;
  return quotient(a,b);
end;

symbolic procedure gcdRD();
begin scalar c1;
 c1:=stats_getargs();
 constants(c1);
 if temp2='stop then
   << temp2:=nil;
      return cons('gcd, eval_list(c1))>>
 else return gcdRD2(c1);
end;

symbolic procedure gcdRD2(args);
begin scalar a;
a:=reval car args;
return if length args=1 then  car args
        else alg_gcd2(a, gcdRD2(cdr args));
end;

algebraic procedure alg_gcd2(a , b);
begin;
return gcd(a,b);
end;

symbolic procedure minRD();
begin scalar a;
a:=mathML();
return if a=nil then nil
         else alg_min(a,minRD());
end;

algebraic procedure alg_min(a,b);
begin;
 return min(b,a);
end;

symbolic procedure maxRD();
begin scalar a;
a:=mathML();
return if a=nil then nil
         else alg_max(a,maxRD());
end;

algebraic procedure alg_max(a,b);
begin;
  return max(a,b)
end;

lisp operator plusRD;

symbolic procedure plusRD();
begin scalar abc1;
abc1:=nil;
abc1:=mathML();
return if abc1 = nil then 0
        else alg_plus(abc1, plusRD());
end;

algebraic procedure alg_plus(acb1,b);
begin;
return acb1+b;
end;


symbolic procedure timesRD();
begin scalar a;
a:=nil;
a:=mathML();
return if a=nil then 1
  else alg_times(a, timesRD());
end;

algebraic procedure alg_times(a,b);
begin;

if b=i then return a*i;
return a*b;
end;



symbolic procedure powerRD();
begin scalar var,power;
 var:=mathML();
 power:=mathML();
 lex();
 return alg_expt(var,power);
end;

algebraic procedure alg_expt(a,b);
begin;
return expt(a,b);
end;

%The following function is in charge of providing the correct error message
%as well as closing the input/output stream, and exiting the program
%correctly.

symbolic procedure errorML( str, msg );
begin;
 terpri();
 princ "***** Error in token number ";
 princ count;
 princ " (<";
 princ compress char;
 princ ">)";
 terpri();
 if msg=1 then
  << princ "Needed attribute";
     princ str;
     princ " and none was found.">> else
 if msg=2 then
  << princ "Missing tag: ";
     princ str >> else
 if msg=3 then
  << princ "Undefined error!";
     princ " Token number "; princ sub1 count;
     princ " probably mispelled or an";
     princ "ambiguous or erroneous use of .">> else
 if msg=4 then
  << princ "Numerical constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=5 then
  << princ "All arguments must be sets";
     terpri();
     princ str;
     princ " does not represent a set.">> else
 if msg=6 then
  << princ "Non-numeric argument in arithmetic.">> else
 if msg=7 then
  << princ "The degree quantifier is of no use in the sumation";
     princ "operator.">> else
 if msg=8 then
  << princ "The degree quantifier is of no use in the limit";
     princ " operator.">> else
 if msg=9 then
  << princ "The index of sumation has not been specified.";
     terpri();
     princ "Please use  tags to specify an index.">>
 else
 if msg=10 then
  << princ "Upperlimit not specified.">> else
 if msg=11 then
  << princ "Upper and lower limits have not been specified.">> else
 if msg=12 then
  << princ "The degree quantifier is of no use in the product";
     princ " operator.">> else
 if msg=13 then
  << princ "The degree quantifier is not allowed in the integral";
     princ " operator.">> else
 if msg=14 then
  << princ "Variable of integration not specified.";
     princ "Please use  tags to specify variable.">>
 else
 if msg=15 then
  << princ "Incorrect use of  tags.";
     princ " Correct use:";
     terpri();
     princ
" bound_var  [ degree ] ">> else
 if msg=16 then
  << princ "Symbolic constant ";
     princ str;
     princ " was enclosed between  tags.";
     terpri();
     princ "Correct syntax:  ";
     princ str;
     princ " ";
     terpri();
     princ "or  ";
     princ "if using constants ⅈ, ⅈ, ⅇ, ⅇ or π."
  >> else
 if msg=17 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Token not allowed within  tags.";
     terpri();
     princ "Might be: <"; princ str; princ "/>.">> else
 if msg=18 then
  << princ "Unknown tag: <";
     princ str;princ ">.";
     terpri();
     princ "Not allowed within  tags.">> else
 if msg=19 then
  << princ "Undefined error!";
     princ " Token "; princ sub1 count;
     princ " is probably mispelled";
     terpri();
     princ "or unknown, ";
     princ "or the  tag is missing">> else
 if msg=20 then
  << princ "Function ";
     princ str;
     princ "()";
     princ " was not enclosed in  tags.";
     terpri();
     princ "Correct syntax: ";
     princ str;
     princ ".">> else
 if msg=21 then
  << princ "Error, division by 0">>;


 terpri();
 if FILE!*=t then close rds f;
 FILE!*:=nil;
 rederr("");
 rederr("");
 terpri();
end;

%Following function are in charge of parsing statistics related mathml.

symbolic procedure meanRD();
begin scalar b, size, args;
 args:=stats_getargs();
 b:=0;
 size:=length( args );
    while (args neq ()) do
        << b:=alg_plus(b, car args);
           args:= cdr args >>;
 return alg_quotient(b,size);
end;

symbolic procedure sdevRD(  );
begin scalar args,mean,b,size;
 args:=stats_getargs();
 mean:=alg_mean( args );
 size:=length(args);
 while(args neq ()) do
   << b:=alg_plus(b, alg_expt(alg_difference(car args, mean),2));
      args:=cdr args; >>;
 return b;
end;

symbolic procedure varRD( );
begin scalar args;
 args:=stats_getargs();
 return alg_expt(sdev( args ), 2);
end;

symbolic procedure medianRD( );
begin scalar args, siz, si;
 args:=stats_getargs();
 args:=cons('list, args);
 args:=sortl(args);
 args:=cdr args;
 si:=length args;
 siz:=si/2;
 if remainder(si,2)=0 then
return alg_quotient(alg_plus(nth(args,siz),nth(args,(siz+1))),2)
 else return nth(args, siz);
end;

algebraic procedure sortl(args);
begin scalar rr;
 rr:=sortlist(args, pred);
 if rr=nil then return sortnumlist(args)
 else return rr;
end;

symbolic procedure momentRD( );
begin scalar args,size,d,i;
 args:=stats_getargs();
if char='(d e g r e e) then
 <>) where outputhandler!* := nil;
if mode neq 'terpri then
  << % FLUID '(indent, flagg,found_int, found_compl, consts_compl, consts_int);
     % FLUID '(found_mat_int, found_mat_compl, consts_mat_int, consts_mat_compl);
     found_mat_int=0$;
     found_mat_compl=0$;
     indent:=0$
     consts_compl:=()$
     consts_mat_compl:=()$
     consts_int:=()$
     consts_mat_int:=()$
     found_int:=0$
     found_compl:=0$
     flagg:=0$
     if (PAIRP u) then <<
        if !*web=t then printout("");
         indent:=3;

        if ((car u)='setq) then
          <>
        else
           if ((car u)='list) then
             << arbitrary_c( !*a2k u );
                  listML(cdr u)>>
           else
                  if ((car u)='mat) then
                << arbitrary_c( u );
                     matrixML(cdr u)>>
              else
                     if ((car u)='!*sq) then
                      << arbitrary_c(PREPSQ (cadr u));
                       expression(PREPSQ (cadr u))>>
                 else expression(u);

             indent:=indent-3;
             close_forall();
             indent:=0;
             printout( "" );
             if !*web=t then princ(""" HEIGHT=300 WIDTH=500>");
             terpri()
        >>
     else
        if (ATOM u) then <<
           if !*web=t then printout("" );
           indent:=3;
           expression( u );
           indent:=0;
           printout( "" );
           if !*web=t then princ(" "" HEIGHT=300 WIDTH=500>");
           terpri() >>
  else ; >> >>;


%Prints out vectors.

symbolic procedure vectorML( elem );
begin;
   printout("");
   indent:=indent+3;
   multi_elem(car elem);
   indent:=indent-3;
   printout("")
end;

%Following functions print out matrices.

symbolic procedure matrixML( elem );
begin;
  if length elem=1 then vectorML( elem )
  else
  << printout("");
     indent:=indent+3;
     matrix_rows(elem);
     indent:=indent-3;
     printout("")
  >>;
end;

symbolic procedure matrix_rows( elem );
begin;
  if (elem neq()) then
     <<      printout("");
        indent:=indent+3;
        row(car elem);
          indent:=indent-3;
        printout("");
        matrix_rows( cdr elem ); >>
end;

symbolic procedure row( elem );
begin;
  if (elem neq()) then
         << expression(car elem); row(cdr elem);>>
end;

%This function searches for arbitrary integers, or complex in the reduce
%output. If so, it declares these variables in a forall statement.

symbolic procedure arbitrary_c( elem );
begin;
found_int:=nil;
found_mat_int:=nil;
found_compl:=nil;
found_mat_compl:=nil;

if (PAIRP elem) then <<
   if (car elem='mat) then
     << isarb_mat_compl(cdr elem);
        isarb_mat_int(cdr elem)>>
   else
     <<      isarb_compl(elem);
          isarb_int(elem)>>;



  if ((found_compl=1) OR (found_int=1)) then
   << flagg:=1;
      printout( "" );
      indent:=indent+3;
      print_arb_compl(elem);
      print_arb_int(elem);
      printout( "");
      indent:=indent+3;
      if ((found_compl=1) AND (found_int=1)) then
        << printout( "" );
           indent:=indent+3>>
      else
        if ((length consts_compl) > 1) then
          <<  printout( "" );
              indent:=indent+3>>
        else
           if ((length consts_int) > 1) then
             << printout( "" );
                indent:=indent+3>>;


      if (found_compl=1) then
        in_complexML( consts_compl );
      if (found_int=1) then
        in_integerML( consts_int );


      if ((found_compl=1) AND (found_int=1)) then
         << indent:=indent-3;
            printout( "" )>>
      else
          if ((length consts_compl) > 1) then
            << indent:=indent-3;
               printout( "" )>>
          else
              if ((length consts_int) > 1) then
                << indent:=indent-3;
                   printout( "" )>>;

      indent:=indent-3;
      printout( "" )>>;


  if ((found_mat_compl=1) OR (found_mat_int=1)) then
    << flagg:=1;
       printout( "" );
       indent:=indent+3;
       printarb_mat_compl(cdr elem);
       printarb_mat_int(cdr elem);
       printout( "");
       indent:=indent+3;

       if ((found_mat_compl=1) AND (found_mat_int=1)) then
         << printout( "" );
           indent:=indent+3>>
       else
          if ((length consts_mat_compl) > 1) then
            << printout( "" );
               indent:=indent+3>>
          else
             if ((length consts_mat_int) > 1) then
               << printout( "" );
                  indent:=indent+3>>;


       if (found_mat_compl=1) then
          in_complexML( consts_mat_compl );
       if (found_mat_int=1) then
          in_integerML( consts_mat_int );

       if ((found_mat_compl=1) AND (found_mat_int=1)) then
         << indent:=indent-3;
            printout( "" )>>
       else
               if ((length consts_mat_compl) > 1) then
            << indent:=indent-3;
               printout( "" )>>
          else
                 if ((length consts_mat_int) > 1) then
              << indent:=indent-3;
                 printout( "" )>>;

     indent:=indent-3;
     printout( "" )>>;
  >>
end;

symbolic procedure in_complexML( elem );
begin;
  if (elem neq ()) then <<
    printout("");
    indent:=indent+3;
    printsub2( car elem, 'compl );
    printout("");
%    printout(" C ");
    indent:=indent-3;
    printout("");
    in_complexML( cdr elem )>>;
end;


symbolic procedure in_integerML( elem );
begin;
  if (elem neq ()) then <<
    printout("");
    indent:=indent+3;
    printsub2( car elem, 'int );
    printout("");
%   printout(" Z ");
    indent:=indent-3;
    printout("");
    in_integerML( cdr elem )>>;
end;

symbolic procedure close_forall();
begin;
  if (flagg=1) then printout("");
end;

%Prints out setq statements as  statements.

symbolic procedure setqML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  expression(cadr elem);
  expression( caddr elem);
  indent:=indent-3;
  printout( "" );
end;

%Prints out lists.

symbolic procedure listML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  multilists( elem );
  indent:=indent-3;
  printout( "" );
end;

symbolic procedure multilists( elem );
begin;
 if elem neq nil then
  if ((LENGTH elem)=1) then expression (car elem)
    else <>
end;

%This function takes in a reduce expression, and parses it. It also takes
%expressions created by the above program.



symbolic procedure expression( elem );
begin scalar aa;
if (ATOM elem) then f4( elem ) else
if car elem='!:RD!: then <> else
 <<



  if (aa:=assoc(car elem, unary!*)) then <<
    if caddr aa = nil then
      apply(cadr aa, list cdr elem)
    else
      apply(cadr aa, list(cdr elem, caddr aa)) >> else
  if ((car elem)= '!*sq)  then expression (PREPSQ (cadr elem)) else
  operator_fn(elem);>>;
end;

%Prints out sum, or products.

symbolic procedure sum_prodML( elem, tty );
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 printout("");
 indent:=indent+3;
 expression( cadr elem );
 indent:=indent-3;
 printout("");
 printout("");
 indent:=indent+3;
 expression( caddr elem );
 indent:=indent-3;
 printout("");
 printout("");
 indent:=indent+3;
 expression( cadddr elem );
 indent:=indent-3;
 printout("");
 expression car elem;
 indent:=indent-3;
 printout("");
end;

%Prints out derivatives.

symbolic procedure dfml( elem );
begin scalar test;
 test:=cdr elem;
 if length test=1 OR (length test=2 AND NUMBERP cadr test) then
    printout("")
 else
    printout("");
 indent:=indent+3;
 dfargs(cdr elem);                % FJW: two statements swapped
 expression(car elem);
 indent:=indent-3;
 printout("");
end;

symbolic procedure dfargs( elem );
begin;
 if elem neq nil then
   << if length elem>1 then
      <<  if NUMBERP cadr elem then
          <");
            indent:=indent+3;
            expression car elem;
            degreeML(cadr elem);
            indent:=indent-3;
            printout("");
            dfargs(cddr elem)>>
          else
          <");
            indent:=indent+3;
            expression car elem;
            indent:=indent-3;
            printout("");
            dfargs(cdr elem)>>; >>
      else
        << printout("");
            indent:=indent+3;
           expression car elem;
            indent:=indent-3;
           printout("");
           dfargs(cdr elem)>> >>;
end;

%Prints out degree statements.

symbolic procedure degreeML( elem );
begin;
 printout("");
 indent:=indent+3;
 expression( elem );
 indent:=indent-3;
 printout("");
end;



symbolic procedure complpart( elem, tty);
begin;
 printout("<");
 princ tty;
 princ ">";
 indent:=indent+3;
 expression(car elem);
 indent:=indent-3;
 printout("");
end;

%Prints out set theory related functions.

symbolic procedure sets(elem, tty);
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 multi_elem( elem );
 indent:=indent-3;
 printout("");
end;

%Prints out relns.

symbolic procedure reln(elem, tty);
begin;
 printout("");
 princ "<"; princ tty; princ "/>";
 indent:=indent+3;
 multi_elem( elem );
 indent:=indent-3;
 printout("");
end;

%Prints out a set.

symbolic procedure setML( elem );
begin;
  printout("");
  indent:=indent+3;
  multi_elem( elem );
  indent:=indent-3;
  printout("");
end;

%Prints out unknown functions as a function. It prints out all variables
%declared a soperators.

symbolic procedure operator_fn( elem );
begin scalar asso;
asso := atsoc(car elem, '((arcsinh . sinh)(arcsech . sech)
        (arccosh . cosh)(arccsch csch) (arctanh . tanh)
        (arccoth . coth)) );
if asso then <<
   printout "";
   princ cdr asso;  >>
else <<
  printout("");
  princ car elem;
  princ "" >>;
  indent:=indent+3;
  multi_args(cdr elem);
  indent:=indent-3;
  printout("");
end;

%Reads through a list and prints out each component.

symbolic procedure multi_args( elem );
begin;
  if  (elem neq ()) then <>
end;

%Prints out all trigonometric functions which have not the same tag name,
%as reduce function.

symbolic procedure trigML(elem, type);
begin;
  printout("");
  if ((type='acos) OR (type='asin) OR (type='atan)) then
    << if (type='acos) then princ "";
       if (type='asin) then princ "";
       if (type='atan) then princ "">>;
  indent:=indent+3;
  expression(car elem);
  indent:=indent-3;
  printout("");
end;

%Prints out all unary functions such as log, or many trig functions.

symbolic procedure unary( elem, type );
begin;
  printout("");
  princ "<";
  princ type;
  princ "/>";
  indent:=indent+3;
  expression(car elem );
  indent:=indent-3;
  printout("");
end;

%Prints out logs with a base.

symbolic procedure log_baseML(elem, type);
begin;
  printout("");
  indent:=indent+3;
  printout("");
  indent:=indent+3;
  if (type='logb) then expression(cadr elem);
  if (type='log10) then f4(10);
  indent:=indent-3;
  printout("");
  expression(car elem);
  indent:=indent-3;
  printout("");
end;

%Prints out equal relns.

symbolic procedure equalML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  expression(car elem);
  expression(cadr elem);
  indent:=indent-3;
  printout( "" );
end;

%Prints out square roots.

symbolic procedure sqrtML( elem , type);
begin;
  printout( "" );
  indent:=indent+3;
  printout( " 2 " );
  expression( car elem );
  indent:=indent-3;
  printout( "" );
end;

%Prints out integrals.

symbolic procedure integralML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  expression (cadr elem);
  indent:=indent-3;
  printout( "" );
  if (length cdr elem >1) then
     << printout("");
        indent:=indent+3;
             expression( caddr elem );
           indent:=indent-3;
             printout("");
             printout("");
             indent:=indent+3;
             expression( cadddr elem );
             indent:=indent-3;
             printout("")>>;
  expression( car elem );
  indent:=indent-3;
  printout( "" );
end;

%Prints out quotients.

symbolic procedure quotientML( elem );
begin;
  if (NUMBERP car elem) AND (NUMBERP cadr elem) then <<
     if !*web=nil then printout(" ")
     else printout(" ");
     princ car elem;
     princ "  ";
     princ cadr elem;
     princ " ">>
  else <<
     printout( "" );
     indent:=indent+3;
     expression( car elem );
     expression( cadr elem );
     indent:=indent-3;
     printout( "" )>>;
end;

%Prints out all n_nary functions.

symbolic procedure n_nary( elem, type );
begin;
  if car elem = 'e AND type = 'power then unary(cdr elem, 'exp)
  else <<
    printout( "" );
    princ "<";
    princ type;
    princ "/>";
    indent:=indent+3;
    multi_elem( elem );
    indent:=indent-3;
    printout( "" )>>
end;

symbolic procedure multi_elem( elem );
begin;
   if ((length elem)=1) then expression( car elem )
       else <>
end;


symbolic procedure minusML( elem );
begin;
  printout( "" );
  indent:=indent+3;
  multiminus( elem );
  indent:=indent-3;
  printout( "" );
end;

symbolic procedure multiminus( elem );
begin;
  expression(car elem);
  if ((length elem)=2) then expression (cadr elem);
end;

%Prints out all pieces of data: i.e terminal symbols.
%They can be numbers, identifiers, or constants.

symbolic procedure f4(exp);
begin;
if (exp='pi) then
     princ ""
else if (exp='euler_gamma) then
     princ ""
else if (exp='true) then
     princ ""
else if (exp='false) then
     princ ""
else if (exp='!Na!N) then
     princ ""
else
if (exp='infinity) then
  << if !*web=nil then printout("")
     else printout("");
     princ "∞";
     princ "">>
else <<
  if (exp='e) then
   << if !*web=nil then printout("")
      else printout("");
      princ "ⅇ";
      princ "">>
else <<
   if (exp='i) then
    << if !*web=nil then printout("")
       else printout("");
       princ "ⅈ";
       princ "">>
   else <<
      if (NUMBERP exp) then
        << printout ""
                     else princ " type="real">" >>
            else
           if (FIXP exp) then
                 <"
                   else princ " type="integer">" >>
                else princ ">";
              princ exp;
                         princ "">>;
       if (IDP exp) then
         <<  printout ""
                   else princ " type="list">">>
              else
            if (vectorp exp) then
                 <"
                   else princ " type="vector">">>
             else princ ">";
            princ exp;
            princ "">>;
         >>
      >>
   >>
end;

%Functions used to print out variables with a subscript.

symbolic procedure printsub( subscript, type );
begin;
  printout("");
  indent:=indent+3;
  printout("");
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  if (type='compl) then printout( "c" );
  if (type='int) then printout( "d" );
  printout( "" );
  princ subscript;
  princ "";
  indent:=indent-3;
  printout( "" );
  indent:=indent-3;
  printout("");
  indent:=indent-3;
  printout("");
end;


symbolic procedure printsub2( subscript, type );
begin;
  printout("");
  indent:=indent+3;
  printout( "" );
  indent:=indent+3;
  if (type='compl) then  printout( "c" );
  if (type='int) then  printout( "d" );
  printout( "" );
  princ subscript;
  princ "";
  indent:=indent-3;
  printout( "" );
  indent:=indent-3;
  printout("");
end;

%Prints out expressions in math form. Plagiarised from reduce code of
%mathprint

symbolic procedure ma_print l;
begin scalar temp;
   temp:=outputhandler!*;
   outputhandler!*:=nil;
   terpri!* nil;
   if !*web=nil then maprin ""
   else maprin "";
   maprin l;
   maprin "";
   terpri!* nil;
   outputhandler!*:=temp;
end;

%Function in charge of doing all printing in order to make sure the
%indentation is always correct.

symbolic procedure printout( str );
begin;
   if !*web = nil then terpri();
   if !*web = nil then for i := 1:indent
      do << princ " " >>;
   if PAIRP str then
    <>
   else princ str;
end;

%Following functions are quite obscure. They find arbitrary constants in
%expressions and matrices. Then record them, and everytime they appear, are
%replaced with a fancy subscripts C, or D.

symbolic procedure issq( elem );
begin scalar value;
 value:=0;
        if (ATOM elem) then value:=0
           else <>
end;

symbolic procedure multi_isarb_compl( elem );
begin;
if (PAIRP elem) then <<
   if (elem=()) then
      else <> >>
end;


symbolic procedure isarb_int( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbint) then found_int:=1
     else  multi_isarb_int(cdr elem);>>
end;

symbolic procedure multi_isarb_int( elem );
begin;
if (PAIRP elem) then <<
   if (elem=()) then
      else <> >>
end;

symbolic procedure print_arb_compl( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbcomplex) then
     << if (xnp(list (cadr elem),consts_compl) eq nil) then
          << printsub(cadr elem, 'compl);
             consts_compl:=cons(cadr elem, consts_compl)>> >>
  else  multi_compl(cdr elem);>>
end;

symbolic procedure multi_compl( elem );
begin;
   if (elem=()) then
      else <>
end;


symbolic procedure print_arb_int( elem );
begin;
if (PAIRP elem) then <<
  if ((car elem)= 'arbint) then
     << if (xnp(list (cadr elem),consts_int) eq nil) then
          << printsub(cadr elem, 'int);
             consts_int:=cons(cadr elem, consts_int)>> >>
  else  multi_int(cdr elem);>>
end;

symbolic procedure multi_int( elem );
begin;
   if (elem=()) then
      else <>
end;

symbolic procedure isarb_mat_int( elem );
begin;
  if (elem neq()) then
    << isarb_row_int(car elem);
       isarb_mat_int( cdr elem ); >>
end;

symbolic procedure isarb_row_int( elem );
begin;
  if (elem neq()) then
         << if (issq(car elem)=1) then
                if (PAIRP (PREPSQ cadr (car elem))) then
                   if (car (PREPSQ cadr (car elem))='arbint) then
                         found_mat_int:=1;
           isarb_row_int(cdr elem);>>
end;


symbolic procedure isarb_mat_compl( elem );
begin;
  if (elem neq()) then
        <<
        isarb_row_compl(car elem);
        isarb_mat_compl( cdr elem ); >>
end;

symbolic procedure isarb_row_compl( elem );
begin;
  if (elem neq()) then
         << if (issq(car elem)=1) then
                if (PAIRP (PREPSQ cadr (car elem))) then
                   if (car (PREPSQ cadr (car elem))='arbcomplex) then
                         found_mat_compl:=1;
           isarb_row_compl(cdr elem);>>
end;

symbolic procedure printarb_mat_compl( elem );
begin;
  if (elem neq()) then
    << printarb_row_compl(car elem);
       printarb_mat_compl( cdr elem ); >>
end;

symbolic procedure printarb_row_compl( elem );
begin scalar value;
  if (elem neq()) then
         << if (issq(car elem)=1) then
              if (PAIRP (PREPSQ cadr (car elem))) then
                << value:=cadr PREPSQ cadr car elem;
                          if (car (PREPSQ cadr (car elem)))='arbcomplex then
                       if (xnp(list (value), consts_mat_compl) eq nil) then
                        << printsub(value, 'compl);
                            consts_mat_compl:=cons(value, consts_mat_compl)>> >>;
           printarb_row_compl(cdr elem);>>
end;


symbolic procedure printarb_mat_int( elem );
begin;
  if (elem neq()) then
        <<
        printarb_row_int(car elem);
        printarb_mat_int( cdr elem ); >>
end;

symbolic procedure printarb_row_int( elem );
begin scalar value;
  if (elem neq()) then
         << if (issq(car elem)=1) then
              if (PAIRP (PREPSQ cadr (car elem))) then
                 << value:=cadr PREPSQ cadr car elem;
                          if (car (PREPSQ cadr (car elem)))='arbint then
                       if (xnp(list (value), consts_mat_int) eq nil) then
                        << printsub(value, 'int);
                            consts_mat_int:=cons(value, consts_mat_int)>> >>;
           printarb_row_int(cdr elem);>>
end;






%Following function is the same as math_ml_printer, just that it prints out
%input given from mml, which reads from files, and not form the reduce
%normal output stream.


symbolic procedure math_ml (u);
  << % FLUID '(indent flagg found_int found_compl consts_compl
     %        consts_int !*mathprint);
     % FLUID '(found_mat_int found_mat_compl consts_mat_int
     %        consts_mat_compl);
     !*mathprint:=0;
     found_mat_int=0$;
     found_mat_compl=0$;
     indent:=0$
     consts_compl:=()$
     consts_mat_compl:=()$
     consts_int:=()$
     consts_mat_int:=()$
     found_int:=0$
     found_compl:=0$
     flagg:=0$
     if (PAIRP u) then <<
        printout("");
         indent:=3;

        if ((car u)='setq) then
          <>
        else
           if ((car u)='list) then
             << arbitrary_c( !*a2k u );
                  listML(cdr u)>>
           else
                  if ((car u)='mat) then
                << arbitrary_c( u );
                     matrixML(cdr u)>>
              else
                     if ((car u)='!*sq) then
                      << arbitrary_c(PREPSQ (cadr u));
                       expression(PREPSQ (cadr u))>>
                 else expression(u);

             indent:=indent-3;
             close_forall();
             indent:=0;
             printout( "" )
        >>
     else
        if (ATOM u) then <<
           printout( "" );
           indent:=3;
           expression( u );
           indent:=0;
           printout( "" )>>
  else ; >>;


%This function executes certain commands when switches state are changed.
%It will change the outputhandler!* when mathml is set to on or both is set
%to on. And then modify it accroding to the switches states.

symbolic procedure onoff(u,bool);
   begin scalar x,y;
      if not idp u then typerr(u,"switch")
       else if not flagp(u,'switch)
               then rerror(rlisp,25,list(u,"not defined as switch"));
      x := intern compress append(explode '!*,explode u);
      if !*switchcheck and lispeval x eq bool then return nil
       else if y := atsoc(bool,get(u,'simpfg))
        then lispeval('progn . append(cdr y,list nil));
      if bool and x eq '!*!r!a!i!s!e then x := '!*raise; % Special case.
   if x='!*web AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*web AND bool=nil then
      if !*mathml neq t then outputhandler!*:=nil;
   if x='!*mathml AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*mathml AND bool=nil then
      if !*both=nil then
        outputhandler!*:=nil;
   if x='!*both AND bool=t then
      outputhandler!*:='math_ml_printer;
   if x='!*both AND bool=nil then
      if !*mathml=nil then
        outputhandler!*:=nil
      else outputhandler!*:='math_ml_printer;

       set(x,bool);
   end;

lisp operator mml;
lisp operator parseml;

endmodule;

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathmlom.tex0000644000175000017500000000144111526203062024326 0ustar  giovannigiovanni\documentclass[11pt,a4paper]{report}
\usepackage{fancyheadings,graphics, makeidx}               
\makeindex
%\textwidth 15cm
%\textheight 21cm
%\oddsidemargin 0.5cm
%\topmargin 0cm
%\parindent 0cm
%\nofiles            

\title{MathML-OpenMath Interface\\ for REDUCE}
\author{Luis Alvarez Sobreviela}

\begin{document}

\maketitle        

\input ptitle

\tableofcontents
                    
\pagestyle{fancy}

\rhead{\thepage}

\lfoot{Luis Alvarez Sobreviela}

\rfoot{OpenMath/MathML Interface}

\cfoot{}

\setlength{\footrulewidth}{0.4pt}

\setcounter{page}{1}                    
              
\newpage

\input introduction

\input analysis

\input design

\input testing

\newpage

\input cds

%\newpage

%\input mml

%\newpage

%\input ptitle

\input bib

\end{document}

                      
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathmlom.tst0000644000175000017500000000015411526203062024340 0ustar  giovannigiovanniload mathmlom;

in "$reduce/packages/mathml/examples.mml";

in "$reduce/packages/mathml/examples.om";

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/examples.om0000755000175000017500000012400711526203062024150 0ustar  giovannigiovanni%  Description: This file contains a long list of examples demonstrating the abilities of
%               the translator. Most of these examples come straight from the CDs. They
%		were used during the development of the interface and should all be correctly
%		translated into MathML.
%
%  Version 17 April 2000
%
%  Author: Luis Alvarez Sobreviela
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

om2mml();

  
    
      
      
      
         
          1
          
      
  
       

om2mml();

  
  
  
    
  
  
    
    
  
  
       

om2mml();

  
  
  
    
    
  
  
    
    
    
      
      
    
  
  
       

om2mml();
       
  
    
    
    
      
      
    
  
       

om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
        
      
      
    
  
      

om2mml();

 
   
   
     
     
       
       
       
       
     
     
       
       
         
         
          2 
       
       
         
         
           
           
              
              
              
           
           
              
              
              
           
         
         
            
            
            
         
       
     
   
 



% The following two examples show how the translator
% can deal with matrices represented either in columns
% or rows. The translator then converts matrices
% represented in columns into ones represented in
% rows. Mapping to MathML is then possible.

om2mml();

  
    
      
        
         1 
         2 
      
      
        
         3 
         4 
      
      
        
         5 
         6 
      
  



om2mml();

  
    
      
        
         1 
         0 
      
      
        
         0 
         1 
      
  
     


om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
            
            
              
              
            
          
          
        
        
      
      
        
        
          
          
          
            
            
              
              
            
          
        
        
      
    
  



om2mml();

  
    
    
    
    
      
      
        
      
      
        
        
      
    
  

                 
% This following example will show that the translator only
% identifies the limit symbol of the limit1 CD

om2mml();

  
    
    
    
    
      
      
        
      
      
        
        
      
    
  

                 
% The following two examples show how the translator
% recognizes whether a symbol has a mathml equivalent
% depending on the CD it comes from. 

% They both use symbol 'notsubset' but from different
% CDs. Only one of them can be mapped to MathML
% and the program distinguishes it by checking if 
% the CD given is the correct one on its table
% om_mml!*.

om2mml();

 
   
   
     
      2 
      3 
      3 
   
   
     
        1 
        2 
        3 
   
  
    


om2mml();

 
   
   
     
      2 
      3 
      3 
   
   
     
        1 
        2 
        3 
   
  
    



om2mml();

  
    
    
      
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  


% Example of a symbol which has a MathML equivalent
% but under another name.

om2mml();

  
    
         1 
  
  


om2mml();

  
    
    
      
      
    
    
  
    



om2mml();

  
    
    
      
      
        
        
          
          
        
      
      
    
    
  

                 


om2mml();

  
    
    
      
         3 
         6 
         9 
    
    
      
         3 
         6 
         9 
    
  
     

om2mml();

  
    
    
      
         3 
         6 
         9 
    
    
      
         3 
         6 
         9 
    
  
     



om2mml();

   
       
       
         
       
       
         
         
           
           
           
         
         
      
   
  



om2mml();

  
     
     
       
     
     
       
       
         
         
         
       
       
     
   
   


om2mml();

  
    
    
      
      
      
      
    
    
      
      
      
        
        
        
      
    
  
   


% The integral symbols defint and int are ambigious as defined
% in the CDs. They do not specify their variable of integration
% explicitly. The following shows that when the function
% to integrate is defined as a lambda expression, then the
% bound variable is easily determined. However, in other
% cases, it is not possible to determine the bound variable.

om2mml();

 
    
    
      
      
        
      
      
        
        
      
    
  
        

om2mml();

  
    
    
     
      
      
    
  


% Some calculus

om2mml();

  
    
    
      
      
        
        
          
        
        
          
          
          
        
      
    
    
  



om2mml();

       
         
           
             
             
               
                1 
                3 
             
             
               
               
                 
                 
                 
               
               
                 
                 
                 
                 
               
             
           
         
       



om2mml();

  
     
     
       
       
     
     
       
       
         
          1 
         
       
       
         
         
           
         
         
      
    
  


                        
om2mml();

  
    
    
      
      
        
      
      
        
        
          
          
            
            
            
          
          
        
        
          
          
            
            
            
          
          
        
        
          
          
          
            
            
            
          
        
      
    
  






om2mml();

  
    
    
      
    
    
      
      
      
    
  

                  


om2mml();

  
    
    
      
       1 
       9 
       5 
    
     9 
  


% The following examples belong to the multiset CD

om2mml();

  
    
    
      
      
        
        
        
      
      
        
        
        
      
    
    
      
      
      
        
        
        
      
    
  



om2mml();

  
    
     4 
     1 
     0 
     1 
     4 
  


om2mml();

  
    
    
      
      
        
        
        
      
      
    
    
      
      
        
        
        
      
      
    
  


     
om2mml();

  
    
    
      
      
      
        
        
        
      
    
    
      
      
      
        
        
        
      
    
  



om2mml();

  
    
    
      
      
      
    
    
      
      
        
        
        
          
          
          
        
      
      
        
        
          
          
          
        
        
          
          
          
        
      
        
  


om2mml();

  
    
    
      
      
      
    
    
  


om2mml();

  
    
    
      
      
        
        
        
      
      
        
        
        
      
    
    
      
      
      
    
  


om2mml();

  
    
     4 
    
      
       1 
       1 
       2 
       3 
    
  


om2mml();

  
    
    
      
       2 
       3 
    
    
      
       2 
       2 
       3 
    
  



om2mml();

  
    
    
      
       2 
       3 
       3 
    
    
      
       1 
       2 
       3 
    
  



om2mml();

  
    
    
      
       1 
       2 
       1 
    
    
      
       1 
       2 
       1 
    
  


% Examples from CD nums1

om2mml();

  
    
     8 
    
      
       8 
       10 
    
  



om2mml();

  
    
     1 
     2 
  



om2mml();

 
   
   
             
     
   
   
     
     
       
       
       
     
     
       
       
       
         
         
         
       
     
   
 



om2mml();


  
  
    
    
    
    
  
  
    
    
      
      
        
        
          
          
          
            
            
          
        
        
      
      
        
        
          
          
          
            
            
          
        
        
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  




om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
          
        
        
          
          
          
        
      
      
        
        
          
          
          
        
        
          
          
          
            
            
            
              
               2 
              
              
            
          
        
      
    
  


om2mml();

  
    
    
    
      
      
        
        
        
      
      
        
        
          
        
        
          
          
          
            
            
          
        
      
    
  



om2mml();

  
    
    
      
      
       2 
    
    
      
      
    
  



om2mml();

  
    
    
      
      
    
    
      
      
      
        
        
          
          
          
        
      
    
  



om2mml();

  
    
    
      
      
    
    
      
      
      
        
        
          
          
          
        
      
    
  


om2mml();

  
    
    
      
      
      
    
    
      
      
      
    
  


om2mml();

  
    
    
    
  


om2mml();

  
    
    
    
      
      
        
        
        
      
      
        
        
          
        
        
          
          
            
            
            
              
              
                
                 4 
                
              
              
            
          
          
            
            
            
              
              
                
                 4 
                
              
              
            
          
        
      
    
  


om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
            
            
          
          
        
        
       
       
         
         
         
           
           
         
       
     
  




om2mml();

  
    
    
      
       1   2   3 
    
     3 
  




om2mml();

  
     
      
      
      
     
      
      
     
     
      
      
     
     
     
   




om2mml();

  
    
    
      
      
        
        
        
      
      
    
    
      
      
        
        
        
      
      
    
  


om2mml();

  
    
    
      
      
        
        
      
      
        
        
          
          
        
      
    
    
      
      
        
        
          
          
        
      
      
    
  





om2mml();

  
    
    
      
      
    
    
      
      
        
        
          
           1 
           0 
           0 
        
        
          
          
            
             1 
          
          
        
      
      
        
        
          
           0 
           1 
           0 
        
        
          
          
            
             2 
          
          
        
      
      
        
        
          
           0 
           0 
           1 
        
        
          
          
            
             3 
          
          
        
      
    
  



om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
        
        
          
          
        
      
      
        
        
          
          
        
        
      
    
  



om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
        
      
      
    
 


% An example of elements which do not have a MathML 
% equivalent. This example comes from the fns1 CD

om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
            
             1 
            
            
          
        
      
      
        
        
        
          
          
            
            
             1 
          
        
         2 
      
    
  



om2mml();

  
    
    
      
      
        
        
      
    
    
  



om2mml();

  
    
    
      
      
        
        
          
           0 
           1 
        
        
          
           2 
           3 
        
      
    
    
      
      
        
         0 
         2 
      
      
        
         1 
         3 
      
    
  




om2mml();

  
    
    
      
      
      
    
    
      
      
        
        
        
      
      
        
        
        
      
    
  

om2mml();

  
    
      
      
    
    
  


% Examples of assigning types to variables.

om2mml();
      
         
           
              
              
           
           
         
       

om2mml();
       
         
           
              
              
           
           
         
       

om2mml();
       
         
           
              
              
           
           
         
       


% These examples show the use of attributions within OpenMath
% expressions.


om2mml();

   
     
       
          
          
       
       
     
     1
     2
     3
   


om2mml();

  
    
    
      
        
        
      
    
    
    
      
      
    
  
   


om2mml();

  
    
    2
    
      
       3 
       6 
       9 
         
  


om2mml();

  
    
    2
    
      
       0 
       1 
       0 
         
  



om2mml();

  
    
    
      
    
    
      
      
        
        
          
          
            
            
              
              
            
            
              
              
            
          
          
        
        
          
          
            
            
          
          
            
            
          
        
      
      
        
        
          
          
          
            
            
              
              
            
            
              
              
            
          
        
        
          
          
            
            
          
          
            
            
          
        
      
    
  



om2mml();

   
      
       1 
      
        
          
          
        
        
              
        


om2mml();

   
      
       1 
       1 
      
        
          
          
        
        
              
        



% The following two examples were produced by REDUCE in MathML with the
% MathML interface, then translated to OpenMath. It is now possible to
% translate them back to MathML.

om2mml();

  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                
              
            
            
              
              
                
                
                  
                  
                    
                    
                      
                    
                    
                      
                      
                      
                    
                  
                
                
                                            
            
            
            
          
          
          
        
      
      
        
        
        
          
          
          
        
      
    
  
      




om2mml();

  
    
    
      
      
        
        
        
          
            
              
              
            
            
          
          
            
            
              
              
                
                
                  
                  
                  
                
              
              
            
            
              
              
                
                
                
              
            
            
              
              
              
                
                
                 1 
              
            
            
              
                                               
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
                
                
                 2 
              
            
            
              
              
                
                
                  
                  
                    
                  
                  
                    
                    
                    
                  
                
              
              
            
          
          
          
        
      
      
        
        
        
      
    
  
                     
om2mml();

 
    
       
       
    
     0   
  


om2mml();

  
    
      
      
    
      
  


om2mml();
 
  
    
    
    
   
 

om2mml();
 
  
    
    
    
   
 

om2mml();
 
  
    
    
    
   
 

om2mml();
 
  
    
    4
    2
   
 

om2mml();
 
  
    
    4
    2
   
 

om2mml();
 
  
    
    4
    2
   
 

end;
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathml.rlg0000644000175000017500000000324411527635055023775 0ustar  giovannigiovanniFri Feb 18 21:28:09 2011 run on win32
on mathml;

 % output

sin (x);



   
      x
   



(x + y)^5;



   
      
         x
         5
      
      
         5
         
            x
            4
         
         y
      
      
         10
         
            x
            3
         
         
            y
            2
         
      
      
         10
         
            x
            2
         
         
            y
            3
         
      
      
         5
         x
         
            y
            4
         
      
      
         y
         5
      
   



off mathml;




parseml();

 
 
3 
5 
 


8
 

operator gt;



 % MathML 1.x form
parseml();



x
y



x>y


 % MathML 2.x form
parseml();



x
y



x>y


end;


Time for test: 1 ms
@@@@@ Resources used: (0 0 2 0)
mathpiper-0.81f+svn4469+dfsg3/src/packages/mathml/mathml.tex0000644000175000017500000004001211526203062023767 0ustar  giovannigiovanni\documentclass{article}
\title{REDUCE-MathML Interface}
\author{Luis Alvarez-Sobreviela \\ alvarez@zib.de \\ \\
	Konrad--Zuse--Zentrum f\"ur Informationstechnik Berlin \\
        Takustra\ss e 7 \\ D-14195 Berlin-Dahlem} 
\date{August 9, 1999}

\begin{document}

\maketitle

\section{Introduction}

MathML is intended to facilitate the use and re-use of mathematical and
scientific content on the Web, and for other applications such as computer
algebra systems. For this reason we believe MathML is an important step
for the scientific community considering the widespread use of the
Internet. We found necessary to include REDUCE in this trend, and
developed the MathML-REDUCE interface.

The MathML interface for REDUCE provides an easy to use series of
commands, allowing it to evaluate and output MathML. This manual is
therefore intended to give the user a good guideline on how to make of it a
proper use. 
\\

The principal features of this package can be resumed as:  
\begin{itemize}
\item Evaluation of MathML code. Allows REDUCE to parse MathML expressions
and evaluate them. 
\item Generation of MathML compliant code. Provides the printing of REDUCE
expressions in MathML source code, to be used directly in web page
production. 

\item Generation of MathML code surrounded by HTML $<$embed$>$$<$/embed$>$
tags. This is useful for directly including MathML into a webpage. It can
then easily be rendered on any browser with the IBM Tech Explorer plug-in
\footnote{Currently available at
http://www.software.ibm.com/network/techexplorer/}. 

\end{itemize}

We assume that the reader is familiar with MathML 1.0. If not, the
specification. is available at: \\

{\tt http://www.w3.org/Math/ }

\section{Getting Started}

\subsection{Loading}

The MathML-REDUCE interface package is under the name {\tt mathml}, and so is
loaded by supplying {\tt load mathml;}.

\subsection{Switches}

There are three switches which can be used alternatively and
incrementally.  These are {\bf mathml}, {\bf web} and {\bf both}. There
use can be described as follows:

\begin{description}
\item[{\tt mathml}:] All output will be printed in MathML.
\item[{\tt both}:] All output will be printed in both MathML and normal
REDUCE.

\item[{\tt web}:] All output will be printed within an HTML $$ tag. 
This is for direct use in an HTML web page when using IBM Tech Explorer.
\end{description}

MathML has often been said to be too verbose. If {\bf both} is on, an easy
interpretation of the results is possible, improving MathML readability.

\subsection{Entering MathML}

The MathML-REDUCE interface gives the user various ways of providing
input. This can be done via a file containing MathML or by writing MathML
directly in the prompt. \\

\subsubsection{Reading MathML from a File: {\tt MML}}

When reading from a file the command {\bf mml} is used. {\bf mml} takes as
argument the name of the file containing the MathML. \\

{\tt mml}(FILE:{\it string}):{\it expression} 

\paragraph{Example:} As long as the file given contains valid MathML, no
errors should be produced.  

{\tt 1:  mml "ex.mml";}

\subsubsection{Reading MathML from Prompt: {\tt PARSEML}}

By using the function {\bf parseml} it is possible to introduce a series of
valid mathml tokens to the prompt. {\bf parseml} takes no arguments,
although once it is called it will prompt you to enter mathml tags starting
with {\tt $<$mathml$>$} and ending with {\tt $<$/mathml$>$}. It then returns
an expression resulting from evaluating the input. \\

\paragraph{Example:} Here is an extract of a REDUCE session where {\tt
parseml()} is used:\\

{\tt 2: parseml(); 

2:  

2:  

2: 3 

2: 5 

2:  

2:  
\\

\hspace*{1cm}  8 \\

3: } \\

If for some reason you do not want to continue typing in at the prompt, and
cancel what has already been typed, it is possible to exit by calling 
control {\tt C} or control {\tt D}.

Although it is simpler to edit a file and then use {\tt mml}, we still
added {\bf parseml} for completeness.     


\section{The Evaluation of MathML}

MathML is evaluated by the interface always before outputting any results.
Just in the same way as REDUCE normally does. The program works in the same
way as the {\tt algebraic} mode. Undefined variables remain undefined,
and it is possible to use all normal REDUCE switches and packages.

\paragraph{Example:}

\noindent The following MathML:\\
\\
{\tt 
\hspace*{0mm}

\hspace*{1mm}

\hspace*{6mm}x

\hspace*{6mm}y

\hspace*{1mm}
\\
\hspace*{0mm}}
\\
\\
will evaluate to {\tt gt(x,y)}. This only states that x is greater than
y.
\\
The interesting characteristic, is that we can set the undefined values of
x and y.
\\
Suppose we enter the following:
\\

{\tt 5: x:=3; y:=2;
\\

x := 3
\\

y := 2}
\\
\\
If we once again enter and evaluate the above piece of MathML we will have as
result:
\\

{\tt t}
\\
\\
because it is true that 3 is greater than 2. It is important to note that
it is also possible to set only one of the two variables x or y above, say
{\tt y:=4}. The expression will then not evaluate completely, and we will
have:  \\

{\tt gt(x,4)}
\\
\\
When one of the switches is on, the MathML output will be:
\\
\\
{\tt 
\hspace*{1mm}\\
\hspace*{5mm}   \\
\hspace*{9mm}      x\\
\hspace*{9mm}      4\\
\hspace*{5mm}   \\
\hspace*{1mm}\\}

Hence, it is possible when dealing with a MathML formula representation in
which there are a set of undefined variables to set each variable to the
desired value and evaluate it. Let us consider a second example to make sure
everything is clear.

\paragraph{Example:}

Let the file {\tt ex.mml} contain the following mathml:
\\
\\
{\tt               \\
\hspace*{2mm}       \\
\hspace*{5mm}        \\
\hspace*{9mm}         x\\
\hspace*{5mm}        \\
\hspace*{5mm}        F\\
\hspace*{9mm}         x\\
\hspace*{5mm}        \\
\hspace*{2mm}       \\
                  }  \\
\\
If we do the following:\\

{\tt 1: mml "ex.mml";}\\
\\
This is what we get:
\\
\\
{\tt int(f(x),x);}\\
\\
It is clear that this has remained unevaluated. We can now set the function
{\tt f(x)} as follows:\\

{\tt for all x let f(x)=2*x**2;}\\
\\
If we then enter '{\tt mml "ex.mml"}' once again, we will have the
following result:\\

{\Large \( \frac {2*x^{3}}{3}\)}
\\
\\
Hence the MathML-REDUCE interface allows the user to set a value to a
variable in order to manipulate the evaluation of the MathML, without needing
to edit the MathML itself.

\subsection{Using Boolean Values}

Boolean values are not defined in MathML, despite their importance in REDUCE.
To get around this problem, we can set a variable's value to a boolean value,
and when evaluating, the MathML-REDUCE interface will use the boolean value
of the variable.
\\
Suppose we want to evaluate the following expression:
\\
\\
{\tt and(t,nil);}
\\
\\
Then all we do, is we create a file with the following MathML:
\\
\\
{\tt          $<$mathml$>$\\
\hspace*{2mm} $<$apply$>$$<$and/$>$\\
\hspace*{5mm}         $<$ci$>$ a $<$/ci$>$\\
\hspace*{5mm}         $<$ci$>$ b $<$/ci$>$\\
\hspace*{2mm}      $<$/apply$>$\\
        $<$/mathml$>$\\}
\\
And before evaluating it, we set {\tt a} to {\tt true} and {\tt b} to {\tt
nil}. When evaluating the MathML, it will produce the same result as the
equivalent REDUCE expression.

\section{Interpretation of Error Messages}

The MathML-REDUCE interface has a set of error messages which aim to help the
user understand and correct any invalid MathML. Because there can exist many
different causes of errors, such error messages should be considered merely
as advice. Here we shall consider the most important error messages.

\paragraph{Missing tag:}

Many MathML tags go by pairs, such as {\tt $<$apply$>$$<$/apply$>$,
$<$reln$>$$<$/reln$>$}, {\tt $<$ci$>$$<$/ci$>$}, etc\ldots. In the
case
where the ending tag is missed out, or misspelled, it is very probable that an
error of this type will be thrown. 

\paragraph{Ambiguous or Erroneous Use of {\tt $<$apply$>$}}

This error message defines an undefined error. When this error message
appears, it is not very clear to the interface where exactly lies the error. 
Probable causes are a misuse of the {\tt $<$apply$>$$<$/apply$>$} tags, or a
mispelling of the tag preceding the {\tt $<$apply$>$}. However, other types
of errors may cause this error message to appear. 

Tags following an {\tt $<$apply$>$} tag may be misspelled without causing an
error message, but they will be considered as operators by REDUCE and
therefore evaluate to some unexpected expression.

\paragraph{Syntax Errors}

It is possible that the input MathML is not syntactically correct. In such
a situation, the error will be spotted, and in some cases a solution might be
presented. There are a variety of syntax errors messages, but relying on
their advice might not always be helpful. 
\\

Despite the verbose nature of the error messages and their recommended
solutions, we do recommend that in most situations reference to the MathML
specification is made. 

\section{Limitations of the Interface}

Not all aspects of MathML have been perfectly fitted into the interface.
There are still some problems unsolved in the present version of the
interface:

\begin{itemize} 
\item MathML Presentation Markup is not supported. The
interface will treat every presentation tag as an unknown tag, or a REDUCE
operator. We found presentation markup not prioritary when dealing with
computer algebra systems, although in the future, parsing of presentation
markup within content markup shall be supported.  
\item Certain MathML tags
do not play an important role in the REDUCE environment. Such tags will not
evaluate or affect in anyway the interface's behaviour. They will be parsed
correctly, although their action will be ignored. These tags are: 
\begin{enumerate} 
{\tt 
\item $<$interval$><$/interval$>$ 
\item $<$inverse$><$/inverse$>$ 
\item $<$condition$><$/condition$>$ 
\item $<$compose$><$/compose$>$ 
\item $<$ident$><$/ident$>$ 
\item $<$forall/$>$
\item $<$exists/$>$} 
\end{enumerate} 

Although {\tt $<$condition$><$/condition$>$} and {\tt
$<$interval$><$/interval$>$} tags are supported when used within the
following tags:  
\begin{enumerate} 
{\tt 
\item $<$int/$>$ 
\item $<$limit/$>$
\item $<$sum/$>$ 
\item $<$product/$>$} 
\end{enumerate} 
\item The {\tt $<$declare$>$} construct takes one or two arguments. It sets
the first argument to the value of the second. In the case where the second
argument is a vector or a matrix, an obscure error message is produced. It is
clearly something which must be fixed in the future.\\ \item The program
throws an error when it encounters {\tt nil} between {\tt $<$ci$><$/ci$>$}
tags. It is not possible to use boolean values directly.  Please refer to the
above subsection treating this matter.  
\end{itemize}

\section{Including MathML into a Webpage}

We shall not get into the details of including MathML in the design of a
web page, but it is important for completeness, to give a quick overview.
One can include MathML in two ways:

\begin{itemize} 

\item By introducing MathML inside $<$math$>$$<$/math$>$ tags in any HTML 
page.

\item By having MathML being embeded inside HTML $<$embed$>$$<$/embed$>$
tags. 

\end{itemize} 

When one has the {\bf mathml} switch on, MathML is generated inside
$<$math$>$$<$/math$>$ tags. Browsers such as WebEQ \footnote{Available at
http://www.webeq.com}can read this type of encoding. 

\paragraph{Example:}
\begin{verbatim} 


MathML example

Solution ",solcount," to problem ",prind,"

"$terpri()$ write"
"$terpri()$ if cadr backup_ then <Remaining equations | "$ terpri()>>$ write"Expressions | "$terpri()$ write"Parameters | "$terpri()$ write"Relevance | "$terpri()$ write"Back to problem ",prind," "$ write"